diff --git a/Bytecodes.h b/Bytecodes.h new file mode 100644 --- /dev/null +++ b/Bytecodes.h @@ -0,0 +1,230 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 1998-2009 + * + * Bytecode definitions. + * + * ---------------------------------------------------------------------------*/ + +/* -------------------------------------------------------------------------- + * Instructions + * + * Notes: + * o CASEFAIL is generated by the compiler whenever it tests an "irrefutable" + * pattern which fails. If we don't see too many of these, we could + * optimise out the redundant test. + * ------------------------------------------------------------------------*/ + +/* NOTE: + + THIS FILE IS INCLUDED IN HASKELL SOURCES (ghc/compiler/GHC/ByteCode/Asm.hs). + DO NOT PUT C-SPECIFIC STUFF IN HERE! + + I hope that's clear :-) +*/ + +#define bci_STKCHECK 1 +#define bci_PUSH_L 2 +#define bci_PUSH_LL 3 +#define bci_PUSH_LLL 4 +#define bci_PUSH8 5 +#define bci_PUSH16 6 +#define bci_PUSH32 7 +#define bci_PUSH8_W 8 +#define bci_PUSH16_W 9 +#define bci_PUSH32_W 10 +#define bci_PUSH_G 11 +#define bci_PUSH_ALTS_P 13 +#define bci_PUSH_ALTS_N 14 +#define bci_PUSH_ALTS_F 15 +#define bci_PUSH_ALTS_D 16 +#define bci_PUSH_ALTS_L 17 +#define bci_PUSH_ALTS_V 18 +#define bci_PUSH_PAD8 19 +#define bci_PUSH_PAD16 20 +#define bci_PUSH_PAD32 21 +#define bci_PUSH_UBX8 22 +#define bci_PUSH_UBX16 23 +#define bci_PUSH_UBX32 24 +#define bci_PUSH_UBX 25 +#define bci_PUSH_APPLY_N 26 +#define bci_PUSH_APPLY_F 27 +#define bci_PUSH_APPLY_D 28 +#define bci_PUSH_APPLY_L 29 +#define bci_PUSH_APPLY_V 30 +#define bci_PUSH_APPLY_P 31 +#define bci_PUSH_APPLY_PP 32 +#define bci_PUSH_APPLY_PPP 33 +#define bci_PUSH_APPLY_PPPP 34 +#define bci_PUSH_APPLY_PPPPP 35 +#define bci_PUSH_APPLY_PPPPPP 36 +/* #define bci_PUSH_APPLY_PPPPPPP 37 */ +#define bci_SLIDE 38 +#define bci_ALLOC_AP 39 +#define bci_ALLOC_AP_NOUPD 40 +#define bci_ALLOC_PAP 41 +#define bci_MKAP 42 +#define bci_MKPAP 43 +#define bci_UNPACK 44 +#define bci_PACK 45 +#define bci_TESTLT_I 46 +#define bci_TESTEQ_I 47 +#define bci_TESTLT_F 48 +#define bci_TESTEQ_F 49 +#define bci_TESTLT_D 50 +#define bci_TESTEQ_D 51 +#define bci_TESTLT_P 52 +#define bci_TESTEQ_P 53 +#define bci_CASEFAIL 54 +#define bci_JMP 55 +#define bci_CCALL 56 +#define bci_SWIZZLE 57 +#define bci_ENTER 58 +#define bci_RETURN_P 60 +#define bci_RETURN_N 61 +#define bci_RETURN_F 62 +#define bci_RETURN_D 63 +#define bci_RETURN_L 64 +#define bci_RETURN_V 65 +#define bci_BRK_FUN 66 +#define bci_TESTLT_W 67 +#define bci_TESTEQ_W 68 + +#define bci_RETURN_T 69 +#define bci_PUSH_ALTS_T 70 + +#define bci_TESTLT_I64 71 +#define bci_TESTEQ_I64 72 +#define bci_TESTLT_I32 73 +#define bci_TESTEQ_I32 74 +#define bci_TESTLT_I16 75 +#define bci_TESTEQ_I16 76 +#define bci_TESTLT_I8 77 +#define bci_TESTEQ_I8 78 +#define bci_TESTLT_W64 79 +#define bci_TESTEQ_W64 80 +#define bci_TESTLT_W32 81 +#define bci_TESTEQ_W32 82 +#define bci_TESTLT_W16 83 +#define bci_TESTEQ_W16 84 +#define bci_TESTLT_W8 85 +#define bci_TESTEQ_W8 86 + +#define bci_PRIMCALL 87 + +#define bci_BCO_NAME 88 + +#define bci_OP_ADD_64 90 +#define bci_OP_SUB_64 91 +#define bci_OP_AND_64 92 +#define bci_OP_XOR_64 93 +#define bci_OP_NOT_64 94 +#define bci_OP_NEG_64 95 +#define bci_OP_MUL_64 96 +#define bci_OP_SHL_64 97 +#define bci_OP_ASR_64 98 +#define bci_OP_LSR_64 99 +#define bci_OP_OR_64 100 + +#define bci_OP_NEQ_64 110 +#define bci_OP_EQ_64 111 +#define bci_OP_U_GE_64 112 +#define bci_OP_U_GT_64 113 +#define bci_OP_U_LT_64 114 +#define bci_OP_U_LE_64 115 +#define bci_OP_S_GE_64 116 +#define bci_OP_S_GT_64 117 +#define bci_OP_S_LT_64 118 +#define bci_OP_S_LE_64 119 + + +#define bci_OP_ADD_32 130 +#define bci_OP_SUB_32 131 +#define bci_OP_AND_32 132 +#define bci_OP_XOR_32 133 +#define bci_OP_NOT_32 134 +#define bci_OP_NEG_32 135 +#define bci_OP_MUL_32 136 +#define bci_OP_SHL_32 137 +#define bci_OP_ASR_32 138 +#define bci_OP_LSR_32 139 +#define bci_OP_OR_32 140 + +#define bci_OP_NEQ_32 150 +#define bci_OP_EQ_32 151 +#define bci_OP_U_GE_32 152 +#define bci_OP_U_GT_32 153 +#define bci_OP_U_LT_32 154 +#define bci_OP_U_LE_32 155 +#define bci_OP_S_GE_32 156 +#define bci_OP_S_GT_32 157 +#define bci_OP_S_LT_32 158 +#define bci_OP_S_LE_32 159 + + +#define bci_OP_ADD_16 170 +#define bci_OP_SUB_16 171 +#define bci_OP_AND_16 172 +#define bci_OP_XOR_16 173 +#define bci_OP_NOT_16 174 +#define bci_OP_NEG_16 175 +#define bci_OP_MUL_16 176 +#define bci_OP_SHL_16 177 +#define bci_OP_ASR_16 178 +#define bci_OP_LSR_16 179 +#define bci_OP_OR_16 180 + +#define bci_OP_NEQ_16 190 +#define bci_OP_EQ_16 191 +#define bci_OP_U_GE_16 192 +#define bci_OP_U_GT_16 193 +#define bci_OP_U_LT_16 194 +#define bci_OP_U_LE_16 195 +#define bci_OP_S_GE_16 196 +#define bci_OP_S_GT_16 197 +#define bci_OP_S_LT_16 198 +#define bci_OP_S_LE_16 199 + + +#define bci_OP_ADD_08 200 +#define bci_OP_SUB_08 201 +#define bci_OP_AND_08 202 +#define bci_OP_XOR_08 203 +#define bci_OP_NOT_08 204 +#define bci_OP_NEG_08 205 +#define bci_OP_MUL_08 206 +#define bci_OP_SHL_08 207 +#define bci_OP_ASR_08 208 +#define bci_OP_LSR_08 209 +#define bci_OP_OR_08 210 + +#define bci_OP_NEQ_08 220 +#define bci_OP_EQ_08 221 +#define bci_OP_U_GE_08 222 +#define bci_OP_U_GT_08 223 +#define bci_OP_U_LT_08 224 +#define bci_OP_U_LE_08 225 +#define bci_OP_S_GE_08 226 +#define bci_OP_S_GT_08 227 +#define bci_OP_S_LT_08 228 +#define bci_OP_S_LE_08 229 + +#define bci_OP_INDEX_ADDR_08 240 +#define bci_OP_INDEX_ADDR_16 241 +#define bci_OP_INDEX_ADDR_32 242 +#define bci_OP_INDEX_ADDR_64 243 + + +/* If you need to go past 255 then you will run into the flags */ + +/* If you need to go below 0x0100 then you will run into the instructions */ +#define bci_FLAG_LARGE_ARGS 0x8000 + +/* If a BCO definitely requires less than this many words of stack, + don't include an explicit STKCHECK insn in it. The interpreter + will check for this many words of stack before running each BCO, + rendering an explicit check unnecessary in the majority of + cases. */ +#define INTERP_STACK_CHECK_THRESH 50 + +/*-------------------------------------------------------------------------*/ diff --git a/ClosureTypes.h b/ClosureTypes.h new file mode 100644 --- /dev/null +++ b/ClosureTypes.h @@ -0,0 +1,93 @@ +/* ---------------------------------------------------------------------------- + * + * (c) The GHC Team, 1998-2005 + * + * Closure Type Constants: out here because the native code generator + * needs to get at them. + * + * -------------------------------------------------------------------------- */ + +#pragma once + +/* + * WARNING WARNING WARNING + * + * If you add or delete any closure types, don't forget to update the following, + * - the closure flags table in rts/ClosureFlags.c + * - isRetainer in rts/RetainerProfile.c + * - the closure_type_names list in rts/Printer.c + * - the ClosureType sum type in libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs + */ + +/* CONSTR/THUNK/FUN_$A_$B mean they have $A pointers followed by $B + * non-pointers in their payloads. + */ + +/* Object tag 0 raises an internal error */ +#define INVALID_OBJECT 0 +#define CONSTR 1 +#define CONSTR_1_0 2 +#define CONSTR_0_1 3 +#define CONSTR_2_0 4 +#define CONSTR_1_1 5 +#define CONSTR_0_2 6 +#define CONSTR_NOCAF 7 +#define FUN 8 +#define FUN_1_0 9 +#define FUN_0_1 10 +#define FUN_2_0 11 +#define FUN_1_1 12 +#define FUN_0_2 13 +#define FUN_STATIC 14 +#define THUNK 15 +#define THUNK_1_0 16 +#define THUNK_0_1 17 +#define THUNK_2_0 18 +#define THUNK_1_1 19 +#define THUNK_0_2 20 +#define THUNK_STATIC 21 +#define THUNK_SELECTOR 22 +#define BCO 23 +#define AP 24 +#define PAP 25 +#define AP_STACK 26 +#define IND 27 +#define IND_STATIC 28 +#define RET_BCO 29 +#define RET_SMALL 30 +#define RET_BIG 31 +#define RET_FUN 32 +#define UPDATE_FRAME 33 +#define CATCH_FRAME 34 +#define UNDERFLOW_FRAME 35 +#define STOP_FRAME 36 +#define BLOCKING_QUEUE 37 +#define BLACKHOLE 38 +#define MVAR_CLEAN 39 +#define MVAR_DIRTY 40 +#define TVAR 41 +#define ARR_WORDS 42 +#define MUT_ARR_PTRS_CLEAN 43 +#define MUT_ARR_PTRS_DIRTY 44 +#define MUT_ARR_PTRS_FROZEN_DIRTY 45 +#define MUT_ARR_PTRS_FROZEN_CLEAN 46 +#define MUT_VAR_CLEAN 47 +#define MUT_VAR_DIRTY 48 +#define WEAK 49 +#define PRIM 50 +#define MUT_PRIM 51 +#define TSO 52 +#define STACK 53 +#define TREC_CHUNK 54 +#define ATOMICALLY_FRAME 55 +#define CATCH_RETRY_FRAME 56 +#define CATCH_STM_FRAME 57 +#define WHITEHOLE 58 +#define SMALL_MUT_ARR_PTRS_CLEAN 59 +#define SMALL_MUT_ARR_PTRS_DIRTY 60 +#define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61 +#define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62 +#define COMPACT_NFDATA 63 +#define CONTINUATION 64 +#define ANN_FRAME 65 +#define N_CLOSURE_TYPES 66 diff --git a/CodeGen.Platform.h b/CodeGen.Platform.h new file mode 100644 --- /dev/null +++ b/CodeGen.Platform.h @@ -0,0 +1,1329 @@ + +import GHC.Cmm.Expr +#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ + || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64) \ + || defined(MACHREGS_riscv64) || defined(MACHREGS_loongarch64)) +import GHC.Utils.Panic.Plain +#endif +import GHC.Platform.Reg + +#include "MachRegs.h" + +#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) + +# if defined(MACHREGS_i386) +# define eax 0 +# define ebx 1 +# define ecx 2 +# define edx 3 +# define esi 4 +# define edi 5 +# define ebp 6 +# define esp 7 +# endif + +# if defined(MACHREGS_x86_64) +# define rax 0 +# define rbx 1 +# define rcx 2 +# define rdx 3 +# define rsi 4 +# define rdi 5 +# define rbp 6 +# define rsp 7 +# define r8 8 +# define r9 9 +# define r10 10 +# define r11 11 +# define r12 12 +# define r13 13 +# define r14 14 +# define r15 15 +# endif + + +-- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence +-- being assigned the same RegNos. +# define xmm0 16 +# define xmm1 17 +# define xmm2 18 +# define xmm3 19 +# define xmm4 20 +# define xmm5 21 +# define xmm6 22 +# define xmm7 23 +# define xmm8 24 +# define xmm9 25 +# define xmm10 26 +# define xmm11 27 +# define xmm12 28 +# define xmm13 29 +# define xmm14 30 +# define xmm15 31 + +# define ymm0 16 +# define ymm1 17 +# define ymm2 18 +# define ymm3 19 +# define ymm4 20 +# define ymm5 21 +# define ymm6 22 +# define ymm7 23 +# define ymm8 24 +# define ymm9 25 +# define ymm10 26 +# define ymm11 27 +# define ymm12 28 +# define ymm13 29 +# define ymm14 30 +# define ymm15 31 + +# define zmm0 16 +# define zmm1 17 +# define zmm2 18 +# define zmm3 19 +# define zmm4 20 +# define zmm5 21 +# define zmm6 22 +# define zmm7 23 +# define zmm8 24 +# define zmm9 25 +# define zmm10 26 +# define zmm11 27 +# define zmm12 28 +# define zmm13 29 +# define zmm14 30 +# define zmm15 31 + +-- Note: these are only needed for ARM/AArch64 because globalRegMaybe is now used in CmmSink.hs. +-- Since it's only used to check 'isJust', the actual values don't matter, thus +-- I'm not sure if these are the correct numberings. +-- Normally, the register names are just stringified as part of the REG() macro + +#elif defined(MACHREGS_powerpc) || defined(MACHREGS_arm) \ + || defined(MACHREGS_aarch64) + +# define r0 0 +# define r1 1 +# define r2 2 +# define r3 3 +# define r4 4 +# define r5 5 +# define r6 6 +# define r7 7 +# define r8 8 +# define r9 9 +# define r10 10 +# define r11 11 +# define r12 12 +# define r13 13 +# define r14 14 +# define r15 15 +# define r16 16 +# define r17 17 +# define r18 18 +# define r19 19 +# define r20 20 +# define r21 21 +# define r22 22 +# define r23 23 +# define r24 24 +# define r25 25 +# define r26 26 +# define r27 27 +# define r28 28 +# define r29 29 +# define r30 30 +# define r31 31 + +-- See note above. These aren't actually used for anything except satisfying the compiler for globalRegMaybe +-- so I'm unsure if they're the correct numberings, should they ever be attempted to be used in the NCG. +#if defined(MACHREGS_aarch64) || defined(MACHREGS_arm) +# define s0 32 +# define s1 33 +# define s2 34 +# define s3 35 +# define s4 36 +# define s5 37 +# define s6 38 +# define s7 39 +# define s8 40 +# define s9 41 +# define s10 42 +# define s11 43 +# define s12 44 +# define s13 45 +# define s14 46 +# define s15 47 +# define s16 48 +# define s17 49 +# define s18 50 +# define s19 51 +# define s20 52 +# define s21 53 +# define s22 54 +# define s23 55 +# define s24 56 +# define s25 57 +# define s26 58 +# define s27 59 +# define s28 60 +# define s29 61 +# define s30 62 +# define s31 63 + +# define d0 32 +# define d1 33 +# define d2 34 +# define d3 35 +# define d4 36 +# define d5 37 +# define d6 38 +# define d7 39 +# define d8 40 +# define d9 41 +# define d10 42 +# define d11 43 +# define d12 44 +# define d13 45 +# define d14 46 +# define d15 47 +# define d16 48 +# define d17 49 +# define d18 50 +# define d19 51 +# define d20 52 +# define d21 53 +# define d22 54 +# define d23 55 +# define d24 56 +# define d25 57 +# define d26 58 +# define d27 59 +# define d28 60 +# define d29 61 +# define d30 62 +# define d31 63 + +# define q0 32 +# define q1 33 +# define q2 34 +# define q3 35 +# define q4 36 +# define q5 37 +# define q6 38 +# define q7 39 +# define q8 40 +# define q9 41 +# define q10 42 +# define q11 43 +# define q12 44 +# define q13 45 +# define q14 46 +# define q15 47 +# define q16 48 +# define q17 49 +# define q18 50 +# define q19 51 +# define q20 52 +# define q21 53 +# define q22 54 +# define q23 55 +# define q24 56 +# define q25 57 +# define q26 58 +# define q27 59 +# define q28 60 +# define q29 61 +# define q30 62 +# define q31 63 +#endif + +# if defined(MACHREGS_darwin) +# define f0 32 +# define f1 33 +# define f2 34 +# define f3 35 +# define f4 36 +# define f5 37 +# define f6 38 +# define f7 39 +# define f8 40 +# define f9 41 +# define f10 42 +# define f11 43 +# define f12 44 +# define f13 45 +# define f14 46 +# define f15 47 +# define f16 48 +# define f17 49 +# define f18 50 +# define f19 51 +# define f20 52 +# define f21 53 +# define f22 54 +# define f23 55 +# define f24 56 +# define f25 57 +# define f26 58 +# define f27 59 +# define f28 60 +# define f29 61 +# define f30 62 +# define f31 63 +# else +# define fr0 32 +# define fr1 33 +# define fr2 34 +# define fr3 35 +# define fr4 36 +# define fr5 37 +# define fr6 38 +# define fr7 39 +# define fr8 40 +# define fr9 41 +# define fr10 42 +# define fr11 43 +# define fr12 44 +# define fr13 45 +# define fr14 46 +# define fr15 47 +# define fr16 48 +# define fr17 49 +# define fr18 50 +# define fr19 51 +# define fr20 52 +# define fr21 53 +# define fr22 54 +# define fr23 55 +# define fr24 56 +# define fr25 57 +# define fr26 58 +# define fr27 59 +# define fr28 60 +# define fr29 61 +# define fr30 62 +# define fr31 63 +# endif + +#elif defined(MACHREGS_s390x) + +# define r0 0 +# define r1 1 +# define r2 2 +# define r3 3 +# define r4 4 +# define r5 5 +# define r6 6 +# define r7 7 +# define r8 8 +# define r9 9 +# define r10 10 +# define r11 11 +# define r12 12 +# define r13 13 +# define r14 14 +# define r15 15 + +# define f0 16 +# define f1 17 +# define f2 18 +# define f3 19 +# define f4 20 +# define f5 21 +# define f6 22 +# define f7 23 +# define f8 24 +# define f9 25 +# define f10 26 +# define f11 27 +# define f12 28 +# define f13 29 +# define f14 30 +# define f15 31 + +#elif defined(MACHREGS_riscv64) + +# define zero 0 +# define ra 1 +# define sp 2 +# define gp 3 +# define tp 4 +# define t0 5 +# define t1 6 +# define t2 7 +# define s0 8 +# define s1 9 +# define a0 10 +# define a1 11 +# define a2 12 +# define a3 13 +# define a4 14 +# define a5 15 +# define a6 16 +# define a7 17 +# define s2 18 +# define s3 19 +# define s4 20 +# define s5 21 +# define s6 22 +# define s7 23 +# define s8 24 +# define s9 25 +# define s10 26 +# define s11 27 +# define t3 28 +# define t4 29 +# define t5 30 +# define t6 31 + +# define ft0 32 +# define ft1 33 +# define ft2 34 +# define ft3 35 +# define ft4 36 +# define ft5 37 +# define ft6 38 +# define ft7 39 +# define fs0 40 +# define fs1 41 +# define fa0 42 +# define fa1 43 +# define fa2 44 +# define fa3 45 +# define fa4 46 +# define fa5 47 +# define fa6 48 +# define fa7 49 +# define fs2 50 +# define fs3 51 +# define fs4 52 +# define fs5 53 +# define fs6 54 +# define fs7 55 +# define fs8 56 +# define fs9 57 +# define fs10 58 +# define fs11 59 +# define ft8 60 +# define ft9 61 +# define ft10 62 +# define ft11 63 + +#elif defined(MACHREGS_loongarch64) + +# define zero 0 +# define ra 1 +# define tp 2 +# define sp 3 +# define a0 4 +# define a1 5 +# define a2 6 +# define a3 7 +# define a4 8 +# define a5 9 +# define a6 10 +# define a7 11 +# define t0 12 +# define t1 13 +# define t2 14 +# define t3 15 +# define t4 16 +# define t5 17 +# define t6 18 +# define t7 19 +# define t8 20 +# define u0 21 +# define fp 22 +# define s0 23 +# define s1 24 +# define s2 25 +# define s3 26 +# define s4 27 +# define s5 28 +# define s6 29 +# define s7 30 +# define s8 31 + +# define fa0 32 +# define fa1 33 +# define fa2 34 +# define fa3 35 +# define fa4 36 +# define fa5 37 +# define fa6 38 +# define fa7 39 +# define ft0 40 +# define ft1 41 +# define ft2 42 +# define ft3 43 +# define ft4 44 +# define ft5 45 +# define ft6 46 +# define ft7 47 +# define ft8 48 +# define ft9 49 +# define ft10 50 +# define ft11 51 +# define ft12 52 +# define ft13 53 +# define ft14 54 +# define ft15 55 +# define fs0 56 +# define fs1 57 +# define fs2 58 +# define fs3 59 +# define fs4 60 +# define fs5 61 +# define fs6 62 +# define fs7 63 + +#endif + +-- See also Note [Caller saves and callee-saves regs.] +callerSaves :: GlobalReg -> Bool +#if defined(CALLER_SAVES_Base) +callerSaves BaseReg = True +#endif +#if defined(CALLER_SAVES_R1) +callerSaves (VanillaReg 1) = True +#endif +#if defined(CALLER_SAVES_R2) +callerSaves (VanillaReg 2) = True +#endif +#if defined(CALLER_SAVES_R3) +callerSaves (VanillaReg 3) = True +#endif +#if defined(CALLER_SAVES_R4) +callerSaves (VanillaReg 4) = True +#endif +#if defined(CALLER_SAVES_R5) +callerSaves (VanillaReg 5) = True +#endif +#if defined(CALLER_SAVES_R6) +callerSaves (VanillaReg 6) = True +#endif +#if defined(CALLER_SAVES_R7) +callerSaves (VanillaReg 7) = True +#endif +#if defined(CALLER_SAVES_R8) +callerSaves (VanillaReg 8) = True +#endif +#if defined(CALLER_SAVES_R9) +callerSaves (VanillaReg 9) = True +#endif +#if defined(CALLER_SAVES_R10) +callerSaves (VanillaReg 10) = True +#endif +#if defined(CALLER_SAVES_F1) +callerSaves (FloatReg 1) = True +#endif +#if defined(CALLER_SAVES_F2) +callerSaves (FloatReg 2) = True +#endif +#if defined(CALLER_SAVES_F3) +callerSaves (FloatReg 3) = True +#endif +#if defined(CALLER_SAVES_F4) +callerSaves (FloatReg 4) = True +#endif +#if defined(CALLER_SAVES_F5) +callerSaves (FloatReg 5) = True +#endif +#if defined(CALLER_SAVES_F6) +callerSaves (FloatReg 6) = True +#endif +#if defined(CALLER_SAVES_D1) +callerSaves (DoubleReg 1) = True +#endif +#if defined(CALLER_SAVES_D2) +callerSaves (DoubleReg 2) = True +#endif +#if defined(CALLER_SAVES_D3) +callerSaves (DoubleReg 3) = True +#endif +#if defined(CALLER_SAVES_D4) +callerSaves (DoubleReg 4) = True +#endif +#if defined(CALLER_SAVES_D5) +callerSaves (DoubleReg 5) = True +#endif +#if defined(CALLER_SAVES_D6) +callerSaves (DoubleReg 6) = True +#endif +#if defined(CALLER_SAVES_L1) +callerSaves (LongReg 1) = True +#endif +#if defined(CALLER_SAVES_Sp) +callerSaves Sp = True +#endif +#if defined(CALLER_SAVES_SpLim) +callerSaves SpLim = True +#endif +#if defined(CALLER_SAVES_Hp) +callerSaves Hp = True +#endif +#if defined(CALLER_SAVES_HpLim) +callerSaves HpLim = True +#endif +#if defined(CALLER_SAVES_CCCS) +callerSaves CCCS = True +#endif +#if defined(CALLER_SAVES_CurrentTSO) +callerSaves CurrentTSO = True +#endif +#if defined(CALLER_SAVES_CurrentNursery) +callerSaves CurrentNursery = True +#endif +callerSaves _ = False + +activeStgRegs :: [GlobalReg] +activeStgRegs = [ +#if defined(REG_Base) + BaseReg +#endif +#if defined(REG_Sp) + ,Sp +#endif +#if defined(REG_Hp) + ,Hp +#endif +#if defined(REG_R1) + ,VanillaReg 1 +#endif +#if defined(REG_R2) + ,VanillaReg 2 +#endif +#if defined(REG_R3) + ,VanillaReg 3 +#endif +#if defined(REG_R4) + ,VanillaReg 4 +#endif +#if defined(REG_R5) + ,VanillaReg 5 +#endif +#if defined(REG_R6) + ,VanillaReg 6 +#endif +#if defined(REG_R7) + ,VanillaReg 7 +#endif +#if defined(REG_R8) + ,VanillaReg 8 +#endif +#if defined(REG_R9) + ,VanillaReg 9 +#endif +#if defined(REG_R10) + ,VanillaReg 10 +#endif +#if defined(REG_SpLim) + ,SpLim +#endif +#if MAX_REAL_XMM_REG != 0 +#if defined(REG_F1) + ,FloatReg 1 +#endif +#if defined(REG_D1) + ,DoubleReg 1 +#endif +#if defined(REG_XMM1) + ,XmmReg 1 +#endif +#if defined(REG_YMM1) + ,YmmReg 1 +#endif +#if defined(REG_ZMM1) + ,ZmmReg 1 +#endif +#if defined(REG_F2) + ,FloatReg 2 +#endif +#if defined(REG_D2) + ,DoubleReg 2 +#endif +#if defined(REG_XMM2) + ,XmmReg 2 +#endif +#if defined(REG_YMM2) + ,YmmReg 2 +#endif +#if defined(REG_ZMM2) + ,ZmmReg 2 +#endif +#if defined(REG_F3) + ,FloatReg 3 +#endif +#if defined(REG_D3) + ,DoubleReg 3 +#endif +#if defined(REG_XMM3) + ,XmmReg 3 +#endif +#if defined(REG_YMM3) + ,YmmReg 3 +#endif +#if defined(REG_ZMM3) + ,ZmmReg 3 +#endif +#if defined(REG_F4) + ,FloatReg 4 +#endif +#if defined(REG_D4) + ,DoubleReg 4 +#endif +#if defined(REG_XMM4) + ,XmmReg 4 +#endif +#if defined(REG_YMM4) + ,YmmReg 4 +#endif +#if defined(REG_ZMM4) + ,ZmmReg 4 +#endif +#if defined(REG_F5) + ,FloatReg 5 +#endif +#if defined(REG_D5) + ,DoubleReg 5 +#endif +#if defined(REG_XMM5) + ,XmmReg 5 +#endif +#if defined(REG_YMM5) + ,YmmReg 5 +#endif +#if defined(REG_ZMM5) + ,ZmmReg 5 +#endif +#if defined(REG_F6) + ,FloatReg 6 +#endif +#if defined(REG_D6) + ,DoubleReg 6 +#endif +#if defined(REG_XMM6) + ,XmmReg 6 +#endif +#if defined(REG_YMM6) + ,YmmReg 6 +#endif +#if defined(REG_ZMM6) + ,ZmmReg 6 +#endif +#else /* MAX_REAL_XMM_REG == 0 */ +#if defined(REG_F1) + ,FloatReg 1 +#endif +#if defined(REG_F2) + ,FloatReg 2 +#endif +#if defined(REG_F3) + ,FloatReg 3 +#endif +#if defined(REG_F4) + ,FloatReg 4 +#endif +#if defined(REG_F5) + ,FloatReg 5 +#endif +#if defined(REG_F6) + ,FloatReg 6 +#endif +#if defined(REG_D1) + ,DoubleReg 1 +#endif +#if defined(REG_D2) + ,DoubleReg 2 +#endif +#if defined(REG_D3) + ,DoubleReg 3 +#endif +#if defined(REG_D4) + ,DoubleReg 4 +#endif +#if defined(REG_D5) + ,DoubleReg 5 +#endif +#if defined(REG_D6) + ,DoubleReg 6 +#endif +#endif /* MAX_REAL_XMM_REG == 0 */ + ] + +haveRegBase :: Bool +#if defined(REG_Base) +haveRegBase = True +#else +haveRegBase = False +#endif + +-- | Returns 'Nothing' if this global register is not stored +-- in a real machine register, otherwise returns @'Just' reg@, where +-- reg is the machine register it is stored in. +globalRegMaybe :: GlobalReg -> Maybe RealReg +#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ + || defined(MACHREGS_powerpc) \ + || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) \ + || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64) \ + || defined(MACHREGS_wasm32) \ + || defined(MACHREGS_loongarch64) + +# if defined(REG_Base) +globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) +# endif +# if defined(REG_R1) +globalRegMaybe (VanillaReg 1) = Just (RealRegSingle REG_R1) +# endif +# if defined(REG_R2) +globalRegMaybe (VanillaReg 2) = Just (RealRegSingle REG_R2) +# endif +# if defined(REG_R3) +globalRegMaybe (VanillaReg 3) = Just (RealRegSingle REG_R3) +# endif +# if defined(REG_R4) +globalRegMaybe (VanillaReg 4) = Just (RealRegSingle REG_R4) +# endif +# if defined(REG_R5) +globalRegMaybe (VanillaReg 5) = Just (RealRegSingle REG_R5) +# endif +# if defined(REG_R6) +globalRegMaybe (VanillaReg 6) = Just (RealRegSingle REG_R6) +# endif +# if defined(REG_R7) +globalRegMaybe (VanillaReg 7) = Just (RealRegSingle REG_R7) +# endif +# if defined(REG_R8) +globalRegMaybe (VanillaReg 8) = Just (RealRegSingle REG_R8) +# endif +# if defined(REG_R9) +globalRegMaybe (VanillaReg 9) = Just (RealRegSingle REG_R9) +# endif +# if defined(REG_R10) +globalRegMaybe (VanillaReg 10) = Just (RealRegSingle REG_R10) +# endif +# if defined(REG_F1) +globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) +# endif +# if defined(REG_F2) +globalRegMaybe (FloatReg 2) = Just (RealRegSingle REG_F2) +# endif +# if defined(REG_F3) +globalRegMaybe (FloatReg 3) = Just (RealRegSingle REG_F3) +# endif +# if defined(REG_F4) +globalRegMaybe (FloatReg 4) = Just (RealRegSingle REG_F4) +# endif +# if defined(REG_F5) +globalRegMaybe (FloatReg 5) = Just (RealRegSingle REG_F5) +# endif +# if defined(REG_F6) +globalRegMaybe (FloatReg 6) = Just (RealRegSingle REG_F6) +# endif +# if defined(REG_D1) +globalRegMaybe (DoubleReg 1) = Just (RealRegSingle REG_D1) +# endif +# if defined(REG_D2) +globalRegMaybe (DoubleReg 2) = Just (RealRegSingle REG_D2) +# endif +# if defined(REG_D3) +globalRegMaybe (DoubleReg 3) = Just (RealRegSingle REG_D3) +# endif +# if defined(REG_D4) +globalRegMaybe (DoubleReg 4) = Just (RealRegSingle REG_D4) +# endif +# if defined(REG_D5) +globalRegMaybe (DoubleReg 5) = Just (RealRegSingle REG_D5) +# endif +# if defined(REG_D6) +globalRegMaybe (DoubleReg 6) = Just (RealRegSingle REG_D6) +# endif +# if MAX_REAL_XMM_REG != 0 +# if defined(REG_XMM1) +globalRegMaybe (XmmReg 1) = Just (RealRegSingle REG_XMM1) +# endif +# if defined(REG_XMM2) +globalRegMaybe (XmmReg 2) = Just (RealRegSingle REG_XMM2) +# endif +# if defined(REG_XMM3) +globalRegMaybe (XmmReg 3) = Just (RealRegSingle REG_XMM3) +# endif +# if defined(REG_XMM4) +globalRegMaybe (XmmReg 4) = Just (RealRegSingle REG_XMM4) +# endif +# if defined(REG_XMM5) +globalRegMaybe (XmmReg 5) = Just (RealRegSingle REG_XMM5) +# endif +# if defined(REG_XMM6) +globalRegMaybe (XmmReg 6) = Just (RealRegSingle REG_XMM6) +# endif +# endif +# if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0 +# if defined(REG_YMM1) +globalRegMaybe (YmmReg 1) = Just (RealRegSingle REG_YMM1) +# endif +# if defined(REG_YMM2) +globalRegMaybe (YmmReg 2) = Just (RealRegSingle REG_YMM2) +# endif +# if defined(REG_YMM3) +globalRegMaybe (YmmReg 3) = Just (RealRegSingle REG_YMM3) +# endif +# if defined(REG_YMM4) +globalRegMaybe (YmmReg 4) = Just (RealRegSingle REG_YMM4) +# endif +# if defined(REG_YMM5) +globalRegMaybe (YmmReg 5) = Just (RealRegSingle REG_YMM5) +# endif +# if defined(REG_YMM6) +globalRegMaybe (YmmReg 6) = Just (RealRegSingle REG_YMM6) +# endif +# endif +# if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0 +# if defined(REG_ZMM1) +globalRegMaybe (ZmmReg 1) = Just (RealRegSingle REG_ZMM1) +# endif +# if defined(REG_ZMM2) +globalRegMaybe (ZmmReg 2) = Just (RealRegSingle REG_ZMM2) +# endif +# if defined(REG_ZMM3) +globalRegMaybe (ZmmReg 3) = Just (RealRegSingle REG_ZMM3) +# endif +# if defined(REG_ZMM4) +globalRegMaybe (ZmmReg 4) = Just (RealRegSingle REG_ZMM4) +# endif +# if defined(REG_ZMM5) +globalRegMaybe (ZmmReg 5) = Just (RealRegSingle REG_ZMM5) +# endif +# if defined(REG_ZMM6) +globalRegMaybe (ZmmReg 6) = Just (RealRegSingle REG_ZMM6) +# endif +# endif +# if defined(REG_Sp) +globalRegMaybe Sp = Just (RealRegSingle REG_Sp) +# endif +# if defined(REG_Lng1) +globalRegMaybe (LongReg 1) = Just (RealRegSingle REG_Lng1) +# endif +# if defined(REG_Lng2) +globalRegMaybe (LongReg 2) = Just (RealRegSingle REG_Lng2) +# endif +# if defined(REG_SpLim) +globalRegMaybe SpLim = Just (RealRegSingle REG_SpLim) +# endif +# if defined(REG_Hp) +globalRegMaybe Hp = Just (RealRegSingle REG_Hp) +# endif +# if defined(REG_HpLim) +globalRegMaybe HpLim = Just (RealRegSingle REG_HpLim) +# endif +# if defined(REG_CurrentTSO) +globalRegMaybe CurrentTSO = Just (RealRegSingle REG_CurrentTSO) +# endif +# if defined(REG_CurrentNursery) +globalRegMaybe CurrentNursery = Just (RealRegSingle REG_CurrentNursery) +# endif +# if defined(REG_MachSp) +globalRegMaybe MachSp = Just (RealRegSingle REG_MachSp) +# endif +globalRegMaybe _ = Nothing +#elif defined(MACHREGS_NO_REGS) +globalRegMaybe _ = Nothing +#else +globalRegMaybe = panic "globalRegMaybe not defined for this platform" +#endif + +freeReg :: RegNo -> Bool + +#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) + +# if defined(MACHREGS_i386) +freeReg esp = False -- %esp is the C stack pointer +freeReg esi = False -- See Note [esi/edi/ebp not allocatable] +freeReg edi = False +freeReg ebp = False +# endif +# if defined(MACHREGS_x86_64) +freeReg rsp = False -- %rsp is the C stack pointer +# endif + +{- +Note [esi/edi/ebp not allocatable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +%esi is mapped to R1, so %esi would normally be allocatable while it +is not being used for R1. However, %esi has no 8-bit version on x86, +and the linear register allocator is not sophisticated enough to +handle this irregularity (we need more RegClasses). The +graph-colouring allocator also cannot handle this - it was designed +with more flexibility in mind, but the current implementation is +restricted to the same set of classes as the linear allocator. + +Hence, on x86 esi, edi and ebp are treated as not allocatable. +-} + +-- split patterns in two functions to prevent overlaps +freeReg r = freeRegBase r + +freeRegBase :: RegNo -> Bool +# if defined(REG_Base) +freeRegBase REG_Base = False +# endif +# if defined(REG_Sp) +freeRegBase REG_Sp = False +# endif +# if defined(REG_SpLim) +freeRegBase REG_SpLim = False +# endif +# if defined(REG_Hp) +freeRegBase REG_Hp = False +# endif +# if defined(REG_HpLim) +freeRegBase REG_HpLim = False +# endif +-- All other regs are considered to be "free", because we can track +-- their liveness accurately. +freeRegBase _ = True + +#elif defined(MACHREGS_powerpc) + +freeReg 0 = False -- Used by code setting the back chain pointer + -- in stack reallocations on Linux. + -- Moreover r0 is not usable in all insns. +freeReg 1 = False -- The Stack Pointer +-- most ELF PowerPC OSes use r2 as a TOC pointer +freeReg 2 = False +freeReg 13 = False -- reserved for system thread ID on 64 bit +-- at least linux in -fPIC relies on r30 in PLT stubs +freeReg 30 = False +{- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively. + For now we use r30 on 64 bit and r13 on 32 bit as a temporary register + in stack handling code. See compiler/GHC/CmmToAsm/PPC/Instr.hs. + + Later we might want to reserve r13 and r30 only where it is required. + Then use r12 as temporary register, which is also what the C ABI does. +-} + +# if defined(REG_Base) +freeReg REG_Base = False +# endif +# if defined(REG_Sp) +freeReg REG_Sp = False +# endif +# if defined(REG_SpLim) +freeReg REG_SpLim = False +# endif +# if defined(REG_Hp) +freeReg REG_Hp = False +# endif +# if defined(REG_HpLim) +freeReg REG_HpLim = False +# endif +freeReg _ = True + +#elif defined(MACHREGS_aarch64) + +-- stack pointer / zero reg +freeReg 31 = False +-- link register +freeReg 30 = False +-- frame pointer +freeReg 29 = False +-- ip0 -- used for spill offset computations +freeReg 16 = False + +-- Note [Aarch64 Register x18 at Darwin and Windows] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- x18 is reserved by the platform on Darwin/iOS, and can not be used +-- More about ARM64 ABI that Apple platforms support: +-- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms +-- https://github.com/Siguza/ios-resources/blob/master/bits/arm64.md +-- It is a reserved at Windows as well. Acts like TEB register in user mode at Windows. +-- https://learn.microsoft.com/en-us/cpp/build/arm64-windows-abi-conventions +#if defined(darwin_HOST_OS) || defined(ios_HOST_OS) || defined(mingw32_HOST_OS) +freeReg 18 = False +#endif + +# if defined(REG_Base) +freeReg REG_Base = False +# endif +# if defined(REG_Sp) +freeReg REG_Sp = False +# endif +# if defined(REG_SpLim) +freeReg REG_SpLim = False +# endif +# if defined(REG_Hp) +freeReg REG_Hp = False +# endif +# if defined(REG_HpLim) +freeReg REG_HpLim = False +# endif + +# if defined(REG_R1) +freeReg REG_R1 = False +# endif +# if defined(REG_R2) +freeReg REG_R2 = False +# endif +# if defined(REG_R3) +freeReg REG_R3 = False +# endif +# if defined(REG_R4) +freeReg REG_R4 = False +# endif +# if defined(REG_R5) +freeReg REG_R5 = False +# endif +# if defined(REG_R6) +freeReg REG_R6 = False +# endif +# if defined(REG_R7) +freeReg REG_R7 = False +# endif +# if defined(REG_R8) +freeReg REG_R8 = False +# endif + +# if defined(REG_F1) +freeReg REG_F1 = False +# endif +# if defined(REG_F2) +freeReg REG_F2 = False +# endif +# if defined(REG_F3) +freeReg REG_F3 = False +# endif +# if defined(REG_F4) +freeReg REG_F4 = False +# endif +# if defined(REG_F5) +freeReg REG_F5 = False +# endif +# if defined(REG_F6) +freeReg REG_F6 = False +# endif + +# if defined(REG_D1) +freeReg REG_D1 = False +# endif +# if defined(REG_D2) +freeReg REG_D2 = False +# endif +# if defined(REG_D3) +freeReg REG_D3 = False +# endif +# if defined(REG_D4) +freeReg REG_D4 = False +# endif +# if defined(REG_D5) +freeReg REG_D5 = False +# endif +# if defined(REG_D6) +freeReg REG_D6 = False +# endif + +freeReg _ = True + +#elif defined(MACHREGS_riscv64) + +-- zero reg +freeReg 0 = False +-- link register +freeReg 1 = False +-- stack pointer +freeReg 2 = False +-- global pointer +freeReg 3 = False +-- thread pointer +freeReg 4 = False +-- frame pointer +freeReg 8 = False +-- made-up inter-procedural (ip) register +-- See Note [The made-up RISCV64 TMP (IP) register] +freeReg 31 = False + +# if defined(REG_Base) +freeReg REG_Base = False +# endif +# if defined(REG_Sp) +freeReg REG_Sp = False +# endif +# if defined(REG_SpLim) +freeReg REG_SpLim = False +# endif +# if defined(REG_Hp) +freeReg REG_Hp = False +# endif +# if defined(REG_HpLim) +freeReg REG_HpLim = False +# endif + +# if defined(REG_R1) +freeReg REG_R1 = False +# endif +# if defined(REG_R2) +freeReg REG_R2 = False +# endif +# if defined(REG_R3) +freeReg REG_R3 = False +# endif +# if defined(REG_R4) +freeReg REG_R4 = False +# endif +# if defined(REG_R5) +freeReg REG_R5 = False +# endif +# if defined(REG_R6) +freeReg REG_R6 = False +# endif +# if defined(REG_R7) +freeReg REG_R7 = False +# endif +# if defined(REG_R8) +freeReg REG_R8 = False +# endif + +# if defined(REG_F1) +freeReg REG_F1 = False +# endif +# if defined(REG_F2) +freeReg REG_F2 = False +# endif +# if defined(REG_F3) +freeReg REG_F3 = False +# endif +# if defined(REG_F4) +freeReg REG_F4 = False +# endif +# if defined(REG_F5) +freeReg REG_F5 = False +# endif +# if defined(REG_F6) +freeReg REG_F6 = False +# endif + +# if defined(REG_D1) +freeReg REG_D1 = False +# endif +# if defined(REG_D2) +freeReg REG_D2 = False +# endif +# if defined(REG_D3) +freeReg REG_D3 = False +# endif +# if defined(REG_D4) +freeReg REG_D4 = False +# endif +# if defined(REG_D5) +freeReg REG_D5 = False +# endif +# if defined(REG_D6) +freeReg REG_D6 = False +# endif + +freeReg _ = True + +#elif defined(MACHREGS_loongarch64) + +-- zero register +freeReg 0 = False +-- linker regster +freeReg 1 = False +-- thread register +freeReg 2 = False +-- stack pointer +freeReg 3 = False +-- made-up inter-procedural (ip) register for spilling offset computations +freeReg 20 = False +-- reserved +freeReg 21 = False +-- frame pointer +freeReg 22 = False + +# if defined(REG_Base) +freeReg REG_Base = False +# endif +# if defined(REG_Sp) +freeReg REG_Sp = False +# endif +# if defined(REG_SpLim) +freeReg REG_SpLim = False +# endif +# if defined(REG_Hp) +freeReg REG_Hp = False +# endif +# if defined(REG_HpLim) +freeReg REG_HpLim = False +# endif + +# if defined(REG_R1) +freeReg REG_R1 = False +# endif +# if defined(REG_R2) +freeReg REG_R2 = False +# endif +# if defined(REG_R3) +freeReg REG_R3 = False +# endif +# if defined(REG_R4) +freeReg REG_R4 = False +# endif +# if defined(REG_R5) +freeReg REG_R5 = False +# endif +# if defined(REG_R6) +freeReg REG_R6 = False +# endif +# if defined(REG_R7) +freeReg REG_R7 = False +# endif +# if defined(REG_R8) +freeReg REG_R8 = False +# endif + +# if defined(REG_F1) +freeReg REG_F1 = False +# endif +# if defined(REG_F2) +freeReg REG_F2 = False +# endif +# if defined(REG_F3) +freeReg REG_F3 = False +# endif +# if defined(REG_F4) +freeReg REG_F4 = False +# endif +# if defined(REG_F5) +freeReg REG_F5 = False +# endif +# if defined(REG_F6) +freeReg REG_F6 = False +# endif + +# if defined(REG_D1) +freeReg REG_D1 = False +# endif +# if defined(REG_D2) +freeReg REG_D2 = False +# endif +# if defined(REG_D3) +freeReg REG_D3 = False +# endif +# if defined(REG_D4) +freeReg REG_D4 = False +# endif +# if defined(REG_D5) +freeReg REG_D5 = False +# endif +# if defined(REG_D6) +freeReg REG_D6 = False +# endif + +freeReg _ = True + +#else + +freeReg = panic "freeReg not defined for this platform" + +#endif diff --git a/FunTypes.h b/FunTypes.h new file mode 100644 --- /dev/null +++ b/FunTypes.h @@ -0,0 +1,54 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2002 + * + * Things for functions. + * + * ---------------------------------------------------------------------------*/ + +#pragma once + +/* generic - function comes with a small bitmap */ +#define ARG_GEN 0 + +/* generic - function comes with a large bitmap */ +#define ARG_GEN_BIG 1 + +/* BCO - function is really a BCO */ +#define ARG_BCO 2 + +/* + * Specialised function types: bitmaps and calling sequences + * for these functions are pre-generated: see ghc/utils/genapply and + * generated code in ghc/rts/AutoApply.cmm. + * + * NOTE: other places to change if you change this table: + * - utils/genapply/Main.hs: stackApplyTypes + * - GHC.StgToCmm.Layout: stdPattern + */ +#define ARG_NONE 3 +#define ARG_N 4 +#define ARG_P 5 +#define ARG_F 6 +#define ARG_D 7 +#define ARG_L 8 +#define ARG_V16 9 +#define ARG_V32 10 +#define ARG_V64 11 +#define ARG_NN 12 +#define ARG_NP 13 +#define ARG_PN 14 +#define ARG_PP 15 +#define ARG_NNN 16 +#define ARG_NNP 17 +#define ARG_NPN 18 +#define ARG_NPP 19 +#define ARG_PNN 20 +#define ARG_PNP 21 +#define ARG_PPN 22 +#define ARG_PPP 23 +#define ARG_PPPP 24 +#define ARG_PPPPP 25 +#define ARG_PPPPPP 26 +#define ARG_PPPPPPP 27 +#define ARG_PPPPPPPP 28 diff --git a/GHC.hs b/GHC.hs new file mode 100644 --- /dev/null +++ b/GHC.hs @@ -0,0 +1,2100 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-} +{-# LANGUAGE TupleSections, NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2012 +-- +-- The GHC API +-- +-- ----------------------------------------------------------------------------- + +module GHC ( + -- * Initialisation + defaultErrorHandler, + defaultCleanupHandler, + prettyPrintGhcErrors, + withSignalHandlers, + withCleanupSession, + + -- * GHC Monad + Ghc, GhcT, GhcMonad(..), HscEnv, + runGhc, runGhcT, initGhcMonad, + printException, + handleSourceError, + + -- * Flags and settings + DynFlags(..), GeneralFlag(..), Severity(..), Backend, gopt, + ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend, + GhcMode(..), GhcLink(..), + parseDynamicFlags, parseTargetFiles, + getSessionDynFlags, + setTopSessionDynFlags, + setSessionDynFlags, + setUnitDynFlags, + getProgramDynFlags, setProgramDynFlags, + setProgramHUG, setProgramHUG_, + getInteractiveDynFlags, setInteractiveDynFlags, + normaliseInteractiveDynFlags, initialiseInteractiveDynFlags, + interpretPackageEnv, + + -- * Logging + Logger, getLogger, + pushLogHook, popLogHook, + pushLogHookM, popLogHookM, modifyLogger, + putMsgM, putLogMsgM, + + + -- * Targets + Target(..), TargetId(..), Phase, + setTargets, + getTargets, + addTarget, + removeTarget, + guessTarget, + guessTargetId, + + -- * Loading\/compiling the program + depanal, depanalE, + load, loadWithCache, LoadHowMuch(..), InteractiveImport(..), + SuccessFlag(..), succeeded, failed, + defaultWarnErrLogger, WarnErrLogger, + workingDirectoryChanged, + parseModule, typecheckModule, desugarModule, + ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), + TypecheckedSource, ParsedSource, RenamedSource, -- ditto + TypecheckedMod, ParsedMod, + moduleInfo, renamedSource, typecheckedSource, + parsedSource, coreModule, + PkgQual(..), + + -- ** Compiling to Core + CoreModule(..), + compileToCoreModule, compileToCoreSimplified, + + -- * Inspecting the module structure of the program + ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, + mgLookupModule, + ModSummary(..), ms_mod_name, ModLocation(..), + pattern ModLocation, + getModSummary, + getModuleGraph, + isLoaded, + isLoadedModule, + isLoadedHomeModule, + topSortModuleGraph, + + -- * Inspecting modules + ModuleInfo, + getModuleInfo, + modInfoTyThings, + modInfoExports, + modInfoExportsWithSelectors, + modInfoInstances, + modInfoIsExportedName, + modInfoLookupName, + modInfoIface, + modInfoSafe, + lookupGlobalName, + findGlobalAnns, + mkNamePprCtxForModule, + ModIface, + ModIface_( mi_mod_info + , mi_module + , mi_sig_of + , mi_hsc_src + , mi_iface_hash + , mi_deps + , mi_public + , mi_exports + , mi_fixities + , mi_warns + , mi_anns + , mi_decls + , mi_defaults + , mi_simplified_core + , mi_top_env + , mi_insts + , mi_fam_insts + , mi_rules + , mi_trust + , mi_trust_pkg + , mi_complete_matches + , mi_docs + , mi_abi_hashes + , mi_ext_fields + , mi_hi_bytes + , mi_self_recomp_info + , mi_fix_fn + , mi_decl_warn_fn + , mi_export_warn_fn + , mi_hash_fn + ), + pattern ModIface, + SafeHaskellMode(..), + + -- * Printing + NamePprCtx, alwaysQualify, + + -- * Interactive evaluation + + -- ** Executing statements + execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), + resumeExec, + + -- ** Adding new declarations + runDecls, runDeclsWithLocation, runParsedDecls, + + -- ** Get/set the current context + parseImportDecl, + setContext, getContext, + setGHCiMonad, getGHCiMonad, + + -- ** Inspecting the current context + getBindings, getInsts, getNamePprCtx, + findModule, lookupModule, + findQualifiedModule, lookupQualifiedModule, + lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames, + renamePkgQualM, renameRawPkgQualM, + isModuleTrusted, moduleTrustReqs, + getNamesInScope, + getRdrNamesInScope, + getGRE, + moduleIsInterpreted, + getInfo, + showModule, + moduleIsBootOrNotObjectLinkable, + getNameToInstancesIndex, + + -- ** Inspecting types and kinds + exprType, TcRnExprMode(..), + typeKind, + + -- ** Looking up a Name + parseName, + lookupName, + + -- ** Compiling expressions + HValue, parseExpr, compileParsedExpr, + GHC.Runtime.Eval.compileExpr, dynCompileExpr, + ForeignHValue, + compileExprRemote, compileParsedExprRemote, + + -- ** Docs + getDocs, GetDocsFailure(..), + + -- ** Other + runTcInteractive, -- Desired by some clients (#8878) + isStmt, hasImport, isImport, isDecl, + + -- ** The debugger + SingleStep(..), + Resume(..), + History(historyBreakpointId, historyEnclosingDecls), + GHC.getHistorySpan, getHistoryModule, + abandon, abandonAll, + getResumeContext, + GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, + modInfoModBreaks, + ModBreaks(..), BreakTickIndex, + BreakpointId(..), InternalBreakpointId(..), + GHC.Runtime.Eval.back, + GHC.Runtime.Eval.forward, + GHC.Runtime.Eval.setupBreakpoint, + + -- * Abstract syntax elements + + -- ** Units + Unit, + + -- ** Modules + Module, mkModule, pprModule, moduleName, moduleUnit, + + -- ** Names + Name, + isExternalName, nameModule, pprParenSymName, nameSrcSpan, + NamedThing(..), + RdrName(Qual,Unqual), + + -- ** Identifiers + Id, idType, + isImplicitId, isDeadBinder, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, isClassOpId_maybe, + isDataConWorkId, idDataCon, + isDeadEndId, isDictonaryId, + recordSelectorTyCon, + + -- ** Type constructors + TyCon, + tyConTyVars, tyConDataCons, tyConArity, + isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon, + isPrimTyCon, + isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon, + tyConClass_maybe, + synTyConRhs_maybe, synTyConDefn_maybe, tyConKind, + + -- ** Type variables + TyVar, + alphaTyVars, + + -- ** Data constructors + DataCon, + dataConType, dataConTyCon, dataConFieldLabels, + dataConIsInfix, isVanillaDataCon, dataConWrapperType, + dataConSrcBangs, + StrictnessMark(..), isMarkedStrict, + + -- ** Classes + Class, + classMethods, classSCTheta, classTvsFds, classATs, + pprFundeps, + + -- ** Instances + ClsInst, + instanceDFunId, + pprInstance, pprInstanceHdr, + pprFamInst, + + FamInst, + + -- ** Types and Kinds + Type, splitForAllTyCoVars, funResultTy, + pprParendType, pprTypeApp, + Kind, + PredType, + ThetaType, pprForAll, pprThetaArrowTy, + parseInstanceHead, + getInstancesForType, + + -- ** Entities + TyThing(..), + + -- ** Syntax + module GHC.Hs, -- ToDo: remove extraneous bits + + -- ** Fixities + FixityDirection(..), + defaultFixity, maxPrecedence, + negateFixity, + compareFixity, + LexicalFixity(..), + + -- ** Source locations + SrcLoc(..), RealSrcLoc, + mkSrcLoc, noSrcLoc, + srcLocFile, srcLocLine, srcLocCol, + SrcSpan(..), RealSrcSpan, + mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, + srcSpanStart, srcSpanEnd, + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + + -- ** Located + GenLocated(..), Located, RealLocated, + + -- *** Constructing Located + noLoc, mkGeneralLocated, + + -- *** Deconstructing Located + getLoc, unLoc, + getRealSrcSpan, unRealSrcSpan, + + -- *** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost_smallest, + spans, isSubspanOf, + + -- * Exceptions + GhcException(..), showGhcException, + GhcApiError(..), + + -- * Token stream manipulations + Token, + getTokenStream, getRichTokenStream, + showRichTokenStream, addSourceToTokens, + + -- * Pure interface to the parser + parser, + + -- * API Annotations + EpaComment(..) + ) where + +{- + ToDo: + + * inline bits of GHC.Driver.Main here to simplify layering: hscTcExpr, hscStmt. +-} + +import GHC.Prelude hiding (init) + +import GHC.Platform +import GHC.Platform.Ways + +import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename + , isSourceFilename, startPhase ) +import GHC.Driver.Env +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.CmdLine +import GHC.Driver.Session +import GHC.Driver.Session.Inspect +import GHC.Driver.Backend +import GHC.Driver.Config.Finder (initFinderOpts) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.StgToJS (initStgToJSConfig) +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Main +import GHC.Driver.Make +import GHC.Driver.Hooks +import GHC.Driver.Monad +import GHC.Driver.Ppr + +import GHC.ByteCode.Types +import qualified GHC.Linker.Loader as Loader +import GHC.Runtime.Loader +import GHC.Runtime.Eval +import GHC.Runtime.Interpreter +import GHC.Runtime.Context +import GHCi.RemoteTypes + +import qualified GHC.Parser as Parser +import GHC.Parser.Lexer +import GHC.Parser.Annotation +import GHC.Parser.Utils + +import GHC.Iface.Env ( trace_if ) +import GHC.Iface.Load ( loadSysInterface ) +import GHC.Hs +import GHC.Builtin.Types.Prim ( alphaTyVars ) +import GHC.Data.StringBuffer +import GHC.Data.FastString +import qualified GHC.LanguageExtensions as LangExt +import GHC.Rename.Names (renamePkgQual, renameRawPkgQual) + +import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) +import GHC.Tc.Types +import GHC.Tc.Utils.TcType +import GHC.Tc.Module +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Instance.Family + +import GHC.Utils.TmpFs +import GHC.Utils.Error +import GHC.Utils.Exception +import GHC.Utils.Monad +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Logger +import GHC.Utils.Fingerprint + +import GHC.Core.Predicate +import GHC.Core.Type hiding( typeKind ) +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr ( pprForAll ) +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts, orphNamesOfFamInst ) +import GHC.Core.InstEnv +import GHC.Core + +import GHC.Data.Maybe + +import GHC.Types.Id +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Avail +import GHC.Types.SrcLoc +import GHC.Types.TyThing.Ppr ( pprFamInst ) +import GHC.Types.Annotations +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.SourceError +import GHC.Types.SafeHaskell +import GHC.Types.Error +import GHC.Types.Fixity +import GHC.Types.Target +import GHC.Types.Basic +import GHC.Types.TyThing +import GHC.Types.Name.Env +import GHC.Types.TypeEnv +import GHC.Types.PkgQual + +import GHC.Unit +import GHC.Unit.Env as UnitEnv +import GHC.Unit.Finder +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Graph +import GHC.Unit.Home.ModInfo +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Settings + +import Control.Applicative ((<|>)) +import Control.Concurrent +import Control.Monad +import Control.Monad.Catch as MC +import Data.Foldable +import Data.Function ((&)) +import Data.IORef +import Data.List (isPrefixOf) +import Data.Typeable ( Typeable ) +import Data.Word ( Word8 ) + +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Sequence as Seq + +import System.Directory +import System.Environment ( getEnv, getProgName ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.FilePath +import System.IO.Error ( isDoesNotExistError ) + + +-- %************************************************************************ +-- %* * +-- Initialisation: exception handlers +-- %* * +-- %************************************************************************ + + +-- | Install some default exception handlers and run the inner computation. +-- Unless you want to handle exceptions yourself, you should wrap this around +-- the top level of your program. The default handlers output the error +-- message(s) to stderr and exit cleanly. +defaultErrorHandler :: (ExceptionMonad m) + => FatalMessager -> FlushOut -> m a -> m a +defaultErrorHandler fm (FlushOut flushOut) inner = + -- top-level exception handler: any unrecognised exception is a compiler bug. + MC.handle (\exception -> liftIO $ do + flushOut + case fromException exception of + -- an IO exception probably isn't our fault, so don't panic + Just (ioe :: IOException) -> + fm (show ioe) + _ -> case fromException exception of + Just UserInterrupt -> + -- Important to let this one propagate out so our + -- calling process knows we were interrupted by ^C + liftIO $ throwIO UserInterrupt + Just StackOverflow -> + fm "stack overflow: use +RTS -K to increase it" + Just HeapOverflow -> + fm "heap overflow: use +RTS -M to increase maximum heap size" + _ -> case fromException exception of + Just (ex :: ExitCode) -> liftIO $ throwIO ex + _ -> + fm (show (Panic (show exception))) + exitWith (ExitFailure 1) + ) $ + + -- error messages propagated as exceptions + handleGhcException + (\ge -> liftIO $ do + flushOut + case ge of + Signal _ -> return () + ProgramError _ -> fm (show ge) + CmdLineError _ -> fm (": " ++ show ge) + _ -> do + progName <- getProgName + fm (progName ++ ": " ++ show ge) + exitWith (ExitFailure 1) + ) $ + inner + +-- | This function is no longer necessary, cleanup is now done by +-- runGhc/runGhcT. +{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-} +defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a +defaultCleanupHandler _ m = m + where _warning_suppression = m `MC.onException` undefined + + +-- %************************************************************************ +-- %* * +-- The Ghc Monad +-- %* * +-- %************************************************************************ + +-- | Run function for the 'Ghc' monad. +-- +-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call +-- to this function will create a new session which should not be shared among +-- several threads. +-- +-- Any errors not handled inside the 'Ghc' action are propagated as IO +-- exceptions. + +runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. + -> Ghc a -- ^ The action to perform. + -> IO a +runGhc mb_top_dir ghc = do + ref <- newIORef (panic "empty session") + let session = Session ref + flip unGhc session $ withSignalHandlers $ do -- catch ^C + initGhcMonad mb_top_dir + withCleanupSession ghc + +-- | Run function for 'GhcT' monad transformer. +-- +-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call +-- to this function will create a new session which should not be shared among +-- several threads. + +runGhcT :: ExceptionMonad m => + Maybe FilePath -- ^ See argument to 'initGhcMonad'. + -> GhcT m a -- ^ The action to perform. + -> m a +runGhcT mb_top_dir ghct = do + ref <- liftIO $ newIORef (panic "empty session") + let session = Session ref + flip unGhcT session $ withSignalHandlers $ do -- catch ^C + initGhcMonad mb_top_dir + withCleanupSession ghct + +withCleanupSession :: GhcMonad m => m a -> m a +withCleanupSession ghc = ghc `MC.finally` cleanup + where + cleanup = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env + liftIO $ do + unless (gopt Opt_KeepTmpFiles dflags) $ do + cleanTempFiles logger tmpfs + cleanTempDirs logger tmpfs + traverse_ stopInterp (hsc_interp hsc_env) + -- exceptions will be blocked while we clean the temporary files, + -- so there shouldn't be any difficulty if we receive further + -- signals. + +-- | Initialise a GHC session. +-- +-- If you implement a custom 'GhcMonad' you must call this function in the +-- monad run function. It will initialise the session variable and clear all +-- warnings. +-- +-- The first argument should point to the directory where GHC's library files +-- reside. More precisely, this should be the output of @ghc --print-libdir@ +-- of the version of GHC the module using this API is compiled with. For +-- portability, you should use the @ghc-paths@ package, available at +-- . + +initGhcMonad :: GhcMonad m => Maybe FilePath -> m () +initGhcMonad mb_top_dir = setSession =<< liftIO ( do +#if !defined(javascript_HOST_ARCH) + -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds. + -- So we can't use assertM here. + -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why. + !keep_cafs <- c_keepCAFsForGHCi + massert keep_cafs +#endif + initHscEnv mb_top_dir + ) + +-- %************************************************************************ +-- %* * +-- Flags & settings +-- %* * +-- %************************************************************************ + +-- $DynFlags +-- +-- The GHC session maintains two sets of 'DynFlags': +-- +-- * The "interactive" @DynFlags@, which are used for everything +-- related to interactive evaluation, including 'runStmt', +-- 'runDecls', 'exprType', 'lookupName' and so on (everything +-- under \"Interactive evaluation\" in this module). +-- +-- * The "program" @DynFlags@, which are used when loading +-- whole modules with 'load' +-- +-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the +-- interactive @DynFlags@. +-- +-- 'setProgramDynFlags', 'getProgramDynFlags' work with the +-- program @DynFlags@. +-- +-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' +-- retrieves the program @DynFlags@ (for backwards compatibility). + +-- This is a compatibility function which sets dynflags for the top session +-- as well as the unit. +setSessionDynFlags :: (HasCallStack, GhcMonad m) => DynFlags -> m () +setSessionDynFlags dflags0 = do + hsc_env <- getSession + logger <- getLogger + dflags <- checkNewDynFlags logger dflags0 + let all_uids = hsc_all_home_unit_ids hsc_env + case S.toList all_uids of + [uid] -> do + setUnitDynFlagsNoCheck uid dflags + modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ dflags)) + dflags' <- getDynFlags + setTopSessionDynFlags dflags' + [] -> panic "nohue" + _ -> panic "setSessionDynFlags can only be used with a single home unit" + + +setUnitDynFlags :: GhcMonad m => UnitId -> DynFlags -> m () +setUnitDynFlags uid dflags0 = do + logger <- getLogger + dflags1 <- checkNewDynFlags logger dflags0 + setUnitDynFlagsNoCheck uid dflags1 + +setUnitDynFlagsNoCheck :: GhcMonad m => UnitId -> DynFlags -> m () +setUnitDynFlagsNoCheck uid dflags1 = do + logger <- getLogger + hsc_env <- getSession + + let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env) + let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env) + updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants + + let upd hue = + hue + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_home_unit = Just home_unit + } + + let unit_env = UnitEnv.ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env) + + let dflags = updated_dflags + + let unit_env0 = unit_env + { ue_platform = targetPlatform dflags + , ue_namever = ghcNameVersion dflags + } + + -- if necessary, change the key for the currently active unit + -- as the dynflags might have been changed + + -- This function is called on every --make invocation because at the start of + -- the session there is one fake unit called main which is immediately replaced + -- after the DynFlags are parsed. + let !unit_env1 = + if homeUnitId_ dflags /= uid + then + UnitEnv.renameUnitId + uid + (homeUnitId_ dflags) + unit_env0 + else unit_env0 + + modifySession $ \h -> h{ hsc_unit_env = unit_env1 + } + + invalidateModSummaryCache + + + + +setTopSessionDynFlags :: GhcMonad m => DynFlags -> m () +setTopSessionDynFlags dflags = do + hsc_env <- getSession + logger <- getLogger + lookup_cache <- liftIO $ mkInterpSymbolCache + + -- see Note [Target code interpreter] + interp <- if + -- Wasm dynamic linker + | ArchWasm32 <- platformArch $ targetPlatform dflags + -> do + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + dyld <- liftIO $ makeAbsolute $ topDir dflags "dyld.mjs" +#if defined(wasm32_HOST_ARCH) + let libdir = sorry "cannot spawn child process on wasm" +#else + libdir <- liftIO $ last <$> Loader.getGccSearchDirectory logger dflags "libraries" +#endif + let profiled = ways dflags `hasWay` WayProf + way_tag = if profiled then "_p" else "" + let cfg = + WasmInterpConfig + { wasmInterpDyLD = dyld, + wasmInterpLibDir = libdir, + wasmInterpOpts = getOpts dflags opt_i, + wasmInterpBrowser = gopt Opt_GhciBrowser dflags, + wasmInterpBrowserHost = ghciBrowserHost dflags, + wasmInterpBrowserPort = ghciBrowserPort dflags, + wasmInterpBrowserRedirectWasiConsole = gopt Opt_GhciBrowserRedirectWasiConsole dflags, + wasmInterpBrowserPuppeteerLaunchOpts = ghciBrowserPuppeteerLaunchOpts dflags, + wasmInterpBrowserPlaywrightBrowserType = ghciBrowserPlaywrightBrowserType dflags, + wasmInterpBrowserPlaywrightLaunchOpts = ghciBrowserPlaywrightLaunchOpts dflags, + wasmInterpTargetPlatform = targetPlatform dflags, + wasmInterpProfiled = profiled, + wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (ghcNameVersion dflags), + wasmInterpUnitState = ue_homeUnitState $ hsc_unit_env hsc_env + } + pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache + + -- JavaScript interpreter + | ArchJavaScript <- platformArch (targetPlatform dflags) + -> do + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + let cfg = JSInterpConfig + { jsInterpNodeConfig = defaultNodeJsSettings + , jsInterpScript = topDir dflags "ghc-interp.js" + , jsInterpTmpFs = hsc_tmpfs hsc_env + , jsInterpTmpDir = tmpDir dflags + , jsInterpLogger = hsc_logger hsc_env + , jsInterpCodegenCfg = initStgToJSConfig dflags + , jsInterpUnitEnv = hsc_unit_env hsc_env + , jsInterpFinderOpts = initFinderOpts dflags + , jsInterpFinderCache = hsc_FC hsc_env + } + return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) + + -- external interpreter + | gopt Opt_ExternalInterpreter dflags + -> do + let + prog = pgm_i dflags ++ flavour + profiled = ways dflags `hasWay` WayProf + dynamic = ways dflags `hasWay` WayDyn + flavour + | profiled && dynamic = "-prof-dyn" + | profiled = "-prof" + | dynamic = "-dyn" + | otherwise = "" + msg = text "Starting " <> text prog + tr <- if verbosity dflags >= 3 + then return (logInfo logger $ withPprStyle defaultDumpStyle msg) + else return (pure ()) + let + conf = IServConfig + { iservConfProgram = prog + , iservConfOpts = getOpts dflags opt_i + , iservConfProfiled = profiled + , iservConfDynamic = dynamic + , iservConfHook = createIservProcessHook (hsc_hooks hsc_env) + , iservConfTrace = tr + } + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) + + -- Internal interpreter + | otherwise + -> +#if defined(HAVE_INTERNAL_INTERPRETER) + do + loader <- liftIO Loader.uninitializedLoader + return (Just (Interp InternalInterp loader lookup_cache)) +#else + return Nothing +#endif + + + modifySession $ \h -> hscSetFlags dflags + h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags } + , hsc_interp = hsc_interp h <|> interp + } + + invalidateModSummaryCache + +-- | Sets the program 'DynFlags'. Note: this invalidates the internal +-- cached module graph, causing more work to be done the next time +-- 'load' is called. +-- +-- Returns a boolean indicating if preload units have changed and need to be +-- reloaded. +setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool +setProgramDynFlags dflags = setProgramDynFlags_ True dflags + +setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool +setProgramDynFlags_ invalidate_needed dflags = do + logger <- getLogger + dflags0 <- checkNewDynFlags logger dflags + dflags_prev <- getProgramDynFlags + let changed = packageFlagsChanged dflags_prev dflags0 + if changed + then do + -- additionally, set checked dflags so we don't lose fixes + old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession + + home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv + dflags = homeUnitEnv_dflags homeUnitEnv + old_hpt = homeUnitEnv_hpt homeUnitEnv + home_units = HUG.allUnits (ue_home_unit_graph old_unit_env) + + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants + pure HomeUnitEnv + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_hpt = old_hpt + , homeUnitEnv_home_unit = Just home_unit + } + + let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph + let unit_env = UnitEnv + { ue_platform = targetPlatform dflags1 + , ue_namever = ghcNameVersion dflags1 + , ue_home_unit_graph = home_unit_graph + , ue_current_unit = ue_currentUnit old_unit_env + , ue_module_graph = ue_module_graph old_unit_env + , ue_eps = ue_eps old_unit_env + } + modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } + else modifySession (hscSetFlags dflags0) + + when invalidate_needed $ invalidateModSummaryCache + return changed + +-- | Sets the program 'HomeUnitGraph'. +-- +-- Sets the given 'HomeUnitGraph' as the 'HomeUnitGraph' of the current +-- session. If the package flags change, we reinitialise the 'UnitState' +-- of all 'HomeUnitEnv's in the current session. +-- +-- This function unconditionally invalidates the module graph cache. +-- +-- Precondition: the given 'HomeUnitGraph' must have the same keys as the 'HomeUnitGraph' +-- of the current session. I.e., assuming the new 'HomeUnitGraph' is called +-- 'new_hug', then: +-- +-- @ +-- do +-- hug <- hsc_HUG \<$\> getSession +-- pure $ unitEnv_keys new_hug == unitEnv_keys hug +-- @ +-- +-- If this precondition is violated, the function will crash. +-- +-- Conceptually, similar to 'setProgramDynFlags', but performs the same check +-- for all 'HomeUnitEnv's. +setProgramHUG :: GhcMonad m => HomeUnitGraph -> m Bool +setProgramHUG = + setProgramHUG_ True + +-- | Same as 'setProgramHUG', but gives you control over whether you want to +-- invalidate the module graph cache. +setProgramHUG_ :: GhcMonad m => Bool -> HomeUnitGraph -> m Bool +setProgramHUG_ invalidate_needed new_hug0 = do + logger <- getLogger + + hug0 <- hsc_HUG <$> getSession + (changed, new_hug1) <- checkNewHugDynFlags logger hug0 new_hug0 + + if changed + then do + unit_env0 <- hsc_unit_env <$> getSession + home_unit_graph <- HUG.unitEnv_traverseWithKey + (updateHomeUnit logger unit_env0 new_hug1) + (ue_home_unit_graph unit_env0) + + let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit unit_env0) home_unit_graph + let unit_env = UnitEnv + { ue_platform = targetPlatform dflags1 + , ue_namever = ghcNameVersion dflags1 + , ue_home_unit_graph = home_unit_graph + , ue_current_unit = ue_currentUnit unit_env0 + , ue_eps = ue_eps unit_env0 + , ue_module_graph = ue_module_graph unit_env0 + } + modifySession $ \h -> + -- hscSetFlags takes care of updating the logger as well. + hscSetFlags dflags1 h{ hsc_unit_env = unit_env } + else do + modifySession (\env -> + env + -- Set the new 'HomeUnitGraph'. + & hscUpdateHUG (const new_hug1) + -- hscSetActiveUnitId makes sure that the 'hsc_dflags' + -- are up-to-date. + & hscSetActiveUnitId (hscActiveUnitId env) + -- Make sure the logger is also updated. + & hscUpdateLoggerFlags) + + when invalidate_needed $ invalidateModSummaryCache + pure changed + where + checkNewHugDynFlags :: GhcMonad m => Logger -> HomeUnitGraph -> HomeUnitGraph -> m (Bool, HomeUnitGraph) + checkNewHugDynFlags logger old_hug new_hug = do + -- Traverse the new HUG and check its 'DynFlags'. + -- The old 'HUG' is used to check whether package flags have changed. + hugWithCheck <- HUG.unitEnv_traverseWithKey + (\unitId homeUnit -> do + let newFlags = homeUnitEnv_dflags homeUnit + oldFlags = homeUnitEnv_dflags (HUG.unitEnv_lookup unitId old_hug) + checkedFlags <- checkNewDynFlags logger newFlags + pure + ( packageFlagsChanged oldFlags checkedFlags + , homeUnit { homeUnitEnv_dflags = checkedFlags } + ) + ) + new_hug + let + -- Did any of the package flags change? + changed = or $ fmap fst hugWithCheck + hug = fmap snd hugWithCheck + pure (changed, hug) + + updateHomeUnit :: GhcMonad m => Logger -> UnitEnv -> HomeUnitGraph -> (UnitId -> HomeUnitEnv -> m HomeUnitEnv) + updateHomeUnit logger unit_env updates = \uid homeUnitEnv -> do + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv + dflags = case HUG.unitEnv_lookup_maybe uid updates of + Nothing -> homeUnitEnv_dflags homeUnitEnv + Just env -> homeUnitEnv_dflags env + old_hpt = homeUnitEnv_hpt homeUnitEnv + home_units = HUG.allUnits (ue_home_unit_graph unit_env) + + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants + pure HomeUnitEnv + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_hpt = old_hpt + , homeUnitEnv_home_unit = Just home_unit + } + +-- When changing the DynFlags, we want the changes to apply to future +-- loads, but without completely discarding the program. But the +-- DynFlags are cached in each ModSummary in the hsc_mod_graph, so +-- after a change to DynFlags, the changes would apply to new modules +-- but not existing modules; this seems undesirable. +-- +-- Furthermore, the GHC API client might expect that changing +-- log_action would affect future compilation messages, but for those +-- modules we have cached ModSummaries for, we'll continue to use the +-- old log_action. This is definitely wrong (#7478). +-- +-- Hence, we invalidate the ModSummary cache after changing the +-- DynFlags. We do this by tweaking the hash on each ModSummary, so +-- that the next downsweep will think that all the files have changed +-- and preprocess them again. This won't necessarily cause everything +-- to be recompiled, because by the time we check whether we need to +-- recompile a module, we'll have re-summarised the module and have a +-- correct ModSummary. +-- +invalidateModSummaryCache :: GhcMonad m => m () +invalidateModSummaryCache = + modifySession $ \hsc_env -> setModuleGraph (mapMG inval (hsc_mod_graph hsc_env)) hsc_env + where + inval ms = ms { ms_hs_hash = fingerprint0 } + +-- | Returns the program 'DynFlags'. +getProgramDynFlags :: GhcMonad m => m DynFlags +getProgramDynFlags = getSessionDynFlags + +-- | Set the 'DynFlags' used to evaluate interactive expressions. +-- Also initialise (load) plugins. +-- +-- Note: this cannot be used for changes to packages. Use +-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the +-- 'unitState' into the interactive @DynFlags@. +setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () +setInteractiveDynFlags dflags = do + logger <- getLogger + icdflags <- normaliseInteractiveDynFlags logger dflags + modifySessionM (initialiseInteractiveDynFlags icdflags) + +-- | Get the 'DynFlags' used to evaluate interactive expressions. +getInteractiveDynFlags :: GhcMonad m => m DynFlags +getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) + + +parseDynamicFlags + :: MonadIO m + => Logger + -> DynFlags + -> [Located String] + -> m (DynFlags, [Located String], Messages DriverMessage) +parseDynamicFlags logger dflags cmdline = do + (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine logger dflags cmdline + -- flags that have just been read are used by the logger when loading package + -- env (this is checked by T16318) + let logger1 = setLogFlags logger (initLogFlags dflags1) + dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1 + return (dflags2, leftovers, warns) + +-- | Parse command line arguments that look like files. +-- First normalises its arguments and then splits them into source files +-- and object files. +-- A source file can be turned into a 'Target' via 'guessTarget' +parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], [String]) +parseTargetFiles dflags0 fileish_args = + let + normal_fileish_paths = map normalise_hyp fileish_args + (srcs, raw_objs) = partition_args normal_fileish_paths [] [] + objs = map (augmentByWorkingDirectory dflags0) raw_objs + + dflags1 = dflags0 { ldInputs = map (FileOption "") objs + ++ ldInputs dflags0 } + {- + We split out the object files (.o, .dll) and add them + to ldInputs for use by the linker. + + The following things should be considered compilation manager inputs: + + - haskell source files (strings ending in .hs, .lhs or other + haskellish extension), + + - module names (not forgetting hierarchical module names), + + - things beginning with '-' are flags that were not recognised by + the flag parser, and we want them to generate errors later in + checkOptions, so we class them as source files (#5921) + + - and finally we consider everything without an extension to be + a comp manager input, as shorthand for a .hs or .lhs filename. + + Everything else is considered to be a linker object, and passed + straight through to the linker. + -} + in (dflags1, srcs, objs) + +-- ----------------------------------------------------------------------------- + +-- | Splitting arguments into source files and object files. This is where we +-- interpret the -x option, and attach a (Maybe Phase) to each source +-- file indicating the phase specified by the -x option in force, if any. +partition_args :: [String] -> [(String, Maybe Phase)] -> [String] + -> ([(String, Maybe Phase)], [String]) +partition_args [] srcs objs = (reverse srcs, reverse objs) +partition_args ("-x":suff:args) srcs objs + | "none" <- suff = partition_args args srcs objs + | StopLn <- phase = partition_args args srcs (slurp ++ objs) + | otherwise = partition_args rest (these_srcs ++ srcs) objs + where phase = startPhase suff + (slurp,rest) = break (== "-x") args + these_srcs = zip slurp (repeat (Just phase)) +partition_args (arg:args) srcs objs + | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs + | otherwise = partition_args args srcs (arg:objs) + + +looks_like_an_input :: String -> Bool +looks_like_an_input m = isSourceFilename m + || looksLikeModuleName m + || "-" `isPrefixOf` m + || not (hasExtension m) + + +-- | To simplify the handling of filepaths, we normalise all filepaths right +-- away. Note the asymmetry of FilePath.normalise: +-- Linux: p\/q -> p\/q; p\\q -> p\\q +-- Windows: p\/q -> p\\q; p\\q -> p\\q +-- #12674: Filenames starting with a hyphen get normalised from ./-foo.hs +-- to -foo.hs. We have to re-prepend the current directory. +normalise_hyp :: FilePath -> FilePath +normalise_hyp fp + | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp + | otherwise = nfp + where +#if defined(mingw32_HOST_OS) + strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp +#else + strt_dot_sl = "./" `isPrefixOf` fp +#endif + cur_dir = '.' : [pathSeparator] + nfp = normalise fp + +----------------------------------------------------------------------------- + +-- | Normalise the 'DynFlags' for us in an interactive context. +-- +-- Makes sure unsupported Flags and other incosistencies are reported and removed. +normaliseInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags +normaliseInteractiveDynFlags logger dflags = do + dflags' <- checkNewDynFlags logger dflags + checkNewInteractiveDynFlags logger dflags' + +-- | Given a set of normalised 'DynFlags' (see 'normaliseInteractiveDynFlags') +-- for the interactive context, initialize the 'InteractiveContext'. +-- +-- Initialized plugins and sets the 'DynFlags' as the 'ic_dflags' of the +-- 'InteractiveContext'. +initialiseInteractiveDynFlags :: GhcMonad m => DynFlags -> HscEnv -> m HscEnv +initialiseInteractiveDynFlags dflags hsc_env0 = do + let ic0 = hsc_IC hsc_env0 + + -- Initialise (load) plugins in the interactive environment with the new + -- DynFlags + plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ + hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags }} + + -- Update both plugins cache and DynFlags in the interactive context. + return $ hsc_env0 + { hsc_IC = ic0 + { ic_plugins = hsc_plugins plugin_env + , ic_dflags = hsc_dflags plugin_env + } + } + +-- | Checks the set of new DynFlags for possibly erroneous option +-- combinations when invoking 'setSessionDynFlags' and friends, and if +-- found, returns a fixed copy (if possible). +checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags +checkNewDynFlags logger dflags = do + -- See Note [DynFlags consistency] + let (dflags', warnings, infoverb) = makeDynFlagsConsistent dflags + let diag_opts = initDiagOpts dflags + print_config = initPrintConfig dflags + liftIO $ printOrThrowDiagnostics logger print_config diag_opts + $ fmap GhcDriverMessage $ warnsToMessages diag_opts warnings + when (logVerbAtLeast logger 3) $ + mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb + return dflags' + +checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags +checkNewInteractiveDynFlags logger dflags0 = do + -- We currently don't support use of StaticPointers in expressions entered on + -- the REPL. See #12356. + if xopt LangExt.StaticPointers dflags0 + then do + let diag_opts = initDiagOpts dflags0 + print_config = initPrintConfig dflags0 + liftIO $ printOrThrowDiagnostics logger print_config diag_opts $ singleMessage + $ fmap GhcDriverMessage + $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported + return $ xopt_unset dflags0 LangExt.StaticPointers + else return dflags0 + + +-- %************************************************************************ +-- %* * +-- Setting, getting, and modifying the targets +-- %* * +-- %************************************************************************ + +-- ToDo: think about relative vs. absolute file paths. And what +-- happens when the current directory changes. + +-- | Sets the targets for this session. Each target may be a module name +-- or a filename. The targets correspond to the set of root modules for +-- the program\/library. Unloading the current program is achieved by +-- setting the current set of targets to be empty, followed by 'load'. +setTargets :: GhcMonad m => [Target] -> m () +setTargets targets = modifySession (\h -> h{ hsc_targets = targets }) + +-- | Returns the current set of targets +getTargets :: GhcMonad m => m [Target] +getTargets = withSession (return . hsc_targets) + +-- | Add another target. +addTarget :: GhcMonad m => Target -> m () +addTarget target + = modifySession (\h -> h{ hsc_targets = target : hsc_targets h }) + +-- | Remove a target +removeTarget :: GhcMonad m => TargetId -> m () +removeTarget target_id + = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) }) + where + filter targets = [ t | t@Target { targetId = id } <- targets, id /= target_id ] + +-- | Attempts to guess what 'Target' a string refers to. This function +-- implements the @--make@/GHCi command-line syntax for filenames: +-- +-- - if the string looks like a Haskell source filename, then interpret it +-- as such +-- +-- - if adding a .hs or .lhs suffix yields the name of an existing file, +-- then use that +-- +-- - If it looks like a module name, interpret it as such +-- +-- - otherwise, this function throws a 'GhcException'. +guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target +guessTarget str mUnitId (Just phase) + = do + tuid <- unitIdOrHomeUnit mUnitId + return (Target (TargetFile str (Just phase)) True tuid Nothing) +guessTarget str mUnitId Nothing = do + targetId <- guessTargetId str + toTarget targetId + where + obj_allowed + | '*':_ <- str = False + | otherwise = True + toTarget tid = do + tuid <- unitIdOrHomeUnit mUnitId + pure $ Target tid obj_allowed tuid Nothing + +-- | Attempts to guess what 'TargetId' a string refers to. This function +-- implements the @--make@/GHCi command-line syntax for filenames: +-- +-- - if the string looks like a Haskell source filename, then interpret it +-- as such +-- +-- - if adding a .hs or .lhs suffix yields the name of an existing file, +-- then use that +-- +-- - If it looks like a module name, interpret it as such +-- +-- - otherwise, this function throws a 'GhcException'. +guessTargetId :: GhcMonad m => String -> m TargetId +guessTargetId str + | isHaskellSrcFilename file + = pure (TargetFile file Nothing) + | otherwise + = do exists <- liftIO $ doesFileExist hs_file + if exists + then pure (TargetFile hs_file Nothing) + else do + exists <- liftIO $ doesFileExist lhs_file + if exists + then pure (TargetFile lhs_file Nothing) + else do + if looksLikeModuleName file + then pure (TargetModule (mkModuleName file)) + else do + dflags <- getDynFlags + liftIO $ throwGhcExceptionIO + (ProgramError (showSDoc dflags $ + text "target" <+> quotes (text file) <+> + text "is not a module name or a source file")) + where + file + | '*':rest <- str = rest + | otherwise = str + + hs_file = file <.> "hs" + lhs_file = file <.> "lhs" + +-- | Unwrap 'UnitId' or retrieve the 'UnitId' +-- of the current 'HomeUnit'. +unitIdOrHomeUnit :: GhcMonad m => Maybe UnitId -> m UnitId +unitIdOrHomeUnit mUnitId = do + currentHomeUnitId <- homeUnitId . hsc_home_unit <$> getSession + pure (fromMaybe currentHomeUnitId mUnitId) + +-- | Inform GHC that the working directory has changed. GHC will flush +-- its cache of module locations, since it may no longer be valid. +-- +-- Note: Before changing the working directory make sure all threads running +-- in the same session have stopped. If you change the working directory, +-- you should also unload the current program (set targets to empty, +-- followed by load). +workingDirectoryChanged :: GhcMonad m => m () +workingDirectoryChanged = do + hsc_env <- getSession + liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) + + +-- %************************************************************************ +-- %* * +-- Running phases one at a time +-- %* * +-- %************************************************************************ + +class ParsedMod m where + modSummary :: m -> ModSummary + parsedSource :: m -> ParsedSource + +class ParsedMod m => TypecheckedMod m where + renamedSource :: m -> Maybe RenamedSource + typecheckedSource :: m -> TypecheckedSource + moduleInfo :: m -> ModuleInfo + tm_internals :: m -> (TcGblEnv, ModDetails) + -- ToDo: improvements that could be made here: + -- if the module succeeded renaming but not typechecking, + -- we can still get back the GlobalRdrEnv and exports, so + -- perhaps the ModuleInfo should be split up into separate + -- fields. + +class TypecheckedMod m => DesugaredMod m where + coreModule :: m -> ModGuts + +-- | The result of successful parsing. +data ParsedModule = + ParsedModule { pm_mod_summary :: ModSummary + , pm_parsed_source :: ParsedSource + , pm_extra_src_files :: [FilePath] } + +instance ParsedMod ParsedModule where + modSummary m = pm_mod_summary m + parsedSource m = pm_parsed_source m + +-- | The result of successful typechecking. It also contains the parser +-- result. +data TypecheckedModule = + TypecheckedModule { tm_parsed_module :: ParsedModule + , tm_renamed_source :: Maybe RenamedSource + , tm_typechecked_source :: TypecheckedSource + , tm_checked_module_info :: ModuleInfo + , tm_internals_ :: (TcGblEnv, ModDetails) + } + +instance ParsedMod TypecheckedModule where + modSummary m = modSummary (tm_parsed_module m) + parsedSource m = parsedSource (tm_parsed_module m) + +instance TypecheckedMod TypecheckedModule where + renamedSource m = tm_renamed_source m + typecheckedSource m = tm_typechecked_source m + moduleInfo m = tm_checked_module_info m + tm_internals m = tm_internals_ m + +-- | The result of successful desugaring (i.e., translation to core). Also +-- contains all the information of a typechecked module. +data DesugaredModule = + DesugaredModule { dm_typechecked_module :: TypecheckedModule + , dm_core_module :: ModGuts + } + +instance ParsedMod DesugaredModule where + modSummary m = modSummary (dm_typechecked_module m) + parsedSource m = parsedSource (dm_typechecked_module m) + +instance TypecheckedMod DesugaredModule where + renamedSource m = renamedSource (dm_typechecked_module m) + typecheckedSource m = typecheckedSource (dm_typechecked_module m) + moduleInfo m = moduleInfo (dm_typechecked_module m) + tm_internals m = tm_internals_ (dm_typechecked_module m) + +instance DesugaredMod DesugaredModule where + coreModule m = dm_core_module m + +type ParsedSource = Located (HsModule GhcPs) +type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], + Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)) +type TypecheckedSource = LHsBinds GhcTc + +-- NOTE: +-- - things that aren't in the output of the typechecker right now: +-- - the export list +-- - the imports +-- - type signatures +-- - type/data/newtype declarations +-- - class declarations +-- - instances +-- - extra things in the typechecker's output: +-- - default methods are turned into top-level decls. +-- - dictionary bindings + +-- | Return the 'ModSummary' of a module with the given name. +-- +-- The module must be part of the module graph (see 'hsc_mod_graph' and +-- 'ModuleGraph'). If this is not the case, this function will throw a +-- 'GhcApiError'. +-- +-- This function ignores boot modules and requires that there is only one +-- non-boot module with the given name. +getModSummary :: GhcMonad m => Module -> m ModSummary +getModSummary mod = do + mg <- liftM hsc_mod_graph getSession + let mods_by_name = [ ms | ms <- mgModSummaries mg + , ms_mod ms == mod + , isBootSummary ms == NotBoot ] + case mods_by_name of + [] -> do dflags <- getDynFlags + liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph") + [ms] -> return ms + multiple -> do dflags <- getDynFlags + liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple) + +-- | Parse a module. +-- +-- Throws a 'SourceError' on parse error. +parseModule :: GhcMonad m => ModSummary -> m ParsedModule +parseModule ms = do + hsc_env <- getSession + liftIO $ do + let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env + hpm <- hscParse lcl_hsc_env ms + return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)) + -- See Note [exact print annotations] in GHC.Parser.Annotation + +-- | Typecheck and rename a parsed module. +-- +-- Throws a 'SourceError' if either fails. +typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule +typecheckModule pmod = do + hsc_env <- getSession + + liftIO $ do + let ms = modSummary pmod + let lcl_dflags = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.) + let lcl_hsc_env = + hscSetFlags lcl_dflags $ + hscSetActiveUnitId (toUnitId $ moduleUnit $ ms_mod ms) hsc_env + let lcl_logger = hsc_logger lcl_hsc_env + (tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $ + HsParsedModule { hpm_module = parsedSource pmod, + hpm_src_files = pm_extra_src_files pmod } + details <- makeSimpleDetails lcl_logger tc_gbl_env + safe <- finalSafeMode lcl_dflags tc_gbl_env + + return $ + TypecheckedModule { + tm_internals_ = (tc_gbl_env, details), + tm_parsed_module = pmod, + tm_renamed_source = rn_info, + tm_typechecked_source = tcg_binds tc_gbl_env, + tm_checked_module_info = + ModuleInfo { + minf_type_env = md_types details, + minf_exports = md_exports details, + minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details, + minf_iface = Nothing, + minf_safe = safe, + minf_modBreaks = Nothing + }} + +-- | Desugar a typechecked module. +desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule +desugarModule tcm = do + hsc_env <- getSession + liftIO $ do + let ms = modSummary tcm + let (tcg, _) = tm_internals tcm + let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env + guts <- hscDesugar lcl_hsc_env ms tcg + return $ + DesugaredModule { + dm_typechecked_module = tcm, + dm_core_module = guts + } + + + +-- %************************************************************************ +-- %* * +-- Dealing with Core +-- %* * +-- %************************************************************************ + +-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for +-- the 'GHC.compileToCoreModule' interface. +data CoreModule + = CoreModule { + -- | Module name + cm_module :: !Module, + -- | Type environment for types declared in this module + cm_types :: !TypeEnv, + -- | Declarations + cm_binds :: CoreProgram, + -- | Safe Haskell mode + cm_safe :: SafeHaskellMode + } + +instance Outputable CoreModule where + ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, + cm_safe = sf}) + = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te + $$ vcat (map ppr cb) + +-- | This is the way to get access to the Core bindings corresponding +-- to a module. 'compileToCore' parses, typechecks, and +-- desugars the module, then returns the resulting Core module (consisting of +-- the module name, type declarations, and function declarations) if +-- successful. +compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule +compileToCoreModule = compileCore False + +-- | Like compileToCoreModule, but invokes the simplifier, so +-- as to return simplified and tidied Core. +compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule +compileToCoreSimplified = compileCore True + +compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule +compileCore simplify fn = do + -- First, set the target to the desired filename + target <- guessTarget fn Nothing Nothing + addTarget target + _ <- load LoadAllTargets + -- Then find dependencies + modGraph <- depanal [] True + case find ((== fn) . msHsFilePath) (mgModSummaries modGraph) of + Just modSummary -> do + -- Now we have the module name; + -- parse, typecheck and desugar the module + (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly? + do tm <- typecheckModule =<< parseModule modSummary + let tcg = fst (tm_internals tm) + (,) tcg . coreModule <$> desugarModule tm + liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ + if simplify + then do + -- If simplify is true: simplify (hscSimplify), then tidy + -- (hscTidy). + hsc_env <- getSession + simpl_guts <- liftIO $ do + plugins <- readIORef (tcg_th_coreplugins tcg) + hscSimplify hsc_env plugins mod_guts + tidy_guts <- liftIO $ hscTidy hsc_env simpl_guts + return $ Left tidy_guts + else + return $ Right mod_guts + + Nothing -> panic "compileToCoreModule: target FilePath not found in module dependency graph" + where -- two versions, based on whether we simplify (thus run tidyProgram, + -- which returns a (CgGuts, ModDetails) pair, or not (in which case + -- we just have a ModGuts. + gutsToCoreModule :: SafeHaskellMode + -> Either (CgGuts, ModDetails) ModGuts + -> CoreModule + gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { + cm_module = cg_module cg, + cm_types = md_types md, + cm_binds = cg_binds cg, + cm_safe = safe_mode + } + gutsToCoreModule safe_mode (Right mg) = CoreModule { + cm_module = mg_module mg, + cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) + (mg_tcs mg) (mg_patsyns mg) + (mg_fam_insts mg), + cm_binds = mg_binds mg, + cm_safe = safe_mode + } + +isDictonaryId :: Id -> Bool +isDictonaryId id = isDictTy (idType id) + +-- | Looks up a global name: that is, any top-level name in any +-- visible module. Unlike 'lookupName', lookupGlobalName does not use +-- the interactive context, and therefore does not require a preceding +-- 'setContext'. +lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) +lookupGlobalName name = withSession $ \hsc_env -> do + liftIO $ lookupType hsc_env name + +findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] +findGlobalAnns deserialize target = withSession $ \hsc_env -> do + ann_env <- liftIO $ prepareAnnotations hsc_env Nothing + return (findAnns deserialize ann_env target) + +-- | get the GlobalRdrEnv for a session +getGRE :: GhcMonad m => m GlobalRdrEnv +getGRE = withSession $ \hsc_env-> return $ icReaderEnv (hsc_IC hsc_env) + +-- | Retrieve all type and family instances in the environment, indexed +-- by 'Name'. Each name's lists will contain every instance in which that name +-- is mentioned in the instance head. +getNameToInstancesIndex :: GhcMonad m + => [Module] -- ^ visible modules. An orphan instance will be returned + -- if it is visible from at least one module in the list. + -> Maybe [Module] -- ^ modules to load. If this is not specified, we load + -- modules for everything that is in scope unqualified. + -> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst]))) +getNameToInstancesIndex visible_mods mods_to_load = do + hsc_env <- getSession + liftIO $ runTcInteractive hsc_env $ + do { case mods_to_load of + Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env) + Just mods -> + let doc = text "Need interface for reporting instances in scope" + in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods + + ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs + ; let visible_mods' = mkModuleSet visible_mods + ; (pkg_fie, home_fie) <- tcGetFamInstEnvs + -- We use Data.Sequence.Seq because we are creating left associated + -- mappends. + -- cls_index and fam_index below are adapted from GHC.Tc.Module.lookupInsts + ; let cls_index = Map.fromListWith mappend + [ (n, Seq.singleton ispec) + | ispec <- instEnvElts ie_local ++ instEnvElts ie_global + , instIsVisible visible_mods' ispec + , n <- nameSetElemsStable $ orphNamesOfClsInst ispec + ] + ; let fam_index = Map.fromListWith mappend + [ (n, Seq.singleton fispec) + | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie + , n <- nameSetElemsStable $ orphNamesOfFamInst fispec + ] + ; return $ mkNameEnv $ + [ (nm, (toList clss, toList fams)) + | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend + (fmap (,Seq.empty) cls_index) + (fmap (Seq.empty,) fam_index) + ] } + +-- ----------------------------------------------------------------------------- +-- Misc exported utils + +dataConType :: DataCon -> Type +dataConType dc = idType (dataConWrapId dc) + +-- | print a 'NamedThing', adding parentheses if the name is an operator. +pprParenSymName :: NamedThing a => a -> SDoc +pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) + +-- ---------------------------------------------------------------------------- + + +-- ToDo: +-- - Data and Typeable instances for HsSyn. + +-- ToDo: check for small transformations that happen to the syntax in +-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) + +-- ToDo: maybe use TH syntax instead of Iface syntax? There's already a way +-- to get from TyCons, Ids etc. to TH syntax (reify). + +-- :browse will use either lm_toplev or inspect lm_interface, depending +-- on whether the module is interpreted or not. + + +-- Extract the filename, stringbuffer content and dynflags associed to a ModSummary +-- Given an initialised GHC session a ModSummary can be retrieved for +-- a module by using 'getModSummary' +-- +-- XXX: Explain pre-conditions +getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags) +getModuleSourceAndFlags m = do + case ml_hs_file $ ms_location m of + Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m)) + Just sourceFile -> do + source <- hGetStringBuffer sourceFile + return (sourceFile, source, ms_hspp_opts m) + + +-- | Return module source as token stream, including comments. +-- +-- A 'Module' can be turned into a 'ModSummary' using 'getModSummary' if +-- your session is fully initialised. +-- Throws a 'GHC.Driver.Env.SourceError' on parse error. +getTokenStream :: ModSummary -> IO [Located Token] +getTokenStream mod = do + (sourceFile, source, dflags) <- getModuleSourceAndFlags mod + let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 + case lexTokenStream (initParserOpts dflags) source startLoc of + POk _ ts -> return ts + PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst) + +-- | Give even more information on the source than 'getTokenStream' +-- This function allows reconstructing the source completely with +-- 'showRichTokenStream'. +getRichTokenStream :: ModSummary -> IO [(Located Token, String)] +getRichTokenStream mod = do + (sourceFile, source, dflags) <- getModuleSourceAndFlags mod + let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 + case lexTokenStream (initParserOpts dflags) source startLoc of + POk _ ts -> return $ addSourceToTokens startLoc source ts + PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst) + +-- | Given a source location and a StringBuffer corresponding to this +-- location, return a rich token stream with the source associated to the +-- tokens. +addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] + -> [(Located Token, String)] +addSourceToTokens _ _ [] = [] +addSourceToTokens loc buf (t@(L span _) : ts) + = case span of + UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts + RealSrcSpan s _ -> (t,str) : addSourceToTokens newLoc newBuf ts + where + (newLoc, newBuf, str) = go "" loc buf + start = realSrcSpanStart s + end = realSrcSpanEnd s + go acc loc buf | loc < start = go acc nLoc nBuf + | start <= loc && loc < end = go (ch:acc) nLoc nBuf + | otherwise = (loc, buf, reverse acc) + where (ch, nBuf) = nextChar buf + nLoc = advanceSrcLoc loc ch + + +-- | Take a rich token stream such as produced from 'getRichTokenStream' and +-- return source code almost identical to the original code (except for +-- insignificant whitespace.) +showRichTokenStream :: [(Located Token, String)] -> String +showRichTokenStream ts = go startLoc ts "" + where sourceFile = getFile $ map (getLoc . fst) ts + getFile [] = panic "showRichTokenStream: No source file found" + getFile (UnhelpfulSpan _ : xs) = getFile xs + getFile (RealSrcSpan s _ : _) = srcSpanFile s + startLoc = mkRealSrcLoc sourceFile 1 1 + go _ [] = id + go loc ((L span _, str):ts) + = case span of + UnhelpfulSpan _ -> go loc ts + RealSrcSpan s _ + | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) + . (str ++) + . go tokEnd ts + | otherwise -> ((replicate (tokLine - locLine) '\n') ++) + . ((replicate (tokCol - 1) ' ') ++) + . (str ++) + . go tokEnd ts + where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) + (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s) + tokEnd = realSrcSpanEnd s + +-- ----------------------------------------------------------------------------- +-- Interactive evaluation + +-- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the +-- filesystem and package database to find the corresponding 'Module', +-- using the algorithm that is used for an @import@ declaration. +findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module +findModule mod_name maybe_pkg = do + pkg_qual <- renamePkgQualM mod_name maybe_pkg + findQualifiedModule pkg_qual mod_name + + +findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module +findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do + liftIO $ trace_if (hsc_logger hsc_env) (text "findQualifiedModule" <+> ppr mod_name <+> ppr pkgqual) + let mhome_unit = hsc_home_unit_maybe hsc_env + let dflags = hsc_dflags hsc_env + case pkgqual of + ThisPkg uid -> do + home <- lookupLoadedHomeModule uid mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + res <- findImportedModule hsc_env mod_name pkgqual + case res of + Found loc m | notHomeModuleMaybe mhome_unit m -> return m + | otherwise -> modNotLoadedError dflags m loc + err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err + + _ -> liftIO $ do + res <- findImportedModule hsc_env mod_name pkgqual + case res of + Found _ m -> return m + err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err + + +modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a +modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ + text "module is not loaded:" <+> + quotes (ppr (moduleName m)) <+> + parens (text (expectJust (ml_hs_file loc))) + +renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual +renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p) + +renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual +renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p) + +-- | Like 'findModule', but differs slightly when the module refers to +-- a source file, and the file has not been loaded via 'load'. In +-- this case, 'findModule' will throw an error (module not loaded), +-- but 'lookupModule' will check to see whether the module can also be +-- found in a package, and if so, that package 'Module' will be +-- returned. If not, the usual module-not-found error will be thrown. +-- +lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module +lookupModule mod_name maybe_pkg = do + pkgqual <- renamePkgQualM mod_name maybe_pkg + lookupQualifiedModule pkgqual mod_name + +lookupQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module +lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do + home <- lookupLoadedHomeModule (homeUnitId $ hsc_home_unit hsc_env) mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + let fc = hsc_FC hsc_env + let units = hsc_units hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + res <- findExposedPackageModule fc fopts units mod_name NoPkgQual + case res of + Found _ m -> return m + err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err +lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name + +lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module) +lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> liftIO $ do + trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModule" <+> ppr mod_name <+> ppr uid) + HUG.lookupHug (hsc_HUG hsc_env) uid mod_name >>= \case + Just mod_info -> return (Just (mi_module (hm_iface mod_info))) + _not_a_home_module -> return Nothing + +-- | Lookup the given 'ModuleName' in the 'HomeUnitGraph'. +-- +-- Returns 'Nothing' if no 'Module' has the given 'ModuleName'. +-- Otherwise, returns all 'Module's that have the given 'ModuleName'. +-- +-- A 'ModuleName' is generally not enough to uniquely identify a 'Module', since +-- there can be multiple units exposing the same 'ModuleName' in the case of +-- multiple home units. +-- Thus, this function may return more than one possible 'Module'. +-- We leave it up to the caller to decide how to handle the ambiguity. +-- For example, GHCi may prompt the user to clarify which 'Module' is the correct one. +-- +lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe [Module]) +lookupLoadedHomeModuleByModuleName mod_name = withSession $ \hsc_env -> liftIO $ do + trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModuleByModuleName" <+> ppr mod_name) + HUG.lookupAllHug (hsc_HUG hsc_env) mod_name >>= \case + [] -> return Nothing + mod_infos -> return (Just (mi_module . hm_iface <$> mod_infos)) + +-- | Given a 'ModuleName' and 'PkgQual', lookup all 'Module's that may fit the criteria. +-- +-- Identically to 'lookupLoadedHomeModuleByModuleName', there may be more than one +-- 'Module' in the 'HomeUnitGraph' that has the given 'ModuleName'. +-- +-- The result is guaranteed to be non-empty, if no 'Module' can be found, +-- this function throws an error. +lookupAllQualifiedModuleNames :: GhcMonad m => PkgQual -> ModuleName -> m [Module] +lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do + home <- lookupLoadedHomeModuleByModuleName mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + let fc = hsc_FC hsc_env + let units = hsc_units hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + res <- findExposedPackageModule fc fopts units mod_name NoPkgQual + case res of + Found _ m -> return [m] + err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err +lookupAllQualifiedModuleNames pkgqual mod_name = do + m <- findQualifiedModule pkgqual mod_name + pure [m] + +-- | Check that a module is safe to import (according to Safe Haskell). +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an error may be thrown first. +isModuleTrusted :: GhcMonad m => Module -> m Bool +isModuleTrusted m = withSession $ \hsc_env -> + liftIO $ hscCheckSafe hsc_env m noSrcSpan + +-- | Return if a module is trusted and the pkgs it depends on to be trusted. +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId) +moduleTrustReqs m = withSession $ \hsc_env -> + liftIO $ hscGetSafe hsc_env m noSrcSpan + +-- | Set the monad GHCi lifts user statements into. +-- +-- Checks that a type (in string form) is an instance of the +-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is, +-- throws an error otherwise. +setGHCiMonad :: GhcMonad m => String -> m () +setGHCiMonad name = withSession $ \hsc_env -> do + ty <- liftIO $ hscIsGHCiMonad hsc_env name + modifySession $ \s -> + let ic = (hsc_IC s) { ic_monad = ty } + in s { hsc_IC = ic } + +-- | Get the monad GHCi lifts user statements into. +getGHCiMonad :: GhcMonad m => m Name +getGHCiMonad = fmap (ic_monad . hsc_IC) getSession + +getHistorySpan :: GhcMonad m => History -> m SrcSpan +getHistorySpan h = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.getHistorySpan (hsc_HUG hsc_env) h + +obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term +obtainTermFromVal bound force ty a = withSession $ \hsc_env -> + liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a + +obtainTermFromId :: GhcMonad m + => Int -- ^ How many times to recurse for subterms + -> Bool -- ^ Whether to force the expression + -> Id + -> m Term +obtainTermFromId bound force id = withSession $ \hsc_env -> + liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id + + +-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any +-- entity known to GHC, including 'Name's defined using 'runStmt'. +lookupName :: GhcMonad m => Name -> m (Maybe TyThing) +lookupName name = + withSession $ \hsc_env -> + liftIO $ hscTcRcLookupName hsc_env name + +-- ----------------------------------------------------------------------------- +-- Pure API + +-- | A pure interface to the module parser. +-- +parser :: String -- ^ Haskell module source text (full Unicode is supported) + -> DynFlags -- ^ the flags + -> FilePath -- ^ the filename (for source locations) + -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs))) + +parser str dflags filename = + let + loc = mkRealSrcLoc (mkFastString filename) 1 1 + buf = stringToStringBuffer str + in + case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of + + PFailed pst -> + let (warns,errs) = getPsMessages pst in + (GhcPsMessage <$> warns, Left $ GhcPsMessage <$> errs) + + POk pst rdr_module -> + let (warns,_) = getPsMessages pst in + (GhcPsMessage <$> warns, Right rdr_module) + +-- ----------------------------------------------------------------------------- +-- | Find the package environment (if one exists) +-- +-- We interpret the package environment as a set of package flags; to be +-- specific, if we find a package environment file like +-- +-- > clear-package-db +-- > global-package-db +-- > package-db blah/package.conf.d +-- > package-id id1 +-- > package-id id2 +-- +-- we interpret this as +-- +-- > [ -hide-all-packages +-- > , -clear-package-db +-- > , -global-package-db +-- > , -package-db blah/package.conf.d +-- > , -package-id id1 +-- > , -package-id id2 +-- > ] +-- +-- There's also an older syntax alias for package-id, which is just an +-- unadorned package id +-- +-- > id1 +-- > id2 +-- +interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags +interpretPackageEnv logger dflags = do + mPkgEnv <- runMaybeT $ msum $ [ + getCmdLineArg >>= \env -> msum [ + probeNullEnv env + , probeEnvFile env + , probeEnvName env + , cmdLineError env + ] + , getEnvVar >>= \env -> msum [ + probeNullEnv env + , probeEnvFile env + , probeEnvName env + , envError env + ] + , notIfHideAllPackages >> msum [ + findLocalEnvFile >>= probeEnvFile + , probeEnvName defaultEnvName + ] + ] + case mPkgEnv of + Nothing -> + -- No environment found. Leave DynFlags unchanged. + return dflags + Just "-" -> do + -- Explicitly disabled environment file. Leave DynFlags unchanged. + return dflags + Just envfile -> do + content <- readFile envfile + compilationProgressMsg logger (text "Loaded package environment from " <> text envfile) + let (_, dflags') = runCmdLineP (runEwM (setFlagsFromEnvFile envfile content)) dflags + + return dflags' + where + -- Loading environments (by name or by location) + + archOS = platformArchOS (targetPlatform dflags) + + namedEnvPath :: String -> MaybeT IO FilePath + namedEnvPath name = do + appdir <- versionedAppDir (programName dflags) archOS + return $ appdir "environments" name + + probeEnvName :: String -> MaybeT IO FilePath + probeEnvName name = probeEnvFile =<< namedEnvPath name + + probeEnvFile :: FilePath -> MaybeT IO FilePath + probeEnvFile path = do + guard =<< liftMaybeT (doesFileExist path) + return path + + probeNullEnv :: FilePath -> MaybeT IO FilePath + probeNullEnv "-" = return "-" + probeNullEnv _ = mzero + + -- Various ways to define which environment to use + + getCmdLineArg :: MaybeT IO String + getCmdLineArg = MaybeT $ return $ packageEnv dflags + + getEnvVar :: MaybeT IO String + getEnvVar = do + mvar <- liftMaybeT $ MC.try $ getEnv "GHC_ENVIRONMENT" + case mvar of + Right var -> return var + Left err -> if isDoesNotExistError err then mzero + else liftMaybeT $ throwIO err + + notIfHideAllPackages :: MaybeT IO () + notIfHideAllPackages = + guard (not (gopt Opt_HideAllPackages dflags)) + + defaultEnvName :: String + defaultEnvName = "default" + + -- e.g. .ghc.environment.x86_64-linux-7.6.3 + localEnvFileName :: FilePath + localEnvFileName = ".ghc.environment" <.> versionedFilePath archOS + + -- Search for an env file, starting in the current dir and looking upwards. + -- Fail if we get to the users home dir or the filesystem root. That is, + -- we don't look for an env file in the user's home dir. The user-wide + -- env lives in ghc's versionedAppDir/environments/default + findLocalEnvFile :: MaybeT IO FilePath + findLocalEnvFile = do + curdir <- liftMaybeT getCurrentDirectory + homedir <- tryMaybeT getHomeDirectory + let probe dir | isDrive dir || dir == homedir + = mzero + probe dir = do + let file = dir localEnvFileName + exists <- liftMaybeT (doesFileExist file) + if exists + then return file + else probe (takeDirectory dir) + probe curdir + + -- Error reporting + + cmdLineError :: String -> MaybeT IO a + cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ + "Package environment " ++ show env ++ " not found" + + envError :: String -> MaybeT IO a + envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ + "Package environment " + ++ show env + ++ " (specified in GHC_ENVIRONMENT) not found" + +-- | An error thrown if the GHC API is used in an incorrect fashion. +newtype GhcApiError = GhcApiError String + +instance Show GhcApiError where + show (GhcApiError msg) = msg + +instance Exception GhcApiError + +mkApiErr :: DynFlags -> SDoc -> GhcApiError +mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) + + +#if !defined(javascript_HOST_ARCH) +foreign import ccall unsafe "keepCAFsForGHCi" + c_keepCAFsForGHCi :: IO Bool +#endif diff --git a/GHC/Builtin/Names.hs b/GHC/Builtin/Names.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Names.hs @@ -0,0 +1,2777 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[GHC.Builtin.Names]{Definitions of prelude modules and names} + + +Nota Bene: all Names defined in here should come from the base package, +the big-num package or (for plugins) the ghc package. + + - ModuleNames for prelude modules, + e.g. pRELUDE_NAME :: ModuleName + + - Modules for prelude modules + e.g. pRELUDE :: Module + + - Uniques for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. orderingTyConKey :: Unique + minusClassOpKey :: Unique + + - Names for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. orderingTyConName :: Name + minusName :: Name + One of these Names contains + (a) the module and occurrence name of the thing + (b) its Unique + The way the compiler "knows about" one of these things is + where the type checker or desugarer needs to look it up. For + example, when desugaring list comprehensions the desugarer + needs to conjure up 'foldr'. It does this by looking up + foldrName in the environment. + + - RdrNames for Ids, DataCons etc that the compiler may emit into + generated code (e.g. for deriving). + e.g. and_RDR :: RdrName + It's not necessary to know the uniques for these guys, only their names + + +Note [Known-key names] +~~~~~~~~~~~~~~~~~~~~~~ +It is *very* important that the compiler gives wired-in things and +things with "known-key" names the correct Uniques wherever they +occur. We have to be careful about this in exactly two places: + + 1. When we parse some source code, renaming the AST better yield an + AST whose Names have the correct uniques + + 2. When we read an interface file, the read-in gubbins better have + the right uniques + +This is accomplished through a combination of mechanisms: + + 1. When parsing source code, the RdrName-decorated AST has some + RdrNames which are Exact. These are wired-in RdrNames where + we could directly tell from the parsed syntax what Name to + use. For example, when we parse a [] in a type and ListTuplePuns + are enabled, we can just insert (Exact listTyConName :: RdrName). + + This is just an optimisation: it would be equally valid to output + Orig RdrNames that correctly record the module (and package) that + we expect the final Name to come from. The name would be looked up + in the OrigNameCache (see point 3). + + 2. The knownKeyNames (which consist of the basicKnownKeyNames from + the module, and those names reachable via the wired-in stuff from + GHC.Builtin.Types) are used to initialise the "OrigNameCache" in + GHC.Iface.Env. This initialization ensures that when the type checker + or renamer (both of which use GHC.Iface.Env) look up an original name + (i.e. a pair of a Module and an OccName) for a known-key name + they get the correct Unique. + + This is the most important mechanism for ensuring that known-key + stuff gets the right Unique, and is why it is so important to + place your known-key names in the appropriate lists. + + 3. For "infinite families" of known-key names (i.e. tuples and sums), we + have to be extra careful. Because there are an infinite number of + these things, we cannot add them to the list of known-key names + used to initialise the OrigNameCache. Instead, lookupOrigNameCache pretends + that these names are in the cache by using isInfiniteFamilyOrigName_maybe + before the actual lookup. + See Note [Infinite families of known-key names] for details. + + +Note [Infinite families of known-key names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Infinite families of known-key things (e.g. tuples and sums) pose a tricky +problem: we can't add them to the knownKeyNames finite map which we use to +ensure that, e.g., a reference to (,) gets assigned the right unique (if this +doesn't sound familiar see Note [Known-key names] above). + +We instead handle tuples and sums separately from the "vanilla" known-key +things, + + a) The parser recognises them specially and generates an Exact Name (hence not + looked up in the orig-name cache) + + b) The known infinite families of names are specially serialised by + GHC.Iface.Binary.putName, with that special treatment detected when we read + back to ensure that we get back to the correct uniques. + See Note [Symbol table representation of names] in GHC.Iface.Binary and + Note [How tuples work] in GHC.Builtin.Types. + + c) GHC.Iface.Env.lookupOrigNameCache uses isInfiniteFamilyOrigName_maybe to + map tuples and sums onto their exact names, rather than trying to find them + in the original-name cache. + See also Note [Built-in syntax and the OrigNameCache] + +-} + +{-# LANGUAGE CPP #-} + +module GHC.Builtin.Names + ( Unique, Uniquable(..), hasKey, -- Re-exported for convenience + + ----------------------------------------------------------- + module GHC.Builtin.Names, -- A huge bunch of (a) Names, e.g. intTyConName + -- (b) Uniques e.g. intTyConKey + -- (c) Groups of classes and types + -- (d) miscellaneous things + -- So many that we export them all + ) +where + +import GHC.Prelude + +import GHC.Unit.Types +import GHC.Types.Name.Occurrence +import GHC.Types.Name.Reader +import GHC.Types.Unique +import GHC.Builtin.Uniques +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Data.FastString +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf + +import Language.Haskell.Syntax.Module.Name + +{- +************************************************************************ +* * + allNameStrings +* * +************************************************************************ +-} + +allNameStrings :: Infinite String +-- Infinite list of a,b,c...z, aa, ab, ac, ... etc +allNameStrings = Inf.allListsOf ['a'..'z'] + +allNameStringList :: [String] +-- Infinite list of a,b,c...z, aa, ab, ac, ... etc +allNameStringList = Inf.toList allNameStrings + +{- +************************************************************************ +* * +\subsection{Local Names} +* * +************************************************************************ + +This *local* name is used by the interactive stuff +-} + +itName :: Unique -> SrcSpan -> Name +itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc + +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: OccName -> Name +mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan + +isUnboundName :: Name -> Bool +isUnboundName name = name `hasKey` unboundKey + +{- +************************************************************************ +* * +\subsection{Known key Names} +* * +************************************************************************ + +This section tells what the compiler knows about the association of +names with uniques. These ones are the *non* wired-in ones. The +wired in ones are defined in GHC.Builtin.Types etc. +-} + +basicKnownKeyNames :: [Name] -- See Note [Known-key names] +basicKnownKeyNames + = genericTyConNames + ++ [ -- Classes. *Must* include: + -- classes that are grabbed by key (e.g., eqClassKey) + -- classes in "Class.standardClassKeys" (quite a few) + eqClassName, -- mentioned, derivable + ordClassName, -- derivable + boundedClassName, -- derivable + numClassName, -- mentioned, numeric + enumClassName, -- derivable + monadClassName, + functorClassName, + realClassName, -- numeric + integralClassName, -- numeric + fractionalClassName, -- numeric + floatingClassName, -- numeric + realFracClassName, -- numeric + realFloatClassName, -- numeric + dataClassName, + isStringClassName, + applicativeClassName, + alternativeClassName, + foldableClassName, + traversableClassName, + semigroupClassName, sappendName, + monoidClassName, memptyName, mappendName, mconcatName, + + -- The IO type + ioTyConName, ioDataConName, + runMainIOName, + runRWName, + + -- Type representation types + trModuleTyConName, trModuleDataConName, + trNameTyConName, trNameSDataConName, trNameDDataConName, + trTyConTyConName, trTyConDataConName, + + -- Typeable + typeableClassName, + typeRepTyConName, + someTypeRepTyConName, + someTypeRepDataConName, + kindRepTyConName, + kindRepTyConAppDataConName, + kindRepVarDataConName, + kindRepAppDataConName, + kindRepFunDataConName, + kindRepTYPEDataConName, + kindRepTypeLitSDataConName, + kindRepTypeLitDDataConName, + typeLitSortTyConName, + typeLitSymbolDataConName, + typeLitNatDataConName, + typeLitCharDataConName, + typeRepIdName, + mkTrTypeName, + mkTrConName, + mkTrAppCheckedName, + mkTrFunName, + typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName, + trGhcPrimModuleName, + + -- KindReps for common cases + starKindRepName, + starArrStarKindRepName, + starArrStarArrStarKindRepName, + constraintKindRepName, + + -- WithDict + withDictClassName, + + -- DataToTag + dataToTagClassName, + + -- seq# + seqHashName, + + -- Dynamic + toDynName, + + -- Numeric stuff + negateName, minusName, geName, eqName, + mkRationalBase2Name, mkRationalBase10Name, + + -- Conversion functions + rationalTyConName, + ratioTyConName, ratioDataConName, + fromRationalName, fromIntegerName, + toIntegerName, toRationalName, + fromIntegralName, realToFracName, + + -- Int# stuff + divIntName, modIntName, + + -- String stuff + fromStringName, + + -- Enum stuff + enumFromName, enumFromThenName, + enumFromThenToName, enumFromToName, + + -- Applicative stuff + pureAName, apAName, thenAName, + + -- Functor stuff + fmapName, + + -- Monad stuff + thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName, + returnMName, joinMName, + + -- MonadFail + monadFailClassName, failMName, + + -- MonadFix + monadFixClassName, mfixName, + + -- Arrow stuff + arrAName, composeAName, firstAName, + appAName, choiceAName, loopAName, + + -- Ix stuff + ixClassName, + + -- Show stuff + showClassName, + + -- Read stuff + readClassName, + + -- Stable pointers + newStablePtrName, + + -- GHC Extensions + considerAccessibleName, + + -- Strings and lists + unpackCStringName, unpackCStringUtf8Name, + unpackCStringAppendName, unpackCStringAppendUtf8Name, + unpackCStringFoldrName, unpackCStringFoldrUtf8Name, + cstringLengthName, + + -- Overloaded lists + isListClassName, + fromListName, + fromListNName, + toListName, + + -- Non-empty lists + nonEmptyTyConName, + + -- Overloaded record dot, record update + getFieldName, setFieldName, + + -- List operations + concatName, filterName, mapName, + zipName, foldrName, buildName, augmentName, appendName, + + -- FFI primitive types that are not wired-in. + stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName, + int8TyConName, int16TyConName, int32TyConName, int64TyConName, + word8TyConName, word16TyConName, word32TyConName, word64TyConName, + jsvalTyConName, + + -- Others + otherwiseIdName, inlineIdName, + eqStringName, assertName, + assertErrorName, traceName, + printName, + dollarName, + + -- ghc-bignum + integerFromNaturalName, + integerToNaturalClampName, + integerToNaturalThrowName, + integerToNaturalName, + integerToWordName, + integerToIntName, + integerToWord64Name, + integerToInt64Name, + integerFromWordName, + integerFromWord64Name, + integerFromInt64Name, + integerAddName, + integerMulName, + integerSubName, + integerNegateName, + integerAbsName, + integerPopCountName, + integerQuotName, + integerRemName, + integerDivName, + integerModName, + integerDivModName, + integerQuotRemName, + integerEncodeFloatName, + integerEncodeDoubleName, + integerGcdName, + integerLcmName, + integerAndName, + integerOrName, + integerXorName, + integerComplementName, + integerBitName, + integerTestBitName, + integerShiftLName, + integerShiftRName, + + naturalToWordName, + naturalPopCountName, + naturalShiftRName, + naturalShiftLName, + naturalAddName, + naturalSubName, + naturalSubThrowName, + naturalSubUnsafeName, + naturalMulName, + naturalQuotRemName, + naturalQuotName, + naturalRemName, + naturalAndName, + naturalAndNotName, + naturalOrName, + naturalXorName, + naturalTestBitName, + naturalBitName, + naturalGcdName, + naturalLcmName, + naturalLog2Name, + naturalLogBaseWordName, + naturalLogBaseName, + naturalPowModName, + naturalSizeInBaseName, + + bignatEqName, + + -- Float/Double + integerToFloatName, + integerToDoubleName, + naturalToFloatName, + naturalToDoubleName, + rationalToFloatName, + rationalToDoubleName, + + -- Other classes + monadPlusClassName, + + -- Type-level naturals + knownNatClassName, knownSymbolClassName, knownCharClassName, + + -- Overloaded labels + fromLabelClassOpName, + + -- Implicit Parameters + ipClassName, + + -- Overloaded record fields + hasFieldClassName, + + -- ExceptionContext + exceptionContextTyConName, + emptyExceptionContextName, + + -- Call Stacks + callStackTyConName, + emptyCallStackName, pushCallStackName, + + -- Source Locations + srcLocDataConName, + + -- Annotation type checking + toAnnotationWrapperName + + -- The SPEC type for SpecConstr + , specTyConName + + -- The Either type + , eitherTyConName, leftDataConName, rightDataConName + + -- The Void type + , voidTyConName + + -- Plugins + , pluginTyConName + , frontendPluginTyConName + + -- Generics + , genClassName, gen1ClassName + , datatypeClassName, constructorClassName, selectorClassName + + -- Monad comprehensions + , guardMName + , liftMName + , mzipName + + -- GHCi Sandbox + , ghciIoClassName, ghciStepIoMName + + -- StaticPtr + , makeStaticName + , staticPtrTyConName + , staticPtrDataConName, staticPtrInfoDataConName + , fromStaticPtrName + + -- Fingerprint + , fingerprintDataConName + + -- Custom type errors + , errorMessageTypeErrorFamName + , typeErrorTextDataConName + , typeErrorAppendDataConName + , typeErrorVAppendDataConName + , typeErrorShowTypeDataConName + + -- "Unsatisfiable" constraint + , unsatisfiableClassName + , unsatisfiableIdName + + -- Unsafe coercion proofs + , unsafeEqualityProofName + , unsafeEqualityTyConName + , unsafeReflDataConName + , unsafeCoercePrimName + + , unsafeUnpackJSStringUtf8ShShName + ] + +genericTyConNames :: [Name] +genericTyConNames = [ + v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, + d1TyConName, c1TyConName, s1TyConName, + repTyConName, rep1TyConName, uRecTyConName, + uAddrTyConName, uCharTyConName, uDoubleTyConName, + uFloatTyConName, uIntTyConName, uWordTyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + sourceUnpackDataConName, sourceNoUnpackDataConName, + noSourceUnpackednessDataConName, sourceLazyDataConName, + sourceStrictDataConName, noSourceStrictnessDataConName, + decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName + ] + +{- +************************************************************************ +* * +\subsection{Module names} +* * +************************************************************************ + + +--MetaHaskell Extension Add a new module here +-} + +gHC_PRIM, gHC_PRIM_PANIC, + gHC_TYPES, gHC_INTERNAL_DATA_DATA, gHC_MAGIC, gHC_MAGIC_DICT, + gHC_CLASSES, gHC_PRIMOPWRAPPERS :: Module +gHC_PRIM = mkGhcInternalModule (fsLit "GHC.Internal.Prim") -- Primitive types and values +gHC_PRIM_PANIC = mkGhcInternalModule (fsLit "GHC.Internal.Prim.Panic") +gHC_TYPES = mkGhcInternalModule (fsLit "GHC.Internal.Types") +gHC_MAGIC = mkGhcInternalModule (fsLit "GHC.Internal.Magic") +gHC_MAGIC_DICT = mkGhcInternalModule (fsLit "GHC.Internal.Magic.Dict") +gHC_CSTRING = mkGhcInternalModule (fsLit "GHC.Internal.CString") +gHC_CLASSES = mkGhcInternalModule (fsLit "GHC.Internal.Classes") +gHC_PRIMOPWRAPPERS = mkGhcInternalModule (fsLit "GHC.Internal.PrimopWrappers") +gHC_INTERNAL_TUPLE = mkGhcInternalModule (fsLit "GHC.Internal.Tuple") + +gHC_INTERNAL_CONTROL_MONAD_ZIP :: Module +gHC_INTERNAL_CONTROL_MONAD_ZIP = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Zip") + +gHC_INTERNAL_NUM_INTEGER, gHC_INTERNAL_NUM_NATURAL, gHC_INTERNAL_NUM_BIGNAT :: Module +gHC_INTERNAL_NUM_INTEGER = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.Integer") +gHC_INTERNAL_NUM_NATURAL = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.Natural") +gHC_INTERNAL_NUM_BIGNAT = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.BigNat") + +gHC_INTERNAL_BASE, gHC_INTERNAL_ENUM, + gHC_INTERNAL_GHCI, gHC_INTERNAL_GHCI_HELPERS, gHC_CSTRING, gHC_INTERNAL_DATA_STRING, + gHC_INTERNAL_SHOW, gHC_INTERNAL_READ, gHC_INTERNAL_NUM, gHC_INTERNAL_MAYBE, + gHC_INTERNAL_LIST, gHC_INTERNAL_TUPLE, gHC_INTERNAL_DATA_EITHER, + gHC_INTERNAL_DATA_FOLDABLE, gHC_INTERNAL_DATA_TRAVERSABLE, + gHC_INTERNAL_EXCEPTION_CONTEXT, + gHC_INTERNAL_CONC, gHC_INTERNAL_IO, gHC_INTERNAL_IO_Exception, + gHC_INTERNAL_ST, gHC_INTERNAL_IX, gHC_INTERNAL_STABLE, gHC_INTERNAL_PTR, gHC_INTERNAL_ERR, gHC_INTERNAL_REAL, + gHC_INTERNAL_FLOAT, gHC_INTERNAL_TOP_HANDLER, gHC_INTERNAL_SYSTEM_IO, gHC_INTERNAL_DYNAMIC, + gHC_INTERNAL_TYPEABLE, gHC_INTERNAL_TYPEABLE_INTERNAL, gHC_INTERNAL_GENERICS, + gHC_INTERNAL_READ_PREC, gHC_INTERNAL_LEX, gHC_INTERNAL_INT, gHC_INTERNAL_WORD, gHC_INTERNAL_MONAD, gHC_INTERNAL_MONAD_FIX, gHC_INTERNAL_MONAD_FAIL, + gHC_INTERNAL_ARROW, gHC_INTERNAL_DESUGAR, gHC_INTERNAL_RANDOM, gHC_INTERNAL_EXTS, gHC_INTERNAL_IS_LIST, + gHC_INTERNAL_CONTROL_EXCEPTION_BASE, gHC_INTERNAL_TYPEERROR, gHC_INTERNAL_TYPELITS, gHC_INTERNAL_TYPELITS_INTERNAL, + gHC_INTERNAL_TYPENATS, gHC_INTERNAL_TYPENATS_INTERNAL, + gHC_INTERNAL_DATA_COERCE, gHC_INTERNAL_DEBUG_TRACE, gHC_INTERNAL_UNSAFE_COERCE, gHC_INTERNAL_FOREIGN_C_CONSTPTR, + gHC_INTERNAL_JS_PRIM, gHC_INTERNAL_WASM_PRIM_TYPES :: Module +gHC_INTERNAL_BASE = mkGhcInternalModule (fsLit "GHC.Internal.Base") +gHC_INTERNAL_ENUM = mkGhcInternalModule (fsLit "GHC.Internal.Enum") +gHC_INTERNAL_GHCI = mkGhcInternalModule (fsLit "GHC.Internal.GHCi") +gHC_INTERNAL_GHCI_HELPERS = mkGhcInternalModule (fsLit "GHC.Internal.GHCi.Helpers") +gHC_INTERNAL_SHOW = mkGhcInternalModule (fsLit "GHC.Internal.Show") +gHC_INTERNAL_READ = mkGhcInternalModule (fsLit "GHC.Internal.Read") +gHC_INTERNAL_NUM = mkGhcInternalModule (fsLit "GHC.Internal.Num") +gHC_INTERNAL_MAYBE = mkGhcInternalModule (fsLit "GHC.Internal.Maybe") +gHC_INTERNAL_LIST = mkGhcInternalModule (fsLit "GHC.Internal.List") +gHC_INTERNAL_DATA_EITHER = mkGhcInternalModule (fsLit "GHC.Internal.Data.Either") +gHC_INTERNAL_DATA_STRING = mkGhcInternalModule (fsLit "GHC.Internal.Data.String") +gHC_INTERNAL_DATA_FOLDABLE = mkGhcInternalModule (fsLit "GHC.Internal.Data.Foldable") +gHC_INTERNAL_DATA_TRAVERSABLE = mkGhcInternalModule (fsLit "GHC.Internal.Data.Traversable") +gHC_INTERNAL_CONC = mkGhcInternalModule (fsLit "GHC.Internal.GHC.Conc") +gHC_INTERNAL_IO = mkGhcInternalModule (fsLit "GHC.Internal.IO") +gHC_INTERNAL_IO_Exception = mkGhcInternalModule (fsLit "GHC.Internal.IO.Exception") +gHC_INTERNAL_ST = mkGhcInternalModule (fsLit "GHC.Internal.ST") +gHC_INTERNAL_IX = mkGhcInternalModule (fsLit "GHC.Internal.Ix") +gHC_INTERNAL_STABLE = mkGhcInternalModule (fsLit "GHC.Internal.Stable") +gHC_INTERNAL_PTR = mkGhcInternalModule (fsLit "GHC.Internal.Ptr") +gHC_INTERNAL_ERR = mkGhcInternalModule (fsLit "GHC.Internal.Err") +gHC_INTERNAL_REAL = mkGhcInternalModule (fsLit "GHC.Internal.Real") +gHC_INTERNAL_FLOAT = mkGhcInternalModule (fsLit "GHC.Internal.Float") +gHC_INTERNAL_TOP_HANDLER = mkGhcInternalModule (fsLit "GHC.Internal.TopHandler") +gHC_INTERNAL_SYSTEM_IO = mkGhcInternalModule (fsLit "GHC.Internal.System.IO") +gHC_INTERNAL_DYNAMIC = mkGhcInternalModule (fsLit "GHC.Internal.Data.Dynamic") +gHC_INTERNAL_TYPEABLE = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable") +gHC_INTERNAL_TYPEABLE_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable.Internal") +gHC_INTERNAL_DATA_DATA = mkGhcInternalModule (fsLit "GHC.Internal.Data.Data") +gHC_INTERNAL_READ_PREC = mkGhcInternalModule (fsLit "GHC.Internal.Text.ParserCombinators.ReadPrec") +gHC_INTERNAL_LEX = mkGhcInternalModule (fsLit "GHC.Internal.Text.Read.Lex") +gHC_INTERNAL_INT = mkGhcInternalModule (fsLit "GHC.Internal.Int") +gHC_INTERNAL_WORD = mkGhcInternalModule (fsLit "GHC.Internal.Word") +gHC_INTERNAL_MONAD = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad") +gHC_INTERNAL_MONAD_FIX = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fix") +gHC_INTERNAL_MONAD_FAIL = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fail") +gHC_INTERNAL_ARROW = mkGhcInternalModule (fsLit "GHC.Internal.Control.Arrow") +gHC_INTERNAL_DESUGAR = mkGhcInternalModule (fsLit "GHC.Internal.Desugar") +gHC_INTERNAL_RANDOM = mkGhcInternalModule (fsLit "GHC.Internal.System.Random") +gHC_INTERNAL_EXTS = mkGhcInternalModule (fsLit "GHC.Internal.Exts") +gHC_INTERNAL_IS_LIST = mkGhcInternalModule (fsLit "GHC.Internal.IsList") +gHC_INTERNAL_CONTROL_EXCEPTION_BASE = mkGhcInternalModule (fsLit "GHC.Internal.Control.Exception.Base") +gHC_INTERNAL_EXCEPTION_CONTEXT = mkGhcInternalModule (fsLit "GHC.Internal.Exception.Context") +gHC_INTERNAL_GENERICS = mkGhcInternalModule (fsLit "GHC.Internal.Generics") +gHC_INTERNAL_TYPEERROR = mkGhcInternalModule (fsLit "GHC.Internal.TypeError") +gHC_INTERNAL_TYPELITS = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits") +gHC_INTERNAL_TYPELITS_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits.Internal") +gHC_INTERNAL_TYPENATS = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats") +gHC_INTERNAL_TYPENATS_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats.Internal") +gHC_INTERNAL_DATA_COERCE = mkGhcInternalModule (fsLit "GHC.Internal.Data.Coerce") +gHC_INTERNAL_DEBUG_TRACE = mkGhcInternalModule (fsLit "GHC.Internal.Debug.Trace") +gHC_INTERNAL_UNSAFE_COERCE = mkGhcInternalModule (fsLit "GHC.Internal.Unsafe.Coerce") +gHC_INTERNAL_FOREIGN_C_CONSTPTR = mkGhcInternalModule (fsLit "GHC.Internal.Foreign.C.ConstPtr") +gHC_INTERNAL_JS_PRIM = mkGhcInternalModule (fsLit "GHC.Internal.JS.Prim") +gHC_INTERNAL_WASM_PRIM_TYPES = mkGhcInternalModule (fsLit "GHC.Internal.Wasm.Prim.Types") + +gHC_INTERNAL_SRCLOC :: Module +gHC_INTERNAL_SRCLOC = mkGhcInternalModule (fsLit "GHC.Internal.SrcLoc") + +gHC_INTERNAL_STACK, gHC_INTERNAL_STACK_TYPES :: Module +gHC_INTERNAL_STACK = mkGhcInternalModule (fsLit "GHC.Internal.Stack") +gHC_INTERNAL_STACK_TYPES = mkGhcInternalModule (fsLit "GHC.Internal.Stack.Types") + +gHC_INTERNAL_STATICPTR :: Module +gHC_INTERNAL_STATICPTR = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr") + +gHC_INTERNAL_STATICPTR_INTERNAL :: Module +gHC_INTERNAL_STATICPTR_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr.Internal") + +gHC_INTERNAL_FINGERPRINT_TYPE :: Module +gHC_INTERNAL_FINGERPRINT_TYPE = mkGhcInternalModule (fsLit "GHC.Internal.Fingerprint.Type") + +gHC_INTERNAL_OVER_LABELS :: Module +gHC_INTERNAL_OVER_LABELS = mkGhcInternalModule (fsLit "GHC.Internal.OverloadedLabels") + +gHC_INTERNAL_RECORDS :: Module +gHC_INTERNAL_RECORDS = mkGhcInternalModule (fsLit "GHC.Internal.Records") + +rOOT_MAIN :: Module +rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation + +mkInteractiveModule :: String -> Module +-- (mkInteractiveMoudule "9") makes module 'interactive:Ghci9' +mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ n)) + +pRELUDE_NAME, mAIN_NAME :: ModuleName +pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") +mAIN_NAME = mkModuleNameFS (fsLit "Main") + +mkGhcInternalModule :: FastString -> Module +mkGhcInternalModule m = mkGhcInternalModule_ (mkModuleNameFS m) + +mkGhcInternalModule_ :: ModuleName -> Module +mkGhcInternalModule_ m = mkModule ghcInternalUnit m + +mkThisGhcModule :: FastString -> Module +mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m) + +mkThisGhcModule_ :: ModuleName -> Module +mkThisGhcModule_ m = mkModule thisGhcUnit m + +mkMainModule :: FastString -> Module +mkMainModule m = mkModule mainUnit (mkModuleNameFS m) + +mkMainModule_ :: ModuleName -> Module +mkMainModule_ m = mkModule mainUnit m + +{- +************************************************************************ +* * + RdrNames +* * +************************************************************************ +-} + +main_RDR_Unqual :: RdrName +main_RDR_Unqual = mkUnqual varName (fsLit "main") + -- We definitely don't want an Orig RdrName, because + -- main might, in principle, be imported into module Main + +eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, + ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName +eq_RDR = nameRdrName eqName +ge_RDR = nameRdrName geName +le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") +lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") +gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") +compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") +ltTag_RDR = nameRdrName ordLTDataConName +eqTag_RDR = nameRdrName ordEQDataConName +gtTag_RDR = nameRdrName ordGTDataConName + +map_RDR, append_RDR :: RdrName +map_RDR = nameRdrName mapName +append_RDR = nameRdrName appendName + +foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR + :: RdrName +foldr_RDR = nameRdrName foldrName +build_RDR = nameRdrName buildName +returnM_RDR = nameRdrName returnMName +bindM_RDR = nameRdrName bindMName +failM_RDR = nameRdrName failMName + +left_RDR, right_RDR :: RdrName +left_RDR = nameRdrName leftDataConName +right_RDR = nameRdrName rightDataConName + +fromEnum_RDR, toEnum_RDR, toEnumError_RDR, succError_RDR, predError_RDR, enumIntToWord_RDR :: RdrName +fromEnum_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "fromEnum") +toEnum_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "toEnum") +toEnumError_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "toEnumError") +succError_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "succError") +predError_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "predError") +enumIntToWord_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "enumIntToWord") + +enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName +enumFrom_RDR = nameRdrName enumFromName +enumFromTo_RDR = nameRdrName enumFromToName +enumFromThen_RDR = nameRdrName enumFromThenName +enumFromThenTo_RDR = nameRdrName enumFromThenToName + +times_RDR, plus_RDR :: RdrName +times_RDR = varQual_RDR gHC_INTERNAL_NUM (fsLit "*") +plus_RDR = varQual_RDR gHC_INTERNAL_NUM (fsLit "+") + +compose_RDR :: RdrName +compose_RDR = varQual_RDR gHC_INTERNAL_BASE (fsLit ".") + +not_RDR, dataToTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR, + and_RDR, range_RDR, inRange_RDR, index_RDR, + unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName +and_RDR = varQual_RDR gHC_CLASSES (fsLit "&&") +not_RDR = varQual_RDR gHC_CLASSES (fsLit "not") +dataToTag_RDR = varQual_RDR gHC_MAGIC (fsLit "dataToTag#") +succ_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "succ") +pred_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "pred") +minBound_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "minBound") +maxBound_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "maxBound") +range_RDR = varQual_RDR gHC_INTERNAL_IX (fsLit "range") +inRange_RDR = varQual_RDR gHC_INTERNAL_IX (fsLit "inRange") +index_RDR = varQual_RDR gHC_INTERNAL_IX (fsLit "index") +unsafeIndex_RDR = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeIndex") +unsafeRangeSize_RDR = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeRangeSize") + +readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR, + readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName +readList_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readList") +readListDefault_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readListDefault") +readListPrec_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrec") +readListPrecDefault_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrecDefault") +readPrec_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readPrec") +parens_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "parens") +choose_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "choose") +lexP_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "lexP") +expectP_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "expectP") + +readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName +readField_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readField") +readFieldHash_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readFieldHash") +readSymField_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readSymField") + +punc_RDR, ident_RDR, symbol_RDR :: RdrName +punc_RDR = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Punc") +ident_RDR = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Ident") +symbol_RDR = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Symbol") + +step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName +step_RDR = varQual_RDR gHC_INTERNAL_READ_PREC (fsLit "step") +alt_RDR = varQual_RDR gHC_INTERNAL_READ_PREC (fsLit "+++") +reset_RDR = varQual_RDR gHC_INTERNAL_READ_PREC (fsLit "reset") +prec_RDR = varQual_RDR gHC_INTERNAL_READ_PREC (fsLit "prec") +pfail_RDR = varQual_RDR gHC_INTERNAL_READ_PREC (fsLit "pfail") + +showsPrec_RDR, shows_RDR, showString_RDR, + showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName +showsPrec_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showsPrec") +shows_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "shows") +showString_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showString") +showSpace_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showSpace") +showCommaSpace_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showCommaSpace") +showParen_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showParen") + +error_RDR :: RdrName +error_RDR = varQual_RDR gHC_INTERNAL_ERR (fsLit "error") + +-- Generics (constructors and functions) +u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, + k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, + prodDataCon_RDR, comp1DataCon_RDR, + unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, + from_RDR, from1_RDR, to_RDR, to1_RDR, + datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR, + conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR, + prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, + rightAssocDataCon_RDR, notAssocDataCon_RDR, + uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR, + uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR, + uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR, + uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName + +u1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "U1") +par1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1") +rec1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1") +k1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1") +m1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "M1") + +l1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "L1") +r1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "R1") + +prodDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit ":*:") +comp1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1") + +unPar1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1") (fsLit "unPar1") +unRec1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1") (fsLit "unRec1") +unK1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1") (fsLit "unK1") +unComp1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1") (fsLit "unComp1") + +from_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from") +from1_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from1") +to_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to") +to1_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to1") + +datatypeName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "datatypeName") +moduleName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "moduleName") +packageName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "packageName") +isNewtypeName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "isNewtype") +selName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "selName") +conName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conName") +conFixity_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conFixity") +conIsRecord_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conIsRecord") + +prefixDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Prefix") +infixDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Infix") +leftAssocDataCon_RDR = nameRdrName leftAssociativeDataConName +rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName +notAssocDataCon_RDR = nameRdrName notAssociativeDataConName + +uAddrDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr") +uCharDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar") +uDoubleDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble") +uFloatDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat") +uIntDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt") +uWordDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord") + +uAddrHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr") (fsLit "uAddr#") +uCharHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar") (fsLit "uChar#") +uDoubleHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble") (fsLit "uDouble#") +uFloatHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat") (fsLit "uFloat#") +uIntHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt") (fsLit "uInt#") +uWordHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord") (fsLit "uWord#") + +fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, + foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR, + mappend_RDR :: RdrName +fmap_RDR = nameRdrName fmapName +replace_RDR = varQual_RDR gHC_INTERNAL_BASE (fsLit "<$") +pure_RDR = nameRdrName pureAName +ap_RDR = nameRdrName apAName +liftA2_RDR = varQual_RDR gHC_INTERNAL_BASE (fsLit "liftA2") +foldable_foldr_RDR = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE (fsLit "foldr") +foldMap_RDR = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE (fsLit "foldMap") +null_RDR = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE (fsLit "null") +all_RDR = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE (fsLit "all") +traverse_RDR = varQual_RDR gHC_INTERNAL_DATA_TRAVERSABLE (fsLit "traverse") +mempty_RDR = nameRdrName memptyName +mappend_RDR = nameRdrName mappendName + +---------------------- +varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR + :: Module -> FastString -> RdrName +varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) +tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str) +clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str) +dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) + +fieldQual_RDR :: Module -> FastString -> FastString -> RdrName +fieldQual_RDR mod con str = mkOrig mod (mkOccNameFS (fieldName con) str) + +{- +************************************************************************ +* * +\subsection{Known-key names} +* * +************************************************************************ + +Many of these Names are not really "built in", but some parts of the +compiler (notably the deriving mechanism) need to mention their names, +and it's convenient to write them all down in one place. +-} + +wildCardName :: Name +wildCardName = mkSystemVarName wildCardKey (fsLit "wild") + +runMainIOName, runRWName :: Name +runMainIOName = varQual gHC_INTERNAL_TOP_HANDLER (fsLit "runMainIO") runMainKey +runRWName = varQual gHC_MAGIC (fsLit "runRW#") runRWKey + +orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name +orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey +ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey +ordEQDataConName = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey +ordGTDataConName = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey + +specTyConName :: Name +specTyConName = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey + +eitherTyConName, leftDataConName, rightDataConName :: Name +eitherTyConName = tcQual gHC_INTERNAL_DATA_EITHER (fsLit "Either") eitherTyConKey +leftDataConName = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Left") leftDataConKey +rightDataConName = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Right") rightDataConKey + +voidTyConName :: Name +voidTyConName = tcQual gHC_INTERNAL_BASE (fsLit "Void") voidTyConKey + +-- Generics (types) +v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, + d1TyConName, c1TyConName, s1TyConName, + repTyConName, rep1TyConName, uRecTyConName, + uAddrTyConName, uCharTyConName, uDoubleTyConName, + uFloatTyConName, uIntTyConName, uWordTyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + sourceUnpackDataConName, sourceNoUnpackDataConName, + noSourceUnpackednessDataConName, sourceLazyDataConName, + sourceStrictDataConName, noSourceStrictnessDataConName, + decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name + +v1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "V1") v1TyConKey +u1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "U1") u1TyConKey +par1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Par1") par1TyConKey +rec1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec1") rec1TyConKey +k1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "K1") k1TyConKey +m1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "M1") m1TyConKey + +sumTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit ":+:") sumTyConKey +prodTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit ":*:") prodTyConKey +compTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit ":.:") compTyConKey + +rTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "R") rTyConKey +dTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "D") dTyConKey +cTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "C") cTyConKey +sTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "S") sTyConKey + +rec0TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec0") rec0TyConKey +d1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "D1") d1TyConKey +c1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "C1") c1TyConKey +s1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "S1") s1TyConKey + +repTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep") repTyConKey +rep1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep1") rep1TyConKey + +uRecTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "URec") uRecTyConKey +uAddrTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UAddr") uAddrTyConKey +uCharTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UChar") uCharTyConKey +uDoubleTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UDouble") uDoubleTyConKey +uFloatTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UFloat") uFloatTyConKey +uIntTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UInt") uIntTyConKey +uWordTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UWord") uWordTyConKey + +prefixIDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "PrefixI") prefixIDataConKey +infixIDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "InfixI") infixIDataConKey +leftAssociativeDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey +rightAssociativeDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey +notAssociativeDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey + +sourceUnpackDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceUnpack") sourceUnpackDataConKey +sourceNoUnpackDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceNoUnpack") sourceNoUnpackDataConKey +noSourceUnpackednessDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey +sourceLazyDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceLazy") sourceLazyDataConKey +sourceStrictDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceStrict") sourceStrictDataConKey +noSourceStrictnessDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceStrictness") noSourceStrictnessDataConKey +decidedLazyDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedLazy") decidedLazyDataConKey +decidedStrictDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedStrict") decidedStrictDataConKey +decidedUnpackDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedUnpack") decidedUnpackDataConKey + +metaDataDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaData") metaDataDataConKey +metaConsDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaCons") metaConsDataConKey +metaSelDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaSel") metaSelDataConKey + +-- Primitive Int +divIntName, modIntName :: Name +divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey +modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey + +-- Base strings Strings +unpackCStringName, unpackCStringFoldrName, + unpackCStringUtf8Name, unpackCStringFoldrUtf8Name, + unpackCStringAppendName, unpackCStringAppendUtf8Name, + eqStringName, cstringLengthName :: Name +cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey +eqStringName = varQual gHC_INTERNAL_BASE (fsLit "eqString") eqStringIdKey + +unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey +unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey +unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey + +unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey +unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey +unpackCStringFoldrUtf8Name = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey + + +-- The 'inline' function +inlineIdName :: Name +inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey + +-- Base classes (Eq, Ord, Functor) +fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name +eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey +eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey +ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey +geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey +functorClassName = clsQual gHC_INTERNAL_BASE (fsLit "Functor") functorClassKey +fmapName = varQual gHC_INTERNAL_BASE (fsLit "fmap") fmapClassOpKey + +-- Class Monad +monadClassName, thenMName, bindMName, returnMName :: Name +monadClassName = clsQual gHC_INTERNAL_BASE (fsLit "Monad") monadClassKey +thenMName = varQual gHC_INTERNAL_BASE (fsLit ">>") thenMClassOpKey +bindMName = varQual gHC_INTERNAL_BASE (fsLit ">>=") bindMClassOpKey +returnMName = varQual gHC_INTERNAL_BASE (fsLit "return") returnMClassOpKey + +-- Class MonadFail +monadFailClassName, failMName :: Name +monadFailClassName = clsQual gHC_INTERNAL_MONAD_FAIL (fsLit "MonadFail") monadFailClassKey +failMName = varQual gHC_INTERNAL_MONAD_FAIL (fsLit "fail") failMClassOpKey + +-- Class Applicative +applicativeClassName, pureAName, apAName, thenAName :: Name +applicativeClassName = clsQual gHC_INTERNAL_BASE (fsLit "Applicative") applicativeClassKey +apAName = varQual gHC_INTERNAL_BASE (fsLit "<*>") apAClassOpKey +pureAName = varQual gHC_INTERNAL_BASE (fsLit "pure") pureAClassOpKey +thenAName = varQual gHC_INTERNAL_BASE (fsLit "*>") thenAClassOpKey + +-- Classes (Foldable, Traversable) +foldableClassName, traversableClassName :: Name +foldableClassName = clsQual gHC_INTERNAL_DATA_FOLDABLE (fsLit "Foldable") foldableClassKey +traversableClassName = clsQual gHC_INTERNAL_DATA_TRAVERSABLE (fsLit "Traversable") traversableClassKey + +-- Classes (Semigroup, Monoid) +semigroupClassName, sappendName :: Name +semigroupClassName = clsQual gHC_INTERNAL_BASE (fsLit "Semigroup") semigroupClassKey +sappendName = varQual gHC_INTERNAL_BASE (fsLit "<>") sappendClassOpKey +monoidClassName, memptyName, mappendName, mconcatName :: Name +monoidClassName = clsQual gHC_INTERNAL_BASE (fsLit "Monoid") monoidClassKey +memptyName = varQual gHC_INTERNAL_BASE (fsLit "mempty") memptyClassOpKey +mappendName = varQual gHC_INTERNAL_BASE (fsLit "mappend") mappendClassOpKey +mconcatName = varQual gHC_INTERNAL_BASE (fsLit "mconcat") mconcatClassOpKey + + + +-- AMP additions + +joinMName, alternativeClassName :: Name +joinMName = varQual gHC_INTERNAL_BASE (fsLit "join") joinMIdKey +alternativeClassName = clsQual gHC_INTERNAL_MONAD (fsLit "Alternative") alternativeClassKey + +-- +joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey, + alternativeClassKey :: Unique +joinMIdKey = mkPreludeMiscIdUnique 750 +apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*> +pureAClassOpKey = mkPreludeMiscIdUnique 752 +thenAClassOpKey = mkPreludeMiscIdUnique 753 +alternativeClassKey = mkPreludeMiscIdUnique 754 + + +-- Functions for GHC extensions +considerAccessibleName :: Name +considerAccessibleName = varQual gHC_INTERNAL_EXTS (fsLit "considerAccessible") considerAccessibleIdKey + +-- Random GHC.Internal.Base functions +fromStringName, otherwiseIdName, foldrName, buildName, augmentName, + mapName, appendName, assertName, + dollarName :: Name +dollarName = varQual gHC_INTERNAL_BASE (fsLit "$") dollarIdKey +otherwiseIdName = varQual gHC_INTERNAL_BASE (fsLit "otherwise") otherwiseIdKey +foldrName = varQual gHC_INTERNAL_BASE (fsLit "foldr") foldrIdKey +buildName = varQual gHC_INTERNAL_BASE (fsLit "build") buildIdKey +augmentName = varQual gHC_INTERNAL_BASE (fsLit "augment") augmentIdKey +mapName = varQual gHC_INTERNAL_BASE (fsLit "map") mapIdKey +appendName = varQual gHC_INTERNAL_BASE (fsLit "++") appendIdKey +assertName = varQual gHC_INTERNAL_BASE (fsLit "assert") assertIdKey +fromStringName = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromStringClassOpKey + +-- Module GHC.Internal.Num +numClassName, fromIntegerName, minusName, negateName :: Name +numClassName = clsQual gHC_INTERNAL_NUM (fsLit "Num") numClassKey +fromIntegerName = varQual gHC_INTERNAL_NUM (fsLit "fromInteger") fromIntegerClassOpKey +minusName = varQual gHC_INTERNAL_NUM (fsLit "-") minusClassOpKey +negateName = varQual gHC_INTERNAL_NUM (fsLit "negate") negateClassOpKey + +--------------------------------- +-- ghc-bignum +--------------------------------- +integerFromNaturalName + , integerToNaturalClampName + , integerToNaturalThrowName + , integerToNaturalName + , integerToWordName + , integerToIntName + , integerToWord64Name + , integerToInt64Name + , integerFromWordName + , integerFromWord64Name + , integerFromInt64Name + , integerAddName + , integerMulName + , integerSubName + , integerNegateName + , integerAbsName + , integerPopCountName + , integerQuotName + , integerRemName + , integerDivName + , integerModName + , integerDivModName + , integerQuotRemName + , integerEncodeFloatName + , integerEncodeDoubleName + , integerGcdName + , integerLcmName + , integerAndName + , integerOrName + , integerXorName + , integerComplementName + , integerBitName + , integerTestBitName + , integerShiftLName + , integerShiftRName + , naturalToWordName + , naturalPopCountName + , naturalShiftRName + , naturalShiftLName + , naturalAddName + , naturalSubName + , naturalSubThrowName + , naturalSubUnsafeName + , naturalMulName + , naturalQuotRemName + , naturalQuotName + , naturalRemName + , naturalAndName + , naturalAndNotName + , naturalOrName + , naturalXorName + , naturalTestBitName + , naturalBitName + , naturalGcdName + , naturalLcmName + , naturalLog2Name + , naturalLogBaseWordName + , naturalLogBaseName + , naturalPowModName + , naturalSizeInBaseName + , bignatEqName + , bignatCompareName + , bignatCompareWordName + :: Name + +bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name +bnbVarQual str key = varQual gHC_INTERNAL_NUM_BIGNAT (fsLit str) key +bnnVarQual str key = varQual gHC_INTERNAL_NUM_NATURAL (fsLit str) key +bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key + +-- Types and DataCons +bignatEqName = bnbVarQual "bigNatEq#" bignatEqIdKey +bignatCompareName = bnbVarQual "bigNatCompare" bignatCompareIdKey +bignatCompareWordName = bnbVarQual "bigNatCompareWord#" bignatCompareWordIdKey + +naturalToWordName = bnnVarQual "naturalToWord#" naturalToWordIdKey +naturalPopCountName = bnnVarQual "naturalPopCount#" naturalPopCountIdKey +naturalShiftRName = bnnVarQual "naturalShiftR#" naturalShiftRIdKey +naturalShiftLName = bnnVarQual "naturalShiftL#" naturalShiftLIdKey +naturalAddName = bnnVarQual "naturalAdd" naturalAddIdKey +naturalSubName = bnnVarQual "naturalSub" naturalSubIdKey +naturalSubThrowName = bnnVarQual "naturalSubThrow" naturalSubThrowIdKey +naturalSubUnsafeName = bnnVarQual "naturalSubUnsafe" naturalSubUnsafeIdKey +naturalMulName = bnnVarQual "naturalMul" naturalMulIdKey +naturalQuotRemName = bnnVarQual "naturalQuotRem#" naturalQuotRemIdKey +naturalQuotName = bnnVarQual "naturalQuot" naturalQuotIdKey +naturalRemName = bnnVarQual "naturalRem" naturalRemIdKey +naturalAndName = bnnVarQual "naturalAnd" naturalAndIdKey +naturalAndNotName = bnnVarQual "naturalAndNot" naturalAndNotIdKey +naturalOrName = bnnVarQual "naturalOr" naturalOrIdKey +naturalXorName = bnnVarQual "naturalXor" naturalXorIdKey +naturalTestBitName = bnnVarQual "naturalTestBit#" naturalTestBitIdKey +naturalBitName = bnnVarQual "naturalBit#" naturalBitIdKey +naturalGcdName = bnnVarQual "naturalGcd" naturalGcdIdKey +naturalLcmName = bnnVarQual "naturalLcm" naturalLcmIdKey +naturalLog2Name = bnnVarQual "naturalLog2#" naturalLog2IdKey +naturalLogBaseWordName = bnnVarQual "naturalLogBaseWord#" naturalLogBaseWordIdKey +naturalLogBaseName = bnnVarQual "naturalLogBase#" naturalLogBaseIdKey +naturalPowModName = bnnVarQual "naturalPowMod" naturalPowModIdKey +naturalSizeInBaseName = bnnVarQual "naturalSizeInBase#" naturalSizeInBaseIdKey + +integerFromNaturalName = bniVarQual "integerFromNatural" integerFromNaturalIdKey +integerToNaturalClampName = bniVarQual "integerToNaturalClamp" integerToNaturalClampIdKey +integerToNaturalThrowName = bniVarQual "integerToNaturalThrow" integerToNaturalThrowIdKey +integerToNaturalName = bniVarQual "integerToNatural" integerToNaturalIdKey +integerToWordName = bniVarQual "integerToWord#" integerToWordIdKey +integerToIntName = bniVarQual "integerToInt#" integerToIntIdKey +integerToWord64Name = bniVarQual "integerToWord64#" integerToWord64IdKey +integerToInt64Name = bniVarQual "integerToInt64#" integerToInt64IdKey +integerFromWordName = bniVarQual "integerFromWord#" integerFromWordIdKey +integerFromWord64Name = bniVarQual "integerFromWord64#" integerFromWord64IdKey +integerFromInt64Name = bniVarQual "integerFromInt64#" integerFromInt64IdKey +integerAddName = bniVarQual "integerAdd" integerAddIdKey +integerMulName = bniVarQual "integerMul" integerMulIdKey +integerSubName = bniVarQual "integerSub" integerSubIdKey +integerNegateName = bniVarQual "integerNegate" integerNegateIdKey +integerAbsName = bniVarQual "integerAbs" integerAbsIdKey +integerPopCountName = bniVarQual "integerPopCount#" integerPopCountIdKey +integerQuotName = bniVarQual "integerQuot" integerQuotIdKey +integerRemName = bniVarQual "integerRem" integerRemIdKey +integerDivName = bniVarQual "integerDiv" integerDivIdKey +integerModName = bniVarQual "integerMod" integerModIdKey +integerDivModName = bniVarQual "integerDivMod#" integerDivModIdKey +integerQuotRemName = bniVarQual "integerQuotRem#" integerQuotRemIdKey +integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey +integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey +integerGcdName = bniVarQual "integerGcd" integerGcdIdKey +integerLcmName = bniVarQual "integerLcm" integerLcmIdKey +integerAndName = bniVarQual "integerAnd" integerAndIdKey +integerOrName = bniVarQual "integerOr" integerOrIdKey +integerXorName = bniVarQual "integerXor" integerXorIdKey +integerComplementName = bniVarQual "integerComplement" integerComplementIdKey +integerBitName = bniVarQual "integerBit#" integerBitIdKey +integerTestBitName = bniVarQual "integerTestBit#" integerTestBitIdKey +integerShiftLName = bniVarQual "integerShiftL#" integerShiftLIdKey +integerShiftRName = bniVarQual "integerShiftR#" integerShiftRIdKey + + + +--------------------------------- +-- End of ghc-bignum +--------------------------------- + +-- GHC.Internal.Real types and classes +rationalTyConName, ratioTyConName, ratioDataConName, realClassName, + integralClassName, realFracClassName, fractionalClassName, + fromRationalName, toIntegerName, toRationalName, fromIntegralName, + realToFracName, mkRationalBase2Name, mkRationalBase10Name :: Name +rationalTyConName = tcQual gHC_INTERNAL_REAL (fsLit "Rational") rationalTyConKey +ratioTyConName = tcQual gHC_INTERNAL_REAL (fsLit "Ratio") ratioTyConKey +ratioDataConName = dcQual gHC_INTERNAL_REAL (fsLit ":%") ratioDataConKey +realClassName = clsQual gHC_INTERNAL_REAL (fsLit "Real") realClassKey +integralClassName = clsQual gHC_INTERNAL_REAL (fsLit "Integral") integralClassKey +realFracClassName = clsQual gHC_INTERNAL_REAL (fsLit "RealFrac") realFracClassKey +fractionalClassName = clsQual gHC_INTERNAL_REAL (fsLit "Fractional") fractionalClassKey +fromRationalName = varQual gHC_INTERNAL_REAL (fsLit "fromRational") fromRationalClassOpKey +toIntegerName = varQual gHC_INTERNAL_REAL (fsLit "toInteger") toIntegerClassOpKey +toRationalName = varQual gHC_INTERNAL_REAL (fsLit "toRational") toRationalClassOpKey +fromIntegralName = varQual gHC_INTERNAL_REAL (fsLit "fromIntegral")fromIntegralIdKey +realToFracName = varQual gHC_INTERNAL_REAL (fsLit "realToFrac") realToFracIdKey +mkRationalBase2Name = varQual gHC_INTERNAL_REAL (fsLit "mkRationalBase2") mkRationalBase2IdKey +mkRationalBase10Name = varQual gHC_INTERNAL_REAL (fsLit "mkRationalBase10") mkRationalBase10IdKey + +-- GHC.Internal.Float classes +floatingClassName, realFloatClassName :: Name +floatingClassName = clsQual gHC_INTERNAL_FLOAT (fsLit "Floating") floatingClassKey +realFloatClassName = clsQual gHC_INTERNAL_FLOAT (fsLit "RealFloat") realFloatClassKey + +-- other GHC.Internal.Float functions +integerToFloatName, integerToDoubleName, + naturalToFloatName, naturalToDoubleName, + rationalToFloatName, rationalToDoubleName :: Name +integerToFloatName = varQual gHC_INTERNAL_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey +integerToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey +naturalToFloatName = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey +naturalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey +rationalToFloatName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey +rationalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey + +-- Class Ix +ixClassName :: Name +ixClassName = clsQual gHC_INTERNAL_IX (fsLit "Ix") ixClassKey + +-- Typeable representation types +trModuleTyConName + , trModuleDataConName + , trNameTyConName + , trNameSDataConName + , trNameDDataConName + , trTyConTyConName + , trTyConDataConName + :: Name +trModuleTyConName = tcQual gHC_TYPES (fsLit "Module") trModuleTyConKey +trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey +trNameTyConName = tcQual gHC_TYPES (fsLit "TrName") trNameTyConKey +trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey +trNameDDataConName = dcQual gHC_TYPES (fsLit "TrNameD") trNameDDataConKey +trTyConTyConName = tcQual gHC_TYPES (fsLit "TyCon") trTyConTyConKey +trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey + +kindRepTyConName + , kindRepTyConAppDataConName + , kindRepVarDataConName + , kindRepAppDataConName + , kindRepFunDataConName + , kindRepTYPEDataConName + , kindRepTypeLitSDataConName + , kindRepTypeLitDDataConName + :: Name +kindRepTyConName = tcQual gHC_TYPES (fsLit "KindRep") kindRepTyConKey +kindRepTyConAppDataConName = dcQual gHC_TYPES (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey +kindRepVarDataConName = dcQual gHC_TYPES (fsLit "KindRepVar") kindRepVarDataConKey +kindRepAppDataConName = dcQual gHC_TYPES (fsLit "KindRepApp") kindRepAppDataConKey +kindRepFunDataConName = dcQual gHC_TYPES (fsLit "KindRepFun") kindRepFunDataConKey +kindRepTYPEDataConName = dcQual gHC_TYPES (fsLit "KindRepTYPE") kindRepTYPEDataConKey +kindRepTypeLitSDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey +kindRepTypeLitDDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey + +typeLitSortTyConName + , typeLitSymbolDataConName + , typeLitNatDataConName + , typeLitCharDataConName + :: Name +typeLitSortTyConName = tcQual gHC_TYPES (fsLit "TypeLitSort") typeLitSortTyConKey +typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey +typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey +typeLitCharDataConName = dcQual gHC_TYPES (fsLit "TypeLitChar") typeLitCharDataConKey + +-- Class Typeable, and functions for constructing `Typeable` dictionaries +typeableClassName + , typeRepTyConName + , someTypeRepTyConName + , someTypeRepDataConName + , mkTrTypeName + , mkTrConName + , mkTrAppCheckedName + , mkTrFunName + , typeRepIdName + , typeNatTypeRepName + , typeSymbolTypeRepName + , typeCharTypeRepName + , trGhcPrimModuleName + :: Name +typeableClassName = clsQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey +typeRepTyConName = tcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey +someTypeRepTyConName = tcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey +someTypeRepDataConName = dcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey +typeRepIdName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey +mkTrTypeName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrType") mkTrTypeKey +mkTrConName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey +mkTrAppCheckedName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrAppChecked") mkTrAppCheckedKey +mkTrFunName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey +typeNatTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey +typeSymbolTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey +typeCharTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey +-- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) +-- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable. +trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey + +-- Typeable KindReps for some common cases +starKindRepName, starArrStarKindRepName, + starArrStarArrStarKindRepName, constraintKindRepName :: Name +starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey +starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey +starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey +constraintKindRepName = varQual gHC_TYPES (fsLit "krep$Constraint") constraintKindRepKey + +-- WithDict +withDictClassName :: Name +withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey + +nonEmptyTyConName :: Name +nonEmptyTyConName = tcQual gHC_INTERNAL_BASE (fsLit "NonEmpty") nonEmptyTyConKey + +-- DataToTag +dataToTagClassName :: Name +dataToTagClassName = clsQual gHC_MAGIC (fsLit "DataToTag") dataToTagClassKey + +-- seq# +seqHashName :: Name +seqHashName = varQual gHC_INTERNAL_IO (fsLit "seq#") seqHashKey + +-- Custom type errors +errorMessageTypeErrorFamName + , typeErrorTextDataConName + , typeErrorAppendDataConName + , typeErrorVAppendDataConName + , typeErrorShowTypeDataConName + :: Name + +errorMessageTypeErrorFamName = + tcQual gHC_INTERNAL_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey + +typeErrorTextDataConName = + dcQual gHC_INTERNAL_TYPEERROR (fsLit "Text") typeErrorTextDataConKey + +typeErrorAppendDataConName = + dcQual gHC_INTERNAL_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey + +typeErrorVAppendDataConName = + dcQual gHC_INTERNAL_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey + +typeErrorShowTypeDataConName = + dcQual gHC_INTERNAL_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey + +-- "Unsatisfiable" constraint +unsatisfiableClassName, unsatisfiableIdName :: Name +unsatisfiableClassName = + clsQual gHC_INTERNAL_TYPEERROR (fsLit "Unsatisfiable") unsatisfiableClassNameKey +unsatisfiableIdName = + varQual gHC_INTERNAL_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey + +-- Unsafe coercion proofs +unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName, + unsafeReflDataConName :: Name +unsafeEqualityProofName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey +unsafeEqualityTyConName = tcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey +unsafeReflDataConName = dcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeRefl") unsafeReflDataConKey +unsafeCoercePrimName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey + +-- Dynamic +toDynName :: Name +toDynName = varQual gHC_INTERNAL_DYNAMIC (fsLit "toDyn") toDynIdKey + +-- Class Data +dataClassName :: Name +dataClassName = clsQual gHC_INTERNAL_DATA_DATA (fsLit "Data") dataClassKey + +-- Error module +assertErrorName :: Name +assertErrorName = varQual gHC_INTERNAL_IO_Exception (fsLit "assertError") assertErrorIdKey + +-- GHC.Internal.Debug.Trace +traceName :: Name +traceName = varQual gHC_INTERNAL_DEBUG_TRACE (fsLit "trace") traceKey + +-- Enum module (Enum, Bounded) +enumClassName, enumFromName, enumFromToName, enumFromThenName, + enumFromThenToName, boundedClassName :: Name +enumClassName = clsQual gHC_INTERNAL_ENUM (fsLit "Enum") enumClassKey +enumFromName = varQual gHC_INTERNAL_ENUM (fsLit "enumFrom") enumFromClassOpKey +enumFromToName = varQual gHC_INTERNAL_ENUM (fsLit "enumFromTo") enumFromToClassOpKey +enumFromThenName = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey +enumFromThenToName = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey +boundedClassName = clsQual gHC_INTERNAL_ENUM (fsLit "Bounded") boundedClassKey + +-- List functions +concatName, filterName, zipName :: Name +concatName = varQual gHC_INTERNAL_LIST (fsLit "concat") concatIdKey +filterName = varQual gHC_INTERNAL_LIST (fsLit "filter") filterIdKey +zipName = varQual gHC_INTERNAL_LIST (fsLit "zip") zipIdKey + +-- Overloaded lists +isListClassName, fromListName, fromListNName, toListName :: Name +isListClassName = clsQual gHC_INTERNAL_IS_LIST (fsLit "IsList") isListClassKey +fromListName = varQual gHC_INTERNAL_IS_LIST (fsLit "fromList") fromListClassOpKey +fromListNName = varQual gHC_INTERNAL_IS_LIST (fsLit "fromListN") fromListNClassOpKey +toListName = varQual gHC_INTERNAL_IS_LIST (fsLit "toList") toListClassOpKey + +-- HasField class ops +getFieldName, setFieldName :: Name +getFieldName = varQual gHC_INTERNAL_RECORDS (fsLit "getField") getFieldClassOpKey +setFieldName = varQual gHC_INTERNAL_RECORDS (fsLit "setField") setFieldClassOpKey + +-- Class Show +showClassName :: Name +showClassName = clsQual gHC_INTERNAL_SHOW (fsLit "Show") showClassKey + +-- Class Read +readClassName :: Name +readClassName = clsQual gHC_INTERNAL_READ (fsLit "Read") readClassKey + +-- Classes Generic and Generic1, Datatype, Constructor and Selector +genClassName, gen1ClassName, datatypeClassName, constructorClassName, + selectorClassName :: Name +genClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic") genClassKey +gen1ClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic1") gen1ClassKey + +datatypeClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Datatype") datatypeClassKey +constructorClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Constructor") constructorClassKey +selectorClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Selector") selectorClassKey + +genericClassNames :: [Name] +genericClassNames = [genClassName, gen1ClassName] + +-- GHCi things +ghciIoClassName, ghciStepIoMName :: Name +ghciIoClassName = clsQual gHC_INTERNAL_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey +ghciStepIoMName = varQual gHC_INTERNAL_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey + +-- IO things +ioTyConName, ioDataConName, + thenIOName, bindIOName, returnIOName, failIOName :: Name +ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey +ioDataConName = dcQual gHC_TYPES (fsLit "IO") ioDataConKey +thenIOName = varQual gHC_INTERNAL_BASE (fsLit "thenIO") thenIOIdKey +bindIOName = varQual gHC_INTERNAL_BASE (fsLit "bindIO") bindIOIdKey +returnIOName = varQual gHC_INTERNAL_BASE (fsLit "returnIO") returnIOIdKey +failIOName = varQual gHC_INTERNAL_IO (fsLit "failIO") failIOIdKey + +-- IO things +printName :: Name +printName = varQual gHC_INTERNAL_SYSTEM_IO (fsLit "print") printIdKey + +-- Int, Word, and Addr things +int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name +int8TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int8") int8TyConKey +int16TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int16") int16TyConKey +int32TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int32") int32TyConKey +int64TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int64") int64TyConKey + +-- Word module +word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name +word8TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word8") word8TyConKey +word16TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word16") word16TyConKey +word32TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word32") word32TyConKey +word64TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word64") word64TyConKey + +-- PrelPtr module +ptrTyConName, funPtrTyConName :: Name +ptrTyConName = tcQual gHC_INTERNAL_PTR (fsLit "Ptr") ptrTyConKey +funPtrTyConName = tcQual gHC_INTERNAL_PTR (fsLit "FunPtr") funPtrTyConKey + +-- Foreign objects and weak pointers +stablePtrTyConName, newStablePtrName :: Name +stablePtrTyConName = tcQual gHC_INTERNAL_STABLE (fsLit "StablePtr") stablePtrTyConKey +newStablePtrName = varQual gHC_INTERNAL_STABLE (fsLit "newStablePtr") newStablePtrIdKey + +-- Recursive-do notation +monadFixClassName, mfixName :: Name +monadFixClassName = clsQual gHC_INTERNAL_MONAD_FIX (fsLit "MonadFix") monadFixClassKey +mfixName = varQual gHC_INTERNAL_MONAD_FIX (fsLit "mfix") mfixIdKey + +-- Arrow notation +arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name +arrAName = varQual gHC_INTERNAL_ARROW (fsLit "arr") arrAIdKey +composeAName = varQual gHC_INTERNAL_DESUGAR (fsLit ">>>") composeAIdKey +firstAName = varQual gHC_INTERNAL_ARROW (fsLit "first") firstAIdKey +appAName = varQual gHC_INTERNAL_ARROW (fsLit "app") appAIdKey +choiceAName = varQual gHC_INTERNAL_ARROW (fsLit "|||") choiceAIdKey +loopAName = varQual gHC_INTERNAL_ARROW (fsLit "loop") loopAIdKey + +-- Monad comprehensions +guardMName, liftMName, mzipName :: Name +guardMName = varQual gHC_INTERNAL_MONAD (fsLit "guard") guardMIdKey +liftMName = varQual gHC_INTERNAL_MONAD (fsLit "liftM") liftMIdKey +mzipName = varQual gHC_INTERNAL_CONTROL_MONAD_ZIP (fsLit "mzip") mzipIdKey + + +-- Annotation type checking +toAnnotationWrapperName :: Name +toAnnotationWrapperName = varQual gHC_INTERNAL_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey + +-- Other classes, needed for type defaulting +monadPlusClassName, isStringClassName :: Name +monadPlusClassName = clsQual gHC_INTERNAL_MONAD (fsLit "MonadPlus") monadPlusClassKey +isStringClassName = clsQual gHC_INTERNAL_DATA_STRING (fsLit "IsString") isStringClassKey + +-- Type-level naturals +knownNatClassName :: Name +knownNatClassName = clsQual gHC_INTERNAL_TYPENATS (fsLit "KnownNat") knownNatClassNameKey +knownSymbolClassName :: Name +knownSymbolClassName = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey +knownCharClassName :: Name +knownCharClassName = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownChar") knownCharClassNameKey + +-- Overloaded labels +fromLabelClassOpName :: Name +fromLabelClassOpName + = varQual gHC_INTERNAL_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey + +-- Implicit Parameters +ipClassName :: Name +ipClassName + = clsQual gHC_CLASSES (fsLit "IP") ipClassKey + +-- Overloaded record fields +hasFieldClassName :: Name +hasFieldClassName + = clsQual gHC_INTERNAL_RECORDS (fsLit "HasField") hasFieldClassNameKey + +-- ExceptionContext +exceptionContextTyConName, emptyExceptionContextName :: Name +exceptionContextTyConName = + tcQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "ExceptionContext") exceptionContextTyConKey +emptyExceptionContextName + = varQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "emptyExceptionContext") emptyExceptionContextKey + +-- Source Locations +callStackTyConName, emptyCallStackName, pushCallStackName, + srcLocDataConName :: Name +callStackTyConName + = tcQual gHC_INTERNAL_STACK_TYPES (fsLit "CallStack") callStackTyConKey +emptyCallStackName + = varQual gHC_INTERNAL_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey +pushCallStackName + = varQual gHC_INTERNAL_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey +srcLocDataConName + = dcQual gHC_INTERNAL_STACK_TYPES (fsLit "SrcLoc") srcLocDataConKey + +-- plugins +pLUGINS :: Module +pLUGINS = mkThisGhcModule (fsLit "GHC.Driver.Plugins") +pluginTyConName :: Name +pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey +frontendPluginTyConName :: Name +frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey + +-- Static pointers +makeStaticName :: Name +makeStaticName = + varQual gHC_INTERNAL_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey + +staticPtrInfoTyConName :: Name +staticPtrInfoTyConName = + tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey + +staticPtrInfoDataConName :: Name +staticPtrInfoDataConName = + dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey + +staticPtrTyConName :: Name +staticPtrTyConName = + tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey + +staticPtrDataConName :: Name +staticPtrDataConName = + dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey + +fromStaticPtrName :: Name +fromStaticPtrName = + varQual gHC_INTERNAL_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey + +fingerprintDataConName :: Name +fingerprintDataConName = + dcQual gHC_INTERNAL_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey + +constPtrConName :: Name +constPtrConName = + tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey + +jsvalTyConName :: Name +jsvalTyConName = tcQual gHC_INTERNAL_WASM_PRIM_TYPES (fsLit "JSVal") jsvalTyConKey + +unsafeUnpackJSStringUtf8ShShName :: Name +unsafeUnpackJSStringUtf8ShShName = varQual gHC_INTERNAL_JS_PRIM (fsLit "unsafeUnpackJSStringUtf8##") unsafeUnpackJSStringUtf8ShShKey + +{- +************************************************************************ +* * +\subsection{Local helpers} +* * +************************************************************************ + +All these are original names; hence mkOrig +-} + +{-# INLINE varQual #-} +{-# INLINE tcQual #-} +{-# INLINE clsQual #-} +{-# INLINE dcQual #-} +varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name +varQual modu str unique = mk_known_key_name varName modu str unique +tcQual modu str unique = mk_known_key_name tcName modu str unique +clsQual modu str unique = mk_known_key_name clsName modu str unique +dcQual modu str unique = mk_known_key_name dataName modu str unique + +mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name +{-# INLINE mk_known_key_name #-} +mk_known_key_name space modu str unique + = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan + + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} +* * +************************************************************************ +--MetaHaskell extension hand allocate keys here +-} + +boundedClassKey, enumClassKey, eqClassKey, floatingClassKey, + fractionalClassKey, integralClassKey, monadClassKey, dataClassKey, + functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey, + realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique +boundedClassKey = mkPreludeClassUnique 1 +enumClassKey = mkPreludeClassUnique 2 +eqClassKey = mkPreludeClassUnique 3 +floatingClassKey = mkPreludeClassUnique 5 +fractionalClassKey = mkPreludeClassUnique 6 +integralClassKey = mkPreludeClassUnique 7 +monadClassKey = mkPreludeClassUnique 8 +dataClassKey = mkPreludeClassUnique 9 +functorClassKey = mkPreludeClassUnique 10 +numClassKey = mkPreludeClassUnique 11 +ordClassKey = mkPreludeClassUnique 12 +readClassKey = mkPreludeClassUnique 13 +realClassKey = mkPreludeClassUnique 14 +realFloatClassKey = mkPreludeClassUnique 15 +realFracClassKey = mkPreludeClassUnique 16 +showClassKey = mkPreludeClassUnique 17 +ixClassKey = mkPreludeClassUnique 18 + +typeableClassKey :: Unique +typeableClassKey = mkPreludeClassUnique 20 + +withDictClassKey :: Unique +withDictClassKey = mkPreludeClassUnique 21 + +dataToTagClassKey :: Unique +dataToTagClassKey = mkPreludeClassUnique 23 + +monadFixClassKey :: Unique +monadFixClassKey = mkPreludeClassUnique 28 + +monadFailClassKey :: Unique +monadFailClassKey = mkPreludeClassUnique 29 + +monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique +monadPlusClassKey = mkPreludeClassUnique 30 +randomClassKey = mkPreludeClassUnique 31 +randomGenClassKey = mkPreludeClassUnique 32 + +isStringClassKey :: Unique +isStringClassKey = mkPreludeClassUnique 33 + +applicativeClassKey, foldableClassKey, traversableClassKey :: Unique +applicativeClassKey = mkPreludeClassUnique 34 +foldableClassKey = mkPreludeClassUnique 35 +traversableClassKey = mkPreludeClassUnique 36 + +genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, + selectorClassKey :: Unique +genClassKey = mkPreludeClassUnique 37 +gen1ClassKey = mkPreludeClassUnique 38 + +datatypeClassKey = mkPreludeClassUnique 39 +constructorClassKey = mkPreludeClassUnique 40 +selectorClassKey = mkPreludeClassUnique 41 + +-- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class +knownNatClassNameKey :: Unique +knownNatClassNameKey = mkPreludeClassUnique 42 + +-- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class +knownSymbolClassNameKey :: Unique +knownSymbolClassNameKey = mkPreludeClassUnique 43 + +knownCharClassNameKey :: Unique +knownCharClassNameKey = mkPreludeClassUnique 44 + +ghciIoClassKey :: Unique +ghciIoClassKey = mkPreludeClassUnique 45 + +semigroupClassKey, monoidClassKey :: Unique +semigroupClassKey = mkPreludeClassUnique 47 +monoidClassKey = mkPreludeClassUnique 48 + +-- Implicit Parameters +ipClassKey :: Unique +ipClassKey = mkPreludeClassUnique 49 + +-- Overloaded record fields +hasFieldClassNameKey :: Unique +hasFieldClassNameKey = mkPreludeClassUnique 50 + + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES ClassUniques 200-299 +----------------------------------------------------- + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} +* * +************************************************************************ +-} + +addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, + byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, + doubleTyConKey, floatPrimTyConKey, floatTyConKey, fUNTyConKey, + intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, + int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey, + int64PrimTyConKey, int64TyConKey, + integerTyConKey, naturalTyConKey, + listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, + weakPrimTyConKey, mutableArrayPrimTyConKey, + mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, + ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, + stablePtrTyConKey, eqTyConKey, heqTyConKey, + smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey, + stringTyConKey, + ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: Unique +addrPrimTyConKey = mkPreludeTyConUnique 1 +arrayPrimTyConKey = mkPreludeTyConUnique 3 +boolTyConKey = mkPreludeTyConUnique 4 +byteArrayPrimTyConKey = mkPreludeTyConUnique 5 +stringTyConKey = mkPreludeTyConUnique 6 +charPrimTyConKey = mkPreludeTyConUnique 7 +charTyConKey = mkPreludeTyConUnique 8 +doublePrimTyConKey = mkPreludeTyConUnique 9 +doubleTyConKey = mkPreludeTyConUnique 10 +floatPrimTyConKey = mkPreludeTyConUnique 11 +floatTyConKey = mkPreludeTyConUnique 12 +fUNTyConKey = mkPreludeTyConUnique 13 +intPrimTyConKey = mkPreludeTyConUnique 14 +intTyConKey = mkPreludeTyConUnique 15 +int8PrimTyConKey = mkPreludeTyConUnique 16 +int8TyConKey = mkPreludeTyConUnique 17 +int16PrimTyConKey = mkPreludeTyConUnique 18 +int16TyConKey = mkPreludeTyConUnique 19 +int32PrimTyConKey = mkPreludeTyConUnique 20 +int32TyConKey = mkPreludeTyConUnique 21 +int64PrimTyConKey = mkPreludeTyConUnique 22 +int64TyConKey = mkPreludeTyConUnique 23 +integerTyConKey = mkPreludeTyConUnique 24 +naturalTyConKey = mkPreludeTyConUnique 25 + +listTyConKey = mkPreludeTyConUnique 26 +foreignObjPrimTyConKey = mkPreludeTyConUnique 27 +maybeTyConKey = mkPreludeTyConUnique 28 +weakPrimTyConKey = mkPreludeTyConUnique 29 +mutableArrayPrimTyConKey = mkPreludeTyConUnique 30 +mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31 +orderingTyConKey = mkPreludeTyConUnique 32 +mVarPrimTyConKey = mkPreludeTyConUnique 33 +-- ioPortPrimTyConKey (34) was killed +ratioTyConKey = mkPreludeTyConUnique 35 +rationalTyConKey = mkPreludeTyConUnique 36 +realWorldTyConKey = mkPreludeTyConUnique 37 +stablePtrPrimTyConKey = mkPreludeTyConUnique 38 +stablePtrTyConKey = mkPreludeTyConUnique 39 +eqTyConKey = mkPreludeTyConUnique 40 +heqTyConKey = mkPreludeTyConUnique 41 + +ctArrowTyConKey = mkPreludeTyConUnique 42 +ccArrowTyConKey = mkPreludeTyConUnique 43 +tcArrowTyConKey = mkPreludeTyConUnique 44 + +statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, + mutVarPrimTyConKey, ioTyConKey, + wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, + word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey, + word64PrimTyConKey, word64TyConKey, + kindConKey, boxityConKey, + typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, + funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, + eqReprPrimTyConKey, eqPhantPrimTyConKey, + compactPrimTyConKey, stackSnapshotPrimTyConKey, + promptTagPrimTyConKey, constPtrTyConKey, jsvalTyConKey :: Unique +statePrimTyConKey = mkPreludeTyConUnique 50 +stableNamePrimTyConKey = mkPreludeTyConUnique 51 +stableNameTyConKey = mkPreludeTyConUnique 52 +eqPrimTyConKey = mkPreludeTyConUnique 53 +eqReprPrimTyConKey = mkPreludeTyConUnique 54 +eqPhantPrimTyConKey = mkPreludeTyConUnique 55 +mutVarPrimTyConKey = mkPreludeTyConUnique 56 +ioTyConKey = mkPreludeTyConUnique 57 +wordPrimTyConKey = mkPreludeTyConUnique 59 +wordTyConKey = mkPreludeTyConUnique 60 +word8PrimTyConKey = mkPreludeTyConUnique 61 +word8TyConKey = mkPreludeTyConUnique 62 +word16PrimTyConKey = mkPreludeTyConUnique 63 +word16TyConKey = mkPreludeTyConUnique 64 +word32PrimTyConKey = mkPreludeTyConUnique 65 +word32TyConKey = mkPreludeTyConUnique 66 +word64PrimTyConKey = mkPreludeTyConUnique 67 +word64TyConKey = mkPreludeTyConUnique 68 +kindConKey = mkPreludeTyConUnique 72 +boxityConKey = mkPreludeTyConUnique 73 +typeConKey = mkPreludeTyConUnique 74 +threadIdPrimTyConKey = mkPreludeTyConUnique 75 +bcoPrimTyConKey = mkPreludeTyConUnique 76 +ptrTyConKey = mkPreludeTyConUnique 77 +funPtrTyConKey = mkPreludeTyConUnique 78 +tVarPrimTyConKey = mkPreludeTyConUnique 79 +compactPrimTyConKey = mkPreludeTyConUnique 80 +stackSnapshotPrimTyConKey = mkPreludeTyConUnique 81 +promptTagPrimTyConKey = mkPreludeTyConUnique 82 + +eitherTyConKey :: Unique +eitherTyConKey = mkPreludeTyConUnique 84 + +voidTyConKey :: Unique +voidTyConKey = mkPreludeTyConUnique 85 + +nonEmptyTyConKey :: Unique +nonEmptyTyConKey = mkPreludeTyConUnique 86 + +dictTyConKey :: Unique +dictTyConKey = mkPreludeTyConUnique 87 + +-- Kind constructors +liftedTypeKindTyConKey, unliftedTypeKindTyConKey, + tYPETyConKey, cONSTRAINTTyConKey, + liftedRepTyConKey, unliftedRepTyConKey, + constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey, + vecCountTyConKey, vecElemTyConKey, + zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique +liftedTypeKindTyConKey = mkPreludeTyConUnique 88 +unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 +tYPETyConKey = mkPreludeTyConUnique 91 +cONSTRAINTTyConKey = mkPreludeTyConUnique 92 +constraintKindTyConKey = mkPreludeTyConUnique 93 +levityTyConKey = mkPreludeTyConUnique 94 +runtimeRepTyConKey = mkPreludeTyConUnique 95 +vecCountTyConKey = mkPreludeTyConUnique 96 +vecElemTyConKey = mkPreludeTyConUnique 97 +liftedRepTyConKey = mkPreludeTyConUnique 98 +unliftedRepTyConKey = mkPreludeTyConUnique 99 +zeroBitRepTyConKey = mkPreludeTyConUnique 100 +zeroBitTypeTyConKey = mkPreludeTyConUnique 101 + +pluginTyConKey, frontendPluginTyConKey :: Unique +pluginTyConKey = mkPreludeTyConUnique 102 +frontendPluginTyConKey = mkPreludeTyConUnique 103 + +trTyConTyConKey, trModuleTyConKey, trNameTyConKey, + kindRepTyConKey, typeLitSortTyConKey :: Unique +trTyConTyConKey = mkPreludeTyConUnique 104 +trModuleTyConKey = mkPreludeTyConUnique 105 +trNameTyConKey = mkPreludeTyConUnique 106 +kindRepTyConKey = mkPreludeTyConUnique 107 +typeLitSortTyConKey = mkPreludeTyConUnique 108 + +-- Generics (Unique keys) +v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, + k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, + compTyConKey, rTyConKey, dTyConKey, + cTyConKey, sTyConKey, rec0TyConKey, + d1TyConKey, c1TyConKey, s1TyConKey, + repTyConKey, rep1TyConKey, uRecTyConKey, + uAddrTyConKey, uCharTyConKey, uDoubleTyConKey, + uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique + +v1TyConKey = mkPreludeTyConUnique 135 +u1TyConKey = mkPreludeTyConUnique 136 +par1TyConKey = mkPreludeTyConUnique 137 +rec1TyConKey = mkPreludeTyConUnique 138 +k1TyConKey = mkPreludeTyConUnique 139 +m1TyConKey = mkPreludeTyConUnique 140 + +sumTyConKey = mkPreludeTyConUnique 141 +prodTyConKey = mkPreludeTyConUnique 142 +compTyConKey = mkPreludeTyConUnique 143 + +rTyConKey = mkPreludeTyConUnique 144 +dTyConKey = mkPreludeTyConUnique 146 +cTyConKey = mkPreludeTyConUnique 147 +sTyConKey = mkPreludeTyConUnique 148 + +rec0TyConKey = mkPreludeTyConUnique 149 +d1TyConKey = mkPreludeTyConUnique 151 +c1TyConKey = mkPreludeTyConUnique 152 +s1TyConKey = mkPreludeTyConUnique 153 + +repTyConKey = mkPreludeTyConUnique 155 +rep1TyConKey = mkPreludeTyConUnique 156 + +uRecTyConKey = mkPreludeTyConUnique 157 +uAddrTyConKey = mkPreludeTyConUnique 158 +uCharTyConKey = mkPreludeTyConUnique 159 +uDoubleTyConKey = mkPreludeTyConUnique 160 +uFloatTyConKey = mkPreludeTyConUnique 161 +uIntTyConKey = mkPreludeTyConUnique 162 +uWordTyConKey = mkPreludeTyConUnique 163 + +-- "Unsatisfiable" constraint +unsatisfiableClassNameKey :: Unique +unsatisfiableClassNameKey = mkPreludeTyConUnique 170 + +anyTyConKey :: Unique +anyTyConKey = mkPreludeTyConUnique 171 + +zonkAnyTyConKey :: Unique +zonkAnyTyConKey = mkPreludeTyConUnique 172 + +-- Custom user type-errors +errorMessageTypeErrorFamKey :: Unique +errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181 + +coercibleTyConKey :: Unique +coercibleTyConKey = mkPreludeTyConUnique 183 + +proxyPrimTyConKey :: Unique +proxyPrimTyConKey = mkPreludeTyConUnique 184 + +specTyConKey :: Unique +specTyConKey = mkPreludeTyConUnique 185 + +smallArrayPrimTyConKey = mkPreludeTyConUnique 187 +smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 188 + +staticPtrTyConKey :: Unique +staticPtrTyConKey = mkPreludeTyConUnique 189 + +staticPtrInfoTyConKey :: Unique +staticPtrInfoTyConKey = mkPreludeTyConUnique 190 + +callStackTyConKey :: Unique +callStackTyConKey = mkPreludeTyConUnique 191 + +-- Typeables +typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique +typeRepTyConKey = mkPreludeTyConUnique 192 +someTypeRepTyConKey = mkPreludeTyConUnique 193 +someTypeRepDataConKey = mkPreludeTyConUnique 194 + + +typeSymbolAppendFamNameKey :: Unique +typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195 + +-- Unsafe equality +unsafeEqualityTyConKey :: Unique +unsafeEqualityTyConKey = mkPreludeTyConUnique 196 + +-- Linear types +multiplicityTyConKey :: Unique +multiplicityTyConKey = mkPreludeTyConUnique 197 + +unrestrictedFunTyConKey :: Unique +unrestrictedFunTyConKey = mkPreludeTyConUnique 198 + +multMulTyConKey :: Unique +multMulTyConKey = mkPreludeTyConUnique 199 + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES TyConUniques 200-299 +----------------------------------------------------- + +----------------------- SIMD ------------------------ +-- USES TyConUniques 300-399 +----------------------------------------------------- + +#include "primop-vector-uniques.hs-incl" + +------------- Type-level Symbol, Nat, Char ---------- +-- USES TyConUniques 400-499 +----------------------------------------------------- +typeSymbolKindConNameKey, typeCharKindConNameKey, + typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, + typeNatSubTyFamNameKey + , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey, typeCharCmpTyFamNameKey + , typeLeqCharTyFamNameKey + , typeNatDivTyFamNameKey + , typeNatModTyFamNameKey + , typeNatLogTyFamNameKey + , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey + , typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey + , exceptionContextTyConKey, unsafeUnpackJSStringUtf8ShShKey + :: Unique +typeSymbolKindConNameKey = mkPreludeTyConUnique 400 +typeCharKindConNameKey = mkPreludeTyConUnique 401 +typeNatAddTyFamNameKey = mkPreludeTyConUnique 402 +typeNatMulTyFamNameKey = mkPreludeTyConUnique 403 +typeNatExpTyFamNameKey = mkPreludeTyConUnique 404 +typeNatSubTyFamNameKey = mkPreludeTyConUnique 405 +typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 406 +typeNatCmpTyFamNameKey = mkPreludeTyConUnique 407 +typeCharCmpTyFamNameKey = mkPreludeTyConUnique 408 +typeLeqCharTyFamNameKey = mkPreludeTyConUnique 409 +typeNatDivTyFamNameKey = mkPreludeTyConUnique 410 +typeNatModTyFamNameKey = mkPreludeTyConUnique 411 +typeNatLogTyFamNameKey = mkPreludeTyConUnique 412 +typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 413 +typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414 +typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415 +typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416 +constPtrTyConKey = mkPreludeTyConUnique 417 + +jsvalTyConKey = mkPreludeTyConUnique 418 + +exceptionContextTyConKey = mkPreludeTyConUnique 420 + +unsafeUnpackJSStringUtf8ShShKey = mkPreludeMiscIdUnique 805 + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} +* * +************************************************************************ +-} + +charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, + floatDataConKey, intDataConKey, nilDataConKey, + ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, + word8DataConKey, ioDataConKey, heqDataConKey, + eqDataConKey, nothingDataConKey, justDataConKey :: Unique + +charDataConKey = mkPreludeDataConUnique 1 +consDataConKey = mkPreludeDataConUnique 2 +doubleDataConKey = mkPreludeDataConUnique 3 +falseDataConKey = mkPreludeDataConUnique 4 +floatDataConKey = mkPreludeDataConUnique 5 +intDataConKey = mkPreludeDataConUnique 6 +nothingDataConKey = mkPreludeDataConUnique 7 +justDataConKey = mkPreludeDataConUnique 8 +eqDataConKey = mkPreludeDataConUnique 9 +nilDataConKey = mkPreludeDataConUnique 10 +ratioDataConKey = mkPreludeDataConUnique 11 +word8DataConKey = mkPreludeDataConUnique 12 +stableNameDataConKey = mkPreludeDataConUnique 13 +trueDataConKey = mkPreludeDataConUnique 14 +wordDataConKey = mkPreludeDataConUnique 15 +ioDataConKey = mkPreludeDataConUnique 16 +heqDataConKey = mkPreludeDataConUnique 18 + +-- Generic data constructors +crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique +crossDataConKey = mkPreludeDataConUnique 20 +inlDataConKey = mkPreludeDataConUnique 21 +inrDataConKey = mkPreludeDataConUnique 22 +genUnitDataConKey = mkPreludeDataConUnique 23 + +leftDataConKey, rightDataConKey :: Unique +leftDataConKey = mkPreludeDataConUnique 25 +rightDataConKey = mkPreludeDataConUnique 26 + +ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique +ordLTDataConKey = mkPreludeDataConUnique 27 +ordEQDataConKey = mkPreludeDataConUnique 28 +ordGTDataConKey = mkPreludeDataConUnique 29 + +mkDictDataConKey :: Unique +mkDictDataConKey = mkPreludeDataConUnique 30 + +coercibleDataConKey :: Unique +coercibleDataConKey = mkPreludeDataConUnique 32 + +staticPtrDataConKey :: Unique +staticPtrDataConKey = mkPreludeDataConUnique 33 + +staticPtrInfoDataConKey :: Unique +staticPtrInfoDataConKey = mkPreludeDataConUnique 34 + +fingerprintDataConKey :: Unique +fingerprintDataConKey = mkPreludeDataConUnique 35 + +srcLocDataConKey :: Unique +srcLocDataConKey = mkPreludeDataConUnique 37 + +trTyConDataConKey, trModuleDataConKey, + trNameSDataConKey, trNameDDataConKey, + trGhcPrimModuleKey :: Unique +trTyConDataConKey = mkPreludeDataConUnique 41 +trModuleDataConKey = mkPreludeDataConUnique 43 +trNameSDataConKey = mkPreludeDataConUnique 45 +trNameDDataConKey = mkPreludeDataConUnique 46 +trGhcPrimModuleKey = mkPreludeDataConUnique 47 + +typeErrorTextDataConKey, + typeErrorAppendDataConKey, + typeErrorVAppendDataConKey, + typeErrorShowTypeDataConKey + :: Unique +typeErrorTextDataConKey = mkPreludeDataConUnique 50 +typeErrorAppendDataConKey = mkPreludeDataConUnique 51 +typeErrorVAppendDataConKey = mkPreludeDataConUnique 52 +typeErrorShowTypeDataConKey = mkPreludeDataConUnique 53 + +prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey, + rightAssociativeDataConKey, notAssociativeDataConKey, + sourceUnpackDataConKey, sourceNoUnpackDataConKey, + noSourceUnpackednessDataConKey, sourceLazyDataConKey, + sourceStrictDataConKey, noSourceStrictnessDataConKey, + decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey, + metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique +prefixIDataConKey = mkPreludeDataConUnique 54 +infixIDataConKey = mkPreludeDataConUnique 55 +leftAssociativeDataConKey = mkPreludeDataConUnique 56 +rightAssociativeDataConKey = mkPreludeDataConUnique 57 +notAssociativeDataConKey = mkPreludeDataConUnique 58 +sourceUnpackDataConKey = mkPreludeDataConUnique 59 +sourceNoUnpackDataConKey = mkPreludeDataConUnique 60 +noSourceUnpackednessDataConKey = mkPreludeDataConUnique 61 +sourceLazyDataConKey = mkPreludeDataConUnique 62 +sourceStrictDataConKey = mkPreludeDataConUnique 63 +noSourceStrictnessDataConKey = mkPreludeDataConUnique 64 +decidedLazyDataConKey = mkPreludeDataConUnique 65 +decidedStrictDataConKey = mkPreludeDataConUnique 66 +decidedUnpackDataConKey = mkPreludeDataConUnique 67 +metaDataDataConKey = mkPreludeDataConUnique 68 +metaConsDataConKey = mkPreludeDataConUnique 69 +metaSelDataConKey = mkPreludeDataConUnique 70 + +vecRepDataConKey, sumRepDataConKey, + tupleRepDataConKey, boxedRepDataConKey :: Unique +vecRepDataConKey = mkPreludeDataConUnique 71 +tupleRepDataConKey = mkPreludeDataConUnique 72 +sumRepDataConKey = mkPreludeDataConUnique 73 +boxedRepDataConKey = mkPreludeDataConUnique 74 + +boxedRepDataConTyConKey, tupleRepDataConTyConKey :: Unique +-- A promoted data constructors (i.e. a TyCon) has +-- the same key as the data constructor itself +boxedRepDataConTyConKey = boxedRepDataConKey +tupleRepDataConTyConKey = tupleRepDataConKey + +-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types +-- Includes all nullary-data-constructor reps. Does not +-- include BoxedRep, VecRep, SumRep, TupleRep. +runtimeRepSimpleDataConKeys :: [Unique] +runtimeRepSimpleDataConKeys + = map mkPreludeDataConUnique [75..87] + +liftedDataConKey,unliftedDataConKey :: Unique +liftedDataConKey = mkPreludeDataConUnique 88 +unliftedDataConKey = mkPreludeDataConUnique 89 + +-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types +-- VecCount +vecCountDataConKeys :: [Unique] +vecCountDataConKeys = map mkPreludeDataConUnique [90..95] + +-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types +-- VecElem +vecElemDataConKeys :: [Unique] +vecElemDataConKeys = map mkPreludeDataConUnique [96..105] + +-- Typeable things +kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, + kindRepFunDataConKey, kindRepTYPEDataConKey, + kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey + :: Unique +kindRepTyConAppDataConKey = mkPreludeDataConUnique 106 +kindRepVarDataConKey = mkPreludeDataConUnique 107 +kindRepAppDataConKey = mkPreludeDataConUnique 108 +kindRepFunDataConKey = mkPreludeDataConUnique 109 +kindRepTYPEDataConKey = mkPreludeDataConUnique 110 +kindRepTypeLitSDataConKey = mkPreludeDataConUnique 111 +kindRepTypeLitDDataConKey = mkPreludeDataConUnique 112 + +typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique +typeLitSymbolDataConKey = mkPreludeDataConUnique 113 +typeLitNatDataConKey = mkPreludeDataConUnique 114 +typeLitCharDataConKey = mkPreludeDataConUnique 115 + +-- Unsafe equality +unsafeReflDataConKey :: Unique +unsafeReflDataConKey = mkPreludeDataConUnique 116 + +-- Multiplicity + +oneDataConKey, manyDataConKey :: Unique +oneDataConKey = mkPreludeDataConUnique 117 +manyDataConKey = mkPreludeDataConUnique 118 + +-- ghc-bignum +integerISDataConKey, integerINDataConKey, integerIPDataConKey, + naturalNSDataConKey, naturalNBDataConKey :: Unique +integerISDataConKey = mkPreludeDataConUnique 120 +integerINDataConKey = mkPreludeDataConUnique 121 +integerIPDataConKey = mkPreludeDataConUnique 122 +naturalNSDataConKey = mkPreludeDataConUnique 123 +naturalNBDataConKey = mkPreludeDataConUnique 124 + + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES DataUniques 200-250 +----------------------------------------------------- + + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} +* * +************************************************************************ +-} + +wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendIdKey, + buildIdKey, foldrIdKey, recSelErrorIdKey, + seqIdKey, eqStringIdKey, + noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, + impossibleErrorIdKey, impossibleConstraintErrorIdKey, + patErrorIdKey, voidPrimIdKey, + realWorldPrimIdKey, recConErrorIdKey, + unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey, + unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, + typeErrorIdKey, divIntIdKey, modIntIdKey, + absentSumFieldErrorIdKey, cstringLengthIdKey + :: Unique + +wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] +absentErrorIdKey = mkPreludeMiscIdUnique 1 +absentConstraintErrorIdKey = mkPreludeMiscIdUnique 2 +augmentIdKey = mkPreludeMiscIdUnique 3 +appendIdKey = mkPreludeMiscIdUnique 4 +buildIdKey = mkPreludeMiscIdUnique 5 +foldrIdKey = mkPreludeMiscIdUnique 6 +recSelErrorIdKey = mkPreludeMiscIdUnique 7 +seqIdKey = mkPreludeMiscIdUnique 8 +absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 +eqStringIdKey = mkPreludeMiscIdUnique 10 +noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 +nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 +impossibleErrorIdKey = mkPreludeMiscIdUnique 13 +impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14 +patErrorIdKey = mkPreludeMiscIdUnique 15 +realWorldPrimIdKey = mkPreludeMiscIdUnique 16 +recConErrorIdKey = mkPreludeMiscIdUnique 17 + +unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 18 +unpackCStringAppendUtf8IdKey = mkPreludeMiscIdUnique 19 +unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 20 + +unpackCStringIdKey = mkPreludeMiscIdUnique 21 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 22 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 23 + +voidPrimIdKey = mkPreludeMiscIdUnique 24 +typeErrorIdKey = mkPreludeMiscIdUnique 25 +divIntIdKey = mkPreludeMiscIdUnique 26 +modIntIdKey = mkPreludeMiscIdUnique 27 +cstringLengthIdKey = mkPreludeMiscIdUnique 28 + +concatIdKey, filterIdKey, zipIdKey, + bindIOIdKey, returnIOIdKey, newStablePtrIdKey, + printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey, + otherwiseIdKey, assertIdKey :: Unique +concatIdKey = mkPreludeMiscIdUnique 31 +filterIdKey = mkPreludeMiscIdUnique 32 +zipIdKey = mkPreludeMiscIdUnique 33 +bindIOIdKey = mkPreludeMiscIdUnique 34 +returnIOIdKey = mkPreludeMiscIdUnique 35 +newStablePtrIdKey = mkPreludeMiscIdUnique 36 +printIdKey = mkPreludeMiscIdUnique 37 +failIOIdKey = mkPreludeMiscIdUnique 38 +nullAddrIdKey = mkPreludeMiscIdUnique 39 +voidArgIdKey = mkPreludeMiscIdUnique 40 +otherwiseIdKey = mkPreludeMiscIdUnique 43 +assertIdKey = mkPreludeMiscIdUnique 44 + +leftSectionKey, rightSectionKey :: Unique +leftSectionKey = mkPreludeMiscIdUnique 45 +rightSectionKey = mkPreludeMiscIdUnique 46 + +rootMainKey, runMainKey :: Unique +rootMainKey = mkPreludeMiscIdUnique 101 +runMainKey = mkPreludeMiscIdUnique 102 + +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashKey :: Unique +thenIOIdKey = mkPreludeMiscIdUnique 103 +lazyIdKey = mkPreludeMiscIdUnique 104 +assertErrorIdKey = mkPreludeMiscIdUnique 105 +oneShotKey = mkPreludeMiscIdUnique 106 +runRWKey = mkPreludeMiscIdUnique 107 + +traceKey :: Unique +traceKey = mkPreludeMiscIdUnique 108 + +nospecIdKey :: Unique +nospecIdKey = mkPreludeMiscIdUnique 109 + +inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique +inlineIdKey = mkPreludeMiscIdUnique 120 +-- see below + +mapIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique +mapIdKey = mkPreludeMiscIdUnique 121 +dollarIdKey = mkPreludeMiscIdUnique 123 +coercionTokenIdKey = mkPreludeMiscIdUnique 124 +considerAccessibleIdKey = mkPreludeMiscIdUnique 125 +noinlineIdKey = mkPreludeMiscIdUnique 126 +noinlineConstraintIdKey = mkPreludeMiscIdUnique 127 + +integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique +integerToFloatIdKey = mkPreludeMiscIdUnique 128 +integerToDoubleIdKey = mkPreludeMiscIdUnique 129 +naturalToFloatIdKey = mkPreludeMiscIdUnique 130 +naturalToDoubleIdKey = mkPreludeMiscIdUnique 131 + +rationalToFloatIdKey, rationalToDoubleIdKey :: Unique +rationalToFloatIdKey = mkPreludeMiscIdUnique 132 +rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 + +seqHashKey = mkPreludeMiscIdUnique 134 + +coerceKey :: Unique +coerceKey = mkPreludeMiscIdUnique 157 + +{- +Certain class operations from Prelude classes. They get their own +uniques so we can look them up easily when we want to conjure them up +during type checking. +-} + +-- Just a placeholder for unbound variables produced by the renamer: +unboundKey :: Unique +unboundKey = mkPreludeMiscIdUnique 158 + +fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, + enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, + enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, + bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey + :: Unique +fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 +minusClassOpKey = mkPreludeMiscIdUnique 161 +fromRationalClassOpKey = mkPreludeMiscIdUnique 162 +enumFromClassOpKey = mkPreludeMiscIdUnique 163 +enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 +enumFromToClassOpKey = mkPreludeMiscIdUnique 165 +enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 +eqClassOpKey = mkPreludeMiscIdUnique 167 +geClassOpKey = mkPreludeMiscIdUnique 168 +negateClassOpKey = mkPreludeMiscIdUnique 169 +bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) +thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) +fmapClassOpKey = mkPreludeMiscIdUnique 173 +returnMClassOpKey = mkPreludeMiscIdUnique 174 + +-- Recursive do notation +mfixIdKey :: Unique +mfixIdKey = mkPreludeMiscIdUnique 175 + +-- MonadFail operations +failMClassOpKey :: Unique +failMClassOpKey = mkPreludeMiscIdUnique 176 + +-- fromLabel +fromLabelClassOpKey :: Unique +fromLabelClassOpKey = mkPreludeMiscIdUnique 177 + +-- Arrow notation +arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, + loopAIdKey :: Unique +arrAIdKey = mkPreludeMiscIdUnique 180 +composeAIdKey = mkPreludeMiscIdUnique 181 -- >>> +firstAIdKey = mkPreludeMiscIdUnique 182 +appAIdKey = mkPreludeMiscIdUnique 183 +choiceAIdKey = mkPreludeMiscIdUnique 184 -- ||| +loopAIdKey = mkPreludeMiscIdUnique 185 + +fromStringClassOpKey :: Unique +fromStringClassOpKey = mkPreludeMiscIdUnique 186 + +-- Annotation type checking +toAnnotationWrapperIdKey :: Unique +toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 187 + +-- Conversion functions +fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique +fromIntegralIdKey = mkPreludeMiscIdUnique 190 +realToFracIdKey = mkPreludeMiscIdUnique 191 +toIntegerClassOpKey = mkPreludeMiscIdUnique 192 +toRationalClassOpKey = mkPreludeMiscIdUnique 193 + +-- Monad comprehensions +guardMIdKey, liftMIdKey, mzipIdKey :: Unique +guardMIdKey = mkPreludeMiscIdUnique 194 +liftMIdKey = mkPreludeMiscIdUnique 195 +mzipIdKey = mkPreludeMiscIdUnique 196 + +-- GHCi +ghciStepIoMClassOpKey :: Unique +ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 + +-- Overloaded lists +isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique +isListClassKey = mkPreludeMiscIdUnique 198 +fromListClassOpKey = mkPreludeMiscIdUnique 199 +fromListNClassOpKey = mkPreludeMiscIdUnique 500 +toListClassOpKey = mkPreludeMiscIdUnique 501 + +proxyHashKey :: Unique +proxyHashKey = mkPreludeMiscIdUnique 502 + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES IdUniques 200-499 +----------------------------------------------------- + +-- Used to make `Typeable` dictionaries +mkTyConKey + , mkTrTypeKey + , mkTrConKey + , mkTrAppCheckedKey + , mkTrFunKey + , typeNatTypeRepKey + , typeSymbolTypeRepKey + , typeCharTypeRepKey + , typeRepIdKey + :: Unique +mkTyConKey = mkPreludeMiscIdUnique 503 +mkTrTypeKey = mkPreludeMiscIdUnique 504 +mkTrConKey = mkPreludeMiscIdUnique 505 +mkTrAppCheckedKey = mkPreludeMiscIdUnique 506 +typeNatTypeRepKey = mkPreludeMiscIdUnique 507 +typeSymbolTypeRepKey = mkPreludeMiscIdUnique 508 +typeCharTypeRepKey = mkPreludeMiscIdUnique 509 +typeRepIdKey = mkPreludeMiscIdUnique 510 +mkTrFunKey = mkPreludeMiscIdUnique 511 + +-- KindReps for common cases +starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: Unique +starKindRepKey = mkPreludeMiscIdUnique 520 +starArrStarKindRepKey = mkPreludeMiscIdUnique 521 +starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522 +constraintKindRepKey = mkPreludeMiscIdUnique 523 + +-- Dynamic +toDynIdKey :: Unique +toDynIdKey = mkPreludeMiscIdUnique 530 + + +heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique +eqSCSelIdKey = mkPreludeMiscIdUnique 551 +heqSCSelIdKey = mkPreludeMiscIdUnique 552 +coercibleSCSelIdKey = mkPreludeMiscIdUnique 553 + +sappendClassOpKey :: Unique +sappendClassOpKey = mkPreludeMiscIdUnique 554 + +memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique +memptyClassOpKey = mkPreludeMiscIdUnique 555 +mappendClassOpKey = mkPreludeMiscIdUnique 556 +mconcatClassOpKey = mkPreludeMiscIdUnique 557 + +emptyCallStackKey, pushCallStackKey :: Unique +emptyCallStackKey = mkPreludeMiscIdUnique 558 +pushCallStackKey = mkPreludeMiscIdUnique 559 + +fromStaticPtrClassOpKey :: Unique +fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560 + +makeStaticKey :: Unique +makeStaticKey = mkPreludeMiscIdUnique 561 + +emptyExceptionContextKey :: Unique +emptyExceptionContextKey = mkPreludeMiscIdUnique 562 + +-- Unsafe coercion proofs +unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique +unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570 +unsafeCoercePrimIdKey = mkPreludeMiscIdUnique 571 + +-- HasField class ops +getFieldClassOpKey, setFieldClassOpKey :: Unique +getFieldClassOpKey = mkPreludeMiscIdUnique 572 +setFieldClassOpKey = mkPreludeMiscIdUnique 573 + +-- "Unsatisfiable" constraints +unsatisfiableIdNameKey :: Unique +unsatisfiableIdNameKey = mkPreludeMiscIdUnique 580 + +------------------------------------------------------ +-- ghc-bignum uses 600-699 uniques +------------------------------------------------------ + +integerFromNaturalIdKey + , integerToNaturalClampIdKey + , integerToNaturalThrowIdKey + , integerToNaturalIdKey + , integerToWordIdKey + , integerToIntIdKey + , integerToWord64IdKey + , integerToInt64IdKey + , integerAddIdKey + , integerMulIdKey + , integerSubIdKey + , integerNegateIdKey + , integerAbsIdKey + , integerPopCountIdKey + , integerQuotIdKey + , integerRemIdKey + , integerDivIdKey + , integerModIdKey + , integerDivModIdKey + , integerQuotRemIdKey + , integerEncodeFloatIdKey + , integerEncodeDoubleIdKey + , integerGcdIdKey + , integerLcmIdKey + , integerAndIdKey + , integerOrIdKey + , integerXorIdKey + , integerComplementIdKey + , integerBitIdKey + , integerTestBitIdKey + , integerShiftLIdKey + , integerShiftRIdKey + , integerFromWordIdKey + , integerFromWord64IdKey + , integerFromInt64IdKey + , naturalToWordIdKey + , naturalPopCountIdKey + , naturalShiftRIdKey + , naturalShiftLIdKey + , naturalAddIdKey + , naturalSubIdKey + , naturalSubThrowIdKey + , naturalSubUnsafeIdKey + , naturalMulIdKey + , naturalQuotRemIdKey + , naturalQuotIdKey + , naturalRemIdKey + , naturalAndIdKey + , naturalAndNotIdKey + , naturalOrIdKey + , naturalXorIdKey + , naturalTestBitIdKey + , naturalBitIdKey + , naturalGcdIdKey + , naturalLcmIdKey + , naturalLog2IdKey + , naturalLogBaseWordIdKey + , naturalLogBaseIdKey + , naturalPowModIdKey + , naturalSizeInBaseIdKey + , bignatEqIdKey + , bignatCompareIdKey + , bignatCompareWordIdKey + :: Unique + +integerFromNaturalIdKey = mkPreludeMiscIdUnique 600 +integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601 +integerToNaturalThrowIdKey = mkPreludeMiscIdUnique 602 +integerToNaturalIdKey = mkPreludeMiscIdUnique 603 +integerToWordIdKey = mkPreludeMiscIdUnique 604 +integerToIntIdKey = mkPreludeMiscIdUnique 605 +integerToWord64IdKey = mkPreludeMiscIdUnique 606 +integerToInt64IdKey = mkPreludeMiscIdUnique 607 +integerAddIdKey = mkPreludeMiscIdUnique 608 +integerMulIdKey = mkPreludeMiscIdUnique 609 +integerSubIdKey = mkPreludeMiscIdUnique 610 +integerNegateIdKey = mkPreludeMiscIdUnique 611 +integerAbsIdKey = mkPreludeMiscIdUnique 618 +integerPopCountIdKey = mkPreludeMiscIdUnique 621 +integerQuotIdKey = mkPreludeMiscIdUnique 622 +integerRemIdKey = mkPreludeMiscIdUnique 623 +integerDivIdKey = mkPreludeMiscIdUnique 624 +integerModIdKey = mkPreludeMiscIdUnique 625 +integerDivModIdKey = mkPreludeMiscIdUnique 626 +integerQuotRemIdKey = mkPreludeMiscIdUnique 627 +integerEncodeFloatIdKey = mkPreludeMiscIdUnique 630 +integerEncodeDoubleIdKey = mkPreludeMiscIdUnique 631 +integerGcdIdKey = mkPreludeMiscIdUnique 632 +integerLcmIdKey = mkPreludeMiscIdUnique 633 +integerAndIdKey = mkPreludeMiscIdUnique 634 +integerOrIdKey = mkPreludeMiscIdUnique 635 +integerXorIdKey = mkPreludeMiscIdUnique 636 +integerComplementIdKey = mkPreludeMiscIdUnique 637 +integerBitIdKey = mkPreludeMiscIdUnique 638 +integerTestBitIdKey = mkPreludeMiscIdUnique 639 +integerShiftLIdKey = mkPreludeMiscIdUnique 640 +integerShiftRIdKey = mkPreludeMiscIdUnique 641 +integerFromWordIdKey = mkPreludeMiscIdUnique 642 +integerFromWord64IdKey = mkPreludeMiscIdUnique 643 +integerFromInt64IdKey = mkPreludeMiscIdUnique 644 + +naturalToWordIdKey = mkPreludeMiscIdUnique 650 +naturalPopCountIdKey = mkPreludeMiscIdUnique 659 +naturalShiftRIdKey = mkPreludeMiscIdUnique 660 +naturalShiftLIdKey = mkPreludeMiscIdUnique 661 +naturalAddIdKey = mkPreludeMiscIdUnique 662 +naturalSubIdKey = mkPreludeMiscIdUnique 663 +naturalSubThrowIdKey = mkPreludeMiscIdUnique 664 +naturalSubUnsafeIdKey = mkPreludeMiscIdUnique 665 +naturalMulIdKey = mkPreludeMiscIdUnique 666 +naturalQuotRemIdKey = mkPreludeMiscIdUnique 669 +naturalQuotIdKey = mkPreludeMiscIdUnique 670 +naturalRemIdKey = mkPreludeMiscIdUnique 671 +naturalAndIdKey = mkPreludeMiscIdUnique 672 +naturalAndNotIdKey = mkPreludeMiscIdUnique 673 +naturalOrIdKey = mkPreludeMiscIdUnique 674 +naturalXorIdKey = mkPreludeMiscIdUnique 675 +naturalTestBitIdKey = mkPreludeMiscIdUnique 676 +naturalBitIdKey = mkPreludeMiscIdUnique 677 +naturalGcdIdKey = mkPreludeMiscIdUnique 678 +naturalLcmIdKey = mkPreludeMiscIdUnique 679 +naturalLog2IdKey = mkPreludeMiscIdUnique 680 +naturalLogBaseWordIdKey = mkPreludeMiscIdUnique 681 +naturalLogBaseIdKey = mkPreludeMiscIdUnique 682 +naturalPowModIdKey = mkPreludeMiscIdUnique 683 +naturalSizeInBaseIdKey = mkPreludeMiscIdUnique 684 + +bignatEqIdKey = mkPreludeMiscIdUnique 691 +bignatCompareIdKey = mkPreludeMiscIdUnique 692 +bignatCompareWordIdKey = mkPreludeMiscIdUnique 693 + + +------------------------------------------------------ +-- ghci optimization for big rationals 700-749 uniques +------------------------------------------------------ + +-- Creating rationals at runtime. +mkRationalBase2IdKey, mkRationalBase10IdKey :: Unique +mkRationalBase2IdKey = mkPreludeMiscIdUnique 700 +mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: Unique + +{- +************************************************************************ +* * +\subsection[Class-std-groups]{Standard groups of Prelude classes} +* * +************************************************************************ + +NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ +even though every numeric class has these two as a superclass, +because the list of ambiguous dictionaries hasn't been simplified. +-} + +numericClassKeys :: [Unique] +numericClassKeys = + [ numClassKey + , realClassKey + , integralClassKey + ] + ++ fractionalClassKeys + +fractionalClassKeys :: [Unique] +fractionalClassKeys = + [ fractionalClassKey + , floatingClassKey + , realFracClassKey + , realFloatClassKey + ] + +-- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), +-- and are: "classes defined in the Prelude or a standard library" +standardClassKeys :: [Unique] +standardClassKeys = derivableClassKeys ++ numericClassKeys + ++ [randomClassKey, randomGenClassKey, + functorClassKey, + monadClassKey, monadPlusClassKey, monadFailClassKey, + semigroupClassKey, monoidClassKey, + isStringClassKey, + applicativeClassKey, foldableClassKey, + traversableClassKey, alternativeClassKey + ] + +{- +@derivableClassKeys@ is also used in checking \tr{deriving} constructs +(@GHC.Tc.Deriv@). +-} + +derivableClassKeys :: [Unique] +derivableClassKeys + = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, + boundedClassKey, showClassKey, readClassKey ] + + +-- These are the "interactive classes" that are consulted when doing +-- defaulting. Does not include Num or IsString, which have special +-- handling. +interactiveClassNames :: [Name] +interactiveClassNames + = [ showClassName, eqClassName, ordClassName, foldableClassName + , traversableClassName ] + +interactiveClassKeys :: [Unique] +interactiveClassKeys = map getUnique interactiveClassNames diff --git a/GHC/Builtin/Names/TH.hs b/GHC/Builtin/Names/TH.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Names/TH.hs @@ -0,0 +1,1212 @@ +-- %************************************************************************ +-- %* * +-- The known-key names for Template Haskell +-- %* * +-- %************************************************************************ + +module GHC.Builtin.Names.TH where + +import GHC.Prelude () + +import GHC.Builtin.Names( mk_known_key_name ) +import GHC.Unit.Types +import GHC.Types.Name( Name ) +import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName, fieldName ) +import GHC.Types.Name.Reader( RdrName, nameRdrName ) +import GHC.Types.Unique ( Unique ) +import GHC.Builtin.Uniques +import GHC.Data.FastString + +import Language.Haskell.Syntax.Module.Name + +-- To add a name, do three things +-- +-- 1) Allocate a key +-- 2) Make a "Name" +-- 3) Add the name to templateHaskellNames + +templateHaskellNames :: [Name] +-- The names that are implicitly mentioned by ``bracket'' +-- Should stay in sync with the import list of GHC.HsToCore.Quote + +templateHaskellNames = [ + returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameG_fldName, + mkNameLName, + mkNameSName, mkNameQName, + mkModNameName, + liftStringName, + unTypeName, unTypeCodeName, + unsafeCodeCoerceName, + + -- Lit + charLName, stringLName, integerLName, intPrimLName, wordPrimLName, + floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, + charPrimLName, + -- Pat + litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, + conPName, tildePName, bangPName, infixPName, + asPName, wildPName, recPName, listPName, sigPName, viewPName, + typePName, invisPName, orPName, + -- FieldPat + fieldPatName, + -- Match + matchName, + -- Clause + clauseName, + -- Exp + varEName, conEName, litEName, appEName, appTypeEName, infixEName, + infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, + lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName, + condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName, + fromEName, fromThenEName, fromToEName, fromThenToEName, + listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName, + labelEName, implicitParamVarEName, getFieldEName, projectionEName, + typeEName, forallEName, forallVisEName, constrainedEName, + -- FieldExp + fieldExpName, + -- Body + guardedBName, normalBName, + -- Guard + normalGEName, patGEName, + -- Stmt + bindSName, letSName, noBindSName, parSName, recSName, + -- Dec + funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, + classDName, instanceWithOverlapDName, + standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName, + pragInlDName, pragOpaqueDName, + pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName, + pragSpecInstDName, + pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName, + defaultSigDName, defaultDName, + dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, + dataInstDName, newtypeInstDName, tySynInstDName, + infixLWithSpecDName, infixRWithSpecDName, infixNWithSpecDName, + roleAnnotDName, patSynDName, patSynSigDName, + implicitParamBindDName, + -- Cxt + cxtName, + + -- SourceUnpackedness + noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName, + -- SourceStrictness + noSourceStrictnessName, sourceLazyName, sourceStrictName, + -- Con + normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName, + -- Bang + bangName, + -- BangType + bangTypeName, + -- VarBangType + varBangTypeName, + -- PatSynDir (for pattern synonyms) + unidirPatSynName, implBidirPatSynName, explBidirPatSynName, + -- PatSynArgs (for pattern synonyms) + prefixPatSynName, infixPatSynName, recordPatSynName, + -- Type + forallTName, forallVisTName, varTName, conTName, infixTName, appTName, + appKindTName, equalityTName, tupleTName, unboxedTupleTName, + unboxedSumTName, arrowTName, mulArrowTName, listTName, sigTName, litTName, + promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, + wildCardTName, implicitParamTName, + -- TyLit + numTyLitName, strTyLitName, charTyLitName, + -- TyVarBndr + plainTVName, kindedTVName, + plainInvisTVName, kindedInvisTVName, + plainBndrTVName, kindedBndrTVName, + -- Specificity + specifiedSpecName, inferredSpecName, + -- Visibility + bndrReqName, bndrInvisName, + -- Role + nominalRName, representationalRName, phantomRName, inferRName, + -- Kind + starKName, constraintKName, + -- FamilyResultSig + noSigName, kindSigName, tyVarSigName, + -- InjectivityAnn + injectivityAnnName, + -- Callconv + cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName, + -- Safety + unsafeName, + safeName, + interruptibleName, + -- Inline + noInlineDataConName, inlineDataConName, inlinableDataConName, + -- RuleMatch + conLikeDataConName, funLikeDataConName, + -- Phases + allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName, + -- Overlap + overlappableDataConName, overlappingDataConName, overlapsDataConName, + incoherentDataConName, + -- NamespaceSpecifier + noNamespaceSpecifierDataConName, typeNamespaceSpecifierDataConName, + dataNamespaceSpecifierDataConName, + -- DerivStrategy + stockStrategyName, anyclassStrategyName, + newtypeStrategyName, viaStrategyName, + -- RuleBndr + ruleVarName, typedRuleVarName, + -- FunDep + funDepName, + -- TySynEqn + tySynEqnName, + -- AnnTarget + valueAnnotationName, typeAnnotationName, moduleAnnotationName, + -- DerivClause + derivClauseName, + + -- The type classes + liftClassName, quoteClassName, + + -- And the tycons + qTyConName, nameTyConName, patTyConName, + fieldPatTyConName, matchTyConName, + expQTyConName, fieldExpTyConName, predTyConName, + stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName, + varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName, + typeTyConName, + tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName, + clauseTyConName, + patQTyConName, funDepTyConName, decsQTyConName, + ruleBndrTyConName, tySynEqnTyConName, + roleTyConName, codeTyConName, injAnnTyConName, kindTyConName, + overlapTyConName, derivClauseTyConName, derivStrategyTyConName, + modNameTyConName, + + -- Quasiquoting + quasiQuoterTyConName, quoteDecName, quoteTypeName, quoteExpName, quotePatName] + +thSyn, thLib, qqLib, liftLib :: Module +thSyn = mkTHModule (fsLit "GHC.Internal.TH.Syntax") +thLib = mkTHModule (fsLit "GHC.Internal.TH.Lib") +qqLib = mkTHModule (fsLit "GHC.Internal.TH.Quote") +liftLib = mkTHModule (fsLit "GHC.Internal.TH.Lift") + +mkTHModule :: FastString -> Module +mkTHModule m = mkModule ghcInternalUnit (mkModuleNameFS m) + +libFun, libTc, thFun, thTc, thCls, thCon, liftFun :: FastString -> Unique -> Name +libFun = mk_known_key_name varName thLib +libTc = mk_known_key_name tcName thLib +thFun = mk_known_key_name varName thSyn +thTc = mk_known_key_name tcName thSyn +thCls = mk_known_key_name clsName thSyn +thCon = mk_known_key_name dataName thSyn +liftFun = mk_known_key_name varName liftLib + +thFld :: FastString -> FastString -> Unique -> Name +thFld con = mk_known_key_name (fieldName con) thSyn + +qqFld :: FastString -> Unique -> Name +qqFld = mk_known_key_name (fieldName (fsLit "QuasiQuoter")) qqLib + +-------------------- TH.Syntax ----------------------- +liftClassName :: Name +liftClassName = mk_known_key_name clsName liftLib (fsLit "Lift") liftClassKey + +quoteClassName :: Name +quoteClassName = thCls (fsLit "Quote") quoteClassKey + +qTyConName, nameTyConName, fieldExpTyConName, patTyConName, + fieldPatTyConName, expTyConName, decTyConName, typeTyConName, + matchTyConName, clauseTyConName, funDepTyConName, predTyConName, + codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName, + modNameTyConName, quasiQuoterTyConName :: Name +qTyConName = thTc (fsLit "Q") qTyConKey +nameTyConName = thTc (fsLit "Name") nameTyConKey +fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey +patTyConName = thTc (fsLit "Pat") patTyConKey +fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey +expTyConName = thTc (fsLit "Exp") expTyConKey +decTyConName = thTc (fsLit "Dec") decTyConKey +decsTyConName = libTc (fsLit "Decs") decsTyConKey +typeTyConName = thTc (fsLit "Type") typeTyConKey +matchTyConName = thTc (fsLit "Match") matchTyConKey +clauseTyConName = thTc (fsLit "Clause") clauseTyConKey +funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey +predTyConName = thTc (fsLit "Pred") predTyConKey +codeTyConName = thTc (fsLit "Code") codeTyConKey +injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey +overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey +modNameTyConName = thTc (fsLit "ModName") modNameTyConKey +quasiQuoterTyConName = mk_known_key_name tcName qqLib (fsLit "QuasiQuoter") quasiQuoterTyConKey + +returnQName, bindQName, sequenceQName, newNameName, liftName, + mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName, + mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName, + unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name +returnQName = thFun (fsLit "returnQ") returnQIdKey +bindQName = thFun (fsLit "bindQ") bindQIdKey +sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey +newNameName = thFun (fsLit "newName") newNameIdKey +mkNameName = thFun (fsLit "mkName") mkNameIdKey +mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey +mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey +mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey +mkNameG_fldName= thFun (fsLit "mkNameG_fld") mkNameG_fldIdKey +mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey +mkNameQName = thFun (fsLit "mkNameQ") mkNameQIdKey +mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey +mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey +unTypeName = thFld (fsLit "TExp") (fsLit "unType") unTypeIdKey +unTypeCodeName = thFun (fsLit "unTypeCode") unTypeCodeIdKey +unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey +liftName = liftFun (fsLit "lift") liftIdKey +liftStringName = liftFun (fsLit "liftString") liftStringIdKey +liftTypedName = liftFun (fsLit "liftTyped") liftTypedIdKey + + +-------------------- TH.Lib ----------------------- +-- data Lit = ... +charLName, stringLName, integerLName, intPrimLName, wordPrimLName, + floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, + charPrimLName :: Name +charLName = libFun (fsLit "charL") charLIdKey +stringLName = libFun (fsLit "stringL") stringLIdKey +integerLName = libFun (fsLit "integerL") integerLIdKey +intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey +wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey +floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey +doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey +rationalLName = libFun (fsLit "rationalL") rationalLIdKey +stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey +charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey + +-- data Pat = ... +litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName, + infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName, + sigPName, viewPName, typePName, invisPName, orPName :: Name +litPName = libFun (fsLit "litP") litPIdKey +varPName = libFun (fsLit "varP") varPIdKey +tupPName = libFun (fsLit "tupP") tupPIdKey +unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey +unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey +conPName = libFun (fsLit "conP") conPIdKey +infixPName = libFun (fsLit "infixP") infixPIdKey +tildePName = libFun (fsLit "tildeP") tildePIdKey +bangPName = libFun (fsLit "bangP") bangPIdKey +asPName = libFun (fsLit "asP") asPIdKey +wildPName = libFun (fsLit "wildP") wildPIdKey +recPName = libFun (fsLit "recP") recPIdKey +listPName = libFun (fsLit "listP") listPIdKey +sigPName = libFun (fsLit "sigP") sigPIdKey +viewPName = libFun (fsLit "viewP") viewPIdKey +orPName = libFun (fsLit "orP") orPIdKey +typePName = libFun (fsLit "typeP") typePIdKey +invisPName = libFun (fsLit "invisP") invisPIdKey + +-- type FieldPat = ... +fieldPatName :: Name +fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey + +-- data Match = ... +matchName :: Name +matchName = libFun (fsLit "match") matchIdKey + +-- data Clause = ... +clauseName :: Name +clauseName = libFun (fsLit "clause") clauseIdKey + +-- data Exp = ... +varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName, + sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName, + unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName, + caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName, + labelEName, implicitParamVarEName, getFieldEName, projectionEName, typeEName, + forallEName, forallVisEName, constrainedEName :: Name +varEName = libFun (fsLit "varE") varEIdKey +conEName = libFun (fsLit "conE") conEIdKey +litEName = libFun (fsLit "litE") litEIdKey +appEName = libFun (fsLit "appE") appEIdKey +appTypeEName = libFun (fsLit "appTypeE") appTypeEIdKey +infixEName = libFun (fsLit "infixE") infixEIdKey +infixAppName = libFun (fsLit "infixApp") infixAppIdKey +sectionLName = libFun (fsLit "sectionL") sectionLIdKey +sectionRName = libFun (fsLit "sectionR") sectionRIdKey +lamEName = libFun (fsLit "lamE") lamEIdKey +lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey +lamCasesEName = libFun (fsLit "lamCasesE") lamCasesEIdKey +tupEName = libFun (fsLit "tupE") tupEIdKey +unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey +unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey +condEName = libFun (fsLit "condE") condEIdKey +multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey +letEName = libFun (fsLit "letE") letEIdKey +caseEName = libFun (fsLit "caseE") caseEIdKey +doEName = libFun (fsLit "doE") doEIdKey +mdoEName = libFun (fsLit "mdoE") mdoEIdKey +compEName = libFun (fsLit "compE") compEIdKey +-- ArithSeq skips a level +fromEName, fromThenEName, fromToEName, fromThenToEName :: Name +fromEName = libFun (fsLit "fromE") fromEIdKey +fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey +fromToEName = libFun (fsLit "fromToE") fromToEIdKey +fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey +-- end ArithSeq +listEName, sigEName, recConEName, recUpdEName :: Name +listEName = libFun (fsLit "listE") listEIdKey +sigEName = libFun (fsLit "sigE") sigEIdKey +recConEName = libFun (fsLit "recConE") recConEIdKey +recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey +staticEName = libFun (fsLit "staticE") staticEIdKey +unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey +labelEName = libFun (fsLit "labelE") labelEIdKey +implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey +getFieldEName = libFun (fsLit "getFieldE") getFieldEIdKey +projectionEName = libFun (fsLit "projectionE") projectionEIdKey +typeEName = libFun (fsLit "typeE") typeEIdKey +forallEName = libFun (fsLit "forallE") forallEIdKey +forallVisEName = libFun (fsLit "forallVisE") forallVisEIdKey +constrainedEName = libFun (fsLit "constrainedE") constrainedEIdKey + +-- type FieldExp = ... +fieldExpName :: Name +fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey + +-- data Body = ... +guardedBName, normalBName :: Name +guardedBName = libFun (fsLit "guardedB") guardedBIdKey +normalBName = libFun (fsLit "normalB") normalBIdKey + +-- data Guard = ... +normalGEName, patGEName :: Name +normalGEName = libFun (fsLit "normalGE") normalGEIdKey +patGEName = libFun (fsLit "patGE") patGEIdKey + +-- data Stmt = ... +bindSName, letSName, noBindSName, parSName, recSName :: Name +bindSName = libFun (fsLit "bindS") bindSIdKey +letSName = libFun (fsLit "letS") letSIdKey +noBindSName = libFun (fsLit "noBindS") noBindSIdKey +parSName = libFun (fsLit "parS") parSIdKey +recSName = libFun (fsLit "recS") recSIdKey + +-- data Dec = ... +funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName, + instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName, + pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName, + pragSpecInstDName, pragRuleDName, + pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName, + standaloneDerivWithStrategyDName, defaultSigDName, defaultDName, + dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName, + openTypeFamilyDName, closedTypeFamilyDName, infixLWithSpecDName, + infixRWithSpecDName, infixNWithSpecDName, roleAnnotDName, patSynDName, + patSynSigDName, pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name +funDName = libFun (fsLit "funD") funDIdKey +valDName = libFun (fsLit "valD") valDIdKey +dataDName = libFun (fsLit "dataD") dataDIdKey +newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey +typeDataDName = libFun (fsLit "typeDataD") typeDataDIdKey +tySynDName = libFun (fsLit "tySynD") tySynDIdKey +classDName = libFun (fsLit "classD") classDIdKey +instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey +standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey +sigDName = libFun (fsLit "sigD") sigDIdKey +kiSigDName = libFun (fsLit "kiSigD") kiSigDIdKey +defaultDName = libFun (fsLit "defaultD") defaultDIdKey +defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey +forImpDName = libFun (fsLit "forImpD") forImpDIdKey +pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey +pragOpaqueDName = libFun (fsLit "pragOpaqueD") pragOpaqueDIdKey +pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey +pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey +pragSpecEDName = libFun (fsLit "pragSpecED") pragSpecEDIdKey +pragSpecInlEDName = libFun (fsLit "pragSpecInlED") pragSpecInlEDIdKey +pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey +pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey +pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey +pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey +pragSCCFunDName = libFun (fsLit "pragSCCFunD") pragSCCFunDKey +pragSCCFunNamedDName = libFun (fsLit "pragSCCFunNamedD") pragSCCFunNamedDKey +dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey +newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey +tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey +closedTypeFamilyDName = libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey +dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey +infixLWithSpecDName = libFun (fsLit "infixLWithSpecD") infixLWithSpecDIdKey +infixRWithSpecDName = libFun (fsLit "infixRWithSpecD") infixRWithSpecDIdKey +infixNWithSpecDName = libFun (fsLit "infixNWithSpecD") infixNWithSpecDIdKey +roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey +patSynDName = libFun (fsLit "patSynD") patSynDIdKey +patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey +implicitParamBindDName = libFun (fsLit "implicitParamBindD") implicitParamBindDIdKey + +-- type Ctxt = ... +cxtName :: Name +cxtName = libFun (fsLit "cxt") cxtIdKey + +-- data SourceUnpackedness = ... +noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name +noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey +sourceNoUnpackName = libFun (fsLit "sourceNoUnpack") sourceNoUnpackKey +sourceUnpackName = libFun (fsLit "sourceUnpack") sourceUnpackKey + +-- data SourceStrictness = ... +noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name +noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey +sourceLazyName = libFun (fsLit "sourceLazy") sourceLazyKey +sourceStrictName = libFun (fsLit "sourceStrict") sourceStrictKey + +-- data Con = ... +normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name +normalCName = libFun (fsLit "normalC" ) normalCIdKey +recCName = libFun (fsLit "recC" ) recCIdKey +infixCName = libFun (fsLit "infixC" ) infixCIdKey +forallCName = libFun (fsLit "forallC" ) forallCIdKey +gadtCName = libFun (fsLit "gadtC" ) gadtCIdKey +recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey + +-- data Bang = ... +bangName :: Name +bangName = libFun (fsLit "bang") bangIdKey + +-- type BangType = ... +bangTypeName :: Name +bangTypeName = libFun (fsLit "bangType") bangTKey + +-- type VarBangType = ... +varBangTypeName :: Name +varBangTypeName = libFun (fsLit "varBangType") varBangTKey + +-- data PatSynDir = ... +unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name +unidirPatSynName = libFun (fsLit "unidir") unidirPatSynIdKey +implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey +explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey + +-- data PatSynArgs = ... +prefixPatSynName, infixPatSynName, recordPatSynName :: Name +prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey +infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey +recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey + +-- data Type = ... +forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName, + unboxedTupleTName, unboxedSumTName, arrowTName, mulArrowTName, listTName, + appTName, appKindTName, sigTName, equalityTName, litTName, promotedTName, + promotedTupleTName, promotedNilTName, promotedConsTName, + wildCardTName, implicitParamTName :: Name +forallTName = libFun (fsLit "forallT") forallTIdKey +forallVisTName = libFun (fsLit "forallVisT") forallVisTIdKey +varTName = libFun (fsLit "varT") varTIdKey +conTName = libFun (fsLit "conT") conTIdKey +tupleTName = libFun (fsLit "tupleT") tupleTIdKey +unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey +unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey +arrowTName = libFun (fsLit "arrowT") arrowTIdKey +mulArrowTName = libFun (fsLit "mulArrowT") mulArrowTIdKey +listTName = libFun (fsLit "listT") listTIdKey +appTName = libFun (fsLit "appT") appTIdKey +appKindTName = libFun (fsLit "appKindT") appKindTIdKey +sigTName = libFun (fsLit "sigT") sigTIdKey +equalityTName = libFun (fsLit "equalityT") equalityTIdKey +litTName = libFun (fsLit "litT") litTIdKey +promotedTName = libFun (fsLit "promotedT") promotedTIdKey +promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey +promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey +promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey +wildCardTName = libFun (fsLit "wildCardT") wildCardTIdKey +infixTName = libFun (fsLit "infixT") infixTIdKey +implicitParamTName = libFun (fsLit "implicitParamT") implicitParamTIdKey + +-- data TyLit = ... +numTyLitName, strTyLitName, charTyLitName :: Name +numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey +strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey +charTyLitName = libFun (fsLit "charTyLit") charTyLitIdKey + +-- data TyVarBndr = ... +plainTVName, kindedTVName :: Name +plainTVName = libFun (fsLit "plainTV") plainTVIdKey +kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey + +plainInvisTVName, kindedInvisTVName :: Name +plainInvisTVName = libFun (fsLit "plainInvisTV") plainInvisTVIdKey +kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey + +plainBndrTVName, kindedBndrTVName :: Name +plainBndrTVName = libFun (fsLit "plainBndrTV") plainBndrTVIdKey +kindedBndrTVName = libFun (fsLit "kindedBndrTV") kindedBndrTVIdKey + +-- data Specificity = ... +specifiedSpecName, inferredSpecName :: Name +specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey +inferredSpecName = libFun (fsLit "inferredSpec") inferredSpecKey + +-- data BndrVis = ... +bndrReqName, bndrInvisName :: Name +bndrReqName = libFun (fsLit "bndrReq") bndrReqKey +bndrInvisName = libFun (fsLit "bndrInvis") bndrInvisKey + +-- data Role = ... +nominalRName, representationalRName, phantomRName, inferRName :: Name +nominalRName = libFun (fsLit "nominalR") nominalRIdKey +representationalRName = libFun (fsLit "representationalR") representationalRIdKey +phantomRName = libFun (fsLit "phantomR") phantomRIdKey +inferRName = libFun (fsLit "inferR") inferRIdKey + +-- data Kind = ... +starKName, constraintKName :: Name +starKName = libFun (fsLit "starK") starKIdKey +constraintKName = libFun (fsLit "constraintK") constraintKIdKey + +-- data FamilyResultSig = ... +noSigName, kindSigName, tyVarSigName :: Name +noSigName = libFun (fsLit "noSig") noSigIdKey +kindSigName = libFun (fsLit "kindSig") kindSigIdKey +tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey + +-- data InjectivityAnn = ... +injectivityAnnName :: Name +injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey + +-- data Callconv = ... +cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name +cCallName = libFun (fsLit "cCall") cCallIdKey +stdCallName = libFun (fsLit "stdCall") stdCallIdKey +cApiCallName = libFun (fsLit "cApi") cApiCallIdKey +primCallName = libFun (fsLit "prim") primCallIdKey +javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey + +-- data Safety = ... +unsafeName, safeName, interruptibleName :: Name +unsafeName = libFun (fsLit "unsafe") unsafeIdKey +safeName = libFun (fsLit "safe") safeIdKey +interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey + +-- data RuleBndr = ... +ruleVarName, typedRuleVarName :: Name +ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey +typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey + +-- data FunDep = ... +funDepName :: Name +funDepName = libFun (fsLit "funDep") funDepIdKey + +-- data TySynEqn = ... +tySynEqnName :: Name +tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey + +-- data AnnTarget = ... +valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name +valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey +typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey +moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey + +-- type DerivClause = ... +derivClauseName :: Name +derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey + +-- data DerivStrategy = ... +stockStrategyName, anyclassStrategyName, newtypeStrategyName, + viaStrategyName :: Name +stockStrategyName = libFun (fsLit "stockStrategy") stockStrategyIdKey +anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey +newtypeStrategyName = libFun (fsLit "newtypeStrategy") newtypeStrategyIdKey +viaStrategyName = libFun (fsLit "viaStrategy") viaStrategyIdKey + +patQTyConName, expQTyConName, stmtTyConName, + conTyConName, bangTypeTyConName, + varBangTypeTyConName, typeQTyConName, + decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, + derivClauseTyConName, kindTyConName, + tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName, + derivStrategyTyConName :: Name +-- These are only used for the types of top-level splices +expQTyConName = libTc (fsLit "ExpQ") expQTyConKey +decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] +typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey +patQTyConName = libTc (fsLit "PatQ") patQTyConKey + +-- These are used in GHC.HsToCore.Quote but always wrapped in a type variable +stmtTyConName = thTc (fsLit "Stmt") stmtTyConKey +conTyConName = thTc (fsLit "Con") conTyConKey +bangTypeTyConName = thTc (fsLit "BangType") bangTypeTyConKey +varBangTypeTyConName = thTc (fsLit "VarBangType") varBangTypeTyConKey +ruleBndrTyConName = thTc (fsLit "RuleBndr") ruleBndrTyConKey +tySynEqnTyConName = thTc (fsLit "TySynEqn") tySynEqnTyConKey +roleTyConName = libTc (fsLit "Role") roleTyConKey +derivClauseTyConName = thTc (fsLit "DerivClause") derivClauseTyConKey +kindTyConName = thTc (fsLit "Kind") kindTyConKey +tyVarBndrUnitTyConName = libTc (fsLit "TyVarBndrUnit") tyVarBndrUnitTyConKey +tyVarBndrSpecTyConName = libTc (fsLit "TyVarBndrSpec") tyVarBndrSpecTyConKey +tyVarBndrVisTyConName = libTc (fsLit "TyVarBndrVis") tyVarBndrVisTyConKey +derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey + +-- quasiquoting +quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name +quoteExpName = qqFld (fsLit "quoteExp") quoteExpKey +quotePatName = qqFld (fsLit "quotePat") quotePatKey +quoteDecName = qqFld (fsLit "quoteDec") quoteDecKey +quoteTypeName = qqFld (fsLit "quoteType") quoteTypeKey + +-- data Inline = ... +noInlineDataConName, inlineDataConName, inlinableDataConName :: Name +noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey +inlineDataConName = thCon (fsLit "Inline") inlineDataConKey +inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey + +-- data RuleMatch = ... +conLikeDataConName, funLikeDataConName :: Name +conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey +funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey + +-- data Phases = ... +allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name +allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey +fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey +beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey + +-- data Overlap = ... +overlappableDataConName, + overlappingDataConName, + overlapsDataConName, + incoherentDataConName :: Name +overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey +overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey +overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey +incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey + +-- data NamespaceSpecifier = ... +noNamespaceSpecifierDataConName, + typeNamespaceSpecifierDataConName, + dataNamespaceSpecifierDataConName :: Name +noNamespaceSpecifierDataConName = + thCon (fsLit "NoNamespaceSpecifier") noNamespaceSpecifierDataConKey +typeNamespaceSpecifierDataConName = + thCon (fsLit "TypeNamespaceSpecifier") typeNamespaceSpecifierDataConKey +dataNamespaceSpecifierDataConName = + thCon (fsLit "DataNamespaceSpecifier") dataNamespaceSpecifierDataConKey + +{- ********************************************************************* +* * + Class keys +* * +********************************************************************* -} + +-- ClassUniques available: 200-299 +-- Check in GHC.Builtin.Names if you want to change this + +liftClassKey :: Unique +liftClassKey = mkPreludeClassUnique 200 + +quoteClassKey :: Unique +quoteClassKey = mkPreludeClassUnique 201 + +{- ********************************************************************* +* * + TyCon keys +* * +********************************************************************* -} + +-- TyConUniques available: 200-299 +-- Check in GHC.Builtin.Names if you want to change this + +expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, + patTyConKey, + stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey, + tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey, tyVarBndrVisTyConKey, + decTyConKey, bangTypeTyConKey, varBangTypeTyConKey, + fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, + funDepTyConKey, predTyConKey, + predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey, + roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey, + overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey, + modNameTyConKey, quasiQuoterTyConKey :: Unique +expTyConKey = mkPreludeTyConUnique 200 +matchTyConKey = mkPreludeTyConUnique 201 +clauseTyConKey = mkPreludeTyConUnique 202 +qTyConKey = mkPreludeTyConUnique 203 +expQTyConKey = mkPreludeTyConUnique 204 +patTyConKey = mkPreludeTyConUnique 206 +stmtTyConKey = mkPreludeTyConUnique 209 +conTyConKey = mkPreludeTyConUnique 210 +typeQTyConKey = mkPreludeTyConUnique 211 +typeTyConKey = mkPreludeTyConUnique 212 +decTyConKey = mkPreludeTyConUnique 213 +bangTypeTyConKey = mkPreludeTyConUnique 214 +varBangTypeTyConKey = mkPreludeTyConUnique 215 +fieldExpTyConKey = mkPreludeTyConUnique 216 +fieldPatTyConKey = mkPreludeTyConUnique 217 +nameTyConKey = mkPreludeTyConUnique 218 +patQTyConKey = mkPreludeTyConUnique 219 +funDepTyConKey = mkPreludeTyConUnique 222 +predTyConKey = mkPreludeTyConUnique 223 +predQTyConKey = mkPreludeTyConUnique 224 +tyVarBndrUnitTyConKey = mkPreludeTyConUnique 225 +decsQTyConKey = mkPreludeTyConUnique 226 +ruleBndrTyConKey = mkPreludeTyConUnique 227 +tySynEqnTyConKey = mkPreludeTyConUnique 228 +roleTyConKey = mkPreludeTyConUnique 229 +injAnnTyConKey = mkPreludeTyConUnique 231 +kindTyConKey = mkPreludeTyConUnique 232 +overlapTyConKey = mkPreludeTyConUnique 233 +derivClauseTyConKey = mkPreludeTyConUnique 234 +derivStrategyTyConKey = mkPreludeTyConUnique 235 +decsTyConKey = mkPreludeTyConUnique 236 +tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237 +codeTyConKey = mkPreludeTyConUnique 238 +modNameTyConKey = mkPreludeTyConUnique 239 +tyVarBndrVisTyConKey = mkPreludeTyConUnique 240 +quasiQuoterTyConKey = mkPreludeTyConUnique 241 + +{- ********************************************************************* +* * + DataCon keys +* * +********************************************************************* -} + +-- DataConUniques available: 100-150 +-- If you want to change this, make sure you check in GHC.Builtin.Names + +-- data Inline = ... +noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique +noInlineDataConKey = mkPreludeDataConUnique 200 +inlineDataConKey = mkPreludeDataConUnique 201 +inlinableDataConKey = mkPreludeDataConUnique 202 + +-- data RuleMatch = ... +conLikeDataConKey, funLikeDataConKey :: Unique +conLikeDataConKey = mkPreludeDataConUnique 204 +funLikeDataConKey = mkPreludeDataConUnique 205 + +-- data Phases = ... +allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique +allPhasesDataConKey = mkPreludeDataConUnique 206 +fromPhaseDataConKey = mkPreludeDataConUnique 207 +beforePhaseDataConKey = mkPreludeDataConUnique 208 + +-- data Overlap = .. +overlappableDataConKey, + overlappingDataConKey, + overlapsDataConKey, + incoherentDataConKey :: Unique +overlappableDataConKey = mkPreludeDataConUnique 209 +overlappingDataConKey = mkPreludeDataConUnique 210 +overlapsDataConKey = mkPreludeDataConUnique 211 +incoherentDataConKey = mkPreludeDataConUnique 212 + +-- data NamespaceSpecifier = ... +noNamespaceSpecifierDataConKey, + typeNamespaceSpecifierDataConKey, + dataNamespaceSpecifierDataConKey :: Unique +noNamespaceSpecifierDataConKey = mkPreludeDataConUnique 213 +typeNamespaceSpecifierDataConKey = mkPreludeDataConUnique 214 +dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215 +{- ********************************************************************* +* * + Id keys +* * +********************************************************************* -} + +-- IdUniques available: 200-499 +-- If you want to change this, make sure you check in GHC.Builtin.Names + +returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, + mkNameIdKey, mkNameG_vIdKey, mkNameG_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, + mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey, + unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique +returnQIdKey = mkPreludeMiscIdUnique 200 +bindQIdKey = mkPreludeMiscIdUnique 201 +sequenceQIdKey = mkPreludeMiscIdUnique 202 +liftIdKey = mkPreludeMiscIdUnique 203 +newNameIdKey = mkPreludeMiscIdUnique 204 +mkNameIdKey = mkPreludeMiscIdUnique 205 +mkNameG_vIdKey = mkPreludeMiscIdUnique 206 +mkNameG_dIdKey = mkPreludeMiscIdUnique 207 +mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 +mkNameLIdKey = mkPreludeMiscIdUnique 209 +mkNameSIdKey = mkPreludeMiscIdUnique 210 +unTypeIdKey = mkPreludeMiscIdUnique 211 +unTypeCodeIdKey = mkPreludeMiscIdUnique 212 +liftTypedIdKey = mkPreludeMiscIdUnique 214 +mkModNameIdKey = mkPreludeMiscIdUnique 215 +unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216 +mkNameQIdKey = mkPreludeMiscIdUnique 217 +mkNameG_fldIdKey = mkPreludeMiscIdUnique 218 + + +-- data Lit = ... +charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, + floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey, + charPrimLIdKey:: Unique +charLIdKey = mkPreludeMiscIdUnique 220 +stringLIdKey = mkPreludeMiscIdUnique 221 +integerLIdKey = mkPreludeMiscIdUnique 222 +intPrimLIdKey = mkPreludeMiscIdUnique 223 +wordPrimLIdKey = mkPreludeMiscIdUnique 224 +floatPrimLIdKey = mkPreludeMiscIdUnique 225 +doublePrimLIdKey = mkPreludeMiscIdUnique 226 +rationalLIdKey = mkPreludeMiscIdUnique 227 +stringPrimLIdKey = mkPreludeMiscIdUnique 228 +charPrimLIdKey = mkPreludeMiscIdUnique 229 + +liftStringIdKey :: Unique +liftStringIdKey = mkPreludeMiscIdUnique 230 + +-- data Pat = ... +litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey, + infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, + listPIdKey, sigPIdKey, viewPIdKey, typePIdKey, invisPIdKey, orPIdKey :: Unique +litPIdKey = mkPreludeMiscIdUnique 240 +varPIdKey = mkPreludeMiscIdUnique 241 +tupPIdKey = mkPreludeMiscIdUnique 242 +unboxedTupPIdKey = mkPreludeMiscIdUnique 243 +unboxedSumPIdKey = mkPreludeMiscIdUnique 244 +conPIdKey = mkPreludeMiscIdUnique 245 +infixPIdKey = mkPreludeMiscIdUnique 246 +tildePIdKey = mkPreludeMiscIdUnique 247 +bangPIdKey = mkPreludeMiscIdUnique 248 +asPIdKey = mkPreludeMiscIdUnique 249 +wildPIdKey = mkPreludeMiscIdUnique 250 +recPIdKey = mkPreludeMiscIdUnique 251 +listPIdKey = mkPreludeMiscIdUnique 252 +sigPIdKey = mkPreludeMiscIdUnique 253 +viewPIdKey = mkPreludeMiscIdUnique 254 +typePIdKey = mkPreludeMiscIdUnique 255 +invisPIdKey = mkPreludeMiscIdUnique 256 +orPIdKey = mkPreludeMiscIdUnique 257 + +-- type FieldPat = ... +fieldPatIdKey :: Unique +fieldPatIdKey = mkPreludeMiscIdUnique 260 + +-- data Match = ... +matchIdKey :: Unique +matchIdKey = mkPreludeMiscIdUnique 261 + +-- data Clause = ... +clauseIdKey :: Unique +clauseIdKey = mkPreludeMiscIdUnique 262 + + +-- data Exp = ... +varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey, + infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, + lamCasesEIdKey, tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, + multiIfEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey, + fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, + listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey, + unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey, + getFieldEIdKey, projectionEIdKey, typeEIdKey, forallEIdKey, + forallVisEIdKey, constrainedEIdKey :: Unique +varEIdKey = mkPreludeMiscIdUnique 270 +conEIdKey = mkPreludeMiscIdUnique 271 +litEIdKey = mkPreludeMiscIdUnique 272 +appEIdKey = mkPreludeMiscIdUnique 273 +appTypeEIdKey = mkPreludeMiscIdUnique 274 +infixEIdKey = mkPreludeMiscIdUnique 275 +infixAppIdKey = mkPreludeMiscIdUnique 276 +sectionLIdKey = mkPreludeMiscIdUnique 277 +sectionRIdKey = mkPreludeMiscIdUnique 278 +lamEIdKey = mkPreludeMiscIdUnique 279 +lamCaseEIdKey = mkPreludeMiscIdUnique 280 +lamCasesEIdKey = mkPreludeMiscIdUnique 281 +tupEIdKey = mkPreludeMiscIdUnique 282 +unboxedTupEIdKey = mkPreludeMiscIdUnique 283 +unboxedSumEIdKey = mkPreludeMiscIdUnique 284 +condEIdKey = mkPreludeMiscIdUnique 285 +multiIfEIdKey = mkPreludeMiscIdUnique 286 +letEIdKey = mkPreludeMiscIdUnique 287 +caseEIdKey = mkPreludeMiscIdUnique 288 +doEIdKey = mkPreludeMiscIdUnique 289 +compEIdKey = mkPreludeMiscIdUnique 290 +fromEIdKey = mkPreludeMiscIdUnique 291 +fromThenEIdKey = mkPreludeMiscIdUnique 292 +fromToEIdKey = mkPreludeMiscIdUnique 293 +fromThenToEIdKey = mkPreludeMiscIdUnique 294 +listEIdKey = mkPreludeMiscIdUnique 295 +sigEIdKey = mkPreludeMiscIdUnique 296 +recConEIdKey = mkPreludeMiscIdUnique 297 +recUpdEIdKey = mkPreludeMiscIdUnique 298 +staticEIdKey = mkPreludeMiscIdUnique 299 +unboundVarEIdKey = mkPreludeMiscIdUnique 300 +labelEIdKey = mkPreludeMiscIdUnique 301 +implicitParamVarEIdKey = mkPreludeMiscIdUnique 302 +mdoEIdKey = mkPreludeMiscIdUnique 303 +getFieldEIdKey = mkPreludeMiscIdUnique 304 +projectionEIdKey = mkPreludeMiscIdUnique 305 +typeEIdKey = mkPreludeMiscIdUnique 306 +forallEIdKey = mkPreludeMiscIdUnique 802 +forallVisEIdKey = mkPreludeMiscIdUnique 803 +constrainedEIdKey = mkPreludeMiscIdUnique 804 + +-- type FieldExp = ... +fieldExpIdKey :: Unique +fieldExpIdKey = mkPreludeMiscIdUnique 307 + +-- data Body = ... +guardedBIdKey, normalBIdKey :: Unique +guardedBIdKey = mkPreludeMiscIdUnique 308 +normalBIdKey = mkPreludeMiscIdUnique 309 + +-- data Guard = ... +normalGEIdKey, patGEIdKey :: Unique +normalGEIdKey = mkPreludeMiscIdUnique 310 +patGEIdKey = mkPreludeMiscIdUnique 311 + +-- data Stmt = ... +bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique +bindSIdKey = mkPreludeMiscIdUnique 312 +letSIdKey = mkPreludeMiscIdUnique 313 +noBindSIdKey = mkPreludeMiscIdUnique 314 +parSIdKey = mkPreludeMiscIdUnique 315 +recSIdKey = mkPreludeMiscIdUnique 316 + +-- data Dec = ... +funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, + instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, + pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, + pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, + openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey, + newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey, + infixLWithSpecDIdKey, infixRWithSpecDIdKey, infixNWithSpecDIdKey, + roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey, + implicitParamBindDIdKey, kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, + typeDataDIdKey, pragSCCFunDKey, pragSCCFunNamedDKey, + pragSpecEDIdKey, pragSpecInlEDIdKey :: Unique +funDIdKey = mkPreludeMiscIdUnique 320 +valDIdKey = mkPreludeMiscIdUnique 321 +dataDIdKey = mkPreludeMiscIdUnique 322 +newtypeDIdKey = mkPreludeMiscIdUnique 323 +tySynDIdKey = mkPreludeMiscIdUnique 324 +classDIdKey = mkPreludeMiscIdUnique 325 +instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 326 +instanceDIdKey = mkPreludeMiscIdUnique 327 +sigDIdKey = mkPreludeMiscIdUnique 328 +forImpDIdKey = mkPreludeMiscIdUnique 329 +pragInlDIdKey = mkPreludeMiscIdUnique 330 +pragSpecDIdKey = mkPreludeMiscIdUnique 331 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 332 +pragSpecInstDIdKey = mkPreludeMiscIdUnique 333 +pragRuleDIdKey = mkPreludeMiscIdUnique 334 +pragAnnDIdKey = mkPreludeMiscIdUnique 335 +dataFamilyDIdKey = mkPreludeMiscIdUnique 336 +openTypeFamilyDIdKey = mkPreludeMiscIdUnique 337 +dataInstDIdKey = mkPreludeMiscIdUnique 338 +newtypeInstDIdKey = mkPreludeMiscIdUnique 339 +tySynInstDIdKey = mkPreludeMiscIdUnique 340 +closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 341 +infixLWithSpecDIdKey = mkPreludeMiscIdUnique 342 +infixRWithSpecDIdKey = mkPreludeMiscIdUnique 343 +infixNWithSpecDIdKey = mkPreludeMiscIdUnique 344 +roleAnnotDIdKey = mkPreludeMiscIdUnique 345 +standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346 +defaultSigDIdKey = mkPreludeMiscIdUnique 347 +patSynDIdKey = mkPreludeMiscIdUnique 348 +patSynSigDIdKey = mkPreludeMiscIdUnique 349 +pragCompleteDIdKey = mkPreludeMiscIdUnique 350 +implicitParamBindDIdKey = mkPreludeMiscIdUnique 351 +kiSigDIdKey = mkPreludeMiscIdUnique 352 +defaultDIdKey = mkPreludeMiscIdUnique 353 +pragOpaqueDIdKey = mkPreludeMiscIdUnique 354 +typeDataDIdKey = mkPreludeMiscIdUnique 355 +pragSCCFunDKey = mkPreludeMiscIdUnique 356 +pragSCCFunNamedDKey = mkPreludeMiscIdUnique 357 +pragSpecEDIdKey = mkPreludeMiscIdUnique 358 +pragSpecInlEDIdKey = mkPreludeMiscIdUnique 359 + +-- type Cxt = ... +cxtIdKey :: Unique +cxtIdKey = mkPreludeMiscIdUnique 361 + +-- data SourceUnpackedness = ... +noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique +noSourceUnpackednessKey = mkPreludeMiscIdUnique 362 +sourceNoUnpackKey = mkPreludeMiscIdUnique 363 +sourceUnpackKey = mkPreludeMiscIdUnique 364 + +-- data SourceStrictness = ... +noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique +noSourceStrictnessKey = mkPreludeMiscIdUnique 365 +sourceLazyKey = mkPreludeMiscIdUnique 366 +sourceStrictKey = mkPreludeMiscIdUnique 367 + +-- data Con = ... +normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey, + recGadtCIdKey :: Unique +normalCIdKey = mkPreludeMiscIdUnique 368 +recCIdKey = mkPreludeMiscIdUnique 369 +infixCIdKey = mkPreludeMiscIdUnique 370 +forallCIdKey = mkPreludeMiscIdUnique 371 +gadtCIdKey = mkPreludeMiscIdUnique 372 +recGadtCIdKey = mkPreludeMiscIdUnique 373 + +-- data Bang = ... +bangIdKey :: Unique +bangIdKey = mkPreludeMiscIdUnique 374 + +-- type BangType = ... +bangTKey :: Unique +bangTKey = mkPreludeMiscIdUnique 375 + +-- type VarBangType = ... +varBangTKey :: Unique +varBangTKey = mkPreludeMiscIdUnique 376 + +-- data PatSynDir = ... +unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique +unidirPatSynIdKey = mkPreludeMiscIdUnique 377 +implBidirPatSynIdKey = mkPreludeMiscIdUnique 378 +explBidirPatSynIdKey = mkPreludeMiscIdUnique 379 + +-- data PatSynArgs = ... +prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique +prefixPatSynIdKey = mkPreludeMiscIdUnique 380 +infixPatSynIdKey = mkPreludeMiscIdUnique 381 +recordPatSynIdKey = mkPreludeMiscIdUnique 382 + +-- data Type = ... +forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey, + unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, + appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey, + promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey, + wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique +forallTIdKey = mkPreludeMiscIdUnique 390 +forallVisTIdKey = mkPreludeMiscIdUnique 391 +varTIdKey = mkPreludeMiscIdUnique 392 +conTIdKey = mkPreludeMiscIdUnique 393 +tupleTIdKey = mkPreludeMiscIdUnique 394 +unboxedTupleTIdKey = mkPreludeMiscIdUnique 395 +unboxedSumTIdKey = mkPreludeMiscIdUnique 396 +arrowTIdKey = mkPreludeMiscIdUnique 397 +listTIdKey = mkPreludeMiscIdUnique 398 +appTIdKey = mkPreludeMiscIdUnique 399 +appKindTIdKey = mkPreludeMiscIdUnique 400 +sigTIdKey = mkPreludeMiscIdUnique 401 +equalityTIdKey = mkPreludeMiscIdUnique 402 +litTIdKey = mkPreludeMiscIdUnique 403 +promotedTIdKey = mkPreludeMiscIdUnique 404 +promotedTupleTIdKey = mkPreludeMiscIdUnique 405 +promotedNilTIdKey = mkPreludeMiscIdUnique 406 +promotedConsTIdKey = mkPreludeMiscIdUnique 407 +wildCardTIdKey = mkPreludeMiscIdUnique 408 +implicitParamTIdKey = mkPreludeMiscIdUnique 409 +infixTIdKey = mkPreludeMiscIdUnique 410 + +-- data TyLit = ... +numTyLitIdKey, strTyLitIdKey, charTyLitIdKey :: Unique +numTyLitIdKey = mkPreludeMiscIdUnique 411 +strTyLitIdKey = mkPreludeMiscIdUnique 412 +charTyLitIdKey = mkPreludeMiscIdUnique 413 + +-- data TyVarBndr = ... +plainTVIdKey, kindedTVIdKey :: Unique +plainTVIdKey = mkPreludeMiscIdUnique 414 +kindedTVIdKey = mkPreludeMiscIdUnique 415 + +plainInvisTVIdKey, kindedInvisTVIdKey :: Unique +plainInvisTVIdKey = mkPreludeMiscIdUnique 482 +kindedInvisTVIdKey = mkPreludeMiscIdUnique 483 + +plainBndrTVIdKey, kindedBndrTVIdKey :: Unique +plainBndrTVIdKey = mkPreludeMiscIdUnique 484 +kindedBndrTVIdKey = mkPreludeMiscIdUnique 485 + +-- data Role = ... +nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique +nominalRIdKey = mkPreludeMiscIdUnique 416 +representationalRIdKey = mkPreludeMiscIdUnique 417 +phantomRIdKey = mkPreludeMiscIdUnique 418 +inferRIdKey = mkPreludeMiscIdUnique 419 + +-- data Kind = ... +starKIdKey, constraintKIdKey :: Unique +starKIdKey = mkPreludeMiscIdUnique 425 +constraintKIdKey = mkPreludeMiscIdUnique 426 + +-- data FamilyResultSig = ... +noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique +noSigIdKey = mkPreludeMiscIdUnique 427 +kindSigIdKey = mkPreludeMiscIdUnique 428 +tyVarSigIdKey = mkPreludeMiscIdUnique 429 + +-- data InjectivityAnn = ... +injectivityAnnIdKey :: Unique +injectivityAnnIdKey = mkPreludeMiscIdUnique 430 + +-- data Callconv = ... +cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, + javaScriptCallIdKey :: Unique +cCallIdKey = mkPreludeMiscIdUnique 431 +stdCallIdKey = mkPreludeMiscIdUnique 432 +cApiCallIdKey = mkPreludeMiscIdUnique 433 +primCallIdKey = mkPreludeMiscIdUnique 434 +javaScriptCallIdKey = mkPreludeMiscIdUnique 435 + +-- data Safety = ... +unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique +unsafeIdKey = mkPreludeMiscIdUnique 440 +safeIdKey = mkPreludeMiscIdUnique 441 +interruptibleIdKey = mkPreludeMiscIdUnique 442 + +-- data FunDep = ... +funDepIdKey :: Unique +funDepIdKey = mkPreludeMiscIdUnique 445 + +-- mulArrow +mulArrowTIdKey :: Unique +mulArrowTIdKey = mkPreludeMiscIdUnique 446 + +-- data TySynEqn = ... +tySynEqnIdKey :: Unique +tySynEqnIdKey = mkPreludeMiscIdUnique 460 + +-- quasiquoting +quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique +quoteExpKey = mkPreludeMiscIdUnique 470 +quotePatKey = mkPreludeMiscIdUnique 471 +quoteDecKey = mkPreludeMiscIdUnique 472 +quoteTypeKey = mkPreludeMiscIdUnique 473 + +-- data RuleBndr = ... +ruleVarIdKey, typedRuleVarIdKey :: Unique +ruleVarIdKey = mkPreludeMiscIdUnique 480 +typedRuleVarIdKey = mkPreludeMiscIdUnique 481 + +-- data AnnTarget = ... +valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique +valueAnnotationIdKey = mkPreludeMiscIdUnique 490 +typeAnnotationIdKey = mkPreludeMiscIdUnique 491 +moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 + +-- type DerivPred = ... +derivClauseIdKey :: Unique +derivClauseIdKey = mkPreludeMiscIdUnique 493 + +-- data DerivStrategy = ... +stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey, + viaStrategyIdKey :: Unique +stockStrategyIdKey = mkPreludeDataConUnique 494 +anyclassStrategyIdKey = mkPreludeDataConUnique 495 +newtypeStrategyIdKey = mkPreludeDataConUnique 496 +viaStrategyIdKey = mkPreludeDataConUnique 497 + +-- data Specificity = ... +specifiedSpecKey, inferredSpecKey :: Unique +specifiedSpecKey = mkPreludeMiscIdUnique 498 +inferredSpecKey = mkPreludeMiscIdUnique 499 + +-- data BndrVis = ... +bndrReqKey, bndrInvisKey :: Unique +bndrReqKey = mkPreludeMiscIdUnique 800 -- TODO (int-index): make up some room in the 5** numberspace? +bndrInvisKey = mkPreludeMiscIdUnique 801 + +{- +************************************************************************ +* * + RdrNames +* * +************************************************************************ +-} + +lift_RDR, liftTyped_RDR, unsafeCodeCoerce_RDR :: RdrName +lift_RDR = nameRdrName liftName +liftTyped_RDR = nameRdrName liftTypedName +unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName diff --git a/GHC/Builtin/PrimOps.hs b/GHC/Builtin/PrimOps.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/PrimOps.hs @@ -0,0 +1,931 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PrimOp]{Primitive operations (machine-level)} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Builtin.PrimOps ( + PrimOp(..), PrimOpVecCat(..), allThePrimOps, + primOpType, primOpSig, primOpResultType, + primOpTag, maxPrimOpTag, primOpOcc, + primOpWrapperId, + pprPrimOp, + + tagToEnumKey, + + primOpOutOfLine, primOpCodeSize, + primOpOkForSpeculation, primOpOkToDiscard, + primOpIsWorkFree, primOpIsCheap, primOpFixity, primOpDocs, primOpDeprecations, + primOpIsDiv, primOpIsReallyInline, + + PrimOpEffect(..), primOpEffect, + + getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), + + PrimCall(..) + ) where + +import GHC.Prelude + +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique ) +import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS ) + +import GHC.Core.TyCon ( isPrimTyCon, isUnboxedTupleTyCon, PrimRep(..) ) +import GHC.Core.Type + +import GHC.Cmm.Type + +import GHC.Types.Demand +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Types.RepType ( tyConPrimRep ) +import GHC.Types.Basic +import GHC.Types.Fixity ( Fixity(..), FixityDirection(..) ) +import GHC.Types.SrcLoc ( wiredInSrcSpan ) +import GHC.Types.ForeignCall ( CLabelString ) +import GHC.Types.Unique ( Unique ) + +import GHC.Unit.Types ( Unit ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.FastString + +{- +************************************************************************ +* * +\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)} +* * +************************************************************************ + +These are in \tr{state-interface.verb} order. +-} + +-- supplies: +-- data PrimOp = ... +#include "primop-data-decl.hs-incl" + +-- supplies +-- primOpTag :: PrimOp -> Int +#include "primop-tag.hs-incl" +primOpTag _ = error "primOpTag: unknown primop" + + +instance Eq PrimOp where + op1 == op2 = primOpTag op1 == primOpTag op2 + +instance Ord PrimOp where + op1 < op2 = primOpTag op1 < primOpTag op2 + op1 <= op2 = primOpTag op1 <= primOpTag op2 + op1 >= op2 = primOpTag op1 >= primOpTag op2 + op1 > op2 = primOpTag op1 > primOpTag op2 + op1 `compare` op2 | op1 < op2 = LT + | op1 == op2 = EQ + | otherwise = GT + +instance Outputable PrimOp where + ppr op = pprPrimOp op + +data PrimOpVecCat = IntVec + | WordVec + | FloatVec + +-- An @Enum@-derived list would be better; meanwhile... (ToDo) + +allThePrimOps :: [PrimOp] +allThePrimOps = +#include "primop-list.hs-incl" + +tagToEnumKey :: Unique +tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp) + +{- +************************************************************************ +* * +\subsection[PrimOp-info]{The essential info about each @PrimOp@} +* * +************************************************************************ +-} + +data PrimOpInfo + = Compare OccName -- string :: T -> T -> Int# + Type + | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T + [TyVarBinder] + [Type] + Type + +mkCompare :: FastString -> Type -> PrimOpInfo +mkCompare str ty = Compare (mkVarOccFS str) ty + +mkGenPrimOp :: FastString -> [TyVarBinder] -> [Type] -> Type -> PrimOpInfo +mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty + +{- +************************************************************************ +* * +\subsubsection{Strictness} +* * +************************************************************************ + +Not all primops are strict! +-} + +primOpStrictness :: PrimOp -> Arity -> DmdSig + -- See Demand.DmdSig for discussion of what the results + -- The arity should be the arity of the primop; that's why + -- this function isn't exported. +#include "primop-strictness.hs-incl" + +{- +************************************************************************ +* * +\subsubsection{Fixity} +* * +************************************************************************ +-} + +primOpFixity :: PrimOp -> Maybe Fixity +#include "primop-fixity.hs-incl" + +{- +************************************************************************ +* * +\subsubsection{Docs} +* * +************************************************************************ + +See Note [GHC.Prim Docs] in GHC.Builtin.Utils +-} + +primOpDocs :: [(FastString, String)] +#include "primop-docs.hs-incl" + +primOpDeprecations :: [(OccName, FastString)] +#include "primop-deprecations.hs-incl" + +{- +************************************************************************ +* * +\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops} +* * +************************************************************************ + +@primOpInfo@ gives all essential information (from which everything +else, notably a type, can be constructed) for each @PrimOp@. +-} + +primOpInfo :: PrimOp -> PrimOpInfo +#include "primop-primop-info.hs-incl" +primOpInfo _ = error "primOpInfo: unknown primop" + +{- +Here are a load of comments from the old primOp info: + +A @Word#@ is an unsigned @Int#@. + +@decodeFloat#@ is given w/ Integer-stuff (it's similar). + +@decodeDouble#@ is given w/ Integer-stuff (it's similar). + +Decoding of floating-point numbers is sorta Integer-related. Encoding +is done with plain ccalls now (see PrelNumExtra.hs). + +A @Weak@ Pointer is created by the @mkWeak#@ primitive: + + mkWeak# :: k -> v -> f -> State# RealWorld + -> (# State# RealWorld, Weak# v #) + +In practice, you'll use the higher-level + + data Weak v = Weak# v + mkWeak :: k -> v -> IO () -> IO (Weak v) + +The following operation dereferences a weak pointer. The weak pointer +may have been finalized, so the operation returns a result code which +must be inspected before looking at the dereferenced value. + + deRefWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, v, Int# #) + +Only look at v if the Int# returned is /= 0 !! + +The higher-level op is + + deRefWeak :: Weak v -> IO (Maybe v) + +Weak pointers can be finalized early by using the finalize# operation: + + finalizeWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, Int#, IO () #) + +The Int# returned is either + + 0 if the weak pointer has already been finalized, or it has no + finalizer (the third component is then invalid). + + 1 if the weak pointer is still alive, with the finalizer returned + as the third component. + +A {\em stable name/pointer} is an index into a table of stable name +entries. Since the garbage collector is told about stable pointers, +it is safe to pass a stable pointer to external systems such as C +routines. + +\begin{verbatim} +makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) +freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld +deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) +eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int# +\end{verbatim} + +It may seem a bit surprising that @makeStablePtr#@ is a @IO@ +operation since it doesn't (directly) involve IO operations. The +reason is that if some optimisation pass decided to duplicate calls to +@makeStablePtr#@ and we only pass one of the stable pointers over, a +massive space leak can result. Putting it into the IO monad +prevents this. (Another reason for putting them in a monad is to +ensure correct sequencing wrt the side-effecting @freeStablePtr@ +operation.) + +An important property of stable pointers is that if you call +makeStablePtr# twice on the same object you get the same stable +pointer back. + +Note that we can implement @freeStablePtr#@ using @_ccall_@ (and, +besides, it's not likely to be used from Haskell) so it's not a +primop. + +Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR] + +Stable Names +~~~~~~~~~~~~ + +A stable name is like a stable pointer, but with three important differences: + + (a) You can't deRef one to get back to the original object. + (b) You can convert one to an Int. + (c) You don't need to 'freeStableName' + +The existence of a stable name doesn't guarantee to keep the object it +points to alive (unlike a stable pointer), hence (a). + +Invariants: + + (a) makeStableName always returns the same value for a given + object (same as stable pointers). + + (b) if two stable names are equal, it implies that the objects + from which they were created were the same. + + (c) stableNameToInt always returns the same Int for a given + stable name. + + +These primops are pretty weird. + + tagToEnum# :: Int -> a (result type must be an enumerated type) + +The constraints aren't currently checked by the front end, but the +code generator will fall over if they aren't satisfied. + +************************************************************************ +* * + Which PrimOps are out-of-line +* * +************************************************************************ + +Some PrimOps need to be called out-of-line because they either need to +perform a heap check or they block. +-} + +primOpOutOfLine :: PrimOp -> Bool +#include "primop-out-of-line.hs-incl" + +{- +************************************************************************ +* * + Failure and side effects +* * +************************************************************************ + + +Note [Exceptions: asynchronous, synchronous, and unchecked] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are three very different sorts of things in GHC-Haskell that are +sometimes called exceptions: + +* Haskell exceptions: + + These are ordinary exceptions that users can raise with the likes + of 'throw' and handle with the likes of 'catch'. They come in two + very different flavors: + + * Asynchronous exceptions: + * These can arise at nearly any time, and may have nothing to do + with the code being executed. + * The compiler itself mostly doesn't need to care about them. + * Examples: a signal from another process, running out of heap or stack + * Even pure code can receive asynchronous exceptions; in this + case, executing the same code again may lead to different + results, because the exception may not happen next time. + * See rts/RaiseAsync.c for the gory details of how they work. + + * Synchronous exceptions: + * These are produced by the code being executed, most commonly via + a call to the `raise#` or `raiseIO#` primops. + * At run-time, if a piece of pure code raises a synchronous + exception, it will always raise the same synchronous exception + if it is run again (and not interrupted by an asynchronous + exception). + * In particular, if an updatable thunk does some work and then + raises a synchronous exception, it is safe to overwrite it with + a thunk that /immediately/ raises the same exception. + * Although we are careful not to discard synchronous exceptions, we + are very liberal about re-ordering them with respect to most other + operations. See the paper "A semantics for imprecise exceptions" + as well as Note [Precise exceptions and strictness analysis] in + GHC.Types.Demand. + +* Unchecked exceptions: + + * These are nasty failures like seg-faults or primitive Int# division + by zero. They differ from Haskell exceptions in that they are + un-recoverable and typically bring execution to an immediate halt. + * We generally treat unchecked exceptions as undefined behavior, on + the assumption that the programmer never intends to crash the + program in this way. Thus we have no qualms about replacing a + division-by-zero with a recoverable Haskell exception or + discarding an indexArray# operation whose result is unused. + + +Note [Classifying primop effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each primop has an associated 'PrimOpEffect', based on what that +primop can or cannot do at runtime. This classification is + +* Recorded in the 'effect' field in primops.txt.pp, and +* Exposed to the compiler via the 'primOpEffect' function in this module. + +See Note [Transformations affected by primop effects] for how we make +use of this categorisation. + +The meanings of the four constructors of 'PrimOpEffect' are as +follows, in decreasing order of permissiveness: + +* ReadWriteEffect + A primop is marked ReadWriteEffect if it can + - read or write to the world (I/O), or + - read or write to a mutable data structure (e.g. readMutVar#). + + Every such primop uses State# tokens for sequencing, with a type like: + Inputs -> State# s -> (# State# s, Outputs #) + The state token threading expresses ordering, but duplicating even + a read-only effect would defeat this. (See "duplication" under + Note [Transformations affected by primop effects] for details.) + + Note that operations like `indexArray#` that read *immutable* + data structures do not need such special sequencing-related care, + and are therefore not marked ReadWriteEffect. + +* ThrowsException + A primop is marked ThrowsException if + - it is not marked ReadWriteEffect, and + - it may diverge or throw a synchronous Haskell exception + even when used in a "correct" and well-specified way. + + See also Note [Exceptions: asynchronous, synchronous, and unchecked]. + Examples include raise#, raiseIO#, dataToTagLarge#, and seq#. + + Note that whether an exception is considered precise or imprecise + does not matter for the purposes of the PrimOpEffect flag. + +* CanFail + A primop is marked CanFail if + - it is not marked ReadWriteEffect or ThrowsException, and + - it can trigger a (potentially-unchecked) exception when used incorrectly. + + See Note [Exceptions: asynchronous, synchronous, and unchecked]. + Examples include quotWord# and indexIntArray#, which can fail with + division-by-zero and a segfault respectively. + + A correct use of a CanFail primop is usually surrounded by a test + that screens out the bad cases such as a zero divisor or an + out-of-bounds array index. We must take care never to move a + CanFail primop outside the scope of such a test. + +* NoEffect + A primop is marked NoEffect if it does not belong to any of the + other three categories. We can very aggressively shuffle these + operations around without fear of changing a program's meaning. + + Perhaps surprisingly, this aggressive shuffling imposes another + restriction: The tricky NoEffect primop uncheckedShiftLWord32# has + an undefined result when the provided shift amount is not between + 0 and 31. Thus, a call like `uncheckedShiftLWord32# x 95#` is + obviously invalid. But since uncheckedShiftLWord32# is marked + NoEffect, we may float such an invalid call out of a dead branch + and speculatively evaluate it. + + In particular, we cannot safely rewrite such an invalid call to a + runtime error; we must emit code that produces a valid Word32#. + (If we're lucky, Core Lint may complain that the result of such a + rewrite violates the let-can-float invariant (#16742), but the + rewrite is always wrong!) See also Note [Guarding against silly shifts] + in GHC.Core.Opt.ConstantFold. + + Marking uncheckedShiftLWord32# as CanFail instead of NoEffect + would give us the freedom to rewrite such invalid calls to runtime + errors, but would get in the way of optimization: When speculatively + executing a bit-shift prevents the allocation of a thunk, that's a + big win. + + +Note [Transformations affected by primop effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The PrimOpEffect properties have the following effect on program +transformations. The summary table is followed by details. See also +Note [Classifying primop effects] for exactly what each column means. + + NoEffect CanFail ThrowsException ReadWriteEffect +Discard YES YES NO NO +Defer (float in) YES YES SAFE SAFE +Speculate (float out) YES NO NO NO +Duplicate YES YES YES NO + +(SAFE means we could perform the transformation but do not.) + +* Discarding: case (a `op` b) of _ -> rhs ===> rhs + You should not discard a ReadWriteEffect primop; e.g. + case (writeIntArray# a i v s of (# _, _ #) -> True + One could argue in favor of discarding this, since the returned + State# token is not used. But in practice unsafePerformIO can + easily produce similar code, and programmers sometimes write this + kind of stuff by hand (#9390). So we (conservatively) never discard + a ReadWriteEffect primop. + + Digression: We could try to track read-only effects separately + from write effects to allow the former to be discarded. But in + fact we want a more general rewrite for read-only operations: + case readOp# state# of (# newState#, _unused_result #) -> body + ==> case state# of newState# -> body + Such a rewrite is not yet implemented, but would have to be done + in a different place anyway. + + Discarding a ThrowsException primop would also discard any exception + it might have thrown. For `raise#` or `raiseIO#` this would defeat + the whole point of the primop, while for `dataToTagLarge#` or `seq#` + this would make programs unexpectly lazier. + + However, it's fine to discard a CanFail primop. For example + case (indexIntArray# a i) of _ -> True + We can discard indexIntArray# here; this came up in #5658. Notice + that CanFail primops like indexIntArray# can only trigger an + exception when used incorrectly, i.e. a call that might not succeed + is undefined behavior anyway. + +* Deferring (float-in): + See Note [Floating primops] in GHC.Core.Opt.FloatIn. + + In the absence of data dependencies (including state token threading), + we reserve the right to re-order the following things arbitrarily: + * Side effects + * Imprecise exceptions + * Divergent computations (infinite loops) + This lets us safely float almost any primop *inwards*, but not + inside a (multi-shot) lambda. (See "Duplication" below.) + + However, the main reason to float-in a primop application would be + to discard it (by floating it into some but not all branches of a + case), so we actually only float-in NoEffect and CanFail operations. + See also Note [Floating primops] in GHC.Core.Opt.FloatIn. + + (This automatically side-steps the question of precise exceptions, which + mustn't be re-ordered arbitrarily but need at least ThrowsException.) + +* Speculation (strict float-out): + You must not float a CanFail primop *outwards* lest it escape the + dynamic scope of a run-time validity test. Example: + case d ># 0# of + True -> case x /# d of r -> r +# 1 + False -> 0 + Here we must not float the case outwards to give + case x/# d of r -> + case d ># 0# of + True -> r +# 1 + False -> 0 + Otherwise, if this block is reached when d is zero, it will crash. + Exactly the same reasoning applies to ThrowsException primops. + + Nor can you float out a ReadWriteEffect primop. For example: + if blah then case writeMutVar# v True s0 of (# s1 #) -> s1 + else s0 + Notice that s0 is mentioned in both branches of the 'if', but + only one of these two will actually be consumed. But if we + float out to + case writeMutVar# v True s0 of (# s1 #) -> + if blah then s1 else s0 + the writeMutVar will be performed in both branches, which is + utterly wrong. + + What about a read-only operation that cannot fail, like + readMutVar#? In principle we could safely float these out. But + there are not very many such operations and it's not clear if + there are real-world programs that would benefit from this. + +* Duplication: + You cannot duplicate a ReadWriteEffect primop. You might wonder + how this can occur given the state token threading, but just look + at Control.Monad.ST.Lazy.Imp.strictToLazy! We get something like this + p = case readMutVar# s v of + (# s', r #) -> (State# s', r) + s' = case p of (s', r) -> s' + r = case p of (s', r) -> r + + (All these bindings are boxed.) If we inline p at its two call + sites, we get a catastrophe: because the read is performed once when + s' is demanded, and once when 'r' is demanded, which may be much + later. Utterly wrong. #3207 is real example of this happening. + Floating p into a multi-shot lambda would be wrong for the same reason. + + However, it's fine to duplicate a CanFail or ThrowsException primop. + + + +Note [Implementation: how PrimOpEffect affects transformations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we ensure that floating/duplication/discarding are done right +in the simplifier? + +Several predicates on primops test this flag: + primOpOkToDiscard <=> effect < ThrowsException + primOpOkForSpeculation <=> effect == NoEffect && not (out_of_line) + primOpIsCheap <=> cheap -- ...defaults to primOpOkForSpeculation + [[But note that the raise# family and seq# are also considered cheap in + GHC.Core.Utils.exprIsCheap by way of being work-free]] + + * The discarding mentioned above happens in + GHC.Core.Opt.Simplify.Iteration, specifically in rebuildCase, + where it is guarded by exprOkToDiscard, which in turn checks + primOpOkToDiscard. + + * The "no-float-out" thing is achieved by ensuring that we never + let-bind a saturated primop application unless it has NoEffect. + The RHS of a let-binding (which can float in and out freely) + satisfies exprOkForSpeculation; this is the let-can-float + invariant. And exprOkForSpeculation is false of a saturated + primop application unless it has NoEffect. + + * So primops that aren't NoEffect will appear only as the + scrutinees of cases, and that's why the FloatIn pass is capable + of floating case bindings inwards. + + * Duplication via inlining and float-in of (lifted) let-binders is + controlled via primOpIsWorkFree and primOpIsCheap, by making + ReadWriteEffect things (among others) not-cheap! (The test + PrimOpEffect_Sanity will complain if any ReadWriteEffect primop + is considered either work-free or cheap.) Additionally, a + case binding is only floated inwards if its scrutinee is ok-to-discard. +-} + +primOpEffect :: PrimOp -> PrimOpEffect +#include "primop-effects.hs-incl" + +data PrimOpEffect + -- See Note [Classifying primop effects] + = NoEffect + | CanFail + | ThrowsException + | ReadWriteEffect + deriving (Eq, Ord) + +primOpOkForSpeculation :: PrimOp -> Bool + -- See Note [Classifying primop effects] + -- See comments with GHC.Core.Utils.exprOkForSpeculation + -- primOpOkForSpeculation => primOpOkToDiscard +primOpOkForSpeculation op + = primOpEffect op == NoEffect && not (primOpOutOfLine op) + -- I think the "out of line" test is because out of line things can + -- be expensive (eg sine, cosine), and so we may not want to speculate them + +primOpOkToDiscard :: PrimOp -> Bool +primOpOkToDiscard op + = primOpEffect op < ThrowsException + +primOpIsWorkFree :: PrimOp -> Bool +#include "primop-is-work-free.hs-incl" + +primOpIsCheap :: PrimOp -> Bool +-- See Note [Classifying primop effects] +#include "primop-is-cheap.hs-incl" +-- In March 2001, we changed this to +-- primOpIsCheap op = False +-- thereby making *no* primops seem cheap. But this killed eta +-- expansion on case (x ==# y) of True -> \s -> ... +-- which is bad. In particular a loop like +-- doLoop n = loop 0 +-- where +-- loop i | i == n = return () +-- | otherwise = bar i >> loop (i+1) +-- allocated a closure every time round because it doesn't eta expand. +-- +-- The problem that originally gave rise to the change was +-- let x = a +# b *# c in x +# x +-- were we don't want to inline x. But primopIsCheap doesn't control +-- that (it's primOpIsWorkFree that does) so the problem doesn't occur +-- even if primOpIsCheap sometimes says 'True'. + + +-- | True of dyadic operators that can fail only if the second arg is zero! +-- +-- This function probably belongs in an automagically generated file.. but it's +-- such a special case I thought I'd leave it here for now. +primOpIsDiv :: PrimOp -> Bool +primOpIsDiv op = case op of + + IntQuotOp -> True + Int8QuotOp -> True + Int16QuotOp -> True + Int32QuotOp -> True + Int64QuotOp -> True + + IntRemOp -> True + Int8RemOp -> True + Int16RemOp -> True + Int32RemOp -> True + Int64RemOp -> True + + IntQuotRemOp -> True + Int8QuotRemOp -> True + Int16QuotRemOp -> True + Int32QuotRemOp -> True + -- Int64QuotRemOp doesn't exist (yet) + + WordQuotOp -> True + Word8QuotOp -> True + Word16QuotOp -> True + Word32QuotOp -> True + Word64QuotOp -> True + + WordRemOp -> True + Word8RemOp -> True + Word16RemOp -> True + Word32RemOp -> True + Word64RemOp -> True + + WordQuotRemOp -> True + Word8QuotRemOp -> True + Word16QuotRemOp -> True + Word32QuotRemOp -> True + -- Word64QuotRemOp doesn't exist (yet) + + WordQuotRem2Op -> True + + FloatDivOp -> True + DoubleDivOp -> True + _ -> False + + + +{- +************************************************************************ +* * + PrimOp code size +* * +************************************************************************ + +primOpCodeSize +~~~~~~~~~~~~~~ +Gives an indication of the code size of a primop, for the purposes of +calculating unfolding sizes; see GHC.Core.Unfold.sizeExpr. +-} + +primOpCodeSize :: PrimOp -> Int +#include "primop-code-size.hs-incl" + +primOpCodeSizeDefault :: Int +primOpCodeSizeDefault = 1 + -- GHC.Core.Unfold.primOpSize already takes into account primOpOutOfLine + -- and adds some further costs for the args in that case. + +primOpCodeSizeForeignCall :: Int +primOpCodeSizeForeignCall = 4 + +{- +************************************************************************ +* * + PrimOp types +* * +************************************************************************ +-} + +primOpType :: PrimOp -> Type -- you may want to use primOpSig instead +primOpType op + = case primOpInfo op of + Compare _occ ty -> compare_fun_ty ty + + GenPrimOp _occ tyvars arg_tys res_ty -> + mkForAllTys tyvars (mkVisFunTysMany arg_tys res_ty) + +primOpResultType :: PrimOp -> Type +primOpResultType op + = case primOpInfo op of + Compare _occ _ty -> intPrimTy + GenPrimOp _occ _tyvars _arg_tys res_ty -> res_ty + +primOpOcc :: PrimOp -> OccName +primOpOcc op = case primOpInfo op of + Compare occ _ -> occ + GenPrimOp occ _ _ _ -> occ + +{- Note [Primop wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +To support (limited) use of primops in GHCi genprimopcode generates the +GHC.PrimopWrappers module. This module contains a "primop wrapper" +binding for each primop. These are standard Haskell functions mirroring the +types of the primops they wrap. For instance, in the case of plusInt# we would +have: + + module GHC.PrimopWrappers where + import GHC.Prim as P + + plusInt# :: Int# -> Int# -> Int# + plusInt# a b = P.plusInt# a b + +The Id for the wrapper of a primop can be found using +'GHC.Builtin.PrimOps.primOpWrapperId'. However, GHCi does not use this mechanism +to link primops; it rather does a rather hacky symbol lookup (see +GHC.ByteCode.Linker.primopToCLabel). TODO: Perhaps this should be changed? + +Note that these wrappers aren't *quite* as expressive as their unwrapped +brethren, in that they may exhibit less representation polymorphism. +For instance, consider the case of mkWeakNoFinalizer#, which has type: + + mkWeakNoFinalizer# :: forall (r :: RuntimeRep) (k :: TYPE r) (v :: Type). + k -> v + -> State# RealWorld + -> (# State# RealWorld, Weak# v #) + +Naively we could generate a wrapper of the form, + + + mkWeakNoFinalizer# k v s = GHC.Prim.mkWeakNoFinalizer# k v s + +However, this would require that 'k' bind the representation-polymorphic key, +which is disallowed by our representation polymorphism validity checks +(see Note [Representation polymorphism invariants] in GHC.Core). +Consequently, we give the wrapper the simpler, less polymorphic type + + mkWeakNoFinalizer# :: forall (k :: Type) (v :: Type). + k -> v + -> State# RealWorld + -> (# State# RealWorld, Weak# v #) + +This simplification tends to be good enough for GHCi uses given that there are +few representation-polymorphic primops, and we do little simplification +on interpreted code anyways. + +TODO: This behavior is actually wrong; a program becomes ill-typed upon +replacing a real primop occurrence with one of its wrapper due to the fact that +the former has an additional type binder. Hmmm.... + +Note [Eta expanding primops] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +STG requires that primop applications be saturated. This makes code generation +significantly simpler since otherwise we would need to define a calling +convention for curried applications that can accommodate representation +polymorphism. + +To ensure saturation, CorePrep eta expands all primop applications as +described in Note [Eta expansion of hasNoBinding things in CorePrep] in +GHC.Core.Prep. + +Historical Note: + +For a short period around GHC 8.8 we rewrote unsaturated primop applications to +rather use the primop's wrapper (see Note [Primop wrappers] in +GHC.Builtin.PrimOps) instead of eta expansion. This was because at the time +CoreTidy would try to predict the CAFfyness of bindings that would be produced +by CorePrep for inclusion in interface files. Eta expanding during CorePrep +proved to be very difficult to predict, leading to nasty inconsistencies in +CAFfyness determinations (see #16846). + +Thankfully, we now no longer try to predict CAFfyness but rather compute it on +GHC STG (see Note [SRTs] in GHC.Cmm.Info.Build) and inject it into the interface +file after code generation (see TODO: Refer to whatever falls out of #18096). +This is much simpler and avoids the potential for inconsistency, allowing us to +return to the somewhat simpler eta expansion approach for unsaturated primops. + +See #18079. +-} + +-- | Returns the 'Id' of the wrapper associated with the given 'PrimOp'. +-- See Note [Primop wrappers]. +primOpWrapperId :: PrimOp -> Id +primOpWrapperId op = mkVanillaGlobalWithInfo name ty info + where + info = setCafInfo vanillaIdInfo NoCafRefs + name = mkExternalName uniq gHC_PRIMOPWRAPPERS (primOpOcc op) wiredInSrcSpan + uniq = mkPrimOpWrapperUnique (primOpTag op) + ty = primOpType op + +isComparisonPrimOp :: PrimOp -> Bool +isComparisonPrimOp op = case primOpInfo op of + Compare {} -> True + GenPrimOp {} -> False + +-- primOpSig is like primOpType but gives the result split apart: +-- (type variables, argument types, result type) +-- It also gives arity, strictness info + +primOpSig :: PrimOp -> ([TyVarBinder], [Type], Type, Arity, DmdSig) +primOpSig op + = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) + where + arity = length arg_tys + (tyvars, arg_tys, res_ty) + = case (primOpInfo op) of + Compare _occ ty -> ([], [ty,ty], intPrimTy) + GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) + +data PrimOpResultInfo + = ReturnsVoid + | ReturnsPrim PrimRep + | ReturnsTuple + +-- Some PrimOps need not return a manifest primitive or algebraic value +-- (i.e. they might return a polymorphic value). These PrimOps *must* +-- be out of line, or the code generator won't work. + +getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo +getPrimOpResultInfo op + = case (primOpInfo op) of + Compare _ _ -> ReturnsPrim IntRep + GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of + [] -> ReturnsVoid + [rep] -> ReturnsPrim rep + _ -> pprPanic "getPrimOpResultInfo" (ppr op) + | isUnboxedTupleTyCon tc -> ReturnsTuple + | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op) + where + tc = tyConAppTyCon ty + -- All primops return a tycon-app result + -- The tycon can be an unboxed tuple or sum, though, + -- which gives rise to a ReturnAlg + +{- +We do not currently make use of whether primops are commutable. + +We used to try to move constants to the right hand side for strength +reduction. +-} + +{- +commutableOp :: PrimOp -> Bool +#include "primop-commutable.hs-incl" +-} + +-- Utils: + +compare_fun_ty :: Type -> Type +compare_fun_ty ty = mkVisFunTysMany [ty, ty] intPrimTy + +-- Output stuff: + +pprPrimOp :: IsLine doc => PrimOp -> doc +pprPrimOp other_op = pprOccName (primOpOcc other_op) +{-# SPECIALIZE pprPrimOp :: PrimOp -> SDoc #-} +{-# SPECIALIZE pprPrimOp :: PrimOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +{- +************************************************************************ +* * +\subsubsection[PrimCall]{User-imported primitive calls} +* * +************************************************************************ +-} + +data PrimCall = PrimCall CLabelString Unit + +instance Outputable PrimCall where + ppr (PrimCall lbl pkgId) + = text "__primcall" <+> ppr pkgId <+> ppr lbl + +-- | Indicate if a primop is really inline: that is, it isn't out-of-line and it +-- isn't DataToTagOp which are two primops that evaluate their argument +-- hence induce thread/stack/heap changes. +primOpIsReallyInline :: PrimOp -> Bool +primOpIsReallyInline = \case + DataToTagSmallOp -> False + DataToTagLargeOp -> False + p -> not (primOpOutOfLine p) diff --git a/GHC/Builtin/PrimOps.hs-boot b/GHC/Builtin/PrimOps.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Builtin/PrimOps.hs-boot @@ -0,0 +1,6 @@ +module GHC.Builtin.PrimOps where + +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + +data PrimOp diff --git a/GHC/Builtin/PrimOps/Casts.hs b/GHC/Builtin/PrimOps/Casts.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/PrimOps/Casts.hs @@ -0,0 +1,211 @@ +{- +This module contains helpers to cast variables +between different Int/WordReps in StgLand. + +-} + +module GHC.Builtin.PrimOps.Casts + ( getCasts ) +where + +import GHC.Prelude + +import GHC.Core.TyCon +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.RepType +import GHC.Core.Type +import GHC.Builtin.Types.Prim + +import GHC.Builtin.PrimOps +import GHC.Plugins (HasDebugCallStack) + +{- Note [PrimRep based casting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module contains a number of utility functions useful when +converting between variables of differing PrimReps. + +The general pattern is: +* We have two primReps `from_rep` and `to_rep`. +* We want a list of PrimOps we can apply to a variable of rep `from_rep`. +Applying the list of primOps in order takes us to `to_rep` from `from_rep` giving +us a variable of the returned type at each step. + +E.g. we call `getCasts from_rep to_rep` and get back [(op1#,ty1),(op2#,ty2)]. +We can use this result to construct a function of type +`StgExpr -> StgExpr` by construction an expression + + case op1# of (x' :: ty1) -> case op2# x' of x' -> + +Ideally backends will compile the sequence of PrimOps to a no-op. E.g. by reusing +the same register but just relabeling it as another width. +However this is might not always be possible or the required optimizations +simply not implemented in the backend. This means currently many of these casts +will be cheap but not all of them will be completely zero-cost. + +-} + +-- | `getCasts from_rep to_rep` gives us a list of primops which when applied in order convert from_rep to to_rep. +-- See Note [PrimRep based casting] +getCasts :: PrimRep -> PrimRep -> [(PrimOp,Type)] +getCasts from_rep to_rep + -- No-op + | -- pprTrace "getCasts" (ppr (from_rep,to_rep)) $ + to_rep == from_rep + = [] + + -- Float <-> Double + | to_rep == FloatRep = + assertPpr (from_rep == DoubleRep) (ppr from_rep <+> ppr to_rep) $ + [(DoubleToFloatOp,floatPrimTy)] + | to_rep == DoubleRep = + assertPpr (from_rep == FloatRep) (ppr from_rep <+> ppr to_rep) $ + [(FloatToDoubleOp,doublePrimTy)] + + -- Addr <-> Word/Int + | to_rep == AddrRep = wordOrIntToAddrRep from_rep + | from_rep == AddrRep = addrToWordOrIntRep to_rep + + -- Int* -> Int* + | primRepIsInt from_rep + , primRepIsInt to_rep + = sizedIntToSizedInt from_rep to_rep + + -- Word* -> Word* + | primRepIsWord from_rep + , primRepIsWord to_rep + = sizedWordToSizedWord from_rep to_rep + + -- Word* -> Int* + | primRepIsWord from_rep + , primRepIsInt to_rep + = let (op1,r1) = wordToIntRep from_rep + in (op1,primRepToType r1):sizedIntToSizedInt r1 to_rep + + -- Int* -> Word* + | primRepIsInt from_rep + , primRepIsWord to_rep + = let (op1,r1) = intToWordRep from_rep + in (op1,primRepToType r1):sizedWordToSizedWord r1 to_rep + + | otherwise = pprPanic "getCasts:Unexpect rep combination" + (ppr (from_rep,to_rep)) + +wordOrIntToAddrRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)] +wordOrIntToAddrRep AddrRep = [] -- No-op argument is already AddrRep +wordOrIntToAddrRep IntRep = [(IntToAddrOp, addrPrimTy)] +wordOrIntToAddrRep WordRep = [(WordToIntOp,intPrimTy), (IntToAddrOp,addrPrimTy)] +wordOrIntToAddrRep r + | primRepIsInt r = (intToMachineInt r,intPrimTy):[(IntToAddrOp,addrPrimTy)] + | primRepIsWord r = + let (op1,r1) = wordToIntRep r + in (op1, primRepToType r1):[(intToMachineInt r1,intPrimTy), (IntToAddrOp,addrPrimTy)] + | otherwise = pprPanic "Rep not word or int rep" (ppr r) + +addrToWordOrIntRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)] +-- Machine sizes +addrToWordOrIntRep IntRep = [(AddrToIntOp, intPrimTy)] +addrToWordOrIntRep WordRep = [(AddrToIntOp,intPrimTy), (IntToWordOp,wordPrimTy)] +-- Explicitly sized reps +addrToWordOrIntRep r + | primRepIsWord r = (AddrToIntOp,intPrimTy) : (IntToWordOp,wordPrimTy) : sizedWordToSizedWord WordRep r + | primRepIsInt r = (AddrToIntOp,intPrimTy) : sizedIntToSizedInt IntRep r + | otherwise = pprPanic "Target rep not word or int rep" (ppr r) + + +-- WordX# -> IntX# (same size), argument is source rep +wordToIntRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep) +wordToIntRep rep + = case rep of + (WordRep) -> (WordToIntOp, IntRep) + (Word8Rep) -> (Word8ToInt8Op, Int8Rep) + (Word16Rep) -> (Word16ToInt16Op, Int16Rep) + (Word32Rep) -> (Word32ToInt32Op, Int32Rep) + (Word64Rep) -> (Word64ToInt64Op, Int64Rep) + _ -> pprPanic "Rep not a wordRep" (ppr rep) + +-- IntX# -> WordX#, argument is source rep +intToWordRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep) +intToWordRep rep + = case rep of + (IntRep) -> (IntToWordOp, WordRep) + (Int8Rep) -> (Int8ToWord8Op, Word8Rep) + (Int16Rep) -> (Int16ToWord16Op, Word16Rep) + (Int32Rep) -> (Int32ToWord32Op, Word32Rep) + (Int64Rep) -> (Int64ToWord64Op, Word64Rep) + _ -> pprPanic "Rep not a wordRep" (ppr rep) + +-- Casts between any size int to any other size of int +sizedIntToSizedInt :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)] +sizedIntToSizedInt r1 r2 + | r1 == r2 = [] +-- Cast to Int# +sizedIntToSizedInt r IntRep = [(intToMachineInt r,intPrimTy)] +-- Cast from Int# +sizedIntToSizedInt IntRep r = [(intFromMachineInt r,primRepToType r)] +-- Sized to differently sized must go over machine word. +sizedIntToSizedInt r1 r2 = (intToMachineInt r1,intPrimTy) : [(intFromMachineInt r2,primRepToType r2)] + +-- Casts between any size Word to any other size of Word +sizedWordToSizedWord :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)] +sizedWordToSizedWord r1 r2 + | r1 == r2 = [] +-- Cast to Word# +sizedWordToSizedWord r WordRep = [(wordToMachineWord r,wordPrimTy)] +-- Cast from Word# +sizedWordToSizedWord WordRep r = [(wordFromMachineWord r, primRepToType r)] +-- Conversion between different non-machine sizes must go via machine word. +sizedWordToSizedWord r1 r2 = (wordToMachineWord r1,wordPrimTy) : [(wordFromMachineWord r2, primRepToType r2)] + + +-- Prefer the definitions above this line if possible +---------------------- + + +-- Int*# to Int# +{-# INLINE intToMachineInt #-} +intToMachineInt :: HasDebugCallStack => PrimRep -> PrimOp +intToMachineInt r = + assertPpr (primRepIsInt r) (ppr r) $ + case r of + (Int8Rep) -> Int8ToIntOp + (Int16Rep) -> Int16ToIntOp + (Int32Rep) -> Int32ToIntOp + (Int64Rep) -> Int64ToIntOp + _ -> pprPanic "Source rep not int" $ ppr r + +-- Int# to Int*# +{-# INLINE intFromMachineInt #-} +intFromMachineInt :: HasDebugCallStack => PrimRep -> PrimOp +intFromMachineInt r = + assertPpr (primRepIsInt r) (ppr r) $ + case r of + Int8Rep -> IntToInt8Op + Int16Rep -> IntToInt16Op + Int32Rep -> IntToInt32Op + Int64Rep -> IntToInt64Op + _ -> pprPanic "Dest rep not sized int" $ ppr r + +-- Word# to Word*# +{-# INLINE wordFromMachineWord #-} +wordFromMachineWord :: HasDebugCallStack => PrimRep -> PrimOp +wordFromMachineWord r = + assert (primRepIsWord r) $ + case r of + Word8Rep -> WordToWord8Op + Word16Rep -> WordToWord16Op + Word32Rep -> WordToWord32Op + Word64Rep -> WordToWord64Op + _ -> pprPanic "Dest rep not sized word" $ ppr r + +-- Word*# to Word# +{-# INLINE wordToMachineWord #-} +wordToMachineWord :: HasDebugCallStack => PrimRep -> PrimOp +wordToMachineWord r = + assertPpr (primRepIsWord r) (text "Not a word rep:" <> ppr r) $ + case r of + Word8Rep -> Word8ToWordOp + Word16Rep -> Word16ToWordOp + Word32Rep -> Word32ToWordOp + Word64Rep -> Word64ToWordOp + _ -> pprPanic "Dest rep not sized word" $ ppr r diff --git a/GHC/Builtin/PrimOps/Ids.hs b/GHC/Builtin/PrimOps/Ids.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/PrimOps/Ids.hs @@ -0,0 +1,175 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} + +-- | PrimOp's Ids +module GHC.Builtin.PrimOps.Ids + ( primOpId + , allThePrimOpIds + ) +where + +import GHC.Prelude + +-- primop rules are attached to primop ids +import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules) +import GHC.Core.TyCo.Rep ( scaledThing ) +import GHC.Core.Type +import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped ) +import GHC.Core.FVs (mkRuleInfo) + +import GHC.Builtin.PrimOps +import GHC.Builtin.Uniques +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim + +import GHC.Types.Basic +import GHC.Types.Cpr +import GHC.Types.Demand +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.TyThing +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var +import GHC.Types.Var.Set + +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType ( ConcreteTvOrigin(..), ConcreteTyVars, TcType ) + +import GHC.Data.SmallArray + +import Data.Maybe ( mapMaybe, listToMaybe, catMaybes, maybeToList ) + + +-- | Build a PrimOp Id +mkPrimOpId :: PrimOp -> Id +mkPrimOpId prim_op + = id + where + (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op + ty = mkForAllTys tyvars (mkVisFunTysMany arg_tys res_ty) + name = mkWiredInName gHC_PRIM (primOpOcc prim_op) + (mkPrimOpIdUnique (primOpTag prim_op)) + (AnId id) UserSyntax + id = mkGlobalId (PrimOpId prim_op conc_tvs) name ty info + + conc_tvs = computePrimOpConcTyVarsFromType name tyvars arg_tys res_ty + + -- PrimOps don't ever construct a product, but we want to preserve bottoms + cpr + | isDeadEndDiv (snd (splitDmdSig strict_sig)) = botCpr + | otherwise = topCpr + + info = noCafIdInfo + `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) + `setArityInfo` arity + `setDmdSigInfo` strict_sig + `setCprSigInfo` mkCprSig arity cpr + `setInlinePragInfo` neverInlinePragma + -- We give PrimOps a NOINLINE pragma so that we don't + -- get silly warnings from Desugar.dsRule (the inline_shadows_rule + -- test) about a RULE conflicting with a possible inlining + -- cf #7287 + +-- | Analyse the type of a primop to determine which of its outermost forall'd +-- type variables must be instantiated to concrete types when the primop is +-- instantiated. +-- +-- These are the Levity and RuntimeRep kinded type-variables which appear in +-- negative position in the type of the primop. +computePrimOpConcTyVarsFromType :: Name -> [TyVarBinder] -> [Type] -> Type -> ConcreteTyVars +computePrimOpConcTyVarsFromType nm tyvars arg_tys _res_ty = mkNameEnv concs + where + concs = [ (tyVarName kind_tv, ConcreteFRR frr_orig) + | Bndr tv _af <- tyvars + , kind_tv <- tyCoVarsOfTypeWellScoped $ tyVarKind tv + , neg_pos <- maybeToList $ frr_tyvar_maybe kind_tv + , let frr_orig = FixedRuntimeRepOrigin + { frr_type = mkTyVarTy tv + , frr_context = FRRRepPolyId nm RepPolyPrimOp neg_pos + } + ] + + -- As per Note [Levity and representation polymorphic primops] + -- in GHC.Builtin.Primops.txt.pp, we compute the ConcreteTyVars associated + -- to a primop by inspecting the type variable names. + frr_tyvar_maybe tv + | tv `elem` [ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar + , levity1TyVar, levity2TyVar ] + = listToMaybe $ + mapMaybe (\ (i,arg) -> mkArgPos i <$> positiveKindPos_maybe tv arg) + (zip [1..] arg_tys) + | otherwise + = Nothing + -- Compute whether the type variable occurs in the kind of a type variable + -- in positive position in one of the argument types of the primop. + +-- | Does this type variable appear in a kind in a negative position in the +-- type? +-- +-- Returns the first such position if so. +-- +-- NB: assumes the type is of a simple form, e.g. no foralls, no function +-- arrows nested in a TyCon other than a function arrow. +-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting +-- its type, see 'computePrimOpConcTyVarsFromType'. +negativeKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Neg) +negativeKindPos_maybe tv ty + | (args, res) <- splitFunTys ty + = listToMaybe $ catMaybes $ + ( (if null args then Nothing else Result <$> negativeKindPos_maybe tv res) + : map recur (zip [1..] args) + ) + where + recur (pos, scaled_ty) + = mkArgPos pos <$> positiveKindPos_maybe tv (scaledThing scaled_ty) + -- (assumes we don't have any function types nested inside other types) + +-- | Does this type variable appear in a kind in a positive position in the +-- type? +-- +-- Returns the first such position if so. +-- +-- NB: assumes the type is of a simple form, e.g. no foralls, no function +-- arrows nested in a TyCon other than a function arrow. +-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting +-- its type, see 'computePrimOpConcTyVarsFromType'. +positiveKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Pos) +positiveKindPos_maybe tv ty + | (args, res) <- splitFunTys ty + = listToMaybe $ catMaybes $ + ( (if null args then finish res else Result <$> positiveKindPos_maybe tv res) + : map recur (zip [1..] args) + ) + where + recur (pos, scaled_ty) + = mkArgPos pos <$> negativeKindPos_maybe tv (scaledThing scaled_ty) + -- (assumes we don't have any function types nested inside other types) + finish ty + | tv `elemVarSet` tyCoVarsOfType (typeKind ty) + = Just Top + | otherwise + = Nothing + +------------------------------------------------------------- +-- Cache of PrimOp's Ids +------------------------------------------------------------- + +-- | A cache of the PrimOp Ids, indexed by PrimOp tag (0 indexed) +primOpIds :: SmallArray Id +{-# NOINLINE primOpIds #-} +primOpIds = listToArray (maxPrimOpTag+1) primOpTag mkPrimOpId allThePrimOps + +-- | Get primop id. +-- +-- Retrieve it from `primOpIds` cache. +primOpId :: PrimOp -> Id +{-# INLINE primOpId #-} +primOpId op = indexSmallArray primOpIds (primOpTag op) + +-- | All the primop ids, as a list +allThePrimOpIds :: [Id] +{-# INLINE allThePrimOpIds #-} +allThePrimOpIds = map (indexSmallArray primOpIds) [0..maxPrimOpTag] diff --git a/GHC/Builtin/Types.hs b/GHC/Builtin/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Types.hs @@ -0,0 +1,2948 @@ +{- +(c) The GRASP Project, Glasgow University, 1994-1998 + +Wired-in knowledge about {\em non-primitive} types +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | This module is about types that can be defined in Haskell, but which +-- must be wired into the compiler nonetheless. C.f module "GHC.Builtin.Types.Prim" +module GHC.Builtin.Types ( + -- * Helper functions defined here + mkWiredInTyConName, -- This is used in GHC.Builtin.Types.Literals to define the + -- built-in functions for evaluation. + + mkWiredInIdName, -- used in GHC.Types.Id.Make + + -- * All wired in things + wiredInTyCons, isBuiltInOcc, isBuiltInOcc_maybe, + isTupleTyOrigName_maybe, isSumTyOrigName_maybe, + isInfiniteFamilyOrigName_maybe, + + -- * Bool + boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, + trueDataCon, trueDataConId, true_RDR, + falseDataCon, falseDataConId, false_RDR, + promotedFalseDataCon, promotedTrueDataCon, + + -- * Ordering + orderingTyCon, + ordLTDataCon, ordLTDataConId, + ordEQDataCon, ordEQDataConId, + ordGTDataCon, ordGTDataConId, + promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, + + -- * Boxing primitive types + boxingDataCon, BoxingInfo(..), + + -- * Char + charTyCon, charDataCon, charTyCon_RDR, + charTy, stringTy, charTyConName, stringTyCon_RDR, + + -- * Double + doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, + + -- * Float + floatTyCon, floatDataCon, floatTy, floatTyConName, + + -- * Int + intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, + intTy, + + -- * Word + wordTyCon, wordDataCon, wordTyConName, wordTy, + + -- * Word8 + word8TyCon, word8DataCon, word8Ty, + + -- * List + listTyCon, listTyCon_RDR, listTyConName, listTyConKey, + nilDataCon, nilDataConName, nilDataConKey, + consDataCon_RDR, consDataCon, consDataConName, + promotedNilDataCon, promotedConsDataCon, + mkListTy, mkPromotedListTy, extractPromotedList, + + -- * Maybe + maybeTyCon, maybeTyConName, + nothingDataCon, nothingDataConName, promotedNothingDataCon, + justDataCon, justDataConName, promotedJustDataCon, + mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy, + + -- * Tuples + mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr, + tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName, + promotedTupleDataCon, + unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, + soloTyCon, + soloDataConName, + pairTyCon, mkPromotedPairTy, isPromotedPairType, + unboxedUnitTy, + unboxedUnitTyCon, unboxedUnitDataCon, + unboxedSoloTyCon, unboxedSoloTyConName, unboxedSoloDataConName, + unboxedTupleKind, unboxedSumKind, + mkConstraintTupleTy, + + -- ** Constraint tuples + cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName, + cTupleDataCon, cTupleDataConName, cTupleDataConNames, + cTupleSelId, cTupleSelIdName, + + -- * Any + anyTyCon, anyTy, anyTypeOfKind, zonkAnyTyCon, + + -- * Recovery TyCon + makeRecoveryTyCon, + + -- * Sums + mkSumTy, sumTyCon, sumDataCon, + unboxedSumTyConName, unboxedSumDataConName, + + -- * Kinds + typeSymbolKindCon, typeSymbolKind, + isLiftedTypeKindTyConName, + typeToTypeKind, + liftedRepTyCon, unliftedRepTyCon, + tYPETyCon, tYPETyConName, tYPEKind, + cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind, + constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind, + constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon, + constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName, + liftedRepTyConName, unliftedRepTyConName, + + -- * Equality predicates + heqTyCon, heqTyConName, heqClass, heqDataCon, + eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR, + coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass, + + -- * RuntimeRep and friends + runtimeRepTyCon, vecCountTyCon, vecElemTyCon, + + boxedRepDataConTyCon, + runtimeRepTy, liftedRepTy, unliftedRepTy, zeroBitRepTy, + + vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, + + -- * Levity + levityTyCon, levityTy, + liftedDataConTyCon, unliftedDataConTyCon, + liftedDataConTy, unliftedDataConTy, + + intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy, + + vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy, + + int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + + doubleElemRepDataConTy, + + -- * Multiplicity and friends + multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy, + multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy, + oneDataConTyCon, manyDataConTyCon, + multMulTyCon, + + unrestrictedFunTyCon, unrestrictedFunTyConName, + + -- * Bignum + integerTy, integerTyCon, integerTyConName, + integerISDataCon, integerISDataConName, + integerIPDataCon, integerIPDataConName, + integerINDataCon, integerINDataConName, + naturalTy, naturalTyCon, naturalTyConName, + naturalNSDataCon, naturalNSDataConName, + naturalNBDataCon, naturalNBDataConName, + + pretendNameIsInScope, + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId ) + +-- friends: +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim +import GHC.Builtin.Uniques + +-- others: +import GHC.Core( Expr(Type), mkConApp ) +import GHC.Core.Coercion.Axiom +import GHC.Core.Type +import GHC.Types.Id +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.Class ( Class, mkClass ) +import GHC.Core.Map.Type ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap ) +import qualified GHC.Core.TyCo.Rep as TyCoRep ( Type(TyConApp) ) + +import GHC.Types.TyThing +import GHC.Types.SourceText +import GHC.Types.Var ( VarBndr (Bndr), tyVarName ) +import GHC.Types.RepType +import GHC.Types.Name.Reader +import GHC.Types.Name as Name +import GHC.Types.Name.Env ( lookupNameEnv_NF, mkNameEnv ) +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Unique.Set + +import {-# SOURCE #-} GHC.Tc.Types.Origin + ( FixedRuntimeRepOrigin(..), mkFRRUnboxedTuple, mkFRRUnboxedSum ) +import {-# SOURCE #-} GHC.Tc.Utils.TcType + ( ConcreteTvOrigin(..), ConcreteTyVars, noConcreteTyVars ) + +import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) +import GHC.Unit.Module ( Module ) + +import Data.Maybe +import Data.Array +import GHC.Data.FastString +import GHC.Data.BooleanFormula ( mkAnd ) + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString.Short.Internal as SBS (unsafeIndex) + +import Data.Foldable +import Data.List ( intersperse ) +import Numeric ( showInt ) + +import Data.Word (Word8) +import Control.Applicative ((<|>)) + +alpha_tyvar :: [TyVar] +alpha_tyvar = [alphaTyVar] + +alpha_ty :: [Type] +alpha_ty = [alphaTy] + +{- +Note [Wired-in Types and Type Constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This module include a lot of wired-in types and type constructors. Here, +these are presented in a tabular format to make it easier to find the +wired-in type identifier corresponding to a known Haskell type. Data +constructors are nested under their corresponding types with two spaces +of indentation. + +Identifier Type Haskell name Notes +---------------------------------------------------------------------------- +liftedTypeKindTyCon TyCon GHC.Types.Type Synonym for: TYPE LiftedRep +unliftedTypeKindTyCon TyCon GHC.Types.Type Synonym for: TYPE UnliftedRep +liftedRepTyCon TyCon GHC.Types.LiftedRep Synonym for: 'BoxedRep 'Lifted +unliftedRepTyCon TyCon GHC.Types.LiftedRep Synonym for: 'BoxedRep 'Unlifted +levityTyCon TyCon GHC.Types.Levity Data type + liftedDataConTyCon TyCon GHC.Types.Lifted Data constructor + unliftedDataConTyCon TyCon GHC.Types.Unlifted Data constructor +vecCountTyCon TyCon GHC.Types.VecCount Data type + vec2DataConTy Type GHC.Types.Vec2 Data constructor + vec4DataConTy Type GHC.Types.Vec4 Data constructor + vec8DataConTy Type GHC.Types.Vec8 Data constructor + vec16DataConTy Type GHC.Types.Vec16 Data constructor + vec32DataConTy Type GHC.Types.Vec32 Data constructor + vec64DataConTy Type GHC.Types.Vec64 Data constructor +runtimeRepTyCon TyCon GHC.Types.RuntimeRep Data type + boxedRepDataConTyCon TyCon GHC.Types.BoxedRep Data constructor + intRepDataConTy Type GHC.Types.IntRep Data constructor + doubleRepDataConTy Type GHC.Types.DoubleRep Data constructor + floatRepDataConTy Type GHC.Types.FloatRep Data constructor +boolTyCon TyCon GHC.Types.Bool Data type + trueDataCon DataCon GHC.Types.True Data constructor + falseDataCon DataCon GHC.Types.False Data constructor + promotedTrueDataCon TyCon GHC.Types.True Data constructor + promotedFalseDataCon TyCon GHC.Types.False Data constructor + +************************************************************************ +* * +\subsection{Wired in type constructors} +* * +************************************************************************ + +If you change which things are wired in, make sure you change their +names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc + +-} + + +-- This list is used only to define GHC.Builtin.Utils.knownKeyNames. That in turn +-- is used to initialise the name environment carried around by the renamer. +-- This means that if we look up the name of a TyCon (or its implicit binders) +-- that occurs in this list that name will be assigned the wired-in key we +-- define here. +-- +-- Because of their infinite nature, this list excludes +-- * Tuples of all sorts (boxed, unboxed, constraint) (mkTupleTyCon) +-- * Unboxed sums (sumTyCon) +-- See Note [Infinite families of known-key names] in GHC.Builtin.Names +-- +-- See also Note [Known-key names] +wiredInTyCons :: [TyCon] + +wiredInTyCons = map (dataConTyCon . snd) boxingDataCons + ++ [ anyTyCon + , zonkAnyTyCon + , boolTyCon + , charTyCon + , stringTyCon + , doubleTyCon + , floatTyCon + , intTyCon + , wordTyCon + , listTyCon + , orderingTyCon + , maybeTyCon + , heqTyCon + , eqTyCon + , coercibleTyCon + , typeSymbolKindCon + , runtimeRepTyCon + , levityTyCon + , vecCountTyCon + , vecElemTyCon + , constraintKindTyCon + , liftedTypeKindTyCon + , unliftedTypeKindTyCon + , unrestrictedFunTyCon + , multiplicityTyCon + , naturalTyCon + , integerTyCon + , liftedRepTyCon + , unliftedRepTyCon + , zeroBitRepTyCon + , zeroBitTypeTyCon + ] + +mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name +mkWiredInTyConName built_in modu fs unique tycon + = mkWiredInName modu (mkTcOccFS fs) unique + (ATyCon tycon) -- Relevant TyCon + built_in + +mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name +mkWiredInDataConName built_in modu fs unique datacon + = mkWiredInName modu (mkDataOccFS fs) unique + (AConLike (RealDataCon datacon)) -- Relevant DataCon + built_in + +mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name +mkWiredInIdName mod fs uniq id + = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax + +-- See Note [Kind-changing of (~) and Coercible] +-- in libraries/ghc-prim/GHC/Types.hs +eqTyConName, eqDataConName, eqSCSelIdName :: Name +eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon +eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon +eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId + +eqTyCon_RDR :: RdrName +eqTyCon_RDR = nameRdrName eqTyConName + +-- See Note [Kind-changing of (~) and Coercible] +-- in libraries/ghc-prim/GHC/Types.hs +heqTyConName, heqDataConName, heqSCSelIdName :: Name +heqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~~") heqTyConKey heqTyCon +heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon +heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId + +-- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs +coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name +coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon +coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon +coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId + +charTyConName, charDataConName, intTyConName, intDataConName, stringTyConName :: Name +charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon +charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon +stringTyConName = mkWiredInTyConName UserSyntax gHC_INTERNAL_BASE (fsLit "String") stringTyConKey stringTyCon +intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon +intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon + +boolTyConName, falseDataConName, trueDataConName :: Name +boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon +falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon +trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon + +listTyConName, nilDataConName, consDataConName :: Name +listTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "List") listTyConKey listTyCon +nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon +consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon + +maybeTyConName, nothingDataConName, justDataConName :: Name +maybeTyConName = mkWiredInTyConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Maybe") + maybeTyConKey maybeTyCon +nothingDataConName = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Nothing") + nothingDataConKey nothingDataCon +justDataConName = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Just") + justDataConKey justDataCon + +wordTyConName, wordDataConName, word8DataConName :: Name +wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon +wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon +word8DataConName = mkWiredInDataConName UserSyntax gHC_INTERNAL_WORD (fsLit "W8#") word8DataConKey word8DataCon + +floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name +floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon +floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon +doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon +doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon + +-- Any + +{- +Note [Any types] +~~~~~~~~~~~~~~~~ +The type constructors `Any` and `ZonkAny` are closed type families declared thus: + + type family Any :: forall k. k where { } + type family ZonkAny :: forall k. Nat -> k where { } + +They are used when we want a type of a particular kind, but we don't really care +what that type is. The leading example is this: `ZonkAny` is used to instantiate +un-constrained type variables after type checking. For example, consider the +term (length [] :: Int), where + + length :: forall a. [a] -> Int + [] :: forall a. [a] + +We must type-apply `length` and `[]`, but to what type? It doesn't matter! +The typechecker will end up with + + length @alpha ([] @alpha) + +where `alpha` is an un-constrained unification variable. The "zonking" process zaps +that unconstrained `alpha` to an arbitrary type (ZonkAny @Type 3), where the `3` is +arbitrary (see wrinkle (Any5) below). This is done in `GHC.Tc.Zonk.Type.commitFlexi`. +So we end up with + + length @(ZonkAny @Type 3) ([] @(ZonkAny @Type 3)) + +`Any` and `ZonkAny` differ only in the presence of the `Nat` argument; see +wrinkle (Any4). + +Wrinkles: + +(Any1) `Any` and `ZonkAny` are kind polymorphic since in some program we may + need to use `ZonkAny` to fill in a type variable of some kind other than * + (see #959 for examples). + +(Any2) They are /closed/ type families, with no instances. For example, suppose that + with alpha :: '(k1, k2) we add a given coercion + g :: alpha ~ (Fst alpha, Snd alpha) + and we zonked alpha = ZonkAny @(k1,k2) n. Then, if `ZonkAny` was a /data/ type, + we'd get inconsistency because we'd have a Given equality with `ZonkAny` on one + side and '(,) on the other. See also #9097 and #9636. + + See #25244 for a suggestion that we instead use an /open/ type family for which + you cannot provide instances. Probably the difference is not very important. + +(Any3) They do not claim to be /data/ types, and that's important for + the code generator, because the code gen may /enter/ a data value + but never enters a function value. + +(Any4) `ZonkAny` takes a `Nat` argument so that we can readily make up /distinct/ + types (#24817). Consider + + data SBool a where { STrue :: SBool True; SFalse :: SBool False } + + foo :: forall a b. (SBool a, SBool b) + + bar :: Bool + bar = case foo @alpha @beta of + (STrue, SFalse) -> True -- This branch is not inaccessible! + _ -> False + + Now, what are `alpha` and `beta`? If we zonk both of them to the same type + `Any @Type`, the pattern-match checker will (wrongly) report that the first + branch is inaccessible. So we zonk them to two /different/ types: + alpha := ZonkAny @Type 4 and beta := ZonkAny @Type k 5 + (The actual numbers are arbitrary; they just need to differ.) + + The unique-name generation comes from field `tcg_zany_n` of `TcGblEnv`; and + `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newZonkAnyType` to + make up a fresh type. + + If this example seems unconvincing (e.g. in this case foo must be bottom) + see #24817 for larger but more compelling examples. + +(Any5) `Any` and `ZonkAny` are wired-in so we can easily refer to it where we + don't have a name environment (e.g. see Rules.matchRule for one example) + +(Any6) `Any` is defined in library module ghc-prim:GHC.Types, and exported so that + it is available to users. For this reason it's treated like any other + wired-in type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + Currently `ZonkAny` is not available to users; but it could easily be. + +(Any7) Properties of `Any`: + * When `Any` is instantiated at a lifted type it is inhabited by at least one value, + namely bottom. + + * You can safely coerce any /lifted/ type to `Any` and back with `unsafeCoerce`. + + * You can safely coerce any /unlifted/ type to `Any` and back with `unsafeCoerceUnlifted`. + + * You can coerce /any/ type to `Any` and back with `unsafeCoerce#`, but it's only safe when + the kinds of both the type and `Any` match. + + * For lifted/unlifted types `unsafeCoerce[Unlifted]` should be preferred over + `unsafeCoerce#` as they prevent accidentally coercing between types with kinds + that don't match. + + See examples in ghc-prim:GHC.Types + +(Any8) Warning about unused bindings of type `Any` and `ZonkAny` are suppressed, + following the same rationale of supressing warning about the unit type. + + For example, consider (#25895): + + do { forever (return ()); blah } + + where forever :: forall a b. IO a -> IO b + Nothing constrains `b`, so it will be instantiates with `Any` or `ZonkAny`. + But we certainly don't want to complain about a discarded do-binding. + +The Any tycon used to be quite magic, but we have since been able to +implement it merely with an empty kind polymorphic type family. See #10886 for a +bit of history. +-} + + +anyTyConName :: Name +anyTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon + +anyTyCon :: TyCon +-- See Note [Any types] +anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing + (ClosedSynFamilyTyCon Nothing) + Nothing + NotInjective + where + binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind] + res_kind = mkTyVarTy (binderVar kv) + +anyTy :: Type +anyTy = mkTyConTy anyTyCon + +anyTypeOfKind :: Kind -> Type +anyTypeOfKind kind = mkTyConApp anyTyCon [kind] + +zonkAnyTyConName :: Name +zonkAnyTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZonkAny") zonkAnyTyConKey zonkAnyTyCon + +zonkAnyTyCon :: TyCon +-- ZonkAnyTyCon :: forall k. Nat -> k +-- See Note [Any types] +zonkAnyTyCon = mkFamilyTyCon zonkAnyTyConName + [ mkNamedTyConBinder Specified kv + , mkAnonTyConBinder nat_kv ] + (mkTyVarTy kv) + Nothing + (ClosedSynFamilyTyCon Nothing) + Nothing + NotInjective + where + [kv,nat_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy] + +-- | Make a fake, recovery 'TyCon' from an existing one. +-- Used when recovering from errors in type declarations +makeRecoveryTyCon :: TyCon -> TyCon +makeRecoveryTyCon tc + = mkTcTyCon (tyConName tc) + bndrs res_kind + noTcTyConScopedTyVars + True -- Fully generalised + flavour -- Keep old flavour + where + flavour = tyConFlavour tc + [kv] = mkTemplateKindVars [liftedTypeKind] + (bndrs, res_kind) + = case flavour of + PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv) + _ -> (tyConBinders tc, tyConResKind tc) + -- For data types we have already validated their kind, so it + -- makes sense to keep it. For promoted data constructors we haven't, + -- so we recover with kind (forall k. k). Otherwise consider + -- data T a where { MkT :: Show a => T a } + -- If T is for some reason invalid, we don't want to fall over + -- at (promoted) use-sites of MkT. + +-- Kinds +typeSymbolKindConName :: Name +typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon + + +boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR, + intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName +boolTyCon_RDR = nameRdrName boolTyConName +false_RDR = nameRdrName falseDataConName +true_RDR = nameRdrName trueDataConName +intTyCon_RDR = nameRdrName intTyConName +charTyCon_RDR = nameRdrName charTyConName +stringTyCon_RDR = nameRdrName stringTyConName +intDataCon_RDR = nameRdrName intDataConName +listTyCon_RDR = nameRdrName listTyConName +consDataCon_RDR = nameRdrName consDataConName + +{- +************************************************************************ +* * +\subsection{mkWiredInTyCon} +* * +************************************************************************ +-} + +-- This function assumes that the types it creates have all parameters at +-- Representational role, and that there is no kind polymorphism. +pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon +pcTyCon name cType tyvars cons + = mkAlgTyCon name + (mkAnonTyConBinders tyvars) + liftedTypeKind + (map (const Representational) tyvars) + cType + [] -- No stupid theta + (mkDataTyConRhs cons) + (VanillaAlgTyCon (mkPrelTyConRepName name)) + False -- Not in GADT syntax + +pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon +pcDataCon n univs tys + = pcRepPolyDataCon n univs noConcreteTyVars tys + +pcRepPolyDataCon :: Name -> [TyVar] -> ConcreteTyVars + -> [Type] -> TyCon -> DataCon +pcRepPolyDataCon n univs conc_tvs tys + = pcDataConWithFixity False n + univs + [] -- no ex_tvs + conc_tvs + univs -- the univs are precisely the user-written tyvars + [] -- No theta + (map linear tys) + +pcDataConConstraint :: Name -> [TyVar] -> ThetaType -> TyCon -> DataCon +-- Used for data constructors whose arguments are all constraints. +-- Notably constraint tuples, Eq# etc. +pcDataConConstraint n univs theta + = pcDataConWithFixity False n + univs + [] -- No ex_tvs + noConcreteTyVars + univs -- The univs are precisely the user-written tyvars + theta -- All constraint arguments + [] -- No value arguments + +-- Used for RuntimeRep and friends; things with PromDataConInfo +pcSpecialDataCon :: Name -> [Type] -> TyCon -> PromDataConInfo -> DataCon +pcSpecialDataCon dc_name arg_tys tycon rri + = pcDataConWithFixity' False dc_name + (dataConWorkerUnique (nameUnique dc_name)) rri + [] [] noConcreteTyVars [] [] (map linear arg_tys) tycon + +pcDataConWithFixity :: Bool -- ^ declared infix? + -> Name -- ^ datacon name + -> [TyVar] -- ^ univ tyvars + -> [TyCoVar] -- ^ ex tycovars + -> ConcreteTyVars + -- ^ concrete tyvars + -> [TyCoVar] -- ^ user-written tycovars + -> ThetaType + -> [Scaled Type] -- ^ args + -> TyCon + -> DataCon +pcDataConWithFixity infx n = pcDataConWithFixity' infx n + (dataConWorkerUnique (nameUnique n)) NoPromInfo +-- The Name's unique is the first of two free uniques; +-- the first is used for the datacon itself, +-- the second is used for the "worker name" +-- +-- To support this the mkPreludeDataConUnique function "allocates" +-- one DataCon unique per pair of Ints. + +pcDataConWithFixity' :: Bool -> Name -> Unique -> PromDataConInfo + -> [TyVar] -> [TyCoVar] + -> ConcreteTyVars + -> [TyCoVar] + -> ThetaType -> [Scaled Type] -> TyCon -> DataCon +-- The Name should be in the DataName name space; it's the name +-- of the DataCon itself. +-- +-- IMPORTANT NOTE: +-- if you try to wire-in a /GADT/ data constructor you will +-- find it hard (we did). You will need wrapper and worker +-- Names, a DataConBoxer, DataConRep, EqSpec, etc. +-- Try hard not to wire-in GADT data types. You will live +-- to regret doing so (we do). + +pcDataConWithFixity' declared_infix dc_name wrk_key rri + tyvars ex_tyvars conc_tyvars user_tyvars theta arg_tys tycon + = data_con + where + tag_map = mkTyConTagMap tycon + -- This constructs the constructor Name to ConTag map once per + -- constructor, which is quadratic. It's OK here, because it's + -- only called for wired in data types that don't have a lot of + -- constructors. It's also likely that GHC will lift tag_map, since + -- we call pcDataConWithFixity' with static TyCons in the same module. + -- See Note [Constructor tag allocation] and #14657 + data_con = mkDataCon dc_name declared_infix prom_info + (map (const no_bang) arg_tys) + (map (const HsLazy) arg_tys) + (map (const NotMarkedStrict) arg_tys) + [] -- No labelled fields + tyvars ex_tyvars + conc_tyvars + (mkTyVarBinders Specified user_tyvars) + [] -- No equality spec + theta + arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) + rri + tycon + (lookupNameEnv_NF tag_map dc_name) + [] -- No stupid theta + (mkDataConWorkId wrk_name data_con) + NoDataConRep -- Wired-in types are too simple to need wrappers + + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict + + wrk_name = mkDataConWorkerName data_con wrk_key + + prom_info = mkPrelTyConRepName dc_name + +mkDataConWorkerName :: DataCon -> Unique -> Name +mkDataConWorkerName data_con wrk_key = + mkWiredInName modu wrk_occ wrk_key + (AnId (dataConWorkId data_con)) UserSyntax + where + modu = assert (isExternalName dc_name) $ + nameModule dc_name + dc_name = dataConName data_con + dc_occ = nameOccName dc_name + wrk_occ = mkDataConWorkerOcc dc_occ + + +{- +************************************************************************ +* * + Symbol +* * +************************************************************************ +-} + +typeSymbolKindCon :: TyCon +-- data Symbol +typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] [] + +typeSymbolKind :: Kind +typeSymbolKind = mkTyConTy typeSymbolKindCon + + +{- +************************************************************************ +* * + Stuff for dealing with tuples +* * +************************************************************************ + +Note [How tuples work] +~~~~~~~~~~~~~~~~~~~~~~ +* There are three families of tuple TyCons and corresponding + DataCons, expressed by the type BasicTypes.TupleSort: + data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple + +* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon + +* BoxedTuples + - A wired-in type + - Data type declarations in GHC.Tuple + - The data constructors really have an info table + +* UnboxedTuples + - A wired-in type + - Data type declarations in GHC.Types + but no actual declaration and no info table + +* ConstraintTuples + - A wired-in type. + - Declared as classes in GHC.Classes, e.g. + class (c1,c2) => CTuple2 c1 c2 + - Given constraints: the superclasses automatically become available + - Wanted constraints: there is a built-in instance + instance (c1,c2) => CTuple2 c1 c2 + See GHC.Tc.Instance.Class.matchCTuple + - Currently just go up to 64; beyond that + you have to use manual nesting + - Unlike BoxedTuples and UnboxedTuples, which only wire + in type constructors and data constructors, ConstraintTuples also wire in + superclass selector functions. For instance, $p1CTuple2 and $p2CTuple2 are + the selectors for the binary constraint tuple. + - The parenthesis syntax for grouping constraints in contexts is not treated + as a constraint tuple. The parser starts with a tuple type, then a + postprocessing action extracts the individual constraints as a list and + stores them in the context field of types like HsQualTy. + +* In quite a lot of places things are restricted just to + BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish + E.g. tupleTyCon has a Boxity argument + +* When looking up an OccName in the original-name cache + (GHC.Types.Name.Cache.lookupOrigNameCache), we spot the tuple OccName to make + sure we get the right wired-in name. + +* Serialization to interface files works via the usual mechanism for known-key + things: instead of serializing the OccName we just serialize the key. During + deserialization we lookup the Name associated with the unique with the logic + in GHC.Builtin.Uniques. See Note [Symbol table representation of names] for details. + +See also Note [Known-key names] in GHC.Builtin.Names. + +Note [One-tuples] +~~~~~~~~~~~~~~~~~ +GHC supports both boxed and unboxed one-tuples: + - Unboxed one-tuples are sometimes useful when returning a + single value after CPR analysis + - A boxed one-tuple is used by GHC.HsToCore.Utils.mkSelectorBinds, when + there is just one binder +Basically it keeps everything uniform. + +However the /naming/ of the type/data constructors for one-tuples is a +bit odd: + 3-tuples: Tuple3 (,,)# + 2-tuples: Tuple2 (,)# + 1-tuples: ?? + 0-tuples: Unit ()# + +Zero-tuples have used up the logical name. So we use 'Solo' and 'Solo#' +for one-tuples. So in ghc-prim:GHC.Tuple we see the declarations: + data Unit = () + data Solo a = MkSolo a + data Tuple2 a b = (a,b) + +There is no way to write a boxed one-tuple in Haskell using tuple syntax. +They can, however, be written using other methods: + +1. They can be written directly by importing them from GHC.Tuple. +2. They can be generated by way of Template Haskell or in `deriving` code. + +There is nothing special about one-tuples in Core; in particular, they have no +custom pretty-printing, just using `Solo`. + +See also Note [Flattening one-tuples] in GHC.Core.Make and +Note [Don't flatten tuples from HsSyn] in GHC.Core.Make. + +Note [isBuiltInOcc_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~ +`isBuiltInOcc_maybe` matches and resolves names that are occurrences of built-in +syntax, i.e. unqualified names that can be unambiguously resolved even without +knowing what's currently in scope (such names also can't be imported, exported, +or redefined in another module). +More on that in Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache. + +In GHC, there are two use cases for `isBuiltInOcc_maybe`: + +1. Making TH's `mkName` work with built-in syntax, + e.g. $(conT (mkName "[]")) is the same as [] + +2. Detecting bulit-in syntax in `infix` declarations, + e.g. users can't write `infixl 6 :` (#15233) + +The parser takes a shortcut and produces Exact RdrNames directly, +so it doesn't need to match on an OccName with isBuiltInOcc_maybe. + +And here are the properties of `isBuiltInOcc_maybe`: + +* The set of names recognized by `isBuiltInOcc_maybe` is essentialy the + same as the set of names that the parser resolves to Exact RdrNames, + e.g. "[]", "(,)", or "->". + + We could leave it at that, but we also recognize unboxed sum syntax + "(#|#)" even though the parser can't handle it. This makes TH's `mkName` + more permissive than the parser. + +* The namespace of the input OccName is treated as a hint, not a + requirement. For example, + + mkOccName dataName ":" maps to consDataConName + mkOccName tcClsName ":" /also/ maps to consDataConName + + The rationale behind this is that with DataKind or RequiredTypeArguments + we may get an OccName with the wrong namespace and need to fallback to the + other one. + +* There is a `listTuplePuns :: Bool` parameter to account for the + ListTuplePuns extension. It has /no/ effect on whether the predicate + matches (i.e. if the result is Just or Nothing), but it can influence + which name is returned (TyCon name or DataCon name). For example, + + isBuiltInOcc_maybe False (mkOccName dataName "[]") == Just nilDataConName + isBuiltInOcc_maybe False (mkOccName tcClsName "[]") == Just nilDataConName + isBuiltInOcc_maybe True (mkOccName dataName "[]") == Just nilDataConName + isBuiltInOcc_maybe True (mkOccName tcClsName "[]") == Just listTyConName + +* There is no `Module` parameter because we are matching unqualified + occurrences of built-in names. It is illegal to qualify built-in syntax, + e.g. GHC.Types.(,) is a parse error. + +* The /input/ to `isBuiltInOcc_maybe` needs to be built-in syntax for the + predicate to match, but the /output/ is not necessarily built-in syntax. + For example, + + 1) input: mkTcOcc "[]" -- built-in syntax + output: Just listTyConName -- user syntax (GHC.Types.List) + + 2) input: mkDataOcc "[]" -- built-in syntax + output: Just nilDataConName -- built-in syntax [] + + 3) input: mkTcOcc "List" -- user syntax + output: Nothing -- no match + + 4) input: mkTcOcc "(,)" -- built-in syntax + output: Just (tupleTyConName BoxedTuple 2) -- user syntax (GHC.Types.Tuple2) + + 5) input: mkTcOcc "(#|#)" -- built-in syntax + output: Just (unboxedSumTyConName 2) -- user syntax (GHC.Types.Sum2#) + + Therefore, `GHC.Types.Name.isBuiltInSyntax` may or may not hold for the name + returned by `isBuiltInOcc_maybe`. +-} + +-- | Match on built-in syntax as it occurs at use sites. +-- See Note [isBuiltInOcc_maybe] +isBuiltInOcc_maybe :: Bool -> OccName -> Maybe Name +isBuiltInOcc_maybe listTuplePuns occ + | fs == "->" = Just unrestrictedFunTyConName + | fs == "[]" = Just (pun listTyConName nilDataConName) + | fs == ":" = Just consDataConName + | Just n <- (is_boxed_tup_syntax fs) = Just (tup_name Boxed n) + | Just n <- (is_unboxed_tup_syntax fs) = Just (tup_name Unboxed n) + | Just n <- (is_unboxed_sum_type_syntax fs) = Just (unboxedSumTyConName n) + | Just (k, n) <- (is_unboxed_sum_data_syntax fs) = Just (unboxedSumDataConName k n) + | otherwise = Nothing + where + fs = occNameFS occ + ns = occNameSpace occ + + pun :: Name -> Name -> Name + pun p n + | listTuplePuns, isTcClsNameSpace ns = p + | otherwise = n + + tup_name :: Boxity -> Arity -> Name + tup_name boxity arity + = pun (tyConName (tupleTyCon boxity arity)) + (dataConName (tupleDataCon boxity arity)) + +-- | Check if the OccName is an occurrence of built-in syntax. +-- +-- This is a variant of `isBuiltInOcc_maybe` that returns a `Bool`. +-- See Note [isBuiltInOcc_maybe] +-- +-- `isBuiltInOcc` holds for: +-- * function arrow `->` +-- * list syntax `[]`, `:` +-- * boxed tuple syntax `()`, `(,)`, `(,,)`, `(,,,)`, ... +-- * unboxed tuple syntax `(##)`, `(#,#)`, `(#,,#)`, ... +-- * unboxed sum type syntax `(#|#)`, `(#||#)`, `(#|||#)`, ... +-- * unboxed sum data syntax `(#_|#)`, `(#|_#)`, `(#_||#), ... +isBuiltInOcc :: OccName -> Bool +isBuiltInOcc = isJust . isBuiltInOcc_maybe listTuplePuns + where + listTuplePuns = False + -- True/False here is inconsequential because ListTuplePuns doesn't affect + -- whether isBuiltInOcc_maybe matches. See Note [isBuiltInOcc_maybe] + +-- Match on original names of infinite families (tuples and sums). +-- See Note [Infinite families of known-key names] in GHC.Builtin.Names +isInfiniteFamilyOrigName_maybe :: Module -> OccName -> Maybe Name +isInfiniteFamilyOrigName_maybe mod occ = + + -- Tuples, boxed and unboxed + isTupleTyOrigName_maybe mod occ + <|> isTupleDataOrigName_maybe mod occ + + -- Constraint tuples + <|> isCTupleOrigName_maybe mod occ + + -- Unboxed sums + <|> isSumTyOrigName_maybe mod occ + <|> isSumDataOrigName_maybe mod occ + +-- Check if the string has form "()", "(,)", "(,,)", etc, +-- and return the corresponding tuple arity. +is_boxed_tup_syntax :: FastString -> Maybe Arity +is_boxed_tup_syntax fs + | fs == "()" = Just 0 + | n >= 2 + , SBS.unsafeIndex sbs 0 == 40 -- ord '(' + , SBS.unsafeIndex sbs (n-1) == 41 -- ord ')' + , sbs_all sbs 1 (n-1) 44 -- ord ',' + = Just (n-1) + where + n = SBS.length sbs -- O(1) + sbs = fastStringToShortByteString fs -- O(1) field access +is_boxed_tup_syntax _ = Nothing + +-- Check if the string has form "(##)", "(# #)", (#,#)", "(#,,#)", etc, +-- and return the corresponding tuple arity. +is_unboxed_tup_syntax :: FastString -> Maybe Arity +is_unboxed_tup_syntax fs + | fs == "(##)" = Just 0 + | fs == "(# #)" = Just 1 + | sbs_unboxed sbs + , sbs_all sbs 2 (n-2) 44 -- ord ',' + = Just (n-3) + where + n = SBS.length sbs -- O(1) + sbs = fastStringToShortByteString fs -- O(1) field access +is_unboxed_tup_syntax _ = Nothing + +-- Check if the string has form "(#|#)", "(#||#)", (#|||#)", etc, +-- and return the corresponding sum arity. +is_unboxed_sum_type_syntax :: FastString -> Maybe Arity +is_unboxed_sum_type_syntax fs + | sbs_unboxed sbs + , Just k <- sbs_pipes sbs 2 (n-2) + , k > 0 + = Just (k+1) + where + n = SBS.length sbs -- O(1) + sbs = fastStringToShortByteString fs -- O(1) field access +is_unboxed_sum_type_syntax _ = Nothing + +-- Check if the string has form "(#_|#)", "(#_||#)", (#|_|#)", etc, +-- and return the corresponding sum tag and sum arity. +is_unboxed_sum_data_syntax :: FastString -> Maybe (ConTag, Arity) +is_unboxed_sum_data_syntax fs + | sbs_unboxed sbs + , Just u <- SBS.elemIndex 95 sbs -- ord '_' + , Just k1 <- sbs_pipes sbs 2 u -- pipes to the left of '_' + , Just k2 <- sbs_pipes sbs (u+1) (n-2) -- pipes to the right of '_' + = Just (k1+1, k1+k2+1) + where + n = SBS.length sbs -- O(1) + sbs = fastStringToShortByteString fs -- O(1) field access +is_unboxed_sum_data_syntax _ = Nothing + +-- (sbs_all sbs i n x) checks if all bytes in the slice [i..n) are equal to x. +sbs_all :: SBS.ShortByteString -> Int -> Int -> Word8 -> Bool +sbs_all !sbs !i !n !x + | i < n = SBS.unsafeIndex sbs i == x && sbs_all sbs (i+1) n x + | otherwise = True + +-- (sbs_pipes sbs i n) checks if all bytes in the slice [i..n) are equal to '|' +-- or ' ', and returns the number of encountered '|'. +sbs_pipes :: SBS.ShortByteString -> Int -> Int -> Maybe Int +sbs_pipes !sbs = go 0 + where + go :: Int -> Int -> Int -> Maybe Int + go !k !i !n + | i < n = + if | SBS.unsafeIndex sbs i == 124 -> go (k+1) (i+1) n -- ord '|' + | SBS.unsafeIndex sbs i == 32 -> go k (i+1) n -- ord ' ' + | otherwise -> Nothing + | otherwise = Just k + +-- (sbs_unboxed sbs) checks if the string starts with "(#" and ends with "#)". +sbs_unboxed :: SBS.ShortByteString -> Bool +sbs_unboxed !sbs = + n >= 4 && SBS.unsafeIndex sbs 0 == 40 -- ord '(' + && SBS.unsafeIndex sbs 1 == 35 -- ord '#' + && SBS.unsafeIndex sbs (n-2) == 35 -- ord '#' + && SBS.unsafeIndex sbs (n-1) == 41 -- ord ')' + where + n = SBS.length sbs -- O(1) + +-- (sbs_Sum sbs) checks if the string has form "SumN#" or "SumNM#", +-- where "N" or "NM" is a decimal numeral in the [2..mAX_SUM_SIZE] range. +sbs_Sum :: SBS.ShortByteString -> Maybe Arity +sbs_Sum !sbs + | n >= 3 && SBS.unsafeIndex sbs 0 == 83 -- ord 'S' + && SBS.unsafeIndex sbs 1 == 117 -- ord 'u' + && SBS.unsafeIndex sbs 2 == 109 -- ord 'm' + , Just (Unboxed, arity) <- sbs_arity_boxity sbs 3 + , arity >= 2, arity <= mAX_SUM_SIZE + = Just arity + | otherwise = Nothing + where + n = SBS.length sbs -- O(1) + +-- (sbs_Tuple sbs) checks if the string has form "TupleN", "TupleNM", "TupleN#" or "TupleNM#", +-- where "N" or "NM" is a decimal numeral in the [2..mAX_TUPLE_SIZE] range. +sbs_Tuple :: SBS.ShortByteString -> Maybe (Boxity, Arity) +sbs_Tuple !sbs + | n >= 5 && SBS.unsafeIndex sbs 0 == 84 -- ord 'T' + && SBS.unsafeIndex sbs 1 == 117 -- ord 'u' + && SBS.unsafeIndex sbs 2 == 112 -- ord 'p' + && SBS.unsafeIndex sbs 3 == 108 -- ord 'l' + && SBS.unsafeIndex sbs 4 == 101 -- ord 'e' + , Just r@(_, arity) <- sbs_arity_boxity sbs 5 + , arity >= 2, arity <= mAX_TUPLE_SIZE + = Just r + | otherwise = Nothing + where + n = SBS.length sbs -- O(1) + +-- (sbs_CTuple sbs) checks if the string has form "CTupleN" or "CTupleNM", +-- where "N" or "NM" is a decimal numeral in the [2..mAX_CTUPLE_SIZE] range. +sbs_CTuple :: SBS.ShortByteString -> Maybe Arity +sbs_CTuple !sbs + | n >= 6 && SBS.unsafeIndex sbs 0 == 67 -- ord 'C' + && SBS.unsafeIndex sbs 1 == 84 -- ord 'T' + && SBS.unsafeIndex sbs 2 == 117 -- ord 'u' + && SBS.unsafeIndex sbs 3 == 112 -- ord 'p' + && SBS.unsafeIndex sbs 4 == 108 -- ord 'l' + && SBS.unsafeIndex sbs 5 == 101 -- ord 'e' + , Just (Boxed, arity) <- sbs_arity_boxity sbs 6 + , arity >= 2, arity <= mAX_CTUPLE_SIZE + = Just arity + | otherwise = Nothing + where + n = SBS.length sbs -- O(1) + +-- (sbs_arity_boxity sbs i) parses bytes from position `i` to the end, +-- matching single- and double-digit decimals numerals (i.e. from 0 to 99) +-- possibly followed by '#'. See Note [Small Ints parsing] +sbs_arity_boxity :: SBS.ShortByteString -> Int -> Maybe (Boxity, Arity) +sbs_arity_boxity !sbs !i = + case n - i of -- bytes to parse + 1 -> parse1 (SBS.unsafeIndex sbs i) + 2 -> parse2 (SBS.unsafeIndex sbs i) (SBS.unsafeIndex sbs (i+1)) + 3 -> parse3 (SBS.unsafeIndex sbs i) (SBS.unsafeIndex sbs (i+1)) (SBS.unsafeIndex sbs (i+2)) + _ -> Nothing + where + n = SBS.length sbs -- O(1) + + is_digit :: Word8 -> Bool + is_digit x = x >= 48 && x <= 57 -- between (ord '0') and (ord '9') + + from_digit :: Word8 -> Int + from_digit x = fromIntegral (x - 48) + + -- single-digit number + parse1 :: Word8 -> Maybe (Boxity, Arity) + parse1 x1 | is_digit x1 = Just (Boxed, from_digit x1) + parse1 _ = Nothing + + -- double-digit number, or a single-digit number followed by '#' + parse2 :: Word8 -> Word8 -> Maybe (Boxity, Arity) + parse2 x1 35 -- ord '#' + | is_digit x1 = Just (Unboxed, from_digit x1) + parse2 x1 x2 + | is_digit x1, is_digit x2 + = Just (Boxed, from_digit x1 * 10 + from_digit x2) + parse2 _ _ = Nothing + + -- double-digit number followed by '#' + parse3 :: Word8 -> Word8 -> Word8 -> Maybe (Boxity, Arity) + parse3 x1 x2 35 -- ord '#' + | is_digit x1, is_digit x2 + = Just (Unboxed, from_digit x1 * 10 + from_digit x2) + parse3 _ _ _ = Nothing + +-- Identify original names of boxed and unboxed tuple type constructors. +-- Examples: +-- 0b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Unit") = Just +-- 1b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Solo") = Just +-- 2b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Tuple2") = Just +-- 0u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Unit#") = Just +-- 1u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Solo#") = Just +-- 2u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Tuple2#") = Just +-- ... +-- 64b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Tuple64") = Just +-- 64u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Tuple64#") = Just +-- +-- Non-examples: "()", "(##)", "(,)", "(#,#)", "(,,)", "(#,,#)", etc. +-- As far as tuple /types/ are concerned, these are not the original names +-- but rather punned names under ListTuplePuns. +-- +-- Also non-examples: "Tuple0", "Tuple0#", "Tuple1", and "Tuple1#". +-- These are merely type synonyms for "Unit", "Unit#", "Solo", and "Solo#". +isTupleTyOrigName_maybe :: Module -> OccName -> Maybe Name +isTupleTyOrigName_maybe mod occ + | mod == gHC_INTERNAL_TUPLE = match_occ_boxed + | mod == gHC_TYPES = match_occ_unboxed + where + fs = occNameFS occ + ns = occNameSpace occ + sbs = fastStringToShortByteString fs -- O(1) field access + + match_occ_boxed + | occ == occName unitTyConName = Just unitTyConName + | occ == occName soloTyConName = Just soloTyConName + | isTcClsNameSpace ns, Just (boxity@Boxed, n) <- sbs_Tuple sbs, n >= 2 + = Just (tyConName (tupleTyCon boxity n)) + | otherwise = Nothing + + match_occ_unboxed + | occ == occName unboxedUnitTyConName = Just unboxedUnitTyConName + | occ == occName unboxedSoloTyConName = Just unboxedSoloTyConName + | isTcClsNameSpace ns, Just (boxity@Unboxed, n) <- sbs_Tuple sbs, n >= 2 + = Just (tyConName (tupleTyCon boxity n)) + | otherwise = Nothing + +isTupleTyOrigName_maybe _ _ = Nothing + +-- Identify original names of boxed and unboxed tuple data constructors. +-- Examples: +-- 0b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "()") = Just +-- 1b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "MkSolo") = Just +-- 2b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "(,)") = Just +-- ... +-- 0u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "(##)") = Just +-- 1u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "MkSolo#") = Just +-- 2u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "(#,#)") = Just +-- ... +-- +-- Non-examples: Tuple or Tuple#, as this is the name format of tuple /type/ constructors. +isTupleDataOrigName_maybe :: Module -> OccName -> Maybe Name +isTupleDataOrigName_maybe mod occ + | mod == gHC_INTERNAL_TUPLE = match_occ_boxed + | mod == gHC_TYPES = match_occ_unboxed + where + match_occ_boxed + | occ == occName soloDataConName = Just soloDataConName + | isDataConNameSpace ns, Just n <- (is_boxed_tup_syntax fs) + = Just (tupleDataConName Boxed n) + | otherwise = Nothing + match_occ_unboxed + | occ == occName unboxedSoloDataConName = Just unboxedSoloDataConName + | isDataConNameSpace ns, Just n <- (is_unboxed_tup_syntax fs) + = Just (tupleDataConName Unboxed n) + | otherwise = Nothing + fs = occNameFS occ + ns = occNameSpace occ +isTupleDataOrigName_maybe _ _ = Nothing + +-- Identify original names of constraint tuples. +-- Examples: +-- 0) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CUnit") = Just +-- 1) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CSolo") = Just +-- 2) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CTuple2") = Just +-- ... +-- 64) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CTuple64") = Just +-- +-- Non-examples: "()", "(,)", "(,,)", etc. +-- As far as constraint tuples are concerned, these are not the original names +-- but rather punned names under ListTuplePuns. +-- +-- Also non-examples: "CTuple0" and "CTuple1". +-- These are merely type synonyms for "CUnit" and "CSolo". +isCTupleOrigName_maybe :: Module -> OccName -> Maybe Name +isCTupleOrigName_maybe mod occ + | mod == gHC_CLASSES + = match_occ + where + fs = occNameFS occ + sbs = fastStringToShortByteString fs -- O(1) field access + match_occ + | occ == occName (cTupleTyConName 0) = Just (cTupleTyConName 0) -- CUnit + | occ == occName (cTupleTyConName 1) = Just (cTupleTyConName 1) -- CSolo + + | Just num <- sbs_CTuple sbs, num >= 2 + = Just $ cTupleTyConName num + + | otherwise = Nothing + +isCTupleOrigName_maybe _ _ = Nothing + +-- Identify original names of unboxed sum type constructors. +-- Examples: +-- 2) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum2#") = Just +-- 3) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum3#") = Just +-- 4) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum4#") = Just +-- ... +-- 64) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum64#") = Just +-- +-- Non-examples: "(#|#)", "(#||#)", "(#|||#)", etc. These are not valid syntax. +-- Also non-examples: "Sum0#", "Sum1#". These do not exist. +isSumTyOrigName_maybe :: Module -> OccName -> Maybe Name +isSumTyOrigName_maybe mod occ + | mod == gHC_TYPES + , isTcClsNameSpace ns + , Just n <- sbs_Sum sbs + , n >= 2 + = Just (tyConName (sumTyCon n)) + where + fs = occNameFS occ + ns = occNameSpace occ + sbs = fastStringToShortByteString fs -- O(1) field access +isSumTyOrigName_maybe _ _ = Nothing + +-- Identify original names of unboxed sum data constructors. +-- "(#_|#)", "(#_||#)", (#|_|#)" +-- +-- Examples: +-- 1/2) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#_|#)") = Just +-- 1/3) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#_||#)") = Just +-- 2/3) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#|_|#)") = Just +-- ... +-- +-- Non-examples: Sum#, as this is the name format of unboxed sum /type/ constructors. +isSumDataOrigName_maybe :: Module -> OccName -> Maybe Name +isSumDataOrigName_maybe mod occ + | mod == gHC_TYPES + , isDataConNameSpace ns + , Just (k,n) <- (is_unboxed_sum_data_syntax fs) + = Just (unboxedSumDataConName k n) + where fs = occNameFS occ + ns = occNameSpace occ +isSumDataOrigName_maybe _ _ = Nothing + +{- +Note [Small Ints parsing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, tuples in Haskell have a maximum arity of 64. +To parse strings of length 1 and 2 more efficiently, we +can utilize an ad-hoc solution that matches their characters. +This results in a speedup of up to 40 times compared to using +`readMaybe @Int` on my machine. +-} + +mkTupleOcc :: NameSpace -> Boxity -> Arity -> (OccName, BuiltInSyntax) +mkTupleOcc ns b ar = (mkOccName ns str, built_in) + where (str, built_in) = mkTupleStr' ns b ar + +mkCTupleOcc :: NameSpace -> Arity -> OccName +mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) + +mkTupleStr :: Boxity -> NameSpace -> Arity -> String +mkTupleStr b ns ar = str + where (str, _) = mkTupleStr' ns b ar + +mkTupleStr' :: NameSpace -> Boxity -> Arity -> (String, BuiltInSyntax) +mkTupleStr' ns Boxed 0 + | isDataConNameSpace ns = ("()", BuiltInSyntax) + | otherwise = ("Unit", UserSyntax) +mkTupleStr' ns Boxed 1 + | isDataConNameSpace ns = ("MkSolo", UserSyntax) -- See Note [One-tuples] + | otherwise = ("Solo", UserSyntax) +mkTupleStr' ns Boxed ar + | isDataConNameSpace ns = ('(' : commas ar ++ ")", BuiltInSyntax) + | otherwise = ("Tuple" ++ showInt ar "", UserSyntax) +mkTupleStr' ns Unboxed 0 + | isDataConNameSpace ns = ("(##)", BuiltInSyntax) + | otherwise = ("Unit#", UserSyntax) +mkTupleStr' ns Unboxed 1 + | isDataConNameSpace ns = ("MkSolo#", UserSyntax) -- See Note [One-tuples] + | otherwise = ("Solo#", UserSyntax) +mkTupleStr' ns Unboxed ar + | isDataConNameSpace ns = ("(#" ++ commas ar ++ "#)", BuiltInSyntax) + | otherwise = ("Tuple" ++ show ar ++ "#", UserSyntax) + +mkConstraintTupleStr :: Arity -> String +mkConstraintTupleStr 0 = "CUnit" +mkConstraintTupleStr 1 = "CSolo" +mkConstraintTupleStr ar = "CTuple" ++ show ar + +commas :: Arity -> String +commas ar = replicate (ar-1) ',' + +cTupleTyCon :: Arity -> TyCon +cTupleTyCon i + | i > mAX_CTUPLE_SIZE = fstOf3 (mk_ctuple i) -- Build one specially + | otherwise = fstOf3 (cTupleArr ! i) + +cTupleTyConName :: Arity -> Name +cTupleTyConName a = tyConName (cTupleTyCon a) + +cTupleTyConNames :: [Name] +cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE]) + +cTupleTyConKeys :: UniqueSet +cTupleTyConKeys = fromListUniqueSet $ map getUnique cTupleTyConNames + +isCTupleTyConName :: Name -> Bool +isCTupleTyConName n + = assertPpr (isExternalName n) (ppr n) $ + getUnique n `memberUniqueSet` cTupleTyConKeys + +cTupleDataCon :: Arity -> DataCon +cTupleDataCon i + | i > mAX_CTUPLE_SIZE = sndOf3 (mk_ctuple i) -- Build one specially + | otherwise = sndOf3 (cTupleArr ! i) + +cTupleDataConName :: Arity -> Name +cTupleDataConName i = dataConName (cTupleDataCon i) + +cTupleDataConNames :: [Name] +cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE]) + +cTupleSelId :: ConTag -- Superclass position + -> Arity -- Arity + -> Id +cTupleSelId sc_pos arity + | sc_pos > arity + = panic ("cTupleSelId: index out of bounds: superclass position: " + ++ show sc_pos ++ " > arity " ++ show arity) + + | sc_pos <= 0 + = panic ("cTupleSelId: Superclass positions start from 1. " + ++ "(superclass position: " ++ show sc_pos + ++ ", arity: " ++ show arity ++ ")") + + | arity < 1 + = panic ("cTupleSelId: Arity starts from 1. " + ++ "(superclass position: " ++ show sc_pos + ++ ", arity: " ++ show arity ++ ")") + + | arity > mAX_CTUPLE_SIZE + = thdOf3 (mk_ctuple arity) ! (sc_pos - 1) -- Build one specially + + | otherwise + = thdOf3 (cTupleArr ! arity) ! (sc_pos - 1) + +cTupleSelIdName :: ConTag -- Superclass position + -> Arity -- Arity + -> Name +cTupleSelIdName sc_pos arity = idName (cTupleSelId sc_pos arity) + +tupleTyCon :: Boxity -> Arity -> TyCon +tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially +tupleTyCon Boxed i = fst (boxedTupleArr ! i) +tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) + +tupleTyConName :: TupleSort -> Arity -> Name +tupleTyConName ConstraintTuple a = cTupleTyConName a +tupleTyConName BoxedTuple a = tyConName (tupleTyCon Boxed a) +tupleTyConName UnboxedTuple a = tyConName (tupleTyCon Unboxed a) + +promotedTupleDataCon :: Boxity -> Arity -> TyCon +promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i) + +tupleDataCon :: Boxity -> Arity -> DataCon +tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially +tupleDataCon Boxed i = snd (boxedTupleArr ! i) +tupleDataCon Unboxed i = snd (unboxedTupleArr ! i) + +tupleDataConName :: Boxity -> Arity -> Name +tupleDataConName sort i = dataConName (tupleDataCon sort i) + +mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type +mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2] + +isPromotedPairType :: Type -> Maybe (Type, Type) +isPromotedPairType t + | Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t + , tc == promotedTupleDataCon Boxed 2 + = Just (x, y) + | otherwise = Nothing + +boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) +boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] + +-- | Cached type constructors, data constructors, and superclass selectors for +-- constraint tuples. The outer array is indexed by the arity of the constraint +-- tuple and the inner array is indexed by the superclass position. +cTupleArr :: Array Int (TyCon, DataCon, Array Int Id) +cTupleArr = listArray (0,mAX_CTUPLE_SIZE) [mk_ctuple i | i <- [0..mAX_CTUPLE_SIZE]] + +-- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed +-- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type +-- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep +-- [IntRep, LiftedRep])@ +unboxedTupleSumKind :: TyCon -> [Type] -> Kind +unboxedTupleSumKind tc rr_tys + = mkTYPEapp (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) + +-- | Specialization of 'unboxedTupleSumKind' for tuples +unboxedTupleKind :: [Type] -> Kind +unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon + +mk_tuple :: Boxity -> Int -> (TyCon,DataCon) +mk_tuple Boxed arity = (tycon, tuple_con) + where + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con + BoxedTuple flavour + + tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind) + tc_res_kind = liftedTypeKind + flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) + + dc_tvs = binderVars tc_binders + dc_arg_tys = mkTyVarTys dc_tvs + tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon + + boxity = Boxed + modu = gHC_INTERNAL_TUPLE + tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in + where (occ, built_in) = mkTupleOcc tcName boxity arity + dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in + where (occ, built_in) = mkTupleOcc dataName boxity arity + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity + +mk_tuple Unboxed arity = (tycon, tuple_con) + where + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con + UnboxedTuple flavour + + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> TYPE (TupleRep [k1, k2]) + tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) + (\ks -> map mkTYPEapp ks) + + tc_res_kind = unboxedTupleKind rr_tys + flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) + + dc_tvs = binderVars tc_binders + (rr_tvs, dc_arg_tvs) = splitAt arity dc_tvs + rr_tys = mkTyVarTys rr_tvs + dc_arg_tys = mkTyVarTys dc_arg_tvs + tuple_con = pcRepPolyDataCon dc_name dc_tvs conc_tvs dc_arg_tys tycon + conc_tvs = + mkNameEnv + [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedTuple pos) + | rr_tv <- rr_tvs + | ty <- dc_arg_tys + | pos <- [1..arity] ] + + boxity = Unboxed + modu = gHC_TYPES + tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in + where (occ, built_in) = mkTupleOcc tcName boxity arity + dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in + where (occ, built_in) = mkTupleOcc dataName boxity arity + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity + +mk_ctuple :: Arity -> (TyCon, DataCon, Array ConTagZ Id) +mk_ctuple arity = (tycon, tuple_con, sc_sel_ids_arr) + where + tycon = mkClassTyCon tc_name binders roles + rhs klass + (mkPrelTyConRepName tc_name) + + klass = mk_ctuple_class tycon sc_theta sc_sel_ids + tuple_con = pcDataConConstraint dc_name tvs sc_theta tycon + + binders = mkTemplateAnonTyConBinders (replicate arity constraintKind) + roles = replicate arity Nominal + rhs = TupleTyCon{data_con = tuple_con, tup_sort = ConstraintTuple} + + modu = gHC_CLASSES + tc_name = mkWiredInName modu (mkCTupleOcc tcName arity) tc_uniq + (ATyCon tycon) UserSyntax + dc_name = mkWiredInName modu (mkCTupleOcc dataName arity) dc_uniq + (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_uniq = mkCTupleTyConUnique arity + dc_uniq = mkCTupleDataConUnique arity + + tvs = binderVars binders + sc_theta = map mkTyVarTy tvs + sc_sel_ids = [mk_sc_sel_id sc_pos | sc_pos <- [0..arity-1]] + sc_sel_ids_arr = listArray (0,arity-1) sc_sel_ids + + mk_sc_sel_id sc_pos = + let sc_sel_id_uniq = mkCTupleSelIdUnique sc_pos arity + sc_sel_id_occ = mkCTupleOcc tcName arity + sc_sel_id_name = mkWiredInIdName + gHC_CLASSES + (occNameFS (mkSuperDictSelOcc sc_pos sc_sel_id_occ)) + sc_sel_id_uniq + sc_sel_id + sc_sel_id = mkDictSelId sc_sel_id_name klass + + in sc_sel_id + +unitTyCon :: TyCon +unitTyCon = tupleTyCon Boxed 0 + +unitTyConName :: Name +unitTyConName = tyConName unitTyCon + +unitTyConKey :: Unique +unitTyConKey = getUnique unitTyCon + +unitDataCon :: DataCon +unitDataCon = head (tyConDataCons unitTyCon) + +unitDataConId :: Id +unitDataConId = dataConWorkId unitDataCon + +soloTyCon :: TyCon +soloTyCon = tupleTyCon Boxed 1 + +soloTyConName :: Name +soloTyConName = tyConName soloTyCon + +soloDataConName :: Name +soloDataConName = tupleDataConName Boxed 1 + +pairTyCon :: TyCon +pairTyCon = tupleTyCon Boxed 2 + +unboxedUnitTy :: Type +unboxedUnitTy = mkTyConTy unboxedUnitTyCon + +unboxedUnitTyCon :: TyCon +unboxedUnitTyCon = tupleTyCon Unboxed 0 + +unboxedUnitTyConName :: Name +unboxedUnitTyConName = tyConName unboxedUnitTyCon + +unboxedUnitDataCon :: DataCon +unboxedUnitDataCon = tupleDataCon Unboxed 0 + +unboxedSoloTyCon :: TyCon +unboxedSoloTyCon = tupleTyCon Unboxed 1 + +unboxedSoloTyConName :: Name +unboxedSoloTyConName = tyConName unboxedSoloTyCon + +unboxedSoloDataConName :: Name +unboxedSoloDataConName = tupleDataConName Unboxed 1 + +{- ********************************************************************* +* * + Unboxed sums +* * +********************************************************************* -} + +-- | OccName for n-ary unboxed sum type constructor. +mkSumTyConOcc :: Arity -> OccName +mkSumTyConOcc n = mkOccName tcName str + where + -- No need to cache these, the caching is done in mk_sum + str = "Sum" ++ show n ++ "#" + +-- | OccName for i-th alternative of n-ary unboxed sum data constructor. +mkSumDataConOcc :: ConTag -> Arity -> OccName +mkSumDataConOcc alt n = mkOccName dataName str + where + -- No need to cache these, the caching is done in mk_sum + str = '(' : '#' : ' ' : bars alt ++ '_' : bars (n - alt - 1) ++ " #)" + bars i = intersperse ' ' $ replicate i '|' + +-- | Type constructor for n-ary unboxed sum. +sumTyCon :: Arity -> TyCon +sumTyCon arity + | arity > mAX_SUM_SIZE + = fst (mk_sum arity) -- Build one specially + + | arity < 2 + = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")") + + | otherwise + = fst (unboxedSumArr ! arity) + +unboxedSumTyConName :: Arity -> Name +unboxedSumTyConName arity = tyConName (sumTyCon arity) + +-- | Data constructor for i-th alternative of a n-ary unboxed sum. +sumDataCon :: ConTag -- Alternative + -> Arity -- Arity + -> DataCon +sumDataCon alt arity + | alt > arity + = panic ("sumDataCon: index out of bounds: alt: " + ++ show alt ++ " > arity " ++ show arity) + + | alt <= 0 + = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt + ++ ", arity: " ++ show arity ++ ")") + + | arity < 2 + = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt + ++ ", arity: " ++ show arity ++ ")") + + | arity > mAX_SUM_SIZE + = snd (mk_sum arity) ! (alt - 1) -- Build one specially + + | otherwise + = snd (unboxedSumArr ! arity) ! (alt - 1) + +unboxedSumDataConName :: ConTag -> Arity -> Name +unboxedSumDataConName alt arity = dataConName (sumDataCon alt arity) + +-- | Cached type and data constructors for sums. The outer array is +-- indexed by the arity of the sum and the inner array is indexed by +-- the alternative. +unboxedSumArr :: Array Int (TyCon, Array Int DataCon) +unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]] + +-- | Specialization of 'unboxedTupleSumKind' for sums +unboxedSumKind :: [Type] -> Kind +unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon + +-- | Create type constructor and data constructors for n-ary unboxed sum. +mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) +mk_sum arity = (tycon, sum_cons) + where + tycon = mkSumTyCon tc_name tc_binders tc_res_kind (elems sum_cons) + UnboxedSumTyCon + + tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) + (\ks -> map mkTYPEapp ks) + + tyvars = binderVars tc_binders + + tc_res_kind = unboxedSumKind rr_tys + + (rr_tvs, dc_arg_tvs) = splitAt arity tyvars + rr_tys = mkTyVarTys rr_tvs + dc_arg_tys = mkTyVarTys dc_arg_tvs + + conc_tvs = + mkNameEnv + [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedSum (Just pos)) + | rr_tv <- rr_tvs + | ty <- dc_arg_tys + | pos <- [1..arity] ] + + tc_name = mkWiredInName gHC_TYPES (mkSumTyConOcc arity) tc_uniq + (ATyCon tycon) UserSyntax + + sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]] + sum_con i = + let dc = pcRepPolyDataCon dc_name + tyvars -- univ tyvars + conc_tvs + [dc_arg_tys !! i] -- arg types + tycon + + dc_name = mkWiredInName gHC_TYPES + (mkSumDataConOcc i arity) + (dc_uniq i) + (AConLike (RealDataCon dc)) + BuiltInSyntax + in dc + + tc_uniq = mkSumTyConUnique arity + dc_uniq i = mkSumDataConUnique i arity + +{- +************************************************************************ +* * + Equality types and classes +* * +********************************************************************* -} + +-- See Note [The equality types story] in GHC.Builtin.Types.Prim +-- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint) +-- +-- It's tempting to put functional dependencies on (~~), but it's not +-- necessary because the functional-dependency coverage check looks +-- through superclasses, and (~#) is handled in that check. + +eqTyCon, heqTyCon, coercibleTyCon :: TyCon +eqClass, heqClass, coercibleClass :: Class +eqDataCon, heqDataCon, coercibleDataCon :: DataCon +eqSCSelId, heqSCSelId, coercibleSCSelId :: Id + +(eqTyCon, eqClass, eqDataCon, eqSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon eqTyConName binders roles + rhs klass + (mkPrelTyConRepName eqTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataConConstraint eqDataConName tvs [sc_pred] tycon + + -- Kind: forall k. k -> k -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) + roles = [Nominal, Nominal, Nominal] + rhs = mkDataTyConRhs [datacon] + -- rhs: a DataTyCon, not a UnaryClassTyCon! Yes it has one + -- field, but it has unboxed type (a ~# b), + -- so the class must provide the box. + + tvs@[k,a,b] = binderVars binders + sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b]) + sc_sel_id = mkDictSelId eqSCSelIdName klass + +(heqTyCon, heqClass, heqDataCon, heqSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon heqTyConName binders roles + rhs klass + (mkPrelTyConRepName heqTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataConConstraint heqDataConName tvs [sc_pred] tycon + + -- Kind: forall k1 k2. k1 -> k2 -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + roles = [Nominal, Nominal, Nominal, Nominal] + rhs = mkDataTyConRhs [datacon] + + tvs = binderVars binders + sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs) + sc_sel_id = mkDictSelId heqSCSelIdName klass + +(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon coercibleTyConName binders roles + rhs klass + (mkPrelTyConRepName coercibleTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataConConstraint coercibleDataConName tvs [sc_pred] tycon + + -- Kind: forall k. k -> k -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) + roles = [Nominal, Representational, Representational] + rhs = mkDataTyConRhs [datacon] + + tvs@[k,a,b] = binderVars binders + sc_pred = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b]) + sc_sel_id = mkDictSelId coercibleSCSelIdName klass + +mk_class :: TyCon -> PredType -> Id -> Class +mk_class tycon sc_pred sc_sel_id + = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id] + [] [] (mkAnd []) tycon + +mk_ctuple_class :: TyCon -> ThetaType -> [Id] -> Class +mk_ctuple_class tycon sc_theta sc_sel_ids + = mkClass (tyConName tycon) (tyConTyVars tycon) [] sc_theta sc_sel_ids + [] [] (mkAnd []) tycon + +{- ********************************************************************* +* * + Multiplicity Polymorphism +* * +********************************************************************* -} + +{- Multiplicity polymorphism is implemented very similarly to representation + polymorphism. We write in the multiplicity kind and the One and Many + types which can appear in user programs. These are defined properly in GHC.Types. + +data Multiplicity = One | Many +-} + +multiplicityTyConName :: Name +multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity") + multiplicityTyConKey multiplicityTyCon + +oneDataConName, manyDataConName :: Name +oneDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon +manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon + +multiplicityTy :: Type +multiplicityTy = mkTyConTy multiplicityTyCon + +multiplicityTyCon :: TyCon +multiplicityTyCon = pcTyCon multiplicityTyConName Nothing [] + [oneDataCon, manyDataCon] + +oneDataCon, manyDataCon :: DataCon +oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon +manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon + +oneDataConTy, manyDataConTy :: Type +oneDataConTy = mkTyConTy oneDataConTyCon +manyDataConTy = mkTyConTy manyDataConTyCon + +oneDataConTyCon, manyDataConTyCon :: TyCon +oneDataConTyCon = promoteDataCon oneDataCon +manyDataConTyCon = promoteDataCon manyDataCon + +multMulTyConName :: Name +multMulTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "MultMul") multMulTyConKey multMulTyCon + +multMulTyCon :: TyCon +multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing + (BuiltInSynFamTyCon trivialBuiltInFamily) + Nothing + NotInjective + where + binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy] + +------------------------ +-- type (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). +-- TYPE rep1 -> TYPE rep2 -> Type +-- type (->) = FUN 'Many +unrestrictedFunTyCon :: TyCon +unrestrictedFunTyCon + = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] + (TyCoRep.TyConApp fUNTyCon [manyDataConTy]) + where + arrowKind = mkTyConKind binders liftedTypeKind + -- See also funTyCon + binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred) + , Bndr runtimeRep2TyVar (NamedTCB Inferred) ] + ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty + , mkTYPEapp runtimeRep2Ty ] + +unrestrictedFunTyConName :: Name +unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->") + unrestrictedFunTyConKey unrestrictedFunTyCon + + +{- ********************************************************************* +* * + Type synonyms (all declared in ghc-prim:GHC.Types) + + type CONSTRAINT :: RuntimeRep -> Type -- primitive; cONSTRAINTKind + type Constraint = CONSTRAINT LiftedRep :: Type -- constraintKind + + type TYPE :: RuntimeRep -> Type -- primitive; tYPEKind + type Type = TYPE LiftedRep :: Type -- liftedTypeKind + type UnliftedType = TYPE UnliftedRep :: Type -- unliftedTypeKind + + type LiftedRep = BoxedRep Lifted :: RuntimeRep -- liftedRepTy + type UnliftedRep = BoxedRep Unlifted :: RuntimeRep -- unliftedRepTy + +* * +********************************************************************* -} + +-- For these synonyms, see +-- Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim, and +-- Note [Using synonyms to compress types] in GHC.Core.Type + +{- Note [Naked FunTy] +~~~~~~~~~~~~~~~~~~~~~ +GHC.Core.TyCo.Rep.mkFunTy has assertions about the consistency of the argument +flag and arg/res types. But when constructing the kinds of tYPETyCon and +cONSTRAINTTyCon we don't want to make these checks because + TYPE :: RuntimeRep -> Type +i.e. TYPE :: RuntimeRep -> TYPE LiftedRep + +so the check will loop infinitely. Hence the use of a naked FunTy +constructor in tTYPETyCon and cONSTRAINTTyCon. +-} + + +---------------------- +-- type Constraint = CONSTRAINT LiftedRep +constraintKindTyCon :: TyCon +constraintKindTyCon + = buildSynTyCon constraintKindTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp cONSTRAINTTyCon [liftedRepTy] + +constraintKindTyConName :: Name +constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") + constraintKindTyConKey constraintKindTyCon + +constraintKind :: Kind +constraintKind = mkTyConTy constraintKindTyCon + +---------------------- +-- type Type = TYPE LiftedRep +liftedTypeKindTyCon :: TyCon +liftedTypeKindTyCon + = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy] + +liftedTypeKindTyConName :: Name +liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") + liftedTypeKindTyConKey liftedTypeKindTyCon + +liftedTypeKind, typeToTypeKind :: Type +liftedTypeKind = mkTyConTy liftedTypeKindTyCon +typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind + +---------------------- +-- type UnliftedType = TYPE ('BoxedRep 'Unlifted) +unliftedTypeKindTyCon :: TyCon +unliftedTypeKindTyCon + = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy] + +unliftedTypeKindTyConName :: Name +unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") + unliftedTypeKindTyConKey unliftedTypeKindTyCon + +unliftedTypeKind :: Type +unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon + + +{- ********************************************************************* +* * + data Levity = Lifted | Unlifted +* * +********************************************************************* -} + +levityTyConName, liftedDataConName, unliftedDataConName :: Name +levityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Levity") levityTyConKey levityTyCon +liftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted") liftedDataConKey liftedDataCon +unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon + +levityTyCon :: TyCon +levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon] + +levityTy :: Type +levityTy = mkTyConTy levityTyCon + +liftedDataCon, unliftedDataCon :: DataCon +liftedDataCon = pcSpecialDataCon liftedDataConName + [] levityTyCon (Levity Lifted) +unliftedDataCon = pcSpecialDataCon unliftedDataConName + [] levityTyCon (Levity Unlifted) + +liftedDataConTyCon :: TyCon +liftedDataConTyCon = promoteDataCon liftedDataCon + +unliftedDataConTyCon :: TyCon +unliftedDataConTyCon = promoteDataCon unliftedDataCon + +liftedDataConTy :: Type +liftedDataConTy = mkTyConTy liftedDataConTyCon + +unliftedDataConTy :: Type +unliftedDataConTy = mkTyConTy unliftedDataConTyCon + + +{- ********************************************************************* +* * + See Note [Wiring in RuntimeRep] + data RuntimeRep = VecRep VecCount VecElem + | TupleRep [RuntimeRep] + | SumRep [RuntimeRep] + | BoxedRep Levity + | IntRep | Int8Rep | ...etc... +* * +********************************************************************* -} + +{- Note [Wiring in RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors, +making it a pain to wire in. To ease the pain somewhat, we use lists of +the different bits, like Uniques, Names, DataCons. These lists must be +kept in sync with each other. The rule is this: use the order as declared +in GHC.Types. All places where such lists exist should contain a reference +to this Note, so a search for this Note's name should find all the lists. + +See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType. +-} + +runtimeRepTyCon :: TyCon +runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] + -- Here we list all the data constructors + -- of the RuntimeRep data type + (vecRepDataCon : tupleRepDataCon : + sumRepDataCon : boxedRepDataCon : + runtimeRepSimpleDataCons) + +runtimeRepTy :: Type +runtimeRepTy = mkTyConTy runtimeRepTyCon + +runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name +runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon + +vecRepDataConName = mk_runtime_rep_dc_name (fsLit "VecRep") vecRepDataConKey vecRepDataCon +tupleRepDataConName = mk_runtime_rep_dc_name (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon +sumRepDataConName = mk_runtime_rep_dc_name (fsLit "SumRep") sumRepDataConKey sumRepDataCon +boxedRepDataConName = mk_runtime_rep_dc_name (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon + +mk_runtime_rep_dc_name :: FastString -> Unique -> DataCon -> Name +mk_runtime_rep_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc + +boxedRepDataCon :: DataCon +boxedRepDataCon = pcSpecialDataCon boxedRepDataConName + [ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in RepType + prim_rep_fun [lev] + = case tyConAppTyCon_maybe lev of + Just tc -> case tyConPromDataConInfo tc of + Levity l -> [BoxedRep (Just l)] + _ -> [BoxedRep Nothing] + Nothing -> [BoxedRep Nothing] + prim_rep_fun args + = pprPanic "boxedRepDataCon" (ppr args) + + +boxedRepDataConTyCon :: TyCon +boxedRepDataConTyCon = promoteDataCon boxedRepDataCon + +tupleRepDataCon :: DataCon +tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] + runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType + prim_rep_fun [rr_ty_list] + = concatMap (runtimeRepPrimRep doc) rr_tys + where + rr_tys = extractPromotedList rr_ty_list + doc = text "tupleRepDataCon" <+> ppr rr_tys + prim_rep_fun args + = pprPanic "tupleRepDataCon" (ppr args) + +tupleRepDataConTyCon :: TyCon +tupleRepDataConTyCon = promoteDataCon tupleRepDataCon + +sumRepDataCon :: DataCon +sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] + runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType + prim_rep_fun [rr_ty_list] + = map slotPrimRep (toList (ubxSumRepType prim_repss)) + where + rr_tys = extractPromotedList rr_ty_list + doc = text "sumRepDataCon" <+> ppr rr_tys + prim_repss = map (runtimeRepPrimRep doc) rr_tys + prim_rep_fun args + = pprPanic "sumRepDataCon" (ppr args) + +sumRepDataConTyCon :: TyCon +sumRepDataConTyCon = promoteDataCon sumRepDataCon + +-- See Note [Wiring in RuntimeRep] +-- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType +runtimeRepSimpleDataCons :: [DataCon] +runtimeRepSimpleDataCons + = zipWith mk_runtime_rep_dc runtimeRepSimpleDataConKeys + [ (fsLit "IntRep", IntRep) + , (fsLit "Int8Rep", Int8Rep) + , (fsLit "Int16Rep", Int16Rep) + , (fsLit "Int32Rep", Int32Rep) + , (fsLit "Int64Rep", Int64Rep) + , (fsLit "WordRep", WordRep) + , (fsLit "Word8Rep", Word8Rep) + , (fsLit "Word16Rep", Word16Rep) + , (fsLit "Word32Rep", Word32Rep) + , (fsLit "Word64Rep", Word64Rep) + , (fsLit "AddrRep", AddrRep) + , (fsLit "FloatRep", FloatRep) + , (fsLit "DoubleRep", DoubleRep) ] + where + mk_runtime_rep_dc :: Unique -> (FastString, PrimRep) -> DataCon + mk_runtime_rep_dc uniq (fs, primrep) + = data_con + where + data_con = pcSpecialDataCon dc_name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) + dc_name = mk_runtime_rep_dc_name fs uniq data_con + +-- See Note [Wiring in RuntimeRep] +intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType +[intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy + ] + = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons + +---------------------- +-- | @type ZeroBitRep = 'Tuple '[] +zeroBitRepTyCon :: TyCon +zeroBitRepTyCon + = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] + +zeroBitRepTyConName :: Name +zeroBitRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep") + zeroBitRepTyConKey zeroBitRepTyCon + +zeroBitRepTy :: RuntimeRepType +zeroBitRepTy = mkTyConTy zeroBitRepTyCon + +---------------------- +-- @type ZeroBitType = TYPE ZeroBitRep +zeroBitTypeTyCon :: TyCon +zeroBitTypeTyCon + = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy] + +zeroBitTypeTyConName :: Name +zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType") + zeroBitTypeTyConKey zeroBitTypeTyCon + +zeroBitTypeKind :: Type +zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon + +---------------------- +-- | @type LiftedRep = 'BoxedRep 'Lifted@ +liftedRepTyCon :: TyCon +liftedRepTyCon + = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy] + +liftedRepTyConName :: Name +liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") + liftedRepTyConKey liftedRepTyCon + +liftedRepTy :: RuntimeRepType +liftedRepTy = mkTyConTy liftedRepTyCon + +---------------------- +-- | @type UnliftedRep = 'BoxedRep 'Unlifted@ +unliftedRepTyCon :: TyCon +unliftedRepTyCon + = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy] + +unliftedRepTyConName :: Name +unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") + unliftedRepTyConKey unliftedRepTyCon + +unliftedRepTy :: RuntimeRepType +unliftedRepTy = mkTyConTy unliftedRepTyCon + + +{- ********************************************************************* +* * + VecCount, VecElem +* * +********************************************************************* -} + +vecCountTyConName :: Name +vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon + +vecElemTyConName :: Name +vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon + +vecRepDataCon :: DataCon +vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon + , mkTyConTy vecElemTyCon ] + runtimeRepTyCon + (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType + prim_rep_fun [count, elem] + | VecCount n <- tyConPromDataConInfo (tyConAppTyCon count) + , VecElem e <- tyConPromDataConInfo (tyConAppTyCon elem) + = [VecRep n e] + prim_rep_fun args + = pprPanic "vecRepDataCon" (ppr args) + +vecRepDataConTyCon :: TyCon +vecRepDataConTyCon = promoteDataCon vecRepDataCon + +vecCountTyCon :: TyCon +vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons + +-- See Note [Wiring in RuntimeRep] +vecCountDataCons :: [DataCon] +vecCountDataCons = zipWith mk_vec_count_dc [1..6] vecCountDataConKeys + where + mk_vec_count_dc logN key = con + where + n = 2^(logN :: Int) + name = mk_runtime_rep_dc_name (fsLit ("Vec" ++ show n)) key con + con = pcSpecialDataCon name [] vecCountTyCon (VecCount n) + +-- See Note [Wiring in RuntimeRep] +vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy :: Type +[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons + +vecElemTyCon :: TyCon +vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons + +-- See Note [Wiring in RuntimeRep] +vecElemDataCons :: [DataCon] +vecElemDataCons = zipWith3 mk_vec_elem_dc + [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep", fsLit "Int64ElemRep" + , fsLit "Word8ElemRep", fsLit "Word16ElemRep", fsLit "Word32ElemRep", fsLit "Word64ElemRep" + , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] + [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep + , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep + , FloatElemRep, DoubleElemRep ] + vecElemDataConKeys + where + mk_vec_elem_dc nameFs elemRep key = con + where + name = mk_runtime_rep_dc_name nameFs key con + con = pcSpecialDataCon name [] vecElemTyCon (VecElem elemRep) + +-- See Note [Wiring in RuntimeRep] +int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy :: Type +[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) + vecElemDataCons + +{- ********************************************************************* +* * + The boxed primitive types: Char, Int, etc +* * +********************************************************************* -} + +charTy :: Type +charTy = mkTyConTy charTyCon + +charTyCon :: TyCon +charTyCon = pcTyCon charTyConName + (Just (CType NoSourceText Nothing + (NoSourceText,fsLit "HsChar"))) + [] [charDataCon] +charDataCon :: DataCon +charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon + +stringTy :: Type +stringTy = mkTyConTy stringTyCon + +stringTyCon :: TyCon +-- We have this wired-in so that Haskell literal strings +-- get type String (in hsLitType), which in turn influences +-- inferred types and error messages +stringTyCon = buildSynTyCon stringTyConName + [] liftedTypeKind [] + (mkListTy charTy) + +intTy :: Type +intTy = mkTyConTy intTyCon + +intTyCon :: TyCon +intTyCon = pcTyCon intTyConName + (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt"))) + [] [intDataCon] +intDataCon :: DataCon +intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon + +wordTy :: Type +wordTy = mkTyConTy wordTyCon + +wordTyCon :: TyCon +wordTyCon = pcTyCon wordTyConName + (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord"))) + [] [wordDataCon] +wordDataCon :: DataCon +wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon + +word8Ty :: Type +word8Ty = mkTyConTy word8TyCon + +word8TyCon :: TyCon +word8TyCon = pcTyCon word8TyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsWord8"))) [] + [word8DataCon] +word8DataCon :: DataCon +word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon + +floatTy :: Type +floatTy = mkTyConTy floatTyCon + +floatTyCon :: TyCon +floatTyCon = pcTyCon floatTyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsFloat"))) [] + [floatDataCon] +floatDataCon :: DataCon +floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon + +doubleTy :: Type +doubleTy = mkTyConTy doubleTyCon + +doubleTyCon :: TyCon +doubleTyCon = pcTyCon doubleTyConName + (Just (CType NoSourceText Nothing + (NoSourceText,fsLit "HsDouble"))) [] + [doubleDataCon] + +doubleDataCon :: DataCon +doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon + +{- ********************************************************************* +* * + Boxing data constructors +* * +********************************************************************* -} + +{- Note [Boxing constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In ghc-prim:GHC.Types we have a family of data types, one for each RuntimeRep +that "box" unlifted values into a (boxed, lifted) value of kind Type. For example + + type Int8Box :: TYPE Int8Rep -> Type + data Int8Box (a :: TYPE Int8Rep) = MkInt8Box a + -- MkInt8Box :: forall (a :: TYPE Int8Rep). a -> Int8Box a + +Then we can package an `Int8#` into an `Int8Box` with `MkInt8Box`. We can also +package up a (lifted) Constraint as a value of kind Type. + +There are a fixed number of RuntimeReps, so we only need a fixed number +of boxing types. (For TupleRep we need to box recursively; not yet done, +see #22336.) + +This is used: + +* In desugaring, when we need to package up a bunch of values into a tuple, + for example when desugaring arrows. See Note [Big tuples] in GHC.Core.Make. + +* In let-floating when we want to float an unlifted sub-expression. + See Note [Floating MFEs of unlifted type] in GHC.Core.Opt.SetLevels + +In this module we make wired-in data type declarations for all of +these boxing functions. The goal is to define boxingDataCon_maybe. + +Wrinkles +(W1) The runtime system has special treatment (e.g. commoning up during GC) + for Int and Char values. See Note [CHARLIKE and INTLIKE closures] and + Note [Precomputed static closures] in the RTS. + + So we treat Int# and Char# specially, in specialBoxingDataCon_maybe +-} + +data BoxingInfo b + = BI_NoBoxNeeded -- The type has kind Type, so there is nothing to do + + | BI_NoBoxAvailable -- The type does not have kind Type, but sadly we + -- don't have a boxing data constructor either + + | BI_Box -- The type does not have kind Type, and we do have a + -- boxing data constructor; here it is + { bi_data_con :: DataCon + , bi_inst_con :: Expr b + , bi_boxed_type :: Type } + -- e.g. BI_Box { bi_data_con = I#, bi_inst_con = I#, bi_boxed_type = Int } + -- recall: data Int = I# Int# + -- + -- BI_Box { bi_data_con = MkInt8Box, bi_inst_con = MkInt8Box @ty + -- , bi_boxed_type = Int8Box ty } + -- recall: data Int8Box (a :: TYPE Int8Rep) = MkIntBox a + +boxingDataCon :: Type -> BoxingInfo b +-- ^ Given a type 'ty', if 'ty' is not of kind Type, return a data constructor that +-- will box it, and the type of the boxed thing, which /does/ now have kind Type. +-- See Note [Boxing constructors] +boxingDataCon ty + | tcIsLiftedTypeKind kind + = BI_NoBoxNeeded -- Fast path for Type + + | Just box_con <- specialBoxingDataCon_maybe ty + = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [] + , bi_boxed_type = tyConNullaryTy (dataConTyCon box_con) } + + | Just box_con <- lookupTypeMap boxingDataConMap kind + = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [Type ty] + , bi_boxed_type = mkTyConApp (dataConTyCon box_con) [ty] } + + | otherwise + = BI_NoBoxAvailable + + where + kind = typeKind ty + +specialBoxingDataCon_maybe :: Type -> Maybe DataCon +-- ^ See Note [Boxing constructors] wrinkle (W1) +specialBoxingDataCon_maybe ty + = case splitTyConApp_maybe ty of + Just (tc, _) | tc `hasKey` intPrimTyConKey -> Just intDataCon + | tc `hasKey` charPrimTyConKey -> Just charDataCon + _ -> Nothing + +boxingDataConMap :: TypeMap DataCon +-- See Note [Boxing constructors] +boxingDataConMap = foldl add emptyTypeMap boxingDataCons + where + add bdcm (kind, boxing_con) = extendTypeMap bdcm kind boxing_con + +boxingDataCons :: [(Kind, DataCon)] +-- The Kind is the kind of types for which the DataCon is the right boxing +boxingDataCons = zipWith mkBoxingDataCon + (map mkBoxingTyConUnique [1..]) + [ (mkTYPEapp wordRepDataConTy, fsLit "WordBox", fsLit "MkWordBox") + , (mkTYPEapp intRepDataConTy, fsLit "IntBox", fsLit "MkIntBox") + + , (mkTYPEapp floatRepDataConTy, fsLit "FloatBox", fsLit "MkFloatBox") + , (mkTYPEapp doubleRepDataConTy, fsLit "DoubleBox", fsLit "MkDoubleBox") + + , (mkTYPEapp int8RepDataConTy, fsLit "Int8Box", fsLit "MkInt8Box") + , (mkTYPEapp int16RepDataConTy, fsLit "Int16Box", fsLit "MkInt16Box") + , (mkTYPEapp int32RepDataConTy, fsLit "Int32Box", fsLit "MkInt32Box") + , (mkTYPEapp int64RepDataConTy, fsLit "Int64Box", fsLit "MkInt64Box") + + , (mkTYPEapp word8RepDataConTy, fsLit "Word8Box", fsLit "MkWord8Box") + , (mkTYPEapp word16RepDataConTy, fsLit "Word16Box", fsLit "MkWord16Box") + , (mkTYPEapp word32RepDataConTy, fsLit "Word32Box", fsLit "MkWord32Box") + , (mkTYPEapp word64RepDataConTy, fsLit "Word64Box", fsLit "MkWord64Box") + + , (unliftedTypeKind, fsLit "LiftBox", fsLit "MkLiftBox") + , (constraintKind, fsLit "DictBox", fsLit "MkDictBox") ] + +mkBoxingDataCon :: Unique -> (Kind, FastString, FastString) -> (Kind, DataCon) +mkBoxingDataCon uniq_tc (kind, fs_tc, fs_dc) + = (kind, dc) + where + uniq_dc = boxingDataConUnique uniq_tc + + (tv:_) = mkTemplateTyVars (repeat kind) + tc = pcTyCon tc_name Nothing [tv] [dc] + tc_name = mkWiredInTyConName UserSyntax gHC_TYPES fs_tc uniq_tc tc + + dc | isConstraintKind kind + = pcDataConConstraint dc_name [tv] [mkTyVarTy tv] tc + | otherwise + = pcDataCon dc_name [tv] [mkTyVarTy tv] tc + dc_name = mkWiredInDataConName UserSyntax gHC_TYPES fs_dc uniq_dc dc + +{- +************************************************************************ +* * + The Bool type +* * +************************************************************************ + +An ordinary enumeration type, but deeply wired in. There are no +magical operations on @Bool@ (just the regular Prelude code). + +{\em BEGIN IDLE SPECULATION BY SIMON} + +This is not the only way to encode @Bool@. A more obvious coding makes +@Bool@ just a boxed up version of @Bool#@, like this: +\begin{verbatim} +type Bool# = Int# +data Bool = MkBool Bool# +\end{verbatim} + +Unfortunately, this doesn't correspond to what the Report says @Bool@ +looks like! Furthermore, we get slightly less efficient code (I +think) with this coding. @gtInt@ would look like this: + +\begin{verbatim} +gtInt :: Int -> Int -> Bool +gtInt x y = case x of I# x# -> + case y of I# y# -> + case (gtIntPrim x# y#) of + b# -> MkBool b# +\end{verbatim} + +Notice that the result of the @gtIntPrim@ comparison has to be turned +into an integer (here called @b#@), and returned in a @MkBool@ box. + +The @if@ expression would compile to this: +\begin{verbatim} +case (gtInt x y) of + MkBool b# -> case b# of { 1# -> e1; 0# -> e2 } +\end{verbatim} + +I think this code is a little less efficient than the previous code, +but I'm not certain. At all events, corresponding with the Report is +important. The interesting thing is that the language is expressive +enough to describe more than one alternative; and that a type doesn't +necessarily need to be a straightforwardly boxed version of its +primitive counterpart. + +{\em END IDLE SPECULATION BY SIMON} +-} + +boolTy :: Type +boolTy = mkTyConTy boolTyCon + +boolTyCon :: TyCon +boolTyCon = pcTyCon boolTyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsBool"))) + [] [falseDataCon, trueDataCon] + +falseDataCon, trueDataCon :: DataCon +falseDataCon = pcDataCon falseDataConName [] [] boolTyCon +trueDataCon = pcDataCon trueDataConName [] [] boolTyCon + +falseDataConId, trueDataConId :: Id +falseDataConId = dataConWorkId falseDataCon +trueDataConId = dataConWorkId trueDataCon + +orderingTyCon :: TyCon +orderingTyCon = pcTyCon orderingTyConName Nothing + [] [ordLTDataCon, ordEQDataCon, ordGTDataCon] + +ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon +ordLTDataCon = pcDataCon ordLTDataConName [] [] orderingTyCon +ordEQDataCon = pcDataCon ordEQDataConName [] [] orderingTyCon +ordGTDataCon = pcDataCon ordGTDataConName [] [] orderingTyCon + +ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id +ordLTDataConId = dataConWorkId ordLTDataCon +ordEQDataConId = dataConWorkId ordEQDataCon +ordGTDataConId = dataConWorkId ordGTDataCon + +{- +************************************************************************ +* * + The List type + Special syntax, deeply wired in, + but otherwise an ordinary algebraic data type +* * +************************************************************************ + + data [] a = [] | a : (List a) +-} + +mkListTy :: Type -> Type +mkListTy ty = mkTyConApp listTyCon [ty] + +listTyCon :: TyCon +listTyCon = pcTyCon listTyConName Nothing [alphaTyVar] [nilDataCon, consDataCon] + +-- See also Note [Empty lists] in GHC.Hs.Expr. +nilDataCon :: DataCon +nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon + +consDataCon :: DataCon +consDataCon = pcDataConWithFixity True {- Declared infix -} + consDataConName + alpha_tyvar [] noConcreteTyVars alpha_tyvar [] + (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) + listTyCon + +-- Interesting: polymorphic recursion would help here. +-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy +-- gets the over-specific type (Type -> Type) + +-- Wired-in type Maybe + +maybeTyCon :: TyCon +maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar + [nothingDataCon, justDataCon] + +nothingDataCon :: DataCon +nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon + +justDataCon :: DataCon +justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon + +mkPromotedMaybeTy :: Kind -> Maybe Type -> Type +mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x] +mkPromotedMaybeTy k Nothing = mkTyConApp promotedNothingDataCon [k] + +mkMaybeTy :: Type -> Kind +mkMaybeTy t = mkTyConApp maybeTyCon [t] + +isPromotedMaybeTy :: Type -> Maybe (Maybe Type) +isPromotedMaybeTy t + | Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x + | Just (tc,[_]) <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing + | otherwise = Nothing + + +{- +** ********************************************************************* +* * + The tuple types +* * +************************************************************************ + +The tuple types are definitely magic, because they form an infinite +family. + +\begin{itemize} +\item +They have a special family of type constructors, of type @TyCon@ +These contain the tycon arity, but don't require a Unique. + +\item +They have a special family of constructors, of type +@Id@. Again these contain their arity but don't need a Unique. + +\item +There should be a magic way of generating the info tables and +entry code for all tuples. + +But at the moment we just compile a Haskell source +file\srcloc{lib/prelude/...} containing declarations like: +\begin{verbatim} +data Tuple0 = Tup0 +data Tuple2 a b = Tup2 a b +data Tuple3 a b c = Tup3 a b c +data Tuple4 a b c d = Tup4 a b c d +... +\end{verbatim} +The print-names associated with the magic @Id@s for tuple constructors +``just happen'' to be the same as those generated by these +declarations. + +\item +The instance environment should have a magic way to know +that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and +so on. \ToDo{Not implemented yet.} + +\item +There should also be a way to generate the appropriate code for each +of these instances, but (like the info tables and entry code) it is +done by enumeration\srcloc{lib/prelude/InTup?.hs}. +\end{itemize} +-} + +-- | Make a tuple type. The list of types should /not/ include any +-- RuntimeRep specifications. Boxed 1-tuples are flattened. +-- See Note [One-tuples] +mkTupleTy :: Boxity -> [Type] -> Type +-- Special case for *boxed* 1-tuples, which are represented by the type itself +mkTupleTy Boxed [ty] = ty +mkTupleTy boxity tys = mkTupleTy1 boxity tys + +-- | Make a tuple type. The list of types should /not/ include any +-- RuntimeRep specifications. Boxed 1-tuples are *not* flattened. +-- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn] +-- in "GHC.Core.Make" +mkTupleTy1 :: Boxity -> [Type] -> Type +mkTupleTy1 Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys +mkTupleTy1 Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys)) + (map getRuntimeRep tys ++ tys) + +-- | Build the type of a small tuple that holds the specified type of thing +-- Flattens 1-tuples. See Note [One-tuples]. +mkBoxedTupleTy :: [Type] -> Type +mkBoxedTupleTy tys = mkTupleTy Boxed tys + +unitTy :: Type +unitTy = mkTupleTy Boxed [] + +-- Make a constraint tuple, flattening a 1-tuple as usual +-- If we get a constraint tuple that is bigger than the pre-built +-- ones (in ghc-prim:GHC.Tuple), then just make one up anyway; it won't +-- have an info table in the RTS, so we can't use it at runtime. But +-- this is used only in filling in extra-constraint wildcards, so it +-- never is used at runtime anyway +-- See GHC.Tc.Gen.HsType Note [Extra-constraint holes in partial type signatures] +mkConstraintTupleTy :: [Type] -> Type +mkConstraintTupleTy [ty] = ty +mkConstraintTupleTy tys = mkTyConApp (cTupleTyCon (length tys)) tys + + +{- ********************************************************************* +* * + The sum types +* * +************************************************************************ +-} + +mkSumTy :: [Type] -> Type +mkSumTy tys = mkTyConApp (sumTyCon (length tys)) + (map getRuntimeRep tys ++ tys) + +-- Promoted Booleans + +promotedFalseDataCon, promotedTrueDataCon :: TyCon +promotedTrueDataCon = promoteDataCon trueDataCon +promotedFalseDataCon = promoteDataCon falseDataCon + +-- Promoted Maybe +promotedNothingDataCon, promotedJustDataCon :: TyCon +promotedNothingDataCon = promoteDataCon nothingDataCon +promotedJustDataCon = promoteDataCon justDataCon + +-- Promoted Ordering + +promotedLTDataCon + , promotedEQDataCon + , promotedGTDataCon + :: TyCon +promotedLTDataCon = promoteDataCon ordLTDataCon +promotedEQDataCon = promoteDataCon ordEQDataCon +promotedGTDataCon = promoteDataCon ordGTDataCon + +-- Promoted List +promotedConsDataCon, promotedNilDataCon :: TyCon +promotedConsDataCon = promoteDataCon consDataCon +promotedNilDataCon = promoteDataCon nilDataCon + +-- | Make a *promoted* list. +mkPromotedListTy :: Kind -- ^ of the elements of the list + -> [Type] -- ^ elements + -> Type +mkPromotedListTy k tys + = foldr cons nil tys + where + cons :: Type -- element + -> Type -- list + -> Type + cons elt list = mkTyConApp promotedConsDataCon [k, elt, list] + + nil :: Type + nil = mkTyConApp promotedNilDataCon [k] + +-- | Extract the elements of a promoted list. Panics if the type is not a +-- promoted list +extractPromotedList :: Type -- ^ The promoted list + -> [Type] +extractPromotedList tys = go tys + where + go list_ty + | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty + = assert (tc `hasKey` consDataConKey) $ + t : go ts + + | Just (tc, [_k]) <- splitTyConApp_maybe list_ty + = assert (tc `hasKey` nilDataConKey) + [] + + | otherwise + = pprPanic "extractPromotedList" (ppr tys) + +--------------------------------------- +-- ghc-bignum +--------------------------------------- + +integerTyConName + , integerISDataConName + , integerIPDataConName + , integerINDataConName + :: Name +integerTyConName + = mkWiredInTyConName + UserSyntax + gHC_INTERNAL_NUM_INTEGER + (fsLit "Integer") + integerTyConKey + integerTyCon +integerISDataConName + = mkWiredInDataConName + UserSyntax + gHC_INTERNAL_NUM_INTEGER + (fsLit "IS") + integerISDataConKey + integerISDataCon +integerIPDataConName + = mkWiredInDataConName + UserSyntax + gHC_INTERNAL_NUM_INTEGER + (fsLit "IP") + integerIPDataConKey + integerIPDataCon +integerINDataConName + = mkWiredInDataConName + UserSyntax + gHC_INTERNAL_NUM_INTEGER + (fsLit "IN") + integerINDataConKey + integerINDataCon + +integerTy :: Type +integerTy = mkTyConTy integerTyCon + +integerTyCon :: TyCon +integerTyCon = pcTyCon integerTyConName Nothing [] + [integerISDataCon, integerIPDataCon, integerINDataCon] + +integerISDataCon :: DataCon +integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon + +integerIPDataCon :: DataCon +integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon + +integerINDataCon :: DataCon +integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon + +naturalTyConName + , naturalNSDataConName + , naturalNBDataConName + :: Name +naturalTyConName + = mkWiredInTyConName + UserSyntax + gHC_INTERNAL_NUM_NATURAL + (fsLit "Natural") + naturalTyConKey + naturalTyCon +naturalNSDataConName + = mkWiredInDataConName + UserSyntax + gHC_INTERNAL_NUM_NATURAL + (fsLit "NS") + naturalNSDataConKey + naturalNSDataCon +naturalNBDataConName + = mkWiredInDataConName + UserSyntax + gHC_INTERNAL_NUM_NATURAL + (fsLit "NB") + naturalNBDataConKey + naturalNBDataCon + +naturalTy :: Type +naturalTy = mkTyConTy naturalTyCon + +naturalTyCon :: TyCon +naturalTyCon = pcTyCon naturalTyConName Nothing [] + [naturalNSDataCon, naturalNBDataCon] + +naturalNSDataCon :: DataCon +naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon + +naturalNBDataCon :: DataCon +naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon + + +{- +************************************************************************ +* * + Semi-builtin names +* * +************************************************************************ + +Note [pretendNameIsInScope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, we filter out instances that mention types whose names are +not in scope. However, in the situations listed below, we make an exception +for some commonly used names, such as Data.Kind.Type, which may not actually +be in scope but should be treated as though they were in scope. +This includes built-in names, as well as a few extra names such as +'Type', 'TYPE', 'BoxedRep', etc. + +Situations in which we apply this special logic: + + - GHCi's :info command, see GHC.Runtime.Eval.getInfo. + This fixes #1581. + + - When reporting instance overlap errors. Not doing so could mean + that we would omit instances for typeclasses like + + type Cls :: k -> Constraint + class Cls a + + because BoxedRep/Lifted were not in scope. + See GHC.Tc.Errors.potentialInstancesErrMsg. + This fixes one of the issues reported in #20465. +-} + +-- | Should this name be considered in-scope, even though it technically isn't? +-- +-- This ensures that we don't filter out information because, e.g., +-- Data.Kind.Type isn't imported. +-- +-- See Note [pretendNameIsInScope]. +pretendNameIsInScope :: Name -> Bool +pretendNameIsInScope n + = isBuiltInSyntax n + || isTupleTyConName n + || isSumTyConName n + || isCTupleTyConName n + || any (n `hasKey`) + [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey + , liftedDataConKey, unliftedDataConKey + , tYPETyConKey + , cONSTRAINTTyConKey + , runtimeRepTyConKey, boxedRepDataConKey + , eqTyConKey + , listTyConKey + , oneDataConKey + , manyDataConKey + , fUNTyConKey, unrestrictedFunTyConKey ] diff --git a/GHC/Builtin/Types.hs-boot b/GHC/Builtin/Types.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Types.hs-boot @@ -0,0 +1,83 @@ +module GHC.Builtin.Types where + +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, RuntimeRepType) +import {-# SOURCE #-} GHC.Core.DataCon ( DataCon ) + +import GHC.Types.Basic (Arity, TupleSort, Boxity, ConTag) +import {-# SOURCE #-} GHC.Types.Name (Name) + +listTyCon :: TyCon +typeSymbolKind :: Type +charTy :: Type +mkBoxedTupleTy :: [Type] -> Type + +coercibleTyCon, heqTyCon :: TyCon + +unitTy :: Type +unitTyCon :: TyCon + +liftedTypeKindTyConName :: Name +constraintKindTyConName :: Name + +liftedTypeKind, unliftedTypeKind, zeroBitTypeKind :: Kind + +liftedTypeKindTyCon, unliftedTypeKindTyCon :: TyCon + +liftedRepTyCon, unliftedRepTyCon :: TyCon + +constraintKind :: Kind + +runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon :: TyCon +runtimeRepTy, levityTy :: Type + +boxedRepDataConTyCon, liftedDataConTyCon :: TyCon +vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon + +liftedRepTy, unliftedRepTy, zeroBitRepTy :: RuntimeRepType +liftedDataConTy, unliftedDataConTy :: Type + +intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType + +vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy :: Type + +int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy :: Type + +anyTypeOfKind :: Kind -> Type +unboxedTupleKind :: [Type] -> Type + +multiplicityTyCon :: TyCon +multiplicityTy :: Type +oneDataConTy :: Type +oneDataConTyCon :: TyCon +manyDataConTy :: Type +manyDataConTyCon :: TyCon +unrestrictedFunTyCon :: TyCon +multMulTyCon :: TyCon + +tupleTyConName :: TupleSort -> Arity -> Name +tupleDataConName :: Boxity -> Arity -> Name + +integerTy, naturalTy :: Type + +promotedTupleDataCon :: Boxity -> Arity -> TyCon + +tupleDataCon :: Boxity -> Arity -> DataCon +tupleTyCon :: Boxity -> Arity -> TyCon + +cTupleDataCon :: Arity -> DataCon +cTupleDataConName :: Arity -> Name +cTupleTyConName :: Arity -> Name +cTupleSelIdName :: ConTag -> Arity -> Name + +sumDataCon :: ConTag -> Arity -> DataCon +sumTyCon :: Arity -> TyCon diff --git a/GHC/Builtin/Types/Literals.hs b/GHC/Builtin/Types/Literals.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Types/Literals.hs @@ -0,0 +1,1176 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- See calls to mkTemplateTyVars + +module GHC.Builtin.Types.Literals + ( tryInteractInertFam, tryInteractTopFam, tryMatchFam + + , typeNatTyCons + , typeNatCoAxiomRules + , BuiltInSynFamily(..) + + -- If you define a new built-in type family, make sure to export its TyCon + -- from here as well. + -- See Note [Adding built-in type families] + , typeNatAddTyCon + , typeNatMulTyCon + , typeNatExpTyCon + , typeNatSubTyCon + , typeNatDivTyCon + , typeNatModTyCon + , typeNatLogTyCon + , typeNatCmpTyCon + , typeSymbolCmpTyCon + , typeSymbolAppendTyCon + , typeCharCmpTyCon + , typeConsSymbolTyCon + , typeUnconsSymbolTyCon + , typeCharToNatTyCon + , typeNatToCharTyCon + ) where + +import GHC.Prelude + +import GHC.Core.Type +import GHC.Core.Unify ( tcMatchTys ) +import GHC.Data.Pair +import GHC.Core.TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon, tyConArity + , Injectivity(..), isBuiltInSynFamTyCon_maybe ) +import GHC.Core.Coercion.Axiom +import GHC.Core.TyCo.Compare ( tcEqType ) +import GHC.Types.Name ( Name, BuiltInSyntax(..) ) +import GHC.Types.Unique.FM +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim ( mkTemplateAnonTyConBinders, mkTemplateTyVars ) +import GHC.Builtin.Names + ( gHC_INTERNAL_TYPELITS + , gHC_INTERNAL_TYPELITS_INTERNAL + , gHC_INTERNAL_TYPENATS + , gHC_INTERNAL_TYPENATS_INTERNAL + , typeNatAddTyFamNameKey + , typeNatMulTyFamNameKey + , typeNatExpTyFamNameKey + , typeNatSubTyFamNameKey + , typeNatDivTyFamNameKey + , typeNatModTyFamNameKey + , typeNatLogTyFamNameKey + , typeNatCmpTyFamNameKey + , typeSymbolCmpTyFamNameKey + , typeSymbolAppendFamNameKey + , typeCharCmpTyFamNameKey + , typeConsSymbolTyFamNameKey + , typeUnconsSymbolTyFamNameKey + , typeCharToNatTyFamNameKey + , typeNatToCharTyFamNameKey + ) +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Utils.Outputable + +import Control.Monad ( guard ) +import Data.List ( isPrefixOf, isSuffixOf ) +import Data.Maybe ( listToMaybe ) +import qualified Data.Char as Char + +{- +Note [Type-level literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are currently three forms of type-level literals: natural numbers, symbols, and +characters. + +Type-level literals are supported by CoAxiomRules (conditional axioms), which +power the built-in type families (see Note [Adding built-in type families]). +Currently, all built-in type families are for the express purpose of supporting +type-level literals. + +See also the Wiki page: + + https://gitlab.haskell.org/ghc/ghc/wikis/type-nats + +Note [Adding built-in type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a few steps to adding a built-in type family: + +* Adding a unique for the type family TyCon + + These go in GHC.Builtin.Names. It will likely be of the form + @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that + has not been chosen before in GHC.Builtin.Names. There are several examples already + in GHC.Builtin.Names—see, for instance, typeNatAddTyFamNameKey. + +* Adding the type family TyCon itself + + This goes in GHC.Builtin.Types.Literals. There are plenty of examples of how to define + these -- see, for instance, typeNatAddTyCon. + + Once your TyCon has been defined, be sure to: + + - Export it from GHC.Builtin.Types.Literals. (Not doing so caused #14632.) + - Include it in the typeNatTyCons list, defined in GHC.Builtin.Types.Literals. + +* Define the type family somewhere + + Finally, you will need to define the type family somewhere, likely in @base@. + Currently, all of the built-in type families are defined in GHC.TypeLits or + GHC.TypeNats, so those are likely candidates. + + Since the behavior of your built-in type family is specified in GHC.Builtin.Types.Literals, + you should give an open type family definition with no instances, like so: + + type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat + + Changing the argument and result kinds as appropriate. + +* Update the relevant test cases + + The GHC test suite will likely need to be updated after you add your built-in + type family. For instance: + + - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added + a test there, the expected output of T9181 will need to change. + - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit + tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have + runtime unit tests. Consider adding further unit tests to those if your + built-in type family deals with Nats or Symbols, respectively. + +Note [Inlining axiom constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have a number of constructor functions with types like + mkUnaryConstFoldAxiom :: TyCon -> String + -> (Type -> Maybe a) + -> (a -> Maybe Type) + -> BuiltInFamRewrite + +For very type-family-heavy code, these higher order argument are inefficient; +e.g. the fourth argument might always return (Just ty) in the above. Inlining +them is a bit brutal, but not bad, makes a few-percent difference in, say +perf test T13386. + +These functions aren't exported, so the effect is very local. + +-} + +------------------------------------------------------------------------------- +-- Key utility functions +------------------------------------------------------------------------------- + +tryInteractTopFam :: BuiltInSynFamily -> TyCon -> [Type] -> Type + -> [(CoAxiomRule, TypeEqn)] +-- The returned CoAxiomRule is always unary +tryInteractTopFam fam fam_tc tys r + = [(bifinj_axr bif, eqn_out) | bif <- sfInteract fam + , Just eqn_out <- [bifinj_proves bif eqn_in] ] + where + eqn_in :: TypeEqn + eqn_in = Pair (mkTyConApp fam_tc tys) r + +tryInteractInertFam :: BuiltInSynFamily -> TyCon + -> [Type] -> [Type] -- F tys1 ~ F tys2 + -> [(CoAxiomRule, TypeEqn)] +tryInteractInertFam builtin_fam fam_tc tys1 tys2 + = [(bifinj_axr bif, eqn_out) | bif <- sfInteract builtin_fam + , Just eqn_out <- [bifinj_proves bif eqn_in] ] + where + eqn_in = Pair (mkTyConApp fam_tc tys1) (mkTyConApp fam_tc tys2) + +tryMatchFam :: BuiltInSynFamily -> [Type] + -> Maybe (CoAxiomRule, [Type], Type) +-- Does this reduce on the given arguments? +-- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type) +-- That is: mkAxiomCo (BuiltInFamRew ax) (map mkNomReflCo ts) +-- :: F tys ~r rhs, +tryMatchFam builtin_fam arg_tys + = listToMaybe $ -- Pick first rule to match + [ (bifrw_axr rw_ax, inst_tys, res_ty) + | rw_ax <- sfMatchFam builtin_fam + , Just (inst_tys,res_ty) <- [bifrw_match rw_ax arg_tys] ] + +------------------------------------------------------------------------------- +-- Constructing BuiltInFamInjectivity, BuiltInFamRewrite +------------------------------------------------------------------------------- + +mkUnaryConstFoldAxiom :: TyCon -> String + -> (Type -> Maybe a) + -> (a -> Maybe Type) + -> BuiltInFamRewrite +-- For the definitional axioms, like (3+4 --> 7) +{-# INLINE mkUnaryConstFoldAxiom #-} -- See Note [Inlining axiom constructors] +mkUnaryConstFoldAxiom fam_tc str isReqTy f + = bif + where + bif = BIF_Rewrite + { bifrw_name = fsLit str + , bifrw_axr = BuiltInFamRew bif + , bifrw_fam_tc = fam_tc + , bifrw_arity = 1 + , bifrw_match = \ts -> do { [t1] <- return ts + ; t1' <- isReqTy t1 + ; res <- f t1' + ; return ([t1], res) } + , bifrw_proves = \cs -> do { [Pair s1 s2] <- return cs + ; s2' <- isReqTy s2 + ; z <- f s2' + ; return (mkTyConApp fam_tc [s1] === z) } + } + +mkBinConstFoldAxiom :: TyCon -> String + -> (Type -> Maybe a) + -> (Type -> Maybe b) + -> (a -> b -> Maybe Type) + -> BuiltInFamRewrite +-- For the definitional axioms, like (3+4 --> 7) +{-# INLINE mkBinConstFoldAxiom #-} -- See Note [Inlining axiom constructors] +mkBinConstFoldAxiom fam_tc str isReqTy1 isReqTy2 f + = bif + where + bif = BIF_Rewrite + { bifrw_name = fsLit str + , bifrw_axr = BuiltInFamRew bif + , bifrw_fam_tc = fam_tc + , bifrw_arity = 2 + , bifrw_match = \ts -> do { [t1,t2] <- return ts + ; t1' <- isReqTy1 t1 + ; t2' <- isReqTy2 t2 + ; res <- f t1' t2' + ; return ([t1,t2], res) } + , bifrw_proves = \cs -> do { [Pair s1 s2, Pair t1 t2] <- return cs + ; s2' <- isReqTy1 s2 + ; t2' <- isReqTy2 t2 + ; z <- f s2' t2' + ; return (mkTyConApp fam_tc [s1,t1] === z) } + } + +mkRewriteAxiom :: TyCon -> String + -> [TyVar] -> [Type] -- LHS of axiom + -> Type -- RHS of axiom + -> BuiltInFamRewrite +-- Not higher order, no benefit in inlining +-- See Note [Inlining axiom constructors] +mkRewriteAxiom fam_tc str tpl_tvs lhs_tys rhs_ty + = assertPpr (tyConArity fam_tc == length lhs_tys) (text str <+> ppr lhs_tys) $ + bif + where + bif = BIF_Rewrite + { bifrw_name = fsLit str + , bifrw_axr = BuiltInFamRew bif + , bifrw_fam_tc = fam_tc + , bifrw_arity = bif_arity + , bifrw_match = match_fn + , bifrw_proves = inst_fn } + + bif_arity = length tpl_tvs + + match_fn :: [Type] -> Maybe ([Type],Type) + match_fn arg_tys + = assertPpr (tyConArity fam_tc == length arg_tys) (text str <+> ppr arg_tys) $ + case tcMatchTys lhs_tys arg_tys of + Nothing -> Nothing + Just subst -> Just (substTyVars subst tpl_tvs, substTy subst rhs_ty) + + inst_fn :: [TypeEqn] -> Maybe TypeEqn + inst_fn inst_eqns + = assertPpr (length inst_eqns == bif_arity) (text str $$ ppr inst_eqns) $ + Just (mkTyConApp fam_tc (substTys (zipTCvSubst tpl_tvs tys1) lhs_tys) + === + substTy (zipTCvSubst tpl_tvs tys2) rhs_ty) + where + (tys1, tys2) = unzipPairs inst_eqns + +mkTopUnaryFamDeduction :: String -> TyCon + -> (Type -> Type -> Maybe TypeEqn) + -> BuiltInFamInjectivity +-- Deduction from (F s ~ r) where `F` is a unary type function +{-# INLINE mkTopUnaryFamDeduction #-} -- See Note [Inlining axiom constructors] +mkTopUnaryFamDeduction str fam_tc f + = bif + where + bif = BIF_Interact + { bifinj_name = fsLit str + , bifinj_axr = BuiltInFamInj bif + , bifinj_proves = \(Pair lhs rhs) + -> do { (tc, [a]) <- splitTyConApp_maybe lhs + ; massertPpr (tc == fam_tc) (ppr tc $$ ppr fam_tc) + ; f a rhs } } + +mkTopBinFamDeduction :: String -> TyCon + -> (Type -> Type -> Type -> Maybe TypeEqn) + -> BuiltInFamInjectivity +-- Deduction from (F s t ~ r) where `F` is a binary type function +{-# INLINE mkTopBinFamDeduction #-} -- See Note [Inlining axiom constructors] +mkTopBinFamDeduction str fam_tc f + = bif + where + bif = BIF_Interact + { bifinj_name = fsLit str + , bifinj_axr = BuiltInFamInj bif + , bifinj_proves = \(Pair lhs rhs) -> + do { (tc, [a,b]) <- splitTyConApp_maybe lhs + ; massertPpr (tc == fam_tc) (ppr tc $$ ppr fam_tc) + ; f a b rhs } } + +mkUnaryBIF :: String -> TyCon -> BuiltInFamInjectivity +-- Not higher order, no benefit in inlining +-- See Note [Inlining axiom constructors] +mkUnaryBIF str fam_tc + = bif + where + bif = BIF_Interact { bifinj_name = fsLit str + , bifinj_axr = BuiltInFamInj bif + , bifinj_proves = proves } + proves (Pair lhs rhs) + = do { (tc2, [x2]) <- splitTyConApp_maybe rhs + ; guard (tc2 == fam_tc) + ; (tc1, [x1]) <- splitTyConApp_maybe lhs + ; massertPpr (tc1 == fam_tc) (ppr tc1 $$ ppr fam_tc) + ; return (Pair x1 x2) } + +mkBinBIF :: String -> TyCon + -> WhichArg -> WhichArg + -> (Type -> Bool) -- The guard on the equal args, if any + -> BuiltInFamInjectivity +{-# INLINE mkBinBIF #-} -- See Note [Inlining axiom constructors] +mkBinBIF str fam_tc eq1 eq2 check_me + = bif + where + bif = BIF_Interact { bifinj_name = fsLit str + , bifinj_axr = BuiltInFamInj bif + , bifinj_proves = proves } + proves (Pair lhs rhs) + = do { (tc2, [x2,y2]) <- splitTyConApp_maybe rhs + ; guard (tc2 == fam_tc) + ; (tc1, [x1,y1]) <- splitTyConApp_maybe lhs + ; massertPpr (tc1 == fam_tc) (ppr tc1 $$ ppr fam_tc) + ; case (eq1, eq2) of + (ArgX,ArgX) -> do_it x1 x2 y1 y2 + (ArgX,ArgY) -> do_it x1 y2 x2 y1 + (ArgY,ArgX) -> do_it y1 x2 y2 x1 + (ArgY,ArgY) -> do_it y1 y2 x1 x2 } + + do_it a1 a2 b1 b2 = do { same a1 a2; guard (check_me a1); return (Pair b1 b2) } + +noGuard :: Type -> Bool +noGuard _ = True + +numGuard :: (Integer -> Bool) -> Type -> Bool +numGuard pred ty = case isNumLitTy ty of + Just n -> pred n + Nothing -> False + +data WhichArg = ArgX | ArgY + + +------------------------------------------------------------------------------- +-- Built-in type constructors for functions on type-level nats +------------------------------------------------------------------------------- + +-- The list of built-in type family TyCons that GHC uses. +-- If you define a built-in type family, make sure to add it to this list. +-- See Note [Adding built-in type families] +typeNatTyCons :: [TyCon] +typeNatTyCons = + [ typeNatAddTyCon + , typeNatMulTyCon + , typeNatExpTyCon + , typeNatSubTyCon + , typeNatDivTyCon + , typeNatModTyCon + , typeNatLogTyCon + , typeNatCmpTyCon + , typeSymbolCmpTyCon + , typeSymbolAppendTyCon + , typeCharCmpTyCon + , typeConsSymbolTyCon + , typeUnconsSymbolTyCon + , typeCharToNatTyCon + , typeNatToCharTyCon + ] + + +-- The list of built-in type family axioms that GHC uses. +-- If you define new axioms, make sure to include them in this list. +-- See Note [Adding built-in type families] +typeNatCoAxiomRules :: UniqFM FastString CoAxiomRule +typeNatCoAxiomRules + = listToUFM $ + [ pr | tc <- typeNatTyCons + , Just ops <- [isBuiltInSynFamTyCon_maybe tc] + , pr <- [ (bifinj_name bif, bifinj_axr bif) | bif <- sfInteract ops ] + ++ [ (bifrw_name bif, bifrw_axr bif) | bif <- sfMatchFam ops ] ] + +------------------------------------------------------------------------------- +-- Addition (+) +------------------------------------------------------------------------------- + +typeNatAddTyCon :: TyCon +typeNatAddTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = axAddRewrites + , sfInteract = axAddInjectivity + } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "+") + typeNatAddTyFamNameKey typeNatAddTyCon + + +sn,tn :: TyVar -- Of kind Natural +(sn: tn: _) = mkTemplateTyVars (repeat typeSymbolKind) + +axAddRewrites :: [BuiltInFamRewrite] +axAddRewrites + = [ mkRewriteAxiom tc "Add0L" [tn] [num 0, var tn] (var tn) -- 0 + t --> t + , mkRewriteAxiom tc "Add0R" [sn] [var sn, num 0] (var sn) -- s + 0 --> s + , mkBinConstFoldAxiom tc "AddDef" isNumLitTy isNumLitTy $ -- 3 + 4 --> 7 + \x y -> Just $ num (x + y) ] + where + tc = typeNatAddTyCon + +axAddInjectivity :: [BuiltInFamInjectivity] +axAddInjectivity + = [ -- (s + t ~ 0) => (s ~ 0) + mkTopBinFamDeduction "AddT-0L" tc $ \ a _b r -> + do { _ <- known r (== 0); return (Pair a (num 0)) } + + , -- (s + t ~ 0) => (t ~ 0) + mkTopBinFamDeduction "AddT-0R" tc $ \ _a b r -> + do { _ <- known r (== 0); return (Pair b (num 0)) } + + , -- (5 + t ~ 8) => (t ~ 3) + mkTopBinFamDeduction "AddT-KKL" tc $ \ a b r -> + do { na <- isNumLitTy a; nr <- known r (>= na); return (Pair b (num (nr-na))) } + + , -- (s + 5 ~ 8) => (s ~ 3) + mkTopBinFamDeduction "AddT-KKR" tc $ \ a b r -> + do { nb <- isNumLitTy b; nr <- known r (>= nb); return (Pair a (num (nr-nb))) } + + , mkBinBIF "AddI-xx" tc ArgX ArgX noGuard -- x1+y1~x2+y2 {x1=x2}=> (y1 ~ y2) + , mkBinBIF "AddI-xy" tc ArgX ArgY noGuard -- x1+y1~x2+y2 {x1=y2}=> (x2 ~ y1) + , mkBinBIF "AddI-yx" tc ArgY ArgX noGuard -- x1+y1~x2+y2 {y1=x2}=> (x1 ~ y2) + , mkBinBIF "AddI-yy" tc ArgY ArgY noGuard -- x1+y1~x2+y2 {y1=y2}=> (x1 ~ x2) + ] + where + tc = typeNatAddTyCon + +------------------------------------------------------------------------------- +-- Subtraction (-) +------------------------------------------------------------------------------- + +typeNatSubTyCon :: TyCon +typeNatSubTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = axSubRewrites + , sfInteract = axSubInjectivity + } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "-") + typeNatSubTyFamNameKey typeNatSubTyCon + +axSubRewrites :: [BuiltInFamRewrite] +axSubRewrites + = [ mkRewriteAxiom tc "Sub0R" [sn] [var sn, num 0] (var sn) -- s - 0 --> s + , mkBinConstFoldAxiom tc "SubDef" isNumLitTy isNumLitTy $ -- 4 - 3 --> 1 if x>=y + \x y -> fmap num (minus x y) ] + where + tc = typeNatSubTyCon + +axSubInjectivity :: [BuiltInFamInjectivity] +axSubInjectivity + = [ -- (a - b ~ 5) => (5 + b ~ a) + mkTopBinFamDeduction "SubT" tc $ \ a b r -> + do { _ <- isNumLitTy r; return (Pair (r .+. b) a) } + + , mkBinBIF "SubI-xx" tc ArgX ArgX noGuard -- (x-y1 ~ x-y2) => (y1 ~ y2) + , mkBinBIF "SubI-yy" tc ArgY ArgY noGuard -- (x1-y ~ x2-y) => (x1 ~ x2) + ] + where + tc = typeNatSubTyCon + +{- +Note [Weakened interaction rule for subtraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A simpler interaction here might be: + + `s - t ~ r` --> `t + r ~ s` + +This would enable us to reuse all the code for addition. +Unfortunately, this works a little too well at the moment. +Consider the following example: + + 0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0) + +This (correctly) spots that the constraint cannot be solved. + +However, this may be a problem if the constraint did not +need to be solved in the first place! Consider the following example: + +f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5 +f = id + +Currently, GHC is strict while evaluating functions, so this does not +work, because even though the `If` should evaluate to `5 - 0`, we +also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`, +which fails. + +So, for the time being, we only add an improvement when the RHS is a constant, +which happens to work OK for the moment, although clearly we need to do +something more general. +-} + + +------------------------------------------------------------------------------- +-- Multiplication (*) +------------------------------------------------------------------------------- + +typeNatMulTyCon :: TyCon +typeNatMulTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily { sfMatchFam = axMulRewrites + , sfInteract = axMulInjectivity } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "*") + typeNatMulTyFamNameKey typeNatMulTyCon + +axMulRewrites :: [BuiltInFamRewrite] +axMulRewrites + = [ mkRewriteAxiom tc "Mul0L" [tn] [num 0, var tn] (num 0) -- 0 * t --> 0 + , mkRewriteAxiom tc "Mul0R" [sn] [var sn, num 0] (num 0) -- s * 0 --> 0 + , mkRewriteAxiom tc "Mul1L" [tn] [num 1, var tn] (var tn) -- 1 * t --> t + , mkRewriteAxiom tc "Mul1R" [sn] [var sn, num 1] (var sn) -- s * 1 --> s + , mkBinConstFoldAxiom tc "MulDef" isNumLitTy isNumLitTy $ -- 3 + 4 --> 12 + \x y -> Just $ num (x * y) ] + where + tc = typeNatMulTyCon + +axMulInjectivity :: [BuiltInFamInjectivity] +axMulInjectivity + = [ -- (s * t ~ 1) => (s ~ 1) + mkTopBinFamDeduction "MulT1" tc $ \ s _t r -> + do { _ <- known r (== 1); return (Pair s r) } + + , -- (s * t ~ 1) => (t ~ 1) + mkTopBinFamDeduction "MulT2" tc $ \ _s t r -> + do { _ <- known r (== 1); return (Pair t r) } + + , -- (3 * t ~ 15) => (t ~ 5) + mkTopBinFamDeduction "MulT3" tc $ \ s t r -> + do { ns <- isNumLitTy s; nr <- isNumLitTy r; y <- divide nr ns; return (Pair t (num y)) } + + , -- (s * 3 ~ 15) => (s ~ 5) + mkTopBinFamDeduction "MulT4" tc $ \ s t r -> + do { nt <- isNumLitTy t; nr <- isNumLitTy r; y <- divide nr nt; return (Pair s (num y)) } + + , mkBinBIF "MulI-xx" tc ArgX ArgX (numGuard (/= 0)) -- (x*y1 ~ x*y2) {x/=0}=> (y1 ~ y2) + , mkBinBIF "MulI-yy" tc ArgY ArgY (numGuard (/= 0)) -- (x1*y ~ x2*y) {y/=0}=> (x1 ~ x2) + ] + where + tc = typeNatMulTyCon + + +------------------------------------------------------------------------------- +-- Division: Div and Mod +------------------------------------------------------------------------------- + +typeNatDivTyCon :: TyCon +typeNatDivTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily { sfMatchFam = axDivRewrites + , sfInteract = [] } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Div") + typeNatDivTyFamNameKey typeNatDivTyCon + +typeNatModTyCon :: TyCon +typeNatModTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily { sfMatchFam = axModRewrites + , sfInteract = [] } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Mod") + typeNatModTyFamNameKey typeNatModTyCon + +axDivRewrites :: [BuiltInFamRewrite] +axDivRewrites + = [ mkRewriteAxiom tc "Div1" [sn] [var sn, num 1] (var sn) -- s `div` 1 --> s + , mkBinConstFoldAxiom tc "DivDef" isNumLitTy isNumLitTy $ -- 8 `div` 4 --> 2 + \x y -> do { guard (y /= 0); return (num (div x y)) } ] + where + tc = typeNatDivTyCon + +axModRewrites :: [BuiltInFamRewrite] +axModRewrites + = [ mkRewriteAxiom tc "Mod1" [sn] [var sn, num 1] (num 0) -- s `mod` 1 --> 0 + , mkBinConstFoldAxiom tc "ModDef" isNumLitTy isNumLitTy $ -- 8 `mod` 3 --> 2 + \x y -> do { guard (y /= 0); return (num (mod x y)) } ] + where + tc = typeNatModTyCon + +------------------------------------------------------------------------------- +-- Exponentiation: Exp +------------------------------------------------------------------------------- + +typeNatExpTyCon :: TyCon -- Exponentiation +typeNatExpTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily { sfMatchFam = axExpRewrites + , sfInteract = axExpInjectivity } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "^") + typeNatExpTyFamNameKey typeNatExpTyCon + +axExpRewrites :: [BuiltInFamRewrite] +axExpRewrites + = [ mkRewriteAxiom tc "Exp0R" [sn] [var sn, num 0] (num 1) -- s ^ 0 --> 1 + , mkRewriteAxiom tc "Exp1L" [tn] [num 1, var tn] (num 1) -- 1 ^ t --> 1 + , mkRewriteAxiom tc "Exp1R" [sn] [var sn, num 1] (var sn) -- s ^ 1 --> s + , mkBinConstFoldAxiom tc "ExpDef" isNumLitTy isNumLitTy $ -- 2 ^ 3 --> 8 + \x y -> Just (num (x ^ y)) ] + where + tc = typeNatExpTyCon + +axExpInjectivity :: [BuiltInFamInjectivity] +axExpInjectivity + = [ -- (s ^ t ~ 0) => (s ~ 0) + mkTopBinFamDeduction "ExpT1" tc $ \ s _t r -> + do { 0 <- isNumLitTy r; return (Pair s r) } + + , -- (2 ^ t ~ 8) => (t ~ 3) + mkTopBinFamDeduction "ExpT2" tc $ \ s t r -> + do { ns <- isNumLitTy s; nr <- isNumLitTy r; y <- logExact nr ns; return (Pair t (num y)) } + + , -- (s ^ 2 ~ 9) => (s ~ 3) + mkTopBinFamDeduction "ExpT3" tc $ \ s t r -> + do { nt <- isNumLitTy t; nr <- isNumLitTy r; y <- rootExact nr nt; return (Pair s (num y)) } + + , mkBinBIF "ExpI-xx" tc ArgX ArgX (numGuard (> 1)) -- (x^y1 ~ x^y2) {x>1}=> (y1 ~ y2) + , mkBinBIF "ExpI-yy" tc ArgY ArgY (numGuard (/= 0)) -- (x1*y ~ x2*y) {y/=0}=> (x1 ~ x2) + ] + where + tc = typeNatExpTyCon + +------------------------------------------------------------------------------- +-- Logarithm: Log2 +------------------------------------------------------------------------------- + +typeNatLogTyCon :: TyCon +typeNatLogTyCon = mkTypeNatFunTyCon1 name + BuiltInSynFamily { sfMatchFam = axLogRewrites + , sfInteract = [] } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Log2") + typeNatLogTyFamNameKey typeNatLogTyCon + +axLogRewrites :: [BuiltInFamRewrite] +axLogRewrites + = [ mkUnaryConstFoldAxiom tc "LogDef" isNumLitTy $ -- log 8 --> 3 + \x -> do { (a,_) <- genLog x 2; return (num a) } ] + where + tc = typeNatLogTyCon + +------------------------------------------------------------------------------- +-- Comparision of Nats: CmpNat +------------------------------------------------------------------------------- + +typeNatCmpTyCon :: TyCon +typeNatCmpTyCon + = mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ]) + orderingKind + Nothing + (BuiltInSynFamTyCon ops) + Nothing + NotInjective + + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS_INTERNAL (fsLit "CmpNat") + typeNatCmpTyFamNameKey typeNatCmpTyCon + ops = BuiltInSynFamily { sfMatchFam = axCmpNatRewrites + , sfInteract = axCmpNatInjectivity } + +axCmpNatRewrites :: [BuiltInFamRewrite] +axCmpNatRewrites + = [ mkRewriteAxiom tc "CmpNatRefl" [sn] [var sn, var sn] (ordering EQ) -- s `cmp` s --> EQ + , mkBinConstFoldAxiom tc "CmpNatDef" isNumLitTy isNumLitTy $ -- 2 `cmp` 3 --> LT + \x y -> Just (ordering (compare x y)) ] + where + tc = typeNatCmpTyCon + +axCmpNatInjectivity :: [BuiltInFamInjectivity] +axCmpNatInjectivity + = [ -- s `cmp` t ~ EQ ==> s ~ t + mkTopBinFamDeduction "CmpNatT3" typeNatCmpTyCon $ \ s t r -> + do { EQ <- isOrderingLitTy r; return (Pair s t) } ] + +------------------------------------------------------------------------------- +-- Comparsion of Symbols: CmpSymbol +------------------------------------------------------------------------------- + +typeSymbolCmpTyCon :: TyCon +typeSymbolCmpTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [typeSymbolKind, typeSymbolKind]) + orderingKind + Nothing + (BuiltInSynFamTyCon ops) + Nothing + NotInjective + + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpSymbol") + typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon + ops = BuiltInSynFamily { sfMatchFam = axSymbolCmpRewrites + , sfInteract = axSymbolCmpInjectivity } + +ss,ts :: TyVar -- Of kind Symbol +(ss: ts: _) = mkTemplateTyVars (repeat typeSymbolKind) + +axSymbolCmpRewrites :: [BuiltInFamRewrite] +axSymbolCmpRewrites + = [ mkRewriteAxiom tc "CmpSymbolRefl" [ss] [var ss, var ss] (ordering EQ) -- s `cmp` s --> EQ + , mkBinConstFoldAxiom tc "CmpSymbolDef" isStrLitTy isStrLitTy $ -- "a" `cmp` "b" --> LT + \x y -> Just (ordering (lexicalCompareFS x y)) ] + where + tc = typeSymbolCmpTyCon + +axSymbolCmpInjectivity :: [BuiltInFamInjectivity] +axSymbolCmpInjectivity + = [ mkTopBinFamDeduction "CmpSymbolT" typeSymbolCmpTyCon $ \ s t r -> + do { EQ <- isOrderingLitTy r; return (Pair s t) } ] + + +------------------------------------------------------------------------------- +-- AppendSymbol +------------------------------------------------------------------------------- + +typeSymbolAppendTyCon :: TyCon +typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name + BuiltInSynFamily { sfMatchFam = axAppendRewrites + , sfInteract = axAppendInjectivity } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "AppendSymbol") + typeSymbolAppendFamNameKey typeSymbolAppendTyCon + +axAppendRewrites :: [BuiltInFamRewrite] +axAppendRewrites + = [ mkRewriteAxiom tc "Concat0R" [ts] [nullStrLitTy, var ts] (var ts) -- "" ++ t --> t + , mkRewriteAxiom tc "Concat0L" [ss] [var ss, nullStrLitTy] (var ss) -- s ++ "" --> s + , mkBinConstFoldAxiom tc "AppendSymbolDef" isStrLitTy isStrLitTy $ -- "a" ++ "b" --> "ab" + \x y -> Just (mkStrLitTy (appendFS x y)) ] + where + tc = typeSymbolAppendTyCon + +axAppendInjectivity :: [BuiltInFamInjectivity] +axAppendInjectivity + = [ -- (AppendSymbol a b ~ "") => (a ~ "") + mkTopBinFamDeduction "AppendSymbolT1" tc $ \ a _b r -> + do { rs <- isStrLitTy r; guard (nullFS rs); return (Pair a nullStrLitTy) } + + , -- (AppendSymbol a b ~ "") => (b ~ "") + mkTopBinFamDeduction "AppendSymbolT2" tc $ \ _a b r -> + do { rs <- isStrLitTy r; guard (nullFS rs); return (Pair b nullStrLitTy) } + + , -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar") + mkTopBinFamDeduction "AppendSymbolT3" tc $ \ a b r -> + do { as <- isStrLitTyS a; rs <- isStrLitTyS r; guard (as `isPrefixOf` rs) + ; return (Pair b (mkStrLitTyS (drop (length as) rs))) } + + , -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo") + mkTopBinFamDeduction "AppendSymbolT3" tc $ \ a b r -> + do { bs <- isStrLitTyS b; rs <- isStrLitTyS r; guard (bs `isSuffixOf` rs) + ; return (Pair a (mkStrLitTyS (take (length rs - length bs) rs))) } + + , mkBinBIF "AppI-xx" tc ArgX ArgX noGuard -- (x++y1 ~ x++y2) => (y1 ~ y2) + , mkBinBIF "AppI-yy" tc ArgY ArgY noGuard -- (x1++y ~ x2++y) => (x1 ~ x2) + ] + where + tc = typeSymbolAppendTyCon + +------------------------------------------------------------------------------- +-- ConsSymbol +------------------------------------------------------------------------------- + +typeConsSymbolTyCon :: TyCon +typeConsSymbolTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ charTy, typeSymbolKind ]) + typeSymbolKind + Nothing + (BuiltInSynFamTyCon ops) + Nothing + (Injective [True, True]) + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "ConsSymbol") + typeConsSymbolTyFamNameKey typeConsSymbolTyCon + ops = BuiltInSynFamily { sfMatchFam = axConsRewrites + , sfInteract = axConsInjectivity } + +axConsRewrites :: [BuiltInFamRewrite] +axConsRewrites + = [ mkBinConstFoldAxiom tc "ConsSymbolDef" isCharLitTy isStrLitTy $ -- 'a' : "bc" --> "abc" + \x y -> Just $ mkStrLitTy (consFS x y) ] + where + tc = typeConsSymbolTyCon + +axConsInjectivity :: [BuiltInFamInjectivity] +axConsInjectivity + = [ -- ConsSymbol a b ~ "blah" => (a ~ 'b') + mkTopBinFamDeduction "ConsSymbolT1" tc $ \ a _b r -> + do { rs <- isStrLitTy r; (x,_) <- unconsFS rs; return (Pair a (mkCharLitTy x)) } + + , -- ConsSymbol a b ~ "blah" => (b ~ "lah") + mkTopBinFamDeduction "ConsSymbolT2" tc $ \ _a b r -> + do { rs <- isStrLitTy r; (_,xs) <- unconsFS rs; return (Pair b (mkStrLitTy xs)) } + + + , mkBinBIF "ConsI-xx" tc ArgX ArgX noGuard -- (x:y1 ~ x:y2) => (y1 ~ y2) + , mkBinBIF "ConsI-yy" tc ArgY ArgY noGuard -- (x1:y ~ x2:y) => (x1 ~ x2) + ] + where + tc = typeConsSymbolTyCon + +------------------------------------------------------------------------------- +-- UnconsSymbol +------------------------------------------------------------------------------- + +typeUnconsSymbolTyCon :: TyCon +typeUnconsSymbolTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ typeSymbolKind ]) + (mkMaybeTy charSymbolPairKind) + Nothing + (BuiltInSynFamTyCon ops) + Nothing + (Injective [True]) + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "UnconsSymbol") + typeUnconsSymbolTyFamNameKey typeUnconsSymbolTyCon + ops = BuiltInSynFamily { sfMatchFam = axUnconsRewrites + , sfInteract = axUnconsInjectivity } + +computeUncons :: FastString -> Type +computeUncons str + = mkPromotedMaybeTy charSymbolPairKind (fmap reify (unconsFS str)) + where + reify :: (Char, FastString) -> Type + reify (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s) + +axUnconsRewrites :: [BuiltInFamRewrite] +axUnconsRewrites + = [ mkUnaryConstFoldAxiom tc "ConsSymbolDef" isStrLitTy $ -- 'a' : "bc" --> "abc" + \x -> Just $ computeUncons x ] + where + tc = typeUnconsSymbolTyCon + +axUnconsInjectivity :: [BuiltInFamInjectivity] +axUnconsInjectivity + = [ -- (UnconsSymbol b ~ Nothing) => (b ~ "") + mkTopUnaryFamDeduction "UnconsSymbolT1" tc $ \b r -> + do { Nothing <- isPromotedMaybeTy r; return (Pair b nullStrLitTy) } + + , -- (UnconsSymbol b ~ Just ('f',"oobar")) => (b ~ "foobar") + mkTopUnaryFamDeduction "UnconsSymbolT2" tc $ \b r -> + do { Just pr <- isPromotedMaybeTy r + ; (c,s) <- isPromotedPairType pr + ; chr <- isCharLitTy c + ; str <- isStrLitTy s + ; return (Pair b (mkStrLitTy (consFS chr str))) } + + , mkUnaryBIF "UnconsI1" tc -- (UnconsSymbol x1 ~ z, UnconsSymbol x2 ~ z) => (x1 ~ x2) + ] + where + tc = typeUnconsSymbolTyCon + +------------------------------------------------------------------------------- +-- CharToNat +------------------------------------------------------------------------------- + +typeCharToNatTyCon :: TyCon +typeCharToNatTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ charTy ]) + naturalTy + Nothing + (BuiltInSynFamTyCon ops) + Nothing + (Injective [True]) + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "CharToNat") + typeCharToNatTyFamNameKey typeCharToNatTyCon + ops = BuiltInSynFamily { sfMatchFam = axCharToNatRewrites + , sfInteract = axCharToNatInjectivity } + +axCharToNatRewrites :: [BuiltInFamRewrite] +axCharToNatRewrites + = [ mkUnaryConstFoldAxiom tc "CharToNatDef" isCharLitTy $ -- CharToNat 'a' --> 97 + \x -> Just $ num (charToInteger x) ] + where + tc = typeCharToNatTyCon + +axCharToNatInjectivity :: [BuiltInFamInjectivity] +axCharToNatInjectivity + = [ -- (CharToNat c ~ 122) => (c ~ 'z') + mkTopUnaryFamDeduction "CharToNatT1" typeCharToNatTyCon $ \c r -> + do { nr <- isNumLitTy r; chr <- integerToChar nr; return (Pair c (mkCharLitTy chr)) } ] + +------------------------------------------------------------------------------- +-- NatToChar +------------------------------------------------------------------------------- + +typeNatToCharTyCon :: TyCon +typeNatToCharTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ naturalTy ]) + charTy + Nothing + (BuiltInSynFamTyCon ops) + Nothing + (Injective [True]) + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "NatToChar") + typeNatToCharTyFamNameKey typeNatToCharTyCon + ops = BuiltInSynFamily { sfMatchFam = axNatToCharRewrites + , sfInteract = axNatToCharInjectivity } + +axNatToCharRewrites :: [BuiltInFamRewrite] +axNatToCharRewrites + = [ mkUnaryConstFoldAxiom tc "NatToCharDef" isNumLitTy $ -- NatToChar 97 --> 'a' + \n -> fmap mkCharLitTy (integerToChar n) ] + where + tc = typeNatToCharTyCon + +axNatToCharInjectivity :: [BuiltInFamInjectivity] +axNatToCharInjectivity + = [ -- (NatToChar n ~ 'z') => (n ~ 122) + mkTopUnaryFamDeduction "CharToNatT1" typeNatToCharTyCon $ \n r -> + do { c <- isCharLitTy r; return (Pair n (mkNumLitTy (charToInteger c))) } ] + + +----------------------------------------------------------------------------- +-- CmpChar +----------------------------------------------------------------------------- + +typeCharCmpTyCon :: TyCon +typeCharCmpTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ charTy, charTy ]) + orderingKind + Nothing + (BuiltInSynFamTyCon ops) + Nothing + NotInjective + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpChar") + typeCharCmpTyFamNameKey typeCharCmpTyCon + ops = BuiltInSynFamily { sfMatchFam = axCharCmpRewrites + , sfInteract = axCharCmpInjectivity } + +sc :: TyVar -- Of kind Char +(sc: _) = mkTemplateTyVars (repeat charTy) + +axCharCmpRewrites :: [BuiltInFamRewrite] +axCharCmpRewrites + = [ mkRewriteAxiom tc "CmpCharRefl" [sc] [var sc, var sc] (ordering EQ) -- s `cmp` s --> EQ + , mkBinConstFoldAxiom tc "CmpCharDef" isCharLitTy isCharLitTy $ -- 'a' `cmp` 'b' --> LT + \chr1 chr2 -> Just $ ordering $ compare chr1 chr2 ] + where + tc = typeCharCmpTyCon + +axCharCmpInjectivity :: [BuiltInFamInjectivity] +axCharCmpInjectivity + = [ -- (CmpChar s t ~ EQ) => s ~ t + mkTopBinFamDeduction "CmpCharT" typeCharCmpTyCon $ \ s t r -> + do { EQ <- isOrderingLitTy r; return (Pair s t) } ] + + +{------------------------------------------------------------------------------- +Various utilities for making axioms and types +-------------------------------------------------------------------------------} + +(===) :: Type -> Type -> Pair Type +x === y = Pair x y + +num :: Integer -> Type +num = mkNumLitTy + +var :: TyVar -> Type +var = mkTyVarTy + +(.+.) :: Type -> Type -> Type +s .+. t = mkTyConApp typeNatAddTyCon [s,t] + +{- +(.-.) :: Type -> Type -> Type +s .-. t = mkTyConApp typeNatSubTyCon [s,t] + +(.*.) :: Type -> Type -> Type +s .*. t = mkTyConApp typeNatMulTyCon [s,t] + +tDiv :: Type -> Type -> Type +tDiv s t = mkTyConApp typeNatDivTyCon [s,t] + +tMod :: Type -> Type -> Type +tMod s t = mkTyConApp typeNatModTyCon [s,t] + +(.^.) :: Type -> Type -> Type +s .^. t = mkTyConApp typeNatExpTyCon [s,t] + +cmpNat :: Type -> Type -> Type +cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t] + +cmpSymbol :: Type -> Type -> Type +cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t] + +appendSymbol :: Type -> Type -> Type +appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t] +-} + + +nullStrLitTy :: Type -- The type "" +nullStrLitTy = mkStrLitTy nilFS + +isStrLitTyS :: Type -> Maybe String +isStrLitTyS ty = do { fs <- isStrLitTy ty; return (unpackFS fs) } + +mkStrLitTyS :: String -> Type +mkStrLitTyS s = mkStrLitTy (mkFastString s) + +charSymbolPair :: Type -> Type -> Type +charSymbolPair = mkPromotedPairTy charTy typeSymbolKind + +charSymbolPairKind :: Kind +charSymbolPairKind = mkTyConApp pairTyCon [charTy, typeSymbolKind] + +orderingKind :: Kind +orderingKind = mkTyConApp orderingTyCon [] + +ordering :: Ordering -> Type +ordering o = + case o of + LT -> mkTyConApp promotedLTDataCon [] + EQ -> mkTyConApp promotedEQDataCon [] + GT -> mkTyConApp promotedGTDataCon [] + +isOrderingLitTy :: Type -> Maybe Ordering +isOrderingLitTy tc = + do (tc1,[]) <- splitTyConApp_maybe tc + case () of + _ | tc1 == promotedLTDataCon -> return LT + | tc1 == promotedEQDataCon -> return EQ + | tc1 == promotedGTDataCon -> return GT + | otherwise -> Nothing + +-- Make a unary built-in constructor of kind: Nat -> Nat +mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon +mkTypeNatFunTyCon1 op tcb = + mkFamilyTyCon op + (mkTemplateAnonTyConBinders [ naturalTy ]) + naturalTy + Nothing + (BuiltInSynFamTyCon tcb) + Nothing + NotInjective + +-- Make a binary built-in constructor of kind: Nat -> Nat -> Nat +mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon +mkTypeNatFunTyCon2 op tcb = + mkFamilyTyCon op + (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ]) + naturalTy + Nothing + (BuiltInSynFamTyCon tcb) + Nothing + NotInjective + +-- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol +mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon +mkTypeSymbolFunTyCon2 op tcb = + mkFamilyTyCon op + (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) + typeSymbolKind + Nothing + (BuiltInSynFamTyCon tcb) + Nothing + NotInjective + +same :: Type -> Type -> Maybe () +same ty1 ty2 = guard (ty1 `tcEqType` ty2) + +known :: Type -> (Integer -> Bool) -> Maybe Integer +known x p = do { nx <- isNumLitTy x; guard (p nx); return nx } + +charToInteger :: Char -> Integer +charToInteger c = fromIntegral (Char.ord c) + +integerToChar :: Integer -> Maybe Char +integerToChar n | inBounds = Just (Char.chr (fromInteger n)) + where inBounds = n >= charToInteger minBound && + n <= charToInteger maxBound +integerToChar _ = Nothing + + +{- ----------------------------------------------------------------------------- +These inverse functions are used for simplifying propositions using +concrete natural numbers. +----------------------------------------------------------------------------- -} + +-- | Subtract two natural numbers. +minus :: Integer -> Integer -> Maybe Integer +minus x y = if x >= y then Just (x - y) else Nothing + +-- | Compute the exact logarithm of a natural number. +-- The logarithm base is the second argument. +logExact :: Integer -> Integer -> Maybe Integer +logExact x y = do (z,True) <- genLog x y + return z + + +-- | Divide two natural numbers. +divide :: Integer -> Integer -> Maybe Integer +divide _ 0 = Nothing +divide x y = case divMod x y of + (a,0) -> Just a + _ -> Nothing + +-- | Compute the exact root of a natural number. +-- The second argument specifies which root we are computing. +rootExact :: Integer -> Integer -> Maybe Integer +rootExact x y = do (z,True) <- genRoot x y + return z + + + +{- | Compute the n-th root of a natural number, rounded down to +the closest natural number. The boolean indicates if the result +is exact (i.e., True means no rounding was done, False means rounded down). +The second argument specifies which root we are computing. -} +genRoot :: Integer -> Integer -> Maybe (Integer, Bool) +genRoot _ 0 = Nothing +genRoot x0 1 = Just (x0, True) +genRoot x0 root = Just (search 0 (x0+1)) + where + search from to = let x = from + div (to - from) 2 + a = x ^ root + in case compare a x0 of + EQ -> (x, True) + LT | x /= from -> search x to + | otherwise -> (from, False) + GT | x /= to -> search from x + | otherwise -> (from, False) + +{- | Compute the logarithm of a number in the given base, rounded down to the +closest integer. The boolean indicates if we the result is exact +(i.e., True means no rounding happened, False means we rounded down). +The logarithm base is the second argument. -} +genLog :: Integer -> Integer -> Maybe (Integer, Bool) +genLog x 0 = if x == 1 then Just (0, True) else Nothing +genLog _ 1 = Nothing +genLog 0 _ = Nothing +genLog x base = Just (exactLoop 0 x) + where + exactLoop s i + | i == 1 = (s,True) + | i < base = (s,False) + | otherwise = + let s1 = s + 1 + in s1 `seq` case divMod i base of + (j,r) + | r == 0 -> exactLoop s1 j + | otherwise -> (underLoop s1 j, False) + + underLoop s i + | i < base = s + | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base) + diff --git a/GHC/Builtin/Types/Prim.hs b/GHC/Builtin/Types/Prim.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Types/Prim.hs @@ -0,0 +1,1440 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + + +Wired-in knowledge about primitive types +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | This module defines TyCons that can't be expressed in Haskell. +-- They are all, therefore, wired-in TyCons. C.f module "GHC.Builtin.Types" +module GHC.Builtin.Types.Prim( + mkTemplateKindVar, mkTemplateKindVars, + mkTemplateTyVars, mkTemplateTyVarsFrom, + mkTemplateKiTyVars, mkTemplateKiTyVar, + + mkTemplateTyConBinders, mkTemplateKindTyConBinders, + mkTemplateAnonTyConBinders, + + alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, + alphaTyVarSpec, betaTyVarSpec, gammaTyVarSpec, deltaTyVarSpec, + alphaTys, alphaTy, betaTy, gammaTy, deltaTy, + alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep, + alphaTysUnliftedRep, alphaTyUnliftedRep, + runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar, + runtimeRep1TyVarInf, runtimeRep2TyVarInf, + runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty, + levity1TyVar, levity2TyVar, + levity1TyVarInf, levity2TyVarInf, + levity1Ty, levity2Ty, + + alphaConstraintTyVar, alphaConstraintTy, + + openAlphaTyVar, openBetaTyVar, openGammaTyVar, + openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec, + openAlphaTy, openBetaTy, openGammaTy, + + levPolyAlphaTyVar, levPolyBetaTyVar, + levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec, + levPolyAlphaTy, levPolyBetaTy, + + multiplicityTyVar1, multiplicityTyVar2, + + -- Kind constructors... + tYPETyCon, tYPETyConName, tYPEKind, + cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind, + + -- Arrows + funTyFlagTyCon, isArrowTyCon, + fUNTyCon, fUNTyConName, + ctArrowTyCon, ctArrowTyConName, + ccArrowTyCon, ccArrowTyConName, + tcArrowTyCon, tcArrowTyConName, + + unexposedPrimTyCons, exposedPrimTyCons, primTyCons, + + charPrimTyCon, charPrimTy, charPrimTyConName, + intPrimTyCon, intPrimTy, intPrimTyConName, + wordPrimTyCon, wordPrimTy, wordPrimTyConName, + addrPrimTyCon, addrPrimTy, addrPrimTyConName, + floatPrimTyCon, floatPrimTy, floatPrimTyConName, + doublePrimTyCon, doublePrimTy, doublePrimTyConName, + + statePrimTyCon, mkStatePrimTy, + realWorldTyCon, realWorldTy, + realWorldStatePrimTy, realWorldMutableByteArrayPrimTy, + + proxyPrimTyCon, mkProxyPrimTy, + + arrayPrimTyCon, mkArrayPrimTy, + byteArrayPrimTyCon, byteArrayPrimTy, + smallArrayPrimTyCon, mkSmallArrayPrimTy, + mutableArrayPrimTyCon, mkMutableArrayPrimTy, + mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy, + smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy, + mutVarPrimTyCon, mkMutVarPrimTy, + + mVarPrimTyCon, mkMVarPrimTy, + tVarPrimTyCon, mkTVarPrimTy, + stablePtrPrimTyCon, mkStablePtrPrimTy, + stableNamePrimTyCon, mkStableNamePrimTy, + compactPrimTyCon, compactPrimTy, + bcoPrimTyCon, bcoPrimTy, + weakPrimTyCon, mkWeakPrimTy, + threadIdPrimTyCon, threadIdPrimTy, + stackSnapshotPrimTyCon, stackSnapshotPrimTy, + promptTagPrimTyCon, mkPromptTagPrimTy, + + int8PrimTyCon, int8PrimTy, int8PrimTyConName, + word8PrimTyCon, word8PrimTy, word8PrimTyConName, + + int16PrimTyCon, int16PrimTy, int16PrimTyConName, + word16PrimTyCon, word16PrimTy, word16PrimTyConName, + + int32PrimTyCon, int32PrimTy, int32PrimTyConName, + word32PrimTyCon, word32PrimTy, word32PrimTyConName, + + int64PrimTyCon, int64PrimTy, int64PrimTyConName, + word64PrimTyCon, word64PrimTy, word64PrimTyConName, + + eqPrimTyCon, -- ty1 ~# ty2 + eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational) + eqPhantPrimTyCon, -- ty1 ~P# ty2 (at role Phantom) + equalityTyCon, + + -- * SIMD +#include "primop-vector-tys-exports.hs-incl" + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Builtin.Types + ( runtimeRepTy, levityTy, unboxedTupleKind, liftedTypeKind, unliftedTypeKind + , boxedRepDataConTyCon, vecRepDataConTyCon + , liftedRepTy, unliftedRepTy, zeroBitRepTy + , intRepDataConTy + , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy + , wordRepDataConTy + , word16RepDataConTy, word8RepDataConTy, word32RepDataConTy, word64RepDataConTy + , addrRepDataConTy + , floatRepDataConTy, doubleRepDataConTy + , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy + , vec64DataConTy + , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy + , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy + , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy + , doubleElemRepDataConTy + , multiplicityTy + , constraintKind ) + +import {-# SOURCE #-} GHC.Types.TyThing( mkATyCon ) +import {-# SOURCE #-} GHC.Core.Type ( mkTyConApp, getLevity ) + +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid + -- import loops which show up if you import Type instead + +import GHC.Types.Var ( TyVarBinder, TyVar,binderVar, binderVars + , mkTyVar, mkTyVarBinder, mkTyVarBinders ) +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Unique + +import GHC.Builtin.Uniques +import GHC.Builtin.Names +import GHC.Utils.Misc ( changeLast ) +import GHC.Utils.Panic ( assertPpr ) +import GHC.Utils.Outputable + +import GHC.Data.FastString +import Data.Char + +{- ********************************************************************* +* * + Building blocks +* * +********************************************************************* -} + +mk_TYPE_app :: Type -> Type +mk_TYPE_app rep = mkTyConApp tYPETyCon [rep] + +mk_CONSTRAINT_app :: Type -> Type +mk_CONSTRAINT_app rep = mkTyConApp cONSTRAINTTyCon [rep] + +mkPrimTc :: FastString -> Unique -> TyCon -> Name +mkPrimTc = mkGenPrimTc UserSyntax + +mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name +mkBuiltInPrimTc = mkGenPrimTc BuiltInSyntax + +mkGenPrimTc :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name +mkGenPrimTc built_in_syntax occ key tycon + = mkWiredInName gHC_PRIM (mkTcOccFS occ) + key + (mkATyCon tycon) + built_in_syntax + +-- | Create a primitive 'TyCon' with the given 'Name', +-- arguments of kind 'Type` with the given 'Role's, +-- and the given result kind representation. +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon :: Name + -> [Role] -> RuntimeRepType -> TyCon +pcPrimTyCon name roles res_rep + = mkPrimTyCon name binders result_kind roles + where + bndr_kis = liftedTypeKind <$ roles + binders = mkTemplateAnonTyConBinders bndr_kis + result_kind = mk_TYPE_app res_rep + +-- | Create a primitive nullary 'TyCon' with the given 'Name' +-- and result kind representation. +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon0 :: Name -> RuntimeRepType -> TyCon +pcPrimTyCon0 name res_rep + = pcPrimTyCon name [] res_rep + +-- | Create a primitive 'TyCon' like 'pcPrimTyCon', except the last +-- argument is levity-polymorphic, where the levity argument is +-- implicit and comes before other arguments +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon_LevPolyLastArg :: Name + -> [Role] -- ^ roles of the arguments (must be non-empty), + -- not including the implicit argument of kind 'Levity', + -- which always has 'Nominal' role + -> RuntimeRepType -- ^ representation of the fully-applied type + -> TyCon +pcPrimTyCon_LevPolyLastArg name roles res_rep + = mkPrimTyCon name binders result_kind (Nominal : roles) + where + result_kind = mk_TYPE_app res_rep + lev_bndr = mkNamedTyConBinder Inferred levity1TyVar + binders = lev_bndr : mkTemplateAnonTyConBinders anon_bndr_kis + lev_tv = mkTyVarTy (binderVar lev_bndr) + + -- [ Type, ..., Type, TYPE (BoxedRep l) ] + anon_bndr_kis = changeLast (liftedTypeKind <$ roles) $ + mk_TYPE_app $ + mkTyConApp boxedRepDataConTyCon [lev_tv] + + +{- ********************************************************************* +* * + Primitive type constructors +* * +********************************************************************* -} + +{- Note Note [Unexposed TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A few primitive TyCons are "unexposed", meaning: +* We don't want users to be able to write them (see #15209); + i.e. they aren't in scope, ever. In particular they do not + appear in the exports of GHC.Prim: see GHC.Builtin.Utils.ghcPrimExports + +* We don't want users to see them in GHCi's @:browse@ output (see #12023). +-} + +primTyCons :: [TyCon] +primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons + +-- | Primitive 'TyCon's that are defined in GHC.Prim but not "exposed". +-- See Note [Unexposed TyCons] +unexposedPrimTyCons :: [TyCon] +unexposedPrimTyCons + = [ eqPrimTyCon -- (~#) + , eqReprPrimTyCon -- (~R#) + , eqPhantPrimTyCon -- (~P#) + + -- These arrows are un-exposed for now + , ctArrowTyCon -- (=>) + , ccArrowTyCon -- (==>) + , tcArrowTyCon -- (-=>) + ] + +-- | Primitive 'TyCon's that are defined in, and exported from, GHC.Prim. +exposedPrimTyCons :: [TyCon] +exposedPrimTyCons + = [ addrPrimTyCon + , arrayPrimTyCon + , byteArrayPrimTyCon + , smallArrayPrimTyCon + , charPrimTyCon + , doublePrimTyCon + , floatPrimTyCon + , intPrimTyCon + , int8PrimTyCon + , int16PrimTyCon + , int32PrimTyCon + , int64PrimTyCon + , bcoPrimTyCon + , weakPrimTyCon + , mutableArrayPrimTyCon + , mutableByteArrayPrimTyCon + , smallMutableArrayPrimTyCon + , mVarPrimTyCon + , tVarPrimTyCon + , mutVarPrimTyCon + , realWorldTyCon + , stablePtrPrimTyCon + , stableNamePrimTyCon + , compactPrimTyCon + , statePrimTyCon + , proxyPrimTyCon + , threadIdPrimTyCon + , wordPrimTyCon + , word8PrimTyCon + , word16PrimTyCon + , word32PrimTyCon + , word64PrimTyCon + , stackSnapshotPrimTyCon + , promptTagPrimTyCon + + , fUNTyCon + , tYPETyCon + , cONSTRAINTTyCon + +#include "primop-vector-tycons.hs-incl" + ] + +charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, + wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, + addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, + statePrimTyConName, proxyPrimTyConName, realWorldTyConName, + arrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, + mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, + smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, + tVarPrimTyConName, stablePtrPrimTyConName, + stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, + weakPrimTyConName, threadIdPrimTyConName, + eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, + stackSnapshotPrimTyConName, promptTagPrimTyConName :: Name +charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon +intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon +int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon +int16PrimTyConName = mkPrimTc (fsLit "Int16#") int16PrimTyConKey int16PrimTyCon +int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon +int64PrimTyConName = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon +wordPrimTyConName = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon +word8PrimTyConName = mkPrimTc (fsLit "Word8#") word8PrimTyConKey word8PrimTyCon +word16PrimTyConName = mkPrimTc (fsLit "Word16#") word16PrimTyConKey word16PrimTyCon +word32PrimTyConName = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon +word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon +addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon +floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon +doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon +statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon +proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon +eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon +eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon +eqPhantPrimTyConName = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKey eqPhantPrimTyCon +realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon +arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon +byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon +smallArrayPrimTyConName = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon +mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon +mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon +smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon +mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon +mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon +tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon +stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon +stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon +compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon +stackSnapshotPrimTyConName = mkPrimTc (fsLit "StackSnapshot#") stackSnapshotPrimTyConKey stackSnapshotPrimTyCon +bcoPrimTyConName = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon +weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon +threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon +promptTagPrimTyConName = mkPrimTc (fsLit "PromptTag#") promptTagPrimTyConKey promptTagPrimTyCon + +{- ********************************************************************* +* * + Type variables +* * +********************************************************************* -} + +{- +alphaTyVars is a list of type variables for use in templates: + ["a", "b", ..., "z", "t1", "t2", ... ] +-} + +mkTemplateKindVar :: Kind -> TyVar +mkTemplateKindVar = mkTyVar (mk_tv_name 0 "k") + +mkTemplateKindVars :: [Kind] -> [TyVar] +-- k0 with unique (mkAlphaTyVarUnique 0) +-- k1 with unique (mkAlphaTyVarUnique 1) +-- ... etc +mkTemplateKindVars [kind] = [mkTemplateKindVar kind] + -- Special case for one kind: just "k" +mkTemplateKindVars kinds + = [ mkTyVar (mk_tv_name u ('k' : show u)) kind + | (kind, u) <- kinds `zip` [0..] ] +mk_tv_name :: Int -> String -> Name +mk_tv_name u s = mkInternalName (mkAlphaTyVarUnique u) + (mkTyVarOccFS (mkFastString s)) + noSrcSpan + +mkTemplateTyVarsFrom :: Int -> [Kind] -> [TyVar] +-- a with unique (mkAlphaTyVarUnique n) +-- b with unique (mkAlphaTyVarUnique n+1) +-- ... etc +-- Typically called as +-- mkTemplateTyVarsFrom (length kv_bndrs) kinds +-- where kv_bndrs are the kind-level binders of a TyCon +mkTemplateTyVarsFrom n kinds + = [ mkTyVar name kind + | (kind, index) <- zip kinds [0..], + let ch_ord = index + ord 'a' + name_str | ch_ord <= ord 'z' = [chr ch_ord] + | otherwise = 't':show index + name = mk_tv_name (index + n) name_str + ] + +mkTemplateTyVars :: [Kind] -> [TyVar] +mkTemplateTyVars = mkTemplateTyVarsFrom 1 + +mkTemplateTyConBinders + :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars + -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] + -- same length as first arg + -- Result is anon arg kinds + -> [TyConBinder] +mkTemplateTyConBinders kind_var_kinds mk_anon_arg_kinds + = kv_bndrs ++ tv_bndrs + where + kv_bndrs = mkTemplateKindTyConBinders kind_var_kinds + anon_kinds = mk_anon_arg_kinds (mkTyVarTys (binderVars kv_bndrs)) + tv_bndrs = mkTemplateAnonTyConBindersFrom (length kv_bndrs) anon_kinds + +mkTemplateKiTyVars + :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars + -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] + -- same length as first arg + -- Result is anon arg kinds [ak1, .., akm] + -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] +-- Example: if you want the tyvars for +-- forall (r::RuntimeRep) (a::TYPE r) (b::Type). blah +-- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, Type]) +mkTemplateKiTyVars kind_var_kinds mk_arg_kinds + = kv_bndrs ++ tv_bndrs + where + kv_bndrs = mkTemplateKindVars kind_var_kinds + anon_kinds = mk_arg_kinds (mkTyVarTys kv_bndrs) + tv_bndrs = mkTemplateTyVarsFrom (length kv_bndrs) anon_kinds + +mkTemplateKiTyVar + :: Kind -- [k1, .., kn] Kind of kind-forall'd var + -> (Kind -> [Kind]) -- Arg is kv1:k1 + -- Result is anon arg kinds [ak1, .., akm] + -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] +-- Example: if you want the tyvars for +-- forall (r::RuntimeRep) (a::TYPE r) (b::Type). blah +-- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, Type]) +mkTemplateKiTyVar kind mk_arg_kinds + = kv_bndr : tv_bndrs + where + kv_bndr = mkTemplateKindVar kind + anon_kinds = mk_arg_kinds (mkTyVarTy kv_bndr) + tv_bndrs = mkTemplateTyVarsFrom 1 anon_kinds + +mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder] +-- Makes named, Specified binders +mkTemplateKindTyConBinders kinds + = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds] + +mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder] +mkTemplateAnonTyConBinders kinds + = mkAnonTyConBinders (mkTemplateTyVars kinds) + +mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder] +mkTemplateAnonTyConBindersFrom n kinds + = mkAnonTyConBinders (mkTemplateTyVarsFrom n kinds) + +alphaTyVars :: [TyVar] +alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind + +alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar +(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars + +alphaTyVarSpec, betaTyVarSpec, gammaTyVarSpec, deltaTyVarSpec :: TyVarBinder +(alphaTyVarSpec:betaTyVarSpec:gammaTyVarSpec:deltaTyVarSpec:_) = mkTyVarBinders Specified alphaTyVars + +alphaConstraintTyVars :: [TyVar] +alphaConstraintTyVars = mkTemplateTyVars $ repeat constraintKind + +alphaConstraintTyVar :: TyVar +(alphaConstraintTyVar:_) = alphaConstraintTyVars + +alphaConstraintTy :: Type +alphaConstraintTy = mkTyVarTy alphaConstraintTyVar + +alphaTys :: [Type] +alphaTys = mkTyVarTys alphaTyVars +alphaTy, betaTy, gammaTy, deltaTy :: Type +(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys + +alphaTyVarsUnliftedRep :: [TyVar] +alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat unliftedTypeKind + +alphaTyVarUnliftedRep :: TyVar +(alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep + +alphaTysUnliftedRep :: [Type] +alphaTysUnliftedRep = mkTyVarTys alphaTyVarsUnliftedRep +alphaTyUnliftedRep :: Type +(alphaTyUnliftedRep:_) = alphaTysUnliftedRep + +runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar :: TyVar +(runtimeRep1TyVar : runtimeRep2TyVar : runtimeRep3TyVar : _) + = drop 16 (mkTemplateTyVars (repeat runtimeRepTy)) -- selects 'q','r' + +runtimeRep1TyVarInf, runtimeRep2TyVarInf :: TyVarBinder +runtimeRep1TyVarInf = mkTyVarBinder Inferred runtimeRep1TyVar +runtimeRep2TyVarInf = mkTyVarBinder Inferred runtimeRep2TyVar + +runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: RuntimeRepType +runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar +runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar +runtimeRep3Ty = mkTyVarTy runtimeRep3TyVar +openAlphaTyVar, openBetaTyVar, openGammaTyVar :: TyVar +-- alpha :: TYPE r1 +-- beta :: TYPE r2 +-- gamma :: TYPE r3 +[openAlphaTyVar,openBetaTyVar,openGammaTyVar] + = mkTemplateTyVars [ mk_TYPE_app runtimeRep1Ty + , mk_TYPE_app runtimeRep2Ty + , mk_TYPE_app runtimeRep3Ty] + +openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec :: TyVarBinder +openAlphaTyVarSpec = mkTyVarBinder Specified openAlphaTyVar +openBetaTyVarSpec = mkTyVarBinder Specified openBetaTyVar +openGammaTyVarSpec = mkTyVarBinder Specified openGammaTyVar + +openAlphaTy, openBetaTy, openGammaTy :: Type +openAlphaTy = mkTyVarTy openAlphaTyVar +openBetaTy = mkTyVarTy openBetaTyVar +openGammaTy = mkTyVarTy openGammaTyVar + +levity1TyVar, levity2TyVar :: TyVar +(levity2TyVar : levity1TyVar : _) -- NB: levity2TyVar before levity1TyVar + = drop 10 (mkTemplateTyVars (repeat levityTy)) -- selects 'k', 'l' +-- The ordering of levity2TyVar before levity1TyVar is chosen so that +-- the more common levity1TyVar uses the levity variable 'l'. + +levity1TyVarInf, levity2TyVarInf :: TyVarBinder +levity1TyVarInf = mkTyVarBinder Inferred levity1TyVar +levity2TyVarInf = mkTyVarBinder Inferred levity2TyVar + +levity1Ty, levity2Ty :: Type +levity1Ty = mkTyVarTy levity1TyVar +levity2Ty = mkTyVarTy levity2TyVar + +levPolyAlphaTyVar, levPolyBetaTyVar :: TyVar +[levPolyAlphaTyVar, levPolyBetaTyVar] = + mkTemplateTyVars + [ mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity1Ty]) + , mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity2Ty])] +-- alpha :: TYPE ('BoxedRep l) +-- beta :: TYPE ('BoxedRep k) + +levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec :: TyVarBinder +levPolyAlphaTyVarSpec = mkTyVarBinder Specified levPolyAlphaTyVar +levPolyBetaTyVarSpec = mkTyVarBinder Specified levPolyBetaTyVar + +levPolyAlphaTy, levPolyBetaTy :: Type +levPolyAlphaTy = mkTyVarTy levPolyAlphaTyVar +levPolyBetaTy = mkTyVarTy levPolyBetaTyVar + +multiplicityTyVar1, multiplicityTyVar2 :: TyVar +(multiplicityTyVar1 : multiplicityTyVar2 : _) + = drop 13 (mkTemplateTyVars (repeat multiplicityTy)) -- selects 'n', 'm' + + +{- +************************************************************************ +* * + FunTyCon +* * +************************************************************************ +-} + +{- Note [Function type constructors and FunTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have four distinct function type constructors, and a type synonym + + FUN :: forall (m :: Multiplicity) -> + forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + TYPE rep1 -> TYPE rep2 -> Type + + (=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + CONSTRAINT rep1 -> TYPE rep2 -> Type + + (==>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + CONSTRAINT rep1 -> CONSTRAINT rep2 -> Constraint + + (-=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + TYPE rep1 -> CONSTRAINT rep2 -> Constraint + + type (->) = FUN Many + +For efficiency, all four are always represented by + FunTy { ft_af :: FunTyFlag, ft_mult :: Mult + , ft_arg :: Type, ft_res :: Type } +rather than by using a TyConApp. + +* The four TyCons FUN, (=>), (==>), (-=>) are all wired in. + But (->) is just a regular synonym, with no special treatment; + in particular it is not wired-in. + +* The ft_af :: FunTyFlag distinguishes the four cases. + See Note [FunTyFlag] in GHC.Types.Var. + +* The ft_af field is redundant: it can always be gleaned from + the kinds of ft_arg and ft_res. See Note [FunTyFlag] in GHC.Types.Var. + +* The ft_mult :: Mult field gives the first argument for FUN + For the other three cases ft_mult is redundant; it is always Many. + Note that of the four type constructors, only `FUN` takes a Multiplicity. + +* Functions in GHC.Core.Type help to build and decompose `FunTy`. + * funTyConAppTy_maybe + * funTyFlagTyCon + * tyConAppFun_maybe + * splitFunTy_maybe + Use them! +-} + +funTyFlagTyCon :: FunTyFlag -> TyCon +-- `anonArgTyCon af` gets the TyCon that corresponds to the `FunTyFlag` +-- But be careful: fUNTyCon has a different kind to the others! +-- See Note [Function type constructors and FunTy] +funTyFlagTyCon FTF_T_T = fUNTyCon +funTyFlagTyCon FTF_T_C = tcArrowTyCon +funTyFlagTyCon FTF_C_T = ctArrowTyCon +funTyFlagTyCon FTF_C_C = ccArrowTyCon + +isArrowTyCon :: TyCon -> Bool +-- We don't bother to look for plain (->), because this function +-- should only be used after unwrapping synonyms +isArrowTyCon tc + = assertPpr (not (isTypeSynonymTyCon tc)) (ppr tc) + getUnique tc `elem` + [fUNTyConKey, ctArrowTyConKey, ccArrowTyConKey, tcArrowTyConKey] + +fUNTyConName, ctArrowTyConName, ccArrowTyConName, tcArrowTyConName :: Name +fUNTyConName = mkPrimTc (fsLit "FUN") fUNTyConKey fUNTyCon +ctArrowTyConName = mkBuiltInPrimTc (fsLit "=>") ctArrowTyConKey ctArrowTyCon +ccArrowTyConName = mkBuiltInPrimTc (fsLit "==>") ccArrowTyConKey ccArrowTyCon +tcArrowTyConName = mkBuiltInPrimTc (fsLit "-=>") tcArrowTyConKey tcArrowTyCon + +-- | The @FUN@ type constructor. +-- +-- @ +-- FUN :: forall (m :: Multiplicity) -> +-- forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- TYPE rep1 -> TYPE rep2 -> Type +-- @ +-- +-- The runtime representations quantification is left inferred. This +-- means they cannot be specified with @-XTypeApplications@. +-- +-- This is a deliberate choice to allow future extensions to the +-- function arrow. +fUNTyCon :: TyCon +fUNTyCon = mkPrimTyCon fUNTyConName tc_bndrs liftedTypeKind tc_roles + where + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar1 + , mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ mk_TYPE_app runtimeRep1Ty + , mk_TYPE_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Nominal, Representational, Representational] + +-- (=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- CONSTRAINT rep1 -> TYPE rep2 -> Type +ctArrowTyCon :: TyCon +ctArrowTyCon = mkPrimTyCon ctArrowTyConName tc_bndrs liftedTypeKind tc_roles + where + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ mk_CONSTRAINT_app runtimeRep1Ty + , mk_TYPE_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Representational, Representational] + +-- (==>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- CONSTRAINT rep1 -> CONSTRAINT rep2 -> Constraint +ccArrowTyCon :: TyCon +ccArrowTyCon = mkPrimTyCon ccArrowTyConName tc_bndrs constraintKind tc_roles + where + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ mk_CONSTRAINT_app runtimeRep1Ty + , mk_CONSTRAINT_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Representational, Representational] + +-- (-=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- TYPE rep1 -> CONSTRAINT rep2 -> Constraint +tcArrowTyCon :: TyCon +tcArrowTyCon = mkPrimTyCon tcArrowTyConName tc_bndrs constraintKind tc_roles + where + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ mk_TYPE_app runtimeRep1Ty + , mk_CONSTRAINT_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Representational, Representational] + +{- +************************************************************************ +* * + Type and Constraint +* * +************************************************************************ + +Note [TYPE and CONSTRAINT] aka Note [Type vs Constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC distinguishes Type from Constraint throughout the compiler. +See GHC Proposal #518, and tickets #21623 and #11715. + +All types that classify values have a kind of the form + (TYPE rr) or (CONSTRAINT rr) +where the `RuntimeRep` parameter, rr, tells us how the value is represented +at runtime. TYPE and CONSTRAINT are primitive type constructors. + +See Note [RuntimeRep polymorphism] about the `rr` parameter. + +There are a bunch of type synonyms and data types defined in the +library ghc-prim:GHC.Types. All of them are also wired in to GHC, in +GHC.Builtin.Types + + type Constraint = CONSTRAINT LiftedRep :: Type + + type Type = TYPE LiftedRep :: Type + type UnliftedType = TYPE UnliftedRep :: Type + + type LiftedRep = BoxedRep Lifted :: RuntimeRep + type UnliftedRep = BoxedRep Unlifted :: RuntimeRep + + data RuntimeRep -- Defined in ghc-prim:GHC.Types + = BoxedRep Levity + | IntRep + | FloatRep + .. etc .. + + data Levity = Lifted | Unlifted + +We abbreviate '*' specially (with -XStarIsType), as if we had this: + type * = Type + +So for example: + Int :: TYPE (BoxedRep Lifted) + Array# Int :: TYPE (BoxedRep Unlifted) + Int# :: TYPE IntRep + Float# :: TYPE FloatRep + Maybe :: TYPE (BoxedRep Lifted) -> TYPE (BoxedRep Lifted) + (# , #) :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2]) + + Eq Int :: CONSTRAINT (BoxedRep Lifted) + IP "foo" Int :: CONSTRAINT (BoxedRep Lifted) + a ~ b :: CONSTRAINT (BoxedRep Lifted) + a ~# b :: CONSTRAINT (TupleRep []) + +Constraints are mostly lifted, but unlifted ones are useful too. +Specifically (a ~# b) :: CONSTRAINT (TupleRep []) + +Wrinkles + +(W1) Type and Constraint are considered distinct throughout GHC. But they + are not /apart/: see Note [Type and Constraint are not apart] + +(W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and + aBSENT_CONSTRAINT_ERROR_ID for types of kind Constraint. + See Note [Type vs Constraint for error ids] in GHC.Core.Make. + Ditto noInlineId vs noInlineConstraintId in GHC.Types.Id.Make; + see Note [inlineId magic]. + +(W3) We need a TypeOrConstraint flag in LitRubbish. + +(W4) In the CPR transformation, we can't unbox constructors with constraint + arguments because unboxed tuples (# …, … #) currently only supports fields + of type TYPE rr. See (CPR2) in Note [Which types are unboxed?] in + GHC.Core.Opt.WorkWrap.Utils. + +Note [Type and Constraint are not apart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type and Constraint are not equal (eqType) but they are not /apart/ +either. Reason (c.f. #7451): + +* We want to allow newtype classes, where + class C a where { op :: a -> a } + +* The axiom for such a class will look like + axiom axC a :: (C a :: Constraint) ~# (a->a :: Type) + +* This axiom connects a type of kind Type with one of kind Constraint + That is dangerous: kindCo (axC Int) :: Type ~N Constraint + And /that/ is bad because we could have + type family F a where + F Type = Int + F Constraint = Bool + So now we can prove Int ~N Bool, and all is lost. We prevent this + by saying that Type and Constraint are not Apart, which makes the + above type family instances illegal. + +So we ensure that Type and Constraint are not apart; or, more +precisely, that TYPE and CONSTRAINT are not apart. This +non-apart-ness check is implemented in GHC.Core.Unify.unify_ty: look +for `maybeApart MARTypeVsConstraint`. + +Note that, as before, nothing prevents writing instances like: + + instance C (Proxy @Type a) where ... + +In particular, TYPE and CONSTRAINT (and the synonyms Type, Constraint +etc) are all allowed in instance heads. It's just that TYPE is not +apart from CONSTRAINT, which means that the above instance would +irretrievably overlap with: + + instance C (Proxy @Constraint a) where ... + +Wrinkles + +(W1) In GHC.Core.RoughMap.roughMatchTyConName we are careful to map + TYPE and CONSTRAINT to the same rough-map key. Reason: + If we insert (F @Constraint tys) into a FamInstEnv, and look + up (F @Type tys'), we /must/ ensure that the (C @Constraint tys) + appears among the unifiables when we do the lookupRM' in + GHC.Core.FamInstEnv.lookup_fam_inst_env'. So for the RoughMap we + simply pretend that they are the same type constructor. If we + don't, we'll treat them as fully apart, which is unsound. + +(W2) We must extend this treatment to the different arrow types (see + Note [Function type constructors and FunTy]): if we have + FunCo (axC Int) :: (C Int => Int) ~ ((Int -> Int) -> Int), + then we could extract an equality between (=>) and (->). We thus + must ensure that (=>) and (->) (among the other arrow combinations) + are not Apart. See the FunTy/FunTy case in GHC.Core.Unify.unify_ty. + +(W3) Are (TYPE IntRep) and (CONSTRAINT WordRep) apart? In truth yes, + they are. But it's easier to say that they are not apart, by + reporting "maybeApart" (which is always safe), rather than + recurse into the arguments (whose kinds may be utterly different) + to look for apartness inside them. Again this is in + GHC.Core.Unify.unify_ty. + +(W4) We give a different Typeable instance for Type than for Constraint. + For type classes instances (unlike type family instances) it is not + /unsound/ for Type and Constraint to treated as fully distinct; and + for Typeable is desirable to give them different TypeReps. + Certainly, + - both Type and Constraint must /have/ a TypeRep, and + - they had better not be the same (else eqTypeRep would give us + a proof Type ~N Constraint, which we do not want + So in GHC.Tc.Instance.Class.matchTypeable, Type and Constraint are + treated as separate TyCons; i.e. given no special treatment. + +Note [RuntimeRep polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, you can't be polymorphic in `RuntimeRep`. E.g + f :: forall (rr::RuntimeRep) (a::TYPE rr). a -> [a] + f = /\(rr::RuntimeRep) (a::rr) \(a::rr). ... +This is no good: we could not generate code for 'f', because the +calling convention for 'f' varies depending on whether the argument is +a a Int, Int#, or Float#. (You could imagine generating specialised +code, one for each instantiation of 'rr', but we don't do that.) + +Certain functions CAN be runtime-rep-polymorphic, because the code +generator never has to manipulate a value of type 'a :: TYPE rr'. + +* error :: forall (rr::RuntimeRep) (a::TYPE rr). String -> a + Code generator never has to manipulate the return value. + +* unsafeCoerce#, defined in Desugar.mkUnsafeCoercePair: + Always inlined to be a no-op + unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b + +* Unboxed tuples, and unboxed sums, defined in GHC.Builtin.Types + Always inlined, and hence specialised to the call site + (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b -> TYPE ('TupleRep '[r1, r2]) +-} + +---------------------- +tYPETyCon :: TyCon +tYPETyCon = mkPrimTyCon tYPETyConName + (mkTemplateAnonTyConBinders [runtimeRepTy]) + liftedTypeKind + [Nominal] + +tYPETyConName :: Name +tYPETyConName = mkPrimTc (fsLit "TYPE") tYPETyConKey tYPETyCon + +tYPEKind :: Type +tYPEKind = mkTyConTy tYPETyCon + +---------------------- +cONSTRAINTTyCon :: TyCon +cONSTRAINTTyCon = mkPrimTyCon cONSTRAINTTyConName + (mkTemplateAnonTyConBinders [runtimeRepTy]) + liftedTypeKind + [Nominal] + +cONSTRAINTTyConName :: Name +cONSTRAINTTyConName = mkPrimTc (fsLit "CONSTRAINT") cONSTRAINTTyConKey cONSTRAINTTyCon + +cONSTRAINTKind :: Type +cONSTRAINTKind = mkTyConTy cONSTRAINTTyCon + + +{- ********************************************************************* +* * + Basic primitive types (Char#, Int#, etc.) +* * +********************************************************************* -} + +charPrimTy :: Type +charPrimTy = mkTyConTy charPrimTyCon +charPrimTyCon :: TyCon +charPrimTyCon = pcPrimTyCon0 charPrimTyConName wordRepDataConTy + +intPrimTy :: Type +intPrimTy = mkTyConTy intPrimTyCon +intPrimTyCon :: TyCon +intPrimTyCon = pcPrimTyCon0 intPrimTyConName intRepDataConTy + +int8PrimTy :: Type +int8PrimTy = mkTyConTy int8PrimTyCon +int8PrimTyCon :: TyCon +int8PrimTyCon = pcPrimTyCon0 int8PrimTyConName int8RepDataConTy + +int16PrimTy :: Type +int16PrimTy = mkTyConTy int16PrimTyCon +int16PrimTyCon :: TyCon +int16PrimTyCon = pcPrimTyCon0 int16PrimTyConName int16RepDataConTy + +int32PrimTy :: Type +int32PrimTy = mkTyConTy int32PrimTyCon +int32PrimTyCon :: TyCon +int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName int32RepDataConTy + +int64PrimTy :: Type +int64PrimTy = mkTyConTy int64PrimTyCon +int64PrimTyCon :: TyCon +int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName int64RepDataConTy + +wordPrimTy :: Type +wordPrimTy = mkTyConTy wordPrimTyCon +wordPrimTyCon :: TyCon +wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName wordRepDataConTy + +word8PrimTy :: Type +word8PrimTy = mkTyConTy word8PrimTyCon +word8PrimTyCon :: TyCon +word8PrimTyCon = pcPrimTyCon0 word8PrimTyConName word8RepDataConTy + +word16PrimTy :: Type +word16PrimTy = mkTyConTy word16PrimTyCon +word16PrimTyCon :: TyCon +word16PrimTyCon = pcPrimTyCon0 word16PrimTyConName word16RepDataConTy + +word32PrimTy :: Type +word32PrimTy = mkTyConTy word32PrimTyCon +word32PrimTyCon :: TyCon +word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName word32RepDataConTy + +word64PrimTy :: Type +word64PrimTy = mkTyConTy word64PrimTyCon +word64PrimTyCon :: TyCon +word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName word64RepDataConTy + +addrPrimTy :: Type +addrPrimTy = mkTyConTy addrPrimTyCon +addrPrimTyCon :: TyCon +addrPrimTyCon = pcPrimTyCon0 addrPrimTyConName addrRepDataConTy + +floatPrimTy :: Type +floatPrimTy = mkTyConTy floatPrimTyCon +floatPrimTyCon :: TyCon +floatPrimTyCon = pcPrimTyCon0 floatPrimTyConName floatRepDataConTy + +doublePrimTy :: Type +doublePrimTy = mkTyConTy doublePrimTyCon +doublePrimTyCon :: TyCon +doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName doubleRepDataConTy + +{- +************************************************************************ +* * + The @State#@ type (and @_RealWorld@ types) +* * +************************************************************************ + +Note [The equality types story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC sports a veritable menagerie of equality types: + + Type or Lifted? Hetero? Role Built in Defining module + class? L/U TyCon +----------------------------------------------------------------------------------------- +~# T U hetero nominal eqPrimTyCon GHC.Prim +~~ C L hetero nominal heqTyCon GHC.Types +~ C L homo nominal eqTyCon GHC.Types +:~: T L homo nominal (not built-in) Data.Type.Equality +:~~: T L hetero nominal (not built-in) Data.Type.Equality + +~R# T U hetero repr eqReprPrimTy GHC.Prim +Coercible C L homo repr coercibleTyCon GHC.Types +Coercion T L homo repr (not built-in) Data.Type.Coercion +~P# T U hetero phantom eqPhantPrimTyCon GHC.Prim + +Recall that "hetero" means the equality can related types of different +kinds. Knowing that (t1 ~# t2) or (t1 ~R# t2) or even that (t1 ~P# t2) +also means that (k1 ~# k2), where (t1 :: k1) and (t2 :: k2). + +To produce less confusion for end users, when not dumping and without +-fprint-equality-relations, each of these groups is printed as the bottommost +listed equality. That is, (~#) and (~~) are both rendered as (~) in +error messages, and (~R#) is rendered as Coercible. + +Let's take these one at a time: + + -------------------------- + (~#) :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[]) + -------------------------- +This is The Type Of Equality in GHC. It classifies nominal coercions. +This type is used in the solver for recording equality constraints. +It responds "yes" to Type.isEqPred and classifies as an EqPred in +Type.classifyPredType. + +All wanted constraints of this type are built with coercion holes. +(See Note [Coercion holes] in GHC.Core.TyCo.Rep.) But see also +Note [Deferred errors for coercion holes] in GHC.Tc.Errors to see how +equality constraints are deferred. + +Within GHC, ~# is called eqPrimTyCon, and it is defined in GHC.Builtin.Types.Prim. + + + -------------------------- + (~~) :: forall k1 k2. k1 -> k2 -> Constraint + -------------------------- +This is (almost) an ordinary class, defined as if by + class a ~# b => a ~~ b + instance a ~# b => a ~~ b +Here's what's unusual about it: + + * We can't actually declare it that way because we don't have syntax for ~#. + And ~# isn't a constraint, so even if we could write it, it wouldn't kind + check. + + * Users cannot write instances of it. + + * It is "naturally coherent". This means that the solver won't hesitate to + solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the + context. (Normally, it waits to learn more, just in case the given + influences what happens next.) See Note [Solving equality classes] + in GHC.Tc.Solver.Dict + + * It always terminates. That is, in the UndecidableInstances checks, we + don't worry if a (~~) constraint is too big, as we know that solving + equality terminates. + +On the other hand, this behaves just like any class w.r.t. eager superclass +unpacking in the solver. So a lifted equality given quickly becomes an unlifted +equality given. This is good, because the solver knows all about unlifted +equalities. There is some special-casing in GHC.Tc.Solver.Dict.matchClassInst to +pretend that there is an instance of this class, as we can't write the instance +in Haskell. + +Within GHC, ~~ is called heqTyCon, and it is defined in GHC.Builtin.Types. + + + -------------------------- + (~) :: forall k. k -> k -> Constraint + -------------------------- +This is /exactly/ like (~~), except with a homogeneous kind. +It is an almost-ordinary class defined as if by + class a ~# b => (a :: k) ~ (b :: k) + instance a ~# b => a ~ b + + * All the bullets for (~~) apply + + * In addition (~) is magical syntax, as ~ is a reserved symbol. + It cannot be exported or imported. + + * The data constructor of the class is "Eq#", not ":C~" + +Within GHC, ~ is called eqTyCon, and it is defined in GHC.Builtin.Types. + +Historical note: prior to July 18 (~) was defined as a + more-ordinary class with (~~) as a superclass. But that made it + special in different ways; and the extra superclass selections to + get from (~) to (~#) via (~~) were tiresome. Now it's defined + uniformly with (~~) and Coercible; much nicer.) + + + -------------------------- + (:~:) :: forall k. k -> k -> * + (:~~:) :: forall k1 k2. k1 -> k2 -> * + -------------------------- +These are perfectly ordinary GADTs, wrapping (~) and (~~) resp. +They are not defined within GHC at all. + + + -------------------------- + (~R#) :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[]) + -------------------------- +The is the representational analogue of ~#. This is the type of representational +equalities that the solver works on. All wanted constraints of this type are +built with coercion holes. + +Within GHC, ~R# is called eqReprPrimTyCon, and it is defined in GHC.Builtin.Types.Prim. + + + -------------------------- + Coercible :: forall k. k -> k -> Constraint + -------------------------- +This is quite like (~~) in the way it's defined and treated within GHC, but +it's homogeneous. Homogeneity helps with type inference (as GHC can solve one +kind from the other) and, in my (Richard's) estimation, will be more intuitive +for users. + +An alternative design included HCoercible (like (~~)) and Coercible (like (~)). +One annoyance was that we want `coerce :: Coercible a b => a -> b`, and +we need the type of coerce to be fully wired-in. So the HCoercible/Coercible +split required that both types be fully wired-in. Instead of doing this, +I just got rid of HCoercible, as I'm not sure who would use it, anyway. + +Within GHC, Coercible is called coercibleTyCon, and it is defined in +GHC.Builtin.Types. + + + -------------------------- + Coercion :: forall k. k -> k -> * + -------------------------- +This is a perfectly ordinary GADT, wrapping Coercible. It is not defined +within GHC at all. + + + -------------------------- + (~P#) :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[]) + -------------------------- +This is the phantom analogue of ~# and it is barely used at all. +(The solver has no idea about this one.) Here is the motivation: + + data Phant a = MkPhant + type role Phant phantom + + Phant _P :: Phant Int ~P# Phant Bool + +We just need to have something to put on that last line. You probably +don't need to worry about it. + + + +Note [The State# TyCon] +~~~~~~~~~~~~~~~~~~~~~~~ +State# is the primitive, unlifted type of states. It has one type parameter, +thus + State# RealWorld +or + State# s + +where s is a type variable. The only purpose of the type parameter is to +keep different state threads separate. It is represented by nothing at all. + +The type parameter to State# is intended to keep separate threads separate. +Even though this parameter is not used in the definition of State#, it is +given role Nominal to enforce its intended use. +-} + +mkStatePrimTy :: Type -> Type +mkStatePrimTy ty = TyConApp statePrimTyCon [ty] + +statePrimTyCon :: TyCon -- See Note [The State# TyCon] +statePrimTyCon = pcPrimTyCon statePrimTyConName [Nominal] zeroBitRepTy + +{- +RealWorld is deeply magical. It is *primitive*, but it is not +*unlifted* (hence ptrArg). We never manipulate values of type +RealWorld; it's only used in the type system, to parameterise State#. +-} + +realWorldTyCon :: TyCon +realWorldTyCon = mkPrimTyCon realWorldTyConName [] liftedTypeKind [] +realWorldTy :: Type +realWorldTy = mkTyConTy realWorldTyCon +realWorldStatePrimTy :: Type +realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld +realWorldMutableByteArrayPrimTy :: Type +realWorldMutableByteArrayPrimTy + = mkMutableByteArrayPrimTy realWorldTy -- MutableByteArray# RealWorld + +mkProxyPrimTy :: Type -> Type -> Type +mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] + +proxyPrimTyCon :: TyCon +proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Phantom] + where + -- Kind: forall k. k -> TYPE (TupleRep '[]) + binders = mkTemplateTyConBinders [liftedTypeKind] id + res_kind = unboxedTupleKind [] + + +{- ********************************************************************* +* * + Primitive equality constraints + See Note [The equality types story] +* * +********************************************************************* -} + +eqPrimTyCon :: TyCon -- The representation type for equality predicates + -- See Note [The equality types story] +eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles + where + -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy] + roles = [Nominal, Nominal, Nominal, Nominal] + +-- like eqPrimTyCon, but the type for *Representational* coercions +-- this should only ever appear as the type of a covar. Its role is +-- interpreted in coercionRole +eqReprPrimTyCon :: TyCon -- See Note [The equality types story] +eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles + where + -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy] + roles = [Nominal, Nominal, Representational, Representational] + +-- like eqPrimTyCon, but the type for *Phantom* coercions. +-- This is only used to make higher-order equalities. Nothing +-- should ever actually have this type! +eqPhantPrimTyCon :: TyCon +eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles + where + -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy] + roles = [Nominal, Nominal, Phantom, Phantom] + +-- | Given a Role, what TyCon is the type of equality predicates at that role? +equalityTyCon :: Role -> TyCon +equalityTyCon Nominal = eqPrimTyCon +equalityTyCon Representational = eqReprPrimTyCon +equalityTyCon Phantom = eqPhantPrimTyCon + +{- ********************************************************************* +* * + The primitive array types +* * +********************************************************************* -} + +arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon, + byteArrayPrimTyCon, + smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon +arrayPrimTyCon = pcPrimTyCon_LevPolyLastArg arrayPrimTyConName [Representational] unliftedRepTy +mutableArrayPrimTyCon = pcPrimTyCon_LevPolyLastArg mutableArrayPrimTyConName [Nominal, Representational] unliftedRepTy +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] unliftedRepTy +byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName unliftedRepTy +smallArrayPrimTyCon = pcPrimTyCon_LevPolyLastArg smallArrayPrimTyConName [Representational] unliftedRepTy +smallMutableArrayPrimTyCon = pcPrimTyCon_LevPolyLastArg smallMutableArrayPrimTyConName [Nominal, Representational] unliftedRepTy + +mkArrayPrimTy :: Type -> Type +mkArrayPrimTy elt = TyConApp arrayPrimTyCon [getLevity elt, elt] +byteArrayPrimTy :: Type +byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon +mkSmallArrayPrimTy :: Type -> Type +mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [getLevity elt, elt] +mkMutableArrayPrimTy :: Type -> Type -> Type +mkMutableArrayPrimTy s elt = TyConApp mutableArrayPrimTyCon [getLevity elt, s, elt] +mkMutableByteArrayPrimTy :: Type -> Type +mkMutableByteArrayPrimTy s = TyConApp mutableByteArrayPrimTyCon [s] +mkSmallMutableArrayPrimTy :: Type -> Type -> Type +mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [getLevity elt, s, elt] + + +{- ********************************************************************* +* * + The mutable variable type +* * +********************************************************************* -} + +mutVarPrimTyCon :: TyCon +mutVarPrimTyCon = pcPrimTyCon_LevPolyLastArg mutVarPrimTyConName [Nominal, Representational] unliftedRepTy + +mkMutVarPrimTy :: Type -> Type -> Type +mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [getLevity elt, s, elt] + +{- +************************************************************************ +* * + The synchronizing variable type +\subsection[TysPrim-synch-var]{The synchronizing variable type} +* * +************************************************************************ +-} + +mVarPrimTyCon :: TyCon +mVarPrimTyCon = pcPrimTyCon_LevPolyLastArg mVarPrimTyConName [Nominal, Representational] unliftedRepTy + +mkMVarPrimTy :: Type -> Type -> Type +mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [getLevity elt, s, elt] + +{- +************************************************************************ +* * + The transactional variable type +* * +************************************************************************ +-} + +tVarPrimTyCon :: TyCon +tVarPrimTyCon = pcPrimTyCon_LevPolyLastArg tVarPrimTyConName [Nominal, Representational] unliftedRepTy + +mkTVarPrimTy :: Type -> Type -> Type +mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [getLevity elt, s, elt] + +{- +************************************************************************ +* * + The stable-pointer type +* * +************************************************************************ +-} + +stablePtrPrimTyCon :: TyCon +stablePtrPrimTyCon = pcPrimTyCon_LevPolyLastArg stablePtrPrimTyConName [Representational] addrRepDataConTy + +mkStablePtrPrimTy :: Type -> Type +mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [getLevity ty, ty] + +{- +************************************************************************ +* * + The stable-name type +* * +************************************************************************ +-} + +stableNamePrimTyCon :: TyCon +stableNamePrimTyCon = pcPrimTyCon_LevPolyLastArg stableNamePrimTyConName [Phantom] unliftedRepTy + +mkStableNamePrimTy :: Type -> Type +mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [getLevity ty, ty] + +{- +************************************************************************ +* * + The Compact NFData (CNF) type +* * +************************************************************************ +-} + +compactPrimTyCon :: TyCon +compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName unliftedRepTy + +compactPrimTy :: Type +compactPrimTy = mkTyConTy compactPrimTyCon + +{- +************************************************************************ +* * + The @StackSnapshot#@ type +* * +************************************************************************ +-} + +stackSnapshotPrimTyCon :: TyCon +stackSnapshotPrimTyCon = pcPrimTyCon0 stackSnapshotPrimTyConName unliftedRepTy + +stackSnapshotPrimTy :: Type +stackSnapshotPrimTy = mkTyConTy stackSnapshotPrimTyCon + + +{- +************************************************************************ +* * + The ``bytecode object'' type +* * +************************************************************************ +-} + +-- Unlike most other primitive types, BCO is lifted. This is because in +-- general a BCO may be a thunk for the reasons given in Note [Updatable CAF +-- BCOs] in GHCi.CreateBCO. +bcoPrimTy :: Type +bcoPrimTy = mkTyConTy bcoPrimTyCon +bcoPrimTyCon :: TyCon +bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName liftedRepTy + +{- +************************************************************************ +* * + The ``weak pointer'' type +* * +************************************************************************ +-} + +weakPrimTyCon :: TyCon +weakPrimTyCon = pcPrimTyCon_LevPolyLastArg weakPrimTyConName [Representational] unliftedRepTy + +mkWeakPrimTy :: Type -> Type +mkWeakPrimTy v = TyConApp weakPrimTyCon [getLevity v, v] + +{- +************************************************************************ +* * + The ``thread id'' type +* * +************************************************************************ + +A thread id is represented by a pointer to the TSO itself, to ensure +that they are always unique and we can always find the TSO for a given +thread id. However, this has the unfortunate consequence that a +ThreadId# for a given thread is treated as a root by the garbage +collector and can keep TSOs around for too long. + +Hence the programmer API for thread manipulation uses a weak pointer +to the thread id internally. +-} + +threadIdPrimTy :: Type +threadIdPrimTy = mkTyConTy threadIdPrimTyCon +threadIdPrimTyCon :: TyCon +threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName unliftedRepTy + +{- +************************************************************************ +* * + The ``prompt tag'' type +* * +************************************************************************ +-} + +promptTagPrimTyCon :: TyCon +promptTagPrimTyCon = pcPrimTyCon promptTagPrimTyConName [Representational] unliftedRepTy + +mkPromptTagPrimTy :: Type -> Type +mkPromptTagPrimTy v = TyConApp promptTagPrimTyCon [v] + +{- +************************************************************************ +* * +\subsection{SIMD vector types} +* * +************************************************************************ +-} + +#include "primop-vector-tys.hs-incl" diff --git a/GHC/Builtin/Uniques.hs b/GHC/Builtin/Uniques.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Uniques.hs @@ -0,0 +1,482 @@ + + +-- | This is where we define a mapping from Uniques to their associated +-- known-key Names for things associated with tuples and sums. We use this +-- mapping while deserializing known-key Names in interface file symbol tables, +-- which are encoded as their Unique. See Note [Symbol table representation of +-- names] for details. +-- + +module GHC.Builtin.Uniques + ( -- * Looking up known-key names + knownUniqueName + + -- * Getting the 'Unique's of 'Name's + -- ** Anonymous sums + , mkSumTyConUnique, mkSumDataConUnique + , isSumTyConUnique + + -- ** Tuples + -- *** Vanilla + , mkTupleTyConUnique + , mkTupleDataConUnique + , isTupleTyConUnique + , isTupleDataConLikeUnique + -- *** Constraint + , mkCTupleTyConUnique + , mkCTupleDataConUnique + , mkCTupleSelIdUnique + , isCTupleTyConUnique + + -- ** Making built-in uniques + , mkAlphaTyVarUnique + , mkPrimOpIdUnique, mkPrimOpWrapperUnique + , mkPreludeMiscIdUnique, mkPreludeDataConUnique + , mkPreludeTyConUnique, mkPreludeClassUnique + + , mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique + , mkCostCentreUnique + + , varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique + , mkFldNSUnique, isFldNSUnique + + , mkBuiltinUnique + , mkPseudoUniqueE + + -- ** Deriving uniques + -- *** From TyCon name uniques + , tyConRepNameUnique + -- *** From DataCon name uniques + , dataConWorkerUnique, dataConTyRepNameUnique + + , initExitJoinUnique + + -- Boxing data types + , mkBoxingTyConUnique, boxingDataConUnique + + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Builtin.Types +import {-# SOURCE #-} GHC.Core.TyCon +import {-# SOURCE #-} GHC.Core.DataCon +import {-# SOURCE #-} GHC.Types.Id +import {-# SOURCE #-} GHC.Types.Name +import GHC.Types.Basic +import GHC.Types.Unique +import GHC.Data.FastString + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Maybe +import GHC.Utils.Word64 (word64ToInt) + +-- | Get the 'Name' associated with a known-key 'Unique'. +knownUniqueName :: Unique -> Maybe Name +knownUniqueName u = + case tag of + 'z' -> Just $ getUnboxedSumName n + '4' -> Just $ getTupleTyConName Boxed n + '5' -> Just $ getTupleTyConName Unboxed n + '7' -> Just $ getTupleDataConName Boxed n + '8' -> Just $ getTupleDataConName Unboxed n + 'j' -> Just $ getCTupleSelIdName n + 'k' -> Just $ getCTupleTyConName n + 'm' -> Just $ getCTupleDataConName n + _ -> Nothing + where + (tag, n') = unpkUnique u + -- Known unique names are guaranteed to fit in Int, so we don't need the whole Word64. + n = assert (isValidKnownKeyUnique u) (word64ToInt n') + +{- +Note [Unique layout for unboxed sums] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Sum arities start from 2. The encoding is a bit funny: we break up the +integral part into bitfields for the arity, an alternative index (which is +taken to be 0xfc in the case of the TyCon), and, in the case of a datacon, a +tag (used to identify the sum's TypeRep binding). + +This layout is chosen to remain compatible with the usual unique allocation +for wired-in data constructors described in GHC.Types.Unique + +TyCon for sum of arity k: + 00000000 kkkkkkkk 11111100 + +TypeRep of TyCon for sum of arity k: + 00000000 kkkkkkkk 11111101 + +DataCon for sum of arity k and alternative n (zero-based): + 00000000 kkkkkkkk nnnnnn00 + +TypeRep for sum DataCon of arity k and alternative n (zero-based): + 00000000 kkkkkkkk nnnnnn10 +-} + +mkSumTyConUnique :: Arity -> Unique +mkSumTyConUnique arity = + assertPpr (arity <= 0x3f) (ppr arity) $ + -- 0x3f since we only have 6 bits to encode the + -- alternative + mkUniqueInt 'z' (arity `shiftL` 8 .|. 0xfc) + +-- | Inverse of 'mkSumTyConUnique' +isSumTyConUnique :: Unique -> Maybe Arity +isSumTyConUnique u = + case (tag, n .&. 0xfc) of + ('z', 0xfc) -> Just (word64ToInt n `shiftR` 8) + _ -> Nothing + where + (tag, n) = unpkUnique u + +mkSumDataConUnique :: ConTagZ -> Arity -> Unique +mkSumDataConUnique alt arity + | alt >= arity + = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity) + | otherwise + = mkUniqueInt 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -} + +getUnboxedSumName :: Int -> Name +getUnboxedSumName n + | n .&. 0xfc == 0xfc + = case tag of + 0x0 -> tyConName $ sumTyCon arity + 0x1 -> getRep $ sumTyCon arity + _ -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag) + | tag == 0x0 + = dataConName $ sumDataCon (alt + 1) arity + | tag == 0x1 + = getName $ dataConWrapId $ sumDataCon (alt + 1) arity + | tag == 0x2 + = getRep $ promoteDataCon $ sumDataCon (alt + 1) arity + | otherwise + = pprPanic "getUnboxedSumName" (ppr n) + where + arity = n `shiftR` 8 + alt = (n .&. 0xfc) `shiftR` 2 + tag = 0x3 .&. n + getRep tycon = + fromMaybe (pprPanic "getUnboxedSumName(getRep)" (ppr tycon)) + $ tyConRepName_maybe tycon + +-- Note [Uniques for tuple type and data constructors] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Wired-in type constructor keys occupy *two* slots: +-- * u: the TyCon itself +-- * u+1: the TyConRepName of the TyCon +-- +-- Wired-in tuple data constructor keys occupy *three* slots: +-- * u: the DataCon itself +-- * u+1: its worker Id +-- * u+2: the TyConRepName of the promoted TyCon + +{- +Note [Unique layout for constraint tuple selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constraint tuples, like boxed and unboxed tuples, have their type and data +constructor Uniques wired in (see +Note [Uniques for tuple type and data constructors]). Constraint tuples are +somewhat more involved, however. For a boxed or unboxed n-tuple, we need: + +* A Unique for the type constructor, and +* A Unique for the data constructor + +With a constraint n-tuple, however, we need: + +* A Unique for the type constructor, +* A Unique for the data constructor, and +* A Unique for each of the n superclass selectors + +To pick a concrete example (n = 2), the binary constraint tuple has a type +constructor and data constructor (%,%) along with superclass selectors +$p1(%,%) and $p2(%,%). + +Just as we wire in the Uniques for constraint tuple type constructors and data +constructors, we wish to wire in the Uniques for the superclass selectors as +well. Not only does this make everything consistent, it also avoids a +compile-time performance penalty whenever GHC.Classes is loaded from an +interface file. This is because GHC.Classes defines constraint tuples as class +definitions, and if these classes weren't wired in, then loading GHC.Classes +would also load every single constraint tuple type constructor, data +constructor, and superclass selector. See #18635. + +We encode the Uniques for constraint tuple superclass selectors as follows. The +integral part of the Unique is broken up into bitfields for the arity and the +position of the superclass. Given a selector for a constraint tuple with +arity n (zero-based) and position k (where 1 <= k <= n), its Unique will look +like: + + 00000000 nnnnnnnn kkkkkkkk + +We can use bit-twiddling tricks to access the arity and position with +cTupleSelIdArityBits and cTupleSelIdPosBitmask, respectively. + +This pattern bears a certain resemblance to the way that the Uniques for +unboxed sums are encoded. This is because for a unboxed sum of arity n, there +are n corresponding data constructors, each with an alternative position k. +Similarly, for a constraint tuple of arity n, there are n corresponding +superclass selectors. Reading Note [Unique layout for unboxed sums] will +instill an appreciation for how the encoding for constraint tuple superclass +selector Uniques takes inspiration from the encoding for unboxed sum Uniques. +-} + +mkCTupleTyConUnique :: Arity -> Unique +mkCTupleTyConUnique a = mkUniqueInt 'k' (2*a) + +mkCTupleDataConUnique :: Arity -> Unique +mkCTupleDataConUnique a = mkUniqueInt 'm' (3*a) + +mkCTupleSelIdUnique :: ConTagZ -> Arity -> Unique +mkCTupleSelIdUnique sc_pos arity + | sc_pos >= arity + = panic ("mkCTupleSelIdUnique: " ++ show sc_pos ++ " >= " ++ show arity) + | otherwise + = mkUniqueInt 'j' (arity `shiftL` cTupleSelIdArityBits + sc_pos) + +-- | Inverse of 'mkCTupleTyConUnique' +isCTupleTyConUnique :: Unique -> Maybe Arity +isCTupleTyConUnique u = + case (tag, i) of + ('k', 0) -> Just arity + _ -> Nothing + where + (tag, n) = unpkUnique u + (arity', i) = quotRem n 2 + arity = word64ToInt arity' + +getCTupleTyConName :: Int -> Name +getCTupleTyConName n = + case n `divMod` 2 of + (arity, 0) -> cTupleTyConName arity + (arity, 1) -> mkPrelTyConRepName $ cTupleTyConName arity + _ -> panic "getCTupleTyConName: impossible" + +getCTupleDataConName :: Int -> Name +getCTupleDataConName n = + case n `divMod` 3 of + (arity, 0) -> cTupleDataConName arity + (arity, 1) -> getName $ dataConWrapId $ cTupleDataCon arity + (arity, 2) -> mkPrelTyConRepName $ cTupleDataConName arity + _ -> panic "getCTupleDataConName: impossible" + +getCTupleSelIdName :: Int -> Name +getCTupleSelIdName n = cTupleSelIdName (sc_pos + 1) arity + where + arity = n `shiftR` cTupleSelIdArityBits + sc_pos = n .&. cTupleSelIdPosBitmask + +-- Given the arity of a constraint tuple, this is the number of bits by which +-- one must shift it to the left in order to encode the arity in the Unique +-- of a superclass selector for that constraint tuple. Alternatively, given the +-- Unique for a constraint tuple superclass selector, this is the number of +-- bits by which one must shift it to the right to retrieve the arity of the +-- constraint tuple. See Note [Unique layout for constraint tuple selectors]. +cTupleSelIdArityBits :: Int +cTupleSelIdArityBits = 8 + +-- Given the Unique for a constraint tuple superclass selector, one can +-- retrieve the position of the selector by ANDing this mask, which will +-- clear all but the eight least significant bits. +-- See Note [Unique layout for constraint tuple selectors]. +cTupleSelIdPosBitmask :: Int +cTupleSelIdPosBitmask = 0xff + +-------------------------------------------------- +-- Normal tuples + +mkTupleDataConUnique :: Boxity -> Arity -> Unique +mkTupleDataConUnique Boxed a = mkUniqueInt '7' (3*a) -- may be used in C labels +mkTupleDataConUnique Unboxed a = mkUniqueInt '8' (3*a) + +mkTupleTyConUnique :: Boxity -> Arity -> Unique +mkTupleTyConUnique Boxed a = mkUniqueInt '4' (2*a) +mkTupleTyConUnique Unboxed a = mkUniqueInt '5' (2*a) + +-- | Inverse of 'mkTupleTyConUnique' +isTupleTyConUnique :: Unique -> Maybe (Boxity, Arity) +isTupleTyConUnique u = + case (tag, i) of + ('4', 0) -> Just (Boxed, arity) + ('5', 0) -> Just (Unboxed, arity) + _ -> Nothing + where + (tag, n) = unpkUnique u + (arity', i) = quotRem n 2 + arity = word64ToInt arity' + +-- | Inverse of 'mkTupleTyDataUnique' that also matches the worker and promoted tycon. +isTupleDataConLikeUnique :: Unique -> Maybe (Boxity, Arity) +isTupleDataConLikeUnique u = + case tag of + '7' -> Just (Boxed, arity) + '8' -> Just (Unboxed, arity) + _ -> Nothing + where + (tag, n) = unpkUnique u + (arity', _) = quotRem n 3 + arity = word64ToInt arity' + +getTupleTyConName :: Boxity -> Int -> Name +getTupleTyConName boxity n = + case n `divMod` 2 of + (arity, 0) -> tyConName $ tupleTyCon boxity arity + (arity, 1) -> fromMaybe (panic "getTupleTyConName") + $ tyConRepName_maybe $ tupleTyCon boxity arity + _ -> panic "getTupleTyConName: impossible" + +getTupleDataConName :: Boxity -> Int -> Name +getTupleDataConName boxity n = + case n `divMod` 3 of + (arity, 0) -> dataConName $ tupleDataCon boxity arity + (arity, 1) -> idName $ dataConWorkId $ tupleDataCon boxity arity + (arity, 2) -> fromMaybe (panic "getTupleDataCon") + $ tyConRepName_maybe $ promotedTupleDataCon boxity arity + _ -> panic "getTupleDataConName: impossible" + +{- +Note [Uniques for wired-in prelude things and known tags] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Allocation of unique supply characters: + v,u: for renumbering value-, and usage- vars. + B: builtin + C-E: pseudo uniques (used in native-code generator) + I: GHCi evaluation + X: uniques from mkLocalUnique + _: unifiable tyvars (above) + 0-9: prelude things below + (no numbers left any more..) + :: (prelude) parallel array data constructors + + other a-z: lower case chars for unique supplies. Used so far: + + a TypeChecking? + b Boxing tycons & datacons + c StgToCmm/Renamer + d desugarer + f AbsC flattener + i TypeChecking interface files + j constraint tuple superclass selectors + k constraint tuple tycons + m constraint tuple datacons + n Native/LLVM codegen + r Hsc name cache + s simplifier + u Cmm pipeline + y GHCi bytecode generator + z anonymous sums + +Note [Related uniques for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* All wired in tycons actually use *two* uniques: + * u: the TyCon itself + * u+1: the TyConRepName of the TyCon (for use with TypeRep) + The "+1" is implemented in tyConRepNameUnique. + If this ever changes, make sure to also change the treatment for boxing tycons. + +* All wired in datacons use *three* uniques: + * u: the DataCon itself + * u+1: its worker Id + * u+2: the TyConRepName of the promoted TyCon + No wired-in datacons have wrappers. + The "+1" is implemented in dataConWorkerUnique and the "+2" is in dataConTyRepNameUnique. + If this ever changes, make sure to also change the treatment for boxing tycons. + +* Because boxing tycons (see Note [Boxing constructors] in GHC.Builtin.Types) + come with both a tycon and a datacon, each one takes up five slots, combining + the two cases above. Getting from the tycon to the datacon (by adding 2) + is implemented in boxingDataConUnique. +-} + +mkAlphaTyVarUnique :: Int -> Unique +mkPreludeClassUnique :: Int -> Unique +mkPrimOpIdUnique :: Int -> Unique +-- See Note [Primop wrappers] in GHC.Builtin.PrimOps. +mkPrimOpWrapperUnique :: Int -> Unique +mkPreludeMiscIdUnique :: Int -> Unique + +mkAlphaTyVarUnique i = mkUniqueInt '1' i +mkPreludeClassUnique i = mkUniqueInt '2' i + +-------------------------------------------------- +mkPrimOpIdUnique op = mkUniqueInt '9' (2*op) +mkPrimOpWrapperUnique op = mkUniqueInt '9' (2*op+1) +mkPreludeMiscIdUnique i = mkUniqueInt '0' i + +mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique + +mkBuiltinUnique i = mkUniqueInt 'B' i +mkPseudoUniqueE i = mkUniqueInt 'E' i -- used in NCG spiller to create spill VirtualRegs + +mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique +mkRegSingleUnique = mkUniqueInt 'R' +mkRegSubUnique = mkUniqueInt 'S' +mkRegPairUnique = mkUniqueInt 'P' +mkRegClassUnique = mkUniqueInt 'L' + +mkCostCentreUnique :: Int -> Unique +mkCostCentreUnique = mkUniqueInt 'C' + +varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique :: Unique +varNSUnique = mkUnique 'i' 0 +dataNSUnique = mkUnique 'd' 0 +tvNSUnique = mkUnique 'v' 0 +tcNSUnique = mkUnique 'c' 0 + +mkFldNSUnique :: FastString -> Unique +mkFldNSUnique fs = mkUniqueInt 'f' (uniqueOfFS fs) + +isFldNSUnique :: Unique -> Bool +isFldNSUnique uniq = case unpkUnique uniq of + (tag, _) -> tag == 'f' + +initExitJoinUnique :: Unique +initExitJoinUnique = mkUnique 's' 0 + +-------------------------------------------------- +-- Wired-in type constructor keys occupy *two* slots: +-- See Note [Related uniques for wired-in things] + +mkPreludeTyConUnique :: Int -> Unique +mkPreludeTyConUnique i = mkUniqueInt '3' (2*i) + +tyConRepNameUnique :: Unique -> Unique +tyConRepNameUnique u = incrUnique u + +-------------------------------------------------- +-- Wired-in data constructor keys occupy *three* slots: +-- See Note [Related uniques for wired-in things] + +mkPreludeDataConUnique :: Int -> Unique +mkPreludeDataConUnique i = mkUniqueInt '6' (3*i) -- Must be alphabetic + +dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique +dataConWorkerUnique u = incrUnique u +dataConTyRepNameUnique u = stepUnique u 2 + +-------------------------------------------------- +-- The data constructors of RuntimeRep occupy *five* slots: +-- See Note [Related uniques for wired-in things] +-- +-- Example: WordRep +-- +-- * u: the TyCon of the boxing data type WordBox +-- * u+1: the TyConRepName of the boxing data type +-- * u+2: the DataCon for MkWordBox +-- * u+3: the worker id for MkWordBox +-- * u+4: the TyConRepName of the promoted TyCon 'MkWordBox +-- +-- Note carefully that +-- * u,u+1 are in sync with the conventions for +-- wired-in type constructors, above +-- * u+2,u+3,u+4 are in sync with the conventions for +-- wired-in data constructors, above +-- A little delicate! + +mkBoxingTyConUnique :: Int -> Unique +mkBoxingTyConUnique i = mkUniqueInt 'b' (5*i) + +boxingDataConUnique :: Unique -> Unique +boxingDataConUnique u = stepUnique u 2 diff --git a/GHC/Builtin/Uniques.hs-boot b/GHC/Builtin/Uniques.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Uniques.hs-boot @@ -0,0 +1,36 @@ +module GHC.Builtin.Uniques where + +import GHC.Prelude +import GHC.Types.Unique +import {-# SOURCE #-} GHC.Types.Name +import GHC.Types.Basic + +-- Needed by GHC.Builtin.Types +knownUniqueName :: Unique -> Maybe Name + +mkSumTyConUnique :: Arity -> Unique +mkSumDataConUnique :: ConTagZ -> Arity -> Unique + +mkCTupleTyConUnique :: Arity -> Unique +mkCTupleDataConUnique :: Arity -> Unique + +mkTupleTyConUnique :: Boxity -> Arity -> Unique +mkTupleDataConUnique :: Boxity -> Arity -> Unique + +mkAlphaTyVarUnique :: Int -> Unique +mkPreludeClassUnique :: Int -> Unique +mkPrimOpIdUnique :: Int -> Unique +mkPrimOpWrapperUnique :: Int -> Unique +mkPreludeMiscIdUnique :: Int -> Unique + +mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique + +mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique + +initExitJoinUnique :: Unique + +mkPreludeTyConUnique :: Int -> Unique +tyConRepNameUnique :: Unique -> Unique + +mkPreludeDataConUnique :: Int -> Unique +dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique diff --git a/GHC/Builtin/Utils.hs b/GHC/Builtin/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Utils.hs @@ -0,0 +1,341 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + + + +-- | The @GHC.Builtin.Utils@ interface to the compiler's prelude knowledge. +-- +-- This module serves as the central gathering point for names which the +-- compiler knows something about. This includes functions for, +-- +-- * discerning whether a 'Name' is known-key +-- +-- * given a 'Unique', looking up its corresponding known-key 'Name' +-- +-- See Note [Known-key names] and Note [About wired-in things] for information +-- about the two types of prelude things in GHC. +-- +module GHC.Builtin.Utils ( + -- * Known-key names + isKnownKeyName, + lookupKnownKeyName, + lookupKnownNameInfo, + + -- ** Internal use + -- | 'knownKeyNames' is exported to seed the original name cache only; + -- if you find yourself wanting to look at it you might consider using + -- 'lookupKnownKeyName' or 'isKnownKeyName'. + knownKeyNames, + + -- * Miscellaneous + wiredInIds, ghcPrimIds, + + ghcPrimExports, + ghcPrimDeclDocs, + ghcPrimWarns, + ghcPrimFixities, + + -- * Random other things + maybeCharLikeCon, maybeIntLikeCon, + + -- * Class categories + isNumericClass, isStandardClass + + ) where + +import GHC.Prelude + +import GHC.Builtin.Uniques +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids +import GHC.Builtin.Types +import GHC.Builtin.Types.Literals ( typeNatTyCons ) +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names.TH ( templateHaskellNames ) +import GHC.Builtin.Names + +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Core.DataCon +import GHC.Core.Class +import GHC.Core.TyCon + +import GHC.Types.Avail +import GHC.Types.Id +import GHC.Types.Fixity +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id.Make +import GHC.Types.SourceText +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Types.TyThing +import GHC.Types.Unique ( isValidKnownKeyUnique, pprUniqueAlways ) + +import GHC.Utils.Outputable +import GHC.Utils.Misc as Utils +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Parser.Annotation +import GHC.Hs.Doc +import GHC.Unit.Module.ModIface (IfaceExport) +import GHC.Unit.Module.Warnings + +import GHC.Data.List.SetOps + +import Control.Applicative ((<|>)) +import Data.Maybe + +{- +************************************************************************ +* * +\subsection[builtinNameInfo]{Lookup built-in names} +* * +************************************************************************ + +Note [About wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Wired-in things are Ids\/TyCons that are completely known to the compiler. + They are global values in GHC, (e.g. listTyCon :: TyCon). + +* A wired-in Name contains the thing itself inside the Name: + see Name.wiredInNameTyThing_maybe + (E.g. listTyConName contains listTyCon. + +* The name cache is initialised with (the names of) all wired-in things + (except tuples and sums; see Note [Infinite families of known-key names]) + +* The type environment itself contains no wired in things. The type + checker sees if the Name is wired in before looking up the name in + the type environment. + +* GHC.Iface.Make prunes out wired-in things before putting them in an interface file. + So interface files never contain wired-in things. +-} + + +-- | This list is used to ensure that when you say "Prelude.map" in your source +-- code, or in an interface file, you get a Name with the correct known key (See +-- Note [Known-key names] in "GHC.Builtin.Names") +knownKeyNames :: [Name] +knownKeyNames + | debugIsOn + , Just badNamesDoc <- knownKeyNamesOkay all_names + = pprPanic "badAllKnownKeyNames" badNamesDoc + | otherwise + = all_names + where + all_names = + concat [ concatMap wired_tycon_kk_names primTyCons + , concatMap wired_tycon_kk_names wiredInTyCons + , concatMap wired_tycon_kk_names typeNatTyCons + , map idName wiredInIds + , map idName allThePrimOpIds + , map (idName . primOpWrapperId) allThePrimOps + , basicKnownKeyNames + , templateHaskellNames + ] + -- All of the names associated with a wired-in TyCon. + -- This includes the TyCon itself, its DataCons and promoted TyCons. + wired_tycon_kk_names :: TyCon -> [Name] + wired_tycon_kk_names tc = + tyConName tc : (rep_names tc ++ implicits) + where implicits = concatMap thing_kk_names (implicitTyConThings tc) + + wired_datacon_kk_names :: DataCon -> [Name] + wired_datacon_kk_names dc = + dataConName dc : rep_names (promoteDataCon dc) + + thing_kk_names :: TyThing -> [Name] + thing_kk_names (ATyCon tc) = wired_tycon_kk_names tc + thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc + thing_kk_names thing = [getName thing] + + -- The TyConRepName for a known-key TyCon has a known key, + -- but isn't itself an implicit thing. Yurgh. + -- NB: if any of the wired-in TyCons had record fields, the record + -- field names would be in a similar situation. Ditto class ops. + -- But it happens that there aren't any + rep_names tc = case tyConRepName_maybe tc of + Just n -> [n] + Nothing -> [] + +-- | Check the known-key names list of consistency. +knownKeyNamesOkay :: [Name] -> Maybe SDoc +knownKeyNamesOkay all_names + | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names + = Just $ text " Out-of-range known-key uniques: " <> + brackets (pprWithCommas (ppr . nameOccName) ns) + | null badNamesPairs + = Nothing + | otherwise + = Just badNamesDoc + where + namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n) + emptyUFM all_names + badNamesEnv = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv + badNamesPairs = nonDetUFMToList badNamesEnv + -- It's OK to use nonDetUFMToList here because the ordering only affects + -- the message when we get a panic + badNamesDoc :: SDoc + badNamesDoc = vcat $ map pairToDoc badNamesPairs + + pairToDoc :: (Unique, [Name]) -> SDoc + pairToDoc (uniq, ns) = text " " <> + pprUniqueAlways uniq <> + text ": " <> + brackets (pprWithCommas (ppr . nameOccName) ns) + +-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a +-- known-key thing. +lookupKnownKeyName :: Unique -> Maybe Name +lookupKnownKeyName u = + knownUniqueName u <|> lookupUFM_Directly knownKeysMap u + +-- | Is a 'Name' known-key? +isKnownKeyName :: Name -> Bool +isKnownKeyName n = + isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap + +-- | Maps 'Unique's to known-key names. +-- +-- The type is @UniqFM Name Name@ to denote that the 'Unique's used +-- in the domain are 'Unique's associated with 'Name's (as opposed +-- to some other namespace of 'Unique's). +knownKeysMap :: UniqFM Name Name +knownKeysMap = listToIdentityUFM knownKeyNames + +-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by +-- GHCi's ':info' command. +lookupKnownNameInfo :: Name -> SDoc +lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of + -- If we do find a doc, we add comment delimiters to make the output + -- of ':info' valid Haskell. + Nothing -> empty + Just doc -> vcat [text "{-", doc, text "-}"] + +-- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390) +knownNamesInfo :: NameEnv SDoc +knownNamesInfo = unitNameEnv coercibleTyConName $ + vcat [ text "Coercible is a special constraint with custom solving rules." + , text "It is not a class." + , text "Please see section `The Coercible constraint`" + , text "of the user's guide for details." ] + +{- +We let a lot of "non-standard" values be visible, so that we can make +sense of them in interface pragmas. It's cool, though they all have +"non-standard" names, so they won't get past the parser in user code. +-} + +{- +************************************************************************ +* * + Export lists for pseudo-modules (GHC.Prim) +* * +************************************************************************ +-} + +ghcPrimExports :: [IfaceExport] +ghcPrimExports + = map (Avail . idName) ghcPrimIds ++ + map (Avail . idName) allThePrimOpIds ++ + [ AvailTC n [n] + | tc <- exposedPrimTyCons, let n = tyConName tc ] + +ghcPrimDeclDocs :: Docs +ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs } + where + findName (nameStr, doc) + | Just name <- lookupFsEnv ghcPrimNames nameStr + = Just (name, [WithHsDocIdentifiers (mkGeneratedHsDocString doc) []]) + | otherwise = Nothing + +ghcPrimNames :: FastStringEnv Name +ghcPrimNames + = mkFsEnv + [ (occNameFS $ nameOccName name, name) + | name <- + map idName ghcPrimIds ++ + map idName allThePrimOpIds ++ + map tyConName exposedPrimTyCons + ] + +-- See Note [GHC.Prim Deprecations] +ghcPrimWarns :: Warnings a +ghcPrimWarns = WarnSome + -- declaration warnings + (map mk_decl_dep primOpDeprecations) + -- export warnings + [] + where + mk_txt msg = + DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []] + mk_decl_dep (occ, msg) = (occ, mk_txt msg) + +ghcPrimFixities :: [(OccName,Fixity)] +ghcPrimFixities = fixities + where + -- The fixity listed here for @`seq`@ should match + -- those in primops.txt.pp (from which Haddock docs are generated). + fixities = (getOccName seqId, Fixity 0 InfixR) + : mapMaybe mkFixity allThePrimOps + mkFixity op = (,) (primOpOcc op) <$> primOpFixity op + +{- +Note [GHC.Prim Docs] +~~~~~~~~~~~~~~~~~~~~ +For haddocks of GHC.Prim we generate a dummy haskell file (gen_hs_source) that +contains the type signatures and the comments (but no implementations) +specifically for consumption by haddock. + +GHCi's :doc command reads directly from ModIface's though, and GHC.Prim has a +wired-in iface that has nothing to do with the above haskell file. The code +below converts primops.txt into an intermediate form that would later be turned +into a proper DeclDocMap. + +We output the docs as a list of pairs (name, docs). We use stringy names here +because mapping names to "Name"s is difficult for things like primtypes and +pseudoops. + +Note [GHC.Prim Deprecations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Like Haddock documentation, we must record deprecation pragmas in two places: +in the GHC.Prim source module consumed by Haddock, and in the +declarations wired-in to GHC. To do the following we generate +GHC.Builtin.PrimOps.primOpDeprecations, a list of (OccName, DeprecationMessage) +pairs. We insert these deprecations into the mi_warns field of GHC.Prim's ModIface, +as though they were written in a source module. +-} + + +{- +************************************************************************ +* * + Built-in keys +* * +************************************************************************ + +ToDo: make it do the ``like'' part properly (as in 0.26 and before). +-} + +maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool +maybeCharLikeCon con = con `hasKey` charDataConKey +maybeIntLikeCon con = con `hasKey` intDataConKey + +{- +************************************************************************ +* * + Class predicates +* * +************************************************************************ +-} + +isNumericClass, isStandardClass :: Class -> Bool + +isNumericClass clas = classKey clas `is_elem` numericClassKeys +isStandardClass clas = classKey clas `is_elem` standardClassKeys + +is_elem :: Eq a => a -> [a] -> Bool +is_elem = isIn "is_X_Class" diff --git a/GHC/Builtin/primops.txt.pp b/GHC/Builtin/primops.txt.pp new file mode 100644 --- /dev/null +++ b/GHC/Builtin/primops.txt.pp @@ -0,0 +1,4488 @@ +----------------------------------------------------------------------- +-- +-- (c) 2010 The University of Glasgow +-- +-- Primitive Operations and Types +-- +-- For more information on PrimOps, see +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/prim-ops +-- +----------------------------------------------------------------------- + +-- This file is processed by the utility program genprimopcode to produce +-- a number of include files within the compiler and optionally to produce +-- human-readable documentation. +-- +-- It should first be preprocessed. +-- +-- Note in particular that Haskell block-style comments are not recognized +-- here, so stick to '--' (even for Notes spanning multiple lines). + +-- Note [GHC.Prim] +-- ~~~~~~~~~~~~~~~ +-- GHC.Prim is a special module: +-- +-- * It can be imported by any module (import GHC.Prim). +-- However, in the future we might change which functions are primitives +-- and which are defined in Haskell. +-- Users should import GHC.Exts, which reexports GHC.Prim and is more stable. +-- In particular, we might move some of the primops to 'foreign import prim' +-- (see ticket #16929 and Note [When do out-of-line primops go in primops.txt.pp]) +-- +-- * It provides primitives of three sorts: +-- - primitive types such as Int64#, MutableByteArray# +-- - primops such as (+#), newTVar#, touch# +-- - pseudoops such as realWorld#, nullAddr# +-- +-- * The pseudoops are described in Note [ghcPrimIds (aka pseudoops)] +-- in GHC.Types.Id.Make. +-- +-- * The primitives (primtypes, primops, pseudoops) cannot be defined in +-- source Haskell. +-- There is no GHC/Prim.hs file with definitions. +-- Instead, we support importing GHC.Prim by manually defining its +-- ModIface (see Iface.Load.ghcPrimIface). +-- +-- * The primitives are listed in this file, primops.txt.pp. +-- It goes through CPP, which creates primops.txt. +-- It is then consumed by the utility program genprimopcode, which produces +-- the following three types of files. +-- +-- 1. The files with extension .hs-incl. +-- They can be found by grepping for hs-incl. +-- They are #included in compiler sources. +-- +-- One of them, primop-data-decl.hs-incl, defines the PrimOp type: +-- data PrimOp +-- = IntAddOp +-- | IntSubOp +-- | CharGtOp +-- | CharGeOp +-- | ... +-- +-- The remaining files define properties of the primops +-- by pattern matching, for example: +-- primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL) +-- primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL) +-- ... +-- This includes fixity, has-side-effects, commutability, +-- IDs used to generate Uniques etc. +-- +-- Additionally, we pattern match on PrimOp when generating Cmm in +-- GHC/StgToCmm/Prim.hs. +-- +-- 2. The dummy Prim.hs file, which is used for Haddock and +-- contains descriptions taken from primops.txt.pp. +-- All definitions are replaced by placeholders. +-- See Note [GHC.Prim Docs] in GHC.Builtin.Utils. +-- +-- 3. The module PrimopWrappers.hs, which wraps every call for GHCi; +-- see Note [Primop wrappers] in GHC.Builtin.Primops for details. +-- +-- * This file does not list internal-only equality types +-- (GHC.Builtin.Types.Prim.unexposedPrimTyCons and coercionToken# +-- in GHC.Types.Id.Make) which are defined but not exported from GHC.Prim. +-- Every export of GHC.Prim should be in listed in this file. +-- +-- * The primitive types should be listed in primTyCons in Builtin.Types.Prim +-- in addition to primops.txt.pp. +-- (This task should be delegated to genprimopcode in the future.) +-- +-- +-- +-- Information on how PrimOps are implemented and the steps necessary to +-- add a new one can be found in the Commentary: +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/prim-ops +-- +-- This file is divided into named sections, each containing or more +-- primop entries. Section headers have the format: +-- +-- section "section-name" {haddock-description} +-- +-- This information is used solely when producing documentation; it is +-- otherwise ignored. The haddock-description is optional. +-- +-- The format of each primop entry is as follows: +-- +-- primop internal-name "name-in-program-text" category type {haddock-description} attributes + +-- The default attribute values which apply if you don't specify +-- other ones. Attribute values can be True, False, or arbitrary +-- text between curly brackets. This is a kludge to enable +-- processors of this file to easily get hold of simple info +-- (eg, out_of_line), whilst avoiding parsing complex expressions +-- needed for strictness info. +-- +-- type refers to the general category of the primop. There are only two: +-- +-- * Compare: A comparison operation of the shape a -> a -> Int# +-- * GenPrimOp: Any other sort of primop +-- + +-- The vector attribute is rather special. It takes a list of 3-tuples, each of +-- which is of the form . ELEM_TYPE is the type of +-- the elements in the vector; LENGTH is the length of the vector; and +-- SCALAR_TYPE is the scalar type used to inject to/project from vector +-- element. Note that ELEM_TYPE and SCALAR_TYPE are not the same; for example, +-- to broadcast a scalar value to a vector whose elements are of type Int8, we +-- use an Int#. + +-- When a primtype or primop has a vector attribute, it is instantiated at each +-- 3-tuple in the list of 3-tuples. That is, the vector attribute allows us to +-- define a family of types or primops. Vector support also adds three new +-- keywords: VECTOR, SCALAR, and VECTUPLE. These keywords are expanded to types +-- derived from the 3-tuple. For the 3-tuple , VECTOR expands to +-- Int64X2#, SCALAR expands to Int64#, and VECTUPLE expands to (# Int64#, Int64# #). + +defaults + effect = NoEffect -- See Note [Classifying primop effects] in GHC.Builtin.PrimOps + can_fail_warning = WarnIfEffectIsCanFail + out_of_line = False -- See Note [When do out-of-line primops go in primops.txt.pp] + commutable = False + code_size = { primOpCodeSizeDefault } + work_free = { primOpCodeSize _thisOp == 0 } + cheap = { primOpOkForSpeculation _thisOp } + strictness = { \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv } + fixity = Nothing + vector = [] + deprecated_msg = {} -- A non-empty message indicates deprecation + div_like = False -- Second argument expected to be non zero - used for tests + defined_bits = Nothing -- The number of bits the operation is defined for (if not all bits) + +-- Note [When do out-of-line primops go in primops.txt.pp] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Out of line primops are those with a C-- implementation. But that +-- doesn't mean they *just* have an C-- implementation. As mentioned in +-- Note [Inlining out-of-line primops and heap checks], some out-of-line +-- primops also have additional internal implementations under certain +-- conditions. Now that `foreign import prim` exists, only those primops +-- which have both internal and external implementations ought to be +-- this file. The rest aren't really primops, since they don't need +-- bespoke compiler support but just a general way to interface with +-- C--. They are just foreign calls. +-- +-- Unfortunately, for the time being most of the primops which should be +-- moved according to the previous paragraph can't yet. There are some +-- superficial restrictions in `foreign import prim` which must be fixed +-- first. Specifically, `foreign import prim` always requires: +-- +-- - No polymorphism in type +-- - `strictness = ` +-- - `effect = ReadWriteEffect` +-- +-- https://gitlab.haskell.org/ghc/ghc/issues/16929 tracks this issue, +-- and has a table of which external-only primops are blocked by which +-- of these. Hopefully those restrictions are relaxed so the rest of +-- those can be moved over. +-- +-- 'module GHC.Prim.Ext is a temporarily "holding ground" for primops +-- that were formally in here, until they can be given a better home. +-- Likewise, their underlying C-- implementation need not live in the +-- RTS either. Best case (in my view), both the C-- and `foreign import +-- prim` can be moved to a small library tailured to the features being +-- implemented and dependencies of those features. + +-- Note [Levity and representation polymorphic primops] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In the types of primops in this module, +-- +-- * The names `a,b,c,s` stand for type variables of kind Type +-- +-- * The names `a_reppoly` and `b_reppoly` stand for representation-polymorphic +-- type variables. For example: +-- op :: a_reppoly -> b_reppoly -> Int +-- really means +-- op :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep} +-- (a :: TYPE rep1) (b :: TYPE rep2). +-- a -> b -> Int +-- +-- Note: +-- - `a_reppoly` and `b_reppoly` have independent `RuntimeRep`s, which +-- are *inferred* type variables. +-- - any use-site of a primop in which the kind of a type appearing in +-- negative position is `a_reppoly` and `b_reppoly` +-- must instantiate the representation to a concrete RuntimeRep. +-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head. +-- - `a_reppoly` and `b_reppoly` share textual names with `a` and `b` (respectively). +-- This means one shouldn't write a type involving both `a` and `a_reppoly`. +-- +-- * The names `a_levpoly` and `b_levpoly` stand for levity-polymorphic +-- type variables, similar to `a_reppoly` and `b_reppoly`. +-- For example: +-- op :: a_levpoly -> b_levpoly -> Int +-- really means +-- op :: forall {l :: Levity} {k :: Levity} +-- (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). +-- a -> b -> Int +-- Note: +-- - `a_levpoly` and `b_levpoly` have independent levities `l` and `k` (respectively), and +-- these are inferred (not specified), as seen from the curly brackets. +-- - any use site of a primop in which `a_levpoly` or `b_levpoly` appear as +-- the kind of a type appearing in negative position in the type of the +-- primop, we require the Levity to be instantiated to a concrete Levity. +-- - `a_levpoly` and `b_levpoly` share textual names with `a` and `b` (respectively). +-- This means one shouldn't write a type involving both `a` and `a_levpoly`, +-- nor `a_levpoly` and `a_reppoly`, etc. + +section "The word size story." + {Haskell98 specifies that signed integers (type 'Int') + must contain at least 30 bits. GHC always implements + 'Int' using the primitive type 'Int#', whose size equals + the @MachDeps.h@ constant @WORD\_SIZE\_IN\_BITS@. + This is normally set based on the RTS @ghcautoconf.h@ parameter + @SIZEOF\_HSWORD@, i.e., 32 bits on 32-bit machines, 64 + bits on 64-bit machines. + + GHC also implements a primitive unsigned integer type + 'Word#' which always has the same number of bits as 'Int#'. + + In addition, GHC supports families of explicit-sized integers + and words at 8, 16, 32, and 64 bits, with the usual + arithmetic operations, comparisons, and a range of + conversions. + + Finally, there are strongly deprecated primops for coercing + between 'Addr#', the primitive type of machine + addresses, and 'Int#'. These are pretty bogus anyway, + but will work on existing 32-bit and 64-bit GHC targets; they + are completely bogus when tag bits are used in 'Int#', + so are not available in this case.} + +------------------------------------------------------------------------ +section "Char#" + {Operations on 31-bit characters.} +------------------------------------------------------------------------ + +primtype Char# + +primop CharGtOp "gtChar#" Compare Char# -> Char# -> Int# +primop CharGeOp "geChar#" Compare Char# -> Char# -> Int# + +primop CharEqOp "eqChar#" Compare + Char# -> Char# -> Int# + with commutable = True + +primop CharNeOp "neChar#" Compare + Char# -> Char# -> Int# + with commutable = True + +primop CharLtOp "ltChar#" Compare Char# -> Char# -> Int# +primop CharLeOp "leChar#" Compare Char# -> Char# -> Int# + +primop OrdOp "ord#" GenPrimOp Char# -> Int# + with code_size = 0 + +------------------------------------------------------------------------ +section "Int8#" + {Operations on 8-bit integers.} +------------------------------------------------------------------------ + +primtype Int8# + +primop Int8ToIntOp "int8ToInt#" GenPrimOp Int8# -> Int# +primop IntToInt8Op "intToInt8#" GenPrimOp Int# -> Int8# + +primop Int8NegOp "negateInt8#" GenPrimOp Int8# -> Int8# + +primop Int8AddOp "plusInt8#" GenPrimOp Int8# -> Int8# -> Int8# + with + commutable = True + +primop Int8SubOp "subInt8#" GenPrimOp Int8# -> Int8# -> Int8# + +primop Int8MulOp "timesInt8#" GenPrimOp Int8# -> Int8# -> Int8# + with + commutable = True + +primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8# + with + effect = CanFail + div_like = True + +primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8# + with + effect = CanFail + div_like = True + + +primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #) + with + effect = CanFail + div_like = True + +primop Int8SllOp "uncheckedShiftLInt8#" GenPrimOp Int8# -> Int# -> Int8# +primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8# +primop Int8SrlOp "uncheckedShiftRLInt8#" GenPrimOp Int8# -> Int# -> Int8# + +primop Int8ToWord8Op "int8ToWord8#" GenPrimOp Int8# -> Word8# + with code_size = 0 + +primop Int8EqOp "eqInt8#" Compare Int8# -> Int8# -> Int# +primop Int8GeOp "geInt8#" Compare Int8# -> Int8# -> Int# +primop Int8GtOp "gtInt8#" Compare Int8# -> Int8# -> Int# +primop Int8LeOp "leInt8#" Compare Int8# -> Int8# -> Int# +primop Int8LtOp "ltInt8#" Compare Int8# -> Int8# -> Int# +primop Int8NeOp "neInt8#" Compare Int8# -> Int8# -> Int# + +------------------------------------------------------------------------ +section "Word8#" + {Operations on 8-bit unsigned words.} +------------------------------------------------------------------------ + +primtype Word8# + +primop Word8ToWordOp "word8ToWord#" GenPrimOp Word8# -> Word# +primop WordToWord8Op "wordToWord8#" GenPrimOp Word# -> Word8# + +primop Word8AddOp "plusWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with + commutable = True + +primop Word8SubOp "subWord8#" GenPrimOp Word8# -> Word8# -> Word8# + +primop Word8MulOp "timesWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with + commutable = True + +primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with + effect = CanFail + div_like = True + +primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with + effect = CanFail + div_like = True + +primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #) + with + effect = CanFail + div_like = True + +primop Word8AndOp "andWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with commutable = True + +primop Word8OrOp "orWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with commutable = True + +primop Word8XorOp "xorWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with commutable = True + +primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8# + +primop Word8SllOp "uncheckedShiftLWord8#" GenPrimOp Word8# -> Int# -> Word8# +primop Word8SrlOp "uncheckedShiftRLWord8#" GenPrimOp Word8# -> Int# -> Word8# + +primop Word8ToInt8Op "word8ToInt8#" GenPrimOp Word8# -> Int8# + with code_size = 0 + +primop Word8EqOp "eqWord8#" Compare Word8# -> Word8# -> Int# +primop Word8GeOp "geWord8#" Compare Word8# -> Word8# -> Int# +primop Word8GtOp "gtWord8#" Compare Word8# -> Word8# -> Int# +primop Word8LeOp "leWord8#" Compare Word8# -> Word8# -> Int# +primop Word8LtOp "ltWord8#" Compare Word8# -> Word8# -> Int# +primop Word8NeOp "neWord8#" Compare Word8# -> Word8# -> Int# + +------------------------------------------------------------------------ +section "Int16#" + {Operations on 16-bit integers.} +------------------------------------------------------------------------ + +primtype Int16# + +primop Int16ToIntOp "int16ToInt#" GenPrimOp Int16# -> Int# +primop IntToInt16Op "intToInt16#" GenPrimOp Int# -> Int16# + +primop Int16NegOp "negateInt16#" GenPrimOp Int16# -> Int16# + +primop Int16AddOp "plusInt16#" GenPrimOp Int16# -> Int16# -> Int16# + with + commutable = True + +primop Int16SubOp "subInt16#" GenPrimOp Int16# -> Int16# -> Int16# + +primop Int16MulOp "timesInt16#" GenPrimOp Int16# -> Int16# -> Int16# + with + commutable = True + +primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16# + with + effect = CanFail + div_like = True + +primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16# + with + effect = CanFail + div_like = True + +primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #) + with + effect = CanFail + div_like = True + +primop Int16SllOp "uncheckedShiftLInt16#" GenPrimOp Int16# -> Int# -> Int16# +primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16# +primop Int16SrlOp "uncheckedShiftRLInt16#" GenPrimOp Int16# -> Int# -> Int16# + +primop Int16ToWord16Op "int16ToWord16#" GenPrimOp Int16# -> Word16# + with code_size = 0 + +primop Int16EqOp "eqInt16#" Compare Int16# -> Int16# -> Int# +primop Int16GeOp "geInt16#" Compare Int16# -> Int16# -> Int# +primop Int16GtOp "gtInt16#" Compare Int16# -> Int16# -> Int# +primop Int16LeOp "leInt16#" Compare Int16# -> Int16# -> Int# +primop Int16LtOp "ltInt16#" Compare Int16# -> Int16# -> Int# +primop Int16NeOp "neInt16#" Compare Int16# -> Int16# -> Int# + +------------------------------------------------------------------------ +section "Word16#" + {Operations on 16-bit unsigned words.} +------------------------------------------------------------------------ + +primtype Word16# + +primop Word16ToWordOp "word16ToWord#" GenPrimOp Word16# -> Word# +primop WordToWord16Op "wordToWord16#" GenPrimOp Word# -> Word16# + +primop Word16AddOp "plusWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with + commutable = True + +primop Word16SubOp "subWord16#" GenPrimOp Word16# -> Word16# -> Word16# + +primop Word16MulOp "timesWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with + commutable = True + +primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with + effect = CanFail + div_like = True + +primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with + effect = CanFail + div_like = True + +primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #) + with + effect = CanFail + div_like = True + +primop Word16AndOp "andWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with commutable = True + +primop Word16OrOp "orWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with commutable = True + +primop Word16XorOp "xorWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with commutable = True + +primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16# + +primop Word16SllOp "uncheckedShiftLWord16#" GenPrimOp Word16# -> Int# -> Word16# +primop Word16SrlOp "uncheckedShiftRLWord16#" GenPrimOp Word16# -> Int# -> Word16# + +primop Word16ToInt16Op "word16ToInt16#" GenPrimOp Word16# -> Int16# + with code_size = 0 + +primop Word16EqOp "eqWord16#" Compare Word16# -> Word16# -> Int# +primop Word16GeOp "geWord16#" Compare Word16# -> Word16# -> Int# +primop Word16GtOp "gtWord16#" Compare Word16# -> Word16# -> Int# +primop Word16LeOp "leWord16#" Compare Word16# -> Word16# -> Int# +primop Word16LtOp "ltWord16#" Compare Word16# -> Word16# -> Int# +primop Word16NeOp "neWord16#" Compare Word16# -> Word16# -> Int# + +------------------------------------------------------------------------ +section "Int32#" + {Operations on 32-bit integers.} +------------------------------------------------------------------------ + +primtype Int32# + +primop Int32ToIntOp "int32ToInt#" GenPrimOp Int32# -> Int# +primop IntToInt32Op "intToInt32#" GenPrimOp Int# -> Int32# + +primop Int32NegOp "negateInt32#" GenPrimOp Int32# -> Int32# + +primop Int32AddOp "plusInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + commutable = True + +primop Int32SubOp "subInt32#" GenPrimOp Int32# -> Int32# -> Int32# + +primop Int32MulOp "timesInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + commutable = True + +primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + effect = CanFail + div_like = True + +primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + effect = CanFail + div_like = True + +primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #) + with + effect = CanFail + div_like = True + +primop Int32SllOp "uncheckedShiftLInt32#" GenPrimOp Int32# -> Int# -> Int32# +primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32# +primop Int32SrlOp "uncheckedShiftRLInt32#" GenPrimOp Int32# -> Int# -> Int32# + +primop Int32ToWord32Op "int32ToWord32#" GenPrimOp Int32# -> Word32# + with code_size = 0 + +primop Int32EqOp "eqInt32#" Compare Int32# -> Int32# -> Int# +primop Int32GeOp "geInt32#" Compare Int32# -> Int32# -> Int# +primop Int32GtOp "gtInt32#" Compare Int32# -> Int32# -> Int# +primop Int32LeOp "leInt32#" Compare Int32# -> Int32# -> Int# +primop Int32LtOp "ltInt32#" Compare Int32# -> Int32# -> Int# +primop Int32NeOp "neInt32#" Compare Int32# -> Int32# -> Int# + +------------------------------------------------------------------------ +section "Word32#" + {Operations on 32-bit unsigned words.} +------------------------------------------------------------------------ + +primtype Word32# + +primop Word32ToWordOp "word32ToWord#" GenPrimOp Word32# -> Word# +primop WordToWord32Op "wordToWord32#" GenPrimOp Word# -> Word32# + +primop Word32AddOp "plusWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + commutable = True + +primop Word32SubOp "subWord32#" GenPrimOp Word32# -> Word32# -> Word32# + +primop Word32MulOp "timesWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + commutable = True + +primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + effect = CanFail + div_like = True + +primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + effect = CanFail + div_like = True + +primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #) + with + effect = CanFail + div_like = True + +primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with commutable = True + +primop Word32OrOp "orWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with commutable = True + +primop Word32XorOp "xorWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with commutable = True + +primop Word32NotOp "notWord32#" GenPrimOp Word32# -> Word32# + +primop Word32SllOp "uncheckedShiftLWord32#" GenPrimOp Word32# -> Int# -> Word32# +primop Word32SrlOp "uncheckedShiftRLWord32#" GenPrimOp Word32# -> Int# -> Word32# + +primop Word32ToInt32Op "word32ToInt32#" GenPrimOp Word32# -> Int32# + with code_size = 0 + +primop Word32EqOp "eqWord32#" Compare Word32# -> Word32# -> Int# +primop Word32GeOp "geWord32#" Compare Word32# -> Word32# -> Int# +primop Word32GtOp "gtWord32#" Compare Word32# -> Word32# -> Int# +primop Word32LeOp "leWord32#" Compare Word32# -> Word32# -> Int# +primop Word32LtOp "ltWord32#" Compare Word32# -> Word32# -> Int# +primop Word32NeOp "neWord32#" Compare Word32# -> Word32# -> Int# + +------------------------------------------------------------------------ +section "Int64#" + {Operations on 64-bit signed words.} +------------------------------------------------------------------------ + +primtype Int64# + +primop Int64ToIntOp "int64ToInt#" GenPrimOp Int64# -> Int# +primop IntToInt64Op "intToInt64#" GenPrimOp Int# -> Int64# + +primop Int64NegOp "negateInt64#" GenPrimOp Int64# -> Int64# + +primop Int64AddOp "plusInt64#" GenPrimOp Int64# -> Int64# -> Int64# + with + commutable = True + +primop Int64SubOp "subInt64#" GenPrimOp Int64# -> Int64# -> Int64# + +primop Int64MulOp "timesInt64#" GenPrimOp Int64# -> Int64# -> Int64# + with + commutable = True + +primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64# + with + effect = CanFail + div_like = True + +primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64# + with + effect = CanFail + div_like = True + +primop Int64SllOp "uncheckedIShiftL64#" GenPrimOp Int64# -> Int# -> Int64# +primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64# +primop Int64SrlOp "uncheckedIShiftRL64#" GenPrimOp Int64# -> Int# -> Int64# + +primop Int64ToWord64Op "int64ToWord64#" GenPrimOp Int64# -> Word64# + with code_size = 0 + +primop Int64EqOp "eqInt64#" Compare Int64# -> Int64# -> Int# +primop Int64GeOp "geInt64#" Compare Int64# -> Int64# -> Int# +primop Int64GtOp "gtInt64#" Compare Int64# -> Int64# -> Int# +primop Int64LeOp "leInt64#" Compare Int64# -> Int64# -> Int# +primop Int64LtOp "ltInt64#" Compare Int64# -> Int64# -> Int# +primop Int64NeOp "neInt64#" Compare Int64# -> Int64# -> Int# + +------------------------------------------------------------------------ +section "Word64#" + {Operations on 64-bit unsigned words.} +------------------------------------------------------------------------ + +primtype Word64# + +primop Word64ToWordOp "word64ToWord#" GenPrimOp Word64# -> Word# +primop WordToWord64Op "wordToWord64#" GenPrimOp Word# -> Word64# + +primop Word64AddOp "plusWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + commutable = True + +primop Word64SubOp "subWord64#" GenPrimOp Word64# -> Word64# -> Word64# + +primop Word64MulOp "timesWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + commutable = True + +primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + effect = CanFail + div_like = True + +primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + effect = CanFail + div_like = True + +primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64# + with commutable = True + +primop Word64OrOp "or64#" GenPrimOp Word64# -> Word64# -> Word64# + with commutable = True + +primop Word64XorOp "xor64#" GenPrimOp Word64# -> Word64# -> Word64# + with commutable = True + +primop Word64NotOp "not64#" GenPrimOp Word64# -> Word64# + +primop Word64SllOp "uncheckedShiftL64#" GenPrimOp Word64# -> Int# -> Word64# +primop Word64SrlOp "uncheckedShiftRL64#" GenPrimOp Word64# -> Int# -> Word64# + +primop Word64ToInt64Op "word64ToInt64#" GenPrimOp Word64# -> Int64# + with code_size = 0 + +primop Word64EqOp "eqWord64#" Compare Word64# -> Word64# -> Int# +primop Word64GeOp "geWord64#" Compare Word64# -> Word64# -> Int# +primop Word64GtOp "gtWord64#" Compare Word64# -> Word64# -> Int# +primop Word64LeOp "leWord64#" Compare Word64# -> Word64# -> Int# +primop Word64LtOp "ltWord64#" Compare Word64# -> Word64# -> Int# +primop Word64NeOp "neWord64#" Compare Word64# -> Word64# -> Int# + +------------------------------------------------------------------------ +section "Int#" + {Operations on native-size integers (32+ bits).} +------------------------------------------------------------------------ + +primtype Int# + +primop IntAddOp "+#" GenPrimOp + Int# -> Int# -> Int# + with commutable = True + fixity = infixl 6 + +primop IntSubOp "-#" GenPrimOp Int# -> Int# -> Int# + with fixity = infixl 6 + +primop IntMulOp "*#" + GenPrimOp Int# -> Int# -> Int# + {Low word of signed integer multiply.} + with commutable = True + fixity = infixl 7 + +primop IntMul2Op "timesInt2#" GenPrimOp + Int# -> Int# -> (# Int#, Int#, Int# #) + {Return a triple (isHighNeeded,high,low) where high and low are respectively + the high and low bits of the double-word result. isHighNeeded is a cheap way + to test if the high word is a sign-extension of the low word (isHighNeeded = + 0#) or not (isHighNeeded = 1#).} + +primop IntMulMayOfloOp "mulIntMayOflo#" + GenPrimOp Int# -> Int# -> Int# + {Return non-zero if there is any possibility that the upper word of a + signed integer multiply might contain useful information. Return + zero only if you are completely sure that no overflow can occur. + On a 32-bit platform, the recommended implementation is to do a + 32 x 32 -> 64 signed multiply, and subtract result[63:32] from + (result[31] >>signed 31). If this is zero, meaning that the + upper word is merely a sign extension of the lower one, no + overflow can occur. + + On a 64-bit platform it is not always possible to + acquire the top 64 bits of the result. Therefore, a recommended + implementation is to take the absolute value of both operands, and + return 0 iff bits[63:31] of them are zero, since that means that their + magnitudes fit within 31 bits, so the magnitude of the product must fit + into 62 bits. + + If in doubt, return non-zero, but do make an effort to create the + correct answer for small args, since otherwise the performance of + @(*) :: Integer -> Integer -> Integer@ will be poor. + } + with commutable = True + +primop IntQuotOp "quotInt#" GenPrimOp + Int# -> Int# -> Int# + {Rounds towards zero. The behavior is undefined if the second argument is + zero. + } + with effect = CanFail + div_like = True + +primop IntRemOp "remInt#" GenPrimOp + Int# -> Int# -> Int# + {Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The + behavior is undefined if the second argument is zero. + } + with effect = CanFail + div_like = True + +primop IntQuotRemOp "quotRemInt#" GenPrimOp + Int# -> Int# -> (# Int#, Int# #) + {Rounds towards zero.} + with effect = CanFail + div_like = True + +primop IntAndOp "andI#" GenPrimOp Int# -> Int# -> Int# + {Bitwise "and".} + with commutable = True + +primop IntOrOp "orI#" GenPrimOp Int# -> Int# -> Int# + {Bitwise "or".} + with commutable = True + +primop IntXorOp "xorI#" GenPrimOp Int# -> Int# -> Int# + {Bitwise "xor".} + with commutable = True + +primop IntNotOp "notI#" GenPrimOp Int# -> Int# + {Bitwise "not", also known as the binary complement.} + +primop IntNegOp "negateInt#" GenPrimOp Int# -> Int# + {Unary negation. + Since the negative 'Int#' range extends one further than the + positive range, 'negateInt#' of the most negative number is an + identity operation. This way, 'negateInt#' is always its own inverse.} + +primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Add signed integers reporting overflow. + First member of result is the sum truncated to an 'Int#'; + second member is zero if the true sum fits in an 'Int#', + nonzero if overflow occurred (the sum is either too large + or too small to fit in an 'Int#').} + with code_size = 2 + commutable = True + +primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Subtract signed integers reporting overflow. + First member of result is the difference truncated to an 'Int#'; + second member is zero if the true difference fits in an 'Int#', + nonzero if overflow occurred (the difference is either too large + or too small to fit in an 'Int#').} + with code_size = 2 + +primop IntGtOp ">#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop IntGeOp ">=#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop IntEqOp "==#" Compare + Int# -> Int# -> Int# + with commutable = True + fixity = infix 4 + +primop IntNeOp "/=#" Compare + Int# -> Int# -> Int# + with commutable = True + fixity = infix 4 + +primop IntLtOp "<#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop IntLeOp "<=#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop ChrOp "chr#" GenPrimOp Int# -> Char# + with code_size = 0 + +primop IntToWordOp "int2Word#" GenPrimOp Int# -> Word# + with code_size = 0 + +primop IntToFloatOp "int2Float#" GenPrimOp Int# -> Float# + {Convert an 'Int#' to the corresponding 'Float#' with the same + integral value (up to truncation due to floating-point precision). e.g. + @'int2Float#' 1# == 1.0#@} +primop IntToDoubleOp "int2Double#" GenPrimOp Int# -> Double# + {Convert an 'Int#' to the corresponding 'Double#' with the same + integral value (up to truncation due to floating-point precision). e.g. + @'int2Double#' 1# == 1.0##@} + +primop WordToFloatOp "word2Float#" GenPrimOp Word# -> Float# + {Convert an 'Word#' to the corresponding 'Float#' with the same + integral value (up to truncation due to floating-point precision). e.g. + @'word2Float#' 1## == 1.0#@} +primop WordToDoubleOp "word2Double#" GenPrimOp Word# -> Double# + {Convert an 'Word#' to the corresponding 'Double#' with the same + integral value (up to truncation due to floating-point precision). e.g. + @'word2Double#' 1## == 1.0##@} + +primop IntSllOp "uncheckedIShiftL#" GenPrimOp Int# -> Int# -> Int# + {Shift left. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop IntSraOp "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int# + {Shift right arithmetic. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop IntSrlOp "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int# + {Shift right logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} + +------------------------------------------------------------------------ +section "Word#" + {Operations on native-sized unsigned words (32+ bits).} +------------------------------------------------------------------------ + +primtype Word# + +primop WordAddOp "plusWord#" GenPrimOp Word# -> Word# -> Word# + with commutable = True + +primop WordAddCOp "addWordC#" GenPrimOp Word# -> Word# -> (# Word#, Int# #) + {Add unsigned integers reporting overflow. + The first element of the pair is the result. The second element is + the carry flag, which is nonzero on overflow. See also 'plusWord2#'.} + with code_size = 2 + commutable = True + +primop WordSubCOp "subWordC#" GenPrimOp Word# -> Word# -> (# Word#, Int# #) + {Subtract unsigned integers reporting overflow. + The first element of the pair is the result. The second element is + the carry flag, which is nonzero on overflow.} + with code_size = 2 + +primop WordAdd2Op "plusWord2#" GenPrimOp Word# -> Word# -> (# Word#, Word# #) + {Add unsigned integers, with the high part (carry) in the first + component of the returned pair and the low part in the second + component of the pair. See also 'addWordC#'.} + with code_size = 2 + commutable = True + +primop WordSubOp "minusWord#" GenPrimOp Word# -> Word# -> Word# + +primop WordMulOp "timesWord#" GenPrimOp Word# -> Word# -> Word# + with commutable = True + +-- Returns (# high, low #) +primop WordMul2Op "timesWord2#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with commutable = True + +primop WordQuotOp "quotWord#" GenPrimOp Word# -> Word# -> Word# + with effect = CanFail + div_like = True + +primop WordRemOp "remWord#" GenPrimOp Word# -> Word# -> Word# + with effect = CanFail + div_like = True + +primop WordQuotRemOp "quotRemWord#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with effect = CanFail + div_like = True + +primop WordQuotRem2Op "quotRemWord2#" GenPrimOp + Word# -> Word# -> Word# -> (# Word#, Word# #) + { Takes high word of dividend, then low word of dividend, then divisor. + Requires that high word < divisor.} + with effect = CanFail + div_like = True + +primop WordAndOp "and#" GenPrimOp Word# -> Word# -> Word# + with commutable = True + +primop WordOrOp "or#" GenPrimOp Word# -> Word# -> Word# + with commutable = True + +primop WordXorOp "xor#" GenPrimOp Word# -> Word# -> Word# + with commutable = True + +primop WordNotOp "not#" GenPrimOp Word# -> Word# + +primop WordSllOp "uncheckedShiftL#" GenPrimOp Word# -> Int# -> Word# + {Shift left logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop WordSrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word# + {Shift right logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} + +primop WordToIntOp "word2Int#" GenPrimOp Word# -> Int# + with code_size = 0 + +primop WordGtOp "gtWord#" Compare Word# -> Word# -> Int# +primop WordGeOp "geWord#" Compare Word# -> Word# -> Int# +primop WordEqOp "eqWord#" Compare Word# -> Word# -> Int# +primop WordNeOp "neWord#" Compare Word# -> Word# -> Int# +primop WordLtOp "ltWord#" Compare Word# -> Word# -> Int# +primop WordLeOp "leWord#" Compare Word# -> Word# -> Int# + +primop PopCnt8Op "popCnt8#" GenPrimOp Word# -> Word# + {Count the number of set bits in the lower 8 bits of a word.} +primop PopCnt16Op "popCnt16#" GenPrimOp Word# -> Word# + {Count the number of set bits in the lower 16 bits of a word.} +primop PopCnt32Op "popCnt32#" GenPrimOp Word# -> Word# + {Count the number of set bits in the lower 32 bits of a word.} +primop PopCnt64Op "popCnt64#" GenPrimOp Word64# -> Word# + {Count the number of set bits in a 64-bit word.} +primop PopCntOp "popCnt#" GenPrimOp Word# -> Word# + {Count the number of set bits in a word.} + +primop Pdep8Op "pdep8#" GenPrimOp Word# -> Word# -> Word# + {Deposit bits to lower 8 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pdep16Op "pdep16#" GenPrimOp Word# -> Word# -> Word# + {Deposit bits to lower 16 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pdep32Op "pdep32#" GenPrimOp Word# -> Word# -> Word# + {Deposit bits to lower 32 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pdep64Op "pdep64#" GenPrimOp Word64# -> Word64# -> Word64# + {Deposit bits to a word at locations specified by a mask. + + @since 0.5.2.0} +primop PdepOp "pdep#" GenPrimOp Word# -> Word# -> Word# + {Deposit bits to a word at locations specified by a mask, aka + [parallel bit deposit](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract). + + Software emulation: + + > pdep :: Word -> Word -> Word + > pdep src mask = go 0 src mask + > where + > go :: Word -> Word -> Word -> Word + > go result _ 0 = result + > go result src mask = go newResult newSrc newMask + > where + > maskCtz = countTrailingZeros mask + > newResult = if testBit src 0 then setBit result maskCtz else result + > newSrc = src `shiftR` 1 + > newMask = clearBit mask maskCtz + + @since 0.5.2.0} + +primop Pext8Op "pext8#" GenPrimOp Word# -> Word# -> Word# + {Extract bits from lower 8 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pext16Op "pext16#" GenPrimOp Word# -> Word# -> Word# + {Extract bits from lower 16 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pext32Op "pext32#" GenPrimOp Word# -> Word# -> Word# + {Extract bits from lower 32 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pext64Op "pext64#" GenPrimOp Word64# -> Word64# -> Word64# + {Extract bits from a word at locations specified by a mask. + + @since 0.5.2.0} +primop PextOp "pext#" GenPrimOp Word# -> Word# -> Word# + {Extract bits from a word at locations specified by a mask, aka + [parallel bit extract](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract). + + Software emulation: + + > pext :: Word -> Word -> Word + > pext src mask = loop 0 0 0 + > where + > loop i count result + > | i >= finiteBitSize (0 :: Word) + > = result + > | testBit mask i + > = loop (i + 1) (count + 1) (if testBit src i then setBit result count else result) + > | otherwise + > = loop (i + 1) count result + + @since 0.5.2.0} + +primop Clz8Op "clz8#" GenPrimOp Word# -> Word# + {Count leading zeros in the lower 8 bits of a word.} +primop Clz16Op "clz16#" GenPrimOp Word# -> Word# + {Count leading zeros in the lower 16 bits of a word.} +primop Clz32Op "clz32#" GenPrimOp Word# -> Word# + {Count leading zeros in the lower 32 bits of a word.} +primop Clz64Op "clz64#" GenPrimOp Word64# -> Word# + {Count leading zeros in a 64-bit word.} +primop ClzOp "clz#" GenPrimOp Word# -> Word# + {Count leading zeros in a word.} + +primop Ctz8Op "ctz8#" GenPrimOp Word# -> Word# + {Count trailing zeros in the lower 8 bits of a word.} +primop Ctz16Op "ctz16#" GenPrimOp Word# -> Word# + {Count trailing zeros in the lower 16 bits of a word.} +primop Ctz32Op "ctz32#" GenPrimOp Word# -> Word# + {Count trailing zeros in the lower 32 bits of a word.} +primop Ctz64Op "ctz64#" GenPrimOp Word64# -> Word# + {Count trailing zeros in a 64-bit word.} +primop CtzOp "ctz#" GenPrimOp Word# -> Word# + {Count trailing zeros in a word.} + +primop BSwap16Op "byteSwap16#" GenPrimOp Word# -> Word# + {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. } + with defined_bits = 16 +primop BSwap32Op "byteSwap32#" GenPrimOp Word# -> Word# + {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. } + with defined_bits = 32 +primop BSwap64Op "byteSwap64#" GenPrimOp Word64# -> Word64# + {Swap bytes in a 64 bits of a word.} +primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word# + {Swap bytes in a word.} + +primop BRev8Op "bitReverse8#" GenPrimOp Word# -> Word# + {Reverse the order of the bits in a 8-bit word.} + with defined_bits = 8 +primop BRev16Op "bitReverse16#" GenPrimOp Word# -> Word# + {Reverse the order of the bits in a 16-bit word.} + with defined_bits = 16 +primop BRev32Op "bitReverse32#" GenPrimOp Word# -> Word# + {Reverse the order of the bits in a 32-bit word.} + with defined_bits = 32 +primop BRev64Op "bitReverse64#" GenPrimOp Word64# -> Word64# + {Reverse the order of the bits in a 64-bit word.} +primop BRevOp "bitReverse#" GenPrimOp Word# -> Word# + {Reverse the order of the bits in a word.} + +------------------------------------------------------------------------ +section "Narrowings" + {Explicit narrowing of native-sized ints or words.} +------------------------------------------------------------------------ + +primop Narrow8IntOp "narrow8Int#" GenPrimOp Int# -> Int# +primop Narrow16IntOp "narrow16Int#" GenPrimOp Int# -> Int# +primop Narrow32IntOp "narrow32Int#" GenPrimOp Int# -> Int# +primop Narrow8WordOp "narrow8Word#" GenPrimOp Word# -> Word# +primop Narrow16WordOp "narrow16Word#" GenPrimOp Word# -> Word# +primop Narrow32WordOp "narrow32Word#" GenPrimOp Word# -> Word# + +------------------------------------------------------------------------ +section "Double#" + {Operations on double-precision (64 bit) floating-point numbers.} +------------------------------------------------------------------------ + +primtype Double# + +primop DoubleGtOp ">##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleGeOp ">=##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleEqOp "==##" Compare + Double# -> Double# -> Int# + with commutable = True + fixity = infix 4 + +primop DoubleNeOp "/=##" Compare + Double# -> Double# -> Int# + with commutable = True + fixity = infix 4 + +primop DoubleLtOp "<##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleLeOp "<=##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleMinOp "minDouble#" GenPrimOp + Double# -> Double# -> Double# + {Return the minimum of the arguments. + When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@) + or one of the arguments is not-a-number (NaN), + it is unspecified which one is returned.} + with commutable = True + +primop DoubleMaxOp "maxDouble#" GenPrimOp + Double# -> Double# -> Double# + {Return the maximum of the arguments. + When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@) + or one of the arguments is not-a-number (NaN), + it is unspecified which one is returned.} + with commutable = True + +primop DoubleAddOp "+##" GenPrimOp + Double# -> Double# -> Double# + with commutable = True + fixity = infixl 6 + +primop DoubleSubOp "-##" GenPrimOp Double# -> Double# -> Double# + with fixity = infixl 6 + +primop DoubleMulOp "*##" GenPrimOp + Double# -> Double# -> Double# + with commutable = True + fixity = infixl 7 + +primop DoubleDivOp "/##" GenPrimOp + Double# -> Double# -> Double# + with effect = CanFail -- Can this one really fail? + fixity = infixl 7 + +primop DoubleNegOp "negateDouble#" GenPrimOp Double# -> Double# + +primop DoubleFabsOp "fabsDouble#" GenPrimOp Double# -> Double# + +primop DoubleToIntOp "double2Int#" GenPrimOp Double# -> Int# + {Truncates a 'Double#' value to the nearest 'Int#'. + Results are undefined if the truncation if truncation yields + a value outside the range of 'Int#'.} + +primop DoubleToFloatOp "double2Float#" GenPrimOp Double# -> Float# + +primop DoubleExpOp "expDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleExpM1Op "expm1Double#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleLogOp "logDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop DoubleLog1POp "log1pDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop DoubleSqrtOp "sqrtDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleSinOp "sinDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleCosOp "cosDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleTanOp "tanDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleAsinOp "asinDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop DoubleAcosOp "acosDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop DoubleAtanOp "atanDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleSinhOp "sinhDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleCoshOp "coshDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleTanhOp "tanhDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleAsinhOp "asinhDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleAcoshOp "acoshDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleAtanhOp "atanhDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoublePowerOp "**##" GenPrimOp + Double# -> Double# -> Double# + {Exponentiation.} + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleDecode_2IntOp "decodeDouble_2Int#" GenPrimOp + Double# -> (# Int#, Word#, Word#, Int# #) + {Convert to integer. + First component of the result is -1 or 1, indicating the sign of the + mantissa. The next two are the high and low 32 bits of the mantissa + respectively, and the last is the exponent.} + with out_of_line = True + +primop DoubleDecode_Int64Op "decodeDouble_Int64#" GenPrimOp + Double# -> (# Int64#, Int# #) + {Decode 'Double#' into mantissa and base-2 exponent.} + with out_of_line = True + +primop CastDoubleToWord64Op "castDoubleToWord64#" GenPrimOp + Double# -> Word64# + {Bitcast a 'Double#' into a 'Word64#'} + +primop CastWord64ToDoubleOp "castWord64ToDouble#" GenPrimOp + Word64# -> Double# + {Bitcast a 'Word64#' into a 'Double#'} + +------------------------------------------------------------------------ +section "Float#" + {Operations on single-precision (32-bit) floating-point numbers.} +------------------------------------------------------------------------ + +primtype Float# + +primop FloatGtOp "gtFloat#" Compare Float# -> Float# -> Int# +primop FloatGeOp "geFloat#" Compare Float# -> Float# -> Int# + +primop FloatEqOp "eqFloat#" Compare + Float# -> Float# -> Int# + with commutable = True + +primop FloatNeOp "neFloat#" Compare + Float# -> Float# -> Int# + with commutable = True + +primop FloatLtOp "ltFloat#" Compare Float# -> Float# -> Int# +primop FloatLeOp "leFloat#" Compare Float# -> Float# -> Int# + +primop FloatMinOp "minFloat#" GenPrimOp + Float# -> Float# -> Float# + {Return the minimum of the arguments. + When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@) + or one of the arguments is not-a-number (NaN), + it is unspecified which one is returned.} + with commutable = True + +primop FloatMaxOp "maxFloat#" GenPrimOp + Float# -> Float# -> Float# + {Return the maximum of the arguments. + When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@) + or one of the arguments is not-a-number (NaN), + it is unspecified which one is returned.} + with commutable = True + +primop FloatAddOp "plusFloat#" GenPrimOp + Float# -> Float# -> Float# + with commutable = True + +primop FloatSubOp "minusFloat#" GenPrimOp Float# -> Float# -> Float# + +primop FloatMulOp "timesFloat#" GenPrimOp + Float# -> Float# -> Float# + with commutable = True + +primop FloatDivOp "divideFloat#" GenPrimOp + Float# -> Float# -> Float# + with effect = CanFail + +primop FloatNegOp "negateFloat#" GenPrimOp Float# -> Float# + +primop FloatFabsOp "fabsFloat#" GenPrimOp Float# -> Float# + +primop FloatToIntOp "float2Int#" GenPrimOp Float# -> Int# + {Truncates a 'Float#' value to the nearest 'Int#'. + Results are undefined if the truncation if truncation yields + a value outside the range of 'Int#'.} + +primop FloatExpOp "expFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatExpM1Op "expm1Float#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatLogOp "logFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop FloatLog1POp "log1pFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop FloatSqrtOp "sqrtFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatSinOp "sinFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatCosOp "cosFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatTanOp "tanFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatAsinOp "asinFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop FloatAcosOp "acosFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop FloatAtanOp "atanFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatSinhOp "sinhFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatCoshOp "coshFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatTanhOp "tanhFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatAsinhOp "asinhFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatAcoshOp "acoshFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatAtanhOp "atanhFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatPowerOp "powerFloat#" GenPrimOp + Float# -> Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatToDoubleOp "float2Double#" GenPrimOp Float# -> Double# + +primop FloatDecode_IntOp "decodeFloat_Int#" GenPrimOp + Float# -> (# Int#, Int# #) + {Convert to integers. + First 'Int#' in result is the mantissa; second is the exponent.} + with out_of_line = True + +primop CastFloatToWord32Op "castFloatToWord32#" GenPrimOp + Float# -> Word32# + {Bitcast a 'Float#' into a 'Word32#'} + +primop CastWord32ToFloatOp "castWord32ToFloat#" GenPrimOp + Word32# -> Float# + {Bitcast a 'Word32#' into a 'Float#'} + +------------------------------------------------------------------------ +section "Fused multiply-add operations" + { #fma# + + The fused multiply-add primops 'fmaddFloat#' and 'fmaddDouble#' + implement the operation + + \[ + \lambda\ x\ y\ z \rightarrow x * y + z + \] + + with a single floating-point rounding operation at the end, as opposed to + rounding twice (which can accumulate rounding errors). + + These primops can be compiled directly to a single machine instruction on + architectures that support them. Currently, these are: + + 1. x86 with CPUs that support the FMA3 extended instruction set (which + includes most processors since 2013). + 2. PowerPC. + 3. AArch64. + + This requires users pass the '-mfma' flag to GHC. Otherwise, the primop + is implemented by falling back to the C standard library, which might + perform software emulation (this may yield results that are not IEEE + compliant on some platforms). + + The additional operations 'fmsubFloat#'/'fmsubDouble#', + 'fnmaddFloat#'/'fnmaddDouble#' and 'fnmsubFloat#'/'fnmsubDouble#' provide + variants on 'fmaddFloat#'/'fmaddDouble#' in which some signs are changed: + + \[ + \begin{aligned} + \mathrm{fmadd}\ x\ y\ z &= \phantom{+} x * y + z \\[8pt] + \mathrm{fmsub}\ x\ y\ z &= \phantom{+} x * y - z \\[8pt] + \mathrm{fnmadd}\ x\ y\ z &= - x * y + z \\[8pt] + \mathrm{fnmsub}\ x\ y\ z &= - x * y - z + \end{aligned} + \] + + } +------------------------------------------------------------------------ + +primop FloatFMAdd "fmaddFloat#" GenPrimOp + Float# -> Float# -> Float# -> Float# + {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".} +primop FloatFMSub "fmsubFloat#" GenPrimOp + Float# -> Float# -> Float# -> Float# + {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".} +primop FloatFNMAdd "fnmaddFloat#" GenPrimOp + Float# -> Float# -> Float# -> Float# + {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".} +primop FloatFNMSub "fnmsubFloat#" GenPrimOp + Float# -> Float# -> Float# -> Float# + {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".} + +primop DoubleFMAdd "fmaddDouble#" GenPrimOp + Double# -> Double# -> Double# -> Double# + {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".} +primop DoubleFMSub "fmsubDouble#" GenPrimOp + Double# -> Double# -> Double# -> Double# + {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".} +primop DoubleFNMAdd "fnmaddDouble#" GenPrimOp + Double# -> Double# -> Double# -> Double# + {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".} +primop DoubleFNMSub "fnmsubDouble#" GenPrimOp + Double# -> Double# -> Double# -> Double# + {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".} + +------------------------------------------------------------------------ +section "Arrays" + {Operations on 'Array#'.} +------------------------------------------------------------------------ + +primtype Array# a + +primtype MutableArray# s a + +primop NewArrayOp "newArray#" GenPrimOp + Int# -> a_levpoly -> State# s -> (# State# s, MutableArray# s a_levpoly #) + {Create a new mutable array with the specified number of elements, + in the specified state thread, + with each element containing the specified initial value.} + with + out_of_line = True + effect = ReadWriteEffect + +primop ReadArrayOp "readArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> State# s -> (# State# s, a_levpoly #) + {Read from specified index of mutable array. Result is not yet evaluated.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop WriteArrayOp "writeArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s + {Write to specified index of mutable array.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = 2 -- card update too + +primop SizeofArrayOp "sizeofArray#" GenPrimOp + Array# a_levpoly -> Int# + {Return the number of elements in the array.} + +primop SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# + {Return the number of elements in the array.} + +primop IndexArrayOp "indexArray#" GenPrimOp + Array# a_levpoly -> Int# -> (# a_levpoly #) + {Read from the specified index of an immutable array. The result is packaged + into an unboxed unary tuple; the result itself is not yet + evaluated. Pattern matching on the tuple forces the indexing of the + array to happen but does not evaluate the element itself. Evaluating + the thunk prevents additional thunks from building up on the + heap. Avoiding these thunks, in turn, reduces references to the + argument array, allowing it to be garbage collected more promptly.} + with + effect = CanFail + +-- Note [primOpEffect of unsafe freezes and thaws] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Mutable and immutable pointer arrays have different info table +-- pointers; this is for the benefit of the garbage collector. +-- Consequently, unsafe freeze/thaw operations on pointer arrays are +-- NOT no-ops: They at least have to update the info table pointer. (For +-- thaw, they also add the array to the mutable set.) +-- +-- We don't want to duplicate this, so these operations are considered +-- to have effect = ReadWriteEffect. +-- +-- (Actually, these operations /are/ no-ops in the JS backend, where +-- mutable and immutable arrays are the same because JS. But we don't +-- have target-dependent primOpEffect yet.) +-- +-- This reasoning does not apply to byte arrays, which the garbage +-- collector can always ignore the contents of. Their unsafe freeze +-- and thaw operations really are no-ops; their underlying heap +-- objects are always ARR_WORDS. + +primop UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp + MutableArray# s a_levpoly -> State# s -> (# State# s, Array# a_levpoly #) + {Make a mutable array immutable, without copying.} + with + effect = ReadWriteEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp + Array# a_levpoly -> State# s -> (# State# s, MutableArray# s a_levpoly #) + {Make an immutable array mutable, without copying.} + with + out_of_line = True + effect = ReadWriteEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +primop CopyArrayOp "copyArray#" GenPrimOp + Array# a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. Both arrays must fully contain the + specified ranges, but this is not checked. The two arrays must not + be the same array in different states, but this is not checked + either.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CopyMutableArrayOp "copyMutableArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. Both arrays must fully contain the + specified ranges, but this is not checked. In the case where + the source and destination are the same array the source and + destination regions may overlap.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CloneArrayOp "cloneArray#" GenPrimOp + Array# a_levpoly -> Int# -> Int# -> Array# a_levpoly + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect -- assumed too expensive to duplicate? + can_fail_warning = YesWarnCanFail + +primop CloneMutableArrayOp "cloneMutableArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FreezeArrayOp "freezeArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, Array# a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop ThawArrayOp "thawArray#" GenPrimOp + Array# a_levpoly -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasArrayOp "casArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #) + {Given an array, an offset, the expected old value, and + the new value, perform an atomic compare and swap (i.e. write the new + value if the current value and the old value are the same pointer). + Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns + the element at the offset after the operation completes. This means that + on a success the new value is returned, and on a failure the actual old + value (not the expected one) is returned. Implies a full memory barrier. + The use of a pointer equality on a boxed value makes this function harder + to use correctly than 'casIntArray#'. All of the difficulties + of using 'reallyUnsafePtrEquality#' correctly apply to + 'casArray#' as well. + } + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + + +------------------------------------------------------------------------ +section "Small Arrays" + + {Operations on 'SmallArray#'. A 'SmallArray#' works + just like an 'Array#', but with different space use and + performance characteristics (that are often useful with small + arrays). The 'SmallArray#' and 'SmallMutableArray#' + lack a `card table'. The purpose of a card table is to avoid + having to scan every element of the array on each GC by + keeping track of which elements have changed since the last GC + and only scanning those that have changed. So the consequence + of there being no card table is that the representation is + somewhat smaller and the writes are somewhat faster (because + the card table does not need to be updated). The disadvantage + of course is that for a 'SmallMutableArray#' the whole + array has to be scanned on each GC. Thus it is best suited for + use cases where the mutable array is not long lived, e.g. + where a mutable array is initialised quickly and then frozen + to become an immutable 'SmallArray#'. + } + +------------------------------------------------------------------------ + +primtype SmallArray# a + +primtype SmallMutableArray# s a + +primop NewSmallArrayOp "newSmallArray#" GenPrimOp + Int# -> a_levpoly -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #) + {Create a new mutable array with the specified number of elements, + in the specified state thread, + with each element containing the specified initial value.} + with + out_of_line = True + effect = ReadWriteEffect + +primop ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> State# s -> State# s + {Shrink mutable array to new specified size, in + the specified state thread. The new size argument must be less than or + equal to the current size as reported by 'getSizeofSmallMutableArray#'. + + Assuming the non-profiling RTS, for the copying garbage collector + (default) this primitive compiles to an O(1) operation in C--, modifying + the array in-place. For the non-moving garbage collector, however, the + time is proportional to the number of elements shrinked out. Backends + bypassing C-- representation (such as JavaScript) might behave + differently. + + @since 0.6.1} + with out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + -- can fail because of the "newSize <= oldSize" requirement + +primop ReadSmallArrayOp "readSmallArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> State# s -> (# State# s, a_levpoly #) + {Read from specified index of mutable array. Result is not yet evaluated.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop WriteSmallArrayOp "writeSmallArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s + {Write to specified index of mutable array.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp + SmallArray# a_levpoly -> Int# + {Return the number of elements in the array.} + +primop SizeofSmallMutableArrayOp "sizeofSmallMutableArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# + {Return the number of elements in the array. __Deprecated__, it is + unsafe in the presence of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@ + operations on the same small mutable array.} + with deprecated_msg = { Use 'getSizeofSmallMutableArray#' instead } + +primop GetSizeofSmallMutableArrayOp "getSizeofSmallMutableArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> State# s -> (# State# s, Int# #) + {Return the number of elements in the array, correctly accounting for + the effect of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@. + + @since 0.6.1} + +primop IndexSmallArrayOp "indexSmallArray#" GenPrimOp + SmallArray# a_levpoly -> Int# -> (# a_levpoly #) + {Read from specified index of immutable array. Result is packaged into + an unboxed singleton; the result itself is not yet evaluated.} + with + effect = CanFail + +primop UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> State# s -> (# State# s, SmallArray# a_levpoly #) + {Make a mutable array immutable, without copying.} + with + effect = ReadWriteEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +primop UnsafeThawSmallArrayOp "unsafeThawSmallArray#" GenPrimOp + SmallArray# a_levpoly -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #) + {Make an immutable array mutable, without copying.} + with + out_of_line = True + effect = ReadWriteEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +-- The code_size is only correct for the case when the copy family of +-- primops aren't inlined. It would be nice to keep track of both. + +primop CopySmallArrayOp "copySmallArray#" GenPrimOp + SmallArray# a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. Both arrays must fully contain the + specified ranges, but this is not checked. The two arrays must not + be the same array in different states, but this is not checked + either.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. The source and destination arrays can + refer to the same array. Both arrays must fully contain the + specified ranges, but this is not checked. + The regions are allowed to overlap, although this is only possible when the same + array is provided as both the source and the destination. } + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CloneSmallArrayOp "cloneSmallArray#" GenPrimOp + SmallArray# a_levpoly -> Int# -> Int# -> SmallArray# a_levpoly + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect -- assumed too expensive to duplicate? + can_fail_warning = YesWarnCanFail + +primop CloneSmallMutableArrayOp "cloneSmallMutableArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FreezeSmallArrayOp "freezeSmallArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallArray# a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop ThawSmallArrayOp "thawSmallArray#" GenPrimOp + SmallArray# a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasSmallArrayOp "casSmallArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #) + {Unsafe, machine-level atomic compare and swap on an element within an array. + See the documentation of 'casArray#'.} + with + out_of_line = True + effect = ReadWriteEffect -- Might index out of bounds + can_fail_warning = YesWarnCanFail + +------------------------------------------------------------------------ +section "Byte Arrays" + {A 'ByteArray#' is a region of + raw memory in the garbage-collected heap, which is not + scanned for pointers. + There are three sets of operations for accessing byte array contents: + index for reading from immutable byte arrays, and read/write + for mutable byte arrays. Each set contains operations for a + range of useful primitive data types. Each operation takes + an offset measured in terms of the size of the primitive type + being read or written. + + } + +------------------------------------------------------------------------ + +primtype ByteArray# +{ + A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap, + which is not scanned for pointers during garbage collection. + + It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'. + Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood. + + The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures, + like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@. + + Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'. + + The representation on the heap of a Byte Array is: + + > +------------+-----------------+-----------------------+ + > | | | | + > | HEADER | SIZE (in bytes) | PAYLOAD | + > | | | | + > +------------+-----------------+-----------------------+ + + To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'. + + Alternatively, enabling the @UnliftedFFITypes@ extension + allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly. +} + +primtype MutableByteArray# s +{ A mutable 'ByteAray#'. It can be created in three ways: + + * 'newByteArray#': Create an unpinned array. + * 'newPinnedByteArray#': This will create a pinned array, + * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment. + + Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values + if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls, + because no garbage collection happens during these unsafe calls + (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety) + in the GHC Manual). For safe FFI calls, byte arrays must be not only pinned, but also kept alive by means of the keepAlive# function + for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether). +} + +primop NewByteArrayOp_Char "newByteArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutableByteArray# s #) + {Create a new mutable byte array of specified size (in bytes), in + the specified state thread. The size of the memory underlying the + array will be rounded up to the platform's word size.} + with out_of_line = True + effect = ReadWriteEffect + +primop NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutableByteArray# s #) + {Like 'newByteArray#' but GC guarantees not to move it.} + with out_of_line = True + effect = ReadWriteEffect + +primop NewAlignedPinnedByteArrayOp_Char "newAlignedPinnedByteArray#" GenPrimOp + Int# -> Int# -> State# s -> (# State# s, MutableByteArray# s #) + {Like 'newPinnedByteArray#' but allow specifying an arbitrary + alignment, which must be a power of two.} + with out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + -- can fail warning for the "power of two" requirement + +primop MutableByteArrayIsPinnedOp "isMutableByteArrayPinned#" GenPrimOp + MutableByteArray# s -> Int# + {Determine whether a 'MutableByteArray#' is guaranteed not to move + during GC.} + with out_of_line = True + +primop ByteArrayIsPinnedOp "isByteArrayPinned#" GenPrimOp + ByteArray# -> Int# + {Determine whether a 'ByteArray#' is guaranteed not to move.} + with out_of_line = True + +primop ByteArrayIsWeaklyPinnedOp "isByteArrayWeaklyPinned#" GenPrimOp + ByteArray# -> Int# + {Similar to 'isByteArrayPinned#'. Weakly pinned byte arrays are allowed + to be copied into compact regions by the user, potentially invalidating + the results of earlier calls to 'byteArrayContents#'. + + See the section `Pinned Byte Arrays` in the user guide for more information. + + This function also returns true for regular pinned bytearrays. + } + with out_of_line = True + +primop MutableByteArrayIsWeaklyPinnedOp "isMutableByteArrayWeaklyPinned#" GenPrimOp + MutableByteArray# s -> Int# + { 'isByteArrayWeaklyPinned#' but for mutable arrays. + } + with out_of_line = True + +primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp + ByteArray# -> Addr# + {Intended for use with pinned arrays; otherwise very unsafe!} + +primop MutableByteArrayContents_Char "mutableByteArrayContents#" GenPrimOp + MutableByteArray# s -> Addr# + {Intended for use with pinned arrays; otherwise very unsafe!} + +primop ShrinkMutableByteArrayOp_Char "shrinkMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + {Shrink mutable byte array to new specified size (in bytes), in + the specified state thread. The new size argument must be less than or + equal to the current size as reported by 'getSizeofMutableByteArray#'. + + Assuming the non-profiling RTS, this primitive compiles to an O(1) + operation in C--, modifying the array in-place. Backends bypassing C-- + representation (such as JavaScript) might behave differently. + + @since 0.4.0.0} + with out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + -- can fail for the "newSize <= oldSize" requirement + +primop ResizeMutableByteArrayOp_Char "resizeMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #) + {Resize mutable byte array to new specified size (in bytes), shrinking or growing it. + The returned 'MutableByteArray#' is either the original + 'MutableByteArray#' resized in-place or, if not possible, a newly + allocated (unpinned) 'MutableByteArray#' (with the original content + copied over). + + To avoid undefined behaviour, the original 'MutableByteArray#' shall + not be accessed anymore after a 'resizeMutableByteArray#' has been + performed. Moreover, no reference to the old one should be kept in order + to allow garbage collection of the original 'MutableByteArray#' in + case a new 'MutableByteArray#' had to be allocated. + + @since 0.4.0.0} + with out_of_line = True + effect = ReadWriteEffect + +primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp + MutableByteArray# s -> State# s -> (# State# s, ByteArray# #) + {Make a mutable byte array immutable, without copying.} + with + code_size = 0 + effect = NoEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +primop UnsafeThawByteArrayOp "unsafeThawByteArray#" GenPrimOp + ByteArray# -> State# s -> (# State# s, MutableByteArray# s #) + {Make an immutable byte array mutable, without copying. + + @since 0.12.0.0} + with + code_size = 0 + effect = NoEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +primop SizeofByteArrayOp "sizeofByteArray#" GenPrimOp + ByteArray# -> Int# + {Return the size of the array in bytes.} + +primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# + {Return the size of the array in bytes. __Deprecated__, it is + unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#' + operations on the same mutable byte + array.} + with deprecated_msg = { Use 'getSizeofMutableByteArray#' instead } + +primop GetSizeofMutableByteArrayOp "getSizeofMutableByteArray#" GenPrimOp + MutableByteArray# s -> State# s -> (# State# s, Int# #) + {Return the number of elements in the array, correctly accounting for + the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'. + + @since 0.5.0.0} + + +bytearray_access_ops +-- This generates a whole bunch of primops; +-- see utils/genprimopcode/AccessOps.hs + + +primop CompareByteArraysOp "compareByteArrays#" GenPrimOp + ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int# + {@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares + @n@ bytes starting at offset @src1_ofs@ in the first + 'ByteArray#' @src1@ to the range of @n@ bytes + (i.e. same length) starting at offset @src2_ofs@ of the second + 'ByteArray#' @src2@. Both arrays must fully contain the + specified ranges, but this is not checked. Returns an 'Int#' + less than, equal to, or greater than zero if the range is found, + respectively, to be byte-wise lexicographically less than, to + match, or be greater than the second range. + + @since 0.5.2.0} + with + effect = CanFail + +primop CopyByteArrayOp "copyByteArray#" GenPrimOp + ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + { @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range + starting at offset @src_ofs@ of length @len@ from the + 'ByteArray#' @src@ to the 'MutableByteArray#' @dst@ + starting at offset @dst_ofs@. Both arrays must fully contain + the specified ranges, but this is not checked. The two arrays must + not be the same array in different states, but this is not checked + either. + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4} + +primop CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + { @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the + range starting at offset @src_ofs@ of length @len@ from the + 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@ + starting at offset @dst_ofs@. Both arrays must fully contain the + specified ranges, but this is not checked. The regions are + allowed to overlap, although this is only possible when the same + array is provided as both the source and the destination. + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CopyMutableByteArrayNonOverlappingOp "copyMutableByteArrayNonOverlapping#" GenPrimOp + MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + { @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@ + copies the range starting at offset @src_ofs@ of length @len@ from + the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@ + starting at offset @dst_ofs@. Both arrays must fully contain the + specified ranges, but this is not checked. The regions are /not/ + allowed to overlap, but this is also not checked. + + @since 0.11.0 + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CopyByteArrayToAddrOp "copyByteArrayToAddr#" GenPrimOp + ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s + {Copy a range of the ByteArray\# to the memory range starting at the Addr\#. + The ByteArray\# and the memory region at Addr\# must fully contain the + specified ranges, but this is not checked. The Addr\# must not point into the + ByteArray\# (e.g. if the ByteArray\# were pinned), but this is not checked + either.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CopyMutableByteArrayToAddrOp "copyMutableByteArrayToAddr#" GenPrimOp + MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s + {Copy a range of the MutableByteArray\# to the memory range starting at the + Addr\#. The MutableByteArray\# and the memory region at Addr\# must fully + contain the specified ranges, but this is not checked. The Addr\# must not + point into the MutableByteArray\# (e.g. if the MutableByteArray\# were + pinned), but this is not checked either.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CopyAddrToByteArrayOp "copyAddrToByteArray#" GenPrimOp + Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Copy a memory range starting at the Addr\# to the specified range in the + MutableByteArray\#. The memory region at Addr\# and the ByteArray\# must fully + contain the specified ranges, but this is not checked. The Addr\# must not + point into the MutableByteArray\# (e.g. if the MutableByteArray\# were pinned), + but this is not checked either.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CopyAddrToAddrOp "copyAddrToAddr#" GenPrimOp + Addr# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld + { @'copyAddrToAddr#' src dest len@ copies @len@ bytes + from @src@ to @dest@. These two memory ranges are allowed to overlap. + + Analogous to the standard C function @memmove@, but with a different + argument order. + + @since 0.11.0 + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall } + +primop CopyAddrToAddrNonOverlappingOp "copyAddrToAddrNonOverlapping#" GenPrimOp + Addr# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld + { @'copyAddrToAddrNonOverlapping#' src dest len@ copies @len@ bytes + from @src@ to @dest@. As the name suggests, these two memory ranges + /must not overlap/, although this pre-condition is not checked. + + Analogous to the standard C function @memcpy@, but with a different + argument order. + + @since 0.11.0 + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall } + +primop SetByteArrayOp "setByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s + {@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of + the 'MutableByteArray#' to the byte @c@.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop SetAddrRangeOp "setAddrRange#" GenPrimOp + Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld + { @'setAddrRange#' dest len c@ sets all of the bytes in + @[dest, dest+len)@ to the value @c@. + + Analogous to the standard C function @memset@, but with a different + argument order. + + @since 0.11.0 + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall } + +-- Atomic operations + +primop AtomicReadByteArrayOp_Int "atomicReadIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) + {Given an array and an offset in machine words, read an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop AtomicWriteByteArrayOp_Int "atomicWriteIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Given an array and an offset in machine words, write an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasByteArrayOp_Int "casIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, an offset in machine words, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasByteArrayOp_Int8 "casInt8Array#" GenPrimOp + MutableByteArray# s -> Int# -> Int8# -> Int8# -> State# s -> (# State# s, Int8# #) + {Given an array, an offset in bytes, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasByteArrayOp_Int16 "casInt16Array#" GenPrimOp + MutableByteArray# s -> Int# -> Int16# -> Int16# -> State# s -> (# State# s, Int16# #) + {Given an array, an offset in 16 bit units, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasByteArrayOp_Int32 "casInt32Array#" GenPrimOp + MutableByteArray# s -> Int# -> Int32# -> Int32# -> State# s -> (# State# s, Int32# #) + {Given an array, an offset in 32 bit units, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasByteArrayOp_Int64 "casInt64Array#" GenPrimOp + MutableByteArray# s -> Int# -> Int64# -> Int64# -> State# s -> (# State# s, Int64# #) + {Given an array, an offset in 64 bit units, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to add, + atomically add the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to subtract, + atomically subtract the value from the element. Returns the value of + the element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to AND, + atomically AND the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to NAND, + atomically NAND the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to OR, + atomically OR the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to XOR, + atomically XOR the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +------------------------------------------------------------------------ +section "Addr#" +------------------------------------------------------------------------ + +primtype Addr# + { An arbitrary machine address assumed to point outside + the garbage-collected heap. } + +pseudoop "nullAddr#" Addr# + { The null address. } + +primop AddrAddOp "plusAddr#" GenPrimOp Addr# -> Int# -> Addr# +primop AddrSubOp "minusAddr#" GenPrimOp Addr# -> Addr# -> Int# + {Result is meaningless if two 'Addr#'s are so far apart that their + difference doesn't fit in an 'Int#'.} +primop AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int# + {Return the remainder when the 'Addr#' arg, treated like an 'Int#', + is divided by the 'Int#' arg.} +primop AddrToIntOp "addr2Int#" GenPrimOp Addr# -> Int# + {Coerce directly from address to int. Users are discouraged from using + this operation as it makes little sense on platforms with tagged pointers.} + with code_size = 0 +primop IntToAddrOp "int2Addr#" GenPrimOp Int# -> Addr# + {Coerce directly from int to address. Users are discouraged from using + this operation as it makes little sense on platforms with tagged pointers.} + with code_size = 0 + +primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Int# +primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Int# +primop AddrEqOp "eqAddr#" Compare Addr# -> Addr# -> Int# +primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Int# +primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Int# +primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Int# + + +addr_access_ops +-- This generates a whole bunch of primops; +-- see utils/genprimopcode/AccessOps.hs + + +primop InterlockedExchange_Addr "atomicExchangeAddrAddr#" GenPrimOp + Addr# -> Addr# -> State# s -> (# State# s, Addr# #) + {The atomic exchange operation. Atomically exchanges the value at the first address + with the Addr# given as second argument. Implies a read barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop InterlockedExchange_Word "atomicExchangeWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {The atomic exchange operation. Atomically exchanges the value at the address + with the given value. Returns the old value. Implies a read barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Addr "atomicCasAddrAddr#" GenPrimOp + Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #) + { Compare and swap on a word-sized memory location. + + Use as: \s -> atomicCasAddrAddr# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Word "atomicCasWordAddr#" GenPrimOp + Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #) + { Compare and swap on a word-sized and aligned memory location. + + Use as: \s -> atomicCasWordAddr# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Word8 "atomicCasWord8Addr#" GenPrimOp + Addr# -> Word8# -> Word8# -> State# s -> (# State# s, Word8# #) + { Compare and swap on a 8 bit-sized and aligned memory location. + + Use as: \s -> atomicCasWordAddr8# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Word16 "atomicCasWord16Addr#" GenPrimOp + Addr# -> Word16# -> Word16# -> State# s -> (# State# s, Word16# #) + { Compare and swap on a 16 bit-sized and aligned memory location. + + Use as: \s -> atomicCasWordAddr16# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Word32 "atomicCasWord32Addr#" GenPrimOp + Addr# -> Word32# -> Word32# -> State# s -> (# State# s, Word32# #) + { Compare and swap on a 32 bit-sized and aligned memory location. + + Use as: \s -> atomicCasWordAddr32# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Word64 "atomicCasWord64Addr#" GenPrimOp + Addr# -> Word64# -> Word64# -> State# s -> (# State# s, Word64# #) + { Compare and swap on a 64 bit-sized and aligned memory location. + + Use as: \s -> atomicCasWordAddr64# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchAddAddrOp_Word "fetchAddWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to add, + atomically add the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchSubAddrOp_Word "fetchSubWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to subtract, + atomically subtract the value from the element. Returns the value of + the element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchAndAddrOp_Word "fetchAndWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to AND, + atomically AND the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchNandAddrOp_Word "fetchNandWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to NAND, + atomically NAND the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchOrAddrOp_Word "fetchOrWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to OR, + atomically OR the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchXorAddrOp_Word "fetchXorWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to XOR, + atomically XOR the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop AtomicReadAddrOp_Word "atomicReadWordAddr#" GenPrimOp + Addr# -> State# s -> (# State# s, Word# #) + {Given an address, read a machine word. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop AtomicWriteAddrOp_Word "atomicWriteWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> State# s + {Given an address, write a machine word. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + + +------------------------------------------------------------------------ +section "Mutable variables" + {Operations on MutVar\#s.} +------------------------------------------------------------------------ + +primtype MutVar# s a + {A 'MutVar#' behaves like a single-element mutable array.} + +primop NewMutVarOp "newMutVar#" GenPrimOp + a_levpoly -> State# s -> (# State# s, MutVar# s a_levpoly #) + {Create 'MutVar#' with specified initial value in specified state thread.} + with + out_of_line = True + effect = ReadWriteEffect + +-- Note [Why MutVar# ops can't fail] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We don't label readMutVar# or writeMutVar# as CanFail. +-- This may seem a bit peculiar, because they surely *could* +-- fail spectacularly if passed a pointer to unallocated memory. +-- But MutVar#s are always correct by construction; we never +-- test if a pointer is valid before using it with these operations. +-- So we never have to worry about floating the pointer reference +-- outside a validity test. At the moment, ReadWriteEffect blocks +-- up the relevant optimizations anyway, but we hope to draw finer +-- distinctions soon, which should improve matters for readMutVar# +-- at least. + +primop ReadMutVarOp "readMutVar#" GenPrimOp + MutVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #) + {Read contents of 'MutVar#'. Result is not yet evaluated.} + with + -- See Note [Why MutVar# ops can't fail] + effect = ReadWriteEffect + +primop WriteMutVarOp "writeMutVar#" GenPrimOp + MutVar# s a_levpoly -> a_levpoly -> State# s -> State# s + {Write contents of 'MutVar#'.} + with + -- See Note [Why MutVar# ops can't fail] + effect = ReadWriteEffect + code_size = { primOpCodeSizeForeignCall } -- for the write barrier + +primop AtomicSwapMutVarOp "atomicSwapMutVar#" GenPrimOp + MutVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s, a_levpoly #) + {Atomically exchange the value of a 'MutVar#'.} + with + effect = ReadWriteEffect + +-- Note [Why not an unboxed tuple in atomicModifyMutVar2#?] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Looking at the type of atomicModifyMutVar2#, one might wonder why +-- it doesn't return an unboxed tuple. e.g., +-- +-- MutVar# s a -> (a -> (# a, b #)) -> State# s -> (# State# s, a, (# a, b #) #) +-- +-- The reason is that atomicModifyMutVar2# relies on laziness for its atomicity. +-- Given a MutVar# containing x, atomicModifyMutVar2# merely replaces +-- its contents with a thunk of the form (fst (f x)). This can be done using an +-- atomic compare-and-swap as it is merely replacing a pointer. + +primop AtomicModifyMutVar2Op "atomicModifyMutVar2#" GenPrimOp + MutVar# s a -> (a -> c) -> State# s -> (# State# s, a, c #) + { Modify the contents of a 'MutVar#', returning the previous + contents @x :: a@ and the result of applying the given function to the + previous contents @f x :: c@. + + The @data@ type @c@ (not a @newtype@!) must be a record whose first field + is of lifted type @a :: Type@ and is not unpacked. For example, product + types @c ~ Solo a@ or @c ~ (a, b)@ work well. If the record type is both + monomorphic and strict in its first field, it's recommended to mark the + latter @{-# NOUNPACK #-}@ explicitly. + + Under the hood 'atomicModifyMutVar2#' atomically replaces a pointer to an + old @x :: a@ with a pointer to a selector thunk @fst r@, where + @fst@ is a selector for the first field of the record and @r@ is a + function application thunk @r = f x@. + + @atomicModifyIORef2Native@ from @atomic-modify-general@ package makes an + effort to reflect restrictions on @c@ faithfully, providing a + well-typed high-level wrapper.} + with + out_of_line = True + effect = ReadWriteEffect + strictness = { \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv } + +primop AtomicModifyMutVar_Op "atomicModifyMutVar_#" GenPrimOp + MutVar# s a -> (a -> a) -> State# s -> (# State# s, a, a #) + { Modify the contents of a 'MutVar#', returning the previous + contents and the result of applying the given function to the + previous contents. } + with + out_of_line = True + effect = ReadWriteEffect + strictness = { \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv } + +primop CasMutVarOp "casMutVar#" GenPrimOp + MutVar# s a_levpoly -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #) + { Compare-and-swap: perform a pointer equality test between + the first value passed to this function and the value + stored inside the 'MutVar#'. If the pointers are equal, + replace the stored value with the second value passed to this + function, otherwise do nothing. + Returns the final value stored inside the 'MutVar#'. + The 'Int#' indicates whether a swap took place, + with @1#@ meaning that we didn't swap, and @0#@ + that we did. + Implies a full memory barrier. + Because the comparison is done on the level of pointers, + all of the difficulties of using + 'reallyUnsafePtrEquality#' correctly apply to + 'casMutVar#' as well. + } + with + out_of_line = True + effect = ReadWriteEffect + +------------------------------------------------------------------------ +section "Exceptions" +------------------------------------------------------------------------ + +-- Note [Strict IO wrappers] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Consider this example, which comes from GHC.IO.Handle.Internals: +-- wantReadableHandle3 f mv b st +-- = case ... of +-- DEFAULT -> case mv of MVar a -> ... +-- 0# -> maskAsyncExceptions# (\st -> case mv of MVar a -> ...) +-- The outer case just decides whether to mask exceptions, but we don't want +-- thereby to hide the strictness in `mv`! Hence the use of strictOnceApply1Dmd +-- in mask#, unmask# and atomically# (where we use strictManyApply1Dmd to respect +-- that it potentially calls its action multiple times). +-- +-- Note [Strictness for catch-style primops] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The catch#-style primops always call their action, just like outlined +-- in Note [Strict IO wrappers]. +-- However, it is important that we give their first arg lazyApply1Dmd and not +-- strictOnceApply1Dmd, like for mask#. Here is why. Consider a call +-- +-- catch# act handler s +-- +-- If `act = raiseIO# ...`, using strictOnceApply1Dmd for `act` would mean that +-- the call forwards the dead-end flag from `act` (see Note [Dead ends] and +-- Note [Precise exceptions and strictness analysis]). +-- This would cause dead code elimination to discard the continuation of the +-- catch# call, among other things. This first came up in #11555. +-- +-- Hence catch# uses lazyApply1Dmd in order /not/ to forward the dead-end flag +-- from `act`. (This is a bit brutal, but the language of strictness types is +-- not expressive enough to give it a more precise semantics that is still +-- sound.) +-- For perf reasons we often (but not always) choose to use a wrapper around +-- catch# that is head-strict in `act`: GHC.IO.catchException. +-- +-- A similar caveat applies to prompt#, which can be seen as a +-- generalisation of catch# as explained in GHC.Prim#continuations#. +-- The reason is that even if `act` appears dead-ending (e.g., looping) +-- `prompt# tag ma s` might return alright due to a (higher-order) use of +-- `control0#` in `act`. This came up in #25439. + +primop CatchOp "catch#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_reppoly #) ) + -> (b_levpoly -> State# RealWorld -> (# State# RealWorld, a_reppoly #) ) + -> State# RealWorld + -> (# State# RealWorld, a_reppoly #) + { @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions + thrown. + + Note that the result type here isn't quite as unrestricted as the + polymorphic type might suggest; see the section \"RuntimeRep polymorphism + in continuation-style primops\" for details. } + with + strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd + , lazyApply2Dmd + , topDmd] topDiv } + -- See Note [Strictness for catch-style primops] + out_of_line = True + effect = ReadWriteEffect + -- Either inner computation might potentially raise an unchecked exception, + -- but it doesn't seem worth putting a WARNING in the haddocks over + +primop RaiseOp "raise#" GenPrimOp + a_levpoly -> b_reppoly + with + -- In contrast to 'raiseIO#', which throws a *precise* exception, + -- exceptions thrown by 'raise#' are considered *imprecise*. + -- See Note [Precise vs imprecise exceptions] in GHC.Types.Demand. + -- Hence, it has 'botDiv', not 'exnDiv'. + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } + out_of_line = True + effect = ThrowsException + work_free = True + +primop RaiseUnderflowOp "raiseUnderflow#" GenPrimOp + (# #) -> b_reppoly + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } + out_of_line = True + effect = ThrowsException + code_size = { primOpCodeSizeForeignCall } + work_free = True + +primop RaiseOverflowOp "raiseOverflow#" GenPrimOp + (# #) -> b_reppoly + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } + out_of_line = True + effect = ThrowsException + code_size = { primOpCodeSizeForeignCall } + work_free = True + +primop RaiseDivZeroOp "raiseDivZero#" GenPrimOp + (# #) -> b_reppoly + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } + out_of_line = True + effect = ThrowsException + code_size = { primOpCodeSizeForeignCall } + work_free = True + +primop RaiseIOOp "raiseIO#" GenPrimOp + a_levpoly -> State# RealWorld -> (# State# RealWorld, b_reppoly #) + with + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + -- for why this is the *only* primop that has 'exnDiv' + strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd] exnDiv } + out_of_line = True + effect = ThrowsException + work_free = True + +primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + -> (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + { @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous + exceptions are deferred until after evaluation has finished. + + Note that the result type here isn't quite as unrestricted as the + polymorphic type might suggest; see the section \"RuntimeRep polymorphism + in continuation-style primops\" for details. } + with + strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } + -- See Note [Strict IO wrappers] + out_of_line = True + effect = ReadWriteEffect + +primop MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + -> (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + { @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous + exceptions are deferred until after evaluation has finished. + + Note that the result type here isn't quite as unrestricted as the + polymorphic type might suggest; see the section \"RuntimeRep polymorphism + in continuation-style primops\" for details. } + with + strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } + -- See Note [Strict IO wrappers] + out_of_line = True + effect = ReadWriteEffect + +primop UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + -> (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + { @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous + exceptions are unmasked. + + Note that the result type here isn't quite as unrestricted as the + polymorphic type might suggest; see the section \"RuntimeRep polymorphism + in continuation-style primops\" for details. } + with + strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } + -- See Note [Strict IO wrappers] + out_of_line = True + effect = ReadWriteEffect + +primop MaskStatus "getMaskingState#" GenPrimOp + State# RealWorld -> (# State# RealWorld, Int# #) + with + out_of_line = True + effect = ReadWriteEffect + +------------------------------------------------------------------------ +section "Continuations" + { #continuations# + + These operations provide access to first-class delimited continuations, + which allow a computation to access and manipulate portions of its + /current continuation/. Operationally, they are implemented by direct + manipulation of the RTS call stack, which may provide significant + performance gains relative to manual continuation-passing style (CPS) for + some programs. + + Intuitively, the delimited control operators 'prompt#' and + 'control0#' can be understood by analogy to 'catch#' and 'raiseIO#', + respectively: + + * Like 'catch#', 'prompt#' does not do anything on its own, it + just /delimits/ a subcomputation (the source of the name "delimited + continuations"). + + * Like 'raiseIO#', 'control0#' aborts to the nearest enclosing + 'prompt#' before resuming execution. + + However, /unlike/ 'raiseIO#', 'control0#' does /not/ discard + the aborted computation: instead, it /captures/ it in a form that allows + it to be resumed later. In other words, 'control0#' does not + irreversibly abort the local computation before returning to the enclosing + 'prompt#', it merely suspends it. All local context of the suspended + computation is packaged up and returned as an ordinary function that can be + invoked at a later point in time to /continue/ execution, which is why + the suspended computation is known as a /first-class continuation/. + + In GHC, every continuation prompt is associated with exactly one + 'PromptTag#'. Prompt tags are unique, opaque values created by + 'newPromptTag#' that may only be compared for equality. Both 'prompt#' + and 'control0#' accept a 'PromptTag#' argument, and 'control0#' + captures the continuation up to the nearest enclosing use of 'prompt#' + /with the same tag/. This allows a program to control exactly which + prompt it will abort to by using different tags, similar to how a program + can control which 'catch' it will abort to by throwing different types + of exceptions. Additionally, 'PromptTag#' accepts a single type parameter, + which is used to relate the expected result type at the point of the + 'prompt#' to the type of the continuation produced by 'control0#'. + + == The gory details + + The high-level explanation provided above should hopefully provide some + intuition for what these operations do, but it is not very precise; this + section provides a more thorough explanation. + + The 'prompt#' operation morally has the following type: + +@ +'prompt#' :: 'PromptTag#' a -> IO a -> IO a +@ + + If a computation @/m/@ never calls 'control0#', then + @'prompt#' /tag/ /m/@ is equivalent to just @/m/@, i.e. the 'prompt#' is + a no-op. This implies the following law: + + \[ + \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ x) \equiv \mathtt{pure}\ x + \] + + The 'control0#' operation morally has the following type: + +@ +'control0#' :: 'PromptTag#' a -> ((IO b -> IO a) -> IO a) -> IO b +@ + + @'control0#' /tag/ /f/@ captures the current continuation up to the nearest + enclosing @'prompt#' /tag/@ and resumes execution from the point of the call + to 'prompt#', passing the captured continuation to @/f/@. To make that + somewhat more precise, we can say 'control0#' obeys the following law: + + \[ + \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{control0\#}\ tag\ f \mathbin{\mathtt{>>=}} k) + \equiv f\ (\lambda\ m \rightarrow m \mathbin{\mathtt{>>=}} k) + \] + + However, this law does not fully describe the behavior of 'control0#', + as it does not account for situations where 'control0#' does not appear + immediately inside 'prompt#'. Capturing the semantics more precisely + requires some additional notational machinery; a common approach is to + use [reduction semantics](https://en.wikipedia.org/wiki/Operational_semantics#Reduction_semantics). + Assuming an appropriate definition of evaluation contexts \(E\), the + semantics of 'prompt#' and 'control0#' can be given as follows: + + \[ + \begin{aligned} + E[\mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ v)] + &\longrightarrow E[\mathtt{pure}\ v] \\[8pt] + E_1[\mathtt{prompt\#}\ \mathit{tag}\ E_2[\mathtt{control0\#}\ tag\ f]] + &\longrightarrow E_1[f\ (\lambda\ m \rightarrow E_2[m])] \\[-2pt] + \mathrm{where}\;\: \mathtt{prompt\#}\ \mathit{tag} &\not\in E_2 + \end{aligned} + \] + + A full treatment of the semantics and metatheory of delimited control is + well outside the scope of this documentation, but a good, thorough + overview (in Haskell) is provided in [A Monadic Framework for Delimited + Continuations](https://legacy.cs.indiana.edu/~dyb/pubs/monadicDC.pdf) by + Dybvig et al. + + == Safety and invariants + + Correct uses of 'control0#' must obey the following restrictions: + + 1. The behavior of 'control0#' is only well-defined within a /strict + 'State#' thread/, such as those associated with @IO@ and strict @ST@ + computations. + + 2. Furthermore, 'control0#' may only be called within the dynamic extent + of a 'prompt#' with a matching tag somewhere in the /current/ strict + 'State#' thread. Effectively, this means that a matching prompt must + exist somewhere, and the captured continuation must /not/ contain any + uses of @unsafePerformIO@, @runST@, @unsafeInterleaveIO@, etc. For + example, the following program is ill-defined: + + @ + 'prompt#' /tag/ $ + evaluate (unsafePerformIO $ 'control0#' /tag/ /f/) + @ + + In this example, the use of 'prompt#' appears in a different 'State#' + thread from the use of 'control0#', so there is no valid prompt in + scope to capture up to. + + 3. Finally, 'control0#' may not be used within 'State#' threads associated + with an STM transaction (i.e. those introduced by 'atomically#'). + + If the runtime is able to detect that any of these invariants have been + violated in a way that would compromise internal invariants of the runtime, + 'control0#' will fail by raising an exception. However, such violations + are only detected on a best-effort basis, as the bookkeeping necessary for + detecting /all/ illegal uses of 'control0#' would have significant overhead. + Therefore, although the operations are "safe" from the runtime's point of + view (e.g. they will not compromise memory safety or clobber internal runtime + state), it is still ultimately the programmer's responsibility to ensure + these invariants hold to guarantee predictable program behavior. + + In a similar vein, since each captured continuation includes the full local + context of the suspended computation, it can safely be resumed arbitrarily + many times without violating any invariants of the runtime system. However, + use of these operations in an arbitrary 'IO' computation may be unsafe for + other reasons, as most 'IO' code is not written with reentrancy in mind. For + example, a computation suspended in the middle of reading a file will likely + finish reading it when it is resumed; further attempts to resume from the + same place would then fail because the file handle was already closed. + + In other words, although the RTS ensures that a computation's control state + and local variables are properly restored for each distinct resumption of + a continuation, it makes no attempt to duplicate any local state the + computation may have been using (and could not possibly do so in general). + Furthermore, it provides no mechanism for an arbitrary computation to + protect itself against unwanted reentrancy (i.e. there is no analogue to + Scheme's @dynamic-wind@). For those reasons, manipulating the continuation + is only safe if the caller can be certain that doing so will not violate any + expectations or invariants of the enclosing computation. } +------------------------------------------------------------------------ + +primtype PromptTag# a + { See "GHC.Prim#continuations". } + +primop NewPromptTagOp "newPromptTag#" GenPrimOp + State# RealWorld -> (# State# RealWorld, PromptTag# a #) + { See "GHC.Prim#continuations". } + with + out_of_line = True + effect = ReadWriteEffect + +primop PromptOp "prompt#" GenPrimOp + PromptTag# a + -> (State# RealWorld -> (# State# RealWorld, a #)) + -> State# RealWorld -> (# State# RealWorld, a #) + { See "GHC.Prim#continuations". } + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv } + -- See Note [Strictness for catch-style primops] + out_of_line = True + effect = ReadWriteEffect + +primop Control0Op "control0#" GenPrimOp + PromptTag# a + -> (((State# RealWorld -> (# State# RealWorld, b_reppoly #)) + -> State# RealWorld -> (# State# RealWorld, a #)) + -> State# RealWorld -> (# State# RealWorld, a #)) + -> State# RealWorld -> (# State# RealWorld, b_reppoly #) + { See "GHC.Prim#continuations". } + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv } + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +------------------------------------------------------------------------ +section "STM-accessible Mutable Variables" +------------------------------------------------------------------------ + +primtype TVar# s a + +primop AtomicallyOp "atomically#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + -> State# RealWorld -> (# State# RealWorld, a_levpoly #) + with + strictness = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv } + -- See Note [Strict IO wrappers] + out_of_line = True + effect = ReadWriteEffect + +-- NB: retry#'s strictness information specifies it to diverge. +-- This lets the compiler perform some extra simplifications, since retry# +-- will technically never return. +-- +-- This allows the simplifier to replace things like: +-- case retry# s1 +-- (# s2, a #) -> e +-- with: +-- retry# s1 +-- where 'e' would be unreachable anyway. See #8091. +primop RetryOp "retry#" GenPrimOp + State# RealWorld -> (# State# RealWorld, a_levpoly #) + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } + out_of_line = True + effect = ReadWriteEffect + +primop CatchRetryOp "catchRetry#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + with + strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd + , lazyApply1Dmd + , topDmd ] topDiv } + -- See Note [Strictness for catch-style primops] + out_of_line = True + effect = ReadWriteEffect + +primop CatchSTMOp "catchSTM#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + -> (b -> State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + with + strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd + , lazyApply2Dmd + , topDmd ] topDiv } + -- See Note [Strictness for catch-style primops] + out_of_line = True + effect = ReadWriteEffect + +primop NewTVarOp "newTVar#" GenPrimOp + a_levpoly + -> State# s -> (# State# s, TVar# s a_levpoly #) + {Create a new 'TVar#' holding a specified initial value.} + with + out_of_line = True + effect = ReadWriteEffect + +primop ReadTVarOp "readTVar#" GenPrimOp + TVar# s a_levpoly + -> State# s -> (# State# s, a_levpoly #) + {Read contents of 'TVar#' inside an STM transaction, + i.e. within a call to 'atomically#'. + Does not force evaluation of the result.} + with + out_of_line = True + effect = ReadWriteEffect + +primop ReadTVarIOOp "readTVarIO#" GenPrimOp + TVar# s a_levpoly + -> State# s -> (# State# s, a_levpoly #) + {Read contents of 'TVar#' outside an STM transaction. + Does not force evaluation of the result.} + with + out_of_line = True + effect = ReadWriteEffect + +primop WriteTVarOp "writeTVar#" GenPrimOp + TVar# s a_levpoly + -> a_levpoly + -> State# s -> State# s + {Write contents of 'TVar#'.} + with + out_of_line = True + effect = ReadWriteEffect + + +------------------------------------------------------------------------ +section "Synchronized Mutable Variables" + {Operations on 'MVar#'s. } +------------------------------------------------------------------------ + +primtype MVar# s a + { A shared mutable variable (/not/ the same as a 'MutVar#'!). + (Note: in a non-concurrent implementation, @('MVar#' a)@ can be + represented by @('MutVar#' (Maybe a))@.) } + +primop NewMVarOp "newMVar#" GenPrimOp + State# s -> (# State# s, MVar# s a_levpoly #) + {Create new 'MVar#'; initially empty.} + with + out_of_line = True + effect = ReadWriteEffect + +primop TakeMVarOp "takeMVar#" GenPrimOp + MVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #) + {If 'MVar#' is empty, block until it becomes full. + Then remove and return its contents, and set it empty.} + with + out_of_line = True + effect = ReadWriteEffect + +primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp + MVar# s a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #) + {If 'MVar#' is empty, immediately return with integer 0 and value undefined. + Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.} + with + out_of_line = True + effect = ReadWriteEffect + +primop PutMVarOp "putMVar#" GenPrimOp + MVar# s a_levpoly -> a_levpoly -> State# s -> State# s + {If 'MVar#' is full, block until it becomes empty. + Then store value arg as its new contents.} + with + out_of_line = True + effect = ReadWriteEffect + +primop TryPutMVarOp "tryPutMVar#" GenPrimOp + MVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s, Int# #) + {If 'MVar#' is full, immediately return with integer 0. + Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.} + with + out_of_line = True + effect = ReadWriteEffect + +primop ReadMVarOp "readMVar#" GenPrimOp + MVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #) + {If 'MVar#' is empty, block until it becomes full. + Then read its contents without modifying the MVar, without possibility + of intervention from other threads.} + with + out_of_line = True + effect = ReadWriteEffect + +primop TryReadMVarOp "tryReadMVar#" GenPrimOp + MVar# s a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #) + {If 'MVar#' is empty, immediately return with integer 0 and value undefined. + Otherwise, return with integer 1 and contents of 'MVar#'.} + with + out_of_line = True + effect = ReadWriteEffect + +primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp + MVar# s a_levpoly -> State# s -> (# State# s, Int# #) + {Return 1 if 'MVar#' is empty; 0 otherwise.} + with + out_of_line = True + effect = ReadWriteEffect + + +------------------------------------------------------------------------ +section "Delay/wait operations" +------------------------------------------------------------------------ + +primop DelayOp "delay#" GenPrimOp + Int# -> State# s -> State# s + {Sleep specified number of microseconds.} + with + effect = ReadWriteEffect + out_of_line = True + +primop WaitReadOp "waitRead#" GenPrimOp + Int# -> State# s -> State# s + {Block until input is available on specified file descriptor.} + with + effect = ReadWriteEffect + out_of_line = True + +primop WaitWriteOp "waitWrite#" GenPrimOp + Int# -> State# s -> State# s + {Block until output is possible on specified file descriptor.} + with + effect = ReadWriteEffect + out_of_line = True + +------------------------------------------------------------------------ +section "Concurrency primitives" +------------------------------------------------------------------------ + +primtype State# s + { 'State#' is the primitive, unlifted type of states. It has + one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@, + where s is a type variable. The only purpose of the type parameter + is to keep different state threads separate. It is represented by + nothing at all. } + +primtype RealWorld + { 'RealWorld' is deeply magical. It is /primitive/, but it is not + /unlifted/ (hence @ptrArg@). We never manipulate values of type + 'RealWorld'; it's only used in the type system, to parameterise 'State#'. } + +primtype ThreadId# + {(In a non-concurrent implementation, this can be a singleton + type, whose (unique) value is returned by 'myThreadId#'. The + other operations can be omitted.)} + +primop ForkOp "fork#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + -> State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + effect = ReadWriteEffect + out_of_line = True + strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd + , topDmd ] topDiv } + +primop ForkOnOp "forkOn#" GenPrimOp + Int# -> (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + -> State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + effect = ReadWriteEffect + out_of_line = True + strictness = { \ _arity -> mkClosedDmdSig [ topDmd + , lazyApply1Dmd + , topDmd ] topDiv } + +primop KillThreadOp "killThread#" GenPrimOp + ThreadId# -> a -> State# RealWorld -> State# RealWorld + with + effect = ReadWriteEffect + out_of_line = True + +primop YieldOp "yield#" GenPrimOp + State# RealWorld -> State# RealWorld + with + effect = ReadWriteEffect + out_of_line = True + +primop MyThreadIdOp "myThreadId#" GenPrimOp + State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + effect = ReadWriteEffect + +primop LabelThreadOp "labelThread#" GenPrimOp + ThreadId# -> ByteArray# -> State# RealWorld -> State# RealWorld + {Set the label of the given thread. The @ByteArray#@ should contain + a UTF-8-encoded string.} + with + effect = ReadWriteEffect + out_of_line = True + +primop IsCurrentThreadBoundOp "isCurrentThreadBound#" GenPrimOp + State# RealWorld -> (# State# RealWorld, Int# #) + with + out_of_line = True + effect = ReadWriteEffect + +primop NoDuplicateOp "noDuplicate#" GenPrimOp + State# s -> State# s + with + out_of_line = True + effect = ReadWriteEffect + +primop GetThreadLabelOp "threadLabel#" GenPrimOp + ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, ByteArray# #) + {Get the label of the given thread. + Morally of type @ThreadId# -> IO (Maybe ByteArray#)@, with a @1#@ tag + denoting @Just@. + + @since 0.10} + with + out_of_line = True + +primop ThreadStatusOp "threadStatus#" GenPrimOp + ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, Int#, Int# #) + {Get the status of the given thread. Result is + @(ThreadStatus, Capability, Locked)@ where + @ThreadStatus@ is one of the status constants defined in + @rts/Constants.h@, @Capability@ is the number of + the capability which currently owns the thread, and + @Locked@ is a boolean indicating whether the + thread is bound to that capability. + + @since 0.9} + with + out_of_line = True + effect = ReadWriteEffect + +primop ListThreadsOp "listThreads#" GenPrimOp + State# RealWorld -> (# State# RealWorld, Array# ThreadId# #) + { Returns an array of the threads started by the program. Note that this + threads which have finished execution may or may not be present in this + list, depending upon whether they have been collected by the garbage collector. + + @since 0.10} + with + out_of_line = True + effect = ReadWriteEffect + +------------------------------------------------------------------------ +section "Weak pointers" +------------------------------------------------------------------------ + +primtype Weak# b + +primop MkWeakOp "mkWeak#" GenPrimOp + a_levpoly -> b_levpoly -> (State# RealWorld -> (# State# RealWorld, c #)) + -> State# RealWorld -> (# State# RealWorld, Weak# b_levpoly #) + { @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@, + with an associated reference to some value @v@. If @k@ is still + alive then @v@ can be retrieved using 'deRefWeak#'. Note that + the type of @k@ must be represented by a pointer (i.e. of kind + @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). } + with + effect = ReadWriteEffect + out_of_line = True + +primop MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp + a_levpoly -> b_levpoly -> State# RealWorld -> (# State# RealWorld, Weak# b_levpoly #) + with + effect = ReadWriteEffect + out_of_line = True + +primop AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp + Addr# -> Addr# -> Int# -> Addr# -> Weak# b_levpoly + -> State# RealWorld -> (# State# RealWorld, Int# #) + { @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C + function pointer @fptr@ to a weak pointer @w@ as a finalizer. If + @flag@ is zero, @fptr@ will be called with one argument, + @ptr@. Otherwise, it will be called with two arguments, + @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns + 1 on success, or 0 if @w@ is already dead. } + with + effect = ReadWriteEffect + out_of_line = True + +primop DeRefWeakOp "deRefWeak#" GenPrimOp + Weak# a_levpoly -> State# RealWorld -> (# State# RealWorld, Int#, a_levpoly #) + with + effect = ReadWriteEffect + out_of_line = True + +primop FinalizeWeakOp "finalizeWeak#" GenPrimOp + Weak# a_levpoly -> State# RealWorld -> (# State# RealWorld, Int#, + (State# RealWorld -> (# State# RealWorld, b #) ) #) + { Finalize a weak pointer. The return value is an unboxed tuple + containing the new state of the world and an "unboxed Maybe", + represented by an 'Int#' and a (possibly invalid) finalization + action. An 'Int#' of @1@ indicates that the finalizer is valid. The + return value @b@ from the finalizer should be ignored. } + with + effect = ReadWriteEffect + out_of_line = True + +primop TouchOp "touch#" GenPrimOp + a_levpoly -> State# s -> State# s + with + code_size = 0 + effect = ReadWriteEffect -- see Note [touch# has ReadWriteEffect] + work_free = False + + +-- Note [touch# has ReadWriteEffect] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Although touch# emits no code, it is marked as ReadWriteEffect to +-- prevent it from being defeated by the optimizer: +-- * Discarding a touch# call would defeat its whole purpose. +-- * Strictly floating a touch# call out would shorten the lifetime +-- of the touched object, again defeating its purpose. +-- * Duplicating a touch# call might unpredictably extend the lifetime +-- of the touched object. Although this would not defeat the purpose +-- of touch#, it seems undesirable. +-- +-- In practice, this designation probably doesn't matter in most cases, +-- as touch# is usually tightly coupled with a "real" read or write effect. + +------------------------------------------------------------------------ +section "Stable pointers and names" +------------------------------------------------------------------------ + +primtype StablePtr# a + +primtype StableName# a + +primop MakeStablePtrOp "makeStablePtr#" GenPrimOp + a_levpoly -> State# RealWorld -> (# State# RealWorld, StablePtr# a_levpoly #) + with + effect = ReadWriteEffect + out_of_line = True + +primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp + StablePtr# a_levpoly -> State# RealWorld -> (# State# RealWorld, a_levpoly #) + with + effect = ReadWriteEffect + out_of_line = True + +primop EqStablePtrOp "eqStablePtr#" GenPrimOp + StablePtr# a_levpoly -> StablePtr# a_levpoly -> Int# + with + effect = ReadWriteEffect + +primop MakeStableNameOp "makeStableName#" GenPrimOp + a_levpoly -> State# RealWorld -> (# State# RealWorld, StableName# a_levpoly #) + with + effect = ReadWriteEffect + out_of_line = True + +primop StableNameToIntOp "stableNameToInt#" GenPrimOp + StableName# a_levpoly -> Int# + +------------------------------------------------------------------------ +section "Compact normal form" + + {Primitives for working with compact regions. The @ghc-compact@ + library and the @compact@ library demonstrate how to use these + primitives. The documentation below draws a distinction between + a CNF and a compact block. A CNF contains one or more compact + blocks. The source file @rts\/sm\/CNF.c@ + diagrams this relationship. When discussing a compact + block, an additional distinction is drawn between capacity and + utilized bytes. The capacity is the maximum number of bytes that + the compact block can hold. The utilized bytes is the number of + bytes that are actually used by the compact block. + } + +------------------------------------------------------------------------ + +primtype Compact# + +primop CompactNewOp "compactNew#" GenPrimOp + Word# -> State# RealWorld -> (# State# RealWorld, Compact# #) + { Create a new CNF with a single compact block. The argument is + the capacity of the compact block (in bytes, not words). + The capacity is rounded up to a multiple of the allocator block size + and is capped to one mega block. } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactResizeOp "compactResize#" GenPrimOp + Compact# -> Word# -> State# RealWorld -> + State# RealWorld + { Set the new allocation size of the CNF. This value (in bytes) + determines the capacity of each compact block in the CNF. It + does not retroactively affect existing compact blocks in the CNF. } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactContainsOp "compactContains#" GenPrimOp + Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #) + { Returns 1\# if the object is contained in the CNF, 0\# otherwise. } + with + out_of_line = True + +primop CompactContainsAnyOp "compactContainsAny#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, Int# #) + { Returns 1\# if the object is in any CNF at all, 0\# otherwise. } + with + out_of_line = True + +primop CompactGetFirstBlockOp "compactGetFirstBlock#" GenPrimOp + Compact# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #) + { Returns the address and the utilized size (in bytes) of the + first compact block of a CNF.} + with + out_of_line = True + +primop CompactGetNextBlockOp "compactGetNextBlock#" GenPrimOp + Compact# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #) + { Given a CNF and the address of one its compact blocks, returns the + next compact block and its utilized size, or 'nullAddr#' if the + argument was the last compact block in the CNF. } + with + out_of_line = True + +primop CompactAllocateBlockOp "compactAllocateBlock#" GenPrimOp + Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #) + { Attempt to allocate a compact block with the capacity (in + bytes) given by the first argument. The 'Addr#' is a pointer + to previous compact block of the CNF or 'nullAddr#' to create a + new CNF with a single compact block. + + The resulting block is not known to the GC until + 'compactFixupPointers#' is called on it, and care must be taken + so that the address does not escape or memory will be leaked. + } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactFixupPointersOp "compactFixupPointers#" GenPrimOp + Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Compact#, Addr# #) + { Given the pointer to the first block of a CNF and the + address of the root object in the old address space, fix up + the internal pointers inside the CNF to account for + a different position in memory than when it was serialized. + This method must be called exactly once after importing + a serialized CNF. It returns the new CNF and the new adjusted + root address. } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactAdd "compactAdd#" GenPrimOp + Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #) + { Recursively add a closure and its transitive closure to a + 'Compact#' (a CNF), evaluating any unevaluated components + at the same time. Note: 'compactAdd#' is not thread-safe, so + only one thread may call 'compactAdd#' with a particular + 'Compact#' at any given time. The primop does not + enforce any mutual exclusion; the caller is expected to + arrange this. } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactAddWithSharing "compactAddWithSharing#" GenPrimOp + Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #) + { Like 'compactAdd#', but retains sharing and cycles + during compaction. } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactSize "compactSize#" GenPrimOp + Compact# -> State# RealWorld -> (# State# RealWorld, Word# #) + { Return the total capacity (in bytes) of all the compact blocks + in the CNF. } + with + effect = ReadWriteEffect + out_of_line = True + +------------------------------------------------------------------------ +section "Unsafe pointer equality" +-- (#1 Bad Guy: Alastair Reid :) +------------------------------------------------------------------------ + +primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp + a_levpoly -> b_levpoly -> Int# + { Returns @1#@ if the given pointers are equal and @0#@ otherwise. } + with + effect = CanFail -- See Note [reallyUnsafePtrEquality# CanFail] + can_fail_warning = DoNotWarnCanFail + +-- Note [Pointer comparison operations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The primop `reallyUnsafePtrEquality#` does a direct pointer +-- equality between two (boxed) values. Several things to note: +-- +-- (PE1) It is levity-polymorphic. It works for TYPE (BoxedRep Lifted) and +-- TYPE (BoxedRep Unlifted). But not TYPE IntRep, for example. +-- This levity-polymorphism comes from the use of the type variables +-- "a_levpoly" and "b_levpoly". See Note [Levity and representation polymorphic primops] +-- +-- (PE2) It is hetero-typed; you can compare pointers of different types. +-- This is used in various packages such as containers & unordered-containers. +-- +-- (PE3) It does not evaluate its arguments. The user of the primop is responsible +-- for doing so. Consider +-- let { x = p+q; y = q+p } in reallyUnsafePtrEquality# x y +-- Here `x` and `y` point to different closures, so the expression will +-- probably return False; but if `x` and/or `y` were evaluated for some +-- other reason, then it might return True. +-- +-- (PE4) It is obviously very dangerous, because replacing equals with equals +-- in the program can change the result. For example +-- let x = f y in reallyUnsafePtrEquality# x x +-- will probably return True, whereas +-- reallyUnsafePtrEquality# (f y) (f y) +-- will probably return False. ("probably", because it's affected +-- by CSE and inlining). +-- +-- (PE5) reallyUnsafePtrEquality# can't fail, but it is marked as such +-- to prevent it from floating out. +-- See Note [reallyUnsafePtrEquality# CanFail] +-- +-- The library GHC.Prim.PtrEq (and GHC.Exts) provides +-- +-- unsafePtrEquality# :: +-- forall (a :: UnliftedType) (b :: UnliftedType). a -> b -> Int# +-- +-- It is still heterotyped (like (PE2)), but it's restricted to unlifted types +-- (unlike (PE1)). That means that (PE3) doesn't apply: unlifted types are +-- always evaluated, which makes it a bit less unsafe. +-- +-- However unsafePtrEquality# is /implemented/ by a call to +-- reallyUnsafePtrEquality#, so using the former is really just a documentation +-- hint to the reader of the code. GHC behaves no differently. +-- +-- The same library provides less Wild-West functions +-- for use in specific cases, namely: +-- +-- reallyUnsafePtrEquality :: a -> a -> Int# -- not levity-polymorphic, nor hetero-typed +-- sameArray# :: Array# a -> Array# a -> Int# +-- sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Int# +-- sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int# +-- sameSmallMutableArray# :: SmallMutableArray# s a -> SmallMutableArray# s a -> Int# +-- sameByteArray# :: ByteArray# -> ByteArray# -> Int# +-- sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int# +-- sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int# +-- sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int# +-- sameMutVar# :: MutVar# s a -> MutVar# s a -> Int# +-- sameTVar# :: TVar# s a -> TVar# s a -> Int# +-- sameMVar# :: MVar# s a -> MVar# s a -> Int# +-- eqStableName# :: StableName# a -> StableName# b -> Int# +-- +-- These operations are all specialisations of unsafePtrEquality#. + +-- Note [reallyUnsafePtrEquality# CanFail] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it +-- CanFail anyway. Until 5a9a1738023a, GHC considered primops okay for +-- speculation only when their arguments were known to be forced. This was +-- unnecessarily conservative, but it prevented reallyUnsafePtrEquality# from +-- floating out of places where its arguments were known to be forced. +-- Unfortunately, GHC could sometimes lose track of whether those arguments +-- were forced, leading to let-can-float invariant failures (see #13027 and the +-- discussion in #11444). Now that ok_for_speculation skips over lifted +-- arguments, we need to explicitly prevent reallyUnsafePtrEquality# +-- from floating out. Imagine if we had +-- +-- \x y . case x of x' +-- DEFAULT -> +-- case y of y' +-- DEFAULT -> +-- let eq = reallyUnsafePtrEquality# x' y' +-- in ... +-- +-- If the let floats out, we'll get +-- +-- \x y . let eq = reallyUnsafePtrEquality# x y +-- in case x of ... +-- +-- The trouble is that pointer equality between thunks is very different +-- from pointer equality between the values those thunks reduce to, and the latter +-- is typically much more precise. + +------------------------------------------------------------------------ +section "Parallelism" +------------------------------------------------------------------------ + +primop ParOp "par#" GenPrimOp a -> Int# + {Create a new spark evaluating the given argument. + The return value should always be 1. + Users are encouraged to use spark# instead.} + with + -- Note that Par is lazy to avoid that the sparked thing + -- gets evaluated strictly, which it should *not* be + effect = ReadWriteEffect + code_size = { primOpCodeSizeForeignCall } + -- `par#` was suppose to be deprecated in favor of `spark#` [1], however it + -- wasn't clear how to replace it with `spark#` [2] and `par#` is still used + -- to implement `GHC.Internal.Conc.Sync.par`. So we undeprecated it until + -- everything is sorted out (see #24825). + -- + -- [1] https://gitlab.haskell.org/ghc/ghc/-/issues/15227#note_154293 + -- [2] https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5548#note_347791 + -- + -- deprecated_msg = { Use 'spark#' instead } + +primop SparkOp "spark#" GenPrimOp + a -> State# s -> (# State# s, a #) + with effect = ReadWriteEffect + code_size = { primOpCodeSizeForeignCall } + +primop GetSparkOp "getSpark#" GenPrimOp + State# s -> (# State# s, Int#, a #) + with + effect = ReadWriteEffect + out_of_line = True + +primop NumSparks "numSparks#" GenPrimOp + State# s -> (# State# s, Int# #) + { Returns the number of sparks in the local spark pool. } + with + effect = ReadWriteEffect + out_of_line = True + + + +------------------------------------------------------------------------ +section "Controlling object lifetime" + {Ensuring that objects don't die a premature death.} +------------------------------------------------------------------------ + +-- See Note [keepAlive# magic] in GHC.CoreToStg.Prep. +primop KeepAliveOp "keepAlive#" GenPrimOp + a_levpoly -> State# s -> (State# s -> b_reppoly) -> b_reppoly + { @'keepAlive#' x s k@ keeps the value @x@ alive during the execution + of the computation @k@. + + Note that the result type here isn't quite as unrestricted as the + polymorphic type might suggest; see the section \"RuntimeRep polymorphism + in continuation-style primops\" for details. } + with + out_of_line = True + strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv } + -- See Note [Strict IO wrappers] + effect = ReadWriteEffect + -- The invoked computation may have side effects + + +------------------------------------------------------------------------ +section "Tag to enum stuff" + {Convert back and forth between values of enumerated types + and small integers.} +------------------------------------------------------------------------ + +primop DataToTagSmallOp "dataToTagSmall#" GenPrimOp + a_levpoly -> Int# + { Used internally to implement @dataToTag#@: Use that function instead! + This one normally offers /no advantage/ and comes with no stability + guarantees: it may change its type, its name, or its behavior + with /no warning/ between compiler releases. + + It is expected that this function will be un-exposed in a future + release of ghc. + + For more details, look at @Note [DataToTag overview]@ + in GHC.Tc.Instance.Class in the source code for + /the specific compiler version you are using./ + } + with + deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. } + strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } + effect = ThrowsException + cheap = True + +primop DataToTagLargeOp "dataToTagLarge#" GenPrimOp + a_levpoly -> Int# + { Used internally to implement @dataToTag#@: Use that function instead! + This one offers /no advantage/ and comes with no stability + guarantees: it may change its type, its name, or its behavior + with /no warning/ between compiler releases. + + It is expected that this function will be un-exposed in a future + release of ghc. + + For more details, look at @Note [DataToTag overview]@ + in GHC.Tc.Instance.Class in the source code for + /the specific compiler version you are using./ + } + with + deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. } + strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } + effect = ThrowsException + cheap = True + +primop TagToEnumOp "tagToEnum#" GenPrimOp + Int# -> a + with + effect = CanFail + +------------------------------------------------------------------------ +section "Bytecode operations" + {Support for manipulating bytecode objects used by the interpreter and + linker. + + Bytecode objects are heap objects which represent top-level bindings and + contain a list of instructions and data needed by these instructions.} +------------------------------------------------------------------------ + +primtype BCO + { Primitive bytecode type. } + +primop AddrToAnyOp "addrToAny#" GenPrimOp + Addr# -> (# a_levpoly #) + { Convert an 'Addr#' to a followable Any type. } + with + code_size = 0 + +primop AnyToAddrOp "anyToAddr#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, Addr# #) + { Retrieve the address of any Haskell value. This is + essentially an 'unsafeCoerce#', but if implemented as such + the core lint pass complains and fails to compile. + As a primop, it is opaque to core/stg, and only appears + in cmm (where the copy propagation pass will get rid of it). + Note that "a" must be a value, not a thunk! It's too late + for strictness analysis to enforce this, so you're on your + own to guarantee this. Also note that 'Addr#' is not a GC + pointer - up to you to guarantee that it does not become + a dangling pointer immediately after you get it.} + with + code_size = 0 + +primop MkApUpd0_Op "mkApUpd0#" GenPrimOp + BCO -> (# a #) + { Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of + the BCO when evaluated. } + with + out_of_line = True + +primop NewBCOOp "newBCO#" GenPrimOp + ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) + { @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The + resulting object encodes a function of the given arity with the instructions + encoded in @instrs@, and a static reference table usage bitmap given by + @bitmap@. } + with + effect = ReadWriteEffect + out_of_line = True + +primop UnpackClosureOp "unpackClosure#" GenPrimOp + a -> (# Addr#, ByteArray#, Array# b #) + { @'unpackClosure#' closure@ copies the closure and pointers in the + payload of the given closure into two new arrays, and returns a pointer to + the first word of the closure's info table, a non-pointer array for the raw + bytes of the closure, and a pointer array for the pointers in the payload. } + with + out_of_line = True + +primop ClosureSizeOp "closureSize#" GenPrimOp + a -> Int# + { @'closureSize#' closure@ returns the size of the given closure in + machine words. } + with + out_of_line = True + +primop GetApStackValOp "getApStackVal#" GenPrimOp + a -> Int# -> (# Int#, b #) + with + out_of_line = True + +------------------------------------------------------------------------ +section "Misc" + {These aren't nearly as wired in as Etc...} +------------------------------------------------------------------------ + +primop GetCCSOfOp "getCCSOf#" GenPrimOp + a -> State# s -> (# State# s, Addr# #) + +primop GetCurrentCCSOp "getCurrentCCS#" GenPrimOp + a -> State# s -> (# State# s, Addr# #) + { Returns the current 'CostCentreStack' (value is @NULL@ if + not profiling). Takes a dummy argument which can be used to + avoid the call to 'getCurrentCCS#' being floated out by the + simplifier, which would result in an uninformative stack + ("CAF"). } + +primop ClearCCSOp "clearCCS#" GenPrimOp + (State# s -> (# State# s, a #)) -> State# s -> (# State# s, a #) + { Run the supplied IO action with an empty CCS. For example, this + is used by the interpreter to run an interpreted computation + without the call stack showing that it was invoked from GHC. } + with + out_of_line = True + +------------------------------------------------------------------------ +section "Annotating call stacks" +------------------------------------------------------------------------ + +primop AnnotateStackOp "annotateStack#" GenPrimOp + b -> (State# s -> (# State# s, a_reppoly #)) -> State# s -> (# State# s, a_reppoly #) + { Pushes an annotation frame to the stack which can be reported by backtraces. } + with + out_of_line = True + +------------------------------------------------------------------------ +section "Info Table Origin" +------------------------------------------------------------------------ +primop WhereFromOp "whereFrom#" GenPrimOp + a -> Addr# -> State# s -> (# State# s, Int# #) + { Fills the given buffer with the @InfoProvEnt@ for the info table of the + given object. Returns @1#@ on success and @0#@ otherwise.} + with + out_of_line = True + +------------------------------------------------------------------------ +section "Etc" + {Miscellaneous built-ins} +------------------------------------------------------------------------ + +primtype FUN m a b + {The builtin function type, written in infix form as @a % m -> b@. + Values of this type are functions taking inputs of type @a@ and + producing outputs of type @b@. The multiplicity of the input is + @m@. + + Note that @'FUN' m a b@ permits representation polymorphism in both + @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be + well-kinded. + } + +pseudoop "realWorld#" + State# RealWorld + { The token used in the implementation of the IO monad as a state monad. + It does not pass any information at runtime. + See also 'GHC.Magic.runRW#'. } + +pseudoop "void#" + (# #) + { This is an alias for the unboxed unit tuple constructor. + In earlier versions of GHC, 'void#' was a value + of the primitive type 'Void#', which is now defined to be @(# #)@. + } + with deprecated_msg = { Use an unboxed unit tuple instead } + +primtype Proxy# a + { The type constructor 'Proxy#' is used to bear witness to some + type variable. It's used when you want to pass around proxy values + for doing things like modelling type applications. A 'Proxy#' + is not only unboxed, it also has a polymorphic kind, and has no + runtime representation, being totally free. } + +pseudoop "proxy#" + Proxy# a + { Witness for an unboxed 'Proxy#' value, which has no runtime + representation. } + +pseudoop "seq" + a -> b_reppoly -> b_reppoly + { The value of @'seq' a b@ is bottom if @a@ is bottom, and + otherwise equal to @b@. In other words, it evaluates the first + argument @a@ to weak head normal form (WHNF). 'seq' is usually + introduced to improve performance by avoiding unneeded laziness. + + A note on evaluation order: the expression @'seq' a b@ does + /not/ guarantee that @a@ will be evaluated before @b@. + The only guarantee given by 'seq' is that the both @a@ + and @b@ will be evaluated before 'seq' returns a value. + In particular, this means that @b@ may be evaluated before + @a@. If you need to guarantee a specific order of evaluation, + you must use the function 'pseq' from the "parallel" package. } + with fixity = infixr 0 + -- This fixity is only the one picked up by Haddock. If you + -- change this, do update 'ghcPrimIface' in 'GHC.Iface.Load'. + +primop TraceEventOp "traceEvent#" GenPrimOp + Addr# -> State# s -> State# s + { Emits an event via the RTS tracing framework. The contents + of the event is the zero-terminated byte string passed as the first + argument. The event will be emitted either to the @.eventlog@ file, + or to stderr, depending on the runtime RTS flags. } + with + effect = ReadWriteEffect + out_of_line = True + +primop TraceEventBinaryOp "traceBinaryEvent#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + { Emits an event via the RTS tracing framework. The contents + of the event is the binary object passed as the first argument with + the given length passed as the second argument. The event will be + emitted to the @.eventlog@ file. } + with + effect = ReadWriteEffect + out_of_line = True + +primop TraceMarkerOp "traceMarker#" GenPrimOp + Addr# -> State# s -> State# s + { Emits a marker event via the RTS tracing framework. The contents + of the event is the zero-terminated byte string passed as the first + argument. The event will be emitted either to the @.eventlog@ file, + or to stderr, depending on the runtime RTS flags. } + with + effect = ReadWriteEffect + out_of_line = True + +primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp + Int64# -> State# RealWorld -> State# RealWorld + { Sets the allocation counter for the current thread to the given value. } + with + effect = ReadWriteEffect + out_of_line = True + +primop SetOtherThreadAllocationCounter "setOtherThreadAllocationCounter#" GenPrimOp + Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld + { Sets the allocation counter for the another thread to the given value. + This doesn't take allocations into the current nursery chunk into account. + Therefore it is only accurate if the other thread is not currently running. } + with + effect = ReadWriteEffect + out_of_line = True + +primtype StackSnapshot# + { Haskell representation of a @StgStack*@ that was created (cloned) + with a function in "GHC.Stack.CloneStack". Please check the + documentation in that module for more detailed explanations. } + +------------------------------------------------------------------------ +section "Safe coercions" +------------------------------------------------------------------------ + +pseudoop "coerce" + Coercible a b => a -> b + { The function 'coerce' allows you to safely convert between values of + types that have the same representation with no run-time overhead. In the + simplest case you can use it instead of a newtype constructor, to go from + the newtype's concrete type to the abstract type. But it also works in + more complicated settings, e.g. converting a list of newtypes to a list of + concrete types. + + When used in conversions involving a newtype wrapper, + make sure the newtype constructor is in scope. + + This function is representation-polymorphic, but the + 'RuntimeRep' type argument is marked as 'Inferred', meaning + that it is not available for visible type application. This means + the typechecker will accept @'coerce' \@'Int' \@Age 42@. + + === __Examples__ + + >>> newtype TTL = TTL Int deriving (Eq, Ord, Show) + >>> newtype Age = Age Int deriving (Eq, Ord, Show) + >>> coerce (Age 42) :: TTL + TTL 42 + >>> coerce (+ (1 :: Int)) (Age 42) :: TTL + TTL 43 + >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL] + [TTL 43,TTL 25] + + } + +------------------------------------------------------------------------ +section "SIMD Vectors" + {Operations on SIMD vectors.} +------------------------------------------------------------------------ + +#define ALL_VECTOR_TYPES \ + [,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,, \ + ,, \ + ,,] + +#define SIGNED_VECTOR_TYPES \ + [,,, \ + ,,,, \ + ,,,, \ + ,, \ + ,, \ + ,,] + +#define FLOAT_VECTOR_TYPES \ + [, \ + ,, \ + ,,] + +#define INT_VECTOR_TYPES \ + [,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,,] + +primtype VECTOR + with vector = ALL_VECTOR_TYPES + +primop VecBroadcastOp "broadcast#" GenPrimOp + SCALAR -> VECTOR + { Broadcast a scalar to all elements of a vector. } + with vector = ALL_VECTOR_TYPES + +primop VecPackOp "pack#" GenPrimOp + VECTUPLE -> VECTOR + { Pack the elements of an unboxed tuple into a vector. } + with vector = ALL_VECTOR_TYPES + +primop VecUnpackOp "unpack#" GenPrimOp + VECTOR -> VECTUPLE + { Unpack the elements of a vector into an unboxed tuple. } + with vector = ALL_VECTOR_TYPES + +primop VecInsertOp "insert#" GenPrimOp + VECTOR -> SCALAR -> Int# -> VECTOR + { Insert a scalar at the given position in a vector. + The position must be a compile-time constant. } + with effect = CanFail + vector = ALL_VECTOR_TYPES + +primop VecAddOp "plus#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Add two vectors element-wise. } + with commutable = True + vector = ALL_VECTOR_TYPES + +primop VecSubOp "minus#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Subtract two vectors element-wise. } + with vector = ALL_VECTOR_TYPES + +primop VecMulOp "times#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Multiply two vectors element-wise. } + with commutable = True + vector = ALL_VECTOR_TYPES + +primop VecDivOp "divide#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Divide two vectors element-wise. } + with effect = CanFail + vector = FLOAT_VECTOR_TYPES + +primop VecQuotOp "quot#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Rounds towards zero element-wise. + + Note: Most CPU ISAs do not contain any SIMD integer division instructions. + Do not expect high performance. } + with effect = CanFail + vector = INT_VECTOR_TYPES + div_like = True + +primop VecRemOp "rem#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. + + Note: Most CPU ISAs do not contain any SIMD integer division instructions. + Do not expect high performance. } + with effect = CanFail + vector = INT_VECTOR_TYPES + div_like = True + + +primop VecNegOp "negate#" GenPrimOp + VECTOR -> VECTOR + { Negate element-wise. } + with vector = SIGNED_VECTOR_TYPES + +primop VecIndexByteArrayOp "indexArray#" GenPrimOp + ByteArray# -> Int# -> VECTOR + { Read a vector from the specified index of an immutable array. + The index is counted in units of SIMD vectors (not scalar elements). } + with effect = CanFail + vector = ALL_VECTOR_TYPES + +primop VecReadByteArrayOp "readArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #) + { Read a vector from the specified index of a mutable array. + The index is counted in units of SIMD vectors (not scalar elements). } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecWriteByteArrayOp "writeArray#" GenPrimOp + MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s + { Write a vector to the specified index of a mutable array. + The index is counted in units of SIMD vectors (not scalar elements). } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp + Addr# -> Int# -> VECTOR + { Reads vector; offset in units of SIMD vectors (not scalar elements). } + with effect = CanFail + vector = ALL_VECTOR_TYPES + +primop VecReadOffAddrOp "readOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, VECTOR #) + { Reads vector; offset in units of SIMD vectors (not scalar elements). } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp + Addr# -> Int# -> VECTOR -> State# s -> State# s + { Write vector; offset in units of SIMD vectors (not scalar elements). } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + + +primop VecIndexScalarByteArrayOp "indexArrayAs#" GenPrimOp + ByteArray# -> Int# -> VECTOR + { Read a vector from specified index of immutable array of scalars; offset is in scalar elements. } + with effect = CanFail + vector = ALL_VECTOR_TYPES + +primop VecReadScalarByteArrayOp "readArrayAs#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #) + { Read a vector from specified index of mutable array of scalars; offset is in scalar elements. } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecWriteScalarByteArrayOp "writeArrayAs#" GenPrimOp + MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s + { Write a vector to specified index of mutable array of scalars; offset is in scalar elements. } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecIndexScalarOffAddrOp "indexOffAddrAs#" GenPrimOp + Addr# -> Int# -> VECTOR + { Reads vector; offset in scalar elements. } + with effect = CanFail + vector = ALL_VECTOR_TYPES + +primop VecReadScalarOffAddrOp "readOffAddrAs#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, VECTOR #) + { Reads vector; offset in scalar elements. } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecWriteScalarOffAddrOp "writeOffAddrAs#" GenPrimOp + Addr# -> Int# -> VECTOR -> State# s -> State# s + { Write vector; offset in scalar elements. } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecFMAdd "fmadd#" GenPrimOp + VECTOR -> VECTOR -> VECTOR -> VECTOR + {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".} + with + vector = FLOAT_VECTOR_TYPES +primop VecFMSub "fmsub#" GenPrimOp + VECTOR -> VECTOR -> VECTOR -> VECTOR + {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".} + with + vector = FLOAT_VECTOR_TYPES +primop VecFNMAdd "fnmadd#" GenPrimOp + VECTOR -> VECTOR -> VECTOR -> VECTOR + {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".} + with + vector = FLOAT_VECTOR_TYPES +primop VecFNMSub "fnmsub#" GenPrimOp + VECTOR -> VECTOR -> VECTOR -> VECTOR + {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".} + with + vector = FLOAT_VECTOR_TYPES + +primop VecShuffleOp "shuffle#" GenPrimOp + VECTOR -> VECTOR -> INTVECTUPLE -> VECTOR + {Shuffle elements of the concatenation of the input two vectors + into the result vector. The indices must be compile-time constants.} + with vector = ALL_VECTOR_TYPES + +primop VecMinOp "min#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + {Component-wise minimum of two vectors.} + with + vector = ALL_VECTOR_TYPES + +primop VecMaxOp "max#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + {Component-wise maximum of two vectors.} + with + vector = ALL_VECTOR_TYPES + +------------------------------------------------------------------------ + +section "Prefetch" + {Prefetch operations: Note how every prefetch operation has a name + with the pattern prefetch*N#, where N is either 0,1,2, or 3. + + This suffix number, N, is the "locality level" of the prefetch, following the + convention in GCC and other compilers. + Higher locality numbers correspond to the memory being loaded in more + levels of the cpu cache, and being retained after initial use. The naming + convention follows the naming convention of the prefetch intrinsic found + in the GCC and Clang C compilers. + + On the LLVM backend, prefetch*N# uses the LLVM prefetch intrinsic + with locality level N. The code generated by LLVM is target architecture + dependent, but should agree with the GHC NCG on x86 systems. + + On the PPC native backend, prefetch*N is a No-Op. + + On the x86 NCG, N=0 will generate prefetchNTA, + N=1 generates prefetcht2, N=2 generates prefetcht1, and + N=3 generates prefetcht0. + + For streaming workloads, the prefetch*0 operations are recommended. + For workloads which do many reads or writes to a memory location in a short period of time, + prefetch*3 operations are recommended. + + For further reading about prefetch and associated systems performance optimization, + the instruction set and optimization manuals by Intel and other CPU vendors are + excellent starting place. + + + The "Intel 64 and IA-32 Architectures Optimization Reference Manual" is + especially a helpful read, even if your software is meant for other CPU + architectures or vendor hardware. The manual can be found at + http://www.intel.com/content/www/us/en/architecture-and-technology/64-ia-32-architectures-optimization-manual.html . + + The @prefetch*@ family of operations has the order of operations + determined by passing around the 'State#' token. + + To get a "pure" version of these operations, use 'inlinePerformIO' which is quite safe in this context. + + It is important to note that while the prefetch operations will never change the + answer to a pure computation, They CAN change the memory locations resident + in a CPU cache and that may change the performance and timing characteristics + of an application. The prefetch operations are marked as ReadWriteEffect + to reflect that these operations have side effects with respect to the runtime + performance characteristics of the resulting code. Additionally, if the prefetchValue + operations did not have this attribute, GHC does a float out transformation that + results in a let-can-float invariant violation, at least with the current design. + } + + + +------------------------------------------------------------------------ + + +--- the Int# argument for prefetch is the byte offset on the byteArray or Addr# + +--- +primop PrefetchByteArrayOp3 "prefetchByteArray3#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchMutableByteArrayOp3 "prefetchMutableByteArray3#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp + a -> State# s -> State# s + with effect = ReadWriteEffect +---- + +primop PrefetchByteArrayOp2 "prefetchByteArray2#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchMutableByteArrayOp2 "prefetchMutableByteArray2#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp + a -> State# s -> State# s + with effect = ReadWriteEffect +---- + +primop PrefetchByteArrayOp1 "prefetchByteArray1#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchMutableByteArrayOp1 "prefetchMutableByteArray1#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp + a -> State# s -> State# s + with effect = ReadWriteEffect +---- + +primop PrefetchByteArrayOp0 "prefetchByteArray0#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchMutableByteArrayOp0 "prefetchMutableByteArray0#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp + a -> State# s -> State# s + with effect = ReadWriteEffect + + +-- Note [RuntimeRep polymorphism in continuation-style primops] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- See below. + +section "RuntimeRep polymorphism in continuation-style primops" + { + Several primops provided by GHC accept continuation arguments with highly polymorphic + arguments. For instance, consider the type of `catch#`: + + catch# :: forall (r_rep :: RuntimeRep) (r :: TYPE r_rep) w. + (State# RealWorld -> (# State# RealWorld, r #) ) + -> (w -> State# RealWorld -> (# State# RealWorld, r #) ) + -> State# RealWorld + -> (# State# RealWorld, r #) + + This type suggests that we could instantiate `catch#` continuation argument + (namely, the first argument) with something like, + + f :: State# RealWorld -> (# State# RealWorld, (# Int, String, Int8# #) #) + + However, sadly the type does not capture an important limitation of the + primop. Specifically, due to the operational behavior of `catch#` the result + type must be representable with a single machine word. In a future GHC + release we may improve the precision of this type to capture this limitation. + + See #21868. + } + +------------------------------------------------------------------------ +--- --- +------------------------------------------------------------------------ + +thats_all_folks diff --git a/GHC/ByteCode/Asm.hs b/GHC/ByteCode/Asm.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/Asm.hs @@ -0,0 +1,1044 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler and linker +module GHC.ByteCode.Asm ( + assembleBCOs, + bcoFreeNames, + SizedSeq, sizeSS, ssElts, + iNTERP_STACK_CHECK_THRESH, + mkNativeCallInfoLit, + + -- * For testing + assembleBCO + ) where + +import GHC.Prelude hiding ( any ) + + +import GHC.ByteCode.Instr +import GHC.ByteCode.InfoTable +import GHC.ByteCode.Types +import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord ) + +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Literal +import GHC.Types.Unique.DSet +import GHC.Types.SptEntry +import GHC.Types.Unique.FM +import GHC.Unit.Types + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Core.TyCon +import GHC.Data.SizedSeq +import GHC.Data.SmallArray + +import GHC.StgToCmm.Layout ( ArgRep(..) ) +import GHC.Cmm.Expr +import GHC.Cmm.Reg ( GlobalArgRegs(..) ) +import GHC.Cmm.CallConv ( allArgRegsCover ) +import GHC.Platform +import GHC.Platform.Profile +import Language.Haskell.Syntax.Module.Name + +import Control.Monad +import qualified Control.Monad.Trans.State.Strict as MTL + +import qualified Data.Array.Unboxed as Array +import qualified Data.Array.IO as Array +import Data.Array.Base ( UArray(..), numElements, unsafeFreeze ) + +#if ! defined(DEBUG) +import Data.Array.Base ( unsafeWrite ) +#endif + +import Foreign hiding (shiftL, shiftR) +import Data.ByteString (ByteString) +import Data.Char (ord) +import Data.Maybe (fromMaybe) +import GHC.Float (castFloatToWord32, castDoubleToWord64) + +import qualified Data.List as List ( any ) +import GHC.Exts + + +-- ----------------------------------------------------------------------------- +-- Unlinked BCOs + +-- CompiledByteCode represents the result of byte-code +-- compiling a bunch of functions and data types + +-- | Finds external references. Remember to remove the names +-- defined by this group of BCOs themselves +bcoFreeNames :: UnlinkedBCO -> UniqDSet Name +bcoFreeNames bco + = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] + where + bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) + = unionManyUniqDSets ( + mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] : + mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] : + map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag ptrs ] + ) + +-- ----------------------------------------------------------------------------- +-- The bytecode assembler + +-- The object format for bytecodes is: 16 bits for the opcode, and 16 +-- for each field -- so the code can be considered a sequence of +-- 16-bit ints. Each field denotes either a stack offset or number of +-- items on the stack (eg SLIDE), and index into the pointer table (eg +-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a +-- bytecode address in this BCO. + +-- Top level assembler fn. +assembleBCOs + :: Profile + -> FlatBag (ProtoBCO Name) + -> [TyCon] + -> [(Name, ByteString)] + -> Maybe InternalModBreaks + -> [SptEntry] + -> IO CompiledByteCode +assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do + -- TODO: the profile should be bundled with the interpreter: the rts ways are + -- fixed for an interpreter + let itbls = mkITbls profile tycons + bcos <- mapM (assembleBCO (profilePlatform profile)) proto_bcos + return CompiledByteCode + { bc_bcos = bcos + , bc_itbls = itbls + , bc_strs = top_strs + , bc_breaks = modbreaks + , bc_spt_entries = spt_entries + } + +-- Note [Allocating string literals] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Our strategy for handling top-level string literal bindings is described in +-- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode, +-- but not all Addr# literals in a program are guaranteed to be lifted to the +-- top level. Our strategy for handling local Addr# literals is somewhat simpler: +-- after assembling, we find all the BCONPtrStr arguments in the program, malloc +-- memory for them, and bake the resulting addresses into the instruction stream +-- in the form of BCONPtrWord arguments. +-- +-- We used to allocate remote buffers for BCONPtrStr ByteStrings when +-- assembling, but this gets in the way of bytecode serialization: we +-- want the ability to serialize and reload assembled bytecode, so +-- it's better to preserve BCONPtrStr as-is, and only perform the +-- actual allocation at link-time. +-- +-- Note that, as with top-level string literal bindings, this memory is never +-- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for +-- top-level string literal bindings] in GHC.StgToByteCode for some discussion +-- about why. +-- + +data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16) + , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr) + , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr ) + } + +data RunAsmResult = RunAsmResult { final_isn_array :: !(Array.UArray Int Word16) + , final_ptr_array :: !(SmallArray BCOPtr) + , final_lit_array :: !(SmallArray BCONPtr) } + +-- How many words we have written so far. +data AsmState = AsmState { nisn :: !Int, nptr :: !Int, nlit :: !Int } + + +{-# NOINLINE inspectInstrs #-} +-- | Perform analysis of the bytecode to determine +-- 1. How many instructions we will produce +-- 2. If we are going to need long jumps. +-- 3. The offsets that labels refer to +inspectInstrs :: Platform -> Bool -> Word -> [BCInstr] -> InspectState +inspectInstrs platform long_jump e instrs = + inspectAsm long_jump e (mapM_ (assembleInspectAsm platform) instrs) + +{-# NOINLINE runInstrs #-} +-- | Assemble the bytecode from the instructions. +runInstrs :: Platform -> Bool -> InspectState -> [BCInstr] -> IO RunAsmResult +runInstrs platform long_jumps is_state instrs = do + -- Produce arrays of exactly the right size, corresponding to the result of inspectInstrs. + isn_array <- Array.newArray_ (0, (fromIntegral $ instrCount is_state) - 1) + ptr_array <- newSmallArrayIO (fromIntegral $ ptrCount is_state) undefined + lit_array <- newSmallArrayIO (fromIntegral $ litCount is_state) undefined + let env :: LocalLabel -> Word + env lbl = fromMaybe + (pprPanic "assembleBCO.findLabel" (ppr lbl)) + (lookupUFM (lblEnv is_state) lbl) + let initial_state = AsmState 0 0 0 + let initial_reader = RunAsmReader{..} + runAsm long_jumps env initial_reader initial_state (mapM_ (\i -> assembleRunAsm platform i) instrs) + final_isn_array <- unsafeFreeze isn_array + final_ptr_array <- unsafeFreezeSmallArrayIO ptr_array + final_lit_array <- unsafeFreezeSmallArrayIO lit_array + return $ RunAsmResult {..} + +assembleRunAsm :: Platform -> BCInstr -> RunAsm () +assembleRunAsm p i = assembleI @RunAsm p i + +assembleInspectAsm :: Platform -> BCInstr -> InspectAsm () +assembleInspectAsm p i = assembleI @InspectAsm p i + +assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO +assembleBCO platform + (ProtoBCO { protoBCOName = nm + , protoBCOInstrs = instrs + , protoBCOBitmap = bitmap + , protoBCOBitmapSize = bsize + , protoBCOArity = arity }) = do + -- pass 1: collect up the offsets of the local labels. + let initial_offset = 0 + + -- Jump instructions are variable-sized, there are long and short variants + -- depending on the magnitude of the offset. However, we can't tell what + -- size instructions we will need until we have calculated the offsets of + -- the labels, which depends on the size of the instructions... So we + -- first create the label environment assuming that all jumps are short, + -- and if the final size is indeed small enough for short jumps, we are + -- done. Otherwise, we repeat the calculation, and we force all jumps in + -- this BCO to be long. + is0 = inspectInstrs platform False initial_offset instrs + (is1, long_jumps) + | isLargeInspectState is0 + = (inspectInstrs platform True initial_offset instrs, True) + | otherwise = (is0, False) + + + -- pass 2: run assembler and generate instructions, literals and pointers + RunAsmResult{..} <- runInstrs platform long_jumps is1 instrs + + -- precomputed size should be equal to final size + massertPpr (fromIntegral (instrCount is1) == numElements final_isn_array + && fromIntegral (ptrCount is1) == sizeofSmallArray final_ptr_array + && fromIntegral (litCount is1) == sizeofSmallArray final_lit_array) + (text "bytecode instruction count mismatch") + + let !insns_arr = mkBCOByteArray $ final_isn_array + !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap + ul_bco = UnlinkedBCO { unlinkedBCOName = nm + , unlinkedBCOArity = arity + , unlinkedBCOInstrs = insns_arr + , unlinkedBCOBitmap = bitmap_arr + , unlinkedBCOLits = fromSmallArray final_lit_array + , unlinkedBCOPtrs = fromSmallArray final_ptr_array + } + + -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive + -- objects, since they might get run too early. Disable this until + -- we figure out what to do. + -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) + + return ul_bco + +-- | Construct a word-array containing an @StgLargeBitmap@. +mkBitmapArray :: Word -> [StgWord] -> UArray Int Word +-- Here the return type must be an array of Words, not StgWords, +-- because the underlying ByteArray# will end up as a component +-- of a BCO object. +mkBitmapArray bsize bitmap + = Array.listArray (0, length bitmap) $ + fromIntegral bsize : map (fromInteger . fromStgWord) bitmap + + +data Operand + = Op Word + | IOp Int + | SmallOp Word16 + | LabelOp LocalLabel + +wOp :: WordOff -> Operand +wOp = Op . fromIntegral + +bOp :: ByteOff -> Operand +bOp = Op . fromIntegral + +truncHalfWord :: Platform -> HalfWord -> Operand +truncHalfWord platform w = case platformWordSize platform of + PW4 | w <= 65535 -> Op (fromIntegral w) + PW8 | w <= 4294967295 -> Op (fromIntegral w) + _ -> pprPanic "GHC.ByteCode.Asm.truncHalfWord" (ppr w) + + +ptr :: MonadAssembler m => BCOPtr -> m Word +ptr = ioptr . return + +type LabelEnv = LocalLabel -> Word + +largeOp :: Bool -> Operand -> Bool +largeOp long_jumps op = case op of + SmallOp _ -> False + Op w -> isLargeW w + IOp i -> isLargeI i + LabelOp _ -> long_jumps + +newtype RunAsm a = RunAsm' { runRunAsm :: Bool + -> LabelEnv + -> RunAsmReader + -> AsmState + -> IO (AsmState, a) } + +pattern RunAsm :: (Bool -> LabelEnv -> RunAsmReader -> AsmState -> IO (AsmState, a)) + -> RunAsm a +pattern RunAsm m <- RunAsm' m + where + RunAsm m = RunAsm' (oneShot $ \a -> oneShot $ \b -> oneShot $ \c -> oneShot $ \d -> m a b c d) +{-# COMPLETE RunAsm #-} + +instance Functor RunAsm where + fmap f (RunAsm x) = RunAsm (\a b c !s -> fmap (fmap f) (x a b c s)) + +instance Applicative RunAsm where + pure x = RunAsm $ \_ _ _ !s -> pure (s, x) + (RunAsm f) <*> (RunAsm x) = RunAsm $ \a b c !s -> do + (!s', f') <- f a b c s + (!s'', x') <- x a b c s' + return (s'', f' x') + {-# INLINE (<*>) #-} + + +instance Monad RunAsm where + return = pure + (RunAsm m) >>= f = RunAsm $ \a b c !s -> m a b c s >>= \(s', r) -> runRunAsm (f r) a b c s' + {-# INLINE (>>=) #-} + +runAsm :: Bool -> LabelEnv -> RunAsmReader -> AsmState -> RunAsm a -> IO a +runAsm long_jumps e r s (RunAsm'{runRunAsm}) = fmap snd $ runRunAsm long_jumps e r s + +expand :: PlatformWordSize -> Bool -> Operand -> RunAsm () +expand word_size largeArgs o = do + e <- askEnv + case o of + (SmallOp w) -> writeIsn w + (LabelOp w) -> let !r = e w in handleLargeArg r + (Op w) -> handleLargeArg w + (IOp i) -> handleLargeArg i + + where + handleLargeArg :: Integral a => a -> RunAsm () + handleLargeArg w = + if largeArgs + then largeArg word_size (fromIntegral w) + else writeIsn (fromIntegral w) + +lift :: IO a -> RunAsm a +lift io = RunAsm $ \_ _ _ s -> io >>= \a -> pure (s, a) + +askLongJumps :: RunAsm Bool +askLongJumps = RunAsm $ \a _ _ s -> pure (s, a) + +askEnv :: RunAsm LabelEnv +askEnv = RunAsm $ \_ b _ s -> pure (s, b) + +writePtr :: BCOPtr -> RunAsm Word +writePtr w + = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do + writeSmallArrayIO ptr_array (nptr asm) w + let !n' = nptr asm + 1 + let !asm' = asm { nptr = n' } + return (asm', fromIntegral (nptr asm)) + +writeLit :: BCONPtr -> RunAsm Word +writeLit w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do + writeSmallArrayIO lit_array (nlit asm) w + let !n' = nlit asm + 1 + let !asm' = asm { nlit = n' } + return (asm', fromIntegral (nlit asm)) + +writeLits :: OneOrTwo BCONPtr -> RunAsm Word +writeLits (OnlyOne l) = writeLit l +writeLits (OnlyTwo l1 l2) = writeLit l1 <* writeLit l2 + +writeIsn :: Word16 -> RunAsm () +writeIsn w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do +#if defined(DEBUG) + Array.writeArray isn_array (nisn asm) w +#else + unsafeWrite isn_array (nisn asm) w +#endif + let !n' = nisn asm + 1 + let !asm' = asm { nisn = n' } + return (asm', ()) + +{-# INLINE any #-} +-- Any is unrolled manually so that the call in `emit` can be eliminated without +-- relying on SpecConstr (which does not work across modules). +any :: (a -> Bool) -> [a] -> Bool +any _ [] = False +any f [x] = f x +any f [x,y] = f x || f y +any f [x,y,z] = f x || f y || f z +any f [x1,x2,x3,x4] = f x1 || f x2 || f x3 || f x4 +any f [x1,x2,x3,x4, x5] = f x1 || f x2 || f x3 || f x4 || f x5 +any f [x1,x2,x3,x4,x5,x6] = f x1 || f x2 || f x3 || f x4 || f x5 || f x6 +any f xs = List.any f xs + +{-# INLINE mapM6_ #-} +mapM6_ :: Monad m => (a -> m b) -> [a] -> m () +mapM6_ _ [] = return () +mapM6_ f [x] = () <$ f x +mapM6_ f [x,y] = () <$ f x <* f y +mapM6_ f [x,y,z] = () <$ f x <* f y <* f z +mapM6_ f [a1,a2,a3,a4] = () <$ f a1 <* f a2 <* f a3 <* f a4 +mapM6_ f [a1,a2,a3,a4,a5] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5 +mapM6_ f [a1,a2,a3,a4,a5,a6] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5 <* f a6 +mapM6_ f xs = mapM_ f xs + +instance MonadAssembler RunAsm where + ioptr p_io = do + p <- lift p_io + writePtr p + lit lits = writeLits lits + + label _ = return () + + emit pwordsize w ops = do + long_jumps <- askLongJumps + -- See the definition of `any` above + let largeArgs = any (largeOp long_jumps) ops + let opcode + | largeArgs = largeArgInstr w + | otherwise = w + writeIsn opcode + mapM6_ (expand pwordsize largeArgs) ops + + {-# INLINE emit #-} + {-# INLINE label #-} + {-# INLINE lit #-} + {-# INLINE ioptr #-} + +type LabelEnvMap = UniqFM LocalLabel Word + +data InspectState = InspectState + { instrCount :: !Word + , ptrCount :: !Word + , litCount :: !Word + , lblEnv :: LabelEnvMap + } + +instance Outputable InspectState where + ppr (InspectState i p l m) = text "InspectState" <+> ppr [ppr i, ppr p, ppr l, ppr (sizeUFM m)] + +isLargeInspectState :: InspectState -> Bool +isLargeInspectState InspectState{..} = + isLargeW (fromIntegral $ sizeUFM lblEnv) + || isLargeW instrCount + +newtype InspectEnv = InspectEnv { _inspectLongJumps :: Bool + } + +newtype InspectAsm a = InspectAsm' { runInspectAsm :: InspectEnv -> InspectState -> (# InspectState, a #) } + +pattern InspectAsm :: (InspectEnv -> InspectState -> (# InspectState, a #)) + -> InspectAsm a +pattern InspectAsm m <- InspectAsm' m + where + InspectAsm m = InspectAsm' (oneShot $ \a -> oneShot $ \b -> m a b) +{-# COMPLETE InspectAsm #-} + +instance Functor InspectAsm where + fmap f (InspectAsm k) = InspectAsm $ \a b -> case k a b of + (# b', c #) -> (# b', f c #) + +instance Applicative InspectAsm where + pure x = InspectAsm $ \_ s -> (# s, x #) + (InspectAsm f) <*> (InspectAsm x) = InspectAsm $ \a b -> case f a b of + (# s', f' #) -> + case x a s' of + (# s'', x' #) -> (# s'', f' x' #) + +instance Monad InspectAsm where + return = pure + (InspectAsm m) >>= f = InspectAsm $ \ a b -> case m a b of + (# s', a' #) -> runInspectAsm (f a') a s' + +get_ :: InspectAsm InspectState +get_ = InspectAsm $ \_ b -> (# b, b #) + +put_ :: InspectState -> InspectAsm () +put_ !s = InspectAsm $ \_ _ -> (# s, () #) + +modify_ :: (InspectState -> InspectState) -> InspectAsm () +modify_ f = InspectAsm $ \_ s -> let !s' = f s in (# s', () #) + +ask_ :: InspectAsm InspectEnv +ask_ = InspectAsm $ \a b -> (# b, a #) + +inspectAsm :: Bool -> Word -> InspectAsm () -> InspectState +inspectAsm long_jumps initial_offset (InspectAsm s) = + case s (InspectEnv long_jumps) (InspectState initial_offset 0 0 emptyUFM) of + (# res, () #) -> res +{-# INLINE inspectAsm #-} + + + +instance MonadAssembler InspectAsm where + ioptr _ = do + s <- get_ + let n = ptrCount s + put_ (s { ptrCount = n + 1 }) + return n + + lit ls = do + s <- get_ + let n = litCount s + put_ (s { litCount = n + oneTwoLength ls }) + return n + + label lbl = modify_ (\s -> let !count = instrCount s in let !env' = addToUFM (lblEnv s) lbl count in s { lblEnv = env' }) + + emit pwordsize _ ops = do + InspectEnv long_jumps <- ask_ + -- Size is written in this way as `mapM6_` is also used by RunAsm, and guaranteed + -- to unroll for arguments up to size 6. + let size = (MTL.execState (mapM6_ (\x -> MTL.modify (count' x +)) ops) 0) + 1 + largeOps = any (largeOp long_jumps) ops + bigSize = largeArg16s pwordsize + count' = if largeOps then countLarge bigSize else countSmall bigSize + + s <- get_ + put_ (s { instrCount = instrCount s + size }) + + {-# INLINE emit #-} + {-# INLINE label #-} + {-# INLINE lit #-} + {-# INLINE ioptr #-} + +count :: Word -> Bool -> Operand -> Word +count _ _ (SmallOp _) = 1 +count big largeOps (LabelOp _) = if largeOps then big else 1 +count big largeOps (Op _) = if largeOps then big else 1 +count big largeOps (IOp _) = if largeOps then big else 1 +{-# INLINE count #-} + +countSmall, countLarge :: Word -> Operand -> Word +countLarge big x = count big True x +countSmall big x = count big False x + + +-- Bring in all the bci_ bytecode constants. +#include "Bytecodes.h" + +largeArgInstr :: Word16 -> Word16 +largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci + +{-# INLINE largeArg #-} +largeArg :: PlatformWordSize -> Word64 -> RunAsm () +largeArg wsize w = case wsize of + PW8 -> do writeIsn (fromIntegral (w `shiftR` 48)) + writeIsn (fromIntegral (w `shiftR` 32)) + writeIsn (fromIntegral (w `shiftR` 16)) + writeIsn (fromIntegral w) + PW4 -> assertPpr (w < fromIntegral (maxBound :: Word32)) + (text "largeArg too big:" <+> ppr w) $ do + writeIsn (fromIntegral (w `shiftR` 16)) + writeIsn (fromIntegral w) + +largeArg16s :: PlatformWordSize -> Word +largeArg16s pwordsize = case pwordsize of + PW8 -> 4 + PW4 -> 2 + +data OneOrTwo a = OnlyOne a | OnlyTwo a a deriving (Functor) + +oneTwoLength :: OneOrTwo a -> Word +oneTwoLength (OnlyOne {}) = 1 +oneTwoLength (OnlyTwo {}) = 2 + +class Monad m => MonadAssembler m where + ioptr :: IO BCOPtr -> m Word + lit :: OneOrTwo BCONPtr -> m Word + label :: LocalLabel -> m () + emit :: PlatformWordSize -> Word16 -> [Operand] -> m () + +lit1 :: MonadAssembler m => BCONPtr -> m Word +lit1 p = lit (OnlyOne p) + +{-# SPECIALISE assembleI :: Platform -> BCInstr -> InspectAsm () #-} +{-# SPECIALISE assembleI :: Platform -> BCInstr -> RunAsm () #-} + +assembleI :: forall m . MonadAssembler m + => Platform + -> BCInstr + -> m () +assembleI platform i = case i of + STKCHECK n -> emit_ bci_STKCHECK [Op n] + PUSH_L o1 -> emit_ bci_PUSH_L [wOp o1] + PUSH_LL o1 o2 -> emit_ bci_PUSH_LL [wOp o1, wOp o2] + PUSH_LLL o1 o2 o3 -> emit_ bci_PUSH_LLL [wOp o1, wOp o2, wOp o3] + PUSH8 o1 -> emit_ bci_PUSH8 [bOp o1] + PUSH16 o1 -> emit_ bci_PUSH16 [bOp o1] + PUSH32 o1 -> emit_ bci_PUSH32 [bOp o1] + PUSH8_W o1 -> emit_ bci_PUSH8_W [bOp o1] + PUSH16_W o1 -> emit_ bci_PUSH16_W [bOp o1] + PUSH32_W o1 -> emit_ bci_PUSH32_W [bOp o1] + PUSH_G nm -> do p <- ptr (BCOPtrName nm) + emit_ bci_PUSH_G [Op p] + PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) + emit_ bci_PUSH_G [Op p] + PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit_ bci_PUSH_G [Op p] + PUSH_ALTS proto pk + -> do let ul_bco = assembleBCO platform proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit_ (push_alts pk) [Op p] + PUSH_ALTS_TUPLE proto call_info tuple_proto + -> do let ul_bco = assembleBCO platform proto + ul_tuple_bco = assembleBCO platform + tuple_proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco) + info <- word (fromIntegral $ + mkNativeCallInfoSig platform call_info) + emit_ bci_PUSH_ALTS_T + [Op p, Op info, Op p_tup] + PUSH_PAD8 -> emit_ bci_PUSH_PAD8 [] + PUSH_PAD16 -> emit_ bci_PUSH_PAD16 [] + PUSH_PAD32 -> emit_ bci_PUSH_PAD32 [] + PUSH_UBX8 lit -> do np <- literal lit + emit_ bci_PUSH_UBX8 [Op np] + PUSH_UBX16 lit -> do np <- literal lit + emit_ bci_PUSH_UBX16 [Op np] + PUSH_UBX32 lit -> do np <- literal lit + emit_ bci_PUSH_UBX32 [Op np] + PUSH_UBX lit nws -> do np <- literal lit + emit_ bci_PUSH_UBX [Op np, wOp nws] + -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode + PUSH_ADDR nm -> do np <- lit1 (BCONPtrAddr nm) + emit_ bci_PUSH_UBX [Op np, SmallOp 1] + + PUSH_APPLY_N -> emit_ bci_PUSH_APPLY_N [] + PUSH_APPLY_V -> emit_ bci_PUSH_APPLY_V [] + PUSH_APPLY_F -> emit_ bci_PUSH_APPLY_F [] + PUSH_APPLY_D -> emit_ bci_PUSH_APPLY_D [] + PUSH_APPLY_L -> emit_ bci_PUSH_APPLY_L [] + PUSH_APPLY_P -> emit_ bci_PUSH_APPLY_P [] + PUSH_APPLY_PP -> emit_ bci_PUSH_APPLY_PP [] + PUSH_APPLY_PPP -> emit_ bci_PUSH_APPLY_PPP [] + PUSH_APPLY_PPPP -> emit_ bci_PUSH_APPLY_PPPP [] + PUSH_APPLY_PPPPP -> emit_ bci_PUSH_APPLY_PPPPP [] + PUSH_APPLY_PPPPPP -> emit_ bci_PUSH_APPLY_PPPPPP [] + + SLIDE n by -> emit_ bci_SLIDE [wOp n, wOp by] + ALLOC_AP n -> emit_ bci_ALLOC_AP [truncHalfWord platform n] + ALLOC_AP_NOUPD n -> emit_ bci_ALLOC_AP_NOUPD [truncHalfWord platform n] + ALLOC_PAP arity n -> emit_ bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n] + MKAP off sz -> emit_ bci_MKAP [wOp off, truncHalfWord platform sz] + MKPAP off sz -> emit_ bci_MKPAP [wOp off, truncHalfWord platform sz] + UNPACK n -> emit_ bci_UNPACK [wOp n] + PACK dcon sz -> do itbl_no <- lit1 (BCONPtrItbl (getName dcon)) + emit_ bci_PACK [Op itbl_no, wOp sz] + LABEL lbl -> label lbl + TESTLT_I i l -> do np <- int i + emit_ bci_TESTLT_I [Op np, LabelOp l] + TESTEQ_I i l -> do np <- int i + emit_ bci_TESTEQ_I [Op np, LabelOp l] + TESTLT_W w l -> do np <- word w + emit_ bci_TESTLT_W [Op np, LabelOp l] + TESTEQ_W w l -> do np <- word w + emit_ bci_TESTEQ_W [Op np, LabelOp l] + TESTLT_I64 i l -> do np <- word64 (fromIntegral i) + emit_ bci_TESTLT_I64 [Op np, LabelOp l] + TESTEQ_I64 i l -> do np <- word64 (fromIntegral i) + emit_ bci_TESTEQ_I64 [Op np, LabelOp l] + TESTLT_I32 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTLT_I32 [Op np, LabelOp l] + TESTEQ_I32 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTEQ_I32 [Op np, LabelOp l] + TESTLT_I16 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTLT_I16 [Op np, LabelOp l] + TESTEQ_I16 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTEQ_I16 [Op np, LabelOp l] + TESTLT_I8 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTLT_I8 [Op np, LabelOp l] + TESTEQ_I8 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTEQ_I8 [Op np, LabelOp l] + TESTLT_W64 w l -> do np <- word64 w + emit_ bci_TESTLT_W64 [Op np, LabelOp l] + TESTEQ_W64 w l -> do np <- word64 w + emit_ bci_TESTEQ_W64 [Op np, LabelOp l] + TESTLT_W32 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTLT_W32 [Op np, LabelOp l] + TESTEQ_W32 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTEQ_W32 [Op np, LabelOp l] + TESTLT_W16 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTLT_W16 [Op np, LabelOp l] + TESTEQ_W16 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTEQ_W16 [Op np, LabelOp l] + TESTLT_W8 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTLT_W8 [Op np, LabelOp l] + TESTEQ_W8 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTEQ_W8 [Op np, LabelOp l] + TESTLT_F f l -> do np <- float f + emit_ bci_TESTLT_F [Op np, LabelOp l] + TESTEQ_F f l -> do np <- float f + emit_ bci_TESTEQ_F [Op np, LabelOp l] + TESTLT_D d l -> do np <- double d + emit_ bci_TESTLT_D [Op np, LabelOp l] + TESTEQ_D d l -> do np <- double d + emit_ bci_TESTEQ_D [Op np, LabelOp l] + TESTLT_P i l -> emit_ bci_TESTLT_P [SmallOp i, LabelOp l] + TESTEQ_P i l -> emit_ bci_TESTEQ_P [SmallOp i, LabelOp l] + CASEFAIL -> emit_ bci_CASEFAIL [] + SWIZZLE stkoff n -> emit_ bci_SWIZZLE [wOp stkoff, IOp n] + JMP l -> emit_ bci_JMP [LabelOp l] + ENTER -> emit_ bci_ENTER [] + RETURN rep -> emit_ (return_non_tuple rep) [] + RETURN_TUPLE -> emit_ bci_RETURN_T [] + CCALL off ffi i -> do np <- lit1 $ BCONPtrFFIInfo ffi + emit_ bci_CCALL [wOp off, Op np, SmallOp i] + PRIMCALL -> emit_ bci_PRIMCALL [] + + OP_ADD w -> case w of + W64 -> emit_ bci_OP_ADD_64 [] + W32 -> emit_ bci_OP_ADD_32 [] + W16 -> emit_ bci_OP_ADD_16 [] + W8 -> emit_ bci_OP_ADD_08 [] + _ -> unsupported_width + OP_SUB w -> case w of + W64 -> emit_ bci_OP_SUB_64 [] + W32 -> emit_ bci_OP_SUB_32 [] + W16 -> emit_ bci_OP_SUB_16 [] + W8 -> emit_ bci_OP_SUB_08 [] + _ -> unsupported_width + OP_AND w -> case w of + W64 -> emit_ bci_OP_AND_64 [] + W32 -> emit_ bci_OP_AND_32 [] + W16 -> emit_ bci_OP_AND_16 [] + W8 -> emit_ bci_OP_AND_08 [] + _ -> unsupported_width + OP_XOR w -> case w of + W64 -> emit_ bci_OP_XOR_64 [] + W32 -> emit_ bci_OP_XOR_32 [] + W16 -> emit_ bci_OP_XOR_16 [] + W8 -> emit_ bci_OP_XOR_08 [] + _ -> unsupported_width + OP_OR w -> case w of + W64 -> emit_ bci_OP_OR_64 [] + W32 -> emit_ bci_OP_OR_32 [] + W16 -> emit_ bci_OP_OR_16 [] + W8 -> emit_ bci_OP_OR_08 [] + _ -> unsupported_width + OP_NOT w -> case w of + W64 -> emit_ bci_OP_NOT_64 [] + W32 -> emit_ bci_OP_NOT_32 [] + W16 -> emit_ bci_OP_NOT_16 [] + W8 -> emit_ bci_OP_NOT_08 [] + _ -> unsupported_width + OP_NEG w -> case w of + W64 -> emit_ bci_OP_NEG_64 [] + W32 -> emit_ bci_OP_NEG_32 [] + W16 -> emit_ bci_OP_NEG_16 [] + W8 -> emit_ bci_OP_NEG_08 [] + _ -> unsupported_width + OP_MUL w -> case w of + W64 -> emit_ bci_OP_MUL_64 [] + W32 -> emit_ bci_OP_MUL_32 [] + W16 -> emit_ bci_OP_MUL_16 [] + W8 -> emit_ bci_OP_MUL_08 [] + _ -> unsupported_width + OP_SHL w -> case w of + W64 -> emit_ bci_OP_SHL_64 [] + W32 -> emit_ bci_OP_SHL_32 [] + W16 -> emit_ bci_OP_SHL_16 [] + W8 -> emit_ bci_OP_SHL_08 [] + _ -> unsupported_width + OP_ASR w -> case w of + W64 -> emit_ bci_OP_ASR_64 [] + W32 -> emit_ bci_OP_ASR_32 [] + W16 -> emit_ bci_OP_ASR_16 [] + W8 -> emit_ bci_OP_ASR_08 [] + _ -> unsupported_width + OP_LSR w -> case w of + W64 -> emit_ bci_OP_LSR_64 [] + W32 -> emit_ bci_OP_LSR_32 [] + W16 -> emit_ bci_OP_LSR_16 [] + W8 -> emit_ bci_OP_LSR_08 [] + _ -> unsupported_width + + OP_NEQ w -> case w of + W64 -> emit_ bci_OP_NEQ_64 [] + W32 -> emit_ bci_OP_NEQ_32 [] + W16 -> emit_ bci_OP_NEQ_16 [] + W8 -> emit_ bci_OP_NEQ_08 [] + _ -> unsupported_width + OP_EQ w -> case w of + W64 -> emit_ bci_OP_EQ_64 [] + W32 -> emit_ bci_OP_EQ_32 [] + W16 -> emit_ bci_OP_EQ_16 [] + W8 -> emit_ bci_OP_EQ_08 [] + _ -> unsupported_width + + OP_U_LT w -> case w of + W64 -> emit_ bci_OP_U_LT_64 [] + W32 -> emit_ bci_OP_U_LT_32 [] + W16 -> emit_ bci_OP_U_LT_16 [] + W8 -> emit_ bci_OP_U_LT_08 [] + _ -> unsupported_width + OP_S_LT w -> case w of + W64 -> emit_ bci_OP_S_LT_64 [] + W32 -> emit_ bci_OP_S_LT_32 [] + W16 -> emit_ bci_OP_S_LT_16 [] + W8 -> emit_ bci_OP_S_LT_08 [] + _ -> unsupported_width + OP_U_GE w -> case w of + W64 -> emit_ bci_OP_U_GE_64 [] + W32 -> emit_ bci_OP_U_GE_32 [] + W16 -> emit_ bci_OP_U_GE_16 [] + W8 -> emit_ bci_OP_U_GE_08 [] + _ -> unsupported_width + OP_S_GE w -> case w of + W64 -> emit_ bci_OP_S_GE_64 [] + W32 -> emit_ bci_OP_S_GE_32 [] + W16 -> emit_ bci_OP_S_GE_16 [] + W8 -> emit_ bci_OP_S_GE_08 [] + _ -> unsupported_width + OP_U_GT w -> case w of + W64 -> emit_ bci_OP_U_GT_64 [] + W32 -> emit_ bci_OP_U_GT_32 [] + W16 -> emit_ bci_OP_U_GT_16 [] + W8 -> emit_ bci_OP_U_GT_08 [] + _ -> unsupported_width + OP_S_GT w -> case w of + W64 -> emit_ bci_OP_S_GT_64 [] + W32 -> emit_ bci_OP_S_GT_32 [] + W16 -> emit_ bci_OP_S_GT_16 [] + W8 -> emit_ bci_OP_S_GT_08 [] + _ -> unsupported_width + OP_U_LE w -> case w of + W64 -> emit_ bci_OP_U_LE_64 [] + W32 -> emit_ bci_OP_U_LE_32 [] + W16 -> emit_ bci_OP_U_LE_16 [] + W8 -> emit_ bci_OP_U_LE_08 [] + _ -> unsupported_width + OP_S_LE w -> case w of + W64 -> emit_ bci_OP_S_LE_64 [] + W32 -> emit_ bci_OP_S_LE_32 [] + W16 -> emit_ bci_OP_S_LE_16 [] + W8 -> emit_ bci_OP_S_LE_08 [] + _ -> unsupported_width + + OP_INDEX_ADDR w -> case w of + W64 -> emit_ bci_OP_INDEX_ADDR_64 [] + W32 -> emit_ bci_OP_INDEX_ADDR_32 [] + W16 -> emit_ bci_OP_INDEX_ADDR_16 [] + W8 -> emit_ bci_OP_INDEX_ADDR_08 [] + _ -> unsupported_width + + BRK_FUN ibi@(InternalBreakpointId info_mod infox) -> do + p1 <- ptr $ BCOPtrBreakArray info_mod + let -- cast that checks that round-tripping through Word32 doesn't change the value + infoW32 = let r = fromIntegral infox :: Word32 + in if fromIntegral r == infox + then r + else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr infox) + ix_hi = fromIntegral (infoW32 `shiftR` 16) + ix_lo = fromIntegral (infoW32 .&. 0xffff) + info_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod + info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId info_mod + np <- lit1 $ BCONPtrCostCentre ibi + emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr + , SmallOp ix_hi, SmallOp ix_lo, Op np ] + +#if MIN_VERSION_rts(1,0,3) + BCO_NAME name -> do np <- lit1 (BCONPtrStr name) + emit_ bci_BCO_NAME [Op np] +#endif + + + + where + unsupported_width = panic "GHC.ByteCode.Asm: Unsupported Width" + emit_ = emit word_size + + literal :: Literal -> m Word + literal (LitLabel fs _) = litlabel fs + literal LitNullAddr = word 0 + literal (LitFloat r) = float (fromRational r) + literal (LitDouble r) = double (fromRational r) + literal (LitChar c) = int (ord c) + literal (LitString bs) = lit1 (BCONPtrStr bs) + -- LitString requires a zero-terminator when emitted + literal (LitNumber nt i) = case nt of + LitNumInt -> word (fromIntegral i) + LitNumWord -> word (fromIntegral i) + LitNumInt8 -> word8 (fromIntegral i) + LitNumWord8 -> word8 (fromIntegral i) + LitNumInt16 -> word16 (fromIntegral i) + LitNumWord16 -> word16 (fromIntegral i) + LitNumInt32 -> word32 (fromIntegral i) + LitNumWord32 -> word32 (fromIntegral i) + LitNumInt64 -> word64 (fromIntegral i) + LitNumWord64 -> word64 (fromIntegral i) + LitNumBigNat -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat" + + -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most + -- likely to elicit a crash (rather than corrupt memory) in case absence + -- analysis messed up. + literal (LitRubbish {}) = word 0 + + litlabel fs = lit1 (BCONPtrLbl fs) + words ws = lit (fmap BCONPtrWord ws) + word w = words (OnlyOne w) + word2 w1 w2 = words (OnlyTwo w1 w2) + word_size = platformWordSize platform + word_size_bits = platformWordSizeInBits platform + + -- Make lists of host-sized words for literals, so that when the + -- words are placed in memory at increasing addresses, the + -- bit pattern is correct for the host's word size and endianness. + -- + -- Note that we only support host endianness == target endianness for now, + -- even with the external interpreter. This would need to be fixed to + -- support host endianness /= target endianness + int :: Int -> m Word + int i = word (fromIntegral i) + + float :: Float -> m Word + float f = word32 (castFloatToWord32 f) + + double :: Double -> m Word + double d = word64 (castDoubleToWord64 d) + + word64 :: Word64 -> m Word + word64 ww = case word_size of + PW4 -> + let !wl = fromIntegral ww + !wh = fromIntegral (ww `unsafeShiftR` 32) + in case platformByteOrder platform of + LittleEndian -> word2 wl wh + BigEndian -> word2 wh wl + PW8 -> word (fromIntegral ww) + + word8 :: Word8 -> m Word + word8 x = case platformByteOrder platform of + LittleEndian -> word (fromIntegral x) + BigEndian -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8)) + + word16 :: Word16 -> m Word + word16 x = case platformByteOrder platform of + LittleEndian -> word (fromIntegral x) + BigEndian -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16)) + + word32 :: Word32 -> m Word + word32 x = case platformByteOrder platform of + LittleEndian -> word (fromIntegral x) + BigEndian -> case word_size of + PW4 -> word (fromIntegral x) + PW8 -> word (fromIntegral x `unsafeShiftL` 32) + + +isLargeW :: Word -> Bool +isLargeW n = n > 65535 + +isLargeI :: Int -> Bool +isLargeI n = n > 32767 || n < -32768 + +push_alts :: ArgRep -> Word16 +push_alts V = bci_PUSH_ALTS_V +push_alts P = bci_PUSH_ALTS_P +push_alts N = bci_PUSH_ALTS_N +push_alts L = bci_PUSH_ALTS_L +push_alts F = bci_PUSH_ALTS_F +push_alts D = bci_PUSH_ALTS_D +push_alts V16 = error "push_alts: vector" +push_alts V32 = error "push_alts: vector" +push_alts V64 = error "push_alts: vector" + +return_non_tuple :: ArgRep -> Word16 +return_non_tuple V = bci_RETURN_V +return_non_tuple P = bci_RETURN_P +return_non_tuple N = bci_RETURN_N +return_non_tuple L = bci_RETURN_L +return_non_tuple F = bci_RETURN_F +return_non_tuple D = bci_RETURN_D +return_non_tuple V16 = error "return_non_tuple: vector" +return_non_tuple V32 = error "return_non_tuple: vector" +return_non_tuple V64 = error "return_non_tuple: vector" + +{- + we can only handle up to a fixed number of words on the stack, + because we need a stg_ctoi_tN stack frame for each size N. See + Note [unboxed tuple bytecodes and tuple_BCO]. + + If needed, you can support larger tuples by adding more in + Jumps.cmm, StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and + raising this limit. + + Note that the limit is the number of words passed on the stack. + If the calling convention passes part of the tuple in registers, the + maximum number of tuple elements may be larger. Elements can also + take multiple words on the stack (for example Double# on a 32 bit + platform). + -} +maxTupleReturnNativeStackSize :: WordOff +maxTupleReturnNativeStackSize = 62 + +{- + Construct the call_info word that stg_ctoi_t, stg_ret_t and stg_primcall + use to convert arguments between the native calling convention and the + interpreter. + + See Note [GHCi and native call registers] for more information. + -} +mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32 +mkNativeCallInfoSig platform NativeCallInfo{..} + | nativeCallType == NativeTupleReturn && nativeCallStackSpillSize > maxTupleReturnNativeStackSize + = pprPanic "mkNativeCallInfoSig: tuple too big for the bytecode compiler" + (ppr nativeCallStackSpillSize <+> text "stack words." <+> + text "Use -fobject-code to get around this limit" + ) + | otherwise + = -- 24 bits for register bitmap + assertPpr (length argRegs <= 24) (text "too many registers for bitmap:" <+> ppr (length argRegs)) + + -- 8 bits for continuation offset (only for NativeTupleReturn) + assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset) + + -- all regs accounted for + assertPpr (all (`elem` (map fst argRegs)) (regSetToList nativeCallRegs)) + ( vcat + [ text "not all registers accounted for" + , text "argRegs:" <+> ppr argRegs + , text "nativeCallRegs:" <+> ppr nativeCallRegs + ] ) $ + -- SIMD GHCi TODO: the above assertion doesn't account for register overlap; + -- it will need to be adjusted for SIMD vector support in the bytecode interpreter. + + foldl' reg_bit 0 argRegs .|. (cont_offset `shiftL` 24) + where + cont_offset :: Word32 + cont_offset + | nativeCallType == NativeTupleReturn = fromIntegral nativeCallStackSpillSize + | otherwise = 0 -- there is no continuation for primcalls + + reg_bit :: Word32 -> (GlobalReg, Int) -> Word32 + reg_bit x (r, n) + | r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n + | otherwise = x + argRegs = zip (allArgRegsCover platform SCALAR_ARG_REGS) [0..] + -- The bytecode interpreter does not (currently) handle vector registers, + -- so we only use the scalar argument-passing registers here. + +mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal +mkNativeCallInfoLit platform call_info = + mkLitWord platform . fromIntegral $ mkNativeCallInfoSig platform call_info + +iNTERP_STACK_CHECK_THRESH :: Int +iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH diff --git a/GHC/ByteCode/Breakpoints.hs b/GHC/ByteCode/Breakpoints.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/Breakpoints.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Breakpoint information constructed during ByteCode generation. +-- +-- Specifically, code-generation breakpoints are referred to as "internal +-- breakpoints", the internal breakpoint data for a module is stored in +-- 'InternalModBreaks', and is uniquely identified at runtime by an +-- 'InternalBreakpointId'. +-- +-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers] +module GHC.ByteCode.Breakpoints + ( -- * Internal Mod Breaks + InternalModBreaks(..), CgBreakInfo(..) + , mkInternalModBreaks, imodBreaks_module + + -- ** Internal breakpoint identifier + , InternalBreakpointId(..), BreakInfoIndex + , InternalBreakLoc(..) + + -- * Operations + + -- ** Internal-level operations + , getInternalBreak + + -- ** Source-level information operations + , getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS + , getBreakSourceId, getBreakSourceMod + + -- * Utils + , seqInternalModBreaks + + ) + where + +import GHC.Prelude +import GHC.Types.SrcLoc +import GHC.Types.Name.Occurrence +import Control.DeepSeq +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IM + +import GHC.HsToCore.Breakpoints +import GHC.Iface.Syntax + +import GHC.Unit.Module (Module) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import Data.Array + +{- +Note [ModBreaks vs InternalModBreaks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'ModBreaks' and 'BreakpointId's must not to be confused with +'InternalModBreaks' and 'InternalBreakId's. + +'ModBreaks' is constructed once during HsToCore from the information attached +to source-level breakpoint ticks and is never changed afterwards. A 'ModBreaks' +can be queried using 'BreakpointId's, which uniquely identifies a breakpoint +within the list of breakpoint information for a given module's 'ModBreaks'. + +'InternalModBreaks' are constructed during bytecode generation and are indexed +by a 'InternalBreakpointId'. They contain all the information relevant to a +breakpoint for code generation that can be accessed during runtime execution +(such as a 'BreakArray' for triggering breakpoints). 'InternalBreakpointId's +are used at runtime to trigger and inspect breakpoints -- a 'BRK_FUN' +instruction receives 'InternalBreakpointId' as an argument. + +We keep a mapping from 'InternalModBreaks' to a 'BreakpointId', which can then be used +to get source-level information about a breakpoint via the corresponding 'ModBreaks'. + +Notably, 'InternalModBreaks' can contain entries for so-called internal +breakpoints, which do not necessarily have a source-level location attached to +it (i.e. do not have a matching entry in 'ModBreaks'). We may leverage this to +introduce breakpoints during code generation for features such as stepping-out. + +Note [Breakpoint identifiers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before optimization a breakpoint is identified uniquely with a tick module +and a tick index. See 'BreakpointId'. A tick module contains an array, indexed +with the tick indexes, which indicates breakpoint status. + +When we generate ByteCode, we collect information for every breakpoint at +their *occurrence sites* (see CgBreakInfo) and these info +are stored in the ModIface of the occurrence module. Because of inlining, we +can't reuse the tick index to uniquely identify an occurrence; because of +cross-module inlining, we can't assume that the occurrence module is the same +as the tick module (#24712). + +So every breakpoint occurrence gets assigned a module-unique *info index* and +we store it alongside the occurrence module (*info module*) in the +'InternalBreakpointId' datatype. This is the index that we use at runtime to +identify a breakpoint. + +When the internal breakpoint has a matching tick-level breakpoint we can fetch +the related tick-level information by first looking up a mapping +@'InternalBreakpointId' -> 'BreakpointId'@ in @'CgBreakInfo'@. +-} + +-------------------------------------------------------------------------------- +-- * Internal breakpoint identifiers +-------------------------------------------------------------------------------- + +-- | Internal breakpoint info index +type BreakInfoIndex = Int + +-- | Internal breakpoint identifier +-- +-- Indexes into the structures in the @'InternalModBreaks'@ produced during ByteCode generation. +-- See Note [Breakpoint identifiers] +data InternalBreakpointId = InternalBreakpointId + { ibi_info_mod :: !Module -- ^ Breakpoint info module + , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint info index + } + deriving (Eq, Ord) + +-------------------------------------------------------------------------------- +-- * Internal Mod Breaks +-------------------------------------------------------------------------------- + +-- | Internal mod breaks store the runtime-relevant information of breakpoints. +-- +-- Importantly, it maps 'InternalBreakpointId's to 'CgBreakInfo'. +-- +-- 'InternalModBreaks' are constructed during bytecode generation and stored in +-- 'CompiledByteCode' afterwards. +data InternalModBreaks = InternalModBreaks + { imodBreaks_breakInfo :: !(IntMap CgBreakInfo) + -- ^ Access code-gen time information about a breakpoint, indexed by + -- 'InternalBreakpointId'. + + , imodBreaks_modBreaks :: !ModBreaks + -- ^ Store the ModBreaks for this module + -- + -- Recall Note [Breakpoint identifiers]: for some module A, an + -- *occurrence* of a breakpoint in A may have been inlined from some + -- breakpoint *defined* in module B. + -- + -- This 'ModBreaks' contains information regarding all the breakpoints + -- defined in the module this 'InternalModBreaks' corresponds to. It + -- /does not/ necessarily have information regarding all the breakpoint + -- occurrences registered in 'imodBreaks_breakInfo'. Some of those + -- occurrences may refer breakpoints inlined from other modules. + } + +-- | Construct an 'InternalModBreaks'. +-- +-- INVARIANT: The given 'ModBreaks' correspond to the same module as this +-- 'InternalModBreaks' module (the first argument) and its breakpoint infos +-- (the @IntMap CgBreakInfo@ argument) +mkInternalModBreaks :: Module -> IntMap CgBreakInfo -> ModBreaks -> InternalModBreaks +mkInternalModBreaks mod im mbs = + assertPpr (mod == modBreaks_module mbs) + (text "Constructing InternalModBreaks with the ModBreaks of a different module!") $ + InternalModBreaks im mbs + +-- | Get the module to which these 'InternalModBreaks' correspond +imodBreaks_module :: InternalModBreaks -> Module +imodBreaks_module = modBreaks_module . imodBreaks_modBreaks + +-- | Information about a breakpoint that we know at code-generation time +-- In order to be used, this needs to be hydrated relative to the current HscEnv by +-- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for +-- preventing space leaks (see #22530) +data CgBreakInfo + = CgBreakInfo + { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint + , cgb_vars :: ![Maybe (IfaceIdBndr, Word)] + , cgb_resty :: !IfaceType + , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId) + -- ^ This field records the original breakpoint tick identifier for this + -- internal breakpoint info. It is used to convert a breakpoint + -- *occurrence* index ('InternalBreakpointId') into a *definition* index + -- ('BreakpointId'). + -- + -- The modules of breakpoint occurrence and breakpoint definition are not + -- necessarily the same: See Note [Breakpoint identifiers]. + -- + -- If there is no original tick identifier (that is, the breakpoint was + -- created during code generation), we re-use the BreakpointId of something else. + -- It would also be reasonable to have an @Either something BreakpointId@ + -- for @cgb_tick_id@, but currently we can always re-use a source-level BreakpointId. + -- In the case of step-out, see Note [Debugger: Stepout internal break locs] + } +-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval + +-- | Breakpoints created during code generation don't have a source-level tick +-- location. Instead, we re-use an existing one. +newtype InternalBreakLoc = InternalBreakLoc { internalBreakLoc :: BreakpointId } + deriving newtype (Eq, NFData, Outputable) + +-- | Get an internal breakpoint info by 'InternalBreakpointId' +getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo +getInternalBreak (InternalBreakpointId mod ix) imbs = + assert_modules_match mod (imodBreaks_module imbs) $ + imodBreaks_breakInfo imbs IM.! ix + +-- | Assert that the module in the 'InternalBreakpointId' and in +-- 'InternalModBreaks' match. +assert_modules_match :: Module -> Module -> a -> a +assert_modules_match ibi_mod imbs_mod = + assertPpr (ibi_mod == imbs_mod) + (text "Tried to query the InternalModBreaks of module" <+> ppr imbs_mod + <+> text "with an InternalBreakpointId for module" <+> ppr ibi_mod) + +-------------------------------------------------------------------------------- +-- Tick-level Breakpoint information +-------------------------------------------------------------------------------- + +-- | Get the source module and tick index for this breakpoint +-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId') +getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId +getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs = + assert_modules_match ibi_mod (imodBreaks_module imbs) $ + let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix + in either internalBreakLoc id (cgb_tick_id cgb) + +-- | Get the source module for this breakpoint (where the breakpoint is defined) +getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module +getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs = + assert_modules_match ibi_mod (imodBreaks_module imbs) $ + let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix + in either (bi_tick_mod . internalBreakLoc) bi_tick_mod (cgb_tick_id cgb) + +-- | Get the source span for this breakpoint +getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan +getBreakLoc = getBreakXXX modBreaks_locs + +-- | Get the vars for this breakpoint +getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName] +getBreakVars = getBreakXXX modBreaks_vars + +-- | Get the decls for this breakpoint +getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String] +getBreakDecls = getBreakXXX modBreaks_decls + +-- | Get the decls for this breakpoint +getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String)) +getBreakCCS = getBreakXXX modBreaks_ccs + +-- | Internal utility to access a ModBreaks field at a particular breakpoint index +-- +-- Recall Note [Breakpoint identifiers]: the internal breakpoint module (the +-- *occurrence* module) doesn't necessarily match the module where the +-- tick breakpoint was defined with the relevant 'ModBreaks'. +-- +-- When the tick module is the same as the internal module, we use the stored +-- 'ModBreaks'. When the tick module is different, we need to look up the +-- 'ModBreaks' in the HUG for that other module. +-- +-- When there is no tick module (the breakpoint was generated at codegen), use +-- the function on internal mod breaks. +-- +-- To avoid cyclic dependencies, we instead receive a function that looks up +-- the 'ModBreaks' given a 'Module' +getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a +getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs = + assert_modules_match ibi_mod (imodBreaks_module imbs) $ do + let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix + case either internalBreakLoc id (cgb_tick_id cgb) of + BreakpointId{bi_tick_mod, bi_tick_index} + | bi_tick_mod == ibi_mod + -> do + let these_mbs = imodBreaks_modBreaks imbs + return $ view these_mbs ! bi_tick_index + | otherwise + -> do + other_mbs <- lookupModule bi_tick_mod + return $ view other_mbs ! bi_tick_index + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +-- | Fully force an 'InternalModBreaks' value +seqInternalModBreaks :: InternalModBreaks -> () +seqInternalModBreaks InternalModBreaks{..} = + rnf (fmap seqCgBreakInfo imodBreaks_breakInfo) + where + seqCgBreakInfo :: CgBreakInfo -> () + seqCgBreakInfo CgBreakInfo{..} = + rnf cgb_tyvars `seq` + rnf cgb_vars `seq` + rnf cgb_resty `seq` + rnf cgb_tick_id + +instance Outputable InternalBreakpointId where + ppr InternalBreakpointId{..} = + text "InternalBreakpointId" <+> ppr ibi_info_mod <+> ppr ibi_info_index + +instance NFData InternalBreakpointId where + rnf InternalBreakpointId{..} = + rnf ibi_info_mod `seq` rnf ibi_info_index + +instance Outputable CgBreakInfo where + ppr info = text "CgBreakInfo" <+> + parens (ppr (cgb_vars info) <+> + ppr (cgb_resty info) <+> + ppr (cgb_tick_id info)) diff --git a/GHC/ByteCode/InfoTable.hs b/GHC/ByteCode/InfoTable.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/InfoTable.hs @@ -0,0 +1,84 @@ + +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Generate infotables for interpreter-made bytecodes +module GHC.ByteCode.InfoTable ( mkITbls ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Profile + +import GHCi.Message + +import GHC.Types.Name ( Name, getName ) +import GHC.Types.RepType + +import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) +import GHC.Core.TyCon ( TyCon, tyConFamilySize, isBoxedDataTyCon, tyConDataCons ) +import GHC.Core.Multiplicity ( scaledThing ) + +import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) +import GHC.StgToCmm.Closure ( tagForCon ) + +import GHC.Utils.Misc +import GHC.Utils.Panic + +{- + Manufacturing of info tables for DataCons +-} + +-- Make info tables for the data decls in this module +mkITbls :: Profile -> [TyCon] -> [(Name, ConInfoTable)] +mkITbls profile tcs = concatMap mkITbl (filter isBoxedDataTyCon tcs) + where + mkITbl :: TyCon -> [(Name, ConInfoTable)] + mkITbl tc + | dcs `lengthIs` n -- paranoia; this is an assertion. + = make_constr_itbls profile dcs + where + dcs = tyConDataCons tc + n = tyConFamilySize tc + mkITbl _ = panic "mkITbl" + +-- Assumes constructors are numbered from zero, not one +make_constr_itbls :: Profile -> [DataCon] -> [(Name, ConInfoTable)] +make_constr_itbls profile cons = + -- TODO: the profile should be bundled with the interpreter: the rts ways are + -- fixed for an interpreter + map (uncurry mk_itbl) (zip cons [0..]) + where + mk_itbl :: DataCon -> Int -> (Name, ConInfoTable) + mk_itbl dcon conNo = + ( getName dcon, + ConInfoTable + tables_next_to_code + ptrs' + nptrs_really + conNo + (tagForCon platform dcon) + descr + ) + where + rep_args = [ prim_rep + | arg <- dataConRepArgTys dcon + , prim_rep <- typePrimRep (scaledThing arg) ] + + (tot_wds, ptr_wds) = + mkVirtConstrSizes profile rep_args + + ptrs' = ptr_wds + nptrs' = tot_wds - ptr_wds + nptrs_really + | ptrs' + nptrs' >= pc_MIN_PAYLOAD_SIZE constants = nptrs' + | otherwise = pc_MIN_PAYLOAD_SIZE constants - ptrs' + + descr = dataConIdentity dcon + + platform = profilePlatform profile + constants = platformConstants platform + tables_next_to_code = platformTablesNextToCode platform diff --git a/GHC/ByteCode/Instr.hs b/GHC/ByteCode/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/Instr.hs @@ -0,0 +1,591 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode instruction definitions +module GHC.ByteCode.Instr ( + BCInstr(..), ProtoBCO(..), bciStackUse, LocalLabel(..) + ) where + +import GHC.Prelude + +import GHC.ByteCode.Types +import GHC.Cmm.Type (Width) +import GHC.StgToCmm.Layout ( ArgRep(..) ) +import GHC.Utils.Outputable +import GHC.Types.Name +import GHC.Types.Literal +import GHC.Types.Unique +import GHC.Core.DataCon +import GHC.Builtin.PrimOps +import GHC.Runtime.Heap.Layout ( StgWord ) + +import Data.Int +import Data.Word + +#if MIN_VERSION_rts(1,0,3) +import Data.ByteString (ByteString) +#endif + + +import GHC.Stg.Syntax + +-- ---------------------------------------------------------------------------- +-- Bytecode instructions + +data ProtoBCO a + = ProtoBCO { + protoBCOName :: a, -- name, in some sense + protoBCOInstrs :: [BCInstr], -- instrs + -- arity and GC info + protoBCOBitmap :: [StgWord], + protoBCOBitmapSize :: Word, + protoBCOArity :: Int, + -- what the BCO came from, for debugging only + protoBCOExpr :: Either [CgStgAlt] CgStgRhs + } + +-- | A local block label (e.g. identifying a case alternative). +newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 } + deriving (Eq, Ord) + +-- Just so we can easily juse UniqFM. +instance Uniquable LocalLabel where + getUnique (LocalLabel w) = mkUniqueGrimily $ fromIntegral w + +instance Outputable LocalLabel where + ppr (LocalLabel lbl) = text "lbl:" <> ppr lbl + +data BCInstr + -- Messing with the stack + = STKCHECK !Word + + -- Push locals (existing bits of the stack) + | PUSH_L !WordOff{-offset-} + | PUSH_LL !WordOff !WordOff{-2 offsets-} + | PUSH_LLL !WordOff !WordOff !WordOff{-3 offsets-} + + -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e., + -- the stack will grow by 8, 16 or 32 bits) + | PUSH8 !ByteOff + | PUSH16 !ByteOff + | PUSH32 !ByteOff + + -- Push the specified local as a 8, 16, 32 bit value onto the stack, but the + -- value will take the whole word on the stack (i.e., the stack will grow by + -- a word) + -- This is useful when extracting a packed constructor field for further use. + -- Currently we expect all values on the stack to take full words, except for + -- the ones used for PACK (i.e., actually constructing new data types, in + -- which case we use PUSH{8,16,32}) + | PUSH8_W !ByteOff + | PUSH16_W !ByteOff + | PUSH32_W !ByteOff + + -- Push a (heap) ptr (these all map to PUSH_G really) + | PUSH_G Name + | PUSH_PRIMOP PrimOp + | PUSH_BCO (ProtoBCO Name) + + -- Push an alt continuation + | PUSH_ALTS (ProtoBCO Name) ArgRep + | PUSH_ALTS_TUPLE (ProtoBCO Name) -- continuation + !NativeCallInfo + (ProtoBCO Name) -- tuple return BCO + + -- Pushing 8, 16 and 32 bits of padding (for constructors). + | PUSH_PAD8 + | PUSH_PAD16 + | PUSH_PAD32 + + -- Pushing literals + | PUSH_UBX8 Literal + | PUSH_UBX16 Literal + | PUSH_UBX32 Literal + | PUSH_UBX Literal !WordOff + -- push this int/float/double/addr, on the stack. Word + -- is # of words to copy from literal pool. Eitherness reflects + -- the difficulty of dealing with MachAddr here, mostly due to + -- the excessive (and unnecessary) restrictions imposed by the + -- designers of the new Foreign library. In particular it is + -- quite impossible to convert an Addr to any other integral + -- type, and it appears impossible to get hold of the bits of + -- an addr, even though we need to assemble BCOs. + + -- Push a top-level Addr#. This is a pseudo-instruction assembled to PUSH_UBX, + -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode. + | PUSH_ADDR Name + + -- various kinds of application + | PUSH_APPLY_N + | PUSH_APPLY_V + | PUSH_APPLY_F + | PUSH_APPLY_D + | PUSH_APPLY_L + | PUSH_APPLY_P + | PUSH_APPLY_PP + | PUSH_APPLY_PPP + | PUSH_APPLY_PPPP + | PUSH_APPLY_PPPPP + | PUSH_APPLY_PPPPPP + + -- | Drop entries @(n, n+by]@ entries from the stack. Graphically: + -- @ + -- a_1 ← top + -- ... + -- a_n + -- b_1 => a_1 ← top + -- ... ... + -- b_by a_n + -- k k + -- @ + | SLIDE !WordOff -- ^ n = this many + !WordOff -- ^ by = down by this much + + -- To do with the heap + | ALLOC_AP !HalfWord {- make an AP with this many payload words. + HalfWord matches the size of the n_args field in StgAP, + make sure that we handle truncation when generating + bytecode using this HalfWord type here -} + | ALLOC_AP_NOUPD !HalfWord -- make an AP_NOUPD with this many payload words + | ALLOC_PAP !HalfWord !HalfWord -- make a PAP with this arity / payload words + | MKAP !WordOff{-ptr to AP is this far down stack-} !HalfWord{-number of words-} + | MKPAP !WordOff{-ptr to PAP is this far down stack-} !HalfWord{-number of words-} + | UNPACK !WordOff -- unpack N words from t.o.s Constr + | PACK DataCon !WordOff + -- after assembly, the DataCon is an index into the + -- itbl array + -- For doing case trees + | LABEL LocalLabel + | TESTLT_I !Int LocalLabel + | TESTEQ_I !Int LocalLabel + | TESTLT_W !Word LocalLabel + | TESTEQ_W !Word LocalLabel + | TESTLT_I64 !Int64 LocalLabel + | TESTEQ_I64 !Int64 LocalLabel + | TESTLT_I32 !Int32 LocalLabel + | TESTEQ_I32 !Int32 LocalLabel + | TESTLT_I16 !Int16 LocalLabel + | TESTEQ_I16 !Int16 LocalLabel + | TESTLT_I8 !Int8 LocalLabel + | TESTEQ_I8 !Int16 LocalLabel + | TESTLT_W64 !Word64 LocalLabel + | TESTEQ_W64 !Word64 LocalLabel + | TESTLT_W32 !Word32 LocalLabel + | TESTEQ_W32 !Word32 LocalLabel + | TESTLT_W16 !Word16 LocalLabel + | TESTEQ_W16 !Word16 LocalLabel + | TESTLT_W8 !Word8 LocalLabel + | TESTEQ_W8 !Word8 LocalLabel + | TESTLT_F !Float LocalLabel + | TESTEQ_F !Float LocalLabel + | TESTLT_D !Double LocalLabel + | TESTEQ_D !Double LocalLabel + + -- The Word16 value is a constructor number and therefore + -- stored in the insn stream rather than as an offset into + -- the literal pool. + + -- | Test whether the tag of a closure pointer is less than the given value. + -- If not, jump to the given label. + | TESTLT_P !Word16 LocalLabel + -- | Test whether the tag of a closure pointer is equal to the given value. + -- If not, jump to the given label. + | TESTEQ_P !Word16 LocalLabel + + | CASEFAIL + | JMP LocalLabel + + -- For doing calls to C (via glue code generated by libffi) + | CCALL !WordOff -- stack frame size + !FFIInfo -- libffi ffi_cif function prototype + !Word16 -- flags. + -- + -- 0x1: call is interruptible + -- 0x2: call is unsafe + -- + -- (XXX: inefficient, but I don't know + -- what the alignment constraints are.) + + | PRIMCALL + + -- Primops - The actual interpreter instructions are flattened into 64/32/16/8 wide + -- instructions. But for generating code it's handy to have the width as argument + -- to avoid duplication. + | OP_ADD !Width + | OP_SUB !Width + | OP_AND !Width + | OP_XOR !Width + | OP_MUL !Width + | OP_SHL !Width + | OP_ASR !Width + | OP_LSR !Width + | OP_OR !Width + + | OP_NOT !Width + | OP_NEG !Width + + | OP_NEQ !Width + | OP_EQ !Width + + | OP_U_LT !Width + | OP_U_GE !Width + | OP_U_GT !Width + | OP_U_LE !Width + + | OP_S_LT !Width + | OP_S_GE !Width + | OP_S_GT !Width + | OP_S_LE !Width + + -- Always puts at least a machine word on the stack. + -- We zero extend the result we put on the stack according to host byte order. + | OP_INDEX_ADDR !Width + + -- For doing magic ByteArray passing to foreign calls + | SWIZZLE !WordOff -- to the ptr N words down the stack, + !Int -- add M + + -- To Infinity And Beyond + | ENTER + | RETURN ArgRep -- return a non-tuple value, here's its rep; see + -- Note [Return convention for non-tuple values] in GHC.StgToByteCode + | RETURN_TUPLE -- return an unboxed tuple (info already on stack); see + -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode + + -- Breakpoints + | BRK_FUN !InternalBreakpointId + +#if MIN_VERSION_rts(1,0,3) + -- | A "meta"-instruction for recording the name of a BCO for debugging purposes. + -- These are ignored by the interpreter but helpfully printed by the disassmbler. + | BCO_NAME !ByteString +#endif + + +{- Note [BCO_NAME] + ~~~~~~~~~~~~~~~ + The BCO_NAME instruction is a debugging-aid enabled with the -fadd-bco-name flag. + When enabled the bytecode assembler will prepend a BCO_NAME instruction to every + generated bytecode object capturing the STG name of the binding the BCO implements. + This is then printed by the bytecode disassembler, allowing bytecode objects to be + readily correlated with their STG and Core source. + -} + +-- ----------------------------------------------------------------------------- +-- Printing bytecode instructions + +instance Outputable a => Outputable (ProtoBCO a) where + ppr (ProtoBCO { protoBCOName = name + , protoBCOInstrs = instrs + , protoBCOBitmap = bitmap + , protoBCOBitmapSize = bsize + , protoBCOArity = arity + , protoBCOExpr = origin }) + = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity + <> colon) + $$ nest 3 (case origin of + Left alts -> + vcat (zipWith (<+>) (char '{' : repeat (char ';')) + (map (pprStgAltShort shortStgPprOpts) alts)) + Right rhs -> + pprStgRhsShort shortStgPprOpts rhs + ) + $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap) + $$ nest 3 (vcat (map ppr instrs)) + +-- Print enough of the STG expression to enable the reader to find +-- the expression in the -ddump-stg output. That is, we need to +-- include at least a binder. + +pprStgExprShort :: OutputablePass pass => StgPprOpts -> GenStgExpr pass -> SDoc +pprStgExprShort _ (StgCase _expr var _ty _alts) = + text "case of" <+> ppr var +pprStgExprShort _ (StgLet _ bnd _) = + text "let" <+> pprStgBindShort bnd <+> text "in ..." +pprStgExprShort _ (StgLetNoEscape _ bnd _) = + text "let-no-escape" <+> pprStgBindShort bnd <+> text "in ..." +pprStgExprShort opts (StgTick t e) = ppr t <+> pprStgExprShort opts e +pprStgExprShort opts e = pprStgExpr opts e + +pprStgBindShort :: OutputablePass pass => GenStgBinding pass -> SDoc +pprStgBindShort (StgNonRec x _) = + ppr x <+> text "= ..." +pprStgBindShort (StgRec bs) = + char '{' <+> ppr (fst (head bs)) <+> text "= ...; ... }" + +pprStgAltShort :: OutputablePass pass => StgPprOpts -> GenStgAlt pass -> SDoc +pprStgAltShort opts GenStgAlt{alt_con=con, alt_bndrs=args, alt_rhs=expr} = + ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort opts expr + +pprStgRhsShort :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc +pprStgRhsShort opts (StgRhsClosure _ext _cc upd_flag args body _typ) = + hang (hsep [ char '\\' <> ppr upd_flag, brackets (interppSP args) ]) + 4 (pprStgExprShort opts body) +pprStgRhsShort opts rhs = pprStgRhs opts rhs + + +instance Outputable BCInstr where + ppr (STKCHECK n) = text "STKCHECK" <+> ppr n + ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset + ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2 + ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3 + ppr (PUSH8 offset) = text "PUSH8 " <+> ppr offset + ppr (PUSH16 offset) = text "PUSH16 " <+> ppr offset + ppr (PUSH32 offset) = text "PUSH32 " <+> ppr offset + ppr (PUSH8_W offset) = text "PUSH8_W " <+> ppr offset + ppr (PUSH16_W offset) = text "PUSH16_W " <+> ppr offset + ppr (PUSH32_W offset) = text "PUSH32_W " <+> ppr offset + ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm + ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." + <> ppr op + ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) + + ppr (PUSH_ALTS bco pk) = hang (text "PUSH_ALTS" <+> ppr pk) 2 (ppr bco) + ppr (PUSH_ALTS_TUPLE bco call_info tuple_bco) = + hang (text "PUSH_ALTS_TUPLE" <+> ppr call_info) + 2 + (ppr tuple_bco $+$ ppr bco) + + ppr PUSH_PAD8 = text "PUSH_PAD8" + ppr PUSH_PAD16 = text "PUSH_PAD16" + ppr PUSH_PAD32 = text "PUSH_PAD32" + + ppr (PUSH_UBX8 lit) = text "PUSH_UBX8" <+> ppr lit + ppr (PUSH_UBX16 lit) = text "PUSH_UBX16" <+> ppr lit + ppr (PUSH_UBX32 lit) = text "PUSH_UBX32" <+> ppr lit + ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit + ppr (PUSH_ADDR nm) = text "PUSH_ADDR" <+> ppr nm + ppr PUSH_APPLY_N = text "PUSH_APPLY_N" + ppr PUSH_APPLY_V = text "PUSH_APPLY_V" + ppr PUSH_APPLY_F = text "PUSH_APPLY_F" + ppr PUSH_APPLY_D = text "PUSH_APPLY_D" + ppr PUSH_APPLY_L = text "PUSH_APPLY_L" + ppr PUSH_APPLY_P = text "PUSH_APPLY_P" + ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" + ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" + ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" + ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" + ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" + + ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d + ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz + ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz + ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz + ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words," + <+> ppr offset <+> text "stkoff" + ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words," + <+> ppr offset <+> text "stkoff" + ppr (UNPACK sz) = text "UNPACK " <+> ppr sz + ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz + ppr (LABEL lab) = text "__" <> ppr lab <> colon + ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab + ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab + ppr (TESTLT_W i lab) = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab + ppr (TESTEQ_W i lab) = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab + ppr (TESTLT_I64 i lab) = text "TESTLT_I64" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_I64 i lab) = text "TESTEQ_I64" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_I32 i lab) = text "TESTLT_I32" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_I32 i lab) = text "TESTEQ_I32" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_I16 i lab) = text "TESTLT_I16" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_I16 i lab) = text "TESTEQ_I16" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_I8 i lab) = text "TESTLT_I8" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_I8 i lab) = text "TESTEQ_I8" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_W64 i lab) = text "TESTLT_W64" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_W64 i lab) = text "TESTEQ_W64" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_W32 i lab) = text "TESTLT_W32" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_W32 i lab) = text "TESTEQ_W32" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_W16 i lab) = text "TESTLT_W16" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_W16 i lab) = text "TESTEQ_W16" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_W8 i lab) = text "TESTLT_W8" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_W8 i lab) = text "TESTEQ_W8" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab + ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab + ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab + ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab + ppr (TESTLT_P i lab) = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab + ppr CASEFAIL = text "CASEFAIL" + ppr (JMP lab) = text "JMP" <+> ppr lab + ppr (CCALL off ffi flags) = text "CCALL " <+> ppr off + <+> text "marshal code at" + <+> text (show ffi) + <+> (case flags of + 0x1 -> text "(interruptible)" + 0x2 -> text "(unsafe)" + _ -> empty) + ppr PRIMCALL = text "PRIMCALL" + + ppr (OP_ADD w) = text "OP_ADD_" <> ppr w + ppr (OP_SUB w) = text "OP_SUB_" <> ppr w + ppr (OP_AND w) = text "OP_AND_" <> ppr w + ppr (OP_XOR w) = text "OP_XOR_" <> ppr w + ppr (OP_OR w) = text "OP_OR_" <> ppr w + ppr (OP_NOT w) = text "OP_NOT_" <> ppr w + ppr (OP_NEG w) = text "OP_NEG_" <> ppr w + ppr (OP_MUL w) = text "OP_MUL_" <> ppr w + ppr (OP_SHL w) = text "OP_SHL_" <> ppr w + ppr (OP_ASR w) = text "OP_ASR_" <> ppr w + ppr (OP_LSR w) = text "OP_LSR_" <> ppr w + + ppr (OP_EQ w) = text "OP_EQ_" <> ppr w + ppr (OP_NEQ w) = text "OP_NEQ_" <> ppr w + ppr (OP_S_LT w) = text "OP_S_LT_" <> ppr w + ppr (OP_S_GE w) = text "OP_S_GE_" <> ppr w + ppr (OP_S_GT w) = text "OP_S_GT_" <> ppr w + ppr (OP_S_LE w) = text "OP_S_LE_" <> ppr w + ppr (OP_U_LT w) = text "OP_U_LT_" <> ppr w + ppr (OP_U_GE w) = text "OP_U_GE_" <> ppr w + ppr (OP_U_GT w) = text "OP_U_GT_" <> ppr w + ppr (OP_U_LE w) = text "OP_U_LE_" <> ppr w + + ppr (OP_INDEX_ADDR w) = text "OP_INDEX_ADDR_" <> ppr w + + ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff + <+> text "by" <+> ppr n + ppr ENTER = text "ENTER" + ppr (RETURN pk) = text "RETURN " <+> ppr pk + ppr (RETURN_TUPLE) = text "RETURN_TUPLE" + ppr (BRK_FUN (InternalBreakpointId info_mod infox)) + = text "BRK_FUN" <+> text "" + <+> ppr info_mod <+> ppr infox + <+> text "" +#if MIN_VERSION_rts(1,0,3) + ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm) +#endif + + + +-- ----------------------------------------------------------------------------- +-- The stack use, in words, of each bytecode insn. These _must_ be +-- correct, or overestimates of reality, to be safe. + +-- NOTE: we aggregate the stack use from case alternatives too, so that +-- we can do a single stack check at the beginning of a function only. + +-- This could all be made more accurate by keeping track of a proper +-- stack high water mark, but it doesn't seem worth the hassle. + +protoBCOStackUse :: ProtoBCO a -> Word +protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco)) + +bciStackUse :: BCInstr -> Word +bciStackUse STKCHECK{} = 0 +bciStackUse PUSH_L{} = 1 +bciStackUse PUSH_LL{} = 2 +bciStackUse PUSH_LLL{} = 3 +bciStackUse PUSH8{} = 1 -- overapproximation +bciStackUse PUSH16{} = 1 -- overapproximation +bciStackUse PUSH32{} = 1 -- overapproximation on 64bit arch +bciStackUse PUSH8_W{} = 1 -- takes exactly 1 word +bciStackUse PUSH16_W{} = 1 -- takes exactly 1 word +bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word +bciStackUse PUSH_G{} = 1 +bciStackUse PUSH_PRIMOP{} = 1 +bciStackUse PUSH_BCO{} = 1 +bciStackUse (PUSH_ALTS bco _) = 2 {- profiling only, restore CCCS -} + + 3 + protoBCOStackUse bco +bciStackUse (PUSH_ALTS_TUPLE bco info _) = + -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t) + -- tuple + -- (call_info, tuple_bco, stg_ret_t) + 1 {- profiling only -} + + 7 + fromIntegral (nativeCallSize info) + protoBCOStackUse bco +bciStackUse (PUSH_PAD8) = 1 -- overapproximation +bciStackUse (PUSH_PAD16) = 1 -- overapproximation +bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch +bciStackUse (PUSH_UBX8 _) = 1 -- overapproximation +bciStackUse (PUSH_UBX16 _) = 1 -- overapproximation +bciStackUse (PUSH_UBX32 _) = 1 -- overapproximation on 64bit arch +bciStackUse (PUSH_UBX _ nw) = fromIntegral nw +bciStackUse PUSH_ADDR{} = 1 +bciStackUse PUSH_APPLY_N{} = 1 +bciStackUse PUSH_APPLY_V{} = 1 +bciStackUse PUSH_APPLY_F{} = 1 +bciStackUse PUSH_APPLY_D{} = 1 +bciStackUse PUSH_APPLY_L{} = 1 +bciStackUse PUSH_APPLY_P{} = 1 +bciStackUse PUSH_APPLY_PP{} = 1 +bciStackUse PUSH_APPLY_PPP{} = 1 +bciStackUse PUSH_APPLY_PPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPPP{} = 1 +bciStackUse ALLOC_AP{} = 1 +bciStackUse ALLOC_AP_NOUPD{} = 1 +bciStackUse ALLOC_PAP{} = 1 +bciStackUse (UNPACK sz) = fromIntegral sz +bciStackUse LABEL{} = 0 +bciStackUse TESTLT_I{} = 0 +bciStackUse TESTEQ_I{} = 0 +bciStackUse TESTLT_W{} = 0 +bciStackUse TESTEQ_W{} = 0 +bciStackUse TESTLT_I64{} = 0 +bciStackUse TESTEQ_I64{} = 0 +bciStackUse TESTLT_I32{} = 0 +bciStackUse TESTEQ_I32{} = 0 +bciStackUse TESTLT_I16{} = 0 +bciStackUse TESTEQ_I16{} = 0 +bciStackUse TESTLT_I8{} = 0 +bciStackUse TESTEQ_I8{} = 0 +bciStackUse TESTLT_W64{} = 0 +bciStackUse TESTEQ_W64{} = 0 +bciStackUse TESTLT_W32{} = 0 +bciStackUse TESTEQ_W32{} = 0 +bciStackUse TESTLT_W16{} = 0 +bciStackUse TESTEQ_W16{} = 0 +bciStackUse TESTLT_W8{} = 0 +bciStackUse TESTEQ_W8{} = 0 +bciStackUse TESTLT_F{} = 0 +bciStackUse TESTEQ_F{} = 0 +bciStackUse TESTLT_D{} = 0 +bciStackUse TESTEQ_D{} = 0 +bciStackUse TESTLT_P{} = 0 +bciStackUse TESTEQ_P{} = 0 +bciStackUse CASEFAIL{} = 0 +bciStackUse JMP{} = 0 +bciStackUse ENTER{} = 0 +bciStackUse RETURN{} = 1 -- pushes stg_ret_X for some X +bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header +bciStackUse CCALL{} = 0 +bciStackUse PRIMCALL{} = 1 -- pushes stg_primcall +bciStackUse OP_ADD{} = 0 -- We overestimate, it's -1 actually ... +bciStackUse OP_SUB{} = 0 +bciStackUse OP_AND{} = 0 +bciStackUse OP_XOR{} = 0 +bciStackUse OP_OR{} = 0 +bciStackUse OP_NOT{} = 0 +bciStackUse OP_NEG{} = 0 +bciStackUse OP_MUL{} = 0 +bciStackUse OP_SHL{} = 0 +bciStackUse OP_ASR{} = 0 +bciStackUse OP_LSR{} = 0 + +bciStackUse OP_NEQ{} = 0 +bciStackUse OP_EQ{} = 0 +bciStackUse OP_S_LT{} = 0 +bciStackUse OP_S_GT{} = 0 +bciStackUse OP_S_LE{} = 0 +bciStackUse OP_S_GE{} = 0 +bciStackUse OP_U_LT{} = 0 +bciStackUse OP_U_GT{} = 0 +bciStackUse OP_U_LE{} = 0 +bciStackUse OP_U_GE{} = 0 + +bciStackUse OP_INDEX_ADDR{} = 0 + +bciStackUse SWIZZLE{} = 0 +bciStackUse BRK_FUN{} = 0 + +-- These insns actually reduce stack use, but we need the high-tide level, +-- so can't use this info. Not that it matters much. +bciStackUse SLIDE{} = 0 +bciStackUse MKAP{} = 0 +bciStackUse MKPAP{} = 0 +bciStackUse PACK{} = 1 -- worst case is PACK 0 words +#if MIN_VERSION_rts(1,0,3) +bciStackUse BCO_NAME{} = 0 +#endif diff --git a/GHC/ByteCode/Linker.hs b/GHC/ByteCode/Linker.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/Linker.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler and linker +module GHC.ByteCode.Linker + ( linkBCO + , lookupStaticPtr + , lookupIE + , linkFail + ) +where + +import GHC.Prelude + +import GHC.Runtime.Interpreter +import GHC.ByteCode.Types +import GHCi.RemoteTypes +import GHCi.ResolvedBCO + +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids + +import GHC.Unit.Module.Env +import GHC.Unit.Types + +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.SizedSeq + +import GHC.Linker.Types + +import GHC.Utils.Panic +import GHC.Utils.Outputable + +import GHC.Types.Name +import GHC.Types.Name.Env +import qualified GHC.Types.Id as Id +import GHC.Types.Unique.DFM + +-- Standard libraries +import Data.Array.Unboxed +import Foreign.Ptr +import GHC.Exts + +{- + Linking interpretables into something we can run +-} + +linkBCO + :: Interp + -> PkgsLoaded + -> LinkerEnv + -> LinkedBreaks + -> NameEnv Int + -> UnlinkedBCO + -> IO ResolvedBCO +linkBCO interp pkgs_loaded le lb bco_ix + (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do + -- fromIntegral Word -> Word64 should be a no op if Word is Word64 + -- otherwise it will result in a cast to longlong on 32bit systems. + (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le lb) (elemsFlatBag lits0) + ptrs <- mapM (resolvePtr interp pkgs_loaded le lb bco_ix) (elemsFlatBag ptrs0) + let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits + return $ ResolvedBCO { resolvedBCOIsLE = isLittleEndian + , resolvedBCOArity = arity + , resolvedBCOInstrs = insns + , resolvedBCOBitmap = bitmap + , resolvedBCOLits = mkBCOByteArray lits' + , resolvedBCOPtrs = addListToSS emptySS ptrs + } + +lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> LinkedBreaks -> BCONPtr -> IO Word +lookupLiteral interp pkgs_loaded le lb ptr = case ptr of + BCONPtrWord lit -> return lit + BCONPtrLbl sym -> do + Ptr a# <- lookupStaticPtr interp sym + return (W# (int2Word# (addr2Int# a#))) + BCONPtrItbl nm -> do + Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm + return (W# (int2Word# (addr2Int# a#))) + BCONPtrAddr nm -> do + Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm + return (W# (int2Word# (addr2Int# a#))) + BCONPtrStr bs -> do + RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bs] + pure $ fromIntegral p + BCONPtrFS fs -> do + RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bytesFS fs] + pure $ fromIntegral p + BCONPtrFFIInfo (FFIInfo {..}) -> do + RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet + pure $ fromIntegral p + BCONPtrCostCentre InternalBreakpointId{..} + | interpreterProfiled interp -> do + case expectJust (lookupModuleEnv (ccs_env lb) ibi_info_mod) ! ibi_info_index of + RemotePtr p -> pure $ fromIntegral p + | otherwise -> + case toRemotePtr nullPtr of + RemotePtr p -> pure $ fromIntegral p + +lookupStaticPtr :: Interp -> FastString -> IO (Ptr ()) +lookupStaticPtr interp addr_of_label_string = do + m <- lookupSymbol interp (IFaststringSymbol addr_of_label_string) + case m of + Just ptr -> return ptr + Nothing -> linkFail "GHC.ByteCode.Linker: can't find label" + (ppr addr_of_label_string) + +lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ()) +lookupIE interp pkgs_loaded ie con_nm = + case lookupNameEnv ie con_nm of + Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) + Nothing -> do -- try looking up in the object files. + let sym_to_find1 = IConInfoSymbol con_nm + m <- lookupHsSymbol interp pkgs_loaded sym_to_find1 + case m of + Just addr -> return addr + Nothing + -> do -- perhaps a nullary constructor? + let sym_to_find2 = IStaticInfoSymbol con_nm + n <- lookupHsSymbol interp pkgs_loaded sym_to_find2 + case n of + Just addr -> return addr + Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE" + (ppr sym_to_find1 <> " or " <> + ppr sym_to_find2) + +-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode +lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ()) +lookupAddr interp pkgs_loaded ae addr_nm = do + case lookupNameEnv ae addr_nm of + Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr) + Nothing -> do -- try looking up in the object files. + let sym_to_find = IBytesSymbol addr_nm + -- see Note [Bytes label] in GHC.Cmm.CLabel + m <- lookupHsSymbol interp pkgs_loaded sym_to_find + case m of + Just ptr -> return ptr + Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr" + (ppr sym_to_find) + +lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ()) +lookupPrimOp interp pkgs_loaded primop = do + let sym_to_find = primopToCLabel primop "closure" + m <- lookupHsSymbol interp pkgs_loaded (IClosureSymbol (Id.idName $ primOpId primop)) + case m of + Just p -> return (toRemotePtr p) + Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" (text sym_to_find) + +resolvePtr + :: Interp + -> PkgsLoaded + -> LinkerEnv + -> LinkedBreaks + -> NameEnv Int + -> BCOPtr + -> IO ResolvedBCOPtr +resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of + BCOPtrName nm + | Just ix <- lookupNameEnv bco_ix nm + -> return (ResolvedBCORef ix) -- ref to another BCO in this group + + | Just (_, rhv) <- lookupNameEnv (closure_env le) nm + -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) + + | otherwise + -> assertPpr (isExternalName nm) (ppr nm) $ + do + let sym_to_find = IClosureSymbol nm + m <- lookupHsSymbol interp pkgs_loaded sym_to_find + case m of + Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) + Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (ppr sym_to_find) + + BCOPtrPrimOp op + -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op + + BCOPtrBCO bco + -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le lb bco_ix bco + + BCOPtrBreakArray tick_mod -> + withForeignRef (expectJust (lookupModuleEnv (breakarray_env lb) tick_mod)) $ + \ba -> pure $ ResolvedBCOPtrBreakArray ba + +-- | Look up the address of a Haskell symbol in the currently +-- loaded units. +-- +-- See Note [Looking up symbols in the relevant objects]. +lookupHsSymbol :: Interp -> PkgsLoaded -> InterpSymbol (Suffix s) -> IO (Maybe (Ptr ())) +lookupHsSymbol interp pkgs_loaded sym_to_find = do + massertPpr (isExternalName (interpSymbolName sym_to_find)) (ppr sym_to_find) + let pkg_id = moduleUnitId $ nameModule (interpSymbolName sym_to_find) + loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id + + go (dll:dlls) = do + mb_ptr <- lookupSymbolInDLL interp dll sym_to_find + case mb_ptr of + Just ptr -> pure (Just ptr) + Nothing -> go dlls + go [] = + -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types + lookupSymbol interp sym_to_find + + go loaded_dlls + +linkFail :: String -> SDoc -> IO a +linkFail who what + = throwGhcExceptionIO (ProgramError $ + unlines [ "",who + , "During interactive linking, GHCi couldn't find the following symbol:" + , ' ' : ' ' : showSDocUnsafe what + , "This may be due to you not asking GHCi to load extra object files," + , "archives or DLLs needed by your current session. Restart GHCi, specifying" + , "the missing library using the -L/path/to/object/dir and -lmissinglibname" + , "flags, or simply by naming the relevant files on the GHCi command line." + , "Alternatively, this link failure might indicate a bug in GHCi." + , "If you suspect the latter, please report this as a GHC bug:" + , " https://www.haskell.org/ghc/reportabug" + ]) + + + + + + +-- See Note [Primop wrappers] in GHC.Builtin.PrimOps +primopToCLabel :: PrimOp -> String -> String +primopToCLabel primop suffix = concat + [ "ghczminternal_GHCziInternalziPrimopWrappers_" + , zString (zEncodeFS (occNameFS (primOpOcc primop))) + , '_':suffix + ] diff --git a/GHC/ByteCode/Types.hs b/GHC/ByteCode/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/Types.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedNewtypes #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler types +module GHC.ByteCode.Types + ( CompiledByteCode(..), seqCompiledByteCode + , BCOByteArray(..), mkBCOByteArray + , FFIInfo(..) + , RegBitmap(..) + , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo + , ByteOff(..), WordOff(..), HalfWord(..) + , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) + , ItblEnv, ItblPtr(..) + , AddrEnv, AddrPtr(..) + , FlatBag, sizeFlatBag, fromSmallArray, elemsFlatBag + + -- * Mod Breaks + , ModBreaks (..), BreakpointId(..), BreakTickIndex + + -- * Internal Mod Breaks + , InternalModBreaks(..), CgBreakInfo(..), seqInternalModBreaks + -- ** Internal breakpoint identifier + , InternalBreakpointId(..), BreakInfoIndex + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Data.FlatBag +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Utils.Outputable +import GHC.Builtin.PrimOps +import GHC.Types.SptEntry +import GHC.HsToCore.Breakpoints +import GHC.ByteCode.Breakpoints +import GHCi.Message +import GHCi.RemoteTypes +import GHCi.FFI +import Control.DeepSeq +import GHCi.ResolvedBCO ( BCOByteArray(..), mkBCOByteArray ) + +import Foreign +import Data.ByteString (ByteString) +import qualified GHC.Exts.Heap as Heap +import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList ) +import GHC.Unit.Module + +-- ----------------------------------------------------------------------------- +-- Compiled Byte Code + +data CompiledByteCode = CompiledByteCode + { bc_bcos :: FlatBag UnlinkedBCO + -- ^ Bunch of interpretable bindings + + , bc_itbls :: [(Name, ConInfoTable)] + -- ^ Mapping from DataCons to their info tables + + , bc_strs :: [(Name, ByteString)] + -- ^ top-level strings (heap allocated) + + , bc_breaks :: Maybe InternalModBreaks + -- ^ All breakpoint information (no information if breakpoints are disabled). + -- + -- This information is used when loading a bytecode object: we will + -- construct the arrays to be used at runtime to trigger breakpoints at load time + -- from it (in 'allocateBreakArrays' and 'allocateCCS' in 'GHC.ByteCode.Loader'). + + , bc_spt_entries :: ![SptEntry] + -- ^ Static pointer table entries which should be loaded along with the + -- BCOs. See Note [Grand plan for static forms] in + -- "GHC.Iface.Tidy.StaticPtrTable". + } + +-- | A libffi ffi_cif function prototype. +data FFIInfo = FFIInfo { ffiInfoArgs :: ![FFIType], ffiInfoRet :: !FFIType } + deriving (Show) + +instance Outputable CompiledByteCode where + ppr CompiledByteCode{..} = ppr $ elemsFlatBag bc_bcos + +-- Not a real NFData instance, because ModBreaks contains some things +-- we can't rnf +seqCompiledByteCode :: CompiledByteCode -> () +seqCompiledByteCode CompiledByteCode{..} = + rnf bc_bcos `seq` + rnf bc_itbls `seq` + rnf bc_strs `seq` + case bc_breaks of + Nothing -> () + Just ibks -> seqInternalModBreaks ibks + +newtype ByteOff = ByteOff Int + deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable) + +newtype WordOff = WordOff Int + deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable) + +-- A type for values that are half the size of a word on the target +-- platform where the interpreter runs (which may be a different +-- wordsize than the compiler). +newtype HalfWord = HalfWord Word + deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable) + +newtype RegBitmap = RegBitmap { unRegBitmap :: Word32 } + deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Bits, FiniteBits, Outputable) + +{- Note [GHCi TupleInfo] +~~~~~~~~~~~~~~~~~~~~~~~~ + This contains the data we need for passing unboxed tuples between + bytecode and native code + + In general we closely follow the native calling convention that + GHC uses for unboxed tuples, but we don't use any registers in + bytecode. All tuple elements are expanded to use a full register + or a full word on the stack. + + The position of tuple elements that are returned on the stack in + the native calling convention is unchanged when returning the same + tuple in bytecode. + + The order of the remaining elements is determined by the register in + which they would have been returned, rather than by their position in + the tuple in the Haskell source code. This makes jumping between bytecode + and native code easier: A map of live registers is enough to convert the + tuple. + + See GHC.StgToByteCode.layoutTuple for more details. +-} + +data NativeCallType = NativePrimCall + | NativeTupleReturn + deriving (Eq) + +data NativeCallInfo = NativeCallInfo + { nativeCallType :: !NativeCallType + , nativeCallSize :: !WordOff -- total size of arguments in words + , nativeCallRegs :: !GlobalRegSet + , nativeCallStackSpillSize :: !WordOff {- words spilled on the stack by + GHCs native calling convention -} + } + +instance Outputable NativeCallInfo where + ppr NativeCallInfo{..} = text " ppr nativeCallSize <+> + text "stack" <+> ppr nativeCallStackSpillSize <+> + text "regs" <+> + ppr (map (text @SDoc . show) $ regSetToList nativeCallRegs) <> + char '>' + + +voidTupleReturnInfo :: NativeCallInfo +voidTupleReturnInfo = NativeCallInfo NativeTupleReturn 0 emptyRegSet 0 + +voidPrimCallInfo :: NativeCallInfo +voidPrimCallInfo = NativeCallInfo NativePrimCall 0 emptyRegSet 0 + +type ItblEnv = NameEnv (Name, ItblPtr) +type AddrEnv = NameEnv (Name, AddrPtr) + -- We need the Name in the range so we know which + -- elements to filter out when unloading a module + +newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable) + deriving (Show, NFData) +newtype AddrPtr = AddrPtr (RemotePtr ()) + deriving (NFData) + +{- +-------------------------------------------------------------------------------- +-- * Byte Code Objects (BCOs) +-------------------------------------------------------------------------------- + +Note [Case continuation BCOs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A stack with a BCO stack frame at the top looks like: + + (an StgBCO) + | ... | +---> +---------[1]--+ + +------------------+ | | info_tbl_ptr | ------+ + | OTHER FRAME | | +--------------+ | + +------------------+ | | StgArrBytes* | <--- the byte code + | ... | | +--------------+ | + +------------------+ | | ... | | + | fvs1 | | | + +------------------+ | | + | ... | | (StgInfoTable) | + +------------------+ | +----------+ <---+ + | args1 | | | ... | + +------------------+ | +----------+ + | some StgBCO* | -----+ | type=BCO | + +------------------+ +----------+ + Sp | stg_apply_interp | -----+ | ... | + +------------------+ | + | + | (StgInfoTable) + +----> +--------------+ + | ... | + +--------------+ + | type=RET_BCO | + +--------------+ + | ... | + + +In the case of bytecode objects found on the heap (e.g. thunks and functions), +the bytecode may refer to free variables recorded in the BCO closure itself. +By contrast, in /case continuation/ BCOs the code may additionally refer to free +variables in their stack frame. These are references by way of statically known +stack offsets (tracked using `BCEnv` in `StgToByteCode`). + +For instance, consider the function: + + f x y = case y of ... -> g x + +Here the RHS of the alternative refers to `x`, which will be recorded in the +continuation stack frame of the `case`. + +Even less obvious is that case continuation BCOs may also refer to free +variables in *parent* stack frames. For instance, + + f x y = case y of + ... -> case g x of + ... -> x + +Here, the RHS of the first alternative still refers to the `x` in the stack +frame of the `case`. Additionally, the RHS of the second alternative also +refers to `x` but it must traverse to its case's *parent* stack frame to find `x`. + +However, in /case continuation/ BCOs, the code may additionally refer to free +variables that are outside of that BCO's stack frame -- some free variables of a +case continuation BCO may only be found in the stack frame of a parent BCO. + +Yet, references to these out-of-frame variables are also done in terms of stack +offsets. Thus, they rely on the position of /another frame/ to be fixed. (See +Note [PUSH_L underflow] for more information about references to previous +frames and nested BCOs) + +This makes case continuation BCOs special: unlike normal BCOs, case cont BCO +frames cannot be moved on the stack independently from their parent BCOs. +-} + +data UnlinkedBCO + = UnlinkedBCO { + unlinkedBCOName :: !Name, + unlinkedBCOArity :: {-# UNPACK #-} !Int, + unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns + unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap + unlinkedBCOLits :: !(FlatBag BCONPtr), -- non-ptrs + unlinkedBCOPtrs :: !(FlatBag BCOPtr) -- ptrs + } + +instance NFData UnlinkedBCO where + rnf UnlinkedBCO{..} = + rnf unlinkedBCOLits `seq` + rnf unlinkedBCOPtrs + +data BCOPtr + = BCOPtrName !Name + | BCOPtrPrimOp !PrimOp + | BCOPtrBCO !UnlinkedBCO + | BCOPtrBreakArray !Module + -- ^ Converted to the actual 'BreakArray' remote pointer at link-time + +instance NFData BCOPtr where + rnf (BCOPtrBCO bco) = rnf bco + rnf x = x `seq` () + +data BCONPtr + = BCONPtrWord {-# UNPACK #-} !Word + | BCONPtrLbl !FastString + | BCONPtrItbl !Name + -- | A reference to a top-level string literal; see + -- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode. + | BCONPtrAddr !Name + -- | A top-level string literal. + -- Also see Note [Allocating string literals] in GHC.ByteCode.Asm. + | BCONPtrStr !ByteString + -- | Same as 'BCONPtrStr' but with benefits of 'FastString' interning logic. + | BCONPtrFS !FastString + -- | A libffi ffi_cif function prototype. + | BCONPtrFFIInfo !FFIInfo + -- | A 'CostCentre' remote pointer array's respective 'BreakpointId' + | BCONPtrCostCentre !InternalBreakpointId + +instance NFData BCONPtr where + rnf x = x `seq` () + +instance Outputable UnlinkedBCO where + ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) + = sep [text "BCO", ppr nm, text "with", + ppr (sizeFlatBag lits), text "lits", + ppr (sizeFlatBag ptrs), text "ptrs" ] + diff --git a/GHC/Cmm.hs b/GHC/Cmm.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm.hs @@ -0,0 +1,560 @@ +-- Cmm representations using Hoopl's Graph CmmNode e x. +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE EmptyCase #-} + +module GHC.Cmm ( + -- * Cmm top-level datatypes + DCmmGroup, + CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup, + CmmDecl, DCmmDecl, CmmDeclSRTs, GenCmmDecl(..), + CmmDataDecl, cmmDataDeclCmmDecl, DCmmGraph, + CmmGraph, GenCmmGraph, GenGenCmmGraph(..), + toBlockMap, revPostorder, toBlockList, + CmmBlock, RawCmmDecl, + Section(..), SectionType(..), + GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..), + SectionProtection(..), sectionProtection, + + DWrap(..), unDeterm, removeDeterm, removeDetermDecl, removeDetermGraph, + + -- ** Blocks containing lists + GenBasicBlock(..), blockId, + ListGraph(..), pprBBlock, + + -- * Info Tables + GenCmmTopInfo(..) + , DCmmTopInfo + , CmmTopInfo + , CmmStackInfo(..), CmmInfoTable(..), topInfoTable, topInfoTableD, + ClosureTypeInfo(..), + ProfilingInfo(..), ConstrDescription, + + -- * Statements, expressions and types + module GHC.Cmm.Node, + module GHC.Cmm.Expr, + + -- * Pretty-printing + pprCmmGroup, pprSection, pprStatic + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Types.Id +import GHC.Types.CostCentre +import GHC.Cmm.CLabel +import GHC.Cmm.BlockId +import GHC.Cmm.Node +import GHC.Runtime.Heap.Layout +import GHC.Cmm.Expr +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Utils.Outputable + +import Data.Void (Void) +import Data.List (intersperse) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS + +----------------------------------------------------------------------------- +-- Cmm, GenCmm +----------------------------------------------------------------------------- + +-- A CmmProgram is a list of CmmGroups +-- A CmmGroup is a list of top-level declarations + +-- When object-splitting is on, each group is compiled into a separate +-- .o file. So typically we put closely related stuff in a CmmGroup. +-- Section-splitting follows suit and makes one .text subsection for each +-- CmmGroup. + +type CmmProgram = [CmmGroup] + +type GenCmmGroup d h g = [GenCmmDecl d h g] +-- | Cmm group after STG generation +type DCmmGroup = GenCmmGroup CmmStatics DCmmTopInfo DCmmGraph +-- | Cmm group before SRT generation +type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph +-- | Cmm group with SRTs +type CmmGroupSRTs = GenCmmGroup RawCmmStatics CmmTopInfo CmmGraph +-- | "Raw" cmm group (TODO (osa): not sure what that means) +type RawCmmGroup = GenCmmGroup RawCmmStatics (LabelMap RawCmmStatics) CmmGraph + +----------------------------------------------------------------------------- +-- CmmDecl, GenCmmDecl +----------------------------------------------------------------------------- + +-- GenCmmDecl is abstracted over +-- d, the type of static data elements in CmmData +-- h, the static info preceding the code of a CmmProc +-- g, the control-flow graph of a CmmProc +-- +-- We expect there to be two main instances of this type: +-- (a) C--, i.e. populated with various C-- constructs +-- (b) Native code, populated with data/instructions + +-- | A top-level chunk, abstracted over the type of the contents of +-- the basic blocks (Cmm or instructions are the likely instantiations). +data GenCmmDecl d h g + = CmmProc -- A procedure + h -- Extra header such as the info table + CLabel -- Entry label + [GlobalRegUse] -- Registers live on entry. Note that the set of live + -- registers will be correct in generated C-- code, but + -- not in hand-written C-- code. However, + -- splitAtProcPoints calculates correct liveness + -- information for CmmProcs. + g -- Control-flow graph for the procedure's code + + | CmmData -- Static data + Section + d + + deriving (Functor) + +instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) + => OutputableP Platform (GenCmmDecl d info i) where + pdoc = pprTop + +type DCmmDecl = GenCmmDecl CmmStatics DCmmTopInfo DCmmGraph +type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph +type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph +type CmmDataDecl = GenCmmDataDecl CmmStatics +type GenCmmDataDecl d = GenCmmDecl d Void Void -- When `CmmProc` case can be statically excluded + +cmmDataDeclCmmDecl :: GenCmmDataDecl d -> GenCmmDecl d h g +cmmDataDeclCmmDecl = \ case + CmmProc void _ _ _ -> case void of + CmmData section d -> CmmData section d +{-# INLINE cmmDataDeclCmmDecl #-} + +type RawCmmDecl + = GenCmmDecl + RawCmmStatics + (LabelMap RawCmmStatics) + CmmGraph + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +type CmmGraph = GenCmmGraph CmmNode +type DCmmGraph = GenGenCmmGraph DWrap CmmNode + +type GenCmmGraph n = GenGenCmmGraph LabelMap n + +data GenGenCmmGraph s n = CmmGraph { g_entry :: BlockId, g_graph :: Graph' s Block n C C } +type CmmBlock = Block CmmNode C C + +instance OutputableP Platform CmmGraph where + pdoc = pprCmmGraph + +toBlockMap :: CmmGraph -> LabelMap CmmBlock +toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body + +pprCmmGraph :: Platform -> CmmGraph -> SDoc +pprCmmGraph platform g + = text "{" <> text "offset" + $$ nest 2 (vcat $ map (pdoc platform) blocks) + $$ text "}" + where blocks = revPostorder g + -- revPostorder has the side-effect of discarding unreachable code, + -- so pretty-printed Cmm will omit any unreachable blocks. This can + -- sometimes be confusing. + +revPostorder :: CmmGraph -> [CmmBlock] +revPostorder g = {-# SCC "revPostorder" #-} + revPostorderFrom (toBlockMap g) (g_entry g) + +toBlockList :: CmmGraph -> [CmmBlock] +toBlockList g = mapElems $ toBlockMap g + +----------------------------------------------------------------------------- +-- Info Tables +----------------------------------------------------------------------------- + +-- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains +-- the extra info (beyond the executable code) that belongs to that CmmDecl. +data GenCmmTopInfo f = TopInfo { info_tbls :: f CmmInfoTable + , stack_info :: CmmStackInfo } + +newtype DWrap a = DWrap [(BlockId, a)] + +unDeterm :: DWrap a -> [(BlockId, a)] +unDeterm (DWrap f) = f + +type DCmmTopInfo = GenCmmTopInfo DWrap +type CmmTopInfo = GenCmmTopInfo LabelMap + +instance OutputableP Platform CmmTopInfo where + pdoc = pprTopInfo + +pprTopInfo :: Platform -> CmmTopInfo -> SDoc +pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = + vcat [text "info_tbls: " <> pdoc platform info_tbl, + text "stack_info: " <> ppr stack_info] + +topInfoTableD :: GenCmmDecl a DCmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable +topInfoTableD (CmmProc infos _ _ g) = case (info_tbls infos) of + DWrap xs -> lookup (g_entry g) xs +topInfoTableD _ = Nothing + +topInfoTable :: GenCmmDecl a CmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable +topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) +topInfoTable _ = Nothing + +data CmmStackInfo + = StackInfo { + arg_space :: ByteOff, + -- number of bytes of arguments on the stack on entry to the + -- the proc. This is filled in by GHC.StgToCmm.codeGen, and + -- used by the stack allocator later. + do_layout :: Bool + -- Do automatic stack layout for this proc. This is + -- True for all code generated by the code generator, + -- but is occasionally False for hand-written Cmm where + -- we want to do the stack manipulation manually. + } + +instance Outputable CmmStackInfo where + ppr = pprStackInfo + +pprStackInfo :: CmmStackInfo -> SDoc +pprStackInfo (StackInfo {arg_space=arg_space}) = + text "arg_space: " <> ppr arg_space + +-- | Info table as a haskell data type +data CmmInfoTable + = CmmInfoTable { + cit_lbl :: CLabel, -- Info table label + cit_rep :: SMRep, + cit_prof :: ProfilingInfo, + cit_srt :: Maybe CLabel, -- empty, or a closure address + cit_clo :: Maybe (Id, CostCentreStack) + -- Just (id,ccs) <=> build a static closure later + -- Nothing <=> don't build a static closure + -- + -- Static closures for FUNs and THUNKs are *not* generated by + -- the code generator, because we might want to add SRT + -- entries to them later (for FUNs at least; THUNKs are + -- treated the same for consistency). See Note [SRTs] in + -- GHC.Cmm.Info.Build, in particular the [FUN] optimisation. + -- + -- This is strictly speaking not a part of the info table that + -- will be finally generated, but it's the only convenient + -- place to convey this information from the code generator to + -- where we build the static closures in + -- GHC.Cmm.Info.Build.doSRTs. + } deriving (Eq, Ord) + +instance OutputableP Platform CmmInfoTable where + pdoc = pprInfoTable + +data ProfilingInfo + = NoProfilingInfo + | ProfilingInfo ByteString ByteString -- closure_type, closure_desc + deriving (Eq, Ord) + +----------------------------------------------------------------------------- +-- Static Data +----------------------------------------------------------------------------- + +data SectionType + = Text + | Data + | ReadOnlyData + | RelocatableReadOnlyData + | UninitialisedData + -- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini + | InitArray -- .init_array on ELF, .ctor on Windows + | FiniArray -- .fini_array on ELF, .dtor on Windows + | CString + | OtherSection String + deriving (Show) + +data SectionProtection + = ReadWriteSection + | ReadOnlySection + | WriteProtectedSection -- See Note [Relocatable Read-Only Data] + deriving (Eq) + +-- | Should a data in this section be considered constant at runtime +sectionProtection :: Section -> SectionProtection +sectionProtection (Section t _) = case t of + Text -> ReadOnlySection + ReadOnlyData -> ReadOnlySection + RelocatableReadOnlyData -> WriteProtectedSection + InitArray -> ReadOnlySection + FiniArray -> ReadOnlySection + CString -> ReadOnlySection + Data -> ReadWriteSection + UninitialisedData -> ReadWriteSection + (OtherSection _) -> ReadWriteSection + +{- +Note [Relocatable Read-Only Data] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Relocatable data are only read-only after relocation at the start of the +program. They should be writable from the source code until then. Failure to +do so would end up in segfaults at execution when using linkers that do not +enforce writability of those sections, such as the gold linker. +-} + +data Section = Section SectionType CLabel + +data CmmStatic + = CmmStaticLit CmmLit + -- ^ a literal value, size given by cmmLitRep of the literal. + | CmmUninitialised Int + -- ^ uninitialised data, N bytes long + | CmmString ByteString + -- ^ string of 8-bit values only, not zero terminated. + | CmmFileEmbed FilePath Int + -- ^ an embedded binary file and its byte length + +instance OutputableP Platform CmmStatic where + pdoc = pprStatic + +instance Outputable CmmStatic where + ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit + ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n + ppr (CmmString _) = text "CmmString" + ppr (CmmFileEmbed fp _) = text "CmmFileEmbed" <+> text fp + +-- | Static data before or after SRT generation +data GenCmmStatics (rawOnly :: Bool) where + CmmStatics + :: CLabel -- Label of statics + -> CmmInfoTable + -> CostCentreStack + -> [CmmLit] -- Payload + -> [CmmLit] -- Non-pointers that go to the end of the closure + -- This is used by stg_unpack_cstring closures. + -- See Note [unpack_cstring closures] in StgStdThunks.cmm. + -> GenCmmStatics 'False + + -- | Static data, after SRTs are generated + CmmStaticsRaw + :: CLabel -- Label of statics + -> [CmmStatic] -- The static data itself + -> GenCmmStatics a + +instance OutputableP Platform (GenCmmStatics a) where + pdoc = pprStatics + +type CmmStatics = GenCmmStatics 'False +type RawCmmStatics = GenCmmStatics 'True + +{- +----------------------------------------------------------------------------- +-- Deterministic Cmm / Info Tables +----------------------------------------------------------------------------- + +Note [DCmmGroup vs CmmGroup or: Deterministic Info Tables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consulting Note [Object determinism] one will learn that in order to produce +deterministic objects just after cmm is produced we perform a renaming pass which +provides fresh uniques for all unique-able things in the input Cmm. + +After this point, we use a deterministic unique supply (an incrementing counter) +so any resulting labels which make their way into object code have a deterministic name. + +A key assumption to this process is that the input is deterministic modulo the uniques +and the order that bindings appear in the definitions is the same. + +CmmGroup uses LabelMap in two places: + +* In CmmProc for info tables +* In CmmGraph for the blocks of the graph + +LabelMap is not a deterministic structure, so traversing a LabelMap can process +elements in different order (depending on the given uniques). + +Therefore before we do the renaming we need to use a deterministic structure, one +which we can traverse in a guaranteed order. A list does the job perfectly. + +Once the renaming happens it is converted back into a LabelMap, which is now deterministic +due to the uniques being generated and assigned in a deterministic manner. + +We prefer using the renamed LabelMap rather than the list in the rest of the +code generation because it is much more efficient than lists for the needs of +the code generator. +-} + +-- Converting out of deterministic Cmm + +removeDeterm :: DCmmGroup -> CmmGroup +removeDeterm = map removeDetermDecl + +removeDetermDecl :: DCmmDecl -> CmmDecl +removeDetermDecl (CmmProc h e r g) = CmmProc (removeDetermTop h) e r (removeDetermGraph g) +removeDetermDecl (CmmData a b) = CmmData a b + +removeDetermTop :: DCmmTopInfo -> CmmTopInfo +removeDetermTop (TopInfo a b) = TopInfo (mapFromList $ unDeterm a) b + +removeDetermGraph :: DCmmGraph -> CmmGraph +removeDetermGraph (CmmGraph x y) = + let y' = case y of + GMany a (DWrap b) c -> GMany a (mapFromList b) c + in CmmGraph x y' + +-- ----------------------------------------------------------------------------- +-- Basic blocks consisting of lists + +-- These are used by the LLVM and NCG backends, when populating Cmm +-- with lists of instructions. + +data GenBasicBlock i + = BasicBlock BlockId [i] + deriving (Functor) + + +-- | The branch block id is that of the first block in +-- the branch, which is that branch's entry point +blockId :: GenBasicBlock i -> BlockId +blockId (BasicBlock blk_id _ ) = blk_id + +newtype ListGraph i + = ListGraph [GenBasicBlock i] + deriving (Functor) + +instance Outputable instr => Outputable (ListGraph instr) where + ppr (ListGraph blocks) = vcat (map ppr blocks) + +instance OutputableP env instr => OutputableP env (ListGraph instr) where + pdoc env g = ppr (fmap (pdoc env) g) + + +instance Outputable instr => Outputable (GenBasicBlock instr) where + ppr = pprBBlock + +instance OutputableP env instr => OutputableP env (GenBasicBlock instr) where + pdoc env block = ppr (fmap (pdoc env) block) + +pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc +pprBBlock (BasicBlock ident stmts) = + hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) + + +-- -------------------------------------------------------------------------- +-- Pretty-printing Cmm +-- -------------------------------------------------------------------------- +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We +-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. + +pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g) + => Platform -> GenCmmGroup d info g -> SDoc +pprCmmGroup platform tops + = vcat $ intersperse blankLine $ map (pprTop platform) tops + +-- -------------------------------------------------------------------------- +-- Top level `procedure' blocks. +-- + +pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) + => Platform -> GenCmmDecl d info i -> SDoc + +pprTop platform (CmmProc info lbl live graph) + + = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live + , nest 8 $ lbrace <+> pdoc platform info $$ rbrace + , nest 4 $ pdoc platform graph + , rbrace ] + +-- -------------------------------------------------------------------------- +-- We follow [1], 4.5 +-- +-- section "data" { ... } +-- + +pprTop platform (CmmData section ds) = + (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds)) + $$ rbrace + +-- -------------------------------------------------------------------------- +-- Pretty-printing info tables +-- -------------------------------------------------------------------------- + +pprInfoTable :: Platform -> CmmInfoTable -> SDoc +pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep + , cit_prof = prof_info + , cit_srt = srt }) + = vcat [ text "label: " <> pdoc platform lbl + , text "rep: " <> ppr rep + , case prof_info of + NoProfilingInfo -> empty + ProfilingInfo ct cd -> + vcat [ text "type: " <> text (show (BS.unpack ct)) + , text "desc: " <> text (show (BS.unpack cd)) ] + , text "srt: " <> pdoc platform srt ] + +-- -------------------------------------------------------------------------- +-- Static data. +-- Strings are printed as C strings, and we print them as I8[], +-- following C-- +-- + +pprStatics :: Platform -> GenCmmStatics a -> SDoc +pprStatics platform (CmmStatics lbl itbl ccs payload extras) = + pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload <+> ppr extras +pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds) + +pprStatic :: Platform -> CmmStatic -> SDoc +pprStatic platform s = case s of + CmmStaticLit lit -> nest 4 $ text "const" <+> pdoc platform lit <> semi + CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) + CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') + CmmFileEmbed path _ -> nest 4 $ text "incbin " <+> text (show path) + +-- -------------------------------------------------------------------------- +-- data sections +-- +pprSection :: Platform -> Section -> SDoc +pprSection platform (Section t suffix) = + section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix) + where + section = text "section" + +pprSectionType :: SectionType -> SDoc +pprSectionType s = doubleQuotes $ case s of + Text -> text "text" + Data -> text "data" + ReadOnlyData -> text "readonly" + RelocatableReadOnlyData -> text "relreadonly" + UninitialisedData -> text "uninitialised" + InitArray -> text "initarray" + FiniArray -> text "finiarray" + CString -> text "cstring" + OtherSection s' -> text s' diff --git a/GHC/Cmm/BlockId.hs b/GHC/Cmm/BlockId.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/BlockId.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- BlockId module should probably go away completely, being superseded by Label -} +module GHC.Cmm.BlockId + ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet + , newBlockId + , blockLbl, infoTblLbl + ) where + +import GHC.Prelude + +import GHC.Cmm.CLabel +import GHC.Data.FastString +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Types.Unique +import qualified GHC.Types.Unique.DSM as DSM + +import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel) + +---------------------------------------------------------------- +--- Block Ids, their environments, and their sets + +{- Note [Unique BlockId] +~~~~~~~~~~~~~~~~~~~~~~~~ +Although a 'BlockId' is a local label, for reasons of implementation, +'BlockId's must be unique within an entire compilation unit. The reason +is that each local label is mapped to an assembly-language label, and in +most assembly languages allow, a label is visible throughout the entire +compilation unit in which it appears. +-} + +type BlockId = Label + +mkBlockId :: Unique -> BlockId +mkBlockId unique = mkHooplLabel $ getKey unique + +-- If the monad unique instance uses a deterministic unique supply, this will +-- give you a deterministic unique. Otherwise, it will not. Note that from Cmm +-- onwards (after deterministic renaming in 'codeGen'), there should only exist +-- deterministic block labels. +newBlockId :: DSM.MonadGetUnique m => m BlockId +newBlockId = mkBlockId <$> DSM.getUniqueM + +blockLbl :: BlockId -> CLabel +blockLbl label = mkLocalBlockLabel (getUnique label) + +infoTblLbl :: BlockId -> CLabel +infoTblLbl label + = mkBlockInfoTableLabel (mkFCallName (getUnique label) (fsLit "block")) NoCafRefs diff --git a/GHC/Cmm/BlockId.hs-boot b/GHC/Cmm/BlockId.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Cmm/BlockId.hs-boot @@ -0,0 +1,8 @@ +module GHC.Cmm.BlockId (BlockId, mkBlockId) where + +import GHC.Cmm.Dataflow.Label (Label) +import GHC.Types.Unique (Unique) + +type BlockId = Label + +mkBlockId :: Unique -> BlockId diff --git a/GHC/Cmm/CLabel.hs b/GHC/Cmm/CLabel.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/CLabel.hs @@ -0,0 +1,1962 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- +-- Object-file symbols (called CLabel for historical reasons). +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.Cmm.CLabel ( + CLabel, -- abstract type + NeedExternDecl (..), + ForeignLabelSource(..), + DynamicLinkerLabelInfo(..), + ConInfoTableLocation(..), + getConInfoTableLocation, + + -- * Constructors + mkClosureLabel, + mkSRTLabel, + mkInfoTableLabel, + mkEntryLabel, + mkRednCountsLabel, + mkTagHitLabel, + mkConInfoTableLabel, + mkApEntryLabel, + mkApInfoTableLabel, + mkClosureTableLabel, + mkBytesLabel, + + mkLocalBlockLabel, + + mkBlockInfoTableLabel, + + mkBitmapLabel, + mkStringLitLabel, + + mkInitializerStubLabel, + mkInitializerArrayLabel, + mkFinalizerStubLabel, + mkFinalizerArrayLabel, + + mkAsmTempLabel, + mkAsmTempDerivedLabel, + mkAsmTempEndLabel, + mkAsmTempProcEndLabel, + mkAsmTempDieLabel, + + mkDirty_MUT_VAR_Label, + mkMUT_VAR_CLEAN_infoLabel, + mkNonmovingWriteBarrierEnabledLabel, + mkOrigThunkInfoLabel, + mkUpdInfoLabel, + mkBHUpdInfoLabel, + mkIndStaticInfoLabel, + mkMainCapabilityLabel, + mkMAP_FROZEN_CLEAN_infoLabel, + mkMAP_FROZEN_DIRTY_infoLabel, + mkMAP_DIRTY_infoLabel, + mkSMAP_FROZEN_CLEAN_infoLabel, + mkSMAP_FROZEN_DIRTY_infoLabel, + mkSMAP_DIRTY_infoLabel, + mkBadAlignmentLabel, + mkOutOfBoundsAccessLabel, + mkMemcpyRangeOverlapLabel, + mkArrWords_infoLabel, + mkSRTInfoLabel, + + mkTopTickyCtrLabel, + mkCAFBlackHoleInfoTableLabel, + mkRtsPrimOpLabel, + mkRtsSlowFastTickyCtrLabel, + mkRtsUnpackCStringLabel, + mkRtsUnpackCStringUtf8Label, + + mkSelectorInfoLabel, + mkSelectorEntryLabel, + mkCmmInfoLabel, + mkCmmEntryLabel, + mkCmmRetInfoLabel, + mkCmmRetLabel, + mkCmmCodeLabel, + mkCmmDataLabel, + mkRtsCmmDataLabel, + mkCmmClosureLabel, + mkRtsApFastLabel, + mkPrimCallLabel, + mkForeignLabel, + mkCCLabel, + mkCCSLabel, + mkIPELabel, + InfoProvEnt(..), + + mkDynamicLinkerLabel, + mkPicBaseLabel, + mkDeadStripPreventer, + mkHpcTicksLabel, + + -- * Predicates + hasCAF, + needsCDecl, + maybeLocalBlockLabel, + externallyVisibleCLabel, + isLibcFun, + isCFunctionLabel, + isGcPtrLabel, + labelDynamic, + isLocalCLabel, + mayRedirectTo, + isInfoTableLabel, + isCmmInfoTableLabel, + isConInfoTableLabel, + isIdLabel, + isTickyLabel, + hasHaskellName, + hasIdLabelInfo, + isBytesLabel, + isForeignLabel, + isSomeRODataLabel, + isStaticClosureLabel, + + -- * Conversions + toClosureLbl, + toSlowEntryLbl, + toEntryLbl, + toInfoLbl, + toProcDelimiterLbl, + + -- * Pretty-printing + LabelStyle (..), + pprDebugCLabel, + pprCLabel, + pprAsmLabel, + ppInternalProcLabel, + + -- * Others + dynamicLinkerLabelInfo, + CStubLabel (..), + cStubLabel, + fromCStubLabel, + mapInternalNonDetUniques + ) where + +import GHC.Prelude + +import GHC.Types.Id.Info +import GHC.Types.Basic +import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId) +import GHC.Unit.Types +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Builtin.PrimOps +import GHC.Types.CostCentre +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.FastString +import GHC.Platform +import GHC.Types.Unique.Set +import GHC.Core.Ppr ( {- instances -} ) +import GHC.Types.SrcLoc + +import qualified Data.Semigroup as S + +-- ----------------------------------------------------------------------------- +-- The CLabel type + +{- | + 'CLabel' is an abstract type that supports the following operations: + + - Pretty printing + + - In a C file, does it need to be declared before use? (i.e. is it + guaranteed to be already in scope in the places we need to refer to it?) + + - If it needs to be declared, what type (code or data) should it be + declared to have? + + - Is it visible outside this object file or not? + + - Is it "dynamic" (see details below) + + - Eq and Ord, so that we can make sets of CLabels (currently only + used in outputting C as far as I can tell, to avoid generating + more than one declaration for any given label). + + - Converting an info table label into an entry label. + + CLabel usage is a bit messy in GHC as they are used in a number of different + contexts: + + - By the C-- AST to identify labels + + - By the unregisterised C code generator (\"PprC\") for naming functions (hence + the name 'CLabel') + + - By the native and LLVM code generators to identify labels + + For extra fun, each of these uses a slightly different subset of constructors + (e.g. 'AsmTempLabel' and 'AsmTempDerivedLabel' are used only in the NCG and + LLVM backends). + + In general, we use 'IdLabel' to represent Haskell things early in the + pipeline. However, later optimization passes will often represent blocks they + create with 'LocalBlockLabel' where there is no obvious 'Name' to hang off the + label. +-} + +data CLabel + = -- | A label related to the definition of a particular Id or Con in a .hs file. + IdLabel + Name + CafInfo + IdLabelInfo -- ^ encodes the suffix of the label + + -- | A label from a .cmm file that is not associated with a .hs level Id. + | CmmLabel + UnitId -- ^ what package the label belongs to. + NeedExternDecl -- ^ does the label need an "extern .." declaration + FastString -- ^ identifier giving the prefix of the label + CmmLabelInfo -- ^ encodes the suffix of the label + + -- | A label with a baked-in \/ algorithmically generated name that definitely + -- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so + -- If it doesn't have an algorithmically generated name then use a CmmLabel + -- instead and give it an appropriate UnitId argument. + | RtsLabel + RtsLabelInfo + + -- | A label associated with a block. These aren't visible outside of the + -- compilation unit in which they are defined. These are generally used to + -- name blocks produced by Cmm-to-Cmm passes and the native code generator, + -- where we don't have a 'Name' to associate the label to and therefore can't + -- use 'IdLabel'. + | LocalBlockLabel + {-# UNPACK #-} !Unique + + -- | A 'C' (or otherwise foreign) label. + -- + | ForeignLabel + FastString -- ^ name of the imported label. + + ForeignLabelSource -- ^ what package the foreign label is in. + + FunctionOrData + + -- | Local temporary label used for native (or LLVM) code generation; must not + -- appear outside of these contexts. Use primarily for debug information + | AsmTempLabel + {-# UNPACK #-} !Unique + + -- | A label \"derived\" from another 'CLabel' by the addition of a suffix. + -- Must not occur outside of the NCG or LLVM code generators. + | AsmTempDerivedLabel + CLabel + FastString -- ^ suffix + + | StringLitLabel + {-# UNPACK #-} !Unique + + | CC_Label CostCentre + | CCS_Label CostCentreStack + | IPE_Label InfoProvEnt + + -- | A per-module metadata label. + | ModuleLabel !Module ModuleLabelKind + + -- | These labels are generated and used inside the NCG only. + -- They are special variants of a label used for dynamic linking + -- see module "GHC.CmmToAsm.PIC" for details. + | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel + + -- | This label is generated and used inside the NCG only. + -- It is used as a base for PIC calculations on some platforms. + -- It takes the form of a local numeric assembler label '1'; and + -- is pretty-printed as 1b, referring to the previous definition + -- of 1: in the assembler source file. + | PicBaseLabel + + -- | A label before an info table to prevent excessive dead-stripping on darwin + | DeadStripPreventer CLabel + + -- | Per-module table of tick locations + | HpcTicksLabel Module + + -- | Static reference table + | SRTLabel + {-# UNPACK #-} !Unique + + -- | A bitmap (function or case return) + | LargeBitmapLabel + {-# UNPACK #-} !Unique + + deriving Eq + +instance Show CLabel where + show = showPprUnsafe . pprDebugCLabel genericPlatform + +data ModuleLabelKind + = MLK_Initializer LexicalFastString + | MLK_InitializerArray + | MLK_Finalizer LexicalFastString + | MLK_FinalizerArray + | MLK_IPEBuffer + deriving (Eq, Ord) + +pprModuleLabelKind :: IsLine doc => ModuleLabelKind -> doc +pprModuleLabelKind MLK_InitializerArray = text "init_arr" +pprModuleLabelKind (MLK_Initializer (LexicalFastString s)) = text "init__" <> ftext s +pprModuleLabelKind MLK_FinalizerArray = text "fini_arr" +pprModuleLabelKind (MLK_Finalizer (LexicalFastString s)) = text "fini__" <> ftext s +pprModuleLabelKind MLK_IPEBuffer = text "ipe_buf" +{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> SDoc #-} +{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +isIdLabel :: CLabel -> Bool +isIdLabel IdLabel{} = True +isIdLabel _ = False + +-- Used in SRT analysis. See Note [Ticky labels in SRT analysis] in +-- GHC.Cmm.Info.Build. +isTickyLabel :: CLabel -> Bool +isTickyLabel (IdLabel _ _ IdTickyInfo{}) = True +isTickyLabel _ = False + +-- | Indicate if "GHC.CmmToC" has to generate an extern declaration for the +-- label (e.g. "extern StgWordArray(foo)"). The type is fixed to StgWordArray. +-- +-- Symbols from the RTS don't need "extern" declarations because they are +-- exposed via "rts/include/Stg.h" with the appropriate type. See 'needsCDecl'. +-- +-- The fixed StgWordArray type led to "conflicting types" issues with user +-- provided Cmm files (not in the RTS) that declare data of another type (#15467 +-- and test for #17920). Hence the Cmm parser considers that labels in data +-- sections don't need the "extern" declaration (just add one explicitly if you +-- need it). +-- +-- See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/backends/ppr-c#prototypes +-- for why extern declaration are needed at all. +newtype NeedExternDecl + = NeedExternDecl Bool + deriving (Ord,Eq) + +-- This is laborious, but necessary. We can't derive Ord because +-- Unique has a special Ord instance that cares for object determinism. +-- Note nonDetCmpUnique and stableNameCmp in the implementation: +-- * If -fobject-determinism, the internal uniques will be renamed, thus the +-- comparison will actually be deterministic +-- * Stable name compare guarantees deterministic ordering of Names despite +-- the non-deterministic uniques underlying external names (which aren't +-- renamed on -fobject-determinism). +-- See Note [Unique Determinism and code generation] and Note [Object determinism] +instance Ord CLabel where + compare (IdLabel a1 b1 c1) + (IdLabel a2 b2 c2) + | isExternalName a1, isExternalName a2 = stableNameCmp a1 a2 S.<> compare b1 b2 S.<> compare c1 c2 + | isExternalName a1 = GT + | isExternalName a2 = LT + + compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) = + -- Comparing names here should deterministic because all unique should have + -- been renamed deterministically, and external names compared above. + compare a1 a2 S.<> + compare b1 b2 S.<> + compare c1 c2 + compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) = + compare a1 a2 S.<> + compare b1 b2 S.<> + -- This is not non-deterministic because the uniques have been deterministically renamed. + -- See Note [Object determinism] + uniqCompareFS c1 c2 S.<> + compare d1 d2 + compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2 + compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2 + compare (ForeignLabel a1 b1 c1) (ForeignLabel a2 b2 c2) = + uniqCompareFS a1 a2 S.<> + compare b1 b2 S.<> + compare c1 c2 + compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2 + compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) = + compare a1 a2 S.<> + lexicalCompareFS b1 b2 + compare (StringLitLabel u1) (StringLitLabel u2) = + nonDetCmpUnique u1 u2 + compare (CC_Label a1) (CC_Label a2) = + compare a1 a2 + compare (CCS_Label a1) (CCS_Label a2) = + compare a1 a2 + compare (IPE_Label a1) (IPE_Label a2) = + compare a1 a2 + compare (ModuleLabel m1 k1) (ModuleLabel m2 k2) = + compare m1 m2 S.<> + compare k1 k2 + compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) = + compare a1 a2 S.<> + compare b1 b2 + compare PicBaseLabel PicBaseLabel = EQ + compare (DeadStripPreventer a1) (DeadStripPreventer a2) = + compare a1 a2 + compare (HpcTicksLabel a1) (HpcTicksLabel a2) = + compare a1 a2 + compare (SRTLabel u1) (SRTLabel u2) = + nonDetCmpUnique u1 u2 + compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) = + nonDetCmpUnique u1 u2 + compare IdLabel{} _ = LT + compare _ IdLabel{} = GT + compare CmmLabel{} _ = LT + compare _ CmmLabel{} = GT + compare RtsLabel{} _ = LT + compare _ RtsLabel{} = GT + compare LocalBlockLabel{} _ = LT + compare _ LocalBlockLabel{} = GT + compare ForeignLabel{} _ = LT + compare _ ForeignLabel{} = GT + compare AsmTempLabel{} _ = LT + compare _ AsmTempLabel{} = GT + compare AsmTempDerivedLabel{} _ = LT + compare _ AsmTempDerivedLabel{} = GT + compare StringLitLabel{} _ = LT + compare _ StringLitLabel{} = GT + compare CC_Label{} _ = LT + compare _ CC_Label{} = GT + compare CCS_Label{} _ = LT + compare _ CCS_Label{} = GT + compare DynamicLinkerLabel{} _ = LT + compare _ DynamicLinkerLabel{} = GT + compare PicBaseLabel{} _ = LT + compare _ PicBaseLabel{} = GT + compare DeadStripPreventer{} _ = LT + compare _ DeadStripPreventer{} = GT + compare HpcTicksLabel{} _ = LT + compare _ HpcTicksLabel{} = GT + compare SRTLabel{} _ = LT + compare _ SRTLabel{} = GT + compare (IPE_Label {}) _ = LT + compare _ (IPE_Label{}) = GT + compare (ModuleLabel {}) _ = LT + compare _ (ModuleLabel{}) = GT + +-- | Record where a foreign label is stored. +data ForeignLabelSource + + -- | Label is in a named package + = ForeignLabelInPackage UnitId + + -- | Label is in some external, system package that doesn't also + -- contain compiled Haskell code, and is not associated with any .hi files. + -- We don't have to worry about Haskell code being inlined from + -- external packages. It is safe to treat the RTS package as "external". + | ForeignLabelInExternalPackage + + -- | Label is in the package currently being compiled. + -- This is only used for creating hacky tmp labels during code generation. + -- Don't use it in any code that might be inlined across a package boundary + -- (ie, core code) else the information will be wrong relative to the + -- destination module. + | ForeignLabelInThisPackage + + deriving (Eq, Ord) + + +-- | For debugging problems with the CLabel representation. +-- We can't make a Show instance for CLabel because lots of its components don't have instances. +-- The regular Outputable instance only shows the label name, and not its other info. +-- +pprDebugCLabel :: Platform -> CLabel -> SDoc +pprDebugCLabel platform lbl = pprAsmLabel platform lbl <> parens extra + where + extra = case lbl of + IdLabel _ _ info + -> text "IdLabel" <> whenPprDebug (text ":" <> ppr info) + + CmmLabel pkg _ext _name _info + -> text "CmmLabel" <+> ppr pkg + + RtsLabel{} + -> text "RtsLabel" + + ForeignLabel _name src funOrData + -> text "ForeignLabel" <+> ppr src <+> ppr funOrData + + _ -> text "other CLabel" + +-- Dynamic ticky info for the id. +data TickyIdInfo + = TickyRednCounts -- ^ Used for dynamic allocations + | TickyInferedTag !Unique -- ^ Used to track dynamic hits of tag inference. + deriving (Eq,Show) + +instance Outputable TickyIdInfo where + ppr TickyRednCounts = text "ct_rdn" + ppr (TickyInferedTag unique) = text "ct_tag[" <> ppr unique <> char ']' + +-- | Don't depend on this if you need determinism. +-- No determinism in the ncg backend, so we use the unique for Ord. +-- Even if it pains me slightly. +instance Ord TickyIdInfo where + compare TickyRednCounts TickyRednCounts = EQ + compare TickyRednCounts _ = LT + compare _ TickyRednCounts = GT + compare (TickyInferedTag unique1) (TickyInferedTag unique2) = + nonDetCmpUnique unique1 unique2 + + +data IdLabelInfo + = Closure -- ^ Label for closure + | InfoTable -- ^ Info tables for closures; always read-only + | Entry -- ^ Entry point + | Slow -- ^ Slow entry point + + | LocalInfoTable -- ^ Like InfoTable but not externally visible + | LocalEntry -- ^ Like Entry but not externally visible + + | IdTickyInfo !TickyIdInfo -- ^ Label of place to keep Ticky-ticky hit info for this Id + + | ConEntry ConInfoTableLocation + -- ^ Constructor entry point, when `-fdistinct-info-tables` is enabled then + -- each usage of a constructor will be given a unique number and a fresh info + -- table will be created in the module where the constructor is used. The + -- argument is used to keep track of which info table a usage of a constructor + -- should use. When the argument is 'Nothing' then it uses the info table which + -- is defined in the module where the datatype is declared, this is the usual case. + -- When it is (Just (m, k)) it will use the kth info table defined in module m. The + -- point of this inefficiency is so that you can work out where allocations of data + -- constructors are coming from when you are debugging. + + | ConInfoTable ConInfoTableLocation -- ^ Corresponding info table + + | ClosureTable -- ^ Table of closures for Enum tycons + + | Bytes -- ^ Content of a string literal. See + -- Note [Bytes label]. + | BlockInfoTable -- ^ Like LocalInfoTable but for a proc-point block + -- instead of a closure entry-point. + -- See Note [Proc-point local block entry-points]. + + deriving (Eq, Ord) + +-- | Which module is the info table from, and which number was it. +data ConInfoTableLocation = UsageSite Module Int + | DefinitionSite + deriving (Eq, Ord) + +instance Outputable ConInfoTableLocation where + ppr (UsageSite m n) = text "Loc(" <> ppr n <> text "):" <+> ppr m + ppr DefinitionSite = empty + +getConInfoTableLocation :: IdLabelInfo -> Maybe ConInfoTableLocation +getConInfoTableLocation (ConInfoTable ci) = Just ci +getConInfoTableLocation _ = Nothing + +instance Outputable IdLabelInfo where + ppr Closure = text "Closure" + ppr InfoTable = text "InfoTable" + ppr Entry = text "Entry" + ppr Slow = text "Slow" + + ppr LocalInfoTable = text "LocalInfoTable" + ppr LocalEntry = text "LocalEntry" + + ppr (ConEntry mn) = text "ConEntry" <+> ppr mn + ppr (ConInfoTable mn) = text "ConInfoTable" <+> ppr mn + ppr ClosureTable = text "ClosureTable" + ppr Bytes = text "Bytes" + ppr BlockInfoTable = text "BlockInfoTable" + ppr (IdTickyInfo info) = text "IdTickyInfo" <+> ppr info + + +data RtsLabelInfo + = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- ^ Selector thunks + | RtsSelectorEntry Bool{-updatable-} Int{-offset-} + + | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- ^ AP thunks + | RtsApEntry Bool{-updatable-} Int{-arity-} + + | RtsUnpackCStringInfoTable + | RtsUnpackCStringUtf8InfoTable + | RtsPrimOp PrimOp + | RtsApFast NonDetFastString -- ^ _fast versions of generic apply + | RtsSlowFastTickyCtr String + + deriving (Eq,Ord) + + +-- | What type of Cmm label we're dealing with. +-- Determines the suffix appended to the name when a CLabel.CmmLabel +-- is pretty printed. +data CmmLabelInfo + = CmmInfo -- ^ misc rts info tables, suffix _info + | CmmEntry -- ^ misc rts entry points, suffix _entry + | CmmRetInfo -- ^ misc rts ret info tables, suffix _info + | CmmRet -- ^ misc rts return points, suffix _ret + | CmmData -- ^ misc rts data bits, eg CHARLIKE_closure + | CmmCode -- ^ misc rts code + | CmmClosure -- ^ closures eg CHARLIKE_closure + | CmmPrimCall -- ^ a prim call to some hand written Cmm code + deriving (Eq, Ord) + +data DynamicLinkerLabelInfo + = CodeStub -- MachO: Lfoo$stub, ELF: foo@plt + | SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo + | GotSymbolPtr -- ELF: foo@got + | GotSymbolOffset -- ELF: foo@gotoff + + deriving (Eq, Ord) + + +-- ----------------------------------------------------------------------------- +-- Constructing CLabels +-- ----------------------------------------------------------------------------- + +-- Constructing IdLabels +-- These are always local: + +mkSRTLabel :: Unique -> CLabel +mkSRTLabel u = SRTLabel u + +-- See Note [ticky for LNE] +mkRednCountsLabel :: Name -> CLabel +mkRednCountsLabel name = IdLabel name NoCafRefs (IdTickyInfo TickyRednCounts) + +mkTagHitLabel :: Name -> Unique -> CLabel +mkTagHitLabel name !uniq = IdLabel name NoCafRefs (IdTickyInfo (TickyInferedTag uniq)) + +mkClosureLabel :: Name -> CafInfo -> CLabel +mkInfoTableLabel :: Name -> CafInfo -> CLabel +mkEntryLabel :: Name -> CafInfo -> CLabel +mkClosureTableLabel :: Name -> CafInfo -> CLabel +mkConInfoTableLabel :: Name -> ConInfoTableLocation -> CLabel +mkBytesLabel :: Name -> CLabel +mkClosureLabel name c = IdLabel name c Closure +-- | Decides between external and local labels based on the names externality. +mkInfoTableLabel name c + | isExternalName name = IdLabel name c InfoTable + | otherwise = IdLabel name c LocalInfoTable +mkEntryLabel name c = IdLabel name c Entry +mkClosureTableLabel name c = IdLabel name c ClosureTable +-- Special case for the normal 'DefinitionSite' case so that the 'ConInfoTable' application can be floated to a CAF. +mkConInfoTableLabel name DefinitionSite = IdLabel name NoCafRefs (ConInfoTable DefinitionSite) +mkConInfoTableLabel name k = IdLabel name NoCafRefs (ConInfoTable k) +mkBytesLabel name = IdLabel name NoCafRefs Bytes + +mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel +mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable + -- See Note [Proc-point local block entry-points]. + +-- Constructing Cmm Labels +mkDirty_MUT_VAR_Label, + mkNonmovingWriteBarrierEnabledLabel, + mkOrigThunkInfoLabel, mkUpdInfoLabel, + mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, + mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel, + mkMAP_DIRTY_infoLabel, + mkArrWords_infoLabel, + mkTopTickyCtrLabel, + mkCAFBlackHoleInfoTableLabel, + mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel, + mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, + mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel, + mkMUT_VAR_CLEAN_infoLabel :: CLabel +mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") ForeignLabelInExternalPackage IsFunction +mkNonmovingWriteBarrierEnabledLabel + = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData +mkOrigThunkInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo +mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo +mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo +mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo +mkMainCapabilityLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "MainCapability") CmmData +mkMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo +mkMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo +mkMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo +mkTopTickyCtrLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "top_ct") CmmData +mkCAFBlackHoleInfoTableLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_CAF_BLACKHOLE") CmmInfo +mkArrWords_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_ARR_WORDS") CmmInfo +mkSMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo +mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo +mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo +mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmEntry +mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") ForeignLabelInExternalPackage IsFunction +mkMemcpyRangeOverlapLabel = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") ForeignLabelInExternalPackage IsFunction +mkMUT_VAR_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN") CmmInfo + +mkSRTInfoLabel :: Int -> CLabel +mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo + where + lbl = + case n of + 1 -> fsLit "stg_SRT_1" + 2 -> fsLit "stg_SRT_2" + 3 -> fsLit "stg_SRT_3" + 4 -> fsLit "stg_SRT_4" + 5 -> fsLit "stg_SRT_5" + 6 -> fsLit "stg_SRT_6" + 7 -> fsLit "stg_SRT_7" + 8 -> fsLit "stg_SRT_8" + 9 -> fsLit "stg_SRT_9" + 10 -> fsLit "stg_SRT_10" + 11 -> fsLit "stg_SRT_11" + 12 -> fsLit "stg_SRT_12" + 13 -> fsLit "stg_SRT_13" + 14 -> fsLit "stg_SRT_14" + 15 -> fsLit "stg_SRT_15" + 16 -> fsLit "stg_SRT_16" + _ -> panic "mkSRTInfoLabel" + +----- +mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, + mkCmmCodeLabel, mkCmmClosureLabel + :: UnitId -> FastString -> CLabel + +mkCmmDataLabel :: UnitId -> NeedExternDecl -> FastString -> CLabel +mkRtsCmmDataLabel :: FastString -> CLabel + +mkCmmInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmInfo +mkCmmEntryLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmEntry +mkCmmRetInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRetInfo +mkCmmRetLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRet +mkCmmCodeLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmCode +mkCmmClosureLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmClosure +mkCmmDataLabel pkg ext str = CmmLabel pkg ext str CmmData +mkRtsCmmDataLabel str = CmmLabel rtsUnitId (NeedExternDecl False) str CmmData + -- RTS symbols don't need "GHC.CmmToC" to + -- generate \"extern\" declaration (they are + -- exposed via rts/include/Stg.h) + +mkLocalBlockLabel :: Unique -> CLabel +mkLocalBlockLabel u = LocalBlockLabel u + +-- Constructing RtsLabels +mkRtsPrimOpLabel :: PrimOp -> CLabel +mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) + +mkSelectorInfoLabel :: Platform -> Bool -> Int -> CLabel +mkSelectorInfoLabel platform upd offset = + assert (offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform)) $ + RtsLabel (RtsSelectorInfoTable upd offset) + +mkSelectorEntryLabel :: Platform -> Bool -> Int -> CLabel +mkSelectorEntryLabel platform upd offset = + assert (offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform)) $ + RtsLabel (RtsSelectorEntry upd offset) + +mkApInfoTableLabel :: Platform -> Bool -> Int -> CLabel +mkApInfoTableLabel platform upd arity = + assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $ + RtsLabel (RtsApInfoTable upd arity) + +mkApEntryLabel :: Platform -> Bool -> Int -> CLabel +mkApEntryLabel platform upd arity = + assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $ + RtsLabel (RtsApEntry upd arity) + +-- A call to some primitive hand written Cmm code +mkPrimCallLabel :: PrimCall -> CLabel +mkPrimCallLabel (PrimCall str pkg) + = CmmLabel (toUnitId pkg) (NeedExternDecl True) str CmmPrimCall + + +-- Constructing ForeignLabels + +-- | Make a foreign label +mkForeignLabel + :: FastString -- name + -> ForeignLabelSource -- what package it's in + -> FunctionOrData + -> CLabel + +mkForeignLabel = ForeignLabel + +-- | Whether label is a top-level string literal +isBytesLabel :: CLabel -> Bool +isBytesLabel (IdLabel _ _ Bytes) = True +isBytesLabel _lbl = False + +-- | Whether label is a non-haskell label (defined in C code) +isForeignLabel :: CLabel -> Bool +isForeignLabel (ForeignLabel _ _ _) = True +isForeignLabel _lbl = False + +-- | Whether label is a static closure label (can come from haskell or cmm) +isStaticClosureLabel :: CLabel -> Bool +-- Closure defined in haskell (.hs) +isStaticClosureLabel (IdLabel _ _ Closure) = True +-- Closure defined in cmm +isStaticClosureLabel (CmmLabel _ _ _ CmmClosure) = True +isStaticClosureLabel _lbl = False + +-- | Whether label is a .rodata label +isSomeRODataLabel :: CLabel -> Bool +-- info table defined in haskell (.hs) +isSomeRODataLabel (IdLabel _ _ ClosureTable) = True +isSomeRODataLabel (IdLabel _ _ ConInfoTable {}) = True +isSomeRODataLabel (IdLabel _ _ InfoTable) = True +isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True +isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True +-- info table defined in cmm (.cmm) +isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True +isSomeRODataLabel (CmmLabel _ _ _ CmmRetInfo) = True +isSomeRODataLabel _lbl = False + +-- | Whether label is points to some kind of info table +isInfoTableLabel :: CLabel -> Bool +isInfoTableLabel (IdLabel _ _ InfoTable) = True +isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True +isInfoTableLabel (IdLabel _ _ ConInfoTable {}) = True +isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True +isInfoTableLabel (CmmLabel _ _ _ CmmInfo) = True +isInfoTableLabel _ = False + +-- | Whether label points to an info table defined in Cmm +isCmmInfoTableLabel :: CLabel -> Bool +isCmmInfoTableLabel (CmmLabel _ _ _ CmmInfo) = True +isCmmInfoTableLabel _ = False + +-- | Whether label is points to constructor info table +isConInfoTableLabel :: CLabel -> Bool +isConInfoTableLabel (IdLabel _ _ ConInfoTable {}) = True +isConInfoTableLabel _ = False + +-- Constructing Large*Labels +mkBitmapLabel :: Unique -> CLabel +mkBitmapLabel uniq = LargeBitmapLabel uniq + +-- | Info Table Provenance Entry +-- See Note [Mapping Info Tables to Source Positions] +data InfoProvEnt = InfoProvEnt + { infoTablePtr :: !CLabel + -- Address of the info table + , infoProvEntClosureType :: !Int + -- The closure type of the info table (from ClosureMacros.h) + , infoTableType :: !String + -- The rendered Haskell type of the closure the table represents + , infoProvModule :: !Module + -- Origin module + , infoTableProv :: !(Maybe (RealSrcSpan, LexicalFastString)) } + -- Position and information about the info table + deriving (Eq, Ord) + +instance OutputableP Platform InfoProvEnt where + pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel + +-- Constructing Cost Center Labels +mkCCLabel :: CostCentre -> CLabel +mkCCSLabel :: CostCentreStack -> CLabel +mkIPELabel :: Module -> CLabel +mkCCLabel cc = CC_Label cc +mkCCSLabel ccs = CCS_Label ccs +mkIPELabel mod = ModuleLabel mod MLK_IPEBuffer + +mkRtsApFastLabel :: FastString -> CLabel +mkRtsApFastLabel str = RtsLabel (RtsApFast (NonDetFastString str)) + +mkRtsSlowFastTickyCtrLabel :: String -> CLabel +mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat) + +-- | A standard string unpacking thunk. See Note [unpack_cstring closures] in +-- StgStdThunks.cmm. +mkRtsUnpackCStringLabel, mkRtsUnpackCStringUtf8Label :: CLabel +mkRtsUnpackCStringLabel = RtsLabel RtsUnpackCStringInfoTable +mkRtsUnpackCStringUtf8Label = RtsLabel RtsUnpackCStringUtf8InfoTable + +-- Constructing Code Coverage Labels +mkHpcTicksLabel :: Module -> CLabel +mkHpcTicksLabel = HpcTicksLabel + + +-- Constructing labels used for dynamic linking +mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel +mkDynamicLinkerLabel = DynamicLinkerLabel + +dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel) +dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl) +dynamicLinkerLabelInfo _ = Nothing + +mkPicBaseLabel :: CLabel +mkPicBaseLabel = PicBaseLabel + + +-- Constructing miscellaneous other labels +mkDeadStripPreventer :: CLabel -> CLabel +mkDeadStripPreventer lbl = DeadStripPreventer lbl + +mkStringLitLabel :: Unique -> CLabel +mkStringLitLabel = StringLitLabel + +mkInitializerStubLabel :: Module -> FastString -> CLabel +mkInitializerStubLabel mod s = ModuleLabel mod (MLK_Initializer (LexicalFastString s)) + +mkInitializerArrayLabel :: Module -> CLabel +mkInitializerArrayLabel mod = ModuleLabel mod MLK_InitializerArray + + +mkFinalizerStubLabel :: Module -> FastString -> CLabel +mkFinalizerStubLabel mod s = ModuleLabel mod (MLK_Finalizer (LexicalFastString s)) + +mkFinalizerArrayLabel :: Module -> CLabel +mkFinalizerArrayLabel mod = ModuleLabel mod MLK_FinalizerArray + +mkAsmTempLabel :: Uniquable a => a -> CLabel +mkAsmTempLabel a = AsmTempLabel (getUnique a) + +mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel +mkAsmTempDerivedLabel = AsmTempDerivedLabel + +mkAsmTempEndLabel :: CLabel -> CLabel +mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end") + +-- | A label indicating the end of a procedure. +mkAsmTempProcEndLabel :: CLabel -> CLabel +mkAsmTempProcEndLabel l = mkAsmTempDerivedLabel l (fsLit "_proc_end") + +-- | Construct a label for a DWARF Debug Information Entity (DIE) +-- describing another symbol. +mkAsmTempDieLabel :: CLabel -> CLabel +mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die") + +-- ----------------------------------------------------------------------------- +-- Convert between different kinds of label + +toClosureLbl :: Platform -> CLabel -> CLabel +toClosureLbl platform lbl = case lbl of + IdLabel n c _ -> IdLabel n c Closure + CmmLabel m ext str _ -> CmmLabel m ext str CmmClosure + _ -> pprPanic "toClosureLbl" (pprDebugCLabel platform lbl) + +toSlowEntryLbl :: Platform -> CLabel -> CLabel +toSlowEntryLbl platform lbl = case lbl of + IdLabel n _ BlockInfoTable -> pprPanic "toSlowEntryLbl" (ppr n) + IdLabel n c _ -> IdLabel n c Slow + _ -> pprPanic "toSlowEntryLbl" (pprDebugCLabel platform lbl) + +toEntryLbl :: Platform -> CLabel -> CLabel +toEntryLbl platform lbl = case lbl of + IdLabel n c LocalInfoTable -> IdLabel n c LocalEntry + IdLabel n c (ConInfoTable k) -> IdLabel n c (ConEntry k) + + IdLabel n _ BlockInfoTable -> mkLocalBlockLabel (nameUnique n) + -- See Note [Proc-point local block entry-points]. + IdLabel n c _ -> IdLabel n c Entry + CmmLabel m ext str CmmInfo -> CmmLabel m ext str CmmEntry + CmmLabel m ext str CmmRetInfo -> CmmLabel m ext str CmmRet + _ -> pprPanic "toEntryLbl" (pprDebugCLabel platform lbl) + +-- | Generate a CmmProc delimiter label from the actual entry label. +-- +-- This delimiter label might be the entry label itself, except when the entry +-- label is a LocalBlockLabel. If we reused the entry label to delimit the proc, +-- we would generate redundant labels (see #22792) +toProcDelimiterLbl :: CLabel -> CLabel +toProcDelimiterLbl lbl = case lbl of + LocalBlockLabel {} -> mkAsmTempDerivedLabel lbl (fsLit "_entry") + _ -> lbl + +toInfoLbl :: Platform -> CLabel -> CLabel +toInfoLbl platform lbl = case lbl of + IdLabel n c LocalEntry -> IdLabel n c LocalInfoTable + IdLabel n c (ConEntry k) -> IdLabel n c (ConInfoTable k) + + IdLabel n c _ -> IdLabel n c InfoTable + CmmLabel m ext str CmmEntry -> CmmLabel m ext str CmmInfo + CmmLabel m ext str CmmRet -> CmmLabel m ext str CmmRetInfo + _ -> pprPanic "CLabel.toInfoLbl" (pprDebugCLabel platform lbl) + +hasHaskellName :: CLabel -> Maybe Name +hasHaskellName (IdLabel n _ _) = Just n +hasHaskellName _ = Nothing + +hasIdLabelInfo :: CLabel -> Maybe IdLabelInfo +hasIdLabelInfo (IdLabel _ _ l) = Just l +hasIdLabelInfo _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Does a CLabel's referent itself refer to a CAF? +hasCAF :: CLabel -> Bool +hasCAF (IdLabel _ _ (IdTickyInfo TickyRednCounts)) = False -- See Note [ticky for LNE] +hasCAF (IdLabel _ MayHaveCafRefs _) = True +hasCAF (RtsLabel RtsUnpackCStringInfoTable) = True +hasCAF (RtsLabel RtsUnpackCStringUtf8InfoTable) = True + -- The info table stg_MK_STRING_info is for thunks +hasCAF _ = False + +-- Note [ticky for LNE] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- Until 14 Feb 2013, every ticky counter was associated with a +-- closure. Thus, ticky labels used IdLabel. It is odd that +-- GHC.Cmm.Info.Build.cafTransfers would consider such a ticky label +-- reason to add the name to the CAFEnv (and thus eventually the SRT), +-- but it was harmless because the ticky was only used if the closure +-- was also. +-- +-- Since we now have ticky counters for LNEs, it is no longer the case +-- that every ticky counter has an actual closure. So I changed the +-- generation of ticky counters' CLabels to not result in their +-- associated id ending up in the SRT. +-- +-- NB IdLabel is still appropriate for ticky ids (as opposed to +-- CmmLabel) because the LNE's counter is still related to an .hs Id, +-- that Id just isn't for a proper closure. + +-- ----------------------------------------------------------------------------- +-- Does a CLabel need declaring before use or not? +-- +-- See wiki:commentary/compiler/backends/ppr-c#prototypes + +needsCDecl :: CLabel -> Bool + -- False <=> it's pre-declared; don't bother + -- don't bother declaring Bitmap labels, we always make sure + -- they are defined before use. +needsCDecl (SRTLabel _) = True +needsCDecl (LargeBitmapLabel _) = False +needsCDecl (IdLabel _ _ _) = True +needsCDecl (LocalBlockLabel _) = True + +needsCDecl (StringLitLabel _) = False +needsCDecl (AsmTempLabel _) = False +needsCDecl (AsmTempDerivedLabel _ _) = False +needsCDecl (RtsLabel _) = False + +needsCDecl (CmmLabel pkgId (NeedExternDecl external) _ _) + -- local labels mustn't have it + | not external = False + + -- Prototypes for labels defined in the runtime system are imported + -- into HC files via rts/include/Stg.h. + | pkgId == rtsUnitId = False + + -- For other labels we inline one into the HC file directly. + | otherwise = True + +needsCDecl l@(ForeignLabel{}) = not (isLibcFun l) +needsCDecl (CC_Label _) = True +needsCDecl (CCS_Label _) = True +needsCDecl (IPE_Label {}) = True +needsCDecl (ModuleLabel _ kind) = modLabelNeedsCDecl kind +needsCDecl (HpcTicksLabel _) = True +needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel" +needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel" +needsCDecl (DeadStripPreventer {}) = panic "needsCDecl DeadStripPreventer" + +modLabelNeedsCDecl :: ModuleLabelKind -> Bool +-- Code for finalizers and initializers are emitted in stub objects +modLabelNeedsCDecl (MLK_Initializer _) = True +modLabelNeedsCDecl (MLK_Finalizer _) = True +modLabelNeedsCDecl MLK_IPEBuffer = True +-- The finalizer and initializer arrays are emitted in the code of the module +modLabelNeedsCDecl MLK_InitializerArray = False +modLabelNeedsCDecl MLK_FinalizerArray = False + +-- | If a label is a local block label then return just its 'BlockId', otherwise +-- 'Nothing'. +maybeLocalBlockLabel :: CLabel -> Maybe BlockId +maybeLocalBlockLabel (LocalBlockLabel uq) = Just $ mkBlockId uq +maybeLocalBlockLabel _ = Nothing + + +-- | Check whether a label corresponds to a C function that has +-- a prototype in a system header somewhere, or is built-in +-- to the C compiler. For these labels we avoid generating our +-- own C prototypes. +isLibcFun :: CLabel -> Bool +isLibcFun (ForeignLabel fs _ _) = fs `elementOfUniqSet` libc_funs +isLibcFun _ = False + +libc_funs :: UniqSet FastString +libc_funs = mkUniqSet [ + --------------------- + -- Math functions + --------------------- + + -- _ISOC99_SOURCE + (fsLit "acos"), (fsLit "acosf"), (fsLit "acosh"), + (fsLit "acoshf"), (fsLit "acoshl"), (fsLit "acosl"), + (fsLit "asin"), (fsLit "asinf"), (fsLit "asinl"), + (fsLit "asinh"), (fsLit "asinhf"), (fsLit "asinhl"), + (fsLit "atan"), (fsLit "atanf"), (fsLit "atanl"), + (fsLit "atan2"), (fsLit "atan2f"), (fsLit "atan2l"), + (fsLit "atanh"), (fsLit "atanhf"), (fsLit "atanhl"), + (fsLit "cbrt"), (fsLit "cbrtf"), (fsLit "cbrtl"), + (fsLit "ceil"), (fsLit "ceilf"), (fsLit "ceill"), + (fsLit "copysign"), (fsLit "copysignf"), (fsLit "copysignl"), + (fsLit "cos"), (fsLit "cosf"), (fsLit "cosl"), + (fsLit "cosh"), (fsLit "coshf"), (fsLit "coshl"), + (fsLit "erf"), (fsLit "erff"), (fsLit "erfl"), + (fsLit "erfc"), (fsLit "erfcf"), (fsLit "erfcl"), + (fsLit "exp"), (fsLit "expf"), (fsLit "expl"), + (fsLit "exp2"), (fsLit "exp2f"), (fsLit "exp2l"), + (fsLit "expm1"), (fsLit "expm1f"), (fsLit "expm1l"), + (fsLit "fabs"), (fsLit "fabsf"), (fsLit "fabsl"), + (fsLit "fdim"), (fsLit "fdimf"), (fsLit "fdiml"), + (fsLit "floor"), (fsLit "floorf"), (fsLit "floorl"), + (fsLit "fma"), (fsLit "fmaf"), (fsLit "fmal"), + (fsLit "fmax"), (fsLit "fmaxf"), (fsLit "fmaxl"), + (fsLit "fmin"), (fsLit "fminf"), (fsLit "fminl"), + (fsLit "fmod"), (fsLit "fmodf"), (fsLit "fmodl"), + (fsLit "frexp"), (fsLit "frexpf"), (fsLit "frexpl"), + (fsLit "hypot"), (fsLit "hypotf"), (fsLit "hypotl"), + (fsLit "ilogb"), (fsLit "ilogbf"), (fsLit "ilogbl"), + (fsLit "ldexp"), (fsLit "ldexpf"), (fsLit "ldexpl"), + (fsLit "lgamma"), (fsLit "lgammaf"), (fsLit "lgammal"), + (fsLit "llrint"), (fsLit "llrintf"), (fsLit "llrintl"), + (fsLit "llround"), (fsLit "llroundf"), (fsLit "llroundl"), + (fsLit "log"), (fsLit "logf"), (fsLit "logl"), + (fsLit "log10l"), (fsLit "log10"), (fsLit "log10f"), + (fsLit "log1pl"), (fsLit "log1p"), (fsLit "log1pf"), + (fsLit "log2"), (fsLit "log2f"), (fsLit "log2l"), + (fsLit "logb"), (fsLit "logbf"), (fsLit "logbl"), + (fsLit "lrint"), (fsLit "lrintf"), (fsLit "lrintl"), + (fsLit "lround"), (fsLit "lroundf"), (fsLit "lroundl"), + (fsLit "modf"), (fsLit "modff"), (fsLit "modfl"), + (fsLit "nan"), (fsLit "nanf"), (fsLit "nanl"), + (fsLit "nearbyint"), (fsLit "nearbyintf"), (fsLit "nearbyintl"), + (fsLit "nextafter"), (fsLit "nextafterf"), (fsLit "nextafterl"), + (fsLit "nexttoward"), (fsLit "nexttowardf"), (fsLit "nexttowardl"), + (fsLit "pow"), (fsLit "powf"), (fsLit "powl"), + (fsLit "remainder"), (fsLit "remainderf"), (fsLit "remainderl"), + (fsLit "remquo"), (fsLit "remquof"), (fsLit "remquol"), + (fsLit "rint"), (fsLit "rintf"), (fsLit "rintl"), + (fsLit "round"), (fsLit "roundf"), (fsLit "roundl"), + (fsLit "scalbln"), (fsLit "scalblnf"), (fsLit "scalblnl"), + (fsLit "scalbn"), (fsLit "scalbnf"), (fsLit "scalbnl"), + (fsLit "sin"), (fsLit "sinf"), (fsLit "sinl"), + (fsLit "sinh"), (fsLit "sinhf"), (fsLit "sinhl"), + (fsLit "sqrt"), (fsLit "sqrtf"), (fsLit "sqrtl"), + (fsLit "tan"), (fsLit "tanf"), (fsLit "tanl"), + (fsLit "tanh"), (fsLit "tanhf"), (fsLit "tanhl"), + (fsLit "tgamma"), (fsLit "tgammaf"), (fsLit "tgammal"), + (fsLit "trunc"), (fsLit "truncf"), (fsLit "truncl"), + -- ISO C 99 also defines these function-like macros in math.h: + -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater, + -- isgreaterequal, isless, islessequal, islessgreater, isunordered + + -- additional symbols from _BSD_SOURCE + (fsLit "drem"), (fsLit "dremf"), (fsLit "dreml"), + (fsLit "finite"), (fsLit "finitef"), (fsLit "finitel"), + (fsLit "gamma"), (fsLit "gammaf"), (fsLit "gammal"), + (fsLit "isinf"), (fsLit "isinff"), (fsLit "isinfl"), + (fsLit "isnan"), (fsLit "isnanf"), (fsLit "isnanl"), + (fsLit "j0"), (fsLit "j0f"), (fsLit "j0l"), + (fsLit "j1"), (fsLit "j1f"), (fsLit "j1l"), + (fsLit "jn"), (fsLit "jnf"), (fsLit "jnl"), + (fsLit "lgamma_r"), (fsLit "lgammaf_r"), (fsLit "lgammal_r"), + (fsLit "scalb"), (fsLit "scalbf"), (fsLit "scalbl"), + (fsLit "significand"), (fsLit "significandf"), (fsLit "significandl"), + (fsLit "y0"), (fsLit "y0f"), (fsLit "y0l"), + (fsLit "y1"), (fsLit "y1f"), (fsLit "y1l"), + (fsLit "yn"), (fsLit "ynf"), (fsLit "ynl"), + + -- These functions are described in IEEE Std 754-2008 - + -- Standard for Floating-Point Arithmetic and ISO/IEC TS 18661 + (fsLit "nextup"), (fsLit "nextupf"), (fsLit "nextupl"), + (fsLit "nextdown"), (fsLit "nextdownf"), (fsLit "nextdownl") + ] + +-- ----------------------------------------------------------------------------- +-- | Is a CLabel visible outside this object file or not? +-- From the point of view of the code generator, a name is +-- externally visible if it has to be declared as exported +-- in the .o file's symbol table; that is, made non-static. +externallyVisibleCLabel :: CLabel -> Bool -- not C "static" +externallyVisibleCLabel (StringLitLabel _) = False +externallyVisibleCLabel (AsmTempLabel _) = False +externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False +externallyVisibleCLabel (RtsLabel _) = True +externallyVisibleCLabel (LocalBlockLabel _) = False +externallyVisibleCLabel (CmmLabel _ _ _ _) = True +externallyVisibleCLabel (ForeignLabel{}) = True +externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info +externallyVisibleCLabel (CC_Label _) = True +externallyVisibleCLabel (CCS_Label _) = True +externallyVisibleCLabel (IPE_Label {}) = True +externallyVisibleCLabel (ModuleLabel {}) = True +externallyVisibleCLabel (DynamicLinkerLabel _ _) = False +externallyVisibleCLabel (HpcTicksLabel _) = True +externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (SRTLabel _) = False +externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel" +externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer" + +externallyVisibleIdLabel :: IdLabelInfo -> Bool +externallyVisibleIdLabel LocalInfoTable = False +externallyVisibleIdLabel LocalEntry = False +externallyVisibleIdLabel BlockInfoTable = False +externallyVisibleIdLabel _ = True + +-- ----------------------------------------------------------------------------- +-- Finding the "type" of a CLabel + +-- For generating correct types in label declarations: + +data CLabelType + = CodeLabel -- Address of some executable instructions + | DataLabel -- Address of data, not a GC ptr + | GcPtrLabel -- Address of a (presumably static) GC object + +isCFunctionLabel :: CLabel -> Bool +isCFunctionLabel lbl = case labelType lbl of + CodeLabel -> True + _other -> False + +isGcPtrLabel :: CLabel -> Bool +isGcPtrLabel lbl = case labelType lbl of + GcPtrLabel -> True + _other -> False + + +-- | Work out the general type of data at the address of this label +-- whether it be code, data, or static GC object. +labelType :: CLabel -> CLabelType +labelType (IdLabel _ _ info) = idInfoLabelType info +labelType (CmmLabel _ _ _ CmmData) = DataLabel +labelType (CmmLabel _ _ _ CmmClosure) = GcPtrLabel +labelType (CmmLabel _ _ _ CmmCode) = CodeLabel +labelType (CmmLabel _ _ _ CmmInfo) = DataLabel +labelType (CmmLabel _ _ _ CmmEntry) = CodeLabel +labelType (CmmLabel _ _ _ CmmPrimCall) = CodeLabel +labelType (CmmLabel _ _ _ CmmRetInfo) = DataLabel +labelType (CmmLabel _ _ _ CmmRet) = CodeLabel +labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel +labelType (RtsLabel (RtsSelectorEntry _ _)) = CodeLabel +labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel +labelType (RtsLabel (RtsApEntry _ _)) = CodeLabel +labelType (RtsLabel (RtsApFast _)) = CodeLabel +labelType (RtsLabel RtsUnpackCStringInfoTable) = DataLabel +labelType (RtsLabel RtsUnpackCStringUtf8InfoTable) + = DataLabel +labelType (RtsLabel (RtsPrimOp _)) = CodeLabel +labelType (RtsLabel (RtsSlowFastTickyCtr _)) = DataLabel +labelType (LocalBlockLabel _) = CodeLabel +labelType (SRTLabel _) = DataLabel +labelType (ForeignLabel _ _ IsFunction) = CodeLabel +labelType (ForeignLabel _ _ IsData) = DataLabel +labelType (AsmTempLabel _) = panic "labelType(AsmTempLabel)" +labelType (AsmTempDerivedLabel _ _) = panic "labelType(AsmTempDerivedLabel)" +labelType (StringLitLabel _) = DataLabel +labelType (CC_Label _) = DataLabel +labelType (CCS_Label _) = DataLabel +labelType (IPE_Label {}) = DataLabel +labelType (ModuleLabel _ kind) = moduleLabelKindType kind +labelType (DynamicLinkerLabel _ _) = DataLabel -- Is this right? +labelType PicBaseLabel = DataLabel +labelType (DeadStripPreventer _) = DataLabel +labelType (HpcTicksLabel _) = DataLabel +labelType (LargeBitmapLabel _) = DataLabel + +moduleLabelKindType :: ModuleLabelKind -> CLabelType +moduleLabelKindType kind = + case kind of + MLK_Initializer _ -> CodeLabel + MLK_InitializerArray -> DataLabel + MLK_Finalizer _ -> CodeLabel + MLK_FinalizerArray -> DataLabel + MLK_IPEBuffer -> DataLabel + +idInfoLabelType :: IdLabelInfo -> CLabelType +idInfoLabelType info = + case info of + InfoTable -> DataLabel + LocalInfoTable -> DataLabel + BlockInfoTable -> DataLabel + Closure -> GcPtrLabel + ConInfoTable {} -> DataLabel + ClosureTable -> DataLabel + IdTickyInfo{} -> DataLabel + Bytes -> DataLabel + _ -> CodeLabel + + +-- ----------------------------------------------------------------------------- + +-- | Is a 'CLabel' defined in the current module being compiled? +-- +-- Sometimes we can optimise references within a compilation unit in ways that +-- we couldn't for inter-module references. This provides a conservative +-- estimate of whether a 'CLabel' lives in the current module. +isLocalCLabel :: Module -> CLabel -> Bool +isLocalCLabel this_mod lbl = + case lbl of + IdLabel name _ _ + | isInternalName name -> True + | otherwise -> nameModule name == this_mod + LocalBlockLabel _ -> True + _ -> False + +-- ----------------------------------------------------------------------------- + +-- | Does a 'CLabel' need dynamic linkage? +-- +-- When referring to data in code, we need to know whether +-- that data resides in a DLL or not. [Win32 only.] +-- @labelDynamic@ returns @True@ if the label is located +-- in a DLL, be it a data reference or not. +labelDynamic :: Module -> Platform -> Bool -> CLabel -> Bool +labelDynamic this_mod platform external_dynamic_refs lbl = + case lbl of + -- is the RTS in a DLL or not? + RtsLabel _ -> + external_dynamic_refs && (this_unit /= rtsUnitId) + + IdLabel n _ _ -> + external_dynamic_refs && isDynLinkName platform this_mod n + + -- When compiling in the "dyn" way, each package is to be linked into + -- its own shared library. + CmmLabel lbl_unit _ _ _ + | os == OSMinGW32 -> external_dynamic_refs && (this_unit /= lbl_unit) + | otherwise -> external_dynamic_refs + + LocalBlockLabel _ -> False + + ForeignLabel _ source _ -> + if os == OSMinGW32 + then case source of + -- Foreign label is in some un-named foreign package (or DLL). + ForeignLabelInExternalPackage -> True + + -- Foreign label is linked into the same package as the + -- source file currently being compiled. + ForeignLabelInThisPackage -> False + + -- Foreign label is in some named package. + -- When compiling in the "dyn" way, each package is to be + -- linked into its own DLL. + ForeignLabelInPackage pkgId -> + external_dynamic_refs && (this_unit /= pkgId) + + else -- On Mac OS X and on ELF platforms, false positives are OK, + -- so we claim that all foreign imports come from dynamic + -- libraries + True + + CC_Label cc -> + external_dynamic_refs && not (ccFromThisModule cc this_mod) + + -- CCS_Label always contains a CostCentre defined in the current module + CCS_Label _ -> False + IPE_Label {} -> True + + HpcTicksLabel m -> + external_dynamic_refs && this_mod /= m + + -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. + _ -> False + where + os = platformOS platform + this_unit = toUnitId (moduleUnit this_mod) + +----------------------------------------------------------------------------- +-- Printing out CLabels. + +{- +Convention: + + _ + +where is _ for external names and for +internal names. is one of the following: + + info Info table + srt Static reference table + entry Entry code (function, closure) + slow Slow entry code (if any) + ret Direct return address + vtbl Vector table + _alt Case alternative (tag n) + dflt Default case alternative + btm Large bitmap vector + closure Static closure + con_entry Dynamic Constructor entry code + con_info Dynamic Constructor info table + static_entry Static Constructor entry code + static_info Static Constructor info table + sel_info Selector info table + sel_entry Selector entry code + cc Cost centre + ccs Cost centre stack + +Many of these distinctions are only for documentation reasons. For +example, _ret is only distinguished from _entry to make it easy to +tell whether a code fragment is a return point or a closure/function +entry. + +Note [Closure and info labels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a function 'foo, we have: + foo_info : Points to the info table describing foo's closure + (and entry code for foo with tables next to code) + foo_closure : Static (no-free-var) closure only: + points to the statically-allocated closure + +For a data constructor (such as Just or Nothing), we have: + Just_con_info: Info table for the data constructor itself + the first word of a heap-allocated Just + Just_info: Info table for the *worker function*, an + ordinary Haskell function of arity 1 that + allocates a (Just x) box: + Just = \x -> Just x + Just_entry: The entry code for the worker function + Just_closure: The closure for this worker + + Nothing_closure: a statically allocated closure for Nothing + Nothing_static_info: info table for Nothing_closure + +All these must be exported symbol, EXCEPT Just_info. We don't need to +export this because in other modules we either have + * A reference to 'Just'; use Just_closure + * A saturated call 'Just x'; allocate using Just_con_info +Not exporting these Just_info labels reduces the number of symbols +somewhat. + +Note [Bytes label] +~~~~~~~~~~~~~~~~~~ +For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which +points to a static data block containing the content of the literal. + +Note [Proc-point local block entry-points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A label for a proc-point local block entry-point has no "_entry" suffix. With +`infoTblLbl` we derive an info table label from a proc-point block ID. If +we convert such an info table label into an entry label we must produce +the label without an "_entry" suffix. So an info table label records +the fact that it was derived from a block ID in `IdLabelInfo` as +`BlockInfoTable`. + +The info table label and the local block label are both local labels +and are not externally visible. + +Note [Bangs in CLabel] +~~~~~~~~~~~~~~~~~~~~~~ +There are some carefully placed strictness annotations in this module, +which were discovered in !5226 to significantly reduce compile-time +allocation. Take care if you want to remove them! + +-} + +-- | Style of label pretty-printing. +-- +-- When we produce C sources or headers, we have to take into account +-- that C compilers transform C labels when they convert them into +-- symbols. For example, they can add prefixes (e.g., "_" on Darwin). +-- So we provide two ways to pretty-print CLabels: C style or Asm +-- style. +-- +data LabelStyle + = CStyle -- ^ C label style (used by C and LLVM backends) + | AsmStyle -- ^ Asm label style (used by NCG backend) + +pprAsmLabel :: IsLine doc => Platform -> CLabel -> doc +pprAsmLabel platform lbl = pprCLabelStyle platform AsmStyle lbl +{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> SDoc #-} +{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +pprCLabel :: IsLine doc => Platform -> CLabel -> doc +pprCLabel platform lbl = pprCLabelStyle platform CStyle lbl +{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> SDoc #-} +{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +instance OutputableP Platform CLabel where + {-# INLINE pdoc #-} -- see Note [Bangs in CLabel] + pdoc !platform lbl = getPprStyle $ \pp_sty -> + case pp_sty of + PprDump{} -> pprCLabel platform lbl + _ -> let lbl_doc = (pprCLabel platform lbl) + in pprTraceUserWarning (text "Labels in code should be printed with pprCLabel or pprAsmLabel" <> lbl_doc) lbl_doc + +pprCLabelStyle :: forall doc. IsLine doc => Platform -> LabelStyle -> CLabel -> doc +pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel] + let + !use_leading_underscores = platformLeadingUnderscore platform + + -- some platform (e.g. Darwin) require a leading "_" for exported asm + -- symbols + maybe_underscore :: doc -> doc + maybe_underscore doc = case sty of + AsmStyle | use_leading_underscores -> pp_cSEP <> doc + _ -> doc + + tempLabelPrefixOrUnderscore :: doc + tempLabelPrefixOrUnderscore = case sty of + AsmStyle -> asmTempLabelPrefix platform + CStyle -> char '_' + + + in case lbl of + LocalBlockLabel u -> case sty of + AsmStyle -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u + CStyle -> tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u + + AsmTempLabel u + -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u + + AsmTempDerivedLabel l suf + -- we print a derived label, so we just print the parent label + -- recursively. However we don't want to print the temp prefix (e.g. + -- ".L") twice, so we must explicitely handle these cases. + -> let skipTempPrefix = \case + AsmTempLabel u -> pprUniqueAlways u + AsmTempDerivedLabel l suf -> skipTempPrefix l <> ftext suf + LocalBlockLabel u -> pprUniqueAlways u + lbl -> pprAsmLabel platform lbl + in + asmTempLabelPrefix platform + <> skipTempPrefix l + <> ftext suf + + DynamicLinkerLabel info lbl + -> pprDynamicLinkerAsmLabel platform info (pprAsmLabel platform lbl) + + PicBaseLabel + -> text "1b" + + DeadStripPreventer lbl + -> + {- + `lbl` can be temp one but we need to ensure that dsp label will stay + in the final binary so we prepend non-temp prefix ("dsp_") and + optional `_` (underscore) because this is how you mark non-temp symbols + on some platforms (Darwin) + -} + maybe_underscore $ text "dsp_" <> pprCLabelStyle platform sty lbl <> text "_dsp" + + StringLitLabel u + -> maybe_underscore $ pprUniqueAlways u <> text "_str" + + ForeignLabel fs _ _ + -> maybe_underscore $ ftext fs + + IdLabel name _cafs flavor -> case sty of + AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor + where + isRandomGenerated = not (isExternalName name) + internalNamePrefix = + if isRandomGenerated + then asmTempLabelPrefix platform + else empty + CStyle -> pprName name <> ppIdFlavor flavor + + SRTLabel u + -> maybe_underscore $ tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt" + + RtsLabel (RtsApFast (NonDetFastString str)) + -> maybe_underscore $ ftext str <> text "_fast" + + RtsLabel (RtsSelectorInfoTable upd_reqd offset) + -> maybe_underscore $ hcat [ text "stg_sel_", int offset + , if upd_reqd + then text "_upd_info" + else text "_noupd_info" + ] + + RtsLabel (RtsSelectorEntry upd_reqd offset) + -> maybe_underscore $ hcat [ text "stg_sel_", int offset + , if upd_reqd + then text "_upd_entry" + else text "_noupd_entry" + ] + + RtsLabel (RtsApInfoTable upd_reqd arity) + -> maybe_underscore $ hcat [ text "stg_ap_", int arity + , if upd_reqd + then text "_upd_info" + else text "_noupd_info" + ] + + RtsLabel (RtsApEntry upd_reqd arity) + -> maybe_underscore $ hcat [ text "stg_ap_", int arity + , if upd_reqd + then text "_upd_entry" + else text "_noupd_entry" + ] + + RtsLabel (RtsPrimOp primop) + -> maybe_underscore $ text "stg_" <> pprPrimOp primop + + RtsLabel (RtsSlowFastTickyCtr pat) + -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr" + + RtsLabel RtsUnpackCStringInfoTable + -> maybe_underscore $ text "stg_unpack_cstring_info" + RtsLabel RtsUnpackCStringUtf8InfoTable + -> maybe_underscore $ text "stg_unpack_cstring_utf8_info" + + LargeBitmapLabel u + -> maybe_underscore $ tempLabelPrefixOrUnderscore + <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm" + -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7') + -- until that gets resolved we'll just force them to start + -- with a letter so the label will be legal assembly code. + + HpcTicksLabel mod + -> maybe_underscore $ text "_hpc_tickboxes_" <> pprModule mod <> text "_hpc" + + CC_Label cc -> maybe_underscore $ pprCostCentre cc + CCS_Label ccs -> maybe_underscore $ pprCostCentreStack ccs + IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform l <> text "_" <> pprModule m <> text "_ipe") + ModuleLabel mod kind -> maybe_underscore $ pprModule mod <> text "_" <> pprModuleLabelKind kind + + CmmLabel _ _ fs CmmCode -> maybe_underscore $ ftext fs + CmmLabel _ _ fs CmmData -> maybe_underscore $ ftext fs + CmmLabel _ _ fs CmmPrimCall -> maybe_underscore $ ftext fs + CmmLabel _ _ fs CmmInfo -> maybe_underscore $ ftext fs <> text "_info" + CmmLabel _ _ fs CmmEntry -> maybe_underscore $ ftext fs <> text "_entry" + CmmLabel _ _ fs CmmRetInfo -> maybe_underscore $ ftext fs <> text "_info" + CmmLabel _ _ fs CmmRet -> maybe_underscore $ ftext fs <> text "_ret" + CmmLabel _ _ fs CmmClosure -> maybe_underscore $ ftext fs <> text "_closure" +{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc #-} +{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- Note [Internal proc labels] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Some tools (e.g. the `perf` utility on Linux) rely on the symbol table +-- for resolution of function names. To help these tools we provide the +-- (enabled by default) -fexpose-all-symbols flag which causes GHC to produce +-- symbols even for symbols with are internal to a module (although such +-- symbols will have only local linkage). +-- +-- Note that these labels are *not* referred to by code. They are strictly for +-- diagnostics purposes. +-- +-- To avoid confusion, it is desirable to add a module-qualifier to the +-- symbol name. However, the Name type's Internal constructor doesn't carry +-- knowledge of the current Module. Consequently, we have to pass this around +-- explicitly. + +-- | Generate a label for a procedure internal to a module (if +-- 'Opt_ExposeAllSymbols' is enabled). +-- See Note [Internal proc labels]. +ppInternalProcLabel :: IsLine doc + => Module -- ^ the current module + -> CLabel + -> Maybe doc -- ^ the internal proc label +ppInternalProcLabel this_mod (IdLabel nm _ flavour) + | isInternalName nm + = Just + $ text "_" <> pprModule this_mod + <> char '_' + <> ztext (zEncodeFS (occNameFS (occName nm))) + <> char '_' + <> pprUniqueAlways (getUnique nm) + <> ppIdFlavor flavour +ppInternalProcLabel _ _ = Nothing +{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe SDoc #-} +{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppIdFlavor :: IsLine doc => IdLabelInfo -> doc +ppIdFlavor x = pp_cSEP <> case x of + Closure -> text "closure" + InfoTable -> text "info" + LocalInfoTable -> text "info" + Entry -> text "entry" + LocalEntry -> text "entry" + Slow -> text "slow" + IdTickyInfo TickyRednCounts + -> text "ct" + IdTickyInfo (TickyInferedTag unique) + -> text "ct_inf_tag" <> char '_' <> pprUniqueAlways unique + ConEntry loc -> + case loc of + DefinitionSite -> text "con_entry" + UsageSite m n -> + pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_entry" + ConInfoTable k -> + case k of + DefinitionSite -> text "con_info" + UsageSite m n -> + pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_info" + ClosureTable -> text "closure_tbl" + Bytes -> text "bytes" + BlockInfoTable -> text "info" + +pp_cSEP :: IsLine doc => doc +pp_cSEP = char '_' + + +instance Outputable ForeignLabelSource where + ppr fs + = case fs of + ForeignLabelInPackage pkgId -> parens $ text "package: " <> ppr pkgId + ForeignLabelInThisPackage -> parens $ text "this package" + ForeignLabelInExternalPackage -> parens $ text "external package" + +-- ----------------------------------------------------------------------------- +-- Machine-dependent knowledge about labels. + +asmTempLabelPrefix :: IsLine doc => Platform -> doc -- for formatting labels +asmTempLabelPrefix !platform = case platformOS platform of + OSDarwin -> text "L" + OSAIX -> text "__L" -- follow IBM XL C's convention + _ -> text ".L" + +pprDynamicLinkerAsmLabel :: IsLine doc => Platform -> DynamicLinkerLabelInfo -> doc -> doc +pprDynamicLinkerAsmLabel !platform dllInfo ppLbl = + case platformOS platform of + OSDarwin + | platformArch platform == ArchX86_64 -> + case dllInfo of + CodeStub -> char 'L' <> ppLbl <> text "$stub" + SymbolPtr -> char 'L' <> ppLbl <> text "$non_lazy_ptr" + GotSymbolPtr -> ppLbl <> text "@GOTPCREL" + GotSymbolOffset -> ppLbl + | platformArch platform == ArchAArch64 -> ppLbl + | otherwise -> panic "pprDynamicLinkerAsmLabel" + + OSAIX -> + case dllInfo of + SymbolPtr -> text "LC.." <> ppLbl -- GCC's naming convention + _ -> panic "pprDynamicLinkerAsmLabel" + + _ | osElfTarget (platformOS platform) -> elfLabel + + OSMinGW32 -> + case dllInfo of + SymbolPtr -> text "__imp_" <> ppLbl + _ -> panic "pprDynamicLinkerAsmLabel" + + _ -> panic "pprDynamicLinkerAsmLabel" + where + elfLabel + | platformArch platform == ArchPPC + = case dllInfo of + CodeStub -> -- See Note [.LCTOC1 in PPC PIC code] + ppLbl <> text "+32768@plt" + SymbolPtr -> text ".LC_" <> ppLbl + _ -> panic "pprDynamicLinkerAsmLabel" + + | platformArch platform == ArchAArch64 + = ppLbl + + | platformArch platform == ArchRISCV64 + = ppLbl + + | platformArch platform == ArchLoongArch64 + = ppLbl + + | platformArch platform == ArchX86_64 + = case dllInfo of + CodeStub -> ppLbl <> text "@plt" + GotSymbolPtr -> ppLbl <> text "@gotpcrel" + GotSymbolOffset -> ppLbl + SymbolPtr -> text ".LC_" <> ppLbl + + | platformArch platform == ArchPPC_64 ELF_V1 + || platformArch platform == ArchPPC_64 ELF_V2 + = case dllInfo of + GotSymbolPtr -> text ".LC_" <> ppLbl <> text "@toc" + GotSymbolOffset -> ppLbl + SymbolPtr -> text ".LC_" <> ppLbl + _ -> panic "pprDynamicLinkerAsmLabel" + + | otherwise + = case dllInfo of + CodeStub -> ppLbl <> text "@plt" + SymbolPtr -> text ".LC_" <> ppLbl + GotSymbolPtr -> ppLbl <> text "@got" + GotSymbolOffset -> ppLbl <> text "@gotoff" + +-- Figure out whether `symbol` may serve as an alias +-- to `target` within one compilation unit. +-- +-- This is true if any of these holds: +-- * `target` is a module-internal haskell name. +-- * `target` is an exported name, but comes from the same +-- module as `symbol` +-- +-- These are sufficient conditions for establishing e.g. a +-- GNU assembly alias ('.equiv' directive). Sadly, there is +-- no such thing as an alias to an imported symbol (conf. +-- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/) +-- See Note [emit-time elimination of static indirections]. +-- +-- Precondition is that both labels represent the +-- same semantic value. + +mayRedirectTo :: CLabel -> CLabel -> Bool +mayRedirectTo symbol target + | Just nam <- haskellName + , staticClosureLabel + , isExternalName nam + , Just mod <- nameModule_maybe nam + , Just anam <- hasHaskellName symbol + , Just amod <- nameModule_maybe anam + = amod == mod + + | Just nam <- haskellName + , staticClosureLabel + , isInternalName nam + = True + + | otherwise = False + where staticClosureLabel = isStaticClosureLabel target + haskellName = hasHaskellName target + + +{- +Note [emit-time elimination of static indirections] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in #15155, certain static values are representationally +equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers). + + newtype A = A Int + {-# NOINLINE a #-} + a = A 42 + +a1_rYB :: Int +[GblId, Caf=NoCafRefs, Unf=OtherCon []] +a1_rYB = GHC.Types.I# 42# + +a [InlPrag=NOINLINE] :: A +[GblId, Unf=OtherCon []] +a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A) + +Formerly we created static indirections for these (IND_STATIC), which +consist of a statically allocated forwarding closure that contains +the (possibly tagged) indirectee. (See CMM/assembly below.) +This approach is suboptimal for two reasons: + (a) they occupy extra space, + (b) they need to be entered in order to obtain the indirectee, + thus they cannot be tagged. + +Fortunately there is a common case where static indirections can be +eliminated while emitting assembly (native or LLVM), viz. when the +indirectee is in the same module (object file) as the symbol that +points to it. In this case an assembly-level identification can +be created ('.equiv' directive), and as such the same object will +be assigned two names in the symbol table. Any of the identified +symbols can be referenced by a tagged pointer. + +Currently the 'mayRedirectTo' predicate will +give a clue whether a label can be equated with another, already +emitted, label (which can in turn be an alias). The general mechanics +is that we identify data (IND_STATIC closures) that are amenable +to aliasing while pretty-printing of assembly output, and emit the +'.equiv' directive instead of static data in such a case. + +Here is a sketch how the output is massaged: + + Consider +newtype A = A Int +{-# NOINLINE a #-} +a = A 42 -- I# 42# is the indirectee + -- 'a' is exported + + results in STG + +a1_rXq :: GHC.Types.Int +[GblId, Caf=NoCafRefs, Unf=OtherCon []] = + CCS_DONT_CARE GHC.Types.I#! [42#]; + +T15155.a [InlPrag=NOINLINE] :: T15155.A +[GblId, Unf=OtherCon []] = + CAF_ccs \ u [] a1_rXq; + + and CMM + +[section ""data" . a1_rXq_closure" { + a1_rXq_closure: + const GHC.Types.I#_con_info; + const 42; + }] + +[section ""data" . T15155.a_closure" { + T15155.a_closure: + const stg_IND_STATIC_info; + const a1_rXq_closure+1; + const 0; + const 0; + }] + +The emitted assembly is + +==== INDIRECTEE +a1_rXq_closure: -- module local haskell value + .quad GHC.Types.I#_con_info -- an Int + .quad 42 + +==== BEFORE +.globl T15155.a_closure -- exported newtype wrapped value +T15155.a_closure: + .quad stg_IND_STATIC_info -- the closure info + .quad a1_rXq_closure+1 -- indirectee ('+1' being the tag) + .quad 0 + .quad 0 + +==== AFTER +.globl T15155.a_closure -- exported newtype wrapped value +.equiv a1_rXq_closure,T15155.a_closure -- both are shared + +The transformation is performed because + T15155.a_closure `mayRedirectTo` a1_rXq_closure+1 +returns True. +-} + +-- | This type encodes the subset of 'CLabel' that occurs in C stubs of foreign +-- declarations for the purpose of serializing to interface files. +-- +-- See Note [Foreign stubs and TH bytecode linking] +data CStubLabel = + CStubLabel { + csl_is_initializer :: Bool, + csl_module :: Module, + csl_name :: FastString + } + +instance Outputable CStubLabel where + ppr CStubLabel {csl_is_initializer, csl_module, csl_name} = + text ini <+> ppr csl_module <> colon <> text (unpackFS csl_name) + where + ini = if csl_is_initializer then "initializer" else "finalizer" + +-- | Project the constructor 'ModuleLabel' out of 'CLabel' if it is an +-- initializer or finalizer. +cStubLabel :: CLabel -> Maybe CStubLabel +cStubLabel = \case + ModuleLabel csl_module label_kind -> do + (csl_is_initializer, csl_name) <- case label_kind of + MLK_Initializer (LexicalFastString s) -> Just (True, s) + MLK_Finalizer (LexicalFastString s) -> Just (False, s) + _ -> Nothing + Just (CStubLabel {csl_is_initializer, csl_module, csl_name}) + _ -> Nothing + +-- | Inject a 'CStubLabel' into a 'CLabel' as a 'ModuleLabel'. +fromCStubLabel :: CStubLabel -> CLabel +fromCStubLabel (CStubLabel {csl_is_initializer, csl_module, csl_name}) = + ModuleLabel csl_module (label_kind (LexicalFastString csl_name)) + where + label_kind = + if csl_is_initializer + then MLK_Initializer + else MLK_Finalizer + +-- | A utility for renaming uniques in CLabels to produce deterministic object. +-- Note that not all Uniques are mapped over. Only those that can be safely alpha +-- renamed, e.g. uniques of local symbols, but not of external ones. +-- See Note [Renaming uniques deterministically]. +mapInternalNonDetUniques :: Applicative m => (Unique -> m Unique) -> CLabel -> m CLabel +-- todo: Can we do less work here, e.g., do we really need to rename AsmTempLabel, LocalBlockLabel? +mapInternalNonDetUniques f x = case x of + IdLabel name cafInfo idLabelInfo + | not (isExternalName name) -> IdLabel . setNameUnique name <$> f (nameUnique name) <*> pure cafInfo <*> pure idLabelInfo + | otherwise -> pure x + cl@CmmLabel{} -> pure cl + RtsLabel rtsLblInfo -> pure $ RtsLabel rtsLblInfo + LocalBlockLabel unique -> LocalBlockLabel <$> f unique + fl@ForeignLabel{} -> pure fl + AsmTempLabel unique -> AsmTempLabel <$> f unique + AsmTempDerivedLabel clbl fs -> AsmTempDerivedLabel <$> mapInternalNonDetUniques f clbl <*> pure fs + StringLitLabel unique -> StringLitLabel <$> f unique + CC_Label cc -> pure $ CC_Label cc + CCS_Label ccs -> pure $ CCS_Label ccs + IPE_Label ipe@InfoProvEnt{infoTablePtr} -> + (\cl' -> IPE_Label ipe{infoTablePtr = cl'}) <$> mapInternalNonDetUniques f infoTablePtr + ml@ModuleLabel{} -> pure ml + DynamicLinkerLabel dlli clbl -> DynamicLinkerLabel dlli <$> mapInternalNonDetUniques f clbl + PicBaseLabel -> pure PicBaseLabel + DeadStripPreventer clbl -> DeadStripPreventer <$> mapInternalNonDetUniques f clbl + HpcTicksLabel mod -> pure $ HpcTicksLabel mod + SRTLabel unique -> SRTLabel <$> f unique + LargeBitmapLabel unique -> LargeBitmapLabel <$> f unique +-- This is called *a lot* if renaming Cmm uniques, and won't specialise without this pragma: +{-# INLINABLE mapInternalNonDetUniques #-} + diff --git a/GHC/Cmm/CLabel.hs-boot b/GHC/Cmm/CLabel.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Cmm/CLabel.hs-boot @@ -0,0 +1,8 @@ +module GHC.Cmm.CLabel where + +import GHC.Utils.Outputable +import GHC.Platform + +data CLabel + +pprCLabel :: IsLine doc => Platform -> CLabel -> doc diff --git a/GHC/Cmm/CallConv.hs b/GHC/Cmm/CallConv.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/CallConv.hs @@ -0,0 +1,324 @@ +module GHC.Cmm.CallConv ( + ParamLocation(..), + assignArgumentsPos, + assignStack, + realArgRegsCover, + allArgRegsCover +) where + +import GHC.Prelude + +import GHC.Cmm.Expr +import GHC.Cmm.Reg (GlobalArgRegs(..)) +import GHC.Runtime.Heap.Layout +import GHC.Cmm (Convention(..)) + +import GHC.Platform +import GHC.Platform.Reg.Class +import GHC.Platform.Profile +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Maybe ( maybeToList ) +import Data.List (nub) + +-- Calculate the 'GlobalReg' or stack locations for function call +-- parameters as used by the Cmm calling convention. + +data ParamLocation + = RegisterParam GlobalReg + | StackParam ByteOff + +instance Outputable ParamLocation where + ppr (RegisterParam g) = ppr g + ppr (StackParam p) = ppr p + +-- | +-- Given a list of arguments, and a function that tells their types, +-- return a list showing where each argument is passed +-- +assignArgumentsPos :: Profile + -> ByteOff -- stack offset to start with + -> Convention + -> (a -> CmmType) -- how to get a type from an arg + -> [a] -- args + -> ( + ByteOff -- bytes of stack args + , [(a, ParamLocation)] -- args and locations + ) + +assignArgumentsPos profile off conv arg_ty reps = (stk_off, assignments) + where + platform = profilePlatform profile + regs = case (reps, conv) of + (_, NativeNodeCall) -> getRegsWithNode platform + (_, NativeDirectCall) -> getRegsWithoutNode platform + ([_], NativeReturn) -> allRegs platform + (_, NativeReturn) -> getRegsWithNode platform + -- GC calling convention *must* put values in registers + (_, GC) -> allRegs platform + (_, Slow) -> nodeOnly + -- The calling conventions first assign arguments to registers, + -- then switch to the stack when we first run out of registers + -- (even if there are still available registers for args of a + -- different type). When returning an unboxed tuple, we also + -- separate the stack arguments by pointerhood. + (reg_assts, stk_args) = assign_regs [] reps regs + (stk_off, stk_assts) = assignStack platform off arg_ty stk_args + assignments = reg_assts ++ stk_assts + + assign_regs assts [] _ = (assts, []) + assign_regs assts (r:rs) regs | isVecType ty = vec + | isFloatType ty = float + | otherwise = int + where vec = case regs of + AvailRegs vs fs ds ls (s:ss) + | passVectorInReg w profile + -> let reg_class = case w of + W128 -> XmmReg + W256 -> YmmReg + W512 -> ZmmReg + _ -> panic "CmmCallConv.assignArgumentsPos: Invalid vector width" + in k (RegisterParam (reg_class s), AvailRegs vs fs ds ls ss) + _ -> (assts, r:rs) + float = case (w, regs) of + (W32, AvailRegs vs fs ds ls (s:ss)) + | passFloatInXmm -> k (RegisterParam (FloatReg s), AvailRegs vs fs ds ls ss) + (W32, AvailRegs vs (f:fs) ds ls ss) + | not passFloatInXmm -> k (RegisterParam f, AvailRegs vs fs ds ls ss) + (W64, AvailRegs vs fs ds ls (s:ss)) + | passFloatInXmm -> k (RegisterParam (DoubleReg s), AvailRegs vs fs ds ls ss) + (W64, AvailRegs vs fs (d:ds) ls ss) + | not passFloatInXmm -> k (RegisterParam d, AvailRegs vs fs ds ls ss) + _ -> (assts, (r:rs)) + int = case (w, regs) of + (W128, _) -> panic "W128 unsupported register type" + (_, AvailRegs (v:vs) fs ds ls ss) | widthInBits w <= widthInBits (wordWidth platform) + -> k (RegisterParam v, AvailRegs vs fs ds ls ss) + (_, AvailRegs vs fs ds (l:ls) ss) | widthInBits w > widthInBits (wordWidth platform) + -> k (RegisterParam l, AvailRegs vs fs ds ls ss) + _ -> (assts, (r:rs)) + k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' + ty = arg_ty r + w = typeWidth ty + passFloatInXmm = passFloatArgsInXmm platform + +passFloatArgsInXmm :: Platform -> Bool +passFloatArgsInXmm platform = + -- TODO: replace the following logic by casing on @registerArch (platformArch platform)@. + -- + -- This will mean we start saying "True" for AArch64, which the rest of the AArch64 + -- compilation pipeline will need to be able to handle (e.g. the AArch64 NCG). + case platformArch platform of + ArchX86_64 -> True + ArchX86 -> False + _ -> False + +-- We used to spill vector registers to the stack since the LLVM backend didn't +-- support vector registers in its calling convention. However, this has now +-- been fixed. This function remains only as a convenient way to re-enable +-- spilling when debugging code generation. +passVectorInReg :: Width -> Profile -> Bool +passVectorInReg _ _ = True + +assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a] + -> ( + ByteOff -- bytes of stack args + , [(a, ParamLocation)] -- args and locations + ) +assignStack platform offset arg_ty args = assign_stk offset [] (reverse args) + where + assign_stk offset assts [] = (offset, assts) + assign_stk offset assts (r:rs) + = assign_stk off' ((r, StackParam off') : assts) rs + where w = typeWidth (arg_ty r) + off' = offset + size + -- Stack arguments always take a whole number of words, we never + -- pack them unlike constructor fields. + size = roundUpToWords platform (widthInBytes w) + +----------------------------------------------------------------------------- +-- Local information about the registers available + +-- | Keep track of locally available registers. +data AvailRegs + = AvailRegs + { availVanillaRegs :: [GlobalReg] + -- ^ Available vanilla registers + , availFloatRegs :: [GlobalReg] + -- ^ Available float registers + , availDoubleRegs :: [GlobalReg] + -- ^ Available double registers + , availLongRegs :: [GlobalReg] + -- ^ Available long registers + , availXMMRegs :: [Int] + -- ^ Available vector XMM registers + } + +noAvailRegs :: AvailRegs +noAvailRegs = AvailRegs [] [] [] [] [] + +-- Vanilla registers can contain pointers, Ints, Chars. +-- Floats and doubles have separate register supplies. +-- +-- We take these register supplies from the *real* registers, i.e. those +-- that are guaranteed to map to machine registers. + +getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs +getRegsWithoutNode platform = + AvailRegs + { availVanillaRegs = filter (\r -> r /= node) (realVanillaRegs platform) + , availFloatRegs = realFloatRegs platform + , availDoubleRegs = realDoubleRegs platform + , availLongRegs = realLongRegs platform + , availXMMRegs = realXmmRegNos platform } + +-- getRegsWithNode uses R1/node even if it isn't a register +getRegsWithNode platform = + AvailRegs + { availVanillaRegs = if null (realVanillaRegs platform) + then [VanillaReg 1] + else realVanillaRegs platform + , availFloatRegs = realFloatRegs platform + , availDoubleRegs = realDoubleRegs platform + , availLongRegs = realLongRegs platform + , availXMMRegs = realXmmRegNos platform } + +allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg] +allVanillaRegs :: Platform -> [GlobalReg] +allXmmRegs :: Platform -> [Int] + +allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform)) +allFloatRegs platform = map FloatReg $ regList (pc_MAX_Float_REG (platformConstants platform)) +allDoubleRegs platform = map DoubleReg $ regList (pc_MAX_Double_REG (platformConstants platform)) +allLongRegs platform = map LongReg $ regList (pc_MAX_Long_REG (platformConstants platform)) +allXmmRegs platform = regList (pc_MAX_XMM_REG (platformConstants platform)) + +realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg] +realVanillaRegs :: Platform -> [GlobalReg] + +realVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Real_Vanilla_REG (platformConstants platform)) +realFloatRegs platform = map FloatReg $ regList (pc_MAX_Real_Float_REG (platformConstants platform)) +realDoubleRegs platform = map DoubleReg $ regList (pc_MAX_Real_Double_REG (platformConstants platform)) +realLongRegs platform = map LongReg $ regList (pc_MAX_Real_Long_REG (platformConstants platform)) + +realXmmRegNos :: Platform -> [Int] +realXmmRegNos platform + | isSse2Enabled platform || platformArch platform == ArchAArch64 + = regList (pc_MAX_Real_XMM_REG (platformConstants platform)) + | otherwise + = [] + +regList :: Int -> [Int] +regList n = [1 .. n] + +allRegs :: Platform -> AvailRegs +allRegs platform = + AvailRegs + { availVanillaRegs = allVanillaRegs platform + , availFloatRegs = allFloatRegs platform + , availDoubleRegs = allDoubleRegs platform + , availLongRegs = allLongRegs platform + , availXMMRegs = allXmmRegs platform } + +nodeOnly :: AvailRegs +nodeOnly = noAvailRegs { availVanillaRegs = [VanillaReg 1] } + +-- | A set of global registers that cover the machine registers used +-- for argument passing. +-- +-- See Note [realArgRegsCover]. +realArgRegsCover :: Platform + -> GlobalArgRegs + -- ^ which kinds of registers do we want to cover? + -> [GlobalReg] +realArgRegsCover platform argRegs + = realVanillaRegs platform + ++ realLongRegs platform + ++ concat + ( [ realFloatRegs platform | wantFP, not (passFloatArgsInXmm platform) ] + -- TODO: the line above is legacy logic, but removing it breaks + -- the bytecode interpreter on AArch64. Probably easy to fix. + -- AK: I believe this might be because we map REG_F1..4 and REG_D1..4 to different + -- machine registers on AArch64. + ++ [ realDoubleRegs platform | wantFP ] + ) + ++ [ mkVecReg i | mkVecReg <- maybeToList mbMkVecReg + , i <- realXmmRegNos platform ] + + where + wantFP = case registerArch (platformArch platform) of + Unified -> argRegs == SCALAR_ARG_REGS + Separate -> argRegs >= SCALAR_ARG_REGS + NoVectors -> argRegs >= SCALAR_ARG_REGS + mbMkVecReg = case registerArch (platformArch platform) of + Unified -> mb_xyzmm + Separate -> mb_xyzmm + NoVectors -> Nothing + mb_xyzmm = case argRegs of + V16_ARG_REGS -> Just XmmReg + V32_ARG_REGS -> Just YmmReg + V64_ARG_REGS -> Just ZmmReg + _ -> Nothing + +-- | Like "realArgRegsCover", but always includes the node. +-- +-- See Note [realArgRegsCover]. +allArgRegsCover :: Platform + -> GlobalArgRegs + -- ^ which kinds of registers do we want to cover? + -> [GlobalReg] +allArgRegsCover platform argRegs = + nub (node : realArgRegsCover platform argRegs) + where + node = VanillaReg 1 + +{- Note [realArgRegsCover] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In low-level Cmm, jumps must be annotated with a set of live registers, +allowing precise control of global STG register contents across function calls. +However, in some places (in particular in the RTS), the registers we want to +preserve depend on the *caller*. For example, if we intercept a function call +via a stack underflow frame, we want to preserve exactly those registers +containing function arguments. +Since we can't know exactly how many arguments the caller passed, we settle on +simply preserving all global regs which might be used for argument passing. +To do this, we specify a collection of registers that *covers* all the registers +we want to preserve; this is done by "realArgRegsCover". + +The situation is made somewhat tricky by the need to handle vector registers. +For example, on X86_64, the F, D, XMM, YMM, ZMM overlap in the following way + ┌─┬─┬───┬───────┬───────────────┐ + │F┆D┆XMM┆ YMM ┆ ZMM │ + └─┴─┴───┴───────┴───────────────┘ +where each register extends all the way to the left. + +Based on this register architecture, on X86_64 we might want to annotate a jump +in which we (might) want to preserve the contents of all argument-passing +registers with [R1, ..., R6, ZMM1, ..., ZMM6]. This, however, is not possible +in general, because preserving e.g. a ZMM register across a C call requires the +availability of the AVX-512F instruction set. If we did this, the RTS would +crash at runtime with an "invalid instruction" error on X86_64 machines which +do not support AVX-512F. + +Instead, we parametrise "realArgRegsCover" on the 'GlobalArgRegs' datatype, which +specifies which registers it is sufficient to preserve. For example, it might +suffice to only preserve general-purpose registers, or to only preserve up to +XMM (not YMM or ZMM). + +Then, to handle certain functions in the RTS such as "stack_underflow_frame", we +proceed by defining 4 variants, stack_underflow_frame_{d,v16,v32,v64}, which +respectively annotate the jump at the end of the function with SCALAR_ARG_REGS, +V16_ARG_REGS, V32_ARG_REGS and V64_ARG_REGS. Compiling these variants, in effect, +amounts to compiling "stack_underflow_frame" four times, once for each level of +vector support. Then, in the RTS, we dispatch at runtime based on the support +for vectors provided by the architecture on the current machine (see e.g. +'threadStackOverflow' and its 'switch (vectorSupportGlobalVar)'.) + +Note that, like in Note [AutoApply.cmm for vectors], it is **critical** that we +compile e.g. stack_underflow_frame_v64 with -mavx512f. If we don't, the LLVM +backend is liable to compile code using e.g. the ZMM1 STG register to uses of +X86 machine registers xmm1, xmm2, xmm3, xmm4, instead of just zmm1. This would +mean that LLVM produces ABI-incompatible code that would result in segfaults in +the RTS. +-} diff --git a/GHC/Cmm/CommonBlockElim.hs b/GHC/Cmm/CommonBlockElim.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/CommonBlockElim.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE GADTs #-} + +module GHC.Cmm.CommonBlockElim + ( elimCommonBlocks + ) +where + + +import GHC.Prelude hiding (iterate, succ, unzip, zip) + +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch (eqSwitchTargetWith) +import GHC.Cmm.ContFlowOpt + +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import Data.Functor.Classes (liftEq) +import Data.Maybe (mapMaybe) +import qualified Data.List as List +import Data.Word +import qualified Data.Map as M +import qualified GHC.Data.TrieMap as TM +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.Utils.Word64 (truncateWord64ToWord32) +import Control.Arrow (first, second) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE + +-- ----------------------------------------------------------------------------- +-- Eliminate common blocks + +-- If two blocks are identical except for the label on the first node, +-- then we can eliminate one of the blocks. To ensure that the semantics +-- of the program are preserved, we have to rewrite each predecessor of the +-- eliminated block to proceed with the block we keep. + +-- The algorithm iterates over the blocks in the graph, +-- checking whether it has seen another block that is equal modulo labels. +-- If so, then it adds an entry in a map indicating that the new block +-- is made redundant by the old block. +-- Otherwise, it is added to the useful blocks. + +-- To avoid comparing every block with every other block repeatedly, we group +-- them by +-- * a hash of the block, ignoring labels (explained below) +-- * the list of outgoing labels +-- The hash is invariant under relabeling, so we only ever compare within +-- the same group of blocks. +-- +-- The list of outgoing labels is updated as we merge blocks (that is why they +-- are not included in the hash, which we want to calculate only once). +-- +-- All in all, two blocks should never be compared if they have different +-- hashes, and at most once otherwise. Previously, we were slower, and people +-- rightfully complained: #10397 + +-- TODO: Use optimization fuel +elimCommonBlocks :: CmmGraph -> CmmGraph +elimCommonBlocks g = replaceLabels env $ copyTicks env g + where + env = iterate mapEmpty blocks_with_key + -- The order of blocks doesn't matter here. While we could use + -- revPostorder which drops unreachable blocks this is done in + -- ContFlowOpt already which runs before this pass. So we use + -- toBlockList since it is faster. + groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]] + blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups] + +-- Invariant: The blocks in the list are pairwise distinct +-- (so avoid comparing them again) +type DistinctBlocks = [CmmBlock] +type Key = [Label] +type Subst = LabelMap BlockId + +-- The outer list groups by hash. We retain this grouping throughout. +iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst +iterate subst blocks + | mapNull new_substs = subst + | otherwise = iterate subst' updated_blocks + where + grouped_blocks :: [[(Key, NonEmpty DistinctBlocks)]] + grouped_blocks = map groupByLabel blocks + + merged_blocks :: [[(Key, DistinctBlocks)]] + (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks + where + go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db)) + where + (new_subst2, db) = mergeBlockList subst dbs + + subst' = subst `mapUnion` new_substs + updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks + +-- Combine two lists of blocks. +-- While they are internally distinct they can still share common blocks. +mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks) +mergeBlocks subst existing new = go new + where + go [] = (mapEmpty, existing) + go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of + -- This block is a duplicate. Drop it, and add it to the substitution + Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs + -- This block is not a duplicate, keep it. + Nothing -> second (b:) $ go bs + +mergeBlockList :: Subst -> NonEmpty DistinctBlocks -> (Subst, DistinctBlocks) +mergeBlockList subst (b:|bs) = go mapEmpty b bs + where + go !new_subst1 b [] = (new_subst1, b) + go !new_subst1 b1 (b2:bs) = go new_subst b bs + where + (new_subst2, b) = mergeBlocks subst b1 b2 + new_subst = new_subst1 `mapUnion` new_subst2 + + +-- ----------------------------------------------------------------------------- +-- Hashing and equality on blocks + +-- Below here is mostly boilerplate: hashing blocks ignoring labels, +-- and comparing blocks modulo a label mapping. + +-- To speed up comparisons, we hash each basic block modulo jump labels. +-- The hashing is a bit arbitrary (the numbers are completely arbitrary), +-- but it should be fast and good enough. + +-- We want to get as many small buckets as possible, as comparing blocks is +-- expensive. So include as much as possible in the hash. Ideally everything +-- that is compared with (==) in eqBlockBodyWith. + +type HashCode = Int + +hash_block :: CmmBlock -> HashCode +hash_block block = + fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32)) + -- UniqFM doesn't like negative Ints + where hash_fst _ h = h + hash_mid m h = hash_node m + h `shiftL` 1 + hash_lst m h = hash_node m + h `shiftL` 1 + + hash_node :: CmmNode O x -> Word32 + hash_node n | dont_care n = 0 -- don't care + hash_node (CmmAssign r e) = hash_reg r + hash_e e + hash_node (CmmStore e e' _) = hash_e e + hash_e e' + hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as + hash_node (CmmBranch _) = 23 -- NB. ignore the label + hash_node (CmmCondBranch p _ _ _) = hash_e p + hash_node (CmmCall e _ _ _ _ _) = hash_e e + hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t + hash_node (CmmSwitch e _) = hash_e e + hash_node _ = error "hash_node: unknown Cmm node!" + + hash_reg :: CmmReg -> Word32 + hash_reg (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397 + hash_reg (CmmGlobal _) = 19 + + hash_e :: CmmExpr -> Word32 + hash_e (CmmLit l) = hash_lit l + hash_e (CmmLoad e _ _) = 67 + hash_e e + hash_e (CmmReg r) = hash_reg r + hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check + hash_e (CmmRegOff r i) = hash_reg r + cvt i + hash_e (CmmStackSlot _ _) = 13 + + hash_lit :: CmmLit -> Word32 + hash_lit (CmmInt i _) = fromInteger i + hash_lit (CmmFloat r _) = truncate r + hash_lit (CmmVec ls) = hash_list hash_lit ls + hash_lit (CmmLabel _) = 119 -- ugh + hash_lit (CmmLabelOff _ i) = cvt $ 199 + i + hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i + hash_lit (CmmBlock _) = 191 -- ugh + hash_lit (CmmHighStackMark) = cvt 313 + + hash_tgt (ForeignTarget e _) = hash_e e + hash_tgt (PrimTarget _) = 31 -- lots of these + + hash_list f = foldl' (\z x -> f x + z) (0::Word32) + + cvt = fromInteger . toInteger + + -- Since we are hashing, we can savely downcast Word64 to Word32 here. + -- Although a different hashing function may be more effective. + hash_unique :: Uniquable a => a -> Word32 + hash_unique = truncateWord64ToWord32 . getKey . getUnique + +-- | Ignore these node types for equality +dont_care :: CmmNode O x -> Bool +dont_care CmmComment {} = True +dont_care CmmTick {} = True +dont_care CmmUnwind {} = True +dont_care _other = False + +-- Utilities: equality and substitution on the graph. + +-- Given a map ``subst'' from BlockID -> BlockID, we define equality. +eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool +eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' +lookupBid :: LabelMap BlockId -> BlockId -> BlockId +lookupBid subst bid = case mapLookup bid subst of + Just bid -> lookupBid subst bid + Nothing -> bid + +-- Middle nodes and expressions can contain BlockIds, in particular in +-- CmmStackSlot and CmmBlock, so we have to use a special equality for +-- these. +-- +eqMiddleWith :: (BlockId -> BlockId -> Bool) + -> CmmNode O O -> CmmNode O O -> Bool +eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2) + = r1 == r2 && eqExprWith eqBid e1 e2 +eqMiddleWith eqBid (CmmStore l1 r1 _) (CmmStore l2 r2 _) + = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 +eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1) + (CmmUnsafeForeignCall t2 r2 a2) + = t1 == t2 && r1 == r2 && liftEq (eqExprWith eqBid) a1 a2 +eqMiddleWith _ _ _ = False + +eqExprWith :: (BlockId -> BlockId -> Bool) + -> CmmExpr -> CmmExpr -> Bool +eqExprWith eqBid = eq + where + CmmLit l1 `eq` CmmLit l2 = eqLit l1 l2 + CmmLoad e1 t1 a1 `eq` CmmLoad e2 t2 a2 = t1 `cmmEqType` t2 && e1 `eq` e2 && a1==a2 + CmmReg r1 `eq` CmmReg r2 = r1==r2 + CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2 + CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && liftEq eq es1 es2 + CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2 + _e1 `eq` _e2 = False + + eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2 + eqLit l1 l2 = l1 == l2 + + eqArea Old Old = True + eqArea (Young id1) (Young id2) = eqBid id1 id2 + eqArea _ _ = False + +-- Equality on the body of a block, modulo a function mapping block +-- IDs to block IDs. +eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool +eqBlockBodyWith eqBid block block' + {- + | equal = pprTrace "equal" (vcat [ppr block, ppr block']) True + | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False + -} + = equal + where (_,m,l) = blockSplit block + nodes = filter (not . dont_care) (blockToList m) + (_,m',l') = blockSplit block' + nodes' = filter (not . dont_care) (blockToList m') + + equal = liftEq (eqMiddleWith eqBid) nodes nodes' && + eqLastWith eqBid l l' + + +eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool +eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2 +eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) = + c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2 +eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) = + t1 == t2 && liftEq eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2 +eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) = + e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2 +eqLastWith _ _ _ = False + +-- | Given a block map, ensure that all "target" blocks are covered by +-- the same ticks as the respective "source" blocks. This not only +-- means copying ticks, but also adjusting tick scopes where +-- necessary. +copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph +copyTicks env g + | mapNull env = g + | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap + where -- Reverse block merge map + blockMap = toBlockMap g + revEnv = mapFoldlWithKey insertRev M.empty env + insertRev m k x = M.insertWith (const (k:)) x [k] m + -- Copy ticks and scopes into the given block + copyTo block = case M.lookup (entryLabel block) revEnv of + Nothing -> block + Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls + copy from to = + let ticks = blockTicks from + CmmEntry _ scp0 = firstNode from + (CmmEntry lbl scp1, code) = blockSplitHead to + in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead` + foldr blockCons code (map CmmTick ticks) + +-- Group by [Label] +-- See Note [Compressed TrieMap] in GHC.Core.Map.Expr about the usage of GenMap. +groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, NonEmpty DistinctBlocks)] +groupByLabel = + go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, NonEmpty DistinctBlocks)) + where + go !m [] = TM.foldTM (:) m [] + go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries + where --k' = map (getKey . getUnique) k + adjust Nothing = Just (k, pure v) + adjust (Just (_,vs)) = Just (k, v NE.<| vs) + +groupByInt :: (a -> Int) -> [a] -> [[a]] +groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs + -- See Note [Unique Determinism and code generation] + where + go m x = alterUFM addEntry m (f x) + where + addEntry xs = Just $! maybe [x] (x:) xs diff --git a/GHC/Cmm/Config.hs b/GHC/Cmm/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Config.hs @@ -0,0 +1,32 @@ +-- | Cmm compilation configuration + +{-# LANGUAGE DerivingStrategies #-} + +module GHC.Cmm.Config + ( CmmConfig(..) + , cmmPlatform + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Profile + + +data CmmConfig = CmmConfig + { cmmProfile :: !Profile -- ^ Target Profile + , cmmOptControlFlow :: !Bool -- ^ Optimize Cmm Control Flow or not + , cmmDoLinting :: !Bool -- ^ Do Cmm Linting Optimization or not + , cmmOptElimCommonBlks :: !Bool -- ^ Eliminate common blocks or not + , cmmOptSink :: !Bool -- ^ Perform sink after stack layout or not + , cmmOptThreadSanitizer :: !Bool -- ^ Instrument memory accesses for ThreadSanitizer + , cmmGenStackUnwindInstr :: !Bool -- ^ Generate stack unwinding instructions (for debugging) + , cmmExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries + , cmmDoCmmSwitchPlans :: !Bool -- ^ Should the Cmm pass replace Stg switch statements + , cmmSplitProcPoints :: !Bool -- ^ Should Cmm split proc points or not + } + +-- | retrieve the target Cmm platform +cmmPlatform :: CmmConfig -> Platform +cmmPlatform = profilePlatform . cmmProfile + diff --git a/GHC/Cmm/ContFlowOpt.hs b/GHC/Cmm/ContFlowOpt.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/ContFlowOpt.hs @@ -0,0 +1,448 @@ +{-# LANGUAGE GADTs #-} +module GHC.Cmm.ContFlowOpt + ( cmmCfgOpts + , cmmCfgOptsProc + , removeUnreachableBlocksProc + , replaceLabels + ) +where + +import GHC.Prelude hiding (succ, unzip, zip) + +import GHC.Cmm.Dataflow.Block hiding (blockConcat) +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList) +import GHC.Data.Maybe +import GHC.Platform +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Monad + + +-- Note [What is shortcutting] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Consider this Cmm code: +-- +-- L1: ... +-- goto L2; +-- L2: goto L3; +-- L3: ... +-- +-- Here L2 is an empty block and contains only an unconditional branch +-- to L3. In this situation any block that jumps to L2 can jump +-- directly to L3: +-- +-- L1: ... +-- goto L3; +-- L2: goto L3; +-- L3: ... +-- +-- In this situation we say that we shortcut L2 to L3. One of +-- consequences of shortcutting is that some blocks of code may become +-- unreachable (in the example above this is true for L2). + + +-- Note [Control-flow optimisations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- This optimisation does three things: +-- +-- - If a block finishes in an unconditional branch to another block +-- and that is the only jump to that block we concatenate the +-- destination block at the end of the current one. +-- +-- - If a block finishes in a call whose continuation block is a +-- goto, then we can shortcut the destination, making the +-- continuation block the destination of the goto - but see Note +-- [Shortcut call returns]. +-- +-- - For any block that is not a call we try to shortcut the +-- destination(s). Additionally, if a block ends with a +-- conditional branch we try to invert the condition. +-- +-- Blocks are processed using postorder DFS traversal. A side effect +-- of determining traversal order with a graph search is elimination +-- of any blocks that are unreachable. +-- +-- Transformations are improved by working from the end of the graph +-- towards the beginning, because we may be able to perform many +-- shortcuts in one go. + + +-- Note [Shortcut call returns] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We are going to maintain the "current" graph (LabelMap CmmBlock) as +-- we go, and also a mapping from BlockId to BlockId, representing +-- continuation labels that we have renamed. This latter mapping is +-- important because we might shortcut a CmmCall continuation. For +-- example: +-- +-- Sp[0] = L +-- call g returns to L +-- L: goto M +-- M: ... +-- +-- So when we shortcut the L block, we need to replace not only +-- the continuation of the call, but also references to L in the +-- code (e.g. the assignment Sp[0] = L): +-- +-- Sp[0] = M +-- call g returns to M +-- M: ... +-- +-- So we keep track of which labels we have renamed and apply the mapping +-- at the end with replaceLabels. + + +-- Note [Shortcut call returns and proc-points] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Consider this code that you might get from a recursive +-- let-no-escape: +-- +-- goto L1 +-- L1: +-- if (Hp > HpLim) then L2 else L3 +-- L2: +-- call stg_gc_noregs returns to L4 +-- L4: +-- goto L1 +-- L3: +-- ... +-- goto L1 +-- +-- Then the control-flow optimiser shortcuts L4. But that turns L1 +-- into the call-return proc point, and every iteration of the loop +-- has to shuffle variables to and from the stack. So we must *not* +-- shortcut L4. +-- +-- Moreover not shortcutting call returns is probably fine. If L4 can +-- concat with its branch target then it will still do so. And we +-- save some compile time because we don't have to traverse all the +-- code in replaceLabels. +-- +-- However, we probably do want to do this if we are splitting proc +-- points, because L1 will be a proc-point anyway, so merging it with +-- L4 reduces the number of proc points. Unfortunately recursive +-- let-no-escapes won't generate very good code with proc-point +-- splitting on - we should probably compile them to explicitly use +-- the native calling convention instead. + +cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph +cmmCfgOpts split g = fst (blockConcat split g) + +cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl +cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g' + where (g', env) = blockConcat split g + info' = info{ info_tbls = new_info_tbls } + new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info))) + + -- If we changed any labels, then we have to update the info tables + -- too, except for the top-level info table because that might be + -- referred to by other procs. + upd_info (k,info) + | Just k' <- mapLookup k env + = (k', if k' == g_entry g' + then info + else info{ cit_lbl = infoTblLbl k' }) + | otherwise + = (k,info) +cmmCfgOptsProc _ top = top + + +blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId) +blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } + = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map') + where + -- We might be able to shortcut the entry BlockId itself. + -- Remember to update the shortcut_map, since we also have to + -- update the info_tbls mapping now. + (new_entry, shortcut_map') + | Just entry_blk <- mapLookup entry_id new_blocks + , Just dest <- canShortcut entry_blk + = (dest, mapInsert entry_id dest shortcut_map) + | otherwise + = (entry_id, shortcut_map) + + -- blocks are sorted in reverse postorder, but we want to go from the exit + -- towards beginning, so we use foldr below. + blocks = revPostorder g + blockmap = foldl' (flip addBlock) emptyBody blocks + + -- Accumulator contains three components: + -- * map of blocks in a graph + -- * map of shortcut labels. See Note [Shortcut call returns] + -- * map containing number of predecessors for each block. We discard + -- it after we process all blocks. + (new_blocks, shortcut_map, _) = + foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks + + -- Map of predecessors for initial graph. We increase number of + -- predecessors for entry block by one to denote that it is + -- target of a jump, even if no block in the current graph jumps + -- to it. + initialBackEdges = incPreds entry_id (predMap blocks) + + maybe_concat :: CmmBlock + -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int) + -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int) + maybe_concat block (!blocks, !shortcut_map, !backEdges) + -- If: + -- (1) current block ends with unconditional branch to b' and + -- (2) it has exactly one predecessor (namely, current block) + -- + -- Then: + -- (1) append b' block at the end of current block + -- (2) remove b' from the map of blocks + -- (3) remove information about b' from predecessors map + -- + -- Since we know that the block has only one predecessor we call + -- mapDelete directly instead of calling decPreds. + -- + -- Note that we always maintain an up-to-date list of predecessors, so + -- we can ignore the contents of shortcut_map + | CmmBranch b' <- last + , hasOnePredecessor b' + , Just blk' <- mapLookup b' blocks + = let bid' = entryLabel blk' + in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks + , shortcut_map + , mapDelete b' backEdges ) + + -- If: + -- (1) we are splitting proc points (see Note + -- [Shortcut call returns and proc-points]) and + -- (2) current block is a CmmCall or CmmForeignCall with + -- continuation b' and + -- (3) we can shortcut that continuation to dest + -- Then: + -- (1) we change continuation to point to b' + -- (2) create mapping from b' to dest + -- (3) increase number of predecessors of dest by 1 + -- (4) decrease number of predecessors of b' by 1 + -- + -- Later we will use replaceLabels to substitute all occurrences of b' + -- with dest. + | splitting_procs + , Just b' <- callContinuation_maybe last + , Just blk' <- mapLookup b' blocks + , Just dest <- canShortcut blk' + = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks + , mapInsert b' dest shortcut_map + , decPreds b' $ incPreds dest backEdges ) + + -- If: + -- (1) a block does not end with a call + -- Then: + -- (1) if it ends with a conditional attempt to invert the + -- conditional + -- (2) attempt to shortcut all destination blocks + -- (3) if new successors of a block are different from the old ones + -- update the of predecessors accordingly + -- + -- A special case of this is a situation when a block ends with an + -- unconditional jump to a block that can be shortcut. + | Nothing <- callContinuation_maybe last + = let oldSuccs = successors last + newSuccs = successors rewrite_last + in ( mapInsert bid (blockJoinTail head rewrite_last) blocks + , shortcut_map + , if oldSuccs == newSuccs + then backEdges + else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs ) + + -- Otherwise don't do anything + | otherwise + = ( blocks, shortcut_map, backEdges ) + where + (head, last) = blockSplitTail block + bid = entryLabel block + + -- Changes continuation of a call to a specified label + update_cont dest = + case last of + CmmCall{} -> last { cml_cont = Just dest } + CmmForeignCall{} -> last { succ = dest } + _ -> panic "Can't shortcut continuation." + + -- Attempts to shortcut successors of last node + shortcut_last = mapSuccessors shortcut last + where + shortcut l = + case mapLookup l blocks of + Just b | Just dest <- canShortcut b -> dest + _otherwise -> l + + rewrite_last + -- Sometimes we can get rid of the conditional completely. + | CmmCondBranch _cond t f _l <- shortcut_last + , t == f + = CmmBranch t + + -- See Note [Invert Cmm conditionals] + | CmmCondBranch cond t f l <- shortcut_last + , hasOnePredecessor t -- inverting will make t a fallthrough + , likelyTrue l || (numPreds f > 1) + , Just cond' <- maybeInvertCmmExpr cond + = CmmCondBranch cond' f t (invertLikeliness l) + + -- If all jump destinations of a switch go to the + -- same target eliminate the switch. + | CmmSwitch _expr targets <- shortcut_last + , (t:ts) <- switchTargetsToList targets + , all (== t) ts + = CmmBranch t + + | otherwise + = shortcut_last + + likelyTrue (Just True) = True + likelyTrue _ = False + + invertLikeliness :: Maybe Bool -> Maybe Bool + invertLikeliness = fmap not + + -- Number of predecessors for a block + numPreds bid = mapLookup bid backEdges `orElse` 0 + + hasOnePredecessor b = numPreds b == 1 + +{- + Note [Invert Cmm conditionals] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The native code generator always produces jumps to the true branch. + Falling through to the false branch is however faster. So we try to + arrange for that to happen. + This means we invert the condition if: + * The likely path will become a fallthrough. + * We can't guarantee a fallthrough for the false branch but for the + true branch. + + In some cases it's faster to avoid inverting when the false branch is likely. + However determining when that is the case is neither easy nor cheap so for + now we always invert as this produces smaller binaries and code that is + equally fast on average. (On an i7-6700K) + + TODO: + There is also the edge case when both branches have multiple predecessors. + In this case we could assume that we will end up with a jump for BOTH + branches. In this case it might be best to put the likely path in the true + branch especially if there are large numbers of predecessors as this saves + us the jump that's not taken. However I haven't tested this and as of early + 2018 we almost never generate cmm where this would apply. +-} + +-- Functions for incrementing and decrementing number of predecessors. If +-- decrementing would set the predecessor count to 0, we remove entry from the +-- map. +-- Invariant: if a block has no predecessors it should be dropped from the +-- graph because it is unreachable. maybe_concat is constructed to maintain +-- that invariant, but calling replaceLabels may introduce unreachable blocks. +-- We rely on subsequent passes in the Cmm pipeline to remove unreachable +-- blocks. +incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int +incPreds bid edges = mapInsertWith (+) bid 1 edges +decPreds bid edges = case mapLookup bid edges of + Just preds | preds > 1 -> mapInsert bid (preds - 1) edges + Just _ -> mapDelete bid edges + _ -> edges + + +-- Checks if a block consists only of "goto dest". If it does than we return +-- "Just dest" label. See Note [What is shortcutting] +canShortcut :: CmmBlock -> Maybe BlockId +canShortcut block + | (_, middle, CmmBranch dest) <- blockSplit block + , all dont_care $ blockToList middle + = Just dest + | otherwise + = Nothing + where dont_care CmmComment{} = True + dont_care CmmTick{} = True + dont_care _other = False + +-- Concatenates two blocks. First one is assumed to be open on exit, the second +-- is assumed to be closed on entry (i.e. it has a label attached to it, which +-- the splice function removes by calling snd on result of blockSplitHead). +splice :: Block CmmNode C O -> CmmBlock -> CmmBlock +splice head rest = entry `blockJoinHead` code0 `blockAppend` code1 + where (CmmEntry lbl sc0, code0) = blockSplitHead head + (CmmEntry _ sc1, code1) = blockSplitHead rest + entry = CmmEntry lbl (combineTickScopes sc0 sc1) + +-- If node is a call with continuation call return Just label of that +-- continuation. Otherwise return Nothing. +callContinuation_maybe :: CmmNode O C -> Maybe BlockId +callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b +callContinuation_maybe (CmmForeignCall { succ = b }) = Just b +callContinuation_maybe _ = Nothing + + +-- Map over the CmmGraph, replacing each label with its mapping in the +-- supplied LabelMap. +replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph +replaceLabels env g + | mapNull env = g + | otherwise = replace_eid $ mapGraphNodes1 txnode g + where + replace_eid g = g {g_entry = lookup (g_entry g)} + lookup id = mapLookup id env `orElse` id + + txnode :: CmmNode e x -> CmmNode e x + txnode (CmmBranch bid) = CmmBranch (lookup bid) + txnode (CmmCondBranch p t f l) = + mkCmmCondBranch (exp p) (lookup t) (lookup f) l + txnode (CmmSwitch e ids) = + CmmSwitch (exp e) (mapSwitchTargets lookup ids) + txnode (CmmCall t k rg a res r) = + CmmCall (exp t) (liftM lookup k) rg a res r + txnode fc@CmmForeignCall{} = + fc{ args = map exp (args fc), succ = lookup (succ fc) } + txnode other = mapExpDeep exp other + + exp :: CmmExpr -> CmmExpr + exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid)) + exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i + exp e = e + +mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C +mkCmmCondBranch p t f l = + if t == f then CmmBranch t else CmmCondBranch p t f l + +-- Build a map from a block to its set of predecessors. +predMap :: [CmmBlock] -> LabelMap Int +predMap blocks = foldr add_preds mapEmpty blocks + where + add_preds block env = foldr add env (successors block) + where add lbl env = mapInsertWith (+) lbl 1 env + +-- Remove unreachable blocks from procs +removeUnreachableBlocksProc :: Platform -> CmmDecl -> CmmDecl +removeUnreachableBlocksProc _ proc@(CmmProc info lbl live g) + | used_blocks `lengthLessThan` mapSize (toBlockMap g) + = CmmProc info' lbl live g' + | otherwise + = proc + where + g' = ofBlockList (g_entry g) used_blocks + info' = info { info_tbls = keep_used (info_tbls info) } + -- Remove any info_tbls for unreachable + + keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable + keep_used bs = mapFoldlWithKey keep mapEmpty bs + + keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable + keep env l i | l `setMember` used_lbls = mapInsert l i env + | otherwise = env + + used_blocks :: [CmmBlock] + used_blocks = revPostorder g + + used_lbls :: LabelSet + used_lbls = setFromList $ map entryLabel used_blocks +removeUnreachableBlocksProc platform data'@(CmmData _ _) = + pprPanic "removeUnreachableBlocksProc: passed data declaration instead of procedure" (pdoc platform data') diff --git a/GHC/Cmm/Dataflow.hs b/GHC/Cmm/Dataflow.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Dataflow.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- +-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones, +-- and Norman Ramsey +-- +-- Modifications copyright (c) The University of Glasgow 2012 +-- +-- This module is a specialised and optimised version of +-- Compiler.Hoopl.Dataflow in the hoopl package. In particular it is +-- specialised to the UniqDSM monad. +-- + +module GHC.Cmm.Dataflow + ( C, O, Block + , lastNode, entryLabel + , foldNodesBwdOO + , foldRewriteNodesBwdOO + , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..) + , TransferFun, RewriteFun + , Fact, FactBase + , getFact, mkFactBase + , analyzeCmmFwd, analyzeCmmBwd + , rewriteCmmBwd + , changedIf + , joinOutFacts + , joinFacts + ) +where + +import GHC.Prelude + +import GHC.Cmm +import GHC.Types.Unique.DSM + +import Data.Array +import Data.Maybe +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.Kind (Type) + +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label + +type family Fact (x :: Extensibility) f :: Type +type instance Fact C f = FactBase f +type instance Fact O f = f + +newtype OldFact a = OldFact a + +newtype NewFact a = NewFact a + +-- | The result of joining OldFact and NewFact. +data JoinedFact a + = Changed !a -- ^ Result is different than OldFact. + | NotChanged !a -- ^ Result is the same as OldFact. + +getJoined :: JoinedFact a -> a +getJoined (Changed a) = a +getJoined (NotChanged a) = a + +changedIf :: Bool -> a -> JoinedFact a +changedIf True = Changed +changedIf False = NotChanged + +type JoinFun a = OldFact a -> NewFact a -> JoinedFact a + +data DataflowLattice a = DataflowLattice + { fact_bot :: a + , fact_join :: JoinFun a + } + +data Direction = Fwd | Bwd + +type TransferFun f = CmmBlock -> FactBase f -> FactBase f + +-- | `TransferFun` abstracted over `n` (the node type) +type TransferFun' (n :: Extensibility -> Extensibility -> Type) f = + Block n C C -> FactBase f -> FactBase f + + +-- | Function for rewriting and analysis combined. To be used with +-- @rewriteCmm@. +-- +-- Currently set to work with @UniqDSM@ monad, but we could probably abstract +-- that away (if we do that, we might want to specialize the fixpoint algorithms +-- to the particular monads through SPECIALIZE). +type RewriteFun f = CmmBlock -> FactBase f -> UniqDSM (CmmBlock, FactBase f) + +-- | `RewriteFun` abstracted over `n` (the node type) +type RewriteFun' (n :: Extensibility -> Extensibility -> Type) f = + Block n C C -> FactBase f -> UniqDSM (Block n C C, FactBase f) + +analyzeCmmBwd, analyzeCmmFwd + :: (NonLocal node) + => DataflowLattice f + -> TransferFun' node f + -> GenCmmGraph node + -> FactBase f + -> FactBase f +analyzeCmmBwd = analyzeCmm Bwd +analyzeCmmFwd = analyzeCmm Fwd + +analyzeCmm + :: (NonLocal node) + => Direction + -> DataflowLattice f + -> TransferFun' node f + -> GenCmmGraph node + -> FactBase f + -> FactBase f +analyzeCmm dir lattice transfer cmmGraph initFact = + {-# SCC analyzeCmm #-} + let entry = g_entry cmmGraph + hooplGraph = g_graph cmmGraph + blockMap = + case hooplGraph of + GMany NothingO bm NothingO -> bm + in fixpointAnalysis dir lattice transfer entry blockMap initFact + +-- Fixpoint algorithm. +fixpointAnalysis + :: forall f node. + (NonLocal node) + => Direction + -> DataflowLattice f + -> TransferFun' node f + -> Label + -> LabelMap (Block node C C) + -> FactBase f + -> FactBase f +fixpointAnalysis direction lattice do_block entry blockmap = loop start + where + -- Sorting the blocks helps to minimize the number of times we need to + -- process blocks. For instance, for forward analysis we want to look at + -- blocks in reverse postorder. Also, see comments for sortBlocks. + blocks = sortBlocks direction entry blockmap + num_blocks = length blocks + block_arr = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks + start = {-# SCC "start" #-} IntSet.fromDistinctAscList + [0 .. num_blocks - 1] + dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks + join = fact_join lattice + + loop + :: IntHeap -- Worklist, i.e., blocks to process + -> FactBase f -- Current result (increases monotonically) + -> FactBase f + loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo = + let block = block_arr ! index + out_facts = {-# SCC "do_block" #-} do_block block fbase1 + -- For each of the outgoing edges, we join it with the current + -- information in fbase1 and (if something changed) we update it + -- and add the affected blocks to the worklist. + (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-} + mapFoldlWithKey + (updateFact join dep_blocks) (todo1, fbase1) out_facts + in loop todo2 fbase2 + loop _ !fbase1 = fbase1 + +rewriteCmmBwd + :: (NonLocal node) + => DataflowLattice f + -> RewriteFun' node f + -> GenCmmGraph node + -> FactBase f + -> UniqDSM (GenCmmGraph node, FactBase f) +rewriteCmmBwd = rewriteCmm Bwd + +rewriteCmm + :: (NonLocal node) + => Direction + -> DataflowLattice f + -> RewriteFun' node f + -> GenCmmGraph node + -> FactBase f + -> UniqDSM (GenCmmGraph node, FactBase f) +rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do + let entry = g_entry cmmGraph + hooplGraph = g_graph cmmGraph + blockMap1 = + case hooplGraph of + GMany NothingO bm NothingO -> bm + (blockMap2, facts) <- + fixpointRewrite dir lattice rwFun entry blockMap1 initFact + return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts) + +fixpointRewrite + :: forall f node. + NonLocal node + => Direction + -> DataflowLattice f + -> RewriteFun' node f + -> Label + -> LabelMap (Block node C C) + -> FactBase f + -> UniqDSM (LabelMap (Block node C C), FactBase f) +fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap + where + -- Sorting the blocks helps to minimize the number of times we need to + -- process blocks. For instance, for forward analysis we want to look at + -- blocks in reverse postorder. Also, see comments for sortBlocks. + blocks = sortBlocks dir entry blockmap + num_blocks = length blocks + block_arr = {-# SCC "block_arr_rewrite" #-} + listArray (0, num_blocks - 1) blocks + start = {-# SCC "start_rewrite" #-} + IntSet.fromDistinctAscList [0 .. num_blocks - 1] + dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks + join = fact_join lattice + + loop + :: IntHeap -- Worklist, i.e., blocks to process + -> LabelMap (Block node C C) -- Rewritten blocks. + -> FactBase f -- Current facts. + -> UniqDSM (LabelMap (Block node C C), FactBase f) + loop todo !blocks1 !fbase1 + | Just (index, todo1) <- IntSet.minView todo = do + -- Note that we use the *original* block here. This is important. + -- We're optimistically rewriting blocks even before reaching the fixed + -- point, which means that the rewrite might be incorrect. So if the + -- facts change, we need to rewrite the original block again (taking + -- into account the new facts). + let block = block_arr ! index + (new_block, out_facts) <- {-# SCC "do_block_rewrite" #-} + do_block block fbase1 + let blocks2 = mapInsert (entryLabel new_block) new_block blocks1 + (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-} + mapFoldlWithKey + (updateFact join dep_blocks) (todo1, fbase1) out_facts + loop todo2 blocks2 fbase2 + loop _ !blocks1 !fbase1 = return (blocks1, fbase1) + + +{- +Note [Unreachable blocks] +~~~~~~~~~~~~~~~~~~~~~~~~~ +A block that is not in the domain of tfb_fbase is "currently unreachable". +A currently-unreachable block is not even analyzed. Reason: consider +constant prop and this graph, with entry point L1: + L1: x:=3; goto L4 + L2: x:=4; goto L4 + L4: if x>3 goto L2 else goto L5 +Here L2 is actually unreachable, but if we process it with bottom input fact, +we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4. + +* If a currently-unreachable block is not analyzed, then its rewritten + graph will not be accumulated in tfb_rg. And that is good: + unreachable blocks simply do not appear in the output. + +* Note that clients must be careful to provide a fact (even if bottom) + for each entry point. Otherwise useful blocks may be garbage collected. + +* Note that updateFact must set the change-flag if a label goes from + not-in-fbase to in-fbase, even if its fact is bottom. In effect the + real fact lattice is + UNR + bottom + the points above bottom + +* Even if the fact is going from UNR to bottom, we still call the + client's fact_join function because it might give the client + some useful debugging information. + +* All of this only applies for *forward* ixpoints. For the backward + case we must treat every block as reachable; it might finish with a + 'return', and therefore have no successors, for example. +-} + + +----------------------------------------------------------------------------- +-- Pieces that are shared by fixpoint and fixpoint_anal +----------------------------------------------------------------------------- + +-- | Sort the blocks into the right order for analysis. This means reverse +-- postorder for a forward analysis. For the backward one, we simply reverse +-- that (see Note [Backward vs forward analysis]). +sortBlocks + :: NonLocal n + => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C] +sortBlocks direction entry blockmap = + case direction of + Fwd -> fwd + Bwd -> reverse fwd + where + fwd = revPostorderFrom blockmap entry + +-- Note [Backward vs forward analysis] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The forward and backward cases are not dual. In the forward case, the entry +-- points are known, and one simply traverses the body blocks from those points. +-- In the backward case, something is known about the exit points, but a +-- backward analysis must also include reachable blocks that don't reach the +-- exit, as in a procedure that loops forever and has side effects.) +-- For instance, let E be the entry and X the exit blocks (arrows indicate +-- control flow) +-- E -> X +-- E -> B +-- B -> C +-- C -> B +-- We do need to include B and C even though they're unreachable in the +-- *reverse* graph (that we could use for backward analysis): +-- E <- X +-- E <- B +-- B <- C +-- C <- B +-- So when sorting the blocks for the backward analysis, we simply take the +-- reverse of what is used for the forward one. + + +-- | Construct a mapping from a @Label@ to the block indexes that should be +-- re-analyzed if the facts at that @Label@ change. +-- +-- Note that we're considering here the entry point of the block, so if the +-- facts change at the entry: +-- * for a backward analysis we need to re-analyze all the predecessors, but +-- * for a forward analysis, we only need to re-analyze the current block +-- (and that will in turn propagate facts into its successors). +mkDepBlocks :: NonLocal node => Direction -> [Block node C C] -> LabelMap IntSet +mkDepBlocks Fwd blocks = go blocks 0 mapEmpty + where + go [] !_ !dep_map = dep_map + go (b:bs) !n !dep_map = + go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map +mkDepBlocks Bwd blocks = go blocks 0 mapEmpty + where + go [] !_ !dep_map = dep_map + go (b:bs) !n !dep_map = + let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m + in go bs (n + 1) $ foldl' insert dep_map (successors b) + +-- | After some new facts have been generated by analysing a block, we +-- fold this function over them to generate (a) a list of block +-- indices to (re-)analyse, and (b) the new FactBase. +updateFact + :: JoinFun f + -> LabelMap IntSet + -> (IntHeap, FactBase f) + -> Label + -> f -- out fact + -> (IntHeap, FactBase f) +updateFact fact_join dep_blocks (todo, fbase) lbl new_fact + = case lookupFact lbl fbase of + Nothing -> + -- See Note [No old fact] + let !z = mapInsert lbl new_fact fbase in (changed, z) + Just old_fact -> + case fact_join (OldFact old_fact) (NewFact new_fact) of + (NotChanged _) -> (todo, fbase) + (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z) + where + changed = todo `IntSet.union` + mapFindWithDefault IntSet.empty lbl dep_blocks + +{- +Note [No old fact] +~~~~~~~~~~~~~~~~~~ +We know that the new_fact is >= _|_, so we don't need to join. However, +if the new fact is also _|_, and we have already analysed its block, +we don't need to record a change. So there's a tradeoff here. It turns +out that always recording a change is faster. +-} + +---------------------------------------------------------------- +-- Utilities +---------------------------------------------------------------- + +-- Fact lookup: the fact `orelse` bottom +getFact :: DataflowLattice f -> Label -> FactBase f -> f +getFact lat l fb = case lookupFact l fb of Just f -> f + Nothing -> fact_bot lat + +-- | Returns the result of joining the facts from all the successors of the +-- provided node or block. +joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f +joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts + where + join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new) + facts = + [ fromJust fact + | s <- successors nonLocal + , let fact = lookupFact s fact_base + , isJust fact + ] + +joinFacts :: DataflowLattice f -> [f] -> f +joinFacts lattice facts = foldl' join (fact_bot lattice) facts + where + join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new) + +-- | Returns the joined facts for each label. +mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f +mkFactBase lattice = foldl' add mapEmpty + where + join = fact_join lattice + + add result (l, f1) = + let !newFact = + case mapLookup l result of + Nothing -> f1 + Just f2 -> getJoined $ join (OldFact f1) (NewFact f2) + in mapInsert l newFact result + +-- | Folds backward over all nodes of an open-open block. +-- Strict in the accumulator. +foldNodesBwdOO :: (node O O -> f -> f) -> Block node O O -> f -> f +foldNodesBwdOO funOO = go + where + go (BCat b1 b2) f = go b1 $! go b2 f + go (BSnoc h n) f = go h $! funOO n f + go (BCons n t) f = funOO n $! go t f + go (BMiddle n) f = funOO n f + go BNil f = f +{-# INLINABLE foldNodesBwdOO #-} + +-- | Folds backward over all the nodes of an open-open block and allows +-- rewriting them. The accumulator is both the block of nodes and @f@ (usually +-- dataflow facts). +-- Strict in both accumulated parts. +foldRewriteNodesBwdOO + :: forall f node. + (node O O -> f -> UniqDSM (Block node O O, f)) + -> Block node O O + -> f + -> UniqDSM (Block node O O, f) +foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts + where + go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1 + go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1 + go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1 + go (BMiddle node) !fact1 = rewriteOO node fact1 + go BNil !fact = return (BNil, fact) + + comp rew1 rew2 = \f1 -> do + (b, f2) <- rew2 f1 + (a, !f3) <- rew1 f2 + let !c = joinBlocksOO a b + return (c, f3) + {-# INLINE comp #-} +{-# INLINABLE foldRewriteNodesBwdOO #-} + +joinBlocksOO :: Block n O O -> Block n O O -> Block n O O +joinBlocksOO BNil b = b +joinBlocksOO b BNil = b +joinBlocksOO (BMiddle n) b = blockCons n b +joinBlocksOO b (BMiddle n) = blockSnoc b n +joinBlocksOO b1 b2 = BCat b1 b2 + +type IntHeap = IntSet diff --git a/GHC/Cmm/Dataflow/Block.hs b/GHC/Cmm/Dataflow/Block.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Dataflow/Block.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module GHC.Cmm.Dataflow.Block + ( Extensibility (..) + , O + , C + , MaybeO(..) + , IndexedCO + , Block(..) + , blockAppend + , blockConcat + , blockCons + , blockFromList + , blockJoin + , blockJoinHead + , blockJoinTail + , blockSnoc + , blockSplit + , blockSplitHead + , blockSplitTail + , blockToList + , emptyBlock + , firstNode + , foldBlockNodesB + , foldBlockNodesB3 + , foldBlockNodesF + , isEmptyBlock + , lastNode + , mapBlock + , mapBlock' + , mapBlock3' + , replaceFirstNode + , replaceLastNode + ) where + +import GHC.Prelude + +-- ----------------------------------------------------------------------------- +-- Shapes: Open and Closed + +-- | Used at the type level to indicate "open" vs "closed" structure. +data Extensibility + -- | An "open" structure with a unique, unnamed control-flow edge flowing in + -- or out. \"Fallthrough\" and concatenation are permitted at an open point. + = Open + -- | A "closed" structure which supports control transfer only through the use + -- of named labels---no "fallthrough" is permitted. The number of control-flow + -- edges is unconstrained. + | Closed + +type O = 'Open +type C = 'Closed + +-- | Either type indexed by closed/open using type families +type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k +type instance IndexedCO C a _b = a +type instance IndexedCO O _a b = b + +-- | Maybe type indexed by open/closed +data MaybeO ex t where + JustO :: t -> MaybeO O t + NothingO :: MaybeO C t + +deriving instance Functor (MaybeO ex) + +-- ----------------------------------------------------------------------------- +-- The Block type + +-- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C). +-- Open at the entry means single entry, mutatis mutandis for exit. +-- A closed/closed block is a /basic/ block and can't be extended further. +-- Clients should avoid manipulating blocks and should stick to either nodes +-- or graphs. +data Block n e x where + BlockCO :: n C O -> Block n O O -> Block n C O + BlockCC :: n C O -> Block n O O -> n O C -> Block n C C + BlockOC :: Block n O O -> n O C -> Block n O C + + BNil :: Block n O O + BMiddle :: n O O -> Block n O O + BCat :: Block n O O -> Block n O O -> Block n O O + BSnoc :: Block n O O -> n O O -> Block n O O + BCons :: n O O -> Block n O O -> Block n O O + + +-- ----------------------------------------------------------------------------- +-- Simple operations on Blocks + +-- Predicates + +isEmptyBlock :: Block n e x -> Bool +isEmptyBlock BNil = True +isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r +isEmptyBlock _ = False + + +-- Building + +emptyBlock :: Block n O O +emptyBlock = BNil + +blockCons :: n O O -> Block n O x -> Block n O x +blockCons n b = case b of + BlockOC b l -> (BlockOC $! (n `blockCons` b)) l + BNil{} -> BMiddle n + BMiddle{} -> n `BCons` b + BCat{} -> n `BCons` b + BSnoc{} -> n `BCons` b + BCons{} -> n `BCons` b + +blockSnoc :: Block n e O -> n O O -> Block n e O +blockSnoc b n = case b of + BlockCO f b -> BlockCO f $! (b `blockSnoc` n) + BNil{} -> BMiddle n + BMiddle{} -> b `BSnoc` n + BCat{} -> b `BSnoc` n + BSnoc{} -> b `BSnoc` n + BCons{} -> b `BSnoc` n + +blockJoinHead :: n C O -> Block n O x -> Block n C x +blockJoinHead f (BlockOC b l) = BlockCC f b l +blockJoinHead f b = BlockCO f BNil `cat` b + +blockJoinTail :: Block n e O -> n O C -> Block n e C +blockJoinTail (BlockCO f b) t = BlockCC f b t +blockJoinTail b t = b `cat` BlockOC BNil t + +blockJoin :: n C O -> Block n O O -> n O C -> Block n C C +blockJoin f b t = BlockCC f b t + +blockAppend :: Block n e O -> Block n O x -> Block n e x +blockAppend = cat + +blockConcat :: [Block n O O] -> Block n O O +blockConcat = foldr blockAppend emptyBlock + +-- Taking apart + +firstNode :: Block n C x -> n C O +firstNode (BlockCO n _) = n +firstNode (BlockCC n _ _) = n + +lastNode :: Block n x C -> n O C +lastNode (BlockOC _ n) = n +lastNode (BlockCC _ _ n) = n + +blockSplitHead :: Block n C x -> (n C O, Block n O x) +blockSplitHead (BlockCO n b) = (n, b) +blockSplitHead (BlockCC n b t) = (n, BlockOC b t) + +blockSplitTail :: Block n e C -> (Block n e O, n O C) +blockSplitTail (BlockOC b n) = (b, n) +blockSplitTail (BlockCC f b t) = (BlockCO f b, t) + +-- | Split a closed block into its entry node, open middle block, and +-- exit node. +blockSplit :: Block n C C -> (n C O, Block n O O, n O C) +blockSplit (BlockCC f b t) = (f, b, t) + +blockToList :: Block n O O -> [n O O] +blockToList b = go b [] + where go :: Block n O O -> [n O O] -> [n O O] + go BNil r = r + go (BMiddle n) r = n : r + go (BCat b1 b2) r = go b1 $! go b2 r + go (BSnoc b1 n) r = go b1 (n:r) + go (BCons n b1) r = n : go b1 r + +blockFromList :: [n O O] -> Block n O O +blockFromList = foldr BCons BNil + +-- Modifying + +replaceFirstNode :: Block n C x -> n C O -> Block n C x +replaceFirstNode (BlockCO _ b) f = BlockCO f b +replaceFirstNode (BlockCC _ b n) f = BlockCC f b n + +replaceLastNode :: Block n x C -> n O C -> Block n x C +replaceLastNode (BlockOC b _) n = BlockOC b n +replaceLastNode (BlockCC l b _) n = BlockCC l b n + +-- ----------------------------------------------------------------------------- +-- General concatenation + +cat :: Block n e O -> Block n O x -> Block n e x +cat x y = case x of + BNil -> y + + BlockCO l b1 -> case y of + BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n + BNil -> x + BMiddle _ -> BlockCO l $! (b1 `cat` y) + BCat{} -> BlockCO l $! (b1 `cat` y) + BSnoc{} -> BlockCO l $! (b1 `cat` y) + BCons{} -> BlockCO l $! (b1 `cat` y) + + BMiddle n -> case y of + BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 + BNil -> x + BMiddle{} -> BCons n y + BCat{} -> BCons n y + BSnoc{} -> BCons n y + BCons{} -> BCons n y + + BCat{} -> case y of + BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2 + BNil -> x + BMiddle n -> BSnoc x n + BCat{} -> BCat x y + BSnoc{} -> BCat x y + BCons{} -> BCat x y + + BSnoc{} -> case y of + BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 + BNil -> x + BMiddle n -> BSnoc x n + BCat{} -> BCat x y + BSnoc{} -> BCat x y + BCons{} -> BCat x y + + + BCons{} -> case y of + BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 + BNil -> x + BMiddle n -> BSnoc x n + BCat{} -> BCat x y + BSnoc{} -> BCat x y + BCons{} -> BCat x y + + +-- ----------------------------------------------------------------------------- +-- Mapping + +-- | map a function over the nodes of a 'Block' +mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x +mapBlock f (BlockCO n b ) = BlockCO (f n) (mapBlock f b) +mapBlock f (BlockOC b n) = BlockOC (mapBlock f b) (f n) +mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m) +mapBlock _ BNil = BNil +mapBlock f (BMiddle n) = BMiddle (f n) +mapBlock f (BCat b1 b2) = BCat (mapBlock f b1) (mapBlock f b2) +mapBlock f (BSnoc b n) = BSnoc (mapBlock f b) (f n) +mapBlock f (BCons n b) = BCons (f n) (mapBlock f b) + +-- | A strict 'mapBlock' +mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x) +mapBlock' f = mapBlock3' (f, f, f) + +-- | map over a block, with different functions to apply to first nodes, +-- middle nodes and last nodes respectively. The map is strict. +-- +mapBlock3' :: forall n n' e x . + ( n C O -> n' C O + , n O O -> n' O O, + n O C -> n' O C) + -> Block n e x -> Block n' e x +mapBlock3' (f, m, l) b = go b + where go :: forall e x . Block n e x -> Block n' e x + go (BlockOC b y) = (BlockOC $! go b) $! l y + go (BlockCO x b) = (BlockCO $! f x) $! (go b) + go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y) + go BNil = BNil + go (BMiddle n) = BMiddle $! m n + go (BCat x y) = (BCat $! go x) $! (go y) + go (BSnoc x n) = (BSnoc $! go x) $! (m n) + go (BCons n x) = (BCons $! m n) $! (go x) + +-- ----------------------------------------------------------------------------- +-- Folding + + +-- | Fold a function over every node in a block, forward or backward. +-- The fold function must be polymorphic in the shape of the nodes. +foldBlockNodesF3 :: forall n a b c . + ( n C O -> a -> b + , n O O -> b -> b + , n O C -> b -> c) + -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b) +foldBlockNodesF :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a) +foldBlockNodesB3 :: forall n a b c . + ( n C O -> b -> c + , n O O -> b -> b + , n O C -> a -> b) + -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b) +foldBlockNodesB :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a) + +foldBlockNodesF3 (ff, fm, fl) = block + where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b + block (BlockCO f b ) = ff f `cat` block b + block (BlockCC f b l) = ff f `cat` block b `cat` fl l + block (BlockOC b l) = block b `cat` fl l + block BNil = id + block (BMiddle node) = fm node + block (b1 `BCat` b2) = block b1 `cat` block b2 + block (b1 `BSnoc` n) = block b1 `cat` fm n + block (n `BCons` b2) = fm n `cat` block b2 + cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c + cat f f' = f' . f + +foldBlockNodesF f = foldBlockNodesF3 (f, f, f) + +foldBlockNodesB3 (ff, fm, fl) = block + where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b + block (BlockCO f b ) = ff f `cat` block b + block (BlockCC f b l) = ff f `cat` block b `cat` fl l + block (BlockOC b l) = block b `cat` fl l + block BNil = id + block (BMiddle node) = fm node + block (b1 `BCat` b2) = block b1 `cat` block b2 + block (b1 `BSnoc` n) = block b1 `cat` fm n + block (n `BCons` b2) = fm n `cat` block b2 + cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c + cat f f' = f . f' + +foldBlockNodesB f = foldBlockNodesB3 (f, f, f) + diff --git a/GHC/Cmm/Dataflow/Graph.hs b/GHC/Cmm/Dataflow/Graph.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Dataflow/Graph.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +module GHC.Cmm.Dataflow.Graph + ( Body + , Graph + , Graph'(..) + , NonLocal(..) + , addBlock + , bodyList + , bodyToBlockList + , emptyBody + , labelsDefined + , mapGraph + , mapGraphBlocks + , revPostorderFrom + ) where + + +import GHC.Prelude +import GHC.Utils.Misc + +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Block + +import Data.Kind + +-- | A (possibly empty) collection of closed/closed blocks +type Body s n = Body' s Block n + +-- | @Body@ abstracted over @block@ +type Body' s block (n :: Extensibility -> Extensibility -> Type) = s (block n C C) + +------------------------------- +-- | Gives access to the anchor points for +-- nonlocal edges as well as the edges themselves +class NonLocal thing where + entryLabel :: thing C x -> Label -- ^ The label of a first node or block + successors :: thing e C -> [Label] -- ^ Gives control-flow successors + +instance NonLocal n => NonLocal (Block n) where + entryLabel (BlockCO f _) = entryLabel f + entryLabel (BlockCC f _ _) = entryLabel f + + successors (BlockOC _ n) = successors n + successors (BlockCC _ _ n) = successors n + + +emptyBody :: Body' LabelMap block n +emptyBody = mapEmpty + +bodyList :: Body' LabelMap block n -> [(Label,block n C C)] +bodyList body = mapToList body + +bodyToBlockList :: Body LabelMap n -> [Block n C C] +bodyToBlockList body = mapElems body + +addBlock + :: (NonLocal block, HasDebugCallStack) + => block C C -> LabelMap (block C C) -> LabelMap (block C C) +addBlock block body = mapAlter add lbl body + where + lbl = entryLabel block + add Nothing = Just block + add _ = error $ "duplicate label " ++ show lbl ++ " in graph" + + +-- --------------------------------------------------------------------------- +-- Graph + +-- | A control-flow graph, which may take any of four shapes (O/O, +-- O/C, C/O, C/C). A graph open at the entry has a single, +-- distinguished, anonymous entry point; if a graph is closed at the +-- entry, its entry point(s) are supplied by a context. +type Graph = Graph' LabelMap Block + +-- | @Graph'@ is abstracted over the block type, so that we can build +-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow +-- needs this). +data Graph' s block (n :: Extensibility -> Extensibility -> Type) e x where + GNil :: Graph' s block n O O + GUnit :: block n O O -> Graph' s block n O O + GMany :: MaybeO e (block n O C) + -> Body' s block n + -> MaybeO x (block n C O) + -> Graph' s block n e x + + +-- ----------------------------------------------------------------------------- +-- Mapping over graphs + +-- | Maps over all nodes in a graph. +mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x +mapGraph f = mapGraphBlocks mapMap (mapBlock f) + +-- | Function 'mapGraphBlocks' enables a change of representation of blocks, +-- nodes, or both. It lifts a polymorphic block transform into a polymorphic +-- graph transform. When the block representation stabilizes, a similar +-- function should be provided for blocks. +mapGraphBlocks :: forall s block n block' n' e x . + (forall a b . (a -> b) -> s a -> s b) + -> (forall e x . block n e x -> block' n' e x) + -> (Graph' s block n e x -> Graph' s block' n' e x) + +mapGraphBlocks f g = map + where map :: Graph' s block n e x -> Graph' s block' n' e x + map GNil = GNil + map (GUnit b) = GUnit (g b) + map (GMany e b x) = GMany (fmap g e) (f g b) (fmap g x) + +-- ----------------------------------------------------------------------------- +-- Extracting Labels from graphs + +labelsDefined :: forall block n e x . NonLocal (block n) => Graph' LabelMap block n e x + -> LabelSet +labelsDefined GNil = setEmpty +labelsDefined (GUnit{}) = setEmpty +labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body + where addEntry :: forall a. LabelSet -> Label -> a -> LabelSet + addEntry labels label _ = setInsert label labels + exitLabel :: MaybeO x (block n C O) -> LabelSet + exitLabel NothingO = setEmpty + exitLabel (JustO b) = setSingleton (entryLabel b) + + +---------------------------------------------------------------- + +-- | Returns a list of blocks reachable from the provided Labels in the reverse +-- postorder. +-- +-- This is the most important traversal over this data structure. It drops +-- unreachable code and puts blocks in an order that is good for solving forward +-- dataflow problems quickly. The reverse order is good for solving backward +-- dataflow problems quickly. The forward order is also reasonably good for +-- emitting instructions, except that it will not usually exploit Forrest +-- Baskett's trick of eliminating the unconditional branch from a loop. For +-- that you would need a more serious analysis, probably based on dominators, to +-- identify loop headers. +-- +-- For forward analyses we want reverse postorder visitation, consider: +-- @ +-- A -> [B,C] +-- B -> D +-- C -> D +-- @ +-- Postorder: [D, C, B, A] (or [D, B, C, A]) +-- Reverse postorder: [A, B, C, D] (or [A, C, B, D]) +-- This matters for, e.g., forward analysis, because we want to analyze *both* +-- B and C before we analyze D. +revPostorderFrom + :: forall block. (NonLocal block) + => LabelMap (block C C) -> Label -> [block C C] +revPostorderFrom graph start = go start_worklist setEmpty [] + where + start_worklist = lookup_for_descend start Nil + + -- To compute the postorder we need to "visit" a block (mark as done) *after* + -- visiting all its successors. So we need to know whether we already + -- processed all successors of each block (and @NonLocal@ allows arbitrary + -- many successors). So we use an explicit stack with an extra bit + -- of information: + -- - @ConsTodo@ means to explore the block if it wasn't visited before + -- - @ConsMark@ means that all successors were already done and we can add + -- the block to the result. + -- + -- NOTE: We add blocks to the result list in postorder, but we *prepend* + -- them (i.e., we use @(:)@), which means that the final list is in reverse + -- postorder. + go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C] + go Nil !_ !result = result + go (ConsMark block rest) !wip_or_done !result = + go rest wip_or_done (block : result) + go (ConsTodo block rest) !wip_or_done !result + | entryLabel block `setMember` wip_or_done = go rest wip_or_done result + | otherwise = + let new_worklist = + foldr lookup_for_descend + (ConsMark block rest) + (successors block) + in go new_worklist (setInsert (entryLabel block) wip_or_done) result + + lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C) + lookup_for_descend label wl + | Just b <- mapLookup label graph = ConsTodo b wl + | otherwise = + error $ "Label that doesn't have a block?! " ++ show label + +data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil diff --git a/GHC/Cmm/Dataflow/Label.hs b/GHC/Cmm/Dataflow/Label.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Dataflow/Label.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module GHC.Cmm.Dataflow.Label + ( Label + , LabelMap + , LabelSet + , FactBase + , lookupFact + , mkHooplLabel + -- * Set + , setEmpty + , setNull + , setSize + , setMember + , setSingleton + , setInsert + , setDelete + , setUnion + , setUnions + , setDifference + , setIntersection + , setIsSubsetOf + , setFilter + , setFoldl + , setFoldr + , setFromList + , setElems + -- * Map + , mapNull + , mapSize + , mapMember + , mapLookup + , mapFindWithDefault + , mapEmpty + , mapSingleton + , mapInsert + , mapInsertWith + , mapDelete + , mapAlter + , mapAdjust + , mapUnion + , mapUnions + , mapUnionWithKey + , mapDifference + , mapIntersection + , mapIsSubmapOf + , mapMap + , mapMapWithKey + , mapFoldl + , mapFoldr + , mapFoldlWithKey + , mapFoldMapWithKey + , mapFilter + , mapFilterWithKey + , mapElems + , mapKeys + , mapToList + , mapFromList + , mapFromListWith + , mapMapMaybe + ) where + +import GHC.Prelude + +import GHC.Utils.Misc +import GHC.Utils.Outputable + +import GHC.Types.Unique (Uniquable(..), mkUniqueGrimily) + +-- The code generator will eventually be using all the labels stored in a +-- LabelSet and LabelMap. For these reasons we use the strict variants of these +-- data structures. We inline selectively to enable the RULES in Word64Map/Set +-- to fire. +import GHC.Data.Word64Set (Word64Set) +import qualified GHC.Data.Word64Set as S +import GHC.Data.Word64Map.Strict (Word64Map) +import qualified GHC.Data.Word64Map.Strict as M +import GHC.Data.TrieMap + +import Data.Word (Word64) + + +----------------------------------------------------------------------------- +-- Label +----------------------------------------------------------------------------- + +newtype Label = Label { lblToUnique :: Word64 } + deriving newtype (Eq, Ord) + +mkHooplLabel :: Word64 -> Label +mkHooplLabel = Label + +instance Show Label where + show (Label n) = "L" ++ show n + +instance Uniquable Label where + getUnique label = mkUniqueGrimily (lblToUnique label) + +instance Outputable Label where + ppr label = ppr (getUnique label) + +instance OutputableP env Label where + pdoc _ l = ppr l + +----------------------------------------------------------------------------- +-- LabelSet + +newtype LabelSet = LS Word64Set + deriving newtype (Eq, Ord, Show, Monoid, Semigroup) + +setNull :: LabelSet -> Bool +setNull (LS s) = S.null s + +setSize :: LabelSet -> Int +setSize (LS s) = S.size s + +setMember :: Label -> LabelSet -> Bool +setMember (Label k) (LS s) = S.member k s + +setEmpty :: LabelSet +setEmpty = LS S.empty + +setSingleton :: Label -> LabelSet +setSingleton (Label k) = LS (S.singleton k) + +setInsert :: Label -> LabelSet -> LabelSet +setInsert (Label k) (LS s) = LS (S.insert k s) + +setDelete :: Label -> LabelSet -> LabelSet +setDelete (Label k) (LS s) = LS (S.delete k s) + +setUnion :: LabelSet -> LabelSet -> LabelSet +setUnion (LS x) (LS y) = LS (S.union x y) + +{-# INLINE setUnions #-} +setUnions :: [LabelSet] -> LabelSet +setUnions = foldl1WithDefault' setEmpty setUnion + +setDifference :: LabelSet -> LabelSet -> LabelSet +setDifference (LS x) (LS y) = LS (S.difference x y) + +setIntersection :: LabelSet -> LabelSet -> LabelSet +setIntersection (LS x) (LS y) = LS (S.intersection x y) + +setIsSubsetOf :: LabelSet -> LabelSet -> Bool +setIsSubsetOf (LS x) (LS y) = S.isSubsetOf x y + +setFilter :: (Label -> Bool) -> LabelSet -> LabelSet +setFilter f (LS s) = LS (S.filter (f . mkHooplLabel) s) + +{-# INLINE setFoldl #-} +setFoldl :: (t -> Label -> t) -> t -> LabelSet -> t +setFoldl k z (LS s) = S.foldl (\a v -> k a (mkHooplLabel v)) z s + +{-# INLINE setFoldr #-} +setFoldr :: (Label -> t -> t) -> t -> LabelSet -> t +setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s + +{-# INLINE setElems #-} +setElems :: LabelSet -> [Label] +setElems (LS s) = map mkHooplLabel (S.elems s) + +{-# INLINE setFromList #-} +setFromList :: [Label] -> LabelSet +setFromList ks = LS (S.fromList (map lblToUnique ks)) + +----------------------------------------------------------------------------- +-- LabelMap + +newtype LabelMap v = LM (Word64Map v) + deriving newtype (Eq, Ord, Show, Functor, Foldable) + deriving stock Traversable + +mapNull :: LabelMap a -> Bool +mapNull (LM m) = M.null m + +{-# INLINE mapSize #-} +mapSize :: LabelMap a -> Int +mapSize (LM m) = M.size m + +mapMember :: Label -> LabelMap a -> Bool +mapMember (Label k) (LM m) = M.member k m + +mapLookup :: Label -> LabelMap a -> Maybe a +mapLookup (Label k) (LM m) = M.lookup k m + +mapFindWithDefault :: a -> Label -> LabelMap a -> a +mapFindWithDefault def (Label k) (LM m) = M.findWithDefault def k m + +mapEmpty :: LabelMap v +mapEmpty = LM M.empty + +mapSingleton :: Label -> v -> LabelMap v +mapSingleton (Label k) v = LM (M.singleton k v) + +mapInsert :: Label -> v -> LabelMap v -> LabelMap v +mapInsert (Label k) v (LM m) = LM (M.insert k v m) + +mapInsertWith :: (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v +mapInsertWith f (Label k) v (LM m) = LM (M.insertWith f k v m) + +mapDelete :: Label -> LabelMap v -> LabelMap v +mapDelete (Label k) (LM m) = LM (M.delete k m) + +mapAlter :: (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v +mapAlter f (Label k) (LM m) = LM (M.alter f k m) + +mapAdjust :: (v -> v) -> Label -> LabelMap v -> LabelMap v +mapAdjust f (Label k) (LM m) = LM (M.adjust f k m) + +mapUnion :: LabelMap v -> LabelMap v -> LabelMap v +mapUnion (LM x) (LM y) = LM (M.union x y) + +{-# INLINE mapUnions #-} +mapUnions :: [LabelMap a] -> LabelMap a +mapUnions = foldl1WithDefault' mapEmpty mapUnion + +mapUnionWithKey :: (Label -> v -> v -> v) -> LabelMap v -> LabelMap v -> LabelMap v +mapUnionWithKey f (LM x) (LM y) = LM (M.unionWithKey (f . mkHooplLabel) x y) + +mapDifference :: LabelMap v -> LabelMap b -> LabelMap v +mapDifference (LM x) (LM y) = LM (M.difference x y) + +mapIntersection :: LabelMap v -> LabelMap b -> LabelMap v +mapIntersection (LM x) (LM y) = LM (M.intersection x y) + +mapIsSubmapOf :: Eq a => LabelMap a -> LabelMap a -> Bool +mapIsSubmapOf (LM x) (LM y) = M.isSubmapOf x y + +mapMap :: (a -> v) -> LabelMap a -> LabelMap v +mapMap f (LM m) = LM (M.map f m) + +mapMapWithKey :: (Label -> a -> v) -> LabelMap a -> LabelMap v +mapMapWithKey f (LM m) = LM (M.mapWithKey (f . mkHooplLabel) m) + +{-# INLINE mapFoldl #-} +mapFoldl :: (a -> b -> a) -> a -> LabelMap b -> a +mapFoldl k z (LM m) = M.foldl k z m + +{-# INLINE mapFoldr #-} +mapFoldr :: (a -> b -> b) -> b -> LabelMap a -> b +mapFoldr k z (LM m) = M.foldr k z m + +{-# INLINE mapFoldlWithKey #-} +mapFoldlWithKey :: (t -> Label -> b -> t) -> t -> LabelMap b -> t +mapFoldlWithKey k z (LM m) = M.foldlWithKey (\a v -> k a (mkHooplLabel v)) z m + +mapFoldMapWithKey :: Monoid m => (Label -> t -> m) -> LabelMap t -> m +mapFoldMapWithKey f (LM m) = M.foldMapWithKey (\k v -> f (mkHooplLabel k) v) m + +{-# INLINEABLE mapFilter #-} +mapFilter :: (v -> Bool) -> LabelMap v -> LabelMap v +mapFilter f (LM m) = LM (M.filter f m) + +{-# INLINEABLE mapFilterWithKey #-} +mapFilterWithKey :: (Label -> v -> Bool) -> LabelMap v -> LabelMap v +mapFilterWithKey f (LM m) = LM (M.filterWithKey (f . mkHooplLabel) m) + +{-# INLINE mapElems #-} +mapElems :: LabelMap a -> [a] +mapElems (LM m) = M.elems m + +{-# INLINE mapKeys #-} +mapKeys :: LabelMap a -> [Label] +mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m) + +{-# INLINE mapToList #-} +mapToList :: LabelMap b -> [(Label, b)] +mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m] + +{-# INLINE mapFromList #-} +mapFromList :: [(Label, v)] -> LabelMap v +mapFromList assocs = LM (M.fromList [(lblToUnique k, v) | (k, v) <- assocs]) + +mapFromListWith :: (v -> v -> v) -> [(Label, v)] -> LabelMap v +mapFromListWith f assocs = LM (M.fromListWith f [(lblToUnique k, v) | (k, v) <- assocs]) + +mapMapMaybe :: (a -> Maybe b) -> LabelMap a -> LabelMap b +mapMapMaybe f (LM m) = LM (M.mapMaybe f m) + +----------------------------------------------------------------------------- +-- Instances + +instance Outputable LabelSet where + ppr = ppr . setElems + +instance Outputable a => Outputable (LabelMap a) where + ppr = ppr . mapToList + +instance OutputableP env a => OutputableP env (LabelMap a) where + pdoc env = pdoc env . mapToList + +instance TrieMap LabelMap where + type Key LabelMap = Label + emptyTM = mapEmpty + lookupTM k m = mapLookup k m + alterTM k f m = mapAlter f k m + foldTM k m z = mapFoldr k z m + filterTM f = mapFilter f + mapMaybeTM f = mapMapMaybe f + +----------------------------------------------------------------------------- +-- FactBase + +type FactBase f = LabelMap f + +lookupFact :: Label -> FactBase f -> Maybe f +lookupFact = mapLookup diff --git a/GHC/Cmm/DebugBlock.hs b/GHC/Cmm/DebugBlock.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/DebugBlock.hs @@ -0,0 +1,583 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE EmptyCase #-} + +----------------------------------------------------------------------------- +-- +-- Debugging data +-- +-- Association of debug data on the Cmm level, with methods to encode it in +-- event log format for later inclusion in profiling event logs. +-- +----------------------------------------------------------------------------- + +module GHC.Cmm.DebugBlock ( + + DebugBlock(..), + cmmDebugGen, + cmmDebugLabels, + cmmDebugLink, + debugToMap, + + -- * Unwinding information + UnwindTable, UnwindPoint(..), + UnwindExpr(..), toUnwindExpr, + pprUnwindTable + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.Cmm.Reg ( pprGlobalReg, pprGlobalRegUse ) +import GHC.Cmm.Utils +import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastString ) +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.SrcLoc +import GHC.Types.Tickish +import GHC.Utils.Misc ( seqList ) + +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label + +import Data.Maybe +import Data.List ( nubBy ) +import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) +import qualified Data.List.NonEmpty as NE +import Data.Ord ( comparing ) +import qualified Data.Map as Map +import Data.Foldable ( toList ) +import Data.Either ( partitionEithers ) +import Data.Void + +-- | Debug information about a block of code. Ticks scope over nested +-- blocks. +data DebugBlock = + DebugBlock + { dblProcedure :: !Label -- ^ Entry label of containing proc + , dblLabel :: !Label -- ^ Hoopl label + , dblCLabel :: !CLabel -- ^ Output label + , dblHasInfoTbl :: !Bool -- ^ Has an info table? + , dblParent :: !(Maybe DebugBlock) + -- ^ The parent of this proc. See Note [Splitting DebugBlocks] + , dblTicks :: ![CmmTickish] -- ^ Ticks defined in this block + , dblSourceTick :: !(Maybe CmmTickish) -- ^ Best source tick covering block + , dblPosition :: !(Maybe Int) -- ^ Output position relative to + -- other blocks. @Nothing@ means + -- the block was optimized out + , dblUnwind :: [UnwindPoint] + , dblBlocks :: ![DebugBlock] -- ^ Nested blocks + } + +instance OutputableP Platform DebugBlock where + pdoc env blk = + (if | dblProcedure blk == dblLabel blk + -> text "proc" + | dblHasInfoTbl blk + -> text "pp-blk" + | otherwise + -> text "blk") <+> + ppr (dblLabel blk) <+> parens (pprAsmLabel env (dblCLabel blk)) <+> + (maybe empty ppr (dblSourceTick blk)) <+> + (maybe (text "removed") ((text "pos " <>) . ppr) + (dblPosition blk)) <+> + (pdoc env (dblUnwind blk)) $+$ + (if null (dblBlocks blk) then empty else nest 4 (pdoc env (dblBlocks blk))) + +-- | Intermediate data structure holding debug-relevant context information +-- about a block. +type BlockContext = (CmmBlock, RawCmmDeclNoStatics) + +-- Same as `RawCmmDecl`, but statically (in GHC) excludes the possibility of statics (in the CMM +-- code). (The first argument is `Void` rather than `RawCmmStatics`. +type RawCmmDeclNoStatics + = GenCmmDecl + Void + (LabelMap RawCmmStatics) + CmmGraph + +-- | Extract debug data from a group of procedures. We will prefer +-- source notes that come from the given module (presumably the module +-- that we are currently compiling). +cmmDebugGen :: ModLocation -> [RawCmmDecl] -> [DebugBlock] +cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes + where + blockCtxs :: Map.Map CmmTickScope (NonEmpty BlockContext) + blockCtxs = blockContexts decls + + -- Analyse tick scope structure: Each one is either a top-level + -- tick scope, or the child of another. + (topScopes, childScopes) + = partitionEithers $ map (\(k, a) -> findP (k, a) k) $ Map.toList blockCtxs + + findP tsc GlobalScope = Left tsc -- top scope + findP tsc scp | Just x <- Map.lookup scp' blockCtxs = Right (scp', tsc, x) + | otherwise = findP tsc scp' + where -- Note that we only following the left parent of + -- combined scopes. This loses us ticks, which we will + -- recover by copying ticks below. + scp' | SubScope _ scp' <- scp = scp' + | CombinedScope scp' _ <- scp = scp' + + scopeMap = foldl' (\ acc (k, (k', a'), _) -> insertMulti k (k', a') acc) Map.empty childScopes + + -- This allows us to recover ticks that we lost by flattening + -- the graph. Basically, if the parent is A but the child is + -- CBA, we know that there is no BA, because it would have taken + -- priority - but there might be a B scope, with ticks that + -- would not be associated with our child anymore. Note however + -- that there might be other childs (DB), which we have to + -- filter out. + -- + -- We expect this to be called rarely, which is why we are not + -- trying too hard to be efficient here. In many cases we won't + -- have to construct blockCtxsU in the first place. + ticksToCopy :: CmmTickScope -> [CmmTickish] + ticksToCopy (CombinedScope scp s) = go s + where go s | scp `isTickSubScope` s = [] -- done + | SubScope _ s' <- s = ticks ++ go s' + | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2 + | otherwise = panic "ticksToCopy impossible" + where ticks = bCtxsTicks $ maybe [] toList $ Map.lookup s blockCtxs + ticksToCopy _ = [] + bCtxsTicks = concatMap (blockTicks . fst) + + -- Finding the "best" source tick is somewhat arbitrary -- we + -- select the first source span, while preferring source ticks + -- from the same source file. Furthermore, dumps take priority + -- (if we generated one, we probably want debug information to + -- refer to it). + bestSrcTick = minimumBy (comparing rangeRating) + rangeRating (span, _) + | srcSpanFile span == thisFile = 1 + | otherwise = 2 :: Int + thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc + + -- Returns block tree for this scope as well as all nested + -- scopes. Note that if there are multiple blocks in the (exact) + -- same scope we elect one as the "branch" node and add the rest + -- as children. + blocksForScope :: Maybe (RealSrcSpan, LexicalFastString) -> (CmmTickScope, NonEmpty BlockContext) -> DebugBlock + blocksForScope cstick (scope, bctx:|bctxs) = mkBlock True bctx + where nested = fromMaybe [] $ Map.lookup scope scopeMap + childs = map (mkBlock False) bctxs ++ + map (blocksForScope stick) nested + + mkBlock :: Bool -> BlockContext -> DebugBlock + mkBlock top (block, prc) + = DebugBlock { dblProcedure = g_entry graph + , dblLabel = label + , dblCLabel = blockLbl label + , dblHasInfoTbl = isJust info + , dblParent = Nothing + , dblTicks = ticks + , dblPosition = Nothing -- see cmmDebugLink + , dblSourceTick = uncurry SourceNote <$> stick + , dblBlocks = blocks + , dblUnwind = [] + } + where (infos, graph) = case prc of + CmmProc infos _ _ graph -> (infos, graph) + CmmData _ v -> case v of + label = entryLabel block + info = mapLookup label infos + blocks | top = seqList childs childs + | otherwise = [] + + -- A source tick scopes over all nested blocks. However + -- their source ticks might take priority. + isSourceTick (SourceNote span a) = Just (span, a) + isSourceTick _ = Nothing + -- Collect ticks from all blocks inside the tick scope. + -- We attempt to filter out duplicates while we're at it. + ticks = nubBy (flip tickishContains) $ + bCtxsTicks bctxs ++ ticksToCopy scope + stick = case nonEmpty $ mapMaybe isSourceTick ticks of + Nothing -> cstick + Just sticks -> Just $! bestSrcTick (sticks `NE.appendList` maybeToList cstick) + +-- | Build a map of blocks sorted by their tick scopes +-- +-- This involves a pre-order traversal, as we want blocks in rough +-- control flow order (so ticks have a chance to be sorted in the +-- right order). +blockContexts :: [GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph] -> Map.Map CmmTickScope (NonEmpty BlockContext) +blockContexts = Map.map NE.reverse . foldr walkProc Map.empty + where walkProc :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph + -> Map.Map CmmTickScope (NonEmpty BlockContext) + -> Map.Map CmmTickScope (NonEmpty BlockContext) + walkProc CmmData{} m = m + walkProc prc@(CmmProc _ _ _ graph) m + | mapNull blocks = m + | otherwise = snd $ walkBlock prc entry (emptyLbls, m) + where blocks = toBlockMap graph + entry = [mapFind (g_entry graph) blocks] + emptyLbls = setEmpty :: LabelSet + + walkBlock :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph -> [Block CmmNode C C] + -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext)) + -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext)) + walkBlock _ [] c = c + walkBlock prc (block:blocks) (visited, m) = case (prc, setMember lbl visited) of + (CmmProc x y z graph, False) -> + let succs = flip mapFind (toBlockMap graph) <$> + successors (lastNode block) in + walkBlock prc blocks $ + walkBlock prc succs + ( lbl `setInsert` visited + , insertMultiNE scope (block, CmmProc x y z graph) m ) + _ -> walkBlock prc blocks (visited, m) + where CmmEntry lbl scope = firstNode block + mapFind = mapFindWithDefault (error "contextTree: block not found!") + +insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a] +insertMulti k v = Map.insertWith (const (v:)) k [v] + +insertMultiNE :: Ord k => k -> a -> Map.Map k (NonEmpty a) -> Map.Map k (NonEmpty a) +insertMultiNE k v = Map.insertWith (const (v NE.<|)) k (NE.singleton v) + +cmmDebugLabels :: (BlockId -> Bool) -> (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label] +cmmDebugLabels is_valid_label isMeta nats = seqList lbls lbls + where -- Find order in which procedures will be generated by the + -- back-end (that actually matters for DWARF generation). + -- + -- Note that we might encounter blocks that are missing or only + -- consist of meta instructions -- we will declare them missing, + -- which will skip debug data generation without messing up the + -- block hierarchy. + lbls = filter is_valid_label $ map blockId $ filter (not . allMeta) $ concatMap getBlocks nats + getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs + getBlocks _other = [] + allMeta (BasicBlock _ instrs) = all isMeta instrs + +-- | Sets position and unwind table fields in the debug block tree according to +-- native generated code. +cmmDebugLink :: [Label] -> LabelMap [UnwindPoint] + -> [DebugBlock] -> [DebugBlock] +cmmDebugLink labels unwindPts blocks = mapMaybe link blocks + where blockPos :: LabelMap Int + blockPos = mapFromList $ flip zip [0..] labels + link block = case mapLookup (dblLabel block) blockPos of + -- filter dead blocks: we generated debug infos from Cmm blocks but + -- asm-shortcutting may remove some blocks later (#22792) + Nothing -> Nothing + pos -> Just $ block + { dblPosition = pos + , dblBlocks = mapMaybe link (dblBlocks block) + , dblUnwind = fromMaybe mempty $ mapLookup (dblLabel block) unwindPts + } + +-- | Converts debug blocks into a label map for easier lookups +debugToMap :: [DebugBlock] -> LabelMap DebugBlock +debugToMap = mapUnions . map go + where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b) + +{- +Note [What is this unwinding business?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Unwinding tables are a variety of debugging information used by debugging tools +to reconstruct the execution history of a program at runtime. These tables +consist of sets of "instructions", one set for every instruction in the program, +which describe how to reconstruct the state of the machine at the point where +the current procedure was called. For instance, consider the following annotated +pseudo-code, + + a_fun: + add rsp, 8 -- unwind: rsp = rsp - 8 + mov rax, 1 -- unwind: rax = unknown + call another_block + sub rsp, 8 -- unwind: rsp = rsp + +We see that attached to each instruction there is an "unwind" annotation, which +provides a relationship between each updated register and its value at the +time of entry to a_fun. This is the sort of information that allows gdb to give +you a stack backtrace given the execution state of your program. This +unwinding information is captured in various ways by various debug information +formats; in the case of DWARF (the only format supported by GHC) it is known as +Call Frame Information (CFI) and can be found in the .debug.frames section of +your object files. + +Currently we only bother to produce unwinding information for registers which +are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp +(which is the STG stack pointer) and $rsp (the C stack pointer). + +Let's consider how GHC would annotate a C-- program with unwinding information +with a typical C-- procedure as would come from the STG-to-Cmm code generator, + + entry() + { c2fe: + v :: P64 = R2; + if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg; + c2ff: + R2 = v :: P64; + R1 = test_closure; + call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; + c2fg: + I64[Sp - 8] = c2dD; + R1 = v :: P64; + Sp = Sp - 8; // Sp updated here + if (R1 & 7 != 0) goto c2dD; else goto c2dE; + c2dE: + call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8; + c2dD: + w :: P64 = R1; + Hp = Hp + 48; + if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi; + ... + }, + +Let's consider how this procedure will be decorated with unwind information +(largely by GHC.Cmm.LayoutStack). Naturally, when we enter the procedure `entry` the +value of Sp is no different from what it was at its call site. Therefore we will +add an `unwind` statement saying this at the beginning of its unwind-annotated +code, + + entry() + { c2fe: + unwind Sp = Just Sp + 0; + v :: P64 = R2; + if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg; + +After c2fe we may pass to either c2ff or c2fg; let's first consider the +former. In this case there is nothing in particular that we need to do other +than reiterate what we already know about Sp, + + c2ff: + unwind Sp = Just Sp + 0; + R2 = v :: P64; + R1 = test_closure; + call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; + +In contrast, c2fg updates Sp midway through its body. To ensure that unwinding +can happen correctly after this point we must include an unwind statement there, +in addition to the usual beginning-of-block statement, + + c2fg: + unwind Sp = Just Sp + 0; + I64[Sp - 8] = c2dD; + R1 = v :: P64; + Sp = Sp - 8; + unwind Sp = Just Sp + 8; + if (R1 & 7 != 0) goto c2dD; else goto c2dE; + +The remaining blocks are simple, + + c2dE: + unwind Sp = Just Sp + 8; + call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8; + c2dD: + unwind Sp = Just Sp + 8; + w :: P64 = R1; + Hp = Hp + 48; + if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi; + ... + }, + + +The flow of unwinding information through the compiler is a bit convoluted: + + * C-- begins life in StgToCmm without any unwind information. This is because we + haven't actually done any register assignment or stack layout yet, so there + is no need for unwind information. + + * GHC.Cmm.LayoutStack figures out how to layout each procedure's stack, and produces + appropriate unwinding nodes for each adjustment of the STG Sp register. + + * The unwind nodes are carried through the sinking pass. Currently this is + guaranteed not to invalidate unwind information since it won't touch stores + to Sp, but this will need revisiting if CmmSink gets smarter in the future. + + * Eventually we make it to the native code generator backend which can then + preserve the unwind nodes in its machine-specific instructions. In so doing + the backend can also modify or add unwinding information; this is necessary, + for instance, in the case of x86-64, where adjustment of $rsp may be + necessary during calls to native foreign code due to the native calling + convention. + + * The NCG then retrieves the final unwinding table for each block from the + backend with extractUnwindPoints. + + * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen + + * These DebugBlocks are then converted to, e.g., DWARF unwinding tables + (by the Dwarf module) and emitted in the final object. + +See also: + Note [Unwinding information in the NCG] in "GHC.CmmToAsm", + Note [Unwind pseudo-instruction in Cmm], + Note [Debugging DWARF unwinding info]. + + +Note [Debugging DWARF unwinding info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For debugging generated unwinding info I've found it most useful to dump the +disassembled binary with objdump -D and dump the debug info with +readelf --debug-dump=frames-interp. + +You should get something like this: + + 0000000000000010 : + 10: 48 83 c5 18 add $0x18,%rbp + 14: ff 65 00 jmpq *0x0(%rbp) + +and: + + Contents of the .debug_frame section: + + 00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16 + LOC CFA rbp rsp ra + 0000000000000000 rbp+0 v+0 s c+0 + + 00000018 0000000000000024 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017 + LOC CFA rbp rsp ra + 000000000000000f rbp+0 v+0 s c+0 + 000000000000000f rbp+24 v+0 s c+0 + +To read it http://www.dwarfstd.org/doc/dwarf-2.0.0.pdf has a nice example in +Appendix 5 (page 101 of the pdf) and more details in the relevant section. + +The key thing to keep in mind is that the value at LOC is the value from +*before* the instruction at LOC executes. In other words it answers the +question: if my $rip is at LOC, how do I get the relevant values given the +values obtained through unwinding so far. + +If the readelf --debug-dump=frames-interp output looks wrong, it may also be +useful to look at readelf --debug-dump=frames, which is closer to the +information that GHC generated. + +It's also useful to dump the relevant Cmm with -ddump-cmm -ddump-opt-cmm +-ddump-cmm-proc -ddump-cmm-verbose. Note [Unwind pseudo-instruction in Cmm] +explains how to interpret it. + +Inside gdb there are a couple useful commands for inspecting frames. +For example: + + gdb> info frame + +It shows the values of registers obtained through unwinding. + +Another useful thing to try when debugging the DWARF unwinding is to enable +extra debugging output in GDB: + + gdb> set debug frame 1 + +This makes GDB produce a trace of its internal workings. Having gone this far, +it's just a tiny step to run GDB in GDB. Make sure you install debugging +symbols for gdb if you obtain it through a package manager. + +Keep in mind that the current release of GDB has an instruction pointer handling +heuristic that works well for C-like languages, but doesn't always work for +Haskell. See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types" for more details. + +Note [Unwind pseudo-instruction in Cmm] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +One of the possible CmmNodes is a CmmUnwind pseudo-instruction. It doesn't +generate any assembly, but controls what DWARF unwinding information gets +generated. + +It's important to understand what ranges of code the unwind pseudo-instruction +refers to. +For a sequence of CmmNodes like: + + A // starts at addr X and ends at addr Y-1 + unwind Sp = Just Sp + 16; + B // starts at addr Y and ends at addr Z + +the unwind statement reflects the state after A has executed, but before B +has executed. If you consult the Note [Debugging DWARF unwinding info], the +LOC this information will end up in is Y. +-} + +-- | A label associated with an 'UnwindTable' +data UnwindPoint = UnwindPoint !CLabel !UnwindTable + +instance OutputableP Platform UnwindPoint where + pdoc env (UnwindPoint lbl uws) = + braces $ pprAsmLabel env lbl <> colon + <+> hsep (punctuate comma $ map pprUw $ Map.toList uws) + where + pprUw (g, expr) = ppr g <> char '=' <> pdoc env expr + +-- | Maps registers to expressions that yield their "old" values +-- further up the stack. Most interesting for the stack pointer @Sp@, +-- but might be useful to document saved registers, too. Note that a +-- register's value will be 'Nothing' when the register's previous +-- value cannot be reconstructed. +type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr) + +-- | Expressions, used for unwind information +data UnwindExpr = UwConst !Int -- ^ literal value + | UwReg !GlobalRegUse !Int -- ^ register plus offset + | UwDeref UnwindExpr -- ^ pointer dereferencing + | UwLabel CLabel + | UwPlus UnwindExpr UnwindExpr + | UwMinus UnwindExpr UnwindExpr + | UwTimes UnwindExpr UnwindExpr + deriving (Eq) + +instance OutputableP Platform UnwindExpr where + pdoc = pprUnwindExpr 0 + +pprUnwindTable :: IsLine doc => Platform -> UnwindTable -> doc +pprUnwindTable platform u = brackets (fsep (punctuate comma (map print_entry (Map.toList u)))) + where print_entry (reg, Nothing) = + parens (sep [pprGlobalReg reg, text "Nothing"]) + print_entry (reg, Just x) = + parens (sep [pprGlobalReg reg, text "Just" <+> pprUnwindExpr 0 platform x]) + -- Follow instance Outputable (Map.Map GlobalReg (Maybe UnwindExpr)) + +pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc +pprUnwindExpr p env = \case + UwConst i -> int i + UwReg g 0 -> pprGlobalRegUse g + UwReg g x -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x)) + UwDeref e -> char '*' <> pprUnwindExpr 3 env e + UwLabel l -> pprAsmLabel env l + UwPlus e0 e1 + | p <= 0 -> pprUnwindExpr 0 env e0 <> char '+' <> pprUnwindExpr 0 env e1 + UwMinus e0 e1 + | p <= 0 -> pprUnwindExpr 1 env e0 <> char '-' <> pprUnwindExpr 1 env e1 + UwTimes e0 e1 + | p <= 1 -> pprUnwindExpr 2 env e0 <> char '*' <> pprUnwindExpr 2 env e1 + other -> parens (pprUnwindExpr 0 env other) +{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc #-} +{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Conversion of Cmm expressions to unwind expressions. We check for +-- unsupported operator usages and simplify the expression as far as +-- possible. +toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr +toUnwindExpr _ (CmmLit (CmmInt i _)) = UwConst (fromIntegral i) +toUnwindExpr _ (CmmLit (CmmLabel l)) = UwLabel l +toUnwindExpr _ (CmmRegOff (CmmGlobal g) i) = UwReg g i +toUnwindExpr _ (CmmReg (CmmGlobal g)) = UwReg g 0 +toUnwindExpr platform (CmmLoad e _ _) = UwDeref (toUnwindExpr platform e) +toUnwindExpr platform e@(CmmMachOp op [e1, e2]) = + case (op, toUnwindExpr platform e1, toUnwindExpr platform e2) of + (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y) + (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y) + (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y) + (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y) + (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y) + (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y) + (MO_Add{}, u1, u2 ) -> UwPlus u1 u2 + (MO_Sub{}, u1, u2 ) -> UwMinus u1 u2 + (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2 + _otherwise -> pprPanic "Unsupported operator in unwind expression!" + (pdoc platform e) +toUnwindExpr platform e + = pprPanic "Unsupported unwind expression!" (pdoc platform e) diff --git a/GHC/Cmm/Dominators.hs b/GHC/Cmm/Dominators.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Dominators.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE GADTs #-} + +module GHC.Cmm.Dominators + ( + -- * Dominator analysis and representation of results + DominatorSet(..) + , GraphWithDominators(..) + , RPNum + , graphWithDominators + + -- * Utility functions on graphs or graphs-with-dominators + , graphMap + , gwdRPNumber + , gwdDominatorsOf + , gwdDominatorTree + + -- * Utility functions on dominator sets + , dominatorsMember + , intersectDominators + ) +where + +import GHC.Prelude + +import Data.Array.IArray +import qualified Data.Tree as Tree + +import Data.Word + +import qualified GHC.CmmToAsm.CFG.Dominators as LT + +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm + +import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>)) +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Word64 (intToWord64) +import qualified GHC.Data.Word64Map as WM +import qualified GHC.Data.Word64Set as WS + + +-- | =Dominator sets +-- +-- Node X dominates node Y if and only if every path from the entry to +-- Y includes X. Node Y technically dominates itself, but it is +-- never included in the *representation* of its dominator set. +-- +-- A dominator set is represented as a linked list in which each node +-- points to its *immediate* dominator, which is its parent in the +-- dominator tree. In many circumstances the immediate dominator +-- will be the only dominator of interest. + +data DominatorSet = ImmediateDominator { ds_label :: Label -- ^ Label of the immediate dominator. + , ds_parent :: DominatorSet -- ^ Set of nodes dominating the immediate dominator. + } + | EntryNode + deriving (Eq) + +instance Outputable DominatorSet where + ppr EntryNode = text "entry" + ppr (ImmediateDominator l parent) = ppr l <+> text "->" <+> ppr parent + + + +-- | Reverse postorder number of a node in a CFG +newtype RPNum = RPNum Int + deriving (Eq, Ord) +-- in reverse postorder, nodes closer to the entry have smaller numbers + +instance Show RPNum where + show (RPNum i) = "RP" ++ show i + +instance Outputable RPNum where + ppr (RPNum i) = hcat [text "RP", int i] + -- using `(<>)` would conflict with Semigroup + + + +dominatorsMember :: Label -> DominatorSet -> Bool +-- ^ Use to tell if the given label is in the given +-- dominator set. Which is to say, does the bloc +-- with with given label _properly_ and _non-vacuously_ +-- dominate the node whose dominator set this is? +-- +-- Takes linear time in the height of the dominator tree, +-- but uses space efficiently. +dominatorsMember lbl (ImmediateDominator l p) = l == lbl || dominatorsMember lbl p +dominatorsMember _ EntryNode = False + + +-- | Intersect two dominator sets to produce a third dominator set. +-- This function takes time linear in the size of the sets. +-- As such it is inefficient and should be used only for things +-- like visualizations or linters. +intersectDominators :: DominatorSet -> DominatorSet -> DominatorSet +intersectDominators ds ds' = commonPrefix (revDoms ds []) (revDoms ds' []) EntryNode + where revDoms EntryNode prev = prev + revDoms (ImmediateDominator lbl doms) prev = revDoms doms (lbl:prev) + commonPrefix (a:as) (b:bs) doms + | a == b = commonPrefix as bs (ImmediateDominator a doms) + commonPrefix _ _ doms = doms + + +-- | The result of dominator analysis. Also includes a reverse +-- postorder numbering, which is needed for dominator analysis +-- and for other (downstream) analyses. +-- +-- Invariant: Dominators, graph, and RP numberings include only *reachable* blocks. +data GraphWithDominators node = + GraphWithDominators { gwd_graph :: GenCmmGraph node + , gwd_dominators :: LabelMap DominatorSet + , gwd_rpnumbering :: LabelMap RPNum + } + + +-- | Call this function with a `CmmGraph` to get back the results of a +-- dominator analysis of that graph (as well as a reverse postorder +-- numbering). The result also includes the subgraph of the original +-- graph that contains only the reachable blocks. +graphWithDominators :: forall node . + (NonLocal node, HasDebugCallStack) + => GenCmmGraph node + -> GraphWithDominators node + +-- The implementation uses the Lengauer-Tarjan algorithm from the x86 +-- back end. + +-- Technically, we do not need Word64 here, however the dominators code +-- has to accomodate Word64 for other uses. + +graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap + where rpblocks = revPostorderFrom (graphMap g) (g_entry g) + rplabels' = map entryLabel rpblocks + rplabels :: Array Word64 Label + rplabels = listArray bounds rplabels' + + rpmap :: LabelMap RPNum + rpmap = mapFromList $ zipWith kvpair rpblocks [0..] + where kvpair block i = (entryLabel block, RPNum i) + + labelIndex :: Label -> Word64 + labelIndex = flip findLabelIn imap + where imap :: LabelMap Word64 + imap = mapFromList $ zip rplabels' [0..] + blockIndex = labelIndex . entryLabel + + bounds :: (Word64, Word64) + bounds = (0, intToWord64 (length rpblocks - 1)) + + ltGraph :: [Block node C C] -> LT.Graph + ltGraph [] = WM.empty + ltGraph (block:blocks) = + WM.insert + (blockIndex block) + (WS.fromList $ map labelIndex $ successors block) + (ltGraph blocks) + + idom_array :: Array Word64 LT.Node + idom_array = array bounds $ LT.idom (0, ltGraph rpblocks) + + domSet 0 = EntryNode + domSet i = ImmediateDominator (rplabels ! d) (doms ! d) + where d = idom_array ! i + doms = tabulate bounds domSet + + dmap = mapFromList $ zipWith (\lbl i -> (lbl, domSet i)) rplabels' [0..] + +reachable :: NonLocal node => [Block node C C] -> GenCmmGraph node -> GenCmmGraph node +reachable blocks g = g { g_graph = GMany NothingO blockmap NothingO } + where blockmap = mapFromList [(entryLabel b, b) | b <- blocks] + + +-- | =Utility functions + +-- | Call `graphMap` to get the mapping from `Label` to `Block` that +-- is embedded in every `CmmGraph`. +graphMap :: GenCmmGraph n -> LabelMap (Block n C C) +graphMap (CmmGraph { g_graph = GMany NothingO blockmap NothingO }) = blockmap + +-- | Use `gwdRPNumber` on the result of the dominator analysis to get +-- a mapping from the `Label` of each reachable block to the reverse +-- postorder number of that block. +gwdRPNumber :: HasDebugCallStack => GraphWithDominators node -> Label -> RPNum +gwdRPNumber g l = findLabelIn l (gwd_rpnumbering g) + +findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a +findLabelIn lbl = mapFindWithDefault failed lbl + where failed = + pprPanic "label not found in result of analysis" (ppr lbl) + +-- | Use `gwdDominatorsOf` on the result of the dominator analysis to get +-- a mapping from the `Label` of each reachable block to the dominator +-- set (and the immediate dominator) of that block. The +-- implementation is space-efficient: intersecting dominator +-- sets share the representation of their intersection. + +gwdDominatorsOf :: HasDebugCallStack => GraphWithDominators node -> Label -> DominatorSet +gwdDominatorsOf g lbl = findLabelIn lbl (gwd_dominators g) + +gwdDominatorTree :: GraphWithDominators node -> Tree.Tree Label +gwdDominatorTree gwd = subtreeAt (g_entry (gwd_graph gwd)) + where subtreeAt label = Tree.Node label $ map subtreeAt $ children label + children l = mapFindWithDefault [] l child_map + child_map :: LabelMap [Label] + child_map = mapFoldlWithKey addParent mapEmpty $ gwd_dominators gwd + where addParent cm _ EntryNode = cm + addParent cm lbl (ImmediateDominator p _) = + mapInsertWith (++) p [lbl] cm + + +-- | Turn a function into an array. Inspired by SML's `Array.tabulate` +tabulate :: (Ix i) => (i, i) -> (i -> e) -> Array i e +tabulate b f = listArray b $ map f $ range b diff --git a/GHC/Cmm/Expr.hs b/GHC/Cmm/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Expr.hs @@ -0,0 +1,581 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHC.Cmm.Expr + ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr + , CmmReg(..), cmmRegType, cmmRegWidth + , CmmLit(..), cmmLitType + , AlignmentSpec(..) + -- TODO: Remove: + , LocalReg(..), localRegType + , GlobalReg(..), isArgReg, globalRegSpillType + , GlobalRegUse(..) + , spReg, hpReg, spLimReg, hpLimReg, nodeReg + , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg + , node, baseReg + + , DefinerOfRegs, UserOfRegs + , foldRegsDefd, foldRegsUsed + , foldLocalRegsDefd, foldLocalRegsUsed + + , RegSet, LocalRegSet, GlobalRegSet + , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet + , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet + , regSetToList + + , isTrivialCmmExpr + , hasNoGlobalRegs + , isLit + , isComparisonExpr + + , Area(..) + , module GHC.Cmm.MachOp + , module GHC.Cmm.Type + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.MachOp +import GHC.Cmm.Type +import GHC.Cmm.Reg +import GHC.Utils.Panic (panic) +import GHC.Utils.Outputable + +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Numeric ( fromRat ) + +import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf) + +----------------------------------------------------------------------------- +-- CmmExpr +-- An expression. Expressions have no side effects. +----------------------------------------------------------------------------- + +data CmmExpr + = CmmLit !CmmLit -- Literal + | CmmLoad !CmmExpr !CmmType !AlignmentSpec + -- Read memory location + | CmmReg !CmmReg -- Contents of register + | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.) + | CmmStackSlot Area {-# UNPACK #-} !Int + -- Addressing expression of a stack slot + -- See Note [CmmStackSlot aliasing] + | CmmRegOff !CmmReg !Int + -- CmmRegOff reg i + -- ** is shorthand only, meaning ** + -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] + -- where rep = typeWidth (cmmRegType reg) + deriving Show + +instance Eq CmmExpr where -- Equality ignores the types + CmmLit l1 == CmmLit l2 = l1==l2 + CmmLoad e1 _ _ == CmmLoad e2 _ _ = e1==e2 + CmmReg r1 == CmmReg r2 = r1==r2 + CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2 + CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2 + CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 + _e1 == _e2 = False + +instance OutputableP Platform CmmExpr where + pdoc = pprExpr + +data AlignmentSpec = NaturallyAligned | Unaligned + deriving (Eq, Ord, Show) + +-- | A stack area is either the stack slot where a variable is spilled +-- or the stack space where function arguments and results are passed. +data Area + = Old -- See Note [Old Area] + | Young {-# UNPACK #-} !BlockId -- Invariant: must be a continuation BlockId + -- See Note [Continuation BlockIds] in GHC.Cmm.Node. + deriving (Eq, Ord, Show) + +instance Outputable Area where + ppr e = pprArea e + +pprArea :: Area -> SDoc +pprArea Old = text "old" +pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] + + +{- Note [Old Area] +~~~~~~~~~~~~~~~~~~ +There is a single call area 'Old', allocated at the extreme old +end of the stack frame (ie just younger than the return address) +which holds: + * incoming (overflow) parameters, + * outgoing (overflow) parameter to tail calls, + * outgoing (overflow) result values + * the update frame (if any) + +Its size is the max of all these requirements. On entry, the stack +pointer will point to the youngest incoming parameter, which is not +necessarily at the young end of the Old area. + +End of note -} + + +{- Note [CmmStackSlot aliasing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When do two CmmStackSlots alias? + + - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M + - T[old+N] aliases with U[old+M] only if the areas actually overlap + +Or more informally, different Areas may overlap with each other. + +An alternative semantics, that we previously had, was that different +Areas do not overlap. The problem that lead to redefining the +semantics of stack areas is described below. + +e.g. if we had + + x = Sp[old + 8] + y = Sp[old + 16] + + Sp[young(L) + 8] = L + Sp[young(L) + 16] = y + Sp[young(L) + 24] = x + call f() returns to L + +if areas semantically do not overlap, then we might optimise this to + + Sp[young(L) + 8] = L + Sp[young(L) + 16] = Sp[old + 8] + Sp[young(L) + 24] = Sp[old + 16] + call f() returns to L + +and now young(L) cannot be allocated at the same place as old, and we +are doomed to use more stack. + + - old+8 conflicts with young(L)+8 + - old+16 conflicts with young(L)+16 and young(L)+8 + +so young(L)+8 == old+24 and we get + + Sp[-8] = L + Sp[-16] = Sp[8] + Sp[-24] = Sp[0] + Sp -= 24 + call f() returns to L + +However, if areas are defined to be "possibly overlapping" in the +semantics, then we cannot commute any loads/stores of old with +young(L), and we will be able to re-use both old+8 and old+16 for +young(L). + + x = Sp[8] + y = Sp[0] + + Sp[8] = L + Sp[0] = y + Sp[-8] = x + Sp = Sp - 8 + call f() returns to L + +Now, the assignments of y go away, + + x = Sp[8] + Sp[8] = L + Sp[-8] = x + Sp = Sp - 8 + call f() returns to L +-} + +data CmmLit + = CmmInt !Integer !Width + -- Interpretation: the 2's complement representation of the value + -- is truncated to the specified size. This is easier than trying + -- to keep the value within range, because we don't know whether + -- it will be used as a signed or unsigned value (the CmmType doesn't + -- distinguish between signed & unsigned). + | CmmFloat Rational !Width + | CmmVec [CmmLit] -- Vector literal + | CmmLabel CLabel -- Address of label + | CmmLabelOff CLabel !Int -- Address of label + byte offset + + -- Due to limitations in the C backend, the following + -- MUST ONLY be used inside the info table indicated by label2 + -- (label2 must be the info label), and label1 must be an + -- SRT, a slow entrypoint or a large bitmap (see the Mangler) + -- Don't use it at all unless tablesNextToCode. + -- It is also used inside the NCG during when generating + -- position-independent code. + | CmmLabelDiffOff CLabel CLabel !Int !Width -- label1 - label2 + offset + -- In an expression, the width just has the effect of MO_SS_Conv + -- from wordWidth to the desired width. + -- + -- In a static literal, the supported Widths depend on the + -- architecture: wordWidth is supported on all + -- architectures. Additionally W32 is supported on x86_64 when + -- using the small memory model. + + | CmmBlock {-# UNPACK #-} !BlockId -- Code label + -- Invariant: must be a continuation BlockId + -- See Note [Continuation BlockIds] in GHC.Cmm.Node. + + | CmmHighStackMark -- A late-bound constant that stands for the max + -- #bytes of stack space used during a procedure. + -- During the stack-layout pass, CmmHighStackMark + -- is replaced by a CmmInt for the actual number + -- of bytes used + deriving (Eq, Show) + +instance OutputableP Platform CmmLit where + pdoc = pprLit + +instance Outputable CmmLit where + ppr (CmmInt n w) = text "CmmInt" <+> ppr n <+> ppr w + ppr (CmmFloat n w) = text "CmmFloat" <+> text (show n) <+> ppr w + ppr (CmmVec xs) = text "CmmVec" <+> ppr xs + ppr (CmmLabel _) = text "CmmLabel" + ppr (CmmLabelOff _ _) = text "CmmLabelOff" + ppr (CmmLabelDiffOff _ _ _ _) = text "CmmLabelDiffOff" + ppr (CmmBlock blk) = text "CmmBlock" <+> ppr blk + ppr CmmHighStackMark = text "CmmHighStackMark" + +cmmExprType :: Platform -> CmmExpr -> CmmType +cmmExprType platform = \case + (CmmLit lit) -> cmmLitType platform lit + (CmmLoad _ rep _) -> rep + (CmmReg reg) -> cmmRegType reg + (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args) + (CmmRegOff reg _) -> cmmRegType reg + (CmmStackSlot _ _) -> bWord platform -- an address + -- Careful though: what is stored at the stack slot may be bigger than + -- an address + +cmmLitType :: Platform -> CmmLit -> CmmType +cmmLitType platform = \case + (CmmInt _ width) -> cmmBits width + (CmmFloat _ width) -> cmmFloat width + (CmmVec []) -> panic "cmmLitType: CmmVec []" + (CmmVec (l:ls)) -> let ty = cmmLitType platform l + in if all (`cmmEqType` ty) (map (cmmLitType platform) ls) + then cmmVec (1+length ls) ty + else panic "cmmLitType: CmmVec" + (CmmLabel lbl) -> cmmLabelType platform lbl + (CmmLabelOff lbl _) -> cmmLabelType platform lbl + (CmmLabelDiffOff _ _ _ width) -> cmmBits width + (CmmBlock _) -> bWord platform + (CmmHighStackMark) -> bWord platform + +cmmLabelType :: Platform -> CLabel -> CmmType +cmmLabelType platform lbl + | isGcPtrLabel lbl = gcWord platform + | otherwise = bWord platform + +cmmExprWidth :: Platform -> CmmExpr -> Width +cmmExprWidth platform e = typeWidth (cmmExprType platform e) + +-- | Returns an alignment in bytes of a CmmExpr when it's a statically +-- known integer constant, otherwise returns an alignment of 1 byte. +-- The caller is responsible for using with a sensible CmmExpr +-- argument. +cmmExprAlignment :: CmmExpr -> Alignment +cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff) +cmmExprAlignment _ = mkAlignment 1 +-------- +--- Negation for conditional branches + +maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr +maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op + return (CmmMachOp op' args) +maybeInvertCmmExpr _ = Nothing + +--------------------------------------------------- +-- CmmExpr predicates +--------------------------------------------------- + +isTrivialCmmExpr :: CmmExpr -> Bool +isTrivialCmmExpr (CmmLoad _ _ _) = False +isTrivialCmmExpr (CmmMachOp _ _) = False +isTrivialCmmExpr (CmmLit _) = True +isTrivialCmmExpr (CmmReg _) = True +isTrivialCmmExpr (CmmRegOff _ _) = True +isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" + +hasNoGlobalRegs :: CmmExpr -> Bool +hasNoGlobalRegs (CmmLoad e _ _) = hasNoGlobalRegs e +hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es +hasNoGlobalRegs (CmmLit _) = True +hasNoGlobalRegs (CmmReg (CmmLocal _)) = True +hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True +hasNoGlobalRegs _ = False + +isLit :: CmmExpr -> Bool +isLit (CmmLit _) = True +isLit _ = False + +isComparisonExpr :: CmmExpr -> Bool +isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op +isComparisonExpr _ = False + + +----------------------------------------------------------------------------- +-- Register-use information for expressions and other types +----------------------------------------------------------------------------- + +-- | Sets of registers + +-- These are used for dataflow facts, and a common operation is taking +-- the union of two RegSets and then asking whether the union is the +-- same as one of the inputs. UniqSet isn't good here, because +-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary +-- Sets. + +type RegSet r = Set r +type LocalRegSet = RegSet LocalReg +type GlobalRegSet = RegSet GlobalReg + +emptyRegSet :: RegSet r +nullRegSet :: RegSet r -> Bool +elemRegSet :: Ord r => r -> RegSet r -> Bool +extendRegSet :: Ord r => RegSet r -> r -> RegSet r +deleteFromRegSet :: Ord r => RegSet r -> r -> RegSet r +mkRegSet :: Ord r => [r] -> RegSet r +minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r +sizeRegSet :: RegSet r -> Int +regSetToList :: RegSet r -> [r] + +emptyRegSet = Set.empty +nullRegSet = Set.null +elemRegSet = Set.member +extendRegSet = flip Set.insert +deleteFromRegSet = flip Set.delete +mkRegSet = Set.fromList +minusRegSet = Set.difference +plusRegSet = Set.union +timesRegSet = Set.intersection +sizeRegSet = Set.size +regSetToList = Set.toList + +class Ord r => UserOfRegs r a where + foldRegsUsed :: Platform -> (b -> r -> b) -> b -> a -> b + +foldLocalRegsUsed :: UserOfRegs LocalReg a + => Platform -> (b -> LocalReg -> b) -> b -> a -> b +foldLocalRegsUsed = foldRegsUsed + +class Ord r => DefinerOfRegs r a where + foldRegsDefd :: Platform -> (b -> r -> b) -> b -> a -> b + +foldLocalRegsDefd :: DefinerOfRegs LocalReg a + => Platform -> (b -> LocalReg -> b) -> b -> a -> b +foldLocalRegsDefd = foldRegsDefd + +instance UserOfRegs LocalReg CmmReg where + foldRegsUsed _ f z (CmmLocal reg) = f z reg + foldRegsUsed _ _ z (CmmGlobal _) = z + +instance DefinerOfRegs LocalReg CmmReg where + foldRegsDefd _ f z (CmmLocal reg) = f z reg + foldRegsDefd _ _ z (CmmGlobal _) = z + +instance UserOfRegs GlobalReg CmmReg where + {-# INLINEABLE foldRegsUsed #-} + foldRegsUsed _ _ z (CmmLocal _) = z + foldRegsUsed _ f z (CmmGlobal (GlobalRegUse reg _)) = f z reg + +instance UserOfRegs GlobalRegUse CmmReg where + {-# INLINEABLE foldRegsUsed #-} + foldRegsUsed _ _ z (CmmLocal _) = z + foldRegsUsed _ f z (CmmGlobal reg) = f z reg +instance DefinerOfRegs GlobalReg CmmReg where + foldRegsDefd _ _ z (CmmLocal _) = z + foldRegsDefd _ f z (CmmGlobal (GlobalRegUse reg _)) = f z reg + +instance DefinerOfRegs GlobalRegUse CmmReg where + foldRegsDefd _ _ z (CmmLocal _) = z + foldRegsDefd _ f z (CmmGlobal reg) = f z reg + +instance Ord r => UserOfRegs r r where + foldRegsUsed _ f z r = f z r + +instance Ord r => DefinerOfRegs r r where + foldRegsDefd _ f z r = f z r + +instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where + -- The (Ord r) in the context is necessary here + -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance + {-# INLINEABLE foldRegsUsed #-} + foldRegsUsed platform f !z e = expr z e + where expr z (CmmLit _) = z + expr z (CmmLoad addr _ _) = foldRegsUsed platform f z addr + expr z (CmmReg r) = foldRegsUsed platform f z r + expr z (CmmMachOp _ exprs) = foldRegsUsed platform f z exprs + expr z (CmmRegOff r _) = foldRegsUsed platform f z r + expr z (CmmStackSlot _ _) = z + +instance UserOfRegs r a => UserOfRegs r [a] where + foldRegsUsed platform f set as = foldl' (foldRegsUsed platform f) set as + {-# INLINABLE foldRegsUsed #-} + +instance DefinerOfRegs r a => DefinerOfRegs r [a] where + foldRegsDefd platform f set as = foldl' (foldRegsDefd platform f) set as + {-# INLINABLE foldRegsDefd #-} + +-- -------------------------------------------------------------------------- +-- Pretty-printing expressions +-- -------------------------------------------------------------------------- + +pprExpr :: Platform -> CmmExpr -> SDoc +pprExpr platform e + = case e of + CmmRegOff reg i -> + pprExpr platform (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) + where rep = typeWidth (cmmRegType reg) + CmmLit lit -> pprLit platform lit + _other -> pprExpr1 platform e + +-- Here's the precedence table from GHC.Cmm.Parser: +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +-- %left '|' +-- %left '^' +-- %left '&' +-- %left '>>' '<<' +-- %left '-' '+' +-- %left '/' '*' '%' +-- %right '~' + +-- We just cope with the common operators for now, the rest will get +-- a default conservative behaviour. + +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc +pprExpr1 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp1 op + = pprExpr7 platform x <+> doc <+> pprExpr7 platform y +pprExpr1 platform e = pprExpr7 platform e + +infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc + +infixMachOp1 (MO_Eq _) = Just (text "==") +infixMachOp1 (MO_Ne _) = Just (text "!=") +infixMachOp1 (MO_Shl _) = Just (text "<<") +infixMachOp1 (MO_U_Shr _) = Just (text ">>") +infixMachOp1 (MO_U_Ge _) = Just (text ">=") +infixMachOp1 (MO_U_Le _) = Just (text "<=") +infixMachOp1 (MO_U_Gt _) = Just (char '>') +infixMachOp1 (MO_U_Lt _) = Just (char '<') +infixMachOp1 _ = Nothing + +-- %left '-' '+' +pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 + = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) +pprExpr7 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp7 op + = pprExpr7 platform x <+> doc <+> pprExpr8 platform y +pprExpr7 platform e = pprExpr8 platform e + +infixMachOp7 (MO_Add _) = Just (char '+') +infixMachOp7 (MO_Sub _) = Just (char '-') +infixMachOp7 _ = Nothing + +-- %left '/' '*' '%' +pprExpr8 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp8 op + = pprExpr8 platform x <+> doc <+> pprExpr9 platform y +pprExpr8 platform e = pprExpr9 platform e + +infixMachOp8 (MO_U_Quot _) = Just (char '/') +infixMachOp8 (MO_Mul _) = Just (char '*') +infixMachOp8 (MO_U_Rem _) = Just (char '%') +infixMachOp8 _ = Nothing + +pprExpr9 :: Platform -> CmmExpr -> SDoc +pprExpr9 platform e = + case e of + CmmLit lit -> pprLit1 platform lit + CmmLoad expr rep align + -> let align_mark = + case align of + NaturallyAligned -> empty + Unaligned -> text "^" + in ppr rep <> align_mark <> brackets (pdoc platform expr) + CmmReg reg -> ppr reg + CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) + CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) + CmmMachOp mop args -> genMachOp platform mop args + +genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc +genMachOp platform (MO_RelaxedRead w) [x] = + ppr (cmmBits w) <> text "!" <> brackets (pdoc platform x) +genMachOp platform mop args + | Just doc <- infixMachOp mop = case args of + -- dyadic + [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y + + -- unary + [x] -> doc <> pprExpr9 platform x + + _ -> pprTrace "GHC.Cmm.Expr.genMachOp: machop with strange number of args" + (pprMachOp mop <+> + parens (hcat $ punctuate comma (map (pprExpr platform) args))) + empty + + | isJust (infixMachOp1 mop) + || isJust (infixMachOp7 mop) + || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args)) + + | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args)) + where ppr_op = text (map (\c -> if c == ' ' then '_' else c) + (show mop)) + -- replace spaces in (show mop) with underscores, + +-- +-- Unsigned ops on the word size of the machine get nice symbols. +-- All else get dumped in their ugly format. +-- +infixMachOp :: MachOp -> Maybe SDoc +infixMachOp mop + = case mop of + MO_And _ -> Just $ char '&' + MO_Or _ -> Just $ char '|' + MO_Xor _ -> Just $ char '^' + MO_Not _ -> Just $ char '~' + MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) + _ -> Nothing + +-- -------------------------------------------------------------------------- +-- Pretty-printing literals +-- +-- To minimise line noise we adopt the convention that if the literal +-- has the natural machine word size, we do not append the type +-- -------------------------------------------------------------------------- + +pprLit :: Platform -> CmmLit -> SDoc +pprLit platform lit = case lit of + CmmInt i rep -> + hcat [ (if i < 0 then parens else id)(integer i) + , ppUnless (rep == wordWidth platform) $ + space <> dcolon <+> ppr rep ] + + CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] + CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>' + CmmLabel clbl -> pdoc platform clbl + CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i + CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-' + <> pdoc platform clbl2 <> ppr_offset i + CmmBlock id -> ppr id + CmmHighStackMark -> text "" + +pprLit1 :: Platform -> CmmLit -> SDoc +pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit) +pprLit1 platform lit = pprLit platform lit + +ppr_offset :: Int -> SDoc +ppr_offset i + | i==0 = empty + | i>=0 = char '+' <> int i + | otherwise = char '-' <> int (-i) + +commafy :: [SDoc] -> SDoc +commafy xs = fsep $ punctuate comma xs diff --git a/GHC/Cmm/GenericOpt.hs b/GHC/Cmm/GenericOpt.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/GenericOpt.hs @@ -0,0 +1,212 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1993-2004 +-- +-- +-- ----------------------------------------------------------------------------- + +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnboxedTuples #-} + +module GHC.Cmm.GenericOpt + ( cmmToCmm + ) +where + +import GHC.Prelude hiding (head) +import GHC.Platform +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Opt ( cmmMachOpFold ) +import GHC.Cmm.CLabel +import GHC.Data.FastString +import GHC.Unit +import Control.Monad.Trans.Reader +import GHC.Utils.Monad.State.Strict as Strict + +-- ----------------------------------------------------------------------------- +-- Generic Cmm optimiser + +{- +Here we do: + + (a) Constant folding + (c) Position independent code and dynamic linking + (i) introduce the appropriate indirections + and position independent refs + (ii) compile a list of imported symbols + (d) Some arch-specific optimizations + +(a) will be moving to the new Hoopl pipeline, however, (c) and +(d) are only needed by the native backend and will continue to live +here. + +Ideas for other things we could do (put these in Hoopl please!): + + - shortcut jumps-to-jumps + - simple CSE: if an expr is assigned to a temp, then replace later occs of + that expr with the temp, until the expr is no longer valid (can push through + temp assignments, and certain assigns to mem...) +-} + +cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel]) +cmmToCmm _ top@(CmmData _ _) = (top, []) +cmmToCmm config (CmmProc info lbl live graph) + = runCmmOpt config $ + do blocks' <- mapM cmmBlockConFold (toBlockList graph) + return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') + +type OptMResult a = (# a, [CLabel] #) + +pattern OptMResult :: a -> b -> (# a, b #) +pattern OptMResult x y = (# x, y #) +{-# COMPLETE OptMResult #-} + +newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a) + deriving (Functor, Applicative, Monad) via (ReaderT NCGConfig (Strict.State [CLabel])) + +instance CmmMakeDynamicReferenceM CmmOptM where + addImport = addImportCmmOpt + +addImportCmmOpt :: CLabel -> CmmOptM () +addImportCmmOpt lbl = CmmOptM $ \_ imports -> OptMResult () (lbl:imports) + +getCmmOptConfig :: CmmOptM NCGConfig +getCmmOptConfig = CmmOptM $ \config imports -> OptMResult config imports + +runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel]) +runCmmOpt config (CmmOptM f) = + case f config [] of + OptMResult result imports -> (result, imports) + +cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock +cmmBlockConFold block = do + let (entry, middle, last) = blockSplit block + stmts = blockToList middle + stmts' <- mapM cmmStmtConFold stmts + last' <- cmmStmtConFold last + return $ blockJoin entry (blockFromList stmts') last' + +-- This does three optimizations, but they're very quick to check, so we don't +-- bother turning them off even when the Hoopl code is active. Since +-- this is on the old Cmm representation, we can't reuse the code either: +-- * reg = reg --> nop +-- * if 0 then jump --> nop +-- * if 1 then jump --> jump +-- We might be tempted to skip this step entirely of not Opt_PIC, but +-- there is some PowerPC code for the non-PIC case, which would also +-- have to be separated. +cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x) +cmmStmtConFold stmt + = case stmt of + CmmAssign reg src + -> do src' <- cmmExprConFold DataReference src + return $ case src' of + CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop") + new_src -> CmmAssign reg new_src + + CmmStore addr src align + -> do addr' <- cmmExprConFold DataReference addr + src' <- cmmExprConFold DataReference src + return $ CmmStore addr' src' align + + CmmCall { cml_target = addr } + -> do addr' <- cmmExprConFold JumpReference addr + return $ stmt { cml_target = addr' } + + CmmUnsafeForeignCall target regs args + -> do target' <- case target of + ForeignTarget e conv -> do + e' <- cmmExprConFold CallReference e + return $ ForeignTarget e' conv + PrimTarget _ -> + return target + args' <- mapM (cmmExprConFold DataReference) args + return $ CmmUnsafeForeignCall target' regs args' + + CmmCondBranch test true false likely + -> do test' <- cmmExprConFold DataReference test + return $ case test' of + CmmLit (CmmInt 0 _) -> CmmBranch false + CmmLit (CmmInt _ _) -> CmmBranch true + _other -> CmmCondBranch test' true false likely + + CmmSwitch expr ids + -> do expr' <- cmmExprConFold DataReference expr + return $ CmmSwitch expr' ids + + other + -> return other + +cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr +cmmExprConFold referenceKind expr = do + config <- getCmmOptConfig + + let expr' = if not (ncgDoConstantFolding config) + then expr + else cmmExprCon config expr + + cmmExprNative referenceKind expr' + +cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr +cmmExprCon config (CmmLoad addr rep align) = CmmLoad (cmmExprCon config addr) rep align +cmmExprCon config (CmmMachOp mop args) + = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args) +cmmExprCon _ other = other + +-- handles both PIC and non-PIC cases... a very strange mixture +-- of things to do. +cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr +cmmExprNative referenceKind expr = do + config <- getCmmOptConfig + let platform = ncgPlatform config + arch = platformArch platform + case expr of + CmmLoad addr rep align + -> do addr' <- cmmExprNative DataReference addr + return $ CmmLoad addr' rep align + + CmmMachOp mop args + -> do args' <- mapM (cmmExprNative DataReference) args + return $ CmmMachOp mop args' + + CmmLit (CmmBlock id) + -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id))) + -- we must convert block Ids to CLabels here, because we + -- might have to do the PIC transformation. Hence we must + -- not modify BlockIds beyond this point. + + CmmLit (CmmLabel lbl) + -> cmmMakeDynamicReference config referenceKind lbl + CmmLit (CmmLabelOff lbl off) + -> do dynRef <- cmmMakeDynamicReference config referenceKind lbl + -- need to optimize here, since it's late + return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [ + dynRef, + (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform)) + ] + + -- On powerpc (non-PIC), it's easier to jump directly to a label than + -- to use the register table, so we replace these registers + -- with the corresponding labels: + CmmReg (CmmGlobal (GlobalRegUse EagerBlackholeInfo _)) + | arch == ArchPPC && not (ncgPIC config) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info"))) + CmmReg (CmmGlobal (GlobalRegUse GCEnter1 _)) + | arch == ArchPPC && not (ncgPIC config) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1"))) + CmmReg (CmmGlobal (GlobalRegUse GCFun _)) + | arch == ArchPPC && not (ncgPIC config) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun"))) + + other + -> return other diff --git a/GHC/Cmm/Graph.hs b/GHC/Cmm/Graph.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Graph.hs @@ -0,0 +1,498 @@ +{-# LANGUAGE GADTs #-} + +module GHC.Cmm.Graph + ( CmmAGraph, CmmAGraphScoped, CgStmt(..) + , (<*>), catAGraphs + , mkLabel, mkMiddle, mkLast, outOfLine + , lgraphOfAGraph, labelAGraph + + , stackStubExpr + , mkNop, mkAssign, mkStore + , mkUnsafeCall, mkFinalCall, mkCallReturnsTo + , mkJumpReturnsTo + , mkJump, mkJumpExtra + , mkRawJump + , mkCbranch, mkSwitch + , mkReturn, mkComment, mkCallEntry, mkBranch + , mkUnwind + , copyInOflow, copyOutOflow + , noExtraStack + , toCall, Transfer(..) + ) +where + +import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>) + +import GHC.Platform.Profile + +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.CallConv +import GHC.Cmm.Switch (SwitchTargets) + +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Data.FastString +import GHC.Types.ForeignCall +import GHC.Data.OrdList +import GHC.Runtime.Heap.Layout (ByteOff) +import GHC.Types.Unique.DSM +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Panic + + +----------------------------------------------------------------------------- +-- Building Graphs + + +-- | CmmAGraph is a chunk of code consisting of: +-- +-- * ordinary statements (assignments, stores etc.) +-- * jumps +-- * labels +-- * out-of-line labelled blocks +-- +-- The semantics is that control falls through labels and out-of-line +-- blocks. Everything after a jump up to the next label is by +-- definition unreachable code, and will be discarded. +-- +-- Two CmmAGraphs can be stuck together with <*>, with the meaning that +-- control flows from the first to the second. +-- +-- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends) +-- by providing a label for the entry point and a tick scope; see +-- 'labelAGraph'. +type CmmAGraph = OrdList CgStmt +-- | Unlabeled graph with tick scope +type CmmAGraphScoped = (CmmAGraph, CmmTickScope) + +data CgStmt + = CgLabel BlockId CmmTickScope + | CgStmt (CmmNode O O) + | CgLast (CmmNode O C) + | CgFork BlockId CmmAGraph CmmTickScope + +flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> DCmmGraph +flattenCmmAGraph id (stmts_t, tscope) = + CmmGraph { g_entry = id, + g_graph = GMany NothingO body NothingO } + where + body = DWrap [(entryLabel b, b) | b <- flatten id stmts_t tscope [] ] + + -- + -- flatten: given an entry label and a CmmAGraph, make a list of blocks. + -- + -- NB. avoid the quadratic-append trap by passing in the tail of the + -- list. This is important for Very Long Functions (e.g. in T783). + -- + flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C] + -> [Block CmmNode C C] + flatten id g tscope blocks + = flatten1 (fromOL g) block' blocks + where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock + -- + -- flatten0: we are outside a block at this point: any code before + -- the first label is unreachable, so just drop it. + -- + flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C] + flatten0 [] blocks = blocks + + flatten0 (CgLabel id tscope : stmts) blocks + = flatten1 stmts block blocks + where !block = blockJoinHead (CmmEntry id tscope) emptyBlock + + flatten0 (CgFork fork_id stmts_t tscope : rest) blocks + = flatten fork_id stmts_t tscope $ flatten0 rest blocks + + flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks + flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks + + -- + -- flatten1: we have a partial block, collect statements until the + -- next last node to make a block, then call flatten0 to get the rest + -- of the blocks + -- + flatten1 :: [CgStmt] -> Block CmmNode C O + -> [Block CmmNode C C] -> [Block CmmNode C C] + + -- The current block falls through to the end of a function or fork: + -- this code should not be reachable, but it may be referenced by + -- other code that is not reachable. We'll remove it later with + -- dead-code analysis, but for now we have to keep the graph + -- well-formed, so we terminate the block with a branch to the + -- beginning of the current block. + flatten1 [] block blocks + = blockJoinTail block (CmmBranch (entryLabel block)) : blocks + + flatten1 (CgLast stmt : stmts) block blocks + = block' : flatten0 stmts blocks + where !block' = blockJoinTail block stmt + + flatten1 (CgStmt stmt : stmts) block blocks + = flatten1 stmts block' blocks + where !block' = blockSnoc block stmt + + flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks + = flatten fork_id stmts_t tscope $ flatten1 rest block blocks + + -- a label here means that we should start a new block, and the + -- current block should fall through to the new block. + flatten1 (CgLabel id tscp : stmts) block blocks + = blockJoinTail block (CmmBranch id) : + flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks + + + +---------- AGraph manipulation + +(<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph +(<*>) = appOL + +catAGraphs :: [CmmAGraph] -> CmmAGraph +catAGraphs = concatOL + +-- | creates a sequence "goto id; id:" as an AGraph +mkLabel :: BlockId -> CmmTickScope -> CmmAGraph +mkLabel bid scp = unitOL (CgLabel bid scp) + +-- | creates an open AGraph from a given node +mkMiddle :: CmmNode O O -> CmmAGraph +mkMiddle middle = unitOL (CgStmt middle) + +-- | creates a closed AGraph from a given node +mkLast :: CmmNode O C -> CmmAGraph +mkLast last = unitOL (CgLast last) + +-- | A labelled code block; should end in a last node +outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph +outOfLine l (c,s) = unitOL (CgFork l c s) + +-- | allocate a fresh label for the entry point +lgraphOfAGraph :: CmmAGraphScoped -> UniqDSM DCmmGraph +lgraphOfAGraph g = do + u <- getUniqueDSM + return (labelAGraph (mkBlockId u) g) + +-- | use the given BlockId as the label of the entry point +labelAGraph :: BlockId -> CmmAGraphScoped -> DCmmGraph +labelAGraph lbl ag = flattenCmmAGraph lbl ag + +---------- No-ops +mkNop :: CmmAGraph +mkNop = nilOL + +mkComment :: FastString -> CmmAGraph +mkComment fs + -- SDM: generating all those comments takes time, this saved about 4% for me + | debugIsOn = mkMiddle $ CmmComment fs + | otherwise = nilOL + +---------- Assignment and store +mkAssign :: CmmReg -> CmmExpr -> CmmAGraph +mkAssign l (CmmReg r) | l == r = mkNop +mkAssign l r = mkMiddle $ CmmAssign l r + +-- | Assumes natural alignment +mkStore :: CmmExpr -> CmmExpr -> CmmAGraph +mkStore l r = mkMiddle $ CmmStore l r NaturallyAligned + +---------- Control transfer +mkJump :: Profile -> Convention -> CmmExpr + -> [CmmExpr] + -> UpdFrameOffset + -> CmmAGraph +mkJump profile conv e actuals updfr_off = + lastWithArgs profile Jump Old conv actuals updfr_off $ + toCall e Nothing updfr_off 0 + +-- | A jump where the caller says what the live GlobalRegs are. Used +-- for low-level hand-written Cmm. +mkRawJump :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalRegUse] + -> CmmAGraph +mkRawJump profile e updfr_off vols = + lastWithArgs profile Jump Old NativeNodeCall [] updfr_off $ + \arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols + + +mkJumpExtra :: Profile -> Convention -> CmmExpr -> [CmmExpr] + -> UpdFrameOffset -> [CmmExpr] + -> CmmAGraph +mkJumpExtra profile conv e actuals updfr_off extra_stack = + lastWithArgsAndExtraStack profile Jump Old conv actuals updfr_off extra_stack $ + toCall e Nothing updfr_off 0 + +mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph +mkCbranch pred ifso ifnot likely = + mkLast (CmmCondBranch pred ifso ifnot likely) + +mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph +mkSwitch e tbl = mkLast $ CmmSwitch e tbl + +mkReturn :: Profile -> CmmExpr -> [CmmExpr] -> UpdFrameOffset + -> CmmAGraph +mkReturn profile e actuals updfr_off = + lastWithArgs profile Ret Old NativeReturn actuals updfr_off $ + toCall e Nothing updfr_off 0 + +mkBranch :: BlockId -> CmmAGraph +mkBranch bid = mkLast (CmmBranch bid) + +mkFinalCall :: Profile + -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset + -> CmmAGraph +mkFinalCall profile f _ actuals updfr_off = + lastWithArgs profile Call Old NativeDirectCall actuals updfr_off $ + toCall f Nothing updfr_off 0 + +mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr] + -> BlockId + -> ByteOff + -> UpdFrameOffset + -> [CmmExpr] + -> CmmAGraph +mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack = + lastWithArgsAndExtraStack profile Call (Young ret_lbl) callConv actuals + updfr_off extra_stack $ + toCall f (Just ret_lbl) updfr_off ret_off + +-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be +-- already on the stack). +mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr] + -> BlockId + -> ByteOff + -> UpdFrameOffset + -> CmmAGraph +mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off = + lastWithArgs profile JumpRet (Young ret_lbl) callConv actuals updfr_off $ + toCall f (Just ret_lbl) updfr_off ret_off + +mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph +mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as + +-- | Construct a 'CmmUnwind' node for the given register and unwinding +-- expression. +mkUnwind :: GlobalReg -> CmmExpr -> CmmAGraph +mkUnwind r e = mkMiddle $ CmmUnwind [(r, Just e)] + +-------------------------------------------------------------------------- + + + + +-- Why are we inserting extra blocks that simply branch to the successors? +-- Because in addition to the branch instruction, @mkBranch@ will insert +-- a necessary adjustment to the stack pointer. + + +-- For debugging purposes, we can stub out dead stack slots: +stackStubExpr :: Width -> CmmExpr +stackStubExpr w = CmmLit (CmmInt 0 w) + +-- When we copy in parameters, we usually want to put overflow +-- parameters on the stack, but sometimes we want to pass the +-- variables in their spill slots. Therefore, for copying arguments +-- and results, we provide different functions to pass the arguments +-- in an overflow area and to pass them in spill slots. +copyInOflow :: Profile -> Convention -> Area + -> [CmmFormal] + -> [CmmFormal] + -> (Int, [GlobalRegUse], CmmAGraph) + +copyInOflow profile conv area formals extra_stk + = (offset, gregs, catAGraphs $ map mkMiddle nodes) + where (offset, gregs, nodes) = copyIn profile conv area formals extra_stk + +-- Return the number of bytes used for copying arguments, as well as the +-- instructions to copy the arguments. +copyIn :: Profile -> Convention -> Area + -> [CmmFormal] + -> [CmmFormal] + -> (ByteOff, [GlobalRegUse], [CmmNode O O]) +copyIn profile conv area formals extra_stk + = (stk_size, [GlobalRegUse r (localRegType lr)| (lr, RegisterParam r) <- args], map ci (stk_args ++ args)) + where + platform = profilePlatform profile + + ci :: (LocalReg, ParamLocation) -> CmmNode O O + ci (reg, RegisterParam r@(VanillaReg {})) = + let local = CmmLocal reg + width = cmmRegWidth local + (expr, ty) + -- See Note [Width of parameters] + | width == wordWidth platform + = (global, localRegType reg) + | width < wordWidth platform + = (CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global] + ,setCmmTypeWidth (wordWidth platform) (localRegType reg)) + | otherwise + = panic "Parameter width greater than word width" + global = CmmReg (CmmGlobal $ GlobalRegUse r ty) + + in CmmAssign local expr + + -- Non VanillaRegs + ci (reg, RegisterParam r) = + CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal $ GlobalRegUse r (localRegType reg))) + + ci (reg, StackParam off) + | isBitsType $ localRegType reg + -- See Note [Width of parameters] + , typeWidth (localRegType reg) < wordWidth platform = + let + stack_slot = CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform) NaturallyAligned + local = CmmLocal reg + width = cmmRegWidth local + expr = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot] + in CmmAssign local expr + + | otherwise = + CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty NaturallyAligned) + where ty = localRegType reg + + init_offset = widthInBytes (wordWidth platform) -- infotable + + (stk_off, stk_args) = assignStack platform init_offset localRegType extra_stk + + (stk_size, args) = assignArgumentsPos profile stk_off conv + localRegType formals + +-- Factoring out the common parts of the copyout functions yielded something +-- more complicated: + +data Transfer = Call | JumpRet | Jump | Ret deriving Eq + +copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr] + -> UpdFrameOffset + -> [CmmExpr] -- extra stack args + -> (Int, [GlobalRegUse], CmmAGraph) + +-- Generate code to move the actual parameters into the locations +-- required by the calling convention. This includes a store for the +-- return address. +-- +-- The argument layout function ignores the pointer to the info table, +-- so we slot that in here. When copying-out to a young area, we set +-- the info table for return and adjust the offsets of the other +-- parameters. If this is a call instruction, we adjust the offsets +-- of the other parameters. +copyOutOflow profile conv transfer area actuals updfr_off extra_stack_stuff + = (stk_size, regs, graph) + where + platform = profilePlatform profile + (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) + + co :: (CmmExpr, ParamLocation) + -> ([GlobalRegUse], CmmAGraph) + -> ([GlobalRegUse], CmmAGraph) + co (v, RegisterParam r@(VanillaReg {})) (rs, ms) = + let width = cmmExprWidth platform v + value + -- See Note [Width of parameters] + | width == wordWidth platform = v + | width < wordWidth platform = + CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v] + | otherwise = panic "Parameter width greater than word width" + ru = GlobalRegUse r (cmmExprType platform value) + + in (ru:rs, mkAssign (CmmGlobal ru) value <*> ms) + + -- Non VanillaRegs + co (v, RegisterParam r) (rs, ms) = + let ru = GlobalRegUse r (cmmExprType platform v) + in (ru:rs, mkAssign (CmmGlobal ru) v <*> ms) + + co (v, StackParam off) (rs, ms) + = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms) + + -- See Note [Width of parameters] + width v = cmmExprWidth platform v + value v + | isBitsType $ cmmExprType platform v + , width v < wordWidth platform = + CmmMachOp (MO_XX_Conv (width v) (wordWidth platform)) [v] + | otherwise = v + + (setRA, init_offset) = + case area of + Young id -> -- Generate a store instruction for + -- the return address if making a call + case transfer of + Call -> + ([(CmmLit (CmmBlock id), StackParam init_offset)], + widthInBytes (wordWidth platform)) + JumpRet -> + ([], + widthInBytes (wordWidth platform)) + _other -> + ([], 0) + Old -> ([], updfr_off) + + (extra_stack_off, stack_params) = + assignStack platform init_offset (cmmExprType platform) extra_stack_stuff + + args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it + (stk_size, args) = assignArgumentsPos profile extra_stack_off conv + (cmmExprType platform) actuals + + +-- Note [Width of parameters] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Consider passing a small (< word width) primitive like Int8# to a function. +-- It's actually non-trivial to do this without extending/narrowing: +-- * Lowering gets harder, since on x86-32 not every register exposes its lower +-- 8 bits (e.g., for %eax we can use %al, but there isn't a corresponding +-- 8-bit register for %edi). So we would either need to extend/narrow anyway, +-- or complicate the calling convention. +-- * Passing a small integer in a stack slot, which has native word width, +-- requires extending to word width when writing to the stack and narrowing +-- when reading off the stack (see #16258). +-- This is because the generated Cmm application functions (such as stg_ap_n) +-- always load the full width from the stack. +-- So instead, we always extend every parameter smaller than native word width +-- in copyOutOflow and then truncate it back to the expected width in copyIn. +-- Note that we do this in cmm using MO_XX_Conv to avoid requiring +-- zero-/sign-extending - it's up to a backend to handle this in a most +-- efficient way (e.g., a simple register move or a smaller size store). +-- This convention (of ignoring the upper bits) is different from some C ABIs, +-- e.g. all PowerPC ELF ABIs, that require sign or zero extending parameters. +-- +-- There was some discussion about this on this PR: +-- https://github.com/ghc-proposals/ghc-proposals/pull/74 + + +mkCallEntry :: Profile -> Convention -> [CmmFormal] -> [CmmFormal] + -> (Int, [GlobalRegUse], CmmAGraph) +mkCallEntry profile conv formals extra_stk + = copyInOflow profile conv Old formals extra_stk + +lastWithArgs :: Profile -> Transfer -> Area -> Convention -> [CmmExpr] + -> UpdFrameOffset + -> (ByteOff -> [GlobalRegUse] -> CmmAGraph) + -> CmmAGraph +lastWithArgs profile transfer area conv actuals updfr_off last = + lastWithArgsAndExtraStack profile transfer area conv actuals + updfr_off noExtraStack last + +lastWithArgsAndExtraStack :: Profile + -> Transfer -> Area -> Convention -> [CmmExpr] + -> UpdFrameOffset -> [CmmExpr] + -> (ByteOff -> [GlobalRegUse] -> CmmAGraph) + -> CmmAGraph +lastWithArgsAndExtraStack profile transfer area conv actuals updfr_off + extra_stack last = + copies <*> last outArgs regs + where + (outArgs, regs, copies) = copyOutOflow profile conv transfer area actuals + updfr_off extra_stack + + +noExtraStack :: [CmmExpr] +noExtraStack = [] + +toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff + -> ByteOff -> [GlobalRegUse] + -> CmmAGraph +toCall e cont updfr_off res_space arg_space regs = + mkLast $ CmmCall e cont regs arg_space res_space updfr_off diff --git a/GHC/Cmm/Info.hs b/GHC/Cmm/Info.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Info.hs @@ -0,0 +1,599 @@ + +module GHC.Cmm.Info ( + mkEmptyContInfoTable, + cmmToRawCmm, + srtEscape, + + -- info table accessors + closureInfoPtr, + entryCode, + getConstrTag, + cmmGetClosureType, + infoTable, + infoTableConstrTag, + infoTableSrtBitmap, + infoTableClosureType, + infoTablePtrs, + infoTableNonPtrs, + funInfoTable, + funInfoArity, + + -- info table sizes and offsets + stdInfoTableSizeW, + fixedInfoTableSizeW, + profInfoTableSizeW, + maxStdInfoTableSizeW, + maxRetInfoTableSizeW, + stdInfoTableSizeB, + conInfoTableSizeB, + stdSrtBitmapOffset, + stdClosureTypeOffset, + stdPtrsOffset, stdNonPtrsOffset, +) where + +import GHC.Prelude + +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.StgToCmm.CgUtils (CgStream) +import GHC.Runtime.Heap.Layout +import GHC.Data.Bitmap +import qualified GHC.Data.Stream as Stream +import GHC.Cmm.Dataflow.Label + +import GHC.Platform +import GHC.Platform.Profile +import GHC.Data.Maybe +import GHC.Utils.Error (withTimingSilent) +import GHC.Utils.Panic +import GHC.Utils.Logger +import GHC.Utils.Monad +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Types.Unique.DSM + +import Data.ByteString (ByteString) + +-- When we split at proc points, we need an empty info table. +mkEmptyContInfoTable :: CLabel -> CmmInfoTable +mkEmptyContInfoTable info_lbl + = CmmInfoTable { cit_lbl = info_lbl + , cit_rep = mkStackRep [] + , cit_prof = NoProfilingInfo + , cit_srt = Nothing + , cit_clo = Nothing } + +cmmToRawCmm :: Logger -> Profile -> CgStream CmmGroupSRTs a + -> IO (CgStream RawCmmGroup a) +cmmToRawCmm logger profile cmms + = do { let do_one :: [CmmDeclSRTs] -> UniqDSMT IO [RawCmmDecl] + do_one cmm = setTagUDSMT 'i' $ do + -- NB. strictness fixes a space leak. DO NOT REMOVE. + withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ()) $ do + liftUniqDSM $ + concatMapM (mkInfoTable profile) cmm + ; return (Stream.mapM do_one cmms) + } + + +-- Make a concrete info table, represented as a list of CmmStatic +-- (it can't be simply a list of Word, because the SRT field is +-- represented by a label+offset expression). +-- +-- With tablesNextToCode, the layout is +-- +-- +-- +-- +-- Without tablesNextToCode, the layout of an info table is +-- +-- +-- +-- +-- See rts/include/rts/storage/InfoTables.h +-- +-- For return-points these are as follows +-- +-- Tables next to code: +-- +-- +-- +-- ret-addr --> +-- +-- Not tables-next-to-code: +-- +-- ret-addr --> +-- +-- +-- +-- * The SRT slot is only there if there is SRT info to record + +mkInfoTable :: Profile -> CmmDeclSRTs -> UniqDSM [RawCmmDecl] +mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] + +mkInfoTable profile proc@(CmmProc infos entry_lbl live blocks) + -- + -- in the non-tables-next-to-code case, procs can have at most a + -- single info table associated with the entry label of the proc. + -- + | not (platformTablesNextToCode platform) + = case topInfoTable proc of -- must be at most one + -- no info table + Nothing -> + return [CmmProc mapEmpty entry_lbl live blocks] + + Just info@CmmInfoTable { cit_lbl = info_lbl } -> do + (top_decls, (std_info, extra_bits)) <- + mkInfoTableContents profile info Nothing + let + rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info + rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits + -- + -- Separately emit info table (with the function entry + -- point as first entry) and the entry code + -- + return (top_decls ++ + [CmmProc mapEmpty entry_lbl live blocks, + mkRODataLits info_lbl + (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]) + + -- + -- With tables-next-to-code, we can have many info tables, + -- associated with some of the BlockIds of the proc. For each info + -- table we need to turn it into CmmStatics, and collect any new + -- CmmDecls that arise from doing so. + -- + | otherwise + = do + (top_declss, raw_infos) <- + unzip `fmap` mapM do_one_info (mapToList (info_tbls infos)) + return (concat top_declss ++ + [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) + + where + platform = profilePlatform profile + do_one_info (lbl,itbl) = do + (top_decls, (std_info, extra_bits)) <- + mkInfoTableContents profile itbl Nothing + let + info_lbl = cit_lbl itbl + rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info + rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits + -- + return (top_decls, (lbl, CmmStaticsRaw info_lbl $ map CmmStaticLit $ + reverse rel_extra_bits ++ rel_std_info)) + +----------------------------------------------------- +type InfoTableContents = ( [CmmLit] -- The standard part + , [CmmLit] ) -- The "extra bits" +-- These Lits have *not* had mkRelativeTo applied to them + +mkInfoTableContents :: Profile + -> CmmInfoTable + -> Maybe Int -- Override default RTS type tag? + -> UniqDSM ([RawCmmDecl], -- Auxiliary top decls + InfoTableContents) -- Info tbl + extra bits + +mkInfoTableContents profile + info@(CmmInfoTable { cit_lbl = info_lbl + , cit_rep = smrep + , cit_prof = prof + , cit_srt = srt }) + mb_rts_tag + | RTSRep rts_tag rep <- smrep + = mkInfoTableContents profile info{cit_rep = rep} (Just rts_tag) + -- Completely override the rts_tag that mkInfoTableContents would + -- otherwise compute, with the rts_tag stored in the RTSRep + -- (which in turn came from a handwritten .cmm file) + + | StackRep frame <- smrep + = do { (prof_lits, prof_data) <- mkProfLits platform prof + ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt + ; (liveness_lit, liveness_data) <- mkLivenessBits platform frame + ; let + std_info = mkStdInfoTable profile prof_lits rts_tag srt_bitmap liveness_lit + rts_tag | Just tag <- mb_rts_tag = tag + | null liveness_data = rET_SMALL -- Fits in extra_bits + | otherwise = rET_BIG -- Does not; extra_bits is + -- a label + ; return (prof_data ++ liveness_data, (std_info, srt_label)) } + + | HeapRep _ ptrs nonptrs closure_type <- smrep + = do { let layout = packIntsCLit platform ptrs nonptrs + ; (prof_lits, prof_data) <- mkProfLits platform prof + ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt + ; (mb_srt_field, mb_layout, extra_bits, ct_data) + <- mk_pieces closure_type srt_label + ; let std_info = mkStdInfoTable profile prof_lits + (mb_rts_tag `orElse` rtsClosureType smrep) + (mb_srt_field `orElse` srt_bitmap) + (mb_layout `orElse` layout) + ; return (prof_data ++ ct_data, (std_info, extra_bits)) } + where + platform = profilePlatform profile + mk_pieces :: ClosureTypeInfo -> [CmmLit] + -> UniqDSM ( Maybe CmmLit -- Override the SRT field with this + , Maybe CmmLit -- Override the layout field with this + , [CmmLit] -- "Extra bits" for info table + , [RawCmmDecl]) -- Auxiliary data decls + mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor + = do { (descr_lit, decl) <- newStringLit con_descr + ; return ( Just (CmmInt (fromIntegral con_tag) + (halfWordWidth platform)) + , Nothing, [descr_lit], [decl]) } + + mk_pieces Thunk srt_label + = return (Nothing, Nothing, srt_label, []) + + mk_pieces (ThunkSelector offset) _no_srt + = return (Just (CmmInt 0 (halfWordWidth platform)), + Just (mkWordCLit platform (fromIntegral offset)), [], []) + -- Layout known (one free var); we use the layout field for offset + + mk_pieces (Fun arity (ArgSpec fun_type)) srt_label + = do { let extra_bits = packIntsCLit platform fun_type arity : srt_label + ; return (Nothing, Nothing, extra_bits, []) } + + mk_pieces (Fun arity (ArgGen arg_bits)) srt_label + = do { (liveness_lit, liveness_data) <- mkLivenessBits platform arg_bits + ; let fun_type | null liveness_data = aRG_GEN + | otherwise = aRG_GEN_BIG + extra_bits = [ packIntsCLit platform fun_type arity ] + ++ (if inlineSRT platform then [] else [ srt_lit ]) + ++ [ liveness_lit, slow_entry ] + ; return (Nothing, Nothing, extra_bits, liveness_data) } + where + slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl) + srt_lit = case srt_label of + [] -> mkIntCLit platform 0 + (lit:_rest) -> assert (null _rest) lit + + mk_pieces other _ = pprPanic "mk_pieces" (ppr other) + +mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier + +packIntsCLit :: Platform -> Int -> Int -> CmmLit +packIntsCLit platform a b = packHalfWordsCLit platform + (toStgHalfWord platform (fromIntegral a)) + (toStgHalfWord platform (fromIntegral b)) + + +mkSRTLit :: Platform + -> CLabel + -> Maybe CLabel + -> ([CmmLit], -- srt_label, if any + CmmLit) -- srt_bitmap +mkSRTLit platform info_lbl (Just lbl) + | inlineSRT platform + = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth platform)) +mkSRTLit platform _ Nothing = ([], CmmInt 0 (halfWordWidth platform)) +mkSRTLit platform _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth platform)) + + +-- | Is the SRT offset field inline in the info table on this platform? +-- +-- See the section "Referring to an SRT from the info table" in +-- Note [SRTs] in "GHC.Cmm.Info.Build" +inlineSRT :: Platform -> Bool +inlineSRT = pc_USE_INLINE_SRT_FIELD . platformConstants + +------------------------------------------------------------------------- +-- +-- Lay out the info table and handle relative offsets +-- +------------------------------------------------------------------------- + +-- This function takes +-- * the standard info table portion (StgInfoTable) +-- * the "extra bits" (StgFunInfoExtraRev etc.) +-- * the entry label +-- * the code +-- and lays them out in memory, producing a list of RawCmmDecl + +------------------------------------------------------------------------- +-- +-- Position independent code +-- +------------------------------------------------------------------------- +-- In order to support position independent code, we mustn't put absolute +-- references into read-only space. Info tables in the tablesNextToCode +-- case must be in .text, which is read-only, so we doctor the CmmLits +-- to use relative offsets instead. + +-- Note that this is done even when the -fPIC flag is not specified, +-- as we want to keep binary compatibility between PIC and non-PIC. + +makeRelativeRefTo :: Platform -> CLabel -> CmmLit -> CmmLit +makeRelativeRefTo platform info_lbl lit + = if platformTablesNextToCode platform + then case lit of + CmmLabel lbl -> CmmLabelDiffOff lbl info_lbl 0 (wordWidth platform) + CmmLabelOff lbl off -> CmmLabelDiffOff lbl info_lbl off (wordWidth platform) + _ -> lit + else lit + +------------------------------------------------------------------------- +-- +-- Build a liveness mask for the stack layout +-- +------------------------------------------------------------------------- + +-- There are four kinds of things on the stack: +-- +-- - pointer variables (bound in the environment) +-- - non-pointer variables (bound in the environment) +-- - free slots (recorded in the stack free list) +-- - non-pointer data slots (recorded in the stack free list) +-- +-- The first two are represented with a 'Just' of a 'LocalReg'. +-- The last two with one or more 'Nothing' constructors. +-- Each 'Nothing' represents one used word. +-- +-- The head of the stack layout is the top of the stack and +-- the least-significant bit. + +mkLivenessBits :: Platform -> Liveness -> UniqDSM (CmmLit, [RawCmmDecl]) + -- ^ Returns: + -- 1. The bitmap (literal value or label) + -- 2. Large bitmap CmmData if needed + +mkLivenessBits platform liveness + | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word + = do { uniq <- getUniqueDSM + ; let bitmap_lbl = mkBitmapLabel uniq + ; return (CmmLabel bitmap_lbl, + [mkRODataLits bitmap_lbl lits]) } + + | otherwise -- Fits in one word + = return (mkStgWordCLit platform bitmap_word, []) + where + n_bits = length liveness + + bitmap :: Bitmap + bitmap = mkBitmap platform liveness + + small_bitmap = case bitmap of + [] -> toStgWord platform 0 + [b] -> b + _ -> panic "mkLiveness" + bitmap_word = toStgWord platform (fromIntegral n_bits) + .|. (small_bitmap `shiftL` pc_BITMAP_BITS_SHIFT (platformConstants platform)) + + lits = mkWordCLit platform (fromIntegral n_bits) + : map (mkStgWordCLit platform) bitmap + -- The first word is the size. The structure must match + -- StgLargeBitmap in rts/include/rts/storage/InfoTable.h + +------------------------------------------------------------------------- +-- +-- Generating a standard info table +-- +------------------------------------------------------------------------- + +-- The standard bits of an info table. This part of the info table +-- corresponds to the StgInfoTable type defined in +-- rts/include/rts/storage/InfoTables.h. +-- +-- Its shape varies with ticky/profiling/tables next to code etc +-- so we can't use constant offsets from Constants + +mkStdInfoTable + :: Profile + -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) + -> Int -- Closure RTS tag + -> CmmLit -- SRT length + -> CmmLit -- layout field + -> [CmmLit] + +mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lit + = -- Parallel revertible-black hole field + prof_info + -- Ticky info (none at present) + -- Debug info (none at present) + ++ [layout_lit, tag, srt] + + where + platform = profilePlatform profile + prof_info + | profileIsProfiling profile = [type_descr, closure_descr] + | otherwise = [] + + tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform) + +------------------------------------------------------------------------- +-- +-- Making string literals +-- +------------------------------------------------------------------------- + +mkProfLits :: Platform -> ProfilingInfo -> UniqDSM ((CmmLit,CmmLit), [RawCmmDecl]) +mkProfLits platform NoProfilingInfo = return ((zeroCLit platform, zeroCLit platform), []) +mkProfLits _ (ProfilingInfo td cd) + = do { (td_lit, td_decl) <- newStringLit td + ; (cd_lit, cd_decl) <- newStringLit cd + ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } + +newStringLit :: ByteString -> UniqDSM (CmmLit, GenCmmDecl RawCmmStatics info stmt) +newStringLit bytes + = do { uniq <- getUniqueDSM + ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) } + + +-- Misc utils + +-- | Value of the srt field of an info table when using an StgLargeSRT +srtEscape :: Platform -> StgHalfWord +srtEscape platform = toStgHalfWord platform (-1) + +------------------------------------------------------------------------- +-- +-- Accessing fields of an info table +-- +------------------------------------------------------------------------- + +-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is +-- enabled. +wordAligned :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr +wordAligned platform align_check e + | align_check + = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e] + | otherwise + = e + +-- | Takes a closure pointer and returns the info table pointer +closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr +closureInfoPtr platform align_check e = + CmmMachOp (MO_RelaxedRead (wordWidth platform)) [wordAligned platform align_check e] + +-- | Takes an info pointer (the first word of a closure) and returns its entry +-- code +entryCode :: Platform -> CmmExpr -> CmmExpr +entryCode platform e = + if platformTablesNextToCode platform + then e + else cmmLoadBWord platform e + +-- | Takes a closure pointer, and return the *zero-indexed* +-- constructor tag obtained from the info table +-- This lives in the SRT field of the info table +-- (constructors don't need SRTs). +getConstrTag :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr +getConstrTag profile align_check closure_ptr + = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag profile info_table] + where + info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr) + platform = profilePlatform profile + +-- | Takes a closure pointer, and return the closure type +-- obtained from the info table +cmmGetClosureType :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr +cmmGetClosureType profile align_check closure_ptr + = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType profile info_table] + where + info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr) + platform = profilePlatform profile + +-- | Takes an info pointer (the first word of a closure) +-- and returns a pointer to the first word of the standard-form +-- info table, excluding the entry-code word (if present) +infoTable :: Profile -> CmmExpr -> CmmExpr +infoTable profile info_ptr + | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile) + | otherwise = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer + where platform = profilePlatform profile + +-- | Takes an info table pointer (from infoTable) and returns the constr tag +-- field of the info table (same as the srt_bitmap field) +infoTableConstrTag :: Profile -> CmmExpr -> CmmExpr +infoTableConstrTag = infoTableSrtBitmap + +-- | Takes an info table pointer (from infoTable) and returns the srt_bitmap +-- field of the info table +infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr +infoTableSrtBitmap profile info_tbl + = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform) NaturallyAligned + where platform = profilePlatform profile + +-- | Takes an info table pointer (from infoTable) and returns the closure type +-- field of the info table. +infoTableClosureType :: Profile -> CmmExpr -> CmmExpr +infoTableClosureType profile info_tbl + = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform) NaturallyAligned + where platform = profilePlatform profile + +infoTablePtrs :: Profile -> CmmExpr -> CmmExpr +infoTablePtrs profile info_tbl + = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform) NaturallyAligned + where platform = profilePlatform profile + +infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr +infoTableNonPtrs profile info_tbl + = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform) NaturallyAligned + where platform = profilePlatform profile + +-- | Takes the info pointer of a function, and returns a pointer to the first +-- word of the StgFunInfoExtra struct in the info table. +funInfoTable :: Profile -> CmmExpr -> CmmExpr +funInfoTable profile info_ptr + | platformTablesNextToCode platform + = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile - pc_SIZEOF_StgFunInfoExtraRev (platformConstants platform)) + | otherwise + = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW profile) + -- Past the entry code pointer + where + platform = profilePlatform profile + +-- | Takes the info pointer of a function, returns the function's arity +funInfoArity :: Profile -> CmmExpr -> CmmExpr +funInfoArity profile iptr + = cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes)) + where + platform = profilePlatform profile + fun_info = funInfoTable profile iptr + rep = cmmBits (widthFromBytes rep_bytes) + tablesNextToCode = platformTablesNextToCode platform + + (rep_bytes, offset) + | tablesNextToCode = ( pc_REP_StgFunInfoExtraRev_arity pc + , pc_OFFSET_StgFunInfoExtraRev_arity pc ) + | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc + , pc_OFFSET_StgFunInfoExtraFwd_arity pc ) + + pc = platformConstants platform + +----------------------------------------------------------------------------- +-- +-- Info table sizes & offsets +-- +----------------------------------------------------------------------------- + +stdInfoTableSizeW :: Profile -> WordOff +-- The size of a standard info table varies with profiling/ticky etc, +-- so we can't get it from Constants +-- It must vary in sync with mkStdInfoTable +stdInfoTableSizeW profile + = fixedInfoTableSizeW + + if profileIsProfiling profile + then profInfoTableSizeW + else 0 + +fixedInfoTableSizeW :: WordOff +fixedInfoTableSizeW = 2 -- layout, type + +profInfoTableSizeW :: WordOff +profInfoTableSizeW = 2 + +maxStdInfoTableSizeW :: WordOff +maxStdInfoTableSizeW = + 1 {- entry, when !tablesNextToCode -} + + fixedInfoTableSizeW + + profInfoTableSizeW + +maxRetInfoTableSizeW :: WordOff +maxRetInfoTableSizeW = + maxStdInfoTableSizeW + + 1 {- srt label -} + +stdInfoTableSizeB :: Profile -> ByteOff +stdInfoTableSizeB profile = stdInfoTableSizeW profile * profileWordSizeInBytes profile + +-- | Byte offset of the SRT bitmap half-word which is in the *higher-addressed* +-- part of the type_lit +stdSrtBitmapOffset :: Profile -> ByteOff +stdSrtBitmapOffset profile = stdInfoTableSizeB profile - halfWordSize (profilePlatform profile) + +-- | Byte offset of the closure type half-word +stdClosureTypeOffset :: Profile -> ByteOff +stdClosureTypeOffset profile = stdInfoTableSizeB profile - profileWordSizeInBytes profile + +stdPtrsOffset :: Profile -> ByteOff +stdPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile + +stdNonPtrsOffset :: Profile -> ByteOff +stdNonPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile + + halfWordSize (profilePlatform profile) + +conInfoTableSizeB :: Profile -> Int +conInfoTableSizeB profile = stdInfoTableSizeB profile + profileWordSizeInBytes profile diff --git a/GHC/Cmm/Info/Build.hs b/GHC/Cmm/Info/Build.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Info/Build.hs @@ -0,0 +1,1333 @@ +{-# LANGUAGE GADTs, RecordWildCards, + NondecreasingIndentation, + OverloadedStrings, LambdaCase #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE UndecidableInstances #-} + + +module GHC.Cmm.Info.Build + ( CAFSet, CAFEnv, cafAnal, cafAnalData + , doSRTs, ModuleSRTInfo (..), emptySRT + , SRTMap, srtMapNonCAFs + ) where + +import GHC.Prelude hiding (succ) + +import GHC.Platform +import GHC.Platform.Profile + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Cmm.BlockId +import GHC.Cmm.Config +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow +import GHC.Unit.Module +import GHC.Data.Graph.Directed +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Runtime.Heap.Layout +import GHC.Types.CostCentre +import GHC.StgToCmm.Heap + +import Control.Monad +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Control.Monad.Trans.State +import Control.Monad.Trans.Class +import Data.List (unzip4) + +import GHC.Types.Name.Set +import GHC.Types.Unique.DSM + +{- Note [SRTs] + ~~~~~~~~~~~ +Static Reference Tables (SRTs) are the mechanism by which the garbage collector +can determine the live CAFs in the program. An SRT is a static table associated +with a CAFfy closure which record which CAFfy objects are reachable from +the closure's code. + +Representation +^^^^^^^^^^^^^^ + ++------+ +| info | +| | +-----+---+---+---+ +| -------->|SRT_2| | | | | 0 | +|------| +-----+-|-+-|-+---+ +| | | | +| code | | | +| | v v + +An SRT is simply an object in the program's data segment. It has the +same representation as a static constructor. There are 16 +pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info, +representing SRT objects with 1-16 pointers, respectively. + +The entries of an SRT object point to static closures, which are either +- FUN_STATIC, THUNK_STATIC or CONSTR +- Another SRT (actually just a CONSTR) + +The final field of the SRT is the static link field, used by the +garbage collector to chain together static closures that it visits and +to determine whether a static closure has been visited or not. (see +Note [STATIC_LINK fields]) + +By traversing the transitive closure of an SRT, the GC will reach all +of the CAFs that are reachable from the code associated with this SRT. + +If we need to create an SRT with more than 16 entries, we build a +chain of SRT objects with all but the last having 16 entries. + ++-----+---+- -+---+---+ +|SRT16| | | | | | 0 | ++-----+-|-+- -+-|-+---+ + | | + v v + +----+---+---+---+ + |SRT2| | | | | 0 | + +----+-|-+-|-+---+ + | | + | | + v v + +Referring to an SRT from the info table +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +The following things have SRTs: + +- Static functions (FUN) +- Static thunks (THUNK), ie. CAFs +- Continuations (RET_SMALL, etc.) + +In each case, the info table points to the SRT, if there is one. + +- info->srt is 0 if there's no SRT +- otherwise, there are three ways which we may encode the location of the SRT in + the info table, described below. + +USE_SRT_POINTER +--------------- +Most general implementation. Can always be used, but other ways are more efficient. + +- info->srt is a pointer + +We encode an **absolute pointer** to the SRT in info->srt. e.g. for a FUN +with an SRT: + +StgInfoTable +------+ + info->layout.ptrs | ... | + info->layout.nptrs | ... | + info->srt | ------------> pointer to SRT object + info->type | ... | + |------| + +USE_SRT_OFFSET +-------------- +Requires: + - tables-next-to-code enabled + +In this case we use the info->srt to encode whether or not there is an SRT and +if so encode the offset to its location in info->f.srt_offset: + +- info->srt is a half-word +- info->f.srt_offset is a 32-bit int +- info->srt is 0 if there's no SRT, otherwise, +- info->srt == 1 and info->f.srt_offset is a offset to the SRT, relative to the +field address itself + +e.g. for a FUN with an SRT: + +StgFunInfoTable +------+ + info->f.srt_offset | ------------> offset to SRT object +StgInfoTable +------+ + info->layout.ptrs | ... | + info->layout.nptrs | ... | + info->srt | 1 | + info->type | ... | + |------| + +USE_INLINE_SRT_FIELD +-------------------- +Requires: + - tables-next-to-code enabled + - 64-bit architecture + - small memory model + +We optimise the info table representation further. The offset to the SRT can +be stored in 32 bits (all code lives within a 2GB region in x86_64's small +memory model), so we can save a word in the info table by storing the +srt_offset in the srt field, which is half a word. + +- info->srt is a half-word +- info->srt is 0 if there's no SRT, otherwise: +- info->srt is an offset from the info pointer to the SRT object + +StgInfoTable +------+ + info->layout.ptrs | | + info->layout.nptrs | | + info->srt | ------------> offset to SRT object + |------| + + +EXAMPLE +^^^^^^^ + +f = \x. ... g ... + where + g = \y. ... h ... c1 ... + h = \z. ... c2 ... + +c1 & c2 are CAFs + +g and h are local functions, but they have no static closures. When +we generate code for f, we start with a CmmGroup of four CmmDecls: + + [ f_closure, f_entry, g_entry, h_entry ] + +we process each CmmDecl separately in cpsTop, giving us a list of +CmmDecls. e.g. for f_entry, we might end up with + + [ f_entry, f1_ret, f2_proc ] + +where f1_ret is a return point, and f2_proc is a proc-point. We have +a CAFSet for each of these CmmDecls, let's suppose they are + + [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ] + [ g_entry{h_info, c1_closure} ] + [ h_entry{c2_closure} ] + +Next, we make an SRT for each of these functions: + + f_srt : [g_info] + g_srt : [h_info, c1_closure] + h_srt : [c2_closure] + +Now, for g_info and h_info, we want to refer to the SRTs for g and h +respectively, which we'll label g_srt and h_srt: + + f_srt : [g_srt] + g_srt : [h_srt, c1_closure] + h_srt : [c2_closure] + +Now, when an SRT has a single entry, we don't actually generate an SRT +closure for it, instead we just replace references to it with its +single element. So, since h_srt == c2_closure, we have + + f_srt : [g_srt] + g_srt : [c2_closure, c1_closure] + h_srt : [c2_closure] + +and the only SRT closure we generate is + + g_srt = SRT_2 [c2_closure, c1_closure] + +Algorithm +^^^^^^^^^ + +0. let srtMap :: Map CAFfyLabel (Maybe SRTEntry) = {} + Maps closures to their SRT entries (i.e. how they appear in a SRT payload) + +1. Start with decls :: [CmmDecl]. This corresponds to an SCC of bindings in STG + after code-generation. + +2. CPS-convert each CmmDecl (GHC.Cmm.Pipeline.cpsTop), resulting in a list + [CmmDecl]. There might be multiple CmmDecls in the result, due to proc-point + splitting. + +3. In cpsTop, *before* proc-point splitting, when we still have a single + CmmDecl, we do cafAnal for procs: + + * cafAnal performs a backwards analysis on the code blocks + + * For each labelled block, the analysis produces a CAFSet (= Set CAFfyLabel), + representing all the CAFfyLabels reachable from this label. + + * A label is added to the set if it refers to a FUN, THUNK, or RET, + and its CafInfo /= NoCafRefs. + (NB. all CafInfo for Ids in the current module should be initialised to + MayHaveCafRefs) + + * The result is CAFEnv = LabelMap CAFSet + + (Why *before* proc-point splitting? Because the analysis needs to propagate + information across branches, and proc-point splitting turns branches into + CmmCalls to top-level CmmDecls. The analysis would fail to find all the + references to CAFFY labels if we did it after proc-point splitting.) + + For static data, cafAnalData simply returns set of all labels that refer to a + FUN, THUNK, and RET whose CafInfos /= NoCafRefs. + +4. The result of cpsTop is (CAFEnv, [CmmDecl]) for procs and (CAFSet, CmmDecl) + for static data. So after `mapM cpsTop decls` we have + [Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)] + +5. For procs concat the decls and union the CAFEnvs to get (CAFEnv, [CmmDecl]) + +6. For static data generate a Map CLabel CAFSet (maps static data to their CAFSets) + +7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFfyLabel + +8. For each SCC in dependency order + - Let lbls :: [CAFfyLabel] be the non-recursive labels in this SCC + - Apply CAFEnv to each label and concat the result :: [CAFfyLabel] + - For each CAFfyLabel in the set apply srtMap (and ignore Nothing) to get + srt :: [SRTEntry] + - Make a label for this SRT, call it l + - If the SRT is not empty (i.e. the group is CAFFY) add FUN_STATICs in the + group to the SRT (see Note [Invalid optimisation: shortcutting]) + - Add to srtMap: lbls -> if null srt then Nothing else Just l + +9. At the end, update the IdInfo for every top-level binding x: + if srtMap x == Nothing, then the binding is non-CAFFY, otherwise it is + CAFFY. + +Optimisations +^^^^^^^^^^^^^ + +To reduce the code size overhead and the cost of traversing SRTs in +the GC, we want to simplify SRTs where possible. We therefore apply +the following optimisations. Each has a [keyword]; search for the +keyword in the code below to see where the optimisation is +implemented. + +1. [Inline] we never create an SRT with a single entry, instead we + point to the single entry directly from the info table. + + i.e. instead of + + +------+ + | info | + | | +-----+---+---+ + | -------->|SRT_1| | | 0 | + |------| +-----+-|-+---+ + | | | + | code | | + | | v + C + + we can point directly to the closure: + + +------+ + | info | + | | + | -------->C + |------| + | | + | code | + | | + + + Furthermore, the SRT for any code that refers to this info table + can point directly to C. + + The exception to this is when we're doing dynamic linking. In that + case, if the closure is not locally defined then we can't point to + it directly from the info table, because this is the text section + which cannot contain runtime relocations. In this case we skip this + optimisation and generate the singleton SRT, because SRTs are in the + data section and *can* have relocatable references. + +2. [FUN] A static function closure can also be an SRT, we simply put + the SRT entries as fields in the static closure. This makes a lot + of sense: the static references are just like the free variables of + the FUN closure. + + i.e. instead of + + f_closure: + +-----+---+ + | | | 0 | + +- |--+---+ + | +------+ + | | info | f_srt: + | | | +-----+---+---+---+ + | | -------->|SRT_2| | | | + 0 | + `----------->|------| +-----+-|-+-|-+---+ + | | | | + | code | | | + | | v v + + + We can generate: + + f_closure: + +-----+---+---+---+ + | | | | | | | 0 | + +- |--+-|-+-|-+---+ + | | | +------+ + | v v | info | + | | | + | | 0 | + `----------->|------| + | | + | code | + | | + + + (note: we can't do this for THUNKs, because the thunk gets + overwritten when it is entered, so we wouldn't be able to share + this SRT with other info tables that want to refer to it (see + [Common] below). FUNs are immutable so don't have this problem.) + +3. [Common] Identical SRTs can be commoned up. + +4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also + refers to C (perhaps transitively), then we can omit the reference + to C from A. + + +Note that there are many other optimisations that we could do, but +aren't implemented. In general, we could omit any reference from an +SRT if everything reachable from it is also reachable from the other +fields in the SRT. Our [Filter] optimisation is a special case of +this. + +Another opportunity we don't exploit is this: + +A = {X,Y,Z} +B = {Y,Z} +C = {X,B} + +Here we could use C = {A} and therefore [Inline] C = A. +-} + +-- --------------------------------------------------------------------- +{- +Note [No static object resurrection] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "static flag" mechanism (see Note [STATIC_LINK fields] in smStorage.h) that +the GC uses to track liveness of static objects assumes that unreachable +objects will never become reachable again (i.e. are never "resurrected"). +Breaking this assumption can result in extremely subtle GC soundness issues +(e.g. #15544, #20959). + +Guaranteeing that this assumption is not violated requires that all CAFfy +static objects reachable from the object's code are reachable from its SRT. In +the past we have gotten this wrong in a few ways: + + * shortcutting references to FUN_STATICs to instead point to the FUN_STATIC's + SRT. This lead to #15544 and is described in more detail in Note [Invalid + optimisation: shortcutting]. + + * omitting references to static data constructor applications. This previously + happened due to an oversight (#20959): when generating an SRT for a + recursive group we would drop references to the CAFfy static data + constructors. + +To see why we cannot allow object resurrection, see the examples in the +above-mentioned Notes. + +If a static closure definitely does not transitively refer to any CAFs, then it +*may* be advertised as not-CAFfy in the interface file and consequently *may* +be omitted from SRTs. Regardless of whether the closure is advertised as CAFfy +or non-CAFfy, its STATIC_LINK field *must* be set to 3, so that it never +appears on the static closure list. +-} + +{- +Note [Invalid optimisation: shortcutting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that if we have something like + +A's SRT = {B} +B's SRT = {X} + +that we could replace the reference to B in A's SRT with X. + +A's SRT = {X} +B's SRT = {X} + +and thereby perhaps save a little work at runtime, because we don't +have to visit B. + +But this is NOT valid. + +Consider these cases: + +0. B can't be a constructor, because constructors don't have SRTs + +1. B is a CAF. This is the easy one. Obviously we want A's SRT to + point to B, so that it keeps B alive. + +2. B is a function. This is the tricky one. The reason we can't + shortcut in this case is that we aren't allowed to resurrect static + objects for the reason described in Note [No static object resurrection]. + We noticed this in #15544. + +The particular case that cropped up when we tried this in #15544 was: + +- A is a thunk +- B is a static function +- X is a CAF +- suppose we GC when A is alive, and B is not otherwise reachable. +- B is "collected", meaning that it doesn't make it onto the static + objects list during this GC, but nothing bad happens yet. +- Next, suppose we enter A, and then call B. (remember that A refers to B) + At the entry point to B, we GC. This puts B on the stack, as part of the + RET_FUN stack frame that gets pushed when we GC at a function entry point. +- This GC will now reach B +- But because B was previous "collected", it breaks the assumption + that static objects are never resurrected. See Note [STATIC_LINK + fields] in rts/sm/Storage.h for why this is bad. +- In practice, the GC thinks that B has already been visited, and so + doesn't visit X, and catastrophe ensues. + + + +Note [Ticky labels in SRT analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Raw Cmm data (CmmStaticsRaw) can't contain pointers so they're considered +non-CAFFY in SRT analysis and we update the SRTMap mapping them to `Nothing` +(meaning they're not CAFFY). + +However when building with -ticky we generate ticky CLabels using the function's +`Name`. For example, if we have a top-level function `sat_s1rQ`, in a ticky +build we get two IdLabels using the name `sat_s1rQ`: + +- For the function itself: IdLabel sat_s1rQ ... Entry +- For the ticky counter: IdLabel sat_s1rQ ... RednCounts + +In these cases we really want to use the function definition for the SRT +analysis of this Name, because that's what we export for this Name -- ticky +counters are not exported. So we ignore ticky counters in SRT analysis (which +are never CAFFY and never exported). + +Not doing this caused #17947 where we analysed the function first mapped the +name to CAFFY. We then saw the ticky constructor, and because it has the same +Name as the function and is not CAFFY we overrode the CafInfo of the name as +non-CAFFY. +-} + +-- --------------------------------------------------------------------- +-- Label types + +-- | +-- The label of a CAFfy thing. +-- +-- Labels that come from 'cafAnal' can be: +-- - @_closure@ labels for static functions, static data constructor +-- applications, or static thunks +-- - @_info@ labels for dynamic functions, thunks, or continuations +-- - @_entry@ labels for functions or thunks +-- +-- Meanwhile the labels on top-level blocks are @_entry@ labels. +-- +-- To put everything in the same namespace we convert all labels to +-- closure labels using 'toClosureLbl'. Note that some of these +-- labels will not actually exist; that's ok because we're going to +-- map them to SRTEntry later, which ranges over labels that do exist. +-- +newtype CAFfyLabel = CAFfyLabel CLabel + deriving (Eq,Ord) + +deriving newtype instance OutputableP env CLabel => OutputableP env CAFfyLabel + +type CAFSet = Set CAFfyLabel +type CAFEnv = LabelMap CAFSet + +-- | Records the CAFfy references of a set of static data decls. +type DataCAFEnv = Map CLabel CAFSet + + +mkCAFfyLabel :: Platform -> CLabel -> CAFfyLabel +mkCAFfyLabel platform lbl = CAFfyLabel (toClosureLbl platform lbl) + +-- This is a label that we can put in an SRT. It *must* be a closure label, +-- pointing to either a @FUN_STATIC@, @THUNK_STATIC@, or @CONSTR@. +newtype SRTEntry = SRTEntry CLabel + deriving (Eq, Ord) + +deriving newtype instance OutputableP env CLabel => OutputableP env SRTEntry + + +-- --------------------------------------------------------------------- +-- CAF analysis + +addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet +addCafLabel platform l s + | Just _ <- hasHaskellName l + , let caf_label = mkCAFfyLabel platform l + -- For imported Ids hasCAF will have accurate CafInfo + -- Locals are initialized as CAFFY. We turn labels with empty SRTs into + -- non-CAFFYs in doSRTs + , hasCAF l + = Set.insert caf_label s + | otherwise + = s + +-- | Collect possible CAFfy references from a 'CmmData' decl. +cafAnalData + :: Platform + -> CmmStatics + -> CAFSet +cafAnalData platform st = case st of + CmmStaticsRaw _lbl _data -> Set.empty + CmmStatics _lbl _itbl _ccs payload _extras -> + foldl' analyzeStatic Set.empty payload + where + analyzeStatic s lit = + case lit of + CmmLabel c -> addCafLabel platform c s + CmmLabelOff c _ -> addCafLabel platform c s + CmmLabelDiffOff c1 c2 _ _ -> addCafLabel platform c1 $! addCafLabel platform c2 s + _ -> s + +-- | +-- For each code block: +-- - collect the references reachable from this code block to FUN, +-- THUNK or RET labels for which @hasCAF == True@ +-- +-- This gives us a 'CAFEnv': a mapping from code block to sets of labels +-- +cafAnal + :: Platform + -> LabelSet -- ^ The blocks representing continuations, ie. those + -- that will get RET info tables. These labels will + -- get their own SRTs, so we don't aggregate CAFs from + -- references to these labels, we just use the label. + -> CLabel -- ^ The top label of the proc + -> CmmGraph + -> CAFEnv +cafAnal platform contLbls topLbl cmmGraph = + analyzeCmmBwd cafLattice + (cafTransfers platform contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty + + +cafLattice :: DataflowLattice CAFSet +cafLattice = DataflowLattice Set.empty add + where + add (OldFact old) (NewFact new) = + let !new' = old `Set.union` new + in changedIf (Set.size new' > Set.size old) new' + + +cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet +cafTransfers platform contLbls entry topLbl + block@(BlockCC eNode middle xNode) fBase = + let joined :: CAFSet + joined = cafsInNode xNode $! live' + + result :: CAFSet + !result = foldNodesBwdOO cafsInNode middle joined + + facts :: [Set CAFfyLabel] + facts = mapMaybe successorFact (successors xNode) + + live' :: CAFSet + live' = joinFacts cafLattice facts + + successorFact :: Label -> Maybe (Set CAFfyLabel) + successorFact s + -- If this is a loop back to the entry, we can refer to the + -- entry label. + | s == entry = Just (addCafLabel platform topLbl Set.empty) + -- If this is a continuation, we want to refer to the + -- SRT for the continuation's info table + | s `setMember` contLbls + = Just (Set.singleton (mkCAFfyLabel platform (infoTblLbl s))) + -- Otherwise, takes the CAF references from the destination + | otherwise + = lookupFact s fBase + + cafsInNode :: CmmNode e x -> CAFSet -> CAFSet + cafsInNode node set = foldExpDeep addCafExpr node set + + addCafExpr :: CmmExpr -> Set CAFfyLabel -> Set CAFfyLabel + addCafExpr expr !set = + case expr of + CmmLit (CmmLabel c) -> + addCafLabel platform c set + CmmLit (CmmLabelOff c _) -> + addCafLabel platform c set + CmmLit (CmmLabelDiffOff c1 c2 _ _) -> + addCafLabel platform c1 $! addCafLabel platform c2 set + _ -> + set + in + srtTrace "cafTransfers" (text "block:" <+> pdoc platform block $$ + text "contLbls:" <+> ppr contLbls $$ + text "entry:" <+> ppr entry $$ + text "topLbl:" <+> pdoc platform topLbl $$ + text "cafs in exit:" <+> pdoc platform joined $$ + text "result:" <+> pdoc platform result) $ + mapSingleton (entryLabel eNode) result + + +-- ----------------------------------------------------------------------------- +-- ModuleSRTInfo + +data ModuleSRTInfo = ModuleSRTInfo + { thisModule :: Module + -- ^ Current module being compiled. Required for calling labelDynamic. + , dedupSRTs :: Map (Set SRTEntry) SRTEntry + -- ^ previous SRTs we've emitted, so we can de-duplicate. + -- Used to implement the [Common] optimisation. + , flatSRTs :: Map SRTEntry (Set SRTEntry) + -- ^ The reverse mapping, so that we can remove redundant + -- entries. e.g. if we have an SRT [a,b,c], and we know that b + -- points to [c,d], we can omit c and emit [a,b]. + -- Used to implement the [Filter] optimisation. + , moduleSRTMap :: SRTMap + } + +instance OutputableP env CLabel => OutputableP env ModuleSRTInfo where + pdoc env ModuleSRTInfo{..} = + text "ModuleSRTInfo {" $$ + (nest 4 $ text "dedupSRTs =" <+> pdoc env dedupSRTs $$ + text "flatSRTs =" <+> pdoc env flatSRTs $$ + text "moduleSRTMap =" <+> pdoc env moduleSRTMap) $$ char '}' + +emptySRT :: Module -> ModuleSRTInfo +emptySRT mod = + ModuleSRTInfo + { thisModule = mod + , dedupSRTs = Map.empty + , flatSRTs = Map.empty + , moduleSRTMap = Map.empty + } + +-- ----------------------------------------------------------------------------- +-- Constructing SRTs + +{- Implementation notes + +- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable + +- The entry in info_tbls corresponding to g_entry is the closure info + table, the rest are continuations. + +- Each entry in info_tbls possibly needs an SRT. We need to make a + label for each of these. + +- We get the CAFSet for each entry from the CAFEnv + +-} + +data SomeLabel + = BlockLabel !Label + | DeclLabel CLabel + deriving (Eq, Ord) + +instance OutputableP env CLabel => OutputableP env SomeLabel where + pdoc env = \case + BlockLabel l -> text "b:" <+> pdoc env l + DeclLabel l -> text "s:" <+> pdoc env l + +getBlockLabel :: SomeLabel -> Maybe Label +getBlockLabel (BlockLabel l) = Just l +getBlockLabel (DeclLabel _) = Nothing + +getBlockLabels :: [SomeLabel] -> [Label] +getBlockLabels = mapMaybe getBlockLabel + +-- | Return a @(Label,CLabel)@ pair for each labelled block of a 'CmmDecl', +-- where the label is +-- - the info label for a continuation or dynamic closure +-- - the closure label for a top-level function (not a CAF) +getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFfyLabel)] +getLabelledBlocks platform decl = case decl of + CmmData _ (CmmStaticsRaw _ _) -> [] + CmmData _ (CmmStatics lbl info _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl) + | not (isThunkRep (cit_rep info)) + ] + CmmProc top_info _ _ _ -> [ (BlockLabel blockId, caf_lbl) + | (blockId, info) <- mapToList (info_tbls top_info) + , let rep = cit_rep info + , not (isStaticRep rep) || not (isThunkRep rep) + , let !caf_lbl = mkCAFfyLabel platform (cit_lbl info) + ] + +-- | Put the labelled blocks that we will be annotating with SRTs into +-- dependency order. This is so that we can process them one at a +-- time, resolving references to earlier blocks to point to their +-- SRTs. CAFs themselves are not included here; see 'getCAFs' below. +depAnalSRTs + :: Platform + -> CAFEnv -- ^ 'CAFEnv' for procedures. From 'cafAnal'. + -> Map CLabel CAFSet -- ^ CAFEnv for statics. Maps statics to the set of the + -- CAFfy things which they refer to. From 'cafAnalData'. + -> [CmmDecl] -- ^ the decls to analyse. + -> [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)] +depAnalSRTs platform cafEnv cafEnv_static decls = + srtTrace "depAnalSRTs" (text "decls:" <+> pdoc platform decls $$ + text "nodes:" <+> pdoc platform (map node_payload nodes) $$ + text "graph:" <+> pdoc platform graph) graph + where + labelledBlocks :: [(SomeLabel, CAFfyLabel)] + labelledBlocks = concatMap (getLabelledBlocks platform) decls + labelToBlock :: Map CAFfyLabel SomeLabel + labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks + + -- the set of graph nodes. A node is identified by either a BlockLabel (in + -- the case of code) or a DeclLabel (in the case of static data). + nodes :: [Node SomeLabel (SomeLabel, CAFfyLabel, Set CAFfyLabel)] + nodes = [ DigraphNode (l,lbl,cafs') l + (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs')) + | (l, lbl) <- labelledBlocks + , Just (cafs :: Set CAFfyLabel) <- + [case l of + BlockLabel l -> mapLookup l cafEnv + DeclLabel cl -> Map.lookup cl cafEnv_static] + , let cafs' = Set.delete lbl cafs + ] + + graph :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)] + graph = stronglyConnCompFromEdgedVerticesOrd nodes + +-- | Get @(Maybe Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block. +-- The @Set CAFfyLabel@ represents the set of CAFfy things which this CAF's code +-- depends upon. +-- +-- - The 'Label' represents the entry code of the closure. This may be +-- 'Nothing' if it is a standard closure type (e.g. @stg_unpack_cstring@; see +-- Note [unpack_cstring closures] in StgStdThunks.cmm). +-- - The 'CAFLabel' is the label of the CAF closure. +-- - The @Set CAFLabel@ is the set of CAFfy closures which should be included +-- in the closure's SRT. +-- +-- Note that CAFs are treated differently from other labelled blocks: +-- +-- - we never shortcut a reference to a CAF to the contents of its +-- SRT, since the point of SRTs is to keep CAFs alive. +-- +-- - CAFs therefore don't take part in the dependency analysis in depAnalSRTs. +-- instead we generate their SRTs after everything else. +getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Maybe Label, CAFfyLabel, Set CAFfyLabel)] +getCAFs platform cafEnv = mapMaybe getCAFLabel + where + getCAFLabel :: CmmDecl -> Maybe (Maybe Label, CAFfyLabel, Set CAFfyLabel) + + getCAFLabel (CmmProc top_info top_lbl _ g) + | Just info <- mapLookup (g_entry g) (info_tbls top_info) + , let rep = cit_rep info + , isStaticRep rep && isThunkRep rep + , Just cafs <- mapLookup (g_entry g) cafEnv + = Just (Just (g_entry g), mkCAFfyLabel platform top_lbl, cafs) + + | otherwise + = Nothing + + getCAFLabel (CmmData _ (CmmStatics top_lbl info _ccs _payload _extras)) + | isThunkRep (cit_rep info) + = Just (Nothing, mkCAFfyLabel platform top_lbl, Set.empty) + + | otherwise + = Nothing + + getCAFLabel (CmmData _ (CmmStaticsRaw _lbl _payload)) + = Nothing + +-- | Get the list of blocks that correspond to the entry points for +-- @FUN_STATIC@ closures. These are the blocks for which if we have an +-- SRT we can merge it with the static closure. [FUN] +getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)] +getStaticFuns decls = + [ (g_entry g, lbl) + | CmmProc top_info _ _ g <- decls + , Just info <- [mapLookup (g_entry g) (info_tbls top_info)] + , Just (id, _) <- [cit_clo info] + , let rep = cit_rep info + , isStaticRep rep && isFunRep rep + , let !lbl = mkClosureLabel (idName id) (idCafInfo id) + ] + + +-- | Maps labels from 'cafAnal' to the final CLabel that will appear +-- in the SRT. +-- - closures with singleton SRTs resolve to their single entry +-- - closures with larger SRTs map to the label for that SRT +-- - CAFs must not map to anything! +-- - if a labels maps to Nothing, we found that this label's SRT +-- is empty, so we don't need to refer to it from other SRTs. +type SRTMap = Map CAFfyLabel (Maybe SRTEntry) + + +-- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the +-- module. Any 'Name's not in the set are CAFFY. +srtMapNonCAFs :: SRTMap -> NonCaffySet +srtMapNonCAFs srtMap = + NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap)) + where + get_name (CAFfyLabel l, Nothing) = hasHaskellName l + get_name (_l, Just _srt_entry) = Nothing + +-- | Resolve a CAFfyLabel to its 'SRTEntry' using the 'SRTMap'. +resolveCAF :: Platform -> SRTMap -> CAFfyLabel -> Maybe SRTEntry +resolveCAF platform srtMap lbl@(CAFfyLabel l) = + srtTrace "resolveCAF" ("l:" <+> pdoc platform l <+> "resolved:" <+> pdoc platform ret) ret + where + ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap + +anyCafRefs :: [CafInfo] -> CafInfo +anyCafRefs caf_infos = case any mayHaveCafRefs caf_infos of + True -> MayHaveCafRefs + False -> NoCafRefs + +-- | Attach SRTs to all info tables in the 'CmmDecl's, and add SRT +-- declarations to the 'ModuleSRTInfo'. +-- +doSRTs + :: CmmConfig + -> ModuleSRTInfo + -> DUniqSupply + -> [(CAFEnv, [CmmDecl])] -- ^ 'CAFEnv's and 'CmmDecl's for code blocks + -> [(CAFSet, CmmDataDecl)] -- ^ static data decls and their 'CAFSet's + -> IO (ModuleSRTInfo, DUniqSupply, [CmmDeclSRTs]) + +doSRTs cfg moduleSRTInfo dus0 procs data_ = do + + let origtag = getTagDUniqSupply dus0 + profile = cmmProfile cfg + dus1 = newTagDUniqSupply 'u' dus0 + + -- Ignore the original grouping of decls, and combine all the + -- CAFEnvs into a single CAFEnv. + static_data_env :: DataCAFEnv + static_data_env = + Map.fromList $ + flip map data_ $ + \(set, decl) -> + case decl of + CmmProc void _ _ _ -> case void of + CmmData _ static -> + case static of + CmmStatics lbl _ _ _ _ -> (lbl, set) + CmmStaticsRaw lbl _ -> (lbl, set) + + (proc_envs, procss) = unzip procs + cafEnv = mapUnions proc_envs + decls = map (cmmDataDeclCmmDecl . snd) data_ ++ concat procss + staticFuns = mapFromList (getStaticFuns decls) + + platform = cmmPlatform cfg + + -- Put the decls in dependency order. Why? So that we can implement + -- [Inline] and [Filter]. If we need to refer to an SRT that has + -- a single entry, we use the entry itself, which means that we + -- don't need to generate the singleton SRT in the first place. But + -- to do this we need to process blocks before things that depend on + -- them. + let + sccs :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)] + sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls + + cafsWithSRTs :: [(Maybe Label, CAFfyLabel, Set CAFfyLabel)] + cafsWithSRTs = getCAFs platform cafEnv decls + + srtTraceM "doSRTs" (text "data:" <+> pdoc platform data_ $$ + text "procs:" <+> pdoc platform procs $$ + text "static_data_env:" <+> pdoc platform static_data_env $$ + text "sccs:" <+> pdoc platform sccs $$ + text "cafsWithSRTs:" <+> pdoc platform cafsWithSRTs) + + -- On each strongly-connected group of decls, construct the SRT + -- closures and the SRT fields for info tables. + let result :: + [ ( [CmmDeclSRTs] -- generated SRTs + , [(Label, CLabel)] -- SRT fields for info tables + , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , CafInfo -- Whether the group has CAF references + ) ] + + ((result, moduleSRTInfo'), dus2) = + runUniqueDSM dus1 $ + flip runStateT moduleSRTInfo $ do + nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs + cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) -> + oneSRT cfg staticFuns (map BlockLabel (maybeToList l)) [cafLbl] + True{-is a CAF-} cafs static_data_env + return (nonCAFs ++ cAFs) + + (srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result + srt_decls = concat srt_declss + + -- Next, update the info tables with the SRTs + let + srtFieldMap = mapFromList (concat pairs) + funSRTMap = mapFromList (concat funSRTs) + has_caf_refs' = anyCafRefs has_caf_refs + decls' = + concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls + + -- Finally update CafInfos for raw static literals (CmmStaticsRaw). Those are + -- not analysed in oneSRT so we never add entries for them to the SRTMap. + let srtMap_w_raws = + foldl' (\(srtMap :: SRTMap) (_, decl) -> + case decl of + CmmData _ CmmStatics{} -> + -- already updated by oneSRT + srtMap + CmmData _ (CmmStaticsRaw lbl _) + | isIdLabel lbl && not (isTickyLabel lbl) -> + -- Raw data are not analysed by oneSRT and they can't + -- be CAFFY. + -- See Note [Ticky labels in SRT analysis] above for + -- why we exclude ticky labels here. + Map.insert (mkCAFfyLabel platform lbl) Nothing srtMap + | otherwise -> + -- Not an IdLabel, ignore + srtMap + CmmProc void _ _ _ -> case void of) + (moduleSRTMap moduleSRTInfo') data_ + dus3 = newTagDUniqSupply origtag dus2 -- restore original tag + return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, dus3, srt_decls ++ decls') + + +-- | Build the SRT for a strongly-connected component of blocks. +doSCC + :: CmmConfig + -> LabelMap CLabel -- ^ which blocks are static function entry points + -> DataCAFEnv -- ^ static data + -> SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel) + -> StateT ModuleSRTInfo UniqDSM + ( [CmmDeclSRTs] -- generated SRTs + , [(Label, CLabel)] -- SRT fields for info tables + , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , CafInfo -- Whether the group has CAF references + ) + +doSCC cfg staticFuns static_data_env (AcyclicSCC (l, cafLbl, cafs)) = + oneSRT cfg staticFuns [l] [cafLbl] False cafs static_data_env + +doSCC cfg staticFuns static_data_env (CyclicSCC nodes) = do + -- build a single SRT for the whole cycle, see Note [recursive SRTs] + let (lbls, caf_lbls, cafsets) = unzip3 nodes + cafs = Set.unions cafsets + oneSRT cfg staticFuns lbls caf_lbls False cafs static_data_env + + +{- Note [recursive SRTs] + ~~~~~~~~~~~~~~~~~~~~~ +If the dependency analyser has found us a recursive group of +declarations, then we build a single SRT for the whole group, on the +grounds that everything in the group is reachable from everything +else, so we lose nothing by having a single SRT. + +However, there are a couple of wrinkles to be aware of. + +* The Set CAFfyLabel for this SRT will contain labels in the group + itself. The SRTMap will therefore not contain entries for these labels + yet, so we can't turn them into SRTEntries using resolveCAF. BUT we + can just remove recursive references from the Set CAFLabel before + generating the SRT - the group SRT will consist of the union of the SRTs of + each of group's constituents minus recursive references. + +* That is, EXCEPT for static function closures and static data constructor + applications. For the same reason described in Note [No static object + resurrection], we cannot omit references to static function closures and + constructor applications. + + But, since we will merge the SRT with one of the static function + closures (see [FUN]), we can omit references to *that* static + function closure from the SRT. + +* Similarly, we must reintroduce recursive references to static data + constructor applications into the group's SRT. +-} + +-- | Build an SRT for a set of blocks +oneSRT + :: CmmConfig + -> LabelMap CLabel -- ^ which blocks are static function entry points + -> [SomeLabel] -- ^ blocks in this set + -> [CAFfyLabel] -- ^ labels for those blocks + -> Bool -- ^ True <=> this SRT is for a CAF + -> Set CAFfyLabel -- ^ SRT for this set + -> DataCAFEnv -- Static data labels in this group + -> StateT ModuleSRTInfo UniqDSM + ( [CmmDeclSRTs] -- SRT objects we built + , [(Label, CLabel)] -- SRT fields for these blocks' itbls + , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , CafInfo -- Whether the group has CAF references + ) + +oneSRT cfg staticFuns lbls caf_lbls isCAF cafs static_data_env = do + topSRT <- get + + let + this_mod = thisModule topSRT + profile = cmmProfile cfg + platform = profilePlatform profile + srtMap = moduleSRTMap topSRT + + blockids = getBlockLabels lbls + + -- Can we merge this SRT with a FUN_STATIC closure? + maybeFunClosure :: Maybe (CLabel, Label) + otherFunLabels :: [CLabel] + (maybeFunClosure, otherFunLabels) = + case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of + [] -> (Nothing, []) + ((l,b):xs) -> (Just (l,b), map fst xs) + + -- Remove recursive references from the SRT as described in + -- Note [recursive SRTs]. We carefully reintroduce references to static + -- functions and data constructor applications below, as is necessary due + -- to Note [No static object resurrection]. + nonRec :: Set CAFfyLabel + nonRec = cafs `Set.difference` Set.fromList caf_lbls + + -- Resolve references to their SRT entries + resolved :: [SRTEntry] + resolved = mapMaybe (resolveCAF platform srtMap) (Set.toList nonRec) + + -- The set of all SRTEntries in SRTs that we refer to from here. + allBelow = + Set.unions [ lbls | caf <- resolved + , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ] + + -- Remove SRTEntries that are also in an SRT that we refer to. + -- Implements the [Filter] optimisation. + filtered0 = Set.fromList resolved `Set.difference` allBelow + + srtTraceM "oneSRT:" + (text "srtMap:" <+> pdoc platform srtMap $$ + text "nonRec:" <+> pdoc platform nonRec $$ + text "lbls:" <+> pdoc platform lbls $$ + text "caf_lbls:" <+> pdoc platform caf_lbls $$ + text "static_data_env:" <+> pdoc platform static_data_env $$ + text "cafs:" <+> pdoc platform cafs $$ + text "blockids:" <+> ppr blockids $$ + text "maybeFunClosure:" <+> pdoc platform maybeFunClosure $$ + text "otherFunLabels:" <+> pdoc platform otherFunLabels $$ + text "resolved:" <+> pdoc platform resolved $$ + text "allBelow:" <+> pdoc platform allBelow $$ + text "filtered0:" <+> pdoc platform filtered0) + + let + isStaticFun = isJust maybeFunClosure + + -- For a label without a closure (e.g. a continuation), we must + -- update the SRTMap for the label to point to a closure. It's + -- important that we don't do this for static functions or CAFs, + -- see Note [Invalid optimisation: shortcutting]. + updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqDSM () + updateSRTMap srtEntry = + srtTrace "updateSRTMap" + (pdoc platform srtEntry <+> "isCAF:" <+> ppr isCAF <+> + "isStaticFun:" <+> ppr isStaticFun) $ + when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ + modify' $ \state -> + let !srt_map = + foldl' (\srt_map cafLbl@(CAFfyLabel clbl) -> + -- Only map static data to Nothing (== not CAFFY). For CAFFY + -- statics we refer to the static itself instead of a SRT. + if not (Map.member clbl static_data_env) || isNothing srtEntry then + Map.insert cafLbl srtEntry srt_map + else + srt_map) + (moduleSRTMap state) + caf_lbls + in + state{ moduleSRTMap = srt_map } + + allStaticData = + all (\(CAFfyLabel clbl) -> Map.member clbl static_data_env) caf_lbls + + if Set.null filtered0 then do + srtTraceM "oneSRT: empty" (pdoc platform caf_lbls) + updateSRTMap Nothing + return ([], [], [], NoCafRefs) + else do + -- We're going to build an SRT for this group, which should include function + -- references in the group. See Note [recursive SRTs]. + let allBelow_funs = + Set.fromList (map (SRTEntry . toClosureLbl platform) otherFunLabels) + -- We must also ensure that all CAFfy static data constructor applications + -- are included. See Note [recursive SRTs] and #20959. + let allBelow_data = + Set.fromList + [ SRTEntry $ toClosureLbl platform lbl + | DeclLabel lbl <- lbls + , Just refs <- pure $ Map.lookup lbl static_data_env + , not $ Set.null refs + ] + let filtered = filtered0 `Set.union` allBelow_funs `Set.union` allBelow_data + srtTraceM "oneSRT" (text "filtered:" <+> pdoc platform filtered $$ + text "allBelow_funs:" <+> pdoc platform allBelow_funs) + case Set.toList filtered of + [] -> pprPanic "oneSRT" empty -- unreachable + + -- [Inline] - when we have only one entry there is no need to + -- build an SRT object at all, instead we put the singleton SRT + -- entry in the info table. + [one@(SRTEntry lbl)] + | -- Info tables refer to SRTs by offset (as noted in the section + -- "Referring to an SRT from the info table" of Note [SRTs]). However, + -- when dynamic linking is used we cannot guarantee that the offset + -- between the SRT and the info table will fit in the offset field. + -- Consequently we build a singleton SRT in this case. + not (labelDynamic this_mod platform (cmmExternalDynamicRefs cfg) lbl) + + -- MachO relocations can't express offsets between compilation units at + -- all, so we are always forced to build a singleton SRT in this case + -- (cf #15169) + && (not (osMachOTarget $ platformOS $ profilePlatform profile) + || isLocalCLabel this_mod lbl) -> do + + -- If we have a static function closure, then it becomes the + -- SRT object, and everything else points to it. (the only way + -- we could have multiple labels here is if this is a + -- recursive group, see Note [recursive SRTs]) + case maybeFunClosure of + Just (staticFunLbl,staticFunBlock) -> + return ([], withLabels, [], MayHaveCafRefs) + where + withLabels = + [ (b, if b == staticFunBlock then lbl else staticFunLbl) + | b <- blockids ] + Nothing -> do + srtTraceM "oneSRT: one" (text "caf_lbls:" <+> pdoc platform caf_lbls $$ + text "one:" <+> pdoc platform one) + updateSRTMap (Just one) + return ([], map (,lbl) blockids, [], MayHaveCafRefs) + + cafList | allStaticData -> + let caffiness = if null cafList then NoCafRefs else MayHaveCafRefs + in return ([], [], [], caffiness) + + cafList -> + -- Check whether an SRT with the same entries has been emitted already. + -- Implements the [Common] optimisation. + case Map.lookup filtered (dedupSRTs topSRT) of + Just srtEntry@(SRTEntry srtLbl) -> do + srtTraceM "oneSRT [Common]" (pdoc platform caf_lbls <+> pdoc platform srtLbl) + updateSRTMap (Just srtEntry) + return ([], map (,srtLbl) blockids, [], MayHaveCafRefs) + Nothing -> do + -- No duplicates: we have to build a new SRT object + (decls, funSRTs, srtEntry) <- + case maybeFunClosure of + Just (fun,block) -> + return ( [], [(block, cafList)], SRTEntry fun ) + Nothing -> do + (decls, entry) <- lift $ buildSRTChain profile cafList + return (decls, [], entry) + updateSRTMap (Just srtEntry) + let allBelowThis = Set.union allBelow filtered + newFlatSRTs = Map.insert srtEntry allBelowThis (flatSRTs topSRT) + -- When all definition in this group are static data we don't + -- generate any SRTs. + newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT) + modify' (\state -> state{ dedupSRTs = newDedupSRTs, + flatSRTs = newFlatSRTs }) + srtTraceM "oneSRT: new" (text "caf_lbls:" <+> pdoc platform caf_lbls $$ + text "filtered:" <+> pdoc platform filtered $$ + text "srtEntry:" <+> pdoc platform srtEntry $$ + text "newDedupSRTs:" <+> pdoc platform newDedupSRTs $$ + text "newFlatSRTs:" <+> pdoc platform newFlatSRTs) + let SRTEntry lbl = srtEntry + return (decls, map (,lbl) blockids, funSRTs, MayHaveCafRefs) + + +-- | Build a static SRT object (or a chain of objects) from a list of +-- 'SRTEntry's. +buildSRTChain + :: Profile + -> [SRTEntry] + -> UniqDSM + ( [CmmDeclSRTs] -- The SRT object(s) + , SRTEntry -- label to use in the info table + ) +buildSRTChain profile cafSet = + case splitAt mAX_SRT_SIZE cafSet of + ([], _) -> panic "buildSRT: empty" + (these, []) -> do + (decl,lbl) <- buildSRT profile these + return ([decl], lbl) + (this:these,those) -> do + (rest, rest_lbl) <- buildSRTChain profile (this : those) + (decl,lbl) <- buildSRT profile (rest_lbl : these) + return (decl:rest, lbl) + where + mAX_SRT_SIZE = 16 + + +buildSRT :: Profile -> [SRTEntry] -> UniqDSM (CmmDeclSRTs, SRTEntry) +buildSRT profile refs = do + id <- getUniqueDSM + let + lbl = mkSRTLabel id + platform = profilePlatform profile + srt_n_info = mkSRTInfoLabel (length refs) + fields = + mkStaticClosure profile srt_n_info dontCareCCS + [ CmmLabel lbl | SRTEntry lbl <- refs ] + [] -- no padding + [mkIntCLit platform 0] -- link field + [] -- no saved info + [] -- no extras + return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl) + +-- | Update info tables with references to their SRTs. Also generate +-- static closures, splicing in SRT fields as necessary. +updInfoSRTs + :: Profile + -> LabelMap CLabel -- ^ SRT labels for each block + -> LabelMap [SRTEntry] -- ^ SRTs to merge into FUN_STATIC closures + -> CafInfo -- ^ Whether the CmmDecl's group has CAF references + -> CmmDecl + -> [CmmDeclSRTs] + +updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics)) + = [CmmData s (CmmStaticsRaw lbl statics)] + +updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload extras)) + = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))] + where + field_lits = mkStaticClosureFields profile itbl ccs caffy payload extras + +updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g) + | Just (_,closure) <- maybeStaticClosure = [ proc, closure ] + | otherwise = [ proc ] + where + proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g + newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info) + updInfoTbl l info_tbl + | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf + | otherwise = info_tbl { cit_srt = mapLookup l srt_env } + + -- Generate static closures [FUN]. Note that this also generates + -- static closures for thunks (CAFs), because it's easier to treat + -- them uniformly in the code generator. + maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs) + maybeStaticClosure + | Just info_tbl@CmmInfoTable{..} <- + mapLookup (g_entry g) (info_tbls top_info) + , Just (id, ccs) <- cit_clo + , isStaticRep cit_rep = + let + (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of + Nothing -> + -- if we don't add SRT entries to this closure, then we + -- want to set the srt field in its info table as usual + (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, []) + Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res) + (info_tbl { cit_rep = new_rep }, res) + where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ] + fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries [] + new_rep = case cit_rep of + HeapRep sta ptrs nptrs ty -> + HeapRep sta (ptrs + length srtEntries) nptrs ty + _other -> panic "maybeStaticFun" + lbl = mkClosureLabel (idName id) caffy + in + Just (newInfo, mkDataLits (Section Data lbl) lbl fields) + | otherwise = Nothing + + +srtTrace :: String -> SDoc -> b -> b +-- srtTrace = pprTrace +srtTrace _ _ b = b + +srtTraceM :: Applicative f => String -> SDoc -> f () +srtTraceM str doc = srtTrace str doc (pure ()) diff --git a/GHC/Cmm/InitFini.hs b/GHC/Cmm/InitFini.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/InitFini.hs @@ -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 diff --git a/GHC/Cmm/LRegSet.hs b/GHC/Cmm/LRegSet.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/LRegSet.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Cmm.LRegSet ( + LRegSet, + + emptyLRegSet, + nullLRegSet, + insertLRegSet, + elemLRegSet, + + deleteFromLRegSet, + sizeLRegSet, + + unionLRegSet, + unionsLRegSet, + elemsLRegSet + ) where + +import GHC.Prelude +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Cmm.Expr + +-- Compact sets for membership tests of local variables. + +type LRegSet = UniqueSet + +{-# INLINE emptyLRegSet #-} +emptyLRegSet :: LRegSet +emptyLRegSet = emptyUniqueSet + +{-# INLINE nullLRegSet #-} +nullLRegSet :: LRegSet -> Bool +nullLRegSet = nullUniqueSet + +{-# INLINE insertLRegSet #-} +insertLRegSet :: LocalReg -> LRegSet -> LRegSet +insertLRegSet l = insertUniqueSet (getUnique l) + +{-# INLINE elemLRegSet #-} +elemLRegSet :: LocalReg -> LRegSet -> Bool +elemLRegSet l = memberUniqueSet (getUnique l) + +{-# INLINE deleteFromLRegSet #-} +deleteFromLRegSet :: LRegSet -> LocalReg -> LRegSet +deleteFromLRegSet set reg = deleteUniqueSet (getUnique reg) set + +{-# INLINE sizeLRegSet #-} +sizeLRegSet :: LRegSet -> Int +sizeLRegSet = sizeUniqueSet + +{-# INLINE unionLRegSet #-} +unionLRegSet :: LRegSet -> LRegSet -> LRegSet +unionLRegSet = unionUniqueSet + +{-# INLINE unionsLRegSet #-} +unionsLRegSet :: [LRegSet] -> LRegSet +unionsLRegSet = unionsUniqueSet + +{-# INLINE elemsLRegSet #-} +elemsLRegSet :: LRegSet -> [Unique] +elemsLRegSet = elemsUniqueSet diff --git a/GHC/Cmm/LayoutStack.hs b/GHC/Cmm/LayoutStack.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/LayoutStack.hs @@ -0,0 +1,1243 @@ +{-# LANGUAGE RecordWildCards, GADTs #-} +module GHC.Cmm.LayoutStack ( + cmmLayoutStack, setInfoTableStackMap + ) where + +import GHC.Prelude hiding ((<*>)) + +import GHC.Platform +import GHC.Platform.Profile + +import GHC.StgToCmm.Monad ( newTemp ) -- XXX layering violation +import GHC.StgToCmm.Utils ( callerSaveVolatileRegs ) -- XXX layering violation +import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation + +import GHC.Cmm +import GHC.Cmm.Info +import GHC.Cmm.BlockId +import GHC.Cmm.Config +import GHC.Cmm.Utils +import GHC.Cmm.Graph +import GHC.Cmm.Liveness +import GHC.Cmm.ProcPoint +import GHC.Runtime.Heap.Layout +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Data.Maybe +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSM +import GHC.Utils.Misc + +import GHC.Utils.Outputable hiding ( isEmpty ) +import GHC.Utils.Panic +import qualified Data.Set as Set +import Control.Monad.Fix +import Data.Array as Array +import Data.List (nub) +import Data.List.NonEmpty ( NonEmpty (..) ) + +{- Note [Stack Layout] + ~~~~~~~~~~~~~~~~~~~ +The job of this pass is to + + - replace references to abstract stack Areas with fixed offsets from Sp. + + - replace the CmmHighStackMark constant used in the stack check with + the maximum stack usage of the proc. + + - save any variables that are live across a call, and reload them as + necessary. + +Before stack allocation, local variables remain live across native +calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local +variables are clobbered by native calls. + +We want to do stack allocation so that as far as possible + - stack use is minimized, and + - unnecessary stack saves and loads are avoided. + +The algorithm we use is a variant of linear-scan register allocation, +where the stack is our register file. + +We proceed in two passes, see Note [Two pass approach] for why they are not easy +to merge into one. + +Pass 1: + + - First, we do a liveness analysis, which annotates every block with + the variables live on entry to the block. + + - We traverse blocks in reverse postorder DFS; that is, we visit at + least one predecessor of a block before the block itself. The + stack layout flowing from the predecessor of the block will + determine the stack layout on entry to the block. + + - We maintain a data structure + + Map Label StackMap + + which describes the contents of the stack and the stack pointer on + entry to each block that is a successor of a block that we have + visited. + + - For each block we visit: + + - Look up the StackMap for this block. + + - If this block is a proc point (or a call continuation, if we aren't + splitting proc points), we need to reload all the live variables from the + stack - but this is done in Pass 2, which calculates more precise liveness + information (see description of Pass 2). + + - Walk forwards through the instructions: + - At an assignment x = Sp[loc] + - Record the fact that Sp[loc] contains x, so that we won't + need to save x if it ever needs to be spilled. + - At an assignment x = E + - If x was previously on the stack, it isn't any more + - At the last node, if it is a call or a jump to a proc point + - Lay out the stack frame for the call (see setupStackFrame) + - emit instructions to save all the live variables + - Remember the StackMaps for all the successors + - emit an instruction to adjust Sp + - If the last node is a branch, then the current StackMap is the + StackMap for the successors. + + - Manifest Sp: replace references to stack areas in this block + with real Sp offsets. We cannot do this until we have laid out + the stack area for the successors above. + + In this phase we also eliminate redundant stores to the stack; + see elimStackStores. + + - There is one important gotcha: sometimes we'll encounter a control + transfer to a block that we've already processed (a join point), + and in that case we might need to rearrange the stack to match + what the block is expecting. (exactly the same as in linear-scan + register allocation, except here we have the luxury of an infinite + supply of temporary variables). + + - Finally, we update the magic CmmHighStackMark constant with the + stack usage of the function, and eliminate the whole stack check + if there was no stack use. (in fact this is done as part of the + main traversal, by feeding the high-water-mark output back in as + an input. I hate cyclic programming, but it's just too convenient + sometimes.) + + There are plenty of tricky details: update frames, proc points, return + addresses, foreign calls, and some ad-hoc optimisations that are + convenient to do here and effective in common cases. Comments in the + code below explain these. + +Pass 2: + +- Calculate live registers, but taking into account that nothing is live at the + entry to a proc point. + +- At each proc point and call continuation insert reloads of live registers from + the stack (they were saved by Pass 1). + + +Note [Two pass approach] +~~~~~~~~~~~~~~~~~~~~~~~~ +The main reason for Pass 2 is being able to insert only the reloads that are +needed and the fact that the two passes need different liveness information. +Let's consider an example: + + ..... + \ / + D <- proc point + / \ + E F + \ / + G <- proc point + | + X + +Pass 1 needs liveness assuming that local variables are preserved across calls. +This is important because it needs to save any local registers to the stack +(e.g., if register a is used in block X, it must be saved before any native +call). +However, for Pass 2, where we want to reload registers from stack (in a proc +point), this is overly conservative and would lead us to generate reloads in D +for things used in X, even though we're going to generate reloads in G anyway +(since it's also a proc point). +So Pass 2 calculates liveness knowing that nothing is live at the entry to a +proc point. This means that in D we only need to reload things used in E or F. +This can be quite important, for an extreme example see testcase for #3294. + +Merging the two passes is not trivial - Pass 2 is a backward rewrite and Pass 1 +is a forward one. Furthermore, Pass 1 is creating code that uses local registers +(saving them before a call), which the liveness analysis for Pass 2 must see to +be correct. + +-} + + +-- All stack locations are expressed as positive byte offsets from the +-- "base", which is defined to be the address above the return address +-- on the stack on entry to this CmmProc. +-- +-- Lower addresses have higher StackLocs. +-- +type StackLoc = ByteOff + +{- + A StackMap describes the stack at any given point. At a continuation + it has a particular layout, like this: + + | | <- base + |-------------| + | ret0 | <- base + 8 + |-------------| + . upd frame . <- base + sm_ret_off + |-------------| + | | + . vars . + . (live/dead) . + | | <- base + sm_sp - sm_args + |-------------| + | ret1 | + . ret vals . <- base + sm_sp (<--- Sp points here) + |-------------| + +Why do we include the final return address (ret0) in our stack map? I +have absolutely no idea, but it seems to be done that way consistently +in the rest of the code generator, so I played along here. --SDM + +Note that we will be constructing an info table for the continuation +(ret1), which needs to describe the stack down to, but not including, +the update frame (or ret0, if there is no update frame). +-} + +data StackMap = StackMap + { sm_sp :: StackLoc + -- ^ the offset of Sp relative to the base on entry + -- to this block. + , sm_args :: ByteOff + -- ^ the number of bytes of arguments in the area for this block + -- Defn: the offset of young(L) relative to the base is given by + -- (sm_sp - sm_args) of the StackMap for block L. + , sm_ret_off :: ByteOff + -- ^ Number of words of stack that we do not describe with an info + -- table, because it contains an update frame. + , sm_regs :: UniqFM LocalReg (LocalReg,StackLoc) + -- ^ regs on the stack + } + +instance Outputable StackMap where + ppr StackMap{..} = + text "Sp = " <> int sm_sp $$ + text "sm_args = " <> int sm_args $$ + text "sm_ret_off = " <> int sm_ret_off $$ + text "sm_regs = " <> pprUFM sm_regs ppr + + +cmmLayoutStack :: CmmConfig -> ProcPointSet -> ByteOff -> CmmGraph + -> UniqDSM (CmmGraph, LabelMap StackMap) +cmmLayoutStack cfg procpoints entry_args + graph@(CmmGraph { g_entry = entry }) + = do + -- We need liveness info. Dead assignments are removed later + -- by the sinking pass. + let liveness = cmmLocalLiveness platform graph + blocks = revPostorder graph + profile = cmmProfile cfg + platform = profilePlatform profile + + (final_stackmaps, _final_high_sp, new_blocks) <- + mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) -> + layout cfg procpoints liveness entry entry_args + rec_stackmaps rec_high_sp blocks + + blocks_with_reloads <- + insertReloadsAsNeeded platform procpoints final_stackmaps entry new_blocks + new_blocks' <- mapM (lowerSafeForeignCall profile) blocks_with_reloads + return (ofBlockList entry new_blocks', final_stackmaps) + +-- ----------------------------------------------------------------------------- +-- Pass 1 +-- ----------------------------------------------------------------------------- + +layout :: CmmConfig + -> LabelSet -- proc points + -> LabelMap CmmLocalLive -- liveness + -> BlockId -- entry + -> ByteOff -- stack args on entry + + -> LabelMap StackMap -- [final] stack maps + -> ByteOff -- [final] Sp high water mark + + -> [CmmBlock] -- [in] blocks + + -> UniqDSM + ( LabelMap StackMap -- [out] stack maps + , ByteOff -- [out] Sp high water mark + , [CmmBlock] -- [out] new blocks + ) + +layout cfg procpoints liveness entry entry_args final_stackmaps final_sp_high blocks + = go blocks init_stackmap entry_args [] + where + (updfr, cont_info) = collectContInfo blocks + + init_stackmap = mapSingleton entry + StackMap{ sm_sp = entry_args + , sm_args = entry_args + , sm_ret_off = updfr + , sm_regs = emptyUFM + } + + go :: [Block CmmNode C C] + -> LabelMap StackMap + -> StackLoc + -> [CmmBlock] + -> UniqDSM (LabelMap StackMap, StackLoc, [CmmBlock]) + go [] acc_stackmaps acc_hwm acc_blocks + = return (acc_stackmaps, acc_hwm, acc_blocks) + + go (b0 : bs) acc_stackmaps acc_hwm acc_blocks + = do + let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0 + + let stack0@StackMap { sm_sp = sp0 } + = mapFindWithDefault + (pprPanic "no stack map for" (ppr entry_lbl)) + entry_lbl acc_stackmaps + + -- (a) Update the stack map to include the effects of + -- assignments in this block + let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0 + + -- (b) Look at the last node and if we are making a call or + -- jumping to a proc point, we must save the live + -- variables, adjust Sp, and construct the StackMaps for + -- each of the successor blocks. See handleLastNode for + -- details. + (middle1, sp_off, last1, fixup_blocks, out) + <- handleLastNode cfg procpoints liveness cont_info + acc_stackmaps stack1 tscope middle0 last0 + + -- (c) Manifest Sp: run over the nodes in the block and replace + -- CmmStackSlot with CmmLoad from Sp with a concrete offset. + -- + -- our block: + -- middle0 -- the original middle nodes + -- middle1 -- live variable saves from handleLastNode + -- Sp = Sp + sp_off -- Sp adjustment goes here + -- last1 -- the last node + -- + let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1 + + let final_blocks = + manifestSp cfg final_stackmaps stack0 sp0 final_sp_high + entry0 middle_pre sp_off last1 fixup_blocks + + let acc_stackmaps' = mapUnion acc_stackmaps out + + -- If this block jumps to the GC, then we do not take its + -- stack usage into account for the high-water mark. + -- Otherwise, if the only stack usage is in the stack-check + -- failure block itself, we will do a redundant stack + -- check. The stack has a buffer designed to accommodate + -- the largest amount of stack needed for calling the GC. + -- + this_sp_hwm | isGcJump last0 = 0 + | otherwise = sp0 - sp_off + + hwm' = maximum (acc_hwm :| this_sp_hwm : map sm_sp (mapElems out)) + + go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks) + + +-- ----------------------------------------------------------------------------- + +-- Not foolproof, but GCFun is the culprit we most want to catch +isGcJump :: CmmNode O C -> Bool +isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal (GlobalRegUse l _)) }) + = l == GCFun || l == GCEnter1 +isGcJump _something_else = False + +-- ----------------------------------------------------------------------------- + +-- This doesn't seem right somehow. We need to find out whether this +-- proc will push some update frame material at some point, so that we +-- can avoid using that area of the stack for spilling. Ideally we would +-- capture this information in the CmmProc (e.g. in CmmStackInfo; see #18232 +-- for details on one ill-fated attempt at this). +-- +-- So we'll just take the max of all the cml_ret_offs. This could be +-- unnecessarily pessimistic, but probably not in the code we +-- generate. + +collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff) +collectContInfo blocks + = (maximum (expectNonEmpty ret_offs), mapFromList (catMaybes mb_argss)) + where + (mb_argss, ret_offs) = mapAndUnzip get_cont blocks + + get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff) + get_cont b = + case lastNode b of + CmmCall { cml_cont = Just l, .. } + -> (Just (l, cml_ret_args), cml_ret_off) + CmmForeignCall { .. } + -> (Just (succ, ret_args), ret_off) + _other -> (Nothing, 0) + + +-- ----------------------------------------------------------------------------- +-- Updating the StackMap from middle nodes + +-- Look for loads from stack slots, and update the StackMap. This is +-- purely for optimisation reasons, so that we can avoid saving a +-- variable back to a different stack slot if it is already on the +-- stack. +-- +-- This happens a lot: for example when function arguments are passed +-- on the stack and need to be immediately saved across a call, we +-- want to just leave them where they are on the stack. +-- +procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap +procMiddle stackmaps node sm + = case node of + CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _ _) + -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) } + where loc = getStackLoc area off stackmaps + CmmAssign (CmmLocal r) _other + -> sm { sm_regs = delFromUFM (sm_regs sm) r } + _other + -> sm + +getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc +getStackLoc Old n _ = n +getStackLoc (Young l) n stackmaps = + case mapLookup l stackmaps of + Nothing -> pprPanic "getStackLoc" (ppr l) + Just sm -> sm_sp sm - sm_args sm + n + + +-- ----------------------------------------------------------------------------- +-- Handling stack allocation for a last node + +-- We take a single last node and turn it into: +-- +-- C1 (some statements) +-- Sp = Sp + N +-- C2 (some more statements) +-- call f() -- the actual last node +-- +-- plus possibly some more blocks (we may have to add some fixup code +-- between the last node and the continuation). +-- +-- C1: is the code for saving the variables across this last node onto +-- the stack, if the continuation is a call or jumps to a proc point. +-- +-- C2: if the last node is a safe foreign call, we have to inject some +-- extra code that goes *after* the Sp adjustment. + +handleLastNode + :: CmmConfig -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff + -> LabelMap StackMap -> StackMap -> CmmTickScope + -> Block CmmNode O O + -> CmmNode O C + -> UniqDSM + ( [CmmNode O O] -- nodes to go *before* the Sp adjustment + , ByteOff -- amount to adjust Sp + , CmmNode O C -- new last node + , [CmmBlock] -- new blocks + , LabelMap StackMap -- stackmaps for the continuations + ) + +handleLastNode cfg procpoints liveness cont_info stackmaps + stack0@StackMap { sm_sp = sp0 } tscp middle last + = case last of + -- At each return / tail call, + -- adjust Sp to point to the last argument pushed, which + -- is cml_args, after popping any other junk from the stack. + CmmCall{ cml_cont = Nothing, .. } -> do + let sp_off = sp0 - cml_args + return ([], sp_off, last, [], mapEmpty) + + -- At each CmmCall with a continuation: + CmmCall{ cml_cont = Just cont_lbl, .. } -> + return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off + + CmmForeignCall{ succ = cont_lbl, .. } -> + return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off + -- one word of args: the return address + + CmmBranch {} -> handleBranches + CmmCondBranch {} -> handleBranches + CmmSwitch {} -> handleBranches + where + platform = cmmPlatform cfg + -- Calls and ForeignCalls are handled the same way: + lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff + -> ( [CmmNode O O] + , ByteOff + , CmmNode O C + , [CmmBlock] + , LabelMap StackMap + ) + lastCall lbl cml_args cml_ret_args cml_ret_off + = ( assignments + , spOffsetForCall sp0 cont_stack cml_args + , last + , [] -- no new blocks + , mapSingleton lbl cont_stack ) + where + (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off + + + prepareStack lbl cml_ret_args cml_ret_off + | Just cont_stack <- mapLookup lbl stackmaps + -- If we have already seen this continuation before, then + -- we just have to make the stack look the same: + = (fixupStack stack0 cont_stack, cont_stack) + -- Otherwise, we have to allocate the stack frame + | otherwise + = (save_assignments, new_cont_stack) + where + (new_cont_stack, save_assignments) + = setupStackFrame platform lbl liveness cml_ret_off cml_ret_args stack0 + + + -- For other last nodes (branches), if any of the targets is a + -- proc point, we have to set up the stack to match what the proc + -- point is expecting. + -- + handleBranches :: UniqDSM ( [CmmNode O O] + , ByteOff + , CmmNode O C + , [CmmBlock] + , LabelMap StackMap ) + + handleBranches + -- See Note [diamond proc point] + | Just l <- futureContinuation middle + , (nub $ filter (`setMember` procpoints) $ successors last) == [l] + = do + let cont_args = mapFindWithDefault 0 l cont_info + (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0) + out = mapFromList [ (l', cont_stack) + | l' <- successors last ] + return ( assigs + , spOffsetForCall sp0 cont_stack (platformWordSizeInBytes platform) + , last + , [] + , out) + + | otherwise = do + pps <- mapM handleBranch (successors last) + let lbl_map :: LabelMap Label + lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ] + fix_lbl l = mapFindWithDefault l l lbl_map + return ( [] + , 0 + , mapSuccessors fix_lbl last + , concat [ blk | (_,_,_,blk) <- pps ] + , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] ) + + -- For each successor of this block + handleBranch :: BlockId -> UniqDSM (BlockId, BlockId, StackMap, [CmmBlock]) + handleBranch l + -- (a) if the successor already has a stackmap, we need to + -- shuffle the current stack to make it look the same. + -- We have to insert a new block to make this happen. + | Just stack2 <- mapLookup l stackmaps + = do + let assigs = fixupStack stack0 stack2 + (tmp_lbl, block) <- makeFixupBlock cfg sp0 l stack2 tscp assigs + return (l, tmp_lbl, stack2, block) + + -- (b) if the successor is a proc point, save everything + -- on the stack. + | l `setMember` procpoints + = do + let cont_args = mapFindWithDefault 0 l cont_info + (stack2, assigs) = + setupStackFrame platform l liveness (sm_ret_off stack0) + cont_args stack0 + (tmp_lbl, block) <- makeFixupBlock cfg sp0 l stack2 tscp assigs + return (l, tmp_lbl, stack2, block) + + -- (c) otherwise, the current StackMap is the StackMap for + -- the continuation. But we must remember to remove any + -- variables from the StackMap that are *not* live at + -- the destination, because this StackMap might be used + -- by fixupStack if this is a join point. + | otherwise = return (l, l, stack1, []) + where live = mapFindWithDefault (panic "handleBranch") l liveness + stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) } + is_live (r,_) = r `elemRegSet` live + + +makeFixupBlock :: CmmConfig -> ByteOff -> Label -> StackMap + -> CmmTickScope -> [CmmNode O O] + -> UniqDSM (Label, [CmmBlock]) +makeFixupBlock cfg sp0 l stack tscope assigs + | null assigs && sp0 == sm_sp stack = return (l, []) + | otherwise = do + tmp_lbl <- newBlockId + let sp_off = sp0 - sm_sp stack + block = blockJoin (CmmEntry tmp_lbl tscope) + ( maybeAddSpAdj cfg sp0 sp_off + $ blockFromList assigs ) + (CmmBranch l) + return (tmp_lbl, [block]) + + +-- Sp is currently pointing to current_sp, +-- we want it to point to +-- (sm_sp cont_stack - sm_args cont_stack + args) +-- so the difference is +-- sp0 - (sm_sp cont_stack - sm_args cont_stack + args) +spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff +spOffsetForCall current_sp cont_stack args + = current_sp - (sm_sp cont_stack - sm_args cont_stack + args) + + +-- | create a sequence of assignments to establish the new StackMap, +-- given the old StackMap. +fixupStack :: StackMap -> StackMap -> [CmmNode O O] +fixupStack old_stack new_stack = concatMap move new_locs + where + old_map = sm_regs old_stack + new_locs = stackSlotRegs new_stack + + move (r,n) + | Just (_,m) <- lookupUFM old_map r, n == m = [] + | otherwise = [CmmStore (CmmStackSlot Old n) + (CmmReg (CmmLocal r)) + NaturallyAligned] + + + +setupStackFrame + :: Platform + -> BlockId -- label of continuation + -> LabelMap CmmLocalLive -- liveness + -> ByteOff -- updfr + -> ByteOff -- bytes of return values on stack + -> StackMap -- current StackMap + -> (StackMap, [CmmNode O O]) + +setupStackFrame platform lbl liveness updfr_off ret_args stack0 + = (cont_stack, assignments) + where + -- get the set of LocalRegs live in the continuation + live = mapFindWithDefault Set.empty lbl liveness + + -- the stack from the base to updfr_off is off-limits. + -- our new stack frame contains: + -- * saved live variables + -- * the return address [young(C) + 8] + -- * the args for the call, + -- which are replaced by the return values at the return + -- point. + + -- everything up to updfr_off is off-limits + -- stack1 contains updfr_off, plus everything we need to save + (stack1, assignments) = allocate platform updfr_off live stack0 + + -- And the Sp at the continuation is: + -- sm_sp stack1 + ret_args + cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args + , sm_args = ret_args + , sm_ret_off = updfr_off + } + + +-- Note [diamond proc point] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- This special case looks for the pattern we get from a typical +-- tagged case expression: +-- +-- Sp[young(L1)] = L1 +-- if (R1 & 7) != 0 goto L1 else goto L2 +-- L2: +-- call [R1] returns to L1 +-- L1: live: {y} +-- x = R1 +-- +-- If we let the generic case handle this, we get +-- +-- Sp[-16] = L1 +-- if (R1 & 7) != 0 goto L1a else goto L2 +-- L2: +-- Sp[-8] = y +-- Sp = Sp - 16 +-- call [R1] returns to L1 +-- L1a: +-- Sp[-8] = y +-- Sp = Sp - 16 +-- goto L1 +-- L1: +-- x = R1 +-- +-- The code for saving the live vars is duplicated in each branch, and +-- furthermore there is an extra jump in the fast path (assuming L1 is +-- a proc point, which it probably is if there is a heap check). +-- +-- So to fix this we want to set up the stack frame before the +-- conditional jump. How do we know when to do this, and when it is +-- safe? The basic idea is, when we see the assignment +-- +-- Sp[young(L)] = L +-- +-- we know that +-- * we are definitely heading for L +-- * there can be no more reads from another stack area, because young(L) +-- overlaps with it. +-- +-- We don't necessarily know that everything live at L is live now +-- (some might be assigned between here and the jump to L). So we +-- simplify and only do the optimisation when we see +-- +-- (1) a block containing an assignment of a return address L +-- (2) ending in a branch where one (and only) continuation goes to L, +-- and no other continuations go to proc points. +-- +-- then we allocate the stack frame for L at the end of the block, +-- before the branch. +-- +-- We could generalise (2), but that would make it a bit more +-- complicated to handle, and this currently catches the common case. + +futureContinuation :: Block CmmNode O O -> Maybe BlockId +futureContinuation middle = foldBlockNodesB f middle Nothing + where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId + f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _)) _) _ + = Just l + f _ r = r + +-- ----------------------------------------------------------------------------- +-- Saving live registers + +-- | Given a set of live registers and a StackMap, save all the registers +-- on the stack and return the new StackMap and the assignments to do +-- the saving. +-- +allocate :: Platform -> ByteOff -> LocalRegSet -> StackMap + -> (StackMap, [CmmNode O O]) +allocate platform ret_off live stackmap@StackMap{ sm_sp = sp0 + , sm_regs = regs0 } + = + -- we only have to save regs that are not already in a slot + let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live) + regs1 = filterUFM (\(r,_) -> elemRegSet r live) regs0 + in + + -- make a map of the stack + let stack = reverse $ Array.elems $ + accumArray (\_ x -> x) Empty (1, toWords platform (max sp0 ret_off)) $ + ret_words ++ live_words + where ret_words = + [ (x, Occupied) + | x <- [ 1 .. toWords platform ret_off] ] + live_words = + [ (toWords platform x, Occupied) + | (r,off) <- nonDetEltsUFM regs1, + -- See Note [Unique Determinism and code generation] + let w = localRegBytes platform r, + x <- [ off, off - platformWordSizeInBytes platform .. off - w + 1] ] + in + + -- Pass over the stack: find slots to save all the new live variables, + -- choosing the oldest slots first (hence a foldr). + let + save slot ([], stack, n, assigs, regs) -- no more regs to save + = ([], slot:stack, plusW platform n 1, assigs, regs) + save slot (to_save, stack, n, assigs, regs) + = case slot of + Occupied -> (to_save, Occupied:stack, plusW platform n 1, assigs, regs) + Empty + | Just (stack', r, to_save') <- + select_save to_save (slot:stack) + -> let assig = CmmStore (CmmStackSlot Old n') + (CmmReg (CmmLocal r)) + NaturallyAligned + n' = plusW platform n 1 + in + (to_save', stack', n', assig : assigs, (r,(r,n')):regs) + + | otherwise + -> (to_save, slot:stack, plusW platform n 1, assigs, regs) + + -- we should do better here: right now we'll fit the smallest first, + -- but it would make more sense to fit the biggest first. + select_save :: [LocalReg] -> [StackSlot] + -> Maybe ([StackSlot], LocalReg, [LocalReg]) + select_save regs stack = go regs [] + where go [] _no_fit = Nothing + go (r:rs) no_fit + | Just rest <- dropEmpty words stack + = Just (replicate words Occupied ++ rest, r, rs++no_fit) + | otherwise + = go rs (r:no_fit) + where words = localRegWords platform r + + -- fill in empty slots as much as possible + (still_to_save, save_stack, n, save_assigs, save_regs) + = foldr save (to_save, [], 0, [], []) stack + + -- push any remaining live vars on the stack + (push_sp, push_assigs, push_regs) + = foldr push (n, [], []) still_to_save + where + push r (n, assigs, regs) + = (n', assig : assigs, (r,(r,n')) : regs) + where + n' = n + localRegBytes platform r + assig = CmmStore (CmmStackSlot Old n') + (CmmReg (CmmLocal r)) + NaturallyAligned + + trim_sp + | not (null push_regs) = push_sp + | otherwise + = plusW platform n (- length (takeWhile isEmpty save_stack)) + + final_regs = regs1 `addListToUFM` push_regs + `addListToUFM` save_regs + + in + -- XXX should be an assert + if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else + + if (trim_sp .&. (platformWordSizeInBytes platform - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else + + ( stackmap { sm_regs = final_regs , sm_sp = trim_sp } + , push_assigs ++ save_assigs ) + + +-- ----------------------------------------------------------------------------- +-- Manifesting Sp + +-- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp. The +-- block looks like this: +-- +-- middle_pre -- the middle nodes +-- Sp = Sp + sp_off -- Sp adjustment goes here +-- last -- the last node +-- +-- And we have some extra blocks too (that don't contain Sp adjustments) +-- +-- The adjustment for middle_pre will be different from that for +-- middle_post, because the Sp adjustment intervenes. +-- +manifestSp + :: CmmConfig + -> LabelMap StackMap -- StackMaps for other blocks + -> StackMap -- StackMap for this block + -> ByteOff -- Sp on entry to the block + -> ByteOff -- SpHigh + -> CmmNode C O -- first node + -> [CmmNode O O] -- middle + -> ByteOff -- sp_off + -> CmmNode O C -- last node + -> [CmmBlock] -- new blocks + -> [CmmBlock] -- final blocks with Sp manifest + +manifestSp cfg stackmaps stack0 sp0 sp_high + first middle_pre sp_off last fixup_blocks + = final_block : fixup_blocks' + where + area_off = getAreaOff stackmaps + platform = cmmPlatform cfg + + adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x + adj_pre_sp = mapExpDeep (areaToSp platform sp0 sp_high area_off) + adj_post_sp = mapExpDeep (areaToSp platform (sp0 - sp_off) sp_high area_off) + + final_middle = maybeAddSpAdj cfg sp0 sp_off + . blockFromList + . map adj_pre_sp + . elimStackStores stack0 stackmaps area_off + $ middle_pre + final_last = optStackCheck (adj_post_sp last) + + final_block = blockJoin first final_middle final_last + + fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks + +getAreaOff :: LabelMap StackMap -> (Area -> StackLoc) +getAreaOff _ Old = 0 +getAreaOff stackmaps (Young l) = + case mapLookup l stackmaps of + Just sm -> sm_sp sm - sm_args sm + Nothing -> pprPanic "getAreaOff" (ppr l) + + +maybeAddSpAdj + :: CmmConfig -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O +maybeAddSpAdj cfg sp0 sp_off block = + add_initial_unwind $ add_adj_unwind $ adj block + where + platform = cmmPlatform cfg + do_stk_unwinding_gen = cmmGenStackUnwindInstr cfg + adj block + | sp_off /= 0 + = block `blockSnoc` CmmAssign (spReg platform) (cmmOffset platform (spExpr platform) sp_off) + | otherwise = block + -- Add unwind pseudo-instruction at the beginning of each block to + -- document Sp level for debugging + add_initial_unwind block + | do_stk_unwinding_gen + = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block + | otherwise + = block + where sp_unwind = CmmRegOff (spReg platform) (sp0 - platformWordSizeInBytes platform) + + -- Add unwind pseudo-instruction right after the Sp adjustment + -- if there is one. + add_adj_unwind block + | do_stk_unwinding_gen + , sp_off /= 0 + = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)] + | otherwise + = block + where sp_unwind = CmmRegOff (spReg platform) (sp0 - platformWordSizeInBytes platform - sp_off) + +{- Note [SP old/young offsets] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sp(L) is the Sp offset on entry to block L relative to the base of the +OLD area. + +SpArgs(L) is the size of the young area for L, i.e. the number of +arguments. + + - in block L, each reference to [old + N] turns into + [Sp + Sp(L) - N] + + - in block L, each reference to [young(L') + N] turns into + [Sp + Sp(L) - Sp(L') + SpArgs(L') - N] + + - be careful with the last node of each block: Sp has already been adjusted + to be Sp + Sp(L) - Sp(L') +-} + +areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr + +areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n) + = cmmOffset platform (spExpr platform) (sp_old - area_off area - n) + -- Replace (CmmStackSlot area n) with an offset from Sp + +areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark) + = mkIntExpr platform sp_hwm + -- Replace CmmHighStackMark with the number of bytes of stack used, + -- the sp_hwm. See Note [Stack usage] in GHC.StgToCmm.Heap + +areaToSp platform _ _ _ (CmmMachOp (MO_U_Lt _) args) + | falseStackCheck args + = zeroExpr platform +areaToSp platform _ _ _ (CmmMachOp (MO_U_Ge _) args) + | falseStackCheck args + = mkIntExpr platform 1 + -- Replace a stack-overflow test that cannot fail with a no-op + -- See Note [Always false stack check] + +areaToSp _ _ _ _ other = other + +-- | Determine whether a stack check cannot fail. +falseStackCheck :: [CmmExpr] -> Bool +falseStackCheck [ CmmMachOp (MO_Sub _) + [ CmmRegOff (CmmGlobal (GlobalRegUse Sp _)) x_off + , CmmLit (CmmInt y_lit _)] + , CmmReg (CmmGlobal (GlobalRegUse SpLim _))] + = fromIntegral x_off >= y_lit +falseStackCheck _ = False + +-- Note [Always false stack check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We can optimise stack checks of the form +-- +-- if ((Sp + x) - y < SpLim) then .. else .. +-- +-- where are non-negative integer byte offsets. Since we know that +-- SpLim <= Sp (remember the stack grows downwards), this test must +-- yield False if (x >= y), so we can rewrite the comparison to False. +-- A subsequent sinking pass will later drop the dead code. +-- Optimising this away depends on knowing that SpLim <= Sp, so it is +-- really the job of the stack layout algorithm, hence we do it now. +-- +-- The control flow optimiser may negate a conditional to increase +-- the likelihood of a fallthrough if the branch is not taken. But +-- not every conditional is inverted as the control flow optimiser +-- places some requirements on the predecessors of both branch targets. +-- So we better look for the inverted comparison too. + +optStackCheck :: CmmNode O C -> CmmNode O C +optStackCheck n = -- Note [Always false stack check] + case n of + CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false + CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true + other -> other + + +-- ----------------------------------------------------------------------------- + +-- | Eliminate stores of the form +-- +-- Sp[area+n] = r +-- +-- when we know that r is already in the same slot as Sp[area+n]. We +-- could do this in a later optimisation pass, but that would involve +-- a separate analysis and we already have the information to hand +-- here. It helps clean up some extra stack stores in common cases. +-- +-- Note that we may have to modify the StackMap as we walk through the +-- code using procMiddle, since an assignment to a variable in the +-- StackMap will invalidate its mapping there. +-- +elimStackStores :: StackMap + -> LabelMap StackMap + -> (Area -> ByteOff) + -> [CmmNode O O] + -> [CmmNode O O] +elimStackStores stackmap stackmaps area_off nodes + = go stackmap nodes + where + go _stackmap [] = [] + go stackmap (n:ns) + = case n of + CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r)) _ + | Just (_,off) <- lookupUFM (sm_regs stackmap) r + , area_off area + m == off + -> go stackmap ns + _otherwise + -> n : go (procMiddle stackmaps n stackmap) ns + + +-- ----------------------------------------------------------------------------- +-- Update info tables to include stack liveness + + +setInfoTableStackMap :: Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl +setInfoTableStackMap platform stackmaps (CmmProc top_info@TopInfo{..} l v g) + = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g + where + fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } = + info_tbl { cit_rep = StackRep (get_liveness lbl) } + fix_info _ other = other + + get_liveness :: BlockId -> Liveness + get_liveness lbl + = case mapLookup lbl stackmaps of + Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> pdoc platform info_tbls) + Just sm -> stackMapToLiveness platform sm + +setInfoTableStackMap _ _ d = d + + +stackMapToLiveness :: Platform -> StackMap -> Liveness +stackMapToLiveness platform StackMap{..} = + reverse $ Array.elems $ + accumArray (\_ x -> x) True (toWords platform sm_ret_off + 1, + toWords platform (sm_sp - sm_args)) live_words + where + live_words = [ (toWords platform off, False) + | (r,off) <- nonDetEltsUFM sm_regs + , isGcPtrType (localRegType r) ] + -- See Note [Unique Determinism and code generation] + +-- ----------------------------------------------------------------------------- +-- Pass 2 +-- ----------------------------------------------------------------------------- + +insertReloadsAsNeeded + :: Platform + -> ProcPointSet + -> LabelMap StackMap + -> BlockId + -> [CmmBlock] + -> UniqDSM [CmmBlock] +insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks = + toBlockList . fst <$> + rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty + where + rewriteCC :: RewriteFun CmmLocalLive + rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do + let entry_label = entryLabel e_node + stackmap = case mapLookup entry_label final_stackmaps of + Just sm -> sm + Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap" + + -- Merge the liveness from successor blocks and analyse the last + -- node. + joined = gen_kill platform x_node $! + joinOutFacts liveLattice x_node fact_base0 + -- What is live at the start of middle0. + live_at_middle0 = foldNodesBwdOO (gen_kill platform) middle0 joined + + -- If this is a procpoint we need to add the reloads, but only if + -- they're actually live. Furthermore, nothing is live at the entry + -- to a proc point. + (middle1, live_with_reloads) + | entry_label `setMember` procpoints + = let reloads = insertReloads platform stackmap live_at_middle0 + in (foldr blockCons middle0 reloads, emptyRegSet) + | otherwise + = (middle0, live_at_middle0) + + -- Final liveness for this block. + !fact_base2 = mapSingleton entry_label live_with_reloads + + return (BlockCC e_node middle1 x_node, fact_base2) + +insertReloads :: Platform -> StackMap -> CmmLocalLive -> [CmmNode O O] +insertReloads platform stackmap live = + [ CmmAssign (CmmLocal reg) + -- This cmmOffset basically corresponds to manifesting + -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets] + (CmmLoad (cmmOffset platform (spExpr platform) (sp_off - reg_off)) + (localRegType reg) + NaturallyAligned) + | (reg, reg_off) <- stackSlotRegs stackmap + , reg `elemRegSet` live + ] + where + sp_off = sm_sp stackmap + +-- ----------------------------------------------------------------------------- +-- Lowering safe foreign calls + +{- +Note [Lower safe foreign calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We start with + + Sp[young(L1)] = L1 + ,----------------------- + | r1 = foo(x,y,z) returns to L1 + '----------------------- + L1: + R1 = r1 -- copyIn, inserted by mkSafeCall + ... + +the stack layout algorithm will arrange to save and reload everything +live across the call. Our job now is to expand the call so we get + + Sp[young(L1)] = L1 + ,----------------------- + | SAVE_THREAD_STATE() + | token = suspendThread(BaseReg, interruptible) + | r = foo(x,y,z) + | BaseReg = resumeThread(token) + | LOAD_THREAD_STATE() + | R1 = r -- copyOut + | jump Sp[0] + '----------------------- + L1: + r = R1 -- copyIn, inserted by mkSafeCall + ... + +Note the copyOut, which saves the results in the places that L1 is +expecting them (see Note [safe foreign call convention]). Note also +that safe foreign call is replace by an unsafe one in the Cmm graph. +-} + +lowerSafeForeignCall :: Profile -> CmmBlock -> UniqDSM CmmBlock +lowerSafeForeignCall profile block + | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block + = do + let platform = profilePlatform profile + -- Both 'id' and 'new_base' are KindNonPtr because they're + -- RTS-only objects and are not subject to garbage collection + id <- newTemp (bWord platform) + new_base <- newTemp (cmmRegType $ baseReg platform) + let (caller_save, caller_load) = callerSaveVolatileRegs platform + save_state_code <- saveThreadState profile + load_state_code <- loadThreadState profile + let suspend = save_state_code <*> + caller_save <*> + mkMiddle (callSuspendThread platform id intrbl) + midCall = mkUnsafeCall tgt res args + resume = mkMiddle (callResumeThread new_base id) <*> + -- Assign the result to BaseReg: we + -- might now have a different Capability! + mkAssign (baseReg platform) (CmmReg (CmmLocal new_base)) <*> + caller_load <*> + load_state_code + + (_, regs, copyout) = + copyOutOflow profile NativeReturn Jump (Young succ) + (map (CmmReg . CmmLocal) res) + ret_off [] + + -- NB. after resumeThread returns, the top-of-stack probably contains + -- the stack frame for succ, but it might not: if the current thread + -- received an exception during the call, then the stack might be + -- different. Hence we continue by jumping to the top stack frame, + -- not by jumping to succ. + jump = CmmCall { cml_target = entryCode platform $ + cmmLoadBWord platform (spExpr platform) + , cml_cont = Just succ + , cml_args_regs = regs + , cml_args = widthInBytes (wordWidth platform) + , cml_ret_args = ret_args + , cml_ret_off = ret_off } + + graph' <- lgraphOfAGraph ( suspend <*> + midCall <*> + resume <*> + copyout <*> + mkLast jump, tscp) + + case toBlockList (removeDetermGraph graph') of + [one] -> let (_, middle', last) = blockSplit one + in return (blockJoin entry (middle `blockAppend` middle') last) + _ -> panic "lowerSafeForeignCall0" + + -- Block doesn't end in a safe foreign call: + | otherwise = return block + + +callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O +callSuspendThread platform id intrbl = + CmmUnsafeForeignCall (PrimTarget MO_SuspendThread) + [id] [baseExpr platform, mkIntExpr platform (fromEnum intrbl)] + +callResumeThread :: LocalReg -> LocalReg -> CmmNode O O +callResumeThread new_base id = + CmmUnsafeForeignCall (PrimTarget MO_ResumeThread) + [new_base] [CmmReg (CmmLocal id)] + +-- ----------------------------------------------------------------------------- + +plusW :: Platform -> ByteOff -> WordOff -> ByteOff +plusW platform b w = b + w * platformWordSizeInBytes platform + +data StackSlot = Occupied | Empty + -- Occupied: a return address or part of an update frame + +instance Outputable StackSlot where + ppr Occupied = text "XXX" + ppr Empty = text "---" + +dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot] +dropEmpty 0 ss = Just ss +dropEmpty n (Empty : ss) = dropEmpty (n-1) ss +dropEmpty _ _ = Nothing + +isEmpty :: StackSlot -> Bool +isEmpty Empty = True +isEmpty _ = False + +localRegBytes :: Platform -> LocalReg -> ByteOff +localRegBytes platform r + = roundUpToWords platform (widthInBytes (typeWidth (localRegType r))) + +localRegWords :: Platform -> LocalReg -> WordOff +localRegWords platform = toWords platform . localRegBytes platform + +toWords :: Platform -> ByteOff -> WordOff +toWords platform x = x `quot` platformWordSizeInBytes platform + + +stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)] +stackSlotRegs sm = nonDetEltsUFM (sm_regs sm) + -- See Note [Unique Determinism and code generation] diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Lexer.hs @@ -0,0 +1,1087 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LINE 13 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Cmm/Lexer.x" #-} +module GHC.Cmm.Lexer ( + CmmToken(..), cmmlex, + ) where + +import GHC.Prelude + +import GHC.Cmm.Expr +import GHC.Cmm.Reg (GlobalArgRegs(..)) + +import GHC.Parser.Lexer +import GHC.Cmm.Parser.Monad +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Parser.CharClass +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () +import GHC.Platform +import GHC.Utils.Error +import GHC.Utils.Misc +--import TRACE + +import Data.Word +import Data.Char +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array.Base (unsafeAt) +import GHC.Exts +#else +import GlaExts +#endif +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: AlexAddr +alex_base = AlexA# + "\x01\x00\x00\x00\xc9\x00\x00\x00\x57\x00\x00\x00\xb9\x00\x00\x00\x2a\x01\x00\x00\x29\x02\x00\x00\x28\x03\x00\x00\x27\x04\x00\x00\x26\x05\x00\x00\x25\x06\x00\x00\x25\x07\x00\x00\xf8\x07\x00\x00\xcb\x08\x00\x00\x9e\x09\x00\x00\x93\xff\xff\xff\xa6\xff\xff\xff\xc2\xff\xff\xff\xce\xff\xff\xff\xd2\xff\xff\xff\x00\x00\x00\x00\xe1\xff\xff\xff\xd7\xff\xff\xff\xe6\xff\xff\xff\x00\x00\x00\x00\xe9\xff\xff\xff\xde\xff\xff\xff\xdb\xff\xff\xff\xef\xff\xff\xff\xe0\xff\xff\xff\x02\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x03\x00\x00\x00\xf9\xff\xff\xff\x05\x00\x00\x00\xf1\xff\xff\xff\x06\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\xf2\xff\xff\xff\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x71\x0a\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x71\x00\x00\x00\xc4\x00\x00\x00\xb7\x00\x00\x00\xbd\x00\x00\x00\xbe\x00\x00\x00\xc2\x00\x00\x00\xc1\x00\x00\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x44\x0b\x00\x00\x17\x0c\x00\x00\xea\x0c\x00\x00\xbd\x0d\x00\x00\x90\x0e\x00\x00\x63\x0f\x00\x00\x36\x10\x00\x00\x09\x11\x00\x00\xdc\x11\x00\x00\xaf\x12\x00\x00\x82\x13\x00\x00\x55\x14\x00\x00\x28\x15\x00\x00\xfb\x15\x00\x00\xce\x16\x00\x00\xa1\x17\x00\x00\x74\x18\x00\x00\x47\x19\x00\x00\x1a\x1a\x00\x00\xd7\x00\x00\x00\xd9\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\xd8\x00\x00\x00\x7a\x00\x00\x00\x6a\x00\x00\x00\x72\x00\x00\x00\x82\x00\x00\x00\xed\x1a\x00\x00\xc0\x1b\x00\x00\x93\x1c\x00\x00\x66\x1d\x00\x00\x39\x1e\x00\x00\x0c\x1f\x00\x00\xdf\x1f\x00\x00\xb2\x20\x00\x00\x85\x21\x00\x00\x58\x22\x00\x00\x2b\x23\x00\x00\xfe\x23\x00\x00\xd1\x24\x00\x00\xa4\x25\x00\x00\x77\x26\x00\x00\x4a\x27\x00\x00\x1d\x28\x00\x00\xf0\x28\x00\x00\xc3\x29\x00\x00\x96\x2a\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x8c\x00\x00\x00\x03\x01\x00\x00\x84\x01\x00\x00\x87\x00\x00\x00\x83\x00\x00\x00\x8e\x00\x00\x00\x34\x2b\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x46\x01\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\xa4\x02\x00\x00\xa3\x03\x00\x00\x7d\x2b\x00\x00\xa4\x01\x00\x00\x00\x02\x00\x00\x81\x04\x00\x00\xa1\x04\x00\x00\x96\x2b\x00\x00\xbc\x2b\x00\x00\xfd\x04\x00\x00\xd5\x2b\x00\x00\x80\x05\x00\x00\x49\x2c\x00\x00\x1c\x2d\x00\x00\xef\x2d\x00\x00\xc2\x2e\x00\x00\x95\x2f\x00\x00\x68\x30\x00\x00\x3b\x31\x00\x00\x0e\x32\x00\x00\xe1\x32\x00\x00\xb4\x33\x00\x00\x87\x34\x00\x00\x5a\x35\x00\x00\x2d\x36\x00\x00\x00\x37\x00\x00\xd3\x37\x00\x00\xa6\x38\x00\x00\x79\x39\x00\x00\x4c\x3a\x00\x00\x1f\x3b\x00\x00\xf2\x3b\x00\x00\xc5\x3c\x00\x00\x98\x3d\x00\x00\x6b\x3e\x00\x00\x3e\x3f\x00\x00\x11\x40\x00\x00\xe4\x40\x00\x00\xb7\x41\x00\x00\x8a\x42\x00\x00\x5d\x43\x00\x00\x30\x44\x00\x00\x03\x45\x00\x00\xd6\x45\x00\x00\x9e\x46\x00\x00\x9d\x47\x00\x00\x9d\x48\x00\x00\x70\x49\x00\x00\x43\x4a\x00\x00\x16\x4b\x00\x00\xe9\x4b\x00\x00\xbc\x4c\x00\x00\x8f\x4d\x00\x00\x62\x4e\x00\x00\x35\x4f\x00\x00\x08\x50\x00\x00\xdb\x50\x00\x00\xae\x51\x00\x00\x81\x52\x00\x00\x54\x53\x00\x00\x27\x54\x00\x00\xfa\x54\x00\x00\xcd\x55\x00\x00\xa0\x56\x00\x00\x73\x57\x00\x00\x46\x58\x00\x00\x19\x59\x00\x00\xec\x59\x00\x00\xbf\x5a\x00\x00\x92\x5b\x00\x00\x65\x5c\x00\x00\x38\x5d\x00\x00\x0b\x5e\x00\x00\xde\x5e\x00\x00\xb1\x5f\x00\x00\x84\x60\x00\x00\x57\x61\x00\x00\x2a\x62\x00\x00\xfd\x62\x00\x00\xd0\x63\x00\x00\xa3\x64\x00\x00\x76\x65\x00\x00\x49\x66\x00\x00\x1c\x67\x00\x00\xef\x67\x00\x00\xc2\x68\x00\x00\x95\x69\x00\x00\x68\x6a\x00\x00\x3b\x6b\x00\x00\x0e\x6c\x00\x00\xe1\x6c\x00\x00\xb4\x6d\x00\x00\x87\x6e\x00\x00\x5a\x6f\x00\x00\x2d\x70\x00\x00\x00\x71\x00\x00\xd3\x71\x00\x00\xa6\x72\x00\x00\x79\x73\x00\x00\x4c\x74\x00\x00\x1f\x75\x00\x00\xf2\x75\x00\x00\xc5\x76\x00\x00\x98\x77\x00\x00\x6b\x78\x00\x00\x3e\x79\x00\x00\x11\x7a\x00\x00\xe4\x7a\x00\x00\xb7\x7b\x00\x00\x8a\x7c\x00\x00\x5d\x7d\x00\x00\x25\x7e\x00\x00\x24\x7f\x00\x00\x24\x80\x00\x00\xf7\x80\x00\x00\xbf\x81\x00\x00\xbe\x82\x00\x00\xbe\x83\x00\x00\x91\x84\x00\x00\x59\x85\x00\x00\x58\x86\x00\x00\x57\x87\x00\x00\x56\x88\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# + "\x00\x00\xff\xff\x8d\x00\xff\xff\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x3a\x00\x81\x00\x81\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x2b\x00\x84\x00\x5e\x00\x11\x00\x1f\x00\x29\x00\xff\xff\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x39\x00\xaf\x00\x38\x00\x8e\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x35\x00\x38\x00\x31\x00\x2d\x00\x33\x00\xff\xff\x12\x00\x15\x00\x69\x00\xa9\x00\xb1\x00\x13\x00\xb0\x00\xb4\x00\xaa\x00\x16\x00\x17\x00\x19\x00\xfe\x00\x45\x00\x1a\x00\x1b\x00\x08\x00\x1d\x00\x06\x00\x4b\x00\x9d\x00\xa5\x00\xb6\x00\x1c\x00\xb3\x00\xfa\x00\xf6\x00\x38\x00\xff\xff\x38\x00\x38\x00\x81\x00\x38\x00\x81\x00\x81\x00\x81\x00\x22\x00\x23\x00\x1e\x00\x21\x00\x24\x00\x14\x00\x25\x00\x26\x00\x71\x00\x28\x00\x2a\x00\x2c\x00\x2e\x00\x32\x00\x2f\x00\x30\x00\x34\x00\x36\x00\x81\x00\x80\x00\x5a\x00\x5e\x00\xff\xff\x38\x00\x27\x00\x38\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\x3d\x00\x3d\x00\x3d\x00\xff\xff\xff\xff\x18\x00\x5c\x00\xff\xff\xff\xff\x3d\x00\xff\xff\x3d\x00\x3d\x00\x3d\x00\x81\x00\x60\x00\x81\x00\x81\x00\x81\x00\x89\x00\xff\xff\x3d\x00\x20\x00\x82\x00\x43\x00\xff\xff\xff\xff\x59\x00\x61\x00\xff\xff\xff\xff\xff\xff\x3d\x00\x5c\x00\x5f\x00\x76\x00\x78\x00\x81\x00\x77\x00\xff\xff\x5e\x00\x7b\x00\x7c\x00\x7f\x00\x7d\x00\x80\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\xff\xff\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5b\x00\x7a\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x40\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x04\x00\x00\x00\x90\x00\x90\x00\x42\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x3c\x00\x5d\x00\x44\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x81\x00\x00\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x3d\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x3d\x00\x00\x00\x81\x00\x00\x00\x00\x00\x81\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x05\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7e\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x07\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7e\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x07\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x89\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x88\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x8d\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x09\x00\x00\x00\x90\x00\x90\x00\x79\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x09\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x8b\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x86\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x79\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x66\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x04\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x4a\x00\x00\x00\x49\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbb\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcf\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd3\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd9\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xdd\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xf3\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xf7\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfb\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfd\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfd\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# + "\xff\xff\x00\x00\x01\x00\x02\x00\x71\x00\x5f\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x63\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x73\x00\x61\x00\x42\x00\x43\x00\x44\x00\x74\x00\x46\x00\x47\x00\x48\x00\x73\x00\x65\x00\x63\x00\x4c\x00\x4d\x00\x71\x00\x75\x00\x50\x00\x72\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x69\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x09\x00\x60\x00\x0b\x00\x0c\x00\x0d\x00\x6c\x00\x61\x00\x65\x00\x65\x00\x78\x00\x65\x00\x65\x00\x64\x00\x6c\x00\x7c\x00\x26\x00\x3d\x00\x3d\x00\x3c\x00\x3d\x00\x3d\x00\x3e\x00\x3a\x00\x20\x00\x0a\x00\x22\x00\x23\x00\x0a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x61\x00\x01\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x69\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\xd7\x00\x20\x00\x72\x00\x73\x00\x23\x00\x0a\x00\x0a\x00\x6e\x00\x6e\x00\x0a\x00\x0a\x00\x0a\x00\x20\x00\x01\x00\x6c\x00\x65\x00\x72\x00\x20\x00\x70\x00\x0a\x00\x23\x00\x61\x00\x67\x00\x61\x00\x6d\x00\x0a\x00\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x22\x00\x01\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\x6d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x69\x00\x65\x00\x6c\x00\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xa0\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xa0\x00\xff\xff\x20\x00\xff\xff\xff\xff\xa0\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x01\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\xff\xff\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x01\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\x32\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x01\x00\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\x78\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\x31\x00\xff\xff\x33\x00\xff\xff\xff\xff\x36\x00\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# + "\x90\x00\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\xff\xff\xff\xff\xff\xff\x3b\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x58\x00\x58\x00\x5a\x00\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x84\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0 :: Int, 254) + [ AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 209 + , AlexAcc 208 + , AlexAcc 207 + , AlexAcc 206 + , AlexAcc 205 + , AlexAcc 204 + , AlexAcc 203 + , AlexAcc 202 + , AlexAcc 201 + , AlexAcc 200 + , AlexAcc 199 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 198 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 197 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 196 + , AlexAcc 195 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 194 + , AlexAcc 193 + , AlexAcc 192 + , AlexAcc 191 + , AlexAcc 190 + , AlexAcc 189 + , AlexAcc 188 + , AlexAcc 187 + , AlexAcc 186 + , AlexAcc 185 + , AlexAcc 184 + , AlexAcc 183 + , AlexAcc 182 + , AlexAcc 181 + , AlexAcc 180 + , AlexAcc 179 + , AlexAcc 178 + , AlexAcc 177 + , AlexAcc 176 + , AlexAcc 175 + , AlexAccSkip + , AlexAcc 174 + , AlexAcc 173 + , AlexAccSkip + , AlexAcc 172 + , AlexAcc 171 + , AlexAcc 170 + , AlexAcc 169 + , AlexAcc 168 + , AlexAccPred 167 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 166) + , AlexAcc 165 + , AlexAcc 164 + , AlexAcc 163 + , AlexAcc 162 + , AlexAcc 161 + , AlexAcc 160 + , AlexAcc 159 + , AlexAcc 158 + , AlexAcc 157 + , AlexAcc 156 + , AlexAcc 155 + , AlexAcc 154 + , AlexAcc 153 + , AlexAcc 152 + , AlexAcc 151 + , AlexAcc 150 + , AlexAcc 149 + , AlexAcc 148 + , AlexAcc 147 + , AlexAcc 146 + , AlexAcc 145 + , AlexAcc 144 + , AlexAccNone + , AlexAcc 143 + , AlexAcc 142 + , AlexAccPred 141 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 140) + , AlexAccPred 139 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 138 + , AlexAcc 137 + , AlexAcc 136 + , AlexAcc 135 + , AlexAcc 134 + , AlexAcc 133 + , AlexAcc 132 + , AlexAcc 131 + , AlexAcc 130 + , AlexAcc 129 + , AlexAcc 128 + , AlexAcc 127 + , AlexAcc 126 + , AlexAcc 125 + , AlexAcc 124 + , AlexAcc 123 + , AlexAcc 122 + , AlexAcc 121 + , AlexAcc 120 + , AlexAcc 119 + , AlexAccPred 118 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 117 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccSkip + , AlexAccNone + , AlexAcc 116 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 115 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 114 + , AlexAccNone + , AlexAcc 113 + , AlexAcc 112 + , AlexAcc 111 + , AlexAcc 110 + , AlexAcc 109 + , AlexAcc 108 + , AlexAcc 107 + , AlexAcc 106 + , AlexAcc 105 + , AlexAcc 104 + , AlexAcc 103 + , AlexAcc 102 + , AlexAcc 101 + , AlexAcc 100 + , AlexAcc 99 + , AlexAcc 98 + , AlexAcc 97 + , AlexAcc 96 + , AlexAcc 95 + , AlexAcc 94 + , AlexAcc 93 + , AlexAcc 92 + , AlexAcc 91 + , AlexAcc 90 + , AlexAcc 89 + , AlexAcc 88 + , AlexAcc 87 + , AlexAcc 86 + , AlexAcc 85 + , AlexAcc 84 + , AlexAcc 83 + , AlexAcc 82 + , AlexAcc 81 + , AlexAcc 80 + , AlexAcc 79 + , AlexAcc 78 + , AlexAcc 77 + , AlexAcc 76 + , AlexAcc 75 + , AlexAcc 74 + , AlexAcc 73 + , AlexAcc 72 + , AlexAcc 71 + , AlexAcc 70 + , AlexAcc 69 + , AlexAcc 68 + , AlexAcc 67 + , AlexAcc 66 + , AlexAcc 65 + , AlexAcc 64 + , AlexAcc 63 + , AlexAcc 62 + , AlexAcc 61 + , AlexAcc 60 + , AlexAcc 59 + , AlexAcc 58 + , AlexAcc 57 + , AlexAcc 56 + , AlexAcc 55 + , AlexAcc 54 + , AlexAcc 53 + , AlexAcc 52 + , AlexAcc 51 + , AlexAcc 50 + , AlexAcc 49 + , AlexAcc 48 + , AlexAcc 47 + , AlexAcc 46 + , AlexAcc 45 + , AlexAcc 44 + , AlexAcc 43 + , AlexAcc 42 + , AlexAcc 41 + , AlexAcc 40 + , AlexAcc 39 + , AlexAcc 38 + , AlexAcc 37 + , AlexAcc 36 + , AlexAcc 35 + , AlexAcc 34 + , AlexAcc 33 + , AlexAcc 32 + , AlexAcc 31 + , AlexAcc 30 + , AlexAcc 29 + , AlexAcc 28 + , AlexAcc 27 + , AlexAcc 26 + , AlexAcc 25 + , AlexAcc 24 + , AlexAcc 23 + , AlexAcc 22 + , AlexAcc 21 + , AlexAcc 20 + , AlexAcc 19 + , AlexAcc 18 + , AlexAcc 17 + , AlexAcc 16 + , AlexAcc 15 + , AlexAcc 14 + , AlexAcc 13 + , AlexAcc 12 + , AlexAcc 11 + , AlexAcc 10 + , AlexAcc 9 + , AlexAcc 8 + , AlexAcc 7 + , AlexAcc 6 + , AlexAcc 5 + , AlexAcc 4 + , AlexAcc 3 + , AlexAcc 2 + , AlexAcc 1 + , AlexAcc 0 + ] + +alex_actions = array (0 :: Int, 210) + [ (209,alex_action_5) + , (208,alex_action_28) + , (207,alex_action_27) + , (206,alex_action_49) + , (205,alex_action_26) + , (204,alex_action_49) + , (203,alex_action_25) + , (202,alex_action_24) + , (201,alex_action_23) + , (200,alex_action_49) + , (199,alex_action_22) + , (198,alex_action_21) + , (197,alex_action_20) + , (196,alex_action_19) + , (195,alex_action_7) + , (194,alex_action_18) + , (193,alex_action_7) + , (192,alex_action_17) + , (191,alex_action_7) + , (190,alex_action_16) + , (189,alex_action_7) + , (188,alex_action_15) + , (187,alex_action_7) + , (186,alex_action_14) + , (185,alex_action_13) + , (184,alex_action_12) + , (183,alex_action_7) + , (182,alex_action_11) + , (181,alex_action_7) + , (180,alex_action_10) + , (179,alex_action_7) + , (178,alex_action_9) + , (177,alex_action_8) + , (176,alex_action_7) + , (175,alex_action_7) + , (174,alex_action_5) + , (173,alex_action_5) + , (172,alex_action_5) + , (171,alex_action_5) + , (170,alex_action_5) + , (169,alex_action_5) + , (168,alex_action_5) + , (167,alex_action_2) + , (166,alex_action_5) + , (165,alex_action_5) + , (164,alex_action_49) + , (163,alex_action_49) + , (162,alex_action_49) + , (161,alex_action_49) + , (160,alex_action_49) + , (159,alex_action_49) + , (158,alex_action_49) + , (157,alex_action_49) + , (156,alex_action_49) + , (155,alex_action_49) + , (154,alex_action_49) + , (153,alex_action_49) + , (152,alex_action_49) + , (151,alex_action_49) + , (150,alex_action_49) + , (149,alex_action_49) + , (148,alex_action_49) + , (147,alex_action_49) + , (146,alex_action_49) + , (145,alex_action_5) + , (144,alex_action_5) + , (143,alex_action_4) + , (142,alex_action_3) + , (141,alex_action_2) + , (140,alex_action_5) + , (139,alex_action_2) + , (138,alex_action_49) + , (137,alex_action_49) + , (136,alex_action_49) + , (135,alex_action_49) + , (134,alex_action_49) + , (133,alex_action_49) + , (132,alex_action_49) + , (131,alex_action_49) + , (130,alex_action_49) + , (129,alex_action_49) + , (128,alex_action_49) + , (127,alex_action_49) + , (126,alex_action_49) + , (125,alex_action_49) + , (124,alex_action_49) + , (123,alex_action_49) + , (122,alex_action_49) + , (121,alex_action_49) + , (120,alex_action_49) + , (119,alex_action_49) + , (118,alex_action_2) + , (117,alex_action_53) + , (116,alex_action_54) + , (115,alex_action_53) + , (114,alex_action_52) + , (113,alex_action_51) + , (112,alex_action_51) + , (111,alex_action_50) + , (110,alex_action_49) + , (109,alex_action_49) + , (108,alex_action_49) + , (107,alex_action_49) + , (106,alex_action_49) + , (105,alex_action_49) + , (104,alex_action_49) + , (103,alex_action_49) + , (102,alex_action_49) + , (101,alex_action_49) + , (100,alex_action_49) + , (99,alex_action_49) + , (98,alex_action_49) + , (97,alex_action_49) + , (96,alex_action_49) + , (95,alex_action_49) + , (94,alex_action_49) + , (93,alex_action_49) + , (92,alex_action_49) + , (91,alex_action_49) + , (90,alex_action_49) + , (89,alex_action_49) + , (88,alex_action_49) + , (87,alex_action_49) + , (86,alex_action_49) + , (85,alex_action_49) + , (84,alex_action_49) + , (83,alex_action_49) + , (82,alex_action_49) + , (81,alex_action_49) + , (80,alex_action_49) + , (79,alex_action_49) + , (78,alex_action_49) + , (77,alex_action_49) + , (76,alex_action_49) + , (75,alex_action_49) + , (74,alex_action_49) + , (73,alex_action_49) + , (72,alex_action_49) + , (71,alex_action_48) + , (70,alex_action_49) + , (69,alex_action_49) + , (68,alex_action_49) + , (67,alex_action_49) + , (66,alex_action_49) + , (65,alex_action_49) + , (64,alex_action_49) + , (63,alex_action_49) + , (62,alex_action_49) + , (61,alex_action_47) + , (60,alex_action_49) + , (59,alex_action_49) + , (58,alex_action_49) + , (57,alex_action_49) + , (56,alex_action_49) + , (55,alex_action_49) + , (54,alex_action_49) + , (53,alex_action_49) + , (52,alex_action_49) + , (51,alex_action_46) + , (50,alex_action_49) + , (49,alex_action_49) + , (48,alex_action_49) + , (47,alex_action_49) + , (46,alex_action_49) + , (45,alex_action_49) + , (44,alex_action_49) + , (43,alex_action_49) + , (42,alex_action_49) + , (41,alex_action_45) + , (40,alex_action_49) + , (39,alex_action_49) + , (38,alex_action_49) + , (37,alex_action_49) + , (36,alex_action_49) + , (35,alex_action_49) + , (34,alex_action_49) + , (33,alex_action_49) + , (32,alex_action_49) + , (31,alex_action_44) + , (30,alex_action_49) + , (29,alex_action_43) + , (28,alex_action_49) + , (27,alex_action_49) + , (26,alex_action_49) + , (25,alex_action_42) + , (24,alex_action_49) + , (23,alex_action_41) + , (22,alex_action_40) + , (21,alex_action_39) + , (20,alex_action_49) + , (19,alex_action_38) + , (18,alex_action_37) + , (17,alex_action_36) + , (16,alex_action_49) + , (15,alex_action_49) + , (14,alex_action_35) + , (13,alex_action_34) + , (12,alex_action_33) + , (11,alex_action_32) + , (10,alex_action_49) + , (9,alex_action_49) + , (8,alex_action_49) + , (7,alex_action_31) + , (6,alex_action_49) + , (5,alex_action_49) + , (4,alex_action_49) + , (3,alex_action_30) + , (2,alex_action_49) + , (1,alex_action_29) + , (0,alex_action_49) + ] + + +line_prag,line_prag1,line_prag2 :: Int +line_prag = 1 +line_prag1 = 2 +line_prag2 = 3 +alex_action_2 = begin line_prag +alex_action_3 = setLine line_prag1 +alex_action_4 = setFile line_prag2 +alex_action_5 = pop +alex_action_7 = special_char +alex_action_8 = kw CmmT_DotDot +alex_action_9 = kw CmmT_DoubleColon +alex_action_10 = kw CmmT_Shr +alex_action_11 = kw CmmT_Shl +alex_action_12 = kw CmmT_Ge +alex_action_13 = kw CmmT_Le +alex_action_14 = kw CmmT_Eq +alex_action_15 = kw CmmT_Ne +alex_action_16 = kw CmmT_BoolAnd +alex_action_17 = kw CmmT_BoolOr +alex_action_18 = kw CmmT_Relaxed +alex_action_19 = kw CmmT_Acquire +alex_action_20 = kw CmmT_Release +alex_action_21 = kw CmmT_SeqCst +alex_action_22 = kw CmmT_True +alex_action_23 = kw CmmT_False +alex_action_24 = kw CmmT_likely +alex_action_25 = global_regN 1 VanillaReg gcWord +alex_action_26 = global_regN 1 VanillaReg bWord +alex_action_27 = global_regN 1 FloatReg (const $ cmmFloat W32) +alex_action_28 = global_regN 1 DoubleReg (const $ cmmFloat W64) +alex_action_29 = global_regN 1 LongReg (const $ cmmBits W64) +alex_action_30 = global_regN 3 XmmReg (const $ cmmVec 2 (cmmFloat W64)) +alex_action_31 = global_regN 3 YmmReg (const $ cmmVec 4 (cmmFloat W64)) +alex_action_32 = global_regN 3 ZmmReg (const $ cmmVec 8 (cmmFloat W64)) +alex_action_33 = global_reg Sp bWord +alex_action_34 = global_reg SpLim bWord +alex_action_35 = global_reg Hp gcWord +alex_action_36 = global_reg HpLim bWord +alex_action_37 = global_reg CCCS bWord +alex_action_38 = global_reg CurrentTSO bWord +alex_action_39 = global_reg CurrentNursery bWord +alex_action_40 = global_reg HpAlloc bWord +alex_action_41 = global_reg BaseReg bWord +alex_action_42 = global_reg MachSp bWord +alex_action_43 = global_reg UnwindReturnReg bWord +alex_action_44 = kw (CmmT_GlobalArgRegs GP_ARG_REGS) +alex_action_45 = kw (CmmT_GlobalArgRegs SCALAR_ARG_REGS) +alex_action_46 = kw (CmmT_GlobalArgRegs V16_ARG_REGS) +alex_action_47 = kw (CmmT_GlobalArgRegs V32_ARG_REGS) +alex_action_48 = kw (CmmT_GlobalArgRegs V64_ARG_REGS) +alex_action_49 = name +alex_action_50 = tok_octal +alex_action_51 = tok_decimal +alex_action_52 = tok_hexadecimal +alex_action_53 = strtoken tok_float +alex_action_54 = strtoken tok_string + +#define ALEX_GHC 1 +#define ALEX_LATIN1 1 +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +#ifdef ALEX_GHC +# define ILIT(n) n# +# define IBOX(n) (I# (n)) +# define FAST_INT Int# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +# if __GLASGOW_HASKELL__ > 706 +# define GTE(n,m) (tagToEnum# (n >=# m)) +# define EQ(n,m) (tagToEnum# (n ==# m)) +# else +# define GTE(n,m) (n >=# m) +# define EQ(n,m) (n ==# m) +# endif +# define PLUS(n,m) (n +# m) +# define MINUS(n,m) (n -# m) +# define TIMES(n,m) (n *# m) +# define NEGATE(n) (negateInt# (n)) +# define IF_GHC(x) (x) +#else +# define ILIT(n) (n) +# define IBOX(n) (n) +# define FAST_INT Int +# define GTE(n,m) (n >= m) +# define EQ(n,m) (n == m) +# define PLUS(n,m) (n + m) +# define MINUS(n,m) (n - m) +# define TIMES(n,m) (n * m) +# define NEGATE(n) (negate (n)) +# define IF_GHC(x) +#endif + +#ifdef ALEX_GHC +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else +#if __GLASGOW_HASKELL__ >= 901 + int16ToInt# +#endif + (indexInt16OffAddr# arr off) +#endif +#else +alexIndexInt16OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else +#if __GLASGOW_HASKELL__ >= 901 + int32ToInt# +#endif + (indexInt32OffAddr# arr off) +#endif +#else +alexIndexInt32OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif +#else +quickIndex arr i = arr ! i +#endif + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ IBOX(sc) + = alexScanUser undefined input__ IBOX(sc) + +alexScanUser user__ input__ IBOX(sc) + = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> +#ifdef ALEX_DEBUG + trace ("End of input.") $ +#endif + AlexEOF + Just _ -> +#ifdef ALEX_DEBUG + trace ("Error.") $ +#endif + AlexError input__' + + (AlexLastSkip input__'' len, _) -> +#ifdef ALEX_DEBUG + trace ("Skipping.") $ +#endif + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> +#ifdef ALEX_DEBUG + trace ("Accept.") $ +#endif + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` IBOX(s))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> +#ifdef ALEX_DEBUG + trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $ +#endif + case fromIntegral c of { IBOX(ord_c) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = PLUS(base,ord_c) + + new_s = if GTE(offset,ILIT(0)) + && let check = alexIndexInt16OffAddr alex_check offset + in EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + ILIT(-1) -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input +#ifdef ALEX_LATIN1 + PLUS(len,ILIT(1)) + -- issue 119: in the latin1 encoding, *each* byte is one character +#else + (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) +#endif + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ IBOX(len) + check_accs (AlexAccSkip) = AlexLastSkip input__ IBOX(len) +#ifndef ALEX_NOPRED + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastAcc a input__ IBOX(len) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastSkip input__ IBOX(len) + | otherwise + = check_accs rest +#endif + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip +#ifndef ALEX_NOPRED + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext IBOX(sc) user__ _ _ input__ = + case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. +#endif +{-# LINE 144 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Cmm/Lexer.x" #-} +data CmmToken + = CmmT_SpecChar Char + | CmmT_DotDot + | CmmT_DoubleColon + | CmmT_Shr + | CmmT_Shl + | CmmT_Ge + | CmmT_Le + | CmmT_Eq + | CmmT_Ne + | CmmT_BoolAnd + | CmmT_BoolOr + | CmmT_CLOSURE + | CmmT_INFO_TABLE + | CmmT_INFO_TABLE_RET + | CmmT_INFO_TABLE_FUN + | CmmT_INFO_TABLE_CONSTR + | CmmT_INFO_TABLE_SELECTOR + | CmmT_else + | CmmT_export + | CmmT_section + | CmmT_goto + | CmmT_if + | CmmT_call + | CmmT_jump + | CmmT_foreign + | CmmT_never + | CmmT_prim + | CmmT_reserve + | CmmT_return + | CmmT_returns + | CmmT_import + | CmmT_switch + | CmmT_case + | CmmT_default + | CmmT_push + | CmmT_unwind + | CmmT_bits8 + | CmmT_bits16 + | CmmT_bits32 + | CmmT_bits64 + | CmmT_vec128 + | CmmT_vec256 + | CmmT_vec512 + | CmmT_float32 + | CmmT_float64 + | CmmT_gcptr + | CmmT_GlobalReg GlobalRegUse + | CmmT_GlobalArgRegs GlobalArgRegs + | CmmT_Name FastString + | CmmT_String String + | CmmT_Int Integer + | CmmT_Float Rational + | CmmT_EOF + | CmmT_False + | CmmT_True + | CmmT_likely + | CmmT_Relaxed + | CmmT_Acquire + | CmmT_Release + | CmmT_SeqCst + deriving (Show) + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken) + +begin :: Int -> Action +begin code _span _str _len = do liftP (pushLexState code); lexToken + +pop :: Action +pop _span _buf _len = liftP popLexState >> lexToken + +special_char :: Action +special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf))) + +kw :: CmmToken -> Action +kw tok span _buf _len = return (L span tok) + +global_regN :: Int -> (Int -> GlobalReg) -> (Platform -> CmmType) -> Action +global_regN ident_nb_chars con ty_fn span buf len + = do { platform <- getPlatform + ; let reg = con (fromIntegral n) + ty = ty_fn platform + ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) } + where buf' = go ident_nb_chars buf + where go 0 b = b + go i b = go (i-1) (stepOn b) + n = parseUnsignedInteger buf' (len-ident_nb_chars) 10 octDecDigit + +global_reg :: GlobalReg -> (Platform -> CmmType) -> Action +global_reg reg ty_fn span _buf _len + = do { platform <- getPlatform + ; let ty = ty_fn platform + ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) } + +strtoken :: (String -> CmmToken) -> Action +strtoken f span buf len = + return (L span $! (f $! lexemeToString buf len)) + +name :: Action +name span buf len = + case lookupUFM reservedWordsFM fs of + Just tok -> return (L span tok) + Nothing -> return (L span (CmmT_Name fs)) + where + fs = lexemeToFastString buf len + +reservedWordsFM = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "CLOSURE", CmmT_CLOSURE ), + ( "INFO_TABLE", CmmT_INFO_TABLE ), + ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), + ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), + ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), + ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), + ( "else", CmmT_else ), + ( "export", CmmT_export ), + ( "section", CmmT_section ), + ( "goto", CmmT_goto ), + ( "if", CmmT_if ), + ( "call", CmmT_call ), + ( "jump", CmmT_jump ), + ( "foreign", CmmT_foreign ), + ( "never", CmmT_never ), + ( "prim", CmmT_prim ), + ( "reserve", CmmT_reserve ), + ( "return", CmmT_return ), + ( "returns", CmmT_returns ), + ( "import", CmmT_import ), + ( "switch", CmmT_switch ), + ( "case", CmmT_case ), + ( "default", CmmT_default ), + ( "push", CmmT_push ), + ( "unwind", CmmT_unwind ), + ( "bits8", CmmT_bits8 ), + ( "bits16", CmmT_bits16 ), + ( "bits32", CmmT_bits32 ), + ( "bits64", CmmT_bits64 ), + ( "vec128", CmmT_vec128 ), + ( "vec256", CmmT_vec256 ), + ( "vec512", CmmT_vec512 ), + ( "float32", CmmT_float32 ), + ( "float64", CmmT_float64 ), +-- New forms + ( "b8", CmmT_bits8 ), + ( "b16", CmmT_bits16 ), + ( "b32", CmmT_bits32 ), + ( "b64", CmmT_bits64 ), + ( "f32", CmmT_float32 ), + ( "f64", CmmT_float64 ), + ( "gcptr", CmmT_gcptr ), + ( "likely", CmmT_likely), + ( "True", CmmT_True ), + ( "False", CmmT_False ) + ] + +tok_decimal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit)) + +tok_octal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit)) + +tok_hexadecimal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit)) + +tok_float str = CmmT_Float $! readRational str + +tok_string str = CmmT_String (read str) + -- urk, not quite right, but it'll do for now + +-- ----------------------------------------------------------------------------- +-- Line pragmas + +setLine :: Int -> Action +setLine code (PsSpan span _) buf len = do + let line = parseUnsignedInteger buf len 10 octDecDigit + liftP $ do + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + -- subtract one: the line number refers to the *following* line + -- trace ("setLine " ++ show line) $ do + popLexState >> pushLexState code + lexToken + +setFile :: Int -> Action +setFile code (PsSpan span _) buf len = do + let file = lexemeToFastString (stepOn buf) (len-2) + liftP $ do + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + popLexState >> pushLexState code + lexToken + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +cmmlex :: (Located CmmToken -> PD a) -> PD a +cmmlex cont = do + (L span tok) <- lexToken + --trace ("token: " ++ show tok) $ do + cont (L (mkSrcSpanPs span) tok) + +lexToken :: PD (PsLocated CmmToken) +lexToken = do + inp@(loc1,buf) <- getInput + sc <- liftP getLexState + case alexScan inp sc of + AlexEOF -> do let span = mkPsSpan loc1 loc1 + liftP (setLastToken span 0) + return (L span CmmT_EOF) + AlexError (loc2,_) -> + let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer + in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(end,_buf2) len t -> do + setInput inp2 + let span = mkPsSpan loc1 end + span `seq` liftP (setLastToken span len) + t span buf len + +-- ----------------------------------------------------------------------------- +-- Monad stuff + +-- Stuff that Alex needs to know about our input type: +type AlexInput = (PsLoc,StringBuffer) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_,s) = prevChar s '\n' + +-- backwards compatibility for Alex 2.x +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar inp = case alexGetByte inp of + Nothing -> Nothing + Just (b,i) -> c `seq` Just (c,i) + where c = chr $ fromIntegral b + +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (loc,s) + | atEnd s = Nothing + | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s')) + where c = currentChar s + b = fromIntegral $ ord $ c + loc' = advancePsLoc loc c + s' = stepOn s + +getInput :: PD AlexInput +getInput = PD $ \_ _ s@PState{ loc=l, buffer=b } -> POk s (l,b) + +setInput :: AlexInput -> PD () +setInput (l,b) = PD $ \_ _ s -> POk s{ loc=l, buffer=b } () diff --git a/GHC/Cmm/Lint.hs b/GHC/Cmm/Lint.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Lint.hs @@ -0,0 +1,317 @@ +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2011 +-- +-- CmmLint: checking the correctness of Cmm statements and expressions +-- +----------------------------------------------------------------------------- +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +module GHC.Cmm.Lint ( + cmmLint, cmmLintGraph + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Regs (callerSaves) +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.Cmm.Liveness +import GHC.Cmm.Switch (switchTargetsToList) +import GHC.Cmm.CLabel (pprDebugCLabel) +import GHC.Utils.Outputable + +import Control.Monad (unless) +import Control.Monad.Trans.Except (ExceptT (..), Except) +import Control.Monad.Trans.Reader (ReaderT (..)) +import Data.Functor.Identity (Identity (..)) + +-- Things to check: +-- - invariant on CmmBlock in GHC.Cmm.Expr (see comment there) +-- - check for branches to blocks that don't exist +-- - check types + +-- ----------------------------------------------------------------------------- +-- Exported entry points: + +cmmLint :: (OutputableP Platform d, OutputableP Platform h) + => Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc +cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops + +cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc +cmmLintGraph platform g = runCmmLint platform lintCmmGraph g + +runCmmLint :: OutputableP Platform a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint platform l p = + case unCL (l p) platform of + Left err -> Just (withPprStyle defaultDumpStyle $ vcat + [text "Cmm lint error:", + nest 2 err, + text "Program was:", + nest 2 (pdoc platform p)]) + Right _ -> Nothing + +lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint () +lintCmmDecl (CmmProc _ lbl _ g) + = do + platform <- getPlatform + addLintInfo (text "in proc " <> pprDebugCLabel platform lbl) $ lintCmmGraph g +lintCmmDecl (CmmData {}) + = return () + + +lintCmmGraph :: CmmGraph -> CmmLint () +lintCmmGraph g = do + platform <- getPlatform + let + blocks = toBlockList g + labels = setFromList (map entryLabel blocks) + cmmLocalLiveness platform g `seq` mapM_ (lintCmmBlock labels) blocks + -- cmmLiveness throws an error if there are registers + -- live on entry to the graph (i.e. undefined + -- variables) + + +lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint () +lintCmmBlock labels block + = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do + let (_, middle, last) = blockSplit block + mapM_ lintCmmMiddle (blockToList middle) + lintCmmLast labels last + +-- ----------------------------------------------------------------------------- +-- lintCmmExpr + +-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking +-- byte/word mismatches. + +lintCmmExpr :: CmmExpr -> CmmLint CmmType +lintCmmExpr (CmmLoad expr rep _alignment) = do + _ <- lintCmmExpr expr + -- Disabled, if we have the inlining phase before the lint phase, + -- we can have funny offsets due to pointer tagging. -- EZY + -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $ + -- cmmCheckWordAddress expr + return rep +lintCmmExpr expr@(CmmMachOp op args) = do + platform <- getPlatform + tys <- mapM lintCmmExpr args + lintShiftOp op (zip args tys) + let machop_arg_widths = machOpArgReps platform op + arg_tys = map (cmmExprType platform) args + if map typeWidth arg_tys == machop_arg_widths + then cmmCheckMachOp op args tys + else cmmLintMachOpErr expr arg_tys machop_arg_widths +lintCmmExpr (CmmRegOff reg offset) + = do let rep = typeWidth (cmmRegType reg) + lintCmmExpr (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) +lintCmmExpr expr = + do platform <- getPlatform + return (cmmExprType platform expr) + +-- | Check for obviously out-of-bounds shift operations +lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint () +lintShiftOp op [(_, arg_ty), (CmmLit (CmmInt n _), _)] + | isShiftOp op + , n >= fromIntegral (widthInBits (typeWidth arg_ty)) + = cmmLintErr (text "Shift operation" <+> pprMachOp op + <+> text "has out-of-range offset" <+> ppr n + <> text ". This will result in undefined behavior") +lintShiftOp _ _ = return () + +isShiftOp :: MachOp -> Bool +isShiftOp (MO_Shl _) = True +isShiftOp (MO_U_Shr _) = True +isShiftOp (MO_S_Shr _) = True +isShiftOp _ = False + +-- Check for some common byte/word mismatches (eg. Sp + 1) +cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType +cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys + = cmmCheckMachOp op [reg, lit] tys +cmmCheckMachOp op _ tys + = do platform <- getPlatform + return (machOpResultType platform op tys) + +{- +isOffsetOp :: MachOp -> Bool +isOffsetOp (MO_Add _) = True +isOffsetOp (MO_Sub _) = True +isOffsetOp _ = False + +-- This expression should be an address from which a word can be loaded: +-- check for funny-looking sub-word offsets. +_cmmCheckWordAddress :: CmmExpr -> CmmLint () +_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0 + = cmmLintDubiousWordOffset e +_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0 + = cmmLintDubiousWordOffset e +_cmmCheckWordAddress _ + = return () + +-- No warnings for unaligned arithmetic with the node register, +-- which is used to extract fields from tagged constructor closures. +notNodeReg :: CmmExpr -> Bool +notNodeReg (CmmReg reg) | reg == nodeReg = False +notNodeReg _ = True +-} + +lintCmmMiddle :: CmmNode O O -> CmmLint () +lintCmmMiddle node = case node of + CmmComment _ -> return () + CmmTick _ -> return () + CmmUnwind{} -> return () + + CmmAssign reg expr -> do + erep <- lintCmmExpr expr + let reg_ty = cmmRegType reg + unless (erep `cmmCompatType` reg_ty) $ + cmmLintAssignErr (CmmAssign reg expr) erep reg_ty + + CmmStore l r _alignment -> do + _ <- lintCmmExpr l + _ <- lintCmmExpr r + return () + + CmmUnsafeForeignCall target _formals actuals -> do + let lintArg expr = do + -- Arguments can't mention caller-saved + -- registers. See Note [Register parameter passing]. + mayNotMentionCallerSavedRegs (text "foreign call argument") expr + lintCmmExpr expr + arg_tys <- mapM lintArg actuals + lintTarget arg_tys target + + +lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint () +lintCmmLast labels node = case node of + CmmBranch id -> checkTarget id + + CmmCondBranch e t f _ -> do + platform <- getPlatform + mapM_ checkTarget [t,f] + _ <- lintCmmExpr e + checkCond platform e + + CmmSwitch e ids -> do + platform <- getPlatform + mapM_ checkTarget $ switchTargetsToList ids + erep <- lintCmmExpr e + unless (isWordAny erep) $ + cmmLintErr (text "switch scrutinee is not a word (of any size): " <> + pdoc platform e <> text " :: " <> ppr erep) + + CmmCall { cml_target = target, cml_cont = cont } -> do + _ <- lintCmmExpr target + maybe (return ()) checkTarget cont + + CmmForeignCall tgt _ args succ _ _ _ -> do + let lintArg expr = do + -- Arguments can't mention caller-saved + -- registers. See Note [Register + -- parameter passing]. + -- N.B. This won't catch local registers + -- which the NCG's register allocator later + -- places in caller-saved registers. + mayNotMentionCallerSavedRegs (text "foreign call argument") expr + lintCmmExpr expr + arg_tys <- mapM lintArg args + lintTarget arg_tys tgt + checkTarget succ + where + checkTarget id + | setMember id labels = return () + | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id) + +lintTarget :: [CmmType] -> ForeignTarget -> CmmLint () +lintTarget _arg_tys (ForeignTarget e _) = do + mayNotMentionCallerSavedRegs (text "foreign target") e + _ <- lintCmmExpr e + return () +lintTarget arg_tys (PrimTarget mop) = do + platform <- getPlatform + let machop_arg_tys = callishMachOpArgTys platform mop + unless (and $ zipWith cmmCompatType arg_tys machop_arg_tys) $ + cmmLintCallishMachOpErr mop arg_tys machop_arg_tys + +-- | As noted in Note [Register parameter passing], the arguments and +-- 'ForeignTarget' of a foreign call mustn't mention +-- caller-saved registers. +mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, OutputableP Platform a) + => SDoc -> a -> CmmLint () +mayNotMentionCallerSavedRegs what thing = do + platform <- getPlatform + let badRegs = filter (callerSaves platform) + $ foldRegsUsed platform (flip (:)) [] thing + unless (null badRegs) + $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ pdoc platform thing) + +checkCond :: Platform -> CmmExpr -> CmmLint () +checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond platform (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth platform = return () -- constant values +checkCond platform expr + = cmmLintErr (hang (text "expression is not a conditional:") 2 + (pdoc platform expr)) + +-- ----------------------------------------------------------------------------- +-- CmmLint monad + +-- just a basic error monad: + +newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a } + deriving stock (Functor) + deriving (Applicative, Monad) via ReaderT Platform (Except SDoc) + +getPlatform :: CmmLint Platform +getPlatform = CmmLint $ \platform -> Right platform + +cmmLintErr :: SDoc -> CmmLint a +cmmLintErr msg = CmmLint (\_ -> Left msg) + +addLintInfo :: SDoc -> CmmLint a -> CmmLint a +addLintInfo info thing = CmmLint $ \platform -> + case unCL thing platform of + Left err -> Left (hang info 2 err) + Right a -> Right a + +cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a +cmmLintMachOpErr expr argsRep opExpectsRep + = do + platform <- getPlatform + cmmLintErr (text "in MachOp application: " $$ + nest 2 (pdoc platform expr) $$ + (text "op is expecting: " <+> ppr opExpectsRep) $$ + (text "arguments provide: " <+> ppr argsRep)) + +cmmLintCallishMachOpErr :: CallishMachOp -> [CmmType] -> [CmmType] -> CmmLint a +cmmLintCallishMachOpErr mop argTys mopTys + = cmmLintErr (text "in Callish MachOp application: " $$ + nest 2 (text $ show mop) $$ + (text "op is expecting: " <+> ppr mopTys) $$ + (text "arguments provide: " <+> ppr argTys)) + +cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a +cmmLintAssignErr stmt e_ty r_ty + = do + platform <- getPlatform + cmmLintErr (text "in assignment: " $$ + nest 2 (vcat [pdoc platform stmt, + text "Reg ty:" <+> ppr r_ty, + text "Rhs ty:" <+> ppr e_ty])) + + +{- +cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a +cmmLintDubiousWordOffset expr + = cmmLintErr (text "offset is not a multiple of words: " $$ + nest 2 (ppr expr)) +-} + diff --git a/GHC/Cmm/Liveness.hs b/GHC/Cmm/Liveness.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Liveness.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE GADTs #-} + +module GHC.Cmm.Liveness + ( CmmLocalLive + , cmmLocalLiveness + , cmmLocalLivenessL + , cmmGlobalLiveness + , liveLattice + , liveLatticeL + , gen_kill + , gen_killL + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.LRegSet + +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Utils.Panic + +----------------------------------------------------------------------------- +-- Calculating what variables are live on entry to a basic block +----------------------------------------------------------------------------- + +-- | The variables live on entry to a block +type CmmLive r = RegSet r +type CmmLocalLive = CmmLive LocalReg + +-- | The dataflow lattice +liveLattice :: Ord r => DataflowLattice (CmmLive r) +{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-} +{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-} +liveLattice = DataflowLattice emptyRegSet add + where + add (OldFact old) (NewFact new) = + let !join = plusRegSet old new + in changedIf (sizeRegSet join > sizeRegSet old) join + +-- | A mapping from block labels to the variables live on entry +type BlockEntryLiveness r = LabelMap (CmmLive r) + +----------------------------------------------------------------------------- +-- | Calculated liveness info for a CmmGraph +----------------------------------------------------------------------------- + +cmmLocalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness LocalReg +cmmLocalLiveness platform graph = + check $ analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty + where + entry = g_entry graph + check facts = + noLiveOnEntry entry (expectJust $ mapLookup entry facts) facts + +cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalRegUse +cmmGlobalLiveness platform graph = + analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty + +-- | On entry to the procedure, there had better not be any LocalReg's live-in. +-- If you see this error it most likely means you are trying to use a variable +-- without it being defined in the given scope. +noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a +noLiveOnEntry bid in_fact x = + if nullRegSet in_fact then x + else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact) + +gen_kill + :: (DefinerOfRegs r n, UserOfRegs r n) + => Platform -> n -> CmmLive r -> CmmLive r +gen_kill platform node set = + let !afterKill = foldRegsDefd platform deleteFromRegSet set node + in foldRegsUsed platform extendRegSet afterKill node +{-# INLINE gen_kill #-} + +xferLive + :: forall r. + ( UserOfRegs r (CmmNode O O) + , DefinerOfRegs r (CmmNode O O) + , UserOfRegs r (CmmNode O C) + , DefinerOfRegs r (CmmNode O C) + ) + => Platform -> TransferFun (CmmLive r) +xferLive platform (BlockCC eNode middle xNode) fBase = + let joined = gen_kill platform xNode $! joinOutFacts liveLattice xNode fBase + !result = foldNodesBwdOO (gen_kill platform) middle joined + in mapSingleton (entryLabel eNode) result +{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive LocalReg) #-} +{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive GlobalRegUse) #-} + +----------------------------------------------------------------------------- +-- | Specialization that only retains the keys for local variables. +-- +-- Local variables are mostly glorified Ints, and some parts of the compiler +-- really don't care about anything but the Int part. So we can avoid some +-- overhead by computing a IntSet instead of a Set LocalReg which (unsurprisingly) +-- is quite a bit faster. +----------------------------------------------------------------------------- + +type BlockEntryLivenessL = LabelMap LRegSet + +-- | The dataflow lattice +liveLatticeL :: DataflowLattice LRegSet +liveLatticeL = DataflowLattice emptyLRegSet add + where + add (OldFact old) (NewFact new) = + let !join = unionLRegSet old new + in changedIf (sizeLRegSet join > sizeLRegSet old) join + + +cmmLocalLivenessL :: Platform -> CmmGraph -> BlockEntryLivenessL +cmmLocalLivenessL platform graph = + check $ analyzeCmmBwd liveLatticeL (xferLiveL platform) graph mapEmpty + where + entry = g_entry graph + check facts = + noLiveOnEntryL entry (expectJust $ mapLookup entry facts) facts + +-- | On entry to the procedure, there had better not be any LocalReg's live-in. +noLiveOnEntryL :: BlockId -> LRegSet -> a -> a +noLiveOnEntryL bid in_fact x = + if nullLRegSet in_fact then x + else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr reg_uniques) + where + -- We convert the int's to uniques so that the printing matches that + -- of registers. + reg_uniques = elemsLRegSet in_fact + + + + +gen_killL + :: (DefinerOfRegs LocalReg n, UserOfRegs LocalReg n) + => Platform -> n -> LRegSet -> LRegSet +gen_killL platform node set = + let !afterKill = foldRegsDefd platform deleteFromLRegSet set node + in foldRegsUsed platform (flip insertLRegSet) afterKill node +{-# INLINE gen_killL #-} + +xferLiveL + :: ( UserOfRegs LocalReg (CmmNode O O) + , DefinerOfRegs LocalReg (CmmNode O O) + , UserOfRegs LocalReg (CmmNode O C) + , DefinerOfRegs LocalReg (CmmNode O C) + ) + => Platform -> TransferFun LRegSet +xferLiveL platform (BlockCC eNode middle xNode) fBase = + let joined = gen_killL platform xNode $! joinOutFacts liveLatticeL xNode fBase + !result = foldNodesBwdOO (gen_killL platform) middle joined + in mapSingleton (entryLabel eNode) result + diff --git a/GHC/Cmm/MachOp.hs b/GHC/Cmm/MachOp.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/MachOp.hs @@ -0,0 +1,988 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.Cmm.MachOp + ( MachOp(..) + , pprMachOp, isCommutableMachOp, isAssociativeMachOp + , isComparisonMachOp, maybeIntComparison, machOpResultType + , machOpArgReps, maybeInvertComparison, isFloatComparison + + -- MachOp builders + , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot + , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem + , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe + , mo_wordULe, mo_wordUGt, mo_wordULt + , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot + , mo_wordShl, mo_wordSShr, mo_wordUShr + , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 + , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord + , mo_u_32ToWord, mo_s_32ToWord + , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 + + -- CallishMachOp + , CallishMachOp(..), callishMachOpHints + , pprCallishMachOp + , machOpMemcpyishAlign + , callishMachOpArgTys + + -- Atomic read-modify-write + , MemoryOrdering(..) + , AtomicMachOp(..) + + -- Fused multiply-add + , FMASign(..), pprFMASign + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Cmm.Type +import GHC.Utils.Outputable +import GHC.Utils.Misc (expectNonEmpty) + +import Data.List.NonEmpty (NonEmpty (..)) + +----------------------------------------------------------------------------- +-- MachOp +----------------------------------------------------------------------------- + +{- | +Machine-level primops; ones which we can reasonably delegate to the +native code generators to handle. + +Most operations are parameterised by the 'Width' that they operate on. +Some operations have separate signed and unsigned versions, and float +and integer versions. + +Note that there are variety of places in the native code generator where we +assume that the code produced for a MachOp does not introduce new blocks. +-} + +-- Note [MO_S_MulMayOflo significant width] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- There are two interpretations in the code about what a multiplication +-- overflow exactly means: +-- +-- 1. The result does not fit into the specified width (of type Width.) +-- 2. The result does not fit into a register. +-- +-- (2) has some flaws: A following MO_Mul has a width, too. So MO_S_MulMayOflo +-- may signal no overflow, while MO_Mul truncates the result. There are +-- architectures with several register widths and it might be hard to decide +-- what's an overflow and what not. Both attributes can easily lead to subtle +-- bugs. +-- +-- (1) has the benefit that its interpretation is completely independent of the +-- architecture. So, the mid-term plan is to migrate to this +-- interpretation/semantics. + +data MachOp + -- Integer operations (insensitive to signed/unsigned) + = MO_Add Width + | MO_Sub Width + | MO_Eq Width + | MO_Ne Width + | MO_Mul Width -- low word of multiply + + -- Signed multiply/divide + | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows. See + -- Note [MO_S_MulMayOflo significant width] + | MO_S_Quot Width -- signed / (same semantics as IntQuotOp) + | MO_S_Rem Width -- signed % (same semantics as IntRemOp) + | MO_S_Neg Width -- unary - + + -- Unsigned multiply/divide + | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp) + | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp) + + -- Signed comparisons + | MO_S_Ge Width + | MO_S_Le Width + | MO_S_Gt Width + | MO_S_Lt Width + + -- Unsigned comparisons + | MO_U_Ge Width + | MO_U_Le Width + | MO_U_Gt Width + | MO_U_Lt Width + + -- Floating point arithmetic + | MO_F_Add Width + | MO_F_Sub Width + | MO_F_Neg Width -- unary - + | MO_F_Mul Width + | MO_F_Quot Width + + -- Floating-point fused multiply-add operations + -- | Fused multiply-add, see 'FMASign'. + | MO_FMA FMASign Length Width + + -- Floating point comparison + | MO_F_Eq Width + | MO_F_Ne Width + | MO_F_Ge Width + | MO_F_Le Width + | MO_F_Gt Width + | MO_F_Lt Width + + | MO_F_Min Width + | MO_F_Max Width + + -- Bitwise operations. Not all of these may be supported + -- at all sizes, and only integral Widths are valid. + | MO_And Width + | MO_Or Width + | MO_Xor Width + | MO_Not Width + + -- Shifts. The shift amount must be in [0,widthInBits). + | MO_Shl Width + | MO_U_Shr Width -- unsigned shift right + | MO_S_Shr Width -- signed shift right + + -- Conversions. Some of these will be NOPs. + -- Floating-point conversions use the signed variant. + | MO_SF_Round Width Width -- Signed int -> Float + | MO_FS_Truncate Width Width -- Float -> Signed int + | MO_SS_Conv Width Width -- Signed int -> Signed int + | MO_UU_Conv Width Width -- unsigned int -> unsigned int + | MO_XX_Conv Width Width -- int -> int; puts no requirements on the + -- contents of upper bits when extending; + -- narrowing is simply truncation; the only + -- expectation is that we can recover the + -- original value by applying the opposite + -- MO_XX_Conv, e.g., + -- MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x) + -- is equivalent to just x. + | MO_FF_Conv Width Width -- Float -> Float + + | MO_WF_Bitcast Width -- Word32/Word64 -> Float/Double + | MO_FW_Bitcast Width -- Float/Double -> Word32/Word64 + + -- Vector element insertion and extraction operations + | MO_V_Broadcast Length Width -- Broadcast a scalar into a vector + | MO_V_Insert Length Width -- Insert scalar into vector + | MO_V_Extract Length Width -- Extract scalar from vector + + -- Integer vector operations + | MO_V_Add Length Width + | MO_V_Sub Length Width + | MO_V_Mul Length Width + | MO_VS_Neg Length Width + + -- Vector shuffles + | MO_V_Shuffle Length Width [Int] + | MO_VF_Shuffle Length Width [Int] + + -- Floating point vector element insertion and extraction operations + | MO_VF_Broadcast Length Width -- Broadcast a scalar into a vector + | MO_VF_Insert Length Width -- Insert scalar into vector + | MO_VF_Extract Length Width -- Extract scalar from vector + + -- Floating point vector operations + | MO_VF_Add Length Width + | MO_VF_Sub Length Width + | MO_VF_Neg Length Width -- unary negation + | MO_VF_Mul Length Width + | MO_VF_Quot Length Width + + -- Min/max operations + | MO_VS_Min Length Width + | MO_VS_Max Length Width + | MO_VU_Min Length Width + | MO_VU_Max Length Width + | MO_VF_Min Length Width + | MO_VF_Max Length Width + + -- | An atomic read with no memory ordering. Address msut + -- be naturally aligned. + | MO_RelaxedRead Width + + -- Alignment check (for -falignment-sanitisation) + | MO_AlignmentCheck Int Width + deriving (Eq, Show) + +pprMachOp :: MachOp -> SDoc +pprMachOp mo = text (show mo) + +-- | Where are the signs in a fused multiply-add instruction? +-- +-- @x*y + z@ vs @x*y - z@ vs @-x*y+z@ vs @-x*y-z@. +-- +-- Warning: the signs aren't consistent across architectures (X86, PowerPC, AArch64). +-- The user-facing implementation uses the X86 convention, while the relevant +-- backends use their corresponding conventions. +data FMASign + -- | Fused multiply-add @x*y + z@. + = FMAdd + -- | Fused multiply-subtract. On X86: @x*y - z@. + | FMSub + -- | Fused multiply-add. On X86: @-x*y + z@. + | FNMAdd + -- | Fused multiply-subtract. On X86: @-x*y - z@. + | FNMSub + deriving (Eq, Show) + +pprFMASign :: IsLine doc => FMASign -> doc +pprFMASign = \case + FMAdd -> text "fmadd" + FMSub -> text "fmsub" + FNMAdd -> text "fnmadd" + FNMSub -> text "fnmsub" + +-- ----------------------------------------------------------------------------- +-- Some common MachReps + +-- A 'wordRep' is a machine word on the target architecture +-- Specifically, it is the size of an Int#, Word#, Addr# +-- and the unit of allocation on the stack and the heap +-- Any pointer is also guaranteed to be a wordRep. + +mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot + , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem + , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe + , mo_wordULe, mo_wordUGt, mo_wordULt + , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr + , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord + , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 + :: Platform -> MachOp + +mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 + , mo_32To8, mo_32To16 + :: MachOp + +mo_wordAdd platform = MO_Add (wordWidth platform) +mo_wordSub platform = MO_Sub (wordWidth platform) +mo_wordEq platform = MO_Eq (wordWidth platform) +mo_wordNe platform = MO_Ne (wordWidth platform) +mo_wordMul platform = MO_Mul (wordWidth platform) +mo_wordSQuot platform = MO_S_Quot (wordWidth platform) +mo_wordSRem platform = MO_S_Rem (wordWidth platform) +mo_wordSNeg platform = MO_S_Neg (wordWidth platform) +mo_wordUQuot platform = MO_U_Quot (wordWidth platform) +mo_wordURem platform = MO_U_Rem (wordWidth platform) + +mo_wordSGe platform = MO_S_Ge (wordWidth platform) +mo_wordSLe platform = MO_S_Le (wordWidth platform) +mo_wordSGt platform = MO_S_Gt (wordWidth platform) +mo_wordSLt platform = MO_S_Lt (wordWidth platform) + +mo_wordUGe platform = MO_U_Ge (wordWidth platform) +mo_wordULe platform = MO_U_Le (wordWidth platform) +mo_wordUGt platform = MO_U_Gt (wordWidth platform) +mo_wordULt platform = MO_U_Lt (wordWidth platform) + +mo_wordAnd platform = MO_And (wordWidth platform) +mo_wordOr platform = MO_Or (wordWidth platform) +mo_wordXor platform = MO_Xor (wordWidth platform) +mo_wordNot platform = MO_Not (wordWidth platform) +mo_wordShl platform = MO_Shl (wordWidth platform) +mo_wordSShr platform = MO_S_Shr (wordWidth platform) +mo_wordUShr platform = MO_U_Shr (wordWidth platform) + +mo_u_8To32 = MO_UU_Conv W8 W32 +mo_s_8To32 = MO_SS_Conv W8 W32 +mo_u_16To32 = MO_UU_Conv W16 W32 +mo_s_16To32 = MO_SS_Conv W16 W32 + +mo_u_8ToWord platform = MO_UU_Conv W8 (wordWidth platform) +mo_s_8ToWord platform = MO_SS_Conv W8 (wordWidth platform) +mo_u_16ToWord platform = MO_UU_Conv W16 (wordWidth platform) +mo_s_16ToWord platform = MO_SS_Conv W16 (wordWidth platform) +mo_s_32ToWord platform = MO_SS_Conv W32 (wordWidth platform) +mo_u_32ToWord platform = MO_UU_Conv W32 (wordWidth platform) + +mo_WordTo8 platform = MO_UU_Conv (wordWidth platform) W8 +mo_WordTo16 platform = MO_UU_Conv (wordWidth platform) W16 +mo_WordTo32 platform = MO_UU_Conv (wordWidth platform) W32 +mo_WordTo64 platform = MO_UU_Conv (wordWidth platform) W64 + +mo_32To8 = MO_UU_Conv W32 W8 +mo_32To16 = MO_UU_Conv W32 W16 + + +-- ---------------------------------------------------------------------------- +-- isCommutableMachOp + +{- | +Returns 'True' if the MachOp has commutable arguments. This is used +in the platform-independent Cmm optimisations. + +If in doubt, return 'False'. This generates worse code on the +native routes, but is otherwise harmless. +-} +isCommutableMachOp :: MachOp -> Bool +isCommutableMachOp mop = + case mop of + MO_Add _ -> True + MO_Eq _ -> True + MO_Ne _ -> True + MO_Mul _ -> True + MO_S_MulMayOflo _ -> True + MO_And _ -> True + MO_Or _ -> True + MO_Xor _ -> True + MO_F_Add _ -> True + MO_F_Mul _ -> True + MO_F_Min {} -> True + MO_F_Max {} -> True + _other -> False + +-- ---------------------------------------------------------------------------- +-- isAssociativeMachOp + +{- | +Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@) +This is used in the platform-independent Cmm optimisations. + +If in doubt, return 'False'. This generates worse code on the +native routes, but is otherwise harmless. +-} +isAssociativeMachOp :: MachOp -> Bool +isAssociativeMachOp mop = + case mop of + MO_Add {} -> True -- NB: does not include + MO_Mul {} -> True -- floatint point! + MO_And {} -> True + MO_Or {} -> True + MO_Xor {} -> True + _other -> False + + +-- ---------------------------------------------------------------------------- +-- isComparisonMachOp + +{- | +Returns 'True' if the MachOp is a comparison. + +If in doubt, return False. This generates worse code on the +native routes, but is otherwise harmless. +-} +isComparisonMachOp :: MachOp -> Bool +isComparisonMachOp mop = + case mop of + MO_Eq _ -> True + MO_Ne _ -> True + MO_S_Ge _ -> True + MO_S_Le _ -> True + MO_S_Gt _ -> True + MO_S_Lt _ -> True + MO_U_Ge _ -> True + MO_U_Le _ -> True + MO_U_Gt _ -> True + MO_U_Lt _ -> True + MO_F_Eq {} -> True + MO_F_Ne {} -> True + MO_F_Ge {} -> True + MO_F_Le {} -> True + MO_F_Gt {} -> True + MO_F_Lt {} -> True + _other -> False + +{- | +Returns @Just w@ if the operation is an integer comparison with width +@w@, or @Nothing@ otherwise. +-} +maybeIntComparison :: MachOp -> Maybe Width +maybeIntComparison mop = + case mop of + MO_Eq w -> Just w + MO_Ne w -> Just w + MO_S_Ge w -> Just w + MO_S_Le w -> Just w + MO_S_Gt w -> Just w + MO_S_Lt w -> Just w + MO_U_Ge w -> Just w + MO_U_Le w -> Just w + MO_U_Gt w -> Just w + MO_U_Lt w -> Just w + _ -> Nothing + +isFloatComparison :: MachOp -> Bool +isFloatComparison mop = + case mop of + MO_F_Eq {} -> True + MO_F_Ne {} -> True + MO_F_Ge {} -> True + MO_F_Le {} -> True + MO_F_Gt {} -> True + MO_F_Lt {} -> True + _other -> False + +-- Note [Inverting conditions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Sometimes it's useful to be able to invert the sense of a +-- condition. Not all conditional tests are invertible: in +-- particular, floating point conditionals cannot be inverted, because +-- there exist floating-point values which return False for both senses +-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)). + +maybeInvertComparison :: MachOp -> Maybe MachOp +maybeInvertComparison op + = case op of -- None of these Just cases include floating point + MO_Eq w -> Just (MO_Ne w) + MO_Ne w -> Just (MO_Eq w) + MO_U_Lt w -> Just (MO_U_Ge w) + MO_U_Gt w -> Just (MO_U_Le w) + MO_U_Le w -> Just (MO_U_Gt w) + MO_U_Ge w -> Just (MO_U_Lt w) + MO_S_Lt w -> Just (MO_S_Ge w) + MO_S_Gt w -> Just (MO_S_Le w) + MO_S_Le w -> Just (MO_S_Gt w) + MO_S_Ge w -> Just (MO_S_Lt w) + _other -> Nothing + +-- ---------------------------------------------------------------------------- +-- machOpResultType + +{- | +Returns the MachRep of the result of a MachOp. +-} +machOpResultType :: Platform -> MachOp -> [CmmType] -> CmmType +machOpResultType platform mop tys = + case mop of + MO_Add {} -> ty1 -- Preserve GC-ptr-hood + MO_Sub {} -> ty1 -- of first arg + MO_Mul w -> cmmBits w + MO_S_MulMayOflo w -> cmmBits w + MO_S_Quot w -> cmmBits w + MO_S_Rem w -> cmmBits w + MO_S_Neg w -> cmmBits w + MO_U_Quot w -> cmmBits w + MO_U_Rem w -> cmmBits w + + MO_Eq {} -> comparisonResultRep platform + MO_Ne {} -> comparisonResultRep platform + MO_S_Ge {} -> comparisonResultRep platform + MO_S_Le {} -> comparisonResultRep platform + MO_S_Gt {} -> comparisonResultRep platform + MO_S_Lt {} -> comparisonResultRep platform + + MO_U_Ge {} -> comparisonResultRep platform + MO_U_Le {} -> comparisonResultRep platform + MO_U_Gt {} -> comparisonResultRep platform + MO_U_Lt {} -> comparisonResultRep platform + + MO_F_Add w -> cmmFloat w + MO_F_Sub w -> cmmFloat w + MO_F_Mul w -> cmmFloat w + MO_F_Quot w -> cmmFloat w + MO_F_Neg w -> cmmFloat w + MO_F_Min w -> cmmFloat w + MO_F_Max w -> cmmFloat w + + MO_FMA _ l w -> if l == 1 then cmmFloat w else cmmVec l (cmmFloat w) + + MO_F_Eq {} -> comparisonResultRep platform + MO_F_Ne {} -> comparisonResultRep platform + MO_F_Ge {} -> comparisonResultRep platform + MO_F_Le {} -> comparisonResultRep platform + MO_F_Gt {} -> comparisonResultRep platform + MO_F_Lt {} -> comparisonResultRep platform + + MO_And {} -> ty1 -- Used for pointer masking + MO_Or {} -> ty1 + MO_Xor {} -> ty1 + MO_Not w -> cmmBits w + MO_Shl w -> cmmBits w + MO_U_Shr w -> cmmBits w + MO_S_Shr w -> cmmBits w + + MO_SS_Conv _ to -> cmmBits to + MO_UU_Conv _ to -> cmmBits to + MO_XX_Conv _ to -> cmmBits to + MO_FS_Truncate _ to -> cmmBits to + MO_SF_Round _ to -> cmmFloat to + MO_FF_Conv _ to -> cmmFloat to + MO_WF_Bitcast w -> cmmFloat w + MO_FW_Bitcast w -> cmmBits w + + MO_V_Broadcast l w -> cmmVec l (cmmBits w) + MO_V_Insert l w -> cmmVec l (cmmBits w) + MO_V_Extract _ w -> cmmBits w + + MO_V_Add l w -> cmmVec l (cmmBits w) + MO_V_Sub l w -> cmmVec l (cmmBits w) + MO_V_Mul l w -> cmmVec l (cmmBits w) + + MO_VS_Neg l w -> cmmVec l (cmmBits w) + MO_VS_Min l w -> cmmVec l (cmmBits w) + MO_VS_Max l w -> cmmVec l (cmmBits w) + + MO_VU_Min l w -> cmmVec l (cmmBits w) + MO_VU_Max l w -> cmmVec l (cmmBits w) + + MO_V_Shuffle l w _ -> cmmVec l (cmmBits w) + MO_VF_Shuffle l w _ -> cmmVec l (cmmFloat w) + + MO_VF_Broadcast l w -> cmmVec l (cmmFloat w) + MO_VF_Insert l w -> cmmVec l (cmmFloat w) + MO_VF_Extract _ w -> cmmFloat w + + MO_VF_Add l w -> cmmVec l (cmmFloat w) + MO_VF_Sub l w -> cmmVec l (cmmFloat w) + MO_VF_Mul l w -> cmmVec l (cmmFloat w) + MO_VF_Quot l w -> cmmVec l (cmmFloat w) + MO_VF_Neg l w -> cmmVec l (cmmFloat w) + MO_VF_Min l w -> cmmVec l (cmmFloat w) + MO_VF_Max l w -> cmmVec l (cmmFloat w) + + MO_RelaxedRead w -> cmmBits w + MO_AlignmentCheck _ _ -> ty1 + where + ty1:|_ = expectNonEmpty tys + +comparisonResultRep :: Platform -> CmmType +comparisonResultRep = bWord -- is it? + + +-- ----------------------------------------------------------------------------- +-- machOpArgReps + +-- | This function is used for debugging only: we can check whether an +-- application of a MachOp is "type-correct" by checking that the MachReps of +-- its arguments are the same as the MachOp expects. This is used when +-- linting a CmmExpr. + +machOpArgReps :: Platform -> MachOp -> [Width] +machOpArgReps platform op = + case op of + MO_Add w -> [w,w] + MO_Sub w -> [w,w] + MO_Eq w -> [w,w] + MO_Ne w -> [w,w] + MO_Mul w -> [w,w] + MO_S_MulMayOflo w -> [w,w] + MO_S_Quot w -> [w,w] + MO_S_Rem w -> [w,w] + MO_S_Neg w -> [w] + MO_U_Quot w -> [w,w] + MO_U_Rem w -> [w,w] + + MO_S_Ge w -> [w,w] + MO_S_Le w -> [w,w] + MO_S_Gt w -> [w,w] + MO_S_Lt w -> [w,w] + + MO_U_Ge w -> [w,w] + MO_U_Le w -> [w,w] + MO_U_Gt w -> [w,w] + MO_U_Lt w -> [w,w] + + MO_F_Add w -> [w,w] + MO_F_Sub w -> [w,w] + MO_F_Mul w -> [w,w] + MO_F_Quot w -> [w,w] + MO_F_Neg w -> [w] + MO_F_Min w -> [w,w] + MO_F_Max w -> [w,w] + + MO_FMA _ l w -> [vecwidth l w, vecwidth l w, vecwidth l w] + + MO_F_Eq w -> [w,w] + MO_F_Ne w -> [w,w] + MO_F_Ge w -> [w,w] + MO_F_Le w -> [w,w] + MO_F_Gt w -> [w,w] + MO_F_Lt w -> [w,w] + + MO_And w -> [w,w] + MO_Or w -> [w,w] + MO_Xor w -> [w,w] + MO_Not w -> [w] + MO_Shl w -> [w, wordWidth platform] + MO_U_Shr w -> [w, wordWidth platform] + MO_S_Shr w -> [w, wordWidth platform] + + MO_SS_Conv from _ -> [from] + MO_UU_Conv from _ -> [from] + MO_XX_Conv from _ -> [from] + MO_SF_Round from _ -> [from] + MO_FS_Truncate from _ -> [from] + MO_FF_Conv from _ -> [from] + MO_WF_Bitcast w -> [w] + MO_FW_Bitcast w -> [w] + + MO_V_Shuffle l w _ -> [vecwidth l w, vecwidth l w] + MO_VF_Shuffle l w _ -> [vecwidth l w, vecwidth l w] + + MO_V_Broadcast _ w -> [w] + MO_V_Insert l w -> [vecwidth l w, w, W32] + MO_V_Extract l w -> [vecwidth l w, W32] + MO_VF_Broadcast _ w -> [w] + MO_VF_Insert l w -> [vecwidth l w, w, W32] + MO_VF_Extract l w -> [vecwidth l w, W32] + -- SIMD vector indices are always 32 bit + + MO_V_Add l w -> [vecwidth l w, vecwidth l w] + MO_V_Sub l w -> [vecwidth l w, vecwidth l w] + MO_V_Mul l w -> [vecwidth l w, vecwidth l w] + + MO_VS_Neg l w -> [vecwidth l w] + MO_VS_Min l w -> [vecwidth l w, vecwidth l w] + MO_VS_Max l w -> [vecwidth l w, vecwidth l w] + + MO_VU_Min l w -> [vecwidth l w, vecwidth l w] + MO_VU_Max l w -> [vecwidth l w, vecwidth l w] + + -- NOTE: The below is owing to the fact that floats use the SSE registers + MO_VF_Add l w -> [vecwidth l w, vecwidth l w] + MO_VF_Sub l w -> [vecwidth l w, vecwidth l w] + MO_VF_Mul l w -> [vecwidth l w, vecwidth l w] + MO_VF_Quot l w -> [vecwidth l w, vecwidth l w] + MO_VF_Neg l w -> [vecwidth l w] + MO_VF_Min l w -> [vecwidth l w, vecwidth l w] + MO_VF_Max l w -> [vecwidth l w, vecwidth l w] + + MO_RelaxedRead _ -> [wordWidth platform] + MO_AlignmentCheck _ w -> [w] + where + vecwidth l w = widthFromBytes (l * widthInBytes w) + +----------------------------------------------------------------------------- +-- CallishMachOp +----------------------------------------------------------------------------- + +-- CallishMachOps tend to be implemented by foreign calls in some backends, +-- so we separate them out. In Cmm, these can only occur in a +-- statement position, in contrast to an ordinary MachOp which can occur +-- anywhere in an expression. +data CallishMachOp + = MO_F64_Pwr + | MO_F64_Sin + | MO_F64_Cos + | MO_F64_Tan + | MO_F64_Sinh + | MO_F64_Cosh + | MO_F64_Tanh + | MO_F64_Asin + | MO_F64_Acos + | MO_F64_Atan + | MO_F64_Asinh + | MO_F64_Acosh + | MO_F64_Atanh + | MO_F64_Log + | MO_F64_Log1P + | MO_F64_Exp + | MO_F64_ExpM1 + | MO_F64_Fabs + | MO_F64_Sqrt + | MO_F32_Pwr + | MO_F32_Sin + | MO_F32_Cos + | MO_F32_Tan + | MO_F32_Sinh + | MO_F32_Cosh + | MO_F32_Tanh + | MO_F32_Asin + | MO_F32_Acos + | MO_F32_Atan + | MO_F32_Asinh + | MO_F32_Acosh + | MO_F32_Atanh + | MO_F32_Log + | MO_F32_Log1P + | MO_F32_Exp + | MO_F32_ExpM1 + | MO_F32_Fabs + | MO_F32_Sqrt + + -- 64-bit int/word ops for when they exceed the native word size + -- (i.e. on 32-bit architectures) + | MO_I64_ToI + | MO_I64_FromI + | MO_W64_ToW + | MO_W64_FromW + + | MO_x64_Neg + | MO_x64_Add + | MO_x64_Sub + | MO_x64_Mul + | MO_I64_Quot + | MO_I64_Rem + | MO_W64_Quot + | MO_W64_Rem + + | MO_x64_And + | MO_x64_Or + | MO_x64_Xor + | MO_x64_Not + | MO_x64_Shl + | MO_I64_Shr + | MO_W64_Shr + + | MO_x64_Eq + | MO_x64_Ne + | MO_I64_Ge + | MO_I64_Gt + | MO_I64_Le + | MO_I64_Lt + | MO_W64_Ge + | MO_W64_Gt + | MO_W64_Le + | MO_W64_Lt + + | MO_UF_Conv Width + + | MO_S_Mul2 Width + | MO_S_QuotRem Width + | MO_U_QuotRem Width + | MO_U_QuotRem2 Width + | MO_Add2 Width + | MO_AddWordC Width + | MO_SubWordC Width + | MO_AddIntC Width + | MO_SubIntC Width + | MO_U_Mul2 Width + + -- Signed vector divide + | MO_VS_Quot Length Width + | MO_VS_Rem Length Width + + -- Unsigned vector divide + | MO_VU_Quot Length Width + | MO_VU_Rem Length Width + + -- Int64X2/Word64X2 min/max + | MO_I64X2_Min + | MO_I64X2_Max + | MO_W64X2_Min + | MO_W64X2_Max + + | MO_Touch -- Keep variables live (when using interior pointers) + + -- Prefetch + | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not + -- program behavior. + -- the Int can be 0-3. Needs to be known at compile time + -- to interact with code generation correctly. + -- TODO: add support for prefetch WRITES, + -- currently only exposes prefetch reads, which + -- would the majority of use cases in ghc anyways + + + -- These three MachOps are parameterised by the known alignment + -- of the destination and source (for memcpy/memmove) pointers. + -- This information may be used for optimisation in backends. + | MO_Memcpy Int + | MO_Memset Int + | MO_Memmove Int + | MO_Memcmp Int + + | MO_PopCnt Width + | MO_Pdep Width + | MO_Pext Width + | MO_Clz Width + | MO_Ctz Width + + | MO_BSwap Width + | MO_BRev Width + + | MO_AcquireFence + | MO_ReleaseFence + | MO_SeqCstFence + + -- | Atomic read-modify-write. Arguments are @[dest, n]@. + | MO_AtomicRMW Width AtomicMachOp + -- | Atomic read. Arguments are @[addr]@. + | MO_AtomicRead Width MemoryOrdering + -- | Atomic write. Arguments are @[addr, value]@. + | MO_AtomicWrite Width MemoryOrdering + -- | Atomic compare-and-swap. Arguments are @[dest, expected, new]@. + -- Sequentially consistent. + -- Possible future refactoring: should this be an'MO_AtomicRMW' variant? + | MO_Cmpxchg Width + -- | Atomic swap. Arguments are @[dest, new]@ + | MO_Xchg Width + + -- These rts provided functions are special: suspendThread releases the + -- capability, hence we mustn't sink any use of data stored in the capability + -- after this instruction. + | MO_SuspendThread + | MO_ResumeThread + deriving (Eq, Show) + +-- | C11 memory ordering semantics. +data MemoryOrdering + = MemOrderRelaxed -- ^ relaxed ordering + | MemOrderAcquire -- ^ acquire ordering + | MemOrderRelease -- ^ release ordering + | MemOrderSeqCst -- ^ sequentially consistent + deriving (Eq, Ord, Show) + +-- | The operation to perform atomically. +data AtomicMachOp = + AMO_Add + | AMO_Sub + | AMO_And + | AMO_Nand + | AMO_Or + | AMO_Xor + deriving (Eq, Show) + +pprCallishMachOp :: CallishMachOp -> SDoc +pprCallishMachOp mo = text (show mo) + +-- | Return (results_hints,args_hints) +callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint]) +callishMachOpHints op = case op of + MO_Memcpy _ -> ([], [AddrHint,AddrHint,NoHint]) + MO_Memset _ -> ([], [AddrHint,NoHint,NoHint]) + MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint]) + MO_Memcmp _ -> ([], [AddrHint, AddrHint, NoHint]) + MO_SuspendThread -> ([AddrHint], [AddrHint,NoHint]) + MO_ResumeThread -> ([AddrHint], [AddrHint]) + _ -> ([],[]) + -- empty lists indicate NoHint + +-- | The alignment of a 'memcpy'-ish operation. +machOpMemcpyishAlign :: CallishMachOp -> Maybe Int +machOpMemcpyishAlign op = case op of + MO_Memcpy align -> Just align + MO_Memset align -> Just align + MO_Memmove align -> Just align + MO_Memcmp align -> Just align + _ -> Nothing + +-- | Like 'machOpArgReps', but for 'CallishMachOp'. +-- +-- Used only in Cmm lint. +callishMachOpArgTys :: Platform -> CallishMachOp -> [CmmType] +callishMachOpArgTys platform = \case + MO_F64_Pwr -> [f64, f64] + MO_F64_Sin -> [f64] + MO_F64_Cos -> [f64] + MO_F64_Tan -> [f64] + MO_F64_Sinh -> [f64] + MO_F64_Cosh -> [f64] + MO_F64_Tanh -> [f64] + MO_F64_Asin -> [f64] + MO_F64_Acos -> [f64] + MO_F64_Atan -> [f64] + MO_F64_Asinh -> [f64] + MO_F64_Acosh -> [f64] + MO_F64_Atanh -> [f64] + MO_F64_Log -> [f64] + MO_F64_Log1P -> [f64] + MO_F64_Exp -> [f64] + MO_F64_ExpM1 -> [f64] + MO_F64_Fabs -> [f64] + MO_F64_Sqrt -> [f64] + MO_F32_Pwr -> [f32, f32] + MO_F32_Sin -> [f32] + MO_F32_Cos -> [f32] + MO_F32_Tan -> [f32] + MO_F32_Sinh -> [f32] + MO_F32_Cosh -> [f32] + MO_F32_Tanh -> [f32] + MO_F32_Asin -> [f32] + MO_F32_Acos -> [f32] + MO_F32_Atan -> [f32] + MO_F32_Asinh -> [f32] + MO_F32_Acosh -> [f32] + MO_F32_Atanh -> [f32] + MO_F32_Log -> [f32] + MO_F32_Log1P -> [f32] + MO_F32_Exp -> [f32] + MO_F32_ExpM1 -> [f32] + MO_F32_Fabs -> [f32] + MO_F32_Sqrt -> [f32] + MO_I64_ToI -> [b64] + MO_I64_FromI -> [bWord platform] + MO_W64_ToW -> [b64] + MO_W64_FromW -> [bWord platform] + MO_x64_Neg -> [b64] + MO_x64_Add -> [b64] + MO_x64_Sub -> [b64] + MO_x64_Mul -> [b64] + MO_I64_Quot -> [b64,b64] + MO_I64_Rem -> [b64,b64] + MO_W64_Quot -> [b64,b64] + MO_W64_Rem -> [b64,b64] + MO_x64_And -> [b64,b64] + MO_x64_Or -> [b64,b64] + MO_x64_Xor -> [b64,b64] + MO_x64_Not -> [b64] + MO_x64_Shl -> [b64,b64] + MO_I64_Shr -> [b64,b64] + MO_W64_Shr -> [b64,b64] + MO_x64_Eq -> [b64,b64] + MO_x64_Ne -> [b64,b64] + MO_I64_Ge -> [b64,b64] + MO_I64_Gt -> [b64,b64] + MO_I64_Le -> [b64,b64] + MO_I64_Lt -> [b64,b64] + MO_W64_Ge -> [b64,b64] + MO_W64_Gt -> [b64,b64] + MO_W64_Le -> [b64,b64] + MO_W64_Lt -> [b64,b64] + MO_UF_Conv _w -> [bWord platform] -- Word to Float/Double + MO_S_Mul2 w -> [cmmBits w, cmmBits w] + MO_S_QuotRem w -> [cmmBits w, cmmBits w] + MO_U_QuotRem w -> [cmmBits w, cmmBits w] + MO_U_QuotRem2 w -> [cmmBits w, cmmBits w] + MO_Add2 w -> [cmmBits w, cmmBits w] + MO_AddWordC w -> [cmmBits w, cmmBits w] + MO_SubWordC w -> [cmmBits w, cmmBits w] + MO_AddIntC w -> [cmmBits w, cmmBits w] + MO_SubIntC w -> [cmmBits w, cmmBits w] + MO_U_Mul2 w -> [cmmBits w, cmmBits w] + MO_VS_Quot l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)] + MO_VS_Rem l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)] + MO_VU_Quot l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)] + MO_VU_Rem l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)] + MO_I64X2_Min -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)] + MO_I64X2_Max -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)] + MO_W64X2_Min -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)] + MO_W64X2_Max -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)] + MO_Touch -> [gcWord platform] + MO_Prefetch_Data _n -> [addr] + MO_Memcpy _align -> [addr, addr, bWord platform] + MO_Memset _align -> + [ addr + , bWord platform -- byte to set: supplied as an int, converted to a byte + , bWord platform] + MO_Memmove _align -> [addr, addr, bWord platform] + MO_Memcmp _align -> [addr, addr, bWord platform] + MO_PopCnt w -> + case w of + W64 -> [cmmBits W64] + _ -> [bWord platform] + MO_Pdep w -> + case w of + W64 -> [cmmBits W64, cmmBits W64] + _ -> [bWord platform, bWord platform] + MO_Pext w -> + case w of + W64 -> [cmmBits W64, cmmBits W64] + _ -> [bWord platform, bWord platform] + MO_Clz w -> + case w of + W64 -> [cmmBits W64] + _ -> [bWord platform] + MO_Ctz w -> + case w of + W64 -> [cmmBits W64] + _ -> [bWord platform] + MO_BSwap w -> + case w of + W64 -> [cmmBits W64] + _ -> [bWord platform] + MO_BRev w -> + case w of + W64 -> [cmmBits W64] + _ -> [bWord platform] + MO_AcquireFence -> [] + MO_ReleaseFence -> [] + MO_SeqCstFence -> [] + MO_AtomicRMW w _op -> [addr, cmmBits w] + MO_AtomicRead _w _mem_ordering -> [addr] + MO_AtomicWrite w _mem_ordering -> [addr, cmmBits w] + MO_Cmpxchg w -> [addr, cmmBits w, cmmBits w] + MO_Xchg w -> [addr, cmmBits w] + MO_SuspendThread -> [] + MO_ResumeThread -> [] + where + addr = bWord platform diff --git a/GHC/Cmm/Node.hs b/GHC/Cmm/Node.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Node.hs @@ -0,0 +1,937 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} + +-- CmmNode type for representation using Hoopl graphs. + +module GHC.Cmm.Node ( + CmmNode(..), CmmFormal, CmmActual, CmmTickish, + UpdFrameOffset, Convention(..), + ForeignConvention(..), ForeignTarget(..), foreignTargetHints, + CmmReturnInfo(..), + mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf, + mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors, + + -- * Tick scopes + CmmTickScope(..), isTickSubScope, combineTickScopes, + ) where + +import GHC.Prelude hiding (succ) + +import GHC.Platform.Regs +import GHC.Cmm.CLabel +import GHC.Cmm.Expr +import GHC.Cmm.Switch +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Types.ForeignCall +import GHC.Utils.Outputable +import GHC.Runtime.Heap.Layout +import GHC.Types.Tickish (CmmTickish) +import qualified GHC.Types.Unique as U +import GHC.Types.Basic (FunctionOrData(..)) + +import GHC.Platform +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import Data.Foldable (toList) +import Data.Functor.Classes (liftCompare) +import Data.Maybe +import Data.List (tails,sortBy) +import GHC.Types.Unique (nonDetCmpUnique) +import GHC.Utils.Constants (debugIsOn) + + +------------------------ +-- CmmNode + +#define ULabel {-# UNPACK #-} !Label + +data CmmNode e x where + CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O + + CmmComment :: FastString -> CmmNode O O + + -- Tick annotation, covering Cmm code in our tick scope. We only + -- expect non-code @Tickish@ at this point (e.g. @SourceNote@). + -- See Note [CmmTick scoping details] + CmmTick :: !CmmTickish -> CmmNode O O + + -- Unwind pseudo-instruction, encoding stack unwinding + -- instructions for a debugger. This describes how to reconstruct + -- the "old" value of a register if we want to navigate the stack + -- up one frame. Having unwind information for @Sp@ will allow the + -- debugger to "walk" the stack. + -- + -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock" + CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O + + CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O + -- Assign to register + + CmmStore :: !CmmExpr -> !CmmExpr -> !AlignmentSpec -> CmmNode O O + -- Assign to memory location. Size is + -- given by cmmExprType of the rhs. + + CmmUnsafeForeignCall :: -- An unsafe foreign call; + -- see Note [Foreign calls] + -- Like a "fat machine instruction"; can occur + -- in the middle of a block + ForeignTarget -> -- call target + [CmmFormal] -> -- zero or more results + [CmmActual] -> -- zero or more arguments + CmmNode O O + -- Semantics: clobbers any GlobalRegs for which callerSaves r == True + -- See Note [Unsafe foreign calls clobber caller-save registers] + -- + -- Invariant: the arguments and the ForeignTarget must not + -- mention any registers for which GHC.Platform.callerSaves + -- is True. See Note [Register parameter passing]. + + CmmBranch :: ULabel -> CmmNode O C + -- Goto another block in the same procedure + + CmmCondBranch :: { -- conditional branch + cml_pred :: CmmExpr, + cml_true, cml_false :: ULabel, + cml_likely :: Maybe Bool -- likely result of the conditional, + -- if known + } -> CmmNode O C + + CmmSwitch + :: CmmExpr -- Scrutinee, of some integral type + -> SwitchTargets -- Cases. See Note [SwitchTargets] + -> CmmNode O C + + CmmCall :: { -- A native call or tail call + cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! + + cml_cont :: Maybe Label, + -- Label of continuation (Nothing for return or tail call) + -- + -- Note [Continuation BlockIds] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- These BlockIds are called + -- Continuation BlockIds, and are the only BlockIds that can + -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or + -- (CmmStackSlot (Young b) _). + + cml_args_regs :: [GlobalRegUse], + -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed + -- to the call. This is essential information for the + -- native code generator's register allocator; without + -- knowing which GlobalRegs are live it has to assume that + -- they are all live. This list should only include + -- GlobalRegs that are mapped to real machine registers on + -- the target platform. + + cml_args :: ByteOff, + -- Byte offset, from the *old* end of the Area associated with + -- the Label (if cml_cont = Nothing, then Old area), of + -- youngest outgoing arg. Set the stack pointer to this before + -- transferring control. + -- (NB: an update frame might also have been stored in the Old + -- area, but it'll be in an older part than the args.) + + cml_ret_args :: ByteOff, + -- For calls *only*, the byte offset for youngest returned value + -- This is really needed at the *return* point rather than here + -- at the call, but in practice it's convenient to record it here. + + cml_ret_off :: ByteOff + -- For calls *only*, the byte offset of the base of the frame that + -- must be described by the info table for the return point. + -- The older words are an update frames, which have their own + -- info-table and layout information + + -- From a liveness point of view, the stack words older than + -- cml_ret_off are treated as live, even if the sequel of + -- the call goes into a loop. + } -> CmmNode O C + + CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls] + -- Always the last node of a block + tgt :: ForeignTarget, -- call target and convention + res :: [CmmFormal], -- zero or more results + args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing] + succ :: ULabel, -- Label of continuation + ret_args :: ByteOff, -- same as cml_ret_args + ret_off :: ByteOff, -- same as cml_ret_off + intrbl:: Bool -- whether or not the call is interruptible + } -> CmmNode O C + +instance OutputableP Platform (CmmNode e x) where + pdoc = pprNode + +pprNode :: Platform -> CmmNode e x -> SDoc +pprNode platform node = pp_node <+> pp_debug + where + pp_node :: SDoc + pp_node = case node of + -- label: + CmmEntry id tscope -> + (sdocOption sdocSuppressUniques $ \case + True -> text "_lbl_" + False -> ppr id + ) + <> colon + <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope) + + -- // text + CmmComment s -> text "//" <+> ftext s + + -- //tick bla<...> + CmmTick t -> ppUnlessOption sdocSuppressTicks + (text "//tick" <+> ppr t) + + -- unwind reg = expr; + CmmUnwind regs -> + text "unwind " + <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi + + -- reg = expr; + CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi + + -- rep[lv] = expr; + CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi + where + align_mark = case align of + Unaligned -> text "^" + NaturallyAligned -> empty + rep = ppr ( cmmExprType platform expr ) + + -- call "ccall" foo(x, y)[r1, r2]; + -- ToDo ppr volatile + CmmUnsafeForeignCall target results args -> + hsep [ ppUnless (null results) $ + parens (commafy $ map ppr results) <+> equals, + text "call", + pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi] + + -- goto label; + CmmBranch ident -> text "goto" <+> ppr ident <> semi + + -- if (expr) goto t; else goto f; + CmmCondBranch expr t f l -> + hsep [ text "if" + , parens (pdoc platform expr) + , case l of + Nothing -> empty + Just b -> parens (text "likely:" <+> ppr b) + , text "goto" + , ppr t <> semi + , text "else goto" + , ppr f <> semi + ] + + CmmSwitch expr ids -> + hang (hsep [ text "switch" + , range + , if isTrivialCmmExpr expr + then pdoc platform expr + else parens (pdoc platform expr) + , text "{" + ]) + 4 (vcat (map ppCase cases) $$ def) $$ rbrace + where + (cases, mbdef) = switchTargetsFallThrough ids + ppCase (is,l) = hsep + [ text "case" + , commafy $ toList $ fmap integer is + , text ": goto" + , ppr l <> semi + ] + def | Just l <- mbdef = hsep + [ text "default:" + , braces (text "goto" <+> ppr l <> semi) + ] + | otherwise = empty + + range = brackets $ hsep [integer lo, text "..", integer hi] + where (lo,hi) = switchTargetsRange ids + + CmmCall tgt k regs out res updfr_off -> + hcat [ text "call", space + , pprFun tgt, parens (interpp'SP regs), space + , returns <+> + text "args: " <> ppr out <> comma <+> + text "res: " <> ppr res <> comma <+> + text "upd: " <> ppr updfr_off + , semi ] + where pprFun f@(CmmLit _) = pdoc platform f + pprFun f = parens (pdoc platform f) + + returns + | Just r <- k = text "returns to" <+> ppr r <> comma + | otherwise = empty + + CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> + hcat $ if i then [text "interruptible", space] else [] ++ + [ text "foreign call", space + , pdoc platform t, text "(...)", space + , text "returns to" <+> ppr s + <+> text "args:" <+> parens (pdoc platform as) + <+> text "ress:" <+> parens (ppr rs) + , text "ret_args:" <+> ppr a + , text "ret_off:" <+> ppr u + , semi ] + + pp_debug :: SDoc + pp_debug = + if not debugIsOn then empty + else case node of + CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" + CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" + CmmTick {} -> empty + CmmUnwind {} -> text " // CmmUnwind" + CmmAssign {} -> text " // CmmAssign" + CmmStore {} -> text " // CmmStore" + CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" + CmmBranch {} -> text " // CmmBranch" + CmmCondBranch {} -> text " // CmmCondBranch" + CmmSwitch {} -> text " // CmmSwitch" + CmmCall {} -> text " // CmmCall" + CmmForeignCall {} -> text " // CmmForeignCall" + + commafy :: [SDoc] -> SDoc + commafy xs = hsep $ punctuate comma xs + +instance OutputableP Platform (Block CmmNode C C) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode C O) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode O C) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode O O) where + pdoc = pprBlock + +instance OutputableP Platform (Graph CmmNode e x) where + pdoc = pprGraph + +pprBlock :: IndexedCO x SDoc SDoc ~ SDoc + => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock platform block + = foldBlockNodesB3 ( ($$) . pdoc platform + , ($$) . (nest 4) . pdoc platform + , ($$) . (nest 4) . pdoc platform + ) + block + empty + +pprGraph :: Platform -> Graph CmmNode e x -> SDoc +pprGraph platform = \case + GNil -> empty + GUnit block -> pdoc platform block + GMany entry body exit -> + text "{" + $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit) + $$ text "}" + where pprMaybeO :: OutputableP Platform (Block CmmNode e x) + => MaybeO ex (Block CmmNode e x) -> SDoc + pprMaybeO NothingO = empty + pprMaybeO (JustO block) = pdoc platform block + +{- Note [Foreign calls] +~~~~~~~~~~~~~~~~~~~~~~~ +A CmmUnsafeForeignCall is used for *unsafe* foreign calls; +a CmmForeignCall call is used for *safe* foreign calls. + +Unsafe ones are mostly easy: think of them as a "fat machine +instruction". In particular, they do *not* kill all live registers, +just the registers they return to (there was a bit of code in GHC that +conservatively assumed otherwise.) However, see [Register parameter passing]. + +Safe ones are trickier. A safe foreign call + r = f(x) +ultimately expands to + push "return address" -- Never used to return to; + -- just points an info table + save registers into TSO + call suspendThread + r = f(x) -- Make the call + call resumeThread + restore registers + pop "return address" +We cannot "lower" a safe foreign call to this sequence of Cmms, because +after we've saved Sp all the Cmm optimiser's assumptions are broken. + +Note that a safe foreign call needs an info table. + +So Safe Foreign Calls must remain as last nodes until the stack is +made manifest in GHC.Cmm.LayoutStack, where they are lowered into the above +sequence. +-} + +{- Note [Unsafe foreign calls clobber caller-save registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A foreign call is defined to clobber any GlobalRegs that are mapped to +caller-saves machine registers (according to the prevailing C ABI). +GHC.StgToCmm.Utils.callerSaves tells you which GlobalRegs are caller-saves. + +This is a design choice that makes it easier to generate code later. +We could instead choose to say that foreign calls do *not* clobber +caller-saves regs, but then we would have to figure out which regs +were live across the call later and insert some saves/restores. + +Furthermore when we generate code we never have any GlobalRegs live +across a call, because they are always copied-in to LocalRegs and +copied-out again before making a call/jump. So all we have to do is +avoid any code motion that would make a caller-saves GlobalReg live +across a foreign call during subsequent optimisations. +-} + +{- Note [Register parameter passing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On certain architectures, some registers are utilized for parameter +passing in the C calling convention. For example, in x86-64 Linux +convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for +argument passing. These are registers R3-R6, which our generated +code may also be using; as a result, it's necessary to save these +values before doing a foreign call. This is done during initial +code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils. + +However, one result of doing this is that the contents of these registers may +mysteriously change if referenced inside the arguments. This is dangerous, so +you'll need to disable inlining much in the same way is done in GHC.Cmm.Sink +currently. We should fix this! +-} + +--------------------------------------------- +-- Eq instance of CmmNode + +deriving instance Eq (CmmNode e x) + +---------------------------------------------- +-- Hoopl instances of CmmNode + +instance NonLocal CmmNode where + entryLabel (CmmEntry l _) = l + + successors (CmmBranch l) = [l] + successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint + successors (CmmSwitch _ ids) = switchTargetsToList ids + successors (CmmCall {cml_cont=l}) = maybeToList l + successors (CmmForeignCall {succ=l}) = [l] + + +-------------------------------------------------- +-- Various helper types + +type CmmActual = CmmExpr +type CmmFormal = LocalReg + +type UpdFrameOffset = ByteOff + +-- | A convention maps a list of values (function arguments or return +-- values) to registers or stack locations. +data Convention + = NativeDirectCall + -- ^ top-level Haskell functions use @NativeDirectCall@, which + -- maps arguments to registers starting with R2, according to + -- how many registers are available on the platform. This + -- convention ignores R1, because for a top-level function call + -- the function closure is implicit, and doesn't need to be passed. + | NativeNodeCall + -- ^ non-top-level Haskell functions, which pass the address of + -- the function closure in R1 (regardless of whether R1 is a + -- real register or not), and the rest of the arguments in + -- registers or on the stack. + | NativeReturn + -- ^ a native return. The convention for returns depends on + -- how many values are returned: for just one value returned, + -- the appropriate register is used (R1, F1, etc.). regardless + -- of whether it is a real register or not. For multiple + -- values returned, they are mapped to registers or the stack. + | Slow + -- ^ Slow entry points: all args pushed on the stack + | GC + -- ^ Entry to the garbage collector: uses the node reg! + -- (TODO: I don't think we need this --SDM) + deriving( Eq ) + +data ForeignConvention + = ForeignConvention + CCallConv -- Which foreign-call convention + [ForeignHint] -- Extra info about the args + [ForeignHint] -- Extra info about the result + CmmReturnInfo + deriving Eq + +instance Outputable ForeignConvention where + ppr = pprForeignConvention + +pprForeignConvention :: ForeignConvention -> SDoc +pprForeignConvention (ForeignConvention c args res ret) = + doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret + +data CmmReturnInfo + = CmmMayReturn + | CmmNeverReturns + deriving ( Eq ) + +instance Outputable CmmReturnInfo where + ppr = pprReturnInfo + +pprReturnInfo :: CmmReturnInfo -> SDoc +pprReturnInfo CmmMayReturn = empty +pprReturnInfo CmmNeverReturns = text "never returns" + +data ForeignTarget -- The target of a foreign call + = ForeignTarget -- A foreign procedure + CmmExpr -- Its address + ForeignConvention -- Its calling convention + | PrimTarget -- A possibly-side-effecting machine operation + CallishMachOp -- Which one + deriving Eq + +instance OutputableP Platform ForeignTarget where + pdoc = pprForeignTarget + +pprForeignTarget :: Platform -> ForeignTarget -> SDoc +pprForeignTarget platform (ForeignTarget fn c) = + ppr c <+> ppr_target fn + where + ppr_target :: CmmExpr -> SDoc + ppr_target t@(CmmLit _) = pdoc platform t + ppr_target fn' = parens (pdoc platform fn') +pprForeignTarget platform (PrimTarget op) + -- HACK: We're just using a ForeignLabel to get this printed, the label + -- might not really be foreign. + = pdoc platform + (mkForeignLabel + (mkFastString (show op)) + ForeignLabelInThisPackage IsFunction) + +instance Outputable Convention where + ppr = pprConvention + +pprConvention :: Convention -> SDoc +pprConvention (NativeNodeCall {}) = text "" +pprConvention (NativeDirectCall {}) = text "" +pprConvention (NativeReturn {}) = text "" +pprConvention Slow = text "" +pprConvention GC = text "" + + +foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) +foreignTargetHints target + = ( res_hints ++ repeat NoHint + , arg_hints ++ repeat NoHint ) + where + (res_hints, arg_hints) = + case target of + PrimTarget op -> callishMachOpHints op + ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) -> + (res_hints, arg_hints) + +-------------------------------------------------- +-- Instances of register and slot users / definers + +instance UserOfRegs LocalReg (CmmNode e x) where + {-# INLINEABLE foldRegsUsed #-} + foldRegsUsed platform f !z n = case n of + CmmAssign _ expr -> fold f z expr + CmmStore addr rval _ -> fold f (fold f z addr) rval + CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args + CmmCondBranch expr _ _ _ -> fold f z expr + CmmSwitch expr _ -> fold f z expr + CmmCall {cml_target=tgt} -> fold f z tgt + CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args + _ -> z + where fold :: forall a b. UserOfRegs LocalReg a + => (b -> LocalReg -> b) -> b -> a -> b + fold f z n = foldRegsUsed platform f z n + +instance UserOfRegs GlobalRegUse (CmmNode e x) where + {-# INLINEABLE foldRegsUsed #-} + foldRegsUsed platform f !z n = case n of + CmmAssign _ expr -> fold f z expr + CmmStore addr rval _ -> fold f (fold f z addr) rval + CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args + CmmCondBranch expr _ _ _ -> fold f z expr + CmmSwitch expr _ -> fold f z expr + CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt + CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args + _ -> z + where fold :: forall a b. UserOfRegs GlobalRegUse a + => (b -> GlobalRegUse -> b) -> b -> a -> b + fold f z n = foldRegsUsed platform f z n +instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where + -- The (Ord r) in the context is necessary here + -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance + {-# INLINEABLE foldRegsUsed #-} + foldRegsUsed _ _ !z (PrimTarget _) = z + foldRegsUsed platform f !z (ForeignTarget e _) = foldRegsUsed platform f z e + +instance DefinerOfRegs LocalReg (CmmNode e x) where + {-# INLINEABLE foldRegsDefd #-} + foldRegsDefd platform f !z n = case n of + CmmAssign lhs _ -> fold f z lhs + CmmUnsafeForeignCall _ fs _ -> fold f z fs + CmmForeignCall {res=res} -> fold f z res + _ -> z + where fold :: forall a b. DefinerOfRegs LocalReg a + => (b -> LocalReg -> b) -> b -> a -> b + fold f z n = foldRegsDefd platform f z n + +instance DefinerOfRegs GlobalRegUse (CmmNode e x) where + {-# INLINEABLE foldRegsDefd #-} + foldRegsDefd platform f !z n = case n of + CmmAssign lhs _ -> fold f z lhs + CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt) + CmmCall {} -> fold f z activeRegs + CmmForeignCall {} -> fold f z activeRegs + -- See Note [Safe foreign calls clobber STG registers] + _ -> z + where fold :: forall a b. DefinerOfRegs GlobalRegUse a + => (b -> GlobalRegUse -> b) -> b -> a -> b + fold f z n = foldRegsDefd platform f z n + + activeRegs :: [GlobalRegUse] + activeRegs = map (\ r -> GlobalRegUse r (globalRegSpillType platform r)) $ activeStgRegs platform + activeCallerSavesRegs = filter (callerSaves platform . globalRegUse_reg) activeRegs + + foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = [] + foreignTargetRegs _ = activeCallerSavesRegs + +-- Note [Safe foreign calls clobber STG registers] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- During stack layout phase every safe foreign call is expanded into a block +-- that contains unsafe foreign call (instead of safe foreign call) and ends +-- with a normal call (See Note [Foreign calls]). This means that we must +-- treat safe foreign call as if it was a normal call (because eventually it +-- will be). This is important if we try to run sinking pass before stack +-- layout phase. Consider this example of what might go wrong (this is cmm +-- code from stablename001 test). Here is code after common block elimination +-- (before stack layout): +-- +-- c1q6: +-- _s1pf::P64 = R1; +-- _c1q8::I64 = performMajorGC; +-- I64[(young + 8)] = c1q9; +-- foreign call "ccall" arg hints: [] result hints: [] (_c1q8::I64)(...) +-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8; +-- c1q9: +-- I64[(young + 8)] = c1qb; +-- R1 = _s1pc::P64; +-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; +-- +-- If we run sinking pass now (still before stack layout) we will get this: +-- +-- c1q6: +-- I64[(young + 8)] = c1q9; +-- foreign call "ccall" arg hints: [] result hints: [] performMajorGC(...) +-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8; +-- c1q9: +-- I64[(young + 8)] = c1qb; +-- _s1pf::P64 = R1; <------ _s1pf sunk past safe foreign call +-- R1 = _s1pc::P64; +-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; +-- +-- Notice that _s1pf was sunk past a foreign call. When we run stack layout +-- safe call to performMajorGC will be turned into: +-- +-- c1q6: +-- _s1pc::P64 = P64[Sp + 8]; +-- I64[Sp - 8] = c1q9; +-- Sp = Sp - 8; +-- I64[I64[CurrentTSO + 24] + 16] = Sp; +-- P64[CurrentNursery + 8] = Hp + 8; +-- (_u1qI::I64) = call "ccall" arg hints: [PtrHint,] +-- result hints: [PtrHint] suspendThread(BaseReg, 0); +-- call "ccall" arg hints: [] result hints: [] performMajorGC(); +-- (_u1qJ::I64) = call "ccall" arg hints: [PtrHint] +-- result hints: [PtrHint] resumeThread(_u1qI::I64); +-- BaseReg = _u1qJ::I64; +-- _u1qK::P64 = CurrentTSO; +-- _u1qL::P64 = I64[_u1qK::P64 + 24]; +-- Sp = I64[_u1qL::P64 + 16]; +-- SpLim = _u1qL::P64 + 192; +-- HpAlloc = 0; +-- Hp = I64[CurrentNursery + 8] - 8; +-- HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1); +-- call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8; +-- c1q9: +-- I64[(young + 8)] = c1qb; +-- _s1pf::P64 = R1; <------ INCORRECT! +-- R1 = _s1pc::P64; +-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; +-- +-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that +-- call is clearly incorrect. This is what would happen if we assumed that +-- safe foreign call has the same semantics as unsafe foreign call. To prevent +-- this we need to treat safe foreign call as if was normal call. + +----------------------------------- +-- mapping Expr in GHC.Cmm.Node + +mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget +mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c +mapForeignTarget _ m@(PrimTarget _) = m + +wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr +-- Take a transformer on expressions and apply it recursively. +-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e +-- then uses f to rewrite the resulting expression +wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es) +wrapRecExp f (CmmLoad addr ty align) = f (CmmLoad (wrapRecExp f addr) ty align) +wrapRecExp f e = f e + +mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x +mapExp _ f@(CmmEntry{}) = f +mapExp _ m@(CmmComment _) = m +mapExp _ m@(CmmTick _) = m +mapExp f (CmmUnwind regs) = CmmUnwind (map (fmap (fmap f)) regs) +mapExp f (CmmAssign r e) = CmmAssign r (f e) +mapExp f (CmmStore addr e align) = CmmStore (f addr) (f e) align +mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as) +mapExp _ l@(CmmBranch _) = l +mapExp f (CmmCondBranch e ti fi l) = CmmCondBranch (f e) ti fi l +mapExp f (CmmSwitch e ids) = CmmSwitch (f e) ids +mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt} +mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl + +mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x +mapExpDeep f = mapExp $ wrapRecExp f + +------------------------------------------------------------------------ +-- mapping Expr in GHC.Cmm.Node, but not performing allocation if no changes + +mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget +mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e +mapForeignTargetM _ (PrimTarget _) = Nothing + +wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr) +-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e +-- then gives f a chance to rewrite the resulting expression +wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es) +wrapRecExpM f n@(CmmLoad addr ty align) = maybe (f n) (\addr' -> f $ CmmLoad addr' ty align) (wrapRecExpM f addr) +wrapRecExpM f e = f e + +mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) +mapExpM _ (CmmEntry{}) = Nothing +mapExpM _ (CmmComment _) = Nothing +mapExpM _ (CmmTick _) = Nothing +mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs +mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e +mapExpM f (CmmStore addr e align) = (\ (Pair addr' e') -> CmmStore addr' e' align) `fmap` traverse f (Pair addr e) +mapExpM _ (CmmBranch _) = Nothing +mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e +mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e +mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt +mapExpM f (CmmUnsafeForeignCall tgt fs as) + = case mapForeignTargetM f tgt of + Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as)) + Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as +mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) + = case mapForeignTargetM f tgt of + Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl) + Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as + +-- share as much as possible +mapListM :: (a -> Maybe a) -> [a] -> Maybe [a] +mapListM f xs = let (b, r) = mapListT f xs + in if b then Just r else Nothing + +mapListJ :: (a -> Maybe a) -> [a] -> [a] +mapListJ f xs = snd (mapListT f xs) + +mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a]) +mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs)) + where g (_, y, Nothing) (True, ys) = (True, y:ys) + g (_, _, Just y) (True, ys) = (True, y:ys) + g (ys', _, Nothing) (False, _) = (False, ys') + g (_, _, Just y) (False, ys) = (True, y:ys) + +mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) +mapExpDeepM f = mapExpM $ wrapRecExpM f + +----------------------------------- +-- folding Expr in GHC.Cmm.Node + +foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z +foldExpForeignTarget exp (ForeignTarget e _) z = exp e z +foldExpForeignTarget _ (PrimTarget _) z = z + +-- Take a folder on expressions and apply it recursively. +-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad +-- itself, delegating all the other CmmExpr forms to 'f'. +wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z +wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es +wrapRecExpf f e@(CmmLoad addr _ _) z = wrapRecExpf f addr (f e z) +wrapRecExpf f e z = f e z + +foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z +foldExp _ (CmmEntry {}) z = z +foldExp _ (CmmComment {}) z = z +foldExp _ (CmmTick {}) z = z +foldExp f (CmmUnwind xs) z = foldr (maybe id f) z (map snd xs) +foldExp f (CmmAssign _ e) z = f e z +foldExp f (CmmStore addr e _) z = f addr $ f e z +foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as +foldExp _ (CmmBranch _) z = z +foldExp f (CmmCondBranch e _ _ _) z = f e z +foldExp f (CmmSwitch e _) z = f e z +foldExp f (CmmCall {cml_target=tgt}) z = f tgt z +foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args + +foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z +foldExpDeep f = foldExp (wrapRecExpf f) + +-- ----------------------------------------------------------------------------- + +mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C +mapSuccessors f (CmmBranch bid) = CmmBranch (f bid) +mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l +mapSuccessors f (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets f ids) +mapSuccessors _ n = n + +mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C + -> (CmmNode O C, [a]) +mapCollectSuccessors f (CmmBranch bid) + = let (bid', acc) = f bid in (CmmBranch bid', [acc]) +mapCollectSuccessors f (CmmCondBranch p y n l) + = let (bidt, acct) = f y + (bidf, accf) = f n + in (CmmCondBranch p bidt bidf l, [accf, acct]) +mapCollectSuccessors f (CmmSwitch e ids) + = let lbls = switchTargetsToList ids :: [Label] + lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a) + in ( CmmSwitch e + (mapSwitchTargets + (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids) + , map snd (mapElems lblMap) + ) +mapCollectSuccessors _ n = (n, []) + +-- ----------------------------------------------------------------------------- + +-- | Tick scope identifier, allowing us to reason about what +-- annotations in a Cmm block should scope over. We especially take +-- care to allow optimisations to reorganise blocks without losing +-- tick association in the process. +data CmmTickScope + = GlobalScope + -- ^ The global scope is the "root" of the scope graph. Every + -- scope is a sub-scope of the global scope. It doesn't make sense + -- to add ticks to this scope. On the other hand, this means that + -- setting this scope on a block means no ticks apply to it. + + | SubScope !U.Unique CmmTickScope + -- ^ Constructs a new sub-scope to an existing scope. This allows + -- us to translate Core-style scoping rules (see @tickishScoped@) + -- into the Cmm world. Suppose the following code: + -- + -- tick<1> case ... of + -- A -> tick<2> ... + -- B -> tick<3> ... + -- + -- We want the top-level tick annotation to apply to blocks + -- generated for the A and B alternatives. We can achieve that by + -- generating tick<1> into a block with scope a, while the code + -- for alternatives A and B gets generated into sub-scopes a/b and + -- a/c respectively. + + | CombinedScope CmmTickScope CmmTickScope + -- ^ A combined scope scopes over everything that the two given + -- scopes cover. It is therefore a sub-scope of either scope. This + -- is required for optimisations. Consider common block elimination: + -- + -- A -> tick<2> case ... of + -- C -> [common] + -- B -> tick<3> case ... of + -- D -> [common] + -- + -- We will generate code for the C and D alternatives, and figure + -- out afterwards that it's actually common code. Scoping rules + -- dictate that the resulting common block needs to be covered by + -- both tick<2> and tick<3>, therefore we need to construct a + -- scope that is a child to *both* scope. Now we can do that - if + -- we assign the scopes a/c and b/d to the common-ed up blocks, + -- the new block could have a combined tick scope a/c+b/d, which + -- both tick<2> and tick<3> apply to. + +-- Note [CmmTick scoping details] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the +-- same block. Note that as a result of this, optimisations making +-- tick scopes more specific can *reduce* the amount of code a tick +-- scopes over. Fixing this would require a separate @CmmTickScope@ +-- field for @CmmTick@. Right now we do not do this simply because I +-- couldn't find an example where it actually mattered -- multiple +-- blocks within the same scope generally jump to each other, which +-- prevents common block elimination from happening in the first +-- place. But this is no strong reason, so if Cmm optimisations become +-- more involved in future this might have to be revisited. + +-- | Output all scope paths. +scopeToPaths :: CmmTickScope -> [[U.Unique]] +scopeToPaths GlobalScope = [[]] +scopeToPaths (SubScope u s) = map (u:) (scopeToPaths s) +scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2 + +-- | Returns the head uniques of the scopes. This is based on the +-- assumption that the @Unique@ of @SubScope@ identifies the +-- underlying super-scope. Used for efficient equality and comparison, +-- see below. +scopeUniques :: CmmTickScope -> [U.Unique] +scopeUniques GlobalScope = [] +scopeUniques (SubScope u _) = [u] +scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2 + +-- Equality and order is based on the head uniques defined above. We +-- take care to short-cut the (extremely) common cases. +instance Eq CmmTickScope where + GlobalScope == GlobalScope = True + GlobalScope == _ = False + _ == GlobalScope = False + (SubScope u _) == (SubScope u' _) = u == u' + (SubScope _ _) == _ = False + _ == (SubScope _ _) = False + scope == scope' = + sortBy nonDetCmpUnique (scopeUniques scope) == + sortBy nonDetCmpUnique (scopeUniques scope') + -- This is still deterministic because + -- the order is the same for equal lists + +-- This is non-deterministic but we do not currently support deterministic +-- code-generation. See Note [Unique Determinism and code generation] +-- See Note [No Ord for Unique] +instance Ord CmmTickScope where + compare GlobalScope GlobalScope = EQ + compare GlobalScope _ = LT + compare _ GlobalScope = GT + compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u' + compare scope scope' = liftCompare nonDetCmpUnique + (sortBy nonDetCmpUnique $ scopeUniques scope) + (sortBy nonDetCmpUnique $ scopeUniques scope') + +instance Outputable CmmTickScope where + ppr GlobalScope = text "global" + ppr (SubScope us GlobalScope) + = ppr us + ppr (SubScope us s) = ppr s <> char '/' <> ppr us + ppr combined = parens $ hcat $ punctuate (char '+') $ + map (hcat . punctuate (char '/') . map ppr . reverse) $ + scopeToPaths combined + +-- | Checks whether two tick scopes are sub-scopes of each other. True +-- if the two scopes are equal. +isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool +isTickSubScope = cmp + where cmp _ GlobalScope = True + cmp GlobalScope _ = False + cmp (CombinedScope s1 s2) s' = cmp s1 s' && cmp s2 s' + cmp s (CombinedScope s1' s2') = cmp s s1' || cmp s s2' + cmp (SubScope u s) s'@(SubScope u' _) = u == u' || cmp s s' + +-- | Combine two tick scopes. The new scope should be sub-scope of +-- both parameters. We simplify automatically if one tick scope is a +-- sub-scope of the other already. +combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope +combineTickScopes s1 s2 + | s1 `isTickSubScope` s2 = s1 + | s2 `isTickSubScope` s1 = s2 + | otherwise = CombinedScope s1 s2 diff --git a/GHC/Cmm/Opt.hs b/GHC/Cmm/Opt.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Opt.hs @@ -0,0 +1,484 @@ +----------------------------------------------------------------------------- +-- +-- Cmm optimisation +-- +-- (c) The University of Glasgow 2006 +-- +----------------------------------------------------------------------------- +module GHC.Cmm.Opt ( + constantFoldNode, + constantFoldExpr, + cmmMachOpFold, + cmmMachOpFoldM + ) where + +import GHC.Prelude + +import GHC.Cmm.Utils +import GHC.Cmm +import GHC.Utils.Misc + +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Platform + +import Data.Maybe +import GHC.Float + + +constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x +constantFoldNode platform = mapExp (constantFoldExpr platform) + +constantFoldExpr :: Platform -> CmmExpr -> CmmExpr +constantFoldExpr platform = wrapRecExp f + where f (CmmMachOp op args) = cmmMachOpFold platform op args + f (CmmRegOff r 0) = CmmReg r + f e = e + +-- ----------------------------------------------------------------------------- +-- MachOp constant folder + +-- Now, try to constant-fold the MachOps. The arguments have already +-- been optimized and folded. + +cmmMachOpFold + :: Platform + -> MachOp -- The operation from an CmmMachOp + -> [CmmExpr] -- The optimized arguments + -> CmmExpr + +cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args) + +-- Returns Nothing if no changes, useful for Hoopl, also reduces +-- allocation! +cmmMachOpFoldM + :: Platform + -> MachOp + -> [CmmExpr] + -> Maybe CmmExpr +cmmMachOpFoldM _ (MO_V_Broadcast lg _w) exprs = + case exprs of + [CmmLit l] -> Just $! CmmLit (CmmVec $ replicate lg l) + _ -> Nothing +cmmMachOpFoldM _ (MO_VF_Broadcast lg _w) exprs = + case exprs of + [CmmLit l] -> Just $! CmmLit (CmmVec $ replicate lg l) + _ -> Nothing +cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)] + | MO_WF_Bitcast width <- op = case width of + W32 | res <- castWord32ToFloat (fromInteger x) + -- Since we store float literals as Rationals + -- we must check for the usual tricky cases first + , not (isNegativeZero res || isNaN res || isInfinite res) + -- (round-tripping subnormals is not a problem) + , !res_rat <- toRational res + -> Just (CmmLit (CmmFloat res_rat W32)) + + W64 | res <- castWord64ToDouble (fromInteger x) + -- Since we store float literals as Rationals + -- we must check for the usual tricky cases first + , not (isNegativeZero res || isNaN res || isInfinite res) + -- (round-tripping subnormals is not a problem) + , !res_rat <- toRational res + -> Just (CmmLit (CmmFloat res_rat W64)) + + _ -> Nothing + | otherwise + = Just $! case op of + MO_S_Neg _ -> CmmLit (CmmInt (narrowS rep (-x)) rep) + MO_Not _ -> CmmLit (CmmInt (complement x) rep) + + -- these are interesting: we must first narrow to the + -- "from" type, in order to truncate to the correct size. + -- The final narrow/widen to the destination type + -- is implicit in the CmmLit. + MO_SF_Round _frm to -> CmmLit (CmmFloat (fromInteger x) to) + MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to) + MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to) + MO_XX_Conv from to -> CmmLit (CmmInt (narrowS from x) to) + + MO_F_Neg{} -> invalidArgPanic + MO_FS_Truncate{} -> invalidArgPanic + MO_FF_Conv{} -> invalidArgPanic + MO_FW_Bitcast{} -> invalidArgPanic + MO_VS_Neg{} -> invalidArgPanic + MO_VF_Neg{} -> invalidArgPanic + MO_RelaxedRead{} -> invalidArgPanic + MO_AlignmentCheck{} -> invalidArgPanic + + _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op + where invalidArgPanic = pprPanic "cmmMachOpFoldM" $ + text "Found" <+> pprMachOp op + <+> text "illegally applied to an int literal" + +-- Eliminate shifts that are wider than the shiftee +cmmMachOpFoldM _ op [_shiftee, CmmLit (CmmInt shift _)] + | Just width <- isShift op + , shift >= fromIntegral (widthInBits width) + = Just $! CmmLit (CmmInt 0 width) + where + isShift (MO_Shl w) = Just w + isShift (MO_U_Shr w) = Just w + isShift (MO_S_Shr w) = Just w + isShift _ = Nothing + +-- Eliminate conversion NOPs +cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x +cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x +cmmMachOpFoldM _ (MO_XX_Conv rep1 rep2) [x] | rep1 == rep2 = Just x + +-- Eliminate nested conversions where possible +cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]] + | Just (rep1,rep2,signed1) <- isIntConversion conv_inner, + Just (_, rep3,signed2) <- isIntConversion conv_outer + = case () of + -- widen then narrow to the same size is a nop + _ | rep1 < rep2 && rep1 == rep3 -> Just x + -- Widen then narrow to different size: collapse to single conversion + -- but remember to use the signedness from the widening, just in case + -- the final conversion is a widen. + | rep1 < rep2 && rep2 > rep3 -> + Just $! cmmMachOpFold platform (intconv signed1 rep1 rep3) [x] + -- Nested widenings: collapse if the signedness is the same + | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 -> + Just $! cmmMachOpFold platform (intconv signed1 rep1 rep3) [x] + -- Nested narrowings: collapse + | rep1 > rep2 && rep2 > rep3 -> + Just $! cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x] + | otherwise -> + Nothing + where + isIntConversion (MO_UU_Conv rep1 rep2) + = Just (rep1,rep2,False) + isIntConversion (MO_SS_Conv rep1 rep2) + = Just (rep1,rep2,True) + isIntConversion _ = Nothing + + intconv True = MO_SS_Conv + intconv False = MO_UU_Conv + +cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] + = case mop of + -- for comparisons: don't forget to narrow the arguments before + -- comparing, since they might be out of range. + MO_Eq _ -> Just $! CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth platform)) + MO_Ne _ -> Just $! CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth platform)) + + MO_U_Gt _ -> Just $! CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth platform)) + MO_U_Ge _ -> Just $! CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth platform)) + MO_U_Lt _ -> Just $! CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth platform)) + MO_U_Le _ -> Just $! CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth platform)) + + MO_S_Gt _ -> Just $! CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth platform)) + MO_S_Ge _ -> Just $! CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth platform)) + MO_S_Lt _ -> Just $! CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth platform)) + MO_S_Le _ -> Just $! CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform)) + + MO_Add r -> Just $! CmmLit (CmmInt (narrowU r $ x + y) r) + MO_Sub r -> Just $! CmmLit (CmmInt (narrowS r $ x - y) r) + MO_Mul r -> Just $! CmmLit (CmmInt (narrowU r $ x * y) r) + MO_U_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `quot` y_u) r) + MO_U_Rem r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `rem` y_u) r) + MO_S_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_s `quot` y_s) r) + MO_S_Rem r | y /= 0 -> Just $! CmmLit (CmmInt (x_s `rem` y_s) r) + + MO_And r -> Just $! CmmLit (CmmInt (x .&. y) r) + MO_Or r -> Just $! CmmLit (CmmInt (x .|. y) r) + MO_Xor r -> Just $! CmmLit (CmmInt (x `xor` y) r) + + MO_Shl r -> Just $! CmmLit (CmmInt (narrowU r $ x `shiftL` fromIntegral y) r) + MO_U_Shr r -> Just $! CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r) + MO_S_Shr r -> Just $! CmmLit (CmmInt (x_s `shiftR` fromIntegral y) r) + + _ -> Nothing + + where + x_u = narrowU xrep x + y_u = narrowU xrep y + x_s = narrowS xrep x + y_s = narrowS xrep y + + +-- When possible, shift the constants to the right-hand side, so that we +-- can match for strength reductions. Note that the code generator will +-- also assume that constants have been shifted to the right when +-- possible. + +cmmMachOpFoldM platform op [x@(CmmLit _), y] + | not (isLit y) && isCommutableMachOp op + = Just $! (cmmMachOpFold platform op [y, x]) + +-- Turn (a+b)+c into a+(b+c) where possible. Because literals are +-- moved to the right, it is more likely that we will find +-- opportunities for constant folding when the expression is +-- right-associated. +-- +-- ToDo: this appears to introduce a quadratic behaviour due to the +-- nested cmmMachOpFold. Can we fix this? +-- +-- Why do we check isLit arg1? If arg1 is a lit, it means that arg2 +-- is also a lit (otherwise arg1 would be on the right). If we +-- put arg1 on the left of the rearranged expression, we'll get into a +-- loop: (x1+x2)+x3 => x1+(x2+x3) => (x2+x3)+x1 => x2+(x3+x1) ... +-- +-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the +-- PicBaseReg from the corresponding label (or label difference). +-- +cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3] + | mop2 `associates_with` mop1 + && not (isLit arg1) && not (isPicReg arg1) + = Just $! (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]]) + where + MO_Add{} `associates_with` MO_Sub{} = True + mop1 `associates_with` mop2 = + mop1 == mop2 && isAssociativeMachOp mop1 + +-- special case: (a - b) + c ==> a + (c - b) +cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] + | not (isLit arg1) && not (isPicReg arg1) + = Just $! (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]]) + +-- special case: (PicBaseReg + lit) + N ==> PicBaseReg + (lit+N) +-- +-- this is better because lit+N is a single link-time constant (e.g. a +-- CmmLabelOff), so the right-hand expression needs only one +-- instruction, whereas the left needs two. This happens when pointer +-- tagging gives us label+offset, and PIC turns the label into +-- PicBaseReg + label. +-- +cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit] + , CmmLit (CmmInt n rep) ] + | isPicReg pic + = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ] + where off = fromIntegral (narrowS rep n) + +-- Make a RegOff if we can. We don't perform this optimization if rep is greater +-- than the host word size because we use an Int to store the offset. See +-- #24893 and #24700. This should be fixed to ensure that optimizations don't +-- depend on the compiler host platform. +cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] + | validOffsetRep rep + = Just $! cmmRegOff reg (fromIntegral (narrowS rep n)) +cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + | validOffsetRep rep + = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n)) +cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] + | validOffsetRep rep + = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n)) +cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + | validOffsetRep rep + = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n)) + +-- Fold label(+/-)offset into a CmmLit where possible + +cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)] + | validOffsetRep rep + = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) +cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit] + | validOffsetRep rep + = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) +cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)] + | validOffsetRep rep + = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) + + +-- Comparison of literal with widened operand: perform the comparison +-- at the smaller width, as long as the literal is within range. + +-- We can't do the reverse trick, when the operand is narrowed: +-- narrowing throws away bits from the operand, there's no way to do +-- the same comparison at the larger size. + +cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] + | -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try + platformArch platform `elem` [ArchX86, ArchX86_64], + -- if the operand is widened: + Just (rep, signed, narrow_fn) <- maybe_conversion conv, + -- and this is a comparison operation: + Just narrow_cmp <- maybe_comparison cmp rep signed, + -- and the literal fits in the smaller size: + i == narrow_fn rep i + -- then we can do the comparison at the smaller size + = Just $! (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)]) + where + maybe_conversion (MO_UU_Conv from to) + | to > from + = Just (from, False, narrowU) + maybe_conversion (MO_SS_Conv from to) + | to > from + = Just (from, True, narrowS) + + -- don't attempt to apply this optimisation when the source + -- is a float; see #1916 + maybe_conversion _ = Nothing + + -- careful (#2080): if the original comparison was signed, but + -- we were doing an unsigned widen, then we must do an + -- unsigned comparison at the smaller size. + maybe_comparison (MO_U_Gt _) rep _ = Just (MO_U_Gt rep) + maybe_comparison (MO_U_Ge _) rep _ = Just (MO_U_Ge rep) + maybe_comparison (MO_U_Lt _) rep _ = Just (MO_U_Lt rep) + maybe_comparison (MO_U_Le _) rep _ = Just (MO_U_Le rep) + maybe_comparison (MO_Eq _) rep _ = Just (MO_Eq rep) + maybe_comparison (MO_S_Gt _) rep True = Just (MO_S_Gt rep) + maybe_comparison (MO_S_Ge _) rep True = Just (MO_S_Ge rep) + maybe_comparison (MO_S_Lt _) rep True = Just (MO_S_Lt rep) + maybe_comparison (MO_S_Le _) rep True = Just (MO_S_Le rep) + maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep) + maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep) + maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep) + maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep) + maybe_comparison _ _ _ = Nothing + +-- We can often do something with constants of 0 and 1 ... +-- See Note [Comparison operators] + +cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))] + = case mop of + -- Arithmetic + MO_Add _ -> Just x -- x + 0 = x + MO_Sub _ -> Just x -- x - 0 = x + MO_Mul _ -> Just y -- x * 0 = 0 + + -- Logical operations + MO_And _ -> Just y -- x & 0 = 0 + MO_Or _ -> Just x -- x | 0 = x + MO_Xor _ -> Just x -- x `xor` 0 = x + + -- Shifts + MO_Shl _ -> Just x -- x << 0 = x + MO_S_Shr _ -> Just x -- ditto shift-right + MO_U_Shr _ -> Just x + + -- Comparisons; these ones are trickier + -- See Note [Comparison operators] + MO_Ne _ | isComparisonExpr x -> Just x -- (x > y) != 0 = x > y + MO_Eq _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x > y) == 0 = x <= y + MO_U_Gt _ | isComparisonExpr x -> Just x -- (x > y) > 0 = x > y + MO_S_Gt _ | isComparisonExpr x -> Just x -- ditto + MO_U_Lt _ | isComparisonExpr x -> Just zero -- (x > y) < 0 = 0 + MO_S_Lt _ | isComparisonExpr x -> Just zero + MO_U_Ge _ | isComparisonExpr x -> Just one -- (x > y) >= 0 = 1 + MO_S_Ge _ | isComparisonExpr x -> Just one + + MO_U_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x > y) <= 0 = x <= y + MO_S_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' + _ -> Nothing + where + zero = CmmLit (CmmInt 0 (wordWidth platform)) + one = CmmLit (CmmInt 1 (wordWidth platform)) + +cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt 1 rep))] + = case mop of + -- Arithmetic: x*1 = x, etc + MO_Mul _ -> Just x + MO_S_Quot _ -> Just x + MO_U_Quot _ -> Just x + MO_S_Rem _ -> Just $! CmmLit (CmmInt 0 rep) + MO_U_Rem _ -> Just $! CmmLit (CmmInt 0 rep) + + -- Comparisons; trickier + -- See Note [Comparison operators] + MO_Ne _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x>y) != 1 = x<=y + MO_Eq _ | isComparisonExpr x -> Just x -- (x>y) == 1 = x>y + MO_U_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x>y) < 1 = x<=y + MO_S_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- ditto + MO_U_Gt _ | isComparisonExpr x -> Just zero -- (x>y) > 1 = 0 + MO_S_Gt _ | isComparisonExpr x -> Just zero + MO_U_Le _ | isComparisonExpr x -> Just one -- (x>y) <= 1 = 1 + MO_S_Le _ | isComparisonExpr x -> Just one + MO_U_Ge _ | isComparisonExpr x -> Just x -- (x>y) >= 1 = x>y + MO_S_Ge _ | isComparisonExpr x -> Just x + _ -> Nothing + where + zero = CmmLit (CmmInt 0 (wordWidth platform)) + one = CmmLit (CmmInt 1 (wordWidth platform)) + +-- Now look for multiplication/division by powers of 2 (integers). + +cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))] + = case mop of + MO_Mul rep + | Just p <- exactLog2 n -> + Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p $ wordWidth platform)]) + MO_U_Quot rep + | Just p <- exactLog2 n -> + Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p $ wordWidth platform)]) + MO_U_Rem rep + | Just _ <- exactLog2 n -> + Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)]) + MO_S_Quot rep + | Just p <- exactLog2 n, + CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require + -- it is a reg. FIXME: remove this restriction. + Just $! (cmmMachOpFold platform (MO_S_Shr rep) + [signedQuotRemHelper rep p, CmmLit (CmmInt p $ wordWidth platform)]) + MO_S_Rem rep + | Just p <- exactLog2 n, + CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require + -- it is a reg. FIXME: remove this restriction. + -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p). + -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot) + -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation. + Just $! (cmmMachOpFold platform (MO_Sub rep) + [x, cmmMachOpFold platform (MO_And rep) + [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]]) + _ -> Nothing + where + -- In contrast with unsigned integers, for signed ones + -- shift right is not the same as quot, because it rounds + -- to minus infinity, whereas quot rounds toward zero. + -- To fix this up, we add one less than the divisor to the + -- dividend if it is a negative number. + -- + -- to avoid a test/jump, we use the following sequence: + -- x1 = x >> word_size-1 (all 1s if -ve, all 0s if +ve) + -- x2 = y & (divisor-1) + -- result = x + x2 + -- this could be done a bit more simply using conditional moves, + -- but we're processor independent here. + -- + -- we optimise the divide by 2 case slightly, generating + -- x1 = x >> word_size-1 (unsigned) + -- return = x + x1 + signedQuotRemHelper :: Width -> Integer -> CmmExpr + signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2] + where + bits = fromIntegral (widthInBits rep) - 1 + shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep + x1 = CmmMachOp shr [x, CmmLit (CmmInt bits $ wordWidth platform)] + x2 = if p == 1 then x1 else + CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] + +-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x +-- Unfortunately this needs a unique supply because x might not be a +-- register. See #2253 (program 6) for an example. + + +-- Anything else is just too hard. + +cmmMachOpFoldM _ _ _ = Nothing + +-- | Check that a literal width is compatible with the host word size used to +-- store offsets. This should be fixed properly (using larger types to store +-- literal offsets). See #24893 +validOffsetRep :: Width -> Bool +validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int) + + +{- Note [Comparison operators] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + CmmCondBranch ((x>#y) == 1) t f +we really want to convert to + CmmCondBranch (x>#y) t f + +That's what the constant-folding operations on comparison operators do above. +-} + +-- ----------------------------------------------------------------------------- +-- Utils + +isPicReg :: CmmExpr -> Bool +isPicReg (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) = True +isPicReg _ = False diff --git a/GHC/Cmm/Parser.hs b/GHC/Cmm/Parser.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Parser.hs @@ -0,0 +1,3906 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS -XMagicHash -XBangPatterns -XTypeSynonymInstances -XFlexibleInstances -cpp #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# OPTIONS_GHC -XPartialTypeSignatures #-} +#endif +{-# LANGUAGE TupleSections #-} + +module GHC.Cmm.Parser ( parseCmmFile, CmmParserConfig(..) ) where + +import GHC.Prelude +import qualified Prelude -- for happy-generated code + +import GHC.Platform +import GHC.Platform.Profile + +import GHC.StgToCmm.ExtCode +import GHC.StgToCmm.Heap +import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit + , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff + , getUpdFrameOff, getProfile, getPlatform, getContext) +import qualified GHC.StgToCmm.Monad as F +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Foreign +import GHC.StgToCmm.Expr +import GHC.StgToCmm.Lit +import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config +import GHC.StgToCmm.Layout hiding (ArgRep(..)) +import GHC.StgToCmm.Ticky +import GHC.StgToCmm.Prof +import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame ) +import GHC.StgToCmm.InfoTableProv + +import GHC.Cmm.Opt +import GHC.Cmm.Graph +import GHC.Cmm +import GHC.Cmm.Reg ( GlobalArgRegs(..) ) +import GHC.Cmm.Utils +import GHC.Cmm.Switch ( mkSwitchTargets ) +import GHC.Cmm.Info +import GHC.Cmm.BlockId +import GHC.Cmm.Lexer +import GHC.Cmm.CLabel +import GHC.Cmm.Parser.Config +import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile) +import qualified GHC.Cmm.Parser.Monad as PD +import GHC.Cmm.CallConv +import GHC.Runtime.Heap.Layout +import GHC.Parser.Lexer +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr + +import GHC.Types.Unique.DSM +import GHC.Types.CostCentre +import GHC.Types.ForeignCall +import GHC.Unit.Module +import GHC.Unit.Home +import GHC.Types.Literal +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.SrcLoc +import GHC.Types.Tickish ( GenTickish(SourceNote) ) +import GHC.Utils.Error +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Settings.Constants +import GHC.Utils.Outputable +import GHC.Types.Basic +import GHC.Data.Bag ( Bag, emptyBag, unitBag, isEmptyBag ) +import GHC.Types.Var + +import Control.Monad +import Data.Array +import Data.Char ( ord ) +import System.Exit +import Data.Maybe +import qualified Data.Map as M +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Array as Happy_Data_Array +import qualified Data.Bits as Bits +import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) +import Control.Monad (ap) + +-- parser produced by Happy Version 1.20.1.1 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +newtype HappyWrap4 = HappyWrap4 (CmmParse ()) +happyIn4 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn4 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap4 x) +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> HappyWrap4 +happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut4 #-} +newtype HappyWrap5 = HappyWrap5 (CmmParse ()) +happyIn5 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn5 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap5 x) +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> HappyWrap5 +happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut5 #-} +newtype HappyWrap6 = HappyWrap6 (CmmParse ()) +happyIn6 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn6 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap6 x) +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> HappyWrap6 +happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut6 #-} +newtype HappyWrap7 = HappyWrap7 (CmmParse CLabel) +happyIn7 :: (CmmParse CLabel) -> (HappyAbsSyn ) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap7 x) +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> HappyWrap7 +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +newtype HappyWrap8 = HappyWrap8 ([CmmParse [CmmStatic]]) +happyIn8 :: ([CmmParse [CmmStatic]]) -> (HappyAbsSyn ) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap8 x) +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> HappyWrap8 +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +newtype HappyWrap9 = HappyWrap9 (CmmParse [CmmStatic]) +happyIn9 :: (CmmParse [CmmStatic]) -> (HappyAbsSyn ) +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap9 x) +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> HappyWrap9 +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut9 #-} +newtype HappyWrap10 = HappyWrap10 ([CmmParse CmmExpr]) +happyIn10 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) +happyIn10 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap10 x) +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> HappyWrap10 +happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut10 #-} +newtype HappyWrap11 = HappyWrap11 (CmmParse ()) +happyIn11 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn11 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap11 x) +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> HappyWrap11 +happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut11 #-} +newtype HappyWrap12 = HappyWrap12 (Convention) +happyIn12 :: (Convention) -> (HappyAbsSyn ) +happyIn12 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap12 x) +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> HappyWrap12 +happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut12 #-} +newtype HappyWrap13 = HappyWrap13 (CmmParse ()) +happyIn13 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn13 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap13 x) +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> HappyWrap13 +happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut13 #-} +newtype HappyWrap14 = HappyWrap14 (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) +happyIn14 :: (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) -> (HappyAbsSyn ) +happyIn14 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap14 x) +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> HappyWrap14 +happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut14 #-} +newtype HappyWrap15 = HappyWrap15 (CmmParse ()) +happyIn15 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn15 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap15 x) +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> HappyWrap15 +happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut15 #-} +newtype HappyWrap16 = HappyWrap16 (CmmParse ()) +happyIn16 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap16 x) +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> HappyWrap16 +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +newtype HappyWrap17 = HappyWrap17 ([(FastString, CLabel)]) +happyIn17 :: ([(FastString, CLabel)]) -> (HappyAbsSyn ) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap17 x) +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> HappyWrap17 +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +newtype HappyWrap18 = HappyWrap18 ((FastString, CLabel)) +happyIn18 :: ((FastString, CLabel)) -> (HappyAbsSyn ) +happyIn18 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap18 x) +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> HappyWrap18 +happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut18 #-} +newtype HappyWrap19 = HappyWrap19 ([FastString]) +happyIn19 :: ([FastString]) -> (HappyAbsSyn ) +happyIn19 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap19 x) +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> HappyWrap19 +happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut19 #-} +newtype HappyWrap20 = HappyWrap20 (CmmParse ()) +happyIn20 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn20 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap20 x) +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> HappyWrap20 +happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut20 #-} +newtype HappyWrap21 = HappyWrap21 (CmmParse [(GlobalReg, Maybe CmmExpr)]) +happyIn21 :: (CmmParse [(GlobalReg, Maybe CmmExpr)]) -> (HappyAbsSyn ) +happyIn21 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap21 x) +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> HappyWrap21 +happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut21 #-} +newtype HappyWrap22 = HappyWrap22 (CmmParse MemoryOrdering) +happyIn22 :: (CmmParse MemoryOrdering) -> (HappyAbsSyn ) +happyIn22 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap22 x) +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> HappyWrap22 +happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut22 #-} +newtype HappyWrap23 = HappyWrap23 (CmmParse (Maybe CmmExpr)) +happyIn23 :: (CmmParse (Maybe CmmExpr)) -> (HappyAbsSyn ) +happyIn23 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap23 x) +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn ) -> HappyWrap23 +happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut23 #-} +newtype HappyWrap24 = HappyWrap24 (CmmParse CmmExpr) +happyIn24 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn24 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap24 x) +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn ) -> HappyWrap24 +happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut24 #-} +newtype HappyWrap25 = HappyWrap25 (CmmReturnInfo) +happyIn25 :: (CmmReturnInfo) -> (HappyAbsSyn ) +happyIn25 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap25 x) +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn ) -> HappyWrap25 +happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut25 #-} +newtype HappyWrap26 = HappyWrap26 (CmmParse BoolExpr) +happyIn26 :: (CmmParse BoolExpr) -> (HappyAbsSyn ) +happyIn26 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap26 x) +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn ) -> HappyWrap26 +happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut26 #-} +newtype HappyWrap27 = HappyWrap27 (CmmParse BoolExpr) +happyIn27 :: (CmmParse BoolExpr) -> (HappyAbsSyn ) +happyIn27 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap27 x) +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn ) -> HappyWrap27 +happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut27 #-} +newtype HappyWrap28 = HappyWrap28 (Safety) +happyIn28 :: (Safety) -> (HappyAbsSyn ) +happyIn28 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap28 x) +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn ) -> HappyWrap28 +happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut28 #-} +newtype HappyWrap29 = HappyWrap29 ([GlobalRegUse]) +happyIn29 :: ([GlobalRegUse]) -> (HappyAbsSyn ) +happyIn29 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap29 x) +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn ) -> HappyWrap29 +happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut29 #-} +newtype HappyWrap30 = HappyWrap30 ([GlobalRegUse]) +happyIn30 :: ([GlobalRegUse]) -> (HappyAbsSyn ) +happyIn30 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap30 x) +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn ) -> HappyWrap30 +happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut30 #-} +newtype HappyWrap31 = HappyWrap31 (Maybe (Integer,Integer)) +happyIn31 :: (Maybe (Integer,Integer)) -> (HappyAbsSyn ) +happyIn31 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap31 x) +{-# INLINE happyIn31 #-} +happyOut31 :: (HappyAbsSyn ) -> HappyWrap31 +happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut31 #-} +newtype HappyWrap32 = HappyWrap32 ([CmmParse ([Integer],Either BlockId (CmmParse ()))]) +happyIn32 :: ([CmmParse ([Integer],Either BlockId (CmmParse ()))]) -> (HappyAbsSyn ) +happyIn32 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap32 x) +{-# INLINE happyIn32 #-} +happyOut32 :: (HappyAbsSyn ) -> HappyWrap32 +happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut32 #-} +newtype HappyWrap33 = HappyWrap33 (CmmParse ([Integer],Either BlockId (CmmParse ()))) +happyIn33 :: (CmmParse ([Integer],Either BlockId (CmmParse ()))) -> (HappyAbsSyn ) +happyIn33 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap33 x) +{-# INLINE happyIn33 #-} +happyOut33 :: (HappyAbsSyn ) -> HappyWrap33 +happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut33 #-} +newtype HappyWrap34 = HappyWrap34 (CmmParse (Either BlockId (CmmParse ()))) +happyIn34 :: (CmmParse (Either BlockId (CmmParse ()))) -> (HappyAbsSyn ) +happyIn34 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap34 x) +{-# INLINE happyIn34 #-} +happyOut34 :: (HappyAbsSyn ) -> HappyWrap34 +happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut34 #-} +newtype HappyWrap35 = HappyWrap35 ([Integer]) +happyIn35 :: ([Integer]) -> (HappyAbsSyn ) +happyIn35 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap35 x) +{-# INLINE happyIn35 #-} +happyOut35 :: (HappyAbsSyn ) -> HappyWrap35 +happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut35 #-} +newtype HappyWrap36 = HappyWrap36 (Maybe (CmmParse ())) +happyIn36 :: (Maybe (CmmParse ())) -> (HappyAbsSyn ) +happyIn36 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap36 x) +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn ) -> HappyWrap36 +happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut36 #-} +newtype HappyWrap37 = HappyWrap37 (CmmParse ()) +happyIn37 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn37 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap37 x) +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn ) -> HappyWrap37 +happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut37 #-} +newtype HappyWrap38 = HappyWrap38 (Maybe Bool) +happyIn38 :: (Maybe Bool) -> (HappyAbsSyn ) +happyIn38 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap38 x) +{-# INLINE happyIn38 #-} +happyOut38 :: (HappyAbsSyn ) -> HappyWrap38 +happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut38 #-} +newtype HappyWrap39 = HappyWrap39 (CmmParse CmmExpr) +happyIn39 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn39 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap39 x) +{-# INLINE happyIn39 #-} +happyOut39 :: (HappyAbsSyn ) -> HappyWrap39 +happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut39 #-} +newtype HappyWrap40 = HappyWrap40 (CmmParse CmmExpr) +happyIn40 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn40 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap40 x) +{-# INLINE happyIn40 #-} +happyOut40 :: (HappyAbsSyn ) -> HappyWrap40 +happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut40 #-} +newtype HappyWrap41 = HappyWrap41 (CmmType) +happyIn41 :: (CmmType) -> (HappyAbsSyn ) +happyIn41 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap41 x) +{-# INLINE happyIn41 #-} +happyOut41 :: (HappyAbsSyn ) -> HappyWrap41 +happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut41 #-} +newtype HappyWrap42 = HappyWrap42 ([CmmParse (CmmExpr, ForeignHint)]) +happyIn42 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn ) +happyIn42 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap42 x) +{-# INLINE happyIn42 #-} +happyOut42 :: (HappyAbsSyn ) -> HappyWrap42 +happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut42 #-} +newtype HappyWrap43 = HappyWrap43 ([CmmParse (CmmExpr, ForeignHint)]) +happyIn43 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn ) +happyIn43 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap43 x) +{-# INLINE happyIn43 #-} +happyOut43 :: (HappyAbsSyn ) -> HappyWrap43 +happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut43 #-} +newtype HappyWrap44 = HappyWrap44 (CmmParse (CmmExpr, ForeignHint)) +happyIn44 :: (CmmParse (CmmExpr, ForeignHint)) -> (HappyAbsSyn ) +happyIn44 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap44 x) +{-# INLINE happyIn44 #-} +happyOut44 :: (HappyAbsSyn ) -> HappyWrap44 +happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut44 #-} +newtype HappyWrap45 = HappyWrap45 ([CmmParse CmmExpr]) +happyIn45 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) +happyIn45 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap45 x) +{-# INLINE happyIn45 #-} +happyOut45 :: (HappyAbsSyn ) -> HappyWrap45 +happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut45 #-} +newtype HappyWrap46 = HappyWrap46 ([CmmParse CmmExpr]) +happyIn46 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) +happyIn46 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap46 x) +{-# INLINE happyIn46 #-} +happyOut46 :: (HappyAbsSyn ) -> HappyWrap46 +happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut46 #-} +newtype HappyWrap47 = HappyWrap47 (CmmParse CmmExpr) +happyIn47 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn47 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap47 x) +{-# INLINE happyIn47 #-} +happyOut47 :: (HappyAbsSyn ) -> HappyWrap47 +happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut47 #-} +newtype HappyWrap48 = HappyWrap48 ([CmmParse (LocalReg, ForeignHint)]) +happyIn48 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn ) +happyIn48 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap48 x) +{-# INLINE happyIn48 #-} +happyOut48 :: (HappyAbsSyn ) -> HappyWrap48 +happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut48 #-} +newtype HappyWrap49 = HappyWrap49 ([CmmParse (LocalReg, ForeignHint)]) +happyIn49 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn ) +happyIn49 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap49 x) +{-# INLINE happyIn49 #-} +happyOut49 :: (HappyAbsSyn ) -> HappyWrap49 +happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut49 #-} +newtype HappyWrap50 = HappyWrap50 (CmmParse (LocalReg, ForeignHint)) +happyIn50 :: (CmmParse (LocalReg, ForeignHint)) -> (HappyAbsSyn ) +happyIn50 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap50 x) +{-# INLINE happyIn50 #-} +happyOut50 :: (HappyAbsSyn ) -> HappyWrap50 +happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut50 #-} +newtype HappyWrap51 = HappyWrap51 (CmmParse LocalReg) +happyIn51 :: (CmmParse LocalReg) -> (HappyAbsSyn ) +happyIn51 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap51 x) +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn ) -> HappyWrap51 +happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut51 #-} +newtype HappyWrap52 = HappyWrap52 (CmmParse CmmReg) +happyIn52 :: (CmmParse CmmReg) -> (HappyAbsSyn ) +happyIn52 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap52 x) +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn ) -> HappyWrap52 +happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut52 #-} +newtype HappyWrap53 = HappyWrap53 (Maybe [CmmParse LocalReg]) +happyIn53 :: (Maybe [CmmParse LocalReg]) -> (HappyAbsSyn ) +happyIn53 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap53 x) +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn ) -> HappyWrap53 +happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut53 #-} +newtype HappyWrap54 = HappyWrap54 ([CmmParse LocalReg]) +happyIn54 :: ([CmmParse LocalReg]) -> (HappyAbsSyn ) +happyIn54 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap54 x) +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn ) -> HappyWrap54 +happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut54 #-} +newtype HappyWrap55 = HappyWrap55 ([CmmParse LocalReg]) +happyIn55 :: ([CmmParse LocalReg]) -> (HappyAbsSyn ) +happyIn55 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap55 x) +{-# INLINE happyIn55 #-} +happyOut55 :: (HappyAbsSyn ) -> HappyWrap55 +happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut55 #-} +newtype HappyWrap56 = HappyWrap56 (CmmParse LocalReg) +happyIn56 :: (CmmParse LocalReg) -> (HappyAbsSyn ) +happyIn56 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap56 x) +{-# INLINE happyIn56 #-} +happyOut56 :: (HappyAbsSyn ) -> HappyWrap56 +happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut56 #-} +newtype HappyWrap57 = HappyWrap57 (CmmType) +happyIn57 :: (CmmType) -> (HappyAbsSyn ) +happyIn57 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap57 x) +{-# INLINE happyIn57 #-} +happyOut57 :: (HappyAbsSyn ) -> HappyWrap57 +happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut57 #-} +newtype HappyWrap58 = HappyWrap58 (CmmType) +happyIn58 :: (CmmType) -> (HappyAbsSyn ) +happyIn58 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap58 x) +{-# INLINE happyIn58 #-} +happyOut58 :: (HappyAbsSyn ) -> HappyWrap58 +happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut58 #-} +happyInTok :: (Located CmmToken) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> (Located CmmToken) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyExpList :: HappyAddr +happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x06\x20\xf8\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x06\x20\xf8\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x08\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xe1\x7f\xf8\x01\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\xc0\x03\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x08\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x0f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x07\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x7f\xf8\x01\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +{-# NOINLINE happyExpListPerState #-} +happyExpListPerState st = + token_strs_expected + where token_strs = ["error","%dummy","%start_cmmParse","cmm","cmmtop","cmmdata","data_label","statics","static","lits","cmmproc","maybe_conv","maybe_body","info","body","decl","importNames","importName","names","stmt","unwind_regs","mem_ordering","expr_or_unknown","foreignLabel","opt_never_returns","bool_expr","bool_op","safety","vols","globals","maybe_range","arms","arm","arm_body","ints","default","else","cond_likely","expr","expr0","maybe_ty","cmm_hint_exprs0","cmm_hint_exprs","cmm_hint_expr","exprs0","exprs","reg","foreign_results","foreign_formals","foreign_formal","local_lreg","lreg","maybe_formals","formals0","formals","formal","type","typenot8","':'","';'","'{'","'}'","'['","']'","'('","')'","'='","'`'","'~'","'/'","'*'","'%'","'-'","'+'","'&'","'^'","'|'","'>'","'<'","','","'!'","'..'","'::'","'>>'","'<<'","'>='","'<='","'=='","'!='","'&&'","'||'","'True'","'False'","'likely'","'relaxed'","'acquire'","'release'","'seq_cst'","'CLOSURE'","'INFO_TABLE'","'INFO_TABLE_RET'","'INFO_TABLE_FUN'","'INFO_TABLE_CONSTR'","'INFO_TABLE_SELECTOR'","'else'","'export'","'section'","'goto'","'if'","'call'","'jump'","'foreign'","'never'","'prim'","'reserve'","'return'","'returns'","'import'","'switch'","'case'","'default'","'push'","'unwind'","'bits8'","'bits16'","'bits32'","'bits64'","'vec128'","'vec256'","'vec512'","'float32'","'float64'","'gcptr'","GLOBALREG","NAME","STRING","INT","FLOAT","GP_ARG_REGS","SCALAR_ARG_REGS","V16_ARG_REGS","V32_ARG_REGS","V64_ARG_REGS","%eof"] + bit_start = st Prelude.* 144 + bit_end = (st Prelude.+ 1) Prelude.* 144 + read_bit = readArrayBit happyExpList + bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] + bits_indexed = Prelude.zip bits [0..143] + token_strs_expected = Prelude.concatMap f bits_indexed + f (Prelude.False, _) = [] + f (Prelude.True, nr) = [token_strs Prelude.!! nr] + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x72\x01\x00\x00\xae\xff\x72\x01\x00\x00\x00\x00\xec\xff\x00\x00\xe7\xff\x00\x00\x3c\x00\x40\x00\x4c\x00\x4f\x00\x64\x00\x73\x00\x31\x00\x33\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xa8\x00\x57\x00\x00\x00\x74\x00\xd3\x00\xd8\x00\xed\x00\xd1\x00\xdb\x00\xdd\x00\xdf\x00\xe4\x00\xe6\x00\x37\x01\x34\x01\x00\x00\x00\x00\xa9\x00\xe6\x04\x00\x00\x39\x01\x3d\x01\x43\x01\x45\x01\x48\x01\x4c\x01\x19\x01\x00\x00\x1d\x01\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x95\x01\x6c\x01\x00\x00\x24\x01\x26\x01\x2d\x01\x31\x01\x33\x01\x40\x01\x69\x01\x00\x00\x74\x01\x46\x01\x00\x00\x00\x00\x50\x00\x93\x01\x50\x00\x50\x00\xe6\x04\x47\x00\x8f\x01\xfd\xff\x00\x00\xd9\x04\x00\x00\x00\x00\x00\x00\x00\x00\x54\x01\xa2\x00\xb1\x00\xb1\x00\xb1\x00\xa3\x01\xa6\x01\xa5\x01\x61\x01\x00\x00\x3f\x00\x00\x00\xe6\x04\x00\x00\x99\x01\x9b\x01\x44\x00\xb1\x01\xb8\x01\xb9\x01\x00\x00\xd2\x01\x95\x01\x1a\x00\xe0\x01\xdf\x01\xe2\x01\x0c\x00\x9e\x01\x9f\x01\x1a\x02\xde\x01\x00\x00\x10\x00\x00\x00\xb1\x00\xb1\x00\xa2\x01\xb1\x00\x00\x00\x00\x00\x00\x00\xd1\x01\xd1\x01\x00\x00\x00\x00\xa7\x01\xa8\x01\xae\x01\x00\x00\xe6\x04\xaf\x01\xed\x01\xb1\x00\x00\x00\x00\x00\xb1\x00\xf0\x01\xf6\x01\xb1\x00\xb1\x00\xb7\x01\xb1\x00\x67\x03\xfc\xff\x1f\x03\x38\x00\x00\x00\xa3\x03\xa2\x00\xa2\x00\xfe\x01\xff\x01\xf4\x01\x00\x00\x07\x02\x00\x00\xc9\x01\xb1\x00\x80\x00\xca\x01\x09\x02\x18\x02\x00\x00\x00\x00\x00\x00\xb1\x00\xd4\x01\xd5\x01\xe6\x04\x2e\x02\x84\x02\x00\x00\x15\x02\x65\x00\x1c\x02\x00\x00\x00\x00\x8e\x00\x29\x02\x50\x03\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x03\x00\x0e\x02\xa2\x00\xa2\x00\xb1\x00\x31\x02\xff\xff\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x7b\x03\x3d\x02\x00\x00\x2f\x02\x6a\x02\x3e\x02\xca\x00\x00\x00\x51\x02\x8f\x03\x58\x02\x45\x02\x64\x02\x6b\x02\x6c\x02\x6d\x02\x00\x00\xe6\x04\x00\x00\x12\x00\x67\x02\x00\x00\x50\x03\xb1\x00\x7b\x02\x95\x02\x22\x02\x00\x00\x96\x02\x85\x02\x4f\x02\x9f\x02\xa4\x02\xa5\x02\xa0\x02\xa7\x02\xaa\x02\xb1\x00\xb1\x00\x9e\x02\x00\x00\xb1\x00\x00\x00\x68\x02\x66\x02\x70\x02\x00\x00\x71\x02\x00\x00\x00\x00\xb5\x02\xab\x02\xa3\x03\x00\x00\xdc\x00\x90\x02\x73\x02\xc1\x02\xb1\x00\xdc\x00\x00\x00\xc7\x02\xca\x02\x00\x00\xbb\x02\x00\x00\xd1\x02\xc2\x00\xba\x02\xda\x02\x50\x00\x8f\x02\xb7\x03\xb7\x03\xb7\x03\xb7\x03\x6b\x01\x6b\x01\xb7\x03\xb7\x03\x61\x00\x98\x01\xb6\x01\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x02\xdf\x02\x00\x00\xe4\x02\xe3\x02\x00\x00\xed\x02\xb8\x02\xe2\x02\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\xef\x02\xe3\x00\xf3\x02\xb6\x02\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\xf0\x02\xc4\x02\xb9\x02\xbe\x02\x00\x00\xc2\x02\x00\x00\xee\x02\xf9\x02\xfa\x02\xfb\x02\xfd\x02\x00\x00\xd2\x02\xec\x02\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x02\xcf\x02\xd9\x02\xdb\x02\x00\x00\x1c\x03\x09\x03\x00\x00\x24\x03\x29\x03\x00\x00\x00\x00\xb1\x00\x00\x00\x00\x00\x2d\x03\x2e\x03\x08\x03\x38\x03\x42\x02\x06\x03\x1e\x00\x30\x03\x00\x00\x2a\x03\x39\x03\xb1\x00\x56\x02\x40\x03\xb1\x00\xf5\x02\x00\x00\x4c\x03\x00\x00\xb1\x00\x00\x00\x4d\x03\x00\x00\x00\x00\x47\x03\x4e\x03\x00\x00\x0a\x03\x04\x00\x44\x03\x45\x03\x51\x03\x5e\x03\x00\x00\x1a\x03\x1b\x03\x23\x03\x00\x00\x50\x00\x25\x03\x00\x00\x50\x00\x7c\x03\x50\x00\x75\x03\x00\x00\x48\x03\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x03\x57\x03\x91\x03\x90\x03\x00\x00\xa2\x03\xa5\x03\xa4\x03\xb1\x03\xa6\x03\xb8\x03\x6c\x03\x80\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x03\xb3\x03\x00\x00\x81\x03\xc5\x03\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x1b\x01\x00\x00\x00\x00\x1f\x01\x00\x00\x00\x00\xda\x03\x00\x00\xdc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x03\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x03\x00\x00\x00\x00\xe5\x03\x97\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x03\x00\x00\xf3\x03\x00\x00\x00\x00\xfd\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x22\x01\x2a\x01\xee\x00\x00\x00\x00\x00\xea\x03\x00\x00\x05\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x01\x7f\x00\x1c\x04\x25\x04\x00\x00\xe6\x03\x00\x00\xef\x03\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\xfc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x2b\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x04\x34\x04\x00\x00\x3a\x04\x00\x00\x00\x00\x00\x00\xde\x03\xdf\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x02\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\xea\x01\x00\x00\x00\x00\xba\x03\x49\x04\x00\x00\xbd\x03\x00\x00\xec\x03\x00\x00\xee\x03\x00\x00\x00\x00\xcd\x01\xd6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x03\x4e\x04\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x04\x00\x00\xf9\x03\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x04\x63\x04\x66\x04\x6c\x04\x72\x04\x7b\x04\x80\x04\x89\x04\x8f\x04\x95\x04\x98\x04\x9e\x04\xa4\x04\xad\x04\xb2\x04\xbb\x04\x00\x00\x00\x00\xe5\x01\xee\x01\xd1\x03\x00\x00\xfd\x03\xd4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x01\x00\x00\x00\x00\x12\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x04\xca\x04\x00\x00\x00\x00\xe8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x04\x13\x01\x00\x00\x00\x00\x17\x04\x16\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x03\xb4\x03\xd0\x04\xd6\x04\xdf\x04\x00\x00\x00\x00\x00\x00\x00\x00\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x62\x01\x06\x04\x00\x00\x15\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x04\x00\x00\x00\x00\x08\x04\x0f\x04\x00\x00\x00\x00\x00\x00\x0e\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x04\x10\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x01\x00\x00\x00\x00\x5c\x01\x00\x00\x64\x01\x00\x00\x00\x00\x21\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int# +happyAdjustOffset off = off + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfb\xff\xfc\xff\xeb\xff\xfa\xff\x00\x00\x53\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\xff\x52\xff\x51\xff\x50\xff\x4f\xff\x4e\xff\x4d\xff\x4c\xff\x4b\xff\x4a\xff\xe7\xff\x00\x00\xda\xff\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\xd5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\xff\xea\xff\xfd\xff\x00\x00\x5a\xff\xdd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xff\x00\x00\xd6\xff\xd7\xff\x00\x00\xdc\xff\xd9\xff\xf6\xff\x00\x00\xd4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\xff\x57\xff\x00\x00\xec\xff\xe9\xff\xe0\xff\x00\x00\xe0\xff\xe0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xd3\xff\x00\x00\xbb\xff\xb9\xff\xba\xff\xb8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\xff\x00\x00\x00\x00\x5d\xff\x5e\xff\x55\xff\x58\xff\x5b\xff\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\xf6\xff\x00\x00\x53\xff\x00\x00\x54\xff\x00\x00\x00\x00\x00\x00\x00\x00\x7e\xff\x7a\xff\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x67\xff\x68\xff\x7b\xff\x74\xff\x74\xff\xf5\xff\xf8\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x5a\xff\x00\x00\x00\x00\x00\x00\x56\xff\xd2\xff\x6c\xff\x00\x00\x00\x00\x6c\xff\x00\x00\x00\x00\x6c\xff\x00\x00\x00\x00\x00\x00\x92\xff\xb2\xff\xb1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x64\xff\x61\xff\x00\x00\x5f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xff\xdf\xff\xe8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\xff\x00\x00\x63\xff\x00\x00\xc9\xff\xae\xff\x00\x00\xb2\xff\xb1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\xff\x00\x00\x00\x00\x6c\xff\xa9\xff\xa8\xff\xa7\xff\xa6\xff\xa5\xff\x00\x00\x6a\xff\x00\x00\x6b\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbe\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\xff\x00\x00\x7d\xff\x80\xff\x00\x00\x81\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\xff\x6c\xff\x73\xff\x00\x00\x00\x00\x00\x00\xe1\xff\x00\x00\xf9\xff\xed\xff\x00\x00\xbc\xff\xb6\xff\xb7\xff\x00\x00\x9f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x5e\xff\x00\x00\x00\x00\xaa\xff\xa3\xff\xc7\xff\x00\x00\xaf\xff\xb0\xff\x00\x00\xe0\xff\x00\x00\x83\xff\x82\xff\x85\xff\x87\xff\x8b\xff\x8c\xff\x84\xff\x86\xff\x88\xff\x89\xff\x8a\xff\x8d\xff\x8e\xff\x8f\xff\x90\xff\x91\xff\xad\xff\x65\xff\x62\xff\x00\x00\x00\x00\xd1\xff\x00\x00\x00\x00\xb5\xff\x00\x00\x00\x00\x00\x00\x6c\xff\x72\xff\x00\x00\x00\x00\x00\x00\xc2\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa4\xff\x00\x00\xbf\xff\x69\xff\xc8\xff\x00\x00\x97\xff\x9f\xff\x00\x00\xc0\xff\x00\x00\xcb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\xff\x00\x00\x00\x00\x00\x00\xf0\xff\xef\xff\xf2\xff\xf1\xff\x7f\xff\x79\xff\x78\xff\x76\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xff\x00\x00\x9a\xff\x9e\xff\x00\x00\x00\x00\xa1\xff\xc6\xff\x6c\xff\xa2\xff\xc4\xff\x00\x00\x00\x00\x96\xff\x00\x00\x00\x00\x00\x00\x6e\xff\x00\x00\x71\xff\x70\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\xff\x6d\xff\x00\x00\xce\xff\x6c\xff\xc1\xff\x00\x00\x93\xff\x94\xff\x00\x00\x00\x00\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\x9d\xff\xe0\xff\x00\x00\x99\xff\xe0\xff\x00\x00\xe0\xff\x00\x00\xd0\xff\xb4\xff\xab\xff\x6f\xff\xcc\xff\xcf\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\x9c\xff\x9b\xff\x98\xff\x95\xff\xc3\xff\xb3\xff\xcd\xff\x00\x00\x00\x00\xe4\xff\x00\x00\x00\x00\xe5\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x05\x00\x05\x00\x07\x00\x56\x00\x06\x00\x03\x00\x03\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x06\x00\x04\x00\x05\x00\x05\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x02\x00\x29\x00\x0c\x00\x0d\x00\x0e\x00\x07\x00\x12\x00\x04\x00\x05\x00\x0b\x00\x3a\x00\x17\x00\x0e\x00\x0f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4d\x00\x32\x00\x32\x00\x24\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x2b\x00\x07\x00\x01\x00\x4d\x00\x4e\x00\x07\x00\x35\x00\x36\x00\x07\x00\x07\x00\x35\x00\x36\x00\x4d\x00\x4c\x00\x08\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x02\x00\x07\x00\x35\x00\x36\x00\x07\x00\x07\x00\x20\x00\x21\x00\x16\x00\x4f\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x07\x00\x4e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x02\x00\x25\x00\x26\x00\x27\x00\x28\x00\x07\x00\x07\x00\x1a\x00\x1b\x00\x36\x00\x4d\x00\x38\x00\x30\x00\x4e\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x07\x00\x38\x00\x39\x00\x3a\x00\x0b\x00\x3c\x00\x3d\x00\x0e\x00\x0f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x33\x00\x34\x00\x35\x00\x36\x00\x23\x00\x24\x00\x4d\x00\x25\x00\x26\x00\x27\x00\x28\x00\x07\x00\x2b\x00\x02\x00\x03\x00\x0b\x00\x20\x00\x21\x00\x0e\x00\x0f\x00\x4d\x00\x4e\x00\x35\x00\x36\x00\x0b\x00\x0c\x00\x07\x00\x17\x00\x02\x00\x10\x00\x0b\x00\x12\x00\x16\x00\x0e\x00\x0f\x00\x4d\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x07\x00\x2d\x00\x2e\x00\x2f\x00\x0b\x00\x03\x00\x2c\x00\x0e\x00\x0f\x00\x02\x00\x30\x00\x4c\x00\x4d\x00\x02\x00\x03\x00\x35\x00\x36\x00\x20\x00\x21\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x07\x00\x16\x00\x3a\x00\x22\x00\x23\x00\x0d\x00\x0e\x00\x0e\x00\x0d\x00\x0e\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x00\x00\x01\x00\x02\x00\x4d\x00\x00\x00\x01\x00\x02\x00\x07\x00\x35\x00\x36\x00\x0a\x00\x07\x00\x0c\x00\x4d\x00\x0a\x00\x4d\x00\x0c\x00\x4d\x00\x0b\x00\x0c\x00\x1c\x00\x1d\x00\x4d\x00\x10\x00\x4d\x00\x12\x00\x0b\x00\x0c\x00\x35\x00\x36\x00\x02\x00\x10\x00\x07\x00\x12\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x35\x00\x36\x00\x2c\x00\x16\x00\x35\x00\x36\x00\x30\x00\x16\x00\x35\x00\x36\x00\x2c\x00\x35\x00\x36\x00\x16\x00\x30\x00\x16\x00\x0b\x00\x0c\x00\x16\x00\x35\x00\x36\x00\x10\x00\x16\x00\x12\x00\x0b\x00\x0c\x00\x4d\x00\x0b\x00\x0c\x00\x10\x00\x4d\x00\x12\x00\x10\x00\x01\x00\x12\x00\x0b\x00\x0c\x00\x08\x00\x12\x00\x4f\x00\x10\x00\x4f\x00\x12\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x4f\x00\x2c\x00\x1c\x00\x1d\x00\x4f\x00\x30\x00\x4f\x00\x23\x00\x24\x00\x2c\x00\x35\x00\x36\x00\x2c\x00\x30\x00\x16\x00\x2b\x00\x30\x00\x4d\x00\x35\x00\x36\x00\x2c\x00\x35\x00\x36\x00\x4d\x00\x30\x00\x35\x00\x36\x00\x04\x00\x09\x00\x35\x00\x36\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x4d\x00\x30\x00\x31\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x05\x00\x07\x00\x4c\x00\x3c\x00\x16\x00\x13\x00\x16\x00\x1a\x00\x1b\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x29\x00\x4d\x00\x23\x00\x24\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x16\x00\x2b\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x35\x00\x36\x00\x16\x00\x17\x00\x04\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x23\x00\x24\x00\x16\x00\x17\x00\x05\x00\x07\x00\x05\x00\x0a\x00\x2b\x00\x19\x00\x4d\x00\x16\x00\x17\x00\x4f\x00\x4d\x00\x23\x00\x24\x00\x02\x00\x35\x00\x36\x00\x08\x00\x4f\x00\x4f\x00\x2b\x00\x23\x00\x24\x00\x16\x00\x17\x00\x4f\x00\x4f\x00\x09\x00\x02\x00\x2b\x00\x35\x00\x36\x00\x16\x00\x17\x00\x4f\x00\x08\x00\x23\x00\x24\x00\x16\x00\x35\x00\x36\x00\x23\x00\x24\x00\x08\x00\x2b\x00\x23\x00\x24\x00\x29\x00\x2a\x00\x2b\x00\x4d\x00\x0e\x00\x4e\x00\x2b\x00\x35\x00\x36\x00\x02\x00\x05\x00\x09\x00\x35\x00\x36\x00\x4d\x00\x4d\x00\x35\x00\x36\x00\x09\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x24\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x08\x00\x18\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x02\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x03\x00\x07\x00\x4d\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x05\x00\x16\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x05\x00\x16\x00\x06\x00\x4e\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x06\x00\x02\x00\x02\x00\x08\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x0a\x00\x4f\x00\x4e\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x4f\x00\x4f\x00\x16\x00\x4f\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x3e\x00\x08\x00\x06\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x08\x00\x20\x00\x01\x00\x4d\x00\x34\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x09\x00\x05\x00\x07\x00\x09\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x04\x00\x07\x00\x02\x00\x06\x00\x3e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4c\x00\x3f\x00\x16\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x4f\x00\x4c\x00\x16\x00\x16\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4e\x00\x01\x00\x4f\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x4e\x00\x04\x00\x4e\x00\x01\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x08\x00\x2f\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x16\x00\x08\x00\x02\x00\x4e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x03\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x4f\x00\x16\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x16\x00\x4e\x00\x4e\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x09\x00\x4e\x00\x4d\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x02\x00\x37\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x3b\x00\x02\x00\x04\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x04\x00\x02\x00\x04\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x4e\x00\x08\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x16\x00\x4f\x00\x4f\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x23\x00\x24\x00\x16\x00\x26\x00\x27\x00\x28\x00\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\x08\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x35\x00\x36\x00\x0f\x00\x0f\x00\x31\x00\x09\x00\x35\x00\x36\x00\x0f\x00\x35\x00\x36\x00\x23\x00\x24\x00\x03\x00\x23\x00\x24\x00\x0f\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x11\x00\x1b\x00\x06\x00\x25\x00\x25\x00\x19\x00\x35\x00\x36\x00\x2f\x00\x35\x00\x36\x00\x23\x00\x24\x00\x14\x00\x23\x00\x24\x00\x22\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x1a\x00\x06\x00\x30\x00\x06\x00\x1a\x00\x09\x00\x35\x00\x36\x00\x09\x00\x35\x00\x36\x00\x23\x00\x24\x00\x20\x00\x1f\x00\x11\x00\x18\x00\x29\x00\x2a\x00\x2b\x00\x23\x00\x24\x00\x21\x00\x1e\x00\x27\x00\x28\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\x15\x00\x29\x00\x2a\x00\x2b\x00\x23\x00\x24\x00\x1f\x00\x35\x00\x36\x00\x23\x00\x24\x00\x2a\x00\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\x35\x00\x36\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xff\xff\x4d\x00\x4e\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\xda\x00\xad\x00\xdb\x00\xff\xff\x21\x01\x28\x01\xa2\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x00\x01\x73\x00\x74\x00\xf9\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x81\x00\x21\x00\xc4\x00\xc5\x00\xc6\x00\x82\x00\xfa\x00\x8a\x00\x74\x00\x83\x00\x2f\x00\xfb\x00\x84\x00\x85\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x26\x00\x29\x01\xa3\x01\x68\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x7e\x00\xd5\x00\x96\x00\x22\x00\x23\x00\x2c\x00\x75\x00\x76\x00\x97\x00\x2b\x00\x7f\x00\x09\x00\x26\x00\x22\x01\x90\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\x59\x00\x2a\x00\x75\x00\x76\x00\x29\x00\x5a\x00\xd6\x00\xd7\x00\x91\x00\x01\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x28\x00\x8c\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x78\x01\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x79\x01\x27\x00\xce\x00\xcf\x00\xaf\x00\x26\x00\xb0\x00\x11\x00\x24\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x66\xff\x82\x00\x66\xff\x63\x00\x64\x00\x83\x00\x13\x00\x65\x00\x84\x00\x85\x00\x66\x00\x67\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x68\x00\x69\x00\x94\x00\x4c\x00\x4d\x00\x09\x00\x9f\x00\x7d\x00\x3e\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xa4\x00\x7e\x00\x50\x00\x51\x00\x83\x00\xd6\x00\xd7\x00\x84\x00\x85\x00\xab\x00\xac\x00\x7f\x00\x09\x00\x51\x00\x52\x00\x82\x00\xa5\x00\x40\x00\x53\x00\x83\x00\x54\x00\x3f\x00\x84\x00\x85\x00\x3d\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x82\x00\x3b\x01\xa7\x00\xa8\x00\x83\x00\x3c\x00\x55\x00\x84\x00\x85\x00\x3b\x00\x56\x00\x68\x00\x1e\x01\x50\x00\x51\x00\x57\x00\x09\x00\xd6\x00\xd7\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x82\x00\x3a\x00\x17\x01\x7c\x01\x7d\x01\x1e\x00\x1f\x00\x84\x00\x40\x00\x1f\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x02\x00\x03\x00\x04\x00\x39\x00\x2f\x00\x03\x00\x04\x00\x05\x00\xb0\x00\x09\x00\x06\x00\x05\x00\x07\x00\x38\x00\x06\x00\x37\x00\x07\x00\x36\x00\xb2\x00\x52\x00\x55\x01\x56\x01\x35\x00\x53\x00\x34\x00\x54\x00\xb1\x00\x52\x00\x3f\x01\x09\x00\x33\x00\x53\x00\x32\x00\x54\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x0b\x01\x09\x00\x55\x00\x4a\x00\x08\x00\x09\x00\x56\x00\x49\x00\x08\x00\x09\x00\x55\x00\x57\x00\x09\x00\x48\x00\x56\x00\x47\x00\x4b\x01\x52\x00\x46\x00\x57\x00\x09\x00\x53\x00\x45\x00\x54\x00\xb5\x01\x52\x00\x26\x00\xb3\x01\x52\x00\x53\x00\x43\x00\x54\x00\x53\x00\x73\x00\x54\x00\xb1\x01\x52\x00\x6c\x00\xb7\x00\x72\x00\x53\x00\x71\x00\x54\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x70\x00\x55\x00\x73\x01\x56\x01\x6f\x00\x56\x00\x6e\x00\xb8\x00\x7d\x00\x55\x00\x57\x00\x09\x00\x55\x00\x56\x00\x6b\x00\x7e\x00\x56\x00\x6d\x00\x57\x00\x09\x00\x55\x00\x57\x00\x09\x00\x6a\x00\x56\x00\x7f\x00\x09\x00\xb4\x00\xae\x00\x57\x00\x09\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\xa6\x00\x11\x00\x12\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\x9d\x00\x9c\x00\x9a\x00\x99\x00\x13\x00\x94\x00\x14\x01\x92\x00\xce\x00\xcf\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x78\x00\x1e\x00\x15\x01\x7d\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x8f\x00\x7e\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\x8e\x00\x8d\x00\xce\x00\xcf\x00\x7f\x00\x09\x00\xa0\x00\xa1\x00\x8c\x00\x79\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xa2\x00\x7d\x00\xc0\x00\xc1\x00\x7c\x00\x7b\x00\x7a\x00\xfc\x00\x7e\x00\xf3\x00\xff\x00\xbf\x00\xa1\x00\xfe\x00\xf6\x00\xc2\x00\x7d\x00\xe9\x00\x7f\x00\x09\x00\xec\x00\xf1\x00\xf0\x00\x7e\x00\xa2\x00\x7d\x00\x25\x01\xa1\x00\xef\x00\xed\x00\xe8\x00\xbf\x00\x7e\x00\x7f\x00\x09\x00\x24\x01\xa1\x00\xe5\x00\xbe\x00\xa2\x00\x7d\x00\xbd\x00\x7f\x00\x09\x00\xe1\x00\x7d\x00\xbc\x00\x7e\x00\xa2\x00\x7d\x00\xe9\x00\xe3\x00\x7e\x00\xab\x00\xb6\x00\xb7\x00\x7e\x00\x7f\x00\x09\x00\xfd\x00\xb5\x00\x3d\x01\x7f\x00\x09\x00\x43\x01\x42\x01\x7f\x00\x09\x00\x3b\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x3f\x01\x3a\x01\x27\x01\x23\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x8e\x01\x1b\x01\x18\x01\x1a\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xae\x01\x14\x01\x12\x01\x11\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x10\x01\x19\x01\x0b\x01\x06\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x08\x01\x0f\x01\x0e\x01\x0d\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x3e\x01\xed\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x07\x01\x94\x00\x05\x01\x03\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x61\x01\x02\x01\x68\x01\x67\x01\x66\x01\x65\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x64\x01\x5e\x01\x5f\x01\x5b\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x45\x01\x5d\x01\x5c\x01\x5a\x01\x55\x01\x54\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x58\x01\x51\x01\x50\x01\x4f\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x6b\x01\x4e\x01\xd6\x00\x4d\x01\x4b\x01\x4a\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x49\x01\x48\x01\x47\x01\x87\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x6a\x01\x7e\x01\x46\x01\x7b\x01\x77\x01\x58\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x22\x01\x76\x01\x70\x01\x6c\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x8d\x01\x73\x01\x99\x00\x6f\x01\x6e\x01\x6d\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x9c\x01\x98\x01\x9b\x01\x97\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd8\x00\x9a\x01\x96\x01\x99\x01\x95\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x93\x01\x92\x01\x91\x01\x8b\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x8f\x01\x8a\x01\x89\x01\xad\x01\xab\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xa9\x01\xa6\x01\xa7\x01\xa5\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x0a\x01\x73\x01\xa0\x01\x9f\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x9d\x01\x9e\x01\xb9\x01\xb8\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xe1\x00\xb7\x01\xb5\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xb1\x01\xb3\x01\xb0\x01\xc3\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x1c\x01\xc2\x01\xc1\x01\xc0\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x94\x00\xbf\x01\xbe\x01\xbd\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xbc\x01\xc5\x01\xc6\x01\xbb\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x00\x00\x00\x00\xc9\x01\xba\x01\xc4\x01\xc8\x01\xce\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x01\x7d\x00\xc7\x01\x82\x01\x83\x01\x84\x01\xe1\x00\x7d\x00\x7e\x00\xe1\x00\x7d\x00\x2d\x00\xe6\x00\xe3\x00\x7e\x00\xe2\x00\xe3\x00\x7e\x00\x7f\x00\x09\x00\x2c\x00\x24\x00\x30\x00\x4e\x00\x7f\x00\x09\x00\x43\x00\x7f\x00\x09\x00\xe1\x00\x7d\x00\x41\x00\xe1\x00\x7d\x00\x2c\x00\x23\x01\xe3\x00\x7e\x00\x1e\x01\xe3\x00\x7e\x00\x97\x00\x9a\x00\x92\x00\xf3\x00\xf1\x00\xd8\x00\x7f\x00\x09\x00\xba\x00\x7f\x00\x09\x00\xe1\x00\x7d\x00\x40\x01\xe1\x00\x7d\x00\xd3\x00\x5f\x01\xe3\x00\x7e\x00\x85\x01\xe3\x00\x7e\x00\x1f\x01\x12\x01\x1c\x01\x03\x01\x79\x01\x58\x01\x7f\x00\x09\x00\x51\x01\x7f\x00\x09\x00\xe1\x00\x7d\x00\x74\x01\x71\x01\x70\x01\xa9\x01\x93\x01\xe3\x00\x7e\x00\x81\x01\x7d\x00\x8f\x01\xa0\x01\xab\x01\x84\x01\xe1\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\xae\x01\xa7\x01\xe3\x00\x7e\x00\xe1\x00\x7d\x00\xa3\x01\x7f\x00\x09\x00\x9e\x00\x7d\x00\x52\x01\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x9d\x00\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\xf7\x00\x7d\x00\x7e\x00\xf6\x00\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\xf4\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\xea\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\xe5\x00\x7d\x00\x00\x00\x7f\x00\x09\x00\xb9\x00\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x43\x01\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x38\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x37\x01\x7d\x00\x7e\x00\x36\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x35\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x34\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x33\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x32\x01\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x31\x01\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x30\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x2f\x01\x7d\x00\x7e\x00\x2e\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x2d\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x2c\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x2b\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x2a\x01\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x29\x01\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x08\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x62\x01\x7d\x00\x7e\x00\x61\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x80\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x7e\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x87\x01\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\xab\x00\xac\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xa6\x00\xa7\x00\xa8\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x4c\x00\x4d\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (1, 181) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139), + (140 , happyReduce_140), + (141 , happyReduce_141), + (142 , happyReduce_142), + (143 , happyReduce_143), + (144 , happyReduce_144), + (145 , happyReduce_145), + (146 , happyReduce_146), + (147 , happyReduce_147), + (148 , happyReduce_148), + (149 , happyReduce_149), + (150 , happyReduce_150), + (151 , happyReduce_151), + (152 , happyReduce_152), + (153 , happyReduce_153), + (154 , happyReduce_154), + (155 , happyReduce_155), + (156 , happyReduce_156), + (157 , happyReduce_157), + (158 , happyReduce_158), + (159 , happyReduce_159), + (160 , happyReduce_160), + (161 , happyReduce_161), + (162 , happyReduce_162), + (163 , happyReduce_163), + (164 , happyReduce_164), + (165 , happyReduce_165), + (166 , happyReduce_166), + (167 , happyReduce_167), + (168 , happyReduce_168), + (169 , happyReduce_169), + (170 , happyReduce_170), + (171 , happyReduce_171), + (172 , happyReduce_172), + (173 , happyReduce_173), + (174 , happyReduce_174), + (175 , happyReduce_175), + (176 , happyReduce_176), + (177 , happyReduce_177), + (178 , happyReduce_178), + (179 , happyReduce_179), + (180 , happyReduce_180), + (181 , happyReduce_181) + ] + +happy_n_terms = 87 :: Prelude.Int +happy_n_nonterms = 55 :: Prelude.Int + +happyReduce_1 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_1 = happySpecReduce_0 0# happyReduction_1 +happyReduction_1 = happyIn4 + (return () + ) + +happyReduce_2 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { (HappyWrap5 happy_var_1) -> + case happyOut4 happy_x_2 of { (HappyWrap4 happy_var_2) -> + happyIn4 + (do happy_var_1; happy_var_2 + )}} + +happyReduce_3 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_3 = happySpecReduce_1 1# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOut11 happy_x_1 of { (HappyWrap11 happy_var_1) -> + happyIn5 + (happy_var_1 + )} + +happyReduce_4 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut6 happy_x_1 of { (HappyWrap6 happy_var_1) -> + happyIn5 + (happy_var_1 + )} + +happyReduce_5 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_5 = happySpecReduce_1 1# happyReduction_5 +happyReduction_5 happy_x_1 + = case happyOut16 happy_x_1 of { (HappyWrap16 happy_var_1) -> + happyIn5 + (happy_var_1 + )} + +happyReduce_6 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_6 = happyMonadReduce 8# 1# happyReduction_6 +happyReduction_6 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Name happy_var_5)) -> + case happyOut10 happy_x_6 of { (HappyWrap10 happy_var_6) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + lits <- sequence happy_var_6; + staticClosure home_unit_id happy_var_3 happy_var_5 (map getLit lits))}}}) + ) (\r -> happyReturn (happyIn5 r)) + +happyReduce_7 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_7 = happyReduce 6# 2# happyReduction_7 +happyReduction_7 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> + case happyOut7 happy_x_4 of { (HappyWrap7 happy_var_4) -> + case happyOut8 happy_x_5 of { (HappyWrap8 happy_var_5) -> + happyIn6 + (do lbl <- happy_var_4; + ss <- sequence happy_var_5; + code (emitDecl (CmmData (Section (section happy_var_2) lbl) (CmmStaticsRaw lbl (concat ss)))) + ) `HappyStk` happyRest}}} + +happyReduce_8 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_8 = happyMonadReduce 2# 3# happyReduction_8 +happyReduction_8 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + pure (mkCmmDataLabel home_unit_id (NeedExternDecl False) happy_var_1))}) + ) (\r -> happyReturn (happyIn7 r)) + +happyReduce_9 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_9 = happySpecReduce_0 4# happyReduction_9 +happyReduction_9 = happyIn8 + ([] + ) + +happyReduce_10 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_10 = happySpecReduce_2 4# happyReduction_10 +happyReduction_10 happy_x_2 + happy_x_1 + = case happyOut9 happy_x_1 of { (HappyWrap9 happy_var_1) -> + case happyOut8 happy_x_2 of { (HappyWrap8 happy_var_2) -> + happyIn8 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_11 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_11 = happySpecReduce_3 5# happyReduction_11 +happyReduction_11 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + happyIn9 + (do e <- happy_var_2; + return [CmmStaticLit (getLit e)] + )} + +happyReduce_12 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_12 = happySpecReduce_2 5# happyReduction_12 +happyReduction_12 happy_x_2 + happy_x_1 + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + happyIn9 + (return [CmmUninitialised + (widthInBytes (typeWidth happy_var_1))] + )} + +happyReduce_13 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_13 = happyReduce 5# 5# happyReduction_13 +happyReduction_13 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_4 of { (L _ (CmmT_String happy_var_4)) -> + happyIn9 + (return [mkString happy_var_4] + ) `HappyStk` happyRest} + +happyReduce_14 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_14 = happyReduce 5# 5# happyReduction_14 +happyReduction_14 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> + happyIn9 + (return [CmmUninitialised + (fromIntegral happy_var_3)] + ) `HappyStk` happyRest} + +happyReduce_15 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_15 = happyReduce 5# 5# happyReduction_15 +happyReduction_15 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> + case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> + happyIn9 + (return [CmmUninitialised + (widthInBytes (typeWidth happy_var_1) * + fromIntegral happy_var_3)] + ) `HappyStk` happyRest}} + +happyReduce_16 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_16 = happyReduce 5# 5# happyReduction_16 +happyReduction_16 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOut10 happy_x_4 of { (HappyWrap10 happy_var_4) -> + happyIn9 + (do { lits <- sequence happy_var_4 + ; profile <- getProfile + ; return $ map CmmStaticLit $ + mkStaticClosure profile (mkForeignLabel happy_var_3 ForeignLabelInExternalPackage IsData) + -- mkForeignLabel because these are only used + -- for CHARLIKE and INTLIKE closures in the RTS. + dontCareCCS (map getLit lits) [] [] [] [] } + ) `HappyStk` happyRest}} + +happyReduce_17 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_17 = happySpecReduce_0 6# happyReduction_17 +happyReduction_17 = happyIn10 + ([] + ) + +happyReduce_18 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_18 = happySpecReduce_3 6# happyReduction_18 +happyReduction_18 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut10 happy_x_3 of { (HappyWrap10 happy_var_3) -> + happyIn10 + (happy_var_2 : happy_var_3 + )}} + +happyReduce_19 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_19 = happyReduce 4# 7# happyReduction_19 +happyReduction_19 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut14 happy_x_1 of { (HappyWrap14 happy_var_1) -> + case happyOut12 happy_x_2 of { (HappyWrap12 happy_var_2) -> + case happyOut53 happy_x_3 of { (HappyWrap53 happy_var_3) -> + case happyOut13 happy_x_4 of { (HappyWrap13 happy_var_4) -> + happyIn11 + (do ((entry_ret_label, info, stk_formals, formals), agraph) <- + getCodeScoped $ loopDecls $ do { + (entry_ret_label, info, stk_formals) <- happy_var_1; + platform <- getPlatform; + ctx <- getContext; + formals <- sequence (fromMaybe [] happy_var_3); + withName (showSDocOneLine ctx (pprCLabel platform entry_ret_label)) + happy_var_4; + return (entry_ret_label, info, stk_formals, formals) } + let do_layout = isJust happy_var_3 + code (emitProcWithStackFrame happy_var_2 info + entry_ret_label stk_formals formals agraph + do_layout ) + ) `HappyStk` happyRest}}}} + +happyReduce_20 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_20 = happySpecReduce_0 8# happyReduction_20 +happyReduction_20 = happyIn12 + (NativeNodeCall + ) + +happyReduce_21 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_21 = happySpecReduce_1 8# happyReduction_21 +happyReduction_21 happy_x_1 + = happyIn12 + (NativeReturn + ) + +happyReduce_22 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_22 = happySpecReduce_1 9# happyReduction_22 +happyReduction_22 happy_x_1 + = happyIn13 + (return () + ) + +happyReduce_23 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_23 = happySpecReduce_3 9# happyReduction_23 +happyReduction_23 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn13 + (withSourceNote happy_var_1 happy_var_3 happy_var_2 + )}}} + +happyReduce_24 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_24 = happyMonadReduce 1# 10# happyReduction_24 +happyReduction_24 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + newFunctionName happy_var_1 home_unit_id + return (mkCmmCodeLabel home_unit_id happy_var_1, Nothing, []))}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_25 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_25 = happyMonadReduce 14# 10# happyReduction_25 +happyReduction_25 (happy_x_14 `HappyStk` + happy_x_13 `HappyStk` + happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> + case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + profile <- getProfile + let prof = profilingInfo profile happy_var_11 happy_var_13 + rep = mkRTSRep (fromIntegral happy_var_9) $ + mkHeapRep profile False (fromIntegral happy_var_5) + (fromIntegral happy_var_7) Thunk + -- not really Thunk, but that makes the info table + -- we want. + return (mkCmmEntryLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []))}}}}}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_26 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_26 = happyMonadReduce 18# 10# happyReduction_26 +happyReduction_26 (happy_x_18 `HappyStk` + happy_x_17 `HappyStk` + happy_x_16 `HappyStk` + happy_x_15 `HappyStk` + happy_x_14 `HappyStk` + happy_x_13 `HappyStk` + happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> + case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> + case happyOutTok happy_x_15 of { (L _ (CmmT_Int happy_var_15)) -> + case happyOutTok happy_x_17 of { (L _ (CmmT_Int happy_var_17)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + profile <- getProfile + let prof = profilingInfo profile happy_var_11 happy_var_13 + ty = Fun (fromIntegral happy_var_15) (ArgSpec (fromIntegral happy_var_17)) + rep = mkRTSRep (fromIntegral happy_var_9) $ + mkHeapRep profile False (fromIntegral happy_var_5) + (fromIntegral happy_var_7) ty + return (mkCmmEntryLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []))}}}}}}}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_27 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_27 = happyMonadReduce 16# 10# happyReduction_27 +happyReduction_27 (happy_x_16 `HappyStk` + happy_x_15 `HappyStk` + happy_x_14 `HappyStk` + happy_x_13 `HappyStk` + happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_Int happy_var_11)) -> + case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> + case happyOutTok happy_x_15 of { (L _ (CmmT_String happy_var_15)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + profile <- getProfile + let prof = profilingInfo profile happy_var_13 happy_var_15 + ty = Constr (fromIntegral happy_var_9) -- Tag + (BS8.pack happy_var_13) + rep = mkRTSRep (fromIntegral happy_var_11) $ + mkHeapRep profile False (fromIntegral happy_var_5) + (fromIntegral happy_var_7) ty + return (mkCmmEntryLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing }, + []))}}}}}}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_28 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_28 = happyMonadReduce 12# 10# happyReduction_28 +happyReduction_28 (happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_String happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + profile <- getProfile + let prof = profilingInfo profile happy_var_9 happy_var_11 + ty = ThunkSelector (fromIntegral happy_var_5) + rep = mkRTSRep (fromIntegral happy_var_7) $ + mkHeapRep profile False 0 0 ty + return (mkCmmEntryLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []))}}}}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_29 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_29 = happyMonadReduce 6# 10# happyReduction_29 +happyReduction_29 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + let prof = NoProfilingInfo + rep = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep [] + return (mkCmmRetLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []))}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_30 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_30 = happyMonadReduce 8# 10# happyReduction_30 +happyReduction_30 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOut54 happy_x_7 of { (HappyWrap54 happy_var_7) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + platform <- getPlatform + live <- sequence happy_var_7 + let prof = NoProfilingInfo + -- drop one for the info pointer + bitmap = mkLiveness platform (drop 1 live) + rep = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep bitmap + return (mkCmmRetLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + live))}}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_31 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_31 = happySpecReduce_0 11# happyReduction_31 +happyReduction_31 = happyIn15 + (return () + ) + +happyReduce_32 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_32 = happySpecReduce_2 11# happyReduction_32 +happyReduction_32 happy_x_2 + happy_x_1 + = case happyOut16 happy_x_1 of { (HappyWrap16 happy_var_1) -> + case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> + happyIn15 + (do happy_var_1; happy_var_2 + )}} + +happyReduce_33 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_33 = happySpecReduce_2 11# happyReduction_33 +happyReduction_33 happy_x_2 + happy_x_1 + = case happyOut20 happy_x_1 of { (HappyWrap20 happy_var_1) -> + case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> + happyIn15 + (do happy_var_1; happy_var_2 + )}} + +happyReduce_34 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_34 = happySpecReduce_3 12# happyReduction_34 +happyReduction_34 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOut19 happy_x_2 of { (HappyWrap19 happy_var_2) -> + happyIn16 + (mapM_ (newLocal happy_var_1) happy_var_2 + )}} + +happyReduce_35 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_35 = happySpecReduce_3 12# happyReduction_35 +happyReduction_35 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut17 happy_x_2 of { (HappyWrap17 happy_var_2) -> + happyIn16 + (mapM_ newImport happy_var_2 + )} + +happyReduce_36 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_36 = happySpecReduce_3 12# happyReduction_36 +happyReduction_36 happy_x_3 + happy_x_2 + happy_x_1 + = happyIn16 + (return () + ) + +happyReduce_37 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_37 = happySpecReduce_1 13# happyReduction_37 +happyReduction_37 happy_x_1 + = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> + happyIn17 + ([happy_var_1] + )} + +happyReduce_38 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_38 = happySpecReduce_3 13# happyReduction_38 +happyReduction_38 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> + case happyOut17 happy_x_3 of { (HappyWrap17 happy_var_3) -> + happyIn17 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_39 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_39 = happySpecReduce_1 14# happyReduction_39 +happyReduction_39 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn18 + ((happy_var_1, mkForeignLabel happy_var_1 ForeignLabelInExternalPackage IsFunction) + )} + +happyReduce_40 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_40 = happySpecReduce_2 14# happyReduction_40 +happyReduction_40 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn18 + ((happy_var_2, mkForeignLabel happy_var_2 ForeignLabelInExternalPackage IsData) + )} + +happyReduce_41 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_41 = happySpecReduce_2 14# happyReduction_41 +happyReduction_41 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn18 + ((happy_var_2, mkCmmCodeLabel (UnitId (mkFastString happy_var_1)) happy_var_2) + )}} + +happyReduce_42 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_42 = happySpecReduce_1 15# happyReduction_42 +happyReduction_42 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn19 + ([happy_var_1] + )} + +happyReduce_43 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_43 = happySpecReduce_3 15# happyReduction_43 +happyReduction_43 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + case happyOut19 happy_x_3 of { (HappyWrap19 happy_var_3) -> + happyIn19 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_44 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_44 = happySpecReduce_1 16# happyReduction_44 +happyReduction_44 happy_x_1 + = happyIn20 + (return () + ) + +happyReduce_45 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_45 = happySpecReduce_2 16# happyReduction_45 +happyReduction_45 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn20 + (do l <- newLabel happy_var_1; emitLabel l + )} + +happyReduce_46 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_46 = happyReduce 4# 16# happyReduction_46 +happyReduction_46 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn20 + (do reg <- happy_var_1; e <- happy_var_3; withSourceNote happy_var_2 happy_var_4 (emitAssign reg e) + ) `HappyStk` happyRest}}}} + +happyReduce_47 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_47 = happyReduce 8# 16# happyReduction_47 +happyReduction_47 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> + case happyOut57 happy_x_4 of { (HappyWrap57 happy_var_4) -> + case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> + case happyOutTok happy_x_7 of { happy_var_7 -> + happyIn20 + (do reg <- happy_var_1; + let lreg = case reg of + { CmmLocal r -> r + ; other -> pprPanic "CmmParse:" (ppr reg <> text "not a local register") + } ; + mord <- happy_var_3; + let { ty = happy_var_4; w = typeWidth ty }; + e <- happy_var_6; + let op = MO_AtomicRead w mord; + withSourceNote happy_var_2 happy_var_7 $ code (emitPrimCall [lreg] op [e]) + ) `HappyStk` happyRest}}}}}} + +happyReduce_48 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_48 = happyReduce 8# 16# happyReduction_48 +happyReduction_48 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut22 happy_x_1 of { (HappyWrap22 happy_var_1) -> + case happyOut57 happy_x_2 of { (HappyWrap57 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut39 happy_x_4 of { (HappyWrap39 happy_var_4) -> + case happyOut39 happy_x_7 of { (HappyWrap39 happy_var_7) -> + case happyOutTok happy_x_8 of { happy_var_8 -> + happyIn20 + (do mord <- happy_var_1; withSourceNote happy_var_3 happy_var_8 (doStore (Just mord) happy_var_2 happy_var_4 happy_var_7) + ) `HappyStk` happyRest}}}}}} + +happyReduce_49 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_49 = happyReduce 7# 16# happyReduction_49 +happyReduction_49 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> + case happyOutTok happy_x_7 of { happy_var_7 -> + happyIn20 + (withSourceNote happy_var_2 happy_var_7 (doStore Nothing happy_var_1 happy_var_3 happy_var_6) + ) `HappyStk` happyRest}}}}} + +happyReduce_50 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_50 = happyMonadReduce 10# 16# happyReduction_50 +happyReduction_50 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut48 happy_x_1 of { (HappyWrap48 happy_var_1) -> + case happyOutTok happy_x_3 of { (L _ (CmmT_String happy_var_3)) -> + case happyOut24 happy_x_4 of { (HappyWrap24 happy_var_4) -> + case happyOut42 happy_x_6 of { (HappyWrap42 happy_var_6) -> + case happyOut28 happy_x_8 of { (HappyWrap28 happy_var_8) -> + case happyOut25 happy_x_9 of { (HappyWrap25 happy_var_9) -> + ( foreignCall happy_var_3 happy_var_1 happy_var_4 happy_var_6 happy_var_8 happy_var_9)}}}}}}) + ) (\r -> happyReturn (happyIn20 r)) + +happyReduce_51 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_51 = happyMonadReduce 8# 16# happyReduction_51 +happyReduction_51 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut48 happy_x_1 of { (HappyWrap48 happy_var_1) -> + case happyOutTok happy_x_4 of { (L _ (CmmT_Name happy_var_4)) -> + case happyOut45 happy_x_6 of { (HappyWrap45 happy_var_6) -> + ( primCall happy_var_1 happy_var_4 happy_var_6)}}}) + ) (\r -> happyReturn (happyIn20 r)) + +happyReduce_52 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_52 = happyMonadReduce 5# 16# happyReduction_52 +happyReduction_52 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> + ( stmtMacro happy_var_1 happy_var_3)}}) + ) (\r -> happyReturn (happyIn20 r)) + +happyReduce_53 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_53 = happyReduce 7# 16# happyReduction_53 +happyReduction_53 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut31 happy_x_2 of { (HappyWrap31 happy_var_2) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + case happyOut32 happy_x_5 of { (HappyWrap32 happy_var_5) -> + case happyOut36 happy_x_6 of { (HappyWrap36 happy_var_6) -> + happyIn20 + (do as <- sequence happy_var_5; doSwitch happy_var_2 happy_var_3 as happy_var_6 + ) `HappyStk` happyRest}}}} + +happyReduce_54 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_54 = happySpecReduce_3 16# happyReduction_54 +happyReduction_54 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn20 + (do l <- lookupLabel happy_var_2; emit (mkBranch l) + )} + +happyReduce_55 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_55 = happyReduce 5# 16# happyReduction_55 +happyReduction_55 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> + happyIn20 + (doReturn happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_56 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_56 = happyReduce 4# 16# happyReduction_56 +happyReduction_56 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut29 happy_x_3 of { (HappyWrap29 happy_var_3) -> + happyIn20 + (doRawJump happy_var_2 happy_var_3 + ) `HappyStk` happyRest}} + +happyReduce_57 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_57 = happyReduce 6# 16# happyReduction_57 +happyReduction_57 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> + happyIn20 + (doJumpWithStack happy_var_2 [] happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_58 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_58 = happyReduce 9# 16# happyReduction_58 +happyReduction_58 (happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> + case happyOut45 happy_x_7 of { (HappyWrap45 happy_var_7) -> + happyIn20 + (doJumpWithStack happy_var_2 happy_var_4 happy_var_7 + ) `HappyStk` happyRest}}} + +happyReduce_59 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_59 = happyReduce 6# 16# happyReduction_59 +happyReduction_59 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> + happyIn20 + (doCall happy_var_2 [] happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_60 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_60 = happyReduce 10# 16# happyReduction_60 +happyReduction_60 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut55 happy_x_2 of { (HappyWrap55 happy_var_2) -> + case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> + case happyOut45 happy_x_8 of { (HappyWrap45 happy_var_8) -> + happyIn20 + (doCall happy_var_6 happy_var_2 happy_var_8 + ) `HappyStk` happyRest}}} + +happyReduce_61 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_61 = happyReduce 5# 16# happyReduction_61 +happyReduction_61 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> + case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Name happy_var_5)) -> + happyIn20 + (do l <- lookupLabel happy_var_5; cmmRawIf happy_var_2 l happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_62 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_62 = happyReduce 7# 16# happyReduction_62 +happyReduction_62 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> + case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut15 happy_x_5 of { (HappyWrap15 happy_var_5) -> + case happyOutTok happy_x_6 of { happy_var_6 -> + case happyOut37 happy_x_7 of { (HappyWrap37 happy_var_7) -> + happyIn20 + (cmmIfThenElse happy_var_2 (withSourceNote happy_var_4 happy_var_6 happy_var_5) happy_var_7 happy_var_3 + ) `HappyStk` happyRest}}}}}} + +happyReduce_63 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_63 = happyReduce 5# 16# happyReduction_63 +happyReduction_63 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> + case happyOut13 happy_x_5 of { (HappyWrap13 happy_var_5) -> + happyIn20 + (pushStackFrame happy_var_3 happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_64 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_64 = happyReduce 5# 16# happyReduction_64 +happyReduction_64 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut52 happy_x_4 of { (HappyWrap52 happy_var_4) -> + case happyOut13 happy_x_5 of { (HappyWrap13 happy_var_5) -> + happyIn20 + (reserveStackFrame happy_var_2 happy_var_4 happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_65 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_65 = happySpecReduce_3 16# happyReduction_65 +happyReduction_65 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut21 happy_x_2 of { (HappyWrap21 happy_var_2) -> + happyIn20 + (happy_var_2 >>= code . emitUnwind + )} + +happyReduce_66 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_66 = happyReduce 5# 17# happyReduction_66 +happyReduction_66 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> + case happyOut21 happy_x_5 of { (HappyWrap21 happy_var_5) -> + happyIn21 + (do e <- happy_var_3; rest <- happy_var_5; return ((globalRegUse_reg happy_var_1, e) : rest) + ) `HappyStk` happyRest}}} + +happyReduce_67 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_67 = happySpecReduce_3 17# happyReduction_67 +happyReduction_67 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> + happyIn21 + (do e <- happy_var_3; return [(globalRegUse_reg happy_var_1, e)] + )}} + +happyReduce_68 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_68 = happySpecReduce_1 18# happyReduction_68 +happyReduction_68 happy_x_1 + = happyIn22 + (do return MemOrderRelaxed + ) + +happyReduce_69 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_69 = happySpecReduce_1 18# happyReduction_69 +happyReduction_69 happy_x_1 + = happyIn22 + (do return MemOrderRelease + ) + +happyReduce_70 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_70 = happySpecReduce_1 18# happyReduction_70 +happyReduction_70 happy_x_1 + = happyIn22 + (do return MemOrderAcquire + ) + +happyReduce_71 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_71 = happySpecReduce_1 18# happyReduction_71 +happyReduction_71 happy_x_1 + = happyIn22 + (do return MemOrderSeqCst + ) + +happyReduce_72 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_72 = happySpecReduce_1 19# happyReduction_72 +happyReduction_72 happy_x_1 + = happyIn23 + (do return Nothing + ) + +happyReduce_73 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_73 = happySpecReduce_1 19# happyReduction_73 +happyReduction_73 happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + happyIn23 + (do e <- happy_var_1; return (Just e) + )} + +happyReduce_74 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_74 = happySpecReduce_1 20# happyReduction_74 +happyReduction_74 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn24 + (return (CmmLit (CmmLabel (mkForeignLabel happy_var_1 ForeignLabelInThisPackage IsFunction))) + )} + +happyReduce_75 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_75 = happySpecReduce_0 21# happyReduction_75 +happyReduction_75 = happyIn25 + (CmmMayReturn + ) + +happyReduce_76 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_76 = happySpecReduce_2 21# happyReduction_76 +happyReduction_76 happy_x_2 + happy_x_1 + = happyIn25 + (CmmNeverReturns + ) + +happyReduce_77 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_77 = happySpecReduce_1 22# happyReduction_77 +happyReduction_77 happy_x_1 + = case happyOut27 happy_x_1 of { (HappyWrap27 happy_var_1) -> + happyIn26 + (happy_var_1 + )} + +happyReduce_78 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_78 = happySpecReduce_1 22# happyReduction_78 +happyReduction_78 happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + happyIn26 + (do e <- happy_var_1; return (BoolTest e) + )} + +happyReduce_79 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_79 = happySpecReduce_3 23# happyReduction_79 +happyReduction_79 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut26 happy_x_1 of { (HappyWrap26 happy_var_1) -> + case happyOut26 happy_x_3 of { (HappyWrap26 happy_var_3) -> + happyIn27 + (do e1 <- happy_var_1; e2 <- happy_var_3; + return (BoolAnd e1 e2) + )}} + +happyReduce_80 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_80 = happySpecReduce_3 23# happyReduction_80 +happyReduction_80 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut26 happy_x_1 of { (HappyWrap26 happy_var_1) -> + case happyOut26 happy_x_3 of { (HappyWrap26 happy_var_3) -> + happyIn27 + (do e1 <- happy_var_1; e2 <- happy_var_3; + return (BoolOr e1 e2) + )}} + +happyReduce_81 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_81 = happySpecReduce_2 23# happyReduction_81 +happyReduction_81 happy_x_2 + happy_x_1 + = case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> + happyIn27 + (do e <- happy_var_2; return (BoolNot e) + )} + +happyReduce_82 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_82 = happySpecReduce_3 23# happyReduction_82 +happyReduction_82 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut27 happy_x_2 of { (HappyWrap27 happy_var_2) -> + happyIn27 + (happy_var_2 + )} + +happyReduce_83 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_83 = happySpecReduce_0 24# happyReduction_83 +happyReduction_83 = happyIn28 + (PlayRisky + ) + +happyReduce_84 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_84 = happyMonadReduce 1# 24# happyReduction_84 +happyReduction_84 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + ( parseSafety happy_var_1)}) + ) (\r -> happyReturn (happyIn28 r)) + +happyReduce_85 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_85 = happySpecReduce_2 25# happyReduction_85 +happyReduction_85 happy_x_2 + happy_x_1 + = happyIn29 + ([] + ) + +happyReduce_86 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_86 = happyMonadReduce 1# 25# happyReduction_86 +happyReduction_86 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; + return + [ GlobalRegUse r (globalRegSpillType platform r) + | r <- realArgRegsCover platform GP_ARG_REGS ])) + ) (\r -> happyReturn (happyIn29 r)) + +happyReduce_87 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_87 = happyMonadReduce 1# 25# happyReduction_87 +happyReduction_87 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; + return + [ GlobalRegUse r (globalRegSpillType platform r) + | r <- realArgRegsCover platform SCALAR_ARG_REGS ])) + ) (\r -> happyReturn (happyIn29 r)) + +happyReduce_88 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_88 = happyMonadReduce 1# 25# happyReduction_88 +happyReduction_88 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; + return + [ GlobalRegUse r (globalRegSpillType platform r) + | r <- realArgRegsCover platform V16_ARG_REGS ])) + ) (\r -> happyReturn (happyIn29 r)) + +happyReduce_89 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_89 = happyMonadReduce 1# 25# happyReduction_89 +happyReduction_89 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; + return + [ GlobalRegUse r (globalRegSpillType platform r) + | r <- realArgRegsCover platform V32_ARG_REGS ])) + ) (\r -> happyReturn (happyIn29 r)) + +happyReduce_90 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_90 = happyMonadReduce 1# 25# happyReduction_90 +happyReduction_90 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; + return + [ GlobalRegUse r (globalRegSpillType platform r) + | r <- realArgRegsCover platform V64_ARG_REGS ])) + ) (\r -> happyReturn (happyIn29 r)) + +happyReduce_91 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_91 = happySpecReduce_3 25# happyReduction_91 +happyReduction_91 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut30 happy_x_2 of { (HappyWrap30 happy_var_2) -> + happyIn29 + (happy_var_2 + )} + +happyReduce_92 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_92 = happySpecReduce_1 26# happyReduction_92 +happyReduction_92 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + happyIn30 + ([happy_var_1] + )} + +happyReduce_93 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_93 = happySpecReduce_3 26# happyReduction_93 +happyReduction_93 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + case happyOut30 happy_x_3 of { (HappyWrap30 happy_var_3) -> + happyIn30 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_94 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_94 = happyReduce 5# 27# happyReduction_94 +happyReduction_94 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (L _ (CmmT_Int happy_var_2)) -> + case happyOutTok happy_x_4 of { (L _ (CmmT_Int happy_var_4)) -> + happyIn31 + (Just (happy_var_2, happy_var_4) + ) `HappyStk` happyRest}} + +happyReduce_95 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_95 = happySpecReduce_0 27# happyReduction_95 +happyReduction_95 = happyIn31 + (Nothing + ) + +happyReduce_96 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_96 = happySpecReduce_0 28# happyReduction_96 +happyReduction_96 = happyIn32 + ([] + ) + +happyReduce_97 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_97 = happySpecReduce_2 28# happyReduction_97 +happyReduction_97 happy_x_2 + happy_x_1 + = case happyOut33 happy_x_1 of { (HappyWrap33 happy_var_1) -> + case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> + happyIn32 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_98 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_98 = happyReduce 4# 29# happyReduction_98 +happyReduction_98 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut35 happy_x_2 of { (HappyWrap35 happy_var_2) -> + case happyOut34 happy_x_4 of { (HappyWrap34 happy_var_4) -> + happyIn33 + (do b <- happy_var_4; return (happy_var_2, b) + ) `HappyStk` happyRest}} + +happyReduce_99 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_99 = happySpecReduce_3 30# happyReduction_99 +happyReduction_99 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn34 + (return (Right (withSourceNote happy_var_1 happy_var_3 happy_var_2)) + )}}} + +happyReduce_100 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_100 = happySpecReduce_3 30# happyReduction_100 +happyReduction_100 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn34 + (do l <- lookupLabel happy_var_2; return (Left l) + )} + +happyReduce_101 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_101 = happySpecReduce_1 31# happyReduction_101 +happyReduction_101 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> + happyIn35 + ([ happy_var_1 ] + )} + +happyReduce_102 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_102 = happySpecReduce_3 31# happyReduction_102 +happyReduction_102 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> + case happyOut35 happy_x_3 of { (HappyWrap35 happy_var_3) -> + happyIn35 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_103 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_103 = happyReduce 5# 32# happyReduction_103 +happyReduction_103 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut15 happy_x_4 of { (HappyWrap15 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + happyIn36 + (Just (withSourceNote happy_var_3 happy_var_5 happy_var_4) + ) `HappyStk` happyRest}}} + +happyReduce_104 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_104 = happySpecReduce_0 32# happyReduction_104 +happyReduction_104 = happyIn36 + (Nothing + ) + +happyReduce_105 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_105 = happySpecReduce_0 33# happyReduction_105 +happyReduction_105 = happyIn37 + (return () + ) + +happyReduce_106 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_106 = happyReduce 4# 33# happyReduction_106 +happyReduction_106 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut15 happy_x_3 of { (HappyWrap15 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn37 + (withSourceNote happy_var_2 happy_var_4 happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_107 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_107 = happyReduce 5# 34# happyReduction_107 +happyReduction_107 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = happyIn38 + (Just True + ) `HappyStk` happyRest + +happyReduce_108 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_108 = happyReduce 5# 34# happyReduction_108 +happyReduction_108 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = happyIn38 + (Just False + ) `HappyStk` happyRest + +happyReduce_109 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_109 = happySpecReduce_0 34# happyReduction_109 +happyReduction_109 = happyIn38 + (Nothing + ) + +happyReduce_110 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_110 = happySpecReduce_3 35# happyReduction_110 +happyReduction_110 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Quot [happy_var_1,happy_var_3] + )}} + +happyReduce_111 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_111 = happySpecReduce_3 35# happyReduction_111 +happyReduction_111 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Mul [happy_var_1,happy_var_3] + )}} + +happyReduce_112 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_112 = happySpecReduce_3 35# happyReduction_112 +happyReduction_112 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Rem [happy_var_1,happy_var_3] + )}} + +happyReduce_113 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_113 = happySpecReduce_3 35# happyReduction_113 +happyReduction_113 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Sub [happy_var_1,happy_var_3] + )}} + +happyReduce_114 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_114 = happySpecReduce_3 35# happyReduction_114 +happyReduction_114 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Add [happy_var_1,happy_var_3] + )}} + +happyReduce_115 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_115 = happySpecReduce_3 35# happyReduction_115 +happyReduction_115 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Shr [happy_var_1,happy_var_3] + )}} + +happyReduce_116 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_116 = happySpecReduce_3 35# happyReduction_116 +happyReduction_116 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Shl [happy_var_1,happy_var_3] + )}} + +happyReduce_117 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_117 = happySpecReduce_3 35# happyReduction_117 +happyReduction_117 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_And [happy_var_1,happy_var_3] + )}} + +happyReduce_118 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_118 = happySpecReduce_3 35# happyReduction_118 +happyReduction_118 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Xor [happy_var_1,happy_var_3] + )}} + +happyReduce_119 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_119 = happySpecReduce_3 35# happyReduction_119 +happyReduction_119 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Or [happy_var_1,happy_var_3] + )}} + +happyReduce_120 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_120 = happySpecReduce_3 35# happyReduction_120 +happyReduction_120 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Ge [happy_var_1,happy_var_3] + )}} + +happyReduce_121 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_121 = happySpecReduce_3 35# happyReduction_121 +happyReduction_121 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Gt [happy_var_1,happy_var_3] + )}} + +happyReduce_122 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_122 = happySpecReduce_3 35# happyReduction_122 +happyReduction_122 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Le [happy_var_1,happy_var_3] + )}} + +happyReduce_123 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_123 = happySpecReduce_3 35# happyReduction_123 +happyReduction_123 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Lt [happy_var_1,happy_var_3] + )}} + +happyReduce_124 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_124 = happySpecReduce_3 35# happyReduction_124 +happyReduction_124 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Ne [happy_var_1,happy_var_3] + )}} + +happyReduce_125 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_125 = happySpecReduce_3 35# happyReduction_125 +happyReduction_125 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Eq [happy_var_1,happy_var_3] + )}} + +happyReduce_126 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_126 = happySpecReduce_2 35# happyReduction_126 +happyReduction_126 happy_x_2 + happy_x_1 + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + happyIn39 + (mkMachOp MO_Not [happy_var_2] + )} + +happyReduce_127 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_127 = happySpecReduce_2 35# happyReduction_127 +happyReduction_127 happy_x_2 + happy_x_1 + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + happyIn39 + (mkMachOp MO_S_Neg [happy_var_2] + )} + +happyReduce_128 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_128 = happyMonadReduce 5# 35# happyReduction_128 +happyReduction_128 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut40 happy_x_1 of { (HappyWrap40 happy_var_1) -> + case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOut40 happy_x_5 of { (HappyWrap40 happy_var_5) -> + ( do { mo <- nameToMachOp happy_var_3 ; + return (mkMachOp mo [happy_var_1,happy_var_5]) })}}}) + ) (\r -> happyReturn (happyIn39 r)) + +happyReduce_129 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_129 = happySpecReduce_1 35# happyReduction_129 +happyReduction_129 happy_x_1 + = case happyOut40 happy_x_1 of { (HappyWrap40 happy_var_1) -> + happyIn39 + (happy_var_1 + )} + +happyReduce_130 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_130 = happySpecReduce_2 36# happyReduction_130 +happyReduction_130 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> + case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> + happyIn40 + (return (CmmLit (CmmInt happy_var_1 (typeWidth happy_var_2))) + )}} + +happyReduce_131 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_131 = happySpecReduce_2 36# happyReduction_131 +happyReduction_131 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Float happy_var_1)) -> + case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> + happyIn40 + (return (CmmLit (CmmFloat happy_var_1 (typeWidth happy_var_2))) + )}} + +happyReduce_132 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_132 = happySpecReduce_1 36# happyReduction_132 +happyReduction_132 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + happyIn40 + (do s <- code (newStringCLit happy_var_1); + return (CmmLit s) + )} + +happyReduce_133 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_133 = happySpecReduce_1 36# happyReduction_133 +happyReduction_133 happy_x_1 + = case happyOut47 happy_x_1 of { (HappyWrap47 happy_var_1) -> + happyIn40 + (happy_var_1 + )} + +happyReduce_134 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_134 = happyReduce 5# 36# happyReduction_134 +happyReduction_134 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOut39 happy_x_4 of { (HappyWrap39 happy_var_4) -> + happyIn40 + (do ptr <- happy_var_4; return (CmmMachOp (MO_RelaxedRead (typeWidth happy_var_1)) [ptr]) + ) `HappyStk` happyRest}} + +happyReduce_135 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_135 = happyReduce 5# 36# happyReduction_135 +happyReduction_135 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOut39 happy_x_4 of { (HappyWrap39 happy_var_4) -> + happyIn40 + (do ptr <- happy_var_4; return (CmmLoad ptr happy_var_1 Unaligned) + ) `HappyStk` happyRest}} + +happyReduce_136 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_136 = happyReduce 4# 36# happyReduction_136 +happyReduction_136 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn40 + (do ptr <- happy_var_3; return (CmmLoad ptr happy_var_1 NaturallyAligned) + ) `HappyStk` happyRest}} + +happyReduce_137 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_137 = happyMonadReduce 5# 36# happyReduction_137 +happyReduction_137 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> + ( exprOp happy_var_2 happy_var_4)}}) + ) (\r -> happyReturn (happyIn40 r)) + +happyReduce_138 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_138 = happySpecReduce_3 36# happyReduction_138 +happyReduction_138 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + happyIn40 + (happy_var_2 + )} + +happyReduce_139 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_139 = happyMonadReduce 0# 37# happyReduction_139 +happyReduction_139 (happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; return $ bWord platform)) + ) (\r -> happyReturn (happyIn41 r)) + +happyReduce_140 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_140 = happySpecReduce_2 37# happyReduction_140 +happyReduction_140 happy_x_2 + happy_x_1 + = case happyOut57 happy_x_2 of { (HappyWrap57 happy_var_2) -> + happyIn41 + (happy_var_2 + )} + +happyReduce_141 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_141 = happySpecReduce_0 38# happyReduction_141 +happyReduction_141 = happyIn42 + ([] + ) + +happyReduce_142 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_142 = happySpecReduce_1 38# happyReduction_142 +happyReduction_142 happy_x_1 + = case happyOut43 happy_x_1 of { (HappyWrap43 happy_var_1) -> + happyIn42 + (happy_var_1 + )} + +happyReduce_143 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_143 = happySpecReduce_1 39# happyReduction_143 +happyReduction_143 happy_x_1 + = case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> + happyIn43 + ([happy_var_1] + )} + +happyReduce_144 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_144 = happySpecReduce_3 39# happyReduction_144 +happyReduction_144 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> + case happyOut43 happy_x_3 of { (HappyWrap43 happy_var_3) -> + happyIn43 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_145 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_145 = happySpecReduce_1 40# happyReduction_145 +happyReduction_145 happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + happyIn44 + (do e <- happy_var_1; + return (e, inferCmmHint e) + )} + +happyReduce_146 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_146 = happyMonadReduce 2# 40# happyReduction_146 +happyReduction_146 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> + ( do h <- parseCmmHint happy_var_2; + return $ do + e <- happy_var_1; return (e, h))}}) + ) (\r -> happyReturn (happyIn44 r)) + +happyReduce_147 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_147 = happySpecReduce_0 41# happyReduction_147 +happyReduction_147 = happyIn45 + ([] + ) + +happyReduce_148 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_148 = happySpecReduce_1 41# happyReduction_148 +happyReduction_148 happy_x_1 + = case happyOut46 happy_x_1 of { (HappyWrap46 happy_var_1) -> + happyIn45 + (happy_var_1 + )} + +happyReduce_149 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_149 = happySpecReduce_1 42# happyReduction_149 +happyReduction_149 happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + happyIn46 + ([ happy_var_1 ] + )} + +happyReduce_150 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_150 = happySpecReduce_3 42# happyReduction_150 +happyReduction_150 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut46 happy_x_3 of { (HappyWrap46 happy_var_3) -> + happyIn46 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_151 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_151 = happySpecReduce_1 43# happyReduction_151 +happyReduction_151 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn47 + (lookupName happy_var_1 + )} + +happyReduce_152 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_152 = happySpecReduce_1 43# happyReduction_152 +happyReduction_152 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + happyIn47 + (return (CmmReg (CmmGlobal happy_var_1)) + )} + +happyReduce_153 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_153 = happySpecReduce_0 44# happyReduction_153 +happyReduction_153 = happyIn48 + ([] + ) + +happyReduce_154 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_154 = happyReduce 4# 44# happyReduction_154 +happyReduction_154 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut49 happy_x_2 of { (HappyWrap49 happy_var_2) -> + happyIn48 + (happy_var_2 + ) `HappyStk` happyRest} + +happyReduce_155 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_155 = happySpecReduce_1 45# happyReduction_155 +happyReduction_155 happy_x_1 + = case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> + happyIn49 + ([happy_var_1] + )} + +happyReduce_156 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_156 = happySpecReduce_2 45# happyReduction_156 +happyReduction_156 happy_x_2 + happy_x_1 + = case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> + happyIn49 + ([happy_var_1] + )} + +happyReduce_157 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_157 = happySpecReduce_3 45# happyReduction_157 +happyReduction_157 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> + case happyOut49 happy_x_3 of { (HappyWrap49 happy_var_3) -> + happyIn49 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_158 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_158 = happySpecReduce_1 46# happyReduction_158 +happyReduction_158 happy_x_1 + = case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> + happyIn50 + (do e <- happy_var_1; return (e, inferCmmHint (CmmReg (CmmLocal e))) + )} + +happyReduce_159 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_159 = happyMonadReduce 2# 46# happyReduction_159 +happyReduction_159 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + case happyOut51 happy_x_2 of { (HappyWrap51 happy_var_2) -> + ( do h <- parseCmmHint happy_var_1; + return $ do + e <- happy_var_2; return (e,h))}}) + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_160 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_160 = happySpecReduce_1 47# happyReduction_160 +happyReduction_160 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn51 + (do e <- lookupName happy_var_1; + return $ + case e of + CmmReg (CmmLocal r) -> r + other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a local register") + )} + +happyReduce_161 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_161 = happySpecReduce_1 48# happyReduction_161 +happyReduction_161 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn52 + (do e <- lookupName happy_var_1; + return $ + case e of + CmmReg r -> r + other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a register") + )} + +happyReduce_162 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_162 = happySpecReduce_1 48# happyReduction_162 +happyReduction_162 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + happyIn52 + (return (CmmGlobal happy_var_1) + )} + +happyReduce_163 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_163 = happySpecReduce_0 49# happyReduction_163 +happyReduction_163 = happyIn53 + (Nothing + ) + +happyReduce_164 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_164 = happySpecReduce_3 49# happyReduction_164 +happyReduction_164 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut54 happy_x_2 of { (HappyWrap54 happy_var_2) -> + happyIn53 + (Just happy_var_2 + )} + +happyReduce_165 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_165 = happySpecReduce_0 50# happyReduction_165 +happyReduction_165 = happyIn54 + ([] + ) + +happyReduce_166 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_166 = happySpecReduce_1 50# happyReduction_166 +happyReduction_166 happy_x_1 + = case happyOut55 happy_x_1 of { (HappyWrap55 happy_var_1) -> + happyIn54 + (happy_var_1 + )} + +happyReduce_167 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_167 = happySpecReduce_2 51# happyReduction_167 +happyReduction_167 happy_x_2 + happy_x_1 + = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> + happyIn55 + ([happy_var_1] + )} + +happyReduce_168 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_168 = happySpecReduce_1 51# happyReduction_168 +happyReduction_168 happy_x_1 + = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> + happyIn55 + ([happy_var_1] + )} + +happyReduce_169 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_169 = happySpecReduce_3 51# happyReduction_169 +happyReduction_169 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> + case happyOut55 happy_x_3 of { (HappyWrap55 happy_var_3) -> + happyIn55 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_170 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_170 = happySpecReduce_2 52# happyReduction_170 +happyReduction_170 happy_x_2 + happy_x_1 + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn56 + (newLocal happy_var_1 happy_var_2 + )}} + +happyReduce_171 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_171 = happySpecReduce_1 53# happyReduction_171 +happyReduction_171 happy_x_1 + = happyIn57 + (b8 + ) + +happyReduce_172 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_172 = happySpecReduce_1 53# happyReduction_172 +happyReduction_172 happy_x_1 + = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> + happyIn57 + (happy_var_1 + )} + +happyReduce_173 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_173 = happySpecReduce_1 54# happyReduction_173 +happyReduction_173 happy_x_1 + = happyIn58 + (b16 + ) + +happyReduce_174 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_174 = happySpecReduce_1 54# happyReduction_174 +happyReduction_174 happy_x_1 + = happyIn58 + (b32 + ) + +happyReduce_175 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_175 = happySpecReduce_1 54# happyReduction_175 +happyReduction_175 happy_x_1 + = happyIn58 + (b64 + ) + +happyReduce_176 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_176 = happySpecReduce_1 54# happyReduction_176 +happyReduction_176 happy_x_1 + = happyIn58 + (cmmVec 2 f64 + ) + +happyReduce_177 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_177 = happySpecReduce_1 54# happyReduction_177 +happyReduction_177 happy_x_1 + = happyIn58 + (cmmVec 4 f64 + ) + +happyReduce_178 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_178 = happySpecReduce_1 54# happyReduction_178 +happyReduction_178 happy_x_1 + = happyIn58 + (cmmVec 8 f64 + ) + +happyReduce_179 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_179 = happySpecReduce_1 54# happyReduction_179 +happyReduction_179 happy_x_1 + = happyIn58 + (f32 + ) + +happyReduce_180 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_180 = happySpecReduce_1 54# happyReduction_180 +happyReduction_180 happy_x_1 + = happyIn58 + (f64 + ) + +happyReduce_181 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_181 = happyMonadReduce 1# 54# happyReduction_181 +happyReduction_181 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; return $ gcWord platform)) + ) (\r -> happyReturn (happyIn58 r)) + +happyNewToken action sts stk + = cmmlex(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + L _ CmmT_EOF -> happyDoAction 86# tk action sts stk; + L _ (CmmT_SpecChar ':') -> cont 1#; + L _ (CmmT_SpecChar ';') -> cont 2#; + L _ (CmmT_SpecChar '{') -> cont 3#; + L _ (CmmT_SpecChar '}') -> cont 4#; + L _ (CmmT_SpecChar '[') -> cont 5#; + L _ (CmmT_SpecChar ']') -> cont 6#; + L _ (CmmT_SpecChar '(') -> cont 7#; + L _ (CmmT_SpecChar ')') -> cont 8#; + L _ (CmmT_SpecChar '=') -> cont 9#; + L _ (CmmT_SpecChar '`') -> cont 10#; + L _ (CmmT_SpecChar '~') -> cont 11#; + L _ (CmmT_SpecChar '/') -> cont 12#; + L _ (CmmT_SpecChar '*') -> cont 13#; + L _ (CmmT_SpecChar '%') -> cont 14#; + L _ (CmmT_SpecChar '-') -> cont 15#; + L _ (CmmT_SpecChar '+') -> cont 16#; + L _ (CmmT_SpecChar '&') -> cont 17#; + L _ (CmmT_SpecChar '^') -> cont 18#; + L _ (CmmT_SpecChar '|') -> cont 19#; + L _ (CmmT_SpecChar '>') -> cont 20#; + L _ (CmmT_SpecChar '<') -> cont 21#; + L _ (CmmT_SpecChar ',') -> cont 22#; + L _ (CmmT_SpecChar '!') -> cont 23#; + L _ (CmmT_DotDot) -> cont 24#; + L _ (CmmT_DoubleColon) -> cont 25#; + L _ (CmmT_Shr) -> cont 26#; + L _ (CmmT_Shl) -> cont 27#; + L _ (CmmT_Ge) -> cont 28#; + L _ (CmmT_Le) -> cont 29#; + L _ (CmmT_Eq) -> cont 30#; + L _ (CmmT_Ne) -> cont 31#; + L _ (CmmT_BoolAnd) -> cont 32#; + L _ (CmmT_BoolOr) -> cont 33#; + L _ (CmmT_True ) -> cont 34#; + L _ (CmmT_False) -> cont 35#; + L _ (CmmT_likely) -> cont 36#; + L _ (CmmT_Relaxed) -> cont 37#; + L _ (CmmT_Acquire) -> cont 38#; + L _ (CmmT_Release) -> cont 39#; + L _ (CmmT_SeqCst) -> cont 40#; + L _ (CmmT_CLOSURE) -> cont 41#; + L _ (CmmT_INFO_TABLE) -> cont 42#; + L _ (CmmT_INFO_TABLE_RET) -> cont 43#; + L _ (CmmT_INFO_TABLE_FUN) -> cont 44#; + L _ (CmmT_INFO_TABLE_CONSTR) -> cont 45#; + L _ (CmmT_INFO_TABLE_SELECTOR) -> cont 46#; + L _ (CmmT_else) -> cont 47#; + L _ (CmmT_export) -> cont 48#; + L _ (CmmT_section) -> cont 49#; + L _ (CmmT_goto) -> cont 50#; + L _ (CmmT_if) -> cont 51#; + L _ (CmmT_call) -> cont 52#; + L _ (CmmT_jump) -> cont 53#; + L _ (CmmT_foreign) -> cont 54#; + L _ (CmmT_never) -> cont 55#; + L _ (CmmT_prim) -> cont 56#; + L _ (CmmT_reserve) -> cont 57#; + L _ (CmmT_return) -> cont 58#; + L _ (CmmT_returns) -> cont 59#; + L _ (CmmT_import) -> cont 60#; + L _ (CmmT_switch) -> cont 61#; + L _ (CmmT_case) -> cont 62#; + L _ (CmmT_default) -> cont 63#; + L _ (CmmT_push) -> cont 64#; + L _ (CmmT_unwind) -> cont 65#; + L _ (CmmT_bits8) -> cont 66#; + L _ (CmmT_bits16) -> cont 67#; + L _ (CmmT_bits32) -> cont 68#; + L _ (CmmT_bits64) -> cont 69#; + L _ (CmmT_vec128) -> cont 70#; + L _ (CmmT_vec256) -> cont 71#; + L _ (CmmT_vec512) -> cont 72#; + L _ (CmmT_float32) -> cont 73#; + L _ (CmmT_float64) -> cont 74#; + L _ (CmmT_gcptr) -> cont 75#; + L _ (CmmT_GlobalReg happy_dollar_dollar) -> cont 76#; + L _ (CmmT_Name happy_dollar_dollar) -> cont 77#; + L _ (CmmT_String happy_dollar_dollar) -> cont 78#; + L _ (CmmT_Int happy_dollar_dollar) -> cont 79#; + L _ (CmmT_Float happy_dollar_dollar) -> cont 80#; + L _ (CmmT_GlobalArgRegs GP_ARG_REGS) -> cont 81#; + L _ (CmmT_GlobalArgRegs SCALAR_ARG_REGS) -> cont 82#; + L _ (CmmT_GlobalArgRegs V16_ARG_REGS) -> cont 83#; + L _ (CmmT_GlobalArgRegs V32_ARG_REGS) -> cont 84#; + L _ (CmmT_GlobalArgRegs V64_ARG_REGS) -> cont 85#; + _ -> happyError' (tk, []) + }) + +happyError_ explist 86# tk = happyError' (tk, explist) +happyError_ explist _ tk = happyError' (tk, explist) + +happyThen :: () => PD a -> (a -> PD b) -> PD b +happyThen = (>>=) +happyReturn :: () => a -> PD a +happyReturn = (return) +happyParse :: () => Happy_GHC_Exts.Int# -> PD (HappyAbsSyn ) + +happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) + +happyDoAction :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) + +happyReduceArr :: () => Happy_Data_Array.Array Prelude.Int (Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )) + +happyThen1 :: () => PD a -> (a -> PD b) -> PD b +happyThen1 = happyThen +happyReturn1 :: () => a -> PD a +happyReturn1 = happyReturn +happyError' :: () => ((Located CmmToken), [Prelude.String]) -> PD a +happyError' tk = (\(tokens, explist) -> happyError) tk +cmmParse = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (let {(HappyWrap4 x') = happyOut4 x} in x')) + +happySeq = happyDoSeq + + +section :: String -> SectionType +section "text" = Text +section "data" = Data +section "rodata" = ReadOnlyData +section "relrodata" = RelocatableReadOnlyData +section "bss" = UninitialisedData +section s = OtherSection s + +mkString :: String -> CmmStatic +mkString s = CmmString (BS8.pack s) + +-- mkMachOp infers the type of the MachOp from the type of its first +-- argument. We assume that this is correct: for MachOps that don't have +-- symmetrical args (e.g. shift ops), the first arg determines the type of +-- the op. +mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr +mkMachOp fn args = do + platform <- getPlatform + arg_exprs <- sequence args + return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs) + +getLit :: CmmExpr -> CmmLit +getLit (CmmLit l) = l +getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r +getLit _ = panic "invalid literal" -- TODO messy failure + +nameToMachOp :: FastString -> PD (Width -> MachOp) +nameToMachOp name = + case lookupUFM machOps name of + Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name) + Just m -> return m + +exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) +exprOp name args_code = do + pdc <- PD.getPDConfig + let profile = PD.pdProfile pdc + let align_check = PD.pdSanitizeAlignment pdc + case lookupUFM (exprMacros profile align_check) name of + Just f -> return $ do + args <- sequence args_code + return (f args) + Nothing -> do + mo <- nameToMachOp name + return $ mkMachOp mo args_code + +exprMacros :: Profile -> DoAlignSanitisation -> UniqFM FastString ([CmmExpr] -> CmmExpr) +exprMacros profile align_check = listToUFM [ + ( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ), + ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr platform align_check x ), + ( fsLit "STD_INFO", \ [x] -> infoTable profile x ), + ( fsLit "FUN_INFO", \ [x] -> funInfoTable profile x ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr platform align_check x) ), + ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr platform align_check x) ), + ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr platform align_check x) ), + ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType profile x ), + ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs profile x ), + ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs profile x ) + ] + where + platform = profilePlatform profile + +-- we understand a subset of C-- primitives: +machOps :: UniqFM FastString (Width -> MachOp) +machOps = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "add", MO_Add ), + ( "sub", MO_Sub ), + ( "eq", MO_Eq ), + ( "ne", MO_Ne ), + ( "mul", MO_Mul ), + ( "mulmayoflo", MO_S_MulMayOflo ), + ( "neg", MO_S_Neg ), + ( "quot", MO_S_Quot ), + ( "rem", MO_S_Rem ), + ( "divu", MO_U_Quot ), + ( "modu", MO_U_Rem ), + + ( "ge", MO_S_Ge ), + ( "le", MO_S_Le ), + ( "gt", MO_S_Gt ), + ( "lt", MO_S_Lt ), + + ( "geu", MO_U_Ge ), + ( "leu", MO_U_Le ), + ( "gtu", MO_U_Gt ), + ( "ltu", MO_U_Lt ), + + ( "and", MO_And ), + ( "or", MO_Or ), + ( "xor", MO_Xor ), + ( "com", MO_Not ), + ( "shl", MO_Shl ), + ( "shrl", MO_U_Shr ), + ( "shra", MO_S_Shr ), + + ( "fadd", MO_F_Add ), + ( "fsub", MO_F_Sub ), + ( "fneg", MO_F_Neg ), + ( "fmul", MO_F_Mul ), + ( "fquot", MO_F_Quot ), + ( "fmin", MO_F_Min ), + ( "fmax", MO_F_Max ), + + ( "fmadd" , MO_FMA FMAdd 1 ), + ( "fmsub" , MO_FMA FMSub 1 ), + ( "fnmadd", MO_FMA FNMAdd 1 ), + ( "fnmsub", MO_FMA FNMSub 1 ), + + ( "feq", MO_F_Eq ), + ( "fne", MO_F_Ne ), + ( "fge", MO_F_Ge ), + ( "fle", MO_F_Le ), + ( "fgt", MO_F_Gt ), + ( "flt", MO_F_Lt ), + + ( "lobits8", flip MO_UU_Conv W8 ), + ( "lobits16", flip MO_UU_Conv W16 ), + ( "lobits32", flip MO_UU_Conv W32 ), + ( "lobits64", flip MO_UU_Conv W64 ), + + ( "zx16", flip MO_UU_Conv W16 ), + ( "zx32", flip MO_UU_Conv W32 ), + ( "zx64", flip MO_UU_Conv W64 ), + + ( "sx16", flip MO_SS_Conv W16 ), + ( "sx32", flip MO_SS_Conv W32 ), + ( "sx64", flip MO_SS_Conv W64 ), + + ( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode + ( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode + ( "f2i8", flip MO_FS_Truncate W8 ), + ( "f2i16", flip MO_FS_Truncate W16 ), + ( "f2i32", flip MO_FS_Truncate W32 ), + ( "f2i64", flip MO_FS_Truncate W64 ), + ( "i2f32", flip MO_SF_Round W32 ), + ( "i2f64", flip MO_SF_Round W64 ), + + ( "w2f_bitcast", MO_WF_Bitcast ), + ( "f2w_bitcast", MO_FW_Bitcast ) + ] + +callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr])) +callishMachOps platform = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + + ( "pow64f", (MO_F64_Pwr,) ), + ( "sin64f", (MO_F64_Sin,) ), + ( "cos64f", (MO_F64_Cos,) ), + ( "tan64f", (MO_F64_Tan,) ), + ( "sinh64f", (MO_F64_Sinh,) ), + ( "cosh64f", (MO_F64_Cosh,) ), + ( "tanh64f", (MO_F64_Tanh,) ), + ( "asin64f", (MO_F64_Asin,) ), + ( "acos64f", (MO_F64_Acos,) ), + ( "atan64f", (MO_F64_Atan,) ), + ( "asinh64f", (MO_F64_Asinh,) ), + ( "acosh64f", (MO_F64_Acosh,) ), + ( "log64f", (MO_F64_Log,) ), + ( "log1p64f", (MO_F64_Log1P,) ), + ( "exp64f", (MO_F64_Exp,) ), + ( "expM164f", (MO_F64_ExpM1,) ), + ( "fabs64f", (MO_F64_Fabs,) ), + ( "sqrt64f", (MO_F64_Sqrt,) ), + + ( "pow32f", (MO_F32_Pwr,) ), + ( "sin32f", (MO_F32_Sin,) ), + ( "cos32f", (MO_F32_Cos,) ), + ( "tan32f", (MO_F32_Tan,) ), + ( "sinh32f", (MO_F32_Sinh,) ), + ( "cosh32f", (MO_F32_Cosh,) ), + ( "tanh32f", (MO_F32_Tanh,) ), + ( "asin32f", (MO_F32_Asin,) ), + ( "acos32f", (MO_F32_Acos,) ), + ( "atan32f", (MO_F32_Atan,) ), + ( "asinh32f", (MO_F32_Asinh,) ), + ( "acosh32f", (MO_F32_Acosh,) ), + ( "log32f", (MO_F32_Log,) ), + ( "log1p32f", (MO_F32_Log1P,) ), + ( "exp32f", (MO_F32_Exp,) ), + ( "expM132f", (MO_F32_ExpM1,) ), + ( "fabs32f", (MO_F32_Fabs,) ), + ( "sqrt32f", (MO_F32_Sqrt,) ), + + -- TODO: It would be nice to rename the following operations to + -- acquire_fence and release_fence. Be aware that there'll be issues + -- with an overlapping token ('acquire') in the lexer. + ( "fence_acquire", (MO_AcquireFence,)), + ( "fence_release", (MO_ReleaseFence,)), + ( "fence_seq_cst", (MO_SeqCstFence,)), + + ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ), + ( "memset", memcpyLikeTweakArgs MO_Memset ), + ( "memmove", memcpyLikeTweakArgs MO_Memmove ), + ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ), + + ( "suspendThread", (MO_SuspendThread,) ), + ( "resumeThread", (MO_ResumeThread,) ), + + ( "prefetch0", (MO_Prefetch_Data 0,)), + ( "prefetch1", (MO_Prefetch_Data 1,)), + ( "prefetch2", (MO_Prefetch_Data 2,)), + ( "prefetch3", (MO_Prefetch_Data 3,)), + + ( "bswap16", (MO_BSwap W16,) ), + ( "bswap32", (MO_BSwap W32,) ), + ( "bswap64", (MO_BSwap W64,) ) + ] ++ concat + [ allWidths "popcnt" MO_PopCnt + , allWidths "pdep" MO_Pdep + , allWidths "pext" MO_Pext + , allWidths "cmpxchg" MO_Cmpxchg + , allWidths "xchg" MO_Xchg + , allWidths "load_relaxed" (\w -> MO_AtomicRead w MemOrderAcquire) + , allWidths "load_acquire" (\w -> MO_AtomicRead w MemOrderAcquire) + , allWidths "load_seqcst" (\w -> MO_AtomicRead w MemOrderSeqCst) + , allWidths "store_release" (\w -> MO_AtomicWrite w MemOrderRelease) + , allWidths "store_seqcst" (\w -> MO_AtomicWrite w MemOrderSeqCst) + , allWidths "fetch_add" (\w -> MO_AtomicRMW w AMO_Add) + , allWidths "fetch_sub" (\w -> MO_AtomicRMW w AMO_Sub) + , allWidths "fetch_and" (\w -> MO_AtomicRMW w AMO_And) + , allWidths "fetch_nand" (\w -> MO_AtomicRMW w AMO_Nand) + , allWidths "fetch_or" (\w -> MO_AtomicRMW w AMO_Or) + , allWidths "fetch_xor" (\w -> MO_AtomicRMW w AMO_Xor) + , allWidths "mul2_" (\w -> MO_S_Mul2 w) + , allWidths "mul2u_" (\w -> MO_U_Mul2 w) + ] + where + allWidths + :: String + -> (Width -> CallishMachOp) + -> [(FastString, a -> (CallishMachOp, a))] + allWidths name f = + [ (mkFastString $ name ++ show (widthInBits w), (f w,)) + | w <- [W8, W16, W32, W64] + ] + + memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr]) + memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument" + memcpyLikeTweakArgs op args@(_:_) = + (op align, args') + where + args' = init args + align = case last args of + CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger + e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (pdoc platform e) + -- The alignment of memcpy-ish operations must be a + -- compile-time constant. We verify this here, passing it around + -- in the MO_* constructor. In order to do this, however, we + -- must intercept the arguments in primCall. + +parseSafety :: String -> PD Safety +parseSafety "safe" = return PlaySafe +parseSafety "unsafe" = return PlayRisky +parseSafety "interruptible" = return PlayInterruptible +parseSafety str = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ + PsErrCmmParser (CmmUnrecognisedSafety str) + +parseCmmHint :: String -> PD ForeignHint +parseCmmHint "ptr" = return AddrHint +parseCmmHint "signed" = return SignedHint +parseCmmHint str = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ + PsErrCmmParser (CmmUnrecognisedHint str) + +-- labels are always pointers, so we might as well infer the hint +inferCmmHint :: CmmExpr -> ForeignHint +inferCmmHint (CmmLit (CmmLabel _)) + = AddrHint +inferCmmHint (CmmReg (CmmGlobal reg)) + | isPtrGlobalRegUse reg + = AddrHint +inferCmmHint _ + = NoHint + +isPtrGlobalRegUse :: GlobalRegUse -> Bool +isPtrGlobalRegUse (GlobalRegUse reg ty) + | VanillaReg {} <- reg + , isGcPtrType ty + = True + | otherwise + = go reg + where + go Sp = True + go SpLim = True + go Hp = True + go HpLim = True + go CCCS = True + go CurrentTSO = True + go CurrentNursery = True + go _ = False + +happyError :: PD a +happyError = PD $ \_ _ s -> unP srcParseFail s + +-- ----------------------------------------------------------------------------- +-- Statement-level macros + +stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) +stmtMacro fun args_code = do + case lookupUFM stmtMacros fun of + Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownMacro fun) + Just fcode -> return $ do + args <- sequence args_code + code (fcode args) + +stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ()) +stmtMacros = listToUFM [ + ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), + ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), + + ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), + ( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ), + + -- completely generic heap and stack checks, for use in high-level cmm. + ( fsLit "HP_CHK_GEN", \[bytes] -> + heapStackCheckGen Nothing (Just bytes) ), + ( fsLit "STK_CHK_GEN", \[] -> + heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ), + + -- A stack check for a fixed amount of stack. Sounds a bit strange, but + -- we use the stack for a bit of temporary storage in a couple of primops + ( fsLit "STK_CHK_GEN_N", \[bytes] -> + heapStackCheckGen (Just bytes) Nothing ), + + -- A stack check on entry to a thunk, where the argument is the thunk pointer. + ( fsLit "STK_CHK_NP" , \[node] -> entryHeapCheck' False node 0 [] (return ())), + + ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), + ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), + + ( fsLit "SAVE_GP_ARG_REGS", \[] -> emitSaveRegs GP_ARG_REGS ), + ( fsLit "RESTORE_GP_ARG_REGS", \[] -> emitRestoreRegs GP_ARG_REGS ), + ( fsLit "SAVE_SCALAR_ARG_REGS", \[] -> emitSaveRegs SCALAR_ARG_REGS ), + ( fsLit "RESTORE_SCALAR_ARG_REGS", \[] -> emitRestoreRegs SCALAR_ARG_REGS ), + ( fsLit "SAVE_V16_ARG_REGS", \[] -> emitSaveRegs V16_ARG_REGS ), + ( fsLit "RESTORE_V16_ARG_REGS", \[] -> emitRestoreRegs V16_ARG_REGS ), + ( fsLit "SAVE_V32_ARG_REGS", \[] -> emitSaveRegs V32_ARG_REGS ), + ( fsLit "RESTORE_V32_ARG_REGS", \[] -> emitRestoreRegs V32_ARG_REGS ), + ( fsLit "SAVE_V64_ARG_REGS", \[] -> emitSaveRegs V64_ARG_REGS ), + ( fsLit "RESTORE_V64_ARG_REGS", \[] -> emitRestoreRegs V64_ARG_REGS ), + + ( fsLit "PUSH_SCALAR_ARG_REGS", \[live_regs] -> emitPushArgRegs SCALAR_ARG_REGS live_regs ), + ( fsLit "POP_SCALAR_ARG_REGS", \[live_regs] -> emitPopArgRegs SCALAR_ARG_REGS live_regs ), + + ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), + ( fsLit "PROF_HEADER_CREATE", \[e] -> profHeaderCreate e ), + + ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), + ( fsLit "PUSH_BH_UPD_FRAME", \[sp,e] -> emitPushBHUpdateFrame sp e ), + ( fsLit "SET_HDR", \[ptr,info,ccs] -> + emitSetDynHdr ptr info ccs ), + ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> + tickyAllocPrim hdr goods slop ), + ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> + tickyAllocPAP goods slop ), + ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> + tickyAllocThunk goods slop ), + ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode reg ) + ] + +emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () +emitPushUpdateFrame sp e = do + emitUpdateFrame sp mkUpdInfoLabel e + +emitPushBHUpdateFrame :: CmmExpr -> CmmExpr -> FCode () +emitPushBHUpdateFrame sp e = do + emitUpdateFrame sp mkBHUpdInfoLabel e + +pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () +pushStackFrame fields body = do + profile <- getProfile + exprs <- sequence fields + updfr_off <- getUpdFrameOff + let (new_updfr_off, _, g) = copyOutOflow profile NativeReturn Ret Old + [] updfr_off exprs + emit g + withUpdFrameOff new_updfr_off body + +reserveStackFrame + :: CmmParse CmmExpr + -> CmmParse CmmReg + -> CmmParse () + -> CmmParse () +reserveStackFrame psize preg body = do + platform <- getPlatform + old_updfr_off <- getUpdFrameOff + reg <- preg + esize <- psize + let size = case constantFoldExpr platform esize of + CmmLit (CmmInt n _) -> n + _other -> pprPanic "CmmParse: not a compile-time integer: " + (pdoc platform esize) + let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size + emitAssign reg (CmmStackSlot Old frame) + withUpdFrameOff frame body + +profilingInfo profile desc_str ty_str + = if not (profileIsProfiling profile) + then NoProfilingInfo + else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str) + +staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () +staticClosure pkg cl_label info payload + = do profile <- getProfile + let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] [] + code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits + +foreignCall + :: String + -> [CmmParse (LocalReg, ForeignHint)] + -> CmmParse CmmExpr + -> [CmmParse (CmmExpr, ForeignHint)] + -> Safety + -> CmmReturnInfo + -> PD (CmmParse ()) +foreignCall conv_string results_code expr_code args_code safety ret + = do conv <- case conv_string of + "C" -> return CCallConv + "stdcall" -> return StdCallConv + _ -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ + PsErrCmmParser (CmmUnknownCConv conv_string) + return $ do + platform <- getPlatform + results <- sequence results_code + expr <- expr_code + args <- sequence args_code + let + (arg_exprs, arg_hints) = unzip args + (res_regs, res_hints) = unzip results + fc = ForeignConvention conv arg_hints res_hints ret + target = ForeignTarget expr fc + _ <- code $ emitForeignCall safety res_regs target arg_exprs + return () + + +doReturn :: [CmmParse CmmExpr] -> CmmParse () +doReturn exprs_code = do + profile <- getProfile + exprs <- sequence exprs_code + updfr_off <- getUpdFrameOff + emit (mkReturnSimple profile exprs updfr_off) + +mkReturnSimple :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkReturnSimple profile actuals updfr_off = + mkReturn profile e actuals updfr_off + where e = entryCode platform (cmmLoadGCWord platform (CmmStackSlot Old updfr_off)) + platform = profilePlatform profile + +doRawJump :: CmmParse CmmExpr -> [GlobalRegUse] -> CmmParse () +doRawJump expr_code vols = do + profile <- getProfile + expr <- expr_code + updfr_off <- getUpdFrameOff + emit (mkRawJump profile expr updfr_off vols) + +doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr] + -> [CmmParse CmmExpr] -> CmmParse () +doJumpWithStack expr_code stk_code args_code = do + profile <- getProfile + expr <- expr_code + stk_args <- sequence stk_code + args <- sequence args_code + updfr_off <- getUpdFrameOff + emit (mkJumpExtra profile NativeNodeCall expr args updfr_off stk_args) + +doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] + -> CmmParse () +doCall expr_code res_code args_code = do + expr <- expr_code + args <- sequence args_code + ress <- sequence res_code + updfr_off <- getUpdFrameOff + c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] + emit c + +primCall + :: [CmmParse (CmmFormal, ForeignHint)] + -> FastString + -> [CmmParse CmmExpr] + -> PD (CmmParse ()) +primCall results_code name args_code + = do + platform <- PD.getPlatform + case lookupUFM (callishMachOps platform) name of + Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name) + Just f -> return $ do + results <- sequence results_code + args <- sequence args_code + let (p, args') = f args + code (emitPrimCall (map fst results) p args') + +doStore :: Maybe MemoryOrdering + -> CmmType + -> CmmParse CmmExpr -- ^ address + -> CmmParse CmmExpr -- ^ value + -> CmmParse () +doStore mem_ord rep addr_code val_code + = do platform <- getPlatform + addr <- addr_code + val <- val_code + -- if the specified store type does not match the type of the expr + -- on the rhs, then we insert a coercion that will cause the type + -- mismatch to be flagged by cmm-lint. If we don't do this, then + -- the store will happen at the wrong type, and the error will not + -- be noticed. + let val_width = typeWidth (cmmExprType platform val) + rep_width = typeWidth rep + let coerce_val + | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] + | otherwise = val + emitStore mem_ord addr coerce_val + +-- ----------------------------------------------------------------------------- +-- If-then-else and boolean expressions + +data BoolExpr + = BoolExpr `BoolAnd` BoolExpr + | BoolExpr `BoolOr` BoolExpr + | BoolNot BoolExpr + | BoolTest CmmExpr + +-- ToDo: smart constructors which simplify the boolean expression. + +cmmIfThenElse cond then_part else_part likely = do + then_id <- newBlockId + join_id <- newBlockId + c <- cond + emitCond c then_id likely + else_part + emit (mkBranch join_id) + emitLabel then_id + then_part + -- fall through to join + emitLabel join_id + +cmmRawIf cond then_id likely = do + c <- cond + emitCond c then_id likely + +-- 'emitCond cond true_id' emits code to test whether the cond is true, +-- branching to true_id if so, and falling through otherwise. +emitCond (BoolTest e) then_id likely = do + else_id <- newBlockId + emit (mkCbranch e then_id else_id likely) + emitLabel else_id +emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely + | Just op' <- maybeInvertComparison op + = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely) +emitCond (BoolNot e) then_id likely = do + else_id <- newBlockId + emitCond e else_id likely + emit (mkBranch then_id) + emitLabel else_id +emitCond (e1 `BoolOr` e2) then_id likely = do + emitCond e1 then_id likely + emitCond e2 then_id likely +emitCond (e1 `BoolAnd` e2) then_id likely = do + -- we'd like to invert one of the conditionals here to avoid an + -- extra branch instruction, but we can't use maybeInvertComparison + -- here because we can't look too closely at the expression since + -- we're in a loop. + and_id <- newBlockId + else_id <- newBlockId + emitCond e1 and_id likely + emit (mkBranch else_id) + emitLabel and_id + emitCond e2 then_id likely + emitLabel else_id + +-- ----------------------------------------------------------------------------- +-- Source code notes + +-- | Generate a source note spanning from "a" to "b" (inclusive), then +-- proceed with parsing. This allows debugging tools to reason about +-- locations in Cmm code. +withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c +withSourceNote a b parse = do + name <- getName + case combineSrcSpans (getLoc a) (getLoc b) of + RealSrcSpan span _ -> code (emitTick (SourceNote span $ LexicalFastString $ mkFastString name)) >> parse + _other -> parse + +-- ----------------------------------------------------------------------------- +-- Table jumps + +-- We use a simplified form of C-- switch statements for now. A +-- switch statement always compiles to a table jump. Each arm can +-- specify a list of values (not ranges), and there can be a single +-- default branch. The range of the table is given either by the +-- optional range on the switch (eg. switch [0..7] {...}), or by +-- the minimum/maximum values from the branches. + +doSwitch :: Maybe (Integer,Integer) + -> CmmParse CmmExpr + -> [([Integer],Either BlockId (CmmParse ()))] + -> Maybe (CmmParse ()) -> CmmParse () +doSwitch mb_range scrut arms deflt + = do + -- Compile code for the default branch + dflt_entry <- + case deflt of + Nothing -> return Nothing + Just e -> do b <- forkLabelledCode e; return (Just b) + + -- Compile each case branch + table_entries <- mapM emitArm arms + let table = M.fromList (concat table_entries) + + platform <- getPlatform + let range = fromMaybe (0, platformMaxWord platform) mb_range + + expr <- scrut + -- ToDo: check for out of range and jump to default if necessary + emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table) + where + emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)] + emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] + emitArm (ints,Right code) = do + blockid <- forkLabelledCode code + return [ (i,blockid) | i <- ints ] + +forkLabelledCode :: CmmParse () -> CmmParse BlockId +forkLabelledCode p = do + (_,ag) <- getCodeScoped p + l <- newBlockId + emitOutOfLine l ag + return l + +-- ----------------------------------------------------------------------------- +-- Putting it all together + +-- The initial environment: we define some constants that the compiler +-- knows about here. +initEnv :: Profile -> Env +initEnv profile = listToUFM [ + ( fsLit "SIZEOF_StgHeader", + VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize profile)) (wordWidth platform)) )), + ( fsLit "SIZEOF_StgInfoTable", + VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB profile)) (wordWidth platform)) )) + ] + where platform = profilePlatform profile + +parseCmmFile :: CmmParserConfig + -> Module + -> HomeUnit + -> FilePath + -> IO (Messages PsMessage, Messages PsMessage, Maybe (DCmmGroup, [InfoProvEnt])) +parseCmmFile cmmpConfig this_mod home_unit filename = do + buf <- hGetStringBuffer filename + let + init_loc = mkRealSrcLoc (mkFastString filename) 1 1 + init_state = (initParserState (cmmpParserOpts cmmpConfig) buf init_loc) { lex_state = [0] } + -- reset the lex_state: the Lexer monad leaves some stuff + -- in there we don't want. + pdConfig = cmmpPDConfig cmmpConfig + case unPD cmmParse pdConfig home_unit init_state of + PFailed pst -> do + let (warnings,errors) = getPsMessages pst + return (warnings, errors, Nothing) + POk pst code -> do + st <- initC + let fstate = F.initFCodeState (profilePlatform $ pdProfile pdConfig) + let fcode = do + ((), cmm) <- getCmm $ unEC code "global" (initEnv (pdProfile pdConfig)) [] >> return () + -- See Note [Mapping Info Tables to Source Positions] (IPE Maps) + let used_info + | do_ipe = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTableD cmm) + | otherwise = [] + where + do_ipe = stgToCmmInfoTableMap $ cmmpStgToCmmConfig cmmpConfig + -- We need to pass a deterministic unique supply to generate IPE + -- symbols deterministically. The symbols created by + -- emitIpeBufferListNode must all be local to the object (see + -- comment on its definition). If the symbols weren't local, using a + -- counter starting from zero for every Cmm file would cause + -- conflicts when compiling more than one Cmm file together. + (_, cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info (initDUniqSupply 'P' 0) + return (cmm ++ cmm2, used_info) + (cmm, _) = runC (cmmpStgToCmmConfig cmmpConfig) fstate st fcode + (warnings,errors) = getPsMessages pst + if not (isEmptyMessages errors) + then return (warnings, errors, Nothing) + else return (warnings, errors, Just cmm) +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ + + + + + + + + + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Prelude.Bool) +#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Prelude.Bool) +#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Prelude.Bool) +#else +#define LT(n,m) (n Happy_GHC_Exts.<# m) +#define GTE(n,m) (n Happy_GHC_Exts.>=# m) +#define EQ(n,m) (n Happy_GHC_Exts.==# m) +#endif + + + + + + + + + + + + + + + + + + + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is ERROR_TOK, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + case action of + 0# -> {- nothing -} + happyFail (happyExpListPerState ((Happy_GHC_Exts.I# (st)) :: Prelude.Int)) i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + happyShift new_state i tk st + where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where off = happyAdjustOffset (indexShortOffAddr happyActOffsets st) + off_i = (off Happy_GHC_Exts.+# i) + check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) + then EQ(indexShortOffAddr happyCheck off_i, i) + else Prelude.False + action + | check = indexShortOffAddr happyTable off_i + | Prelude.otherwise = indexShortOffAddr happyDefActions st + + + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# + + + + +{-# INLINE happyLt #-} +happyLt x y = LT(x,y) + + +readArrayBit arr bit = + Bits.testBit (Happy_GHC_Exts.I# (indexShortOffAddr arr ((unbox_int bit) `Happy_GHC_Exts.iShiftRA#` 4#))) (bit `Prelude.mod` 16) + where unbox_int (Happy_GHC_Exts.I# x) = x + + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + + + + + + + + + + + + + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk + + off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st1) + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st) + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (ERROR_TOK is the error token) + +-- parse error if we are in recovery and we fail again +happyFail explist 0# tk old_st _ stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "failing" $ + happyError_ explist i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail explist i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ((Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = Prelude.error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `Prelude.seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/GHC/Cmm/Parser/Config.hs b/GHC/Cmm/Parser/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Parser/Config.hs @@ -0,0 +1,24 @@ +module GHC.Cmm.Parser.Config ( + PDConfig(..) + , CmmParserConfig(..) +) where + +import GHC.Prelude + +import GHC.Platform.Profile + +import GHC.StgToCmm.Config + +import GHC.Parser.Lexer + + +data PDConfig = PDConfig + { pdProfile :: !Profile + , pdSanitizeAlignment :: !Bool -- ^ Insert alignment checks (cf @-falignment-sanitisation@) + } + +data CmmParserConfig = CmmParserConfig + { cmmpParserOpts :: !ParserOpts + , cmmpPDConfig :: !PDConfig + , cmmpStgToCmmConfig :: !StgToCmmConfig + } diff --git a/GHC/Cmm/Parser/Monad.hs b/GHC/Cmm/Parser/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Parser/Monad.hs @@ -0,0 +1,75 @@ +----------------------------------------------------------------------------- +-- A Parser monad with access to the 'DynFlags'. +-- +-- The 'P' monad only has access to the subset of 'DynFlags' +-- required for parsing Haskell. + +-- The parser for C-- requires access to a lot more of the 'DynFlags', +-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance. +----------------------------------------------------------------------------- +module GHC.Cmm.Parser.Monad ( + PD(..) + , liftP + , failMsgPD + , getPDConfig + , getProfile + , getPlatform + , getHomeUnitId + , PDConfig(..) + ) where + +import GHC.Prelude + +import GHC.Cmm.Parser.Config + +import GHC.Platform +import GHC.Platform.Profile + +import Control.Monad + +import GHC.Parser.Lexer +import GHC.Parser.Errors.Types +import GHC.Types.Error ( MsgEnvelope ) +import GHC.Types.SrcLoc +import GHC.Unit.Types +import GHC.Unit.Home + +newtype PD a = PD { unPD :: PDConfig -> HomeUnit -> PState -> ParseResult a } + +instance Functor PD where + fmap = liftM + +instance Applicative PD where + pure = returnPD + (<*>) = ap + +instance Monad PD where + (>>=) = thenPD + +liftP :: P a -> PD a +liftP (P f) = PD $ \_ _ s -> f s + +failMsgPD :: (SrcSpan -> MsgEnvelope PsMessage) -> PD a +failMsgPD = liftP . failMsgP + +returnPD :: a -> PD a +returnPD = liftP . return + +thenPD :: PD a -> (a -> PD b) -> PD b +(PD m) `thenPD` k = PD $ \d hu s -> + case m d hu s of + POk s1 a -> unPD (k a) d hu s1 + PFailed s1 -> PFailed s1 + +getPDConfig :: PD PDConfig +getPDConfig = PD $ \pdc _ s -> POk s pdc + +getProfile :: PD Profile +getProfile = PD $ \pdc _ s -> POk s (pdProfile pdc) + +getPlatform :: PD Platform +getPlatform = profilePlatform <$> getProfile + +-- | Return the UnitId of the home-unit. This is used to create labels. +getHomeUnitId :: PD UnitId +getHomeUnitId = PD $ \_ hu s -> POk s (homeUnitId hu) diff --git a/GHC/Cmm/Pipeline.hs b/GHC/Cmm/Pipeline.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Pipeline.hs @@ -0,0 +1,381 @@ + +module GHC.Cmm.Pipeline ( + cmmPipeline +) where + +import GHC.Prelude + +import GHC.Driver.Flags + +import GHC.Cmm +import GHC.Cmm.Config +import GHC.Cmm.ContFlowOpt +import GHC.Cmm.CommonBlockElim +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Info.Build +import GHC.Cmm.Lint +import GHC.Cmm.LayoutStack +import GHC.Cmm.ProcPoint +import GHC.Cmm.Sink +import GHC.Cmm.Switch.Implement +import GHC.Cmm.ThreadSanitizer + +import GHC.Types.Unique.Supply +import GHC.Types.Unique.DSM + +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Misc ( partitionWith ) + +import GHC.Platform + +import Control.Monad +import GHC.Utils.Monad (mapAccumLM) + +----------------------------------------------------------------------------- +-- | Top level driver for C-- pipeline +----------------------------------------------------------------------------- + +-- | Converts C-- with an implicit stack and native C-- calls into +-- optimized, CPS converted and native-call-less C--. The latter +-- C-- can be used to generate assembly. +cmmPipeline + :: Logger + -> CmmConfig + -> ModuleSRTInfo -- Info about SRTs generated so far + -> CmmGroup -- Input C-- with Procedures + -> DUniqSupply + -> IO ((ModuleSRTInfo, CmmGroupSRTs), DUniqSupply) -- Output CPS transformed C-- + +cmmPipeline logger cmm_config srtInfo prog dus0 = do + let forceRes ((info, group), us) = info `seq` us `seq` foldr seq () group + let platform = cmmPlatform cmm_config + withTimingSilent logger (text "Cmm pipeline") forceRes $ do + (dus1, prog') <- {-# SCC "tops" #-} mapAccumLM (cpsTop logger platform cmm_config) dus0 prog + let (procs, data_) = partitionWith id prog' + (srtInfo, dus, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo dus1 procs data_ + dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) + + return ((srtInfo, cmms), dus) + +-- | The Cmm pipeline for a single 'CmmDecl'. Returns: +-- +-- - in the case of a 'CmmProc': 'Left' of the resulting (possibly +-- proc-point-split) 'CmmDecl's and their 'CafEnv'. CAF analysis +-- necessarily happens *before* proc-point splitting, as described in Note +-- [SRTs]. +-- +-- - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing +cpsTop :: Logger -> Platform -> CmmConfig -> DUniqSupply -> CmmDecl -> IO (DUniqSupply, Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl)) +cpsTop _logger platform _ dus (CmmData section statics) = + return (dus, Right (cafAnalData platform statics, CmmData section statics)) +cpsTop logger platform cfg dus proc = + do + ----------- Control-flow optimisations ---------------------------------- + + -- The first round of control-flow optimisation speeds up the + -- later passes by removing lots of empty blocks, so we do it + -- even when optimisation isn't turned on. + -- + CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-} + return $ cmmCfgOptsProc splitting_proc_points proc + dump Opt_D_dump_cmm_cfg "Post control-flow optimisations (1)" g + + let !TopInfo {stack_info=StackInfo { arg_space = entry_off + , do_layout = do_layout }} = h + + ----------- Eliminate common blocks ------------------------------------- + g <- {-# SCC "elimCommonBlocks" #-} + condPass (cmmOptElimCommonBlks cfg) elimCommonBlocks g + Opt_D_dump_cmm_cbe "Post common block elimination" + + -- Any work storing block Labels must be performed _after_ + -- elimCommonBlocks + + ----------- Implement switches ------------------------------------------ + (g, dus) <- if cmmDoCmmSwitchPlans cfg + then {-# SCC "createSwitchPlans" #-} + pure $ runUniqueDSM dus $ cmmImplementSwitchPlans platform g + else pure (g, dus) + dump Opt_D_dump_cmm_switch "Post switch plan" g + + ----------- ThreadSanitizer instrumentation ----------------------------- + g <- {-# SCC "annotateTSAN" #-} + if cmmOptThreadSanitizer cfg + then do + -- TODO(#25273): Use the deterministic UniqDSM (ie `runUniqueDSM`) instead + -- of UniqSM (see `initUs_`) to guarantee deterministic objects + -- when doing thread sanitization. + us <- mkSplitUniqSupply 'u' + return $ initUs_ us $ + annotateTSAN platform g + else return g + dump Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g + + ----------- Proc points ------------------------------------------------- + let + call_pps :: ProcPointSet -- LabelMap + call_pps = {-# SCC "callProcPoints" #-} callProcPoints g + (proc_points, dus) <- + if splitting_proc_points + then do + let (pp, dus') = {-# SCC "minimalProcPointSet" #-} runUniqueDSM dus $ + minimalProcPointSet platform call_pps g + dumpWith logger Opt_D_dump_cmm_proc "Proc points" + FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g) + return (pp, dus') + else + return (call_pps, dus) + + ----------- Layout the stack and manifest Sp ---------------------------- + ((g, stackmaps), dus) <- pure $ + {-# SCC "layoutStack" #-} + if do_layout + then runUniqueDSM dus $ cmmLayoutStack cfg proc_points entry_off g + else ((g, mapEmpty), dus) + dump Opt_D_dump_cmm_sp "Layout Stack" g + + ----------- Sink and inline assignments -------------------------------- + g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] + condPass (cmmOptSink cfg) (cmmSink platform) g + Opt_D_dump_cmm_sink "Sink assignments" + + ------------- CAF analysis ---------------------------------------------- + let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g + dumpWith logger Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) + + (g, dus) <- if splitting_proc_points + then do + ------------- Split into separate procedures ----------------------- + let pp_map = {-# SCC "procPointAnalysis" #-} + procPointAnalysis proc_points g + dumpWith logger Opt_D_dump_cmm_procmap "procpoint map" + FormatCMM (ppr pp_map) + (g, dus) <- {-# SCC "splitAtProcPoints" #-} pure $ runUniqueDSM dus $ + splitAtProcPoints platform l call_pps proc_points pp_map + (CmmProc h l v g) + dumps Opt_D_dump_cmm_split "Post splitting" g + return (g, dus) + else + -- attach info tables to return points + return ([attachContInfoTables call_pps (CmmProc h l v g)], dus) + + ------------- Populate info tables with stack info ----------------- + g <- {-# SCC "setInfoTableStackMap" #-} + return $ map (setInfoTableStackMap platform stackmaps) g + dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g + + ----------- Control-flow optimisations ----------------------------- + g <- {-# SCC "cmmCfgOpts(2)" #-} + return $ if cmmOptControlFlow cfg + then map (cmmCfgOptsProc splitting_proc_points) g + else g + g <- return $ map (removeUnreachableBlocksProc platform) g + -- See Note [unreachable blocks] + dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations (2)" g + + return (dus, Left (cafEnv, g)) + + where dump = dumpGraph logger platform (cmmDoLinting cfg) + + dumps flag name + = mapM_ (dumpWith logger flag name FormatCMM . pdoc platform) + + condPass do_opt pass g dumpflag dumpname = + if do_opt + then do + g <- return $ pass g + dump dumpflag dumpname g + return g + else return g + + -- we don't need to split proc points for the NCG, unless + -- tablesNextToCode is off. The latter is because we have no + -- label to put on info tables for basic blocks that are not + -- the entry point. + splitting_proc_points = cmmSplitProcPoints cfg + +-- Note [Sinking after stack layout] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In the past we considered running sinking pass also before stack +-- layout, but after making some measurements we realized that: +-- +-- a) running sinking only before stack layout produces slower +-- code than running sinking only before stack layout +-- +-- b) running sinking both before and after stack layout produces +-- code that has the same performance as when running sinking +-- only after stack layout. +-- +-- In other words sinking before stack layout doesn't buy as anything. +-- +-- An interesting question is "why is it better to run sinking after +-- stack layout"? It seems that the major reason are stores and loads +-- generated by stack layout. Consider this code before stack layout: +-- +-- c1E: +-- _c1C::P64 = R3; +-- _c1B::P64 = R2; +-- _c1A::P64 = R1; +-- I64[(young + 8)] = c1D; +-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; +-- c1D: +-- R3 = _c1C::P64; +-- R2 = _c1B::P64; +-- R1 = _c1A::P64; +-- call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8; +-- +-- Stack layout pass will save all local variables live across a call +-- (_c1C, _c1B and _c1A in this example) on the stack just before +-- making a call and reload them from the stack after returning from a +-- call: +-- +-- c1E: +-- _c1C::P64 = R3; +-- _c1B::P64 = R2; +-- _c1A::P64 = R1; +-- I64[Sp - 32] = c1D; +-- P64[Sp - 24] = _c1A::P64; +-- P64[Sp - 16] = _c1B::P64; +-- P64[Sp - 8] = _c1C::P64; +-- Sp = Sp - 32; +-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; +-- c1D: +-- _c1A::P64 = P64[Sp + 8]; +-- _c1B::P64 = P64[Sp + 16]; +-- _c1C::P64 = P64[Sp + 24]; +-- R3 = _c1C::P64; +-- R2 = _c1B::P64; +-- R1 = _c1A::P64; +-- Sp = Sp + 32; +-- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8; +-- +-- If we don't run sinking pass after stack layout we are basically +-- left with such code. However, running sinking on this code can lead +-- to significant improvements: +-- +-- c1E: +-- I64[Sp - 32] = c1D; +-- P64[Sp - 24] = R1; +-- P64[Sp - 16] = R2; +-- P64[Sp - 8] = R3; +-- Sp = Sp - 32; +-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; +-- c1D: +-- R3 = P64[Sp + 24]; +-- R2 = P64[Sp + 16]; +-- R1 = P64[Sp + 8]; +-- Sp = Sp + 32; +-- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8; +-- +-- Now we only have 9 assignments instead of 15. +-- +-- There is one case when running sinking before stack layout could +-- be beneficial. Consider this: +-- +-- L1: +-- x = y +-- call f() returns L2 +-- L2: ...x...y... +-- +-- Since both x and y are live across a call to f, they will be stored +-- on the stack during stack layout and restored after the call: +-- +-- L1: +-- x = y +-- P64[Sp - 24] = L2 +-- P64[Sp - 16] = x +-- P64[Sp - 8] = y +-- Sp = Sp - 24 +-- call f() returns L2 +-- L2: +-- y = P64[Sp + 16] +-- x = P64[Sp + 8] +-- Sp = Sp + 24 +-- ...x...y... +-- +-- However, if we run sinking before stack layout we would propagate x +-- to its usage place (both x and y must be local register for this to +-- be possible - global registers cannot be floated past a call): +-- +-- L1: +-- x = y +-- call f() returns L2 +-- L2: ...y...y... +-- +-- Thus making x dead at the call to f(). If we ran stack layout now +-- we would generate less stores and loads: +-- +-- L1: +-- x = y +-- P64[Sp - 16] = L2 +-- P64[Sp - 8] = y +-- Sp = Sp - 16 +-- call f() returns L2 +-- L2: +-- y = P64[Sp + 8] +-- Sp = Sp + 16 +-- ...y...y... +-- +-- But since we don't see any benefits from running sinking before stack +-- layout, this situation probably doesn't arise too often in practice. +-- + +{- Note [inconsistent-pic-reg] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On x86/Darwin, PIC is implemented by inserting a sequence like + + call 1f + 1: popl %reg + +at the proc entry point, and then referring to labels as offsets from +%reg. If we don't split proc points, then we could have many entry +points in a proc that would need this sequence, and each entry point +would then get a different value for %reg. If there are any join +points, then at the join point we don't have a consistent value for +%reg, so we don't know how to refer to labels. + +Hence, on x86/Darwin, we have to split proc points, and then each proc +point will get its own PIC initialisation sequence. + +This isn't an issue on x86/ELF, where the sequence is + + call 1f + 1: popl %reg + addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg + +so %reg always has a consistent value: the address of +_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. + +-} + +{- Note [unreachable blocks] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +The control-flow optimiser sometimes leaves unreachable blocks behind +containing junk code. These aren't necessarily a problem, but +removing them is good because it might save time in the native code +generator later. + +-} + +dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO () +dumpGraph logger platform do_linting flag name g = do + when do_linting $ do_lint g + dumpWith logger flag name FormatCMM (pdoc platform g) + where + do_lint g = case cmmLintGraph platform g of + Just err -> do { fatalErrorMsg logger err + ; ghcExit logger 1 + } + Nothing -> return () + +dumpWith :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +dumpWith logger flag txt fmt sdoc = do + putDumpFileMaybe logger flag txt fmt sdoc + when (not (logHasDumpFlag logger flag)) $ + -- If `-ddump-cmm-verbose -ddump-to-file` is specified, + -- dump each Cmm pipeline stage output to a separate file. #16930 + when (logHasDumpFlag logger Opt_D_dump_cmm_verbose) + $ logDumpFile logger (mkDumpStyle alwaysQualify) flag txt fmt sdoc + putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc diff --git a/GHC/Cmm/ProcPoint.hs b/GHC/Cmm/ProcPoint.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/ProcPoint.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE GADTs #-} + +module GHC.Cmm.ProcPoint + ( ProcPointSet, Status(..) + , callProcPoints, minimalProcPointSet + , splitAtProcPoints, procPointAnalysis + , attachContInfoTables + ) +where + +import GHC.Prelude hiding (last, unzip, succ, zip) + +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Info +import GHC.Cmm.Liveness +import GHC.Cmm.Switch +import Data.List (sortBy) +import GHC.Data.Maybe +import Control.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform +import GHC.Types.Unique.DSM +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label + +-- Compute a minimal set of proc points for a control-flow graph. + +-- Determine a protocol for each proc point (which live variables will +-- be passed as arguments and which will be on the stack). + +{- +A proc point is a basic block that, after CPS transformation, will +start a new function. The entry block of the original function is a +proc point, as is the continuation of each function call. +A third kind of proc point arises if we want to avoid copying code. +Suppose we have code like the following: + + f() { + if (...) { ..1..; call foo(); ..2..} + else { ..3..; call bar(); ..4..} + x = y + z; + return x; + } + +The statement 'x = y + z' can be reached from two different proc +points: the continuations of foo() and bar(). We would prefer not to +put a copy in each continuation; instead we would like 'x = y + z' to +be the start of a new procedure to which the continuations can jump: + + f_cps () { + if (...) { ..1..; push k_foo; jump foo_cps(); } + else { ..3..; push k_bar; jump bar_cps(); } + } + k_foo() { ..2..; jump k_join(y, z); } + k_bar() { ..4..; jump k_join(y, z); } + k_join(y, z) { x = y + z; return x; } + +You might think then that a criterion to make a node a proc point is +that it is directly reached by two distinct proc points. (Note +[Direct reachability].) But this criterion is a bit too simple; for +example, 'return x' is also reached by two proc points, yet there is +no point in pulling it out of k_join. A good criterion would be to +say that a node should be made a proc point if it is reached by a set +of proc points that is different than its immediate dominator. NR +believes this criterion can be shown to produce a minimum set of proc +points, and given a dominator tree, the proc points can be chosen in +time linear in the number of blocks. Lacking a dominator analysis, +however, we turn instead to an iterative solution, starting with no +proc points and adding them according to these rules: + + 1. The entry block is a proc point. + 2. The continuation of a call is a proc point. + 3. A node is a proc point if it is directly reached by more proc + points than one of its predecessors. + +Because we don't understand the problem very well, we apply rule 3 at +most once per iteration, then recompute the reachability information. +(See Note [No simple dataflow].) The choice of the new proc point is +arbitrary, and I don't know if the choice affects the final solution, +so I don't know if the number of proc points chosen is the +minimum---but the set will be minimal. + + + +Note [Proc-point analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Given a specified set of proc-points (a set of block-ids), "proc-point +analysis" figures out, for every block, which proc-point it belongs to. +All the blocks belonging to proc-point P will constitute a single +top-level C procedure. + +A non-proc-point block B "belongs to" a proc-point P iff B is +reachable from P without going through another proc-point. + +Invariant: a block B should belong to at most one proc-point; if it +belongs to two, that's a bug. + +Note [Non-existing proc-points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +On some architectures it might happen that the list of proc-points +computed before stack layout pass will be invalidated by the stack +layout. This will happen if stack layout removes from the graph +blocks that were determined to be proc-points. Later on in the pipeline +we use list of proc-points to perform [Proc-point analysis], but +if a proc-point does not exist anymore then we will get compiler panic. +See #8205. +-} + +type ProcPointSet = LabelSet + +data Status + = ReachedBy ProcPointSet -- set of proc points that directly reach the block + | ProcPoint -- this block is itself a proc point + +instance Outputable Status where + ppr (ReachedBy ps) + | setNull ps = text "" + | otherwise = text "reached by" <+> + (hsep $ punctuate comma $ map ppr $ setElems ps) + ppr ProcPoint = text "" + +-------------------------------------------------- +-- Proc point analysis + +-- Once you know what the proc-points are, figure out +-- what proc-points each block is reachable from +-- See Note [Proc-point analysis] +procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status +procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) = + analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints + where + initProcPoints = + mkFactBase + procPointLattice + [ (id, ProcPoint) + | id <- setElems procPoints + -- See Note [Non-existing proc-points] + , id `setMember` labelsInGraph + ] + labelsInGraph = labelsDefined graph + +procPointTransfer :: TransferFun Status +procPointTransfer block facts = + let label = entryLabel block + !fact = case getFact procPointLattice label facts of + ProcPoint -> ReachedBy $! setSingleton label + f -> f + result = map (\id -> (id, fact)) (successors block) + in mkFactBase procPointLattice result + +procPointLattice :: DataflowLattice Status +procPointLattice = DataflowLattice unreached add_to + where + unreached = ReachedBy setEmpty + add_to (OldFact ProcPoint) _ = NotChanged ProcPoint + add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case + add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p')) + | setSize union > setSize p = Changed (ReachedBy union) + | otherwise = NotChanged (ReachedBy p) + where + union = setUnion p' p + +---------------------------------------------------------------------- + +-- It is worth distinguishing two sets of proc points: those that are +-- induced by calls in the original graph and those that are +-- introduced because they're reachable from multiple proc points. +-- +-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds]. +callProcPoints :: CmmGraph -> ProcPointSet +callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g + where add :: LabelSet -> CmmBlock -> LabelSet + add set b = case lastNode b of + CmmCall {cml_cont = Just k} -> setInsert k set + CmmForeignCall {succ=k} -> setInsert k set + _ -> set + +minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph + -> UniqDSM ProcPointSet +-- Given the set of successors of calls (which must be proc-points) +-- figure out the minimal set of necessary proc-points +minimalProcPointSet platform callProcPoints g + = extendPPSet platform g (revPostorder g) callProcPoints + +extendPPSet + :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqDSM ProcPointSet +extendPPSet platform g blocks procPoints = + let env = procPointAnalysis procPoints g + add pps block = let id = entryLabel block + in case mapLookup id env of + Just ProcPoint -> setInsert id pps + _ -> pps + procPoints' = foldlGraphBlocks add setEmpty g + newPoints = mapMaybe ppSuccessor blocks + newPoint = listToMaybe newPoints + ppSuccessor b = + let nreached id = case mapLookup id env `orElse` + pprPanic "no ppt" (ppr id <+> pdoc platform b) of + ProcPoint -> 1 + ReachedBy ps -> setSize ps + block_procpoints = nreached (entryLabel b) + -- Looking for a successor of b that is reached by + -- more proc points than b and is not already a proc + -- point. If found, it can become a proc point. + newId succ_id = not (setMember succ_id procPoints') && + nreached succ_id > block_procpoints + in listToMaybe $ filter newId $ successors b + + in case newPoint of + Just id -> + if setMember id procPoints' + then panic "added old proc pt" + else extendPPSet platform g blocks (setInsert id procPoints') + Nothing -> return procPoints' + + +-- At this point, we have found a set of procpoints, each of which should be +-- the entry point of a procedure. +-- Now, we create the procedure for each proc point, +-- which requires that we: +-- 1. build a map from proc points to the blocks reachable from the proc point +-- 2. turn each branch to a proc point into a jump +-- 3. turn calls and returns into jumps +-- 4. build info tables for the procedures -- and update the info table for +-- the SRTs in the entry procedure as well. +-- Input invariant: A block should only be reachable from a single ProcPoint. +-- ToDo: use the _ret naming convention that the old code generator +-- used. -- EZY +splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl + -> UniqDSM [CmmDecl] +splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] +splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do + -- Build a map from procpoints to the blocks they reach + let (CmmProc (TopInfo {info_tbls = info_tbls}) top_l _ g@(CmmGraph {g_entry=entry})) = cmmProc + + let add graphEnv procId bid b = mapInsert procId graph' graphEnv + where + graph' = mapInsert bid b graph + graph = mapLookup procId graphEnv `orElse` mapEmpty + + let add_block :: LabelMap (LabelMap CmmBlock) -> CmmBlock -> LabelMap (LabelMap CmmBlock) + add_block graphEnv b = + case mapLookup bid procMap of + Just ProcPoint -> add graphEnv bid bid b + Just (ReachedBy set) -> + case setElems set of + [] -> graphEnv + [id] -> add graphEnv id bid b + _ -> panic "Each block should be reachable from only one ProcPoint" + Nothing -> graphEnv + where + bid = entryLabel b + + + let liveness = cmmGlobalLiveness platform g + let ppLiveness pp = filter (isArgReg . globalRegUse_reg) $ regSetToList $ + expectJust $ mapLookup pp liveness + graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g + + -- Build a map from proc point BlockId to pairs of: + -- * Labels for their new procedures + -- * Labels for the info tables of their new procedures (only if + -- the proc point is a callPP) + -- Due to common blockification, we may overestimate the set of procpoints. + let add_label map pp = mapInsert pp lbls map + where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls)) + | otherwise = (block_lbl, guard (setMember pp callPPs) >> + Just info_table_lbl) + where block_lbl = blockLbl pp + info_table_lbl = infoTblLbl pp + + procLabels :: LabelMap (CLabel, Maybe CLabel) + procLabels = foldl' add_label mapEmpty + (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) + + -- In each new graph, add blocks jumping off to the new procedures, + -- and replace branches to procpoints with branches to the jump-off blocks + let add_jump_block :: (LabelMap Label, [CmmBlock]) + -> (Label, CLabel) + -> UniqDSM (LabelMap Label, [CmmBlock]) + add_jump_block (env, bs) (pp, l) = do + bid <- liftM mkBlockId getUniqueDSM + let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump + live = ppLiveness pp + jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 + return (mapInsert pp bid env, b : bs) + + -- when jumping to a PP that has an info table, if + -- tablesNextToCode is off we must jump to the entry + -- label instead. + let tablesNextToCode = platformTablesNextToCode platform + + let jump_label (Just info_lbl) _ + | tablesNextToCode = info_lbl + | otherwise = toEntryLbl platform info_lbl + jump_label Nothing block_lbl = block_lbl + + let add_if_pp id rst = + case mapLookup id procLabels of + Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst + Nothing -> rst + + let add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)] + add_if_branch_to_pp block rst = + case lastNode block of + CmmBranch id -> add_if_pp id rst + CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst) + CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids + _ -> rst + + let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqDSM (LabelMap CmmGraph) + add_jumps newGraphEnv (ppId, blockEnv) = do + -- find which procpoints we currently branch to + let needed_jumps = mapFoldr add_if_branch_to_pp [] blockEnv + + (jumpEnv, jumpBlocks) <- + foldM add_jump_block (mapEmpty, []) needed_jumps + -- update the entry block + let b = expectJust $ mapLookup ppId blockEnv + blockEnv' = mapInsert ppId b blockEnv + -- replace branches to procpoints with branches to jumps + blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' + -- add the jump blocks to the graph + blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks + let g' = ofBlockMap ppId blockEnv''' + -- pprTrace "g' pre jumps" (ppr g') $ do + return (mapInsert ppId g' newGraphEnv) + + graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv + + let to_proc (bid, g) + | bid == entry + = CmmProc (TopInfo {info_tbls = info_tbls, + stack_info = stack_info}) + top_l live g' + | otherwise + = case expectJust $ mapLookup bid procLabels of + (lbl, Just info_lbl) + -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) + , stack_info=stack_info}) + lbl live g' + (lbl, Nothing) + -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) + lbl live g' + where + g' = replacePPIds g + live = ppLiveness (g_entry g') + stack_info = StackInfo { arg_space = 0 + , do_layout = True } + -- cannot use panic, this is printed by -ddump-cmm + + -- References to procpoint IDs can now be replaced with the + -- infotable's label + replacePPIds g = {-# SCC "replacePPIds" #-} + mapGraphNodes (id, mapExp repl, mapExp repl) g + where repl e@(CmmLit (CmmBlock bid)) = + case mapLookup bid procLabels of + Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) + _ -> e + repl e = e + + -- The C back end expects to see return continuations before the + -- call sites. Here, we sort them in reverse order -- it gets + -- reversed later. + let add_block_num (i, map) block = + (i + 1, mapInsert (entryLabel block) i map) + let (_, block_order) = + foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int) + (revPostorder g) + let sort_fn (bid, _) (bid', _) = + compare (expectJust $ mapLookup bid block_order) + (expectJust $ mapLookup bid' block_order) + + return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv + +-- Only called from GHC.Cmm.ProcPoint.splitAtProcPoints. NB. does a +-- recursive lookup, see comment below. +replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph +replaceBranches env cmmg + = {-# SCC "replaceBranches" #-} + ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg + where + f block = replaceLastNode block $ last (lastNode block) + + last :: CmmNode O C -> CmmNode O C + last (CmmBranch id) = CmmBranch (lookup id) + last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l + last (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets lookup ids) + last l@(CmmCall {}) = l { cml_cont = Nothing } + -- NB. remove the continuation of a CmmCall, since this + -- label will now be in a different CmmProc. Not only + -- is this tidier, it stops CmmLint from complaining. + last l@(CmmForeignCall {}) = l + lookup id = fmap lookup (mapLookup id env) `orElse` id + -- XXX: this is a recursive lookup, it follows chains + -- until the lookup returns Nothing, at which point we + -- return the last BlockId + +-- -------------------------------------------------------------- +-- Not splitting proc points: add info tables for continuations + +attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl +attachContInfoTables call_proc_points (CmmProc top_info top_l live g) + = CmmProc top_info{info_tbls = info_tbls'} top_l live g + where + info_tbls' = mapUnion (info_tbls top_info) $ + mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l)) + | l <- setElems call_proc_points + , l /= g_entry g ] +attachContInfoTables _ other_decl + = other_decl + +---------------------------------------------------------------- + +{- +Note [Direct reachability] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Block B is directly reachable from proc point P iff control can flow +from P to B without passing through an intervening proc point. +-} + +---------------------------------------------------------------- + +{- +Note [No simple dataflow] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Sadly, it seems impossible to compute the proc points using a single +dataflow pass. One might attempt to use this simple lattice: + + data Location = Unknown + | InProc BlockId -- node is in procedure headed by the named proc point + | ProcPoint -- node is itself a proc point + +At a join, a node in two different blocks becomes a proc point. +The difficulty is that the change of information during iterative +computation may promote a node prematurely. Here's a program that +illustrates the difficulty: + + f () { + entry: + .... + L1: + if (...) { ... } + else { ... } + + L2: if (...) { g(); goto L1; } + return x + y; + } + +The only proc-point needed (besides the entry) is L1. But in an +iterative analysis, consider what happens to L2. On the first pass +through, it rises from Unknown to 'InProc entry', but when L1 is +promoted to a proc point (because it's the successor of g()), L1's +successors will be promoted to 'InProc L1'. The problem hits when the +new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'. +The join operation makes it a proc point when in fact it needn't be, +because its immediate dominator L1 is already a proc point and there +are no other proc points that directly reach L2. +-} + + + +{- Note [Separate Adams optimization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It may be worthwhile to attempt the Adams optimization by rewriting +the graph before the assignment of proc-point protocols. Here are a +couple of rules: + + g() returns to k; g() returns to L; + k: CopyIn c ress; goto L: + ... ==> ... + L: // no CopyIn node here L: CopyIn c ress; + + +And when c == c' and ress == ress', this also: + + g() returns to k; g() returns to L; + k: CopyIn c ress; goto L: + ... ==> ... + L: CopyIn c' ress' L: CopyIn c' ress' ; + +In both cases the goal is to eliminate k. +-} diff --git a/GHC/Cmm/Reducibility.hs b/GHC/Cmm/Reducibility.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Reducibility.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| +Module : GHC.Cmm.Reducibility +Description : Tell if a `CmmGraph` is reducible, or make it so + +Test a Cmm control-flow graph for reducibility. And provide a +function that, when given an arbitrary control-flow graph, returns an +equivalent, reducible control-flow graph. The equivalent graph is +obtained by "splitting" (copying) nodes of the original graph. +The resulting equivalent graph has the same dynamic behavior as the +original, but it is larger. + +Documentation uses the language of control-flow analysis, in which a +basic block is called a "node." These "nodes" are `CmmBlock`s or +equivalent; they have nothing to do with a `CmmNode`. + +For more on reducibility and related analyses and algorithms, see +Note [Reducibility resources] +-} + +module GHC.Cmm.Reducibility + ( Reducibility(..) + , reducibility + + , asReducible + ) +where + +import GHC.Prelude hiding (splitAt, succ) + +import Control.Monad +import Data.List (nub) +import Data.Maybe +import Data.Semigroup +import qualified Data.Sequence as Seq + +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dominators +import GHC.Cmm.Dataflow.Graph hiding (addBlock) +import GHC.Cmm.Dataflow.Label +import GHC.Data.Graph.Collapse +import GHC.Data.Graph.Inductive.Graph +import GHC.Data.Graph.Inductive.PatriciaTree +import GHC.Types.Unique.DSM +import GHC.Utils.Panic + +-- | Represents the result of a reducibility analysis. +data Reducibility = Reducible | Irreducible + deriving (Eq, Show) + +-- | Given a graph, say whether the graph is reducible. The graph must +-- be bundled with a dominator analysis and a reverse postorder +-- numbering, as these results are needed to perform the test. + +reducibility :: NonLocal node + => GraphWithDominators node + -> Reducibility +reducibility gwd = + if all goodBlock blockmap then Reducible else Irreducible + where goodBlock b = all (goodEdge (entryLabel b)) (successors b) + goodEdge from to = rpnum to > rpnum from || to `dominates` from + rpnum = gwdRPNumber gwd + blockmap = graphMap $ gwd_graph gwd + dominators = gwdDominatorsOf gwd + dominates lbl blockname = + lbl == blockname || dominatorsMember lbl (dominators blockname) + +-- | Given a graph, return an equivalent reducible graph, by +-- "splitting" (copying) nodes if necessary. The input +-- graph must be bundled with a dominator analysis and a reverse +-- postorder numbering. The computation is monadic because when a +-- node is split, the new copy needs a fresh label. +-- +-- Use this function whenever a downstream algorithm needs a reducible +-- control-flow graph. + +asReducible :: GraphWithDominators CmmNode + -> UniqDSM (GraphWithDominators CmmNode) +asReducible gwd = case reducibility gwd of + Reducible -> return gwd + Irreducible -> assertReducible <$> nodeSplit gwd + +assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode +assertReducible gwd = case reducibility gwd of + Reducible -> gwd + Irreducible -> panic "result not reducible" + +---------------------------------------------------------------- + +-- | Split one or more nodes of the given graph, which must be +-- irreducible. + +nodeSplit :: GraphWithDominators CmmNode + -> UniqDSM (GraphWithDominators CmmNode) +nodeSplit gwd = + graphWithDominators <$> inflate (g_entry g) <$> runNullCollapse collapsed + where g = gwd_graph gwd + collapsed :: NullCollapseViz (Gr CmmSuper ()) + collapsed = collapseInductiveGraph (cgraphOfCmm g) + +type CGraph = Gr CmmSuper () + +-- | Turn a collapsed supernode back into a control-flow graph +inflate :: Label -> CGraph -> CmmGraph +inflate entry cg = CmmGraph entry graph + where graph = GMany NothingO body NothingO + body :: LabelMap CmmBlock + body = foldl (\map block -> mapInsert (entryLabel block) block map) mapEmpty $ + blocks super + super = case labNodes cg of + [(_, s)] -> s + _ -> panic "graph given to `inflate` is not singleton" + + +-- | Convert a `CmmGraph` into an inductive graph. +-- (The function coalesces duplicate edges into a single edge.) +cgraphOfCmm :: CmmGraph -> CGraph +cgraphOfCmm g = foldl' addSuccEdges (mkGraph cnodes []) blocks + where blocks = zip [0..] $ revPostorderFrom (graphMap g) (g_entry g) + cnodes = [(k, super block) | (k, block) <- blocks] + where super block = Nodes (entryLabel block) (Seq.singleton block) + labelNumber = \lbl -> fromJust $ mapLookup lbl numbers + where numbers :: LabelMap Int + numbers = mapFromList $ map swap blocks + swap (k, block) = (entryLabel block, k) + addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph + addSuccEdges graph (k, block) = + insEdges [(k, labelNumber lbl, ()) | lbl <- nub $ successors block] graph +{- +Note [Reducibility resources] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +*Flow Analysis of Computer Programs.* Matthew S. Hecht North Holland, 1977. +Available to borrow from archive.org. + +Matthew S. Hecht and Jeffrey D. Ullman (1972). +Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202. +https://doi.org/10.1137/0201014 + +Johan Janssen and Henk Corporaal. 1997. Making graphs reducible with +controlled node splitting. ACM TOPLAS 19, 6 (Nov. 1997), +1031–1052. DOI:https://doi.org/10.1145/267959.269971 + +Sebastian Unger and Frank Mueller. 2002. Handling irreducible loops: +optimized node splitting versus DJ-graphs. ACM TOPLAS 24, 4 (July +2002), 299–333. https://doi.org/10.1145/567097.567098. (This one +contains the most detailed account of how the Hecht/Ullman algorithm +is used to modify an actual control-flow graph. But still not much detail.) + +https://rgrig.blogspot.com/2009/10/dtfloatleftclearleft-summary-of-some.html + (Nice summary of useful facts) + +-} + + + +type Seq = Seq.Seq + +-- | A "supernode" contains a single-entry, multiple-exit, reducible subgraph. +-- The entry point is the given label, and the block with that label +-- dominates all the other blocks in the supernode. When an entire +-- graph is collapsed into a single supernode, the graph is reducible. +-- More detail can be found in "GHC.Data.Graph.Collapse". + +data CmmSuper + = Nodes { label :: Label + , blocks :: Seq CmmBlock + } + +instance Semigroup CmmSuper where + s <> s' = Nodes (label s) (blocks s <> blocks s') + +instance PureSupernode CmmSuper where + superLabel = label + mapLabels = changeLabels + +instance Supernode CmmSuper NullCollapseViz where + freshen s = liftUniqDSM $ relabel s + + +-- | Return all labels defined within a supernode. +definedLabels :: CmmSuper -> Seq Label +definedLabels = fmap entryLabel . blocks + + + +-- | Map the given function over every use and definition of a label +-- in the given supernode. +changeLabels :: (Label -> Label) -> (CmmSuper -> CmmSuper) +changeLabels f (Nodes l blocks) = Nodes (f l) (fmap (changeBlockLabels f) blocks) + +-- | Map the given function over every use and definition of a label +-- in the given block. +changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock +changeBlockLabels f block = blockJoin entry' middle exit' + where (entry, middle, exit) = blockSplit block + entry' = let CmmEntry l scope = entry + in CmmEntry (f l) scope + exit' = case exit of + -- unclear why mapSuccessors doesn't touch these + CmmCall { cml_cont = Just l } -> exit { cml_cont = Just (f l) } + CmmForeignCall { succ = l } -> exit { succ = f l } + _ -> mapSuccessors f exit + + +-- | Within the given supernode, replace every defined label (and all +-- of its uses) with a fresh label. + +relabel :: CmmSuper -> UniqDSM CmmSuper +relabel node = do + finite_map <- foldM addPair mapEmpty $ definedLabels node + return $ changeLabels (labelChanger finite_map) node + where addPair :: LabelMap Label -> Label -> UniqDSM (LabelMap Label) + addPair map old = do new <- newBlockId + return $ mapInsert old new map + labelChanger :: LabelMap Label -> (Label -> Label) + labelChanger mapping = \lbl -> mapFindWithDefault lbl lbl mapping diff --git a/GHC/Cmm/Reg.hs b/GHC/Cmm/Reg.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Reg.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module GHC.Cmm.Reg + ( -- * Cmm Registers + CmmReg(..) + , cmmRegType + , cmmRegWidth + -- * Local registers + , LocalReg(..) + , localRegType + -- * Global registers + , GlobalReg(..), isArgReg, globalRegSpillType, pprGlobalReg + , spReg, hpReg, spLimReg, hpLimReg, nodeReg + , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg + , node, baseReg + , GlobalRegUse(..), pprGlobalRegUse + + , GlobalArgRegs(..) + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Cmm.Type + +----------------------------------------------------------------------------- +-- Cmm registers +----------------------------------------------------------------------------- + +{- Note [GlobalReg vs GlobalRegUse] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We distinguish GlobalReg, which describes registers in the STG abstract machine, +with GlobalRegUse, which describes an usage of such a register to store values +of a particular CmmType. + +For example, we might want to load/store an 8-bit integer in a register that +can store 32-bit integers. + +The width of the type must fit in the register, i.e. for a usage +@GlobalRegUse reg ty@ we must have that + + > typeWidth ty <= typeWidth (globalRegSpillType reg) + +The restrictions about what categories of types can be stored in a given +register are less easily stated. Some examples are: + + - Vanilla registers can contain both pointers (gcWord) and non-pointers (bWord), + as well as sub-word sized values (e.g. b16). + - On x86_64, SIMD registers can be used to hold vectors of both floating + and integral values (e.g. XmmReg may store 2 Double values or 4 Int32 values). +-} + +-- | A use of a global register at a particular type. +-- +-- While a 'GlobalReg' identifies a global register in the STG machine, +-- a 'GlobalRegUse' also contains information about the type we are storing +-- in the register. +-- +-- See Note [GlobalReg vs GlobalRegUse] for more information. +data GlobalRegUse + = GlobalRegUse + { globalRegUse_reg :: !GlobalReg + -- ^ The underlying 'GlobalReg' + , globalRegUse_type :: !CmmType + -- ^ The 'CmmType' at which we are using the 'GlobalReg'. + -- + -- Its width must be less than the width of the 'GlobalReg': + -- + -- > typeWidth ty <= typeWidth (globalRegSpillType platform reg) + } + deriving Show + +instance Outputable GlobalRegUse where + ppr (GlobalRegUse reg _) = ppr reg + +pprGlobalRegUse :: IsLine doc => GlobalRegUse -> doc +pprGlobalRegUse (GlobalRegUse reg _) = pprGlobalReg reg + +-- TODO: these instances should be removed in favour +-- of more surgical uses of equality. +instance Eq GlobalRegUse where + GlobalRegUse r1 _ == GlobalRegUse r2 _ = r1 == r2 +instance Ord GlobalRegUse where + GlobalRegUse r1 _ `compare` GlobalRegUse r2 _ = compare r1 r2 + +data CmmReg + = CmmLocal {-# UNPACK #-} !LocalReg + | CmmGlobal GlobalRegUse + deriving ( Eq, Ord, Show ) + +instance Outputable CmmReg where + ppr e = pprReg e + +pprReg :: CmmReg -> SDoc +pprReg r + = case r of + CmmLocal local -> pprLocalReg local + CmmGlobal (GlobalRegUse global _) -> pprGlobalReg global + +cmmRegType :: CmmReg -> CmmType +cmmRegType (CmmLocal reg) = localRegType reg +cmmRegType (CmmGlobal reg) = globalRegUse_type reg + +cmmRegWidth :: CmmReg -> Width +cmmRegWidth = typeWidth . cmmRegType + +----------------------------------------------------------------------------- +-- Local registers +----------------------------------------------------------------------------- + +data LocalReg + = LocalReg {-# UNPACK #-} !Unique !CmmType + -- ^ Parameters: + -- 1. Identifier + -- 2. Type + deriving Show + +instance Eq LocalReg where + (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 + +instance Outputable LocalReg where + ppr e = pprLocalReg e + +-- This is non-deterministic but we do not currently support deterministic +-- code-generation. See Note [Unique Determinism and code generation] +-- See Note [No Ord for Unique] +instance Ord LocalReg where + compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2 + +instance Uniquable LocalReg where + getUnique (LocalReg uniq _) = uniq + +localRegType :: LocalReg -> CmmType +localRegType (LocalReg _ rep) = rep + +-- +-- We only print the type of the local reg if it isn't wordRep +-- +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq rep) = +-- = ppr rep <> char '_' <> ppr uniq +-- Temp Jan08 + char '_' <> pprUnique uniq <> + (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh + then dcolon <> ptr <> ppr rep + else dcolon <> ptr <> ppr rep) + where + pprUnique unique = sdocOption sdocSuppressUniques $ \case + True -> text "_locVar_" + False -> ppr unique + ptr = empty + --if isGcPtrType rep + -- then doubleQuotes (text "ptr") + -- else empty + +----------------------------------------------------------------------------- +-- Global STG registers +----------------------------------------------------------------------------- +{- +Note [Overlapping global registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The backend might not faithfully implement the abstraction of the STG +machine with independent registers for different values of type +GlobalReg. Specifically, certain pairs of registers (r1, r2) may +overlap in the sense that a store to r1 invalidates the value in r2, +and vice versa. + +Currently this occurs only on the x86_64 architecture where FloatReg n +and DoubleReg n are assigned the same microarchitectural register, in +order to allow functions to receive more Float# or Double# arguments +in registers (as opposed to on the stack). + +There are no specific rules about which registers might overlap with +which other registers, but presumably it's safe to assume that nothing +will overlap with special registers like Sp or BaseReg. + +Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap +on a particular platform. The instance Eq GlobalReg is syntactic +equality of STG registers and does not take overlap into +account. However it is still used in UserOfRegs/DefinerOfRegs and +there are likely still bugs there, beware! +-} + +-- | An abstract global register for the STG machine. +-- +-- See also 'GlobalRegUse', which denotes a usage of a register at a particular +-- type (e.g. using a 32-bit wide register to store an 8-bit wide value), as per +-- Note [GlobalReg vs GlobalRegUse]. +data GlobalReg + -- Argument and return registers + = VanillaReg -- pointers, unboxed ints and chars + {-# UNPACK #-} !Int -- its number + + | FloatReg -- single-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | DoubleReg -- double-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | LongReg -- long int registers (64-bit, really) + {-# UNPACK #-} !Int -- its number + + -- I think we should redesign 'GlobalReg', for example instead of + -- FloatReg/DoubleReg/XmmReg/YmmReg/ZmmReg we could have a single VecReg + -- which also stores the type we are storing in it. + -- + -- We might then be able to get rid of GlobalRegUse, as the type information + -- would already be contained in a 'GlobalReg'. + + | XmmReg -- 128-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | YmmReg -- 256-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | ZmmReg -- 512-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + -- STG registers + | Sp -- ^ Stack ptr; points to last occupied stack location. + | SpLim -- ^ Stack limit + | Hp -- ^ Heap ptr; points to last occupied heap location. + | HpLim -- ^ Heap limit register + | CCCS -- ^ Current cost-centre stack + | CurrentTSO -- ^ pointer to current thread's TSO + | CurrentNursery -- ^ pointer to allocation area + | HpAlloc -- ^ allocation count for heap check failure + + -- We keep the address of some commonly-called + -- functions in the register table, to keep code + -- size down: + | EagerBlackholeInfo -- ^ address of stg_EAGER_BLACKHOLE_info + | GCEnter1 -- ^ address of stg_gc_enter_1 + | GCFun -- ^ address of stg_gc_fun + + -- | Base offset for the register table, used for accessing registers + -- which do not have real registers assigned to them. This register + -- will only appear after we have expanded GlobalReg into memory accesses + -- (where necessary) in the native code generator. + | BaseReg + + -- | The register used by the platform for the C stack pointer. This is + -- a break in the STG abstraction used exclusively to setup stack unwinding + -- information. + | MachSp + + -- | A dummy register used to indicate to the stack unwinder where + -- a routine would return to. + | UnwindReturnReg + + -- | Base Register for PIC (position-independent code) calculations. + -- + -- Only used inside the native code generator. Its exact meaning differs + -- from platform to platform (see module PositionIndependentCode). + | PicBaseReg + + deriving( Eq, Ord, Show ) + -- NOTE: the Ord instance affects the tuple layout in GHCi, see + -- Note [GHCi and native call registers] + +instance Outputable GlobalReg where + ppr e = pprGlobalReg e + +instance OutputableP env GlobalReg where + pdoc _ = ppr + +pprGlobalReg :: IsLine doc => GlobalReg -> doc +pprGlobalReg gr + = case gr of + VanillaReg n -> char 'R' <> int n + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + XmmReg n -> text "XMM" <> int n + YmmReg n -> text "YMM" <> int n + ZmmReg n -> text "ZMM" <> int n + Sp -> text "Sp" + SpLim -> text "SpLim" + Hp -> text "Hp" + HpLim -> text "HpLim" + MachSp -> text "MachSp" + UnwindReturnReg-> text "UnwindReturnReg" + CCCS -> text "CCCS" + CurrentTSO -> text "CurrentTSO" + CurrentNursery -> text "CurrentNursery" + HpAlloc -> text "HpAlloc" + EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" + GCEnter1 -> text "stg_gc_enter_1" + GCFun -> text "stg_gc_fun" + BaseReg -> text "BaseReg" + PicBaseReg -> text "PicBaseReg" +{-# SPECIALIZE pprGlobalReg :: GlobalReg -> SDoc #-} +{-# SPECIALIZE pprGlobalReg :: GlobalReg -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- convenient aliases +baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg, + currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: Platform -> CmmReg +baseReg p = CmmGlobal (GlobalRegUse BaseReg $ bWord p) +spReg p = CmmGlobal (GlobalRegUse Sp $ bWord p) +hpReg p = CmmGlobal (GlobalRegUse Hp $ gcWord p) +hpLimReg p = CmmGlobal (GlobalRegUse HpLim $ bWord p) +spLimReg p = CmmGlobal (GlobalRegUse SpLim $ bWord p) +nodeReg p = CmmGlobal (GlobalRegUse (VanillaReg 1) $ gcWord p) +currentTSOReg p = CmmGlobal (GlobalRegUse CurrentTSO $ bWord p) +currentNurseryReg p = CmmGlobal (GlobalRegUse CurrentNursery $ bWord p) +hpAllocReg p = CmmGlobal (GlobalRegUse HpAlloc $ bWord p) +cccsReg p = CmmGlobal (GlobalRegUse CCCS $ bWord p) + +node :: GlobalReg +node = VanillaReg 1 + +globalRegSpillType :: Platform -> GlobalReg -> CmmType +globalRegSpillType platform = \case + VanillaReg _ -> gcWord platform + FloatReg _ -> cmmFloat W32 + DoubleReg _ -> cmmFloat W64 + LongReg _ -> cmmBits W64 + + -- TODO: improve the internal model of SIMD/vectorized registers + -- the right design SHOULD improve handling of float and double code too. + -- see remarks in Note [SIMD Design for the future] in GHC.StgToCmm.Prim + XmmReg _ -> cmmVec 4 (cmmBits W32) + YmmReg _ -> cmmVec 8 (cmmBits W32) + ZmmReg _ -> cmmVec 16 (cmmBits W32) + + Hp -> gcWord platform -- The initialiser for all + -- dynamically allocated closures + _ -> bWord platform + +isArgReg :: GlobalReg -> Bool +isArgReg (VanillaReg {}) = True +isArgReg (FloatReg {}) = True +isArgReg (DoubleReg {}) = True +isArgReg (LongReg {}) = True +isArgReg (XmmReg {}) = True +isArgReg (YmmReg {}) = True +isArgReg (ZmmReg {}) = True +isArgReg _ = False + +-- -------------------------------------------------------------------------- + +-- | Global registers used for argument passing. +-- +-- See Note [realArgRegsCover] in GHC.Cmm.CallConv. +data GlobalArgRegs + -- | General-purpose (integer) argument-passing registers. + = GP_ARG_REGS + -- | Scalar (integer & floating-point) argument-passing registers. + | SCALAR_ARG_REGS + -- | 16 byte vector argument-passing registers, together with + -- integer & floating-point argument-passing scalar registers. + | V16_ARG_REGS + -- | 32 byte vector argument-passing registers, together with + -- integer & floating-point argument-passing scalar registers. + | V32_ARG_REGS + -- | 64 byte vector argument-passing registers, together with + -- integer & floating-point argument-passing scalar registers. + | V64_ARG_REGS + deriving ( Show, Eq, Ord ) diff --git a/GHC/Cmm/Sink.hs b/GHC/Cmm/Sink.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Sink.hs @@ -0,0 +1,953 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Cmm.Sink ( + cmmSink + ) where + +import GHC.Prelude + +import GHC.Cmm +import GHC.Cmm.Opt +import GHC.Cmm.Liveness +import GHC.Cmm.LRegSet +import GHC.Cmm.Utils +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Graph +import GHC.Platform.Regs + +import GHC.Platform +import GHC.Types.Unique.FM + +import Data.List (partition) +import Data.Maybe + +import GHC.Exts (inline) + +-- ----------------------------------------------------------------------------- +-- Sinking and inlining + +-- This is an optimisation pass that +-- (a) moves assignments closer to their uses, to reduce register pressure +-- (b) pushes assignments into a single branch of a conditional if possible +-- (c) inlines assignments to registers that are mentioned only once +-- (d) discards dead assignments +-- +-- This tightens up lots of register-heavy code. It is particularly +-- helpful in the Cmm generated by the Stg->Cmm code generator, in +-- which every function starts with a copyIn sequence like: +-- +-- x1 = R1 +-- x2 = Sp[8] +-- x3 = Sp[16] +-- if (Sp - 32 < SpLim) then L1 else L2 +-- +-- we really want to push the x1..x3 assignments into the L2 branch. +-- +-- Algorithm: +-- +-- * Start by doing liveness analysis. +-- +-- * Keep a list of assignments A; earlier ones may refer to later ones. +-- Currently we only sink assignments to local registers, because we don't +-- have liveness information about global registers. +-- +-- * Walk forwards through the graph, look at each node N: +-- +-- * If it is a dead assignment, i.e. assignment to a register that is +-- not used after N, discard it. +-- +-- * Try to inline based on current list of assignments +-- * If any assignments in A (1) occur only once in N, and (2) are +-- not live after N, inline the assignment and remove it +-- from A. +-- +-- * If an assignment in A is cheap (RHS is local register), then +-- inline the assignment and keep it in A in case it is used afterwards. +-- +-- * Otherwise don't inline. +-- +-- * If N is assignment to a local register pick up the assignment +-- and add it to A. +-- +-- * If N is not an assignment to a local register: +-- * remove any assignments from A that conflict with N, and +-- place them before N in the current block. We call this +-- "dropping" the assignments. +-- +-- * An assignment conflicts with N if it: +-- - assigns to a register mentioned in N +-- - mentions a register assigned by N +-- - reads from memory written by N +-- * do this recursively, dropping dependent assignments +-- +-- * At an exit node: +-- * drop any assignments that are live on more than one successor +-- and are not trivial +-- * if any successor has more than one predecessor (a join-point), +-- drop everything live in that successor. Since we only propagate +-- assignments that are not dead at the successor, we will therefore +-- eliminate all assignments dead at this point. Thus analysis of a +-- join-point will always begin with an empty list of assignments. +-- +-- +-- As a result of above algorithm, sinking deletes some dead assignments +-- (transitively, even). This isn't as good as removeDeadAssignments, +-- but it's much cheaper. + +-- ----------------------------------------------------------------------------- +-- things that we aren't optimising very well yet. +-- +-- ----------- +-- (1) From GHC's FastString.hashStr: +-- +-- s2ay: +-- if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp; +-- c2gn: +-- R1 = _s2au::I64; +-- call (I64[Sp])(R1) args: 8, res: 0, upd: 8; +-- c2gp: +-- _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128, +-- 4091); +-- _s2an::I64 = _s2an::I64 + 1; +-- _s2au::I64 = _s2cO::I64; +-- goto s2ay; +-- +-- a nice loop, but we didn't eliminate the silly assignment at the end. +-- See Note [dependent assignments], which would probably fix this. +-- This is #8336. +-- +-- ----------- +-- (2) From stg_atomically_frame in PrimOps.cmm +-- +-- We have a diamond control flow: +-- +-- x = ... +-- | +-- / \ +-- A B +-- \ / +-- | +-- use of x +-- +-- Now x won't be sunk down to its use, because we won't push it into +-- both branches of the conditional. We certainly do have to check +-- that we can sink it past all the code in both A and B, but having +-- discovered that, we could sink it to its use. +-- + +-- ----------------------------------------------------------------------------- + +type Assignment = (LocalReg, CmmExpr, AbsMem) + -- Assignment caches AbsMem, an abstraction of the memory read by + -- the RHS of the assignment. + +type Assignments = [Assignment] + -- A sequence of assignments; kept in *reverse* order + -- So the list [ x=e1, y=e2 ] means the sequence of assignments + -- y = e2 + -- x = e1 + +cmmSink :: Platform -> CmmGraph -> CmmGraph +cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks + where + liveness = cmmLocalLivenessL platform graph + getLive l = mapFindWithDefault emptyLRegSet l liveness + + blocks = revPostorder graph + + join_pts = findJoinPoints blocks + + sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock] + sink _ [] = [] + sink sunk (b:bs) = + -- pprTrace "sink" (ppr lbl) $ + blockJoin first final_middle final_last : sink sunk' bs + where + lbl = entryLabel b + (first, middle, last) = blockSplit b + + succs = successors last + + -- Annotate the middle nodes with the registers live *after* + -- the node. This will help us decide whether we can inline + -- an assignment in the current node or not. + live = unionsLRegSet (map getLive succs) + live_middle = gen_killL platform last live + ann_middles = annotate platform live_middle (blockToList middle) + + -- Now sink and inline in this block + (middle', assigs) = walk platform ann_middles (mapFindWithDefault [] lbl sunk) + fold_last = constantFoldNode platform last + (final_last, assigs') = tryToInline platform live fold_last assigs + + -- We cannot sink into join points (successors with more than + -- one predecessor), so identify the join points and the set + -- of registers live in them. + (joins, nonjoins) = partition (`mapMember` join_pts) succs + live_in_joins = unionsLRegSet (map getLive joins) + + -- We do not want to sink an assignment into multiple branches, + -- so identify the set of registers live in multiple successors. + -- This is made more complicated because when we sink an assignment + -- into one branch, this might change the set of registers that are + -- now live in multiple branches. + init_live_sets = map getLive nonjoins + live_in_multi live_sets r = + case filter (elemLRegSet r) live_sets of + (_one:_two:_) -> True + _ -> False + + -- Now, drop any assignments that we will not sink any further. + (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs' + + drop_if :: (LocalReg, CmmExpr, AbsMem) + -> [LRegSet] -> (Bool, [LRegSet]) + drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') + where + should_drop = conflicts platform a final_last + || not (isTrivial platform rhs) && live_in_multi live_sets r + || r `elemLRegSet` live_in_joins + + live_sets' | should_drop = live_sets + | otherwise = map upd live_sets + + upd set | r `elemLRegSet` set = set `unionLRegSet` live_rhs + | otherwise = set + + live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs + + final_middle = foldl' blockSnoc middle' dropped_last + + sunk' = mapUnion sunk $ + mapFromList [ (l, filterAssignments platform (getLive l) assigs'') + | l <- succs ] + +{- TODO: enable this later, when we have some good tests in place to + measure the effect and tune it. + +-- small: an expression we don't mind duplicating +isSmall :: CmmExpr -> Bool +isSmall (CmmReg (CmmLocal _)) = True -- +isSmall (CmmLit _) = True +isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y +isSmall (CmmRegOff (CmmLocal _) _) = True +isSmall _ = False +-} + +-- +-- We allow duplication of trivial expressions: registers (both local and +-- global) and literals. +-- +isTrivial :: Platform -> CmmExpr -> Bool +isTrivial _ (CmmReg (CmmLocal _)) = True +isTrivial platform (CmmReg (CmmGlobal (GlobalRegUse r _))) = -- see Note [Inline GlobalRegs?] + if isARM (platformArch platform) + then True -- CodeGen.Platform.ARM does not have globalRegMaybe + else isJust (globalRegMaybe platform r) + -- GlobalRegs that are loads from BaseReg are not trivial +isTrivial _ (CmmLit _) = True +isTrivial _ _ = False + +-- +-- annotate each node with the set of registers live *after* the node +-- +annotate :: Platform -> LRegSet -> [CmmNode O O] -> [(LRegSet, CmmNode O O)] +annotate platform live nodes = snd $ foldr ann (live,[]) nodes + where ann n (live,nodes) = (gen_killL platform n live, (live,n) : nodes) + +-- +-- Find the blocks that have multiple successors (join points) +-- +findJoinPoints :: [CmmBlock] -> LabelMap Int +findJoinPoints blocks = mapFilter (>1) succ_counts + where + all_succs = concatMap successors blocks + + succ_counts :: LabelMap Int + succ_counts = foldl' (\acc l -> mapInsertWith (+) l 1 acc) mapEmpty all_succs + +-- +-- filter the list of assignments to remove any assignments that +-- are not live in a continuation. +-- +filterAssignments :: Platform -> LRegSet -> Assignments -> Assignments +filterAssignments platform live assigs = reverse (go assigs []) + where go [] kept = kept + go (a@(r,_,_):as) kept | needed = go as (a:kept) + | otherwise = go as kept + where + needed = r `elemLRegSet` live + || any (conflicts platform a) (map toNode kept) + -- Note that we must keep assignments that are + -- referred to by other assignments we have + -- already kept. + +-- ----------------------------------------------------------------------------- +-- Walk through the nodes of a block, sinking and inlining assignments +-- as we go. +-- +-- On input we pass in a: +-- * list of nodes in the block +-- * a list of assignments that appeared *before* this block and +-- that are being sunk. +-- +-- On output we get: +-- * a new block +-- * a list of assignments that will be placed *after* that block. +-- + +walk :: Platform + -> [(LRegSet, CmmNode O O)] -- nodes of the block, annotated with + -- the set of registers live *after* + -- this node. + + -> Assignments -- The current list of + -- assignments we are sinking. + -- Earlier assignments may refer + -- to later ones. + + -> ( Block CmmNode O O -- The new block + , Assignments -- Assignments to sink further + ) + +walk platform nodes assigs = go nodes emptyBlock assigs + where + go [] block as = (block, as) + go ((live,node):ns) block as + -- discard nodes representing dead assignment + | shouldDiscard node live = go ns block as + -- sometimes only after simplification we can tell we can discard the node. + -- See Note [Discard simplified nodes] + | noOpAssignment node2 = go ns block as + -- Pick up interesting assignments + | Just a <- shouldSink platform node2 = go ns block (a : as1) + -- Try inlining, drop assignments and move on + | otherwise = go ns block' as' + where + -- Simplify node + node1 = constantFoldNode platform node + + -- Inline assignments + (node2, as1) = tryToInline platform live node1 as + + -- Drop any earlier assignments conflicting with node2 + (dropped, as') = dropAssignmentsSimple platform + (\a -> conflicts platform a node2) as1 + + -- Walk over the rest of the block. Includes dropped assignments + block' = foldl' blockSnoc block dropped `blockSnoc` node2 + +{- Note [Discard simplified nodes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a sequence like this: + + _c1::P64 = R1; + _c3::I64 = I64[_c1::P64 + 1]; + R1 = _c1::P64; + P64[Sp - 72] = _c1::P64; + I64[Sp - 64] = _c3::I64; + +If we discard assignments *before* simplifying nodes when we get to `R1 = _c1`. +This is then simplified into `R1 = `R1` and as a consequence prevents sinking of +loads from R1. What happens is that we: + * Check if we can discard the node `R1 = _c1 (no) + * Simplify the node to R1 = R1 + * We check all remaining assignments for conflicts. + * The assignment `_c3 = [R1 + 1]`; (R1 already inlined on pickup) + conflicts with R1 = R1, because it reads `R1` and the node writes + to R1 + * This is clearly nonsensical because `R1 = R1` doesn't affect R1's value. + +The solutions is to check if we can discard nodes before and *after* simplifying +them. We could only do it after as well, but I assume doing it early might save +some work. + +That is if we process a assignment node we now: + * Check if it can be discarded (because it's dead or a no-op) + * Simplify the rhs of the assignment. + * New: Check again if it might be a no-op now. + * ... + +This can help with problems like the one reported in #20334. For a full example see the test +cmm_sink_sp. + +-} + +-- +-- Heuristic to decide whether to pick up and sink an assignment +-- Currently we pick up all assignments to local registers. It might +-- be profitable to sink assignments to global regs too, but the +-- liveness analysis doesn't track those (yet) so we can't. +-- +shouldSink :: Platform -> CmmNode e x -> Maybe Assignment +shouldSink platform (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem platform e) + where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e +shouldSink _ _other = Nothing + +-- +-- discard dead assignments. This doesn't do as good a job as +-- removeDeadAssignments, because it would need multiple passes +-- to get all the dead code, but it catches the common case of +-- superfluous reloads from the stack that the stack allocator +-- leaves behind. +-- +-- Also we catch "r = r" here. You might think it would fall +-- out of inlining, but the inliner will see that r is live +-- after the instruction and choose not to inline r in the rhs. +-- +shouldDiscard :: CmmNode e x -> LRegSet -> Bool +shouldDiscard node live + = case node of + -- r = r + CmmAssign r (CmmReg r') | r == r' -> True + -- r = e, r is dead after assignment + CmmAssign (CmmLocal r) _ -> not (r `elemLRegSet` live) + _otherwise -> False + +noOpAssignment :: CmmNode e x -> Bool +noOpAssignment node + = case node of + -- r = r + CmmAssign r (CmmReg r') | r == r' -> True + _otherwise -> False + + +toNode :: Assignment -> CmmNode O O +toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs + +dropAssignmentsSimple :: Platform -> (Assignment -> Bool) -> Assignments + -> ([CmmNode O O], Assignments) +dropAssignmentsSimple platform f = dropAssignments platform (\a _ -> (f a, ())) () + +dropAssignments :: Platform -> (Assignment -> s -> (Bool, s)) -> s -> Assignments + -> ([CmmNode O O], Assignments) +dropAssignments platform should_drop state assigs + = (dropped, reverse kept) + where + (dropped,kept) = go state assigs [] [] + + go _ [] dropped kept = (dropped, kept) + go state (assig : rest) dropped kept + | conflict = + let !node = toNode assig + in go state' rest (node : dropped) kept + | otherwise = go state' rest dropped (assig:kept) + where + (dropit, state') = should_drop assig state + conflict = dropit || any (conflicts platform assig) dropped + + +-- ----------------------------------------------------------------------------- +-- Try to inline assignments into a node. +-- This also does constant folding for primops, since +-- inlining opens up opportunities for doing so. + +tryToInline + :: forall x. Platform + -> LRegSet -- set of registers live after this + -- node. We cannot inline anything + -- that is live after the node, unless + -- it is small enough to duplicate. + -> CmmNode O x -- The node to inline into + -> Assignments -- Assignments to inline + -> ( + CmmNode O x -- New node + , Assignments -- Remaining assignments + ) + +tryToInline platform liveAfter node assigs = + -- pprTrace "tryToInline assig length:" (ppr $ length assigs) $ + go usages liveAfter node emptyLRegSet assigs + where + usages :: UniqFM LocalReg Int -- Maps each LocalReg to a count of how often it is used + usages = foldLocalRegsUsed platform addUsage emptyUFM node + + go :: UniqFM LocalReg Int -> LRegSet -> CmmNode O x -> LRegSet -> Assignments + -> (CmmNode O x, Assignments) + go _usages _live node _skipped [] = (node, []) + + go usages live node skipped (a@(l,rhs,_) : rest) + | cannot_inline = dont_inline + | occurs_none = discard -- See Note [discard during inlining] + | occurs_once = inline_and_discard + | isTrivial platform rhs = inline_and_keep + | otherwise = dont_inline + where + inline_and_discard = go usages' live inl_node skipped rest + where usages' = foldLocalRegsUsed platform addUsage usages rhs + + discard = go usages live node skipped rest + + dont_inline = keep node -- don't inline the assignment, keep it + inline_and_keep = keep inl_node -- inline the assignment, keep it + + keep :: CmmNode O x -> (CmmNode O x, Assignments) + keep node' = (final_node, a : rest') + where (final_node, rest') = go usages live' node' (insertLRegSet l skipped) rest + + -- Avoid discarding of assignments to vars on the rhs. + -- See Note [Keeping assignments mentioned in skipped RHSs] + -- usages' = foldLocalRegsUsed platform (\m r -> addToUFM m r 2) + -- usages rhs + live' = inline foldLocalRegsUsed platform (\m r -> insertLRegSet r m) + live rhs + + cannot_inline = skipped `regsUsedIn` rhs -- See Note [dependent assignments] + || l `elemLRegSet` skipped + || not (okToInline platform rhs node) + + -- How often is l used in the current node. + l_usages = lookupUFM usages l + l_live = l `elemLRegSet` live + + occurs_once = not l_live && l_usages == Just 1 + occurs_none = not l_live && l_usages == Nothing + + inl_node = improveConditional (mapExpDeep inl_exp node) + + inl_exp :: CmmExpr -> CmmExpr + -- inl_exp is where the inlining actually takes place! + inl_exp (CmmReg (CmmLocal l')) | l == l' = rhs + inl_exp (CmmRegOff (CmmLocal l') off) | l == l' + = cmmOffset platform rhs off + -- re-constant fold after inlining + inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args + inl_exp other = other + +{- Note [Keeping assignments mentioned in skipped RHSs] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + If we have two assignments: [z = y, y = e1] and we skip + z we *must* retain the assignment y = e1. This is because + we might inline "z = y" into another node later on so we + must ensure y is still defined at this point. + + If we dropped the assignment of "y = e1" then we would end up + referencing a variable which hasn't been mentioned after + inlining. + + We use a hack to do this. + + We pretend the regs from the rhs are live after the current + node. Since we only discard assignments to variables + which are dead after the current block this prevents discarding of the + assignment. It still allows inlining should e1 be a trivial rhs + however. + +-} + +{- Note [improveConditional] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +cmmMachOpFold tries to simplify conditionals to turn things like + (a == b) != 1 +into + (a != b) +but there's one case it can't handle: when the comparison is over +floating-point values, we can't invert it, because floating-point +comparisons aren't invertible (because of NaNs). + +But we *can* optimise this conditional by swapping the true and false +branches. Given + CmmCondBranch ((a >## b) != 1) t f +we can turn it into + CmmCondBranch (a >## b) f t + +So here we catch conditionals that weren't optimised by cmmMachOpFold, +and apply above transformation to eliminate the comparison against 1. + +It's tempting to just turn every != into == and then let cmmMachOpFold +do its thing, but that risks changing a nice fall-through conditional +into one that requires two jumps. (see swapcond_last in +GHC.Cmm.ContFlowOpt), so instead we carefully look for just the cases where +we can eliminate a comparison. +-} +improveConditional :: CmmNode O x -> CmmNode O x +improveConditional + (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l) + | neLike mop, isComparisonExpr x + = CmmCondBranch x f t (fmap not l) + where + neLike (MO_Ne _) = True + neLike (MO_U_Lt _) = True -- (x LocalReg -> UniqFM LocalReg Int +addUsage m r = addToUFM_C (+) m r 1 + +regsUsedIn :: LRegSet -> CmmExpr -> Bool +regsUsedIn ls _ | nullLRegSet ls = False +regsUsedIn ls e = go ls e False + where use :: LRegSet -> CmmExpr -> Bool -> Bool + use ls (CmmReg (CmmLocal l)) _ | l `elemLRegSet` ls = True + use ls (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True + use _ls _ z = z + + go :: LRegSet -> CmmExpr -> Bool -> Bool + go ls (CmmMachOp _ es) z = foldr (go ls) z es + go ls (CmmLoad addr _ _) z = go ls addr z + go ls e z = use ls e z + +-- we don't inline into CmmUnsafeForeignCall if the expression refers +-- to global registers. This is a HACK to avoid global registers +-- clashing with C argument-passing registers, really the back-end +-- ought to be able to handle it properly, but currently neither PprC +-- nor the NCG can do it. See Note [Register parameter passing] +-- See also GHC.StgToCmm.Foreign.load_args_into_temps. +okToInline :: Platform -> CmmExpr -> CmmNode e x -> Bool +okToInline platform expr node@(CmmUnsafeForeignCall{}) = + not (globalRegistersConflict platform expr node) +okToInline _ _ _ = True + +-- ----------------------------------------------------------------------------- + +-- | @conflicts (r,e) node@ is @False@ if and only if the assignment +-- @r = e@ can be safely commuted past statement @node@. +conflicts :: Platform -> Assignment -> CmmNode O x -> Bool +conflicts platform (r, rhs, addr) node + + -- (1) node defines registers used by rhs of assignment. This catches + -- assignments and all three kinds of calls. See Note [Sinking and calls] + | globalRegistersConflict platform rhs node = True + | localRegistersConflict platform rhs node = True + + -- (2) node uses register defined by assignment + | foldRegsUsed platform (\b r' -> r == r' || b) False node = True + + -- (3) a store to an address conflicts with a read of the same memory + | CmmStore addr' e _ <- node + , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True + + -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively + | HeapMem <- addr, CmmAssign (CmmGlobal (GlobalRegUse Hp _)) _ <- node = True + | StackMem <- addr, CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node = True + | SpMem{} <- addr, CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node = True + + -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap] + | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem = True + + -- (6) suspendThread clobbers every global register not backed by a real + -- register. It also clobbers heap and stack but this is handled by (5) + | CmmUnsafeForeignCall (PrimTarget MO_SuspendThread) _ _ <- node + , foldRegsUsed platform (\b g -> globalRegMaybe platform g == Nothing || b) False rhs + = True + + -- (7) native calls clobber any memory + | CmmCall{} <- node, memConflicts addr AnyMem = True + + -- (8) otherwise, no conflict + | otherwise = False + +{- Note [Inlining foldRegsDefd] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + foldRegsDefd is, after optimization, *not* a small function so + it's only marked INLINEABLE, but not INLINE. + + However in some specific cases we call it *very* often making it + important to avoid the overhead of allocating the folding function. + + So we simply force inlining via the magic inline function. + For T3294 this improves allocation with -O by ~1%. + +-} + +-- Returns True if node defines any global registers that are used in the +-- Cmm expression +globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool +globalRegistersConflict platform expr node = + -- See Note [Inlining foldRegsDefd] + inline foldRegsDefd platform (\b r -> b || globalRegUsedIn platform (globalRegUse_reg r) expr) + False node + +-- Returns True if node defines any local registers that are used in the +-- Cmm expression +localRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool +localRegistersConflict platform expr node = + -- See Note [Inlining foldRegsDefd] + inline foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmLocal r) expr) + False node + +-- Note [Sinking and calls] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall) +-- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after +-- stack layout (see Note [Sinking after stack layout]) which leads to two +-- invariants related to calls: +-- +-- a) during stack layout phase all safe foreign calls are turned into +-- unsafe foreign calls (see Note [Lower safe foreign calls]). This +-- means that we will never encounter CmmForeignCall node when running +-- sinking after stack layout +-- +-- b) stack layout saves all variables live across a call on the stack +-- just before making a call (remember we are not sinking assignments to +-- stack): +-- +-- L1: +-- x = R1 +-- P64[Sp - 16] = L2 +-- P64[Sp - 8] = x +-- Sp = Sp - 16 +-- call f() returns L2 +-- L2: +-- +-- We will attempt to sink { x = R1 } but we will detect conflict with +-- { P64[Sp - 8] = x } and hence we will drop { x = R1 } without even +-- checking whether it conflicts with { call f() }. In this way we will +-- never need to check any assignment conflicts with CmmCall. Remember +-- that we still need to check for potential memory conflicts. +-- +-- So the result is that we only need to worry about CmmUnsafeForeignCall nodes +-- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]). +-- This assumption holds only when we do sinking after stack layout. If we run +-- it before stack layout we need to check for possible conflicts with all three +-- kinds of calls. Our `conflicts` function does that by using a generic +-- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and +-- UserOfRegs typeclasses. +-- + +-- An abstraction of memory read or written. +data AbsMem + = NoMem -- no memory accessed + | AnyMem -- arbitrary memory + | HeapMem -- definitely heap memory + | StackMem -- definitely stack memory + | SpMem -- [Sp+n] + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + +-- Having SpMem is important because it lets us float loads from Sp +-- past stores to Sp as long as they don't overlap, and this helps to +-- unravel some long sequences of +-- x1 = [Sp + 8] +-- x2 = [Sp + 16] +-- ... +-- [Sp + 8] = xi +-- [Sp + 16] = xj +-- +-- Note that SpMem is invalidated if Sp is changed, but the definition +-- of 'conflicts' above handles that. + +-- ToDo: this won't currently fix the following commonly occurring code: +-- x1 = [R1 + 8] +-- x2 = [R1 + 16] +-- .. +-- [Hp - 8] = x1 +-- [Hp - 16] = x2 +-- .. + +-- because [R1 + 8] and [Hp - 8] are both HeapMem. We know that +-- assignments to [Hp + n] do not conflict with any other heap memory, +-- but this is tricky to nail down. What if we had +-- +-- x = Hp + n +-- [x] = ... +-- +-- the store to [x] should be "new heap", not "old heap". +-- Furthermore, you could imagine that if we started inlining +-- functions in Cmm then there might well be reads of heap memory +-- that was written in the same basic block. To take advantage of +-- non-aliasing of heap memory we will have to be more clever. + +-- Note [Foreign calls clobber heap] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- It is tempting to say that foreign calls clobber only +-- non-heap/stack memory, but unfortunately we break this invariant in +-- the RTS. For example, in stg_catch_retry_frame we call +-- stmCommitNestedTransaction() which modifies the contents of the +-- TRec it is passed (this actually caused incorrect code to be +-- generated). +-- +-- Since the invariant is true for the majority of foreign calls, +-- perhaps we ought to have a special annotation for calls that can +-- modify heap/stack memory. For now we just use the conservative +-- definition here. +-- +-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and +-- therefore we should never float any memory operations across one of +-- these calls. +-- +-- `suspendThread` releases the capability used by the thread, hence we mustn't +-- float accesses to heap, stack or virtual global registers stored in the +-- capability (e.g. with unregisterised build, see #19237). + + +bothMems :: AbsMem -> AbsMem -> AbsMem +bothMems NoMem x = x +bothMems x NoMem = x +bothMems HeapMem HeapMem = HeapMem +bothMems StackMem StackMem = StackMem +bothMems (SpMem o1 w1) (SpMem o2 w2) + | o1 == o2 = SpMem o1 (max w1 w2) + | otherwise = StackMem +bothMems SpMem{} StackMem = StackMem +bothMems StackMem SpMem{} = StackMem +bothMems _ _ = AnyMem + +memConflicts :: AbsMem -> AbsMem -> Bool +memConflicts NoMem _ = False +memConflicts _ NoMem = False +memConflicts HeapMem StackMem = False +memConflicts StackMem HeapMem = False +memConflicts SpMem{} HeapMem = False +memConflicts HeapMem SpMem{} = False +memConflicts (SpMem o1 w1) (SpMem o2 w2) + | o1 < o2 = o1 + w1 > o2 + | otherwise = o2 + w2 > o1 +memConflicts _ _ = True + +exprMem :: Platform -> CmmExpr -> AbsMem +exprMem platform (CmmLoad addr w _) = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr) +exprMem platform (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem platform) es) +exprMem _ _ = NoMem + +loadAddr :: Platform -> CmmExpr -> Width -> AbsMem +loadAddr platform e w = + case e of + CmmReg r -> regAddr r 0 w + CmmRegOff r i -> regAddr r i w + _other | regUsedIn platform (spReg platform) e -> StackMem + | otherwise -> AnyMem + +regAddr :: CmmReg -> Int -> Width -> AbsMem +regAddr (CmmGlobal (GlobalRegUse Sp _)) i w = SpMem i (widthInBytes w) +regAddr (CmmGlobal (GlobalRegUse Hp _)) _ _ = HeapMem +regAddr (CmmGlobal (GlobalRegUse CurrentTSO _)) _ _ = HeapMem -- important for PrimOps +regAddr r _ _ | isGcPtrType (cmmRegType r) = HeapMem -- yay! GCPtr pays for itself +regAddr _ _ _ = AnyMem + +{- +Note [Inline GlobalRegs?] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Should we freely inline GlobalRegs? + +Actually it doesn't make a huge amount of difference either way, so we +*do* currently treat GlobalRegs as "trivial" and inline them +everywhere, but for what it's worth, here is what I discovered when I +(SimonM) looked into this: + +Common sense says we should not inline GlobalRegs, because when we +have + + x = R1 + +the register allocator will coalesce this assignment, generating no +code, and simply record the fact that x is bound to $rbx (or +whatever). Furthermore, if we were to sink this assignment, then the +range of code over which R1 is live increases, and the range of code +over which x is live decreases. All things being equal, it is better +for x to be live than R1, because R1 is a fixed register whereas x can +live in any register. So we should neither sink nor inline 'x = R1'. + +However, not inlining GlobalRegs can have surprising +consequences. e.g. (cgrun020) + + c3EN: + _s3DB::P64 = R1; + _c3ES::P64 = _s3DB::P64 & 7; + if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV; + c3EU: + _s3DD::P64 = P64[_s3DB::P64 + 6]; + _s3DE::P64 = P64[_s3DB::P64 + 14]; + I64[Sp - 8] = c3F0; + R1 = _s3DE::P64; + P64[Sp] = _s3DD::P64; + +inlining the GlobalReg gives: + + c3EN: + if (R1 & 7 >= 2) goto c3EU; else goto c3EV; + c3EU: + I64[Sp - 8] = c3F0; + _s3DD::P64 = P64[R1 + 6]; + R1 = P64[R1 + 14]; + P64[Sp] = _s3DD::P64; + +but if we don't inline the GlobalReg, instead we get: + + _s3DB::P64 = R1; + if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV; + c3EU: + I64[Sp - 8] = c3F0; + R1 = P64[_s3DB::P64 + 14]; + P64[Sp] = P64[_s3DB::P64 + 6]; + +This looks better - we managed to inline _s3DD - but in fact it +generates an extra reg-reg move: + +.Lc3EU: + movq $c3F0_info,-8(%rbp) + movq %rbx,%rax + movq 14(%rbx),%rbx + movq 6(%rax),%rax + movq %rax,(%rbp) + +because _s3DB is now live across the R1 assignment, we lost the +benefit of coalescing. + +Who is at fault here? Perhaps if we knew that _s3DB was an alias for +R1, then we would not sink a reference to _s3DB past the R1 +assignment. Or perhaps we *should* do that - we might gain by sinking +it, despite losing the coalescing opportunity. + +Sometimes not inlining global registers wins by virtue of the rule +about not inlining into arguments of a foreign call, e.g. (T7163) this +is what happens when we inlined F1: + + _s3L2::F32 = F1; + _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32); + (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(_c3O3::F32); + +but if we don't inline F1: + + (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(%MO_F_Mul_W32(_s3L2::F32, + 10.0 :: W32)); +-} diff --git a/GHC/Cmm/Switch.hs b/GHC/Cmm/Switch.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Switch.hs @@ -0,0 +1,496 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module GHC.Cmm.Switch ( + SwitchTargets, + mkSwitchTargets, + switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned, + mapSwitchTargets, mapSwitchTargetsA, switchTargetsToTable, switchTargetsFallThrough, + switchTargetsToList, eqSwitchTargetWith, + + SwitchPlan(..), + backendHasNativeSwitch, + createSwitchPlan, + ) where + +import GHC.Prelude hiding (head) + +import GHC.Utils.Outputable +import GHC.Driver.Backend +import GHC.Utils.Panic +import GHC.Cmm.Dataflow.Label (Label) + +import Data.Maybe +import Data.List.NonEmpty (NonEmpty (..), groupWith, head) +import qualified Data.Map as M + +-- Note [Cmm Switches, the general plan] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Compiling a high-level switch statement, as it comes out of a STG case +-- expression, for example, allows for a surprising amount of design decisions. +-- Therefore, we cleanly separated this from the Stg → Cmm transformation, as +-- well as from the actual code generation. +-- +-- The overall plan is: +-- * The Stg → Cmm transformation creates a single `SwitchTargets` in +-- emitSwitch and emitCmmLitSwitch in GHC.StgToCmm.Utils. +-- At this stage, they are unsuitable for code generation. +-- * A dedicated Cmm transformation (GHC.Cmm.Switch.Implement) replaces these +-- switch statements with code that is suitable for code generation, i.e. +-- a nice balanced tree of decisions with dense jump tables in the leafs. +-- The actual planning of this tree is performed in pure code in createSwitchPlan +-- in this module. See Note [createSwitchPlan]. +-- * The actual code generation will not do any further processing and +-- implement each CmmSwitch with a jump tables. +-- +-- When compiling to LLVM or C, GHC.Cmm.Switch.Implement leaves the switch +-- statements alone, as we can turn a SwitchTargets value into a nice +-- switch-statement in LLVM resp. C, and leave the rest to the compiler. +-- +-- See Note [GHC.Cmm.Switch vs. GHC.Cmm.Switch.Implement] why the two module are +-- separated. + + +-- Note [Magic Constants in GHC.Cmm.Switch] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- There are a lot of heuristics here that depend on magic values where it is +-- hard to determine the "best" value (for whatever that means). These are the +-- magic values: + +-- | Number of consecutive default values allowed in a jump table. If there are +-- more of them, the jump tables are split. +-- +-- Currently 7, as it costs 7 words of additional code when a jump table is +-- split (at least on x64, determined experimentally). +maxJumpTableHole :: Integer +maxJumpTableHole = 7 + +-- | Minimum size of a jump table. If the number is smaller, the switch is +-- implemented using conditionals. +-- Currently 5, because an if-then-else tree of 4 values is nice and compact. +minJumpTableSize :: Int +minJumpTableSize = 5 + +-- | Minimum non-zero offset for a jump table. See Note [Jump Table Offset]. +minJumpTableOffset :: Integer +minJumpTableOffset = 2 + + +----------------------------------------------------------------------------- +-- Switch Targets + +-- Note [SwitchTargets] +-- ~~~~~~~~~~~~~~~~~~~~ +-- The branches of a switch are stored in a SwitchTargets, which consists of an +-- (optional) default jump target, and a map from values to jump targets. +-- +-- If the default jump target is absent, the behaviour of the switch outside the +-- values of the map is undefined. +-- +-- We use an Integer for the keys the map so that it can be used in switches on +-- unsigned as well as signed integers. +-- +-- The map may be empty (we prune out-of-range branches here, so it could be us +-- emptying it). +-- +-- Before code generation, the table needs to be brought into a form where all +-- entries are non-negative, so that it can be compiled into a jump table. +-- See switchTargetsToTable. + + +-- | A value of type SwitchTargets contains the alternatives for a 'CmmSwitch' +-- value, and knows whether the value is signed, the possible range, an +-- optional default value and a map from values to jump labels. +data SwitchTargets = + SwitchTargets + Bool -- Signed values + (Integer, Integer) -- Range + (Maybe Label) -- Default value + (M.Map Integer Label) -- The branches + deriving (Show, Eq) + +-- | The smart constructor mkSwitchTargets normalises the map a bit: +-- * No entries outside the range +-- * No entries equal to the default +-- * No default if all elements have explicit values +mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets +mkSwitchTargets signed range@(lo,hi) mbdef ids + = SwitchTargets signed range mbdef' ids' + where + ids' = dropDefault $ restrict ids + mbdef' | defaultNeeded = mbdef + | otherwise = Nothing + + -- Drop entries outside the range, if there is a range + restrict = restrictMap (lo,hi) + + -- Drop entries that equal the default, if there is a default + dropDefault | Just l <- mbdef = M.filter (/= l) + | otherwise = id + + -- Check if the default is still needed + defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1 + + +-- | Changes all labels mentioned in the SwitchTargets value +mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets +mapSwitchTargets f (SwitchTargets signed range mbdef branches) + = SwitchTargets signed range (fmap f mbdef) (fmap f branches) + +-- | Changes all labels mentioned in the SwitchTargets value +mapSwitchTargetsA :: Applicative m => (Label -> m Label) -> SwitchTargets -> m SwitchTargets +mapSwitchTargetsA f (SwitchTargets signed range mbdef branches) + = SwitchTargets signed range <$> traverse f mbdef <*> traverse f branches + +-- | Returns the list of non-default branches of the SwitchTargets value +switchTargetsCases :: SwitchTargets -> [(Integer, Label)] +switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches + +-- | Return the default label of the SwitchTargets value +switchTargetsDefault :: SwitchTargets -> Maybe Label +switchTargetsDefault (SwitchTargets _ _ mbdef _) = mbdef + +-- | Return the range of the SwitchTargets value +switchTargetsRange :: SwitchTargets -> (Integer, Integer) +switchTargetsRange (SwitchTargets _ range _ _) = range + +-- | Return whether this is used for a signed value +switchTargetsSigned :: SwitchTargets -> Bool +switchTargetsSigned (SwitchTargets signed _ _ _) = signed + +-- | switchTargetsToTable creates a dense jump table, usable for code generation. +-- +-- Also returns an offset to add to the value; the list is 0-based on the +-- result of that addition. +-- +-- The conversion from Integer to Int is a bit of a wart, as the actual +-- scrutinee might be an unsigned word, but it just works, due to wrap-around +-- arithmetic (as verified by the CmmSwitchTest test case). +switchTargetsToTable :: SwitchTargets -> (Int, [Maybe Label]) +switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches) + = (fromIntegral (-start), [ labelFor i | i <- [start..hi] ]) + where + labelFor i = case M.lookup i branches of Just l -> Just l + Nothing -> mbdef + start | lo >= 0 && lo < minJumpTableOffset = 0 -- See Note [Jump Table Offset] + | otherwise = lo + +-- Note [Jump Table Offset] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- Usually, the code for a jump table starting at x will first subtract x from +-- the value, to avoid a large amount of empty entries. But if x is very small, +-- the extra entries are no worse than the subtraction in terms of code size, and +-- not having to do the subtraction is quicker. +-- +-- I.e. instead of +-- _u20N: +-- leaq -1(%r14),%rax +-- jmp *_n20R(,%rax,8) +-- _n20R: +-- .quad _c20p +-- .quad _c20q +-- do +-- _u20N: +-- jmp *_n20Q(,%r14,8) +-- +-- _n20Q: +-- .quad 0 +-- .quad _c20p +-- .quad _c20q +-- .quad _c20r + +-- | The list of all labels occurring in the SwitchTargets value. +switchTargetsToList :: SwitchTargets -> [Label] +switchTargetsToList (SwitchTargets _ _ mbdef branches) + = maybeToList mbdef ++ M.elems branches + +-- | Groups cases with equal targets, suitable for pretty-printing to a +-- c-like switch statement with fall-through semantics. +switchTargetsFallThrough :: SwitchTargets -> ([(NonEmpty Integer, Label)], Maybe Label) +switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef) + where + groups = fmap (\xs -> (fmap fst xs, snd (head xs))) $ + groupWith snd $ + M.toList branches + +-- | Custom equality helper, needed for "GHC.Cmm.CommonBlockElim" +eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool +eqSwitchTargetWith eq (SwitchTargets signed1 range1 mbdef1 ids1) (SwitchTargets signed2 range2 mbdef2 ids2) = + signed1 == signed2 && range1 == range2 && goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2) + where + goMB Nothing Nothing = True + goMB (Just l1) (Just l2) = l1 `eq` l2 + goMB _ _ = False + goList [] [] = True + goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2 + goList _ _ = False + +----------------------------------------------------------------------------- +-- Code generation for Switches + + +-- | A SwitchPlan abstractly describes how a Switch statement ought to be +-- implemented. See Note [createSwitchPlan] +data SwitchPlan + = Unconditionally Label + | IfEqual Integer Label SwitchPlan + | IfLT Bool Integer SwitchPlan SwitchPlan + | JumpTable SwitchTargets + deriving Show +-- +-- Note [createSwitchPlan] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- A SwitchPlan describes how a Switch statement is to be broken down into +-- smaller pieces suitable for code generation. +-- +-- createSwitchPlan creates such a switch plan, in these steps: +-- 1. It splits the switch statement at segments of non-default values that +-- are too large. See splitAtHoles and Note [Magic Constants in GHC.Cmm.Switch] +-- 2. Too small jump tables should be avoided, so we break up smaller pieces +-- in breakTooSmall. +-- 3. We fill in the segments between those pieces with a jump to the default +-- label (if there is one), returning a SeparatedList in mkFlatSwitchPlan +-- 4. We find and replace two less-than branches by a single equal-to-test in +-- findSingleValues +-- 5. The thus collected pieces are assembled to a balanced binary tree. + +{- + Note [Two alts + default] + ~~~~~~~~~~~~~~~~~~~~~~~~~ + +Discussion and a bit more info at #14644 + +When dealing with a switch of the form: +switch(e) { + case 1: goto l1; + case 3000: goto l2; + default: goto ldef; +} + +If we treat it as a sparse jump table we would generate: + +if (e > 3000) //Check if value is outside of the jump table. + goto ldef; +else { + if (e < 3000) { //Compare to upper value + if(e != 1) //Compare to remaining value + goto ldef; + else + goto l2; + } + else + goto l1; +} + +Instead we special case this to : + +if (e==1) goto l1; +else if (e==3000) goto l2; +else goto l3; + +This means we have: +* Less comparisons for: 1,<3000 +* Unchanged for 3000 +* One more for >3000 + +This improves code in a few ways: +* One comparison less means smaller code which helps with cache. +* It exchanges a taken jump for two jumps no taken in the >range case. + Jumps not taken are cheaper (See Agner guides) making this about as fast. +* For all other cases the first range check is removed making it faster. + +The end result is that the change is not measurably slower for the case +>3000 and faster for the other cases. + +This makes running this kind of match in an inner loop cheaper by 10-20% +depending on the data. +In nofib this improves wheel-sieve1 by 4-9% depending on problem +size. + +We could also add a second conditional jump after the comparison to +keep the range check like this: + cmp 3000, rArgument + jg + je +While this is fairly cheap it made no big difference for the >3000 case +and slowed down all other cases making it not worthwhile. +-} + + +-- | This function creates a SwitchPlan from a SwitchTargets value, breaking it +-- down into smaller pieces suitable for code generation. +createSwitchPlan :: SwitchTargets -> SwitchPlan +-- Lets do the common case of a singleton map quickly and efficiently (#10677) +createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m) + | [(x, l)] <- M.toList m + = IfEqual x l (Unconditionally defLabel) +-- And another common case, matching "booleans" +createSwitchPlan (SwitchTargets _signed (lo,hi) Nothing m) + | [(x1, l1), (_x2,l2)] <- M.toAscList m + --Checking If |range| = 2 is enough if we have two unique literals + , hi - lo == 1 + = IfEqual x1 l1 (Unconditionally l2) +-- See Note [Two alts + default] +createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m) + | [(x1, l1), (x2,l2)] <- M.toAscList m + = IfEqual x1 l1 (IfEqual x2 l2 (Unconditionally defLabel)) +createSwitchPlan (SwitchTargets signed range mbdef m) = + -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $ + plan + where + pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m + flatPlan = findSingleValues $ mkFlatSwitchPlan signed mbdef range pieces + plan = buildTree signed $ flatPlan + + +--- +--- Step 1: Splitting at large holes +--- +splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a] +splitAtHoles _ m | M.null m = [] +splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles + where + holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m)) + nonHoles = reassocTuples lo holes hi + + (lo,_) = M.findMin m + (hi,_) = M.findMax m + +--- +--- Step 2: Avoid small jump tables +--- +-- We do not want jump tables below a certain size. This breaks them up +-- (into singleton maps, for now). +breakTooSmall :: M.Map Integer a -> [M.Map Integer a] +breakTooSmall m + | M.size m > minJumpTableSize = [m] + | otherwise = [M.singleton k v | (k,v) <- M.toList m] + +--- +--- Step 3: Fill in the blanks +--- + +-- | A FlatSwitchPlan is a list of SwitchPlans, with an integer in between every +-- two entries, dividing the range. +-- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if +-- the expression is < n, and plan2 otherwise. + +type FlatSwitchPlan = SeparatedList Integer SwitchPlan + +mkFlatSwitchPlan :: Bool -> Maybe Label -> (Integer, Integer) -> [M.Map Integer Label] -> FlatSwitchPlan + +-- If we have no default (i.e. undefined where there is no entry), we can +-- branch at the minimum of each map +mkFlatSwitchPlan _ Nothing _ [] = pprPanic "mkFlatSwitchPlan with nothing left to do" empty +mkFlatSwitchPlan signed Nothing _ (m:ms) + = (mkLeafPlan signed Nothing m , [ (fst (M.findMin m'), mkLeafPlan signed Nothing m') | m' <- ms ]) + +-- If we have a default, we have to interleave segments that jump +-- to the default between the maps +mkFlatSwitchPlan signed (Just l) r ms = let ((_,p1):ps) = go r ms in (p1, ps) + where + go (lo,hi) [] + | lo > hi = [] + | otherwise = [(lo, Unconditionally l)] + go (lo,hi) (m:ms) + | lo < min + = (lo, Unconditionally l) : go (min,hi) (m:ms) + | lo == min + = (lo, mkLeafPlan signed (Just l) m) : go (max+1,hi) ms + | otherwise + = pprPanic "mkFlatSwitchPlan" (integer lo <+> integer min) + where + min = fst (M.findMin m) + max = fst (M.findMax m) + + +mkLeafPlan :: Bool -> Maybe Label -> M.Map Integer Label -> SwitchPlan +mkLeafPlan signed mbdef m + | [(_,l)] <- M.toList m -- singleton map + = Unconditionally l + | otherwise + = JumpTable $ mkSwitchTargets signed (min,max) mbdef m + where + min = fst (M.findMin m) + max = fst (M.findMax m) + +--- +--- Step 4: Reduce the number of branches using == +--- + +-- A sequence of three unconditional jumps, with the outer two pointing to the +-- same value and the bounds off by exactly one can be improved +findSingleValues :: FlatSwitchPlan -> FlatSwitchPlan +findSingleValues (Unconditionally l, (i, Unconditionally l2) : (i', Unconditionally l3) : xs) + | l == l3 && i + 1 == i' + = findSingleValues (IfEqual i l2 (Unconditionally l), xs) +findSingleValues (p, (i,p'):xs) + = (p,i) `consSL` findSingleValues (p', xs) +findSingleValues (p, []) + = (p, []) + +--- +--- Step 5: Actually build the tree +--- + +-- Build a balanced tree from a separated list +buildTree :: Bool -> FlatSwitchPlan -> SwitchPlan +buildTree _ (p,[]) = p +buildTree signed sl = IfLT signed m (buildTree signed sl1) (buildTree signed sl2) + where + (sl1, m, sl2) = divideSL sl + + + +-- +-- Utility data type: Non-empty lists with extra markers in between each +-- element: +-- + +type SeparatedList b a = (a, [(b,a)]) + +consSL :: (a, b) -> SeparatedList b a -> SeparatedList b a +consSL (a, b) (a', xs) = (a, (b,a'):xs) + +divideSL :: SeparatedList b a -> (SeparatedList b a, b, SeparatedList b a) +divideSL (_,[]) = error "divideSL: Singleton SeparatedList" +divideSL (p,xs) = ((p, xs1), m, (p', xs2)) + where + (xs1, (m,p'):xs2) = splitAt (length xs `div` 2) xs + +-- +-- Other Utilities +-- + +restrictMap :: (Integer,Integer) -> M.Map Integer b -> M.Map Integer b +restrictMap (lo,hi) m = mid + where (_, mid_hi) = M.split (lo-1) m + (mid, _) = M.split (hi+1) mid_hi + +-- for example: reassocTuples a [(b,c),(d,e)] f == [(a,b),(c,d),(e,f)] +reassocTuples :: a -> [(a,a)] -> a -> [(a,a)] +reassocTuples initial [] last + = [(initial,last)] +reassocTuples initial ((a,b):tuples) last + = (initial,a) : reassocTuples b tuples last + +-- Note [GHC.Cmm.Switch vs. GHC.Cmm.Switch.Implement] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- I (Joachim) separated the two somewhat closely related modules +-- +-- - GHC.Cmm.Switch, which provides the CmmSwitchTargets type and contains the strategy +-- for implementing a Cmm switch (createSwitchPlan), and +-- - GHC.Cmm.Switch.Implement, which contains the actual Cmm graph modification, +-- +-- for these reasons: +-- +-- * GHC.Cmm.Switch is very low in the dependency tree, i.e. does not depend on any +-- GHC specific modules at all (with the exception of Output and +-- GHC.Cmm.Dataflow (Literal)). +-- * GHC.Cmm.Switch.Implement is the Cmm transformation and hence very high in +-- the dependency tree. +-- * GHC.Cmm.Switch provides the CmmSwitchTargets data type, which is abstract, but +-- used in GHC.Cmm.Node. +-- * Because GHC.Cmm.Switch is low in the dependency tree, the separation allows +-- for more parallelism when building GHC. +-- * The interaction between the modules is very explicit and easy to +-- understand, due to the small and simple interface. diff --git a/GHC/Cmm/Switch/Implement.hs b/GHC/Cmm/Switch/Implement.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Switch/Implement.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE GADTs #-} +module GHC.Cmm.Switch.Implement + ( cmmImplementSwitchPlans + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Utils.Monad (concatMapM) +import GHC.Types.Unique.DSM + +-- +-- This module replaces Switch statements as generated by the Stg -> Cmm +-- transformation, which might be huge and sparse and hence unsuitable for +-- assembly code, by proper constructs (if-then-else trees, dense jump tables). +-- +-- The actual, abstract strategy is determined by createSwitchPlan in +-- GHC.Cmm.Switch and returned as a SwitchPlan; here is just the implementation in +-- terms of Cmm code. See Note [Cmm Switches, the general plan] in GHC.Cmm.Switch. +-- +-- This division into different modules is both to clearly separate concerns, +-- but also because createSwitchPlan needs access to the constructors of +-- SwitchTargets, a data type exported abstractly by GHC.Cmm.Switch. +-- + +-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for +-- code generation. +cmmImplementSwitchPlans :: Platform -> CmmGraph -> UniqDSM CmmGraph +cmmImplementSwitchPlans platform g = + -- Switch generation done by backend (LLVM/C) + do + blocks' <- concatMapM (visitSwitches platform) (toBlockList g) + return $ ofBlockList (g_entry g) blocks' + +visitSwitches :: Platform -> CmmBlock -> UniqDSM [CmmBlock] +visitSwitches platform block + | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block + = do + let plan = createSwitchPlan ids + -- See Note [Floating switch expressions] + (assignSimple, simpleExpr) <- floatSwitchExpr platform vanillaExpr + + (newTail, newBlocks) <- implementSwitchPlan platform scope simpleExpr plan + + let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail + + return $ block' : newBlocks + + | otherwise + = return [block] + +-- Note [Floating switch expressions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When we translate a sparse switch into a search tree we would like +-- to compute the value we compare against only once. +-- +-- For this purpose we assign the switch expression to a local register +-- and then use this register when constructing the actual binary tree. +-- +-- This is important as the expression could contain expensive code like +-- memory loads or divisions which we REALLY don't want to duplicate. +-- +-- This happened in parts of the handwritten RTS Cmm code. See also #16933 + +-- See Note [Floating switch expressions] +floatSwitchExpr :: Platform -> CmmExpr -> UniqDSM (Block CmmNode O O, CmmExpr) +floatSwitchExpr _ reg@(CmmReg {}) = return (emptyBlock, reg) +floatSwitchExpr platform expr = do + (assign, expr') <- cmmMkAssign platform expr <$> getUniqueDSM + return (BMiddle assign, expr') + + +-- Implementing a switch plan (returning a tail block) +implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqDSM (Block CmmNode O C, [CmmBlock]) +implementSwitchPlan platform scope expr = go + where + width = typeWidth $ cmmExprType platform expr + + go (Unconditionally l) + = return (emptyBlock `blockJoinTail` CmmBranch l, []) + go (JumpTable ids) + = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, []) + go (IfLT signed i ids1 ids2) + = do + (bid1, newBlocks1) <- go' ids1 + (bid2, newBlocks2) <- go' ids2 + + let lt | signed = MO_S_Lt + | otherwise = MO_U_Lt + scrut = CmmMachOp (lt width) [expr, CmmLit $ CmmInt i width] + lastNode = CmmCondBranch scrut bid1 bid2 Nothing + lastBlock = emptyBlock `blockJoinTail` lastNode + return (lastBlock, newBlocks1++newBlocks2) + go (IfEqual i l ids2) + = do + (bid2, newBlocks2) <- go' ids2 + + let scrut = CmmMachOp (MO_Ne width) [expr, CmmLit $ CmmInt i width] + lastNode = CmmCondBranch scrut bid2 l Nothing + lastBlock = emptyBlock `blockJoinTail` lastNode + return (lastBlock, newBlocks2) + + -- Same but returning a label to branch to + go' (Unconditionally l) + = return (l, []) + go' p + = do + bid <- mkBlockId `fmap` getUniqueDSM + (last, newBlocks) <- go p + let block = CmmEntry bid scope `blockJoinHead` last + return (bid, block: newBlocks) diff --git a/GHC/Cmm/ThreadSanitizer.hs b/GHC/Cmm/ThreadSanitizer.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/ThreadSanitizer.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +-- | Annotate a CmmGraph with ThreadSanitizer instrumentation calls. +module GHC.Cmm.ThreadSanitizer (annotateTSAN) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Regs (activeStgRegs, callerSaves) +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Data.FastString +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import GHC.Cmm.Dataflow.Label + +import Data.Maybe (fromMaybe) + +data Env = Env { platform :: Platform + , uniques :: UniqSupply + } + +annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph +annotateTSAN platform graph = do + env <- Env platform <$> getUniqueSupplyM + return $ modifyGraph (mapGraphBlocks mapMap (annotateBlock env)) graph + +mapBlockList :: (forall e' x'. n e' x' -> Block n e' x') + -> Block n e x -> Block n e x +mapBlockList f (BlockCO n rest ) = f n `blockAppend` mapBlockList f rest +mapBlockList f (BlockCC n rest m) = f n `blockAppend` mapBlockList f rest `blockAppend` f m +mapBlockList f (BlockOC rest m) = mapBlockList f rest `blockAppend` f m +mapBlockList _ BNil = BNil +mapBlockList f (BMiddle blk) = f blk +mapBlockList f (BCat a b) = mapBlockList f a `blockAppend` mapBlockList f b +mapBlockList f (BSnoc a n) = mapBlockList f a `blockAppend` f n +mapBlockList f (BCons n a) = f n `blockAppend` mapBlockList f a + +annotateBlock :: Env -> Block CmmNode e x -> Block CmmNode e x +annotateBlock env = mapBlockList (annotateNode env) + +annotateNode :: Env -> CmmNode e x -> Block CmmNode e x +annotateNode env node = + case node of + CmmEntry{} -> BlockCO node BNil + CmmComment{} -> BMiddle node + CmmTick{} -> BMiddle node + CmmUnwind{} -> BMiddle node + CmmAssign{} -> annotateNodeOO env node + -- TODO: Track unaligned stores + CmmStore _ _ Unaligned -> annotateNodeOO env node + CmmStore lhs rhs NaturallyAligned -> + let ty = cmmExprType (platform env) rhs + rhs_nodes = annotateLoads env (collectExprLoads rhs) + lhs_nodes = annotateLoads env (collectExprLoads lhs) + st = tsanStore env ty lhs + in rhs_nodes `blockAppend` lhs_nodes `blockAppend` st `blockSnoc` node + CmmUnsafeForeignCall (PrimTarget op) formals args -> + let node' = fromMaybe (BMiddle node) (annotatePrim env op formals args) + arg_nodes = blockConcat $ map (annotateExpr env) args + in arg_nodes `blockAppend` node' + CmmUnsafeForeignCall{} -> annotateNodeOO env node + CmmBranch{} -> annotateNodeOC env node + CmmCondBranch{} -> annotateNodeOC env node + CmmSwitch{} -> annotateNodeOC env node + CmmCall{} -> annotateNodeOC env node + CmmForeignCall{} -> annotateNodeOC env node + +annotateNodeOO :: Env -> CmmNode O O -> Block CmmNode O O +annotateNodeOO env node = + annotateLoads env (collectLoadsNode node) `blockSnoc` node + +annotateNodeOC :: Env -> CmmNode O C -> Block CmmNode O C +annotateNodeOC env node = + annotateLoads env (collectLoadsNode node) `blockJoinTail` node + +annotateExpr :: Env -> CmmExpr -> Block CmmNode O O +annotateExpr env expr = + annotateLoads env (collectExprLoads expr) + +-- | A load mentioned in a 'CmmExpr'. +data Load = Load CmmType AlignmentSpec CmmExpr + +annotateLoads :: Env -> [Load] -> Block CmmNode O O +annotateLoads env loads = + blockConcat + [ tsanLoad env align ty addr + | Load ty align addr <- loads + ] + +collectLoadsNode :: CmmNode e x -> [Load] +collectLoadsNode node = + foldExp (\exp rest -> collectExprLoads exp ++ rest) node [] + +-- | Collect all of the memory locations loaded from by a 'CmmExpr'. +collectExprLoads :: CmmExpr -> [Load] +collectExprLoads (CmmLit _) = [] +collectExprLoads (CmmLoad e ty align) = [Load ty align e] +collectExprLoads (CmmReg _) = [] +-- N.B. we don't bother telling TSAN about MO_RelaxedReads +-- since doing so would be inconvenient and they by +-- definition can neither race nor introduce ordering. +collectExprLoads (CmmMachOp _op args) = foldMap collectExprLoads args +collectExprLoads (CmmStackSlot _ _) = [] +collectExprLoads (CmmRegOff _ _) = [] + +-- | Generate TSAN instrumentation for a 'CallishMachOp' occurrence. +annotatePrim :: Env + -> CallishMachOp -- ^ the applied operation + -> [CmmFormal] -- ^ results + -> [CmmActual] -- ^ arguments + -> Maybe (Block CmmNode O O) + -- ^ 'Just' a block of instrumentation, if applicable +annotatePrim env (MO_AtomicRMW w aop) [dest] [addr, val] = Just $ tsanAtomicRMW env MemOrderSeqCst aop w addr val dest +annotatePrim env (MO_AtomicRead w mord) [dest] [addr] = Just $ tsanAtomicLoad env mord w addr dest +annotatePrim env (MO_AtomicWrite w mord) [] [addr, val] = Just $ tsanAtomicStore env mord w val addr +annotatePrim env (MO_Xchg w) [dest] [addr, val] = Just $ tsanAtomicExchange env MemOrderSeqCst w val addr dest +annotatePrim env (MO_Cmpxchg w) [dest] [addr, expected, new] + = Just $ tsanAtomicCas env MemOrderSeqCst MemOrderSeqCst w addr expected new dest +annotatePrim _ _ _ _ = Nothing + +mkUnsafeCall :: Env + -> ForeignTarget -- ^ function + -> [CmmFormal] -- ^ results + -> [CmmActual] -- ^ arguments + -> Block CmmNode O O +mkUnsafeCall env ftgt formals args = + save `blockAppend` -- save global registers + bind_args `blockSnoc` -- bind arguments to local registers + call `blockAppend` -- perform call + restore -- restore global registers + where + (save, restore) = saveRestoreCallerRegs gregs_us (platform env) + + (arg_us, gregs_us) = splitUniqSupply (uniques env) + + -- We also must be careful not to mention caller-saved registers in + -- arguments as Cmm-Lint checks this. To accomplish this we instead bind + -- the arguments to local registers. + arg_regs :: [CmmReg] + arg_regs = zipWith arg_reg (uniqsFromSupply arg_us) args + where + arg_reg :: Unique -> CmmExpr -> CmmReg + arg_reg u expr = CmmLocal $ LocalReg u (cmmExprType (platform env) expr) + + bind_args :: Block CmmNode O O + bind_args = blockConcat $ zipWith (\r e -> BMiddle $ CmmAssign r e) arg_regs args + + call = CmmUnsafeForeignCall ftgt formals (map CmmReg arg_regs) + +-- | We save the contents of global registers in locals and allow the +-- register allocator to spill them to the stack around the call. +-- We cannot use the register table for this since we would interface +-- with {SAVE,RESTORE}_THREAD_STATE. +saveRestoreCallerRegs :: UniqSupply -> Platform + -> (Block CmmNode O O, Block CmmNode O O) +saveRestoreCallerRegs us platform = + (save, restore) + where + regs_to_save :: [GlobalReg] + regs_to_save = filter (callerSaves platform) (activeStgRegs platform) + + nodes :: [(CmmNode O O, CmmNode O O)] + nodes = + zipWith mk_reg regs_to_save (uniqsFromSupply us) + where + mk_reg :: GlobalReg -> Unique -> (CmmNode O O, CmmNode O O) + mk_reg reg u = + let ty = globalRegSpillType platform reg + greg = CmmGlobal (GlobalRegUse reg ty) + lreg = CmmLocal (LocalReg u ty) + save = CmmAssign lreg (CmmReg greg) + restore = CmmAssign greg (CmmReg lreg) + in (save, restore) + + (save_nodes, restore_nodes) = unzip nodes + save = blockFromList save_nodes + restore = blockFromList restore_nodes + +-- | Mirrors __tsan_memory_order +-- +memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr +memoryOrderToTsanMemoryOrder env mord = + mkIntExpr (platform env) n + where + n = case mord of + MemOrderRelaxed -> 0 + MemOrderAcquire -> 2 + MemOrderRelease -> 3 + MemOrderSeqCst -> 5 + +tsanTarget :: FastString -- ^ function name + -> [ForeignHint] -- ^ formals + -> [ForeignHint] -- ^ arguments + -> ForeignTarget +tsanTarget fn formals args = + ForeignTarget (CmmLit (CmmLabel lbl)) conv + where + conv = ForeignConvention CCallConv args formals CmmMayReturn + lbl = mkForeignLabel fn ForeignLabelInExternalPackage IsFunction + +tsanStore :: Env + -> CmmType -> CmmExpr + -> Block CmmNode O O +tsanStore env ty addr + | typeWidth ty < W128 = mkUnsafeCall env ftarget [] [addr] + | otherwise = emptyBlock + where + ftarget = tsanTarget fn [] [AddrHint] + w = widthInBytes (typeWidth ty) + fn = fsLit $ "__tsan_write" ++ show w + +tsanLoad :: Env + -> AlignmentSpec -> CmmType -> CmmExpr + -> Block CmmNode O O +tsanLoad env align ty addr + | typeWidth ty < W128 = mkUnsafeCall env ftarget [] [addr] + | otherwise = emptyBlock + where + ftarget = tsanTarget fn [] [AddrHint] + w = widthInBytes (typeWidth ty) + fn = case align of + Unaligned + | w > 1 -> fsLit $ "__tsan_unaligned_read" ++ show w + _ -> fsLit $ "__tsan_read" ++ show w + +tsanAtomicStore :: Env + -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr + -> Block CmmNode O O +tsanAtomicStore env mord w val addr = + mkUnsafeCall env ftarget [] [addr, val, mord'] + where + mord' = memoryOrderToTsanMemoryOrder env mord + ftarget = tsanTarget fn [] [AddrHint, NoHint, NoHint] + fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_store" + +tsanAtomicLoad :: Env + -> MemoryOrdering -> Width -> CmmExpr -> LocalReg + -> Block CmmNode O O +tsanAtomicLoad env mord w addr dest = + mkUnsafeCall env ftarget [dest] [addr, mord'] + where + mord' = memoryOrderToTsanMemoryOrder env mord + ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint] + fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_load" + +tsanAtomicExchange :: Env + -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr -> LocalReg + -> Block CmmNode O O +tsanAtomicExchange env mord w val addr dest = + mkUnsafeCall env ftarget [dest] [addr, val, mord'] + where + mord' = memoryOrderToTsanMemoryOrder env mord + ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint] + fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_exchange" + +-- N.B. C11 CAS returns a boolean (to avoid the ABA problem) whereas Cmm's CAS +-- returns the expected value. We use define a shim in the RTS to provide +-- Cmm's semantics using the TSAN C11 primitive. +tsanAtomicCas :: Env + -> MemoryOrdering -- ^ success ordering + -> MemoryOrdering -- ^ failure ordering + -> Width + -> CmmExpr -- ^ address + -> CmmExpr -- ^ expected value + -> CmmExpr -- ^ new value + -> LocalReg -- ^ result destination + -> Block CmmNode O O +tsanAtomicCas env mord_success mord_failure w addr expected new dest = + mkUnsafeCall env ftarget [dest] [addr, expected, new, mord_success', mord_failure'] + where + mord_success' = memoryOrderToTsanMemoryOrder env mord_success + mord_failure' = memoryOrderToTsanMemoryOrder env mord_failure + ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint, NoHint, NoHint] + fn = fsLit $ "ghc_tsan_atomic" ++ show (widthInBits w) ++ "_compare_exchange" + +tsanAtomicRMW :: Env + -> MemoryOrdering -> AtomicMachOp -> Width -> CmmExpr -> CmmExpr -> LocalReg + -> Block CmmNode O O +tsanAtomicRMW env mord op w addr val dest = + mkUnsafeCall env ftarget [dest] [addr, val, mord'] + where + mord' = memoryOrderToTsanMemoryOrder env mord + ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint] + op' = case op of + AMO_Add -> "fetch_add" + AMO_Sub -> "fetch_sub" + AMO_And -> "fetch_and" + AMO_Nand -> "fetch_nand" + AMO_Or -> "fetch_or" + AMO_Xor -> "fetch_xor" + fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_" ++ op' diff --git a/GHC/Cmm/Type.hs b/GHC/Cmm/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Type.hs @@ -0,0 +1,498 @@ +module GHC.Cmm.Type + ( CmmType -- Abstract + , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord + , cInt + , cmmBits, cmmFloat + , typeWidth, setCmmTypeWidth + , cmmEqType, cmmCompatType + , isFloatType, isGcPtrType, isBitsType + , isWordAny, isWord32, isWord64 + , isFloat64, isFloat32 + + , Width(..) + , widthInBits, widthInBytes, widthInLog, widthFromBytes + , wordWidth, halfWordWidth, cIntWidth + , halfWordMask + , narrowU, narrowS + , rEP_CostCentreStack_mem_alloc + , rEP_CostCentreStack_scc_count + , rEP_StgEntCounter_allocs + , rEP_StgEntCounter_allocd + + , ForeignHint(..) + + , Length + , vec, vec2, vec4, vec8, vec16 + , vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 + , cmmVec + , vecLength, vecElemType + , isVecType + + , DoAlignSanitisation + ) +where + + +import GHC.Prelude + +import GHC.Platform +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Word +import Data.Int + +----------------------------------------------------------------------------- +-- CmmType +----------------------------------------------------------------------------- + + -- NOTE: CmmType is an abstract type, not exported from this + -- module so you can easily change its representation + -- + -- However Width is exported in a concrete way, + -- and is used extensively in pattern-matching + +data CmmType -- The important one! + = CmmType CmmCat !Width + deriving Show + +data CmmCat -- "Category" (not exported) + = GcPtrCat -- ^ GC pointer + | BitsCat -- ^ Integer (including non-GC pointer addresses) + -- + -- Makes no distinction between signed and unsigned integers, + -- see Note [Signed vs unsigned] in GHC.Cmm.Type. + | FloatCat -- ^ Float + | VecCat Length CmmCat -- ^ Vector + deriving( Eq, Show ) + +instance Outputable CmmType where + ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid) + +instance Outputable CmmCat where + ppr FloatCat = text "F" + ppr GcPtrCat = text "P" + ppr BitsCat = text "I" + ppr (VecCat n cat) = ppr cat <> text "x" <> ppr n <> text "V" + +-- Why is CmmType stratified? For native code generation, +-- most of the time you just want to know what sort of register +-- to put the thing in, and for this you need to know how +-- many bits thing has, and whether it goes in a floating-point +-- register. By contrast, the distinction between GcPtr and +-- GcNonPtr is of interest to only a few parts of the code generator. + +-------- Equality on CmmType -------------- +-- CmmType is *not* an instance of Eq; sometimes we care about the +-- Gc/NonGc distinction, and sometimes we don't +-- So we use an explicit function to force you to think about it +cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality +cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2 + +-- | A weaker notion of equality of 'CmmType's than 'cmmEqType', +-- used (only) in Cmm Lint. +-- +-- Why "weaker"? Because: +-- +-- - we don't distinguish GcPtr vs NonGcPtr, because the the RTS files +-- are not yet well-typed wrt pointers, +-- - for vectors, we only compare the widths, because in practice things like +-- X86 xmm registers support different types of data (e.g. 4xf32, 2xf64, 2xu64 etc). +cmmCompatType :: CmmType -> CmmType -> Bool +cmmCompatType (CmmType c1 w1) (CmmType c2 w2) + = c1 `weak_eq` c2 && w1 == w2 + where + weak_eq :: CmmCat -> CmmCat -> Bool + FloatCat `weak_eq` FloatCat = True + FloatCat `weak_eq` _other = False + _other `weak_eq` FloatCat = False + (VecCat {}) `weak_eq` (VecCat {}) = True -- only compare overall width + (VecCat {}) `weak_eq` _other = False + _other `weak_eq` (VecCat {}) = False + _word1 `weak_eq` _word2 = True -- Ignores GcPtr + +--- Simple operations on CmmType ----- +typeWidth :: CmmType -> Width +typeWidth (CmmType _ w) = w + +setCmmTypeWidth :: Width -> CmmType -> CmmType +setCmmTypeWidth w (CmmType c _) = CmmType c w + +cmmBits, cmmFloat :: Width -> CmmType +cmmBits = CmmType BitsCat +cmmFloat = CmmType FloatCat + +-------- Common CmmTypes ------------ +-- Floats and words of specific widths +b8, b16, b32, b64, b128, b256, b512, f32, f64 :: CmmType +b8 = cmmBits W8 +b16 = cmmBits W16 +b32 = cmmBits W32 +b64 = cmmBits W64 +b128 = cmmBits W128 +b256 = cmmBits W256 +b512 = cmmBits W512 +f32 = cmmFloat W32 +f64 = cmmFloat W64 + +-- CmmTypes of native word widths +bWord :: Platform -> CmmType +bWord platform = cmmBits (wordWidth platform) + +bHalfWord :: Platform -> CmmType +bHalfWord platform = cmmBits (halfWordWidth platform) + +gcWord :: Platform -> CmmType +gcWord platform = CmmType GcPtrCat (wordWidth platform) + +cInt :: Platform -> CmmType +cInt platform = cmmBits (cIntWidth platform) + +------------ Predicates ---------------- +isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool +isFloatType (CmmType FloatCat _) = True +isFloatType _other = False + +isGcPtrType (CmmType GcPtrCat _) = True +isGcPtrType _other = False + +isBitsType (CmmType BitsCat _) = True +isBitsType _ = False + +isWordAny, isWord32, isWord64, + isFloat32, isFloat64 :: CmmType -> Bool +-- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise) +-- isFloat32 and 64 are obvious + +isWordAny (CmmType BitsCat _) = True +isWordAny (CmmType GcPtrCat _) = True +isWordAny _other = False + +isWord64 (CmmType BitsCat W64) = True +isWord64 (CmmType GcPtrCat W64) = True +isWord64 _other = False + +isWord32 (CmmType BitsCat W32) = True +isWord32 (CmmType GcPtrCat W32) = True +isWord32 _other = False + +isFloat32 (CmmType FloatCat W32) = True +isFloat32 _other = False + +isFloat64 (CmmType FloatCat W64) = True +isFloat64 _other = False + +----------------------------------------------------------------------------- +-- Width +----------------------------------------------------------------------------- + +data Width + = W8 + | W16 + | W32 + | W64 + | W128 + | W256 + | W512 + deriving (Eq, Ord, Show) + +instance Outputable Width where + ppr rep = text (show rep) + +-------- Common Widths ------------ + +-- | The width of the current platform's word size. +wordWidth :: Platform -> Width +wordWidth platform = case platformWordSize platform of + PW4 -> W32 + PW8 -> W64 + +-- | The width of the current platform's half-word size. +halfWordWidth :: Platform -> Width +halfWordWidth platform = case platformWordSize platform of + PW4 -> W16 + PW8 -> W32 + +-- | A bit-mask for the lower half-word of current platform. +halfWordMask :: Platform -> Integer +halfWordMask platform = case platformWordSize platform of + PW4 -> 0xFFFF + PW8 -> 0xFFFFFFFF + +-- cIntRep is the Width for a C-language 'int' +cIntWidth :: Platform -> Width +cIntWidth platform = case pc_CINT_SIZE (platformConstants platform) of + 4 -> W32 + 8 -> W64 + s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s) + +-- | A width in bits. +widthInBits :: Width -> Int +widthInBits W8 = 8 +widthInBits W16 = 16 +widthInBits W32 = 32 +widthInBits W64 = 64 +widthInBits W128 = 128 +widthInBits W256 = 256 +widthInBits W512 = 512 + +-- | A width in bytes. +-- +-- > widthFromBytes (widthInBytes w) === w +widthInBytes :: Width -> Int +widthInBytes W8 = 1 +widthInBytes W16 = 2 +widthInBytes W32 = 4 +widthInBytes W64 = 8 +widthInBytes W128 = 16 +widthInBytes W256 = 32 +widthInBytes W512 = 64 + + +-- | *Partial* A width from the number of bytes. +widthFromBytes :: Int -> Width +widthFromBytes 1 = W8 +widthFromBytes 2 = W16 +widthFromBytes 4 = W32 +widthFromBytes 8 = W64 +widthFromBytes 16 = W128 +widthFromBytes 32 = W256 +widthFromBytes 64 = W512 + +widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n) + +-- | log_2 of the width in bytes, useful for generating shifts. +widthInLog :: Width -> Int +widthInLog W8 = 0 +widthInLog W16 = 1 +widthInLog W32 = 2 +widthInLog W64 = 3 +widthInLog W128 = 4 +widthInLog W256 = 5 +widthInLog W512 = 6 + + +-- widening / narrowing + +-- | Narrow a signed or unsigned value to the given width. The result will +-- reside in @[0, +2^width)@. +-- +-- >>> narrowU W8 256 == 256 +-- >>> narrowU W8 255 == 255 +-- >>> narrowU W8 128 == 128 +-- >>> narrowU W8 127 == 127 +-- >>> narrowU W8 0 == 0 +-- >>> narrowU W8 (-127) == 129 +-- >>> narrowU W8 (-128) == 128 +-- >>> narrowU W8 (-129) == 127 +-- >>> narrowU W8 (-255) == 1 +-- >>> narrowU W8 (-256) == 0 +-- +narrowU :: Width -> Integer -> Integer +narrowU W8 x = fromIntegral (fromIntegral x :: Word8) +narrowU W16 x = fromIntegral (fromIntegral x :: Word16) +narrowU W32 x = fromIntegral (fromIntegral x :: Word32) +narrowU W64 x = fromIntegral (fromIntegral x :: Word64) +narrowU _ _ = panic "narrowTo" + +-- | Narrow a signed value to the given width. The result will reside +-- in @[-2^(width-1), +2^(width-1))@. +-- +-- >>> narrowS W8 256 == 0 +-- >>> narrowS W8 255 == -1 +-- >>> narrowS W8 128 == -128 +-- >>> narrowS W8 127 == 127 +-- >>> narrowS W8 0 == 0 +-- >>> narrowS W8 (-127) == -127 +-- >>> narrowS W8 (-128) == -128 +-- >>> narrowS W8 (-129) == 127 +-- >>> narrowS W8 (-255) == 1 +-- >>> narrowS W8 (-256) == 0 +-- +narrowS :: Width -> Integer -> Integer +narrowS W8 x = fromIntegral (fromIntegral x :: Int8) +narrowS W16 x = fromIntegral (fromIntegral x :: Int16) +narrowS W32 x = fromIntegral (fromIntegral x :: Int32) +narrowS W64 x = fromIntegral (fromIntegral x :: Int64) +narrowS _ _ = panic "narrowTo" + +----------------------------------------------------------------------------- +-- SIMD +----------------------------------------------------------------------------- + +type Length = Int + +vec :: Length -> CmmType -> CmmType +vec l (CmmType cat w) = CmmType (VecCat l cat) vecw + where + vecw :: Width + vecw = widthFromBytes (l*widthInBytes w) + +vec2, vec4, vec8, vec16 :: CmmType -> CmmType +vec2 = vec 2 +vec4 = vec 4 +vec8 = vec 8 +vec16 = vec 16 + +vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 :: CmmType +vec2f64 = vec 2 f64 +vec2b64 = vec 2 b64 +vec4f32 = vec 4 f32 +vec4b32 = vec 4 b32 +vec8b16 = vec 8 b16 +vec16b8 = vec 16 b8 + +cmmVec :: Int -> CmmType -> CmmType +cmmVec n (CmmType cat w) = + CmmType (VecCat n cat) (widthFromBytes (n*widthInBytes w)) + +vecLength :: CmmType -> Length +vecLength (CmmType (VecCat l _) _) = l +vecLength _ = panic "vecLength: not a vector" + +vecElemType :: CmmType -> CmmType +vecElemType (CmmType (VecCat l cat) w) = CmmType cat scalw + where + scalw :: Width + scalw = widthFromBytes (widthInBytes w `div` l) +vecElemType _ = panic "vecElemType: not a vector" + +isVecType :: CmmType -> Bool +isVecType (CmmType (VecCat {}) _) = True +isVecType _ = False + +------------------------------------------------------------------------- +-- Hints + +-- Hints are extra type information we attach to the arguments and +-- results of a foreign call, where more type information is sometimes +-- needed by the ABI to make the correct kind of call. +-- +-- See Note [Signed vs unsigned] for one case where this is used. + +data ForeignHint + = NoHint | AddrHint | SignedHint + deriving( Eq ) + -- Used to give extra per-argument or per-result + -- information needed by foreign calling conventions + +instance Outputable ForeignHint where + ppr NoHint = empty + ppr SignedHint = quotes(text "signed") +-- ppr AddrHint = quotes(text "address") +-- Temp Jan08 + ppr AddrHint = (text "PtrHint") + + +------------------------------------------------------------------------- + +-- These don't really belong here, but I don't know where is best to +-- put them. + +rEP_CostCentreStack_mem_alloc :: Platform -> CmmType +rEP_CostCentreStack_mem_alloc platform + = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc)) + where pc = platformConstants platform + +rEP_CostCentreStack_scc_count :: Platform -> CmmType +rEP_CostCentreStack_scc_count platform + = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc)) + where pc = platformConstants platform + +rEP_StgEntCounter_allocs :: Platform -> CmmType +rEP_StgEntCounter_allocs platform + = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc)) + where pc = platformConstants platform + +rEP_StgEntCounter_allocd :: Platform -> CmmType +rEP_StgEntCounter_allocd platform + = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc)) + where pc = platformConstants platform + +------------------------------------------------------------------------- +{- Note [Signed vs unsigned] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +Should a CmmType include a signed vs. unsigned distinction? + +This is very much like a "hint" in C-- terminology: it isn't necessary +in order to generate correct code, but it might be useful in that the +compiler can generate better code if it has access to higher-level +hints about data. This is important at call boundaries, because the +definition of a function is not visible at all of its call sites, so +the compiler cannot infer the hints. + +Here in Cmm, we're taking a slightly different approach. We include +the int vs. float hint in the CmmType, because (a) the majority of +platforms have a strong distinction between float and int registers, +and (b) we don't want to do any heavyweight hint-inference in the +native code backend in order to get good code. We're treating the +hint more like a type: our Cmm is always completely consistent with +respect to hints. All coercions between float and int are explicit. + +What about the signed vs. unsigned hint? This information might be +useful if we want to keep sub-word-sized values in word-size +registers, which we must do if we only have word-sized registers. + +On such a system, there are two straightforward conventions for +representing sub-word-sized values: + +(a) Leave the upper bits undefined. Comparison operations must + sign- or zero-extend both operands before comparing them, + depending on whether the comparison is signed or unsigned. + +(b) Always keep the values sign- or zero-extended as appropriate. + Arithmetic operations must narrow the result to the appropriate + size. + +A clever compiler might not use either (a) or (b) exclusively, instead +it would attempt to minimize the coercions by analysis: the same kind +of analysis that propagates hints around. In Cmm we don't want to +have to do this, so we plump for having richer types and keeping the +type information consistent. + +If signed/unsigned hints are missing from CmmType, then the only +choice we have is (a), because we don't know whether the result of an +operation should be sign- or zero-extended. + +Many architectures have extending load operations, which work well +with (b). To make use of them with (a), you need to know whether the +value is going to be sign- or zero-extended by an enclosing comparison +(for example), which involves knowing above the context. This is +doable but more complex. + +Further complicating the issue is foreign calls: a foreign calling +convention can specify that signed 8-bit quantities are passed as +sign-extended 32 bit quantities, for example (this is the case on the +PowerPC). So we *do* need sign information on foreign call arguments. + +Pros for adding signed vs. unsigned to CmmType: + + - It would let us use convention (b) above, and get easier + code generation for extending loads. + + - Less information required on foreign calls. + + - MachOp type would be simpler + +Cons: + + - More complexity + + - What is the CmmType for a VanillaReg? Currently it is + always wordRep, but now we have to decide whether it is + signed or unsigned. The same VanillaReg can thus have + different CmmType in different parts of the program. + + - Extra coercions cluttering up expressions. + +Currently for GHC, the foreign call point is moot, because we do our +own promotion of sub-word-sized values to word-sized values. The Int8 +type is represented by an Int# which is kept sign-extended at all times +(this is slightly naughty, because we're making assumptions about the +C calling convention rather early on in the compiler). However, given +this, the cons outweigh the pros. + +-} + +-- | is @-falignment-sanitisation@ enabled? +type DoAlignSanitisation = Bool diff --git a/GHC/Cmm/UniqueRenamer.hs b/GHC/Cmm/UniqueRenamer.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/UniqueRenamer.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE LambdaCase, RecordWildCards, MagicHash, UnboxedTuples, PatternSynonyms, ExplicitNamespaces #-} +module GHC.Cmm.UniqueRenamer + ( detRenameCmmGroup + , detRenameIPEMap + , MonadGetUnique(..) + + -- Careful! Not for general use! + , DetUniqFM, emptyDetUFM + + , module GHC.Types.Unique.DSM + ) + where + +import GHC.Prelude +import GHC.Utils.Monad.State.Strict +import Data.Tuple (swap) +import GHC.Word +import GHC.Cmm +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Switch +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Utils.Outputable as Outputable +import GHC.Types.Id +import GHC.Types.Unique.DSM +import GHC.Types.Name hiding (varName) +import GHC.Types.Var +import GHC.Types.IPE + +{- +Note [Renaming uniques deterministically] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As mentioned by Note [Object determinism], a key step in producing +deterministic objects is to rename all existing uniques deterministically. + +An important observation is that GHC already produces code in a deterministic +order, both declarations (say, A_closure always comes before B_closure) and the +instructions and data within. + +We can leverage this /deterministic order/ to +rename all uniques deterministically, by traversing, specifically, Cmm code +fresh off of StgToCmm and assigning a new unique from a deterministic supply +(an incrementing counter) to every non-external unique in the order they are found. + +Since the order is deterministic across runs, so will the renamed uniques. + +This Cmm renaming pass is guarded by -fobject-determinism because it means the +compiler must do more work. However, performance profiling has shown the impact +to be small enough that we should consider enabling -fobject-determinism by +default instead eventually. +-} + +-- | A mapping from non-deterministic uniques to deterministic uniques, to +-- rename local symbols with the end goal of producing deterministic object files. +-- See Note [Renaming uniques deterministically] +data DetUniqFM = DetUniqFM + { mapping :: !(UniqFM Unique Unique) + , supply :: !Word64 + } + +instance Outputable DetUniqFM where + ppr DetUniqFM{mapping, supply} = + ppr mapping $$ + text "supply:" Outputable.<> ppr supply + +type DetRnM = State DetUniqFM + +emptyDetUFM :: DetUniqFM +emptyDetUFM = DetUniqFM + { mapping = emptyUFM + -- NB: A lower initial value can get us label `Lsl` which is not parsed + -- correctly in older versions of LLVM assembler (llvm-project#80571) + -- So we use an `x` s.t. w64ToBase62 x > "R" > "L" > "r" > "l" + , supply = 54 + } + +renameDetUniq :: Unique -> DetRnM Unique +renameDetUniq uq = do + m <- gets mapping + case lookupUFM m uq of + Nothing -> do + new_w <- gets supply -- New deterministic unique in this `DetRnM` + let --(_tag, _) = unpkUnique uq + det_uniq = mkUnique 'Q' new_w + modify (\DetUniqFM{mapping, supply} -> + -- Update supply and mapping + DetUniqFM + { mapping = addToUFM mapping uq det_uniq + , supply = supply + 1 + }) + return det_uniq + Just det_uniq -> + return det_uniq + +-- The most important function here, which does the actual renaming. +detRenameCLabel :: CLabel -> DetRnM CLabel +detRenameCLabel = mapInternalNonDetUniques renameDetUniq + +-- | We want to rename uniques in Ids, but ONLY internal ones. +detRenameId :: Id -> DetRnM Id +detRenameId i + | isExternalName (varName i) = return i + | otherwise = setIdUnique i <$> renameDetUniq (getUnique i) + +-- | Similar to `detRenameId`, but for `Name`. +detRenameName :: Name -> DetRnM Name +detRenameName n + | isExternalName n = return n + | otherwise = setNameUnique n <$> renameDetUniq (getUnique n) + +detRenameCmmGroup :: DetUniqFM -> DCmmGroup -> (DetUniqFM, CmmGroup) +detRenameCmmGroup dufm group = swap (runState (mapM detRenameCmmDecl group) dufm) + where + detRenameCmmDecl :: DCmmDecl -> DetRnM CmmDecl + detRenameCmmDecl (CmmProc h lbl regs g) + = do + h' <- detRenameCmmTop h + lbl' <- detRenameCLabel lbl + regs' <- mapM detRenameGlobalRegUse regs + g' <- detRenameCmmGraph g + return (CmmProc h' lbl' regs' g') + detRenameCmmDecl (CmmData sec d) + = CmmData <$> detRenameSection sec <*> detRenameCmmStatics d + + detRenameCmmTop :: DCmmTopInfo -> DetRnM CmmTopInfo + detRenameCmmTop (TopInfo (DWrap i) b) + = TopInfo . mapFromList <$> mapM (detRenamePair detRenameLabel detRenameCmmInfoTable) i <*> pure b + + detRenameCmmGraph :: DCmmGraph -> DetRnM CmmGraph + detRenameCmmGraph (CmmGraph entry bs) + = CmmGraph <$> detRenameLabel entry <*> detRenameGraph bs + + detRenameGraph = \case + GNil -> pure GNil + GUnit block -> GUnit <$> detRenameBlock block + GMany m1 b m2 -> GMany <$> detRenameMaybeBlock m1 <*> detRenameBody b <*> detRenameMaybeBlock m2 + + detRenameBody (DWrap b) + = mapFromList <$> mapM (detRenamePair detRenameLabel detRenameBlock) b + + detRenameCmmStatics :: CmmStatics -> DetRnM CmmStatics + detRenameCmmStatics + (CmmStatics clbl info ccs lits1 lits2) + = CmmStatics <$> detRenameCLabel clbl <*> detRenameCmmInfoTable info <*> pure ccs <*> mapM detRenameCmmLit lits1 <*> mapM detRenameCmmLit lits2 + detRenameCmmStatics + (CmmStaticsRaw lbl sts) + = CmmStaticsRaw <$> detRenameCLabel lbl <*> mapM detRenameCmmStatic sts + + detRenameCmmInfoTable :: CmmInfoTable -> DetRnM CmmInfoTable + detRenameCmmInfoTable + CmmInfoTable{cit_lbl, cit_rep, cit_prof, cit_srt, cit_clo} + = CmmInfoTable <$> detRenameCLabel cit_lbl <*> pure cit_rep <*> pure cit_prof <*> detRenameMaybe detRenameCLabel cit_srt <*> + (case cit_clo of + Nothing -> pure Nothing + Just (an_id, ccs) -> Just . (,ccs) <$> detRenameId an_id) + + detRenameCmmStatic :: CmmStatic -> DetRnM CmmStatic + detRenameCmmStatic = \case + CmmStaticLit l -> CmmStaticLit <$> detRenameCmmLit l + CmmUninitialised x -> pure $ CmmUninitialised x + CmmString x -> pure $ CmmString x + CmmFileEmbed f i -> pure $ CmmFileEmbed f i + + detRenameCmmLit :: CmmLit -> DetRnM CmmLit + detRenameCmmLit = \case + CmmInt i w -> pure $ CmmInt i w + CmmFloat r w -> pure $ CmmFloat r w + CmmVec lits -> CmmVec <$> mapM detRenameCmmLit lits + CmmLabel lbl -> CmmLabel <$> detRenameCLabel lbl + CmmLabelOff lbl i -> CmmLabelOff <$> detRenameCLabel lbl <*> pure i + CmmLabelDiffOff lbl1 lbl2 i w -> + CmmLabelDiffOff <$> detRenameCLabel lbl1 <*> detRenameCLabel lbl2 <*> pure i <*> pure w + CmmBlock bid -> CmmBlock <$> detRenameLabel bid + CmmHighStackMark -> pure CmmHighStackMark + + detRenameMaybeBlock :: MaybeO n (Block CmmNode a b) -> DetRnM (MaybeO n (Block CmmNode a b)) + detRenameMaybeBlock (JustO x) = JustO <$> detRenameBlock x + detRenameMaybeBlock NothingO = pure NothingO + + detRenameBlock :: Block CmmNode n m -> DetRnM (Block CmmNode n m) + detRenameBlock = \case + BlockCO n bn -> BlockCO <$> detRenameCmmNode n <*> detRenameBlock bn + BlockCC n1 bn n2 -> BlockCC <$> detRenameCmmNode n1 <*> detRenameBlock bn <*> detRenameCmmNode n2 + BlockOC bn n -> BlockOC <$> detRenameBlock bn <*> detRenameCmmNode n + BNil -> pure BNil + BMiddle n -> BMiddle <$> detRenameCmmNode n + BCat b1 b2 -> BCat <$> detRenameBlock b1 <*> detRenameBlock b2 + BSnoc bn n -> BSnoc <$> detRenameBlock bn <*> detRenameCmmNode n + BCons n bn -> BCons <$> detRenameCmmNode n <*> detRenameBlock bn + + detRenameCmmNode :: CmmNode n m -> DetRnM (CmmNode n m) + detRenameCmmNode = \case + CmmEntry l t -> CmmEntry <$> detRenameLabel l <*> detRenameCmmTick t + CmmComment fs -> pure $ CmmComment fs + CmmTick tickish -> pure $ CmmTick tickish + CmmUnwind xs -> CmmUnwind <$> mapM (detRenamePair detRenameGlobalReg (detRenameMaybe detRenameCmmExpr)) xs + CmmAssign reg e -> CmmAssign <$> detRenameCmmReg reg <*> detRenameCmmExpr e + CmmStore e1 e2 align -> CmmStore <$> detRenameCmmExpr e1 <*> detRenameCmmExpr e2 <*> pure align + CmmUnsafeForeignCall ftgt cmmformal cmmactual -> + CmmUnsafeForeignCall <$> detRenameForeignTarget ftgt <*> mapM detRenameLocalReg cmmformal <*> mapM detRenameCmmExpr cmmactual + CmmBranch l -> CmmBranch <$> detRenameLabel l + CmmCondBranch pred t f likely -> + CmmCondBranch <$> detRenameCmmExpr pred <*> detRenameLabel t <*> detRenameLabel f <*> pure likely + CmmSwitch e sts -> CmmSwitch <$> detRenameCmmExpr e <*> mapSwitchTargetsA detRenameLabel sts + CmmCall tgt cont regs args retargs retoff -> + CmmCall <$> detRenameCmmExpr tgt <*> detRenameMaybe detRenameLabel cont <*> mapM detRenameGlobalRegUse regs + <*> pure args <*> pure retargs <*> pure retoff + CmmForeignCall tgt res args succ retargs retoff intrbl -> + CmmForeignCall <$> detRenameForeignTarget tgt <*> mapM detRenameLocalReg res <*> mapM detRenameCmmExpr args + <*> detRenameLabel succ <*> pure retargs <*> pure retoff <*> pure intrbl + + detRenameCmmExpr :: CmmExpr -> DetRnM CmmExpr + detRenameCmmExpr = \case + CmmLit l -> CmmLit <$> detRenameCmmLit l + CmmLoad e t a -> CmmLoad <$> detRenameCmmExpr e <*> pure t <*> pure a + CmmReg r -> CmmReg <$> detRenameCmmReg r + CmmMachOp mop es -> CmmMachOp mop <$> mapM detRenameCmmExpr es + CmmStackSlot a i -> CmmStackSlot <$> detRenameArea a <*> pure i + CmmRegOff r i -> CmmRegOff <$> detRenameCmmReg r <*> pure i + + detRenameForeignTarget :: ForeignTarget -> DetRnM ForeignTarget + detRenameForeignTarget = \case + ForeignTarget e fc -> ForeignTarget <$> detRenameCmmExpr e <*> pure fc + PrimTarget cmop -> pure $ PrimTarget cmop + + detRenameArea :: Area -> DetRnM Area + detRenameArea Old = pure Old + detRenameArea (Young l) = Young <$> detRenameLabel l + + detRenameLabel :: Label -> DetRnM Label + detRenameLabel lbl + = mkHooplLabel . getKey <$> renameDetUniq (getUnique lbl) + + detRenameSection :: Section -> DetRnM Section + detRenameSection (Section ty lbl) + = Section ty <$> detRenameCLabel lbl + + detRenameCmmReg :: CmmReg -> DetRnM CmmReg + detRenameCmmReg = \case + CmmLocal l -> CmmLocal <$> detRenameLocalReg l + CmmGlobal x -> pure $ CmmGlobal x + + detRenameLocalReg :: LocalReg -> DetRnM LocalReg + detRenameLocalReg (LocalReg uq t) + = LocalReg <$> renameDetUniq uq <*> pure t + + -- Global registers don't need to be renamed. + detRenameGlobalReg :: GlobalReg -> DetRnM GlobalReg + detRenameGlobalReg = pure + detRenameGlobalRegUse :: GlobalRegUse -> DetRnM GlobalRegUse + detRenameGlobalRegUse = pure + + -- todo: We may have to change this to get deterministic objects with ticks. + detRenameCmmTick :: CmmTickScope -> DetRnM CmmTickScope + detRenameCmmTick = pure + + detRenameMaybe _ Nothing = pure Nothing + detRenameMaybe f (Just x) = Just <$> f x + + detRenamePair f g (a, b) = (,) <$> f a <*> g b + +detRenameIPEMap :: DetUniqFM -> InfoTableProvMap -> (DetUniqFM, InfoTableProvMap) +detRenameIPEMap dufm InfoTableProvMap{ provDC, provClosure, provInfoTables } = + (dufm2, InfoTableProvMap { provDC, provClosure = cm, provInfoTables }) + where + (cm, dufm2) = runState (detRenameClosureMap provClosure) dufm + + detRenameClosureMap :: ClosureMap -> DetRnM ClosureMap + detRenameClosureMap m = + -- `eltsUDFM` preserves the deterministic order, but it doesn't matter + -- since we will rename all uniques deterministically, thus the + -- reconstructed map will necessarily be deterministic too. + listToUDFM <$> mapM (\(n,r) -> do + n' <- detRenameName n + return (n', (n', r)) + ) (eltsUDFM m) diff --git a/GHC/Cmm/Utils.hs b/GHC/Cmm/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Utils.hs @@ -0,0 +1,597 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- +-- Cmm utilities. +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.Cmm.Utils( + -- CmmType + primRepCmmType, slotCmmType, + typeCmmType, typeForeignHint, primRepForeignHint, + + -- CmmLit + zeroCLit, mkIntCLit, + mkWordCLit, packHalfWordsCLit, + mkByteStringCLit, mkFileEmbedLit, + mkDataLits, mkRODataLits, + mkStgWordCLit, + + -- CmmExpr + mkIntExpr, zeroExpr, + mkLblExpr, + cmmRegOff, cmmOffset, cmmLabelOff, cmmOffsetLit, cmmOffsetExpr, + cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB, + cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW, + cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW, + cmmLoadBWord, cmmLoadGCWord, + cmmNegate, + cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, + cmmSLtWord, + cmmNeWord, cmmEqWord, + cmmOrWord, cmmAndWord, + cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord, + cmmToWord, + + cmmMkAssign, + + baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr, + currentTSOExpr, currentNurseryExpr, cccsExpr, + + -- Tagging + cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged, + cmmConstrTag1, mAX_PTR_TAG, tAG_MASK, + + -- Overlap and usage + regsOverlap, globalRegsOverlap, regUsedIn, globalRegUsedIn, + + -- Liveness and bitmaps + mkLiveness, + + -- * Operations that probably don't belong here + modifyGraph, + + ofBlockMap, toBlockMap, + ofBlockList, toBlockList, + toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough, + foldlGraphBlocks, mapGraphNodes, mapGraphNodes1, + + -- * Ticks + blockTicks + ) where + +import GHC.Prelude + +import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) ) +import GHC.Types.RepType ( NvUnaryType, SlotTy (..), typePrimRepU ) + +import GHC.Platform +import GHC.Runtime.Heap.Layout +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.Unique +import GHC.Platform.Regs + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Foldable (toList) +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Block + +--------------------------------------------------- +-- +-- CmmTypes +-- +--------------------------------------------------- + +primRepCmmType :: Platform -> PrimRep -> CmmType +primRepCmmType platform = \case + BoxedRep _ -> gcWord platform + IntRep -> bWord platform + WordRep -> bWord platform + Int8Rep -> b8 + Word8Rep -> b8 + Int16Rep -> b16 + Word16Rep -> b16 + Int32Rep -> b32 + Word32Rep -> b32 + Int64Rep -> b64 + Word64Rep -> b64 + AddrRep -> bWord platform + FloatRep -> f32 + DoubleRep -> f64 + VecRep len rep -> vec len (primElemRepCmmType rep) + +slotCmmType :: Platform -> SlotTy -> CmmType +slotCmmType platform = \case + PtrUnliftedSlot -> gcWord platform + PtrLiftedSlot -> gcWord platform + WordSlot -> bWord platform + Word64Slot -> b64 + FloatSlot -> f32 + DoubleSlot -> f64 + VecSlot l e -> vec l (primElemRepCmmType e) + +primElemRepCmmType :: PrimElemRep -> CmmType +primElemRepCmmType Int8ElemRep = b8 +primElemRepCmmType Int16ElemRep = b16 +primElemRepCmmType Int32ElemRep = b32 +primElemRepCmmType Int64ElemRep = b64 +primElemRepCmmType Word8ElemRep = b8 +primElemRepCmmType Word16ElemRep = b16 +primElemRepCmmType Word32ElemRep = b32 +primElemRepCmmType Word64ElemRep = b64 +primElemRepCmmType FloatElemRep = f32 +primElemRepCmmType DoubleElemRep = f64 + +typeCmmType :: Platform -> NvUnaryType -> CmmType +typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty) + +primRepForeignHint :: PrimRep -> ForeignHint +primRepForeignHint (BoxedRep _) = AddrHint +primRepForeignHint IntRep = SignedHint +primRepForeignHint Int8Rep = SignedHint +primRepForeignHint Int16Rep = SignedHint +primRepForeignHint Int32Rep = SignedHint +primRepForeignHint Int64Rep = SignedHint +primRepForeignHint WordRep = NoHint +primRepForeignHint Word8Rep = NoHint +primRepForeignHint Word16Rep = NoHint +primRepForeignHint Word32Rep = NoHint +primRepForeignHint Word64Rep = NoHint +primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg +primRepForeignHint FloatRep = NoHint +primRepForeignHint DoubleRep = NoHint +primRepForeignHint (VecRep {}) = NoHint + +typeForeignHint :: NvUnaryType -> ForeignHint +typeForeignHint = primRepForeignHint . typePrimRepU + +--------------------------------------------------- +-- +-- CmmLit +-- +--------------------------------------------------- + +-- XXX: should really be Integer, since Int doesn't necessarily cover +-- the full range of target Ints. +mkIntCLit :: Platform -> Int -> CmmLit +mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform) + +mkIntExpr :: Platform -> Int -> CmmExpr +mkIntExpr platform i = CmmLit $! mkIntCLit platform i + +zeroCLit :: Platform -> CmmLit +zeroCLit platform = CmmInt 0 (wordWidth platform) + +zeroExpr :: Platform -> CmmExpr +zeroExpr platform = CmmLit (zeroCLit platform) + +mkWordCLit :: Platform -> Integer -> CmmLit +mkWordCLit platform wd = CmmInt wd (wordWidth platform) + +-- | We make a top-level decl for the string, and return a label pointing to it +mkByteStringCLit + :: CLabel -> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt) +mkByteStringCLit lbl bytes + = (CmmLabel lbl, CmmData (Section sec lbl) $ CmmStaticsRaw lbl [CmmString bytes]) + where + -- This can not happen for String literals (as there \NUL is replaced by + -- C0 80). However, it can happen with Addr# literals. + sec = if 0 `BS.elem` bytes then ReadOnlyData else CString + +-- | We make a top-level decl for the embedded binary file, and return a label pointing to it +mkFileEmbedLit + :: CLabel -> FilePath -> Int -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt) +mkFileEmbedLit lbl path len + = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path len])) + + +-- | Build a data-segment data block +mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt +mkDataLits section lbl lits + = CmmData section (CmmStaticsRaw lbl $ map CmmStaticLit lits) + +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt +-- Build a read-only data block +mkRODataLits lbl lits + = mkDataLits section lbl lits + where + section | any needsRelocation lits = Section RelocatableReadOnlyData lbl + | otherwise = Section ReadOnlyData lbl + needsRelocation (CmmLabel _) = True + needsRelocation (CmmLabelOff _ _) = True + needsRelocation _ = False + +mkStgWordCLit :: Platform -> StgWord -> CmmLit +mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform) + +packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit +-- Make a single word literal in which the lower_half_word is +-- at the lower address, and the upper_half_word is at the +-- higher address +-- ToDo: consider using half-word lits instead +-- but be careful: that's vulnerable when reversed +packHalfWordsCLit platform lower_half_word upper_half_word + = case platformByteOrder platform of + BigEndian -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u) + LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform)) + where l = fromStgHalfWord lower_half_word + u = fromStgHalfWord upper_half_word + +--------------------------------------------------- +-- +-- CmmExpr +-- +--------------------------------------------------- + +mkLblExpr :: CLabel -> CmmExpr +mkLblExpr lbl = CmmLit (CmmLabel lbl) + +cmmOffsetExpr :: Platform -> CmmExpr -> CmmExpr -> CmmExpr +-- assumes base and offset have the same CmmType +cmmOffsetExpr platform e (CmmLit (CmmInt n _)) = cmmOffset platform e (fromInteger n) +cmmOffsetExpr platform e byte_off = CmmMachOp (MO_Add (cmmExprWidth platform e)) [e, byte_off] + +cmmOffset :: Platform -> CmmExpr -> Int -> CmmExpr +cmmOffset _platform e 0 = e +cmmOffset platform e byte_off = case e of + CmmReg reg -> cmmRegOff reg byte_off + CmmRegOff reg m -> cmmRegOff reg (m+byte_off) + CmmLit lit -> CmmLit (cmmOffsetLit lit byte_off) + CmmStackSlot area off -> CmmStackSlot area (off - byte_off) + -- note stack area offsets increase towards lower addresses + CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)] + -> let !lit_off = (byte_off1 + toInteger byte_off) + in CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt lit_off rep)] + _ -> let !width = cmmExprWidth platform e + in + CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)] + +-- Smart constructor for CmmRegOff. Same caveats as cmmOffset above. +cmmRegOff :: CmmReg -> Int -> CmmExpr +cmmRegOff reg 0 = CmmReg reg +cmmRegOff reg byte_off = CmmRegOff reg byte_off + +cmmOffsetLit :: CmmLit -> Int -> CmmLit +cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off +cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off) +cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off + = CmmLabelDiffOff l1 l2 (m+byte_off) w +cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep +cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off) + +cmmLabelOff :: CLabel -> Int -> CmmLit +-- Smart constructor for CmmLabelOff +cmmLabelOff lbl 0 = CmmLabel lbl +cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off + +-- | Useful for creating an index into an array, with a statically known offset. +-- The type is the element type; used for making the multiplier +cmmIndex :: Platform + -> Width -- Width w + -> CmmExpr -- Address of vector of items of width w + -> Int -- Which element of the vector (0 based) + -> CmmExpr -- Address of i'th element +cmmIndex platform width base idx = cmmOffset platform base (idx * widthInBytes width) + +-- | Useful for creating an index into an array, with an unknown offset. +cmmIndexExpr :: Platform + -> Width -- Width w + -> CmmExpr -- Address of vector of items of width w + -> CmmExpr -- Which element of the vector (0 based) + -> CmmExpr -- Address of i'th element +cmmIndexExpr platform width base (CmmLit (CmmInt n _)) = cmmIndex platform width base (fromInteger n) +cmmIndexExpr platform width base idx = + cmmOffsetExpr platform base byte_off + where + idx_w = cmmExprWidth platform idx + byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)] + +cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr +cmmLoadIndex platform ty expr ix = + CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty NaturallyAligned -- TODO: Audit uses + +-- | Load a naturally-aligned non-pointer word. +cmmLoadBWord :: Platform -> CmmExpr -> CmmExpr +cmmLoadBWord platform ptr = CmmLoad ptr (bWord platform) NaturallyAligned + +-- | Load a naturally-aligned GC pointer. +cmmLoadGCWord :: Platform -> CmmExpr -> CmmExpr +cmmLoadGCWord platform ptr = CmmLoad ptr (gcWord platform) NaturallyAligned + +-- The "B" variants take byte offsets +cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr +cmmRegOffB = cmmRegOff + +cmmOffsetB :: Platform -> CmmExpr -> ByteOff -> CmmExpr +cmmOffsetB = cmmOffset + +cmmOffsetExprB :: Platform -> CmmExpr -> CmmExpr -> CmmExpr +cmmOffsetExprB = cmmOffsetExpr + +cmmLabelOffB :: CLabel -> ByteOff -> CmmLit +cmmLabelOffB = cmmLabelOff + +cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit +cmmOffsetLitB = cmmOffsetLit + +----------------------- +-- The "W" variants take word offsets + +cmmOffsetExprW :: Platform -> CmmExpr -> CmmExpr -> CmmExpr +-- The second arg is a *word* offset; need to change it to bytes +cmmOffsetExprW platform e (CmmLit (CmmInt n _)) = cmmOffsetW platform e (fromInteger n) +cmmOffsetExprW platform e wd_off = cmmIndexExpr platform (wordWidth platform) e wd_off + +cmmOffsetW :: Platform -> CmmExpr -> WordOff -> CmmExpr +cmmOffsetW platform e n = cmmOffsetB platform e (wordsToBytes platform n) + +cmmRegOffW :: Platform -> CmmReg -> WordOff -> CmmExpr +cmmRegOffW platform reg wd_off = cmmRegOffB reg (wordsToBytes platform wd_off) + +cmmOffsetLitW :: Platform -> CmmLit -> WordOff -> CmmLit +cmmOffsetLitW platform lit wd_off = cmmOffsetLitB lit (wordsToBytes platform wd_off) + +cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit +cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off) + +cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr +cmmLoadIndexW platform base off ty = + CmmLoad (cmmOffsetW platform base off) ty NaturallyAligned -- TODO: Audit ses + +----------------------- +cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, + cmmSLtWord, + cmmNeWord, cmmEqWord, + cmmOrWord, cmmAndWord, + cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord + :: Platform -> CmmExpr -> CmmExpr -> CmmExpr +cmmOrWord platform e1 e2 = CmmMachOp (mo_wordOr platform) [e1, e2] +cmmAndWord platform e1 e2 = CmmMachOp (mo_wordAnd platform) [e1, e2] +cmmNeWord platform e1 e2 = CmmMachOp (mo_wordNe platform) [e1, e2] +cmmEqWord platform e1 e2 = CmmMachOp (mo_wordEq platform) [e1, e2] +cmmULtWord platform e1 e2 = CmmMachOp (mo_wordULt platform) [e1, e2] +cmmUGeWord platform e1 e2 = CmmMachOp (mo_wordUGe platform) [e1, e2] +cmmUGtWord platform e1 e2 = CmmMachOp (mo_wordUGt platform) [e1, e2] +cmmSLtWord platform e1 e2 = CmmMachOp (mo_wordSLt platform) [e1, e2] +cmmUShrWord platform e1 e2 = CmmMachOp (mo_wordUShr platform) [e1, e2] +cmmAddWord platform e1 e2 = CmmMachOp (mo_wordAdd platform) [e1, e2] +cmmSubWord platform e1 e2 = CmmMachOp (mo_wordSub platform) [e1, e2] +cmmMulWord platform e1 e2 = CmmMachOp (mo_wordMul platform) [e1, e2] +cmmQuotWord platform e1 e2 = CmmMachOp (mo_wordUQuot platform) [e1, e2] + +cmmNegate :: Platform -> CmmExpr -> CmmExpr +cmmNegate platform = \case + (CmmLit (CmmInt n rep)) + -> CmmLit (CmmInt (-n) rep) + e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e] + +cmmToWord :: Platform -> CmmExpr -> CmmExpr +cmmToWord platform e + | w == word = e + | otherwise = CmmMachOp (MO_UU_Conv w word) [e] + where + w = cmmExprWidth platform e + word = wordWidth platform + +cmmMkAssign :: Platform -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr) +cmmMkAssign platform expr uq = + let !ty = cmmExprType platform expr + reg = (CmmLocal (LocalReg uq ty)) + in (CmmAssign reg expr, CmmReg reg) + + +--------------------------------------------------- +-- +-- Tagging +-- +--------------------------------------------------- + +tAG_MASK :: Platform -> Int +tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1 + +mAX_PTR_TAG :: Platform -> Int +mAX_PTR_TAG = tAG_MASK + +-- Tag bits mask +cmmTagMask, cmmPointerMask :: Platform -> CmmExpr +cmmTagMask platform = mkIntExpr platform (tAG_MASK platform) +cmmPointerMask platform = mkIntExpr platform (complement (tAG_MASK platform)) + +-- Used to untag a possibly tagged pointer +-- A static label need not be untagged +cmmUntag, cmmIsTagged, cmmIsNotTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr +cmmUntag _ e@(CmmLit (CmmLabel _)) = e +-- Default case +cmmUntag platform e = cmmAndWord platform e (cmmPointerMask platform) + +-- Test if a closure pointer is untagged/tagged. +cmmIsTagged platform e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform) +cmmIsNotTagged platform e = cmmEqWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform) + +-- Get constructor tag, but one based. +cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform) + + +----------------------------------------------------------------------------- +-- Overlap and usage + +-- | Returns True if the two STG registers overlap on the specified +-- platform, in the sense that writing to one will clobber the +-- other. This includes the case that the two registers are the same +-- STG register. See Note [Overlapping global registers] for details. +regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool +regsOverlap platform (CmmGlobal (GlobalRegUse g1 _)) (CmmGlobal (GlobalRegUse g2 _)) + = globalRegsOverlap platform g1 g2 +regsOverlap _ reg reg' = reg == reg' + +globalRegsOverlap :: Platform -> GlobalReg -> GlobalReg -> Bool +globalRegsOverlap platform g1 g2 + | Just real <- globalRegMaybe platform g1 + , Just real' <- globalRegMaybe platform g2 + , real == real' + = True + | otherwise + = g1 == g2 + +-- | Returns True if the STG register is used by the expression, in +-- the sense that a store to the register might affect the value of +-- the expression. +-- +-- We must check for overlapping registers and not just equal +-- registers here, otherwise CmmSink may incorrectly reorder +-- assignments that conflict due to overlap. See #10521 and Note +-- [Overlapping global registers]. +regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool +regUsedIn platform = regUsedIn_ where + _ `regUsedIn_` CmmLit _ = False + reg `regUsedIn_` CmmLoad e _ _ = reg `regUsedIn_` e + reg `regUsedIn_` CmmReg reg' = regsOverlap platform reg reg' + reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg' + reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es + _ `regUsedIn_` CmmStackSlot _ _ = False + +globalRegUsedIn :: Platform -> GlobalReg -> CmmExpr -> Bool +globalRegUsedIn platform = globalRegUsedIn_ where + _ `globalRegUsedIn_` CmmLit _ + = False + reg `globalRegUsedIn_` CmmLoad e _ _ + = reg `globalRegUsedIn_` e + reg `globalRegUsedIn_` CmmReg reg' + | CmmGlobal (GlobalRegUse reg' _) <- reg' + = globalRegsOverlap platform reg reg' + | otherwise + = False + reg `globalRegUsedIn_` CmmRegOff reg' _ + | CmmGlobal (GlobalRegUse reg' _) <- reg' + = globalRegsOverlap platform reg reg' + | otherwise + = False + reg `globalRegUsedIn_` CmmMachOp _ es + = any (reg `globalRegUsedIn_`) es + _ `globalRegUsedIn_` CmmStackSlot _ _ + = False + +-------------------------------------------- +-- +-- mkLiveness +-- +--------------------------------------------- + +mkLiveness :: Platform -> [LocalReg] -> Liveness +mkLiveness _ [] = [] +mkLiveness platform (reg:regs) + = bits ++ mkLiveness platform regs + where + word_size = platformWordSizeInBytes platform + sizeW = (widthInBytes (typeWidth (localRegType reg)) + word_size - 1) + `quot` word_size + -- number of words, rounded up + bits = replicate sizeW is_non_ptr -- True <=> Non Ptr + + is_non_ptr = not $ isGcPtrType (localRegType reg) + + +-- ============================================== - +-- ============================================== - +-- ============================================== - + +--------------------------------------------------- +-- +-- Manipulating CmmGraphs +-- +--------------------------------------------------- + +modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' +modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} + +ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph +ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} + +-- | like 'toBlockList', but the entry block always comes first +toBlockListEntryFirst :: CmmGraph -> [CmmBlock] +toBlockListEntryFirst g = do + entry_block <- toList $ mapLookup entry_id m + entry_block : filter ((/= entry_id) . entryLabel) (mapElems m) + where + m = toBlockMap g + entry_id = g_entry g + +-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks +-- so that the false case of a conditional jumps to the next block in the output +-- list of blocks. This matches the way OldCmm blocks were output since in +-- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches +-- have both true and false successors. Block ordering can make a big difference +-- in performance in the LLVM backend. Note that we rely crucially on the order +-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode +-- defined in "GHC.Cmm.Node". -GBM +toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock] +toBlockListEntryFirstFalseFallthrough g = dfs setEmpty $ toList $ mapLookup entry_id m + where + m = toBlockMap g + entry_id = g_entry g + + dfs :: LabelSet -> [CmmBlock] -> [CmmBlock] + dfs _ [] = [] + dfs visited (block:bs) + | id `setMember` visited = dfs visited bs + | otherwise = block : dfs (setInsert id visited) bs' + where id = entryLabel block + bs' = foldr add_id bs (successors block) + add_id id bs = case mapLookup id m of + Just b -> b : bs + Nothing -> bs + +ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph +ofBlockList entry blocks = CmmGraph { g_entry = entry + , g_graph = GMany NothingO body NothingO } + where body = foldr addBlock emptyBody blocks + +mapGraphNodes :: ( CmmNode C O -> CmmNode C O + , CmmNode O O -> CmmNode O O + , CmmNode O C -> CmmNode O C) + -> CmmGraph -> CmmGraph +mapGraphNodes funs@(mf,_,_) g = + ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $ + mapMap (mapBlock3' funs) $ toBlockMap g + +mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph +mapGraphNodes1 f = modifyGraph (mapGraph f) + + +foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a +foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g + +------------------------------------------------- +-- Tick utilities + +-- | Extract all tick annotations from the given block +blockTicks :: Block CmmNode C C -> [CmmTickish] +blockTicks b = reverse $ foldBlockNodesF goStmt b [] + where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish] + goStmt (CmmTick t) ts = t:ts + goStmt _other ts = ts + + +-- ----------------------------------------------------------------------------- +-- Access to common global registers + +baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr, + spLimExpr, hpLimExpr, cccsExpr :: Platform -> CmmExpr +baseExpr p = CmmReg $ baseReg p +spExpr p = CmmReg $ spReg p +spLimExpr p = CmmReg $ spLimReg p +hpExpr p = CmmReg $ hpReg p +hpLimExpr p = CmmReg $ hpLimReg p +currentTSOExpr p = CmmReg $ currentTSOReg p +currentNurseryExpr p = CmmReg $ currentNurseryReg p +cccsExpr p = CmmReg $ cccsReg p diff --git a/GHC/CmmToAsm.hs b/GHC/CmmToAsm.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm.hs @@ -0,0 +1,940 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1993-2004 +-- +-- +-- ----------------------------------------------------------------------------- + +-- | Note [Native code generator] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The native-code generator has machine-independent and +-- machine-dependent modules. +-- +-- This module ("GHC.CmmToAsm") is the top-level machine-independent +-- module. Before entering machine-dependent land, we do some +-- machine-independent optimisations (defined below) on the +-- 'CmmStmts's. (Which ideally would be folded into CmmOpt ...) +-- +-- We convert to the machine-specific 'Instr' datatype with +-- 'cmmCodeGen', assuming an infinite supply of registers. We then use +-- a (mostly) machine-independent register allocator to rejoin +-- reality. Obviously, 'regAlloc' has machine-specific helper +-- functions (see the used register allocator for details). +-- +-- Finally, we order the basic blocks of the function so as to minimise +-- the number of jumps between blocks, by utilising fallthrough wherever +-- possible. +-- +-- The machine-dependent bits are generally contained under +-- GHC/CmmToAsm//* and generally breaks down as follows: +-- +-- * "Regs": Everything about the target platform's machine +-- registers (and immediate operands, and addresses, which tend to +-- intermingle/interact with registers). +-- +-- * "Instr": Includes the 'Instr' datatype plus a miscellany of other things +-- (e.g., 'targetDoubleSize', 'smStablePtrTable', ...) +-- +-- * "CodeGen": is where 'Cmm' stuff turns into +-- machine instructions. +-- +-- * "Ppr": 'pprInstr' turns an 'Instr' into text (well, really +-- a 'SDoc'). +-- +-- The register allocators lives under GHC.CmmToAsm.Reg.*, there is both a Linear and a Graph +-- based register allocator. Both of which have their own notes describing them. They +-- are mostly platform independent but there are some platform specific files +-- encoding architecture details under Reg// +-- +-- -} +-- +module GHC.CmmToAsm + ( nativeCodeGen + + -- * Test-only exports: see #12744 + -- used by testGraphNoSpills, which needs to access + -- the register allocator intermediate data structures + -- cmmNativeGen emits + , cmmNativeGen + , NcgImpl(..) + ) +where + +import GHC.Prelude hiding (head) + +import qualified GHC.CmmToAsm.X86 as X86 +import qualified GHC.CmmToAsm.PPC as PPC +import qualified GHC.CmmToAsm.AArch64 as AArch64 +import qualified GHC.CmmToAsm.Wasm as Wasm32 +import qualified GHC.CmmToAsm.RV64 as RV64 +import qualified GHC.CmmToAsm.LA64 as LA64 + +import GHC.CmmToAsm.Reg.Liveness +import qualified GHC.CmmToAsm.Reg.Linear as Linear + +import qualified GHC.Data.Graph.Color as Color +import qualified GHC.CmmToAsm.Reg.Graph as Color +import qualified GHC.CmmToAsm.Reg.Graph.Stats as Color +import qualified GHC.CmmToAsm.Reg.Graph.TrivColorable as Color + +import GHC.Utils.Asm +import GHC.CmmToAsm.Reg.Target +import GHC.Platform +import GHC.CmmToAsm.BlockLayout as BlockLayout +import GHC.Settings.Config +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.PIC +import GHC.Platform.Reg +import GHC.Platform.Reg.Class (RegClass) +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.Dwarf +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types +import GHC.Cmm.DebugBlock + +import GHC.Cmm.BlockId +import GHC.StgToCmm.CgUtils ( fixStgRegisters ) +import GHC.Cmm +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.GenericOpt +import GHC.Cmm.CLabel + +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSM +import GHC.Driver.DynFlags +import GHC.Driver.Ppr +import GHC.Utils.Misc +import GHC.Utils.Logger + +import GHC.Utils.BufHandle +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Error +import GHC.Utils.Exception (evaluate) +import GHC.Utils.Constants (debugIsOn) + +import GHC.Data.FastString +import GHC.Types.Unique.Set +import GHC.Unit +import GHC.StgToCmm.CgUtils (CgStream) +import GHC.Data.Stream (liftIO) +import qualified GHC.Data.Stream as Stream +import GHC.Settings + +import Data.List (sortBy) +import Data.List.NonEmpty (groupAllWith, head) +import Data.Maybe +import Data.Ord ( comparing ) +import Control.Monad +import System.IO +import System.Directory ( getCurrentDirectory ) + +-------------------- +nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle + -> CgStream RawCmmGroup a + -> UniqDSMT IO a +nativeCodeGen logger ts config modLoc h cmms + = let platform = ncgPlatform config + nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr) + => NcgImpl statics instr jumpDest -> UniqDSMT IO a + nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h cmms + in case platformArch platform of + ArchX86 -> nCG' (X86.ncgX86 config) + ArchX86_64 -> nCG' (X86.ncgX86_64 config) + ArchPPC -> nCG' (PPC.ncgPPC config) + ArchPPC_64 _ -> nCG' (PPC.ncgPPC config) + ArchS390X -> panic "nativeCodeGen: No NCG for S390X" + ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" + ArchAArch64 -> nCG' (AArch64.ncgAArch64 config) + ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha" + ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" + ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel" + ArchRISCV64 -> nCG' (RV64.ncgRV64 config) + ArchLoongArch64 -> nCG' (LA64.ncgLA64 config) + ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" + ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" + ArchWasm32 -> Wasm32.ncgWasm config logger platform ts modLoc h cmms + +-- | Data accumulated during code generation. Mostly about statistics, +-- but also collects debug data for DWARF generation. +data NativeGenAcc statics instr + = NGS { ngs_imports :: ![[CLabel]] + , ngs_natives :: ![[NatCmmDecl statics instr]] + -- ^ Native code generated, for statistics. This might + -- hold a lot of data, so it is important to clear this + -- field as early as possible if it isn't actually + -- required. + , ngs_colorStats :: ![[Color.RegAllocStats statics instr]] + , ngs_linearStats :: ![[Linear.RegAllocStats]] + , ngs_labels :: ![Label] + , ngs_debug :: ![DebugBlock] + , ngs_dwarfFiles :: !DwarfFiles + , ngs_unwinds :: !(LabelMap [UnwindPoint]) + -- ^ see Note [Unwinding information in the NCG] + -- and Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". + } + +{- +Note [Unwinding information in the NCG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unwind information is a type of metadata which allows a debugging tool +to reconstruct the values of machine registers at the time a procedure was +entered. For the most part, the production of unwind information is handled by +the Cmm stage, where it is represented by CmmUnwind nodes. + +Unfortunately, the Cmm stage doesn't know everything necessary to produce +accurate unwinding information. For instance, the x86-64 calling convention +requires that the stack pointer be aligned to 16 bytes, which in turn means that +GHC must sometimes add padding to $sp prior to performing a foreign call. When +this happens unwind information must be updated accordingly. +For this reason, we make the NCG backends responsible for producing +unwinding tables (with the extractUnwindPoints function in NcgImpl). + +We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds +field of NativeGenAcc. This is a label map which contains an entry for each +procedure, containing a list of unwinding points (e.g. a label and an associated +unwinding table). + +See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". +-} + +nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) + => Logger + -> NCGConfig + -> ModLocation + -> NcgImpl statics instr jumpDest + -> Handle + -> CgStream RawCmmGroup a + -> UniqDSMT IO a +nativeCodeGen' logger config modLoc ncgImpl h cmms + = do + -- BufHandle is a performance hack. We could hide it inside + -- Pretty if it weren't for the fact that we do lots of little + -- printDocs here (in order to do codegen in constant space). + bufh <- liftIO $ newBufHandle h + let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty + (ngs, a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh cmms ngs0 + _ <- finishNativeGen logger config modLoc bufh ngs + return a + +finishNativeGen :: Instruction instr + => Logger + -> NCGConfig + -> ModLocation + -> BufHandle + -> NativeGenAcc statics instr + -> UniqDSMT IO () +finishNativeGen logger config modLoc bufh ngs + = withTimingSilent logger (text "NCG") (`seq` ()) $ do + -- Write debug data and finish + if not (ncgDwarfEnabled config) + then return () + else withDUS $ \us -> do + compPath <- getCurrentDirectory + let (dwarf_h, us') = dwarfGen compPath config modLoc us (ngs_debug ngs) + (dwarf_s, _) = dwarfGen compPath config modLoc us (ngs_debug ngs) + emitNativeCode logger config bufh dwarf_h dwarf_s + return ((), us') + liftIO $ do + + -- dump global NCG stats for graph coloring allocator + let stats = concat (ngs_colorStats ngs) + platform = ncgPlatform config + unless (null stats) $ do + + -- build the global register conflict graph + let graphGlobal + = foldl' Color.union Color.initGraph + $ [ Color.raGraph stat + | stat@Color.RegAllocStatsStart{} <- stats] + + dump_stats (Color.pprStats stats graphGlobal) + + + putDumpFileMaybe logger + Opt_D_dump_asm_conflicts "Register conflict graph" + FormatText + $ Color.dotGraph + (targetRegDotColor platform) + (Color.trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + $ graphGlobal + + + -- dump global NCG stats for linear allocator + let linearStats = concat (ngs_linearStats ngs) + unless (null linearStats) $ + dump_stats (Linear.pprStats platform (concat (ngs_natives ngs)) linearStats) + + -- write out the imports + let ctx = ncgAsmContext config + bPutHDoc bufh ctx $ makeImportsDoc config (concat (ngs_imports ngs)) + bFlush bufh + + return () + where + dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify) + Opt_D_dump_asm_stats "NCG stats" + FormatText + +cmmNativeGenStream :: forall statics jumpDest instr a . (OutputableP Platform statics, Outputable jumpDest, Instruction instr) + => Logger + -> NCGConfig + -> ModLocation + -> NcgImpl statics instr jumpDest + -> BufHandle + -> CgStream RawCmmGroup a + -> NativeGenAcc statics instr + -> UniqDSMT IO (NativeGenAcc statics instr, a) + +cmmNativeGenStream logger config modLoc ncgImpl h cmm_stream ngs + = loop (Stream.runStream cmm_stream) ngs + where + ncglabel = text "NCG" + loop :: Stream.StreamS (UniqDSMT IO) RawCmmGroup a + -> NativeGenAcc statics instr + -> UniqDSMT IO (NativeGenAcc statics instr, a) + loop s ngs = + case s of + Stream.Done a -> + return (ngs { ngs_imports = reverse $ ngs_imports ngs + , ngs_natives = reverse $ ngs_natives ngs + , ngs_colorStats = reverse $ ngs_colorStats ngs + , ngs_linearStats = reverse $ ngs_linearStats ngs + }, + a) + Stream.Effect m -> m >>= \cmm_stream' -> loop cmm_stream' ngs + Stream.Yield cmms cmm_stream' -> do + ngs'' <- + withTimingSilent logger ncglabel (`seq` ()) $ do + -- Generate debug information + let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms + | otherwise = [] + dbgMap = debugToMap ndbgs + + -- Generate native code + ngs' <- withDUS $ cmmNativeGens logger config ncgImpl h + dbgMap cmms ngs 0 + + -- Link native code information into debug blocks + -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". + let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs + platform = ncgPlatform config + unless (null ldbgs) $ liftIO $ + putDumpFileMaybe logger Opt_D_dump_debug "Debug Infos" FormatText + (vcat $ map (pdoc platform) ldbgs) + + -- Accumulate debug information for emission in finishNativeGen. + let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] } + return ngs'' + + loop cmm_stream' ngs'' + + +-- | Do native code generation on all these cmms. +-- +cmmNativeGens :: forall statics instr jumpDest. + (OutputableP Platform statics, Outputable jumpDest, Instruction instr) + => Logger + -> NCGConfig + -> NcgImpl statics instr jumpDest + -> BufHandle + -> LabelMap DebugBlock + -> [RawCmmDecl] + -> NativeGenAcc statics instr + -> Int + -> DUniqSupply + -> IO (NativeGenAcc statics instr, DUniqSupply) + +cmmNativeGens logger config ncgImpl h dbgMap = go + where + go :: [RawCmmDecl] + -> NativeGenAcc statics instr -> Int -> DUniqSupply + -> IO (NativeGenAcc statics instr, DUniqSupply) + + go [] ngs !_ !us = + return (ngs, us) + + go (cmm : cmms) ngs count us = do + let fileIds = ngs_dwarfFiles ngs + (us', fileIds', native, imports, colorStats, linearStats, unwinds, mcfg) + <- {-# SCC "cmmNativeGen" #-} + cmmNativeGen logger ncgImpl us fileIds dbgMap + cmm count + + -- Generate .file directives for every new file that has been + -- used. Note that it is important that we generate these in + -- ascending order, as Clang's 3.6 assembler complains. + let newFileIds = sortBy (comparing snd) $ + nonDetEltsUFM $ fileIds' `minusUFM` fileIds + -- See Note [Unique Determinism and code generation] + pprDecl (f,n) = line $ text "\t.file " <> int n <+> + pprFilePathString (unpackFS f) + + -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad + emitNativeCode logger config h + (vcat $ + map pprDecl newFileIds ++ + map (pprNatCmmDeclH ncgImpl) native) + (vcat $ + map pprDecl newFileIds ++ + map (pprNatCmmDeclS ncgImpl) native) + + -- force evaluation all this stuff to avoid space leaks + let platform = ncgPlatform config + {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pprAsmLabel platform) imports) () + + let !labels' = if ncgDwarfEnabled config + then cmmDebugLabels is_valid_label isMetaInstr native else [] + is_valid_label + -- filter dead labels: asm-shortcutting may remove some blocks + -- (#22792) + | Just cfg <- mcfg = hasNode cfg + | otherwise = const True + + !natives' = if logHasDumpFlag logger Opt_D_dump_asm_stats + then native : ngs_natives ngs else [] + + mCon = maybe id (:) + ngs' = ngs{ ngs_imports = imports : ngs_imports ngs + , ngs_natives = natives' + , ngs_colorStats = colorStats `mCon` ngs_colorStats ngs + , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs + , ngs_labels = ngs_labels ngs ++ labels' + , ngs_dwarfFiles = fileIds' + , ngs_unwinds = ngs_unwinds ngs `mapUnion` unwinds + } + go cmms ngs' (count + 1) us' + + +-- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad +emitNativeCode :: Logger -> NCGConfig -> BufHandle -> HDoc -> SDoc -> IO () +emitNativeCode logger config h hdoc sdoc = do + let ctx = ncgAsmContext config + {-# SCC "pprNativeCode" #-} bPutHDoc h ctx hdoc + + -- dump native code + putDumpFileMaybe logger + Opt_D_dump_asm "Asm code" FormatASM + sdoc + +-- | Complete native code generation phase for a single top-level chunk of Cmm. +-- Dumping the output of each stage along the way. +-- Global conflict graph and NGC stats +cmmNativeGen + :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest) + => Logger + -> NcgImpl statics instr jumpDest + -> DUniqSupply + -> DwarfFiles + -> LabelMap DebugBlock + -> RawCmmDecl -- ^ the cmm to generate code for + -> Int -- ^ sequence number of this top thing + -> IO ( DUniqSupply + , DwarfFiles + , [NatCmmDecl statics instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats] -- stats for the linear register allocators + , LabelMap [UnwindPoint] -- unwinding information for blocks + , Maybe CFG -- final CFG + ) + +cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count + = do + let config = ncgConfig ncgImpl + let platform = ncgPlatform config + let weights = ncgCfgWeights config + + let proc_name = case cmm of + (CmmProc _ entry_label _ _) -> pprAsmLabel platform entry_label + _ -> text "DataChunk" + + -- rewrite assignments to global regs + let fixed_cmm = + {-# SCC "fixStgRegisters" #-} + fixStgRegisters platform cmm + + -- cmm to cmm optimisations + let (opt_cmm, imports) = + {-# SCC "cmmToCmm" #-} + cmmToCmm config fixed_cmm + + putDumpFileMaybe logger + Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM + (pprCmmGroup platform [opt_cmm]) + + let cmmCfg = {-# SCC "getCFG" #-} + getCfgProc platform weights opt_cmm + + -- generate native code from cmm + let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) = + {-# SCC "genMachCode" #-} + runUniqueDSM us $ genMachCode config + (cmmTopCodeGen ncgImpl) + fileIds dbgMap opt_cmm cmmCfg + + putDumpFileMaybe logger + Opt_D_dump_asm_native "Native code" FormatASM + (vcat $ map (pprNatCmmDeclS ncgImpl) native) + + maybeDumpCfg logger (Just nativeCfgWeights) "CFG Weights - Native" proc_name + + -- tag instructions with register liveness information + -- also drops dead code. We don't keep the cfg in sync on + -- some backends, so don't use it there. + let livenessCfg = if ncgEnableDeadCodeElimination config + then Just nativeCfgWeights + else Nothing + let (withLiveness, usLive) = + {-# SCC "regLiveness" #-} + runUniqueDSM usGen + $ mapM (cmmTopLiveness livenessCfg platform) native + + putDumpFileMaybe logger + Opt_D_dump_asm_liveness "Liveness annotations added" + FormatCMM + (vcat $ map (pprLiveCmmDecl platform) withLiveness) + + -- allocate registers + (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <- + if ( ncgRegsGraph config || ncgRegsIterative config ) + then do + -- the regs usable for allocation + let alloc_regs :: UniqFM RegClass (UniqSet RealReg) + = foldr (\r -> plusUFM_C unionUniqSets + $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) + emptyUFM + $ allocatableRegs ncgImpl + + -- do the graph coloring register allocation + let ((alloced, maybe_more_stack, regAllocStats), usAlloc) + = {-# SCC "RegAlloc-color" #-} + runUniqueDSM usLive + $ Color.regAlloc + config + alloc_regs + (mkUniqSet [0 .. maxSpillSlots ncgImpl]) + (maxSpillSlots ncgImpl) + withLiveness + livenessCfg + + let ((alloced', stack_updt_blks), usAlloc') + = runUniqueDSM usAlloc $ + case maybe_more_stack of + Nothing -> return (alloced, []) + Just amount -> do + (alloced',stack_updt_blks) <- unzip <$> + (mapM ((ncgAllocMoreStack ncgImpl) amount) alloced) + return (alloced', concat stack_updt_blks ) + + + -- dump out what happened during register allocation + putDumpFileMaybe logger + Opt_D_dump_asm_regalloc "Registers allocated" + FormatCMM + (vcat $ map (pprNatCmmDeclS ncgImpl) alloced) + + putDumpFileMaybe logger + Opt_D_dump_asm_regalloc_stages "Build/spill stages" + FormatText + (vcat $ map (\(stage, stats) + -> text "# --------------------------" + $$ text "# cmm " <> int count <> text " Stage " <> int stage + $$ ppr (fmap (pprInstr platform) stats)) + $ zip [0..] regAllocStats) + + let mPprStats = + if logHasDumpFlag logger Opt_D_dump_asm_stats + then Just regAllocStats else Nothing + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + + return ( alloced', usAlloc' + , mPprStats + , Nothing + , [], stack_updt_blks) + + else do + -- do linear register allocation + let reg_alloc proc = do + (alloced, maybe_more_stack, ra_stats) <- + Linear.regAlloc config proc + case maybe_more_stack of + Nothing -> return ( alloced, ra_stats, [] ) + Just amount -> do + (alloced',stack_updt_blks) <- + ncgAllocMoreStack ncgImpl amount alloced + return (alloced', ra_stats, stack_updt_blks ) + + let ((alloced, regAllocStats, stack_updt_blks), usAlloc) + = {-# SCC "RegAlloc-linear" #-} + runUniqueDSM usLive + $ liftM unzip3 + $ mapM reg_alloc withLiveness + + putDumpFileMaybe logger + Opt_D_dump_asm_regalloc "Registers allocated" + FormatCMM + (vcat $ map (pprNatCmmDeclS ncgImpl) alloced) + + let mPprStats = + if logHasDumpFlag logger Opt_D_dump_asm_stats + then Just (catMaybes regAllocStats) else Nothing + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + + return ( alloced, usAlloc + , Nothing + , mPprStats, (catMaybes regAllocStats) + , concat stack_updt_blks ) + + -- Fixupblocks the register allocator inserted (from, regMoves, to) + let cfgRegAllocUpdates :: [(BlockId,BlockId,BlockId)] + cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats) + + let cfgWithFixupBlks = + (\cfg -> addNodesBetween weights cfg cfgRegAllocUpdates) <$> livenessCfg + + -- Insert stack update blocks + let postRegCFG = + pure (foldl' (\m (from,to) -> addImmediateSuccessor weights from to m )) + <*> cfgWithFixupBlks + <*> pure stack_updt_blks + + ---- generate jump tables + let tabled = + {-# SCC "generateJumpTables" #-} + generateJumpTables ncgImpl alloced + + when (not $ null nativeCfgWeights) $ putDumpFileMaybe logger + Opt_D_dump_cfg_weights "CFG Update information" + FormatText + ( text "stack:" <+> ppr stack_updt_blks $$ + text "linearAlloc:" <+> ppr cfgRegAllocUpdates ) + + ---- shortcut branches + let (shorted, postShortCFG) = + {-# SCC "shortcutBranches" #-} + shortcutBranches config ncgImpl tabled postRegCFG + + let optimizedCFG :: Maybe CFG + optimizedCFG = + optimizeCFG (ncgCmmStaticPred config) weights cmm <$!> postShortCFG + + maybeDumpCfg logger optimizedCFG "CFG Weights - Final" proc_name + + --TODO: Partially check validity of the cfg. + let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks + getBlks _ = [] + + when ( ncgEnableDeadCodeElimination config && + (ncgAsmLinting config || debugIsOn )) $ do + let blocks = concatMap getBlks shorted + let labels = setFromList $ fmap blockId blocks :: LabelSet + let cfg = fromJust optimizedCFG + return $! seq (sanityCheckCfg cfg labels $ + text "cfg not in lockstep") () + + ---- sequence blocks + -- sequenced :: [NatCmmDecl statics instr] + let (sequenced, us_seq) = + {-# SCC "sequenceBlocks" #-} + runUniqueDSM usAlloc $ mapM (BlockLayout.sequenceTop + ncgImpl optimizedCFG) + shorted + + massert (checkLayout shorted sequenced) + + let branchOpt :: [NatCmmDecl statics instr] + branchOpt = + {-# SCC "invertCondBranches" #-} + map invert sequenced + where + invertConds :: LabelMap RawCmmStatics -> [NatBasicBlock instr] + -> [NatBasicBlock instr] + invertConds = invertCondBranches ncgImpl optimizedCFG + invert top@CmmData {} = top + invert (CmmProc info lbl live (ListGraph blocks)) = + CmmProc info lbl live (ListGraph $ invertConds info blocks) + + -- generate unwinding information from cmm + let unwinds :: BlockMap [UnwindPoint] + unwinds = + {-# SCC "unwindingInfo" #-} + foldl' addUnwind mapEmpty branchOpt + where + addUnwind acc proc = + acc `mapUnion` computeUnwinding config ncgImpl proc + + return ( us_seq + , fileIds' + , branchOpt + , lastMinuteImports ++ imports + , ppr_raStatsColor + , ppr_raStatsLinear + , unwinds + , optimizedCFG + ) + +maybeDumpCfg :: Logger -> Maybe CFG -> String -> SDoc -> IO () +maybeDumpCfg _logger Nothing _ _ = return () +maybeDumpCfg logger (Just cfg) msg proc_name + | null cfg = return () + | otherwise + = putDumpFileMaybe logger + Opt_D_dump_cfg_weights msg + FormatText + (proc_name <> char ':' $$ pprEdgeWeights cfg) + +-- | Make sure all blocks we want the layout algorithm to place have been placed. +checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] + -> Bool +checkLayout procsUnsequenced procsSequenced = + assertPpr (setNull diff) (text "Block sequencing dropped blocks:" <> ppr diff) + True + where + blocks1 = foldl' (setUnion) setEmpty $ + map getBlockIds procsUnsequenced :: LabelSet + blocks2 = foldl' (setUnion) setEmpty $ + map getBlockIds procsSequenced + diff = setDifference blocks1 blocks2 + + getBlockIds (CmmData _ _) = setEmpty + getBlockIds (CmmProc _ _ _ (ListGraph blocks)) = + setFromList $ map blockId blocks + +-- | Compute unwinding tables for the blocks of a procedure +computeUnwinding :: Instruction instr + => NCGConfig + -> NcgImpl statics instr jumpDest + -> NatCmmDecl statics instr + -- ^ the native code generated for the procedure + -> LabelMap [UnwindPoint] + -- ^ unwinding tables for all points of all blocks of the + -- procedure +computeUnwinding config _ _ + | not (ncgComputeUnwinding config) = mapEmpty +computeUnwinding _ _ (CmmData _ _) = mapEmpty +computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) = + -- In general we would need to push unwinding information down the + -- block-level call-graph to ensure that we fully account for all + -- relevant register writes within a procedure. + -- + -- However, the only unwinding information that we care about in GHC is for + -- Sp. The fact that GHC.Cmm.LayoutStack already ensures that we have unwind + -- information at the beginning of every block means that there is no need + -- to perform this sort of push-down. + mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs) + | BasicBlock blk_lbl instrs <- blks ] + +-- | Build a doc for all the imports. +-- +makeImportsDoc :: NCGConfig -> [CLabel] -> HDoc +makeImportsDoc config imports + = dyld_stubs imports + $$ + -- On recent versions of Darwin, the linker supports + -- dead-stripping of code and data on a per-symbol basis. + -- There's a hack to make this work in PprMach.pprNatCmmDecl. + (if platformHasSubsectionsViaSymbols platform + then line $ text ".subsections_via_symbols" + else Outputable.empty) + $$ + -- On recent GNU ELF systems one can mark an object file + -- as not requiring an executable stack. If all objects + -- linked into a program have this note then the program + -- will not use an executable stack, which is good for + -- security. GHC generated code does not need an executable + -- stack so add the note in: + (if platformHasGnuNonexecStack platform + then line $ text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits" + else Outputable.empty) + $$ + -- And just because every other compiler does, let's stick in + -- an identifier directive: .ident "GHC x.y.z" + (if platformHasIdentDirective platform + then let compilerIdent = text "GHC" <+> text cProjectVersion + in line $ text ".ident" <+> doubleQuotes compilerIdent + else Outputable.empty) + + where + platform = ncgPlatform config + + -- Generate "symbol stubs" for all external symbols that might + -- come from a dynamic library. + dyld_stubs :: [CLabel] -> HDoc + -- (Hack) sometimes two Labels pretty-print the same, but have + -- different uniques; so we compare their text versions... + dyld_stubs imps + | needImportedSymbols config + = vcat $ + (pprGotDeclaration config :) $ + fmap (pprImportedSymbol config . fst . head) $ + groupAllWith snd $ + map doPpr $ + imps + | otherwise + = Outputable.empty + + doPpr lbl = (lbl, showSDocOneLine + (ncgAsmContext config) + (pprAsmLabel platform lbl)) + +-- ----------------------------------------------------------------------------- +-- Generate jump tables + +-- Analyzes all native code and generates data sections for all jump +-- table instructions. +generateJumpTables + :: NcgImpl statics instr jumpDest + -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] +generateJumpTables ncgImpl xs = concatMap f xs + where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs + f p = [p] + g (BasicBlock _ xs) = mapMaybe (generateJumpTableForInstr ncgImpl) xs + +-- ----------------------------------------------------------------------------- +-- Shortcut branches + +-- Note [No asm-shortcutting on Darwin] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Asm-shortcutting may produce relative references to symbols defined in +-- other compilation units. This is not something that MachO relocations +-- support (see #21972). For this reason we disable the optimisation on Darwin. +-- We do so in the backend without a warning since this flag is enabled by +-- `-O2`. +-- +-- Another way to address this issue would be to rather implement a +-- PLT-relocatable jump-table strategy. However, this would only benefit Darwin +-- and does not seem worth the effort as this optimisation generally doesn't +-- offer terribly great benefits. + +shortcutBranches + :: forall statics instr jumpDest. (Outputable jumpDest) + => NCGConfig + -> NcgImpl statics instr jumpDest + -> [NatCmmDecl statics instr] + -> Maybe CFG + -> ([NatCmmDecl statics instr],Maybe CFG) + +shortcutBranches config ncgImpl tops weights + | ncgEnableShortcutting config + -- See Note [No asm-shortcutting on Darwin] + , not $ osMachOTarget $ platformOS $ ncgPlatform config + = ( map (apply_mapping ncgImpl mapping) tops' + , shortcutWeightMap mappingBid <$!> weights ) + | otherwise + = (tops, weights) + where + (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops + mapping = mapUnions mappings :: LabelMap jumpDest + mappingBid = fmap (getJumpDestBlockId ncgImpl) mapping + +build_mapping :: forall instr t d statics jumpDest. + NcgImpl statics instr jumpDest + -> GenCmmDecl d (LabelMap t) (ListGraph instr) + -> (GenCmmDecl d (LabelMap t) (ListGraph instr) + ,LabelMap jumpDest) +build_mapping _ top@(CmmData _ _) = (top, mapEmpty) +build_mapping _ (CmmProc info lbl live (ListGraph [])) + = (CmmProc info lbl live (ListGraph []), mapEmpty) +build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks))) + = (CmmProc info lbl live (ListGraph (head:others)), mapping) + -- drop the shorted blocks, but don't ever drop the first one, + -- because it is pointed to by a global label. + where + -- find all the blocks that just consist of a jump that can be + -- shorted. + -- Don't completely eliminate loops here -- that can leave a dangling jump! + shortcut_blocks :: [(BlockId, jumpDest)] + (_, shortcut_blocks, others) = + foldl' split (setEmpty :: LabelSet, [], []) blocks + split (s, shortcut_blocks, others) b@(BasicBlock id [insn]) + | Just jd <- canShortcut ncgImpl insn + , Just dest <- getJumpDestBlockId ncgImpl jd + , not (has_info id) + , (setMember dest s) || dest == id -- loop checks + = (s, shortcut_blocks, b : others) + split (s, shortcut_blocks, others) (BasicBlock id [insn]) + | Just dest <- canShortcut ncgImpl insn + , not (has_info id) + = (setInsert id s, (id,dest) : shortcut_blocks, others) + split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others) + + -- do not eliminate blocks that have an info table + has_info l = mapMember l info + + -- build a mapping from BlockId to JumpDest for shorting branches + mapping = mapFromList shortcut_blocks + +apply_mapping :: NcgImpl statics instr jumpDest + -> LabelMap jumpDest + -> GenCmmDecl statics h (ListGraph instr) + -> GenCmmDecl statics h (ListGraph instr) +apply_mapping ncgImpl ufm (CmmData sec statics) + = CmmData sec (shortcutStatics ncgImpl (\bid -> mapLookup bid ufm) statics) +apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks)) + = CmmProc info lbl live (ListGraph $ map short_bb blocks) + where + short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns + short_insn i = shortcutJump ncgImpl (\bid -> mapLookup bid ufm) i + -- shortcutJump should apply the mapping repeatedly, + -- just in case we can short multiple branches. + +-- ----------------------------------------------------------------------------- +-- Instruction selection + +-- Native code instruction selection for a chunk of stix code. For +-- this part of the computation, we switch from the UniqSM monad to +-- the NatM monad. The latter carries not only a Unique, but also an +-- Int denoting the current C stack pointer offset in the generated +-- code; this is needed for creating correct spill offsets on +-- architectures which don't offer, or for which it would be +-- prohibitively expensive to employ, a frame pointer register. Viz, +-- x86. + +-- The offset is measured in bytes, and indicates the difference +-- between the current (simulated) C stack-ptr and the value it was at +-- the beginning of the block. For stacks which grow down, this value +-- should be either zero or negative. + +-- Along with the stack pointer offset, we also carry along a LabelMap of +-- DebugBlocks, which we read to generate .location directives. +-- +-- Switching between the two monads whilst carrying along the same +-- Unique supply breaks abstraction. Is that bad? + +genMachCode + :: NCGConfig + -> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) + -> DwarfFiles + -> LabelMap DebugBlock + -> RawCmmDecl + -> CFG + -> UniqDSM + ( [NatCmmDecl statics instr] + , [CLabel] + , DwarfFiles + , CFG + ) + +genMachCode config cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg + = UDSM $ \initial_us -> do + { let initial_st = mkNatM_State initial_us 0 config + fileIds dbgMap cmm_cfg + (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) + final_delta = natm_delta final_st + final_imports = natm_imports final_st + final_cfg = natm_cfg final_st + ; if final_delta == 0 + then DUniqResult + (new_tops, final_imports + , natm_fileid final_st, final_cfg) (natm_us final_st) + else DUniqResult (pprPanic "genMachCode: nonzero final delta" (int final_delta)) undefined + } diff --git a/GHC/CmmToAsm/AArch64.hs b/GHC/CmmToAsm/AArch64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/AArch64.hs @@ -0,0 +1,62 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Native code generator for AArch64 architectures +module GHC.CmmToAsm.AArch64 + ( ncgAArch64 ) +where + +import GHC.Prelude + +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types +import GHC.Utils.Outputable (ftext) + +import qualified GHC.CmmToAsm.AArch64.Instr as AArch64 +import qualified GHC.CmmToAsm.AArch64.Ppr as AArch64 +import qualified GHC.CmmToAsm.AArch64.CodeGen as AArch64 +import qualified GHC.CmmToAsm.AArch64.Regs as AArch64 +import qualified GHC.CmmToAsm.AArch64.RegInfo as AArch64 + +ncgAArch64 :: NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest +ncgAArch64 config + = NcgImpl { + ncgConfig = config + ,cmmTopCodeGen = AArch64.cmmTopCodeGen + ,generateJumpTableForInstr = AArch64.generateJumpTableForInstr config + ,getJumpDestBlockId = AArch64.getJumpDestBlockId + ,canShortcut = AArch64.canShortcut + ,shortcutStatics = AArch64.shortcutStatics + ,shortcutJump = AArch64.shortcutJump + ,pprNatCmmDeclS = AArch64.pprNatCmmDecl config + ,pprNatCmmDeclH = AArch64.pprNatCmmDecl config + ,maxSpillSlots = AArch64.maxSpillSlots config + ,allocatableRegs = AArch64.allocatableRegs platform + ,ncgAllocMoreStack = AArch64.allocMoreStack platform + ,ncgMakeFarBranches = AArch64.makeFarBranches + ,extractUnwindPoints = const [] + ,invertCondBranches = \_ _ blocks -> blocks + } + where + platform = ncgPlatform config + +-- | Instruction instance for aarch64 +instance Instruction AArch64.Instr where + regUsageOfInstr = AArch64.regUsageOfInstr + patchRegsOfInstr _ = AArch64.patchRegsOfInstr + isJumpishInstr = AArch64.isJumpishInstr + jumpDestsOfInstr = AArch64.jumpDestsOfInstr + canFallthroughTo = AArch64.canFallthroughTo + patchJumpInstr = AArch64.patchJumpInstr + mkSpillInstr = AArch64.mkSpillInstr + mkLoadInstr = AArch64.mkLoadInstr + takeDeltaInstr = AArch64.takeDeltaInstr + isMetaInstr = AArch64.isMetaInstr + mkRegRegMoveInstr _ = AArch64.mkRegRegMoveInstr + takeRegRegMoveInstr _ = AArch64.takeRegRegMoveInstr + mkJumpInstr = AArch64.mkJumpInstr + mkStackAllocInstr = AArch64.mkStackAllocInstr + mkStackDeallocInstr = AArch64.mkStackDeallocInstr + mkComment = pure . AArch64.COMMENT . ftext + pprInstr = AArch64.pprInstr diff --git a/GHC/CmmToAsm/AArch64/CodeGen.hs b/GHC/CmmToAsm/AArch64/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -0,0 +1,2577 @@ +{-# language GADTs, LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.CmmToAsm.AArch64.CodeGen ( + cmmTopCodeGen + , generateJumpTableForInstr + , makeFarBranches +) + +where + +-- NCG stuff: +import GHC.Prelude hiding (EQ) + +import Data.Word + +import GHC.Platform.Regs +import GHC.CmmToAsm.AArch64.Instr +import GHC.CmmToAsm.AArch64.Regs +import GHC.CmmToAsm.AArch64.Cond + +import GHC.CmmToAsm.CPrim +import GHC.Cmm.DebugBlock +import GHC.CmmToAsm.Monad + ( NatM, getNewRegNat + , getPicBaseMaybeNat, getPlatform, getConfig + , getDebugBlock, getFileId, getNewLabelNat, getThisModuleNat + ) +-- import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types +import GHC.Platform.Reg +import GHC.Platform + +-- Our intermediate code: +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Graph +import GHC.Types.Tickish ( GenTickish(..) ) +import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) +import GHC.Types.Unique.DSM + +-- The rest: +import GHC.Data.OrdList +import GHC.Utils.Outputable + +import Control.Monad ( mapAndUnzipM ) +import GHC.Float + +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Monad (mapAccumLM) + +-- Note [General layout of an NCG] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- @cmmTopCodeGen@ will be our main entry point to code gen. Here we'll get +-- @RawCmmDecl@; see GHC.Cmm +-- +-- RawCmmDecl = GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph +-- +-- GenCmmDecl d h g = CmmProc h CLabel [GlobalReg] g +-- | CmmData Section d +-- +-- As a result we want to transform this to a list of @NatCmmDecl@, which is +-- defined @GHC.CmmToAsm.Instr@ as +-- +-- type NatCmmDecl statics instr +-- = GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr) +-- +-- Thus well' turn +-- GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph +-- into +-- [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) (ListGraph Instr)] +-- +-- where @CmmGraph@ is +-- +-- type CmmGraph = GenCmmGraph CmmNode +-- data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } +-- type CmmBlock = Block CmmNode C C +-- +-- and @ListGraph Instr@ is +-- +-- newtype ListGraph i = ListGraph [GenBasicBlock i] +-- data GenBasicBlock i = BasicBlock BlockId [i] + +cmmTopCodeGen + :: RawCmmDecl + -> NatM [NatCmmDecl RawCmmStatics Instr] + +-- Thus we'll have to deal with either CmmProc ... +cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do + -- do + -- traceM $ "-- -------------------------- cmmTopGen (CmmProc) -------------------------- --\n" + -- ++ showSDocUnsafe (ppr cmm) + + let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + picBaseMb <- getPicBaseMaybeNat + + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + + case picBaseMb of + Just _picBase -> panic "AArch64.cmmTopCodeGen: picBase not implemented" + Nothing -> return tops + +-- ... or CmmData. +cmmTopCodeGen _cmm@(CmmData sec dat) = do + -- do + -- traceM $ "-- -------------------------- cmmTopGen (CmmData) -------------------------- --\n" + -- ++ showSDocUnsafe (ppr cmm) + return [CmmData sec dat] -- no translation, we just use CmmStatic + +basicBlockCodeGen + :: Block CmmNode C C + -> NatM ( [NatBasicBlock Instr] + , [NatCmmDecl RawCmmStatics Instr]) + +basicBlockCodeGen block = do + config <- getConfig + -- do + -- traceM $ "-- --------------------------- basicBlockCodeGen --------------------------- --\n" + -- ++ showSDocUnsafe (ppr block) + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + + header_comment_instr | debugIsOn = unitOL $ MULTILINE_COMMENT ( + text "-- --------------------------- basicBlockCodeGen --------------------------- --\n" + $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block) + ) + | otherwise = nilOL + -- Generate location directive + dbg <- getDebugBlock (entryLabel block) + loc_instrs <- case dblSourceTick =<< dbg of + Just (SourceNote span (LexicalFastString name)) + -> do fileId <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col = srcSpanStartCol span + return $ unitOL $ LOCATION fileId line col (unpackFS name) + _ -> return nilOL + mid_instrs <- stmtsToInstrs stmts + (!tail_instrs) <- stmtToInstrs tail + let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs + -- TODO: Then x86 backend run @verifyBasicBlock@ here and inserts + -- unwinding info. See Ticket 19913 + -- code generation may introduce new basic block boundaries, which + -- are indicated by the NEWBLOCK instruction. We must split up the + -- instruction stream into basic blocks again. Also, we may extract + -- LDATAs here too (if they are implemented by AArch64 again - See + -- PPC how to do that.) + let + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs + + return (BasicBlock id top : other_blocks, statics) + +mkBlocks :: Instr + -> ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) + -> ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) +mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) +mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) +-- ----------------------------------------------------------------------------- +-- | Utilities +ann :: SDoc -> Instr -> Instr +ann doc instr {- debugIsOn -} = ANN doc instr +-- ann _ instr = instr +{-# INLINE ann #-} + +-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with +-- -dppr-debug. The idea is that we can trivially see how a cmm expression +-- ended up producing the assembly we see. By having the verbatim AST printed +-- we can simply check the patterns that were matched to arrive at the assembly +-- we generated. +-- +-- pprExpr will hide a lot of noise of the underlying data structure and print +-- the expression into something that can be easily read by a human. However +-- going back to the exact CmmExpr representation can be laborious and adds +-- indirections to find the matches that lead to the assembly. +-- +-- An improvement could be to have +-- +-- (pprExpr genericPlatform e) <> parens (text. show e) +-- +-- to have the best of both worlds. +-- +-- Note: debugIsOn is too restrictive, it only works for debug compilers. +-- However, we do not only want to inspect this for debug compilers. Ideally +-- we'd have a check for -dppr-debug here already, such that we don't even +-- generate the ANN expressions. However, as they are lazy, they shouldn't be +-- forced until we actually force them, and without -dppr-debug they should +-- never end up being forced. +annExpr :: CmmExpr -> Instr -> Instr +annExpr e instr {- debugIsOn -} = ANN (text . show $ e) instr +-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr +-- annExpr _ instr = instr +{-# INLINE annExpr #-} + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +-- | Generate jump to jump table target +-- +-- The index into the jump table is calulated by evaluating @expr@. The +-- corresponding table entry contains the relative address to jump to (relative +-- to the jump table's first entry / the table's own label). +genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock +genSwitch config expr targets = do + (reg, fmt1, e_code) <- getSomeReg indexExpr + let fmt = II64 + targetReg <- getNewRegNat fmt + lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + (tableReg, fmt2, t_code) <- getSomeReg dynRef + let code = + toOL + [ COMMENT (text "indexExpr" <+> (text . show) indexExpr), + COMMENT (text "dynRef" <+> (text . show) dynRef) + ] + `appOL` e_code + `appOL` t_code + `appOL` toOL + [ COMMENT (ftext "Jump table for switch"), + -- index to offset into the table (relative to tableReg) + annExpr expr (LSL (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))), + -- calculate table entry address + ADD (OpReg W64 targetReg) (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt2) tableReg), + -- load table entry (relative offset from tableReg (first entry) to target label) + LDR II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))), + -- calculate absolute address of the target label + ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg), + -- prepare jump to target label + J_TBL ids (Just lbl) targetReg + ] + return code + where + -- See Note [Sub-word subtlety during jump-table indexing] in + -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen. + indexExpr0 = cmmOffset platform expr offset + -- We widen to a native-width register to sanitize the high bits + indexExpr = + CmmMachOp + (MO_UU_Conv expr_w (platformWordWidth platform)) + [indexExpr0] + expr_w = cmmExprWidth platform expr + (offset, ids) = switchTargetsToTable targets + platform = ncgPlatform config + +-- | Generate jump table data (if required) +-- +-- The idea is to emit one table entry per case. The entry is the relative +-- address of the block to jump to (relative to the table's first entry / +-- table's own label.) The calculation itself is done by the linker. +generateJumpTableForInstr :: + NCGConfig -> + Instr -> + Maybe (NatCmmDecl RawCmmStatics Instr) +generateJumpTableForInstr config (J_TBL ids (Just lbl) _) = + let jumpTable = + map jumpTableEntryRel ids + where + jumpTableEntryRel Nothing = + CmmStaticLit (CmmInt 0 (ncgWordWidth config)) + jumpTableEntryRel (Just blockid) = + CmmStaticLit + ( CmmLabelDiffOff + blockLabel + lbl + 0 + (ncgWordWidth config) + ) + where + blockLabel = blockLbl blockid + sectionType = case platformOS (ncgPlatform config) of + -- Aarch64 Windows platform requires LLVM 20 to support .rodata + OSMinGW32 -> Text + _ -> ReadOnlyData + in Just (CmmData (Section sectionType lbl) (CmmStaticsRaw lbl jumpTable)) +generateJumpTableForInstr _ _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Top-level of the instruction selector + +stmtsToInstrs :: [CmmNode O O] -- ^ Cmm Statements + -> NatM InstrBlock -- ^ Resulting instructions +stmtsToInstrs stmts = + go stmts nilOL + where + go [] instrs = return instrs + go (s:stmts) instrs = do + instrs' <- stmtToInstrs s + go stmts (instrs `appOL` instrs') + +stmtToInstrs :: CmmNode e x -- ^ Cmm Statement + -> NatM InstrBlock -- ^ Resulting Instructions +stmtToInstrs stmt = do + -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n" + -- ++ showSDocUnsafe (ppr stmt) + config <- getConfig + platform <- getPlatform + case stmt of + CmmUnsafeForeignCall target result_regs args + -> genCCall target result_regs args + + _ -> case stmt of + CmmComment s -> return (unitOL (COMMENT (ftext s))) + CmmTick {} -> return nilOL + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode format reg src + | otherwise -> assignReg_IntCode format reg src + where ty = cmmRegType reg + format = cmmTypeFormat ty + + CmmStore addr src _alignment + | isFloatType ty -> assignMem_FltCode format addr src + | otherwise -> assignMem_IntCode format addr src + where ty = cmmExprType platform src + format = cmmTypeFormat ty + + CmmBranch id -> genBranch id + + --We try to arrange blocks such that the likely branch is the fallthrough + --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. + CmmCondBranch arg true false _prediction -> + genCondBranch true false arg + + CmmSwitch arg ids -> genSwitch config arg ids + + CmmCall { cml_target = arg } -> genJump arg + + CmmUnwind _regs -> return nilOL + + _ -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt) + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + +-- | Register's passed up the tree. If the stix code forces the register +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. +-- +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + +-- | Sometimes we need to change the Format of a register. Primarily during +-- conversion. +swizzleRegisterRep :: Format -> Register -> Register +swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code +swizzleRegisterRep format (Any _ codefn) = Any format codefn + +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal (LocalReg u pk)) + = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) + +getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) + = case globalRegMaybe platform mid of + Just reg -> RegReal reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence if it's not mapped to a registers something + -- went wrong earlier in the pipeline. + +-- ----------------------------------------------------------------------------- +-- General things for putting together code sequences + +-- | The dual to getAnyReg: compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, rep, code tmp) + Fixed rep reg code -> + return (reg, rep, code) + +{- Note [Aarch64 immediates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Aarch64 with it's fixed width instruction encoding uses leftover space for +immediates. +If you want the full rundown consult the arch reference document: +"Arm® Architecture Reference Manual" - "C3.4 Data processing - immediate" + +The gist of it is that different instructions allow for different immediate encodings. +The ones we care about for better code generation are: + +* Simple but potentially repeated bit-patterns for logic instructions. +* 16bit numbers shifted by multiples of 16. +* 12 bit numbers optionally shifted by 12 bits. + +It might seem like the ISA allows for 64bit immediates but this isn't the case. +Rather there are some instruction aliases which allow for large unencoded immediates +which will then be transalted to one of the immediate encodings implicitly. + +For example mov x1, #0x10000 is allowed but will be assembled to movz x1, #0x1, lsl #16 +-} + +-- | Move (wide immediate) +-- Allows for 16bit immediate which can be shifted by 0/16/32/48 bits. +-- Used with MOVZ,MOVN, MOVK +-- See Note [Aarch64 immediates] +getMovWideImm :: Integer -> Width -> Maybe Operand +getMovWideImm n w + -- TODO: Handle sign extension/negatives + | n <= 0 + = Nothing + -- Fits in 16 bits + | sized_n < 2^(16 :: Int) + = Just $ OpImm (ImmInteger truncated) + + -- 0x0000 0000 xxxx 0000 + | trailing_zeros >= 16 && sized_n < 2^(32 :: Int) + = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 16) SLSL 16 + + -- 0x 0000 xxxx 0000 0000 + | trailing_zeros >= 32 && sized_n < 2^(48 :: Int) + = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 32) SLSL 32 + + -- 0x xxxx 0000 0000 0000 + | trailing_zeros >= 48 + = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 48) SLSL 48 + + | otherwise + = Nothing + where + truncated = narrowU w n + sized_n = fromIntegral truncated :: Word64 + trailing_zeros = countTrailingZeros sized_n + +-- | Arithmetic(immediate) +-- Allows for 12bit immediates which can be shifted by 0 or 12 bits. +-- Used with ADD, ADDS, SUB, SUBS, CMP +-- See Note [Aarch64 immediates] +getArithImm :: Integer -> Width -> Maybe Operand +getArithImm n w + -- TODO: Handle sign extension + | n <= 0 + = Nothing + -- Fits in 16 bits + -- Fits in 12 bits + | sized_n < 2^(12::Int) + = Just $ OpImm (ImmInteger truncated) + + -- 12 bits shifted by 12 places. + | trailing_zeros >= 12 && sized_n < 2^(24::Int) + = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 12) SLSL 12 + + | otherwise + = Nothing + where + sized_n = fromIntegral truncated :: Word64 + truncated = narrowU w n + trailing_zeros = countTrailingZeros sized_n + +-- | Logical (immediate) +-- Allows encoding of some repeated bitpatterns +-- Used with AND, EOR, ORR +-- and their aliases which includes at least MOV (bitmask immediate) +-- See Note [Aarch64 immediates] +getBitmaskImm :: Integer -> Width -> Maybe Operand +getBitmaskImm n w + | isAArch64Bitmask (opRegWidth w) truncated = Just $ OpImm (ImmInteger truncated) + | otherwise = Nothing + where + truncated = narrowU w n + +-- | Load/store immediate. +-- Depends on the width of the store to some extent. +isOffsetImm :: Int -> Width -> Bool +isOffsetImm off w + -- 8 bits + sign for unscaled offsets + | -256 <= off, off <= 255 = True + -- Offset using 12-bit positive immediate, scaled by width + -- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4 + -- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8 + -- 16-bit: 0 .. 8188, 8-bit: 0 -- 4095 + | 0 <= off, off < 4096 * byte_width, off `mod` byte_width == 0 = True + | otherwise = False + where + byte_width = widthInBytes w + + + + +-- TODO OPT: we might be able give getRegister +-- a hint, what kind of register we want. +getFloatReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) +getFloatReg expr = do + r <- getRegister expr + case r of + Any rep code | isFloatFormat rep -> do + tmp <- getNewRegNat rep + return (tmp, rep, code tmp) + Any II32 code -> do + tmp <- getNewRegNat FF32 + return (tmp, FF32, code tmp) + Any II64 code -> do + tmp <- getNewRegNat FF64 + return (tmp, FF64, code tmp) + Any _w _code -> do + config <- getConfig + pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr) + -- can't do much for fixed. + Fixed rep reg code -> + return (reg, rep, code) + +-- TODO: TODO, bounds. We can't put any immediate +-- value in. They are constrained. +-- See Ticket 19911 +litToImm' :: CmmLit -> NatM (Operand, InstrBlock) +litToImm' lit = return (OpImm (litToImm lit), nilOL) + +getRegister :: CmmExpr -> NatM Register +getRegister e = do + config <- getConfig + getRegister' config (ncgPlatform config) e + +-- | The register width to be used for an operation on the given width +-- operand. +opRegWidth :: Width -> Width +opRegWidth W64 = W64 -- x +opRegWidth W32 = W32 -- w +opRegWidth W16 = W32 -- w +opRegWidth W8 = W32 -- w +opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) + +-- Note [Signed arithmetic on AArch64] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Handling signed arithmetic on sub-word-size values on AArch64 is a bit +-- tricky as Cmm's type system does not capture signedness. While 32-bit values +-- are fairly easy to handle due to AArch64's 32-bit instruction variants +-- (denoted by use of %wN registers), 16- and 8-bit values require quite some +-- care. +-- +-- We handle 16-and 8-bit values by using the 32-bit operations and +-- sign-/zero-extending operands and truncate results as necessary. For +-- simplicity we maintain the invariant that a register containing a +-- sub-word-size value always contains the zero-extended form of that value +-- in between operations. +-- +-- For instance, consider the program, +-- +-- test(bits64 buffer) +-- bits8 a = bits8[buffer]; +-- bits8 b = %mul(a, 42); +-- bits8 c = %not(b); +-- bits8 d = %shrl(c, 4::bits8); +-- return (d); +-- } +-- +-- This program begins by loading `a` from memory, for which we use a +-- zero-extended byte-size load. We next sign-extend `a` to 32-bits, and use a +-- 32-bit multiplication to compute `b`, and truncate the result back down to +-- 8-bits. +-- +-- Next we compute `c`: The `%not` requires no extension of its operands, but +-- we must still truncate the result back down to 8-bits. Finally the `%shrl` +-- requires no extension and no truncate since we can assume that +-- `c` is zero-extended. +-- +-- TODO: +-- Don't use Width in Operands +-- Instructions should rather carry a RegWidth +-- +-- Note [Handling PIC on AArch64] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- AArch64 does not have a special PIC register, the general approach is to +-- simply go through the GOT, and there is assembly support for this: +-- +-- // Load the address of 'sym' from the GOT using ADRP and LDR (used for +-- // position-independent code on AArch64): +-- adrp x0, #:got:sym +-- ldr x0, [x0, #:got_lo12:sym] +-- +-- See also: https://developer.arm.com/documentation/dui0774/i/armclang-integrated-assembler-directives/assembly-expressions +-- +-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the +-- @cmmMakePicReference@. This is in turn called from @cmmMakeDynamicReference@ +-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported. There are two +-- callsites for this. One is in this module to produce the @target@ in @genCCall@ +-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@. +-- +-- Conceptually we do not want any special PicBaseReg to be used on AArch64. If +-- we want to distinguish between symbol loading, we need to address this through +-- the way we load it, not through a register. +-- + +getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register +-- OPTIMIZATION WARNING: CmmExpr rewrites +-- 1. Rewrite: Reg + (-n) => Reg - n +-- TODO: this expression shouldn't even be generated to begin with. +getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)]) | i < 0 + = getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)]) + +getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)]) | i < 0 + = getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt (-i) w1)]) + + +-- Generic case. +getRegister' config plat expr + = case expr of + CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) + -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg) + CmmLit lit + -> case lit of + + -- Use wzr xzr for CmmInt 0 if the width matches up, otherwise do a move. + -- TODO: Reenable after https://gitlab.haskell.org/ghc/ghc/-/issues/23632 is fixed. + -- CmmInt 0 W32 -> do + -- let format = intFormat W32 + -- return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) )) + -- CmmInt 0 W64 -> do + -- let format = intFormat W64 + -- return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) )) + CmmInt i W8 | i >= 0 -> do + return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i)))))) + CmmInt i W16 | i >= 0 -> do + return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i)))))) + + CmmInt i W8 -> do + return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i)))))) + CmmInt i W16 -> do + return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i)))))) + + -- We need to be careful to not shorten this for negative literals. + -- Those need the upper bits set. We'd either have to explicitly sign + -- or figure out something smarter. Lowered to + -- `MOV dst XZR` + CmmInt i w | i >= 0 + , Just imm_op <- getMovWideImm i w -> do + return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOVZ (OpReg w dst) imm_op))) + + CmmInt i w | isNbitEncodeable 16 i, i >= 0 -> do + return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger i))))) + + CmmInt i w | isNbitEncodeable 32 i, i >= 0 -> do + let half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + return (Any (intFormat w) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W32 dst) (OpImm (ImmInt half0)) + , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16) + ])) + -- fallback for W32 + CmmInt i W32 -> do + let half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + return (Any (intFormat W32) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W32 dst) (OpImm (ImmInt half0)) + , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16) + ])) + -- anything else + CmmInt i W64 -> do + let half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16) + half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16) + return (Any (intFormat W64) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W64 dst) (OpImm (ImmInt half0)) + , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half1) SLSL 16) + , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half2) SLSL 32) + , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half3) SLSL 48) + ])) + CmmInt _i rep -> do + (op, imm_code) <- litToImm' lit + return (Any (intFormat rep) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg rep dst) op))) + + -- floatToBytes (fromRational f) + CmmFloat 0 w -> do + (op, imm_code) <- litToImm' lit + return (Any (floatFormat w) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg w dst) op))) + + CmmFloat _f W8 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr) + CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr) + CmmFloat f W32 -> do + let word = castFloatToWord32 (fromRational f) :: Word32 + half0 = fromIntegral (fromIntegral word :: Word16) + half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16) + tmp <- getNewRegNat (intFormat W32) + return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W32 tmp) (OpImm (ImmInt half0)) + , MOVK (OpReg W32 tmp) (OpImmShift (ImmInt half1) SLSL 16) + , MOV (OpReg W32 dst) (OpReg W32 tmp) + ])) + CmmFloat f W64 -> do + let word = castDoubleToWord64 (fromRational f) :: Word64 + half0 = fromIntegral (fromIntegral word :: Word16) + half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16) + half2 = fromIntegral (fromIntegral (word `shiftR` 32) :: Word16) + half3 = fromIntegral (fromIntegral (word `shiftR` 48) :: Word16) + tmp <- getNewRegNat (intFormat W64) + return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W64 tmp) (OpImm (ImmInt half0)) + , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half1) SLSL 16) + , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half2) SLSL 32) + , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half3) SLSL 48) + , MOV (OpReg W64 dst) (OpReg W64 tmp) + ])) + CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr) + CmmVec _ -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr) + CmmLabel _lbl -> do + (op, imm_code) <- litToImm' lit + let rep = cmmLitType plat lit + format = cmmTypeFormat rep + return (Any format (\dst -> imm_code `snocOL` (annExpr expr $ LDR format (OpReg (formatToWidth format) dst) op))) + + CmmLabelOff _lbl off | isNbitEncodeable 12 (fromIntegral off) -> do + (op, imm_code) <- litToImm' lit + let rep = cmmLitType plat lit + format = cmmTypeFormat rep + return (Any format (\dst -> imm_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op)) + + CmmLabelOff lbl off -> do + (op, imm_code) <- litToImm' (CmmLabel lbl) + let rep = cmmLitType plat lit + format = cmmTypeFormat rep + width = typeWidth rep + (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width) + return (Any format (\dst -> imm_code `appOL` off_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op `snocOL` ADD (OpReg width dst) (OpReg width dst) (OpReg width off_r))) + + CmmLabelDiffOff _ _ _ _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmLoad mem rep _ -> do + Amode addr addr_code <- getAmode plat (typeWidth rep) mem + let format = cmmTypeFormat rep + return (Any format (\dst -> addr_code `snocOL` LDR format (OpReg (formatToWidth format) dst) (OpAddr addr))) + CmmStackSlot _ _ + -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr) + CmmReg reg + -> return (Fixed (cmmTypeFormat (cmmRegType reg)) + (getRegisterReg plat reg) + nilOL) + CmmRegOff reg off -> + -- If we got here we will load the address into a register either way. So we might as well just expand + -- and re-use the existing code path to handle "reg + off". + let !width = cmmRegWidth reg + in getRegister' config plat (CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]) + + -- for MachOps, see GHC.Cmm.MachOp + -- For CmmMachOp, see GHC.Cmm.Expr + + -- Handle MO_RelaxedRead as a normal CmmLoad, to allow + -- non-trivial addressing modes to be used. + CmmMachOp (MO_RelaxedRead w) [e] -> + getRegister (CmmLoad e (cmmBits w) NaturallyAligned) + + CmmMachOp op [e] -> do + (reg, _format, code) <- getSomeReg e + case op of + MO_Not w -> return $ Any (intFormat w) $ \dst -> + let w' = opRegWidth w + in code `snocOL` + MVN (OpReg w' dst) (OpReg w' reg) `appOL` + truncateReg w' w dst -- See Note [Signed arithmetic on AArch64] + + MO_S_Neg w -> negate code w reg + MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg)) + + MO_SF_Round from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float) + MO_FS_Truncate from to -> return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed) + + -- TODO this is very hacky + -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@ + -- UBFM will set the high bits to 0. SBFM will copy the sign (sign extend). + MO_UU_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` UBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to))) + MO_SS_Conv from to -> ss_conv from to reg code + MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg)) + MO_WF_Bitcast w -> return $ Any (floatFormat w) (\dst -> code `snocOL` FMOV (OpReg w dst) (OpReg w reg)) + MO_FW_Bitcast w -> return $ Any (intFormat w) (\dst -> code `snocOL` FMOV (OpReg w dst) (OpReg w reg)) + + -- Conversions + MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e + + MO_Eq {} -> notUnary + MO_Ne {} -> notUnary + MO_Mul {} -> notUnary + MO_S_MulMayOflo {} -> notUnary + MO_S_Quot {} -> notUnary + MO_S_Rem {} -> notUnary + MO_U_Quot {} -> notUnary + MO_U_Rem {} -> notUnary + MO_S_Ge {} -> notUnary + MO_S_Le {} -> notUnary + MO_S_Gt {} -> notUnary + MO_S_Lt {} -> notUnary + MO_U_Ge {} -> notUnary + MO_U_Le {} -> notUnary + MO_U_Gt {} -> notUnary + MO_U_Lt {} -> notUnary + MO_F_Add {} -> notUnary + MO_F_Sub {} -> notUnary + MO_F_Mul {} -> notUnary + MO_F_Quot {} -> notUnary + MO_FMA {} -> notUnary + MO_F_Eq {} -> notUnary + MO_F_Ne {} -> notUnary + MO_F_Ge {} -> notUnary + MO_F_Le {} -> notUnary + MO_F_Gt {} -> notUnary + MO_F_Lt {} -> notUnary + MO_And {} -> notUnary + MO_Or {} -> notUnary + MO_Xor {} -> notUnary + MO_Shl {} -> notUnary + MO_U_Shr {} -> notUnary + MO_S_Shr {} -> notUnary + MO_V_Insert {} -> notUnary + MO_V_Extract {} -> notUnary + MO_V_Add {} -> notUnary + MO_V_Sub {} -> notUnary + MO_V_Mul {} -> notUnary + MO_VS_Neg {} -> notUnary + MO_V_Shuffle {} -> notUnary + MO_VF_Shuffle {} -> notUnary + MO_VF_Insert {} -> notUnary + MO_VF_Extract {} -> notUnary + MO_VF_Add {} -> notUnary + MO_VF_Sub {} -> notUnary + MO_VF_Mul {} -> notUnary + MO_VF_Quot {} -> notUnary + MO_Add {} -> notUnary + MO_Sub {} -> notUnary + + MO_F_Min {} -> notUnary + MO_F_Max {} -> notUnary + MO_VU_Min {} -> notUnary + MO_VU_Max {} -> notUnary + MO_VS_Min {} -> notUnary + MO_VS_Max {} -> notUnary + MO_VF_Min {} -> notUnary + MO_VF_Max {} -> notUnary + + MO_AlignmentCheck {} -> + pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr) + + MO_V_Broadcast {} -> vectorsNeedLlvm + MO_VF_Broadcast {} -> vectorsNeedLlvm + MO_VF_Neg {} -> vectorsNeedLlvm + where + notUnary = pprPanic "getRegister' (non-unary CmmMachOp with 1 argument):" (pdoc plat expr) + vectorsNeedLlvm = + sorry "SIMD operations on AArch64 currently require the LLVM backend" + toImm W8 = (OpImm (ImmInt 7)) + toImm W16 = (OpImm (ImmInt 15)) + toImm W32 = (OpImm (ImmInt 31)) + toImm W64 = (OpImm (ImmInt 63)) + toImm W128 = (OpImm (ImmInt 127)) + toImm W256 = (OpImm (ImmInt 255)) + toImm W512 = (OpImm (ImmInt 511)) + + -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits + -- See Note [Signed arithmetic on AArch64]. + negate code w reg = do + let w' = opRegWidth w + (reg', code_sx) <- signExtendReg w w' reg + return $ Any (intFormat w) $ \dst -> + code `appOL` + code_sx `snocOL` + NEG (OpReg w' dst) (OpReg w' reg') `appOL` + truncateReg w' w dst + + ss_conv from to reg code = + let w' = opRegWidth (max from to) + in return $ Any (intFormat to) $ \dst -> + code `snocOL` + SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL` + -- At this point an 8- or 16-bit value would be sign-extended + -- to 32-bits. Truncate back down the final width. + truncateReg w' to dst + + -- Dyadic machops: + -- + -- The general idea is: + -- compute x <- x + -- compute x <- y + -- OP x, x, x + -- + -- TODO: for now we'll only implement the 64bit versions. And rely on the + -- fallthrough to alert us if things go wrong! + -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring + -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg + CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' + CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' + -- Immediates are handled via `getArithImm` in the generic code path. + + CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` + (UXTB (OpReg w reg_y) (OpReg w reg_y)) `snocOL` + (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + CmmMachOp (MO_U_Quot w) [x, y] | w == W16 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` + (UXTH (OpReg w reg_y) (OpReg w reg_y)) `snocOL` + (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + + -- 2. Shifts. x << n, x >> n. + CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] + | w == W32 || w == W64 + , 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))) + `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` + (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL` + (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + + CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))) + `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` + (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL` + (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + + CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] + | w == W32 || w == W64 + , 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))) + CmmMachOp (MO_U_Shr w) [x, y] | w == W8 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` + (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + + CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))) + CmmMachOp (MO_U_Shr w) [x, y] | w == W16 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) + `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + + CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] + | w == W32 || w == W64 + , 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + -- 3. Logic &&, || + CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) -> + return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) + r' = getRegisterReg plat reg + + CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) -> + return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) + r' = getRegisterReg plat reg + + -- Generic binary case. + CmmMachOp op [x, y] -> do + -- alright, so we have an operation, and two expressions. And we want to essentially do + -- ensure we get float regs (TODO(Ben): What?) + let withTempIntReg w op = OpReg w <$> getNewRegNat (intFormat w) >>= op + -- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op + + -- A "plain" operation. + bitOpImm w op encode_imm = do + -- compute x <- x + -- compute x <- y + -- x, x, x + (reg_x, format_x, code_x) <- getSomeReg x + (op_y, format_y, code_y) <- case y of + CmmLit (CmmInt n w) + | Just imm_operand_y <- encode_imm n w + -> return (imm_operand_y, intFormat w, nilOL) + _ -> do + (reg_y, format_y, code_y) <- getSomeReg y + return (OpReg w reg_y, format_y, code_y) + massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOpImm: incompatible" + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + op (OpReg w dst) (OpReg w reg_x) op_y) + + -- A (potentially signed) integer operation. + -- In the case of 8- and 16-bit signed arithmetic we must first + -- sign-extend both arguments to 32-bits. + -- See Note [Signed arithmetic on AArch64]. + intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register) + intOpImm {- is signed -} True w op _encode_imm = intOp True w op + intOpImm False w op encode_imm = do + -- compute x <- x + -- compute x <- y + -- x, x, x + (reg_x, format_x, code_x) <- getSomeReg x + (op_y, format_y, code_y) <- case y of + CmmLit (CmmInt n w) + | Just imm_operand_y <- encode_imm n w + -> return (imm_operand_y, intFormat w, nilOL) + _ -> do + (reg_y, format_y, code_y) <- getSomeReg y + return (OpReg w reg_y, format_y, code_y) + massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int" + -- This is the width of the registers on which the operation + -- should be performed. + let w' = opRegWidth w + return $ Any (intFormat w) $ \dst -> + code_x `appOL` + code_y `appOL` + op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL` + truncateReg w' w dst -- truncate back to the operand's original width + + -- A (potentially signed) integer operation. + -- In the case of 8- and 16-bit signed arithmetic we must first + -- sign-extend both arguments to 32-bits. + -- See Note [Signed arithmetic on AArch64]. + intOp is_signed w op = do + -- compute x <- x + -- compute x <- y + -- x, x, x + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int" + -- This is the width of the registers on which the operation + -- should be performed. + let w' = opRegWidth w + signExt r + | not is_signed = return (r, nilOL) + | otherwise = signExtendReg w w' r + (reg_x_sx, code_x_sx) <- signExt reg_x + (reg_y_sx, code_y_sx) <- signExt reg_y + return $ Any (intFormat w) $ \dst -> + code_x `appOL` + code_y `appOL` + -- sign-extend both operands + code_x_sx `appOL` + code_y_sx `appOL` + op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL` + truncateReg w' w dst -- truncate back to the operand's original width + + floatOp w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float" + return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)) + + -- need a special one for conditionals, as they return ints + floatCond w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float" + return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)) + + case op of + -- Integer operations + -- Add/Sub should only be Integer Options. + MO_Add w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (ADD d x y)) getArithImm + -- TODO: Handle sub-word case + MO_Sub w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (SUB d x y)) getArithImm + + -- Note [CSET] + -- ~~~~~~~~~~~ + -- Setting conditional flags: the architecture internally knows the + -- following flag bits. And based on thsoe comparisons as in the + -- table below. + -- + -- 31 30 29 28 + -- .---+---+---+---+-- - - + -- | N | Z | C | V | + -- '---+---+---+---+-- - - + -- Negative + -- Zero + -- Carry + -- oVerflow + -- + -- .------+-------------------------------------+-----------------+----------. + -- | Code | Meaning | Flags | Encoding | + -- |------+-------------------------------------+-----------------+----------| + -- | EQ | Equal | Z = 1 | 0000 | + -- | NE | Not Equal | Z = 0 | 0001 | + -- | HI | Unsigned Higher | C = 1 && Z = 0 | 1000 | + -- | HS | Unsigned Higher or Same | C = 1 | 0010 | + -- | LS | Unsigned Lower or Same | C = 0 || Z = 1 | 1001 | + -- | LO | Unsigned Lower | C = 0 | 0011 | + -- | GT | Signed Greater Than | Z = 0 && N = V | 1100 | + -- | GE | Signed Greater Than or Equal | N = V | 1010 | + -- | LE | Signed Less Than or Equal | Z = 1 || N /= V | 1101 | + -- | LT | Signed Less Than | N /= V | 1011 | + -- | CS | Carry Set (Unsigned Overflow) | C = 1 | 0010 | + -- | CC | Carry Clear (No Unsigned Overflow) | C = 0 | 0011 | + -- | VS | Signed Overflow | V = 1 | 0110 | + -- | VC | No Signed Overflow | V = 0 | 0111 | + -- | MI | Minus, Negative | N = 1 | 0100 | + -- | PL | Plus, Positive or Zero (!) | N = 0 | 0101 | + -- | AL | Always | Any | 1110 | + -- | NV | Never | Any | 1111 | + --- '-------------------------------------------------------------------------' + + -- N.B. We needn't sign-extend sub-word size (in)equality comparisons + -- since we don't care about ordering. + MO_Eq w -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d EQ ]) getArithImm + MO_Ne w -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d NE ]) getArithImm + + -- Signed multiply/divide + MO_Mul w -> intOp True w (\d x y -> unitOL $ MUL d x y) + MO_S_MulMayOflo w -> do_mul_may_oflo w x y + MO_S_Quot w -> intOp True w (\d x y -> unitOL $ SDIV d x y) + + -- No native rem instruction. So we'll compute the following + -- Rd <- Rx / Ry | 2 <- 7 / 3 -- SDIV Rd Rx Ry + -- Rd' <- Rx - Rd * Ry | 1 <- 7 - 2 * 3 -- MSUB Rd' Rd Ry Rx + -- | '---|----------------|---' | + -- | '----------------|-------' + -- '--------------------------' + -- Note the swap in Rx and Ry. + MO_S_Rem w -> withTempIntReg w $ \t -> + intOp True w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ]) + + -- Unsigned multiply/divide + MO_U_Quot w -> intOp False w (\d x y -> unitOL $ UDIV d x y) + MO_U_Rem w -> withTempIntReg w $ \t -> + intOp False w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ]) + + -- Signed comparisons -- see Note [CSET] + MO_S_Ge w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGE ]) + MO_S_Le w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLE ]) + MO_S_Gt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGT ]) + MO_S_Lt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLT ]) + + -- Unsigned comparisons + MO_U_Ge w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm + MO_U_Le w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm + MO_U_Gt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm + MO_U_Lt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm + + -- Floating point arithmetic + MO_F_Add w -> floatOp w (\d x y -> unitOL $ ADD d x y) + MO_F_Sub w -> floatOp w (\d x y -> unitOL $ SUB d x y) + MO_F_Mul w -> floatOp w (\d x y -> unitOL $ MUL d x y) + MO_F_Quot w -> floatOp w (\d x y -> unitOL $ SDIV d x y) + MO_F_Min w -> floatOp w (\d x y -> unitOL $ FMIN d x y) + MO_F_Max w -> floatOp w (\d x y -> unitOL $ FMAX d x y) + + -- Floating point comparison + MO_F_Eq w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d EQ ]) + MO_F_Ne w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d NE ]) + + -- careful with the floating point operations. + -- SLE is effectively LE or unordered (NaN) + -- SLT is the same. ULE, and ULT will not return true for NaN. + -- This is a bit counter-intuitive. Don't let yourself be fooled by + -- the S/U prefix for floats, it's only meaningful for integers. + MO_F_Ge w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGE ]) + MO_F_Le w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLE ]) -- x <= y <=> y > x + MO_F_Gt w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGT ]) + MO_F_Lt w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLT ]) -- x < y <=> y >= x + + -- Bitwise operations + MO_And w -> bitOpImm w (\d x y -> unitOL $ AND d x y) getBitmaskImm + MO_Or w -> bitOpImm w (\d x y -> unitOL $ ORR d x y) getBitmaskImm + MO_Xor w -> bitOpImm w (\d x y -> unitOL $ EOR d x y) getBitmaskImm + MO_Shl w -> intOp False w (\d x y -> unitOL $ LSL d x y) + MO_U_Shr w -> intOp False w (\d x y -> unitOL $ LSR d x y) + MO_S_Shr w -> intOp True w (\d x y -> unitOL $ ASR d x y) + + -- Non-dyadic MachOp with 2 arguments + MO_S_Neg {} -> notDyadic + MO_F_Neg {} -> notDyadic + MO_FMA {} -> notDyadic + MO_Not {} -> notDyadic + MO_SF_Round {} -> notDyadic + MO_FS_Truncate {} -> notDyadic + MO_SS_Conv {} -> notDyadic + MO_UU_Conv {} -> notDyadic + MO_XX_Conv {} -> notDyadic + MO_FF_Conv {} -> notDyadic + MO_WF_Bitcast {} -> notDyadic + MO_FW_Bitcast {} -> notDyadic + MO_V_Broadcast {} -> notDyadic + MO_VF_Broadcast {} -> notDyadic + MO_V_Insert {} -> notDyadic + MO_VF_Insert {} -> notDyadic + MO_AlignmentCheck {} -> notDyadic + MO_RelaxedRead {} -> notDyadic + + -- Vector operations: currently unsupported in the AArch64 NCG. + MO_V_Extract {} -> vectorsNeedLlvm + MO_V_Add {} -> vectorsNeedLlvm + MO_V_Sub {} -> vectorsNeedLlvm + MO_V_Mul {} -> vectorsNeedLlvm + MO_VS_Neg {} -> vectorsNeedLlvm + MO_VF_Extract {} -> vectorsNeedLlvm + MO_VF_Add {} -> vectorsNeedLlvm + MO_VF_Sub {} -> vectorsNeedLlvm + MO_VF_Neg {} -> vectorsNeedLlvm + MO_VF_Mul {} -> vectorsNeedLlvm + MO_VF_Quot {} -> vectorsNeedLlvm + MO_V_Shuffle {} -> vectorsNeedLlvm + MO_VF_Shuffle {} -> vectorsNeedLlvm + MO_VU_Min {} -> vectorsNeedLlvm + MO_VU_Max {} -> vectorsNeedLlvm + MO_VS_Min {} -> vectorsNeedLlvm + MO_VS_Max {} -> vectorsNeedLlvm + MO_VF_Min {} -> vectorsNeedLlvm + MO_VF_Max {} -> vectorsNeedLlvm + where + notDyadic = + pprPanic "getRegister' (non-dyadic CmmMachOp with 2 arguments): " $ + (pprMachOp op) <+> text "in" <+> (pdoc plat expr) + vectorsNeedLlvm = + sorry "SIMD operations on AArch64 currently require the LLVM backend" + + -- Generic ternary case. + CmmMachOp op [x, y, z] -> + + case op of + + -- Floating-point fused multiply-add operations + + -- x86 fmadd x * y + z <=> AArch64 fmadd : d = r1 * r2 + r3 + -- x86 fmsub x * y - z <=> AArch64 fnmsub: d = r1 * r2 - r3 + -- x86 fnmadd - x * y + z <=> AArch64 fmsub : d = - r1 * r2 + r3 + -- x86 fnmsub - x * y - z <=> AArch64 fnmadd: d = - r1 * r2 - r3 + + MO_FMA var l w + | l == 1 + -> case var of + FMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMAdd d n m a) + FMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMSub d n m a) + FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMSub d n m a) + FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a) + | otherwise + -> vectorsNeedLlvm + + MO_V_Insert {} -> vectorsNeedLlvm + MO_VF_Insert {} -> vectorsNeedLlvm + + _ -> pprPanic "getRegister' (unhandled ternary CmmMachOp): " $ + (pprMachOp op) <+> text "in" <+> (pdoc plat expr) + + where + vectorsNeedLlvm = + sorry "SIMD operations on AArch64 currently require the LLVM backend" + float3Op w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + (reg_fz, format_z, code_fz) <- getFloatReg z + massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z) $ + text "float3Op: non-float" + return $ + Any (floatFormat w) $ \ dst -> + code_fx `appOL` + code_fy `appOL` + code_fz `appOL` + op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz) + + CmmMachOp _op _xs + -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr) + + where + isNbitEncodeable :: Int -> Integer -> Bool + isNbitEncodeable n_bits i = let shift = n_bits - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift) + + -- N.B. MUL does not set the overflow flag. + -- These implementations are based on output from GCC 11. + do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register + do_mul_may_oflo w@W64 x y = do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + lo <- getNewRegNat II64 + hi <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y) `snocOL` + SMULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y) `snocOL` + CMP (OpReg w hi) (OpRegShift w lo SASR 63) `snocOL` + CSET (OpReg w dst) NE) + + do_mul_may_oflo W32 x y = do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + tmp1 <- getNewRegNat II64 + tmp2 <- getNewRegNat II64 + return $ Any (intFormat W32) (\dst -> + code_x `appOL` + code_y `snocOL` + SMULL (OpReg W64 tmp1) (OpReg W32 reg_x) (OpReg W32 reg_y) `snocOL` + ASR (OpReg W64 tmp2) (OpReg W64 tmp1) (OpImm (ImmInt 31)) `snocOL` + CMP (OpReg W32 tmp2) (OpRegShift W32 tmp1 SASR 31) `snocOL` + CSET (OpReg W32 dst) NE) + + do_mul_may_oflo w x y = do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + tmp1 <- getNewRegNat II32 + tmp2 <- getNewRegNat II32 + let extend dst arg = + case w of + W16 -> SXTH (OpReg W32 dst) (OpReg W32 arg) + W8 -> SXTB (OpReg W32 dst) (OpReg W32 arg) + _ -> panic "unreachable" + cmp_ext_mode = + case w of + W16 -> EUXTH + W8 -> EUXTB + _ -> panic "unreachable" + width = widthInBits w + opInt = OpImm . ImmInt + + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + extend tmp1 reg_x `snocOL` + extend tmp2 reg_y `snocOL` + MUL (OpReg W32 tmp1) (OpReg W32 tmp1) (OpReg W32 tmp2) `snocOL` + SBFX (OpReg W64 tmp2) (OpReg W64 tmp1) (opInt $ width - 1) (opInt 1) `snocOL` + UBFX (OpReg W32 tmp1) (OpReg W32 tmp1) (opInt width) (opInt width) `snocOL` + CMP (OpReg W32 tmp1) (OpRegExt W32 tmp2 cmp_ext_mode 0) `snocOL` + CSET (OpReg w dst) NE) + +-- | Is a given number encodable as a bitmask immediate? +-- +-- https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly +isAArch64Bitmask :: Width -> Integer -> Bool +-- N.B. zero and ~0 are not encodable as bitmask immediates +isAArch64Bitmask width n = + assert (width `elem` [W32,W64]) $ + case n of + 0 -> False + _ | n == bit (widthInBits width) - 1 + -> False -- 1111...1111 + | otherwise + -> (width == W64 && check 64) || check 32 || check 16 || check 8 + where + -- Check whether @n@ can be represented as a subpattern of the given + -- width. + check width + | hasOneRun subpat = + let n' = fromIntegral (mkPat width subpat) + in n == n' + | otherwise = False + where + subpat :: Word64 + subpat = fromIntegral (n .&. (bit width - 1)) + + -- Construct a bit-pattern from a repeated subpatterns the given width. + mkPat :: Int -> Word64 -> Word64 + mkPat width subpat = + foldl' (.|.) 0 [ subpat `shiftL` p | p <- [0, width..63] ] + + -- Does the given number's bit representation match the regular expression + -- @0*1*0*@? + hasOneRun :: Word64 -> Bool + hasOneRun m = + 64 == popCount m + countLeadingZeros m + countTrailingZeros m + +-- | Instructions to sign-extend the value in the given register from width @w@ +-- up to width @w'@. +signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr) +signExtendReg w w' r = + case w of + W64 -> noop + W32 + | w' == W32 -> noop + | otherwise -> extend SXTH + W16 -> extend SXTH + W8 -> extend SXTB + _ -> panic "intOp" + where + noop = return (r, nilOL) + extend instr = do + r' <- getNewRegNat II64 + return (r', unitOL $ instr (OpReg w' r') (OpReg w' r)) + +-- | Instructions to truncate the value in the given register from width @w@ +-- down to width @w'@. +truncateReg :: Width -> Width -> Reg -> OrdList Instr +truncateReg w w' r = + case w of + W64 -> nilOL + W32 + | w' == W32 -> nilOL + _ -> unitOL $ UBFM (OpReg w r) + (OpReg w r) + (OpImm (ImmInt 0)) + (OpImm $ ImmInt $ widthInBits w' - 1) + +-- ----------------------------------------------------------------------------- +-- The 'Amode' type: Memory addressing modes passed up the tree. +data Amode = Amode AddrMode InstrBlock + +getAmode :: Platform + -> Width -- ^ width of loaded value + -> CmmExpr + -> NatM Amode +-- TODO: Specialize stuff we can destructure here. + +-- OPTIMIZATION WARNING: Addressing modes. +-- Addressing options: +getAmode platform w (CmmRegOff reg off) + | isOffsetImm off w + = return $ Amode (AddrRegImm reg' off') nilOL + where reg' = getRegisterReg platform reg + off' = ImmInt off + +-- For Stores we often see something like this: +-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2) +-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ] +-- for `n` in range. +getAmode _platform w (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')]) + | isOffsetImm (fromIntegral off) w + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrRegImm reg (ImmInteger off)) code + +getAmode _platform w (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')]) + | isOffsetImm (fromIntegral $ -off) w + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrRegImm reg (ImmInteger $ -off)) code + +-- Generic case +getAmode _platform _ expr + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrReg reg) code + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_IntCode rep addrE srcE + = do + (src_reg, _format, code) <- getSomeReg srcE + platform <- getPlatform + let w = formatToWidth rep + Amode addr addr_code <- getAmode platform w addrE + return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE))) + `consOL` (code + `appOL` addr_code + `snocOL` STR rep (OpReg w src_reg) (OpAddr addr)) + +assignReg_IntCode _ reg src + = do + platform <- getPlatform + let dst = getRegisterReg platform reg + r <- getRegister src + return $ case r of + Any _ code -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` code dst + Fixed format freg fcode -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` (fcode `snocOL` MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg)) + +-- Let's treat Floating point stuff +-- as integer code for now. Opaque. +assignMem_FltCode = assignMem_IntCode +assignReg_FltCode = assignReg_IntCode + +-- ----------------------------------------------------------------------------- +-- Jumps + +genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock +genJump expr@(CmmLit (CmmLabel lbl)) = do + cur_mod <- getThisModuleNat + !useFarJumps <- ncgEnableInterModuleFarJumps <$> getConfig + let is_local = isLocalCLabel cur_mod lbl + + -- We prefer to generate a near jump using a simble `B` instruction + -- with a range (+/-128MB). But if the target is outside the current module + -- we might have to account for large code offsets. (#24648) + if not useFarJumps || is_local + then return $ unitOL (annExpr expr (J (TLabel lbl))) + else do + (target, _format, code) <- getSomeReg expr + return (code `appOL` unitOL (annExpr expr (J (TReg target)))) + +genJump expr = do + (target, _format, code) <- getSomeReg expr + return (code `appOL` unitOL (annExpr expr (J (TReg target)))) + +-- ----------------------------------------------------------------------------- +-- Unconditional branches +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + +-- ----------------------------------------------------------------------------- +-- Conditional branches +genCondJump + :: BlockId + -> CmmExpr + -> NatM InstrBlock +genCondJump bid expr = do + case expr of + -- Optimized == 0 case. + CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ code_x `snocOL` (annExpr expr (CBZ (OpReg w reg_x) (TBlock bid))) + + -- Optimized /= 0 case. + CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ code_x `snocOL` (annExpr expr (CBNZ (OpReg w reg_x) (TBlock bid))) + + -- Generic case. + CmmMachOp mop [x, y] -> do + + let ubcond w cmp = do + -- compute both sides. + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + let x' = OpReg w reg_x + y' = OpReg w reg_y + return $ case w of + W8 -> code_x `appOL` code_y `appOL` toOL [ UXTB x' x', UXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + W16 -> code_x `appOL` code_y `appOL` toOL [ UXTH x' x', UXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + + sbcond w cmp = do + -- compute both sides. + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + let x' = OpReg w reg_x + y' = OpReg w reg_y + return $ case w of + W8 -> code_x `appOL` code_y `appOL` toOL [ SXTB x' x', SXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + W16 -> code_x `appOL` code_y `appOL` toOL [ SXTH x' x', SXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + + fbcond w cmp = do + -- ensure we get float regs + (reg_fx, _format_fx, code_fx) <- getFloatReg x + (reg_fy, _format_fy, code_fy) <- getFloatReg y + return $ code_fx `appOL` code_fy `snocOL` CMP (OpReg w reg_fx) (OpReg w reg_fy) `snocOL` (annExpr expr (BCOND cmp (TBlock bid))) + + case mop of + MO_F_Eq w -> fbcond w EQ + MO_F_Ne w -> fbcond w NE + + MO_F_Gt w -> fbcond w OGT + MO_F_Ge w -> fbcond w OGE + MO_F_Lt w -> fbcond w OLT + MO_F_Le w -> fbcond w OLE + + MO_Eq w -> sbcond w EQ + MO_Ne w -> sbcond w NE + + MO_S_Gt w -> sbcond w SGT + MO_S_Ge w -> sbcond w SGE + MO_S_Lt w -> sbcond w SLT + MO_S_Le w -> sbcond w SLE + MO_U_Gt w -> ubcond w UGT + MO_U_Ge w -> ubcond w UGE + MO_U_Lt w -> ubcond w ULT + MO_U_Le w -> ubcond w ULE + _ -> pprPanic "AArch64.genCondJump:case mop: " (text $ show expr) + _ -> pprPanic "AArch64.genCondJump: " (text $ show expr) + +-- A conditional jump with at least +/-128M jump range +genCondFarJump :: MonadGetUnique m => Cond -> Target -> m InstrBlock +genCondFarJump cond far_target = do + skip_lbl_id <- newBlockId + jmp_lbl_id <- newBlockId + + -- TODO: We can improve this by inverting the condition + -- but it's not quite trivial since we don't know if we + -- need to consider float orderings. + -- So we take the hit of the additional jump in the false + -- case for now. + return $ toOL [ BCOND cond (TBlock jmp_lbl_id) + , B (TBlock skip_lbl_id) + , NEWBLOCK jmp_lbl_id + , B far_target + , NEWBLOCK skip_lbl_id] + +genCondBranch :: BlockId -- the true branch target + -> BlockId -- the false branch target + -> CmmExpr -- the condition on which to branch + -> NatM InstrBlock -- Instructions + +genCondBranch true false expr = do + b1 <- genCondJump true expr + b2 <- genBranch false + return (b1 `appOL` b2) + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +-- Now the biggest nightmare---calls. Most of the nastiness is buried in +-- @get_arg@, which moves the arguments to the correct registers/stack +-- locations. Apart from that, the code is easy. +-- +-- As per *convention*: +-- x0-x7: (volatile) argument registers +-- x8: (volatile) indirect result register / Linux syscall no +-- x9-x15: (volatile) caller saved regs +-- x16,x17: (volatile) intra-procedure-call registers +-- x18: (volatile) platform register. don't use for portability +-- x19-x28: (non-volatile) callee save regs +-- x29: (non-volatile) frame pointer +-- x30: link register +-- x31: stack pointer / zero reg +-- +-- Thus, this is what a c function will expect. Find the arguments in x0-x7, +-- anything above that on the stack. We'll ignore c functions with more than +-- 8 arguments for now. Sorry. +-- +-- We need to make sure we preserve x9-x15, don't want to touch x16, x17. + +-- Note [PLT vs GOT relocations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When linking objects together, we may need to lookup foreign references. That +-- is symbolic references to functions or values in other objects. When +-- compiling the object, we can not know where those elements will end up in +-- memory (relative to the current location). Thus the use of symbols. There +-- are two types of items we are interested, code segments we want to jump to +-- and continue execution there (functions, ...), and data items we want to look +-- up (strings, numbers, ...). For functions we can use the fact that we can use +-- an intermediate jump without visibility to the programs execution. If we +-- want to jump to a function that is simply too far away to reach for the B/BL +-- instruction, we can create a small piece of code that loads the full target +-- address and jumps to that on demand. Say f wants to call g, however g is out +-- of range for a direct jump, we can create a function h in range for f, that +-- will load the address of g, and jump there. The area where we construct h +-- is called the Procedure Linking Table (PLT), we have essentially replaced +-- f -> g with f -> h -> g. This is fine for function calls. However if we +-- want to lookup values, this trick doesn't work, so we need something else. +-- We will instead reserve a slot in memory, and have a symbol pointing to that +-- slot. Now what we essentially do is, we reference that slot, and expect that +-- slot to hold the final resting address of the data we are interested in. +-- Thus what that symbol really points to is the location of the final data. +-- The block of memory where we hold all those slots is the Global Offset Table +-- (GOT). Instead of x <- $foo, we now do y <- $fooPtr, and x <- [$y]. +-- +-- For JUMP/CALLs we have 26bits (+/- 128MB), for conditional branches we only +-- have 19bits (+/- 1MB). Symbol lookups are also within +/- 1MB, thus for most +-- of the LOAD/STOREs we'd want to use adrp, and add to compute a value within +-- 4GB of the PC, and load that. For anything outside of that range, we'd have +-- to go through the GOT. +-- +-- adrp x0, +-- add x0, :lo: +-- +-- will compute the address of int x0 if is within 4GB of the +-- PC. +-- +-- If we want to get the slot in the global offset table (GOT), we can do this: +-- +-- adrp x0, #:got: +-- ldr x0, [x0, #:got_lo12:] +-- +-- this will compute the address anywhere in the addressable 64bit space into +-- x0, by loading the address from the GOT slot. +-- +-- To actually get the value of , we'd need to ldr x0, x0 still, which +-- for the first case can be optimized to use ldr x0, [x0, #:lo12:] +-- instead of the add instruction. +-- +-- As the memory model for AArch64 for PIC is considered to be +/- 4GB, we do +-- not need to go through the GOT, unless we want to address the full address +-- range within 64bit. + +genCCall + :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +-- TODO: Specialize where we can. +-- Generic impl +genCCall target dest_regs arg_regs = do + -- we want to pass arg_regs into allArgRegs + -- pprTraceM "genCCall target" (ppr target) + -- pprTraceM "genCCall formal" (ppr dest_regs) + -- pprTraceM "genCCall actual" (ppr arg_regs) + platform <- getPlatform + case target of + -- The target :: ForeignTarget call can either + -- be a foreign procedure with an address expr + -- and a calling convention. + ForeignTarget expr _cconv -> do + (call_target, call_target_code) <- case expr of + -- if this is a label, let's just directly to it. This will produce the + -- correct CALL relocation for BL... + (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL) + -- ... if it's not a label--well--let's compute the expression into a + -- register and jump to that. See Note [PLT vs GOT relocations] + _ -> do (reg, _format, reg_code) <- getSomeReg expr + pure (TReg reg, reg_code) + -- compute the code and register logic for all arg_regs. + -- this will give us the format information to match on. + arg_regs' <- mapM getSomeReg arg_regs + + -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes + -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in + -- STG; this thenn breaks packing of stack arguments, if we need to pack + -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type + -- in Cmm proper. Option two, which we choose here is to use extended Hint + -- information to contain the size information and use that when packing + -- arguments, spilled onto the stack. + let (_res_hints, arg_hints) = foreignTargetHints target + arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints + + let packStack = platformOS platform == OSDarwin + + (stackSpace', passRegs, passArgumentsCode) <- passArguments packStack allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL + + -- if we pack the stack, we may need to adjust to multiple of 8byte. + -- if we don't pack the stack, it will always be multiple of 8. + let stackSpace = if stackSpace' `mod` 8 /= 0 + then 8 * (stackSpace' `div` 8 + 1) + else stackSpace' + + readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL + + let moveStackDown 0 = toOL [ PUSH_STACK_FRAME + , DELTA (-16) ] + moveStackDown i | odd i = moveStackDown (i + 1) + moveStackDown i = toOL [ PUSH_STACK_FRAME + , SUB (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i))) + , DELTA (-8 * i - 16) ] + moveStackUp 0 = toOL [ POP_STACK_FRAME + , DELTA 0 ] + moveStackUp i | odd i = moveStackUp (i + 1) + moveStackUp i = toOL [ ADD (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i))) + , POP_STACK_FRAME + , DELTA 0 ] + + let code = call_target_code -- compute the label (possibly into a register) + `appOL` moveStackDown (stackSpace `div` 8) + `appOL` passArgumentsCode -- put the arguments into x0, ... + `appOL` (unitOL $ BL call_target passRegs) -- branch and link. + `appOL` readResultsCode -- parse the results into registers + `appOL` moveStackUp (stackSpace `div` 8) + return code + + PrimTarget MO_F32_Fabs + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F32_Fabs" + PrimTarget MO_F64_Fabs + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F64_Fabs" + PrimTarget MO_F32_Sqrt + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F32_Sqrt" + PrimTarget MO_F64_Sqrt + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F64_Sqrt" + + + PrimTarget (MO_S_Mul2 w) + -- Life is easier when we're working with word sized operands, + -- we can use SMULH to compute the high 64 bits, and dst_needed + -- checks if the high half's bits are all the same as the low half's + -- top bit. + | w == W64 + , [src_a, src_b] <- arg_regs + -- dst_needed = did the result fit into just the low half + , [dst_needed, dst_hi, dst_lo] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src_a + (reg_b, _format_y, code_y) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + nd = getRegisterReg platform (CmmLocal dst_needed) + return $ + code_x `appOL` + code_y `snocOL` + MUL (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL` + SMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL` + -- Are all high bits equal to the sign bit of the low word? + -- nd = (hi == ASR(lo,width-1)) ? 1 : 0 + CMP (OpReg W64 hi) (OpRegShift W64 lo SASR (widthInBits w - 1)) `snocOL` + CSET (OpReg W64 nd) NE + -- For sizes < platform width, we can just perform a multiply and shift + -- using the normal 64 bit multiply. Calculating the dst_needed value is + -- complicated a little by the need to be careful when truncation happens. + -- Currently this case can't be generated since + -- timesInt2# :: Int# -> Int# -> (# Int#, Int#, Int# #) + -- TODO: Should this be removed or would other primops be useful? + | w < W64 + , [src_a, src_b] <- arg_regs + , [dst_needed, dst_hi, dst_lo] <- dest_regs + -> do + (reg_a', _format_x, code_a) <- getSomeReg src_a + (reg_b', _format_y, code_b) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + nd = getRegisterReg platform (CmmLocal dst_needed) + -- Do everything in a full 64 bit registers + w' = platformWordWidth platform + + (reg_a, code_a') <- signExtendReg w w' reg_a' + (reg_b, code_b') <- signExtendReg w w' reg_b' + + return $ + code_a `appOL` + code_b `appOL` + code_a' `appOL` + code_b' `snocOL` + -- the low 2w' of lo contains the full multiplication; + -- eg: int8 * int8 -> int16 result + -- so lo is in the last w of the register, and hi is in the second w. + SMULL (OpReg w' lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL` + -- Make sure we hold onto the sign bits for dst_needed + ASR (OpReg w' hi) (OpReg w' lo) (OpImm (ImmInt $ widthInBits w)) `appOL` + -- lo can now be truncated so we can get at it's top bit easily. + truncateReg w' w lo `snocOL` + -- Note the use of CMN (compare negative), not CMP: we want to + -- test if the top half is negative one and the top + -- bit of the bottom half is positive one. eg: + -- hi = 0b1111_1111 (actually 64 bits) + -- lo = 0b1010_1111 (-81, so the result didn't need the top half) + -- lo' = ASR(lo,7) (second reg of SMN) + -- = 0b0000_0001 (theeshift gives us 1 for negative, + -- and 0 for positive) + -- hi == -lo'? + -- 0b1111_1111 == 0b1111_1111 (yes, top half is just overflow) + -- Another way to think of this is if hi + lo' == 0, which is what + -- CMN really is under the hood. + CMN (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL` + -- Set dst_needed to 1 if hi and lo' were (negatively) equal + CSET (OpReg w' nd) EQ `appOL` + -- Finally truncate hi to drop any extraneous sign bits. + truncateReg w' w hi + -- Can't handle > 64 bit operands + | otherwise -> unsupported (MO_S_Mul2 w) + PrimTarget (MO_U_Mul2 w) + -- The unsigned case is much simpler than the signed, all we need to + -- do is the multiplication straight into the destination registers. + | w == W64 + , [src_a, src_b] <- arg_regs + , [dst_hi, dst_lo] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src_a + (reg_b, _format_y, code_y) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + return ( + code_x `appOL` + code_y `snocOL` + MUL (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL` + UMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b) + ) + -- For sizes < platform width, we can just perform a multiply and shift + -- Need to be careful to truncate the low half, but the upper half should be + -- be ok if the invariant in [Signed arithmetic on AArch64] is maintained. + -- Currently this case can't be produced by the compiler since + -- timesWord2# :: Word# -> Word# -> (# Word#, Word# #) + -- TODO: Remove? Or would the extra primop be useful for avoiding the extra + -- steps needed to do this in userland? + | w < W64 + , [src_a, src_b] <- arg_regs + , [dst_hi, dst_lo] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src_a + (reg_b, _format_y, code_y) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + w' = opRegWidth w + return ( + code_x `appOL` + code_y `snocOL` + -- UMULL: Xd = Wa * Wb with 64 bit result + -- W64 inputs should have been caught by case above + UMULL (OpReg W64 lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL` + -- Extract and truncate high result + -- hi[w:0] = lo[2w:w] + UBFX (OpReg W64 hi) (OpReg W64 lo) + (OpImm (ImmInt $ widthInBits w)) -- lsb + (OpImm (ImmInt $ widthInBits w)) -- width to extract + `appOL` + truncateReg W64 w lo + ) + | otherwise -> unsupported (MO_U_Mul2 w) + PrimTarget (MO_Clz w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return ( + code_x `snocOL` + CLZ (OpReg w dst_reg) (OpReg w reg_a) + ) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(x << 16 | 0x0000_8000) -} + return ( + code_x `appOL` toOL + [ LSL (r dst') (r reg_a) (imm 16) + , ORR (r dst') (r dst') (imm 0x00008000) + , CLZ (r dst') (r dst') + ] + ) + | w == W8 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(x << 24 | 0x0080_0000) -} + return $ + code_x `appOL` toOL + [ LSL (r dst') (r reg_a) (imm 24) + , ORR (r dst') (r dst') (imm 0x00800000) + , CLZ (r dst') (r dst') + ] + | otherwise -> unsupported (MO_Clz w) + PrimTarget (MO_Ctz w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return $ + code_x `snocOL` + RBIT (OpReg w dst_reg) (OpReg w reg_a) `snocOL` + CLZ (OpReg w dst_reg) (OpReg w dst_reg) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(reverseBits(x) | 0x0000_8000) -} + return $ + code_x `appOL` toOL + [ RBIT (r dst') (r reg_a) + , ORR (r dst') (r dst') (imm 0x00008000) + , CLZ (r dst') (r dst') + ] + | w == W8 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(reverseBits(x) | 0x0080_0000) -} + return $ + code_x `appOL` toOL + [ RBIT (r dst') (r reg_a) + , ORR (r dst') (r dst') (imm 0x00800000) + , CLZ (r dst') (r dst') + ] + | otherwise -> unsupported (MO_Ctz w) + PrimTarget (MO_BRev w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return $ + code_x `snocOL` + RBIT (OpReg w dst_reg) (OpReg w reg_a) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = reverseBits32(x << 16) -} + return $ + code_x `appOL` toOL + [ LSL (r dst') (r reg_a) (imm 16) + , RBIT (r dst') (r dst') + ] + | w == W8 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = reverseBits32(x << 24) -} + return $ + code_x `appOL` toOL + [ LSL (r dst') (r reg_a) (imm 24) + , RBIT (r dst') (r dst') + ] + | otherwise -> unsupported (MO_BRev w) + PrimTarget (MO_BSwap w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return $ code_x `snocOL` REV (OpReg w dst_reg) (OpReg w reg_a) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + -- Swaps the bytes in each 16bit word + -- TODO: Expose the 32 & 64 bit version of this? + return $ code_x `snocOL` REV16 (r dst') (r reg_a) + | otherwise -> unsupported (MO_BSwap w) + + -- or a possibly side-effecting machine operation + -- mop :: CallishMachOp (see GHC.Cmm.MachOp) + PrimTarget mop -> do + -- We'll need config to construct forien targets + case mop of + -- 64 bit float ops + MO_F64_Pwr -> mkCCall "pow" + + MO_F64_Sin -> mkCCall "sin" + MO_F64_Cos -> mkCCall "cos" + MO_F64_Tan -> mkCCall "tan" + + MO_F64_Sinh -> mkCCall "sinh" + MO_F64_Cosh -> mkCCall "cosh" + MO_F64_Tanh -> mkCCall "tanh" + + MO_F64_Asin -> mkCCall "asin" + MO_F64_Acos -> mkCCall "acos" + MO_F64_Atan -> mkCCall "atan" + + MO_F64_Asinh -> mkCCall "asinh" + MO_F64_Acosh -> mkCCall "acosh" + MO_F64_Atanh -> mkCCall "atanh" + + MO_F64_Log -> mkCCall "log" + MO_F64_Log1P -> mkCCall "log1p" + MO_F64_Exp -> mkCCall "exp" + MO_F64_ExpM1 -> mkCCall "expm1" + + -- 32 bit float ops + MO_F32_Pwr -> mkCCall "powf" + + MO_F32_Sin -> mkCCall "sinf" + MO_F32_Cos -> mkCCall "cosf" + MO_F32_Tan -> mkCCall "tanf" + MO_F32_Sinh -> mkCCall "sinhf" + MO_F32_Cosh -> mkCCall "coshf" + MO_F32_Tanh -> mkCCall "tanhf" + MO_F32_Asin -> mkCCall "asinf" + MO_F32_Acos -> mkCCall "acosf" + MO_F32_Atan -> mkCCall "atanf" + MO_F32_Asinh -> mkCCall "asinhf" + MO_F32_Acosh -> mkCCall "acoshf" + MO_F32_Atanh -> mkCCall "atanhf" + MO_F32_Log -> mkCCall "logf" + MO_F32_Log1P -> mkCCall "log1pf" + MO_F32_Exp -> mkCCall "expf" + MO_F32_ExpM1 -> mkCCall "expm1f" + + -- 64-bit primops + MO_I64_ToI -> mkCCall "hs_int64ToInt" + MO_I64_FromI -> mkCCall "hs_intToInt64" + MO_W64_ToW -> mkCCall "hs_word64ToWord" + MO_W64_FromW -> mkCCall "hs_wordToWord64" + MO_x64_Neg -> mkCCall "hs_neg64" + MO_x64_Add -> mkCCall "hs_add64" + MO_x64_Sub -> mkCCall "hs_sub64" + MO_x64_Mul -> mkCCall "hs_mul64" + MO_I64_Quot -> mkCCall "hs_quotInt64" + MO_I64_Rem -> mkCCall "hs_remInt64" + MO_W64_Quot -> mkCCall "hs_quotWord64" + MO_W64_Rem -> mkCCall "hs_remWord64" + MO_x64_And -> mkCCall "hs_and64" + MO_x64_Or -> mkCCall "hs_or64" + MO_x64_Xor -> mkCCall "hs_xor64" + MO_x64_Not -> mkCCall "hs_not64" + MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64" + MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64" + MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64" + MO_x64_Eq -> mkCCall "hs_eq64" + MO_x64_Ne -> mkCCall "hs_ne64" + MO_I64_Ge -> mkCCall "hs_geInt64" + MO_I64_Gt -> mkCCall "hs_gtInt64" + MO_I64_Le -> mkCCall "hs_leInt64" + MO_I64_Lt -> mkCCall "hs_ltInt64" + MO_W64_Ge -> mkCCall "hs_geWord64" + MO_W64_Gt -> mkCCall "hs_gtWord64" + MO_W64_Le -> mkCCall "hs_leWord64" + MO_W64_Lt -> mkCCall "hs_ltWord64" + + -- Conversion + MO_UF_Conv w -> mkCCall (word2FloatLabel w) + + -- Arithmetic + -- These are not supported on X86, so I doubt they are used much. + MO_S_QuotRem _w -> unsupported mop + MO_U_QuotRem _w -> unsupported mop + MO_U_QuotRem2 _w -> unsupported mop + MO_Add2 _w -> unsupported mop + MO_AddWordC _w -> unsupported mop + MO_SubWordC _w -> unsupported mop + MO_AddIntC _w -> unsupported mop + MO_SubIntC _w -> unsupported mop + + -- Vector + MO_VS_Quot {} -> unsupported mop + MO_VS_Rem {} -> unsupported mop + MO_VU_Quot {} -> unsupported mop + MO_VU_Rem {} -> unsupported mop + MO_I64X2_Min -> unsupported mop + MO_I64X2_Max -> unsupported mop + MO_W64X2_Min -> unsupported mop + MO_W64X2_Max -> unsupported mop + + -- Memory Ordering + -- Set flags according to their C pendants (stdatomic.h): + -- atomic_thread_fence(memory_order_acquire); // -> dmb ishld + MO_AcquireFence -> return . unitOL $ DMBISH DmbLoad + -- atomic_thread_fence(memory_order_release); // -> dmb ish + MO_ReleaseFence -> return . unitOL $ DMBISH DmbLoadStore + -- atomic_thread_fence(memory_order_seq_cst); // -> dmb ish + MO_SeqCstFence -> return . unitOL $ DMBISH DmbLoadStore + MO_Touch -> return nilOL -- Keep variables live (when using interior pointers) + -- Prefetch + MO_Prefetch_Data _n -> return nilOL -- Prefetch hint. + + -- Memory copy/set/move/cmp, with alignment for optimization + + -- TODO Optimize and use e.g. quad registers to move memory around instead + -- of offloading this to memcpy. For small memcpys we can utilize + -- the 128bit quad registers in NEON to move block of bytes around. + -- Might also make sense of small memsets? Use xzr? What's the function + -- call overhead? + MO_Memcpy _align -> mkCCall "memcpy" + MO_Memset _align -> mkCCall "memset" + MO_Memmove _align -> mkCCall "memmove" + MO_Memcmp _align -> mkCCall "memcmp" + + MO_SuspendThread -> mkCCall "suspendThread" + MO_ResumeThread -> mkCCall "resumeThread" + + MO_PopCnt w -> mkCCall (popCntLabel w) + MO_Pdep w -> mkCCall (pdepLabel w) + MO_Pext w -> mkCCall (pextLabel w) + + -- -- Atomic read-modify-write. + MO_AtomicRead w ord + | [p_reg] <- arg_regs + , [dst_reg] <- dest_regs -> do + (p, _fmt_p, code_p) <- getSomeReg p_reg + platform <- getPlatform + let instr = case ord of + MemOrderRelaxed -> LDR + _ -> LDAR + dst = getRegisterReg platform (CmmLocal dst_reg) + code = + code_p `snocOL` + instr (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p) + return code + | otherwise -> panic "mal-formed AtomicRead" + MO_AtomicWrite w ord + | [p_reg, val_reg] <- arg_regs -> do + (p, _fmt_p, code_p) <- getSomeReg p_reg + (val, fmt_val, code_val) <- getSomeReg val_reg + let instr = case ord of + MemOrderRelaxed -> STR + _ -> STLR + code = + code_p `appOL` + code_val `snocOL` + instr fmt_val (OpReg w val) (OpAddr $ AddrReg p) + return code + | otherwise -> panic "mal-formed AtomicWrite" + MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop) + MO_Cmpxchg w -> mkCCall (cmpxchgLabel w) + -- -- Should be an AtomicRMW variant eventually. + -- -- Sequential consistent. + -- TODO: this should be implemented properly! + MO_Xchg w -> mkCCall (xchgLabel w) + + where + unsupported :: Show a => a -> b + unsupported mop = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + mkCCall :: FastString -> NatM InstrBlock + mkCCall name = do + config <- getConfig + target <- cmmMakeDynamicReference config CallReference $ + mkForeignLabel name ForeignLabelInThisPackage IsFunction + let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn + genCCall (ForeignTarget target cconv) dest_regs arg_regs + + -- TODO: Optimize using paired stores and loads (STP, LDP). It is + -- automatically done by the allocator for us. However it's not optimal, + -- as we'd rather want to have control over + -- all spill/load registers, so we can optimize with instructions like + -- STP xA, xB, [sp, #-16]! + -- and + -- LDP xA, xB, sp, #16 + -- + passArguments :: Bool -> [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock) + passArguments _packStack _ _ [] stackSpace accumRegs accumCode = return (stackSpace, accumRegs, accumCode) + -- passArguments _ _ [] accumCode stackSpace | isEven stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * stackSpace)) + -- passArguments _ _ [] accumCode stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * (stackSpace + 1))) + -- passArguments [] fpRegs (arg0:arg1:args) stack accumCode = do + -- -- allocate this on the stack + -- (r0, format0, code_r0) <- getSomeReg arg0 + -- (r1, format1, code_r1) <- getSomeReg arg1 + -- let w0 = formatToWidth format0 + -- w1 = formatToWidth format1 + -- stackCode = unitOL $ STP (OpReg w0 r0) (OpReg w1 R1), (OpAddr (AddrRegImm x31 (ImmInt (stackSpace * 8))) + -- passArguments gpRegs (fpReg:fpRegs) args (stackCode `appOL` accumCode) + + -- float promotion. + -- According to + -- ISO/IEC 9899:2018 + -- Information technology — Programming languages — C + -- + -- e.g. + -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf + -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1256.pdf + -- + -- GHC would need to know the prototype. + -- + -- > If the expression that denotes the called function has a type that does not include a + -- > prototype, the integer promotions are performed on each argument, and arguments that + -- > have type float are promoted to double. + -- + -- As we have no way to get prototypes for C yet, we'll *not* promote this + -- which is in line with the x86_64 backend :( + -- + -- See the encode_values.cmm test. + -- + -- We would essentially need to insert an FCVT (OpReg W64 fpReg) (OpReg W32 fpReg) + -- if w == W32. But *only* if we don't have a prototype m( + -- + -- For AArch64 specificies see: https://developer.arm.com/docs/ihi0055/latest/procedure-call-standard-for-the-arm-64-bit-architecture + -- + -- Still have GP regs, and we want to pass an GP argument. + + -- AArch64-Darwin: stack packing and alignment + -- + -- According to the "Writing ARM64 Code for Apple Platforms" document form + -- Apple, specifically the section "Handle Data Types and Data Alignment Properly" + -- we need to not only pack, but also align arguments on the stack. + -- + -- Data type Size (in bytes) Natural alignment (in bytes) + -- BOOL, bool 1 1 + -- char 1 1 + -- short 2 2 + -- int 4 4 + -- long 8 8 + -- long long 8 8 + -- pointer 8 8 + -- size_t 8 8 + -- NSInteger 8 8 + -- CFIndex 8 8 + -- fpos_t 8 8 + -- off_t 8 8 + -- + -- We can see that types are aligned by their sizes so the easiest way to + -- guarantee alignment during packing seems to be to pad to a multiple of the + -- size we want to pack. Failure to get this right can result in pretty + -- subtle bugs, e.g. #20137. + + passArguments pack (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do + platform <- getPlatform + let w = formatToWidth format + mov + -- Specifically, Darwin/AArch64's ABI requires that the caller + -- sign-extend arguments which are smaller than 32-bits. + | w < W32 + , platformCConvNeedsExtension platform + , SignedHint <- hint + = case w of + W8 -> SXTB (OpReg W64 gpReg) (OpReg w r) + W16 -> SXTH (OpReg W64 gpReg) (OpReg w r) + _ -> panic "impossible" + | otherwise + = MOV (OpReg w gpReg) (OpReg w r) + accumCode' = accumCode `appOL` + code_r `snocOL` + ann (text "Pass gp argument: " <> ppr r) mov + passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode' + + -- Still have FP regs, and we want to pass an FP argument. + passArguments pack gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do + let w = formatToWidth format + mov = MOV (OpReg w fpReg) (OpReg w r) + accumCode' = accumCode `appOL` + code_r `snocOL` + ann (text "Pass fp argument: " <> ppr r) mov + passArguments pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) accumCode' + + -- No mor regs left to pass. Must pass on stack. + passArguments pack [] [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode = do + let w = formatToWidth format + bytes = widthInBits w `div` 8 + space = if pack then bytes else 8 + stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) + | otherwise = stackSpace + str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))) + stackCode = code_r `snocOL` + ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str + passArguments pack [] [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode) + + -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then. + passArguments pack [] fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do + let w = formatToWidth format + bytes = widthInBits w `div` 8 + space = if pack then bytes else 8 + stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) + | otherwise = stackSpace + str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))) + stackCode = code_r `snocOL` + ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str + passArguments pack [] fpRegs args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode) + + -- Still have gpRegs left, but want to pass a FP argument. Must be passed on the stack then. + passArguments pack gpRegs [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do + let w = formatToWidth format + bytes = widthInBits w `div` 8 + space = if pack then bytes else 8 + stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) + | otherwise = stackSpace + str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))) + stackCode = code_r `snocOL` + ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str + passArguments pack gpRegs [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode) + + passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") + + readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM (InstrBlock) + readResults _ _ [] _ accumCode = return accumCode + readResults [] _ _ _ _ = do + platform <- getPlatform + pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target) + readResults _ [] _ _ _ = do + platform <- getPlatform + pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target) + readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do + -- gp/fp reg -> dst + platform <- getPlatform + let rep = cmmRegType (CmmLocal dst) + format = cmmTypeFormat rep + w = cmmRegWidth (CmmLocal dst) + r_dst = getRegisterReg platform (CmmLocal dst) + if isFloatFormat format + then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg)) + else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg)) + + unaryFloatOp w op arg_reg dest_reg = do + platform <- getPlatform + (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg + let dst = getRegisterReg platform (CmmLocal dest_reg) + let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx) + return code + +{- Note [AArch64 far jumps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +AArch conditional jump instructions can only encode an offset of +/-1MB +which is usually enough but can be exceeded in edge cases. In these cases +we will replace: + + b.cond foo + +with the sequence: + + b.cond + b + : + b foo + : + +Note the encoding of the `b` instruction still limits jumps to ++/-128M offsets, but that seems like an acceptable limitation. + +Since AArch64 instructions are all of equal length we can reasonably estimate jumps +in range by counting the instructions between a jump and its target label. + +We make some simplifications in the name of performance which can result in overestimating +jump <-> label offsets: + +* To avoid having to recalculate the label offsets once we replaced a jump we simply + assume all jumps will be expanded to a three instruction far jump sequence. +* For labels associated with a info table we assume the info table is 64byte large. + Most info tables are smaller than that but it means we don't have to distinguish + between multiple types of info tables. + +In terms of implementation we walk the instruction stream at least once calculating +label offsets, and if we determine during this that the functions body is big enough +to potentially contain out of range jumps we walk the instructions a second time, replacing +out of range jumps with the sequence of instructions described above. + +-} + +-- See Note [AArch64 far jumps] +data BlockInRange = InRange | NotInRange Target + +-- See Note [AArch64 far jumps] +makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr] + -> UniqDSM [NatBasicBlock Instr] +makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do + -- All offsets/positions are counted in multiples of 4 bytes (the size of AArch64 instructions) + -- That is an offset of 1 represents a 4-byte/one instruction offset. + let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks + if func_size < max_jump_dist + then pure basic_blocks + else do + (_,blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks + pure $ concat blocks + -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks + + where + -- 2^18, 19 bit immediate with one bit is reserved for the sign + max_jump_dist = 2^(18::Int) - 1 :: Int + -- Currently all inline info tables fit into 64 bytes. + max_info_size = 16 :: Int + long_bc_jump_size = 3 :: Int + long_bz_jump_size = 4 :: Int + + -- Replace out of range conditional jumps with unconditional jumps. + replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr]) + replace_blk !m !pos (BasicBlock lbl instrs) = do + -- Account for a potential info table before the label. + let !block_pos = pos + infoTblSize_maybe lbl + (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs + let instrs'' = concat instrs' + -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary. + let (top, split_blocks, no_data) = foldr mkBlocks ([],[],[]) instrs'' + -- There should be no data in the instruction stream at this point + massert (null no_data) + + let final_blocks = BasicBlock lbl top : split_blocks + pure (pos', final_blocks) + + replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr]) + replace_jump !m !pos instr = do + case instr of + ANN ann instr -> do + replace_jump m pos instr >>= \case + (idx,instr':instrs') -> + pure (idx, ANN ann instr':instrs') + (idx,[]) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx) + BCOND cond t + -> case target_in_range m t pos of + InRange -> pure (pos+long_bc_jump_size,[instr]) + NotInRange far_target -> do + jmp_code <- genCondFarJump cond far_target + pure (pos+long_bc_jump_size, fromOL jmp_code) + CBZ op t -> long_zero_jump op t EQ + CBNZ op t -> long_zero_jump op t NE + instr + | isMetaInstr instr -> pure (pos,[instr]) + | otherwise -> pure (pos+1, [instr]) + + where + -- cmp_op: EQ = CBZ, NEQ = CBNZ + long_zero_jump op t cmp_op = + case target_in_range m t pos of + InRange -> pure (pos+long_bz_jump_size,[instr]) + NotInRange far_target -> do + jmp_code <- genCondFarJump cmp_op far_target + -- TODO: Fix zero reg so we can use it here + pure (pos + long_bz_jump_size, CMP op (OpImm (ImmInt 0)) : fromOL jmp_code) + + + target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange + target_in_range m target src = + case target of + (TReg{}) -> InRange + (TBlock bid) -> block_in_range m src bid + (TLabel clbl) + | Just bid <- maybeLocalBlockLabel clbl + -> block_in_range m src bid + | otherwise + -- Maybe we should be pessimistic here, for now just fixing intra proc jumps + -> InRange + + block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange + block_in_range m src_pos dest_lbl = + case mapLookup dest_lbl m of + Nothing -> + pprTrace "not in range" (ppr dest_lbl) $ + NotInRange (TBlock dest_lbl) + Just dest_pos -> if abs (dest_pos - src_pos) < max_jump_dist + then InRange + else NotInRange (TBlock dest_lbl) + + calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int) + calc_lbl_positions (pos, m) (BasicBlock lbl instrs) + = let !pos' = pos + infoTblSize_maybe lbl + in foldl' instr_pos (pos',mapInsert lbl pos' m) instrs + + instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int) + instr_pos (pos, m) instr = + case instr of + ANN _ann instr -> instr_pos (pos, m) instr + NEWBLOCK _bid -> panic "mkFarBranched - unexpected NEWBLOCK" -- At this point there should be no NEWBLOCK + -- in the instruction stream + -- (pos, mapInsert bid pos m) + COMMENT{} -> (pos, m) + instr + | Just jump_size <- is_expandable_jump instr -> (pos+jump_size, m) + | otherwise -> (pos+1, m) + + infoTblSize_maybe bid = + case mapLookup bid statics of + Nothing -> 0 :: Int + Just _info_static -> max_info_size + + -- These jumps have a 19bit immediate as offset which is quite + -- limiting so we potentially have to expand them into + -- multiple instructions. + is_expandable_jump i = case i of + CBZ{} -> Just long_bz_jump_size + CBNZ{} -> Just long_bz_jump_size + BCOND{} -> Just long_bc_jump_size + _ -> Nothing diff --git a/GHC/CmmToAsm/AArch64/Cond.hs b/GHC/CmmToAsm/AArch64/Cond.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/AArch64/Cond.hs @@ -0,0 +1,72 @@ +module GHC.CmmToAsm.AArch64.Cond where + +import GHC.Prelude hiding (EQ) + +-- https://developer.arm.com/documentation/den0024/a/the-a64-instruction-set/data-processing-instructions/conditional-instructions + +-- TODO: This appears to go a bit overboard? Maybe we should stick with what LLVM +-- settled on for fcmp? +-- false: always yields false, regardless of operands. +-- oeq: yields true if both operands are not a QNAN and op1 is equal to op2. +-- ogt: yields true if both operands are not a QNAN and op1 is greater than op2. +-- oge: yields true if both operands are not a QNAN and op1 is greater than or equal to op2. +-- olt: yields true if both operands are not a QNAN and op1 is less than op2. +-- ole: yields true if both operands are not a QNAN and op1 is less than or equal to op2. +-- one: yields true if both operands are not a QNAN and op1 is not equal to op2. +-- ord: yields true if both operands are not a QNAN. +-- ueq: yields true if either operand is a QNAN or op1 is equal to op2. +-- ugt: yields true if either operand is a QNAN or op1 is greater than op2. +-- uge: yields true if either operand is a QNAN or op1 is greater than or equal to op2. +-- ult: yields true if either operand is a QNAN or op1 is less than op2. +-- ule: yields true if either operand is a QNAN or op1 is less than or equal to op2. +-- une: yields true if either operand is a QNAN or op1 is not equal to op2. +-- uno: yields true if either operand is a QNAN. +-- true: always yields true, regardless of operands. +-- +-- LLVMs icmp knows about: +-- eq: yields true if the operands are equal, false otherwise. No sign interpretation is necessary or performed. +-- ne: yields true if the operands are unequal, false otherwise. No sign interpretation is necessary or performed. +-- ugt: interprets the operands as unsigned values and yields true if op1 is greater than op2. +-- uge: interprets the operands as unsigned values and yields true if op1 is greater than or equal to op2. +-- ult: interprets the operands as unsigned values and yields true if op1 is less than op2. +-- ule: interprets the operands as unsigned values and yields true if op1 is less than or equal to op2. +-- sgt: interprets the operands as signed values and yields true if op1 is greater than op2. +-- sge: interprets the operands as signed values and yields true if op1 is greater than or equal to op2. +-- slt: interprets the operands as signed values and yields true if op1 is less than op2. +-- sle: interprets the operands as signed values and yields true if op1 is less than or equal to op2. + +data Cond + = ALWAYS -- b.al + | EQ -- b.eq + | NE -- b.ne + -- signed + | SLT -- b.lt + | SLE -- b.le + | SGE -- b.ge + | SGT -- b.gt + -- unsigned + | ULT -- b.lo + | ULE -- b.ls + | UGE -- b.hs + | UGT -- b.hi + -- ordered + | OLT -- b.mi + | OLE -- b.ls + | OGE -- b.ge + | OGT -- b.gt + -- unordered + | UOLT -- b.lt + | UOLE -- b.le + | UOGE -- b.pl + | UOGT -- b.hi + -- others + -- NEVER -- b.nv + -- I removed never. According to the ARM spec: + -- > The Condition code NV exists only to provide a valid disassembly of + -- > the 0b1111 encoding, otherwise its behavior is identical to AL. + -- This can only lead to disaster. Better to not have it than someone + -- using it assuming it actually means never. + + | VS -- oVerflow set + | VC -- oVerflow clear + deriving Eq diff --git a/GHC/CmmToAsm/AArch64/Instr.hs b/GHC/CmmToAsm/AArch64/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/AArch64/Instr.hs @@ -0,0 +1,924 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.CmmToAsm.AArch64.Instr + +where + +import GHC.Prelude + +import GHC.CmmToAsm.AArch64.Cond +import GHC.CmmToAsm.AArch64.Regs + +import GHC.CmmToAsm.Instr (RegUsage(..)) +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Reg.Target (targetClassOfReg) +import GHC.Platform.Reg +import GHC.Platform.Reg.Class.Unified + +import GHC.Platform.Regs +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.Cmm.CLabel +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique.DSM + +import GHC.Utils.Panic + +import Data.Maybe (fromMaybe, catMaybes) + +import GHC.Stack + +-- | LR and FP (8 byte each) are the prologue of each stack frame +stackFrameHeaderSize :: Int +stackFrameHeaderSize = 2 * 8 + +-- | All registers are 8 byte wide. +spillSlotSize :: Int +spillSlotSize = 8 + +-- | The number of bytes that the stack pointer should be aligned +-- to. +stackAlign :: Int +stackAlign = 16 + +-- | The number of spill slots available without allocating more. +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config +-- = 0 -- set to zero, to see when allocMoreStack has to fire. + = ((ncgSpillPreallocSize config - stackFrameHeaderSize) + `div` spillSlotSize) - 1 + +-- | Convert a spill slot number to a *byte* offset, with no sign. +spillSlotToOffset :: NCGConfig -> Int -> Int +spillSlotToOffset _ slot + = stackFrameHeaderSize + spillSlotSize * slot + +-- | Get the registers that are being used by this instruction. +-- regUsage doesn't need to do any trickery for jumps and such. +-- Just state precisely the regs read and written by that insn. +-- The consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. +-- +-- RegUsage = RU [] [] + +instance Outputable RegUsage where + ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')' + +regUsageOfInstr :: Platform -> Instr -> RegUsage +regUsageOfInstr platform instr = case instr of + ANN _ i -> regUsageOfInstr platform i + COMMENT{} -> usage ([], []) + MULTILINE_COMMENT{} -> usage ([], []) + PUSH_STACK_FRAME -> usage ([], []) + POP_STACK_FRAME -> usage ([], []) + DELTA{} -> usage ([], []) + + -- 1. Arithmetic Instructions ------------------------------------------------ + ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + CMP l r -> usage (regOp l ++ regOp r, []) + CMN l r -> usage (regOp l ++ regOp r, []) + MSUB dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + NEG dst src -> usage (regOp src, regOp dst) + SMULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SMULL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + UMULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + UMULL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SDIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + UDIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + + -- 2. Bit Manipulation Instructions ------------------------------------------ + SBFM dst src _ _ -> usage (regOp src, regOp dst) + UBFM dst src _ _ -> usage (regOp src, regOp dst) + SBFX dst src _ _ -> usage (regOp src, regOp dst) + UBFX dst src _ _ -> usage (regOp src, regOp dst) + SXTB dst src -> usage (regOp src, regOp dst) + UXTB dst src -> usage (regOp src, regOp dst) + SXTH dst src -> usage (regOp src, regOp dst) + UXTH dst src -> usage (regOp src, regOp dst) + CLZ dst src -> usage (regOp src, regOp dst) + RBIT dst src -> usage (regOp src, regOp dst) + REV dst src -> usage (regOp src, regOp dst) + -- REV32 dst src -> usage (regOp src, regOp dst) + REV16 dst src -> usage (regOp src, regOp dst) + -- 3. Logical and Move Instructions ------------------------------------------ + AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + ASR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + EOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + LSL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + LSR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MOV dst src -> usage (regOp src, regOp dst) + MOVK dst src -> usage (regOp src, regOp dst) + MOVZ dst src -> usage (regOp src, regOp dst) + MVN dst src -> usage (regOp src, regOp dst) + ORR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + -- 4. Branch Instructions ---------------------------------------------------- + J t -> usage (regTarget t, []) + J_TBL _ _ t -> usage ([t], []) + B t -> usage (regTarget t, []) + BCOND _ t -> usage (regTarget t, []) + BL t ps -> usage (regTarget t ++ ps, callerSavedRegisters) + + -- 5. Atomic Instructions ---------------------------------------------------- + -- 6. Conditional Instructions ----------------------------------------------- + CSET dst _ -> usage ([], regOp dst) + CBZ src _ -> usage (regOp src, []) + CBNZ src _ -> usage (regOp src, []) + -- 7. Load and Store Instructions -------------------------------------------- + STR _ src dst -> usage (regOp src ++ regOp dst, []) + STLR _ src dst -> usage (regOp src ++ regOp dst, []) + LDR _ dst src -> usage (regOp src, regOp dst) + LDAR _ dst src -> usage (regOp src, regOp dst) + + -- 8. Synchronization Instructions ------------------------------------------- + DMBISH _ -> usage ([], []) + + -- 9. Floating Point Instructions -------------------------------------------- + FMOV dst src -> usage (regOp src, regOp dst) + FCVT dst src -> usage (regOp src, regOp dst) + SCVTF dst src -> usage (regOp src, regOp dst) + FCVTZS dst src -> usage (regOp src, regOp dst) + FABS dst src -> usage (regOp src, regOp dst) + FSQRT dst src -> usage (regOp src, regOp dst) + FMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FMA _ dst src1 src2 src3 -> + usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + + LOCATION{} -> panic $ "regUsageOfInstr: " ++ instrCon instr + NEWBLOCK{} -> panic $ "regUsageOfInstr: " ++ instrCon instr + + where + -- filtering the usage is necessary, otherwise the register + -- allocator will try to allocate pre-defined fixed stg + -- registers as well, as they show up. + usage (src, dst) = RU (map mkFmt $ filter (interesting platform) src) + (map mkFmt $ filter (interesting platform) dst) + -- SIMD NCG TODO: the format here is used for register spilling/unspilling. + -- As the AArch64 NCG does not currently support SIMD registers, + -- this simple logic is OK. + mkFmt r = RegWithFormat r fmt + where fmt = case targetClassOfReg platform r of + RcInteger -> II64 + RcFloatOrVector -> FF64 + + regAddr :: AddrMode -> [Reg] + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] + regAddr (AddrReg r1) = [r1] + regOp :: Operand -> [Reg] + regOp (OpReg _ r1) = [r1] + regOp (OpRegExt _ r1 _ _) = [r1] + regOp (OpRegShift _ r1 _ _) = [r1] + regOp (OpAddr a) = regAddr a + regOp (OpImm _) = [] + regOp (OpImmShift _ _ _) = [] + regTarget :: Target -> [Reg] + regTarget (TBlock _) = [] + regTarget (TLabel _) = [] + regTarget (TReg r1) = [r1] + + -- Is this register interesting for the register allocator? + interesting :: Platform -> Reg -> Bool + interesting _ (RegVirtual _) = True + interesting platform (RegReal (RealRegSingle i)) = freeReg platform i + +-- Note [AArch64 Register assignments] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Save caller save registers +-- This is x0-x18 +-- +-- For SIMD/FP Registers: +-- Registers v8-v15 must be preserved by a callee across subroutine calls; +-- the remaining registers (v0-v7, v16-v31) do not need to be preserved (or +-- should be preserved by the caller). Additionally, only the bottom 64 bits +-- of each value stored in v8-v15 need to be preserved [7]; it is the +-- responsibility of the caller to preserve larger values. +-- +-- .---------------------------------------------------------------------------------------------------------------------------------------------------------------. +-- | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | +-- | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 42 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | +-- |== General Purpose registers ==================================================================================================================================| +-- | <---- argument passing -------------> | IR | <------- tmp registers --------> | IP0| IP1| PL | <------------------- callee saved ------------> | FP | LR | SP | +-- | <------ free registers --------------------------------------------------------------------> | BR | Sp | Hp | R1 | R2 | R3 | R4 | R5 | R6 | SL | -- | -- | -- | +-- |== SIMD/FP Registers ==========================================================================================================================================| +-- | <---- argument passing -------------> | <-- callee saved (lower 64 bits) ---> | <--------------------------------------- caller saved ----------------------> | +-- | <------ free registers -------------> | F1 | F2 | F3 | F4 | D1 | D2 | D3 | D4 | <------ free registers -----------------------------------------------------> | +-- '---------------------------------------------------------------------------------------------------------------------------------------------------------------' +-- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register (See Note [Aarch64 Register x18 at Darwin and Windows]), FP: Frame pointer, LR: Link register, SP: Stack pointer +-- BR: Base, SL: SpLim +-- +-- TODO: The zero register is currently mapped to -1 but should get it's own separate number. +callerSavedRegisters :: [Reg] +callerSavedRegisters + = map regSingle [0..18] + ++ map regSingle [32..39] + ++ map regSingle [48..63] + +-- | Apply a given mapping to all the register references in this +-- instruction. +patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +patchRegsOfInstr instr env = case instr of + -- 0. Meta Instructions + ANN d i -> ANN d (patchRegsOfInstr i env) + COMMENT{} -> instr + MULTILINE_COMMENT{} -> instr + PUSH_STACK_FRAME -> instr + POP_STACK_FRAME -> instr + DELTA{} -> instr + -- 1. Arithmetic Instructions ---------------------------------------------- + ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3) + CMP o1 o2 -> CMP (patchOp o1) (patchOp o2) + CMN o1 o2 -> CMN (patchOp o1) (patchOp o2) + MSUB o1 o2 o3 o4 -> MSUB (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3) + NEG o1 o2 -> NEG (patchOp o1) (patchOp o2) + SMULH o1 o2 o3 -> SMULH (patchOp o1) (patchOp o2) (patchOp o3) + SMULL o1 o2 o3 -> SMULL (patchOp o1) (patchOp o2) (patchOp o3) + UMULH o1 o2 o3 -> UMULH (patchOp o1) (patchOp o2) (patchOp o3) + UMULL o1 o2 o3 -> UMULL (patchOp o1) (patchOp o2) (patchOp o3) + SDIV o1 o2 o3 -> SDIV (patchOp o1) (patchOp o2) (patchOp o3) + SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3) + UDIV o1 o2 o3 -> UDIV (patchOp o1) (patchOp o2) (patchOp o3) + + -- 2. Bit Manipulation Instructions ---------------------------------------- + SBFM o1 o2 o3 o4 -> SBFM (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + UBFM o1 o2 o3 o4 -> UBFM (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + SBFX o1 o2 o3 o4 -> SBFX (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + UBFX o1 o2 o3 o4 -> UBFX (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + SXTB o1 o2 -> SXTB (patchOp o1) (patchOp o2) + UXTB o1 o2 -> UXTB (patchOp o1) (patchOp o2) + SXTH o1 o2 -> SXTH (patchOp o1) (patchOp o2) + UXTH o1 o2 -> UXTH (patchOp o1) (patchOp o2) + CLZ o1 o2 -> CLZ (patchOp o1) (patchOp o2) + RBIT o1 o2 -> RBIT (patchOp o1) (patchOp o2) + REV o1 o2 -> REV (patchOp o1) (patchOp o2) + -- REV32 o1 o2 -> REV32 (patchOp o1) (patchOp o2) + REV16 o1 o2 -> REV16 (patchOp o1) (patchOp o2) + + + -- 3. Logical and Move Instructions ---------------------------------------- + AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3) + ASR o1 o2 o3 -> ASR (patchOp o1) (patchOp o2) (patchOp o3) + EOR o1 o2 o3 -> EOR (patchOp o1) (patchOp o2) (patchOp o3) + LSL o1 o2 o3 -> LSL (patchOp o1) (patchOp o2) (patchOp o3) + LSR o1 o2 o3 -> LSR (patchOp o1) (patchOp o2) (patchOp o3) + MOV o1 o2 -> MOV (patchOp o1) (patchOp o2) + MOVK o1 o2 -> MOVK (patchOp o1) (patchOp o2) + MOVZ o1 o2 -> MOVZ (patchOp o1) (patchOp o2) + MVN o1 o2 -> MVN (patchOp o1) (patchOp o2) + ORR o1 o2 o3 -> ORR (patchOp o1) (patchOp o2) (patchOp o3) + + -- 4. Branch Instructions -------------------------------------------------- + J t -> J (patchTarget t) + J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t) + B t -> B (patchTarget t) + BL t rs -> BL (patchTarget t) rs + BCOND c t -> BCOND c (patchTarget t) + + -- 5. Atomic Instructions -------------------------------------------------- + -- 6. Conditional Instructions --------------------------------------------- + CSET o c -> CSET (patchOp o) c + CBZ o l -> CBZ (patchOp o) l + CBNZ o l -> CBNZ (patchOp o) l + -- 7. Load and Store Instructions ------------------------------------------ + STR f o1 o2 -> STR f (patchOp o1) (patchOp o2) + STLR f o1 o2 -> STLR f (patchOp o1) (patchOp o2) + LDR f o1 o2 -> LDR f (patchOp o1) (patchOp o2) + LDAR f o1 o2 -> LDAR f (patchOp o1) (patchOp o2) + + -- 8. Synchronization Instructions ----------------------------------------- + DMBISH c -> DMBISH c + + -- 9. Floating Point Instructions ------------------------------------------ + FMOV o1 o2 -> FMOV (patchOp o1) (patchOp o2) + FCVT o1 o2 -> FCVT (patchOp o1) (patchOp o2) + SCVTF o1 o2 -> SCVTF (patchOp o1) (patchOp o2) + FCVTZS o1 o2 -> FCVTZS (patchOp o1) (patchOp o2) + FABS o1 o2 -> FABS (patchOp o1) (patchOp o2) + FSQRT o1 o2 -> FSQRT (patchOp o1) (patchOp o2) + FMIN o1 o2 o3 -> FMIN (patchOp o1) (patchOp o2) (patchOp o3) + FMAX o1 o2 o3 -> FMAX (patchOp o1) (patchOp o2) (patchOp o3) + FMA s o1 o2 o3 o4 -> + FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + + NEWBLOCK{} -> panic $ "patchRegsOfInstr: " ++ instrCon instr + LOCATION{} -> panic $ "patchRegsOfInstr: " ++ instrCon instr + where + patchOp :: Operand -> Operand + patchOp (OpReg w r) = OpReg w (env r) + patchOp (OpRegExt w r x s) = OpRegExt w (env r) x s + patchOp (OpRegShift w r m s) = OpRegShift w (env r) m s + patchOp (OpAddr a) = OpAddr (patchAddr a) + patchOp op = op + patchTarget :: Target -> Target + patchTarget (TReg r) = TReg (env r) + patchTarget t = t + patchAddr :: AddrMode -> AddrMode + patchAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + patchAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i + patchAddr (AddrReg r) = AddrReg (env r) +-------------------------------------------------------------------------------- +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +isJumpishInstr :: Instr -> Bool +isJumpishInstr instr = case instr of + ANN _ i -> isJumpishInstr i + CBZ{} -> True + CBNZ{} -> True + J{} -> True + J_TBL{} -> True + B{} -> True + BL{} -> True + BCOND{} -> True + _ -> False + +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +jumpDestsOfInstr :: Instr -> [BlockId] +jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i +jumpDestsOfInstr (CBZ _ t) = [ id | TBlock id <- [t]] +jumpDestsOfInstr (CBNZ _ t) = [ id | TBlock id <- [t]] +jumpDestsOfInstr (J t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids +jumpDestsOfInstr (B t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BL t _) = [ id | TBlock id <- [t]] +jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]] +jumpDestsOfInstr _ = [] + +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo (ANN _ i) bid = canFallthroughTo i bid +canFallthroughTo (J (TBlock target)) bid = bid == target +canFallthroughTo (J_TBL targets _ _) bid = all isTargetBid targets + where + isTargetBid target = case target of + Nothing -> True + Just target -> target == bid +canFallthroughTo (B (TBlock target)) bid = bid == target +canFallthroughTo _ _ = False + +-- | Change the destination of this jump instruction. +-- Used in the linear allocator when adding fixup blocks for join +-- points. +patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr +patchJumpInstr instr patchF + = case instr of + ANN d i -> ANN d (patchJumpInstr i patchF) + CBZ r (TBlock bid) -> CBZ r (TBlock (patchF bid)) + CBNZ r (TBlock bid) -> CBNZ r (TBlock (patchF bid)) + J (TBlock bid) -> J (TBlock (patchF bid)) + J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r + B (TBlock bid) -> B (TBlock (patchF bid)) + BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps + BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid)) + _ -> panic $ "patchJumpInstr: " ++ instrCon instr + +-- ----------------------------------------------------------------------------- +-- Note [Spills and Reloads] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We reserve @RESERVED_C_STACK_BYTES@ on the C stack for spilling and reloading +-- registers. AArch64s maximum displacement for SP relative spills and reloads +-- is essentially [-256,255], or [0, 0xFFF]*8 = [0, 32760] for 64bits. +-- +-- The @RESERVED_C_STACK_BYTES@ is 16k, so we can't address any location in a +-- single instruction. The idea is to use the Inter Procedure 0 (ip0) register +-- to perform the computations for larger offsets. +-- +-- Using sp to compute the offset will violate assumptions about the stack pointer +-- pointing to the top of the stack during signal handling. As we can't force +-- every signal to use its own stack, we have to ensure that the stack pointer +-- always points to the top of the stack, and we can't use it for computation. +-- +-- | An instruction to spill a register into a spill slot. +mkSpillInstr + :: HasCallStack + => NCGConfig + -> RegWithFormat -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] + +mkSpillInstr config (RegWithFormat reg fmt) delta slot = + case off - delta of + imm | -256 <= imm && imm <= 255 -> [ mkStrSp imm ] + imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff -> [ mkStrSp imm ] + imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0 -> [ mkIp0SpillAddr (imm .&~. 0xfff) + , mkStrIp0 (imm .&. 0xfff) + ] + imm -> pprPanic "mkSpillInstr" (text "Unable to spill register into" <+> int imm) + where + a .&~. b = a .&. (complement b) + + -- SIMD NCG TODO: emit the correct instructions to spill a vector register. + -- You can take inspiration from the X86_64 backend. + mkIp0SpillAddr imm = ANN (text "Spill: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm)) + mkStrSp imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm))) + mkStrIp0 imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm))) + + off = spillSlotToOffset config slot + +mkLoadInstr + :: NCGConfig + -> RegWithFormat + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] +mkLoadInstr config (RegWithFormat reg fmt) delta slot = + case off - delta of + imm | -256 <= imm && imm <= 255 -> [ mkLdrSp imm ] + imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff -> [ mkLdrSp imm ] + imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0 -> [ mkIp0SpillAddr (imm .&~. 0xfff) + , mkLdrIp0 (imm .&. 0xfff) + ] + imm -> pprPanic "mkLoadInstr" (text "Unable to load spilled register at" <+> int imm) + where + a .&~. b = a .&. (complement b) + + -- SIMD NCG TODO: emit the correct instructions to load a vector register. + -- You can take inspiration from the X86_64 backend. + mkIp0SpillAddr imm = ANN (text "Reload: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm)) + mkLdrSp imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm))) + mkLdrIp0 imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm))) + + off = spillSlotToOffset config slot + +-------------------------------------------------------------------------------- +-- | See if this instruction is telling us the current C stack delta +takeDeltaInstr :: Instr -> Maybe Int +takeDeltaInstr (ANN _ i) = takeDeltaInstr i +takeDeltaInstr (DELTA i) = Just i +takeDeltaInstr _ = Nothing + +-- Not real instructions. Just meta data +isMetaInstr :: Instr -> Bool +isMetaInstr instr + = case instr of + ANN _ i -> isMetaInstr i + COMMENT{} -> True + MULTILINE_COMMENT{} -> True + LOCATION{} -> True + NEWBLOCK{} -> True + DELTA{} -> True + PUSH_STACK_FRAME -> True + POP_STACK_FRAME -> True + _ -> False + +-- | Copy the value in a register to another one. +-- Must work for all register classes. +mkRegRegMoveInstr :: Format -> Reg -> Reg -> Instr +mkRegRegMoveInstr _fmt src dst + = ANN (text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst) $ MOV (OpReg W64 dst) (OpReg W64 src) + -- SIMD NCG TODO: incorrect for vector formats + +-- | Take the source and destination registers from a move instruction of same +-- register class (`RegClass`). +-- +-- The idea is to identify moves that can be eliminated by the register +-- allocator: If the source register serves no special purpose, one could +-- continue using it; saving one move instruction. For this, the register kinds +-- (classes) must be the same (no conversion involved.) +takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) +takeRegRegMoveInstr (MOV (OpReg _fmt dst) (OpReg _fmt' src)) + | classOfReg dst == classOfReg src = pure (src, dst) + where + classOfReg :: Reg -> RegClass + classOfReg reg + = case reg of + RegVirtual vr -> classOfVirtualReg ArchAArch64 vr + RegReal rr -> classOfRealReg rr +takeRegRegMoveInstr _ = Nothing + +-- | Make an unconditional jump instruction. +mkJumpInstr :: BlockId -> [Instr] +mkJumpInstr id = [B (TBlock id)] + +mkStackAllocInstr :: Platform -> Int -> [Instr] +mkStackAllocInstr platform n + | n == 0 = [] + | n > 0 && n < 4096 = [ ANN (text "Alloc More Stack") $ SUB sp sp (OpImm (ImmInt n)) ] + | n > 0 = ANN (text "Alloc More Stack") (SUB sp sp (OpImm (ImmInt 4095))) : mkStackAllocInstr platform (n - 4095) +mkStackAllocInstr _platform n = pprPanic "mkStackAllocInstr" (int n) + +mkStackDeallocInstr :: Platform -> Int -> [Instr] +mkStackDeallocInstr platform n + | n == 0 = [] + | n > 0 && n < 4096 = [ ANN (text "Dealloc More Stack") $ ADD sp sp (OpImm (ImmInt n)) ] + | n > 0 = ANN (text "Dealloc More Stack") (ADD sp sp (OpImm (ImmInt 4095))) : mkStackDeallocInstr platform (n - 4095) +mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n) + +-- +-- See Note [extra spill slots] in X86/Instr.hs +-- +allocMoreStack + :: Platform + -> Int + -> NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr + -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr, [(BlockId,BlockId)]) + +allocMoreStack _ _ top@(CmmData _ _) = return (top,[]) +allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do + let entries = entryBlocks proc + + retargetList <- mapM (\e -> (e,) <$> newBlockId) entries + + let + delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up + where x = slots * spillSlotSize -- sp delta + + alloc = mkStackAllocInstr platform delta + dealloc = mkStackDeallocInstr platform delta + + new_blockmap :: LabelMap BlockId + new_blockmap = mapFromList retargetList + + insert_stack_insn (BasicBlock id insns) + | Just new_blockid <- mapLookup id new_blockmap + = [ BasicBlock id $ alloc ++ [ B (TBlock new_blockid) ] + , BasicBlock new_blockid block' ] + | otherwise + = [ BasicBlock id block' ] + where + block' = foldr insert_dealloc [] insns + + insert_dealloc insn r = case insn of + J _ -> dealloc ++ (insn : r) + ANN _ (J _) -> dealloc ++ (insn : r) + _other | jumpDestsOfInstr insn /= [] + -> patchJumpInstr insn retarget : r + _other -> insn : r + + where retarget b = fromMaybe b (mapLookup b new_blockmap) + + new_code = concatMap insert_stack_insn code + -- in + return (CmmProc info lbl live (ListGraph new_code), retargetList) +-- ----------------------------------------------------------------------------- +-- Machine's assembly language + +-- We have a few common "instructions" (nearly all the pseudo-ops) but +-- mostly all of 'Instr' is machine-specific. + +-- Some additional (potential future) instructions are commented out. They are +-- not needed yet for the backend but could be used in the future. +data Instr + -- comment pseudo-op + = COMMENT SDoc + | MULTILINE_COMMENT SDoc + + -- Annotated instruction. Should print # + | ANN SDoc Instr + + -- location pseudo-op (file, line, col, name) + | LOCATION Int Int Int String + + -- start a new basic block. Useful during + -- codegen, removed later. Preceding + -- instruction should be a jump, as per the + -- invariants for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for + -- benefit of subsequent passes + | DELTA Int + + -- 0. Pseudo Instructions -------------------------------------------------- + | SXTB Operand Operand + | UXTB Operand Operand + | SXTH Operand Operand + | UXTH Operand Operand + -- | SXTW Operand Operand + -- | SXTX Operand Operand + | PUSH_STACK_FRAME + | POP_STACK_FRAME + -- 1. Arithmetic Instructions ---------------------------------------------- + -- | ADC Operand Operand Operand -- rd = rn + rm + C + -- | ADCS ... + | ADD Operand Operand Operand -- rd = rn + rm + -- | ADDS Operand Operand Operand -- rd = rn + rm + -- | ADR ... + -- | ADRP ... + | CMP Operand Operand -- rd - op2 + | CMN Operand Operand -- rd + op2 + -- | MADD ... + -- | MNEG ... + | MSUB Operand Operand Operand Operand -- rd = ra - rn × rm + | MUL Operand Operand Operand -- rd = rn × rm + | NEG Operand Operand -- rd = -op2 + -- | NEGS ... + -- | NGC ... + -- | NGCS ... + -- | SBC ... + -- | SBCS ... + | SDIV Operand Operand Operand -- rd = rn ÷ rm + -- | SMADDL ... + -- | SMNEGL ... + -- | SMSUBL ... + | SMULH Operand Operand Operand + | SMULL Operand Operand Operand + | SUB Operand Operand Operand -- rd = rn - op2 + -- | SUBS ... + | UDIV Operand Operand Operand -- rd = rn ÷ rm + -- | UMADDL ... -- Xd = Xa + Wn × Wm + -- | UMNEGL ... -- Xd = - Wn × Wm + -- | UMSUBL ... -- Xd = Xa - Wn × Wm + | UMULH Operand Operand Operand -- Xd = (Xn × Xm)_127:64 + | UMULL Operand Operand Operand -- Xd = Wn × Wm + + -- 2. Bit Manipulation Instructions ---------------------------------------- + | SBFM Operand Operand Operand Operand -- rd = rn[i,j] + -- SXTB = SBFM , , #0, #7 + -- SXTH = SBFM , , #0, #15 + -- SXTW = SBFM , , #0, #31 + | UBFM Operand Operand Operand Operand -- rd = rn[i,j] + -- UXTB = UBFM , , #0, #7 + -- UXTH = UBFM , , #0, #15 + -- Signed/Unsigned bitfield extract + | SBFX Operand Operand Operand Operand -- rd = rn[i,j] + | UBFX Operand Operand Operand Operand -- rd = rn[i,j] + | CLZ Operand Operand -- rd = countLeadingZeros(rn) + | RBIT Operand Operand -- rd = reverseBits(rn) + | REV Operand Operand -- rd = reverseBytes(rn): (for 32 & 64 bit operands) + -- 0xAABBCCDD -> 0xDDCCBBAA + | REV16 Operand Operand -- rd = reverseBytes16(rn) + -- 0xAABB_CCDD -> xBBAA_DDCC + -- | REV32 Operand Operand -- rd = reverseBytes32(rn) - 64bit operands only! + -- -- 0xAABBCCDD_EEFFGGHH -> 0XDDCCBBAA_HHGGFFEE + + -- 3. Logical and Move Instructions ---------------------------------------- + | AND Operand Operand Operand -- rd = rn & op2 + | ASR Operand Operand Operand -- rd = rn ≫ rm or rd = rn ≫ #i, i is 6 bits + | EOR Operand Operand Operand -- rd = rn ⊕ op2 + | LSL Operand Operand Operand -- rd = rn ≪ rm or rd = rn ≪ #i, i is 6 bits + | LSR Operand Operand Operand -- rd = rn ≫ rm or rd = rn ≫ #i, i is 6 bits + | MOV Operand Operand -- rd = rn or rd = #i + | MOVK Operand Operand + -- | MOVN Operand Operand + | MOVZ Operand Operand + | MVN Operand Operand -- rd = ~rn + | ORR Operand Operand Operand -- rd = rn | op2 + -- Load and stores. + -- TODO STR/LDR might want to change to STP/LDP with XZR for the second register. + | STR Format Operand Operand -- str Xn, address-mode // Xn -> *addr + | STLR Format Operand Operand -- stlr Xn, address-mode // Xn -> *addr + | LDR Format Operand Operand -- ldr Xn, address-mode // Xn <- *addr + | LDAR Format Operand Operand -- ldar Xn, address-mode // Xn <- *addr + + -- Conditional instructions + | CSET Operand Cond -- if(cond) op <- 1 else op <- 0 + + | CBZ Operand Target -- if op == 0, then branch. + | CBNZ Operand Target -- if op /= 0, then branch. + -- Branching. + | J Target -- like B, but only generated from genJump. Used to distinguish genJumps from others. + | J_TBL [Maybe BlockId] (Maybe CLabel) Reg -- A jump instruction with data for switch/jump tables + | B Target -- unconditional branching b/br. (To a blockid, label or register) + | BL Target [Reg] -- branch and link (e.g. set x30 to next pc, and branch) + | BCOND Cond Target -- branch with condition. b. + + -- 8. Synchronization Instructions ----------------------------------------- + | DMBISH DMBISHFlags + -- 9. Floating Point Instructions + -- move to/from general purpose <-> floating, or floating to floating + | FMOV Operand Operand + -- Float ConVerT + | FCVT Operand Operand + -- Signed ConVerT Float + | SCVTF Operand Operand + -- Float ConVerT to Zero Signed + | FCVTZS Operand Operand + -- Float ABSolute value + | FABS Operand Operand + -- Float minimum + | FMIN Operand Operand Operand + -- Float maximum + | FMAX Operand Operand Operand + -- Float SQuare RooT + | FSQRT Operand Operand + + -- | Floating-point fused multiply-add instructions + -- + -- - fmadd : d = r1 * r2 + r3 + -- - fnmsub: d = r1 * r2 - r3 + -- - fmsub : d = - r1 * r2 + r3 + -- - fnmadd: d = - r1 * r2 - r3 + | FMA FMASign Operand Operand Operand Operand + +data DMBISHFlags = DmbLoad | DmbLoadStore + deriving (Eq, Show) + +instrCon :: Instr -> String +instrCon i = + case i of + COMMENT{} -> "COMMENT" + MULTILINE_COMMENT{} -> "COMMENT" + ANN{} -> "ANN" + LOCATION{} -> "LOCATION" + NEWBLOCK{} -> "NEWBLOCK" + DELTA{} -> "DELTA" + SXTB{} -> "SXTB" + UXTB{} -> "UXTB" + SXTH{} -> "SXTH" + UXTH{} -> "UXTH" + PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME" + POP_STACK_FRAME{} -> "POP_STACK_FRAME" + ADD{} -> "ADD" + CMP{} -> "CMP" + CMN{} -> "CMN" + MSUB{} -> "MSUB" + MUL{} -> "MUL" + NEG{} -> "NEG" + SDIV{} -> "SDIV" + SMULH{} -> "SMULH" + SMULL{} -> "SMULL" + UMULH{} -> "UMULH" + UMULL{} -> "UMULL" + SUB{} -> "SUB" + UDIV{} -> "UDIV" + SBFM{} -> "SBFM" + UBFM{} -> "UBFM" + SBFX{} -> "SBFX" + UBFX{} -> "UBFX" + CLZ{} -> "CLZ" + RBIT{} -> "RBIT" + REV{} -> "REV" + REV16{} -> "REV16" + -- REV32{} -> "REV32" + AND{} -> "AND" + ASR{} -> "ASR" + EOR{} -> "EOR" + LSL{} -> "LSL" + LSR{} -> "LSR" + MOV{} -> "MOV" + MOVK{} -> "MOVK" + MOVZ{} -> "MOVZ" + MVN{} -> "MVN" + ORR{} -> "ORR" + STR{} -> "STR" + STLR{} -> "STLR" + LDR{} -> "LDR" + LDAR{} -> "LDAR" + CSET{} -> "CSET" + CBZ{} -> "CBZ" + CBNZ{} -> "CBNZ" + J{} -> "J" + J_TBL {} -> "J_TBL" + B{} -> "B" + BL{} -> "BL" + BCOND{} -> "BCOND" + DMBISH{} -> "DMBISH" + FMOV{} -> "FMOV" + FCVT{} -> "FCVT" + SCVTF{} -> "SCVTF" + FCVTZS{} -> "FCVTZS" + FABS{} -> "FABS" + FSQRT{} -> "FSQRT" + FMIN {} -> "FMIN" + FMAX {} -> "FMAX" + FMA variant _ _ _ _ -> + case variant of + FMAdd -> "FMADD" + FMSub -> "FMSUB" + FNMAdd -> "FNMADD" + FNMSub -> "FNMSUB" + +data Target + = TBlock BlockId + | TLabel CLabel + | TReg Reg + deriving (Eq, Ord) + + +-- Extension +-- {Unsigned|Signed}XT{Byte|Half|Word|Doube} +data ExtMode + = EUXTB | EUXTH | EUXTW | EUXTX + | ESXTB | ESXTH | ESXTW | ESXTX + deriving (Eq, Show) + +data ShiftMode + = SLSL | SLSR | SASR | SROR + deriving (Eq, Show) + + +-- We can also add ExtShift to Extension. +-- However at most 3bits. +type ExtShift = Int +-- at most 6bits +type RegShift = Int + +data Operand + = OpReg Width Reg -- register + | OpRegExt Width Reg ExtMode ExtShift -- rm, [, ] + | OpRegShift Width Reg ShiftMode RegShift -- rm, , <0-64> + | OpImm Imm -- immediate value + | OpImmShift Imm ShiftMode RegShift + | OpAddr AddrMode -- memory reference + deriving (Eq, Show) + +-- Smart constructors +opReg :: Width -> Reg -> Operand +opReg = OpReg + +sp, ip0 :: Operand +sp = OpReg W64 (RegReal (RealRegSingle 31)) +ip0 = OpReg W64 (RegReal (RealRegSingle 16)) + +_x :: Int -> Operand +_x i = OpReg W64 (RegReal (RealRegSingle i)) +x0, x1, x2, x3, x4, x5, x6, x7 :: Operand +x8, x9, x10, x11, x12, x13, x14, x15 :: Operand +x16, x17, x18, x19, x20, x21, x22, x23 :: Operand +x24, x25, x26, x27, x28, x29, x30, x31 :: Operand +x0 = OpReg W64 (RegReal (RealRegSingle 0)) +x1 = OpReg W64 (RegReal (RealRegSingle 1)) +x2 = OpReg W64 (RegReal (RealRegSingle 2)) +x3 = OpReg W64 (RegReal (RealRegSingle 3)) +x4 = OpReg W64 (RegReal (RealRegSingle 4)) +x5 = OpReg W64 (RegReal (RealRegSingle 5)) +x6 = OpReg W64 (RegReal (RealRegSingle 6)) +x7 = OpReg W64 (RegReal (RealRegSingle 7)) +x8 = OpReg W64 (RegReal (RealRegSingle 8)) +x9 = OpReg W64 (RegReal (RealRegSingle 9)) +x10 = OpReg W64 (RegReal (RealRegSingle 10)) +x11 = OpReg W64 (RegReal (RealRegSingle 11)) +x12 = OpReg W64 (RegReal (RealRegSingle 12)) +x13 = OpReg W64 (RegReal (RealRegSingle 13)) +x14 = OpReg W64 (RegReal (RealRegSingle 14)) +x15 = OpReg W64 (RegReal (RealRegSingle 15)) +x16 = OpReg W64 (RegReal (RealRegSingle 16)) +x17 = OpReg W64 (RegReal (RealRegSingle 17)) +x18 = OpReg W64 (RegReal (RealRegSingle 18)) +x19 = OpReg W64 (RegReal (RealRegSingle 19)) +x20 = OpReg W64 (RegReal (RealRegSingle 20)) +x21 = OpReg W64 (RegReal (RealRegSingle 21)) +x22 = OpReg W64 (RegReal (RealRegSingle 22)) +x23 = OpReg W64 (RegReal (RealRegSingle 23)) +x24 = OpReg W64 (RegReal (RealRegSingle 24)) +x25 = OpReg W64 (RegReal (RealRegSingle 25)) +x26 = OpReg W64 (RegReal (RealRegSingle 26)) +x27 = OpReg W64 (RegReal (RealRegSingle 27)) +x28 = OpReg W64 (RegReal (RealRegSingle 28)) +x29 = OpReg W64 (RegReal (RealRegSingle 29)) +x30 = OpReg W64 (RegReal (RealRegSingle 30)) +x31 = OpReg W64 (RegReal (RealRegSingle 31)) + +_d :: Int -> Operand +_d = OpReg W64 . RegReal . RealRegSingle +d0, d1, d2, d3, d4, d5, d6, d7 :: Operand +d8, d9, d10, d11, d12, d13, d14, d15 :: Operand +d16, d17, d18, d19, d20, d21, d22, d23 :: Operand +d24, d25, d26, d27, d28, d29, d30, d31 :: Operand +d0 = OpReg W64 (RegReal (RealRegSingle 32)) +d1 = OpReg W64 (RegReal (RealRegSingle 33)) +d2 = OpReg W64 (RegReal (RealRegSingle 34)) +d3 = OpReg W64 (RegReal (RealRegSingle 35)) +d4 = OpReg W64 (RegReal (RealRegSingle 36)) +d5 = OpReg W64 (RegReal (RealRegSingle 37)) +d6 = OpReg W64 (RegReal (RealRegSingle 38)) +d7 = OpReg W64 (RegReal (RealRegSingle 39)) +d8 = OpReg W64 (RegReal (RealRegSingle 40)) +d9 = OpReg W64 (RegReal (RealRegSingle 41)) +d10 = OpReg W64 (RegReal (RealRegSingle 42)) +d11 = OpReg W64 (RegReal (RealRegSingle 43)) +d12 = OpReg W64 (RegReal (RealRegSingle 44)) +d13 = OpReg W64 (RegReal (RealRegSingle 45)) +d14 = OpReg W64 (RegReal (RealRegSingle 46)) +d15 = OpReg W64 (RegReal (RealRegSingle 47)) +d16 = OpReg W64 (RegReal (RealRegSingle 48)) +d17 = OpReg W64 (RegReal (RealRegSingle 49)) +d18 = OpReg W64 (RegReal (RealRegSingle 50)) +d19 = OpReg W64 (RegReal (RealRegSingle 51)) +d20 = OpReg W64 (RegReal (RealRegSingle 52)) +d21 = OpReg W64 (RegReal (RealRegSingle 53)) +d22 = OpReg W64 (RegReal (RealRegSingle 54)) +d23 = OpReg W64 (RegReal (RealRegSingle 55)) +d24 = OpReg W64 (RegReal (RealRegSingle 56)) +d25 = OpReg W64 (RegReal (RealRegSingle 57)) +d26 = OpReg W64 (RegReal (RealRegSingle 58)) +d27 = OpReg W64 (RegReal (RealRegSingle 59)) +d28 = OpReg W64 (RegReal (RealRegSingle 60)) +d29 = OpReg W64 (RegReal (RealRegSingle 61)) +d30 = OpReg W64 (RegReal (RealRegSingle 62)) +d31 = OpReg W64 (RegReal (RealRegSingle 63)) + +opRegUExt :: Width -> Reg -> Operand +opRegUExt W64 r = OpRegExt W64 r EUXTX 0 +opRegUExt W32 r = OpRegExt W32 r EUXTW 0 +opRegUExt W16 r = OpRegExt W16 r EUXTH 0 +opRegUExt W8 r = OpRegExt W8 r EUXTB 0 +opRegUExt w _r = pprPanic "opRegUExt" (ppr w) + +opRegSExt :: Width -> Reg -> Operand +opRegSExt W64 r = OpRegExt W64 r ESXTX 0 +opRegSExt W32 r = OpRegExt W32 r ESXTW 0 +opRegSExt W16 r = OpRegExt W16 r ESXTH 0 +opRegSExt W8 r = OpRegExt W8 r ESXTB 0 +opRegSExt w _r = pprPanic "opRegSExt" (ppr w) diff --git a/GHC/CmmToAsm/AArch64/Ppr.hs b/GHC/CmmToAsm/AArch64/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/AArch64/Ppr.hs @@ -0,0 +1,593 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr, pprBasicBlock) where + +import GHC.Prelude hiding (EQ) + +import GHC.CmmToAsm.AArch64.Instr +import GHC.CmmToAsm.AArch64.Regs +import GHC.CmmToAsm.AArch64.Cond +import GHC.CmmToAsm.Ppr +import GHC.CmmToAsm.Format +import GHC.Platform.Reg +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils + +import GHC.Cmm hiding (topInfoTable) +import GHC.Cmm.Dataflow.Label + +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel + +import GHC.Types.Unique ( pprUniqueAlways, getUnique ) +import GHC.Platform +import GHC.Utils.Outputable + +import GHC.Utils.Panic + +pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc +pprNatCmmDecl config (CmmData section dats) = + let platform = ncgPlatform config + in + pprSectionAlign config section $$ pprDatas platform dats + +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config + with_dwarf = ncgDwarfEnabled config + in + case topInfoTable proc of + Nothing -> + -- special case for code without info table: + pprSectionAlign config (Section Text lbl) $$ + -- do not + -- pprProcAlignment config $$ + (if lbl /= blockLbl (blockId (head blocks)) -- blocks can have clashed names + then pprLabel platform lbl -- blocks guaranteed not null, so label needed + else empty) $$ + vcat (map (pprBasicBlock platform with_dwarf top_info) blocks) $$ + (if ncgDwarfEnabled config + then line (pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':') else empty) $$ + pprSizeDecl platform lbl + + Just (CmmStaticsRaw info_lbl _) -> + pprSectionAlign config (Section Text info_lbl) $$ + -- pprProcAlignment config $$ + (if platformHasSubsectionsViaSymbols platform + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':') + else empty) $$ + vcat (map (pprBasicBlock platform with_dwarf top_info) blocks) $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + (if platformHasSubsectionsViaSymbols platform + then -- See Note [Subsections Via Symbols] + line + $ text "\t.long " + <+> pprAsmLabel platform info_lbl + <+> char '-' + <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl) + else empty) $$ + pprSizeDecl platform info_lbl +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-} +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +pprLabel :: IsDoc doc => Platform -> CLabel -> doc +pprLabel platform lbl = + pprGloblDecl platform lbl + $$ pprTypeDecl platform lbl + $$ line (pprAsmLabel platform lbl <> char ':') + +-- | Print appropriate alignment for the given section type. +pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc +pprAlignForSection _platform _seg + -- .balign is stable, whereas .align is platform dependent. + = line (text "\t.balign 8") -- always 8 + +-- | Print section header and appropriate alignment for that section. +-- +-- This one will emit the header: +-- +-- .section .text +-- .balign 8 +-- +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc +pprSectionAlign _config (Section (OtherSection _) _) = + panic "AArch64.Ppr.pprSectionAlign: unknown section" +pprSectionAlign config sec@(Section seg _) = + line (pprSectionHeader config sec) + $$ pprAlignForSection (ncgPlatform config) seg + +-- | Output the ELF .size directive. +pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc +pprSizeDecl platform lbl + = if osElfTarget (platformOS platform) + then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl) + else empty + +pprBasicBlock :: IsDoc doc => Platform -> {- dwarf enabled -} Bool -> LabelMap RawCmmStatics -> NatBasicBlock Instr + -> doc +pprBasicBlock platform with_dwarf info_env (BasicBlock blockid instrs) + = maybe_infotable $ + pprLabel platform asmLbl $$ + vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$ + (if with_dwarf + then line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':') + else empty + ) + where + -- Filter out identity moves. E.g. mov x18, x18 will be dropped. + optInstrs = filter f instrs + where f (MOV o1 o2) | o1 == o2 = False + f _ = True + + asmLbl = blockLbl blockid + maybe_infotable c = case mapLookup blockid info_env of + Nothing -> c + Just (CmmStaticsRaw info_lbl info) -> + -- pprAlignForSection platform Text $$ + infoTableLoc $$ + vcat (map (pprData platform) info) $$ + pprLabel platform info_lbl $$ + c $$ + (if with_dwarf + then line (pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':') + else empty) + -- Make sure the info table has the right .loc for the block + -- coming right after it. See Note [Info Offset] + infoTableLoc = case instrs of + (l@LOCATION{} : _) -> pprInstr platform l + _other -> empty + +pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc +-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' + = pprGloblDecl platform alias + $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind') + +pprDatas platform (CmmStaticsRaw lbl dats) + = vcat (pprLabel platform lbl : map (pprData platform) dats) + +pprData :: IsDoc doc => Platform -> CmmStatic -> doc +pprData _platform (CmmString str) = line (pprString str) +pprData _platform (CmmFileEmbed path _) = line (pprFileEmbed path) + +pprData platform (CmmUninitialised bytes) + = line $ if platformOS platform == OSDarwin + then text ".space " <> int bytes + else text ".skip " <> int bytes + +pprData platform (CmmStaticLit lit) = pprDataItem platform lit + +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc +pprGloblDecl platform lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl) + +-- Note [Always use objects for info tables] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- See discussion in X86.Ppr for why this is necessary. Essentially we need to +-- ensure that we never pass function symbols when we might want to lookup the +-- info table. If we did, we could end up with procedure linking tables +-- (PLT)s, and thus the lookup wouldn't point to the function, but into the +-- jump table. +-- +-- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as +-- well. +pprLabelType' :: IsLine doc => Platform -> CLabel -> doc +pprLabelType' platform lbl = + if isCFunctionLabel lbl || functionOkInfoTable then + text "@function" + else + text "@object" + where + functionOkInfoTable = platformTablesNextToCode platform && + isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl) + +-- this is called pprTypeAndSizeDecl in PPC.Ppr +pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc +pprTypeDecl platform lbl + = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) + else empty + +pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc +pprDataItem platform lit + = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + where + imm = litToImm lit + + ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm] + ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] + ppr_item II64 _ = [text "\t.quad\t" <> pprImm platform imm] + + ppr_item FF32 (CmmFloat r _) + = let bs = floatToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs + + ppr_item FF64 (CmmFloat r _) + = let bs = doubleToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs + + ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit) + +pprImm :: IsLine doc => Platform -> Imm -> doc +pprImm _ (ImmInt i) = int i +pprImm _ (ImmInteger i) = integer i +pprImm p (ImmCLbl l) = pprAsmLabel p l +pprImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i +pprImm _ (ImmLit s) = ftext s + +-- TODO: See pprIm below for why this is a bad idea! +pprImm _ (ImmFloat f) + | f == 0 = text "wzr" + | otherwise = float (fromRational f) +pprImm _ (ImmDouble d) + | d == 0 = text "xzr" + | otherwise = double (fromRational d) + +pprImm p (ImmConstantSum a b) = pprImm p a <> char '+' <> pprImm p b +pprImm p (ImmConstantDiff a b) = pprImm p a <> char '-' + <> lparen <> pprImm p b <> rparen + + +-- aarch64 GNU as uses // for comments. +asmComment :: SDoc -> SDoc +asmComment c = whenPprDebug $ text "#" <+> c + +asmDoubleslashComment :: SDoc -> SDoc +asmDoubleslashComment c = whenPprDebug $ text "//" <+> c + +asmMultilineComment :: SDoc -> SDoc +asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/" + +pprIm :: IsLine doc => Platform -> Imm -> doc +pprIm platform im = case im of + ImmInt i -> char '#' <> int i + ImmInteger i -> char '#' <> integer i + + -- TODO: This will only work for + -- The floating point value must be expressible as ±n ÷ 16 × 2^r, + -- where n and r are integers such that 16 ≤ n ≤ 31 and -3 ≤ r ≤ 4. + -- and 0 needs to be encoded as wzr/xzr. + -- + -- Except for 0, we might want to either split it up into enough + -- ADD operations into an Integer register and then just bit copy it into + -- the double register? See the toBytes + fromRational above for data items. + -- This is something the x86 backend does. + -- + -- We could also just turn them into statics :-/ Which is what the + -- PowerPC backend does. + ImmFloat f | f == 0 -> text "wzr" + ImmFloat f -> char '#' <> float (fromRational f) + ImmDouble d | d == 0 -> text "xzr" + ImmDouble d -> char '#' <> double (fromRational d) + -- = pseudo instruction! + ImmCLbl l -> char '=' <> pprAsmLabel platform l + ImmIndex l o -> text "[=" <> pprAsmLabel platform l <> comma <+> char '#' <> int o <> char ']' + _ -> panic "AArch64.pprIm" + +pprExt :: IsLine doc => ExtMode -> doc +pprExt EUXTB = text "uxtb" +pprExt EUXTH = text "uxth" +pprExt EUXTW = text "uxtw" +pprExt EUXTX = text "uxtx" +pprExt ESXTB = text "sxtb" +pprExt ESXTH = text "sxth" +pprExt ESXTW = text "sxtw" +pprExt ESXTX = text "sxtx" + +pprShift :: IsLine doc => ShiftMode -> doc +pprShift SLSL = text "lsl" +pprShift SLSR = text "lsr" +pprShift SASR = text "asr" +pprShift SROR = text "ror" + +pprOp :: IsLine doc => Platform -> Operand -> doc +pprOp plat op = case op of + OpReg w r -> pprReg w r + OpRegExt w r x 0 -> pprReg w r <> comma <+> pprExt x + OpRegExt w r x i -> pprReg w r <> comma <+> pprExt x <> comma <+> char '#' <> int i + OpRegShift w r s i -> pprReg w r <> comma <+> pprShift s <+> char '#' <> int i + OpImm im -> pprIm plat im + OpImmShift im s i -> pprIm plat im <> comma <+> pprShift s <+> char '#' <> int i + -- TODO: Address computation always use registers as 64bit -- is this correct? + OpAddr (AddrRegReg r1 r2) -> char '[' <+> pprReg W64 r1 <> comma <+> pprReg W64 r2 <+> char ']' + OpAddr (AddrRegImm r1 im) -> char '[' <+> pprReg W64 r1 <> comma <+> pprImm plat im <+> char ']' + OpAddr (AddrReg r1) -> char '[' <+> pprReg W64 r1 <+> char ']' + +pprReg :: forall doc. IsLine doc => Width -> Reg -> doc +pprReg w r = case r of + RegReal (RealRegSingle i) -> ppr_reg_no w i + -- virtual regs should not show up, but this is helpful for debugging. + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u + _ -> pprPanic "AArch64.pprReg" (text $ show r) + + where + ppr_reg_no :: Width -> Int -> doc + ppr_reg_no w 31 + | w == W64 = text "sp" + | w == W32 = text "wsp" + + -- See Note [AArch64 Register assignments] + ppr_reg_no w i + | i < 0, w == W32 = text "wzr" + | i < 0, w == W64 = text "xzr" + | i < 0 = pprPanic "Invalid Zero Reg" (ppr w <+> int i) + -- General Purpose Registers + | i <= 31, w == W8 = text "w" <> int i -- there are no byte or half + | i <= 31, w == W16 = text "w" <> int i -- words... word will do. + | i <= 31, w == W32 = text "w" <> int i + | i <= 31, w == W64 = text "x" <> int i + | i <= 31 = pprPanic "Invalid Reg" (ppr w <+> int i) + -- Floating Point Registers + | i <= 63, w == W8 = text "b" <> int (i-32) + | i <= 63, w == W16 = text "h" <> int (i-32) + | i <= 63, w == W32 = text "s" <> int (i-32) + | i <= 63, w == W64 = text "d" <> int (i-32) + | i <= 63, w == W128= text "q" <> int (i-32) + | otherwise = text "very naughty AArch64 register" <+> parens (text (show w) <+> int i) + +isFloatOp :: Operand -> Bool +isFloatOp (OpReg _ (RegReal (RealRegSingle i))) | i > 31 = True +isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True +-- SIMD NCG TODO: what about VirtualVecV128? Could be floating-point or not? +isFloatOp _ = False + +pprInstr :: IsDoc doc => Platform -> Instr -> doc +pprInstr platform instr = case instr of + -- Meta Instructions --------------------------------------------------------- + -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable + COMMENT s -> dualDoc (asmComment s) empty + MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty + ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i) + + LOCATION file line' col _name + -> line (text "\t.loc" <+> int file <+> int line' <+> int col) + DELTA d -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty + -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable + NEWBLOCK blockid -> -- This is invalid assembly. But NEWBLOCK should never be contained + -- in the final instruction stream. But we still want to be able to + -- print it for debugging purposes. + line (text "BLOCK " <> pprAsmLabel platform (blockLbl blockid)) + + -- Pseudo Instructions ------------------------------------------------------- + + PUSH_STACK_FRAME -> lines_ [text "\tstp x29, x30, [sp, #-16]!", + text "\tmov x29, sp"] + + POP_STACK_FRAME -> line $ text "\tldp x29, x30, [sp], #16" + -- =========================================================================== + -- AArch64 Instruction Set + -- 1. Arithmetic Instructions ------------------------------------------------ + ADD o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfadd") o1 o2 o3 + | otherwise -> op3 (text "\tadd") o1 o2 o3 + CMP o1 o2 + | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfcmp") o1 o2 + | otherwise -> op2 (text "\tcmp") o1 o2 + CMN o1 o2 -> op2 (text "\tcmn") o1 o2 + MSUB o1 o2 o3 o4 -> op4 (text "\tmsub") o1 o2 o3 o4 + MUL o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfmul") o1 o2 o3 + | otherwise -> op3 (text "\tmul") o1 o2 o3 + SMULH o1 o2 o3 -> op3 (text "\tsmulh") o1 o2 o3 + SMULL o1 o2 o3 -> op3 (text "\tsmull") o1 o2 o3 + UMULH o1 o2 o3 -> op3 (text "\tumulh") o1 o2 o3 + UMULL o1 o2 o3 -> op3 (text "\tumull") o1 o2 o3 + NEG o1 o2 + | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfneg") o1 o2 + | otherwise -> op2 (text "\tneg") o1 o2 + SDIV o1 o2 o3 | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 + -> op3 (text "\tfdiv") o1 o2 o3 + SDIV o1 o2 o3 -> op3 (text "\tsdiv") o1 o2 o3 + + SUB o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfsub") o1 o2 o3 + | otherwise -> op3 (text "\tsub") o1 o2 o3 + UDIV o1 o2 o3 -> op3 (text "\tudiv") o1 o2 o3 + + -- 2. Bit Manipulation Instructions ------------------------------------------ + SBFM o1 o2 o3 o4 -> op4 (text "\tsbfm") o1 o2 o3 o4 + UBFM o1 o2 o3 o4 -> op4 (text "\tubfm") o1 o2 o3 o4 + CLZ o1 o2 -> op2 (text "\tclz") o1 o2 + RBIT o1 o2 -> op2 (text "\trbit") o1 o2 + REV o1 o2 -> op2 (text "\trev") o1 o2 + REV16 o1 o2 -> op2 (text "\trev16") o1 o2 + -- REV32 o1 o2 -> op2 (text "\trev32") o1 o2 + -- signed and unsigned bitfield extract + SBFX o1 o2 o3 o4 -> op4 (text "\tsbfx") o1 o2 o3 o4 + UBFX o1 o2 o3 o4 -> op4 (text "\tubfx") o1 o2 o3 o4 + SXTB o1 o2 -> op2 (text "\tsxtb") o1 o2 + UXTB o1 o2 -> op2 (text "\tuxtb") o1 o2 + SXTH o1 o2 -> op2 (text "\tsxth") o1 o2 + UXTH o1 o2 -> op2 (text "\tuxth") o1 o2 + + -- 3. Logical and Move Instructions ------------------------------------------ + AND o1 o2 o3 -> op3 (text "\tand") o1 o2 o3 + ASR o1 o2 o3 -> op3 (text "\tasr") o1 o2 o3 + EOR o1 o2 o3 -> op3 (text "\teor") o1 o2 o3 + LSL o1 o2 o3 -> op3 (text "\tlsl") o1 o2 o3 + LSR o1 o2 o3 -> op3 (text "\tlsr") o1 o2 o3 + MOV o1 o2 + | isFloatOp o1 || isFloatOp o2 -> op2 (text "\tfmov") o1 o2 + | otherwise -> op2 (text "\tmov") o1 o2 + MOVK o1 o2 -> op2 (text "\tmovk") o1 o2 + MOVZ o1 o2 -> op2 (text "\tmovz") o1 o2 + MVN o1 o2 -> op2 (text "\tmvn") o1 o2 + ORR o1 o2 o3 -> op3 (text "\torr") o1 o2 o3 + + -- 4. Branch Instructions ---------------------------------------------------- + J t -> pprInstr platform (B t) + J_TBL _ _ r -> pprInstr platform (B (TReg r)) + B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl + B (TReg r) -> line $ text "\tbr" <+> pprReg W64 r + + BL (TBlock bid) _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BL (TLabel lbl) _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl + BL (TReg r) _ -> line $ text "\tblr" <+> pprReg W64 r + + BCOND c (TBlock bid) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BCOND c (TLabel lbl) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform lbl + BCOND _ (TReg _) -> panic "AArch64.ppr: No conditional branching to registers!" + + -- 5. Atomic Instructions ---------------------------------------------------- + -- 6. Conditional Instructions ----------------------------------------------- + CSET o c -> line $ text "\tcset" <+> pprOp platform o <> comma <+> pprCond c + + CBZ o (TBlock bid) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + CBZ o (TLabel lbl) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl + CBZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbz) branching to registers!" + + CBNZ o (TBlock bid) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + CBNZ o (TLabel lbl) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl + CBNZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbnz) branching to registers!" + + -- 7. Load and Store Instructions -------------------------------------------- + -- NOTE: GHC may do whacky things where it only load the lower part of an + -- address. Not observing the correct size when loading will lead + -- inevitably to crashes. + STR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 -> + op2 (text "\tstrb") o1 o2 + STR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 -> + op2 (text "\tstrh") o1 o2 + STR _f o1 o2 -> op2 (text "\tstr") o1 o2 + STLR _f o1 o2 -> op2 (text "\tstlr") o1 o2 + + LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> + let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_ldr o1 (ldr') $$ + op_add o1 (check_off off) + + LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl -> + case platformOS platform of + OSMinGW32 -> + let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_add o1 add' $$ + op_add o1 (check_off off) + _ -> + let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_ldr o1 (ldr') $$ + op_add o1 (check_off off) + + LDR _f o1 (OpImm (ImmIndex lbl off)) -> + let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_add o1 (add') $$ + op_add o1 (check_off off) + + LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> + let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_ldr o1 (ldr') + + LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl -> + case platformOS platform of + OSMinGW32 -> + let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_add o1 add' + _ -> + let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_ldr o1 (ldr') + + LDR _f o1 (OpImm (ImmCLbl lbl)) -> + let (adrp', ldr') = op_adrp_reloc_local $ pprAsmLabel platform lbl in + op_adrp o1 adrp' $$ + op_add o1 ldr' + + LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 -> + op2 (text "\tldrb") o1 o2 + LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 -> + op2 (text "\tldrh") o1 o2 + LDR _f o1 o2 -> op2 (text "\tldr") o1 o2 + LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2 + + -- 8. Synchronization Instructions ------------------------------------------- + DMBISH DmbLoadStore -> line $ text "\tdmb ish" + DMBISH DmbLoad -> line $ text "\tdmb ishld" + + -- 9. Floating Point Instructions -------------------------------------------- + FMOV o1 o2 -> op2 (text "\tfmov") o1 o2 + FCVT o1 o2 -> op2 (text "\tfcvt") o1 o2 + SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2 + FCVTZS o1 o2 -> op2 (text "\tfcvtzs") o1 o2 + FABS o1 o2 -> op2 (text "\tfabs") o1 o2 + FSQRT o1 o2 -> op2 (text "\tfsqrt") o1 o2 + FMIN o1 o2 o3 -> op3 (text "\tfmin") o1 o2 o3 + FMAX o1 o2 o3 -> op3 (text "\tfmax") o1 o2 o3 + FMA variant d r1 r2 r3 -> + let fma = case variant of + FMAdd -> text "\tfmadd" + FMSub -> text "\tfmsub" + FNMAdd -> text "\tfnmadd" + FNMSub -> text "\tfnmsub" + in op4 fma d r1 r2 r3 + where op2 op o1 o2 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 + op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 + op_ldr o1 rest = line $ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> rest <> text "]" + op_adrp o1 rest = line $ text "\tadrp" <+> pprOp platform o1 <> comma <+> rest + op_add o1 rest = line $ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> rest + + op_adrp_reloc_dynamic asm_lbl = case platformOS platform of + OSDarwin -> (asm_lbl <> text "@gotpage", asm_lbl <> text "@gotpageoff") + OSLinux -> (text ":got:" <> asm_lbl, text ":got_lo12:" <> asm_lbl) + OSMinGW32 -> (text "__imp_" <> asm_lbl, text ":lo12:__imp_" <> asm_lbl) + os' -> pgmError $ "GHC.CmmToAsm.AArch64.Ppr.op_adrp_reloc_dynamic : " ++ show os' ++ " is unsuppported by relocations" + + op_adrp_reloc_local asm_lbl = case platformOS platform of + OSDarwin -> (asm_lbl <> text "@page", asm_lbl <> text "@pageoff") + OSLinux -> (asm_lbl, text ":lo12:" <> asm_lbl) + OSMinGW32 -> (asm_lbl, text ":lo12:" <> asm_lbl) + os' -> pgmError $ "GHC.CmmToAsm.AArch64.Ppr.op_adrp_reloc_local : " ++ show os' ++ " is unsuppported by relocations" + + check_off off = if off >= 0 && off <= 4095 then char '#' <> int off else + pgmError $ "GHC.CmmToAsm.AArch64.Ppr.check_off : " ++ show off ++ " is out of 12 bit" + +pprBcond :: IsLine doc => Cond -> doc +pprBcond c = text "b." <> pprCond c + +pprCond :: IsLine doc => Cond -> doc +pprCond c = case c of + ALWAYS -> text "al" -- Always + EQ -> text "eq" -- Equal + NE -> text "ne" -- Not Equal + + SLT -> text "lt" -- Signed less than ; Less than, or unordered + SLE -> text "le" -- Signed less than or equal ; Less than or equal, or unordered + SGE -> text "ge" -- Signed greater than or equal ; Greater than or equal + SGT -> text "gt" -- Signed greater than ; Greater than + + ULT -> text "lo" -- Carry clear/ unsigned lower ; less than + ULE -> text "ls" -- Unsigned lower or same ; Less than or equal + UGE -> text "hs" -- Carry set/unsigned higher or same ; Greater than or equal, or unordered + UGT -> text "hi" -- Unsigned higher ; Greater than, or unordered + + -- NEVER -> text "nv" -- Never + VS -> text "vs" -- Overflow ; Unordered (at least one NaN operand) + VC -> text "vc" -- No overflow ; Not unordered + + -- Ordered variants. Respecting NaN. + OLT -> text "mi" + OLE -> text "ls" + OGE -> text "ge" + OGT -> text "gt" + + -- Unordered + UOLT -> text "lt" + UOLE -> text "le" + UOGE -> text "pl" + UOGT -> text "hi" diff --git a/GHC/CmmToAsm/AArch64/RegInfo.hs b/GHC/CmmToAsm/AArch64/RegInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/AArch64/RegInfo.hs @@ -0,0 +1,29 @@ +module GHC.CmmToAsm.AArch64.RegInfo where + +import GHC.Prelude + +import GHC.CmmToAsm.AArch64.Instr +import GHC.Cmm.BlockId +import GHC.Cmm + +import GHC.Utils.Outputable + +data JumpDest = DestBlockId BlockId + +-- Debug Instance +instance Outputable JumpDest where + ppr (DestBlockId bid) = text "jd:" <> ppr bid + +-- Implementations of the methods of 'NgcImpl' + +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid + +canShortcut :: Instr -> Maybe JumpDest +canShortcut _ = Nothing + +shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics +shortcutStatics _ other_static = other_static + +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump _ other = other diff --git a/GHC/CmmToAsm/AArch64/Regs.hs b/GHC/CmmToAsm/AArch64/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/AArch64/Regs.hs @@ -0,0 +1,153 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module GHC.CmmToAsm.AArch64.Regs where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Platform.Reg +import GHC.Platform.Reg.Class.Unified +import GHC.CmmToAsm.Format + +import GHC.Cmm +import GHC.Cmm.CLabel ( CLabel ) +import GHC.Types.Unique + +import GHC.Platform.Regs +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform + +-- TODO: Should this include the zero register? +allMachRegNos :: [RegNo] +allMachRegNos = [0..31] ++ [32..63] +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform + = let isFree i = freeReg platform i + in map RealRegSingle $ filter isFree allMachRegNos + + +-- argRegs is the set of regs which are read for an n-argument call to C. +allGpArgRegs :: [Reg] +allGpArgRegs = map regSingle [0..7] +allFpArgRegs :: [Reg] +allFpArgRegs = map regSingle [32..39] + +-- STG: +-- 19: Base +-- 20: Sp +-- 21: Hp +-- 22-27: R1-R6 +-- 28: SpLim + +-- This is the STG Sp reg. +-- sp :: Reg +-- sp = regSingle 20 + +-- addressing modes ------------------------------------------------------------ + +data AddrMode + = AddrRegReg Reg Reg + | AddrRegImm Reg Imm + | AddrReg Reg + deriving (Eq, Show) + +-- ----------------------------------------------------------------------------- +-- Immediates + +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit FastString + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + deriving (Eq, Show) + +strImmLit :: FastString -> Imm +strImmLit s = ImmLit s + + +litToImm :: CmmLit -> Imm +litToImm (CmmInt i w) = ImmInteger (narrowS w i) + -- narrow to the width: a CmmInt might be out of + -- range, but we assume that ImmInteger only contains + -- in-range values. A signed value should be fine here. + -- AK: We do call this with out of range values, however + -- it just truncates as we would expect. +litToImm (CmmFloat f W32) = ImmFloat f +litToImm (CmmFloat f W64) = ImmDouble f +litToImm (CmmLabel l) = ImmCLbl l +litToImm (CmmLabelOff l off) = ImmIndex l off +litToImm (CmmLabelDiffOff l1 l2 off _) + = ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) +litToImm _ = panic "AArch64.Regs.litToImm: no match" + + +-- == To satisfy GHC.CmmToAsm.Reg.Target ======================================= + +-- squeese functions for the graph allocator ----------------------------------- +-- | regSqueeze_class reg +-- Calculate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> Int +virtualRegSqueeze cls vr + = case cls of + RcInteger + -> case vr of + VirtualRegI{} -> 1 + VirtualRegHi{} -> 1 + _other -> 0 + + RcFloatOrVector + -> case vr of + VirtualRegD{} -> 1 + VirtualRegV128{} -> 1 + _other -> 0 + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> Int +realRegSqueeze cls rr + = case cls of + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> 1 -- first fp reg is 32 + | otherwise -> 0 + + RcFloatOrVector + -> case rr of + RealRegSingle regNo + | regNo < 32 -> 0 + | otherwise -> 1 + +mkVirtualReg :: Unique -> Format -> VirtualReg +mkVirtualReg u format + | not (isFloatFormat format) = VirtualRegI u + | otherwise + = case format of + FF32 -> VirtualRegD u + FF64 -> VirtualRegD u + _ -> panic "AArch64.mkVirtualReg" + +{-# INLINE classOfRealReg #-} +classOfRealReg :: RealReg -> RegClass +classOfRealReg (RealRegSingle i) + | i < 32 = RcInteger + | otherwise = RcFloatOrVector + +regDotColor :: RealReg -> SDoc +regDotColor reg + = case classOfRealReg reg of + RcInteger -> text "blue" + RcFloatOrVector -> text "red" diff --git a/GHC/CmmToAsm/BlockLayout.hs b/GHC/CmmToAsm/BlockLayout.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/BlockLayout.hs @@ -0,0 +1,921 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- +-- Copyright (c) 2018 Andreas Klebinger +-- + +module GHC.CmmToAsm.BlockLayout + ( sequenceTop, backendMaintainsCfg) +where + +import GHC.Prelude hiding (head, init, last, tail) +import qualified GHC.Prelude as Partial (head, tail) + +import GHC.Platform + +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Config + +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label + +import GHC.Types.Unique.FM + +import GHC.Data.Graph.Directed +import GHC.Data.Maybe +import GHC.Data.List.SetOps (removeDups) +import GHC.Data.OrdList + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import Data.List (sortOn, sortBy, nub) +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Foldable (toList) +import qualified Data.Set as Set +import Data.STRef +import Control.Monad.ST.Strict +import Control.Monad (foldM, unless) +import GHC.Data.UnionFind +import GHC.Types.Unique.DSM (UniqDSM) + +{- + Note [CFG based code layout] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + The major steps in placing blocks are as follow: + * Compute a CFG based on the Cmm AST, see getCfgProc. + This CFG will have edge weights representing a guess + on how important they are. + * After we convert Cmm to Asm we run `optimizeCFG` which + adds a few more "educated guesses" to the equation. + * Then we run loop analysis on the CFG (`loopInfo`) which tells us + about loop headers, loop nesting levels and the sort. + * Based on the CFG and loop information refine the edge weights + in the CFG and normalize them relative to the most often visited + node. (See `mkGlobalWeights`) + * Feed this CFG into the block layout code (`sequenceTop`) in this + module. Which will then produce a code layout based on the input weights. + + + Note [Chain based CFG serialization] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + For additional information also look at + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout + + We have a CFG with edge weights based on which we try to place blocks next to + each other. + + Edge weights not only represent likelihood of control transfer between blocks + but also how much a block would benefit from being placed sequentially after + it's predecessor. + For example blocks which are preceded by an info table are more likely to end + up in a different cache line than their predecessor and we can't eliminate the jump + so there is less benefit to placing them sequentially. + + For example consider this example: + + A: ... + jmp cond D (weak successor) + jmp B + B: ... + jmp C + C: ... + jmp X + D: ... + jmp B (weak successor) + + We determine a block layout by building up chunks (calling them chains) of + possible control flows for which blocks will be placed sequentially. + + Eg for our example we might end up with two chains like: + [A->B->C->X],[D]. Blocks inside chains will always be placed sequentially. + However there is no particular order in which chains are placed since + (hopefully) the blocks for which sequentiality is important have already + been placed in the same chain. + + ----------------------------------------------------------------------------- + 1) First try to create a list of good chains. + ----------------------------------------------------------------------------- + + Good chains are these which allow us to eliminate jump instructions. + Which further eliminate often executed jumps first. + + We do so by: + + *) Ignore edges which represent instructions which can not be replaced + by fall through control flow. Primarily calls and edges to blocks which + are prefixed by a info table we have to jump across. + + *) Then process remaining edges in order of frequency taken and: + + +) If source and target have not been placed build a new chain from them. + + +) If source and target have been placed, and are ends of differing chains + try to merge the two chains. + + +) If one side of the edge is a end/front of a chain, add the other block of + to edge to the same chain + + Eg if we look at edge (B -> C) and already have the chain (A -> B) + then we extend the chain to (A -> B -> C). + + +) If the edge was used to modify or build a new chain remove the edge from + our working list. + + *) If there any blocks not being placed into a chain after these steps we place + them into a chain consisting of only this block. + + Ranking edges by their taken frequency, if + two edges compete for fall through on the same target block, the one taken + more often will automatically win out. Resulting in fewer instructions being + executed. + + Creating singleton chains is required for situations where we have code of the + form: + + A: goto B: + + B: goto C: + + C: ... + + As the code in block B is only connected to the rest of the program via edges + which will be ignored in this step we make sure that B still ends up in a chain + this way. + + ----------------------------------------------------------------------------- + 2) We also try to fuse chains. + ----------------------------------------------------------------------------- + + As a result from the above step we still end up with multiple chains which + represent sequential control flow chunks. But they are not yet suitable for + code layout as we need to place *all* blocks into a single sequence. + + In this step we combine chains result from the above step via these steps: + + *) Look at the ranked list of *all* edges, including calls/jumps across info tables + and the like. + + *) Look at each edge and + + +) Given an edge (A -> B) try to find two chains for which + * Block A is at the end of one chain + * Block B is at the front of the other chain. + +) If we find such a chain we "fuse" them into a single chain, remove the + edge from working set and continue. + +) If we can't find such chains we skip the edge and continue. + + ----------------------------------------------------------------------------- + 3) Place indirect successors (neighbours) after each other + ----------------------------------------------------------------------------- + + We might have chains [A,B,C,X],[E] in a CFG of the sort: + + A ---> B ---> C --------> X(exit) + \- ->E- -/ + + While E does not follow X it's still beneficial to place them near each other. + This can be advantageous if eg C,X,E will end up in the same cache line. + + + Note [Triangle Control Flow] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Checking if an argument is already evaluated leads to a somewhat + special case which looks like this: + + A: + if (R1 & 7 != 0) goto Leval; else goto Lwork; + Leval: // global + call (I64[R1])(R1) returns to Lwork, args: 8, res: 8, upd: 8; + Lwork: // global + ... + + A + |\ + | Leval + |/ - (This edge can be missing because of optimizations) + Lwork + + Once we hit the metal the call instruction is just 2-3 bytes large + depending on the register used. So we lay out the assembly like this: + + movq %rbx,%rax + andl $7,%eax + cmpq $1,%rax + jne Lwork + Leval: + jmp *(%rbx) # encoded in 2-3 bytes. + + Lwork: + ... + + We could explicitly check for this control flow pattern. + + This is advantageous because: + * It's optimal if the argument isn't evaluated. + * If it's evaluated we only have the extra cost of jumping over + the 2-3 bytes for the call. + * Guarantees the smaller encoding for the conditional jump. + + However given that Lwork usually has an info table we + penalize this edge. So Leval should get placed first + either way and things work out for the best. + + Optimizing for the evaluated case instead would penalize + the other code path. It adds an jump as we can't fall through + to Lwork because of the info table. + Assuming that Lwork is large the chance that the "call" ends up + in the same cache line is also fairly small. + + + Note [Layout relevant edge weights] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The input to the chain based code layout algorithm is a CFG + with edges annotated with their frequency. The frequency + of traversal corresponds quite well to the cost of not placing + the connected blocks next to each other. + + However even if having the same frequency certain edges are + inherently more or less relevant to code layout. + + In particular: + + * Edges which cross an info table are less relevant than others. + + If we place the blocks across this edge next to each other + they are still separated by the info table which negates + much of the benefit. It makes it less likely both blocks + will share a cache line reducing the benefits from locality. + But it also prevents us from eliminating jump instructions. + + * Conditional branches and switches are slightly less relevant. + + We can completely remove unconditional jumps by placing them + next to each other. This is not true for conditional branch edges. + We apply a small modifier to them to ensure edges for which we can + eliminate the overhead completely are considered first. See also #18053. + + * Edges constituted by a call are ignored. + + Considering these hardly helped with performance and ignoring + them helps quite a bit to improve compiler performance. + + So we perform a preprocessing step where we apply a multiplicator + to these kinds of edges. + + -} + + +-- | Look at X number of blocks in two chains to determine +-- if they are "neighbours". +neighbourOverlapp :: Int +neighbourOverlapp = 2 + +-- | Maps blocks near the end of a chain to it's chain AND +-- the other blocks near the end. +-- [A,B,C,D,E] Gives entries like (B -> ([A,B], [A,B,C,D,E])) +-- where [A,B] are blocks in the end region of a chain. +-- This is cheaper then recomputing the ends multiple times. +type FrontierMap = LabelMap ([BlockId],BlockChain) + +-- | A non empty ordered sequence of basic blocks. +-- It is suitable for serialization in this order. +-- +-- We use OrdList instead of [] to allow fast append on both sides +-- when combining chains. +newtype BlockChain + = BlockChain { chainBlocks :: (OrdList BlockId) } + +-- All chains are constructed the same way so comparison +-- including structure is faster. +instance Eq BlockChain where + BlockChain b1 == BlockChain b2 = strictlyEqOL b1 b2 + +-- Useful for things like sets and debugging purposes, sorts by blocks +-- in the chain. +instance Ord (BlockChain) where + (BlockChain lbls1) `compare` (BlockChain lbls2) + = assert (toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2) $ + strictlyOrdOL lbls1 lbls2 + +instance Outputable (BlockChain) where + ppr (BlockChain blks) = + parens (text "Chain:" <+> ppr (fromOL $ blks) ) + +chainFoldl :: (b -> BlockId -> b) -> b -> BlockChain -> b +chainFoldl f z (BlockChain blocks) = foldl' f z blocks + +noDups :: [BlockChain] -> Bool +noDups chains = + let chainBlocks = concatMap chainToBlocks chains :: [BlockId] + (_blocks, dups) = removeDups compare chainBlocks + in if null dups then True + else pprTrace "Duplicates:" (ppr (map toList dups) $$ text "chains" <+> ppr chains ) False + +inFront :: BlockId -> BlockChain -> Bool +inFront bid (BlockChain seq) + = headOL seq == bid + +chainSingleton :: BlockId -> BlockChain +chainSingleton lbl + = BlockChain (unitOL lbl) + +chainFromList :: [BlockId] -> BlockChain +chainFromList = BlockChain . toOL + +chainSnoc :: BlockChain -> BlockId -> BlockChain +chainSnoc (BlockChain blks) lbl + = BlockChain (blks `snocOL` lbl) + +chainCons :: BlockId -> BlockChain -> BlockChain +chainCons lbl (BlockChain blks) + = BlockChain (lbl `consOL` blks) + +chainConcat :: BlockChain -> BlockChain -> BlockChain +chainConcat (BlockChain blks1) (BlockChain blks2) + = BlockChain (blks1 `appOL` blks2) + +chainToBlocks :: BlockChain -> [BlockId] +chainToBlocks (BlockChain blks) = fromOL blks + +-- | Given the Chain A -> B -> C -> D and we break at C +-- we get the two Chains (A -> B, C -> D) as result. +breakChainAt :: BlockId -> BlockChain + -> (BlockChain,BlockChain) +breakChainAt bid (BlockChain blks) + | not (bid == Partial.head rblks) + = panic "Block not in chain" + | otherwise + = (BlockChain (toOL lblks), + BlockChain (toOL rblks)) + where + (lblks, rblks) = break (\lbl -> lbl == bid) (fromOL blks) + +takeR :: Int -> BlockChain -> [BlockId] +takeR n (BlockChain blks) = + take n . fromOLReverse $ blks + +takeL :: Int -> BlockChain -> [BlockId] +takeL n (BlockChain blks) = + take n . fromOL $ blks + + +-- Note [Combining neighborhood chains] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- See also Note [Chain based CFG serialization] +-- We have the chains (A-B-C-D) and (E-F) and an Edge C->E. +-- +-- While placing the latter after the former doesn't result in sequential +-- control flow it is still beneficial. As block C and E might end +-- up in the same cache line. +-- +-- So we place these chains next to each other even if we can't fuse them. +-- +-- A -> B -> C -> D +-- v +-- - -> E -> F ... +-- +-- A simple heuristic to chose which chains we want to combine: +-- * Process edges in descending priority. +-- * Check if there is a edge near the end of one chain which goes +-- to a block near the start of another edge. +-- +-- While we could take into account the space between the two blocks which +-- share an edge this blows up compile times quite a bit. It requires +-- us to find all edges between two chains, check the distance for all edges, +-- rank them based on the distance and only then we can select two chains +-- to combine. Which would add a lot of complexity for little gain. +-- +-- So instead we just rank by the strength of the edge and use the first pair we +-- find. + +-- | For a given list of chains and edges try to combine chains with strong +-- edges between them. +combineNeighbourhood :: [CfgEdge] -- ^ Edges to consider + -> [BlockChain] -- ^ Current chains of blocks + -> ([BlockChain], Set.Set (BlockId,BlockId)) + -- ^ Resulting list of block chains, and a set of edges which + -- were used to fuse chains and as such no longer need to be + -- considered. +combineNeighbourhood edges chains + = -- pprTraceIt "Neighbours" $ + -- pprTrace "combineNeighbours" (ppr edges) $ + applyEdges edges endFrontier startFrontier (Set.empty) + where + --Build maps from chain ends to chains + endFrontier, startFrontier :: FrontierMap + endFrontier = + mapFromList $ concatMap (\chain -> + let ends = getEnds chain :: [BlockId] + entry = (ends,chain) + in map (\x -> (x,entry)) ends ) chains + startFrontier = + mapFromList $ concatMap (\chain -> + let front = getFronts chain + entry = (front,chain) + in map (\x -> (x,entry)) front) chains + applyEdges :: [CfgEdge] -> FrontierMap -> FrontierMap -> Set.Set (BlockId, BlockId) + -> ([BlockChain], Set.Set (BlockId,BlockId)) + applyEdges [] chainEnds _chainFronts combined = + (ordNub $ map snd $ mapElems chainEnds, combined) + applyEdges ((CfgEdge from to _w):edges) chainEnds chainFronts combined + | Just (c1_e,c1) <- mapLookup from chainEnds + , Just (c2_f,c2) <- mapLookup to chainFronts + , c1 /= c2 -- Avoid trying to concat a chain with itself. + = let newChain = chainConcat c1 c2 + newChainFrontier = getFronts newChain + newChainEnds = getEnds newChain + newFronts :: FrontierMap + newFronts = + let withoutOld = + foldl' (\m b -> mapDelete b m :: FrontierMap) chainFronts (c2_f ++ getFronts c1) + entry = + (newChainFrontier,newChain) --let bound to ensure sharing + in foldl' (\m x -> mapInsert x entry m) + withoutOld newChainFrontier + + newEnds = + let withoutOld = foldl' (\m b -> mapDelete b m) chainEnds (c1_e ++ getEnds c2) + entry = (newChainEnds,newChain) --let bound to ensure sharing + in foldl' (\m x -> mapInsert x entry m) + withoutOld newChainEnds + in + -- pprTrace "ApplyEdges" + -- (text "before" $$ + -- text "fronts" <+> ppr chainFronts $$ + -- text "ends" <+> ppr chainEnds $$ + + -- text "various" $$ + -- text "newChain" <+> ppr newChain $$ + -- text "newChainFrontier" <+> ppr newChainFrontier $$ + -- text "newChainEnds" <+> ppr newChainEnds $$ + -- text "drop" <+> ppr ((c2_f ++ getFronts c1) ++ (c1_e ++ getEnds c2)) $$ + + -- text "after" $$ + -- text "fronts" <+> ppr newFronts $$ + -- text "ends" <+> ppr newEnds + -- ) + applyEdges edges newEnds newFronts (Set.insert (from,to) combined) + | otherwise + = applyEdges edges chainEnds chainFronts combined + + getFronts chain = takeL neighbourOverlapp chain + getEnds chain = takeR neighbourOverlapp chain + +-- In the last stop we combine all chains into a single one. +-- Trying to place chains with strong edges next to each other. +mergeChains :: [CfgEdge] -> [BlockChain] + -> (BlockChain) +mergeChains edges chains + = runST $ do + let addChain m0 chain = do + ref <- fresh chain + return $ chainFoldl (\m' b -> mapInsert b ref m') m0 chain + chainMap' <- foldM (\m0 c -> addChain m0 c) mapEmpty chains + merge edges chainMap' + where + -- We keep a map from ALL blocks to their respective chain (sigh) + -- This is required since when looking at an edge we need to find + -- the associated chains quickly. + -- We use a union-find data structure to do this efficiently. + + merge :: forall s. [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain + merge [] chains = do + chains' <- mapM find =<< (nub <$> (mapM repr $ mapElems chains)) :: ST s [BlockChain] + return $ foldl' chainConcat (Partial.head chains') (Partial.tail chains') + merge ((CfgEdge from to _):edges) chains + -- | pprTrace "merge" (ppr (from,to) <> ppr chains) False + -- = undefined + = do + same <- equivalent cFrom cTo + unless same $ do + cRight <- find cTo + cLeft <- find cFrom + new_point <- fresh (chainConcat cLeft cRight) + union cTo new_point + union cFrom new_point + merge edges chains + where + cFrom = expectJust $ mapLookup from chains + cTo = expectJust $ mapLookup to chains + + +-- See Note [Chain based CFG serialization] for the general idea. +-- This creates and fuses chains at the same time for performance reasons. + +-- Try to build chains from a list of edges. +-- Edges must be sorted **descending** by their priority. +-- Returns the constructed chains, along with all edges which +-- are irrelevant past this point, this information doesn't need +-- to be complete - it's only used to speed up the process. +-- An Edge is irrelevant if the ends are part of the same chain. +-- We say these edges are already linked +buildChains :: [CfgEdge] -> [BlockId] + -> ( LabelMap BlockChain -- Resulting chains, indexed by end if chain. + , Set.Set (BlockId, BlockId)) --List of fused edges. +buildChains edges blocks + = runST $ buildNext setEmpty mapEmpty mapEmpty edges Set.empty + where + -- buildNext builds up chains from edges one at a time. + + -- We keep a map from the ends of chains to the chains. + -- This way we can easily check if an block should be appended to an + -- existing chain! + -- We store them using STRefs so we don't have to rebuild the spine of both + -- maps every time we update a chain. + buildNext :: forall s. LabelSet + -> LabelMap (STRef s BlockChain) -- Map from end of chain to chain. + -> LabelMap (STRef s BlockChain) -- Map from start of chain to chain. + -> [CfgEdge] -- Edges to check - ordered by decreasing weight + -> Set.Set (BlockId, BlockId) -- Used edges + -> ST s ( LabelMap BlockChain -- Chains by end + , Set.Set (BlockId, BlockId) --List of fused edges + ) + buildNext placed _chainStarts chainEnds [] linked = do + ends' <- sequence $ mapMap readSTRef chainEnds :: ST s (LabelMap BlockChain) + -- Any remaining blocks have to be made to singleton chains. + -- They might be combined with other chains later on outside this function. + let unplaced = filter (\x -> not (setMember x placed)) blocks + singletons = map (\x -> (x,chainSingleton x)) unplaced :: [(BlockId,BlockChain)] + return (foldl' (\m (k,v) -> mapInsert k v m) ends' singletons , linked) + buildNext placed chainStarts chainEnds (edge:todo) linked + | from == to + -- We skip self edges + = buildNext placed chainStarts chainEnds todo (Set.insert (from,to) linked) + | not (alreadyPlaced from) && + not (alreadyPlaced to) + = do + --pprTraceM "Edge-Chain:" (ppr edge) + chain' <- newSTRef $ chainFromList [from,to] + buildNext + (setInsert to (setInsert from placed)) + (mapInsert from chain' chainStarts) + (mapInsert to chain' chainEnds) + todo + (Set.insert (from,to) linked) + + | (alreadyPlaced from) && + (alreadyPlaced to) + , Just predChain <- mapLookup from chainEnds + , Just succChain <- mapLookup to chainStarts + , predChain /= succChain -- Otherwise we try to create a cycle. + = fuseChain predChain succChain + + | (alreadyPlaced from) && + (alreadyPlaced to) + = buildNext placed chainStarts chainEnds todo linked + + | otherwise + = findChain + where + from = edgeFrom edge + to = edgeTo edge + alreadyPlaced blkId = (setMember blkId placed) + + -- Combine two chains into a single one. + fuseChain :: STRef s BlockChain -> STRef s BlockChain + -> ST s ( LabelMap BlockChain -- Chains by end + , Set.Set (BlockId, BlockId) --List of fused edges + ) + fuseChain fromRef toRef = do + fromChain <- readSTRef fromRef + toChain <- readSTRef toRef + let newChain = chainConcat fromChain toChain + ref <- newSTRef newChain + let start = Partial.head $ takeL 1 newChain + let end = Partial.head $ takeR 1 newChain + -- chains <- sequence $ mapMap readSTRef chainStarts + -- pprTraceM "pre-fuse chains:" $ ppr chains + buildNext + placed + (mapInsert start ref $ mapDelete to $ chainStarts) + (mapInsert end ref $ mapDelete from $ chainEnds) + todo + (Set.insert (from,to) linked) + + + --Add the block to a existing chain or creates a new chain + findChain :: ST s ( LabelMap BlockChain -- Chains by end + , Set.Set (BlockId, BlockId) --List of fused edges + ) + findChain + -- We can attach the block to the end of a chain + | alreadyPlaced from + , Just predChain <- mapLookup from chainEnds + = do + chain <- readSTRef predChain + let newChain = chainSnoc chain to + writeSTRef predChain newChain + let chainEnds' = mapInsert to predChain $ mapDelete from chainEnds + -- chains <- sequence $ mapMap readSTRef chainStarts + -- pprTraceM "from chains:" $ ppr chains + buildNext (setInsert to placed) chainStarts chainEnds' todo (Set.insert (from,to) linked) + -- We can attack it to the front of a chain + | alreadyPlaced to + , Just succChain <- mapLookup to chainStarts + = do + chain <- readSTRef succChain + let newChain = from `chainCons` chain + writeSTRef succChain newChain + let chainStarts' = mapInsert from succChain $ mapDelete to chainStarts + -- chains <- sequence $ mapMap readSTRef chainStarts' + -- pprTraceM "to chains:" $ ppr chains + buildNext (setInsert from placed) chainStarts' chainEnds todo (Set.insert (from,to) linked) + -- The placed end of the edge is part of a chain already and not an end. + | otherwise + = do + let block = if alreadyPlaced to then from else to + --pprTraceM "Singleton" $ ppr block + let newChain = chainSingleton block + ref <- newSTRef newChain + buildNext (setInsert block placed) (mapInsert block ref chainStarts) + (mapInsert block ref chainEnds) todo (linked) + where + alreadyPlaced blkId = (setMember blkId placed) + +-- | Place basic blocks based on the given CFG. +-- See Note [Chain based CFG serialization] +sequenceChain :: forall a i. Instruction i + => LabelMap a -- ^ Keys indicate an info table on the block. + -> CFG -- ^ Control flow graph and some meta data. + -> [GenBasicBlock i] -- ^ List of basic blocks to be placed. + -> [GenBasicBlock i] -- ^ Blocks placed in sequence. +sequenceChain _info _weights [] = [] +sequenceChain _info _weights [x] = [x] +sequenceChain info weights blocks@((BasicBlock entry _):_) = + let directEdges :: [CfgEdge] + directEdges = sortBy (flip compare) $ mapMaybe relevantWeight (infoEdgeList weights) + where + -- Apply modifiers to turn edge frequencies into useable weights + -- for computing code layout. + -- See also Note [Layout relevant edge weights] + relevantWeight :: CfgEdge -> Maybe CfgEdge + relevantWeight edge@(CfgEdge from to edgeInfo) + | (EdgeInfo CmmSource { trans_cmmNode = CmmCall {} } _) <- edgeInfo + -- Ignore edges across calls. + = Nothing + | mapMember to info + , w <- edgeWeight edgeInfo + -- The payoff is quite small if we jump over an info table + = Just (CfgEdge from to edgeInfo { edgeWeight = w/8 }) + | (EdgeInfo CmmSource { trans_cmmNode = exitNode } _) <- edgeInfo + , cantEliminate exitNode + , w <- edgeWeight edgeInfo + -- A small penalty to edge types which + -- we can't optimize away by layout. + -- w * 0.96875 == w - w/32 + = Just (CfgEdge from to edgeInfo { edgeWeight = w * 0.96875 }) + | otherwise + = Just edge + where + cantEliminate CmmCondBranch {} = True + cantEliminate CmmSwitch {} = True + cantEliminate _ = False + + blockMap :: LabelMap (GenBasicBlock i) + blockMap + = foldl' (\m blk@(BasicBlock lbl _ins) -> + mapInsert lbl blk m) + mapEmpty blocks + + (builtChains, builtEdges) + = {-# SCC "buildChains" #-} + --pprTraceIt "generatedChains" $ + --pprTrace "blocks" (ppr (mapKeys blockMap)) $ + buildChains directEdges (mapKeys blockMap) + + rankedEdges :: [CfgEdge] + -- Sort descending by weight, remove fused edges + rankedEdges = + filter (\edge -> not (Set.member (edgeFrom edge,edgeTo edge) builtEdges)) $ + directEdges + + (neighbourChains, combined) + = assert (noDups $ mapElems builtChains) $ + {-# SCC "groupNeighbourChains" #-} + -- pprTraceIt "NeighbourChains" $ + combineNeighbourhood rankedEdges (mapElems builtChains) + + + allEdges :: [CfgEdge] + allEdges = {-# SCC allEdges #-} + sortOn (relevantWeight) $ filter (not . deadEdge) $ (infoEdgeList weights) + where + deadEdge :: CfgEdge -> Bool + deadEdge (CfgEdge from to _) = let e = (from,to) in Set.member e combined || Set.member e builtEdges + relevantWeight :: CfgEdge -> EdgeWeight + relevantWeight (CfgEdge _ _ edgeInfo) + | EdgeInfo (CmmSource { trans_cmmNode = CmmCall {}}) _ <- edgeInfo + -- Penalize edges across calls + = weight/(64.0) + | otherwise + = weight + where + -- negate to sort descending + weight = negate (edgeWeight edgeInfo) + + masterChain = + {-# SCC "mergeChains" #-} + -- pprTraceIt "MergedChains" $ + mergeChains allEdges neighbourChains + + --Make sure the first block stays first + prepedChains + | inFront entry masterChain + = [masterChain] + | (rest,entry) <- breakChainAt entry masterChain + = [entry,rest] + + blockList + = assert (noDups [masterChain]) + (concatMap fromOL $ map chainBlocks prepedChains) + + --chainPlaced = setFromList $ map blockId blockList :: LabelSet + chainPlaced = setFromList $ blockList :: LabelSet + unplaced = + let blocks = mapKeys blockMap + isPlaced b = setMember (b) chainPlaced + in filter (\block -> not (isPlaced block)) blocks + + placedBlocks = + -- We want debug builds to catch this as it's a good indicator for + -- issues with CFG invariants. But we don't want to blow up production + -- builds if something slips through. + assert (null unplaced) $ + --pprTraceIt "placedBlocks" $ + -- ++ [] is still kinda expensive + if null unplaced then blockList else blockList ++ unplaced + getBlock bid = expectJust $ mapLookup bid blockMap + in + --Assert we placed all blocks given as input + assert (all (\bid -> mapMember bid blockMap) placedBlocks) $ + dropJumps info $ map getBlock placedBlocks + +{-# SCC dropJumps #-} +-- | Remove redundant jumps between blocks when we can rely on +-- fall through. +dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i] + -> [GenBasicBlock i] +dropJumps _ [] = [] +dropJumps info (BasicBlock lbl ins:todo) + | Just ins <- nonEmpty ins --This can happen because of shortcutting + , BasicBlock nextLbl _ : _ <- todo + , canFallthroughTo (NE.last ins) nextLbl + , not (mapMember nextLbl info) + = BasicBlock lbl (NE.init ins) : dropJumps info todo + | otherwise + = BasicBlock lbl ins : dropJumps info todo + + +-- ----------------------------------------------------------------------------- +-- Sequencing the basic blocks + +-- Cmm BasicBlocks are self-contained entities: they always end in a +-- jump, either non-local or to another basic block in the same proc. +-- In this phase, we attempt to place the basic blocks in a sequence +-- such that as many of the local jumps as possible turn into +-- fallthroughs. + +sequenceTop + :: Instruction instr + => NcgImpl statics instr jumpDest + -> Maybe CFG -- ^ CFG if we have one. + -> NatCmmDecl statics instr -- ^ Function to serialize + -> UniqDSM (NatCmmDecl statics instr) + +sequenceTop _ _ top@(CmmData _ _) = pure top +sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks)) = do + let config = ncgConfig ncgImpl + platform = ncgPlatform config + + seq_blocks = + if -- Chain based algorithm + | ncgCfgBlockLayout config + , backendMaintainsCfg platform + , Just cfg <- edgeWeights + -> {-# SCC layoutBlocks #-} sequenceChain info cfg blocks + + -- Old algorithm without edge weights + | ncgCfgWeightlessLayout config + || not (backendMaintainsCfg platform) + -> {-# SCC layoutBlocks #-} sequenceBlocks Nothing info blocks + + -- Old algorithm with edge weights (if any) + | otherwise + -> {-# SCC layoutBlocks #-} sequenceBlocks edgeWeights info blocks + + far_blocks <- (ncgMakeFarBranches ncgImpl) platform info seq_blocks + pure $ CmmProc info lbl live $ ListGraph far_blocks + + +-- The old algorithm: +-- It is very simple (and stupid): We make a graph out of +-- the blocks where there is an edge from one block to another iff the +-- first block ends by jumping to the second. Then we topologically +-- sort this graph. Then traverse the list: for each block, we first +-- output the block, then if it has an out edge, we move the +-- destination of the out edge to the front of the list, and continue. + +-- FYI, the classic layout for basic blocks uses postorder DFS; this +-- algorithm is implemented in Hoopl. + +sequenceBlocks :: Instruction inst => Maybe CFG -> LabelMap a + -> [GenBasicBlock inst] -> [GenBasicBlock inst] +sequenceBlocks _edgeWeight _ [] = [] +sequenceBlocks edgeWeights infos (entry:blocks) = + let entryNode = mkNode edgeWeights entry + bodyNodes = reverse + (flattenSCCs (sccBlocks edgeWeights blocks)) + in dropJumps infos . seqBlocks infos $ ( entryNode : bodyNodes) + -- the first block is the entry point ==> it must remain at the start. + +sccBlocks + :: Instruction instr + => Maybe CFG -> [NatBasicBlock instr] + -> [SCC (Node BlockId (NatBasicBlock instr))] +sccBlocks edgeWeights blocks = + stronglyConnCompFromEdgedVerticesUniqR + (map (mkNode edgeWeights) blocks) + +mkNode :: (Instruction t) + => Maybe CFG -> GenBasicBlock t + -> Node BlockId (GenBasicBlock t) +mkNode edgeWeights block@(BasicBlock id instrs) = + DigraphNode block id outEdges + where + outEdges :: [BlockId] + outEdges + --Select the heaviest successor, ignore weights <= zero + = successor + where + successor + | Just successors <- fmap (`getSuccEdgesSorted` id) + edgeWeights -- :: Maybe [(Label, EdgeInfo)] + = case successors of + [] -> [] + ((target,info):_) + | length successors > 2 || edgeWeight info <= 0 -> [] + | otherwise -> [target] + | Just instr <- lastMaybe instrs + , [one] <- jumpDestsOfInstr instr + = [one] + | otherwise = [] + + +seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)] + -> [GenBasicBlock t1] +seqBlocks infos blocks = placeNext pullable0 todo0 + where + -- pullable: Blocks that are not yet placed + -- todo: Original order of blocks, to be followed if we have no good + -- reason not to; + -- may include blocks that have already been placed, but then + -- these are not in pullable + pullable0 = listToUFM [ (i,(b,n)) | DigraphNode b i n <- blocks ] + todo0 = map node_key blocks + + placeNext _ [] = [] + placeNext pullable (i:rest) + | Just (block, pullable') <- lookupDeleteUFM pullable i + = place pullable' rest block + | otherwise + -- We already placed this block, so ignore + = placeNext pullable rest + + place pullable todo (block,[]) + = block : placeNext pullable todo + place pullable todo (block@(BasicBlock id instrs),[next]) + | mapMember next infos + = block : placeNext pullable todo + | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next + = BasicBlock id instrs : place pullable' todo nextBlock + | otherwise + = block : placeNext pullable todo + place _ _ (_,tooManyNextNodes) + = pprPanic "seqBlocks" (ppr tooManyNextNodes) + + +lookupDeleteUFM :: UniqFM BlockId elt -> BlockId + -> Maybe (elt, UniqFM BlockId elt) +lookupDeleteUFM m k = do -- Maybe monad + v <- lookupUFM m k + return (v, delFromUFM m k) + +backendMaintainsCfg :: Platform -> Bool +backendMaintainsCfg platform = case platformArch platform of + -- ArchX86 -- Should work but not tested so disabled currently. + ArchX86_64 -> True + _otherwise -> False + diff --git a/GHC/CmmToAsm/CFG.hs b/GHC/CmmToAsm/CFG.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/CFG.hs @@ -0,0 +1,1360 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +-- +-- Copyright (c) 2018 Andreas Klebinger +-- + +module GHC.CmmToAsm.CFG + ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..) + , TransitionSource(..) + + --Modify the CFG + , addWeightEdge, addEdge + , delEdge + , addNodesBetween, shortcutWeightMap + , reverseEdges, filterEdges + , addImmediateSuccessor + , mkWeightInfo, adjustEdgeWeight, setEdgeWeight + + --Query the CFG + , infoEdgeList, edgeList + , getSuccessorEdges, getSuccessors + , getSuccEdgesSorted + , getEdgeInfo + , getCfgNodes, hasNode + + -- Loop Information + , loopMembers, loopLevels, loopInfo + + --Construction/Misc + , getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg + + --Find backedges and update their weight + , optimizeCFG + , mkGlobalWeights + + ) +where + +import GHC.Prelude +import GHC.Platform + +import GHC.Cmm.BlockId +import GHC.Cmm as Cmm + +import GHC.Cmm.Switch +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Block +import qualified GHC.Cmm.Dataflow.Graph as G + +import GHC.Utils.Misc +import GHC.Data.Graph.Directed +import GHC.Data.Maybe + +import GHC.Types.Unique +import qualified GHC.CmmToAsm.CFG.Dominators as Dom +import GHC.CmmToAsm.CFG.Weight +import GHC.Data.Word64Map.Strict (Word64Map) +import GHC.Data.Word64Set (Word64Set) +import Data.IntMap.Strict (IntMap) +import Data.IntSet (IntSet) + +import qualified Data.IntMap.Strict as IM +import qualified GHC.Data.Word64Map.Strict as WM +import qualified Data.Map as M +import qualified Data.IntSet as IS +import qualified GHC.Data.Word64Set as WS +import qualified Data.Set as S +import Data.Tree +import Data.Bifunctor + +import GHC.Utils.Outputable +import GHC.Utils.Panic +-- DEBUGGING ONLY +--import GHC.Cmm.DebugBlock +--import GHC.Data.OrdList +--import GHC.Cmm.DebugBlock.Trace + +import Data.List (sort, nub, partition) +import Data.STRef.Strict +import Control.Monad.ST + +import Data.Array.MArray +import Data.Array.ST +import Data.Array.IArray +import Data.Array.Unsafe (unsafeFreeze) +import Data.Array.Base (unsafeRead, unsafeWrite) + +import Control.Monad +import GHC.Data.UnionFind +import Data.Word + +type Prob = Double + +type Edge = (BlockId, BlockId) +type Edges = [Edge] + +newtype EdgeWeight + = EdgeWeight { weightToDouble :: Double } + deriving (Eq,Ord,Enum,Num,Real,Fractional) + +instance Outputable EdgeWeight where + ppr (EdgeWeight w) = doublePrec 5 w + +type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo) + +-- | A control flow graph where edges have been annotated with a weight. +-- Implemented as IntMap (IntMap \) +-- We must uphold the invariant that for each edge A -> B we must have: +-- A entry B in the outer map. +-- A entry B in the map we get when looking up A. +-- Maintaining this invariant is useful as any failed lookup now indicates +-- an actual error in code which might go unnoticed for a while +-- otherwise. +type CFG = EdgeInfoMap EdgeInfo + +data CfgEdge + = CfgEdge + { edgeFrom :: !BlockId + , edgeTo :: !BlockId + , edgeInfo :: !EdgeInfo + } + +-- | Careful! Since we assume there is at most one edge from A to B +-- the Eq instance does not consider weight. +instance Eq CfgEdge where + (==) (CfgEdge from1 to1 _) (CfgEdge from2 to2 _) + = from1 == from2 && to1 == to2 + +-- | Edges are sorted ascending pointwise by weight, source and destination +instance Ord CfgEdge where + compare (CfgEdge from1 to1 (EdgeInfo {edgeWeight = weight1})) + (CfgEdge from2 to2 (EdgeInfo {edgeWeight = weight2})) + | weight1 < weight2 || weight1 == weight2 && from1 < from2 || + weight1 == weight2 && from1 == from2 && to1 < to2 + = LT + | from1 == from2 && to1 == to2 && weight1 == weight2 + = EQ + | otherwise + = GT + +instance Outputable CfgEdge where + ppr (CfgEdge from1 to1 edgeInfo) + = parens (ppr from1 <+> text "-(" <> ppr edgeInfo <> text ")->" <+> ppr to1) + +-- | Can we trace back a edge to a specific Cmm Node +-- or has it been introduced during assembly codegen. We use this to maintain +-- some information which would otherwise be lost during the +-- Cmm \<-> asm transition. +-- See also Note [Inverting conditions] +data TransitionSource + = CmmSource { trans_cmmNode :: (CmmNode O C) + , trans_info :: BranchInfo } + | AsmCodeGen + deriving (Eq) + +data BranchInfo = NoInfo -- ^ Unknown, but not heap or stack check. + | HeapStackCheck -- ^ Heap or stack check + deriving Eq + +instance Outputable BranchInfo where + ppr NoInfo = text "regular" + ppr HeapStackCheck = text "heap/stack" + +isHeapOrStackCheck :: TransitionSource -> Bool +isHeapOrStackCheck (CmmSource { trans_info = HeapStackCheck}) = True +isHeapOrStackCheck _ = False + +-- | Information about edges +data EdgeInfo + = EdgeInfo + { transitionSource :: !TransitionSource + , edgeWeight :: !EdgeWeight + } deriving (Eq) + +instance Outputable EdgeInfo where + ppr edgeInfo = text "weight:" <+> ppr (edgeWeight edgeInfo) + +-- | Convenience function, generate edge info based +-- on weight not originating from cmm. +mkWeightInfo :: EdgeWeight -> EdgeInfo +mkWeightInfo = EdgeInfo AsmCodeGen + +-- | Adjust the weight between the blocks using the given function. +-- If there is no such edge returns the original map. +adjustEdgeWeight :: CFG -> (EdgeWeight -> EdgeWeight) + -> BlockId -> BlockId -> CFG +adjustEdgeWeight cfg f from to + | Just info <- getEdgeInfo from to cfg + , !weight <- edgeWeight info + , !newWeight <- f weight + = addEdge from to (info { edgeWeight = newWeight}) cfg + | otherwise = cfg + +-- | Set the weight between the blocks to the given weight. +-- If there is no such edge returns the original map. +setEdgeWeight :: CFG -> EdgeWeight + -> BlockId -> BlockId -> CFG +setEdgeWeight cfg !weight from to + | Just info <- getEdgeInfo from to cfg + = addEdge from to (info { edgeWeight = weight}) cfg + | otherwise = cfg + + +getCfgNodes :: CFG -> [BlockId] +getCfgNodes m = + mapKeys m + +-- | Is this block part of this graph? +hasNode :: CFG -> BlockId -> Bool +hasNode m node = + -- Check the invariant that each node must exist in the first map or not at all. + assert (found || not (any (mapMember node) m)) + found + where + found = mapMember node m + + + +-- | Check if the nodes in the cfg and the set of blocks are the same. +-- In a case of a mismatch we panic and show the difference. +sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool +sanityCheckCfg m blockSet msg + | blockSet == cfgNodes + = True + | otherwise = + pprPanic "Block list and cfg nodes don't match" ( + text "difference:" <+> ppr diff $$ + text "blocks:" <+> ppr blockSet $$ + text "cfg:" <+> pprEdgeWeights m $$ + msg ) + False + where + cfgNodes = setFromList $ getCfgNodes m :: LabelSet + diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet + +-- | Filter the CFG with a custom function f. +-- Parameters are `f from to edgeInfo` +filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG +filterEdges f cfg = + mapMapWithKey filterSources cfg + where + filterSources from m = + mapFilterWithKey (\to w -> f from to w) m + + +{- Note [Updating the CFG during shortcutting] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [What is shortcutting] in the control flow optimization +code (GHC.Cmm.ContFlowOpt) for a slightly more in depth explanation on shortcutting. + +In the native backend we shortcut jumps at the assembly level. ("GHC.CmmToAsm") +This means we remove blocks containing only one jump from the code +and instead redirecting all jumps targeting this block to the deleted +blocks jump target. + +However we want to have an accurate representation of control +flow in the CFG. So we add/remove edges accordingly to account +for the eliminated blocks and new edges. + +If we shortcut A -> B -> C to A -> C: +* We delete edges A -> B and B -> C +* Replacing them with the edge A -> C + +We also try to preserve jump weights while doing so. + +Note that: +* The edge B -> C can't have interesting weights since + the block B consists of a single unconditional jump without branching. +* We delete the edge A -> B and add the edge A -> C. +* The edge A -> B can be one of many edges originating from A so likely + has edge weights we want to preserve. + +For this reason we simply store the edge info from the original A -> B +edge and apply this information to the new edge A -> C. + +Sometimes we have a scenario where jump target C is not represented by an +BlockId but an immediate value. I'm only aware of this happening without +tables next to code currently. + +Then we go from A ---> B - -> IMM to A - -> IMM where the dashed arrows +are not stored in the CFG. + +In that case we simply delete the edge A -> B. + +In terms of implementation the native backend first builds a mapping +from blocks suitable for shortcutting to their jump targets. +Then it redirects all jump instructions to these blocks using the +built up mapping. +This function (shortcutWeightMap) takes the same mapping and +applies the mapping to the CFG in the way laid out above. + +-} +shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG +shortcutWeightMap cuts cfg + | mapNull cuts = cfg + | otherwise = normalised_cfg + where + -- First take the cuts map and collapse any shortcuts, for example + -- if the cuts map has A -> B and B -> C then we want to rewrite + -- A -> C and B -> C directly. + normalised_cuts_st :: forall s . ST s (LabelMap (Maybe BlockId)) + normalised_cuts_st = do + (null :: Point s (Maybe BlockId)) <- fresh Nothing + let cuts_list = mapToList cuts + -- Create a unification variable for each of the nodes in a rewrite + cuts_vars <- traverse (\p -> (p,) <$> fresh (Just p)) (concatMap (\(a, b) -> [a] ++ maybe [] (:[]) b) cuts_list) + let cuts_map = mapFromList cuts_vars :: LabelMap (Point s (Maybe BlockId)) + -- Then unify according to the rewrites in the cuts map + mapM_ (\(from, to) -> expectJust (mapLookup from cuts_map) + `union` expectJust (maybe (Just null) (flip mapLookup cuts_map) to) ) cuts_list + -- Then recover the unique representative, which is the result of following + -- the chain to the end. + mapM find cuts_map + + normalised_cuts = runST normalised_cuts_st + + cuts_domain :: LabelSet + cuts_domain = setFromList $ mapKeys cuts + + -- The CFG is shortcutted using the normalised cuts map + normalised_cfg :: CFG + normalised_cfg = mapFoldlWithKey update_edge mapEmpty cfg + + update_edge :: CFG -> Label -> LabelMap EdgeInfo -> CFG + update_edge new_map from edge_map + -- If the from edge is in the cuts map then delete the edge + | setMember from cuts_domain = new_map + -- Otherwise we are keeping the edge, but might have shortcutted some of + -- the target nodes. + | otherwise = mapInsert from (mapFoldlWithKey update_from_edge mapEmpty edge_map) new_map + + update_from_edge :: LabelMap a -> Label -> a -> LabelMap a + update_from_edge new_map to_edge edge_info + -- Edge is in the normalised cuts + | Just new_edge <- mapLookup to_edge normalised_cuts = + case new_edge of + -- The result was Nothing, so edge is deleted + Nothing -> new_map + -- The new target for the edge, write it with the old edge_info. + Just new_to -> mapInsert new_to edge_info new_map + -- Node wasn't in the cuts map, so just add it back + | otherwise = mapInsert to_edge edge_info new_map + + +-- | Sometimes we insert a block which should unconditionally be executed +-- after a given block. This function updates the CFG for these cases. +-- So we get A -> B => A -> A' -> B +-- \ \ +-- -> C => -> C +-- +addImmediateSuccessor :: Weights -> BlockId -> BlockId -> CFG -> CFG +addImmediateSuccessor weights node follower cfg + = updateEdges . addWeightEdge node follower weight $ cfg + where + weight = fromIntegral (uncondWeight weights) + targets = getSuccessorEdges cfg node + successors = map fst targets :: [BlockId] + updateEdges = addNewSuccs . remOldSuccs + remOldSuccs m = foldl' (flip (delEdge node)) m successors + addNewSuccs m = + foldl' (\m' (t,info) -> addEdge follower t info m') m targets + +-- | Adds a new edge, overwrites existing edges if present +addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG +addEdge from to info cfg = + mapAlter addFromToEdge from $ + mapAlter addDestNode to cfg + where + -- Simply insert the edge into the edge list. + addFromToEdge Nothing = Just $ mapSingleton to info + addFromToEdge (Just wm) = Just $ mapInsert to info wm + -- We must add the destination node explicitly + addDestNode Nothing = Just $ mapEmpty + addDestNode n@(Just _) = n + + +-- | Adds a edge with the given weight to the cfg +-- If there already existed an edge it is overwritten. +-- `addWeightEdge from to weight cfg` +addWeightEdge :: BlockId -> BlockId -> EdgeWeight -> CFG -> CFG +addWeightEdge from to weight cfg = + addEdge from to (mkWeightInfo weight) cfg + +delEdge :: BlockId -> BlockId -> CFG -> CFG +delEdge from to m = + mapAdjust (mapDelete to) from m + + +-- | Destinations from bid ordered by weight (descending) +getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)] +getSuccEdgesSorted m bid = + let destMap = mapFindWithDefault mapEmpty bid m + cfgEdges = mapToList destMap + sortedEdges = sortWith (negate . edgeWeight . snd) cfgEdges + in --pprTrace "getSuccEdgesSorted" (ppr bid <+> text "map:" <+> ppr m) + sortedEdges + +-- | Get successors of a given node with edge weights. +getSuccessorEdges :: HasDebugCallStack => CFG -> BlockId -> [(BlockId,EdgeInfo)] +getSuccessorEdges m bid = maybe lookupError mapToList (mapLookup bid m) + where + lookupError = pprPanic "getSuccessorEdges: Block does not exist" $ + ppr bid <+> pprEdgeWeights m + +getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo +getEdgeInfo from to m + | Just wm <- mapLookup from m + , Just info <- mapLookup to wm + = Just $! info + | otherwise + = Nothing + +getEdgeWeight :: CFG -> BlockId -> BlockId -> EdgeWeight +getEdgeWeight cfg from to = edgeWeight $ expectJust $ getEdgeInfo from to cfg + +getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource +getTransitionSource from to cfg = transitionSource $ expectJust $ getEdgeInfo from to cfg + +reverseEdges :: CFG -> CFG +reverseEdges cfg = mapFoldlWithKey (\cfg from toMap -> go (addNode cfg from) from toMap) mapEmpty cfg + where + -- We must preserve nodes without outgoing edges! + addNode :: CFG -> BlockId -> CFG + addNode cfg b = mapInsertWith mapUnion b mapEmpty cfg + go :: CFG -> BlockId -> (LabelMap EdgeInfo) -> CFG + go cfg from toMap = mapFoldlWithKey (\cfg to info -> addEdge to from info cfg) cfg toMap :: CFG + + +-- | Returns a unordered list of all edges with info +infoEdgeList :: CFG -> [CfgEdge] +infoEdgeList m = + go (mapToList m) [] + where + -- We avoid foldMap to avoid thunk buildup + go :: [(BlockId,LabelMap EdgeInfo)] -> [CfgEdge] -> [CfgEdge] + go [] acc = acc + go ((from,toMap):xs) acc + = go' xs from (mapToList toMap) acc + go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [(BlockId,EdgeInfo)] -> [CfgEdge] -> [CfgEdge] + go' froms _ [] acc = go froms acc + go' froms from ((to,info):tos) acc + = go' froms from tos (CfgEdge from to info : acc) + +-- | Returns a unordered list of all edges without weights +edgeList :: CFG -> [Edge] +edgeList m = + go (mapToList m) [] + where + -- We avoid foldMap to avoid thunk buildup + go :: [(BlockId,LabelMap EdgeInfo)] -> [Edge] -> [Edge] + go [] acc = acc + go ((from,toMap):xs) acc + = go' xs from (mapKeys toMap) acc + go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [BlockId] -> [Edge] -> [Edge] + go' froms _ [] acc = go froms acc + go' froms from (to:tos) acc + = go' froms from tos ((from,to) : acc) + +-- | Get successors of a given node without edge weights. +getSuccessors :: HasDebugCallStack => CFG -> BlockId -> [BlockId] +getSuccessors m bid + | Just wm <- mapLookup bid m + = mapKeys wm + | otherwise = lookupError + where + lookupError = pprPanic "getSuccessors: Block does not exist" $ + ppr bid <+> pprEdgeWeights m + +pprEdgeWeights :: CFG -> SDoc +pprEdgeWeights m = + let edges = sort $ infoEdgeList m :: [CfgEdge] + printEdge (CfgEdge from to (EdgeInfo { edgeWeight = weight })) + = text "\t" <> ppr from <+> text "->" <+> ppr to <> + text "[label=\"" <> ppr weight <> text "\",weight=\"" <> + ppr weight <> text "\"];\n" + --for the case that there are no edges from/to this node. + --This should rarely happen but it can save a lot of time + --to immediately see it when it does. + printNode node + = text "\t" <> ppr node <> text ";\n" + getEdgeNodes (CfgEdge from to _) = [from,to] + edgeNodes = setFromList $ concatMap getEdgeNodes edges :: LabelSet + nodes = filter (\n -> (not . setMember n) edgeNodes) . mapKeys $ mapFilter null m + in + text "digraph {\n" <> + (foldl' (<>) empty (map printEdge edges)) <> + (foldl' (<>) empty (map printNode nodes)) <> + text "}\n" + +{-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible +-- | Invariant: The edge **must** exist already in the graph. +updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG +updateEdgeWeight f (from, to) cfg + | Just oldInfo <- getEdgeInfo from to cfg + = let !oldWeight = edgeWeight oldInfo + !newWeight = f oldWeight + in addEdge from to (oldInfo {edgeWeight = newWeight}) cfg + | otherwise + = panic "Trying to update invalid edge" + +-- from to oldWeight => newWeight +mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG +mapWeights f cfg = + foldl' (\cfg (CfgEdge from to info) -> + let oldWeight = edgeWeight info + newWeight = f from to oldWeight + in addEdge from to (info {edgeWeight = newWeight}) cfg) + cfg (infoEdgeList cfg) + + +-- | Insert a block in the control flow between two other blocks. +-- We pass a list of tuples (A,B,C) where +-- * A -> C: Old edge +-- * A -> B -> C : New Arc, where B is the new block. +-- It's possible that a block has two jumps to the same block +-- in the assembly code. However we still only store a single edge for +-- these cases. +-- We assign the old edge info to the edge A -> B and assign B -> C the +-- weight of an unconditional jump. +addNodesBetween :: Weights -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG +addNodesBetween weights m updates = + foldl' updateWeight m . + weightUpdates $ updates + where + weight = fromIntegral (uncondWeight weights) + -- We might add two blocks for different jumps along a single + -- edge. So we end up with edges: A -> B -> C , A -> D -> C + -- in this case after applying the first update the weight for A -> C + -- is no longer available. So we calculate future weights before updates. + weightUpdates = map getWeight + getWeight :: (BlockId,BlockId,BlockId) -> (BlockId,BlockId,BlockId,EdgeInfo) + getWeight (from,between,old) + | Just edgeInfo <- getEdgeInfo from old m + = (from,between,old,edgeInfo) + | otherwise + = pprPanic "Can't find weight for edge that should have one" ( + text "triple" <+> ppr (from,between,old) $$ + text "updates" <+> ppr updates $$ + text "cfg:" <+> pprEdgeWeights m ) + updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG + updateWeight m (from,between,old,edgeInfo) + = addEdge from between edgeInfo . + addWeightEdge between old weight . + delEdge from old $ m + +{- + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ~~~ Note [CFG Edge Weights] ~~~ + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + Edge weights assigned do not currently represent a specific + cost model and rather just a ranking of which blocks should + be placed next to each other given their connection type in + the CFG. + This is especially relevant if we whenever two blocks will + jump to the same target. + + A B + \ / + C + + Should A or B be placed in front of C? The block layout algorithm + decides this based on which edge (A,C)/(B,C) is heavier. So we + make a educated guess on which branch should be preferred. + + We rank edges in this order: + * Unconditional Control Transfer - They will always + transfer control to their target. Unless there is a info table + we can turn the jump into a fallthrough as well. + We use 20k as default, so it's easy to spot if values have been + modified but unlikely that we run into issues with overflow. + * If branches (likely) - We assume branches marked as likely + are taken more than 80% of the time. + By ranking them below unconditional jumps we make sure we + prefer the unconditional if there is a conditional and + unconditional edge towards a block. + * If branches (regular) - The false branch can potentially be turned + into a fallthrough so we prefer it slightly over the true branch. + * Unlikely branches - These can be assumed to be taken less than 20% + of the time. So we given them one of the lowest priorities. + * Switches - Switches at this level are implemented as jump tables + so have a larger number of successors. So without more information + we can only say that each individual successor is unlikely to be + jumped to and we rank them accordingly. + * Calls - We currently ignore calls completely: + * By the time we return from a call there is a good chance + that the address we return to has already been evicted from + cache eliminating a main advantage sequential placement brings. + * Calls always require a info table in front of their return + address. This reduces the chance that we return to the same + cache line further. + +-} +-- | Generate weights for a Cmm proc based on some simple heuristics. +getCfgProc :: Platform -> Weights -> GenCmmDecl d h CmmGraph -> CFG +getCfgProc _ _ (CmmData {}) = mapEmpty +getCfgProc platform weights (CmmProc _info _lab _live graph) = getCfg platform weights graph + +getCfg :: Platform -> Weights -> CmmGraph -> CFG +getCfg platform weights graph = + foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks + where + Weights + { uncondWeight = uncondWeight + , condBranchWeight = condBranchWeight + , switchWeight = switchWeight + , callWeight = callWeight + , likelyCondWeight = likelyCondWeight + , unlikelyCondWeight = unlikelyCondWeight + -- Last two are used in other places + --, infoTablePenalty = infoTablePenalty + --, backEdgeBonus = backEdgeBonus + } = weights + -- Explicitly add all nodes to the cfg to ensure they are part of the + -- CFG. + edgelessCfg = mapFromList $ zip (map G.entryLabel blocks) (repeat mapEmpty) + insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG + insertEdge m ((from,to),weight) = + mapAlter f from m + where + f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo) + f Nothing = Just $ mapSingleton to weight + f (Just destMap) = Just $ mapInsert to weight destMap + getBlockEdges :: CmmBlock -> [((BlockId,BlockId),EdgeInfo)] + getBlockEdges block = + case branch of + CmmBranch dest -> [mkEdge dest uncondWeight] + CmmCondBranch cond t f l + | l == Nothing -> + [mkEdge f condBranchWeight, mkEdge t condBranchWeight] + | l == Just True -> + [mkEdge f unlikelyCondWeight, mkEdge t likelyCondWeight] + | l == Just False -> + [mkEdge f likelyCondWeight, mkEdge t unlikelyCondWeight] + where + mkEdgeInfo = -- pprTrace "Info" (ppr branchInfo <+> ppr cond) + EdgeInfo (CmmSource branch branchInfo) . fromIntegral + mkEdge target weight = ((bid,target), mkEdgeInfo weight) + branchInfo = + foldRegsUsed + (panic "GHC.CmmToAsm.CFG.getCfg: foldRegsUsed") + (\info r -> if r == SpLim || r == HpLim || r == BaseReg + then HeapStackCheck else info) + NoInfo cond + + (CmmSwitch _e ids) -> + let switchTargets = switchTargetsToList ids + --Compiler performance hack - for very wide switches don't + --consider targets for layout. + adjustedWeight = + if (length switchTargets > 10) then -1 else switchWeight + in map (\x -> mkEdge x adjustedWeight) switchTargets + (CmmCall { cml_cont = Just cont}) -> [mkEdge cont callWeight] + (CmmForeignCall {Cmm.succ = cont}) -> [mkEdge cont callWeight] + (CmmCall { cml_cont = Nothing }) -> [] + other -> + panic "Foo" $ + assertPpr False (text "Unknown successor cause:" <> + (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other))) $ + map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other + where + bid = G.entryLabel block + mkEdgeInfo = EdgeInfo (CmmSource branch NoInfo) . fromIntegral + mkEdge target weight = ((bid,target), mkEdgeInfo weight) + branch = lastNode block :: CmmNode O C + + blocks = revPostorder graph :: [CmmBlock] + +--Find back edges by BFS +findBackEdges :: HasDebugCallStack => BlockId -> CFG -> Edges +findBackEdges root cfg = + --pprTraceIt "Backedges:" $ + map fst . + filter (\x -> snd x == Backward) $ typedEdges + where + edges = edgeList cfg :: [(BlockId,BlockId)] + getSuccs = getSuccessors cfg :: BlockId -> [BlockId] + typedEdges = + classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)] + +optimizeCFG :: Bool -> Weights -> RawCmmDecl -> CFG -> CFG +optimizeCFG _ _ (CmmData {}) cfg = cfg +optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg = + (if doStaticPred then staticPredCfg (g_entry graph) else id) $ + optHsPatterns weights proc $ cfg + +-- | Modify branch weights based on educated guess on +-- patterns GHC tends to produce and how they affect +-- performance. +-- +-- Most importantly we penalize jumps across info tables. +optHsPatterns :: Weights -> RawCmmDecl -> CFG -> CFG +optHsPatterns _ (CmmData {}) cfg = cfg +optHsPatterns weights (CmmProc info _lab _live graph) cfg = + {-# SCC optHsPatterns #-} + -- pprTrace "Initial:" (pprEdgeWeights cfg) $ + -- pprTrace "Initial:" (ppr $ mkGlobalWeights (g_entry graph) cfg) $ + + -- pprTrace "LoopInfo:" (ppr $ loopInfo cfg (g_entry graph)) $ + favourFewerPreds . + penalizeInfoTables info . + increaseBackEdgeWeight (g_entry graph) $ cfg + where + + -- Increase the weight of all backedges in the CFG + -- this helps to make loop jumpbacks the heaviest edges + increaseBackEdgeWeight :: BlockId -> CFG -> CFG + increaseBackEdgeWeight root cfg = + let backedges = findBackEdges root cfg + update weight + --Keep irrelevant edges irrelevant + | weight <= 0 = 0 + | otherwise + = weight + fromIntegral (backEdgeBonus weights) + in foldl' (\cfg edge -> updateEdgeWeight update edge cfg) + cfg backedges + + -- Since we cant fall through info tables we penalize these. + penalizeInfoTables :: LabelMap a -> CFG -> CFG + penalizeInfoTables info cfg = + mapWeights fupdate cfg + where + fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight + fupdate _ to weight + | mapMember to info + = weight - (fromIntegral $ infoTablePenalty weights) + | otherwise = weight + + -- If a block has two successors, favour the one with fewer + -- predecessors and/or the one allowing fall through. + favourFewerPreds :: CFG -> CFG + favourFewerPreds cfg = + let + revCfg = + reverseEdges $ filterEdges + (\_from -> fallthroughTarget) cfg + + predCount n = length $ getSuccessorEdges revCfg n + nodes = getCfgNodes cfg + + modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight) + modifiers preds1 preds2 + | preds1 < preds2 = ( 1,-1) + | preds1 == preds2 = ( 0, 0) + | otherwise = (-1, 1) + + update :: CFG -> BlockId -> CFG + update cfg node + | [(s1,e1),(s2,e2)] <- getSuccessorEdges cfg node + , !w1 <- edgeWeight e1 + , !w2 <- edgeWeight e2 + --Only change the weights if there isn't already a ordering. + , w1 == w2 + , (mod1,mod2) <- modifiers (predCount s1) (predCount s2) + = (\cfg' -> + (adjustEdgeWeight cfg' (+mod2) node s2)) + (adjustEdgeWeight cfg (+mod1) node s1) + | otherwise + = cfg + in foldl' update cfg nodes + where + fallthroughTarget :: BlockId -> EdgeInfo -> Bool + fallthroughTarget to (EdgeInfo source _weight) + | mapMember to info = False + | AsmCodeGen <- source = True + | CmmSource { trans_cmmNode = CmmBranch {} } <- source = True + | CmmSource { trans_cmmNode = CmmCondBranch {} } <- source = True + | otherwise = False + +-- | Convert block-local branch weights to global weights. +staticPredCfg :: BlockId -> CFG -> CFG +staticPredCfg entry cfg = cfg' + where + (_, globalEdgeWeights) = {-# SCC mkGlobalWeights #-} + mkGlobalWeights entry cfg + cfg' = {-# SCC rewriteEdges #-} + mapFoldlWithKey + (\cfg from m -> + mapFoldlWithKey + (\cfg to w -> setEdgeWeight cfg (EdgeWeight w) from to ) + cfg m ) + cfg + globalEdgeWeights + +-- | Determine loop membership of blocks based on SCC analysis +-- This is faster but only gives yes/no answers. +loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool +loopMembers cfg = + foldl' (flip setLevel) mapEmpty sccs + where + mkNode :: BlockId -> Node BlockId BlockId + mkNode bid = DigraphNode bid bid (getSuccessors cfg bid) + nodes = map mkNode (getCfgNodes cfg) + + sccs = stronglyConnCompFromEdgedVerticesOrd nodes + + setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool + setLevel (AcyclicSCC bid) m = mapInsert bid False m + setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids + +loopLevels :: CFG -> BlockId -> LabelMap Int +loopLevels cfg root = liLevels loopInfos + where + loopInfos = loopInfo cfg root + +data LoopInfo = LoopInfo + { liBackEdges :: [(Edge)] -- ^ List of back edges + , liLevels :: LabelMap Int -- ^ BlockId -> LoopLevel mapping + , liLoops :: [(Edge, LabelSet)] -- ^ (backEdge, loopBody), body includes header + } + +instance Outputable LoopInfo where + ppr (LoopInfo _ _lvls loops) = + text "Loops:(backEdge, bodyNodes)" $$ + (vcat $ map ppr loops) + +{- Note [Determining the loop body] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + Starting with the knowledge that: + * head dominates the loop + * `tail` -> `head` is a backedge + + We can determine all nodes by: + * Deleting the loop head from the graph. + * Collect all blocks which are reachable from the `tail`. + + We do so by performing bfs from the tail node towards the head. + -} + +-- | Determine loop membership of blocks based on Dominator analysis. +-- This is slower but gives loop levels instead of just loop membership. +-- However it only detects natural loops. Irreducible control flow is not +-- recognized even if it loops. But that is rare enough that we don't have +-- to care about that special case. +loopInfo :: HasDebugCallStack => CFG -> BlockId -> LoopInfo +loopInfo cfg root = LoopInfo { liBackEdges = backEdges + , liLevels = mapFromList loopCounts + , liLoops = loopBodies } + where + revCfg = reverseEdges cfg + + graph = -- pprTrace "CFG - loopInfo" (pprEdgeWeights cfg) $ + fmap (setFromList . mapKeys ) cfg :: LabelMap LabelSet + + + --TODO - This should be a no op: Export constructors? Use unsafeCoerce? ... + rooted = ( fromBlockId root + , toWord64Map $ fmap toWord64Set graph) :: (Word64, Word64Map Word64Set) + tree = fmap toBlockId $ Dom.domTree rooted :: Tree BlockId + + -- Map from Nodes to their dominators + domMap :: LabelMap LabelSet + domMap = mkDomMap tree + + edges = edgeList cfg :: [(BlockId, BlockId)] + -- We can't recompute nodes from edges, there might be blocks not connected via edges. + nodes = getCfgNodes cfg :: [BlockId] + + -- identify back edges + isBackEdge (from,to) + | Just doms <- mapLookup from domMap + , setMember to doms + = True + | otherwise = False + + -- See Note [Determining the loop body] + -- Get the loop body associated with a back edge. + findBody edge@(tail, head) + = ( edge, setInsert head $ go (setSingleton tail) (setSingleton tail) ) + where + -- See Note [Determining the loop body] + + + go :: LabelSet -> LabelSet -> LabelSet + go found current + | setNull current = found + | otherwise = go (setUnion newSuccessors found) + newSuccessors + where + -- Really predecessors, since we use the reversed cfg. + newSuccessors = setFilter (\n -> not $ setMember n found) successors :: LabelSet + successors = setDelete head $ setUnions $ map + (\x -> if x == head then setEmpty else setFromList (getSuccessors revCfg x)) + (setElems current) :: LabelSet + + backEdges = filter isBackEdge edges + loopBodies = map findBody backEdges :: [(Edge, LabelSet)] + + -- Block b is part of n loop bodies => loop nest level of n + loopCounts = + let bodies = map (first snd) loopBodies -- [(Header, Body)] + loopCount n = length $ nub . map fst . filter (setMember n . snd) $ bodies + in map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)] + + toWord64Set :: LabelSet -> Word64Set + toWord64Set s = WS.fromList . map fromBlockId . setElems $ s + toWord64Map :: LabelMap a -> Word64Map a + toWord64Map m = WM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m + + mkDomMap :: Tree BlockId -> LabelMap LabelSet + mkDomMap root = mapFromList $ go setEmpty root + where + go :: LabelSet -> Tree BlockId -> [(Label,LabelSet)] + go parents (Node lbl []) + = [(lbl, parents)] + go parents (Node _ leaves) + = let nodes = map rootLabel leaves + entries = map (\x -> (x,parents)) nodes + in entries ++ concatMap + (\n -> go (setInsert (rootLabel n) parents) n) + leaves + + fromBlockId :: BlockId -> Word64 + fromBlockId = getKey . getUnique + + toBlockId :: Word64 -> BlockId + toBlockId = mkBlockId . mkUniqueGrimily + +-- We make the CFG a Hoopl Graph, so we can reuse revPostOrder. +newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId]) + +instance G.NonLocal (BlockNode) where + entryLabel (BN (lbl,_)) = lbl + successors (BN (_,succs)) = succs + +revPostorderFrom :: HasDebugCallStack => CFG -> BlockId -> [BlockId] +revPostorderFrom cfg root = + map fromNode $ G.revPostorderFrom hooplGraph root + where + nodes = getCfgNodes cfg + hooplGraph = foldl' (\m n -> mapInsert n (toNode n) m) mapEmpty nodes + + fromNode :: BlockNode C C -> BlockId + fromNode (BN x) = fst x + + toNode :: BlockId -> BlockNode C C + toNode bid = + BN (bid,getSuccessors cfg $ bid) + + +-- | We take in a CFG which has on its edges weights which are +-- relative only to other edges originating from the same node. +-- +-- We return a CFG for which each edge represents a GLOBAL weight. +-- This means edge weights are comparable across the whole graph. +-- +-- For irreducible control flow results might be imprecise, otherwise they +-- are reliable. +-- +-- The algorithm is based on the Paper +-- "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus +-- The only big change is that we go over the nodes in the body of loops in +-- reverse post order. Which is required for diamond control flow to work probably. +-- +-- We also apply a few prediction heuristics (based on the same paper) +-- +-- The returned result represents frequences. +-- For blocks it's the expected number of executions and +-- for edges is the number of traversals. + +{-# NOINLINE mkGlobalWeights #-} +{-# SCC mkGlobalWeights #-} +mkGlobalWeights :: HasDebugCallStack => BlockId -> CFG -> (LabelMap Double, LabelMap (LabelMap Double)) +mkGlobalWeights root localCfg + | null localCfg = panic "Error - Empty CFG" + | otherwise + = (blockFreqs', edgeFreqs') + where + -- Calculate fixpoints + (blockFreqs, edgeFreqs) = calcFreqs nodeProbs backEdges' bodies' revOrder' + blockFreqs' = mapFromList $ map (first fromVertex) (assocs blockFreqs) :: LabelMap Double + edgeFreqs' = fmap fromVertexMap $ fromVertexMap edgeFreqs + + fromVertexMap :: IM.IntMap x -> LabelMap x + fromVertexMap m = mapFromList . map (first fromVertex) $ IM.toList m + + revOrder = revPostorderFrom localCfg root :: [BlockId] + loopResults@(LoopInfo backedges _levels bodies) = loopInfo localCfg root + + revOrder' = map toVertex revOrder + backEdges' = map (bimap toVertex toVertex) backedges + bodies' = map calcBody bodies + + estimatedCfg = staticBranchPrediction root loopResults localCfg + -- Normalize the weights to probabilities and apply heuristics + nodeProbs = cfgEdgeProbabilities estimatedCfg toVertex + + -- By mapping vertices to numbers in reverse post order we can bring any subset into reverse post + -- order simply by sorting. + -- TODO: The sort is redundant if we can guarantee that setElems returns elements ascending + calcBody (backedge, blocks) = + (toVertex $ snd backedge, sort . map toVertex $ (setElems blocks)) + + vertexMapping = mapFromList $ zip revOrder [0..] :: LabelMap Int + blockMapping = listArray (0,mapSize vertexMapping - 1) revOrder :: Array Int BlockId + -- Map from blockId to indices starting at zero + toVertex :: BlockId -> Int + toVertex blockId = expectJust $ mapLookup blockId vertexMapping + -- Map from indices starting at zero to blockIds + fromVertex :: Int -> BlockId + fromVertex vertex = blockMapping ! vertex + +{- Note [Static Branch Prediction] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The work here has been based on the paper +"Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus. + +The primary differences are that if we branch on the result of a heap +check we do not apply any of the heuristics. +The reason is simple: They look like loops in the control flow graph +but are usually never entered, and if at most once. + +Currently implemented is a heuristic to predict that we do not exit +loops (lehPredicts) and one to predict that backedges are more likely +than any other edge. + +The back edge case is special as it supersedes any other heuristic if it +applies. + +Do NOT rely solely on nofib results for benchmarking this. I recommend at least +comparing megaparsec and container benchmarks. Nofib does not seem to have +many instances of "loopy" Cmm where these make a difference. + +TODO: +* The paper containers more benchmarks which should be implemented. +* If we turn the likelihood on if/else branches into a probability + instead of true/false we could implement this as a Cmm pass. + + The complete Cmm code still exists and can be accessed by the heuristics + + There is no chance of register allocation/codegen inserting branches/blocks + + making the TransitionSource info wrong. + + potential to use this information in CmmPasses. + - Requires refactoring of all the code relying on the binary nature of likelihood. + - Requires refactoring `loopInfo` to work on both, Cmm Graphs and the backend CFG. +-} + +-- | Combination of target node id and information about the branch +-- we are looking at. +type TargetNodeInfo = (BlockId, EdgeInfo) + + +-- | Update branch weights based on certain heuristics. +-- See Note [Static Branch Prediction] +-- TODO: This should be combined with optimizeCFG +{-# SCC staticBranchPrediction #-} +staticBranchPrediction :: BlockId -> LoopInfo -> CFG -> CFG +staticBranchPrediction _root (LoopInfo l_backEdges loopLevels l_loops) cfg = + -- pprTrace "staticEstimatesOn" (ppr (cfg)) $ + foldl' update cfg nodes + where + nodes = getCfgNodes cfg + backedges = S.fromList $ l_backEdges + -- Loops keyed by their back edge + loops = M.fromList $ l_loops :: M.Map Edge LabelSet + loopHeads = S.fromList $ map snd $ M.keys loops + + update :: CFG -> BlockId -> CFG + update cfg node + -- No successors, nothing to do. + | null successors = cfg + + -- Mix of backedges and others: + -- Always predict the backedges. + | not (null m) && length m < length successors + -- Heap/Stack checks "loop", but only once. + -- So we simply exclude any case involving them. + , not $ any (isHeapOrStackCheck . transitionSource . snd) successors + = let loopChance = repeat $! pred_LBH / (fromIntegral $ length m) + exitChance = repeat $! (1 - pred_LBH) / fromIntegral (length not_m) + updates = zip (map fst m) loopChance ++ zip (map fst not_m) exitChance + in -- pprTrace "mix" (ppr (node,successors)) $ + foldl' (\cfg (to,weight) -> setEdgeWeight cfg weight node to) cfg updates + + -- For (regular) non-binary branches we keep the weights from the STG -> Cmm translation. + | length successors /= 2 + = cfg + + -- Only backedges - no need to adjust + | length m > 0 + = cfg + + -- A regular binary branch, we can plug addition predictors in here. + | [(s1,s1_info),(s2,s2_info)] <- successors + , not $ any (isHeapOrStackCheck . transitionSource . snd) successors + = -- Normalize weights to total of 1 + let !w1 = max (edgeWeight s1_info) (0) + !w2 = max (edgeWeight s2_info) (0) + -- Of both weights are <= 0 we set both to 0.5 + normalizeWeight w = if w1 + w2 == 0 then 0.5 else w/(w1+w2) + !cfg' = setEdgeWeight cfg (normalizeWeight w1) node s1 + !cfg'' = setEdgeWeight cfg' (normalizeWeight w2) node s2 + + -- Figure out which heuristics apply to these successors + heuristics = map ($ ((s1,s1_info),(s2,s2_info))) + [lehPredicts, phPredicts, ohPredicts, ghPredicts, lhhPredicts, chPredicts + , shPredicts, rhPredicts] + -- Apply result of a heuristic. Argument is the likelihood + -- predicted for s1. + applyHeuristic :: CFG -> Maybe Prob -> CFG + applyHeuristic cfg Nothing = cfg + applyHeuristic cfg (Just (s1_pred :: Double)) + | s1_old == 0 || s2_old == 0 || + isHeapOrStackCheck (transitionSource s1_info) || + isHeapOrStackCheck (transitionSource s2_info) + = cfg + | otherwise = + let -- Predictions from heuristic + s1_prob = EdgeWeight s1_pred :: EdgeWeight + s2_prob = 1.0 - s1_prob + -- Update + d = (s1_old * s1_prob) + (s2_old * s2_prob) :: EdgeWeight + s1_prob' = s1_old * s1_prob / d + !s2_prob' = s2_old * s2_prob / d + !cfg_s1 = setEdgeWeight cfg s1_prob' node s1 + in -- pprTrace "Applying heuristic!" (ppr (node,s1,s2) $$ ppr (s1_prob', s2_prob')) $ + setEdgeWeight cfg_s1 s2_prob' node s2 + where + -- Old weights + s1_old = getEdgeWeight cfg node s1 + s2_old = getEdgeWeight cfg node s2 + + in + -- pprTraceIt "RegularCfgResult" $ + foldl' applyHeuristic cfg'' heuristics + + -- Branch on heap/stack check + | otherwise = cfg + + where + -- Chance that loops are taken. + pred_LBH = 0.875 + -- successors + successors = getSuccessorEdges cfg node + -- backedges + (m,not_m) = partition (\succ -> S.member (node, fst succ) backedges) successors + + -- Heuristics return nothing if they don't say anything about this branch + -- or Just (prob_s1) where prob_s1 is the likelihood for s1 to be the + -- taken branch. s1 is the branch in the true case. + + -- Loop exit heuristic. + -- We are unlikely to leave a loop unless it's to enter another one. + pred_LEH = 0.75 + -- If and only if no successor is a loopheader, + -- then we will likely not exit the current loop body. + lehPredicts :: (TargetNodeInfo,TargetNodeInfo) -> Maybe Prob + lehPredicts ((s1,_s1_info),(s2,_s2_info)) + | S.member s1 loopHeads || S.member s2 loopHeads + = Nothing + + | otherwise + = --pprTrace "lehPredict:" (ppr $ compare s1Level s2Level) $ + case compare s1Level s2Level of + EQ -> Nothing + LT -> Just (1-pred_LEH) --s1 exits to a shallower loop level (exits loop) + GT -> Just (pred_LEH) --s1 exits to a deeper loop level + where + s1Level = mapLookup s1 loopLevels + s2Level = mapLookup s2 loopLevels + + -- Comparing to a constant is unlikely to be equal. + ohPredicts (s1,_s2) + | CmmSource { trans_cmmNode = src1 } <- getTransitionSource node (fst s1) cfg + , CmmCondBranch cond ltrue _lfalse likely <- src1 + , likely == Nothing + , CmmMachOp mop args <- cond + , MO_Eq {} <- mop + , not (null [x | x@CmmLit{} <- args]) + = if fst s1 == ltrue then Just 0.3 else Just 0.7 + + | otherwise + = Nothing + + -- TODO: These are all the other heuristics from the paper. + -- Not all will apply, for now we just stub them out as Nothing. + phPredicts = const Nothing + ghPredicts = const Nothing + lhhPredicts = const Nothing + chPredicts = const Nothing + shPredicts = const Nothing + rhPredicts = const Nothing + +-- We normalize all edge weights as probabilities between 0 and 1. +-- Ignoring rounding errors all outgoing edges sum up to 1. +cfgEdgeProbabilities :: CFG -> (BlockId -> Int) -> IM.IntMap (IM.IntMap Prob) +cfgEdgeProbabilities cfg toVertex + = mapFoldlWithKey foldEdges IM.empty cfg + where + foldEdges = (\m from toMap -> IM.insert (toVertex from) (normalize toMap) m) + + normalize :: (LabelMap EdgeInfo) -> (IM.IntMap Prob) + normalize weightMap + | edgeCount <= 1 = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) 1.0 m) IM.empty weightMap + | otherwise = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) (normalWeight k) m) IM.empty weightMap + where + edgeCount = mapSize weightMap + -- Negative weights are generally allowed but are mapped to zero. + -- We then check if there is at least one non-zero edge and if not + -- assign uniform weights to all branches. + minWeight = 0 :: Prob + weightMap' = fmap (\w -> max (weightToDouble . edgeWeight $ w) minWeight) weightMap + totalWeight = sum weightMap' + + normalWeight :: BlockId -> Prob + normalWeight bid + | totalWeight == 0 + = 1.0 / fromIntegral edgeCount + | Just w <- mapLookup bid weightMap' + = w/totalWeight + | otherwise = panic "impossible" + +-- This is the fixpoint algorithm from +-- "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus +-- The adaption to Haskell is my own. +calcFreqs :: IM.IntMap (IM.IntMap Prob) -> [(Int,Int)] -> [(Int, [Int])] -> [Int] + -> (Array Int Double, IM.IntMap (IM.IntMap Prob)) +calcFreqs graph backEdges loops revPostOrder = runST $ do + visitedNodes <- newArray (0,nodeCount-1) False :: ST s (STUArray s Int Bool) + blockFreqs <- newArray (0,nodeCount-1) 0.0 :: ST s (STUArray s Int Double) + edgeProbs <- newSTRef graph + edgeBackProbs <- newSTRef graph + + -- let traceArray a = do + -- vs <- forM [0..nodeCount-1] $ \i -> readArray a i >>= (\v -> return (i,v)) + -- trace ("array: " ++ show vs) $ return () + + let -- See #1600, we need to inline or unboxing makes perf worse. + -- {-# INLINE getFreq #-} + {-# INLINE visited #-} + visited b = unsafeRead visitedNodes b + getFreq b = unsafeRead blockFreqs b + -- setFreq :: forall s. Int -> Double -> ST s () + setFreq b f = unsafeWrite blockFreqs b f + -- setVisited :: forall s. Node -> ST s () + setVisited b = unsafeWrite visitedNodes b True + -- Frequency/probability that edge is taken. + getProb' arr b1 b2 = readSTRef arr >>= + (\graph -> + return . + fromMaybe (error "getFreq 1") . + IM.lookup b2 . + fromMaybe (error "getFreq 2") $ + (IM.lookup b1 graph) + ) + setProb' arr b1 b2 prob = do + g <- readSTRef arr + let !m = fromMaybe (error "Foo") $ IM.lookup b1 g + !m' = IM.insert b2 prob m + writeSTRef arr $! (IM.insert b1 m' g) + + getEdgeFreq b1 b2 = getProb' edgeProbs b1 b2 + setEdgeFreq b1 b2 = setProb' edgeProbs b1 b2 + getProb b1 b2 = fromMaybe (error "getProb") $ do + m' <- IM.lookup b1 graph + IM.lookup b2 m' + + getBackProb b1 b2 = getProb' edgeBackProbs b1 b2 + setBackProb b1 b2 = setProb' edgeBackProbs b1 b2 + + + let -- calcOutFreqs :: Node -> ST s () + calcOutFreqs bhead block = do + !f <- getFreq block + forM (successors block) $ \bi -> do + let !prob = getProb block bi + let !succFreq = f * prob + setEdgeFreq block bi succFreq + -- traceM $ "SetOut: " ++ show (block, bi, f, prob, succFreq) + when (bi == bhead) $ setBackProb block bi succFreq + + + let propFreq block head = do + -- traceM ("prop:" ++ show (block,head)) + -- traceShowM block + + !v <- visited block + if v then + return () --Dont look at nodes twice + else if block == head then + setFreq block 1.0 -- Loop header frequency is always 1 + else do + let preds = IS.elems $ predecessors block + irreducible <- (fmap or) $ forM preds $ \bp -> do + !bp_visited <- visited bp + let bp_backedge = isBackEdge bp block + return (not bp_visited && not bp_backedge) + + if irreducible + then return () -- Rare we don't care + else do + setFreq block 0 + !cycleProb <- sum <$> (forM preds $ \pred -> do + if isBackEdge pred block + then + getBackProb pred block + else do + !f <- getFreq block + !prob <- getEdgeFreq pred block + setFreq block $! f + prob + return 0) + -- traceM $ "cycleProb:" ++ show cycleProb + let limit = 1 - 1/512 -- Paper uses 1 - epsilon, but this works. + -- determines how large likelyhoods in loops can grow. + !cycleProb <- return $ min cycleProb limit -- <- return $ if cycleProb > limit then limit else cycleProb + -- traceM $ "cycleProb:" ++ show cycleProb + + !f <- getFreq block + setFreq block (f / (1.0 - cycleProb)) + + setVisited block + calcOutFreqs head block + + -- Loops, by nesting, inner to outer + forM_ loops $ \(head, body) -> do + forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i True) -- Mark all nodes as visited. + forM_ body (\i -> unsafeWrite visitedNodes i False) -- Mark all blocks reachable from head as not visited + forM_ body $ \block -> propFreq block head + + -- After dealing with all loops, deal with non-looping parts of the CFG + forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i False) -- Everything in revPostOrder is reachable + forM_ revPostOrder $ \block -> propFreq block (head revPostOrder) + + -- trace ("Final freqs:") $ return () + -- let freqString = pprFreqs freqs + -- trace (unlines freqString) $ return () + -- trace (pprFre) $ return () + graph' <- readSTRef edgeProbs + freqs' <- unsafeFreeze blockFreqs + + return (freqs', graph') + where + -- How can these lookups fail? Consider the CFG [A -> B] + predecessors :: Int -> IS.IntSet + predecessors b = fromMaybe IS.empty $ IM.lookup b revGraph + successors :: Int -> [Int] + successors b = fromMaybe (lookupError "succ" b graph)$ IM.keys <$> IM.lookup b graph + lookupError s b g = pprPanic ("Lookup error " ++ s) $ + ( text "node" <+> ppr b $$ + text "graph" <+> + vcat (map (\(k,m) -> ppr (k,m :: IM.IntMap Double)) $ IM.toList g) + ) + + nodeCount = IM.foldl' (\count toMap -> IM.foldlWithKey' countTargets (count + 1) toMap) 0 graph + where + countTargets = (\count k _ -> countNode k + count ) + countNode n = if IM.member n graph then 0 else 1 + + isBackEdge from to = S.member (from,to) backEdgeSet + backEdgeSet = S.fromList backEdges + + revGraph :: IntMap IntSet + revGraph = IM.foldlWithKey' (\m from toMap -> addEdges m from toMap) IM.empty graph + where + addEdges m0 from toMap = IM.foldlWithKey' (\m k _ -> addEdge m from k) m0 toMap + addEdge m0 from to = IM.insertWith IS.union to (IS.singleton from) m0 diff --git a/GHC/CmmToAsm/CFG/Dominators.hs b/GHC/CmmToAsm/CFG/Dominators.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/CFG/Dominators.hs @@ -0,0 +1,585 @@ +{-# LANGUAGE Strict #-} + +{- | + Module : GHC.CmmToAsm.CFG.Dominators + Copyright : (c) Matt Morrow 2009 + License : BSD3 + Maintainer : + Stability : stable + Portability : portable + + The Lengauer-Tarjan graph dominators algorithm. + + \[1\] Lengauer, Tarjan, + /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979. + + \[2\] Muchnick, + /Advanced Compiler Design and Implementation/, 1997. + + \[3\] Brisk, Sarrafzadeh, + /Interference CGraphs for Procedures in Static Single/ + /Information Form are Interval CGraphs/, 2007. + + * Strictness + + Unless stated otherwise all exposed functions might fully evaluate their input + but are not guaranteed to do so. + +-} + +module GHC.CmmToAsm.CFG.Dominators ( + Node,Path,Edge + ,Graph,Rooted + ,idom,ipdom + ,domTree,pdomTree + ,dom,pdom + ,pddfs,rpddfs + ,fromAdj,fromEdges + ,toAdj,toEdges + ,asTree,asCGraph + ,parents,ancestors +) where + +import GHC.Prelude +import Data.Bifunctor +import Data.Tuple (swap) + +import Data.Tree +import Data.IntMap(IntMap) +import Data.IntSet(IntSet) +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS + +import Control.Monad +import Control.Monad.ST.Strict + +import Data.Array.ST +import Data.Array.Base + (unsafeNewArray_ + ,unsafeWrite,unsafeRead) +import GHC.Data.Word64Set (Word64Set) +import qualified GHC.Data.Word64Set as WS +import GHC.Data.Word64Map (Word64Map) +import qualified GHC.Data.Word64Map as WM +import Data.Word + +----------------------------------------------------------------------------- + +-- Compacted nodes; these can be stored in contiguous arrays +type CNode = Int +type CGraph = IntMap IntSet + +type Node = Word64 +type Path = [Node] +type Edge = (Node, Node) +type Graph = Word64Map Word64Set +type Rooted = (Node, Graph) + +----------------------------------------------------------------------------- + +-- | /Dominators/. +-- Complexity as for @idom@ +dom :: Rooted -> [(Node, Path)] +dom = ancestors . domTree + +-- | /Post-dominators/. +-- Complexity as for @idom@. +pdom :: Rooted -> [(Node, Path)] +pdom = ancestors . pdomTree + +-- | /Dominator tree/. +-- Complexity as for @idom@. +domTree :: Rooted -> Tree Node +domTree a@(r,_) = + let is = filter ((/=r).fst) (idom a) + tg = fromEdges (fmap swap is) + in asTree (r,tg) + +-- | /Post-dominator tree/. +-- Complexity as for @idom@. +pdomTree :: Rooted -> Tree Node +pdomTree a@(r,_) = + let is = filter ((/=r).fst) (ipdom a) + tg = fromEdges (fmap swap is) + in asTree (r,tg) + +-- | /Immediate dominators/. +-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is +-- \"a functional inverse of Ackermann's function\". +-- +-- This Complexity bound assumes /O(1)/ indexing. Since we're +-- using @IntMap@, it has an additional /lg |V|/ factor +-- somewhere in there. I'm not sure where. +idom :: Rooted -> [(Node,Node)] +idom rg = runST (evalS idomM =<< initEnv (pruneReach rg)) + +-- | /Immediate post-dominators/. +-- Complexity as for @idom@. +ipdom :: Rooted -> [(Node,Node)] +ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predGW rg))) + +----------------------------------------------------------------------------- + +-- | /Post-dominated depth-first search/. +pddfs :: Rooted -> [Node] +pddfs = reverse . rpddfs + +-- | /Reverse post-dominated depth-first search/. +rpddfs :: Rooted -> [Node] +rpddfs = concat . levels . pdomTree + +----------------------------------------------------------------------------- + +type Dom s a = S s (Env s) a +type NodeSet = Word64Set +type NodeMap a = Word64Map a +data Env s = Env + {succE :: !CGraph + ,predE :: !CGraph + ,bucketE :: !CGraph + ,dfsE :: {-# UNPACK #-}!Int + ,zeroE :: {-# UNPACK #-}!CNode + ,rootE :: {-# UNPACK #-}!CNode + ,labelE :: {-# UNPACK #-}!(Arr s CNode) + ,parentE :: {-# UNPACK #-}!(Arr s CNode) + ,ancestorE :: {-# UNPACK #-}!(Arr s CNode) + ,childE :: {-# UNPACK #-}!(Arr s CNode) + ,ndfsE :: {-# UNPACK #-}!(Arr s CNode) + ,dfnE :: {-# UNPACK #-}!(Arr s Int) + ,sdnoE :: {-# UNPACK #-}!(Arr s Int) + ,sizeE :: {-# UNPACK #-}!(Arr s Int) + ,domE :: {-# UNPACK #-}!(Arr s CNode) + ,rnE :: {-# UNPACK #-}!(Arr s Node)} + +----------------------------------------------------------------------------- + +idomM :: Dom s [(Node,Node)] +idomM = do + dfsDom =<< rootM + n <- gets dfsE + forM_ [n,n-1..1] (\i-> do + w <- ndfsM i + ps <- predsM w + forM_ ps (\v-> do + sw <- sdnoM w + u <- eval v + su <- sdnoM u + when (su < sw) + (store sdnoE w su)) + z <- ndfsM =<< sdnoM w + modify(\e->e{bucketE=IM.adjust + (w`IS.insert`) + z (bucketE e)}) + pw <- parentM w + link pw w + bps <- bucketM pw + forM_ bps (\v-> do + u <- eval v + su <- sdnoM u + sv <- sdnoM v + let dv = case su < sv of + True-> u + False-> pw + store domE v dv)) + forM_ [1..n] (\i-> do + w <- ndfsM i + j <- sdnoM w + z <- ndfsM j + dw <- domM w + when (dw /= z) + (do ddw <- domM dw + store domE w ddw)) + fromEnv + +----------------------------------------------------------------------------- + +eval :: CNode -> Dom s CNode +eval v = do + n0 <- zeroM + a <- ancestorM v + case a==n0 of + True-> labelM v + False-> do + compress v + a <- ancestorM v + l <- labelM v + la <- labelM a + sl <- sdnoM l + sla <- sdnoM la + case sl <= sla of + True-> return l + False-> return la + +compress :: CNode -> Dom s () +compress v = do + n0 <- zeroM + a <- ancestorM v + aa <- ancestorM a + when (aa /= n0) (do + compress a + a <- ancestorM v + aa <- ancestorM a + l <- labelM v + la <- labelM a + sl <- sdnoM l + sla <- sdnoM la + when (sla < sl) + (store labelE v la) + store ancestorE v aa) + +----------------------------------------------------------------------------- + +link :: CNode -> CNode -> Dom s () +link v w = do + n0 <- zeroM + lw <- labelM w + slw <- sdnoM lw + let balance s = do + c <- childM s + lc <- labelM c + slc <- sdnoM lc + case slw < slc of + False-> return s + True-> do + zs <- sizeM s + zc <- sizeM c + cc <- childM c + zcc <- sizeM cc + case 2*zc <= zs+zcc of + True-> do + store ancestorE c s + store childE s cc + balance s + False-> do + store sizeE c zs + store ancestorE s c + balance c + s <- balance w + lw <- labelM w + zw <- sizeM w + store labelE s lw + store sizeE v . (+zw) =<< sizeM v + let follow s = + when (s /= n0) (do + store ancestorE s v + follow =<< childM s) + zv <- sizeM v + follow =<< case zv < 2*zw of + False-> return s + True-> do + cv <- childM v + store childE v s + return cv + +----------------------------------------------------------------------------- + +dfsDom :: CNode -> Dom s () +dfsDom i = do + _ <- go i + n0 <- zeroM + r <- rootM + store parentE r n0 + where go i = do + n <- nextM + store dfnE i n + store sdnoE i n + store ndfsE n i + store labelE i i + ss <- succsM i + forM_ ss (\j-> do + s <- sdnoM j + case s==0 of + False-> return() + True-> do + store parentE j i + go j) + +----------------------------------------------------------------------------- + +initEnv :: Rooted -> ST s (Env s) +initEnv (r0,g0) = do + -- CGraph renumbered to indices from 1 to |V| + let (g,rnmap) = renum 1 g0 + pred = predG g -- reverse graph + root = rnmap WM.! r0 -- renamed root + n = IM.size g + ns = [0..n] + m = n+1 + + let bucket = IM.fromList + (zip ns (repeat mempty)) + + rna <- newW m + writes rna (fmap swap + (WM.toList rnmap)) + + doms <- newI m + sdno <- newI m + size <- newI m + parent <- newI m + ancestor <- newI m + child <- newI m + label <- newI m + ndfs <- newI m + dfn <- newI m + + -- Initialize all arrays + forM_ [0..n] (doms.=0) + forM_ [0..n] (sdno.=0) + forM_ [1..n] (size.=1) + forM_ [0..n] (ancestor.=0) + forM_ [0..n] (child.=0) + + (doms.=root) root + (size.=0) 0 + (label.=0) 0 + + return (Env + {rnE = rna + ,dfsE = 0 + ,zeroE = 0 + ,rootE = root + ,labelE = label + ,parentE = parent + ,ancestorE = ancestor + ,childE = child + ,ndfsE = ndfs + ,dfnE = dfn + ,sdnoE = sdno + ,sizeE = size + ,succE = g + ,predE = pred + ,bucketE = bucket + ,domE = doms}) + +fromEnv :: Dom s [(Node,Node)] +fromEnv = do + dom <- gets domE + rn <- gets rnE + -- r <- gets rootE + (_,n) <- st (getBounds dom) + forM [1..n] (\i-> do + j <- st(rn!:i) + d <- st(dom!:i) + k <- st(rn!:d) + return (j,k)) + +----------------------------------------------------------------------------- + +zeroM :: Dom s CNode +zeroM = gets zeroE +domM :: CNode -> Dom s CNode +domM = fetch domE +rootM :: Dom s CNode +rootM = gets rootE +succsM :: CNode -> Dom s [CNode] +succsM i = gets (IS.toList . (! i) . succE) +predsM :: CNode -> Dom s [CNode] +predsM i = gets (IS.toList . (! i) . predE) +bucketM :: CNode -> Dom s [CNode] +bucketM i = gets (IS.toList . (! i) . bucketE) +sizeM :: CNode -> Dom s Int +sizeM = fetch sizeE +sdnoM :: CNode -> Dom s Int +sdnoM = fetch sdnoE +-- dfnM :: CNode -> Dom s Int +-- dfnM = fetch dfnE +ndfsM :: Int -> Dom s CNode +ndfsM = fetch ndfsE +childM :: CNode -> Dom s CNode +childM = fetch childE +ancestorM :: CNode -> Dom s CNode +ancestorM = fetch ancestorE +parentM :: CNode -> Dom s CNode +parentM = fetch parentE +labelM :: CNode -> Dom s CNode +labelM = fetch labelE +nextM :: Dom s Int +nextM = do + n <- gets dfsE + let n' = n+1 + modify(\e->e{dfsE=n'}) + return n' + +----------------------------------------------------------------------------- + +type A = STUArray +type Arr s a = A s Int a + +infixl 9 !: +infixr 2 .= + +-- | arr .= x idx => write x to index +(.=) :: (MArray (A s) a (ST s)) + => Arr s a -> a -> Int -> ST s () +(v .= x) i = unsafeWrite v i x + +(!:) :: (MArray (A s) a (ST s)) + => A s Int a -> Int -> ST s a +a !: i = do + o <- unsafeRead a i + return $! o + +new :: (MArray (A s) a (ST s)) + => Int -> ST s (Arr s a) +new n = unsafeNewArray_ (0,n-1) + +newI :: Int -> ST s (Arr s Int) +newI = new + +newW :: Int -> ST s (Arr s Node) +newW = new + +writes :: (MArray (A s) a (ST s)) + => Arr s a -> [(Int,a)] -> ST s () +writes a xs = forM_ xs (\(i,x) -> (a.=x) i) + + +(!) :: Monoid a => IntMap a -> Int -> a +(!) g n = maybe mempty id (IM.lookup n g) + +fromAdj :: [(Node, [Node])] -> Graph +fromAdj = WM.fromList . fmap (second WS.fromList) + +fromEdges :: [Edge] -> Graph +fromEdges = collectW WS.union fst (WS.singleton . snd) + +toAdj :: Graph -> [(Node, [Node])] +toAdj = fmap (second WS.toList) . WM.toList + +toEdges :: Graph -> [Edge] +toEdges = concatMap (uncurry (fmap . (,))) . toAdj + +predG :: CGraph -> CGraph +predG g = IM.unionWith IS.union (go g) g0 + where g0 = fmap (const mempty) g + go = flip IM.foldrWithKey mempty (\i a m -> + foldl' (\m p -> IM.insertWith mappend p + (IS.singleton i) m) + m + (IS.toList a)) + +predGW :: Graph -> Graph +predGW g = WM.unionWith WS.union (go g) g0 + where g0 = fmap (const mempty) g + go = flip WM.foldrWithKey mempty (\i a m -> + foldl' (\m p -> WM.insertWith mappend p + (WS.singleton i) m) + m + (WS.toList a)) + +pruneReach :: Rooted -> Rooted +pruneReach (r,g) = (r,g2) + where is = reachable + (maybe mempty id + . flip WM.lookup g) $ r + g2 = WM.fromList + . fmap (second (WS.filter (`WS.member`is))) + . filter ((`WS.member`is) . fst) + . WM.toList $ g + +tip :: Tree a -> (a, [Tree a]) +tip (Node a ts) = (a, ts) + +parents :: Tree a -> [(a, a)] +parents (Node i xs) = p i xs + ++ concatMap parents xs + where p i = fmap (flip (,) i . rootLabel) + +ancestors :: Tree a -> [(a, [a])] +ancestors = go [] + where go acc (Node i xs) + = let acc' = i:acc + in p acc' xs ++ concatMap (go acc') xs + p is = fmap (flip (,) is . rootLabel) + +asCGraph :: Tree Node -> Rooted +asCGraph t@(Node a _) = let g = go t in (a, fromAdj g) + where go (Node a ts) = let as = (fst . unzip . fmap tip) ts + in (a, as) : concatMap go ts + +asTree :: Rooted -> Tree Node +asTree (r,g) = let go a = Node a (fmap go ((WS.toList . f) a)) + f = (g !) + in go r + where (!) g n = maybe mempty id (WM.lookup n g) + + +reachable :: (Node -> NodeSet) -> (Node -> NodeSet) +reachable f a = go (WS.singleton a) a + where go seen a = let s = f a + as = WS.toList (s `WS.difference` seen) + in foldl' go (s `WS.union` seen) as + +collectW :: (c -> c -> c) + -> (a -> Node) -> (a -> c) -> [a] -> Word64Map c +collectW (<>) f g + = foldl' (\m a -> WM.insertWith (<>) + (f a) + (g a) m) mempty + +-- | renum n g: Rename all nodes +-- +-- Gives nodes sequential names starting at n. +-- Returns the new graph and a mapping. +-- (renamed, old -> new) +renum :: Int -> Graph -> (CGraph, NodeMap CNode) +renum from = (\(_,m,g)->(g,m)) + . WM.foldrWithKey + (\i ss (!n,!env,!new)-> + let (j,n2,env2) = go n env i + (n3,env3,ss2) = WS.fold + (\k (!n,!env,!new)-> + case go n env k of + (l,n2,env2)-> (n2,env2,l `IS.insert` new)) + (n2,env2,mempty) ss + new2 = IM.insertWith IS.union j ss2 new + in (n3,env3,new2)) (from,mempty,mempty) + where go :: Int + -> NodeMap CNode + -> Node + -> (CNode,Int,NodeMap CNode) + go !n !env i = + case WM.lookup i env of + Just j -> (j,n,env) + Nothing -> (n,n+1,WM.insert i n env) + +----------------------------------------------------------------------------- + +-- Nothing better than reinventing the state monad. +newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o} + deriving (Functor) +instance Monad (S z s) where + return = pure + S g >>= f = S (\k -> g (\a -> unS (f a) k)) +instance Applicative (S z s) where + pure a = S (\k -> k a) + (<*>) = ap +-- get :: S z s s +-- get = S (\k s -> k s s) +gets :: (s -> a) -> S z s a +gets f = S (\k s -> k (f s) s) +-- set :: s -> S z s () +-- set s = S (\k _ -> k () s) +modify :: (s -> s) -> S z s () +modify f = S (\k -> k () . f) +-- runS :: S z s a -> s -> ST z (a, s) +-- runS (S g) = g (\a s -> return (a,s)) +evalS :: S z s a -> s -> ST z a +evalS (S g) = g ((return .) . const) +-- execS :: S z s a -> s -> ST z s +-- execS (S g) = g ((return .) . flip const) +st :: ST z a -> S z s a +st m = S (\k s-> do + a <- m + k a s) +store :: (MArray (A z) a (ST z)) + => (s -> Arr z a) -> Int -> a -> S z s () +store f i x = do + a <- gets f + st ((a.=x) i) +fetch :: (MArray (A z) a (ST z)) + => (s -> Arr z a) -> Int -> S z s a +fetch f i = do + a <- gets f + st (a!:i) diff --git a/GHC/CmmToAsm/CFG/Weight.hs b/GHC/CmmToAsm/CFG/Weight.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/CFG/Weight.hs @@ -0,0 +1,78 @@ +module GHC.CmmToAsm.CFG.Weight + ( Weights (..) + , defaultWeights + , parseWeights + ) +where + +import GHC.Prelude +import GHC.Utils.Panic + +-- | Edge weights to use when generating a CFG from CMM +data Weights = Weights + { uncondWeight :: Int + , condBranchWeight :: Int + , switchWeight :: Int + , callWeight :: Int + , likelyCondWeight :: Int + , unlikelyCondWeight :: Int + , infoTablePenalty :: Int + , backEdgeBonus :: Int + } + +-- | Default edge weights +defaultWeights :: Weights +defaultWeights = Weights + { uncondWeight = 1000 + , condBranchWeight = 800 + , switchWeight = 1 + , callWeight = -10 + , likelyCondWeight = 900 + , unlikelyCondWeight = 300 + , infoTablePenalty = 300 + , backEdgeBonus = 400 + } + +parseWeights :: String -> Weights -> Weights +parseWeights s oldWeights = + foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments + where + assignments = map assignment $ settings s + update "uncondWeight" n w = + w {uncondWeight = n} + update "condBranchWeight" n w = + w {condBranchWeight = n} + update "switchWeight" n w = + w {switchWeight = n} + update "callWeight" n w = + w {callWeight = n} + update "likelyCondWeight" n w = + w {likelyCondWeight = n} + update "unlikelyCondWeight" n w = + w {unlikelyCondWeight = n} + update "infoTablePenalty" n w = + w {infoTablePenalty = n} + update "backEdgeBonus" n w = + w {backEdgeBonus = n} + update other _ _ + = panic $ other ++ + " is not a CFG weight parameter. " ++ + exampleString + settings s + | (s1,rest) <- break (== ',') s + , null rest + = [s1] + | (s1,rest) <- break (== ',') s + = s1 : settings (drop 1 rest) + + assignment as + | (name, _:val) <- break (== '=') as + = (name,read val) + | otherwise + = panic $ "Invalid CFG weight parameters." ++ exampleString + + exampleString = "Example parameters: uncondWeight=1000," ++ + "condBranchWeight=800,switchWeight=0,callWeight=300" ++ + ",likelyCondWeight=900,unlikelyCondWeight=300" ++ + ",infoTablePenalty=300,backEdgeBonus=400" + diff --git a/GHC/CmmToAsm/CPrim.hs b/GHC/CmmToAsm/CPrim.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/CPrim.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Generating C symbol names emitted by the compiler. +module GHC.CmmToAsm.CPrim + ( atomicReadLabel + , atomicWriteLabel + , atomicRMWLabel + , cmpxchgLabel + , xchgLabel + , popCntLabel + , pdepLabel + , pextLabel + , bSwapLabel + , bRevLabel + , clzLabel + , ctzLabel + , word2FloatLabel + ) where + +import GHC.Cmm.Type +import GHC.Cmm.MachOp +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic + +popCntLabel :: Width -> FastString +popCntLabel = \case + W8 -> fsLit "hs_popcnt8" + W16 -> fsLit "hs_popcnt16" + W32 -> fsLit "hs_popcnt32" + W64 -> fsLit "hs_popcnt64" + w -> pprPanic "popCntLabel: Unsupported word width " (ppr w) + +pdepLabel :: Width -> FastString +pdepLabel = \case + W8 -> fsLit "hs_pdep8" + W16 -> fsLit "hs_pdep16" + W32 -> fsLit "hs_pdep32" + W64 -> fsLit "hs_pdep64" + w -> pprPanic "pdepLabel: Unsupported word width " (ppr w) + +pextLabel :: Width -> FastString +pextLabel = \case + W8 -> fsLit "hs_pext8" + W16 -> fsLit "hs_pext16" + W32 -> fsLit "hs_pext32" + W64 -> fsLit "hs_pext64" + w -> pprPanic "pextLabel: Unsupported word width " (ppr w) + +bSwapLabel :: Width -> FastString +bSwapLabel = \case + W16 -> fsLit "hs_bswap16" + W32 -> fsLit "hs_bswap32" + W64 -> fsLit "hs_bswap64" + w -> pprPanic "bSwapLabel: Unsupported word width " (ppr w) + +bRevLabel :: Width -> FastString +bRevLabel = \case + W8 -> fsLit "hs_bitrev8" + W16 -> fsLit "hs_bitrev16" + W32 -> fsLit "hs_bitrev32" + W64 -> fsLit "hs_bitrev64" + w -> pprPanic "bRevLabel: Unsupported word width " (ppr w) + +clzLabel :: Width -> FastString +clzLabel = \case + W8 -> fsLit "hs_clz8" + W16 -> fsLit "hs_clz16" + W32 -> fsLit "hs_clz32" + W64 -> fsLit "hs_clz64" + w -> pprPanic "clzLabel: Unsupported word width " (ppr w) + +ctzLabel :: Width -> FastString +ctzLabel = \case + W8 -> fsLit "hs_ctz8" + W16 -> fsLit "hs_ctz16" + W32 -> fsLit "hs_ctz32" + W64 -> fsLit "hs_ctz64" + w -> pprPanic "ctzLabel: Unsupported word width " (ppr w) + +word2FloatLabel :: Width -> FastString +word2FloatLabel = \case + W32 -> fsLit "hs_word2float32" + W64 -> fsLit "hs_word2float64" + w -> pprPanic "word2FloatLabel: Unsupported word width " (ppr w) + +atomicRMWLabel :: Width -> AtomicMachOp -> FastString +atomicRMWLabel w amop = case amop of + -- lots of boring cases, but we do it this way to get shared FastString + -- literals (compared to concatenating strings and allocating FastStrings at + -- runtime) + AMO_Add -> case w of + W8 -> fsLit "hs_atomic_add8" + W16 -> fsLit "hs_atomic_add16" + W32 -> fsLit "hs_atomic_add32" + W64 -> fsLit "hs_atomic_add64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + AMO_Sub -> case w of + W8 -> fsLit "hs_atomic_sub8" + W16 -> fsLit "hs_atomic_sub16" + W32 -> fsLit "hs_atomic_sub32" + W64 -> fsLit "hs_atomic_sub64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + AMO_And -> case w of + W8 -> fsLit "hs_atomic_and8" + W16 -> fsLit "hs_atomic_and16" + W32 -> fsLit "hs_atomic_and32" + W64 -> fsLit "hs_atomic_and64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + AMO_Nand -> case w of + W8 -> fsLit "hs_atomic_nand8" + W16 -> fsLit "hs_atomic_nand16" + W32 -> fsLit "hs_atomic_nand32" + W64 -> fsLit "hs_atomic_nand64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + AMO_Or -> case w of + W8 -> fsLit "hs_atomic_or8" + W16 -> fsLit "hs_atomic_or16" + W32 -> fsLit "hs_atomic_or32" + W64 -> fsLit "hs_atomic_or64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + AMO_Xor -> case w of + W8 -> fsLit "hs_atomic_xor8" + W16 -> fsLit "hs_atomic_xor16" + W32 -> fsLit "hs_atomic_xor32" + W64 -> fsLit "hs_atomic_xor64" + _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + + +xchgLabel :: Width -> FastString +xchgLabel = \case + W8 -> fsLit "hs_xchg8" + W16 -> fsLit "hs_xchg16" + W32 -> fsLit "hs_xchg32" + W64 -> fsLit "hs_xchg64" + w -> pprPanic "xchgLabel: Unsupported word width " (ppr w) + +cmpxchgLabel :: Width -> FastString +cmpxchgLabel = \case + W8 -> fsLit "hs_cmpxchg8" + W16 -> fsLit "hs_cmpxchg16" + W32 -> fsLit "hs_cmpxchg32" + W64 -> fsLit "hs_cmpxchg64" + w -> pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) + +atomicReadLabel :: Width -> FastString +atomicReadLabel = \case + W8 -> fsLit "hs_atomicread8" + W16 -> fsLit "hs_atomicread16" + W32 -> fsLit "hs_atomicread32" + W64 -> fsLit "hs_atomicread64" + w -> pprPanic "atomicReadLabel: Unsupported word width " (ppr w) + +atomicWriteLabel :: Width -> FastString +atomicWriteLabel = \case + W8 -> fsLit "hs_atomicwrite8" + W16 -> fsLit "hs_atomicwrite16" + W32 -> fsLit "hs_atomicwrite32" + W64 -> fsLit "hs_atomicwrite64" + w -> pprPanic "atomicWriteLabel: Unsupported word width " (ppr w) diff --git a/GHC/CmmToAsm/Config.hs b/GHC/CmmToAsm/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Config.hs @@ -0,0 +1,67 @@ +-- | Native code generator configuration +module GHC.CmmToAsm.Config + ( NCGConfig(..) + , ncgWordWidth + , ncgSpillPreallocSize + , platformWordWidth + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Cmm.Type (Width(..)) +import GHC.CmmToAsm.CFG.Weight +import GHC.Unit.Module (Module) +import GHC.Utils.Outputable + +-- | Native code generator configuration +data NCGConfig = NCGConfig + { ncgPlatform :: !Platform -- ^ Target platform + , ncgAsmContext :: !SDocContext -- ^ Context for ASM code generation + , ncgThisModule :: !Module -- ^ The name of the module we are currently compiling + , ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment + , ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries + , ncgPIC :: !Bool -- ^ Enable Position-Independent Code + , ncgInlineThresholdMemcpy :: !Word -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it + , ncgInlineThresholdMemset :: !Word -- ^ Ditto for `memset` + , ncgSplitSections :: !Bool -- ^ Split sections + , ncgRegsIterative :: !Bool + , ncgRegsGraph :: !Bool + , ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass + , ncgDoConstantFolding :: !Bool -- ^ Perform CMM constant folding + , ncgSseVersion :: Maybe SseVersion -- ^ (x86) SSE instructions + , ncgAvxEnabled :: !Bool + , ncgAvx2Enabled :: !Bool + , ncgAvx512fEnabled :: !Bool + , ncgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions + , ncgDumpRegAllocStages :: !Bool + , ncgDumpAsmStats :: !Bool + , ncgDumpAsmConflicts :: !Bool + , ncgCfgWeights :: !Weights -- ^ CFG edge weights + , ncgCfgBlockLayout :: !Bool -- ^ Use CFG based block layout algorithm + , ncgCfgWeightlessLayout :: !Bool -- ^ Layout based on last instruction per block. + , ncgDwarfEnabled :: !Bool -- ^ Enable Dwarf generation + , ncgDwarfUnwindings :: !Bool -- ^ Enable unwindings + , ncgDwarfStripBlockInfo :: !Bool -- ^ Strip out block information from generated Dwarf + , ncgExposeInternalSymbols :: !Bool -- ^ Expose symbol table entries for internal symbols + , ncgDwarfSourceNotes :: !Bool -- ^ Enable GHC-specific source note DIEs + , ncgCmmStaticPred :: !Bool -- ^ Enable static control-flow prediction + , ncgEnableShortcutting :: !Bool -- ^ Enable shortcutting (don't jump to blocks only containing a jump) + , ncgEnableInterModuleFarJumps:: !Bool -- ^ Use far-jumps for cross-module jumps. + , ncgComputeUnwinding :: !Bool -- ^ Compute block unwinding tables + , ncgEnableDeadCodeElimination :: !Bool -- ^ Whether to enable the dead-code elimination + } + +-- | Return Word size +ncgWordWidth :: NCGConfig -> Width +ncgWordWidth config = platformWordWidth (ncgPlatform config) + +-- | Size in bytes of the pre-allocated spill space on the C stack +ncgSpillPreallocSize :: NCGConfig -> Int +ncgSpillPreallocSize config = pc_RESERVED_C_STACK_BYTES (platformConstants (ncgPlatform config)) + +-- | Return Word size +platformWordWidth :: Platform -> Width +platformWordWidth platform = case platformWordSize platform of + PW4 -> W32 + PW8 -> W64 diff --git a/GHC/CmmToAsm/Dwarf.hs b/GHC/CmmToAsm/Dwarf.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Dwarf.hs @@ -0,0 +1,271 @@ +module GHC.CmmToAsm.Dwarf ( + dwarfGen + ) where + +import GHC.Prelude + +import GHC.Cmm.CLabel +import GHC.Cmm.Expr +import GHC.Data.FastString +import GHC.Settings.Config ( cProjectName, cProjectVersion ) +import GHC.Types.Tickish ( CmmTickish, GenTickish(..) ) +import GHC.Cmm.DebugBlock +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique +import GHC.Types.Unique.DSM + +import GHC.CmmToAsm.Dwarf.Constants +import GHC.CmmToAsm.Dwarf.Types +import GHC.CmmToAsm.Config + +import Control.Arrow ( first ) +import Control.Monad ( mfilter ) +import Data.Maybe +import Data.List ( sortBy ) +import Data.Ord ( comparing ) +import qualified Data.Map as Map +import System.FilePath + +import qualified GHC.Cmm.Dataflow.Label as H + +-- | Generate DWARF/debug information +dwarfGen :: IsDoc doc => String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (doc, DUniqSupply) +dwarfGen _ _ _ us [] = (empty, us) +dwarfGen compPath config modLoc us blocks = + let platform = ncgPlatform config + + -- Convert debug data structures to DWARF info records + procs = debugSplitProcs blocks + stripBlocks dbg + | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] } + | otherwise = dbg + lowLabel = dblCLabel $ head procs + highLabel = mkAsmTempProcEndLabel $ dblCLabel $ last procs + dwarfUnit = DwarfCompileUnit + { dwChildren = map (procToDwarf config) (map stripBlocks procs) + , dwName = fromMaybe "" (ml_hs_file modLoc) + , dwCompDir = addTrailingPathSeparator compPath + , dwProducer = cProjectName ++ " " ++ cProjectVersion + , dwLowLabel = lowLabel + , dwHighLabel = highLabel + } + + -- Check whether we have any source code information, so we do not + -- end up writing a pointer to an empty .debug_line section + -- (dsymutil on Mac Os gets confused by this). + haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk) + || any haveSrcIn (dblBlocks blk) + haveSrc = any haveSrcIn procs + + -- .debug_abbrev section: Declare the format we're using + abbrevSct = pprAbbrevDecls platform haveSrc + + -- .debug_info section: Information records on procedures and blocks + -- unique to identify start and end compilation unit .debug_inf + (unitU, us') = takeUniqueFromDSupply us + infoSct = vcat [ line (dwarfInfoLabel <> colon) + , dwarfInfoSection platform + , compileUnitHeader platform unitU + , pprDwarfInfo platform haveSrc dwarfUnit + , compileUnitFooter platform unitU + ] + + -- .debug_line section: Generated mainly by the assembler, but we + -- need to label it + lineSct = dwarfLineSection platform $$ + line (dwarfLineLabel <> colon) + + -- .debug_frame section: Information about the layout of the GHC stack + (framesU, us'') = takeUniqueFromDSupply us' + frameSct = dwarfFrameSection platform $$ + line (dwarfFrameLabel <> colon) $$ + pprDwarfFrame platform (debugFrame platform framesU procs) + + -- .aranges section: Information about the bounds of compilation units + aranges' | ncgSplitSections config = map mkDwarfARange procs + | otherwise = [DwarfARange lowLabel highLabel] + aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU + + in (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'') +{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (SDoc, DUniqSupply) #-} +{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (HDoc, DUniqSupply) #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Build an address range entry for one proc. +-- With split sections, each proc needs its own entry, since they may get +-- scattered in the final binary. Without split sections, we could make a +-- single arange based on the first/last proc. +mkDwarfARange :: DebugBlock -> DwarfARange +mkDwarfARange proc = DwarfARange lbl end + where + lbl = dblCLabel proc + end = mkAsmTempProcEndLabel lbl + +-- | Header for a compilation unit, establishing global format +-- parameters +compileUnitHeader :: IsDoc doc => Platform -> Unique -> doc +compileUnitHeader platform unitU = + let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field + length = pprAsmLabel platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pprAsmLabel platform cuLabel + <> text "-4" -- length of initialLength field + in vcat [ line (pprAsmLabel platform cuLabel <> colon) + , line (text "\t.long " <> length) -- compilation unit size + , pprHalf 3 -- DWARF version + , sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel + -- abbrevs offset + , line (text "\t.byte " <> int (platformWordSizeInBytes platform)) -- word size + ] + +-- | Compilation unit footer, mainly establishing size of debug sections +compileUnitFooter :: IsDoc doc => Platform -> Unique -> doc +compileUnitFooter platform unitU = + let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU + in line (pprAsmLabel platform cuEndLabel <> colon) + +-- | Splits the blocks by procedures. In the result all nested blocks +-- will come from the same procedure as the top-level block. See +-- Note [Splitting DebugBlocks] for details. +debugSplitProcs :: [DebugBlock] -> [DebugBlock] +debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b + where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty + split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock] + split parent blk = H.mapInsert prc [blk'] nested + where prc = dblProcedure blk + blk' = blk { dblBlocks = own_blks + , dblParent = parent + } + own_blks = fromMaybe [] $ H.mapLookup prc nested + nested = mergeMaps $ map (split parent') $ dblBlocks blk + -- Figure out who should be the parent of nested blocks. + -- If @blk@ is optimized out then it isn't a good choice + -- and we just use its parent. + parent' + | Nothing <- dblPosition blk = parent + | otherwise = Just blk + +{- +Note [Splitting DebugBlocks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DWARF requires that we break up the nested DebugBlocks produced from +the C-- AST. For instance, we begin with tick trees containing nested procs. +For example, + + proc A [tick1, tick2] + block B [tick3] + proc C [tick4] + +when producing DWARF we need to procs (which are represented in DWARF as +TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for +this transform, pulling out the nested procs into top-level procs. + +However, in doing this we need to be careful to preserve the parentage of the +nested procs. This is the reason DebugBlocks carry the dblParent field, allowing +us to reorganize the above tree as, + + proc A [tick1, tick2] + block B [tick3] + proc C [tick4] parent=B + +Here we have annotated the new proc C with an attribute giving its original +parent, B. +-} + +-- | Generate DWARF info for a procedure debug block +procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo +procToDwarf config prc + = DwarfSubprogram { dwChildren = map (blockToDwarf config) (dblBlocks prc) + , dwName = case dblSourceTick prc of + Just s@SourceNote{} -> case sourceName s of + LexicalFastString s -> unpackFS s + _otherwise -> show (dblLabel prc) + , dwLabel = dblCLabel prc + , dwParent = fmap mkAsmTempDieLabel + $ mfilter goodParent + $ fmap dblCLabel (dblParent prc) + } + where + goodParent a | a == dblCLabel prc = False + -- Omit parent if it would be self-referential + goodParent a | not (externallyVisibleCLabel a) + , ncgDwarfStripBlockInfo config = False + -- If we strip block information, don't refer to blocks. + -- Fixes #14894. + goodParent _ = True + +-- | Generate DWARF info for a block +blockToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo +blockToDwarf config blk + = DwarfBlock { dwChildren = map (blockToDwarf config) (dblBlocks blk) ++ srcNotes + , dwLabel = dblCLabel blk + , dwMarker = marker + } + where + srcNotes + | ncgDwarfSourceNotes config = concatMap tickToDwarf (dblTicks blk) + | otherwise = [] + + marker + | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk + | otherwise = Nothing -- block was optimized out + +tickToDwarf :: CmmTickish -> [DwarfInfo] +tickToDwarf (SourceNote ss _) = [DwarfSrcNote ss] +tickToDwarf _ = [] + +-- | Generates the data for the debug frame section, which encodes the +-- desired stack unwind behaviour for the debugger +debugFrame :: Platform -> Unique -> [DebugBlock] -> DwarfFrame +debugFrame p u procs + = DwarfFrame { dwCieLabel = mkAsmTempLabel u + , dwCieInit = initUws + , dwCieProcs = map (procToFrame initUws) procs + } + where + initUws :: UnwindTable + initUws = Map.fromList [(Sp, Just (UwReg (GlobalRegUse Sp $ bWord p) 0))] + +-- | Generates unwind information for a procedure debug block +procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc +procToFrame initUws blk + = DwarfFrameProc { dwFdeProc = dblCLabel blk + , dwFdeHasInfo = dblHasInfoTbl blk + , dwFdeBlocks = map (uncurry blockToFrame) + (setHasInfo blockUws) + } + where blockUws :: [(DebugBlock, [UnwindPoint])] + blockUws = map snd $ sortBy (comparing fst) $ flatten blk + + flatten :: DebugBlock + -> [(Int, (DebugBlock, [UnwindPoint]))] + flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks } + | Just p <- pos = (p, (b, uws')):nested + | otherwise = nested -- block was optimized out + where uws' = addDefaultUnwindings initUws uws + nested = concatMap flatten blocks + + -- If the current procedure has an info table, then we also say that + -- its first block has one to ensure that it gets the necessary -1 + -- offset applied to its start address. + -- See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types". + setHasInfo :: [(DebugBlock, [UnwindPoint])] + -> [(DebugBlock, [UnwindPoint])] + setHasInfo [] = [] + setHasInfo (c0:cs) = first setIt c0 : cs + where + setIt child = + child { dblHasInfoTbl = dblHasInfoTbl child + || dblHasInfoTbl blk } + +blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock +blockToFrame blk uws + = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk + , dwFdeUnwind = uws + } + +addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint] +addDefaultUnwindings tbl pts = + [ UnwindPoint lbl (tbl' `mappend` tbl) + -- mappend is left-biased + | UnwindPoint lbl tbl' <- pts + ] diff --git a/GHC/CmmToAsm/Dwarf/Constants.hs b/GHC/CmmToAsm/Dwarf/Constants.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Dwarf/Constants.hs @@ -0,0 +1,260 @@ +-- | Constants describing the DWARF format. Most of this simply +-- mirrors \/usr\/include\/dwarf.h. + +module GHC.CmmToAsm.Dwarf.Constants where + +import GHC.Prelude + +import GHC.Utils.Asm +import GHC.Platform +import GHC.Utils.Outputable + +import GHC.Platform.Reg +import GHC.CmmToAsm.X86.Regs +import GHC.CmmToAsm.PPC.Regs (toRegNo) + +import Data.Word + +-- | Language ID used for Haskell. +dW_LANG_Haskell :: Word +dW_LANG_Haskell = 0x18 + -- Thanks to Nathan Howell for getting us our very own language ID! + +-- * Dwarf tags +dW_TAG_compile_unit, dW_TAG_subroutine_type, + dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block, + dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type, + dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef, + dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable, + dW_TAG_ghc_src_note :: Word +dW_TAG_array_type = 1 +dW_TAG_lexical_block = 11 +dW_TAG_pointer_type = 15 +dW_TAG_compile_unit = 17 +dW_TAG_structure_type = 19 +dW_TAG_typedef = 22 +dW_TAG_subroutine_type = 32 +dW_TAG_subrange_type = 33 +dW_TAG_base_type = 36 +dW_TAG_file_type = 41 +dW_TAG_subprogram = 46 +dW_TAG_variable = 52 +dW_TAG_auto_variable = 256 +dW_TAG_arg_variable = 257 + +dW_TAG_ghc_src_note = 0x5b00 + +-- * Dwarf attributes +dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language, + dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base, + dW_AT_use_UTF8, dW_AT_linkage_name :: Word +dW_AT_name = 0x03 +dW_AT_stmt_list = 0x10 +dW_AT_low_pc = 0x11 +dW_AT_high_pc = 0x12 +dW_AT_language = 0x13 +dW_AT_comp_dir = 0x1b +dW_AT_producer = 0x25 +dW_AT_external = 0x3f +dW_AT_frame_base = 0x40 +dW_AT_use_UTF8 = 0x53 +dW_AT_linkage_name = 0x6e + +-- * Custom DWARF attributes +-- Chosen a more or less random section of the vendor-extensible region + +-- ** Describing C-- blocks +-- These appear in DW_TAG_lexical_scope DIEs corresponding to C-- blocks +dW_AT_ghc_tick_parent :: Word +dW_AT_ghc_tick_parent = 0x2b20 + +-- ** Describing source notes +-- These appear in DW_TAG_ghc_src_note DIEs +dW_AT_ghc_span_file, dW_AT_ghc_span_start_line, + dW_AT_ghc_span_start_col, dW_AT_ghc_span_end_line, + dW_AT_ghc_span_end_col :: Word +dW_AT_ghc_span_file = 0x2b00 +dW_AT_ghc_span_start_line = 0x2b01 +dW_AT_ghc_span_start_col = 0x2b02 +dW_AT_ghc_span_end_line = 0x2b03 +dW_AT_ghc_span_end_col = 0x2b04 + + +-- * Abbrev declarations +dW_CHILDREN_no, dW_CHILDREN_yes :: Word8 +dW_CHILDREN_no = 0 +dW_CHILDREN_yes = 1 + +dW_FORM_addr, dW_FORM_data2, dW_FORM_data4, dW_FORM_string, dW_FORM_flag, + dW_FORM_block1, dW_FORM_ref4, dW_FORM_ref_addr, dW_FORM_flag_present :: Word +dW_FORM_addr = 0x01 +dW_FORM_data2 = 0x05 +dW_FORM_data4 = 0x06 +dW_FORM_string = 0x08 +dW_FORM_flag = 0x0c +dW_FORM_block1 = 0x0a +dW_FORM_ref_addr = 0x10 +dW_FORM_ref4 = 0x13 +dW_FORM_flag_present = 0x19 + +-- * Dwarf native types +dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed, + dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word +dW_ATE_address = 1 +dW_ATE_boolean = 2 +dW_ATE_float = 4 +dW_ATE_signed = 5 +dW_ATE_signed_char = 6 +dW_ATE_unsigned = 7 +dW_ATE_unsigned_char = 8 + +-- * Call frame information +dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value, + dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression, + dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf, + dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression, + dW_CFA_offset :: Word8 +dW_CFA_set_loc = 0x01 +dW_CFA_undefined = 0x07 +dW_CFA_same_value = 0x08 +dW_CFA_def_cfa = 0x0c +dW_CFA_def_cfa_offset = 0x0e +dW_CFA_def_cfa_expression = 0x0f +dW_CFA_expression = 0x10 +dW_CFA_offset_extended_sf = 0x11 +dW_CFA_def_cfa_sf = 0x12 +dW_CFA_def_cfa_offset_sf = 0x13 +dW_CFA_val_offset = 0x14 +dW_CFA_val_expression = 0x16 +dW_CFA_offset = 0x80 + +-- * Operations +dW_OP_addr, dW_OP_deref, dW_OP_consts, + dW_OP_minus, dW_OP_mul, dW_OP_plus, + dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8 +dW_OP_addr = 0x03 +dW_OP_deref = 0x06 +dW_OP_consts = 0x11 +dW_OP_minus = 0x1c +dW_OP_mul = 0x1e +dW_OP_plus = 0x22 +dW_OP_lit0 = 0x30 +dW_OP_breg0 = 0x70 +dW_OP_call_frame_cfa = 0x9c + +-- * Dwarf section declarations +dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection, + dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: IsDoc doc => Platform -> doc +dwarfInfoSection platform = dwarfSection platform "info" +dwarfAbbrevSection platform = dwarfSection platform "abbrev" +dwarfLineSection platform = dwarfSection platform "line" +dwarfFrameSection platform = dwarfSection platform "frame" +dwarfGhcSection platform = dwarfSection platform "ghc" +dwarfARangesSection platform = dwarfSection platform "aranges" +{-# SPECIALIZE dwarfInfoSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfInfoSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfAbbrevSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfAbbrevSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfLineSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfLineSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfFrameSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfFrameSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfGhcSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfGhcSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfARangesSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfARangesSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +dwarfSection :: IsDoc doc => Platform -> String -> doc +dwarfSection platform name = + line $ case platformOS platform of + os | osElfTarget os + -> text "\t.section .debug_" <> text name <> text ",\"\"," + <> sectionType platform "progbits" + | osMachOTarget os + -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug" + | otherwise + -> text "\t.section .debug_" <> text name <> text ",\"dr\"" +{-# SPECIALIZE dwarfSection :: Platform -> String -> SDoc #-} +{-# SPECIALIZE dwarfSection :: Platform -> String -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- * Dwarf section labels +dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: IsLine doc => doc +dwarfInfoLabel = text ".Lsection_info" +dwarfAbbrevLabel = text ".Lsection_abbrev" +dwarfLineLabel = text ".Lsection_line" +dwarfFrameLabel = text ".Lsection_frame" +{-# SPECIALIZE dwarfInfoLabel :: SDoc #-} +{-# SPECIALIZE dwarfInfoLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfAbbrevLabel :: SDoc #-} +{-# SPECIALIZE dwarfAbbrevLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfLineLabel :: SDoc #-} +{-# SPECIALIZE dwarfLineLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfFrameLabel :: SDoc #-} +{-# SPECIALIZE dwarfFrameLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Mapping of registers to DWARF register numbers +dwarfRegNo :: Platform -> Reg -> Word8 +dwarfRegNo p r = case platformArch p of + ArchX86 + | r == eax -> 0 + | r == ecx -> 1 -- yes, no typo + | r == edx -> 2 + | r == ebx -> 3 + | r == esp -> 4 + | r == ebp -> 5 + | r == esi -> 6 + | r == edi -> 7 + ArchX86_64 + | r == rax -> 0 + | r == rdx -> 1 -- this neither. The order GCC allocates registers in? + | r == rcx -> 2 + | r == rbx -> 3 + | r == rsi -> 4 + | r == rdi -> 5 + | r == rbp -> 6 + | r == rsp -> 7 + | r == r8 -> 8 + | r == r9 -> 9 + | r == r10 -> 10 + | r == r11 -> 11 + | r == r12 -> 12 + | r == r13 -> 13 + | r == r14 -> 14 + | r == r15 -> 15 + | r == xmm0 -> 17 + | r == xmm1 -> 18 + | r == xmm2 -> 19 + | r == xmm3 -> 20 + | r == xmm4 -> 21 + | r == xmm5 -> 22 + | r == xmm6 -> 23 + | r == xmm7 -> 24 + | r == xmm8 -> 25 + | r == xmm9 -> 26 + | r == xmm10 -> 27 + | r == xmm11 -> 28 + | r == xmm12 -> 29 + | r == xmm13 -> 30 + | r == xmm14 -> 31 + | r == xmm15 -> 32 + ArchPPC_64 _ -> fromIntegral $ toRegNo r + ArchAArch64 -> fromIntegral $ toRegNo r + ArchRISCV64 -> fromIntegral $ toRegNo r + ArchLoongArch64 -> fromIntegral $ toRegNo r + _other -> error "dwarfRegNo: Unsupported platform or unknown register!" + +-- | Virtual register number to use for return address. +dwarfReturnRegNo :: Platform -> Word8 +dwarfReturnRegNo p + -- We "overwrite" IP with our pseudo register - that makes sense, as + -- when using this mechanism gdb already knows the IP anyway. Clang + -- does this too, so it must be safe. + = case platformArch p of + ArchX86 -> 8 -- eip + ArchX86_64 -> 16 -- rip + ArchPPC_64 ELF_V2 -> 65 -- lr (link register) + ArchAArch64 -> 30 + ArchRISCV64 -> 1 -- ra (return address) + ArchLoongArch64 -> 1 -- ra (return address) + _other -> error "dwarfReturnRegNo: Unsupported platform!" diff --git a/GHC/CmmToAsm/Dwarf/Types.hs b/GHC/CmmToAsm/Dwarf/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Dwarf/Types.hs @@ -0,0 +1,656 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHC.CmmToAsm.Dwarf.Types + ( -- * Dwarf information + DwarfInfo(..) + , pprDwarfInfo + , pprAbbrevDecls + -- * Dwarf address range table + , DwarfARange(..) + , pprDwarfARanges + -- * Dwarf frame + , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..) + , pprDwarfFrame + -- * Utilities + , pprByte + , pprHalf + , pprData4' + , pprDwWord + , pprWord + , pprLEBWord + , pprLEBInt + , wordAlign + , sectionOffset + ) + where + +import GHC.Prelude + +import GHC.Cmm.DebugBlock +import GHC.Cmm.CLabel +import GHC.Cmm.Expr +import GHC.Utils.Encoding +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique +import GHC.Platform.Reg +import GHC.Types.SrcLoc +import GHC.Utils.Misc + +import GHC.CmmToAsm.Dwarf.Constants + +import qualified Data.ByteString as BS +import qualified GHC.Utils.Monad.State.Strict as S +import Control.Monad (zipWithM, join) +import qualified Data.Map as Map +import Data.Word +import Data.Char + +import GHC.Platform.Regs + +-- | Individual dwarf records. Each one will be encoded as an entry in +-- the @.debug_info@ section. +data DwarfInfo + = DwarfCompileUnit { dwChildren :: [DwarfInfo] + , dwName :: String + , dwProducer :: String + , dwCompDir :: String + , dwLowLabel :: CLabel + , dwHighLabel :: CLabel } + | DwarfSubprogram { dwChildren :: [DwarfInfo] + , dwName :: String + , dwLabel :: CLabel + , dwParent :: Maybe CLabel + -- ^ label of DIE belonging to the parent tick + } + | DwarfBlock { dwChildren :: [DwarfInfo] + , dwLabel :: CLabel + , dwMarker :: Maybe CLabel + } + | DwarfSrcNote { dwSrcSpan :: RealSrcSpan + } + +-- | Abbreviation codes used for encoding above records in the +-- @.debug_info@ section. +data DwarfAbbrev + = DwAbbrNull -- ^ Pseudo, used for marking the end of lists + | DwAbbrCompileUnit + | DwAbbrSubprogram + | DwAbbrSubprogramWithParent + | DwAbbrBlockWithoutCode + | DwAbbrBlock + | DwAbbrGhcSrcNote + deriving (Eq, Enum) + +-- | Generate assembly for the given abbreviation code +pprAbbrev :: IsDoc doc => DwarfAbbrev -> doc +pprAbbrev = pprLEBWord . fromIntegral . fromEnum + +-- | Abbreviation declaration. This explains the binary encoding we +-- use for representing 'DwarfInfo'. Be aware that this must be updated +-- along with 'pprDwarfInfo'. +pprAbbrevDecls :: IsDoc doc => Platform -> Bool -> doc +pprAbbrevDecls platform haveDebugLine = + let mkAbbrev abbr tag chld flds = + let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form + in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$ + vcat (map fld flds) $$ pprByte 0 $$ pprByte 0 + -- These are shared between DwAbbrSubprogram and + -- DwAbbrSubprogramWithParent + subprogramAttrs = + [ (dW_AT_name, dW_FORM_string) + , (dW_AT_linkage_name, dW_FORM_string) + , (dW_AT_external, dW_FORM_flag) + , (dW_AT_low_pc, dW_FORM_addr) + , (dW_AT_high_pc, dW_FORM_addr) + , (dW_AT_frame_base, dW_FORM_block1) + ] + in dwarfAbbrevSection platform $$ + line (dwarfAbbrevLabel <> colon) $$ + mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes + ([(dW_AT_name, dW_FORM_string) + , (dW_AT_producer, dW_FORM_string) + , (dW_AT_language, dW_FORM_data4) + , (dW_AT_comp_dir, dW_FORM_string) + , (dW_AT_use_UTF8, dW_FORM_flag_present) -- not represented in body + , (dW_AT_low_pc, dW_FORM_addr) + , (dW_AT_high_pc, dW_FORM_addr) + ] ++ + (if haveDebugLine + then [ (dW_AT_stmt_list, dW_FORM_data4) ] + else [])) $$ + mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes + subprogramAttrs $$ + mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes + (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$ + mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes + [ (dW_AT_name, dW_FORM_string) + ] $$ + mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes + [ (dW_AT_name, dW_FORM_string) + , (dW_AT_low_pc, dW_FORM_addr) + , (dW_AT_high_pc, dW_FORM_addr) + ] $$ + mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no + [ (dW_AT_ghc_span_file, dW_FORM_string) + , (dW_AT_ghc_span_start_line, dW_FORM_data4) + , (dW_AT_ghc_span_start_col, dW_FORM_data2) + , (dW_AT_ghc_span_end_line, dW_FORM_data4) + , (dW_AT_ghc_span_end_col, dW_FORM_data2) + ] $$ + pprByte 0 +{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> SDoc #-} +{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Generate assembly for DWARF data +pprDwarfInfo :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc +pprDwarfInfo platform haveSrc d + = case d of + DwarfCompileUnit {dwChildren = kids} -> hasChildren kids + DwarfSubprogram {dwChildren = kids} -> hasChildren kids + DwarfBlock {dwChildren = kids} -> hasChildren kids + DwarfSrcNote {} -> noChildren + where + hasChildren kids = + pprDwarfInfoOpen platform haveSrc d $$ + vcat (map (pprDwarfInfo platform haveSrc) kids) $$ + pprDwarfInfoClose + noChildren = pprDwarfInfoOpen platform haveSrc d +{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc #-} +{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print a CLabel name in a ".stringz \"LABEL\"" +pprLabelString :: IsDoc doc => Platform -> CLabel -> doc +pprLabelString platform label = + pprString' -- we don't need to escape the string as labels don't contain exotic characters + $ pprCLabel platform label -- pretty-print as C label (foreign labels may be printed differently in Asm) + +-- | Prints assembler data corresponding to DWARF info records. Note +-- that the binary format of this is parameterized in @abbrevDecls@ and +-- has to be kept in synch. +pprDwarfInfoOpen :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc +pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel + highLabel) = + pprAbbrev DwAbbrCompileUnit + $$ pprString name + $$ pprString producer + $$ pprData4 dW_LANG_Haskell + $$ pprString compDir + -- Offset due to Note [Info Offset] + $$ pprWord platform (pprAsmLabel platform lowLabel <> text "-1") + $$ pprWord platform (pprAsmLabel platform highLabel) + $$ if haveSrc + then sectionOffset platform dwarfLineLabel dwarfLineLabel + else empty +pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) = + line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon) + $$ pprAbbrev abbrev + $$ pprString name + $$ pprLabelString platform label + $$ pprFlag (externallyVisibleCLabel label) + -- Offset due to Note [Info Offset] + $$ pprWord platform (pprAsmLabel platform label <> text "-1") + $$ pprWord platform (pprAsmLabel platform $ mkAsmTempProcEndLabel label) + $$ pprByte 1 + $$ pprByte dW_OP_call_frame_cfa + $$ parentValue + where + abbrev = case parent of Nothing -> DwAbbrSubprogram + Just _ -> DwAbbrSubprogramWithParent + parentValue = maybe empty pprParentDie parent + pprParentDie sym = sectionOffset platform (pprAsmLabel platform sym) dwarfInfoLabel +pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) = + line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon) + $$ pprAbbrev DwAbbrBlockWithoutCode + $$ pprLabelString platform label +pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = + line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon) + $$ pprAbbrev DwAbbrBlock + $$ pprLabelString platform label + $$ pprWord platform (pprAsmLabel platform marker) + $$ pprWord platform (pprAsmLabel platform $ mkAsmTempEndLabel marker) +pprDwarfInfoOpen _ _ (DwarfSrcNote ss) = + pprAbbrev DwAbbrGhcSrcNote + $$ pprString' (ftext $ srcSpanFile ss) + $$ pprData4 (fromIntegral $ srcSpanStartLine ss) + $$ pprHalf (fromIntegral $ srcSpanStartCol ss) + $$ pprData4 (fromIntegral $ srcSpanEndLine ss) + $$ pprHalf (fromIntegral $ srcSpanEndCol ss) + +-- | Close a DWARF info record with children +pprDwarfInfoClose :: IsDoc doc => doc +pprDwarfInfoClose = pprAbbrev DwAbbrNull + +-- | A DWARF address range. This is used by the debugger to quickly locate +-- which compilation unit a given address belongs to. This type assumes +-- a non-segmented address-space. +data DwarfARange + = DwarfARange + { dwArngStartLabel :: CLabel + , dwArngEndLabel :: CLabel + } + +-- | Print assembler directives corresponding to a DWARF @.debug_aranges@ +-- address table entry. +pprDwarfARanges :: IsDoc doc => Platform -> [DwarfARange] -> Unique -> doc +pprDwarfARanges platform arngs unitU = + let wordSize = platformWordSizeInBytes platform + paddingSize = 4 :: Int + -- header is 12 bytes long. + -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform). + -- pad such that first entry begins at multiple of entry size. + pad n = vcat $ replicate n $ pprByte 0 + -- Fix for #17428 + initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize + in pprDwWord (int initialLength) + $$ pprHalf 2 + $$ sectionOffset platform (pprAsmLabel platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel + $$ pprByte (fromIntegral wordSize) + $$ pprByte 0 + $$ pad paddingSize + -- body + $$ vcat (map (pprDwarfARange platform) arngs) + -- terminus + $$ pprWord platform (char '0') + $$ pprWord platform (char '0') +{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc #-} +{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +pprDwarfARange :: IsDoc doc => Platform -> DwarfARange -> doc +pprDwarfARange platform arng = + -- Offset due to Note [Info Offset]. + pprWord platform (pprAsmLabel platform (dwArngStartLabel arng) <> text "-1") + $$ pprWord platform length + where + length = pprAsmLabel platform (dwArngEndLabel arng) + <> char '-' <> pprAsmLabel platform (dwArngStartLabel arng) + +-- | Information about unwind instructions for a procedure. This +-- corresponds to a "Common Information Entry" (CIE) in DWARF. +data DwarfFrame + = DwarfFrame + { dwCieLabel :: CLabel + , dwCieInit :: UnwindTable + , dwCieProcs :: [DwarfFrameProc] + } + +-- | Unwind instructions for an individual procedure. Corresponds to a +-- "Frame Description Entry" (FDE) in DWARF. +data DwarfFrameProc + = DwarfFrameProc + { dwFdeProc :: CLabel + , dwFdeHasInfo :: Bool + , dwFdeBlocks :: [DwarfFrameBlock] + -- ^ List of blocks. Order must match asm! + } + +-- | Unwind instructions for a block. Will become part of the +-- containing FDE. +data DwarfFrameBlock + = DwarfFrameBlock + { dwFdeBlkHasInfo :: Bool + , dwFdeUnwind :: [UnwindPoint] + -- ^ these unwind points must occur in the same order as they occur + -- in the block + } + +instance OutputableP Platform DwarfFrameBlock where + pdoc env (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> pdoc env unwinds + +-- | Header for the @.debug_frame@ section. Here we emit the "Common +-- Information Entry" record that establishes general call frame +-- parameters and the default stack layout. +pprDwarfFrame :: forall doc. IsDoc doc => Platform -> DwarfFrame -> doc +pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} + = let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start") + cieEndLabel = mkAsmTempEndLabel cieLabel + length = pprAsmLabel platform cieEndLabel <> char '-' <> pprAsmLabel platform cieStartLabel + spReg = dwarfGlobalRegNo platform Sp + retReg = dwarfReturnRegNo platform + wordSize = platformWordSizeInBytes platform + pprInit :: (GlobalReg, Maybe UnwindExpr) -> doc + pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw) + + -- Preserve C stack pointer: This necessary to override that default + -- unwinding behavior of setting $sp = CFA. + preserveSp = case platformArch platform of + ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4 + ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7 + _ -> empty + in vcat [ line (pprAsmLabel platform cieLabel <> colon) + , pprData4' length -- Length of CIE + , line (pprAsmLabel platform cieStartLabel <> colon) + , pprData4' (text "-1") + -- Common Information Entry marker (-1 = 0xf..f) + , pprByte 3 -- CIE version (we require DWARF 3) + , pprByte 0 -- Augmentation (none) + , pprByte 1 -- Code offset multiplicator + , pprByte (128-fromIntegral wordSize) + -- Data offset multiplicator + -- (stacks grow down => "-w" in signed LEB128) + , pprByte retReg -- virtual register holding return address + ] $$ + -- Initial unwind table + vcat (map pprInit $ Map.toList cieInit) $$ + vcat [ -- RET = *CFA + pprByte (dW_CFA_offset+retReg) + , pprByte 0 + + -- Preserve C stack pointer + , preserveSp + + -- Sp' = CFA + -- (we need to set this manually as our (STG) Sp register is + -- often not the architecture's default stack register) + , pprByte dW_CFA_val_offset + , pprLEBWord (fromIntegral spReg) + , pprLEBWord 0 + ] $$ + wordAlign platform $$ + line (pprAsmLabel platform cieEndLabel <> colon) $$ + -- Procedure unwind tables + vcat (map (pprFrameProc platform cieLabel cieInit) procs) +{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> SDoc #-} +{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Writes a "Frame Description Entry" for a procedure. This consists +-- mainly of referencing the CIE and writing state machine +-- instructions to describe how the frame base (CFA) changes. +pprFrameProc :: IsDoc doc => Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> doc +pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) + = let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde") + fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end") + procEnd = mkAsmTempProcEndLabel procLbl + ifInfo str = if hasInfo then text str else empty + -- see Note [Info Offset] + in vcat [ whenPprDebug $ line $ text "# Unwinding for" <+> pprAsmLabel platform procLbl <> colon + , pprData4' (pprAsmLabel platform fdeEndLabel <> char '-' <> pprAsmLabel platform fdeLabel) + , line (pprAsmLabel platform fdeLabel <> colon) + , pprData4' (pprAsmLabel platform frameLbl <> char '-' <> dwarfFrameLabel) -- Reference to CIE + , pprWord platform (pprAsmLabel platform procLbl <> ifInfo "-1") -- Code pointer + , pprWord platform (pprAsmLabel platform procEnd <> char '-' <> + pprAsmLabel platform procLbl <> ifInfo "+1") -- Block byte length + ] $$ + vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$ + wordAlign platform $$ + line (pprAsmLabel platform fdeEndLabel <> colon) + +-- | Generates unwind information for a block. We only generate +-- instructions where unwind information actually changes. This small +-- optimisations saves a lot of space, as subsequent blocks often have +-- the same unwind information. +pprFrameBlock :: forall doc. IsDoc doc => Platform -> DwarfFrameBlock -> S.State UnwindTable doc +pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) = + vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0 + where + pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable doc + pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws -> + let -- Did a register's unwind expression change? + isChanged :: GlobalReg -> Maybe UnwindExpr + -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr) + isChanged g new + -- the value didn't change + | Just new == old = Nothing + -- the value was and still is undefined + | Nothing <- old + , Nothing <- new = Nothing + -- the value changed + | otherwise = Just (join old, new) + where + old = Map.lookup g oldUws + + changed = Map.toList $ Map.mapMaybeWithKey isChanged uws + + in if oldUws == uws + then (empty, oldUws) + else let -- see Note [Info Offset] + needsOffset = firstDecl && hasInfo + lblDoc = pprAsmLabel platform lbl <> + if needsOffset then text "-1" else empty + doc = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$ + vcat (map (uncurry $ pprSetUnwind platform) changed) + in (doc, uws) + +-- Note [Info Offset] +-- ~~~~~~~~~~~~~~~~~~ +-- GDB was pretty much written with C-like programs in mind, and as a +-- result they assume that once you have a return address, it is a +-- good idea to look at (PC-1) to unwind further - as that's where the +-- "call" instruction is supposed to be. +-- +-- Now on one hand, code generated by GHC looks nothing like what GDB +-- expects, and in fact going up from a return pointer is guaranteed +-- to land us inside an info table! On the other hand, that actually +-- gives us some wiggle room, as we expect IP to never *actually* end +-- up inside the info table, so we can "cheat" by putting whatever GDB +-- expects to see there. This is probably pretty safe, as GDB cannot +-- assume (PC-1) to be a valid code pointer in the first place - and I +-- have seen no code trying to correct this. +-- +-- Note that this will not prevent GDB from failing to look-up the +-- correct function name for the frame, as that uses the symbol table, +-- which we can not manipulate as easily. +-- +-- We apply this offset in several places: +-- +-- * unwind information in .debug_frames +-- * the subprogram and lexical_block DIEs in .debug_info +-- * the ranges in .debug_aranges +-- +-- In the latter two cases we apply the offset unconditionally. +-- +-- There's a GDB patch to address this at [1]. At the moment of writing +-- it's not merged, so I recommend building GDB with the patch if you +-- care about unwinding. The hack above doesn't cover every case. +-- +-- [1] https://sourceware.org/ml/gdb-patches/2018-02/msg00055.html + +-- | Get DWARF register ID for a given GlobalReg +dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8 +dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p +dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg + +-- | Generate code for setting the unwind information for a register, +-- optimized using its known old value in the table. Note that "Sp" is +-- special: We see it as synonym for the CFA. +pprSetUnwind :: IsDoc doc => Platform + -> GlobalReg + -- ^ the register to produce an unwinding table entry for + -> (Maybe UnwindExpr, Maybe UnwindExpr) + -- ^ the old and new values of the register + -> doc +pprSetUnwind plat g (_, Nothing) + = pprUndefUnwind plat g +pprSetUnwind _ Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s' + = if o' >= 0 + then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o') + else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o' +pprSetUnwind plat Sp (_, Just (UwReg (GlobalRegUse s' _) o')) + = if o' >= 0 + then pprByte dW_CFA_def_cfa $$ + pprLEBRegNo plat s' $$ + pprLEBWord (fromIntegral o') + else pprByte dW_CFA_def_cfa_sf $$ + pprLEBRegNo plat s' $$ + pprLEBInt o' +pprSetUnwind plat Sp (_, Just uw) + = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw +pprSetUnwind plat g (_, Just (UwDeref (UwReg (GlobalRegUse Sp _) o))) + | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case + = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$ + pprLEBWord (fromIntegral ((-o) `div` platformWordSizeInBytes plat)) + | otherwise + = pprByte dW_CFA_offset_extended_sf $$ + pprLEBRegNo plat g $$ + pprLEBInt o +pprSetUnwind plat g (_, Just (UwDeref uw)) + = pprByte dW_CFA_expression $$ + pprLEBRegNo plat g $$ + pprUnwindExpr plat True uw +pprSetUnwind plat g (_, Just (UwReg (GlobalRegUse g' _) 0)) + | g == g' + = pprByte dW_CFA_same_value $$ + pprLEBRegNo plat g +pprSetUnwind plat g (_, Just uw) + = pprByte dW_CFA_val_expression $$ + pprLEBRegNo plat g $$ + pprUnwindExpr plat True uw + +-- | Print the register number of the given 'GlobalReg' as an unsigned LEB128 +-- encoded number. +pprLEBRegNo :: IsDoc doc => Platform -> GlobalReg -> doc +pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat + +-- | Generates a DWARF expression for the given unwind expression. If +-- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets +-- mentioned. +pprUnwindExpr :: IsDoc doc => Platform -> Bool -> UnwindExpr -> doc +pprUnwindExpr platform spIsCFA expr + = let pprE (UwConst i) + | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i) + | otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy... + pprE (UwReg r@(GlobalRegUse Sp _) i) + | spIsCFA + = if i == 0 + then pprByte dW_OP_call_frame_cfa + else pprE (UwPlus (UwReg r 0) (UwConst i)) + pprE (UwReg (GlobalRegUse g _) i) + = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$ + pprLEBInt i + pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref + pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (pprAsmLabel platform l) + pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus + pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus + pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul + in line (text "\t.uleb128 2f-1f") $$ -- DW_FORM_block length + -- computed as the difference of the following local labels 2: and 1: + line (text "1:") $$ + pprE expr $$ + line (text "2:") + +-- | Generate code for re-setting the unwind information for a +-- register to @undefined@ +pprUndefUnwind :: IsDoc doc => Platform -> GlobalReg -> doc +pprUndefUnwind plat g = pprByte dW_CFA_undefined $$ + pprLEBRegNo plat g + + +-- | Align assembly at (machine) word boundary +wordAlign :: IsDoc doc => Platform -> doc +wordAlign plat = + line $ text "\t.align " <> case platformOS plat of + OSDarwin -> case platformWordSize plat of + PW8 -> char '3' + PW4 -> char '2' + _other -> int (platformWordSizeInBytes plat) +{-# SPECIALIZE wordAlign :: Platform -> SDoc #-} +{-# SPECIALIZE wordAlign :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Assembly for a single byte of constant DWARF data +pprByte :: IsDoc doc => Word8 -> doc +pprByte x = line $ text "\t.byte " <> integer (fromIntegral x) +{-# SPECIALIZE pprByte :: Word8 -> SDoc #-} +{-# SPECIALIZE pprByte :: Word8 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Assembly for a two-byte constant integer +pprHalf :: IsDoc doc => Word16 -> doc +pprHalf x = line $ text "\t.short" <+> integer (fromIntegral x) +{-# SPECIALIZE pprHalf :: Word16 -> SDoc #-} +{-# SPECIALIZE pprHalf :: Word16 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Assembly for a constant DWARF flag +pprFlag :: IsDoc doc => Bool -> doc +pprFlag f = pprByte (if f then 0xff else 0x00) + +-- | Assembly for 4 bytes of dynamic DWARF data +pprData4' :: IsDoc doc => Line doc -> doc +pprData4' x = line (text "\t.long " <> x) +{-# SPECIALIZE pprData4' :: SDoc -> SDoc #-} +{-# SPECIALIZE pprData4' :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Assembly for 4 bytes of constant DWARF data +pprData4 :: IsDoc doc => Word -> doc +pprData4 = pprData4' . integer . fromIntegral + +-- | Assembly for a DWARF word of dynamic data. This means 32 bit, as +-- we are generating 32 bit DWARF. +pprDwWord :: IsDoc doc => Line doc -> doc +pprDwWord = pprData4' +{-# SPECIALIZE pprDwWord :: SDoc -> SDoc #-} +{-# SPECIALIZE pprDwWord :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Assembly for a machine word of dynamic data. Depends on the +-- architecture we are currently generating code for. +pprWord :: IsDoc doc => Platform -> Line doc -> doc +pprWord plat s = + line $ case platformWordSize plat of + PW4 -> text "\t.long " <> s + PW8 -> text "\t.quad " <> s +{-# SPECIALIZE pprWord :: Platform -> SDoc -> SDoc #-} +{-# SPECIALIZE pprWord :: Platform -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Prints a number in "little endian base 128" format. The idea is +-- to optimize for small numbers by stopping once all further bytes +-- would be 0. The highest bit in every byte signals whether there +-- are further bytes to read. +pprLEBWord :: IsDoc doc => Word -> doc +pprLEBWord x | x < 128 = pprByte (fromIntegral x) + | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ + pprLEBWord (x `shiftR` 7) +{-# SPECIALIZE pprLEBWord :: Word -> SDoc #-} +{-# SPECIALIZE pprLEBWord :: Word -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Same as @pprLEBWord@, but for a signed number +pprLEBInt :: IsDoc doc => Int -> doc +pprLEBInt x | x >= -64 && x < 64 + = pprByte (fromIntegral (x .&. 127)) + | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ + pprLEBInt (x `shiftR` 7) +{-# SPECIALIZE pprLEBInt :: Int -> SDoc #-} +{-# SPECIALIZE pprLEBInt :: Int -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Generates a dynamic null-terminated string. If required the +-- caller needs to make sure that the string is escaped properly. +pprString' :: IsDoc doc => Line doc -> doc +pprString' str = line (text "\t.asciz \"" <> str <> char '"') + +-- | Generate a string constant. We take care to escape the string. +pprString :: IsDoc doc => String -> doc +pprString str + = pprString' $ hcat $ map escapeChar $ + if str `lengthIs` utf8EncodedLength str + then str + else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeByteString str + +-- | Escape a single non-unicode character +escapeChar :: IsLine doc => Char -> doc +escapeChar '\\' = text "\\\\" +escapeChar '\"' = text "\\\"" +escapeChar '\n' = text "\\n" +escapeChar c + | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings + = char c + | otherwise + = char '\\' <> char (intToDigit (ch `div` 64)) <> + char (intToDigit ((ch `div` 8) `mod` 8)) <> + char (intToDigit (ch `mod` 8)) + where ch = ord c + +-- | Generate an offset into another section. This is tricky because +-- this is handled differently depending on platform: Mac Os expects +-- us to calculate the offset using assembler arithmetic. Linux expects +-- us to just reference the target directly, and will figure out on +-- their own that we actually need an offset. Finally, Windows has +-- a special directive to refer to relative offsets. Fun. +sectionOffset :: IsDoc doc => Platform -> Line doc -> Line doc -> doc +sectionOffset plat target section = + case platformOS plat of + OSDarwin -> pprDwWord (target <> char '-' <> section) + OSMinGW32 -> line (text "\t.secrel32 " <> target) + _other -> pprDwWord target +{-# SPECIALIZE sectionOffset :: Platform -> SDoc -> SDoc -> SDoc #-} +{-# SPECIALIZE sectionOffset :: Platform -> HLine -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable diff --git a/GHC/CmmToAsm/Format.hs b/GHC/CmmToAsm/Format.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Format.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Formats on this architecture +-- A Format is a combination of width and class +-- +-- TODO: Signed vs unsigned? +-- +-- TODO: This module is currently shared by all architectures because +-- NCGMonad need to know about it to make a VReg. It would be better +-- to have architecture specific formats, and do the overloading +-- properly. eg SPARC doesn't care about FF80. +-- +module GHC.CmmToAsm.Format ( + Format(.., IntegerFormat), + ScalarFormat(..), + intFormat, + floatFormat, + isIntFormat, + isIntScalarFormat, + intScalarFormat, + isFloatFormat, + vecFormat, + isVecFormat, + cmmTypeFormat, + formatToWidth, + scalarWidth, + formatInBytes, + isFloatScalarFormat, + isFloatOrFloatVecFormat, + floatScalarFormat, + scalarFormatFormat, + VirtualRegWithFormat(..), + RegWithFormat(..), + takeVirtualRegs, + takeRealRegs, +) + +where + +import GHC.Prelude + +import GHC.Cmm +import GHC.Platform.Reg ( Reg(..), RealReg, VirtualReg ) +import GHC.Types.Unique ( Uniquable(..) ) +import GHC.Types.Unique.Set +import GHC.Utils.Outputable +import GHC.Utils.Panic + +{- Note [GHC's data format representations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has severals types that represent various aspects of data format. +These include: + + * 'CmmType.CmmType': The data classification used throughout the C-- + pipeline. This is a pair of a CmmCat and a Width. + + * 'CmmType.CmmCat': What the bits in a C-- value mean (e.g. a pointer, integer, or floating-point value) + + * 'CmmType.Width': The width of a C-- value. + + * 'CmmType.Length': The width (measured in number of scalars) of a vector value. + + * 'Format.Format': The data format representation used by much of the backend. + + * 'Format.ScalarFormat': The format of a 'Format.VecFormat'\'s scalar. + + * 'RegClass.RegClass': Whether a register is an integer or a floating point/vector register. +-} + +-- It looks very like the old MachRep, but it's now of purely local +-- significance, here in the native code generator. You can change it +-- without global consequences. +-- +-- A major use is as an opcode qualifier; thus the opcode +-- mov.l a b +-- might be encoded +-- MOV II32 a b +-- where the Format field encodes the ".l" part. + +-- ToDo: it's not clear to me that we need separate signed-vs-unsigned formats +-- here. I've removed them from the x86 version, we'll see what happens --SDM + +-- ToDo: quite a few occurrences of Format could usefully be replaced by Width + +data Format + = II8 + | II16 + | II32 + | II64 + | FF32 + | FF64 + | VecFormat !Length -- ^ number of elements (always at least 2) + !ScalarFormat -- ^ format of each element + deriving (Show, Eq, Ord) + +pattern IntegerFormat :: Format +pattern IntegerFormat <- ( isIntegerFormat -> True ) +{-# COMPLETE IntegerFormat, FF32, FF64, VecFormat #-} + +isIntegerFormat :: Format -> Bool +isIntegerFormat = \case + II8 -> True + II16 -> True + II32 -> True + II64 -> True + _ -> False + + +instance Outputable Format where + ppr fmt = text (show fmt) + +data ScalarFormat + = FmtInt8 + | FmtInt16 + | FmtInt32 + | FmtInt64 + | FmtFloat + | FmtDouble + deriving (Show, Eq, Ord) + +scalarFormatFormat :: ScalarFormat -> Format +scalarFormatFormat = \case + FmtInt8 -> II8 + FmtInt16 -> II16 + FmtInt32 -> II32 + FmtInt64 -> II64 + FmtFloat -> FF32 + FmtDouble -> FF64 + +isFloatScalarFormat :: ScalarFormat -> Bool +isFloatScalarFormat = \case + FmtFloat -> True + FmtDouble -> True + _ -> False + +isFloatOrFloatVecFormat :: Format -> Bool +isFloatOrFloatVecFormat = \case + VecFormat _ sFmt -> isFloatScalarFormat sFmt + fmt -> isFloatFormat fmt + +floatScalarFormat :: Width -> ScalarFormat +floatScalarFormat W32 = FmtFloat +floatScalarFormat W64 = FmtDouble +floatScalarFormat w = pprPanic "floatScalarFormat" (ppr w) + +isIntScalarFormat :: ScalarFormat -> Bool +isIntScalarFormat = not . isFloatScalarFormat + +intScalarFormat :: Width -> ScalarFormat +intScalarFormat = \case + W8 -> FmtInt8 + W16 -> FmtInt16 + W32 -> FmtInt32 + W64 -> FmtInt64 + w -> pprPanic "intScalarFormat" (ppr w) + +-- | Get the integer format of this width. +intFormat :: Width -> Format +intFormat width + = case width of + W8 -> II8 + W16 -> II16 + W32 -> II32 + W64 -> II64 + other -> sorry $ "The native code generator cannot " ++ + "produce code for Format.intFormat " ++ show other + ++ "\n\tConsider using the llvm backend with -fllvm" + +-- | Check if a format represent an integer value. +isIntFormat :: Format -> Bool +isIntFormat format = + case format of + II8 -> True + II16 -> True + II32 -> True + II64 -> True + _ -> False + +-- | Get the float format of this width. +floatFormat :: Width -> Format +floatFormat width + = case width of + W32 -> FF32 + W64 -> FF64 + other -> pprPanic "Format.floatFormat" (ppr other) + +-- | Check if a format represents a floating point value. +isFloatFormat :: Format -> Bool +isFloatFormat format + = case format of + FF32 -> True + FF64 -> True + _ -> False + +vecFormat :: CmmType -> Format +vecFormat ty = + let l = vecLength ty + elemTy = vecElemType ty + in if isFloatType elemTy + then case typeWidth elemTy of + W32 -> VecFormat l FmtFloat + W64 -> VecFormat l FmtDouble + _ -> pprPanic "Incorrect vector element width" (ppr elemTy) + else case typeWidth elemTy of + W8 -> VecFormat l FmtInt8 + W16 -> VecFormat l FmtInt16 + W32 -> VecFormat l FmtInt32 + W64 -> VecFormat l FmtInt64 + _ -> pprPanic "Incorrect vector element width" (ppr elemTy) + +-- | Check if a format represents a vector +isVecFormat :: Format -> Bool +isVecFormat (VecFormat {}) = True +isVecFormat _ = False + + +-- | Convert a Cmm type to a Format. +cmmTypeFormat :: CmmType -> Format +cmmTypeFormat ty + | isFloatType ty = floatFormat (typeWidth ty) + | isVecType ty = vecFormat ty + | otherwise = intFormat (typeWidth ty) + + +-- | Get the Width of a Format. +formatToWidth :: Format -> Width +formatToWidth format + = case format of + II8 -> W8 + II16 -> W16 + II32 -> W32 + II64 -> W64 + FF32 -> W32 + FF64 -> W64 + VecFormat l s -> + widthFromBytes (l * widthInBytes (scalarWidth s)) + +scalarWidth :: ScalarFormat -> Width +scalarWidth = \case + FmtInt8 -> W8 + FmtInt16 -> W16 + FmtInt32 -> W32 + FmtInt64 -> W64 + FmtFloat -> W32 + FmtDouble -> W64 + +formatInBytes :: Format -> Int +formatInBytes = widthInBytes . formatToWidth + +-------------------------------------------------------------------------------- + +-- | A typed virtual register: a virtual register, together with the specific +-- format we are using it at. +data VirtualRegWithFormat + = VirtualRegWithFormat + { virtualRegWithFormat_reg :: {-# UNPACK #-} !VirtualReg + , virtualRegWithFormat_format :: !Format + } + +-- | A typed register: a register, together with the specific format we +-- are using it at. +data RegWithFormat + = RegWithFormat + { regWithFormat_reg :: {-# UNPACK #-} !Reg + , regWithFormat_format :: !Format + } + +instance Show RegWithFormat where + show (RegWithFormat reg fmt) = show reg ++ "::" ++ show fmt + +instance Uniquable RegWithFormat where + getUnique = getUnique . regWithFormat_reg + +instance Outputable VirtualRegWithFormat where + ppr (VirtualRegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt + +instance Outputable RegWithFormat where + ppr (RegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt + +-- | Take all the virtual registers from this set. +takeVirtualRegs :: UniqSet RegWithFormat -> UniqSet VirtualReg +takeVirtualRegs = mapMaybeUniqSet_sameUnique $ + \ case { RegWithFormat { regWithFormat_reg = RegVirtual vr } -> Just vr; _ -> Nothing } + -- See Note [Unique Determinism and code generation] + +-- | Take all the real registers from this set. +takeRealRegs :: UniqSet RegWithFormat -> UniqSet RealReg +takeRealRegs = mapMaybeUniqSet_sameUnique $ + \ case { RegWithFormat { regWithFormat_reg = RegReal rr } -> Just rr; _ -> Nothing } + -- See Note [Unique Determinism and code generation] diff --git a/GHC/CmmToAsm/Instr.hs b/GHC/CmmToAsm/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Instr.hs @@ -0,0 +1,180 @@ + +module GHC.CmmToAsm.Instr + ( Instruction(..) + , RegUsage(..) + , noUsage + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Reg +import GHC.Utils.Outputable (SDoc) + +import GHC.Cmm.BlockId + +import GHC.CmmToAsm.Config +import GHC.Data.FastString +import GHC.CmmToAsm.Format + +import GHC.Utils.Misc (HasDebugCallStack) + +-- | Holds a list of source and destination registers used by a +-- particular instruction. +-- +-- Machine registers that are pre-allocated to stgRegs are filtered +-- out, because they are uninteresting from a register allocation +-- standpoint. (We wouldn't want them to end up on the free list!) +-- +-- As far as we are concerned, the fixed registers simply don't exist +-- (for allocation purposes, anyway). +-- +data RegUsage + = RU { + reads :: [RegWithFormat], + writes :: [RegWithFormat] + } + deriving Show + +-- | No regs read or written to. +noUsage :: RegUsage +noUsage = RU [] [] + +-- | Common things that we can do with instructions, on all architectures. +-- These are used by the shared parts of the native code generator, +-- specifically the register allocators. +-- +class Instruction instr where + + -- | Get the registers that are being used by this instruction. + -- regUsage doesn't need to do any trickery for jumps and such. + -- Just state precisely the regs read and written by that insn. + -- The consequences of control flow transfers, as far as register + -- allocation goes, are taken care of by the register allocator. + -- + regUsageOfInstr + :: Platform + -> instr + -> RegUsage + + + -- | Apply a given mapping to all the register references in this + -- instruction. + patchRegsOfInstr + :: HasDebugCallStack + => Platform + -> instr + -> (Reg -> Reg) + -> instr + + + -- | Checks whether this instruction is a jump/branch instruction. + -- One that can change the flow of control in a way that the + -- register allocator needs to worry about. + isJumpishInstr + :: instr -> Bool + + + -- | Give the possible *local block* destinations of this jump instruction. + -- Must be defined for all jumpish instructions. + jumpDestsOfInstr + :: instr -> [BlockId] + + -- | Check if the instr always transfers control flow + -- to the given block. Used by code layout to eliminate + -- jumps that can be replaced by fall through. + canFallthroughTo + :: instr -> BlockId -> Bool + + + -- | Change the destination of this jump instruction. + -- Used in the linear allocator when adding fixup blocks for join + -- points. + patchJumpInstr + :: instr + -> (BlockId -> BlockId) + -> instr + + + -- | An instruction to spill a register into a spill slot. + mkSpillInstr + :: HasDebugCallStack + => NCGConfig + -> RegWithFormat -- ^ the reg to spill + -> Int -- ^ the current stack delta + -> Int -- ^ spill slots to use + -> [instr] -- ^ instructions + + + -- | An instruction to reload a register from a spill slot. + mkLoadInstr + :: HasDebugCallStack + => NCGConfig + -> RegWithFormat -- ^ the reg to reload. + -> Int -- ^ the current stack delta + -> Int -- ^ the spill slot to use + -> [instr] -- ^ instructions + + -- | See if this instruction is telling us the current C stack delta + takeDeltaInstr + :: instr + -> Maybe Int + + -- | Check whether this instruction is some meta thing inserted into + -- the instruction stream for other purposes. + -- + -- Not something that has to be treated as a real machine instruction + -- and have its registers allocated. + -- + -- eg, comments, delta, ldata, etc. + isMetaInstr + :: instr + -> Bool + + + + -- | Copy the value in a register to another one. + -- Must work for all register classes. + mkRegRegMoveInstr + :: HasDebugCallStack + => NCGConfig + -> Format + -> Reg -- ^ source register + -> Reg -- ^ destination register + -> instr + + -- | Take the source and destination from this reg -> reg move instruction + -- or Nothing if it's not one + takeRegRegMoveInstr + :: Platform + -> instr + -> Maybe (Reg, Reg) + + -- | Make an unconditional jump instruction. + -- For architectures with branch delay slots, its ok to put + -- a NOP after the jump. Don't fill the delay slot with an + -- instruction that references regs or you'll confuse the + -- linear allocator. + mkJumpInstr + :: BlockId + -> [instr] + + + -- Subtract an amount from the C stack pointer + mkStackAllocInstr + :: Platform + -> Int + -> [instr] + + -- Add an amount to the C stack pointer + mkStackDeallocInstr + :: Platform + -> Int + -> [instr] + + -- | Pretty-print an instruction + pprInstr :: Platform -> instr -> SDoc + + -- Create a comment instruction + mkComment :: FastString -> [instr] diff --git a/GHC/CmmToAsm/LA64.hs b/GHC/CmmToAsm/LA64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64.hs @@ -0,0 +1,60 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Native code generator for LoongArch64 architectures +module GHC.CmmToAsm.LA64 ( ncgLA64 ) where + +import GHC.Prelude + +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Types +import GHC.Utils.Outputable (ftext) + +import qualified GHC.CmmToAsm.LA64.CodeGen as LA64 +import qualified GHC.CmmToAsm.LA64.Instr as LA64 +import qualified GHC.CmmToAsm.LA64.Ppr as LA64 +import qualified GHC.CmmToAsm.LA64.RegInfo as LA64 +import qualified GHC.CmmToAsm.LA64.Regs as LA64 + +ncgLA64 :: NCGConfig -> NcgImpl RawCmmStatics LA64.Instr LA64.JumpDest +ncgLA64 config = + NcgImpl + { ncgConfig = config, + cmmTopCodeGen = LA64.cmmTopCodeGen, + generateJumpTableForInstr = LA64.generateJumpTableForInstr config, + getJumpDestBlockId = LA64.getJumpDestBlockId, + canShortcut = LA64.canShortcut, + shortcutStatics = LA64.shortcutStatics, + shortcutJump = LA64.shortcutJump, + pprNatCmmDeclS = LA64.pprNatCmmDecl config, + pprNatCmmDeclH = LA64.pprNatCmmDecl config, + maxSpillSlots = LA64.maxSpillSlots config, + allocatableRegs = LA64.allocatableRegs platform, + ncgAllocMoreStack = LA64.allocMoreStack platform, + ncgMakeFarBranches = LA64.makeFarBranches, + extractUnwindPoints = const [], + invertCondBranches = \_ _ -> id + } + where + platform = ncgPlatform config + +-- | `Instruction` instance for LA64 +instance Instruction LA64.Instr where + regUsageOfInstr = LA64.regUsageOfInstr + patchRegsOfInstr _ = LA64.patchRegsOfInstr + isJumpishInstr = LA64.isJumpishInstr + canFallthroughTo = LA64.canFallthroughTo + jumpDestsOfInstr = LA64.jumpDestsOfInstr + patchJumpInstr = LA64.patchJumpInstr + mkSpillInstr = LA64.mkSpillInstr + mkLoadInstr = LA64.mkLoadInstr + takeDeltaInstr = LA64.takeDeltaInstr + isMetaInstr = LA64.isMetaInstr + mkRegRegMoveInstr _ _ = LA64.mkRegRegMoveInstr + takeRegRegMoveInstr _ = LA64.takeRegRegMoveInstr + mkJumpInstr = LA64.mkJumpInstr + mkStackAllocInstr = LA64.mkStackAllocInstr + mkStackDeallocInstr = LA64.mkStackDeallocInstr + mkComment = pure . LA64.COMMENT . ftext + pprInstr = LA64.pprInstr diff --git a/GHC/CmmToAsm/LA64/CodeGen.hs b/GHC/CmmToAsm/LA64/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/CodeGen.hs @@ -0,0 +1,2236 @@ +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +module GHC.CmmToAsm.LA64.CodeGen ( + cmmTopCodeGen + , generateJumpTableForInstr + , makeFarBranches +) + +where + +import Data.Maybe +import Data.Word +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.DebugBlock +import GHC.Cmm.Switch +import GHC.Cmm.Utils +import GHC.CmmToAsm.CPrim +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Monad + ( NatM, + getConfig, + getDebugBlock, + getFileId, + getNewLabelNat, + getNewRegNat, + getPicBaseMaybeNat, + getPlatform + ) +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.LA64.Cond +import GHC.CmmToAsm.LA64.Instr +import GHC.CmmToAsm.LA64.Regs +import GHC.CmmToAsm.Types +import GHC.Data.FastString +import GHC.Data.OrdList +import GHC.Float +import GHC.Platform +import GHC.Platform.Reg +import GHC.Platform.Regs +import GHC.Prelude hiding (EQ) +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.SrcLoc (srcSpanFile, srcSpanStartCol, srcSpanStartLine) +import GHC.Types.Tickish (GenTickish (..)) +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Monad +import Control.Monad +import GHC.Cmm.Dataflow.Label +import GHC.Types.Unique.DSM + +-- [General layout of an NCG] +cmmTopCodeGen :: + RawCmmDecl -> + NatM [NatCmmDecl RawCmmStatics Instr] +-- Thus we'll have to deal with either CmmProc ... +cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do + picBaseMb <- getPicBaseMaybeNat + when (isJust picBaseMb) $ panic "LA64.cmmTopCodeGen: Unexpected PIC base register" + + let blocks = toBlockListEntryFirst graph + (nat_blocks, statics) <- mapAndUnzipM basicBlockCodeGen blocks + + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + + pure tops + +-- ... or CmmData. +cmmTopCodeGen (CmmData sec dat) = pure [CmmData sec dat] -- no translation, we just use CmmStatic + +basicBlockCodeGen :: + Block CmmNode C C -> + NatM + ( [NatBasicBlock Instr], + [NatCmmDecl RawCmmStatics Instr] + ) +basicBlockCodeGen block = do + config <- getConfig + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + + header_comment_instr + | debugIsOn = + unitOL + $ MULTILINE_COMMENT + ( text "-- --------------------------- basicBlockCodeGen --------------------------- --\n" + $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block) + ) + | otherwise = nilOL + + -- Generate location directive `.loc` (DWARF debug location info) + loc_instrs <- genLocInstrs + + -- Generate other instructions + mid_instrs <- stmtsToInstrs stmts + (!tail_instrs) <- stmtToInstrs tail + + let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs + + -- TODO: Then x86 backend runs @verifyBasicBlock@ here. How important it is to + -- have a valid CFG is an open question: This and the AArch64 and PPC NCGs + -- work fine without it. + + -- Code generation may introduce new basic block boundaries, which are + -- indicated by the NEWBLOCK instruction. We must split up the instruction + -- stream into basic blocks again. Also, we extract LDATAs here too. + (top, other_blocks, statics) = foldrOL mkBlocks ([], [], []) instrs + + return (BasicBlock id top : other_blocks, statics) + where + genLocInstrs :: NatM (OrdList Instr) + genLocInstrs = do + dbg <- getDebugBlock (entryLabel block) + case dblSourceTick =<< dbg of + Just (SourceNote span name) -> + do + fileId <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col = srcSpanStartCol span + pure $ unitOL $ LOCATION fileId line col name + _ -> pure nilOL + +mkBlocks :: + Instr -> + ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) -> + ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) +mkBlocks (NEWBLOCK id) (instrs, blocks, statics) = + ([], BasicBlock id instrs : blocks, statics) +mkBlocks (LDATA sec dat) (instrs, blocks, statics) = + (instrs, blocks, CmmData sec dat : statics) +mkBlocks instr (instrs, blocks, statics) = + (instr : instrs, blocks, statics) + +-- ----------------------------------------------------------------------------- +-- | Utilities + +-- | Annotate an `Instr` with a `SDoc` comment +ann :: SDoc -> Instr -> Instr +ann doc instr {- debugIsOn -} = ANN doc instr +{-# INLINE ann #-} + +-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with +-- -dppr-debug. The idea is that we can trivially see how a cmm expression +-- ended up producing the assembly we see. By having the verbatim AST printed +-- we can simply check the patterns that were matched to arrive at the assembly +-- we generated. +-- +-- pprExpr will hide a lot of noise of the underlying data structure and print +-- the expression into something that can be easily read by a human. However +-- going back to the exact CmmExpr representation can be laborious and adds +-- indirections to find the matches that lead to the assembly. +-- +-- An improvement oculd be to have +-- +-- (pprExpr genericPlatform e) <> parens (text. show e) +-- +-- to have the best of both worlds. +-- +-- Note: debugIsOn is too restrictive, it only works for debug compilers. +-- However, we do not only want to inspect this for debug compilers. Ideally +-- we'd have a check for -dppr-debug here already, such that we don't even +-- generate the ANN expressions. However, as they are lazy, they shouldn't be +-- forced until we actually force them, and without -dppr-debug they should +-- never end up being forced. +annExpr :: CmmExpr -> Instr -> Instr +annExpr e {- debugIsOn -} = ANN (text . show $ e) +-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr +-- annExpr _ instr = instr +{-# INLINE annExpr #-} + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch +-- The index into the jump table is calulated by evaluating @expr@. The +-- corresponding table entry contains the address to jump to. +genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock +genSwitch config expr targets = do + (reg, fmt1, e_code) <- getSomeReg indexExpr + targetReg <- getNewRegNat II64 + lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + (tableReg, fmt2, t_code) <- getSomeReg $ dynRef + let code = + toOL [ COMMENT (text "indexExpr" <+> (text . show) indexExpr) + , COMMENT (text "dynRef" <+> (text . show) dynRef) + ] + `appOL` e_code + `appOL` t_code + `appOL` toOL + [ + COMMENT (ftext "Jump table for switch"), + -- index to offset into the table (relative to tableReg) + annExpr expr (SLL (OpReg W64 reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))), + -- calculate table entry address + ADD (OpReg W64 targetReg) (OpReg W64 reg) (OpReg (formatToWidth fmt2) tableReg), + -- load table entry (relative offset from tableReg (first entry) to target label) + LDU II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))), + -- calculate absolute address of the target label + ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg), + -- prepare jump to target label + J_TBL bids (Just lbl) targetReg + ] + return code + where + platform = ncgPlatform config + expr_w = cmmExprWidth platform expr + indexExpr0 = cmmOffset platform expr offset + -- Widen to a native-width register(addressing modes) + indexExpr = CmmMachOp + (MO_UU_Conv expr_w (platformWordWidth platform)) + [indexExpr0] + (offset, bids) = switchTargetsToTable targets + + +-- Generate jump table data (if required) +-- +-- Relies on PIC relocations. The idea is to emit one table entry per case. The +-- entry is the label of the block to jump to. This will be relocated to be the +-- address of the jump target. +generateJumpTableForInstr :: + NCGConfig -> + Instr -> + Maybe (NatCmmDecl RawCmmStatics Instr) +generateJumpTableForInstr config (J_TBL ids (Just lbl) _) = + let jumpTable = + map jumpTableEntryRel ids + where + jumpTableEntryRel Nothing = + CmmStaticLit (CmmInt 0 (ncgWordWidth config)) + jumpTableEntryRel (Just blockid) = + CmmStaticLit + ( CmmLabelDiffOff + blockLabel + lbl + 0 + (ncgWordWidth config) + ) + where + blockLabel = blockLbl blockid + in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable)) +generateJumpTableForInstr _ _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Top-level of the instruction selector +stmtsToInstrs :: + -- | Cmm Statements + [CmmNode O O] -> + -- | Resulting instruction + NatM InstrBlock +stmtsToInstrs stmts = concatOL <$> mapM stmtToInstrs stmts + +stmtToInstrs :: + CmmNode e x -> + -- | Resulting instructions + NatM InstrBlock + +stmtToInstrs stmt = do + config <- getConfig + platform <- getPlatform + case stmt of + CmmUnsafeForeignCall target result_regs args + -> genCCall target result_regs args + + CmmComment s -> return (unitOL (COMMENT (ftext s))) + CmmTick {} -> return nilOL + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode format reg src + | otherwise -> assignReg_IntCode format reg src + where ty = cmmRegType reg + format = cmmTypeFormat ty + + CmmStore addr src _alignment + | isFloatType ty -> assignMem_FltCode format addr src + | otherwise -> assignMem_IntCode format addr src + where ty = cmmExprType platform src + format = cmmTypeFormat ty + + CmmBranch id -> genBranch id + + --We try to arrange blocks such that the likely branch is the fallthrough + --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. + CmmCondBranch arg true false _prediction -> + genCondBranch true false arg + + CmmSwitch arg ids -> genSwitch config arg ids + + CmmCall { cml_target = arg } -> genJump arg + + CmmUnwind _regs -> pure nilOL + + _ -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt) + +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +type InstrBlock = + OrdList Instr + +-- | Register's passed up the tree. +-- If the stix code forces the register to live in a pre-decided machine +-- register, it comes out as @Fixed@; otherwise, it comes out as @Any@, and the +-- parent can decide which register to put it in. +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + +-- | Sometimes we need to change the Format of a register. Primarily during +-- conversion. +swizzleRegisterRep :: Format -> Register -> Register +swizzleRegisterRep format' (Fixed _ reg code) = Fixed format' reg code +swizzleRegisterRep format' (Any _ codefn) = Any format' codefn + +-- | Grab a `Reg` for a `CmmReg` +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal (LocalReg u pk)) + = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) + +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform (globalRegUse_reg mid) of + Just reg -> RegReal reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + +-- General things for putting together code sequences + +-- | Compute an expression into any register +getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, rep, code tmp) + Fixed rep reg code -> + return (reg, rep, code) + +-- | Compute an expression into any floating-point register + +-- | Compute an expression into floating point register +-- If the initial expression is not a floating-point expression, finally move +-- the result into a floating-point register. +getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) +getFloatReg expr = do + r <- getRegister expr + case r of + Any rep code | isFloatFormat rep -> do + tmp <- getNewRegNat rep + return (tmp, rep, code tmp) + Any II32 code -> do + tmp <- getNewRegNat FF32 + return (tmp, FF32, code tmp) + Any II64 code -> do + tmp <- getNewRegNat FF64 + return (tmp, FF64, code tmp) + Any _w _code -> do + config <- getConfig + pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr) + -- can't do much for fixed. + Fixed rep reg code -> + return (reg, rep, code) + +-- | Map `CmmLit` to `OpImm` +litToImm' :: CmmLit -> Operand +litToImm' = OpImm . litToImm + +-- Handling PIC on LA64 +-- Commonly, `PIC` means of `position independent code`, that to say, the execution +-- of code does not be influenced by Load_address. Through PC-Relative addressing +-- or GOT addressing, both can be used to implement `PIC`. +-- +-- For LoongArch's common compiler(GCC, Clang), they generate PIC code by default +-- without condition. The command option `-fPIC` dicates to generate code for +-- shared-library. If not just specified for shared-library, another option `-fPIE` +-- was be created. +-- +-- Like RV64, LA64 does not have a special PIC register, the general approach is to +-- simply do PC-relative addressing or go through the GOT. There is assembly support +-- for both. +-- +-- LA64 assembly has many `la*` (load address) pseudo-instructions, that allows +-- loading a symbols's address into a register. These instructions is desugared into +-- different addressing modes. See following: +-- +-- la rd, label + addend -> Load global symbol +-- la.global rd, label + addend -> Same as `la` +-- la.local rd, label + addend -> Load local symbol +-- la.pcrel rd, label + addend +-- la.got rd, label +-- la.abs rd, label + addend +-- +-- `la` is alias of `la.global`. Commonly recommended use `la.local` and `la.global`. +-- +-- PC-relative addressing: +-- pcalau12i $a0, %pc_hi20(a) +-- addi.d $a0, $a0, %pc_lo12(a) +-- +-- GOT addressing: +-- pcalau12i $a0, %got_pc_hi20(global_a) +-- ld.d $a0, $a0, %got_pc_lo12(global_a) +-- +-- PIC can be enabled/disabled through: +-- .option pic +-- +-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the +-- @cmmMakePicReference@. This is in turn called from @cmmMakeDynamicReference@ +-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported. There are two +-- callsites for this. One is in this module to produce the @target@ in @genCCall@ +-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@. +-- +-- Conceptually we do not want any special PicBaseReg to be used on LA64. If +-- we want to distinguish between symbol loading, we need to address this through +-- the way we load it, not through a register. + +-- Compute a `CmmExpr` into a `Register` +getRegister :: CmmExpr -> NatM Register +getRegister e = do + config <- getConfig + getRegister' config (ncgPlatform config) e + +-- Signed arithmetic on LoongArch64 +-- +-- Handling signed arithmetic on sub-word-size values on LA64 is a bit tricky +-- as Cmm's type system does not capture signedness. While 32- and 64-bit +-- values are fairly easy to handle due to LA64's 32- and 64-bit instructions +-- with responding register, 8- and 16-bit values require quite some care. +-- +-- For LoongArch64, EXT.W.[B/H] will sign-extend 8- and 16-bit to 64-bit. +-- However, it is best to use EXT instruction only if the input and +-- output data widths are fully determined. +-- +-- We handle 16-and 8-bit values by using the following two steps: +-- 1. Sign- or Zero-extending operands. +-- 2. Truncate results as necessary. +-- +-- For simplicity we maintain the invariant that a register containing a +-- sub-word-size value always contains the zero-extended form of that value +-- in between operations. + +getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register + +-- OPTIMIZATION WARNING: CmmExpr rewrites + +-- Generic case. +getRegister' config plat expr = + case expr of + CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) -> + pprPanic "getRegisterReg-memory" (ppr PicBaseReg) + + CmmLit lit -> + case lit of + CmmInt 0 w -> pure $ Fixed (intFormat w) zeroReg nilOL + CmmInt i w -> do + -- narrowU is important: Negative immediates may be + -- sign-extended on load! + let imm = OpImm . ImmInteger $ narrowU w i + return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) imm))) + + CmmFloat 0 w -> do + let op = litToImm' lit + pure (Any (floatFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) op))) + + CmmFloat _f W8 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr) + CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr) + + CmmFloat f W32 -> do + let word = castFloatToWord32 (fromRational f) :: Word32 + tmp <- getNewRegNat (intFormat W32) + return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W32 tmp) (OpImm (ImmInteger (fromIntegral word))) + , MOV (OpReg W32 dst) (OpReg W32 tmp) + ])) + CmmFloat f W64 -> do + let word = castDoubleToWord64 (fromRational f) :: Word64 + tmp <- getNewRegNat (intFormat W64) + return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W64 tmp) (OpImm (ImmInteger (fromIntegral word))) + , MOV (OpReg W64 dst) (OpReg W64 tmp) + ])) + + CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr) + CmmVec _lits -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr) + + CmmLabel lbl -> do + let op = OpImm (ImmCLbl lbl) + rep = cmmLitType plat lit + format = cmmTypeFormat rep + return (Any format (\dst -> unitOL $ annExpr expr (LD format (OpReg (formatToWidth format) dst) op))) + + CmmLabelOff lbl off | isNbitEncodeable 12 (fromIntegral off) -> do + let op = OpImm (ImmIndex lbl off) + rep = cmmLitType plat lit + format = cmmTypeFormat rep + return (Any format (\dst -> unitOL $ LD format (OpReg (formatToWidth format) dst) op)) + + CmmLabelOff lbl off -> do + let op = litToImm' (CmmLabel lbl) + rep = cmmLitType plat lit + format = cmmTypeFormat rep + width = typeWidth rep + (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width) + return (Any format (\dst -> off_code `snocOL` + LD format (OpReg (formatToWidth format) dst) op `snocOL` + ADD (OpReg W64 dst) (OpReg width dst) (OpReg width off_r) + )) + + CmmLabelDiffOff {} -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + + CmmLoad mem rep _ -> do + let format = cmmTypeFormat rep + width = typeWidth rep + Amode addr addr_code <- getAmode plat width mem + case width of + w | w `elem` [W8, W16, W32, W64] -> + -- Load without sign-extension. + pure (Any format (\dst -> + addr_code `snocOL` + LDU format (OpReg width dst) (OpAddr addr)) + ) + _ -> pprPanic ("Unknown width to load: " ++ show width) (pdoc plat expr) + + CmmStackSlot _ _ -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr) + + CmmReg reg -> return (Fixed (cmmTypeFormat (cmmRegType reg)) + (getRegisterReg plat reg) + nilOL + ) + + CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do + getRegister' config plat + $ CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where + width = typeWidth (cmmRegType reg) + CmmRegOff reg off -> do + (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width) + (reg, _format, code) <- getSomeReg $ CmmReg reg + return $ Any (intFormat width) ( \dst -> + off_code `appOL` + code `snocOL` + ADD (OpReg W64 dst) (OpReg width reg) (OpReg width off_r) + ) + where + width = typeWidth (cmmRegType reg) + + -- Handle MO_RelaxedRead as a normal CmmLoad, to allow + -- non-trivial addressing modes to be used. + CmmMachOp (MO_RelaxedRead w) [e] -> + getRegister (CmmLoad e (cmmBits w) NaturallyAligned) + + -- for MachOps, see GHC.Cmm.MachOp + -- For CmmMachOp, see GHC.Cmm.Expr + CmmMachOp op [e] -> do + (reg, format, code) <- getSomeReg e + case op of + MO_Not w -> return $ Any (intFormat w) $ \dst -> + code `appOL` + -- pseudo instruction `not dst rd` is `nor dst, r0, rd` + truncateReg (formatToWidth format) W64 reg `snocOL` + -- At this point an 8- or 16-bit value would be zero-extended + -- to 64-bits. Truncate back down the final width. + ann (text "not") (NOR (OpReg W64 dst) (OpReg W64 reg) zero) `appOL` + truncateReg W64 w dst + + MO_S_Neg w -> negate code w reg + MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` FNEG (OpReg w dst) (OpReg w reg)) + + -- Floating convertion oprations + -- Float -> Float + MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg)) + + -- Signed int -> Float + MO_SF_Round from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) + + -- Float -> Signed int + MO_FS_Truncate from to | from == W32 -> do + tmp <- getNewRegNat FF32 + return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from tmp) (OpReg from reg)) + + MO_FS_Truncate from to | from == W64-> do + tmp <- getNewRegNat FF64 + return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from tmp) (OpReg from reg)) + + -- unsigned int -> unsigned int + MO_UU_Conv from to -> return $ Any (intFormat to) (\dst -> + code `snocOL` BSTRPICK II64 (OpReg W64 dst) (OpReg W64 reg) (OpImm (ImmInt (widthToInt (min from to) - 1))) (OpImm (ImmInt 0)) + ) + + -- Signed int -> Signed int + MO_SS_Conv from to -> ss_conv from to reg code + + -- int -> int + MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e + + MO_WF_Bitcast w -> return $ Any (floatFormat w) (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg)) + MO_FW_Bitcast w -> return $ Any (intFormat w) (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg)) + + x -> pprPanic ("getRegister' (monadic CmmMachOp): " ++ show x) (pdoc plat expr) + where + -- In the case of 32- or 16- or 8-bit values we need to sign-extend to 64-bits + negate code w reg + | w `elem` [W8, W16] = do + return $ Any (intFormat w) $ \dst -> + code `snocOL` + EXT (OpReg W64 reg) (OpReg w reg) `snocOL` + NEG (OpReg W64 dst) (OpReg W64 reg) `appOL` + truncateReg W64 w dst + | otherwise = do + return $ Any (intFormat w) $ \dst -> + code `snocOL` + NEG (OpReg W64 dst) (OpReg w reg) + + ss_conv from to reg code + | from `elem` [W8, W16] || to `elem` [W8, W16] = do + return $ Any (intFormat to) $ \dst -> + code `snocOL` + EXT (OpReg W64 dst) (OpReg (min from to) reg) `appOL` + -- At this point an 8- or 16-bit value would be sign-extended + -- to 64-bits. Truncate back down the final width. + truncateReg W64 to dst + | from == W32 && to == W64 = do + return $ Any (intFormat to) $ \dst -> + code `snocOL` + SLL (OpReg to dst) (OpReg from reg) (OpImm (ImmInt 0)) + | from == to = do + return $ Any (intFormat from) $ \dst -> + code `snocOL` MOV (OpReg from dst) (OpReg from reg) + | otherwise = do + return $ Any (intFormat to) $ \dst -> + code `appOL` + signExtend from W64 reg dst `appOL` + truncateReg W64 to dst + + +-- Dyadic machops: + -- + -- The general idea is: + -- compute x <- x + -- compute x <- y + -- OP x, x, x + -- + -- TODO: for now we'll only implement the 64bit versions. And rely on the + -- fallthrough to alert us if things go wrong! + -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring + -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg + CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' + CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' + + CmmMachOp (MO_Add w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do + if w `elem` [W8, W16] + then do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + ADD (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)) + ) + else do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ADD (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_Sub w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do + if w `elem` [W8, W16] + then do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + SUB (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)) + ) + else do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SUB (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_U_Quot w) [x, y] + | w `elem` [W8, W16] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (DIVU (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + -- 2. Shifts. + CmmMachOp (MO_Shl w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)) + ) + CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + _ | w `elem` [W8, W16] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL` + SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y) + ) + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + + -- MO_S_Shr: signed-shift-right + CmmMachOp (MO_S_Shr w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)) + ) + CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRA (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + _ | w `elem` [W8, W16] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL` + SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y) + ) + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (SRA (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + + -- MO_U_Shr: unsigned-shift-right + CmmMachOp (MO_U_Shr w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + _ | w `elem` [W8, W16] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (SRL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + + -- 3. Logic &&, || + -- andi Instr's Imm-operand is zero-extended. + CmmMachOp (MO_And w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + + CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (AND (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp) + ) + + CmmLit (CmmInt n _) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp) + ) + + _ | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (AND (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + + -- ori Instr's Imm-operand is zero-extended. + CmmMachOp (MO_Or w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + + CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (OR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp) + ) + + CmmLit (CmmInt n _) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp) + ) + + _ | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (OR (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + + -- xori Instr's Imm-operand is zero-extended. + CmmMachOp (MO_Xor w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + + CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (XOR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp) + ) + + CmmLit (CmmInt n _) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + XOR (OpReg W64 dst) (OpReg w reg_x) (OpReg W64 tmp) + ) + + _ | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + -- CSET commands register operand being W64. + CmmMachOp (MO_Eq w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_Ne w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_S_Lt w) [x, CmmLit (CmmInt n _)] + | w `elem` [W8, W16, W32] + , fitsInNbits 12 (fromIntegral n) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + signExtend w W64 reg_x reg_x `snocOL` + annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + | fitsInNbits 12 (fromIntegral n) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_U_Lt w) [x, CmmLit (CmmInt n _)] + | w `elem` [W8, W16, W32] + , fitsInNbits 12 (fromIntegral n) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + | fitsInNbits 12 (fromIntegral n) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_S_Lt w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_S_Le w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_S_Ge w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_S_Gt w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_U_Lt w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_U_Le w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_U_Ge w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_U_Gt w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + + -- Generic binary case. + CmmMachOp op [x, y] -> do + let + -- A (potentially signed) integer operation. + -- In the case of 8-, 16- and 32-bit signed arithmetic we must first + -- sign-extend all arguments to 64-bits. + -- TODO: can be simplified. + intOp is_signed w op = do + -- compute x <- x + -- compute x <- y + -- x, x, x + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int" + let w' = W64 + -- This is the width of the registers on which the operation + -- should be performed. + if not is_signed + then return $ Any (intFormat w) $ \dst -> + code_x `appOL` + code_y `appOL` + -- zero-extend both operands + truncateReg (formatToWidth format_x) w' reg_x `appOL` + truncateReg (formatToWidth format_y) w' reg_y `snocOL` + op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL` + truncateReg w' w dst -- truncate back to the operand's original width + else return $ Any (intFormat w) $ \dst -> + code_x `appOL` + code_y `appOL` + -- sign-extend both operands + signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL` + signExtend (formatToWidth format_x) W64 reg_y reg_y `snocOL` + op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL` + truncateReg w' w dst -- truncate back to the operand's original width + + floatOp w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float" + return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)) + + -- need a special one for conditionals, as they return ints + floatCond w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float" + return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)) + + case op of + -- Integer operations + -- Add/Sub should only be Integer Options. + MO_Add w -> intOp False w (\d x y -> annExpr expr (ADD d x y)) + MO_Sub w -> intOp False w (\d x y -> annExpr expr (SUB d x y)) + + -- Signed multiply/divide/remain + MO_Mul w -> intOp True w (\d x y -> annExpr expr (MUL d x y)) + MO_S_MulMayOflo w -> do_mul_may_oflo w x y + + MO_S_Quot w -> intOp True w (\d x y -> annExpr expr (DIV d x y)) + MO_S_Rem w -> intOp True w (\d x y -> annExpr expr (MOD d x y)) + + -- Unsigned divide/remain + MO_U_Quot w -> intOp False w (\d x y -> annExpr expr (DIVU d x y)) + MO_U_Rem w -> intOp False w (\d x y -> annExpr expr (MODU d x y)) + + -- Floating point arithmetic + MO_F_Add w -> floatOp w (\d x y -> unitOL $ annExpr expr (ADD d x y)) + MO_F_Sub w -> floatOp w (\d x y -> unitOL $ annExpr expr (SUB d x y)) + MO_F_Mul w -> floatOp w (\d x y -> unitOL $ annExpr expr (MUL d x y)) + MO_F_Quot w -> floatOp w (\d x y -> unitOL $ annExpr expr (DIV d x y)) + MO_F_Min w -> floatOp w (\d x y -> unitOL $ annExpr expr (FMIN d x y)) + MO_F_Max w -> floatOp w (\d x y -> unitOL $ annExpr expr (FMAX d x y)) + + -- Floating point comparison + MO_F_Eq w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET EQ d x y)) + MO_F_Ne w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET NE d x y)) + MO_F_Ge w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FGE d x y)) + MO_F_Le w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FLE d x y)) + MO_F_Gt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FGT d x y)) + MO_F_Lt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FLT d x y)) + + op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ pprMachOp op <+> text "in" <+> pdoc plat expr + + -- Generic ternary case. + CmmMachOp op [x, y, z] -> + case op of + + -- Floating-point fused multiply-add operations + MO_FMA var l w + | l == 1 + -> case var of + FMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMAdd d n m a) + FMSub -> float3Op w (\d n m a -> unitOL $ FMA FMSub d n m a) + FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FNMSub d n m a) + FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a) + | otherwise + -> sorry "The RISCV64 backend does not (yet) support vectors." + + _ -> pprPanic "getRegister' (unhandled ternary CmmMachOp): " $ (pprMachOp op) <+> text "in" <+> (pdoc plat expr) + + where + float3Op w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + (reg_fz, format_z, code_fz) <- getFloatReg z + massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z) $ + text "float3Op: non-float" + pure $ + Any (floatFormat w) $ \ dst -> + code_fx `appOL` + code_fy `appOL` + code_fz `appOL` + op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz) + + CmmMachOp _op _xs + -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr) + + where + -- N.B. MUL does not set the overflow flag. + -- Return 0 when the operation cannot overflow, /= 0 otherwise + do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register + do_mul_may_oflo W64 x y = do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + lo <- getNewRegNat II64 + hi <- getNewRegNat II64 + return $ Any (intFormat W64) (\dst -> + code_x `appOL` + code_y `snocOL` + MULH (OpReg W64 hi) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL` + MUL (OpReg W64 lo) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL` + SRA (OpReg W64 lo) (OpReg W64 lo) (OpImm (ImmInt 63)) `snocOL` + CSET NE (OpReg W64 dst) (OpReg W64 hi) (OpReg W64 lo) + ) + + do_mul_may_oflo W32 x y = do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + tmp1 <- getNewRegNat II64 + tmp2 <- getNewRegNat II64 + return $ Any (intFormat W32) (\dst -> + code_x `appOL` + code_y `snocOL` + MULW (OpReg W64 tmp1) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL` + ADD (OpReg W64 tmp2) (OpReg W32 tmp1) (OpImm (ImmInt 0)) `snocOL` + CSET NE (OpReg W64 dst) (OpReg W64 tmp1) (OpReg W64 tmp2) + ) + + -- General case + do_mul_may_oflo w x y = do + -- Assert: 8bit * 8bit cannot overflow 16bit, and so on. + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + tmp1 <- getNewRegNat II64 + tmp2 <- getNewRegNat II64 + let width_x = formatToWidth format_x + width_y = formatToWidth format_y + extend dst src = + case w of + W8 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0)) + W16 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0)) + _ -> panic "Must be in [W8, W16, W32]!" + extract width dst src = + case width of + W8 -> EXT (OpReg W64 dst) (OpReg W8 src) + W16 -> EXT (OpReg W64 dst) (OpReg W16 src) + W32 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0)) + _ -> panic "Must be in [W8, W16, W32]!" + + case w of + w | (width_x < w) && (width_y < w) -> + return $ Any (intFormat w) ( \dst -> + unitOL $ annExpr expr (MOV (OpReg w dst) (OpImm (ImmInt 0))) + ) + w | w <= W32 && width_x <= W32 && width_y <= W32 -> + return $ Any (intFormat W32) (\dst -> + code_x `appOL` + code_y `appOL` + -- signExtend [W8, W16] register to W64 and then SLL + -- nil for W32 + signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL` + signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL` + extend reg_x reg_x `snocOL` + extend reg_y reg_y `snocOL` + -- 64-bits MUL + MUL (OpReg W64 tmp1) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL` + -- extract valid result via result's width + -- slli.w for W32, otherwise ext.w.[b, h] + extract w tmp2 tmp1 `snocOL` + CSET NE (OpReg W64 dst) (OpReg W64 tmp1) (OpReg W64 tmp2) + ) + + -- Should it be happened? + _ -> + return $ Any (intFormat w) ( \dst -> + unitOL $ annExpr expr (MOV (OpReg w dst) (OpImm (ImmInt 1)))) + +-- Sign-extend the value in the given register from width @w@ +-- up to width @w'@. +-- TODO: Is there room for optimization? +signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr +signExtend w w' r r' + | w > w' = pprPanic "Sign-extend Error: not a sign extension, but a truncation." $ ppr w <> text "->" <+> ppr w' + | w > W64 || w' > W64 = pprPanic "Sign-extend Error: from/to register width greater than 64-bit." $ ppr w <> text "->" <+> ppr w' + | w == W64 && w' == W64 && r == r' = nilOL + | w == W32 && w' == W64 = unitOL $ SLL (OpReg W64 r') (OpReg w r) (OpImm (ImmInt 0)) + -- Sign-extend W8 and W16 to W64. + | w `elem` [W8, W16] = unitOL $ EXT (OpReg W64 r') (OpReg w r) + | w == w' = unitOL $ MOV (OpReg w' r') (OpReg w r) + | otherwise = pprPanic "signExtend: Unexpected width: " $ ppr w <> text "->" <+> ppr w' + +-- | Instructions to truncate the value in the given register from width @w@ +-- down to width @w'@. +truncateReg :: Width -> Width -> Reg -> OrdList Instr +truncateReg w w' r + | w > W64 || w' > W64 = pprPanic "Tructate Error: from/to register width greater than 64-bit." $ ppr w <> text "->" <+> ppr w' + | w == w' = nilOL + | w /= w' = toOL + [ + ann + (text "truncateReg: " <+> ppr r <+> ppr w <> text "->" <> ppr w') + (BSTRPICK II64 (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift)) (OpImm (ImmInt 0))) + ] + | otherwise = pprPanic "truncateReg: Unexpected width: " $ ppr w <> text "->" <+> ppr w' + where + shift = (min (widthInBits w) (widthInBits w')) - 1 + +-- The 'Amode' type: Memory addressing modes passed up the tree. +data Amode = Amode AddrMode InstrBlock + +-- | Provide the value of a `CmmExpr` with an `Amode` +-- N.B. this function should be used to provide operands to load and store +-- instructions with signed 12bit wide immediates (S & I types). For other +-- immediate sizes and formats (e.g. B type uses multiples of 2) this function +-- would need to be adjusted. +getAmode :: Platform + -> Width -- ^ width of loaded value + -> CmmExpr + -> NatM Amode + +-- LD/ST: Immediate can be represented with 12bits +getAmode platform w (CmmRegOff reg off) + | w <= W64, fitsInNbits 12 (fromIntegral off) + = return $ Amode (AddrRegImm reg' off') nilOL + where reg' = getRegisterReg platform reg + off' = ImmInt off + +-- For Stores we often see something like this: +-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2) +-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ] +-- for `n` in range. +getAmode _platform _ (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')]) + | fitsInNbits 12 (fromIntegral off) + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrRegImm reg (ImmInteger off)) code + +getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')]) + | fitsInNbits 12 (fromIntegral (-off)) + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrRegImm reg (ImmInteger (-off))) code + +-- Generic case +getAmode _platform _ expr + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrReg reg) code + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_IntCode rep addrE srcE + = do + (src_reg, _format, code) <- getSomeReg srcE + platform <- getPlatform + let w = formatToWidth rep + Amode addr addr_code <- getAmode platform w addrE + return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE))) + `consOL` (code + `appOL` addr_code + `snocOL` ST rep (OpReg w src_reg) (OpAddr addr) + ) + +assignReg_IntCode _ reg src + = do + platform <- getPlatform + let dst = getRegisterReg platform reg + r <- getRegister src + return $ case r of + Any _ code -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` code dst + Fixed format freg fcode -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` + (fcode `snocOL` + MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg) + ) + +-- Let's treat Floating point stuff +-- as integer code for now. Opaque. +assignMem_FltCode = assignMem_IntCode +assignReg_FltCode = assignReg_IntCode + +-- Jumps +genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock +genJump expr = do + case expr of + (CmmLit (CmmLabel lbl)) -> do + return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TLabel lbl))) + (CmmLit (CmmBlock bid)) -> do + return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TBlock bid))) + _ -> do + (target, _format, code) <- getSomeReg expr + -- I'd like to do more. + return $ COMMENT (text "genJump for unknow expr: " <+> (text (show expr))) `consOL` + (code `appOL` + unitOL (annExpr expr (J (TReg target))) + ) + +-- ----------------------------------------------------------------------------- +-- Unconditional branches +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + +-- ----------------------------------------------------------------------------- +-- Conditional branches +genCondJump + :: BlockId + -> CmmExpr + -> NatM InstrBlock +genCondJump bid expr = do + case expr of + -- Optimized == 0 case. + CmmMachOp (MO_Eq W64) [x, CmmLit (CmmInt 0 _)] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ + code_x `snocOL` + BEQZ (OpReg W64 reg_x) (TBlock bid) + CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] + | w `elem` [W8, W16, W32] -> do + (reg_x, format_x, code_x) <- getSomeReg x + return $ + code_x `appOL` + signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL` + BEQZ (OpReg W64 reg_x) (TBlock bid) + + -- Optimized /= 0 case. + CmmMachOp (MO_Ne W64) [x, CmmLit (CmmInt 0 _)] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ code_x `snocOL` (annExpr expr (BNEZ (OpReg W64 reg_x) (TBlock bid))) + CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)] + | w `elem` [W8, W16, W32] -> do + (reg_x, format_x, code_x) <- getSomeReg x + return $ + code_x `appOL` + signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL` + BNEZ (OpReg W64 reg_x) (TBlock bid) + + -- Generic case. + CmmMachOp mop [x, y] -> do + let ubcond w cmp = do + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + return $ case w of + w | w `elem` [W8, W16, W32] -> + code_x `appOL` + truncateReg (formatToWidth format_x) W64 reg_x `appOL` + code_y `appOL` + truncateReg (formatToWidth format_y) W64 reg_y `snocOL` + BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) + _ -> + code_x `appOL` + code_y `snocOL` + BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) + + sbcond w cmp = do + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + return $ case w of + w | w `elem` [W8, W16, W32] -> + code_x `appOL` + signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL` + code_y `appOL` + signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL` + BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) + _ -> + code_x `appOL` + code_y `snocOL` + BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) + + fbcond w cmp = do + (reg_fx, _format_fx, code_fx) <- getFloatReg x + (reg_fy, _format_fy, code_fy) <- getFloatReg y + rst <- OpReg W64 <$> getNewRegNat II64 + oneReg <- OpReg W64 <$> getNewRegNat II64 + return $ + code_fx `appOL` + code_fy `snocOL` + CSET cmp rst (OpReg w reg_fx) (OpReg w reg_fy) `snocOL` + MOV oneReg (OpImm (ImmInt 1)) `snocOL` + BCOND1 EQ rst oneReg (TBlock bid) + + + case mop of + MO_F_Eq w -> fbcond w EQ + MO_F_Ne w -> fbcond w NE + MO_F_Gt w -> fbcond w FGT + MO_F_Ge w -> fbcond w FGE + MO_F_Lt w -> fbcond w FLT + MO_F_Le w -> fbcond w FLE + MO_Eq w -> sbcond w EQ + MO_Ne w -> sbcond w NE + MO_S_Gt w -> sbcond w SGT + MO_S_Ge w -> sbcond w SGE + MO_S_Lt w -> sbcond w SLT + MO_S_Le w -> sbcond w SLE + MO_U_Gt w -> ubcond w UGT + MO_U_Ge w -> ubcond w UGE + MO_U_Lt w -> ubcond w ULT + MO_U_Le w -> ubcond w ULE + _ -> pprPanic "LA64.genCondJump:case mop: " (text $ show expr) + + _ -> pprPanic "LA64.genCondJump: " (text $ show expr) + +-- | Generate conditional branching instructions +-- This is basically an "if with else" statement. +genCondBranch :: + BlockId -> + BlockId -> + CmmExpr -> + NatM InstrBlock +genCondBranch true false expr = do + b1 <- genCondJump true expr + b2 <- genBranch false + return (b1 `appOL` b2) + +-- ----------------------------------------------------------------------------- +{- +Generating C calls + +Generate a call to a C function: + +GARs: 8 general-purpose registers $a0 - $a7, where $a0 and $a1 are also used for +integral values. +FARs: 8 floating-point registers $fa0 - $fa7, where $fa0 and $fa1 are also used +for returning values. + +An argument is passed using the stack only when no appropriate argument register +is available. + +Subroutines should ensure that the initial values of the general-purpose registers +$s0 - $s9 and floating-point registers $fs0 - $fs7 are preserved across the call. + +At the entry of a procedure call, the return address of the call site is stored +in $ra. A branch jump to this address should be the last instruction executed in +the called procedure. + +The on-stack part of the structure and scalar arguments are aligned to the greater +of the type alignment and GRLEN bits, except when this alignment is larger than + the 16-byte stack alignment. In this case, the part of the argument should be +16-byte-aligned. + +In a procedure call, GARs / FARs are generally only used for passing non-floating +-point / floating-point argument data, respectively. However, the floating-point +member of a structure or union argument, or a vector/floating-point argument +wider than FRLEN may be passed in a GAR. +-} + +genCCall + :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + +-- TODO: Specialize where we can. +-- Generic impl +genCCall target dest_regs arg_regs = do + case target of + -- The target :: ForeignTarget call can either + -- be a foreign procedure with an address expr + -- and a calling convention. + ForeignTarget expr _cconv -> do + (call_target, call_target_code) <- case expr of + -- if this is a label, let's just directly to it. + (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL) + -- if it's not a label, let's compute the expression into a + -- register and jump to that. + _ -> do + (reg, _format, reg_code) <- getSomeReg expr + pure (TReg reg, reg_code) + -- compute the code and register logic for all arg_regs. + -- this will give us the format information to match on. + arg_regs' <- mapM getSomeReg arg_regs + + -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes + -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in + -- STG; this thenn breaks packing of stack arguments, if we need to pack + -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type + -- in Cmm proper. Option two, which we choose here is to use extended Hint + -- information to contain the size information and use that when packing + -- arguments, spilled onto the stack. + let (_res_hints, arg_hints) = foreignTargetHints target + arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints + + (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL + + readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL + + let moveStackDown 0 = toOL [ PUSH_STACK_FRAME + , DELTA (-16) + ] + moveStackDown i | odd i = moveStackDown (i + 1) + moveStackDown i = toOL [ PUSH_STACK_FRAME + , SUB (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i))) + , DELTA (-8 * i - 16) + ] + moveStackUp 0 = toOL [ POP_STACK_FRAME + , DELTA 0 + ] + moveStackUp i | odd i = moveStackUp (i + 1) + moveStackUp i = toOL [ ADD (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i))) + , POP_STACK_FRAME + , DELTA 0 + ] + + let code = + call_target_code -- compute the label (possibly into a register) + `appOL` moveStackDown (stackSpaceWords) + `appOL` passArgumentsCode -- put the arguments into x0, ... + `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return) + `appOL` readResultsCode -- parse the results into registers + `appOL` moveStackUp (stackSpaceWords) + return code + + PrimTarget MO_F32_Fabs + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F32_Fabs" + PrimTarget MO_F64_Fabs + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F64_Fabs" + + PrimTarget MO_F32_Sqrt + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F32_Sqrt" + PrimTarget MO_F64_Sqrt + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F64_Sqrt" + + PrimTarget (MO_Clz w) + | w `elem` [W32, W64], + [arg_reg] <- arg_regs, + [dest_reg] <- dest_regs -> do + platform <- getPlatform + (reg_x, _format_x, code_x) <- getSomeReg arg_reg + let dst_reg = getRegisterReg platform (CmmLocal dest_reg) + return ( code_x `snocOL` + CLZ (OpReg w dst_reg) (OpReg w reg_x) + ) + | w `elem` [W8, W16], + [arg_reg] <- arg_regs, + [dest_reg] <- dest_regs -> do + platform <- getPlatform + (reg_x, _format_x, code_x) <- getSomeReg arg_reg + let dst_reg = getRegisterReg platform (CmmLocal dest_reg) + return ( code_x `appOL` toOL + [ + MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)), + SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))), + SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))), + OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x), + CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg) + ] + ) + | otherwise -> unsupported (MO_Clz w) + where + shift = widthToInt w + + PrimTarget (MO_Ctz w) + | w `elem` [W32, W64], + [arg_reg] <- arg_regs, + [dest_reg] <- dest_regs -> do + platform <- getPlatform + (reg_x, _format_x, code_x) <- getSomeReg arg_reg + let dst_reg = getRegisterReg platform (CmmLocal dest_reg) + return ( code_x `snocOL` + CTZ (OpReg w dst_reg) (OpReg w reg_x) + ) + | w `elem` [W8, W16], + [arg_reg] <- arg_regs, + [dest_reg] <- dest_regs -> do + platform <- getPlatform + (reg_x, _format_x, code_x) <- getSomeReg arg_reg + let dst_reg = getRegisterReg platform (CmmLocal dest_reg) + return ( code_x `appOL` toOL + [ + MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)), + SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)), + BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)), + OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x), + CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg) + ] + ) + | otherwise -> unsupported (MO_Ctz w) + where + shift = (widthToInt w) + + -- mop :: CallishMachOp (see GHC.Cmm.MachOp) + PrimTarget mop -> do + -- We'll need config to construct forien targets + case mop of + -- 64 bit float ops + MO_F64_Pwr -> mkCCall "pow" + + MO_F64_Sin -> mkCCall "sin" + MO_F64_Cos -> mkCCall "cos" + MO_F64_Tan -> mkCCall "tan" + + MO_F64_Sinh -> mkCCall "sinh" + MO_F64_Cosh -> mkCCall "cosh" + MO_F64_Tanh -> mkCCall "tanh" + + MO_F64_Asin -> mkCCall "asin" + MO_F64_Acos -> mkCCall "acos" + MO_F64_Atan -> mkCCall "atan" + + MO_F64_Asinh -> mkCCall "asinh" + MO_F64_Acosh -> mkCCall "acosh" + MO_F64_Atanh -> mkCCall "atanh" + + MO_F64_Log -> mkCCall "log" + MO_F64_Log1P -> mkCCall "log1p" + MO_F64_Exp -> mkCCall "exp" + MO_F64_ExpM1 -> mkCCall "expm1" + + -- 32 bit float ops + MO_F32_Pwr -> mkCCall "powf" + + MO_F32_Sin -> mkCCall "sinf" + MO_F32_Cos -> mkCCall "cosf" + MO_F32_Tan -> mkCCall "tanf" + MO_F32_Sinh -> mkCCall "sinhf" + MO_F32_Cosh -> mkCCall "coshf" + MO_F32_Tanh -> mkCCall "tanhf" + MO_F32_Asin -> mkCCall "asinf" + MO_F32_Acos -> mkCCall "acosf" + MO_F32_Atan -> mkCCall "atanf" + MO_F32_Asinh -> mkCCall "asinhf" + MO_F32_Acosh -> mkCCall "acoshf" + MO_F32_Atanh -> mkCCall "atanhf" + MO_F32_Log -> mkCCall "logf" + MO_F32_Log1P -> mkCCall "log1pf" + MO_F32_Exp -> mkCCall "expf" + MO_F32_ExpM1 -> mkCCall "expm1f" + + -- 64-bit primops + MO_I64_ToI -> mkCCall "hs_int64ToInt" + MO_I64_FromI -> mkCCall "hs_intToInt64" + MO_W64_ToW -> mkCCall "hs_word64ToWord" + MO_W64_FromW -> mkCCall "hs_wordToWord64" + MO_x64_Neg -> mkCCall "hs_neg64" + MO_x64_Add -> mkCCall "hs_add64" + MO_x64_Sub -> mkCCall "hs_sub64" + MO_x64_Mul -> mkCCall "hs_mul64" + MO_I64_Quot -> mkCCall "hs_quotInt64" + MO_I64_Rem -> mkCCall "hs_remInt64" + MO_W64_Quot -> mkCCall "hs_quotWord64" + MO_W64_Rem -> mkCCall "hs_remWord64" + MO_x64_And -> mkCCall "hs_and64" + MO_x64_Or -> mkCCall "hs_or64" + MO_x64_Xor -> mkCCall "hs_xor64" + MO_x64_Not -> mkCCall "hs_not64" + MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64" + MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64" + MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64" + MO_x64_Eq -> mkCCall "hs_eq64" + MO_x64_Ne -> mkCCall "hs_ne64" + MO_I64_Ge -> mkCCall "hs_geInt64" + MO_I64_Gt -> mkCCall "hs_gtInt64" + MO_I64_Le -> mkCCall "hs_leInt64" + MO_I64_Lt -> mkCCall "hs_ltInt64" + MO_W64_Ge -> mkCCall "hs_geWord64" + MO_W64_Gt -> mkCCall "hs_gtWord64" + MO_W64_Le -> mkCCall "hs_leWord64" + MO_W64_Lt -> mkCCall "hs_ltWord64" + + -- Conversion + MO_UF_Conv w -> mkCCall (word2FloatLabel w) + + -- Optional MachOps + -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config + MO_S_Mul2 _w -> unsupported mop + MO_S_QuotRem _w -> unsupported mop + MO_U_QuotRem _w -> unsupported mop + MO_U_QuotRem2 _w -> unsupported mop + MO_Add2 _w -> unsupported mop + MO_AddWordC _w -> unsupported mop + MO_SubWordC _w -> unsupported mop + MO_AddIntC _w -> unsupported mop + MO_SubIntC _w -> unsupported mop + MO_U_Mul2 _w -> unsupported mop + + MO_VS_Quot {} -> unsupported mop + MO_VS_Rem {} -> unsupported mop + MO_VU_Quot {} -> unsupported mop + MO_VU_Rem {} -> unsupported mop + MO_I64X2_Min -> unsupported mop + MO_I64X2_Max -> unsupported mop + MO_W64X2_Min -> unsupported mop + MO_W64X2_Max -> unsupported mop + + -- Memory Ordering + -- A hint value of 0 is mandatory by default, and it indicates a fully functional synchronization barrier. + -- Only after all previous load/store access operations are completely executed, the DBAR 0 instruction can be executed; + -- and only after the execution of DBAR 0 is completed, all subsequent load/store access operations can be executed. + + MO_AcquireFence -> pure (unitOL (DBAR Hint0)) + MO_ReleaseFence -> pure (unitOL (DBAR Hint0)) + MO_SeqCstFence -> pure (unitOL (DBAR Hint0)) + + MO_Touch -> pure nilOL -- Keep variables live (when using interior pointers) + -- Prefetch + MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint. + + -- Memory copy/set/move/cmp, with alignment for optimization + + -- TODO Optimize and use e.g. quad registers to move memory around instead + -- of offloading this to memcpy. For small memcpys we can utilize + -- the 128bit quad registers in NEON to move block of bytes around. + -- Might also make sense of small memsets? Use xzr? What's the function + -- call overhead? + MO_Memcpy _align -> mkCCall "memcpy" + MO_Memset _align -> mkCCall "memset" + MO_Memmove _align -> mkCCall "memmove" + MO_Memcmp _align -> mkCCall "memcmp" + + MO_SuspendThread -> mkCCall "suspendThread" + MO_ResumeThread -> mkCCall "resumeThread" + + MO_PopCnt w -> mkCCall (popCntLabel w) + MO_Pdep w -> mkCCall (pdepLabel w) + MO_Pext w -> mkCCall (pextLabel w) + MO_BSwap w -> mkCCall (bSwapLabel w) + MO_BRev w -> mkCCall (bRevLabel w) + + -- or a possibly side-effecting machine operation + mo@(MO_AtomicRead w ord) + | [p_reg] <- arg_regs + , [dst_reg] <- dest_regs -> do + (p, _fmt_p, code_p) <- getSomeReg p_reg + platform <- getPlatform + let instrs = case ord of + MemOrderRelaxed -> unitOL $ ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)) + + MemOrderAcquire -> toOL [ + ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)), + DBAR Hint0 + ] + MemOrderSeqCst -> toOL [ + ann moDescr (DBAR Hint0), + LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p), + DBAR Hint0 + ] + _ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo + dst = getRegisterReg platform (CmmLocal dst_reg) + moDescr = (text . show) mo + code = code_p `appOL` instrs + pure code + | otherwise -> panic "mal-formed AtomicRead" + + mo@(MO_AtomicWrite w ord) + | [p_reg, val_reg] <- arg_regs -> do + (p, _fmt_p, code_p) <- getSomeReg p_reg + (val, fmt_val, code_val) <- getSomeReg val_reg + let instrs = case ord of + MemOrderRelaxed -> unitOL $ ann moDescr (ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)) + MemOrderRelease -> toOL [ + ann moDescr (DBAR Hint0), + ST fmt_val (OpReg w val) (OpAddr $ AddrReg p) + ] + MemOrderSeqCst -> toOL [ + ann moDescr (DBAR Hint0), + ST fmt_val (OpReg w val) (OpAddr $ AddrReg p), + DBAR Hint0 + ] + _ -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo + moDescr = (text . show) mo + code = + code_p `appOL` + code_val `appOL` + instrs + pure code + | otherwise -> panic "mal-formed AtomicWrite" + + MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop) + MO_Cmpxchg w -> mkCCall (cmpxchgLabel w) + MO_Xchg w -> mkCCall (xchgLabel w) + + where + unsupported :: Show a => a -> b + unsupported mop = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + + mkCCall :: FastString -> NatM InstrBlock + mkCCall name = do + config <- getConfig + target <- + cmmMakeDynamicReference config CallReference + $ mkForeignLabel name ForeignLabelInThisPackage IsFunction + let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn + genCCall (ForeignTarget target cconv) dest_regs arg_regs + + -- Implementiation of the LoongArch ABI calling convention. + -- https://github.com/loongson/la-abi-specs/blob/release/lapcs.adoc#passing-arguments + passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock) + + -- 1. Base case: no more arguments to pass (left) + passArguments _ _ [] stackSpaceWords accumRegs accumCode = return (stackSpaceWords, accumRegs, accumCode) + + -- 2. Still have GP regs, and we want to pass an GP argument. + passArguments (gpReg : gpRegs) fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do + let w = formatToWidth format + ext + -- Specifically, LoongArch64's ABI requires that the caller + -- sign-extend arguments which are smaller than 64-bits. + | w `elem` [W8, W16, W32] + = case w of + W8 -> EXT (OpReg W64 gpReg) (OpReg w r) + W16 -> EXT (OpReg W64 gpReg) (OpReg w r) + W32 -> SLL (OpReg W64 gpReg) (OpReg w r) (OpImm (ImmInt 0)) + _ -> panic "Unexpected width(Here w < W64)!" + | otherwise + = MOV (OpReg w gpReg) (OpReg w r) + accumCode' = accumCode `appOL` + code_r `snocOL` + ann (text "Pass gp argument: " <> ppr r) ext + + passArguments gpRegs fpRegs args stackSpaceWords (gpReg : accumRegs) accumCode' + + -- 3. Still have FP regs, and we want to pass an FP argument. + passArguments gpRegs (fpReg : fpRegs) ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do + let w = formatToWidth format + mov = MOV (OpReg w fpReg) (OpReg w r) + accumCode' = accumCode `appOL` + code_r `snocOL` + ann (text "Pass fp argument: " <> ppr r) mov + + passArguments gpRegs fpRegs args stackSpaceWords (fpReg : accumRegs) accumCode' + + -- 4. No mor regs left to pass. Must pass on stack. + passArguments [] [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode = do + let w = formatToWidth format + spOffet = 8 * stackSpaceWords + str = ST format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet))) + stackCode = + code_r + `snocOL` (MOV (OpReg w tmpReg) (OpReg w r)) + `appOL` truncateReg w W64 tmpReg + `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr tmpReg) str + + passArguments [] [] args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode) + + -- 5. Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then. + passArguments [] fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do + let w = formatToWidth format + spOffet = 8 * stackSpaceWords + str = ST format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet))) + stackCode = + code_r + `snocOL` ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str + + passArguments [] fpRegs args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode) + + -- 6. Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then. + passArguments (gpReg : gpRegs) [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do + let w = formatToWidth format + mov = MOV (OpReg w gpReg) (OpReg w r) + accumCode' = accumCode `appOL` + code_r `snocOL` + ann (text "Pass fp argument in gpReg: " <> ppr r) mov + + passArguments gpRegs [] args stackSpaceWords (gpReg : accumRegs) accumCode' + + + passArguments _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") + + readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg] -> InstrBlock -> NatM InstrBlock + readResults _ _ [] _ accumCode = return accumCode + readResults [] _ _ _ _ = do + platform <- getPlatform + pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target) + readResults _ [] _ _ _ = do + platform <- getPlatform + pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target) + readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do + -- gp/fp reg -> dst + platform <- getPlatform + let rep = cmmRegType (CmmLocal dst) + format = cmmTypeFormat rep + w = cmmRegWidth (CmmLocal dst) + r_dst = getRegisterReg platform (CmmLocal dst) + if isFloatFormat format + then readResults (gpReg : gpRegs) fpRegs dsts (fpReg : accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg)) + else + readResults gpRegs (fpReg : fpRegs) dsts (gpReg : accumRegs) + $ accumCode + `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg) + `appOL` + -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations + truncateReg W64 w r_dst + + unaryFloatOp w op arg_reg dest_reg = do + platform <- getPlatform + (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg + let dst = getRegisterReg platform (CmmLocal dest_reg) + let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx) + pure code + +data BlockInRange = InRange | NotInRange BlockId + +genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock +genCondFarJump cond op1 op2 far_target = do + return $ toOL [ ann (text "Conditional far jump to: " <> ppr far_target) + $ BCOND cond op1 op2 (TBlock far_target) + ] + +makeFarBranches :: + Platform -> + LabelMap RawCmmStatics -> + [NatBasicBlock Instr] -> + UniqDSM [NatBasicBlock Instr] + +makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do + -- All offsets/positions are counted in multiples of 4 bytes (the size of LoongArch64 instructions) + -- That is an offset of 1 represents a 4-byte/one instruction offset. + let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks + if func_size < max_cond_jump_dist + then pure basic_blocks + else do + (_, blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks + pure $ concat blocks + where + max_cond_jump_dist = 2 ^ (15 :: Int) - 8 :: Int + -- Currently all inline info tables fit into 64 bytes. + max_info_size = 16 :: Int + long_bc_jump_dist = 2 :: Int + + -- Replace out of range conditional jumps with unconditional jumps. + replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr]) + replace_blk !m !pos (BasicBlock lbl instrs) = do + -- Account for a potential info table before the label. + let !block_pos = pos + infoTblSize_maybe lbl + (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs + let instrs'' = concat instrs' + -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary. + let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs'' + -- There should be no data in the instruction stream at this point + massert (null no_data) + + let final_blocks = BasicBlock lbl top : split_blocks + pure (pos', final_blocks) + + replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr]) + replace_jump !m !pos instr = do + case instr of + ANN ann instr -> do + replace_jump m pos instr >>= \case + (idx, instr' : instrs') -> pure (idx, ANN ann instr' : instrs') + (idx, []) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx) + + BCOND1 cond op1 op2 t -> + case target_in_range m t pos of + InRange -> pure (pos + 1, [instr]) + NotInRange far_target -> do + jmp_code <- genCondFarJump cond op1 op2 far_target + pure (pos + long_bc_jump_dist, fromOL jmp_code) + + _ -> pure (pos + instr_size instr, [instr]) + + target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange + target_in_range m target src = + case target of + (TReg{}) -> InRange + (TBlock bid) -> block_in_range m src bid + (TLabel clbl) + | Just bid <- maybeLocalBlockLabel clbl + -> block_in_range m src bid + | otherwise + -> InRange + + block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange + block_in_range m src_pos dest_lbl = + case mapLookup dest_lbl m of + Nothing -> + pprTrace "not in range" (ppr dest_lbl) $ NotInRange dest_lbl + Just dest_pos -> + if abs (dest_pos - src_pos) < max_cond_jump_dist + then InRange + else NotInRange dest_lbl + + calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int) + calc_lbl_positions (pos, m) (BasicBlock lbl instrs) = + let !pos' = pos + infoTblSize_maybe lbl + in foldl' instr_pos (pos', mapInsert lbl pos' m) instrs + + instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int) + instr_pos (pos, m) instr = (pos + instr_size instr, m) + + infoTblSize_maybe bid = + case mapLookup bid statics of + Nothing -> 0 :: Int + Just _info_static -> max_info_size + + instr_size :: Instr -> Int + instr_size i = case i of + COMMENT {} -> 0 + MULTILINE_COMMENT {} -> 0 + ANN _ instr -> instr_size instr + LOCATION {} -> 0 + DELTA {} -> 0 + -- At this point there should be no NEWBLOCK in the instruction stream (pos, mapInsert bid pos m) + NEWBLOCK {} -> panic "mkFarBranched - Unexpected" + LDATA {} -> panic "mkFarBranched - Unexpected" + PUSH_STACK_FRAME -> 4 + POP_STACK_FRAME -> 4 + CSET {} -> 2 + LD _ _ (OpImm (ImmIndex _ _)) -> 3 + LD _ _ (OpImm (ImmCLbl _)) -> 2 + SCVTF {} -> 2 + FCVTZS {} -> 4 + BCOND {} -> long_bc_jump_dist + CALL (TReg _) _ -> 1 + CALL {} -> 2 + CALL36 {} -> 2 + TAIL36 {} -> 2 + _ -> 1 diff --git a/GHC/CmmToAsm/LA64/Cond.hs b/GHC/CmmToAsm/LA64/Cond.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/Cond.hs @@ -0,0 +1,33 @@ +module GHC.CmmToAsm.LA64.Cond where + +import GHC.Prelude hiding (EQ) + +-- | Condition codes. +-- Used in conditional branches and bit setters. According to the available +-- instruction set, some conditions are encoded as their negated opposites. I.e. +-- these are logical things that don't necessarily map 1:1 to hardware/ISA. +-- TODO: Maybe need to simplify or expand? +data Cond +-- ISA condition + = EQ -- beq + | NE -- bne + | LT -- blt + | GE -- bge + | LTU -- bltu + | GEU -- bgeu + | EQZ -- beqz + | NEZ -- bnez +-- Extra Logical condition + | SLT -- LT + | SLE + | SGE -- GE + | SGT + | ULT -- LTU + | ULE + | UGE -- GEU + | UGT + | FLT + | FLE + | FGE + | FGT + deriving (Eq, Show) diff --git a/GHC/CmmToAsm/LA64/Instr.hs b/GHC/CmmToAsm/LA64/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/Instr.hs @@ -0,0 +1,1012 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.CmmToAsm.LA64.Instr where + +import GHC.Prelude + +import GHC.CmmToAsm.LA64.Cond +import GHC.CmmToAsm.LA64.Regs + +import GHC.CmmToAsm.Instr (RegUsage(..)) +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils +import GHC.CmmToAsm.Config +import GHC.Platform.Reg + +import GHC.Platform.Regs +import GHC.Platform.Reg.Class.Separate +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.Cmm.CLabel +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique.DSM + +import GHC.Utils.Panic +import Data.Maybe +import GHC.Stack +import GHC.Data.FastString (LexicalFastString) + +-- | Stack frame header size +-- Each stack frame contains ra and fp -- prologue. +stackFrameHeaderSize :: Int +stackFrameHeaderSize = 2 * spillSlotSize + +-- | All registers are 8 byte wide. +spillSlotSize :: Int +spillSlotSize = 8 + +-- | The number of bytes that the stack pointer should be aligned to. +stackAlign :: Int +stackAlign = 16 + +-- | The number of spill slots available without allocating more. +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config + = ( + (ncgSpillPreallocSize config - stackFrameHeaderSize) + `div` + spillSlotSize + ) - 1 + +-- | Convert a spill slot number to a *byte* offset. +spillSlotToOffset :: Int -> Int +spillSlotToOffset slot + = stackFrameHeaderSize + spillSlotSize * slot + +instance Outputable RegUsage where + ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')' + +-- | Get the registers that are being used by this instruction. +-- regUsage doesn't need to do any trickery for jumps and such. +-- Just state precisely the regs read and written by that insn. +-- The consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. +-- +-- RegUsage = RU [] [] +regUsageOfInstr :: Platform -> Instr -> RegUsage +regUsageOfInstr platform instr = case instr of + -- Pseudo Instructions + ANN _ i -> regUsageOfInstr platform i + COMMENT{} -> usage ([], []) + MULTILINE_COMMENT{} -> usage ([], []) + PUSH_STACK_FRAME -> usage ([], []) + POP_STACK_FRAME -> usage ([], []) + DELTA{} -> usage ([], []) + LOCATION{} -> usage ([], []) + + -- 1. Arithmetic Instructions ------------------------------------------------ + ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + ALSL dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + ALSLU dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + LU12I dst src1 -> usage (regOp src1, regOp dst) + LU32I dst src1 -> usage (regOp src1, regOp dst) + LU52I dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SSLT dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SSLTU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + PCADDI dst src1 -> usage (regOp src1, regOp dst) + PCADDU12I dst src1 -> usage (regOp src1, regOp dst) + PCADDU18I dst src1 -> usage (regOp src1, regOp dst) + PCALAU12I dst src1 -> usage (regOp src1, regOp dst) + AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + OR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + XOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + NOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + ANDN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + ORN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MULW dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MULWU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MULHU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + DIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + DIVU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MOD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MODU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + -- 2. Bit-shift Instructions ------------------------------------------ + SLL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SRL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SRA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + ROTR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + -- 3. Bit Manipulation Instructions ------------------------------------------ + EXT dst src1 -> usage (regOp src1, regOp dst) + CLO dst src1 -> usage (regOp src1, regOp dst) + CLZ dst src1 -> usage (regOp src1, regOp dst) + CTO dst src1 -> usage (regOp src1, regOp dst) + CTZ dst src1 -> usage (regOp src1, regOp dst) + BYTEPICK dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + REVB2H dst src1 -> usage (regOp src1, regOp dst) + REVB4H dst src1 -> usage (regOp src1, regOp dst) + REVB2W dst src1 -> usage (regOp src1, regOp dst) + REVBD dst src1 -> usage (regOp src1, regOp dst) + REVH2W dst src1 -> usage (regOp src1, regOp dst) + REVHD dst src1 -> usage (regOp src1, regOp dst) + BITREV4B dst src1 -> usage (regOp src1, regOp dst) + BITREV8B dst src1 -> usage (regOp src1, regOp dst) + BITREVW dst src1 -> usage (regOp src1, regOp dst) + BITREVD dst src1 -> usage (regOp src1, regOp dst) + BSTRINS _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + BSTRPICK _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + MASKEQZ dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MASKNEZ dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + -- + -- Pseudo instructions + NOP -> usage ([], []) + MOV dst src -> usage (regOp src, regOp dst) + NEG dst src -> usage (regOp src, regOp dst) + CSET _cond dst src1 src2 -> usage (regOp src1 ++ regOp src2 , regOp dst) + -- 4. Branch Instructions ---------------------------------------------------- + J t -> usage (regTarget t, []) + J_TBL _ _ t -> usage ([t], []) + B t -> usage (regTarget t, []) + BL t ps -> usage (regTarget t ++ ps, callerSavedRegisters) + CALL t ps -> usage (regTarget t ++ ps, callerSavedRegisters) + CALL36 t -> usage (regTarget t, []) + TAIL36 r t -> usage (regTarget t, regOp r) + -- Here two kinds of BCOND and BCOND1 are implemented, mainly because we want + -- to distinguish between two kinds of conditional jumps with different jump + -- ranges, corresponding to 2 and 1 instruction implementations respectively. + -- + -- BCOND1 is selected by default. + BCOND1 _ j d t -> usage (regTarget t ++ regOp j ++ regOp d, []) + BCOND _ j d t -> usage (regTarget t ++ regOp j ++ regOp d, []) + BEQZ j t -> usage (regTarget t ++ regOp j, []) + BNEZ j t -> usage (regTarget t ++ regOp j, []) + -- 5. Common Memory Access Instructions -------------------------------------- + LD _ dst src -> usage (regOp src, regOp dst) + LDU _ dst src -> usage (regOp src, regOp dst) + ST _ dst src -> usage (regOp src ++ regOp dst, []) + LDX _ dst src -> usage (regOp src, regOp dst) + LDXU _ dst src -> usage (regOp src, regOp dst) + STX _ dst src -> usage (regOp src ++ regOp dst, []) + LDPTR _ dst src -> usage (regOp src, regOp dst) + STPTR _ dst src -> usage (regOp src ++ regOp dst, []) + PRELD _hint src -> usage (regOp src, []) + -- 6. Bound Check Memory Access Instructions --------------------------------- + -- LDCOND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + -- STCOND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + -- 7. Atomic Memory Access Instructions -------------------------------------- + -- 8. Barrier Instructions --------------------------------------------------- + DBAR _hint -> usage ([], []) + IBAR _hint -> usage ([], []) + -- 11. Floating Point Instructions ------------------------------------------- + FMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FMAXA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FMINA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FNEG dst src1 -> usage (regOp src1, regOp dst) + + FCVT dst src -> usage (regOp src, regOp dst) + -- SCVTF dst src -> usage (regOp src, regOp src ++ regOp dst) + SCVTF dst src -> usage (regOp src, regOp dst) + FCVTZS dst src1 src2 -> usage (regOp src2, regOp src1 ++ regOp dst) + FABS dst src -> usage (regOp src, regOp dst) + FSQRT dst src -> usage (regOp src, regOp dst) + FMA _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + + _ -> panic $ "regUsageOfInstr: " ++ instrCon instr + + where + -- filtering the usage is necessary, otherwise the register + -- allocator will try to allocate pre-defined fixed stg + -- registers as well, as they show up. + usage :: ([Reg], [Reg]) -> RegUsage + usage (srcRegs, dstRegs) = + RU + (map mkFmt $ filter (interesting platform) srcRegs) + (map mkFmt $ filter (interesting platform) dstRegs) + + mkFmt r = RegWithFormat r fmt + where + fmt = case cls of + RcInteger -> II64 + RcFloat -> FF64 + RcVector -> sorry "The LoongArch64 NCG does not (yet) support vectors; please use -fllvm." + cls = case r of + RegVirtual vr -> classOfVirtualReg (platformArch platform) vr + RegReal rr -> classOfRealReg rr + + regAddr :: AddrMode -> [Reg] + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] + regAddr (AddrReg r1) = [r1] + + regOp :: Operand -> [Reg] + regOp (OpReg _ r1) = [r1] + regOp (OpAddr a) = regAddr a + regOp (OpImm _) = [] + + regTarget :: Target -> [Reg] + regTarget (TBlock _) = [] + regTarget (TLabel _) = [] + regTarget (TReg r1) = [r1] + + -- Is this register interesting for the register allocator? + interesting :: Platform -> Reg -> Bool + interesting _ (RegVirtual _) = True + interesting platform (RegReal (RealRegSingle i)) = freeReg platform i + +-- | Caller-saved registers (according to calling convention) +-------------------------------------------------------------------------------------------------------------------------------------------------------------------- +-- | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | +-------------------------------------------------------------------------------------------------------------------------------------------------------------------- +-- |zero| ra | tp | sp | a0 | a1 | a2 | a3 | a4 | a5 | a6 | a7 | t0 | t1 | t2 | t3 | t4 | t5 | t6 | t7 | t8 | Rv | fp | s0 | s1 | s2 | s3 | s4 | s5 | s6 | s7 | s8 | +-------------------------------------------------------------------------------------------------------------------------------------------------------------------- +-- | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 42 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | +-------------------------------------------------------------------------------------------------------------------------------------------------------------------- +--f| a0 | a1 | a2 | a3 | a4 | a5 | a6 | a7 | t0 | t1 | t2 | t3 | t4 | t5 | t6 | t7 | t8 | t9 | t10| t11| t12| t13| t14| t15| s0 | s1 | s2 | s3 | s4 | s5 | s6 | s7 | +-------------------------------------------------------------------------------------------------------------------------------------------------------------------- +callerSavedRegisters :: [Reg] +callerSavedRegisters = + -- TODO: Not sure. + [regSingle 1] -- ra + ++ map regSingle [4 .. 11] -- a0 - a7 + ++ map regSingle [12 .. 20] -- t0 - t8 + ++ map regSingle [32 .. 39] -- fa0 - fa7 + ++ map regSingle [40 .. 55] -- ft0 - ft15 + +-- | Apply a given mapping to all the register references in this instruction. +patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +patchRegsOfInstr instr env = case instr of + -- 0. Meta Instructions + ANN d i -> ANN d (patchRegsOfInstr i env) + COMMENT{} -> instr + MULTILINE_COMMENT{} -> instr + PUSH_STACK_FRAME -> instr + POP_STACK_FRAME -> instr + DELTA{} -> instr + LOCATION{} -> instr + -- 1. Arithmetic Instructions ------------------------------------------------ + ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3) + SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3) + ALSL o1 o2 o3 o4 -> ALSL (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + ALSLU o1 o2 o3 o4 -> ALSLU (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + LU12I o1 o2 -> LU12I (patchOp o1) (patchOp o2) + LU32I o1 o2 -> LU32I (patchOp o1) (patchOp o2) + LU52I o1 o2 o3 -> LU52I (patchOp o1) (patchOp o2) (patchOp o3) + SSLT o1 o2 o3 -> SSLT (patchOp o1) (patchOp o2) (patchOp o3) + SSLTU o1 o2 o3 -> SSLTU (patchOp o1) (patchOp o2) (patchOp o3) + PCADDI o1 o2 -> PCADDI (patchOp o1) (patchOp o2) + PCADDU12I o1 o2 -> PCADDU12I (patchOp o1) (patchOp o2) + PCADDU18I o1 o2 -> PCADDU18I (patchOp o1) (patchOp o2) + PCALAU12I o1 o2 -> PCALAU12I (patchOp o1) (patchOp o2) + AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3) + OR o1 o2 o3 -> OR (patchOp o1) (patchOp o2) (patchOp o3) + XOR o1 o2 o3 -> XOR (patchOp o1) (patchOp o2) (patchOp o3) + NOR o1 o2 o3 -> NOR (patchOp o1) (patchOp o2) (patchOp o3) + ANDN o1 o2 o3 -> ANDN (patchOp o1) (patchOp o2) (patchOp o3) + ORN o1 o2 o3 -> ORN (patchOp o1) (patchOp o2) (patchOp o3) + MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3) + MULW o1 o2 o3 -> MULW (patchOp o1) (patchOp o2) (patchOp o3) + MULWU o1 o2 o3 -> MULWU (patchOp o1) (patchOp o2) (patchOp o3) + MULH o1 o2 o3 -> MULH (patchOp o1) (patchOp o2) (patchOp o3) + MULHU o1 o2 o3 -> MULHU (patchOp o1) (patchOp o2) (patchOp o3) + DIV o1 o2 o3 -> DIV (patchOp o1) (patchOp o2) (patchOp o3) + MOD o1 o2 o3 -> MOD (patchOp o1) (patchOp o2) (patchOp o3) + DIVU o1 o2 o3 -> DIVU (patchOp o1) (patchOp o2) (patchOp o3) + MODU o1 o2 o3 -> MODU (patchOp o1) (patchOp o2) (patchOp o3) + -- 2. Bit-shift Instructions ------------------------------------------ + SLL o1 o2 o3 -> SLL (patchOp o1) (patchOp o2) (patchOp o3) + SRL o1 o2 o3 -> SRL (patchOp o1) (patchOp o2) (patchOp o3) + SRA o1 o2 o3 -> SRA (patchOp o1) (patchOp o2) (patchOp o3) + ROTR o1 o2 o3 -> ROTR (patchOp o1) (patchOp o2) (patchOp o3) + -- 3. Bit Manipulation Instructions ------------------------------------------ + EXT o1 o2 -> EXT (patchOp o1) (patchOp o2) + CLO o1 o2 -> CLO (patchOp o1) (patchOp o2) + CLZ o1 o2 -> CLZ (patchOp o1) (patchOp o2) + CTO o1 o2 -> CTO (patchOp o1) (patchOp o2) + CTZ o1 o2 -> CTZ (patchOp o1) (patchOp o2) + BYTEPICK o1 o2 o3 o4 -> BYTEPICK (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + REVB2H o1 o2 -> REVB2H (patchOp o1) (patchOp o2) + REVB4H o1 o2 -> REVB4H (patchOp o1) (patchOp o2) + REVB2W o1 o2 -> REVB2W (patchOp o1) (patchOp o2) + REVBD o1 o2 -> REVBD (patchOp o1) (patchOp o2) + REVH2W o1 o2 -> REVH2W (patchOp o1) (patchOp o2) + REVHD o1 o2 -> REVHD (patchOp o1) (patchOp o2) + BITREV4B o1 o2 -> BITREV4B (patchOp o1) (patchOp o2) + BITREV8B o1 o2 -> BITREV8B (patchOp o1) (patchOp o2) + BITREVW o1 o2 -> BITREVW (patchOp o1) (patchOp o2) + BITREVD o1 o2 -> BITREVD (patchOp o1) (patchOp o2) + BSTRINS f o1 o2 o3 o4 -> BSTRINS f (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + BSTRPICK f o1 o2 o3 o4 -> BSTRPICK f (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + MASKEQZ o1 o2 o3 -> MASKEQZ (patchOp o1) (patchOp o2) (patchOp o3) + MASKNEZ o1 o2 o3 -> MASKNEZ (patchOp o1) (patchOp o2) (patchOp o3) + -- + -- Pseudo instrcutions + NOP -> NOP + MOV o1 o2 -> MOV (patchOp o1) (patchOp o2) + NEG o1 o2 -> NEG (patchOp o1) (patchOp o2) + CSET cond o1 o2 o3 -> CSET cond (patchOp o1) (patchOp o2) (patchOp o3) + -- 4. Branch Instructions ---------------------------------------------------- + -- TODO: + J t -> J (patchTarget t) + J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t) + B t -> B (patchTarget t) + BL t ps -> BL (patchTarget t) ps + CALL t ps -> CALL (patchTarget t) ps + CALL36 t -> CALL36 (patchTarget t) + TAIL36 r t -> TAIL36 (patchOp r) (patchTarget t) + BCOND1 c j d t -> BCOND1 c (patchOp j) (patchOp d) (patchTarget t) + BCOND c j d t -> BCOND c (patchOp j) (patchOp d) (patchTarget t) + BEQZ j t -> BEQZ (patchOp j) (patchTarget t) + BNEZ j t -> BNEZ (patchOp j) (patchTarget t) + -- 5. Common Memory Access Instructions -------------------------------------- + -- TODO: + LD f o1 o2 -> LD f (patchOp o1) (patchOp o2) + LDU f o1 o2 -> LDU f (patchOp o1) (patchOp o2) + ST f o1 o2 -> ST f (patchOp o1) (patchOp o2) + LDX f o1 o2 -> LDX f (patchOp o1) (patchOp o2) + LDXU f o1 o2 -> LDXU f (patchOp o1) (patchOp o2) + STX f o1 o2 -> STX f (patchOp o1) (patchOp o2) + LDPTR f o1 o2 -> LDPTR f (patchOp o1) (patchOp o2) + STPTR f o1 o2 -> STPTR f (patchOp o1) (patchOp o2) + PRELD o1 o2 -> PRELD (patchOp o1) (patchOp o2) + -- 6. Bound Check Memory Access Instructions --------------------------------- + -- LDCOND o1 o2 o3 -> LDCOND (patchOp o1) (patchOp o2) (patchOp o3) + -- STCOND o1 o2 o3 -> STCOND (patchOp o1) (patchOp o2) (patchOp o3) + -- 7. Atomic Memory Access Instructions -------------------------------------- + -- 8. Barrier Instructions --------------------------------------------------- + -- TODO: need fix + DBAR o1 -> DBAR o1 + IBAR o1 -> IBAR o1 + -- 11. Floating Point Instructions ------------------------------------------- + FCVT o1 o2 -> FCVT (patchOp o1) (patchOp o2) + SCVTF o1 o2 -> SCVTF (patchOp o1) (patchOp o2) + FCVTZS o1 o2 o3 -> FCVTZS (patchOp o1) (patchOp o2) (patchOp o3) + FMIN o1 o2 o3 -> FMIN (patchOp o1) (patchOp o2) (patchOp o3) + FMAX o1 o2 o3 -> FMAX (patchOp o1) (patchOp o2) (patchOp o3) + FMINA o1 o2 o3 -> FMINA (patchOp o1) (patchOp o2) (patchOp o3) + FMAXA o1 o2 o3 -> FMAXA (patchOp o1) (patchOp o2) (patchOp o3) + FNEG o1 o2 -> FNEG (patchOp o1) (patchOp o2) + FABS o1 o2 -> FABS (patchOp o1) (patchOp o2) + FSQRT o1 o2 -> FSQRT (patchOp o1) (patchOp o2) + FMA s o1 o2 o3 o4 -> FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + + _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr + where + -- TODO: + patchOp :: Operand -> Operand + patchOp (OpReg w r) = OpReg w (env r) + patchOp (OpAddr a) = OpAddr (patchAddr a) + patchOp opImm = opImm + + patchTarget :: Target -> Target + patchTarget (TReg r) = TReg (env r) + patchTarget t = t + + patchAddr :: AddrMode -> AddrMode + patchAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + patchAddr (AddrRegImm r1 imm) = AddrRegImm (env r1) imm + patchAddr (AddrReg r) = AddrReg (env r) + +-------------------------------------------------------------------------------- + +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +isJumpishInstr :: Instr -> Bool +isJumpishInstr instr = case instr of + ANN _ i -> isJumpishInstr i + J {} -> True + J_TBL {} -> True + B {} -> True + BL {} -> True + CALL {} -> True + CALL36 {} -> True + TAIL36 {} -> True + BCOND1 {} -> True + BCOND {} -> True + BEQZ {} -> True + BNEZ {} -> True + _ -> False + +-- | Get the `BlockId`s of the jump destinations (if any) +jumpDestsOfInstr :: Instr -> [BlockId] +jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i +jumpDestsOfInstr (J t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids +jumpDestsOfInstr (B t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BL t _) = [id | TBlock id <- [t]] +jumpDestsOfInstr (CALL t _) = [id | TBlock id <- [t]] +jumpDestsOfInstr (CALL36 t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (TAIL36 _ t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BCOND1 _ _ _ t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BEQZ _ t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BNEZ _ t) = [id | TBlock id <- [t]] +jumpDestsOfInstr _ = [] + +-- | Change the destination of this (potential) jump instruction. +-- Used in the linear allocator when adding fixup blocks for join +-- points. +patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr +patchJumpInstr instr patchF = + case instr of + ANN d i -> ANN d (patchJumpInstr i patchF) + J (TBlock bid) -> J (TBlock (patchF bid)) + J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r + B (TBlock bid) -> B (TBlock (patchF bid)) + BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps + CALL (TBlock bid) ps -> CALL (TBlock (patchF bid)) ps + CALL36 (TBlock bid) -> CALL36 (TBlock (patchF bid)) + TAIL36 r (TBlock bid) -> TAIL36 r (TBlock (patchF bid)) + BCOND1 c o1 o2 (TBlock bid) -> BCOND1 c o1 o2 (TBlock (patchF bid)) + BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid)) + BEQZ j (TBlock bid) -> BEQZ j (TBlock (patchF bid)) + BNEZ j (TBlock bid) -> BNEZ j (TBlock (patchF bid)) + _ -> panic $ "patchJumpInstr: " ++ instrCon instr + +-- ----------------------------------------------------------------------------- +-- | Make a spill instruction, spill a register into spill slot. +mkSpillInstr + :: HasCallStack + => NCGConfig + -> RegWithFormat -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] + +mkSpillInstr _config (RegWithFormat reg _fmt) delta slot = + case off - delta of + imm | fitsInNbits 12 imm -> [mkStrSpImm imm] + imm -> + [ movImmToIp imm, + addSpToIp, + mkStrIp + ] + where + fmt = case reg of + RegReal (RealRegSingle n) | n < 32 -> II64 + _ -> FF64 + mkStrSpImm imm = ANN (text "Spill@" <> int (off - delta)) $ ST fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm))) + movImmToIp imm = ANN (text "Spill: TMP <- " <> int imm) $ MOV tmp (OpImm (ImmInt imm)) + addSpToIp = ANN (text "Spill: TMP <- SP + TMP ") $ ADD tmp tmp sp + mkStrIp = ANN (text "Spill@" <> int (off - delta)) $ ST fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg)) + off = spillSlotToOffset slot + +-- | Make a reload instruction, reload from spill slot to a register. +mkLoadInstr + :: NCGConfig + -> RegWithFormat + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] + +mkLoadInstr _config (RegWithFormat reg _fmt) delta slot = + case off - delta of + imm | fitsInNbits 12 imm -> [mkLdrSpImm imm] + imm -> + [ movImmToIp imm, + addSpToIp, + mkLdrIp + ] + where + fmt = case reg of + RegReal (RealRegSingle n) | n < 32 -> II64 + _ -> FF64 + mkLdrSpImm imm = ANN (text "Reload@" <> int (off - delta)) $ LD fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm))) + movImmToIp imm = ANN (text "Reload: TMP <- " <> int imm) $ MOV tmp (OpImm (ImmInt imm)) + addSpToIp = ANN (text "Reload: TMP <- SP + TMP ") $ ADD tmp tmp sp + mkLdrIp = ANN (text "Reload@" <> int (off - delta)) $ LD fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg)) + off = spillSlotToOffset slot + +-- | See if this instruction is telling us the current C stack delta +takeDeltaInstr :: Instr -> Maybe Int +takeDeltaInstr (ANN _ i) = takeDeltaInstr i +takeDeltaInstr (DELTA i) = Just i +takeDeltaInstr _ = Nothing + +-- | Not real instructions. Just meta data +isMetaInstr :: Instr -> Bool +isMetaInstr instr = + case instr of + ANN _ i -> isMetaInstr i + COMMENT {} -> True + MULTILINE_COMMENT {} -> True + LOCATION {} -> True + NEWBLOCK {} -> True + DELTA {} -> True + LDATA {} -> True + PUSH_STACK_FRAME -> True + POP_STACK_FRAME -> True + _ -> False + +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo insn bid = + case insn of + J (TBlock target) -> bid == target + J_TBL targets _ _ -> all isTargetBid targets + B (TBlock target) -> bid == target + TAIL36 _ (TBlock target) -> bid == target + BCOND1 _ _ _ (TBlock target) -> bid == target + BCOND _ _ _ (TBlock target) -> bid == target + _ -> False + where + isTargetBid target = case target of + Nothing -> True + Just target -> target == bid + +-- | Copy the value in a register to another one. +-- Must work for all register classes. +mkRegRegMoveInstr :: Reg -> Reg -> Instr +mkRegRegMoveInstr src dst = ANN desc instr + where + desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst + instr = MOV (OpReg W64 dst) (OpReg W64 src) + +-- | Take the source and destination from this (potential) reg -> reg move instruction +-- We have to be a bit careful here: A `MOV` can also mean an implicit +-- conversion. This case is filtered out. +takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg) +takeRegRegMoveInstr (MOV (OpReg width dst) (OpReg width' src)) + | width == width' && (isFloatReg dst == isFloatReg src) = pure (src, dst) +takeRegRegMoveInstr _ = Nothing + +-- | Make an unconditional jump instruction. +mkJumpInstr :: BlockId -> [Instr] +mkJumpInstr id = [TAIL36 (OpReg W64 tmpReg) (TBlock (id))] + +-- | Decrement @sp@ to allocate stack space. +mkStackAllocInstr :: Platform -> Int -> [Instr] +mkStackAllocInstr _platform n + | n == 0 = [] + | n > 0 && fitsInNbits 12 (fromIntegral n) = + [ ANN (text "Alloc stack") $ SUB sp sp (OpImm (ImmInt n)) ] + | n > 0 = + [ + ANN (text "Alloc more stack") (MOV tmp (OpImm (ImmInt n))), + SUB sp sp tmp + ] +mkStackAllocInstr _platform n = pprPanic "mkStackAllocInstr" (int n) + +-- | Increment SP to deallocate stack space. +mkStackDeallocInstr :: Platform -> Int -> [Instr] +mkStackDeallocInstr _platform n + | n == 0 = [] + | n > 0 && fitsInNbits 12 (fromIntegral n) = + [ ANN (text "Dealloc stack") $ ADD sp sp (OpImm (ImmInt n)) ] + | n > 0 = + [ + ANN (text "Dealloc more stack") (MOV tmp (OpImm (ImmInt n))), + ADD sp sp tmp + ] +mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n) + +allocMoreStack + :: Platform + -> Int + -> NatCmmDecl statics GHC.CmmToAsm.LA64.Instr.Instr + -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.LA64.Instr.Instr, [(BlockId,BlockId)]) + +allocMoreStack _ _ top@(CmmData _ _) = return (top, []) +allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do + let entries = entryBlocks proc + + retargetList <- mapM (\e -> (e,) <$> newBlockId) entries + + let + delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up + where x = slots * spillSlotSize -- sp delta + + alloc = mkStackAllocInstr platform delta + dealloc = mkStackDeallocInstr platform delta + + new_blockmap :: LabelMap BlockId + new_blockmap = mapFromList retargetList + + insert_stack_insn (BasicBlock id insns) + | Just new_blockid <- mapLookup id new_blockmap = + [ BasicBlock id $ alloc ++ [ B (TBlock new_blockid) ], + BasicBlock new_blockid block' ] + | otherwise = + [ BasicBlock id block' ] + where + block' = foldr insert_dealloc [] insns + + insert_dealloc insn r = case insn of + J {} -> dealloc ++ (insn : r) + ANN _ e -> insert_dealloc e r + _other | jumpDestsOfInstr insn /= [] -> + patchJumpInstr insn retarget : r + _other -> insn : r + + where retarget b = fromMaybe b (mapLookup b new_blockmap) + + new_code = concatMap insert_stack_insn code + return (CmmProc info lbl live (ListGraph new_code), retargetList) + +-- ----------------------------------------------------------------------------- +-- Machine's assembly language + +-- We have a few common "instructions" (nearly all the pseudo-ops) but +-- mostly all of 'Instr' is machine-specific. + +data Instr + -- comment pseudo-op + = COMMENT SDoc + | MULTILINE_COMMENT SDoc + + -- Annotated instruction. Should print # + | ANN SDoc Instr + + -- location pseudo-op (file, line, col, name) + | LOCATION Int Int Int LexicalFastString + + -- start a new basic block. Useful during codegen, removed later. + -- Preceding instruction should be a jump, as per the invariants + -- for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for benefit of subsequent passes. + -- This carries a BlockId so it can be used in unwinding information. + | DELTA Int + + -- | Static data spat out during code generation. + | LDATA Section RawCmmStatics + + | PUSH_STACK_FRAME + | POP_STACK_FRAME + -- Basic Integer Instructions ------------------------------------------------ + -- 1. Arithmetic Instructions ------------------------------------------------ + | ADD Operand Operand Operand + | SUB Operand Operand Operand + | ALSL Operand Operand Operand Operand + | ALSLU Operand Operand Operand Operand + | LU12I Operand Operand + | LU32I Operand Operand + | LU52I Operand Operand Operand + | SSLT Operand Operand Operand + | SSLTU Operand Operand Operand + | PCADDI Operand Operand + | PCADDU12I Operand Operand + | PCADDU18I Operand Operand + | PCALAU12I Operand Operand + | AND Operand Operand Operand + | OR Operand Operand Operand + | XOR Operand Operand Operand + | NOR Operand Operand Operand + | ANDN Operand Operand Operand + | ORN Operand Operand Operand + | MUL Operand Operand Operand + | MULW Operand Operand Operand + | MULWU Operand Operand Operand + | MULH Operand Operand Operand + | MULHU Operand Operand Operand + | DIV Operand Operand Operand + | DIVU Operand Operand Operand + | MOD Operand Operand Operand + | MODU Operand Operand Operand + -- 2. Bit-shift Instuctions -------------------------------------------------- + | SLL Operand Operand Operand + | SRL Operand Operand Operand + | SRA Operand Operand Operand + | ROTR Operand Operand Operand + -- 3. Bit-manupulation Instructions ------------------------------------------ + | EXT Operand Operand + | CLO Operand Operand + | CTO Operand Operand + | CLZ Operand Operand + | CTZ Operand Operand + | BYTEPICK Operand Operand Operand Operand + | REVB2H Operand Operand + | REVB4H Operand Operand + | REVB2W Operand Operand + | REVBD Operand Operand + | REVH2W Operand Operand + | REVHD Operand Operand + | BITREV4B Operand Operand + | BITREV8B Operand Operand + | BITREVW Operand Operand + | BITREVD Operand Operand + | BSTRINS Format Operand Operand Operand Operand + | BSTRPICK Format Operand Operand Operand Operand + | MASKEQZ Operand Operand Operand + | MASKNEZ Operand Operand Operand + -- Pseudo instructions + | NOP + | MOV Operand Operand + | NEG Operand Operand + | CSET Cond Operand Operand Operand + -- 4. Branch Instructions ---------------------------------------------------- + | J Target + | J_TBL [Maybe BlockId] (Maybe CLabel) Reg + | B Target + | BL Target [Reg] + | CALL Target [Reg] + | CALL36 Target + | TAIL36 Operand Target + | BCOND1 Cond Operand Operand Target + | BCOND Cond Operand Operand Target + | BEQZ Operand Target + | BNEZ Operand Target + -- 5. Common Memory Access Instructions -------------------------------------- + | LD Format Operand Operand + | LDU Format Operand Operand + | ST Format Operand Operand + | LDX Format Operand Operand + | LDXU Format Operand Operand + | STX Format Operand Operand + | LDPTR Format Operand Operand + | STPTR Format Operand Operand + | PRELD Operand Operand + -- 6. Bound Check Memory Access Instructions --------------------------------- + -- 7. Atomic Memory Access Instructions -------------------------------------- + -- 8. Barrier Instructions --------------------------------------------------- + | DBAR BarrierType + | IBAR BarrierType + -- Basic Floating Point Instructions ----------------------------------------- + | FCVT Operand Operand + | SCVTF Operand Operand + | FCVTZS Operand Operand Operand + | FMAX Operand Operand Operand + | FMIN Operand Operand Operand + | FMAXA Operand Operand Operand + | FMINA Operand Operand Operand + | FNEG Operand Operand + | FABS Operand Operand + | FSQRT Operand Operand + -- Floating-point fused multiply-add instructions + -- fmadd : d = r1 * r2 + r3 + -- fnmsub: d = r1 * r2 - r3 + -- fmsub : d = - r1 * r2 + r3 + -- fnmadd: d = - r1 * r2 - r3 + | FMA FMASign Operand Operand Operand Operand + +-- TODO: Not complete. +data BarrierType = Hint0 + +instrCon :: Instr -> String +instrCon i = + case i of + COMMENT{} -> "COMMENT" + MULTILINE_COMMENT{} -> "COMMENT" + ANN{} -> "ANN" + LOCATION{} -> "LOCATION" + NEWBLOCK{} -> "NEWBLOCK" + DELTA{} -> "DELTA" + LDATA {} -> "LDATA" + PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME" + POP_STACK_FRAME{} -> "POP_STACK_FRAME" + + ADD{} -> "ADD" + SUB{} -> "SUB" + ALSL{} -> "ALSL" + ALSLU{} -> "ALSLU" + LU12I{} -> "LU12I" + LU32I{} -> "LU32I" + LU52I{} -> "LU52I" + SSLT{} -> "SSLT" + SSLTU{} -> "SSLTU" + PCADDI{} -> "PCADDI" + PCADDU12I{} -> "PCADDU12I" + PCADDU18I{} -> "PCADDU18I" + PCALAU12I{} -> "PCALAU12I" + AND{} -> "AND" + OR{} -> "OR" + XOR{} -> "XOR" + NOR{} -> "NOR" + ANDN{} -> "ANDN" + ORN{} -> "ORN" + MUL{} -> "MUL" + MULW{} -> "MULW" + MULWU{} -> "MULWU" + MULH{} -> "MULH" + MULHU{} -> "MULHU" + DIV{} -> "DIV" + MOD{} -> "MOD" + DIVU{} -> "DIVU" + MODU{} -> "MODU" + SLL{} -> "SLL" + SRL{} -> "SRL" + SRA{} -> "SRA" + ROTR{} -> "ROTR" + EXT{} -> "EXT" + CLO{} -> "CLO" + CLZ{} -> "CLZ" + CTO{} -> "CTO" + CTZ{} -> "CTZ" + BYTEPICK{} -> "BYTEPICK" + REVB2H{} -> "REVB2H" + REVB4H{} -> "REVB4H" + REVB2W{} -> "REVB2W" + REVBD{} -> "REVBD" + REVH2W{} -> "REVH2W" + REVHD{} -> "REVHD" + BITREV4B{} -> "BITREV4B" + BITREV8B{} -> "BITREV8B" + BITREVW{} -> "BITREVW" + BITREVD{} -> "BITREVD" + BSTRINS{} -> "BSTRINS" + BSTRPICK{} -> "BSTRPICK" + MASKEQZ{} -> "MASKEQZ" + MASKNEZ{} -> "MASKNEZ" + NOP{} -> "NOP" + MOV{} -> "MOV" + NEG{} -> "NEG" + CSET{} -> "CSET" + J{} -> "J" + J_TBL{} -> "J_TBL" + B{} -> "B" + BL{} -> "BL" + CALL{} -> "CALL" + CALL36{} -> "CALL36" + TAIL36{} -> "TAIL36" + BCOND1{} -> "BCOND1" + BCOND{} -> "BCOND" + BEQZ{} -> "BEQZ" + BNEZ{} -> "BNEZ" + LD{} -> "LD" + LDU{} -> "LDU" + ST{} -> "ST" + LDX{} -> "LDX" + LDXU{} -> "LDXU" + STX{} -> "STX" + LDPTR{} -> "LDPTR" + STPTR{} -> "STPTR" + PRELD{} -> "PRELD" + DBAR{} -> "DBAR" + IBAR{} -> "IBAR" + FCVT{} -> "FCVT" + SCVTF{} -> "SCVTF" + FCVTZS{} -> "FCVTZS" + FMAX{} -> "FMAX" + FMIN{} -> "FMIN" + FMAXA{} -> "FMAXA" + FMINA{} -> "FMINA" + FNEG{} -> "FNEG" + FABS{} -> "FABS" + FSQRT{} -> "FSQRT" + FMA variant _ _ _ _ -> + case variant of + FMAdd -> "FMADD" + FMSub -> "FMSUB" + FNMAdd -> "FNMADD" + FNMSub -> "FNMSUB" + +data Target + = TBlock BlockId + | TLabel CLabel + | TReg Reg + +data Operand + = OpReg Width Reg -- register + | OpImm Imm -- immediate + | OpAddr AddrMode -- address + deriving (Eq, Show) + +opReg :: Reg -> Operand +opReg = OpReg W64 + +opRegNo :: RegNo -> Operand +opRegNo = opReg . regSingle + +-- LoongArch64 has no ip register in ABI. Here ip register is for spilling/ +-- reloading register to/from slots. So make t8(r20) non-free for ip. +zero, ra, tp, sp, fp, tmp :: Operand +zero = opReg zeroReg +ra = opReg raReg +sp = opReg spMachReg +tp = opReg tpMachReg +fp = opReg fpMachReg +tmp = opReg tmpReg + +x0, x1, x2, x3, x4, x5, x6, x7 :: Operand +x8, x9, x10, x11, x12, x13, x14, x15 :: Operand +x16, x17, x18, x19, x20, x21, x22, x23 :: Operand +x24, x25, x26, x27, x28, x29, x30, x31 :: Operand +x0 = opRegNo 0 +x1 = opRegNo 1 +x2 = opRegNo 2 +x3 = opRegNo 3 +x4 = opRegNo 4 +x5 = opRegNo 5 +x6 = opRegNo 6 +x7 = opRegNo 7 +x8 = opRegNo 8 +x9 = opRegNo 9 +x10 = opRegNo 10 +x11 = opRegNo 11 +x12 = opRegNo 12 +x13 = opRegNo 13 +x14 = opRegNo 14 +x15 = opRegNo 15 +x16 = opRegNo 16 +x17 = opRegNo 17 +x18 = opRegNo 18 +x19 = opRegNo 19 +x20 = opRegNo 20 +x21 = opRegNo 21 +x22 = opRegNo 22 +x23 = opRegNo 23 +x24 = opRegNo 24 +x25 = opRegNo 25 +x26 = opRegNo 26 +x27 = opRegNo 27 +x28 = opRegNo 18 +x29 = opRegNo 29 +x30 = opRegNo 30 +x31 = opRegNo 31 + +d0, d1, d2, d3, d4, d5, d6, d7 :: Operand +d8, d9, d10, d11, d12, d13, d14, d15 :: Operand +d16, d17, d18, d19, d20, d21, d22, d23 :: Operand +d24, d25, d26, d27, d28, d29, d30, d31 :: Operand +d0 = opRegNo 32 +d1 = opRegNo 33 +d2 = opRegNo 34 +d3 = opRegNo 35 +d4 = opRegNo 36 +d5 = opRegNo 37 +d6 = opRegNo 38 +d7 = opRegNo 39 +d8 = opRegNo 40 +d9 = opRegNo 41 +d10 = opRegNo 42 +d11 = opRegNo 43 +d12 = opRegNo 44 +d13 = opRegNo 45 +d14 = opRegNo 46 +d15 = opRegNo 47 +d16 = opRegNo 48 +d17 = opRegNo 49 +d18 = opRegNo 50 +d19 = opRegNo 51 +d20 = opRegNo 52 +d21 = opRegNo 53 +d22 = opRegNo 54 +d23 = opRegNo 55 +d24 = opRegNo 56 +d25 = opRegNo 57 +d26 = opRegNo 58 +d27 = opRegNo 59 +d28 = opRegNo 60 +d29 = opRegNo 61 +d30 = opRegNo 62 +d31 = opRegNo 63 + +fitsInNbits :: Int -> Int -> Bool +fitsInNbits n i = (-1 `shiftL` (n - 1)) <= i && i <= (1 `shiftL` (n - 1) - 1) + +isUnsignOp :: Int -> Bool +isUnsignOp i = (i >= 0) + +isNbitEncodeable :: Int -> Integer -> Bool +isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift) + +isEncodeableInWidth :: Width -> Integer -> Bool +isEncodeableInWidth = isNbitEncodeable . widthInBits + +isIntOp :: Operand -> Bool +isIntOp = not . isFloatOp + +isFloatOp :: Operand -> Bool +isFloatOp (OpReg _ reg) | isFloatReg reg = True +isFloatOp _ = False + +isFloatReg :: Reg -> Bool +isFloatReg (RegReal (RealRegSingle i)) | i > 31 = True +isFloatReg (RegVirtual (VirtualRegD _)) = True +isFloatReg _ = False + +widthToInt :: Width -> Int +widthToInt W8 = 8 +widthToInt W16 = 16 +widthToInt W32 = 32 +widthToInt W64 = 64 +widthToInt _ = 64 + +widthFromOpReg :: Operand -> Width +widthFromOpReg (OpReg W8 _) = W8 +widthFromOpReg (OpReg W16 _) = W16 +widthFromOpReg (OpReg W32 _) = W32 +widthFromOpReg (OpReg W64 _) = W64 +widthFromOpReg _ = W64 + +ldFormat :: Format -> Format +ldFormat f + | f `elem` [II8, II16, II32, II64] = II64 + | f `elem` [FF32, FF64] = FF64 + | otherwise = pprPanic "unsupported ldFormat: " (text $ show f) diff --git a/GHC/CmmToAsm/LA64/Ppr.hs b/GHC/CmmToAsm/LA64/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/Ppr.hs @@ -0,0 +1,1149 @@ +module GHC.CmmToAsm.LA64.Ppr (pprNatCmmDecl, pprInstr) where + +import GHC.Prelude hiding (EQ) + +import GHC.CmmToAsm.LA64.Regs +import GHC.CmmToAsm.LA64.Instr +import GHC.CmmToAsm.LA64.Cond +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Ppr +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils +import GHC.Cmm hiding (topInfoTable) +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Label +import GHC.Platform +import GHC.Platform.Reg +import GHC.Types.Unique ( pprUniqueAlways, getUnique ) +import GHC.Utils.Outputable +import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment) +import GHC.Utils.Panic + +pprNatCmmDecl :: forall doc. (IsDoc doc) => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc + +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section $$ pprDatas config dats + +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config + + pprProcAlignment :: doc + pprProcAlignment = maybe empty (pprAlign . mkAlignment) (ncgProcAlignment config) + in pprProcAlignment + $$ case topInfoTable proc of + Nothing -> + -- special case for code without info table: + pprSectionAlign config (Section Text lbl) + $$ + -- do not + -- pprProcAlignment config $$ + pprLabel platform lbl + $$ vcat (map (pprBasicBlock config top_info) blocks) -- blocks guaranteed not null, so label needed + $$ ppWhen + (ncgDwarfEnabled config) + (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl)) + $$ pprSizeDecl platform lbl + Just (CmmStaticsRaw info_lbl _) -> + pprSectionAlign config (Section Text info_lbl) + $$ + -- pprProcAlignment config $$ + ( if platformHasSubsectionsViaSymbols platform + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':') + else empty + ) + $$ vcat (map (pprBasicBlock config top_info) blocks) + $$ ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl)) + $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + ( if platformHasSubsectionsViaSymbols platform + then -- See Note [Subsections Via Symbols] + + line + $ text "\t.long " + <+> pprAsmLabel platform info_lbl + <+> char '-' + <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl) + else empty + ) + $$ pprSizeDecl platform info_lbl +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-} +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure + -> doc +pprProcEndLabel platform lbl = + pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon + +pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name + -> doc +pprBlockEndLabel platform lbl = + pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon + +pprLabel :: IsDoc doc => Platform -> CLabel -> doc +pprLabel platform lbl = + pprGloblDecl platform lbl + $$ pprTypeDecl platform lbl + $$ line (pprAsmLabel platform lbl <> char ':') + +pprAlign :: (IsDoc doc) => Alignment -> doc +pprAlign alignment = + -- .balign is stable, whereas .align is platform dependent. + line $ text "\t.balign " <> int (alignmentBytes alignment) + +-- | Print appropriate alignment for the given section type. +-- +-- Currently, this always aligns to a full machine word (8 byte.) A future +-- improvement could be to really do this per section type (though, it's +-- probably not a big gain.) +pprAlignForSection :: (IsDoc doc) => SectionType -> doc +pprAlignForSection _seg = pprAlign . mkAlignment $ 8 + +-- Print section header and appropriate alignment for that section. +-- This will e.g. emit a header like: +-- +-- .section .text +-- .balign 8 +-- +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc +pprSectionAlign _config (Section (OtherSection _) _) = + panic "LA64.Ppr.pprSectionAlign: unknown section" +pprSectionAlign config sec@(Section seg _) = + line (pprSectionHeader config sec) + $$ pprAlignForSection seg + +-- | Output the ELF .size directive +pprSizeDecl :: (IsDoc doc) => Platform -> CLabel -> doc +pprSizeDecl platform lbl + | osElfTarget (platformOS platform) = + line $ text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl +pprSizeDecl _ _ = empty + +pprBasicBlock :: + (IsDoc doc) => + NCGConfig -> + LabelMap RawCmmStatics -> + NatBasicBlock Instr -> + doc + +pprBasicBlock config info_env (BasicBlock blockid instrs) + = maybe_infotable $ + pprLabel platform asmLbl $$ + vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$ + ppWhen (ncgDwarfEnabled config) ( + -- Emit both end labels since this may end up being a standalone + -- top-level block + line (pprBlockEndLabel platform asmLbl + <> pprProcEndLabel platform asmLbl) + ) + where + -- Filter out identity moves. E.g. mov x18, x18 will be dropped. + optInstrs = filter f instrs + where f (MOV o1 o2) | o1 == o2 = False + f _ = True + + asmLbl = blockLbl blockid + platform = ncgPlatform config + maybe_infotable c = case mapLookup blockid info_env of + Nothing -> c + Just (CmmStaticsRaw info_lbl info) -> + -- pprAlignForSection platform Text $$ + infoTableLoc $$ + vcat (map (pprData config) info) $$ + pprLabel platform info_lbl $$ + c $$ + ppWhen (ncgDwarfEnabled config) + (line (pprBlockEndLabel platform info_lbl)) + -- Make sure the info table has the right .loc for the block + -- coming right after it. See Note [Info Offset] + infoTableLoc = case instrs of + (l@LOCATION{} : _) -> pprInstr platform l + _other -> empty + +pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc +-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' + = pprGloblDecl (ncgPlatform config) alias + $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind') + +pprDatas config (CmmStaticsRaw lbl dats) + = vcat (pprLabel platform lbl : map (pprData config) dats) + where + platform = ncgPlatform config + +pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc +pprData _config (CmmString str) = line (pprString str) +pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path) + +pprData config (CmmUninitialised bytes) + = line $ let platform = ncgPlatform config + in if platformOS platform == OSDarwin + then text ".space " <> int bytes + else text ".skip " <> int bytes + +pprData config (CmmStaticLit lit) = pprDataItem config lit + +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc +pprGloblDecl platform lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl) + +-- Always use objects for info tables +-- +-- See discussion in X86.Ppr for why this is necessary. Essentially we need to +-- ensure that we never pass function symbols when we might want to lookup the +-- info table. If we did, we could end up with procedure linking tables +-- (PLT)s, and thus the lookup wouldn't point to the function, but into the +-- jump table. +-- +-- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as +-- well. +pprLabelType' :: IsLine doc => Platform -> CLabel -> doc +pprLabelType' platform lbl = + if isCFunctionLabel lbl || functionOkInfoTable + then text "@function" + else text "@object" + where + functionOkInfoTable = platformTablesNextToCode platform && + isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl) + +-- this is called pprTypeAndSizeDecl in PPC.Ppr +pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc +pprTypeDecl platform lbl + = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) + else empty + +pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc +pprDataItem config lit + = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + where + platform = ncgPlatform config + + imm = litToImm lit + + ppr_item II8 _ = [text "\t.byte\t" <> pprDataImm platform imm] + ppr_item II16 _ = [text "\t.short\t" <> pprDataImm platform imm] + ppr_item II32 _ = [text "\t.long\t" <> pprDataImm platform imm] + ppr_item II64 _ = [text "\t.quad\t" <> pprDataImm platform imm] + + ppr_item FF32 (CmmFloat r _) + = let bs = floatToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs + + ppr_item FF64 (CmmFloat r _) + = let bs = doubleToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs + + ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit) + +-- | Pretty print an immediate value in the @data@ section +-- This does not include any checks. We rely on the Assembler to check for +-- errors. Use `pprOpImm` for immediates in instructions (operands.) +pprDataImm :: IsLine doc => Platform -> Imm -> doc +pprDataImm _ (ImmInt i) = int i +pprDataImm _ (ImmInteger i) = integer i +pprDataImm p (ImmCLbl l) = pprAsmLabel p l +pprDataImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i +pprDataImm _ (ImmLit s) = ftext s +pprDataImm _ (ImmFloat f) = float (fromRational f) +pprDataImm _ (ImmDouble d) = double (fromRational d) + +pprDataImm p (ImmConstantSum a b) = pprDataImm p a <> char '+' <> pprDataImm p b +pprDataImm p (ImmConstantDiff a b) = pprDataImm p a <> char '-' + <> lparen <> pprDataImm p b <> rparen + +asmComment :: SDoc -> SDoc +asmComment c = text "#" <+> c + +asmDoubleslashComment :: SDoc -> SDoc +asmDoubleslashComment c = text "//" <+> c + +asmMultilineComment :: SDoc -> SDoc +asmMultilineComment c = text "/*" $+$ c $+$ text "*/" + +-- | Pretty print an immediate operand of an instruction +pprOpImm :: (IsLine doc) => Platform -> Imm -> doc +pprOpImm platform imm = case imm of + ImmInt i -> int i + ImmInteger i -> integer i + ImmCLbl l -> char '=' <> pprAsmLabel platform l + ImmFloat f -> float (fromRational f) + ImmDouble d -> double (fromRational d) + _ -> pprPanic "LA64.Ppr.pprOpImm" (text "Unsupported immediate for instruction operands:" <+> (text . show) imm) + +negOp :: Operand -> Operand +negOp (OpImm (ImmInt i)) = OpImm (ImmInt (negate i)) +negOp (OpImm (ImmInteger i)) = OpImm (ImmInteger (negate i)) +negOp op = pprPanic "LA64.negOp" (text $ show op) + +pprOp :: IsLine doc => Platform -> Operand -> doc +pprOp plat op = case op of + OpReg w r -> pprReg w r + OpImm imm -> pprOpImm plat imm + OpAddr (AddrRegReg r1 r2) -> pprReg W64 r1 <> comma <+> pprReg W64 r2 + OpAddr (AddrRegImm r imm) -> pprReg W64 r <> comma <+> pprOpImm plat imm + OpAddr (AddrReg r) -> pprReg W64 r <+> text ", 0" + +pprReg :: forall doc. IsLine doc => Width -> Reg -> doc +pprReg w r = case r of + RegReal (RealRegSingle i) -> ppr_reg_no i + -- virtual regs should not show up, but this is helpful for debugging. + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u + -- RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u + _ -> pprPanic "LA64.pprReg" (text (show r) <+> ppr w) + + where + ppr_reg_no :: Int -> doc + -- LoongArch's registers must be started from `$[fr]` + -- General Purpose Registers + ppr_reg_no 0 = text "$zero" + ppr_reg_no 1 = text "$ra" + ppr_reg_no 2 = text "$tp" + ppr_reg_no 3 = text "$sp" + ppr_reg_no 4 = text "$a0" + ppr_reg_no 5 = text "$a1" + ppr_reg_no 6 = text "$a2" + ppr_reg_no 7 = text "$a3" + ppr_reg_no 8 = text "$a4" + ppr_reg_no 9 = text "$a5" + ppr_reg_no 10 = text "$a6" + ppr_reg_no 11 = text "$a7" + ppr_reg_no 12 = text "$t0" + ppr_reg_no 13 = text "$t1" + ppr_reg_no 14 = text "$t2" + ppr_reg_no 15 = text "$t3" + ppr_reg_no 16 = text "$t4" + ppr_reg_no 17 = text "$t5" + ppr_reg_no 18 = text "$t6" + ppr_reg_no 19 = text "$t7" + ppr_reg_no 20 = text "$t8" + ppr_reg_no 21 = text "$u0" -- Reserverd + ppr_reg_no 22 = text "$fp" + ppr_reg_no 23 = text "$s0" + ppr_reg_no 24 = text "$s1" + ppr_reg_no 25 = text "$s2" + ppr_reg_no 26 = text "$s3" + ppr_reg_no 27 = text "$s4" + ppr_reg_no 28 = text "$s5" + ppr_reg_no 29 = text "$s6" + ppr_reg_no 30 = text "$s7" + ppr_reg_no 31 = text "$s8" + + -- Floating Point Registers + ppr_reg_no 32 = text "$fa0" + ppr_reg_no 33 = text "$fa1" + ppr_reg_no 34 = text "$fa2" + ppr_reg_no 35 = text "$fa3" + ppr_reg_no 36 = text "$fa4" + ppr_reg_no 37 = text "$fa5" + ppr_reg_no 38 = text "$fa6" + ppr_reg_no 39 = text "$fa7" + ppr_reg_no 40 = text "$ft0" + ppr_reg_no 41 = text "$ft1" + ppr_reg_no 42 = text "$ft2" + ppr_reg_no 43 = text "$ft3" + ppr_reg_no 44 = text "$ft4" + ppr_reg_no 45 = text "$ft5" + ppr_reg_no 46 = text "$ft6" + ppr_reg_no 47 = text "$ft7" + ppr_reg_no 48 = text "$ft8" + ppr_reg_no 49 = text "$ft9" + ppr_reg_no 50 = text "$ft10" + ppr_reg_no 51 = text "$ft11" + ppr_reg_no 52 = text "$ft12" + ppr_reg_no 53 = text "$ft13" + ppr_reg_no 54 = text "$ft14" + ppr_reg_no 55 = text "$ft15" + ppr_reg_no 56 = text "$fs0" + ppr_reg_no 57 = text "$fs1" + ppr_reg_no 58 = text "$fs2" + ppr_reg_no 59 = text "$fs3" + ppr_reg_no 60 = text "$fs4" + ppr_reg_no 61 = text "$fs5" + ppr_reg_no 62 = text "$fs6" + ppr_reg_no 63 = text "$fs7" + + ppr_reg_no i + | i < 0 = pprPanic "Unexpected register number (min is 0)" (ppr w <+> int i) + | i > 63 = pprPanic "Unexpected register number (max is 63)" (ppr w <+> int i) + -- no support for widths > W64. + | otherwise = pprPanic "Unsupported width in register (max is 64)" (ppr w <+> int i) + +-- | Single precission `Operand` (floating-point) +isSingleOp :: Operand -> Bool +isSingleOp (OpReg W32 _) = True +isSingleOp _ = False + +-- | Double precission `Operand` (floating-point) +isDoubleOp :: Operand -> Bool +isDoubleOp (OpReg W64 _) = True +isDoubleOp _ = False + +-- | `Operand` is an immediate value +isImmOp :: Operand -> Bool +isImmOp (OpImm _) = True +isImmOp _ = False + +-- | `Operand` is an immediate @0@ value +isImmZero :: Operand -> Bool +isImmZero (OpImm (ImmFloat 0)) = True +isImmZero (OpImm (ImmDouble 0)) = True +isImmZero (OpImm (ImmInt 0)) = True +isImmZero _ = False + +pprInstr :: IsDoc doc => Platform -> Instr -> doc +pprInstr platform instr = case instr of + -- Meta Instructions --------------------------------------------------------- + -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable + COMMENT s -> dualDoc (asmComment s) empty + MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty + ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i) + + LOCATION file line' col _name + -> line (text "\t.loc" <+> int file <+> int line' <+> int col) + DELTA d -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty + NEWBLOCK _ -> panic "PprInstr: NEWBLOCK" + LDATA _ _ -> panic "PprInstr: NEWBLOCK" + + -- Pseudo Instructions ------------------------------------------------------- + + PUSH_STACK_FRAME -> lines_ [ text "\taddi.d $sp, $sp, -16" + , text "\tst.d $ra, $sp, 8" + , text "\tst.d $fp, $sp, 0" + , text "\taddi.d $fp, $sp, 16" + ] + + POP_STACK_FRAME -> lines_ [ text "\tld.d $fp, $sp, 0" + , text "\tld.d $ra, $sp, 8" + , text "\taddi.d $sp, $sp, 16" + ] + + + -- =========================================================================== + -- LoongArch64 Instruction Set + -- Basic Integer Instructions ------------------------------------------------ + -- 1. Arithmetic Instructions ------------------------------------------------ + -- ADD.{W/D}, SUB.{W/D} + -- ADDI.{W/D}, ADDU16I.D + ADD o1 o2 o3 + | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfadd.s") o1 o2 o3 + | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfadd.d") o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tadd.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tadd.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 o3 + | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: ADD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- TODO: Not complete. + -- Here we should add addu16i.d for optimizations of accelerating GOT accession + -- with ldptr.w/d, stptr.w/d + SUB o1 o2 o3 + | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfsub.s") o1 o2 o3 + | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfsub.d") o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsub.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsub.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 (negOp o3) + | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 (negOp o3) + | otherwise -> pprPanic "LA64.ppr: SUB error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- ALSL.{W[U]/D} + ALSL o1 o2 o3 o4 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3, isImmOp o4 -> op4 (text "\talsl.w") o1 o2 o3 o4 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3, isImmOp o4 -> op4 (text "\talsl.d") o1 o2 o3 o4 + | otherwise -> pprPanic "LA64.ppr: ALSL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + ALSLU o1 o2 o3 o4 -> op4 (text "\talsl.wu") o1 o2 o3 o4 + -- LoongArch-Assembler should implement following pesudo instructions, here we can directly use them. + -- li.w rd, s32 + -- li.w rd, u32 + -- li.d rd, s64 + -- li.d rd, u64 + -- + -- # Load with one instruction + -- ori dst, $zero, imm[11:0] + -- + -- # Load with two instructions + -- lu12i.w dst, imm[31:12] + -- ori dst, dst, imm[11:0] + -- + -- # Load with four instructions + -- lu12i.w dst, imm[31:12] + -- ori dst, dst, imm[11:0] + -- lu32i.d dst, imm[51:32] + -- lu52i.d dst, dst, imm[63:52] + + -- -- LU12I.W, LU32I.D, LU52I.D + LU12I o1 o2 -> op2 (text "\tlu12i.w") o1 o2 + LU32I o1 o2 -> op2 (text "\tlu32i.d") o1 o2 + LU52I o1 o2 o3 -> op3 (text "\tlu52i.d") o1 o2 o3 + -- SSLT[U] + -- SSLT[U]I + SSLT o1 o2 o3 + | isImmOp o3 -> op3 (text "\tslti") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tslt") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: SSLT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + SSLTU o1 o2 o3 + | isImmOp o3 -> op3 (text "\tsltui") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsltu") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: SSLTU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- PCADDI, PCADDU121, PCADDU18l, PCALAU12I + PCADDI o1 o2 -> op2 (text "\tpcaddi") o1 o2 + PCADDU12I o1 o2 -> op2 (text "\tpcaddu12i") o1 o2 + PCADDU18I o1 (OpImm (ImmCLbl lbl)) -> + lines_ [ + text "\tpcaddu18i" <+> pprOp platform o1 <> comma <+> text "%call36(" <+> pprAsmLabel platform lbl <+> text ")" + ] + PCALAU12I o1 o2 -> op2 (text "\tpcalau12i") o1 o2 + -- AND, OR, NOR, XOR, ANDN, ORN + -- ANDI, ORI, XORI: zero-extention + AND o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tand") o1 o2 o3 + | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tandi") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: AND error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + OR o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tor") o1 o2 o3 + | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tori") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: OR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + XOR o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\txor") o1 o2 o3 + | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\txori") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: XOR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + NOR o1 o2 o3 -> op3 (text "\tnor") o1 o2 o3 + ANDN o1 o2 o3 -> op3 (text "\tandn") o1 o2 o3 + ORN o1 o2 o3 -> op3 (text "\torn") o1 o2 o3 + + ----------------------------------------------------------------------------- + -- Pseudo instructions + -- NOP, alias for "andi r0, r0, r0" + NOP -> line $ text "\tnop" + -- NEG o1 o2, alias for "sub o1, r0, o2" + NEG o1 o2 + | isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2 + | isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2 + | OpReg W32 _ <- o2 -> op3 (text "\tsub.w" ) o1 zero o2 + | OpReg W64 _ <- o2 -> op3 (text "\tsub.d" ) o1 zero o2 + | otherwise -> pprPanic "LA64.ppr: NEG error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + -- Here we can do more simplitcations. + -- To be honest, floating point instructions are too scarce, so maybe + -- we should reimplement some pseudo instructions with others. + MOV o1 o2 + | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> op2 (text "\tfmov.s") o1 o2 + | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> op2 (text "\tfmov.d") o1 o2 + | isFloatOp o1 && isImmZero o2 && isSingleOp o1 -> op2 (text "\tmovgr2fr.w") o1 zero + | isFloatOp o1 && isImmZero o2 && isDoubleOp o1 -> op2 (text "\tmovgr2fr.d") o1 zero + | isFloatOp o1 && not (isFloatOp o2) && isSingleOp o1 -> op2 (text "\tmovgr2fr.w") o1 o2 + | isFloatOp o1 && not (isFloatOp o2) && isDoubleOp o1 -> op2 (text "\tmovgr2fr.d") o1 o2 + | not (isFloatOp o1) && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tmovfr2gr.s") o1 o2 + | not (isFloatOp o1) && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tmovfr2gr.d") o1 o2 + | isImmOp o2, (OpImm (ImmInt i)) <- o2, fitsInNbits 12 (fromIntegral i) -> + lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2] + | isImmOp o2, (OpImm (ImmInteger i)) <- o2, fitsInNbits 12 (fromIntegral i) -> + lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2] + | OpReg W64 _ <- o2 -> op2 (text "\tmove") o1 o2 + | OpReg _ _ <- o2 -> + lines_ [ + text "\tbstrpick.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform (OpImm (ImmInt ((widthToInt (min (widthFromOpReg o1) (widthFromOpReg o2))) - 1))) <+> text ", 0" + ] + -- TODO: Maybe we can do more. + -- Let the assembler do these concret things. + | isImmOp o2 -> + lines_ [text "\tli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2] + | otherwise -> pprPanic "LA64.ppr: MOV error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + + -- CSET pesudo instrcutions implementation + CSET cond dst o1 o2 -> case cond of + -- SEQ dst, rd, rs -> [SUB rd, rd, rs; sltui dst, rd, 1] + EQ | isIntOp o1 && isIntOp o2 -> + lines_ [ + subFor o1 o2, + text "\tsltui" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1)) + ] + EQ | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.seq.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + EQ | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.seq.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + -- SNE rd, rs -> [SUB rd, rd, rs; sltu rd, zero, rs] + NE | isIntOp o1 && isIntOp o2 -> + lines_ [ + subFor o1 o2, + text "\tsltu" <+> pprOp platform dst <> comma <+> text "$r0" <+> comma <+> pprOp platform dst + ] + NE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.cune.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + NE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.cune.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + SLT -> lines_ [ sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 ] + -- SLE rd, rs -> [SLT rd, rs; xori rd, rs, o1] + SLE -> + lines_ [ + sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\txori" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1)) + ] + -- SGE rd, rs -> [SLT rd, rs; xori rd, rs, o1] + SGE -> + lines_ [ + sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\txori" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1)) + ] + -- SGT rd, rs -> [SLT rd, rs] + SGT -> lines_ [ sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1 ] + + ULT -> lines_ [ sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 ] + ULE -> + lines_ [ + sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\txori" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1)) + ] + -- UGE rd, rs -> [SLTU rd, rs; xori rd, rs, 1] + UGE -> + lines_ [ + sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\txori" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1)) + ] + -- SGTU rd, rs -> [SLTU rd, rs] + UGT -> lines_ [ sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1 ] + + -- TODO: + -- LoongArch's floating point instrcutions don't write the compared result to an interger register, instead of cc. + -- Fcond dst o1 o2 -> [fcmp.cond.[s/d] fcc0 o1 o2; movcf2gr dst, fcc0] + FLT | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.slt.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FLE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.sle.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FGT | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.slt.d $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FGE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.sle.d $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + + FLT | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.slt.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FLE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.sle.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FGT | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.slt.s $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FGE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.sle.s $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + + _ -> pprPanic "LA64.ppr: CSET error: " (pprCond cond <+> pprOp platform dst <> comma <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + + where + subFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2 = + text "\taddi.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform (negOp o2) + | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = + text "\tsub.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 + | otherwise = pprPanic "LA64.ppr: unknown subFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + + sltFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2 = text "\tslti" + | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tslt" + | otherwise = pprPanic "LA64.ppr: unknown sltFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + + sltuFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2 = text "\tsltui" + | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tsltu" + | otherwise = pprPanic "LA64.ppr: unknown sltuFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + + -- MUL.{W/D}, MULH, {W[U]/D[U]}, 'h' means high 32bit. + -- MULW.D.W[U] + MUL o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfmul.s") o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfmul.d") o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmul.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmul.d") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MUL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MULW o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.w") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MULW error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MULWU o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.wu") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MULWU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MULH o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o2 -> op3 (text "\tmulh.d") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MULH error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MULHU o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.wu") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmulh.du") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MULHU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- DIV.{W[U]/D[U]}, MOD.{W[U]/D[U]} + DIV o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfdiv.s") o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfdiv.d") o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.d") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: DIV error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + DIVU o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.wu") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.du") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: DIVU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MOD o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.d") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MOD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MODU o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.wu") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.du") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MODU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- 2. Bit-shift Instuctions -------------------------------------------------- + -- SLL.W, SRL.W, SRA.W, ROTR.W + -- SLL.D, SRL.D, SRA.D, ROTR.D + -- SLLI.W, SRLI.W, SRAI.W, ROTRI.W + -- SLLI.D, SRLI.D, SRAI.D, ROTRI.D + SLL o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsll.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsll.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> + lines_ [text "\tslli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | OpReg W64 _ <- o2, isImmOp o3 -> + lines_ [text "\tslli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | otherwise -> pprPanic "LA64.ppr: SLL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + SRL o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsrl.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsrl.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> + lines_ [text "\tsrli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | OpReg W64 _ <- o2, isImmOp o3 -> + lines_ [text "\tsrli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | otherwise -> pprPanic "LA64.ppr: SRL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + SRA o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsra.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsra.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> + lines_ [text "\tsrai.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | OpReg W64 _ <- o2, isImmOp o3 -> + lines_ [text "\tsrai.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | otherwise -> pprPanic "LA64.ppr: SRA error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + ROTR o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\trotr.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\trotr.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> + lines_ [text "\trotri.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | OpReg W64 _ <- o2, isImmOp o3 -> + lines_ [text "\trotri.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | otherwise -> pprPanic "LA64.ppr: ROTR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- 3. Bit-manupulation Instructions ------------------------------------------ + -- EXT.W{B/H} + EXT o1 o2 + | OpReg W8 _ <- o2 -> op2 (text "\text.w.b") o1 o2 + | OpReg W16 _ <- o2 -> op2 (text "\text.w.h") o1 o2 + | otherwise -> pprPanic "LA64.ppr: EXT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + -- CL{O/Z}.{W/D}, CT{O/Z}.{W/D} + CLO o1 o2 + | OpReg W32 _ <- o2 -> op2 (text "\tclo.w") o1 o2 + | OpReg W64 _ <- o2 -> op2 (text "\tclo.d") o1 o2 + | otherwise -> pprPanic "LA64.ppr: CLO error" (pprOp platform o1 <+> pprOp platform o2) + CLZ o1 o2 + | OpReg W32 _ <- o2 -> op2 (text "\tclz.w") o1 o2 + | OpReg W64 _ <- o2 -> op2 (text "\tclz.d") o1 o2 + | otherwise -> pprPanic "LA64.ppr: CLZ error" (pprOp platform o1 <+> pprOp platform o2) + CTO o1 o2 + | OpReg W32 _ <- o2 -> op2 (text "\tcto.w") o1 o2 + | OpReg W64 _ <- o2 -> op2 (text "\tcto.d") o1 o2 + | otherwise -> pprPanic "LA64.ppr: CTO error" (pprOp platform o1 <+> pprOp platform o2) + CTZ o1 o2 + | OpReg W32 _ <- o2 -> op2 (text "\tctz.w") o1 o2 + | OpReg W64 _ <- o2 -> op2 (text "\tctz.d") o1 o2 + | otherwise -> pprPanic "LA64.ppr: CTZ error" (pprOp platform o1 <+> pprOp platform o2) + -- BYTEPICK.{W/D} rd, rj, rk, sa2/sa3 + BYTEPICK o1 o2 o3 o4 + | OpReg W32 _ <- o2 -> op4 (text "\tbytepick.w") o1 o2 o3 o4 + | OpReg W64 _ <- o2 -> op4 (text "\tbytepick.d") o1 o2 o3 o4 + | otherwise -> pprPanic "LA64.ppr: BYTEPICK error" (pprOp platform o1 <+> pprOp platform o2 <+> pprOp platform o3 <+> pprOp platform o4) + -- REVB.{2H/4H/2W/D} + REVB2H o1 o2 -> op2 (text "\trevb.2h") o1 o2 + REVB4H o1 o2 -> op2 (text "\trevb.4h") o1 o2 + REVB2W o1 o2 -> op2 (text "\trevb.2w") o1 o2 + REVBD o1 o2 -> op2 (text "\trevb.d") o1 o2 + -- REVH.{2W/D} + REVH2W o1 o2 -> op2 (text "\trevh.2w") o1 o2 + REVHD o1 o2 -> op2 (text "\trevh.d") o1 o2 + -- BITREV.{4B/8B} + -- BITREV.{W/D} + BITREV4B o1 o2 -> op2 (text "\tbitrev.4b") o1 o2 + BITREV8B o1 o2 -> op2 (text "\tbitrev.8b") o1 o2 + BITREVW o1 o2 -> op2 (text "\tbitrev.w") o1 o2 + BITREVD o1 o2 -> op2 (text "\tbitrev.d") o1 o2 + -- BSTRINS.{W/D} + BSTRINS II64 o1 o2 o3 o4 -> op4 (text "\tbstrins.d") o1 o2 o3 o4 + BSTRINS II32 o1 o2 o3 o4 -> op4 (text "\tbstrins.w") o1 o2 o3 o4 + -- BSTRPICK.{W/D} + BSTRPICK II64 o1 o2 o3 o4 -> op4 (text "\tbstrpick.d") o1 o2 o3 o4 + BSTRPICK II32 o1 o2 o3 o4 -> op4 (text "\tbstrpick.w") o1 o2 o3 o4 + -- MASKEQZ rd, rj, rk: if rk == 0 ? rd = 0 : rd = rj + MASKEQZ o1 o2 o3 -> op3 (text "\tmaskeqz") o1 o2 o3 + -- MASKNEZ: if rk == 0 ? rd = 0 : rd = rj + MASKNEZ o1 o2 o3 -> op3 (text "\tmasknez") o1 o2 o3 + -- 4. Branch Instructions ---------------------------------------------------- + -- BEQ, BNE, BLT[U], BGE[U] rj, rd, off16 + -- BEQZ, BNEZ rj, off21 + -- B + -- BL + -- JIRL + -- jr rd = jirl $zero, rd, 0: Commonly used for subroutine return. + J (TReg r) -> line $ text "\tjirl" <+> text "$r0" <> comma <+> pprReg W64 r <> comma <+> text " 0" + J_TBL _ _ r -> pprInstr platform (B (TReg r)) + + B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl + B (TReg r) -> line $ text "\tjr" <+> pprReg W64 r + + BL (TBlock bid) _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BL (TLabel lbl) _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl + BL (TReg r) _ -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0" + + CALL (TBlock bid) _ -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + CALL (TLabel lbl) _ -> line $ text "\tcall36" <+> pprAsmLabel platform lbl + CALL (TReg r) _ -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0" + + CALL36 (TBlock bid) -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + CALL36 (TLabel lbl) -> line $ text "\tcall36" <+> pprAsmLabel platform lbl + CALL36 _ -> panic "LA64.ppr: CALL36: Not to registers!" + TAIL36 r (TBlock bid) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + TAIL36 r (TLabel lbl) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform lbl + TAIL36 _ _ -> panic "LA64.ppr: TAIL36: Not to registers!" + + BCOND1 c j d (TBlock bid) -> case c of + SLE -> + line $ text "\tbge" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + SGT -> + line $ text "\tblt" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ULE -> + line $ text "\tbgeu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + UGT -> + line $ text "\tbltu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + _ -> line $ text "\t" <> pprBcond c <+> pprOp platform j <> comma <+> pprOp platform d <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + + BCOND1 _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND1: No conditional branching to TLabel!" + + BCOND1 _ _ _ (TReg _) -> panic "LA64.ppr: BCOND1: No conditional branching to registers!" + + -- Reuse t8(IP) register + BCOND c j d (TBlock bid) -> case c of + SLE -> + lines_ [ + text "\tslt $t8, " <+> pprOp platform d <> comma <+> pprOp platform j, + text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + SGT -> + lines_ [ + text "\tslt $t8, " <+> pprOp platform d <> comma <+> pprOp platform j, + text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + ULE -> + lines_ [ + text "\tsltu $t8, " <+> pprOp platform d <> comma <+> pprOp platform j, + text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + UGT -> + lines_ [ + text "\tsltu $t8, " <+> pprOp platform d <> comma <+> pprOp platform j, + text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + EQ -> + lines_ [ + text "\tsub.d $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + NE -> + lines_ [ + text "\tsub.d $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + SLT -> + lines_ [ + text "\tslt $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + SGE -> + lines_ [ + text "\tslt $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + ULT -> + lines_ [ + text "\tsltu $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + UGE -> + lines_ [ + text "\tsltu $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + _ -> panic "LA64.ppr: BCOND: Unsupported cond!" + + BCOND _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND: No conditional branching to TLabel!" + + BCOND _ _ _ (TReg _) -> panic "LA64.ppr: BCOND: No conditional branching to registers!" + + BEQZ j (TBlock bid) -> + line $ text "\tbeqz" <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BEQZ j (TLabel lbl) -> + line $ text "\tbeqz" <+> pprOp platform j <> comma <+> pprAsmLabel platform lbl + BEQZ _ (TReg _) -> panic "LA64.ppr: BEQZ: No conditional branching to registers!" + + BNEZ j (TBlock bid) -> + line $ text "\tbnez" <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BNEZ j (TLabel lbl) -> + line $ text "\tbnez" <+> pprOp platform j <> comma <+> pprAsmLabel platform lbl + BNEZ _ (TReg _) -> panic "LA64.ppr: BNEZ: No conditional branching to registers!" + + -- 5. Common Memory Access Instructions -------------------------------------- + -- LD.{B[U]/H[U]/W[U]/D}, ST.{B/H/W/D}: AddrRegImm + -- LD: load, ST: store, x: offset in register, u: load unsigned imm. + -- LD format dst src: 'src' means final address, not single register or immdiate. + -- Load symbol's address + LD _fmt o1 (OpImm (ImmIndex lbl' off)) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off + ] + LD _fmt o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off + ] + LD _fmt o1 (OpImm (ImmIndex lbl off)) -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off + ] + + LD _fmt o1 (OpImm (ImmCLbl lbl')) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + ] + LD _fmt o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + ] + LD _fmt o1 (OpImm (ImmCLbl lbl)) -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + ] + + LD II8 o1 o2 -> op2 (text "\tld.b") o1 o2 + LD II16 o1 o2 -> op2 (text "\tld.h") o1 o2 + LD II32 o1 o2 -> op2 (text "\tld.w") o1 o2 + LD II64 o1 o2 -> op2 (text "\tld.d") o1 o2 + LD FF32 o1 o2 -> op2 (text "\tfld.s") o1 o2 + LD FF64 o1 o2 -> op2 (text "\tfld.d") o1 o2 + + LDU II8 o1 o2 -> op2 (text "\tld.bu") o1 o2 + LDU II16 o1 o2 -> op2 (text "\tld.hu") o1 o2 + LDU II32 o1 o2 -> op2 (text "\tld.wu") o1 o2 + LDU II64 o1 o2 -> op2 (text "\tld.d") o1 o2 -- double words (64bit) cannot be sign extended by definition + LDU FF32 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tfld.s") o1 o2 + LDU FF32 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tfld.s") o1 o2 + LDU FF64 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tfld.d") o1 o2 + LDU FF64 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tfld.d") o1 o2 + LDU f o1 o2 -> pprPanic "Unsupported unsigned load" ((text.show) f <+> pprOp platform o1 <+> pprOp platform o2) + + ST II8 o1 o2 -> op2 (text "\tst.b") o1 o2 + ST II16 o1 o2 -> op2 (text "\tst.h") o1 o2 + ST II32 o1 o2 -> op2 (text "\tst.w") o1 o2 + ST II64 o1 o2 -> op2 (text "\tst.d") o1 o2 + ST FF32 o1 o2 -> op2 (text "\tfst.s") o1 o2 + ST FF64 o1 o2 -> op2 (text "\tfst.d") o1 o2 + + -- LDPTR.{W/D}, STPTR.{W/D}: AddrRegImm: AddrRegImm + LDPTR II32 o1 o2 -> op2 (text "\tldptr.w") o1 o2 + LDPTR II64 o1 o2 -> op2 (text "\tldptr.d") o1 o2 + STPTR II32 o1 o2 -> op2 (text "\tstptr.w") o1 o2 + STPTR II64 o1 o2 -> op2 (text "\tstptr.d") o1 o2 + + -- LDX.{B[U]/H[U]/W[U]/D}, STX.{B/H/W/D}: AddrRegReg + LDX II8 o1 o2 -> op2 (text "\tldx.b") o1 o2 + LDX II16 o1 o2 -> op2 (text "\tldx.h") o1 o2 + LDX II32 o1 o2 -> op2 (text "\tldx.w") o1 o2 + LDX II64 o1 o2 -> op2 (text "\tldx.d") o1 o2 + LDX FF32 o1 o2 -> op2 (text "\tfldx.s") o1 o2 + LDX FF64 o1 o2 -> op2 (text "\tfldx.d") o1 o2 + LDXU II8 o1 o2 -> op2 (text "\tldx.bu") o1 o2 + LDXU II16 o1 o2 -> op2 (text "\tldx.hu") o1 o2 + LDXU II32 o1 o2 -> op2 (text "\tldx.wu") o1 o2 + LDXU II64 o1 o2 -> op2 (text "\tldx.d") o1 o2 + STX II8 o1 o2 -> op2 (text "\tstx.b") o1 o2 + STX II16 o1 o2 -> op2 (text "\tstx.h") o1 o2 + STX II32 o1 o2 -> op2 (text "\tstx.w") o1 o2 + STX II64 o1 o2 -> op2 (text "\tstx.d") o1 o2 + STX FF32 o1 o2 -> op2 (text "\tfstx.s") o1 o2 + STX FF64 o1 o2 -> op2 (text "\tfstx.d") o1 o2 + + PRELD h o1@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tpreld") h o1 + -- 6. Bound Check Memory Access Instructions --------------------------------- + -- LD{GT/LE}.{B/H/W/D}, ST{GT/LE}.{B/H/W/D} + -- 7. Atomic Memory Access Instructions -------------------------------------- + -- AM{SWAP/ADD/AND/OR/XOR/MAX/MIN}[DB].{W/D}, AM{MAX/MIN}[_DB].{WU/DU} + -- AM.{SWAP/ADD}[_DB].{B/H} + -- AMCAS[_DB].{B/H/W/D} + -- LL.{W/D}, SC.{W/D} + -- SC.Q + -- LL.ACQ.{W/D}, SC.REL.{W/D} + -- 8. Barrier Instructions --------------------------------------------------- + -- DBAR, IBAR + DBAR h -> line $ text "\tdbar" <+> pprBarrierType h + IBAR h -> line $ text "\tibar" <+> pprBarrierType h + + -- Floating-point convert precision + FCVT o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.d") o1 o2 + FCVT o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.s") o1 o2 + FCVT o1 o2 -> pprPanic "LA64.pprInstr - impossible float conversion" $ + line (pprOp platform o1 <> text "->" <> pprOp platform o2) + -- Signed fixed-point convert to floating-point + -- For LoongArch, ffint.* instructions's second operand must be float-pointing register, + -- so we need one more operation. + -- Also to tfint.*. + SCVTF o1@(OpReg W32 _) o2@(OpReg W32 _) -> lines_ + [ + text "\tmovgr2fr.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tffint.s.w" <+> pprOp platform o1 <> comma <+> pprOp platform o1 + ] + SCVTF o1@(OpReg W32 _) o2@(OpReg W64 _) -> lines_ + [ + text "\tmovgr2fr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tffint.s.l" <+> pprOp platform o1 <> comma <+> pprOp platform o1 + ] + SCVTF o1@(OpReg W64 _) o2@(OpReg W32 _) -> lines_ + [ + text "\tmovgr2fr.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tffint.d.w" <+> pprOp platform o1 <> comma <+> pprOp platform o1 + ] + SCVTF o1@(OpReg W64 _) o2@(OpReg W64 _) -> lines_ + [ + text "\tmovgr2fr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tffint.d.l" <+> pprOp platform o1 <> comma <+> pprOp platform o1 + ] + SCVTF o1 o2 -> pprPanic "LA64.pprInstr - impossible integer to float conversion" $ + line (pprOp platform o1 <> text "->" <> pprOp platform o2) + + -- Floating-point convert to signed integer, rounding toward zero + -- TODO: FCVTZS will destroy src-floating register if the previous opertion + -- includes this reg. So I'm just stupidly saving and restoring by adding + -- an extra register. + FCVTZS o1@(OpReg W32 _) o2@(OpReg W32 _) o3@(OpReg W32 _) -> lines_ + [ + text "\tfmov.s" <+> pprOp platform o2 <> comma <+> pprOp platform o3, + text "\tftintrz.w.s" <+> pprOp platform o3 <> comma <+> pprOp platform o3, + text "\tmovfr2gr.s" <+> pprOp platform o1 <> comma <+> pprOp platform o3, + text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2 + ] + FCVTZS o1@(OpReg W32 _) o2@(OpReg W64 _) o3@(OpReg W64 _) -> lines_ + [ + text "\tfmov.d" <+> pprOp platform o2 <> comma <+> pprOp platform o3, + text "\tftintrz.w.d" <+> pprOp platform o3 <> comma <+> pprOp platform o3, + text "\tmovfr2gr.s" <+> pprOp platform o1 <> comma <+> pprOp platform o3, + text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2 + ] + FCVTZS o1@(OpReg W64 _) o2@(OpReg W32 _) o3@(OpReg W32 _) -> lines_ + [ + text "\tfmov.s" <+> pprOp platform o2 <> comma <+> pprOp platform o3, + text "\tftintrz.l.s" <+> pprOp platform o3 <> comma <+> pprOp platform o3, + text "\tmovfr2gr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o3, + text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2 + ] + FCVTZS o1@(OpReg W64 _) o2@(OpReg W64 _) o3@(OpReg W64 _) -> lines_ + [ + text "\tfmov.d" <+> pprOp platform o2 <> comma <+> pprOp platform o3, + text "\tftintrz.l.d" <+> pprOp platform o3 <> comma <+> pprOp platform o3, + text "\tmovfr2gr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o3, + text "\tfmov.d" <+> pprOp platform o3 <> comma <+> pprOp platform o2 + ] + FCVTZS o1 o2 o3 -> pprPanic "LA64.pprInstr - impossible float to integer conversion" $ + line (pprOp platform o3 <> text "->" <+> pprOp platform o1 <+> text "tmpReg:" <+> pprOp platform o2) + + FMIN o1 o2 o3 -> op3 (text "fmin." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3 + FMINA o1 o2 o3 -> op3 (text "fmina." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3 + FMAX o1 o2 o3 -> op3 (text "fmax." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3 + FMAXA o1 o2 o3 -> op3 (text "fmaxa." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3 + FABS o1 o2 -> op2 (text "fabs." <> if isSingleOp o2 then text "s" else text "d") o1 o2 + FNEG o1 o2 -> op2 (text "fneg." <> if isSingleOp o2 then text "s" else text "d") o1 o2 + FSQRT o1 o2 -> op2 (text "fsqrt." <> if isSingleOp o2 then text "s" else text "d") o1 o2 + FMA variant d o1 o2 o3 -> + let fma = case variant of + FMAdd -> text "\tfmadd." <+> floatPrecission d + FMSub -> text "\tfmsub." <+> floatPrecission d + FNMAdd -> text "\tfnmadd." <+> floatPrecission d + FNMSub -> text "\tfnmsub." <+> floatPrecission d + in op4 fma d o1 o2 o3 + + instr -> panic $ "LA64.pprInstr - Unknown instruction: " ++ (instrCon instr) + where op2 op o1 o2 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 + op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 +{- + -- TODO: Support dbar with different hints. + On LoongArch uses "dbar 0" (full completion barrier) for everything. + But the full completion barrier has no performance to tell, so + Loongson-3A6000 and newer processors have made finer granularity hints + available: + + Bit4: ordering or completion (0: completion, 1: ordering) + Bit3: barrier for previous read (0: true, 1: false) + Bit2: barrier for previous write (0: true, 1: false) + Bit1: barrier for succeeding read (0: true, 1: false) + Bit0: barrier for succeeding write (0: true, 1: false) +-} + pprBarrierType Hint0 = text "0x0" + floatPrecission o | isSingleOp o = text "s" + | isDoubleOp o = text "d" + | otherwise = pprPanic "Impossible floating point precission: " (pprOp platform o) + +-- LoongArch64 Conditional Branch Instructions +pprBcond :: IsLine doc => Cond -> doc +pprBcond c = text "b" <> pprCond c + +pprCond :: IsLine doc => Cond -> doc +pprCond c = case c of + EQ -> text "eq" -- beq rj, rd, off16 + NE -> text "ne" -- bne rj, rd, off16 + SLT -> text "lt" -- blt rj, rd, off16 + SGE -> text "ge" -- bge rj, rd, off16 + ULT -> text "ltu" -- bltu rj, rd, off16 + UGE -> text "geu" -- bgeu rj, rd, off16 + -- Following not real instructions, just mark it. + SLE -> text "sle->ge" -- ble rj, rd, off16 -> bge rd, rj, off16 + SGT -> text "sgt->lt" -- bgt rj, rd, off16 -> blt rd, rj, off16 + ULE -> text "ule->geu" -- bleu rj, rd, off16 -> bgeu rd, rj, off16 + UGT -> text "ugt->ltu" -- bgtu rj, rd, off16 -> bltu rd, rj, off16 + _ -> panic $ "LA64.ppr: non-implemented branch condition: " ++ show c diff --git a/GHC/CmmToAsm/LA64/RegInfo.hs b/GHC/CmmToAsm/LA64/RegInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/RegInfo.hs @@ -0,0 +1,25 @@ +-- Here maybe have something to be optimized in future? +module GHC.CmmToAsm.LA64.RegInfo where + +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.CmmToAsm.LA64.Instr +import GHC.Prelude +import GHC.Utils.Outputable + +newtype JumpDest = DestBlockId BlockId + +instance Outputable JumpDest where + ppr (DestBlockId bid) = text "jd:" <> ppr bid + +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid + +canShortcut :: Instr -> Maybe JumpDest +canShortcut _ = Nothing + +shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics +shortcutStatics _ other_static = other_static + +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump _ other = other diff --git a/GHC/CmmToAsm/LA64/Regs.hs b/GHC/CmmToAsm/LA64/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/Regs.hs @@ -0,0 +1,155 @@ +module GHC.CmmToAsm.LA64.Regs where + +import GHC.Prelude +import GHC.Cmm +import GHC.Cmm.CLabel ( CLabel ) +import GHC.CmmToAsm.Format +import GHC.Data.FastString +import GHC.Platform +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import GHC.Platform.Reg.Class.Separate +import GHC.Platform.Regs +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.Unique + +-- All machine register numbers. +allMachRegNos :: [RegNo] +allMachRegNos = [0..31] ++ [32..63] + +zeroReg, raReg, tpMachReg, fpMachReg, spMachReg, tmpReg :: Reg +zeroReg = regSingle 0 +raReg = regSingle 1 +tpMachReg = regSingle 2 +-- Not to be confused with the `CmmReg` `spReg` +spMachReg = regSingle 3 +fpMachReg = regSingle 22 +-- Use t8(r20) for LA64 IP register. +tmpReg = regSingle 20 + +-- Registers available to the register allocator. +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform = + let isFree = freeReg platform + in map RealRegSingle $ filter isFree allMachRegNos + +-- Integer argument registers according to the calling convention +allGpArgRegs :: [Reg] +allGpArgRegs = map regSingle [4..11] + +-- | Floating point argument registers according to the calling convention +allFpArgRegs :: [Reg] +allFpArgRegs = map regSingle [32..39] + +-- Addressing modes +data AddrMode + = AddrRegReg Reg Reg + | AddrRegImm Reg Imm + | AddrReg Reg + deriving (Eq, Show) + +-- Immediates +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit FastString + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + deriving (Eq, Show) + +-- Map CmmLit to Imm +litToImm :: CmmLit -> Imm +litToImm (CmmInt i w) = ImmInteger (narrowS w i) +-- narrow to the width: a CmmInt might be out of +-- range, but we assume that ImmInteger only contains +-- in-range values. A signed value should be fine here. +litToImm (CmmFloat f W32) = ImmFloat f +litToImm (CmmFloat f W64) = ImmDouble f +litToImm (CmmLabel l) = ImmCLbl l +litToImm (CmmLabelOff l off) = ImmIndex l off +litToImm (CmmLabelDiffOff l1 l2 off _) = + ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) +litToImm l = panic $ "LA64.Regs.litToImm: no match for " ++ show l + +-- == To satisfy GHC.CmmToAsm.Reg.Target ======================================= + +-- squeese functions for the graph allocator ----------------------------------- +-- | regSqueeze_class reg +-- Calculate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> Int +virtualRegSqueeze cls vr + = case cls of + RcInteger -> + case vr of + VirtualRegI {} -> 1 + VirtualRegHi {} -> 1 + _other -> 0 + RcFloat -> + case vr of + VirtualRegD {} -> 1 + _other -> 0 + RcVector -> + case vr of + VirtualRegV128 {} -> 1 + _other -> 0 + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> Int +realRegSqueeze cls rr = + case cls of + RcInteger -> + case rr of + RealRegSingle regNo + | regNo < 32 + -> 1 + | otherwise + -> 0 + RcFloat -> + case rr of + RealRegSingle regNo + | regNo < 32 + || regNo > 63 + -> 0 + | otherwise + -> 1 + RcVector -> + case rr of + RealRegSingle regNo + | regNo > 63 + -> 1 + | otherwise + -> 0 + +mkVirtualReg :: Unique -> Format -> VirtualReg +mkVirtualReg u format + | not (isFloatFormat format) = VirtualRegI u + | otherwise + = case format of + FF32 -> VirtualRegD u + FF64 -> VirtualRegD u + _ -> panic "LA64.mkVirtualReg" + +{-# INLINE classOfRealReg #-} +classOfRealReg :: RealReg -> RegClass +classOfRealReg (RealRegSingle i) + | i < 32 = RcInteger + | i > 63 = RcVector + | otherwise = RcFloat + +regDotColor :: RealReg -> SDoc +regDotColor reg + = case classOfRealReg reg of + RcInteger -> text "blue" + RcFloat -> text "red" + RcVector -> text "green" diff --git a/GHC/CmmToAsm/Monad.hs b/GHC/CmmToAsm/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Monad.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1993-2004 +-- +-- The native code generator's monad. +-- +-- ----------------------------------------------------------------------------- + +module GHC.CmmToAsm.Monad ( + NcgImpl(..), + NatM_State(..), mkNatM_State, + + NatM, -- instance Monad + initNat, + addImportNat, + addNodeBetweenNat, + addImmediateSuccessorNat, + updateCfgNat, + getUniqueNat, + setDeltaNat, + getConfig, + getPlatform, + getDeltaNat, + getThisModuleNat, + getBlockIdNat, + getNewLabelNat, + getNewRegNat, + getPicBaseMaybeNat, + getPicBaseNat, + getCfgWeights, + getFileId, + getDebugBlock, + + DwarfFiles, + + -- * 64-bit registers on 32-bit architectures + Reg64(..), RegCode64(..), + getNewReg64, localReg64 +) + +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Reg +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.CLabel ( CLabel ) +import GHC.Cmm.DebugBlock +import GHC.Cmm.Expr (LocalReg (..), isWord64) + +import GHC.Data.FastString ( FastString ) +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSM +import GHC.Types.Unique ( Unique ) +import GHC.Unit.Module + +import GHC.Utils.Outputable (SDoc, HDoc, ppr) +import GHC.Utils.Panic (pprPanic) +import GHC.Utils.Monad.State.Strict (State (..), runState, state) +import GHC.Utils.Misc +import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.CFG.Weight + +-- | A Native Code Generator implementation is parametrised over +-- * The type of static data (typically related to 'CmmStatics') +-- * The type of instructions +-- * The type of jump destinations +data NcgImpl statics instr jumpDest = NcgImpl { + ncgConfig :: !NCGConfig, + cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr], + generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr), + -- | Given a jump destination, if it refers to a block, return the block id of the destination. + getJumpDestBlockId :: jumpDest -> Maybe BlockId, + -- | Does this jump always jump to a single destination and is shortcutable? + -- + -- We use this to determine whether the given instruction is a shortcutable + -- jump to some destination - See Note [supporting shortcutting] + -- Note that if we return a destination here we *most* support the relevant shortcutting in + -- shortcutStatics for jump tables and shortcutJump for the instructions itself. + canShortcut :: instr -> Maybe jumpDest, + -- | Replace references to blockIds with other destinations - used to update jump tables. + shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, + -- | Change the jump destination(s) of an instruction. + -- + -- Rewrites the destination of a jump instruction to another + -- destination, if the given function returns a new jump destination for + -- the 'BlockId' of the original destination. + -- + -- For instance, for a mapping @block_a -> dest_b@ and a instruction @goto block_a@ we would + -- rewrite the instruction to @goto dest_b@ + shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, + -- | 'Module' is only for printing internal labels. See Note [Internal proc + -- labels] in CLabel. + pprNatCmmDeclS :: NatCmmDecl statics instr -> SDoc, + pprNatCmmDeclH :: NatCmmDecl statics instr -> HDoc, + -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] + maxSpillSlots :: Int, + allocatableRegs :: [RealReg], + ncgAllocMoreStack :: Int -> NatCmmDecl statics instr + -> UniqDSM (NatCmmDecl statics instr, [(BlockId,BlockId)]), + -- ^ The list of block ids records the redirected jumps to allow us to update + -- the CFG. + ncgMakeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock instr] + -> UniqDSM [NatBasicBlock instr], + extractUnwindPoints :: [instr] -> [UnwindPoint], + -- ^ given the instruction sequence of a block, produce a list of + -- the block's 'UnwindPoint's + -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock" + -- and Note [Unwinding information in the NCG] in this module. + invertCondBranches :: Maybe CFG -> LabelMap RawCmmStatics -> [NatBasicBlock instr] + -> [NatBasicBlock instr] + -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \@ + -- when possible. + } + +{- Note [supporting shortcutting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the concept of shortcutting see Note [What is shortcutting]. + +In order to support shortcutting across multiple backends uniformly we +use canShortcut, shortcutStatics and shortcutJump. + +canShortcut tells us if the backend support shortcutting of a instruction +and if so what destination we should retarget instruction to instead. + +shortcutStatics exists to allow us to update jump destinations in jump tables. + +shortcutJump updates the instructions itself. + +A backend can opt out of those by always returning Nothing for canShortcut +and implementing shortcutStatics/shortcutJump as \_ x -> x + +-} + +{- Note [pprNatCmmDeclS and pprNatCmmDeclH] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each NcgImpl provides two implementations of its CmmDecl printer, pprNatCmmDeclS +and pprNatCmmDeclH, which are specialized to SDoc and HDoc, respectively +(see Note [SDoc versus HDoc] in GHC.Utils.Outputable). These are both internally +implemented as a single, polymorphic function, but they need to be stored using +monomorphic types to ensure the specialized versions are used, which is +essential for performance (see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable). + +One might wonder why we bother with pprNatCmmDeclS and SDoc at all, since we +have a perfectly serviceable HDoc-based implementation that is more efficient. +However, it turns out we benefit from keeping both, for two (related) reasons: + + 1. Although we absolutely want to take care to use pprNatCmmDeclH for actual + code generation (the improved performance there is why we have HDoc at + all!), we also sometimes print assembly for debug dumps, when requested via + -ddump-asm. In this case, it’s more convenient to produce an SDoc, which + can be concatenated with other SDocs for consistency with the general- + purpose dump file infrastructure. + + 2. Some debug information is sometimes useful to include in -ddump-asm that is + neither necessary nor useful in normal code generation, and it turns out to + be tricky to format neatly using the one-line-at-a-time model of HLine/HDoc. + +Therefore, we provide both pprNatCmmDeclS and pprNatCmmDeclH, and we sometimes +include additional information in the SDoc variant using dualDoc +(see Note [dualLine and dualDoc] in GHC.Utils.Outputable). However, it is +absolutely *critical* that pprNatCmmDeclS is not actually used unless -ddump-asm +is provided, as that would rather defeat the whole point. (Fortunately, the +difference in allocations between the two implementations is so vast that such a +mistake would readily show up in performance tests). -} + +data NatM_State + = NatM_State { + natm_us :: DUniqSupply, + natm_delta :: Int, -- ^ Stack offset for unwinding information + natm_imports :: [(CLabel)], + natm_pic :: Maybe Reg, + natm_config :: NCGConfig, + natm_fileid :: DwarfFiles, + natm_debug_map :: LabelMap DebugBlock, + natm_cfg :: CFG + -- ^ Having a CFG with additional information is essential for some + -- operations. However we can't reconstruct all information once we + -- generated instructions. So instead we update the CFG as we go. + } + +type DwarfFiles = UniqFM FastString (FastString, Int) + +newtype NatM a = NatM' (State NatM_State a) + deriving stock (Functor) + deriving (Applicative, Monad) via State NatM_State + +pattern NatM :: (NatM_State -> (a, NatM_State)) -> NatM a +pattern NatM f <- NatM' (runState -> f) + where NatM f = NatM' (state f) +{-# COMPLETE NatM #-} + +unNat :: NatM a -> NatM_State -> (a, NatM_State) +unNat (NatM a) = a + +mkNatM_State :: DUniqSupply -> Int -> NCGConfig -> + DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State +mkNatM_State us delta config + = \dwf dbg cfg -> + NatM_State + { natm_us = us + , natm_delta = delta + , natm_imports = [] + , natm_pic = Nothing + , natm_config = config + , natm_fileid = dwf + , natm_debug_map = dbg + , natm_cfg = cfg + } + +initNat :: NatM_State -> NatM a -> (a, NatM_State) +initNat = flip unNat + +instance MonadGetUnique NatM where + getUniqueM = NatM $ \st -> + case takeUniqueFromDSupply (natm_us st) of + (uniq, us') -> (uniq, st {natm_us = us'}) + +getUniqueNat :: NatM Unique +getUniqueNat = getUniqueM + +getDeltaNat :: NatM Int +getDeltaNat = NatM $ \ st -> (natm_delta st, st) + +-- | Get CFG edge weights +getCfgWeights :: NatM Weights +getCfgWeights = NatM $ \ st -> (ncgCfgWeights (natm_config st), st) + +setDeltaNat :: Int -> NatM () +setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta}) + +getThisModuleNat :: NatM Module +getThisModuleNat = NatM $ \ st -> (ncgThisModule $ natm_config st, st) + +instance HasModule NatM where + getModule = getThisModuleNat + +addImportNat :: CLabel -> NatM () +addImportNat imp + = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st}) + +updateCfgNat :: (CFG -> CFG) -> NatM () +updateCfgNat f + = NatM $ \ st -> let !cfg' = f (natm_cfg st) + in ((), st { natm_cfg = cfg'}) + +-- | Record that we added a block between `from` and `old`. +addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM () +addNodeBetweenNat from between to + = do weights <- getCfgWeights + let jmpWeight = fromIntegral (uncondWeight weights) + updateCfgNat (updateCfg jmpWeight from between to) + where + -- When transforming A -> B to A -> A' -> B + -- A -> A' keeps the old edge info while + -- A' -> B gets the info for an unconditional + -- jump. + updateCfg weight from between old m + | Just info <- getEdgeInfo from old m + = addEdge from between info . + addWeightEdge between old weight . + delEdge from old $ m + | otherwise + = pprPanic "Failed to update cfg: Untracked edge" (ppr (from,to)) + + +-- | Place `succ` after `block` and change any edges +-- block -> X to `succ` -> X +addImmediateSuccessorNat :: BlockId -> BlockId -> NatM () +addImmediateSuccessorNat block succ = do + weights <- getCfgWeights + updateCfgNat (addImmediateSuccessor weights block succ) + +getBlockIdNat :: NatM BlockId +getBlockIdNat + = mkBlockId <$> getUniqueNat + +getNewLabelNat :: NatM CLabel +getNewLabelNat + = blockLbl <$> getBlockIdNat + + +getNewRegNat :: Format -> NatM Reg +getNewRegNat rep + = do u <- getUniqueNat + platform <- getPlatform + return (RegVirtual $ targetMkVirtualReg platform u rep) + + +-- | Two 32-bit regs used as a single virtual 64-bit register +data Reg64 = Reg64 + !Reg -- ^ Higher part + !Reg -- ^ Lower part + +-- | Two 32-bit regs used as a single virtual 64-bit register +-- and the code to set them appropriately +data RegCode64 code = RegCode64 + code -- ^ Code to initialize the registers + !Reg -- ^ Higher part + !Reg -- ^ Lower part + +-- | Return a virtual 64-bit register +getNewReg64 :: NatM Reg64 +getNewReg64 = do + let rep = II32 + u <- getUniqueNat + platform <- getPlatform + let vLo = targetMkVirtualReg platform u rep + let lo = RegVirtual $ targetMkVirtualReg platform u rep + let hi = RegVirtual $ getHiVirtualRegFromLo vLo + return $ Reg64 hi lo + +-- | Convert a 64-bit LocalReg into two virtual 32-bit regs. +-- +-- Used to handle 64-bit "registers" on 32-bit architectures +localReg64 :: HasDebugCallStack => LocalReg -> Reg64 +localReg64 (LocalReg vu ty) + | isWord64 ty = let lo = RegVirtual (VirtualRegI vu) + hi = getHiVRegFromLo lo + in Reg64 hi lo + | otherwise = pprPanic "localReg64" (ppr ty) + + +getPicBaseMaybeNat :: NatM (Maybe Reg) +getPicBaseMaybeNat + = NatM (\state -> (natm_pic state, state)) + + +getPicBaseNat :: Format -> NatM Reg +getPicBaseNat rep + = do mbPicBase <- getPicBaseMaybeNat + case mbPicBase of + Just picBase -> return picBase + Nothing + -> do + reg <- getNewRegNat rep + NatM (\state -> (reg, state { natm_pic = Just reg })) + +-- | Get native code generator configuration +getConfig :: NatM NCGConfig +getConfig = NatM $ \st -> (natm_config st, st) + +-- | Get target platform from native code generator configuration +getPlatform :: NatM Platform +getPlatform = ncgPlatform <$> getConfig + +getFileId :: FastString -> NatM Int +getFileId f = NatM $ \st -> + case lookupUFM (natm_fileid st) f of + Just (_,n) -> (n, st) + Nothing -> let n = 1 + sizeUFM (natm_fileid st) + fids = addToUFM (natm_fileid st) f (f,n) + in n `seq` fids `seq` (n, st { natm_fileid = fids }) + +getDebugBlock :: Label -> NatM (Maybe DebugBlock) +getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st) diff --git a/GHC/CmmToAsm/PIC.hs b/GHC/CmmToAsm/PIC.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PIC.hs @@ -0,0 +1,826 @@ +{- + This module handles generation of position independent code and + dynamic-linking related issues for the native code generator. + + This depends on both the architecture and OS, so we define it here + instead of in one of the architecture specific modules. + + Things outside this module which are related to this: + + + module CLabel + - PIC base label (pretty printed as local label 1) + - DynamicLinkerLabels - several kinds: + CodeStub, SymbolPtr, GotSymbolPtr, GotSymbolOffset + - labelDynamic predicate + + module Cmm + - The GlobalReg datatype has a PicBaseReg constructor + - The CmmLit datatype has a CmmLabelDiffOff constructor + + codeGen & RTS + - When tablesNextToCode, no absolute addresses are stored in info tables + any more. Instead, offsets from the info label are used. + - For Win32 only, SRTs might contain addresses of __imp_ symbol pointers + because Win32 doesn't support external references in data sections. + TODO: make sure this still works, it might be bitrotted + + NCG + - The cmmToCmm pass in AsmCodeGen calls cmmMakeDynamicReference for all + labels. + - nativeCodeGen calls pprImportedSymbol and pprGotDeclaration to output + all the necessary stuff for imported symbols. + - The NCG monad keeps track of a list of imported symbols. + - MachCodeGen invokes initializePicBase to generate code to initialize + the PIC base register when needed. + - MachCodeGen calls cmmMakeDynamicReference whenever it uses a CLabel + that wasn't in the original Cmm code (e.g. floating point literals). +-} + +module GHC.CmmToAsm.PIC ( + cmmMakeDynamicReference, + CmmMakeDynamicReferenceM(..), + ReferenceKind(..), + needImportedSymbols, + pprImportedSymbol, + pprGotDeclaration, + + initializePicBase_ppc, + initializePicBase_x86 +) + +where + +import GHC.Prelude + +import qualified GHC.CmmToAsm.PPC.Instr as PPC +import qualified GHC.CmmToAsm.PPC.Regs as PPC +import qualified GHC.CmmToAsm.X86.Instr as X86 + +import GHC.Platform +import GHC.Platform.Reg +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types + + +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.Cmm.CLabel +import GHC.Cmm.Utils (cmmLoadBWord) + +import GHC.Types.Basic + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.FastString + + + +-------------------------------------------------------------------------------- +-- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm +-- code. It does The Right Thing(tm) to convert the CmmLabel into a +-- position-independent, dynamic-linking-aware reference to the thing +-- in question. +-- Note that this also has to be called from MachCodeGen in order to +-- access static data like floating point literals (labels that were +-- created after the cmmToCmm pass). +-- The function must run in a monad that can keep track of imported symbols +-- A function for recording an imported symbol must be passed in: +-- - addImportCmmOpt for the CmmOptM monad +-- - addImportNat for the NatM monad. + +data ReferenceKind + = DataReference + | CallReference + | JumpReference + deriving(Eq) + +class Monad m => CmmMakeDynamicReferenceM m where + addImport :: CLabel -> m () + +instance CmmMakeDynamicReferenceM NatM where + addImport = addImportNat + +cmmMakeDynamicReference + :: CmmMakeDynamicReferenceM m + => NCGConfig + -> ReferenceKind -- whether this is the target of a jump + -> CLabel -- the label + -> m CmmExpr + +cmmMakeDynamicReference config referenceKind lbl + | Just _ <- dynamicLinkerLabelInfo lbl + = return $ CmmLit $ CmmLabel lbl -- already processed it, pass through + + | otherwise + = do let platform = ncgPlatform config + case howToAccessLabel + config + (platformArch platform) + (platformOS platform) + referenceKind lbl of + + AccessViaStub -> do + let stub = mkDynamicLinkerLabel CodeStub lbl + addImport stub + return $ CmmLit $ CmmLabel stub + + -- GOT relative loads work differently on AArch64. We don't do two + -- step loads. The got symbol is loaded directly, and not through an + -- additional load. Thus we do not need the CmmLoad decoration we have + -- on other platforms. + AccessViaSymbolPtr | ArchAArch64 <- platformArch platform -> do + let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl + addImport symbolPtr + return $ cmmMakePicReference config symbolPtr + + AccessViaSymbolPtr | ArchRISCV64 <- platformArch platform -> do + let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl + addImport symbolPtr + return $ cmmMakePicReference config symbolPtr + + AccessViaSymbolPtr | ArchLoongArch64 <- platformArch platform -> do + let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl + addImport symbolPtr + return $ cmmMakePicReference config symbolPtr + + AccessViaSymbolPtr -> do + let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl + addImport symbolPtr + return $ cmmLoadBWord platform (cmmMakePicReference config symbolPtr) + + -- On wasm, always preserve the original CLabel, the backends + -- will handle dynamic references properly + AccessDirectly | ArchWasm32 <- platformArch platform -> + pure $ CmmLit $ CmmLabel lbl + + AccessDirectly -> case referenceKind of + -- for data, we might have to make some calculations: + DataReference -> return $ cmmMakePicReference config lbl + -- all currently supported processors support + -- PC-relative branch and call instructions, + -- so just jump there if it's a call or a jump + _ -> return $ CmmLit $ CmmLabel lbl + +-- ----------------------------------------------------------------------------- +-- Create a position independent reference to a label. +-- (but do not bother with dynamic linking). +-- We calculate the label's address by adding some (platform-dependent) +-- offset to our base register; this offset is calculated by +-- the function picRelative in the platform-dependent part below. + +cmmMakePicReference :: NCGConfig -> CLabel -> CmmExpr +cmmMakePicReference config lbl + -- Windows doesn't need PIC, + -- everything gets relocated at runtime + | OSMinGW32 <- platformOS platform + = CmmLit $ CmmLabel lbl + + -- no pic base reg on AArch64, however indicate this symbol should go through + -- the global offset table (GOT). + | ArchAArch64 <- platformArch platform + = CmmLit $ CmmLabel lbl + + -- as on AArch64, there's no pic base register. + | ArchRISCV64 <- platformArch platform + = CmmLit $ CmmLabel lbl + + | ArchLoongArch64 <- platformArch platform + = CmmLit $ CmmLabel lbl + + | OSAIX <- platformOS platform + = CmmMachOp (MO_Add W32) + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) + , CmmLit $ picRelative (wordWidth platform) + (platformArch platform) + (platformOS platform) + lbl ] + + -- both ABI versions default to medium code model + | ArchPPC_64 _ <- platformArch platform + = CmmMachOp (MO_Add W32) -- code model medium + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) + , CmmLit $ picRelative (wordWidth platform) + (platformArch platform) + (platformOS platform) + lbl ] + + | (ncgPIC config || ncgExternalDynamicRefs config) + && absoluteLabel lbl + = CmmMachOp (MO_Add (wordWidth platform)) + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) + , CmmLit $ picRelative (wordWidth platform) + (platformArch platform) + (platformOS platform) + lbl ] + + | otherwise + = CmmLit $ CmmLabel lbl + where + platform = ncgPlatform config + + + +absoluteLabel :: CLabel -> Bool +absoluteLabel lbl + = case dynamicLinkerLabelInfo lbl of + Just (GotSymbolPtr, _) -> False + Just (GotSymbolOffset, _) -> False + _ -> True + + +-------------------------------------------------------------------------------- +-- Knowledge about how special dynamic linker labels like symbol +-- pointers, code stubs and GOT offsets look like is located in the +-- module CLabel. + +-- | Helper to check whether the data resides in a DLL or not, see @labelDynamic@ +ncgLabelDynamic :: NCGConfig -> CLabel -> Bool +ncgLabelDynamic config = labelDynamic (ncgThisModule config) + (ncgPlatform config) + (ncgExternalDynamicRefs config) + + +-- We have to decide which labels need to be accessed +-- indirectly or via a piece of stub code. +data LabelAccessStyle + = AccessViaStub + | AccessViaSymbolPtr + | AccessDirectly + +howToAccessLabel :: NCGConfig -> Arch -> OS -> ReferenceKind -> CLabel -> LabelAccessStyle + +-- Windows +-- In Windows speak, a "module" is a set of objects linked into the +-- same Portable Executable (PE) file. (both .exe and .dll files are PEs). +-- +-- If we're compiling a multi-module program then symbols from other modules +-- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the +-- following. +-- +-- (in the local module) +-- __imp_SYMBOL: addr of SYMBOL +-- +-- (in the other module) +-- SYMBOL: the real function / data. +-- +-- To access the function at SYMBOL from our local module, we just need to +-- dereference the local __imp_SYMBOL. +-- +-- If not compiling with -dynamic we assume that all our code will be linked +-- into the same .exe file. In this case we always access symbols directly, +-- and never use __imp_SYMBOL. +-- +howToAccessLabel config _arch OSMinGW32 _kind lbl + + -- Assume all symbols will be in the same PE, so just access them directly. + | not (ncgExternalDynamicRefs config) + = AccessDirectly + + -- If the target symbol is in another PE we need to access it via the + -- appropriate __imp_SYMBOL pointer. + | ncgLabelDynamic config lbl + = AccessViaSymbolPtr + + -- Target symbol is in the same PE as the caller, so just access it directly. + | otherwise + = AccessDirectly + +-- On AArch64, relocations for JUMP and CALL will be emitted with 26bits, this +-- is enough for ~64MB of range. Anything else will need to go through a veneer, +-- which is the job of the linker to build. We might only want to lookup +-- Data References through the GOT. +howToAccessLabel config ArchAArch64 _os _kind lbl + | not (ncgExternalDynamicRefs config) + = AccessDirectly + + | ncgLabelDynamic config lbl + = AccessViaSymbolPtr + + | otherwise + = AccessDirectly + + +-- Mach-O (Darwin, Mac OS X) +-- +-- Indirect access is required in the following cases: +-- * things imported from a dynamic library +-- * (not on x86_64) data from a different module, if we're generating PIC code +-- It is always possible to access something indirectly, +-- even when it's not necessary. +-- +howToAccessLabel config arch OSDarwin DataReference lbl + -- data access to a dynamic library goes via a symbol pointer + | ncgLabelDynamic config lbl + = AccessViaSymbolPtr + + -- when generating PIC code, all cross-module data references must + -- must go via a symbol pointer, too, because the assembler + -- cannot generate code for a label difference where one + -- label is undefined. Doesn't apply to x86_64 (why?). + | arch /= ArchX86_64 + , not (isLocalCLabel (ncgThisModule config) lbl) + , ncgPIC config + , externallyVisibleCLabel lbl + = AccessViaSymbolPtr + + | otherwise + = AccessDirectly + +howToAccessLabel config _ OSDarwin JumpReference lbl + -- dyld code stubs don't work for tailcalls because the + -- stack alignment is only right for regular calls. + -- Therefore, we have to go via a symbol pointer: + | ncgLabelDynamic config lbl + = AccessViaSymbolPtr + + +howToAccessLabel _ _ OSDarwin _ _ + = AccessDirectly + +---------------------------------------------------------------------------- +-- AIX + +-- quite simple (for now) +howToAccessLabel _config _arch OSAIX kind _lbl + = case kind of + DataReference -> AccessViaSymbolPtr + CallReference -> AccessDirectly + JumpReference -> AccessDirectly + +-- ELF (Linux) +-- +-- ELF tries to pretend to the main application code that dynamic linking does +-- not exist. While this may sound convenient, it tends to mess things up in +-- very bad ways, so we have to be careful when we generate code for a non-PIE +-- main program (-dynamic but no -fPIC). +-- +-- Indirect access is required for references to imported symbols +-- from position independent code. It is also required from the main program +-- when dynamic libraries containing Haskell code are used. + +howToAccessLabel _config (ArchPPC_64 _) os kind _lbl + | osElfTarget os + = case kind of + -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC + DataReference -> AccessViaSymbolPtr + -- RTLD does not generate stubs for function descriptors + -- in tail calls. Create a symbol pointer and generate + -- the code to load the function descriptor at the call site. + JumpReference -> AccessViaSymbolPtr + -- regular calls are handled by the runtime linker + _ -> AccessDirectly + +howToAccessLabel config _arch os _kind _lbl + -- no PIC -> the dynamic linker does everything for us; + -- if we don't dynamically link to Haskell code, + -- it actually manages to do so without messing things up. + | osElfTarget os + , not (ncgPIC config) && + not (ncgExternalDynamicRefs config) + = AccessDirectly + +howToAccessLabel config arch os DataReference lbl + | osElfTarget os + = case () of + -- A dynamic label needs to be accessed via a symbol pointer. + _ | ncgLabelDynamic config lbl + -> AccessViaSymbolPtr + + -- For PowerPC32 -fPIC, we have to access even static data + -- via a symbol pointer (see below for an explanation why + -- PowerPC32 Linux is especially broken). + | arch == ArchPPC + , ncgPIC config + -> AccessViaSymbolPtr + + | otherwise + -> AccessDirectly + + + -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons: + -- on i386, the position-independent symbol stubs in the Procedure Linkage Table + -- require the address of the GOT to be loaded into register %ebx on entry. + -- The linker will take any reference to the symbol stub as a hint that + -- the label in question is a code label. When linking executables, this + -- will cause the linker to replace even data references to the label with + -- references to the symbol stub. + + -- This leaves calling a (foreign) function from non-PIC code + -- (AccessDirectly, because we get an implicit symbol stub) + -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) + +howToAccessLabel config arch os CallReference lbl + | osElfTarget os + , ncgLabelDynamic config lbl + , not (ncgPIC config) + = AccessDirectly + + | osElfTarget os + , arch /= ArchX86 + , ncgLabelDynamic config lbl + , ncgPIC config + = AccessViaStub + +howToAccessLabel config _arch os _kind lbl + | osElfTarget os + = if ncgLabelDynamic config lbl + then AccessViaSymbolPtr + else AccessDirectly + +-- On wasm, always keep the original CLabel and let the backend decide +-- how to handle dynamic references +howToAccessLabel _ ArchWasm32 _ _ _ + = AccessDirectly + +-- all other platforms +howToAccessLabel config _arch _os _kind _lbl + | not (ncgPIC config) + = AccessDirectly + + | otherwise + = panic "howToAccessLabel: PIC not defined for this platform" + + + +-- ------------------------------------------------------------------- +-- | Says what we have to add to our 'PIC base register' in order to +-- get the address of a label. + +picRelative :: Width -> Arch -> OS -> CLabel -> CmmLit + +-- Darwin, but not x86_64: +-- The PIC base register points to the PIC base label at the beginning +-- of the current CmmDecl. We just have to use a label difference to +-- get the offset. +-- We have already made sure that all labels that are not from the current +-- module are accessed indirectly ('as' can't calculate differences between +-- undefined labels). +picRelative width arch OSDarwin lbl + | arch /= ArchX86_64 + = CmmLabelDiffOff lbl mkPicBaseLabel 0 width + +-- On AIX we use an indirect local TOC anchored by 'gotLabel'. +-- This way we use up only one global TOC entry per compilation-unit +-- (this is quite similar to GCC's @-mminimal-toc@ compilation mode) +picRelative width _ OSAIX lbl + = CmmLabelDiffOff lbl gotLabel 0 width + +-- PowerPC Linux: +-- The PIC base register points to our fake GOT. Use a label difference +-- to get the offset. +-- We have made sure that *everything* is accessed indirectly, so this +-- is only used for offsets from the GOT to symbol pointers inside the +-- GOT. +picRelative width ArchPPC os lbl + | osElfTarget os + = CmmLabelDiffOff lbl gotLabel 0 width + + +-- Most Linux versions: +-- The PIC base register points to the GOT. Use foo@got for symbol +-- pointers, and foo@gotoff for everything else. +-- Linux and Darwin on x86_64: +-- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers, +-- and a GotSymbolOffset label for other things. +-- For reasons of tradition, the symbol offset label is written as a plain label. +picRelative _ arch os lbl + | osElfTarget os || (os == OSDarwin && arch == ArchX86_64) + = let result + | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl + = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl' + + | otherwise + = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl + + in result + +picRelative _ _ _ _ + = panic "GHC.CmmToAsm.PIC.picRelative undefined for this platform" + + + +-------------------------------------------------------------------------------- + +needImportedSymbols :: NCGConfig -> Bool +needImportedSymbols config + | os == OSDarwin + , arch /= ArchX86_64 + = True + + | os == OSAIX + = True + + -- PowerPC Linux: -fPIC or -dynamic + | osElfTarget os + , arch == ArchPPC + = ncgPIC config || ncgExternalDynamicRefs config + + -- PowerPC 64 Linux: always + | osElfTarget os + , arch == ArchPPC_64 ELF_V1 || arch == ArchPPC_64 ELF_V2 + = True + + -- i386 (and others?): -dynamic but not -fPIC + | osElfTarget os + , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 + = ncgExternalDynamicRefs config && + not (ncgPIC config) + + | otherwise + = False + where + platform = ncgPlatform config + arch = platformArch platform + os = platformOS platform + +-- gotLabel +-- The label used to refer to our "fake GOT" from +-- position-independent code. +gotLabel :: CLabel +gotLabel + -- HACK: this label isn't really foreign + = mkForeignLabel + (fsLit ".LCTOC1") + ForeignLabelInThisPackage IsData + + + +-- Emit GOT declaration +-- Output whatever needs to be output once per .s file. +-- +-- We don't need to declare any offset tables. +-- However, for PIC on x86, we need a small helper function. +pprGotDeclaration :: NCGConfig -> HDoc +pprGotDeclaration config = case (arch,os) of + (_, OSDarwin) -> empty + + -- Emit XCOFF TOC section + (_, OSAIX) + -> lines_ [ text ".toc" + , text ".tc ghc_toc_table[TC],.LCTOC1" + , text ".csect ghc_toc_table[RW]" + -- See Note [.LCTOC1 in PPC PIC code] + , text ".set .LCTOC1,$+0x8000" + ] + + + -- PPC 64 ELF v1 needs a Table Of Contents (TOC) + (ArchPPC_64 ELF_V1, _) + -> line $ text ".section \".toc\",\"aw\"" + + -- In ELF v2 we also need to tell the assembler that we want ABI + -- version 2. This would normally be done at the top of the file + -- right after a file directive, but I could not figure out how + -- to do that. + (ArchPPC_64 ELF_V2, _) + -> lines_ [ text ".abiversion 2", + text ".section \".toc\",\"aw\"" + ] + + (arch, os) + | osElfTarget os + , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 + , not (ncgPIC config) + -> empty + + | osElfTarget os + , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 + -> lines_ [ + -- See Note [.LCTOC1 in PPC PIC code] + text ".section \".got2\",\"aw\"", + text ".LCTOC1 = .+32768" ] + + _ -> panic "pprGotDeclaration: no match" + where + platform = ncgPlatform config + arch = platformArch platform + os = platformOS platform + + +-------------------------------------------------------------------------------- +-- On Darwin, we have to generate our own stub code for lazy binding.. +-- For each processor architecture, there are two versions, one for PIC +-- and one for non-PIC. +-- + +pprImportedSymbol :: NCGConfig -> CLabel -> HDoc +pprImportedSymbol config importedLbl = case (arch,os) of + (ArchAArch64, OSDarwin) + -> empty + + + + -- XCOFF / AIX + -- + -- Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To + -- workaround the limitation of a global TOC we use an indirect TOC + -- with the label `ghc_toc_table`. + -- + -- See also GCC's `-mminimal-toc` compilation mode or + -- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/ + -- + -- NB: No DSO-support yet + + (_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of + Just (SymbolPtr, lbl) + -> lines_ [ + text "LC.." <> ppr_lbl lbl <> char ':', + text "\t.long" <+> ppr_lbl lbl ] + _ -> empty + + -- ELF / Linux + -- + -- In theory, we don't need to generate any stubs or symbol pointers + -- by hand for Linux. + -- + -- Reality differs from this in two areas. + -- + -- 1) If we just use a dynamically imported symbol directly in a read-only + -- section of the main executable (as GCC does), ld generates R_*_COPY + -- relocations, which are fundamentally incompatible with reversed info + -- tables. Therefore, we need a table of imported addresses in a writable + -- section. + -- The "official" GOT mechanism (label@got) isn't intended to be used + -- in position dependent code, so we have to create our own "fake GOT" + -- when not Opt_PIC && WayDyn `elem` ways dflags. + -- + -- 2) PowerPC Linux is just plain broken. + -- While it's theoretically possible to use GOT offsets larger + -- than 16 bit, the standard crt*.o files don't, which leads to + -- linker errors as soon as the GOT size exceeds 16 bit. + -- Also, the assembler doesn't support @gotoff labels. + -- In order to be able to use a larger GOT, we have to circumvent the + -- entire GOT mechanism and do it ourselves (this is also what GCC does). + + + -- When needImportedSymbols is defined, + -- the NCG will keep track of all DynamicLinkerLabels it uses + -- and output each of them using pprImportedSymbol. + + (ArchPPC_64 _, _) + | osElfTarget os + -> case dynamicLinkerLabelInfo importedLbl of + Just (SymbolPtr, lbl) + -> lines_ [ + text ".LC_" <> ppr_lbl lbl <> char ':', + text "\t.quad" <+> ppr_lbl lbl ] + _ -> empty + + _ | osElfTarget os + -> case dynamicLinkerLabelInfo importedLbl of + Just (SymbolPtr, lbl) + -> let symbolSize = case ncgWordWidth config of + W32 -> text "\t.long" + W64 -> text "\t.quad" + _ -> panic "Unknown wordRep in pprImportedSymbol" + + in lines_ [ + text ".section \".got2\", \"aw\"", + text ".LC_" <> ppr_lbl lbl <> char ':', + symbolSize <+> ppr_lbl lbl ] + + -- PLT code stubs are generated automatically by the dynamic linker. + _ -> empty + + _ -> panic "PIC.pprImportedSymbol: no match" + where + platform = ncgPlatform config + ppr_lbl :: CLabel -> HLine + ppr_lbl = pprAsmLabel platform + arch = platformArch platform + os = platformOS platform + +-------------------------------------------------------------------------------- +-- Generate code to calculate the address that should be put in the +-- PIC base register. +-- This is called by MachCodeGen for every CmmProc that accessed the +-- PIC base register. It adds the appropriate instructions to the +-- top of the CmmProc. + +-- It is assumed that the first NatCmmDecl in the input list is a Proc +-- and the rest are CmmDatas. + +-- Darwin is simple: just fetch the address of a local label. +-- The FETCHPC pseudo-instruction is expanded to multiple instructions +-- during pretty-printing so that we don't have to deal with the +-- local label: + +-- PowerPC version: +-- bcl 20,31,1f. +-- 1: mflr picReg + +-- i386 version: +-- call 1f +-- 1: popl %picReg + + + +-- Get a pointer to our own fake GOT, which is defined on a per-module basis. +-- This is exactly how GCC does it in linux. + +initializePicBase_ppc + :: Arch -> OS -> Reg + -> [NatCmmDecl RawCmmStatics PPC.Instr] + -> NatM [NatCmmDecl RawCmmStatics PPC.Instr] + +initializePicBase_ppc ArchPPC os picReg + (CmmProc info lab live (ListGraph blocks) : statics) + | osElfTarget os + = do + let + gotOffset = PPC.ImmConstantDiff + (PPC.ImmCLbl gotLabel) + (PPC.ImmCLbl mkPicBaseLabel) + + blocks' = case blocks of + [] -> [] + (b:bs) -> fetchPC b : map maybeFetchPC bs + + maybeFetchPC b@(BasicBlock bID _) + | bID `mapMember` info = fetchPC b + | otherwise = b + + -- GCC does PIC prologs thusly: + -- bcl 20,31,.L1 + -- .L1: + -- mflr 30 + -- addis 30,30,.LCTOC1-.L1@ha + -- addi 30,30,.LCTOC1-.L1@l + -- TODO: below we use it over temporary register, + -- it can and should be optimised by picking + -- correct PIC reg. + fetchPC (BasicBlock bID insns) = + BasicBlock bID (PPC.FETCHPC picReg + : PPC.ADDIS picReg picReg (PPC.HA gotOffset) + : PPC.ADD picReg picReg + (PPC.RIImm (PPC.LO gotOffset)) + : PPC.MR PPC.r30 picReg + : insns) + + return (CmmProc info lab live (ListGraph blocks') : statics) + +------------------------------------------------------------------------- +-- Load TOC into register 2 +-- PowerPC 64-bit ELF ABI 2.0 requires the address of the callee +-- in register 12. +-- We pass the label to FETCHTOC and create a .localentry too. +-- TODO: Explain this better and refer to ABI spec! +{- +We would like to do approximately this, but spill slot allocation +might be added before the first BasicBlock. That violates the ABI. + +For now we will emit the prologue code in the pretty printer, +which is also what we do for ELF v1. +initializePicBase_ppc (ArchPPC_64 ELF_V2) OSLinux picReg + (CmmProc info lab live (ListGraph (entry:blocks)) : statics) + = do + bID <-getUniqueM + return (CmmProc info lab live (ListGraph (b':entry:blocks)) + : statics) + where BasicBlock entryID _ = entry + b' = BasicBlock bID [PPC.FETCHTOC picReg lab, + PPC.BCC PPC.ALWAYS entryID] +-} + +initializePicBase_ppc _ _ _ _ + = panic "initializePicBase_ppc: not needed" + + +-- We cheat a bit here by defining a pseudo-instruction named FETCHGOT +-- which pretty-prints as: +-- call 1f +-- 1: popl %picReg +-- addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg +-- (See PprMach.hs) + +initializePicBase_x86 + :: OS -> Reg + -> [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr] + -> NatM [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr] + +initializePicBase_x86 os picReg + (CmmProc info lab live (ListGraph blocks) : statics) + | osElfTarget os + = return (CmmProc info lab live (ListGraph blocks') : statics) + where blocks' = case blocks of + [] -> [] + (b:bs) -> fetchGOT b : map maybeFetchGOT bs + + -- we want to add a FETCHGOT instruction to the beginning of + -- every block that is an entry point, which corresponds to + -- the blocks that have entries in the info-table mapping. + maybeFetchGOT b@(BasicBlock bID _) + | bID `mapMember` info = fetchGOT b + | otherwise = b + + fetchGOT (BasicBlock bID insns) = + BasicBlock bID (X86.FETCHGOT picReg : insns) + +initializePicBase_x86 OSDarwin picReg + (CmmProc info lab live (ListGraph (entry:blocks)) : statics) + = return (CmmProc info lab live (ListGraph (block':blocks)) : statics) + + where BasicBlock bID insns = entry + block' = BasicBlock bID (X86.FETCHPC picReg : insns) + +initializePicBase_x86 _ _ _ + = panic "initializePicBase_x86: not needed" diff --git a/GHC/CmmToAsm/PPC.hs b/GHC/CmmToAsm/PPC.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Native code generator for PPC architectures +module GHC.CmmToAsm.PPC + ( ncgPPC + ) +where + +import GHC.Prelude + +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types + +import qualified GHC.CmmToAsm.PPC.Instr as PPC +import qualified GHC.CmmToAsm.PPC.Ppr as PPC +import qualified GHC.CmmToAsm.PPC.CodeGen as PPC +import qualified GHC.CmmToAsm.PPC.Regs as PPC +import qualified GHC.CmmToAsm.PPC.RegInfo as PPC + +ncgPPC :: NCGConfig -> NcgImpl RawCmmStatics PPC.Instr PPC.JumpDest +ncgPPC config = NcgImpl + { ncgConfig = config + , cmmTopCodeGen = PPC.cmmTopCodeGen + , generateJumpTableForInstr = PPC.generateJumpTableForInstr config + , getJumpDestBlockId = PPC.getJumpDestBlockId + , canShortcut = PPC.canShortcut + , shortcutStatics = PPC.shortcutStatics + , shortcutJump = PPC.shortcutJump + , pprNatCmmDeclH = PPC.pprNatCmmDecl config + , pprNatCmmDeclS = PPC.pprNatCmmDecl config + , maxSpillSlots = PPC.maxSpillSlots config + , allocatableRegs = PPC.allocatableRegs platform + , ncgAllocMoreStack = PPC.allocMoreStack platform + , ncgMakeFarBranches = PPC.makeFarBranches + , extractUnwindPoints = const [] + , invertCondBranches = \_ _ -> id + } + where + platform = ncgPlatform config + +-- | Instruction instance for powerpc +instance Instruction PPC.Instr where + regUsageOfInstr = PPC.regUsageOfInstr + patchRegsOfInstr _ = PPC.patchRegsOfInstr + isJumpishInstr = PPC.isJumpishInstr + jumpDestsOfInstr = PPC.jumpDestsOfInstr + canFallthroughTo = PPC.canFallthroughTo + patchJumpInstr = PPC.patchJumpInstr + mkSpillInstr = PPC.mkSpillInstr + mkLoadInstr = PPC.mkLoadInstr + takeDeltaInstr = PPC.takeDeltaInstr + isMetaInstr = PPC.isMetaInstr + mkRegRegMoveInstr _ = PPC.mkRegRegMoveInstr + takeRegRegMoveInstr _ = PPC.takeRegRegMoveInstr + mkJumpInstr = PPC.mkJumpInstr + mkStackAllocInstr = PPC.mkStackAllocInstr + mkStackDeallocInstr = PPC.mkStackDeallocInstr + pprInstr = PPC.pprInstr + mkComment = pure . PPC.COMMENT diff --git a/GHC/CmmToAsm/PPC/CodeGen.hs b/GHC/CmmToAsm/PPC/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/CodeGen.hs @@ -0,0 +1,2669 @@ +{-# LANGUAGE GADTs #-} + +----------------------------------------------------------------------------- +-- +-- Generating machine code (instruction selection) +-- +-- (c) The University of Glasgow 1996-2004 +-- +----------------------------------------------------------------------------- + +-- This is a big module, but, if you pay attention to +-- (a) the sectioning, and (b) the type signatures, +-- the structure should not be too overwhelming. + +module GHC.CmmToAsm.PPC.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) + +where + +-- NCG stuff: +import GHC.Prelude + +import GHC.Platform.Regs +import GHC.CmmToAsm.PPC.Instr +import GHC.CmmToAsm.PPC.Cond +import GHC.CmmToAsm.PPC.Regs +import GHC.CmmToAsm.CPrim +import GHC.CmmToAsm.Types +import GHC.Cmm.DebugBlock + ( DebugBlock(..) ) +import GHC.CmmToAsm.Monad + ( NatM, getNewRegNat, getNewLabelNat + , getBlockIdNat, getPicBaseNat + , Reg64(..), RegCode64(..), getNewReg64, localReg64 + , getPicBaseMaybeNat, getPlatform, getConfig + , getDebugBlock, getFileId + ) +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config +import GHC.Platform.Reg.Class.Unified +import GHC.Platform.Reg +import GHC.CmmToAsm.Reg.Target +import GHC.Platform + +-- Our intermediate code: +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Types.Tickish ( GenTickish(..) ) +import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) + +-- The rest: +import GHC.Data.OrdList +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Monad ( mapAndUnzipM, when ) +import Data.Word + +import GHC.Types.Basic +import GHC.Data.FastString + +-- ----------------------------------------------------------------------------- +-- Top-level of the instruction selector + +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal (pre-order?) yields the insns in the correct +-- order. + +cmmTopCodeGen + :: RawCmmDecl + -> NatM [NatCmmDecl RawCmmStatics Instr] + +cmmTopCodeGen (CmmProc info lab live graph) = do + let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + platform <- getPlatform + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + os = platformOS platform + arch = platformArch platform + case arch of + ArchPPC | os == OSAIX -> return tops + | otherwise -> do + picBaseMb <- getPicBaseMaybeNat + case picBaseMb of + Just picBase -> initializePicBase_ppc arch os picBase tops + Nothing -> return tops + ArchPPC_64 ELF_V1 -> fixup_entry tops + -- generating function descriptor is handled in + -- pretty printer + ArchPPC_64 ELF_V2 -> fixup_entry tops + -- generating function prologue is handled in + -- pretty printer + _ -> panic "PPC.cmmTopCodeGen: unknown arch" + where + fixup_entry (CmmProc info lab live (ListGraph (entry:blocks)) : statics) + = do + let BasicBlock bID insns = entry + bID' <- if lab == (blockLbl bID) + then newBlockId + else return bID + let b' = BasicBlock bID' insns + return (CmmProc info lab live (ListGraph (b':blocks)) : statics) + fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc" + +cmmTopCodeGen (CmmData sec dat) = + return [CmmData sec dat] -- no translation, we just use CmmStatic + +basicBlockCodeGen + :: Block CmmNode C C + -> NatM ( [NatBasicBlock Instr] + , [NatCmmDecl RawCmmStatics Instr]) + +basicBlockCodeGen block = do + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + -- Generate location directive + dbg <- getDebugBlock (entryLabel block) + loc_instrs <- case dblSourceTick =<< dbg of + Just (SourceNote span (LexicalFastString name)) + -> do fileid <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col =srcSpanStartCol span + return $ unitOL $ LOCATION fileid line col (unpackFS name) + _ -> return nilOL + mid_instrs <- stmtsToInstrs stmts + tail_instrs <- stmtToInstrs tail + let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs + -- code generation may introduce new basic block boundaries, which + -- are indicated by the NEWBLOCK instruction. We must split up the + -- instruction stream into basic blocks again. Also, we extract + -- LDATAs here too. + let + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + return (BasicBlock id top : other_blocks, statics) + +stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock +stmtsToInstrs stmts + = do instrss <- mapM stmtToInstrs stmts + return (concatOL instrss) + +stmtToInstrs :: CmmNode e x -> NatM InstrBlock +stmtToInstrs stmt = do + config <- getConfig + platform <- getPlatform + case stmt of + CmmComment s -> return (unitOL (COMMENT s)) + CmmTick {} -> return nilOL + CmmUnwind {} -> return nilOL + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode format reg src + | target32Bit platform && + isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode format reg src + where ty = cmmRegType reg + format = cmmTypeFormat ty + + CmmStore addr src _alignment + | isFloatType ty -> assignMem_FltCode format addr src + | target32Bit platform && + isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode format addr src + where ty = cmmExprType platform src + format = cmmTypeFormat ty + + CmmUnsafeForeignCall target result_regs args + -> genCCall target result_regs args + + CmmBranch id -> genBranch id + CmmCondBranch arg true false prediction -> do + b1 <- genCondJump true arg prediction + b2 <- genBranch false + return (b1 `appOL` b2) + CmmSwitch arg ids -> genSwitch config arg ids + CmmCall { cml_target = arg + , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs) + _ -> + panic "stmtToInstrs: statement should have been cps'd away" + +jumpRegs :: Platform -> [GlobalRegUse] -> [RegWithFormat] +jumpRegs platform gregs = + [ RegWithFormat (RegReal r) (cmmTypeFormat ty) + | GlobalRegUse gr ty <- gregs + , Just r <- [globalRegMaybe platform gr] ] + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + + +-- | Register's passed up the tree. If the stix code forces the register +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. +-- +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + + +swizzleRegisterRep :: Register -> Format -> Register +swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code +swizzleRegisterRep (Any _ codefn) format = Any format codefn + +getLocalRegReg :: LocalReg -> Reg +getLocalRegReg (LocalReg u pk) + = RegVirtual (mkVirtualReg u (cmmTypeFormat pk)) + +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal local_reg) + = getLocalRegReg local_reg + +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform (globalRegUse_reg mid) of + Just reg -> RegReal reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence ... + +-- | Convert a BlockId to some CmmStatic data +jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic +jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = blockLbl blockid + + + +-- ----------------------------------------------------------------------------- +-- General things for putting together code sequences + +-- Expand CmmRegOff. ToDo: should we do it this way around, or convert +-- CmmExprs into CmmRegOff? +mangleIndexTree :: CmmExpr -> CmmExpr +mangleIndexTree (CmmRegOff reg off) + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType reg) + +mangleIndexTree _ + = panic "PPC.CodeGen.mangleIndexTree: no match" + +-- ----------------------------------------------------------------------------- +-- Code gen for 64-bit arithmetic on 32-bit platforms + +{- +Simple support for generating 64-bit code (ie, 64 bit values and 64 +bit assignments) on 32-bit platforms. Unlike the main code generator +we merely shoot for generating working code as simply as possible, and +pay little attention to code quality. Specifically, there is no +attempt to deal cleverly with the fixed-vs-floating register +distinction; all values are generated into (pairs of) floating +registers, even if this would mean some redundant reg-reg moves as a +result. Only one of the VRegUniques is returned, since it will be +of the VRegUniqueLo form, and the upper-half VReg can be determined +by applying getHiVRegFromLo to it. +-} + +-- | Compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) + +getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock) +getI64Amodes addrTree = do + Amode hi_addr addr_code <- getAmode D addrTree + case addrOffset hi_addr 4 of + Just lo_addr -> return (hi_addr, lo_addr, addr_code) + Nothing -> do (hi_ptr, code) <- getSomeReg addrTree + return (AddrRegImm hi_ptr (ImmInt 0), + AddrRegImm hi_ptr (ImmInt 4), + code) + + +assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock +assignMem_I64Code addrTree valueTree = do + (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree + RegCode64 vcode rhi rlo <- iselExpr64 valueTree + let + -- Big-endian store + mov_hi = ST II32 rhi hi_addr + mov_lo = ST II32 rlo lo_addr + return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) + + +assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock +assignReg_I64Code (CmmLocal lreg) valueTree = do + RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree + let Reg64 r_dst_hi r_dst_lo = localReg64 lreg + mov_lo = MR r_dst_lo r_src_lo + mov_hi = MR r_dst_hi r_src_hi + return ( + vcode `snocOL` mov_lo `snocOL` mov_hi + ) + +assignReg_I64Code _ _ + = panic "assignReg_I64Code(powerpc): invalid lvalue" + + +iselExpr64 :: CmmExpr -> NatM (RegCode64 InstrBlock) +iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do + (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree + Reg64 rhi rlo <- getNewReg64 + let mov_hi = LD II32 rhi hi_addr + mov_lo = LD II32 rlo lo_addr + return $ RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) + rhi rlo + +iselExpr64 (CmmReg (CmmLocal local_reg)) = do + let Reg64 hi lo = localReg64 local_reg + return (RegCode64 nilOL hi lo) + +iselExpr64 (CmmLit (CmmInt i _)) = do + Reg64 rhi rlo <- getNewReg64 + let + half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16) + half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16) + + code = toOL [ + LIS rlo (ImmInt half1), + OR rlo rlo (RIImm $ ImmInt half0), + LIS rhi (ImmInt half3), + OR rhi rhi (RIImm $ ImmInt half2) + ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + RegCode64 code2 r2hi r2lo <- iselExpr64 e2 + Reg64 rhi rlo <- getNewReg64 + let + code = code1 `appOL` + code2 `appOL` + toOL [ ADDC rlo r1lo r2lo, + ADDE rhi r1hi r2hi ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + RegCode64 code2 r2hi r2lo <- iselExpr64 e2 + Reg64 rhi rlo <- getNewReg64 + let + code = code1 `appOL` + code2 `appOL` + toOL [ SUBFC rlo r2lo (RIReg r1lo), + SUBFE rhi r2hi r1hi ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do + (expr_reg,expr_code) <- getSomeReg expr + Reg64 rhi rlo <- getNewReg64 + let mov_hi = LI rhi (ImmInt 0) + mov_lo = MR rlo expr_reg + return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) + rhi rlo + +iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do + (expr_reg,expr_code) <- getSomeReg expr + Reg64 rhi rlo <- getNewReg64 + let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31)) + mov_lo = MR rlo expr_reg + return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) + rhi rlo +iselExpr64 expr + = do + platform <- getPlatform + pprPanic "iselExpr64(powerpc)" (pdoc platform expr) + +data MinOrMax = Min | Max + +getRegister :: CmmExpr -> NatM Register +getRegister e = do config <- getConfig + getRegister' config (ncgPlatform config) e + +getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register + +getRegister' _ platform (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) + | OSAIX <- platformOS platform = do + let code dst = toOL [ LD II32 dst tocAddr ] + tocAddr = AddrRegImm toc (ImmLit (fsLit "ghc_toc_table[TC]")) + return (Any II32 code) + | target32Bit platform = do + reg <- getPicBaseNat $ archWordFormat (target32Bit platform) + return (Fixed (archWordFormat (target32Bit platform)) + reg nilOL) + | otherwise = return (Fixed II64 toc nilOL) + +getRegister' _ platform (CmmReg reg) + = return (Fixed (cmmTypeFormat (cmmRegType reg)) + (getRegisterReg platform reg) nilOL) + +getRegister' config platform tree@(CmmRegOff _ _) + = getRegister' config platform (mangleIndexTree tree) + + -- for 32-bit architectures, support some 64 -> 32 bit conversions: + -- TO_W_(x), TO_W_(x >> 32) + +getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | target32Bit platform = do + RegCode64 code _rhi rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | target32Bit platform = do + RegCode64 code _rhi rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) [x]) + | target32Bit platform = do + RegCode64 code _rhi rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x]) + | target32Bit platform = do + RegCode64 code _rhi rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ platform (CmmLoad mem pk _) + | not (isWord64 pk) = do + Amode addr addr_code <- getAmode D mem + let format = cmmTypeFormat pk + let code dst = assert ((targetClassOfReg platform dst == RcFloatOrVector) == isFloatType pk) $ + addr_code `snocOL` LD format dst addr + return (Any format code) + | not (target32Bit platform) = do + Amode addr addr_code <- getAmode DS mem + let code dst = addr_code `snocOL` LD II64 dst addr + return (Any II64 code) + + | otherwise = do -- 32-bit arch & 64-bit load + (hi_addr, lo_addr, addr_code) <- getI64Amodes mem + let code dst = addr_code + `snocOL` LD II32 dst lo_addr + `snocOL` LD II32 (getHiVRegFromLo dst) hi_addr + return (Any II64 code) + +-- catch simple cases of zero- or sign-extended load +getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _ _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _ _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _ _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _ _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) + +-- Note: there is no Load Byte Arithmetic instruction, so no signed case here + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _ _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _ _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _ _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _ _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _ _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _ _]) = do + -- lwa is DS-form. See Note [Power instruction format] + Amode addr addr_code <- getAmode DS mem + return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr)) + +getRegister' config platform (CmmMachOp (MO_RelaxedRead w) [e]) = + getRegister' config platform (CmmLoad e (cmmBits w) NaturallyAligned) + +getRegister' config platform (CmmMachOp mop [x]) -- unary MachOps + = case mop of + MO_Not rep -> triv_ucode_int rep NOT + + MO_F_Neg w -> triv_ucode_float w FNEG + MO_S_Neg w -> triv_ucode_int w NEG + + MO_FF_Conv W64 W32 -> trivialUCode FF32 FRSP x + MO_FF_Conv W32 W64 -> conversionNop FF64 x + + MO_FS_Truncate from to -> coerceFP2Int from to x + MO_SF_Round from to -> coerceInt2FP from to x + + MO_SS_Conv from to + | from >= to -> conversionNop (intFormat to) x + | otherwise -> triv_ucode_int to (EXTS (intFormat from)) + + MO_UU_Conv from to + | from >= to -> conversionNop (intFormat to) x + | otherwise -> clearLeft from to + + MO_XX_Conv _ to -> conversionNop (intFormat to) x + + MO_V_Broadcast {} -> vectorsNeedLlvm + MO_VF_Broadcast {} -> vectorsNeedLlvm + MO_VF_Neg {} -> vectorsNeedLlvm + + _ -> panic "PPC.CodeGen.getRegister: no match" + + where + vectorsNeedLlvm = + sorry "SIMD operations on PowerPC currently require the LLVM backend" + triv_ucode_int width instr = trivialUCode (intFormat width) instr x + triv_ucode_float width instr = trivialUCode (floatFormat width) instr x + + conversionNop new_format expr + = do e_code <- getRegister' config platform expr + return (swizzleRegisterRep e_code new_format) + + clearLeft from to + = do (src1, code1) <- getSomeReg x + let arch_fmt = intFormat (wordWidth platform) + arch_bits = widthInBits (wordWidth platform) + size = widthInBits from + code dst = code1 `snocOL` + CLRLI arch_fmt dst src1 (arch_bits - size) + return (Any (intFormat to) code) + +getRegister' _ _ (CmmMachOp mop [x, y]) -- dyadic PrimOps + = case mop of + MO_F_Eq _ -> condFltReg EQQ x y + MO_F_Ne _ -> condFltReg NE x y + MO_F_Gt _ -> condFltReg GTT x y + MO_F_Ge _ -> condFltReg GE x y + MO_F_Lt _ -> condFltReg LTT x y + MO_F_Le _ -> condFltReg LE x y + + MO_Eq rep -> condIntReg EQQ rep x y + MO_Ne rep -> condIntReg NE rep x y + + MO_S_Gt rep -> condIntReg GTT rep x y + MO_S_Ge rep -> condIntReg GE rep x y + MO_S_Lt rep -> condIntReg LTT rep x y + MO_S_Le rep -> condIntReg LE rep x y + + MO_U_Gt rep -> condIntReg GU rep x y + MO_U_Ge rep -> condIntReg GEU rep x y + MO_U_Lt rep -> condIntReg LU rep x y + MO_U_Le rep -> condIntReg LEU rep x y + + MO_F_Add w -> triv_float w FADD + MO_F_Sub w -> triv_float w FSUB + MO_F_Mul w -> triv_float w FMUL + MO_F_Quot w -> triv_float w FDIV + + MO_F_Min w -> minmax_float Min w x y + MO_F_Max w -> minmax_float Max w x y + + -- optimize addition with 32-bit immediate + -- (needed for PIC) + MO_Add W32 -> + case y of + CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True imm + -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep) + CmmLit lit + -> do + (src, srcCode) <- getSomeReg x + let imm = litToImm lit + code dst = srcCode `appOL` toOL [ + ADDIS dst src (HA imm), + ADD dst dst (RIImm (LO imm)) + ] + return (Any II32 code) + _ -> trivialCode W32 True ADD x y + + MO_Add rep -> trivialCode rep True ADD x y + MO_Sub rep -> + case y of + CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm) + -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep) + _ -> case x of + CmmLit (CmmInt imm _) + | Just _ <- makeImmediate rep True imm + -- subfi ('subtract from' with immediate) doesn't exist + -> trivialCode rep True SUBFC y x + _ -> trivialCodeNoImm' (intFormat rep) SUBF y x + + MO_Mul rep -> shiftMulCode rep True MULL x y + MO_S_MulMayOflo rep -> do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + format = intFormat rep + code dst = code1 `appOL` code2 + `appOL` toOL [ MULLO format dst src1 src2 + , MFOV format dst + ] + return (Any format code) + + MO_S_Quot rep -> divCode rep True x y + MO_U_Quot rep -> divCode rep False x y + + MO_S_Rem rep -> remainder rep True x y + MO_U_Rem rep -> remainder rep False x y + + MO_And rep -> case y of + (CmmLit (CmmInt imm _)) | imm == -8 || imm == -4 + -> do + (src, srcCode) <- getSomeReg x + let clear_mask = if imm == -4 then 2 else 3 + fmt = intFormat rep + code dst = srcCode + `appOL` unitOL (CLRRI fmt dst src clear_mask) + return (Any fmt code) + _ -> trivialCode rep False AND x y + MO_Or rep -> trivialCode rep False OR x y + MO_Xor rep -> trivialCode rep False XOR x y + + MO_Shl rep -> shiftMulCode rep False SL x y + MO_S_Shr rep -> srCode rep True SRA x y + MO_U_Shr rep -> srCode rep False SR x y + + MO_V_Extract {} -> vectorsNeedLlvm + MO_V_Add {} -> vectorsNeedLlvm + MO_V_Sub {} -> vectorsNeedLlvm + MO_V_Mul {} -> vectorsNeedLlvm + MO_VS_Neg {} -> vectorsNeedLlvm + MO_VF_Extract {} -> vectorsNeedLlvm + MO_VF_Add {} -> vectorsNeedLlvm + MO_VF_Sub {} -> vectorsNeedLlvm + MO_VF_Neg {} -> vectorsNeedLlvm + MO_VF_Mul {} -> vectorsNeedLlvm + MO_VF_Quot {} -> vectorsNeedLlvm + MO_V_Shuffle {} -> vectorsNeedLlvm + MO_VF_Shuffle {} -> vectorsNeedLlvm + MO_VU_Min {} -> vectorsNeedLlvm + MO_VU_Max {} -> vectorsNeedLlvm + MO_VS_Min {} -> vectorsNeedLlvm + MO_VS_Max {} -> vectorsNeedLlvm + MO_VF_Min {} -> vectorsNeedLlvm + MO_VF_Max {} -> vectorsNeedLlvm + + _ -> panic "PPC.CodeGen.getRegister: no match" + + where + vectorsNeedLlvm = + sorry "SIMD operations on PowerPC currently require the LLVM backend" + + triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register + triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y + + remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register + remainder rep sgn x y = do + let fmt = intFormat rep + tmp <- getNewRegNat fmt + code <- remainderCode rep sgn tmp x y + return (Any fmt code) + + minmax_float :: MinOrMax -> Width -> CmmExpr -> CmmExpr -> NatM Register + minmax_float m w x y = + do + (src1, src1Code) <- getSomeReg x + (src2, src2Code) <- getSomeReg y + l1 <- getBlockIdNat + l2 <- getBlockIdNat + end <- getBlockIdNat + let cond = case m of + Min -> LTT + Max -> GTT + let code dst = src1Code `appOL` src2Code `appOL` + toOL [ FCMP src1 src2 + , BCC cond l1 Nothing + , BCC ALWAYS l2 Nothing + , NEWBLOCK l2 + , MR dst src2 + , BCC ALWAYS end Nothing + , NEWBLOCK l1 + , MR dst src1 + , BCC ALWAYS end Nothing + , NEWBLOCK end + ] + return (Any (floatFormat w) code) + +getRegister' _ _ (CmmMachOp mop [x, y, z]) -- ternary PrimOps + = case mop of + + -- x86 fmadd x * y + z <> PPC fmadd rt = ra * rc + rb + -- x86 fmsub x * y - z <> PPC fmsub rt = ra * rc - rb + -- x86 fnmadd - x * y + z ~~ PPC fnmsub rt = -(ra * rc - rb) + -- x86 fnmsub - x * y - z ~~ PPC fnmadd rt = -(ra * rc + rb) + + MO_FMA variant l w | l == 1 -> + case variant of + FMAdd -> fma_code w (FMADD FMAdd) x y z + FMSub -> fma_code w (FMADD FMSub) x y z + FNMAdd -> fma_code w (FMADD FNMAdd) x y z + FNMSub -> fma_code w (FMADD FNMSub) x y z + | otherwise + -> vectorsNeedLlvm + + MO_V_Insert {} -> vectorsNeedLlvm + MO_VF_Insert {} -> vectorsNeedLlvm + + _ -> panic "PPC.CodeGen.getRegister: no match" + where + vectorsNeedLlvm = + sorry "SIMD operations on PowerPC currently require the LLVM backend" + +getRegister' _ _ (CmmLit (CmmInt i rep)) + | Just imm <- makeImmediate rep True i + = let + code dst = unitOL (LI dst imm) + in + return (Any (intFormat rep) code) + +getRegister' config _ (CmmLit (CmmFloat f frep)) = do + lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + Amode addr addr_code <- getAmode D dynRef + let format = floatFormat frep + code dst = + LDATA (Section ReadOnlyData lbl) + (CmmStaticsRaw lbl [CmmStaticLit (CmmFloat f frep)]) + `consOL` (addr_code `snocOL` LD format dst addr) + return (Any format code) + +getRegister' config platform (CmmLit lit) + | target32Bit platform + = let rep = cmmLitType platform lit + imm = litToImm lit + code dst = toOL [ + LIS dst (HA imm), + ADD dst dst (RIImm (LO imm)) + ] + in return (Any (cmmTypeFormat rep) code) + | otherwise + = do lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + Amode addr addr_code <- getAmode D dynRef + let rep = cmmLitType platform lit + format = cmmTypeFormat rep + code dst = + LDATA (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmStaticLit lit]) + `consOL` (addr_code `snocOL` LD format dst addr) + return (Any format code) + +getRegister' _ platform other = pprPanic "getRegister(ppc)" (pdoc platform other) + + -- extend?Rep: wrap integer expression of type `from` + -- in a conversion to `to` +extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr +extendSExpr from to x = CmmMachOp (MO_SS_Conv from to) [x] + +extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr +extendUExpr from to x = CmmMachOp (MO_UU_Conv from to) [x] + +-- ----------------------------------------------------------------------------- +-- The 'Amode' type: Memory addressing modes passed up the tree. + +data Amode + = Amode AddrMode InstrBlock + +{- +Now, given a tree (the argument to a CmmLoad) that references memory, +produce a suitable addressing mode. + +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... +-} + +{- Note [Power instruction format] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In some instructions the 16 bit offset must be a multiple of 4, i.e. +the two least significant bits must be zero. The "Power ISA" specification +calls these instruction formats "DS-FORM" and the instructions with +arbitrary 16 bit offsets are "D-FORM". + +The Power ISA specification document can be obtained from www.power.org. +-} +data InstrForm = D | DS + +getAmode :: InstrForm -> CmmExpr -> NatM Amode +getAmode inf tree@(CmmRegOff _ _) + = getAmode inf (mangleIndexTree tree) + +getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W32 True (-i) + = do + (reg, code) <- getSomeReg x + return (Amode (AddrRegImm reg off) code) + + +getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W32 True i + = do + (reg, code) <- getSomeReg x + return (Amode (AddrRegImm reg off) code) + +getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W64 True (-i) + = do + (reg, code) <- getSomeReg x + return (Amode (AddrRegImm reg off) code) + + +getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W64 True i + = do + (reg, code) <- getSomeReg x + return (Amode (AddrRegImm reg off) code) + +getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W64 True (-i) + = do + (reg, code) <- getSomeReg x + (reg', off', code') <- + if i `mod` 4 == 0 + then return (reg, off, code) + else do + tmp <- getNewRegNat II64 + return (tmp, ImmInt 0, + code `snocOL` ADD tmp reg (RIImm off)) + return (Amode (AddrRegImm reg' off') code') + +getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W64 True i + = do + (reg, code) <- getSomeReg x + (reg', off', code') <- + if i `mod` 4 == 0 + then return (reg, off, code) + else do + tmp <- getNewRegNat II64 + return (tmp, ImmInt 0, + code `snocOL` ADD tmp reg (RIImm off)) + return (Amode (AddrRegImm reg' off') code') + + -- optimize addition with 32-bit immediate + -- (needed for PIC) +getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit]) + = do + platform <- getPlatform + (src, srcCode) <- getSomeReg x + let imm = litToImm lit + case () of + _ | OSAIX <- platformOS platform + , isCmmLabelType lit -> + -- HA16/LO16 relocations on labels not supported on AIX + return (Amode (AddrRegImm src imm) srcCode) + | otherwise -> do + tmp <- getNewRegNat II32 + let code = srcCode `snocOL` ADDIS tmp src (HA imm) + return (Amode (AddrRegImm tmp (LO imm)) code) + where + isCmmLabelType (CmmLabel {}) = True + isCmmLabelType (CmmLabelOff {}) = True + isCmmLabelType (CmmLabelDiffOff {}) = True + isCmmLabelType _ = False + +getAmode _ (CmmLit lit) + = do + platform <- getPlatform + case platformArch platform of + ArchPPC -> do + tmp <- getNewRegNat II32 + let imm = litToImm lit + code = unitOL (LIS tmp (HA imm)) + return (Amode (AddrRegImm tmp (LO imm)) code) + _ -> do -- TODO: Load from TOC, + -- see getRegister' _ (CmmLit lit) + tmp <- getNewRegNat II64 + let imm = litToImm lit + code = toOL [ + LIS tmp (HIGHESTA imm), + OR tmp tmp (RIImm (HIGHERA imm)), + SL II64 tmp tmp (RIImm (ImmInt 32)), + ORIS tmp tmp (HA imm) + ] + return (Amode (AddrRegImm tmp (LO imm)) code) + +getAmode _ (CmmMachOp (MO_Add W32) [x, y]) + = do + (regX, codeX) <- getSomeReg x + (regY, codeY) <- getSomeReg y + return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) + +getAmode _ (CmmMachOp (MO_Add W64) [x, y]) + = do + (regX, codeX) <- getSomeReg x + (regY, codeY) <- getSomeReg y + return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) + +getAmode _ other + = do + (reg, code) <- getSomeReg other + let + off = ImmInt 0 + return (Amode (AddrRegImm reg off) code) + + +-- The 'CondCode' type: Condition codes passed up the tree. +data CondCode + = CondCode Bool Cond InstrBlock + +-- Set up a condition code for a conditional branch. + +getCondCode :: CmmExpr -> NatM CondCode + +-- almost the same as everywhere else - but we need to +-- extend small integers to 32 bit or 64 bit first + +getCondCode (CmmMachOp mop [x, y]) + = case mop of + MO_F_Eq W32 -> condFltCode EQQ x y + MO_F_Ne W32 -> condFltCode NE x y + MO_F_Gt W32 -> condFltCode GTT x y + MO_F_Ge W32 -> condFltCode GE x y + MO_F_Lt W32 -> condFltCode LTT x y + MO_F_Le W32 -> condFltCode LE x y + + MO_F_Eq W64 -> condFltCode EQQ x y + MO_F_Ne W64 -> condFltCode NE x y + MO_F_Gt W64 -> condFltCode GTT x y + MO_F_Ge W64 -> condFltCode GE x y + MO_F_Lt W64 -> condFltCode LTT x y + MO_F_Le W64 -> condFltCode LE x y + + MO_Eq rep -> condIntCode EQQ rep x y + MO_Ne rep -> condIntCode NE rep x y + + MO_S_Gt rep -> condIntCode GTT rep x y + MO_S_Ge rep -> condIntCode GE rep x y + MO_S_Lt rep -> condIntCode LTT rep x y + MO_S_Le rep -> condIntCode LE rep x y + + MO_U_Gt rep -> condIntCode GU rep x y + MO_U_Ge rep -> condIntCode GEU rep x y + MO_U_Lt rep -> condIntCode LU rep x y + MO_U_Le rep -> condIntCode LEU rep x y + + _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop) + +getCondCode _ = panic "getCondCode(2)(powerpc)" + + +-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be +-- passed back up the tree. + +condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode +condIntCode cond width x y = do + platform <- getPlatform + condIntCode' (target32Bit platform) cond width x y + +condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode + +-- simple code for 64-bit on 32-bit platforms +condIntCode' True cond W64 x y + | condUnsigned cond + = do + RegCode64 code_x x_hi x_lo <- iselExpr64 x + RegCode64 code_y y_hi y_lo <- iselExpr64 y + end_lbl <- getBlockIdNat + let code = code_x `appOL` code_y `appOL` toOL + [ CMPL II32 x_hi (RIReg y_hi) + , BCC NE end_lbl Nothing + , CMPL II32 x_lo (RIReg y_lo) + , BCC ALWAYS end_lbl Nothing + + , NEWBLOCK end_lbl + ] + return (CondCode False cond code) + | otherwise + = do + RegCode64 code_x x_hi x_lo <- iselExpr64 x + RegCode64 code_y y_hi y_lo <- iselExpr64 y + end_lbl <- getBlockIdNat + cmp_lo <- getBlockIdNat + let code = code_x `appOL` code_y `appOL` toOL + [ CMP II32 x_hi (RIReg y_hi) + , BCC NE end_lbl Nothing + , CMP II32 x_hi (RIImm (ImmInt 0)) + , BCC LE cmp_lo Nothing + , CMPL II32 x_lo (RIReg y_lo) + , BCC ALWAYS end_lbl Nothing + , NEWBLOCK cmp_lo + , CMPL II32 y_lo (RIReg x_lo) + , BCC ALWAYS end_lbl Nothing + + , NEWBLOCK end_lbl + ] + return (CondCode False cond code) + +-- optimize pointer tag checks. Operation andi. sets condition register +-- so cmpi ..., 0 is redundant. +condIntCode' _ cond _ (CmmMachOp (MO_And _) [x, CmmLit (CmmInt imm rep)]) + (CmmLit (CmmInt 0 _)) + | not $ condUnsigned cond, + Just src2 <- makeImmediate rep False imm + = do + (src1, code) <- getSomeReg x + let code' = code `snocOL` AND r0 src1 (RIImm src2) + return (CondCode False cond code') + +condIntCode' _ cond width x (CmmLit (CmmInt y rep)) + | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y + = do + let op_len = max W32 width + let extend = if condUnsigned cond then extendUExpr width op_len + else extendSExpr width op_len + (src1, code) <- getSomeReg (extend x) + let format = intFormat op_len + code' = code `snocOL` + (if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2) + return (CondCode False cond code') + +condIntCode' _ cond width x y = do + let op_len = max W32 width + let extend = if condUnsigned cond then extendUExpr width op_len + else extendSExpr width op_len + (src1, code1) <- getSomeReg (extend x) + (src2, code2) <- getSomeReg (extend y) + let format = intFormat op_len + code' = code1 `appOL` code2 `snocOL` + (if condUnsigned cond then CMPL else CMP) format src1 (RIReg src2) + return (CondCode False cond code') + +condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode +condFltCode cond x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code' = code1 `appOL` code2 `snocOL` FCMP src1 src2 + code'' = case cond of -- twiddle CR to handle unordered case + GE -> code' `snocOL` CRNOR ltbit eqbit gtbit + LE -> code' `snocOL` CRNOR gtbit eqbit ltbit + _ -> code' + where + ltbit = 0 ; eqbit = 2 ; gtbit = 1 + return (CondCode True cond code'') + + + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_IntCode pk addr src = do + (srcReg, code) <- getSomeReg src + Amode dstAddr addr_code <- case pk of + II64 -> getAmode DS addr + _ -> getAmode D addr + return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr + +-- dst is a reg, but src could be anything +assignReg_IntCode _ reg src + = do + platform <- getPlatform + let dst = getRegisterReg platform reg + r <- getRegister src + return $ case r of + Any _ code -> code dst + Fixed _ freg fcode -> fcode `snocOL` MR dst freg + + + +-- Easy, isn't it? +assignMem_FltCode = assignMem_IntCode +assignReg_FltCode = assignReg_IntCode + + + +genJump :: CmmExpr{-the branch target-} -> [RegWithFormat] -> NatM InstrBlock + +genJump (CmmLit (CmmLabel lbl)) regs + = return (unitOL $ JMP lbl regs) + +genJump tree gregs + = do + platform <- getPlatform + genJump' tree (platformToGCP platform) gregs + +genJump' :: CmmExpr -> GenCCallPlatform -> [RegWithFormat] -> NatM InstrBlock + +genJump' tree (GCP64ELF 1) regs + = do + (target,code) <- getSomeReg tree + return (code + `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0)) + `snocOL` LD II64 toc (AddrRegImm target (ImmInt 8)) + `snocOL` MTCTR r11 + `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16)) + `snocOL` BCTR [] Nothing regs) + +genJump' tree (GCP64ELF 2) regs + = do + (target,code) <- getSomeReg tree + return (code + `snocOL` MR r12 target + `snocOL` MTCTR r12 + `snocOL` BCTR [] Nothing regs) + +genJump' tree _ regs + = do + (target,code) <- getSomeReg tree + return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing regs) + +-- ----------------------------------------------------------------------------- +-- Unconditional branches +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + + +-- ----------------------------------------------------------------------------- +-- Conditional jumps + +{- +Conditional jumps are always to local labels, so we can use branch +instructions. We peek at the arguments to decide what kind of +comparison to do. +-} + + +genCondJump + :: BlockId -- the branch target + -> CmmExpr -- the condition on which to branch + -> Maybe Bool + -> NatM InstrBlock + +genCondJump id bool prediction = do + CondCode _ cond code <- getCondCode bool + return (code `snocOL` BCC cond id prediction) + + + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +-- Now the biggest nightmare---calls. Most of the nastiness is buried in +-- @get_arg@, which moves the arguments to the correct registers/stack +-- locations. Apart from that, the code is easy. + +genCCall :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall (PrimTarget MO_AcquireFence) _ _ + = return $ unitOL LWSYNC +genCCall (PrimTarget MO_ReleaseFence) _ _ + = return $ unitOL LWSYNC +genCCall (PrimTarget MO_SeqCstFence) _ _ + = return $ unitOL HWSYNC + +genCCall (PrimTarget MO_Touch) _ _ + = return $ nilOL + +genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ + = return $ nilOL + +genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] + = do let fmt = intFormat width + reg_dst = getLocalRegReg dst + (instr, n_code) <- case amop of + AMO_Add -> getSomeRegOrImm ADD True reg_dst + AMO_Sub -> case n of + CmmLit (CmmInt i _) + | Just imm <- makeImmediate width True (-i) + -> return (ADD reg_dst reg_dst (RIImm imm), nilOL) + _ + -> do + (n_reg, n_code) <- getSomeReg n + return (SUBF reg_dst n_reg reg_dst, n_code) + AMO_And -> getSomeRegOrImm AND False reg_dst + AMO_Nand -> do (n_reg, n_code) <- getSomeReg n + return (NAND reg_dst reg_dst n_reg, n_code) + AMO_Or -> getSomeRegOrImm OR False reg_dst + AMO_Xor -> getSomeRegOrImm XOR False reg_dst + Amode addr_reg addr_code <- getAmodeIndex addr + lbl_retry <- getBlockIdNat + return $ n_code `appOL` addr_code + `appOL` toOL [ HWSYNC + , BCC ALWAYS lbl_retry Nothing + + , NEWBLOCK lbl_retry + , LDR fmt reg_dst addr_reg + , instr + , STC fmt reg_dst addr_reg + , BCC NE lbl_retry (Just False) + , ISYNC + ] + where + getAmodeIndex (CmmMachOp (MO_Add _) [x, y]) + = do + (regX, codeX) <- getSomeReg x + (regY, codeY) <- getSomeReg y + return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) + getAmodeIndex other + = do + (reg, code) <- getSomeReg other + return (Amode (AddrRegReg r0 reg) code) -- NB: r0 is 0 here! + getSomeRegOrImm op sign dst + = case n of + CmmLit (CmmInt i _) | Just imm <- makeImmediate width sign i + -> return (op dst dst (RIImm imm), nilOL) + _ + -> do + (n_reg, n_code) <- getSomeReg n + return (op dst dst (RIReg n_reg), n_code) + +genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr] + = do let fmt = intFormat width + reg_dst = getLocalRegReg dst + form = if widthInBits width == 64 then DS else D + Amode addr_reg addr_code <- getAmode form addr + lbl_end <- getBlockIdNat + return $ addr_code `appOL` toOL [ HWSYNC + , LD fmt reg_dst addr_reg + , CMP fmt reg_dst (RIReg reg_dst) + , BCC NE lbl_end (Just False) + , BCC ALWAYS lbl_end Nothing + -- See Note [Seemingly useless cmp and bne] + , NEWBLOCK lbl_end + , ISYNC + ] + +-- Note [Seemingly useless cmp and bne] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In Power ISA, Book II, Section 4.4.1, Instruction Synchronize Instruction +-- the second paragraph says that isync may complete before storage accesses +-- "associated" with a preceding instruction have been performed. The cmp +-- operation and the following bne introduce a data and control dependency +-- on the load instruction (See also Power ISA, Book II, Appendix B.2.3, Safe +-- Fetch). +-- This is also what gcc does. + + +genCCall (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do + code <- assignMem_IntCode (intFormat width) addr val + return $ unitOL HWSYNC `appOL` code + +genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] + | width == W32 || width == W64 + = do + (old_reg, old_code) <- getSomeReg old + (new_reg, new_code) <- getSomeReg new + (addr_reg, addr_code) <- getSomeReg addr + lbl_retry <- getBlockIdNat + lbl_eq <- getBlockIdNat + lbl_end <- getBlockIdNat + let reg_dst = getLocalRegReg dst + code = toOL + [ HWSYNC + , BCC ALWAYS lbl_retry Nothing + , NEWBLOCK lbl_retry + , LDR format reg_dst (AddrRegReg r0 addr_reg) + , CMP format reg_dst (RIReg old_reg) + , BCC NE lbl_end Nothing + , BCC ALWAYS lbl_eq Nothing + , NEWBLOCK lbl_eq + , STC format new_reg (AddrRegReg r0 addr_reg) + , BCC NE lbl_retry Nothing + , BCC ALWAYS lbl_end Nothing + , NEWBLOCK lbl_end + , ISYNC + ] + return $ addr_code `appOL` new_code `appOL` old_code `appOL` code + where + format = intFormat width + + +genCCall (PrimTarget (MO_Clz width)) [dst] [src] + = do platform <- getPlatform + let reg_dst = getLocalRegReg dst + if target32Bit platform && width == W64 + then do + RegCode64 code vr_hi vr_lo <- iselExpr64 src + lbl1 <- getBlockIdNat + lbl2 <- getBlockIdNat + lbl3 <- getBlockIdNat + let cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0)) + , BCC NE lbl2 Nothing + , BCC ALWAYS lbl1 Nothing + + , NEWBLOCK lbl1 + , CNTLZ II32 reg_dst vr_lo + , ADD reg_dst reg_dst (RIImm (ImmInt 32)) + , BCC ALWAYS lbl3 Nothing + + , NEWBLOCK lbl2 + , CNTLZ II32 reg_dst vr_hi + , BCC ALWAYS lbl3 Nothing + + , NEWBLOCK lbl3 + ] + return $ code `appOL` cntlz + else do + let format = if width == W64 then II64 else II32 + (s_reg, s_code) <- getSomeReg src + (pre, reg , post) <- + case width of + W64 -> return (nilOL, s_reg, nilOL) + W32 -> return (nilOL, s_reg, nilOL) + W16 -> do + reg_tmp <- getNewRegNat format + return + ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535)) + , reg_tmp + , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-16))) + ) + W8 -> do + reg_tmp <- getNewRegNat format + return + ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255)) + , reg_tmp + , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-24))) + ) + _ -> panic "genCall: Clz wrong format" + let cntlz = unitOL (CNTLZ format reg_dst reg) + return $ s_code `appOL` pre `appOL` cntlz `appOL` post + +genCCall (PrimTarget (MO_Ctz width)) [dst] [src] + = do platform <- getPlatform + let reg_dst = getLocalRegReg dst + if target32Bit platform && width == W64 + then do + let format = II32 + RegCode64 code vr_hi vr_lo <- iselExpr64 src + lbl1 <- getBlockIdNat + lbl2 <- getBlockIdNat + lbl3 <- getBlockIdNat + x' <- getNewRegNat format + x'' <- getNewRegNat format + r' <- getNewRegNat format + cnttzlo <- cnttz format reg_dst vr_lo + let cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0)) + , BCC NE lbl2 Nothing + , BCC ALWAYS lbl1 Nothing + + , NEWBLOCK lbl1 + , ADD x' vr_hi (RIImm (ImmInt (-1))) + , ANDC x'' x' vr_hi + , CNTLZ format r' x'' + -- 32 + (32 - clz(x'')) + , SUBFC reg_dst r' (RIImm (ImmInt 64)) + , BCC ALWAYS lbl3 Nothing + + , NEWBLOCK lbl2 + ] + `appOL` cnttzlo `appOL` + toOL [ BCC ALWAYS lbl3 Nothing + + , NEWBLOCK lbl3 + ] + return $ code `appOL` cnttz64 + else do + let format = if width == W64 then II64 else II32 + (s_reg, s_code) <- getSomeReg src + (reg_ctz, pre_code) <- + case width of + W64 -> return (s_reg, nilOL) + W32 -> return (s_reg, nilOL) + W16 -> do + reg_tmp <- getNewRegNat format + return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1)) + W8 -> do + reg_tmp <- getNewRegNat format + return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256))) + _ -> panic "genCall: Ctz wrong format" + ctz_code <- cnttz format reg_dst reg_ctz + return $ s_code `appOL` pre_code `appOL` ctz_code + where + -- cnttz(x) = sizeof(x) - cntlz(~x & (x - 1)) + -- see Henry S. Warren, Hacker's Delight, p 107 + cnttz format dst src = do + let format_bits = 8 * formatInBytes format + x' <- getNewRegNat format + x'' <- getNewRegNat format + r' <- getNewRegNat format + return $ toOL [ ADD x' src (RIImm (ImmInt (-1))) + , ANDC x'' x' src + , CNTLZ format r' x'' + , SUBFC dst r' (RIImm (ImmInt (format_bits))) + ] + +genCCall target dest_regs argsAndHints + = do platform <- getPlatform + case target of + PrimTarget (MO_S_QuotRem width) -> divOp1 True width + dest_regs argsAndHints + PrimTarget (MO_U_QuotRem width) -> divOp1 False width + dest_regs argsAndHints + PrimTarget (MO_U_QuotRem2 width) -> divOp2 width dest_regs + argsAndHints + PrimTarget (MO_U_Mul2 width) -> multOp2 width dest_regs + argsAndHints + PrimTarget (MO_Add2 _) -> add2Op dest_regs argsAndHints + PrimTarget (MO_AddWordC _) -> addcOp dest_regs argsAndHints + PrimTarget (MO_SubWordC _) -> subcOp dest_regs argsAndHints + PrimTarget (MO_AddIntC width) -> addSubCOp ADDO width + dest_regs argsAndHints + PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO width + dest_regs argsAndHints + PrimTarget MO_F64_Fabs -> fabs dest_regs argsAndHints + PrimTarget MO_F32_Fabs -> fabs dest_regs argsAndHints + _ -> do config <- getConfig + genCCall' config (platformToGCP platform) + target dest_regs argsAndHints + where divOp1 signed width [res_q, res_r] [arg_x, arg_y] + = do let reg_q = getLocalRegReg res_q + reg_r = getLocalRegReg res_r + remainderCode width signed reg_q arg_x arg_y + <*> pure reg_r + + divOp1 _ _ _ _ + = panic "genCCall: Wrong number of arguments for divOp1" + divOp2 width [res_q, res_r] + [arg_x_high, arg_x_low, arg_y] + = do let reg_q = getLocalRegReg res_q + reg_r = getLocalRegReg res_r + fmt = intFormat width + half = 4 * (formatInBytes fmt) + (xh_reg, xh_code) <- getSomeReg arg_x_high + (xl_reg, xl_code) <- getSomeReg arg_x_low + (y_reg, y_code) <- getSomeReg arg_y + s <- getNewRegNat fmt + b <- getNewRegNat fmt + v <- getNewRegNat fmt + vn1 <- getNewRegNat fmt + vn0 <- getNewRegNat fmt + un32 <- getNewRegNat fmt + tmp <- getNewRegNat fmt + un10 <- getNewRegNat fmt + un1 <- getNewRegNat fmt + un0 <- getNewRegNat fmt + q1 <- getNewRegNat fmt + rhat <- getNewRegNat fmt + tmp1 <- getNewRegNat fmt + q0 <- getNewRegNat fmt + un21 <- getNewRegNat fmt + again1 <- getBlockIdNat + no1 <- getBlockIdNat + then1 <- getBlockIdNat + endif1 <- getBlockIdNat + again2 <- getBlockIdNat + no2 <- getBlockIdNat + then2 <- getBlockIdNat + endif2 <- getBlockIdNat + return $ y_code `appOL` xl_code `appOL` xh_code `appOL` + -- see Hacker's Delight p 196 Figure 9-3 + toOL [ -- b = 2 ^ (bits_in_word / 2) + LI b (ImmInt 1) + , SL fmt b b (RIImm (ImmInt half)) + -- s = clz(y) + , CNTLZ fmt s y_reg + -- v = y << s + , SL fmt v y_reg (RIReg s) + -- vn1 = upper half of v + , SR fmt vn1 v (RIImm (ImmInt half)) + -- vn0 = lower half of v + , CLRLI fmt vn0 v half + -- un32 = (u1 << s) + -- | (u0 >> (bits_in_word - s)) + , SL fmt un32 xh_reg (RIReg s) + , SUBFC tmp s + (RIImm (ImmInt (8 * formatInBytes fmt))) + , SR fmt tmp xl_reg (RIReg tmp) + , OR un32 un32 (RIReg tmp) + -- un10 = u0 << s + , SL fmt un10 xl_reg (RIReg s) + -- un1 = upper half of un10 + , SR fmt un1 un10 (RIImm (ImmInt half)) + -- un0 = lower half of un10 + , CLRLI fmt un0 un10 half + -- q1 = un32/vn1 + , DIV fmt False q1 un32 vn1 + -- rhat = un32 - q1*vn1 + , MULL fmt tmp q1 (RIReg vn1) + , SUBF rhat tmp un32 + , BCC ALWAYS again1 Nothing + + , NEWBLOCK again1 + -- if (q1 >= b || q1*vn0 > b*rhat + un1) + , CMPL fmt q1 (RIReg b) + , BCC GEU then1 Nothing + , BCC ALWAYS no1 Nothing + + , NEWBLOCK no1 + , MULL fmt tmp q1 (RIReg vn0) + , SL fmt tmp1 rhat (RIImm (ImmInt half)) + , ADD tmp1 tmp1 (RIReg un1) + , CMPL fmt tmp (RIReg tmp1) + , BCC LEU endif1 Nothing + , BCC ALWAYS then1 Nothing + + , NEWBLOCK then1 + -- q1 = q1 - 1 + , ADD q1 q1 (RIImm (ImmInt (-1))) + -- rhat = rhat + vn1 + , ADD rhat rhat (RIReg vn1) + -- if (rhat < b) goto again1 + , CMPL fmt rhat (RIReg b) + , BCC LTT again1 Nothing + , BCC ALWAYS endif1 Nothing + + , NEWBLOCK endif1 + -- un21 = un32*b + un1 - q1*v + , SL fmt un21 un32 (RIImm (ImmInt half)) + , ADD un21 un21 (RIReg un1) + , MULL fmt tmp q1 (RIReg v) + , SUBF un21 tmp un21 + -- compute second quotient digit + -- q0 = un21/vn1 + , DIV fmt False q0 un21 vn1 + -- rhat = un21- q0*vn1 + , MULL fmt tmp q0 (RIReg vn1) + , SUBF rhat tmp un21 + , BCC ALWAYS again2 Nothing + + , NEWBLOCK again2 + -- if (q0>b || q0*vn0 > b*rhat + un0) + , CMPL fmt q0 (RIReg b) + , BCC GEU then2 Nothing + , BCC ALWAYS no2 Nothing + + , NEWBLOCK no2 + , MULL fmt tmp q0 (RIReg vn0) + , SL fmt tmp1 rhat (RIImm (ImmInt half)) + , ADD tmp1 tmp1 (RIReg un0) + , CMPL fmt tmp (RIReg tmp1) + , BCC LEU endif2 Nothing + , BCC ALWAYS then2 Nothing + + , NEWBLOCK then2 + -- q0 = q0 - 1 + , ADD q0 q0 (RIImm (ImmInt (-1))) + -- rhat = rhat + vn1 + , ADD rhat rhat (RIReg vn1) + -- if (rhat> s + , SL fmt reg_r un21 (RIImm (ImmInt half)) + , ADD reg_r reg_r (RIReg un0) + , MULL fmt tmp q0 (RIReg v) + , SUBF reg_r tmp reg_r + , SR fmt reg_r reg_r (RIReg s) + -- compute quotient + -- q = q1*b + q0 + , SL fmt reg_q q1 (RIImm (ImmInt half)) + , ADD reg_q reg_q (RIReg q0) + ] + divOp2 _ _ _ + = panic "genCCall: Wrong number of arguments for divOp2" + multOp2 width [res_h, res_l] [arg_x, arg_y] + = do let reg_h = getLocalRegReg res_h + reg_l = getLocalRegReg res_l + fmt = intFormat width + (x_reg, x_code) <- getSomeReg arg_x + (y_reg, y_code) <- getSomeReg arg_y + return $ y_code `appOL` x_code + `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg) + , MULHU fmt reg_h x_reg y_reg + ] + multOp2 _ _ _ + = panic "genCall: Wrong number of arguments for multOp2" + add2Op [res_h, res_l] [arg_x, arg_y] + = do let reg_h = getLocalRegReg res_h + reg_l = getLocalRegReg res_l + (x_reg, x_code) <- getSomeReg arg_x + (y_reg, y_code) <- getSomeReg arg_y + return $ y_code `appOL` x_code + `appOL` toOL [ LI reg_h (ImmInt 0) + , ADDC reg_l x_reg y_reg + , ADDZE reg_h reg_h + ] + add2Op _ _ + = panic "genCCall: Wrong number of arguments/results for add2" + + addcOp [res_r, res_c] [arg_x, arg_y] + = add2Op [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y] + addcOp _ _ + = panic "genCCall: Wrong number of arguments/results for addc" + + -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1, + -- which is 0 for borrow and 1 otherwise. We need 1 and 0 + -- so xor with 1. + subcOp [res_r, res_c] [arg_x, arg_y] + = do let reg_r = getLocalRegReg res_r + reg_c = getLocalRegReg res_c + (x_reg, x_code) <- getSomeReg arg_x + (y_reg, y_code) <- getSomeReg arg_y + return $ y_code `appOL` x_code + `appOL` toOL [ LI reg_c (ImmInt 0) + , SUBFC reg_r y_reg (RIReg x_reg) + , ADDZE reg_c reg_c + , XOR reg_c reg_c (RIImm (ImmInt 1)) + ] + subcOp _ _ + = panic "genCCall: Wrong number of arguments/results for subc" + addSubCOp instr width [res_r, res_c] [arg_x, arg_y] + = do let reg_r = getLocalRegReg res_r + reg_c = getLocalRegReg res_c + (x_reg, x_code) <- getSomeReg arg_x + (y_reg, y_code) <- getSomeReg arg_y + return $ y_code `appOL` x_code + `appOL` toOL [ instr reg_r y_reg x_reg, + -- SUBFO argument order reversed! + MFOV (intFormat width) reg_c + ] + addSubCOp _ _ _ _ + = panic "genCall: Wrong number of arguments/results for addC" + fabs [res] [arg] + = do let res_r = getLocalRegReg res + (arg_reg, arg_code) <- getSomeReg arg + return $ arg_code `snocOL` FABS res_r arg_reg + fabs _ _ + = panic "genCall: Wrong number of arguments/results for fabs" + +-- TODO: replace 'Int' by an enum such as 'PPC_64ABI' +data GenCCallPlatform = GCP32ELF | GCP64ELF !Int | GCPAIX + +platformToGCP :: Platform -> GenCCallPlatform +platformToGCP platform + = case platformOS platform of + OSAIX -> GCPAIX + _ -> case platformArch platform of + ArchPPC -> GCP32ELF + ArchPPC_64 ELF_V1 -> GCP64ELF 1 + ArchPPC_64 ELF_V2 -> GCP64ELF 2 + _ -> panic "platformToGCP: Not PowerPC" + + +genCCall' + :: NCGConfig + -> GenCCallPlatform + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + +{- + PowerPC Linux uses the System V Release 4 Calling Convention + for PowerPC. It is described in the + "System V Application Binary Interface PowerPC Processor Supplement". + + PowerPC 64 Linux uses the System V Release 4 Calling Convention for + 64-bit PowerPC. It is specified in + "64-bit PowerPC ELF Application Binary Interface Supplement 1.9" + (PPC64 ELF v1.9). + + PowerPC 64 Linux in little endian mode uses the "Power Architecture 64-Bit + ELF V2 ABI Specification -- OpenPOWER ABI for Linux Supplement" + (PPC64 ELF v2). + + AIX follows the "PowerOpen ABI: Application Binary Interface Big-Endian + 32-Bit Hardware Implementation" + + All four conventions are similar: + Parameters may be passed in general-purpose registers starting at r3, in + floating point registers starting at f1, or on the stack. + + But there are substantial differences: + * The number of registers used for parameter passing and the exact set of + nonvolatile registers differs (see MachRegs.hs). + * On AIX and 64-bit ELF, stack space is always reserved for parameters, + even if they are passed in registers. The called routine may choose to + save parameters from registers to the corresponding space on the stack. + * On AIX and 64-bit ELF, a corresponding amount of GPRs is skipped when + a floating point parameter is passed in an FPR. + * SysV insists on either passing I64 arguments on the stack, or in two GPRs, + starting with an odd-numbered GPR. It may skip a GPR to achieve this. + AIX just treats an I64 likt two separate I32s (high word first). + * I64 and FF64 arguments are 8-byte aligned on the stack for SysV, but only + 4-byte aligned like everything else on AIX. + * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on + PowerPC Linux does not agree, so neither do we. + + According to all conventions, the parameter area should be part of the + caller's stack frame, allocated in the caller's prologue code (large enough + to hold the parameter lists for all called routines). The NCG already + uses the stack for register spilling, leaving 64 bytes free at the top. + If we need a larger parameter area than that, we increase the size + of the stack frame just before ccalling. +-} + + +genCCall' config gcp target dest_regs args + = do + (finalStack,passArgumentsCode,usedRegs) <- passArguments + (zip3 args argReps argHints) + allArgRegs + (allFPArgRegs platform) + initialStackOffset + nilOL [] + + (labelOrExpr, reduceToFF32) <- case target of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do + uses_pic_base_implicitly + return (Left lbl, False) + ForeignTarget expr _ -> do + uses_pic_base_implicitly + return (Right expr, False) + PrimTarget mop -> outOfLineMachOp mop + + let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode + codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 + + case labelOrExpr of + Left lbl -> -- the linker does all the work for us + return ( codeBefore + `snocOL` BL lbl usedRegs + `appOL` maybeNOP -- some ABI require a NOP after BL + `appOL` codeAfter) + Right dyn -> do -- implement call through function pointer + (dynReg, dynCode) <- getSomeReg dyn + case gcp of + GCP64ELF 1 -> return ( dynCode + `appOL` codeBefore + `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 40)) + `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 0)) + `snocOL` LD II64 toc (AddrRegImm dynReg (ImmInt 8)) + `snocOL` MTCTR r11 + `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 16)) + `snocOL` BCTRL usedRegs + `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 40)) + `appOL` codeAfter) + GCP64ELF 2 -> return ( dynCode + `appOL` codeBefore + `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 24)) + `snocOL` MR r12 dynReg + `snocOL` MTCTR r12 + `snocOL` BCTRL usedRegs + `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 24)) + `appOL` codeAfter) + GCPAIX -> return ( dynCode + -- AIX/XCOFF follows the PowerOPEN ABI + -- which is quite similar to LinuxPPC64/ELFv1 + `appOL` codeBefore + `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20)) + `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0)) + `snocOL` LD II32 toc (AddrRegImm dynReg (ImmInt 4)) + `snocOL` MTCTR r11 + `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 8)) + `snocOL` BCTRL usedRegs + `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 20)) + `appOL` codeAfter) + _ -> return ( dynCode + `snocOL` MTCTR dynReg + `appOL` codeBefore + `snocOL` BCTRL usedRegs + `appOL` codeAfter) + where + platform = ncgPlatform config + + uses_pic_base_implicitly = + -- See Note [implicit register in PPC PIC code] + -- on why we claim to use PIC register here + when (ncgPIC config && target32Bit platform) $ do + _ <- getPicBaseNat $ archWordFormat True + return () + + initialStackOffset = case gcp of + GCPAIX -> 24 + GCP32ELF -> 8 + GCP64ELF 1 -> 48 + GCP64ELF 2 -> 32 + _ -> panic "genCall': unknown calling convention" + -- size of linkage area + size of arguments, in bytes + stackDelta finalStack = case gcp of + GCPAIX -> + roundTo 16 $ (24 +) $ max 32 $ sum $ + map (widthInBytes . typeWidth) argReps + GCP32ELF -> roundTo 16 finalStack + GCP64ELF 1 -> + roundTo 16 $ (48 +) $ max 64 $ sum $ + map (roundTo 8 . widthInBytes . typeWidth) + argReps + GCP64ELF 2 -> + roundTo 16 $ (32 +) $ max 64 $ sum $ + map (roundTo 8 . widthInBytes . typeWidth) + argReps + _ -> panic "genCall': unknown calling conv." + + argReps = map (cmmExprType platform) args + (_, argHints) = foreignTargetHints target + + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) + + spFormat = if target32Bit platform then II32 else II64 + + -- TODO: Do not create a new stack frame if delta is too large. + move_sp_down finalStack + | delta > stackFrameHeaderSize platform = + toOL [STU spFormat sp (AddrRegImm sp (ImmInt (-delta))), + DELTA (-delta)] + | otherwise = nilOL + where delta = stackDelta finalStack + move_sp_up finalStack + | delta > stackFrameHeaderSize platform = + toOL [ADD sp sp (RIImm (ImmInt delta)), + DELTA 0] + | otherwise = nilOL + where delta = stackDelta finalStack + + -- A NOP instruction is required after a call (bl instruction) + -- on AIX and 64-Bit Linux. + -- If the call is to a function with a different TOC (r2) the + -- link editor replaces the NOP instruction with a load of the TOC + -- from the stack to restore the TOC. + maybeNOP = case gcp of + GCP32ELF -> nilOL + -- See Section 3.9.4 of OpenPower ABI + GCPAIX -> unitOL NOP + -- See Section 3.5.11 of PPC64 ELF v1.9 + GCP64ELF 1 -> unitOL NOP + -- See Section 2.3.6 of PPC64 ELF v2 + GCP64ELF 2 -> unitOL NOP + _ -> panic "maybeNOP: Unknown PowerPC 64-bit ABI" + + passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed) + passArguments ((arg,arg_ty,_):args) gprs fprs stackOffset + accumCode accumUsed | isWord64 arg_ty + && target32Bit (ncgPlatform config) = + do + RegCode64 code vr_hi vr_lo <- iselExpr64 arg + + case gcp of + GCPAIX -> + do let storeWord vr (gpr:_) _ = MR gpr vr + storeWord vr [] offset + = ST II32 vr (AddrRegImm sp (ImmInt offset)) + passArguments args + (drop 2 gprs) + fprs + (stackOffset+8) + (accumCode `appOL` code + `snocOL` storeWord vr_hi gprs stackOffset + `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4)) + ((take 2 gprs) ++ accumUsed) + GCP32ELF -> + do let stackOffset' = roundTo 8 stackOffset + stackCode = accumCode `appOL` code + `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset')) + `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4))) + regCode hireg loreg = + accumCode `appOL` code + `snocOL` MR hireg vr_hi + `snocOL` MR loreg vr_lo + + case gprs of + hireg : loreg : regs | even (length gprs) -> + passArguments args regs fprs stackOffset + (regCode hireg loreg) (hireg : loreg : accumUsed) + _skipped : hireg : loreg : regs -> + passArguments args regs fprs stackOffset + (regCode hireg loreg) (hireg : loreg : accumUsed) + _ -> -- only one or no regs left + passArguments args [] fprs (stackOffset'+8) + stackCode accumUsed + GCP64ELF _ -> panic "passArguments: 32 bit code" + + passArguments ((arg,rep,hint):args) gprs fprs stackOffset accumCode accumUsed + | reg : _ <- regs = do + register <- getRegister arg_pro + let code = case register of + Fixed _ freg fcode -> fcode `snocOL` MR reg freg + Any _ acode -> acode reg + stackOffsetRes = case gcp of + -- The PowerOpen ABI requires that we + -- reserve stack slots for register + -- parameters + GCPAIX -> stackOffset + stackBytes + -- ... the SysV ABI 32-bit doesn't. + GCP32ELF -> stackOffset + -- ... but SysV ABI 64-bit does. + GCP64ELF _ -> stackOffset + stackBytes + passArguments args + (drop nGprs gprs) + (drop nFprs fprs) + stackOffsetRes + (accumCode `appOL` code) + (reg : accumUsed) + | otherwise = do + (vr, code) <- getSomeReg arg_pro + passArguments args + (drop nGprs gprs) + (drop nFprs fprs) + (stackOffset' + stackBytes) + (accumCode `appOL` code + `snocOL` ST format_pro vr stackSlot) + accumUsed + where + arg_pro + | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth platform)) [arg] + | otherwise = arg + format_pro + | isBitsType rep = intFormat (wordWidth platform) + | otherwise = cmmTypeFormat rep + conv_op = case hint of + SignedHint -> MO_SS_Conv + _ -> MO_UU_Conv + + stackOffset' = case gcp of + GCPAIX -> + -- The 32bit PowerOPEN ABI is happy with + -- 32bit-alignment ... + stackOffset + GCP32ELF + -- ... the SysV ABI requires 8-byte + -- alignment for doubles. + | isFloatType rep && typeWidth rep == W64 -> + roundTo 8 stackOffset + | otherwise -> + stackOffset + GCP64ELF _ -> + -- Everything on the stack is mapped to + -- 8-byte aligned doublewords + stackOffset + stackOffset'' + | isFloatType rep && typeWidth rep == W32 = + case gcp of + -- The ELF v1 ABI Section 3.2.3 requires: + -- "Single precision floating point values + -- are mapped to the second word in a single + -- doubleword" + GCP64ELF 1 -> stackOffset' + 4 + -- ELF v2 ABI Revision 1.5 Section 2.2.3.3. requires + -- a single-precision floating-point value + -- to be mapped to the least-significant + -- word in a single doubleword. + GCP64ELF 2 -> case platformByteOrder platform of + BigEndian -> stackOffset' + 4 + LittleEndian -> stackOffset' + _ -> stackOffset' + | otherwise = stackOffset' + + stackSlot = AddrRegImm sp (ImmInt stackOffset'') + (nGprs, nFprs, stackBytes, regs) + = case gcp of + GCPAIX -> + case cmmTypeFormat rep of + II8 -> (1, 0, 4, gprs) + II16 -> (1, 0, 4, gprs) + II32 -> (1, 0, 4, gprs) + -- The PowerOpen ABI requires that we skip a + -- corresponding number of GPRs when we use + -- the FPRs. + -- + -- E.g. for a `double` two GPRs are skipped, + -- whereas for a `float` one GPR is skipped + -- when parameters are assigned to + -- registers. + -- + -- The PowerOpen ABI specification can be found at + -- ftp://www.sourceware.org/pub/binutils/ppc-docs/ppc-poweropen/ + FF32 -> (1, 1, 4, fprs) + FF64 -> (2, 1, 8, fprs) + II64 -> panic "genCCall' passArguments II64" + VecFormat {} + -> panic "genCCall' passArguments vector format" + + GCP32ELF -> + case cmmTypeFormat rep of + II8 -> (1, 0, 4, gprs) + II16 -> (1, 0, 4, gprs) + II32 -> (1, 0, 4, gprs) + -- ... the SysV ABI doesn't. + FF32 -> (0, 1, 4, fprs) + FF64 -> (0, 1, 8, fprs) + II64 -> panic "genCCall' passArguments II64" + VecFormat {} + -> panic "genCCall' passArguments vector format" + + GCP64ELF _ -> + case cmmTypeFormat rep of + II8 -> (1, 0, 8, gprs) + II16 -> (1, 0, 8, gprs) + II32 -> (1, 0, 8, gprs) + II64 -> (1, 0, 8, gprs) + -- The ELFv1 ABI requires that we skip a + -- corresponding number of GPRs when we use + -- the FPRs. + FF32 -> (1, 1, 8, fprs) + FF64 -> (1, 1, 8, fprs) + VecFormat {} + -> panic "genCCall' passArguments vector format" + + moveResult reduceToFF32 = + case dest_regs of + [] -> nilOL + [dest] + | reduceToFF32 && isFloat32 rep -> unitOL (FRSP r_dest f1) + | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1) + | isWord64 rep && target32Bit platform + -> toOL [MR (getHiVRegFromLo r_dest) r3, + MR r_dest r4] + | otherwise -> unitOL (MR r_dest r3) + where rep = cmmRegType (CmmLocal dest) + r_dest = getLocalRegReg dest + _ -> panic "genCCall' moveResult: Bad dest_regs" + + outOfLineMachOp mop = + do + mopExpr <- cmmMakeDynamicReference config CallReference $ + mkForeignLabel functionName ForeignLabelInThisPackage IsFunction + let mopLabelOrExpr = case mopExpr of + CmmLit (CmmLabel lbl) -> Left lbl + _ -> Right mopExpr + return (mopLabelOrExpr, reduce) + where + (functionName, reduce) = case mop of + MO_F32_Exp -> (fsLit "exp", True) + MO_F32_ExpM1 -> (fsLit "expm1", True) + MO_F32_Log -> (fsLit "log", True) + MO_F32_Log1P -> (fsLit "log1p", True) + MO_F32_Sqrt -> (fsLit "sqrt", True) + MO_F32_Fabs -> unsupported + + MO_F32_Sin -> (fsLit "sin", True) + MO_F32_Cos -> (fsLit "cos", True) + MO_F32_Tan -> (fsLit "tan", True) + + MO_F32_Asin -> (fsLit "asin", True) + MO_F32_Acos -> (fsLit "acos", True) + MO_F32_Atan -> (fsLit "atan", True) + + MO_F32_Sinh -> (fsLit "sinh", True) + MO_F32_Cosh -> (fsLit "cosh", True) + MO_F32_Tanh -> (fsLit "tanh", True) + MO_F32_Pwr -> (fsLit "pow", True) + + MO_F32_Asinh -> (fsLit "asinh", True) + MO_F32_Acosh -> (fsLit "acosh", True) + MO_F32_Atanh -> (fsLit "atanh", True) + + MO_F64_Exp -> (fsLit "exp", False) + MO_F64_ExpM1 -> (fsLit "expm1", False) + MO_F64_Log -> (fsLit "log", False) + MO_F64_Log1P -> (fsLit "log1p", False) + MO_F64_Sqrt -> (fsLit "sqrt", False) + MO_F64_Fabs -> unsupported + + MO_F64_Sin -> (fsLit "sin", False) + MO_F64_Cos -> (fsLit "cos", False) + MO_F64_Tan -> (fsLit "tan", False) + + MO_F64_Asin -> (fsLit "asin", False) + MO_F64_Acos -> (fsLit "acos", False) + MO_F64_Atan -> (fsLit "atan", False) + + MO_F64_Sinh -> (fsLit "sinh", False) + MO_F64_Cosh -> (fsLit "cosh", False) + MO_F64_Tanh -> (fsLit "tanh", False) + MO_F64_Pwr -> (fsLit "pow", False) + + MO_F64_Asinh -> (fsLit "asinh", False) + MO_F64_Acosh -> (fsLit "acosh", False) + MO_F64_Atanh -> (fsLit "atanh", False) + + MO_I64_ToI -> (fsLit "hs_int64ToInt", False) + MO_I64_FromI -> (fsLit "hs_intToInt64", False) + MO_W64_ToW -> (fsLit "hs_word64ToWord", False) + MO_W64_FromW -> (fsLit "hs_wordToWord64", False) + + MO_x64_Neg -> (fsLit "hs_neg64", False) + MO_x64_Add -> (fsLit "hs_add64", False) + MO_x64_Sub -> (fsLit "hs_sub64", False) + MO_x64_Mul -> (fsLit "hs_mul64", False) + MO_I64_Quot -> (fsLit "hs_quotInt64", False) + MO_I64_Rem -> (fsLit "hs_remInt64", False) + MO_W64_Quot -> (fsLit "hs_quotWord64", False) + MO_W64_Rem -> (fsLit "hs_remWord64", False) + + MO_x64_And -> (fsLit "hs_and64", False) + MO_x64_Or -> (fsLit "hs_or64", False) + MO_x64_Xor -> (fsLit "hs_xor64", False) + MO_x64_Not -> (fsLit "hs_not64", False) + MO_x64_Shl -> (fsLit "hs_uncheckedShiftL64", False) + MO_I64_Shr -> (fsLit "hs_uncheckedIShiftRA64", False) + MO_W64_Shr -> (fsLit "hs_uncheckedShiftRL64", False) + + MO_x64_Eq -> (fsLit "hs_eq64", False) + MO_x64_Ne -> (fsLit "hs_ne64", False) + MO_I64_Ge -> (fsLit "hs_geInt64", False) + MO_I64_Gt -> (fsLit "hs_gtInt64", False) + MO_I64_Le -> (fsLit "hs_leInt64", False) + MO_I64_Lt -> (fsLit "hs_ltInt64", False) + MO_W64_Ge -> (fsLit "hs_geWord64", False) + MO_W64_Gt -> (fsLit "hs_gtWord64", False) + MO_W64_Le -> (fsLit "hs_leWord64", False) + MO_W64_Lt -> (fsLit "hs_ltWord64", False) + + MO_UF_Conv w -> (word2FloatLabel w, False) + + MO_Memcpy _ -> (fsLit "memcpy", False) + MO_Memset _ -> (fsLit "memset", False) + MO_Memmove _ -> (fsLit "memmove", False) + MO_Memcmp _ -> (fsLit "memcmp", False) + + MO_SuspendThread -> (fsLit "suspendThread", False) + MO_ResumeThread -> (fsLit "resumeThread", False) + + MO_BSwap w -> (bSwapLabel w, False) + MO_BRev w -> (bRevLabel w, False) + MO_PopCnt w -> (popCntLabel w, False) + MO_Pdep w -> (pdepLabel w, False) + MO_Pext w -> (pextLabel w, False) + MO_Clz _ -> unsupported + MO_Ctz _ -> unsupported + MO_AtomicRMW {} -> unsupported + MO_Cmpxchg w -> (cmpxchgLabel w, False) + MO_Xchg w -> (xchgLabel w, False) + MO_AtomicRead _ _ -> unsupported + MO_AtomicWrite _ _ -> unsupported + + MO_S_Mul2 {} -> unsupported + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_AddWordC {} -> unsupported + MO_SubWordC {} -> unsupported + MO_AddIntC {} -> unsupported + MO_SubIntC {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_VS_Quot {} -> unsupported + MO_VS_Rem {} -> unsupported + MO_VU_Quot {} -> unsupported + MO_VU_Rem {} -> unsupported + MO_I64X2_Min -> unsupported + MO_I64X2_Max -> unsupported + MO_W64X2_Min -> unsupported + MO_W64X2_Max -> unsupported + MO_AcquireFence -> unsupported + MO_ReleaseFence -> unsupported + MO_SeqCstFence -> unsupported + MO_Touch -> unsupported + MO_Prefetch_Data _ -> unsupported + unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported") + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock +genSwitch config expr targets + | OSAIX <- platformOS platform + = do + (reg,e_code) <- getSomeReg indexExpr + let fmt = archWordFormat $ target32Bit platform + sha = if target32Bit platform then 2 else 3 + tmp <- getNewRegNat fmt + lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + (tableReg,t_code) <- getSomeReg $ dynRef + let code = e_code `appOL` t_code `appOL` toOL [ + SL fmt tmp reg (RIImm (ImmInt sha)), + LD fmt tmp (AddrRegReg tableReg tmp), + MTCTR tmp, + BCTR ids (Just lbl) [] + ] + return code + + | (ncgPIC config) || (not $ target32Bit platform) + = do + (reg,e_code) <- getSomeReg indexExpr + let fmt = archWordFormat $ target32Bit platform + sha = if target32Bit platform then 2 else 3 + tmp <- getNewRegNat fmt + lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + (tableReg,t_code) <- getSomeReg $ dynRef + let code = e_code `appOL` t_code `appOL` toOL [ + SL fmt tmp reg (RIImm (ImmInt sha)), + LD fmt tmp (AddrRegReg tableReg tmp), + ADD tmp tmp (RIReg tableReg), + MTCTR tmp, + BCTR ids (Just lbl) [] + ] + return code + | otherwise + = do + (reg,e_code) <- getSomeReg indexExpr + let fmt = archWordFormat $ target32Bit platform + sha = if target32Bit platform then 2 else 3 + tmp <- getNewRegNat fmt + lbl <- getNewLabelNat + let code = e_code `appOL` toOL [ + SL fmt tmp reg (RIImm (ImmInt sha)), + ADDIS tmp tmp (HA (ImmCLbl lbl)), + LD fmt tmp (AddrRegImm tmp (LO (ImmCLbl lbl))), + MTCTR tmp, + BCTR ids (Just lbl) [] + ] + return code + where + -- See Note [Sub-word subtlety during jump-table indexing] in + -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen. + indexExpr0 = cmmOffset platform expr offset + -- We widen to a native-width register to sanitize the high bits + indexExpr = CmmMachOp + (MO_UU_Conv expr_w (platformWordWidth platform)) + [indexExpr0] + expr_w = cmmExprWidth platform expr + (offset, ids) = switchTargetsToTable targets + platform = ncgPlatform config + +generateJumpTableForInstr :: NCGConfig -> Instr + -> Maybe (NatCmmDecl RawCmmStatics Instr) +generateJumpTableForInstr config (BCTR ids (Just lbl) _) = + let jumpTable + | (ncgPIC config) || (not $ target32Bit $ ncgPlatform config) + = map jumpTableEntryRel ids + | otherwise = map (jumpTableEntry config) ids + where jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 + (ncgWordWidth config)) + where blockLabel = blockLbl blockid + in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable)) +generateJumpTableForInstr _ _ = Nothing + +-- ----------------------------------------------------------------------------- +-- 'condIntReg' and 'condFltReg': condition codes into registers + +-- Turn those condition codes into integers now (when they appear on +-- the right hand side of an assignment). + + + +condReg :: NatM CondCode -> NatM Register +condReg getCond = do + CondCode _ cond cond_code <- getCond + platform <- getPlatform + let + code dst = cond_code + `appOL` negate_code + `appOL` toOL [ + MFCR dst, + RLWINM dst dst (bit + 1) 31 31 + ] + + negate_code | do_negate = unitOL (CRNOR bit bit bit) + | otherwise = nilOL + + (bit, do_negate) = case cond of + LTT -> (0, False) + LE -> (1, True) + EQQ -> (2, False) + GE -> (0, True) + GTT -> (1, False) + + NE -> (2, True) + + LU -> (0, False) + LEU -> (1, True) + GEU -> (0, True) + GU -> (1, False) + _ -> panic "PPC.CodeGen.codeReg: no match" + + format = archWordFormat $ target32Bit platform + return (Any format code) + +condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register +condIntReg cond width x y = condReg (condIntCode cond width x y) +condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register +condFltReg cond x y = condReg (condFltCode cond x y) + + + +-- ----------------------------------------------------------------------------- +-- 'trivial*Code': deal with trivial instructions + +-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', +-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. +-- Only look for constants on the right hand side, because that's +-- where the generic optimizer will have put them. + +-- Similarly, for unary instructions, we don't have to worry about +-- matching an StInt as the argument, because genericOpt will already +-- have handled the constant-folding. + + + +{- +Wolfgang's PowerPC version of The Rules: + +A slightly modified version of The Rules to take advantage of the fact +that PowerPC instructions work on all registers and don't implicitly +clobber any fixed registers. + +* The only expression for which getRegister returns Fixed is (CmmReg reg). + +* If getRegister returns Any, then the code it generates may modify only: + (a) fresh temporaries + (b) the destination register + It may *not* modify global registers, unless the global + register happens to be the destination register. + It may not clobber any other registers. In fact, only ccalls clobber any + fixed registers. + Also, it may not modify the counter register (used by genCCall). + + Corollary: If a getRegister for a subexpression returns Fixed, you need + not move it to a fresh temporary before evaluating the next subexpression. + The Fixed register won't be modified. + Therefore, we don't need a counterpart for the x86's getStableReg on PPC. + +* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on + the value of the destination register. +-} + +trivialCode + :: Width + -> Bool + -> (Reg -> Reg -> RI -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + +trivialCode rep signed instr x (CmmLit (CmmInt y _)) + | Just imm <- makeImmediate rep signed y + = do + (src1, code1) <- getSomeReg x + let code dst = code1 `snocOL` instr dst src1 (RIImm imm) + return (Any (intFormat rep) code) + +trivialCode rep _ instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2) + return (Any (intFormat rep) code) + +shiftMulCode + :: Width + -> Bool + -> (Format-> Reg -> Reg -> RI -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register +shiftMulCode width sign instr x (CmmLit (CmmInt y _)) + | Just imm <- makeImmediate width sign y + = do + (src1, code1) <- getSomeReg x + let format = intFormat width + let ins_fmt = intFormat (max W32 width) + let code dst = code1 `snocOL` instr ins_fmt dst src1 (RIImm imm) + return (Any format code) + +shiftMulCode width _ instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let format = intFormat width + let ins_fmt = intFormat (max W32 width) + let code dst = code1 `appOL` code2 + `snocOL` instr ins_fmt dst src1 (RIReg src2) + return (Any format code) + +trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCodeNoImm' format instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2 + return (Any format code) + +trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCodeNoImm format instr x y + = trivialCodeNoImm' format (instr format) x y + +srCode :: Width -> Bool -> (Format-> Reg -> Reg -> RI -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +srCode width sgn instr x (CmmLit (CmmInt y _)) + | Just imm <- makeImmediate width sgn y + = do + let op_len = max W32 width + extend = if sgn then extendSExpr else extendUExpr + (src1, code1) <- getSomeReg (extend width op_len x) + let code dst = code1 `snocOL` + instr (intFormat op_len) dst src1 (RIImm imm) + return (Any (intFormat width) code) + +srCode width sgn instr x y = do + let op_len = max W32 width + extend = if sgn then extendSExpr else extendUExpr + (src1, code1) <- getSomeReg (extend width op_len x) + (src2, code2) <- getSomeReg (extendUExpr width op_len y) + -- Note: Shift amount `y` is unsigned + let code dst = code1 `appOL` code2 `snocOL` + instr (intFormat op_len) dst src1 (RIReg src2) + return (Any (intFormat width) code) + +divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register +divCode width sgn x y = do + let op_len = max W32 width + extend = if sgn then extendSExpr else extendUExpr + (src1, code1) <- getSomeReg (extend width op_len x) + (src2, code2) <- getSomeReg (extend width op_len y) + let code dst = code1 `appOL` code2 `snocOL` + DIV (intFormat op_len) sgn dst src1 src2 + return (Any (intFormat width) code) + + +trivialUCode :: Format + -> (Reg -> Reg -> Instr) + -> CmmExpr + -> NatM Register +trivialUCode rep instr x = do + (src, code) <- getSomeReg x + let code' dst = code `snocOL` instr dst src + return (Any rep code') + +-- | Generate code for a 4-register FMA instruction, +-- e.g. @fmadd rt ra rc rb := rt <- ra * rc + rb@. +fma_code :: Width + -> (Format -> Reg -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register +fma_code w instr ra rc rb = do + let rep = floatFormat w + (src1, code1) <- getSomeReg ra + (src2, code2) <- getSomeReg rc + (src3, code3) <- getSomeReg rb + let instrCode rt = + code1 `appOL` + code2 `appOL` + code3 `snocOL` instr rep rt src1 src2 src3 + return $ Any rep instrCode + +-- There is no "remainder" instruction on the PPC, so we have to do +-- it the hard way. +-- The "sgn" parameter is the signedness for the division instruction +remainderCode :: Width -> Bool -> Reg -> CmmExpr -> CmmExpr + -> NatM (Reg -> InstrBlock) +remainderCode rep sgn reg_q arg_x arg_y = do + let op_len = max W32 rep + fmt = intFormat op_len + extend = if sgn then extendSExpr else extendUExpr + (x_reg, x_code) <- getSomeReg (extend rep op_len arg_x) + (y_reg, y_code) <- getSomeReg (extend rep op_len arg_y) + return $ \reg_r -> y_code `appOL` x_code + `appOL` toOL [ DIV fmt sgn reg_q x_reg y_reg + , MULL fmt reg_r reg_q (RIReg y_reg) + , SUBF reg_r reg_r x_reg + ] + + +coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register +coerceInt2FP fromRep toRep x = do + platform <- getPlatform + let arch = platformArch platform + coerceInt2FP' arch fromRep toRep x + +coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register +coerceInt2FP' ArchPPC fromRep toRep x = do + (src, code) <- getSomeReg x + lbl <- getNewLabelNat + itmp <- getNewRegNat II32 + ftmp <- getNewRegNat FF64 + config <- getConfig + platform <- getPlatform + dynRef <- cmmMakeDynamicReference config DataReference lbl + Amode addr addr_code <- getAmode D dynRef + let + code' dst = code `appOL` maybe_exts `appOL` toOL [ + LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl + [CmmStaticLit (CmmInt 0x43300000 W32), + CmmStaticLit (CmmInt 0x80000000 W32)], + XORIS itmp src (ImmInt 0x8000), + ST II32 itmp (spRel platform 3), + LIS itmp (ImmInt 0x4330), + ST II32 itmp (spRel platform 2), + LD FF64 ftmp (spRel platform 2) + ] `appOL` addr_code `appOL` toOL [ + LD FF64 dst addr, + FSUB FF64 dst ftmp dst + ] `appOL` maybe_frsp dst + + maybe_exts = case fromRep of + W8 -> unitOL $ EXTS II8 src src + W16 -> unitOL $ EXTS II16 src src + W32 -> nilOL + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + + maybe_frsp dst + = case toRep of + W32 -> unitOL $ FRSP dst dst + W64 -> nilOL + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + + return (Any (floatFormat toRep) code') + +-- On an ELF v1 Linux we use the compiler doubleword in the stack frame +-- this is the TOC pointer doubleword on ELF v2 Linux. The latter is only +-- set right before a call and restored right after return from the call. +-- So it is fine. +coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do + (src, code) <- getSomeReg x + platform <- getPlatform + upper <- getNewRegNat II64 + lower <- getNewRegNat II64 + l1 <- getBlockIdNat + l2 <- getBlockIdNat + let + code' dst = code `appOL` maybe_exts `appOL` toOL [ + ST II64 src (spRel platform 3), + LD FF64 dst (spRel platform 3), + FCFID dst dst + ] `appOL` maybe_frsp dst + + maybe_exts + = case fromRep of + W8 -> unitOL $ EXTS II8 src src + W16 -> unitOL $ EXTS II16 src src + W32 -> unitOL $ EXTS II32 src src + W64 -> case toRep of + W32 -> toOL [ SRA II64 upper src (RIImm (ImmInt 53)) + , CLRLI II64 lower src 53 + , ADD upper upper (RIImm (ImmInt 1)) + , ADD lower lower (RIImm (ImmInt 2047)) + , CMPL II64 upper (RIImm (ImmInt 2)) + , OR lower lower (RIReg src) + , CLRRI II64 lower lower 11 + , BCC LTT l2 Nothing + , BCC ALWAYS l1 Nothing + , NEWBLOCK l1 + , MR src lower + , BCC ALWAYS l2 Nothing + , NEWBLOCK l2 + ] + _ -> nilOL + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + + maybe_frsp dst + = case toRep of + W32 -> unitOL $ FRSP dst dst + W64 -> nilOL + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + + return (Any (floatFormat toRep) code') + +coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch" + + +coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register +coerceFP2Int fromRep toRep x = do + platform <- getPlatform + let arch = platformArch platform + coerceFP2Int' arch fromRep toRep x + +coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register +coerceFP2Int' ArchPPC _ toRep x = do + platform <- getPlatform + -- the reps don't really matter: F*->FF64 and II32->I* are no-ops + (src, code) <- getSomeReg x + tmp <- getNewRegNat FF64 + let + code' dst = code `appOL` toOL [ + -- convert to int in FP reg + FCTIWZ tmp src, + -- store value (64bit) from FP to stack + ST FF64 tmp (spRel platform 2), + -- read low word of value (high word is undefined) + LD II32 dst (spRel platform 3)] + return (Any (intFormat toRep) code') + +coerceFP2Int' (ArchPPC_64 _) _ toRep x = do + platform <- getPlatform + -- the reps don't really matter: F*->FF64 and II64->I* are no-ops + (src, code) <- getSomeReg x + tmp <- getNewRegNat FF64 + let + code' dst = code `appOL` toOL [ + -- convert to int in FP reg + FCTIDZ tmp src, + -- store value (64bit) from FP to compiler word on stack + ST FF64 tmp (spRel platform 3), + LD II64 dst (spRel platform 3)] + return (Any (intFormat toRep) code') + +coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch" + +-- Note [.LCTOC1 in PPC PIC code] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The .LCTOC1 label is defined to point 32768 bytes into the GOT table +-- to make the most of the PPC's 16-bit displacements. +-- As 16-bit signed offset is used (usually via addi/lwz instructions) +-- first element will have '-32768' offset against .LCTOC1. + +-- Note [implicit register in PPC PIC code] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- PPC generates calls by labels in assembly +-- in form of: +-- bl puts+32768@plt +-- in this form it's not seen directly (by GHC NCG) +-- that r30 (PicBaseReg) is used, +-- but r30 is a required part of PLT code setup: +-- puts+32768@plt: +-- lwz r11,-30484(r30) ; offset in .LCTOC1 +-- mtctr r11 +-- bctr diff --git a/GHC/CmmToAsm/PPC/Cond.hs b/GHC/CmmToAsm/PPC/Cond.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/Cond.hs @@ -0,0 +1,47 @@ +module GHC.CmmToAsm.PPC.Cond ( + Cond(..), + condNegate, + condUnsigned, +) + +where + +import GHC.Prelude + +import GHC.Utils.Panic + +data Cond + = ALWAYS + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + deriving Eq + + +condNegate :: Cond -> Cond +condNegate ALWAYS = panic "condNegate: ALWAYS" +condNegate EQQ = NE +condNegate GE = LTT +condNegate GEU = LU +condNegate GTT = LE +condNegate GU = LEU +condNegate LE = GTT +condNegate LEU = GU +condNegate LTT = GE +condNegate LU = GEU +condNegate NE = EQQ + +-- Condition utils +condUnsigned :: Cond -> Bool +condUnsigned GU = True +condUnsigned LU = True +condUnsigned GEU = True +condUnsigned LEU = True +condUnsigned _ = False diff --git a/GHC/CmmToAsm/PPC/Instr.hs b/GHC/CmmToAsm/PPC/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/Instr.hs @@ -0,0 +1,731 @@ +----------------------------------------------------------------------------- +-- +-- Machine-dependent assembly language +-- +-- (c) The University of Glasgow 1993-2004 +-- +----------------------------------------------------------------------------- + +module GHC.CmmToAsm.PPC.Instr + ( Instr(..) + , RI(..) + , archWordFormat + , stackFrameHeaderSize + , maxSpillSlots + , allocMoreStack + , makeFarBranches + , mkJumpInstr + , mkLoadInstr + , mkSpillInstr + , patchJumpInstr + , patchRegsOfInstr + , jumpDestsOfInstr + , canFallthroughTo + , takeRegRegMoveInstr + , takeDeltaInstr + , mkRegRegMoveInstr + , mkStackAllocInstr + , mkStackDeallocInstr + , regUsageOfInstr + , isJumpishInstr + , isMetaInstr + ) +where + +import GHC.Prelude hiding (head, init, last, tail) + +import GHC.CmmToAsm.PPC.Regs +import GHC.CmmToAsm.PPC.Cond +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Instr (RegUsage(..), noUsage) +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config +import GHC.Platform.Reg.Class.Unified +import GHC.Platform.Reg + +import GHC.Platform.Regs +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.Cmm.Info +import GHC.Cmm.CLabel +import GHC.Utils.Panic +import GHC.Platform +import GHC.Types.Unique.FM (listToUFM, lookupUFM) +import GHC.Types.Unique.DSM + +import Data.Foldable (toList) +import qualified Data.List.NonEmpty as NE +import GHC.Data.FastString (FastString) +import GHC.Data.Maybe (expectJust, fromMaybe) + + +-------------------------------------------------------------------------------- +-- Format of a PPC memory address. +-- +archWordFormat :: Bool -> Format +archWordFormat is32Bit + | is32Bit = II32 + | otherwise = II64 + + +mkStackAllocInstr :: Platform -> Int -> [Instr] +mkStackAllocInstr platform amount + = mkStackAllocInstr' platform (-amount) + +mkStackDeallocInstr :: Platform -> Int -> [Instr] +mkStackDeallocInstr platform amount + = mkStackAllocInstr' platform amount + +mkStackAllocInstr' :: Platform -> Int -> [Instr] +mkStackAllocInstr' platform amount + | fits16Bits amount + = [ LD fmt r0 (AddrRegImm sp zero) + , STU fmt r0 (AddrRegImm sp immAmount) + ] + | otherwise + = [ LD fmt r0 (AddrRegImm sp zero) + , ADDIS tmp sp (HA immAmount) + , ADD tmp tmp (RIImm (LO immAmount)) + , STU fmt r0 (AddrRegReg sp tmp) + ] + where + fmt = intFormat $ widthFromBytes (platformWordSizeInBytes platform) + zero = ImmInt 0 + tmp = tmpReg platform + immAmount = ImmInt amount + +-- +-- See Note [extra spill slots] in X86/Instr.hs +-- +allocMoreStack + :: Platform + -> Int + -> NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr + -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr, [(BlockId,BlockId)]) + +allocMoreStack _ _ top@(CmmData _ _) = return (top,[]) +allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do + let + infos = mapKeys info + entries = case code of + [] -> infos + BasicBlock entry _ : _ -- first block is the entry point + | entry `elem` infos -> infos + | otherwise -> entry : infos + + retargetList <- mapM (\e -> (e,) <$> newBlockId) entries + + let + delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up + where x = slots * spillSlotSize -- sp delta + + alloc = mkStackAllocInstr platform delta + dealloc = mkStackDeallocInstr platform delta + + new_blockmap :: LabelMap BlockId + new_blockmap = mapFromList retargetList + + insert_stack_insns (BasicBlock id insns) + | Just new_blockid <- mapLookup id new_blockmap + = [ BasicBlock id $ alloc ++ [BCC ALWAYS new_blockid Nothing] + , BasicBlock new_blockid block' + ] + | otherwise + = [ BasicBlock id block' ] + where + block' = foldr insert_dealloc [] insns + + insert_dealloc insn r + -- BCTR might or might not be a non-local jump. For + -- "labeled-goto" we use JMP, and for "computed-goto" we + -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'. + = case insn of + JMP _ _ -> dealloc ++ (insn : r) + BCTR [] Nothing _ -> dealloc ++ (insn : r) + BCTR ids label rs -> BCTR (map (fmap retarget) ids) label rs : r + BCCFAR cond b p -> BCCFAR cond (retarget b) p : r + BCC cond b p -> BCC cond (retarget b) p : r + _ -> insn : r + -- BL and BCTRL are call-like instructions rather than + -- jumps, and are used only for C calls. + + retarget :: BlockId -> BlockId + retarget b + = fromMaybe b (mapLookup b new_blockmap) + + new_code + = concatMap insert_stack_insns code + + -- in + return (CmmProc info lbl live (ListGraph new_code),retargetList) + + +-- ----------------------------------------------------------------------------- +-- Machine's assembly language + +-- We have a few common "instructions" (nearly all the pseudo-ops) but +-- mostly all of 'Instr' is machine-specific. + +-- Register or immediate +data RI + = RIReg Reg + | RIImm Imm + +data Instr + -- comment pseudo-op + = COMMENT FastString + + -- location pseudo-op (file, line, col, name) + | LOCATION Int Int Int String + + -- some static data spat out during code + -- generation. Will be extracted before + -- pretty-printing. + | LDATA Section RawCmmStatics + + -- start a new basic block. Useful during + -- codegen, removed later. Preceding + -- instruction should be a jump, as per the + -- invariants for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for + -- benefit of subsequent passes + | DELTA Int + + -- Loads and stores. + | LD Format Reg AddrMode -- Load format, dst, src + | LDFAR Format Reg AddrMode -- Load format, dst, src 32 bit offset + | LDR Format Reg AddrMode -- Load and reserve format, dst, src + | LA Format Reg AddrMode -- Load arithmetic format, dst, src + | ST Format Reg AddrMode -- Store format, src, dst + | STFAR Format Reg AddrMode -- Store format, src, dst 32 bit offset + | STU Format Reg AddrMode -- Store with Update format, src, dst + | STC Format Reg AddrMode -- Store conditional format, src, dst + | LIS Reg Imm -- Load Immediate Shifted dst, src + | LI Reg Imm -- Load Immediate dst, src + | MR Reg Reg -- Move Register dst, src -- also for fmr + + | CMP Format Reg RI -- format, src1, src2 + | CMPL Format Reg RI -- format, src1, src2 + + | BCC Cond BlockId (Maybe Bool) -- cond, block, hint + | BCCFAR Cond BlockId (Maybe Bool) -- cond, block, hint + -- hint: + -- Just True: branch likely taken + -- Just False: branch likely not taken + -- Nothing: no hint + | JMP CLabel [RegWithFormat] -- same as branch, + -- but with CLabel instead of block ID + -- and live global registers + | MTCTR Reg + | BCTR [Maybe BlockId] (Maybe CLabel) [RegWithFormat] + -- with list of local destinations, and + -- jump table location if necessary + | BL CLabel [Reg] -- with list of argument regs + | BCTRL [Reg] + + | ADD Reg Reg RI -- dst, src1, src2 + | ADDO Reg Reg Reg -- add and set overflow + | ADDC Reg Reg Reg -- (carrying) dst, src1, src2 + | ADDE Reg Reg Reg -- (extended) dst, src1, src2 + | ADDZE Reg Reg -- (to zero extended) dst, src + | ADDIS Reg Reg Imm -- Add Immediate Shifted dst, src1, src2 + | SUBF Reg Reg Reg -- dst, src1, src2 ; dst = src2 - src1 + | SUBFO Reg Reg Reg -- subtract from and set overflow + | SUBFC Reg Reg RI -- (carrying) dst, src1, src2 ; + -- dst = src2 - src1 + | SUBFE Reg Reg Reg -- (extended) dst, src1, src2 ; + -- dst = src2 - src1 + | MULL Format Reg Reg RI + | MULLO Format Reg Reg Reg -- multiply and set overflow + | MFOV Format Reg -- move overflow bit (1|33) to register + -- pseudo-instruction; pretty printed as + -- mfxer dst + -- extr[w|d]i dst, dst, 1, [1|33] + | MULHU Format Reg Reg Reg + | DIV Format Bool Reg Reg Reg + | AND Reg Reg RI -- dst, src1, src2 + | ANDC Reg Reg Reg -- AND with complement, dst = src1 & ~ src2 + | NAND Reg Reg Reg -- dst, src1, src2 + | OR Reg Reg RI -- dst, src1, src2 + | ORIS Reg Reg Imm -- OR Immediate Shifted dst, src1, src2 + | XOR Reg Reg RI -- dst, src1, src2 + | XORIS Reg Reg Imm -- XOR Immediate Shifted dst, src1, src2 + + | EXTS Format Reg Reg + | CNTLZ Format Reg Reg + + | NEG Reg Reg + | NOT Reg Reg + + | SL Format Reg Reg RI -- shift left + | SR Format Reg Reg RI -- shift right + | SRA Format Reg Reg RI -- shift right arithmetic + + | RLWINM Reg Reg Int Int Int -- Rotate Left Word Immediate then AND with Mask + | CLRLI Format Reg Reg Int -- clear left immediate (extended mnemonic) + | CLRRI Format Reg Reg Int -- clear right immediate (extended mnemonic) + + | FADD Format Reg Reg Reg + | FSUB Format Reg Reg Reg + | FMUL Format Reg Reg Reg + | FDIV Format Reg Reg Reg + | FABS Reg Reg -- abs is the same for single and double + | FNEG Reg Reg -- negate is the same for single and double prec. + + -- | Fused multiply-add instructions. + -- + -- - FMADD: @rd = (ra * rb) + rd@ + -- - FMSUB: @rd = ra * rb - rd@ + -- - FNMADD: @rd = -(ra * rb + rd)@ + -- - FNMSUB: @rd = -(ra * rb - rd)@ + | FMADD FMASign Format Reg Reg Reg Reg + + | FCMP Reg Reg + + | FCTIWZ Reg Reg -- convert to integer word + | FCTIDZ Reg Reg -- convert to integer double word + | FCFID Reg Reg -- convert from integer double word + | FRSP Reg Reg -- reduce to single precision + -- (but destination is a FP register) + + | CRNOR Int Int Int -- condition register nor + | MFCR Reg -- move from condition register + + | MFLR Reg -- move from link register + | FETCHPC Reg -- pseudo-instruction: + -- bcl to next insn, mflr reg + | HWSYNC -- heavy weight sync + | ISYNC -- instruction synchronize + | LWSYNC -- memory barrier + | NOP -- no operation, PowerPC 64 bit + -- needs this as place holder to + -- reload TOC pointer + +-- | Get the registers that are being used by this instruction. +-- regUsage doesn't need to do any trickery for jumps and such. +-- Just state precisely the regs read and written by that insn. +-- The consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. +-- +regUsageOfInstr :: Platform -> Instr -> RegUsage +regUsageOfInstr platform instr + = case instr of + LD _ reg addr -> usage (regAddr addr, [reg]) + LDFAR _ reg addr -> usage (regAddr addr, [reg]) + LDR _ reg addr -> usage (regAddr addr, [reg]) + LA _ reg addr -> usage (regAddr addr, [reg]) + ST _ reg addr -> usage (reg : regAddr addr, []) + STFAR _ reg addr -> usage (reg : regAddr addr, []) + STU _ reg addr -> usage (reg : regAddr addr, []) + STC _ reg addr -> usage (reg : regAddr addr, []) + LIS reg _ -> usage ([], [reg]) + LI reg _ -> usage ([], [reg]) + MR reg1 reg2 -> usage ([reg2], [reg1]) + CMP _ reg ri -> usage (reg : regRI ri,[]) + CMPL _ reg ri -> usage (reg : regRI ri,[]) + BCC _ _ _ -> noUsage + BCCFAR _ _ _ -> noUsage + JMP _ regs -> usage (map regWithFormat_reg regs, []) + MTCTR reg -> usage ([reg],[]) + BCTR _ _ regs -> usage (map regWithFormat_reg regs, []) + BL _ params -> usage (params, callClobberedRegs platform) + BCTRL params -> usage (params, callClobberedRegs platform) + + ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + ADDO reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + ADDC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + ADDE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + ADDZE reg1 reg2 -> usage ([reg2], [reg1]) + ADDIS reg1 reg2 _ -> usage ([reg2], [reg1]) + SUBF reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + SUBFO reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + SUBFC reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + SUBFE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + MULL _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + MULLO _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + MFOV _ reg -> usage ([], [reg]) + MULHU _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + DIV _ _ reg1 reg2 reg3 + -> usage ([reg2,reg3], [reg1]) + + AND reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + ANDC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + NAND reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + OR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + ORIS reg1 reg2 _ -> usage ([reg2], [reg1]) + XOR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + XORIS reg1 reg2 _ -> usage ([reg2], [reg1]) + EXTS _ reg1 reg2 -> usage ([reg2], [reg1]) + CNTLZ _ reg1 reg2 -> usage ([reg2], [reg1]) + NEG reg1 reg2 -> usage ([reg2], [reg1]) + NOT reg1 reg2 -> usage ([reg2], [reg1]) + SL _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + SR _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + SRA _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + RLWINM reg1 reg2 _ _ _ -> usage ([reg2], [reg1]) + CLRLI _ reg1 reg2 _ -> usage ([reg2], [reg1]) + CLRRI _ reg1 reg2 _ -> usage ([reg2], [reg1]) + + FADD _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FSUB _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FMUL _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FDIV _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FABS r1 r2 -> usage ([r2], [r1]) + FNEG r1 r2 -> usage ([r2], [r1]) + FCMP r1 r2 -> usage ([r1,r2], []) + FCTIWZ r1 r2 -> usage ([r2], [r1]) + FCTIDZ r1 r2 -> usage ([r2], [r1]) + FCFID r1 r2 -> usage ([r2], [r1]) + FRSP r1 r2 -> usage ([r2], [r1]) + MFCR reg -> usage ([], [reg]) + MFLR reg -> usage ([], [reg]) + FETCHPC reg -> usage ([], [reg]) + FMADD _ _ rt ra rc rb -> usage ([ra, rc, rb], [rt]) + _ -> noUsage + where + usage (src, dst) = RU (map mkFmt $ filter (interesting platform) src) + (map mkFmt $ filter (interesting platform) dst) + -- SIMD NCG TODO: the format here is used for register spilling/unspilling. + -- As the PowerPC NCG does not currently support SIMD registers, + -- this simple logic is OK. + mkFmt r = RegWithFormat r fmt + where fmt = case targetClassOfReg platform r of + RcInteger -> archWordFormat (target32Bit platform) + RcFloatOrVector -> FF64 + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] + + regRI (RIReg r) = [r] + regRI _ = [] + +interesting :: Platform -> Reg -> Bool +interesting _ (RegVirtual _) = True +interesting platform (RegReal (RealRegSingle i)) = freeReg platform i + + +-- | Apply a given mapping to all the register references in this +-- instruction. +patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +patchRegsOfInstr instr env + = case instr of + LD fmt reg addr -> LD fmt (env reg) (fixAddr addr) + LDFAR fmt reg addr -> LDFAR fmt (env reg) (fixAddr addr) + LDR fmt reg addr -> LDR fmt (env reg) (fixAddr addr) + LA fmt reg addr -> LA fmt (env reg) (fixAddr addr) + ST fmt reg addr -> ST fmt (env reg) (fixAddr addr) + STFAR fmt reg addr -> STFAR fmt (env reg) (fixAddr addr) + STU fmt reg addr -> STU fmt (env reg) (fixAddr addr) + STC fmt reg addr -> STC fmt (env reg) (fixAddr addr) + LIS reg imm -> LIS (env reg) imm + LI reg imm -> LI (env reg) imm + MR reg1 reg2 -> MR (env reg1) (env reg2) + CMP fmt reg ri -> CMP fmt (env reg) (fixRI ri) + CMPL fmt reg ri -> CMPL fmt (env reg) (fixRI ri) + BCC cond lbl p -> BCC cond lbl p + BCCFAR cond lbl p -> BCCFAR cond lbl p + JMP l regs -> JMP l regs -- global regs will not be remapped + MTCTR reg -> MTCTR (env reg) + BCTR targets lbl rs -> BCTR targets lbl rs + BL imm argRegs -> BL imm argRegs -- argument regs + BCTRL argRegs -> BCTRL argRegs -- cannot be remapped + ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri) + ADDO reg1 reg2 reg3 -> ADDO (env reg1) (env reg2) (env reg3) + ADDC reg1 reg2 reg3 -> ADDC (env reg1) (env reg2) (env reg3) + ADDE reg1 reg2 reg3 -> ADDE (env reg1) (env reg2) (env reg3) + ADDZE reg1 reg2 -> ADDZE (env reg1) (env reg2) + ADDIS reg1 reg2 imm -> ADDIS (env reg1) (env reg2) imm + SUBF reg1 reg2 reg3 -> SUBF (env reg1) (env reg2) (env reg3) + SUBFO reg1 reg2 reg3 -> SUBFO (env reg1) (env reg2) (env reg3) + SUBFC reg1 reg2 ri -> SUBFC (env reg1) (env reg2) (fixRI ri) + SUBFE reg1 reg2 reg3 -> SUBFE (env reg1) (env reg2) (env reg3) + MULL fmt reg1 reg2 ri + -> MULL fmt (env reg1) (env reg2) (fixRI ri) + MULLO fmt reg1 reg2 reg3 + -> MULLO fmt (env reg1) (env reg2) (env reg3) + MFOV fmt reg -> MFOV fmt (env reg) + MULHU fmt reg1 reg2 reg3 + -> MULHU fmt (env reg1) (env reg2) (env reg3) + DIV fmt sgn reg1 reg2 reg3 + -> DIV fmt sgn (env reg1) (env reg2) (env reg3) + + AND reg1 reg2 ri -> AND (env reg1) (env reg2) (fixRI ri) + ANDC reg1 reg2 reg3 -> ANDC (env reg1) (env reg2) (env reg3) + NAND reg1 reg2 reg3 -> NAND (env reg1) (env reg2) (env reg3) + OR reg1 reg2 ri -> OR (env reg1) (env reg2) (fixRI ri) + ORIS reg1 reg2 imm -> ORIS (env reg1) (env reg2) imm + XOR reg1 reg2 ri -> XOR (env reg1) (env reg2) (fixRI ri) + XORIS reg1 reg2 imm -> XORIS (env reg1) (env reg2) imm + EXTS fmt reg1 reg2 -> EXTS fmt (env reg1) (env reg2) + CNTLZ fmt reg1 reg2 -> CNTLZ fmt (env reg1) (env reg2) + NEG reg1 reg2 -> NEG (env reg1) (env reg2) + NOT reg1 reg2 -> NOT (env reg1) (env reg2) + SL fmt reg1 reg2 ri + -> SL fmt (env reg1) (env reg2) (fixRI ri) + SR fmt reg1 reg2 ri + -> SR fmt (env reg1) (env reg2) (fixRI ri) + SRA fmt reg1 reg2 ri + -> SRA fmt (env reg1) (env reg2) (fixRI ri) + RLWINM reg1 reg2 sh mb me + -> RLWINM (env reg1) (env reg2) sh mb me + CLRLI fmt reg1 reg2 n -> CLRLI fmt (env reg1) (env reg2) n + CLRRI fmt reg1 reg2 n -> CLRRI fmt (env reg1) (env reg2) n + FADD fmt r1 r2 r3 -> FADD fmt (env r1) (env r2) (env r3) + FSUB fmt r1 r2 r3 -> FSUB fmt (env r1) (env r2) (env r3) + FMUL fmt r1 r2 r3 -> FMUL fmt (env r1) (env r2) (env r3) + FDIV fmt r1 r2 r3 -> FDIV fmt (env r1) (env r2) (env r3) + FABS r1 r2 -> FABS (env r1) (env r2) + FNEG r1 r2 -> FNEG (env r1) (env r2) + FMADD sgn fmt r1 r2 r3 r4 + -> FMADD sgn fmt (env r1) (env r2) (env r3) (env r4) + FCMP r1 r2 -> FCMP (env r1) (env r2) + FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2) + FCTIDZ r1 r2 -> FCTIDZ (env r1) (env r2) + FCFID r1 r2 -> FCFID (env r1) (env r2) + FRSP r1 r2 -> FRSP (env r1) (env r2) + MFCR reg -> MFCR (env reg) + MFLR reg -> MFLR (env reg) + FETCHPC reg -> FETCHPC (env reg) + _ -> instr + where + fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i + + fixRI (RIReg r) = RIReg (env r) + fixRI other = other + + +-------------------------------------------------------------------------------- +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +isJumpishInstr :: Instr -> Bool +isJumpishInstr instr + = case instr of + BCC{} -> True + BCCFAR{} -> True + BCTR{} -> True + BCTRL{} -> True + BL{} -> True + JMP{} -> True + _ -> False + +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo instr bid + = case instr of + BCC _ target _ -> target == bid + BCCFAR _ target _ -> target == bid + _ -> False + + +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +jumpDestsOfInstr :: Instr -> [BlockId] +jumpDestsOfInstr insn + = case insn of + BCC _ id _ -> [id] + BCCFAR _ id _ -> [id] + BCTR targets _ _ -> [id | Just id <- targets] + _ -> [] + + +-- | Change the destination of this jump instruction. +-- Used in the linear allocator when adding fixup blocks for join +-- points. +patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr +patchJumpInstr insn patchF + = case insn of + BCC cc id p -> BCC cc (patchF id) p + BCCFAR cc id p -> BCCFAR cc (patchF id) p + BCTR ids lbl rs -> BCTR (map (fmap patchF) ids) lbl rs + _ -> insn + + +-- ----------------------------------------------------------------------------- + +-- | An instruction to spill a register into a spill slot. +mkSpillInstr + :: NCGConfig + -> RegWithFormat -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] + +mkSpillInstr config (RegWithFormat reg _fmt) delta slot + = let platform = ncgPlatform config + off = spillSlotToOffset platform slot + arch = platformArch platform + in + let fmt = case targetClassOfReg platform reg of + RcInteger -> case arch of + ArchPPC -> II32 + _ -> II64 + RcFloatOrVector -> FF64 + instr = case makeImmediate W32 True (off-delta) of + Just _ -> ST + Nothing -> STFAR -- pseudo instruction: 32 bit offsets + + in [instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))] + + +mkLoadInstr + :: NCGConfig + -> RegWithFormat -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] + +mkLoadInstr config (RegWithFormat reg _fmt) delta slot + = let platform = ncgPlatform config + off = spillSlotToOffset platform slot + arch = platformArch platform + in + let fmt = case targetClassOfReg platform reg of + RcInteger -> case arch of + ArchPPC -> II32 + _ -> II64 + RcFloatOrVector -> FF64 + instr = case makeImmediate W32 True (off-delta) of + Just _ -> LD + Nothing -> LDFAR -- pseudo instruction: 32 bit offsets + + in [instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))] + + +-- | The size of a minimal stackframe header including minimal +-- parameter save area. +stackFrameHeaderSize :: Platform -> Int +stackFrameHeaderSize platform + = case platformOS platform of + OSAIX -> 24 + 8 * 4 + _ -> case platformArch platform of + -- header + parameter save area + ArchPPC -> 64 -- TODO: check ABI spec + ArchPPC_64 ELF_V1 -> 48 + 8 * 8 + ArchPPC_64 ELF_V2 -> 32 + 8 * 8 + _ -> panic "PPC.stackFrameHeaderSize: not defined for this OS" + +-- | The maximum number of bytes required to spill a register. PPC32 +-- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and +-- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike +-- x86. Note that AltiVec's vector registers are 128-bit wide so we +-- must not use this to spill them. +spillSlotSize :: Int +spillSlotSize = 8 + +-- | The number of spill slots available without allocating more. +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config +-- = 0 -- useful for testing allocMoreStack + = let platform = ncgPlatform config + in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform) + `div` spillSlotSize) - 1 + +-- | The number of bytes that the stack pointer should be aligned +-- to. This is 16 both on PPC32 and PPC64 ELF (see ELF processor +-- specific supplements). +stackAlign :: Int +stackAlign = 16 + +-- | Convert a spill slot number to a *byte* offset, with no sign. +spillSlotToOffset :: Platform -> Int -> Int +spillSlotToOffset platform slot + = stackFrameHeaderSize platform + spillSlotSize * slot + + +-------------------------------------------------------------------------------- +-- | See if this instruction is telling us the current C stack delta +takeDeltaInstr + :: Instr + -> Maybe Int + +takeDeltaInstr instr + = case instr of + DELTA i -> Just i + _ -> Nothing + + +isMetaInstr + :: Instr + -> Bool + +isMetaInstr instr + = case instr of + COMMENT{} -> True + LOCATION{} -> True + LDATA{} -> True + NEWBLOCK{} -> True + DELTA{} -> True + _ -> False + + +-- | Copy the value in a register to another one. +-- Must work for all register classes. +mkRegRegMoveInstr + :: Format + -> Reg + -> Reg + -> Instr + +mkRegRegMoveInstr _fmt src dst + = MR dst src + -- SIMD NCG TODO: handle vector format + + +-- | Make an unconditional jump instruction. +mkJumpInstr + :: BlockId + -> [Instr] + +mkJumpInstr id + = [BCC ALWAYS id Nothing] + + +-- | Take the source and destination from this reg -> reg move instruction +-- or Nothing if it's not one +takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) +takeRegRegMoveInstr (MR dst src) = Just (src,dst) +takeRegRegMoveInstr _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Making far branches + +-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too +-- big, we have to work around this limitation. + +makeFarBranches + :: Platform + -> LabelMap RawCmmStatics + -> [NatBasicBlock Instr] + -> UniqDSM [NatBasicBlock Instr] +makeFarBranches _platform info_env blocks + | NE.last blockAddresses < nearLimit = return blocks + | otherwise = return $ zipWith handleBlock blockAddressList blocks + where + blockAddresses = NE.scanl (+) 0 $ map blockLen blocks + blockAddressList = toList blockAddresses + blockLen (BasicBlock _ instrs) = length instrs + + handleBlock addr (BasicBlock id instrs) + = BasicBlock id (zipWith makeFar [addr..] instrs) + + makeFar _ (BCC ALWAYS tgt _) = BCC ALWAYS tgt Nothing + makeFar addr (BCC cond tgt p) + | abs (addr - targetAddr) >= nearLimit + = BCCFAR cond tgt p + | otherwise + = BCC cond tgt p + where targetAddr = expectJust $ lookupUFM blockAddressMap tgt + makeFar _ other = other + + -- 8192 instructions are allowed; let's keep some distance, as + -- we have a few pseudo-insns that are pretty-printed as + -- multiple instructions, and it's just not worth the effort + -- to calculate things exactly + nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW + + blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddressList diff --git a/GHC/CmmToAsm/PPC/Ppr.hs b/GHC/CmmToAsm/PPC/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/Ppr.hs @@ -0,0 +1,1128 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- +-- Pretty-printing assembly language +-- +-- (c) The University of Glasgow 1993-2005 +-- +----------------------------------------------------------------------------- + +module GHC.CmmToAsm.PPC.Ppr + ( pprNatCmmDecl + , pprInstr + ) +where + +import GHC.Prelude + +import GHC.CmmToAsm.PPC.Regs +import GHC.CmmToAsm.PPC.Instr +import GHC.CmmToAsm.PPC.Cond +import GHC.CmmToAsm.Ppr +import GHC.CmmToAsm.Format +import GHC.Platform.Reg +import GHC.Platform.Reg.Class.Unified +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils + +import GHC.Cmm hiding (topInfoTable) +import GHC.Cmm.Dataflow.Label + +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel + +import GHC.Types.Unique ( pprUniqueAlways, getUnique ) +import GHC.Platform +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Word +import Data.Int + +-- ----------------------------------------------------------------------------- +-- Printing this stuff out + +pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section + $$ pprDatas (ncgPlatform config) dats + +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config in + case topInfoTable proc of + Nothing -> + -- special case for code without info table: + pprSectionAlign config (Section Text lbl) $$ + (case platformArch platform of + ArchPPC_64 ELF_V1 -> pprFunctionDescriptor platform lbl + ArchPPC_64 ELF_V2 -> pprFunctionPrologue platform lbl + _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null, + -- so label needed + vcat (map (pprBasicBlock config top_info) blocks) $$ + ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel lbl) + <> char ':') $$ + line (pprProcEndLabel platform lbl)) $$ + pprSizeDecl platform lbl + + Just (CmmStaticsRaw info_lbl _) -> + pprSectionAlign config (Section Text info_lbl) $$ + (if platformHasSubsectionsViaSymbols platform + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':') + else empty) $$ + vcat (map (pprBasicBlock config top_info) blocks) $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + (if platformHasSubsectionsViaSymbols platform + then + -- See Note [Subsections Via Symbols] in X86/Ppr.hs + line (text "\t.long " + <+> pprAsmLabel platform info_lbl + <+> char '-' + <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)) + else empty) $$ + pprSizeDecl platform info_lbl +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-} +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Output the ELF .size directive. +pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc +pprSizeDecl platform lbl + = if osElfTarget (platformOS platform) + then line (text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl) + else empty + where + prettyLbl = pprAsmLabel platform lbl + codeLbl + | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl + | otherwise = prettyLbl + +pprFunctionDescriptor :: IsDoc doc => Platform -> CLabel -> doc +pprFunctionDescriptor platform lab = + vcat [pprGloblDecl platform lab, + line (text "\t.section \".opd\", \"aw\""), + line (text "\t.align 3"), + line (pprAsmLabel platform lab <> char ':'), + line (text "\t.quad ." + <> pprAsmLabel platform lab + <> text ",.TOC.@tocbase,0"), + line (text "\t.previous"), + line (text "\t.type" + <+> pprAsmLabel platform lab + <> text ", @function"), + line (char '.' <> pprAsmLabel platform lab <> char ':')] + +pprFunctionPrologue :: IsDoc doc => Platform -> CLabel -> doc +pprFunctionPrologue platform lab = + vcat [pprGloblDecl platform lab, + line (text ".type " <> pprAsmLabel platform lab <> text ", @function"), + line (pprAsmLabel platform lab <> char ':'), + line (text "0:\taddis\t" <> pprReg toc <> text ",12,.TOC.-0b@ha"), + line (text "\taddi\t" <> pprReg toc <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"), + line (text "\t.localentry\t" <> pprAsmLabel platform lab <> + text ",.-" <> pprAsmLabel platform lab)] + +pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name + -> doc +pprProcEndLabel platform lbl = + pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> char ':' + +pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr + -> doc +pprBasicBlock config info_env (BasicBlock blockid instrs) + = maybe_infotable $$ + pprLabel platform asmLbl $$ + vcat (map (pprInstr platform) instrs) $$ + ppWhen (ncgDwarfEnabled config) ( + line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':' + <> pprProcEndLabel platform asmLbl) + ) + where + asmLbl = blockLbl blockid + platform = ncgPlatform config + maybe_infotable = case mapLookup blockid info_env of + Nothing -> empty + Just (CmmStaticsRaw info_lbl info) -> + pprAlignForSection platform Text $$ + vcat (map (pprData platform) info) $$ + pprLabel platform info_lbl + + + +pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc +-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' + = pprGloblDecl platform alias + $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind') +pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) + +pprData :: IsDoc doc => Platform -> CmmStatic -> doc +pprData platform d = case d of + CmmString str -> line (pprString str) + CmmFileEmbed path _ -> line (pprFileEmbed path) + CmmUninitialised bytes -> line (text ".space " <> int bytes) + CmmStaticLit lit -> pprDataItem platform lit + +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc +pprGloblDecl platform lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = line (text ".globl " <> pprAsmLabel platform lbl) + +pprTypeAndSizeDecl :: IsLine doc => Platform -> CLabel -> doc +pprTypeAndSizeDecl platform lbl + = if platformOS platform == OSLinux && externallyVisibleCLabel lbl + then text ".type " <> + pprAsmLabel platform lbl <> text ", @object" + else empty + +pprLabel :: IsDoc doc => Platform -> CLabel -> doc +pprLabel platform lbl = + pprGloblDecl platform lbl + $$ line (pprTypeAndSizeDecl platform lbl) + $$ line (pprAsmLabel platform lbl <> char ':') + +-- ----------------------------------------------------------------------------- +-- pprInstr: print an 'Instr' + +pprReg :: forall doc. IsLine doc => Reg -> doc + +pprReg r + = case r of + RegReal (RealRegSingle i) -> ppr_reg_no i + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u + RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u + RegVirtual (VirtualRegV128 u) -> text "%vV128_" <> pprUniqueAlways u + + where + ppr_reg_no :: Int -> doc + ppr_reg_no i + | i <= 31 = int i -- GPRs + | i <= 63 = int (i-32) -- FPRs + | otherwise = text "very naughty powerpc register" + + + +pprFormat :: IsLine doc => Format -> doc +pprFormat x + = case x of + II8 -> text "b" + II16 -> text "h" + II32 -> text "w" + II64 -> text "d" + FF32 -> text "fs" + FF64 -> text "fd" + VecFormat {} -> panic "PPC pprFormat: VecFormat" + +pprCond :: IsLine doc => Cond -> doc +pprCond c + = case c of { + ALWAYS -> text ""; + EQQ -> text "eq"; NE -> text "ne"; + LTT -> text "lt"; GE -> text "ge"; + GTT -> text "gt"; LE -> text "le"; + LU -> text "lt"; GEU -> text "ge"; + GU -> text "gt"; LEU -> text "le"; } + + +pprImm :: IsLine doc => Platform -> Imm -> doc +pprImm platform = \case + ImmInt i -> int i + ImmInteger i -> integer i + ImmCLbl l -> pprAsmLabel platform l + ImmIndex l i -> pprAsmLabel platform l <> char '+' <> int i + ImmLit s -> ftext s + ImmFloat f -> float $ fromRational f + ImmDouble d -> double $ fromRational d + ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b + ImmConstantDiff a b -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen + LO (ImmInt i) -> pprImm platform (LO (ImmInteger (toInteger i))) + LO (ImmInteger i) -> pprImm platform (ImmInteger (toInteger lo16)) + where + lo16 = fromInteger (i .&. 0xffff) :: Int16 + + LO i -> pprImm platform i <> text "@l" + HI i -> pprImm platform i <> text "@h" + HA (ImmInt i) -> pprImm platform (HA (ImmInteger (toInteger i))) + HA (ImmInteger i) -> pprImm platform (ImmInteger ha16) + where + ha16 = if lo16 >= 0x8000 then hi16+1 else hi16 + hi16 = (i `shiftR` 16) + lo16 = i .&. 0xffff + + HA i -> pprImm platform i <> text "@ha" + HIGHERA i -> pprImm platform i <> text "@highera" + HIGHESTA i -> pprImm platform i <> text "@highesta" + + +pprAddr :: IsLine doc => Platform -> AddrMode -> doc +pprAddr platform = \case + AddrRegReg r1 r2 -> pprReg r1 <> char ',' <+> pprReg r2 + AddrRegImm r1 (ImmInt i) -> hcat [ int i, char '(', pprReg r1, char ')' ] + AddrRegImm r1 (ImmInteger i) -> hcat [ integer i, char '(', pprReg r1, char ')' ] + AddrRegImm r1 imm -> hcat [ pprImm platform imm, char '(', pprReg r1, char ')' ] + + +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc +pprSectionAlign config sec@(Section seg _) = + line (pprSectionHeader config sec) $$ + pprAlignForSection (ncgPlatform config) seg + +-- | Print appropriate alignment for the given section type. +pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc +pprAlignForSection platform seg = line $ + let ppc64 = not $ target32Bit platform + in case seg of + Text -> text ".align 2" + Data + | ppc64 -> text ".align 3" + | otherwise -> text ".align 2" + ReadOnlyData + | ppc64 -> text ".align 3" + | otherwise -> text ".align 2" + RelocatableReadOnlyData + | ppc64 -> text ".align 3" + | otherwise -> text ".align 2" + UninitialisedData + | ppc64 -> text ".align 3" + | otherwise -> text ".align 2" + -- TODO: This is copied from the ReadOnlyData case, but it can likely be + -- made more efficient. + InitArray -> text ".align 3" + FiniArray -> text ".align 3" + CString + | ppc64 -> text ".align 3" + | otherwise -> text ".align 2" + OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section" + +pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc +pprDataItem platform lit + = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + where + imm = litToImm lit + archPPC_64 = not $ target32Bit platform + + ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm] + ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] + ppr_item II64 _ + | archPPC_64 = [text "\t.quad\t" <> pprImm platform imm] + + ppr_item II64 (CmmInt x _) + | not archPPC_64 = + [text "\t.long\t" + <> int (fromIntegral + (fromIntegral (x `shiftR` 32) :: Word32)), + text "\t.long\t" + <> int (fromIntegral (fromIntegral x :: Word32))] + + + ppr_item FF32 _ = [text "\t.float\t" <> pprImm platform imm] + ppr_item FF64 _ = [text "\t.double\t" <> pprImm platform imm] + + ppr_item _ _ + = panic "PPC.Ppr.pprDataItem: no match" + + +asmComment :: IsLine doc => doc -> doc +asmComment c = whenPprDebug $ text "#" <+> c + + +pprInstr :: IsDoc doc => Platform -> Instr -> doc +pprInstr platform instr = case instr of + + COMMENT s + -> line (asmComment (ftext s)) + + LOCATION file line' col _name + -> line (text "\t.loc" <+> int file <+> int line' <+> int col) + + DELTA d + -> line (asmComment $ text ("\tdelta = " ++ show d)) + + NEWBLOCK _ + -> panic "PprMach.pprInstr: NEWBLOCK" + + LDATA _ _ + -> panic "PprMach.pprInstr: LDATA" + +{- + SPILL reg slot + -> hcat [ + text "\tSPILL", + char '\t', + pprReg reg, + comma, + text "SLOT" <> parens (int slot)] + + RELOAD slot reg + -> hcat [ + text "\tRELOAD", + char '\t', + text "SLOT" <> parens (int slot), + comma, + pprReg reg] +-} + + LD fmt reg addr + -> line $ hcat [ + char '\t', + text "l", + (case fmt of + II8 -> text "bz" + II16 -> text "hz" + II32 -> text "wz" + II64 -> text "d" + FF32 -> text "fs" + FF64 -> text "fd" + VecFormat {} -> panic "PPC pprInstr: VecFormat" + ), + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr platform addr + ] + + LDFAR fmt reg (AddrRegImm source off) + -> vcat + [ pprInstr platform (ADDIS (tmpReg platform) source (HA off)) + , pprInstr platform (LD fmt reg (AddrRegImm (tmpReg platform) (LO off))) + ] + + LDFAR _ _ _ + -> panic "PPC.Ppr.pprInstr LDFAR: no match" + + LDR fmt reg1 addr + -> line $ hcat [ + text "\tl", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC.Ppr.Instr LDR: no match", + text "arx\t", + pprReg reg1, + text ", ", + pprAddr platform addr + ] + + LA fmt reg addr + -> line $ hcat [ + char '\t', + text "l", + (case fmt of + II8 -> text "ba" + II16 -> text "ha" + II32 -> text "wa" + II64 -> text "d" + FF32 -> text "fs" + FF64 -> text "fd" + VecFormat {} -> panic "PPC pprInstr: VecFormat" + ), + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr platform addr + ] + + ST fmt reg addr + -> line $ hcat [ + char '\t', + text "st", + pprFormat fmt, + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr platform addr + ] + + STFAR fmt reg (AddrRegImm source off) + -> vcat [ pprInstr platform (ADDIS (tmpReg platform) source (HA off)) + , pprInstr platform (ST fmt reg (AddrRegImm (tmpReg platform) (LO off))) + ] + + STFAR _ _ _ + -> panic "PPC.Ppr.pprInstr STFAR: no match" + + STU fmt reg addr + -> line $ hcat [ + char '\t', + text "st", + pprFormat fmt, + char 'u', + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr platform addr + ] + + STC fmt reg1 addr + -> line $ hcat [ + text "\tst", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC.Ppr.Instr STC: no match", + text "cx.\t", + pprReg reg1, + text ", ", + pprAddr platform addr + ] + + LIS reg imm + -> line $ hcat [ + char '\t', + text "lis", + char '\t', + pprReg reg, + text ", ", + pprImm platform imm + ] + + LI reg imm + -> line $ hcat [ + char '\t', + text "li", + char '\t', + pprReg reg, + text ", ", + pprImm platform imm + ] + + MR reg1 reg2 + | reg1 == reg2 -> empty + | otherwise -> line $ hcat [ + char '\t', + case targetClassOfReg platform reg1 of + RcInteger -> text "mr" + RcFloatOrVector -> text "fmr", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2 + ] + + CMP fmt reg ri + -> line $ hcat [ + char '\t', + op, + char '\t', + pprReg reg, + text ", ", + pprRI platform ri + ] + where + op = hcat [ + text "cmp", + pprFormat fmt, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] + + CMPL fmt reg ri + -> line $ hcat [ + char '\t', + op, + char '\t', + pprReg reg, + text ", ", + pprRI platform ri + ] + where + op = hcat [ + text "cmpl", + pprFormat fmt, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] + + BCC cond blockid prediction + -> line $ hcat [ + char '\t', + text "b", + pprCond cond, + pprPrediction prediction, + char '\t', + pprAsmLabel platform lbl + ] + where lbl = mkLocalBlockLabel (getUnique blockid) + pprPrediction p = case p of + Nothing -> empty + Just True -> char '+' + Just False -> char '-' + + BCCFAR cond blockid prediction + -> lines_ [ + hcat [ + text "\tb", + pprCond (condNegate cond), + neg_prediction, + text "\t$+8" + ], + hcat [ + text "\tb\t", + pprAsmLabel platform lbl + ] + ] + where lbl = mkLocalBlockLabel (getUnique blockid) + neg_prediction = case prediction of + Nothing -> empty + Just True -> char '-' + Just False -> char '+' + + JMP lbl _ + | OSAIX <- platformOS platform -> + line $ hcat [ -- an alias for b that takes a CLabel + text "\tb.\t", -- add the ".", cf Note [AIX function descriptors and entry-code addresses] + pprAsmLabel platform lbl + ] + + | otherwise -> + line $ hcat [ -- an alias for b that takes a CLabel + text "\tb\t", + pprAsmLabel platform lbl + ] + + MTCTR reg + -> line $ hcat [ + char '\t', + text "mtctr", + char '\t', + pprReg reg + ] + + BCTR _ _ _ + -> line $ hcat [ + char '\t', + text "bctr" + ] + + BL lbl _ + -> case platformOS platform of + OSAIX -> + -- Note [AIX function descriptors and entry-code addresses] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- On AIX, "printf" denotes a function-descriptor (for use + -- by function pointers), whereas the actual entry-code + -- address is denoted by the dot-prefixed ".printf" label. + -- Moreover, the PPC NCG only ever emits a BL instruction + -- for calling C ABI functions. Most of the time these calls + -- originate from FFI imports and have a 'ForeignLabel', + -- but when profiling the codegen inserts calls via + -- 'emitRtsCallGen' which are 'CmmLabel's even though + -- they'd technically be more like 'ForeignLabel's. + line $ hcat [ + text "\tbl\t.", + pprAsmLabel platform lbl + ] + _ -> + line $ hcat [ + text "\tbl\t", + pprAsmLabel platform lbl + ] + + BCTRL _ + -> line $ hcat [ + char '\t', + text "bctrl" + ] + + ADD reg1 reg2 ri + -> pprLogic platform (text "add") reg1 reg2 ri + + ADDIS reg1 reg2 imm + -> line $ hcat [ + char '\t', + text "addis", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm platform imm + ] + + ADDO reg1 reg2 reg3 + -> pprLogic platform (text "addo") reg1 reg2 (RIReg reg3) + + ADDC reg1 reg2 reg3 + -> pprLogic platform (text "addc") reg1 reg2 (RIReg reg3) + + ADDE reg1 reg2 reg3 + -> pprLogic platform (text "adde") reg1 reg2 (RIReg reg3) + + ADDZE reg1 reg2 + -> pprUnary (text "addze") reg1 reg2 + + SUBF reg1 reg2 reg3 + -> pprLogic platform (text "subf") reg1 reg2 (RIReg reg3) + + SUBFO reg1 reg2 reg3 + -> pprLogic platform (text "subfo") reg1 reg2 (RIReg reg3) + + SUBFC reg1 reg2 ri + -> line $ hcat [ + char '\t', + text "subf", + case ri of + RIReg _ -> empty + RIImm _ -> char 'i', + text "c\t", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprRI platform ri + ] + + SUBFE reg1 reg2 reg3 + -> pprLogic platform (text "subfe") reg1 reg2 (RIReg reg3) + + MULL fmt reg1 reg2 ri + -> pprMul platform fmt reg1 reg2 ri + + MULLO fmt reg1 reg2 reg3 + -> line $ hcat [ + char '\t', + text "mull", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + text "o\t", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprReg reg3 + ] + + MFOV fmt reg + -> vcat [ + line $ hcat [ + char '\t', + text "mfxer", + char '\t', + pprReg reg + ], + line $ hcat [ + char '\t', + text "extr", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + text "i\t", + pprReg reg, + text ", ", + pprReg reg, + text ", 1, ", + case fmt of + II32 -> text "1" + II64 -> text "33" + _ -> panic "PPC: illegal format" + ] + ] + + MULHU fmt reg1 reg2 reg3 + -> line $ hcat [ + char '\t', + text "mulh", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + text "u\t", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprReg reg3 + ] + + DIV fmt sgn reg1 reg2 reg3 + -> pprDiv fmt sgn reg1 reg2 reg3 + + -- for some reason, "andi" doesn't exist. + -- we'll use "andi." instead. + AND reg1 reg2 (RIImm imm) + -> line $ hcat [ + char '\t', + text "andi.", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm platform imm + ] + + AND reg1 reg2 ri + -> pprLogic platform (text "and") reg1 reg2 ri + + ANDC reg1 reg2 reg3 + -> pprLogic platform (text "andc") reg1 reg2 (RIReg reg3) + + NAND reg1 reg2 reg3 + -> pprLogic platform (text "nand") reg1 reg2 (RIReg reg3) + + OR reg1 reg2 ri + -> pprLogic platform (text "or") reg1 reg2 ri + + XOR reg1 reg2 ri + -> pprLogic platform (text "xor") reg1 reg2 ri + + ORIS reg1 reg2 imm + -> line $ hcat [ + char '\t', + text "oris", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm platform imm + ] + + XORIS reg1 reg2 imm + -> line $ hcat [ + char '\t', + text "xoris", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm platform imm + ] + + EXTS fmt reg1 reg2 + -> line $ hcat [ + char '\t', + text "exts", + pprFormat fmt, + char '\t', + pprReg reg1, + text ", ", + pprReg reg2 + ] + + CNTLZ fmt reg1 reg2 + -> line $ hcat [ + char '\t', + text "cntlz", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2 + ] + + NEG reg1 reg2 + -> pprUnary (text "neg") reg1 reg2 + + NOT reg1 reg2 + -> pprUnary (text "not") reg1 reg2 + + SR II32 reg1 reg2 (RIImm (ImmInt i)) + -- Handle the case where we are asked to shift a 32 bit register by + -- less than zero or more than 31 bits. We convert this into a clear + -- of the destination register. + -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/5900 + | i < 0 || i > 31 -> pprInstr platform (XOR reg1 reg2 (RIReg reg2)) + + SL II32 reg1 reg2 (RIImm (ImmInt i)) + -- As above for SR, but for left shifts. + -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/10870 + | i < 0 || i > 31 -> pprInstr platform (XOR reg1 reg2 (RIReg reg2)) + + SRA II32 reg1 reg2 (RIImm (ImmInt i)) + -- PT: I don't know what to do for negative shift amounts: + -- For now just panic. + -- + -- For shift amounts greater than 31 set all bit to the + -- value of the sign bit, this also what sraw does. + | i > 31 -> pprInstr platform (SRA II32 reg1 reg2 (RIImm (ImmInt 31))) + + SL fmt reg1 reg2 ri + -> let op = case fmt of + II32 -> text "slw" + II64 -> text "sld" + _ -> panic "PPC.Ppr.pprInstr: shift illegal size" + in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri) + + SR fmt reg1 reg2 ri + -> let op = case fmt of + II32 -> text "srw" + II64 -> text "srd" + _ -> panic "PPC.Ppr.pprInstr: shift illegal size" + in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri) + + SRA fmt reg1 reg2 ri + -> let op = case fmt of + II32 -> text "sraw" + II64 -> text "srad" + _ -> panic "PPC.Ppr.pprInstr: shift illegal size" + in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri) + + RLWINM reg1 reg2 sh mb me + -> line $ hcat [ + text "\trlwinm\t", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + int sh, + text ", ", + int mb, + text ", ", + int me + ] + + CLRLI fmt reg1 reg2 n + -> line $ hcat [ + text "\tclrl", + pprFormat fmt, + text "i ", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + int n + ] + + CLRRI fmt reg1 reg2 n + -> line $ hcat [ + text "\tclrr", + pprFormat fmt, + text "i ", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + int n + ] + + FADD fmt reg1 reg2 reg3 + -> pprBinaryF (text "fadd") fmt reg1 reg2 reg3 + + FSUB fmt reg1 reg2 reg3 + -> pprBinaryF (text "fsub") fmt reg1 reg2 reg3 + + FMUL fmt reg1 reg2 reg3 + -> pprBinaryF (text "fmul") fmt reg1 reg2 reg3 + + FDIV fmt reg1 reg2 reg3 + -> pprBinaryF (text "fdiv") fmt reg1 reg2 reg3 + + FABS reg1 reg2 + -> pprUnary (text "fabs") reg1 reg2 + + FNEG reg1 reg2 + -> pprUnary (text "fneg") reg1 reg2 + + FMADD signs fmt dst ra rc rb + -> pprTernaryF (pprFMASign signs) fmt dst ra rc rb + + FCMP reg1 reg2 + -> line $ hcat [ + char '\t', + text "fcmpu\t0, ", + -- Note: we're using fcmpu, not fcmpo + -- The difference is with fcmpo, compare with NaN is an invalid operation. + -- We don't handle invalid fp ops, so we don't care. + -- Moreover, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for + -- better portability since some non-GNU assembler (such as + -- IBM's `as`) tend not to support the symbolic register name cr0. + -- This matches the syntax that GCC seems to emit for PPC targets. + pprReg reg1, + text ", ", + pprReg reg2 + ] + + FCTIWZ reg1 reg2 + -> pprUnary (text "fctiwz") reg1 reg2 + + FCTIDZ reg1 reg2 + -> pprUnary (text "fctidz") reg1 reg2 + + FCFID reg1 reg2 + -> pprUnary (text "fcfid") reg1 reg2 + + FRSP reg1 reg2 + -> pprUnary (text "frsp") reg1 reg2 + + CRNOR dst src1 src2 + -> line $ hcat [ + text "\tcrnor\t", + int dst, + text ", ", + int src1, + text ", ", + int src2 + ] + + MFCR reg + -> line $ hcat [ + char '\t', + text "mfcr", + char '\t', + pprReg reg + ] + + MFLR reg + -> line $ hcat [ + char '\t', + text "mflr", + char '\t', + pprReg reg + ] + + FETCHPC reg + -> lines_ [ + text "\tbcl\t20,31,1f", + hcat [ text "1:\tmflr\t", pprReg reg ] + ] + + HWSYNC + -> line $ text "\tsync" + + ISYNC + -> line $ text "\tisync" + + LWSYNC + -> line $ text "\tlwsync" + + NOP + -> line $ text "\tnop" + +pprLogic :: IsDoc doc => Platform -> Line doc -> Reg -> Reg -> RI -> doc +pprLogic platform op reg1 reg2 ri = line $ hcat [ + char '\t', + op, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i', + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprRI platform ri + ] + + +pprMul :: IsDoc doc => Platform -> Format -> Reg -> Reg -> RI -> doc +pprMul platform fmt reg1 reg2 ri = line $ hcat [ + char '\t', + text "mull", + case ri of + RIReg _ -> case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format" + RIImm _ -> char 'i', + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprRI platform ri + ] + + +pprDiv :: IsDoc doc => Format -> Bool -> Reg -> Reg -> Reg -> doc +pprDiv fmt sgn reg1 reg2 reg3 = line $ hcat [ + char '\t', + text "div", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + if sgn then empty else char 'u', + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprReg reg3 + ] + + +pprUnary :: IsDoc doc => Line doc -> Reg -> Reg -> doc +pprUnary op reg1 reg2 = line $ hcat [ + char '\t', + op, + char '\t', + pprReg reg1, + text ", ", + pprReg reg2 + ] + + +pprBinaryF :: IsDoc doc => Line doc -> Format -> Reg -> Reg -> Reg -> doc +pprBinaryF op fmt reg1 reg2 reg3 = line $ hcat [ + char '\t', + op, + pprFFormat fmt, + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprReg reg3 + ] + +pprTernaryF :: IsDoc doc => Line doc -> Format -> Reg -> Reg -> Reg -> Reg -> doc +pprTernaryF op fmt rt ra rc rb = line $ hcat [ + char '\t', + op, + pprFFormat fmt, + char '\t', + pprReg rt, + text ", ", + pprReg ra, + text ", ", + pprReg rc, + text ", ", + pprReg rb + ] + +pprRI :: IsLine doc => Platform -> RI -> doc +pprRI _ (RIReg r) = pprReg r +pprRI platform (RIImm r) = pprImm platform r + + +pprFFormat :: IsLine doc => Format -> doc +pprFFormat FF64 = empty +pprFFormat FF32 = char 's' +pprFFormat _ = panic "PPC.Ppr.pprFFormat: no match" + + -- limit immediate argument for shift instruction to range 0..63 + -- for 64 bit size and 0..32 otherwise +limitShiftRI :: Format -> RI -> RI +limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 = + panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed." +limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 = + panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed." +limitShiftRI _ x = x diff --git a/GHC/CmmToAsm/PPC/RegInfo.hs b/GHC/CmmToAsm/PPC/RegInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/RegInfo.hs @@ -0,0 +1,77 @@ + +----------------------------------------------------------------------------- +-- +-- Machine-specific parts of the register allocator +-- +-- (c) The University of Glasgow 1996-2004 +-- +----------------------------------------------------------------------------- +module GHC.CmmToAsm.PPC.RegInfo ( + JumpDest( DestBlockId ), getJumpDestBlockId, + canShortcut, + shortcutJump, + + shortcutStatics +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.PPC.Instr + +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.CLabel + +import GHC.Types.Unique +import GHC.Utils.Outputable (ppr, text, Outputable, (<>)) + +data JumpDest = DestBlockId BlockId + +-- Debug Instance +instance Outputable JumpDest where + ppr (DestBlockId bid) = text "jd:" <> ppr bid + +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid + +canShortcut :: Instr -> Maybe JumpDest +canShortcut _ = Nothing + +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump _ other = other + + +-- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics +shortcutStatics fn (CmmStaticsRaw lbl statics) + = CmmStaticsRaw lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId + | otherwise = lab + +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w) + -- slightly dodgy, we're ignoring the second label, but this + -- works with the way we use CmmLabelDiffOff for jump tables now. +shortcutStatic _ other_static + = other_static + +shortBlockId + :: (BlockId -> Maybe JumpDest) + -> BlockId + -> CLabel + +shortBlockId fn blockid = + case fn blockid of + Nothing -> mkLocalBlockLabel uq + Just (DestBlockId blockid') -> shortBlockId fn blockid' + where uq = getUnique blockid diff --git a/GHC/CmmToAsm/PPC/Regs.hs b/GHC/CmmToAsm/PPC/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/Regs.hs @@ -0,0 +1,316 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1994-2004 +-- +-- ----------------------------------------------------------------------------- + +module GHC.CmmToAsm.PPC.Regs ( + -- squeeze functions + virtualRegSqueeze, + realRegSqueeze, + + mkVirtualReg, + regDotColor, + + -- immediates + Imm(..), + strImmLit, + litToImm, + + -- addressing modes + AddrMode(..), + addrOffset, + + -- registers + spRel, + argRegs, + allArgRegs, + callClobberedRegs, + allMachRegNos, + classOfRealReg, + toRegNo, + + -- machine specific + allFPArgRegs, + fits16Bits, + makeImmediate, + fReg, + r0, sp, toc, r3, r4, r11, r12, r30, + tmpReg, + f1, + + allocatableRegs + +) + +where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Platform.Reg +import GHC.Platform.Reg.Class.Unified +import GHC.CmmToAsm.Format + +import GHC.Cmm +import GHC.Cmm.CLabel ( CLabel ) +import GHC.Types.Unique + +import GHC.Platform.Regs +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform + +import Data.Word ( Word8, Word16, Word32, Word64 ) +import Data.Int ( Int8, Int16, Int32, Int64 ) + + +-- squeese functions for the graph allocator ----------------------------------- + +-- | regSqueeze_class reg +-- Calculate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> Int +virtualRegSqueeze cls vr + = case cls of + RcInteger + -> case vr of + VirtualRegI{} -> 1 + VirtualRegHi{} -> 1 + _other -> 0 + + RcFloatOrVector + -> case vr of + VirtualRegD{} -> 1 + VirtualRegV128{} -> 1 + _other -> 0 + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> Int +realRegSqueeze cls rr + = case cls of + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> 1 -- first fp reg is 32 + | otherwise -> 0 + + + RcFloatOrVector + -> case rr of + RealRegSingle regNo + | regNo < 32 -> 0 + | otherwise -> 1 + + +mkVirtualReg :: Unique -> Format -> VirtualReg +mkVirtualReg u format + | not (isFloatFormat format) = VirtualRegI u + | otherwise + = case format of + FF32 -> VirtualRegD u + FF64 -> VirtualRegD u + _ -> panic "mkVirtualReg" + +regDotColor :: RealReg -> SDoc +regDotColor reg + = case classOfRealReg reg of + RcInteger -> text "blue" + RcFloatOrVector -> text "red" + + + +-- immediates ------------------------------------------------------------------ +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit FastString + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + | LO Imm + | HI Imm + | HA Imm {- high halfword adjusted -} + | HIGHERA Imm + | HIGHESTA Imm + + +strImmLit :: FastString -> Imm +strImmLit s = ImmLit s + + +litToImm :: CmmLit -> Imm +litToImm (CmmInt i w) = ImmInteger (narrowS w i) + -- narrow to the width: a CmmInt might be out of + -- range, but we assume that ImmInteger only contains + -- in-range values. A signed value should be fine here. +litToImm (CmmFloat f W32) = ImmFloat f +litToImm (CmmFloat f W64) = ImmDouble f +litToImm (CmmLabel l) = ImmCLbl l +litToImm (CmmLabelOff l off) = ImmIndex l off +litToImm (CmmLabelDiffOff l1 l2 off _) + = ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) +litToImm _ = panic "PPC.Regs.litToImm: no match" + + +-- addressing modes ------------------------------------------------------------ + +data AddrMode + = AddrRegReg Reg Reg + | AddrRegImm Reg Imm + + +addrOffset :: AddrMode -> Int -> Maybe AddrMode +addrOffset addr off + = case addr of + AddrRegImm r (ImmInt n) + | fits16Bits n2 -> Just (AddrRegImm r (ImmInt n2)) + | otherwise -> Nothing + where n2 = n + off + + AddrRegImm r (ImmInteger n) + | fits16Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) + | otherwise -> Nothing + where n2 = n + toInteger off + + _ -> Nothing + + +-- registers ------------------------------------------------------------------- +-- @spRel@ gives us a stack relative addressing mode for volatile +-- temporaries and for excess call arguments. @fpRel@, where +-- applicable, is the same but for the frame pointer. + +spRel :: Platform + -> Int -- desired stack offset in words, positive or negative + -> AddrMode + +spRel platform n = AddrRegImm sp (ImmInt (n * platformWordSizeInBytes platform)) + + +-- argRegs is the set of regs which are read for an n-argument call to C. +-- For archs which pass all args on the stack (x86), is empty. +-- Sparc passes up to the first 6 args in regs. +argRegs :: RegNo -> [Reg] +argRegs 0 = [] +argRegs 1 = map regSingle [3] +argRegs 2 = map regSingle [3,4] +argRegs 3 = map regSingle [3..5] +argRegs 4 = map regSingle [3..6] +argRegs 5 = map regSingle [3..7] +argRegs 6 = map regSingle [3..8] +argRegs 7 = map regSingle [3..9] +argRegs 8 = map regSingle [3..10] +argRegs _ = panic "MachRegs.argRegs(powerpc): don't know about >8 arguments!" + + +allArgRegs :: [Reg] +allArgRegs = map regSingle [3..10] + + +-- these are the regs which we cannot assume stay alive over a C call. +callClobberedRegs :: Platform -> [Reg] +callClobberedRegs _platform + = map regSingle (0:[2..12] ++ map fReg [0..13]) + + +allMachRegNos :: [RegNo] +allMachRegNos = [0..63] + + +{-# INLINE classOfRealReg #-} +classOfRealReg :: RealReg -> RegClass +classOfRealReg (RealRegSingle i) + | i < 32 = RcInteger + | otherwise = RcFloatOrVector + +toRegNo :: Reg -> RegNo +toRegNo (RegReal (RealRegSingle n)) = n +toRegNo _ = panic "PPC.toRegNo: unsupported register" + +-- machine specific ------------------------------------------------------------ + +allFPArgRegs :: Platform -> [Reg] +allFPArgRegs platform + = case platformOS platform of + OSAIX -> map (regSingle . fReg) [1..13] + _ -> case platformArch platform of + ArchPPC -> map (regSingle . fReg) [1..8] + ArchPPC_64 _ -> map (regSingle . fReg) [1..13] + _ -> panic "PPC.Regs.allFPArgRegs: unknown PPC Linux" + +fits16Bits :: Integral a => a -> Bool +fits16Bits x = x >= -32768 && x < 32768 + +makeImmediate :: Integral a => Width -> Bool -> a -> Maybe Imm +makeImmediate rep signed x = fmap ImmInt (toI16 rep signed) + where + narrow W64 False = fromIntegral (fromIntegral x :: Word64) + narrow W32 False = fromIntegral (fromIntegral x :: Word32) + narrow W16 False = fromIntegral (fromIntegral x :: Word16) + narrow W8 False = fromIntegral (fromIntegral x :: Word8) + narrow W64 True = fromIntegral (fromIntegral x :: Int64) + narrow W32 True = fromIntegral (fromIntegral x :: Int32) + narrow W16 True = fromIntegral (fromIntegral x :: Int16) + narrow W8 True = fromIntegral (fromIntegral x :: Int8) + narrow _ _ = panic "PPC.Regs.narrow: no match" + + narrowed = narrow rep signed + + toI16 W32 True + | narrowed >= -32768 && narrowed < 32768 = Just narrowed + | otherwise = Nothing + toI16 W32 False + | narrowed >= 0 && narrowed < 65536 = Just narrowed + | otherwise = Nothing + toI16 W64 True + | narrowed >= -32768 && narrowed < 32768 = Just narrowed + | otherwise = Nothing + toI16 W64 False + | narrowed >= 0 && narrowed < 65536 = Just narrowed + | otherwise = Nothing + toI16 _ _ = Just narrowed + + +{- +The PowerPC has 64 registers of interest; 32 integer registers and 32 floating +point registers. +-} + +fReg :: Int -> RegNo +fReg x = (32 + x) + +r0, sp, toc, r3, r4, r11, r12, r30, f1 :: Reg +r0 = regSingle 0 +sp = regSingle 1 +toc = regSingle 2 +r3 = regSingle 3 +r4 = regSingle 4 +r11 = regSingle 11 +r12 = regSingle 12 +r30 = regSingle 30 +f1 = regSingle $ fReg 1 + +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform + = let isFree i = freeReg platform i + in map RealRegSingle $ filter isFree allMachRegNos + +-- temporary register for compiler use +tmpReg :: Platform -> Reg +tmpReg platform = + case platformArch platform of + ArchPPC -> regSingle 13 + ArchPPC_64 _ -> regSingle 30 + _ -> panic "PPC.Regs.tmpReg: unknown arch" diff --git a/GHC/CmmToAsm/Ppr.hs b/GHC/CmmToAsm/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Ppr.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- +-- Pretty-printing assembly language +-- +-- (c) The University of Glasgow 1993-2005 +-- +----------------------------------------------------------------------------- + +module GHC.CmmToAsm.Ppr ( + doubleToBytes, + floatToBytes, + pprASCII, + pprString, + pprFileEmbed, + pprSectionHeader +) + +where + +import GHC.Prelude + +import GHC.Utils.Asm +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.CmmToAsm.Config +import GHC.Utils.Outputable as SDoc +import GHC.Utils.Panic +import GHC.Platform + +import qualified Data.Array.Unsafe as U ( castSTUArray ) +import Data.Array.ST + +import Control.Monad.ST +import Data.Word +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import GHC.Exts +import GHC.Word + + +-- ----------------------------------------------------------------------------- +-- Converting floating-point literals to integrals for printing + +-- | Get bytes of a Float representation +floatToBytes :: Float -> [Word8] +floatToBytes f = runST $ do + arr <- newArray_ ((0::Int),3) + writeArray arr 0 f + let cast :: STUArray s Int Float -> ST s (STUArray s Int Word8) + cast = U.castSTUArray + arr <- cast arr + i0 <- readArray arr 0 + i1 <- readArray arr 1 + i2 <- readArray arr 2 + i3 <- readArray arr 3 + return [i0,i1,i2,i3] + +-- | Get bytes of a Double representation +doubleToBytes :: Double -> [Word8] +doubleToBytes d = runST $ do + arr <- newArray_ ((0::Int),7) + writeArray arr 0 d + let cast :: STUArray s Int Double -> ST s (STUArray s Int Word8) + cast = U.castSTUArray + arr <- cast arr + i0 <- readArray arr 0 + i1 <- readArray arr 1 + i2 <- readArray arr 2 + i3 <- readArray arr 3 + i4 <- readArray arr 4 + i5 <- readArray arr 5 + i6 <- readArray arr 6 + i7 <- readArray arr 7 + return [i0,i1,i2,i3,i4,i5,i6,i7] + + +-- --------------------------------------------------------------------------- +-- Printing ASCII strings. +-- +-- Print as a string and escape non-printable characters. +-- This is similar to charToC in GHC.Utils.Misc + +pprASCII :: forall doc. IsLine doc => ByteString -> doc +pprASCII str + -- Transform this given literal bytestring to escaped string and construct + -- the literal SDoc directly. + -- See #14741 + -- and Note [Pretty print ASCII when AsmCodeGen] + -- + -- We work with a `Doc` instead of an `SDoc` because there is no need to carry + -- an `SDocContext` that we don't use. It leads to nicer (STG) code. + = BS.foldr f empty str + where + f :: Word8 -> doc -> doc + f w s = do1 w <> s + + do1 :: Word8 -> doc + do1 w | 0x09 == w = text "\\t" + | 0x0A == w = text "\\n" + | 0x22 == w = text "\\\"" + | 0x5C == w = text "\\\\" + -- ASCII printable characters range + | w >= 0x20 && w <= 0x7E = char (chr' w) + | otherwise = text xs + where + !xs = [ '\\', x0, x1, x2] -- octal + !x0 = chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07) + !x1 = chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07) + !x2 = chr' (ord0 + w .&. 0x07) + !ord0 = 0x30 -- = ord '0' + + -- we know that the Chars we create are in the ASCII range + -- so we bypass the check in "chr" + chr' :: Word8 -> Char + chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#))) +{-# SPECIALIZE pprASCII :: ByteString -> SDoc #-} +{-# SPECIALIZE pprASCII :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Emit a ".string" directive +pprString :: IsLine doc => ByteString -> doc +pprString bs = text "\t.string " <> doubleQuotes (pprASCII bs) +{-# SPECIALIZE pprString :: ByteString -> SDoc #-} +{-# SPECIALIZE pprString :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Emit a ".incbin" directive +-- +-- A NULL byte is added after the binary data. +pprFileEmbed :: IsLine doc => FilePath -> doc +pprFileEmbed path + = text "\t.incbin " + <> pprFilePathString path -- proper escape (see #16389) + <> text "\n\t.byte 0" +{-# SPECIALIZE pprFileEmbed :: FilePath -> SDoc #-} +{-# SPECIALIZE pprFileEmbed :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +{- +Note [Embedding large binary blobs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To embed a blob of binary data (e.g. an UTF-8 encoded string) into the generated +code object, we have several options: + + 1. Generate a ".byte" directive for each byte. This is what was done in the past + (see Note [Pretty print ASCII when AsmCodeGen]). + + 2. Generate a single ".string"/".asciz" directive for the whole sequence of + bytes. Bytes in the ASCII printable range are rendered as characters and + other values are escaped (e.g., "\t", "\077", etc.). + + 3. Create a temporary file into which we dump the binary data and generate a + single ".incbin" directive. The assembler will include the binary file for + us in the generated output object. + +Now the code generator uses either (2) or (3), depending on the binary blob +size. Using (3) for small blobs adds too much overhead (see benchmark results +in #16190), so we only do it when the size is above a threshold (500K at the +time of writing). + +The threshold is configurable via the `-fbinary-blob-threshold` flag. + +-} + + +{- +Note [Pretty print ASCII when AsmCodeGen] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, when generating assembly code, we created SDoc with +`(ptext . sLit)` for every bytes in literal bytestring, then +combine them using `hcat`. + +When handling literal bytestrings with millions of bytes, +millions of SDoc would be created and to combine, leading to +high memory usage. + +Now we escape the given bytestring to string directly and construct +SDoc only once. This improvement could dramatically decrease the +memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal +string in source code. See #14741 for profiling results. +-} + +-- ---------------------------------------------------------------------------- +-- Printing section headers. +-- +-- If -split-section was specified, include the suffix label, otherwise just +-- print the section type. For Darwin, where subsections-for-symbols are +-- used instead, only print section type. +-- +-- For string literals, additional flags are specified to enable merging of +-- identical strings in the linker. With -split-sections each string also gets +-- a unique section to allow strings from unused code to be GC'd. + +pprSectionHeader :: IsLine doc => NCGConfig -> Section -> doc +pprSectionHeader config (Section t suffix) = + case platformOS (ncgPlatform config) of + OSAIX -> pprXcoffSectionHeader t + OSDarwin -> pprDarwinSectionHeader t + _ -> pprGNUSectionHeader config t suffix +{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> SDoc #-} +{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +pprGNUSectionHeader :: IsLine doc => NCGConfig -> SectionType -> CLabel -> doc +pprGNUSectionHeader config t suffix = + hcat [text ".section ", header, subsection, flags] + where + sep + | OSMinGW32 <- platformOS platform = char '$' + | otherwise = char '.' + platform = ncgPlatform config + splitSections = ncgSplitSections config + subsection + | splitSections = sep <> pprAsmLabel platform suffix + | otherwise = empty + header = case t of + Text -> text ".text" + Data -> text ".data" + ReadOnlyData | OSMinGW32 <- platformOS platform + -> text ".rdata" + | otherwise -> text ".rodata" + RelocatableReadOnlyData | OSMinGW32 <- platformOS platform + -- Concept does not exist on Windows, + -- So map these to R/O data. + -> text ".rdata$rel.ro" + | otherwise -> text ".data.rel.ro" + UninitialisedData -> text ".bss" + InitArray + | OSMinGW32 <- platformOS platform + -> text ".ctors" + | otherwise -> text ".init_array" + FiniArray + | OSMinGW32 <- platformOS platform + -> text ".dtors" + | otherwise -> text ".fini_array" + CString + | OSMinGW32 <- platformOS platform + -> text ".rdata" + | otherwise -> text ".rodata.str" + OtherSection _ -> + panic "PprBase.pprGNUSectionHeader: unknown section type" + flags = case t of + Text + | OSMinGW32 <- platformOS platform, splitSections + -> text ",\"xr\"" + | splitSections + -> text ",\"ax\"," <> sectionType platform "progbits" + CString + | OSMinGW32 <- platformOS platform + -> empty + | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1" + _ -> empty +{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc #-} +{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- XCOFF doesn't support relocating label-differences, so we place all +-- RO sections into .text[PR] sections +pprXcoffSectionHeader :: IsLine doc => SectionType -> doc +pprXcoffSectionHeader t = case t of + Text -> text ".csect .text[PR]" + Data -> text ".csect .data[RW]" + ReadOnlyData -> text ".csect .text[PR] # ReadOnlyData" + RelocatableReadOnlyData -> text ".csect .text[PR] # RelocatableReadOnlyData" + CString -> text ".csect .text[PR] # CString" + UninitialisedData -> text ".csect .data[BS]" + _ -> panic "pprXcoffSectionHeader: unknown section type" +{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> SDoc #-} +{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +pprDarwinSectionHeader :: IsLine doc => SectionType -> doc +pprDarwinSectionHeader t = case t of + Text -> text ".text" + Data -> text ".data" + ReadOnlyData -> text ".const" + RelocatableReadOnlyData -> text ".const_data" + UninitialisedData -> text ".data" + InitArray -> text ".section\t__DATA,__mod_init_func,mod_init_funcs" + FiniArray -> panic "pprDarwinSectionHeader: fini not supported" + CString -> text ".section\t__TEXT,__cstring,cstring_literals" + OtherSection _ -> panic "pprDarwinSectionHeader: unknown section type" +{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> SDoc #-} +{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable diff --git a/GHC/CmmToAsm/RV64.hs b/GHC/CmmToAsm/RV64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64.hs @@ -0,0 +1,58 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Native code generator for RiscV64 architectures +module GHC.CmmToAsm.RV64 (ncgRV64) where + +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.RV64.CodeGen qualified as RV64 +import GHC.CmmToAsm.RV64.Instr qualified as RV64 +import GHC.CmmToAsm.RV64.Ppr qualified as RV64 +import GHC.CmmToAsm.RV64.RegInfo qualified as RV64 +import GHC.CmmToAsm.RV64.Regs qualified as RV64 +import GHC.CmmToAsm.Types +import GHC.Prelude +import GHC.Utils.Outputable (ftext) + +ncgRV64 :: NCGConfig -> NcgImpl RawCmmStatics RV64.Instr RV64.JumpDest +ncgRV64 config = + NcgImpl + { ncgConfig = config, + cmmTopCodeGen = RV64.cmmTopCodeGen, + generateJumpTableForInstr = RV64.generateJumpTableForInstr config, + getJumpDestBlockId = RV64.getJumpDestBlockId, + canShortcut = RV64.canShortcut, + shortcutStatics = RV64.shortcutStatics, + shortcutJump = RV64.shortcutJump, + pprNatCmmDeclS = RV64.pprNatCmmDecl config, + pprNatCmmDeclH = RV64.pprNatCmmDecl config, + maxSpillSlots = RV64.maxSpillSlots config, + allocatableRegs = RV64.allocatableRegs platform, + ncgAllocMoreStack = RV64.allocMoreStack platform, + ncgMakeFarBranches = RV64.makeFarBranches, + extractUnwindPoints = const [], + invertCondBranches = \_ _ -> id + } + where + platform = ncgPlatform config + +-- | `Instruction` instance for RV64 +instance Instruction RV64.Instr where + regUsageOfInstr = RV64.regUsageOfInstr + patchRegsOfInstr _ = RV64.patchRegsOfInstr + isJumpishInstr = RV64.isJumpishInstr + canFallthroughTo = RV64.canFallthroughTo + jumpDestsOfInstr = RV64.jumpDestsOfInstr + patchJumpInstr = RV64.patchJumpInstr + mkSpillInstr = RV64.mkSpillInstr + mkLoadInstr = RV64.mkLoadInstr + takeDeltaInstr = RV64.takeDeltaInstr + isMetaInstr = RV64.isMetaInstr + mkRegRegMoveInstr _ _ = RV64.mkRegRegMoveInstr + takeRegRegMoveInstr _ = RV64.takeRegRegMoveInstr + mkJumpInstr = RV64.mkJumpInstr + mkStackAllocInstr = RV64.mkStackAllocInstr + mkStackDeallocInstr = RV64.mkStackDeallocInstr + mkComment = pure . RV64.COMMENT . ftext + pprInstr = RV64.pprInstr diff --git a/GHC/CmmToAsm/RV64/CodeGen.hs b/GHC/CmmToAsm/RV64/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/CodeGen.hs @@ -0,0 +1,2231 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.CmmToAsm.RV64.CodeGen + ( cmmTopCodeGen, + generateJumpTableForInstr, + makeFarBranches, + ) +where + +import Control.Monad +import Data.Maybe +import Data.Word +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.DebugBlock +import GHC.Cmm.Switch +import GHC.Cmm.Utils +import GHC.CmmToAsm.CPrim +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Monad + ( NatM, + getBlockIdNat, + getConfig, + getDebugBlock, + getFileId, + getNewLabelNat, + getNewRegNat, + getPicBaseMaybeNat, + getPlatform, + ) +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.RV64.Cond +import GHC.CmmToAsm.RV64.Instr +import GHC.CmmToAsm.RV64.Regs +import GHC.CmmToAsm.Types +import GHC.Data.FastString +import GHC.Data.OrdList +import GHC.Float +import GHC.Platform +import GHC.Platform.Reg +import GHC.Platform.Regs +import GHC.Prelude hiding (EQ) +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.SrcLoc (srcSpanFile, srcSpanStartCol, srcSpanStartLine) +import GHC.Types.Tickish (GenTickish (..)) +import GHC.Types.Unique.DSM +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- For an overview of an NCG's structure, see Note [General layout of an NCG] + +cmmTopCodeGen :: + RawCmmDecl -> + NatM [NatCmmDecl RawCmmStatics Instr] +-- Thus we'll have to deal with either CmmProc ... +cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do + picBaseMb <- getPicBaseMaybeNat + when (isJust picBaseMb) $ panic "RV64.cmmTopCodeGen: Unexpected PIC base register (RISCV ISA does not define one)" + + let blocks = toBlockListEntryFirst graph + (nat_blocks, statics) <- mapAndUnzipM basicBlockCodeGen blocks + + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + + pure tops + +-- ... or CmmData. +cmmTopCodeGen (CmmData sec dat) = pure [CmmData sec dat] -- no translation, we just use CmmStatic + +basicBlockCodeGen :: + Block CmmNode C C -> + NatM + ( [NatBasicBlock Instr], + [NatCmmDecl RawCmmStatics Instr] + ) +basicBlockCodeGen block = do + config <- getConfig + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + + header_comment_instr + | debugIsOn = + unitOL + $ MULTILINE_COMMENT + ( text "-- --------------------------- basicBlockCodeGen --------------------------- --\n" + $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block) + ) + | otherwise = nilOL + + -- Generate location directive `.loc` (DWARF debug location info) + loc_instrs <- genLocInstrs + + -- Generate other instructions + mid_instrs <- stmtsToInstrs stmts + (!tail_instrs) <- stmtToInstrs tail + + let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs + + -- TODO: Then x86 backend runs @verifyBasicBlock@ here. How important it is to + -- have a valid CFG is an open question: This and the AArch64 and PPC NCGs + -- work fine without it. + + -- Code generation may introduce new basic block boundaries, which are + -- indicated by the NEWBLOCK instruction. We must split up the instruction + -- stream into basic blocks again. Also, we extract LDATAs here too. + (top, other_blocks, statics) = foldrOL mkBlocks ([], [], []) instrs + + return (BasicBlock id top : other_blocks, statics) + where + genLocInstrs :: NatM (OrdList Instr) + genLocInstrs = do + dbg <- getDebugBlock (entryLabel block) + case dblSourceTick =<< dbg of + Just (SourceNote span name) -> + do + fileId <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col = srcSpanStartCol span + pure $ unitOL $ LOCATION fileId line col name + _ -> pure nilOL + +mkBlocks :: + Instr -> + ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) -> + ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) +mkBlocks (NEWBLOCK id) (instrs, blocks, statics) = + ([], BasicBlock id instrs : blocks, statics) +mkBlocks (LDATA sec dat) (instrs, blocks, statics) = + (instrs, blocks, CmmData sec dat : statics) +mkBlocks instr (instrs, blocks, statics) = + (instr : instrs, blocks, statics) + +-- ----------------------------------------------------------------------------- + +-- | Utilities + +-- | Annotate an `Instr` with a `SDoc` comment +ann :: SDoc -> Instr -> Instr +ann doc instr {- debugIsOn -} = ANN doc instr +{-# INLINE ann #-} + +-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with +-- -dppr-debug. The idea is that we can trivially see how a cmm expression +-- ended up producing the assembly we see. By having the verbatim AST printed +-- we can simply check the patterns that were matched to arrive at the assembly +-- we generated. +-- +-- pprExpr will hide a lot of noise of the underlying data structure and print +-- the expression into something that can be easily read by a human. However +-- going back to the exact CmmExpr representation can be laborious and adds +-- indirections to find the matches that lead to the assembly. +-- +-- An improvement could be to have +-- +-- (pprExpr genericPlatform e) <> parens (text. show e) +-- +-- to have the best of both worlds. +-- +-- Note: debugIsOn is too restrictive, it only works for debug compilers. +-- However, we do not only want to inspect this for debug compilers. Ideally +-- we'd have a check for -dppr-debug here already, such that we don't even +-- generate the ANN expressions. However, as they are lazy, they shouldn't be +-- forced until we actually force them, and without -dppr-debug they should +-- never end up being forced. +annExpr :: CmmExpr -> Instr -> Instr +annExpr e {- debugIsOn -} = ANN (text . show $ e) +-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr +-- annExpr _ instr = instr +{-# INLINE annExpr #-} + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +-- Note [RISCV64 Jump Tables] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Jump tables are implemented by generating a table of relative addresses, +-- where each entry is the relative offset to the target block from the first +-- entry / table label (`generateJumpTableForInstr`). Using the jump table means +-- loading the entry's value and jumping to the calculated absolute address +-- (`genSwitch`). +-- +-- For example, this Cmm switch +-- +-- switch [1 .. 10] _s2wn::I64 { +-- case 1 : goto c347; +-- case 2 : goto c348; +-- case 3 : goto c349; +-- case 4 : goto c34a; +-- case 5 : goto c34b; +-- case 6 : goto c34c; +-- case 7 : goto c34d; +-- case 8 : goto c34e; +-- case 9 : goto c34f; +-- case 10 : goto c34g; +-- } // CmmSwitch +-- +-- leads to this jump table in Assembly +-- +-- .section .rodata +-- .balign 8 +-- .Ln34G: +-- .quad 0 +-- .quad .Lc347-(.Ln34G)+0 +-- .quad .Lc348-(.Ln34G)+0 +-- .quad .Lc349-(.Ln34G)+0 +-- .quad .Lc34a-(.Ln34G)+0 +-- .quad .Lc34b-(.Ln34G)+0 +-- .quad .Lc34c-(.Ln34G)+0 +-- .quad .Lc34d-(.Ln34G)+0 +-- .quad .Lc34e-(.Ln34G)+0 +-- .quad .Lc34f-(.Ln34G)+0 +-- .quad .Lc34g-(.Ln34G)+0 +-- +-- and this indexing code where the jump should be done (register t0 contains +-- the index) +-- +-- addi t0, t0, 0 // silly move (ignore it) +-- la t1, .Ln34G // load the table's address +-- sll t0, t0, 3 // index * 8 -> offset in bytes +-- add t0, t0, t1 // address of the table's entry +-- ld t0, 0(t0) // load entry +-- add t0, t0, t1 // relative to absolute address +-- jalr zero, t0, 0 // jump to the block +-- +-- In object code (disassembled) the table looks like +-- +-- 0000000000000000 <.Ln34G>: +-- ... +-- 8: R_RISCV_ADD64 .Lc347 +-- 8: R_RISCV_SUB64 .Ln34G +-- 10: R_RISCV_ADD64 .Lc348 +-- 10: R_RISCV_SUB64 .Ln34G +-- 18: R_RISCV_ADD64 .Lc349 +-- 18: R_RISCV_SUB64 .Ln34G +-- 20: R_RISCV_ADD64 .Lc34a +-- 20: R_RISCV_SUB64 .Ln34G +-- 28: R_RISCV_ADD64 .Lc34b +-- 28: R_RISCV_SUB64 .Ln34G +-- 30: R_RISCV_ADD64 .Lc34c +-- 30: R_RISCV_SUB64 .Ln34G +-- 38: R_RISCV_ADD64 .Lc34d +-- 38: R_RISCV_SUB64 .Ln34G +-- 40: R_RISCV_ADD64 .Lc34e +-- 40: R_RISCV_SUB64 .Ln34G +-- 48: R_RISCV_ADD64 .Lc34f +-- 48: R_RISCV_SUB64 .Ln34G +-- 50: R_RISCV_ADD64 .Lc34g +-- 50: R_RISCV_SUB64 .Ln34G +-- +-- I.e. the relative offset calculations are done by the linker via relocations. +-- This seems to be PIC compatible; at least `scanelf` (pax-utils) does not +-- complain. + + +-- | Generate jump to jump table target +-- +-- The index into the jump table is calulated by evaluating @expr@. The +-- corresponding table entry contains the relative address to jump to (relative +-- to the jump table's first entry / the table's own label). +genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock +genSwitch config expr targets = do + (reg, fmt1, e_code) <- getSomeReg indexExpr + let fmt = II64 + targetReg <- getNewRegNat fmt + lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + (tableReg, fmt2, t_code) <- getSomeReg dynRef + let code = + toOL + [ COMMENT (text "indexExpr" <+> (text . show) indexExpr), + COMMENT (text "dynRef" <+> (text . show) dynRef) + ] + `appOL` e_code + `appOL` t_code + `appOL` toOL + [ COMMENT (ftext "Jump table for switch"), + -- index to offset into the table (relative to tableReg) + annExpr expr (SLL (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))), + -- calculate table entry address + ADD (OpReg W64 targetReg) (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt2) tableReg), + -- load table entry (relative offset from tableReg (first entry) to target label) + LDRU II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))), + -- calculate absolute address of the target label + ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg), + -- prepare jump to target label + J_TBL ids (Just lbl) targetReg + ] + return code + where + -- See Note [Sub-word subtlety during jump-table indexing] in + -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen. + indexExpr0 = cmmOffset platform expr offset + -- We widen to a native-width register to sanitize the high bits + indexExpr = + CmmMachOp + (MO_UU_Conv expr_w (platformWordWidth platform)) + [indexExpr0] + expr_w = cmmExprWidth platform expr + (offset, ids) = switchTargetsToTable targets + platform = ncgPlatform config + +-- | Generate jump table data (if required) +-- +-- The idea is to emit one table entry per case. The entry is the relative +-- address of the block to jump to (relative to the table's first entry / +-- table's own label.) The calculation itself is done by the linker. +generateJumpTableForInstr :: + NCGConfig -> + Instr -> + Maybe (NatCmmDecl RawCmmStatics Instr) +generateJumpTableForInstr config (J_TBL ids (Just lbl) _) = + let jumpTable = + map jumpTableEntryRel ids + where + jumpTableEntryRel Nothing = + CmmStaticLit (CmmInt 0 (ncgWordWidth config)) + jumpTableEntryRel (Just blockid) = + CmmStaticLit + ( CmmLabelDiffOff + blockLabel + lbl + 0 + (ncgWordWidth config) + ) + where + blockLabel = blockLbl blockid + in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable)) +generateJumpTableForInstr _ _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Top-level of the instruction selector + +stmtsToInstrs :: + -- | Cmm Statements + [CmmNode O O] -> + -- | Resulting instruction + NatM InstrBlock +stmtsToInstrs stmts = concatOL <$> mapM stmtToInstrs stmts + +stmtToInstrs :: + CmmNode e x -> + -- | Resulting instructions + NatM InstrBlock +stmtToInstrs stmt = do + config <- getConfig + platform <- getPlatform + case stmt of + CmmUnsafeForeignCall target result_regs args -> + genCCall target result_regs args + CmmComment s -> pure (unitOL (COMMENT (ftext s))) + CmmTick {} -> pure nilOL + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode format reg src + | otherwise -> assignReg_IntCode format reg src + where + ty = cmmRegType reg + format = cmmTypeFormat ty + CmmStore addr src _alignment + | isFloatType ty -> assignMem_FltCode format addr src + | otherwise -> assignMem_IntCode format addr src + where + ty = cmmExprType platform src + format = cmmTypeFormat ty + CmmBranch id -> genBranch id + -- We try to arrange blocks such that the likely branch is the fallthrough + -- in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. + CmmCondBranch arg true false _prediction -> + genCondBranch true false arg + CmmSwitch arg ids -> genSwitch config arg ids + CmmCall {cml_target = arg} -> genJump arg + CmmUnwind _regs -> pure nilOL + -- Intentionally not have a default case here: If anybody adds a + -- constructor, the compiler should force them to think about this here. + CmmForeignCall {} -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt) + CmmEntry {} -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt) + +-------------------------------------------------------------------------------- + +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +type InstrBlock = + OrdList Instr + +-- | Register's passed up the tree. +-- +-- If the stix code forces the register to live in a pre-decided machine +-- register, it comes out as @Fixed@; otherwise, it comes out as @Any@, and the +-- parent can decide which register to put it in. +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + +-- | Sometimes we need to change the Format of a register. Primarily during +-- conversion. +swizzleRegisterRep :: Format -> Register -> Register +swizzleRegisterRep format' (Fixed _format reg code) = Fixed format' reg code +swizzleRegisterRep format' (Any _format codefn) = Any format' codefn + +-- | Grab a `Reg` for a `CmmReg` +-- +-- `LocalReg`s are assigned virtual registers (`RegVirtual`), `GlobalReg`s are +-- assigned real registers (`RegReal`). It is an error if a `GlobalReg` is not a +-- STG register. +getRegisterReg :: Platform -> CmmReg -> Reg +getRegisterReg _ (CmmLocal (LocalReg u pk)) = + RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) +getRegisterReg platform (CmmGlobal mid) = + case globalRegMaybe platform (globalRegUse_reg mid) of + Just reg -> RegReal reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + +-- ----------------------------------------------------------------------------- +-- General things for putting together code sequences + +-- | Compute an expression into any register +getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + newReg <- getNewRegNat rep + return (newReg, rep, code newReg) + Fixed rep reg code -> + return (reg, rep, code) + +-- | Compute an expression into any floating-point register +-- +-- If the initial expression is not a floating-point expression, finally move +-- the result into a floating-point register. +getFloatReg :: (HasCallStack) => CmmExpr -> NatM (Reg, Format, InstrBlock) +getFloatReg expr = do + r <- getRegister expr + case r of + Any rep code | isFloatFormat rep -> do + newReg <- getNewRegNat rep + return (newReg, rep, code newReg) + Any II32 code -> do + newReg <- getNewRegNat FF32 + return (newReg, FF32, code newReg) + Any II64 code -> do + newReg <- getNewRegNat FF64 + return (newReg, FF64, code newReg) + Any _w _code -> do + config <- getConfig + pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr) + -- can't do much for fixed. + Fixed rep reg code -> + return (reg, rep, code) + +-- | Map `CmmLit` to `OpImm` +-- +-- N.B. this is a partial function, because not all `CmmLit`s have an immediate +-- representation. +litToImm' :: CmmLit -> Operand +litToImm' = OpImm . litToImm + +-- | Compute a `CmmExpr` into a `Register` +getRegister :: CmmExpr -> NatM Register +getRegister e = do + config <- getConfig + getRegister' config (ncgPlatform config) e + +-- | The register width to be used for an operation on the given width +-- operand. +opRegWidth :: Width -> Width +opRegWidth W64 = W64 +opRegWidth W32 = W32 +opRegWidth W16 = W32 +opRegWidth W8 = W32 +opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) + +-- Note [Signed arithmetic on RISCV64] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Handling signed arithmetic on sub-word-size values on RISCV64 is a bit +-- tricky as Cmm's type system does not capture signedness. While 32-bit values +-- are fairly easy to handle due to RISCV64's 32-bit instruction variants +-- (denoted by use of %wN registers), 16- and 8-bit values require quite some +-- care. +-- +-- We handle 16-and 8-bit values by using the 32-bit operations and +-- sign-/zero-extending operands and truncate results as necessary. For +-- simplicity we maintain the invariant that a register containing a +-- sub-word-size value always contains the zero-extended form of that value +-- in between operations. +-- +-- For instance, consider the program, +-- +-- test(bits64 buffer) +-- bits8 a = bits8[buffer]; +-- bits8 b = %mul(a, 42); +-- bits8 c = %not(b); +-- bits8 d = %shrl(c, 4::bits8); +-- return (d); +-- } +-- +-- This program begins by loading `a` from memory, for which we use a +-- zero-extended byte-size load. We next sign-extend `a` to 32-bits, and use a +-- 32-bit multiplication to compute `b`, and truncate the result back down to +-- 8-bits. +-- +-- Next we compute `c`: The `%not` requires no extension of its operands, but +-- we must still truncate the result back down to 8-bits. Finally the `%shrl` +-- requires no extension and no truncate since we can assume that +-- `c` is zero-extended. +-- +-- The "RISC-V Sign Extension Optimizations" LLVM tech talk presentation by +-- Craig Topper covers possible future improvements +-- (https://llvm.org/devmtg/2022-11/slides/TechTalk21-RISC-VSignExtensionOptimizations.pdf) +-- +-- +-- Note [Handling PIC on RV64] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- RV64 does not have a special PIC register, the general approach is to simply +-- do PC-relative addressing or go through the GOT. There is assembly support +-- for both. +-- +-- rv64 assembly has a `la` (load address) pseudo-instruction, that allows +-- loading a label's address into a register. The instruction is desugared into +-- different addressing modes, e.g. PC-relative addressing: +-- +-- 1: lui rd1, %pcrel_hi(label) +-- addi rd1, %pcrel_lo(1b) +-- +-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dModifiers.html, +-- PIC can be enabled/disabled through +-- +-- .option pic +-- +-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dDirectives.html#RISC_002dV_002dDirectives +-- +-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the +-- @cmmMakePicReference@. This is in turn called from @cmmMakeDynamicReference@ +-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported. There are two +-- callsites for this. One is in this module to produce the @target@ in @genCCall@ +-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@. +-- +-- Conceptually we do not want any special PicBaseReg to be used on RV64. If +-- we want to distinguish between symbol loading, we need to address this through +-- the way we load it, not through a register. +-- + +getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register +-- OPTIMIZATION WARNING: CmmExpr rewrites +-- 1. Rewrite: Reg + (-n) => Reg - n +-- TODO: this expression shouldn't even be generated to begin with. +getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)]) + | i < 0 = + getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)]) +getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)]) + | i < 0 = + getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt (-i) w1)]) +-- Generic case. +getRegister' config plat expr = + case expr of + CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) -> + -- See Note [Handling PIC on RV64] + pprPanic "getRegister': There's no PIC base register on RISCV" (ppr PicBaseReg) + CmmLit lit -> + case lit of + CmmInt 0 w -> pure $ Fixed (intFormat w) zeroReg nilOL + CmmInt i w -> + -- narrowU is important: Negative immediates may be + -- sign-extended on load! + let imm = OpImm . ImmInteger $ narrowU w i + in pure (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) imm))) + CmmFloat 0 w -> do + let op = litToImm' lit + pure (Any (floatFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) op))) + CmmFloat _f W8 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr) + CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr) + CmmFloat f W32 -> do + let word = castFloatToWord32 (fromRational f) :: Word32 + intReg <- getNewRegNat (intFormat W32) + return + ( Any + (floatFormat W32) + ( \dst -> + toOL + [ annExpr expr + $ MOV (OpReg W32 intReg) (OpImm (ImmInteger (fromIntegral word))), + MOV (OpReg W32 dst) (OpReg W32 intReg) + ] + ) + ) + CmmFloat f W64 -> do + let word = castDoubleToWord64 (fromRational f) :: Word64 + intReg <- getNewRegNat (intFormat W64) + return + ( Any + (floatFormat W64) + ( \dst -> + toOL + [ annExpr expr + $ MOV (OpReg W64 intReg) (OpImm (ImmInteger (fromIntegral word))), + MOV (OpReg W64 dst) (OpReg W64 intReg) + ] + ) + ) + CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr) + CmmVec _lits -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr) + CmmLabel lbl -> do + let op = OpImm (ImmCLbl lbl) + rep = cmmLitType plat lit + format = cmmTypeFormat rep + return (Any format (\dst -> unitOL $ annExpr expr (LDR format (OpReg (formatToWidth format) dst) op))) + CmmLabelOff lbl off | isNbitEncodeable 12 (fromIntegral off) -> do + let op = OpImm (ImmIndex lbl off) + rep = cmmLitType plat lit + format = cmmTypeFormat rep + return (Any format (\dst -> unitOL $ LDR format (OpReg (formatToWidth format) dst) op)) + CmmLabelOff lbl off -> do + let op = litToImm' (CmmLabel lbl) + rep = cmmLitType plat lit + format = cmmTypeFormat rep + width = typeWidth rep + (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width) + return + ( Any + format + ( \dst -> + off_code + `snocOL` LDR format (OpReg (formatToWidth format) dst) op + `snocOL` ADD (OpReg width dst) (OpReg width dst) (OpReg width off_r) + ) + ) + CmmLabelDiffOff {} -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmLoad mem rep _ -> do + let format = cmmTypeFormat rep + width = typeWidth rep + Amode addr addr_code <- getAmode plat width mem + case width of + w + | w <= W64 -> + -- Load without sign-extension. See Note [Signed arithmetic on RISCV64] + pure + ( Any + format + ( \dst -> + addr_code + `snocOL` LDRU format (OpReg width dst) (OpAddr addr) + ) + ) + _ -> + pprPanic ("Width too big! Cannot load: " ++ show width) (pdoc plat expr) + CmmStackSlot _ _ -> + pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr) + CmmReg reg -> + return + ( Fixed + (cmmTypeFormat (cmmRegType reg)) + (getRegisterReg plat reg) + nilOL + ) + CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do + getRegister' config plat + $ CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where + width = typeWidth (cmmRegType reg) + CmmRegOff reg off -> do + (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width) + (reg, _format, code) <- getSomeReg $ CmmReg reg + return + $ Any + (intFormat width) + ( \dst -> + off_code + `appOL` code + `snocOL` ADD (OpReg width dst) (OpReg width reg) (OpReg width off_r) + ) + where + width = typeWidth (cmmRegType reg) + + -- Handle MO_RelaxedRead as a normal CmmLoad, to allow + -- non-trivial addressing modes to be used. + CmmMachOp (MO_RelaxedRead w) [e] -> + getRegister (CmmLoad e (cmmBits w) NaturallyAligned) + -- for MachOps, see GHC.Cmm.MachOp + -- For CmmMachOp, see GHC.Cmm.Expr + CmmMachOp op [e] -> do + (reg, _format, code) <- getSomeReg e + case op of + MO_Not w -> return $ Any (intFormat w) $ \dst -> + let w' = opRegWidth w + in code + `snocOL` + -- pseudo instruction `not` is `xori rd, rs, -1` + ann (text "not") (XORI (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt (-1)))) + `appOL` truncateReg w' w dst -- See Note [Signed arithmetic on RISCV64] + MO_S_Neg w -> negate code w reg + MO_F_Neg w -> + return + $ Any + (floatFormat w) + ( \dst -> + code + `snocOL` NEG (OpReg w dst) (OpReg w reg) + ) + -- TODO: Can this case happen? + MO_SF_Round from to | from < W32 -> do + -- extend to the smallest available representation + (reg_x, code_x) <- signExtendReg from W32 reg + pure + $ Any + (floatFormat to) + ( \dst -> + code + `appOL` code_x + `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg_x)) -- (Signed ConVerT Float) + ) + MO_SF_Round from to -> + pure + $ Any + (floatFormat to) + ( \dst -> + code + `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float) + ) + -- TODO: Can this case happen? + MO_FS_Truncate from to + | to < W32 -> + pure + $ Any + (intFormat to) + ( \dst -> + code + `snocOL` + -- W32 is the smallest width to convert to. Decrease width afterwards. + annExpr expr (FCVT FloatToInt (OpReg W32 dst) (OpReg from reg)) + `appOL` signExtendAdjustPrecission W32 to dst dst -- (float convert (-> zero) signed) + ) + MO_FS_Truncate from to -> + pure + $ Any + (intFormat to) + ( \dst -> + code + `snocOL` annExpr expr (FCVT FloatToInt (OpReg to dst) (OpReg from reg)) + `appOL` truncateReg from to dst -- (float convert (-> zero) signed) + ) + MO_UU_Conv from to + | from <= to -> + pure + $ Any + (intFormat to) + ( \dst -> + code + `snocOL` annExpr e (MOV (OpReg to dst) (OpReg from reg)) + ) + MO_UU_Conv from to -> + pure + $ Any + (intFormat to) + ( \dst -> + code + `snocOL` annExpr e (MOV (OpReg from dst) (OpReg from reg)) + `appOL` truncateReg from to dst + ) + MO_SS_Conv from to -> ss_conv from to reg code + MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` annExpr e (FCVT FloatToFloat (OpReg to dst) (OpReg from reg))) + MO_WF_Bitcast w -> return $ Any (floatFormat w) (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg)) + MO_FW_Bitcast w -> return $ Any (intFormat w) (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg)) + + -- Conversions + -- TODO: Duplication with MO_UU_Conv + MO_XX_Conv from to + | to < from -> + pure + $ Any + (intFormat to) + ( \dst -> + code + `snocOL` annExpr e (MOV (OpReg from dst) (OpReg from reg)) + `appOL` truncateReg from to dst + ) + MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e + MO_AlignmentCheck align wordWidth -> do + reg <- getRegister' config plat e + addAlignmentCheck align wordWidth reg + x -> pprPanic ("getRegister' (monadic CmmMachOp): " ++ show x) (pdoc plat expr) + where + -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits + -- See Note [Signed arithmetic on RISCV64]. + negate code w reg = do + let w' = opRegWidth w + (reg', code_sx) <- signExtendReg w w' reg + return $ Any (intFormat w) $ \dst -> + code + `appOL` code_sx + `snocOL` NEG (OpReg w' dst) (OpReg w' reg') + `appOL` truncateReg w' w dst + + ss_conv from to reg code + | from < to = do + pure $ Any (intFormat to) $ \dst -> + code + `appOL` signExtend from to reg dst + `appOL` truncateReg from to dst + | from > to = + pure $ Any (intFormat to) $ \dst -> + code + `appOL` toOL + [ ann + (text "MO_SS_Conv: narrow register signed" <+> ppr reg <+> ppr from <> text "->" <> ppr to) + (SLL (OpReg to dst) (OpReg from reg) (OpImm (ImmInt shift))), + -- signed right shift + SRA (OpReg to dst) (OpReg to dst) (OpImm (ImmInt shift)) + ] + `appOL` truncateReg from to dst + | otherwise = + -- No conversion necessary: Just copy. + pure $ Any (intFormat from) $ \dst -> + code `snocOL` MOV (OpReg from dst) (OpReg from reg) + where + shift = 64 - (widthInBits from - widthInBits to) + + -- Dyadic machops: + -- + -- The general idea is: + -- compute x <- x + -- compute x <- y + -- OP x, x, x + -- + -- TODO: for now we'll only implement the 64bit versions. And rely on the + -- fallthrough to alert us if things go wrong! + -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring + -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg + CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' + CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' + -- 1. Compute Reg +/- n directly. + -- For Add/Sub we can directly encode 12bits, or 12bits lsl #12. + CmmMachOp (MO_Add w) [CmmReg reg, CmmLit (CmmInt n _)] + | fitsIn12bitImm n -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + where + -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. + w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) + r' = getRegisterReg plat reg + CmmMachOp (MO_Sub w) [CmmReg reg, CmmLit (CmmInt n _)] + | fitsIn12bitImm n -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + where + -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. + w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) + r' = getRegisterReg plat reg + CmmMachOp (MO_U_Quot w) [x, y] | w == W8 || w == W16 -> do + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + return + $ Any + (intFormat w) + ( \dst -> + code_x + `appOL` truncateReg (formatToWidth format_x) w reg_x + `appOL` code_y + `appOL` truncateReg (formatToWidth format_y) w reg_y + `snocOL` annExpr expr (DIVU (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + + -- 2. Shifts. x << n, x >> n. + CmmMachOp (MO_Shl w) [x, CmmLit (CmmInt n _)] + | w == W32, + 0 <= n, + n < 32 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return + $ Any + (intFormat w) + ( \dst -> + code_x + `snocOL` annExpr expr (SLL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))) + `appOL` truncateReg w w dst + ) + CmmMachOp (MO_Shl w) [x, CmmLit (CmmInt n _)] + | w == W64, + 0 <= n, + n < 64 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return + $ Any + (intFormat w) + ( \dst -> + code_x + `snocOL` annExpr expr (SLL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))) + `appOL` truncateReg w w dst + ) + CmmMachOp (MO_S_Shr w) [x, CmmLit (CmmInt n _)] | fitsIn12bitImm n -> do + (reg_x, format_x, code_x) <- getSomeReg x + (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x + return + $ Any + (intFormat w) + ( \dst -> + code_x + `appOL` code_x' + `snocOL` annExpr expr (SRA (OpReg w dst) (OpReg w reg_x') (OpImm (ImmInteger n))) + ) + CmmMachOp (MO_S_Shr w) [x, y] -> do + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x + return + $ Any + (intFormat w) + ( \dst -> + code_x + `appOL` code_x' + `appOL` code_y + `snocOL` annExpr expr (SRA (OpReg w dst) (OpReg w reg_x') (OpReg w reg_y)) + ) + CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)] + | w == W8, + 0 <= n, + n < 8 -> do + (reg_x, format_x, code_x) <- getSomeReg x + return + $ Any + (intFormat w) + ( \dst -> + code_x + `appOL` truncateReg (formatToWidth format_x) w reg_x + `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))) + ) + CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)] + | w == W16, + 0 <= n, + n < 16 -> do + (reg_x, format_x, code_x) <- getSomeReg x + return + $ Any + (intFormat w) + ( \dst -> + code_x + `appOL` truncateReg (formatToWidth format_x) w reg_x + `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))) + ) + CmmMachOp (MO_U_Shr w) [x, y] | w == W8 || w == W16 -> do + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return + $ Any + (intFormat w) + ( \dst -> + code_x + `appOL` code_y + `appOL` truncateReg (formatToWidth format_x) w reg_x + `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)] + | w == W32, + 0 <= n, + n < 32 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return + $ Any + (intFormat w) + ( \dst -> + code_x + `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))) + ) + CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)] + | w == W64, + 0 <= n, + n < 64 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return + $ Any + (intFormat w) + ( \dst -> + code_x + `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))) + ) + + -- 3. Logic &&, || + CmmMachOp (MO_And w) [CmmReg reg, CmmLit (CmmInt n _)] + | fitsIn12bitImm n -> + return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + where + w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) + r' = getRegisterReg plat reg + CmmMachOp (MO_Or w) [CmmReg reg, CmmLit (CmmInt n _)] + | fitsIn12bitImm n -> + return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORI (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + where + w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) + r' = getRegisterReg plat reg + + -- Generic binary case. + CmmMachOp op [x, y] -> do + let -- A "plain" operation. + bitOp w op = do + -- compute x <- x + -- compute x <- y + -- x, x, x + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOp: incompatible" + return + $ Any + (intFormat w) + ( \dst -> + code_x + `appOL` code_y + `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y) + ) + + -- A (potentially signed) integer operation. + -- In the case of 8- and 16-bit signed arithmetic we must first + -- sign-extend both arguments to 32-bits. + -- See Note [Signed arithmetic on RISCV64]. + intOp is_signed w op = do + -- compute x <- x + -- compute x <- y + -- x, x, x + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int" + -- This is the width of the registers on which the operation + -- should be performed. + let w' = opRegWidth w + signExt r + | not is_signed = return (r, nilOL) + | otherwise = signExtendReg w w' r + (reg_x_sx, code_x_sx) <- signExt reg_x + (reg_y_sx, code_y_sx) <- signExt reg_y + return $ Any (intFormat w) $ \dst -> + code_x + `appOL` code_y + `appOL` + -- sign-extend both operands + code_x_sx + `appOL` code_y_sx + `appOL` op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) + `appOL` truncateReg w' w dst -- truncate back to the operand's original width + floatOp w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float" + return + $ Any + (floatFormat w) + ( \dst -> + code_fx + `appOL` code_fy + `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) + ) + + -- need a special one for conditionals, as they return ints + floatCond w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float" + return + $ Any + (intFormat w) + ( \dst -> + code_fx + `appOL` code_fy + `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) + ) + + case op of + -- Integer operations + -- Add/Sub should only be Integer Options. + MO_Add w -> intOp False w (\d x y -> unitOL $ annExpr expr (ADD d x y)) + -- TODO: Handle sub-word case + MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y)) + -- N.B. We needn't sign-extend sub-word size (in)equality comparisons + -- since we don't care about ordering. + MO_Eq w -> bitOp w (\d x y -> unitOL $ annExpr expr (CSET d x y EQ)) + MO_Ne w -> bitOp w (\d x y -> unitOL $ annExpr expr (CSET d x y NE)) + -- Signed multiply/divide + MO_Mul w -> intOp True w (\d x y -> unitOL $ annExpr expr (MUL d x y)) + MO_S_MulMayOflo w -> do_mul_may_oflo w x y + MO_S_Quot w -> intOp True w (\d x y -> unitOL $ annExpr expr (DIV d x y)) + MO_S_Rem w -> intOp True w (\d x y -> unitOL $ annExpr expr (REM d x y)) + -- Unsigned multiply/divide + MO_U_Quot w -> intOp False w (\d x y -> unitOL $ annExpr expr (DIVU d x y)) + MO_U_Rem w -> intOp False w (\d x y -> unitOL $ annExpr expr (REMU d x y)) + -- Signed comparisons + MO_S_Ge w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGE)) + MO_S_Le w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SLE)) + MO_S_Gt w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGT)) + MO_S_Lt w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SLT)) + -- Unsigned comparisons + MO_U_Ge w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y UGE)) + MO_U_Le w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y ULE)) + MO_U_Gt w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y UGT)) + MO_U_Lt w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y ULT)) + -- Floating point arithmetic + MO_F_Add w -> floatOp w (\d x y -> unitOL $ annExpr expr (ADD d x y)) + MO_F_Sub w -> floatOp w (\d x y -> unitOL $ annExpr expr (SUB d x y)) + MO_F_Mul w -> floatOp w (\d x y -> unitOL $ annExpr expr (MUL d x y)) + MO_F_Quot w -> floatOp w (\d x y -> unitOL $ annExpr expr (DIV d x y)) + -- Floating point comparison + MO_F_Min w -> floatOp w (\d x y -> unitOL $ annExpr expr (FMIN d x y)) + MO_F_Max w -> floatOp w (\d x y -> unitOL $ annExpr expr (FMAX d x y)) + MO_F_Eq w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y EQ)) + MO_F_Ne w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y NE)) + MO_F_Ge w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FGE)) + MO_F_Le w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FLE)) -- x <= y <=> y > x + MO_F_Gt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FGT)) + MO_F_Lt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FLT)) -- x < y <=> y >= x + + -- Bitwise operations + MO_And w -> bitOp w (\d x y -> unitOL $ annExpr expr (AND d x y)) + MO_Or w -> bitOp w (\d x y -> unitOL $ annExpr expr (OR d x y)) + MO_Xor w -> bitOp w (\d x y -> unitOL $ annExpr expr (XOR d x y)) + MO_Shl w -> intOp False w (\d x y -> unitOL $ annExpr expr (SLL d x y)) + MO_U_Shr w -> intOp False w (\d x y -> unitOL $ annExpr expr (SRL d x y)) + MO_S_Shr w -> intOp True w (\d x y -> unitOL $ annExpr expr (SRA d x y)) + op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ pprMachOp op <+> text "in" <+> pdoc plat expr + + -- Generic ternary case. + CmmMachOp op [x, y, z] -> + case op of + -- Floating-point fused multiply-add operations + -- + -- x86 fmadd x * y + z <=> RISCV64 fmadd : d = r1 * r2 + r3 + -- x86 fmsub x * y - z <=> RISCV64 fnmsub: d = r1 * r2 - r3 + -- x86 fnmadd - x * y + z <=> RISCV64 fmsub : d = - r1 * r2 + r3 + -- x86 fnmsub - x * y - z <=> RISCV64 fnmadd: d = - r1 * r2 - r3 + MO_FMA var l w + | l == 1 + -> case var of + FMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMAdd d n m a) + FMSub -> float3Op w (\d n m a -> unitOL $ FMA FMSub d n m a) + FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FNMSub d n m a) + FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a) + | otherwise + -> sorry "The RISCV64 backend does not (yet) support vectors." + _ -> + pprPanic "getRegister' (unhandled ternary CmmMachOp): " + $ pprMachOp op + <+> text "in" + <+> pdoc plat expr + where + float3Op w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + (reg_fz, format_z, code_fz) <- getFloatReg z + massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z) + $ text "float3Op: non-float" + pure + $ Any (floatFormat w) + $ \dst -> + code_fx + `appOL` code_fy + `appOL` code_fz + `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz) + CmmMachOp _op _xs -> + pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr) + where + isNbitEncodeable :: Int -> Integer -> Bool + isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift) + -- N.B. MUL does not set the overflow flag. + -- Return 0 when the operation cannot overflow, /= 0 otherwise + do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register + do_mul_may_oflo w _x _y | w > W64 = pprPanic "Cannot multiply larger than 64bit" (ppr w) + do_mul_may_oflo w@W64 x y = do + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + -- TODO: Can't we clobber reg_x and reg_y to save registers? + lo <- getNewRegNat II64 + hi <- getNewRegNat II64 + -- TODO: Overhaul CSET: 3rd operand isn't needed for SNEZ + let nonSense = OpImm (ImmInt 0) + pure + $ Any + (intFormat w) + ( \dst -> + code_x + `appOL` signExtend (formatToWidth format_x) W64 reg_x reg_x + `appOL` code_y + `appOL` signExtend (formatToWidth format_y) W64 reg_y reg_y + `appOL` toOL + [ annExpr expr (MULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y)), + MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y), + SRA (OpReg w lo) (OpReg w lo) (OpImm (ImmInt (widthInBits W64 - 1))), + ann + (text "Set flag if result of MULH contains more than sign bits.") + (XOR (OpReg w hi) (OpReg w hi) (OpReg w lo)), + CSET (OpReg w dst) (OpReg w hi) nonSense NE + ] + ) + do_mul_may_oflo w x y = do + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + let width_x = formatToWidth format_x + width_y = formatToWidth format_y + if w > width_x && w > width_y + then + pure + $ Any + (intFormat w) + ( \dst -> + -- 8bit * 8bit cannot overflow 16bit + -- 16bit * 16bit cannot overflow 32bit + -- 32bit * 32bit cannot overflow 64bit + unitOL $ annExpr expr (ADD (OpReg w dst) zero (OpImm (ImmInt 0))) + ) + else do + let use32BitMul = w <= W32 && width_x <= W32 && width_y <= W32 + nonSense = OpImm (ImmInt 0) + if use32BitMul + then do + narrowedReg <- getNewRegNat II64 + pure + $ Any + (intFormat w) + ( \dst -> + code_x + `appOL` signExtend (formatToWidth format_x) W32 reg_x reg_x + `appOL` code_y + `appOL` signExtend (formatToWidth format_y) W32 reg_y reg_y + `snocOL` annExpr expr (MUL (OpReg W32 dst) (OpReg W32 reg_x) (OpReg W32 reg_y)) + `appOL` signExtendAdjustPrecission W32 w dst narrowedReg + `appOL` toOL + [ ann + (text "Check if the multiplied value fits in the narrowed register") + (SUB (OpReg w dst) (OpReg w dst) (OpReg w narrowedReg)), + CSET (OpReg w dst) (OpReg w dst) nonSense NE + ] + ) + else + pure + $ Any + (intFormat w) + ( \dst -> + -- Do not handle this unlikely case. Just tell that it may overflow. + unitOL $ annExpr expr (ADD (OpReg w dst) zero (OpImm (ImmInt 1))) + ) + +-- | Instructions to sign-extend the value in the given register from width @w@ +-- up to width @w'@. +signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr) +signExtendReg w _w' r | w == W64 = pure (r, nilOL) +signExtendReg w w' r = do + r' <- getNewRegNat (intFormat w') + let instrs = signExtend w w' r r' + pure (r', instrs) + +-- | Sign extends to 64bit, if needed +-- +-- Source `Reg` @r@ stays untouched, while the conversion happens on destination +-- `Reg` @r'@. +signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr +signExtend w w' _r _r' | w > w' = pprPanic "This is not a sign extension, but a truncation." $ ppr w <> text "->" <+> ppr w' +signExtend w w' _r _r' | w > W64 || w' > W64 = pprPanic "Unexpected width (max is 64bit):" $ ppr w <> text "->" <+> ppr w' +signExtend w w' r r' | w == W64 && w' == W64 && r == r' = nilOL +signExtend w w' r r' | w == W64 && w' == W64 = unitOL $ MOV (OpReg w' r') (OpReg w r) +signExtend w w' r r' + | w == W32 && w' == W64 = + unitOL + $ ann + (text "sign-extend register (SEXT.W)" <+> ppr r <+> ppr w <> text "->" <> ppr w') + -- `ADDIW r r 0` is the pseudo-op SEXT.W + (ADD (OpReg w' r') (OpReg w r) (OpImm (ImmInt 0))) +signExtend w w' r r' = + toOL + [ ann + (text "narrow register signed" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w') + (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))), + -- signed (arithmetic) right shift + SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift)) + ] + where + shift = 64 - widthInBits w + +-- | Sign extends to 64bit, if needed and reduces the precission to the target `Width` (@w'@) +-- +-- Source `Reg` @r@ stays untouched, while the conversion happens on destination +-- `Reg` @r'@. +signExtendAdjustPrecission :: Width -> Width -> Reg -> Reg -> OrdList Instr +signExtendAdjustPrecission w w' _r _r' | w > W64 || w' > W64 = pprPanic "Unexpected width (max is 64bit):" $ ppr w <> text "->" <+> ppr w' +signExtendAdjustPrecission w w' r r' | w == W64 && w' == W64 && r == r' = nilOL +signExtendAdjustPrecission w w' r r' | w == W64 && w' == W64 = unitOL $ MOV (OpReg w' r') (OpReg w r) +signExtendAdjustPrecission w w' r r' + | w == W32 && w' == W64 = + unitOL + $ ann + (text "sign-extend register (SEXT.W)" <+> ppr r <+> ppr w <> text "->" <> ppr w') + -- `ADDIW r r 0` is the pseudo-op SEXT.W + (ADD (OpReg w' r') (OpReg w r) (OpImm (ImmInt 0))) +signExtendAdjustPrecission w w' r r' + | w > w' = + toOL + [ ann + (text "narrow register signed" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w') + (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))), + -- signed (arithmetic) right shift + SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift)) + ] + where + shift = 64 - widthInBits w' +signExtendAdjustPrecission w w' r r' = + toOL + [ ann + (text "sign extend register" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w') + (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))), + -- signed (arithmetic) right shift + SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift)) + ] + where + shift = 64 - widthInBits w + +-- | Instructions to truncate the value in the given register from width @w@ +-- to width @w'@. +-- +-- In other words, it just cuts the width out of the register. N.B.: This +-- ignores signedness (no sign extension takes place)! +truncateReg :: Width -> Width -> Reg -> OrdList Instr +truncateReg _w w' _r | w' == W64 = nilOL +truncateReg _w w' r | w' > W64 = pprPanic "Cannot truncate to width bigger than register size (max is 64bit):" $ text (show r) <> char ':' <+> ppr w' +truncateReg w _w' r | w > W64 = pprPanic "Unexpected register size (max is 64bit):" $ text (show r) <> char ':' <+> ppr w +truncateReg w w' r = + toOL + [ ann + (text "truncate register" <+> ppr r <+> ppr w <> text "->" <> ppr w') + (SLL (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift))), + -- SHL ignores signedness! + SRL (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift)) + ] + where + shift = 64 - widthInBits w' + +-- | Given a 'Register', produce a new 'Register' with an instruction block +-- which will check the value for alignment. Used for @-falignment-sanitisation@. +addAlignmentCheck :: Int -> Width -> Register -> NatM Register +addAlignmentCheck align wordWidth reg = do + jumpReg <- getNewRegNat II64 + cmpReg <- getNewRegNat II64 + okayLblId <- getBlockIdNat + + pure $ case reg of + Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt jumpReg cmpReg okayLblId reg) + Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt jumpReg cmpReg okayLblId reg) + where + check :: Format -> Reg -> Reg -> BlockId -> Reg -> InstrBlock + check fmt jumpReg cmpReg okayLblId reg = + let width = formatToWidth fmt + in assert (not $ isFloatFormat fmt) + $ toOL + [ ann + (text "Alignment check - alignment: " <> int align <> text ", word width: " <> text (show wordWidth)) + (AND (OpReg width cmpReg) (OpReg width reg) (OpImm $ ImmInt $ align - 1)), + BCOND EQ (OpReg width cmpReg) zero (TBlock okayLblId), + COMMENT (text "Alignment check failed"), + LDR II64 (OpReg W64 jumpReg) (OpImm $ ImmCLbl mkBadAlignmentLabel), + B (TReg jumpReg), + NEWBLOCK okayLblId + ] + +-- ----------------------------------------------------------------------------- +-- The 'Amode' type: Memory addressing modes passed up the tree. +data Amode = Amode AddrMode InstrBlock + +-- | Provide the value of a `CmmExpr` with an `Amode` +-- +-- N.B. this function should be used to provide operands to load and store +-- instructions with signed 12bit wide immediates (S & I types). For other +-- immediate sizes and formats (e.g. B type uses multiples of 2) this function +-- would need to be adjusted. +getAmode :: + Platform -> + -- | width of loaded value + Width -> + CmmExpr -> + NatM Amode +-- TODO: Specialize stuff we can destructure here. + +-- LDR/STR: Immediate can be represented with 12bits +getAmode platform w (CmmRegOff reg off) + | w <= W64, + fitsIn12bitImm off = + return $ Amode (AddrRegImm reg' off') nilOL + where + reg' = getRegisterReg platform reg + off' = ImmInt off + +-- For Stores we often see something like this: +-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2) +-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ] +-- for `n` in range. +getAmode _platform _ (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')]) + | fitsIn12bitImm off = + do + (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrRegImm reg (ImmInteger off)) code +getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')]) + | fitsIn12bitImm (-off) = + do + (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrRegImm reg (ImmInteger (-off))) code + +-- Generic case +getAmode _platform _ expr = + do + (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrReg reg) code + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock +assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock +assignMem_IntCode rep addrE srcE = + do + (src_reg, _format, code) <- getSomeReg srcE + platform <- getPlatform + let w = formatToWidth rep + Amode addr addr_code <- getAmode platform w addrE + return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE))) + `consOL` ( code + `appOL` addr_code + `snocOL` STR rep (OpReg w src_reg) (OpAddr addr) + ) + +assignReg_IntCode _ reg src = + do + platform <- getPlatform + let dst = getRegisterReg platform reg + r <- getRegister src + return $ case r of + Any _ code -> + COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) + `consOL` code dst + Fixed format freg fcode -> + COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) + `consOL` ( fcode + `snocOL` MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg) + ) + +-- Let's treat Floating point stuff +-- as integer code for now. Opaque. +assignMem_FltCode = assignMem_IntCode + +assignReg_FltCode = assignReg_IntCode + +-- ----------------------------------------------------------------------------- +-- Jumps +-- AArch64 has 26bits for targets, whereas RiscV only has 20. +-- Thus we need to distinguish between far (outside of the) +-- current compilation unit. And regular branches. +-- RiscV has ±2MB of displacement, whereas AArch64 has ±128MB. +-- Thus for most branches we can get away with encoding it +-- directly in the instruction rather than always loading the +-- address into a register and then using that to jump. +-- Under the assumption that our linked build product is less than +-- ~2*128MB of TEXT, and there are no jump that span the whole +-- TEXT segment. +-- Something where riscv's compressed instruction might come in +-- handy. +genJump :: CmmExpr {-the branch target-} -> NatM InstrBlock +genJump expr = do + (target, _format, code) <- getSomeReg expr + return (code `appOL` unitOL (annExpr expr (J (TReg target)))) + +-- ----------------------------------------------------------------------------- +-- Unconditional branches +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + +-- ----------------------------------------------------------------------------- +-- Conditional branches +genCondJump :: + BlockId -> + CmmExpr -> + NatM InstrBlock +genCondJump bid expr = do + case expr of + -- Optimized == 0 case. + CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ code_x `snocOL` annExpr expr (BCOND EQ zero (OpReg w reg_x) (TBlock bid)) + + -- Optimized /= 0 case. + CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ code_x `snocOL` annExpr expr (BCOND NE zero (OpReg w reg_x) (TBlock bid)) + + -- Generic case. + CmmMachOp mop [x, y] -> do + let ubcond w cmp = do + -- compute both sides. + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + let x' = OpReg w reg_x + y' = OpReg w reg_y + return $ case w of + w + | w == W8 || w == W16 -> + code_x + `appOL` truncateReg (formatToWidth format_x) w reg_x + `appOL` code_y + `appOL` truncateReg (formatToWidth format_y) w reg_y + `appOL` code_y + `snocOL` annExpr expr (BCOND cmp x' y' (TBlock bid)) + _ -> + code_x + `appOL` code_y + `snocOL` annExpr expr (BCOND cmp x' y' (TBlock bid)) + + sbcond w cmp = do + -- compute both sides. + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + let x' = OpReg w reg_x + y' = OpReg w reg_y + return $ case w of + w + | w `elem` [W8, W16, W32] -> + code_x + `appOL` signExtend (formatToWidth format_x) W64 reg_x reg_x + `appOL` code_y + `appOL` signExtend (formatToWidth format_y) W64 reg_y reg_y + `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid))) + _ -> code_x `appOL` code_y `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid))) + + fbcond w cmp = do + -- ensure we get float regs + (reg_fx, _format_fx, code_fx) <- getFloatReg x + (reg_fy, _format_fy, code_fy) <- getFloatReg y + condOpReg <- OpReg W64 <$> getNewRegNat II64 + oneReg <- getNewRegNat II64 + return $ code_fx + `appOL` code_fy + `snocOL` annExpr expr (CSET condOpReg (OpReg w reg_fx) (OpReg w reg_fy) cmp) + `snocOL` MOV (OpReg W64 oneReg) (OpImm (ImmInt 1)) + `snocOL` BCOND EQ condOpReg (OpReg w oneReg) (TBlock bid) + + case mop of + MO_F_Eq w -> fbcond w EQ + MO_F_Ne w -> fbcond w NE + MO_F_Gt w -> fbcond w FGT + MO_F_Ge w -> fbcond w FGE + MO_F_Lt w -> fbcond w FLT + MO_F_Le w -> fbcond w FLE + MO_Eq w -> sbcond w EQ + MO_Ne w -> sbcond w NE + MO_S_Gt w -> sbcond w SGT + MO_S_Ge w -> sbcond w SGE + MO_S_Lt w -> sbcond w SLT + MO_S_Le w -> sbcond w SLE + MO_U_Gt w -> ubcond w UGT + MO_U_Ge w -> ubcond w UGE + MO_U_Lt w -> ubcond w ULT + MO_U_Le w -> ubcond w ULE + _ -> pprPanic "RV64.genCondJump:case mop: " (text $ show expr) + _ -> pprPanic "RV64.genCondJump: " (text $ show expr) + +-- | Generate conditional branching instructions +-- +-- This is basically an "if with else" statement. +genCondBranch :: + -- | the true branch target + BlockId -> + -- | the false branch target + BlockId -> + -- | the condition on which to branch + CmmExpr -> + -- | Instructions + NatM InstrBlock +genCondBranch true false expr = + appOL + <$> genCondJump true expr + <*> genBranch false + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +-- | Generate a call to a C function. +-- +-- - Integer values are passed in GP registers a0-a7. +-- - Floating point values are passed in FP registers fa0-fa7. +-- - If there are no free floating point registers, the FP values are passed in GP registers. +-- - If all GP registers are taken, the values are spilled as whole words (!) onto the stack. +-- - For integers/words, the return value is in a0. +-- - The return value is in fa0 if the return type is a floating point value. +genCCall :: + ForeignTarget -> -- function to call + [CmmFormal] -> -- where to put the result + [CmmActual] -> -- arguments (of mixed type) + NatM InstrBlock +-- TODO: Specialize where we can. +-- Generic impl +genCCall target@(ForeignTarget expr _cconv) dest_regs arg_regs = do + -- we want to pass arg_regs into allArgRegs + -- The target :: ForeignTarget call can either + -- be a foreign procedure with an address expr + -- and a calling convention. + (call_target_reg, call_target_code) <- + -- Compute the address of the call target into a register. This + -- addressing enables us to jump through the whole address space + -- without further ado. PC-relative addressing would involve + -- instructions to do similar, though. + do + (reg, _format, reg_code) <- getSomeReg expr + pure (reg, reg_code) + -- compute the code and register logic for all arg_regs. + -- this will give us the format information to match on. + arg_regs' <- mapM getSomeReg arg_regs + + -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes + -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in + -- STG; this then breaks packing of stack arguments, if we need to pack + -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type + -- in Cmm proper. Option two, which we choose here is to use extended Hint + -- information to contain the size information and use that when packing + -- arguments, spilled onto the stack. + let (_res_hints, arg_hints) = foreignTargetHints target + arg_regs'' = zipWith (\(r, f, c) h -> (r, f, h, c)) arg_regs' arg_hints + + (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL + + readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL + + let moveStackDown 0 = + toOL + [ PUSH_STACK_FRAME, + DELTA (-16) + ] + moveStackDown i | odd i = moveStackDown (i + 1) + moveStackDown i = + toOL + [ PUSH_STACK_FRAME, + SUB (OpReg W64 spMachReg) (OpReg W64 spMachReg) (OpImm (ImmInt (8 * i))), + DELTA (-8 * i - 16) + ] + moveStackUp 0 = + toOL + [ POP_STACK_FRAME, + DELTA 0 + ] + moveStackUp i | odd i = moveStackUp (i + 1) + moveStackUp i = + toOL + [ ADD (OpReg W64 spMachReg) (OpReg W64 spMachReg) (OpImm (ImmInt (8 * i))), + POP_STACK_FRAME, + DELTA 0 + ] + + let code = + call_target_code -- compute the label (possibly into a register) + `appOL` moveStackDown stackSpaceWords + `appOL` passArgumentsCode -- put the arguments into x0, ... + `snocOL` BL call_target_reg passRegs -- branch and link (C calls aren't tail calls, but return) + `appOL` readResultsCode -- parse the results into registers + `appOL` moveStackUp stackSpaceWords + return code + where + -- Implementiation of the RISCV ABI calling convention. + -- https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/948463cd5dbebea7c1869e20146b17a2cc8fda2f/riscv-cc.adoc#integer-calling-convention + passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock) + -- Base case: no more arguments to pass (left) + passArguments _ _ [] stackSpaceWords accumRegs accumCode = return (stackSpaceWords, accumRegs, accumCode) + -- Still have GP regs, and we want to pass an GP argument. + passArguments (gpReg : gpRegs) fpRegs ((r, format, hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do + -- RISCV64 Integer Calling Convention: "When passed in registers or on the + -- stack, integer scalars narrower than XLEN bits are widened according to + -- the sign of their type up to 32 bits, then sign-extended to XLEN bits." + let w = formatToWidth format + assignArg = + if hint == SignedHint + then + COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r) + `consOL` signExtend w W64 r gpReg + else + toOL + [ COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r), + MOV (OpReg w gpReg) (OpReg w r) + ] + accumCode' = + accumCode + `appOL` code_r + `appOL` assignArg + passArguments gpRegs fpRegs args stackSpaceWords (gpReg : accumRegs) accumCode' + + -- Still have FP regs, and we want to pass an FP argument. + passArguments gpRegs (fpReg : fpRegs) ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do + let w = formatToWidth format + mov = MOV (OpReg w fpReg) (OpReg w r) + accumCode' = + accumCode + `appOL` code_r + `snocOL` ann (text "Pass fp argument: " <> ppr r) mov + passArguments gpRegs fpRegs args stackSpaceWords (fpReg : accumRegs) accumCode' + + -- No mor regs left to pass. Must pass on stack. + passArguments [] [] ((r, format, hint, code_r) : args) stackSpaceWords accumRegs accumCode = do + let w = formatToWidth format + spOffet = 8 * stackSpaceWords + str = STR format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet))) + stackCode = + if hint == SignedHint + then + code_r + `appOL` signExtend w W64 r tmpReg + `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr tmpReg) str + else + code_r + `snocOL` ann (text "Pass unsigned argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str + passArguments [] [] args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode) + + -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then. + passArguments [] fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do + let w = formatToWidth format + spOffet = 8 * stackSpaceWords + str = STR format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet))) + stackCode = + code_r + `snocOL` ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str + passArguments [] fpRegs args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode) + + -- Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then. + passArguments (gpReg : gpRegs) [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do + let w = formatToWidth format + mov = MOV (OpReg w gpReg) (OpReg w r) + accumCode' = + accumCode + `appOL` code_r + `snocOL` ann (text "Pass fp argument in gpReg: " <> ppr r) mov + passArguments gpRegs [] args stackSpaceWords (gpReg : accumRegs) accumCode' + passArguments _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") + + readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg] -> InstrBlock -> NatM InstrBlock + readResults _ _ [] _ accumCode = return accumCode + readResults [] _ _ _ _ = do + platform <- getPlatform + pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target) + readResults _ [] _ _ _ = do + platform <- getPlatform + pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target) + readResults (gpReg : gpRegs) (fpReg : fpRegs) (dst : dsts) accumRegs accumCode = do + -- gp/fp reg -> dst + platform <- getPlatform + let rep = cmmRegType (CmmLocal dst) + format = cmmTypeFormat rep + w = cmmRegWidth (CmmLocal dst) + r_dst = getRegisterReg platform (CmmLocal dst) + if isFloatFormat format + then readResults (gpReg : gpRegs) fpRegs dsts (fpReg : accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg)) + else + readResults gpRegs (fpReg : fpRegs) dsts (gpReg : accumRegs) + $ accumCode + `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg) + `appOL` + -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations + truncateReg W64 w r_dst +genCCall (PrimTarget mop) dest_regs arg_regs = do + case mop of + MO_F32_Fabs + | [arg_reg] <- arg_regs, + [dest_reg] <- dest_regs -> + unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + MO_F64_Fabs + | [arg_reg] <- arg_regs, + [dest_reg] <- dest_regs -> + unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + -- 64 bit float ops + MO_F64_Pwr -> mkCCall "pow" + MO_F64_Sin -> mkCCall "sin" + MO_F64_Cos -> mkCCall "cos" + MO_F64_Tan -> mkCCall "tan" + MO_F64_Sinh -> mkCCall "sinh" + MO_F64_Cosh -> mkCCall "cosh" + MO_F64_Tanh -> mkCCall "tanh" + MO_F64_Asin -> mkCCall "asin" + MO_F64_Acos -> mkCCall "acos" + MO_F64_Atan -> mkCCall "atan" + MO_F64_Asinh -> mkCCall "asinh" + MO_F64_Acosh -> mkCCall "acosh" + MO_F64_Atanh -> mkCCall "atanh" + MO_F64_Log -> mkCCall "log" + MO_F64_Log1P -> mkCCall "log1p" + MO_F64_Exp -> mkCCall "exp" + MO_F64_ExpM1 -> mkCCall "expm1" + MO_F64_Fabs -> mkCCall "fabs" + MO_F64_Sqrt -> mkCCall "sqrt" + -- 32 bit float ops + MO_F32_Pwr -> mkCCall "powf" + MO_F32_Sin -> mkCCall "sinf" + MO_F32_Cos -> mkCCall "cosf" + MO_F32_Tan -> mkCCall "tanf" + MO_F32_Sinh -> mkCCall "sinhf" + MO_F32_Cosh -> mkCCall "coshf" + MO_F32_Tanh -> mkCCall "tanhf" + MO_F32_Asin -> mkCCall "asinf" + MO_F32_Acos -> mkCCall "acosf" + MO_F32_Atan -> mkCCall "atanf" + MO_F32_Asinh -> mkCCall "asinhf" + MO_F32_Acosh -> mkCCall "acoshf" + MO_F32_Atanh -> mkCCall "atanhf" + MO_F32_Log -> mkCCall "logf" + MO_F32_Log1P -> mkCCall "log1pf" + MO_F32_Exp -> mkCCall "expf" + MO_F32_ExpM1 -> mkCCall "expm1f" + MO_F32_Fabs -> mkCCall "fabsf" + MO_F32_Sqrt -> mkCCall "sqrtf" + -- 64-bit primops + MO_I64_ToI -> mkCCall "hs_int64ToInt" + MO_I64_FromI -> mkCCall "hs_intToInt64" + MO_W64_ToW -> mkCCall "hs_word64ToWord" + MO_W64_FromW -> mkCCall "hs_wordToWord64" + MO_x64_Neg -> mkCCall "hs_neg64" + MO_x64_Add -> mkCCall "hs_add64" + MO_x64_Sub -> mkCCall "hs_sub64" + MO_x64_Mul -> mkCCall "hs_mul64" + MO_I64_Quot -> mkCCall "hs_quotInt64" + MO_I64_Rem -> mkCCall "hs_remInt64" + MO_W64_Quot -> mkCCall "hs_quotWord64" + MO_W64_Rem -> mkCCall "hs_remWord64" + MO_x64_And -> mkCCall "hs_and64" + MO_x64_Or -> mkCCall "hs_or64" + MO_x64_Xor -> mkCCall "hs_xor64" + MO_x64_Not -> mkCCall "hs_not64" + MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64" + MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64" + MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64" + MO_x64_Eq -> mkCCall "hs_eq64" + MO_x64_Ne -> mkCCall "hs_ne64" + MO_I64_Ge -> mkCCall "hs_geInt64" + MO_I64_Gt -> mkCCall "hs_gtInt64" + MO_I64_Le -> mkCCall "hs_leInt64" + MO_I64_Lt -> mkCCall "hs_ltInt64" + MO_W64_Ge -> mkCCall "hs_geWord64" + MO_W64_Gt -> mkCCall "hs_gtWord64" + MO_W64_Le -> mkCCall "hs_leWord64" + MO_W64_Lt -> mkCCall "hs_ltWord64" + -- Conversion + MO_UF_Conv w -> mkCCall (word2FloatLabel w) + -- Optional MachOps + -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config + MO_S_Mul2 _w -> unsupported mop + MO_S_QuotRem _w -> unsupported mop + MO_U_QuotRem _w -> unsupported mop + MO_U_QuotRem2 _w -> unsupported mop + MO_Add2 _w -> unsupported mop + MO_AddWordC _w -> unsupported mop + MO_SubWordC _w -> unsupported mop + MO_AddIntC _w -> unsupported mop + MO_SubIntC _w -> unsupported mop + MO_U_Mul2 _w -> unsupported mop + MO_VS_Quot {} -> unsupported mop + MO_VS_Rem {} -> unsupported mop + MO_VU_Quot {} -> unsupported mop + MO_VU_Rem {} -> unsupported mop + MO_I64X2_Min -> unsupported mop + MO_I64X2_Max -> unsupported mop + MO_W64X2_Min -> unsupported mop + MO_W64X2_Max -> unsupported mop + -- Memory Ordering + -- The related C functions are: + -- #include + -- atomic_thread_fence(memory_order_acquire); + -- atomic_thread_fence(memory_order_release); + -- atomic_thread_fence(memory_order_seq_cst); + MO_AcquireFence -> pure (unitOL (FENCE FenceRead FenceReadWrite)) + MO_ReleaseFence -> pure (unitOL (FENCE FenceReadWrite FenceWrite)) + MO_SeqCstFence -> pure (unitOL (FENCE FenceReadWrite FenceReadWrite)) + MO_Touch -> pure nilOL -- Keep variables live (when using interior pointers) + -- Prefetch + MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint. + + -- Memory copy/set/move/cmp, with alignment for optimization + MO_Memcpy _align -> mkCCall "memcpy" + MO_Memset _align -> mkCCall "memset" + MO_Memmove _align -> mkCCall "memmove" + MO_Memcmp _align -> mkCCall "memcmp" + MO_SuspendThread -> mkCCall "suspendThread" + MO_ResumeThread -> mkCCall "resumeThread" + MO_PopCnt w -> mkCCall (popCntLabel w) + MO_Pdep w -> mkCCall (pdepLabel w) + MO_Pext w -> mkCCall (pextLabel w) + MO_Clz w -> mkCCall (clzLabel w) + MO_Ctz w -> mkCCall (ctzLabel w) + MO_BSwap w -> mkCCall (bSwapLabel w) + MO_BRev w -> mkCCall (bRevLabel w) + -- Atomic read-modify-write. + mo@(MO_AtomicRead w ord) + | [p_reg] <- arg_regs, + [dst_reg] <- dest_regs -> do + (p, _fmt_p, code_p) <- getSomeReg p_reg + platform <- getPlatform + -- Analog to the related MachOps (above) + -- The related C functions are: + -- #include + -- __atomic_load_n(&a, __ATOMIC_ACQUIRE); + -- __atomic_load_n(&a, __ATOMIC_SEQ_CST); + let instrs = case ord of + MemOrderRelaxed -> unitOL $ ann moDescr (LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)) + MemOrderAcquire -> + toOL + [ ann moDescr (LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)), + FENCE FenceRead FenceReadWrite + ] + MemOrderSeqCst -> + toOL + [ ann moDescr (FENCE FenceReadWrite FenceReadWrite), + LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p), + FENCE FenceRead FenceReadWrite + ] + MemOrderRelease -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo + dst = getRegisterReg platform (CmmLocal dst_reg) + moDescr = (text . show) mo + code = code_p `appOL` instrs + return code + | otherwise -> panic "mal-formed AtomicRead" + mo@(MO_AtomicWrite w ord) + | [p_reg, val_reg] <- arg_regs -> do + (p, _fmt_p, code_p) <- getSomeReg p_reg + (val, fmt_val, code_val) <- getSomeReg val_reg + -- Analog to the related MachOps (above) + -- The related C functions are: + -- #include + -- __atomic_store_n(&a, 23, __ATOMIC_SEQ_CST); + -- __atomic_store_n(&a, 23, __ATOMIC_RELEASE); + let instrs = case ord of + MemOrderRelaxed -> unitOL $ ann moDescr (STR fmt_val (OpReg w val) (OpAddr $ AddrReg p)) + MemOrderSeqCst -> + toOL + [ ann moDescr (FENCE FenceReadWrite FenceWrite), + STR fmt_val (OpReg w val) (OpAddr $ AddrReg p), + FENCE FenceReadWrite FenceReadWrite + ] + MemOrderRelease -> + toOL + [ ann moDescr (FENCE FenceReadWrite FenceWrite), + STR fmt_val (OpReg w val) (OpAddr $ AddrReg p) + ] + MemOrderAcquire -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo + moDescr = (text . show) mo + code = + code_p + `appOL` code_val + `appOL` instrs + pure code + | otherwise -> panic "mal-formed AtomicWrite" + MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop) + MO_Cmpxchg w -> mkCCall (cmpxchgLabel w) + -- -- Should be an AtomicRMW variant eventually. + -- -- Sequential consistent. + -- TODO: this should be implemented properly! + MO_Xchg w -> mkCCall (xchgLabel w) + where + unsupported :: (Show a) => a -> b + unsupported mop = + panic + ( "outOfLineCmmOp: " + ++ show mop + ++ " not supported here" + ) + mkCCall :: FastString -> NatM InstrBlock + mkCCall name = do + config <- getConfig + target <- + cmmMakeDynamicReference config CallReference + $ mkForeignLabel name ForeignLabelInThisPackage IsFunction + let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn + genCCall (ForeignTarget target cconv) dest_regs arg_regs + + unaryFloatOp w op arg_reg dest_reg = do + platform <- getPlatform + (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg + let dst = getRegisterReg platform (CmmLocal dest_reg) + let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx) + pure code + +{- Note [RISCV64 far jumps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +RISCV64 conditional jump instructions can only encode an offset of +/-4KiB +(12bits) which is usually enough but can be exceeded in edge cases. In these +cases we will replace: + + b.cond foo + +with the sequence: + + b.cond + b + : + la reg foo + b reg + : + +and + + b foo + +with the sequence: + + la reg foo + b reg + +Compared to AArch64 the target label is loaded to a register, because +unconditional jump instructions can only address +/-1MiB. The LA +pseudo-instruction will be replaced by up to two real instructions, ensuring +correct addressing. + +One could surely find more efficient replacements, taking PC-relative addressing +into account. This could be a future improvement. (As far branches are pretty +rare, one might question and measure the value of such improvement.) + +RISCV has many pseudo-instructions which emit more than one real instructions. +Thus, we count the real instructions after the Assembler has seen them. + +We make some simplifications in the name of performance which can result in +overestimating jump <-> label offsets: + +\* To avoid having to recalculate the label offsets once we replaced a jump we simply + assume all label jumps will be expanded to a three instruction far jump sequence. +\* For labels associated with a info table we assume the info table is 64byte large. + Most info tables are smaller than that but it means we don't have to distinguish + between multiple types of info tables. + +In terms of implementation we walk the instruction stream at least once calculating +label offsets, and if we determine during this that the functions body is big enough +to potentially contain out of range jumps we walk the instructions a second time, replacing +out of range jumps with the sequence of instructions described above. + +-} + +-- | A conditional jump to a far target +-- +-- By loading the far target into a register for the jump, we can address the +-- whole memory range. +genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock +genCondFarJump cond op1 op2 far_target = do + skip_lbl_id <- newBlockId + jmp_lbl_id <- newBlockId + + -- TODO: We can improve this by inverting the condition + -- but it's not quite trivial since we don't know if we + -- need to consider float orderings. + -- So we take the hit of the additional jump in the false + -- case for now. + return + $ toOL + [ ann (text "Conditional far jump to: " <> ppr far_target) + $ BCOND cond op1 op2 (TBlock jmp_lbl_id), + B (TBlock skip_lbl_id), + NEWBLOCK jmp_lbl_id, + LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))), + B (TReg tmpReg), + NEWBLOCK skip_lbl_id + ] + +-- | An unconditional jump to a far target +-- +-- By loading the far target into a register for the jump, we can address the +-- whole memory range. +genFarJump :: (MonadGetUnique m) => BlockId -> m InstrBlock +genFarJump far_target = + return + $ toOL + [ ann (text "Unconditional far jump to: " <> ppr far_target) + $ LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))), + B (TReg tmpReg) + ] + +-- See Note [RISCV64 far jumps] +data BlockInRange = InRange | NotInRange BlockId + +-- See Note [RISCV64 far jumps] +makeFarBranches :: + Platform -> + LabelMap RawCmmStatics -> + [NatBasicBlock Instr] -> + UniqDSM [NatBasicBlock Instr] +makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do + -- All offsets/positions are counted in multiples of 4 bytes (the size of RISCV64 instructions) + -- That is an offset of 1 represents a 4-byte/one instruction offset. + let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks + if func_size < max_jump_dist + then pure basic_blocks + else do + (_, blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks + pure $ concat blocks + where + -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks + + -- 2^11, 12 bit immediate with one bit is reserved for the sign + max_jump_dist = 2 ^ (11 :: Int) - 1 :: Int + -- Currently all inline info tables fit into 64 bytes. + max_info_size = 16 :: Int + long_bc_jump_size = 5 :: Int + long_b_jump_size = 2 :: Int + + -- Replace out of range conditional jumps with unconditional jumps. + replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr]) + replace_blk !m !pos (BasicBlock lbl instrs) = do + -- Account for a potential info table before the label. + let !block_pos = pos + infoTblSize_maybe lbl + (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs + let instrs'' = concat instrs' + -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary. + let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs'' + -- There should be no data in the instruction stream at this point + massert (null no_data) + + let final_blocks = BasicBlock lbl top : split_blocks + pure (pos', final_blocks) + + replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr]) + replace_jump !m !pos instr = do + case instr of + ANN ann instr -> do + replace_jump m pos instr >>= \case + (_, []) -> error "RV64:replace_jump" + (idx, instr' : instrs') -> + pure (idx, ANN ann instr' : instrs') + BCOND cond op1 op2 t -> + case target_in_range m t pos of + InRange -> pure (pos + instr_size instr, [instr]) + NotInRange far_target -> do + jmp_code <- genCondFarJump cond op1 op2 far_target + pure (pos + instr_size instr, fromOL jmp_code) + B t -> + case target_in_range m t pos of + InRange -> pure (pos + instr_size instr, [instr]) + NotInRange far_target -> do + jmp_code <- genFarJump far_target + pure (pos + instr_size instr, fromOL jmp_code) + _ -> pure (pos + instr_size instr, [instr]) + + target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange + target_in_range m target src = + case target of + (TReg {}) -> InRange + (TBlock bid) -> block_in_range m src bid + + block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange + block_in_range m src_pos dest_lbl = + case mapLookup dest_lbl m of + Nothing -> + pprTrace "not in range" (ppr dest_lbl) + $ NotInRange dest_lbl + Just dest_pos -> + if abs (dest_pos - src_pos) < max_jump_dist + then InRange + else NotInRange dest_lbl + + calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int) + calc_lbl_positions (pos, m) (BasicBlock lbl instrs) = + let !pos' = pos + infoTblSize_maybe lbl + in foldl' instr_pos (pos', mapInsert lbl pos' m) instrs + + instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int) + instr_pos (pos, m) instr = (pos + instr_size instr, m) + + infoTblSize_maybe bid = + case mapLookup bid statics of + Nothing -> 0 :: Int + Just _info_static -> max_info_size + + instr_size :: Instr -> Int + instr_size i = case i of + COMMENT {} -> 0 + MULTILINE_COMMENT {} -> 0 + ANN _ instr -> instr_size instr + LOCATION {} -> 0 + DELTA {} -> 0 + -- At this point there should be no NEWBLOCK in the instruction stream (pos, mapInsert bid pos m) + NEWBLOCK {} -> panic "mkFarBranched - Unexpected" + LDATA {} -> panic "mkFarBranched - Unexpected" + PUSH_STACK_FRAME -> 4 + POP_STACK_FRAME -> 4 + ADD {} -> 1 + MUL {} -> 1 + MULH {} -> 1 + NEG {} -> 1 + DIV {} -> 1 + REM {} -> 1 + REMU {} -> 1 + SUB {} -> 1 + DIVU {} -> 1 + AND {} -> 1 + OR {} -> 1 + SRA {} -> 1 + XOR {} -> 1 + SLL {} -> 1 + SRL {} -> 1 + MOV {} -> 2 + ORI {} -> 1 + XORI {} -> 1 + CSET {} -> 2 + STR {} -> 1 + LDR {} -> 3 + LDRU {} -> 1 + FENCE {} -> 1 + FCVT {} -> 1 + FABS {} -> 1 + FMIN {} -> 1 + FMAX {} -> 1 + FMA {} -> 1 + -- estimate the subsituted size for jumps to lables + -- jumps to registers have size 1 + BCOND {} -> long_bc_jump_size + B (TBlock _) -> long_b_jump_size + B (TReg _) -> 1 + J op -> instr_size (B op) + BL _ _ -> 1 + J_TBL {} -> 1 diff --git a/GHC/CmmToAsm/RV64/Cond.hs b/GHC/CmmToAsm/RV64/Cond.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/Cond.hs @@ -0,0 +1,42 @@ +module GHC.CmmToAsm.RV64.Cond + ( Cond (..), + ) +where + +import GHC.Prelude hiding (EQ) + +-- | Condition codes. +-- +-- Used in conditional branches and bit setters. According to the available +-- instruction set, some conditions are encoded as their negated opposites. I.e. +-- these are logical things that don't necessarily map 1:1 to hardware/ISA. +data Cond + = -- | int and float + EQ + | -- | int and float + NE + | -- | signed less than + SLT + | -- | signed less than or equal + SLE + | -- | signed greater than or equal + SGE + | -- | signed greater than + SGT + | -- | unsigned less than + ULT + | -- | unsigned less than or equal + ULE + | -- | unsigned greater than or equal + UGE + | -- | unsigned greater than + UGT + | -- | floating point instruction @flt@ + FLT + | -- | floating point instruction @fle@ + FLE + | -- | floating point instruction @fge@ + FGE + | -- | floating point instruction @fgt@ + FGT + deriving (Eq, Show) diff --git a/GHC/CmmToAsm/RV64/Instr.hs b/GHC/CmmToAsm/RV64/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/Instr.hs @@ -0,0 +1,868 @@ +-- All instructions will be rendered eventually. Thus, there's no benefit in +-- being lazy in data types. +{-# LANGUAGE StrictData #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.CmmToAsm.RV64.Instr where + +import Data.Maybe +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Label +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Instr (RegUsage (..)) +import GHC.CmmToAsm.RV64.Cond +import GHC.CmmToAsm.RV64.Regs +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils +import GHC.Data.FastString (LexicalFastString) +import GHC.Platform +import GHC.Platform.Reg +import GHC.Platform.Regs +import GHC.Platform.Reg.Class.Separate +import GHC.Prelude +import GHC.Stack +import GHC.Types.Unique.DSM +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- | Stack frame header size in bytes. +-- +-- The stack frame header is made of the values that are always saved +-- (regardless of the context.) It consists of the saved return address and a +-- pointer to the previous frame. Thus, its size is two stack frame slots which +-- equals two addresses/words (2 * 8 byte). +stackFrameHeaderSize :: Int +stackFrameHeaderSize = 2 * spillSlotSize + +-- | All registers are 8 byte wide. +spillSlotSize :: Int +spillSlotSize = 8 + +-- | The number of bytes that the stack pointer should be aligned to. +stackAlign :: Int +stackAlign = 16 + +-- | The number of spill slots available without allocating more. +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config = + ( (ncgSpillPreallocSize config - stackFrameHeaderSize) + `div` spillSlotSize + ) + - 1 + +-- | Convert a spill slot number to a *byte* offset. +spillSlotToOffset :: Int -> Int +spillSlotToOffset slot = + stackFrameHeaderSize + spillSlotSize * slot + +instance Outputable RegUsage where + ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')' + +-- | Get the registers that are being used by this instruction. +-- regUsage doesn't need to do any trickery for jumps and such. +-- Just state precisely the regs read and written by that insn. +-- The consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. +-- +-- RegUsage = RU [] [] +regUsageOfInstr :: Platform -> Instr -> RegUsage +regUsageOfInstr platform instr = case instr of + ANN _ i -> regUsageOfInstr platform i + COMMENT {} -> usage ([], []) + MULTILINE_COMMENT {} -> usage ([], []) + PUSH_STACK_FRAME -> usage ([], []) + POP_STACK_FRAME -> usage ([], []) + LOCATION {} -> usage ([], []) + DELTA {} -> usage ([], []) + ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + NEG dst src -> usage (regOp src, regOp dst) + MULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + DIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + REM dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + REMU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + DIVU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + OR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SRA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + XOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SLL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SRL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MOV dst src -> usage (regOp src, regOp dst) + -- ORI's third operand is always an immediate + ORI dst src1 _ -> usage (regOp src1, regOp dst) + XORI dst src1 _ -> usage (regOp src1, regOp dst) + J_TBL _ _ t -> usage ([t], []) + J t -> usage (regTarget t, []) + B t -> usage (regTarget t, []) + BCOND _ l r t -> usage (regTarget t ++ regOp l ++ regOp r, []) + BL t ps -> usage (t : ps, callerSavedRegisters) + CSET dst l r _ -> usage (regOp l ++ regOp r, regOp dst) + STR _ src dst -> usage (regOp src ++ regOp dst, []) + LDR _ dst src -> usage (regOp src, regOp dst) + LDRU _ dst src -> usage (regOp src, regOp dst) + FENCE _ _ -> usage ([], []) + FCVT _variant dst src -> usage (regOp src, regOp dst) + FABS dst src -> usage (regOp src, regOp dst) + FMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FMA _ dst src1 src2 src3 -> + usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + _ -> panic $ "regUsageOfInstr: " ++ instrCon instr + where + -- filtering the usage is necessary, otherwise the register + -- allocator will try to allocate pre-defined fixed stg + -- registers as well, as they show up. + usage :: ([Reg], [Reg]) -> RegUsage + usage (srcRegs, dstRegs) = + RU + (map mkFmt $ filter (interesting platform) srcRegs) + (map mkFmt $ filter (interesting platform) dstRegs) + + -- SIMD NCG TODO: the format here is used for register spilling/unspilling. + -- As the RISCV64 NCG does not currently support SIMD registers, + -- this simple logic is OK. + mkFmt r = RegWithFormat r fmt + where + fmt = case cls of + RcInteger -> II64 + RcFloat -> FF64 + RcVector -> sorry "The RISCV64 NCG does not (yet) support vectors; please use -fllvm." + cls = case r of + RegVirtual vr -> classOfVirtualReg (platformArch platform) vr + RegReal rr -> classOfRealReg rr + + regAddr :: AddrMode -> [Reg] + regAddr (AddrRegImm r1 _imm) = [r1] + regAddr (AddrReg r1) = [r1] + + regOp :: Operand -> [Reg] + regOp (OpReg _w r1) = [r1] + regOp (OpAddr a) = regAddr a + regOp (OpImm _imm) = [] + + regTarget :: Target -> [Reg] + regTarget (TBlock _bid) = [] + regTarget (TReg r1) = [r1] + + -- Is this register interesting for the register allocator? + interesting :: Platform -> Reg -> Bool + interesting _ (RegVirtual _) = True + interesting platform (RegReal (RealRegSingle i)) = freeReg platform i + +-- | Caller-saved registers (according to calling convention) +-- +-- These registers may be clobbered after a jump. +callerSavedRegisters :: [Reg] +callerSavedRegisters = + [regSingle raRegNo] + ++ map regSingle [t0RegNo .. t2RegNo] + ++ map regSingle [a0RegNo .. a7RegNo] + ++ map regSingle [t3RegNo .. t6RegNo] + ++ map regSingle [ft0RegNo .. ft7RegNo] + ++ map regSingle [fa0RegNo .. fa7RegNo] + +-- | Apply a given mapping to all the register references in this instruction. +patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +patchRegsOfInstr instr env = case instr of + ANN d i -> ANN d (patchRegsOfInstr i env) + COMMENT {} -> instr + MULTILINE_COMMENT {} -> instr + PUSH_STACK_FRAME -> instr + POP_STACK_FRAME -> instr + LOCATION {} -> instr + DELTA {} -> instr + ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3) + MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3) + NEG o1 o2 -> NEG (patchOp o1) (patchOp o2) + MULH o1 o2 o3 -> MULH (patchOp o1) (patchOp o2) (patchOp o3) + DIV o1 o2 o3 -> DIV (patchOp o1) (patchOp o2) (patchOp o3) + REM o1 o2 o3 -> REM (patchOp o1) (patchOp o2) (patchOp o3) + REMU o1 o2 o3 -> REMU (patchOp o1) (patchOp o2) (patchOp o3) + SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3) + DIVU o1 o2 o3 -> DIVU (patchOp o1) (patchOp o2) (patchOp o3) + AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3) + OR o1 o2 o3 -> OR (patchOp o1) (patchOp o2) (patchOp o3) + SRA o1 o2 o3 -> SRA (patchOp o1) (patchOp o2) (patchOp o3) + XOR o1 o2 o3 -> XOR (patchOp o1) (patchOp o2) (patchOp o3) + SLL o1 o2 o3 -> SLL (patchOp o1) (patchOp o2) (patchOp o3) + SRL o1 o2 o3 -> SRL (patchOp o1) (patchOp o2) (patchOp o3) + MOV o1 o2 -> MOV (patchOp o1) (patchOp o2) + -- o3 cannot be a register for ORI (always an immediate) + ORI o1 o2 o3 -> ORI (patchOp o1) (patchOp o2) (patchOp o3) + XORI o1 o2 o3 -> XORI (patchOp o1) (patchOp o2) (patchOp o3) + J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t) + J t -> J (patchTarget t) + B t -> B (patchTarget t) + BL t ps -> BL (patchReg t) ps + BCOND c o1 o2 t -> BCOND c (patchOp o1) (patchOp o2) (patchTarget t) + CSET o l r c -> CSET (patchOp o) (patchOp l) (patchOp r) c + STR f o1 o2 -> STR f (patchOp o1) (patchOp o2) + LDR f o1 o2 -> LDR f (patchOp o1) (patchOp o2) + LDRU f o1 o2 -> LDRU f (patchOp o1) (patchOp o2) + FENCE o1 o2 -> FENCE o1 o2 + FCVT variant o1 o2 -> FCVT variant (patchOp o1) (patchOp o2) + FABS o1 o2 -> FABS (patchOp o1) (patchOp o2) + FMIN o1 o2 o3 -> FMIN (patchOp o1) (patchOp o2) (patchOp o3) + FMAX o1 o2 o3 -> FMAX (patchOp o1) (patchOp o2) (patchOp o3) + FMA s o1 o2 o3 o4 -> + FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr + where + patchOp :: Operand -> Operand + patchOp (OpReg w r) = OpReg w (env r) + patchOp (OpAddr a) = OpAddr (patchAddr a) + patchOp opImm = opImm + + patchTarget :: Target -> Target + patchTarget (TReg r) = TReg (env r) + patchTarget tBlock = tBlock + + patchAddr :: AddrMode -> AddrMode + patchAddr (AddrRegImm r1 imm) = AddrRegImm (env r1) imm + patchAddr (AddrReg r) = AddrReg (env r) + + patchReg :: Reg -> Reg + patchReg = env + +-- | Checks whether this instruction is a jump/branch instruction. +-- +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +isJumpishInstr :: Instr -> Bool +isJumpishInstr instr = case instr of + ANN _ i -> isJumpishInstr i + J_TBL {} -> True + J {} -> True + B {} -> True + BL {} -> True + BCOND {} -> True + _ -> False + +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo insn bid = + case insn of + J (TBlock target) -> bid == target + B (TBlock target) -> bid == target + BCOND _ _ _ (TBlock target) -> bid == target + J_TBL targets _ _ -> all isTargetBid targets + _ -> False + where + isTargetBid target = case target of + Nothing -> True + Just target -> target == bid + +-- | Get the `BlockId`s of the jump destinations (if any) +jumpDestsOfInstr :: Instr -> [BlockId] +jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i +jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids +jumpDestsOfInstr (J t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (B t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]] +jumpDestsOfInstr _ = [] + +-- | Change the destination of this (potential) jump instruction. +-- +-- Used in the linear allocator when adding fixup blocks for join +-- points. +patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr +patchJumpInstr instr patchF = + case instr of + ANN d i -> ANN d (patchJumpInstr i patchF) + J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r + J (TBlock bid) -> J (TBlock (patchF bid)) + B (TBlock bid) -> B (TBlock (patchF bid)) + BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid)) + _ -> panic $ "patchJumpInstr: " ++ instrCon instr + +-- ----------------------------------------------------------------------------- +-- Note [RISCV64 Spills and Reloads] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We reserve @RESERVED_C_STACK_BYTES@ on the C stack for spilling and reloading +-- registers. The load and store instructions of RISCV64 address with a signed +-- 12-bit immediate + a register; machine stackpointer (sp/x2) in this case. +-- +-- The @RESERVED_C_STACK_BYTES@ is 16k, so we can't always address into it in a +-- single load/store instruction. There are offsets to sp (not to be confused +-- with STG's SP!) which need a register to be calculated. +-- +-- Using sp to compute the offset would violate assumptions about the stack pointer +-- pointing to the top of the stack during signal handling. As we can't force +-- every signal to use its own stack, we have to ensure that the stack pointer +-- always points to the top of the stack, and we can't use it for computation. +-- +-- So, we reserve one register (TMP) for this purpose (and other, unrelated +-- intermediate operations.) See Note [The made-up RISCV64 TMP (IP) register] + +-- | Generate instructions to spill a register into a spill slot. +mkSpillInstr :: + (HasCallStack) => + NCGConfig -> + -- | register to spill + RegWithFormat -> + -- | current stack delta + Int -> + -- | spill slot to use + Int -> + [Instr] +mkSpillInstr _config (RegWithFormat reg _fmt) delta slot = + case off - delta of + imm | fitsIn12bitImm imm -> [mkStrSpImm imm] + imm -> + [ movImmToTmp imm, + addSpToTmp, + mkStrTmp + ] + where + fmt = case reg of + RegReal (RealRegSingle n) | n < d0RegNo -> II64 + _ -> FF64 + mkStrSpImm imm = + ANN (text "Spill@" <> int (off - delta)) + $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm))) + movImmToTmp imm = + ANN (text "Spill: TMP <- " <> int imm) + $ MOV tmp (OpImm (ImmInt imm)) + addSpToTmp = + ANN (text "Spill: TMP <- SP + TMP ") + $ ADD tmp tmp sp + mkStrTmp = + ANN (text "Spill@" <> int (off - delta)) + $ STR fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg)) + + off = spillSlotToOffset slot + +-- | Generate instructions to load a register from a spill slot. +mkLoadInstr :: + NCGConfig -> + -- | register to load + RegWithFormat -> + -- | current stack delta + Int -> + -- | spill slot to use + Int -> + [Instr] +mkLoadInstr _config (RegWithFormat reg _fmt) delta slot = + case off - delta of + imm | fitsIn12bitImm imm -> [mkLdrSpImm imm] + imm -> + [ movImmToTmp imm, + addSpToTmp, + mkLdrTmp + ] + where + fmt = case reg of + RegReal (RealRegSingle n) | n < d0RegNo -> II64 + _ -> FF64 + mkLdrSpImm imm = + ANN (text "Reload@" <> int (off - delta)) + $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm))) + movImmToTmp imm = + ANN (text "Reload: TMP <- " <> int imm) + $ MOV tmp (OpImm (ImmInt imm)) + addSpToTmp = + ANN (text "Reload: TMP <- SP + TMP ") + $ ADD tmp tmp sp + mkLdrTmp = + ANN (text "Reload@" <> int (off - delta)) + $ LDR fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg)) + + off = spillSlotToOffset slot + +-- | See if this instruction is telling us the current C stack delta +takeDeltaInstr :: Instr -> Maybe Int +takeDeltaInstr (ANN _ i) = takeDeltaInstr i +takeDeltaInstr (DELTA i) = Just i +takeDeltaInstr _ = Nothing + +-- | Not real instructions. Just meta data +isMetaInstr :: Instr -> Bool +isMetaInstr instr = + case instr of + ANN _ i -> isMetaInstr i + COMMENT {} -> True + MULTILINE_COMMENT {} -> True + LOCATION {} -> True + LDATA {} -> True + NEWBLOCK {} -> True + DELTA {} -> True + PUSH_STACK_FRAME -> True + POP_STACK_FRAME -> True + _ -> False + +-- | Copy the value in a register to another one. +-- +-- Must work for all register classes. +mkRegRegMoveInstr :: Reg -> Reg -> Instr +mkRegRegMoveInstr src dst = ANN desc instr + where + desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst + instr = MOV (operandFromReg dst) (operandFromReg src) + +-- | Take the source and destination from this (potential) reg -> reg move instruction +-- +-- We have to be a bit careful here: A `MOV` can also mean an implicit +-- conversion. This case is filtered out. +takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg) +takeRegRegMoveInstr (MOV (OpReg width dst) (OpReg width' src)) + | width == width' && (isFloatReg dst == isFloatReg src) = pure (src, dst) +takeRegRegMoveInstr _ = Nothing + +-- | Make an unconditional jump instruction. +mkJumpInstr :: BlockId -> [Instr] +mkJumpInstr = pure . B . TBlock + +-- | Decrement @sp@ to allocate stack space. +-- +-- The stack grows downwards, so we decrement the stack pointer by @n@ (bytes). +-- This is dual to `mkStackDeallocInstr`. @sp@ is the RISCV stack pointer, not +-- to be confused with the STG stack pointer. +mkStackAllocInstr :: Platform -> Int -> [Instr] +mkStackAllocInstr _platform = moveSp . negate + +-- | Increment SP to deallocate stack space. +-- +-- The stack grows downwards, so we increment the stack pointer by @n@ (bytes). +-- This is dual to `mkStackAllocInstr`. @sp@ is the RISCV stack pointer, not to +-- be confused with the STG stack pointer. +mkStackDeallocInstr :: Platform -> Int -> [Instr] +mkStackDeallocInstr _platform = moveSp + +moveSp :: Int -> [Instr] +moveSp n + | n == 0 = [] + | n /= 0 && fitsIn12bitImm n = pure . ANN desc $ ADD sp sp (OpImm (ImmInt n)) + | otherwise = + -- This ends up in three effective instructions. We could get away with + -- two for intMax12bit < n < 3 * intMax12bit by recursing once. However, + -- this way is likely less surprising. + [ ANN desc (MOV tmp (OpImm (ImmInt n))), + ADD sp sp tmp + ] + where + desc = text "Move SP:" <+> int n + +-- +-- See Note [extra spill slots] in X86/Instr.hs +-- +allocMoreStack :: + Platform -> + Int -> + NatCmmDecl statics GHC.CmmToAsm.RV64.Instr.Instr -> + UniqDSM (NatCmmDecl statics GHC.CmmToAsm.RV64.Instr.Instr, [(BlockId, BlockId)]) +allocMoreStack _ _ top@(CmmData _ _) = return (top, []) +allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do + let entries = entryBlocks proc + + retargetList <- mapM (\e -> (e,) <$> newBlockId) entries + + let delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up + where + x = slots * spillSlotSize -- sp delta + alloc = mkStackAllocInstr platform delta + dealloc = mkStackDeallocInstr platform delta + + new_blockmap :: LabelMap BlockId + new_blockmap = mapFromList retargetList + + insert_stack_insn (BasicBlock id insns) + | Just new_blockid <- mapLookup id new_blockmap = + [ BasicBlock id $ alloc ++ [B (TBlock new_blockid)], + BasicBlock new_blockid block' + ] + | otherwise = + [BasicBlock id block'] + where + block' = foldr insert_dealloc [] insns + + insert_dealloc insn r = case insn of + J {} -> dealloc ++ (insn : r) + ANN _ e -> insert_dealloc e r + _other + | jumpDestsOfInstr insn /= [] -> + patchJumpInstr insn retarget : r + _other -> insn : r + where + retarget b = fromMaybe b (mapLookup b new_blockmap) + + new_code = concatMap insert_stack_insn code + return (CmmProc info lbl live (ListGraph new_code), retargetList) + +data Instr + = -- | Comment pseudo-op + COMMENT SDoc + | -- | Multi-line comment pseudo-op + MULTILINE_COMMENT SDoc + | -- | Annotated instruction. Should print # + ANN SDoc Instr + | -- | Location pseudo-op @.loc@ (file, line, col, name) + LOCATION Int Int Int LexicalFastString + | -- | Static data spat out during code generation. + LDATA Section RawCmmStatics + | -- | Start a new basic block. + -- + -- Useful during codegen, removed later. Preceding instruction should be a + -- jump, as per the invariants for a BasicBlock (see Cmm). + NEWBLOCK BlockId + | -- | Specify current stack offset for benefit of subsequent passes + DELTA Int + | -- | Push a minimal stack frame consisting of the return address (RA) and the frame pointer (FP). + PUSH_STACK_FRAME + | -- | Pop the minimal stack frame of prior `PUSH_STACK_FRAME`. + POP_STACK_FRAME + | -- | Arithmetic addition (both integer and floating point) + -- + -- @rd = rs1 + rs2@ + ADD Operand Operand Operand + | -- | Arithmetic subtraction (both integer and floating point) + -- + -- @rd = rs1 - rs2@ + SUB Operand Operand Operand + | -- | Logical AND (integer only) + -- + -- @rd = rs1 & rs2@ + AND Operand Operand Operand + | -- | Logical OR (integer only) + -- + -- @rd = rs1 | rs2@ + OR Operand Operand Operand + | -- | Logical left shift (zero extened, integer only) + -- + -- @rd = rs1 << rs2@ + SLL Operand Operand Operand + | -- | Logical right shift (zero extened, integer only) + -- + -- @rd = rs1 >> rs2@ + SRL Operand Operand Operand + | -- | Arithmetic right shift (sign-extened, integer only) + -- + -- @rd = rs1 >> rs2@ + SRA Operand Operand Operand + | -- | Store to memory (both, integer and floating point) + STR Format Operand Operand + | -- | Load from memory (sign-extended, integer and floating point) + LDR Format Operand Operand + | -- | Load from memory (unsigned, integer and floating point) + LDRU Format Operand Operand + | -- | Arithmetic multiplication (both, integer and floating point) + -- + -- @rd = rn × rm@ + MUL Operand Operand Operand + | -- | Negation (both, integer and floating point) + -- + -- @rd = -op2@ + NEG Operand Operand + | -- | Division (both, integer and floating point) + -- + -- @rd = rn ÷ rm@ + DIV Operand Operand Operand + | -- | Remainder (integer only, signed) + -- + -- @rd = rn % rm@ + REM Operand Operand Operand -- + | -- | Remainder (integer only, unsigned) + -- + -- @rd = |rn % rm|@ + REMU Operand Operand Operand + | -- | High part of a multiplication that doesn't fit into 64bits (integer only) + -- + -- E.g. for a multiplication with 64bits width: @rd = (rs1 * rs2) >> 64@. + MULH Operand Operand Operand + | -- | Unsigned division (integer only) + -- + -- @rd = |rn ÷ rm|@ + DIVU Operand Operand Operand + | -- | XOR (integer only) + -- + -- @rd = rn ⊕ op2@ + XOR Operand Operand Operand + | -- | ORI with immediate (integer only) + -- + -- @rd = rn | op2@ + ORI Operand Operand Operand + | -- | OR with immediate (integer only) + -- + -- @rd = rn ⊕ op2@ + XORI Operand Operand Operand + | -- | Move to register (integer and floating point) + -- + -- @rd = rn@ or @rd = #imm@ + MOV Operand Operand + | -- | Pseudo-op for conditional setting of a register. + -- + -- @if(o2 cond o3) op <- 1 else op <- 0@ + CSET Operand Operand Operand Cond + -- | Like B, but only used for non-local jumps. Used to distinguish genJumps from others. + | J Target + | -- | A jump instruction with data for switch/jump tables + J_TBL [Maybe BlockId] (Maybe CLabel) Reg + | -- | Unconditional jump (no linking) + B Target + | -- | Unconditional jump, links return address (sets @ra@/@x1@) + BL Reg [Reg] + | -- | branch with condition (integer only) + BCOND Cond Operand Operand Target + | -- | Fence instruction + -- + -- Memory barrier. + FENCE FenceType FenceType + | -- | Floating point conversion + FCVT FcvtVariant Operand Operand + | -- | Floating point ABSolute value + FABS Operand Operand + + | -- | Min + -- dest = min(r1) + FMIN Operand Operand Operand + | -- | Max + FMAX Operand Operand Operand + + | -- | Floating-point fused multiply-add instructions + -- + -- - fmadd : d = r1 * r2 + r3 + -- - fnmsub: d = r1 * r2 - r3 + -- - fmsub : d = - r1 * r2 + r3 + -- - fnmadd: d = - r1 * r2 - r3 + FMA FMASign Operand Operand Operand Operand + +-- | Operand of a FENCE instruction (@r@, @w@ or @rw@) +data FenceType = FenceRead | FenceWrite | FenceReadWrite + +-- | Variant of a floating point conversion instruction +data FcvtVariant = FloatToFloat | IntToFloat | FloatToInt + +instrCon :: Instr -> String +instrCon i = + case i of + COMMENT {} -> "COMMENT" + MULTILINE_COMMENT {} -> "COMMENT" + ANN {} -> "ANN" + LOCATION {} -> "LOCATION" + LDATA {} -> "LDATA" + NEWBLOCK {} -> "NEWBLOCK" + DELTA {} -> "DELTA" + PUSH_STACK_FRAME {} -> "PUSH_STACK_FRAME" + POP_STACK_FRAME {} -> "POP_STACK_FRAME" + ADD {} -> "ADD" + OR {} -> "OR" + MUL {} -> "MUL" + NEG {} -> "NEG" + DIV {} -> "DIV" + REM {} -> "REM" + REMU {} -> "REMU" + MULH {} -> "MULH" + SUB {} -> "SUB" + DIVU {} -> "DIVU" + AND {} -> "AND" + SRA {} -> "SRA" + XOR {} -> "XOR" + SLL {} -> "SLL" + SRL {} -> "SRL" + MOV {} -> "MOV" + ORI {} -> "ORI" + XORI {} -> "ORI" + STR {} -> "STR" + LDR {} -> "LDR" + LDRU {} -> "LDRU" + CSET {} -> "CSET" + J_TBL {} -> "J_TBL" + J {} -> "J" + B {} -> "B" + BL {} -> "BL" + BCOND {} -> "BCOND" + FENCE {} -> "FENCE" + FCVT {} -> "FCVT" + FABS {} -> "FABS" + FMIN {} -> "FMIN" + FMAX {} -> "FMAX" + FMA variant _ _ _ _ -> + case variant of + FMAdd -> "FMADD" + FMSub -> "FMSUB" + FNMAdd -> "FNMADD" + FNMSub -> "FNMSUB" + +data Target + = TBlock BlockId + | TReg Reg + +data Operand + = -- | register + OpReg Width Reg + | -- | immediate value + OpImm Imm + | -- | memory reference + OpAddr AddrMode + deriving (Eq, Show) + +operandFromReg :: Reg -> Operand +operandFromReg = OpReg W64 + +operandFromRegNo :: RegNo -> Operand +operandFromRegNo = operandFromReg . regSingle + +zero, ra, sp, gp, tp, fp, tmp :: Operand +zero = operandFromReg zeroReg +ra = operandFromReg raReg +sp = operandFromReg spMachReg +gp = operandFromRegNo 3 +tp = operandFromRegNo 4 +fp = operandFromRegNo 8 +tmp = operandFromReg tmpReg + +x0, x1, x2, x3, x4, x5, x6, x7 :: Operand +x8, x9, x10, x11, x12, x13, x14, x15 :: Operand +x16, x17, x18, x19, x20, x21, x22, x23 :: Operand +x24, x25, x26, x27, x28, x29, x30, x31 :: Operand +x0 = operandFromRegNo x0RegNo +x1 = operandFromRegNo 1 +x2 = operandFromRegNo 2 +x3 = operandFromRegNo 3 +x4 = operandFromRegNo 4 +x5 = operandFromRegNo x5RegNo +x6 = operandFromRegNo 6 +x7 = operandFromRegNo x7RegNo + +x8 = operandFromRegNo 8 + +x9 = operandFromRegNo 9 + +x10 = operandFromRegNo x10RegNo + +x11 = operandFromRegNo 11 + +x12 = operandFromRegNo 12 + +x13 = operandFromRegNo 13 + +x14 = operandFromRegNo 14 + +x15 = operandFromRegNo 15 + +x16 = operandFromRegNo 16 + +x17 = operandFromRegNo x17RegNo + +x18 = operandFromRegNo 18 + +x19 = operandFromRegNo 19 + +x20 = operandFromRegNo 20 + +x21 = operandFromRegNo 21 + +x22 = operandFromRegNo 22 + +x23 = operandFromRegNo 23 + +x24 = operandFromRegNo 24 + +x25 = operandFromRegNo 25 + +x26 = operandFromRegNo 26 + +x27 = operandFromRegNo 27 + +x28 = operandFromRegNo x28RegNo + +x29 = operandFromRegNo 29 + +x30 = operandFromRegNo 30 + +x31 = operandFromRegNo x31RegNo + +d0, d1, d2, d3, d4, d5, d6, d7 :: Operand +d8, d9, d10, d11, d12, d13, d14, d15 :: Operand +d16, d17, d18, d19, d20, d21, d22, d23 :: Operand +d24, d25, d26, d27, d28, d29, d30, d31 :: Operand +d0 = operandFromRegNo d0RegNo +d1 = operandFromRegNo 33 +d2 = operandFromRegNo 34 +d3 = operandFromRegNo 35 +d4 = operandFromRegNo 36 +d5 = operandFromRegNo 37 +d6 = operandFromRegNo 38 +d7 = operandFromRegNo d7RegNo + +d8 = operandFromRegNo 40 + +d9 = operandFromRegNo 41 + +d10 = operandFromRegNo d10RegNo + +d11 = operandFromRegNo 43 + +d12 = operandFromRegNo 44 + +d13 = operandFromRegNo 45 + +d14 = operandFromRegNo 46 + +d15 = operandFromRegNo 47 + +d16 = operandFromRegNo 48 + +d17 = operandFromRegNo d17RegNo + +d18 = operandFromRegNo 50 + +d19 = operandFromRegNo 51 + +d20 = operandFromRegNo 52 + +d21 = operandFromRegNo 53 + +d22 = operandFromRegNo 54 + +d23 = operandFromRegNo 55 + +d24 = operandFromRegNo 56 + +d25 = operandFromRegNo 57 + +d26 = operandFromRegNo 58 + +d27 = operandFromRegNo 59 + +d28 = operandFromRegNo 60 + +d29 = operandFromRegNo 61 + +d30 = operandFromRegNo 62 + +d31 = operandFromRegNo d31RegNo + +fitsIn12bitImm :: (Num a, Ord a) => a -> Bool +fitsIn12bitImm off = off >= intMin12bit && off <= intMax12bit + +intMin12bit :: (Num a) => a +intMin12bit = -2048 + +intMax12bit :: (Num a) => a +intMax12bit = 2047 + +fitsIn32bits :: (Num a, Ord a, Bits a) => a -> Bool +fitsIn32bits i = (-1 `shiftL` 31) <= i && i <= (1 `shiftL` 31 - 1) + +isNbitEncodeable :: Int -> Integer -> Bool +isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift) + +isEncodeableInWidth :: Width -> Integer -> Bool +isEncodeableInWidth = isNbitEncodeable . widthInBits + +isIntOp :: Operand -> Bool +isIntOp = not . isFloatOp + +isFloatOp :: Operand -> Bool +isFloatOp (OpReg _ reg) | isFloatReg reg = True +isFloatOp _ = False + +isFloatReg :: Reg -> Bool +isFloatReg (RegReal (RealRegSingle i)) | i > 31 = True +isFloatReg (RegVirtual (VirtualRegD _)) = True +isFloatReg _ = False diff --git a/GHC/CmmToAsm/RV64/Ppr.hs b/GHC/CmmToAsm/RV64/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/Ppr.hs @@ -0,0 +1,719 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.CmmToAsm.RV64.Ppr (pprNatCmmDecl, pprInstr) where + +import GHC.Cmm hiding (topInfoTable) +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Label +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Ppr +import GHC.CmmToAsm.RV64.Cond +import GHC.CmmToAsm.RV64.Instr +import GHC.CmmToAsm.RV64.Regs +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils +import GHC.Platform +import GHC.Platform.Reg +import GHC.Prelude hiding (EQ) +import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment) +import GHC.Types.Unique (getUnique, pprUniqueAlways) +import GHC.Utils.Outputable +import GHC.Utils.Panic + +pprNatCmmDecl :: forall doc. (IsDoc doc) => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section $$ pprDatas config dats +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config + + pprProcAlignment :: doc + pprProcAlignment = maybe empty (pprAlign . mkAlignment) (ncgProcAlignment config) + in pprProcAlignment + $$ case topInfoTable proc of + Nothing -> + -- special case for code without info table: + pprSectionAlign config (Section Text lbl) + $$ + -- do not + -- pprProcAlignment config $$ + pprLabel platform lbl + $$ vcat (map (pprBasicBlock config top_info) blocks) -- blocks guaranteed not null, so label needed + $$ ppWhen + (ncgDwarfEnabled config) + (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl)) + $$ pprSizeDecl platform lbl + Just (CmmStaticsRaw info_lbl _) -> + pprSectionAlign config (Section Text info_lbl) + $$ + -- pprProcAlignment config $$ + ( if platformHasSubsectionsViaSymbols platform + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':') + else empty + ) + $$ vcat (map (pprBasicBlock config top_info) blocks) + $$ ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl)) + $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + ( if platformHasSubsectionsViaSymbols platform + then -- See Note [Subsections Via Symbols] + + line + $ text "\t.long " + <+> pprAsmLabel platform info_lbl + <+> char '-' + <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl) + else empty + ) + $$ pprSizeDecl platform info_lbl +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-} +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +pprLabel :: (IsDoc doc) => Platform -> CLabel -> doc +pprLabel platform lbl = + pprGloblDecl platform lbl + $$ pprTypeDecl platform lbl + $$ line (pprAsmLabel platform lbl <> char ':') + +pprAlign :: (IsDoc doc) => Alignment -> doc +pprAlign alignment = + -- "The .align directive for RISC-V is an alias to .p2align, which aligns to a + -- power of two, so .align 2 means align to 4 bytes. Because the definition of + -- the .align directive varies by architecture, it is recommended to use the + -- unambiguous .p2align or .balign directives instead." + -- (https://github.com/riscv-non-isa/riscv-asm-manual/blob/main/riscv-asm.md#-align) + line $ text "\t.balign " <> int (alignmentBytes alignment) + +-- | Print appropriate alignment for the given section type. +-- +-- Currently, this always aligns to a full machine word (8 byte.) A future +-- improvement could be to really do this per section type (though, it's +-- probably not a big gain.) +pprAlignForSection :: (IsDoc doc) => SectionType -> doc +pprAlignForSection _seg = pprAlign . mkAlignment $ 8 + +-- | Print section header and appropriate alignment for that section. +-- +-- This will e.g. emit a header like: +-- +-- .section .text +-- .balign 8 +pprSectionAlign :: (IsDoc doc) => NCGConfig -> Section -> doc +pprSectionAlign _config (Section (OtherSection _) _) = + panic "RV64.Ppr.pprSectionAlign: unknown section" +pprSectionAlign config sec@(Section seg _) = + line (pprSectionHeader config sec) + $$ pprAlignForSection seg + +pprProcEndLabel :: + (IsLine doc) => + Platform -> + -- | Procedure name + CLabel -> + doc +pprProcEndLabel platform lbl = + pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon + +pprBlockEndLabel :: + (IsLine doc) => + Platform -> + -- | Block name + CLabel -> + doc +pprBlockEndLabel platform lbl = + pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon + +-- | Output the ELF .size directive (if needed.) +pprSizeDecl :: (IsDoc doc) => Platform -> CLabel -> doc +pprSizeDecl platform lbl + | osElfTarget (platformOS platform) = + line $ text "\t.size" <+> asmLbl <> text ", .-" <> asmLbl + where + asmLbl = pprAsmLabel platform lbl +pprSizeDecl _ _ = empty + +pprBasicBlock :: + (IsDoc doc) => + NCGConfig -> + LabelMap RawCmmStatics -> + NatBasicBlock Instr -> + doc +pprBasicBlock config info_env (BasicBlock blockid instrs) = + maybe_infotable + $ pprLabel platform asmLbl + $$ vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) + $$ ppWhen + (ncgDwarfEnabled config) + ( -- Emit both end labels since this may end up being a standalone + -- top-level block + line + ( pprBlockEndLabel platform asmLbl + <> pprProcEndLabel platform asmLbl + ) + ) + where + -- TODO: Check if we can filter more instructions here. + -- TODO: Shouldn't this be a more general check on a higher level? + -- Filter out identity moves. E.g. mov x18, x18 will be dropped. + optInstrs = filter f instrs + where + f (MOV o1 o2) | o1 == o2 = False + f _ = True + + asmLbl = blockLbl blockid + platform = ncgPlatform config + maybe_infotable c = case mapLookup blockid info_env of + Nothing -> c + Just (CmmStaticsRaw info_lbl info) -> + -- pprAlignForSection platform Text $$ + infoTableLoc + $$ vcat (map (pprData config) info) + $$ pprLabel platform info_lbl + $$ c + $$ ppWhen + (ncgDwarfEnabled config) + (line (pprBlockEndLabel platform info_lbl)) + -- Make sure the info table has the right .loc for the block + -- coming right after it. See Note [Info Offset] + infoTableLoc = case instrs of + (l@LOCATION {} : _) -> pprInstr platform l + _other -> empty + +pprDatas :: (IsDoc doc) => NCGConfig -> RawCmmStatics -> doc +-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel, + let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing, + Just ind' <- labelInd ind, + alias `mayRedirectTo` ind' = + pprGloblDecl (ncgPlatform config) alias + $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind') +pprDatas config (CmmStaticsRaw lbl dats) = + vcat (pprLabel platform lbl : map (pprData config) dats) + where + platform = ncgPlatform config + +pprData :: (IsDoc doc) => NCGConfig -> CmmStatic -> doc +pprData _config (CmmString str) = line (pprString str) +pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path) +-- TODO: AFAIK there no Darwin for RISCV, so we may consider to simplify this. +pprData config (CmmUninitialised bytes) = + line + $ let platform = ncgPlatform config + in if platformOS platform == OSDarwin + then text ".space " <> int bytes + else text ".skip " <> int bytes +pprData config (CmmStaticLit lit) = pprDataItem config lit + +pprGloblDecl :: (IsDoc doc) => Platform -> CLabel -> doc +pprGloblDecl platform lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl) + +-- Note [Always use objects for info tables] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- See discussion in X86.Ppr for why this is necessary. Essentially we need to +-- ensure that we never pass function symbols when we might want to lookup the +-- info table. If we did, we could end up with procedure linking tables +-- (PLT)s, and thus the lookup wouldn't point to the function, but into the +-- jump table. +-- +-- Fun fact: The LLVMMangler exists to patch this issue on the LLVM side as +-- well. +pprLabelType' :: (IsLine doc) => Platform -> CLabel -> doc +pprLabelType' platform lbl = + if isCFunctionLabel lbl || functionOkInfoTable + then text "@function" + else text "@object" + where + functionOkInfoTable = + platformTablesNextToCode platform + && isInfoTableLabel lbl + && not (isCmmInfoTableLabel lbl) + && not (isConInfoTableLabel lbl) + +-- this is called pprTypeAndSizeDecl in PPC.Ppr +pprTypeDecl :: (IsDoc doc) => Platform -> CLabel -> doc +pprTypeDecl platform lbl = + if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) + else empty + +pprDataItem :: (IsDoc doc) => NCGConfig -> CmmLit -> doc +pprDataItem config lit = + lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + where + platform = ncgPlatform config + + imm = litToImm lit + + ppr_item II8 _ = [text "\t.byte\t" <> pprDataImm platform imm] + ppr_item II16 _ = [text "\t.short\t" <> pprDataImm platform imm] + ppr_item II32 _ = [text "\t.long\t" <> pprDataImm platform imm] + ppr_item II64 _ = [text "\t.quad\t" <> pprDataImm platform imm] + ppr_item FF32 (CmmFloat r _) = + let bs = floatToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs + ppr_item FF64 (CmmFloat r _) = + let bs = doubleToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs + ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit) + +-- | Pretty print an immediate value in the @data@ section +-- +-- This does not include any checks. We rely on the Assembler to check for +-- errors. Use `pprOpImm` for immediates in instructions (operands.) +pprDataImm :: (IsLine doc) => Platform -> Imm -> doc +pprDataImm _ (ImmInt i) = int i +pprDataImm _ (ImmInteger i) = integer i +pprDataImm p (ImmCLbl l) = pprAsmLabel p l +pprDataImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i +pprDataImm _ (ImmLit s) = ftext s +pprDataImm _ (ImmFloat f) = float (fromRational f) +pprDataImm _ (ImmDouble d) = double (fromRational d) +pprDataImm p (ImmConstantSum a b) = pprDataImm p a <> char '+' <> pprDataImm p b +pprDataImm p (ImmConstantDiff a b) = + pprDataImm p a + <> char '-' + <> lparen + <> pprDataImm p b + <> rparen + +-- | Comment @c@ with @# c@ +asmComment :: SDoc -> SDoc +asmComment c = text "#" <+> c + +-- | Commen @c@ with @// c@ +asmDoubleslashComment :: SDoc -> SDoc +asmDoubleslashComment c = text "//" <+> c + +-- | Comment @c@ with @/* c */@ (multiline comment) +asmMultilineComment :: SDoc -> SDoc +asmMultilineComment c = text "/*" $+$ c $+$ text "*/" + +-- | Pretty print an immediate operand of an instruction +-- +-- The kinds of immediates we can use here is pretty limited: RISCV doesn't +-- support index expressions (as e.g. Aarch64 does.) Floating points need to +-- fit in range. As we don't need them, forbit them to save us from future +-- troubles. +pprOpImm :: (IsLine doc) => Platform -> Imm -> doc +pprOpImm platform im = case im of + ImmInt i -> int i + ImmInteger i -> integer i + ImmCLbl l -> char '=' <> pprAsmLabel platform l + _ -> pprPanic "RV64.Ppr.pprOpImm" (text "Unsupported immediate for instruction operands" <> colon <+> (text . show) im) + +-- | Negate integer immediate operand +-- +-- This function is partial and will panic if the operand is not an integer. +negOp :: Operand -> Operand +negOp (OpImm (ImmInt i)) = OpImm (ImmInt (negate i)) +negOp (OpImm (ImmInteger i)) = OpImm (ImmInteger (negate i)) +negOp op = pprPanic "RV64.negOp" (text $ show op) + +-- | Pretty print an operand +pprOp :: (IsLine doc) => Platform -> Operand -> doc +pprOp plat op = case op of + OpReg w r -> pprReg w r + OpImm im -> pprOpImm plat im + OpAddr (AddrRegImm r1 im) -> pprOpImm plat im <> char '(' <> pprReg W64 r1 <> char ')' + OpAddr (AddrReg r1) -> text "0(" <+> pprReg W64 r1 <+> char ')' + +-- | Pretty print register with calling convention name +-- +-- This representation makes it easier to reason about the emitted assembly +-- code. +pprReg :: forall doc. (IsLine doc) => Width -> Reg -> doc +pprReg w r = case r of + RegReal (RealRegSingle i) -> ppr_reg_no i + -- virtual regs should not show up, but this is helpful for debugging. + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u + _ -> pprPanic "RiscV64.pprReg" (text (show r) <+> ppr w) + where + ppr_reg_no :: Int -> doc + -- General Purpose Registers + ppr_reg_no 0 = text "zero" + ppr_reg_no 1 = text "ra" + ppr_reg_no 2 = text "sp" + ppr_reg_no 3 = text "gp" + ppr_reg_no 4 = text "tp" + ppr_reg_no 5 = text "t0" + ppr_reg_no 6 = text "t1" + ppr_reg_no 7 = text "t2" + ppr_reg_no 8 = text "s0" + ppr_reg_no 9 = text "s1" + ppr_reg_no 10 = text "a0" + ppr_reg_no 11 = text "a1" + ppr_reg_no 12 = text "a2" + ppr_reg_no 13 = text "a3" + ppr_reg_no 14 = text "a4" + ppr_reg_no 15 = text "a5" + ppr_reg_no 16 = text "a6" + ppr_reg_no 17 = text "a7" + ppr_reg_no 18 = text "s2" + ppr_reg_no 19 = text "s3" + ppr_reg_no 20 = text "s4" + ppr_reg_no 21 = text "s5" + ppr_reg_no 22 = text "s6" + ppr_reg_no 23 = text "s7" + ppr_reg_no 24 = text "s8" + ppr_reg_no 25 = text "s9" + ppr_reg_no 26 = text "s10" + ppr_reg_no 27 = text "s11" + ppr_reg_no 28 = text "t3" + ppr_reg_no 29 = text "t4" + ppr_reg_no 30 = text "t5" + ppr_reg_no 31 = text "t6" + -- Floating Point Registers + ppr_reg_no 32 = text "ft0" + ppr_reg_no 33 = text "ft1" + ppr_reg_no 34 = text "ft2" + ppr_reg_no 35 = text "ft3" + ppr_reg_no 36 = text "ft4" + ppr_reg_no 37 = text "ft5" + ppr_reg_no 38 = text "ft6" + ppr_reg_no 39 = text "ft7" + ppr_reg_no 40 = text "fs0" + ppr_reg_no 41 = text "fs1" + ppr_reg_no 42 = text "fa0" + ppr_reg_no 43 = text "fa1" + ppr_reg_no 44 = text "fa2" + ppr_reg_no 45 = text "fa3" + ppr_reg_no 46 = text "fa4" + ppr_reg_no 47 = text "fa5" + ppr_reg_no 48 = text "fa6" + ppr_reg_no 49 = text "fa7" + ppr_reg_no 50 = text "fs2" + ppr_reg_no 51 = text "fs3" + ppr_reg_no 52 = text "fs4" + ppr_reg_no 53 = text "fs5" + ppr_reg_no 54 = text "fs6" + ppr_reg_no 55 = text "fs7" + ppr_reg_no 56 = text "fs8" + ppr_reg_no 57 = text "fs9" + ppr_reg_no 58 = text "fs10" + ppr_reg_no 59 = text "fs11" + ppr_reg_no 60 = text "ft8" + ppr_reg_no 61 = text "ft9" + ppr_reg_no 62 = text "ft10" + ppr_reg_no 63 = text "ft11" + ppr_reg_no i + | i < 0 = pprPanic "Unexpected register number (min is 0)" (ppr w <+> int i) + | i > 63 = pprPanic "Unexpected register number (max is 63)" (ppr w <+> int i) + -- no support for widths > W64. + | otherwise = pprPanic "Unsupported width in register (max is 64)" (ppr w <+> int i) + +-- | Single precission `Operand` (floating-point) +isSingleOp :: Operand -> Bool +isSingleOp (OpReg W32 _) = True +isSingleOp _ = False + +-- | Double precission `Operand` (floating-point) +isDoubleOp :: Operand -> Bool +isDoubleOp (OpReg W64 _) = True +isDoubleOp _ = False + +-- | `Operand` is an immediate value +isImmOp :: Operand -> Bool +isImmOp (OpImm _) = True +isImmOp _ = False + +-- | `Operand` is an immediate @0@ value +isImmZero :: Operand -> Bool +isImmZero (OpImm (ImmFloat 0)) = True +isImmZero (OpImm (ImmDouble 0)) = True +isImmZero (OpImm (ImmInt 0)) = True +isImmZero _ = False + +-- | `Target` represents a label +isLabel :: Target -> Bool +isLabel (TBlock _) = True +isLabel _ = False + +-- | Get the pretty-printed label from a `Target` +-- +-- This function is partial and will panic if the `Target` is not a label. +getLabel :: (IsLine doc) => Platform -> Target -> doc +getLabel platform (TBlock bid) = pprBlockId platform bid + where + pprBlockId :: (IsLine doc) => Platform -> BlockId -> doc + pprBlockId platform bid = pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) +getLabel _platform _other = panic "Cannot turn this into a label" + +-- | Pretty-print an `Instr` +-- +-- This function is partial and will panic if the `Instr` is not supported. This +-- can happen due to invalid operands or unexpected meta instructions. +pprInstr :: (IsDoc doc) => Platform -> Instr -> doc +pprInstr platform instr = case instr of + -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable + COMMENT s -> dualDoc (asmComment s) empty + MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty + ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i) + LOCATION file line' col _name -> + line (text "\t.loc" <+> int file <+> int line' <+> int col) + DELTA d -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty + NEWBLOCK _ -> panic "PprInstr: NEWBLOCK" + LDATA _ _ -> panic "pprInstr: LDATA" + PUSH_STACK_FRAME -> + lines_ + [ text "\taddi sp, sp, -16", + text "\tsd x1, 8(sp)", -- store RA + text "\tsd x8, 0(sp)", -- store FP/s0 + text "\taddi x8, sp, 16" + ] + POP_STACK_FRAME -> + lines_ + [ text "\tld x8, 0(sp)", -- restore FP/s0 + text "\tld x1, 8(sp)", -- restore RA + text "\taddi sp, sp, 16" + ] + ADD o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfadd." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3 + -- This case is used for sign extension: SEXT.W op + | OpReg W64 _ <- o1, OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddiw") o1 o2 o3 + | otherwise -> op3 (text "\tadd") o1 o2 o3 + MUL o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfmul." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3 + | otherwise -> op3 (text "\tmul") o1 o2 o3 + MULH o1 o2 o3 -> op3 (text "\tmulh") o1 o2 o3 + NEG o1 o2 | isFloatOp o1 && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2 + NEG o1 o2 | isFloatOp o1 && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2 + NEG o1 o2 -> op2 (text "\tneg") o1 o2 + DIV o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> + -- TODO: This must (likely) be refined regarding width + op3 (text "\tfdiv." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3 + DIV o1 o2 o3 -> op3 (text "\tdiv") o1 o2 o3 + REM o1 o2 o3 + | isFloatOp o1 || isFloatOp o2 || isFloatOp o3 -> + panic "pprInstr - REM not implemented for floats (yet)" + REM o1 o2 o3 -> op3 (text "\trem") o1 o2 o3 + REMU o1 o2 o3 -> op3 (text "\tremu") o1 o2 o3 + SUB o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfsub." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3 + | isImmOp o3 -> op3 (text "\taddi") o1 o2 (negOp o3) + | otherwise -> op3 (text "\tsub") o1 o2 o3 + DIVU o1 o2 o3 -> op3 (text "\tdivu") o1 o2 o3 + AND o1 o2 o3 + | isImmOp o3 -> op3 (text "\tandi") o1 o2 o3 + | otherwise -> op3 (text "\tand") o1 o2 o3 + OR o1 o2 o3 -> op3 (text "\tor") o1 o2 o3 + SRA o1 o2 o3 | isImmOp o3 -> op3 (text "\tsrai") o1 o2 o3 + SRA o1 o2 o3 -> op3 (text "\tsra") o1 o2 o3 + XOR o1 o2 o3 -> op3 (text "\txor") o1 o2 o3 + SLL o1 o2 o3 -> op3 (text "\tsll") o1 o2 o3 + SRL o1 o2 o3 -> op3 (text "\tsrl") o1 o2 o3 + MOV o1 o2 + | isFloatOp o1 && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.d") o1 o2 -- fmv.d rd, rs is pseudo op fsgnj.d rd, rs, rs + | isFloatOp o1 && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfmv.s") o1 o2 -- fmv.s rd, rs is pseudo op fsgnj.s rd, rs, rs + | isFloatOp o1 && isImmZero o2 && isDoubleOp o1 -> op2 (text "\tfcvt.d.w") o1 zero + | isFloatOp o1 && isImmZero o2 && isSingleOp o1 -> op2 (text "\tfcvt.s.w") o1 zero + | isFloatOp o1 && not (isFloatOp o2) && isSingleOp o1 -> op2 (text "\tfmv.w.x") o1 o2 + | isFloatOp o1 && not (isFloatOp o2) && isDoubleOp o1 -> op2 (text "\tfmv.d.x") o1 o2 + | not (isFloatOp o1) && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfmv.x.w") o1 o2 + | not (isFloatOp o1) && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.x.d") o1 o2 + | (OpImm (ImmInteger i)) <- o2, + fitsIn12bitImm i -> + lines_ [text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <> comma <+> pprOp platform o2] + | (OpImm (ImmInt i)) <- o2, + fitsIn12bitImm i -> + lines_ [text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <> comma <+> pprOp platform o2] + | (OpImm (ImmInteger i)) <- o2, + fitsIn32bits i -> + lines_ + [ text "\tlui" <+> pprOp platform o1 <> comma <+> text "%hi(" <> pprOp platform o2 <> text ")", + text "\taddw" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%lo(" <> pprOp platform o2 <> text ")" + ] + | (OpImm (ImmInt i)) <- o2, + fitsIn32bits i -> + lines_ + [ text "\tlui" <+> pprOp platform o1 <> comma <+> text "%hi(" <> pprOp platform o2 <> text ")", + text "\taddw" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%lo(" <> pprOp platform o2 <> text ")" + ] + | isImmOp o2 -> + -- Surrender! Let the assembler figure out the right expressions with pseudo-op LI. + lines_ [text "\tli" <+> pprOp platform o1 <> comma <+> pprOp platform o2] + | otherwise -> op3 (text "\taddi") o1 o2 (OpImm (ImmInt 0)) + ORI o1 o2 o3 -> op3 (text "\tori") o1 o2 o3 + XORI o1 o2 o3 -> op3 (text "\txori") o1 o2 o3 + J o1 -> pprInstr platform (B o1) + J_TBL _ _ r -> pprInstr platform (B (TReg r)) + B l | isLabel l -> line $ text "\tjal" <+> pprOp platform x0 <> comma <+> getLabel platform l + B (TReg r) -> line $ text "\tjalr" <+> pprOp platform x0 <> comma <+> pprReg W64 r <> comma <+> text "0" + BL r _ -> line $ text "\tjalr" <+> text "x1" <> comma <+> pprReg W64 r <> comma <+> text "0" + BCOND c l r t + | isLabel t -> + line $ text "\t" <> pprBcond c <+> pprOp platform l <> comma <+> pprOp platform r <> comma <+> getLabel platform t + BCOND _ _ _ (TReg _) -> panic "RV64.ppr: No conditional branching to registers!" + CSET o l r c -> case c of + EQ + | isIntOp l && isIntOp r -> + lines_ + [ subFor l r, + text "\tseqz" <+> pprOp platform o <> comma <+> pprOp platform o + ] + EQ | isFloatOp l && isFloatOp r -> line $ binOp ("\tfeq." ++ floatOpPrecision platform l r) + NE + | isIntOp l && isIntOp r -> + lines_ + [ subFor l r, + text "\tsnez" <+> pprOp platform o <> comma <+> pprOp platform o + ] + NE + | isFloatOp l && isFloatOp r -> + lines_ + [ binOp ("\tfeq." ++ floatOpPrecision platform l r), + text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1" + ] + SLT -> lines_ [sltFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r] + SLE -> + lines_ + [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l, + text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1" + ] + SGE -> + lines_ + [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r, + text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1" + ] + SGT -> lines_ [sltFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l] + ULT -> lines_ [sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r] + ULE -> + lines_ + [ sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l, + text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1" + ] + UGE -> + lines_ + [ sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r, + text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1" + ] + UGT -> lines_ [sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l] + FLT | isFloatOp l && isFloatOp r -> line $ binOp ("\tflt." ++ floatOpPrecision platform l r) + FLE | isFloatOp l && isFloatOp r -> line $ binOp ("\tfle." ++ floatOpPrecision platform l r) + FGT | isFloatOp l && isFloatOp r -> line $ binOp ("\tfgt." ++ floatOpPrecision platform l r) + FGE | isFloatOp l && isFloatOp r -> line $ binOp ("\tfge." ++ floatOpPrecision platform l r) + x -> pprPanic "RV64.ppr: unhandled CSET conditional" (text (show x) <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l) + where + subFor l r + | (OpImm _) <- r = text "\taddi" <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform (negOp r) + | (OpImm _) <- l = panic "RV64.ppr: Cannot SUB IMM _" + | otherwise = text "\tsub" <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r + sltFor l r + | (OpImm _) <- r = text "\tslti" + | (OpImm _) <- l = panic "PV64.ppr: Cannot SLT IMM _" + | otherwise = text "\tslt" + sltuFor l r + | (OpImm _) <- r = text "\tsltui" + | (OpImm _) <- l = panic "PV64.ppr: Cannot SLTU IMM _" + | otherwise = text "\tsltu" + binOp :: (IsLine doc) => String -> doc + binOp op = text op <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r + STR II8 o1 o2 -> op2 (text "\tsb") o1 o2 + STR II16 o1 o2 -> op2 (text "\tsh") o1 o2 + STR II32 o1 o2 -> op2 (text "\tsw") o1 o2 + STR II64 o1 o2 -> op2 (text "\tsd") o1 o2 + STR FF32 o1 o2 -> op2 (text "\tfsw") o1 o2 + STR FF64 o1 o2 -> op2 (text "\tfsd") o1 o2 + LDR _f o1 (OpImm (ImmIndex lbl off)) -> + lines_ + [ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl, + text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off + ] + LDR _f o1 (OpImm (ImmCLbl lbl)) -> + line $ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl + LDR II8 o1 o2 -> op2 (text "\tlb") o1 o2 + LDR II16 o1 o2 -> op2 (text "\tlh") o1 o2 + LDR II32 o1 o2 -> op2 (text "\tlw") o1 o2 + LDR II64 o1 o2 -> op2 (text "\tld") o1 o2 + LDR FF32 o1 o2 -> op2 (text "\tflw") o1 o2 + LDR FF64 o1 o2 -> op2 (text "\tfld") o1 o2 + LDRU II8 o1 o2 -> op2 (text "\tlbu") o1 o2 + LDRU II16 o1 o2 -> op2 (text "\tlhu") o1 o2 + LDRU II32 o1 o2 -> op2 (text "\tlwu") o1 o2 + -- double words (64bit) cannot be sign extended by definition + LDRU II64 o1 o2 -> op2 (text "\tld") o1 o2 + LDRU FF32 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tflw") o1 o2 + LDRU FF32 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tflw") o1 o2 + LDRU FF64 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tfld") o1 o2 + LDRU FF64 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tfld") o1 o2 + LDRU f o1 o2 -> pprPanic "Unsupported unsigned load" ((text . show) f <+> pprOp platform o1 <+> pprOp platform o2) + FENCE r w -> line $ text "\tfence" <+> pprFenceType r <> char ',' <+> pprFenceType w + FCVT FloatToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.d") o1 o2 + FCVT FloatToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.s") o1 o2 + FCVT FloatToFloat o1 o2 -> + pprPanic "RV64.pprInstr - impossible float to float conversion" + $ line (pprOp platform o1 <> text "->" <> pprOp platform o2) + FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.s.w") o1 o2 + FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.l") o1 o2 + FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.w") o1 o2 + FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.d.l") o1 o2 + FCVT IntToFloat o1 o2 -> + pprPanic "RV64.pprInstr - impossible integer to float conversion" + $ line (pprOp platform o1 <> text "->" <> pprOp platform o2) + FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.w.s") o1 o2 + FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.w.d") o1 o2 + FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.l.s") o1 o2 + FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.l.d") o1 o2 + FCVT FloatToInt o1 o2 -> + pprPanic "RV64.pprInstr - impossible float to integer conversion" + $ line (pprOp platform o1 <> text "->" <> pprOp platform o2) + FABS o1 o2 | isSingleOp o2 -> op2 (text "\tfabs.s") o1 o2 + FABS o1 o2 | isDoubleOp o2 -> op2 (text "\tfabs.d") o1 o2 + FMIN o1 o2 o3 | isSingleOp o1 -> op3 (text "\tfmin.s") o1 o2 o3 + | isDoubleOp o2 -> op3 (text "\tfmin.d") o1 o2 o3 + FMAX o1 o2 o3 | isSingleOp o1 -> op3 (text "\tfmax.s") o1 o2 o3 + | isDoubleOp o2 -> op3 (text "\tfmax.d") o1 o2 o3 + FMA variant d r1 r2 r3 -> + let fma = case variant of + FMAdd -> text "\tfmadd" <> dot <> floatPrecission d + FMSub -> text "\tfmsub" <> dot <> floatPrecission d + FNMAdd -> text "\tfnmadd" <> dot <> floatPrecission d + FNMSub -> text "\tfnmsub" <> dot <> floatPrecission d + in op4 fma d r1 r2 r3 + instr -> panic $ "RV64.pprInstr - Unknown instruction: " ++ instrCon instr + where + op2 op o1 o2 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 + op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 + pprFenceType FenceRead = text "r" + pprFenceType FenceWrite = text "w" + pprFenceType FenceReadWrite = text "rw" + floatPrecission o + | isSingleOp o = text "s" + | isDoubleOp o = text "d" + | otherwise = pprPanic "Impossible floating point precission: " (pprOp platform o) + +floatOpPrecision :: Platform -> Operand -> Operand -> String +floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isSingleOp l && isSingleOp r = "s" -- single precision +floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isDoubleOp l && isDoubleOp r = "d" -- double precision +floatOpPrecision p l r = pprPanic "Cannot determine floating point precission" (text "op1" <+> pprOp p l <+> text "op2" <+> pprOp p r) + +-- | Pretty print a conditional branch +-- +-- This function is partial and will panic if the conditional is not supported; +-- i.e. if its floating point related. +pprBcond :: (IsLine doc) => Cond -> doc +pprBcond c = text "b" <> pprCond c + where + pprCond :: (IsLine doc) => Cond -> doc + pprCond c = case c of + EQ -> text "eq" + NE -> text "ne" + SLT -> text "lt" + SLE -> text "le" + SGE -> text "ge" + SGT -> text "gt" + ULT -> text "ltu" + ULE -> text "leu" + UGE -> text "geu" + UGT -> text "gtu" + -- BCOND cannot handle floating point comparisons / registers + _ -> panic $ "RV64.ppr: unhandled BCOND conditional: " ++ show c diff --git a/GHC/CmmToAsm/RV64/RegInfo.hs b/GHC/CmmToAsm/RV64/RegInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/RegInfo.hs @@ -0,0 +1,41 @@ +-- | Minimum viable implementation of jump short-cutting: No short-cutting. +-- +-- The functions here simply implement the no-short-cutting case. Implementing +-- the real behaviour would be a great optimization in future. +module GHC.CmmToAsm.RV64.RegInfo + ( getJumpDestBlockId, + canShortcut, + shortcutStatics, + shortcutJump, + JumpDest (..), + ) +where + +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.CmmToAsm.RV64.Instr +import GHC.Prelude +import GHC.Utils.Outputable + +newtype JumpDest = DestBlockId BlockId + +instance Outputable JumpDest where + ppr (DestBlockId bid) = text "jd:" <> ppr bid + +-- | Extract BlockId +-- +-- Never `Nothing` for Riscv64 NCG. +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid + +-- No `Instr`s can bet shortcut (for now) +canShortcut :: Instr -> Maybe JumpDest +canShortcut _ = Nothing + +-- Identity of the provided `RawCmmStatics` +shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics +shortcutStatics _ other_static = other_static + +-- Identity of the provided `Instr` +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump _ other = other diff --git a/GHC/CmmToAsm/RV64/Regs.hs b/GHC/CmmToAsm/RV64/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/Regs.hs @@ -0,0 +1,245 @@ +module GHC.CmmToAsm.RV64.Regs where + +import GHC.Cmm +import GHC.Cmm.CLabel (CLabel) +import GHC.CmmToAsm.Format +import GHC.Data.FastString +import GHC.Platform +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import GHC.Platform.Reg.Class.Separate +import GHC.Platform.Regs +import GHC.Prelude +import GHC.Types.Unique +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- * Registers + +-- | First integer register number. @zero@ register. +x0RegNo :: RegNo +x0RegNo = 0 + +-- | return address register +x1RegNo, raRegNo :: RegNo +x1RegNo = 1 +raRegNo = x1RegNo + +x5RegNo, t0RegNo :: RegNo +x5RegNo = 5 +t0RegNo = x5RegNo + +x7RegNo, t2RegNo :: RegNo +x7RegNo = 7 +t2RegNo = x7RegNo + +x28RegNo, t3RegNo :: RegNo +x28RegNo = 28 +t3RegNo = x28RegNo + +-- | Last integer register number. Used as TMP (IP) register. +x31RegNo, t6RegNo, tmpRegNo :: RegNo +x31RegNo = 31 +t6RegNo = x31RegNo +tmpRegNo = x31RegNo + +-- | First floating point register. +d0RegNo, ft0RegNo :: RegNo +d0RegNo = 32 +ft0RegNo = d0RegNo + +d7RegNo, ft7RegNo :: RegNo +d7RegNo = 39 +ft7RegNo = d7RegNo + +-- | Last floating point register. +d31RegNo :: RegNo +d31RegNo = 63 + +a0RegNo, x10RegNo :: RegNo +x10RegNo = 10 +a0RegNo = x10RegNo + +a7RegNo, x17RegNo :: RegNo +x17RegNo = 17 +a7RegNo = x17RegNo + +fa0RegNo, d10RegNo :: RegNo +d10RegNo = 42 +fa0RegNo = d10RegNo + +fa7RegNo, d17RegNo :: RegNo +d17RegNo = 49 +fa7RegNo = d17RegNo + +-- Note [The made-up RISCV64 TMP (IP) register] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- RISCV64 has no inter-procedural register in its ABI. However, we need one to +-- make register spills/loads to/from high number slots. I.e. slot numbers that +-- do not fit in a 12bit integer which is used as immediate in the arithmetic +-- operations. Thus, we're marking one additional register (x31) as permanently +-- non-free and call it TMP. +-- +-- TMP can be used as temporary register in all operations. Just be aware that +-- it may be clobbered as soon as you loose direct control over it (i.e. using +-- TMP by-passes the register allocation/spilling mechanisms.) It should be fine +-- to use it as temporary register in a MachOp translation as long as you don't +-- rely on its value beyond this limited scope. +-- +-- X31 is a caller-saved register. I.e. there are no guarantees about what the +-- callee does with it. That's exactly what we want here. + +zeroReg, raReg, spMachReg, tmpReg :: Reg +zeroReg = regSingle x0RegNo +raReg = regSingle 1 + +-- | Not to be confused with the `CmmReg` `spReg` +spMachReg = regSingle 2 + +tmpReg = regSingle tmpRegNo + +-- | All machine register numbers. +allMachRegNos :: [RegNo] +allMachRegNos = intRegs ++ fpRegs + where + intRegs = [x0RegNo .. x31RegNo] + fpRegs = [d0RegNo .. d31RegNo] + +-- | Registers available to the register allocator. +-- +-- These are all registers minus those with a fixed role in RISCV ABI (zero, lr, +-- sp, gp, tp, fp, tmp) and GHC RTS (Base, Sp, Hp, HpLim, R1..R8, F1..F6, +-- D1..D6.) +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform = + let isFree = freeReg platform + in map RealRegSingle $ filter isFree allMachRegNos + +-- | Integer argument registers according to the calling convention +allGpArgRegs :: [Reg] +allGpArgRegs = map regSingle [a0RegNo .. a7RegNo] + +-- | Floating point argument registers according to the calling convention +allFpArgRegs :: [Reg] +allFpArgRegs = map regSingle [fa0RegNo .. fa7RegNo] + +-- * Addressing modes + +-- | Addressing modes +data AddrMode + = -- | A register plus some immediate integer, e.g. @8(sp)@ or @-16(sp)@. The + -- offset needs to fit into 12bits. + AddrRegImm Reg Imm + | -- | A register + AddrReg Reg + deriving (Eq, Show) + +-- * Immediates + +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit FastString + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + deriving (Eq, Show) + +-- | Map `CmmLit` to `Imm` +-- +-- N.B. this is a partial function, because not all `CmmLit`s have an immediate +-- representation. +litToImm :: CmmLit -> Imm +litToImm (CmmInt i w) = ImmInteger (narrowS w i) +-- narrow to the width: a CmmInt might be out of +-- range, but we assume that ImmInteger only contains +-- in-range values. A signed value should be fine here. +litToImm (CmmFloat f W32) = ImmFloat f +litToImm (CmmFloat f W64) = ImmDouble f +litToImm (CmmLabel l) = ImmCLbl l +litToImm (CmmLabelOff l off) = ImmIndex l off +litToImm (CmmLabelDiffOff l1 l2 off _) = + ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) +litToImm l = panic $ "RV64.Regs.litToImm: no match for " ++ show l + +-- == To satisfy GHC.CmmToAsm.Reg.Target ======================================= + +-- squeese functions for the graph allocator ----------------------------------- + +-- | regSqueeze_class reg +-- Calculate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> Int +virtualRegSqueeze cls vr = + case cls of + RcInteger -> + case vr of + VirtualRegI {} -> 1 + VirtualRegHi {} -> 1 + _other -> 0 + RcFloat -> + case vr of + VirtualRegD {} -> 1 + _other -> 0 + RcVector -> + case vr of + VirtualRegV128 {} -> 1 + _other -> 0 + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> Int +realRegSqueeze cls rr = + case cls of + RcInteger -> + case rr of + RealRegSingle regNo + | regNo < d0RegNo + -> 1 + | otherwise + -> 0 + RcFloat -> + case rr of + RealRegSingle regNo + | regNo < d0RegNo + || regNo > d31RegNo + -> 0 + | otherwise + -> 1 + RcVector -> + case rr of + RealRegSingle regNo + | regNo > d31RegNo + -> 1 + | otherwise + -> 0 + +mkVirtualReg :: Unique -> Format -> VirtualReg +mkVirtualReg u format + | not (isFloatFormat format) = VirtualRegI u + | otherwise = + case format of + FF32 -> VirtualRegD u + FF64 -> VirtualRegD u + _ -> panic "RV64.mkVirtualReg" + +{-# INLINE classOfRealReg #-} +classOfRealReg :: RealReg -> RegClass +classOfRealReg (RealRegSingle i) + | i < d0RegNo = RcInteger + | i > d31RegNo = RcVector + | otherwise = RcFloat + +regDotColor :: RealReg -> SDoc +regDotColor reg = + case classOfRealReg reg of + RcInteger -> text "blue" + RcFloat -> text "red" + RcVector -> text "green" diff --git a/GHC/CmmToAsm/Reg/Graph.hs b/GHC/CmmToAsm/Reg/Graph.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + + +-- | Graph coloring register allocator. +module GHC.CmmToAsm.Reg.Graph ( + regAlloc +) where +import GHC.Prelude + +import qualified GHC.Data.Graph.Color as Color +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Reg.Graph.Spill +import GHC.CmmToAsm.Reg.Graph.SpillClean +import GHC.CmmToAsm.Reg.Graph.SpillCost +import GHC.CmmToAsm.Reg.Graph.Stats +import GHC.CmmToAsm.Reg.Graph.TrivColorable +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Types +import GHC.Platform.Reg.Class +import GHC.Platform.Reg + +import GHC.Data.Bag +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSM +import GHC.Utils.Misc (seqList, HasDebugCallStack) +import GHC.CmmToAsm.CFG + +import Data.Maybe +import Control.Monad + + +-- | The maximum number of build\/spill cycles we'll allow. +-- +-- It should only take 3 or 4 cycles for the allocator to converge. +-- If it takes any longer than this it's probably in an infinite loop, +-- so it's better just to bail out and report a bug. +maxSpinCount :: Int +maxSpinCount = 10 + + +-- | The top level of the graph coloring register allocator. +regAlloc + :: (OutputableP Platform statics, Instruction instr) + => NCGConfig + -> UniqFM RegClass (UniqSet RealReg) -- ^ registers we can use for allocation + -> UniqSet Int -- ^ set of available spill slots. + -> Int -- ^ current number of spill slots + -> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information. + -> Maybe CFG -- ^ CFG of basic blocks if available + -> UniqDSM ( [NatCmmDecl statics instr] + , Maybe Int, [RegAllocStats statics instr] ) + -- ^ code with registers allocated, additional stacks required + -- and stats for each stage of allocation + +regAlloc config regsFree slotsFree slotsCount code cfg + = do + let platform = ncgPlatform config + triv = trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform) + + (code_final, debug_codeGraphs, slotsCount', _) + <- regAlloc_spin config 0 + triv + regsFree slotsFree slotsCount [] code cfg + + let needStack + | slotsCount == slotsCount' + = Nothing + | otherwise + = Just slotsCount' + + return ( code_final + , needStack + , reverse debug_codeGraphs ) + + +-- | Perform solver iterations for the graph coloring allocator. +-- +-- We extract a register conflict graph from the provided cmm code, +-- and try to colour it. If that works then we use the solution rewrite +-- the code with real hregs. If coloring doesn't work we add spill code +-- and try to colour it again. After `maxSpinCount` iterations we give up. +-- +regAlloc_spin + :: forall instr statics. + (Instruction instr, + OutputableP Platform statics, + HasDebugCallStack) + => NCGConfig + -> Int -- ^ Number of solver iterations we've already performed. + -> Color.Triv VirtualReg RegClass RealReg + -- ^ Function for calculating whether a register is trivially + -- colourable. + -> UniqFM RegClass (UniqSet RealReg) -- ^ Free registers that we can allocate. + -> UniqSet Int -- ^ Free stack slots that we can use. + -> Int -- ^ Number of spill slots in use + -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to. + -> [LiveCmmDecl statics instr] -- ^ Liveness annotated code to allocate. + -> Maybe CFG + -> UniqDSM ( [NatCmmDecl statics instr] + , [RegAllocStats statics instr] + , Int -- Slots in use + , Color.Graph VirtualReg RegClass RealReg) + +regAlloc_spin config spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg + = do + let platform = ncgPlatform config + + -- If any of these dump flags are turned on we want to hang on to + -- intermediate structures in the allocator - otherwise tell the + -- allocator to ditch them early so we don't end up creating space leaks. + let dump = or + [ ncgDumpRegAllocStages config + , ncgDumpAsmStats config + , ncgDumpAsmConflicts config + ] + + -- Check that we're not running off down the garden path. + when (spinCount > maxSpinCount) + $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded." + ( text "It looks like the register allocator is stuck in an infinite loop." + $$ text "max cycles = " <> int maxSpinCount + $$ text "regsFree = " <> (hcat $ punctuate space $ map ppr + $ nonDetEltsUniqSet $ unionManyUniqSets + $ nonDetEltsUFM regsFree) + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) + + -- Build the register conflict graph from the cmm code. + (graph :: Color.Graph VirtualReg RegClass RealReg) + <- {-# SCC "BuildGraph" #-} buildGraph platform code + + -- VERY IMPORTANT: + -- We really do want the graph to be fully evaluated _before_ we + -- start coloring. If we don't do this now then when the call to + -- Color.colorGraph forces bits of it, the heap will be filled with + -- half evaluated pieces of graph and zillions of apply thunks. + seqGraph graph `seq` return () + + -- Build a map of the cost of spilling each instruction. + -- This is a lazy binding, so the map will only be computed if we + -- actually have to spill to the stack. + let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo + $ map (slurpSpillCostInfo platform cfg) code + + -- The function to choose regs to leave uncolored. + let spill = chooseSpill spillCosts + + -- Record startup state in our log. + let stat1 + = if spinCount == 0 + then Just $ RegAllocStatsStart + { raLiveCmm = code + , raGraph = graph + , raSpillCosts = spillCosts + , raPlatform = platform + } + else Nothing + + -- Try and color the graph. + let (graph_colored, rsSpill, rmCoalesce) + = {-# SCC "ColorGraph" #-} + Color.colorGraph + (ncgRegsIterative config) + spinCount + regsFree triv spill graph + + -- Rewrite registers in the code that have been coalesced. + let patchF reg + | RegVirtual vr <- reg + = case lookupUFM rmCoalesce vr of + Just vr' -> patchF (RegVirtual vr') + Nothing -> reg + + | otherwise + = reg + + let (code_coalesced :: [LiveCmmDecl statics instr]) + = map (patchEraseLive platform patchF) code + + -- Check whether we've found a coloring. + if isEmptyUniqSet rsSpill + + -- Coloring was successful because no registers needed to be spilled. + then do + -- if -fasm-lint is turned on then validate the graph. + -- This checks for bugs in the graph allocator itself. + let graph_colored_lint = + if ncgAsmLinting config + then Color.validateGraph (text "") + True -- Require all nodes to be colored. + graph_colored + else graph_colored + + -- Rewrite the code to use real hregs, using the colored graph. + let code_patched + = map (patchRegsFromGraph platform graph_colored_lint) + code_coalesced + + -- Clean out unneeded SPILL/RELOAD meta instructions. + -- The spill code generator just spills the entire live range + -- of a vreg, but it might not need to be on the stack for + -- its entire lifetime. + let code_spillclean + = map (cleanSpills config) code_patched + + -- Strip off liveness information from the allocated code. + -- Also rewrite SPILL/RELOAD meta instructions into real machine + -- instructions along the way + let code_final + = map (stripLive config) code_spillclean + + -- Record what happened in this stage for debugging + let stat + = RegAllocStatsColored + { raCode = code + , raGraph = graph + , raGraphColored = graph_colored_lint + , raCoalesced = rmCoalesce + , raCodeCoalesced = code_coalesced + , raPatched = code_patched + , raSpillClean = code_spillclean + , raFinal = code_final + , raSRMs = foldl' addSRM (0, 0, 0) + $ map (countSRMs platform) code_spillclean + , raPlatform = platform + } + + -- Bundle up all the register allocator statistics. + -- .. but make sure to drop them on the floor if they're not + -- needed, otherwise we'll get a space leak. + let statList = + if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else [] + + -- Ensure all the statistics are evaluated, to avoid space leaks. + seqList statList (return ()) + + return ( code_final + , statList + , slotsCount + , graph_colored_lint) + + -- Coloring was unsuccessful. We need to spill some register to the + -- stack, make a new graph, and try to color it again. + else do + -- if -fasm-lint is turned on then validate the graph + let graph_colored_lint = + if ncgAsmLinting config + then Color.validateGraph (text "") + False -- don't require nodes to be colored + graph_colored + else graph_colored + + -- Spill uncolored regs to the stack. + (code_spilled, slotsFree', slotsCount', spillStats) + <- regSpill platform code_coalesced slotsFree slotsCount rsSpill + + -- Recalculate liveness information. + -- NOTE: we have to reverse the SCCs here to get them back into + -- the reverse-dependency order required by computeLiveness. + -- If they're not in the correct order that function will panic. + code_relive <- mapM (regLiveness platform . reverseBlocksInTops) + code_spilled + + -- Record what happened in this stage for debugging. + let stat = + RegAllocStatsSpill + { raCode = code + , raGraph = graph_colored_lint + , raCoalesced = rmCoalesce + , raSpillStats = spillStats + , raSpillCosts = spillCosts + , raSpilled = code_spilled + , raPlatform = platform } + + -- Bundle up all the register allocator statistics. + -- .. but make sure to drop them on the floor if they're not + -- needed, otherwise we'll get a space leak. + let statList = + if dump + then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else [] + + -- Ensure all the statistics are evaluated, to avoid space leaks. + seqList statList (return ()) + + regAlloc_spin config (spinCount + 1) triv regsFree slotsFree' + slotsCount' statList code_relive cfg + + +-- | Build a graph from the liveness and coalesce information in this code. +buildGraph + :: Instruction instr + => Platform + -> [LiveCmmDecl statics instr] + -> UniqDSM (Color.Graph VirtualReg RegClass RealReg) + +buildGraph platform code + = do + -- Slurp out the conflicts and reg->reg moves from this code. + let (conflictList, moveList) = + unzip $ map (slurpConflicts platform) code + + -- Slurp out the spill/reload coalesces. + let moveList2 = map slurpReloadCoalesce code + + -- Add the reg-reg conflicts to the graph. + let conflictBag = unionManyBags conflictList + let graph_conflict + = foldr (graphAddConflictSet platform) Color.initGraph conflictBag + + -- Add the coalescences edges to the graph. + let moveBag + = unionBags (unionManyBags moveList2) + (unionManyBags moveList) + + let graph_coalesce + = foldr (graphAddCoalesce platform) graph_conflict moveBag + + return graph_coalesce + + +-- | Add some conflict edges to the graph. +-- Conflicts between virtual and real regs are recorded as exclusions. +graphAddConflictSet + :: Platform + -> UniqSet RegWithFormat + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg + +graphAddConflictSet platform regs graph + = let arch = platformArch platform + virtuals = takeVirtualRegs regs + reals = takeRealRegs regs + + graph1 = Color.addConflicts virtuals (classOfVirtualReg arch) graph + -- NB: we could add "arch" as argument to functions such as "addConflicts" + -- and "addExclusion" if it turns out that the partial application + -- "classOfVirtualReg arch" affects performance. + + graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 (classOfVirtualReg arch) r2) + graph1 + [ (vr, rr) + | vr <- nonDetEltsUniqSet virtuals + , rr <- nonDetEltsUniqSet reals ] + -- See Note [Unique Determinism and code generation] + + in graph2 + + +-- | Add some coalescence edges to the graph +-- Coalescences between virtual and real regs are recorded as preferences. +graphAddCoalesce + :: Platform + -> (Reg, Reg) + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg + +graphAddCoalesce platform (r1, r2) graph + | RegReal rr <- r1 + , RegVirtual vr <- r2 + = Color.addPreference (vr, classOfVirtualReg arch vr) rr graph + + | RegReal rr <- r2 + , RegVirtual vr <- r1 + = Color.addPreference (vr, classOfVirtualReg arch vr) rr graph + + | RegVirtual vr1 <- r1 + , RegVirtual vr2 <- r2 + = Color.addCoalesce + (vr1, classOfVirtualReg arch vr1) + (vr2, classOfVirtualReg arch vr2) + graph + + -- We can't coalesce two real regs, but there could well be existing + -- hreg,hreg moves in the input code. We'll just ignore these + -- for coalescing purposes. + | RegReal _ <- r1 + , RegReal _ <- r2 + = graph + where + arch = platformArch platform + + +-- | Patch registers in code using the reg -> reg mapping in this graph. +patchRegsFromGraph + :: (OutputableP Platform statics, Instruction instr) + => Platform -> Color.Graph VirtualReg RegClass RealReg + -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr + +patchRegsFromGraph platform graph code + = patchEraseLive platform patchF code + where + -- Function to lookup the hardreg for a virtual reg from the graph. + patchF reg + -- leave real regs alone. + | RegReal{} <- reg + = reg + + -- this virtual has a regular node in the graph. + | RegVirtual vr <- reg + , Just node <- Color.lookupNode graph vr + = case Color.nodeColor node of + Just color -> RegReal color + Nothing -> RegVirtual vr + + -- no node in the graph for this virtual, bad news. + | otherwise + = pprPanic "patchRegsFromGraph: register mapping failed." + ( text "There is no node in the graph for register " + <> ppr reg + $$ pprLiveCmmDecl platform code + $$ Color.dotGraph + (\_ -> text "white") + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + graph) + + +----- +-- for when laziness just isn't what you wanted... +-- We need to deepSeq the whole graph before trying to colour it to avoid +-- space leaks. +seqGraph :: Color.Graph VirtualReg RegClass RealReg -> () +seqGraph graph = seqNodes (nonDetEltsUFM (Color.graphMap graph)) + -- See Note [Unique Determinism and code generation] + +seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> () +seqNodes ns + = case ns of + [] -> () + (n : ns) -> seqNode n `seq` seqNodes ns + +seqNode :: Color.Node VirtualReg RegClass RealReg -> () +seqNode node + = seqVirtualReg (Color.nodeId node) + `seq` seqRegClass (Color.nodeClass node) + `seq` seqMaybeRealReg (Color.nodeColor node) + `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node))) + `seq` (seqRealRegList (nonDetEltsUniqSet (Color.nodeExclusions node))) + `seq` (seqRealRegList (Color.nodePreference node)) + `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node))) + -- It's OK to use nonDetEltsUniqSet for seq + +seqVirtualReg :: VirtualReg -> () +seqVirtualReg reg = reg `seq` () + +seqRealReg :: RealReg -> () +seqRealReg reg = reg `seq` () + +seqRegClass :: RegClass -> () +seqRegClass c = c `seq` () + +seqMaybeRealReg :: Maybe RealReg -> () +seqMaybeRealReg mr + = case mr of + Nothing -> () + Just r -> seqRealReg r + +seqVirtualRegList :: [VirtualReg] -> () +seqVirtualRegList rs + = case rs of + [] -> () + (r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs + +seqRealRegList :: [RealReg] -> () +seqRealRegList rs + = case rs of + [] -> () + (r : rs) -> seqRealReg r `seq` seqRealRegList rs diff --git a/GHC/CmmToAsm/Reg/Graph/Base.hs b/GHC/CmmToAsm/Reg/Graph/Base.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/Base.hs @@ -0,0 +1,165 @@ + +-- | Utils for calculating general worst, bound, squeese and free, functions. +-- +-- as per: "A Generalized Algorithm for Graph-Coloring Register Allocation" +-- Michael Smith, Normal Ramsey, Glenn Holloway. +-- PLDI 2004 +-- +-- These general versions are not used in GHC proper because they are too slow. +-- Instead, hand written optimised versions are provided for each architecture +-- in MachRegs*.hs +-- +-- This code is here because we can test the architecture specific code against +-- it. +-- +module GHC.CmmToAsm.Reg.Graph.Base ( + RegClass(..), + Reg(..), + RegSub(..), + + worst, + bound, + squeese +) where + +import GHC.Prelude + +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.Builtin.Uniques +import GHC.Utils.Monad (concatMapM) + +import Data.List.NonEmpty (NonEmpty (..)) + +-- Some basic register classes. +-- These aren't necessarily in 1-to-1 correspondence with the allocatable +-- RegClasses in MachRegs.hs +data RegClass + -- general purpose regs + = ClassG32 -- 32 bit GPRs + | ClassG16 -- 16 bit GPRs + | ClassG8 -- 8 bit GPRs + + -- floating point regs + | ClassF64 -- 64 bit FPRs + deriving (Show, Eq, Enum) + + +-- | A register of some class +data Reg + -- a register of some class + = Reg RegClass Int + + -- a sub-component of one of the other regs + | RegSub RegSub Reg + deriving (Show, Eq) + + +-- | so we can put regs in UniqSets +instance Uniquable Reg where + getUnique (Reg c i) + = mkRegSingleUnique + $ fromEnum c * 1000 + i + + getUnique (RegSub s (Reg c i)) + = mkRegSubUnique + $ fromEnum s * 10000 + fromEnum c * 1000 + i + + getUnique (RegSub _ (RegSub _ _)) + = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg." + + +-- | A subcomponent of another register +data RegSub + = SubL16 -- lowest 16 bits + | SubL8 -- lowest 8 bits + | SubL8H -- second lowest 8 bits + deriving (Show, Enum, Ord, Eq) + + +-- | Worst case displacement +-- +-- a node N of classN has some number of neighbors, +-- all of which are from classC. +-- +-- (worst neighbors classN classC) is the maximum number of potential +-- colors for N that can be lost by coloring its neighbors. +-- +-- This should be hand coded/cached for each particular architecture, +-- because the compute time is very long.. +worst :: (RegClass -> UniqSet Reg) + -> (Reg -> UniqSet Reg) + -> Int -> RegClass -> RegClass -> Int + +worst regsOfClass regAlias neighbors classN classC + = let regAliasS regs = unionManyUniqSets + $ map regAlias + $ nonDetEltsUniqSet regs + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + + -- all the regs in classes N, C + regsN = regsOfClass classN + regsC = regsOfClass classC + + -- all the possible subsets of c which have size < m + regsS = filter (\s -> not (isEmptyUniqSet s) + && sizeUniqSet s <= neighbors) + $ powersetLS regsC + + -- for each of the subsets of C, the regs which conflict + -- with possibilities for N + regsS_conflict + = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS + + in maximum $ 0 :| map sizeUniqSet regsS_conflict + + +-- | For a node N of classN and neighbors of classesC +-- (bound classN classesC) is the maximum number of potential +-- colors for N that can be lost by coloring its neighbors. +bound :: (RegClass -> UniqSet Reg) + -> (Reg -> UniqSet Reg) + -> RegClass -> [RegClass] -> Int + +bound regsOfClass regAlias classN classesC + = let regAliasS regs = unionManyUniqSets + $ map regAlias + $ nonDetEltsUFM regs + -- See Note [Unique Determinism and code generation] + + regsC_aliases + = unionManyUniqSets + $ map (regAliasS . getUniqSet . regsOfClass) classesC + + overlap = intersectUniqSets (regsOfClass classN) regsC_aliases + + in sizeUniqSet overlap + + +-- | The total squeese on a particular node with a list of neighbors. +-- +-- A version of this should be constructed for each particular architecture, +-- possibly including uses of bound, so that aliased registers don't get +-- counted twice, as per the paper. +squeese :: (RegClass -> UniqSet Reg) + -> (Reg -> UniqSet Reg) + -> RegClass -> [(Int, RegClass)] -> Int + +squeese regsOfClass regAlias classN countCs + = sum + $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC) + $ countCs + + +-- | powerset (for lists) +powersetL :: [a] -> [[a]] +powersetL = concatMapM (\x -> [[],[x]]) + + +-- | powersetLS (list of sets) +powersetLS :: Uniquable a => UniqSet a -> [UniqSet a] +powersetLS s = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s + -- See Note [Unique Determinism and code generation] diff --git a/GHC/CmmToAsm/Reg/Graph/Coalesce.hs b/GHC/CmmToAsm/Reg/Graph/Coalesce.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/Coalesce.hs @@ -0,0 +1,102 @@ +-- | Register coalescing. +module GHC.CmmToAsm.Reg.Graph.Coalesce ( + regCoalesce, + slurpJoinMovs +) where +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg + +import GHC.Cmm +import GHC.Data.Bag +import GHC.Data.Graph.Directed +import GHC.Platform (Platform) +import GHC.Types.Unique (getUnique) +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply +import GHC.Types.Unique.Set + +-- | Do register coalescing on this top level thing +-- +-- For Reg -> Reg moves, if the first reg dies at the same time the +-- second reg is born then the mov only serves to join live ranges. +-- The two regs can be renamed to be the same and the move instruction +-- safely erased. +regCoalesce + :: Instruction instr + => Platform + -> [LiveCmmDecl statics instr] + -> UniqSM [LiveCmmDecl statics instr] + +regCoalesce platform code + = do + let joins = foldl' unionBags emptyBag + $ map (slurpJoinMovs platform) code + + let alloc = foldl' buildAlloc emptyUFM + $ bagToList joins + + let patched = map (patchEraseLive platform (sinkReg alloc)) code + + return patched + + +-- | Add a v1 = v2 register renaming to the map. +-- The register with the lowest lexical name is set as the +-- canonical version. +buildAlloc :: UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg +buildAlloc fm (r1, r2) + = let rmin = min r1 r2 + rmax = max r1 r2 + in addToUFM fm rmax rmin + + +-- | Determine the canonical name for a register by following +-- v1 = v2 renamings in this map. +sinkReg :: UniqFM Reg Reg -> Reg -> Reg +sinkReg fm r + = case lookupUFM fm r of + Nothing -> r + Just r' -> sinkReg fm r' + + +-- | Slurp out mov instructions that only serve to join live ranges. +-- +-- During a mov, if the source reg dies and the destination reg is +-- born then we can rename the two regs to the same thing and +-- eliminate the move. +slurpJoinMovs + :: Instruction instr + => Platform + -> LiveCmmDecl statics instr + -> Bag (Reg, Reg) + +slurpJoinMovs platform live + = slurpCmm emptyBag live + where + slurpCmm rs CmmData{} + = rs + + slurpCmm rs (CmmProc _ _ _ sccs) + = foldl' slurpBlock rs (flattenSCCs sccs) + + slurpBlock rs (BasicBlock _ instrs) + = foldl' slurpLI rs instrs + + slurpLI rs (LiveInstr _ Nothing) = rs + slurpLI rs (LiveInstr instr (Just live)) + | Just (r1, r2) <- takeRegRegMoveInstr platform instr + , elemUniqSet_Directly (getUnique r1) $ liveDieRead live + , elemUniqSet_Directly (getUnique r2) $ liveBorn live + + -- only coalesce movs between two virtuals for now, + -- else we end up with allocatable regs in the live + -- regs list.. + , isVirtualReg r1 && isVirtualReg r2 + = consBag (r1, r2) rs + + | otherwise + = rs + diff --git a/GHC/CmmToAsm/Reg/Graph/Spill.hs b/GHC/CmmToAsm/Reg/Graph/Spill.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/Spill.hs @@ -0,0 +1,394 @@ +-- | When there aren't enough registers to hold all the vregs we have to spill +-- some of those vregs to slots on the stack. This module is used modify the +-- code to use those slots. +module GHC.CmmToAsm.Reg.Graph.Spill ( + regSpill, + SpillStats(..), + accSpillSL +) where + +import GHC.Prelude + +import GHC.CmmToAsm.Format ( RegWithFormat(..) ) +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Reg.Utils +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label + + +import GHC.Utils.Monad +import GHC.Utils.Monad.State.Strict +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSM +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform + +import Data.Function ( on ) +import Data.List (intersectBy, nubBy) +import Data.Maybe +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + + +-- | Spill all these virtual regs to stack slots. +-- +-- Bumps the number of required stack slots if required. +-- +-- +-- TODO: See if we can split some of the live ranges instead of just globally +-- spilling the virtual reg. This might make the spill cleaner's job easier. +-- +-- TODO: On CISCy x86 and x86_64 we don't necessarily have to add a mov instruction +-- when making spills. If an instr is using a spilled virtual we may be able to +-- address the spill slot directly. +-- +regSpill + :: Instruction instr + => Platform + -> [LiveCmmDecl statics instr] -- ^ the code + -> UniqSet Int -- ^ available stack slots + -> Int -- ^ current number of spill slots. + -> UniqSet VirtualReg -- ^ the regs to spill + -> UniqDSM + ([LiveCmmDecl statics instr] + -- code with SPILL and RELOAD meta instructions added. + , UniqSet Int -- left over slots + , Int -- slot count in use now. + , SpillStats ) -- stats about what happened during spilling + +regSpill platform code slotsFree slotCount regs + + -- Not enough slots to spill these regs. + | sizeUniqSet slotsFree < sizeUniqSet regs + = -- pprTrace "Bumping slot count:" (ppr slotCount <> text " -> " <> ppr (slotCount+512)) $ + let slotsFree' = (addListToUniqSet slotsFree [slotCount+1 .. slotCount+512]) + in regSpill platform code slotsFree' (slotCount+512) regs + + | otherwise + = do + -- Allocate a slot for each of the spilled regs. + let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree + let + regSlotMap = toRegMap -- Cast keys from VirtualReg to Reg + -- See Note [UniqFM and the register allocator] + $ listToUFM + $ zip (nonDetEltsUniqSet regs) slots :: UniqFM Reg Int + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + + -- Grab the unique supply from the monad. + UDSM $ \us -> + + -- Run the spiller on all the blocks. + let (code', state') = + runState (mapM (regSpill_top platform regSlotMap) code) + (initSpillS us) + + in DUniqResult + ( code' + , minusUniqSet slotsFree (mkUniqSet slots) + , slotCount + , makeSpillStats state') + ( stateUS state' ) + + + +-- | Spill some registers to stack slots in a top-level thing. +regSpill_top + :: Instruction instr + => Platform + -> RegMap Int + -- ^ map of vregs to slots they're being spilled to. + -> LiveCmmDecl statics instr + -- ^ the top level thing. + -> SpillM (LiveCmmDecl statics instr) + +regSpill_top platform regSlotMap cmm + = case cmm of + CmmData{} + -> return cmm + + CmmProc info label live sccs + | LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry <- info + -> do + -- The liveVRegsOnEntry contains the set of vregs that are live + -- on entry to each basic block. If we spill one of those vregs + -- we remove it from that set and add the corresponding slot + -- number to the liveSlotsOnEntry set. The spill cleaner needs + -- this information to erase unneeded spill and reload instructions + -- after we've done a successful allocation. + let liveSlotsOnEntry' :: BlockMap IntSet + liveSlotsOnEntry' + = mapFoldlWithKey patchLiveSlot + liveSlotsOnEntry liveVRegsOnEntry + + let info' + = LiveInfo static firstId + liveVRegsOnEntry + liveSlotsOnEntry' + + -- Apply the spiller to all the basic blocks in the CmmProc. + sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs + + return $ CmmProc info' label live sccs' + + where -- Given a BlockId and the set of registers live in it, + -- if registers in this block are being spilled to stack slots, + -- then record the fact that these slots are now live in those blocks + -- in the given slotmap. + patchLiveSlot + :: BlockMap IntSet -> BlockId -> UniqSet RegWithFormat-> BlockMap IntSet + + patchLiveSlot slotMap blockId regsLive + = let + -- Slots that are already recorded as being live. + curSlotsLive = fromMaybe IntSet.empty + $ mapLookup blockId slotMap + + moreSlotsLive = IntSet.fromList + $ mapMaybe (lookupUFM regSlotMap . regWithFormat_reg) + $ nonDetEltsUniqSet regsLive + -- See Note [Unique Determinism and code generation] + + slotMap' + = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive) + slotMap + + in slotMap' + + +-- | Spill some registers to stack slots in a basic block. +regSpill_block + :: Instruction instr + => Platform + -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to. + -> LiveBasicBlock instr + -> SpillM (LiveBasicBlock instr) + +regSpill_block platform regSlotMap (BasicBlock i instrs) + = do instrss' <- mapM (regSpill_instr platform regSlotMap) instrs + return $ BasicBlock i (concat instrss') + + +-- | Spill some registers to stack slots in a single instruction. +-- If the instruction uses registers that need to be spilled, then it is +-- prefixed (or postfixed) with the appropriate RELOAD or SPILL meta +-- instructions. +regSpill_instr + :: Instruction instr + => Platform + -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to. + -> LiveInstr instr + -> SpillM [LiveInstr instr] +regSpill_instr _ _ li@(LiveInstr _ Nothing) = return [li] +regSpill_instr platform regSlotMap (LiveInstr instr (Just _)) = do + -- work out which regs are read and written in this instr + let RU rlRead rlWritten = regUsageOfInstr platform instr + + -- sometimes a register is listed as being read more than once, + -- nub this so we don't end up inserting two lots of spill code. + let rsRead_ = nubBy ((==) `on` getUnique) rlRead + rsWritten_ = nubBy ((==) `on` getUnique) rlWritten + + -- if a reg is modified, it appears in both lists, want to undo this.. + let rsModify = intersectBy ((==) `on` getUnique) rsRead_ rsWritten_ + modified = mkUniqSet rsModify + rsRead = filter (\ r -> not $ elementOfUniqSet r modified) rsRead_ + rsWritten = filter (\ r -> not $ elementOfUniqSet r modified) rsWritten_ + + + -- work out if any of the regs being used are currently being spilled. + let rsSpillRead = filter (\r -> elemUFM (regWithFormat_reg r) regSlotMap) rsRead + let rsSpillWritten = filter (\r -> elemUFM (regWithFormat_reg r) regSlotMap) rsWritten + let rsSpillModify = filter (\r -> elemUFM (regWithFormat_reg r) regSlotMap) rsModify + + -- rewrite the instr and work out spill code. + (instr1, prepost1) <- mapAccumLM (spillRead platform regSlotMap) instr rsSpillRead + (instr2, prepost2) <- mapAccumLM (spillWrite platform regSlotMap) instr1 rsSpillWritten + (instr3, prepost3) <- mapAccumLM (spillModify platform regSlotMap) instr2 rsSpillModify + + let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3) + let prefixes = concat mPrefixes + let postfixes = concat mPostfixes + + -- final code + let instrs' = prefixes + ++ [LiveInstr instr3 Nothing] + ++ postfixes + + return instrs' + + +-- | Add a RELOAD met a instruction to load a value for an instruction that +-- writes to a vreg that is being spilled. +spillRead + :: Instruction instr + => Platform + -> UniqFM Reg Int + -> instr + -> RegWithFormat + -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) + +spillRead platform regSlotMap instr (RegWithFormat reg fmt) + | Just slot <- lookupUFM regSlotMap reg + = do (instr', nReg) <- patchInstr platform reg instr + + modify $ \s -> s + { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) } + + return ( instr' + , ( [LiveInstr (RELOAD slot (RegWithFormat nReg fmt)) Nothing] + , []) ) + + | otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg" + + +-- | Add a SPILL meta instruction to store a value for an instruction that +-- writes to a vreg that is being spilled. +spillWrite + :: Instruction instr + => Platform + -> UniqFM Reg Int + -> instr + -> RegWithFormat + -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) + +spillWrite platform regSlotMap instr (RegWithFormat reg fmt) + | Just slot <- lookupUFM regSlotMap reg + = do (instr', nReg) <- patchInstr platform reg instr + + modify $ \s -> s + { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) } + + return ( instr' + , ( [] + , [LiveInstr (SPILL (RegWithFormat nReg fmt) slot) Nothing])) + + | otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg" + + +-- | Add both RELOAD and SPILL meta instructions for an instruction that +-- both reads and writes to a vreg that is being spilled. +spillModify + :: Instruction instr + => Platform + -> UniqFM Reg Int + -> instr + -> RegWithFormat + -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) + +spillModify platform regSlotMap instr (RegWithFormat reg fmt) + | Just slot <- lookupUFM regSlotMap reg + = do (instr', nReg) <- patchInstr platform reg instr + + modify $ \s -> s + { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) } + + return ( instr' + , ( [LiveInstr (RELOAD slot (RegWithFormat nReg fmt)) Nothing] + , [LiveInstr (SPILL (RegWithFormat nReg fmt) slot) Nothing])) + + | otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg" + + +-- | Rewrite uses of this virtual reg in an instr to use a different +-- virtual reg. +patchInstr + :: Instruction instr + => Platform -> Reg -> instr -> SpillM (instr, Reg) + +patchInstr platform reg instr + = do nUnique <- newUnique + + -- The register we're rewriting is supposed to be virtual. + -- If it's not then something has gone horribly wrong. + let nReg + = case reg of + RegVirtual vr + -> RegVirtual (renameVirtualReg nUnique vr) + + RegReal{} + -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg" + + let instr' = patchReg1 platform reg nReg instr + return (instr', nReg) + + +patchReg1 + :: Instruction instr + => Platform -> Reg -> Reg -> instr -> instr + +patchReg1 platform old new instr + = let patchF r + | r == old = new + | otherwise = r + in patchRegsOfInstr platform instr patchF + + +-- Spiller monad -------------------------------------------------------------- +-- | State monad for the spill code generator. +type SpillM = State SpillS + +-- | Spill code generator state. +data SpillS + = SpillS + { -- | Unique supply for generating fresh vregs. + stateUS :: DUniqSupply + + -- | Spilled vreg vs the number of times it was loaded, stored. + , stateSpillSL :: UniqFM Reg (Reg, Int, Int) } + +instance MonadGetUnique SpillM where + getUniqueM = do + us <- gets stateUS + case takeUniqueFromDSupply us of + (uniq, us') + -> do modify $ \s -> s { stateUS = us' } + return uniq + + +-- | Create a new spiller state. +initSpillS :: DUniqSupply -> SpillS +initSpillS uniqueSupply + = SpillS + { stateUS = uniqueSupply + , stateSpillSL = emptyUFM } + + +-- | Allocate a new unique in the spiller monad. +newUnique :: SpillM Unique +newUnique = getUniqueM + + +-- | Add a spill/reload count to a stats record for a register. +accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int) +accSpillSL (r1, s1, l1) (_, s2, l2) + = (r1, s1 + s2, l1 + l2) + + +-- Spiller stats -------------------------------------------------------------- +-- | Spiller statistics. +-- Tells us what registers were spilled. +data SpillStats + = SpillStats + { spillStoreLoad :: UniqFM Reg (Reg, Int, Int) } + + +-- | Extract spiller statistics from the spiller state. +makeSpillStats :: SpillS -> SpillStats +makeSpillStats s + = SpillStats + { spillStoreLoad = stateSpillSL s } + + +instance Outputable SpillStats where + ppr stats + = pprUFM (spillStoreLoad stats) + (vcat . map (\(r, s, l) -> ppr r <+> int s <+> int l)) diff --git a/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/GHC/CmmToAsm/Reg/Graph/SpillClean.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/SpillClean.hs @@ -0,0 +1,609 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Clean out unneeded spill\/reload instructions. +-- +-- Handling of join points +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- @ +-- B1: B2: +-- ... ... +-- RELOAD SLOT(0), %r1 RELOAD SLOT(0), %r1 +-- ... A ... ... B ... +-- jump B3 jump B3 +-- +-- B3: ... C ... +-- RELOAD SLOT(0), %r1 +-- ... +-- @ +-- +-- The Plan +-- ~~~~~~~~ +-- +-- As long as %r1 hasn't been written to in A, B or C then we don't need +-- the reload in B3. +-- +-- What we really care about here is that on the entry to B3, %r1 will +-- always have the same value that is in SLOT(0) (ie, %r1 is _valid_) +-- +-- This also works if the reloads in B1\/B2 were spills instead, because +-- spilling %r1 to a slot makes that slot have the same value as %r1. +-- +module GHC.CmmToAsm.Reg.Graph.SpillClean ( + cleanSpills +) where +import GHC.Prelude + +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg + +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.Builtin.Uniques +import GHC.Utils.Misc +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Cmm.Dataflow.Label + +import Data.List (nub, find) +import Data.Maybe +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + + + +-- | The identification number of a spill slot. +-- A value is stored in a spill slot when we don't have a free +-- register to hold it. +type Slot = Int + + +-- | Clean out unneeded spill\/reloads from this top level thing. +cleanSpills + :: Instruction instr + => NCGConfig + -> LiveCmmDecl statics instr + -> LiveCmmDecl statics instr + +cleanSpills config cmm + = evalState (cleanSpin config 0 cmm) initCleanS + + +-- | Do one pass of cleaning. +cleanSpin + :: Instruction instr + => NCGConfig + -> Int -- ^ Iteration number for the cleaner. + -> LiveCmmDecl statics instr -- ^ Liveness annotated code to clean. + -> CleanM (LiveCmmDecl statics instr) + +cleanSpin config spinCount code + = do + -- Initialise count of cleaned spill and reload instructions. + modify $ \s -> s + { sCleanedSpillsAcc = 0 + , sCleanedReloadsAcc = 0 + , sReloadedBy = emptyUFM } + + code_forward <- mapBlockTopM (cleanBlockForward config) code + code_backward <- cleanTopBackward code_forward + + -- During the cleaning of each block we collected information about + -- what regs were valid across each jump. Based on this, work out + -- whether it will be safe to erase reloads after join points for + -- the next pass. + collateJoinPoints + + -- Remember how many spill and reload instructions we cleaned in this pass. + spills <- gets sCleanedSpillsAcc + reloads <- gets sCleanedReloadsAcc + modify $ \s -> s + { sCleanedCount = (spills, reloads) : sCleanedCount s } + + -- If nothing was cleaned in this pass or the last one + -- then we're done and it's time to bail out. + cleanedCount <- gets sCleanedCount + if take 2 cleanedCount == [(0, 0), (0, 0)] + then return code + + -- otherwise go around again + else cleanSpin config (spinCount + 1) code_backward + + +------------------------------------------------------------------------------- +-- | Clean out unneeded reload instructions, +-- while walking forward over the code. +cleanBlockForward + :: Instruction instr + => NCGConfig + -> LiveBasicBlock instr + -> CleanM (LiveBasicBlock instr) + +cleanBlockForward config (BasicBlock blockId instrs) + = do + -- See if we have a valid association for the entry to this block. + jumpValid <- gets sJumpValid + let assoc = case lookupUFM jumpValid blockId of + Just assoc -> assoc + Nothing -> emptyAssoc + + instrs_reload <- cleanForward config blockId assoc [] instrs + return $ BasicBlock blockId instrs_reload + + + +-- | Clean out unneeded reload instructions. +-- +-- Walking forwards across the code +-- On a reload, if we know a reg already has the same value as a slot +-- then we don't need to do the reload. +-- +cleanForward + :: Instruction instr + => NCGConfig + -> BlockId -- ^ the block that we're currently in + -> Assoc Store -- ^ two store locations are associated if + -- they have the same value + -> [LiveInstr instr] -- ^ acc + -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) + -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) + +cleanForward _ _ _ acc [] + = return acc + +-- Rewrite live range joins via spill slots to just a spill and a reg-reg move +-- hopefully the spill will be also be cleaned in the next pass +cleanForward config blockId assoc acc (li1 : li2 : instrs) + | LiveInstr (SPILL reg1 slot1) _ <- li1 + , LiveInstr (RELOAD slot2 reg2) _ <- li2 + , slot1 == slot2 + = do + modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } + cleanForward config blockId assoc acc + $ li1 : LiveInstr (mkRegRegMoveInstr config (regWithFormat_format reg2) (regWithFormat_reg reg1) (regWithFormat_reg reg2)) Nothing + : instrs + +cleanForward config blockId assoc acc (li@(LiveInstr i1 _) : instrs) + | Just (r1, r2) <- takeRegRegMoveInstr (ncgPlatform config) i1 + = if r1 == r2 + -- Erase any left over nop reg reg moves while we're here + -- this will also catch any nop moves that the previous case + -- happens to add. + then cleanForward config blockId assoc acc instrs + + -- If r1 has the same value as some slots and we copy r1 to r2, + -- then r2 is now associated with those slots instead + else do let assoc' = addAssoc (SReg r1) (SReg r2) + $ delAssoc (SReg r2) + $ assoc + + cleanForward config blockId assoc' (li : acc) instrs + + +cleanForward config blockId assoc acc (li : instrs) + + -- Update association due to the spill. + | LiveInstr (SPILL reg slot) _ <- li + = let assoc' = addAssoc (SReg $ regWithFormat_reg reg) (SSlot slot) + $ delAssoc (SSlot slot) + $ assoc + in cleanForward config blockId assoc' (li : acc) instrs + + -- Clean a reload instr. + | LiveInstr (RELOAD{}) _ <- li + = do (assoc', mli) <- cleanReload config blockId assoc li + case mli of + Nothing -> cleanForward config blockId assoc' acc + instrs + + Just li' -> cleanForward config blockId assoc' (li' : acc) + instrs + + -- Remember the association over a jump. + | LiveInstr instr _ <- li + , targets <- jumpDestsOfInstr instr + , not $ null targets + = do mapM_ (accJumpValid assoc) targets + cleanForward config blockId assoc (li : acc) instrs + + -- Writing to a reg changes its value. + | LiveInstr instr _ <- li + , RU _ written <- regUsageOfInstr (ncgPlatform config) instr + = let assoc' = foldr delAssoc assoc (map SReg $ nub $ map regWithFormat_reg written) + in cleanForward config blockId assoc' (li : acc) instrs + + + +-- | Try and rewrite a reload instruction to something more pleasing +cleanReload + :: Instruction instr + => NCGConfig + -> BlockId + -> Assoc Store + -> LiveInstr instr + -> CleanM (Assoc Store, Maybe (LiveInstr instr)) + +cleanReload config blockId assoc li@(LiveInstr (RELOAD slot (RegWithFormat reg fmt)) _) + + -- If the reg we're reloading already has the same value as the slot + -- then we can erase the instruction outright. + | elemAssoc (SSlot slot) (SReg reg) assoc + = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } + return (assoc, Nothing) + + -- If we can find another reg with the same value as this slot then + -- do a move instead of a reload. + | Just reg2 <- findRegOfSlot assoc slot + = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } + + let assoc' = addAssoc (SReg reg) (SReg reg2) + $ delAssoc (SReg reg) + $ assoc + + return ( assoc' + , Just $ LiveInstr (mkRegRegMoveInstr config fmt reg2 reg) Nothing ) + + -- Gotta keep this instr. + | otherwise + = do -- Update the association. + let assoc' + = addAssoc (SReg reg) (SSlot slot) + -- doing the reload makes reg and slot the same value + $ delAssoc (SReg reg) + -- reg value changes on reload + $ assoc + + -- Remember that this block reloads from this slot. + accBlockReloadsSlot blockId slot + + return (assoc', Just li) + +cleanReload _ _ _ _ + = panic "RegSpillClean.cleanReload: unhandled instr" + + +------------------------------------------------------------------------------- +-- | Clean out unneeded spill instructions, +-- while walking backwards over the code. +-- +-- If there were no reloads from a slot between a spill and the last one +-- then the slot was never read and we don't need the spill. +-- +-- SPILL r0 -> s1 +-- RELOAD s1 -> r2 +-- SPILL r3 -> s1 <--- don't need this spill +-- SPILL r4 -> s1 +-- RELOAD s1 -> r5 +-- +-- Maintain a set of +-- "slots which were spilled to but not reloaded from yet" +-- +-- Walking backwards across the code: +-- a) On a reload from a slot, remove it from the set. +-- +-- a) On a spill from a slot +-- If the slot is in set then we can erase the spill, +-- because it won't be reloaded from until after the next spill. +-- +-- otherwise +-- keep the spill and add the slot to the set +-- +-- TODO: This is mostly inter-block +-- we should really be updating the noReloads set as we cross jumps also. +-- +-- TODO: generate noReloads from liveSlotsOnEntry +-- +cleanTopBackward + :: Instruction instr + => LiveCmmDecl statics instr + -> CleanM (LiveCmmDecl statics instr) + +cleanTopBackward cmm + = case cmm of + CmmData{} + -> return cmm + + CmmProc info label live sccs + | LiveInfo _ _ _ liveSlotsOnEntry <- info + -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs + return $ CmmProc info label live sccs' + + +cleanBlockBackward + :: Instruction instr + => BlockMap IntSet + -> LiveBasicBlock instr + -> CleanM (LiveBasicBlock instr) + +cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs) + = do instrs_spill <- cleanBackward liveSlotsOnEntry emptyUniqSet [] instrs + return $ BasicBlock blockId instrs_spill + + + +cleanBackward + :: Instruction instr + => BlockMap IntSet -- ^ Slots live on entry to each block + -> UniqSet Int -- ^ Slots that have been spilled, but not reloaded from + -> [LiveInstr instr] -- ^ acc + -> [LiveInstr instr] -- ^ Instrs to clean (in forwards order) + -> CleanM [LiveInstr instr] -- ^ Cleaned instrs (in backwards order) + +cleanBackward liveSlotsOnEntry noReloads acc lis + = do reloadedBy <- gets sReloadedBy + cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis + + +cleanBackward' + :: Instruction instr + => BlockMap IntSet + -> UniqFM Store [BlockId] + -> UniqSet Int + -> [LiveInstr instr] + -> [LiveInstr instr] + -> State CleanS [LiveInstr instr] + +cleanBackward' _ _ _ acc [] + = return acc + +cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs) + + -- If nothing ever reloads from this slot then we don't need the spill. + | LiveInstr (SPILL _ slot) _ <- li + , Nothing <- lookupUFM reloadedBy (SSlot slot) + = do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } + cleanBackward liveSlotsOnEntry noReloads acc instrs + + | LiveInstr (SPILL _ slot) _ <- li + = if elementOfUniqSet slot noReloads + + -- We can erase this spill because the slot won't be read until + -- after the next one + then do + modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } + cleanBackward liveSlotsOnEntry noReloads acc instrs + + else do + -- This slot is being spilled to, but we haven't seen any reloads yet. + let noReloads' = addOneToUniqSet noReloads slot + cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs + + -- if we reload from a slot then it's no longer unused + | LiveInstr (RELOAD slot _) _ <- li + , noReloads' <- delOneFromUniqSet noReloads slot + = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs + + -- If a slot is live in a jump target then assume it's reloaded there. + -- + -- TODO: A real dataflow analysis would do a better job here. + -- If the target block _ever_ used the slot then we assume + -- it always does, but if those reloads are cleaned the slot + -- liveness map doesn't get updated. + | LiveInstr instr _ <- li + , targets <- jumpDestsOfInstr instr + = do + let slotsReloadedByTargets + = IntSet.unions + $ mapMaybe (flip mapLookup liveSlotsOnEntry) + $ targets + + let noReloads' + = foldl' delOneFromUniqSet noReloads + $ IntSet.toList slotsReloadedByTargets + + cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs + + +-- | Combine the associations from all the inward control flow edges. +-- +collateJoinPoints :: CleanM () +collateJoinPoints + = modify $ \s -> s + { sJumpValid = mapUFM intersects (sJumpValidAcc s) + , sJumpValidAcc = emptyUFM } + +intersects :: [Assoc Store] -> Assoc Store +intersects = foldl1WithDefault' emptyAssoc intersectAssoc + + +-- | See if we have a reg with the same value as this slot in the association table. +findRegOfSlot :: Assoc Store -> Int -> Maybe Reg +findRegOfSlot assoc slot + | close <- closeAssoc (SSlot slot) assoc + , Just (SReg reg) <- find isStoreReg $ nonDetEltsUniqSet close + -- See Note [Unique Determinism and code generation] + = Just reg + + | otherwise + = Nothing + + +------------------------------------------------------------------------------- +-- | Cleaner monad. +type CleanM + = State CleanS + +-- | Cleaner state. +data CleanS + = CleanS + { -- | Regs which are valid at the start of each block. + sJumpValid :: UniqFM BlockId (Assoc Store) + + -- | Collecting up what regs were valid across each jump. + -- in the next pass we can collate these and write the results + -- to sJumpValid. + , sJumpValidAcc :: UniqFM BlockId [Assoc Store] + + -- | Map of (slot -> blocks which reload from this slot) + -- used to decide if whether slot spilled to will ever be + -- reloaded from on this path. + , sReloadedBy :: UniqFM Store [BlockId] + + -- | Spills and reloads cleaned each pass (latest at front) + , sCleanedCount :: [(Int, Int)] + + -- | Spills and reloads that have been cleaned in this pass so far. + , sCleanedSpillsAcc :: Int + , sCleanedReloadsAcc :: Int } + + +-- | Construct the initial cleaner state. +initCleanS :: CleanS +initCleanS + = CleanS + { sJumpValid = emptyUFM + , sJumpValidAcc = emptyUFM + + , sReloadedBy = emptyUFM + + , sCleanedCount = [] + + , sCleanedSpillsAcc = 0 + , sCleanedReloadsAcc = 0 } + + +-- | Remember the associations before a jump. +accJumpValid :: Assoc Store -> BlockId -> CleanM () +accJumpValid assocs target + = modify $ \s -> s { + sJumpValidAcc = addToUFM_C (++) + (sJumpValidAcc s) + target + [assocs] } + + +accBlockReloadsSlot :: BlockId -> Slot -> CleanM () +accBlockReloadsSlot blockId slot + = modify $ \s -> s { + sReloadedBy = addToUFM_C (++) + (sReloadedBy s) + (SSlot slot) + [blockId] } + + +------------------------------------------------------------------------------- +-- A store location can be a stack slot or a register +data Store + = SSlot Int + | SReg Reg + + +-- | Check if this is a reg store. +isStoreReg :: Store -> Bool +isStoreReg ss + = case ss of + SSlot _ -> False + SReg _ -> True + + +-- Spill cleaning is only done once all virtuals have been allocated to realRegs +instance Uniquable Store where + getUnique (SReg r) + | RegReal (RealRegSingle i) <- r + = mkRegSingleUnique i + + | otherwise + = error $ "RegSpillClean.getUnique: found virtual reg during spill clean," + ++ "only real regs expected." + + getUnique (SSlot i) = mkRegSubUnique i -- [SLPJ] I hope "SubUnique" is ok + + +instance Outputable Store where + ppr (SSlot i) = text "slot" <> int i + ppr (SReg r) = ppr r + + +------------------------------------------------------------------------------- +-- Association graphs. +-- In the spill cleaner, two store locations are associated if they are known +-- to hold the same value. +-- +-- TODO: Monomorphize: I think we only ever use this with a ~ Store +type Assoc a = UniqFM a (UniqSet a) + +-- | An empty association +emptyAssoc :: Assoc a +emptyAssoc = emptyUFM + + +-- | Add an association between these two things. +-- addAssoc :: Uniquable a +-- => a -> a -> Assoc a -> Assoc a +addAssoc :: Store -> Store -> Assoc Store -> Assoc Store + +addAssoc a b m + = let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b) + m2 = addToUFM_C unionUniqSets m1 b (unitUniqSet a) + in m2 + + +-- | Delete all associations to a node. +delAssoc :: Store -> Assoc Store -> Assoc Store +delAssoc a m + | Just aSet <- lookupUFM m a + , m1 <- delFromUFM m a + = nonDetStrictFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet + -- It's OK to use a non-deterministic fold here because deletion is + -- commutative + + | otherwise = m + + +-- | Delete a single association edge (a -> b). +delAssoc1 :: Store -> Store -> Assoc Store -> Assoc Store +delAssoc1 a b m + | Just aSet <- lookupUFM m a + = addToUFM m a (delOneFromUniqSet aSet b) + + | otherwise = m + + +-- | Check if these two things are associated. +elemAssoc :: Store -> Store -> Assoc Store -> Bool + +elemAssoc a b m + = elementOfUniqSet b (closeAssoc a m) + + +-- | Find the refl. trans. closure of the association from this point. +closeAssoc :: Store -> Assoc Store -> UniqSet Store +closeAssoc a assoc + = closeAssoc' assoc emptyUniqSet (unitUniqSet a) + where + closeAssoc' assoc visited toVisit + = case nonDetEltsUniqSet toVisit of + -- See Note [Unique Determinism and code generation] + + -- nothing else to visit, we're done + [] -> visited + + (x:_) + -- we've already seen this node + | elementOfUniqSet x visited + -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x) + + -- haven't seen this node before, + -- remember to visit all its neighbors + | otherwise + -> let neighbors + = case lookupUFM assoc x of + Nothing -> emptyUniqSet + Just set -> set + + in closeAssoc' assoc + (addOneToUniqSet visited x) + (unionUniqSets toVisit neighbors) + +-- | Intersect two associations. +intersectAssoc :: Assoc Store -> Assoc Store -> Assoc Store +intersectAssoc a b + = intersectUFM_C (intersectUniqSets) a b diff --git a/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/GHC/CmmToAsm/Reg/Graph/SpillCost.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/SpillCost.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.CmmToAsm.Reg.Graph.SpillCost ( + SpillCostRecord, + plusSpillCostRecord, + pprSpillCostRecord, + + SpillCostInfo, + zeroSpillCostInfo, + plusSpillCostInfo, + + slurpSpillCostInfo, + chooseSpill, + + lifeMapFromSpillCostInfo +) where +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg.Class +import GHC.Platform.Reg + +import GHC.Data.Graph.Base + +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Data.Graph.Directed (flattenSCCs) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform +import GHC.Utils.Monad.State.Strict +import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.Format +import GHC.Utils.Misc + +import Data.List (nub) +import Data.Maybe +import Control.Monad (join) + + +-- | Records the expected cost to spill some register. +type SpillCostRecord + = ( VirtualReg -- register name + , Int -- number of writes to this reg + , Int -- number of reads from this reg + , Int) -- number of instrs this reg was live on entry to + + +-- | Map of `SpillCostRecord` +type SpillCostInfo + = UniqFM VirtualReg SpillCostRecord + +type SpillCostState = State SpillCostInfo () + +-- | An empty map of spill costs. +zeroSpillCostInfo :: SpillCostInfo +zeroSpillCostInfo = emptyUFM + + +-- | Add two spill cost infos. +plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo +plusSpillCostInfo sc1 sc2 + = plusUFM_C plusSpillCostRecord sc1 sc2 + + +-- | Add two spill cost records. +plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord +plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) + | r1 == r2 = (r1, a1 + a2, b1 + b2, c1 + c2) + | otherwise = error "RegSpillCost.plusRegInt: regs don't match" + + +-- | Slurp out information used for determining spill costs. +-- +-- For each vreg, the number of times it was written to, read from, +-- and the number of instructions it was live on entry to (lifetime) +-- +slurpSpillCostInfo :: forall instr statics. Instruction instr + => Platform + -> Maybe CFG + -> LiveCmmDecl statics instr + -> SpillCostInfo + +slurpSpillCostInfo platform cfg cmm + = execState (countCmm cmm) zeroSpillCostInfo + where + countCmm CmmData{} = return () + countCmm (CmmProc info _ _ sccs) + = mapM_ (countBlock info freqMap) + $ flattenSCCs sccs + where + LiveInfo _ entries _ _ = info + freqMap = (fst . mkGlobalWeights (head entries)) <$> cfg + + -- Lookup the regs that are live on entry to this block in + -- the info table from the CmmProc. + countBlock info freqMap (BasicBlock blockId instrs) + | LiveInfo _ _ blockLive _ <- info + , Just rsLiveEntry <- mapLookup blockId blockLive + , rsLiveEntry_virt <- takeVirtualRegs rsLiveEntry + = countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs + + | otherwise + = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block" + + + countLIs :: Int -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState + countLIs _ _ [] + = return () + + -- Skip over comment and delta pseudo instrs. + countLIs scale rsLive (LiveInstr instr Nothing : lis) + | isMetaInstr instr + = countLIs scale rsLive lis + + | otherwise + = pprPanic "RegSpillCost.slurpSpillCostInfo" + $ text "no liveness information on instruction " <> pprInstr platform instr + + countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis) + = do + -- Increment the lifetime counts for regs live on entry to this instr. + mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + + -- Increment counts for what regs were read/written from. + let (RU read written) = regUsageOfInstr platform instr + mapM_ (incUses scale) $ nub $ mapMaybe (takeVirtualReg . regWithFormat_reg) read + mapM_ (incDefs scale) $ nub $ mapMaybe (takeVirtualReg . regWithFormat_reg) written + + -- Compute liveness for entry to next instruction. + let liveDieRead_virt = takeVirtualRegs (liveDieRead live) + let liveDieWrite_virt = takeVirtualRegs (liveDieWrite live) + let liveBorn_virt = takeVirtualRegs (liveBorn live) + + let rsLiveAcross + = rsLiveEntry `minusUniqSet` liveDieRead_virt + + let rsLiveNext + = (rsLiveAcross `unionUniqSets` liveBorn_virt) + `minusUniqSet` liveDieWrite_virt + + countLIs scale rsLiveNext lis + + incDefs count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0) + incUses count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0) + incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1) + + blockFreq :: Maybe (LabelMap Double) -> Label -> Double + blockFreq freqs bid + | Just freq <- join (mapLookup bid <$> freqs) + = max 1.0 (10000 * freq) + | otherwise + = 1.0 -- Only if no cfg given + +-- | Choose a node to spill from this graph +chooseSpill + :: SpillCostInfo + -> Graph VirtualReg RegClass RealReg + -> VirtualReg + +chooseSpill info graph + = let cost = spillCost_length info graph + node = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2)) + $ expectNonEmpty $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + in nodeId node + + +------------------------------------------------------------------------------- +-- | Chaitins spill cost function is: +-- +-- cost = sum loadCost * freq (u) + sum storeCost * freq (d) +-- u <- uses (v) d <- defs (v) +-- +-- There are no loops in our code at the moment, so we can set the freq's to 1. +-- +-- If we don't have live range splitting then Chaitins function performs badly +-- if we have lots of nested live ranges and very few registers. +-- +-- v1 v2 v3 +-- def v1 . +-- use v1 . +-- def v2 . . +-- def v3 . . . +-- use v1 . . . +-- use v3 . . . +-- use v2 . . +-- use v1 . +-- +-- defs uses degree cost +-- v1: 1 3 3 1.5 +-- v2: 1 2 3 1.0 +-- v3: 1 1 3 0.666 +-- +-- v3 has the lowest cost, but if we only have 2 hardregs and we insert +-- spill code for v3 then this isn't going to improve the colorability of +-- the graph. +-- +-- When compiling SHA1, which as very long basic blocks and some vregs +-- with very long live ranges the allocator seems to try and spill from +-- the inside out and eventually run out of stack slots. +-- +-- Without live range splitting, its's better to spill from the outside +-- in so set the cost of very long live ranges to zero +-- + +-- spillCost_chaitin +-- :: SpillCostInfo +-- -> Graph VirtualReg RegClass RealReg +-- -> VirtualReg +-- -> Float + +-- spillCost_chaitin info graph reg +-- -- Spilling a live range that only lives for 1 instruction +-- -- isn't going to help us at all - and we definitely want to avoid +-- -- trying to re-spill previously inserted spill code. +-- | lifetime <= 1 = 1/0 + +-- -- It's unlikely that we'll find a reg for a live range this long +-- -- better to spill it straight up and not risk trying to keep it around +-- -- and have to go through the build/color cycle again. + +-- -- To facility this we scale down the spill cost of long ranges. +-- -- This makes sure long ranges are still spilled first. +-- -- But this way spill cost remains relevant for long live +-- -- ranges. +-- | lifetime >= 128 +-- = (spillCost / conflicts) / 10.0 + + +-- -- Otherwise revert to chaitin's regular cost function. +-- | otherwise = (spillCost / conflicts) +-- where +-- !spillCost = fromIntegral (uses + defs) :: Float +-- conflicts = fromIntegral (nodeDegree classOfVirtualReg graph reg) +-- (_, defs, uses, lifetime) +-- = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg + + +-- Just spill the longest live range. +spillCost_length + :: SpillCostInfo + -> Graph VirtualReg RegClass RealReg + -> VirtualReg + -> Float + +spillCost_length info _ reg + | lifetime <= 1 = 1/0 + | otherwise = 1 / fromIntegral lifetime + where (_, _, _, lifetime) + = fromMaybe (reg, 0, 0, 0) + $ lookupUFM info reg + + +-- | Extract a map of register lifetimes from a `SpillCostInfo`. +lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM VirtualReg (VirtualReg, Int) +lifeMapFromSpillCostInfo info + = listToUFM + $ map (\(r, _, _, life) -> (r, (r, life))) + $ nonDetEltsUFM info + -- See Note [Unique Determinism and code generation] + + +-- | Determine the degree (number of neighbors) of this node which +-- have the same class. +nodeDegree + :: (VirtualReg -> RegClass) + -> Graph VirtualReg RegClass RealReg + -> VirtualReg + -> Int + +nodeDegree classOfVirtualReg graph reg + | Just node <- lookupUFM (graphMap graph) reg + + , virtConflicts + <- length + $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg) + $ nonDetEltsUniqSet + -- See Note [Unique Determinism and code generation] + $ nodeConflicts node + + = virtConflicts + sizeUniqSet (nodeExclusions node) + + | otherwise + = 0 + + +-- | Show a spill cost record, including the degree from the graph +-- and final calculated spill cost. +pprSpillCostRecord + :: (VirtualReg -> RegClass) + -> (Reg -> SDoc) + -> Graph VirtualReg RegClass RealReg + -> SpillCostRecord + -> SDoc + +pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life) + = hsep + [ pprReg (RegVirtual reg) + , ppr uses + , ppr defs + , ppr life + , ppr $ nodeDegree regClass graph reg + , text $ show $ (fromIntegral (uses + defs) + / fromIntegral (nodeDegree regClass graph reg) :: Float) ] + diff --git a/GHC/CmmToAsm/Reg/Graph/Stats.hs b/GHC/CmmToAsm/Reg/Graph/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/Stats.hs @@ -0,0 +1,358 @@ +-- | Carries interesting info for debugging / profiling of the +-- graph coloring register allocator. +module GHC.CmmToAsm.Reg.Graph.Stats ( + RegAllocStats (..), + + pprStats, + pprStatsSpills, + pprStatsLifetimes, + pprStatsConflict, + pprStatsLifeConflict, + + countSRMs, addSRM +) where + +import GHC.Prelude + +import qualified GHC.Data.Graph.Color as Color +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Reg.Graph.Spill +import GHC.CmmToAsm.Reg.Graph.SpillCost +import GHC.CmmToAsm.Reg.Graph.TrivColorable +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Types + +import GHC.Platform +import GHC.Platform.Reg +import GHC.Platform.Reg.Class + +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Outputable +import GHC.Utils.Monad.State.Strict + +-- | Holds interesting statistics from the register allocator. +data RegAllocStats statics instr + + -- Information about the initial conflict graph. + = RegAllocStatsStart + { -- | Initial code, with liveness. + raLiveCmm :: [LiveCmmDecl statics instr] + + -- | The initial, uncolored graph. + , raGraph :: Color.Graph VirtualReg RegClass RealReg + + -- | Information to help choose which regs to spill. + , raSpillCosts :: SpillCostInfo + + -- | Target platform + , raPlatform :: !Platform + } + + + -- Information about an intermediate graph. + -- This is one that we couldn't color, so had to insert spill code + -- instruction stream. + | RegAllocStatsSpill + { -- | Code we tried to allocate registers for. + raCode :: [LiveCmmDecl statics instr] + + -- | Partially colored graph. + , raGraph :: Color.Graph VirtualReg RegClass RealReg + + -- | The regs that were coalesced. + , raCoalesced :: UniqFM VirtualReg VirtualReg + + -- | Spiller stats. + , raSpillStats :: SpillStats + + -- | Number of instructions each reg lives for. + , raSpillCosts :: SpillCostInfo + + -- | Code with spill instructions added. + , raSpilled :: [LiveCmmDecl statics instr] + + -- | Target platform + , raPlatform :: !Platform + } + + + -- a successful coloring + | RegAllocStatsColored + { -- | Code we tried to allocate registers for. + raCode :: [LiveCmmDecl statics instr] + + -- | Uncolored graph. + , raGraph :: Color.Graph VirtualReg RegClass RealReg + + -- | Coalesced and colored graph. + , raGraphColored :: Color.Graph VirtualReg RegClass RealReg + + -- | Regs that were coalesced. + , raCoalesced :: UniqFM VirtualReg VirtualReg + + -- | Code with coalescings applied. + , raCodeCoalesced :: [LiveCmmDecl statics instr] + + -- | Code with vregs replaced by hregs. + , raPatched :: [LiveCmmDecl statics instr] + + -- | Code with unneeded spill\/reloads cleaned out. + , raSpillClean :: [LiveCmmDecl statics instr] + + -- | Final code. + , raFinal :: [NatCmmDecl statics instr] + + -- | Spill\/reload\/reg-reg moves present in this code. + , raSRMs :: (Int, Int, Int) + + -- | Target platform + , raPlatform :: !Platform + } + deriving (Functor) + + +instance (OutputableP Platform statics, OutputableP Platform instr) + => Outputable (RegAllocStats statics instr) where + + ppr (s@RegAllocStatsStart{}) + = text "# Start" + $$ text "# Native code with liveness information." + $$ pdoc (raPlatform s) (raLiveCmm s) + $$ text "" + $$ text "# Initial register conflict graph." + $$ Color.dotGraph + (targetRegDotColor (raPlatform s)) + (trivColorable (raPlatform s) + (targetVirtualRegSqueeze (raPlatform s)) + (targetRealRegSqueeze (raPlatform s))) + (raGraph s) + + + ppr (s@RegAllocStatsSpill{}) = + text "# Spill" + + $$ text "# Code with liveness information." + $$ pdoc (raPlatform s) (raCode s) + $$ text "" + + $$ (if (not $ isNullUFM $ raCoalesced s) + then text "# Registers coalesced." + $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr) + $$ text "" + else empty) + + $$ text "# Spills inserted." + $$ ppr (raSpillStats s) + $$ text "" + + $$ text "# Code with spills inserted." + $$ pdoc (raPlatform s) (raSpilled s) + + + ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) + = text "# Colored" + + $$ text "# Code with liveness information." + $$ pdoc (raPlatform s) (raCode s) + $$ text "" + + $$ text "# Register conflict graph (colored)." + $$ Color.dotGraph + (targetRegDotColor (raPlatform s)) + (trivColorable (raPlatform s) + (targetVirtualRegSqueeze (raPlatform s)) + (targetRealRegSqueeze (raPlatform s))) + (raGraphColored s) + $$ text "" + + $$ (if (not $ isNullUFM $ raCoalesced s) + then text "# Registers coalesced." + $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr) + $$ text "" + else empty) + + $$ text "# Native code after coalescings applied." + $$ pdoc (raPlatform s) (raCodeCoalesced s) + $$ text "" + + $$ text "# Native code after register allocation." + $$ pdoc (raPlatform s) (raPatched s) + $$ text "" + + $$ text "# Clean out unneeded spill/reloads." + $$ pdoc (raPlatform s) (raSpillClean s) + $$ text "" + + $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." + $$ pdoc (raPlatform s) (raFinal s) + $$ text "" + $$ text "# Score:" + $$ (text "# spills inserted: " <> int spills) + $$ (text "# reloads inserted: " <> int reloads) + $$ (text "# reg-reg moves remaining: " <> int moves) + $$ text "" + + +-- | Do all the different analysis on this list of RegAllocStats +pprStats + :: [RegAllocStats statics instr] + -> Color.Graph VirtualReg RegClass RealReg + -> SDoc + +pprStats stats graph + = let outSpills = pprStatsSpills stats + outLife = pprStatsLifetimes stats + outConflict = pprStatsConflict stats + outScatter = pprStatsLifeConflict stats graph + + in vcat [outSpills, outLife, outConflict, outScatter] + + +-- | Dump a table of how many spill loads \/ stores were inserted for each vreg. +pprStatsSpills + :: [RegAllocStats statics instr] -> SDoc + +pprStatsSpills stats + = let + finals = [srms | RegAllocStatsColored{ raSRMs = srms } <- stats] + + -- sum up how many stores\/loads\/reg-reg-moves were left in the code + total = foldl' addSRM (0, 0, 0) finals + + in ( text "-- spills-added-total" + $$ text "-- (stores, loads, reg_reg_moves_remaining)" + $$ ppr total + $$ text "") + + +-- | Dump a table of how long vregs tend to live for in the initial code. +pprStatsLifetimes + :: [RegAllocStats statics instr] -> SDoc + +pprStatsLifetimes stats + = let info = foldl' plusSpillCostInfo zeroSpillCostInfo + [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- stats ] + + lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info + + in ( text "-- vreg-population-lifetimes" + $$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)" + $$ pprUFM lifeBins (vcat . map ppr) + $$ text "\n") + + +binLifetimeCount :: UniqFM VirtualReg (VirtualReg, Int) -> UniqFM Int (Int, Int) +binLifetimeCount fm + = let lifes = map (\l -> (l, (l, 1))) + $ map snd + $ nonDetEltsUFM fm + -- See Note [Unique Determinism and code generation] + + in addListToUFM_C + (\(l1, c1) (_, c2) -> (l1, c1 + c2)) + emptyUFM + lifes + + +-- | Dump a table of how many conflicts vregs tend to have in the initial code. +pprStatsConflict + :: [RegAllocStats statics instr] -> SDoc + +pprStatsConflict stats + = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) + emptyUFM + $ map Color.slurpNodeConflictCount + [ raGraph s | s@RegAllocStatsStart{} <- stats ] + + in ( text "-- vreg-conflicts" + $$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)" + $$ pprUFM confMap (vcat . map ppr) + $$ text "\n") + + +-- | For every vreg, dump how many conflicts it has, and its lifetime. +-- Good for making a scatter plot. +pprStatsLifeConflict + :: [RegAllocStats statics instr] + -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph + -> SDoc + +pprStatsLifeConflict stats graph + = let lifeMap = lifeMapFromSpillCostInfo + $ foldl' plusSpillCostInfo zeroSpillCostInfo + $ [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- stats ] + + scatter = + [ let lifetime = case lookupUFM lifeMap r of + Just (_, l) -> l + Nothing -> 0 + in parens $ hcat $ punctuate (text ", ") + [ doubleQuotes $ ppr $ Color.nodeId node + , ppr $ sizeUniqSet (Color.nodeConflicts node) + , ppr $ lifetime ] + | node <- nonDetEltsUFM + -- See Note [Unique Determinism and code generation] + $ Color.graphMap graph + , let r = Color.nodeId node + ] + + in ( text "-- vreg-conflict-lifetime" + $$ text "-- (vreg, vreg_conflicts, vreg_lifetime)" + $$ (vcat scatter) + $$ text "\n") + + +-- | Count spill/reload/reg-reg moves. +-- Lets us see how well the register allocator has done. +countSRMs + :: Instruction instr + => Platform + -> LiveCmmDecl statics instr -> (Int, Int, Int) + +countSRMs platform cmm + = execState (mapBlockTopM (countSRM_block platform) cmm) (0, 0, 0) + + +countSRM_block + :: Instruction instr + => Platform + -> GenBasicBlock (LiveInstr instr) + -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr)) + +countSRM_block platform (BasicBlock i instrs) + = do instrs' <- mapM (countSRM_instr platform) instrs + return $ BasicBlock i instrs' + + +countSRM_instr + :: Instruction instr + => Platform -> LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr) + +countSRM_instr platform li + | LiveInstr SPILL{} _ <- li + = do modify $ \(s, r, m) -> (s + 1, r, m) + return li + + | LiveInstr RELOAD{} _ <- li + = do modify $ \(s, r, m) -> (s, r + 1, m) + return li + + | LiveInstr instr _ <- li + , Just _ <- takeRegRegMoveInstr platform instr + = do modify $ \(s, r, m) -> (s, r, m + 1) + return li + + | otherwise + = return li + + +-- sigh.. +addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int) +addSRM (s1, r1, m1) (s2, r2, m2) + = let !s = s1 + s2 + !r = r1 + r2 + !m = m1 + m2 + in (s, r, m) + diff --git a/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -0,0 +1,232 @@ +module GHC.CmmToAsm.Reg.Graph.TrivColorable ( + trivColorable, +) + +where + +import GHC.Prelude + +import GHC.Platform.Reg.Class +import qualified GHC.Platform.Reg.Class.Unified as Unified +import qualified GHC.Platform.Reg.Class.Separate as Separate +import GHC.Platform.Reg + +import GHC.Data.Graph.Base + +import GHC.Types.Unique.Set ( nonDetEltsUniqSet, UniqSet ) +import GHC.Platform +import GHC.Utils.Panic + +-- trivColorable --------------------------------------------------------------- + +-- trivColorable function for the graph coloring allocator +-- +-- This gets hammered by scanGraph during register allocation, +-- so needs to be fairly efficient. +-- +-- NOTE: This only works for architectures with just RcInteger and RcFloatOrVector +-- (which are disjoint) ie. x86, x86_64 and ppc +-- +-- The number of allocatable regs is hard coded in here so we can do +-- a fast comparison in trivColorable. +-- +-- It's ok if these numbers are _less_ than the actual number of free +-- regs, but they can't be more or the register conflict +-- graph won't color. +-- +-- If the graph doesn't color then the allocator will panic, but it won't +-- generate bad object code or anything nasty like that. +-- +-- There is an allocatableRegsInClass :: RegClass -> Int, but doing +-- the unboxing is too slow for us here. +-- TODO: Is that still true? Could we use allocatableRegsInClass +-- without losing performance now? +-- +-- Look at rts/include/stg/MachRegs.h to get the numbers. +-- + + +-- Disjoint registers ---------------------------------------------------------- +-- +-- The definition has been unfolded into individual cases for speed. +-- Each architecture has a different register setup, so we use a +-- different regSqueeze function for each. +-- +accSqueeze + :: Int + -> Int + -> (reg -> Int) + -> UniqSet reg + -> Int + +accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us) + -- See Note [Unique Determinism and code generation] + where acc count [] = count + acc count _ | count >= maxCount = count + acc count (r:rs) = acc (count + squeeze r) rs + +{- Note [accSqueeze] +~~~~~~~~~~~~~~~~~~~~ +BL 2007/09 +Doing a nice fold over the UniqSet makes trivColorable use +32% of total compile time and 42% of total alloc when compiling SHA1.hs from darcs. +Therefore the UniqFM is made non-abstract and we use custom fold. + +MS 2010/04 +When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal +representation any more. But it is imperative that the accSqueeze stops +the folding if the count gets greater or equal to maxCount. We thus convert +UniqFM to a (lazy) list, do the fold and stops if necessary, which was +the most efficient variant tried. Benchmark compiling 10-times SHA1.hs follows. +(original = previous implementation, folding = fold of the whole UFM, + lazyFold = the current implementation, + hackFold = using internal representation of Data.IntMap) + + original folding hackFold lazyFold + -O -fasm (used everywhere) 31.509s 30.387s 30.791s 30.603s + 100.00% 96.44% 97.72% 97.12% + -fregs-graph 67.938s 74.875s 62.673s 64.679s + 100.00% 110.21% 92.25% 95.20% + -fregs-iterative 89.761s 143.913s 81.075s 86.912s + 100.00% 160.33% 90.32% 96.83% + -fnew-codegen 38.225s 37.142s 37.551s 37.119s + 100.00% 97.17% 98.24% 97.11% + -fnew-codegen -fregs-graph 91.786s 91.51s 87.368s 86.88s + 100.00% 99.70% 95.19% 94.65% + -fnew-codegen -fregs-iterative 206.72s 343.632s 194.694s 208.677s + 100.00% 166.23% 94.18% 100.95% +-} + +trivColorable + :: Platform + -> (RegClass -> VirtualReg -> Int) + -> (RegClass -> RealReg -> Int) + -> Triv VirtualReg RegClass RealReg +trivColorable platform virtualRegSqueeze realRegSqueeze rc conflicts exclusions = + let allocatableRegsThisClass = allocatableRegs (platformArch platform) rc + count2 = accSqueeze 0 allocatableRegsThisClass (virtualRegSqueeze rc) conflicts + count3 = accSqueeze count2 allocatableRegsThisClass (realRegSqueeze rc) exclusions + in count3 < allocatableRegsThisClass + +allocatableRegs :: Arch -> RegClass -> Int +allocatableRegs arch rc = + case arch of + ArchX86 -> case rc of + Unified.RcInteger -> 3 + Unified.RcFloatOrVector -> 8 + -- in x86 32bit mode sse2 there are only + -- 8 XMM registers xmm0 ... xmm7 + ArchX86_64 -> case rc of + Unified.RcInteger -> 5 + Unified.RcFloatOrVector -> 10 + -- in x86_64 there are 16 XMM registers + -- xmm0 .. xmm15, here 10 is a + -- "don't need to solve conflicts" count that + -- was chosen at some point in the past. + ArchPPC -> case rc of + Unified.RcInteger -> 16 + Unified.RcFloatOrVector -> 26 + ArchPPC_64 _ -> case rc of + Unified.RcInteger -> 15 + Unified.RcFloatOrVector -> 20 + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchAArch64 -> case rc of + Unified.RcInteger -> 17 + -- N.B. x18 is reserved by the platform on AArch64/Darwin + -- 32 - Base - Sp - Hp - R1..R6 - SpLim - IP0 - SP - LR - FP - X18 + -- -> 32 - 15 = 17 + -- (one stack pointer for Haskell, one for C) + Unified.RcFloatOrVector -> 24 + -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use. + -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this. + ArchAlpha -> panic "trivColorable ArchAlpha" + ArchMipseb -> panic "trivColorable ArchMipseb" + ArchMipsel -> panic "trivColorable ArchMipsel" + ArchS390X -> panic "trivColorable ArchS390X" + ArchRISCV64 -> case rc of + -- TODO for Sven Tennie + Separate.RcInteger -> 14 + Separate.RcFloat -> 20 + Separate.RcVector -> 20 + ArchLoongArch64 -> case rc of + Separate.RcInteger -> 16 + Separate.RcFloat -> 24 + Separate.RcVector -> 24 + ArchJavaScript-> panic "trivColorable ArchJavaScript" + ArchWasm32 -> panic "trivColorable ArchWasm32" + ArchUnknown -> panic "trivColorable ArchUnknown" + + +-- Specification Code ---------------------------------------------------------- +-- +-- The trivColorable function for each particular architecture should +-- implement the following function, but faster. +-- + +{- +trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool +trivColorable classN conflicts exclusions + = let + + acc :: Reg -> (Int, Int) -> (Int, Int) + acc r (cd, cf) + = case regClass r of + RcInteger -> (cd+1, cf) + RcFloatOrVector -> (cd, cf+1) + _ -> panic "Regs.trivColorable: reg class not handled" + + tmp = nonDetFoldUFM acc (0, 0) conflicts + (countInt, countFloat) = nonDetFoldUFM acc tmp exclusions + + squeese = worst countInt classN RcInteger + + worst countFloat classN RcFloatOrVector + + in squeese < allocatableRegsInClass classN + +-- | Worst case displacement +-- node N of classN has n neighbors of class C. +-- +-- We currently only have RcInteger and RcFloatOrVector, which don't conflict at all. +-- This is a bit boring compared to what's in RegArchX86. +-- +worst :: Int -> RegClass -> RegClass -> Int +worst n classN classC + = case classN of + RcInteger + -> case classC of + RcInteger -> min n (allocatableRegsInClass RcInteger) + RcFloatOrVector -> 0 + + RcFloatOrVector + -> case classC of + RcFloatOrVector -> min n (allocatableRegsInClass RcFloatOrVector) + RcInteger -> 0 + +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: [RegNo] +allocatableRegs + = let isFree i = freeReg i + in filter isFree allMachRegNos + + +-- | The number of regs in each class. +-- We go via top level CAFs to ensure that we're not recomputing +-- the length of these lists each time the fn is called. +allocatableRegsInClass :: RegClass -> Int +allocatableRegsInClass cls + = case cls of + RcInteger -> allocatableRegsInteger + RcFloatOrVector -> allocatableRegsDouble + +allocatableRegsInteger :: Int +allocatableRegsInteger + = length $ filter (\r -> regClass r == RcInteger) + $ map RealReg allocatableRegs + +allocatableRegsDouble :: Int +allocatableRegsDouble + = length $ filter (\r -> regClass r == RcFloatOrVector) + $ map RealReg allocatableRegs +-} diff --git a/GHC/CmmToAsm/Reg/Graph/X86.hs b/GHC/CmmToAsm/Reg/Graph/X86.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/X86.hs @@ -0,0 +1,161 @@ + +-- | A description of the register set of the X86. +-- +-- This isn't used directly in GHC proper. +-- +-- See RegArchBase.hs for the reference. +-- See MachRegs.hs for the actual trivColorable function used in GHC. +-- +module GHC.CmmToAsm.Reg.Graph.X86 ( + classOfReg, + regsOfClass, + regName, + regAlias, + worst, + squeese, +) where + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Graph.Base (Reg(..), RegSub(..), RegClass(..)) +import GHC.Types.Unique.Set + +import qualified Data.Array as A + + +-- | Determine the class of a register +classOfReg :: Reg -> RegClass +classOfReg reg + = case reg of + Reg c _ -> c + + RegSub SubL16 _ -> ClassG16 + RegSub SubL8 _ -> ClassG8 + RegSub SubL8H _ -> ClassG8 + + +-- | Determine all the regs that make up a certain class. +regsOfClass :: RegClass -> UniqSet Reg +regsOfClass c + = case c of + ClassG32 + -> mkUniqSet [ Reg ClassG32 i + | i <- [0..7] ] + + ClassG16 + -> mkUniqSet [ RegSub SubL16 (Reg ClassG32 i) + | i <- [0..7] ] + + ClassG8 + -> unionUniqSets + (mkUniqSet [ RegSub SubL8 (Reg ClassG32 i) | i <- [0..3] ]) + (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ]) + + ClassF64 + -> mkUniqSet [ Reg ClassF64 i + | i <- [0..5] ] + + +-- | Determine the common name of a reg +-- returns Nothing if this reg is not part of the machine. +regName :: Reg -> Maybe String +regName reg + = case reg of + Reg ClassG32 i + | i <= 7 -> + let names = A.listArray (0,8) + [ "eax", "ebx", "ecx", "edx" + , "ebp", "esi", "edi", "esp" ] + in Just $ names A.! i + + RegSub SubL16 (Reg ClassG32 i) + | i <= 7 -> + let names = A.listArray (0,8) + [ "ax", "bx", "cx", "dx" + , "bp", "si", "di", "sp"] + in Just $ names A.! i + + RegSub SubL8 (Reg ClassG32 i) + | i <= 3 -> + let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"] + in Just $ names A.! i + + RegSub SubL8H (Reg ClassG32 i) + | i <= 3 -> + let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"] + in Just $ names A.! i + + _ -> Nothing + + +-- | Which regs alias what other regs. +regAlias :: Reg -> UniqSet Reg +regAlias reg + = case reg of + + -- 32 bit regs alias all of the subregs + Reg ClassG32 i + + -- for eax, ebx, ecx, eds + | i <= 3 + -> mkUniqSet + $ [ Reg ClassG32 i, RegSub SubL16 reg + , RegSub SubL8 reg, RegSub SubL8H reg ] + + -- for esi, edi, esp, ebp + | 4 <= i && i <= 7 + -> mkUniqSet + $ [ Reg ClassG32 i, RegSub SubL16 reg ] + + -- 16 bit subregs alias the whole reg + RegSub SubL16 r@(Reg ClassG32 _) + -> regAlias r + + -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg + RegSub SubL8 r@(Reg ClassG32 _) + -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ] + + RegSub SubL8H r@(Reg ClassG32 _) + -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ] + + -- fp + Reg ClassF64 _ + -> unitUniqSet reg + + _ -> error "regAlias: invalid register" + + +-- | Optimised versions of RegColorBase.{worst, squeese} specific to x86 +worst :: Int -> RegClass -> RegClass -> Int +worst n classN classC + = case classN of + ClassG32 + -> case classC of + ClassG32 -> min n 8 + ClassG16 -> min n 8 + ClassG8 -> min n 4 + ClassF64 -> 0 + + ClassG16 + -> case classC of + ClassG32 -> min n 8 + ClassG16 -> min n 8 + ClassG8 -> min n 4 + ClassF64 -> 0 + + ClassG8 + -> case classC of + ClassG32 -> min (n*2) 8 + ClassG16 -> min (n*2) 8 + ClassG8 -> min n 8 + ClassF64 -> 0 + + ClassF64 + -> case classC of + ClassF64 -> min n 6 + _ -> 0 + +squeese :: RegClass -> [(Int, RegClass)] -> Int +squeese classN countCs + = sum (map (\(i, classC) -> worst i classN classC) countCs) + diff --git a/GHC/CmmToAsm/Reg/Linear.hs b/GHC/CmmToAsm/Reg/Linear.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear.hs @@ -0,0 +1,1011 @@ + +----------------------------------------------------------------------------- +-- +-- The register allocator +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +{- +The algorithm is roughly: + + 1) Compute strongly connected components of the basic block list. + + 2) Compute liveness (mapping from pseudo register to + point(s) of death?). + + 3) Walk instructions in each basic block. We keep track of + (a) Free real registers (a bitmap?) + (b) Current assignment of temporaries to machine registers and/or + spill slots (call this the "assignment"). + (c) Partial mapping from basic block ids to a virt-to-loc mapping. + When we first encounter a branch to a basic block, + we fill in its entry in this table with the current mapping. + + For each instruction: + (a) For each temporary *read* by the instruction: + If the temporary does not have a real register allocation: + - Allocate a real register from the free list. If + the list is empty: + - Find a temporary to spill. Pick one that is + not used in this instruction (ToDo: not + used for a while...) + - generate a spill instruction + - If the temporary was previously spilled, + generate an instruction to read the temp from its spill loc. + (optimisation: if we can see that a real register is going to + be used soon, then don't use it for allocation). + + (b) For each real register clobbered by this instruction: + If a temporary resides in it, + If the temporary is live after this instruction, + Move the temporary to another (non-clobbered & free) reg, + or spill it to memory. Mark the temporary as residing + in both memory and a register if it was spilled (it might + need to be read by this instruction). + + (ToDo: this is wrong for jump instructions?) + + We do this after step (a), because if we start with + movq v1, %rsi + which is an instruction that clobbers %rsi, if v1 currently resides + in %rsi we want to get + movq %rsi, %freereg + movq %rsi, %rsi -- will disappear + instead of + movq %rsi, %freereg + movq %freereg, %rsi + + (c) Update the current assignment + + (d) If the instruction is a branch: + if the destination block already has a register assignment, + Generate a new block with fixup code and redirect the + jump to the new block. + else, + Update the block id->assignment mapping with the current + assignment. + + (e) Delete all register assignments for temps which are read + (only) and die here. Update the free register list. + + (f) Mark all registers clobbered by this instruction as not free, + and mark temporaries which have been spilled due to clobbering + as in memory (step (a) marks then as in both mem & reg). + + (g) For each temporary *written* by this instruction: + Allocate a real register as for (b), spilling something + else if necessary. + - except when updating the assignment, drop any memory + locations that the temporary was previously in, since + they will be no longer valid after this instruction. + + (h) Delete all register assignments for temps which are + written and die here (there should rarely be any). Update + the free register list. + + (i) Rewrite the instruction with the new mapping. + + (j) For each spilled reg known to be now dead, re-add its stack slot + to the free list. + +-} + +module GHC.CmmToAsm.Reg.Linear ( + regAlloc, + module GHC.CmmToAsm.Reg.Linear.Base, + module GHC.CmmToAsm.Reg.Linear.Stats + ) where + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Linear.State +import GHC.CmmToAsm.Reg.Linear.Base +import GHC.CmmToAsm.Reg.Linear.StackMap +import GHC.CmmToAsm.Reg.Linear.FreeRegs +import GHC.CmmToAsm.Reg.Linear.Stats +import GHC.CmmToAsm.Reg.Linear.JoinToTargets +import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC +import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 +import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 +import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 +import qualified GHC.CmmToAsm.Reg.Linear.RV64 as RV64 +import qualified GHC.CmmToAsm.Reg.Linear.LA64 as LA64 +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Reg.Utils +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Types +import GHC.Platform.Reg +import GHC.Platform.Reg.Class (RegArch (..), registerArch) +import qualified GHC.Platform.Reg.Class.Separate as Separate +import qualified GHC.Platform.Reg.Class.Unified as Unified +import qualified GHC.Platform.Reg.Class.NoVectors as NoVectors + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label +import GHC.Cmm + +import GHC.Data.Graph.Directed +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSM +import GHC.Types.Unique.Set +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform + +import Data.Containers.ListUtils +import Data.Maybe +import Data.List (sortOn) +import Control.Monad + +-- ----------------------------------------------------------------------------- +-- Top level of the register allocator + +-- Allocate registers +regAlloc + :: Instruction instr + => NCGConfig + -> LiveCmmDecl statics instr + -> UniqDSM ( NatCmmDecl statics instr + , Maybe Int -- number of extra stack slots required, + -- beyond maxSpillSlots + , Maybe RegAllocStats + ) + +regAlloc _ (CmmData sec d) + = return + ( CmmData sec d + , Nothing + , Nothing ) + +regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) + = return ( CmmProc info lbl live (ListGraph []) + , Nothing + , Nothing ) + +regAlloc config (CmmProc static lbl live sccs) + | LiveInfo info entry_ids@(first_id:_) block_live _ <- static + = do + -- do register allocation on each component. + !(!final_blocks, !stats, !stack_use) + <- linearRegAlloc config entry_ids block_live sccs + + -- make sure the block that was first in the input list + -- stays at the front of the output + let !final_blocks' = sortOn ((/= first_id) . blockId) final_blocks + + let max_spill_slots = maxSpillSlots config + extra_stack + | stack_use > max_spill_slots + = Just $! stack_use - max_spill_slots + | otherwise + = Nothing + + return ( CmmProc info lbl live (ListGraph final_blocks') + , extra_stack + , Just stats) + +-- bogus. to make non-exhaustive match warning go away. +regAlloc _ (CmmProc _ _ _ _) + = panic "RegAllocLinear.regAlloc: no match" + + +-- ----------------------------------------------------------------------------- +-- Linear sweep to allocate registers + + +-- | Do register allocation on some basic blocks. +-- But be careful to allocate a block in an SCC only if it has +-- an entry in the block map or it is the first block. +-- +linearRegAlloc + :: forall instr. (Instruction instr) + => NCGConfig + -> [BlockId] -- ^ entry points + -> BlockMap (UniqSet RegWithFormat) + -- ^ live regs on entry to each basic block + -> [SCC (LiveBasicBlock instr)] + -- ^ instructions annotated with "deaths" + -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int) + +linearRegAlloc config entry_ids block_live sccs + = case platformArch platform of + ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs) + ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs) + ArchS390X -> panic "linearRegAlloc ArchS390X" + ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) + ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" + ArchAArch64 -> go $ (frInitFreeRegs platform :: AArch64.FreeRegs) + ArchPPC_64 _ -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) + ArchAlpha -> panic "linearRegAlloc ArchAlpha" + ArchMipseb -> panic "linearRegAlloc ArchMipseb" + ArchMipsel -> panic "linearRegAlloc ArchMipsel" + ArchRISCV64 -> go (frInitFreeRegs platform :: RV64.FreeRegs) + ArchLoongArch64 -> go $ (frInitFreeRegs platform :: LA64.FreeRegs) + ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" + ArchWasm32 -> panic "linearRegAlloc ArchWasm32" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" + where + go :: (FR regs, Outputable regs) + => regs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int) + go f = linearRegAlloc' config f entry_ids block_live sccs + platform = ncgPlatform config + +-- | Constraints on the instruction instances used by the +-- linear allocator. +type OutputableRegConstraint freeRegs instr = + (FR freeRegs, Outputable freeRegs, Instruction instr) + +linearRegAlloc' + :: OutputableRegConstraint freeRegs instr + => NCGConfig + -> freeRegs + -> [BlockId] -- ^ entry points + -> BlockMap (UniqSet RegWithFormat) -- ^ live regs on entry to each basic block + -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" + -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int) + +linearRegAlloc' config initFreeRegs entry_ids block_live sccs + = UDSM $ \us -> do + let !(_, !stack, !stats, !blocks, us') = + runR config emptyBlockAssignment initFreeRegs emptyRegMap emptyStackMap us + $ linearRA_SCCs entry_ids block_live [] sccs + in DUniqResult (blocks, stats, getStackUse stack) us' + + +linearRA_SCCs :: OutputableRegConstraint freeRegs instr + => [BlockId] + -> BlockMap (UniqSet RegWithFormat) + -> [NatBasicBlock instr] + -> [SCC (LiveBasicBlock instr)] + -> RegM freeRegs [NatBasicBlock instr] + +linearRA_SCCs _ _ blocksAcc [] + = return $ reverse blocksAcc + +linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs) + = do blocks' <- processBlock block_live block + linearRA_SCCs entry_ids block_live + ((reverse blocks') ++ blocksAcc) + sccs + +linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) + = do + blockss' <- process entry_ids block_live blocks + linearRA_SCCs entry_ids block_live + (reverse (concat blockss') ++ blocksAcc) + sccs + +{- from John Dias's patch 2008/10/16: + The linear-scan allocator sometimes allocates a block + before allocating one of its predecessors, which could lead to + inconsistent allocations. Make it so a block is only allocated + if a predecessor has set the "incoming" assignments for the block, or + if it's the procedure's entry block. + + BL 2009/02: Careful. If the assignment for a block doesn't get set for + some reason then this function will loop. We should probably do some + more sanity checking to guard against this eventuality. +-} + +process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr) + => [BlockId] + -> BlockMap (UniqSet RegWithFormat) + -> [GenBasicBlock (LiveInstr instr)] + -> RegM freeRegs [[NatBasicBlock instr]] +process entry_ids block_live = + \blocks -> go blocks [] (return []) False + where + go :: [GenBasicBlock (LiveInstr instr)] + -> [GenBasicBlock (LiveInstr instr)] + -> [[NatBasicBlock instr]] + -> Bool + -> RegM freeRegs [[NatBasicBlock instr]] + go [] [] accum _madeProgress + = return $ reverse accum + + go [] next_round accum madeProgress + | not madeProgress + {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. + pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." + ( text "Unreachable blocks:" + $$ vcat (map ppr next_round)) -} + = return $ reverse accum + + | otherwise + = go next_round [] accum False + + go (b@(BasicBlock id _) : blocks) next_round accum madeProgress + = do + block_assig <- getBlockAssigR + if isJust (lookupBlockAssignment id block_assig) || id `elem` entry_ids + then do b' <- processBlock block_live b + go blocks next_round (b' : accum) True + + else do go blocks (b : next_round) accum madeProgress + + +-- | Do register allocation on this basic block +-- +processBlock + :: OutputableRegConstraint freeRegs instr + => BlockMap (UniqSet RegWithFormat) -- ^ live regs on entry to each basic block + -> LiveBasicBlock instr -- ^ block to do register allocation on + -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated + +processBlock block_live (BasicBlock id instrs) + = do -- pprTraceM "processBlock" $ text "" $$ ppr (BasicBlock id instrs) + initBlock id block_live + + (instrs', fixups) + <- linearRA block_live id instrs + -- pprTraceM "blockResult" $ ppr (instrs', fixups) + return $ BasicBlock id instrs' : fixups + + +-- | Load the freeregs and current reg assignment into the RegM state +-- for the basic block with this BlockId. +initBlock :: FR freeRegs + => BlockId -> BlockMap (UniqSet RegWithFormat) -> RegM freeRegs () +initBlock id block_live + = do platform <- getPlatform + block_assig <- getBlockAssigR + case lookupBlockAssignment id block_assig of + -- no prior info about this block: we must consider + -- any fixed regs to be allocated, but we can ignore + -- virtual regs (presumably this is part of a loop, + -- and we'll iterate again). The assignment begins + -- empty. + Nothing + -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) + case mapLookup id block_live of + Nothing -> + setFreeRegsR (frInitFreeRegs platform) + Just live -> + setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform) + (nonDetEltsUniqSet $ takeRealRegs live) + -- See Note [Unique Determinism and code generation] + setAssigR emptyRegMap + + -- load info about register assignments leading into this block. + Just (freeregs, assig) + -> do setFreeRegsR freeregs + setAssigR assig + + +-- | Do allocation for a sequence of instructions. +linearRA + :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr) + => BlockMap (UniqSet RegWithFormat) -- ^ map of what vregs are live on entry to each block. + -> BlockId -- ^ id of the current block, for debugging. + -> [LiveInstr instr] -- ^ liveness annotated instructions in this block. + -> RegM freeRegs + ( [instr] -- instructions after register allocation + , [NatBasicBlock instr]) -- fresh blocks of fixup code. +linearRA block_live block_id = go [] [] + where + go :: [instr] -- accumulator for instructions already processed. + -> [NatBasicBlock instr] -- accumulator for blocks of fixup code. + -> [LiveInstr instr] -- liveness annotated instructions in this block. + -> RegM freeRegs + ( [instr] -- instructions after register allocation + , [NatBasicBlock instr] ) -- fresh blocks of fixup code. + go !accInstr !accFixups [] = do + return ( reverse accInstr -- instrs need to be returned in the correct order. + , accFixups ) -- it doesn't matter what order the fixup blocks are returned in. + + go accInstr accFixups (instr:instrs) = do + (accInstr', new_fixups) <- raInsn block_live accInstr block_id instr + go accInstr' (new_fixups ++ accFixups) instrs + +-- | Do allocation for a single instruction. +raInsn + :: OutputableRegConstraint freeRegs instr + => BlockMap (UniqSet RegWithFormat) -- ^ map of what vregs are love on entry to each block. + -> [instr] -- ^ accumulator for instructions already processed. + -> BlockId -- ^ the id of the current block, for debugging + -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. + -> RegM freeRegs + ( [instr] -- new instructions + , [NatBasicBlock instr]) -- extra fixup blocks + +raInsn _ new_instrs _ (LiveInstr ii Nothing) + | Just n <- takeDeltaInstr ii + = do setDeltaR n + return (new_instrs, []) + +raInsn _ new_instrs _ (LiveInstr ii@(Instr i) Nothing) + | isMetaInstr ii + = return (i : new_instrs, []) + + +raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) + = do + platform <- getPlatform + assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc) + + -- If we have a reg->reg move between virtual registers, where the + -- src register is not live after this instruction, and the dst + -- register does not already have an assignment, + -- and the source register is assigned to a register, not to a spill slot, + -- then we can eliminate the instruction. + -- (we can't eliminate it if the source register is on the stack, because + -- we do not want to use one spill slot for different virtual registers) + case takeRegRegMoveInstr platform instr of + Just (src,dst) | Just (RegWithFormat _ fmt) <- lookupUniqSet_Directly (liveDieRead live) (getUnique src), + isVirtualReg dst, + not (dst `elemUFM` assig), + isRealReg src || isInReg src assig -> do + case src of + RegReal rr -> setAssigR (addToUFM assig dst (InReg $ RealRegUsage rr fmt)) + -- if src is a fixed reg, then we just map dest to this + -- reg in the assignment. src must be an allocatable reg, + -- otherwise it wouldn't be in r_dying. + _virt -> case lookupUFM assig src of + Nothing -> panic "raInsn" + Just loc -> + setAssigR (addToUFM (delFromUFM assig src) dst loc) + + -- we have eliminated this instruction + {- + freeregs <- getFreeRegsR + assig <- getAssigR + pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) + $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do + -} + return (new_instrs, []) + + _ -> genRaInsn block_live new_instrs id instr + (map regWithFormat_reg $ nonDetEltsUniqSet $ liveDieRead live) + (map regWithFormat_reg $ nonDetEltsUniqSet $ liveDieWrite live) + -- See Note [Unique Determinism and code generation] + +raInsn _ _ _ instr + = do + platform <- getPlatform + let instr' = fmap (pprInstr platform) instr + pprPanic "raInsn" (text "no match for:" <> ppr instr') + +-- ToDo: what can we do about +-- +-- R1 = x +-- jump I64[x] // [R1] +-- +-- where x is mapped to the same reg as R1. We want to coalesce x and +-- R1, but the register allocator doesn't know whether x will be +-- assigned to again later, in which case x and R1 should be in +-- different registers. Right now we assume the worst, and the +-- assignment to R1 will clobber x, so we'll spill x into another reg, +-- generating another reg->reg move. + + +isInReg :: Reg -> RegMap Loc -> Bool +isInReg src assig | Just (InReg _) <- lookupUFM assig src = True + | otherwise = False + + +genRaInsn :: forall freeRegs instr. + (OutputableRegConstraint freeRegs instr) + => BlockMap (UniqSet RegWithFormat) + -> [instr] + -> BlockId + -> instr + -> [Reg] + -> [Reg] + -> RegM freeRegs ([instr], [NatBasicBlock instr]) + +genRaInsn block_live new_instrs block_id instr r_dying w_dying = do +-- pprTraceM "genRaInsn" $ ppr (block_id, instr) + platform <- getPlatform + case regUsageOfInstr platform instr of { RU read written -> + do + let real_written = [ rr | RegWithFormat {regWithFormat_reg = RegReal rr} <- written ] + let virt_written = [ VirtualRegWithFormat vr fmt | RegWithFormat (RegVirtual vr) fmt <- written ] + + -- we don't need to do anything with real registers that are + -- only read by this instr. (the list is typically ~2 elements, + -- so using nub isn't a problem). + let virt_read :: [VirtualRegWithFormat] + virt_read = nubOrdOn virtualRegWithFormat_reg [ VirtualRegWithFormat vr fmt | RegWithFormat (RegVirtual vr) fmt <- read ] + +-- do +-- let real_read = nub [ rr | (RegReal rr) <- read] +-- freeregs <- getFreeRegsR +-- assig <- getAssigR + +-- pprTraceM "genRaInsn" +-- ( text "block = " <+> ppr block_id +-- $$ text "instruction = " <+> ppr instr +-- $$ text "r_dying = " <+> ppr r_dying +-- $$ text "w_dying = " <+> ppr w_dying +-- $$ text "read = " <+> ppr real_read <+> ppr virt_read +-- $$ text "written = " <+> ppr real_written <+> ppr virt_written +-- $$ text "freeregs = " <+> ppr freeregs +-- $$ text "assign = " <+> ppr assig) + + -- (a), (b) allocate real regs for all regs read by this instruction. + (r_spills, r_allocd) <- + allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read + + -- (c) save any temporaries which will be clobbered by this instruction + clobber_saves <- saveClobberedTemps real_written r_dying + + -- (d) Update block map for new destinations + -- NB. do this before removing dead regs from the assignment, because + -- these dead regs might in fact be live in the jump targets (they're + -- only dead in the code that follows in the current basic block). + (fixup_blocks, adjusted_instr) + <- joinToTargets block_live block_id instr + +-- when (not $ null fixup_blocks) $ pprTraceM "genRA:FixBlocks" $ ppr fixup_blocks + + -- Debugging - show places where the reg alloc inserted + -- assignment fixup blocks. + -- when (not $ null fixup_blocks) $ + -- pprTrace "fixup_blocks" (ppr fixup_blocks) (return ()) + + -- (e) Delete all register assignments for temps which are read + -- (only) and die here. Update the free register list. + releaseRegs r_dying + + -- (f) Mark regs which are clobbered as unallocatable + clobberRegs real_written + + -- (g) Allocate registers for temporaries *written* (only) + (w_spills, w_allocd) <- + allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written + + -- (h) Release registers for temps which are written here and not + -- used again. + releaseRegs w_dying + + let + -- (i) Patch the instruction + patch_map :: UniqFM Reg Reg + patch_map + = toRegMap $ -- Cast key from VirtualReg to Reg + -- See Note [UniqFM and the register allocator] + listToUFM + [ (virtualRegWithFormat_reg vr, RegReal rr) + | (vr, rr) <- zip virt_read r_allocd + ++ zip virt_written w_allocd ] + + patched_instr :: instr + patched_instr + = patchRegsOfInstr platform adjusted_instr patchLookup + + patchLookup :: Reg -> Reg + patchLookup x + = case lookupUFM patch_map x of + Nothing -> x + Just y -> y + + -- (j) free up stack slots for dead spilled regs + -- TODO (can't be bothered right now) + + -- erase reg->reg moves where the source and destination are the same. + -- If the src temp didn't die in this instr but happened to be allocated + -- to the same real reg as the destination, then we can erase the move anyway. + let squashed_instr = case takeRegRegMoveInstr platform patched_instr of + Just (src, dst) + | src == dst -> [] + _ -> [patched_instr] + + -- On the use of @reverse@ below. + -- Since we can have spills and reloads produce multiple instructions + -- we need to ensure they are emitted in the correct order. We used to only + -- emit single instructions in mkSpill/mkReload/mkRegRegMove. + -- As such order of spills and reloads didn't matter. However, with + -- multiple instructions potentially issued by those functions we need to be + -- careful to not break execution order. Reversing the spills (clobber will + -- also spill), will ensure they are emitted in the right order. + -- + -- See also Ticket 19910 for changing the return type from [] to OrdList. + + -- For debugging, uncomment the follow line and the mkComment lines. + -- u <- getUniqueR + let code = concat [ -- mkComment (text " ppr u <> text ")>") + -- ,mkComment (text " ppr u <> text "):squashed>")] + squashed_instr + -- ,mkComment (text " ppr u <> text "):w_spills>") + , reverse w_spills + -- ,mkComment (text " ppr u <> text "):r_spills>") + , reverse r_spills + -- ,mkComment (text " ppr u <> text "):clobber_saves>") + , reverse clobber_saves + -- ,mkComment (text " ppr u <> text "):new_instrs>") + , new_instrs + -- ,mkComment (text " ppr u <> text ")>") + ] + +-- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do +-- pprTrace "patched-fixup" ((ppr fixup_blocks)) $ do + + return (code, fixup_blocks) + + } + +-- ----------------------------------------------------------------------------- +-- releaseRegs + +releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () +releaseRegs regs = do + platform <- getPlatform + assig <- getAssigR + free <- getFreeRegsR + + let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return () + loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs + loop assig !free (r:rs) = + case lookupUFM assig r of + Just (InBoth real _) -> loop (delFromUFM assig r) + (frReleaseReg platform (realReg real) free) rs + Just (InReg real) -> loop (delFromUFM assig r) + (frReleaseReg platform (realReg real) free) rs + _ -> loop (delFromUFM assig r) free rs + loop assig free regs + + +-- ----------------------------------------------------------------------------- +-- Clobber real registers + +-- For each temp in a register that is going to be clobbered: +-- - if the temp dies after this instruction, do nothing +-- - otherwise, put it somewhere safe (another reg if possible, +-- otherwise spill and record InBoth in the assignment). +-- - for allocateRegs on the temps *read*, +-- - clobbered regs are allocatable. +-- +-- for allocateRegs on the temps *written*, +-- - clobbered regs are not allocatable. +-- + +saveClobberedTemps + :: forall instr freeRegs. + (Instruction instr, FR freeRegs) + => [RealReg] -- real registers clobbered by this instruction + -> [Reg] -- registers which are no longer live after this insn + -> RegM freeRegs [instr] -- return: instructions to spill any temps that will + -- be clobbered. + +saveClobberedTemps [] _ + = return [] + +saveClobberedTemps clobbered dying + = do + assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc) + (assig',instrs) <- nonDetStrictFoldUFM_DirectlyM maybe_spill (assig,[]) assig + setAssigR assig' + return $ -- mkComment (text "") ++ + instrs +-- ++ mkComment (text "") + where + -- Unique represents the VirtualReg + -- Here we separate the cases which we do want to spill from these we don't. + maybe_spill :: Unique -> (RegMap Loc,[instr]) -> (Loc) -> RegM freeRegs (RegMap Loc,[instr]) + maybe_spill !temp !(assig,instrs) !loc = + case loc of + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + InReg reg + | any (realRegsAlias $ realReg reg) clobbered + , temp `notElem` map getUnique dying + -> clobber temp (assig,instrs) reg + _ -> return (assig,instrs) + + + -- See Note [UniqFM and the register allocator] + clobber :: Unique -> (RegMap Loc,[instr]) -> RealRegUsage -> RegM freeRegs (RegMap Loc,[instr]) + clobber temp (assig,instrs) (RealRegUsage reg fmt) + = do config <- getConfig + platform <- getPlatform + + freeRegs <- getFreeRegsR + let regclass = targetClassOfRealReg platform reg + freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs + + case filter (`notElem` clobbered) freeRegs_thisClass of + + -- (1) we have a free reg of the right class that isn't + -- clobbered by this instruction; use it to save the + -- clobbered value. + (my_reg : _) -> do + setFreeRegsR (frAllocateReg platform my_reg freeRegs) + + let new_assign = addToUFM_Directly assig temp (InReg (RealRegUsage my_reg fmt)) + let instr = mkRegRegMoveInstr config fmt + (RegReal reg) (RegReal my_reg) + + return (new_assign,(instr : instrs)) + + -- (2) no free registers: spill the value + [] -> do + (spill, slot) <- spillR (RegWithFormat (RegReal reg) fmt) temp + + -- record why this reg was spilled for profiling + recordSpill (SpillClobber temp) + + let new_assign = addToUFM_Directly assig temp (InBoth (RealRegUsage reg fmt) slot) + + return (new_assign, (spill ++ instrs)) + + + + +-- | Mark all these real regs as allocated, +-- and kick out their vreg assignments. +-- +clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs () +clobberRegs [] + = return () + +clobberRegs clobbered + = do platform <- getPlatform + freeregs <- getFreeRegsR + + let allRegClasses = + case registerArch (platformArch platform) of + Unified -> Unified.allRegClasses + Separate -> Separate.allRegClasses + NoVectors -> NoVectors.allRegClasses + allFreeRegs = foldMap (\ rc -> frGetFreeRegs platform rc freeregs) allRegClasses + + let extra_clobbered = [ r | r <- clobbered, r `elem` allFreeRegs ] + + setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs extra_clobbered + + -- setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered + + assig <- getAssigR + setAssigR $! clobber assig (nonDetUFMToList assig) + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + + where + -- if the temp was InReg and clobbered, then we will have + -- saved it in saveClobberedTemps above. So the only case + -- we have to worry about here is InBoth. Note that this + -- also catches temps which were loaded up during allocation + -- of read registers, not just those saved in saveClobberedTemps. + + clobber :: RegMap Loc -> [(Unique,Loc)] -> RegMap Loc + clobber assig [] + = assig + + clobber assig ((temp, InBoth reg slot) : rest) + | any (realRegsAlias $ realReg reg) clobbered + = clobber (addToUFM_Directly assig temp (InMem slot)) rest + + clobber assig (_:rest) + = clobber assig rest + +-- ----------------------------------------------------------------------------- +-- allocateRegsAndSpill + +-- Why are we performing a spill? +data SpillLoc = ReadMem StackSlot -- reading from register only in memory + | WriteNew -- writing to a new variable + | WriteMem -- writing to register only in memory +-- Note that ReadNew is not valid, since you don't want to be reading +-- from an uninitialized register. We also don't need the location of +-- the register in memory, since that will be invalidated by the write. +-- Technically, we could coalesce WriteNew and WriteMem into a single +-- entry as well. -- EZY + +-- This function does several things: +-- For each temporary referred to by this instruction, +-- we allocate a real register (spilling another temporary if necessary). +-- We load the temporary up from memory if necessary. +-- We also update the register assignment in the process, and +-- the list of free registers and free stack slots. + +allocateRegsAndSpill + :: forall freeRegs instr. (FR freeRegs, Instruction instr) + => Bool -- True <=> reading (load up spilled regs) + -> [VirtualRegWithFormat] -- don't push these out + -> [instr] -- spill insns + -> [RealReg] -- real registers allocated (accum.) + -> [VirtualRegWithFormat] -- temps to allocate + -> RegM freeRegs ( [instr] , [RealReg]) + +allocateRegsAndSpill _ _ spills alloc [] + = return (spills, reverse alloc) + +allocateRegsAndSpill reading keep spills alloc (r@(VirtualRegWithFormat vr _fmt):rs) + = do assig <- toVRegMap <$> getAssigR + -- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig) + -- See Note [UniqFM and the register allocator] + let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig + case lookupUFM assig vr of + -- case (1a): already in a register + Just (InReg my_reg) -> + allocateRegsAndSpill reading keep spills (realReg my_reg:alloc) rs + + -- case (1b): already in a register (and memory) + -- NB1. if we're writing this register, update its assignment to be + -- InReg, because the memory value is no longer valid. + -- NB2. This is why we must process written registers here, even if they + -- are also read by the same instruction. + Just (InBoth my_reg _) + -> do when (not reading) (setAssigR $ toRegMap (addToUFM assig vr (InReg my_reg))) + allocateRegsAndSpill reading keep spills (realReg my_reg:alloc) rs + + -- Not already in a register, so we need to find a free one... + Just (InMem slot) | reading -> doSpill (ReadMem slot) + | otherwise -> doSpill WriteMem + Nothing | reading -> + pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr vr) + -- NOTE: if the input to the NCG contains some + -- unreachable blocks with junk code, this panic + -- might be triggered. Make sure you only feed + -- sensible code into the NCG. In GHC.Cmm.Pipeline we + -- call removeUnreachableBlocks at the end for this + -- reason. + + | otherwise -> doSpill WriteNew + +-- | Given a virtual reg find a preferred real register. +-- The preferred register is simply the first one the variable +-- was assigned to (if any). This way when we allocate for a loop +-- variables are likely to end up in the same registers at the +-- end and start of the loop, avoiding redundant reg-reg moves. +-- Note: I tried returning a list of past assignments, but that +-- turned out to barely matter. +findPrefRealReg :: VirtualReg -> RegM freeRegs (Maybe RealReg) +findPrefRealReg vreg = do + bassig <- getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) + return $ lookupFirstUsed vreg bassig + +-- reading is redundant with reason, but we keep it around because it's +-- convenient and it maintains the recursive structure of the allocator. -- EZY +allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr) + => Bool + -> [VirtualRegWithFormat] + -> [instr] + -> [RealReg] + -> VirtualRegWithFormat + -> [VirtualRegWithFormat] + -> UniqFM VirtualReg Loc + -> SpillLoc + -> RegM freeRegs ([instr], [RealReg]) +allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt) rs assig spill_loc + = do platform <- getPlatform + freeRegs <- getFreeRegsR + let regclass = classOfVirtualReg (platformArch platform) vr + freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs :: [RealReg] + + -- Can we put the variable into a register it already was? + pref_reg <- findPrefRealReg vr + + case freeRegs_thisClass of + -- case (2): we have a free register + (first_free : _) -> + do let !final_reg + | Just reg <- pref_reg + , reg `elem` freeRegs_thisClass + = reg + | otherwise + = first_free + + spills' <- loadTemp r spill_loc final_reg spills + + setAssigR $ toRegMap + $ (addToUFM assig vr $! newLocation spill_loc $ RealRegUsage final_reg fmt) + setFreeRegsR $ frAllocateReg platform final_reg freeRegs + + allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs + + + -- case (3): we need to push something out to free up a register + [] -> + do let inRegOrBoth (InReg _) = True + inRegOrBoth (InBoth _ _) = True + inRegOrBoth _ = False + let candidates' :: UniqFM VirtualReg Loc + candidates' = + flip delListFromUFM (fmap virtualRegWithFormat_reg keep) $ + filterUFM inRegOrBoth $ + assig + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + let candidates = nonDetUFMToList candidates' + + -- the vregs we could kick out that are already in a slot + let compat reg' + = targetClassOfRealReg platform reg' + == regclass + candidates_inBoth :: [(Unique, RealRegUsage, StackSlot)] + candidates_inBoth + = [ (temp, reg, mem) + | (temp, InBoth reg mem) <- candidates + , compat (realReg reg) ] + + -- the vregs we could kick out that are only in a reg + -- this would require writing the reg to a new slot before using it. + let candidates_inReg + = [ (temp, reg) + | (temp, InReg reg) <- candidates + , compat (realReg reg) ] + + let result + + -- we have a temporary that is in both register and mem, + -- just free up its register for use. + | (temp, (RealRegUsage my_reg _old_fmt), slot) : _ <- candidates_inBoth + = do spills' <- loadTemp r spill_loc my_reg spills + let assig1 = addToUFM_Directly assig temp (InMem slot) + let assig2 = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage my_reg fmt) + + setAssigR $ toRegMap assig2 + allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs + + -- otherwise, we need to spill a temporary that currently + -- resides in a register. + | (temp_to_push_out, RealRegUsage my_reg fmt) : _ + <- candidates_inReg + = do + (spill_store, slot) <- spillR (RegWithFormat (RegReal my_reg) fmt) temp_to_push_out + + -- record that this temp was spilled + recordSpill (SpillAlloc temp_to_push_out) + + -- update the register assignment + let assig1 = addToUFM_Directly assig temp_to_push_out (InMem slot) + let assig2 = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage my_reg fmt) + setAssigR $ toRegMap assig2 + + -- if need be, load up a spilled temp into the reg we've just freed up. + spills' <- loadTemp r spill_loc my_reg spills + + allocateRegsAndSpill reading keep + (spill_store ++ spills') + (my_reg:alloc) rs + + + -- there wasn't anything to spill, so we're screwed. + | otherwise + = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n") + $ vcat + [ text "allocating vreg: " <> text (show vr) + , text "assignment: " <> ppr assig + , text "format: " <> ppr fmt + , text "freeRegs: " <> text (showRegs freeRegs) + , text "initFreeRegs: " <> text (showRegs (frInitFreeRegs platform `asTypeOf` freeRegs)) + ] + where showRegs = show . map (\reg -> (reg, targetClassOfRealReg platform reg)) . allFreeRegs platform + + result + + +-- | Calculate a new location after a register has been loaded. +newLocation :: SpillLoc -> RealRegUsage -> Loc +-- if the tmp was read from a slot, then now its in a reg as well +newLocation (ReadMem slot) my_reg = InBoth my_reg slot +-- writes will always result in only the register being available +newLocation _ my_reg = InReg my_reg + +-- | Load up a spilled temporary if we need to (read from memory). +loadTemp + :: (Instruction instr) + => VirtualRegWithFormat -- the temp being loaded + -> SpillLoc -- the current location of this temp + -> RealReg -- the hreg to load the temp into + -> [instr] + -> RegM freeRegs [instr] + +loadTemp (VirtualRegWithFormat vreg fmt) (ReadMem slot) hreg spills + = do + insn <- loadR (RegWithFormat (RegReal hreg) fmt) slot + recordSpill (SpillLoad $ getUnique vreg) + return $ {- mkComment (text "spill load") : -} insn ++ spills + +loadTemp _ _ _ spills = + return spills diff --git a/GHC/CmmToAsm/Reg/Linear/AArch64.hs b/GHC/CmmToAsm/Reg/Linear/AArch64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/AArch64.hs @@ -0,0 +1,136 @@ +module GHC.CmmToAsm.Reg.Linear.AArch64 where + +import GHC.Prelude + +import GHC.CmmToAsm.AArch64.Regs +import GHC.Platform.Reg.Class.Unified +import GHC.Platform.Reg + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc( HasDebugCallStack ) +import GHC.Platform + +import Data.Word + +-- AArch64 has 32 64bit general purpose register r0..r30, and zr/sp +-- AArch64 has 32 128bit floating point registers v0..v31 as part of the NEON +-- extension in Armv8-A. +-- +-- Armv8-A is a fundamental change to the Arm architecture. It supports the +-- 64-bit Execution state called “AArch64”, and a new 64-bit instruction set +-- “A64”. To provide compatibility with the Armv7-A (32-bit architecture) +-- instruction set, a 32-bit variant of Armv8-A “AArch32” is provided. Most of +-- existing Armv7-A code can be run in the AArch32 execution state of Armv8-A. +-- +-- these can be addresses as q/d/s/h/b 0..31, or v.f[idx] +-- where size is 64, 32, 16, 8, ... and the index i allows us +-- to access the given part. +-- +-- History of Arm Adv SIMD +-- .---------------------------------------------------------------------------. +-- | Armv6 | Armv7-A | Armv8-A AArch64 | +-- | SIMD extension | NEON | NEON | +-- |===========================================================================| +-- | - Operates on 32-bit | - Separate reg. bank, | - Separate reg. bank, | +-- | GP ARM registers | 32x64-bit NEON regs | 32x128-bit NEON regs | +-- | - 8-bit/16-bit integer | - 8/16/32/64-bit int | - 8/16/32/64-bit int | +-- | | - Single precision fp | - Single precision fp | +-- | | | - Double precision fp | +-- | | | - Single/Double fp are | +-- | | | IEEE compliant | +-- | - 2x16-bit/4x8-bit ops | - Up to 16x8-bit ops | - Up to 16x8-bit ops | +-- | per instruction | per instruction | per instruction | +-- '---------------------------------------------------------------------------' + +data FreeRegs = FreeRegs !Word32 !Word32 + +instance Show FreeRegs where + show (FreeRegs g f) = "FreeRegs: " ++ showBits g ++ "; " ++ showBits f + +instance Outputable FreeRegs where + ppr (FreeRegs g f) = text " " <+> foldr (\i x -> pad_int i <+> x) (text "") [0..31] + $$ text "GPR" <+> foldr (\i x -> show_bit g i <+> x) (text "") [0..31] + $$ text "FPR" <+> foldr (\i x -> show_bit f i <+> x) (text "") [0..31] + where pad_int i | i < 10 = char ' ' <> int i + pad_int i = int i + -- remember bit = 1 means it's available. + show_bit bits bit | testBit bits bit = text " " + show_bit _ _ = text " x" + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 0 + +showBits :: Word32 -> String +showBits w = map (\i -> if testBit w i then '1' else '0') [0..31] + +-- FR instance implementation (See Linear.FreeRegs) +allocateReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs g f) + | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) + | r < 32 && testBit g r = FreeRegs (clearBit g r) f + | r > 31 = panic $ "Linear.AArch64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f + | otherwise = pprPanic "Linear.AArch64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g) + +-- we start from 28 downwards... the logic is similar to the ppc logic. +-- 31 is Stack Pointer +-- 30 is Link Register +-- 29 is Stack Frame (by convention) +-- 19-28 are callee save +-- the lower ones are all caller save + +-- For this reason someone decided to give aarch64 only 6 regs for +-- STG: +-- 19: Base +-- 20: Sp +-- 21: Hp +-- 22-27: R1-R6 +-- 28: SpLim + +-- For LLVM code gen interop: +-- See https://lists.llvm.org/pipermail/llvm-commits/Week-of-Mon-20150119/253722.html +-- and the current ghccc implementation here: +-- https://github.com/llvm/llvm-project/blob/161ae1f39816edf667aaa190bce702a86879c7bd/llvm/lib/Target/AArch64/AArch64CallingConvention.td#L324-L363 +-- and https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/generated-code +-- for the STG discussion. +{- For reference the ghcc from the link above: +let Entry = 1 in +def CC_AArch64_GHC : CallingConv<[ + CCIfType<[iPTR], CCBitConvertToType>, + + // Handle all vector types as either f64 or v2f64. + CCIfType<[v1i64, v2i32, v4i16, v8i8, v2f32], CCBitConvertToType>, + CCIfType<[v2i64, v4i32, v8i16, v16i8, v4f32, f128], CCBitConvertToType>, + + CCIfType<[v2f64], CCAssignToReg<[Q4, Q5]>>, + CCIfType<[f32], CCAssignToReg<[S8, S9, S10, S11]>>, + CCIfType<[f64], CCAssignToReg<[D12, D13, D14, D15]>>, + + // Promote i8/i16/i32 arguments to i64. + CCIfType<[i8, i16, i32], CCPromoteToType>, + + // Pass in STG registers: Base, Sp, Hp, R1, R2, R3, R4, R5, R6, SpLim + CCIfType<[i64], CCAssignToReg<[X19, X20, X21, X22, X23, X24, X25, X26, X27, X28]>> +]>; +-} + +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] +getFreeRegs cls (FreeRegs g f) = + case cls of + RcFloatOrVector -> go 32 f 31 + -- x18 is a platform-reserved register for Win/Mac and free for Linux (See Note [Aarch64 Register x18 at Darwin and Windows]) + RcInteger -> go 0 g 18 + where + go _ _ i | i < 0 = [] + go off x i | testBit x i = RealRegSingle (off + i) : (go off x $! i - 1) + | otherwise = go off x $! i - 1 + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) + +releaseReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle r) (FreeRegs g f) + | r > 31 && testBit f (r - 32) = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32)) + | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r) + | r > 31 = FreeRegs g (setBit f (r - 32)) + | otherwise = FreeRegs (setBit g r) f diff --git a/GHC/CmmToAsm/Reg/Linear/Base.hs b/GHC/CmmToAsm/Reg/Linear/Base.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/Base.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Put common type definitions here to break recursive module dependencies. + +module GHC.CmmToAsm.Reg.Linear.Base ( + BlockAssignment, + lookupBlockAssignment, + lookupFirstUsed, + emptyBlockAssignment, + updateBlockAssignment, + + Loc(..), + regsOfLoc, + RealRegUsage(..), + + -- for stats + SpillReason(..), + RegAllocStats(..), + + -- the allocator monad + RA_State(..), +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Linear.StackMap +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Config +import GHC.Platform.Reg + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSM +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label +import GHC.CmmToAsm.Reg.Utils +import GHC.CmmToAsm.Format + +import Data.Function ( on ) + +data ReadingOrWriting = Reading | Writing deriving (Eq,Ord) + +-- | Used to store the register assignment on entry to a basic block. +-- We use this to handle join points, where multiple branch instructions +-- target a particular label. We have to insert fixup code to make +-- the register assignments from the different sources match up. +-- +data BlockAssignment freeRegs + = BlockAssignment { blockMap :: !(BlockMap (freeRegs, RegMap Loc)) + , firstUsed :: !(UniqFM VirtualReg RealReg) } + +-- | Find the register mapping for a specific BlockId. +lookupBlockAssignment :: BlockId -> BlockAssignment freeRegs -> Maybe (freeRegs, RegMap Loc) +lookupBlockAssignment bid ba = mapLookup bid (blockMap ba) + +-- | Lookup which register a virtual register was first assigned to. +lookupFirstUsed :: VirtualReg -> BlockAssignment freeRegs -> Maybe RealReg +lookupFirstUsed vr ba = lookupUFM (firstUsed ba) vr + +-- | An initial empty 'BlockAssignment' +emptyBlockAssignment :: BlockAssignment freeRegs +emptyBlockAssignment = BlockAssignment mapEmpty mempty + +-- | Add new register mappings for a specific block. +updateBlockAssignment :: BlockId + -> (freeRegs, RegMap Loc) + -> BlockAssignment freeRegs + -> BlockAssignment freeRegs +updateBlockAssignment dest (freeRegs, regMap) (BlockAssignment {..}) = + BlockAssignment (mapInsert dest (freeRegs, regMap) blockMap) + (mergeUFM combWithExisting id (mapMaybeUFM fromLoc) (firstUsed) (toVRegMap regMap)) + where + -- The blocks are processed in dependency order, so if there's already an + -- entry in the map then keep that assignment rather than writing the new + -- assignment. + combWithExisting :: RealReg -> Loc -> Maybe RealReg + combWithExisting old_reg _ = Just $ old_reg + + fromLoc :: Loc -> Maybe RealReg + fromLoc (InReg rr) = Just $ realReg rr + fromLoc (InBoth rr _) = Just $ realReg rr + fromLoc _ = Nothing + + +-- | Where a vreg is currently stored +-- A temporary can be marked as living in both a register and memory +-- (InBoth), for example if it was recently loaded from a spill location. +-- This makes it cheap to spill (no save instruction required), but we +-- have to be careful to turn this into InReg if the value in the +-- register is changed. + +-- This is also useful when a temporary is about to be clobbered. We +-- save it in a spill location, but mark it as InBoth because the current +-- instruction might still want to read it. +-- +data Loc + -- | vreg is in a register + = InReg {-# UNPACK #-} !RealRegUsage + + -- | vreg is held in stack slots + | InMem {-# UNPACK #-} !StackSlot + + + -- | vreg is held in both a register and stack slots + | InBoth {-# UNPACK #-} !RealRegUsage + {-# UNPACK #-} !StackSlot + deriving (Eq, Ord, Show) + +instance Outputable Loc where + ppr l = text (show l) + +-- | A 'RealReg', together with the specific 'Format' it is used at. +data RealRegUsage + = RealRegUsage + { realReg :: !RealReg + , realRegFormat :: !Format + } deriving Show + +instance Outputable RealRegUsage where + ppr (RealRegUsage r fmt) = ppr r <> dcolon <+> ppr fmt + +-- NB: these instances only compare the underlying 'RealReg', as that is what +-- is important for register allocation. +-- +-- (It would nonetheless be a good idea to remove these instances.) +instance Eq RealRegUsage where + (==) = (==) `on` realReg +instance Ord RealRegUsage where + compare = compare `on` realReg + +-- | Get the reg numbers stored in this Loc. +regsOfLoc :: Loc -> [RealRegUsage] +regsOfLoc (InReg r) = [r] +regsOfLoc (InBoth r _) = [r] +regsOfLoc (InMem _) = [] + + +-- | Reasons why instructions might be inserted by the spiller. +-- Used when generating stats for -ddrop-asm-stats. +-- +data SpillReason + -- | vreg was spilled to a slot so we could use its + -- current hreg for another vreg + = SpillAlloc !Unique + + -- | vreg was moved because its hreg was clobbered + | SpillClobber !Unique + + -- | vreg was loaded from a spill slot + | SpillLoad !Unique + + -- | reg-reg move inserted during join to targets + | SpillJoinRR !Unique + + -- | reg-mem move inserted during join to targets + | SpillJoinRM !Unique + + +-- | Used to carry interesting stats out of the register allocator. +data RegAllocStats + = RegAllocStats + { ra_spillInstrs :: UniqFM Unique [Int] -- Keys are the uniques of regs + -- and taken from SpillReason + -- See Note [UniqFM and the register allocator] + , ra_fixupList :: [(BlockId,BlockId,BlockId)] + -- ^ (from,fixup,to) : We inserted fixup code between from and to + } + + +-- | The register allocator state +data RA_State freeRegs + = RA_State + + { + -- | the current mapping from basic blocks to + -- the register assignments at the beginning of that block. + ra_blockassig :: BlockAssignment freeRegs + + -- | free machine registers + , ra_freeregs :: !freeRegs + + -- | assignment of temps to locations + , ra_assig :: RegMap Loc + + -- | current stack delta + , ra_delta :: Int + + -- | free stack slots for spilling + , ra_stack :: StackMap + + -- | unique supply for generating names for join point fixup blocks. + , ra_us :: DUniqSupply + + -- | Record why things were spilled, for -ddrop-asm-stats. + -- Just keep a list here instead of a map of regs -> reasons. + -- We don't want to slow down the allocator if we're not going to emit the stats. + , ra_spills :: [SpillReason] + + -- | Native code generator configuration + , ra_config :: !NCGConfig + + -- | (from,fixup,to) : We inserted fixup code between from and to + , ra_fixups :: [(BlockId,BlockId,BlockId)] + + } + diff --git a/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs b/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs @@ -0,0 +1,112 @@ +module GHC.CmmToAsm.Reg.Linear.FreeRegs ( + FR(..), + allFreeRegs, + maxSpillSlots +) +where + +import GHC.Prelude + +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import qualified GHC.Platform.Reg.Class.Unified as Unified +import qualified GHC.Platform.Reg.Class.Separate as Separate +import qualified GHC.Platform.Reg.Class.NoVectors as NoVectors + +import GHC.CmmToAsm.Config +import GHC.Utils.Panic +import GHC.Platform + +-- ----------------------------------------------------------------------------- +-- The free register set +-- This needs to be *efficient* +-- Here's an inefficient 'executable specification' of the FreeRegs data type: +-- +-- type FreeRegs = [RegNo] +-- noFreeRegs = 0 +-- releaseReg n f = if n `elem` f then f else (n : f) +-- initFreeRegs = allocatableRegs +-- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f +-- allocateReg f r = filter (/= r) f + +import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC +import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 +import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 +import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 +import qualified GHC.CmmToAsm.Reg.Linear.RV64 as RV64 +import qualified GHC.CmmToAsm.Reg.Linear.LA64 as LA64 + +import qualified GHC.CmmToAsm.PPC.Instr as PPC.Instr +import qualified GHC.CmmToAsm.X86.Instr as X86.Instr +import qualified GHC.CmmToAsm.AArch64.Instr as AArch64.Instr +import qualified GHC.CmmToAsm.RV64.Instr as RV64.Instr +import qualified GHC.CmmToAsm.LA64.Instr as LA64.Instr + +class Show freeRegs => FR freeRegs where + frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs + frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg] + frInitFreeRegs :: Platform -> freeRegs + frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs + +instance FR X86.FreeRegs where + frAllocateReg = \_ -> X86.allocateReg + frGetFreeRegs = X86.getFreeRegs + frInitFreeRegs = X86.initFreeRegs + frReleaseReg = \_ -> X86.releaseReg + +instance FR X86_64.FreeRegs where + frAllocateReg = \_ -> X86_64.allocateReg + frGetFreeRegs = X86_64.getFreeRegs + frInitFreeRegs = X86_64.initFreeRegs + frReleaseReg = \_ -> X86_64.releaseReg + +instance FR PPC.FreeRegs where + frAllocateReg = \_ -> PPC.allocateReg + frGetFreeRegs = \_ -> PPC.getFreeRegs + frInitFreeRegs = PPC.initFreeRegs + frReleaseReg = \_ -> PPC.releaseReg + +instance FR AArch64.FreeRegs where + frAllocateReg = \_ -> AArch64.allocateReg + frGetFreeRegs = \_ -> AArch64.getFreeRegs + frInitFreeRegs = AArch64.initFreeRegs + frReleaseReg = \_ -> AArch64.releaseReg + +instance FR RV64.FreeRegs where + frAllocateReg = const RV64.allocateReg + frGetFreeRegs = const RV64.getFreeRegs + frInitFreeRegs = RV64.initFreeRegs + frReleaseReg = const RV64.releaseReg + +instance FR LA64.FreeRegs where + frAllocateReg = \_ -> LA64.allocateReg + frGetFreeRegs = \_ -> LA64.getFreeRegs + frInitFreeRegs = LA64.initFreeRegs + frReleaseReg = \_ -> LA64.releaseReg + +allFreeRegs :: FR freeRegs => Platform -> freeRegs -> [RealReg] +allFreeRegs plat fr = foldMap (\rcls -> frGetFreeRegs plat rcls fr) allRegClasses + where + allRegClasses = + case registerArch (platformArch plat) of + Unified -> Unified.allRegClasses + Separate -> Separate.allRegClasses + NoVectors -> NoVectors.allRegClasses + +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config = case platformArch (ncgPlatform config) of + ArchX86 -> X86.Instr.maxSpillSlots config + ArchX86_64 -> X86.Instr.maxSpillSlots config + ArchPPC -> PPC.Instr.maxSpillSlots config + ArchS390X -> panic "maxSpillSlots ArchS390X" + ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" + ArchAArch64 -> AArch64.Instr.maxSpillSlots config + ArchPPC_64 _ -> PPC.Instr.maxSpillSlots config + ArchAlpha -> panic "maxSpillSlots ArchAlpha" + ArchMipseb -> panic "maxSpillSlots ArchMipseb" + ArchMipsel -> panic "maxSpillSlots ArchMipsel" + ArchRISCV64 -> RV64.Instr.maxSpillSlots config + ArchLoongArch64 -> LA64.Instr.maxSpillSlots config + ArchJavaScript-> panic "maxSpillSlots ArchJavaScript" + ArchWasm32 -> panic "maxSpillSlots ArchWasm32" + ArchUnknown -> panic "maxSpillSlots ArchUnknown" diff --git a/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs @@ -0,0 +1,378 @@ +-- | Handles joining of a jump instruction to its targets. + +-- The first time we encounter a jump to a particular basic block, we +-- record the assignment of temporaries. The next time we encounter a +-- jump to the same block, we compare our current assignment to the +-- stored one. They might be different if spilling has occurred in one +-- branch; so some fixup code will be required to match up the assignments. +-- +module GHC.CmmToAsm.Reg.Linear.JoinToTargets (joinToTargets) where + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Linear.State +import GHC.CmmToAsm.Reg.Linear.Base +import GHC.CmmToAsm.Reg.Linear.FreeRegs +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types + +import GHC.Platform.Reg + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label +import GHC.Data.Graph.Directed +import GHC.Data.Maybe +import GHC.Utils.Panic +import GHC.Utils.Monad (concatMapM) +import GHC.Types.Unique +import GHC.Types.Unique.FM + +import GHC.Utils.Outputable +import GHC.CmmToAsm.Format +import GHC.Types.Unique.Set + +-- | For a jump instruction at the end of a block, generate fixup code so its +-- vregs are in the correct regs for its destination. +-- +joinToTargets + :: (FR freeRegs, Instruction instr) + => BlockMap (UniqSet RegWithFormat) -- ^ maps the unique of the blockid to the set of vregs + -- that are known to be live on the entry to each block. + + -> BlockId -- ^ id of the current block + -> instr -- ^ branch instr on the end of the source block. + + -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code. + , instr) -- the original branch + -- instruction, but maybe + -- patched to jump + -- to a fixup block first. + +joinToTargets block_live id instr + + -- we only need to worry about jump instructions. + | not $ isJumpishInstr instr + = return ([], instr) + + | otherwise + = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) + +----- +joinToTargets' + :: (FR freeRegs, Instruction instr) + => BlockMap (UniqSet RegWithFormat) -- ^ maps the unique of the blockid to the set of vregs + -- that are known to be live on the entry to each block. + + -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. + + -> BlockId -- ^ id of the current block + -> instr -- ^ branch instr on the end of the source block. + + -> [BlockId] -- ^ branch destinations still to consider. + + -> RegM freeRegs ([NatBasicBlock instr], instr) + +-- no more targets to consider. all done. +joinToTargets' _ new_blocks _ instr [] + = return (new_blocks, instr) + +-- handle a branch target. +joinToTargets' block_live new_blocks block_id instr (dest:dests) + = do + -- get the map of where the vregs are stored on entry to each basic block. + block_assig <- getBlockAssigR + + -- get the assignment on entry to the branch instruction. + assig <- getAssigR + + -- adjust the current assignment to remove any vregs that are not live + -- on entry to the destination block. + let live_set = expectJust $ mapLookup dest block_live + let still_live uniq _ = uniq `elemUniqSet_Directly` live_set + let adjusted_assig = filterUFM_Directly still_live assig + + -- and free up those registers which are now free. + let to_free = + [ r | (reg, loc) <- nonDetUFMToList assig + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + , not (elemUniqSet_Directly reg live_set) + , r <- regsOfLoc loc ] + + case lookupBlockAssignment dest block_assig of + Nothing + -> joinToTargets_first + block_live new_blocks block_id instr dest dests + block_assig adjusted_assig $ map realReg to_free + + Just (_, dest_assig) + -> joinToTargets_again + block_live new_blocks block_id instr dest dests + adjusted_assig dest_assig + + +-- this is the first time we jumped to this block. +joinToTargets_first :: (FR freeRegs, Instruction instr) + => BlockMap (UniqSet RegWithFormat) + -> [NatBasicBlock instr] + -> BlockId + -> instr + -> BlockId + -> [BlockId] + -> BlockAssignment freeRegs + -> RegMap Loc + -> [RealReg] + -> RegM freeRegs ([NatBasicBlock instr], instr) +joinToTargets_first block_live new_blocks block_id instr dest dests + block_assig src_assig + to_free + + = do config <- getConfig + let platform = ncgPlatform config + + -- free up the regs that are not live on entry to this block. + freeregs <- getFreeRegsR + let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free + + -- remember the current assignment on entry to this block. + setBlockAssigR (updateBlockAssignment dest (freeregs', src_assig) block_assig) + + joinToTargets' block_live new_blocks block_id instr dests + + +-- we've jumped to this block before +joinToTargets_again :: (Instruction instr, FR freeRegs) + => BlockMap (UniqSet RegWithFormat) + -> [NatBasicBlock instr] + -> BlockId + -> instr + -> BlockId + -> [BlockId] + -> UniqFM Reg Loc + -> UniqFM Reg Loc + -> RegM freeRegs ([NatBasicBlock instr], instr) +joinToTargets_again + block_live new_blocks block_id instr dest dests + src_assig dest_assig + + -- the assignments already match, no problem. + | nonDetUFMToList dest_assig == nonDetUFMToList src_assig + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + = joinToTargets' block_live new_blocks block_id instr dests + + -- assignments don't match, need fixup code + | otherwise + = do + + -- make a graph of what things need to be moved where. + let graph = makeRegMovementGraph src_assig dest_assig + + -- look for cycles in the graph. This can happen if regs need to be swapped. + -- Note that we depend on the fact that this function does a + -- bottom up traversal of the tree-like portions of the graph. + -- + -- eg, if we have + -- R1 -> R2 -> R3 + -- + -- ie move value in R1 to R2 and value in R2 to R3. + -- + -- We need to do the R2 -> R3 move before R1 -> R2. + -- + let sccs = stronglyConnCompFromEdgedVerticesOrdR graph + + -- debugging + {- + pprTrace + ("joinToTargets: making fixup code") + (vcat [ text " in block: " <> ppr block_id + , text " jmp instruction: " <> ppr instr + , text " src assignment: " <> ppr src_assig + , text " dest assignment: " <> ppr dest_assig + , text " movement graph: " <> ppr graph + , text " sccs of graph: " <> ppr sccs + , text ""]) + (return ()) + -} + delta <- getDeltaR + fixUpInstrs <- concatMapM (handleComponent delta instr) sccs + + -- make a new basic block containing the fixup code. + -- A the end of the current block we will jump to the fixup one, + -- then that will jump to our original destination. + fixup_block_id <- mkBlockId <$> getUniqueR + let block = BasicBlock fixup_block_id + $ fixUpInstrs ++ mkJumpInstr dest + + -- if we didn't need any fixups, then don't include the block + case fixUpInstrs of + [] -> joinToTargets' block_live new_blocks block_id instr dests + + -- patch the original branch instruction so it goes to our + -- fixup block instead. + _ -> let instr' = patchJumpInstr instr + (\bid -> if bid == dest + then fixup_block_id + else bid) -- no change! + + in do + {- --debugging + pprTrace "FixUpEdge info:" + ( + text "inBlock:" <> ppr block_id $$ + text "instr:" <> ppr instr $$ + text "instr':" <> ppr instr' $$ + text "fixup_block_id':" <> + ppr fixup_block_id $$ + text "dest:" <> ppr dest + ) (return ()) + -} + recordFixupBlock block_id fixup_block_id dest + joinToTargets' block_live (block : new_blocks) + block_id instr' dests + + +-- | Construct a graph of register\/spill movements. +-- +-- Cyclic components seem to occur only very rarely. +-- +-- We cut some corners by not handling memory-to-memory moves. +-- This shouldn't happen because every temporary gets its own stack slot. +-- +makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [Node Loc Unique] +makeRegMovementGraph adjusted_assig dest_assig + = [ node | (vreg, src) <- nonDetUFMToList adjusted_assig + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + -- source reg might not be needed at the dest: + , Just loc <- [lookupUFM_Directly dest_assig vreg] + , node <- expandNode vreg src loc ] + + +-- | Expand out the destination, so InBoth destinations turn into +-- a combination of InReg and InMem. + +-- The InBoth handling is a little tricky here. If the destination is +-- InBoth, then we must ensure that the value ends up in both locations. +-- An InBoth destination must conflict with an InReg or InMem source, so +-- we expand an InBoth destination as necessary. +-- +-- An InBoth source is slightly different: we only care about the register +-- that the source value is in, so that we can move it to the destinations. +-- +expandNode + :: a + -> Loc -- ^ source of move + -> Loc -- ^ destination of move + -> [Node Loc a ] + +expandNode vreg loc@(InReg src) (InBoth dst mem) + | src == dst = [DigraphNode vreg loc [InMem mem]] + | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]] + +expandNode vreg loc@(InMem src) (InBoth dst mem) + | src == mem = [DigraphNode vreg loc [InReg dst]] + | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]] + +expandNode _ (InBoth _ src) (InMem dst) + | src == dst = [] -- guaranteed to be true + +expandNode _ (InBoth src _) (InReg dst) + | src == dst = [] + +expandNode vreg (InBoth src _) dst + = expandNode vreg (InReg src) dst + +expandNode vreg src dst + | src == dst = [] + | otherwise = [DigraphNode vreg src [dst]] + + +-- | Generate fixup code for a particular component in the move graph +-- This component tells us what values need to be moved to what +-- destinations. We have eliminated any possibility of single-node +-- cycles in expandNode above. +-- +handleComponent + :: Instruction instr + => Int -> instr -> SCC (Node Loc Unique) + -> RegM freeRegs [instr] + +-- If the graph is acyclic then we won't get the swapping problem below. +-- In this case we can just do the moves directly, and avoid having to +-- go via a spill slot. +-- +handleComponent delta _ (AcyclicSCC (DigraphNode vreg src dsts)) + = concatMapM (makeMove delta vreg src) dsts + + +-- Handle some cyclic moves. +-- This can happen if we have two regs that need to be swapped. +-- eg: +-- vreg source loc dest loc +-- (vreg1, InReg r1, [InReg r2]) +-- (vreg2, InReg r2, [InReg r1]) +-- +-- To avoid needing temp register, we just spill all the source regs, then +-- reaload them into their destination regs. +-- +-- Note that we can not have cycles that involve memory locations as +-- sources as single destination because memory locations (stack slots) +-- are allocated exclusively for a virtual register and therefore can not +-- require a fixup. +-- +handleComponent delta instr + (CyclicSCC ((DigraphNode vreg (InReg (RealRegUsage sreg scls)) ((InReg (RealRegUsage dreg dcls): _))) : rest)) + -- dest list may have more than one element, if the reg is also InMem. + = do + -- spill the source into its slot + (instrSpill, slot) + <- spillR (RegWithFormat (RegReal sreg) scls) vreg + + -- reload into destination reg + instrLoad <- loadR (RegWithFormat (RegReal dreg) dcls) slot + + remainingFixUps <- mapM (handleComponent delta instr) + (stronglyConnCompFromEdgedVerticesOrdR rest) + + -- make sure to do all the reloads after all the spills, + -- so we don't end up clobbering the source values. + return (instrSpill ++ concat remainingFixUps ++ instrLoad) + +handleComponent _ _ (CyclicSCC _) + = panic "Register Allocator: handleComponent cyclic" + + +-- | Move a vreg between these two locations. +-- +makeMove + :: Instruction instr + => Int -- ^ current C stack delta. + -> Unique -- ^ unique of the vreg that we're moving. + -> Loc -- ^ source location. + -> Loc -- ^ destination location. + -> RegM freeRegs [instr] -- ^ move instruction. + +makeMove delta vreg src dst + = do config <- getConfig + case (src, dst) of + (InReg (RealRegUsage s _), InReg (RealRegUsage d fmt)) -> + do recordSpill (SpillJoinRR vreg) + return $ [mkRegRegMoveInstr config fmt (RegReal s) (RegReal d)] + (InMem s, InReg (RealRegUsage d cls)) -> + do recordSpill (SpillJoinRM vreg) + return $ mkLoadInstr config (RegWithFormat (RegReal d) cls) delta s + (InReg (RealRegUsage s cls), InMem d) -> + do recordSpill (SpillJoinRM vreg) + return $ mkSpillInstr config (RegWithFormat (RegReal s) cls) delta d + _ -> + -- we don't handle memory to memory moves. + -- they shouldn't happen because we don't share + -- stack slots between vregs. + pprPanic "makeMove: we don't handle mem->mem moves" + (ppr vreg <+> parens (ppr src) <+> parens (ppr dst)) diff --git a/GHC/CmmToAsm/Reg/Linear/LA64.hs b/GHC/CmmToAsm/Reg/Linear/LA64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/LA64.hs @@ -0,0 +1,71 @@ +module GHC.CmmToAsm.Reg.Linear.LA64 where + +import GHC.Prelude + +import Data.Word +import GHC.CmmToAsm.LA64.Regs +import GHC.Platform +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import GHC.Platform.Reg.Class.Separate +import GHC.Stack +import GHC.Utils.Outputable +import GHC.Utils.Panic + +data FreeRegs = FreeRegs !Word32 !Word32 + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 0 + +instance Show FreeRegs where + show (FreeRegs g f) = "FreeRegs 0b" ++ showBits g ++ " 0b" ++ showBits f + +-- | Show bits as a `String` of @1@s and @0@s +showBits :: Word32 -> String +showBits w = map (\i -> if testBit w i then '1' else '0') [0 .. 31] + +instance Outputable FreeRegs where + ppr (FreeRegs g f) = + text " " <+> foldr (\i x -> pad_int i <+> x) (text "") [0 .. 31] + $$ text "GPR" <+> foldr (\i x -> show_bit g i <+> x) (text "") [0 .. 31] + $$ text "FPR" <+> foldr (\i x -> show_bit f i <+> x) (text "") [0 .. 31] + where + pad_int i | i < 10 = char ' ' <> int i + pad_int i = int i + -- remember bit = 1 means it's available. + show_bit bits bit | testBit bits bit = text " " + show_bit _ _ = text " x" + +-- | Set bits of all allocatable registers to 1 +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) + +-- | Get all free `RealReg`s (i.e. those where the corresponding bit is 1) +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] +getFreeRegs cls (FreeRegs g f) + | RcInteger <- cls = go 0 g allocatableIntRegs + | RcFloat <- cls = go 32 f allocatableDoubleRegs + | RcVector <- cls = sorry "Linear.LA64.getFreeRegs: vector registers are not supported" + where + go _ _ [] = [] + go off x (i : is) + | testBit x i = RealRegSingle (off + i) : (go off x $! is) + | otherwise = go off x $! is + allocatableIntRegs = [4 .. 11] ++ [12 .. 19] + allocatableDoubleRegs = [0 .. 7] ++ [8 .. 23] + +-- | Set corresponding register bit to 0 +allocateReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs g f) + | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) + | r < 32 && testBit g r = FreeRegs (clearBit g r) f + | r > 31 = panic $ "Linear.LA64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f + | otherwise = pprPanic "Linear.LA64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g) + +-- | Set corresponding register bit to 1 +releaseReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle r) (FreeRegs g f) + | r > 31 && testBit f (r - 32) = pprPanic "Linear.LA64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32)) + | r < 32 && testBit g r = pprPanic "Linear.LA64.releaseReg" (text "can't release non-allocated reg x" <> int r) + | r > 31 = FreeRegs g (setBit f (r - 32)) + | otherwise = FreeRegs (setBit g r) f diff --git a/GHC/CmmToAsm/Reg/Linear/PPC.hs b/GHC/CmmToAsm/Reg/Linear/PPC.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/PPC.hs @@ -0,0 +1,57 @@ +-- | Free regs map for PowerPC +module GHC.CmmToAsm.Reg.Linear.PPC where + +import GHC.Prelude + +import GHC.CmmToAsm.PPC.Regs +import GHC.Platform.Reg.Class.Unified +import GHC.Platform.Reg + +import GHC.Utils.Outputable +import GHC.Platform + +import Data.Word + +-- The PowerPC has 32 integer and 32 floating point registers. +-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much +-- better. +-- Note that when getFreeRegs scans for free registers, it starts at register +-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered +-- registers are callee-saves, while the lower regs are caller-saves, so it +-- makes sense to start at the high end. +-- Apart from that, the code does nothing PowerPC-specific, so feel free to +-- add your favourite platform to the #if (if you have 64 registers but only +-- 32-bit words). + +data FreeRegs = FreeRegs !Word32 !Word32 + deriving( Show ) -- The Show is used in an ASSERT + +instance Outputable FreeRegs where + ppr = text . show + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 0 + +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle r) (FreeRegs g f) + | r > 31 = FreeRegs g (f .|. (1 `shiftL` (r - 32))) + | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) + +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs cls (FreeRegs g f) = + case cls of + RcFloatOrVector -> go f (0x80000000) 63 + RcInteger -> go g (0x80000000) 31 + where + go _ 0 _ = [] + go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1) + | otherwise = go x (m `shiftR` 1) $! i-1 + +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs g f) + | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (r - 32))) + | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f + diff --git a/GHC/CmmToAsm/Reg/Linear/RV64.hs b/GHC/CmmToAsm/Reg/Linear/RV64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/RV64.hs @@ -0,0 +1,99 @@ +-- | Functions to implement the @FR@ (as in "free regs") type class. +-- +-- For LLVM GHC calling convention (used registers), see +-- https://github.com/llvm/llvm-project/blob/6ab900f8746e7d8e24afafb5886a40801f6799f4/llvm/lib/Target/RISCV/RISCVISelLowering.cpp#L13638-L13685 +module GHC.CmmToAsm.Reg.Linear.RV64 + ( allocateReg, + getFreeRegs, + initFreeRegs, + releaseReg, + FreeRegs (..), + ) +where + +import Data.Word +import GHC.CmmToAsm.RV64.Regs +import GHC.Platform +import GHC.Platform.Reg +import GHC.Platform.Reg.Class.Separate +import GHC.Prelude +import GHC.Stack +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- | Bitmaps to indicate which registers are free (currently unused) +-- +-- The bit index represents the `RegNo`, in case of floating point registers +-- with an offset of 32. The register is free when the bit is set. +data FreeRegs + = FreeRegs + -- | integer/general purpose registers (`RcInteger`) + !Word32 + -- | floating point registers (`RcDouble`) + !Word32 + +instance Show FreeRegs where + show (FreeRegs g f) = "FreeRegs 0b" ++ showBits g ++ " 0b" ++ showBits f + +-- | Show bits as a `String` of @1@s and @0@s +showBits :: Word32 -> String +showBits w = map (\i -> if testBit w i then '1' else '0') [0 .. 31] + +instance Outputable FreeRegs where + ppr (FreeRegs g f) = + text " " + <+> foldr (\i x -> pad_int i <+> x) (text "") [0 .. 31] + $$ text "GPR" + <+> foldr (\i x -> show_bit g i <+> x) (text "") [0 .. 31] + $$ text "FPR" + <+> foldr (\i x -> show_bit f i <+> x) (text "") [0 .. 31] + where + pad_int i | i < 10 = char ' ' <> int i + pad_int i = int i + -- remember bit = 1 means it's available. + show_bit bits bit | testBit bits bit = text " " + show_bit _ _ = text " x" + +-- | Set bits of all allocatable registers to 1 +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) + where + noFreeRegs :: FreeRegs + noFreeRegs = FreeRegs 0 0 + +-- | Get all free `RealReg`s (i.e. those where the corresponding bit is 1) +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] +getFreeRegs cls (FreeRegs g f) = + case cls of + RcInteger -> go 0 g allocatableIntRegs + RcFloat -> go 32 f allocatableDoubleRegs + RcVector -> + sorry "Linear.RV64.getFreeRegs: vector registers are not supported" + + where + go _ _ [] = [] + go off x (i : is) + | testBit x i = RealRegSingle (off + i) : (go off x $! is) + | otherwise = go off x $! is + -- The lists of allocatable registers are manually crafted: Register + -- allocation is pretty hot code. We don't want to iterate and map like + -- `initFreeRegs` all the time! (The register mappings aren't supposed to + -- change often.) + allocatableIntRegs = [5 .. 7] ++ [10 .. 17] ++ [28 .. 30] + allocatableDoubleRegs = [0 .. 7] ++ [10 .. 17] ++ [28 .. 31] + +-- | Set corresponding register bit to 0 +allocateReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs g f) + | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) + | r < 32 && testBit g r = FreeRegs (clearBit g r) f + | r > 31 = panic $ "Linear.RV64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f + | otherwise = pprPanic "Linear.RV64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g) + +-- | Set corresponding register bit to 1 +releaseReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle r) (FreeRegs g f) + | r > 31 && testBit f (r - 32) = pprPanic "Linear.RV64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32)) + | r < 32 && testBit g r = pprPanic "Linear.RV64.releaseReg" (text "can't release non-allocated reg x" <> int r) + | r > 31 = FreeRegs g (setBit f (r - 32)) + | otherwise = FreeRegs (setBit g r) f diff --git a/GHC/CmmToAsm/Reg/Linear/StackMap.hs b/GHC/CmmToAsm/Reg/Linear/StackMap.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/StackMap.hs @@ -0,0 +1,65 @@ + +-- | The assignment of virtual registers to stack slots + +-- We have lots of stack slots. Memory-to-memory moves are a pain on most +-- architectures. Therefore, we avoid having to generate memory-to-memory moves +-- by simply giving every virtual register its own stack slot. + +-- The StackMap stack map keeps track of virtual register - stack slot +-- associations and of which stack slots are still free. Once it has been +-- associated, a stack slot is never "freed" or removed from the StackMap again, +-- it remains associated until we are done with the current CmmProc. +-- +module GHC.CmmToAsm.Reg.Linear.StackMap ( + StackSlot, + StackMap(..), + emptyStackMap, + getStackSlotFor, + getStackUse +) + +where + +import GHC.Prelude + +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.CmmToAsm.Format + + +-- | Identifier for a stack slot. +type StackSlot = Int + +data StackMap + = StackMap + { -- | The slots that are still available to be allocated. + stackMapNextFreeSlot :: !Int + + -- See Note [UniqFM and the register allocator] + -- | Assignment of vregs to stack slots. + , stackMapAssignment :: UniqFM Unique StackSlot } + + +-- | An empty stack map, with all slots available. +emptyStackMap :: StackMap +emptyStackMap = StackMap 0 emptyUFM + + +-- | If this vreg unique already has a stack assignment then return the slot number, +-- otherwise allocate a new slot, and update the map. +-- +getStackSlotFor :: StackMap -> Format -> Unique -> (StackMap, Int) + +getStackSlotFor fs@(StackMap _ reserved) _fmt regUnique + | Just slot <- lookupUFM reserved regUnique = (fs, slot) + +getStackSlotFor (StackMap freeSlot reserved) fmt regUnique = + let + nbSlots = (formatInBytes fmt + 7) `div` 8 + in + (StackMap (freeSlot+nbSlots) (addToUFM reserved regUnique freeSlot), freeSlot) + +-- | Return the number of stack slots that were allocated +getStackUse :: StackMap -> Int +getStackUse (StackMap freeSlot _) = freeSlot + diff --git a/GHC/CmmToAsm/Reg/Linear/State.hs b/GHC/CmmToAsm/Reg/Linear/State.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/State.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE PatternSynonyms, DeriveFunctor, DerivingVia #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | State monad for the linear register allocator. + +-- Here we keep all the state that the register allocator keeps track +-- of as it walks the instructions in a basic block. + +module GHC.CmmToAsm.Reg.Linear.State ( + RA_State(..), + RegM, + runR, + + spillR, + loadR, + + getFreeRegsR, + setFreeRegsR, + + getAssigR, + setAssigR, + + getBlockAssigR, + setBlockAssigR, + + setDeltaR, + getDeltaR, + + getUniqueR, + getConfig, + getPlatform, + + recordSpill, + recordFixupBlock +) +where + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Linear.Stats +import GHC.CmmToAsm.Reg.Linear.StackMap +import GHC.CmmToAsm.Reg.Linear.Base +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Config +import GHC.Cmm.BlockId + +import GHC.Platform +import GHC.Types.Unique +import GHC.Types.Unique.DSM +import GHC.Exts (oneShot) + +import GHC.Utils.Monad.State.Strict as Strict + +type RA_Result freeRegs a = (# a, RA_State freeRegs #) + +pattern RA_Result :: a -> b -> (# b, a #) +pattern RA_Result a b = (# b, a #) +{-# COMPLETE RA_Result #-} + +-- | The register allocator monad type. +newtype RegM freeRegs a + = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a } + deriving (Functor, Applicative, Monad) via (Strict.State (RA_State freeRegs)) + +-- | Smart constructor for 'RegM', as described in Note [The one-shot state +-- monad trick] in GHC.Utils.Monad. +mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a +mkRegM f = RegM (oneShot f) + +-- | Get native code generator configuration +getConfig :: RegM a NCGConfig +getConfig = mkRegM $ \s -> RA_Result s (ra_config s) + +-- | Get target platform from native code generator configuration +getPlatform :: RegM a Platform +getPlatform = ncgPlatform <$> getConfig + +-- | Run a computation in the RegM register allocator monad. +runR :: NCGConfig + -> BlockAssignment freeRegs + -> freeRegs + -> RegMap Loc + -> StackMap + -> DUniqSupply + -> RegM freeRegs a + -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a, DUniqSupply) + +runR config block_assig freeregs assig stack us thing = + case unReg thing + (RA_State + { ra_blockassig = block_assig + , ra_freeregs = freeregs + , ra_assig = assig + , ra_delta = 0{-???-} + , ra_stack = stack + , ra_us = us + , ra_spills = [] + , ra_config = config + , ra_fixups = [] }) + of + RA_Result state returned_thing + -> (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing, ra_us state) + + +-- | Make register allocator stats from its final state. +makeRAStats :: RA_State freeRegs -> RegAllocStats +makeRAStats state + = RegAllocStats + { ra_spillInstrs = binSpillReasons (ra_spills state) + , ra_fixupList = ra_fixups state } + + +spillR :: Instruction instr + => RegWithFormat -> Unique -> RegM freeRegs ([instr], Int) + +spillR reg temp = mkRegM $ \s -> + let (stack1,slots) = getStackSlotFor (ra_stack s) (regWithFormat_format reg) temp + instr = mkSpillInstr (ra_config s) reg (ra_delta s) slots + in + RA_Result s{ra_stack=stack1} (instr,slots) + + +loadR :: Instruction instr + => RegWithFormat -> Int -> RegM freeRegs [instr] + +loadR reg slot = mkRegM $ \s -> + RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot) + +getFreeRegsR :: RegM freeRegs freeRegs +getFreeRegsR = mkRegM $ \ s@RA_State{ra_freeregs = freeregs} -> + RA_Result s freeregs + +setFreeRegsR :: freeRegs -> RegM freeRegs () +setFreeRegsR regs = mkRegM $ \ s -> + RA_Result s{ra_freeregs = regs} () + +getAssigR :: RegM freeRegs (RegMap Loc) +getAssigR = mkRegM $ \ s@RA_State{ra_assig = assig} -> + RA_Result s assig + +setAssigR :: RegMap Loc -> RegM freeRegs () +setAssigR assig = mkRegM $ \ s -> + RA_Result s{ra_assig=assig} () + +getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) +getBlockAssigR = mkRegM $ \ s@RA_State{ra_blockassig = assig} -> + RA_Result s assig + +setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs () +setBlockAssigR assig = mkRegM $ \ s -> + RA_Result s{ra_blockassig = assig} () + +setDeltaR :: Int -> RegM freeRegs () +setDeltaR n = mkRegM $ \ s -> + RA_Result s{ra_delta = n} () + +getDeltaR :: RegM freeRegs Int +getDeltaR = mkRegM $ \s -> RA_Result s (ra_delta s) + +getUniqueR :: RegM freeRegs Unique +getUniqueR = mkRegM $ \s -> + case takeUniqueFromDSupply (ra_us s) of + (uniq, us) -> RA_Result s{ra_us = us} uniq + + +-- | Record that a spill instruction was inserted, for profiling. +recordSpill :: SpillReason -> RegM freeRegs () +recordSpill spill + = mkRegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) () + +-- | Record a created fixup block +recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs () +recordFixupBlock from between to + = mkRegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) () diff --git a/GHC/CmmToAsm/Reg/Linear/Stats.hs b/GHC/CmmToAsm/Reg/Linear/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/Stats.hs @@ -0,0 +1,93 @@ +module GHC.CmmToAsm.Reg.Linear.Stats ( + binSpillReasons, + countRegRegMovesNat, + pprStats +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Linear.Base +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Instr +import GHC.Types.Unique (Unique) +import GHC.CmmToAsm.Types + +import GHC.Types.Unique.FM + +import GHC.Utils.Outputable +import GHC.Utils.Monad.State.Strict +import GHC.Platform (Platform) + +-- | Build a map of how many times each reg was alloced, clobbered, loaded etc. +binSpillReasons + :: [SpillReason] -> UniqFM Unique [Int] + -- See Note [UniqFM and the register allocator] +binSpillReasons reasons + = addListToUFM_C + (zipWith (+)) + emptyUFM + (map (\reason -> case reason of + SpillAlloc r -> (r, [1, 0, 0, 0, 0]) + SpillClobber r -> (r, [0, 1, 0, 0, 0]) + SpillLoad r -> (r, [0, 0, 1, 0, 0]) + SpillJoinRR r -> (r, [0, 0, 0, 1, 0]) + SpillJoinRM r -> (r, [0, 0, 0, 0, 1])) reasons) + + +-- | Count reg-reg moves remaining in this code. +countRegRegMovesNat + :: Instruction instr + => Platform + -> NatCmmDecl statics instr -> Int + +countRegRegMovesNat platform cmm + = execState (mapGenBlockTopM countBlock cmm) 0 + where + countBlock b@(BasicBlock _ instrs) + = do mapM_ countInstr instrs + return b + + countInstr instr + | Just _ <- takeRegRegMoveInstr platform instr + = do modify (+ 1) + return instr + + | otherwise + = return instr + + +-- | Pretty print some RegAllocStats +pprStats + :: Instruction instr + => Platform -> [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc + +pprStats platform code statss + = let -- sum up all the instrs inserted by the spiller + -- See Note [UniqFM and the register allocator] + spills :: UniqFM Unique [Int] + spills = foldl' (plusUFM_C (zipWith (+))) + emptyUFM + $ map ra_spillInstrs statss + + spillTotals = foldl' (zipWith (+)) + [0, 0, 0, 0, 0] + $ nonDetEltsUFM spills + -- See Note [Unique Determinism and code generation] + + -- count how many reg-reg-moves remain in the code + moves = sum $ map (countRegRegMovesNat platform) code + + pprSpill (reg, spills) + = parens $ (hcat $ punctuate (text ", ") (doubleQuotes (ppr reg) : map ppr spills)) + + in ( text "-- spills-added-total" + $$ text "-- (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)" + $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves]))) + $$ text "" + $$ text "-- spills-added" + $$ text "-- (reg_name, allocs, clobbers, loads, joinRR, joinRM)" + $$ (pprUFMWithKeys spills (vcat . map pprSpill)) + $$ text "") + diff --git a/GHC/CmmToAsm/Reg/Linear/X86.hs b/GHC/CmmToAsm/Reg/Linear/X86.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/X86.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Free regs map for i386 +module GHC.CmmToAsm.Reg.Linear.X86 where + +import GHC.Prelude + +import GHC.CmmToAsm.X86.Regs +import GHC.Platform.Reg.Class.Unified +import GHC.Platform.Reg +import GHC.Platform +import GHC.Utils.Outputable + +import Data.Word + +newtype FreeRegs = FreeRegs Word32 + deriving (Show,Outputable) + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 + +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle n) (FreeRegs f) + = FreeRegs (setBit f n) + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) + +getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs platform cls (FreeRegs f) = + case cls of + RcInteger -> + [ RealRegSingle i + | i <- intregnos platform + , testBit f i + ] + RcFloatOrVector -> + [ RealRegSingle i + | i <- xmmregnos platform + , testBit f i + ] + +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs f) + = FreeRegs (clearBit f r) + diff --git a/GHC/CmmToAsm/Reg/Linear/X86_64.hs b/GHC/CmmToAsm/Reg/Linear/X86_64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/X86_64.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Free regs map for x86_64 +module GHC.CmmToAsm.Reg.Linear.X86_64 where + +import GHC.Prelude + +import GHC.CmmToAsm.X86.Regs +import GHC.Platform.Reg.Class.Unified +import GHC.Platform.Reg +import GHC.Platform +import GHC.Utils.Outputable + +import Data.Word + +newtype FreeRegs = FreeRegs Word64 + deriving (Show,Outputable) + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 + +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle n) (FreeRegs f) + = FreeRegs (setBit f n) + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) + +getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs platform cls (FreeRegs f) = + case cls of + RcInteger -> + [ RealRegSingle i + | i <- intregnos platform + , testBit f i + ] + RcFloatOrVector -> + [ RealRegSingle i + | i <- xmmregnos platform + , testBit f i + ] + +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs f) + = FreeRegs (clearBit f r) + diff --git a/GHC/CmmToAsm/Reg/Liveness.hs b/GHC/CmmToAsm/Reg/Liveness.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Liveness.hs @@ -0,0 +1,1073 @@ +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- +-- The register liveness determinator +-- +-- (c) The University of Glasgow 2004-2013 +-- +----------------------------------------------------------------------------- + +module GHC.CmmToAsm.Reg.Liveness ( + RegMap, emptyRegMap, + BlockMap, + LiveCmmDecl, + InstrSR (..), + LiveInstr (..), + Liveness (..), + LiveInfo (..), + LiveBasicBlock, + + mapBlockTop, mapBlockTopM, mapSCCM, + mapGenBlockTop, mapGenBlockTopM, + mapLiveCmmDecl, pprLiveCmmDecl, + stripLive, + stripLiveBlock, + slurpConflicts, + slurpReloadCoalesce, + eraseDeltasLive, + patchEraseLive, + patchRegsLiveInstr, + reverseBlocksInTops, + regLiveness, + cmmTopLiveness + ) where +import GHC.Prelude + +import GHC.Platform.Reg +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.CmmToAsm.Reg.Target + +import GHC.Data.Graph.Directed +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform +import GHC.Types.Unique (Uniquable(..)) +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSM +import GHC.Data.Bag +import GHC.Utils.Monad.State.Strict + +import Data.List (mapAccumL, sortOn) +import Data.Maybe +import Data.IntSet (IntSet) +import GHC.Utils.Misc + +----------------------------------------------------------------------------- + +-- | Map from some kind of register to a. +-- +-- While we give the type for keys as Reg which is the common case +-- sometimes we end up using VirtualReq or naked Uniques. +-- See Note [UniqFM and the register allocator] +type RegMap a = UniqFM Reg a + +emptyRegMap :: RegMap a +emptyRegMap = emptyUFM + +type BlockMap a = LabelMap a + +type SlotMap a = UniqFM Slot a + +type Slot = Int + +-- | A top level thing which carries liveness information. +type LiveCmmDecl statics instr + = GenCmmDecl + statics + LiveInfo + [SCC (LiveBasicBlock instr)] + + +-- | The register allocator also wants to use SPILL/RELOAD meta instructions, +-- so we'll keep those here. +data InstrSR instr + -- | A real machine instruction + = Instr !instr + + -- | spill this reg to a stack slot + | SPILL !RegWithFormat !Int + + -- | reload this reg from a stack slot + | RELOAD !Int !RegWithFormat + + deriving (Functor) + +instance Instruction instr => Instruction (InstrSR instr) where + regUsageOfInstr platform i + = case i of + Instr instr -> regUsageOfInstr platform instr + SPILL reg _ -> RU [reg] [] + RELOAD _ reg -> RU [] [reg] + + patchRegsOfInstr platform i f + = case i of + Instr instr -> Instr (patchRegsOfInstr platform instr f) + SPILL reg slot -> SPILL (updReg f reg) slot + RELOAD slot reg -> RELOAD slot (updReg f reg) + where + updReg g (RegWithFormat reg fmt) = RegWithFormat (g reg) fmt + + isJumpishInstr :: Instruction instr => InstrSR instr -> Bool + isJumpishInstr i + = case i of + Instr instr -> isJumpishInstr instr + _ -> False + + canFallthroughTo i bid + = case i of + Instr instr -> canFallthroughTo instr bid + _ -> False + + jumpDestsOfInstr i + = case i of + Instr instr -> jumpDestsOfInstr instr + _ -> [] + + patchJumpInstr i f + = case i of + Instr instr -> Instr (patchJumpInstr instr f) + _ -> i + + mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" + mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" + + takeDeltaInstr i + = case i of + Instr instr -> takeDeltaInstr instr + _ -> Nothing + + isMetaInstr i + = case i of + Instr instr -> isMetaInstr instr + _ -> False + + mkRegRegMoveInstr platform fmt r1 r2 + = Instr (mkRegRegMoveInstr platform fmt r1 r2) + + takeRegRegMoveInstr platform i + = case i of + Instr instr -> takeRegRegMoveInstr platform instr + _ -> Nothing + + mkJumpInstr target = map Instr (mkJumpInstr target) + + mkStackAllocInstr platform amount = + Instr <$> mkStackAllocInstr platform amount + + mkStackDeallocInstr platform amount = + Instr <$> mkStackDeallocInstr platform amount + + pprInstr platform i = ppr (fmap (pprInstr platform) i) + + mkComment = fmap Instr . mkComment + + +-- | An instruction with liveness information. +data LiveInstr instr + = LiveInstr (InstrSR instr) (Maybe Liveness) + deriving (Functor) + +-- | Liveness information. +-- The regs which die are ones which are no longer live in the *next* instruction +-- in this sequence. +-- (NB. if the instruction is a jump, these registers might still be live +-- at the jump target(s) - you have to check the liveness at the destination +-- block to find out). + +data Liveness + = Liveness + { liveBorn :: UniqSet RegWithFormat -- ^ registers born in this instruction (written to for first time). + , liveDieRead :: UniqSet RegWithFormat -- ^ registers that died because they were read for the last time. + , liveDieWrite :: UniqSet RegWithFormat} -- ^ registers that died because they were clobbered by something. + + +-- | Stash regs live on entry to each basic block in the info part of the cmm code. +data LiveInfo + = LiveInfo + (LabelMap RawCmmStatics) -- cmm info table static stuff + [BlockId] -- entry points (first one is the + -- entry point for the proc). + (BlockMap (UniqSet RegWithFormat)) -- argument locals live on entry to this block + (BlockMap IntSet) -- stack slots live on entry to this block + + +-- | A basic block with liveness information. +type LiveBasicBlock instr + = GenBasicBlock (LiveInstr instr) + + +instance Outputable instr + => Outputable (InstrSR instr) where + + ppr (Instr realInstr) + = ppr realInstr + + ppr (SPILL (RegWithFormat reg _fmt) slot) + = hcat [ + text "\tSPILL", + char ' ', + ppr reg, + comma, + text "SLOT" <> parens (int slot)] + + ppr (RELOAD slot (RegWithFormat reg _fmt)) + = hcat [ + text "\tRELOAD", + char ' ', + text "SLOT" <> parens (int slot), + comma, + ppr reg] + +instance Outputable instr + => Outputable (LiveInstr instr) where + + ppr (LiveInstr instr Nothing) + = ppr instr + + ppr (LiveInstr instr (Just live)) + = ppr instr + $$ (nest 8 + $ vcat + [ pprRegs (text "# born: ") (liveBorn live) + , pprRegs (text "# r_dying: ") (liveDieRead live) + , pprRegs (text "# w_dying: ") (liveDieWrite live) ] + $+$ space) + + where pprRegs :: SDoc -> UniqSet RegWithFormat -> SDoc + pprRegs name regs + | isEmptyUniqSet regs = empty + | otherwise = name <> + (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr)) + +instance OutputableP env instr => OutputableP env (LiveInstr instr) where + pdoc env i = ppr (fmap (pdoc env) i) + +instance OutputableP Platform LiveInfo where + pdoc env (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) + = (pdoc env mb_static) + $$ text "# entryIds = " <> ppr entryIds + $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry + $$ text "# liveSlotsOnEntry = " <> ppr liveSlotsOnEntry + + + + +-- | map a function across all the basic blocks in this code +-- +mapBlockTop + :: (LiveBasicBlock instr -> LiveBasicBlock instr) + -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr + +mapBlockTop f cmm + = evalState (mapBlockTopM (\x -> return $ f x) cmm) () + + +-- | map a function across all the basic blocks in this code (monadic version) +-- +mapBlockTopM + :: Monad m + => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) + -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr) + +mapBlockTopM _ cmm@(CmmData{}) + = return cmm + +mapBlockTopM f (CmmProc header label live sccs) + = do sccs' <- mapM (mapSCCM f) sccs + return $ CmmProc header label live sccs' + +mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) +mapSCCM f (AcyclicSCC x) + = do x' <- f x + return $ AcyclicSCC x' + +mapSCCM f (CyclicSCC xs) + = do xs' <- mapM f xs + return $ CyclicSCC xs' + + +-- map a function across all the basic blocks in this code +mapGenBlockTop + :: (GenBasicBlock i -> GenBasicBlock i) + -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i)) + +mapGenBlockTop f cmm + = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () + + +-- | map a function across all the basic blocks in this code (monadic version) +mapGenBlockTopM + :: Monad m + => (GenBasicBlock i -> m (GenBasicBlock i)) + -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))) + +mapGenBlockTopM _ cmm@(CmmData{}) + = return cmm + +mapGenBlockTopM f (CmmProc header label live (ListGraph blocks)) + = do blocks' <- mapM f blocks + return $ CmmProc header label live (ListGraph blocks') + + +-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. +-- Slurping of conflicts and moves is wrapped up together so we don't have +-- to make two passes over the same code when we want to build the graph. +-- +slurpConflicts + :: Instruction instr + => Platform + -> LiveCmmDecl statics instr + -> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg)) + +slurpConflicts platform live + = slurpCmm (emptyBag, emptyBag) live + + where slurpCmm rs CmmData{} = rs + slurpCmm rs (CmmProc info _ _ sccs) + = foldl' (slurpSCC info) rs sccs + + slurpSCC info rs (AcyclicSCC b) + = slurpBlock info rs b + + slurpSCC info rs (CyclicSCC bs) + = foldl' (slurpBlock info) rs bs + + slurpBlock info rs (BasicBlock blockId instrs) + | LiveInfo _ _ blockLive _ <- info + , Just rsLiveEntry <- mapLookup blockId blockLive + , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs + = (consBag rsLiveEntry conflicts, moves) + + | otherwise + = panic "Liveness.slurpConflicts: bad block" + + slurpLIs rsLive (conflicts, moves) [] + = (consBag rsLive conflicts, moves) + + slurpLIs rsLive rs (LiveInstr _ Nothing : lis) + = slurpLIs rsLive rs lis + + slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) + = let + -- regs that die because they are read for the last time at the start of an instruction + -- are not live across it. + rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) + + -- regs live on entry to the next instruction. + -- be careful of orphans, make sure to delete dying regs _after_ unioning + -- in the ones that are born here. + rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) + `minusUniqSet` (liveDieWrite live) + + -- orphan vregs are the ones that die in the same instruction they are born in. + -- these are likely to be results that are never used, but we still + -- need to assign a hreg to them.. + rsOrphans = intersectUniqSets + (liveBorn live) + (unionUniqSets (liveDieWrite live) (liveDieRead live)) + + -- + rsConflicts = unionUniqSets rsLiveNext rsOrphans + + in case takeRegRegMoveInstr platform instr of + Just rr -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , consBag rr moves) lis + + Nothing -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , moves) lis + + +-- | For spill\/reloads +-- +-- SPILL v1, slot1 +-- ... +-- RELOAD slot1, v2 +-- +-- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely +-- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. +-- +-- +slurpReloadCoalesce + :: forall statics instr. Instruction instr + => LiveCmmDecl statics instr + -> Bag (Reg, Reg) + +slurpReloadCoalesce live + = slurpCmm emptyBag live + + where + slurpCmm :: Bag (Reg, Reg) + -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)] + -> Bag (Reg, Reg) + slurpCmm cs CmmData{} = cs + slurpCmm cs (CmmProc _ _ _ sccs) + = slurpComp cs (flattenSCCs sccs) + + slurpComp :: Bag (Reg, Reg) + -> [LiveBasicBlock instr] + -> Bag (Reg, Reg) + slurpComp cs blocks + = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM + in unionManyBags (cs : moveBags) + + slurpCompM :: [LiveBasicBlock instr] + -> State (UniqFM BlockId [UniqFM Slot Reg]) [Bag (Reg, Reg)] + slurpCompM blocks + = do -- run the analysis once to record the mapping across jumps. + mapM_ (slurpBlock False) blocks + + -- run it a second time while using the information from the last pass. + -- We /could/ run this many more times to deal with graphical control + -- flow and propagating info across multiple jumps, but it's probably + -- not worth the trouble. + mapM (slurpBlock True) blocks + + slurpBlock :: Bool -> LiveBasicBlock instr + -> State (UniqFM BlockId [UniqFM Slot Reg]) (Bag (Reg, Reg)) + slurpBlock propagate (BasicBlock blockId instrs) + = do -- grab the slot map for entry to this block + slotMap <- if propagate + then getSlotMap blockId + else return emptyUFM + + (_, mMoves) <- mapAccumLM slurpLI slotMap instrs + return $ listToBag $ catMaybes mMoves + + slurpLI :: SlotMap Reg -- current slotMap + -> LiveInstr instr + -> State (UniqFM BlockId [SlotMap Reg]) -- blockId -> [slot -> reg] + -- for tracking slotMaps across jumps + + ( SlotMap Reg -- new slotMap + , Maybe (Reg, Reg)) -- maybe a new coalesce edge + + slurpLI slotMap li + + -- remember what reg was stored into the slot + | LiveInstr (SPILL (RegWithFormat reg _fmt) slot) _ <- li + , slotMap' <- addToUFM slotMap slot reg + = return (slotMap', Nothing) + + -- add an edge between the this reg and the last one stored into the slot + | LiveInstr (RELOAD slot (RegWithFormat reg _fmt)) _ <- li + = case lookupUFM slotMap slot of + Just reg2 + | reg /= reg2 -> return (slotMap, Just (reg, reg2)) + | otherwise -> return (slotMap, Nothing) + + Nothing -> return (slotMap, Nothing) + + -- if we hit a jump, remember the current slotMap + | LiveInstr (Instr instr) _ <- li + , targets <- jumpDestsOfInstr instr + , not $ null targets + = do mapM_ (accSlotMap slotMap) targets + return (slotMap, Nothing) + + | otherwise + = return (slotMap, Nothing) + + -- record a slotmap for an in edge to this block + accSlotMap slotMap blockId + = modify (\s -> addToUFM_C (++) s blockId [slotMap]) + + -- work out the slot map on entry to this block + -- if we have slot maps for multiple in-edges then we need to merge them. + getSlotMap blockId + = do map <- get + let slotMaps = fromMaybe [] (lookupUFM map blockId) + return $ foldr mergeSlotMaps emptyUFM slotMaps + + mergeSlotMaps :: SlotMap Reg -> SlotMap Reg -> SlotMap Reg + mergeSlotMaps map1 map2 + -- toList sadly means we have to use the _Directly style + -- functions. + -- TODO: We shouldn't need to go through a list here. + = listToUFM_Directly + $ [ (k, r1) + | (k, r1) <- nonDetUFMToList map1 + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + , case lookupUFM_Directly map2 k of + Nothing -> False + Just r2 -> r1 == r2 ] + + +-- | Strip away liveness information, yielding NatCmmDecl +stripLive + :: (OutputableP Platform statics, Instruction instr) + => NCGConfig + -> LiveCmmDecl statics instr + -> NatCmmDecl statics instr + +stripLive config live + = stripCmm live + + where stripCmm :: (OutputableP Platform statics, Instruction instr) + => LiveCmmDecl statics instr -> NatCmmDecl statics instr + stripCmm (CmmData sec ds) = CmmData sec ds + stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs) + = let final_blocks = flattenSCCs sccs + + -- make sure the block that was first in the input list + -- stays at the front of the output. This is the entry point + -- of the proc, and it needs to come first. + final_blocks' = sortOn ((/= first_id) . blockId) final_blocks + + in CmmProc info label live $ ListGraph $ + map (stripLiveBlock config) final_blocks' + + -- If the proc has blocks but we don't know what the first one was, then we're dead. + stripCmm proc + = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprLiveCmmDecl (ncgPlatform config) proc) + + +-- | Pretty-print a `LiveCmmDecl` +pprLiveCmmDecl :: (OutputableP Platform statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc +pprLiveCmmDecl platform d = pdoc platform (mapLiveCmmDecl (pprInstr platform) d) + + +-- | Map over instruction type in `LiveCmmDecl` +mapLiveCmmDecl + :: (instr -> b) + -> LiveCmmDecl statics instr + -> LiveCmmDecl statics b +mapLiveCmmDecl f proc = fmap (fmap (fmap (fmap (fmap f)))) proc + +-- | Strip away liveness information from a basic block, +-- and make real spill instructions out of SPILL, RELOAD pseudos along the way. + +stripLiveBlock + :: Instruction instr + => NCGConfig + -> LiveBasicBlock instr + -> NatBasicBlock instr + +stripLiveBlock config (BasicBlock i lis) + = BasicBlock i instrs' + + where (instrs', _) + = runState (spillNat [] lis) 0 + + -- spillNat :: [instr] -> [LiveInstr instr] -> State Int [instr] + spillNat :: Instruction instr => [instr] -> [LiveInstr instr] -> State Int [instr] + spillNat acc [] + = return (reverse acc) + + -- The SPILL/RELOAD cases do not appear to be exercised by our codegens + -- + spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) + = do delta <- get + spillNat (mkSpillInstr config reg delta slot ++ acc) instrs + + spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) + = do delta <- get + spillNat (mkLoadInstr config reg delta slot ++ acc) instrs + + spillNat acc (LiveInstr (Instr instr) _ : instrs) + | Just i <- takeDeltaInstr instr + = do put i + spillNat acc instrs + + spillNat acc (LiveInstr (Instr instr) _ : instrs) + = spillNat (instr : acc) instrs + + +-- | Erase Delta instructions. + +eraseDeltasLive + :: Instruction instr + => LiveCmmDecl statics instr + -> LiveCmmDecl statics instr + +eraseDeltasLive cmm + = mapBlockTop eraseBlock cmm + where + eraseBlock (BasicBlock id lis) + = BasicBlock id + $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) + $ lis + + +-- | Patch the registers in this code according to this register mapping. +-- also erase reg -> reg moves when the reg is the same. +-- also erase reg -> reg moves when the destination dies in this instr. +patchEraseLive + :: (Instruction instr, HasDebugCallStack) + => Platform + -> (Reg -> Reg) + -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr + +patchEraseLive platform patchF cmm + = patchCmm cmm + where + patchCmm cmm@CmmData{} = cmm + + patchCmm (CmmProc info label live sccs) + | LiveInfo static id blockMap mLiveSlots <- info + = let + -- See Note [Unique Determinism and code generation] + blockMap' = mapMap (mapRegFormatSet patchF) blockMap + + info' = LiveInfo static id blockMap' mLiveSlots + in CmmProc info' label live $ map patchSCC sccs + + patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) + patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) + + patchBlock (BasicBlock id lis) + = BasicBlock id $ patchInstrs lis + + patchInstrs [] = [] + patchInstrs (li : lis) + + | LiveInstr i (Just live) <- li' + , Just (r1, r2) <- takeRegRegMoveInstr platform i + , eatMe r1 r2 live + = patchInstrs lis + + | otherwise + = li' : patchInstrs lis + + where li' = patchRegsLiveInstr platform patchF li + + eatMe r1 r2 live + -- source and destination regs are the same + | r1 == r2 = True + + -- destination reg is never used + | elemUniqSet_Directly (getUnique r2) (liveBorn live) + , elemUniqSet_Directly (getUnique r2) (liveDieRead live) || elemUniqSet_Directly (getUnique r2) (liveDieWrite live) + = True + + | otherwise = False + + +-- | Patch registers in this LiveInstr, including the liveness information. +-- +patchRegsLiveInstr + :: (Instruction instr, HasDebugCallStack) + => Platform + -> (Reg -> Reg) + -> LiveInstr instr -> LiveInstr instr + +patchRegsLiveInstr platform patchF li + = case li of + LiveInstr instr Nothing + -> LiveInstr (patchRegsOfInstr platform instr patchF) Nothing + + LiveInstr instr (Just live) + -> LiveInstr + (patchRegsOfInstr platform instr patchF) + (Just live + { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg + liveBorn = mapRegFormatSet patchF $ liveBorn live + , liveDieRead = mapRegFormatSet patchF $ liveDieRead live + , liveDieWrite = mapRegFormatSet patchF $ liveDieWrite live }) + -- See Note [Unique Determinism and code generation] + +-------------------------------------------------------------------------------- +-- | Convert a NatCmmDecl to a LiveCmmDecl, with liveness information + +cmmTopLiveness + :: Instruction instr + => Maybe CFG + -> Platform + -> NatCmmDecl statics instr + -> UniqDSM (LiveCmmDecl statics instr) +cmmTopLiveness cfg platform cmm + = regLiveness platform $ natCmmTopToLive cfg cmm + +natCmmTopToLive + :: Instruction instr + => Maybe CFG -> NatCmmDecl statics instr + -> LiveCmmDecl statics instr + +natCmmTopToLive _ (CmmData i d) + = CmmData i d + +natCmmTopToLive _ (CmmProc info lbl live (ListGraph [])) + = CmmProc (LiveInfo info [] mapEmpty mapEmpty) lbl live [] + +natCmmTopToLive mCfg proc@(CmmProc info lbl live (ListGraph blocks@(first : _))) + = CmmProc (LiveInfo info' (first_id : entry_ids) mapEmpty mapEmpty) + lbl live sccsLive + where + first_id = blockId first + all_entry_ids = entryBlocks proc + sccs = sccBlocks blocks all_entry_ids mCfg + sccsLive = map (fmap (\(BasicBlock l instrs) -> + BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) + $ sccs + + entry_ids = filter (reachable_node) . + filter (/= first_id) $ all_entry_ids + info' = mapFilterWithKey (\node _ -> reachable_node node) info + reachable_node + | Just cfg <- mCfg + = hasNode cfg + | otherwise + = const True + +-- +-- Compute the liveness graph of the set of basic blocks. Important: +-- we also discard any unreachable code here, starting from the entry +-- points (the first block in the list, and any blocks with info +-- tables). Unreachable code arises when code blocks are orphaned in +-- earlier optimisation passes, and may confuse the register allocator +-- by referring to registers that are not initialised. It's easy to +-- discard the unreachable code as part of the SCC pass, so that's +-- exactly what we do. (#7574) +-- +sccBlocks + :: forall instr . Instruction instr + => [NatBasicBlock instr] + -> [BlockId] + -> Maybe CFG + -> [SCC (NatBasicBlock instr)] + +sccBlocks blocks entries mcfg = map (fmap node_payload) sccs + where + nodes :: [ Node BlockId (NatBasicBlock instr) ] + nodes = [ DigraphNode block id (getOutEdges instrs) + | block@(BasicBlock id instrs) <- blocks ] + + g1 = graphFromEdgedVerticesUniq nodes + + reachable :: LabelSet + reachable + | Just cfg <- mcfg + -- Our CFG only contains reachable nodes by construction at this point. + = setFromList $ getCfgNodes cfg + | otherwise + = setFromList $ [ node_key node | node <- reachablesG g1 roots ] + + g2 = graphFromEdgedVerticesUniq [ node | node <- nodes + , node_key node + `setMember` reachable ] + + sccs = stronglyConnCompG g2 + + getOutEdges :: Instruction instr => [instr] -> [BlockId] + getOutEdges instrs = concatMap jumpDestsOfInstr instrs + + -- This is truly ugly, but I don't see a good alternative. + -- Digraph just has the wrong API. We want to identify nodes + -- by their keys (BlockId), but Digraph requires the whole + -- node: (NatBasicBlock, BlockId, [BlockId]). This takes + -- advantage of the fact that Digraph only looks at the key, + -- even though it asks for the whole triple. + roots = [DigraphNode (panic "sccBlocks") b (panic "sccBlocks") + | b <- entries ] + +-------------------------------------------------------------------------------- +-- Annotate code with register liveness information +-- + +regLiveness + :: Instruction instr + => Platform + -> LiveCmmDecl statics instr + -> UniqDSM (LiveCmmDecl statics instr) + +regLiveness _ (CmmData i d) + = return $ CmmData i d + +regLiveness _ (CmmProc info lbl live []) + | LiveInfo static mFirst _ _ <- info + = return $ CmmProc + (LiveInfo static mFirst mapEmpty mapEmpty) + lbl live [] + +regLiveness platform (CmmProc info lbl live sccs) + | LiveInfo static mFirst _ liveSlotsOnEntry <- info + = let (ann_sccs, block_live) = computeLiveness platform sccs + + in return $ CmmProc (LiveInfo static mFirst block_live liveSlotsOnEntry) + lbl live ann_sccs + + +-- ----------------------------------------------------------------------------- +-- | Check ordering of Blocks +-- The computeLiveness function requires SCCs to be in reverse +-- dependent order. If they're not the liveness information will be +-- wrong, and we'll get a bad allocation. Better to check for this +-- precondition explicitly or some other poor sucker will waste a +-- day staring at bad assembly code.. +-- +checkIsReverseDependent + :: Instruction instr + => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. + -> Maybe BlockId -- ^ BlockIds that fail the test (if any) + +checkIsReverseDependent sccs' + = go emptyUniqSet sccs' + + where go _ [] + = Nothing + + go blocksSeen (AcyclicSCC block : sccs) + = let dests = slurpJumpDestsOfBlock block + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] + badDests = dests `minusUniqSet` blocksSeen' + in case nonDetEltsUniqSet badDests of + -- See Note [Unique Determinism and code generation] + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + go blocksSeen (CyclicSCC blocks : sccs) + = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks + badDests = dests `minusUniqSet` blocksSeen' + in case nonDetEltsUniqSet badDests of + -- See Note [Unique Determinism and code generation] + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + slurpJumpDestsOfBlock (BasicBlock _ instrs) + = unionManyUniqSets + $ map (mkUniqSet . jumpDestsOfInstr) + [ i | LiveInstr i _ <- instrs] + + +-- | If we've compute liveness info for this code already we have to reverse +-- the SCCs in each top to get them back to the right order so we can do it again. +reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr +reverseBlocksInTops top + = case top of + CmmData{} -> top + CmmProc info lbl live sccs -> CmmProc info lbl live (reverse sccs) + + +-- | Computing liveness +-- +-- On entry, the SCCs must be in "reverse" order: later blocks may transfer +-- control to earlier ones only, else `panic`. +-- +-- The SCCs returned are in the *opposite* order, which is exactly what we +-- want for the next pass. +-- +computeLiveness + :: Instruction instr + => Platform + -> [SCC (LiveBasicBlock instr)] + -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers + -- which are "dead after this instruction". + BlockMap (UniqSet RegWithFormat)) -- blocks annotated with set of live registers + -- on entry to the block. + +computeLiveness platform sccs + = case checkIsReverseDependent sccs of + Nothing -> livenessSCCs platform mapEmpty [] sccs + Just bad -> let sccs' = fmap (fmap (fmap (fmap (pprInstr platform)))) sccs + in pprPanic "RegAlloc.Liveness.computeLiveness" + (vcat [ text "SCCs aren't in reverse dependent order" + , text "bad blockId" <+> ppr bad + , ppr sccs']) + +livenessSCCs + :: Instruction instr + => Platform + -> BlockMap (UniqSet RegWithFormat) + -> [SCC (LiveBasicBlock instr)] -- accum + -> [SCC (LiveBasicBlock instr)] + -> ( [SCC (LiveBasicBlock instr)] + , BlockMap (UniqSet RegWithFormat)) + +livenessSCCs _ blockmap done [] + = (done, blockmap) + +livenessSCCs platform blockmap done (AcyclicSCC block : sccs) + = let (blockmap', block') = livenessBlock platform blockmap block + in livenessSCCs platform blockmap' (AcyclicSCC block' : done) sccs + +livenessSCCs platform blockmap done + (CyclicSCC blocks : sccs) = + livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs + where (blockmap', blocks') + = iterateUntilUnchanged linearLiveness equalBlockMaps + blockmap blocks + + iterateUntilUnchanged + :: (a -> b -> (a,c)) -> (a -> a -> Bool) + -> a -> b + -> (a,c) + + iterateUntilUnchanged f eq aa b = go aa + where + go a = if eq a a' then ac else go a' + where + ac@(a', _) = f a b + + linearLiveness + :: Instruction instr + => BlockMap (UniqSet RegWithFormat) -> [LiveBasicBlock instr] + -> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr]) + + linearLiveness = mapAccumL (livenessBlock platform) + + -- probably the least efficient way to compare two + -- BlockMaps for equality. + equalBlockMaps a b + = a' == b' + where a' = mapToList a + b' = mapToList b + -- See Note [Unique Determinism and code generation] + + + +-- | Annotate a basic block with register liveness information. +-- +livenessBlock + :: Instruction instr + => Platform + -> BlockMap (UniqSet RegWithFormat) + -> LiveBasicBlock instr + -> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr) + +livenessBlock platform blockmap (BasicBlock block_id instrs) + = let + (regsLiveOnEntry, instrs1) + = livenessBack platform emptyUniqSet blockmap [] (reverse instrs) + blockmap' = mapInsert block_id regsLiveOnEntry blockmap + + instrs2 = livenessForward platform regsLiveOnEntry instrs1 + + output = BasicBlock block_id instrs2 + + in ( blockmap', output) + +-- | Calculate liveness going forwards, +-- filling in when regs are born + +livenessForward + :: Instruction instr + => Platform + -> UniqSet RegWithFormat -- regs live on this instr + -> [LiveInstr instr] -> [LiveInstr instr] + +livenessForward _ _ [] = [] +livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis) + | Just live <- mLive + = let + RU _ written = regUsageOfInstr platform instr + -- Regs that are written to but weren't live on entry to this instruction + -- are recorded as being born here. + rsBorn = mkUniqSet + $ filter (\ r -> not $ elemUniqSet_Directly (getUnique r) rsLiveEntry) + $ written + + rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) + `minusUniqSet` (liveDieRead live) + `minusUniqSet` (liveDieWrite live) + + in LiveInstr instr (Just live { liveBorn = rsBorn }) + : livenessForward platform rsLiveNext lis + + | otherwise + = li : livenessForward platform rsLiveEntry lis + + +-- | Calculate liveness going backwards, +-- filling in when regs die, and what regs are live across each instruction + +livenessBack + :: Instruction instr + => Platform + -> UniqSet RegWithFormat -- regs live on this instr + -> BlockMap (UniqSet RegWithFormat) -- regs live on entry to other BBs + -> [LiveInstr instr] -- instructions (accum) + -> [LiveInstr instr] -- instructions + -> (UniqSet RegWithFormat, [LiveInstr instr]) + +livenessBack _ liveregs _ done [] = (liveregs, done) + +livenessBack platform liveregs blockmap acc (instr : instrs) + = let !(!liveregs', instr') = liveness1 platform liveregs blockmap instr + in livenessBack platform liveregs' blockmap (instr' : acc) instrs + + +-- don't bother tagging comments or deltas with liveness +liveness1 + :: Instruction instr + => Platform + -> UniqSet RegWithFormat + -> BlockMap (UniqSet RegWithFormat) + -> LiveInstr instr + -> (UniqSet RegWithFormat, LiveInstr instr) + +liveness1 _ liveregs _ (LiveInstr instr _) + | isMetaInstr instr + = (liveregs, LiveInstr instr Nothing) + +liveness1 platform liveregs blockmap (LiveInstr instr _) + + | not_a_branch + = (liveregs1, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = r_dying + , liveDieWrite = w_dying })) + + | otherwise + = (liveregs_br, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = r_dying_br + , liveDieWrite = w_dying })) + + where + !(RU read written) = regUsageOfInstr platform instr + + -- registers that were written here are dead going backwards. + -- registers that were read here are live going backwards. + liveregs1 = (liveregs `delListFromUniqSet` written) + `addListToUniqSet` read + + -- registers that are not live beyond this point, are recorded + -- as dying here. + r_dying = mkUniqSet + [ reg + | reg@(RegWithFormat r _) <- read + , not $ any (\ w -> getUnique w == getUnique r) written + , not (elementOfUniqSet reg liveregs) ] + + w_dying = mkUniqSet + [ reg + | reg <- written + , not (elementOfUniqSet reg liveregs) ] + + -- union in the live regs from all the jump destinations of this + -- instruction. + targets = jumpDestsOfInstr instr -- where we go from here + not_a_branch = null targets + + targetLiveRegs target + = case mapLookup target blockmap of + Just ra -> ra + Nothing -> emptyUniqSet + + live_from_branch = unionManyUniqSets (map targetLiveRegs targets) + + liveregs_br = liveregs1 `unionUniqSets` live_from_branch + + -- registers that are live only in the branch targets should + -- be listed as dying here. + live_branch_only = live_from_branch `minusUniqSet` liveregs + r_dying_br = (r_dying `unionUniqSets` live_branch_only) + -- See Note [Unique Determinism and code generation] diff --git a/GHC/CmmToAsm/Reg/Target.hs b/GHC/CmmToAsm/Reg/Target.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Target.hs @@ -0,0 +1,147 @@ + +-- | Hard wired things related to registers. +-- This is module is preventing the native code generator being able to +-- emit code for non-host architectures. +-- +-- TODO: Do a better job of the overloading, and eliminate this module. +-- We'd probably do better with a Register type class, and hook this to +-- Instruction somehow. +-- +-- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable +module GHC.CmmToAsm.Reg.Target ( + targetVirtualRegSqueeze, + targetRealRegSqueeze, + targetClassOfRealReg, + targetMkVirtualReg, + targetRegDotColor, + targetClassOfReg, + mapRegFormatSet, +) + +where + +import GHC.Prelude + +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import GHC.CmmToAsm.Format + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Platform + +import qualified GHC.CmmToAsm.X86.Regs as X86 +import qualified GHC.CmmToAsm.X86.RegInfo as X86 +import qualified GHC.CmmToAsm.PPC.Regs as PPC +import qualified GHC.CmmToAsm.AArch64.Regs as AArch64 +import qualified GHC.CmmToAsm.RV64.Regs as RV64 +import qualified GHC.CmmToAsm.LA64.Regs as LA64 + +targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int +targetVirtualRegSqueeze platform + = case platformArch platform of + ArchX86 -> X86.virtualRegSqueeze + ArchX86_64 -> X86.virtualRegSqueeze + ArchPPC -> PPC.virtualRegSqueeze + ArchS390X -> panic "targetVirtualRegSqueeze ArchS390X" + ArchPPC_64 _ -> PPC.virtualRegSqueeze + ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM" + ArchAArch64 -> AArch64.virtualRegSqueeze + ArchAlpha -> panic "targetVirtualRegSqueeze ArchAlpha" + ArchMipseb -> panic "targetVirtualRegSqueeze ArchMipseb" + ArchMipsel -> panic "targetVirtualRegSqueeze ArchMipsel" + ArchRISCV64 -> RV64.virtualRegSqueeze + ArchLoongArch64 -> LA64.virtualRegSqueeze + ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript" + ArchWasm32 -> panic "targetVirtualRegSqueeze ArchWasm32" + ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" + + +targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> Int +targetRealRegSqueeze platform + = case platformArch platform of + ArchX86 -> X86.realRegSqueeze + ArchX86_64 -> X86.realRegSqueeze + ArchPPC -> PPC.realRegSqueeze + ArchS390X -> panic "targetRealRegSqueeze ArchS390X" + ArchPPC_64 _ -> PPC.realRegSqueeze + ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM" + ArchAArch64 -> AArch64.realRegSqueeze + ArchAlpha -> panic "targetRealRegSqueeze ArchAlpha" + ArchMipseb -> panic "targetRealRegSqueeze ArchMipseb" + ArchMipsel -> panic "targetRealRegSqueeze ArchMipsel" + ArchRISCV64 -> RV64.realRegSqueeze + ArchLoongArch64 -> LA64.realRegSqueeze + ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript" + ArchWasm32 -> panic "targetRealRegSqueeze ArchWasm32" + ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" + +targetClassOfRealReg :: Platform -> RealReg -> RegClass +targetClassOfRealReg platform + = case platformArch platform of + ArchX86 -> X86.classOfRealReg platform + ArchX86_64 -> X86.classOfRealReg platform + ArchPPC -> PPC.classOfRealReg + ArchS390X -> panic "targetClassOfRealReg ArchS390X" + ArchPPC_64 _ -> PPC.classOfRealReg + ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" + ArchAArch64 -> AArch64.classOfRealReg + ArchAlpha -> panic "targetClassOfRealReg ArchAlpha" + ArchMipseb -> panic "targetClassOfRealReg ArchMipseb" + ArchMipsel -> panic "targetClassOfRealReg ArchMipsel" + ArchRISCV64 -> RV64.classOfRealReg + ArchLoongArch64 -> LA64.classOfRealReg + ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript" + ArchWasm32 -> panic "targetClassOfRealReg ArchWasm32" + ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" + +targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg +targetMkVirtualReg platform + = case platformArch platform of + ArchX86 -> X86.mkVirtualReg + ArchX86_64 -> X86.mkVirtualReg + ArchPPC -> PPC.mkVirtualReg + ArchS390X -> panic "targetMkVirtualReg ArchS390X" + ArchPPC_64 _ -> PPC.mkVirtualReg + ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM" + ArchAArch64 -> AArch64.mkVirtualReg + ArchAlpha -> panic "targetMkVirtualReg ArchAlpha" + ArchMipseb -> panic "targetMkVirtualReg ArchMipseb" + ArchMipsel -> panic "targetMkVirtualReg ArchMipsel" + ArchRISCV64 -> RV64.mkVirtualReg + ArchLoongArch64 -> LA64.mkVirtualReg + ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript" + ArchWasm32 -> panic "targetMkVirtualReg ArchWasm32" + ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" + +targetRegDotColor :: Platform -> RealReg -> SDoc +targetRegDotColor platform + = case platformArch platform of + ArchX86 -> X86.regDotColor platform + ArchX86_64 -> X86.regDotColor platform + ArchPPC -> PPC.regDotColor + ArchS390X -> panic "targetRegDotColor ArchS390X" + ArchPPC_64 _ -> PPC.regDotColor + ArchARM _ _ _ -> panic "targetRegDotColor ArchARM" + ArchAArch64 -> AArch64.regDotColor + ArchAlpha -> panic "targetRegDotColor ArchAlpha" + ArchMipseb -> panic "targetRegDotColor ArchMipseb" + ArchMipsel -> panic "targetRegDotColor ArchMipsel" + ArchRISCV64 -> RV64.regDotColor + ArchLoongArch64 -> LA64.regDotColor + ArchJavaScript-> panic "targetRegDotColor ArchJavaScript" + ArchWasm32 -> panic "targetRegDotColor ArchWasm32" + ArchUnknown -> panic "targetRegDotColor ArchUnknown" + + +targetClassOfReg :: Platform -> Reg -> RegClass +targetClassOfReg platform reg + = case reg of + RegVirtual vr -> classOfVirtualReg (platformArch platform) vr + RegReal rr -> targetClassOfRealReg platform rr + +mapRegFormatSet :: HasDebugCallStack => (Reg -> Reg) -> UniqSet RegWithFormat -> UniqSet RegWithFormat +mapRegFormatSet f = mapUniqSet (\ ( RegWithFormat r fmt ) -> RegWithFormat ( f r ) fmt) diff --git a/GHC/CmmToAsm/Reg/Utils.hs b/GHC/CmmToAsm/Reg/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Utils.hs @@ -0,0 +1,58 @@ +module GHC.CmmToAsm.Reg.Utils + ( toRegMap, toVRegMap ) +where + +{- Note [UniqFM and the register allocator] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Before UniqFM had a key type the register allocator + wasn't picky about key types, using VirtualReg, Reg + and Unique at various use sites for the same map. + + This is safe. + * The Unique values come from registers at various + points where we lose a reference to the original + register value, but the unique is still valid. + + * VirtualReg is a subset of the registers in Reg's type. + Making a value of VirtualReg into a Reg in fact doesn't + change its unique. This is because Reg consists of virtual + regs and real regs, whose unique values do not overlap. + + * Since the code was written in the assumption that keys are + not typed it's hard to reverse this assumption now. So we get + some gnarly but correct code where we often pass around Uniques + and switch between using Uniques, VirtualReg and RealReg as keys + of the same map. These issues were always there. But with the + now-typed keys they become visible. It's a classic case of not all + correct programs type checking. + + We reduce some of the burden by providing a way to cast + + UniqFM VirtualReg a + + to + + UniqFM Reg a + + in this module. This is safe as Reg is the sum of VirtualReg and + RealReg. With each kind of register keeping the same unique when + treated as Reg. + + TODO: If you take offense to this I encourage you to refactor this + code. I'm sure we can do with less casting of keys and direct use + of uniques. It might also be reasonable to just use a IntMap directly + instead of dealing with UniqFM at all. + + +-} +import GHC.Types.Unique.FM +import GHC.Platform.Reg + +-- These should hopefully be zero cost. + +toRegMap :: UniqFM VirtualReg elt -> UniqFM Reg elt +toRegMap = unsafeCastUFMKey + +toVRegMap :: UniqFM Reg elt -> UniqFM VirtualReg elt +toVRegMap = unsafeCastUFMKey + diff --git a/GHC/CmmToAsm/Types.hs b/GHC/CmmToAsm/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Types.hs @@ -0,0 +1,32 @@ +module GHC.CmmToAsm.Types + ( NatCmm + , NatCmmDecl + , NatBasicBlock + , GenBasicBlock(..) + , blockId + , ListGraph(..) + , RawCmmStatics + , RawCmmDecl + ) +where + +import GHC.Cmm.Dataflow.Label +import GHC.Cmm + + +-- Our flavours of the Cmm types +-- Type synonyms for Cmm populated with native code +type NatCmm instr + = GenCmmGroup + RawCmmStatics + (LabelMap RawCmmStatics) + (ListGraph instr) + +type NatCmmDecl statics instr + = GenCmmDecl + statics + (LabelMap RawCmmStatics) + (ListGraph instr) + +type NatBasicBlock instr + = GenBasicBlock instr diff --git a/GHC/CmmToAsm/Utils.hs b/GHC/CmmToAsm/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Utils.hs @@ -0,0 +1,32 @@ +module GHC.CmmToAsm.Utils + ( topInfoTable + , entryBlocks + ) +where + +import GHC.Prelude + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label +import GHC.Cmm hiding (topInfoTable) + +-- | Returns the info table associated with the CmmDecl's entry point, +-- if any. +topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i +topInfoTable (CmmProc infos _ _ (ListGraph (b:_))) + = mapLookup (blockId b) infos +topInfoTable _ + = Nothing + +-- | Return the list of BlockIds in a CmmDecl that are entry points +-- for this proc (i.e. they may be jumped to from outside this proc). +entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId] +entryBlocks (CmmProc info _ _ (ListGraph code)) = entries + where + infos = mapKeys info + entries = case code of + [] -> infos + BasicBlock entry _ : _ -- first block is the entry point + | entry `elem` infos -> infos + | otherwise -> entry : infos +entryBlocks _ = [] diff --git a/GHC/CmmToAsm/Wasm.hs b/GHC/CmmToAsm/Wasm.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Wasm.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.CmmToAsm.Wasm (ncgWasm) where + +import Data.ByteString.Builder +import Data.ByteString.Lazy.Char8 (unpack) +import Data.Maybe +import Data.Semigroup +import GHC.Cmm +import GHC.Cmm.ContFlowOpt +import GHC.Cmm.GenericOpt +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Wasm.Asm +import GHC.CmmToAsm.Wasm.FromCmm +import GHC.CmmToAsm.Wasm.Types +import GHC.StgToCmm.CgUtils (CgStream) +import GHC.Data.Stream (StreamS (..), runStream, liftIO) +import GHC.Driver.DynFlags +import GHC.Platform +import GHC.Prelude +import GHC.Settings +import GHC.Types.Unique.DSM +import GHC.Unit +import GHC.Utils.Logger +import GHC.Utils.Outputable (text) +import System.IO + +ncgWasm :: + NCGConfig -> + Logger -> + Platform -> + ToolSettings -> + ModLocation -> + Handle -> + CgStream RawCmmGroup a -> + UniqDSMT IO a +ncgWasm ncg_config logger platform ts loc h cmms = do + (r, s) <- streamCmmGroups ncg_config platform cmms + outputWasm $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n" + -- See Note [WasmTailCall] + let cfg = (defaultWasmAsmConfig s) { pic = ncgPIC ncg_config, tailcall = doTailCall ts } + outputWasm $ execWasmAsmM cfg $ asmTellEverything TagI32 s + pure r + where + outputWasm builder = liftIO $ do + putDumpFileMaybe + logger + Opt_D_dump_asm + "Asm Code" + FormatASM + (text . unpack $ toLazyByteString builder) + hPutBuilder h builder + +streamCmmGroups :: + NCGConfig -> + Platform -> + CgStream RawCmmGroup a -> + UniqDSMT IO (a, WasmCodeGenState 'I32) +streamCmmGroups ncg_config platform cmms = withDUS $ \us -> do + (r,s) <- go (initialWasmCodeGenState platform us) $ runStream cmms + return ((r,s), wasmDUniqSupply s) + where + go s (Done r) = pure (r, s) + go s (Effect m) = do + (a, us') <- runUDSMT (wasmDUniqSupply s) m + go s{wasmDUniqSupply = us'} a + go s (Yield decls k) = go (wasmExecM (onCmmGroup $ map opt decls) s) k + where + -- Run the generic cmm optimizations like other NCGs, followed + -- by a late control-flow optimization pass that does shrink + -- the CFG block count in some cases. + opt decl = case decl of + CmmData {} -> decl + CmmProc {} -> CmmProc info lbl live $ cmmCfgOpts False graph + where + (CmmProc info lbl live graph, _) = cmmToCmm ncg_config decl + +doTailCall :: ToolSettings -> Bool +doTailCall ts = Option "-mtail-call" `elem` as_args + where + (_, as_args) = toolSettings_pgm_a ts diff --git a/GHC/CmmToAsm/Wasm/Asm.hs b/GHC/CmmToAsm/Wasm/Asm.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Wasm/Asm.hs @@ -0,0 +1,569 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Strict #-} + +module GHC.CmmToAsm.Wasm.Asm (asmTellEverything, execWasmAsmM) where + +import Control.Monad +import Control.Monad.Trans.Reader +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Builder +import qualified Data.ByteString.Char8 as BS8 +import Data.Coerce +import Data.Foldable +import Data.Maybe +import Data.Semigroup +import GHC.Cmm +import GHC.CmmToAsm.Ppr +import GHC.CmmToAsm.Wasm.FromCmm +import GHC.CmmToAsm.Wasm.Types +import GHC.CmmToAsm.Wasm.Utils +import GHC.Data.FastString +import GHC.Float +import GHC.Prelude +import GHC.Settings.Config (cProjectVersion) +import GHC.Types.Basic +import GHC.Types.Unique +import GHC.Types.Unique.Map +import GHC.Types.Unique.Set +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.Panic (panic) + +-- | Reads current indentation, appends result to state +newtype WasmAsmM a = WasmAsmM (WasmAsmConfig -> Builder -> State Builder a) + deriving + ( Functor, + Applicative, + Monad + ) + via (ReaderT WasmAsmConfig (ReaderT Builder (State Builder))) + +instance Semigroup a => Semigroup (WasmAsmM a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (WasmAsmM a) where + mempty = pure mempty + +getConf :: WasmAsmM WasmAsmConfig +getConf = WasmAsmM $ \conf _ -> pure conf + +-- | Default indent level is none +execWasmAsmM :: WasmAsmConfig -> WasmAsmM a -> Builder +execWasmAsmM conf (WasmAsmM m) = + execState (m conf mempty) mempty + +-- | Increase indent level by a tab +asmWithTab :: WasmAsmM a -> WasmAsmM a +asmWithTab (WasmAsmM m) = + WasmAsmM $ \conf t -> m conf $! char7 '\t' <> t + +-- | Writes a single line starting with the current indent +asmTellLine :: Builder -> WasmAsmM () +asmTellLine b = WasmAsmM $ \_ t -> modify $ \acc -> acc <> t <> b <> char7 '\n' + +-- | Writes a single line break +asmTellLF :: WasmAsmM () +asmTellLF = WasmAsmM $ \_ _ -> modify $ \acc -> acc <> char7 '\n' + +-- | Writes a line starting with a single tab, ignoring current indent +-- level +asmTellTabLine :: Builder -> WasmAsmM () +asmTellTabLine b = + WasmAsmM $ \_ _ -> modify $ \acc -> acc <> char7 '\t' <> b <> char7 '\n' + +asmFromWasmType :: WasmTypeTag t -> Builder +asmFromWasmType ty = case ty of + TagI32 -> "i32" + TagI64 -> "i64" + TagF32 -> "f32" + TagF64 -> "f64" + +asmFromSomeWasmType :: SomeWasmType -> Builder +asmFromSomeWasmType (SomeWasmType t) = asmFromWasmType t + +asmFromSomeWasmTypes :: [SomeWasmType] -> Builder +asmFromSomeWasmTypes ts = "(" <> builderCommas asmFromSomeWasmType ts <> ")" + +asmFromFuncType :: [SomeWasmType] -> [SomeWasmType] -> Builder +asmFromFuncType arg_tys ret_tys = + asmFromSomeWasmTypes arg_tys <> " -> " <> asmFromSomeWasmTypes ret_tys + +asmTellFuncType :: + SymName -> ([SomeWasmType], [SomeWasmType]) -> WasmAsmM () +asmTellFuncType sym (arg_tys, ret_tys) = + asmTellTabLine $ + ".functype " + <> asmFromSymName sym + <> " " + <> asmFromFuncType arg_tys ret_tys + +asmTellLocals :: [SomeWasmType] -> WasmAsmM () +asmTellLocals [] = mempty +asmTellLocals local_tys = + asmTellTabLine $ ".local " <> builderCommas asmFromSomeWasmType local_tys + +asmFromSymName :: SymName -> Builder +asmFromSymName = shortByteString . coerce fastStringToShortByteString + +asmTellDefSym :: SymName -> WasmAsmM () +asmTellDefSym sym = do + WasmAsmConfig {..} <- getConf + unless pic $ asmTellTabLine $ ".hidden " <> asm_sym + asmTellTabLine $ ".globl " <> asm_sym + where + asm_sym = asmFromSymName sym + +asmTellDataSectionContent :: WasmTypeTag w -> DataSectionContent -> WasmAsmM () +asmTellDataSectionContent ty_word c = asmTellTabLine $ case c of + DataI8 i -> ".int8 0x" <> word8Hex i + DataI16 i -> ".int16 0x" <> word16Hex i + DataI32 i -> ".int32 0x" <> word32Hex i + DataI64 i -> ".int64 0x" <> word64Hex i + DataF32 f -> ".int32 0x" <> word32Hex (castFloatToWord32 f) + DataF64 d -> ".int64 0x" <> word64Hex (castDoubleToWord64 d) + DataSym sym o -> + ( case ty_word of + TagI32 -> ".int32 " + TagI64 -> ".int64 " + _ -> panic "asmTellDataSectionContent: unreachable" + ) + <> asmFromSymName sym + <> ( case compare o 0 of + EQ -> mempty + GT -> "+" <> intDec o + LT -> panic "asmTellDataSectionContent: negative offset" + ) + DataSkip i -> ".skip " <> intDec i + DataASCII s + | not (BS.null s) && BS.last s == 0 -> + ".asciz \"" + <> string7 + (showSDocOneLine defaultSDocContext $ pprASCII $ BS.init s) + <> "\"" + | otherwise -> + ".ascii \"" + <> string7 + (showSDocOneLine defaultSDocContext $ pprASCII s) + <> "\"" + DataIncBin f _ -> + ".incbin " + <> string7 + (showSDocOneLine defaultSDocContext $ pprFilePathString f) + +dataSectionContentSize :: WasmTypeTag w -> DataSectionContent -> Int +dataSectionContentSize ty_word c = case c of + DataI8 {} -> 1 + DataI16 {} -> 2 + DataI32 {} -> 4 + DataI64 {} -> 8 + DataF32 {} -> 4 + DataF64 {} -> 8 + DataSym {} -> alignmentBytes $ alignmentFromWordType ty_word + DataSkip i -> i + DataASCII s -> BS.length s + DataIncBin _ l -> l + +dataSectionSize :: WasmTypeTag w -> [DataSectionContent] -> Int +dataSectionSize ty_word = + coerce + . foldMap' + (Sum . dataSectionContentSize ty_word) + +asmTellAlign :: Alignment -> WasmAsmM () +asmTellAlign a = case alignmentBytes a of + 1 -> mempty + i -> asmTellTabLine $ ".p2align " <> intDec (countTrailingZeros i) + +asmTellSectionHeader :: Builder -> WasmAsmM () +asmTellSectionHeader k = asmTellTabLine $ ".section " <> k <> ",\"\",@" + +asmTellDataSection :: + WasmTypeTag w -> UniqueSet -> SymName -> DataSection -> WasmAsmM () +asmTellDataSection ty_word def_syms sym DataSection {..} = do + when (getUnique sym `memberUniqueSet` def_syms) $ asmTellDefSym sym + asmTellSectionHeader sec_name + asmTellAlign dataSectionAlignment + asmTellTabLine asm_size + asmTellLine $ asm_sym <> ":" + for_ dataSectionContents $ asmTellDataSectionContent ty_word + asmTellLF + where + asm_sym = asmFromSymName sym + + sec_name = + ( case dataSectionKind of + SectionData -> ".data." + SectionROData -> ".rodata." + ) + <> asm_sym + + asm_size = + ".size " + <> asm_sym + <> ", " + <> intDec + (dataSectionSize ty_word dataSectionContents) + +asmFromWasmBlockType :: WasmTypeTag w -> WasmFunctionType pre post -> Builder +asmFromWasmBlockType + _ + (WasmFunctionType {ft_pops = TypeListNil, ft_pushes = TypeListNil}) = + mempty +asmFromWasmBlockType + TagI32 + ( WasmFunctionType + { ft_pops = TypeListNil, + ft_pushes = TypeListCons TagI32 TypeListNil + } + ) = + " i32" +asmFromWasmBlockType + TagI64 + ( WasmFunctionType + { ft_pops = TypeListNil, + ft_pushes = TypeListCons TagI64 TypeListNil + } + ) = + " i64" +asmFromWasmBlockType _ _ = panic "asmFromWasmBlockType: invalid block type" + +asmFromAlignmentSpec :: AlignmentSpec -> Builder +asmFromAlignmentSpec NaturallyAligned = mempty +asmFromAlignmentSpec Unaligned = ":p2align=0" + +asmTellWasmInstr :: WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM () +asmTellWasmInstr ty_word instr = case instr of + WasmComment c -> asmTellLine $ stringUtf8 $ "# " <> c + WasmNop -> mempty + WasmDrop -> asmTellLine "drop" + WasmUnreachable -> asmTellLine "unreachable" + WasmConst TagI32 i -> asmTellLine $ "i32.const " <> integerDec i + WasmConst TagI64 i -> asmTellLine $ "i64.const " <> integerDec i + WasmConst {} -> panic "asmTellWasmInstr: unreachable" + WasmSymConst sym -> do + WasmAsmConfig {..} <- getConf + let + asm_sym = asmFromSymName sym + (ty_const, ty_add) = case ty_word of + TagI32 -> ("i32.const ", "i32.add") + TagI64 -> ("i64.const ", "i64.add") + _ -> panic "asmTellWasmInstr: invalid word type" + traverse_ asmTellLine $ if + | pic, getUnique sym `memberUniqueSet` mbrelSyms -> [ + "global.get __memory_base", + ty_const <> asm_sym <> "@MBREL", + ty_add + ] + | pic, getUnique sym `memberUniqueSet` tbrelSyms -> [ + "global.get __table_base", + ty_const <> asm_sym <> "@TBREL", + ty_add + ] + | pic -> [ "global.get " <> asm_sym <> "@GOT" ] + | otherwise -> [ ty_const <> asm_sym ] + WasmLoad ty (Just w) s o align -> + asmTellLine $ + asmFromWasmType ty + <> ".load" + <> intDec w + <> ( case s of + Signed -> "_s" + Unsigned -> "_u" + ) + <> " " + <> intDec o + <> asmFromAlignmentSpec align + WasmLoad ty Nothing _ o align -> + asmTellLine $ + asmFromWasmType ty + <> ".load" + <> " " + <> intDec o + <> asmFromAlignmentSpec align + WasmStore ty (Just w) o align -> + asmTellLine $ + asmFromWasmType ty + <> ".store" + <> intDec w + <> " " + <> intDec o + <> asmFromAlignmentSpec align + WasmStore ty Nothing o align -> + asmTellLine $ + asmFromWasmType ty + <> ".store" + <> " " + <> intDec o + <> asmFromAlignmentSpec align + WasmGlobalGet _ sym -> asmTellLine $ "global.get " <> asmFromSymName sym + WasmGlobalSet _ sym -> asmTellLine $ "global.set " <> asmFromSymName sym + WasmLocalGet _ i -> asmTellLine $ "local.get " <> intDec i + WasmLocalSet _ i -> asmTellLine $ "local.set " <> intDec i + WasmLocalTee _ i -> asmTellLine $ "local.tee " <> intDec i + WasmCCall sym -> asmTellLine $ "call " <> asmFromSymName sym + WasmCCallIndirect arg_tys ret_tys -> + asmTellLine $ + "call_indirect " + <> asmFromFuncType + (someWasmTypesFromTypeList arg_tys) + (someWasmTypesFromTypeList ret_tys) + WasmConcat instr0 instr1 -> do + asmTellWasmInstr ty_word instr0 + asmTellWasmInstr ty_word instr1 + WasmReinterpret t0 t1 -> + asmTellLine $ + asmFromWasmType t1 <> ".reinterpret_" <> asmFromWasmType t0 + WasmTruncSat Signed t0 t1 -> + asmTellLine $ + asmFromWasmType t1 <> ".trunc_sat_" <> asmFromWasmType t0 <> "_s" + WasmTruncSat Unsigned t0 t1 -> + asmTellLine $ + asmFromWasmType t1 <> ".trunc_sat_" <> asmFromWasmType t0 <> "_u" + WasmConvert Signed t0 t1 -> + asmTellLine $ + asmFromWasmType t1 <> ".convert_" <> asmFromWasmType t0 <> "_s" + WasmConvert Unsigned t0 t1 -> + asmTellLine $ + asmFromWasmType t1 <> ".convert_" <> asmFromWasmType t0 <> "_u" + WasmAdd ty -> asmTellLine $ asmFromWasmType ty <> ".add" + WasmSub ty -> asmTellLine $ asmFromWasmType ty <> ".sub" + WasmMul ty -> asmTellLine $ asmFromWasmType ty <> ".mul" + WasmDiv _ TagF32 -> asmTellLine "f32.div" + WasmDiv _ TagF64 -> asmTellLine "f64.div" + WasmDiv Signed ty -> asmTellLine $ asmFromWasmType ty <> ".div_s" + WasmDiv Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".div_u" + WasmRem Signed ty -> asmTellLine $ asmFromWasmType ty <> ".rem_s" + WasmRem Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".rem_u" + WasmAnd ty -> asmTellLine $ asmFromWasmType ty <> ".and" + WasmOr ty -> asmTellLine $ asmFromWasmType ty <> ".or" + WasmXor ty -> asmTellLine $ asmFromWasmType ty <> ".xor" + WasmEq ty -> asmTellLine $ asmFromWasmType ty <> ".eq" + WasmNe ty -> asmTellLine $ asmFromWasmType ty <> ".ne" + WasmLt _ TagF32 -> asmTellLine "f32.lt" + WasmLt _ TagF64 -> asmTellLine "f64.lt" + WasmLt Signed ty -> asmTellLine $ asmFromWasmType ty <> ".lt_s" + WasmLt Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".lt_u" + WasmGt _ TagF32 -> asmTellLine "f32.gt" + WasmGt _ TagF64 -> asmTellLine "f64.gt" + WasmGt Signed ty -> asmTellLine $ asmFromWasmType ty <> ".gt_s" + WasmGt Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".gt_u" + WasmLe _ TagF32 -> asmTellLine "f32.le" + WasmLe _ TagF64 -> asmTellLine "f64.le" + WasmLe Signed ty -> asmTellLine $ asmFromWasmType ty <> ".le_s" + WasmLe Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".le_u" + WasmGe _ TagF32 -> asmTellLine "f32.ge" + WasmGe _ TagF64 -> asmTellLine "f64.ge" + WasmGe Signed ty -> asmTellLine $ asmFromWasmType ty <> ".ge_s" + WasmGe Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".ge_u" + WasmShl ty -> asmTellLine $ asmFromWasmType ty <> ".shl" + WasmShr Signed ty -> asmTellLine $ asmFromWasmType ty <> ".shr_s" + WasmShr Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".shr_u" + WasmI32Extend8S -> asmTellLine "i32.extend8_s" + WasmI32Extend16S -> asmTellLine "i32.extend16_s" + WasmI64Extend8S -> asmTellLine "i64.extend8_s" + WasmI64Extend16S -> asmTellLine "i64.extend16_s" + WasmI64Extend32S -> asmTellLine "i64.extend32_s" + WasmI64ExtendI32 Signed -> asmTellLine "i64.extend_i32_s" + WasmI64ExtendI32 Unsigned -> asmTellLine "i64.extend_i32_u" + WasmI32WrapI64 -> asmTellLine "i32.wrap_i64" + WasmF32DemoteF64 -> asmTellLine "f32.demote_f64" + WasmF64PromoteF32 -> asmTellLine "f64.promote_f32" + WasmAbs ty -> asmTellLine $ asmFromWasmType ty <> ".abs" + WasmSqrt ty -> asmTellLine $ asmFromWasmType ty <> ".sqrt" + WasmNeg ty -> asmTellLine $ asmFromWasmType ty <> ".neg" + WasmMin ty -> asmTellLine $ asmFromWasmType ty <> ".min" + WasmMax ty -> asmTellLine $ asmFromWasmType ty <> ".max" + WasmCond t -> do + asmTellLine "if" + asmWithTab $ asmTellWasmInstr ty_word t + asmTellLine "end_if" + +asmTellWasmControl :: + WasmTypeTag w -> + WasmControl + (WasmStatements w) + (WasmExpr w a) + pre + post -> + WasmAsmM () +asmTellWasmControl ty_word c = case c of + WasmPush _ (WasmExpr e) -> asmTellWasmInstr ty_word e + WasmBlock bt c -> do + asmTellLine $ "block" <> asmFromWasmBlockType ty_word bt + asmWithTab $ asmTellWasmControl ty_word c + asmTellLine "end_block" + WasmLoop bt c -> do + asmTellLine $ "loop" <> asmFromWasmBlockType ty_word bt + asmWithTab $ asmTellWasmControl ty_word c + asmTellLine "end_loop" + WasmIfTop bt t f -> do + asmTellLine $ "if" <> asmFromWasmBlockType ty_word bt + asmWithTab $ asmTellWasmControl ty_word t + asmTellLine "else" + asmWithTab $ asmTellWasmControl ty_word f + asmTellLine "end_if" + WasmBr i -> asmTellLine $ "br " <> intDec i + WasmFallthrough -> mempty + WasmBrTable (WasmExpr e) _ ts t -> do + asmTellWasmInstr ty_word e + asmTellLine $ "br_table {" <> builderCommas intDec (ts <> [t]) <> "}" + -- See Note [WasmTailCall] + WasmTailCall (WasmExpr e) -> do + WasmAsmConfig {..} <- getConf + if + | tailcall, + WasmSymConst sym <- e -> + asmTellLine $ "return_call " <> asmFromSymName sym + | tailcall -> + do + asmTellWasmInstr ty_word e + asmTellLine $ + "return_call_indirect " + <> asmFromFuncType + [] + [SomeWasmType ty_word] + | otherwise -> + do + asmTellWasmInstr ty_word e + asmTellLine "return" + WasmActions (WasmStatements a) -> asmTellWasmInstr ty_word a + WasmSeq c0 c1 -> do + asmTellWasmControl ty_word c0 + asmTellWasmControl ty_word c1 + +asmTellFunc :: + WasmTypeTag w -> + UniqueSet -> + SymName -> + (([SomeWasmType], [SomeWasmType]), FuncBody w) -> + WasmAsmM () +asmTellFunc ty_word def_syms sym (func_ty, FuncBody {..}) = do + when (getUnique sym `memberUniqueSet` def_syms) $ asmTellDefSym sym + asmTellSectionHeader $ ".text." <> asm_sym + asmTellLine $ asm_sym <> ":" + asmTellFuncType sym func_ty + asmTellLocals funcLocals + asmWithTab $ asmTellWasmControl ty_word funcBody + asmTellTabLine "end_function" + asmTellLF + where + asm_sym = asmFromSymName sym + +asmTellGlobals :: WasmTypeTag w -> WasmAsmM () +asmTellGlobals ty_word = do + WasmAsmConfig {..} <- getConf + when pic $ traverse_ asmTellTabLine [ + ".globaltype __memory_base, i32, immutable", + ".globaltype __table_base, i32, immutable" + ] + for_ supportedCmmGlobalRegs $ \reg -> + let + (sym, ty) = fromJust $ globalInfoFromCmmGlobalReg ty_word reg + asm_sym = asmFromSymName sym + in do + asmTellTabLine $ + ".globaltype " + <> asm_sym + <> ", " + <> asmFromSomeWasmType ty + when pic $ traverse_ asmTellTabLine [ + ".import_module " <> asm_sym <> ", regs", + ".import_name " <> asm_sym <> ", " <> asm_sym + ] + asmTellLF + +asmTellCtors :: WasmTypeTag w -> [SymName] -> WasmAsmM () +asmTellCtors _ [] = mempty +asmTellCtors ty_word syms = do + -- See Note [JSFFI initialization] for details + asmTellSectionHeader ".init_array.101" + asmTellAlign $ alignmentFromWordType ty_word + for_ syms $ \sym -> + asmTellTabLine $ + ( case ty_word of + TagI32 -> ".int32 " + TagI64 -> ".int64 " + _ -> panic "asmTellCtors: unreachable" + ) + <> asmFromSymName sym + asmTellLF + +asmTellBS :: ByteString -> WasmAsmM () +asmTellBS s = do + asmTellTabLine $ ".int8 " <> intDec (BS.length s) + asmTellTabLine $ + ".ascii \"" + <> string7 + (showSDocOneLine defaultSDocContext $ pprASCII s) + <> "\"" + +asmTellVec :: [WasmAsmM ()] -> WasmAsmM () +asmTellVec xs = do + asmTellTabLine $ ".int8 " <> intDec (length xs) + sequence_ xs + +asmTellProducers :: WasmAsmM () +asmTellProducers = do + asmTellSectionHeader ".custom_section.producers" + asmTellVec + [ do + asmTellBS "processed-by" + asmTellVec + [ do + asmTellBS "ghc" + asmTellBS $ BS8.pack cProjectVersion + ] + ] + +asmTellTargetFeatures :: WasmAsmM () +asmTellTargetFeatures = do + WasmAsmConfig {..} <- getConf + asmTellSectionHeader ".custom_section.target_features" + asmTellVec + [ do + asmTellTabLine ".int8 0x2b" + asmTellBS feature + | feature <- + ["tail-call" | tailcall] + <> [ "bulk-memory", + "mutable-globals", + "nontrapping-fptoint", + "reference-types", + "sign-ext" + ] + ] + +asmTellEverything :: WasmTypeTag w -> WasmCodeGenState w -> WasmAsmM () +asmTellEverything ty_word WasmCodeGenState {..} = do + asmTellGlobals ty_word + asm_functypes + asm_funcs + asm_data_secs + asm_ctors + asmTellProducers + asmTellTargetFeatures + where + asm_functypes = do + for_ + (detEltsUniqMap $ funcTypes `minusUniqMap` funcBodies) + (uncurry asmTellFuncType) + asmTellLF + + asm_funcs = do + for_ + (detEltsUniqMap $ intersectUniqMap_C (,) funcTypes funcBodies) + (uncurry $ asmTellFunc ty_word defaultSyms) + asmTellLF + + asm_data_secs = do + for_ + (detEltsUniqMap dataSections) + (uncurry (asmTellDataSection ty_word defaultSyms)) + asmTellLF + + asm_ctors = asmTellCtors ty_word ctors diff --git a/GHC/CmmToAsm/Wasm/FromCmm.hs b/GHC/CmmToAsm/Wasm/FromCmm.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -0,0 +1,1761 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use camelCase" #-} +module GHC.CmmToAsm.Wasm.FromCmm + ( alignmentFromWordType, + globalInfoFromCmmGlobalReg, + supportedCmmGlobalRegs, + onCmmGroup, + ) +where + +import Control.Monad +import qualified Data.ByteString as BS +import Data.Foldable +import Data.Functor +import Data.Semigroup +import Data.String +import Data.Traversable +import Data.Type.Equality +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.InitFini +import GHC.CmmToAsm.Wasm.Types +import GHC.CmmToAsm.Wasm.Utils +import GHC.Float +import GHC.Platform +import GHC.Prelude +import GHC.StgToCmm.CgUtils +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSM +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.Panic +import GHC.Wasm.ControlFlow.FromCmm + +-- | Calculate the wasm representation type from a 'CmmType'. This is +-- a lossy conversion, and sometimes we need to pass the original +-- 'CmmType' or at least its 'Width' around, so to properly add +-- subword truncation or extension logic. +someWasmTypeFromCmmType :: CmmType -> SomeWasmType +someWasmTypeFromCmmType t + | isWord32 t = SomeWasmType TagI32 + | isWord64 t = SomeWasmType TagI64 + | t `cmmEqType` b16 = SomeWasmType TagI32 + | t `cmmEqType` b8 = SomeWasmType TagI32 + | isFloat64 t = SomeWasmType TagF64 + | isFloat32 t = SomeWasmType TagF32 + | otherwise = + panic $ + "someWasmTypeFromCmmType: unsupported CmmType " + <> showSDocOneLine defaultSDocContext (ppr t) + +-- | Calculate the optional memory narrowing of a 'CmmLoad' or +-- 'CmmStore'. +wasmMemoryNarrowing :: WasmTypeTag t -> CmmType -> Maybe Int +wasmMemoryNarrowing ty ty_cmm = case (# ty, typeWidth ty_cmm #) of + (# TagI32, W8 #) -> Just 8 + (# TagI32, W16 #) -> Just 16 + (# TagI32, W32 #) -> Nothing + (# TagI64, W8 #) -> Just 8 + (# TagI64, W16 #) -> Just 16 + (# TagI64, W32 #) -> Just 32 + (# TagI64, W64 #) -> Nothing + (# TagF32, W32 #) -> Nothing + (# TagF64, W64 #) -> Nothing + _ -> panic "wasmMemoryNarrowing: unreachable" + +-- | Despite this is used by the WebAssembly native codegen, we use +-- 'pprCLabel' instead of 'pprAsmLabel' when emitting the textual +-- symbol name. Either one would work, but 'pprCLabel' makes the +-- output assembly code looks closer to the unregisterised codegen +-- output, which can be handy when using the unregisterised codegen as +-- a source of truth when debugging the native codegen. +symNameFromCLabel :: CLabel -> SymName +symNameFromCLabel lbl = + fromString $ + showSDocOneLine defaultSDocContext {sdocStyle = PprCode} $ + pprCLabel genericPlatform lbl + +-- | Calculate a symbol's visibility. +symVisibilityFromCLabel :: CLabel -> SymVisibility +symVisibilityFromCLabel lbl + | externallyVisibleCLabel lbl = SymDefault + | otherwise = SymStatic + +-- | Calculate a symbol's kind, see haddock docs of 'SymKind' for more +-- explanation. +symKindFromCLabel :: CLabel -> SymKind +symKindFromCLabel lbl + | isCFunctionLabel lbl = SymFunc + | otherwise = SymData + +-- | Calculate a data section's kind, see haddock docs of +-- 'DataSectionKind' for more explanation. +dataSectionKindFromCmmSection :: Section -> DataSectionKind +dataSectionKindFromCmmSection s = case sectionProtection s of + ReadWriteSection -> SectionData + _ -> SectionROData + +-- | Calculate the natural alignment size given the platform word +-- type. +alignmentFromWordType :: WasmTypeTag w -> Alignment +alignmentFromWordType TagI32 = mkAlignment 4 +alignmentFromWordType TagI64 = mkAlignment 8 +alignmentFromWordType _ = panic "alignmentFromWordType: unreachable" + +-- | Calculate a data section's alignment. As a conservative +-- optimization, a data section with a single CmmString/CmmFileEmbed +-- has no alignment requirement, otherwise we always align to the word +-- size to satisfy pointer tagging requirements and avoid unaligned +-- loads/stores. +alignmentFromCmmSection :: WasmTypeTag w -> [DataSectionContent] -> Alignment +alignmentFromCmmSection _ [DataASCII {}] = mkAlignment 1 +alignmentFromCmmSection _ [DataIncBin {}] = mkAlignment 1 +alignmentFromCmmSection t _ = alignmentFromWordType t + +-- | Lower a 'CmmStatic'. +lower_CmmStatic :: CmmStatic -> WasmCodeGenM w DataSectionContent +lower_CmmStatic s = case s of + CmmStaticLit (CmmInt i W8) -> pure $ DataI8 $ fromInteger $ narrowU W8 i + CmmStaticLit (CmmInt i W16) -> pure $ DataI16 $ fromInteger $ narrowU W16 i + CmmStaticLit (CmmInt i W32) -> pure $ DataI32 $ fromInteger $ narrowU W32 i + CmmStaticLit (CmmInt i W64) -> pure $ DataI64 $ fromInteger $ narrowU W64 i + CmmStaticLit (CmmFloat f W32) -> pure $ DataF32 $ fromRational f + CmmStaticLit (CmmFloat d W64) -> pure $ DataF64 $ fromRational d + CmmStaticLit (CmmLabel lbl) -> + onAnySym lbl + $> DataSym + (symNameFromCLabel lbl) + 0 + CmmStaticLit (CmmLabelOff lbl o) -> + onAnySym lbl + $> DataSym + (symNameFromCLabel lbl) + o + CmmUninitialised i -> pure $ DataSkip i + CmmString b -> pure $ DataASCII b + CmmFileEmbed f l -> pure $ DataIncBin f l + _ -> panic "lower_CmmStatic: unreachable" + +{- +Note [Register mapping on WebAssembly] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Unlike typical ISAs, WebAssembly doesn't expose a fixed set of +registers. For now, we map each Cmm LocalReg to a wasm local, and each +Cmm GlobalReg to a wasm global. The wasm globals are defined in +rts/wasm/Wasm.S, and must be kept in sync with +'globalInfoFromCmmGlobalReg' and 'supportedCmmGlobalRegs' here. + +There are some other Cmm GlobalRegs which are still represented by +StgRegTable fields instead of wasm globals (e.g. HpAlloc). It's cheap +to add wasm globals, but other parts of rts logic only work with the +StgRegTable fields, so we also need to instrument StgRun/StgReturn to +sync the wasm globals with the StgRegTable. It's not really worth the +trouble. + +-} +globalInfoFromCmmGlobalReg :: WasmTypeTag w -> GlobalReg -> Maybe GlobalInfo +globalInfoFromCmmGlobalReg t reg = case reg of + VanillaReg i + | i >= 1 && i <= 10 -> Just (fromString $ "__R" <> show i, ty_word) + FloatReg i + | i >= 1 && i <= 6 -> + Just (fromString $ "__F" <> show i, SomeWasmType TagF32) + DoubleReg i + | i >= 1 && i <= 6 -> + Just (fromString $ "__D" <> show i, SomeWasmType TagF64) + LongReg i + | i == 1 -> Just (fromString $ "__L" <> show i, SomeWasmType TagI64) + Sp -> Just ("__Sp", ty_word) + SpLim -> Just ("__SpLim", ty_word) + Hp -> Just ("__Hp", ty_word) + HpLim -> Just ("__HpLim", ty_word) + _ -> Nothing + where + ty_word = SomeWasmType t + +supportedCmmGlobalRegs :: [GlobalReg] +supportedCmmGlobalRegs = + [VanillaReg i | i <- [1 .. 10]] + <> [FloatReg i | i <- [1 .. 6]] + <> [DoubleReg i | i <- [1 .. 6]] + <> [LongReg i | i <- [1 .. 1]] + <> [Sp, SpLim, Hp, HpLim] + +-- | Truncate a subword. +truncSubword :: Width -> WasmTypeTag t -> WasmExpr w t -> WasmExpr w t +truncSubword W8 ty (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmConst ty 0xFF `WasmConcat` WasmAnd ty +truncSubword W16 ty (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmConst ty 0xFFFF `WasmConcat` WasmAnd ty +truncSubword _ _ expr = expr + +-- | Sign-extend a subword. +extendSubword :: Width -> WasmTypeTag t -> WasmExpr w t -> WasmExpr w t +extendSubword W8 TagI32 (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmI32Extend8S +extendSubword W16 TagI32 (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmI32Extend16S +extendSubword W8 TagI64 (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmI64Extend8S +extendSubword W16 TagI64 (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmI64Extend16S +extendSubword W32 TagI64 (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmI64Extend32S +extendSubword _ _ expr = expr + +-- | Lower an unary homogeneous operation. +lower_MO_Un_Homo :: + ( forall pre t. + WasmTypeTag t -> + WasmInstr + w + (t : pre) + (t : pre) + ) -> + CLabel -> + CmmType -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Un_Homo op lbl t0 [x] = case someWasmTypeFromCmmType t0 of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + pure $ + SomeWasmExpr ty $ + WasmExpr $ + x_instr `WasmConcat` op ty +lower_MO_Un_Homo _ _ _ _ = panic "lower_MO_Un_Homo: unreachable" + +-- | Lower a binary homogeneous operation. Homogeneous: result type is +-- the same with operand types. +lower_MO_Bin_Homo :: + ( forall pre t. + WasmTypeTag t -> + WasmInstr + w + (t : t : pre) + (t : pre) + ) -> + CLabel -> + CmmType -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Bin_Homo op lbl t0 [x, y] = case someWasmTypeFromCmmType t0 of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y + pure $ + SomeWasmExpr ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` op ty +lower_MO_Bin_Homo _ _ _ _ = panic "lower_MO_Bin_Homo: unreachable" + +-- | Lower a binary homogeneous operation, and truncate the result if +-- it's a subword. +lower_MO_Bin_Homo_Trunc :: + (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)) -> + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Bin_Homo_Trunc op lbl w0 [x, y] = + case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y + pure $ + SomeWasmExpr ty $ + truncSubword w0 ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` op ty +lower_MO_Bin_Homo_Trunc _ _ _ _ = panic "lower_MO_Bin_Homo_Trunc: unreachable" + +-- | Lower a binary homogeneous operation, first sign extending the +-- operands, then truncating the result. +lower_MO_Bin_Homo_Ext_Trunc :: + (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)) -> + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Bin_Homo_Ext_Trunc op lbl w0 [x, y] = + case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- + extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- + extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty y + pure $ + SomeWasmExpr ty $ + truncSubword w0 ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` op ty +lower_MO_Bin_Homo_Ext_Trunc _ _ _ _ = + panic "lower_MO_Bin_Homo_Ext_Trunc: unreachable" + +-- | Lower a relational binary operation, first sign extending the +-- operands. Relational: result type is a boolean (word type). +lower_MO_Bin_Rel_Ext :: + (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)) -> + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Bin_Rel_Ext op lbl w0 [x, y] = + case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- + extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- + extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty y + ty_word <- wasmWordTypeM + pure $ + SomeWasmExpr ty_word $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` op ty +lower_MO_Bin_Rel_Ext _ _ _ _ = panic "lower_MO_Bin_Rel_Ext: unreachable" + +-- | Lower a relational binary operation. +lower_MO_Bin_Rel :: + ( forall pre t. + WasmTypeTag t -> + WasmInstr + w + (t : t : pre) + (w : pre) + ) -> + CLabel -> + CmmType -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Bin_Rel op lbl t0 [x, y] = case someWasmTypeFromCmmType t0 of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y + ty_word <- wasmWordTypeM + pure $ + SomeWasmExpr ty_word $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` op ty +lower_MO_Bin_Rel _ _ _ _ = panic "lower_MO_Bin_Rel: unreachable" + +-- | Cast a shiftL/shiftR RHS to the same type as LHS. Because we may +-- have a 64-bit LHS and 32-bit RHS, but wasm shift operators are +-- homogeneous. +shiftRHSCast :: + CLabel -> + WasmTypeTag t -> + CmmExpr -> + WasmCodeGenM + w + (WasmExpr w t) +shiftRHSCast lbl t1 x = do + SomeWasmExpr t0 (WasmExpr x_instr) <- lower_CmmExpr lbl x + if + | Just Refl <- t0 `testEquality` t1 -> pure $ WasmExpr x_instr + | TagI32 <- t0, + TagI64 <- t1 -> + pure $ WasmExpr $ x_instr `WasmConcat` WasmI64ExtendI32 Unsigned + | otherwise -> panic "shiftRHSCast: unreachable" + +-- | Lower a 'MO_Shl' operation, truncating the result. +lower_MO_Shl :: + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_Shl lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- shiftRHSCast lbl ty y + pure $ + SomeWasmExpr ty $ + truncSubword w0 ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` WasmShl ty +lower_MO_Shl _ _ _ = panic "lower_MO_Shl: unreachable" + +-- | Lower a 'MO_U_Shr' operation. +lower_MO_U_Shr :: + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_U_Shr lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- shiftRHSCast lbl ty y + pure $ + SomeWasmExpr ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` WasmShr Unsigned ty +lower_MO_U_Shr _ _ _ = panic "lower_MO_U_Shr: unreachable" + +-- | Lower a 'MO_S_Shr' operation, first sign-extending the LHS, then +-- truncating the result. +lower_MO_S_Shr :: + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_S_Shr lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- shiftRHSCast lbl ty y + pure $ + SomeWasmExpr ty $ + truncSubword w0 ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` WasmShr Signed ty +lower_MO_S_Shr _ _ _ = panic "lower_MO_S_Shr: unreachable" + +-- | Lower a 'MO_MulMayOflo' operation. It's translated to a ccall to +-- @hs_mulIntMayOflo@ function in @rts/prim/mulIntMayOflo@, +-- otherwise it's quite non-trivial to implement as inline assembly. +lower_MO_MulMayOflo :: + CLabel -> Width -> [CmmExpr] -> WasmCodeGenM w (SomeWasmExpr w) +lower_MO_MulMayOflo lbl w0 [x, y] = case someWasmTypeFromCmmType ty_cmm of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y + onFuncSym "hs_mulIntMayOflo" [ty_cmm, ty_cmm] [ty_cmm] + pure $ + SomeWasmExpr ty $ + WasmExpr $ + x_instr + `WasmConcat` y_instr + `WasmConcat` WasmCCall "hs_mulIntMayOflo" + where + ty_cmm = cmmBits w0 +lower_MO_MulMayOflo _ _ _ = panic "lower_MO_MulMayOflo: unreachable" + +-- | Lower an unary conversion operation. +lower_MO_Un_Conv :: + ( forall pre t0 t1. + WasmTypeTag t0 -> + WasmTypeTag t1 -> + WasmInstr w (t0 : pre) (t1 : pre) + ) -> + CLabel -> + CmmType -> + CmmType -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Un_Conv op lbl t0 t1 [x] = + case (# someWasmTypeFromCmmType t0, someWasmTypeFromCmmType t1 #) of + (# SomeWasmType ty0, SomeWasmType ty1 #) -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty0 x + pure $ SomeWasmExpr ty1 $ WasmExpr $ x_instr `WasmConcat` op ty0 ty1 +lower_MO_Un_Conv _ _ _ _ _ = panic "lower_MO_Un_Conv: unreachable" + +-- | Lower a 'MO_SS_Conv' operation. +lower_MO_SS_Conv :: + CLabel -> + Width -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_SS_Conv lbl w0 w1 [x] + | w0 == w1 = lower_CmmExpr lbl x +lower_MO_SS_Conv lbl w0 w1 [CmmLoad ptr _ align] + | w0 < w1, + w1 <= W32 = do + (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr + pure $ + SomeWasmExpr TagI32 $ + truncSubword w1 TagI32 $ + WasmExpr $ + ptr_instr + `WasmConcat` WasmLoad + TagI32 + (wasmMemoryNarrowing TagI32 (cmmBits w0)) + Signed + o + align + | w0 > w1 = + SomeWasmExpr TagI32 + <$> lower_CmmLoad_Typed + lbl + ptr + TagI32 + (cmmBits w1) + align +lower_MO_SS_Conv lbl w0 W64 [CmmLoad ptr _ align] = do + (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr + pure $ + SomeWasmExpr TagI64 $ + WasmExpr $ + ptr_instr + `WasmConcat` WasmLoad + TagI64 + (wasmMemoryNarrowing TagI64 (cmmBits w0)) + Signed + o + align +lower_MO_SS_Conv lbl w0 w1 [x] + | w0 < w1, + w1 <= W32 = do + x_expr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ + SomeWasmExpr TagI32 $ + truncSubword w1 TagI32 $ + extendSubword w0 TagI32 x_expr + | W32 >= w0, + w0 > w1 = do + x_expr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ SomeWasmExpr TagI32 $ truncSubword w1 TagI32 x_expr +lower_MO_SS_Conv lbl W32 W64 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ + SomeWasmExpr TagI64 $ + WasmExpr $ + x_instr `WasmConcat` WasmI64ExtendI32 Signed +lower_MO_SS_Conv lbl w0 W64 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ + SomeWasmExpr TagI64 $ + extendSubword w0 TagI64 $ + WasmExpr $ + x_instr `WasmConcat` WasmI64ExtendI32 Unsigned +lower_MO_SS_Conv lbl W64 w1 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x + pure $ + SomeWasmExpr TagI32 $ + truncSubword w1 TagI32 $ + WasmExpr $ + x_instr `WasmConcat` WasmI32WrapI64 +lower_MO_SS_Conv _ _ _ _ = panic "lower_MO_SS_Conv: unreachable" + +-- | Lower a 'MO_UU_Conv' operation. +lower_MO_UU_Conv :: + CLabel -> + Width -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_UU_Conv lbl w0 w1 [CmmLoad ptr _ align] = + case someWasmTypeFromCmmType (cmmBits w1) of + SomeWasmType ty -> + SomeWasmExpr ty + <$> lower_CmmLoad_Typed + lbl + ptr + ty + (cmmBits (min w0 w1)) + align +lower_MO_UU_Conv lbl w0 w1 [x] + | w0 == w1 = lower_CmmExpr lbl x + | w0 < w1, w1 <= W32 = lower_CmmExpr lbl x + | W32 >= w0, + w0 > w1 = do + x_expr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ SomeWasmExpr TagI32 $ truncSubword w1 TagI32 x_expr +lower_MO_UU_Conv lbl _ W64 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ + SomeWasmExpr TagI64 $ + WasmExpr $ + x_instr `WasmConcat` WasmI64ExtendI32 Unsigned +lower_MO_UU_Conv lbl W64 w1 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x + pure $ + SomeWasmExpr TagI32 $ + truncSubword w1 TagI32 $ + WasmExpr $ + x_instr `WasmConcat` WasmI32WrapI64 +lower_MO_UU_Conv _ _ _ _ = panic "lower_MO_UU_Conv: unreachable" + +-- | Lower a 'MO_FF_Conv' operation. +lower_MO_FF_Conv :: + CLabel -> + Width -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_FF_Conv lbl W32 W64 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF32 x + pure $ + SomeWasmExpr TagF64 $ + WasmExpr $ + x_instr `WasmConcat` WasmF64PromoteF32 +lower_MO_FF_Conv lbl W64 W32 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF64 x + pure $ + SomeWasmExpr TagF32 $ + WasmExpr $ + x_instr `WasmConcat` WasmF32DemoteF64 +lower_MO_FF_Conv _ _ _ _ = panic "lower_MO_FF_Conv: unreachable" + + +-- | Lower a 'MO_WF_Bitcast' operation. Note that this is not a conversion, +-- rather it reinterprets the data. +lower_MO_WF_Bitcast :: + CLabel -> + Width -> + [CmmActual] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_WF_Bitcast lbl W32 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ + SomeWasmExpr TagF32 $ + WasmExpr $ + x_instr `WasmConcat` WasmReinterpret TagI32 TagF32 +lower_MO_WF_Bitcast lbl W64 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x + pure $ + SomeWasmExpr TagF64 $ + WasmExpr $ + x_instr `WasmConcat` WasmReinterpret TagI64 TagF64 +lower_MO_WF_Bitcast _ _ _ = panic "lower_MO_WF_Bitcast: unreachable" + +-- | Lower a 'MO_FW_Bitcast' operation. Note that this is not a conversion, +-- rather it reinterprets the data. +lower_MO_FW_Bitcast :: + CLabel -> + Width -> + [CmmActual] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_FW_Bitcast lbl W32 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF32 x + pure $ + SomeWasmExpr TagI32 $ + WasmExpr $ + x_instr `WasmConcat` WasmReinterpret TagF32 TagI32 +lower_MO_FW_Bitcast lbl W64 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF64 x + pure $ + SomeWasmExpr TagI64 $ + WasmExpr $ + x_instr `WasmConcat` WasmReinterpret TagF64 TagI64 +lower_MO_FW_Bitcast _ _ _ = panic "lower_MO_FW_Bitcast: unreachable" + +-- | Lower a 'CmmMachOp'. +lower_CmmMachOp :: + CLabel -> + MachOp -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_CmmMachOp lbl (MO_RelaxedRead w0) [x] = lower_CmmExpr lbl (CmmLoad x (cmmBits w0) NaturallyAligned) +lower_CmmMachOp lbl (MO_Add w0) xs = lower_MO_Bin_Homo_Trunc WasmAdd lbl w0 xs +lower_CmmMachOp lbl (MO_Sub w0) xs = lower_MO_Bin_Homo_Trunc WasmSub lbl w0 xs +lower_CmmMachOp lbl (MO_Eq w0) xs = lower_MO_Bin_Rel WasmEq lbl (cmmBits w0) xs +lower_CmmMachOp lbl (MO_Ne w0) xs = lower_MO_Bin_Rel WasmNe lbl (cmmBits w0) xs +lower_CmmMachOp lbl (MO_Mul w0) xs = lower_MO_Bin_Homo_Trunc WasmMul lbl w0 xs +lower_CmmMachOp lbl (MO_S_MulMayOflo w0) xs = lower_MO_MulMayOflo lbl w0 xs +lower_CmmMachOp lbl (MO_S_Quot w0) xs = + lower_MO_Bin_Homo_Ext_Trunc + (WasmDiv Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_S_Rem w0) xs = + lower_MO_Bin_Homo_Ext_Trunc + (WasmRem Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_S_Neg w0) [x] = + lower_CmmMachOp + lbl + (MO_Sub w0) + [CmmLit $ CmmInt 0 w0, x] +lower_CmmMachOp lbl (MO_U_Quot w0) xs = + lower_MO_Bin_Homo + (WasmDiv Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_U_Rem w0) xs = + lower_MO_Bin_Homo + (WasmRem Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_S_Ge w0) xs = + lower_MO_Bin_Rel_Ext + (WasmGe Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_S_Le w0) xs = + lower_MO_Bin_Rel_Ext + (WasmLe Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_S_Gt w0) xs = + lower_MO_Bin_Rel_Ext + (WasmGt Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_S_Lt w0) xs = + lower_MO_Bin_Rel_Ext + (WasmLt Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_U_Ge w0) xs = + lower_MO_Bin_Rel + (WasmGe Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_U_Le w0) xs = + lower_MO_Bin_Rel + (WasmLe Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_U_Gt w0) xs = + lower_MO_Bin_Rel + (WasmGt Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_U_Lt w0) xs = + lower_MO_Bin_Rel + (WasmLt Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_F_Add w0) xs = + lower_MO_Bin_Homo + WasmAdd + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Sub w0) xs = + lower_MO_Bin_Homo + WasmSub + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Neg w0) xs = + lower_MO_Un_Homo + WasmNeg + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Mul w0) xs = + lower_MO_Bin_Homo + WasmMul + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Quot w0) xs = + lower_MO_Bin_Homo + (WasmDiv Signed) + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Eq w0) xs = + lower_MO_Bin_Rel + WasmEq + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Ne w0) xs = + lower_MO_Bin_Rel + WasmNe + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Ge w0) xs = + lower_MO_Bin_Rel + (WasmGe Signed) + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Le w0) xs = + lower_MO_Bin_Rel + (WasmLe Signed) + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Gt w0) xs = + lower_MO_Bin_Rel + (WasmGt Signed) + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Lt w0) xs = + lower_MO_Bin_Rel + (WasmLt Signed) + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Min w0) xs = + lower_MO_Bin_Homo + WasmMin + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Max w0) xs = + lower_MO_Bin_Homo + WasmMax + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_And w0) xs = + lower_MO_Bin_Homo + WasmAnd + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_Or w0) xs = lower_MO_Bin_Homo WasmOr lbl (cmmBits w0) xs +lower_CmmMachOp lbl (MO_Xor w0) xs = + lower_MO_Bin_Homo + WasmXor + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_Not w0) [x] = + lower_CmmMachOp + lbl + (MO_Xor w0) + [x, CmmLit $ CmmInt (widthMax w0) w0] +lower_CmmMachOp lbl (MO_Shl w0) xs = lower_MO_Shl lbl w0 xs +lower_CmmMachOp lbl (MO_U_Shr w0) xs = lower_MO_U_Shr lbl w0 xs +lower_CmmMachOp lbl (MO_S_Shr w0) xs = lower_MO_S_Shr lbl w0 xs +lower_CmmMachOp lbl (MO_SF_Round w0 w1) xs = + lower_MO_Un_Conv + (WasmConvert Signed) + lbl + (cmmBits w0) + (cmmFloat w1) + xs +lower_CmmMachOp lbl (MO_FS_Truncate w0 w1) xs = + lower_MO_Un_Conv + (WasmTruncSat Signed) + lbl + (cmmFloat w0) + (cmmBits w1) + xs +lower_CmmMachOp lbl (MO_SS_Conv w0 w1) xs = lower_MO_SS_Conv lbl w0 w1 xs +lower_CmmMachOp lbl (MO_UU_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs +lower_CmmMachOp lbl (MO_XX_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs +lower_CmmMachOp lbl (MO_FF_Conv w0 w1) xs = lower_MO_FF_Conv lbl w0 w1 xs +lower_CmmMachOp lbl (MO_FW_Bitcast w) xs = lower_MO_FW_Bitcast lbl w xs +lower_CmmMachOp lbl (MO_WF_Bitcast w) xs = lower_MO_WF_Bitcast lbl w xs +lower_CmmMachOp _ mop _ = + pprPanic "lower_CmmMachOp: unreachable" $ + vcat [ text "offending MachOp:" <+> pprMachOp mop ] + +-- | Lower a 'CmmLit'. Note that we don't emit 'f32.const' or +-- 'f64.const' for the time being, and instead emit their relative bit +-- pattern as int literals, then use an reinterpret cast. This is +-- simpler than dealing with textual representation of floating point +-- values. +lower_CmmLit :: CmmLit -> WasmCodeGenM w (SomeWasmExpr w) +lower_CmmLit lit = do + ty_word <- wasmWordTypeM + case lit of + CmmInt i w -> case someWasmTypeFromCmmType (cmmBits w) of + SomeWasmType ty -> + pure $ + SomeWasmExpr ty $ + WasmExpr $ + WasmConst ty $ + narrowU w i + CmmFloat f W32 -> + pure $ + SomeWasmExpr TagF32 $ + WasmExpr $ + WasmConst + TagI32 + (toInteger $ castFloatToWord32 $ fromRational f) + `WasmConcat` WasmReinterpret TagI32 TagF32 + CmmFloat f W64 -> + pure $ + SomeWasmExpr TagF64 $ + WasmExpr $ + WasmConst + TagI64 + (toInteger $ castDoubleToWord64 $ fromRational f) + `WasmConcat` WasmReinterpret TagI64 TagF64 + CmmLabel lbl' -> do + onAnySym lbl' + let sym = symNameFromCLabel lbl' + pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst sym + CmmLabelOff lbl' o -> do + onAnySym lbl' + let sym = symNameFromCLabel lbl' + pure $ + SomeWasmExpr ty_word $ + WasmExpr $ + WasmSymConst sym + `WasmConcat` WasmConst ty_word (toInteger o) + `WasmConcat` WasmAdd ty_word + CmmBlock bid -> lower_CmmLit $ CmmLabel $ infoTblLbl bid + _ -> panic "lower_CmmLit: unreachable" + +-- | Lower a 'CmmReg'. Some of the logic here wouldn't be needed if +-- we have run 'fixStgRegisters' on the wasm NCG's input Cmm, but we +-- haven't run it yet for certain reasons. +lower_CmmReg :: CLabel -> CmmReg -> WasmCodeGenM w (SomeWasmExpr w) +lower_CmmReg _ (CmmLocal reg) = do + (reg_i, SomeWasmType ty) <- onCmmLocalReg reg + pure $ SomeWasmExpr ty $ WasmExpr $ WasmLocalGet ty reg_i +lower_CmmReg lbl (CmmGlobal (GlobalRegUse greg reg_use_ty)) = do + ty_word <- wasmWordTypeM + ty_word_cmm <- wasmWordCmmTypeM + case greg of + EagerBlackholeInfo -> + pure $ + SomeWasmExpr ty_word $ + WasmExpr $ + WasmSymConst "__stg_EAGER_BLACKHOLE_info" + GCEnter1 -> do + onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm] + pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1" + GCFun -> do + onFuncSym "__stg_gc_fun" [] [ty_word_cmm] + pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_fun" + BaseReg -> do + platform <- wasmPlatformM + lower_CmmExpr lbl $ regTableOffset platform 0 + _other + | Just (sym_global, SomeWasmType ty) <- + globalInfoFromCmmGlobalReg ty_word greg -> + pure $ SomeWasmExpr ty $ WasmExpr $ WasmGlobalGet ty sym_global + | otherwise -> do + platform <- wasmPlatformM + case someWasmTypeFromCmmType reg_use_ty of + SomeWasmType ty -> do + (WasmExpr ptr_instr, o) <- + lower_CmmExpr_Ptr lbl $ + get_GlobalReg_addr platform greg + pure $ + SomeWasmExpr ty $ + WasmExpr $ + ptr_instr + `WasmConcat` WasmLoad + ty + Nothing + Unsigned + o + NaturallyAligned + +-- | Lower a 'CmmRegOff'. +lower_CmmRegOff :: CLabel -> CmmReg -> Int -> WasmCodeGenM w (SomeWasmExpr w) +lower_CmmRegOff lbl reg 0 = lower_CmmReg lbl reg +lower_CmmRegOff lbl reg o = do + SomeWasmExpr ty (WasmExpr reg_instr) <- lower_CmmReg lbl reg + pure $ + SomeWasmExpr ty $ + WasmExpr $ + reg_instr + `WasmConcat` WasmConst + ty + (toInteger o) + `WasmConcat` WasmAdd ty + +-- | Lower a 'CmmLoad', passing in the expected wasm representation +-- type, and also the Cmm type (which contains width info needed for +-- memory narrowing). +-- +-- The Cmm type system doesn't track signedness, so all 'CmmLoad's are +-- unsigned loads. However, as an optimization, we do emit signed +-- loads when a 'CmmLoad' result is immediately used as a 'MO_SS_Conv' +-- operand. +lower_CmmLoad_Typed :: + CLabel -> + CmmExpr -> + WasmTypeTag t -> + CmmType -> + AlignmentSpec -> + WasmCodeGenM w (WasmExpr w t) +lower_CmmLoad_Typed lbl ptr_expr ty ty_cmm align = do + (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr_expr + pure $ + WasmExpr $ + ptr_instr + `WasmConcat` WasmLoad + ty + (wasmMemoryNarrowing ty ty_cmm) + Unsigned + o + align + +-- | Lower a 'CmmLoad'. +lower_CmmLoad :: + CLabel -> + CmmExpr -> + CmmType -> + AlignmentSpec -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_CmmLoad lbl ptr_expr ty_cmm align = case someWasmTypeFromCmmType ty_cmm of + SomeWasmType ty -> + SomeWasmExpr ty <$> lower_CmmLoad_Typed lbl ptr_expr ty ty_cmm align + +-- | Lower a 'CmmExpr'. +lower_CmmExpr :: CLabel -> CmmExpr -> WasmCodeGenM w (SomeWasmExpr w) +lower_CmmExpr lbl expr = case expr of + CmmLit lit -> lower_CmmLit lit + CmmLoad ptr_expr ty_cmm align -> lower_CmmLoad lbl ptr_expr ty_cmm align + CmmReg reg -> lower_CmmReg lbl reg + CmmRegOff reg o -> lower_CmmRegOff lbl reg o + CmmMachOp op xs -> lower_CmmMachOp lbl op xs + _ -> panic "lower_CmmExpr: unreachable" + +-- | Lower a 'CmmExpr', passing in the expected wasm representation +-- type. +lower_CmmExpr_Typed :: + CLabel -> + WasmTypeTag t -> + CmmExpr -> + WasmCodeGenM + w + (WasmExpr w t) +lower_CmmExpr_Typed lbl ty expr = do + SomeWasmExpr ty' r <- lower_CmmExpr lbl expr + if + | Just Refl <- ty' `testEquality` ty -> pure r + | otherwise -> panic "lower_CmmExpr_Typed: unreachable" + +-- | Lower a 'CmmExpr' as a pointer, returning the pair of base +-- pointer and non-negative offset. +lower_CmmExpr_Ptr :: CLabel -> CmmExpr -> WasmCodeGenM w (WasmExpr w w, Int) +lower_CmmExpr_Ptr lbl ptr = do + ty_word <- wasmWordTypeM + let (ptr', o) = case ptr of + CmmLit (CmmLabelOff lbl o) + | o >= 0 -> (CmmLit $ CmmLabel lbl, o) + CmmRegOff reg o + | o >= 0 -> (CmmReg reg, o) + CmmMachOp (MO_Add _) [base, CmmLit (CmmInt o _)] + | o >= 0 -> (base, fromInteger o) + _ -> (ptr, 0) + instrs <- lower_CmmExpr_Typed lbl ty_word ptr' + pure (instrs, o) + +-- | Push a series of values onto the wasm value stack, returning the +-- result stack type. +type family + WasmPushes (ts :: [WasmType]) (pre :: [WasmType]) :: + [WasmType] + where + WasmPushes '[] pre = pre + WasmPushes (t : ts) pre = WasmPushes ts (t : pre) + +-- | Push the arguments onto the wasm value stack before a ccall. +data SomeWasmPreCCall w where + SomeWasmPreCCall :: + TypeList ts -> + (forall pre. WasmInstr w pre (WasmPushes ts pre)) -> + SomeWasmPreCCall w + +-- | Pop the results into locals after a ccall. +data SomeWasmPostCCall w where + SomeWasmPostCCall :: + TypeList ts -> + (forall post. WasmInstr w (WasmPushes ts post) post) -> + SomeWasmPostCCall w + +-- | Lower an unary homogeneous 'CallishMachOp' to a ccall. +lower_CMO_Un_Homo :: + CLabel -> + SymName -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_CMO_Un_Homo lbl op [reg] [x] = do + (ri, SomeWasmType ty) <- onCmmLocalReg reg + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + let ty_cmm = localRegType reg + onFuncSym op [ty_cmm] [ty_cmm] + pure $ + WasmStatements $ + x_instr `WasmConcat` WasmCCall op `WasmConcat` WasmLocalSet ty ri +lower_CMO_Un_Homo _ _ _ _ = panic "lower_CMO_Un_Homo: unreachable" + +-- | Lower an unary homogeneous 'CallishMachOp' to a primitive operation. +lower_CMO_Un_Homo_Prim :: + CLabel -> + ( forall pre t. + WasmTypeTag t -> + WasmInstr + w + (t : pre) + (t : pre) + ) -> + WasmTypeTag t -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_CMO_Un_Homo_Prim lbl op ty [reg] [x] = do + (ri, _) <- onCmmLocalReg reg + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + pure $ + WasmStatements $ + x_instr `WasmConcat` op ty `WasmConcat` WasmLocalSet ty ri +lower_CMO_Un_Homo_Prim _ _ _ _ _ = panic "lower_CMO_Bin_Homo_Prim: unreachable" + +-- | Lower a binary homogeneous 'CallishMachOp' to a ccall. +lower_CMO_Bin_Homo :: + CLabel -> + SymName -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_CMO_Bin_Homo lbl op [reg] [x, y] = do + (ri, SomeWasmType ty) <- onCmmLocalReg reg + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y + let ty_cmm = localRegType reg + onFuncSym op [ty_cmm, ty_cmm] [ty_cmm] + pure $ + WasmStatements $ + x_instr + `WasmConcat` y_instr + `WasmConcat` WasmCCall op + `WasmConcat` WasmLocalSet ty ri +lower_CMO_Bin_Homo _ _ _ _ = panic "lower_CMO_Bin_Homo: unreachable" + +-- | Lower a 'MO_UF_Conv' operation. +lower_MO_UF_Conv :: + CLabel -> + Width -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_MO_UF_Conv lbl W32 [reg] [x] = do + ri <- onCmmLocalReg_Typed TagF32 reg + SomeWasmExpr ty0 (WasmExpr x_instr) <- lower_CmmExpr lbl x + pure $ + WasmStatements $ + x_instr + `WasmConcat` WasmConvert Unsigned ty0 TagF32 + `WasmConcat` WasmLocalSet TagF32 ri +lower_MO_UF_Conv lbl W64 [reg] [x] = do + ri <- onCmmLocalReg_Typed TagF64 reg + SomeWasmExpr ty0 (WasmExpr x_instr) <- lower_CmmExpr lbl x + pure $ + WasmStatements $ + x_instr + `WasmConcat` WasmConvert Unsigned ty0 TagF64 + `WasmConcat` WasmLocalSet TagF64 ri +lower_MO_UF_Conv _ _ _ _ = panic "lower_MO_UF_Conv: unreachable" + +-- | Lower a 'MO_Cmpxchg' operation to inline assembly. Currently we +-- target wasm without atomics and threads, so it's just lowered to +-- regular memory loads and stores. +lower_MO_Cmpxchg :: + CLabel -> + Width -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_MO_Cmpxchg lbl w0 [reg] [ptr, expected, new] = + case someWasmTypeFromCmmType ty_cmm of + SomeWasmType ty -> do + reg_i <- onCmmLocalReg_Typed ty reg + let narrowing = wasmMemoryNarrowing ty ty_cmm + (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr + WasmExpr expected_instr <- lower_CmmExpr_Typed lbl ty expected + WasmExpr new_instr <- lower_CmmExpr_Typed lbl ty new + pure $ + WasmStatements $ + ptr_instr + `WasmConcat` WasmLoad ty narrowing Unsigned o NaturallyAligned + `WasmConcat` WasmLocalTee ty reg_i + `WasmConcat` expected_instr + `WasmConcat` WasmEq ty + `WasmConcat` WasmCond + ( ptr_instr + `WasmConcat` new_instr + `WasmConcat` WasmStore ty narrowing o NaturallyAligned + ) + where + ty_cmm = cmmBits w0 +lower_MO_Cmpxchg _ _ _ _ = panic "lower_MO_Cmpxchg: unreachable" + +-- | Lower a 'CallishMachOp'. +lower_CallishMachOp :: + CLabel -> + CallishMachOp -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_CallishMachOp lbl MO_F64_Pwr rs xs = lower_CMO_Bin_Homo lbl "pow" rs xs +lower_CallishMachOp lbl MO_F64_Sin rs xs = lower_CMO_Un_Homo lbl "sin" rs xs +lower_CallishMachOp lbl MO_F64_Cos rs xs = lower_CMO_Un_Homo lbl "cos" rs xs +lower_CallishMachOp lbl MO_F64_Tan rs xs = lower_CMO_Un_Homo lbl "tan" rs xs +lower_CallishMachOp lbl MO_F64_Sinh rs xs = lower_CMO_Un_Homo lbl "sinh" rs xs +lower_CallishMachOp lbl MO_F64_Cosh rs xs = lower_CMO_Un_Homo lbl "cosh" rs xs +lower_CallishMachOp lbl MO_F64_Tanh rs xs = lower_CMO_Un_Homo lbl "tanh" rs xs +lower_CallishMachOp lbl MO_F64_Asin rs xs = lower_CMO_Un_Homo lbl "asin" rs xs +lower_CallishMachOp lbl MO_F64_Acos rs xs = lower_CMO_Un_Homo lbl "acos" rs xs +lower_CallishMachOp lbl MO_F64_Atan rs xs = lower_CMO_Un_Homo lbl "atan" rs xs +lower_CallishMachOp lbl MO_F64_Asinh rs xs = lower_CMO_Un_Homo lbl "asinh" rs xs +lower_CallishMachOp lbl MO_F64_Acosh rs xs = lower_CMO_Un_Homo lbl "acosh" rs xs +lower_CallishMachOp lbl MO_F64_Atanh rs xs = lower_CMO_Un_Homo lbl "atanh" rs xs +lower_CallishMachOp lbl MO_F64_Log rs xs = lower_CMO_Un_Homo lbl "log" rs xs +lower_CallishMachOp lbl MO_F64_Log1P rs xs = lower_CMO_Un_Homo lbl "log1p" rs xs +lower_CallishMachOp lbl MO_F64_Exp rs xs = lower_CMO_Un_Homo lbl "exp" rs xs +lower_CallishMachOp lbl MO_F64_ExpM1 rs xs = lower_CMO_Un_Homo lbl "expm1" rs xs +lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF64 rs xs +lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF64 rs xs +lower_CallishMachOp lbl MO_F32_Pwr rs xs = lower_CMO_Bin_Homo lbl "powf" rs xs +lower_CallishMachOp lbl MO_F32_Sin rs xs = lower_CMO_Un_Homo lbl "sinf" rs xs +lower_CallishMachOp lbl MO_F32_Cos rs xs = lower_CMO_Un_Homo lbl "cosf" rs xs +lower_CallishMachOp lbl MO_F32_Tan rs xs = lower_CMO_Un_Homo lbl "tanf" rs xs +lower_CallishMachOp lbl MO_F32_Sinh rs xs = lower_CMO_Un_Homo lbl "sinhf" rs xs +lower_CallishMachOp lbl MO_F32_Cosh rs xs = lower_CMO_Un_Homo lbl "coshf" rs xs +lower_CallishMachOp lbl MO_F32_Tanh rs xs = lower_CMO_Un_Homo lbl "tanhf" rs xs +lower_CallishMachOp lbl MO_F32_Asin rs xs = lower_CMO_Un_Homo lbl "asinf" rs xs +lower_CallishMachOp lbl MO_F32_Acos rs xs = lower_CMO_Un_Homo lbl "acosf" rs xs +lower_CallishMachOp lbl MO_F32_Atan rs xs = lower_CMO_Un_Homo lbl "atanf" rs xs +lower_CallishMachOp lbl MO_F32_Asinh rs xs = + lower_CMO_Un_Homo lbl "asinhf" rs xs +lower_CallishMachOp lbl MO_F32_Acosh rs xs = + lower_CMO_Un_Homo lbl "acoshf" rs xs +lower_CallishMachOp lbl MO_F32_Atanh rs xs = + lower_CMO_Un_Homo lbl "atanhf" rs xs +lower_CallishMachOp lbl MO_F32_Log rs xs = lower_CMO_Un_Homo lbl "logf" rs xs +lower_CallishMachOp lbl MO_F32_Log1P rs xs = + lower_CMO_Un_Homo lbl "log1pf" rs xs +lower_CallishMachOp lbl MO_F32_Exp rs xs = lower_CMO_Un_Homo lbl "expf" rs xs +lower_CallishMachOp lbl MO_F32_ExpM1 rs xs = + lower_CMO_Un_Homo lbl "expm1f" rs xs +lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF32 rs xs +lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF32 rs xs +lower_CallishMachOp lbl (MO_UF_Conv w0) rs xs = lower_MO_UF_Conv lbl w0 rs xs +lower_CallishMachOp _ MO_AcquireFence _ _ = pure $ WasmStatements WasmNop +lower_CallishMachOp _ MO_ReleaseFence _ _ = pure $ WasmStatements WasmNop +lower_CallishMachOp _ MO_SeqCstFence _ _ = pure $ WasmStatements WasmNop +lower_CallishMachOp _ MO_Touch _ _ = pure $ WasmStatements WasmNop +lower_CallishMachOp _ (MO_Prefetch_Data {}) _ _ = pure $ WasmStatements WasmNop +lower_CallishMachOp lbl (MO_Memcpy {}) [] xs = do + ty_word_cmm <- wasmWordCmmTypeM + lower_CmmUnsafeForeignCall_Drop lbl "memcpy" ty_word_cmm xs +lower_CallishMachOp lbl (MO_Memset {}) [] xs = do + ty_word_cmm <- wasmWordCmmTypeM + lower_CmmUnsafeForeignCall_Drop lbl "memset" ty_word_cmm xs +lower_CallishMachOp lbl (MO_Memmove {}) [] xs = do + ty_word_cmm <- wasmWordCmmTypeM + lower_CmmUnsafeForeignCall_Drop lbl "memmove" ty_word_cmm xs +lower_CallishMachOp lbl (MO_Memcmp {}) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left "memcmp") + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_PopCnt w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_popcnt" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_Pdep w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_pdep" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_Pext w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_pext" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_Clz w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_clz" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_Ctz w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_ctz" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_BSwap w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_bswap" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_BRev w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_bitrev" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_AtomicRMW w0 op) rs xs = + lower_CmmUnsafeForeignCall + lbl + ( Left $ + fromString $ + ( case op of + AMO_Add -> "hs_atomic_add" + AMO_Sub -> "hs_atomic_sub" + AMO_And -> "hs_atomic_and" + AMO_Nand -> "hs_atomic_nand" + AMO_Or -> "hs_atomic_or" + AMO_Xor -> "hs_atomic_xor" + ) + <> show (widthInBits w0) + ) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_AtomicRead w0 _) [reg] [ptr] = do + SomeWasmExpr ty (WasmExpr ret_instr) <- + lower_CmmLoad + lbl + ptr + (cmmBits w0) + NaturallyAligned + ri <- onCmmLocalReg_Typed ty reg + pure $ WasmStatements $ ret_instr `WasmConcat` WasmLocalSet ty ri +lower_CallishMachOp lbl (MO_AtomicWrite _ _) [] [ptr, val] = + lower_CmmStore lbl ptr val NaturallyAligned +lower_CallishMachOp lbl (MO_Cmpxchg w0) rs xs = lower_MO_Cmpxchg lbl w0 rs xs +lower_CallishMachOp lbl (MO_Xchg w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_xchg" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl MO_SuspendThread rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left "suspendThread") + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl MO_ResumeThread rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left "resumeThread") + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp _ _ _ _ = panic "lower_CallishMachOp: unreachable" + +-- | Lower a ccall, but drop the result by assigning it to an unused +-- local. This is only used for lowering 'MO_Memcpy' and such, where +-- the libc functions do have a return value, but the corresponding +-- 'CallishMachOp' does not expect one. +lower_CmmUnsafeForeignCall_Drop :: + CLabel -> + SymName -> + CmmType -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do + ret_uniq <- getUniqueM + let ret_local = LocalReg ret_uniq ret_cmm_ty + lower_CmmUnsafeForeignCall + lbl + (Left sym_callee) + Nothing + CmmMayReturn + [ret_local] + arg_exprs + +-- | Lower a 'CmmUnsafeForeignCall'. The target is 'Either' a symbol, +-- which translates to a direct @call@, or an expression, which +-- translates to a @call_indirect@. The callee function signature is +-- inferred from the passed in arguments here. +lower_CmmUnsafeForeignCall :: + CLabel -> + (Either SymName CmmExpr) -> + Maybe + ([ForeignHint], [ForeignHint]) -> + CmmReturnInfo -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_CmmUnsafeForeignCall lbl target mb_hints ret_info ret_locals arg_exprs = do + platform <- wasmPlatformM + SomeWasmPreCCall arg_tys args_instr <- + foldrM + ( \(arg_expr, arg_hint) (SomeWasmPreCCall acc_tys acc_instr) -> do + SomeWasmExpr arg_ty arg_wasm_expr <- lower_CmmExpr lbl arg_expr + let WasmExpr arg_instr = case arg_hint of + SignedHint -> + extendSubword + (cmmExprWidth platform arg_expr) + arg_ty + arg_wasm_expr + _ -> arg_wasm_expr + pure $ + SomeWasmPreCCall (arg_ty `TypeListCons` acc_tys) $ + arg_instr `WasmConcat` acc_instr + ) + (SomeWasmPreCCall TypeListNil WasmNop) + arg_exprs_hints + SomeWasmPostCCall ret_tys ret_instr <- + foldrM + ( \(reg, ret_hint) (SomeWasmPostCCall acc_tys acc_instr) -> do + (reg_i, SomeWasmType reg_ty) <- onCmmLocalReg reg + pure $ + SomeWasmPostCCall (reg_ty `TypeListCons` acc_tys) $ + case (# ret_hint, cmmRegWidth $ CmmLocal reg #) of + (# SignedHint, W8 #) -> + acc_instr + `WasmConcat` WasmConst reg_ty 0xFF + `WasmConcat` WasmAnd reg_ty + `WasmConcat` WasmLocalSet reg_ty reg_i + (# SignedHint, W16 #) -> + acc_instr + `WasmConcat` WasmConst reg_ty 0xFFFF + `WasmConcat` WasmAnd reg_ty + `WasmConcat` WasmLocalSet reg_ty reg_i + _ -> acc_instr `WasmConcat` WasmLocalSet reg_ty reg_i + ) + (SomeWasmPostCCall TypeListNil WasmNop) + ret_locals_hints + case target of + Left sym_callee -> do + platform <- wasmPlatformM + let arg_cmm_tys = map (cmmExprType platform) arg_exprs + ret_cmm_tys = map localRegType ret_locals + onFuncSym sym_callee arg_cmm_tys ret_cmm_tys + pure $ + WasmStatements $ + args_instr + `WasmConcat` WasmCCall sym_callee + `WasmConcat` ( case ret_info of + CmmMayReturn -> ret_instr + CmmNeverReturns -> WasmUnreachable + ) + Right fptr_callee -> do + (WasmExpr instr_callee, _) <- lower_CmmExpr_Ptr lbl fptr_callee + pure $ + WasmStatements $ + args_instr + `WasmConcat` instr_callee + `WasmConcat` WasmCCallIndirect arg_tys ret_tys + `WasmConcat` ( case ret_info of + CmmMayReturn -> ret_instr + CmmNeverReturns -> WasmUnreachable + ) + where + (# arg_exprs_hints, ret_locals_hints #) = case mb_hints of + Just (arg_hints, ret_hints) -> + (# zip arg_exprs arg_hints, zip ret_locals ret_hints #) + _ -> (# map (,NoHint) arg_exprs, map (,NoHint) ret_locals #) + +-- | Lower a 'CmmStore'. +lower_CmmStore :: + CLabel -> + CmmExpr -> + CmmExpr -> + AlignmentSpec -> + WasmCodeGenM + w + (WasmStatements w) +lower_CmmStore lbl ptr val align = do + platform <- wasmPlatformM + (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr + let ty_cmm = cmmExprType platform val + SomeWasmExpr ty (WasmExpr val_instr) <- lower_CmmExpr lbl val + pure $ + WasmStatements $ + ptr_instr + `WasmConcat` val_instr + `WasmConcat` WasmStore ty (wasmMemoryNarrowing ty ty_cmm) o align + +-- | Lower a single Cmm action. +lower_CmmAction :: CLabel -> CmmNode O O -> WasmCodeGenM w (WasmStatements w) +lower_CmmAction lbl act = do + ty_word <- wasmWordTypeM + platform <- wasmPlatformM + case act of + CmmComment {} -> pure $ WasmStatements WasmNop + CmmTick {} -> pure $ WasmStatements WasmNop + CmmUnwind {} -> pure $ WasmStatements WasmNop + CmmAssign (CmmLocal reg) e -> do + (i, SomeWasmType ty_reg) <- onCmmLocalReg reg + WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e + pure $ WasmStatements $ instrs `WasmConcat` WasmLocalSet ty_reg i + CmmAssign (CmmGlobal (GlobalRegUse reg _)) e + | BaseReg <- reg -> pure $ WasmStatements WasmNop + | Just (sym_global, SomeWasmType ty_reg) <- + globalInfoFromCmmGlobalReg ty_word reg -> do + WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e + pure $ + WasmStatements $ + instrs `WasmConcat` WasmGlobalSet ty_reg sym_global + | otherwise -> do + (WasmExpr ptr_instr, o) <- + lower_CmmExpr_Ptr lbl $ get_GlobalReg_addr platform reg + SomeWasmExpr ty_e (WasmExpr instrs) <- lower_CmmExpr lbl e + pure $ + WasmStatements $ + ptr_instr + `WasmConcat` instrs + `WasmConcat` WasmStore ty_e Nothing o NaturallyAligned + CmmStore ptr val align -> lower_CmmStore lbl ptr val align + CmmUnsafeForeignCall + ( ForeignTarget + (CmmLit (CmmLabel lbl_callee)) + (ForeignConvention conv arg_hints ret_hints ret_info) + ) + ret_locals + arg_exprs + | conv `elem` [CCallConv, CApiConv] -> + lower_CmmUnsafeForeignCall + lbl + (Left $ symNameFromCLabel lbl_callee) + (Just (arg_hints, ret_hints)) + ret_info + ret_locals + arg_exprs + CmmUnsafeForeignCall + (ForeignTarget target_expr (ForeignConvention conv arg_hints ret_hints ret_info)) + ret_locals + arg_exprs + | conv `elem` [CCallConv, CApiConv] -> + lower_CmmUnsafeForeignCall + lbl + (Right target_expr) + (Just (arg_hints, ret_hints)) + ret_info + ret_locals + arg_exprs + CmmUnsafeForeignCall (PrimTarget op) ret_locals arg_exprs -> + lower_CallishMachOp lbl op ret_locals arg_exprs + _ -> panic "lower_CmmAction: unreachable" + +-- | Lower a block of Cmm actions. +lower_CmmActions :: + CLabel -> + Label -> + Block CmmNode O O -> + WasmCodeGenM + w + (WasmStatements w) +lower_CmmActions lbl _ blk = + foldlM + ( \(WasmStatements acc) act -> + (\(WasmStatements stmts) -> WasmStatements $ acc `WasmConcat` stmts) + <$> lower_CmmAction lbl act + ) + (WasmStatements WasmNop) + acts + where + acts = blockToList blk + +-- | Lower a 'CmmGraph'. +lower_CmmGraph :: CLabel -> CmmGraph -> WasmCodeGenM w (FuncBody w) +lower_CmmGraph lbl g = do + ty_word <- wasmWordTypeM + platform <- wasmPlatformM + body <- + structuredControl + platform + (\_ -> lower_CmmExpr_Typed lbl ty_word) + (lower_CmmActions lbl) + g + locals <- wasmStateM $ \s -> + (# + map snd $ detEltsUFM $ localRegs s, + s {localRegs = emptyUFM, localRegsCount = 0} + #) + pure FuncBody {funcLocals = locals, funcBody = wasmControlCast $ body} + +-- | Invoked once for each 'CLabel' which indexes a 'CmmData' or +-- 'CmmProc'. +onTopSym :: CLabel -> WasmCodeGenM w () +onTopSym lbl = case sym_vis of + SymDefault -> wasmModifyM $ \s -> + s + { defaultSyms = + insertUniqueSet + (getUnique sym) + $ defaultSyms s + } + _ -> pure () + where + sym = symNameFromCLabel lbl + + sym_vis = symVisibilityFromCLabel lbl + +-- | Invoked for each function 'CLabel' with known type (e.g. a +-- 'CmmProc', or callee of 'CmmUnsafeForeignCall'). +onFuncSym :: SymName -> [CmmType] -> [CmmType] -> WasmCodeGenM w () +onFuncSym sym arg_tys ret_tys = wasmModifyM $ + \s@WasmCodeGenState {..} -> + s + { funcTypes = + addToUniqMap + funcTypes + sym + ( map someWasmTypeFromCmmType arg_tys, + map someWasmTypeFromCmmType ret_tys + ) + } + +-- | Invoked for all other 'CLabel's along the way, e.g. in +-- 'CmmStatic's or 'CmmExpr's. +onAnySym :: CLabel -> WasmCodeGenM w () +onAnySym lbl = case sym_kind of + SymFunc -> do + ty_word <- wasmWordTypeM + wasmModifyM $ \s@WasmCodeGenState {..} -> + s {funcTypes = addToUniqMap_C const funcTypes sym ([], [SomeWasmType ty_word])} + _ -> pure () + where + sym = symNameFromCLabel lbl + + sym_kind = symKindFromCLabel lbl + +-- | Invoked for each 'LocalReg', returning its wasm local id and +-- representation type. +onCmmLocalReg :: LocalReg -> WasmCodeGenM w LocalInfo +onCmmLocalReg reg = wasmStateM $ \s@WasmCodeGenState {..} -> + let reg_info = + (localRegsCount, someWasmTypeFromCmmType $ localRegType reg) + in case addToUFM_L (\_ i _ -> i) reg reg_info localRegs of + (Just i, _) -> (# i, s #) + (_, localRegs') -> + (# + reg_info, + s + { localRegs = localRegs', + localRegsCount = + localRegsCount + 1 + } + #) + +-- | Invoked for each 'LocalReg' with expected representation type, +-- only returning its wasm local id. +onCmmLocalReg_Typed :: WasmTypeTag t -> LocalReg -> WasmCodeGenM w Int +onCmmLocalReg_Typed ty reg = do + (i, SomeWasmType ty') <- onCmmLocalReg reg + if + | Just Refl <- ty' `testEquality` ty -> pure i + | otherwise -> panic "onCmmLocalReg_Typed: unreachable" + +-- | Invoked for dtors. We don't bother to implement dtors yet; +-- there's no native @.fini_array@ support for wasm, and the way +-- @clang@ handles dtors is generating a ctor that calls @atexit()@ +-- for dtors. Which makes some sense, but we don't need to do the same +-- thing yet. +onFini :: [SymName] -> WasmCodeGenM w () +onFini syms = do + let n_finis = length syms + when (n_finis /= 0) $ panic "dtors unsupported by wasm32 NCG" + +-- | Invoked for ctors and dtors. +onCmmInitFini :: InitOrFini -> [CLabel] -> WasmCodeGenM w () +onCmmInitFini iof lbls = do + for_ lbls $ \lbl -> onFuncSym (symNameFromCLabel lbl) [] [] + case iof of + IsInitArray -> wasmModifyM $ \s -> s {ctors = syms <> ctors s} + IsFiniArray -> onFini syms + where + syms = map symNameFromCLabel lbls + +-- | Invoked for each data section. +onCmmData :: CLabel -> Section -> [CmmStatic] -> WasmCodeGenM w () +onCmmData lbl s statics = do + ty_word <- wasmWordTypeM + onTopSym lbl + cs <- for statics lower_CmmStatic + let sym = symNameFromCLabel lbl + sec = + DataSection + { dataSectionKind = + dataSectionKindFromCmmSection s, + dataSectionAlignment = + alignmentFromCmmSection ty_word cs, + dataSectionContents = + case cs of + [DataASCII buf] -> [DataASCII $ buf `BS.snoc` 0] + [DataIncBin p l] -> [DataIncBin p l, DataI8 0] + _ -> cs + } + wasmModifyM $ \s -> + s + { dataSections = + addToUniqMap (dataSections s) sym sec + } + +-- | Invoked for each 'CmmProc'. +onCmmProc :: CLabel -> CmmGraph -> WasmCodeGenM w () +onCmmProc lbl g = do + ty_word <- wasmWordCmmTypeM + onTopSym lbl + onFuncSym sym [] [ty_word] + body <- lower_CmmGraph lbl g + wasmModifyM $ \s -> s {funcBodies = addToUniqMap (funcBodies s) sym body} + where + sym = symNameFromCLabel lbl + +-- | Invoked for each 'RawCmmDecl'. +onCmmDecl :: RawCmmDecl -> WasmCodeGenM w () +onCmmDecl decl + | Just (iof, lbls) <- isInitOrFiniArray decl = onCmmInitFini iof lbls +onCmmDecl (CmmData s (CmmStaticsRaw lbl statics)) = onCmmData lbl s statics +onCmmDecl (CmmProc _ lbl _ g) = onCmmProc lbl g + +-- | Invoked for each 'RawCmmGroup'. +onCmmGroup :: RawCmmGroup -> WasmCodeGenM w () +onCmmGroup cmms = wasmStateM $ \s0 -> + (# (), foldl' (\s cmm -> wasmExecM (onCmmDecl cmm) s) s0 cmms #) diff --git a/GHC/CmmToAsm/Wasm/Types.hs b/GHC/CmmToAsm/Wasm/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Wasm/Types.hs @@ -0,0 +1,522 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHC.CmmToAsm.Wasm.Types + ( WasmType (..), + WasmTypeTag (..), + SomeWasmType (..), + TypeList (..), + someWasmTypesFromTypeList, + WasmFunctionType (..), + SymName (..), + SymVisibility (..), + SymKind (..), + DataSectionKind (..), + DataSectionContent (..), + DataSection (..), + GlobalInfo, + LocalInfo, + FuncBody (..), + Signage (..), + WasmInstr (..), + WasmExpr (..), + SomeWasmExpr (..), + WasmStatements (..), + WasmControl (..), + BrTableInterval (..), + wasmControlCast, + WasmCodeGenState (..), + initialWasmCodeGenState, + WasmCodeGenM (..), + wasmGetsM, + wasmPlatformM, + wasmWordTypeM, + wasmWordCmmTypeM, + wasmStateM, + wasmModifyM, + wasmExecM, + wasmRunM, + WasmAsmConfig (..), + defaultWasmAsmConfig + ) +where + +import Control.Applicative +import Data.ByteString (ByteString) +import Data.Coerce +import Data.Functor +import Data.Kind +import Data.String +import Data.Type.Equality +import Data.Word +import GHC.Cmm +import GHC.Data.FastString +import GHC.Float +import GHC.Platform +import GHC.Prelude +import GHC.Types.Basic +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSM +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Outputable hiding ((<>)) +import Unsafe.Coerce + +-- | WebAssembly type of a WebAssembly value that WebAssembly code +-- could either expect on the evaluation stack or leave on the +-- evaluation stack. +data WasmType = I32 | I64 | F32 | F64 + +-- | Singleton type useful for programming with `WasmType` at the type +-- level. +data WasmTypeTag :: WasmType -> Type where + TagI32 :: WasmTypeTag 'I32 + TagI64 :: WasmTypeTag 'I64 + TagF32 :: WasmTypeTag 'F32 + TagF64 :: WasmTypeTag 'F64 + +deriving instance Show (WasmTypeTag t) + +instance TestEquality WasmTypeTag where + TagI32 `testEquality` TagI32 = Just Refl + TagI64 `testEquality` TagI64 = Just Refl + TagF32 `testEquality` TagF32 = Just Refl + TagF64 `testEquality` TagF64 = Just Refl + _ `testEquality` _ = Nothing + +data SomeWasmType where + SomeWasmType :: WasmTypeTag t -> SomeWasmType + +instance Eq SomeWasmType where + SomeWasmType ty0 == SomeWasmType ty1 + | Just Refl <- ty0 `testEquality` ty1 = True + | otherwise = False + +-- | List of WebAssembly types used to describe the sequence of +-- WebAssembly values that a block of code may expect on the stack or +-- leave on the stack. +data TypeList :: [WasmType] -> Type where + TypeListNil :: TypeList '[] + TypeListCons :: WasmTypeTag t -> TypeList ts -> TypeList (t : ts) + +someWasmTypesFromTypeList :: TypeList ts -> [SomeWasmType] +someWasmTypesFromTypeList TypeListNil = [] +someWasmTypesFromTypeList (ty `TypeListCons` tys) = + SomeWasmType ty : someWasmTypesFromTypeList tys + +-- | The type of a WebAssembly function, loop, block, or conditional. +-- This type says what values the code expects to pop off the stack +-- and what values it promises to push. The WebAssembly standard +-- requires that this type appear explicitly in the code. +data WasmFunctionType pre post = WasmFunctionType {ft_pops :: TypeList pre, ft_pushes :: TypeList post} + +-- | For simplicity, we record other metadata in 'WasmCodeGenState' by +-- need, instead of carrying them along with 'SymName'. +newtype SymName = SymName FastString + deriving (Eq, IsString, Show, Uniquable) via FastString + deriving (Ord) via LexicalFastString + +data SymVisibility + = -- | Not defined in the current compilation unit. + -- + -- @[ undefined binding=global vis=default ]@ + SymUndefined + | -- | Defined, not visible to other compilation units. + -- + -- @[ binding=local vis=default ]@ + SymStatic + | -- | Defined, visible to other compilation units. + -- + -- Adds @.globl@ directives in the output assembly. Also adds + -- @.hidden@ when not generating PIC code, similar to + -- -fvisibility=hidden in clang. + -- + -- @[ binding=global vis=hidden ]@ + SymDefault + +-- | Represents whether a symbol is a data symbol or a function +-- symbol. Unlike linkers for other targets, @wasm-ld@ does panic at +-- link-time if it finds symbol kind inconsistency between the +-- definition site and other use sites. +-- +-- Currently we solely rely on 'isCFunctionLabel' to determine a +-- symbol's kind, but it does take extra effort to make it work. The +-- main source of inconsistency arises from hand-written Cmm sources, +-- where it's possible to refer to external entities like @xxx_info@ +-- and @xxx_closure@ without explicit @import CLOSURE@ declarations. +-- The Cmm parser will implicitly assume those are foreign function +-- labels, and then this will break the WebAssembly backend. #22368 +-- provides more context on this issue. +-- +-- tl;dr for any GHC contributor that accidentally triggers @wasm-ld@ +-- errors when hacking Cmm: whatever data symbols are used in new +-- code, just add the corresponding @import CLOSURE@ declarations at +-- the top of that Cmm file. +data SymKind = SymData | SymFunc + deriving (Eq) + +-- | WebAssembly doesn't really have proper read-only memory regions +-- yet. Neverthless we add the .rodata logic here, wasm-ld will +-- aggregate all .rodata sections into a single one, which adds +-- possibility for runtime checks later, either via a customized +-- runtime, or via code instrumentation. See +-- +data DataSectionKind = SectionData | SectionROData + +-- | Neither Cmm or Wasm type system takes integer signedness into +-- account, therefore we always round up a 'CmmLit' to the right width +-- and handle it as an untyped integer. +data DataSectionContent + = DataI8 Word8 + | DataI16 Word16 + | DataI32 Word32 + | DataI64 Word64 + | DataF32 Float + | DataF64 Double + | DataSym SymName Int + | DataSkip Int + | DataASCII ByteString + | DataIncBin FilePath Int + +data DataSection = DataSection + { dataSectionKind :: DataSectionKind, + dataSectionAlignment :: + Alignment, + dataSectionContents :: [DataSectionContent] + } + +-- | We need to remember the symbols. Determinism is achieved by +-- sorting symbols before writing the assembly. +type SymMap = UniqMap SymName + +-- | No need to remember the symbols. +type SymSet = UniqueSet + +type GlobalInfo = (SymName, SomeWasmType) + +type LocalInfo = (Int, SomeWasmType) + +data FuncBody w = FuncBody + { funcLocals :: [SomeWasmType], + -- | Most are Cmm functions, but may also contain synthesized + -- function of other types, sigh. + funcBody :: WasmControl (WasmStatements w) (WasmExpr w w) '[] '[w] + } + +data Signage = Signed | Unsigned + +-- | The @w@ type variable in the Wasm IR stands for "platform word +-- type", so 'TagI32' on wasm32, and 'TagI64' on wasm64. This way, we +-- can make the codegen logic work on both wasm32/wasm64 in a +-- type-safe manner. +data WasmInstr :: WasmType -> [WasmType] -> [WasmType] -> Type where + WasmComment :: String -> WasmInstr w pre pre + WasmNop :: WasmInstr w pre pre + WasmDrop :: WasmInstr w (t : pre) pre + WasmUnreachable :: WasmInstr w pre post + WasmConst :: WasmTypeTag t -> Integer -> WasmInstr w pre (t : pre) + WasmSymConst :: SymName -> WasmInstr w pre (w : pre) + WasmLoad :: + WasmTypeTag t -> + Maybe Int -> + Signage -> + Int -> + AlignmentSpec -> + WasmInstr w (w : pre) (t : pre) + WasmStore :: + WasmTypeTag t -> + Maybe Int -> + Int -> + AlignmentSpec -> + WasmInstr + w + (t : w : pre) + pre + WasmGlobalGet :: WasmTypeTag t -> SymName -> WasmInstr w pre (t : pre) + WasmGlobalSet :: WasmTypeTag t -> SymName -> WasmInstr w (t : pre) pre + WasmLocalGet :: WasmTypeTag t -> Int -> WasmInstr w pre (t : pre) + WasmLocalSet :: WasmTypeTag t -> Int -> WasmInstr w (t : pre) pre + WasmLocalTee :: WasmTypeTag t -> Int -> WasmInstr w (t : pre) (t : pre) + WasmCCall :: SymName -> WasmInstr w pre post + WasmCCallIndirect :: + TypeList arg_tys -> + TypeList ret_tys -> + WasmInstr + w + (w : pre) + post + WasmConcat :: + WasmInstr w pre mid -> + WasmInstr w mid post -> + WasmInstr w pre post + WasmReinterpret :: + WasmTypeTag t0 -> + WasmTypeTag t1 -> + WasmInstr + w + (t0 : pre) + (t1 : pre) + WasmTruncSat :: + Signage -> + WasmTypeTag t0 -> + WasmTypeTag t1 -> + WasmInstr + w + (t0 : pre) + (t1 : pre) + WasmConvert :: + Signage -> + WasmTypeTag t0 -> + WasmTypeTag t1 -> + WasmInstr + w + (t0 : pre) + (t1 : pre) + WasmAdd :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmSub :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmMul :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmDiv :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmRem :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmAnd :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmOr :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmXor :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmEq :: WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmNe :: WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmLt :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmGt :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmLe :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmGe :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmShl :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmShr :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmI32Extend8S :: WasmInstr w ('I32 : pre) ('I32 : pre) + WasmI32Extend16S :: WasmInstr w ('I32 : pre) ('I32 : pre) + WasmI64Extend8S :: WasmInstr w ('I64 : pre) ('I64 : pre) + WasmI64Extend16S :: WasmInstr w ('I64 : pre) ('I64 : pre) + WasmI64Extend32S :: WasmInstr w ('I64 : pre) ('I64 : pre) + WasmI64ExtendI32 :: Signage -> WasmInstr w ('I32 : pre) ('I64 : pre) + WasmI32WrapI64 :: WasmInstr w ('I64 : pre) ('I32 : pre) + WasmF32DemoteF64 :: WasmInstr w ('F64 : pre) ('F32 : pre) + WasmF64PromoteF32 :: WasmInstr w ('F32 : pre) ('F64 : pre) + WasmAbs :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre) + WasmSqrt :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre) + WasmNeg :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre) + WasmMin :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmMax :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmCond :: WasmInstr w pre pre -> WasmInstr w (w : pre) pre + +newtype WasmExpr w t = WasmExpr (forall pre. WasmInstr w pre (t : pre)) + +data SomeWasmExpr w where + SomeWasmExpr :: WasmTypeTag t -> WasmExpr w t -> SomeWasmExpr w + +newtype WasmStatements w = WasmStatements (forall pre. WasmInstr w pre pre) + +-- | Representation of WebAssembly control flow. +-- Normally written as +-- @ +-- WasmControl s e pre post +-- @ +-- Type parameter `s` is the type of (unspecified) statements. +-- It might be instantiated with an open Cmm block or with a sequence +-- of Wasm instructions. +-- Parameter `e` is the type of expressions. +-- Parameter `pre` represents the values that are expected on the +-- WebAssembly stack when the code runs, and `post` represents +-- the state of the stack on completion. +data WasmControl :: Type -> Type -> [WasmType] -> [WasmType] -> Type where + WasmPush :: WasmTypeTag t -> e -> WasmControl s e stack (t : stack) + WasmBlock :: + WasmFunctionType pre post -> + WasmControl s e pre post -> + WasmControl s e pre post + WasmLoop :: + WasmFunctionType pre post -> + WasmControl s e pre post -> + WasmControl s e pre post + WasmIfTop :: + WasmFunctionType pre post -> + WasmControl s e pre post -> + WasmControl s e pre post -> + WasmControl s e ('I32 : pre) post + WasmBr :: Int -> WasmControl s e dropped destination -- not typechecked + WasmFallthrough :: WasmControl s e dropped destination + -- generates no code, but has the same type as a branch + WasmBrTable :: + e -> + BrTableInterval -> -- for testing + [Int] -> -- targets + Int -> -- default target + WasmControl s e dropped destination + -- invariant: the table interval is contained + -- within [0 .. pred (length targets)] + + -- Note [WasmTailCall] + -- ~~~~~~~~~~~~~~~~~~~ + -- This represents the exit point of each CmmGraph: tail calling the + -- destination in CmmCall. The STG stack may grow before the call, + -- but it's always a tail call in the sense that the C call stack is + -- guaranteed not to grow. + -- + -- In the wasm backend, WasmTailCall is lowered to different + -- assembly code given whether the wasm tail-call extension is + -- enabled: + -- + -- When tail-call is not enabled (which is the default as of today), + -- a WasmTailCall is lowered to code that pushes the callee function + -- pointer onto the value stack and returns immediately. The actual + -- call is done by the trampoline in StgRun. + -- + -- When tail-call is indeed enabled via passing -mtail-call in + -- CONF_CC_OPTS_STAGE2 at configure time, a WasmTailCall is lowered + -- to return_call/return_call_indirect, thus tail calling into its + -- callee without returning to StgRun. + WasmTailCall :: + e -> + WasmControl s e t1star t2star -- as per type system + WasmActions :: + s -> + WasmControl s e stack stack -- basic block: one entry, one exit + WasmSeq :: + WasmControl s e pre mid -> + WasmControl s e mid post -> + WasmControl s e pre post + +data BrTableInterval = BrTableInterval {bti_lo :: Integer, bti_count :: Integer} + deriving (Show) + +instance Outputable BrTableInterval where + ppr range = + brackets $ + hcat + [integer (bti_lo range), text "..", integer hi] + where + hi = bti_lo range + bti_count range - 1 + +wasmControlCast :: WasmControl s e pre post -> WasmControl s e pre' post' +wasmControlCast = unsafeCoerce + +data WasmCodeGenState w = WasmCodeGenState + { -- | Target platform + wasmPlatform :: Platform, + -- | Defined symbols with 'SymDefault' visibility. + defaultSyms :: SymSet, + -- | Function types, defined or not. There may exist a function + -- whose type is unknown (e.g. as a function pointer), in that + -- case we fall back to () -> (), it's imperfect but works with + -- wasm-ld. + funcTypes :: SymMap ([SomeWasmType], [SomeWasmType]), + -- | Defined function bodies. + funcBodies :: SymMap (FuncBody w), + -- | Defined data sections. + dataSections :: SymMap DataSection, + -- | ctors in the current compilation unit. + ctors :: [SymName], + localRegs :: + UniqFM LocalReg LocalInfo, + localRegsCount :: + Int, + wasmDUniqSupply :: DUniqSupply + } + +initialWasmCodeGenState :: Platform -> DUniqSupply -> WasmCodeGenState w +initialWasmCodeGenState platform us = + WasmCodeGenState + { wasmPlatform = + platform, + defaultSyms = emptyUniqueSet, + funcTypes = emptyUniqMap, + funcBodies = + emptyUniqMap, + dataSections = emptyUniqMap, + ctors = + [], + localRegs = emptyUFM, + localRegsCount = 0, + wasmDUniqSupply = us + } + +newtype WasmCodeGenM w a = WasmCodeGenM (State (WasmCodeGenState w) a) + deriving newtype (Functor, Applicative, Monad) + +instance MonadUniqDSM (WasmCodeGenM w) where + liftUniqDSM (UDSM m) = wasmStateM $ \st -> + let DUniqResult a us' = m (wasmDUniqSupply st) + in (# a, st{wasmDUniqSupply=us'} #) + +wasmGetsM :: (WasmCodeGenState w -> a) -> WasmCodeGenM w a +wasmGetsM = coerce . gets + +wasmPlatformM :: WasmCodeGenM w Platform +wasmPlatformM = wasmGetsM wasmPlatform + +wasmWordTypeM :: WasmCodeGenM w (WasmTypeTag w) +wasmWordTypeM = wasmGetsM $ \s -> + if target32Bit $ wasmPlatform s + then unsafeCoerce TagI32 + else unsafeCoerce TagI64 + +wasmWordCmmTypeM :: WasmCodeGenM w CmmType +wasmWordCmmTypeM = wasmGetsM (bWord . wasmPlatform) + +wasmStateM :: + (WasmCodeGenState w -> (# a, WasmCodeGenState w #)) -> + WasmCodeGenM w a +wasmStateM = coerce . State + +wasmModifyM :: (WasmCodeGenState w -> WasmCodeGenState w) -> WasmCodeGenM w () +wasmModifyM = coerce . modify + +wasmExecM :: WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w +wasmExecM (WasmCodeGenM s) = execState s + +wasmRunM :: WasmCodeGenM w a -> WasmCodeGenState w -> (a, WasmCodeGenState w) +wasmRunM (WasmCodeGenM s) = runState s + +instance MonadGetUnique (WasmCodeGenM w) where + getUniqueM = wasmStateM $ + \s@WasmCodeGenState {..} -> case takeUniqueFromDSupply wasmDUniqSupply of + (u, us) -> (# u, s {wasmDUniqSupply = us} #) + +data WasmAsmConfig = WasmAsmConfig + { + pic, tailcall :: Bool, + -- | Data/function symbols with 'SymStatic' visibility (defined + -- but not visible to other compilation units). When doing PIC + -- codegen, private symbols must be emitted as @MBREL@/@TBREL@ + -- relocations in the code section. The public symbols, defined or + -- elsewhere, are all emitted as @GOT@ relocations instead. + mbrelSyms, tbrelSyms :: ~SymSet + } + +-- | The default 'WasmAsmConfig' must be extracted from the final +-- 'WasmCodeGenState'. +defaultWasmAsmConfig :: WasmCodeGenState w -> WasmAsmConfig +defaultWasmAsmConfig WasmCodeGenState {..} = + WasmAsmConfig + { pic = False, + tailcall = False, + mbrelSyms = mk_rel_syms dataSections, + tbrelSyms = mk_rel_syms funcBodies + } + where + mk_rel_syms :: SymMap a -> SymSet + mk_rel_syms = + nonDetFoldUniqMap + ( \(sym, _) acc -> + if getUnique sym `memberUniqueSet` defaultSyms + then acc + else insertUniqueSet (getUnique sym) acc + ) + emptyUniqueSet diff --git a/GHC/CmmToAsm/Wasm/Utils.hs b/GHC/CmmToAsm/Wasm/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Wasm/Utils.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +module GHC.CmmToAsm.Wasm.Utils + ( widthMax, + detEltsUFM, + detEltsUniqMap, + builderCommas, + ) +where + +import Data.ByteString.Builder +import Data.List (intersperse, sortOn) +import GHC.Cmm +import GHC.Prelude +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map + +widthMax :: Width -> Integer +widthMax w = (1 `shiftL` widthInBits w) - 1 + +detEltsUFM :: Ord k => UniqFM k0 (k, a) -> [(k, a)] +detEltsUFM = sortOn fst . nonDetEltsUFM + +detEltsUniqMap :: Ord k => UniqMap k a -> [(k, a)] +detEltsUniqMap = sortOn fst . nonDetUniqMapToList + +builderCommas :: (a -> Builder) -> [a] -> Builder +builderCommas f xs = mconcat (intersperse ", " (map f xs)) diff --git a/GHC/CmmToAsm/X86.hs b/GHC/CmmToAsm/X86.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Native code generator for x86 and x86-64 architectures +module GHC.CmmToAsm.X86 + ( ncgX86_64 + , ncgX86 + ) +where + +import GHC.Prelude + +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types +import GHC.Types.Basic (Alignment) + +import qualified GHC.CmmToAsm.X86.Instr as X86 +import qualified GHC.CmmToAsm.X86.Ppr as X86 +import qualified GHC.CmmToAsm.X86.CodeGen as X86 +import qualified GHC.CmmToAsm.X86.Regs as X86 + +ncgX86 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest +ncgX86 = ncgX86_64 + + +ncgX86_64 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest +ncgX86_64 config = NcgImpl + { ncgConfig = config + , cmmTopCodeGen = X86.cmmTopCodeGen + , generateJumpTableForInstr = X86.generateJumpTableForInstr config + , getJumpDestBlockId = X86.getJumpDestBlockId + , canShortcut = X86.canShortcut + , shortcutStatics = X86.shortcutStatics + , shortcutJump = X86.shortcutJump + , pprNatCmmDeclS = X86.pprNatCmmDecl config + , pprNatCmmDeclH = X86.pprNatCmmDecl config + , maxSpillSlots = X86.maxSpillSlots config + , allocatableRegs = X86.allocatableRegs platform + , ncgAllocMoreStack = X86.allocMoreStack platform + , ncgMakeFarBranches = \_p _i bs -> pure bs + , extractUnwindPoints = X86.extractUnwindPoints + , invertCondBranches = X86.invertCondBranches + } + where + platform = ncgPlatform config + +-- | Instruction instance for x86 instruction set. +instance Instruction X86.Instr where + regUsageOfInstr = X86.regUsageOfInstr + patchRegsOfInstr = X86.patchRegsOfInstr + isJumpishInstr = X86.isJumpishInstr + jumpDestsOfInstr = X86.jumpDestsOfInstr + canFallthroughTo = X86.canFallthroughTo + patchJumpInstr = X86.patchJumpInstr + mkSpillInstr = X86.mkSpillInstr + mkLoadInstr = X86.mkLoadInstr + takeDeltaInstr = X86.takeDeltaInstr + isMetaInstr = X86.isMetaInstr + mkRegRegMoveInstr = X86.mkRegRegMoveInstr + takeRegRegMoveInstr = X86.takeRegRegMoveInstr + mkJumpInstr = X86.mkJumpInstr + mkStackAllocInstr = X86.mkStackAllocInstr + mkStackDeallocInstr = X86.mkStackDeallocInstr + pprInstr = X86.pprInstr + mkComment = pure . X86.COMMENT diff --git a/GHC/CmmToAsm/X86/CodeGen.hs b/GHC/CmmToAsm/X86/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/CodeGen.hs @@ -0,0 +1,6718 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NondecreasingIndentation #-} + +----------------------------------------------------------------------------- +-- +-- Generating machine code (instruction selection) +-- +-- (c) The University of Glasgow 1996-2004 +-- +----------------------------------------------------------------------------- + +-- This is a big module, but, if you pay attention to +-- (a) the sectioning, and (b) the type signatures, the +-- structure should not be too overwhelming. + +module GHC.CmmToAsm.X86.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + extractUnwindPoints, + invertCondBranches, + InstrBlock +) + +where + +-- NCG stuff: +import GHC.Prelude + +import GHC.CmmToAsm.X86.Instr +import GHC.CmmToAsm.X86.Cond +import GHC.CmmToAsm.X86.Regs +import GHC.CmmToAsm.X86.Ppr +import GHC.CmmToAsm.X86.RegInfo + +import GHC.Platform.Regs +import GHC.CmmToAsm.CPrim +import GHC.CmmToAsm.Types +import GHC.Cmm.DebugBlock + ( DebugBlock(..), UnwindPoint(..), UnwindTable + , UnwindExpr(UwReg), toUnwindExpr + ) +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.Monad + ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat + , getDeltaNat, getBlockIdNat, getPicBaseNat + , Reg64(..), RegCode64(..), getNewReg64, localReg64 + , getPicBaseMaybeNat, getDebugBlock, getFileId + , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform + , getCfgWeights + ) +import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config +import GHC.Platform.Reg +import GHC.Platform + +-- Our intermediate code: +import GHC.Types.Basic +import GHC.Cmm.BlockId +import GHC.Unit.Types ( ghcInternalUnitId ) +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.CLabel +import GHC.Types.Tickish ( GenTickish(..) ) +import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) + +-- The rest: +import GHC.Data.Maybe ( expectJust ) +import GHC.Types.ForeignCall ( CCallConv(..) ) +import GHC.Data.OrdList +import GHC.Utils.Outputable +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Monad ( foldMapM ) +import GHC.Utils.Panic +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Types.Unique.DSM ( getUniqueM ) + +import qualified Data.Semigroup as S + +import Control.Monad +import Control.Monad.Trans.State.Strict + ( StateT, evalStateT, get, put ) +import Control.Monad.Trans.Class (lift) +import Data.Foldable (fold) +import Data.Int +import Data.List (partition, (\\)) +import Data.Maybe +import Data.Word + +import qualified Data.Map as Map + +is32BitPlatform :: NatM Bool +is32BitPlatform = do + platform <- getPlatform + return $ target32Bit platform + +ssse3Enabled :: NatM Bool +ssse3Enabled = do + config <- getConfig + return (ncgSseVersion config >= Just SSSE3) + +sse4_1Enabled :: NatM Bool +sse4_1Enabled = do + config <- getConfig + return (ncgSseVersion config >= Just SSE4) + +sse4_2Enabled :: NatM Bool +sse4_2Enabled = do + config <- getConfig + return (ncgSseVersion config >= Just SSE42) + +avxEnabled :: NatM Bool +avxEnabled = do + config <- getConfig + return (ncgAvxEnabled config) + +avx2Enabled :: NatM Bool +avx2Enabled = do + config <- getConfig + return (ncgAvx2Enabled config) + +cmmTopCodeGen + :: RawCmmDecl + -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr] + +cmmTopCodeGen (CmmProc info lab live graph) = do + let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + picBaseMb <- getPicBaseMaybeNat + platform <- getPlatform + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + os = platformOS platform + + case picBaseMb of + Just picBase -> initializePicBase_x86 os picBase tops + Nothing -> return tops + +cmmTopCodeGen (CmmData sec dat) = + return [CmmData sec (mkAlignment 1, dat)] -- no translation, we just use CmmStatic + +{- Note [Verifying basic blocks] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We want to guarantee a few things about the results + of instruction selection. + + Namely that each basic blocks consists of: + * A (potentially empty) sequence of straight line instructions + followed by + * A (potentially empty) sequence of jump like instructions. + + We can verify this by going through the instructions and + making sure that any non-jumpish instruction can't appear + after a jumpish instruction. + + There are gotchas however: + * CALLs are strictly speaking control flow but here we care + not about them. Hence we treat them as regular instructions. + + It's safe for them to appear inside a basic block + as (ignoring side effects inside the call) they will result in + straight line code. + + * NEWBLOCK marks the start of a new basic block so can + be followed by any instructions. +-} + +-- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally. +verifyBasicBlock :: Platform -> [Instr] -> () +verifyBasicBlock platform instrs + | debugIsOn = go False instrs + | otherwise = () + where + go _ [] = () + go atEnd (i:instr) + = case i of + -- Start a new basic block + NEWBLOCK {} -> go False instr + -- Calls are not viable block terminators + CALL {} | atEnd -> faultyBlockWith i + | not atEnd -> go atEnd instr + -- All instructions ok, check if we reached the end and continue. + _ | not atEnd -> go (isJumpishInstr i) instr + -- Only jumps allowed at the end of basic blocks. + | otherwise -> if isJumpishInstr i + then go True instr + else faultyBlockWith i + faultyBlockWith i + = pprPanic "Non control flow instructions after end of basic block." + (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs)) + +basicBlockCodeGen + :: CmmBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmDecl (Alignment, RawCmmStatics) Instr]) + +basicBlockCodeGen block = do + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + -- Generate location directive + dbg <- getDebugBlock (entryLabel block) + loc_instrs <- case dblSourceTick =<< dbg of + Just (SourceNote span (LexicalFastString name)) + -> do fileId <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col = srcSpanStartCol span + return $ unitOL $ LOCATION fileId line col (unpackFS name) + _ -> return nilOL + (mid_instrs,mid_bid) <- stmtsToInstrs id stmts + (!tail_instrs,_) <- stmtToInstrs mid_bid tail + let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs + platform <- getPlatform + return $! verifyBasicBlock platform (fromOL instrs) + instrs' <- fold <$> traverse addSpUnwindings instrs + -- code generation may introduce new basic block boundaries, which + -- are indicated by the NEWBLOCK instruction. We must split up the + -- instruction stream into basic blocks again. Also, we extract + -- LDATAs here too. + let + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs' + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + return (BasicBlock id top : other_blocks, statics) + +-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes +-- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock" +-- for details. +addSpUnwindings :: Instr -> NatM (OrdList Instr) +addSpUnwindings instr@(DELTA d) = do + config <- getConfig + let platform = ncgPlatform config + if ncgDwarfUnwindings config + then do lbl <- mkAsmTempLabel <$> getUniqueM + let unwind = Map.singleton MachSp (Just $ UwReg (GlobalRegUse MachSp (bWord platform)) $ negate d) + return $ toOL [ instr, UNWIND lbl unwind ] + else return (unitOL instr) +addSpUnwindings instr = return $ unitOL instr + +{- Note [Keeping track of the current block] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When generating instructions for Cmm we sometimes require +the current block for things like retry loops. + +We also sometimes change the current block, if a MachOP +results in branching control flow. + +Issues arise if we have two statements in the same block, +which both depend on the current block id *and* change the +basic block after them. This happens for atomic primops +in the X86 backend where we want to update the CFG data structure +when introducing new basic blocks. + +For example in #17334 we got this Cmm code: + + c3Bf: // global + (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18); + (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0); + _s3sT::I64 = _s3sV::I64; + goto c3B1; + +This resulted in two new basic blocks being inserted: + + c3Bf: + movl $18,%vI_n3Bo + movq 88(%vI_s3sQ),%rax + jmp _n3Bp + n3Bp: + ... + cmpxchgq %vI_n3Bq,88(%vI_s3sQ) + jne _n3Bp + ... + jmp _n3Bs + n3Bs: + ... + cmpxchgq %vI_n3Bt,88(%vI_s3sQ) + jne _n3Bs + ... + jmp _c3B1 + ... + +Based on the Cmm we called stmtToInstrs we translated both atomic operations under +the assumption they would be placed into their Cmm basic block `c3Bf`. +However for the retry loop we introduce new labels, so this is not the case +for the second statement. +This resulted in a desync between the explicit control flow graph +we construct as a separate data type and the actual control flow graph in the code. + +Instead we now return the new basic block if a statement causes a change +in the current block and use the block for all following statements. + +For this reason genForeignCall is also split into two parts. One for calls which +*won't* change the basic blocks in which successive instructions will be +placed (since they only evaluate CmmExpr, which can only contain MachOps, which +cannot introduce basic blocks in their lowerings). A different one for calls +which *are* known to change the basic block. + +-} + +-- See Note [Keeping track of the current block] for why +-- we pass the BlockId. +stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in. + -> [CmmNode O O] -- ^ Cmm Statement + -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction +stmtsToInstrs bid stmts = + go bid stmts nilOL + where + go bid [] instrs = return (instrs,bid) + go bid (s:stmts) instrs = do + (instrs',bid') <- stmtToInstrs bid s + -- If the statement introduced a new block, we use that one + let !newBid = fromMaybe bid bid' + go newBid stmts (instrs `appOL` instrs') + +-- | `bid` refers to the current block and is used to update the CFG +-- if new blocks are inserted in the control flow. +-- See Note [Keeping track of the current block] for more details. +stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in. + -> CmmNode e x + -> NatM (InstrBlock, Maybe BlockId) + -- ^ Instructions, and bid of new block if successive + -- statements are placed in a different basic block. +stmtToInstrs bid stmt = do + is32Bit <- is32BitPlatform + platform <- getPlatform + case stmt of + CmmUnsafeForeignCall target result_regs args + -> genForeignCall target result_regs args bid + + _ -> (,Nothing) <$> case stmt of + CmmComment s -> return (unitOL (COMMENT s)) + CmmTick {} -> return nilOL + + CmmUnwind regs -> do + let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable + to_unwind_entry (reg, expr) = Map.singleton reg (fmap (toUnwindExpr platform) expr) + case foldMap to_unwind_entry regs of + tbl | Map.null tbl -> return nilOL + | otherwise -> do + lbl <- mkAsmTempLabel <$> getUniqueM + return $ unitOL $ UNWIND lbl tbl + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode reg src + | is32Bit && isWord64 ty -> assignReg_I64Code reg src + | isVecType ty -> assignReg_VecCode reg src + | otherwise -> assignReg_IntCode reg src + where ty = cmmRegType reg + + CmmStore addr src _alignment + | isFloatType ty -> assignMem_FltCode format addr src + | is32Bit && isWord64 ty -> assignMem_I64Code addr src + | isVecType ty -> assignMem_VecCode format addr src + | otherwise -> assignMem_IntCode format addr src + where ty = cmmExprType platform src + format = cmmTypeFormat ty + + CmmBranch id -> return $ genBranch id + + --We try to arrange blocks such that the likely branch is the fallthrough + --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. + CmmCondBranch arg true false _ -> genCondBranch bid true false arg + CmmSwitch arg ids -> genSwitch arg ids + CmmCall { cml_target = arg + , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs) + _ -> + panic "stmtToInstrs: statement should have been cps'd away" + + +jumpRegs :: Platform -> [GlobalRegUse] -> [RegWithFormat] +jumpRegs platform gregs = + [ RegWithFormat (RegReal r) (cmmTypeFormat ty) + | GlobalRegUse gr ty <- gregs + , Just r <- [globalRegMaybe platform gr] ] + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + + +-- | Condition codes passed up the tree. +-- +data CondCode + = CondCode Bool Cond InstrBlock + + +-- | Register's passed up the tree. If the stix code forces the register +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. +-- +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + + +swizzleRegisterRep :: Register -> Format -> Register +swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code +swizzleRegisterRep (Any _ codefn) format = Any format codefn + +getLocalRegReg :: LocalReg -> Reg +getLocalRegReg (LocalReg u ty) + = -- by assuming SSE2, Int, Word, Float, Double and vectors all can be register allocated + RegVirtual (mkVirtualReg u (cmmTypeFormat ty)) + +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal lreg) = getLocalRegReg lreg + +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform $ globalRegUse_reg mid of + Just reg -> RegReal $ reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence ... + +-- | Memory addressing modes passed up the tree. +data Amode + = Amode AddrMode InstrBlock + +{- +Now, given a tree (the argument to a CmmLoad) that references memory, +produce a suitable addressing mode. + +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... +-} + +{- +Note [%rip-relative addressing on x86-64] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On x86-64 GHC produces code for use in the "small" or, when `-fPIC` is set, +"small PIC" code models defined by the x86-64 System V ABI (section 3.5.1 of +specification version 0.99). + +In general the small code model would allow us to assume that code is located +between 0 and 2^31 - 1. However, this is not true on Windows which, due to +high-entropy ASLR, may place the executable image anywhere in 64-bit address +space. This is problematic since immediate operands in x86-64 are generally +32-bit sign-extended values (with the exception of the 64-bit MOVABS encoding). +Consequently, to avoid overflowing we use %rip-relative addressing universally. +Since %rip-relative addressing comes essentially for free and makes linking far +easier, we use it even on non-Windows platforms. + +See also: the documentation for GCC's `-mcmodel=small` flag. +-} + + +-- | Check whether an integer will fit in 32 bits. +-- A CmmInt is intended to be truncated to the appropriate +-- number of bits, so here we truncate it to Int64. This is +-- important because e.g. -1 as a CmmInt might be either +-- -1 or 18446744073709551615. +-- +is32BitInteger :: Integer -> Bool +is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 + where i64 = fromIntegral i :: Int64 + + +-- | Convert a BlockId to some CmmStatic data +jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic +jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = blockLbl blockid + + +-- ----------------------------------------------------------------------------- +-- General things for putting together code sequences + +-- Expand CmmRegOff. ToDo: should we do it this way around, or convert +-- CmmExprs into CmmRegOff? +mangleIndexTree :: CmmReg -> Int -> CmmExpr +mangleIndexTree reg off + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType reg) + +-- | The dual to getAnyReg: compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) + +assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock +assignMem_I64Code addrTree valueTree = do + Amode addr addr_code <- getAmode addrTree + RegCode64 vcode rhi rlo <- iselExpr64 valueTree + let + -- Little-endian store + mov_lo = MOV II32 (OpReg rlo) (OpAddr addr) + mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4))) + return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) + + +assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock +assignReg_I64Code (CmmLocal dst) valueTree = do + RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree + let + Reg64 r_dst_hi r_dst_lo = localReg64 dst + mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo) + mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi) + return ( + vcode `snocOL` mov_lo `snocOL` mov_hi + ) + +assignReg_I64Code _ _ + = panic "assignReg_I64Code(i386): invalid lvalue" + +iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock) +iselExpr64 (CmmLit (CmmInt i _)) = do + Reg64 rhi rlo <- getNewReg64 + let + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) + code = toOL [ + MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) + ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do + Amode addr addr_code <- getAmode addrTree + Reg64 rhi rlo <- getNewReg64 + let + mov_lo = MOV II32 (OpAddr addr) (OpReg rlo) + mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi) + return ( + RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rhi rlo + ) + +iselExpr64 (CmmReg (CmmLocal local_reg)) = do + let Reg64 hi lo = localReg64 local_reg + return (RegCode64 nilOL hi lo) + +iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + Reg64 rhi rlo <- getNewReg64 + let + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) + code = code1 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + RegCode64 code2 r2hi r2lo <- iselExpr64 e2 + Reg64 rhi rlo <- getNewReg64 + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpReg r2hi) (OpReg rhi) ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + RegCode64 code2 r2hi r2lo <- iselExpr64 e2 + Reg64 rhi rlo <- getNewReg64 + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + SUB II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + SBB II32 (OpReg r2hi) (OpReg rhi) ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do + code <- getAnyReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code r_dst_lo `snocOL` + XOR II32 (OpReg r_dst_hi) (OpReg r_dst_hi)) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_UU_Conv W16 W64) [expr]) = do + (rsrc, code) <- getByteReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code `appOL` toOL [ + MOVZxL II16 (OpReg rsrc) (OpReg r_dst_lo), + XOR II32 (OpReg r_dst_hi) (OpReg r_dst_hi) + ]) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_UU_Conv W8 W64) [expr]) = do + (rsrc, code) <- getByteReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code `appOL` toOL [ + MOVZxL II8 (OpReg rsrc) (OpReg r_dst_lo), + XOR II32 (OpReg r_dst_hi) (OpReg r_dst_hi) + ]) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do + code <- getAnyReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code r_dst_lo `snocOL` + MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL` + CLTD II32 `snocOL` + MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL` + MOV II32 (OpReg edx) (OpReg r_dst_hi)) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_SS_Conv W16 W64) [expr]) = do + (r, code) <- getByteReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code `appOL` toOL [ + MOVSxL II16 (OpReg r) (OpReg eax), + CLTD II32, + MOV II32 (OpReg eax) (OpReg r_dst_lo), + MOV II32 (OpReg edx) (OpReg r_dst_hi)]) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_SS_Conv W8 W64) [expr]) = do + (r, code) <- getByteReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code `appOL` toOL [ + MOVSxL II8 (OpReg r) (OpReg eax), + CLTD II32, + MOV II32 (OpReg eax) (OpReg r_dst_lo), + MOV II32 (OpReg edx) (OpReg r_dst_hi)]) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_S_Neg _) [expr]) = do + RegCode64 code rhi rlo <- iselExpr64 expr + Reg64 rohi rolo <- getNewReg64 + let + ocode = code `appOL` + toOL [ MOV II32 (OpReg rlo) (OpReg rolo), + XOR II32 (OpReg rohi) (OpReg rohi), + NEGI II32 (OpReg rolo), + SBB II32 (OpReg rhi) (OpReg rohi) ] + return (RegCode64 ocode rohi rolo) + +-- To multiply two 64-bit numbers we use the following decomposition (in C notation): +-- +-- ((r1hi << 32) + r1lo) * ((r2hi << 32) + r2lo) +-- = ((r2lo * r1hi) << 32) +-- + ((r1lo * r2hi) << 32) +-- + r1lo * r2lo +-- +-- Note that @(r1hi * r2hi) << 64@ can be dropped because it overflows completely. + +iselExpr64 (CmmMachOp (MO_Mul _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + RegCode64 code2 r2hi r2lo <- iselExpr64 e2 + Reg64 rhi rlo <- getNewReg64 + tmp <- getNewRegNat II32 + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg eax), + MOV II32 (OpReg r2lo) (OpReg tmp), + MOV II32 (OpReg r1hi) (OpReg rhi), + IMUL II32 (OpReg tmp) (OpReg rhi), + MOV II32 (OpReg r2hi) (OpReg rlo), + IMUL II32 (OpReg eax) (OpReg rlo), + ADD II32 (OpReg rlo) (OpReg rhi), + MUL2 II32 (OpReg tmp), + ADD II32 (OpReg edx) (OpReg rhi), + MOV II32 (OpReg eax) (OpReg rlo) + ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_S_MulMayOflo W64) _) = do + -- Performance sensitive users won't use 32 bit so let's keep it simple: + -- We always return a (usually false) positive. + Reg64 rhi rlo <- getNewReg64 + let code = toOL [ + MOV II32 (OpImm (ImmInt 1)) (OpReg rhi), + MOV II32 (OpImm (ImmInt 1)) (OpReg rlo) + ] + return (RegCode64 code rhi rlo) + + +-- To shift a 64-bit number to the left we use the SHLD and SHL instructions. +-- We use SHLD to shift the bits in @rhi@ to the left while copying +-- high bits from @rlo@ to fill the new space in the low bits of @rhi@. +-- That leaves @rlo@ unchanged, so we use SHL to shift the bits of @rlo@ left. +-- However, both these instructions only use the lowest 5 bits from %cl to do +-- their shifting. So if the sixth bit (0x32) is set then we additionally move +-- the contents of @rlo@ to @rhi@ and clear @rlo@. + +iselExpr64 (CmmMachOp (MO_Shl _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + code2 <- getAnyReg e2 + Reg64 rhi rlo <- getNewReg64 + lbl1 <- newBlockId + lbl2 <- newBlockId + let + code = code1 `appOL` + code2 ecx `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + SHLD II32 (OpReg ecx) (OpReg rlo) (OpReg rhi), + SHL II32 (OpReg ecx) (OpReg rlo), + TEST II32 (OpImm (ImmInt 32)) (OpReg ecx), + JXX EQQ lbl2, + JXX ALWAYS lbl1, + NEWBLOCK lbl1, + MOV II32 (OpReg rlo) (OpReg rhi), + XOR II32 (OpReg rlo) (OpReg rlo), + JXX ALWAYS lbl2, + NEWBLOCK lbl2 + ] + return (RegCode64 code rhi rlo) + +-- Similar to above, however now we're shifting to the right +-- and we're doing a signed shift which means that @rhi@ needs +-- to be set to either 0 if @rhi@ is positive or 0xffffffff otherwise, +-- and if the sixth bit of %cl is set (so the shift amount is more than 32). +-- To accomplish that we shift @rhi@ by 31. + +iselExpr64 (CmmMachOp (MO_S_Shr _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + (r2, code2) <- getSomeReg e2 + Reg64 rhi rlo <- getNewReg64 + lbl1 <- newBlockId + lbl2 <- newBlockId + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + MOV II32 (OpReg r2) (OpReg ecx), + SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo), + SAR II32 (OpReg ecx) (OpReg rhi), + TEST II32 (OpImm (ImmInt 32)) (OpReg ecx), + JXX EQQ lbl2, + JXX ALWAYS lbl1, + NEWBLOCK lbl1, + MOV II32 (OpReg rhi) (OpReg rlo), + SAR II32 (OpImm (ImmInt 31)) (OpReg rhi), + JXX ALWAYS lbl2, + NEWBLOCK lbl2 + ] + return (RegCode64 code rhi rlo) + +-- Similar to the above. + +iselExpr64 (CmmMachOp (MO_U_Shr _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + (r2, code2) <- getSomeReg e2 + Reg64 rhi rlo <- getNewReg64 + lbl1 <- newBlockId + lbl2 <- newBlockId + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + MOV II32 (OpReg r2) (OpReg ecx), + SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo), + SHR II32 (OpReg ecx) (OpReg rhi), + TEST II32 (OpImm (ImmInt 32)) (OpReg ecx), + JXX EQQ lbl2, + JXX ALWAYS lbl1, + NEWBLOCK lbl1, + MOV II32 (OpReg rhi) (OpReg rlo), + XOR II32 (OpReg rhi) (OpReg rhi), + JXX ALWAYS lbl2, + NEWBLOCK lbl2 + ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_And _) [e1,e2]) = iselExpr64ParallelBin AND e1 e2 +iselExpr64 (CmmMachOp (MO_Or _) [e1,e2]) = iselExpr64ParallelBin OR e1 e2 +iselExpr64 (CmmMachOp (MO_Xor _) [e1,e2]) = iselExpr64ParallelBin XOR e1 e2 + +iselExpr64 (CmmMachOp (MO_Not _) [e1]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + Reg64 rhi rlo <- getNewReg64 + let + code = code1 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + NOT II32 (OpReg rlo), + NOT II32 (OpReg rhi) + ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmRegOff r i) = iselExpr64 (mangleIndexTree r i) + +iselExpr64 expr + = do + platform <- getPlatform + pprPanic "iselExpr64(i386)" (pdoc platform expr $+$ text (show expr)) + +iselExpr64ParallelBin :: (Format -> Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM (RegCode64 (OrdList Instr)) +iselExpr64ParallelBin op e1 e2 = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + RegCode64 code2 r2hi r2lo <- iselExpr64 e2 + Reg64 rhi rlo <- getNewReg64 + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + op II32 (OpReg r2lo) (OpReg rlo), + op II32 (OpReg r2hi) (OpReg rhi) + ] + return (RegCode64 code rhi rlo) + +-------------------------------------------------------------------------------- + +getRegister :: HasDebugCallStack => CmmExpr -> NatM Register +getRegister e = do platform <- getPlatform + is32Bit <- is32BitPlatform + getRegister' platform is32Bit e + +getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register + +getRegister' platform is32Bit (CmmReg reg) + = case reg of + CmmGlobal (GlobalRegUse PicBaseReg _) + | is32Bit -> + -- on x86_64, we have %rip for PicBaseReg, but it's not + -- a full-featured register, it can only be used for + -- rip-relative addressing. + do reg' <- getPicBaseNat (archWordFormat is32Bit) + return (Fixed (archWordFormat is32Bit) reg' nilOL) + _ -> + let ty = cmmRegType reg + reg_fmt = cmmTypeFormat ty + in return $ Fixed reg_fmt (getRegisterReg platform reg) nilOL + +getRegister' platform is32Bit (CmmRegOff r n) + = getRegister' platform is32Bit $ mangleIndexTree r n + +getRegister' platform is32Bit (CmmMachOp (MO_RelaxedRead w) [e]) + = getRegister' platform is32Bit (CmmLoad e (cmmBits w) NaturallyAligned) + +getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e]) + = addAlignmentCheck align <$> getRegister' platform is32Bit e + +-- for 32-bit architectures, support some 64 -> 32 bit conversions: +-- TO_W_(x), TO_W_(x >> 32) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do + RegCode64 code rhi _rlo <- iselExpr64 x + return $ Fixed II32 rhi code + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do + RegCode64 code rhi _rlo <- iselExpr64 x + return $ Fixed II32 rhi code + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) + | is32Bit = do + RegCode64 code _rhi rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) + | is32Bit = do + RegCode64 code _rhi rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W8) [x]) + | is32Bit = do + RegCode64 code _rhi rlo <- iselExpr64 x + ro <- getNewRegNat II8 + return $ Fixed II8 ro (code `appOL` toOL [ MOVZxL II8 (OpReg rlo) (OpReg ro) ]) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W16) [x]) + | is32Bit = do + RegCode64 code _rhi rlo <- iselExpr64 x + ro <- getNewRegNat II16 + return $ Fixed II16 ro (code `appOL` toOL [ MOVZxL II16 (OpReg rlo) (OpReg ro) ]) + +-- catch simple cases of zero- or sign-extended load +getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do + code <- intLoadCode (MOVZxL II8) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do + code <- intLoadCode (MOVSxL II8) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do + code <- intLoadCode (MOVZxL II16) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do + code <- intLoadCode (MOVSxL II16) addr + return (Any II32 code) + +-- catch simple cases of zero- or sign-extended load +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOVZxL II8) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II8) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOVZxL II16) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II16) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II32) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)), + CmmLit displacement]) + | not is32Bit = + return $ Any II64 (\dst -> unitOL $ + LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) + +getRegister' _ _ (CmmMachOp mop []) = + pprPanic "getRegister(x86): nullary MachOp" (text $ show mop) + +getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps + avx <- avxEnabled + avx2 <- avx2Enabled + case mop of + MO_F_Neg w -> sse2NegCode w x + + + MO_S_Neg w -> triv_ucode NEGI (intFormat w) + MO_Not w -> triv_ucode NOT (intFormat w) + + -- Nop conversions + MO_UU_Conv W32 W8 -> toI8Reg W32 x + MO_SS_Conv W32 W8 -> toI8Reg W32 x + MO_XX_Conv W32 W8 -> toI8Reg W32 x + MO_UU_Conv W16 W8 -> toI8Reg W16 x + MO_SS_Conv W16 W8 -> toI8Reg W16 x + MO_XX_Conv W16 W8 -> toI8Reg W16 x + MO_UU_Conv W32 W16 -> toI16Reg W32 x + MO_SS_Conv W32 W16 -> toI16Reg W32 x + MO_XX_Conv W32 W16 -> toI16Reg W32 x + + MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_UU_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + MO_SS_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + MO_XX_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + + MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x + MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x + MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x + + MO_FW_Bitcast W32 -> bitcast FF32 II32 x + MO_WF_Bitcast W32 -> bitcast II32 FF32 x + MO_FW_Bitcast W64 -> bitcast FF64 II64 x + MO_WF_Bitcast W64 -> bitcast II64 FF64 x + MO_WF_Bitcast {} -> incorrectOperands + MO_FW_Bitcast {} -> incorrectOperands + + -- widenings + MO_UU_Conv W8 W32 -> integerExtend W8 W32 MOVZxL x + MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x + MO_UU_Conv W8 W16 -> integerExtend W8 W16 MOVZxL x + + MO_SS_Conv W8 W32 -> integerExtend W8 W32 MOVSxL x + MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x + MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x + + -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we + -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register + -- has 8-bit version). So for 32-bit code, we'll just zero-extend. + MO_XX_Conv W8 W32 + | is32Bit -> integerExtend W8 W32 MOVZxL x + | otherwise -> integerExtend W8 W32 MOV x + MO_XX_Conv W8 W16 + | is32Bit -> integerExtend W8 W16 MOVZxL x + | otherwise -> integerExtend W8 W16 MOV x + MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x + + MO_UU_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVZxL x + MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x + MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x + MO_SS_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVSxL x + MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x + MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x + -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl. + -- However, we don't want the register allocator to throw it + -- away as an unnecessary reg-to-reg move, so we keep it in + -- the form of a movzl and print it as a movl later. + -- This doesn't apply to MO_XX_Conv since in this case we don't care about + -- the upper bits. So we can just use MOV. + MO_XX_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOV x + MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x + MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x + + MO_FF_Conv W32 W64 -> coerceFP2FP W64 x + MO_FF_Conv W64 W32 -> coerceFP2FP W32 x + + MO_FF_Conv from to -> invalidConversion from to + MO_UU_Conv from to -> invalidConversion from to + MO_SS_Conv from to -> invalidConversion from to + MO_XX_Conv from to -> invalidConversion from to + + MO_FS_Truncate from to -> coerceFP2Int from to x + MO_SF_Round from to -> coerceInt2FP from to x + + MO_VF_Neg l w | avx -> vector_float_negate_avx l w x + | otherwise -> vector_float_negate_sse l w x + -- SIMD NCG TODO: Support 256/512-bit integer vectors + MO_VS_Neg l w -> getRegister' platform is32Bit (CmmMachOp (MO_V_Sub l w) [zero_vec, x]) + where zero_vec = CmmLit $ CmmVec $ replicate l $ CmmInt 0 w + + MO_VF_Broadcast l w + | avx + -> vector_float_broadcast_avx l w x + | otherwise + -> vector_float_broadcast_sse l w x + MO_V_Broadcast l w + | avx2, l * widthInBits w `elem` [128, 256] -- AVX-512 is not supported for now + -> vector_int_broadcast_avx2 l w x + MO_V_Broadcast 16 W8 -> vector_int8x16_broadcast x + MO_V_Broadcast 8 W16 -> vector_int16x8_broadcast x + MO_V_Broadcast 4 W32 -> vector_int32x4_broadcast x + MO_V_Broadcast 2 W64 -> vector_int64x2_broadcast x + MO_V_Broadcast {} + -> pprPanic "Unsupported integer vector broadcast operation for: " (pdoc platform x) + + -- Binary MachOps + MO_Add {} -> incorrectOperands + MO_Sub {} -> incorrectOperands + MO_Eq {} -> incorrectOperands + MO_Ne {} -> incorrectOperands + MO_Mul {} -> incorrectOperands + MO_S_MulMayOflo {} -> incorrectOperands + MO_S_Quot {} -> incorrectOperands + MO_S_Rem {} -> incorrectOperands + MO_U_Quot {} -> incorrectOperands + MO_U_Rem {} -> incorrectOperands + MO_S_Ge {} -> incorrectOperands + MO_S_Le {} -> incorrectOperands + MO_S_Gt {} -> incorrectOperands + MO_S_Lt {} -> incorrectOperands + MO_U_Ge {} -> incorrectOperands + MO_U_Le {} -> incorrectOperands + MO_U_Gt {} -> incorrectOperands + MO_U_Lt {} -> incorrectOperands + MO_F_Add {} -> incorrectOperands + MO_F_Sub {} -> incorrectOperands + MO_F_Mul {} -> incorrectOperands + MO_F_Quot {} -> incorrectOperands + MO_F_Eq {} -> incorrectOperands + MO_F_Ne {} -> incorrectOperands + MO_F_Ge {} -> incorrectOperands + MO_F_Le {} -> incorrectOperands + MO_F_Gt {} -> incorrectOperands + MO_F_Lt {} -> incorrectOperands + MO_F_Min {} -> incorrectOperands + MO_F_Max {} -> incorrectOperands + MO_And {} -> incorrectOperands + MO_Or {} -> incorrectOperands + MO_Xor {} -> incorrectOperands + MO_Shl {} -> incorrectOperands + MO_U_Shr {} -> incorrectOperands + MO_S_Shr {} -> incorrectOperands + + MO_V_Extract {} -> incorrectOperands + MO_V_Add {} -> incorrectOperands + MO_V_Sub {} -> incorrectOperands + MO_V_Mul {} -> incorrectOperands + MO_V_Shuffle {} -> incorrectOperands + MO_VF_Shuffle {} -> incorrectOperands + MO_VU_Min {} -> incorrectOperands + MO_VU_Max {} -> incorrectOperands + MO_VS_Min {} -> incorrectOperands + MO_VS_Max {} -> incorrectOperands + MO_VF_Min {} -> incorrectOperands + MO_VF_Max {} -> incorrectOperands + + MO_VF_Extract {} -> incorrectOperands + MO_VF_Add {} -> incorrectOperands + MO_VF_Sub {} -> incorrectOperands + MO_VF_Mul {} -> incorrectOperands + MO_VF_Quot {} -> incorrectOperands + + -- Ternary MachOps + MO_FMA {} -> incorrectOperands + MO_VF_Insert {} -> incorrectOperands + MO_V_Insert {} -> incorrectOperands + + --_other -> pprPanic "getRegister" (pprMachOp mop) + where + triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register + triv_ucode instr format = trivialUCode format (instr format) x + + -- signed or unsigned extension. + integerExtend :: Width -> Width + -> (Format -> Operand -> Operand -> Instr) + -> CmmExpr -> NatM Register + integerExtend from to instr expr = do + (reg,e_code) <- if from == W8 then getByteReg expr + else getSomeReg expr + let + code dst = + e_code `snocOL` + instr (intFormat from) (OpReg reg) (OpReg dst) + return (Any (intFormat to) code) + + bitcast :: Format -> Format -> CmmExpr -> NatM Register + bitcast fmt rfmt expr = + do (src, e_code) <- getSomeReg expr + let code = \dst -> e_code `snocOL` (MOVD fmt rfmt (OpReg src) (OpReg dst)) + return (Any rfmt code) + + toI8Reg :: Width -> CmmExpr -> NatM Register + toI8Reg new_rep expr + = do codefn <- getAnyReg expr + return (Any (intFormat new_rep) codefn) + -- HACK: use getAnyReg to get a byte-addressable register. + -- If the source was a Fixed register, this will add the + -- mov instruction to put it into the desired destination. + -- We're assuming that the destination won't be a fixed + -- non-byte-addressable register; it won't be, because all + -- fixed registers are word-sized. + + toI16Reg = toI8Reg -- for now + + conversionNop :: Format -> CmmExpr -> NatM Register + conversionNop new_format expr + = do e_code <- getRegister' platform is32Bit expr + return (swizzleRegisterRep e_code new_format) + + vector_float_negate_avx :: Length -> Width -> CmmExpr -> NatM Register + vector_float_negate_avx l w expr = do + let fmt :: Format + mask :: CmmLit + (fmt, mask) = case w of + W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- TODO: these should be negative 0 floating point literals, + W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- but we don't currently have those in Cmm. + _ -> panic "AVX floating-point negation: elements must be FF32 or FF64" + (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask) + (reg, exp) <- getSomeReg expr + let code dst = maskCode `appOL` + exp `snocOL` + (VMOVU fmt (OpReg reg) (OpReg dst)) `snocOL` + (VXOR fmt (OpReg maskReg) dst dst) + return (Any fmt code) + + vector_float_negate_sse :: Length -> Width -> CmmExpr -> NatM Register + vector_float_negate_sse l w expr = do + let fmt :: Format + mask :: CmmLit + (fmt, mask) = case w of + W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- Same comment as for vector_float_negate_avx, + W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- these should be -0.0 CmmFloat values. + _ -> panic "SSE floating-point negation: elements must be FF32 or FF64" + (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask) + (reg, exp) <- getSomeReg expr + let code dst = maskCode `appOL` + exp `snocOL` + (MOVU fmt (OpReg reg) (OpReg dst)) `snocOL` + (XOR fmt (OpReg maskReg) (OpReg dst)) + return (Any fmt code) + + ----------------------- + + -- TODO: we could use VBROADCASTSS/SD when AVX2 is available. + vector_float_broadcast_avx :: Length + -> Width + -> CmmExpr + -> NatM Register + vector_float_broadcast_avx len w expr = do + (dst, exp) <- getSomeReg expr + let fmt = VecFormat len (floatScalarFormat w) + code = VSHUF fmt (ImmInt 0) (OpReg dst) dst dst + return $ Fixed fmt dst (exp `snocOL` code) + + vector_float_broadcast_sse :: Length + -> Width + -> CmmExpr + -> NatM Register + vector_float_broadcast_sse len w expr = do + (dst, exp) <- getSomeReg expr + let fmt = VecFormat len (floatScalarFormat w) + code = SHUF fmt (ImmInt 0) (OpReg dst) dst + return $ Fixed fmt dst (exp `snocOL` code) + + vector_int_broadcast_avx2 :: Length + -> Width + -> CmmExpr + -> NatM Register + vector_int_broadcast_avx2 len w expr = do + (reg, exp) <- getNonClobberedReg expr + let (movFormat, fmt) = case w of + W8 -> (II32, VecFormat len FmtInt8) + W16 -> (II32, VecFormat len FmtInt16) + W32 -> (II32, VecFormat len FmtInt32) + W64 -> (II64, VecFormat len FmtInt64) + _ -> pprPanic "Broadcast not supported for: " (pdoc platform expr) + code dst = exp `snocOL` + -- VPBROADCAST from GPR requires AVX-512, + -- so we use an additional MOVD. + (MOVD movFormat fmt (OpReg reg) (OpReg dst)) `snocOL` + (VPBROADCAST fmt fmt (OpReg dst) dst) + return $ Any fmt code + + vector_int8x16_broadcast :: CmmExpr + -> NatM Register + vector_int8x16_broadcast expr = do + (reg, exp) <- getNonClobberedReg expr + let fmt = VecFormat 16 FmtInt8 + return $ Any fmt (\dst -> exp `snocOL` + (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL` + (PUNPCKLBW fmt (OpReg dst) dst) `snocOL` + (PUNPCKLWD (VecFormat 8 FmtInt16) (OpReg dst) dst) `snocOL` + (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst) + ) + + vector_int16x8_broadcast :: CmmExpr + -> NatM Register + vector_int16x8_broadcast expr = do + (reg, exp) <- getNonClobberedReg expr + let fmt = VecFormat 8 FmtInt16 + return $ Any fmt (\dst -> exp `snocOL` + (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL` + (PUNPCKLWD fmt (OpReg dst) dst) `snocOL` + (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst) + ) + + vector_int32x4_broadcast :: CmmExpr + -> NatM Register + vector_int32x4_broadcast expr = do + (reg, exp) <- getNonClobberedReg expr + let fmt = VecFormat 4 FmtInt32 + return $ Any fmt (\dst -> exp `snocOL` + (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL` + (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst) + ) + + vector_int64x2_broadcast :: CmmExpr + -> NatM Register + vector_int64x2_broadcast expr = do + (reg, exp) <- getNonClobberedReg expr + let fmt = VecFormat 2 FmtInt64 + return $ Any fmt (\dst -> exp `snocOL` + (MOVD II64 fmt (OpReg reg) (OpReg dst)) `snocOL` + (PUNPCKLQDQ fmt (OpReg dst) dst) + ) + +getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps + sse4_1 <- sse4_1Enabled + sse4_2 <- sse4_2Enabled + avx <- avxEnabled + case mop of + MO_F_Eq _ -> condFltReg is32Bit EQQ x y + MO_F_Ne _ -> condFltReg is32Bit NE x y + MO_F_Gt _ -> condFltReg is32Bit GTT x y + MO_F_Ge _ -> condFltReg is32Bit GE x y + -- Invert comparison condition and swap operands + -- See Note [SSE Parity Checks] + MO_F_Lt _ -> condFltReg is32Bit GTT y x + MO_F_Le _ -> condFltReg is32Bit GE y x + + MO_Eq _ -> condIntReg EQQ x y + MO_Ne _ -> condIntReg NE x y + + MO_S_Gt _ -> condIntReg GTT x y + MO_S_Ge _ -> condIntReg GE x y + MO_S_Lt _ -> condIntReg LTT x y + MO_S_Le _ -> condIntReg LE x y + + MO_U_Gt _ -> condIntReg GU x y + MO_U_Ge _ -> condIntReg GEU x y + MO_U_Lt _ -> condIntReg LU x y + MO_U_Le _ -> condIntReg LEU x y + + MO_F_Add w -> trivialFCode_sse2 w (\fmt op2 -> ADD fmt op2 . OpReg) x y + MO_F_Sub w -> trivialFCode_sse2 w (\fmt op2 -> SUB fmt op2 . OpReg) x y + MO_F_Quot w -> trivialFCode_sse2 w FDIV x y + MO_F_Mul w -> trivialFCode_sse2 w (\fmt op2 -> MUL fmt op2 . OpReg) x y + MO_F_Min w -> trivialFCode_sse2 w (MINMAX Min FloatMinMax) x y + MO_F_Max w -> trivialFCode_sse2 w (MINMAX Max FloatMinMax) x y + + MO_Add rep -> add_code rep x y + MO_Sub rep -> sub_code rep x y + + MO_S_Quot rep -> div_code rep True True x y + MO_S_Rem rep -> div_code rep True False x y + MO_U_Quot rep -> div_code rep False True x y + MO_U_Rem rep -> div_code rep False False x y + + MO_S_MulMayOflo rep -> imulMayOflo rep x y + + MO_Mul W8 -> imulW8 x y + MO_Mul rep -> triv_op rep IMUL + MO_And rep -> triv_op rep AND + MO_Or rep -> triv_op rep OR + MO_Xor rep -> triv_op rep XOR + + {- Shift ops on x86s have constraints on their source, it + either has to be Imm, CL or 1 + => trivialCode is not restrictive enough (sigh.) + -} + MO_Shl rep -> shift_code rep SHL x y {-False-} + MO_U_Shr rep -> shift_code rep SHR x y {-False-} + MO_S_Shr rep -> shift_code rep SAR x y {-False-} + + MO_VF_Shuffle 4 W32 is | avx -> vector_shuffle_float_avx 4 x y is + | otherwise -> vector_shuffle_floatx4_sse sse4_1 x y is + MO_VF_Shuffle 2 W64 is | avx -> vector_shuffle_double_avx 2 x y is + | otherwise -> vector_shuffle_doublex2_sse x y is + MO_VF_Shuffle {} -> sorry "Please use -fllvm for wide shuffle instructions" + + MO_VF_Extract l W32 | avx -> vector_float_extract l W32 x y + | otherwise -> vector_float_extract_sse l W32 x y + MO_VF_Extract l W64 -> vector_float_extract l W64 x y + MO_VF_Extract {} -> incorrectOperands + + MO_V_Extract 16 W8 | sse4_1 -> vector_int_extract_pextr 16 W8 x y + | otherwise -> vector_int8x16_extract_sse2 x y + MO_V_Extract 8 W16 -> vector_int_extract_pextr 8 W16 x y -- PEXTRW (SSE2) + MO_V_Extract 4 W32 | sse4_1 -> vector_int_extract_pextr 4 W32 x y + | otherwise -> vector_int32x4_extract_sse2 x y + MO_V_Extract 2 W64 | sse4_1 -> vector_int_extract_pextr 2 W64 x y + | otherwise -> vector_int64x2_extract_sse2 x y + -- SIMD NCG TODO: 256/512-bit vector + MO_V_Extract {} -> needLlvm mop + + MO_VF_Add l w | avx -> vector_float_op_avx VADD l w x y + | otherwise -> vector_float_op_sse (\fmt op2 -> ADD fmt op2 . OpReg) l w x y + + MO_VF_Sub l w | avx -> vector_float_op_avx VSUB l w x y + | otherwise -> vector_float_op_sse (\fmt op2 -> SUB fmt op2 . OpReg) l w x y + + MO_VF_Mul l w | avx -> vector_float_op_avx VMUL l w x y + | otherwise -> vector_float_op_sse (\fmt op2 -> MUL fmt op2 . OpReg) l w x y + + MO_VF_Quot l w | avx -> vector_float_op_avx VDIV l w x y + | otherwise -> vector_float_op_sse FDIV l w x y + + MO_VF_Min l w | avx -> vector_float_op_avx (VMINMAX Min FloatMinMax) l w x y + | otherwise -> vector_float_op_sse (MINMAX Min FloatMinMax) l w x y + + MO_VF_Max l w | avx -> vector_float_op_avx (VMINMAX Max FloatMinMax) l w x y + | otherwise -> vector_float_op_sse (MINMAX Max FloatMinMax) l w x y + + -- SIMD NCG TODO: 256/512-bit integer vector operations + MO_V_Shuffle 16 W8 is | not is32Bit -> vector_shuffle_int8x16 sse4_1 x y is + MO_V_Shuffle 8 W16 is -> vector_shuffle_int16x8 sse4_1 x y is + MO_V_Shuffle 4 W32 is -> vector_shuffle_int32x4 sse4_1 x y is + MO_V_Shuffle 2 W64 is -> vector_shuffle_int64x2 sse4_1 x y is + MO_V_Shuffle {} -> needLlvm mop + MO_V_Add l w | l * widthInBits w == 128 -> vector_int_op_sse PADD l w x y + | otherwise -> needLlvm mop + MO_V_Sub l w | l * widthInBits w == 128 -> vector_int_op_sse PSUB l w x y + | otherwise -> needLlvm mop + MO_V_Mul 16 W8 -> vector_int8x16_mul_sse2 x y + MO_V_Mul l@8 w@W16 -> vector_int_op_sse PMULL l w x y -- PMULLW (SSE2) + MO_V_Mul l@4 w@W32 | sse4_1 -> vector_int_op_sse PMULL l w x y -- PMULLD (SSE4.1) + | otherwise -> vector_int32x4_mul_sse2 x y + MO_V_Mul 2 W64 -> vector_int64x2_mul_sse2 x y + MO_V_Mul {} -> needLlvm mop + + MO_VU_Min l@16 w@W8 + -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUB (SSE2) + MO_VU_Min l@8 w@W16 + | sse4_1 -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUW (SSE4.1) + | otherwise -> vector_word_minmax_sse Min l w x y + MO_VU_Min l@4 w@W32 + | sse4_1 -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUD (SSE4.1) + | otherwise -> vector_word_minmax_sse Min l w x y + MO_VU_Min l@2 w@W64 + | sse4_2 -> vector_word_minmax_sse Min l w x y -- PCMPGTQ requires SSE4.2 + -- The SSE2 version is implemented as a C call (MO_W64X2_Min) + MO_VU_Min {} -> needLlvm mop + MO_VU_Max l@16 w@W8 + -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUB (SSE2) + MO_VU_Max l@8 w@W16 + | sse4_1 -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUW (SSE4.1) + | otherwise -> vector_word_minmax_sse Max l w x y + MO_VU_Max l@4 w@W32 + | sse4_1 -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUD (SSE4.1) + | otherwise -> vector_word_minmax_sse Max l w x y + MO_VU_Max l@2 w@W64 + | sse4_2 -> vector_word_minmax_sse Max l w x y -- PCMPGTQ requires SSE4.2 + -- The SSE2 version is implemented as a C call (MO_W64X2_Max) + MO_VU_Max {} -> needLlvm mop + MO_VS_Min l@16 w@W8 + | sse4_1 -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSB (SSE4.1) + | otherwise -> vector_int_minmax_sse Min l w x y + MO_VS_Min l@8 w@W16 + -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSW (SSE2) + MO_VS_Min l@4 w@W32 + | sse4_1 -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSD (SSE4.1) + | otherwise -> vector_int_minmax_sse Min l w x y + MO_VS_Min l@2 w@W64 + | sse4_2 -> vector_int_minmax_sse Min l w x y -- PCMPGTQ requires SSE4.2 + -- The SSE2 version is implemented as a C call (MO_I64X2_Min) + MO_VS_Min {} -> needLlvm mop + MO_VS_Max l@16 w@W8 + | sse4_1 -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSB (SSE4.1) + | otherwise -> vector_int_minmax_sse Max l w x y + MO_VS_Max l@8 w@W16 + -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSW (SSE2) + MO_VS_Max l@4 w@W32 + | sse4_1 -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSD (SSE4.1) + | otherwise -> vector_int_minmax_sse Max l w x y + MO_VS_Max l@2 w@W64 + | sse4_2 -> vector_int_minmax_sse Max l w x y -- PCMPGTQ requires SSE4.2 + -- The SSE2 version is implemented as a C call (MO_I64X2_Max) + MO_VS_Max {} -> needLlvm mop + + -- Unary MachOps + MO_S_Neg {} -> incorrectOperands + MO_F_Neg {} -> incorrectOperands + MO_Not {} -> incorrectOperands + MO_SF_Round {} -> incorrectOperands + MO_FS_Truncate {} -> incorrectOperands + MO_SS_Conv {} -> incorrectOperands + MO_XX_Conv {} -> incorrectOperands + MO_FF_Conv {} -> incorrectOperands + MO_UU_Conv {} -> incorrectOperands + MO_WF_Bitcast {} -> incorrectOperands + MO_FW_Bitcast {} -> incorrectOperands + MO_RelaxedRead {} -> incorrectOperands + MO_AlignmentCheck {} -> incorrectOperands + MO_VS_Neg {} -> incorrectOperands + MO_VF_Neg {} -> incorrectOperands + MO_V_Broadcast {} -> incorrectOperands + MO_VF_Broadcast {} -> incorrectOperands + + -- Ternary MachOps + MO_FMA {} -> incorrectOperands + MO_V_Insert {} -> incorrectOperands + MO_VF_Insert {} -> incorrectOperands + + where + -------------------- + triv_op width instr = trivialCode width op (Just op) x y + where op = instr (intFormat width) + + -- Special case for IMUL for bytes, since the result of IMULB will be in + -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider + -- values. + imulW8 :: CmmExpr -> CmmExpr -> NatM Register + imulW8 arg_a arg_b = do + (a_reg, a_code) <- getNonClobberedReg arg_a + b_code <- getAnyReg arg_b + + let code = a_code `appOL` b_code eax `appOL` + toOL [ IMUL2 format (OpReg a_reg) ] + format = intFormat W8 + + return (Fixed format eax code) + + imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register + imulMayOflo W8 a b = do + -- The general case (W16, W32, W64) doesn't work for W8 as its + -- multiplication doesn't use two registers. + -- + -- The plan is: + -- 1. truncate and sign-extend a and b to 8bit width + -- 2. multiply a' = a * b in 32bit width + -- 3. copy and sign-extend 8bit from a' to c + -- 4. compare a' and c: they are equal if there was no overflow + (a_reg, a_code) <- getNonClobberedReg a + (b_reg, b_code) <- getNonClobberedReg b + let + code = a_code `appOL` b_code `appOL` + toOL [ + MOVSxL II8 (OpReg a_reg) (OpReg a_reg), + MOVSxL II8 (OpReg b_reg) (OpReg b_reg), + IMUL II32 (OpReg b_reg) (OpReg a_reg), + MOVSxL II8 (OpReg a_reg) (OpReg eax), + CMP II16 (OpReg a_reg) (OpReg eax), + SETCC NE (OpReg eax) + ] + return (Fixed II8 eax code) + imulMayOflo rep a b = do + (a_reg, a_code) <- getNonClobberedReg a + b_code <- getAnyReg b + let + shift_amt = case rep of + W16 -> 15 + W32 -> 31 + W64 -> 63 + w -> panic ("shift_amt: " ++ show w) + + format = intFormat rep + code = a_code `appOL` b_code eax `appOL` + toOL [ + IMUL2 format (OpReg a_reg), -- result in %edx:%eax + SAR format (OpImm (ImmInt shift_amt)) (OpReg eax), + -- sign extend lower part + SUB format (OpReg edx) (OpReg eax) + -- compare against upper + -- eax==0 if high part == sign extended low part + ] + return (Fixed format eax code) + + -------------------- + shift_code :: Width + -> (Format -> Operand -> Operand -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + + {- Case1: shift length as immediate -} + shift_code width instr x (CmmLit lit) + -- Handle the case of a shift larger than the width of the shifted value. + -- This is necessary since x86 applies a mask of 0x1f to the shift + -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by + -- `47 & 0x1f == 15`. See #20626. + | CmmInt n _ <- lit + , n >= fromIntegral (widthInBits width) + = getRegister $ CmmLit $ CmmInt 0 width + + | otherwise = do + x_code <- getAnyReg x + let + format = intFormat width + code dst + = x_code dst `snocOL` + instr format (OpImm (litToImm lit)) (OpReg dst) + return (Any format code) + + {- Case2: shift length is complex (non-immediate) + * y must go in %ecx. + * we cannot do y first *and* put its result in %ecx, because + %ecx might be clobbered by x. + * if we do y second, then x cannot be + in a clobbered reg. Also, we cannot clobber x's reg + with the instruction itself. + * so we can either: + - do y first, put its result in a fresh tmp, then copy it to %ecx later + - do y second and put its result into %ecx. x gets placed in a fresh + tmp. This is likely to be better, because the reg alloc can + eliminate this reg->reg move here (it won't eliminate the other one, + because the move is into the fixed %ecx). + * in the case of C calls the use of ecx here can interfere with arguments. + We avoid this with the hack described in Note [Evaluate C-call + arguments before placing in destination registers] + -} + shift_code width instr x y{-amount-} = do + x_code <- getAnyReg x + let format = intFormat width + tmp <- getNewRegNat format + y_code <- getAnyReg y + let + code = x_code tmp `appOL` + y_code ecx `snocOL` + instr format (OpReg ecx) (OpReg tmp) + return (Fixed format tmp code) + + -------------------- + add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register + add_code rep x (CmmLit (CmmInt y _)) + | is32BitInteger y + , rep /= W8 -- LEA doesn't support byte size (#18614) + = add_int rep x y + add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y + where format = intFormat rep + -- TODO: There are other interesting patterns we want to replace + -- with a LEA, e.g. `(x + offset) + (y << shift)`. + + -------------------- + sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register + sub_code rep x (CmmLit (CmmInt y _)) + | is32BitInteger (-y) + , rep /= W8 -- LEA doesn't support byte size (#18614) + = add_int rep x (-y) + sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y + + -- our three-operand add instruction: + add_int width x y = do + (x_reg, x_code) <- getSomeReg x + let + format = intFormat width + imm = ImmInt (fromInteger y) + code dst + = x_code `snocOL` + LEA format + (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm)) + (OpReg dst) + -- + return (Any format code) + + ---------------------- + + -- See Note [DIV/IDIV for bytes] + div_code W8 signed quotient x y = do + let widen | signed = MO_SS_Conv W8 W16 + | otherwise = MO_UU_Conv W8 W16 + div_code + W16 + signed + quotient + (CmmMachOp widen [x]) + (CmmMachOp widen [y]) + + div_code width signed quotient x y = do + (y_op, y_code) <- getRegOrMem y -- cannot be clobbered + x_code <- getAnyReg x + let + format = intFormat width + widen | signed = CLTD format + | otherwise = XOR format (OpReg edx) (OpReg edx) + + instr | signed = IDIV + | otherwise = DIV + + code = y_code `appOL` + x_code eax `appOL` + toOL [widen, instr format y_op] + + result | quotient = eax + | otherwise = edx + + return (Fixed format result code) + + ----------------------- + -- Vector operations--- + vector_float_op_avx :: (Format -> Operand -> Reg -> Reg -> Instr) + -> Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_op_avx instr l w = vector_op_avx_reg (\fmt -> instr fmt . OpReg) format + where format = case w of + W32 -> VecFormat l FmtFloat + W64 -> VecFormat l FmtDouble + _ -> pprPanic "Floating-point AVX vector operation not supported at this width" + (text "width:" <+> ppr w) + + vector_op_avx_reg :: (Format -> Reg -> Reg -> Reg -> Instr) + -> Format + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_op_avx_reg instr format expr1 expr2 = do + (reg1, exp1) <- getSomeReg expr1 + (reg2, exp2) <- getSomeReg expr2 + let -- opcode src2 src1 dst <==> dst = src1 `opcode` src2 + code dst = exp1 `appOL` exp2 `snocOL` + (instr format reg2 reg1 dst) + return (Any format code) + + vector_float_op_sse :: (Format -> Operand -> Reg -> Instr) + -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register + vector_float_op_sse instr l w = vector_op_sse instr format + where format = case w of + W32 -> VecFormat l FmtFloat + W64 -> VecFormat l FmtDouble + _ -> pprPanic "Floating-point SSE vector operation not supported at this width" + (text "width:" <+> ppr w) + + vector_int_op_sse :: (Format -> Operand -> Reg -> Instr) + -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register + vector_int_op_sse instr l w = vector_op_sse instr format + where format = case w of + W8 -> VecFormat l FmtInt8 + W16 -> VecFormat l FmtInt16 + W32 -> VecFormat l FmtInt32 + W64 -> VecFormat l FmtInt64 + _ -> pprPanic "Integer SSE vector operation not supported at this width" + (text "width:" <+> ppr w) + + -- This function is similar to genTrivialCode, but re-using it would require + -- handling alignment correctly: SSE vector instructions typically require 16-byte + -- alignment for their memory operand (this restriction is relaxed with VEX-encoded + -- instructions). + -- For now, we always load the value into a register and avoid the alignment issue. + vector_op_sse :: (Format -> Operand -> Reg -> Instr) + -> Format + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_op_sse instr = vector_op_sse_reg (\fmt -> instr fmt . OpReg) + + vector_op_sse_reg :: (Format -> Reg -> Reg -> Instr) + -> Format + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_op_sse_reg instr format expr1 expr2 = do + config <- getConfig + exp1_code <- getAnyReg expr1 + (reg2, exp2_code) <- getSomeReg expr2 -- vector registers are never clobbered by an instruction + tmp <- getNewRegNat format + let code dst + -- opcode src2 src1 <==> src1 = src1 `opcode` src2 + | dst == reg2 = exp2_code `snocOL` + movInstr config format (OpReg reg2) (OpReg tmp) `appOL` -- MOVU or MOVDQU + exp1_code dst `snocOL` + instr format tmp dst + | otherwise = exp2_code `appOL` + exp1_code dst `snocOL` + instr format reg2 dst + return (Any format code) + -------------------- + vector_float_extract :: Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_extract l W32 expr (CmmLit lit) = do + (r, exp) <- getSomeReg expr + let format = VecFormat l FmtFloat + imm = litToImm lit + code dst + = case lit of + CmmInt 0 _ -> exp `snocOL` (MOV FF32 (OpReg r) (OpReg dst)) + CmmInt _ _ -> exp `snocOL` (VPSHUFD format imm (OpReg r) dst) + _ -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit) + return (Any FF32 code) + vector_float_extract _ W64 expr (CmmLit lit) = do + (r, exp) <- getSomeReg expr + let code dst + = case lit of + CmmInt 0 _ -> exp `snocOL` + (MOV FF64 (OpReg r) (OpReg dst)) + CmmInt 1 _ -> exp `snocOL` + (MOVHLPS FF64 r dst) + _ -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit) + return (Any FF64 code) + vector_float_extract _ w c e = + pprPanic "Unsupported AVX floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w) + ----------------------- + + vector_float_extract_sse :: Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_extract_sse l W32 expr (CmmLit lit) + = do + (r,exp) <- getSomeReg expr + let format = VecFormat l FmtFloat + imm = litToImm lit + code dst + = case lit of + CmmInt 0 _ -> exp `snocOL` (MOVU format (OpReg r) (OpReg dst)) + CmmInt _ _ -> exp `snocOL` (PSHUFD format imm (OpReg r) dst) + _ -> pprPanic "Unsupported SSE floating-point vector extract offset" (ppr lit) + return (Any FF32 code) + vector_float_extract_sse _ w c e + = pprPanic "Unsupported SSE floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w) + ----------------------- + + -- PEXTRW ("to GPR" variant) is an SSE2 instruction, + -- whereas PEXTR{B,D,Q} and PEXTRW ("to memory" variant) require SSE4.1. + vector_int_extract_pextr :: Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_int_extract_pextr l w expr (CmmLit (CmmInt i _)) + | 0 <= i, i < toInteger l + = do + (r, exp) <- getSomeReg expr -- vector registers are never clobbered by an instruction + let (scalarFormat, vectorFormat) = case w of + W8 -> (II32, VecFormat l FmtInt8) + W16 -> (II32, VecFormat l FmtInt16) + W32 -> (II32, VecFormat l FmtInt32) + W64 -> (II64, VecFormat l FmtInt64) + _ -> sorry "Unsupported vector format" + code dst = exp `snocOL` + (PEXTR scalarFormat vectorFormat (ImmInteger i) r (OpReg dst)) + return (Any scalarFormat code) + vector_int_extract_pextr _ _ _ i + = pprPanic "Unsupported offset" (pdoc platform i) + + vector_int8x16_extract_sse2 :: CmmExpr + -> CmmExpr + -> NatM Register + vector_int8x16_extract_sse2 expr (CmmLit (CmmInt i _)) + | 0 <= i, i < 16 + = do + (r, exp) <- getSomeReg expr + let code dst = + case i `quotRem` 2 of + (j, 0) -> exp `snocOL` + (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) r (OpReg dst)) -- PEXTRW + (j, _) -> exp `snocOL` + (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) r (OpReg dst)) `snocOL` -- PEXTRW + (SHR II32 (OpImm (ImmInt 8)) (OpReg dst)) + return (Any II8 code) + vector_int8x16_extract_sse2 _ offset + = pprPanic "Unsupported offset" (pdoc platform offset) + + vector_int32x4_extract_sse2 :: CmmExpr + -> CmmExpr + -> NatM Register + vector_int32x4_extract_sse2 expr (CmmLit (CmmInt i _)) + | 0 <= i, i < 4 + = do + (r, exp) <- getSomeReg expr + let fmt = VecFormat 4 FmtInt32 + tmp <- getNewRegNat fmt + let code dst = + case i of + 0 -> exp `snocOL` + (MOVD fmt II32 (OpReg r) (OpReg dst)) + 1 -> exp `snocOL` + (PSHUFD fmt (ImmInt 0b01_01_01_01) (OpReg r) tmp) `snocOL` -- tmp <- (r[1],r[1],r[1],r[1]) + (MOVD fmt II32 (OpReg tmp) (OpReg dst)) + 2 -> exp `snocOL` + (PSHUFD fmt (ImmInt 0b11_10_11_10) (OpReg r) tmp) `snocOL` -- tmp <- (r[2],r[3],r[2],r[3]) + (MOVD fmt II32 (OpReg tmp) (OpReg dst)) + _ -> exp `snocOL` + (PSHUFD fmt (ImmInt 0b11_11_11_11) (OpReg r) tmp) `snocOL` -- tmp <- (r[3],r[3],r[3],r[3]) + (MOVD fmt II32 (OpReg tmp) (OpReg dst)) + return (Any II32 code) + vector_int32x4_extract_sse2 _ offset + = pprPanic "Unsupported offset" (pdoc platform offset) + + vector_int64x2_extract_sse2 :: CmmExpr + -> CmmExpr + -> NatM Register + vector_int64x2_extract_sse2 expr (CmmLit lit) + = do + (r, exp) <- getSomeReg expr + let fmt = VecFormat 2 FmtInt64 + tmp <- getNewRegNat fmt + let code dst = + case lit of + CmmInt 0 _ -> exp `snocOL` + (MOVD fmt II64 (OpReg r) (OpReg dst)) + CmmInt 1 _ -> exp `snocOL` + (MOVHLPS FF64 r tmp) `snocOL` + (MOVD fmt II64 (OpReg tmp) (OpReg dst)) + _ -> panic "Error in offset while unpacking" + return (Any II64 code) + vector_int64x2_extract_sse2 _ offset + = pprPanic "Unsupported offset" (pdoc platform offset) + + vector_int8x16_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register + vector_int8x16_mul_sse2 expr1 expr2 = do + -- use two SSE2 PMULLW (low 16 bits of int16 multiplication) operations + (reg1, exp1) <- getSomeReg expr1 + (reg2, exp2) <- getSomeReg expr2 + let format = VecFormat 16 FmtInt8 + format16 = VecFormat 8 FmtInt16 -- for PMULLW + tmp1lo <- getNewRegNat format + tmp1hi <- getNewRegNat format + tmp2hi <- getNewRegNat format + tmp2lo <- getNewRegNat format + (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate 8 (CmmInt 0xff W16)) -- (0xff,0,0xff,0,...,0xff,0) :: Int8X16 + let code = exp1 `appOL` exp2 `appOL` maskCode `snocOL` + (MOVDQU format (OpReg reg1) (OpReg tmp1lo)) `snocOL` -- tmp1lo <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp2lo)) `snocOL` -- tmp2lo <- reg2 + (PUNPCKLBW format (OpReg reg1) tmp1lo) `snocOL` -- tmp1lo <- (tmp1lo[0],reg1[0],tmp1lo[1],reg1[1],...,tmp1lo[7],reg1[7]); The first operand does not really matter + (PUNPCKLBW format (OpReg reg2) tmp2lo) `snocOL` -- tmp2lo <- (tmp2lo[0],reg2[0],tmp2lo[1],reg2[1],...,tmp2lo[7],reg2[7]); The first operand does not really matter + (MOVDQU format (OpReg reg1) (OpReg tmp1hi)) `snocOL` -- tmp1hi <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp2hi)) `snocOL` -- tmp2hi <- reg2 + (PUNPCKHBW format (OpReg reg1) tmp1hi) `snocOL` -- tmp1hi <- (tmp1hi[8],reg1[8],tmp1hi[9],reg1[9],...,tmp1hi[15],reg1[15]); The first operand does not really matter + (PMULL format16 (OpReg tmp2lo) tmp1lo) `snocOL` -- PMULLW; tmp1lo <- (tmp1lo[0]*tmp2lo[0],*,tmp1lo[2]*tmp2lo[2],*,...,tmp1lo[14]*tmp2lo[14],*) + (PUNPCKHBW format (OpReg reg2) tmp2hi) `snocOL` -- tmp2hi <- (tmp2hi[8],reg2[8],tmp2hi[9],reg2[9],...,tmp2hi[15],reg2[15]); The first operand does not really matter + (PMULL format16 (OpReg tmp2hi) tmp1hi) `snocOL` -- PMULLW; tmp1hi <- (tmp1hi[0]*tmp2hi[0],*,tmp1hi[2]*tmp2hi[2],*,...,tmp1hi[14]*tmp2hi[14],*) + (PAND format (OpReg maskReg) tmp1lo) `snocOL` -- tmp1lo <- (tmp1lo[0],0,tmp1lo[2],0,...,tmp1lo[14],0) + (PAND format (OpReg maskReg) tmp1hi) `snocOL` -- tmp1hi <- (tmp1hi[0],0,tmp1hi[2],0,...,tmp1hi[14],0) + (PACKUSWB format (OpReg tmp1hi) tmp1lo) -- tmp1lo <- (tmp1lo[0],tmp1lo[2],...,tmp1lo[14],tmp1hi[0],tmp1hi[2],...tmp1hi[14]) + return (Fixed format tmp1lo code) + + vector_int32x4_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register + vector_int32x4_mul_sse2 expr1 expr2 = do + -- use two SSE2 PMULUDQ (int32 x int32 -> int64 multiplication) operations + (reg1, exp1) <- getSomeReg expr1 + (reg2, exp2) <- getSomeReg expr2 + let format = VecFormat 4 FmtInt32 + tmpEven <- getNewRegNat format + tmpOdd1 <- getNewRegNat format + tmpOdd2 <- getNewRegNat format + let code dst = exp1 `appOL` exp2 `snocOL` + (MOVDQU format (OpReg reg1) (OpReg tmpEven)) `snocOL` -- tmpEven <- reg1 + (PSHUFD format (ImmInt 0b11_11_01_01) (OpReg reg1) tmpOdd1) `snocOL` -- tmpOdd1 <- (reg1[1],reg1[1],reg1[3],reg1[3]) + (PMULUDQ format (OpReg reg2) tmpEven) `snocOL` -- tmpEven <- (tmpEven[0]*reg2[0],*,tmpEven[2]*reg2[2],*) + (PSHUFD format (ImmInt 0b11_11_01_01) (OpReg reg2) tmpOdd2) `snocOL` -- tmpOdd2 <- (reg2[1],reg2[1],reg2[3],reg2[3]) + (PMULUDQ format (OpReg tmpOdd2) tmpOdd1) `snocOL` -- tmpOdd1 <- (tmpOdd1[0]*tmpOdd2[0],*,tmpOdd1[2]*tmpOdd2[2],*) + (PSHUFD format (ImmInt 0b00_00_10_00) (OpReg tmpEven) dst) `snocOL` -- dst <- (tmpEven[0],tmpEven[2],tmpEven[0],tmpEven[0]) + (PSHUFD format (ImmInt 0b00_00_10_00) (OpReg tmpOdd1) tmpOdd1) `snocOL` -- tmpOdd1 <- (tmpOdd1[0],tmpOdd1[2],tmpOdd1[0],tmpOdd1[0]) + (PUNPCKLDQ format (OpReg tmpOdd1) dst) -- dst <- (dst[0],tmpOdd1[0],dst[1],tmpOdd1[1]) + return (Any format code) + + -- TODO: We could use `VPMULLQ` if AVX-512 or AVX10.1 is available. + vector_int64x2_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register + vector_int64x2_mul_sse2 expr1 expr2 = do + -- implement 64 bit multiplication using 32-bit PMULUDQ multiplication instructions + -- (lo1 + shiftL hi1 32) * (lo2 + shiftL hi2 32) = lo1 * lo2 + shiftL (lo1 * hi2) 32 + shiftL (lo2 * hi1) 32 + exp1 <- getAnyReg expr1 + exp2 <- getAnyReg expr2 + let format = VecFormat 2 FmtInt64 + reg1 <- getNewRegNat format + reg2 <- getNewRegNat format + tmp1Hi <- getNewRegNat format + tmp2Hi <- getNewRegNat format + let code dst = exp1 reg1 `appOL` exp2 reg2 `snocOL` + (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1 + (MOVDQU format (OpReg reg1) (OpReg tmp1Hi)) `snocOL` -- tmp1Hi <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp2Hi)) `snocOL` -- tmp2Hi <- reg2 + (PSRL format (OpImm (ImmInt 32)) tmp1Hi) `snocOL` -- PSRLQ (logical shift); tmp1Hi <- (tmp1Hi[0] >> 32, tmp1Hi[1] >> 32) + (PMULUDQ format (OpReg reg2) dst) `snocOL` -- dst <- ((dst as Word32X4)[0] * (reg2 as Word32X4)[0] as Word64, (dst as Word32X4)[2] * (reg2 as Word32X4)[2] as Word64) + (PSRL format (OpImm (ImmInt 32)) tmp2Hi) `snocOL` -- PSRLQ (logical shift); tmp2Hi <- (tmp2Hi[0] >> 32, tmp2Hi[1] >> 32) + (PMULUDQ format (OpReg reg2) tmp1Hi) `snocOL` -- tmp1Hi <- ((tmp1Hi as Word32X4)[0] * (reg2 as Word32X4)[0] as Word64, (tmp1Hi as Word32X4)[2] * (reg2 as Word32X4)[2] as Word64) + (PMULUDQ format (OpReg reg1) tmp2Hi) `snocOL` -- tmp2Hi <- ((tmp2Hi as Word32X4)[0] * (reg1 as Word32X4)[0] as Word64, (tmp2Hi as Word32X4)[2] * (reg1 as Word32X4)[2] as Word64) + (PADD format (OpReg tmp2Hi) tmp1Hi) `snocOL` -- PADDQ; tmp1Hi <- (tmp1Hi[0] + tmp2Hi[0], tmp1Hi[1] + tmp2Hi[1]) + (PSLL format (OpImm (ImmInt 32)) tmp1Hi) `snocOL` -- PSLLQ; tmp1Hi <- (tmp1Hi[0] << 32, tmp1Hi[1] << 32) + (PADD format (OpReg tmp1Hi) dst) -- PADDQ; dst <- (dst[0] + tmp1Hi[0], dst[1] + tmp1Hi[1]) + return (Any format code) + + vector_int_minmax_sse :: MinOrMax -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register + vector_int_minmax_sse minmax l w expr1 expr2 = do + -- SSE2 fallback: compute a mask of 0s/1s using PCMPGT, then max a b = (mask & a) | (not mask & b) + exp1 <- getAnyReg expr1 + exp2 <- getAnyReg expr2 + let format = case w of + W8 -> VecFormat l FmtInt8 + W16 -> VecFormat l FmtInt16 + W32 -> VecFormat l FmtInt32 + W64 -> VecFormat l FmtInt64 + _ -> panic "Unsupported width" + reg1 <- getNewRegNat format + reg2 <- getNewRegNat format + tmp <- getNewRegNat format + let codeMin dst = exp1 reg1 `appOL` exp2 reg2 `snocOL` + (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp)) `snocOL` -- tmp <- reg2 + (PCMPGT format (OpReg reg2) dst) `snocOL` -- dst <- if dst > reg2 then True(-1) else False(0) + (PAND format (OpReg dst) tmp) `snocOL` -- tmp <- tmp & dst; if dst then tmp else 0 + (PANDN format (OpReg reg1) dst) `snocOL` -- dst <- ~dst & reg1; if dst then 0 else reg1 + (POR format (OpReg tmp) dst) -- dst <- tmp | dst + codeMax dst = exp1 reg1 `appOL` exp2 reg2 `snocOL` + (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1 + (MOVDQU format (OpReg reg1) (OpReg tmp)) `snocOL` -- tmp <- reg1 + (PCMPGT format (OpReg reg2) dst) `snocOL` -- dst <- if dst > reg2 then True(-1) else False(0) + (PAND format (OpReg dst) tmp) `snocOL` -- tmp <- tmp & dst; if dst then tmp else 0 + (PANDN format (OpReg reg2) dst) `snocOL` -- dst <- ~dst & reg2; if dst then 0 else reg2 + (POR format (OpReg tmp) dst) -- dst <- tmp | dst + return $ case minmax of + Min -> Any format codeMin + Max -> Any format codeMax + + vector_word_minmax_sse :: MinOrMax -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register + vector_word_minmax_sse minmax l w expr1 expr2 = do + -- SSE2 fallback: compute a mask of 0s/1s using PCMPGT, then max a b = (mask & a) | (not mask & b) + -- We can use PCMPGT to compare unsigned integers by flipping the most significant bit. + exp1 <- getAnyReg expr1 + exp2 <- getAnyReg expr2 + let (format, sign) = case w of + W8 -> (VecFormat l FmtInt8, 0x80) + W16 -> (VecFormat l FmtInt16, 0x8000) + W32 -> (VecFormat l FmtInt32, 2^(31 :: Int)) + W64 -> (VecFormat l FmtInt64, 2^(63 :: Int)) + _ -> panic "Unsupported width" + reg1 <- getNewRegNat format + reg2 <- getNewRegNat format + tmp1 <- getNewRegNat format + tmp2 <- getNewRegNat format + (signReg, signCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l (CmmInt sign w)) + let codeMin dst = exp1 reg1 `appOL` exp2 reg2 `appOL` signCode `snocOL` + (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp1)) `snocOL` -- tmp1 <- reg2 + (MOVDQU format (OpReg reg2) (OpReg tmp2)) `snocOL` -- tmp2 <- reg2 + (PXOR format (OpReg signReg) dst) `snocOL` -- dst <- dst ^ 2^(w-1) + (PXOR format (OpReg signReg) tmp1) `snocOL` -- tmp1 < dst ^ 2^(w-1) + (PCMPGT format (OpReg tmp1) dst) `snocOL` -- dst <- if dst > tmp1 then True(-1) else False(0) + (PAND format (OpReg dst) tmp2) `snocOL` -- tmp2 <- tmp2 & dst; if dst then tmp2 else 0 + (PANDN format (OpReg reg1) dst) `snocOL` -- dst <- ~dst & reg1; if dst then 0 else reg1 + (POR format (OpReg tmp2) dst) -- dst <- tmp2 | dst + codeMax dst = exp1 reg1 `appOL` exp2 reg2 `appOL` signCode `snocOL` + (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp1)) `snocOL` -- tmp1 <- reg2 + (MOVDQU format (OpReg reg1) (OpReg tmp2)) `snocOL` -- tmp2 <- reg1 + (PXOR format (OpReg signReg) dst) `snocOL` -- dst <- dst ^ 2^(w-1) + (PXOR format (OpReg signReg) tmp1) `snocOL` -- tmp1 <- tmp1 ^ 2^(w-1) + (PCMPGT format (OpReg tmp1) dst) `snocOL` -- dst <- if dst > tmp1 then True(-1) else False(0) + (PAND format (OpReg dst) tmp2) `snocOL` -- tmp2 <- tmp2 & dst; if dst then tmp2 else 0 + (PANDN format (OpReg reg2) dst) `snocOL` -- dst <- ~dst & reg2; if dst then 0 else reg2 + (POR format (OpReg tmp2) dst) -- dst <- tmp2 | dst + return $ case minmax of + Min -> Any format codeMin + Max -> Any format codeMax + + vector_shuffle_floatx4_sse :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_floatx4_sse sse4_1 v1 v2 is + | length is == 4, all (\i -> 0 <= i && i < 8) is = do + let fmt = VecFormat 4 FmtFloat + + -- A helper function to shuffle a vector `r` in-place using (dst,src) pairs + -- (r[d0],r[d1],...) <- (r[s0],r[s1],...) + inplaceShuffle pairs r = do + let mask = foldl' (\acc (dst,src) -> acc .|. (src `shiftL` (2 * dst))) 0 pairs + case mask of + 0b11_10_01_00 -> nilOL -- trivial + 0b01_00_01_00 -> unitOL (MOVLHPS fmt r r) + 0b11_10_11_10 -> unitOL (MOVHLPS fmt r r) + 0b01_01_00_00 -> unitOL (UNPCKL fmt (OpReg r) r) + 0b11_11_10_10 -> unitOL (UNPCKH fmt (OpReg r) r) + _ -> unitOL (SHUF fmt (ImmInt mask) (OpReg r) r) + + -- All elements are from one source vector + oneSource p0 p1 p2 p3 v = do + exp <- getAnyReg v + let code dst = exp dst `appOL` + inplaceShuffle [p0,p1,p2,p3] dst + return $ Any fmt code + + -- Two elements from one vector, other two from the other vector + twoAndTwo (0,0) (1,1) (2,0) (3,1) v1 v2 = vector_op_sse_reg MOVLHPS fmt v1 v2 + twoAndTwo (2,0) (3,1) (0,0) (1,1) v1 v2 = vector_op_sse_reg MOVLHPS fmt v2 v1 + twoAndTwo (2,2) (3,3) (0,2) (1,3) v1 v2 = vector_op_sse_reg MOVHLPS fmt v1 v2 + twoAndTwo (0,2) (1,3) (2,2) (3,3) v1 v2 = vector_op_sse_reg MOVHLPS fmt v2 v1 + twoAndTwo (0,0) (2,1) (1,0) (3,1) v1 v2 = vector_op_sse UNPCKL fmt v1 v2 + twoAndTwo (1,0) (3,1) (0,0) (2,1) v1 v2 = vector_op_sse UNPCKL fmt v2 v1 + twoAndTwo (0,2) (2,3) (1,2) (3,3) v1 v2 = vector_op_sse UNPCKH fmt v1 v2 + twoAndTwo (1,2) (3,3) (0,2) (2,3) v1 v2 = vector_op_sse UNPCKH fmt v2 v1 + twoAndTwo p0 p1 q0 q1 v1 v2 = + if sse4_1 && all (\(dst,src) -> dst == src) [p0,p1,q0,q1] then + let imm = (1 `shiftL` fst q0) .|. (1 `shiftL` fst q1) + in vector_op_sse (`BLEND` (ImmInt imm)) fmt v1 v2 + else do + let imm = snd p0 .|. (snd p1 `shiftL` 2) .|. (snd q0 `shiftL` 4) .|. (snd q1 `shiftL` 6) + reg <- vector_op_sse (`SHUF` (ImmInt imm)) fmt v1 v2 + exp <- anyReg reg + let code dst = exp dst `appOL` + inplaceShuffle [(fst p0,0),(fst p1,1),(fst q0,2),(fst q1,3)] dst + return $ Any fmt code + + -- Three elements from one vector, the last one from the other vector + threeAndOne p0 p1 p2 q0 v1 v2 + | sse4_1 = do -- Use INSERTPS + exp1 <- getAnyReg v1 + (r2, exp2) <- getSomeReg v2 + let imm2 = (snd q0 `shiftL` 6) .|. (fst q0 `shiftL` 4) + dst <- getNewRegNat fmt + let code = exp1 dst `appOL` exp2 `appOL` + inplaceShuffle [p0,p1,p2,(fst q0,fst q0)] dst `snocOL` + (INSERTPS fmt (ImmInt imm2) (OpReg r2) dst) + return $ Fixed fmt dst code + + | (_, 0) <- q0, 0 `notElem` [snd p0,snd p1,snd p2] = do -- Use MOVSS + exp1 <- getAnyReg v1 + (r2, exp2) <- getSomeReg v2 + dst <- getNewRegNat fmt + let code = exp1 dst `appOL` exp2 `snocOL` + (MOV fmt (OpReg r2) (OpReg dst)) `appOL` + inplaceShuffle [p0,p1,p2,(fst q0,0)] dst + return $ Fixed fmt dst code + + | otherwise = do -- Use two or three SHUFPSs + (r1, exp1) <- getSomeReg v1 + exp2 <- getAnyReg v2 + let makeMask i0 i1 i2 i3 = i0 .|. (i1 `shiftL` 2) .|. (i2 `shiftL` 4) .|. (i3 `shiftL` 6) + let imm1 = makeMask (snd q0) (snd q0) (snd p0) (snd p0) + (imm2, pairs) = + if fst q0 == 1 then + (makeMask 2 1 (snd p1) (snd p2), [(fst p0,0),(fst q0,1),(fst p1,2),(fst p2,3)]) + -- dst <- (dst[2],dst[1],r1[snd p1],r1[snd p2]) = (v1[snd p0],v2[snd q0],v1[snd p1],v1[snd p2]) + -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst + else + (makeMask 0 2 (snd p1) (snd p2), [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)]) + -- dst <- (dst[0],dst[2],r1[snd p1],r1[snd p2]) = (v2[snd q0],v1[snd p0],v1[snd p1],v1[snd p2]) + -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst + dst <- getNewRegNat fmt + let code = exp1 `appOL` exp2 dst `snocOL` + (SHUF fmt (ImmInt imm1) (OpReg r1) dst) `snocOL` -- dst <- (dst[snd q0],dst[snd q0],r1[snd p0],r1[snd p0]) = (v2[snd q0],v2[snd q0],v1[snd p0],v1[snd p0]) + (SHUF fmt (ImmInt imm2) (OpReg r1) dst) `appOL` + inplaceShuffle pairs dst + return $ Fixed fmt dst code + + -- We partition the list of indices into those that refer to the first vector and those that + -- refer to the second, and handle each case depending on the number of indices in each group. + let (from_first, from_second) = partition (\(_dstPos, srcPos) -> srcPos < 4) (zip [0..] is) + case (from_first, map (\(dst, src) -> (dst, src - 4)) from_second) of + ([p0,p1,p2,p3], []) -> oneSource p0 p1 p2 p3 v1 + ([], [q0,q1,q2,q3]) -> oneSource q0 q1 q2 q3 v2 + ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 v1 v2 + ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1 + ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2 + _ -> pprPanic "vector shuffle: cannot occur" (ppr is) + | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is) + + -- Shuffle with AVX instructions. + -- The components above 128 bits are shuffled in the same way as the lower 128 bits. + -- For example, `l == 8 && is == [0,2,5,7]` would represent `shuffleFloatX8# _ _ (# 0#, 2#, 9#, 11#, 4#, 6#, 13#, 15# #)`. + vector_shuffle_float_avx :: Length -- Vector length. 4 for XMM, 8 for YMM, 16 for ZMM. + -> CmmExpr + -> CmmExpr + -> [Int] -- 4-element list of indices + -> NatM Register + vector_shuffle_float_avx l v1 v2 is + | length is == 4, all (\i -> 0 <= i && i < 8) is = do + let fmt = VecFormat l FmtFloat + + -- A helper function to shuffle a vector using (dst,src) pairs + -- (dst[d0],dst[d1],...) <- (r[s0],r[s1],...) + inplaceShuffle pairs r dst = do + let mask = foldl' (\acc (dst,src) -> acc .|. (src `shiftL` (2 * dst))) 0 pairs + case mask of + 0b11_10_01_00 | r == dst -> nilOL + | otherwise -> unitOL (VMOVU fmt (OpReg r) (OpReg dst)) -- trivial + 0b01_00_01_00 | l == 4 -> unitOL (VMOVLHPS fmt r r dst) -- 128-bit only + 0b11_10_11_10 | l == 4 -> unitOL (VMOVHLPS fmt r r dst) -- 128-bit only + 0b01_01_00_00 -> unitOL (VUNPCKL fmt (OpReg r) r dst) + 0b11_11_10_10 -> unitOL (VUNPCKH fmt (OpReg r) r dst) + _ -> unitOL (VSHUF fmt (ImmInt mask) (OpReg r) r dst) + + -- All elements are from one source vector + oneSource p0 p1 p2 p3 v = do + (r, exp) <- getSomeReg v + let code dst = exp `appOL` + inplaceShuffle [p0,p1,p2,p3] r dst + return $ Any fmt code + + -- Two elements from one vector, other two from the other vector + twoAndTwo (0,0) (1,1) (2,0) (3,1) v1 v2 | l == 4 = vector_op_avx_reg VMOVLHPS fmt v1 v2 + twoAndTwo (2,0) (3,1) (0,0) (1,1) v1 v2 | l == 4 = vector_op_avx_reg VMOVLHPS fmt v2 v1 + twoAndTwo (2,2) (3,3) (0,2) (1,3) v1 v2 | l == 4 = vector_op_avx_reg VMOVHLPS fmt v1 v2 + twoAndTwo (0,2) (1,3) (2,2) (3,3) v1 v2 | l == 4 = vector_op_avx_reg VMOVHLPS fmt v2 v1 + twoAndTwo (0,0) (2,1) (1,0) (3,1) v1 v2 = vector_float_op_avx VUNPCKL l W32 v1 v2 + twoAndTwo (1,0) (3,1) (0,0) (2,1) v1 v2 = vector_float_op_avx VUNPCKL l W32 v2 v1 + twoAndTwo (0,2) (2,3) (1,2) (3,3) v1 v2 = vector_float_op_avx VUNPCKH l W32 v1 v2 + twoAndTwo (1,2) (3,3) (0,2) (2,3) v1 v2 = vector_float_op_avx VUNPCKH l W32 v2 v1 + twoAndTwo p0 p1 q0 q1 v1 v2 = + if l <= 8 && all (\(dst,src) -> dst == src) [p0,p1,q0,q1] then + -- VBLENDPS does not support ZMM (no EVEX-encoded variant) + let imm = (1 `shiftL` fst q0) .|. (1 `shiftL` fst q1) + imm' = if l == 4 then imm .|. (imm `shiftL` 4) else imm + in vector_float_op_avx (`VBLEND` (ImmInt imm')) l W32 v1 v2 + else do + let imm1 = snd p0 .|. (snd p1 `shiftL` 2) .|. (snd q0 `shiftL` 4) .|. (snd q1 `shiftL` 6) + reg <- vector_float_op_avx (`VSHUF` (ImmInt imm1)) l W32 v1 v2 + exp <- anyReg reg + let code dst = exp dst `appOL` + inplaceShuffle [(fst p0,0),(fst p1,1),(fst q0,2),(fst q1,3)] dst dst + return $ Any fmt code + + -- Three elements from one vector, the last one from the other vector + threeAndOne p0 p1 p2 q0 v1 v2 + | l == 4, (_, 0) <- q0, 0 `notElem` [snd p0,snd p1,snd p2] = do -- Use VMOVSS (128-bit only) + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + let code dst = exp1 `appOL` exp2 `snocOL` + (VMOV_MERGE fmt r2 r1 dst) `appOL` + inplaceShuffle [p0,p1,p2,(fst q0,0)] dst dst + return $ Any fmt code + + | l == 4 = do -- Use VINSERTPS (128-bit only) + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + let i = case [0, 1, 2, 3] \\ [snd p0, snd p1, snd p2] of + i:_ -> i -- We can clobber this position of r1 + _ -> panic "cannot occur" + imm = (snd q0 `shiftL` 6) .|. (i `shiftL` 4) + code dst = exp1 `appOL` exp2 `snocOL` + (VINSERTPS fmt (ImmInt imm) (OpReg r2) r1 dst) `appOL` + inplaceShuffle [p0,p1,p2,(fst q0,i)] dst dst + return $ Any fmt code + + | otherwise = do -- Use two or three VSHUFPSs + (r1, exp1) <- getSomeReg v1 + exp2 <- getAnyReg v2 + let makeMask i0 i1 i2 i3 = i0 .|. (i1 `shiftL` 2) .|. (i2 `shiftL` 4) .|. (i3 `shiftL` 6) + let imm1 = makeMask (snd q0) (snd q0) (snd p0) (snd p0) + (imm2, pairs) = + if fst q0 == 1 then + (makeMask 2 1 (snd p1) (snd p2), [(fst p0,0),(fst q0,1),(fst p1,2),(fst p2,3)]) + -- dst <- (dst[2],dst[1],r1[snd p1],r1[snd p2]) = (v1[snd p0],v2[snd q0],v1[snd p1],v1[snd p2]) + -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst + else + (makeMask 0 2 (snd p1) (snd p2), [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)]) + -- dst <- (dst[0],dst[2],r1[snd p1],r1[snd p2]) = (v2[snd q0],v1[snd p0],v1[snd p1],v1[snd p2]) + -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst + dst <- getNewRegNat fmt + let code = exp1 `appOL` exp2 dst `snocOL` + (VSHUF fmt (ImmInt imm1) (OpReg r1) dst dst) `snocOL` -- dst <- (dst[snd q0],dst[snd q0],r1[snd p0],r1[snd p0]) = (v2[snd q0],v2[snd q0],v1[snd p0],v1[snd p0]) + (VSHUF fmt (ImmInt imm2) (OpReg r1) dst dst) `appOL` + inplaceShuffle pairs dst dst + return $ Fixed fmt dst code + + -- We partition the list of indices into those that refer to the first vector and those that + -- refer to the second, and handle each case depending on the number of indices in each group. + let (from_first, from_second) = partition (\(_dstPos, srcPos) -> srcPos < 4) (zip [0..] is) + case (from_first, map (\(dst, src) -> (dst, src - 4)) from_second) of + ([p0,p1,p2,p3], []) -> oneSource p0 p1 p2 p3 v1 + ([], [q0,q1,q2,q3]) -> oneSource q0 q1 q2 q3 v2 + ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 v1 v2 + ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1 + ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2 + _ -> pprPanic "vector shuffle: cannot occur" (ppr is) + | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is) + + vector_shuffle_doublex2_sse :: CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_doublex2_sse v1 v2 is + | [i0, i1] <- is = + let fmt = VecFormat 2 FmtDouble + in case (i0, i1) of + -- Trivial cases + (0, 1) -> getRegister' platform is32Bit v1 + (2, 3) -> getRegister' platform is32Bit v2 + + -- MOVSD/UNPCKLPD/UNPCKHPD have shorter encoding than SHUFPD + -- If SSE4.1 is available, BLENDPD could also be used in place of MOVSD (the encoding is longer though) + (0, 3) -> vector_op_sse (\_ src -> MOV fmt src . OpReg) fmt v2 v1 -- MOVSD + (2, 1) -> vector_op_sse (\_ src -> MOV fmt src . OpReg) fmt v1 v2 -- MOVSD + _ | i0 == i1 -> do + exp <- getAnyReg (if i0 <= 1 then v1 else v2) + let unpck = if i0 == 0 || i0 == 2 + then UNPCKL + else UNPCKH + code dst = exp dst `snocOL` + (unpck fmt (OpReg dst) dst) + return (Any fmt code) + (0, 2) -> vector_op_sse UNPCKL fmt v1 v2 + (2, 0) -> vector_op_sse UNPCKL fmt v2 v1 + (1, 3) -> vector_op_sse UNPCKH fmt v1 v2 + (3, 1) -> vector_op_sse UNPCKH fmt v2 v1 + + -- SHUFPD + (1, 2) -> vector_op_sse (`SHUF` (ImmInt 0b01)) fmt v1 v2 + (3, 0) -> vector_op_sse (`SHUF` (ImmInt 0b01)) fmt v2 v1 + (1, 0) -> do + exp <- getAnyReg v1 + let code dst = exp dst `snocOL` + (SHUF fmt (ImmInt 0b01) (OpReg dst) dst) + return (Any fmt code) + (3, 2) -> do + exp <- getAnyReg v2 + let code dst = exp dst `snocOL` + (SHUF fmt (ImmInt 0b01) (OpReg dst) dst) + return (Any fmt code) + _ -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 3" (ppr is) + | otherwise = pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is) + + -- Shuffle with AVX instructions. + -- The components above 128 bits are shuffled in the same way as the lower 128 bits. + -- For example, `l == 4 && is == [0,3]` would represent `shuffleDoubleX4# _ _ (# 0#, 5#, 2#, 7# #)`. + vector_shuffle_double_avx :: Length -- Vector length. 2 for XMM, 4 for YMM, 8 for ZMM. + -> CmmExpr + -> CmmExpr + -> [Int] -- 2-element list of indices + -> NatM Register + vector_shuffle_double_avx l v1 v2 is + | [i0, i1] <- is = + let fmt = VecFormat l FmtDouble + repeatShufpdMask m = case l of + 8 -> m .|. (m `shiftL` 2) .|. (m `shiftL` 4) .|. (m `shiftL` 6) + 4 -> m .|. (m `shiftL` 2) + _ -> m + in case (i0, i1) of + -- Trivial cases + (0, 1) -> getRegister' platform is32Bit v1 + (2, 3) -> getRegister' platform is32Bit v2 + + -- VMOVSD/VUNPCKLPD/VUNPCKHPD have shorter encoding than VSHUFPD + (0, 3) | l == 2 -> do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + let code dst = exp1 `appOL` exp2 `snocOL` + (VMOV_MERGE fmt r1 r2 dst) -- VMOVSD + return (Any fmt code) + | otherwise -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b10)) l W64 v1 v2 + (2, 1) | l == 2 -> do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + let code dst = exp1 `appOL` exp2 `snocOL` + (VMOV_MERGE fmt r2 r1 dst) -- VMOVSD + return (Any fmt code) + | otherwise -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b10)) l W64 v2 v1 + _ | i0 == i1 -> do + (r, exp) <- getSomeReg (if i0 <= 1 then v1 else v2) + let unpck = if i0 == 0 || i0 == 2 + then VUNPCKL + else VUNPCKH + code dst = exp `snocOL` + (unpck fmt (OpReg r) r dst) + return (Any fmt code) + (0, 2) -> vector_float_op_avx VUNPCKL l W64 v1 v2 + (2, 0) -> vector_float_op_avx VUNPCKL l W64 v2 v1 + (1, 3) -> vector_float_op_avx VUNPCKH l W64 v1 v2 + (3, 1) -> vector_float_op_avx VUNPCKH l W64 v2 v1 + + -- SHUFPD + (1, 2) -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b01)) l W64 v1 v2 + (3, 0) -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b01)) l W64 v2 v1 + (1, 0) -> do + (r, exp) <- getSomeReg v1 + let code dst = exp `snocOL` + (VSHUF fmt (ImmInt $ repeatShufpdMask 0b01) (OpReg r) r dst) + return (Any fmt code) + (3, 2) -> do + (r, exp) <- getSomeReg v2 + let code dst = exp `snocOL` + (VSHUF fmt (ImmInt $ repeatShufpdMask 0b01) (OpReg r) r dst) + return (Any fmt code) + _ -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 3" (ppr is) + | otherwise = pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is) + + isZeroVecLit :: CmmExpr -> Bool + isZeroVecLit (CmmLit (CmmVec elems)) = all (\lit -> case lit of CmmInt 0 _ -> True; _ -> False) elems + isZeroVecLit _ = False + + vector_shuffle_int128_common :: Bool -> Format -> CmmExpr -> CmmExpr -> [Int] -> Maybe (NatM Register) + vector_shuffle_int128_common sse4_1 fmt v1 v2 is + | length is == n, all (\i -> 0 <= i && i < 2 * n) is = if + -- Trivial cases + | is == [0..n-1] -> Just $ getRegister' platform is32Bit v1 + | is == [n..2*n-1] -> Just $ getRegister' platform is32Bit v2 + + -- We would like to emit PXOR for these trivial cases, instead of PSLLDQ. + -- These conditions can be generalized to the cases where all elements are equal, + -- or more generally, a constant-folding rule. + | v1IsZero, all (< n) is -> Just $ getRegister' platform is32Bit v1 + | v2IsZero, all (>= n) is -> Just $ getRegister' platform is32Bit v2 + + -- PSLLDQ: v2 == 0 && is == [n..(2n-1),...,n..(2n-1);0,1,2,3,...,n-i-1] + | v2IsZero, (z, js) <- span (>= n) is, and (zipWith (==) js [0..]) -> Just $ do + exp1 <- getAnyReg v1 + let code dst = exp1 dst `snocOL` + (PSLLDQ fmt (ImmInt (widthInBytes * length z)) dst) + return (Any fmt code) + + -- PSLLDQ: v1 == 0 && is == [0..(n-1),...,0..(n-1);n,n+1,...,2n-i-1] + | v1IsZero, (z, js) <- span (< n) is, and (zipWith (==) js [n..]) -> Just $ do + exp2 <- getAnyReg v2 + let code dst = exp2 dst `snocOL` + (PSLLDQ fmt (ImmInt (widthInBytes * length z)) dst) + return (Any fmt code) + + -- PSRLDQ: v2 == 0 && is == [i,i+1,...,n-2,n-1;n..(2n-1),...,n..(2n-1)] + | v2IsZero, (js, z) <- span (< n) is, all (>= n) z, and (zipWith (==) (reverse js) [n-1,n-2..]) -> Just $ do + exp1 <- getAnyReg v1 + let code dst = exp1 dst `snocOL` + (PSRLDQ fmt (ImmInt (widthInBytes * length z)) dst) + return (Any fmt code) + + -- PSRLDQ: v1 == 0 && is == [n+i,...,2n-2,2n-1;0..(n-1),...,0..(n-1)] + | v1IsZero, (js, z) <- span (>= n) is, all (< n) z, and (zipWith (==) (reverse js) [2*n-1,2*n-2..]) -> Just $ do + exp2 <- getAnyReg v2 + let code dst = exp2 dst `snocOL` + (PSRLDQ fmt (ImmInt (widthInBytes * length z)) dst) + return (Any fmt code) + + -- PALIGNR (SSSE3) or PSLLDQ + PSRLDQ: is == [i,i+1,...,n-2,n-1;n,n+1,...,n+i-1] + | (js, ks) <- span (< n) is, and (zipWith (==) (reverse js) [n-1,n-2..]), and (zipWith (==) ks [n..]) -> Just $ do + ssse3 <- ssse3Enabled + let amountInBytes = widthInBytes * length ks + if ssse3 + then vector_op_sse (`PALIGNR` (ImmInt amountInBytes)) fmt v2 v1 + else do + exp1 <- getAnyReg v1 + exp2 <- getAnyReg v2 + tmp <- getNewRegNat fmt + let code dst = exp1 tmp `snocOL` + (PSRLDQ fmt (ImmInt amountInBytes) tmp) `appOL` + exp2 dst `snocOL` + (PSLLDQ fmt (ImmInt (16 - amountInBytes)) dst) `snocOL` + (POR fmt (OpReg tmp) dst) + return (Any fmt code) + + -- PALIGNR (SSSE3) or PSLLDQ + PSRLDQ: is == [n+i,n+i+1,...,2n-2,2n-1;0,1,...,i-1] + | (js, ks) <- span (>= n) is, and (zipWith (==) (reverse js) [2*n-1,2*n-2..]), and (zipWith (==) ks [0..]) -> Just $ do + ssse3 <- ssse3Enabled + let amountInBytes = widthInBytes * length ks + if ssse3 + then vector_op_sse (`PALIGNR` (ImmInt amountInBytes)) fmt v1 v2 + else do + exp1 <- getAnyReg v1 + exp2 <- getAnyReg v2 + tmp <- getNewRegNat fmt + let code dst = exp2 tmp `snocOL` + (PSRLDQ fmt (ImmInt amountInBytes) tmp) `appOL` + exp1 dst `snocOL` + (PSLLDQ fmt (ImmInt (16 - amountInBytes)) dst) `snocOL` + (POR fmt (OpReg tmp) dst) + return (Any fmt code) + + -- PBLENDW (SSE4.1): map (`mod` n) is == [0,1,...,n-1] if widthInBytes >= 2 + | sse4_1, widthInBytes >= 2, and (zipWith (\i j -> i `rem` n == j) is [0..]) -> Just $ do + let k = widthInBytes `quot` 2 + m = bit k - 1 + imm = foldr (\i acc -> if i >= n then (acc `shiftL` k) .|. m else acc `shiftL` k) 0 is + vector_op_sse (`PBLENDW` (ImmInt imm)) fmt v1 v2 + + | otherwise -> Nothing + + | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is) + where + (n, widthInBytes) = case fmt of + VecFormat 16 FmtInt8 -> (16, 1) + VecFormat 8 FmtInt16 -> (8, 2) + VecFormat 4 FmtInt32 -> (4, 4) + VecFormat 2 FmtInt64 -> (2, 8) + _ -> pprPanic "Invalid format" (ppr fmt) + v1IsZero = isZeroVecLit v1 + v2IsZero = isZeroVecLit v2 + + vector_shuffle_int8x16 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_int8x16 sse4_1 v1 v2 is + | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase + | otherwise = do + ssse3 <- ssse3Enabled + let fmtInt16X8 = VecFormat 8 FmtInt16 + v1IsZero = isZeroVecLit v1 + v2IsZero = isZeroVecLit v2 + tryInt16X8Mask [] = Just [] + tryInt16X8Mask (j0:j1:js) + | even j0, j1 == j0 + 1 = (j0 `quot` 2 :) <$> tryInt16X8Mask js + tryInt16X8Mask _ = Nothing + if + -- PUNPCKLBW / PUNPCKHBW + | [0,16,1,17,2,18,3,19,4,20,5,21,6,22,7,23] <- is -> vector_op_sse PUNPCKLBW fmt v1 v2 + | [16,0,17,1,18,2,19,3,20,4,21,5,22,6,23,7] <- is -> vector_op_sse PUNPCKLBW fmt v2 v1 + | [8,24,9,25,10,26,11,27,12,28,13,29,14,30,15,31] <- is -> vector_op_sse PUNPCKHBW fmt v1 v2 + | [24,8,25,9,26,10,27,11,28,12,29,13,30,14,31,15] <- is -> vector_op_sse PUNPCKHBW fmt v2 v1 + + -- PSHUFB (SSSE3) + | ssse3, all (< 16) is || v2IsZero -> do + exp1 <- getAnyReg v1 + let mask1 = CmmVec $ map (\i -> CmmInt (toInteger $ if i < 16 then i else 255) W8) is + Amode amode1 amode_code1 <- memConstant (mkAlignment 16) mask1 + let code dst = exp1 dst `appOL` + amode_code1 `snocOL` + (PSHUFB fmt (OpAddr amode1) dst) + return (Any fmt code) + + -- PSHUFB (SSSE3) + | ssse3, all (>= 16) is || v1IsZero -> do + exp2 <- getAnyReg v2 + let mask2 = CmmVec $ map (\i -> CmmInt (toInteger $ if i >= 16 then i - 16 else 255) W8) is + Amode amode2 amode_code2 <- memConstant (mkAlignment 16) mask2 + let code dst = exp2 dst `appOL` + amode_code2 `snocOL` + (PSHUFB fmt (OpAddr amode2) dst) + return (Any fmt code) + + -- PBLENDW (SSE4.1): js <- tryInt16X8Mask is, map (`mod` 8) js == [0,1,...,7] + | sse4_1, Just js <- tryInt16X8Mask is, and (zipWith (\i j -> i `rem` 8 == j) js [0..]) -> do + let imm = foldr (\i acc -> if i >= 8 then (acc `shiftL` 1) .|. 1 else acc `shiftL` 1) 0 js + vector_op_sse (`PBLENDW` (ImmInt imm)) fmt v1 v2 + + -- General case with SSSE3: PSHUFB + PSHUFB + POR + | ssse3 -> do + exp1 <- getAnyReg v1 + exp2 <- getAnyReg v2 + tmp1 <- getNewRegNat fmt + let mask1 = CmmVec $ map (\i -> CmmInt (toInteger $ if i < 16 then i else 255) W8) is + mask2 = CmmVec $ map (\i -> CmmInt (toInteger $ if i >= 16 then i - 16 else 255) W8) is + Amode amode1 amode_code1 <- memConstant (mkAlignment 16) mask1 + Amode amode2 amode_code2 <- memConstant (mkAlignment 16) mask2 + let code dst = exp1 tmp1 `appOL` exp2 dst `appOL` + amode_code1 `snocOL` + (PSHUFB fmt (OpAddr amode1) tmp1) `appOL` + amode_code2 `snocOL` + (PSHUFB fmt (OpAddr amode2) dst) `snocOL` + (POR fmt (OpReg tmp1) dst) + return (Any fmt code) + + -- General case with SSE2: GPR + MOVQ + PUNPCKLQDQ + | otherwise -> do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + tmp <- getNewRegNat II64 + tmpLo <- getNewRegNat II64 + tmpHi <- getNewRegNat II64 + tmpXmm <- getNewRegNat fmt + dst <- getNewRegNat fmt + let place8Bits srcPos dstPos dst = + -- Assumption: 0 <= srcPos < 32, 0 <= dstPos < 8 + -- tmp <- (src[srcPos] `shiftR` ((srcPos `rem` 16) * 8)) .&. 0xff + -- dst <- dst .|. (tmp `shiftL` (dstPos * 8)) + let r = if srcPos < 16 then r1 else r2 + in case (srcPos `rem` 16) `quotRem` 2 of + (k, 0) -> toOL [ PEXTR II32 fmtInt16X8 (ImmInt k) r (OpReg tmp) + , MOVZxL II8 (OpReg tmp) (OpReg tmp) + , SHL II64 (OpImm (ImmInt (8 * dstPos))) (OpReg tmp) + , OR II64 (OpReg tmp) (OpReg dst) + ] + (k, _) -> (PEXTR II32 fmtInt16X8 (ImmInt k) r (OpReg tmp)) `consOL` + ((case dstPos of + 0 -> unitOL (SHR II32 (OpImm (ImmInt 8)) (OpReg tmp)) + 1 -> unitOL (AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp)) + _ -> toOL [ AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp) + , SHL II64 (OpImm (ImmInt (8 * (dstPos - 1)))) (OpReg tmp) ]) `snocOL` + (OR II64 (OpReg tmp) (OpReg dst))) + makeInt8x8OnGPR dst js = (XOR II32 (OpReg dst) (OpReg dst)) `consOL` + concatOL [ place8Bits srcPos dstPos dst | (srcPos, dstPos) <- zip js [0..] ] + code = exp1 `appOL` exp2 `appOL` + makeInt8x8OnGPR tmpLo (take 8 is) `snocOL` + (MOVD II64 fmt (OpReg tmpLo) (OpReg dst)) `appOL` + makeInt8x8OnGPR tmpHi (drop 8 is) `snocOL` + (MOVD II64 fmt (OpReg tmpHi) (OpReg tmpXmm)) `snocOL` + (PUNPCKLQDQ fmt (OpReg tmpXmm) dst) + return (Fixed fmt dst code) + where fmt = VecFormat 16 FmtInt8 + + vector_shuffle_int16x8 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_int16x8 sse4_1 v1 v2 is@(i0:i1:i2:i3:i4567@[i4,i5,i6,i7]) + | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase + | otherwise = do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + let -- shufL src dst k0 k1 k2 k3 (0 <= k_i < 4): + -- dst <- (src[k0],src[k1],src[k2],src[k3],src[4],src[5],src[6],src[7]) + shufL src dst 0 1 2 3 | src == dst = nilOL + | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst)) + shufL src dst k0 k1 k2 k3 = let imm = k0 + (k1 `shiftL` 2) + (k2 `shiftL` 4) + (k3 `shiftL` 6) + in unitOL (PSHUFLW fmt (ImmInt imm) (OpReg src) dst) + -- shufH src dst k0 k1 k2 k3 (4 <= k_i < 8): + -- dst <- (src[0],src[1],src[2],src[3],src[k0],src[k1],src[k2],src[k3]) + shufH src dst 4 5 6 7 | src == dst = nilOL + | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst)) + shufH src dst k0 k1 k2 k3 = let imm = (k0 - 4) + ((k1 - 4) `shiftL` 2) + ((k2 - 4) `shiftL` 4) + ((k3 - 4) `shiftL` 6) + in unitOL (PSHUFHW fmt (ImmInt imm) (OpReg src) dst) + + shufLHImm src dst immLo immHi = case (immLo, immHi) of + (0b11_10_01_00, 0b11_10_01_00) + | src == dst -> nilOL + | otherwise -> unitOL (MOVDQU fmt (OpReg src) (OpReg dst)) + (0b11_10_01_00, _) -> unitOL (PSHUFHW fmt (ImmInt immHi) (OpReg src) dst) + (_, 0b11_10_01_00) -> unitOL (PSHUFLW fmt (ImmInt immLo) (OpReg src) dst) + (_, _) -> toOL [PSHUFLW fmt (ImmInt immLo) (OpReg src) dst, + PSHUFHW fmt (ImmInt immHi) (OpReg dst) dst] + + -- ks = [k0,...,k7] + -- Assumption: 0 <= k_i < 4 for 0 <= i < 4, 4 <= k_i < 8 for 4 <= i < 8 + -- dst <- (src[k0],...,src[k7]) + shufLH src dst ks + = let (k_lo, k_hi) = splitAt 4 ks + immLo = foldr (\k acc -> (acc `shiftL` 2) + k) 0 k_lo + immHi = foldr (\k acc -> (acc `shiftL` 2) + (k - 4)) 0 k_hi + in shufLHImm src dst immLo immHi + + -- shufRev src dst j0 j1 j2 j3 j4 j5 j6 j7: + -- Assumption: [j0,j1,j2,j3] `elem` permutations [0,1,2,3] && [j4,j5,j6,j7] `elem` permutations [4,5,6,7]: + -- dst[j0] <- src[0]; dst[j1] <- src[1]; dst[j2] <- src[2]; dst[j3] <- src[3]; + -- dst[j4] <- src[4]; dst[j5] <- src[5]; dst[j6] <- src[6]; dst[j7] <- src[7]; + shufRev src dst _j0 j1 j2 j3 _j4 j5 j6 j7 + = let immLo = (1 `shiftL` (2 * j1)) + (2 `shiftL` (2 * j2)) + (3 `shiftL` (2 * j3)) + immHi = (1 `shiftL` (2 * (j5 - 4))) + (2 `shiftL` (2 * (j6 - 4))) + (3 `shiftL` (2 * (j7 - 4))) + in shufLHImm src dst immLo immHi + i0123 = [i0, i1, i2, i3] + if + -- PSHUFLW + PSHUFHW + | all (\i -> i < 4) i0123 + , all (\i -> 4 <= i && i < 8) i4567 + -> do + let code dst = exp1 `appOL` + shufLH r1 dst is + return (Any fmt code) + + -- PSHUFLW + PSHUFHW + | all (\i -> 8 <= i && i < 12) i0123 + , all (\i -> 12 <= i) i4567 + -> do + let code dst = exp2 `appOL` + shufLH r2 dst (map (subtract 8) is) + return (Any fmt code) + + -- PSHUF{L,H}W + PBLENDW (SSE4.1) + | sse4_1 + , all (\i -> i `rem` 8 < 4) i0123 + , all (\i -> 4 <= i `rem` 8) i4567 + -> do + tmp <- getNewRegNat fmt + let imm = foldl' (\acc (i,p) -> if i >= 8 then setBit acc p else acc) 0 (zip is [0..]) + js = zipWith (\i p -> if i >= 8 then p else i) is [0..] + ks = zipWith (\i p -> if i >= 8 then i - 8 else p) is [0..] + code dst = exp1 `appOL` exp2 `appOL` + shufLH r2 tmp ks `appOL` + shufLH r1 dst js `snocOL` + (PBLENDW fmt (ImmInt imm) (OpReg tmp) dst) + return (Any fmt code) + + -- PSHUFLW + PSHUFLW + PUNPCKLWD + PSHUFLW + PSHUFHW + | all (\i -> i < 4 || (8 <= i && i < 12)) is + , ([(j0, k0), (j1, k1)], [(j2, k2), (j3, k3)]) <- partition (\(_, i) -> i < 4) [(0, i0), (1, i1), (2, i2), (3, i3)] + , ([(j4, k4), (j5, k5)], [(j6, k6), (j7, k7)]) <- partition (\(_, i) -> i < 4) [(4, i4), (5, i5), (6, i6), (7, i7)] + -> do + tmp1 <- getNewRegNat fmt + tmp2 <- getNewRegNat fmt + let code dst = exp1 `appOL` exp2 `appOL` + shufL r1 tmp1 k0 k1 k4 k5 `appOL` + shufL r2 tmp2 (k2 - 8) (k3 - 8) (k6 - 8) (k7 - 8) `snocOL` + (PUNPCKLWD fmt (OpReg tmp2) tmp1) `appOL` + shufRev tmp1 dst j0 j2 j1 j3 j4 j6 j5 j7 + return (Any fmt code) + + -- PSHUFHW + PSHUFHW + PUNPCKHWD + PSHUFLW + PSHUFHW + | all (\i -> (4 <= i && i < 8) || 12 <= i) is + , ([(j0, k0), (j1, k1)], [(j2, k2), (j3, k3)]) <- partition (\(_, i) -> i < 8) [(0, i0), (1, i1), (2, i2), (3, i3)] + , ([(j4, k4), (j5, k5)], [(j6, k6), (j7, k7)]) <- partition (\(_, i) -> i < 8) [(4, i4), (5, i5), (6, i6), (7, i7)] + -> do + tmp1 <- getNewRegNat fmt + tmp2 <- getNewRegNat fmt + let code dst = exp1 `appOL` exp2 `appOL` + shufH r1 tmp1 k0 k1 k4 k5 `appOL` + shufH r2 tmp2 (k2 - 8) (k3 - 8) (k6 - 8) (k7 - 8) `snocOL` + (PUNPCKHWD fmt (OpReg tmp2) tmp1) `appOL` + shufRev tmp1 dst j0 j2 j1 j3 j4 j6 j5 j7 + return (Any fmt code) + + -- Generic implementation + | otherwise -> do + tmp0 <- getNewRegNat II32 + tmps <- replicateM 7 (getNewRegNat II32) + let code dst = exp1 `appOL` exp2 `appOL` + toOL [ PEXTR II32 fmt (ImmInt i') r (OpReg tmp) + | (i, tmp) <- zip is (tmp0:tmps) + , let (i', r) = if i < 8 then (i, r1) else (i - 8, r2) + ] `snocOL` + (MOVD II32 fmt (OpReg tmp0) (OpReg dst)) `appOL` + toOL [ PINSR II32 fmt (ImmInt i) (OpReg tmp) dst + | (i, tmp) <- zip [1..] tmps + ] + return (Any fmt code) + where fmt = VecFormat 8 FmtInt16 + vector_shuffle_int16x8 _ _ _ is = pprPanic "vector shuffle: wrong number of indices (expected 8)" (ppr is) + + vector_shuffle_int32x4 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_int32x4 sse4_1 v1 v2 is + | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase + | otherwise = do + let -- `pshufd imm src dst` is equivalent to `PSHUFD fmt (ImmInt imm) (OpReg src) dst` + pshufd 0b11_10_01_00 src dst + | src == dst = nilOL + | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst)) + pshufd imm src dst = unitOL (PSHUFD fmt (ImmInt imm) (OpReg src) dst) + + -- PSHUFD (composeImm imm1 imm2) src dst == (PSHUFD imm1 src tmp; PSHUFD imm2 tmp dst) + composeMask :: Int -> Int -> Int + composeMask imm1 imm2 = foldr (\i acc -> let j = (imm2 `shiftR` (2 * i)) .&. 3 + in (imm1 `shiftR` (2 * j) .&. 3) .|. (acc `shiftL` 2) + ) 0 [0..3] + + makeMask :: [(Int, Int)] -- List of (dst,src). If src == -1, the value there can be anything. + -> Int + makeMask m = foldl' (.|.) 0 [ src `shiftL` (2 * dst) | dst <- [0..3], let src = fromMaybe dst (mfilter (>= 0) $ lookup dst m) ] + + twoAndTwo p0@(1,_) p1@(3,_) q0@(0,_) q1@(2,_) imm4 v1 v2 = twoAndTwo' q0 q1 p0 p1 imm4 v2 v1 + twoAndTwo p0 p1 q0 q1 imm4 v1 v2 = twoAndTwo' p0 p1 q0 q1 imm4 v1 v2 + twoAndTwo' p0 p1 q0 q1 imm4 v1 v2 = do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + tmp <- getNewRegNat fmt + let (instr, imm1, imm2) = + if all (\(_,i) -> 2 <= i || i == -1) [p0,p1,q0,q1] then + -- The inputs are all from higher lanes + (PUNPCKHDQ, makeMask [(2,snd p0),(3,snd p1)], makeMask [(2,snd q0),(3,snd q1)]) + else + (PUNPCKLDQ, makeMask [(0,snd p0),(1,snd p1)], makeMask [(0,snd q0),(1,snd q1)]) + imm3 = makeMask [(fst p0,0),(fst q0,1),(fst p1,2),(fst q1,3)] + code dst = exp1 `appOL` exp2 `appOL` + pshufd imm2 r2 tmp `appOL` -- tmp <- (*,*,r2[snd q0],r2[snd q1]) or (r2[snd q0],r2[snd q1],*,*) + pshufd imm1 r1 dst `snocOL` -- dst <- (*,*,r1[snd p0],r1[snd p1]) or (r1[snd p0],r1[snd p1],*,*) + instr fmt (OpReg tmp) dst `appOL` -- dst <- (dst[0],tmp[0],dst[1],tmp[1]) = (r1[snd p0],r2[snd q0],r1[snd p1],r2[snd q1]) + pshufd (composeMask imm3 imm4) dst dst -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst q1]) <- dst + return $ Any fmt code + + threeAndOne p0 p1 p2 q0 + | snd p0 == snd p1 = twoAndTwo p0 p2 q0 (fst p1,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p0),(fst p2,fst p2),(fst q0,fst q0)]) + | snd p0 == snd p2 = twoAndTwo p0 p1 q0 (fst p2,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p1),(fst p2,fst p0),(fst q0,fst q0)]) + | snd p1 == snd p2 = twoAndTwo p0 p1 q0 (fst p2,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p1),(fst p2,fst p1),(fst q0,fst q0)]) + | otherwise = \v1 v2 -> do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + tmp1 <- getNewRegNat fmt + if sse4_1 + then do + let imm1 = makeMask [p0,p1,p2] + imm2 = makeMask [q0] + imm3 = foldl' (.|.) 0 [ (if i == fst q0 then 0 else 3) `shiftL` (2 * i) | i <- [0..3] ] + let code dst = exp1 `appOL` exp2 `appOL` + pshufd imm1 r1 tmp1 `appOL` + pshufd imm2 r2 dst `snocOL` + PBLENDW fmt (ImmInt imm3) (OpReg tmp1) dst + return $ Any fmt code + else do + tmp2 <- getNewRegNat fmt + tmp3 <- getNewRegNat fmt + let imm1 = snd q0 .|. 0b11_10_01_00 + imm2 = snd p1 .|. 0b11_10_01_00 + imm3 = snd p0 .|. (snd p2 `shiftL` 2) .|. 0b11_10_00_00 + imm6 = makeMask [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)] + code dst = exp1 `appOL` exp2 `appOL` + pshufd imm1 r2 tmp1 `appOL` -- tmp1 <- (y0,*,*,*) + pshufd imm2 r1 tmp2 `appOL` -- tmp2 <- (x1,*,*,*) + pshufd imm3 r1 tmp3 `snocOL` -- tmp3 <- (x0,x2,*,*) + PUNPCKLDQ fmt (OpReg tmp2) tmp1 `snocOL` -- tmp1 <- unpckldq tmp1 tmp2 = (y0,x1,*,*) + PUNPCKLDQ fmt (OpReg tmp3) tmp1 `appOL` -- tmp1 <- unpckldq tmp1 tmp3 = (y0,x0,x1,x2) + pshufd imm6 tmp1 dst -- dst <- shuffle tmp1 + return $ Any fmt code + + let (from_first, from_second) = partition (\(_dstPos,srcPos) -> srcPos < 4) (zip [0..] is) + case (from_first, map (\(dstPos,srcPos) -> (dstPos, srcPos - 4)) from_second) of + ([p0,p1,p2,p3], []) -> do + (r, exp) <- getSomeReg v1 + let imm = makeMask [p0,p1,p2,p3] + code dst = exp `appOL` pshufd imm r dst + return $ Any fmt code + + ([], [q0,q1,q2,q3]) -> do + (r, exp) <- getSomeReg v2 + let imm = makeMask [q0,q1,q2,q3] + code dst = exp `appOL` pshufd imm r dst + return $ Any fmt code + + ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 0b11_10_01_00 v1 v2 + ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1 + ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2 + + _ -> pprPanic "vector shuffle: cannot occur" (ppr is) + where fmt = VecFormat 4 FmtInt32 + + vector_shuffle_int64x2 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_int64x2 sse4_1 v1 v2 is + | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase + | otherwise = case is of + -- PUNPCKLQDQ / PUNPCKHQDQ + [i, i'] | i == i' -> do + exp <- getAnyReg $ if i < 2 then v1 else v2 + let instr = if i == 0 || i == 2 + then PUNPCKLQDQ + else PUNPCKHQDQ + code dst = exp dst `snocOL` + (instr fmt (OpReg dst) dst) + return $ Any fmt code + [0, 2] -> vector_op_sse PUNPCKLQDQ fmt v1 v2 + [2, 0] -> vector_op_sse PUNPCKLQDQ fmt v2 v1 + [1, 3] -> vector_op_sse PUNPCKHQDQ fmt v1 v2 + [3, 1] -> vector_op_sse PUNPCKHQDQ fmt v2 v1 + + -- PSHUFD + [1, 0] -> do + (r1, exp1) <- getSomeReg v1 + let code dst = exp1 `snocOL` + (PSHUFD fmt (ImmInt 0b01_00_11_10) (OpReg r1) dst) + return $ Any fmt code + [3, 2] -> do + (r2, exp2) <- getSomeReg v2 + let code dst = exp2 `snocOL` + (PSHUFD fmt (ImmInt 0b01_00_11_10) (OpReg r2) dst) + return $ Any fmt code + + -- Others: + -- If SSE4.1 is available, use PBLENDW (see vector_shuffle_int128_common). + -- Otherwise, we resort to SHUFPD. + [0, 3] -> vector_op_sse (\_ -> SHUF doubleFormat (ImmInt 2)) fmt v1 v2 + [2, 1] -> vector_op_sse (\_ -> SHUF doubleFormat (ImmInt 2)) fmt v2 v1 + + -- [0, 1], [2, 3], [1, 2], [3, 0] are covered by the common cases + + -- Indices are checked in vector_shuffle_int128_common, so the following line should be unreachable: + _ -> pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is) + where fmt = VecFormat 2 FmtInt64 + doubleFormat = VecFormat 2 FmtDouble + + +getRegister' platform _is32Bit (CmmMachOp mop [x, y, z]) = do -- ternary MachOps + avx <- avxEnabled + sse4_1 <- sse4_1Enabled + case mop of + -- Floating point fused multiply-add operations @ ± x*y ± z@ + MO_FMA var l w + | l * widthInBits w > 256 + -> sorry "Please use -fllvm for wide vector FMA support" + | otherwise + -> genFMA3Code l w var x y z + + -- Ternary vector operations + MO_VF_Insert l W32 | l == 4 -> vector_floatx4_insert_sse sse4_1 x y z + | otherwise -> + sorry $ "FloatX" ++ show l ++ "# insert operations require -fllvm" + -- SIMD NCG TODO: + -- + -- - add support for FloatX8, FloatX16. + MO_VF_Insert l W64 -> vector_double_insert avx l x y z + MO_V_Insert 16 W8 | sse4_1 -> vector_int_insert_pinsr 16 W8 x y z + | otherwise -> vector_int8x16_insert_sse2 x y z + MO_V_Insert 8 W16 -> vector_int_insert_pinsr 8 W16 x y z -- PINSRW (SSE2) + MO_V_Insert 4 W32 | sse4_1 -> vector_int_insert_pinsr 4 W32 x y z + | otherwise -> vector_int32x4_insert_sse2 x y z + MO_V_Insert 2 W64 | sse4_1 -> vector_int_insert_pinsr 2 W64 x y z + | otherwise -> vector_int64x2_insert_sse2 x y z + MO_V_Insert _ _ -> sorry "Unsupported integer vector insert operation; please use -fllvm" + + _other -> pprPanic "getRegister(x86) - ternary CmmMachOp (1)" + (pprMachOp mop) + + where + -- SIMD NCG TODO: + -- + -- - add support for FloatX8, FloatX16. + vector_floatx4_insert_sse :: Bool + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_floatx4_insert_sse sse4_1 vecExpr valExpr (CmmLit (CmmInt offset _)) + | sse4_1 = do + (r, exp) <- getNonClobberedReg valExpr + fn <- getAnyReg vecExpr + let fmt = VecFormat 4 FmtFloat + imm = litToImm (CmmInt (offset `shiftL` 4) W32) + code dst = exp `appOL` + (fn dst) `snocOL` + (INSERTPS fmt imm (OpReg r) dst) + in return $ Any fmt code + | otherwise = do -- SSE <= 3 + (r, exp) <- getNonClobberedReg valExpr + fn <- getAnyReg vecExpr + let fmt = VecFormat 4 FmtFloat + tmp <- getNewRegNat fmt + let code dst + = case offset of + 0 -> exp `appOL` + (fn dst) `snocOL` + -- The following MOV compiles to MOVSS instruction and merges two vectors + (MOV fmt (OpReg r) (OpReg dst)) -- dst <- (r[0],dst[1],dst[2],dst[3]) + 1 -> exp `appOL` + (fn dst) `snocOL` + (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL` -- tmp <- dst + (UNPCKL fmt (OpReg r) dst) `snocOL` -- dst <- (dst[0],r[0],dst[1],r[1]) + (SHUF fmt (ImmInt 0xe4) (OpReg tmp) dst) -- dst <- (dst[0],dst[1],tmp[2],tmp[3]) + 2 -> exp `appOL` + (fn dst) `snocOL` + (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL` -- tmp <- dst + (MOV fmt (OpReg r) (OpReg tmp)) `snocOL` -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS + (SHUF fmt (ImmInt 0xc4) (OpReg tmp) dst) -- dst <- (dst[0],dst[1],tmp[0],tmp[3]) + 3 -> exp `appOL` + (fn dst) `snocOL` + (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL` -- tmp <- dst + (MOV fmt (OpReg r) (OpReg tmp)) `snocOL` -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS + (SHUF fmt (ImmInt 0x24) (OpReg tmp) dst) -- dst <- (dst[0],dst[1],tmp[2],tmp[0]) + _ -> panic "MO_VF_Insert FloatX4: unsupported offset" + in return $ Any fmt code + vector_floatx4_insert_sse _ _ _ offset + = pprPanic "Unsupported vector insert operation" $ + vcat + [ text "FloatX4#" + , text "offset:" <+> pdoc platform offset ] + + + -- SIMD NCG TODO: + -- + -- - add support for DoubleX4#, DoubleX8#. + vector_double_insert :: Bool + -> Length + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + -- DoubleX2 + vector_double_insert avx len@2 vecExpr valExpr (CmmLit offset) + = do + (valReg, valExp) <- getNonClobberedReg valExpr + (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction + let movu = if avx then VMOVU else MOVU + fmt = VecFormat len FmtDouble + code dst + = case offset of + CmmInt 0 _ -> valExp `appOL` + vecExp `snocOL` + (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL` + -- The following MOV compiles to MOVSD instruction and merges two vectors + (MOV (VecFormat 2 FmtDouble) (OpReg valReg) (OpReg dst)) + CmmInt 1 _ -> valExp `appOL` + vecExp `snocOL` + (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL` + (SHUF fmt (ImmInt 0b00) (OpReg valReg) dst) + _ -> pprPanic "MO_VF_Insert DoubleX2: unsupported offset" (ppr offset) + in return $ Any fmt code + vector_double_insert _ _ _ _ _ = + sorry "Unsupported floating-point vector insert operation; please use -fllvm" + -- For DoubleX4: use VSHUFPD. + -- For DoubleX8: use something like vinsertf64x2 followed by vpblendd? + + -- SIMD NCG TODO: + -- + -- - only supports 128-bit vector types (Int64X2, Int32X4, Int16X8, Int8X16), + -- add support for 256-bit and 512-bit vector types. + + -- PINSRW is an SSE2 instruction, whereas PINSR{B,D,Q} require SSE4.1. + vector_int_insert_pinsr :: HasCallStack => Length + -> Width + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_int_insert_pinsr len w vecExpr valExpr (CmmLit (CmmInt offset _)) + | 0 <= offset, offset < toInteger len + = do + (valReg, valExp) <- getNonClobberedReg valExpr + vecCode <- getAnyReg vecExpr + let (scalarFormat, vectorFormat) = case w of + W8 -> (II32, VecFormat len FmtInt8) + W16 -> (II32, VecFormat len FmtInt16) + W32 -> (II32, VecFormat len FmtInt32) + W64 -> (II64, VecFormat len FmtInt64) + _ -> sorry "Unsupported vector format" + code dst = valExp `appOL` + (vecCode dst) `snocOL` + (PINSR scalarFormat vectorFormat (ImmInteger offset) (OpReg valReg) dst) + return $ Any vectorFormat code + vector_int_insert_pinsr _ _ _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset) + + vector_int8x16_insert_sse2 :: CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_int8x16_insert_sse2 vecExpr valExpr (CmmLit (CmmInt offset _)) + | 0 <= offset, offset < 16 + = do + (valReg, valExp) <- getNonClobberedReg valExpr + vecCode <- getAnyReg vecExpr + tmp <- getNewRegNat II32 + let vectorFormat = VecFormat 16 FmtInt8 + code dst + = case offset `quotRem` 2 of + (j, 0) -> valExp `appOL` + (vecCode dst) `snocOL` + (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) dst (OpReg tmp)) `snocOL` -- PEXTRW + (AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp)) `snocOL` + (MOVZxL II8 (OpReg valReg) (OpReg valReg)) `snocOL` + (OR II32 (OpReg valReg) (OpReg tmp)) `snocOL` + (PINSR II32 (VecFormat 8 FmtInt16) (ImmInteger j) (OpReg tmp) dst) -- PINSRW + (j, _) -> valExp `appOL` + (vecCode dst) `snocOL` + (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) dst (OpReg tmp)) `snocOL` -- PEXTRW + (MOVZxL II8 (OpReg tmp) (OpReg tmp)) `snocOL` + (SHL II32 (OpImm (ImmInt 8)) (OpReg valReg)) `snocOL` + (OR II32 (OpReg valReg) (OpReg tmp)) `snocOL` + (PINSR II32 (VecFormat 8 FmtInt16) (ImmInteger j) (OpReg tmp) dst) -- PINSRW + return $ Any vectorFormat code + vector_int8x16_insert_sse2 _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset) + + vector_int32x4_insert_sse2 :: CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_int32x4_insert_sse2 vecExpr valExpr (CmmLit (CmmInt offset _)) + | 0 <= offset, offset < 4 + = do + (valReg, valExp) <- getNonClobberedReg valExpr + vecCode <- getAnyReg vecExpr + -- Since SSE2 does not have an integer vector instruction to achieve this, + -- we are forced to either use floating-point vector instructions + -- or lots of integer vector instructions. (sigh) + let floatVectorFormat = VecFormat 4 FmtFloat + tmp1 <- getNewRegNat floatVectorFormat + tmp2 <- getNewRegNat floatVectorFormat + let vectorFormat = VecFormat 4 FmtInt32 + code dst + = case offset of + 0 -> valExp `appOL` + (vecCode dst) `snocOL` + (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` + (MOV floatVectorFormat (OpReg tmp1) (OpReg dst)) -- MOVSS; dst <- (tmp1[0],dst[1],dst[2],dst[3]) + 1 -> valExp `appOL` + (vecCode tmp1) `snocOL` + (MOVD II32 vectorFormat (OpReg valReg) (OpReg dst)) `snocOL` -- dst <- (val,0,0,0) + (PUNPCKLQDQ vectorFormat (OpReg tmp1) dst) `snocOL` -- dst <- (dst[0],dst[1],tmp1[0],tmp1[1]) + (SHUF floatVectorFormat (ImmInt 0b11_10_00_10) (OpReg tmp1) dst) -- SHUFPS; dst <- (dst[2],dst[0],tmp1[2],tmp1[3]) + 2 -> valExp `appOL` + (vecCode dst) `snocOL` + (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` -- tmp1 <- (val,0,0,0) + (MOVU floatVectorFormat (OpReg dst) (OpReg tmp2)) `snocOL` -- MOVUPS; tmp2 <- dst + (SHUF floatVectorFormat (ImmInt 0b01_00_01_11) (OpReg tmp1) tmp2) `snocOL` -- SHUFPS; tmp2 <- (tmp2[3],tmp2[1],tmp1[0],tmp1[1]) + (SHUF floatVectorFormat (ImmInt 0b00_10_01_00) (OpReg tmp2) dst) -- SHUFPS; dst <- (dst[0],dst[1],tmp2[2],tmp2[0]) + _ -> valExp `appOL` + (vecCode dst) `snocOL` + (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` -- tmp1 <- (val,0,0,0) + (SHUF floatVectorFormat (ImmInt 0b11_10_01_00) (OpReg dst) tmp1) `snocOL` -- SHUFPS; tmp1 <- (tmp1[0],tmp1[1],dst[2],dst[3]) + (SHUF floatVectorFormat (ImmInt 0b00_10_01_00) (OpReg tmp1) dst) -- SHUFPS; dst <- (dst[0],dst[1],tmp1[2],tmp1[0]) + return $ Any vectorFormat code + vector_int32x4_insert_sse2 _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset) + + vector_int64x2_insert_sse2 :: CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_int64x2_insert_sse2 vecExpr valExpr (CmmLit offset) + = do + (valReg, valExp) <- getNonClobberedReg valExpr + (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction + let fmt = VecFormat 2 FmtInt64 + tmp <- getNewRegNat fmt + let code dst + = case offset of + CmmInt 0 _ -> valExp `appOL` + vecExp `snocOL` + (MOVHLPS FF64 vecReg tmp) `snocOL` + (MOVD II64 fmt (OpReg valReg) (OpReg dst)) `snocOL` + (PUNPCKLQDQ fmt (OpReg tmp) dst) + CmmInt 1 _ -> valExp `appOL` + vecExp `snocOL` + (MOVDQU fmt (OpReg vecReg) (OpReg dst)) `snocOL` + (MOVD II64 fmt (OpReg valReg) (OpReg tmp)) `snocOL` + (PUNPCKLQDQ fmt (OpReg tmp) dst) + _ -> pprPanic "MO_V_Insert Int64X2: unsupported offset" (ppr offset) + in return $ Any fmt code + vector_int64x2_insert_sse2 _ _ offset = pprPanic "MO_V_Insert Int64X2: unsupported offset" (pdoc platform offset) + +getRegister' _ _ (CmmMachOp mop (_:_:_:_:_)) = + pprPanic "getRegister(x86): MachOp with >= 4 arguments" (text $ show mop) + +getRegister' platform is32Bit load@(CmmLoad mem ty _) + | isVecType ty + = do + config <- getConfig + Amode addr mem_code <- getAmode mem + let code dst = + mem_code `snocOL` + movInstr config format (OpAddr addr) (OpReg dst) + return (Any format code) + | isFloatType ty + = do + Amode addr mem_code <- getAmode mem + loadAmode (floatFormat width) addr mem_code + + | is32Bit && not (isWord64 ty) + = do + let + instr = case width of + W8 -> MOVZxL II8 + -- We always zero-extend 8-bit loads, if we + -- can't think of anything better. This is because + -- we can't guarantee access to an 8-bit variant of every register + -- (esi and edi don't have 8-bit variants), so to make things + -- simpler we do our 8-bit arithmetic with full 32-bit registers. + _other -> MOV format + code <- intLoadCode instr mem + return (Any format code) + + | not is32Bit + -- Simpler memory load code on x86_64 + = do + code <- intLoadCode (MOV format) mem + return (Any format code) + + | otherwise + = pprPanic "getRegister(x86) CmmLoad" (pdoc platform load) + where + format = cmmTypeFormat ty + width = typeWidth ty + +-- Handle symbol references with LEA and %rip-relative addressing. +-- See Note [%rip-relative addressing on x86-64]. +getRegister' platform is32Bit (CmmLit lit) + | is_label lit + , not is32Bit + = do let format = cmmTypeFormat (cmmLitType platform lit) + imm = litToImm lit + op = OpAddr (AddrBaseIndex EABaseRip EAIndexNone imm) + code dst = unitOL (LEA format op (OpReg dst)) + return (Any format code) + where + is_label (CmmLabel {}) = True + is_label (CmmLabelOff {}) = True + is_label (CmmLabelDiffOff {}) = True + is_label _ = False + +getRegister' platform is32Bit (CmmLit lit) = do + avx <- avxEnabled + + -- NB: it is important that the code produced here (to load a literal into + -- a register) doesn't clobber any registers other than the destination + -- register; the code for generating C calls relies on this property. + -- + -- In particular, we have: + -- + -- > loadIntoRegMightClobberOtherReg (CmmLit _) = False + -- + -- which means that we assume that loading a literal into a register + -- will not clobber any other registers. + + -- TODO: this function mishandles floating-point negative zero, + -- because -0.0 == 0.0 returns True and because we represent CmmFloat as + -- Rational, which can't properly represent negative zero. + + if + -- Zero: use XOR. + | isZeroLit lit + -> let code dst + | isIntFormat fmt + = let fmt' + | is32Bit + = fmt + | otherwise + -- x86_64: 32-bit xor is one byte shorter, + -- and zero-extends to 64 bits + = case fmt of + II64 -> II32 + _ -> fmt + in unitOL (XOR fmt' (OpReg dst) (OpReg dst)) + | avx + = if float_or_floatvec + then unitOL (VXOR fmt (OpReg dst) dst dst) + else unitOL (VPXOR fmt dst dst dst) + | otherwise + = if float_or_floatvec + then unitOL (XOR fmt (OpReg dst) (OpReg dst)) + else unitOL (PXOR fmt (OpReg dst) dst) + in return $ Any fmt code + + -- Constant vector: use broadcast. + | VecFormat l sFmt <- fmt + , CmmVec (f:fs) <- lit + , all (== f) fs + -> do let w = scalarWidth sFmt + broadcast = if isFloatScalarFormat sFmt + then MO_VF_Broadcast l w + else MO_V_Broadcast l w + valCode <- getAnyReg (CmmMachOp broadcast [CmmLit f]) + return $ Any fmt valCode + + -- Optimisation for loading small literals on x86_64: take advantage + -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit + -- instruction forms are shorter. + | not is32Bit, isWord64 cmmTy, not (isBigLit lit) + -> let + imm = litToImm lit + code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) + in + return (Any II64 code) + + -- Scalar integer: use an immediate. + | isIntFormat fmt + -> let imm = litToImm lit + code dst = unitOL (MOV fmt (OpImm imm) (OpReg dst)) + in return (Any fmt code) + + -- General case: load literal from data address. + | otherwise + -> do let w = formatToWidth fmt + Amode addr addr_code <- memConstant (mkAlignment $ widthInBytes w) lit + loadAmode fmt addr addr_code + + where + cmmTy = cmmLitType platform lit + fmt = cmmTypeFormat cmmTy + float_or_floatvec = isFloatOrFloatVecFormat fmt + isZeroLit (CmmInt i _) = i == 0 + isZeroLit (CmmFloat f _) = f == 0 -- TODO: mishandles negative zero + isZeroLit (CmmVec fs) = all isZeroLit fs + isZeroLit _ = False + + isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff + isBigLit _ = False + -- note1: not the same as (not.is32BitLit), because that checks for + -- signed literals that fit in 32 bits, but we want unsigned + -- literals here. + -- note2: all labels are small, because we're assuming the + -- small memory model. See Note [%rip-relative addressing on x86-64]. + +getRegister' platform _ slot@(CmmStackSlot {}) = + pprPanic "getRegister(x86) CmmStackSlot" (pdoc platform slot) + +intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr + -> NatM (Reg -> InstrBlock) +intLoadCode instr mem = do + Amode src mem_code <- getAmode mem + return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst)) + +-- Compute an expression into *any* register, adding the appropriate +-- move instruction if necessary. +getAnyReg :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock) +getAnyReg expr = do + r <- getRegister expr + anyReg r + +anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock) +anyReg (Any _ code) = return code +anyReg (Fixed rep reg fcode) = do + config <- getConfig + return (\dst -> fcode `snocOL` mkRegRegMoveInstr config rep reg dst) + +-- A bit like getSomeReg, but we want a reg that can be byte-addressed. +-- Fixed registers might not be byte-addressable, so we make sure we've +-- got a temporary, inserting an extra reg copy if necessary. +getByteReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock) +getByteReg expr = do + config <- getConfig + is32Bit <- is32BitPlatform + if is32Bit + then do r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed rep reg code + | isVirtualReg reg -> return (reg,code) + | otherwise -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` mkRegRegMoveInstr config rep reg tmp) + -- ToDo: could optimise slightly by checking for + -- byte-addressable real registers, but that will + -- happen very rarely if at all. + else getSomeReg expr -- all regs are byte-addressable on x86_64 + +-- Another variant: this time we want the result in a register that cannot +-- be modified by code to evaluate an arbitrary expression. +getNonClobberedReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock) +getNonClobberedReg expr = do + r <- getRegister expr + config <- getConfig + let platform = ncgPlatform config + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed rep reg code + -- only certain regs can be clobbered + | reg `elem` instrClobberedRegs platform + -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` mkRegRegMoveInstr config rep reg tmp) + | otherwise -> + return (reg, code) + +-------------------------------------------------------------------------------- + +-- | Convert a 'CmmExpr' representing a memory address into an 'Amode'. +-- +-- An 'Amode' is a datatype representing a valid address form for the target +-- (e.g. "Base + Index + disp" or immediate) and the code to compute it. +getAmode :: CmmExpr -> NatM Amode +getAmode e = do + platform <- getPlatform + let is32Bit = target32Bit platform + + case e of + CmmRegOff r n + -> getAmode $ mangleIndexTree r n + + CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)), CmmLit displacement] + | not is32Bit + -> return $ Amode (ripRel (litToImm displacement)) nilOL + + -- This is all just ridiculous, since it carefully undoes + -- what mangleIndexTree has just done. + CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)] + | is32BitLit platform lit + -- assert (rep == II32)??? + -> do + (x_reg, x_code) <- getSomeReg x + let off = ImmInt (-(fromInteger i)) + return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) + + CmmMachOp (MO_Add _rep) [x, CmmLit lit] + | is32BitLit platform lit + -- assert (rep == II32)??? + -> do + (x_reg, x_code) <- getSomeReg x + let off = litToImm lit + return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) + + -- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be + -- recognised by the next rule. + CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)] + -> getAmode (CmmMachOp (MO_Add rep) [b,a]) + + -- Matches: (x + offset) + (y << shift) + CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]] + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset) + + CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]] + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + -> x86_complex_amode x y shift 0 + + CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _) + [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]] + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + && is32BitInteger offset + -> x86_complex_amode x y shift offset + + CmmMachOp (MO_Add _) [x,y] + | not (isLit y) -- we already handle valid literals above. + -> x86_complex_amode x y 0 0 + + CmmLit lit@(CmmFloat {}) + -> pprPanic "X86 CodeGen: attempt to use floating-point value as a memory address" + (ppr lit) + + -- Handle labels with %rip-relative addressing since in general the image + -- may be loaded anywhere in the 64-bit address space (e.g. on Windows + -- with high-entropy ASLR). See Note [%rip-relative addressing on x86-64]. + CmmLit lit + | not is32Bit + , is_label lit + -> return (Amode (AddrBaseIndex EABaseRip EAIndexNone (litToImm lit)) nilOL) + + CmmLit lit + | is32BitLit platform lit + -> return (Amode (ImmAddr (litToImm lit) 0) nilOL) + + -- Literal with offsets too big (> 32 bits) fails during the linking phase + -- (#15570). We already handled valid literals above so we don't have to + -- test anything here. + CmmLit (CmmLabelOff l off) + -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l) + , CmmLit (CmmInt (fromIntegral off) W64) + ]) + CmmLit (CmmLabelDiffOff l1 l2 off w) + -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w) + , CmmLit (CmmInt (fromIntegral off) W64) + ]) + + -- in case we can't do something better, we just compute the expression + -- and put the result in a register + _ -> do + (reg,code) <- getSomeReg e + return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) + where + is_label (CmmLabel{}) = True + is_label (CmmLabelOff{}) = True + is_label (CmmLabelDiffOff{}) = True + is_label _ = False + + +-- | Like 'getAmode', but on 32-bit use simple register addressing +-- (i.e. no index register). This stops us from running out of +-- registers on x86 when using instructions such as cmpxchg, which can +-- use up to three virtual registers and one fixed register. +getSimpleAmode :: CmmExpr -> NatM Amode +getSimpleAmode addr = is32BitPlatform >>= \case + False -> getAmode addr + True -> do + addr_code <- getAnyReg addr + config <- getConfig + addr_r <- getNewRegNat (intFormat (ncgWordWidth config)) + let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0) + return $! Amode amode (addr_code addr_r) + +x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode +x86_complex_amode base index shift offset + = do (x_reg, x_code) <- getNonClobberedReg base + -- x must be in a temp, because it has to stay live over y_code + -- we could compare x_reg and y_reg and do something better here... + (y_reg, y_code) <- getSomeReg index + let + code = x_code `appOL` y_code + base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8; + n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")" + return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset))) + code) + + + + +-- ----------------------------------------------------------------------------- +-- getOperand: sometimes any operand will do. + +-- getNonClobberedOperand: the value of the operand will remain valid across +-- the computation of an arbitrary expression, unless the expression +-- is computed directly into a register which the operand refers to +-- (see trivialCode where this function is used for an example). + +getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) +getNonClobberedOperand (CmmLit lit) + | Just w <- isSuitableFloatingPointLit_maybe lit = do + Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit + return (OpAddr addr, code) + | otherwise = do + platform <- getPlatform + if is32BitLit platform lit && isIntFormat (cmmTypeFormat (cmmLitType platform lit)) + then return (OpImm (litToImm lit), nilOL) + else getNonClobberedOperand_generic (CmmLit lit) + +getNonClobberedOperand (CmmLoad mem ty _) = do + is32Bit <- is32BitPlatform + -- this logic could be simplified + -- TODO FIXME + if (if is32Bit then not (isWord64 ty) else True) + -- if 32bit and ty is at float/double/simd value + -- or if 64bit + -- this could use some eyeballs or i'll need to stare at it more later + then do + platform <- ncgPlatform <$> getConfig + Amode src mem_code <- getAmode mem + (src',save_code) <- + if (amodeCouldBeClobbered platform src) + then do + tmp <- getNewRegNat (archWordFormat is32Bit) + return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), + unitOL (LEA (archWordFormat is32Bit) + (OpAddr src) + (OpReg tmp))) + else + return (src, nilOL) + return (OpAddr src', mem_code `appOL` save_code) + else + -- if its a word or gcptr on 32bit? + getNonClobberedOperand_generic (CmmLoad mem ty NaturallyAligned) + +getNonClobberedOperand e = getNonClobberedOperand_generic e + +getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) +getNonClobberedOperand_generic e = do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) + +amodeCouldBeClobbered :: Platform -> AddrMode -> Bool +amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode) + +regClobbered :: Platform -> Reg -> Bool +regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr +regClobbered _ _ = False + +-- getOperand: the operand is not required to remain valid across the +-- computation of an arbitrary expression. +getOperand :: CmmExpr -> NatM (Operand, InstrBlock) + +getOperand (CmmLit lit) = case isSuitableFloatingPointLit_maybe lit of + Just w -> do + Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit + return (OpAddr addr, code) + Nothing -> do + platform <- getPlatform + if is32BitLit platform lit && (isIntFormat $ cmmTypeFormat (cmmLitType platform lit)) + then return (OpImm (litToImm lit), nilOL) + else getOperand_generic (CmmLit lit) + +getOperand (CmmLoad mem ty _) = do + is32Bit <- is32BitPlatform + if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) else True) + then do + Amode src mem_code <- getAmode mem + return (OpAddr src, mem_code) + else + getOperand_generic (CmmLoad mem ty NaturallyAligned) + +getOperand e = getOperand_generic e + +getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) +getOperand_generic e = do + (reg, code) <- getSomeReg e + return (OpReg reg, code) + +isOperand :: Platform -> CmmExpr -> Bool +isOperand _ (CmmLoad _ _ _) = True +isOperand platform (CmmLit lit) + = is32BitLit platform lit + || isSuitableFloatingPointLit lit +isOperand _ _ = False + +-- | Given a 'Register', produce a new 'Register' with an instruction block +-- which will check the value for alignment. Used for @-falignment-sanitisation@. +addAlignmentCheck :: Int -> Register -> Register +addAlignmentCheck align reg = + case reg of + Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg) + Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt reg) + where + check :: Format -> Reg -> InstrBlock + check fmt reg = + assert (isIntFormat fmt) $ + toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg) + , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel + ] + +memConstant :: Alignment -> CmmLit -> NatM Amode +memConstant align lit = do + lbl <- getNewLabelNat + let rosection = Section ReadOnlyData lbl + config <- getConfig + platform <- getPlatform + (addr, addr_code) <- if target32Bit platform + then do dynRef <- cmmMakeDynamicReference + config + DataReference + lbl + Amode addr addr_code <- getAmode dynRef + return (addr, addr_code) + else return (ripRel (ImmCLbl lbl), nilOL) + let code = + LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit]) + `consOL` addr_code + return (Amode addr code) + +-- | Load the value at the given address into any register. +loadAmode :: Format -> AddrMode -> InstrBlock -> NatM Register +loadAmode fmt addr addr_code = do + config <- getConfig + let load dst = movInstr config fmt (OpAddr addr) (OpReg dst) + return $ Any fmt (\ dst -> addr_code `snocOL` load dst) + +-- if we want a floating-point literal as an operand, we can +-- use it directly from memory. However, if the literal is +-- zero, we're better off generating it into a register using +-- xor. +isSuitableFloatingPointLit :: CmmLit -> Bool +isSuitableFloatingPointLit = isJust . isSuitableFloatingPointLit_maybe + +isSuitableFloatingPointLit_maybe :: CmmLit -> Maybe Width +isSuitableFloatingPointLit_maybe (CmmFloat f w) = w <$ guard (f /= 0.0) +isSuitableFloatingPointLit_maybe _ = Nothing + +getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock) +getRegOrMem e@(CmmLoad mem ty _) = do + is32Bit <- is32BitPlatform + if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) else True) + then do + Amode src mem_code <- getAmode mem + return (OpAddr src, mem_code) + else do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) +getRegOrMem e = do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) + +is32BitLit :: Platform -> CmmLit -> Bool +is32BitLit platform _lit + | target32Bit platform = True +is32BitLit platform lit = + case lit of + CmmInt i W64 -> is32BitInteger i + -- Except on Windows, assume that labels are in the range 0-2^31-1: this + -- assumes the small memory model. Note [%rip-relative addressing on + -- x86-64]. + CmmLabel _ -> low_image + -- however we can't assume that label offsets are in this range + -- (see #15570) + CmmLabelOff _ off -> low_image && is32BitInteger (fromIntegral off) + CmmLabelDiffOff _ _ off _ -> low_image && is32BitInteger (fromIntegral off) + _ -> True + where + -- Is the executable image certain to be located below 4GB? As noted in + -- Note [%rip-relative addressing on x86-64], this is not true on Windows. + low_image = + case platformOS platform of + OSMinGW32 -> False -- See Note [%rip-relative addressing on x86-64] + _ -> True + + +-- Set up a condition code for a conditional branch. + +getCondCode :: CmmExpr -> NatM CondCode + +-- yes, they really do seem to want exactly the same! + +getCondCode (CmmMachOp mop [x, y]) + = + case mop of + MO_F_Eq W32 -> condFltCode EQQ x y + MO_F_Ne W32 -> condFltCode NE x y + MO_F_Gt W32 -> condFltCode GTT x y + MO_F_Ge W32 -> condFltCode GE x y + -- Invert comparison condition and swap operands + -- See Note [SSE Parity Checks] + MO_F_Lt W32 -> condFltCode GTT y x + MO_F_Le W32 -> condFltCode GE y x + + MO_F_Eq W64 -> condFltCode EQQ x y + MO_F_Ne W64 -> condFltCode NE x y + MO_F_Gt W64 -> condFltCode GTT x y + MO_F_Ge W64 -> condFltCode GE x y + MO_F_Lt W64 -> condFltCode GTT y x + MO_F_Le W64 -> condFltCode GE y x + + _ -> condIntCode (machOpToCond mop) x y + +getCondCode other = do + platform <- getPlatform + pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other) + +machOpToCond :: MachOp -> Cond +machOpToCond mo = case mo of + MO_Eq _ -> EQQ + MO_Ne _ -> NE + MO_S_Gt _ -> GTT + MO_S_Ge _ -> GE + MO_S_Lt _ -> LTT + MO_S_Le _ -> LE + MO_U_Gt _ -> GU + MO_U_Ge _ -> GEU + MO_U_Lt _ -> LU + MO_U_Le _ -> LEU + _other -> pprPanic "machOpToCond" (pprMachOp mo) + +{- Note [64-bit integer comparisons on 32-bit] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + When doing these comparisons there are 2 kinds of + comparisons. + + * Comparison for equality (or lack thereof) + + We use xor to check if high/low bits are + equal. Then combine the results using or. + + * Other comparisons: + + We first compare the low registers + and use a subtraction with borrow to compare the high registers. + + For signed numbers the condition is determined by + the sign and overflow flags agreeing or not + and for unsigned numbers the condition is the carry flag. + +-} + +-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be +-- passed back up the tree. + +condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode +condIntCode cond x y = do platform <- getPlatform + condIntCode' platform cond x y + +condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode + +-- 64-bit integer comparisons on 32-bit +-- See Note [64-bit integer comparisons on 32-bit] +condIntCode' platform cond x y + | target32Bit platform && isWord64 (cmmExprType platform x) = do + + RegCode64 code1 r1hi r1lo <- iselExpr64 x + RegCode64 code2 r2hi r2lo <- iselExpr64 y + + -- we mustn't clobber r1/r2 so we use temporaries + tmp1 <- getNewRegNat II32 + tmp2 <- getNewRegNat II32 + + let (cond', cmpCode) = intComparison cond r1hi r1lo r2hi r2lo tmp1 tmp2 + return $ CondCode False cond' (code1 `appOL` code2 `appOL` cmpCode) + + where + intComparison cond r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 = + case cond of + -- These don't occur as argument of condIntCode' + ALWAYS -> panic "impossible" + NEG -> panic "impossible" + POS -> panic "impossible" + CARRY -> panic "impossible" + OFLO -> panic "impossible" + PARITY -> panic "impossible" + NOTPARITY -> panic "impossible" + -- Special case #1 x == y and x != y + EQQ -> (EQQ, cmpExact) + NE -> (NE, cmpExact) + -- [x >= y] + GE -> (GE, cmpGE) + GEU -> (GEU, cmpGE) + -- [x > y] + GTT -> (LTT, cmpLE) + GU -> (LU, cmpLE) + -- [x <= y] + LE -> (GE, cmpLE) + LEU -> (GEU, cmpLE) + -- [x < y] + LTT -> (LTT, cmpGE) + LU -> (LU, cmpGE) + where + cmpExact :: OrdList Instr + cmpExact = + toOL + [ MOV II32 (OpReg r1_hi) (OpReg tmp1) + , MOV II32 (OpReg r1_lo) (OpReg tmp2) + , XOR II32 (OpReg r2_hi) (OpReg tmp1) + , XOR II32 (OpReg r2_lo) (OpReg tmp2) + , OR II32 (OpReg tmp1) (OpReg tmp2) + ] + cmpGE = toOL + [ MOV II32 (OpReg r1_hi) (OpReg tmp1) + , CMP II32 (OpReg r2_lo) (OpReg r1_lo) + , SBB II32 (OpReg r2_hi) (OpReg tmp1) + ] + cmpLE = toOL + [ MOV II32 (OpReg r2_hi) (OpReg tmp1) + , CMP II32 (OpReg r1_lo) (OpReg r2_lo) + , SBB II32 (OpReg r1_hi) (OpReg tmp1) + ] + +-- memory vs immediate +condIntCode' platform cond (CmmLoad x ty _) (CmmLit lit) + | is32BitLit platform lit = do + Amode x_addr x_code <- getAmode x + let + imm = litToImm lit + code = x_code `snocOL` + CMP (cmmTypeFormat ty) (OpImm imm) (OpAddr x_addr) + -- + return (CondCode False cond code) + +-- anything vs zero, using a mask +-- TODO: Add some sanity checking!!!! +condIntCode' platform cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 ty)) + | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit + = do + (x_reg, x_code) <- getSomeReg x + let + code = x_code `snocOL` + TEST (intFormat ty) (OpImm (ImmInteger mask)) (OpReg x_reg) + -- + return (CondCode False cond code) + +-- anything vs zero +condIntCode' _ cond x (CmmLit (CmmInt 0 ty)) = do + (x_reg, x_code) <- getSomeReg x + let + code = x_code `snocOL` + TEST (intFormat ty) (OpReg x_reg) (OpReg x_reg) + -- + return (CondCode False cond code) + +-- anything vs operand +condIntCode' platform cond x y + | isOperand platform y = do + (x_reg, x_code) <- getNonClobberedReg x + (y_op, y_code) <- getOperand y + let + code = x_code `appOL` y_code `snocOL` + CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg) + return (CondCode False cond code) +-- operand vs. anything: invert the comparison so that we can use a +-- single comparison instruction. + | isOperand platform x + , Just revcond <- maybeFlipCond cond = do + (y_reg, y_code) <- getNonClobberedReg y + (x_op, x_code) <- getOperand x + let + code = y_code `appOL` x_code `snocOL` + CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg) + return (CondCode False revcond code) + +-- anything vs anything +condIntCode' platform cond x y = do + (y_reg, y_code) <- getNonClobberedReg y + (x_op, x_code) <- getRegOrMem x + let + code = y_code `appOL` + x_code `snocOL` + CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op + return (CondCode False cond code) + + + +-------------------------------------------------------------------------------- +condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode + +condFltCode cond x y + = condFltCode_sse2 + where + + + -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be + -- an operand, but the right must be a reg. We can probably do better + -- than this general case... + condFltCode_sse2 = do + platform <- getPlatform + (x_reg, x_code) <- getNonClobberedReg x + (y_op, y_code) <- getOperand y + let + code = x_code `appOL` + y_code `snocOL` + CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg) + -- NB(1): we need to use the unsigned comparison operators on the + -- result of this comparison. + return (CondCode True (condToUnsigned cond) code) + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_VecCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_VecCode :: CmmReg -> CmmExpr -> NatM InstrBlock + +-- integer assignment to memory + +-- specific case of adding/subtracting an integer to a particular address. +-- ToDo: catch other cases where we can use an operation directly on a memory +-- address. +assignMem_IntCode ty addr (CmmMachOp op [CmmLoad addr2 _ _, + CmmLit (CmmInt i _)]) + | addr == addr2, ty /= II64 || is32BitInteger i, + Just instr <- check op + = do Amode amode code_addr <- getAmode addr + let code = code_addr `snocOL` + instr ty (OpImm (ImmInt (fromIntegral i))) (OpAddr amode) + return code + where + check (MO_Add _) = Just ADD + check (MO_Sub _) = Just SUB + check _ = Nothing + -- ToDo: more? + +-- general case +assignMem_IntCode ty addr src = do + platform <- getPlatform + Amode addr code_addr <- getAmode addr + (code_src, op_src) <- get_op_RI platform src + let + code = code_src `appOL` + code_addr `snocOL` + MOV ty op_src (OpAddr addr) + -- NOTE: op_src is stable, so it will still be valid + -- after code_addr. This may involve the introduction + -- of an extra MOV to a temporary register, but we hope + -- the register allocator will get rid of it. + -- + return code + where + get_op_RI :: Platform -> CmmExpr -> NatM (InstrBlock,Operand) -- code, operator + get_op_RI platform (CmmLit lit) | is32BitLit platform lit + = return (nilOL, OpImm (litToImm lit)) + get_op_RI _ op + = do (reg,code) <- getNonClobberedReg op + return (code, OpReg reg) + + +-- Assign; dst is a reg, rhs is mem +assignReg_IntCode reg (CmmLoad src _ _) = do + let ty = cmmTypeFormat $ cmmRegType reg + load_code <- intLoadCode (MOV ty) src + platform <- ncgPlatform <$> getConfig + return (load_code (getRegisterReg platform reg)) + +-- dst is a reg, but src could be anything +assignReg_IntCode reg src = do + platform <- ncgPlatform <$> getConfig + code <- getAnyReg src + return (code (getRegisterReg platform reg)) + + +-- Floating point assignment to memory +assignMem_FltCode ty addr src = do + (src_reg, src_code) <- getNonClobberedReg src + Amode addr addr_code <- getAmode addr + let + code = src_code `appOL` + addr_code `snocOL` + MOV ty (OpReg src_reg) (OpAddr addr) + + return code + +-- Floating point assignment to a register/temporary +assignReg_FltCode reg src = do + src_code <- getAnyReg src + platform <- ncgPlatform <$> getConfig + return (src_code (getRegisterReg platform reg)) + +-- Vector assignment to a register/temporary +assignMem_VecCode ty addr src = do + (src_reg, src_code) <- getNonClobberedReg src + Amode addr addr_code <- getAmode addr + config <- getConfig + let + code = src_code `appOL` + addr_code `snocOL` + movInstr config ty (OpReg src_reg) (OpAddr addr) + return code + +assignReg_VecCode reg src = do + platform <- ncgPlatform <$> getConfig + src_code <- getAnyReg src + return (src_code (getRegisterReg platform reg)) + +genJump :: CmmExpr{-the branch target-} -> [RegWithFormat] -> NatM InstrBlock + +genJump (CmmLoad mem _ _) regs = do + Amode target code <- getAmode mem + return (code `snocOL` JMP (OpAddr target) regs) + +genJump (CmmLit lit) regs = + return (unitOL (JMP (OpImm (litToImm lit)) regs)) + +genJump expr regs = do + (reg,code) <- getSomeReg expr + return (code `snocOL` JMP (OpReg reg) regs) + + +-- ----------------------------------------------------------------------------- +-- Unconditional branches + +genBranch :: BlockId -> InstrBlock +genBranch = toOL . mkJumpInstr + + + +-- ----------------------------------------------------------------------------- +-- Conditional jumps/branches + +{- +Conditional jumps are always to local labels, so we can use branch +instructions. We peek at the arguments to decide what kind of +comparison to do. + +I386: First, we have to ensure that the condition +codes are set according to the supplied comparison operation. +-} + +genCondBranch + :: BlockId -- the source of the jump + -> BlockId -- the true branch target + -> BlockId -- the false branch target + -> CmmExpr -- the condition on which to branch + -> NatM InstrBlock -- Instructions + +genCondBranch bid id false expr = do + is32Bit <- is32BitPlatform + genCondBranch' is32Bit bid id false expr + +-- | We return the instructions generated. +genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr + -> NatM InstrBlock + +genCondBranch' _ bid id false bool = do + CondCode is_float cond cond_code <- getCondCode bool + if not is_float + then + return (cond_code `snocOL` JXX cond id `appOL` genBranch false) + else do + -- See Note [SSE Parity Checks] + let jmpFalse = genBranch false + code + = case cond of + NE -> or_unordered + GU -> plain_test + GEU -> plain_test + -- Use ASSERT so we don't break releases if + -- LTT/LE creep in somehow. + LTT -> + assertPpr False (text "Should have been turned into >") + and_ordered + LE -> + assertPpr False (text "Should have been turned into >=") + and_ordered + _ -> and_ordered + + plain_test = unitOL ( + JXX cond id + ) `appOL` jmpFalse + or_unordered = toOL [ + JXX cond id, + JXX PARITY id + ] `appOL` jmpFalse + and_ordered = toOL [ + JXX PARITY false, + JXX cond id, + JXX ALWAYS false + ] + updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false) + return (cond_code `appOL` code) + +{- Note [Introducing cfg edges inside basic blocks] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + During instruction selection a statement `s` + in a block B with control of the sort: B -> C + will sometimes result in control + flow of the sort: + + ┌ < ┐ + v ^ + B -> B1 ┴ -> C + + as is the case for some atomic operations. + + Now to keep the CFG in sync when introducing B1 we clearly + want to insert it between B and C. However there is + a catch when we have to deal with self loops. + + We might start with code and a CFG of these forms: + + loop: + stmt1 ┌ < ┐ + .... v ^ + stmtX loop ┘ + stmtY + .... + goto loop: + + Now we introduce B1: + ┌ ─ ─ ─ ─ ─┐ + loop: │ ┌ < ┐ │ + instrs v │ │ ^ + .... loop ┴ B1 ┴ ┘ + instrsFromX + stmtY + goto loop: + + This is simple, all outgoing edges from loop now simply + start from B1 instead and the code generator knows which + new edges it introduced for the self loop of B1. + + Disaster strikes if the statement Y follows the same pattern. + If we apply the same rule that all outgoing edges change then + we end up with: + + loop ─> B1 ─> B2 ┬─┐ + │ │ └─<┤ │ + │ └───<───┘ │ + └───────<────────┘ + + This is problematic. The edge B1->B1 is modified as expected. + However the modification is wrong! + + The assembly in this case looked like this: + + _loop: + + _B1: + ... + cmpxchgq ... + jne _B1 + + + _B2: + ... + cmpxchgq ... + jne _B2 + + 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: + + _B1: + ... + cmpxchgq ... + jne _B1 + jmp _B1' + _B1': + + + _B2: + ... + + Now when inserting B2 we will only look at the outgoing edges of B1' and + everything will work out nicely. + + You might also wonder why we don't insert jumps at the end of _B1'. There is + no way another block ends up jumping to the labels _B1 or _B2 since they are + essentially invisible to other blocks. View them as control flow labels local + to the basic block if you'd like. + + Not doing this ultimately caused (part 2 of) #17334. +-} + + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +-- Now the biggest nightmare---calls. Most of the nastiness is buried in +-- @get_arg@, which moves the arguments to the correct registers/stack +-- locations. Apart from that, the code is easy. +-- +-- (If applicable) Do not fill the delay slots here; you will confuse the +-- register allocator. +-- +-- See Note [Keeping track of the current block] for information why we need +-- to take/return a block id. + +genForeignCall + :: ForeignTarget -- ^ function to call + -> [CmmFormal] -- ^ where to put the result + -> [CmmActual] -- ^ arguments (of mixed type) + -> BlockId -- ^ The block we are in + -> NatM (InstrBlock, Maybe BlockId) + +genForeignCall target dst args bid = do + case target of + PrimTarget prim -> genPrim bid prim dst args + ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args + +genPrim + :: BlockId -- ^ The block we are in + -> CallishMachOp -- ^ MachOp + -> [CmmFormal] -- ^ where to put the result + -> [CmmActual] -- ^ arguments (of mixed type) + -> NatM (InstrBlock, Maybe BlockId) + +-- First we deal with cases which might introduce new blocks in the stream. +genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n] + = genAtomicRMW bid width amop dst addr n +genPrim bid (MO_Ctz width) [dst] [src] + = genCtz bid width dst src + +-- Then we deal with cases which not introducing new blocks in the stream. +genPrim bid prim dst args + = (,Nothing) <$> genSimplePrim bid prim dst args + +genSimplePrim + :: BlockId -- ^ the block we are in + -> CallishMachOp -- ^ MachOp + -> [CmmFormal] -- ^ where to put the result + -> [CmmActual] -- ^ arguments (of mixed type) + -> NatM InstrBlock +genSimplePrim bid (MO_Memcpy align) [] [dst,src,n] = genMemCpy bid align dst src n +genSimplePrim bid (MO_Memmove align) [] [dst,src,n] = genMemMove bid align dst src n +genSimplePrim bid (MO_Memcmp align) [res] [dst,src,n] = genMemCmp bid align res dst src n +genSimplePrim bid (MO_Memset align) [] [dst,c,n] = genMemSet bid align dst c n +genSimplePrim _ MO_AcquireFence [] [] = return nilOL -- barriers compile to no code on x86/x86-64; +genSimplePrim _ MO_ReleaseFence [] [] = return nilOL -- we keep it this long in order to prevent earlier optimisations. +genSimplePrim _ MO_SeqCstFence [] [] = return $ unitOL MFENCE +genSimplePrim _ MO_Touch [] [_] = return nilOL +genSimplePrim _ (MO_Prefetch_Data n) [] [src] = genPrefetchData n src +genSimplePrim _ (MO_BSwap width) [dst] [src] = genByteSwap width dst src +genSimplePrim bid (MO_BRev width) [dst] [src] = genBitRev bid width dst src +genSimplePrim bid (MO_PopCnt width) [dst] [src] = genPopCnt bid width dst src +genSimplePrim bid (MO_Pdep width) [dst] [src,mask] = genPdep bid width dst src mask +genSimplePrim bid (MO_Pext width) [dst] [src,mask] = genPext bid width dst src mask +genSimplePrim bid (MO_Clz width) [dst] [src] = genClz bid width dst src +genSimplePrim bid (MO_UF_Conv width) [dst] [src] = genWordToFloat bid width dst src +genSimplePrim _ (MO_AtomicRead w mo) [dst] [addr] = genAtomicRead w mo dst addr +genSimplePrim _ (MO_AtomicWrite w mo) [] [addr,val] = genAtomicWrite w mo addr val +genSimplePrim bid (MO_Cmpxchg width) [dst] [addr,old,new] = genCmpXchg bid width dst addr old new +genSimplePrim _ (MO_Xchg width) [dst] [addr, value] = genXchg width dst addr value +genSimplePrim _ (MO_AddWordC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y +genSimplePrim _ (MO_SubWordC w) [r,c] [x,y] = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y +genSimplePrim _ (MO_AddIntC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO r c x y +genSimplePrim _ (MO_SubIntC w) [r,c] [x,y] = genAddSubRetCarry w SUB_CC (const Nothing) OFLO r c x y +genSimplePrim _ (MO_Add2 w) [h,l] [x,y] = genAddWithCarry w h l x y +genSimplePrim _ (MO_U_Mul2 w) [h,l] [x,y] = genUnsignedLargeMul w h l x y +genSimplePrim _ (MO_S_Mul2 w) [c,h,l] [x,y] = genSignedLargeMul w c h l x y +genSimplePrim _ (MO_S_QuotRem w) [q,r] [x,y] = genQuotRem w True q r Nothing x y +genSimplePrim _ (MO_U_QuotRem w) [q,r] [x,y] = genQuotRem w False q r Nothing x y +genSimplePrim _ (MO_U_QuotRem2 w) [q,r] [hx,lx,y] = genQuotRem w False q r (Just hx) lx y +genSimplePrim _ MO_F32_Fabs [dst] [src] = genFloatAbs W32 dst src +genSimplePrim _ MO_F64_Fabs [dst] [src] = genFloatAbs W64 dst src +genSimplePrim _ MO_F32_Sqrt [dst] [src] = genFloatSqrt FF32 dst src +genSimplePrim _ MO_F64_Sqrt [dst] [src] = genFloatSqrt FF64 dst src +genSimplePrim bid MO_F32_Sin [dst] [src] = genLibCCall bid (fsLit "sinf") [dst] [src] +genSimplePrim bid MO_F32_Cos [dst] [src] = genLibCCall bid (fsLit "cosf") [dst] [src] +genSimplePrim bid MO_F32_Tan [dst] [src] = genLibCCall bid (fsLit "tanf") [dst] [src] +genSimplePrim bid MO_F32_Exp [dst] [src] = genLibCCall bid (fsLit "expf") [dst] [src] +genSimplePrim bid MO_F32_ExpM1 [dst] [src] = genLibCCall bid (fsLit "expm1f") [dst] [src] +genSimplePrim bid MO_F32_Log [dst] [src] = genLibCCall bid (fsLit "logf") [dst] [src] +genSimplePrim bid MO_F32_Log1P [dst] [src] = genLibCCall bid (fsLit "log1pf") [dst] [src] +genSimplePrim bid MO_F32_Asin [dst] [src] = genLibCCall bid (fsLit "asinf") [dst] [src] +genSimplePrim bid MO_F32_Acos [dst] [src] = genLibCCall bid (fsLit "acosf") [dst] [src] +genSimplePrim bid MO_F32_Atan [dst] [src] = genLibCCall bid (fsLit "atanf") [dst] [src] +genSimplePrim bid MO_F32_Sinh [dst] [src] = genLibCCall bid (fsLit "sinhf") [dst] [src] +genSimplePrim bid MO_F32_Cosh [dst] [src] = genLibCCall bid (fsLit "coshf") [dst] [src] +genSimplePrim bid MO_F32_Tanh [dst] [src] = genLibCCall bid (fsLit "tanhf") [dst] [src] +genSimplePrim bid MO_F32_Pwr [dst] [x,y] = genLibCCall bid (fsLit "powf") [dst] [x,y] +genSimplePrim bid MO_F32_Asinh [dst] [src] = genLibCCall bid (fsLit "asinhf") [dst] [src] +genSimplePrim bid MO_F32_Acosh [dst] [src] = genLibCCall bid (fsLit "acoshf") [dst] [src] +genSimplePrim bid MO_F32_Atanh [dst] [src] = genLibCCall bid (fsLit "atanhf") [dst] [src] +genSimplePrim bid MO_F64_Sin [dst] [src] = genLibCCall bid (fsLit "sin") [dst] [src] +genSimplePrim bid MO_F64_Cos [dst] [src] = genLibCCall bid (fsLit "cos") [dst] [src] +genSimplePrim bid MO_F64_Tan [dst] [src] = genLibCCall bid (fsLit "tan") [dst] [src] +genSimplePrim bid MO_F64_Exp [dst] [src] = genLibCCall bid (fsLit "exp") [dst] [src] +genSimplePrim bid MO_F64_ExpM1 [dst] [src] = genLibCCall bid (fsLit "expm1") [dst] [src] +genSimplePrim bid MO_F64_Log [dst] [src] = genLibCCall bid (fsLit "log") [dst] [src] +genSimplePrim bid MO_F64_Log1P [dst] [src] = genLibCCall bid (fsLit "log1p") [dst] [src] +genSimplePrim bid MO_F64_Asin [dst] [src] = genLibCCall bid (fsLit "asin") [dst] [src] +genSimplePrim bid MO_F64_Acos [dst] [src] = genLibCCall bid (fsLit "acos") [dst] [src] +genSimplePrim bid MO_F64_Atan [dst] [src] = genLibCCall bid (fsLit "atan") [dst] [src] +genSimplePrim bid MO_F64_Sinh [dst] [src] = genLibCCall bid (fsLit "sinh") [dst] [src] +genSimplePrim bid MO_F64_Cosh [dst] [src] = genLibCCall bid (fsLit "cosh") [dst] [src] +genSimplePrim bid MO_F64_Tanh [dst] [src] = genLibCCall bid (fsLit "tanh") [dst] [src] +genSimplePrim bid MO_F64_Pwr [dst] [x,y] = genLibCCall bid (fsLit "pow") [dst] [x,y] +genSimplePrim bid MO_F64_Asinh [dst] [src] = genLibCCall bid (fsLit "asinh") [dst] [src] +genSimplePrim bid MO_F64_Acosh [dst] [src] = genLibCCall bid (fsLit "acosh") [dst] [src] +genSimplePrim bid MO_F64_Atanh [dst] [src] = genLibCCall bid (fsLit "atanh") [dst] [src] +genSimplePrim bid MO_SuspendThread [tok] [rs,i] = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i] +genSimplePrim bid MO_ResumeThread [rs] [tok] = genRTSCCall bid (fsLit "resumeThread") [rs] [tok] +genSimplePrim bid MO_I64_Quot [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y] +genSimplePrim bid MO_I64_Rem [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y] +genSimplePrim bid MO_W64_Quot [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y] +genSimplePrim bid MO_W64_Rem [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y] +genSimplePrim bid (MO_VS_Quot 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt8X16") [dst] [x,y] +genSimplePrim bid (MO_VS_Quot 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt16X8") [dst] [x,y] +genSimplePrim bid (MO_VS_Quot 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt32X4") [dst] [x,y] +genSimplePrim bid (MO_VS_Quot 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt64X2") [dst] [x,y] +genSimplePrim _ op@(MO_VS_Quot {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genSimplePrim bid (MO_VS_Rem 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt8X16") [dst] [x,y] +genSimplePrim bid (MO_VS_Rem 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt16X8") [dst] [x,y] +genSimplePrim bid (MO_VS_Rem 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt32X4") [dst] [x,y] +genSimplePrim bid (MO_VS_Rem 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt64X2") [dst] [x,y] +genSimplePrim _ op@(MO_VS_Rem {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genSimplePrim bid (MO_VU_Quot 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord8X16") [dst] [x,y] +genSimplePrim bid (MO_VU_Quot 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord16X8") [dst] [x,y] +genSimplePrim bid (MO_VU_Quot 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord32X4") [dst] [x,y] +genSimplePrim bid (MO_VU_Quot 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord64X2") [dst] [x,y] +genSimplePrim _ op@(MO_VU_Quot {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genSimplePrim bid (MO_VU_Rem 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord8X16") [dst] [x,y] +genSimplePrim bid (MO_VU_Rem 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord16X8") [dst] [x,y] +genSimplePrim bid (MO_VU_Rem 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord32X4") [dst] [x,y] +genSimplePrim bid (MO_VU_Rem 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord64X2") [dst] [x,y] +genSimplePrim _ op@(MO_VU_Rem {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genSimplePrim bid MO_I64X2_Min [dst] [x,y] = genPrimCCall bid (fsLit "hs_minInt64X2") [dst] [x,y] +genSimplePrim bid MO_I64X2_Max [dst] [x,y] = genPrimCCall bid (fsLit "hs_maxInt64X2") [dst] [x,y] +genSimplePrim bid MO_W64X2_Min [dst] [x,y] = genPrimCCall bid (fsLit "hs_minWord64X2") [dst] [x,y] +genSimplePrim bid MO_W64X2_Max [dst] [x,y] = genPrimCCall bid (fsLit "hs_maxWord64X2") [dst] [x,y] +genSimplePrim _ op dst args = do + platform <- ncgPlatform <$> getConfig + pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args)) + +{- Note [Evaluate C-call arguments before placing in destination registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When producing code for C calls we must take care when placing arguments +in their final registers. Specifically, we must ensure that temporary register +usage due to evaluation of one argument does not clobber a register in which we +already placed a previous argument (e.g. as the code generation logic for +MO_Shl can clobber %rcx due to x86 instruction limitations). + +This is precisely what happened in #18527. Consider this C--: + + (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64)); + +Here we are calling the C function `doSomething` with three arguments, the last +involving a non-trivial expression involving MO_Shl. In this case the NCG could +naively generate the following assembly (where $tmp denotes some temporary +register and $argN denotes the register for argument N, as dictated by the +platform's calling convention): + + mov _s2hp, $arg1 # place first argument + mov _s2hq, $arg2 # place second argument + + # Compute 1 << _s2hz + mov _s2hz, %rcx + shl %cl, $tmp + + # Compute (_s2hw | (1 << _s2hz)) + mov _s2hw, $arg3 + or $tmp, $arg3 + + # Perform the call + call func + +This code is outright broken on Windows which assigns $arg1 to %rcx. This means +that the evaluation of the last argument clobbers the first argument. + +To avoid this we use a rather awful hack: when producing code for a C call with +at least one non-trivial argument, we first evaluate all of the arguments into +local registers before moving them into their final calling-convention-defined +homes. This is performed by 'evalArgs'. Here we define "non-trivial" to be an +expression which might contain a MachOp since these are the only cases which +might clobber registers. Furthermore, we use a conservative approximation of +this condition (only looking at the top-level of CmmExprs) to avoid spending +too much effort trying to decide whether we want to take the fast path. + +Note that this hack *also* applies to calls to out-of-line PrimTargets (which +are lowered via a C call), which will ultimately end up in +genForeignCall{32,64}. +-} + +-- | See Note [Evaluate C-call arguments before placing in destination registers] +evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual]) +evalArgs bid actuals + | any loadIntoRegMightClobberOtherReg actuals = do + regs_blks <- mapM evalArg actuals + return (concatOL $ map fst regs_blks, map snd regs_blks) + | otherwise = return (nilOL, actuals) + where + + evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr) + evalArg actual = do + platform <- getPlatform + lreg <- newLocalReg $ cmmExprType platform actual + (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual + -- The above assignment shouldn't change the current block + massert (isNothing bid1) + return (instrs, CmmReg $ CmmLocal lreg) + + newLocalReg :: CmmType -> NatM LocalReg + newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty + +-- | Might the code to put this expression into a register +-- clobber any other registers? +loadIntoRegMightClobberOtherReg :: CmmExpr -> Bool +loadIntoRegMightClobberOtherReg (CmmReg _) = False +loadIntoRegMightClobberOtherReg (CmmRegOff _ _) = False +loadIntoRegMightClobberOtherReg (CmmLit _) = False + -- NB: this last 'False' is slightly risky, because the code for loading + -- a literal into a register is not entirely trivial. +loadIntoRegMightClobberOtherReg _ = True + +-- Note [DIV/IDIV for bytes] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- IDIV reminder: +-- Size Dividend Divisor Quotient Remainder +-- byte %ax r/m8 %al %ah +-- word %dx:%ax r/m16 %ax %dx +-- dword %edx:%eax r/m32 %eax %edx +-- qword %rdx:%rax r/m64 %rax %rdx +-- +-- We do a special case for the byte division because the current +-- codegen doesn't deal well with accessing %ah register (also, +-- accessing %ah in 64-bit mode is complicated because it cannot be an +-- operand of many instructions). So we just widen operands to 16 bits +-- and get the results from %al, %dl. This is not optimal, but a few +-- register moves are probably not a huge deal when doing division. + + +-- | Generate C call to the given function in ghc-prim +genPrimCCall + :: BlockId + -> FastString + -> [CmmFormal] + -> [CmmActual] + -> NatM InstrBlock +genPrimCCall bid lbl_txt dsts args = do + config <- getConfig + -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel + let lbl = mkCmmCodeLabel ghcInternalUnitId lbl_txt + addr <- cmmMakeDynamicReference config CallReference lbl + let conv = ForeignConvention CCallConv [] [] CmmMayReturn + genCCall bid addr conv dsts args + +-- | Generate C call to the given function in libc +genLibCCall + :: BlockId + -> FastString + -> [CmmFormal] + -> [CmmActual] + -> NatM InstrBlock +genLibCCall bid lbl_txt dsts args = do + config <- getConfig + -- Assume we can call these functions directly, and that they're not in a dynamic library. + -- TODO: Why is this ok? Under linux this code will be in libm.so + -- Is it because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 + let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction + addr <- cmmMakeDynamicReference config CallReference lbl + let conv = ForeignConvention CCallConv [] [] CmmMayReturn + genCCall bid addr conv dsts args + +-- | Generate C call to the given function in the RTS +genRTSCCall + :: BlockId + -> FastString + -> [CmmFormal] + -> [CmmActual] + -> NatM InstrBlock +genRTSCCall bid lbl_txt dsts args = do + config <- getConfig + -- Assume we can call these functions directly, and that they're not in a dynamic library. + let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction + addr <- cmmMakeDynamicReference config CallReference lbl + let conv = ForeignConvention CCallConv [] [] CmmMayReturn + genCCall bid addr conv dsts args + +-- | Generate a real C call to the given address with the given convention +genCCall + :: BlockId + -> CmmExpr + -> ForeignConvention + -> [CmmFormal] + -> [CmmActual] + -> NatM InstrBlock +genCCall bid addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do + platform <- getPlatform + is32Bit <- is32BitPlatform + let args_hints = zip args (argHints ++ repeat NoHint) + prom_args = map (maybePromoteCArgToW32 platform) args_hints + (instrs0, args') <- evalArgs bid prom_args + instrs1 <- if is32Bit + then genCCall32 addr conv dest_regs args' + else genCCall64 addr conv dest_regs args' + return (instrs0 `appOL` instrs1) + +maybePromoteCArgToW32 :: Platform -> (CmmExpr, ForeignHint) -> CmmExpr +maybePromoteCArgToW32 platform (arg, hint) + | wfrom < wto = + -- As wto=W32, we only need to handle integer conversions, + -- never Float -> Double. + case hint of + SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg] + _ -> CmmMachOp (MO_UU_Conv wfrom wto) [arg] + | otherwise = arg + where + ty = cmmExprType platform arg + wfrom = typeWidth ty + wto = W32 + +genCCall32 :: CmmExpr -- ^ address of the function to call + -> ForeignConvention -- ^ calling convention + -> [CmmFormal] -- ^ where to put the result + -> [CmmActual] -- ^ arguments (of mixed type) + -> NatM InstrBlock +genCCall32 addr _conv dest_regs args = do + config <- getConfig + let platform = ncgPlatform config + + -- If the size is smaller than the word, we widen things (see maybePromoteCArg) + arg_size_bytes :: CmmType -> Int + arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform)) + + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) + + push_arg :: CmmActual {-current argument-} + -> NatM InstrBlock -- code + + push_arg arg -- we don't need the hints on x86 + | isWord64 arg_ty = do + RegCode64 code r_hi r_lo <- iselExpr64 arg + delta <- getDeltaNat + setDeltaNat (delta - 8) + return ( code `appOL` + toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), + PUSH II32 (OpReg r_lo), DELTA (delta - 8), + DELTA (delta-8)] + ) + + | isFloatType arg_ty || isVecType arg_ty = do + (reg, code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `appOL` + toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), + DELTA (delta-size), + let addr = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + format = cmmTypeFormat arg_ty + in + + movInstr config format (OpReg reg) (OpAddr addr) + + ] + ) + + | otherwise = do + -- Arguments can be smaller than 32-bit, but we still use @PUSH + -- II32@ - the usual calling conventions expect integers to be + -- 4-byte aligned. + massert ((typeWidth arg_ty) <= W32) + (operand, code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `snocOL` + PUSH II32 operand `snocOL` + DELTA (delta-size)) + + where + arg_ty = cmmExprType platform arg + size = arg_size_bytes arg_ty -- Byte size + + let + -- Align stack to 16n for calls, assuming a starting stack + -- alignment of 16n - word_size on procedure entry. Which we + -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c. + sizes = map (arg_size_bytes . cmmExprType platform) (reverse args) + raw_arg_size = sum sizes + platformWordSizeInBytes platform + arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size + tot_arg_size = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform + + + delta0 <- getDeltaNat + setDeltaNat (delta0 - arg_pad_size) + + push_codes <- mapM push_arg (reverse args) + delta <- getDeltaNat + massert (delta == delta0 - tot_arg_size) + + -- deal with static vs dynamic call targets + callinsns <- + case addr of + CmmLit (CmmLabel lbl) + -> return $ unitOL (CALL (Left fn_imm) []) + where fn_imm = ImmCLbl lbl + _ + -> do { (dyn_r, dyn_c) <- getSomeReg addr + ; massert (isWord32 (cmmExprType platform addr)) + ; return $ dyn_c `snocOL` CALL (Right dyn_r) [] } + let push_code + | arg_pad_size /= 0 + = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), + DELTA (delta0 - arg_pad_size)] + `appOL` concatOL push_codes + | otherwise + = concatOL push_codes + + call = callinsns `appOL` + toOL ( + (if tot_arg_size == 0 then [] else + [ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) + ++ + [DELTA delta0] + ) + setDeltaNat delta0 + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [dest] + | isVecType ty + = unitOL (mkRegRegMoveInstr config (cmmTypeFormat ty) xmm0 r_dest) + | isFloatType ty = + -- we assume SSE2 + let tmp_amode = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + fmt = floatFormat w + in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), + DELTA (delta0 - b), + X87Store fmt tmp_amode, + -- X87Store only supported for the CDECL ABI + -- NB: This code will need to be + -- revisited once GHC does more work around + -- SIGFPE f + MOV fmt (OpAddr tmp_amode) (OpReg r_dest), + ADD II32 (OpImm (ImmInt b)) (OpReg esp), + DELTA delta0] + | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), + MOV II32 (OpReg edx) (OpReg r_dest_hi)] + | otherwise = unitOL (MOV (intFormat w) + (OpReg eax) + (OpReg r_dest)) + where + ty = localRegType dest + w = typeWidth ty + b = widthInBytes w + r_dest_hi = getHiVRegFromLo r_dest + r_dest = getLocalRegReg dest + assign_code many = pprPanic "genForeignCall.assign_code - too many return values:" (ppr many) + + return (push_code `appOL` + call `appOL` + assign_code dest_regs) + +genCCall64 :: CmmExpr -- ^ address of function to call + -> ForeignConvention -- ^ calling convention + -> [CmmFormal] -- ^ where to put the result + -> [CmmActual] -- ^ arguments (of mixed type) + -> NatM InstrBlock +genCCall64 addr conv dest_regs args = do + config <- getConfig + let platform = ncgPlatform config + word_size = platformWordSizeInBytes platform + wordFmt = archWordFormat (target32Bit platform) + + -- Compute the code for loading arguments into registers, + -- returning the leftover arguments that will need to be passed on the stack. + -- + -- NB: the code for loading references to data into registers is computed + -- later (in 'pushArgs'), because we don't yet know where the data will be + -- placed (due to alignment requirements). + LoadArgs + { stackArgs = proper_stack_args + , stackDataArgs = stack_data_args + , usedRegs = arg_regs_used + , assignArgsCode = assign_args_code + } + <- loadArgs config args + + let + + -- Pad all arguments and data passed on stack to align them properly. + (stk_args_with_padding, args_aligned_16) = + padStackArgs platform (proper_stack_args, stack_data_args) + + -- Align stack to 16n for calls, assuming a starting stack + -- alignment of 16n - word_size on procedure entry. Which we + -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c + need_realign_call = args_aligned_16 + align_call_code <- + if need_realign_call + then addStackPadding word_size + else return nilOL + + -- Compute the code that pushes data to the stack, and also + -- the code that loads references to that data into registers, + -- when the data is passed by reference in a register. + (load_data_refs, push_code) <- + pushArgs config proper_stack_args stk_args_with_padding + + -- On Windows, leave stack space for the arguments that we are passing + -- in registers (the so-called shadow space). + let shadow_space = + if platformOS platform == OSMinGW32 + then 8 * length (allArgRegs platform) + -- NB: the shadow store is always 8 * 4 = 32 bytes large, + -- i.e. the cumulative size of rcx, rdx, r8, r9 (see 'allArgRegs'). + else 0 + shadow_space_code <- addStackPadding shadow_space + + let total_args_size + = shadow_space + + sum (map (stackArgSpace platform) stk_args_with_padding) + real_size = + total_args_size + if need_realign_call then word_size else 0 + + -- End of argument passing. + -- + -- Next step: emit the appropriate call instruction. + delta <- getDeltaNat + + let -- The System V AMD64 ABI requires us to set %al to the number of SSE2 + -- registers that contain arguments, if the called routine + -- is a varargs function. We don't know whether it's a + -- varargs function or not, so we have to assume it is. + -- + -- It's not safe to omit this assignment, even if the number + -- of SSE2 regs in use is zero. If %al is larger than 8 + -- on entry to a varargs function, seg faults ensue. + nb_sse_regs_used = count (isFloatFormat . regWithFormat_format) arg_regs_used + assign_eax_sse_regs + = unitOL (MOV II32 (OpImm (ImmInt nb_sse_regs_used)) (OpReg eax)) + -- Note: we do this on Windows as well. It's not entirely clear why + -- it's needed (the Windows X86_64 calling convention does not + -- dictate it), but we get segfaults without it. + -- + -- One test case exhibiting the issue is T20030_test1j; + -- if you change this, make sure to run it in a loop for a while + -- with at least -j8 to check. + + -- Live registers we are annotating the call instruction with + arg_regs = [RegWithFormat eax wordFmt] ++ arg_regs_used + + -- deal with static vs dynamic call targets + (callinsns,_cconv) <- case addr of + CmmLit (CmmLabel lbl) -> + return (unitOL (CALL (Left (ImmCLbl lbl)) arg_regs), conv) + _ -> do + (dyn_r, dyn_c) <- getSomeReg addr + return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + + let call = callinsns `appOL` + toOL ( + -- Deallocate parameters after call for ccall + (if real_size==0 then [] else + [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)]) + ++ + [DELTA (delta + real_size)] + ) + setDeltaNat (delta + real_size) + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [dest] = + unitOL $ + mkRegRegMoveInstr config fmt reg r_dest + where + reg = if isIntFormat fmt then rax else xmm0 + fmt = cmmTypeFormat rep + rep = localRegType dest + r_dest = getRegisterReg platform (CmmLocal dest) + assign_code _many = panic "genForeignCall.assign_code many" + + return (align_call_code `appOL` + push_code `appOL` + assign_args_code `appOL` + load_data_refs `appOL` + shadow_space_code `appOL` + assign_eax_sse_regs `appOL` + call `appOL` + assign_code dest_regs) + +-- ----------------------------------------------------------------------------- +-- Loading arguments into registers for 64-bit C calls. + +-- | Information needed to know how to pass arguments in a C call, +-- and in particular how to load them into registers. +data LoadArgs + = LoadArgs + -- | Arguments that should be passed on the stack + { stackArgs :: [RawStackArg] + -- | Additional values to store onto the stack. + , stackDataArgs :: [CmmExpr] + -- | Which registers are we using for argument passing? + , usedRegs :: [RegWithFormat] + -- | The code to assign arguments to registers used for argument passing. + , assignArgsCode :: InstrBlock + } +instance Semigroup LoadArgs where + LoadArgs a1 d1 r1 j1 <> LoadArgs a2 d2 r2 j2 + = LoadArgs (a1 ++ a2) (d1 ++ d2) (r1 ++ r2) (j1 S.<> j2) +instance Monoid LoadArgs where + mempty = LoadArgs [] [] [] nilOL + +-- | An argument passed on the stack, either directly or by reference. +-- +-- The padding information hasn't yet been computed (see 'StackArg'). +data RawStackArg + -- | Pass the argument on the stack directly. + = RawStackArg { stackArgExpr :: CmmExpr } + -- | Pass the argument by reference. + | RawStackArgRef + { stackRef :: StackRef + -- ^ is the reference passed in a register, or on the stack? + , stackRefArgSize :: Int + -- ^ the size of the data pointed to + } + deriving ( Show ) + +-- | An argument passed on the stack, either directly or by reference, +-- with additional padding information. +data StackArg + -- | Pass the argument on the stack directly. + = StackArg + { stackArgExpr :: CmmExpr + , stackArgPadding :: Int + -- ^ padding required (in bytes) + } + -- | Pass the argument by reference. + | StackArgRef + { stackRef :: StackRef + -- ^ where the reference is passed + , stackRefArgSize :: Int + -- ^ the size of the data pointed to + , stackRefArgPadding :: Int + -- ^ padding of the data pointed to + -- (the reference itself never requires padding) + } + deriving ( Show ) + +-- | Where is a reference to data on the stack passed? +data StackRef + -- | In a register. + = InReg Reg + -- | On the stack. + | OnStack + deriving ( Eq, Ord, Show ) + +newtype Padding = Padding { paddingBytes :: Int } + deriving ( Show, Eq, Ord ) + +-- | How much space does this 'StackArg' take up on the stack? +-- +-- Only counts the "reference" part for references, not the data it points to. +stackArgSpace :: Platform -> StackArg -> Int +stackArgSpace platform = \case + StackArg arg padding -> + argSize platform arg + padding + StackArgRef { stackRef = ref } -> + case ref of + InReg {} -> 0 + OnStack {} -> 8 + +-- | Pad arguments, assuming we start aligned to a 16-byte boundary. +-- +-- Returns padded arguments, together with whether we end up aligned +-- to a 16-byte boundary. +padStackArgs :: Platform + -> ([RawStackArg], [CmmExpr]) + -> ([StackArg], Bool) +padStackArgs platform (args0, data_args0) = + let + -- Pad the direct args + (args, align_16_mid) = pad_args True args0 + + -- Pad the data section + (data_args, align_16_end) = pad_args align_16_mid (map RawStackArg data_args0) + + -- Now figure out where the data is placed relative to the direct arguments, + -- in order to resolve references. + resolve_args :: [(RawStackArg, Padding)] -> [Padding] -> [StackArg] + resolve_args [] _ = [] + resolve_args ((stk_arg, Padding pad):rest) pads = + let (this_arg, pads') = + case stk_arg of + RawStackArg arg -> (StackArg arg pad, pads) + RawStackArgRef ref size -> case pads of + Padding arg_pad : rest_pads -> + let arg = StackArgRef + { stackRef = ref + , stackRefArgSize = size + , stackRefArgPadding = arg_pad } + in (arg, rest_pads) + _ -> panic "padStackArgs: no padding info found for StackArgRef" + in this_arg : resolve_args rest pads' + + in + ( resolve_args args (fmap snd data_args) ++ + [ case data_arg of + RawStackArg arg -> StackArg arg pad + RawStackArgRef {} -> panic "padStackArgs: reference in data section" + | (data_arg, Padding pad) <- data_args + ] + , align_16_end ) + + where + pad_args :: Bool -> [RawStackArg] -> ([(RawStackArg, Padding)], Bool) + pad_args aligned_16 [] = ([], aligned_16) + pad_args aligned_16 (arg:args) + | needed_alignment > 16 + -- We don't know if the stack is aligned to 8 (mod 32) or 24 (mod 32). + -- This makes aligning the stack to a 32 or 64 byte boundary more + -- complicated, in particular with DELTA. + = sorry $ unlines + [ "X86_86 C call: unsupported argument." + , " Alignment requirement: " ++ show needed_alignment ++ " bytes." + , if platformOS platform == OSMinGW32 + then " The X86_64 NCG does not (yet) support Windows C calls with 256/512 bit vectors." + else " The X86_64 NCG cannot (yet) pass 256/512 bit vectors on the stack for C calls." + , " Please use the LLVM backend (-fllvm)." ] + | otherwise + = let ( rest, final_align_16 ) = pad_args next_aligned_16 args + in ( (arg, Padding padding) : rest, final_align_16 ) + + where + needed_alignment = case arg of + RawStackArg arg -> argSize platform arg + RawStackArgRef {} -> platformWordSizeInBytes platform + padding + | needed_alignment < 16 || aligned_16 + = 0 + | otherwise + = 8 + next_aligned_16 = not ( aligned_16 && needed_alignment < 16 ) + +-- | Load arguments into available registers. +loadArgs :: NCGConfig -> [CmmExpr] -> NatM LoadArgs +loadArgs config args + | platformOS platform == OSMinGW32 + = evalStateT (loadArgsWin config args) (allArgRegs platform) + | otherwise + = evalStateT (loadArgsSysV config args) (allIntArgRegs platform + ,allFPArgRegs platform) + where + platform = ncgPlatform config + +-- | Load arguments into available registers (System V AMD64 ABI). +loadArgsSysV :: NCGConfig + -> [CmmExpr] + -> StateT ([Reg], [Reg]) NatM LoadArgs +loadArgsSysV _ [] = return mempty +loadArgsSysV config (arg:rest) = do + (iregs, fregs) <- get + -- No available registers: pass everything on the stack (shortcut). + if null iregs && null fregs + then return $ + LoadArgs + { stackArgs = map RawStackArg (arg:rest) + , stackDataArgs = [] + , assignArgsCode = nilOL + , usedRegs = [] + } + else do + mbReg <- + if + | isIntFormat arg_fmt + , ireg:iregs' <- iregs + -> do put (iregs', fregs) + return $ Just ireg + | isFloatFormat arg_fmt || isVecFormat arg_fmt + , freg:fregs' <- fregs + -> do put (iregs, fregs') + return $ Just freg + | otherwise + -> return Nothing + this_arg <- + case mbReg of + Just reg -> do + assign_code <- lift $ loadArgIntoReg arg reg + return $ + LoadArgs + { stackArgs = [] -- passed in register + , stackDataArgs = [] + , assignArgsCode = assign_code + , usedRegs = [RegWithFormat reg arg_fmt] + } + Nothing -> do + return $ + -- No available register for this argument: pass it on the stack. + LoadArgs + { stackArgs = [RawStackArg arg] + , stackDataArgs = [] + , assignArgsCode = nilOL + , usedRegs = [] + } + others <- loadArgsSysV config rest + return $ this_arg S.<> others + + where + platform = ncgPlatform config + arg_fmt = cmmTypeFormat (cmmExprType platform arg) + +-- | Compute all things that will need to be pushed to the stack. +-- +-- On Windows, an argument passed by reference will require two pieces of data: +-- +-- - the reference (returned in the first position) +-- - the actual data (returned in the second position) +computeWinPushArgs :: Platform -> [CmmExpr] -> ([RawStackArg], [CmmExpr]) +computeWinPushArgs platform = go + where + go :: [CmmExpr] -> ([RawStackArg], [CmmExpr]) + go [] = ([], []) + go (arg:args) = + let + arg_size = argSize platform arg + (this_arg, add_this_arg) + | arg_size > 8 + = ( RawStackArgRef OnStack arg_size, (arg :) ) + | otherwise + = ( RawStackArg arg, id ) + (stk_args, stk_data) = go args + in + (this_arg:stk_args, add_this_arg stk_data) + +-- | Load arguments into available registers (Windows C X64 calling convention). +loadArgsWin :: NCGConfig -> [CmmExpr] -> StateT [(Reg,Reg)] NatM LoadArgs +loadArgsWin _ [] = return mempty +loadArgsWin config (arg:rest) = do + regs <- get + case regs of + reg:regs' -> do + put regs' + this_arg <- lift $ load_arg_win reg + rest <- loadArgsWin config rest + return $ this_arg S.<> rest + [] -> do + -- No more registers available: pass all (remaining) arguments on the stack. + let (stk_args, data_args) = computeWinPushArgs platform (arg:rest) + return $ + LoadArgs + { stackArgs = stk_args + , stackDataArgs = data_args + , assignArgsCode = nilOL + , usedRegs = [] + } + where + platform = ncgPlatform config + arg_fmt = cmmTypeFormat $ cmmExprType platform arg + load_arg_win (ireg, freg) + | isVecFormat arg_fmt + -- Vectors are passed by reference. + -- See Note [The Windows X64 C calling convention]. + = do return $ + LoadArgs + -- Pass the reference in a register, + -- and the argument data on the stack. + { stackArgs = [RawStackArgRef (InReg ireg) (argSize platform arg)] + , stackDataArgs = [arg] -- we don't yet know where the data will reside, + , assignArgsCode = nilOL -- so we defer computing the reference and storing it + -- in the register until later + , usedRegs = [RegWithFormat ireg II64] + } + | otherwise + = do let arg_reg + | isFloatFormat arg_fmt + = freg + | otherwise + = ireg + assign_code <- loadArgIntoReg arg arg_reg + -- Recall that, for varargs, we must pass floating-point + -- arguments in both fp and integer registers. + let (assign_code', regs') + | isFloatFormat arg_fmt = + ( assign_code `snocOL` MOVD FF64 II64 (OpReg freg) (OpReg ireg), + [ RegWithFormat freg FF64 + , RegWithFormat ireg II64 ]) + | otherwise = (assign_code, [RegWithFormat ireg II64]) + return $ + LoadArgs + { stackArgs = [] -- passed in register + , stackDataArgs = [] + , assignArgsCode = assign_code' + , usedRegs = regs' + } + +-- | Load an argument into a register. +-- +-- Assumes that the expression does not contain any MachOps, +-- as per Note [Evaluate C-call arguments before placing in destination registers]. +loadArgIntoReg :: CmmExpr -> Reg -> NatM InstrBlock +loadArgIntoReg arg reg = do + when (debugIsOn && loadIntoRegMightClobberOtherReg arg) $ do + platform <- getPlatform + massertPpr False $ + vcat [ text "loadArgIntoReg: arg might contain MachOp" + , text "arg:" <+> pdoc platform arg ] + arg_code <- getAnyReg arg + return $ arg_code reg + +-- ----------------------------------------------------------------------------- +-- Pushing arguments onto the stack for 64-bit C calls. + +-- | The size of an argument (in bytes). +-- +-- Never smaller than the platform word width. +argSize :: Platform -> CmmExpr -> Int +argSize platform arg = + max (platformWordSizeInBytes platform) $ + widthInBytes (typeWidth $ cmmExprType platform arg) + +-- | Add the given amount of padding on the stack. +addStackPadding :: Int -- ^ padding (in bytes) + -> NatM InstrBlock +addStackPadding pad_bytes + | pad_bytes == 0 + = return nilOL + | otherwise + = do delta <- getDeltaNat + setDeltaNat (delta - pad_bytes) + return $ + toOL [ SUB II64 (OpImm (ImmInt pad_bytes)) (OpReg rsp) + , DELTA (delta - pad_bytes) + ] + +-- | Push one argument directly to the stack (by value). +-- +-- Assumes the current stack pointer fulfills any necessary alignment requirements. +pushArgByValue :: NCGConfig -> CmmExpr -> NatM InstrBlock +pushArgByValue config arg + -- For 64-bit integer arguments, use PUSH II64. + -- + -- Note: we *must not* do this for smaller arguments. + -- For example, if we tried to push an argument such as @CmmLoad addr W32 aln@, + -- we could end up reading unmapped memory and segfaulting. + | isIntFormat fmt + , formatInBytes fmt == 8 + = do + (arg_op, arg_code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + return $ + arg_code `appOL` toOL + [ PUSH II64 arg_op + , DELTA (delta-arg_size) ] + + | otherwise + = do + (arg_reg, arg_code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + return $ arg_code `appOL` toOL + [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp) + , DELTA (delta-arg_size) + , movInstr config fmt (OpReg arg_reg) (OpAddr (spRel platform 0)) ] + + where + platform = ncgPlatform config + arg_size = argSize platform arg + arg_rep = cmmExprType platform arg + fmt = cmmTypeFormat arg_rep + +-- | Load an argument into a register or push it to the stack. +loadOrPushArg :: NCGConfig -> (StackArg, Maybe Int) -> NatM (InstrBlock, InstrBlock) +loadOrPushArg config (stk_arg, mb_off) = + case stk_arg of + StackArg arg pad -> do + push_code <- pushArgByValue config arg + pad_code <- addStackPadding pad + return (nilOL, push_code `appOL` pad_code) + StackArgRef { stackRef = ref } -> + case ref of + -- Pass the reference in a register + InReg ireg -> + return (unitOL $ LEA II64 (OpAddr (spRel platform off)) (OpReg ireg), nilOL) + -- Pass the reference on the stack + OnStack {} -> do + tmp <- getNewRegNat II64 + delta <- getDeltaNat + setDeltaNat (delta-arg_ref_size) + let push_code = toOL + [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_ref_size)) (OpReg rsp) + , DELTA (delta-arg_ref_size) + , LEA II64 (OpAddr (spRel platform off)) (OpReg tmp) + , MOV II64 (OpReg tmp) (OpAddr (spRel platform 0)) ] + return (nilOL, push_code) + where off = expectJust mb_off + where + arg_ref_size = 8 -- passing a reference to the argument + platform = ncgPlatform config + +-- | Push arguments to the stack, right to left. +-- +-- On Windows, some arguments may need to be passed by reference, +-- which requires separately passing the data and the reference. +-- See Note [The Windows X64 C calling convention]. +pushArgs :: NCGConfig + -> [RawStackArg] + -- ^ arguments proper (i.e. don't include the data for arguments passed by reference) + -> [StackArg] + -- ^ arguments we are passing on the stack + -> NatM (InstrBlock, InstrBlock) +pushArgs config proper_args all_stk_args + = do { let + vec_offs :: [Maybe Int] + vec_offs + | platformOS platform == OSMinGW32 + = go stack_arg_size all_stk_args + | otherwise + = repeat Nothing + + --------------------- + -- Windows-only code + + -- Size of the arguments we are passing on the stack, counting only + -- the reference part for arguments passed by reference. + stack_arg_size = 8 * count not_in_reg proper_args + not_in_reg (RawStackArg {}) = True + not_in_reg (RawStackArgRef { stackRef = ref }) = + case ref of + InReg {} -> False + OnStack {} -> True + + -- Check an offset is valid (8-byte aligned), for assertions. + ok off = off `rem` 8 == 0 + + -- Tricky code: compute the stack offset to the vector data + -- for this argument. + -- + -- If you're confused, Note [The Windows X64 C calling convention] + -- contains a helpful diagram. + go :: Int -> [StackArg] -> [Maybe Int] + go _ [] = [] + go off (stk_arg:args) = + assertPpr (ok off) (text "unaligned offset:" <+> ppr off) $ + case stk_arg of + StackArg {} -> + -- Only account for the stack pointer movement. + let off' = off - stackArgSpace platform stk_arg + in Nothing : go off' args + StackArgRef + { stackRefArgSize = data_size + , stackRefArgPadding = data_pad } -> + assertPpr (ok data_size) (text "unaligned data size:" <+> ppr data_size) $ + assertPpr (ok data_pad) (text "unaligned data padding:" <+> ppr data_pad) $ + let off' = off + -- Next piece of data is after the data for this reference + + data_size + data_pad + -- ... and account for the stack pointer movement. + - stackArgSpace platform stk_arg + in Just (data_pad + off) : go off' args + + -- end of Windows-only code + ---------------------------- + + -- Push the stack arguments (right to left), + -- including both the reference and the data for arguments passed by reference. + ; (load_regs, push_args) <- foldMapM (loadOrPushArg config) (reverse $ zip all_stk_args vec_offs) + ; return (load_regs, push_args) } + where + platform = ncgPlatform config + +{- Note [The Windows X64 C calling convention] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here are a few facts about the Windows X64 C calling convention that +are important: + + - any argument larger than 8 bytes must be passed by reference, + and arguments smaller than 8 bytes are padded to 8 bytes. + + - the first four arguments are passed in registers: + - floating-point scalar arguments are passed in %xmm0, %xmm1, %xmm2, %xmm3 + - other arguments are passed in %rcx, %rdx, %r8, %r9 + (this includes vector arguments, passed by reference) + + For variadic functions, it is additionally expected that floating point + scalar arguments are copied to the corresponding integer register, e.g. + the data in xmm2 should also be copied to r8. + + There is no requirement about setting %al like there is for the + System V AMD64 ABI. + + - subsequent arguments are passed on the stack. + +There are also alignment requirements: + + - the data for vectors must be aligned to the size of the vector, + e.g. a 32 byte vector must be aligned on a 32 byte boundary, + + - the call instruction must be aligned to 16 bytes. + (This differs from the System V AMD64 ABI, which mandates that the call + instruction must be aligned to 32 bytes if there are any 32 byte vectors + passed on the stack.) + +This motivates our handling of vector values. Suppose we have a function call +with many arguments, several of them being vectors. We proceed as follows: + + - Add some padding, if necessary, to ensure the stack, when executing the call + instruction, is 16-byte aligned. Whether this padding is necessary depends + on what happens next. (Recall also that we start off at 8 (mod 16) alignment, + as per Note [Stack Alignment on X86] in rts/StgCRun.c) + - Push all the vectors to the stack first, adding padding after each one + if necessary. + - Then push the arguments: + - for non-vectors, proceed as usual, + - for vectors, push the address of the vector data we pushed above. + - Then assign the registers: + - for non-vectors, proceed as usual, + - for vectors, store the address in a general-purpose register, as opposed + to storing the data in an xmm register. + +For a concrete example, suppose we have a call of the form: + + f x1 x2 x3 x4 x5 x6 x7 + +in which: + + - x2, x3, x5 and x7 are 16 byte vectors + - the other arguments are all 8 byte wide + +Now, x1, x2, x3, x4 will get passed in registers, except that we pass +x2 and x3 by reference, because they are vectors. We proceed as follows: + + - push the vectors to the stack: x7, x5, x3, x2 (in that order) + - push the stack arguments in order: addr(x7), x6, addr(x5) + - load the remaining arguments into registers: x4, addr(x3), addr(x2), x1 + +The tricky part is to get the right offsets for the addresses of the vector +data. The following visualisation will hopefully clear things up: + + ┌──┐ + │▓▓│ ─── padding to align the call instruction + ╭─╴ ╞══╡ (ensures Sp, below, is 16-byte aligned) + │ │ │ + │ x7 ───╴ │ │ + │ ├──┤ + │ │ │ + │ x5 ───╴ │ │ + │ ├──┤ + vector data ────┤ │ │ +(individually padded) │ x3 ───╴ │ │ + │ ├──┤ + │ │ │ + │ x2 ───╴ │ │ + │ ├┄┄┤ + │ │▓▓│ ─── padding to align x2 to 16 bytes + ╭─╴ ╰─╴ ╞══╡ + │ addr(x7) ───╴ │ │ ╭─ from here: x7 is +64 + │ ├──┤ ╾──╯ = 64 (position of x5) + stack ───┤ x6 ───╴ │ │ + 16 (size of x5) + 0 (padding of x7) + arguments │ ├──┤ - 2 * 8 (x7 is 2 arguments higher than x5) + │ addr(x5) ───╴ │ │ + ╰─╴ ╭─╴ ╞══╡ ╾─── from here: + │ │ │ - x2 is +32 = 24 (stack_arg_size) + 8 (padding of x2) + shadow ───┤ │ │ - x3 is +48 = 32 (position of x2) + 16 (size of x2) + 0 (padding of x3) + space │ │ │ - x5 is +64 = 48 (position of x3) + 16 (size of x3) + 0 (padding of x5) + │ │ │ + ╰─╴ └──┘ ╾─── Sp + +This is all tested in the simd013 test. +-} + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +{- +Note [Sub-word subtlety during jump-table indexing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Offset the index by the start index of the jump table. +It's important that we do this *before* the widening below. To see +why, consider a switch with a sub-word, signed discriminant such as: + + switch [-5...+2] x::I16 { + case -5: ... + ... + case +2: ... + } + +Consider what happens if we offset *after* widening in the case that +x=-4: + + // x == -4 == 0xfffc::I16 + indexWidened = UU_Conv(x); // == 0xfffc::I64 + indexExpr = indexWidened - (-5); // == 0x10000::I64 + +This index is clearly nonsense given that the jump table only has +eight entries. + +By contrast, if we widen *after* we offset then we get the correct +index (1), + + // x == -4 == 0xfffc::I16 + indexOffset = x - (-5); // == 1::I16 + indexExpr = UU_Conv(indexOffset); // == 1::I64 + +See #21186. +-} + +genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock + +genSwitch expr targets = do + config <- getConfig + let platform = ncgPlatform config + expr_w = cmmExprWidth platform expr + indexExpr0 = cmmOffset platform expr offset + -- We widen to a native-width register because we cannot use arbitrary sizes + -- in x86 addressing modes. + -- See Note [Sub-word subtlety during jump-table indexing]. + indexExpr = CmmMachOp + (MO_UU_Conv expr_w (platformWordWidth platform)) + [indexExpr0] + if ncgPIC config + then do + (reg,e_code) <- getNonClobberedReg indexExpr + -- getNonClobberedReg because it needs to survive across t_code + lbl <- getNewLabelNat + let is32bit = target32Bit platform + os = platformOS platform + -- Might want to use .rodata. instead, but as + -- long as it's something unique it'll work out since the + -- references to the jump table are in the appropriate section. + rosection = case os of + -- on Mac OS X/x86_64, put the jump table in the text section to + -- work around a limitation of the linker. + -- ld64 is unable to handle the relocations for + -- .quad L1 - L0 + -- if L0 is not preceded by a non-anonymous label in its section. + OSDarwin | not is32bit -> Section Text lbl + _ -> Section ReadOnlyData lbl + dynRef <- cmmMakeDynamicReference config DataReference lbl + (tableReg,t_code) <- getSomeReg $ dynRef + let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) + (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) + + return $ e_code `appOL` t_code `appOL` toOL [ + ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids rosection lbl + ] + else do + (reg,e_code) <- getSomeReg indexExpr + lbl <- getNewLabelNat + let is32bit = target32Bit platform + if is32bit + then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl)) + jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl + in return $ e_code `appOL` unitOL jmp_code + else do + -- See Note [%rip-relative addressing on x86-64]. + tableReg <- getNewRegNat (intFormat (platformWordWidth platform)) + targetReg <- getNewRegNat (intFormat (platformWordWidth platform)) + let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) + fmt = archWordFormat is32bit + code = e_code `appOL` toOL + [ LEA fmt (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg) + , MOV fmt op (OpReg targetReg) + , JMP_TBL (OpReg targetReg) ids (Section ReadOnlyData lbl) lbl + ] + return code + where + (offset, blockIds) = switchTargetsToTable targets + ids = map (fmap DestBlockId) blockIds + +generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr) +generateJumpTableForInstr config (JMP_TBL _ ids section lbl) + = let getBlockId (DestBlockId id) = id + getBlockId _ = panic "Non-Label target in Jump Table" + blockIds = map (fmap getBlockId) ids + in Just (createJumpTable config blockIds section lbl) +generateJumpTableForInstr _ _ = Nothing + +createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel + -> GenCmmDecl (Alignment, RawCmmStatics) h g +createJumpTable config ids section lbl + = let jumpTable + | ncgPIC config = + let ww = ncgWordWidth config + jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 ww) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww) + where blockLabel = blockLbl blockid + in map jumpTableEntryRel ids + | otherwise = map (jumpTableEntry config) ids + in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable) + +extractUnwindPoints :: [Instr] -> [UnwindPoint] +extractUnwindPoints instrs = + [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs] + +-- ----------------------------------------------------------------------------- +-- 'condIntReg' and 'condFltReg': condition codes into registers + +-- Turn those condition codes into integers now (when they appear on +-- the right hand side of an assignment). +-- +-- (If applicable) Do not fill the delay slots here; you will confuse the +-- register allocator. + +condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register + +condIntReg cond x y = do + CondCode _ cond cond_code <- condIntCode cond x y + tmp <- getNewRegNat II8 + let + code dst = cond_code `appOL` toOL [ + SETCC cond (OpReg tmp), + MOVZxL II8 (OpReg tmp) (OpReg dst) + ] + return (Any II32 code) + + +-- Note [SSE Parity Checks] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- We have to worry about unordered operands (eg. comparisons +-- against NaN). If the operands are unordered, the comparison +-- sets the parity flag, carry flag and zero flag. +-- All comparisons are supposed to return false for unordered +-- operands except for !=, which returns true. +-- +-- Optimisation: we don't have to test the parity flag if we +-- know the test has already excluded the unordered case: eg > +-- and >= test for a zero carry flag, which can only occur for +-- ordered operands. +-- +-- By reversing comparisons we can avoid testing the parity +-- for < and <= as well. If any of the arguments is an NaN we +-- return false either way. If both arguments are valid then +-- x <= y <-> y >= x holds. So it's safe to swap these. +-- +-- We invert the condition inside getRegister'and getCondCode +-- which should cover all invertable cases. +-- All other functions translating FP comparisons to assembly +-- use these to two generate the comparison code. +-- +-- As an example consider a simple check: +-- +-- func :: Float -> Float -> Int +-- func x y = if x < y then 1 else 0 +-- +-- Which in Cmm gives the floating point comparison. +-- +-- if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf; +-- +-- We used to compile this to an assembly code block like this: +-- _c2gh: +-- ucomiss %xmm2,%xmm1 +-- jp _c2gf +-- jb _c2gg +-- jmp _c2gf +-- +-- Where we have to introduce an explicit +-- check for unordered results (using jmp parity): +-- +-- We can avoid this by exchanging the arguments and inverting the direction +-- of the comparison. This results in the sequence of: +-- +-- ucomiss %xmm1,%xmm2 +-- ja _c2g2 +-- jmp _c2g1 +-- +-- Removing the jump reduces the pressure on the branch prediction system +-- and plays better with the uOP cache. + +condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register +condFltReg is32Bit cond x y = condFltReg_sse2 + where + + + condFltReg_sse2 = do + CondCode _ cond cond_code <- condFltCode cond x y + tmp1 <- getNewRegNat (archWordFormat is32Bit) + tmp2 <- getNewRegNat (archWordFormat is32Bit) + let -- See Note [SSE Parity Checks] + code dst = + cond_code `appOL` + (case cond of + NE -> or_unordered dst + GU -> plain_test dst + GEU -> plain_test dst + -- Use ASSERT so we don't break releases if these creep in. + LTT -> assertPpr False (text "Should have been turned into >") $ + and_ordered dst + LE -> assertPpr False (text "Should have been turned into >=") $ + and_ordered dst + _ -> and_ordered dst) + + plain_test dst = toOL [ + SETCC cond (OpReg tmp1), + MOVZxL II8 (OpReg tmp1) (OpReg dst) + ] + or_unordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC PARITY (OpReg tmp2), + OR II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] + and_ordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC NOTPARITY (OpReg tmp2), + AND II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] + return (Any II32 code) + + +-- ----------------------------------------------------------------------------- +-- 'trivial*Code': deal with trivial instructions + +-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', +-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. +-- Only look for constants on the right hand side, because that's +-- where the generic optimizer will have put them. + +-- Similarly, for unary instructions, we don't have to worry about +-- matching an StInt as the argument, because genericOpt will already +-- have handled the constant-folding. + + +{- +The Rules of the Game are: + +* You cannot assume anything about the destination register dst; + it may be anything, including a fixed reg. + +* You may compute an operand into a fixed reg, but you may not + subsequently change the contents of that fixed reg. If you + want to do so, first copy the value either to a temporary + or into dst. You are free to modify dst even if it happens + to be a fixed reg -- that's not your problem. + +* You cannot assume that a fixed reg will stay live over an + arbitrary computation. The same applies to the dst reg. + +* Temporary regs obtained from getNewRegNat are distinct from + each other and from all other regs, and stay live over + arbitrary computations. + +-------------------- + +SDM's version of The Rules: + +* If getRegister returns Any, that means it can generate correct + code which places the result in any register, period. Even if that + register happens to be read during the computation. + + Corollary #1: this means that if you are generating code for an + operation with two arbitrary operands, you cannot assign the result + of the first operand into the destination register before computing + the second operand. The second operand might require the old value + of the destination register. + + Corollary #2: A function might be able to generate more efficient + code if it knows the destination register is a new temporary (and + therefore not read by any of the sub-computations). + +* If getRegister returns Any, then the code it generates may modify only: + (a) fresh temporaries + (b) the destination register + (c) known registers (eg. %ecx is used by shifts) + In particular, it may *not* modify global registers, unless the global + register happens to be the destination register. +-} + +trivialCode :: Width -> (Operand -> Operand -> Instr) + -> Maybe (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCode width instr m a b + = do platform <- getPlatform + trivialCode' platform width instr m a b + +trivialCode' :: Platform -> Width -> (Operand -> Operand -> Instr) + -> Maybe (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCode' platform width _ (Just revinstr) (CmmLit lit_a) b + | is32BitLit platform lit_a = do + b_code <- getAnyReg b + let + code dst + = b_code dst `snocOL` + revinstr (OpImm (litToImm lit_a)) (OpReg dst) + return (Any (intFormat width) code) + +trivialCode' _ width instr _ a b + = genTrivialCode (intFormat width) (\op2 -> instr op2 . OpReg) a b + +-- This is re-used for floating pt instructions too. +genTrivialCode :: Format -> (Operand -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +genTrivialCode rep instr a b = do + (b_op, b_code) <- getNonClobberedOperand b + a_code <- getAnyReg a + tmp <- getNewRegNat rep + let + -- We want the value of 'b' to stay alive across the computation of 'a'. + -- But, we want to calculate 'a' straight into the destination register, + -- because the instruction only has two operands (dst := dst `op` src). + -- The troublesome case is when the result of 'b' is in the same register + -- as the destination 'reg'. In this case, we have to save 'b' in a + -- new temporary across the computation of 'a'. + code dst + | dst `regClashesWithOp` b_op = + b_code `appOL` + unitOL (MOV rep b_op (OpReg tmp)) `appOL` + a_code dst `snocOL` + instr (OpReg tmp) dst + | otherwise = + b_code `appOL` + a_code dst `snocOL` + instr b_op dst + return (Any rep code) + +regClashesWithOp :: Reg -> Operand -> Bool +reg `regClashesWithOp` OpReg reg2 = reg == reg2 +reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) +_ `regClashesWithOp` _ = False + +-- | Generate code for a fused multiply-add operation, of the form @± x * y ± z@, +-- with 3 operands (FMA3 instruction set). +genFMA3Code :: Length + -> Width + -> FMASign + -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register +genFMA3Code l w signs x y z = do + config <- getConfig + -- For the FMA instruction, we want to compute x * y + z + -- + -- There are three possible instructions we could emit: + -- + -- - fmadd213 z y x, result in x, z can be a memory address + -- - fmadd132 x z y, result in y, x can be a memory address + -- - fmadd231 y x z, result in z, y can be a memory address + -- + -- This suggests two possible optimisations: + -- + -- - OPTIMISATION 1 + -- If one argument is an address, use the instruction that allows + -- a memory address in that position. + -- + -- - OPTIMISATION 2 + -- If one argument is in a fixed register, use the instruction that puts + -- the result in that same register. + -- + -- Currently we follow neither of these optimisations, + -- opting to always use fmadd213 for simplicity. + -- + -- We would like to compute the result directly into the requested register. + -- To do so we must first compute `x` into the destination register. This is + -- only possible if the other arguments don't use the destination register. + -- We check for this and if there is a conflict we move the result only after + -- the computation. See #24496 how this went wrong in the past. + let rep + | l == 1 + = floatFormat w + | otherwise + = vecFormat (cmmVec l $ cmmFloat w) + (y_reg, y_code) <- getNonClobberedReg y + (z_op, z_code) <- getNonClobberedOperand z + x_code <- getAnyReg x + x_tmp <- getNewRegNat rep + let + fma213 = FMA3 rep signs FMA213 + + code, code_direct, code_mov :: Reg -> InstrBlock + -- Ideal: Compute the result directly into dst + code_direct dst = x_code dst `snocOL` + fma213 z_op y_reg dst + -- Fallback: Compute the result into a tmp reg and then move it. + code_mov dst = x_code x_tmp `snocOL` + fma213 z_op y_reg x_tmp `snocOL` + mkRegRegMoveInstr config rep x_tmp dst + + code dst = + y_code `appOL` + z_code `appOL` + ( if arg_regs_conflict then code_mov dst else code_direct dst ) + + where + + arg_regs_conflict = + y_reg == dst || + case z_op of + OpReg z_reg -> z_reg == dst + OpAddr amode -> dst `elem` addrModeRegs amode + OpImm {} -> False + + -- NB: Computing the result into a desired register using Any can be tricky. + -- So for now, we keep it simple. (See #24496). + return (Any rep code) + +----------- + +trivialUCode :: Format -> (Operand -> Instr) + -> CmmExpr -> NatM Register +trivialUCode rep instr x = do + x_code <- getAnyReg x + let + code dst = + x_code dst `snocOL` + instr (OpReg dst) + return (Any rep code) + +----------- + + +trivialFCode_sse2 :: Width -> (Format -> Operand -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialFCode_sse2 ty instr x y + = genTrivialCode format (instr format) x y + where format = floatFormat ty + + +-------------------------------------------------------------------------------- +coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register +coerceInt2FP from to x = coerce_sse2 + where + + coerce_sse2 = do + (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand + let + opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD + n -> panic $ "coerceInt2FP.sse: unhandled width (" + ++ show n ++ ")" + code dst = x_code `snocOL` opc (intFormat from) x_op dst + return (Any (floatFormat to) code) + -- works even if the destination rep is 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 CmmExpr -> NatM Register +coerceFP2FP to x = do + (x_reg, x_code) <- getSomeReg x + let + opc = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD; + n -> panic $ "coerceFP2FP: unhandled width (" + ++ show n ++ ")" + code dst = x_code `snocOL` opc x_reg dst + return (Any ( floatFormat to) code) + +-------------------------------------------------------------------------------- + +sse2NegCode :: Width -> CmmExpr -> NatM Register +sse2NegCode w x = do + let fmt = floatFormat w + x_code <- getAnyReg x + -- This is how gcc does it, so it can't be that bad: + let + const = case fmt of + FF32 -> CmmInt 0x80000000 W32 + FF64 -> CmmInt 0x8000000000000000 W64 + x@II8 -> wrongFmt x + x@II16 -> wrongFmt x + x@II32 -> wrongFmt x + x@II64 -> wrongFmt x + x@(VecFormat {}) -> wrongFmt x + + where + wrongFmt x = panic $ "sse2NegCode: " ++ show x + Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const + tmp <- getNewRegNat fmt + let + code dst = x_code dst `appOL` amode_code `appOL` toOL [ + MOV fmt (OpAddr amode) (OpReg tmp), + XOR fmt (OpReg tmp) (OpReg dst) + ] + -- + return (Any fmt code) + +needLlvm :: MachOp -> NatM a +needLlvm mop = + sorry $ unlines [ "Unsupported vector instruction for the native code generator:" + , show mop + , "Please use -fllvm." ] + +incorrectOperands :: NatM a +incorrectOperands = sorry "Incorrect number of operands" + +invalidConversion :: Width -> Width -> NatM a +invalidConversion from to = + sorry $ "Invalid conversion operation from " ++ show from ++ " to " ++ show to + +-- | This works on the invariant that all jumps in the given blocks are required. +-- Starting from there we try to make a few more jumps redundant by reordering +-- them. +-- We depend on the information in the CFG to do so so without a given CFG +-- we do nothing. +invertCondBranches :: Maybe CFG -- ^ CFG if present + -> LabelMap a -- ^ Blocks with info tables + -> [NatBasicBlock Instr] -- ^ List of basic blocks + -> [NatBasicBlock Instr] +invertCondBranches Nothing _ bs = bs +invertCondBranches (Just cfg) keep bs = + invert bs + where + invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr] + invert (BasicBlock lbl1 ins:b2@(BasicBlock lbl2 _):bs) + | --pprTrace "Block" (ppr lbl1) True, + Just (jmp1,jmp2) <- last2 ins + , JXX cond1 target1 <- jmp1 + , target1 == lbl2 + --, pprTrace "CutChance" (ppr b1) True + , JXX ALWAYS target2 <- jmp2 + -- We have enough information to check if we can perform the inversion + -- TODO: We could also check for the last asm instruction which sets + -- status flags instead. Which I suspect is worse in terms of compiler + -- performance, but might be applicable to more cases + , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg + , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg + -- Both jumps come from the same cmm statement + , transitionSource edgeInfo1 == transitionSource edgeInfo2 + , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1 + + --Int comparisons are invertable + , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch + , Just _ <- maybeIntComparison op + , Just invCond <- maybeInvertCond cond1 + + --Swap the last two jumps, invert the conditional jumps condition. + = let jumps = + case () of + -- We are free the eliminate the jmp. So we do so. + _ | not (mapMember target1 keep) + -> [JXX invCond target2] + -- If the conditional target is unlikely we put the other + -- target at the front. + | edgeWeight edgeInfo2 > edgeWeight edgeInfo1 + -> [JXX invCond target2, JXX ALWAYS target1] + -- Keep things as-is otherwise + | otherwise + -> [jmp1, jmp2] + in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $ + (BasicBlock lbl1 + (dropTail 2 ins ++ jumps)) + : invert (b2:bs) + invert (b:bs) = b : invert bs + invert [] = [] + +genAtomicRMW + :: BlockId + -> Width + -> AtomicMachOp + -> LocalReg + -> CmmExpr + -> CmmExpr + -> NatM (InstrBlock, Maybe BlockId) +genAtomicRMW bid width amop dst addr n = do + Amode amode addr_code <- + if amop `elem` [AMO_Add, AMO_Sub] + then getAmode addr + else getSimpleAmode addr -- See genForeignCall for MO_Cmpxchg + arg <- getNewRegNat format + arg_code <- getAnyReg n + platform <- ncgPlatform <$> getConfig + + let dst_r = getRegisterReg platform (CmmLocal dst) + (code, lbl) <- op_code dst_r arg amode + return (addr_code `appOL` arg_code arg `appOL` code, Just lbl) + where + -- Code for the operation + op_code :: Reg -- Destination reg + -> Reg -- Register containing argument + -> AddrMode -- Address of location to mutate + -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId + op_code dst_r arg amode = do + case amop of + -- In the common case where dst_r is a virtual register the + -- final move should go away, because it's the last use of arg + -- and the first use of dst_r. + AMO_Add -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode)) + , MOV format (OpReg arg) (OpReg dst_r) + ], bid) + AMO_Sub -> return $ (toOL [ NEGI format (OpReg arg) + , LOCK (XADD format (OpReg arg) (OpAddr amode)) + , MOV format (OpReg arg) (OpReg dst_r) + ], bid) + -- In these cases we need a new block id, and have to return it so + -- that later instruction selection can reference it. + AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst) + AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst + , NOT format dst + ]) + AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst) + AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst) + where + -- Simulate operation that lacks a dedicated instruction using + -- cmpxchg. + cmpxchg_code :: (Operand -> Operand -> OrdList Instr) + -> NatM (OrdList Instr, BlockId) + cmpxchg_code instrs = do + lbl1 <- getBlockIdNat + lbl2 <- getBlockIdNat + tmp <- getNewRegNat format + + --Record inserted blocks + -- We turn A -> B into A -> A' -> A'' -> B + -- with a self loop on A'. + addImmediateSuccessorNat bid lbl1 + addImmediateSuccessorNat lbl1 lbl2 + updateCfgNat (addWeightEdge lbl1 lbl1 0) + + return $ (toOL + [ MOV format (OpAddr amode) (OpReg eax) + , JXX ALWAYS lbl1 + , NEWBLOCK lbl1 + -- Keep old value so we can return it: + , MOV format (OpReg eax) (OpReg dst_r) + , MOV format (OpReg eax) (OpReg tmp) + ] + `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL + [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode)) + , JXX NE lbl1 + -- See Note [Introducing cfg edges inside basic blocks] + -- why this basic block is required. + , JXX ALWAYS lbl2 + , NEWBLOCK lbl2 + ], + lbl2) + format = intFormat width + +-- | Count trailing zeroes +genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId) +genCtz bid width dst src = do + is32Bit <- is32BitPlatform + if is32Bit && width == W64 + then genCtz64_32 bid dst src + else (,Nothing) <$> genCtzGeneric width dst src + +-- | Count trailing zeroes +-- +-- 64-bit width on 32-bit architecture +genCtz64_32 + :: BlockId + -> LocalReg + -> CmmExpr + -> NatM (InstrBlock, Maybe BlockId) +genCtz64_32 bid dst src = do + RegCode64 vcode rhi rlo <- iselExpr64 src + let dst_r = getLocalRegReg dst + lbl1 <- getBlockIdNat + lbl2 <- getBlockIdNat + tmp_r <- getNewRegNat II64 + + -- New CFG Edges: + -- bid -> lbl2 + -- bid -> lbl1 -> lbl2 + -- We also changes edges originating at bid to start at lbl2 instead. + weights <- getCfgWeights + updateCfgNat (addWeightEdge bid lbl1 110 . + addWeightEdge lbl1 lbl2 110 . + addImmediateSuccessor weights bid lbl2) + + -- The following instruction sequence corresponds to the pseudo-code + -- + -- if (src) { + -- dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32); + -- } else { + -- dst = 64; + -- } + let instrs = vcode `appOL` toOL + ([ MOV II32 (OpReg rhi) (OpReg tmp_r) + , OR II32 (OpReg rlo) (OpReg tmp_r) + , MOV II32 (OpImm (ImmInt 64)) (OpReg dst_r) + , JXX EQQ lbl2 + , JXX ALWAYS lbl1 + + , NEWBLOCK lbl1 + , BSF II32 (OpReg rhi) dst_r + , ADD II32 (OpImm (ImmInt 32)) (OpReg dst_r) + , BSF II32 (OpReg rlo) tmp_r + , CMOV NE II32 (OpReg tmp_r) dst_r + , JXX ALWAYS lbl2 + + , NEWBLOCK lbl2 + ]) + return (instrs, Just lbl2) + +-- | Count trailing zeroes +-- +-- Generic case (width <= word size) +genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genCtzGeneric width dst src = do + code_src <- getAnyReg src + config <- getConfig + let bw = widthInBits width + let dst_r = getLocalRegReg dst + if ncgBmiVersion config >= Just BMI2 + then do + src_r <- getNewRegNat (intFormat width) + let instrs = appOL (code_src src_r) $ case width of + W8 -> toOL + [ OR II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r) + , TZCNT II32 (OpReg src_r) dst_r + ] + W16 -> toOL + [ TZCNT II16 (OpReg src_r) dst_r + , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) + ] + _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r + return instrs + else do + -- The following insn sequence makes sure 'ctz 0' has a defined value. + -- starting with Haswell, one could use the TZCNT insn instead. + let format = if width == W8 then II16 else intFormat width + src_r <- getNewRegNat format + tmp_r <- getNewRegNat format + let instrs = code_src src_r `appOL` toOL + ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ + [ BSF format (OpReg src_r) tmp_r + , MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r) + , CMOV NE format (OpReg tmp_r) dst_r + ]) -- NB: We don't need to zero-extend the result for the + -- W8/W16 cases because the 'MOV' insn already + -- took care of implicitly clearing the upper bits + return instrs + + + +-- | Copy memory +-- +-- Unroll memcpy calls if the number of bytes to copy isn't too large (cf +-- ncgInlineThresholdMemcpy). Otherwise, call C's memcpy. +genMemCpy + :: BlockId + -> Int + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM InstrBlock +genMemCpy bid align dst src arg_n = do + + let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n] + + case arg_n of + CmmLit (CmmInt n _) -> do + -- try to inline it + mcode <- genMemCpyInlineMaybe align dst src n + -- if it didn't inline, call the C function + case mcode of + Nothing -> libc_memcpy + Just c -> pure c + + -- not a literal size argument: call the C function + _ -> libc_memcpy + + + +genMemCpyInlineMaybe + :: Int + -> CmmExpr + -> CmmExpr + -> Integer + -> NatM (Maybe InstrBlock) +genMemCpyInlineMaybe align dst src n = do + config <- getConfig + let + platform = ncgPlatform config + maxAlignment = wordAlignment platform + -- only machine word wide MOVs are supported + effectiveAlignment = min (alignmentOf align) maxAlignment + format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment + + + -- The size of each move, in bytes. + let sizeBytes :: Integer + sizeBytes = fromIntegral (formatInBytes format) + + -- The number of instructions we will generate (approx). We need 2 + -- instructions per move. + let insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes) + + go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr + go dst src tmp i + | i >= sizeBytes = + unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - sizeBytes) + -- Deal with remaining bytes. + | i >= 4 = -- Will never happen on 32-bit + unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 4) + | i >= 2 = + unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 2) + | i >= 1 = + unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 1) + | otherwise = nilOL + where + src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone + (ImmInteger (n - i)) + + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone + (ImmInteger (n - i)) + + if insns > fromIntegral (ncgInlineThresholdMemcpy config) + then pure Nothing + else do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat format + code_src <- getAnyReg src + src_r <- getNewRegNat format + tmp_r <- getNewRegNat format + pure $ Just $ code_dst dst_r `appOL` code_src src_r `appOL` + go dst_r src_r tmp_r (fromInteger n) + +-- | Set memory to the given byte +-- +-- Unroll memset calls if the number of bytes to copy isn't too large (cf +-- ncgInlineThresholdMemset). Otherwise, call C's memset. +genMemSet + :: BlockId + -> Int + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM InstrBlock +genMemSet bid align dst arg_c arg_n = do + + let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n] + + case (arg_c,arg_n) of + (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do + -- try to inline it + mcode <- genMemSetInlineMaybe align dst c n + -- if it didn't inline, call the C function + case mcode of + Nothing -> libc_memset + Just c -> pure c + + -- not literal size arguments: call the C function + _ -> libc_memset + +genMemSetInlineMaybe + :: Int + -> CmmExpr + -> Integer + -> Integer + -> NatM (Maybe InstrBlock) +genMemSetInlineMaybe align dst c n = do + config <- getConfig + let + platform = ncgPlatform config + maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported + effectiveAlignment = min (alignmentOf align) maxAlignment + format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment + c2 = c `shiftL` 8 .|. c + c4 = c2 `shiftL` 16 .|. c2 + c8 = c4 `shiftL` 32 .|. c4 + + -- The number of instructions we will generate (approx). We need 1 + -- instructions per move. + insns = (n + sizeBytes - 1) `div` sizeBytes + + -- The size of each move, in bytes. + sizeBytes :: Integer + sizeBytes = fromIntegral (formatInBytes format) + + -- Depending on size returns the widest MOV instruction and its + -- width. + gen4 :: AddrMode -> Integer -> (InstrBlock, Integer) + gen4 addr size + | size >= 4 = + (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4) + | size >= 2 = + (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2) + | size >= 1 = + (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1) + | otherwise = (nilOL, 0) + + -- Generates a 64-bit wide MOV instruction from REG to MEM. + gen8 :: AddrMode -> Reg -> InstrBlock + gen8 addr reg8byte = + unitOL (MOV format (OpReg reg8byte) (OpAddr addr)) + + -- Unrolls memset when the widest MOV is <= 4 bytes. + go4 :: Reg -> Integer -> InstrBlock + go4 dst left = + if left <= 0 then nilOL + else curMov `appOL` go4 dst (left - curWidth) + where + possibleWidth = min left sizeBytes + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left)) + (curMov, curWidth) = gen4 dst_addr possibleWidth + + -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg + -- argument). Falls back to go4 when all 8 byte moves are + -- exhausted. + go8 :: Reg -> Reg -> Integer -> InstrBlock + go8 dst reg8byte left = + if possibleWidth >= 8 then + let curMov = gen8 dst_addr reg8byte + in curMov `appOL` go8 dst reg8byte (left - 8) + else go4 dst left + where + possibleWidth = min left sizeBytes + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left)) + + if fromInteger insns > ncgInlineThresholdMemset config + then pure Nothing + else do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat format + if format == II64 && n >= 8 + then do + code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64)) + imm8byte_r <- getNewRegNat II64 + return $ Just $ code_dst dst_r `appOL` + code_imm8byte imm8byte_r `appOL` + go8 dst_r imm8byte_r (fromInteger n) + else + return $ Just $ code_dst dst_r `appOL` + go4 dst_r (fromInteger n) + + +genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock +genMemMove bid _align dst src n = do + -- TODO: generate inline assembly when under a given threshold (similarly to + -- memcpy and memset) + genLibCCall bid (fsLit "memmove") [] [dst,src,n] + +genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock +genMemCmp bid _align res dst src n = do + -- TODO: generate inline assembly when under a given threshold (similarly to + -- memcpy and memset) + genLibCCall bid (fsLit "memcmp") [res] [dst,src,n] + +genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr) +genPrefetchData n src = do + is32Bit <- is32BitPlatform + let + format = archWordFormat is32Bit + -- need to know what register width for pointers! + genPrefetch inRegSrc prefetchCTor = do + code_src <- getAnyReg inRegSrc + src_r <- getNewRegNat format + return $ code_src src_r `appOL` + (unitOL (prefetchCTor (OpAddr + ((AddrBaseIndex (EABaseReg src_r ) EAIndexNone (ImmInt 0)))) )) + -- prefetch always takes an address + + -- the c / llvm prefetch convention is 0, 1, 2, and 3 + -- the x86 corresponding names are : NTA, 2 , 1, and 0 + case n of + 0 -> genPrefetch src $ PREFETCH NTA format + 1 -> genPrefetch src $ PREFETCH Lvl2 format + 2 -> genPrefetch src $ PREFETCH Lvl1 format + 3 -> genPrefetch src $ PREFETCH Lvl0 format + l -> pprPanic "genPrefetchData: unexpected prefetch level" (ppr l) + +genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genByteSwap width dst src = do + is32Bit <- is32BitPlatform + let format = intFormat width + case width of + W64 | is32Bit -> do + let Reg64 dst_hi dst_lo = localReg64 dst + RegCode64 vcode rhi rlo <- iselExpr64 src + tmp <- getNewRegNat II32 + -- Swap the low and high halves of the register. + -- + -- NB: if dst_hi == rhi, we must make sure to preserve the contents + -- of rhi before writing to dst_hi (#25601). + let shuffle = if dst_hi == rhi && dst_lo == rlo then + toOL [ MOV II32 (OpReg rhi) (OpReg tmp), + MOV II32 (OpReg rlo) (OpReg dst_hi), + MOV II32 (OpReg tmp) (OpReg dst_lo) ] + else if dst_hi == rhi then + toOL [ MOV II32 (OpReg rhi) (OpReg dst_lo), + MOV II32 (OpReg rlo) (OpReg dst_hi) ] + else + toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi), + MOV II32 (OpReg rhi) (OpReg dst_lo) ] + return $ vcode `appOL` shuffle `appOL` + toOL [ BSWAP II32 dst_hi, + BSWAP II32 dst_lo ] + W16 -> do + let dst_r = getLocalRegReg dst + code_src <- getAnyReg src + return $ code_src dst_r `appOL` + unitOL (BSWAP II32 dst_r) `appOL` + unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r)) + _ -> do + let dst_r = getLocalRegReg dst + code_src <- getAnyReg src + return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r) + +genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock +genBitRev bid width dst src = do + -- Here the C implementation (hs_bitrevN) is used as there is no x86 + -- instruction to reverse a word's bit order. + genPrimCCall bid (bRevLabel width) [dst] [src] + +genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genPopCnt bid width dst src = do + config <- getConfig + let + platform = ncgPlatform config + format = intFormat width + + sse4_2Enabled >>= \case + + True -> do + code_src <- getAnyReg src + src_r <- getNewRegNat format + let dst_r = getRegisterReg platform (CmmLocal dst) + return $ code_src src_r `appOL` + (if width == W8 then + -- The POPCNT instruction doesn't take a r/m8 + unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL` + unitOL (POPCNT II16 (OpReg src_r) dst_r) + else + unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL` + (if width == W8 || width == W16 then + -- We used a 16-bit destination register above, + -- so zero-extend + unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) + else nilOL) + + False -> + -- generate C call to hs_popcntN in ghc-prim + -- TODO: we could directly generate the assembly to index popcount_tab + -- here instead of doing it by calling a C function + genPrimCCall bid (popCntLabel width) [dst] [src] + + +genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock +genPdep bid width dst src mask = do + config <- getConfig + let + platform = ncgPlatform config + format = intFormat width + + if ncgBmiVersion config >= Just BMI2 + then do + code_src <- getAnyReg src + code_mask <- getAnyReg mask + src_r <- getNewRegNat format + mask_r <- getNewRegNat format + let dst_r = getRegisterReg platform (CmmLocal dst) + return $ code_src src_r `appOL` code_mask mask_r `appOL` + -- PDEP only supports > 32 bit args + ( if width == W8 || width == W16 then + toOL + [ MOVZxL format (OpReg src_r ) (OpReg src_r ) + , MOVZxL format (OpReg mask_r) (OpReg mask_r) + , PDEP II32 (OpReg mask_r) (OpReg src_r ) dst_r + , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width + ] + else + unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r) + ) + else + -- generate C call to hs_pdepN in ghc-prim + genPrimCCall bid (pdepLabel width) [dst] [src,mask] + + +genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock +genPext bid width dst src mask = do + config <- getConfig + if ncgBmiVersion config >= Just BMI2 + then do + let format = intFormat width + let dst_r = getLocalRegReg dst + code_src <- getAnyReg src + code_mask <- getAnyReg mask + src_r <- getNewRegNat format + mask_r <- getNewRegNat format + return $ code_src src_r `appOL` code_mask mask_r `appOL` + (if width == W8 || width == W16 then + -- The PEXT instruction doesn't take a r/m8 or 16 + toOL + [ MOVZxL format (OpReg src_r ) (OpReg src_r ) + , MOVZxL format (OpReg mask_r) (OpReg mask_r) + , PEXT II32 (OpReg mask_r) (OpReg src_r ) dst_r + , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width + ] + else + unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r) + ) + else + -- generate C call to hs_pextN in ghc-prim + genPrimCCall bid (pextLabel width) [dst] [src,mask] + +genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock +genClz bid width dst src = do + is32Bit <- is32BitPlatform + config <- getConfig + if is32Bit && width == W64 + + then + -- Fallback to `hs_clz64` on i386 + genPrimCCall bid (clzLabel width) [dst] [src] + + else do + code_src <- getAnyReg src + let dst_r = getLocalRegReg dst + if ncgBmiVersion config >= Just BMI2 + then do + src_r <- getNewRegNat (intFormat width) + return $ appOL (code_src src_r) $ case width of + W8 -> toOL + [ MOVZxL II8 (OpReg src_r) (OpReg src_r) -- zero-extend to 32 bit + , LZCNT II32 (OpReg src_r) dst_r -- lzcnt with extra 24 zeros + , SUB II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros + ] + W16 -> toOL + [ LZCNT II16 (OpReg src_r) dst_r + , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit + ] + _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r) + else do + let format = if width == W8 then II16 else intFormat width + let bw = widthInBits width + src_r <- getNewRegNat format + tmp_r <- getNewRegNat format + return $ code_src src_r `appOL` toOL + ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ + [ BSR format (OpReg src_r) tmp_r + , MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r) + , CMOV NE format (OpReg tmp_r) dst_r + , XOR format (OpImm (ImmInt (bw-1))) (OpReg dst_r) + ]) -- NB: We don't need to zero-extend the result for the + -- W8/W16 cases because the 'MOV' insn already + -- took care of implicitly clearing the upper bits + +genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock +genWordToFloat bid width dst src = + -- TODO: generate assembly instead + genPrimCCall bid (word2FloatLabel width) [dst] [src] + +genAtomicRead :: Width -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock +genAtomicRead width _mord dst addr = do + let fmt = intFormat width + load_code <- intLoadCode (MOV fmt) addr + return (load_code (getLocalRegReg dst)) + +genAtomicWrite :: Width -> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM InstrBlock +genAtomicWrite width mord addr val = do + code <- assignMem_IntCode (intFormat width) addr val + let needs_fence = case mord of + MemOrderSeqCst -> True + MemOrderRelease -> False + MemOrderAcquire -> pprPanic "genAtomicWrite: acquire ordering on write" empty + MemOrderRelaxed -> False + return $ if needs_fence then code `snocOL` MFENCE else code + +genCmpXchg + :: BlockId + -> Width + -> LocalReg + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM InstrBlock +genCmpXchg bid width dst addr old new = do + is32Bit <- is32BitPlatform + -- On x86 we don't have enough registers to use cmpxchg with a + -- complicated addressing mode, so on that architecture we + -- pre-compute the address first. + if not (is32Bit && width == W64) + then do + let format = intFormat width + Amode amode addr_code <- getSimpleAmode addr + newval <- getNewRegNat format + newval_code <- getAnyReg new + oldval <- getNewRegNat format + oldval_code <- getAnyReg old + platform <- getPlatform + let dst_r = getRegisterReg platform (CmmLocal dst) + code = toOL + [ MOV format (OpReg oldval) (OpReg eax) + , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode)) + , MOV format (OpReg eax) (OpReg dst_r) + ] + return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval + `appOL` code + else + -- generate C call to hs_cmpxchgN in ghc-prim + genPrimCCall bid (cmpxchgLabel width) [dst] [addr,old,new] + -- TODO: implement cmpxchg8b instruction + +genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock +genXchg width dst addr value = do + is32Bit <- is32BitPlatform + + when (is32Bit && width == W64) $ + panic "genXchg: 64bit atomic exchange not supported on 32bit platforms" + + Amode amode addr_code <- getSimpleAmode addr + (newval, newval_code) <- getSomeReg value + let format = intFormat width + let dst_r = getLocalRegReg dst + -- Copy the value into the target register, perform the exchange. + let code = toOL + [ MOV format (OpReg newval) (OpReg dst_r) + -- On X86 xchg implies a lock prefix if we use a memory argument. + -- so this is atomic. + , XCHG format (OpAddr amode) dst_r + ] + return $ addr_code `appOL` newval_code `appOL` code + + +genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genFloatAbs width dst src = do + let + format = floatFormat width + const = case width of + W32 -> CmmInt 0x7fffffff W32 + W64 -> CmmInt 0x7fffffffffffffff W64 + _ -> pprPanic "genFloatAbs: invalid width" (ppr width) + src_code <- getAnyReg src + Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes width) const + tmp <- getNewRegNat format + let dst_r = getLocalRegReg dst + pure $ src_code dst_r `appOL` amode_code `appOL` toOL + [ MOV format (OpAddr amode) (OpReg tmp) + , AND format (OpReg tmp) (OpReg dst_r) + ] + + +genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock +genFloatSqrt format dst src = do + let dst_r = getLocalRegReg dst + src_code <- getAnyReg src + pure $ src_code dst_r `snocOL` SQRT format (OpReg dst_r) dst_r + + +genAddSubRetCarry + :: Width + -> (Format -> Operand -> Operand -> Instr) + -> (Format -> Maybe (Operand -> Operand -> Instr)) + -> Cond + -> LocalReg + -> LocalReg + -> CmmExpr + -> CmmExpr + -> NatM InstrBlock +genAddSubRetCarry width instr mrevinstr cond res_r res_c arg_x arg_y = do + platform <- ncgPlatform <$> getConfig + let format = intFormat width + rCode <- anyReg =<< trivialCode width (instr format) + (mrevinstr format) arg_x arg_y + reg_tmp <- getNewRegNat II8 + let reg_c = getRegisterReg platform (CmmLocal res_c) + reg_r = getRegisterReg platform (CmmLocal res_r) + code = rCode reg_r `snocOL` + SETCC cond (OpReg reg_tmp) `snocOL` + MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c) + return code + + +genAddWithCarry + :: Width + -> LocalReg + -> LocalReg + -> CmmExpr + -> CmmExpr + -> NatM InstrBlock +genAddWithCarry width res_h res_l arg_x arg_y = do + hCode <- getAnyReg (CmmLit (CmmInt 0 width)) + let format = intFormat width + lCode <- anyReg =<< trivialCode width (ADD_CC format) + (Just (ADD_CC format)) arg_x arg_y + let reg_l = getLocalRegReg res_l + reg_h = getLocalRegReg res_h + code = hCode reg_h `appOL` + lCode reg_l `snocOL` + ADC format (OpImm (ImmInteger 0)) (OpReg reg_h) + return code + + +genSignedLargeMul + :: Width + -> LocalReg + -> LocalReg + -> LocalReg + -> CmmExpr + -> CmmExpr + -> NatM (OrdList Instr) +genSignedLargeMul width res_c res_h res_l arg_x arg_y = do + (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + reg_tmp <- getNewRegNat II8 + let format = intFormat width + reg_h = getLocalRegReg res_h + reg_l = getLocalRegReg res_l + reg_c = getLocalRegReg res_c + code = y_code `appOL` + x_code rax `appOL` + toOL [ IMUL2 format y_reg + , MOV format (OpReg rdx) (OpReg reg_h) + , MOV format (OpReg rax) (OpReg reg_l) + , SETCC CARRY (OpReg reg_tmp) + , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c) + ] + return code + +genUnsignedLargeMul + :: Width + -> LocalReg + -> LocalReg + -> CmmExpr + -> CmmExpr + -> NatM (OrdList Instr) +genUnsignedLargeMul width res_h res_l arg_x arg_y = do + (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + let format = intFormat width + reg_h = getLocalRegReg res_h + reg_l = getLocalRegReg res_l + code = y_code `appOL` + x_code rax `appOL` + toOL [MUL2 format y_reg, + MOV format (OpReg rdx) (OpReg reg_h), + MOV format (OpReg rax) (OpReg reg_l)] + return code + + +genQuotRem + :: Width + -> Bool + -> LocalReg + -> LocalReg + -> Maybe CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM InstrBlock +genQuotRem width signed res_q res_r m_arg_x_high arg_x_low arg_y = do + case width of + W8 -> do + -- See Note [DIV/IDIV for bytes] + let widen | signed = MO_SS_Conv W8 W16 + | otherwise = MO_UU_Conv W8 W16 + arg_x_low_16 = CmmMachOp widen [arg_x_low] + arg_y_16 = CmmMachOp widen [arg_y] + m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high + genQuotRem W16 signed res_q res_r m_arg_x_high_16 arg_x_low_16 arg_y_16 + + _ -> do + let format = intFormat width + reg_q = getLocalRegReg res_q + reg_r = getLocalRegReg res_r + widen | signed = CLTD format + | otherwise = XOR format (OpReg rdx) (OpReg rdx) + instr | signed = IDIV + | otherwise = DIV + (y_reg, y_code) <- getRegOrMem arg_y + x_low_code <- getAnyReg arg_x_low + x_high_code <- case m_arg_x_high of + Just arg_x_high -> + getAnyReg arg_x_high + Nothing -> + return $ const $ unitOL widen + return $ y_code `appOL` + x_low_code rax `appOL` + x_high_code rdx `appOL` + toOL [instr format y_reg, + MOV format (OpReg rax) (OpReg reg_q), + MOV format (OpReg rdx) (OpReg reg_r)] diff --git a/GHC/CmmToAsm/X86/Cond.hs b/GHC/CmmToAsm/X86/Cond.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/Cond.hs @@ -0,0 +1,91 @@ +module GHC.CmmToAsm.X86.Cond ( + Cond(..), + condToUnsigned, + maybeFlipCond, + maybeInvertCond +) + +where + +import GHC.Prelude + +data Cond + = ALWAYS -- What's really used? ToDo + | EQQ -- je/jz -> zf=1 + | GE -- jge -> sf=of + | GEU -- ae -> cf=0 + | GTT -- jg -> zf=0 && sf=of + | GU -- ja -> cf=0 && zf=0 + | LE -- jle -> zf=1 || sf/=of + | LEU -- jbe -> cf=1 || zf=1 + | LTT -- jl -> sf/=of + | LU -- jb -> cf=1 + | NE -- jne -> zf=0 + | NEG -- js -> sf=1 + | POS -- jns -> sf=0 + | CARRY -- jc -> cf=1 + | OFLO -- jo -> of=1 + | PARITY -- jp -> pf=1 + | NOTPARITY -- jnp -> pf=0 + deriving Eq + +condToUnsigned :: Cond -> Cond +condToUnsigned GTT = GU +condToUnsigned LTT = LU +condToUnsigned GE = GEU +condToUnsigned LE = LEU +condToUnsigned x = x + +-- | @maybeFlipCond c@ returns @Just c'@ if it is possible to flip the +-- arguments to the conditional @c@, and the new condition should be @c'@. +maybeFlipCond :: Cond -> Maybe Cond +maybeFlipCond cond = case cond of + EQQ -> Just EQQ + NE -> Just NE + LU -> Just GU + GU -> Just LU + LEU -> Just GEU + GEU -> Just LEU + LTT -> Just GTT + GTT -> Just LTT + LE -> Just GE + GE -> Just LE + _other -> Nothing + +-- | If we apply @maybeInvertCond@ to the condition of a jump we turn +-- jumps taken into jumps not taken and vice versa. +-- +-- Careful! If the used comparison and the conditional jump +-- don't match the above behaviour will NOT hold. +-- When used for FP comparisons this does not consider unordered +-- numbers. +-- Also inverting twice might return a synonym for the original condition. +maybeInvertCond :: Cond -> Maybe Cond +maybeInvertCond cond = case cond of + ALWAYS -> Nothing + EQQ -> Just NE + NE -> Just EQQ + + NEG -> Just POS + POS -> Just NEG + + GEU -> Just LU + LU -> Just GEU + + GE -> Just LTT + LTT -> Just GE + + GTT -> Just LE + LE -> Just GTT + + GU -> Just LEU + LEU -> Just GU + + --GEU "==" NOTCARRY, they are synonyms + --at the assembly level + CARRY -> Just GEU + + OFLO -> Nothing + + PARITY -> Just NOTPARITY + NOTPARITY -> Just PARITY diff --git a/GHC/CmmToAsm/X86/Instr.hs b/GHC/CmmToAsm/X86/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/Instr.hs @@ -0,0 +1,1533 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- +-- Machine-dependent assembly language +-- +-- (c) The University of Glasgow 1993-2004 +-- +----------------------------------------------------------------------------- + +module GHC.CmmToAsm.X86.Instr + ( Instr(..) + , Operand(..) + , PrefetchVariant(..) + , FMAPermutation(..) + , JumpDest(..) + , getJumpDestBlockId + , canShortcut + , shortcutStatics + , shortcutJump + , allocMoreStack + , maxSpillSlots + , archWordFormat + , takeRegRegMoveInstr + , regUsageOfInstr + , takeDeltaInstr + , mkLoadInstr + , mkJumpInstr + , mkStackAllocInstr + , mkStackDeallocInstr + , mkSpillInstr + , mkRegRegMoveInstr + , movInstr + , jumpDestsOfInstr + , canFallthroughTo + , patchRegsOfInstr + , patchJumpInstr + , isMetaInstr + , isJumpishInstr + , MinOrMax(..), MinMaxType(..) + ) +where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.CmmToAsm.X86.Cond +import GHC.CmmToAsm.X86.Regs +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Reg.Target (targetClassOfReg) +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils +import GHC.CmmToAsm.Instr (RegUsage(..), noUsage) +import GHC.Platform.Reg +import GHC.Platform.Reg.Class.Unified + +import GHC.CmmToAsm.Config + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label +import GHC.Platform.Regs +import GHC.Cmm +import GHC.Utils.Constants ( debugIsOn ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform + +import GHC.Cmm.CLabel +import GHC.Types.Unique.Set +import GHC.Types.Unique +import GHC.Types.Unique.DSM +import GHC.Types.Basic (Alignment) +import GHC.Cmm.DebugBlock (UnwindTable) +import GHC.Utils.Misc ( HasDebugCallStack ) + +import GHC.Data.Maybe + +-- Format of an x86/x86_64 memory address, in bytes. +-- +archWordFormat :: Bool -> Format +archWordFormat is32Bit + | is32Bit = II32 + | otherwise = II64 + +-- ----------------------------------------------------------------------------- +-- Intel x86 instructions + +data Instr + -- comment pseudo-op + = COMMENT FastString + + -- location pseudo-op (file, line, col, name) + | LOCATION Int Int Int String + + -- some static data spat out during code + -- generation. Will be extracted before + -- pretty-printing. + | LDATA Section (Alignment, RawCmmStatics) + + -- start a new basic block. Useful during + -- codegen, removed later. Preceding + -- instruction should be a jump, as per the + -- invariants for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- unwinding information + -- See Note [Unwinding information in the NCG]. + | UNWIND CLabel UnwindTable + + -- specify current stack offset for benefit of subsequent passes. + -- This carries a BlockId so it can be used in unwinding information. + | DELTA Int + + -- | X86 scalar move instruction. + -- + -- When used at a vector format, only moves the lower 64 bits of data; + -- the rest of the data in the destination may either be zeroed or + -- preserved, depending on the specific format and operands. + | MOV Format Operand Operand + -- N.B. Due to AT&T assembler quirks, when used with 'II64' + -- 'Format' immediate source and memory target operand, the source + -- operand is interpreted to be a 32-bit sign-extended value. + -- True 64-bit operands need to be either first moved to a register or moved + -- with @MOVABS@; we currently do not use this instruction in GHC. + -- See https://stackoverflow.com/questions/52434073/whats-the-difference-between-the-x86-64-att-instructions-movq-and-movabsq. + + -- | MOVD/MOVQ SSE2 instructions + -- (bitcast between a general purpose register and a float register). + | MOVD + Format -- ^ input format + Format -- ^ output format + Operand Operand + -- NB: MOVD stores both the input and output formats. This is because + -- neither format fully determines the other, as either might be + -- a vector format, and we need to know the exact format in order to + -- correctly spill/unspill. See #25659. + | CMOV Cond Format Operand Reg + | MOVZxL Format Operand Operand + -- ^ The format argument is the size of operand 1 (the number of bits we keep) + -- We always zero *all* high bits, even though this isn't how the actual instruction + -- works. The code generator also seems to rely on this behaviour and it's faster + -- to execute on many cpus as well so for now I'm just documenting the fact. + | MOVSxL Format Operand Operand -- format is the size of operand 1 + -- x86_64 note: plain mov into a 32-bit register always zero-extends + -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which + -- don't affect the high bits of the register. + + -- Load effective address (also a very useful three-operand add instruction :-) + | LEA Format Operand Operand + + -- Int Arithmetic. + | ADD Format Operand Operand + | ADC Format Operand Operand + | SUB Format Operand Operand + | SBB Format Operand Operand + + | MUL Format Operand Operand + | MUL2 Format Operand -- %edx:%eax = operand * %rax + | IMUL Format Operand Operand -- signed int mul + | IMUL2 Format Operand -- %edx:%eax = operand * %eax + + | DIV Format Operand -- eax := eax:edx/op, edx := eax:edx%op + | IDIV Format Operand -- ditto, but signed + + -- Int Arithmetic, where the effects on the condition register + -- are important. Used in specialized sequences such as MO_Add2. + -- Do not rewrite these instructions to "equivalent" ones that + -- have different effect on the condition register! (See #9013.) + | ADD_CC Format Operand Operand + | SUB_CC Format Operand Operand + + -- Simple bit-twiddling. + | AND Format Operand Operand + | OR Format Operand Operand + | XOR Format Operand Operand + -- | AVX bitwise logical XOR operation + | VXOR Format Operand Reg Reg + | NOT Format Operand + | NEGI Format Operand -- NEG instruction (name clash with Cond) + | BSWAP Format Reg + + -- Shifts (amount may be immediate or %cl only) + | SHL Format Operand{-amount-} Operand + | SAR Format Operand{-amount-} Operand + | SHR Format Operand{-amount-} Operand + | SHRD Format Operand{-amount-} Operand Operand + | SHLD Format Operand{-amount-} Operand Operand + + | BT Format Imm Operand + | NOP + + + -- We need to support the FSTP (x87 store and pop) instruction + -- so that we can correctly read off the return value of an + -- x86 CDECL C function call when its floating point. + -- so we don't include a register argument, and just use st(0) + -- this instruction is used ONLY for return values of C ffi calls + -- in x86_32 abi + | X87Store Format AddrMode -- st(0), dst + + + -- SSE2 floating point: we use a restricted set of the available SSE2 + -- instructions for floating-point. + -- use MOV for moving (either movss or movsd (movlpd better?)) + | CVTSS2SD Reg Reg -- F32 to F64 + | CVTSD2SS Reg Reg -- F64 to F32 + | CVTTSS2SIQ Format Operand Reg -- F32 to I32/I64 (with truncation) + | CVTTSD2SIQ Format Operand Reg -- F64 to I32/I64 (with truncation) + | CVTSI2SS Format Operand Reg -- I32/I64 to F32 + | CVTSI2SD Format Operand Reg -- I32/I64 to F64 + + -- | FMA3 fused multiply-add operations. + | FMA3 Format FMASign FMAPermutation Operand Reg Reg + -- For the FMA213 permutation (the only one we use currently), + -- this is: src3 (r/m), src2 (r), dst/src1 (r) + -- (NB: this isexactly reversed from how Intel lists the arguments.) + + -- use ADD, SUB, and SQRT for arithmetic. In both cases, operands + -- are Operand Reg. + + -- SSE2 floating-point division: + | FDIV Format Operand Reg -- divisor, dividend(dst) + + -- use CMP for comparisons. ucomiss and ucomisd instructions + -- compare single/double prec floating point respectively. + + | SQRT Format Operand Reg -- src, dst + + + -- Comparison + | TEST Format Operand Operand + | CMP Format Operand Operand + | SETCC Cond Operand + + -- Stack Operations. + | PUSH Format Operand + | POP Format Operand + -- both unused (SDM): + -- | PUSHA + -- | POPA + + -- Jumping around. + | JMP Operand [RegWithFormat] -- including live Regs at the call + | JXX Cond BlockId -- includes unconditional branches + | JXX_GBL Cond Imm -- non-local version of JXX + -- Table jump + | JMP_TBL Operand -- Address to jump to + [Maybe JumpDest] -- Targets of the jump table + Section -- Data section jump table should be put in + CLabel -- Label of jump table + -- | X86 call instruction + | CALL (Either Imm Reg) -- ^ Jump target + [RegWithFormat] -- ^ Arguments (required for register allocation) + + -- Other things. + | CLTD Format -- sign extend %eax into %edx:%eax + + | FETCHGOT Reg -- pseudo-insn for ELF position-independent code + -- pretty-prints as + -- call 1f + -- 1: popl %reg + -- addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg + | FETCHPC Reg -- pseudo-insn for Darwin position-independent code + -- pretty-prints as + -- call 1f + -- 1: popl %reg + + -- bit counting instructions + | POPCNT Format Operand Reg -- [SSE4.2] count number of bits set to 1 + | LZCNT Format Operand Reg -- [BMI2] count number of leading zeros + | TZCNT Format Operand Reg -- [BMI2] count number of trailing zeros + | BSF Format Operand Reg -- bit scan forward + | BSR Format Operand Reg -- bit scan reverse + + -- bit manipulation instructions + | PDEP Format Operand Operand Reg -- [BMI2] deposit bits to the specified mask + | PEXT Format Operand Operand Reg -- [BMI2] extract bits from the specified mask + + -- prefetch + | PREFETCH PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch + -- variant can be NTA, Lvl0, Lvl1, or Lvl2 + + | LOCK Instr -- lock prefix + | XADD Format Operand Operand -- src (r), dst (r/m) + | CMPXCHG Format Operand Operand -- src (r), dst (r/m), eax implicit + | XCHG Format Operand Reg -- src (r/m), dst (r/m) + | MFENCE + + -- Vector Instructions -- + -- NOTE: Instructions follow the AT&T syntax + -- Constructors and deconstructors + | VBROADCAST Format Operand Reg + | VPBROADCAST Format Format Operand Reg -- scalar format, vector format, source, destination + | VEXTRACT Format Imm Reg Operand + | INSERTPS Format Imm Operand Reg + | VINSERTPS Format Imm Operand Reg Reg + | PINSR Format Format Imm Operand Reg -- scalar format, vector format, offset, scalar src, vector + | PEXTR Format Format Imm Reg Operand -- scalar format, vector format, offset, vector src, scalar dst + + -- move operations + + -- | SSE2 unaligned move of floating-point vectors + | MOVU Format Operand Operand + -- | AVX unaligned move of floating-point vectors + | VMOVU Format Operand Operand + -- | SSE2 move between memory and low-part of an xmm register + | MOVL Format Operand Operand + -- | SSE move between memory and high-part of an xmm register + | MOVH Format Operand Operand + -- | SSE2 unaligned move of integer vectors + | MOVDQU Format Operand Operand + -- | AVX unaligned move of integer vectors + | VMOVDQU Format Operand Operand + -- | Alias for VMOVSS/VMOVSD, used to merge two vectors + | VMOV_MERGE Format Reg Reg Reg + + -- logic operations + | PXOR Format Operand Reg + | VPXOR Format Reg Reg Reg + | PAND Format Operand Reg + | PANDN Format Operand Reg + | POR Format Operand Reg + + -- Arithmetic + | VADD Format Operand Reg Reg + | VSUB Format Operand Reg Reg + | VMUL Format Operand Reg Reg + | VDIV Format Operand Reg Reg + | PADD Format Operand Reg + | PSUB Format Operand Reg + | PMULL Format Operand Reg + | PMULUDQ Format Operand Reg + + -- SIMD compare + | PCMPGT Format Operand Reg + + -- Shuffle + | SHUF Format Imm Operand Reg + | VSHUF Format Imm Operand Reg Reg + | PSHUFB Format Operand Reg + | PSHUFLW Format Imm Operand Reg + | PSHUFHW Format Imm Operand Reg + | PSHUFD Format Imm Operand Reg + | VPSHUFD Format Imm Operand Reg + | BLEND Format Imm Operand Reg + | VBLEND Format Imm Operand Reg Reg + | PBLENDW Format Imm Operand Reg + + -- | Move two 32-bit floats from the high part of an xmm register + -- to the low part of another xmm register. + -- + -- If the format is a vector format, the destination register is treated as the second source. + -- If the format is FF32 or FF64, the destination register is not treated as a source. + | MOVHLPS Format Reg Reg + | VMOVHLPS Format Reg Reg Reg + | MOVLHPS Format Reg Reg + | VMOVLHPS Format Reg Reg Reg + | UNPCKL Format Operand Reg + | VUNPCKL Format Operand Reg Reg + | UNPCKH Format Operand Reg + | VUNPCKH Format Operand Reg Reg + | PUNPCKLQDQ Format Operand Reg + | PUNPCKLDQ Format Operand Reg + | PUNPCKLWD Format Operand Reg + | PUNPCKLBW Format Operand Reg + | PUNPCKHQDQ Format Operand Reg + | PUNPCKHDQ Format Operand Reg + | PUNPCKHWD Format Operand Reg + | PUNPCKHBW Format Operand Reg + | PACKUSWB Format Operand Reg + + -- Shift + | PSLL Format Operand Reg + | PSLLDQ Format Imm Reg + | PSRL Format Operand Reg + | PSRLDQ Format Imm Reg + | PALIGNR Format Imm Operand Reg + + -- min/max + | MINMAX MinOrMax MinMaxType Format Operand Reg + | VMINMAX MinOrMax MinMaxType Format Operand Reg Reg + +data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 + +-- | 'MIN' or 'MAX' +data MinOrMax = Min | Max + deriving ( Eq, Show ) +-- | What kind of min/max operation: signed or unsigned vector integer min/max, +-- or (scalar or vector) floating point min/max? +data MinMaxType = + IntVecMinMax { minMaxSigned :: Bool } | FloatMinMax + deriving ( Eq, Show ) + +data Operand + = OpReg Reg -- register + | OpImm Imm -- immediate value + | OpAddr AddrMode -- memory reference + +-- NB: As of 2023 we only use the FMA213 permutation. +data FMAPermutation = FMA132 | FMA213 | FMA231 + +-- | Returns which registers are read and written as a (read, written) +-- pair. +regUsageOfInstr :: Platform -> Instr -> RegUsage +regUsageOfInstr platform instr + = case instr of + MOV fmt src dst + -- MOVSS/MOVSD preserve the upper half of vector registers, + -- but only for reg-2-reg moves + | VecFormat _ sFmt <- fmt + , isFloatScalarFormat sFmt + , OpReg {} <- src + , OpReg {} <- dst + -> usageRM fmt src dst + -- other MOV instructions zero any remaining upper part of the destination + -- (largely to avoid partial register stalls) + | otherwise + -> usageRW fmt src dst + MOVD fmt1 fmt2 src dst -> + -- NB: MOVD and MOVQ always zero any remaining upper part of destination, + -- so the destination is "written" not "modified". + usageRW' fmt1 fmt2 src dst + CMOV _ fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + MOVZxL fmt src dst -> usageRW fmt src dst + MOVSxL fmt src dst -> usageRW fmt src dst + LEA fmt src dst -> usageRW fmt src dst + ADD fmt src dst -> usageRM fmt src dst + ADC fmt src dst -> usageRM fmt src dst + SUB fmt src dst -> usageRM fmt src dst + SBB fmt src dst -> usageRM fmt src dst + IMUL fmt src dst -> usageRM fmt src dst + + -- Result of IMULB will be in just in %ax + IMUL2 II8 src -> mkRU (mk II8 eax:use_R II8 src []) [mk II8 eax] + -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and + -- %ax/%eax/%rax. + IMUL2 fmt src -> mkRU (mk fmt eax:use_R fmt src []) [mk fmt eax,mk fmt edx] + + MUL fmt src dst -> usageRM fmt src dst + MUL2 fmt src -> mkRU (mk fmt eax:use_R fmt src []) [mk fmt eax,mk fmt edx] + DIV fmt op -> mkRU (mk fmt eax:mk fmt edx:use_R fmt op []) [mk fmt eax, mk fmt edx] + IDIV fmt op -> mkRU (mk fmt eax:mk fmt edx:use_R fmt op []) [mk fmt eax, mk fmt edx] + ADD_CC fmt src dst -> usageRM fmt src dst + SUB_CC fmt src dst -> usageRM fmt src dst + AND fmt src dst -> usageRM fmt src dst + OR fmt src dst -> usageRM fmt src dst + + XOR fmt (OpReg src) (OpReg dst) + | src == dst + -> mkRU [] [mk fmt dst] + XOR fmt src dst + -> usageRM fmt src dst + VXOR fmt (OpReg src1) src2 dst + | src1 == src2, src1 == dst + -> mkRU [] [mk fmt dst] + VXOR fmt src1 src2 dst + -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst] + + NOT fmt op -> usageM fmt op + BSWAP fmt reg -> mkRU [mk fmt reg] [mk fmt reg] + NEGI fmt op -> usageM fmt op + SHL fmt imm dst -> usageRM fmt imm dst + SAR fmt imm dst -> usageRM fmt imm dst + SHR fmt imm dst -> usageRM fmt imm dst + SHLD fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2 + SHRD fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2 + BT fmt _ src -> mkRUR (use_R fmt src []) + + PUSH fmt op -> mkRUR (use_R fmt op []) + POP fmt op -> mkRU [] (def_W fmt op) + TEST fmt src dst -> mkRUR (use_R fmt src $! use_R fmt dst []) + CMP fmt src dst -> mkRUR (use_R fmt src $! use_R fmt dst []) + SETCC _ op -> mkRU [] (def_W II8 op) + JXX _ _ -> mkRU [] [] + JXX_GBL _ _ -> mkRU [] [] + JMP op regs -> mkRU (use_R addrFmt op regs) [] + JMP_TBL op _ _ _ -> mkRU (use_R addrFmt op []) [] + CALL (Left _) params -> mkRU params (map mkFmt $ callClobberedRegs platform) + CALL (Right reg) params -> mkRU (mk addrFmt reg:params) (map mkFmt $ callClobberedRegs platform) + CLTD fmt -> mkRU [mk fmt eax] [mk fmt edx] + NOP -> mkRU [] [] + + X87Store _fmt dst -> mkRUR (use_EA dst []) + + CVTSS2SD src dst -> mkRU [mk FF32 src] [mk FF64 dst] + CVTSD2SS src dst -> mkRU [mk FF64 src] [mk FF32 dst] + CVTTSS2SIQ fmt src dst -> mkRU (use_R FF32 src []) [mk fmt dst] + CVTTSD2SIQ fmt src dst -> mkRU (use_R FF64 src []) [mk fmt dst] + CVTSI2SS fmt src dst -> mkRU (use_R fmt src []) [mk FF32 dst] + CVTSI2SD fmt src dst -> mkRU (use_R fmt src []) [mk FF64 dst] + FDIV fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + SQRT fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst] + + FETCHGOT reg -> mkRU [] [mk addrFmt reg] + FETCHPC reg -> mkRU [] [mk addrFmt reg] + + COMMENT _ -> noUsage + LOCATION{} -> noUsage + UNWIND{} -> noUsage + DELTA _ -> noUsage + + POPCNT fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst] + LZCNT fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst] + TZCNT fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst] + BSF fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst] + BSR fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst] + + PDEP fmt src mask dst -> mkRU (use_R fmt src $ use_R fmt mask []) [mk fmt dst] + PEXT fmt src mask dst -> mkRU (use_R fmt src $ use_R fmt mask []) [mk fmt dst] + + FMA3 fmt _ _ src3 src2 dst -> usageFMA fmt src3 src2 dst + + -- note: might be a better way to do this + PREFETCH _ fmt src -> mkRU (use_R fmt src []) [] + LOCK i -> regUsageOfInstr platform i + XADD fmt src dst -> usageMM fmt src dst + CMPXCHG fmt src dst -> usageRMM fmt src dst (OpReg eax) + XCHG fmt src dst -> usageMM fmt src (OpReg dst) + MFENCE -> noUsage + + -- vector instructions + VBROADCAST fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst] + VPBROADCAST sFmt vFmt src dst -> mkRU (use_R sFmt src []) [mk vFmt dst] + VEXTRACT fmt _off src dst -> usageRW fmt (OpReg src) dst + INSERTPS fmt (ImmInt off) src dst + -> mkRU ((use_R fmt src []) ++ [mk fmt dst | not doesNotReadDst]) [mk fmt dst] + where + -- Compute whether the instruction reads the destination register or not. + -- Immediate bits: ss_dd_zzzz s = src pos, d = dst pos, z = zeroed components. + doesNotReadDst = and [ testBit off i | i <- [0, 1, 2, 3], i /= pos ] + -- Check whether the positions in which we are not inserting + -- are being zeroed. + where pos = ( off `shiftR` 4 ) .&. 0b11 + INSERTPS fmt _off src dst + -> mkRU ((use_R fmt src []) ++ [mk fmt dst]) [mk fmt dst] + VINSERTPS fmt _imm src2 src1 dst + -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst] + PINSR sFmt vFmt _off src dst + -> mkRU (use_R sFmt src [mk vFmt dst]) [mk vFmt dst] + PEXTR sFmt vFmt _off src dst + -> usageRW' vFmt sFmt (OpReg src) dst + + VMOVU fmt src dst -> usageRW fmt src dst + MOVU fmt src dst -> usageRW fmt src dst + MOVL fmt src dst -> usageRM fmt src dst + MOVH fmt src dst -> usageRM fmt src dst + MOVDQU fmt src dst -> usageRW fmt src dst + VMOVDQU fmt src dst -> usageRW fmt src dst + VMOV_MERGE fmt src2 src1 dst -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst] + + PXOR fmt (OpReg src) dst + | src == dst + -> mkRU [] [mk fmt dst] + | otherwise + -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst] + + VPXOR fmt s1 s2 dst + | s1 == s2, s1 == dst + -> mkRU [] [mk fmt dst] + | otherwise + -> mkRU [mk fmt s1, mk fmt s2] [mk fmt dst] + + PAND fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PANDN fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + POR fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + VADD fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst] + VSUB fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst] + VMUL fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst] + VDIV fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst] + PADD fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PSUB fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PMULL fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PMULUDQ fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + PCMPGT fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + SHUF fmt _mask src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + VSHUF fmt _mask src1 src2 dst + -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst] + PSHUFB fmt mask dst + -> mkRU (use_R fmt mask [mk fmt dst]) [mk fmt dst] + PSHUFLW fmt _mask src dst + -> mkRU (use_R fmt src []) [mk fmt dst] + PSHUFHW fmt _mask src dst + -> mkRU (use_R fmt src []) [mk fmt dst] + PSHUFD fmt _mask src dst + -> mkRU (use_R fmt src []) [mk fmt dst] + VPSHUFD fmt _mask src dst + -> mkRU (use_R fmt src []) [mk fmt dst] + BLEND fmt _mask src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + VBLEND fmt _mask src2 src1 dst + -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst] + PBLENDW fmt _mask src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + PSLL fmt off dst -> mkRU (use_R fmt off [mk fmt dst]) [mk fmt dst] + PSLLDQ fmt _off dst -> mkRU [mk fmt dst] [mk fmt dst] + PSRL fmt off dst -> mkRU (use_R fmt off [mk fmt dst]) [mk fmt dst] + PSRLDQ fmt _off dst -> mkRU [mk fmt dst] [mk fmt dst] + PALIGNR fmt _off src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + MOVHLPS fmt src dst + -> case fmt of + VecFormat {} -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst] + -- MOVHLPS moves the high 64 bits of src to the low 64 bits of dst, + -- keeping the high 64 bits of dst intact. + -- If we only care about the lower 64 bits of the result, + -- dst is only written to, not read. + FF64 -> mkRU [mk (VecFormat 2 FmtDouble) src] [mk fmt dst] + FF32 -> mkRU [mk (VecFormat 4 FmtFloat) src] [mk fmt dst] + _ -> pprPanic "regUsage: invalid format for MOVHLPS" (ppr fmt) + VMOVHLPS fmt src2 src1 dst + -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst] + MOVLHPS fmt src dst + -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst] + VMOVLHPS fmt src2 src1 dst + -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst] + UNPCKL fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + VUNPCKL fmt src2 src1 dst + -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst] + UNPCKH fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + VUNPCKH fmt src2 src1 dst + -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst] + PUNPCKLQDQ fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKLDQ fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKLWD fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKLBW fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKHQDQ fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKHDQ fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKHWD fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKHBW fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PACKUSWB fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + MINMAX _ _ fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + VMINMAX _ _ fmt src1 src2 dst + -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst] + _other -> panic "regUsage: unrecognised instr" + where + + -- # Definitions + -- + -- Written: If the operand is a register, it's written. If it's an + -- address, registers mentioned in the address are read. + -- + -- Modified: If the operand is a register, it's both read and + -- written. If it's an address, registers mentioned in the address + -- are read. + + -- 2 operand form; first operand Read; second Written + usageRW :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage + usageRW fmt op (OpReg reg) = mkRU (use_R fmt op []) [mk fmt reg] + usageRW fmt op (OpAddr ea) = mkRUR (use_R fmt op $! use_EA ea []) + usageRW _ _ _ = panic "X86.RegInfo.usageRW: no match" + + usageRW' :: HasDebugCallStack => Format -> Format -> Operand -> Operand -> RegUsage + usageRW' fmt1 fmt2 op (OpReg reg) = mkRU (use_R fmt1 op []) [mk fmt2 reg] + usageRW' fmt1 _ op (OpAddr ea) = mkRUR (use_R fmt1 op $! use_EA ea []) + usageRW' _ _ _ _ = panic "X86.RegInfo.usageRW: no match" + + -- 2 operand form; first operand Read; second Modified + usageRM :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage + usageRM fmt op (OpReg reg) = mkRU (use_R fmt op [mk fmt reg]) [mk fmt reg] + usageRM fmt op (OpAddr ea) = mkRUR (use_R fmt op $! use_EA ea []) + usageRM _ _ _ = panic "X86.RegInfo.usageRM: no match" + + -- 2 operand form; first operand Modified; second Modified + usageMM :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage + usageMM fmt (OpReg src) (OpReg dst) = mkRU [mk fmt src, mk fmt dst] [mk fmt src, mk fmt dst] + usageMM fmt (OpReg src) (OpAddr ea) = mkRU (use_EA ea [mk fmt src]) [mk fmt src] + usageMM fmt (OpAddr ea) (OpReg dst) = mkRU (use_EA ea [mk fmt dst]) [mk fmt dst] + usageMM _ _ _ = panic "X86.RegInfo.usageMM: no match" + + -- 3 operand form; first operand Read; second Modified; third Modified + usageRMM :: HasDebugCallStack => Format -> Operand -> Operand -> Operand -> RegUsage + usageRMM fmt (OpReg src) (OpReg dst) (OpReg reg) = mkRU [mk fmt src, mk fmt dst, mk fmt reg] [mk fmt dst, mk fmt reg] + usageRMM fmt (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [mk fmt src, mk fmt reg]) [mk fmt reg] + usageRMM _ _ _ _ = panic "X86.RegInfo.usageRMM: no match" + + -- 3 operand form of FMA instructions. + usageFMA :: HasDebugCallStack => Format -> Operand -> Reg -> Reg -> RegUsage + usageFMA fmt (OpReg src1) src2 dst = + mkRU [mk fmt src1, mk fmt src2, mk fmt dst] [mk fmt dst] + usageFMA fmt (OpAddr ea1) src2 dst + = mkRU (use_EA ea1 [mk fmt src2, mk fmt dst]) [mk fmt dst] + usageFMA _ _ _ _ + = panic "X86.RegInfo.usageFMA: no match" + + -- 1 operand form; operand Modified + usageM :: HasDebugCallStack => Format -> Operand -> RegUsage + usageM fmt (OpReg reg) = + let r' = mk fmt reg + in mkRU [r'] [r'] + usageM _ (OpAddr ea) = mkRUR (use_EA ea []) + usageM _ _ = panic "X86.RegInfo.usageM: no match" + + -- Registers defd when an operand is written. + def_W fmt (OpReg reg) = [mk fmt reg] + def_W _ (OpAddr _ ) = [] + def_W _ _ = panic "X86.RegInfo.def_W: no match" + + -- Registers used when an operand is read. + use_R :: HasDebugCallStack => Format -> Operand -> [RegWithFormat] -> [RegWithFormat] + use_R fmt (OpReg reg) tl = mk fmt reg : tl + use_R _ (OpImm _) tl = tl + use_R _ (OpAddr ea) tl = use_EA ea tl + + -- Registers used to compute an effective address. + use_EA (ImmAddr _ _) tl = tl + use_EA (AddrBaseIndex base index _) tl = + use_base base $! use_index index tl + where use_base (EABaseReg r) tl = mk addrFmt r : tl + use_base _ tl = tl + use_index EAIndexNone tl = tl + use_index (EAIndex i _) tl = mk addrFmt i : tl + + mkRUR :: [RegWithFormat] -> RegUsage + mkRUR src = mkRU src [] + + mkRU :: [RegWithFormat] -> [RegWithFormat] -> RegUsage + mkRU src dst = src' `seq` dst' `seq` RU src' dst' + where src' = filter (interesting platform . regWithFormat_reg) src + dst' = filter (interesting platform . regWithFormat_reg) dst + + addrFmt = archWordFormat (target32Bit platform) + mk :: Format -> Reg -> RegWithFormat + mk fmt r = RegWithFormat r fmt + + mkFmt :: Reg -> RegWithFormat + mkFmt r = RegWithFormat r $ case targetClassOfReg platform r of + RcInteger -> addrFmt + RcFloatOrVector -> FF64 + +-- | Is this register interesting for the register allocator? +interesting :: Platform -> Reg -> Bool +interesting _ (RegVirtual _) = True +interesting platform (RegReal (RealRegSingle i)) = freeReg platform i + + +-- | Applies the supplied function to all registers in instructions. +-- Typically used to change virtual registers to real registers. +patchRegsOfInstr :: HasDebugCallStack => Platform -> Instr -> (Reg -> Reg) -> Instr +patchRegsOfInstr platform instr env + = case instr of + MOV fmt src dst -> MOV fmt (patchOp src) (patchOp dst) + MOVD fmt1 fmt2 src dst -> patch2 (MOVD fmt1 fmt2) src dst + CMOV cc fmt src dst -> CMOV cc fmt (patchOp src) (env dst) + MOVZxL fmt src dst -> patch2 (MOVZxL fmt) src dst + MOVSxL fmt src dst -> patch2 (MOVSxL fmt) src dst + LEA fmt src dst -> patch2 (LEA fmt) src dst + ADD fmt src dst -> patch2 (ADD fmt) src dst + ADC fmt src dst -> patch2 (ADC fmt) src dst + SUB fmt src dst -> patch2 (SUB fmt) src dst + SBB fmt src dst -> patch2 (SBB fmt) src dst + IMUL fmt src dst -> patch2 (IMUL fmt) src dst + IMUL2 fmt src -> patch1 (IMUL2 fmt) src + MUL fmt src dst -> patch2 (MUL fmt) src dst + MUL2 fmt src -> patch1 (MUL2 fmt) src + IDIV fmt op -> patch1 (IDIV fmt) op + DIV fmt op -> patch1 (DIV fmt) op + ADD_CC fmt src dst -> patch2 (ADD_CC fmt) src dst + SUB_CC fmt src dst -> patch2 (SUB_CC fmt) src dst + AND fmt src dst -> patch2 (AND fmt) src dst + OR fmt src dst -> patch2 (OR fmt) src dst + XOR fmt src dst -> patch2 (XOR fmt) src dst + VXOR fmt src1 src2 dst -> VXOR fmt (patchOp src1) (env src2) (env dst) + NOT fmt op -> patch1 (NOT fmt) op + BSWAP fmt reg -> BSWAP fmt (env reg) + NEGI fmt op -> patch1 (NEGI fmt) op + SHL fmt imm dst -> patch1 (SHL fmt imm) dst + SAR fmt imm dst -> patch1 (SAR fmt imm) dst + SHR fmt imm dst -> patch1 (SHR fmt imm) dst + SHLD fmt imm dst1 dst2 -> patch2 (SHLD fmt imm) dst1 dst2 + SHRD fmt imm dst1 dst2 -> patch2 (SHRD fmt imm) dst1 dst2 + BT fmt imm src -> patch1 (BT fmt imm) src + TEST fmt src dst -> patch2 (TEST fmt) src dst + CMP fmt src dst -> patch2 (CMP fmt) src dst + PUSH fmt op -> patch1 (PUSH fmt) op + POP fmt op -> patch1 (POP fmt) op + SETCC cond op -> patch1 (SETCC cond) op + JMP op regs -> JMP (patchOp op) regs + JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl + + FMA3 fmt perm var x1 x2 x3 -> patch3 (FMA3 fmt perm var) x1 x2 x3 + + -- literally only support storing the top x87 stack value st(0) + X87Store fmt dst -> X87Store fmt (lookupAddr dst) + + CVTSS2SD src dst -> CVTSS2SD (env src) (env dst) + CVTSD2SS src dst -> CVTSD2SS (env src) (env dst) + CVTTSS2SIQ fmt src dst -> CVTTSS2SIQ fmt (patchOp src) (env dst) + CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst) + CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst) + CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst) + FDIV fmt src dst -> FDIV fmt (patchOp src) (env dst) + SQRT fmt src dst -> SQRT fmt (patchOp src) (env dst) + + CALL (Left _) _ -> instr + CALL (Right reg) p -> CALL (Right (env reg)) p + + FETCHGOT reg -> FETCHGOT (env reg) + FETCHPC reg -> FETCHPC (env reg) + + NOP -> instr + COMMENT _ -> instr + LOCATION {} -> instr + UNWIND {} -> instr + DELTA _ -> instr + LDATA {} -> instr + NEWBLOCK {} -> instr + + JXX _ _ -> instr + JXX_GBL _ _ -> instr + CLTD _ -> instr + + POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst) + LZCNT fmt src dst -> LZCNT fmt (patchOp src) (env dst) + TZCNT fmt src dst -> TZCNT fmt (patchOp src) (env dst) + PDEP fmt src mask dst -> PDEP fmt (patchOp src) (patchOp mask) (env dst) + PEXT fmt src mask dst -> PEXT fmt (patchOp src) (patchOp mask) (env dst) + BSF fmt src dst -> BSF fmt (patchOp src) (env dst) + BSR fmt src dst -> BSR fmt (patchOp src) (env dst) + + PREFETCH lvl format src -> PREFETCH lvl format (patchOp src) + + LOCK i -> LOCK (patchRegsOfInstr platform i env) + XADD fmt src dst -> patch2 (XADD fmt) src dst + CMPXCHG fmt src dst -> patch2 (CMPXCHG fmt) src dst + XCHG fmt src dst -> XCHG fmt (patchOp src) (env dst) + MFENCE -> instr + + -- vector instructions + VBROADCAST fmt src dst -> VBROADCAST fmt (patchOp src) (env dst) + VPBROADCAST fmt1 fmt2 src dst + -> VPBROADCAST fmt1 fmt2 (patchOp src) (env dst) + VEXTRACT fmt off src dst + -> VEXTRACT fmt off (env src) (patchOp dst) + INSERTPS fmt off src dst + -> INSERTPS fmt off (patchOp src) (env dst) + VINSERTPS fmt off src2 src1 dst + -> VINSERTPS fmt off (patchOp src2) (env src1) (env dst) + PINSR fmt1 fmt2 off src dst + -> PINSR fmt1 fmt2 off (patchOp src) (env dst) + PEXTR fmt1 fmt2 off src dst + -> PEXTR fmt1 fmt2 off (env src) (patchOp dst) + + VMOVU fmt src dst -> VMOVU fmt (patchOp src) (patchOp dst) + MOVU fmt src dst -> MOVU fmt (patchOp src) (patchOp dst) + MOVL fmt src dst -> MOVL fmt (patchOp src) (patchOp dst) + MOVH fmt src dst -> MOVH fmt (patchOp src) (patchOp dst) + MOVDQU fmt src dst -> MOVDQU fmt (patchOp src) (patchOp dst) + VMOVDQU fmt src dst -> VMOVDQU fmt (patchOp src) (patchOp dst) + VMOV_MERGE fmt src2 src1 dst -> VMOV_MERGE fmt (env src2) (env src1) (env dst) + + PXOR fmt src dst -> PXOR fmt (patchOp src) (env dst) + VPXOR fmt s1 s2 dst -> VPXOR fmt (env s1) (env s2) (env dst) + PAND fmt src dst -> PAND fmt (patchOp src) (env dst) + PANDN fmt src dst -> PANDN fmt (patchOp src) (env dst) + POR fmt src dst -> POR fmt (patchOp src) (env dst) + + VADD fmt s1 s2 dst -> VADD fmt (patchOp s1) (env s2) (env dst) + VSUB fmt s1 s2 dst -> VSUB fmt (patchOp s1) (env s2) (env dst) + VMUL fmt s1 s2 dst -> VMUL fmt (patchOp s1) (env s2) (env dst) + VDIV fmt s1 s2 dst -> VDIV fmt (patchOp s1) (env s2) (env dst) + PADD fmt src dst -> PADD fmt (patchOp src) (env dst) + PSUB fmt src dst -> PSUB fmt (patchOp src) (env dst) + PMULL fmt src dst -> PMULL fmt (patchOp src) (env dst) + PMULUDQ fmt src dst -> PMULUDQ fmt (patchOp src) (env dst) + + PCMPGT fmt src dst -> PCMPGT fmt (patchOp src) (env dst) + + SHUF fmt off src dst + -> SHUF fmt off (patchOp src) (env dst) + VSHUF fmt off src1 src2 dst + -> VSHUF fmt off (patchOp src1) (env src2) (env dst) + PSHUFB fmt mask dst + -> PSHUFB fmt (patchOp mask) (env dst) + PSHUFLW fmt off src dst + -> PSHUFLW fmt off (patchOp src) (env dst) + PSHUFHW fmt off src dst + -> PSHUFHW fmt off (patchOp src) (env dst) + PSHUFD fmt off src dst + -> PSHUFD fmt off (patchOp src) (env dst) + VPSHUFD fmt off src dst + -> VPSHUFD fmt off (patchOp src) (env dst) + BLEND fmt mask src dst + -> BLEND fmt mask (patchOp src) (env dst) + VBLEND fmt mask src2 src1 dst + -> VBLEND fmt mask (patchOp src2) (env src1) (env dst) + PBLENDW fmt mask src dst + -> PBLENDW fmt mask (patchOp src) (env dst) + + PSLL fmt off dst + -> PSLL fmt (patchOp off) (env dst) + PSLLDQ fmt off dst + -> PSLLDQ fmt off (env dst) + PSRL fmt off dst + -> PSRL fmt (patchOp off) (env dst) + PSRLDQ fmt off dst + -> PSRLDQ fmt off (env dst) + PALIGNR fmt off src dst + -> PALIGNR fmt off (patchOp src) (env dst) + + MOVHLPS fmt src dst + -> MOVHLPS fmt (env src) (env dst) + VMOVHLPS fmt src2 src1 dst + -> VMOVHLPS fmt (env src2) (env src1) (env dst) + MOVLHPS fmt src dst + -> MOVLHPS fmt (env src) (env dst) + VMOVLHPS fmt src2 src1 dst + -> VMOVLHPS fmt (env src2) (env src1) (env dst) + UNPCKL fmt src dst + -> UNPCKL fmt (patchOp src) (env dst) + VUNPCKL fmt src2 src1 dst + -> VUNPCKL fmt (patchOp src2) (env src1) (env dst) + UNPCKH fmt src dst + -> UNPCKH fmt (patchOp src) (env dst) + VUNPCKH fmt src2 src1 dst + -> VUNPCKH fmt (patchOp src2) (env src1) (env dst) + PUNPCKLQDQ fmt src dst + -> PUNPCKLQDQ fmt (patchOp src) (env dst) + PUNPCKLDQ fmt src dst + -> PUNPCKLDQ fmt (patchOp src) (env dst) + PUNPCKLWD fmt src dst + -> PUNPCKLWD fmt (patchOp src) (env dst) + PUNPCKLBW fmt src dst + -> PUNPCKLBW fmt (patchOp src) (env dst) + PUNPCKHQDQ fmt src dst + -> PUNPCKHQDQ fmt (patchOp src) (env dst) + PUNPCKHDQ fmt src dst + -> PUNPCKHDQ fmt (patchOp src) (env dst) + PUNPCKHWD fmt src dst + -> PUNPCKHWD fmt (patchOp src) (env dst) + PUNPCKHBW fmt src dst + -> PUNPCKHBW fmt (patchOp src) (env dst) + PACKUSWB fmt src dst + -> PACKUSWB fmt (patchOp src) (env dst) + + MINMAX minMax ty fmt src dst + -> MINMAX minMax ty fmt (patchOp src) (env dst) + VMINMAX minMax ty fmt src1 src2 dst + -> VMINMAX minMax ty fmt (patchOp src1) (env src2) (env dst) + + where + patch1 :: (Operand -> a) -> Operand -> a + patch1 insn op = insn $! patchOp op + patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a + patch2 insn src dst = (insn $! patchOp src) $! patchOp dst + patch3 :: (Operand -> Reg -> Reg -> a) -> Operand -> Reg -> Reg -> a + patch3 insn src1 src2 dst = ((insn $! patchOp src1) $! env src2) $! env dst + + patchOp (OpReg reg) = OpReg $! env reg + patchOp (OpImm imm) = OpImm imm + patchOp (OpAddr ea) = OpAddr $! lookupAddr ea + + lookupAddr (ImmAddr imm off) = ImmAddr imm off + lookupAddr (AddrBaseIndex base index disp) + = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp + where + lookupBase EABaseNone = EABaseNone + lookupBase EABaseRip = EABaseRip + lookupBase (EABaseReg r) = EABaseReg $! env r + + lookupIndex EAIndexNone = EAIndexNone + lookupIndex (EAIndex r i) = (EAIndex $! env r) i + + +-------------------------------------------------------------------------------- +isJumpishInstr + :: Instr -> Bool + +isJumpishInstr instr + = case instr of + JMP{} -> True + JXX{} -> True + JXX_GBL{} -> True + JMP_TBL{} -> True + CALL{} -> True + _ -> False + +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo insn bid + = case insn of + JXX _ target -> bid == target + JMP_TBL _ targets _ _ -> all isTargetBid targets + _ -> False + where + isTargetBid target = case target of + Nothing -> True + Just (DestBlockId target) -> target == bid + _ -> False + +jumpDestsOfInstr + :: Instr + -> [BlockId] + +jumpDestsOfInstr insn + = case insn of + JXX _ id -> [id] + JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids] + _ -> [] + + +patchJumpInstr + :: Instr -> (BlockId -> BlockId) -> Instr + +patchJumpInstr insn patchF + = case insn of + JXX cc id -> JXX cc (patchF id) + JMP_TBL op ids section lbl + -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section lbl + _ -> insn + where + patchJumpDest f (DestBlockId id) = DestBlockId (f id) + patchJumpDest _ dest = dest + + + + + +-- ----------------------------------------------------------------------------- +-- | Make a spill instruction. +mkSpillInstr + :: HasDebugCallStack + => NCGConfig + -> RegWithFormat -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] + +mkSpillInstr config (RegWithFormat reg fmt) delta slot = + [ movInstr config fmt' (OpReg reg) (OpAddr (spRel platform off)) ] + where + fmt' + | isVecFormat fmt + = fmt + | otherwise + = scalarMoveFormat platform fmt + -- Spill the platform word size, at a minimum + platform = ncgPlatform config + off = spillSlotToOffset platform slot - delta + +-- | Make a spill reload instruction. +mkLoadInstr + :: HasDebugCallStack + => NCGConfig + -> RegWithFormat -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] + +mkLoadInstr config (RegWithFormat reg fmt) delta slot = + [ movInstr config fmt' (OpAddr (spRel platform off)) (OpReg reg) ] + where + fmt' + | isVecFormat fmt + = fmt + | otherwise + = scalarMoveFormat platform fmt + -- Load the platform word size, at a minimum + platform = ncgPlatform config + off = spillSlotToOffset platform slot - delta + +-- | A move instruction for moving the entire contents of an operand +-- at the given 'Format'. +movInstr :: HasDebugCallStack => NCGConfig -> Format -> (Operand -> Operand -> Instr) +movInstr config fmt = + case fmt of + VecFormat _ sFmt -> + case formatToWidth fmt of + W512 -> + if avx512f + then avx_move sFmt + else sorry "512-bit wide vectors require -mavx512f" + W256 -> + if avx2 + then avx_move sFmt + else sorry "256-bit wide vectors require -mavx2" + W128 -> + if avx + -- Prefer AVX instructions over SSE when available + -- (usually results in better performance). + then avx_move sFmt + else sse_move sFmt + w -> sorry $ "Unhandled SIMD vector width: " ++ show w ++ " bits" + _ -> MOV fmt + where + + assertCompatibleRegs :: ( Operand -> Operand -> Instr ) -> Operand -> Operand -> Instr + assertCompatibleRegs f + | debugIsOn + = \ op1 op2 -> + if | OpReg r1 <- op1 + , OpReg r2 <- op2 + , targetClassOfReg plat r1 /= targetClassOfReg plat r2 + -> assertPpr False + ( vcat [ text "movInstr: move between incompatible registers" + , text "fmt:" <+> ppr fmt + , text "r1:" <+> ppr r1 + , text "r2:" <+> ppr r2 ] + ) f op1 op2 + | otherwise + -> f op1 op2 + | otherwise + = f + + plat = ncgPlatform config + avx = ncgAvxEnabled config + avx2 = ncgAvx2Enabled config + avx512f = ncgAvx512fEnabled config + avx_move sFmt = + if isFloatScalarFormat sFmt + then assertCompatibleRegs $ + VMOVU fmt + else VMOVDQU fmt + sse_move sFmt = + if isFloatScalarFormat sFmt + then assertCompatibleRegs $ + MOVU fmt + else MOVDQU fmt + -- NB: we are using {V}MOVU and not {V}MOVA, because we have no guarantees + -- about the stack being sufficiently aligned (even for even numbered stack slots). + -- + -- (Ben Gamari told me that using MOVA instead of MOVU does not make a + -- difference in practice when moving between registers.) + +spillSlotSize :: Platform -> Int +spillSlotSize platform + | target32Bit platform = 12 + | otherwise = 8 + +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config + = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize (ncgPlatform config)) - 1 +-- = 0 -- useful for testing allocMoreStack + +-- number of bytes that the stack pointer should be aligned to +stackAlign :: Int +stackAlign = 16 + +-- convert a spill slot number to a *byte* offset, with no sign: +-- decide on a per arch basis whether you are spilling above or below +-- the C stack pointer. +spillSlotToOffset :: Platform -> Int -> Int +spillSlotToOffset platform slot + = 64 + spillSlotSize platform * slot + +-------------------------------------------------------------------------------- + +-- | See if this instruction is telling us the current C stack delta +takeDeltaInstr + :: Instr + -> Maybe Int + +takeDeltaInstr instr + = case instr of + DELTA i -> Just i + _ -> Nothing + + +isMetaInstr + :: Instr + -> Bool + +isMetaInstr instr + = case instr of + COMMENT{} -> True + LOCATION{} -> True + LDATA{} -> True + NEWBLOCK{} -> True + UNWIND{} -> True + DELTA{} -> True + _ -> False + +-- | Make a reg-reg move instruction. +mkRegRegMoveInstr + :: HasDebugCallStack + => NCGConfig + -> Format + -> Reg + -> Reg + -> Instr +mkRegRegMoveInstr config fmt src dst = + movInstr config fmt' (OpReg src) (OpReg dst) + -- Move the platform word size, at a minimum. + -- + -- This ensures the upper part of the register is properly cleared + -- and avoids partial register stalls. + -- + -- See also the 'ArithInt8' and 'ArithWord8' tests, + -- which fail without this logic. + where + platform = ncgPlatform config + fmt' + | isVecFormat fmt + = fmt + | otherwise + = scalarMoveFormat platform fmt + +scalarMoveFormat :: Platform -> Format -> Format +scalarMoveFormat platform fmt + | isFloatFormat fmt + = FF64 + | II64 <- fmt + = II64 + | otherwise + = archWordFormat (target32Bit platform) + +-- | Check whether an instruction represents a reg-reg move. +-- The register allocator attempts to eliminate reg->reg moves whenever it can, +-- by assigning the src and dest temporaries to the same real register. +-- +takeRegRegMoveInstr + :: Platform + -> Instr + -> Maybe (Reg,Reg) + +takeRegRegMoveInstr platform = \case + MOV fmt (OpReg r1) (OpReg r2) + -- When used with vector registers, MOV only moves the lower part, + -- so it is not a real move. For example, MOVSS/MOVSD between xmm registers + -- preserves the upper half, and MOVQ between xmm registers zeroes the upper half. + | not $ isVecFormat fmt + -- Don't eliminate a move between e.g. RAX and XMM: + -- even though we might be using XMM to store a scalar integer value, + -- some instructions only support XMM registers. + , targetClassOfReg platform r1 == targetClassOfReg platform r2 + -> Just (r1, r2) + MOVD {} + -- MOVD moves between xmm registers and general-purpose registers, + -- and we don't want to eliminate those moves (as noted for MOV). + -> Nothing + + -- SSE2/AVX move instructions always move the full register. + MOVU _ (OpReg r1) (OpReg r2) + -> Just (r1, r2) + VMOVU _ (OpReg r1) (OpReg r2) + -> Just (r1, r2) + MOVDQU _ (OpReg r1) (OpReg r2) + -> Just (r1, r2) + VMOVDQU _ (OpReg r1) (OpReg r2) + -> Just (r1, r2) + + -- TODO: perhaps we can eliminate MOVZxL in certain situations? + MOVZxL {} -> Nothing + MOVSxL {} -> Nothing + + -- MOVL, MOVH and MOVHLPS preserve some part of the destination register, + -- so are not simple moves. + MOVL {} -> Nothing + MOVH {} -> Nothing + MOVHLPS {} -> Nothing + + -- Other instructions are not moves. + _ -> Nothing + +-- | Make an unconditional branch instruction. +mkJumpInstr + :: BlockId + -> [Instr] + +mkJumpInstr id + = [JXX ALWAYS id] + +-- Note [Windows stack layout] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- | On most OSes the kernel will place a guard page after the current stack +-- page. If you allocate larger than a page worth you may jump over this +-- guard page. Not only is this a security issue, but on certain OSes such +-- as Windows a new page won't be allocated if you don't hit the guard. This +-- will cause a segfault or access fault. +-- +-- This function defines if the current allocation amount requires a probe. +-- On Windows (for now) we emit a call to _chkstk for this. For other OSes +-- this is not yet implemented. +-- See https://docs.microsoft.com/en-us/windows/desktop/DevNotes/-win32-chkstk +-- The Windows stack looks like this: +-- +-- +-------------------+ +-- | SP | +-- +-------------------+ +-- | | +-- | GUARD PAGE | +-- | | +-- +-------------------+ +-- | | +-- | | +-- | UNMAPPED | +-- | | +-- | | +-- +-------------------+ +-- +-- In essence each allocation larger than a page size needs to be chunked and +-- a probe emitted after each page allocation. You have to hit the guard +-- page so the kernel can map in the next page, otherwise you'll segfault. +-- See Note [Windows stack allocations]. +-- +needs_probe_call :: Platform -> Int -> Bool +needs_probe_call platform amount + = case platformOS platform of + OSMinGW32 -> case platformArch platform of + ArchX86_64 -> amount > (4 * 1024) + _ -> False + _ -> False + +mkStackAllocInstr + :: Platform + -> Int + -> [Instr] +mkStackAllocInstr platform amount + = case platformOS platform of + OSMinGW32 -> + -- These will clobber AX but this should be ok because + -- + -- 1. It is the first thing we do when entering the closure and AX is + -- a caller saved registers on Windows both on x86_64 and x86. + -- + -- 2. The closures are only entered via a call or longjmp in which case + -- there are no expectations for volatile registers. + -- + -- 3. When the target is a local branch point it is re-targeted + -- after the dealloc, preserving #2. See Note [extra spill slots]. + -- + -- We emit a call because the stack probes are quite involved and + -- would bloat code size a lot. GHC doesn't really have an -Os. + -- ___chkstk is guaranteed to leave all nonvolatile registers and AX + -- untouched. It's part of the standard prologue code for any Windows + -- function dropping the stack more than a page. + -- See Note [Windows stack layout] + case platformArch platform of + ArchX86_64 | needs_probe_call platform amount -> + [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax) + , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [RegWithFormat rax II64] + , SUB II64 (OpReg rax) (OpReg rsp) + ] + | otherwise -> + [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) + , TEST II64 (OpReg rsp) (OpReg rsp) + ] + _ -> panic "X86.mkStackAllocInstr" + _ -> + case platformArch platform of + ArchX86 -> [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) ] + ArchX86_64 -> [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) ] + _ -> panic "X86.mkStackAllocInstr" + +mkStackDeallocInstr + :: Platform + -> Int + -> [Instr] +mkStackDeallocInstr platform amount + = case platformArch platform of + ArchX86 -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)] + ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)] + _ -> panic "X86.mkStackDeallocInstr" + + +-- Note [extra spill slots] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- If the register allocator used more spill slots than we have +-- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more +-- C stack space on entry and exit from this proc. Therefore we +-- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp" +-- before every non-local jump. +-- +-- This became necessary when the new codegen started bundling entire +-- functions together into one proc, because the register allocator +-- assigns a different stack slot to each virtual reg within a proc. +-- To avoid using so many slots we could also: +-- +-- - split up the proc into connected components before code generator +-- +-- - rename the virtual regs, so that we re-use vreg names and hence +-- stack slots for non-overlapping vregs. +-- +-- Note that when a block is both a non-local entry point (with an +-- info table) and a local branch target, we have to split it into +-- two, like so: +-- +-- +-- L: +-- +-- +-- becomes +-- +-- +-- L: +-- subl $rsp, N +-- jmp Lnew +-- Lnew: +-- +-- +-- and all branches pointing to L are retargetted to point to Lnew. +-- Otherwise, we would repeat the $rsp adjustment for each branch to +-- L. +-- +-- Returns a list of (L,Lnew) pairs. +-- +allocMoreStack + :: Platform + -> Int + -> NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr + -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr, [(BlockId,BlockId)]) + +allocMoreStack _ _ top@(CmmData _ _) = return (top,[]) +allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do + let entries = entryBlocks proc + + retargetList <- mapM (\e -> (e,) <$> newBlockId) entries + + let + delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up + where x = slots * spillSlotSize platform -- sp delta + + alloc = mkStackAllocInstr platform delta + dealloc = mkStackDeallocInstr platform delta + + new_blockmap :: LabelMap BlockId + new_blockmap = mapFromList retargetList + + insert_stack_insns (BasicBlock id insns) + | Just new_blockid <- mapLookup id new_blockmap + = [ BasicBlock id $ alloc ++ [JXX ALWAYS new_blockid] + , BasicBlock new_blockid block' ] + | otherwise + = [ BasicBlock id block' ] + where + block' = foldr insert_dealloc [] insns + + insert_dealloc insn r = case insn of + JMP _ _ -> dealloc ++ (insn : r) + JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL" + _other -> patchJumpInstr insn retarget : r + where retarget b = fromMaybe b (mapLookup b new_blockmap) + + new_code = concatMap insert_stack_insns code + -- in + return (CmmProc info lbl live (ListGraph new_code), retargetList) + +data JumpDest = DestBlockId BlockId | DestImm Imm + +-- Debug Instance +instance Outputable JumpDest where + ppr (DestBlockId bid) = text "jd:" <> ppr bid + ppr (DestImm _imm) = text "jd:noShow" + +-- Implementations of the methods of 'NgcImpl' + +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid +getJumpDestBlockId _ = Nothing + +canShortcut :: Instr -> Maybe JumpDest +canShortcut (JXX ALWAYS id) = Just (DestBlockId id) +canShortcut (JMP (OpImm imm) _) = Just (DestImm imm) +canShortcut _ = Nothing + +-- This helper shortcuts a sequence of branches. +-- The blockset helps avoid following cycles. +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn + where + shortcutJump' :: (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr + shortcutJump' fn seen insn@(JXX cc id) = + if setMember id seen then insn + else case fn id of + Nothing -> insn + Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id') + Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm) + where seen' = setInsert id seen + shortcutJump' fn _ (JMP_TBL addr blocks section tblId) = + let updateBlock (Just (DestBlockId bid)) = + case fn bid of + Nothing -> Just (DestBlockId bid ) + Just dest -> Just dest + updateBlock dest = dest + blocks' = map updateBlock blocks + in JMP_TBL addr blocks' section tblId + shortcutJump' _ _ other = other + +-- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, RawCmmStatics) -> (Alignment, RawCmmStatics) +shortcutStatics fn (align, CmmStaticsRaw lbl statics) + = (align, CmmStaticsRaw lbl $ map (shortcutStatic fn) statics) + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqueSet blkId + | otherwise = lab + +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w) + -- slightly dodgy, we're ignoring the second label, but this + -- works with the way we use CmmLabelDiffOff for jump tables now. +shortcutStatic _ other_static + = other_static + +shortBlockId + :: (BlockId -> Maybe JumpDest) + -> UniqueSet + -> BlockId + -> CLabel + +shortBlockId fn seen blockid = + case (memberUniqueSet uq seen, fn blockid) of + (True, _) -> blockLbl blockid + (_, Nothing) -> blockLbl blockid + (_, Just (DestBlockId blockid')) -> shortBlockId fn (insertUniqueSet uq seen) blockid' + (_, Just (DestImm (ImmCLbl lbl))) -> lbl + (_, _other) -> panic "shortBlockId" + where uq = getUnique blockid diff --git a/GHC/CmmToAsm/X86/Ppr.hs b/GHC/CmmToAsm/X86/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/Ppr.hs @@ -0,0 +1,1562 @@ + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- +-- Pretty-printing assembly language +-- +-- (c) The University of Glasgow 1993-2005 +-- +----------------------------------------------------------------------------- + +module GHC.CmmToAsm.X86.Ppr ( + pprNatCmmDecl, + pprInstr, +) + +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Reg + +import GHC.CmmToAsm.X86.Regs +import GHC.CmmToAsm.X86.Instr +import GHC.CmmToAsm.X86.Cond +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils +import GHC.CmmToAsm.Ppr + +import GHC.Cmm hiding (topInfoTable) +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.DebugBlock (pprUnwindTable) + +import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) +import GHC.Types.Unique ( pprUniqueAlways ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.List ( intersperse ) +import Data.Word + +-- Note [Subsections Via Symbols] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we are using the .subsections_via_symbols directive +-- (available on recent versions of Darwin), +-- we have to make sure that there is some kind of reference +-- from the entry code to a label on the _top_ of the info table, +-- so that the linker will not think it is unreferenced and dead-strip +-- it. That's why the label is called a DeadStripPreventer (_dsp). +-- +-- The LLVM code gen already creates `iTableSuf` symbols, where +-- the X86 would generate the DeadStripPreventer (_dsp) symbol. +-- Therefore all that is left for llvm code gen, is to ensure +-- that all the `iTableSuf` symbols are marked as used. +-- As of this writing the documentation regarding the +-- .subsections_via_symbols and -dead_strip can be found at +-- + +pprProcAlignment :: IsDoc doc => NCGConfig -> doc +pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config) + where + platform = ncgPlatform config + +pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> doc +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section $$ pprDatas config dats + +pprNatCmmDecl config proc@(CmmProc top_info entry_lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config + top_info_table = topInfoTable proc + -- we need a label to delimit the proc code (e.g. in debug builds). When + -- we have an info table, we reuse the info table label. Otherwise we use + -- the entry label. + proc_lbl = case top_info_table of + Just (CmmStaticsRaw info_lbl _) -> info_lbl + Nothing -> entry_lbl + + -- handle subsections_via_symbols when enabled and when we have an + -- info-table to link to. See Note [Subsections Via Symbols] + (sub_via_sym_label,sub_via_sym_offset) + | platformHasSubsectionsViaSymbols platform + , Just (CmmStaticsRaw info_lbl _) <- top_info_table + , info_dsp_lbl <- pprAsmLabel platform (mkDeadStripPreventer info_lbl) + = ( line (info_dsp_lbl <> colon) + , line $ text "\t.long " <+> pprAsmLabel platform info_lbl <+> char '-' <+> info_dsp_lbl + ) + | otherwise = (empty,empty) + + in vcat + [ -- section directive. Requires proc_lbl when split-section is enabled to + -- use as a subsection name. + pprSectionAlign config (Section Text proc_lbl) + + -- section alignment. Note that when there is an info table, we align the + -- info table and not the entry code! + , pprProcAlignment config + + -- Special label when ncgExposeInternalSymbols is enabled. See Note + -- [Internal proc labels] in GHC.Cmm.Label + , pprExposedInternalProcLabel config entry_lbl + + -- Subsections-via-symbols label. See Note [Subsections Via Symbols] + , sub_via_sym_label + + -- We need to print a label indicating the beginning of the entry code: + -- 1. Without tables-next-to-code, we just print it here + -- 2. With tables-next-to-code, the proc_lbl is the info-table label and it + -- will be printed in pprBasicBlock after the info-table itself. + , case top_info_table of + Nothing -> pprLabel platform proc_lbl + Just _ -> empty + + -- Proc's basic blocks + , vcat (map (pprBasicBlock config top_info) blocks) + -- Note that even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + + -- Print the proc end label when debugging is enabled + , ppWhen (ncgDwarfEnabled config) $ line (pprProcEndLabel platform proc_lbl) + + -- Subsections-via-symbols offset. See Note [Subsections Via Symbols] + , sub_via_sym_offset + + -- ELF .size directive (size of the entry code function) + , pprSizeDecl platform proc_lbl + ] +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc #-} +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Output an internal proc label. See Note [Internal proc labels] in CLabel. +pprExposedInternalProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc +pprExposedInternalProcLabel config lbl + | ncgExposeInternalSymbols config + , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl + = line (lbl' <> colon) + | otherwise + = empty + +pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name + -> doc +pprProcEndLabel platform lbl = pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon + +pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name + -> doc +pprBlockEndLabel platform lbl = + pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon + +-- | Output the ELF .size directive. +pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc +pprSizeDecl platform lbl + = if osElfTarget (platformOS platform) + then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl) + else empty + +pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc +pprBasicBlock config info_env (BasicBlock blockid instrs) + = maybe_infotable $ + pprLabel platform block_label $$ + vcat (map (pprInstr platform) instrs) $$ + ppWhen (ncgDwarfEnabled config) ( + -- Emit both end labels since this may end up being a standalone + -- top-level block + line (pprBlockEndLabel platform block_label) $$ + line (pprProcEndLabel platform block_label) + ) + where + block_label = blockLbl blockid + platform = ncgPlatform config + maybe_infotable c = case mapLookup blockid info_env of + Nothing -> c + Just (CmmStaticsRaw infoLbl info) -> + pprAlignForSection platform Text $$ + infoTableLoc $$ + vcat (map (pprData config) info) $$ + pprLabel platform infoLbl $$ + c $$ + ppWhen (ncgDwarfEnabled config) (line (pprBlockEndLabel platform infoLbl)) + + -- Make sure the info table has the right .loc for the block + -- coming right after it. See Note [Info Offset] + infoTableLoc = case instrs of + (l@LOCATION{} : _) -> pprInstr platform l + _other -> empty + + +pprDatas :: IsDoc doc => NCGConfig -> (Alignment, RawCmmStatics) -> doc +-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' + = pprGloblDecl (ncgPlatform config) alias + $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind') + +pprDatas config (align, (CmmStaticsRaw lbl dats)) + = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats) + where + platform = ncgPlatform config + +pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc +pprData _config (CmmString str) = line (pprString str) +pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path) + +pprData config (CmmUninitialised bytes) + = line + $ let platform = ncgPlatform config + in if platformOS platform == OSDarwin + then text ".space " <> int bytes + else text ".skip " <> int bytes + +pprData config (CmmStaticLit lit) = pprDataItem config lit + +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc +pprGloblDecl platform lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = line (text ".globl " <> pprAsmLabel platform lbl) + +pprLabelType' :: IsLine doc => Platform -> CLabel -> doc +pprLabelType' platform lbl = + if isCFunctionLabel lbl || functionOkInfoTable then + text "@function" + else + text "@object" + where + {- + NOTE: This is a bit hacky. + + With the `tablesNextToCode` info tables look like this: + ``` + + label_info: + + ``` + So actually info table label points exactly to the code and we can mark + the label as @function. (This is required to make perf and potentially other + tools to work on Haskell binaries). + This usually works well but it can cause issues with a linker. + A linker uses different algorithms for the relocation depending on + the symbol type.For some reason, a linker will generate JUMP_SLOT relocation + when constructor info table is referenced from a data section. + This only happens with static constructor call so + we mark _con_info symbols as `@object` to avoid the issue with relocations. + + @SimonMarlow hack explanation: + "The reasoning goes like this: + + * The danger when we mark a symbol as `@function` is that the linker will + redirect it to point to the PLT and use a `JUMP_SLOT` relocation when + the symbol refers to something outside the current shared object. + A PLT / JUMP_SLOT reference only works for symbols that we jump to, not + for symbols representing data,, nor for info table symbol references which + we expect to point directly to the info table. + * GHC generates code that might refer to any info table symbol from the text + segment, but that's OK, because those will be explicit GOT references + generated by the code generator. + * When we refer to info tables from the data segment, it's either + * a FUN_STATIC/THUNK_STATIC local to this module + * a `con_info` that could be from anywhere + + So, the only info table symbols that we might refer to from the data segment + of another shared object are `con_info` symbols, so those are the ones we + need to exclude from getting the @function treatment. + " + + A good place to check for more + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code + + Another possible hack is to create an extra local function symbol for + every code-like thing to give the needed information for to the tools + but mess up with the relocation. https://phabricator.haskell.org/D4730 + -} + functionOkInfoTable = platformTablesNextToCode platform && + isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl) + + +pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc +pprTypeDecl platform lbl + = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) + else empty + +pprLabel :: IsDoc doc => Platform -> CLabel -> doc +pprLabel platform lbl = + pprGloblDecl platform lbl + $$ pprTypeDecl platform lbl + $$ line (pprAsmLabel platform lbl <> colon) + +pprAlign :: IsDoc doc => Platform -> Alignment -> doc +pprAlign platform alignment + = line $ text ".align " <> int (alignmentOn platform) + where + bytes = alignmentBytes alignment + alignmentOn platform = if platformOS platform == OSDarwin + then log2 bytes + else bytes + + log2 :: Int -> Int -- cache the common ones + log2 1 = 0 + log2 2 = 1 + log2 4 = 2 + log2 8 = 3 + log2 n = 1 + log2 (n `quot` 2) + +pprReg :: forall doc. IsLine doc => Platform -> Format -> Reg -> doc +pprReg platform f r + = case r of + RegReal (RealRegSingle i) -> + if target32Bit platform then ppr32_reg_no f i + else ppr64_reg_no f i + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u + RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u + RegVirtual (VirtualRegV128 u) -> text "%vV128_" <> pprUniqueAlways u + + where + ppr32_reg_no :: Format -> Int -> doc + ppr32_reg_no II8 = ppr32_reg_byte + ppr32_reg_no II16 = ppr32_reg_word + ppr32_reg_no fmt = ppr32_reg_long fmt + + ppr32_reg_byte i = + case i of { + 0 -> text "%al"; 1 -> text "%bl"; + 2 -> text "%cl"; 3 -> text "%dl"; + _ -> text "very naughty I386 byte register: " <> int i + } + + ppr32_reg_word i = + case i of { + 0 -> text "%ax"; 1 -> text "%bx"; + 2 -> text "%cx"; 3 -> text "%dx"; + 4 -> text "%si"; 5 -> text "%di"; + 6 -> text "%bp"; 7 -> text "%sp"; + _ -> text "very naughty I386 word register" + } + + ppr32_reg_long fmt i = + case i of { + 0 -> text "%eax"; 1 -> text "%ebx"; + 2 -> text "%ecx"; 3 -> text "%edx"; + 4 -> text "%esi"; 5 -> text "%edi"; + 6 -> text "%ebp"; 7 -> text "%esp"; + _ -> ppr_reg_float fmt i + } + + ppr64_reg_no :: Format -> Int -> doc + ppr64_reg_no II8 = ppr64_reg_byte + ppr64_reg_no II16 = ppr64_reg_word + ppr64_reg_no II32 = ppr64_reg_long + ppr64_reg_no fmt = ppr64_reg_quad fmt + + ppr64_reg_byte i = + case i of { + 0 -> text "%al"; 1 -> text "%bl"; + 2 -> text "%cl"; 3 -> text "%dl"; + 4 -> text "%sil"; 5 -> text "%dil"; -- new 8-bit regs! + 6 -> text "%bpl"; 7 -> text "%spl"; + 8 -> text "%r8b"; 9 -> text "%r9b"; + 10 -> text "%r10b"; 11 -> text "%r11b"; + 12 -> text "%r12b"; 13 -> text "%r13b"; + 14 -> text "%r14b"; 15 -> text "%r15b"; + _ -> text "very naughty x86_64 byte register: " <> int i + } + + ppr64_reg_word i = + case i of { + 0 -> text "%ax"; 1 -> text "%bx"; + 2 -> text "%cx"; 3 -> text "%dx"; + 4 -> text "%si"; 5 -> text "%di"; + 6 -> text "%bp"; 7 -> text "%sp"; + 8 -> text "%r8w"; 9 -> text "%r9w"; + 10 -> text "%r10w"; 11 -> text "%r11w"; + 12 -> text "%r12w"; 13 -> text "%r13w"; + 14 -> text "%r14w"; 15 -> text "%r15w"; + _ -> text "very naughty x86_64 word register" + } + + ppr64_reg_long i = + case i of { + 0 -> text "%eax"; 1 -> text "%ebx"; + 2 -> text "%ecx"; 3 -> text "%edx"; + 4 -> text "%esi"; 5 -> text "%edi"; + 6 -> text "%ebp"; 7 -> text "%esp"; + 8 -> text "%r8d"; 9 -> text "%r9d"; + 10 -> text "%r10d"; 11 -> text "%r11d"; + 12 -> text "%r12d"; 13 -> text "%r13d"; + 14 -> text "%r14d"; 15 -> text "%r15d"; + _ -> text "very naughty x86_64 register" + } + + ppr64_reg_quad fmt i = + case i of { + 0 -> text "%rax"; 1 -> text "%rbx"; + 2 -> text "%rcx"; 3 -> text "%rdx"; + 4 -> text "%rsi"; 5 -> text "%rdi"; + 6 -> text "%rbp"; 7 -> text "%rsp"; + 8 -> text "%r8"; 9 -> text "%r9"; + 10 -> text "%r10"; 11 -> text "%r11"; + 12 -> text "%r12"; 13 -> text "%r13"; + 14 -> text "%r14"; 15 -> text "%r15"; + _ -> ppr_reg_float fmt i + } + +ppr_reg_float :: IsLine doc => Format -> Int -> doc +ppr_reg_float fmt i + | W256 <- size + = case i of + 16 -> text "%ymm0" ; 17 -> text "%ymm1" + 18 -> text "%ymm2" ; 19 -> text "%ymm3" + 20 -> text "%ymm4" ; 21 -> text "%ymm5" + 22 -> text "%ymm6" ; 23 -> text "%ymm7" + 24 -> text "%ymm8" ; 25 -> text "%ymm9" + 26 -> text "%ymm10"; 27 -> text "%ymm11" + 28 -> text "%ymm12"; 29 -> text "%ymm13" + 30 -> text "%ymm14"; 31 -> text "%ymm15" + _ -> text "very naughty x86 register" + | W512 <- size + = case i of + 16 -> text "%zmm0" ; 17 -> text "%zmm1" + 18 -> text "%zmm2" ; 19 -> text "%zmm3" + 20 -> text "%zmm4" ; 21 -> text "%zmm5" + 22 -> text "%zmm6" ; 23 -> text "%zmm7" + 24 -> text "%zmm8" ; 25 -> text "%zmm9" + 26 -> text "%zmm10"; 27 -> text "%zmm11" + 28 -> text "%zmm12"; 29 -> text "%zmm13" + 30 -> text "%zmm14"; 31 -> text "%zmm15" + _ -> text "very naughty x86 register" + | otherwise + = case i of + 16 -> text "%xmm0" ; 17 -> text "%xmm1" + 18 -> text "%xmm2" ; 19 -> text "%xmm3" + 20 -> text "%xmm4" ; 21 -> text "%xmm5" + 22 -> text "%xmm6" ; 23 -> text "%xmm7" + 24 -> text "%xmm8" ; 25 -> text "%xmm9" + 26 -> text "%xmm10"; 27 -> text "%xmm11" + 28 -> text "%xmm12"; 29 -> text "%xmm13" + 30 -> text "%xmm14"; 31 -> text "%xmm15" + _ -> text "very naughty x86 register" + where size = formatToWidth fmt + +pprFormat :: IsLine doc => Format -> doc +pprFormat x = case x of + II8 -> text "b" + II16 -> text "w" + II32 -> text "l" + II64 -> text "q" + FF32 -> text "ss" -- "scalar single-precision float" (SSE2) + FF64 -> text "sd" -- "scalar double-precision float" (SSE2) + VecFormat _ FmtFloat -> text "ps" + VecFormat _ FmtDouble -> text "pd" + -- TODO: this is shady because it only works for certain instructions + VecFormat _ FmtInt8 -> text "b" + VecFormat _ FmtInt16 -> text "w" + VecFormat _ FmtInt32 -> text "d" + VecFormat _ FmtInt64 -> text "q" + +pprFormat_x87 :: IsLine doc => Format -> doc +pprFormat_x87 x = case x of + FF32 -> text "s" + FF64 -> text "l" + _ -> panic "X86.Ppr.pprFormat_x87" + + +pprCond :: IsLine doc => Cond -> doc +pprCond c = case c of { + GEU -> text "ae"; LU -> text "b"; + EQQ -> text "e"; GTT -> text "g"; + GE -> text "ge"; GU -> text "a"; + LTT -> text "l"; LE -> text "le"; + LEU -> text "be"; NE -> text "ne"; + NEG -> text "s"; POS -> text "ns"; + CARRY -> text "c"; OFLO -> text "o"; + PARITY -> text "p"; NOTPARITY -> text "np"; + ALWAYS -> text "mp"} + + +pprImm :: IsLine doc => Platform -> Imm -> doc +pprImm platform = \case + ImmInt i -> int i + ImmInteger i -> integer i + ImmCLbl l -> pprAsmLabel platform l + ImmIndex l i -> pprAsmLabel platform l <> char '+' <> int i + ImmLit s -> ftext s + ImmFloat f -> float $ fromRational f + ImmDouble d -> double $ fromRational d + ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b + ImmConstantDiff a b -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen + + + +pprAddr :: IsLine doc => Platform -> AddrMode -> doc +pprAddr platform (ImmAddr imm off) + = let pp_imm = pprImm platform imm + in + if (off == 0) then + pp_imm + else if (off < 0) then + pp_imm <> int off + else + pp_imm <> char '+' <> int off + +pprAddr platform (AddrBaseIndex base index displacement) + = let + pp_disp = ppr_disp displacement + pp_off p = pp_disp <> char '(' <> p <> char ')' + pp_reg r = pprReg platform (archWordFormat (target32Bit platform)) r + in + case (base, index) of + (EABaseNone, EAIndexNone) -> pp_disp + (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b) + (EABaseRip, EAIndexNone) -> pp_off (text "%rip") + (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i) + (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r + <> comma <> int i) + _ -> panic "X86.Ppr.pprAddr: no match" + + where + ppr_disp (ImmInt 0) = empty + ppr_disp imm = pprImm platform imm + +-- | Print section header and appropriate alignment for that section. +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc +pprSectionAlign _config (Section (OtherSection _) _) = + panic "X86.Ppr.pprSectionAlign: unknown section" +pprSectionAlign config sec@(Section seg _) = + line (pprSectionHeader config sec) $$ + pprAlignForSection (ncgPlatform config) seg + +-- | Print appropriate alignment for the given section type. +pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc +pprAlignForSection platform seg = line $ + text ".align " <> + case platformOS platform of + -- Darwin: alignments are given as shifts. + OSDarwin + | target32Bit platform -> + case seg of + CString -> int 1 + _ -> int 2 + | otherwise -> + case seg of + CString -> int 1 + _ -> int 3 + -- Other: alignments are given as bytes. + _ + | target32Bit platform -> + case seg of + Text -> text "4,0x90" + CString -> int 1 + _ -> int 4 + | otherwise -> + case seg of + CString -> int 1 + _ -> int 8 + +pprDataItem :: forall doc. IsDoc doc => NCGConfig -> CmmLit -> doc +pprDataItem config lit = + let (itemFmt, items) = itemFormatAndItems (cmmTypeFormat $ cmmLitType platform lit) + in line $ itemFmt <> hsep (punctuate comma (items lit)) + where + platform = ncgPlatform config + + pprLitImm, pprII64AsII32x2 :: CmmLit -> [Line doc] + pprLitImm = (:[]) . pprImm platform . litToImm + pprII64AsII32x2 (CmmInt x _) + = [ int (fromIntegral (fromIntegral x :: Word32)) + , int (fromIntegral (fromIntegral (x `shiftR` 32) :: Word32)) ] + pprII64AsII32x2 x + = pprPanic "X86 pprDataItem II64" (ppr x) + + itemFormatAndItems :: Format -> (Line doc, CmmLit -> [Line doc]) + itemFormatAndItems = \case + II8 -> ( text "\t.byte\t", pprLitImm ) + II16 -> ( text "\t.word\t", pprLitImm ) + II32 -> ( text "\t.long\t", pprLitImm ) + II64 -> + case platformOS platform of + OSDarwin + | target32Bit platform + -> ( text "\t.long\t", pprII64AsII32x2 ) + _ -> ( text "\t.quad\t", pprLitImm ) + FF32 -> ( text "\t.float\t", pprLitImm ) + FF64 -> ( text "\t.double\t", pprLitImm ) + VecFormat _ sFmt -> + let (fmtTxt, pprElt) = itemFormatAndItems (scalarFormatFormat sFmt) + in (fmtTxt, \ case { CmmVec elts -> pprElt =<< elts + ; x -> pprPanic "X86 pprDataItem VecFormat" (ppr x) + }) + +asmComment :: IsLine doc => doc -> doc +asmComment c = whenPprDebug $ text "# " <> c + +pprInstr :: forall doc. IsDoc doc => Platform -> Instr -> doc +pprInstr platform i = case i of + COMMENT s + -> line (asmComment (ftext s)) + + LOCATION file line' col _name + -> line (text "\t.loc " <> int file <+> int line' <+> int col) + + DELTA d + -> line (asmComment $ text ("\tdelta = " ++ show d)) + + NEWBLOCK _ + -> panic "pprInstr: NEWBLOCK" + + UNWIND lbl d + -> line (asmComment (text "\tunwind = " <> pprUnwindTable platform d)) + $$ line (pprAsmLabel platform lbl <> colon) + + LDATA _ _ + -> panic "pprInstr: LDATA" + +{- + SPILL reg slot + -> hcat [ + text "\tSPILL", + char ' ', + pprUserReg reg, + comma, + text "SLOT" <> parens (int slot)] + + RELOAD slot reg + -> hcat [ + text "\tRELOAD", + char ' ', + text "SLOT" <> parens (int slot), + comma, + pprUserReg reg] +-} + + -- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper. + -- The code generator catches most of these already, but not all. + MOV format (OpImm (ImmInt 0)) dst@(OpReg _) + -> pprInstr platform (XOR format' dst dst) + where format' = case format of + II64 -> II32 -- 32-bit version is equivalent, and smaller + _ -> format + + MOV fmt src dst + -> pprFormatOpOp (text "mov") fmt' src dst + where + fmt' = case fmt of + VecFormat _l sFmt -> scalarFormatFormat sFmt + _ -> fmt + + CMOV cc format src dst + -> pprCondOpReg (text "cmov") format cc src dst + + MOVD format1 format2 src dst + -> pprMovdOpOp (text "mov") format1 format2 src dst + + MOVZxL II32 src dst + -> pprFormatOpOp (text "mov") II32 src dst + -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple + -- movl. But we represent it as a MOVZxL instruction, because + -- the reg alloc would tend to throw away a plain reg-to-reg + -- move, and we still want it to do that. + + MOVZxL formats src dst + -> pprFormatOpOpCoerce (text "movz") formats II32 src dst + -- zero-extension only needs to extend to 32 bits: on x86_64, + -- the remaining zero-extension to 64 bits is automatic, and the 32-bit + -- instruction is shorter. + + MOVSxL formats src dst + -> pprFormatOpOpCoerce (text "movs") formats (archWordFormat (target32Bit platform)) src dst + + -- here we do some patching, since the physical registers are only set late + -- in the code generation. + LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3) + | reg1 == reg3 + -> pprFormatOpOp (text "add") format (OpReg reg2) dst + + LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3) + | reg2 == reg3 + -> pprFormatOpOp (text "add") format (OpReg reg1) dst + + LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3) + | reg1 == reg3 + -> pprInstr platform (ADD format (OpImm displ) dst) + + LEA format src dst + -> pprFormatOpOp (text "lea") format src dst + + ADD format (OpImm (ImmInt (-1))) dst + -> pprFormatOp (text "dec") format dst + + ADD format (OpImm (ImmInt 1)) dst + -> pprFormatOp (text "inc") format dst + + ADD format src dst + -> pprFormatOpOp (text "add") format src dst + + ADC format src dst + -> pprFormatOpOp (text "adc") format src dst + + SUB format src dst + -> pprFormatOpOp (text "sub") format src dst + + SBB format src dst + -> pprFormatOpOp (text "sbb") format src dst + + IMUL format op1 op2 + -> pprFormatOpOp (text "imul") format op1 op2 + + ADD_CC format src dst + -> pprFormatOpOp (text "add") format src dst + + SUB_CC format src dst + -> pprFormatOpOp (text "sub") format src dst + + -- Use a 32-bit instruction when possible as it saves a byte. + -- Notably, extracting the tag bits of a pointer has this form. + -- TODO: we could save a byte in a subsequent CMP instruction too, + -- but need something like a peephole pass for this + AND II64 src@(OpImm (ImmInteger mask)) dst + | 0 <= mask && mask < 0xffffffff + -> pprInstr platform (AND II32 src dst) + + AND FF32 src dst + -> pprOpOp (text "andps") FF32 src dst + + AND FF64 src dst + -> pprOpOp (text "andpd") FF64 src dst + + AND format src dst + -> pprFormatOpOp (text "and") format src dst + + OR format src dst + -> pprFormatOpOp (text "or") format src dst + + XOR FF32 src dst + -> pprOpOp (text "xorps") FF32 src dst + + XOR FF64 src dst + -> pprOpOp (text "xorpd") FF64 src dst + + XOR format@(VecFormat _ sfmt) src dst | isIntScalarFormat sfmt + -> pprOpOp (text "pxor") format src dst + + XOR format src dst + -> pprFormatOpOp (text "xor") format src dst + + VXOR fmt src1 src2 dst + -> pprVxor fmt src1 src2 dst + + POPCNT format src dst + -> pprOpOp (text "popcnt") format src (OpReg dst) + + LZCNT format src dst + -> pprOpOp (text "lzcnt") format src (OpReg dst) + + TZCNT format src dst + -> pprOpOp (text "tzcnt") format src (OpReg dst) + + BSF format src dst + -> pprOpOp (text "bsf") format src (OpReg dst) + + BSR format src dst + -> pprOpOp (text "bsr") format src (OpReg dst) + + PDEP format src mask dst + -> pprFormatOpOpReg (text "pdep") format src mask dst + + PEXT format src mask dst + -> pprFormatOpOpReg (text "pext") format src mask dst + + PREFETCH NTA format src + -> pprFormatOp_ (text "prefetchnta") format src + + PREFETCH Lvl0 format src + -> pprFormatOp_ (text "prefetcht0") format src + + PREFETCH Lvl1 format src + -> pprFormatOp_ (text "prefetcht1") format src + + PREFETCH Lvl2 format src + -> pprFormatOp_ (text "prefetcht2") format src + + NOT format op + -> pprFormatOp (text "not") format op + + BSWAP format op + -> pprFormatOp (text "bswap") format (OpReg op) + + NEGI format op + -> pprFormatOp (text "neg") format op + + SHL format src dst + -> pprShift (text "shl") format src dst + + SAR format src dst + -> pprShift (text "sar") format src dst + + SHR format src dst + -> pprShift (text "shr") format src dst + + SHLD format src dst1 dst2 + -> pprShift2 (text "shld") format src dst1 dst2 + + SHRD format src dst1 dst2 + -> pprShift2 (text "shrd") format src dst1 dst2 + + BT format imm src + -> pprFormatImmOp (text "bt") format imm src + + CMP format src dst + | isFloatFormat format -> pprFormatOpOp (text "ucomi") format src dst -- SSE2 + | otherwise -> pprFormatOpOp (text "cmp") format src dst + + TEST format src dst + -> pprFormatOpOp (text "test") format' src dst + where + -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'. + -- We can replace them by equivalent, but smaller instructions + -- by reducing the size of the immediate operand as far as possible. + -- (We could handle masks larger than a single byte too, + -- but it would complicate the code considerably + -- and tag checks are by far the most common case.) + -- The mask must have the high bit clear for this smaller encoding + -- to be completely equivalent to the original; in particular so + -- that the signed comparison condition bits are the same as they + -- would be if doing a full word comparison. See #13425. + format' = case (src,dst) of + (OpImm (ImmInteger mask), OpReg dstReg) + | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg + _ -> format + minSizeOfReg platform (RegReal (RealRegSingle i)) + | target32Bit platform && i <= 3 = II8 -- al, bl, cl, dl + | target32Bit platform && i <= 7 = II16 -- si, di, bp, sp + | not (target32Bit platform) && i <= 15 = II8 -- al .. r15b + minSizeOfReg _ _ = format -- other + + PUSH format op + -> pprFormatOp (text "push") format op + + POP format op + -> pprFormatOp (text "pop") format op + +-- both unused (SDM): +-- PUSHA -> text "\tpushal" +-- POPA -> text "\tpopal" + + NOP + -> line $ text "\tnop" + + CLTD II8 + -> line $ text "\tcbtw" + + CLTD II16 + -> line $ text "\tcwtd" + + CLTD II32 + -> line $ text "\tcltd" + + CLTD II64 + -> line $ text "\tcqto" + + CLTD x + -> panic $ "pprInstr: CLTD " ++ show x + + SETCC cond op + -> pprCondInstr (text "set") cond (pprOperand platform II8 op) + + XCHG format src val + -> pprFormatOpReg (text "xchg") format src val + + JXX cond blockid + -> pprCondInstr (text "j") cond (pprAsmLabel platform lab) + where lab = blockLbl blockid + + JXX_GBL cond imm + -> pprCondInstr (text "j") cond (pprImm platform imm) + + JMP (OpImm imm) _ + -> line $ text "\tjmp " <> pprImm platform imm + + JMP op _ + -> line $ text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op + + JMP_TBL op _ _ _ + -> pprInstr platform (JMP op []) + + CALL (Left imm) _ + -> line $ text "\tcall " <> pprImm platform imm + + CALL (Right reg) _ + -> line $ text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg + + IDIV fmt op + -> pprFormatOp (text "idiv") fmt op + + DIV fmt op + -> pprFormatOp (text "div") fmt op + + IMUL2 fmt op + -> pprFormatOp (text "imul") fmt op + + -- x86_64 only + MUL format op1 op2 + -> pprFormatOpOp (text "mul") format op1 op2 + + MUL2 format op + -> pprFormatOp (text "mul") format op + + FDIV format op1 op2 + -> pprFormatOpReg (text "div") format op1 op2 + + FMA3 format var perm op1 op2 op3 + -> let mnemo = case var of + FMAdd -> text "vfmadd" + FMSub -> text "vfmsub" + FNMAdd -> text "vfnmadd" + FNMSub -> text "vfnmsub" + in pprFormatOpRegReg (mnemo <> pprFMAPermutation perm) format op1 op2 op3 + + SQRT format op1 op2 + -> pprFormatOpReg (text "sqrt") format op1 op2 + + CVTSS2SD from to + -> pprRegReg (text "cvtss2sd") from to + + CVTSD2SS from to + -> pprRegReg (text "cvtsd2ss") from to + + CVTTSS2SIQ fmt from to + -> pprFormatFormatOpReg (text "cvttss2si") FF32 fmt from to + + CVTTSD2SIQ fmt from to + -> pprFormatFormatOpReg (text "cvttsd2si") FF64 fmt from to + + CVTSI2SS fmt from to + -> pprFormatOpReg (text "cvtsi2ss") fmt from to + + CVTSI2SD fmt from to + -> pprFormatOpReg (text "cvtsi2sd") fmt from to + + -- FETCHGOT for PIC on ELF platforms + FETCHGOT reg + -> lines_ [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg platform II32 reg ], + hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ", + pprReg platform II32 reg ] + ] + + -- FETCHPC for PIC on Darwin/x86 + -- get the instruction pointer into a register + -- (Terminology note: the IP is called Program Counter on PPC, + -- and it's a good thing to use the same name on both platforms) + FETCHPC reg + -> lines_ [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg platform II32 reg ] + ] + + -- the + -- GST fmt src addr ==> FLD dst ; FSTPsz addr + g@(X87Store fmt addr) + -> pprX87 g (hcat [gtab, text "fstp", pprFormat_x87 fmt, gsp, pprAddr platform addr]) + + -- Atomics + LOCK i + -> line (text "\tlock") $$ pprInstr platform i + + MFENCE + -> line $ text "\tmfence" + + XADD format src dst + -> pprFormatOpOp (text "xadd") format src dst + + CMPXCHG format src dst + -> pprFormatOpOp (text "cmpxchg") format src dst + + -- Vector Instructions + VADD format s1 s2 dst + -> pprFormatOpRegReg (text "vadd") format s1 s2 dst + VSUB format s1 s2 dst + -> pprFormatOpRegReg (text "vsub") format s1 s2 dst + VMUL format s1 s2 dst + -> pprFormatOpRegReg (text "vmul") format s1 s2 dst + VDIV format s1 s2 dst + -> pprFormatOpRegReg (text "vdiv") format s1 s2 dst + PADD format src dst + -> pprFormatOpReg (text "padd") format src dst + PSUB format src dst + -> pprFormatOpReg (text "psub") format src dst + PMULL format src dst + -> pprFormatOpReg (text "pmull") format src dst + PMULUDQ format src dst + -> pprOpReg (text "pmuludq") format src dst + PCMPGT format src dst + -> pprFormatOpReg (text "pcmpgt") format src dst + VBROADCAST format@(VecFormat _ sFmt) from to + -> pprBroadcast (text "vbroadcast") (scalarFormatFormat sFmt) format from to + VBROADCAST format _ _ + -> pprPanic "VBROADCAST: expected vector format" (ppr format) + VPBROADCAST scalarFormat format from to + -> pprBroadcast (text "vpbroadcast") scalarFormat format from to + VMOVU format from to + -> pprFormatOpOp (text "vmovu") format from to + MOVU format from to + -> pprFormatOpOp (text "movu") format from to + MOVL format from to + -> pprFormatOpOp (text "movl") format from to + MOVH format from to + -> pprFormatOpOp (text "movh") format from to + + MOVDQU format from to + -> pprOpOp (text "movdqu") format from to + VMOVDQU format from to + -> pprOpOp vmovdqu_op format from to + where + vmovdqu_op = case format of + VecFormat 8 FmtInt64 -> text "vmovdqu64" + VecFormat 16 FmtInt32 -> text "vmovdqu32" + VecFormat 32 FmtInt16 -> text "vmovdqu32" -- NB: not using vmovdqu16/8, as they + VecFormat 64 FmtInt8 -> text "vmovdqu32" -- require the additional AVX512BW extension + _ -> text "vmovdqu" + VMOV_MERGE format src2 src1 dst + -> pprRegRegReg instr format src2 src1 dst + where instr = case format of + VecFormat _ FmtFloat -> text "vmovss" + VecFormat _ FmtDouble -> text "vmovsd" + _ -> pprPanic "invalid format for VMOV_MERGE" (ppr format) + + PXOR format src dst + -> pprPXor (text "pxor") format src dst + VPXOR format s1 s2 dst + -> pprXor (text "vpxor") format s1 s2 dst + PAND format src dst + -> pprOpReg (text "pand") format src dst + PANDN format src dst + -> pprOpReg (text "pandn") format src dst + POR format src dst + -> pprOpReg (text "por") format src dst + VEXTRACT format offset from to + -> pprFormatImmRegOp (text "vextract") format offset from to + INSERTPS format offset addr dst + -> pprInsert (text "insertps") format offset addr dst + VINSERTPS format offset src2 src1 dst + -> pprImmOpRegReg (text "vinsertps") format offset src2 src1 dst + PINSR scalarFormat vectorFormat offset src dst + -> pprPinsr (text "pinsr") scalarFormat vectorFormat offset src dst + PEXTR scalarFormat vectorFormat offset src dst + -> pprPextr (text "pextr") scalarFormat vectorFormat offset src dst + + SHUF format offset src dst + -> pprShuf (text "shuf" <> pprFormat format) format offset src dst + VSHUF format offset src1 src2 dst + -> pprVShuf (text "vshuf" <> pprFormat format) format offset src1 src2 dst + PSHUFB format mask dst + -> pprOpReg (text "pshufb") format mask dst + PSHUFLW format offset src dst + -> pprShuf (text "pshuflw") format offset src dst + PSHUFHW format offset src dst + -> pprShuf (text "pshufhw") format offset src dst + PSHUFD format offset src dst + -> pprShuf (text "pshufd") format offset src dst + VPSHUFD format offset src dst + -> pprShuf (text "vpshufd") format offset src dst + BLEND format mask src dst + -> pprFormatImmOpReg (text "blend") format mask src dst + VBLEND format mask src2 src1 dst + -> pprFormatImmOpRegReg (text "vblend") format mask src2 src1 dst + PBLENDW format mask src dst + -> pprShuf (text "pblendw") format mask src dst + + PSLL format offset dst + -> pprFormatOpReg (text "psll") format offset dst + PSLLDQ format offset dst + -> pprDoubleShift (text "pslldq") format offset dst + PSRL format offset dst + -> pprFormatOpReg (text "psrl") format offset dst + PSRLDQ format offset dst + -> pprDoubleShift (text "psrldq") format offset dst + PALIGNR format offset src dst + -> pprImmOpReg (text "palignr") format offset src dst + + MOVHLPS format from to + -> pprOpReg (text "movhlps") format (OpReg from) to + VMOVHLPS format src2 src1 dst + -> pprRegRegReg (text "vmovhlps") format src2 src1 dst + MOVLHPS format from to + -> pprOpReg (text "movlhps") format (OpReg from) to + VMOVLHPS format src2 src1 dst + -> pprRegRegReg (text "vmovlhps") format src2 src1 dst + UNPCKL format src dst + -> pprFormatOpReg (text "unpckl") format src dst + VUNPCKL format src2 src1 dst + -> pprFormatOpRegReg (text "vunpckl") format src2 src1 dst + UNPCKH format src dst + -> pprFormatOpReg (text "unpckh") format src dst + VUNPCKH format src2 src1 dst + -> pprFormatOpRegReg (text "vunpckh") format src2 src1 dst + PUNPCKLQDQ format from to + -> pprOpReg (text "punpcklqdq") format from to + PUNPCKLDQ format from to + -> pprOpReg (text "punpckldq") format from to + PUNPCKLWD format from to + -> pprOpReg (text "punpcklwd") format from to + PUNPCKLBW format from to + -> pprOpReg (text "punpcklbw") format from to + PUNPCKHQDQ format from to + -> pprOpReg (text "punpckhqdq") format from to + PUNPCKHDQ format from to + -> pprOpReg (text "punpckhdq") format from to + PUNPCKHWD format from to + -> pprOpReg (text "punpckhwd") format from to + PUNPCKHBW format from to + -> pprOpReg (text "punpckhbw") format from to + PACKUSWB format from to + -> pprOpReg (text "packuswb") format from to + + MINMAX minMax ty fmt src dst + -> pprMinMax False minMax ty fmt [src, OpReg dst] + VMINMAX minMax ty fmt src1 src2 dst + -> pprMinMax True minMax ty fmt [src1, OpReg src2, OpReg dst] + + where + gtab :: Line doc + gtab = char '\t' + + gsp :: Line doc + gsp = char ' ' + + + + pprX87 :: Instr -> Line doc -> doc + pprX87 fake actual + = line (char '#' <> pprX87Instr fake) $$ line actual + + pprX87Instr :: Instr -> Line doc + pprX87Instr (X87Store fmt dst) = pprFormatAddr (text "gst") fmt dst + pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" + + pprDollImm :: Imm -> Line doc + pprDollImm i = text "$" <> pprImm platform i + + + pprOperand :: Platform -> Format -> Operand -> Line doc + pprOperand platform f op = case op of + OpReg r -> pprReg platform f r + OpImm i -> pprDollImm i + OpAddr ea -> pprAddr platform ea + + + pprMnemonic_ :: Line doc -> Line doc + pprMnemonic_ name = + char '\t' <> name <> space + + + pprMnemonic :: Line doc -> Format -> Line doc + pprMnemonic name format = + char '\t' <> name <> pprFormat format <> space + + + pprGenMnemonic :: Line doc -> Format -> Line doc + pprGenMnemonic name _ = + char '\t' <> name <> text "" <> space + + pprBroadcastMnemonic :: Line doc -> Format -> Line doc + pprBroadcastMnemonic name format = + char '\t' <> name <> pprBroadcastFormat format <> space + + pprBroadcastFormat :: Format -> Line doc + pprBroadcastFormat (VecFormat _ f) + = case f of + FmtFloat -> text "ss" + FmtDouble -> text "sd" + FmtInt8 -> text "b" + FmtInt16 -> text "w" + FmtInt32 -> text "d" + FmtInt64 -> text "q" + pprBroadcastFormat _ = panic "Scalar Format invading vector operation" + + pprFormatImmOp :: Line doc -> Format -> Imm -> Operand -> doc + pprFormatImmOp name format imm op1 + = line $ hcat [ + pprMnemonic name format, + char '$', + pprImm platform imm, + comma, + pprOperand platform format op1 + ] + + pprFormatOp_ :: Line doc -> Format -> Operand -> doc + pprFormatOp_ name format op1 + = line $ hcat [ + pprMnemonic_ name , + pprOperand platform format op1 + ] + + pprFormatOp :: Line doc -> Format -> Operand -> doc + pprFormatOp name format op1 + = line $ hcat [ + pprMnemonic name format, + pprOperand platform format op1 + ] + + + pprFormatOpOp :: Line doc -> Format -> Operand -> Operand -> doc + pprFormatOpOp name format op1 op2 + = line $ hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprOperand platform format op2 + ] + + pprMovdOpOp :: Line doc -> Format -> Format -> Operand -> Operand -> doc + pprMovdOpOp name format1 format2 op1 op2 + = let instr = case (format1, format2) of + -- bitcasts to/from a general purpose register to a floating point + -- register require II32 or II64. + (II32, _) -> text "d" + (II64, _) -> text "q" + (_, II32) -> text "d" + (_, II64) -> text "q" + _ -> panic "X86.Ppr.pprMovdOpOp: improper format for movd/movq." + in line $ hcat [ + char '\t' <> name <> instr <> space, + pprOperand platform format1 op1, + comma, + pprOperand platform format2 op2 + ] + + pprFormatImmRegOp :: Line doc -> Format -> Imm -> Reg -> Operand -> doc + pprFormatImmRegOp name format off reg1 op2 + = line $ hcat [ + pprMnemonic name format, + pprDollImm off, + comma, + pprReg platform format reg1, + comma, + pprOperand platform format op2 + ] + + pprFormatOpRegReg :: Line doc -> Format -> Operand -> Reg -> Reg -> doc + pprFormatOpRegReg name format op1 reg2 reg3 + = line $ hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprReg platform format reg2, + comma, + pprReg platform format reg3 + ] + + pprFMAPermutation :: FMAPermutation -> Line doc + pprFMAPermutation FMA132 = text "132" + pprFMAPermutation FMA213 = text "213" + pprFMAPermutation FMA231 = text "231" + + pprOpOp :: Line doc -> Format -> Operand -> Operand -> doc + pprOpOp name format op1 op2 + = line $ hcat [ + pprMnemonic_ name, + pprOperand platform format op1, + comma, + pprOperand platform format op2 + ] + + pprRegReg :: Line doc -> Reg -> Reg -> doc + pprRegReg name reg1 reg2 + = line $ hcat [ + pprMnemonic_ name, + pprReg platform (archWordFormat (target32Bit platform)) reg1, + comma, + pprReg platform (archWordFormat (target32Bit platform)) reg2 + ] + + pprRegRegReg :: Line doc -> Format -> Reg -> Reg -> Reg -> doc + pprRegRegReg name format reg1 reg2 reg3 + = line $ hcat [ + pprMnemonic_ name, + pprReg platform format reg1, + comma, + pprReg platform format reg2, + comma, + pprReg platform format reg3 + ] + + pprOpReg :: Line doc -> Format -> Operand -> Reg -> doc + pprOpReg name format op reg + = line $ hcat [ + pprMnemonic_ name, + pprOperand platform format op, + comma, + pprReg platform (archWordFormat (target32Bit platform)) reg + ] + + + pprFormatOpReg :: Line doc -> Format -> Operand -> Reg -> doc + pprFormatOpReg name format op1 reg2 + = line $ hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprReg platform (archWordFormat (target32Bit platform)) reg2 + ] + + pprCondOpReg :: Line doc -> Format -> Cond -> Operand -> Reg -> doc + pprCondOpReg name format cond op1 reg2 + = line $ hcat [ + char '\t', + name, + pprCond cond, + space, + pprOperand platform format op1, + comma, + pprReg platform format reg2 + ] + + pprFormatFormatOpReg :: Line doc -> Format -> Format -> Operand -> Reg -> doc + pprFormatFormatOpReg name format1 format2 op1 reg2 + = line $ hcat [ + pprMnemonic name format2, + pprOperand platform format1 op1, + comma, + pprReg platform format2 reg2 + ] + + pprFormatOpOpReg :: Line doc -> Format -> Operand -> Operand -> Reg -> doc + pprFormatOpOpReg name format op1 op2 reg3 + = line $ hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3 + ] + + + + pprFormatAddr :: Line doc -> Format -> AddrMode -> Line doc + pprFormatAddr name format op + = hcat [ + pprMnemonic name format, + comma, + pprAddr platform op + ] + + pprShift :: Line doc -> Format -> Operand -> Operand -> doc + pprShift name format src dest + = line $ hcat [ + pprMnemonic name format, + pprOperand platform II8 src, -- src is 8-bit sized + comma, + pprOperand platform format dest + ] + + pprShift2 :: Line doc -> Format -> Operand -> Operand -> Operand -> doc + pprShift2 name format src dest1 dest2 + = line $ hcat [ + pprMnemonic name format, + pprOperand platform II8 src, -- src is 8-bit sized + comma, + pprOperand platform format dest1, + comma, + pprOperand platform format dest2 + ] + + + pprFormatOpOpCoerce :: Line doc -> Format -> Format -> Operand -> Operand -> doc + pprFormatOpOpCoerce name format1 format2 op1 op2 + = line $ hcat [ char '\t', name, pprFormat format1, pprFormat format2, space, + pprOperand platform format1 op1, + comma, + pprOperand platform format2 op2 + ] + + + pprCondInstr :: Line doc -> Cond -> Line doc -> doc + pprCondInstr name cond arg + = line $ hcat [ char '\t', name, pprCond cond, space, arg] + + -- Custom pretty printers + -- These instructions currently don't follow a uniform suffix pattern + -- in their names, so we have custom pretty printers for them. + pprBroadcast :: Line doc -> Format -> Format -> Operand -> Reg -> doc + pprBroadcast name scalarFormat vectorFormat op dst + = line $ hcat [ + pprBroadcastMnemonic name vectorFormat, + pprOperand platform scalarFormat op, + comma, + pprReg platform vectorFormat dst + ] + + pprXor :: Line doc -> Format -> Reg -> Reg -> Reg -> doc + pprXor name format reg1 reg2 reg3 + = line $ hcat [ + pprGenMnemonic name format, + pprReg platform format reg1, + comma, + pprReg platform format reg2, + comma, + pprReg platform format reg3 + ] + + pprPXor :: Line doc -> Format -> Operand -> Reg -> doc + pprPXor name format src dst + = line $ hcat [ + pprGenMnemonic name format, + pprOperand platform format src, + comma, + pprReg platform format dst + ] + + pprVxor :: Format -> Operand -> Reg -> Reg -> doc + pprVxor fmt src1 src2 dst + = line $ hcat [ + pprGenMnemonic mem fmt, + pprOperand platform fmt src1, + comma, + pprReg platform fmt src2, + comma, + pprReg platform fmt dst + ] + where + mem = case fmt of + FF32 -> text "vxorps" + FF64 -> text "vxorpd" + VecFormat _ FmtFloat -> text "vxorps" + VecFormat _ FmtDouble -> text "vxorpd" + _ -> pprPanic "GHC.CmmToAsm.X86.Ppr.pprVxor: element type must be Float or Double" + (ppr fmt) + + pprInsert :: Line doc -> Format -> Imm -> Operand -> Reg -> doc + pprInsert name format off src dst + = line $ hcat [ + pprGenMnemonic name format, + pprDollImm off, + comma, + pprOperand platform format src, + comma, + pprReg platform format dst + ] + + pprPinsr :: Line doc -> Format -> Format -> Imm -> Operand -> Reg -> doc + pprPinsr name scalarFormat vectorFormat imm src dst + = line $ hcat [ + pprMnemonic name vectorFormat, + pprDollImm imm, + comma, + pprOperand platform scalarFormat src, + comma, + pprReg platform vectorFormat dst + ] + + pprPextr :: Line doc -> Format -> Format -> Imm -> Reg -> Operand -> doc + pprPextr name scalarFormat vectorFormat imm src dst + = line $ hcat [ + pprMnemonic name vectorFormat, + pprDollImm imm, + comma, + pprReg platform vectorFormat src, + comma, + pprOperand platform scalarFormat dst + ] + + pprShuf :: Line doc -> Format -> Imm -> Operand -> Reg -> doc + pprShuf name format imm1 op2 reg3 + = line $ hcat [ + pprGenMnemonic name format, + pprDollImm imm1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3 + ] + + pprVShuf :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc + pprVShuf name format imm1 op2 reg3 reg4 + = line $ hcat [ + pprGenMnemonic name format, + pprDollImm imm1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3, + comma, + pprReg platform format reg4 + ] + + pprDoubleShift :: Line doc -> Format -> Imm -> Reg -> doc + pprDoubleShift name format off reg + = line $ hcat [ + pprGenMnemonic name format, + pprDollImm off, + comma, + pprReg platform format reg + ] + + pprImmOpReg :: Line doc -> Format -> Imm -> Operand -> Reg -> doc + pprImmOpReg name format imm1 op2 reg3 + = line $ hcat [ + pprGenMnemonic name format, + pprDollImm imm1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3 + ] + + pprFormatImmOpReg :: Line doc -> Format -> Imm -> Operand -> Reg -> doc + pprFormatImmOpReg name format imm1 op2 reg3 + = line $ hcat [ + pprMnemonic name format, + pprDollImm imm1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3 + ] + + pprImmOpRegReg :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc + pprImmOpRegReg name format imm1 op2 reg3 reg4 + = line $ hcat [ + pprGenMnemonic name format, + pprDollImm imm1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3, + comma, + pprReg platform format reg4 + ] + + pprFormatImmOpRegReg :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc + pprFormatImmOpRegReg name format imm1 op2 reg3 reg4 + = line $ hcat [ + pprMnemonic name format, + pprDollImm imm1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3, + comma, + pprReg platform format reg4 + ] + + pprMinMax :: Bool -> MinOrMax -> MinMaxType -> Format -> [Operand] -> doc + pprMinMax wantV minOrMax mmTy fmt regs + = line $ hcat ( instr : intersperse comma ( map ( pprOperand platform fmt ) regs ) ) + where + instr = (if wantV then text "v" else empty) + <> (case mmTy of { IntVecMinMax {} -> text "p"; FloatMinMax -> empty }) + <> (case minOrMax of { Min -> text "min"; Max -> text "max" }) + <> (case mmTy of { IntVecMinMax wantSigned -> if wantSigned then text "s" else text "u"; FloatMinMax -> empty }) + <> pprFormat fmt + <> space diff --git a/GHC/CmmToAsm/X86/RegInfo.hs b/GHC/CmmToAsm/X86/RegInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/RegInfo.hs @@ -0,0 +1,70 @@ + +module GHC.CmmToAsm.X86.RegInfo ( + mkVirtualReg, + regDotColor +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.Format +import GHC.Platform.Reg + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform +import GHC.Types.Unique + +import GHC.Types.Unique.FM +import GHC.CmmToAsm.X86.Regs + + +mkVirtualReg :: Unique -> Format -> VirtualReg +mkVirtualReg u format + = case format of + FF32 -> VirtualRegD u + -- On X86, we pass 32-bit floats in the same registers as 64-bit floats. + FF64 -> VirtualRegD u + -- SIMD NCG TODO: add support for 256 and 512-wide vectors. + VecFormat {} -> VirtualRegV128 u + _other -> VirtualRegI u + +regDotColor :: Platform -> RealReg -> SDoc +regDotColor platform reg + = case (lookupUFM (regColors platform) reg) of + Just str -> text str + _ -> panic "Register not assigned a color" + +regColors :: Platform -> UniqFM RealReg [Char] +regColors platform = listToUFM (normalRegColors platform) + +normalRegColors :: Platform -> [(RealReg,String)] +normalRegColors platform = + zip (map realRegSingle [0..lastint platform]) colors + ++ zip (map realRegSingle [firstxmm..lastxmm platform]) greys + where + -- 16 colors - enough for amd64 gp regs + colors = ["#800000","#ff0000","#808000","#ffff00","#008000" + ,"#00ff00","#008080","#00ffff","#000080","#0000ff" + ,"#800080","#ff00ff","#87005f","#875f00","#87af00" + ,"#ff00af"] + + -- 16 shades of grey, enough for the currently supported + -- SSE extensions. + greys = ["#0e0e0e","#1c1c1c","#2a2a2a","#383838","#464646" + ,"#545454","#626262","#707070","#7e7e7e","#8c8c8c" + ,"#9a9a9a","#a8a8a8","#b6b6b6","#c4c4c4","#d2d2d2" + ,"#e0e0e0"] + + + +-- 32 shades of grey - use for avx 512 if we ever need it +-- greys = ["#070707","#0e0e0e","#151515","#1c1c1c" +-- ,"#232323","#2a2a2a","#313131","#383838","#3f3f3f" +-- ,"#464646","#4d4d4d","#545454","#5b5b5b","#626262" +-- ,"#696969","#707070","#777777","#7e7e7e","#858585" +-- ,"#8c8c8c","#939393","#9a9a9a","#a1a1a1","#a8a8a8" +-- ,"#afafaf","#b6b6b6","#bdbdbd","#c4c4c4","#cbcbcb" +-- ,"#d2d2d2","#d9d9d9","#e0e0e0"] + diff --git a/GHC/CmmToAsm/X86/Regs.hs b/GHC/CmmToAsm/X86/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/Regs.hs @@ -0,0 +1,409 @@ + + +module GHC.CmmToAsm.X86.Regs ( + -- squeese functions for the graph allocator + virtualRegSqueeze, + realRegSqueeze, + + -- immediates + Imm(..), + strImmLit, + litToImm, + + -- addressing modes + AddrMode(..), + addrOffset, + + -- registers + spRel, + argRegs, + allArgRegs, + allIntArgRegs, + callClobberedRegs, + instrClobberedRegs, + allMachRegNos, + classOfRealReg, + + -- machine specific + EABase(..), EAIndex(..), addrModeRegs, + + eax, ebx, ecx, edx, esi, edi, ebp, esp, + + + rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp, + r8, r9, r10, r11, r12, r13, r14, r15, + lastint, + xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7, + xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15, + xmm, + firstxmm, lastxmm, + intregnos, xmmregnos, + + ripRel, + allFPArgRegs, + + allocatableRegs +) + +where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Platform.Regs +import GHC.Platform.Reg +import GHC.Platform.Reg.Class.Unified + +import GHC.Cmm +import GHC.Cmm.CLabel ( CLabel ) +import GHC.Utils.Panic +import GHC.Platform + +-- | regSqueeze_class reg +-- Calculate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> Int + +virtualRegSqueeze cls vr + = case cls of + RcInteger + -> case vr of + VirtualRegI{} -> 1 + VirtualRegHi{} -> 1 + _other -> 0 + + RcFloatOrVector + -> case vr of + VirtualRegD{} -> 1 + VirtualRegV128{} -> 1 + _other -> 0 + + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> Int +realRegSqueeze cls rr + = case cls of + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < firstxmm -> 1 + | otherwise -> 0 + + RcFloatOrVector + -> case rr of + RealRegSingle regNo + | regNo >= firstxmm -> 1 + | otherwise -> 0 + +-- ----------------------------------------------------------------------------- +-- Immediates + +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit FastString + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + +strImmLit :: FastString -> Imm +strImmLit s = ImmLit s + + +litToImm :: CmmLit -> Imm +litToImm (CmmInt i w) = ImmInteger (narrowS w i) + -- narrow to the width: a CmmInt might be out of + -- range, but we assume that ImmInteger only contains + -- in-range values. A signed value should be fine here. +litToImm (CmmFloat f W32) = ImmFloat f +litToImm (CmmFloat f W64) = ImmDouble f +litToImm (CmmLabel l) = ImmCLbl l +litToImm (CmmLabelOff l off) = ImmIndex l off +litToImm (CmmLabelDiffOff l1 l2 off _) + = ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) +litToImm _ = panic "X86.Regs.litToImm: no match" + +-- addressing modes ------------------------------------------------------------ + +data AddrMode + = AddrBaseIndex EABase EAIndex Displacement + | ImmAddr Imm Int + +data EABase = EABaseNone | EABaseReg Reg | EABaseRip +data EAIndex = EAIndexNone | EAIndex Reg Int +type Displacement = Imm + + +addrOffset :: AddrMode -> Int -> Maybe AddrMode +addrOffset addr off + = case addr of + ImmAddr i off0 -> Just (ImmAddr i (off0 + off)) + + AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off))) + AddrBaseIndex r i (ImmInteger n) + -> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off)))) + + AddrBaseIndex r i (ImmCLbl lbl) + -> Just (AddrBaseIndex r i (ImmIndex lbl off)) + + AddrBaseIndex r i (ImmIndex lbl ix) + -> Just (AddrBaseIndex r i (ImmIndex lbl (ix+off))) + + _ -> Nothing -- in theory, shouldn't happen + + +addrModeRegs :: AddrMode -> [Reg] +addrModeRegs (AddrBaseIndex b i _) = b_regs ++ i_regs + where + b_regs = case b of { EABaseReg r -> [r]; _ -> [] } + i_regs = case i of { EAIndex r _ -> [r]; _ -> [] } +addrModeRegs _ = [] + + +-- registers ------------------------------------------------------------------- + +-- @spRel@ gives us a stack relative addressing mode for volatile +-- temporaries and for excess call arguments. @fpRel@, where +-- applicable, is the same but for the frame pointer. + + +spRel :: Platform + -> Int -- ^ desired stack offset in bytes, positive or negative + -> AddrMode +spRel platform n + | target32Bit platform + = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n) + | otherwise + = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n) + +-- The register numbers must fit into 32 bits on x86, so that we can +-- use a Word32 to represent the set of free registers in the register +-- allocator. + + + +firstxmm :: RegNo +firstxmm = 16 + +-- on 32bit platformOSs, only the first 8 XMM/YMM/ZMM registers are available +lastxmm :: Platform -> RegNo +lastxmm platform + | target32Bit platform = firstxmm + 7 -- xmm0 - xmmm7 + | otherwise = firstxmm + 15 -- xmm0 -xmm15 + +lastint :: Platform -> RegNo +lastint platform + | target32Bit platform = 7 -- not %r8..%r15 + | otherwise = 15 + +intregnos :: Platform -> [RegNo] +intregnos platform = [0 .. lastint platform] + + + +xmmregnos :: Platform -> [RegNo] +xmmregnos platform = [firstxmm .. lastxmm platform] + +floatregnos :: Platform -> [RegNo] +floatregnos platform = xmmregnos platform + +-- argRegs is the set of regs which are read for an n-argument call to C. +-- For archs which pass all args on the stack (x86), is empty. +-- Sparc passes up to the first 6 args in regs. +argRegs :: RegNo -> [Reg] +argRegs _ = panic "MachRegs.argRegs(x86): should not be used!" + +-- | The complete set of machine registers. +allMachRegNos :: Platform -> [RegNo] +allMachRegNos platform = intregnos platform ++ floatregnos platform + +-- | Take the class of a register. +{-# INLINE classOfRealReg #-} +classOfRealReg :: Platform -> RealReg -> RegClass +-- On x86, we might want to have an 8-bit RegClass, which would +-- contain just regs 1-4 (the others don't have 8-bit versions). +-- However, we can get away without this at the moment because the +-- only allocatable integer regs are also 8-bit compatible (1, 3, 4). +classOfRealReg platform reg + = case reg of + RealRegSingle i + | i <= lastint platform -> RcInteger + | i <= lastxmm platform -> RcFloatOrVector + | otherwise -> panic "X86.Reg.classOfRealReg registerSingle too high" + +-- machine specific ------------------------------------------------------------ + + +{- +Intel x86 architecture: +- All registers except 7 (esp) are available for use. +- Only ebx, esi, edi and esp are available across a C call (they are callee-saves). +- Registers 0-7 have 16-bit counterparts (ax, bx etc.) +- Registers 0-3 have 8 bit counterparts (ah, bh etc.) + +The fp registers support Float, Doubles and vectors of those, as well +as vectors of integer values. +-} + + +eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg + +eax = regSingle 0 +ebx = regSingle 1 +ecx = regSingle 2 +edx = regSingle 3 +esi = regSingle 4 +edi = regSingle 5 +ebp = regSingle 6 +esp = regSingle 7 + + + + +{- +AMD x86_64 architecture: +- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values: + + 8 16 32 64 + --------------------- + al ax eax rax + bl bx ebx rbx + cl cx ecx rcx + dl dx edx rdx + sil si esi rsi + dil si edi rdi + bpl bp ebp rbp + spl sp esp rsp + r10b r10w r10d r10 + r11b r11w r11d r11 + r12b r12w r12d r12 + r13b r13w r13d r13 + r14b r14w r14d r14 + r15b r15w r15d r15 +-} + +rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi, + r8, r9, r10, r11, r12, r13, r14, r15, + xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7, + xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15 :: Reg + +rax = regSingle 0 +rbx = regSingle 1 +rcx = regSingle 2 +rdx = regSingle 3 +rsi = regSingle 4 +rdi = regSingle 5 +rbp = regSingle 6 +rsp = regSingle 7 +r8 = regSingle 8 +r9 = regSingle 9 +r10 = regSingle 10 +r11 = regSingle 11 +r12 = regSingle 12 +r13 = regSingle 13 +r14 = regSingle 14 +r15 = regSingle 15 +xmm0 = regSingle 16 +xmm1 = regSingle 17 +xmm2 = regSingle 18 +xmm3 = regSingle 19 +xmm4 = regSingle 20 +xmm5 = regSingle 21 +xmm6 = regSingle 22 +xmm7 = regSingle 23 +xmm8 = regSingle 24 +xmm9 = regSingle 25 +xmm10 = regSingle 26 +xmm11 = regSingle 27 +xmm12 = regSingle 28 +xmm13 = regSingle 29 +xmm14 = regSingle 30 +xmm15 = regSingle 31 + +ripRel :: Displacement -> AddrMode +ripRel imm = AddrBaseIndex EABaseRip EAIndexNone imm + + + -- so we can re-use some x86 code: +{- +eax = rax +ebx = rbx +ecx = rcx +edx = rdx +esi = rsi +edi = rdi +ebp = rbp +esp = rsp +-} + +xmm :: RegNo -> Reg +xmm n = regSingle (firstxmm+n) + + + + +-- | these are the regs which we cannot assume stay alive over a C call. +callClobberedRegs :: Platform -> [Reg] +-- caller-saves registers +callClobberedRegs platform + | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform) + | platformOS platform == OSMinGW32 + = [rax,rcx,rdx,r8,r9,r10,r11] + -- Only xmm0-5 are caller-saves registers on 64-bit windows. + -- For details check the Win64 ABI: + -- https://docs.microsoft.com/en-us/cpp/build/x64-software-conventions + ++ map xmm [0 .. 5] + | otherwise + -- all xmm regs are caller-saves + -- caller-saves registers + = [rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11] + ++ map regSingle (floatregnos platform) + +allArgRegs :: Platform -> [(Reg, Reg)] +allArgRegs platform + | platformOS platform == OSMinGW32 = zip [rcx,rdx,r8,r9] + (map regSingle [firstxmm ..]) + | otherwise = panic "X86.Regs.allArgRegs: not defined for this arch" + +allIntArgRegs :: Platform -> [Reg] +allIntArgRegs platform + | (platformOS platform == OSMinGW32) || target32Bit platform + = panic "X86.Regs.allIntArgRegs: not defined for this platform" + | otherwise = [rdi,rsi,rdx,rcx,r8,r9] + + +-- | on 64bit platforms we pass the first 8 float/double arguments +-- in the xmm registers. +allFPArgRegs :: Platform -> [Reg] +allFPArgRegs platform + | platformOS platform == OSMinGW32 + = panic "X86.Regs.allFPArgRegs: not defined for this platform" + | otherwise = map regSingle [firstxmm .. firstxmm + 7 ] + + +-- Machine registers which might be clobbered by instructions that +-- generate results into fixed registers, or need arguments in a fixed +-- register. +instrClobberedRegs :: Platform -> [Reg] +instrClobberedRegs platform + | target32Bit platform = [ eax, ecx, edx ] + | otherwise = [ rax, rcx, rdx ] + +-- + +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform + = let isFree i = freeReg platform i + in map RealRegSingle $ filter isFree (allMachRegNos platform) + diff --git a/GHC/CmmToC.hs b/GHC/CmmToC.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToC.hs @@ -0,0 +1,1593 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- +-- Pretty-printing of Cmm as C, suitable for feeding gcc +-- +-- (c) The University of Glasgow 2004-2006 +-- +-- Print Cmm as real C, for -fvia-C +-- +-- See wiki:commentary/compiler/backends/ppr-c +-- +-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded" +-- relative to the old AbstractC, and many oddities/decorations have +-- disappeared from the data type. +-- +-- This code generator is only supported in unregisterised mode. +-- +----------------------------------------------------------------------------- + +module GHC.CmmToC + ( cmmToC + ) +where + +import GHC.Prelude + +import GHC.Platform + +import GHC.CmmToAsm.CPrim + +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm hiding (pprBBlock, pprStatic) +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm.InitFini + +import GHC.Types.ForeignCall +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Monad.State.Strict (State (..), runState, state) +import GHC.Utils.Misc + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char +import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) +import qualified Data.Map as Map +import GHC.Float + +-- -------------------------------------------------------------------------- +-- Now do some real work +-- +-- for fun, we could call cmmToCmm over the tops... +-- + +cmmToC :: Platform -> RawCmmGroup -> SDoc +cmmToC platform tops = (vcat $ intersperse blankLine $ map (pprTop platform) tops) $$ blankLine + +-- +-- top level procs +-- +pprTop :: Platform -> RawCmmDecl -> SDoc +pprTop platform = \case + (CmmProc infos clbl _in_live_regs graph) -> + (case mapLookup (g_entry graph) infos of + Nothing -> empty + Just (CmmStaticsRaw info_clbl info_dat) -> + pprDataExterns platform info_dat $$ + pprWordArray platform info_is_in_rodata info_clbl info_dat) $$ + (vcat [ + blankLine, + extern_decls, + (if (externallyVisibleCLabel clbl) + then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace, + nest 8 temp_decls, + vcat (map (pprBBlock platform) blocks), + rbrace ] + ) + where + -- info tables are always in .rodata + info_is_in_rodata = True + blocks = toBlockListEntryFirst graph + (temp_decls, extern_decls) = pprTempAndExternDecls platform blocks + + + -- Chunks of static data. + + -- We only handle (a) arrays of word-sized things and (b) strings. + + cmm_data | Just (initOrFini, clbls) <- isInitOrFiniArray cmm_data -> + pprCtorArray platform initOrFini clbls + + (CmmData section (CmmStaticsRaw lbl [CmmString str])) -> + pprExternDecl platform lbl $$ + hcat [ + pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl, + text "[] = ", pprStringInCStyle str, semi + ] + + (CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) -> + pprExternDecl platform lbl $$ + hcat [ + pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl, + brackets (int size), semi + ] + + (CmmData section (CmmStaticsRaw lbl lits)) -> + pprDataExterns platform lits $$ + pprWordArray platform (isSecConstant section) lbl lits + where + isSecConstant section = case sectionProtection section of + ReadOnlySection -> True + WriteProtectedSection -> True + _ -> False + +-- -------------------------------------------------------------------------- +-- BasicBlocks are self-contained entities: they always end in a jump. +-- +-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn +-- as many jumps as possible into fallthroughs. +-- + +pprBBlock :: Platform -> CmmBlock -> SDoc +pprBBlock platform block = + nest 4 (pprBlockId (entryLabel block) <> colon) $$ + nest 8 (vcat (map (pprStmt platform) (blockToList nodes)) $$ pprStmt platform last) + where + (_, nodes, last) = blockSplit block + +-- -------------------------------------------------------------------------- +-- Info tables. Just arrays of words. +-- See codeGen/ClosureInfo, and nativeGen/PprMach + +pprWordArray :: Platform -> Bool -> CLabel -> [CmmStatic] -> SDoc +pprWordArray platform is_ro lbl ds + = -- TODO: align closures only + pprExternDecl platform lbl $$ + hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord" + , space, pprCLabel platform lbl, text "[]" + -- See Note [StgWord alignment] + , pprAlignment (wordWidth platform) + , text "= {" ] + $$ nest 8 (commafy (staticLitsToWords platform $ toLits ds)) + $$ text "};" + where + toLits :: [CmmStatic] -> [CmmLit] + toLits = map f + where + f (CmmStaticLit lit) = lit + f static = pprPanic "pprWordArray: Unexpected literal" (pprStatic platform static) + +pprAlignment :: Width -> SDoc +pprAlignment words = + text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))" + +-- Note [StgWord alignment] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- C codegen builds static closures as StgWord C arrays (pprWordArray). +-- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume +-- pointers to 'StgClosure' are aligned at pointer size boundary: +-- 4 byte boundary on 32 systems +-- and 8 bytes on 64-bit systems +-- see TAG_MASK and TAG_BITS definition and usage. +-- +-- It's a reasonable assumption also known as natural alignment. +-- Although some architectures have different alignment rules. +-- One of known exceptions is m68k (#11395, comment:16) where: +-- __alignof__(StgWord) == 2, sizeof(StgWord) == 4 +-- +-- Thus we explicitly increase alignment by using +-- __attribute__((aligned(4))) +-- declaration. + +-- +-- has to be static, if it isn't globally visible +-- +pprLocalness :: CLabel -> SDoc +pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static " + | otherwise = empty + +pprConstness :: Bool -> SDoc +pprConstness is_ro | is_ro = text "const " + | otherwise = empty + +-- -------------------------------------------------------------------------- +-- Statements. +-- + +pprStmt :: Platform -> CmmNode e x -> SDoc +pprStmt platform stmt = + case stmt of + CmmEntry{} -> empty + CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ text "*/" + -- XXX if the string contains "*/", we need to fix it + -- XXX we probably want to emit these comments when + -- some debugging option is on. They can get quite + -- large. + + CmmTick _ -> empty + CmmUnwind{} -> empty + + CmmAssign dest src -> pprAssign platform dest src + + CmmStore dest src align + | typeWidth rep == W64 && wordWidth platform /= W64 + -> (if isFloatType rep then text "ASSIGN_DBL" + else text "ASSIGN_Word64") <> + parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi + + | otherwise + -> hsep [ pprExpr platform (CmmLoad dest rep align), equals, pprExpr platform src <> semi ] + where + rep = cmmExprType platform src + + CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args -> + fnCall + where + (res_hints, arg_hints) = foreignTargetHints target + hresults = zip results res_hints + hargs = zip args arg_hints + + ForeignConvention cconv _ _ ret = conv + + cast_fn = parens (cCast platform (pprCFunType platform (char '*') cconv hresults hargs) fn) + + -- See wiki:commentary/compiler/backends/ppr-c#prototypes + fnCall = + case fn of + CmmLit (CmmLabel lbl) + | CmmNeverReturns <- ret -> + pprCall platform cast_fn cconv hresults hargs <> semi <> text "__builtin_unreachable();" + | not (isLibcFun lbl) -> + pprForeignCall platform (pprCLabel platform lbl) cconv hresults hargs + _ -> + pprCall platform cast_fn cconv hresults hargs <> semi + -- for a dynamic call, no declaration is necessary. + + CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty + CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty + + CmmUnsafeForeignCall (PrimTarget MO_ReleaseFence) [] [] -> + text "__atomic_thread_fence(__ATOMIC_RELEASE);" + CmmUnsafeForeignCall (PrimTarget MO_AcquireFence) [] [] -> + text "__atomic_thread_fence(__ATOMIC_ACQUIRE);" + CmmUnsafeForeignCall (PrimTarget MO_SeqCstFence) [] [] -> + text "__atomic_thread_fence(__ATOMIC_SEQ_CST);" + + CmmUnsafeForeignCall target@(PrimTarget op) results args -> + fn_call + where + cconv = CCallConv + fn = pprCallishMachOp_for_C op + + (res_hints, arg_hints) = foreignTargetHints target + hresults = zip results res_hints + hargs = zip args arg_hints + + need_cdecl + | MO_ResumeThread <- op = True + | MO_SuspendThread <- op = True + | otherwise = False + + fn_call + -- The mem primops carry an extra alignment arg. + -- We could maybe emit an alignment directive using this info. + -- We also need to cast mem primops to prevent conflicts with GCC + -- builtins (see bug #5967). + | need_cdecl + = (text ";EFF_(" <> fn <> char ')' <> semi) $$ + pprForeignCall platform fn cconv hresults hargs + | otherwise + = pprCall platform fn cconv hresults hargs + + CmmBranch ident -> pprBranch ident + CmmCondBranch expr yes no _ -> pprCondBranch platform expr yes no + CmmCall { cml_target = expr } -> mkJMP_ (pprExpr platform expr) <> semi + CmmSwitch arg ids -> pprSwitch platform arg ids + + _other -> pprPanic "PprC.pprStmt" (pdoc platform stmt) + +type Hinted a = (a, ForeignHint) + +pprForeignCall :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] + -> SDoc +pprForeignCall platform fn cconv results args = fn_call + where + fn_call = braces ( + pprCFunType platform (char '*' <> text "ghcFunPtr") cconv results args <> semi + $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi + $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi + ) + cast_fn = parens (parens (pprCFunType platform (char '*') cconv results args) <> fn) + +pprCFunType :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc +pprCFunType platform ppr_fn cconv ress args + = let res_type [] = text "void" + res_type [(one, hint)] = machRepHintCType platform (localRegType one) hint + res_type _ = panic "pprCFunType: only void or 1 return value supported" + + arg_type (expr, hint) = machRepHintCType platform (cmmExprType platform expr) hint + in res_type ress <+> + parens (ccallConvAttribute cconv <> ppr_fn) <> + parens (commafy (map arg_type args)) + +-- --------------------------------------------------------------------- +-- unconditional branches +pprBranch :: BlockId -> SDoc +pprBranch ident = text "goto" <+> pprBlockId ident <> semi + + +-- --------------------------------------------------------------------- +-- conditional branches to local labels +pprCondBranch :: Platform -> CmmExpr -> BlockId -> BlockId -> SDoc +pprCondBranch platform expr yes no + = hsep [ text "if" , parens (pprExpr platform expr) , + text "goto", pprBlockId yes <> semi, + text "else goto", pprBlockId no <> semi ] + +-- --------------------------------------------------------------------- +-- a local table branch +-- +-- we find the fall-through cases +-- +pprSwitch :: Platform -> CmmExpr -> SwitchTargets -> SDoc +pprSwitch platform e ids + = (hang (text "switch" <+> parens ( pprExpr platform e ) <+> lbrace) + 4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace + where + (pairs, mbdef) = switchTargetsFallThrough ids + + rep = typeWidth (cmmExprType platform e) + + -- fall through case + caseify (ix:|ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix + where + do_fallthrough ix = + hsep [ text "case" , pprHexVal platform ix rep <> colon , + text "/* fall through */" ] + + final_branch ix = + hsep [ text "case" , pprHexVal platform ix rep <> colon , + text "goto" , (pprBlockId ident) <> semi ] + + def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi + | otherwise = text "default: __builtin_unreachable();" + +-- --------------------------------------------------------------------- +-- Expressions. +-- + +-- C Types: the invariant is that the C expression generated by +-- +-- pprExpr e +-- +-- has a type in C which is also given by +-- +-- machRepCType (cmmExprType e) +-- +-- (similar invariants apply to the rest of the pretty printer). + +pprExpr :: Platform -> CmmExpr -> SDoc +pprExpr platform e = case e of + CmmLit lit -> pprLit platform lit + CmmLoad e ty align -> pprLoad platform e ty align + CmmReg reg -> pprCastReg reg + CmmRegOff reg 0 -> pprCastReg reg + + -- CmmRegOff is an alias of MO_Add + CmmRegOff reg i -> pprExpr platform $ CmmMachOp (MO_Add w) [CmmReg reg, CmmLit $ CmmInt (toInteger i) w] + where w = cmmRegWidth reg + + CmmMachOp mop args -> pprMachOpApp platform mop args + + CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" + + +pprLoad :: Platform -> CmmExpr -> CmmType -> AlignmentSpec -> SDoc +pprLoad platform e ty _align + | width == W64, wordWidth platform /= W64 + = (if isFloatType ty then text "PK_DBL" + else text "PK_Word64") + <> parens (mkP_ <> pprExpr1 platform e) + + -- TODO: exploit natural-alignment where possible + | otherwise + = case e of + CmmReg r | isPtrReg r && width == wordWidth platform && not (isFloatType ty) + -> char '*' <> pprAsPtrReg r + + CmmRegOff r 0 | isPtrReg r && width == wordWidth platform && not (isFloatType ty) + -> char '*' <> pprAsPtrReg r + + CmmRegOff r off | isPtrReg r && width == wordWidth platform + , off `rem` platformWordSizeInBytes platform == 0 && not (isFloatType ty) + -- ToDo: check that the offset is a word multiple? + -- (For tagging to work, I had to avoid unaligned loads. --ARY) + -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift platform)) + + _other -> cLoad platform e ty + where + width = typeWidth ty + +pprExpr1 :: Platform -> CmmExpr -> SDoc +pprExpr1 platform e = case e of + CmmLit lit -> pprLit1 platform lit + CmmReg _reg -> pprExpr platform e + _ -> parens (pprExpr platform e) + +-- -------------------------------------------------------------------------- +-- MachOp applications + +pprMachOpApp :: Platform -> MachOp -> [CmmExpr] -> SDoc + +pprMachOpApp platform op args + | isMulMayOfloOp op + = text "mulIntMayOflo" <> parens (commafy (map (pprExpr platform) args)) + where isMulMayOfloOp (MO_S_MulMayOflo _) = True + isMulMayOfloOp _ = False + +pprMachOpApp platform (MO_RelaxedRead w) [x] + = pprExpr platform (CmmLoad x (cmmBits w) NaturallyAligned) + +pprMachOpApp platform mop args + | Just ty <- machOpNeedsCast platform mop (map (cmmExprType platform) args) + = ty <> parens (pprMachOpApp' platform mop args) + | otherwise + = pprMachOpApp' platform mop args + +{- +Note [Zero-extending sub-word signed results] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a program like (from #20634): + + test() { + bits64 ret; + bits8 a,b; + a = 0xe1 :: bits8; // == -31 signed + b = %quot(a, 3::bits8); // == -10 signed + ret = %zx64(a); // == 0xf6 unsigned + return (ret); + } + +This program should return 0xf6 == 246. However, we need to be very careful +with when dealing with the result of the %quot. For instance, one might be +tempted produce code like: + + StgWord8 a = 0xe1U; + StgInt8 b = (StgInt8) a / (StgInt8) 0x3U; + StgWord ret = (W_) b; + +However, this would be wrong; by widening `b` directly from `StgInt8` to +`StgWord` we will get sign-extension semantics: rather than 0xf6 we will get +0xfffffffffffffff6. To avoid this we must first cast `b` back to `StgWord8`, +ensuring that we get zero-extension semantics when we widen up to `StgWord`. + +Note [When in doubt, cast arguments as unsigned] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general C's signed-ness behavior can lead to surprising results and +consequently we are very explicit about ensuring that arguments have the +correct signedness. For instance, consider a program like + + test() { + bits64 ret, a, b; + a = %neg(43 :: bits64); + b = %neg(0x443c70fa3e465120 :: bits64); + ret = %modu(a, b); + return (ret); + } + +In this case both `a` and `b` will be StgInts in the generated C (since +`MO_Neg` is a signed operation). However, we want to ensure that we perform an +*unsigned* modulus operation, therefore we must be careful to cast both arguments +to StgWord. We do this for any operation where the signedness of the argument +may affect the operation's semantics. +-} + +-- | The result type of most operations is determined by the operands. However, +-- there are a few exceptions: particularly operations which might get promoted +-- to a signed result. For these we explicitly cast the result. +machOpNeedsCast :: Platform -> MachOp -> [CmmType] -> Maybe SDoc +machOpNeedsCast platform mop args + -- Comparisons in C have type 'int', but we want type W_ (this is what + -- resultRepOfMachOp says). + | isComparisonMachOp mop = Just mkW_ + + -- See Note [Zero-extending sub-word signed results] + | signedOp mop + , res_ty <- machOpResultType platform mop args + , not $ isFloatType res_ty -- only integer operations, not MO_SF_Conv + , let w = typeWidth res_ty + , w < wordWidth platform + = cast_it w + + -- A shift operation like (a >> b) where a::Word8 and b::Word has type Word + -- in C yet we want a Word8 + | Just w <- shiftOp mop = cast_it w + + -- The results of these operations may be promoted to signed values + -- due to C11 section 6.3.1.1. + | MO_Add w <- mop = cast_it w + | MO_Sub w <- mop = cast_it w + | MO_Mul w <- mop = cast_it w + | MO_U_Quot w <- mop = cast_it w + | MO_U_Rem w <- mop = cast_it w + | MO_And w <- mop = cast_it w + | MO_Or w <- mop = cast_it w + | MO_Xor w <- mop = cast_it w + | MO_Not w <- mop = cast_it w + + | otherwise = Nothing + where + cast_it w = + let ty = machRep_U_CType platform w + in Just $ parens ty + +pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc +pprMachOpApp' platform mop args + = case args of + + -- ternary + args@[_,_,_] -> + let (_fixity, op) = pprMachOp_for_C platform mop + in op <> parens (pprWithCommas pprArg args) + + -- dyadic + args@[x,y] -> + let (fixity, op) = pprMachOp_for_C platform mop + in case fixity of + Infix -> pprArg x <+> op <+> pprArg y + Prefix -> op <> parens (pprWithCommas pprArg args) + + -- unary + [x] -> + let (_fixity, op) = pprMachOp_for_C platform mop + in op <> parens (pprArg x) + + _ -> panic "PprC.pprMachOp : machop with wrong number of args" + + where + pprArg e + | needsFCasts mop = cCast platform (machRep_F_CType width) e + -- Cast needed for signed integer ops + | signedOp mop = cCast platform (machRep_S_CType platform width) e + -- See Note [When in doubt, cast arguments as unsigned] + | needsUnsignedCast mop + = cCast platform (machRep_U_CType platform width) e + | otherwise = pprExpr1 platform e + where + width = typeWidth (cmmExprType platform e) + + needsFCasts (MO_F_Neg _) = True + needsFCasts (MO_F_Quot _) = True + needsFCasts mop = floatComparison mop + + -- See Note [When in doubt, cast arguments as unsigned] + needsUnsignedCast (MO_Mul _) = True + needsUnsignedCast (MO_U_Shr _) = True + needsUnsignedCast (MO_U_Quot _) = True + needsUnsignedCast (MO_U_Rem _) = True + needsUnsignedCast (MO_U_Ge _) = True + needsUnsignedCast (MO_U_Le _) = True + needsUnsignedCast (MO_U_Gt _) = True + needsUnsignedCast (MO_U_Lt _) = True + needsUnsignedCast _ = False + +-- -------------------------------------------------------------------------- +-- Literals + +pprLit :: Platform -> CmmLit -> SDoc +pprLit platform lit = case lit of + CmmInt i rep -> pprHexVal platform i rep + + CmmFloat f w -> parens (machRep_F_CType w) <> str + where d = fromRational f :: Double + str | isInfinite d && d < 0 = text "-INFINITY" + | isInfinite d = text "INFINITY" + | isNaN d = text "NAN" + | otherwise = text (show d) + -- these constants come from + -- see #1861 + + CmmVec {} -> panic "PprC printing vector literal" + + CmmBlock bid -> mkW_ <> pprCLabelAddr (infoTblLbl bid) + CmmHighStackMark -> panic "PprC printing high stack mark" + CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl + CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i + CmmLabelDiffOff clbl1 _ i _ -- non-word widths not supported via C + -- WARNING: + -- * the lit must occur in the info table clbl2 + -- * clbl1 must be an SRT, a slow entry point or a large bitmap + -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i + + where + pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl + +pprLit1 :: Platform -> CmmLit -> SDoc +pprLit1 platform lit = case lit of + (CmmLabelOff _ _) -> parens (pprLit platform lit) + (CmmLabelDiffOff _ _ _ _) -> parens (pprLit platform lit) + (CmmFloat _ _) -> parens (pprLit platform lit) + _ -> pprLit platform lit + +-- --------------------------------------------------------------------------- +-- Static data + +-- | Produce a list of word sized literals encoding the given list of 'CmmLit's. +staticLitsToWords :: Platform -> [CmmLit] -> [SDoc] +staticLitsToWords platform = go . foldMap decomposeMultiWord + where + -- rem_bytes is how many bytes remain in the word we are currently filling. + -- accum is the word we are filling. + go :: [CmmLit] -> [SDoc] + go [] = [] + go lits@(lit : _) + | Just _ <- isSubWordLit lit + = goSubWord wordWidthBytes 0 lits + go (lit : rest) + = pprLit1 platform lit : go rest + + goSubWord :: Int -> Integer -> [CmmLit] -> [SDoc] + goSubWord rem_bytes accum (lit : rest) + | Just (bytes, w) <- isSubWordLit lit + , rem_bytes >= widthInBytes w + = let accum' = (accum `shiftL` widthInBits w) .|. fixEndian w bytes + in goSubWord (rem_bytes - widthInBytes w) accum' rest + goSubWord rem_bytes accum rest + = pprWord (fixEndian (wordWidth platform) $ accum `shiftL` (8*rem_bytes)) : go rest + + fixEndian :: Width -> Integer -> Integer + fixEndian w = case platformByteOrder platform of + BigEndian -> id + LittleEndian -> byteSwap w + + -- Decompose multi-word or floating-point literals into multiple + -- single-word (or smaller) literals. + decomposeMultiWord :: CmmLit -> [CmmLit] + decomposeMultiWord (CmmFloat n W64) + | W32 <- wordWidth platform = decomposeMultiWord (doubleToWord64 n) + | otherwise = [doubleToWord64 n] + decomposeMultiWord (CmmFloat n W32) + = [floatToWord32 n] + decomposeMultiWord (CmmInt n W64) + | W32 <- wordWidth platform + = case platformByteOrder platform of + BigEndian -> [CmmInt hi W32, CmmInt lo W32] + LittleEndian -> [CmmInt lo W32, CmmInt hi W32] + where + hi = n `shiftR` 32 + lo = n .&. 0xffffffff + decomposeMultiWord lit = [lit] + + -- Decompose a sub-word-sized literal into the integer value and its + -- (sub-word-sized) width. + isSubWordLit :: CmmLit -> Maybe (Integer, Width) + isSubWordLit lit = + case lit of + CmmInt n w + | w < wordWidth platform -> Just (n, w) + _ -> Nothing + + wordWidthBytes = widthInBytes $ wordWidth platform + + pprWord :: Integer -> SDoc + pprWord n = pprHexVal platform n (wordWidth platform) + +byteSwap :: Width -> Integer -> Integer +byteSwap width n = foldl' f 0 bytes + where + f acc m = (acc `shiftL` 8) .|. m + bytes = [ byte i | i <- [0..widthInBytes width - 1] ] + byte i = (n `shiftR` (i*8)) .&. 0xff + +pprStatic :: Platform -> CmmStatic -> SDoc +pprStatic platform s = case s of + + CmmStaticLit lit -> nest 4 (pprLit platform lit) + CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) + + -- these should be inlined, like the old .hc + CmmString s' -> nest 4 (mkW_ <> parens(pprStringInCStyle s')) + CmmFileEmbed {} -> panic "Unexpected CmmFileEmbed literal" + + +-- --------------------------------------------------------------------------- +-- Block Ids + +pprBlockId :: BlockId -> SDoc +pprBlockId b = char '_' <> ppr (getUnique b) + +-- -------------------------------------------------------------------------- +-- Print a MachOp in a way suitable for emitting via C. +-- + +data Fixity = Prefix | Infix + deriving ( Eq, Show ) + +pprMachOp_for_C :: Platform -> MachOp -> (Fixity, SDoc) + +pprMachOp_for_C platform mop = case mop of + + -- Integer operations + MO_Add _ -> (Infix, char '+') + MO_Sub _ -> (Infix, char '-') + MO_Eq _ -> (Infix, text "==") + MO_Ne _ -> (Infix, text "!=") + MO_Mul _ -> (Infix, char '*') + + MO_S_Quot _ -> (Infix, char '/') + MO_S_Rem _ -> (Infix, char '%') + MO_S_Neg _ -> (Infix, char '-') + + MO_U_Quot _ -> (Infix, char '/') + MO_U_Rem _ -> (Infix, char '%') + + -- Floating-point operations + MO_F_Add _ -> (Infix, char '+') + MO_F_Sub _ -> (Infix, char '-') + MO_F_Neg _ -> (Infix, char '-') + MO_F_Mul _ -> (Infix, char '*') + MO_F_Quot _ -> (Infix, char '/') + MO_F_Min _ -> (Prefix, text "fmin") + MO_F_Max _ -> (Prefix, text "fmax") + + -- Floating-point fused multiply-add operations + MO_FMA FMAdd 1 w -> + case w of + W32 -> (Prefix, text "fmaf") + W64 -> (Prefix, text "fma") + _ -> + pprTrace "offending mop:" + (text "FMAdd") + (panic $ "PprC.pprMachOp_for_C: FMAdd unsupported" + ++ "at width " ++ show w) + MO_FMA var l width + | l == 1 + -> pprTrace "offending mop:" + (text $ "FMA " ++ show var) + (panic $ "PprC.pprMachOp_for_C: should have been handled earlier!") + | otherwise + -> pprTrace "offending mop:" + (text $ "FMA " ++ show var ++ " " ++ show l ++ " " ++ show width) + (panic $ "PprC.pprMachOp_for_C: unsupported vector operation") + + -- Signed comparisons + MO_S_Ge _ -> (Infix, text ">=") + MO_S_Le _ -> (Infix, text "<=") + MO_S_Gt _ -> (Infix, char '>') + MO_S_Lt _ -> (Infix, char '<') + + -- & Unsigned comparisons + MO_U_Ge _ -> (Infix, text ">=") + MO_U_Le _ -> (Infix, text "<=") + MO_U_Gt _ -> (Infix, char '>') + MO_U_Lt _ -> (Infix, char '<') + + -- & Floating-point comparisons + MO_F_Eq _ -> (Infix, text "==") + MO_F_Ne _ -> (Infix, text "!=") + MO_F_Ge _ -> (Infix, text ">=") + MO_F_Le _ -> (Infix, text "<=") + MO_F_Gt _ -> (Infix, char '>') + MO_F_Lt _ -> (Infix, char '<') + + -- Bitwise operations. Not all of these may be supported at all + -- sizes, and only integral MachReps are valid. + MO_And _ -> (Infix, char '&') + MO_Or _ -> (Infix, char '|') + MO_Xor _ -> (Infix, char '^') + MO_Not _ -> (Infix, char '~') + MO_Shl _ -> (Infix, text "<<") + MO_U_Shr _ -> (Infix, text ">>") -- unsigned shift right + MO_S_Shr _ -> (Infix, text ">>") -- signed shift right + +-- Conversions. Some of these will be NOPs, but never those that convert +-- between ints and floats. +-- Floating-point conversions use the signed variant. +-- We won't know to generate (void*) casts here, but maybe from +-- context elsewhere + +-- bitcasts, in the C backend these are performed with __builtin_memcpy. +-- See rts/include/stg/Prim.h + + MO_FW_Bitcast W32 -> (Prefix, text "hs_bitcastfloat2word") + MO_FW_Bitcast W64 -> (Prefix, text "hs_bitcastdouble2word64") + + MO_WF_Bitcast W32 -> (Prefix, text "hs_bitcastword2float") + MO_WF_Bitcast W64 -> (Prefix, text "hs_bitcastword642double") + + MO_FW_Bitcast w -> pprTrace "offending mop:" + (text "MO_FW_Bitcast") + (panic $ "PprC.pprMachOp_for_C: MO_FW_Bitcast" + ++ " called with improper width!" + ++ show w) + + MO_WF_Bitcast w -> pprTrace "offending mop:" + (text "MO_WF_Bitcast") + (panic $ "PprC.pprMachOp_for_C: MO_WF_Bitcast" + ++ " called with improper width!" + ++ show w) + + +-- noop casts + MO_UU_Conv from to | from == to -> (Prefix, empty) + MO_UU_Conv _from to -> (Prefix, parens (machRep_U_CType platform to)) + + MO_SS_Conv from to | from == to -> (Prefix, empty) + MO_SS_Conv _from to -> (Prefix, parens (machRep_S_CType platform to)) + + MO_XX_Conv from to | from == to -> (Prefix, empty) + MO_XX_Conv _from to -> (Prefix,parens (machRep_U_CType platform to)) + + MO_FF_Conv from to | from == to -> (Prefix, empty) + MO_FF_Conv _from to -> (Prefix,parens (machRep_F_CType to)) + + MO_SF_Round _from to -> (Prefix,parens (machRep_F_CType to)) + MO_FS_Truncate _from to -> (Prefix,parens (machRep_S_CType platform to)) + + MO_RelaxedRead _ -> pprTrace "offending mop:" + (text "MO_RelaxedRead") + (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo" + ++ " should have been handled earlier!") + + MO_S_MulMayOflo _ -> pprTrace "offending mop:" + (text "MO_S_MulMayOflo") + (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo" + ++ " should have been handled earlier!") + + MO_AlignmentCheck {} -> panic "-falignment-sanitisation not supported by unregisterised backend" + +-- SIMD vector instructions: currently unsupported + MO_V_Shuffle {} -> pprTrace "offending mop:" + (text "MO_V_Shuffle") + (panic $ "PprC.pprMachOp_for_C: MO_V_Shuffle" + ++ "unsupported by the unregisterised backend") + MO_VF_Shuffle {} -> pprTrace "offending mop:" + (text "MO_VF_Shuffle") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Shuffle" + ++ "unsupported by the unregisterised backend") + MO_V_Insert {} -> pprTrace "offending mop:" + (text "MO_V_Insert") + (panic $ "PprC.pprMachOp_for_C: MO_V_Insert" + ++ "unsupported by the unregisterised backend") + MO_V_Extract {} -> pprTrace "offending mop:" + (text "MO_V_Extract") + (panic $ "PprC.pprMachOp_for_C: MO_V_Extract" + ++ "unsupported by the unregisterised backend") + MO_V_Add {} -> pprTrace "offending mop:" + (text "MO_V_Add") + (panic $ "PprC.pprMachOp_for_C: MO_V_Add" + ++ "unsupported by the unregisterised backend") + MO_V_Sub {} -> pprTrace "offending mop:" + (text "MO_V_Sub") + (panic $ "PprC.pprMachOp_for_C: MO_V_Sub" + ++ "unsupported by the unregisterised backend") + MO_V_Mul {} -> pprTrace "offending mop:" + (text "MO_V_Mul") + (panic $ "PprC.pprMachOp_for_C: MO_V_Mul" + ++ "unsupported by the unregisterised backend") + MO_VS_Neg {} -> pprTrace "offending mop:" + (text "MO_VS_Neg") + (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg" + ++ "unsupported by the unregisterised backend") + MO_V_Broadcast {} -> pprTrace "offending mop:" + (text "MO_V_Broadcast") + (panic $ "PprC.pprMachOp_for_C: MO_V_Broadcast" + ++ "unsupported by the unregisterised backend") + MO_VF_Broadcast {} -> pprTrace "offending mop:" + (text "MO_VF_Broadcast") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Broadcast" + ++ "unsupported by the unregisterised backend") + MO_VF_Insert {} -> pprTrace "offending mop:" + (text "MO_VF_Insert") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert" + ++ "unsupported by the unregisterised backend") + MO_VF_Extract {} -> pprTrace "offending mop:" + (text "MO_VF_Extract") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract" + ++ "unsupported by the unregisterised backend") + MO_VF_Add {} -> pprTrace "offending mop:" + (text "MO_VF_Add") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Add" + ++ "unsupported by the unregisterised backend") + MO_VF_Sub {} -> pprTrace "offending mop:" + (text "MO_VF_Sub") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub" + ++ "unsupported by the unregisterised backend") + MO_VF_Neg {} -> pprTrace "offending mop:" + (text "MO_VF_Neg") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg" + ++ "unsupported by the unregisterised backend") + MO_VF_Mul {} -> pprTrace "offending mop:" + (text "MO_VF_Mul") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul" + ++ "unsupported by the unregisterised backend") + MO_VF_Quot {} -> pprTrace "offending mop:" + (text "MO_VF_Quot") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot" + ++ "unsupported by the unregisterised backend") + MO_VU_Min {} -> pprTrace "offending mop:" + (text "MO_VU_Min") + (panic $ "PprC.pprMachOp_for_C: MO_VU_Min" + ++ "unsupported by the unregisterised backend") + MO_VU_Max {} -> pprTrace "offending mop:" + (text "MO_VU_Max") + (panic $ "PprC.pprMachOp_for_C: MO_VU_Max" + ++ "unsupported by the unregisterised backend") + MO_VS_Min {} -> pprTrace "offending mop:" + (text "MO_VS_Min") + (panic $ "PprC.pprMachOp_for_C: MO_VS_Min" + ++ "unsupported by the unregisterised backend") + MO_VS_Max {} -> pprTrace "offending mop:" + (text "MO_VS_Max") + (panic $ "PprC.pprMachOp_for_C: MO_VS_Max" + ++ "unsupported by the unregisterised backend") + MO_VF_Min {} -> pprTrace "offending mop:" + (text "MO_VF_Min") + (panic $ "PprC.pprMachOp_for_C: MO_VU_Min" + ++ "unsupported by the unregisterised backend") + MO_VF_Max {} -> pprTrace "offending mop:" + (text "MO_VF_Max") + (panic $ "PprC.pprMachOp_for_C: MO_VU_Max" + ++ "unsupported by the unregisterised backend") + +signedOp :: MachOp -> Bool -- Argument type(s) are signed ints +signedOp (MO_S_Quot _) = True +signedOp (MO_S_Rem _) = True +signedOp (MO_S_Neg _) = True +signedOp (MO_S_Ge _) = True +signedOp (MO_S_Le _) = True +signedOp (MO_S_Gt _) = True +signedOp (MO_S_Lt _) = True +signedOp (MO_S_Shr _) = True +signedOp (MO_SS_Conv _ _) = True +signedOp (MO_SF_Round _ _) = True +signedOp _ = False + +shiftOp :: MachOp -> Maybe Width +shiftOp (MO_Shl w) = Just w +shiftOp (MO_U_Shr w) = Just w +shiftOp (MO_S_Shr w) = Just w +shiftOp _ = Nothing + +floatComparison :: MachOp -> Bool -- comparison between float args +floatComparison (MO_F_Eq _) = True +floatComparison (MO_F_Ne _) = True +floatComparison (MO_F_Ge _) = True +floatComparison (MO_F_Le _) = True +floatComparison (MO_F_Gt _) = True +floatComparison (MO_F_Lt _) = True +floatComparison _ = False + +-- --------------------------------------------------------------------- +-- tend to be implemented by foreign calls + +pprCallishMachOp_for_C :: CallishMachOp -> SDoc + +pprCallishMachOp_for_C mop + = case mop of + MO_F64_Pwr -> text "pow" + MO_F64_Sin -> text "sin" + MO_F64_Cos -> text "cos" + MO_F64_Tan -> text "tan" + MO_F64_Sinh -> text "sinh" + MO_F64_Cosh -> text "cosh" + MO_F64_Tanh -> text "tanh" + MO_F64_Asin -> text "asin" + MO_F64_Acos -> text "acos" + MO_F64_Atanh -> text "atanh" + MO_F64_Asinh -> text "asinh" + MO_F64_Acosh -> text "acosh" + MO_F64_Atan -> text "atan" + MO_F64_Log -> text "log" + MO_F64_Log1P -> text "log1p" + MO_F64_Exp -> text "exp" + MO_F64_ExpM1 -> text "expm1" + MO_F64_Sqrt -> text "sqrt" + MO_F64_Fabs -> text "fabs" + MO_F32_Pwr -> text "powf" + MO_F32_Sin -> text "sinf" + MO_F32_Cos -> text "cosf" + MO_F32_Tan -> text "tanf" + MO_F32_Sinh -> text "sinhf" + MO_F32_Cosh -> text "coshf" + MO_F32_Tanh -> text "tanhf" + MO_F32_Asin -> text "asinf" + MO_F32_Acos -> text "acosf" + MO_F32_Atan -> text "atanf" + MO_F32_Asinh -> text "asinhf" + MO_F32_Acosh -> text "acoshf" + MO_F32_Atanh -> text "atanhf" + MO_F32_Log -> text "logf" + MO_F32_Log1P -> text "log1pf" + MO_F32_Exp -> text "expf" + MO_F32_ExpM1 -> text "expm1f" + MO_F32_Sqrt -> text "sqrtf" + MO_F32_Fabs -> text "fabsf" + MO_AcquireFence -> unsupported + MO_ReleaseFence -> unsupported + MO_SeqCstFence -> unsupported + MO_Memcpy _ -> text "__builtin_memcpy" + MO_Memset _ -> text "__builtin_memset" + MO_Memmove _ -> text "__builtin_memmove" + MO_Memcmp _ -> text "__builtin_memcmp" + + MO_SuspendThread -> text "suspendThread" + MO_ResumeThread -> text "resumeThread" + + MO_BSwap w -> ftext (bSwapLabel w) + MO_BRev w -> ftext (bRevLabel w) + MO_PopCnt w -> ftext (popCntLabel w) + MO_Pext w -> ftext (pextLabel w) + MO_Pdep w -> ftext (pdepLabel w) + MO_Clz w -> ftext (clzLabel w) + MO_Ctz w -> ftext (ctzLabel w) + MO_AtomicRMW w amop -> ftext (atomicRMWLabel w amop) + MO_Cmpxchg w -> ftext (cmpxchgLabel w) + MO_Xchg w -> ftext (xchgLabel w) + -- TODO: handle orderings + MO_AtomicRead w _ -> ftext (atomicReadLabel w) + MO_AtomicWrite w _ -> ftext (atomicWriteLabel w) + MO_UF_Conv w -> ftext (word2FloatLabel w) + + MO_S_Mul2 {} -> unsupported + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_AddWordC {} -> unsupported + MO_SubWordC {} -> unsupported + MO_AddIntC {} -> unsupported + MO_SubIntC {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_VS_Quot {} -> unsupported + MO_VS_Rem {} -> unsupported + MO_VU_Quot {} -> unsupported + MO_VU_Rem {} -> unsupported + MO_I64X2_Min -> unsupported + MO_I64X2_Max -> unsupported + MO_W64X2_Min -> unsupported + MO_W64X2_Max -> unsupported + MO_Touch -> unsupported + -- we could support prefetch via "__builtin_prefetch" + -- Not adding it for now + (MO_Prefetch_Data _ ) -> unsupported + + MO_I64_ToI -> text "hs_int64ToInt" + MO_I64_FromI -> text "hs_intToInt64" + MO_W64_ToW -> text "hs_word64ToWord" + MO_W64_FromW -> text "hs_wordToWord64" + MO_x64_Neg -> text "hs_neg64" + MO_x64_Add -> text "hs_add64" + MO_x64_Sub -> text "hs_sub64" + MO_x64_Mul -> text "hs_mul64" + MO_I64_Quot -> text "hs_quotInt64" + MO_I64_Rem -> text "hs_remInt64" + MO_W64_Quot -> text "hs_quotWord64" + MO_W64_Rem -> text "hs_remWord64" + MO_x64_And -> text "hs_and64" + MO_x64_Or -> text "hs_or64" + MO_x64_Xor -> text "hs_xor64" + MO_x64_Not -> text "hs_not64" + MO_x64_Shl -> text "hs_uncheckedShiftL64" + MO_I64_Shr -> text "hs_uncheckedIShiftRA64" + MO_W64_Shr -> text "hs_uncheckedShiftRL64" + MO_x64_Eq -> text "hs_eq64" + MO_x64_Ne -> text "hs_ne64" + MO_I64_Ge -> text "hs_geInt64" + MO_I64_Gt -> text "hs_gtInt64" + MO_I64_Le -> text "hs_leInt64" + MO_I64_Lt -> text "hs_ltInt64" + MO_W64_Ge -> text "hs_geWord64" + MO_W64_Gt -> text "hs_gtWord64" + MO_W64_Le -> text "hs_leWord64" + MO_W64_Lt -> text "hs_ltWord64" + where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop + ++ " not supported!") + +-- --------------------------------------------------------------------- +-- Useful #defines +-- + +mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc + +mkJMP_ i = text "JMP_" <> parens i +mkFN_ i = text "FN_" <> parens i -- externally visible function +mkIF_ i = text "IF_" <> parens i -- locally visible + +-- from rts/include/Stg.h +-- +mkC_,mkW_,mkP_ :: SDoc + +mkC_ = text "(C_)" -- StgChar +mkW_ = text "(W_)" -- StgWord +mkP_ = text "(P_)" -- StgWord* + +-- --------------------------------------------------------------------- +-- +-- Assignments +-- +-- Generating assignments is what we're all about, here +-- +pprAssign :: Platform -> CmmReg -> CmmExpr -> SDoc + +-- dest is a reg, rhs is a reg +pprAssign _ r1 (CmmReg r2) + | isPtrReg r1 && isPtrReg r2 + = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ] + +-- dest is a reg, rhs is a CmmRegOff +pprAssign platform r1 (CmmRegOff r2 off) + | isPtrReg r1 && isPtrReg r2 && (off `rem` platformWordSizeInBytes platform == 0) + = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] + where + off1 = off `shiftR` wordShift platform + + (op,off') | off >= 0 = (char '+', off1) + | otherwise = (char '-', -off1) + +-- dest is a reg, rhs is anything. +-- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting +-- the lvalue elicits a warning from new GCC versions (3.4+). +pprAssign platform r1 r2 + | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 platform r2) + | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2) + | otherwise = mkAssign (pprExpr platform r2) + where mkAssign x = + case r1 of + CmmGlobal (GlobalRegUse BaseReg _) -> + text "ASSIGN_BaseReg" <> parens x <> semi + _ -> pprReg r1 <> text " = " <> x <> semi + +-- --------------------------------------------------------------------- +-- Registers + +pprCastReg :: CmmReg -> SDoc +pprCastReg reg + | isStrangeTypeReg reg = mkW_ <> pprReg reg + | otherwise = pprReg reg + +-- True if (pprReg reg) will give an expression with type StgPtr. We +-- need to take care with pointer arithmetic on registers with type +-- StgPtr. +isFixedPtrReg :: CmmReg -> Bool +isFixedPtrReg (CmmLocal _) = False +isFixedPtrReg (CmmGlobal (GlobalRegUse r _)) = isFixedPtrGlobalReg r + +-- True if (pprAsPtrReg reg) will give an expression with type StgPtr +-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST. +-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT; +-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY. +isPtrReg :: CmmReg -> Bool +isPtrReg (CmmLocal _) = False +isPtrReg (CmmGlobal (GlobalRegUse (VanillaReg _) ty)) = isGcPtrType ty -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal (GlobalRegUse reg _)) = isFixedPtrGlobalReg reg + +-- True if this global reg has type StgPtr +isFixedPtrGlobalReg :: GlobalReg -> Bool +isFixedPtrGlobalReg Sp = True +isFixedPtrGlobalReg Hp = True +isFixedPtrGlobalReg HpLim = True +isFixedPtrGlobalReg SpLim = True +isFixedPtrGlobalReg _ = False + +-- True if in C this register doesn't have the type given by +-- (machRepCType (cmmRegType reg)), so it has to be cast. +isStrangeTypeReg :: CmmReg -> Bool +isStrangeTypeReg (CmmLocal _) = False +isStrangeTypeReg (CmmGlobal (GlobalRegUse g _)) = isStrangeTypeGlobal g + +isStrangeTypeGlobal :: GlobalReg -> Bool +isStrangeTypeGlobal CCCS = True +isStrangeTypeGlobal CurrentTSO = True +isStrangeTypeGlobal CurrentNursery = True +isStrangeTypeGlobal BaseReg = True +isStrangeTypeGlobal r = isFixedPtrGlobalReg r + +strangeRegType :: CmmReg -> Maybe SDoc +strangeRegType (CmmGlobal (GlobalRegUse CCCS _)) = Just (text "struct CostCentreStack_ *") +strangeRegType (CmmGlobal (GlobalRegUse CurrentTSO _)) = Just (text "struct StgTSO_ *") +strangeRegType (CmmGlobal (GlobalRegUse CurrentNursery _)) = Just (text "struct bdescr_ *") +strangeRegType (CmmGlobal (GlobalRegUse BaseReg _)) = Just (text "struct StgRegTable_ *") +strangeRegType _ = Nothing + +-- pprReg just prints the register name. +-- +pprReg :: CmmReg -> SDoc +pprReg r = case r of + CmmLocal local -> pprLocalReg local + CmmGlobal (GlobalRegUse global _ ) -> pprGlobalReg global + +pprAsPtrReg :: CmmReg -> SDoc +pprAsPtrReg (CmmGlobal (GlobalRegUse (VanillaReg n) ty)) + = warnPprTrace (not $ isGcPtrType ty) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p" +pprAsPtrReg other_reg = pprReg other_reg + +pprGlobalReg :: GlobalReg -> SDoc +pprGlobalReg gr = case gr of + VanillaReg n -> char 'R' <> int n <> text ".w" + -- pprGlobalReg prints a VanillaReg as a .w regardless + -- Example: R1.w = R1.w & (-0x8UL); + -- JMP_(*R1.p); + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + Sp -> text "Sp" + SpLim -> text "SpLim" + Hp -> text "Hp" + HpLim -> text "HpLim" + CCCS -> text "CCCS" + CurrentTSO -> text "CurrentTSO" + CurrentNursery -> text "CurrentNursery" + HpAlloc -> text "HpAlloc" + BaseReg -> text "BaseReg" + EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" + GCEnter1 -> text "stg_gc_enter_1" + GCFun -> text "stg_gc_fun" + other -> panic $ "pprGlobalReg: Unsupported register: " ++ show other + +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq + +-- ----------------------------------------------------------------------------- +-- Foreign Calls + +pprCall :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc +pprCall platform ppr_fn cconv results args + | not (is_cishCC cconv) + = panic $ "pprCall: unknown calling convention" + + | otherwise + = + ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi + where + ppr_assign [] rhs = rhs + ppr_assign [(one,hint)] rhs + = pprLocalReg one <> text " = " + <> pprUnHint hint (localRegType one) <> rhs + ppr_assign _other _rhs = panic "pprCall: multiple results" + + pprArg (expr, AddrHint) + = cCast platform (text "void *") expr + -- see comment by machRepHintCType below + pprArg (expr, SignedHint) + = cCast platform (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr + pprArg (expr, _other) + = pprExpr platform expr + + pprUnHint AddrHint rep = parens (machRepCType platform rep) + pprUnHint SignedHint rep = parens (machRepCType platform rep) + pprUnHint _ _ = empty + +-- Currently we only have these two calling conventions, but this might +-- change in the future... +is_cishCC :: CCallConv -> Bool +is_cishCC CCallConv = True +is_cishCC CApiConv = True +is_cishCC StdCallConv = True +is_cishCC PrimCallConv = False +is_cishCC JavaScriptCallConv = False + +-- --------------------------------------------------------------------- +-- Find and print local and external declarations for a list of +-- Cmm statements. +-- +pprTempAndExternDecls :: Platform -> [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-}) +pprTempAndExternDecls platform stmts + = (pprUFM (getUniqSet temps) (vcat . map (pprTempDecl platform)), + vcat (map (pprExternDecl platform) (Map.keys lbls))) + where (temps, lbls) = runTE (mapM_ te_BB stmts) + +pprDataExterns :: Platform -> [CmmStatic] -> SDoc +pprDataExterns platform statics + = vcat (map (pprExternDecl platform) (Map.keys lbls)) + where (_, lbls) = runTE (mapM_ te_Static statics) + +pprTempDecl :: Platform -> LocalReg -> SDoc +pprTempDecl platform l@(LocalReg _ rep) + = hcat [ machRepCType platform rep, space, pprLocalReg l, semi ] + +pprExternDecl :: Platform -> CLabel -> SDoc +pprExternDecl platform lbl + -- do not print anything for "known external" things + | not (needsCDecl lbl) = empty + | otherwise = + hcat [ visibility, label_type lbl , lparen, pprCLabel platform lbl, text ");" + -- occasionally useful to see label type + -- , text "/* ", pprDebugCLabel lbl, text " */" + ] + where + label_type lbl | isBytesLabel lbl = text "B_" + | isForeignLabel lbl && isCFunctionLabel lbl + = text "FF_" + | isCFunctionLabel lbl = text "F_" + | isStaticClosureLabel lbl = text "C_" + -- generic .rodata labels + | isSomeRODataLabel lbl = text "RO_" + -- generic .data labels (common case) + | otherwise = text "RW_" + + visibility + | externallyVisibleCLabel lbl = char 'E' + | otherwise = char 'I' + +type TEState = (UniqSet LocalReg, Map CLabel ()) +newtype TE a = TE' (State TEState a) + deriving stock (Functor) + deriving (Applicative, Monad) via State TEState + +pattern TE :: (TEState -> (a, TEState)) -> TE a +pattern TE f <- TE' (runState -> f) + where TE f = TE' (state f) +{-# COMPLETE TE #-} + +te_lbl :: CLabel -> TE () +te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls)) + +te_temp :: LocalReg -> TE () +te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls)) + +runTE :: TE () -> TEState +runTE (TE m) = snd (m (emptyUniqSet, Map.empty)) + +te_Static :: CmmStatic -> TE () +te_Static (CmmStaticLit lit) = te_Lit lit +te_Static _ = return () + +te_BB :: CmmBlock -> TE () +te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last + where (_, mid, last) = blockSplit block + +te_Lit :: CmmLit -> TE () +te_Lit (CmmLabel l) = te_lbl l +te_Lit (CmmLabelOff l _) = te_lbl l +te_Lit (CmmLabelDiffOff l1 _ _ _) = te_lbl l1 +te_Lit _ = return () + +te_Stmt :: CmmNode e x -> TE () +te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e +te_Stmt (CmmStore l r _) = te_Expr l >> te_Expr r +te_Stmt (CmmUnsafeForeignCall target rs es) + = do te_Target target + mapM_ te_temp rs + mapM_ te_Expr es +te_Stmt (CmmCondBranch e _ _ _) = te_Expr e +te_Stmt (CmmSwitch e _) = te_Expr e +te_Stmt (CmmCall { cml_target = e }) = te_Expr e +te_Stmt _ = return () + +te_Target :: ForeignTarget -> TE () +te_Target (ForeignTarget e _) = te_Expr e +te_Target (PrimTarget{}) = return () + +te_Expr :: CmmExpr -> TE () +te_Expr (CmmLit lit) = te_Lit lit +te_Expr (CmmLoad e _ _) = te_Expr e +te_Expr (CmmReg r) = te_Reg r +te_Expr (CmmMachOp _ es) = mapM_ te_Expr es +te_Expr (CmmRegOff r _) = te_Reg r +te_Expr (CmmStackSlot _ _) = panic "te_Expr: CmmStackSlot not supported!" + +te_Reg :: CmmReg -> TE () +te_Reg (CmmLocal l) = te_temp l +te_Reg _ = return () + + +-- --------------------------------------------------------------------- +-- C types for MachReps + +cCast :: Platform -> SDoc -> CmmExpr -> SDoc +cCast platform ty expr = parens ty <> pprExpr1 platform expr + +cLoad :: Platform -> CmmExpr -> CmmType -> SDoc +cLoad platform expr rep + = if bewareLoadStoreAlignment (platformArch platform) + then let decl = machRepCType platform rep <+> text "x" <> semi + struct = text "struct" <+> braces (decl) + packed_attr = text "__attribute__((packed))" + cast = parens (struct <+> packed_attr <> char '*') + in parens (cast <+> pprExpr1 platform expr) <> text "->x" + else char '*' <> parens (cCast platform (machRepPtrCType platform rep) expr) + where -- On these platforms, unaligned loads are known to cause problems + bewareLoadStoreAlignment ArchAlpha = True + bewareLoadStoreAlignment ArchMipseb = True + bewareLoadStoreAlignment ArchMipsel = True + bewareLoadStoreAlignment (ArchARM {}) = True + bewareLoadStoreAlignment ArchAArch64 = True + -- Pessimistically assume that they will also cause problems + -- on unknown arches + bewareLoadStoreAlignment ArchUnknown = True + bewareLoadStoreAlignment _ = False + +isCmmWordType :: Platform -> CmmType -> Bool +-- True of GcPtrReg/NonGcReg of native word size +isCmmWordType platform ty = not (isFloatType ty) + && typeWidth ty == wordWidth platform + +-- This is for finding the types of foreign call arguments. For a pointer +-- argument, we always cast the argument to (void *), to avoid warnings from +-- the C compiler. +machRepHintCType :: Platform -> CmmType -> ForeignHint -> SDoc +machRepHintCType platform rep = \case + AddrHint -> text "void *" + SignedHint -> machRep_S_CType platform (typeWidth rep) + _other -> machRepCType platform rep + +machRepPtrCType :: Platform -> CmmType -> SDoc +machRepPtrCType platform r + = if isCmmWordType platform r + then text "P_" + else machRepCType platform r <> char '*' + +machRepCType :: Platform -> CmmType -> SDoc +machRepCType platform ty + | isFloatType ty = machRep_F_CType w + | otherwise = machRep_U_CType platform w + where + w = typeWidth ty + +machRep_F_CType :: Width -> SDoc +machRep_F_CType W32 = text "StgFloat" -- ToDo: correct? +machRep_F_CType W64 = text "StgDouble" +machRep_F_CType _ = panic "machRep_F_CType" + +machRep_U_CType :: Platform -> Width -> SDoc +machRep_U_CType platform w + = case w of + _ | w == wordWidth platform -> text "W_" + W8 -> text "StgWord8" + W16 -> text "StgWord16" + W32 -> text "StgWord32" + W64 -> text "StgWord64" + _ -> panic "machRep_U_CType" + +machRep_S_CType :: Platform -> Width -> SDoc +machRep_S_CType platform w + = case w of + _ | w == wordWidth platform -> text "I_" + W8 -> text "StgInt8" + W16 -> text "StgInt16" + W32 -> text "StgInt32" + W64 -> text "StgInt64" + _ -> panic "machRep_S_CType" + + +-- --------------------------------------------------------------------- +-- print strings as valid C strings + +pprStringInCStyle :: ByteString -> SDoc +pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s))) + +-- --------------------------------------------------------------------------- +-- Initialising static objects with floating-point numbers. We can't +-- just emit the floating point number, because C will cast it to an int +-- by rounding it. We want the actual bit-representation of the float. +-- +-- Consider a concrete C example: +-- double d = 2.5e-10; +-- float f = 2.5e-10f; +-- +-- int * i2 = &d; printf ("i2: %08X %08X\n", i2[0], i2[1]); +-- long long * l = &d; printf (" l: %016llX\n", l[0]); +-- int * i = &f; printf (" i: %08X\n", i[0]); +-- Result on 64-bit LE (x86_64): +-- i2: E826D695 3DF12E0B +-- l: 3DF12E0BE826D695 +-- i: 2F89705F +-- Result on 32-bit BE (m68k): +-- i2: 3DF12E0B E826D695 +-- l: 3DF12E0BE826D695 +-- i: 2F89705F +-- +-- The trick here is to notice that binary representation does not +-- change much: only Word32 values get swapped on LE hosts / targets. + +-- This is a hack to turn the floating point numbers into ints that we +-- can safely initialise to static locations. + +floatToWord32 :: Rational -> CmmLit +floatToWord32 r = CmmInt (toInteger (castFloatToWord32 (fromRational r))) W32 + +doubleToWord64 :: Rational -> CmmLit +doubleToWord64 r = CmmInt (toInteger (castDoubleToWord64 (fromRational r))) W64 + +-- --------------------------------------------------------------------------- +-- Utils + +wordShift :: Platform -> Int +wordShift platform = widthInLog (wordWidth platform) + +commafy :: [SDoc] -> SDoc +commafy xs = hsep $ punctuate comma xs + +-- | Print in C hex format +-- +-- Examples: +-- +-- 5114 :: W32 ===> ((StgWord32)0x13faU) +-- (-5114) :: W32 ===> ((StgWord32)(-0x13faU)) +-- +-- We use casts to support types smaller than `unsigned int`; C literal +-- suffixes support longer but not shorter types. +pprHexVal :: Platform -> Integer -> Width -> SDoc +pprHexVal platform w rep = parens ctype <> rawlit + where + rawlit + | w < 0 = parens (char '-' <> + text "0x" <> intToDoc (-w) <> repsuffix rep) + | otherwise = text "0x" <> intToDoc w <> repsuffix rep + ctype = machRep_U_CType platform rep + + -- type suffix for literals: + -- Integer literals are unsigned in Cmm/C. We explicitly cast to + -- signed values for doing signed operations, but at all other + -- times values are unsigned. This also helps eliminate occasional + -- warnings about integer overflow from gcc. + + constants = platformConstants platform + + repsuffix W64 = + if pc_CINT_SIZE constants == 8 then char 'U' + else if pc_CLONG_SIZE constants == 8 then text "UL" + else if pc_CLONG_LONG_SIZE constants == 8 then text "ULL" + else panic "pprHexVal: Can't find a 64-bit type" + repsuffix _ = char 'U' + + intToDoc :: Integer -> SDoc + intToDoc i = case truncInt i of + 0 -> char '0' + v -> go v + + -- We need to truncate value as Cmm backend does not drop + -- redundant bits to ease handling of negative values. + -- Thus the following Cmm code on 64-bit arch, like amd64: + -- CInt v; + -- v = {something}; + -- if (v == %lobits32(-1)) { ... + -- leads to the following C code: + -- StgWord64 v = (StgWord32)({something}); + -- if (v == 0xFFFFffffFFFFffffU) { ... + -- Such code is incorrect as it promotes both operands to StgWord64 + -- and the whole condition is always false. + truncInt :: Integer -> Integer + truncInt i = + case rep of + W8 -> i `rem` (2^(8 :: Int)) + W16 -> i `rem` (2^(16 :: Int)) + W32 -> i `rem` (2^(32 :: Int)) + W64 -> i `rem` (2^(64 :: Int)) + _ -> panic ("pprHexVal/truncInt: C backend can't encode " + ++ show rep ++ " literals") + + go 0 = empty + go w' = go q <> dig + where + (q,r) = w' `quotRem` 16 + dig | r < 10 = char (chr (fromInteger r + ord '0')) + | otherwise = char (chr (fromInteger r - 10 + ord 'a')) + +-- | Construct a constructor/finalizer function. Instead of emitting a +-- initializer/finalizer array we rather just emit a single function, annotated +-- with the appropriate C attribute, which then calls each of the initializers. +pprCtorArray :: Platform -> InitOrFini -> [CLabel] -> SDoc +pprCtorArray platform initOrFini lbls = + decls + <> text "static __attribute__((" <> text attribute <> text "))" + <> text "void _hs_" <> text suffix <> text "()" + <> braces body + where + body = vcat [ pprCLabel platform lbl <> text " ();" | lbl <- lbls ] + decls = vcat [ text "void" <+> pprCLabel platform lbl <> text " (void);" | lbl <- lbls ] + (attribute, suffix) = case initOrFini of + IsInitArray + -- See Note [JSFFI initialization] for details + | ArchWasm32 <- platformArch platform -> ("constructor(101)", "constructor") + | otherwise -> ("constructor", "constructor") + IsFiniArray -> ("destructor", "destructor") diff --git a/GHC/CmmToLlvm.hs b/GHC/CmmToLlvm.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE TypeFamilies, ViewPatterns, OverloadedStrings #-} + +-- ----------------------------------------------------------------------------- +-- | This is the top-level module in the LLVM code generator. +-- +module GHC.CmmToLlvm + ( LlvmVersion + , llvmVersionList + , llvmCodeGen + , llvmFixupAsm + ) +where + +import GHC.Prelude + +import GHC.Llvm +import GHC.CmmToLlvm.Base +import GHC.CmmToLlvm.CodeGen +import GHC.CmmToLlvm.Config +import GHC.CmmToLlvm.Data +import GHC.CmmToLlvm.Ppr +import GHC.CmmToLlvm.Regs +import GHC.CmmToLlvm.Mangler +import GHC.CmmToLlvm.Version + +import GHC.StgToCmm.CgUtils ( fixStgRegisters, CgStream ) +import GHC.Cmm +import GHC.Cmm.Dataflow.Label + +import GHC.Types.Unique.DSM +import GHC.Utils.BufHandle +import GHC.Driver.DynFlags +import GHC.Platform ( platformArch, Arch(..) ) +import GHC.Utils.Error +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Logger +import qualified GHC.Data.Stream as Stream + +import Control.Monad ( when, forM_ ) +import Data.Maybe ( fromMaybe, catMaybes, isNothing ) +import System.IO + +-- ----------------------------------------------------------------------------- +-- | Top-level of the LLVM Code generator +-- +llvmCodeGen :: Logger -> LlvmCgConfig -> Handle + -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream. + -- See Note [Deterministic Uniques in the CG] + -> CgStream RawCmmGroup a + -> IO a +llvmCodeGen logger cfg h dus cmm_stream + = withTiming logger (text "LLVM CodeGen") (const ()) $ do + bufh <- newBufHandle h + + -- Pass header + showPass logger "LLVM CodeGen" + + -- get llvm version, cache for later use + let mb_ver = llvmCgLlvmVersion cfg + + -- warn if unsupported + forM_ mb_ver $ \ver -> do + debugTraceMsg logger 2 + (text "Using LLVM version:" <+> text (llvmVersionStr ver)) + let doWarn = llvmCgDoWarn cfg + when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger $ + "You are using an unsupported version of LLVM!" $$ + "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+> + "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+> + "System LLVM version: " <> text (llvmVersionStr ver) $$ + "We will try though..." + + when (isNothing mb_ver) $ do + let doWarn = llvmCgDoWarn cfg + when doWarn $ putMsg logger $ + "Failed to detect LLVM version!" $$ + "Make sure LLVM is installed correctly." $$ + "We will try though..." + + -- HACK: the Nothing case here is potentially wrong here but we + -- currently don't use the LLVM version to guide code generation + -- so this is okay. + let llvm_ver :: LlvmVersion + llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver + + -- run code generation + (a, _) <- runLlvm logger cfg llvm_ver bufh dus $ + llvmCodeGen' cfg cmm_stream + + bFlush bufh + + return a + +llvmCodeGen' :: LlvmCgConfig + -> CgStream RawCmmGroup a -> LlvmM a +llvmCodeGen' cfg cmm_stream + = do -- Preamble + renderLlvm (llvmHeader cfg) (llvmHeader cfg) + ghcInternalFunctions + cmmMetaLlvmPrelude + + -- Procedures + a <- Stream.consume cmm_stream (GHC.CmmToLlvm.Base.liftUDSMT) (llvmGroupLlvmGens) + + -- Declare aliases for forward references + decls <- generateExternDecls + renderLlvm (pprLlvmData cfg decls) + (pprLlvmData cfg decls) + + -- Postamble + cmmUsedLlvmGens + + return a + +llvmHeader :: IsDoc doc => LlvmCgConfig -> doc +llvmHeader cfg = + let target = llvmCgLlvmTarget cfg + llvmCfg = llvmCgLlvmConfig cfg + in lines_ + [ text "target datalayout = \"" <> text (getDataLayout llvmCfg target) <> text "\"" + , text "target triple = \"" <> text target <> text "\"" ] + where + getDataLayout :: LlvmConfig -> String -> String + getDataLayout config target = + case lookup target (llvmTargets config) of + Just (LlvmTarget {lDataLayout=dl}) -> dl + Nothing -> pprPanic "Failed to lookup LLVM data layout" $ + text "Target:" <+> text target $$ + hang (text "Available targets:") 4 + (vcat $ map (text . fst) $ llvmTargets config) +{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> SDoc #-} +{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +llvmGroupLlvmGens :: RawCmmGroup -> LlvmM () +llvmGroupLlvmGens cmm = do + + -- Insert functions into map, collect data + let split (CmmData s d' ) = return $ Just (s, d') + split (CmmProc h l live g) = do + -- Set function type + let l' = case mapLookup (g_entry g) h :: Maybe RawCmmStatics of + Nothing -> l + Just (CmmStaticsRaw info_lbl _) -> info_lbl + lml <- strCLabel_llvm l' + funInsert lml =<< llvmFunTy live + return Nothing + cdata <- fmap catMaybes $ mapM split cmm + + {-# SCC "llvm_datas_gen" #-} + cmmDataLlvmGens cdata + {-# SCC "llvm_procs_gen" #-} + mapM_ cmmLlvmGen cmm + +-- ----------------------------------------------------------------------------- +-- | Do LLVM code generation on all these Cmms data sections. +-- +cmmDataLlvmGens :: [(Section,RawCmmStatics)] -> LlvmM () + +cmmDataLlvmGens statics + = do lmdatas <- mapM genLlvmData statics + + let (concat -> gs, tss) = unzip lmdatas + + let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _) + = funInsert l ty + regGlobal _ = pure () + mapM_ regGlobal gs + gss' <- mapM aliasify gs + + cfg <- getConfig + renderLlvm (pprLlvmData cfg (concat gss', concat tss)) + (pprLlvmData cfg (concat gss', concat tss)) + +-- | Complete LLVM code generation phase for a single top-level chunk of Cmm. +cmmLlvmGen ::RawCmmDecl -> LlvmM () +cmmLlvmGen cmm@CmmProc{} = do + + -- rewrite assignments to global regs + platform <- getPlatform + let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters platform cmm + + dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" + FormatCMM (pprCmmGroup platform [fixed_cmm]) + + -- generate llvm code from cmm + llvmBC <- withClearVars $ genLlvmProc fixed_cmm + + -- pretty print - print as we go, since we produce HDocs, we know + -- no nesting state needs to be maintained for the SDocs. + forM_ llvmBC (\decl -> do + (hdoc, sdoc) <- pprLlvmCmmDecl decl + renderLlvm (hdoc $$ empty) (sdoc $$ empty) + ) + +cmmLlvmGen _ = return () + +-- ----------------------------------------------------------------------------- +-- | Generate meta data nodes +-- + +cmmMetaLlvmPrelude :: LlvmM () +cmmMetaLlvmPrelude = do + tbaa_metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do + -- Generate / lookup meta data IDs + tbaaId <- getMetaUniqueId + setUniqMeta uniq tbaaId + parentId <- maybe (return Nothing) getUniqMeta parent + -- Build definition + return $ MetaUnnamed tbaaId $ MetaStruct $ + case parentId of + Just p -> [ MetaStr name, MetaNode p ] + -- As of LLVM 4.0, a node without parents should be rendered as + -- just a name on its own. Previously `null` was accepted as the + -- name. + Nothing -> [ MetaStr name ] + + platform <- getPlatform + cfg <- getConfig + let stack_alignment_metas = + case platformArch platform of + ArchX86_64 | llvmCgAvxEnabled cfg -> [mkStackAlignmentMeta 32] + _ -> [] + let codel_model_metas = + case platformArch platform of + -- FIXME: We should not rely on LLVM + ArchLoongArch64 -> [mkCodeModelMeta CMMedium] + _ -> [] + module_flags_metas <- mkModuleFlagsMeta (stack_alignment_metas ++ codel_model_metas) + let metas = tbaa_metas ++ module_flags_metas + cfg <- getConfig + renderLlvm (ppLlvmMetas cfg metas) + (ppLlvmMetas cfg metas) + +mkNamedMeta :: LMString -> [MetaExpr] -> LlvmM [MetaDecl] +mkNamedMeta name exprs = do + (ids, decls) <- unzip <$> mapM f exprs + return $ decls ++ [MetaNamed name ids] + where + f expr = do + i <- getMetaUniqueId + return (i, MetaUnnamed i expr) + +mkModuleFlagsMeta :: [ModuleFlag] -> LlvmM [MetaDecl] +mkModuleFlagsMeta = + mkNamedMeta "llvm.module.flags" . map moduleFlagToMetaExpr + +mkStackAlignmentMeta :: Integer -> ModuleFlag +mkStackAlignmentMeta alignment = + ModuleFlag MFBError "override-stack-alignment" (MetaLit $ LMIntLit alignment i32) + +-- LLVM's @LLVM::CodeModel::Model@ enumeration +data CodeModel = CMMedium + +-- Pass -mcmodel=medium option to LLVM on LoongArch64 +mkCodeModelMeta :: CodeModel -> ModuleFlag +mkCodeModelMeta codemodel = + ModuleFlag MFBError "Code Model" (MetaLit $ LMIntLit n i32) + where + n = case codemodel of CMMedium -> 3 -- as of LLVM 8 + +-- ----------------------------------------------------------------------------- +-- | Marks variables as used where necessary +-- + +cmmUsedLlvmGens :: LlvmM () +cmmUsedLlvmGens = do + + -- LLVM would discard variables that are internal and not obviously + -- used if we didn't provide these hints. This will generate a + -- definition of the form + -- + -- @llvm.used = appending global [42 x i8*] [i8* bitcast to i8*, ...] + -- + -- Which is the LLVM way of protecting them against getting removed. + ivars <- getUsedVars + let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr + ty = LMArray (length ivars) i8Ptr + usedArray = LMStaticArray (map cast ivars) ty + sectName = Just $ fsLit "llvm.metadata" + lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant + lmUsed = LMGlobal lmUsedVar (Just usedArray) + if null ivars + then return () + else do + cfg <- getConfig + renderLlvm (pprLlvmData cfg ([lmUsed], [])) + (pprLlvmData cfg ([lmUsed], [])) diff --git a/GHC/CmmToLlvm/Base.hs b/GHC/CmmToLlvm/Base.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Base.hs @@ -0,0 +1,637 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- ---------------------------------------------------------------------------- +-- | Base LLVM Code Generation module +-- +-- Contains functions useful through out the code generator. +-- + +module GHC.CmmToLlvm.Base ( + + LlvmCmmDecl, LlvmBasicBlock, + LiveGlobalRegs, LiveGlobalRegUses, + LlvmUnresData, LlvmData, UnresLabel, UnresStatic, + + LlvmM, + runLlvm, withClearVars, varLookup, varInsert, + markStackReg, checkStackReg, + funLookup, funInsert, getLlvmVer, + dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars, + ghcInternalFunctions, getPlatform, getConfig, + + getMetaUniqueId, + setUniqMeta, getUniqMeta, liftIO, liftUDSMT, + + cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, + llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, + llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR, + + lookupRegUse, + + strCLabel_llvm, + getGlobalPtr, generateExternDecls, + + aliasify, llvmDefLabel + ) where + +import GHC.Prelude +import GHC.Utils.Panic + +import GHC.Llvm +import GHC.CmmToLlvm.Regs +import GHC.CmmToLlvm.Config +import GHC.CmmToLlvm.Version + +import GHC.Cmm.CLabel +import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe ) +import GHC.Driver.DynFlags +import GHC.Data.FastString +import GHC.Cmm hiding ( succ ) +import GHC.Cmm.Utils (globalRegsOverlap) +import GHC.Utils.Outputable as Outp +import GHC.Platform +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.Utils.BufHandle ( BufHandle ) +import GHC.Types.Unique.Set +import qualified GHC.Types.Unique.DSM as DSM +import GHC.Utils.Logger + +import Control.Monad.Trans.State (StateT (..)) +import Control.Applicative (Alternative((<|>))) +import Data.Maybe (fromJust, mapMaybe) + +import Data.List (find, isPrefixOf) +import qualified Data.List.NonEmpty as NE +import Data.Ord (comparing) +import qualified Control.Monad.IO.Class as IO + +-- ---------------------------------------------------------------------------- +-- * Some Data Types +-- + +type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe RawCmmStatics) (ListGraph LlvmStatement) +type LlvmBasicBlock = GenBasicBlock LlvmStatement + +-- | Global registers live on proc entry +type LiveGlobalRegs = [GlobalReg] +type LiveGlobalRegUses = [GlobalRegUse] + +-- | Unresolved code. +-- Of the form: (data label, data type, unresolved data) +type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic]) + +-- | Top level LLVM Data (globals and type aliases) +type LlvmData = ([LMGlobal], [LlvmType]) + +-- | An unresolved Label. +-- +-- Labels are unresolved when we haven't yet determined if they are defined in +-- the module we are currently compiling, or an external one. +type UnresLabel = CmmLit +type UnresStatic = Either UnresLabel LlvmStatic + +-- ---------------------------------------------------------------------------- +-- * Type translations +-- + +-- | Translate a basic CmmType to an LlvmType. +cmmToLlvmType :: CmmType -> LlvmType +cmmToLlvmType ty | isVecType ty = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty)) + | isFloatType ty = widthToLlvmFloat $ typeWidth ty + | otherwise = widthToLlvmInt $ typeWidth ty + +-- | Translate a Cmm Float Width to a LlvmType. +widthToLlvmFloat :: Width -> LlvmType +widthToLlvmFloat W32 = LMFloat +widthToLlvmFloat W64 = LMDouble +widthToLlvmFloat W128 = LMFloat128 +widthToLlvmFloat w = panic $ "widthToLlvmFloat: Bad float size: " ++ show w + +-- | Translate a Cmm Bit Width to a LlvmType. +widthToLlvmInt :: Width -> LlvmType +widthToLlvmInt w = LMInt $ widthInBits w + +-- | GHC Call Convention for LLVM +llvmGhcCC :: Platform -> LlvmCallConvention +llvmGhcCC platform + | platformUnregisterised platform = CC_Ccc + | otherwise = CC_Ghc + +-- | Llvm Function type for Cmm function +llvmFunTy :: LiveGlobalRegUses -> LlvmM LlvmType +llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible + +-- | Llvm Function signature +llvmFunSig :: LiveGlobalRegUses -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig live lbl link = do + lbl' <- strCLabel_llvm lbl + llvmFunSig' live lbl' link + +llvmFunSig' :: LiveGlobalRegUses -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig' live lbl link + = do let toParams x | isPointer x = (x, [NoAlias, NoCapture]) + | otherwise = (x, []) + platform <- getPlatform + return $ LlvmFunctionDecl lbl link (llvmGhcCC platform) LMVoid FixedArgs + (map (toParams . getVarType) (llvmFunArgs platform live)) + (llvmFunAlign platform) + +-- | Alignment to use for functions +llvmFunAlign :: Platform -> LMAlign +llvmFunAlign platform = Just (platformWordSizeInBytes platform) + +-- | Alignment to use for into tables +llvmInfAlign :: Platform -> LMAlign +llvmInfAlign platform = Just (platformWordSizeInBytes platform) + +-- | Section to use for a function +llvmFunSection :: LlvmCgConfig -> LMString -> LMSection +llvmFunSection opts lbl + | llvmCgSplitSection opts = Just (concatFS [fsLit ".text.", lbl]) + | otherwise = Nothing + +-- | A Function's arguments +llvmFunArgs :: Platform -> LiveGlobalRegUses -> [LlvmVar] +llvmFunArgs platform live = + map (lmGlobalRegArg platform) (mapMaybe isPassed allRegs) + where allRegs = activeStgRegs platform + paddingRegs = padLiveArgs platform live + isLive :: GlobalReg -> Maybe GlobalRegUse + isLive r = + lookupRegUse r (alwaysLive platform) + <|> + lookupRegUse r live + <|> + lookupRegUse r paddingRegs + isPassed r = + if not (isFPR r) + then Just $ GlobalRegUse r (globalRegSpillType platform r) + else isLive r + +lookupRegUse :: GlobalReg -> [GlobalRegUse] -> Maybe GlobalRegUse +lookupRegUse r = find ((== r) . globalRegUse_reg) + +isFPR :: GlobalReg -> Bool +isFPR (FloatReg _) = True +isFPR (DoubleReg _) = True +isFPR (XmmReg _) = True +isFPR (YmmReg _) = True +isFPR (ZmmReg _) = True +isFPR _ = False + +-- | Return a list of "padding" registers for LLVM function calls. +-- +-- When we generate LLVM function signatures, we can't just make any register +-- alive on function entry. Instead, we need to insert fake arguments of the +-- same register class until we are sure that one of them is mapped to the +-- register we want alive. E.g. to ensure that F5 is alive, we may need to +-- insert fake arguments mapped to F1, F2, F3 and F4. +-- +-- Invariant: Cmm FPR regs with number "n" maps to real registers with number +-- "n" If the calling convention uses registers in a different order or if the +-- invariant doesn't hold, this code probably won't be correct. +padLiveArgs :: Platform -> LiveGlobalRegUses -> LiveGlobalRegUses +padLiveArgs platform live = + if platformUnregisterised platform + then [] -- not using GHC's register convention for platform. + else padded + where + ---------------------------------- + -- handle floating-point registers (FPR) + + fprLive = filter (isFPR . globalRegUse_reg) live -- real live FPR registers + + -- we group live registers sharing the same classes, i.e. that use the same + -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg + -- all use the same real regs on X86-64 (XMM registers). + -- + classes = NE.groupBy sharesClass fprLive + sharesClass a b = globalRegsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers + norm x = globalRegUse_reg (fpr_ctor x 1) -- get the first register of the family + + -- For each class, we just have to fill missing registers numbers. We use + -- the constructor of the greatest register to build padding registers. + -- + -- E.g. sortedRs = [ F2, XMM4, D5] + -- output = [D1, D3] + padded :: [GlobalRegUse] + padded = concatMap padClass classes + + padClass :: NE.NonEmpty GlobalRegUse -> [GlobalRegUse] + padClass rs = go (NE.toList sortedRs) 1 + where + sortedRs = NE.sortBy (comparing (fpr_num . globalRegUse_reg)) rs + maxr = NE.last sortedRs + ctor = fpr_ctor maxr + + go [] _ = [] + go (GlobalRegUse c1 _: GlobalRegUse c2 _:_) _ -- detect bogus case (see #17920) + | fpr_num c1 == fpr_num c2 + , Just real <- globalRegMaybe platform c1 + = sorryDoc "LLVM code generator" $ + text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <> + text ") both alive AND mapped to the same real register: " <> ppr real <> + text ". This isn't currently supported by the LLVM backend." + go (cu@(GlobalRegUse c _):cs) f + | fpr_num c == f = go cs (f+1) -- already covered by a real register + | otherwise = ctor f : go (cu:cs) (f + 1) -- add padding register + + fpr_ctor :: GlobalRegUse -> Int -> GlobalRegUse + fpr_ctor (GlobalRegUse r fmt) i = + case r of + FloatReg _ -> GlobalRegUse (FloatReg i) fmt + DoubleReg _ -> GlobalRegUse (DoubleReg i) fmt + XmmReg _ -> GlobalRegUse (XmmReg i) fmt + YmmReg _ -> GlobalRegUse (YmmReg i) fmt + ZmmReg _ -> GlobalRegUse (ZmmReg i) fmt + _ -> error "fpr_ctor expected only FPR regs" + + fpr_num :: GlobalReg -> Int + fpr_num (FloatReg i) = i + fpr_num (DoubleReg i) = i + fpr_num (XmmReg i) = i + fpr_num (YmmReg i) = i + fpr_num (ZmmReg i) = i + fpr_num _ = error "fpr_num expected only FPR regs" + + +-- | Llvm standard fun attributes +llvmStdFunAttrs :: [LlvmFuncAttr] +llvmStdFunAttrs = [NoUnwind] + +-- | Convert a list of types to a list of function parameters +-- (each with no parameter attributes) +tysToParams :: [LlvmType] -> [LlvmParameter] +tysToParams = map (\ty -> (ty, [])) + +-- | Pointer width +llvmPtrBits :: Platform -> Int +llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform + +-- ---------------------------------------------------------------------------- +-- * Environment Handling +-- + +data LlvmEnv = LlvmEnv + { envVersion :: LlvmVersion -- ^ LLVM version + , envConfig :: !LlvmCgConfig -- ^ Configuration for LLVM code gen + , envLogger :: !Logger -- ^ Logger + , envOutput :: BufHandle -- ^ Output buffer + , envTag :: !Char -- ^ Tag for creating unique values + , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs + , envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes + , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type + , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References] + , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@) + + -- the following get cleared for every function (see @withClearVars@) + , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type + , envStackRegs :: [GlobalRegUse] -- ^ Non-constant registers (alloca'd in the function prelude) + } + +type LlvmEnvMap = UniqFM Unique LlvmType + +-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad +newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> DSM.UniqDSMT IO (a, LlvmEnv) } + deriving stock (Functor) + deriving (Applicative, Monad) via StateT LlvmEnv (DSM.UniqDSMT IO) + +instance HasLogger LlvmM where + getLogger = LlvmM $ \env -> return (envLogger env, env) + +-- | Get target platform +getPlatform :: LlvmM Platform +getPlatform = llvmCgPlatform <$> getConfig + +getConfig :: LlvmM LlvmCgConfig +getConfig = LlvmM $ \env -> return (envConfig env, env) + + +-- This instance uses a deterministic unique supply from UniqDSMT, so new +-- uniques within LlvmM will be sampled deterministically. +instance DSM.MonadGetUnique LlvmM where + getUniqueM = do + tag <- getEnv envTag + liftUDSMT $! do + uq <- DSM.getUniqueM + return (newTagUnique uq tag) + +-- | Lifting of IO actions. Not exported, as we want to encapsulate IO. +liftIO :: IO a -> LlvmM a +liftIO m = LlvmM $ \env -> do x <- IO.liftIO m + return (x, env) + +-- | Lifting of UniqDSMT actions. Gives access to the deterministic unique supply being threaded through by LlvmM. +liftUDSMT :: DSM.UniqDSMT IO a -> LlvmM a +liftUDSMT m = LlvmM $ \env -> do x <- m + return (x, env) + +-- | Get initial Llvm environment. +runLlvm :: Logger -> LlvmCgConfig -> LlvmVersion -> BufHandle -> DSM.DUniqSupply -> LlvmM a -> IO (a, DSM.DUniqSupply) +runLlvm logger cfg ver out us m = do + ((a, _), us') <- DSM.runUDSMT us $ runLlvmM m env + return (a, us') + where env = LlvmEnv { envFunMap = emptyUFM + , envVarMap = emptyUFM + , envStackRegs = [] + , envUsedVars = [] + , envAliases = emptyUniqSet + , envVersion = ver + , envConfig = cfg + , envLogger = logger + , envOutput = out + , envTag = 'n' + , envFreshMeta = MetaId 0 + , envUniqMeta = emptyUFM + } + +-- | Get environment (internal) +getEnv :: (LlvmEnv -> a) -> LlvmM a +getEnv f = LlvmM (\env -> return (f env, env)) + +-- | Modify environment (internal) +modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM () +modifyEnv f = LlvmM (\env -> return ((), f env)) + +-- | Clear variables from the environment for a subcomputation +withClearVars :: LlvmM a -> LlvmM a +withClearVars m = LlvmM $ \env -> do + (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] } + return (x, env' { envVarMap = emptyUFM, envStackRegs = [] }) + +-- | Insert variables or functions into the environment. +varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM () +varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) (getUnique s) t } +funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) (getUnique s) t } + +-- | Lookup variables or functions in the environment. +varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType) +varLookup s = getEnv (flip lookupUFM (getUnique s) . envVarMap) +funLookup s = getEnv (flip lookupUFM (getUnique s) . envFunMap) + +-- | Set a register as allocated on the stack +markStackReg :: GlobalRegUse -> LlvmM () +markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env } + +-- | Check whether a register is allocated on the stack +checkStackReg :: GlobalReg -> LlvmM (Maybe CmmType) +checkStackReg r = do + stack_regs <- getEnv envStackRegs + return $ fmap globalRegUse_type $ lookupRegUse r stack_regs + +-- | Allocate a new global unnamed metadata identifier +getMetaUniqueId :: LlvmM MetaId +getMetaUniqueId = LlvmM $ \env -> + return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env }) + +-- | Get the LLVM version we are generating code for +getLlvmVer :: LlvmM LlvmVersion +getLlvmVer = getEnv envVersion + +-- | Dumps the document if the corresponding flag has been set by the user +dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM () +dumpIfSetLlvm flag hdr fmt doc = do + logger <- getLogger + liftIO $ putDumpFileMaybe logger flag hdr fmt doc + +-- | Prints the given contents to the output handle +renderLlvm :: Outp.HDoc -> Outp.SDoc -> LlvmM () +renderLlvm hdoc sdoc = do + + -- Write to output + ctx <- llvmCgContext <$> getConfig + out <- getEnv envOutput + liftIO $ Outp.bPutHDoc out ctx hdoc + + -- Dump, if requested + dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc + return () + +-- | Marks a variable as "used" +markUsedVar :: LlvmVar -> LlvmM () +markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env } + +-- | Return all variables marked as "used" so far +getUsedVars :: LlvmM [LlvmVar] +getUsedVars = getEnv envUsedVars + +-- | Saves that at some point we didn't know the type of the label and +-- generated a reference to a type variable instead +saveAlias :: LMString -> LlvmM () +saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl } + +-- | Sets metadata node for a given unique +setUniqMeta :: Unique -> MetaId -> LlvmM () +setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m } + +-- | Gets metadata node for given unique +getUniqMeta :: Unique -> LlvmM (Maybe MetaId) +getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta) + +-- ---------------------------------------------------------------------------- +-- * Internal functions +-- + +-- | Here we pre-initialise some functions that are used internally by GHC +-- so as to make sure they have the most general type in the case that +-- user code also uses these functions but with a different type than GHC +-- internally. (Main offender is treating return type as 'void' instead of +-- 'void *'). Fixes #5486. +ghcInternalFunctions :: LlvmM () +ghcInternalFunctions = do + platform <- getPlatform + let w = llvmWord platform + cint = LMInt $ widthInBits $ cIntWidth platform + mk "memcmp" cint [i8Ptr, i8Ptr, w] + mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w] + mk "memmove" i8Ptr [i8Ptr, i8Ptr, w] + mk "memset" i8Ptr [i8Ptr, w, w] + mk "newSpark" w [i8Ptr, i8Ptr] + where + mk n ret args = do + let n' = fsLit n + decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret + FixedArgs (tysToParams args) Nothing + renderLlvm (ppLlvmFunctionDecl decl) (ppLlvmFunctionDecl decl) + funInsert n' (LMFunction decl) + +-- ---------------------------------------------------------------------------- +-- * Label handling +-- + +-- | Pretty print a 'CLabel'. +strCLabel_llvm :: CLabel -> LlvmM LMString +strCLabel_llvm lbl = do + ctx <- llvmCgContext <$> getConfig + platform <- getPlatform + let sdoc = pprCLabel platform lbl + str = Outp.showSDocOneLine ctx sdoc + return (fsLit str) + +-- ---------------------------------------------------------------------------- +-- * Global variables / forward references +-- + +-- | Create/get a pointer to a global value. Might return an alias if +-- the value in question hasn't been defined yet. We especially make +-- no guarantees on the type of the returned pointer. +getGlobalPtr :: LMString -> LlvmM LlvmVar +getGlobalPtr llvmLbl = do + m_ty <- funLookup llvmLbl + let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing + case m_ty of + -- Directly reference if we have seen it already + Just ty -> do + if llvmLbl `elem` (map fsLit ["newSpark", "memmove", "memcpy", "memcmp", "memset"]) + then return $ mkGlbVar (llvmLbl) ty Global + else return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global + -- Otherwise use a forward alias of it + Nothing -> do + saveAlias llvmLbl + return $ mkGlbVar llvmLbl i8 Alias + +-- | Derive the definition label. It has an identified +-- structure type. +llvmDefLabel :: LMString -> LMString +llvmDefLabel = (`appendFS` fsLit "$def") + +-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@. +-- +-- Must be called at a point where we are sure that no new global definitions +-- will be generated anymore! +generateExternDecls :: LlvmM ([LMGlobal], [LlvmType]) +generateExternDecls = do + delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + defss <- flip mapM delayed $ \lbl -> do + m_ty <- funLookup lbl + case m_ty of + -- If we have a definition we've already emitted the proper aliases + -- when the symbol itself was emitted by @aliasify@ + Just _ -> return [] + + -- If we don't have a definition this is an external symbol and we + -- need to emit a declaration + Nothing -> + let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global + in return [LMGlobal var Nothing] + + -- Reset forward list + modifyEnv $ \env -> env { envAliases = emptyUniqSet } + return (concat defss, []) + +-- | Is a variable one of the special @\@llvm@ globals? +isBuiltinLlvmVar :: LlvmVar -> Bool +isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) = + "llvm." `isPrefixOf` unpackFS lbl +isBuiltinLlvmVar _ = False + +-- | Here we take a global variable definition, rename it with a +-- @$def@ suffix, and generate the appropriate alias. +aliasify :: LMGlobal -> LlvmM [LMGlobal] +-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +-- Here we obtain the indirectee's precise type and introduce +-- fresh aliases to both the precise typed label (lbl$def) and the i8* +-- typed (regular) label of it with the matching new names. +aliasify (LMGlobal var@(LMGlobalVar lbl ty@LMAlias{} link sect align Alias) + (Just orig)) + | not $ isBuiltinLlvmVar var = do + let defLbl = llvmDefLabel lbl + LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig + defOrigLbl = llvmDefLabel origLbl + orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias) + origType <- funLookup origLbl + let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl + (pLift $ fromJust origType) oLnk + Nothing Nothing Alias)) + (pLift ty) + pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig) + , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig') + ] +aliasify (LMGlobal var val) + | not $ isBuiltinLlvmVar var = do + let LMGlobalVar lbl ty link sect align const = var + + defLbl = llvmDefLabel lbl + defVar = LMGlobalVar defLbl ty Internal sect align const + + defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const + aliasVar = LMGlobalVar lbl i8Ptr link Nothing Nothing Alias + aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr + + -- we need to mark the $def symbols as used so LLVM doesn't forget which + -- section they need to go in. This will vanish once we switch away from + -- mangling sections for TNTC. + markUsedVar defVar + + return [ LMGlobal defVar val + , LMGlobal aliasVar (Just aliasVal) + ] +aliasify global = pure [global] + +-- Note [Llvm Forward References] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The issue here is that LLVM insists on being strongly typed at +-- every corner, so the first time we mention something, we have to +-- settle what type we assign to it. That makes things awkward, as Cmm +-- will often reference things before their definition, and we have no +-- idea what (LLVM) type it is going to be before that point. +-- +-- Our work-around is to define "aliases" of a standard type (i8 *) in +-- these kind of situations, which we later tell LLVM to be either +-- references to their actual local definitions (involving a cast) or +-- an external reference. This obviously only works for pointers. +-- +-- In particular when we encounter a reference to a symbol in a chunk of +-- C-- there are three possible scenarios, +-- +-- 1. We have already seen a definition for the referenced symbol. This +-- means we already know its type. +-- +-- 2. We have not yet seen a definition but we will find one later in this +-- compilation unit. Since we want to be a good consumer of the +-- C-- streamed to us from upstream, we don't know the type of the +-- symbol at the time when we must emit the reference. +-- +-- 3. We have not yet seen a definition nor will we find one in this +-- compilation unit. In this case the reference refers to an +-- external symbol for which we do not know the type. +-- +-- Let's consider case (2) for a moment: say we see a reference to +-- the symbol @fooBar@ for which we have not seen a definition. As we +-- do not know the symbol's type, we assume it is of type @i8*@ and emit +-- the appropriate casts in @getSymbolPtr@. Later on, when we +-- encounter the definition of @fooBar@ we emit it but with a modified +-- name, @fooBar$def@ (which we'll call the definition symbol), to +-- since we have already had to assume that the symbol @fooBar@ +-- is of type @i8*@. We then emit @fooBar@ itself as an alias +-- of @fooBar$def@ with appropriate casts. This all happens in +-- @aliasify@. +-- +-- Case (3) is quite similar to (2): References are emitted assuming +-- the referenced symbol is of type @i8*@. When we arrive at the end of +-- the compilation unit and realize that the symbol is external, we emit +-- an LLVM @external global@ declaration for the symbol @fooBar@ +-- (handled in @generateExternDecls@). This takes advantage of the +-- fact that the aliases produced by @aliasify@ for exported symbols +-- have external linkage and can therefore be used as normal symbols. +-- +-- Historical note: As of release 3.5 LLVM does not allow aliases to +-- refer to declarations. This the reason why aliases are produced at the +-- point of definition instead of the point of usage, as was previously +-- done. See #9142 for details. +-- +-- Finally, case (1) is trivial. As we already have a definition for +-- and therefore know the type of the referenced symbol, we can do +-- away with casting the alias to the desired type in @getSymbolPtr@ +-- and instead just emit a reference to the definition symbol directly. +-- This is the @Just@ case in @getSymbolPtr@. +-- +-- Note that we must take care not to turn LLVM's builtin variables into +-- aliases (e.g. $llvm.global_ctors) since this confuses LLVM. diff --git a/GHC/CmmToLlvm/CodeGen.hs b/GHC/CmmToLlvm/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/CodeGen.hs @@ -0,0 +1,2450 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs, MultiWayIf #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- | Handle conversion of CmmProc to LLVM code. +module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Regs ( activeStgRegs ) + +import GHC.Llvm +import GHC.Llvm.Types +import GHC.CmmToLlvm.Base +import GHC.CmmToLlvm.Config +import GHC.CmmToLlvm.Regs + +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label + +import GHC.Data.FastString +import GHC.Data.Maybe (expectJust) +import GHC.Data.OrdList + +import GHC.Types.ForeignCall +import GHC.Types.Unique.DSM +import GHC.Types.Unique + +import GHC.Utils.Outputable +import qualified GHC.Utils.Panic as Panic +import GHC.Utils.Misc + +import Control.Applicative (Alternative((<|>))) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer +import Control.Monad + +import qualified Data.Semigroup as Semigroup +import Data.Foldable ( toList ) +import Data.List ( nub ) +import qualified Data.List as List +import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) +import Data.Maybe ( catMaybes ) + +type Atomic = Maybe MemoryOrdering +type LlvmStatements = OrdList LlvmStatement + +data Signage = Signed | Unsigned deriving (Eq, Show) + +-- ----------------------------------------------------------------------------- +-- | Top-level of the LLVM proc Code generator +-- +genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] +genLlvmProc (CmmProc infos lbl live graph) + | Just blocks <- nonEmpty $ toBlockListEntryFirstFalseFallthrough graph = do + (lmblocks, lmdata) <- basicBlocksCodeGen live blocks + let info = mapLookup (g_entry graph) infos + proc = CmmProc info lbl live (ListGraph lmblocks) + return (proc:lmdata) + +genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!" + +-- ----------------------------------------------------------------------------- +-- * Block code generation +-- + +-- | Unreachable basic block +-- +-- See Note [Unreachable block as default destination in Switch] +newtype UnreachableBlockId = UnreachableBlockId BlockId + +-- | Generate code for a list of blocks that make up a complete +-- procedure. The first block in the list is expected to be the entry +-- point. +basicBlocksCodeGen :: LiveGlobalRegUses -> NonEmpty CmmBlock + -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) +basicBlocksCodeGen live cmmBlocks + = do -- Emit the prologue + -- N.B. this must be its own block to ensure that the entry block of the + -- procedure has no predecessors, as required by the LLVM IR. See #17589 + -- and #11649. + bid <- newBlockId + (prologue, prologueTops) <- funPrologue live cmmBlocks + let entryBlock = BasicBlock bid (fromOL prologue) + + -- allocate one unreachable basic block that can be used as a default + -- destination in exhaustive switches. + -- + -- See Note [Unreachable block as default destination in Switch] + ubid@(UnreachableBlockId ubid') <- UnreachableBlockId <$> newBlockId + let ubblock = BasicBlock ubid' [Unreachable] + + -- Generate code + (blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) $ toList cmmBlocks + + -- Compose + return (entryBlock : ubblock : blocks, prologueTops ++ concat topss) + + +-- | Generate code for one block +basicBlockCodeGen :: UnreachableBlockId -> CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] ) +basicBlockCodeGen ubid block + = do let (_, nodes, tail) = blockSplit block + id = entryLabel block + (mid_instrs, top) <- stmtsToInstrs ubid $ blockToList nodes + (tail_instrs, top') <- stmtToInstrs ubid tail + let instrs = fromOL (mid_instrs `appOL` tail_instrs) + return (BasicBlock id instrs, top' ++ top) + +-- ----------------------------------------------------------------------------- +-- * CmmNode code generation +-- + +-- A statement conversion return data. +-- * LlvmStatements: The compiled LLVM statements. +-- * LlvmCmmDecl: Any global data needed. +type StmtData = (LlvmStatements, [LlvmCmmDecl]) + + +-- | Convert a list of CmmNode's to LlvmStatement's +stmtsToInstrs :: UnreachableBlockId -> [CmmNode e x] -> LlvmM StmtData +stmtsToInstrs ubid stmts + = do (instrss, topss) <- fmap unzip $ mapM (stmtToInstrs ubid) stmts + return (concatOL instrss, concat topss) + + +-- | Convert a CmmStmt to a list of LlvmStatement's +stmtToInstrs :: UnreachableBlockId -> CmmNode e x -> LlvmM StmtData +stmtToInstrs ubid stmt = case stmt of + + CmmComment _ -> return (nilOL, []) -- nuke comments + CmmTick _ -> return (nilOL, []) + CmmUnwind {} -> return (nilOL, []) + + CmmAssign reg src -> genAssign reg src + CmmStore addr src align + -> genStore addr src align + + CmmBranch id -> genBranch id + CmmCondBranch arg true false likely + -> genCondBranch arg true false likely + CmmSwitch arg ids -> genSwitch ubid arg ids + + -- Foreign Call + CmmUnsafeForeignCall target res args + -> genCall target res args + + -- Tail call + CmmCall { cml_target = arg, + cml_args_regs = live } -> genJump arg live + + _ -> panic "Llvm.CodeGen.stmtToInstrs" + +-- | Wrapper function to declare an instrinct function by function type +getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData +getInstrinct2 fname fty@(LMFunction funSig) = do + + let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant + + fn <- funLookup fname + tops <- case fn of + Just _ -> + return [] + Nothing -> do + funInsert fname fty + un <- getUniqueM + let lbl = mkAsmTempLabel un + return [CmmData (Section Data lbl) [([],[fty])]] + + return (fv, nilOL, tops) + +getInstrinct2 _ _ = error "getInstrinct2: Non-function type!" + +-- | Declares an instrinct function by return and parameter types +getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData +getInstrinct fname retTy parTys = + let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy + FixedArgs (tysToParams parTys) Nothing + fty = LMFunction funSig + in getInstrinct2 fname fty + +-- | Foreign Calls +genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData + +-- Barriers need to be handled specially as they are implemented as LLVM +-- intrinsic functions. +genCall (PrimTarget MO_AcquireFence) _ _ = runStmtsDecls $ + statement $ Fence False SyncAcquire +genCall (PrimTarget MO_ReleaseFence) _ _ = runStmtsDecls $ + statement $ Fence False SyncRelease +genCall (PrimTarget MO_SeqCstFence) _ _ = runStmtsDecls $ + statement $ Fence False SyncSeqCst + +genCall (PrimTarget MO_Touch) _ _ = + return (nilOL, []) + +genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do + (dstV, ty) <- getCmmRegW (CmmLocal dst) + let width = widthToLlvmFloat w + castV <- lift $ mkLocalVar ty + ve <- exprToVarW e + statement $ Assignment castV $ Cast LM_Uitofp ve width + statement $ Store castV dstV Nothing [] + +genCall (PrimTarget (MO_UF_Conv _)) [_] args = + panic $ "genCall: Too many arguments to MO_UF_Conv. " ++ + "Can only handle 1, given" ++ show (length args) ++ "." + +-- Handle prefetching data +genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args + | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ do + let argTy = [i8Ptr, i32, i32, i32] + funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing + + let (_, arg_hints) = foreignTargetHints t + let args_hints' = zip args arg_hints + argVars <- arg_varsW args_hints' ([], nilOL, []) + fptr <- liftExprData $ getFunPtr funTy t + argVars' <- castVarsW Signed $ zip argVars argTy + + let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1] + statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] + | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) + +-- Handle Clz, Ctz, BRev, BSwap, Pdep, Pext, and PopCnt that need to only +-- convert arg and return types +genCall (PrimTarget op@(MO_Clz w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Ctz w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_BRev w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_BSwap w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Pdep w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Pext w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_PopCnt w)) [dst] args = + genCallSimpleCast w op dst args + +genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do + addrVar <- exprToVarW addr + nVar <- exprToVarW n + let targetTy = widthToLlvmInt width + ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) + ptrVar <- doExprW (pLift targetTy) ptrExpr + (dstVar, _dst_ty) <- getCmmRegW (CmmLocal dst) + let op = case amop of + AMO_Add -> LAO_Add + AMO_Sub -> LAO_Sub + AMO_And -> LAO_And + AMO_Nand -> LAO_Nand + AMO_Or -> LAO_Or + AMO_Xor -> LAO_Xor + retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst + statement $ Store retVar dstVar Nothing [] + +genCall (PrimTarget (MO_AtomicRead _ mem_ord)) [dst] [addr] = runStmtsDecls $ do + (dstV, _dst_ty) <- getCmmRegW (CmmLocal dst) + v1 <- genLoadW (Just mem_ord) addr (localRegType dst) NaturallyAligned + statement $ Store v1 dstV Nothing [] + +genCall (PrimTarget (MO_Cmpxchg _width)) + [dst] [addr, old, new] = runStmtsDecls $ do + addrVar <- exprToVarW addr + oldVar <- exprToVarW old + newVar <- exprToVarW new + let targetTy = getVarType oldVar + ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) + ptrVar <- doExprW (pLift targetTy) ptrExpr + (dstVar, _dst_ty) <- getCmmRegW (CmmLocal dst) + retVar <- doExprW (LMStructU [targetTy,i1]) + $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst + retVar' <- doExprW targetTy $ ExtractV retVar 0 + statement $ Store retVar' dstVar Nothing [] + +genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do + (dstV, _dst_ty) <- getCmmRegW (CmmLocal dst) + addrVar <- exprToVarW addr + valVar <- exprToVarW val + let ptrTy = pLift $ getVarType valVar + ptrExpr = Cast LM_Inttoptr addrVar ptrTy + ptrVar <- doExprW ptrTy ptrExpr + resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst) + statement $ Store resVar dstV Nothing [] + +genCall (PrimTarget (MO_AtomicWrite _width mem_ord)) [] [addr, val] = runStmtsDecls $ do + addrVar <- exprToVarW addr + valVar <- exprToVarW val + let ptrTy = pLift $ getVarType valVar + ptrExpr = Cast LM_Inttoptr addrVar ptrTy + ptrVar <- doExprW ptrTy ptrExpr + let ordering = convertMemoryOrdering mem_ord + statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar ordering + +-- Handle memcpy function specifically since llvm's intrinsic version takes +-- some extra parameters. +genCall t@(PrimTarget op) [] args + | Just align <- machOpMemcpyishAlign op + = do + platform <- getPlatform + runStmtsDecls $ do + let isVolTy = [i1] + isVolVal = [mkIntLit i1 0] + argTy | MO_Memset _ <- op = [i8Ptr, i8, llvmWord platform, i32] ++ isVolTy + | otherwise = [i8Ptr, i8Ptr, llvmWord platform, i32] ++ isVolTy + funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing + + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + argVars <- arg_varsW args_hints ([], nilOL, []) + fptr <- getFunPtrW funTy t + argVars' <- castVarsW Signed $ zip argVars argTy + + let alignVal = mkIntLit i32 align + arguments = argVars' ++ (alignVal:isVolVal) + statement $ Expr $ Call StdCall fptr arguments [] + +-- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands +-- twice the width (we first zero-extend them), e.g., on 64-bit arch we will +-- generate 'mul' on 128-bit operands. Then we only need some plumbing to +-- extract the two 64-bit values out of 128-bit result. +genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do + let width = widthToLlvmInt w + bitWidth = widthInBits w + width2x = LMInt (bitWidth * 2) + -- First zero-extend the operands ('mul' instruction requires the operands + -- and the result to be of the same type). Note that we don't use 'castVars' + -- because it tries to do LM_Sext. + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x + rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x + -- Do the actual multiplication (note that the result is also 2x width). + retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt + -- Extract the lower bits of the result into retL. + retL <- doExprW width $ Cast LM_Trunc retV width + -- Now we unsigned right-shift the higher bits by width. + let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width + retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit + -- And extract them into retH. + retH <- doExprW width $ Cast LM_Trunc retShifted width + (dstRegL, _dstL_ty) <- getCmmRegW (CmmLocal dstL) + (dstRegH, _dstH_ty) <- getCmmRegW (CmmLocal dstH) + statement $ Store retL dstRegL Nothing [] + statement $ Store retH dstRegH Nothing [] + +genCall (PrimTarget (MO_S_Mul2 w)) [dstC, dstH, dstL] [lhs, rhs] = runStmtsDecls $ do + let width = widthToLlvmInt w + bitWidth = widthInBits w + width2x = LMInt (bitWidth * 2) + -- First sign-extend the operands ('mul' instruction requires the operands + -- and the result to be of the same type). Note that we don't use 'castVars' + -- because it tries to do LM_Sext. + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + lhsExt <- doExprW width2x $ Cast LM_Sext lhsVar width2x + rhsExt <- doExprW width2x $ Cast LM_Sext rhsVar width2x + -- Do the actual multiplication (note that the result is also 2x width). + retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt + -- Extract the lower bits of the result into retL. + retL <- doExprW width $ Cast LM_Trunc retV width + -- Now we signed right-shift the higher bits by width. + let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width + retShifted <- doExprW width2x $ LlvmOp LM_MO_AShr retV widthLlvmLit + -- And extract them into retH. + retH <- doExprW width $ Cast LM_Trunc retShifted width + -- Check if the carry is useful by doing a full arithmetic right shift on + -- retL and comparing the result with retH + let widthLlvmLitm1 = LMLitVar $ LMIntLit (fromIntegral bitWidth - 1) width + retH' <- doExprW width $ LlvmOp LM_MO_AShr retL widthLlvmLitm1 + retC1 <- doExprW i1 $ Compare LM_CMP_Ne retH retH' -- Compare op returns a 1-bit value (i1) + retC <- doExprW width $ Cast LM_Zext retC1 width -- so we zero-extend it + (dstRegL, _dstL_ty) <- getCmmRegW (CmmLocal dstL) + (dstRegH, _dstH_ty) <- getCmmRegW (CmmLocal dstH) + (dstRegC, _dstC_ty) <- getCmmRegW (CmmLocal dstC) + statement $ Store retL dstRegL Nothing [] + statement $ Store retH dstRegH Nothing [] + statement $ Store retC dstRegC Nothing [] + +-- MO_U_QuotRem2 is another case we handle by widening the registers to double +-- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The +-- main difference here is that we need to combine two words into one register +-- and then use both 'udiv' and 'urem' instructions to compute the result. +genCall (PrimTarget (MO_U_QuotRem2 w)) + [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do + let width = widthToLlvmInt w + bitWidth = widthInBits w + width2x = LMInt (bitWidth * 2) + -- First zero-extend all parameters to double width. + let zeroExtend expr = do + var <- exprToVarW expr + doExprW width2x $ Cast LM_Zext var width2x + lhsExtH <- zeroExtend lhsH + lhsExtL <- zeroExtend lhsL + rhsExt <- zeroExtend rhs + -- Now we combine the first two parameters (that represent the high and low + -- bits of the value). So first left-shift the high bits to their position + -- and then bit-or them with the low bits. + let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width + lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit + lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL + -- Finally, we can call 'udiv' and 'urem' to compute the results. + retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt + retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt + -- And since everything is in 2x width, we need to truncate the results and + -- then return them. + let narrow var = doExprW width $ Cast LM_Trunc var width + retDiv <- narrow retExtDiv + retRem <- narrow retExtRem + (dstRegQ, _dstQ_ty) <- lift $ getCmmReg (CmmLocal dstQ) + (dstRegR, _dstR_ty) <- lift $ getCmmReg (CmmLocal dstR) + statement $ Store retDiv dstRegQ Nothing [] + statement $ Store retRem dstRegR Nothing [] + +-- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from +-- which we need to extract the actual values. +genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] +genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +-- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the +-- return tuple to be the overflow bit and the second element to contain the +-- actual result of the addition. So we still use genCallWithOverflow but swap +-- the return registers. +genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +genCall t@(PrimTarget (MO_AddWordC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +genCall (PrimTarget (MO_VS_Quot l w)) [dst] [lhs, rhs] = runStmtsDecls $ do + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_SDiv lhsVar rhsVar) + (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst) + statement $ Store result dstReg Nothing [] + +genCall (PrimTarget (MO_VS_Rem l w)) [dst] [lhs, rhs] = runStmtsDecls $ do + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_SRem lhsVar rhsVar) + (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst) + statement $ Store result dstReg Nothing [] + +genCall (PrimTarget (MO_VU_Quot l w)) [dst] [lhs, rhs] = runStmtsDecls $ do + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_UDiv lhsVar rhsVar) + (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst) + statement $ Store result dstReg Nothing [] + +genCall (PrimTarget (MO_VU_Rem l w)) [dst] [lhs, rhs] = runStmtsDecls $ do + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_URem lhsVar rhsVar) + (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst) + statement $ Store result dstReg Nothing [] + +-- Handle all other foreign calls and prim ops. +genCall target res args = do + platform <- getPlatform + runStmtsDecls $ do + + -- extract Cmm call convention, and translate to LLVM call convention + let lmconv = case target of + ForeignTarget _ (ForeignConvention conv _ _ _) -> + case conv of + StdCallConv -> panic "GHC.CmmToLlvm.CodeGen.genCall: StdCallConv" + CCallConv -> CC_Ccc + CApiConv -> CC_Ccc + PrimCallConv -> panic "GHC.CmmToLlvm.CodeGen.genCall: PrimCallConv" + JavaScriptCallConv -> panic "GHC.CmmToLlvm.CodeGen.genCall: JavaScriptCallConv" + + PrimTarget _ -> CC_Ccc + + {- + CC_Ccc of the possibilities here are a worry with the use of a custom + calling convention for passing STG args. In practice the more + dangerous combinations (e.g StdCall + llvmGhcCC) don't occur. + + The native code generator only handles StdCall and CCallConv. + -} + + -- parameter types + let arg_type (_, AddrHint) = (i8Ptr, []) + -- cast pointers to i8*. Llvm equivalent of void* + arg_type (expr, hint) = + case cmmToLlvmType $ cmmExprType platform expr of + ty@(LMInt n) | n < 64 && lmconv == CC_Ccc && platformCConvNeedsExtension platform + -> (ty, if hint == SignedHint then [SignExt] else [ZeroExt]) + ty -> (ty, []) + + -- ret type + let ret_type [] = LMVoid + ret_type [(_, AddrHint)] = i8Ptr + ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg + ret_type t = panic $ "genCall: Too many return values! Can only handle" + ++ " 0 or 1, given " ++ show (length t) ++ "." + + -- call attributes + let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs + | otherwise = llvmStdFunAttrs + + never_returns = case target of + ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True + _ -> False + + -- fun type + let (res_hints, arg_hints) = foreignTargetHints target + let args_hints = zip args arg_hints + let ress_hints = zip res res_hints + let ccTy = StdCall -- tail calls should be done through CmmJump + let retTy = ret_type ress_hints + let argTy = map arg_type args_hints + let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + lmconv retTy FixedArgs argTy (llvmFunAlign platform) + + argVars <- arg_varsW args_hints ([], nilOL, []) + fptr <- getFunPtrW funTy target + + let doReturn | ccTy == TailCall = statement $ Return Nothing + | never_returns = statement $ Unreachable + | otherwise = return () + + + -- make the actual call + case retTy of + LMVoid -> + statement $ Expr $ Call ccTy fptr argVars fnAttrs + _ -> do + v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs + -- get the return register + let ret_reg [reg] = reg + ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" + ++ " 1, given " ++ show (length t) ++ "." + let creg = ret_reg res + (vreg, ty) <- getCmmRegW (CmmLocal creg) + if retTy == ty + then do + statement $ Store v1 vreg Nothing [] + doReturn + else do + let op = case ty of + vt | isPointer vt -> LM_Bitcast + | isInt vt -> LM_Ptrtoint + | otherwise -> + panic $ "genCall: CmmReg bad match for" + ++ " returned type!" + v2 <- doExprW ty $ Cast op v1 ty + statement $ Store v2 vreg Nothing [] + doReturn + +-- | Generate a call to an LLVM intrinsic that performs arithmetic operation +-- with overflow bit (i.e., returns a struct containing the actual result of the +-- operation and an overflow bit). This function will also extract the overflow +-- bit and zero-extend it (all the corresponding Cmm PrimOps represent the +-- overflow "bit" as a usual Int# or Word#). +genCallWithOverflow + :: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData +genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do + -- So far this was only tested for the following four CallishMachOps. + let valid = op `elem` [ MO_Add2 w + , MO_AddIntC w + , MO_SubIntC w + , MO_AddWordC w + , MO_SubWordC w + ] + Panic.massert valid + let width = widthToLlvmInt w + -- This will do most of the work of generating the call to the intrinsic and + -- extracting the values from the struct. + (value, overflowBit, (stmts, top)) <- + genCallExtract t w (lhs, rhs) (width, i1) + -- value is i, but overflowBit is i1, so we need to cast (Cmm expects + -- both to be i) + (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width + (dstRegV, _dstV_ty) <- getCmmReg (CmmLocal dstV) + (dstRegO, _dstO_ty) <- getCmmReg (CmmLocal dstO) + let storeV = Store value dstRegV Nothing [] + storeO = Store overflow dstRegO Nothing [] + return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top) +genCallWithOverflow _ _ _ _ = + panic "genCallExtract: wrong ForeignTarget or number of arguments" + +-- | A helper function for genCallWithOverflow that handles generating the call +-- to the LLVM intrinsic and extracting the result from the struct to LlvmVars. +genCallExtract + :: ForeignTarget -- ^ PrimOp + -> Width -- ^ Width of the operands. + -> (CmmActual, CmmActual) -- ^ Actual arguments. + -> (LlvmType, LlvmType) -- ^ LLVM types of the returned struct. + -> LlvmM (LlvmVar, LlvmVar, StmtData) +genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do + let width = widthToLlvmInt w + argTy = [width, width] + retTy = LMStructU [llvmTypeA, llvmTypeB] + + -- Process the arguments. + let args_hints = zip [argA, argB] (snd $ foreignTargetHints target) + (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, []) + (argsV2, args2) <- castVars Signed $ zip argsV1 argTy + + -- Get the function and make the call. + fname <- cmmPrimOpFunctions op + (fptr, _, top2) <- getInstrinct fname retTy argTy + -- We use StdCall for primops. See also the last case of genCall. + (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 [] + + -- This will result in a two element struct, we need to use "extractvalue" + -- to get them out of it. + (res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0) + (res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1) + + let stmts = args1 `appOL` args2 `snocOL` call `snocOL` ext1 `snocOL` ext2 + tops = top1 ++ top2 + return (res1, res2, (stmts, tops)) + +genCallExtract _ _ _ _ = + panic "genCallExtract: unsupported ForeignTarget" + +-- Handle simple function call that only need simple type casting, of the form: +-- truncate arg >>= \a -> call(a) >>= zext +-- +-- since GHC only really has i32 and i64 types and things like Word8 are backed +-- by an i32 and just present a logical i8 range. So we must handle conversions +-- from i32 to i8 explicitly as LLVM is strict about types. +genCallSimpleCast :: Width -> CallishMachOp -> CmmFormal -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast specW op dst args = do + let width = widthToLlvmInt specW + argsW = const width <$> args + dstType = cmmToLlvmType $ localRegType dst + signage = cmmPrimOpRetValSignage op + + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width argsW + (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) + let (_, arg_hints) = foreignTargetHints $ PrimTarget op + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars signage $ zip argsV argsW + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + (retV', stmts5) <- castVar signage retV dstType + let s2 = Store retV' dstV Nothing [] + + let stmts = stmts2 `appOL` stmts4 `snocOL` + s1 `snocOL` stmts5 `snocOL` s2 + return (stmts, top2 ++ top3) + +-- | Create a function pointer from a target. +getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget + -> WriterT LlvmAccum LlvmM LlvmVar +getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ + +-- | Create a function pointer from a target. +getFunPtr :: (LMString -> LlvmType) -> ForeignTarget + -> LlvmM ExprData +getFunPtr funTy targ = case targ of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do + name <- strCLabel_llvm lbl + getHsFunc' name (funTy name) + + ForeignTarget expr _ -> do + (v1, stmts, top) <- exprToVar expr + let fty = funTy $ fsLit "dynamic" + cast = case getVarType v1 of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + ty -> pprPanic "genCall: Expr is of bad type for function" $ + text " call! " <> lparen <> ppr ty <> rparen + + (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) + return (v2, stmts `snocOL` s1, top) + + PrimTarget mop -> do + name <- cmmPrimOpFunctions mop + let fty = funTy name + getInstrinct2 name fty + +-- | Conversion of call arguments. +arg_varsW :: [(CmmActual, ForeignHint)] + -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) + -> WriterT LlvmAccum LlvmM [LlvmVar] +arg_varsW xs ys = do + (vars, stmts, decls) <- lift $ arg_vars xs ys + tell $ LlvmAccum stmts decls + return vars + +-- | Conversion of call arguments. +arg_vars :: [(CmmActual, ForeignHint)] + -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) + -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) + +arg_vars [] (vars, stmts, tops) + = return (vars, stmts, tops) + +arg_vars ((e, AddrHint):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + let op = case getVarType v1 of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + a -> pprPanic "genCall: Can't cast llvmType to i8*! " $ + lparen <> ppr a <> rparen + + (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr + arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, + tops ++ top') + +arg_vars ((e, _):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') + + +-- | Cast a collection of LLVM variables to specific types. +castVarsW :: Signage + -> [(LlvmVar, LlvmType)] + -> WriterT LlvmAccum LlvmM [LlvmVar] +castVarsW signage vars = do + (vars, stmts) <- lift $ castVars signage vars + tell $ LlvmAccum stmts mempty + return vars + +-- | Cast a collection of LLVM variables to specific types. +castVars :: Signage -> [(LlvmVar, LlvmType)] + -> LlvmM ([LlvmVar], LlvmStatements) +castVars signage vars = do + done <- mapM (uncurry (castVar signage)) vars + let (vars', stmts) = unzip done + return (vars', toOL stmts) + +-- | Cast an LLVM variable to a specific type, panicking if it can't be done. +castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement) +castVar signage v t | getVarType v == t + = return (v, Nop) + + | otherwise + = do platform <- getPlatform + let op = case (getVarType v, t) of + (LMInt n, LMInt m) + -> if n < m then extend else LM_Trunc + (vt, _) | isFloat vt && isFloat t + -> if llvmWidthInBits platform vt < llvmWidthInBits platform t + then LM_Fpext else LM_Fptrunc + (vt, _) | isInt vt && isFloat t -> LM_Sitofp + (vt, _) | isFloat vt && isInt t -> LM_Fptosi + (vt, _) | isInt vt && isPointer t -> LM_Inttoptr + (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint + (vt, _) | isPointer vt && isPointer t -> LM_Bitcast + (vt, _) | isVector vt && isVector t -> LM_Bitcast + + (vt, _) -> pprPanic "castVars: Can't cast this type " $ + lparen <> ppr vt <> rparen + <> text " to " <> + lparen <> ppr t <> rparen + + doExpr t $ Cast op v t + where extend = case signage of + Signed -> LM_Sext + Unsigned -> LM_Zext + +cmmPrimOpRetValSignage :: CallishMachOp -> Signage +cmmPrimOpRetValSignage mop = case mop of + -- Some bit-wise operations /must/ always treat the input and output values + -- as 'Unsigned' in order to return the expected result values when pre/post- + -- operation bit-width truncation and/or extension occur. For example, + -- consider the Bit-Reverse operation: + -- + -- If the result of a Bit-Reverse is treated as signed, + -- an positive input can result in an negative output, i.e.: + -- + -- identity(0x03) = 0x03 = 00000011 + -- breverse(0x03) = 0xC0 = 11000000 + -- + -- Now if an extension is performed after the operation to + -- promote a smaller bit-width value into a larger bit-width + -- type, it is expected that the /bit-wise/ operations will + -- not be treated /numerically/ as signed. + -- + -- To illustrate the difference, consider how a signed extension + -- for the type i16 to i32 differs for out values above: + -- ext_zeroed(i32, breverse(0x03)) = 0x00C0 = 0000000011000000 + -- ext_signed(i32, breverse(0x03)) = 0xFFC0 = 1111111111000000 + -- + -- Here we can see that the former output is the expected result + -- of a bit-wise operation which needs to be promoted to a larger + -- bit-width type. The latter output is not desirable when we must + -- constraining a value into a range of i16 within an i32 type. + -- + -- Hence we always treat the "signage" as unsigned for Bit-Reverse! + -- + -- The same reasoning applied to Bit-Reverse above applies to the other + -- bit-wise operations; do not sign extend a possibly negated number! + MO_BRev _ -> Unsigned + MO_BSwap _ -> Unsigned + MO_Clz _ -> Unsigned + MO_Ctz _ -> Unsigned + MO_Pdep _ -> Unsigned + MO_Pext _ -> Unsigned + MO_PopCnt _ -> Unsigned + + -- All other cases, default to preserving the numeric sign when extending. + _ -> Signed + +-- | Decide what C function to use to implement a CallishMachOp +cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString +cmmPrimOpFunctions mop = do + cfg <- getConfig + platform <- getPlatform + let !isBmi2Enabled = llvmCgBmiVersion cfg >= Just BMI2 + !is32bit = platformWordSize platform == PW4 + unsupported = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " not supported here") + dontReach64 = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " should be not be encountered because the regular primop for this 64-bit operation is used instead.") + + return $ case mop of + MO_F32_Exp -> fsLit "expf" + MO_F32_ExpM1 -> fsLit "expm1f" + MO_F32_Log -> fsLit "logf" + MO_F32_Log1P -> fsLit "log1pf" + MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" + MO_F32_Fabs -> fsLit "llvm.fabs.f32" + MO_F32_Pwr -> fsLit "llvm.pow.f32" + + MO_F32_Sin -> fsLit "llvm.sin.f32" + MO_F32_Cos -> fsLit "llvm.cos.f32" + MO_F32_Tan -> fsLit "tanf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + + MO_F32_Asinh -> fsLit "asinhf" + MO_F32_Acosh -> fsLit "acoshf" + MO_F32_Atanh -> fsLit "atanhf" + + MO_F64_Exp -> fsLit "exp" + MO_F64_ExpM1 -> fsLit "expm1" + MO_F64_Log -> fsLit "log" + MO_F64_Log1P -> fsLit "log1p" + MO_F64_Sqrt -> fsLit "llvm.sqrt.f64" + MO_F64_Fabs -> fsLit "llvm.fabs.f64" + MO_F64_Pwr -> fsLit "llvm.pow.f64" + + MO_F64_Sin -> fsLit "llvm.sin.f64" + MO_F64_Cos -> fsLit "llvm.cos.f64" + MO_F64_Tan -> fsLit "tan" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + + MO_F64_Asinh -> fsLit "asinh" + MO_F64_Acosh -> fsLit "acosh" + MO_F64_Atanh -> fsLit "atanh" + + -- In the following ops, it looks like we could factorize the concatenation + -- of the bit size, and indeed it was like this before, e.g. + -- + -- MO_PopCnt w -> fsLit $ "llvm.ctpop.i" ++ wbits w + -- or + -- MO_Memcpy _ -> fsLit $ "llvm.memcpy." ++ intrinTy1 + -- + -- however it meant that FastStrings were not built from constant string + -- literals, hence they weren't matching the "fslit" rewrite rule in + -- GHC.Data.FastString that computes the string size at compilation time. + + MO_Memcpy _ + | is32bit -> fsLit "llvm.memcpy.p0i8.p0i8.i32" + | otherwise -> fsLit "llvm.memcpy.p0i8.p0i8.i64" + MO_Memmove _ + | is32bit -> fsLit "llvm.memmove.p0i8.p0i8.i32" + | otherwise -> fsLit "llvm.memmove.p0i8.p0i8.i64" + MO_Memset _ + | is32bit -> fsLit "llvm.memset.p0i8.i32" + | otherwise -> fsLit "llvm.memset.p0i8.i64" + MO_Memcmp _ -> fsLit "memcmp" + + MO_SuspendThread -> fsLit "suspendThread" + MO_ResumeThread -> fsLit "resumeThread" + + MO_PopCnt w -> case w of + W8 -> fsLit "llvm.ctpop.i8" + W16 -> fsLit "llvm.ctpop.i16" + W32 -> fsLit "llvm.ctpop.i32" + W64 -> fsLit "llvm.ctpop.i64" + W128 -> fsLit "llvm.ctpop.i128" + W256 -> fsLit "llvm.ctpop.i256" + W512 -> fsLit "llvm.ctpop.i512" + MO_BSwap w -> case w of + W8 -> fsLit "llvm.bswap.i8" + W16 -> fsLit "llvm.bswap.i16" + W32 -> fsLit "llvm.bswap.i32" + W64 -> fsLit "llvm.bswap.i64" + W128 -> fsLit "llvm.bswap.i128" + W256 -> fsLit "llvm.bswap.i256" + W512 -> fsLit "llvm.bswap.i512" + MO_BRev w -> case w of + W8 -> fsLit "llvm.bitreverse.i8" + W16 -> fsLit "llvm.bitreverse.i16" + W32 -> fsLit "llvm.bitreverse.i32" + W64 -> fsLit "llvm.bitreverse.i64" + W128 -> fsLit "llvm.bitreverse.i128" + W256 -> fsLit "llvm.bitreverse.i256" + W512 -> fsLit "llvm.bitreverse.i512" + MO_Clz w -> case w of + W8 -> fsLit "llvm.ctlz.i8" + W16 -> fsLit "llvm.ctlz.i16" + W32 -> fsLit "llvm.ctlz.i32" + W64 -> fsLit "llvm.ctlz.i64" + W128 -> fsLit "llvm.ctlz.i128" + W256 -> fsLit "llvm.ctlz.i256" + W512 -> fsLit "llvm.ctlz.i512" + MO_Ctz w -> case w of + W8 -> fsLit "llvm.cttz.i8" + W16 -> fsLit "llvm.cttz.i16" + W32 -> fsLit "llvm.cttz.i32" + W64 -> fsLit "llvm.cttz.i64" + W128 -> fsLit "llvm.cttz.i128" + W256 -> fsLit "llvm.cttz.i256" + W512 -> fsLit "llvm.cttz.i512" + MO_Pdep w + | isBmi2Enabled -> case w of + W8 -> fsLit "llvm.x86.bmi.pdep.8" + W16 -> fsLit "llvm.x86.bmi.pdep.16" + W32 -> fsLit "llvm.x86.bmi.pdep.32" + W64 -> fsLit "llvm.x86.bmi.pdep.64" + W128 -> fsLit "llvm.x86.bmi.pdep.128" + W256 -> fsLit "llvm.x86.bmi.pdep.256" + W512 -> fsLit "llvm.x86.bmi.pdep.512" + | otherwise -> case w of + W8 -> fsLit "hs_pdep8" + W16 -> fsLit "hs_pdep16" + W32 -> fsLit "hs_pdep32" + W64 -> fsLit "hs_pdep64" + W128 -> fsLit "hs_pdep128" + W256 -> fsLit "hs_pdep256" + W512 -> fsLit "hs_pdep512" + MO_Pext w + | isBmi2Enabled -> case w of + W8 -> fsLit "llvm.x86.bmi.pext.8" + W16 -> fsLit "llvm.x86.bmi.pext.16" + W32 -> fsLit "llvm.x86.bmi.pext.32" + W64 -> fsLit "llvm.x86.bmi.pext.64" + W128 -> fsLit "llvm.x86.bmi.pext.128" + W256 -> fsLit "llvm.x86.bmi.pext.256" + W512 -> fsLit "llvm.x86.bmi.pext.512" + | otherwise -> case w of + W8 -> fsLit "hs_pext8" + W16 -> fsLit "hs_pext16" + W32 -> fsLit "hs_pext32" + W64 -> fsLit "hs_pext64" + W128 -> fsLit "hs_pext128" + W256 -> fsLit "hs_pext256" + W512 -> fsLit "hs_pext512" + + MO_AddIntC w -> case w of + W8 -> fsLit "llvm.sadd.with.overflow.i8" + W16 -> fsLit "llvm.sadd.with.overflow.i16" + W32 -> fsLit "llvm.sadd.with.overflow.i32" + W64 -> fsLit "llvm.sadd.with.overflow.i64" + W128 -> fsLit "llvm.sadd.with.overflow.i128" + W256 -> fsLit "llvm.sadd.with.overflow.i256" + W512 -> fsLit "llvm.sadd.with.overflow.i512" + MO_SubIntC w -> case w of + W8 -> fsLit "llvm.ssub.with.overflow.i8" + W16 -> fsLit "llvm.ssub.with.overflow.i16" + W32 -> fsLit "llvm.ssub.with.overflow.i32" + W64 -> fsLit "llvm.ssub.with.overflow.i64" + W128 -> fsLit "llvm.ssub.with.overflow.i128" + W256 -> fsLit "llvm.ssub.with.overflow.i256" + W512 -> fsLit "llvm.ssub.with.overflow.i512" + MO_Add2 w -> case w of + W8 -> fsLit "llvm.uadd.with.overflow.i8" + W16 -> fsLit "llvm.uadd.with.overflow.i16" + W32 -> fsLit "llvm.uadd.with.overflow.i32" + W64 -> fsLit "llvm.uadd.with.overflow.i64" + W128 -> fsLit "llvm.uadd.with.overflow.i128" + W256 -> fsLit "llvm.uadd.with.overflow.i256" + W512 -> fsLit "llvm.uadd.with.overflow.i512" + MO_AddWordC w -> case w of + W8 -> fsLit "llvm.uadd.with.overflow.i8" + W16 -> fsLit "llvm.uadd.with.overflow.i16" + W32 -> fsLit "llvm.uadd.with.overflow.i32" + W64 -> fsLit "llvm.uadd.with.overflow.i64" + W128 -> fsLit "llvm.uadd.with.overflow.i128" + W256 -> fsLit "llvm.uadd.with.overflow.i256" + W512 -> fsLit "llvm.uadd.with.overflow.i512" + MO_SubWordC w -> case w of + W8 -> fsLit "llvm.usub.with.overflow.i8" + W16 -> fsLit "llvm.usub.with.overflow.i16" + W32 -> fsLit "llvm.usub.with.overflow.i32" + W64 -> fsLit "llvm.usub.with.overflow.i64" + W128 -> fsLit "llvm.usub.with.overflow.i128" + W256 -> fsLit "llvm.usub.with.overflow.i256" + W512 -> fsLit "llvm.usub.with.overflow.i512" + + + MO_Prefetch_Data _ -> fsLit "llvm.prefetch" + + MO_S_Mul2 {} -> unsupported + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the + -- appropriate case of genCall. + MO_U_Mul2 {} -> unsupported + + MO_VS_Quot {} -> unsupported + MO_VS_Rem {} -> unsupported + MO_VU_Quot {} -> unsupported + MO_VU_Rem {} -> unsupported + MO_I64X2_Min -> unsupported + MO_I64X2_Max -> unsupported + MO_W64X2_Min -> unsupported + MO_W64X2_Max -> unsupported + + MO_ReleaseFence -> unsupported + MO_AcquireFence -> unsupported + MO_SeqCstFence -> unsupported + + MO_Touch -> unsupported + MO_UF_Conv _ -> unsupported + + MO_AtomicRead _ _ -> unsupported + MO_AtomicRMW _ _ -> unsupported + MO_AtomicWrite _ _ -> unsupported + MO_Cmpxchg _ -> unsupported + MO_Xchg _ -> unsupported + + MO_I64_ToI -> dontReach64 + MO_I64_FromI -> dontReach64 + MO_W64_ToW -> dontReach64 + MO_W64_FromW -> dontReach64 + MO_x64_Neg -> dontReach64 + MO_x64_Add -> dontReach64 + MO_x64_Sub -> dontReach64 + MO_x64_Mul -> dontReach64 + MO_I64_Quot -> dontReach64 + MO_I64_Rem -> dontReach64 + MO_W64_Quot -> dontReach64 + MO_W64_Rem -> dontReach64 + MO_x64_And -> dontReach64 + MO_x64_Or -> dontReach64 + MO_x64_Xor -> dontReach64 + MO_x64_Not -> dontReach64 + MO_x64_Shl -> dontReach64 + MO_I64_Shr -> dontReach64 + MO_W64_Shr -> dontReach64 + MO_x64_Eq -> dontReach64 + MO_x64_Ne -> dontReach64 + MO_I64_Ge -> dontReach64 + MO_I64_Gt -> dontReach64 + MO_I64_Le -> dontReach64 + MO_I64_Lt -> dontReach64 + MO_W64_Ge -> dontReach64 + MO_W64_Gt -> dontReach64 + MO_W64_Le -> dontReach64 + MO_W64_Lt -> dontReach64 + + +-- | Tail function calls +genJump :: CmmExpr -> LiveGlobalRegUses -> LlvmM StmtData + +-- Call to known function +genJump (CmmLit (CmmLabel lbl)) live = do + (vf, stmts, top) <- getHsFunc live lbl + (stgRegs, stgStmts) <- funEpilogue live + let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs + let s2 = Return Nothing + return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) + + +-- Call to unknown function / address +genJump expr live = do + fty <- llvmFunTy live + (vf, stmts, top) <- exprToVar expr + + let cast = case getVarType vf of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + ty -> pprPanic "genJump: Expr is of bad type for function call! " + $ lparen <> ppr ty <> rparen + + (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) + (stgRegs, stgStmts) <- funEpilogue live + let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs + let s3 = Return Nothing + return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, + top) + + +-- | CmmAssign operation +-- +-- We use stack allocated variables for CmmReg. The optimiser will replace +-- these with registers when possible. +genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData +genAssign reg val = do + (vreg, ty) <- getCmmReg reg + (vval, stmts2, top2) <- exprToVar val + let stmts = stmts2 + platform <- getPlatform + case ty of + -- Some registers are pointer types, so need to cast value to pointer + LMPointer _ | getVarType vval == llvmWord platform -> do + (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty + let s2 = Store v vreg Nothing [] + return (stmts `snocOL` s1 `snocOL` s2, top2) + + LMVector _ _ -> do + (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty + let s2 = mkStore v vreg NaturallyAligned [] + return (stmts `snocOL` s1 `snocOL` s2, top2) + + _ -> do + let s1 = Store vval vreg Nothing [] + return (stmts `snocOL` s1, top2) + + +-- | CmmStore operation +genStore :: CmmExpr -> CmmExpr -> AlignmentSpec -> LlvmM StmtData + +-- First we try to detect a few common cases and produce better code for +-- these then the default case. We are mostly trying to detect Cmm code +-- like I32[Sp + n] and use 'getelementptr' operations instead of the +-- generic case that uses casts and pointer arithmetic +genStore addr@(CmmReg (CmmGlobal r)) val alignment + = genStore_fast addr r 0 val alignment + +genStore addr@(CmmRegOff (CmmGlobal r) n) val alignment + = genStore_fast addr r n val alignment + +genStore addr@(CmmMachOp (MO_Add _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + val alignment + = genStore_fast addr r (fromInteger n) val alignment + +genStore addr@(CmmMachOp (MO_Sub _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + val alignment + = genStore_fast addr r (negate $ fromInteger n) val alignment + +-- generic case +genStore addr val alignment + = getTBAAMeta topN >>= genStore_slow addr val alignment + +-- | CmmStore operation +-- This is a special case for storing to a global register pointer +-- offset such as I32[Sp+8]. +genStore_fast :: CmmExpr -> GlobalRegUse -> Int -> CmmExpr -> AlignmentSpec + -> LlvmM StmtData +genStore_fast addr r n val alignment + = do platform <- getPlatform + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta (globalRegUse_reg r) + let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8) + case isPointer grt && rem == 0 of + True -> do + (vval, stmts, top) <- exprToVar val + (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] + -- We might need a different pointer type, so check + case pLower grt == getVarType vval of + -- were fine + True -> do + let s3 = mkStore vval ptr alignment meta + return (stmts `appOL` s1 `snocOL` s2 + `snocOL` s3, top) + + -- cast to pointer type needed + False -> do + let ty = (pLift . getVarType) vval + (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty + let s4 = mkStore vval ptr' alignment meta + return (stmts `appOL` s1 `snocOL` s2 + `snocOL` s3 `snocOL` s4, top) + + -- If its a bit type then we use the slow method since + -- we can't avoid casting anyway. + False -> genStore_slow addr val alignment meta + + +-- | CmmStore operation +-- Generic case. Uses casts and pointer arithmetic if needed. +genStore_slow :: CmmExpr -> CmmExpr -> AlignmentSpec -> [MetaAnnot] -> LlvmM StmtData +genStore_slow addr val alignment meta = do + (vaddr, stmts1, top1) <- exprToVar addr + (vval, stmts2, top2) <- exprToVar val + + let stmts = stmts1 `appOL` stmts2 + platform <- getPlatform + cfg <- getConfig + case getVarType vaddr of + -- sometimes we need to cast an int to a pointer before storing + LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do + (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty + let s2 = mkStore v vaddr alignment meta + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + + LMPointer _ -> do + let s1 = mkStore vval vaddr alignment meta + return (stmts `snocOL` s1, top1 ++ top2) + + i@(LMInt _) | i == llvmWord platform -> do + let vty = pLift $ getVarType vval + (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty + let s2 = mkStore vval vptr alignment meta + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + + other -> + pprPanic "genStore: ptr not right type!" + (pdoc platform addr $$ + text "Size of Ptr:" <+> ppr (llvmPtrBits platform) $$ + text "Size of var:" <+> ppr (llvmWidthInBits platform other) $$ + text "Var:" <+> ppVar cfg vaddr) + +mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement +mkStore vval vptr alignment metas = + Store vval vptr align metas + where + ty = pLower (getVarType vptr) + align = case alignment of + -- See Note [Alignment of vector-typed values] + _ | isVector ty -> Just 1 + Unaligned -> Just 1 + NaturallyAligned -> Nothing + +-- | Unconditional branch +genBranch :: BlockId -> LlvmM StmtData +genBranch id = + let label = blockIdToLlvm id + in return (unitOL $ Branch label, []) + + +-- | Conditional branch +genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData +genCondBranch cond idT idF likely = do + let labelT = blockIdToLlvm idT + let labelF = blockIdToLlvm idF + -- See Note [Literals and branch conditions]. + (vc, stmts1, top1) <- exprToVarOpt i1Option cond + if getVarType vc == i1 + then do + (vc', (stmts2, top2)) <- case likely of + Just b -> genExpectLit (if b then 1 else 0) i1 vc + _ -> pure (vc, (nilOL, [])) + let s1 = BranchIf vc' labelT labelF + return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) + else do + cfg <- getConfig + pprPanic "genCondBranch: Cond expr not bool! " $ + lparen <> ppVar cfg vc <> rparen + + +-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var. +genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData) +genExpectLit expLit expTy var = do + cfg <- getConfig + + let + lit = LMLitVar $ LMIntLit expLit expTy + + llvmExpectName + | isInt expTy = fsLit $ "llvm.expect." ++ showSDocOneLine (llvmCgContext cfg) (ppr expTy) + | otherwise = panic "genExpectedLit: Type not an int!" + + (llvmExpect, stmts, top) <- + getInstrinct llvmExpectName expTy [expTy, expTy] + (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] [] + return (var', (stmts `snocOL` call, top)) + +{- Note [Literals and branch conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is important that whenever we generate branch conditions for +literals like '1', they are properly narrowed to an LLVM expression of +type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert +a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt +must be certain to return a properly narrowed type. genLit is +responsible for this, in the case of literal integers. + +Often, we won't see direct statements like: + + if(1) { + ... + } else { + ... + } + +at this point in the pipeline, because the Glorious Code Generator +will do trivial branch elimination in the sinking pass (among others,) +which will eliminate the expression entirely. + +However, it's certainly possible and reasonable for this to occur in +hand-written C-- code. Consider something like: + + #if !defined(SOME_CONDITIONAL) + #define CHECK_THING(x) 1 + #else + #define CHECK_THING(x) some_operation((x)) + #endif + + f() { + + if (CHECK_THING(xyz)) { + ... + } else { + ... + } + + } + +In such an instance, CHECK_THING might result in an *expression* in +one case, and a *literal* in the other, depending on what in +particular was #define'd. So we must be sure to properly narrow the +literal in this case to i1 as it won't be eliminated beforehand. + +For a real example of this, see ./rts/StgStdThunks.cmm + +-} + + + +-- | Switch branch +genSwitch :: UnreachableBlockId -> CmmExpr -> SwitchTargets -> LlvmM StmtData +genSwitch (UnreachableBlockId ubid) cond ids = do + (vc, stmts, top) <- exprToVar cond + let ty = getVarType vc + + let labels = [ (mkIntLit ty ix, blockIdToLlvm b) + | (ix, b) <- switchTargetsCases ids ] + let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l + | otherwise = blockIdToLlvm ubid + -- switch to an unreachable basic block for exhaustive + -- switches. See Note [Unreachable block as default destination + -- in Switch] + + let s1 = Switch vc defLbl labels + return $ (stmts `snocOL` s1, top) + + +-- Note [Unreachable block as default destination in Switch] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- LLVM IR requires a default destination (a block label) for its Switch +-- operation, even if the switch is exhaustive. An LLVM switch is considered +-- exhausitve (e.g. to omit range checks for bit tests [1]) if the default +-- destination is unreachable. +-- +-- When we codegen a Cmm function, we always reserve an unreachable basic block +-- that is used as a default destination for exhaustive Cmm switches in +-- genSwitch. See #24717 +-- +-- [1] https://reviews.llvm.org/D68131 + + + +-- ----------------------------------------------------------------------------- +-- * CmmExpr code generation +-- + +-- | An expression conversion return data: +-- * LlvmVar: The var holding the result of the expression +-- * LlvmStatements: Any statements needed to evaluate the expression +-- * LlvmCmmDecl: Any global data needed for this expression +type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl]) + +-- | Values which can be passed to 'exprToVar' to configure its +-- behaviour in certain circumstances. +-- +-- Currently just used for determining if a comparison should return +-- a boolean (i1) or a word. See Note [Literals and branch conditions]. +newtype EOption = EOption { i1Expected :: Bool } +-- XXX: EOption is an ugly and inefficient solution to this problem. + +-- | i1 type expected (condition scrutinee). +i1Option :: EOption +i1Option = EOption True + +-- | Word type expected (usual). +wordOption :: EOption +wordOption = EOption False + +-- | Convert a CmmExpr to a list of LlvmStatements with the result of the +-- expression being stored in the returned LlvmVar. +exprToVar :: CmmExpr -> LlvmM ExprData +exprToVar = exprToVarOpt wordOption + +exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData +exprToVarOpt opt e = case e of + + CmmLit lit + -> genLit opt lit + + CmmLoad e' ty align + -> genLoad Nothing e' ty align + + -- Cmmreg in expression is the value, so must load. If you want actual + -- reg pointer, call getCmmReg directly. + CmmReg r -> do + (v1, ty, s1) <- getCmmRegVal r + case isPointer ty of + True -> do + -- Cmm wants the value, so pointer types must be cast to ints + platform <- getPlatform + (v2, s2) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint v1 (llvmWord platform) + return (v2, s1 `snocOL` s2, []) + + False -> return (v1, s1, []) + + CmmMachOp op exprs + -> genMachOp opt op exprs + + CmmRegOff r i + -> exprToVar $ expandCmmReg (r, i) + + CmmStackSlot _ _ + -> panic "exprToVar: CmmStackSlot not supported!" + + +-- | Handle CmmMachOp expressions +genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData + +-- Unary Machop +genMachOp _ op [x] = case op of + + MO_Not w -> + let all1 = mkIntLit (widthToLlvmInt w) (-1) + in negate (widthToLlvmInt w) all1 LM_MO_Xor + + MO_S_Neg w -> + let all0 = mkIntLit (widthToLlvmInt w) 0 + in negate (widthToLlvmInt w) all0 LM_MO_Sub + + MO_F_Neg w -> + let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w) + in negate (widthToLlvmFloat w) all0 LM_MO_FSub + + MO_SF_Round _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp + MO_FS_Truncate _ w -> fiConv (widthToLlvmInt w) LM_Fptosi + + MO_SS_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext + + MO_UU_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext + + MO_XX_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext + + MO_FF_Conv from to + -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext + + MO_WF_Bitcast w -> fiConv (widthToLlvmFloat w) LM_Bitcast + MO_FW_Bitcast w -> fiConv (widthToLlvmInt w) LM_Bitcast + + MO_VS_Neg len w -> + let ty = widthToLlvmInt w + vecty = LMVector len ty + all0 = LMIntLit (-0) ty + all0s = LMLitVar $ LMVectorLit (replicate len all0) + in negateVec vecty all0s LM_MO_Sub + + MO_VF_Neg len w -> + let ty = widthToLlvmFloat w + vecty = LMVector len ty + all0 = LMFloatLit (-0) ty + all0s = LMLitVar $ LMVectorLit (replicate len all0) + in negateVec vecty all0s LM_MO_FSub + + MO_V_Broadcast l w -> genBroadcastOp l w x + MO_VF_Broadcast l w -> genBroadcastOp l w x + + MO_RelaxedRead w -> exprToVar (CmmLoad x (cmmBits w) NaturallyAligned) + + MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm" + + -- Handle unsupported cases explicitly so we get a warning + -- of missing case when new MachOps added + MO_Add _ -> panicOp + MO_Mul _ -> panicOp + MO_Sub _ -> panicOp + MO_S_MulMayOflo _ -> panicOp + MO_S_Quot _ -> panicOp + MO_S_Rem _ -> panicOp + MO_U_Quot _ -> panicOp + MO_U_Rem _ -> panicOp + + MO_Eq _ -> panicOp + MO_Ne _ -> panicOp + MO_S_Ge _ -> panicOp + MO_S_Gt _ -> panicOp + MO_S_Le _ -> panicOp + MO_S_Lt _ -> panicOp + MO_U_Ge _ -> panicOp + MO_U_Gt _ -> panicOp + MO_U_Le _ -> panicOp + MO_U_Lt _ -> panicOp + + MO_F_Add _ -> panicOp + MO_F_Sub _ -> panicOp + MO_F_Mul _ -> panicOp + MO_F_Quot _ -> panicOp + MO_F_Min _ -> panicOp + MO_F_Max _ -> panicOp + + MO_FMA _ _ _ -> panicOp + + MO_F_Eq _ -> panicOp + MO_F_Ne _ -> panicOp + MO_F_Ge _ -> panicOp + MO_F_Gt _ -> panicOp + MO_F_Le _ -> panicOp + MO_F_Lt _ -> panicOp + + MO_And _ -> panicOp + MO_Or _ -> panicOp + MO_Xor _ -> panicOp + MO_Shl _ -> panicOp + MO_U_Shr _ -> panicOp + MO_S_Shr _ -> panicOp + + MO_V_Insert _ _ -> panicOp + MO_V_Extract _ _ -> panicOp + + MO_V_Add _ _ -> panicOp + MO_V_Sub _ _ -> panicOp + MO_V_Mul _ _ -> panicOp + + MO_VS_Min _ _ -> panicOp + MO_VS_Max _ _ -> panicOp + + MO_VU_Min _ _ -> panicOp + MO_VU_Max _ _ -> panicOp + + MO_VF_Insert _ _ -> panicOp + MO_VF_Extract _ _ -> panicOp + + MO_V_Shuffle {} -> panicOp + MO_VF_Shuffle {} -> panicOp + + MO_VF_Add _ _ -> panicOp + MO_VF_Sub _ _ -> panicOp + MO_VF_Mul _ _ -> panicOp + MO_VF_Quot _ _ -> panicOp + MO_VF_Min _ _ -> panicOp + MO_VF_Max _ _ -> panicOp + + where + negate ty v2 negOp = do + (vx, stmts, top) <- exprToVar x + (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx + return (v1, stmts `snocOL` s1, top) + + negateVec ty v2 negOp = do + (vx, stmts1, top) <- exprToVar x + (vxs', stmts2) <- castVars Signed [(vx, ty)] + let vx' = singletonPanic "genMachOp: negateVec" vxs' + (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx' + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top) + + fiConv ty convOp = do + (vx, stmts, top) <- exprToVar x + (v1, s1) <- doExpr ty $ Cast convOp vx ty + return (v1, stmts `snocOL` s1, top) + + sameConv from ty reduce expand = do + x'@(vx, stmts, top) <- exprToVar x + let sameConv' op = do + (v1, s1) <- doExpr ty $ Cast op vx ty + return (v1, stmts `snocOL` s1, top) + platform <- getPlatform + let toWidth = llvmWidthInBits platform ty + -- LLVM doesn't like trying to convert to same width, so + -- need to check for that as we do get Cmm code doing it. + case widthInBits from of + w | w < toWidth -> sameConv' expand + w | w > toWidth -> sameConv' reduce + _w -> return x' + + panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered" + ++ "with one argument! (" ++ show op ++ ")" + +-- Handle GlobalRegs pointers +genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (fromInteger n) e + +genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (negate . fromInteger $ n) e + +-- Generic case +genMachOp opt op e = genMachOp_slow opt op e + + +-- | Handle CmmMachOp expressions +-- This is a specialised method that handles Global register manipulations like +-- 'Sp - 16', using the getelementptr instruction. +genMachOp_fast :: EOption -> MachOp -> GlobalRegUse -> Int -> [CmmExpr] + -> LlvmM ExprData +genMachOp_fast opt op r n e + = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + platform <- getPlatform + let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8) + case isPointer grt && rem == 0 of + True -> do + (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] + (var, s3) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint ptr (llvmWord platform) + return (var, s1 `snocOL` s2 `snocOL` s3, []) + + False -> genMachOp_slow opt op e + + +-- | Handle CmmMachOp expressions +-- This handles all the cases not handle by the specialised genMachOp_fast. +genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData + +-- Element extraction +genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do + vval <- exprToVarW val + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, LMVector l ty)] + doExprW ty $ Extract vval' vidx + where + ty = widthToLlvmInt w + +genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do + vval <- exprToVarW val + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, LMVector l ty)] + doExprW ty $ Extract vval' vidx + where + ty = widthToLlvmFloat w + +-- Element insertion +genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do + vval <- exprToVarW val + velt <- exprToVarW elt + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, ty)] + doExprW ty $ Insert vval' velt vidx + where + ty = LMVector l (widthToLlvmInt w) + +genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do + vval <- exprToVarW val + velt <- exprToVarW elt + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, ty)] + doExprW ty $ Insert vval' velt vidx + where + ty = LMVector l (widthToLlvmFloat w) + +-- Binary MachOp +genMachOp_slow opt op [x, y] = case op of + + MO_Eq _ -> genBinComp opt LM_CMP_Eq + MO_Ne _ -> genBinComp opt LM_CMP_Ne + + MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt + MO_S_Ge _ -> genBinComp opt LM_CMP_Sge + MO_S_Lt _ -> genBinComp opt LM_CMP_Slt + MO_S_Le _ -> genBinComp opt LM_CMP_Sle + + MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt + MO_U_Ge _ -> genBinComp opt LM_CMP_Uge + MO_U_Lt _ -> genBinComp opt LM_CMP_Ult + MO_U_Le _ -> genBinComp opt LM_CMP_Ule + + MO_Add _ -> genBinMach LM_MO_Add + MO_Sub _ -> genBinMach LM_MO_Sub + MO_Mul _ -> genBinMach LM_MO_Mul + + MO_S_MulMayOflo w -> isSMulOK w x y + + MO_S_Quot _ -> genBinMach LM_MO_SDiv + MO_S_Rem _ -> genBinMach LM_MO_SRem + + MO_U_Quot _ -> genBinMach LM_MO_UDiv + MO_U_Rem _ -> genBinMach LM_MO_URem + + MO_F_Eq _ -> genBinComp opt LM_CMP_Feq + MO_F_Ne _ -> genBinComp opt LM_CMP_Fne + MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt + MO_F_Ge _ -> genBinComp opt LM_CMP_Fge + MO_F_Lt _ -> genBinComp opt LM_CMP_Flt + MO_F_Le _ -> genBinComp opt LM_CMP_Fle + + MO_F_Add _ -> genBinMach LM_MO_FAdd + MO_F_Sub _ -> genBinMach LM_MO_FSub + MO_F_Mul _ -> genBinMach LM_MO_FMul + MO_F_Quot _ -> genBinMach LM_MO_FDiv + + MO_FMA _ _ _ -> panicOp + + MO_And _ -> genBinMach LM_MO_And + MO_Or _ -> genBinMach LM_MO_Or + MO_Xor _ -> genBinMach LM_MO_Xor + MO_Shl _ -> genBinCastYMach LM_MO_Shl + MO_U_Shr _ -> genBinCastYMach LM_MO_LShr + MO_S_Shr _ -> genBinCastYMach LM_MO_AShr + + MO_V_Add l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add + MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub + MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul + + MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd + MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub + MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul + MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv + + MO_Not _ -> panicOp + MO_S_Neg _ -> panicOp + MO_F_Neg _ -> panicOp + + MO_SF_Round _ _ -> panicOp + MO_FS_Truncate _ _ -> panicOp + MO_SS_Conv _ _ -> panicOp + MO_UU_Conv _ _ -> panicOp + MO_XX_Conv _ _ -> panicOp + MO_FF_Conv _ _ -> panicOp + + MO_WF_Bitcast _to -> panicOp + MO_FW_Bitcast _to -> panicOp + + MO_VS_Neg {} -> panicOp + + MO_VF_Broadcast {} -> panicOp + MO_V_Broadcast {} -> panicOp + MO_V_Insert {} -> panicOp + MO_VF_Insert {} -> panicOp + + MO_V_Shuffle _ _ is -> genShuffleOp is x y + MO_VF_Shuffle _ _ is -> genShuffleOp is x y + + MO_VF_Neg {} -> panicOp + + -- Min/max + MO_F_Min {} -> genMinMaxOp "minnum" x y + MO_F_Max {} -> genMinMaxOp "maxnum" x y + MO_VF_Min {} -> genMinMaxOp "minnum" x y + MO_VF_Max {} -> genMinMaxOp "maxnum" x y + MO_VU_Min {} -> genMinMaxOp "umin" x y + MO_VU_Max {} -> genMinMaxOp "umax" x y + MO_VS_Min {} -> genMinMaxOp "smin" x y + MO_VS_Max {} -> genMinMaxOp "smax" x y + + MO_RelaxedRead {} -> panicOp + + MO_AlignmentCheck {} -> panicOp + + where + binLlvmOp ty binOp allow_y_cast = do + platform <- getPlatform + runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + + if | getVarType vx == getVarType vy + -> doExprW (ty vx) $ binOp vx vy + + | allow_y_cast + -> do + vy' <- singletonPanic "binLlvmOp cast"<$> + castVarsW Signed [(vy, (ty vx))] + doExprW (ty vx) $ binOp vx vy' + + | otherwise + -> pprPanic "binLlvmOp types" (pdoc platform x $$ pdoc platform y) + + binCastLlvmOp ty binOp = runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + vxy' <- castVarsW Signed [(vx, ty), (vy, ty)] + case vxy' of + [vx',vy'] -> doExprW ty $ binOp vx' vy' + _ -> panic "genMachOp_slow: binCastLlvmOp" + + -- Need to use EOption here as Cmm expects word size results from + -- comparisons while LLVM return i1. Need to extend to llvmWord type + -- if expected. See Note [Literals and branch conditions]. + genBinComp opt cmp = do + ed@(v1, stmts, top) <- binLlvmOp (const i1) (Compare cmp) False + platform <- getPlatform + if getVarType v1 == i1 + then case i1Expected opt of + True -> return ed + False -> do + let w_ = llvmWord platform + (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_ + return (v2, stmts `snocOL` s1, top) + else + pprPanic "genBinComp: Compare returned type other then i1! " + (ppr $ getVarType v1) + + genBinMach op = binLlvmOp getVarType (LlvmOp op) False + + genBinCastYMach op = binLlvmOp getVarType (LlvmOp op) True + + genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op) + + genMinMaxOp intrin x y = runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + let tx = getVarType vx + ty = getVarType vy + fname = "llvm." ++ intrin ++ "." ++ ppLlvmTypeShort ty + Panic.massertPpr + (tx == ty) + (vcat [ text (fname ++ ": mismatched arg types") + , ppLlvmType tx, ppLlvmType ty ]) + fptr <- liftExprData $ getInstrinct (fsLit fname) ty [tx, ty] + doExprW tx $ Call StdCall fptr [vx, vy] [ReadNone, NoUnwind] + + -- Detect if overflow will occur in signed multiply of the two + -- CmmExpr's. This is the LLVM assembly equivalent of the NCG + -- implementation. Its much longer due to type information/safety. + -- This should actually compile to only about 3 asm instructions. + isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData + isSMulOK _ x y = do + platform <- getPlatform + runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + + let word = getVarType vx + let word2 = LMInt $ 2 * llvmWidthInBits platform (getVarType vx) + let shift = llvmWidthInBits platform word + let shift1 = toIWord platform (shift - 1) + let shift2 = toIWord platform shift + + if isInt word + then do + x1 <- doExprW word2 $ Cast LM_Sext vx word2 + y1 <- doExprW word2 $ Cast LM_Sext vy word2 + r1 <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1 + rlow1 <- doExprW word $ Cast LM_Trunc r1 word + rlow2 <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1 + rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2 + rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word + doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2 + + else + pprPanic "isSMulOK: Not bit type! " $ + lparen <> ppr word <> rparen + + panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-binary op encountered " + ++ "with two arguments! (" ++ show op ++ ")" + +genMachOp_slow _opt op [x, y, z] = do + let + panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered " + ++ "with three arguments! (" ++ show op ++ ")" + case op of + MO_FMA var lg width -> + case var of + -- LLVM only has the fmadd variant. + FMAdd -> genFmaOp x y z + -- Other fused multiply-add operations are implemented in terms of fmadd + -- This is sound: it does not lose any precision. + FMSub -> genFmaOp x y (neg z) + FNMAdd -> genFmaOp (neg x) y z + FNMSub -> genFmaOp (neg x) y (neg z) + where + neg x + | lg == 1 + = CmmMachOp (MO_F_Neg width) [x] + | otherwise + = CmmMachOp (MO_VF_Neg lg width) [x] + _ -> panicOp + +-- More than three expressions, invalid! +genMachOp_slow _ _ _ = panic "genMachOp_slow: More than 3 expressions in MachOp!" + +genBroadcastOp :: Int -> Width -> CmmExpr -> LlvmM ExprData +genBroadcastOp lg _width x = runExprData $ do + -- To broadcast a scalar x as a vector v: + -- 1. insert x at the 0 position of the zero vector + -- 2. shuffle x into all positions + var_x <- exprToVarW x + let tx = getVarType var_x + tv = LMVector lg tx + z = if isFloat tx + then LMFloatLit 0 tx + else LMIntLit 0 tx + zs = LMLitVar $ LMVectorLit $ replicate lg z + w <- doExprW tv $ Insert zs var_x (LMLitVar $ LMIntLit 0 (LMInt 32)) + doExprW tv $ Shuffle w w (replicate lg 0) + +genShuffleOp :: [Int] -> CmmExpr -> CmmExpr -> LlvmM ExprData +genShuffleOp is x y = runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + let tx = getVarType vx + ty = getVarType vy + Panic.massertPpr + (tx == ty) + (vcat [ text "shuffle: mismatched arg types" + , ppLlvmType tx, ppLlvmType ty ]) + doExprW tx $ Shuffle vx vy is + +-- | Generate code for a fused multiply-add operation. +genFmaOp :: CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData +genFmaOp x y z = runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + vz <- exprToVarW z + let tx = getVarType vx + ty = getVarType vy + tz = getVarType vz + Panic.massertPpr + (tx == ty && tx == tz) + (vcat [ text "fma: mismatched arg types" + , ppLlvmType tx, ppLlvmType ty, ppLlvmType tz ]) + let fname = case tx of + LMFloat -> fsLit "llvm.fma.f32" + LMDouble -> fsLit "llvm.fma.f64" + LMVector 4 LMFloat -> fsLit "llvm.fma.v4f32" + LMVector 8 LMFloat -> fsLit "llvm.fma.v8f32" + LMVector 16 LMFloat -> fsLit "llvm.fma.v16f32" + LMVector 2 LMDouble -> fsLit "llvm.fma.v2f64" + LMVector 4 LMDouble -> fsLit "llvm.fma.v4f64" + LMVector 8 LMDouble -> fsLit "llvm.fma.v8f64" + _ -> pprPanic "CmmToLlvm.genFmaOp: unsupported type" (ppLlvmType tx) + fptr <- liftExprData $ getInstrinct fname ty [tx, ty, tz] + doExprW tx $ Call StdCall fptr [vx, vy, vz] [ReadNone, NoUnwind] + +-- | Handle CmmLoad expression. +genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData + +-- First we try to detect a few common cases and produce better code for +-- these then the default case. We are mostly trying to detect Cmm code +-- like I32[Sp + n] and use 'getelementptr' operations instead of the +-- generic case that uses casts and pointer arithmetic +genLoad atomic e@(CmmReg (CmmGlobal r)) ty align + = genLoad_fast atomic e r 0 ty align + +genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty align + = genLoad_fast atomic e r n ty align + +genLoad atomic e@(CmmMachOp (MO_Add _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty align + = genLoad_fast atomic e r (fromInteger n) ty align + +genLoad atomic e@(CmmMachOp (MO_Sub _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty align + = genLoad_fast atomic e r (negate $ fromInteger n) ty align + +-- generic case +genLoad atomic e ty align + = getTBAAMeta topN >>= genLoad_slow atomic e ty align + +-- | Handle CmmLoad expression. +-- This is a special case for loading from a global register pointer +-- offset such as I32[Sp+8]. +genLoad_fast :: Atomic -> CmmExpr -> GlobalRegUse -> Int -> CmmType + -> AlignmentSpec -> LlvmM ExprData +genLoad_fast atomic e r n ty align = do + platform <- getPlatform + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta (globalRegUse_reg r) + let ty' = cmmToLlvmType ty + (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8) + case isPointer grt && rem == 0 of + True -> do + (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] + -- We might need a different pointer type, so check + case grt == ty' of + -- were fine + True -> do + (var, s3) <- doExpr ty' (MExpr meta $ mkLoad atomic ptr align) + return (var, s1 `snocOL` s2 `snocOL` s3, + []) + + -- cast to pointer type needed + False -> do + let pty = pLift ty' + (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty + (var, s4) <- doExpr ty' (MExpr meta $ mkLoad atomic ptr' align) + return (var, s1 `snocOL` s2 `snocOL` s3 + `snocOL` s4, []) + + -- If its a bit type then we use the slow method since + -- we can't avoid casting anyway. + False -> genLoad_slow atomic e ty align meta + +-- | Handle Cmm load expression. +-- Generic case. Uses casts and pointer arithmetic if needed. +genLoad_slow :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> [MetaAnnot] + -> LlvmM ExprData +genLoad_slow atomic e ty align meta = do + platform <- getPlatform + cfg <- getConfig + runExprData $ do + iptr <- exprToVarW e + case getVarType iptr of + LMPointer _ -> + doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic iptr align) + + i@(LMInt _) | i == llvmWord platform -> do + let pty = LMPointer $ cmmToLlvmType ty + ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty + doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic ptr align) + + other -> pprPanic "exprToVar: CmmLoad expression is not right type!" + (pdoc platform e $$ + text "Size of Ptr:" <+> ppr (llvmPtrBits platform) $$ + text "Size of var:" <+> ppr (llvmWidthInBits platform other) $$ + text "Var:" <+> (ppVar cfg iptr)) + +{- +Note [Alignment of vector-typed values] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On x86, vector types need to be 16-byte aligned for aligned +access, but we have no way of guaranteeing that this is true with GHC +(we would need to modify the layout of the stack and closures, change +the storage manager, etc.). So, we blindly tell LLVM that *any* vector +store or load could be unaligned. In the future we may be able to +guarantee that certain vector access patterns are aligned, in which +case we will need a more granular way of specifying alignment. +-} + +mkLoad :: Atomic -> LlvmVar -> AlignmentSpec -> LlvmExpression +mkLoad atomic vptr alignment + | Just mem_ord <- atomic + = ALoad (convertMemoryOrdering mem_ord) False vptr + | otherwise = Load vptr align + where + ty = pLower (getVarType vptr) + align = case alignment of + -- See Note [Alignment of vector-typed values] + _ | isVector ty -> Just 1 + Unaligned -> Just 1 + NaturallyAligned -> Nothing + +-- | Handle CmmReg expression. This will return a pointer to the stack +-- location of the register. Throws an error if it isn't allocated on +-- the stack. +getCmmReg :: CmmReg -> LlvmM (LlvmVar, LlvmType) +getCmmReg (CmmLocal (LocalReg un _)) + = do exists <- varLookup un + case exists of + Just ety -> return (LMLocalVar un $ pLift ety, ety) + Nothing -> pprPanic "getCmmReg: Cmm register " $ + ppr un <> text " was not allocated!" + -- This should never happen, as every local variable should + -- have been assigned a value at some point, triggering + -- "funPrologue" to allocate it on the stack. + +getCmmReg (CmmGlobal (GlobalRegUse reg _reg_ty)) + = do onStack <- checkStackReg reg + platform <- getPlatform + case onStack of + Just stack_ty -> do + let var = lmGlobalRegVar platform (GlobalRegUse reg stack_ty) + return (var, pLower $ getVarType var) + Nothing -> + pprPanic "getCmmReg: Cmm register " $ + ppr reg <> text " not stack-allocated!" + +-- | Return the value of a given register, as well as its type. Might +-- need to be load from stack. +getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) +getCmmRegVal reg = + case reg of + CmmGlobal gu@(GlobalRegUse g _) -> do + onStack <- checkStackReg g + platform <- getPlatform + case onStack of + Just {} -> + loadFromStack + Nothing -> do + let r = lmGlobalRegArg platform gu + return (r, getVarType r, nilOL) + _ -> loadFromStack + where + loadFromStack = do + platform <- getPlatform + (ptr, stack_reg_ty) <- getCmmReg reg + let reg_ty = case reg of + CmmGlobal g -> pLower $ getVarType $ lmGlobalRegVar platform g + CmmLocal {} -> stack_reg_ty + if reg_ty /= stack_reg_ty + then do + (v1, s1) <- doExpr stack_reg_ty (Load ptr Nothing) + (v2, s2) <- doExpr reg_ty (Cast LM_Bitcast v1 reg_ty) + return (v2, reg_ty, toOL [s1, s2]) + else do + (v, s) <- doExpr reg_ty (Load ptr Nothing) + return (v, reg_ty, unitOL s) + +-- | Allocate a local CmmReg on the stack +allocReg :: CmmReg -> (LlvmVar, LlvmStatements) +allocReg (CmmLocal (LocalReg un ty)) + = let ty' = cmmToLlvmType ty + var = LMLocalVar un (LMPointer ty') + alc = Alloca ty' 1 + in (var, unitOL $ Assignment var alc) + +allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" + ++ " have been handled elsewhere!" + + +-- | Generate code for a literal +genLit :: EOption -> CmmLit -> LlvmM ExprData +genLit opt (CmmInt i w) + -- See Note [Literals and branch conditions]. + = let width | i1Expected opt = i1 + | otherwise = LMInt (widthInBits w) + -- comm = Comment [ fsLit $ "EOption: " ++ show opt + -- , fsLit $ "Width : " ++ show w + -- , fsLit $ "Width' : " ++ show (widthInBits w) + -- ] + in return (mkIntLit width i, nilOL, []) + +genLit _ (CmmFloat r W32) + = return (LMLitVar $ LMFloatLit (widenFp (fromRational r :: Float)) (widthToLlvmFloat W32), + nilOL, []) + +genLit _ (CmmFloat r W64) + = return (LMLitVar $ LMFloatLit (fromRational r :: Double) (widthToLlvmFloat W64), + nilOL, []) + +genLit _ (CmmFloat _r _w) + = panic "genLit (CmmLit:CmmFloat), unsupported float lit" + +genLit opt (CmmVec ls) + = do llvmLits <- mapM toLlvmLit ls + return (LMLitVar $ LMVectorLit llvmLits, nilOL, []) + where + toLlvmLit :: CmmLit -> LlvmM LlvmLit + toLlvmLit lit = do + (llvmLitVar, _, _) <- genLit opt lit + case llvmLitVar of + LMLitVar llvmLit -> return llvmLit + _ -> panic "genLit" + +genLit _ cmm@(CmmLabel l) + = do var <- getGlobalPtr =<< strCLabel_llvm l + platform <- getPlatform + let lmty = cmmToLlvmType $ cmmLitType platform cmm + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord platform) + return (v1, unitOL s1, []) + +genLit opt (CmmLabelOff label off) = do + platform <- getPlatform + (vlbl, stmts, stat) <- genLit opt (CmmLabel label) + let voff = toIWord platform off + (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff + return (v1, stmts `snocOL` s1, stat) + +genLit opt (CmmLabelDiffOff l1 l2 off w) = do + platform <- getPlatform + (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1) + (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2) + let voff = toIWord platform off + let ty1 = getVarType vl1 + let ty2 = getVarType vl2 + if (isInt ty1) && (isInt ty2) + && (llvmWidthInBits platform ty1 == llvmWidthInBits platform ty2) + then do + (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 + (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff + let ty = widthToLlvmInt w + let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2 + if w /= wordWidth platform + then do + (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty + return (v3, stmts `snocOL` s3, stat1 ++ stat2) + else + return (v2, stmts, stat1 ++ stat2) + else + panic "genLit: CmmLabelDiffOff encountered with different label ty!" + +genLit opt (CmmBlock b) + = genLit opt (CmmLabel $ infoTblLbl b) + +genLit _ CmmHighStackMark + = panic "genStaticLit - CmmHighStackMark unsupported!" + + +-- ----------------------------------------------------------------------------- +-- * Misc +-- + +convertMemoryOrdering :: MemoryOrdering -> LlvmSyncOrdering +convertMemoryOrdering MemOrderRelaxed = SyncMonotonic +convertMemoryOrdering MemOrderAcquire = SyncAcquire +convertMemoryOrdering MemOrderRelease = SyncRelease +convertMemoryOrdering MemOrderSeqCst = SyncSeqCst + +-- | Find CmmRegs that get assigned and allocate them on the stack +-- +-- Any register that gets written needs to be allocated on the +-- stack. This avoids having to map a CmmReg to an equivalent SSA form +-- and avoids having to deal with Phi node insertion. This is also +-- the approach recommended by LLVM developers. +-- +-- On the other hand, this is unnecessarily verbose if the register in +-- question is never written. Therefore we skip it where we can to +-- save a few lines in the output and hopefully speed compilation up a +-- bit. +funPrologue :: LiveGlobalRegUses -> NonEmpty CmmBlock -> LlvmM StmtData +funPrologue live cmmBlocks = do + platform <- getPlatform + + let getAssignedRegs :: CmmNode O O -> [CmmReg] + getAssignedRegs (CmmAssign reg _) = [reg] + getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmLocal rs + getAssignedRegs _ = [] + getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body + assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks + mbLive r = + lookupRegUse r (alwaysLive platform) <|> lookupRegUse r live + + platform <- getPlatform + stmtss <- forM assignedRegs $ \reg -> + case reg of + CmmLocal (LocalReg un _) -> do + let (newv, stmts) = allocReg reg + varInsert un (pLower $ getVarType newv) + return stmts + CmmGlobal ru@(GlobalRegUse r ty0) -> do + let reg = lmGlobalRegVar platform ru + ty = (pLower . getVarType) reg + trash = LMLitVar $ LMUndefLit ty + rval = case mbLive r of + Just (GlobalRegUse _ ty') -> + lmGlobalRegArg platform (GlobalRegUse r ty') + _ -> trash + alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 + markStackReg ru + case mbLive r of + Just (GlobalRegUse _ ty') + | let llvm_ty = cmmToLlvmType ty0 + llvm_ty' = cmmToLlvmType ty' + , llvm_ty /= llvm_ty' + -> do castV <- mkLocalVar (pLift llvm_ty') + return $ + toOL [ alloc + , Assignment castV $ Cast LM_Bitcast reg (pLift llvm_ty') + , Store rval castV Nothing [] + ] + _ -> + return $ toOL [alloc, Store rval reg Nothing []] + + return (concatOL stmtss `snocOL` jumpToEntry, []) + where + entryBlk :| _ = cmmBlocks + jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk) + +-- | Function epilogue. Load STG variables to use as argument for call. +-- STG Liveness optimisation done here. +funEpilogue :: LiveGlobalRegUses -> LlvmM ([LlvmVar], LlvmStatements) +funEpilogue live = do + platform <- getPlatform + + let paddingRegs = padLiveArgs platform live + + -- Set to value or "undef" depending on whether the register is + -- actually live + let loadExpr r = do + (v, _, s) <- getCmmRegVal (CmmGlobal r) + return (Just $ v, s) + loadUndef r = do + let ty = (pLower . getVarType $ lmGlobalRegVar platform r) + return (Just $ LMLitVar $ LMUndefLit ty, nilOL) + + -- Note that floating-point registers in `activeStgRegs` must be sorted + -- according to the calling convention. + -- E.g. for X86: + -- GOOD: F1,D1,XMM1,F2,D2,XMM2,... + -- BAD : F1,F2,F3,D1,D2,D3,XMM1,XMM2,XMM3,... + -- As Fn, Dn and XMMn use the same register (XMMn) to be passed, we don't + -- want to pass F2 before D1 for example, otherwise we could get F2 -> XMM1 + -- and D1 -> XMM2. + let allRegs = activeStgRegs platform + loads <- forM allRegs $ \r -> if + -- load live registers + | Just ru <- lookupRegUse r (alwaysLive platform) + -> loadExpr ru + | Just ru <- lookupRegUse r live + -> loadExpr ru + -- load all non Floating-Point Registers + | not (isFPR r) + -> loadUndef (GlobalRegUse r (globalRegSpillType platform r)) + -- load padding Floating-Point Registers + | Just ru <- lookupRegUse r paddingRegs + -> loadUndef ru + | otherwise -> return (Nothing, nilOL) + + let (vars, stmts) = unzip loads + return (catMaybes vars, concatOL stmts) + +-- | Get a function pointer to the CLabel specified. +-- +-- This is for Haskell functions, function type is assumed, so doesn't work +-- with foreign functions. +getHsFunc :: LiveGlobalRegUses -> CLabel -> LlvmM ExprData +getHsFunc live lbl + = do fty <- llvmFunTy live + name <- strCLabel_llvm lbl + getHsFunc' name fty + +getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData +getHsFunc' name fty + = do fun <- getGlobalPtr name + if getVarType fun == fty + then return (fun, nilOL, []) + else do (v1, s1) <- doExpr (pLift fty) + $ Cast LM_Bitcast fun (pLift fty) + return (v1, unitOL s1, []) + +-- | Create a new local var +mkLocalVar :: LlvmType -> LlvmM LlvmVar +mkLocalVar ty = do + un <- getUniqueM + return $ LMLocalVar un ty + + +-- | Execute an expression, assigning result to a var +doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement) +doExpr ty expr = do + v <- mkLocalVar ty + return (v, Assignment v expr) + + +-- | Expand CmmRegOff +expandCmmReg :: (CmmReg, Int) -> CmmExpr +expandCmmReg (reg, off) + = let width = typeWidth (cmmRegType reg) + voff = CmmLit $ CmmInt (fromIntegral off) width + in CmmMachOp (MO_Add width) [CmmReg reg, voff] + + +-- | Convert a block id into a appropriate Llvm label +blockIdToLlvm :: BlockId -> LlvmVar +blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel + +-- | Create Llvm int Literal +mkIntLit :: Integral a => LlvmType -> a -> LlvmVar +mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty + +-- | Convert int type to a LLvmVar of word or i32 size +toI32 :: Integral a => a -> LlvmVar +toI32 = mkIntLit i32 + +toIWord :: Integral a => Platform -> a -> LlvmVar +toIWord platform = mkIntLit (llvmWord platform) + + +-- | Error functions +panic :: HasCallStack => String -> a +panic s = Panic.panic $ "GHC.CmmToLlvm.CodeGen." ++ s + +pprPanic :: HasCallStack => String -> SDoc -> a +pprPanic s d = Panic.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d + + +-- | Returns TBAA meta data by unique +getTBAAMeta :: Unique -> LlvmM [MetaAnnot] +getTBAAMeta u = + List.singleton . MetaAnnot tbaa . MetaNode . expectJust <$> getUniqMeta u + +-- | Returns TBAA meta data for given register +getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot] +getTBAARegMeta = getTBAAMeta . getTBAA + + +-- | A more convenient way of accumulating LLVM statements and declarations. +data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl] + +instance Semigroup LlvmAccum where + LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB = + LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB) + +instance Monoid LlvmAccum where + mempty = LlvmAccum nilOL [] + mappend = (Semigroup.<>) + +liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar +liftExprData action = do + (var, stmts, decls) <- lift action + tell $ LlvmAccum stmts decls + return var + +statement :: LlvmStatement -> WriterT LlvmAccum LlvmM () +statement stmt = tell $ LlvmAccum (unitOL stmt) [] + +doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar +doExprW a b = do + (var, stmt) <- lift $ doExpr a b + statement stmt + return var + +exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar +exprToVarW = liftExprData . exprToVar + +runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData +runExprData action = do + (var, LlvmAccum stmts decls) <- runWriterT action + return (var, stmts, decls) + +runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl]) +runStmtsDecls action = do + LlvmAccum stmts decls <- execWriterT action + return (stmts, decls) + +getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM (LlvmVar, LlvmType) +getCmmRegW = lift . getCmmReg + +genLoadW :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> WriterT LlvmAccum LlvmM LlvmVar +genLoadW atomic e ty alignment = liftExprData $ genLoad atomic e ty alignment + +-- | Return element of single-element list; 'panic' if list is not a single-element list +singletonPanic :: String -> [a] -> a +singletonPanic _ [x] = x +singletonPanic s _ = panic s diff --git a/GHC/CmmToLlvm/Config.hs b/GHC/CmmToLlvm/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Config.hs @@ -0,0 +1,82 @@ +-- | Llvm code generator configuration +module GHC.CmmToLlvm.Config + ( LlvmCgConfig(..) + , LlvmConfig(..) + , LlvmTarget(..) + , initLlvmConfig + ) +where + +import GHC.Prelude +import GHC.Platform + +import GHC.Utils.Outputable +import GHC.Settings.Utils +import GHC.Utils.Panic +import GHC.CmmToLlvm.Version.Type (LlvmVersion) + +import System.FilePath + +data LlvmCgConfig = LlvmCgConfig + { llvmCgPlatform :: !Platform -- ^ Target platform + , llvmCgContext :: !SDocContext -- ^ Context for LLVM code generation + , llvmCgFillUndefWithGarbage :: !Bool -- ^ Fill undefined literals with garbage values + , llvmCgSplitSection :: !Bool -- ^ Split sections + , llvmCgAvxEnabled :: !Bool + , llvmCgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions + , llvmCgLlvmVersion :: Maybe LlvmVersion -- ^ version of Llvm we're using + , llvmCgDoWarn :: !Bool -- ^ True ==> warn unsupported Llvm version + , llvmCgLlvmTarget :: !String -- ^ target triple passed to LLVM + , llvmCgLlvmConfig :: !LlvmConfig -- ^ Supported LLVM configurations. + -- see Note [LLVM configuration] + } + +data LlvmTarget = LlvmTarget + { lDataLayout :: String + , lCPU :: String + , lAttributes :: [String] + } + +-- Note [LLVM configuration] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain +-- information needed by the LLVM backend to invoke `llc` and `opt`. +-- Specifically: +-- +-- * llvm-targets maps autoconf host triples to the corresponding LLVM +-- `data-layout` declarations. This information is extracted from clang using +-- the script in utils/llvm-targets/gen-data-layout.sh and should be updated +-- whenever we target a new version of LLVM. +-- +-- * llvm-passes maps GHC optimization levels to sets of LLVM optimization +-- flags that GHC should pass to `opt`. +-- +-- This information is contained in files rather the GHC source to allow users +-- to add new targets to GHC without having to recompile the compiler. +-- + +initLlvmConfig :: FilePath -> IO LlvmConfig +initLlvmConfig top_dir + = do + targets <- readAndParse "llvm-targets" + passes <- readAndParse "llvm-passes" + return $ LlvmConfig + { llvmTargets = fmap mkLlvmTarget <$> targets + , llvmPasses = passes + } + where + readAndParse :: Read a => String -> IO a + readAndParse name = do + let f = top_dir name + llvmConfigStr <- readFile f + case maybeReadFuzzy llvmConfigStr of + Just s -> return s + Nothing -> pgmError ("Can't parse LLVM config file: " ++ show f) + + mkLlvmTarget :: (String, String, String) -> LlvmTarget + mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs) + +data LlvmConfig = LlvmConfig + { llvmTargets :: [(String, LlvmTarget)] + , llvmPasses :: [(Int, String)] + } diff --git a/GHC/CmmToLlvm/Data.hs b/GHC/CmmToLlvm/Data.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Data.hs @@ -0,0 +1,244 @@ + +-- ---------------------------------------------------------------------------- +-- | Handle conversion of CmmData to LLVM code. +-- + +module GHC.CmmToLlvm.Data ( + genLlvmData, genData + ) where + +import GHC.Prelude + +import GHC.Llvm +import GHC.Llvm.Types (widenFp) +import GHC.CmmToLlvm.Base +import GHC.CmmToLlvm.Config + +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.InitFini +import GHC.Cmm +import GHC.Platform + +import GHC.Data.FastString +import GHC.Utils.Panic +import qualified Data.ByteString as BS + +-- ---------------------------------------------------------------------------- +-- * Constants +-- + +-- | The string appended to a variable name to create its structure type alias +structStr :: LMString +structStr = fsLit "_struct" + +-- | The LLVM visibility of the label +linkage :: CLabel -> LlvmLinkageType +linkage lbl = if externallyVisibleCLabel lbl + then ExternallyVisible else Internal + +-- ---------------------------------------------------------------------------- +-- * Top level +-- + +-- | Pass a CmmStatic section to an equivalent Llvm code. +genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData +-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +genLlvmData (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' = do + label <- strCLabel_llvm alias + label' <- strCLabel_llvm ind' + let link = linkage alias + link' = linkage ind' + -- the LLVM type we give the alias is an empty struct type + -- but it doesn't really matter, as the pointer is only + -- used for (bit/int)casting. + tyAlias = LMAlias (label `appendFS` structStr, LMStructU []) + + aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias + -- we don't know the type of the indirectee here + indType = panic "will be filled by 'aliasify', later" + orig = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias + + pure ([LMGlobal aliasDef $ Just orig], [tyAlias]) + +-- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini. +genLlvmData (sect, statics) + | Just (initOrFini, clbls) <- isInitOrFiniArray (CmmData sect statics) + = let var = case initOrFini of + IsInitArray -> fsLit "llvm.global_ctors" + IsFiniArray -> fsLit "llvm.global_dtors" + in genGlobalLabelArray var clbls + +genLlvmData (sec, CmmStaticsRaw lbl xs) = do + label <- strCLabel_llvm lbl + static <- mapM genData xs + lmsec <- llvmSection sec + platform <- getPlatform + let types = map getStatType static + + strucTy = LMStruct types + tyAlias = LMAlias (label `appendFS` structStr, strucTy) + + struct = Just $ LMStaticStruc static tyAlias + link = linkage lbl + align = case sec of + Section CString _ -> if (platformArch platform == ArchS390X) + then Just 2 else Just 1 + Section Data _ -> Just $ platformWordSizeInBytes platform + _ -> Nothing + const = if sectionProtection sec == ReadOnlySection + then Constant else Global + varDef = LMGlobalVar label tyAlias link lmsec align const + globDef = LMGlobal varDef struct + + return ([globDef], [tyAlias]) + +-- | Produce an initializer or finalizer array declaration. +-- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for +-- details. +genGlobalLabelArray :: FastString -> [CLabel] -> LlvmM LlvmData +genGlobalLabelArray var_nm clbls = do + lbls <- mapM strCLabel_llvm clbls + decls <- mapM mkFunDecl lbls + let entries = map toArrayEntry lbls + static = LMStaticArray entries arr_ty + arr = LMGlobal arr_var (Just static) + return ([arr], decls) + where + mkFunDecl :: LMString -> LlvmM LlvmType + mkFunDecl fn_lbl = do + let fn_ty = mkFunTy fn_lbl + funInsert fn_lbl fn_ty + return (fn_ty) + + toArrayEntry :: LMString -> LlvmStatic + toArrayEntry fn_lbl = + let fn_var = LMGlobalVar fn_lbl (LMPointer $ mkFunTy fn_lbl) Internal Nothing Nothing Global + fn = LMStaticPointer fn_var + null = LMStaticLit (LMNullLit i8Ptr) + prio = LMStaticLit $ LMIntLit 0xffff i32 + in LMStaticStrucU [prio, fn, null] entry_ty + + arr_var = LMGlobalVar var_nm arr_ty Appending Nothing Nothing Global + mkFunTy lbl = LMFunction $ LlvmFunctionDecl lbl ExternallyVisible CC_Ccc LMVoid FixedArgs [] Nothing + entry_ty = LMStructU [i32, LMPointer $ mkFunTy $ fsLit "placeholder", LMPointer i8] + arr_ty = LMArray (length clbls) entry_ty + +-- | Format the section type part of a Cmm Section +llvmSectionType :: Platform -> SectionType -> FastString +llvmSectionType p t = case t of + Text -> fsLit ".text" + ReadOnlyData -> case platformOS p of + OSMinGW32 -> fsLit ".rdata" + _ -> fsLit ".rodata" + RelocatableReadOnlyData -> case platformOS p of + OSMinGW32 -> fsLit ".rdata$rel.ro" + _ -> fsLit ".data.rel.ro" + Data -> fsLit ".data" + UninitialisedData -> fsLit ".bss" + CString -> case platformOS p of + OSMinGW32 -> fsLit ".rdata$str" + _ -> fsLit ".rodata.str" + + InitArray -> panic "llvmSectionType: InitArray" + FiniArray -> panic "llvmSectionType: FiniArray" + OtherSection _ -> panic "llvmSectionType: unknown section type" + +-- | Format a Cmm Section into a LLVM section name +llvmSection :: Section -> LlvmM LMSection +llvmSection (Section t suffix) = do + opts <- getConfig + let splitSect = llvmCgSplitSection opts + platform = llvmCgPlatform opts + if not splitSect + then return Nothing + else do + lmsuffix <- strCLabel_llvm suffix + let result sep = Just (concatFS [llvmSectionType platform t + , fsLit sep, lmsuffix]) + case platformOS platform of + OSMinGW32 -> return (result "$") + _ -> return (result ".") + +-- ---------------------------------------------------------------------------- +-- * Generate static data +-- + +-- | Handle static data +genData :: CmmStatic -> LlvmM LlvmStatic + +genData (CmmFileEmbed {}) = panic "Unexpected CmmFileEmbed literal" +genData (CmmString str) = do + let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) + (BS.unpack str) + ve = v ++ [LMStaticLit $ LMIntLit 0 i8] + return $ LMStaticArray ve (LMArray (length ve) i8) + +genData (CmmUninitialised bytes) + = return $ LMUninitType (LMArray bytes i8) + +genData (CmmStaticLit lit) + = genStaticLit lit + +-- | Generate Llvm code for a static literal. +-- +-- Will either generate the code or leave it unresolved if it is a 'CLabel' +-- which isn't yet known. +genStaticLit :: CmmLit -> LlvmM LlvmStatic +genStaticLit (CmmInt i w) + = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) + +genStaticLit (CmmFloat r W32) + = return $ LMStaticLit (LMFloatLit (widenFp (fromRational r :: Float)) (widthToLlvmFloat W32)) + +genStaticLit (CmmFloat r W64) + = return $ LMStaticLit (LMFloatLit (fromRational r :: Double) (widthToLlvmFloat W64)) + +genStaticLit (CmmFloat _r _w) + = panic "genStaticLit (CmmLit:CmmFloat), unsupported float lit" + +genStaticLit (CmmVec ls) + = do sls <- mapM toLlvmLit ls + return $ LMStaticLit (LMVectorLit sls) + where + toLlvmLit :: CmmLit -> LlvmM LlvmLit + toLlvmLit lit = do + slit <- genStaticLit lit + case slit of + LMStaticLit llvmLit -> return llvmLit + _ -> panic "genStaticLit" + +-- Leave unresolved, will fix later +genStaticLit cmm@(CmmLabel l) = do + var <- getGlobalPtr =<< strCLabel_llvm l + platform <- getPlatform + let ptr = LMStaticPointer var + lmty = cmmToLlvmType $ cmmLitType platform cmm + return $ LMPtoI ptr lmty + +genStaticLit (CmmLabelOff label off) = do + platform <- getPlatform + var <- genStaticLit (CmmLabel label) + let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord platform) + return $ LMAdd var offset + +genStaticLit (CmmLabelDiffOff l1 l2 off w) = do + platform <- getPlatform + var1 <- genStaticLit (CmmLabel l1) + var2 <- genStaticLit (CmmLabel l2) + let var + | w == wordWidth platform = LMSub var1 var2 + | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w) + offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w) + return $ LMAdd var offset + +genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b + +genStaticLit (CmmHighStackMark) + = panic "genStaticLit: CmmHighStackMark unsupported!" diff --git a/GHC/CmmToLlvm/Mangler.hs b/GHC/CmmToLlvm/Mangler.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Mangler.hs @@ -0,0 +1,169 @@ +-- ----------------------------------------------------------------------------- +-- | GHC LLVM Mangler +-- +-- This script processes the assembly produced by LLVM, rewriting all symbols +-- of type @function to @object. This keeps them from going through the PLT, +-- which would be bad due to tables-next-to-code. On x86_64, +-- it also rewrites AVX instructions that require alignment to their +-- unaligned counterparts, since the stack is only 16-byte aligned but these +-- instructions require 32-byte alignment. +-- + +module GHC.CmmToLlvm.Mangler ( llvmFixupAsm ) where + +import GHC.Prelude + +import GHC.Platform ( Platform, platformArch, Arch(..) ) +import GHC.Utils.Exception (try) + +import qualified Data.ByteString.Char8 as B +import System.IO + +-- | Read in assembly file and process +llvmFixupAsm :: Platform -> FilePath -> FilePath -> IO () +llvmFixupAsm platform f1 f2 = {-# SCC "llvm_mangler" #-} + withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do + go r w + hClose r + hClose w + return () + where + go :: Handle -> Handle -> IO () + go r w = do + e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString) + let writeline a = B.hPutStrLn w (rewriteLine platform rewrites a) >> go r w + case e_l of + Right l -> writeline l + Left _ -> return () + +-- | These are the rewrites that the mangler will perform +rewrites :: [Rewrite] +rewrites = [rewriteSymType, rewriteAVX, rewriteCall, rewriteJump] + +type Rewrite = Platform -> B.ByteString -> Maybe B.ByteString + +-- | Rewrite a line of assembly source with the given rewrites, +-- taking the first rewrite that applies. +rewriteLine :: Platform -> [Rewrite] -> B.ByteString -> B.ByteString +rewriteLine platform rewrites l + -- We disable .subsections_via_symbols on darwin and ios, as the llvm code + -- gen uses prefix data for the info table. This however does not prevent + -- llvm from generating .subsections_via_symbols, which in turn with + -- -dead_strip, strips the info tables, and therefore breaks ghc. + | isSubsectionsViaSymbols l = + (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!") + | otherwise = + case firstJust $ map (\rewrite -> rewrite platform rest) rewrites of + Nothing -> l + Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten] + where + isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols") + + (symbol, rest) = splitLine l + + firstJust :: [Maybe a] -> Maybe a + firstJust (Just x:_) = Just x + firstJust [] = Nothing + firstJust (_:rest) = firstJust rest + +-- | This rewrites @.type@ annotations of function symbols to @%object@. +-- This is done as the linker can relocate @%functions@ through the +-- Procedure Linking Table (PLT). This is bad since we expect that the +-- info table will appear directly before the symbol's location. In the +-- case that the PLT is used, this will be not an info table but instead +-- some random PLT garbage. +rewriteSymType :: Rewrite +rewriteSymType _ l + | isType l = Just $ rewrite '@' $ rewrite '%' l + | otherwise = Nothing + where + isType = B.isPrefixOf (B.pack ".type") + + rewrite :: Char -> B.ByteString -> B.ByteString + rewrite prefix = replaceOnce funcType objType + where + funcType = prefix `B.cons` B.pack "function" + objType = prefix `B.cons` B.pack "object" + +-- | This rewrites aligned AVX instructions to their unaligned counterparts on +-- x86-64. This is necessary because the stack is not adequately aligned for +-- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer +-- and disable tail call optimization. Both would be catastrophic here so GHC +-- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then +-- rewrites the instructions in the mangler. +rewriteAVX :: Rewrite +rewriteAVX platform s + | not isX86_64 = Nothing + | isVmovdqa s = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s + | isVmovap s = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s + | otherwise = Nothing + where + isX86_64 = platformArch platform == ArchX86_64 + isVmovdqa = B.isPrefixOf (B.pack "vmovdqa") + isVmovap = B.isPrefixOf (B.pack "vmovap") + +-- | This rewrites (tail) calls to avoid creating PLT entries for +-- functions on riscv64. The replacement will load the address from the +-- GOT, which is resolved to point to the real address of the function. +rewriteCall :: Rewrite +rewriteCall platform l + | not isRISCV64 = Nothing + | isCall l = Just $ replaceCall "call" "jalr" "ra" l + | isTail l = Just $ replaceCall "tail" "jr" "t1" l + | otherwise = Nothing + where + isRISCV64 = platformArch platform == ArchRISCV64 + isCall = B.isPrefixOf (B.pack "call\t") + isTail = B.isPrefixOf (B.pack "tail\t") + + replaceCall call jump reg l = + appendInsn (jump ++ "\t" ++ reg) $ removePlt $ + replaceOnce (B.pack call) (B.pack ("la\t" ++ reg ++ ",")) l + where + removePlt = replaceOnce (B.pack "@plt") (B.pack "") + appendInsn i = (`B.append` B.pack ("\n\t" ++ i)) + +-- | This rewrites bl and b jump inst to avoid creating PLT entries for +-- functions on loongarch64, because there is no separate call instruction +-- for function calls in loongarch64. Also, this replacement will load +-- the function address from the GOT, which is resolved to point to the +-- real address of the function. +rewriteJump :: Rewrite +rewriteJump platform l + | not isLoongArch64 = Nothing + | isBL l = Just $ replaceJump "bl" "$ra" "$ra" l + | isB l = Just $ replaceJump "b" "$zero" "$t0" l + | otherwise = Nothing + where + isLoongArch64 = platformArch platform == ArchLoongArch64 + isBL = B.isPrefixOf (B.pack "bl\t") + isB = B.isPrefixOf (B.pack "b\t") + + replaceJump jump rd rj l = + appendInsn ("jirl" ++ "\t" ++ rd ++ ", " ++ rj ++ ", 0") $ removeBracket $ + replaceOnce (B.pack (jump ++ "\t%plt(")) (B.pack ("la\t" ++ rj ++ ", ")) l + where + removeBracket = replaceOnce (B.pack ")") (B.pack "") + appendInsn i = (`B.append` B.pack ("\n\t" ++ i)) + +-- | @replaceOnce match replace bs@ replaces the first occurrence of the +-- substring @match@ in @bs@ with @replace@. +replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +replaceOnce matchBS replaceOnceBS = loop + where + loop :: B.ByteString -> B.ByteString + loop cts = + case B.breakSubstring matchBS cts of + (hd,tl) | B.null tl -> hd + | otherwise -> hd `B.append` replaceOnceBS `B.append` + B.drop (B.length matchBS) tl + +-- | This function splits a line of assembly code into the label and the +-- rest of the code. +splitLine :: B.ByteString -> (B.ByteString, B.ByteString) +splitLine l = (symbol, B.dropWhile isSpace rest) + where + isSpace ' ' = True + isSpace '\t' = True + isSpace _ = False + (symbol, rest) = B.span (not . isSpace) l diff --git a/GHC/CmmToLlvm/Ppr.hs b/GHC/CmmToLlvm/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Ppr.hs @@ -0,0 +1,108 @@ + + +-- ---------------------------------------------------------------------------- +-- | Pretty print helpers for the LLVM Code generator. +-- +module GHC.CmmToLlvm.Ppr ( + pprLlvmCmmDecl, pprLlvmData, infoSection + ) where + +import GHC.Prelude + +import GHC.Llvm +import GHC.CmmToLlvm.Base +import GHC.CmmToLlvm.Data +import GHC.CmmToLlvm.Config + +import GHC.Cmm.CLabel +import GHC.Cmm + +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Types.Unique + +-- ---------------------------------------------------------------------------- +-- * Top level +-- + +-- | Pretty print LLVM data code +pprLlvmData :: IsDoc doc => LlvmCgConfig -> LlvmData -> doc +pprLlvmData cfg (globals, types) = + let ppLlvmTys (LMAlias a) = line $ ppLlvmAlias a + ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f + ppLlvmTys _other = empty + + types' = vcat $ map ppLlvmTys types + globals' = ppLlvmGlobals cfg globals + in types' $$ globals' +{-# SPECIALIZE pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc #-} +{-# SPECIALIZE pprLlvmData :: LlvmCgConfig -> LlvmData -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Pretty print LLVM code +-- The HDoc we return is used to produce the final LLVM file, with the +-- SDoc being returned alongside for use when @Opt_D_dump_llvm@ is set +-- as we can't (currently) dump HDocs. +pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (HDoc, SDoc) +pprLlvmCmmDecl (CmmData _ lmdata) = do + opts <- getConfig + return ( vcat $ map (pprLlvmData opts) lmdata + , vcat $ map (pprLlvmData opts) lmdata) + +pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks)) + = do let lbl = case mb_info of + Nothing -> entry_lbl + Just (CmmStaticsRaw info_lbl _) -> info_lbl + link = if externallyVisibleCLabel lbl + then ExternallyVisible + else Internal + lmblocks = map (\(BasicBlock id stmts) -> + LlvmBlock (getUnique id) stmts) blks + + funDec <- llvmFunSig live lbl link + cfg <- getConfig + platform <- getPlatform + let buildArg = fsLit . showSDocOneLine (llvmCgContext cfg). ppPlainName cfg + funArgs = map buildArg (llvmFunArgs platform live) + funSect = llvmFunSection cfg (decName funDec) + + -- generate the info table + prefix <- case mb_info of + Nothing -> return Nothing + Just (CmmStaticsRaw _ statics) -> do + infoStatics <- mapM genData statics + let infoTy = LMStruct $ map getStatType infoStatics + return $ Just $ LMStaticStruc infoStatics infoTy + + + let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect + prefix lmblocks + name = decName $ funcDecl fun + defName = llvmDefLabel name + funcDecl' = (funcDecl fun) { decName = defName } + fun' = fun { funcDecl = funcDecl' } + funTy = LMFunction funcDecl' + funVar = LMGlobalVar name + (LMPointer funTy) + link + Nothing + Nothing + Alias + defVar = LMGlobalVar defName + (LMPointer funTy) + (funcLinkage funcDecl') + (funcSect fun) + (funcAlign funcDecl') + Alias + alias = LMGlobal funVar + (Just $ LMBitc (LMStaticPointer defVar) + i8Ptr) + + return ( vcat [line $ ppLlvmGlobal cfg alias, ppLlvmFunction cfg fun'] + , vcat [line $ ppLlvmGlobal cfg alias, ppLlvmFunction cfg fun']) + + +-- | The section we are putting info tables and their entry code into, should +-- be unique since we process the assembly pattern matching this. +infoSection :: String +infoSection = "X98A__STRIP,__me" diff --git a/GHC/CmmToLlvm/Regs.hs b/GHC/CmmToLlvm/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Regs.hs @@ -0,0 +1,151 @@ + + +-------------------------------------------------------------------------------- +-- | Deal with Cmm registers +-- + +module GHC.CmmToLlvm.Regs ( + lmGlobalRegArg, lmGlobalRegVar, alwaysLive, + stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA + ) where + +import GHC.Prelude + +import GHC.Llvm + +import GHC.Cmm.Expr +import GHC.CmmToAsm.Format +import GHC.Platform +import GHC.Data.FastString +import GHC.Utils.Panic ( panic ) +import GHC.Types.Unique + + +-- | Get the LlvmVar function variable storing the real register +lmGlobalRegVar :: Platform -> GlobalRegUse -> LlvmVar +lmGlobalRegVar platform = pVarLift . lmGlobalReg platform "_Var" + +-- | Get the LlvmVar function argument storing the real register +lmGlobalRegArg :: Platform -> GlobalRegUse -> LlvmVar +lmGlobalRegArg platform = lmGlobalReg platform "_Arg" + +{- Need to make sure the names here can't conflict with the unique generated + names. Uniques generated names containing only base62 chars. So using say + the '_' char guarantees this. +-} +lmGlobalReg :: Platform -> String -> GlobalRegUse -> LlvmVar +lmGlobalReg platform suf (GlobalRegUse reg ty) + = case reg of + BaseReg -> ptrGlobal $ "Base" ++ suf + Sp -> ptrGlobal $ "Sp" ++ suf + Hp -> ptrGlobal $ "Hp" ++ suf + VanillaReg 1 -> wordGlobal $ "R1" ++ suf + VanillaReg 2 -> wordGlobal $ "R2" ++ suf + VanillaReg 3 -> wordGlobal $ "R3" ++ suf + VanillaReg 4 -> wordGlobal $ "R4" ++ suf + VanillaReg 5 -> wordGlobal $ "R5" ++ suf + VanillaReg 6 -> wordGlobal $ "R6" ++ suf + VanillaReg 7 -> wordGlobal $ "R7" ++ suf + VanillaReg 8 -> wordGlobal $ "R8" ++ suf + VanillaReg 9 -> wordGlobal $ "R9" ++ suf + VanillaReg 10 -> wordGlobal $ "R10" ++ suf + SpLim -> wordGlobal $ "SpLim" ++ suf + FloatReg 1 -> floatGlobal $ "F1" ++ suf + FloatReg 2 -> floatGlobal $ "F2" ++ suf + FloatReg 3 -> floatGlobal $ "F3" ++ suf + FloatReg 4 -> floatGlobal $ "F4" ++ suf + FloatReg 5 -> floatGlobal $ "F5" ++ suf + FloatReg 6 -> floatGlobal $ "F6" ++ suf + DoubleReg 1 -> doubleGlobal $ "D1" ++ suf + DoubleReg 2 -> doubleGlobal $ "D2" ++ suf + DoubleReg 3 -> doubleGlobal $ "D3" ++ suf + DoubleReg 4 -> doubleGlobal $ "D4" ++ suf + DoubleReg 5 -> doubleGlobal $ "D5" ++ suf + DoubleReg 6 -> doubleGlobal $ "D6" ++ suf + XmmReg 1 -> xmmGlobal $ "XMM1" ++ suf + XmmReg 2 -> xmmGlobal $ "XMM2" ++ suf + XmmReg 3 -> xmmGlobal $ "XMM3" ++ suf + XmmReg 4 -> xmmGlobal $ "XMM4" ++ suf + XmmReg 5 -> xmmGlobal $ "XMM5" ++ suf + XmmReg 6 -> xmmGlobal $ "XMM6" ++ suf + YmmReg 1 -> ymmGlobal $ "YMM1" ++ suf + YmmReg 2 -> ymmGlobal $ "YMM2" ++ suf + YmmReg 3 -> ymmGlobal $ "YMM3" ++ suf + YmmReg 4 -> ymmGlobal $ "YMM4" ++ suf + YmmReg 5 -> ymmGlobal $ "YMM5" ++ suf + YmmReg 6 -> ymmGlobal $ "YMM6" ++ suf + ZmmReg 1 -> zmmGlobal $ "ZMM1" ++ suf + ZmmReg 2 -> zmmGlobal $ "ZMM2" ++ suf + ZmmReg 3 -> zmmGlobal $ "ZMM3" ++ suf + ZmmReg 4 -> zmmGlobal $ "ZMM4" ++ suf + ZmmReg 5 -> zmmGlobal $ "ZMM5" ++ suf + ZmmReg 6 -> zmmGlobal $ "ZMM6" ++ suf + MachSp -> wordGlobal $ "MachSp" ++ suf + _other -> panic $ "GHC.CmmToLlvm.Reg: GlobalReg (" ++ (show reg) + ++ ") not supported!" + -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc + -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg + where + wordGlobal name = LMNLocalVar (fsLit name) (llvmWord platform) + ptrGlobal name = LMNLocalVar (fsLit name) (llvmWordPtr platform) + floatGlobal name = LMNLocalVar (fsLit name) LMFloat + doubleGlobal name = LMNLocalVar (fsLit name) LMDouble + fmt = cmmTypeFormat ty + xmmGlobal name = LMNLocalVar (fsLit name) (formatLlvmType fmt) + ymmGlobal name = LMNLocalVar (fsLit name) (formatLlvmType fmt) + zmmGlobal name = LMNLocalVar (fsLit name) (formatLlvmType fmt) + +formatLlvmType :: Format -> LlvmType +formatLlvmType II8 = LMInt 8 +formatLlvmType II16 = LMInt 16 +formatLlvmType II32 = LMInt 32 +formatLlvmType II64 = LMInt 64 +formatLlvmType FF32 = LMFloat +formatLlvmType FF64 = LMDouble +formatLlvmType (VecFormat l sFmt) = LMVector l (formatLlvmType $ scalarFormatFormat sFmt) + +-- | A list of STG Registers that should always be considered alive +alwaysLive :: Platform -> [GlobalRegUse] +alwaysLive platform = + [ GlobalRegUse r (globalRegSpillType platform r) + | r <- [BaseReg, Sp, Hp, SpLim, HpLim, node] + ] + +-- | STG Type Based Alias Analysis hierarchy +stgTBAA :: [(Unique, LMString, Maybe Unique)] +stgTBAA + = [ (rootN, fsLit "root", Nothing) + , (topN, fsLit "top", Just rootN) + , (stackN, fsLit "stack", Just topN) + , (heapN, fsLit "heap", Just topN) + , (rxN, fsLit "rx", Just heapN) + , (baseN, fsLit "base", Just topN) + -- FIX: Not 100% sure if this hierarchy is complete. I think the big thing + -- is Sp is never aliased, so might want to change the hierarchy to have Sp + -- on its own branch that is never aliased (e.g never use top as a TBAA + -- node). + ] + +-- | Id values +-- The `rootN` node is the root (there can be more than one) of the TBAA +-- hierarchy and as of LLVM 4.0 should *only* be referenced by other nodes. It +-- should never occur in any LLVM instruction statement. +rootN, topN, stackN, heapN, rxN, baseN :: Unique +rootN = getUnique (fsLit "GHC.CmmToLlvm.Regs.rootN") +topN = getUnique (fsLit "GHC.CmmToLlvm.Regs.topN") +stackN = getUnique (fsLit "GHC.CmmToLlvm.Regs.stackN") +heapN = getUnique (fsLit "GHC.CmmToLlvm.Regs.heapN") +rxN = getUnique (fsLit "GHC.CmmToLlvm.Regs.rxN") +baseN = getUnique (fsLit "GHC.CmmToLlvm.Regs.baseN") + +-- | The TBAA metadata identifier +tbaa :: LMString +tbaa = fsLit "tbaa" + +-- | Get the correct TBAA metadata information for this register type +getTBAA :: GlobalReg -> Unique +getTBAA BaseReg = baseN +getTBAA Sp = stackN +getTBAA Hp = heapN +getTBAA (VanillaReg _) = rxN +getTBAA _ = topN diff --git a/GHC/CmmToLlvm/Version.hs b/GHC/CmmToLlvm/Version.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Version.hs @@ -0,0 +1,43 @@ +module GHC.CmmToLlvm.Version + ( LlvmVersion(..) + , supportedLlvmVersionLowerBound + , supportedLlvmVersionUpperBound + , parseLlvmVersion + , llvmVersionSupported + , llvmVersionStr + , llvmVersionList + ) +where + +import GHC.Prelude + +import GHC.CmmToLlvm.Version.Type +import GHC.CmmToLlvm.Version.Bounds + +import Data.Char (isDigit) +import Data.List (intercalate) +import qualified Data.List.NonEmpty as NE + +parseLlvmVersion :: String -> Maybe LlvmVersion +parseLlvmVersion = + fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit) + where + go vs s + | null ver_str + = reverse vs + | '.' : rest' <- rest + = go (read ver_str : vs) rest' + | otherwise + = reverse (read ver_str : vs) + where + (ver_str, rest) = span isDigit s + +llvmVersionSupported :: LlvmVersion -> Bool +llvmVersionSupported v = + v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound + +llvmVersionStr :: LlvmVersion -> String +llvmVersionStr = intercalate "." . map show . llvmVersionList + +llvmVersionList :: LlvmVersion -> [Int] +llvmVersionList = NE.toList . llvmVersionNE diff --git a/GHC/CmmToLlvm/Version/Bounds.hs b/GHC/CmmToLlvm/Version/Bounds.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Version/Bounds.hs @@ -0,0 +1,19 @@ +module GHC.CmmToLlvm.Version.Bounds + ( supportedLlvmVersionLowerBound + , supportedLlvmVersionUpperBound + ) +where + +import GHC.Prelude () + +import GHC.CmmToLlvm.Version.Type + +import qualified Data.List.NonEmpty as NE + +-- | The (inclusive) lower bound on the LLVM Version that is currently supported. +supportedLlvmVersionLowerBound :: LlvmVersion +supportedLlvmVersionLowerBound = LlvmVersion (13 NE.:| []) + +-- | The (not-inclusive) upper bound bound on the LLVM Version that is currently supported. +supportedLlvmVersionUpperBound :: LlvmVersion +supportedLlvmVersionUpperBound = LlvmVersion (21 NE.:| []) diff --git a/GHC/CmmToLlvm/Version/Type.hs b/GHC/CmmToLlvm/Version/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Version/Type.hs @@ -0,0 +1,11 @@ +module GHC.CmmToLlvm.Version.Type + ( LlvmVersion(..) + ) +where + +import GHC.Prelude + +import qualified Data.List.NonEmpty as NE + +newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } + deriving (Eq, Ord) diff --git a/GHC/Core.hs b/GHC/Core.hs new file mode 100644 --- /dev/null +++ b/GHC/Core.hs @@ -0,0 +1,2438 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE NoPolyKinds #-} + +-- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection +module GHC.Core ( + -- * Main data types + Expr(..), Alt(..), Bind(..), AltCon(..), Arg, + CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, + + -- * In/Out type synonyms + InId, InBind, InExpr, InAlt, InArg, InType, InKind, + InBndr, InVar, InCoercion, InTyVar, InCoVar, InTyCoVar, + OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind, + OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, + OutTyCoVar, MOutCoercion, + + -- ** 'Expr' construction + mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams, + mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg, + + mkIntLit, mkIntLitWrap, + mkWordLit, mkWordLitWrap, + mkWord8Lit, + mkWord32LitWord32, mkWord64LitWord64, mkInt64LitInt64, + mkCharLit, mkStringLit, + mkFloatLit, mkFloatLitFloat, + mkDoubleLit, mkDoubleLitDouble, + + mkConApp, mkConApp2, mkTyBind, mkCoBind, + varToCoreExpr, varsToCoreExprs, + + mkBinds, + + isId, cmpAltCon, cmpAlt, ltAlt, + + -- ** Simple 'Expr' access functions and predicates + bindersOf, bindersOfBinds, rhssOfBind, rhssOfBinds, rhssOfAlts, + foldBindersOfBindStrict, foldBindersOfBindsStrict, + collectBinders, collectTyBinders, collectTyAndValBinders, + collectNBinders, collectNValBinders_maybe, + collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds, + collectFunSimple, + + exprToType, + wrapLamBody, + + isValArg, isTypeArg, isCoArg, isTyCoArg, valArgCount, valBndrCount, + isRuntimeArg, isRuntimeVar, + + -- * Unfolding data types + Unfolding(..), UnfoldingCache(..), UnfoldingGuidance(..), UnfoldingSource(..), + + -- ** Constructing 'Unfolding's + noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon, + unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, + + -- ** Predicates and deconstruction on 'Unfolding' + expandUnfolding_maybe, + maybeUnfoldingTemplate, otherCons, + isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, + isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, + isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding, + isInlineUnfolding, isBootUnfolding, isBetterUnfoldingThan, + hasCoreUnfolding, hasSomeUnfolding, + canUnfold, neverUnfoldGuidance, isStableSource, + + -- * Annotated expression data types + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt(..), + + -- ** Operations on annotated expressions + collectAnnArgs, collectAnnArgsTicks, + + -- ** Operations on annotations + deAnnotate, deAnnotate', deAnnAlt, deAnnBind, + collectAnnBndrs, collectNAnnBndrs, + + -- * Orphanhood + IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, + + -- * Core rule data types + CoreRule(..), + RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts, + + -- ** Operations on 'CoreRule's + ruleArity, ruleName, ruleIdName, ruleActivation, + setRuleIdName, ruleModule, + isBuiltinRule, isLocalRule, isAutoRule, + ) where + +import GHC.Prelude +import GHC.Platform + +import GHC.Types.Var.Env( InScopeSet ) +import GHC.Types.Var +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Rules.Config ( RuleOpts ) +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Literal +import GHC.Types.Tickish +import GHC.Core.DataCon +import GHC.Unit.Module +import GHC.Types.Basic +import GHC.Types.Unique.Set + +import GHC.Utils.Binary +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Data hiding (TyCon) +import Data.Int +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Word + +import Control.DeepSeq + +infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` +-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) + +{- +************************************************************************ +* * +\subsection{The main data types} +* * +************************************************************************ + +These data types are the heart of the compiler +-} + +-- | This is the data type that represents GHCs core intermediate language. Currently +-- GHC uses System FC for this purpose, +-- which is closely related to the simpler and better known System F . +-- +-- We get from Haskell source to this Core language in a number of stages: +-- +-- 1. The source code is parsed into an abstract syntax tree, which is represented +-- by the data type 'GHC.Hs.Expr.HsExpr' with the names being 'GHC.Types.Name.Reader.RdrNames' +-- +-- 2. This syntax tree is /renamed/, which attaches a 'GHC.Types.Unique.Unique' to every 'GHC.Types.Name.Reader.RdrName' +-- (yielding a 'GHC.Types.Name.Name') to disambiguate identifiers which are lexically identical. +-- For example, this program: +-- +-- @ +-- f x = let f x = x + 1 +-- in f (x - 2) +-- @ +-- +-- Would be renamed by having 'Unique's attached so it looked something like this: +-- +-- @ +-- f_1 x_2 = let f_3 x_4 = x_4 + 1 +-- in f_3 (x_2 - 2) +-- @ +-- But see Note [Shadowing in Core] below. +-- +-- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating +-- type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'GHC.Types.Id.Id' as it's names. +-- +-- 4. Finally the syntax tree is /desugared/ from the expressive 'GHC.Hs.Expr.HsExpr' type into +-- this 'Expr' type, which has far fewer constructors and hence is easier to perform +-- optimization, analysis and code generation on. +-- +-- The type parameter @b@ is for the type of binders in the expression tree. +-- +-- The language consists of the following elements: +-- +-- * Variables +-- See Note [Variable occurrences in Core] +-- +-- * Primitive literals +-- +-- * Applications: note that the argument may be a 'Type'. +-- See Note [Representation polymorphism invariants] +-- +-- * Lambda abstraction +-- See Note [Representation polymorphism invariants] +-- +-- * Recursive and non recursive @let@s. Operationally +-- this corresponds to allocating a thunk for the things +-- bound and then executing the sub-expression. +-- +-- See Note [Core letrec invariant] +-- See Note [Core let-can-float invariant] +-- See Note [Representation polymorphism invariants] +-- See Note [Core type and coercion invariant] +-- +-- * Case expression. Operationally this corresponds to evaluating +-- the scrutinee (expression examined) to weak head normal form +-- and then examining at most one level of resulting constructor (i.e. you +-- cannot do nested pattern matching directly with this). +-- +-- The binder gets bound to the value of the scrutinee, +-- and the 'Type' must be that of all the case alternatives +-- +-- IMPORTANT: see Note [Case expression invariants] +-- +-- * Cast an expression to a particular type. +-- This is used to implement @newtype@s (a @newtype@ constructor or +-- destructor just becomes a 'Cast' in Core) and GADTs. +-- +-- * Ticks. These are used to represent all the source annotation we +-- support: profiling SCCs, HPC ticks, and GHCi breakpoints. +-- +-- * A type: this should only show up at the top level of an Arg +-- +-- * A coercion + +{- Note [Why does Case have a 'Type' field?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The obvious alternative is + exprType (Case scrut bndr alts) + | (_,_,rhs1):_ <- alts + = exprType rhs1 + +But caching the type in the Case constructor + exprType (Case scrut bndr ty alts) = ty +is better for at least three reasons: + +* It works when there are no alternatives (see case invariant 1 above) + +* It might be faster in deeply-nested situations. + +* It might not be quite the same as (exprType rhs) for one + of the RHSs in alts. Consider a phantom type synonym + type S a = Int + and we want to form the case expression + case x of { K (a::*) -> (e :: S a) } + Then exprType of the RHS is (S a), but we cannot make that be + the 'ty' in the Case constructor because 'a' is simply not in + scope there. Instead we must expand the synonym to Int before + putting it in the Case constructor. See GHC.Core.Utils.mkSingleAltCase. + + So we'd have to do synonym expansion in exprType which would + be inefficient. + +* The type stored in the case is checked with lintInTy. This checks + (among other things) that it does not mention any variables that are + not in scope. If we did not have the type there, it would be a bit + harder for Core Lint to reject case blah of Ex x -> x where + data Ex = forall a. Ex a. +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Expr b + = Var Id + | Lit Literal + | App (Expr b) (Arg b) + | Lam b (Expr b) + | Let (Bind b) (Expr b) + | Case (Expr b) b Type [Alt b] -- See Note [Case expression invariants] + -- and Note [Why does Case have a 'Type' field?] + | Cast (Expr b) CoercionR -- The Coercion has Representational role + | Tick CoreTickish (Expr b) + | Type Type + | Coercion Coercion + deriving Data + +-- | Type synonym for expressions that occur in function argument positions. +-- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not +type Arg b = Expr b + +-- | A case split alternative. Consists of the constructor leading to the alternative, +-- the variables bound from the constructor, and the expression to be executed given that binding. +-- The default alternative is @(DEFAULT, [], rhs)@ + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Alt b + = Alt AltCon [b] (Expr b) + deriving (Data) + +-- | A case alternative constructor (i.e. pattern match) + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data AltCon + = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@. + -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ + + | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ + -- Invariant: always an *unlifted* literal + -- See Note [Literal alternatives] + + | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@ + deriving (Eq, Data) + +-- This instance is a bit shady. It can only be used to compare AltCons for +-- a single type constructor. Fortunately, it seems quite unlikely that we'll +-- ever need to compare AltCons for different type constructors. +-- The instance adheres to the order described in Note [Case expression invariants] +instance Ord AltCon where + compare (DataAlt con1) (DataAlt con2) = + assert (dataConTyCon con1 == dataConTyCon con2) $ + compare (dataConTag con1) (dataConTag con2) + compare (DataAlt _) _ = GT + compare _ (DataAlt _) = LT + compare (LitAlt l1) (LitAlt l2) = compare l1 l2 + compare (LitAlt _) DEFAULT = GT + compare DEFAULT DEFAULT = EQ + compare DEFAULT _ = LT + +-- | Binding, used for top level bindings in a module and local bindings in a @let@. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Bind b = NonRec b (Expr b) + | Rec [(b, (Expr b))] + deriving Data + +-- | Helper function. You can use the result of 'mkBinds' with 'mkLets' for +-- instance. +-- +-- * @'mkBinds' 'Recursive' binds@ makes a single mutually-recursive +-- bindings with all the rhs/lhs pairs in @binds@ +-- * @'mkBinds' 'NonRecursive' binds@ makes one non-recursive binding +-- for each rhs/lhs pairs in @binds@ +mkBinds :: RecFlag -> [(b, (Expr b))] -> [Bind b] +mkBinds Recursive binds = [Rec binds] +mkBinds NonRecursive binds = map (uncurry NonRec) binds + +{- +Note [Literal alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal alternatives (LitAlt lit) are always for *un-lifted* literals. +We have one literal, a literal Integer, that is lifted, and we don't +allow in a LitAlt, because LitAlt cases don't do any evaluation. Also +(see #5603) if you say + case 3 of + IS x -> ... + IP _ -> ... + IN _ -> ... +(where IS, IP, IN are the constructors for Integer) we don't want the +simplifier calling findAlt with argument (LitAlt 3). No no. Integer +literals are an opaque encoding of an algebraic data type, not of +an unlifted literal, like all the others. + +Also, we do not permit case analysis with literal patterns on floating-point +types. See #9238 and Note [Rules for floating-point comparisons] in +GHC.Core.Opt.ConstantFold for the rationale for this restriction. + +-------------------------- GHC.Core INVARIANTS --------------------------- + +Note [Variable occurrences in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Variable /occurrences/ are never CoVars, though /bindings/ can be. +All CoVars appear in Coercions. + +For example + \(c :: Age~#Int) (d::Int). d |> (sym c) +Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in +a Coercion, (sym c). + +Note [Shadowing in Core] +~~~~~~~~~~~~~~~~~~~~~~~~ +You might wonder if there is an invariant that a Core expression has no +"shadowing". For example, is this illegal? + \x. \x. blah -- x is shadowed +Answer; no! Core does /not/ have a no-shadowing invariant. + +Neither the simplifier nor any other pass GUARANTEES that shadowing is +avoided. Thus, all passes SHOULD work fine even in the presence of +arbitrary shadowing in their inputs. + +So the Unique in a Var is not really unique at all. Still, it's very +useful to give a constant-time equality/ordering for Vars, and to give +a key that can be used to make sets of Vars (VarSet), or mappings from +Vars to other things (VarEnv). Moreover, if you do want to eliminate +shadowing, you can give a new Unique to an Id without changing its +printable name, which makes debugging easier. + +It would in many ways be easier to have a no-shadowing invariant. And the +Simplifier does its best to clone variables that are shadowed. But it is +extremely difficult to GUARANTEE it: + +* We use `GHC.Types.Id.mkTemplateLocal` to make up local binders, with uniques + that are locally-unique (enough for the purpose) but not globally unique. + It is convenient not to have to plumb a unique supply to these functions. + +* It is very difficult for the Simplifier to gurantee a no-shadowing result. + See Note [Shadowing in the Simplifier] in GHC.Core.Opt.Simplify.Iteration. + +* See Note [Shadowing in CSE] in GHC.Core.Opt.CSE + +* See Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecContr + +Note [Core letrec invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Core letrec invariant: + + The right hand sides of all /top-level/ or /recursive/ + bindings must be of lifted type + +See "Type#type_classification" in GHC.Core.Type +for the meaning of "lifted" vs. "unlifted". + +For the non-top-level, non-recursive case see +Note [Core let-can-float invariant]. + +At top level, however, there are two exceptions to this rule: + +(TL1) A top-level binding is allowed to bind primitive string literal, + (which is unlifted). See Note [Core top-level string literals]. + +(TL2) In Core, we generate a top-level binding for every non-newtype data +constructor worker or wrapper + e.g. data T = MkT Int + we generate + MkT :: Int -> T + MkT = \x. MkT x + (This binding looks recursive, but isn't; it defines a top-level, curried + function whose body just allocates and returns the data constructor.) + + But if (a) the data constructor is nullary and (b) the data type is unlifted, + this binding is unlifted. + e.g. data S :: UnliftedType where { S1 :: S, S2 :: S -> S } + we generate + S1 :: S -- A top-level unlifted binding + S1 = S1 + We allow this top-level unlifted binding to exist. + +Note [Core let-can-float invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The let-can-float invariant: + + The right hand side of a /non-top-level/, /non-recursive/ binding + may be of unlifted type, but only if + the expression is ok-for-speculation + or the 'Let' is for a join point. + + (For top-level or recursive lets see Note [Core letrec invariant].) + +This means that the let can be floated around +without difficulty. For example, this is OK: + + y::Int# = x +# 1# + +But this is not, as it may affect termination if the +expression is floated out: + + y::Int# = fac 4# + +In this situation you should use @case@ rather than a @let@. The function +'GHC.Core.Utils.needsCaseBinding' can help you determine which to generate, or +alternatively use 'GHC.Core.Make.mkCoreLet' rather than this constructor directly, +which will generate a @case@ if necessary + +The let-can-float invariant is initially enforced by mkCoreLet in GHC.Core.Make. + +Historical Note [The let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before 2022 GHC used the "let/app invariant", which applied the let-can-float rules +to the argument of an application, as well as to the RHS of a let. This made some +kind of sense, because 'let' can always be encoded as application: + let x=rhs in b = (\x.b) rhs + +But the let/app invariant got in the way of RULES; see #19313. For example + up :: Int# -> Int# + {-# RULES "up/down" forall x. up (down x) = x #-} +The LHS of this rule doesn't satisfy the let/app invariant. + +Indeed RULES is a big reason that GHC doesn't use ANF, where the argument of an +application is always a variable or a constant. To allow RULES to work nicely +we need to allow lots of things in the arguments of a call. + +TL;DR: we relaxed the let/app invariant to become the let-can-float invariant. + +Note [Core top-level string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As an exception to the usual rule that top-level binders must be lifted, +we allow binding primitive string literals (of type Addr#) at the +top level. This allows us to share string literals earlier in the pipeline and +crucially allows other optimizations in the Core2Core pipeline to fire. +Consider, + + f n = let a::Addr# = "foo"# + in \x -> blah + +In order to be able to inline `f`, we would like to float `a` to the top. +Another option would be to inline `a`, but that would lead to duplicating string +literals, which we want to avoid. See #8472. + +The solution is simply to allow top-level unlifted binders. We can't allow +arbitrary unlifted expression at the top-level though, unlifted binders cannot +be thunks, so we just allow string literals. + +We allow the top-level primitive string literals to be wrapped in Ticks +in the same way they can be wrapped when nested in an expression. +CoreToSTG currently discards Ticks around top-level primitive string literals. +See #14779. + +Also see Note [Compilation plan for top-level string literals]. + +Note [Compilation plan for top-level string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is a summary on how top-level string literals are handled by various +parts of the compilation pipeline. + +* In the source language, there is no way to bind a primitive string literal + at the top level. + +* In Core, we have a special rule that permits top-level Addr# bindings. See + Note [Core top-level string literals]. Core-to-core passes may introduce + new top-level string literals. + + See GHC.Core.Utils.exprIsTopLevelBindable, and exprIsTickedString + +* In STG, top-level string literals are explicitly represented in the syntax + tree. + +* A top-level string literal may end up exported from a module. In this case, + in the object file, the content of the exported literal is given a label with + the _bytes suffix. + +Note [NON-BOTTOM-DICTS invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is a global invariant (not checkable by Lint) that + + every non-newtype dictionary-typed expression is non-bottom. + +These conditions are captured by GHC.Core.Type.isTerminatingType. + +How are we so sure about this? Dictionaries are built by GHC in only two ways: + +* A dictionary function (DFun), arising from an instance declaration. + DFuns do no computation: they always return a data constructor immediately. + See DFunUnfolding in GHC.Core. So the result of a call to a DFun is always + non-bottom. + + Exception: newtype dictionaries. + + Plus: see the Very Nasty Wrinkle in Note [Speculative evaluation] + in GHC.CoreToStg.Prep + +* A superclass selection from some other dictionary. This is harder to guarantee: + see Note [Recursive superclasses] and Note [Solving superclass constraints] + in GHC.Tc.TyCl.Instance. + +A bad Core-to-Core pass could invalidate this reasoning, but that's too bad. +It's still an invariant of Core programs generated by GHC from Haskell, and +Core-to-Core passes maintain it. + +Why is it useful to know that dictionaries are non-bottom? + +1. It justifies the use of `-XDictsStrict`; + see `GHC.Core.Types.Demand.strictifyDictDmd` + +2. It means that (eq_sel d) is ok-for-speculation and thus + case (eq_sel d) of _ -> blah + can be discarded by the Simplifier. See these Notes: + Note [exprOkForSpeculation and type classes] in GHC.Core.Utils + Note[Speculative evaluation] in GHC.CoreToStg.Prep + +Note [Case expression invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case expressions are one of the more complicated elements of the Core +language, and come with a number of invariants. All of them should be +checked by Core Lint. + +1. The list of alternatives may be empty; + See Note [Empty case alternatives] + +2. The 'DEFAULT' case alternative must be first in the list, + if it occurs at all. Checked in GHC.Core.Lint.checkCaseAlts. + +3. The remaining cases are in order of (strictly) increasing + tag (for 'DataAlts') or + lit (for 'LitAlts'). + This makes finding the relevant constructor easy, and makes + comparison easier too. Checked in GHC.Core.Lint.checkCaseAlts. + +4. The list of alternatives must be exhaustive. An /exhaustive/ case + does not necessarily mention all constructors: + + @ + data Foo = Red | Green | Blue + ... case x of + Red -> True + other -> f (case x of + Green -> ... + Blue -> ... ) ... + @ + + The inner case does not need a @Red@ alternative, because @x@ + can't be @Red@ at that program point. + + This is not checked by Core Lint -- it's very hard to do so. + E.g. suppose that inner case was floated out, thus: + let a = case x of + Green -> ... + Blue -> ... ) + case x of + Red -> True + other -> f a + Now it's really hard to see that the Green/Blue case is + exhaustive. But it is. + + If you have a case-expression that really /isn't/ exhaustive, + we may generate seg-faults. Consider the Green/Blue case + above. Since there are only two branches we may generate + code that tests for Green, and if not Green simply /assumes/ + Blue (since, if the case is exhaustive, that's all that + remains). Of course, if it's not Blue and we start fetching + fields that should be in a Blue constructor, we may die + horribly. See also Note [Core Lint guarantee] in GHC.Core.Lint. + +5. Floating-point values must not be scrutinised against literals. + See #9238 and Note [Rules for floating-point comparisons] + in GHC.Core.Opt.ConstantFold for rationale. Checked in lintCaseExpr; + see the call to isFloatingPrimTy. + +6. The 'ty' field of (Case scrut bndr ty alts) is the type of the + /entire/ case expression. Checked in lintAltExpr. + See also Note [Why does Case have a 'Type' field?]. + +7. The type of the scrutinee must be the same as the type + of the case binder, obviously. Checked in lintCaseExpr. + +8. The multiplicity of the binders in constructor patterns must be the + multiplicity of the corresponding field /scaled by the multiplicity of the + case binder/. Checked in lintCoreAlt. + +Note [Core type and coercion invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow a /non-recursive/, /non-top-level/ let to bind type and +coercion variables. These can be very convenient for postponing type +substitutions until the next run of the simplifier. + +* A type variable binding must have a RHS of (Type ty) + +* A coercion variable binding must have a RHS of (Coercion co) + + It is possible to have terms that return a coercion, but we use + case-binding for those; e.g. + case (eq_sel d) of (co :: a ~# b) -> blah + where eq_sel :: (a~b) -> (a~#b) + + Or even + case (df @Int) of (co :: a ~# b) -> blah + Which is very exotic, and I think never encountered; but see + Note [Equality superclasses in quantified constraints] + in GHC.Tc.Solver.Dict + +Note [Representation polymorphism invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC allows us to abstract over calling conventions using **representation polymorphism**. +For example, we have: + + ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). (a -> b) -> a -> b + +In this example, the type `b` is representation-polymorphic: it has kind `TYPE r`, +where the type variable `r :: RuntimeRep` abstracts over the runtime representation +of values of type `b`. + +To ensure that programs containing representation-polymorphism remain compilable, +we enforce the following representation-polymorphism invariants: + +The paper "Levity Polymorphism" [PLDI'17] states the first two invariants: + + I1. The type of a bound variable must have a fixed runtime representation + (except for join points: See Note [Invariants on join points]) + I2. The type of a function argument must have a fixed runtime representation. + +Example of I1: + + \(r::RuntimeRep). \(a::TYPE r). \(x::a). e + + This contravenes I1 because x's type has kind (TYPE r), which has 'r' free. + We thus wouldn't know how to compile this lambda abstraction. + +Example of I2: + + f (undefined :: (a :: TYPE r)) + + This contravenes I2: we are applying the function `f` to a value + with an unknown runtime representation. + +Note that these two invariants require us to check other types than just the +types of bound variables and types of function arguments, due to transformations +that GHC performs. For example, the definition + + myCoerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b + myCoerce = coerce + +is invalid, because `coerce` has no binding (see GHC.Types.Id.Make.coerceId). +So, before code-generation, GHC saturates the RHS of 'myCoerce' by performing +an eta-expansion (see GHC.CoreToStg.Prep.maybeSaturate): + + myCoerce = \ (x :: TYPE r) -> coerce x + +However, this transformation would be invalid, because now the binding of x +in the lambda abstraction would violate I1. + +See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete +and Note [Linting representation-polymorphic builtins] in GHC.Core.Lint for +more details. + +Note that we currently require something slightly stronger than a fixed runtime +representation: we check whether bound variables and function arguments have a +/fixed RuntimeRep/ in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete +for an overview of how we enforce these invariants in the typechecker. + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The alternatives of a case expression should be exhaustive. But +this exhaustive list can be empty! + +* A case expression can have empty alternatives if (and only if) the + scrutinee is bound to raise an exception or diverge. When do we know + this? See Note [Bottoming expressions] in GHC.Core.Utils. + +* The possibility of empty alternatives is one reason we need a type on + the case expression: if the alternatives are empty we can't get the + type from the alternatives! + +* In the case of empty types (see Note [Bottoming expressions]), say + data T + we do NOT want to replace + case (x::T) of Bool {} --> error Bool "Inaccessible case" + because x might raise an exception, and *that*'s what we want to see! + (#6067 is an example.) To preserve semantics we'd have to say + x `seq` error Bool "Inaccessible case" + but the 'seq' is just such a case, so we are back to square 1. + +* We can use the empty-alternative construct to coerce error values from + one type to another. For example + + f :: Int -> Int + f n = error "urk" + + g :: Int -> (# Char, Bool #) + g x = case f x of { 0 -> ..., n -> ... } + + Then if we inline f in g's RHS we get + case (error Int "urk") of (# Char, Bool #) { ... } + and we can discard the alternatives since the scrutinee is bottom to give + case (error Int "urk") of (# Char, Bool #) {} + + This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #), + if for no other reason that we don't need to instantiate the (~) at an + unboxed type. + +* We treat a case expression with empty alternatives as trivial iff + its scrutinee is (see GHC.Core.Utils.exprIsTrivial). This is actually + important; see Note [Empty case is trivial] in GHC.Core.Utils + +* We lower empty cases in GHC.CoreToStg.coreToStgExpr to an eval on the + scrutinee. + +Historical Note: We used to lower EmptyCase in CorePrep by way of an +unsafeCoercion on the scrutinee, but that yielded panics in CodeGen when +we were beginning to eta expand in arguments, plus required to mess with +heterogenously-kinded coercions. It's simpler to stick to it just a bit longer. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +In Core, a *join point* is a specially tagged function whose only occurrences +are saturated tail calls. A tail call can appear in these places: + + 1. In the branches (not the scrutinee) of a case + 2. Underneath a let (value or join point) + 3. Inside another join point + +We write a join-point declaration as + join j @a @b x y = e1 in e2, +like a let binding but with "join" instead (or "join rec" for "let rec"). Note +that we put the parameters before the = rather than using lambdas; this is +because it's relevant how many parameters the join point takes *as a join +point.* This number is called the *join arity,* distinct from arity because it +counts types as well as values. Note that a join point may return a lambda! So + join j x = x + 1 +is different from + join j = \x -> x + 1 +The former has join arity 1, while the latter has join arity 0. + +The identifier for a join point is called a join id or a *label.* An invocation +is called a *jump.* We write a jump using the jump keyword: + + jump j 3 + +The words *label* and *jump* are evocative of assembly code (or Cmm) for a +reason: join points are indeed compiled as labeled blocks, and jumps become +actual jumps (plus argument passing and stack adjustment). There is no closure +allocated and only a fraction of the function-call overhead. Hence we would +like as many functions as possible to become join points (see OccurAnal) and +the type rules for join points ensure we preserve the properties that make them +efficient. + +In the actual AST, a join point is indicated by the IdDetails of the binder: a +local value binding gets 'VanillaId' but a join point gets a 'JoinId' with its +join arity. + +For more details, see the paper: + + Luke Maurer, Paul Downen, Zena Ariola, and Simon Peyton Jones. "Compiling + without continuations." Submitted to PLDI'17. + + https://www.microsoft.com/en-us/research/publication/compiling-without-continuations/ + +Note [Invariants on join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Join points must follow these invariants: + + 1. All occurrences must be tail calls. Each of these tail calls must pass the + same number of arguments, counting both types and values; we call this the + "join arity" (to distinguish from regular arity, which only counts values). + + See Note [Join points are less general than the paper] + + 2. For join arity n, the right-hand side must begin with at least n lambdas. + No ticks, no casts, just lambdas! C.f. GHC.Core.Utils.joinRhsArity. + + 2a. Moreover, this same constraint applies to any unfolding of + the binder. Reason: if we want to push a continuation into + the RHS we must push it into the unfolding as well. + + 2b. The Arity (in the IdInfo) of a join point varies independently of the + join-arity. For example, we could have + j x = case x of { T -> \y.y; F -> \y.3 } + Its join-arity is 1, but its idArity is 2; and we do not eta-expand + join points: see Note [Do not eta-expand join points] in + GHC.Core.Opt.Simplify.Utils. + + Allowing the idArity to be bigger than the join-arity is + important in arityType; see GHC.Core.Opt.Arity + Note [Arity for recursive join bindings] + + Historical note: see #17294. + + 3. If the binding is recursive, then all other bindings in the recursive group + must also be join points. + + 4. The binding's type must not be polymorphic in its return type (as defined + in Note [The polymorphism rule of join points]). + +However, join points have simpler invariants in other ways + + 5. A join point can have an unboxed type without the RHS being + ok-for-speculation (i.e. drop the let-can-float invariant) + e.g. let j :: Int# = factorial x in ... + + 6. The RHS of join point is not required to have a fixed runtime representation, + e.g. let j :: r :: TYPE l = fail (##) in ... + This happened in an intermediate program #13394 + +Examples: + + join j1 x = 1 + x in jump j (jump j x) -- Fails 1: non-tail call + join j1' x = 1 + x in if even a + then jump j1 a + else jump j1 a b -- Fails 1: inconsistent calls + join j2 x = flip (+) x in j2 1 2 -- Fails 2: not enough lambdas + join j2' x = \y -> x + y in j3 1 -- Passes: extra lams ok + join j @a (x :: a) = x -- Fails 4: polymorphic in ret type + +Invariant 1 applies to left-hand sides of rewrite rules, so a rule for a join +point must have an exact call as its LHS. + +Strictly speaking, invariant 3 is redundant, since a call from inside a lazy +binding isn't a tail call. Since a let-bound value can't invoke a free join +point, then, they can't be mutually recursive. (A Core binding group *can* +include spurious extra bindings if the occurrence analyser hasn't run, so +invariant 3 does still need to be checked.) For the rigorous definition of +"tail call", see Section 3 of the paper (Note [Join points]). + +Invariant 4 is subtle; see Note [The polymorphism rule of join points]. + +Invariant 6 is to enable code like this: + + f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). + join j :: a + j = error @r @a "bloop" + in case x of + A -> j + B -> j + C -> error @r @a "blurp" + +Core Lint will check these invariants, anticipating that any binder whose +OccInfo is marked AlwaysTailCalled will become a join point as soon as the +simplifier (or simpleOptPgm) runs. + +Note [Join points are less general than the paper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the paper "Compiling without continuations", this expression is +perfectly valid: + + join { j = \_ -> e } + in (case blah of ) + ( True -> j void# ) arg + ( False -> blah ) + +assuming 'j' has arity 1. Here the call to 'j' does not look like a +tail call, but actually everything is fine. See Section 3, "Managing \Delta" +in the paper. + +In GHC, however, we adopt a slightly more restrictive subset, in which +join point calls must be tail calls. I think we /could/ loosen it up, but +in fact the simplifier ensures that we always get tail calls, and it makes +the back end a bit easier I think. Generally, just less to think about; +nothing deeper than that. + +Note [The type of a join point] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A join point has the same type it would have as a function. That is, if it takes +an Int and a Bool and its body produces a String, its type is `Int -> Bool -> +String`. Natural as this may seem, it can be awkward. A join point shouldn't be +thought to "return" in the same sense a function does---a jump is one-way. This +is crucial for understanding how case-of-case interacts with join points: + + case (join + j :: Int -> Bool -> String + j x y = ... + in + jump j z w) of + "" -> True + _ -> False + +The simplifier will pull the case into the join point (see Note [Join points +and case-of-case] in GHC.Core.Opt.Simplify): + + join + j :: Int -> Bool -> Bool -- changed! + j x y = case ... of "" -> True + _ -> False + in + jump j z w + +The body of the join point now returns a Bool, so the label `j` has to +have its type updated accordingly, which is done by +GHC.Core.Opt.Simplify.Env.adjustJoinPointType. Inconvenient though +this may be, it has the advantage that 'GHC.Core.Utils.exprType' can +still return a type for any expression, including a jump. + +Relationship to the paper + +This plan differs from the paper (see Note [Invariants on join +points]). In the paper, we instead give j the type `Int -> Bool -> +forall a. a`. Then each jump carries the "return type" as a parameter, +exactly the way other non-returning functions like `error` work: + + case (join + j :: Int -> Bool -> forall a. a + j x y = ... + in + jump j z w @String) of + "" -> True + _ -> False + +Now we can move the case inward and we only have to change the jump: + + join + j :: Int -> Bool -> forall a. a + j x y = case ... of "" -> True + _ -> False + in + jump j z w @Bool + +(Core Lint would still check that the body of the join point has the right type; +that type would simply not be reflected in the join id.) + +Note [The polymorphism rule of join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant 4 of Note [Invariants on join points] forbids a join point to be +polymorphic in its return type. That is, if its type is + + forall a1 ... ak. t1 -> ... -> tn -> r + +where its join arity is k+n, none of the type parameters ai may occur free in r. + +In some way, this falls out of the fact that given + + join + j @a1 ... @ak x1 ... xn = e1 + in e2 + +then all calls to `j` are in tail-call positions of `e`, and expressions in +tail-call positions in `e` have the same type as `e`. +Therefore the type of `e1` -- the return type of the join point -- must be the +same as the type of e2. +Since the type variables aren't bound in `e2`, its type can't include them, and +thus neither can the type of `e1`. + +This unfortunately prevents the `go` in the following code from being a +join-point: + + iter :: forall a. Int -> (a -> a) -> a -> a + iter @a n f x = go @a n f x + where + go :: forall a. Int -> (a -> a) -> a -> a + go @a 0 _ x = x + go @a n f x = go @a (n-1) f (f x) + +In this case, a static argument transformation would fix that (see +ticket #14620): + + iter :: forall a. Int -> (a -> a) -> a -> a + iter @a n f x = go' @a n f x + where + go' :: Int -> (a -> a) -> a -> a + go' 0 _ x = x + go' n f x = go' (n-1) f (f x) + +In general, loopification could be employed to do that (see #14068.) + +Can we simply drop the requirement, and allow `go` to be a join-point? We +could, and it would work. But we could not longer apply the case-of-join-point +transformation universally. This transformation would do: + + case (join go @a n f x = case n of 0 -> x + n -> go @a (n-1) f (f x) + in go @Bool n neg True) of + True -> e1; False -> e2 + + ===> + + join go @a n f x = case n of 0 -> case x of True -> e1; False -> e2 + n -> go @a (n-1) f (f x) + in go @Bool n neg True + +but that is ill-typed, as `x` is type `a`, not `Bool`. + + +This also justifies why we do not consider the `e` in `e |> co` to be in +tail position: A cast changes the type, but the type must be the same. But +operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for +ideas how to fix this. + +Note [Strict fields in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Core, evaluating a data constructor worker evaluates its strict fields. + +In other words, let's say we have the following data type + + data T a b = MkT !a b + +Now if `xs` reduces to `error "boom"`, then `MkT xs b` will throw that error. +Consequently, it is sound to seq the field before the call to the constructor, +e.g., with `case xs of xs' { __DEFAULT -> MkT xs' b }`. +Let's call this transformation "field eval insertion". + +Note in particular that the data constructor application `MkT xs b` above is +*not* a value, unless `xs` is! + +This has pervasive effect on the Core pipeline: + +(SFC1) `exprIsHNF`/`exprIsConLike`/`exprOkForSpeculation` need to assert that the + strict arguments of a DataCon worker are values/ok-for-spec themselves. + +(SFC2) `exprIsConApp_maybe` inserts field evals in the `FloatBind`s it returns, so + that the Simplifier, Constant-folding, the pattern-match checker, etc. all + see the inserted field evals when they match on strict workers. + + For example, + exprIsConApp_maybe (MkT e1 e2) + = Just ([FloatCase e1 x], MkT, [x,e2]) + Meaning that (MkT e1 e2) is indeed a data constructor application, but if + you want to decompose it (which is the purpose of exprIsConApp_maybe) you + must evaluate e1 first. + In case of case-of-known constructor, we get the rewrite + case MkT e1 e2 of MkT xs' b' -> b' + ==> + case e1 of xs' { __DEFAULT -> e2 } + which crucially retains the eval on e1. + +(SFC3) The demand signature of a data constructor is strict in strict field + position and lazy in non-strict fields. Likewise the demand *transformer* + of a DataCon worker can stricten up demands on strict field args. + See Note [Demand transformer for data constructors]. + +(SFC4) In the absence of `-fpedantic-bottoms`, it is still possible that some seqs + are ultimately dropped or delayed due to eta-expansion. + See Note [Dealing with bottom]. + +Strict field semantics is exploited and lowered in STG during EPT enforcement; +see Note [EPT enforcement lowers strict constructor worker semantics] for the +connection. + +It might be tempting to think that strict fields could be implemented in terms +of unlifted fields. However, unlifted fields behave differently when the data +constructor is partially applied; see Note [exprIsHNF for function applications] +for an example. + +Historical Note: +The delightfully simple description of strict field semantics is the result of +a long saga (#20749, the bits about strict data constructors in #21497, #22475), +where we tried a more lenient (but actually not) semantics first that would +allow both strict and lazy implementations of DataCon workers. This was favoured +because the "pervasive effect" throughout the compiler was deemed too large +(when it really turned out to be quite modest). +Alas, this semantics would require us to implement `exprIsHNF` in *exactly* the +same way as above, otherwise the analysis would not be conservative wrt. the +lenient semantics (which includes the strict one). It is also much harder to +explain and maintain, as it turned out. + +************************************************************************ +* * + In/Out type synonyms +* * +********************************************************************* -} + +{- Many passes apply a substitution, and it's very handy to have type + synonyms to remind us whether or not the substitution has been applied -} + +-- Pre-cloning or substitution +type InBndr = CoreBndr +type InType = Type +type InKind = Kind +type InBind = CoreBind +type InExpr = CoreExpr +type InAlt = CoreAlt +type InArg = CoreArg +type InCoercion = Coercion + +-- Post-cloning or substitution +type OutBndr = CoreBndr +type OutType = Type +type OutKind = Kind +type OutCoercion = Coercion +type OutBind = CoreBind +type OutExpr = CoreExpr +type OutAlt = CoreAlt +type OutArg = CoreArg +type MOutCoercion = MCoercion + + +{- +************************************************************************ +* * + Orphans +* * +************************************************************************ +-} + +-- | Is this instance an orphan? If it is not an orphan, contains an 'OccName' +-- witnessing the instance's non-orphanhood. +-- See Note [Orphans] +data IsOrphan + = IsOrphan + | NotOrphan !OccName -- The OccName 'n' witnesses the instance's non-orphanhood + -- In that case, the instance is fingerprinted as part + -- of the definition of 'n's definition + deriving Data + +-- | Returns true if 'IsOrphan' is orphan. +isOrphan :: IsOrphan -> Bool +isOrphan IsOrphan = True +isOrphan _ = False + +-- | Returns true if 'IsOrphan' is not an orphan. +notOrphan :: IsOrphan -> Bool +notOrphan NotOrphan{} = True +notOrphan _ = False + +chooseOrphanAnchor :: NameSet -> IsOrphan +-- Something (rule, instance) is relate to all the Names in this +-- list. Choose one of them to be an "anchor" for the orphan. We make +-- the choice deterministic to avoid gratuitous changes in the ABI +-- hash (#4012). Specifically, use lexicographic comparison of +-- OccName rather than comparing Uniques +-- +-- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically +-- +chooseOrphanAnchor local_names = case nonEmpty $ nonDetEltsUniqSet local_names of + Nothing -> IsOrphan + Just local_names -> NotOrphan (minimum (NE.map nameOccName local_names)) + -- It's OK to use nonDetEltsUFM here, see comments above + +instance Binary IsOrphan where + put_ bh IsOrphan = putByte bh 0 + put_ bh (NotOrphan n) = do + putByte bh 1 + put_ bh n + get bh = do + h <- getByte bh + case h of + 0 -> return IsOrphan + _ -> do + n <- get bh + return $ NotOrphan n + +instance NFData IsOrphan where + rnf IsOrphan = () + rnf (NotOrphan n) = rnf n + +{- +Note [Orphans] +~~~~~~~~~~~~~~ +Class instances, rules, and family instances are divided into orphans +and non-orphans. Roughly speaking, an instance/rule is an orphan if +its left hand side mentions nothing defined in this module. Orphan-hood +has two major consequences + + * A module that contains orphans is called an "orphan module". If + the module being compiled depends (transitively) on an orphan + module M, then M.hi is read in regardless of whether M is otherwise + needed. This is to ensure that we don't miss any instance decls in + M. But it's painful, because it means we need to keep track of all + the orphan modules below us. + + * The "visible orphan modules" are all the orphan module in the transitive + closure of the imports of this module. + + * During instance lookup, we filter orphan instances depending on + whether or not the instance is in a visible orphan module. + + * A non-orphan is not finger-printed separately. Instead, for + fingerprinting purposes it is treated as part of the entity it + mentions on the LHS. For example + data T = T1 | T2 + instance Eq T where .... + The instance (Eq T) is incorporated as part of T's fingerprint. + + In contrast, orphans are all fingerprinted together in the + mi_orph_hash field of the ModIface. + + See GHC.Iface.Recomp.addFingerprints. + +Orphan-hood is computed + * For class instances: + when we make a ClsInst in GHC.Core.InstEnv.mkLocalClsInst + (because it is needed during instance lookup) + See Note [When exactly is an instance decl an orphan?] + in GHC.Core.InstEnv + + * For rules + when we generate a CoreRule (GHC.Core.Rules.mkRule) + + * For family instances: + when we generate an IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst) + +Orphan-hood is persisted into interface files, in ClsInst, FamInst, +and CoreRules. + +-} + +{- +************************************************************************ +* * +\subsection{Rewrite rules} +* * +************************************************************************ + +The CoreRule type and its friends are dealt with mainly in GHC.Core.Rules, but +GHC.Core.FVs, GHC.Core.Subst, GHC.Core.Ppr, GHC.Core.Tidy also inspect the +representation. +-} + + +-- | A 'CoreRule' is: +-- +-- * \"Local\" if the function it is a rule for is defined in the +-- same module as the rule itself. +-- +-- * \"Orphan\" if nothing on the LHS is defined in the same module +-- as the rule itself +data CoreRule + = Rule { + ru_name :: RuleName, -- ^ Name of the rule, for communication with the user + ru_act :: Activation, -- ^ When the rule is active + + -- Rough-matching stuff + -- see comments with InstEnv.ClsInst( is_cls, is_rough ) + ru_fn :: !Name, -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule + ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side + + -- Proper-matching stuff + -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) + ru_bndrs :: [CoreBndr], -- ^ Variables quantified over + ru_args :: [CoreExpr], -- ^ Left hand side arguments + + -- And the right-hand side + ru_rhs :: CoreExpr, -- ^ Right hand side of the rule + -- Occurrence info is guaranteed correct + -- See Note [OccInfo in unfoldings and rules] + + -- Locality + ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated + -- (notably by Specialise or SpecConstr) + -- @False@ <=> generated at the user's behest + -- See Note [Trimming auto-rules] in "GHC.Iface.Tidy" + -- for the sole purpose of this field. + + ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used + -- to test if we should see an orphan rule. + + ru_orphan :: !IsOrphan, -- ^ Whether or not the rule is an orphan. + + ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is + -- defined in the same module as the rule + -- and is not an implicit 'Id' (like a record selector, + -- class operation, or data constructor). This + -- is different from 'ru_orphan', where a rule + -- can avoid being an orphan if *any* Name in + -- LHS of the rule was defined in the same + -- module as the rule. + } + + -- | Built-in rules are used for constant folding + -- and suchlike. They have no free variables. + -- A built-in rule is always visible (there is no such thing as + -- an orphan built-in rule.) + | BuiltinRule { + ru_name :: RuleName, -- ^ As above + ru_fn :: Name, -- ^ As above + ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, + -- if it fires, including type arguments + ru_try :: RuleFun + -- ^ This function does the rewrite. It given too many + -- arguments, it simply discards them; the returned 'CoreExpr' + -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args + } + -- See Note [Extra args in the target] in GHC.Core.Rules + +type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr + +-- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are +-- currently in scope. See Note [The InScopeSet invariant]. +data InScopeEnv = ISE InScopeSet IdUnfoldingFun + +type IdUnfoldingFun = Id -> Unfolding +-- A function that embodies how to unfold an Id if you need +-- to do that in the Rule. The reason we need to pass this info in +-- is that whether an Id is unfoldable depends on the simplifier phase + +isBuiltinRule :: CoreRule -> Bool +isBuiltinRule (BuiltinRule {}) = True +isBuiltinRule _ = False + +isAutoRule :: CoreRule -> Bool +isAutoRule (BuiltinRule {}) = False +isAutoRule (Rule { ru_auto = is_auto }) = is_auto + +-- | The number of arguments the 'ru_fn' must be applied +-- to before the rule can match on it +ruleArity :: CoreRule -> FullArgCount +ruleArity (BuiltinRule {ru_nargs = n}) = n +ruleArity (Rule {ru_args = args}) = length args + +ruleName :: CoreRule -> RuleName +ruleName = ru_name + +ruleModule :: CoreRule -> Maybe Module +ruleModule Rule { ru_origin } = Just ru_origin +ruleModule BuiltinRule {} = Nothing + +ruleActivation :: CoreRule -> Activation +ruleActivation (BuiltinRule { }) = AlwaysActive +ruleActivation (Rule { ru_act = act }) = act + +-- | The 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side +ruleIdName :: CoreRule -> Name +ruleIdName = ru_fn + +isLocalRule :: CoreRule -> Bool +isLocalRule (BuiltinRule {}) = False +isLocalRule (Rule { ru_local = is_local }) = is_local + +-- | Set the 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side +setRuleIdName :: Name -> CoreRule -> CoreRule +setRuleIdName nm ru = ru { ru_fn = nm } + +{- +************************************************************************ +* * + Unfoldings +* * +************************************************************************ + +The @Unfolding@ type is declared here to avoid numerous loops + +Note [Never put `OtherCon` unfoldings on lambda binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Based on #21496 we never attach unfoldings of any kind to lambda binders. +It's just too easy for the call site to change and invalidate the unfolding. +E.g. the caller of the lambda drops a seq (e.g. because the lambda is strict in it's binder) +which in turn makes the OtherCon[] unfolding a lie. +So unfoldings on lambda binders can never really be trusted when on lambda binders if there +is the chance of the call site to change. So it's easiest to just never attach any +to lambda binders to begin with, as well as stripping them off if we e.g. float out +and expression while abstracting over some arguments. +-} + +-- | Records the /unfolding/ of an identifier, which is approximately the form the +-- identifier would have if we substituted its definition in for the identifier. +-- This type should be treated as abstract everywhere except in "GHC.Core.Unfold" +data Unfolding + = NoUnfolding -- ^ We have no information about the unfolding. + + | BootUnfolding -- ^ We have no information about the unfolding, because + -- this 'Id' came from an @hi-boot@ file. + -- See Note [Inlining and hs-boot files] in "GHC.CoreToIface" + -- for what this is used for. + + | OtherCon [AltCon] -- ^ It ain't one of these constructors. + -- @OtherCon xs@ also indicates that something has been evaluated + -- and hence there's no point in re-evaluating it. + -- @OtherCon []@ is used even for non-data-type values + -- to indicated evaluated-ness. Notably: + -- + -- > data C = C !(Int -> Int) + -- > case x of { C f -> ... } + -- + -- Here, @f@ gets an @OtherCon []@ unfolding. + + | DFunUnfolding { -- The Unfolding of a DFunId + -- See Note [DFun unfoldings] + -- df = /\a1..am. \d1..dn. MkD t1 .. tk + -- (op1 a1..am d1..dn) + -- (op2 a1..am d1..dn) + df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] + df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) + df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, + } -- in positional order + + | CoreUnfolding { -- An unfolding for an Id with no pragma, + -- or perhaps a NOINLINE pragma + -- (For NOINLINE, the phase, if any, is in the + -- InlinePragInfo for this Id.) + uf_tmpl :: CoreExpr, -- The unfolding itself (aka "template") + -- Always occ-analysed; + -- See Note [OccInfo in unfoldings and rules] + + uf_src :: UnfoldingSource, -- Where the unfolding came from + uf_is_top :: Bool, -- True <=> top level binding + uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr + -- See Note [Tying the 'CoreUnfolding' knot] + uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. + } + -- ^ An unfolding with redundant cached information. Parameters: + -- + -- uf_tmpl: Template used to perform unfolding; + -- NB: Occurrence info is guaranteed correct: + -- see Note [OccInfo in unfoldings and rules] + -- + -- uf_is_top: Is this a top level binding? + -- + -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on + -- this variable + -- + -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? + -- Basically this is a cached version of 'exprIsWorkFree' + -- + -- uf_guidance: Tells us about the /size/ of the unfolding template + + +-- | Properties of a 'CoreUnfolding' that could be computed on-demand from its template. +-- See Note [UnfoldingCache] +data UnfoldingCache + = UnfoldingCache { + uf_is_value :: !Bool, -- exprIsHNF template (cached); it is ok to discard + -- a `seq` on this variable + uf_is_conlike :: !Bool, -- True <=> applicn of constructor or CONLIKE function + -- Cached version of exprIsConLike + uf_is_work_free :: !Bool, -- True <=> doesn't waste (much) work to expand + -- inside an inlining + -- Cached version of exprIsCheap + uf_expandable :: !Bool -- True <=> can expand in RULE matching + -- Cached version of exprIsExpandable + } + deriving (Eq) + +-- | 'UnfoldingGuidance' says when unfolding should take place +data UnfoldingGuidance + = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl + -- Used (a) for small *and* cheap unfoldings + -- (b) for INLINE functions + -- See Note [INLINE for small functions] in GHC.Core.Unfold + ug_arity :: Arity, -- Number of value arguments expected + + ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated + ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring + -- So True,True means "always" + } + + | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the + -- result of a simple analysis of the RHS + + ug_args :: [Int], -- Discount if the argument is evaluated. + -- (i.e., a simplification will definitely + -- be possible). One elt of the list per *value* arg. + + ug_size :: Int, -- The "size" of the unfolding. + + ug_res :: Int -- Scrutinee discount: the discount to subtract if the thing is in + } -- a context (case (thing args) of ...), + -- (where there are the right number of arguments.) + + | UnfNever -- The RHS is big, so don't inline it + deriving (Eq) + +{- Note [UnfoldingCache] +~~~~~~~~~~~~~~~~~~~~~~~~ +The UnfoldingCache field of an Unfolding holds four (strict) booleans, +all derived from the uf_tmpl field of the unfolding. + +* We serialise the UnfoldingCache to and from interface files, for + reasons described in Note [Tying the 'CoreUnfolding' knot] in + GHC.IfaceToCore + +* Because it is a strict data type, we must be careful not to + pattern-match on it until we actually want its values. E.g + GHC.Core.Unfold.callSiteInline/tryUnfolding are careful not to force + it unnecessarily. Just saves a bit of work. + +* When `seq`ing Core to eliminate space leaks, to suffices to `seq` on + the cache, but not its fields, because it is strict in all fields. + +Note [Historical note: unfoldings for wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have a nice clever scheme in interface files for +wrappers. A wrapper's unfolding can be reconstructed from its worker's +id and its strictness. This decreased .hi file size (sometimes +significantly, for modules like GHC.Classes with many high-arity w/w +splits) and had a slight corresponding effect on compile times. + +However, when we added the second demand analysis, this scheme lead to +some Core lint errors. The second analysis could change the strictness +signatures, which sometimes resulted in a wrapper's regenerated +unfolding applying the wrapper to too many arguments. + +Instead of repairing the clever .hi scheme, we abandoned it in favor +of simplicity. The .hi sizes are usually insignificant (excluding the ++1M for base libraries), and compile time barely increases (~+1% for +nofib). The nicer upshot is that the UnfoldingSource no longer mentions +an Id, so, eg, substitutions need not traverse them. + + +Note [DFun unfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The Arity in a DFunUnfolding is total number of args (type and value) +that the DFun needs to produce a dictionary. That's not necessarily +related to the ordinary arity of the dfun Id, esp if the class has +one method, so the dictionary is represented by a newtype. Example + + class C a where { op :: a -> Int } + instance C a -> C [a] where op xs = op (head xs) + +The instance translates to + + $dfCList :: forall a. C a => C [a] -- Arity 2! + $dfCList = /\a.\d. $copList {a} d |> co + + $copList :: forall a. C a => [a] -> Int -- Arity 2! + $copList = /\a.\d.\xs. op {a} d (head xs) + +Now we might encounter (op (dfCList {ty} d) a1 a2) +and we want the (op (dfList {ty} d)) rule to fire, because $dfCList +has all its arguments, even though its (value) arity is 2. That's +why we record the number of expected arguments in the DFunUnfolding. + +Note that although it's an Arity, it's most convenient for it to give +the *total* number of arguments, both type and value. See the use +site in exprIsConApp_maybe. +-} + +-- Constants for the UnfWhen constructor +needSaturated, unSaturatedOk :: Bool +needSaturated = False +unSaturatedOk = True + +boringCxtNotOk, boringCxtOk :: Bool +boringCxtOk = True +boringCxtNotOk = False + +------------------------------------------------ +noUnfolding :: Unfolding +-- ^ There is no known 'Unfolding' +evaldUnfolding :: Unfolding +-- ^ This unfolding marks the associated thing as being evaluated + +noUnfolding = NoUnfolding +evaldUnfolding = OtherCon [] + +-- | There is no known 'Unfolding', because this came from an +-- hi-boot file. +bootUnfolding :: Unfolding +bootUnfolding = BootUnfolding + +mkOtherCon :: [AltCon] -> Unfolding +mkOtherCon = OtherCon + +-- | Retrieves the template of an unfolding if possible +-- maybeUnfoldingTemplate is used mainly when specialising, and we do +-- want to specialise DFuns, so it's important to return a template +-- for DFunUnfoldings +maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr +maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) + = Just expr +maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args)) +maybeUnfoldingTemplate _ + = Nothing + +-- | The constructors that the unfolding could never be: +-- returns @[]@ if no information is available +otherCons :: Unfolding -> [AltCon] +otherCons (OtherCon cons) = cons +otherCons _ = [] + +-- | Determines if it is certainly the case that the unfolding will +-- yield a value (something in HNF): returns @False@ if unsure +isValueUnfolding :: Unfolding -> Bool + -- Returns False for OtherCon +isValueUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache +isValueUnfolding (DFunUnfolding {}) = True +isValueUnfolding _ = False + +-- | Determines if it possibly the case that the unfolding will +-- yield a value. Unlike 'isValueUnfolding' it returns @True@ +-- for 'OtherCon' +isEvaldUnfolding :: Unfolding -> Bool + -- Returns True for OtherCon +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (DFunUnfolding {}) = True +isEvaldUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache +isEvaldUnfolding _ = False + +-- | @True@ if the unfolding is a constructor application, the application +-- of a CONLIKE function or 'OtherCon' +isConLikeUnfolding :: Unfolding -> Bool +isConLikeUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_conlike cache +isConLikeUnfolding _ = False + +-- | Is the thing we will unfold into certainly cheap? +isCheapUnfolding :: Unfolding -> Bool +isCheapUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_work_free cache +isCheapUnfolding _ = False + +isExpandableUnfolding :: Unfolding -> Bool +isExpandableUnfolding (CoreUnfolding { uf_cache = cache }) = uf_expandable cache +isExpandableUnfolding _ = False + +expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr +-- Expand an expandable unfolding; this is used in rule matching +-- See Note [Expanding variables] in GHC.Core.Rules +-- The key point here is that CONLIKE things can be expanded +expandUnfolding_maybe (CoreUnfolding { uf_cache = cache, uf_tmpl = rhs }) + | uf_expandable cache + = Just rhs +expandUnfolding_maybe _ = Nothing + +isCompulsoryUnfolding :: Unfolding -> Bool +isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src +isCompulsoryUnfolding _ = False + +isStableUnfolding :: Unfolding -> Bool +-- True of unfoldings that should not be overwritten +-- by a CoreUnfolding for the RHS of a let-binding +isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src +isStableUnfolding (DFunUnfolding {}) = True +isStableUnfolding _ = False + +isStableUserUnfolding :: Unfolding -> Bool +-- True of unfoldings that arise from an INLINE or INLINEABLE pragma +isStableUserUnfolding (CoreUnfolding { uf_src = src }) = isStableUserSource src +isStableUserUnfolding _ = False + +isStableSystemUnfolding :: Unfolding -> Bool +-- True of unfoldings that arise from an INLINE or INLINEABLE pragma +isStableSystemUnfolding (CoreUnfolding { uf_src = src }) = isStableSystemSource src +isStableSystemUnfolding _ = False + +isInlineUnfolding :: Unfolding -> Bool +-- ^ True of a /stable/ unfolding that is +-- (a) always inlined; that is, with an `UnfWhen` guidance, or +-- (b) a DFunUnfolding which never needs to be inlined +isInlineUnfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) + | isStableSource src + , UnfWhen {} <- guidance + = True + +isInlineUnfolding (DFunUnfolding {}) + = True + +-- Default case +isInlineUnfolding _ = False + + +-- | Only returns False if there is no unfolding information available at all +hasSomeUnfolding :: Unfolding -> Bool +hasSomeUnfolding NoUnfolding = False +hasSomeUnfolding BootUnfolding = False +hasSomeUnfolding _ = True + +isBootUnfolding :: Unfolding -> Bool +isBootUnfolding BootUnfolding = True +isBootUnfolding _ = False + +neverUnfoldGuidance :: UnfoldingGuidance -> Bool +neverUnfoldGuidance UnfNever = True +neverUnfoldGuidance _ = False + +hasCoreUnfolding :: Unfolding -> Bool +-- An unfolding "has Core" if it contains a Core expression, which +-- may mention free variables. See Note [Fragile unfoldings] +hasCoreUnfolding (CoreUnfolding {}) = True +hasCoreUnfolding (DFunUnfolding {}) = True +hasCoreUnfolding _ = False + -- NoUnfolding, BootUnfolding, OtherCon have no Core + +canUnfold :: Unfolding -> Bool +canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) +canUnfold _ = False + +isBetterUnfoldingThan :: Unfolding -> Unfolding -> Bool +-- See Note [Better unfolding] +isBetterUnfoldingThan NoUnfolding _ = False +isBetterUnfoldingThan BootUnfolding _ = False + +isBetterUnfoldingThan (CoreUnfolding {uf_cache = uc1}) unf2 + = case unf2 of + CoreUnfolding {uf_cache = uc2} -> uf_is_value uc1 && not (uf_is_value uc2) + OtherCon _ -> uf_is_value uc1 + _ -> True + -- Default case: CoreUnfolding better than NoUnfolding etc + -- Better than DFunUnfolding? I don't care. + +isBetterUnfoldingThan (DFunUnfolding {}) unf2 + | DFunUnfolding {} <- unf2 = False + | otherwise = True + +isBetterUnfoldingThan (OtherCon cs1) unf2 + = case unf2 of + CoreUnfolding {uf_cache = uc} -- If unf1 is OtherCon and unf2 is + -> not (uf_is_value uc) -- just a thunk, unf1 is better + + OtherCon cs2 -> not (null cs1) && null cs2 -- A bit crude + DFunUnfolding {} -> False + NoUnfolding -> True + BootUnfolding -> True + +{- Note [Fragile unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An unfolding is "fragile" if it mentions free variables (and hence would +need substitution) or might be affected by optimisation. The non-fragile +ones are + + NoUnfolding, BootUnfolding + + OtherCon {} If we know this binder (say a lambda binder) will be + bound to an evaluated thing, we want to retain that + info in simpleOptExpr; see #13077. + +We consider even a StableUnfolding as fragile, because it needs substitution. + +Note [Better unfolding] +~~~~~~~~~~~~~~~~~~~~~~~ +(unf1 `isBetterUnfoldingThan` unf2) is used when we have + let x = in -- unf2 + let $j y = ...x... + in case x of + K a -> ...$j v.... + +At the /call site/ of $j, `x` has a better unfolding than it does at the +/defnition site/ of $j; so we are keener to inline $j. See +Note [Inlining join points] in GHC.Core.Opt.Simplify.Inline for discussion. + +The notion of "better" is encapsulated here. + +Note [Stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~ +When you say + {-# INLINE f #-} + f x = +you intend that calls (f e) are replaced by [e/x] So we +should capture (\x.) in the Unfolding of 'f', and never meddle +with it. Meanwhile, we can optimise to our heart's content, +leaving the original unfolding intact in Unfolding of 'f'. For example + all xs = foldr (&&) True xs + any p = all . map p {-# INLINE any #-} +We optimise any's RHS fully, but leave the stable unfolding for `any` +saying "all . map p", which deforests well at the call site. + +So INLINE pragma gives rise to a stable unfolding, which captures the +original RHS. + +Moreover, it's only used when 'f' is applied to the +specified number of arguments; that is, the number of argument on +the LHS of the '=' sign in the original source definition. +For example, (.) is now defined in the libraries like this + {-# INLINE (.) #-} + (.) f g = \x -> f (g x) +so that it'll inline when applied to two arguments. If 'x' appeared +on the left, thus + (.) f g x = f (g x) +it'd only inline when applied to three arguments. This slightly-experimental +change was requested by Roman, but it seems to make sense. + +Note [OccInfo in unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In unfoldings and rules, we guarantee that the template is occ-analysed, so +that the occurrence info on the binders is correct. That way, when the +Simplifier inlines an unfolding, it doesn't need to occ-analysis it first. +(The Simplifier is designed to simplify occ-analysed expressions.) + +Given this decision it's vital that we do *always* do it. + +* If we don't, we may get more simplifier iterations than necessary, + because once-occ info isn't there + +* More seriously, we may get an infinite loop if there's a Rec without a + loop breaker marked. + +* Or we may get code that mentions variables not in scope: #22761 + e.g. Suppose we have a stable unfolding : \y. let z = p+1 in 3 + Then the pre-simplifier occ-anal will occ-anal the unfolding + (redundantly perhaps, but we need its free vars); this will not report + the use of `p`; so p's binding will be discarded, and yet `p` is still + mentioned. + + Better to occ-anal the unfolding at birth, which will drop the + z-binding as dead code. (Remember, it's the occurrence analyser that + drops dead code.) + +* Another example is #8892: + \x -> letrec { f = ...g...; g* = f } in body + where g* is (for some strange reason) the loop breaker. If we don't + occ-anal it when reading it in, we won't mark g as a loop breaker, and we + may inline g entirely in body, dropping its binding, and leaving the + occurrence in f out of scope. This happened in #8892, where the unfolding + in question was a DFun unfolding. + + +************************************************************************ +* * + AltCon +* * +************************************************************************ +-} + +-- The Ord is needed for the FiniteMap used in the lookForConstructor +-- in GHC.Core.Opt.Simplify.Env. If you declared that lookForConstructor +-- *ignores* constructor-applications with LitArg args, then you could get rid +-- of this Ord. + +instance Outputable AltCon where + ppr (DataAlt dc) = ppr dc + ppr (LitAlt lit) = ppr lit + ppr DEFAULT = text "__DEFAULT" + +cmpAlt :: Alt a -> Alt a -> Ordering +cmpAlt (Alt con1 _ _) (Alt con2 _ _) = con1 `cmpAltCon` con2 + +ltAlt :: Alt a -> Alt a -> Bool +ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT + +cmpAltCon :: AltCon -> AltCon -> Ordering +-- ^ Compares 'AltCon's within a single list of alternatives +-- DEFAULT comes out smallest, so that sorting by AltCon puts +-- alternatives in the order required: see Note [Case expression invariants] +cmpAltCon DEFAULT DEFAULT = EQ +cmpAltCon DEFAULT _ = LT + +cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2 +cmpAltCon (DataAlt _) DEFAULT = GT +cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2 +cmpAltCon (LitAlt _) DEFAULT = GT + +cmpAltCon con1 con2 = pprPanic "cmpAltCon" (ppr con1 $$ ppr con2) + +{- +************************************************************************ +* * +\subsection{Useful synonyms} +* * +************************************************************************ + +Note [CoreProgram] +~~~~~~~~~~~~~~~~~~ +The top level bindings of a program, a CoreProgram, are represented as +a list of CoreBind + + * Later bindings in the list can refer to earlier ones, but not vice + versa. So this is OK + NonRec { x = 4 } + Rec { p = ...q...x... + ; q = ...p...x } + Rec { f = ...p..x..f.. } + NonRec { g = ..f..q...x.. } + But it would NOT be ok for 'f' to refer to 'g'. + + * The occurrence analyser does strongly-connected component analysis + on each Rec binding, and splits it into a sequence of smaller + bindings where possible. So the program typically starts life as a + single giant Rec, which is then dependency-analysed into smaller + chunks. +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +type CoreProgram = [CoreBind] -- See Note [CoreProgram] + +-- | The common case for the type of binders and variables when +-- we are manipulating the Core language within GHC +type CoreBndr = Var +-- | Expressions where binders are 'CoreBndr's +type CoreExpr = Expr CoreBndr +-- | Argument expressions where binders are 'CoreBndr's +type CoreArg = Arg CoreBndr +-- | Binding groups where binders are 'CoreBndr's +type CoreBind = Bind CoreBndr +-- | Case alternatives where binders are 'CoreBndr's +type CoreAlt = Alt CoreBndr + +{- +************************************************************************ +* * +\subsection{Tagging} +* * +************************************************************************ +-} + +-- | Binders are /tagged/ with a t +data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" + +type TaggedBind t = Bind (TaggedBndr t) +type TaggedExpr t = Expr (TaggedBndr t) +type TaggedArg t = Arg (TaggedBndr t) +type TaggedAlt t = Alt (TaggedBndr t) + +instance Outputable b => Outputable (TaggedBndr b) where + ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' + +deTagExpr :: TaggedExpr t -> CoreExpr +deTagExpr (Var v) = Var v +deTagExpr (Lit l) = Lit l +deTagExpr (Type ty) = Type ty +deTagExpr (Coercion co) = Coercion co +deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2) +deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e) +deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body) +deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts) +deTagExpr (Tick t e) = Tick t (deTagExpr e) +deTagExpr (Cast e co) = Cast (deTagExpr e) co + +deTagBind :: TaggedBind t -> CoreBind +deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs) +deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs] + +deTagAlt :: TaggedAlt t -> CoreAlt +deTagAlt (Alt con bndrs rhs) = Alt con [b | TB b _ <- bndrs] (deTagExpr rhs) + +{- +************************************************************************ +* * +\subsection{Core-constructing functions with checking} +* * +************************************************************************ +-} + +-- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to +-- use 'GHC.Core.Make.mkCoreApps' if possible +mkApps :: Expr b -> [Arg b] -> Expr b +-- | Apply a list of type argument expressions to a function expression in a nested fashion +mkTyApps :: Expr b -> [Type] -> Expr b +-- | Apply a list of coercion argument expressions to a function expression in a nested fashion +mkCoApps :: Expr b -> [Coercion] -> Expr b +-- | Apply a list of type or value variables to a function expression in a nested fashion +mkVarApps :: Expr b -> [Var] -> Expr b +-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to +-- use 'GHC.Core.Make.mkCoreConApps' if possible +mkConApp :: DataCon -> [Arg b] -> Expr b + +mkApps f args = foldl' App f args +mkCoApps f args = foldl' (\ e a -> App e (Coercion a)) f args +mkVarApps f vars = foldl' (\ e a -> App e (varToCoreExpr a)) f vars +mkConApp con args = mkApps (Var (dataConWorkId con)) args + +mkTyApps f args = foldl' (\ e a -> App e (mkTyArg a)) f args + +mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b +mkConApp2 con tys arg_ids = Var (dataConWorkId con) + `mkApps` map Type tys + `mkApps` map varToCoreExpr arg_ids + +mkTyArg :: Type -> Expr b +mkTyArg ty + | Just co <- isCoercionTy_maybe ty = Coercion co + | otherwise = Type ty + +-- | Create a machine integer literal expression of type @Int#@ from an @Integer@. +-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr' +mkIntLit :: Platform -> Integer -> Expr b +mkIntLit platform n = Lit (mkLitInt platform n) + +-- | Create a machine integer literal expression of type @Int#@ from an +-- @Integer@, wrapping if necessary. +-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr' +mkIntLitWrap :: Platform -> Integer -> Expr b +mkIntLitWrap platform n = Lit (mkLitIntWrap platform n) + +-- | Create a machine word literal expression of type @Word#@ from an @Integer@. +-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr' +mkWordLit :: Platform -> Integer -> Expr b +mkWordLit platform w = Lit (mkLitWord platform w) + +-- | Create a machine word literal expression of type @Word#@ from an +-- @Integer@, wrapping if necessary. +-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr' +mkWordLitWrap :: Platform -> Integer -> Expr b +mkWordLitWrap platform w = Lit (mkLitWordWrap platform w) + +mkWord8Lit :: Integer -> Expr b +mkWord8Lit w = Lit (mkLitWord8 w) + +mkWord32LitWord32 :: Word32 -> Expr b +mkWord32LitWord32 w = Lit (mkLitWord32 (toInteger w)) + +mkWord64LitWord64 :: Word64 -> Expr b +mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w)) + +mkInt64LitInt64 :: Int64 -> Expr b +mkInt64LitInt64 w = Lit (mkLitInt64 (toInteger w)) + +-- | Create a machine character literal expression of type @Char#@. +-- If you want an expression of type @Char@ use 'GHC.Core.Make.mkCharExpr' +mkCharLit :: Char -> Expr b +-- | Create a machine string literal expression of type @Addr#@. +-- If you want an expression of type @String@ use 'GHC.Core.Make.mkStringExpr' +mkStringLit :: String -> Expr b + +mkCharLit c = Lit (mkLitChar c) +mkStringLit s = Lit (mkLitString s) + +-- | Create a machine single precision literal expression of type @Float#@ from a @Rational@. +-- If you want an expression of type @Float@ use 'GHC.Core.Make.mkFloatExpr' +mkFloatLit :: Rational -> Expr b +-- | Create a machine single precision literal expression of type @Float#@ from a @Float@. +-- If you want an expression of type @Float@ use 'GHC.Core.Make.mkFloatExpr' +mkFloatLitFloat :: Float -> Expr b + +mkFloatLit f = Lit (mkLitFloat f) +mkFloatLitFloat f = Lit (mkLitFloat (toRational f)) + +-- | Create a machine double precision literal expression of type @Double#@ from a @Rational@. +-- If you want an expression of type @Double@ use 'GHC.Core.Make.mkDoubleExpr' +mkDoubleLit :: Rational -> Expr b +-- | Create a machine double precision literal expression of type @Double#@ from a @Double@. +-- If you want an expression of type @Double@ use 'GHC.Core.Make.mkDoubleExpr' +mkDoubleLitDouble :: Double -> Expr b + +mkDoubleLit d = Lit (mkLitDouble d) +mkDoubleLitDouble d = Lit (mkLitDouble (toRational d)) + +-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes +-- that the rhs satisfies the let-can-float invariant. Prefer to use +-- 'GHC.Core.Make.mkCoreLets' if possible, which does guarantee the invariant +mkLets :: [Bind b] -> Expr b -> Expr b +-- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to +-- use 'GHC.Core.Make.mkCoreLams' if possible +mkLams :: [b] -> Expr b -> Expr b + +mkLams binders body = foldr Lam body binders +mkLets binds body = foldr mkLet body binds + +mkLet :: Bind b -> Expr b -> Expr b +-- The desugarer sometimes generates an empty Rec group +-- which Lint rejects, so we kill it off right away +mkLet (Rec []) body = body +mkLet bind body = Let bind body + +-- | @mkLetNonRec bndr rhs body@ wraps @body@ in a @let@ binding @bndr@. +mkLetNonRec :: b -> Expr b -> Expr b -> Expr b +mkLetNonRec b rhs body = Let (NonRec b rhs) body + +-- | @mkLetRec binds body@ wraps @body@ in a @let rec@ with the given set of +-- @binds@ if binds is non-empty. +mkLetRec :: [(b, Expr b)] -> Expr b -> Expr b +mkLetRec [] body = body +mkLetRec bs body = Let (Rec bs) body + +-- | Create a binding group where a type variable is bound to a type. +-- Per Note [Core type and coercion invariant], +-- this can only be used to bind something in a non-recursive @let@ expression +mkTyBind :: TyVar -> Type -> CoreBind +mkTyBind tv ty = NonRec tv (Type ty) + +-- | Create a binding group where a type variable is bound to a type. +-- Per Note [Core type and coercion invariant], +-- this can only be used to bind something in a non-recursive @let@ expression +mkCoBind :: CoVar -> Coercion -> CoreBind +mkCoBind cv co = NonRec cv (Coercion co) + +-- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately +varToCoreExpr :: CoreBndr -> Expr b +varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) + | isCoVar v = Coercion (mkCoVarCo v) + | otherwise = assert (isId v) $ Var v + +varsToCoreExprs :: [CoreBndr] -> [Expr b] +varsToCoreExprs vs = map varToCoreExpr vs + +{- +************************************************************************ +* * + Getting a result type +* * +************************************************************************ + +These are defined here to avoid a module loop between GHC.Core.Utils and GHC.Core.FVs + +-} + +-- | If the expression is a 'Type', converts. Otherwise, +-- panics. NB: This does /not/ convert 'Coercion' to 'CoercionTy'. +exprToType :: CoreExpr -> Type +exprToType (Type ty) = ty +exprToType _bad = pprPanic "exprToType" empty + +{- +************************************************************************ +* * +\subsection{Simple access functions} +* * +************************************************************************ +-} + +-- | Extract every variable by this group +bindersOf :: Bind b -> [b] +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +bindersOf (NonRec binder _) = [binder] +bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] + +-- | 'bindersOf' applied to a list of binding groups +bindersOfBinds :: [Bind b] -> [b] +bindersOfBinds binds = foldr ((++) . bindersOf) [] binds + +-- We inline this to avoid unknown function calls. +{-# INLINE foldBindersOfBindStrict #-} +foldBindersOfBindStrict :: (a -> b -> a) -> a -> Bind b -> a +foldBindersOfBindStrict f + = \z bind -> case bind of + NonRec b _rhs -> f z b + Rec pairs -> foldl' f z $ map fst pairs + +{-# INLINE foldBindersOfBindsStrict #-} +foldBindersOfBindsStrict :: (a -> b -> a) -> a -> [Bind b] -> a +foldBindersOfBindsStrict f = \z binds -> foldl' fold_bind z binds + where + fold_bind = (foldBindersOfBindStrict f) + + +rhssOfBind :: Bind b -> [Expr b] +rhssOfBind (NonRec _ rhs) = [rhs] +rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] + +rhssOfBinds :: [Bind b] -> [Expr b] +rhssOfBinds [] = [] +rhssOfBinds (NonRec _ rhs : bs) = rhs : rhssOfBinds bs +rhssOfBinds (Rec pairs : bs) = map snd pairs ++ rhssOfBinds bs + +rhssOfAlts :: [Alt b] -> [Expr b] +rhssOfAlts alts = [e | Alt _ _ e <- alts] + +-- | Collapse all the bindings in the supplied groups into a single +-- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group +flattenBinds :: [Bind b] -> [(b, Expr b)] +flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds +flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds +flattenBinds [] = [] + +-- | We often want to strip off leading lambdas before getting down to +-- business. Variants are 'collectTyBinders', 'collectValBinders', +-- and 'collectTyAndValBinders' +collectBinders :: Expr b -> ([b], Expr b) +collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) +collectValBinders :: CoreExpr -> ([Id], CoreExpr) +collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) + +-- | Strip off exactly N leading lambdas (type or value). +-- Good for use with join points. +-- Panic if there aren't enough +collectNBinders :: JoinArity -> Expr b -> ([b], Expr b) + +collectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs e = (reverse bs, e) + +collectTyBinders expr + = go [] expr + where + go tvs (Lam b e) | isTyVar b = go (b:tvs) e + go tvs e = (reverse tvs, e) + +collectValBinders expr + = go [] expr + where + go ids (Lam b e) | isId b = go (b:ids) e + go ids body = (reverse ids, body) + +collectTyAndValBinders expr + = (tvs, ids, body) + where + (tvs, body1) = collectTyBinders expr + (ids, body) = collectValBinders body1 + +collectNBinders orig_n orig_expr + = go orig_n [] orig_expr + where + go 0 bs expr = (reverse bs, expr) + go n bs (Lam b e) = go (n-1) (b:bs) e + go _ _ _ = pprPanic "collectNBinders" $ int orig_n + +-- | Strip off exactly N leading value lambdas +-- returning all the binders found up to that point +-- Return Nothing if there aren't enough +collectNValBinders_maybe :: Arity -> CoreExpr -> Maybe ([Var], CoreExpr) +collectNValBinders_maybe orig_n orig_expr + = go orig_n [] orig_expr + where + go 0 bs expr = Just (reverse bs, expr) + go n bs (Lam b e) | isId b = go (n-1) (b:bs) e + | otherwise = go n (b:bs) e + go _ _ _ = Nothing + +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectArgs :: Expr b -> (Expr b, [Arg b]) +collectArgs expr + = go expr [] + where + go (App f a) as = go f (a:as) + go e as = (e, as) + +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectValArgs :: Expr b -> (Expr b, [Arg b]) +collectValArgs expr + = go expr [] + where + go (App f a) as + | isValArg a = go f (a:as) + | otherwise = go f as + go e as = (e, as) + +-- | Takes a nested application expression and returns the function +-- being applied. Looking through casts and ticks to find it. +collectFunSimple :: Expr b -> Expr b +collectFunSimple expr + = go expr + where + go expr' = + case expr' of + App f _a -> go f + Tick _t e -> go e + Cast e _co -> go e + e -> e + +-- | fmap on the body of a lambda. +-- wrapLamBody f (\x -> body) == (\x -> f body) +wrapLamBody :: (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr +wrapLamBody f expr = go expr + where + go (Lam v body) = Lam v $ go body + go expr = f expr + +-- | Attempt to remove the last N arguments of a function call. +-- Strip off any ticks or coercions encountered along the way and any +-- at the end. +stripNArgs :: Word -> Expr a -> Maybe (Expr a) +stripNArgs !n (Tick _ e) = stripNArgs n e +stripNArgs n (Cast f _) = stripNArgs n f +stripNArgs 0 e = Just e +stripNArgs n (App f _) = stripNArgs (n - 1) f +stripNArgs _ _ = Nothing + +-- | Like @collectArgs@, but also looks through floatable +-- ticks if it means that we can find more arguments. +collectArgsTicks :: (CoreTickish -> Bool) -> Expr b + -> (Expr b, [Arg b], [CoreTickish]) +collectArgsTicks skipTick expr + = go expr [] [] + where + go (App f a) as ts = go f (a:as) ts + go (Tick t e) as ts + | skipTick t = go e as (t:ts) + go e as ts = (e, as, reverse ts) + + +{- +************************************************************************ +* * +\subsection{Predicates} +* * +************************************************************************ + +At one time we optionally carried type arguments through to runtime. +@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime, +i.e. if type applications are actual lambdas because types are kept around +at runtime. Similarly isRuntimeArg. +-} + +-- | Will this variable exist at runtime? +isRuntimeVar :: Var -> Bool +isRuntimeVar = isId + +-- | Will this argument expression exist at runtime? +isRuntimeArg :: CoreExpr -> Bool +isRuntimeArg = isValArg + +-- | Returns @True@ for value arguments, false for type args +-- NB: coercions are value arguments (zero width, to be sure, +-- like State#, but still value args). +isValArg :: Expr b -> Bool +isValArg e = not (isTypeArg e) + +-- | Returns @True@ iff the expression is a 'Type' or 'Coercion' +-- expression at its top level +isTyCoArg :: Expr b -> Bool +isTyCoArg (Type {}) = True +isTyCoArg (Coercion {}) = True +isTyCoArg _ = False + +-- | Returns @True@ iff the expression is a 'Coercion' +-- expression at its top level +isCoArg :: Expr b -> Bool +isCoArg (Coercion {}) = True +isCoArg _ = False + +-- | Returns @True@ iff the expression is a 'Type' expression at its +-- top level. Note this does NOT include 'Coercion's. +isTypeArg :: Expr b -> Bool +isTypeArg (Type {}) = True +isTypeArg _ = False + +-- | The number of binders that bind values rather than types +valBndrCount :: [CoreBndr] -> Int +valBndrCount = count isId + +-- | The number of argument expressions that are values rather than types at their top level +valArgCount :: [Arg b] -> Int +valArgCount = count isValArg + +{- +************************************************************************ +* * +\subsection{Annotated core} +* * +************************************************************************ +-} + +-- | Annotated core: allows annotation at every node in the tree +type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) + +-- | A clone of the 'Expr' type but allowing annotation at every tree node +data AnnExpr' bndr annot + = AnnVar Id + | AnnLit Literal + | AnnLam bndr (AnnExpr bndr annot) + | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) + | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] + | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) + | AnnCast (AnnExpr bndr annot) (annot, Coercion) + -- Put an annotation on the (root of) the coercion + | AnnTick CoreTickish (AnnExpr bndr annot) + | AnnType Type + | AnnCoercion Coercion + +-- | A clone of the 'Alt' type but allowing annotation at every tree node +data AnnAlt bndr annot = AnnAlt AltCon [bndr] (AnnExpr bndr annot) + +-- | A clone of the 'Bind' type but allowing annotation at every tree node +data AnnBind bndr annot + = AnnNonRec bndr (AnnExpr bndr annot) + | AnnRec [(bndr, AnnExpr bndr annot)] + +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) +collectAnnArgs expr + = go expr [] + where + go (_, AnnApp f a) as = go f (a:as) + go e as = (e, as) + +collectAnnArgsTicks :: (CoreTickish -> Bool) -> AnnExpr b a + -> (AnnExpr b a, [AnnExpr b a], [CoreTickish]) +collectAnnArgsTicks tickishOk expr + = go expr [] [] + where + go (_, AnnApp f a) as ts = go f (a:as) ts + go (_, AnnTick t e) as ts | tickishOk t + = go e as (t:ts) + go e as ts = (e, as, reverse ts) + +deAnnotate :: AnnExpr bndr annot -> Expr bndr +deAnnotate (_, e) = deAnnotate' e + +deAnnotate' :: AnnExpr' bndr annot -> Expr bndr +deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnCoercion co) = Coercion co +deAnnotate' (AnnVar v) = Var v +deAnnotate' (AnnLit lit) = Lit lit +deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) +deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) +deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co +deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body) + +deAnnotate' (AnnLet bind body) + = Let (deAnnBind bind) (deAnnotate body) +deAnnotate' (AnnCase scrut v t alts) + = Case (deAnnotate scrut) v t (map deAnnAlt alts) + +deAnnAlt :: AnnAlt bndr annot -> Alt bndr +deAnnAlt (AnnAlt con args rhs) = Alt con args (deAnnotate rhs) + +deAnnBind :: AnnBind b annot -> Bind b +deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) +deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] + +-- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' +collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) +collectAnnBndrs e + = collect [] e + where + collect bs (_, AnnLam b body) = collect (b:bs) body + collect bs body = (reverse bs, body) + +-- | As 'collectNBinders' but for 'AnnExpr' rather than 'Expr' +collectNAnnBndrs :: Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) +collectNAnnBndrs orig_n e + = collect orig_n [] e + where + collect 0 bs body = (reverse bs, body) + collect n bs (_, AnnLam b body) = collect (n-1) (b:bs) body + collect _ _ _ = pprPanic "collectNBinders" $ int orig_n diff --git a/GHC/Core.hs-boot b/GHC/Core.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core.hs-boot @@ -0,0 +1,9 @@ +{-# LANGUAGE NoPolyKinds #-} +module GHC.Core where +import {-# SOURCE #-} GHC.Types.Var + +data Expr a + +type CoreBndr = Var + +type CoreExpr = Expr CoreBndr diff --git a/GHC/Core/Class.hs b/GHC/Core/Class.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Class.hs @@ -0,0 +1,405 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +-- The @Class@ datatype + + + +module GHC.Core.Class ( + Class, + ClassOpItem, + ClassATItem(..), TyFamEqnValidityInfo(..), + ClassMinimalDef, + DefMethInfo, pprDefMethInfo, + + FunDep, pprFundeps, pprFunDep, + + mkClass, mkAbstractClass, classTyVars, classArity, + classKey, className, classATs, classATItems, classTyCon, classMethods, + classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, + classHasSCs, classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, + classHasFds, + + -- Predicates + -- NB: other isXXlass predicates are defined in GHC.Core.Predicate + -- to avoid module loops + isAbstractClass + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) +import GHC.Hs.Extension (GhcRn) +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Types.Unique +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Types.SrcLoc +import GHC.Types.Var.Set +import GHC.Utils.Outputable +import Language.Haskell.Syntax.BooleanFormula ( BooleanFormula, mkTrue ) + +import qualified Data.Data as Data + +{- +************************************************************************ +* * +\subsection[Class-basic]{@Class@: basic definition} +* * +************************************************************************ + +A @Class@ corresponds to a Greek kappa in the static semantics: +-} + +data Class + = Class { + classTyCon :: TyCon, -- The data type constructor for + -- dictionaries of this class + -- See Note [ATyCon for classes] in GHC.Core.TyCo.Rep + + className :: Name, -- Just the cached name of the TyCon + classKey :: Unique, -- Cached unique of TyCon + + classTyVars :: [TyVar], -- The class kind and type variables; + -- identical to those of the TyCon + -- If you want visibility info, look at the classTyCon + -- This field is redundant because it's duplicated in the + -- classTyCon, but classTyVars is used quite often, so maybe + -- it's a bit faster to cache it here + + classFunDeps :: [FunDep TyVar], -- The functional dependencies + + classBody :: ClassBody -- Superclasses, ATs, methods + + } + +-- | e.g. +-- +-- > class C a b c | a b -> c, a c -> b where... +-- +-- Here fun-deps are [([a,b],[c]), ([a,c],[b])] +type FunDep a = ([a],[a]) + +type ClassOpItem = (Id, DefMethInfo) + -- Selector function; contains unfolding + -- Default-method info + +type DefMethInfo = Maybe (Name, DefMethSpec Type) + -- Nothing No default method + -- Just ($dm, VanillaDM) A polymorphic default method, name $dm + -- Just ($gm, GenericDM ty) A generic default method, name $gm, type ty + -- The generic dm type is *not* quantified + -- over the class variables; ie has the + -- class variables free + +data ClassATItem + = ATI TyCon -- See Note [Associated type tyvar names] + (Maybe (Type, TyFamEqnValidityInfo)) + -- ^ Default associated type (if any) from this template. + -- + -- As per Note [Associated type defaults], the Type has been renamed + -- to use the class tyvars, while the 'TyFamEqnValidityInfo' uses + -- the original user-written type variables. + +-- | Information about a type family equation, used for validity checking +-- of closed type family equations and associated type family default equations. +-- +-- This type exists to delay validity-checking after typechecking type declaration +-- groups, to avoid cyclic evaluation inside the typechecking knot. +-- +-- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl". +data TyFamEqnValidityInfo + -- | Used for equations which don't need any validity checking, + -- for example equations imported from another module. + = NoVI + + -- | Information necessary for validity checking of a type family equation. + | VI + { vi_loc :: SrcSpan + , vi_qtvs :: [TcTyVar] + -- ^ LHS quantified type variables + , vi_non_user_tvs :: TyVarSet + -- ^ non-user-written type variables (for error message reporting) + -- + -- Example: with -XPolyKinds, typechecking @type instance forall a. F = ()@ + -- introduces the kind variable @k@ for the kind of @a@. See #23734. + , vi_pats :: [Type] + -- ^ LHS patterns + , vi_rhs :: Type + -- ^ RHS of the equation + -- + -- NB: for associated type family default declarations, this is the RHS + -- *before* applying the substitution from + -- Note [Type-checking default assoc decls] in GHC.Tc.TyCl. + } + +type ClassMinimalDef = BooleanFormula GhcRn -- Required methods + +data ClassBody + = AbstractClass + | ConcreteClass { + -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) + -- We need value-level selectors for both the dictionary + -- superclasses and the equality superclasses + cls_sc_theta :: [PredType], -- Immediate superclasses, + cls_sc_sel_ids :: [Id], -- Selector functions to extract the + -- superclasses from a + -- dictionary of this class + -- Associated types + cls_ats :: [ClassATItem], -- Associated type families + + -- Class operations (methods, not superclasses) + cls_ops :: [ClassOpItem], -- Ordered by tag + + -- Minimal complete definition + cls_min_def :: ClassMinimalDef + } + -- TODO: maybe super classes should be allowed in abstract class definitions + +classMinimalDef :: Class -> ClassMinimalDef +classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d +classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction + +{- +Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following is an example of associated type defaults: + class C a where + data D a r + + type F x a b :: * + type F p q r = (p,q)->r -- Default + +Note that + + * The TyCons for the associated types *share type variables* with the + class, so that we can tell which argument positions should be + instantiated in an instance decl. (The first for 'D', the second + for 'F'.) + + * We can have default definitions only for *type* families, + not data families + + * In the default decl, the "patterns" should all be type variables, + but (in the source language) they don't need to be the same as in + the 'type' decl signature or the class. It's more like a + free-standing 'type instance' declaration. + + * HOWEVER, in the internal ClassATItem we rename the RHS to match the + tyConTyVars of the family TyCon. So in the example above we'd get + a ClassATItem of + + ATI F (Just ((x,a) -> b, validity_info) + + That is, the type stored in the first component of the pair has been + renamed to use the class type variables. On the other hand, the + TyFamEqnValidityInfo, used for validity checking of the type family equation + (considered as a free-standing equation) uses the original types, e.g. + involving the type variables 'p', 'q', 'r'. + +The @mkClass@ function fills in the indirect superclasses. + +The SrcSpan is for the entire original declaration. +-} + +mkClass :: Name -> [TyVar] + -> [FunDep TyVar] + -> [PredType] -> [Id] + -> [ClassATItem] + -> [ClassOpItem] + -> ClassMinimalDef + -> TyCon + -> Class + +mkClass cls_name tyvars fds super_classes superdict_sels at_stuff + op_stuff mindef tycon + = Class { classKey = nameUnique cls_name, + className = cls_name, + -- NB: tyConName tycon = cls_name, + -- But it takes a module loop to assert it here + classTyVars = tyvars, + classFunDeps = fds, + classBody = ConcreteClass { + cls_sc_theta = super_classes, + cls_sc_sel_ids = superdict_sels, + cls_ats = at_stuff, + cls_ops = op_stuff, + cls_min_def = mindef + }, + classTyCon = tycon } + +mkAbstractClass :: Name -> [TyVar] + -> [FunDep TyVar] + -> TyCon + -> Class + +mkAbstractClass cls_name tyvars fds tycon + = Class { classKey = nameUnique cls_name, + className = cls_name, + -- NB: tyConName tycon = cls_name, + -- But it takes a module loop to assert it here + classTyVars = tyvars, + classFunDeps = fds, + classBody = AbstractClass, + classTyCon = tycon } + +{- +Note [Associated type tyvar names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TyCon of an associated type should use the same variable names as its +parent class. Thus + class C a b where + type F b x a :: * +We make F use the same Name for 'a' as C does, and similarly 'b'. + +The reason for this is when checking instances it's easier to match +them up, to ensure they match. Eg + instance C Int [d] where + type F [d] x Int = .... +we should make sure that the first and third args match the instance +header. + +Having the same variables for class and tycon is also used in checkValidRoles +(in GHC.Tc.TyCl) when checking a class's roles. + + +************************************************************************ +* * +\subsection[Class-selectors]{@Class@: simple selectors} +* * +************************************************************************ + +The rest of these functions are just simple selectors. +-} + +classArity :: Class -> Arity +classArity clas = length (classTyVars clas) + -- Could memoise this + +classAllSelIds :: Class -> [Id] +-- Both superclass-dictionary and method selectors +classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) + = sc_sels ++ classMethods c +classAllSelIds c = assert (null (classMethods c) ) [] + +classSCSelIds :: Class -> [Id] +-- Both superclass-dictionary and method selectors +classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) + = sc_sels +classSCSelIds c = assert (null (classMethods c) ) [] + +classSCSelId :: Class -> Int -> Id +-- Get the n'th superclass selector Id +-- where n is 0-indexed, and counts +-- *all* superclasses including equalities +classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n + = assert (n >= 0 && lengthExceeds sc_sels n ) + sc_sels !! n +classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n) + +classMethods :: Class -> [Id] +classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } }) + = [op_sel | (op_sel, _) <- op_stuff] +classMethods _ = [] + +classOpItems :: Class -> [ClassOpItem] +classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }}) + = op_stuff +classOpItems _ = [] + +classATs :: Class -> [TyCon] +classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } }) + = [tc | ATI tc _ <- at_stuff] +classATs _ = [] + +classATItems :: Class -> [ClassATItem] +classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }}) + = at_stuff +classATItems _ = [] + +classSCTheta :: Class -> [PredType] +classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }}) + = theta_stuff +classSCTheta _ = [] + +classHasSCs :: Class -> Bool +classHasSCs cls = not (null (classSCTheta cls)) + +classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) +classTvsFds c = (classTyVars c, classFunDeps c) + +classHasFds :: Class -> Bool +classHasFds (Class { classFunDeps = fds }) = not (null fds) + +classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem]) +classBigSig (Class {classTyVars = tyvars, + classBody = AbstractClass}) + = (tyvars, [], [], []) +classBigSig (Class {classTyVars = tyvars, + classBody = ConcreteClass { + cls_sc_theta = sc_theta, + cls_sc_sel_ids = sc_sels, + cls_ops = op_stuff + }}) + = (tyvars, sc_theta, sc_sels, op_stuff) + +classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem]) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classBody = AbstractClass}) + = (tyvars, fundeps, [], [], [], []) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classBody = ConcreteClass { + cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels, + cls_ats = ats, cls_ops = op_stuff + }}) + = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) + +isAbstractClass :: Class -> Bool +isAbstractClass Class{ classBody = AbstractClass } = True +isAbstractClass _ = False + +{- +************************************************************************ +* * +\subsection[Class-instances]{Instance declarations for @Class@} +* * +************************************************************************ + +We compare @Classes@ by their keys (which include @Uniques@). +-} + +instance Eq Class where + c1 == c2 = classKey c1 == classKey c2 + c1 /= c2 = classKey c1 /= classKey c2 + +instance Uniquable Class where + getUnique c = classKey c + +instance NamedThing Class where + getName clas = className clas + +instance Outputable Class where + ppr c = ppr (getName c) + +pprDefMethInfo :: DefMethInfo -> SDoc +pprDefMethInfo Nothing = empty -- No default method +pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n +pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method" + <+> ppr n <+> dcolon <+> pprType ty + +pprFundeps :: Outputable a => [FunDep a] -> SDoc +pprFundeps [] = empty +pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) + +pprFunDep :: Outputable a => FunDep a -> SDoc +pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs] + +instance Data.Data Class where + -- don't traverse? + toConstr _ = abstractConstr "Class" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Class" diff --git a/GHC/Core/Coercion.hs b/GHC/Core/Coercion.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Coercion.hs @@ -0,0 +1,2807 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- +(c) The University of Glasgow 2006 +-} + +-- | Module for (a) type kinds and (b) type coercions, +-- as used in System FC. See 'GHC.Core.Expr' for +-- more on System FC and how coercions fit into it. +-- +module GHC.Core.Coercion ( + -- * Main data type + Coercion, CoercionN, CoercionR, CoercionP, + MCoercion(..), MCoercionN, MCoercionR, + CoSel(..), FunSel(..), + UnivCoProvenance, CoercionHole(..), + coHoleCoVar, setCoHoleCoVar, + LeftOrRight(..), + Var, CoVar, TyCoVar, + Role(..), ltRole, + + -- ** Functions over coercions + coVarRType, coVarLType, coVarTypes, + coVarKind, coVarTypesRole, coVarRole, + coercionType, mkCoercionType, + coercionKind, coercionLKind, coercionRKind,coercionKinds, + coercionRole, coercionKindRole, + + -- ** Constructing coercions + mkGReflCo, mkGReflMCo, mkReflCo, mkRepReflCo, mkNomReflCo, + mkCoVarCo, mkCoVarCos, + mkAxInstCo, mkUnbranchedAxInstCo, + mkAxInstRHS, mkUnbranchedAxInstRHS, + mkAxInstLHS, mkUnbranchedAxInstLHS, + mkPiCo, mkPiCos, mkCoCast, + mkSymCo, mkTransCo, + mkSelCo, mkSelCoResRole, getNthFun, selectFromType, mkLRCo, + mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, + mkFunCo, mkFunCo2, mkFunCoNoFTF, mkFunResCo, + mkNakedFunCo, + mkNakedForAllCo, mkForAllCo, mkForAllVisCos, mkHomoForAllCos, + mkPhantomCo, mkAxiomCo, + mkHoleCo, mkUnivCo, mkSubCo, + mkProofIrrelCo, + downgradeRole, + mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, + mkKindCo, + castCoercionKind, castCoercionKind1, castCoercionKind2, + + -- ** Decomposition + instNewTyCon_maybe, + + NormaliseStepper, NormaliseStepResult(..), composeSteppers, unwrapNewTypeStepper, + topNormaliseNewType_maybe, topNormaliseTypeX, + + decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, + splitAppCo_maybe, + splitFunCo_maybe, + splitForAllCo_maybe, + splitForAllCo_ty_maybe, splitForAllCo_co_maybe, + + tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, + tyConRoleListX, tyConRoleListRepresentational, funRole, + pickLR, + + isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, + isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo, + mkCoherenceRightMCo, + + coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo, + mkFunResMCo, mkPiMCos, + isReflMCo, checkReflexiveMCo, + + -- ** Coercion variables + mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, + + -- ** Free variables + tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, + tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, + coercionSize, anyFreeVarsOfCo, + + -- ** Substitution + CvSubstEnv, emptyCvSubstEnv, + lookupCoVar, + substCo, substCos, substCoVar, substCoVars, substCoWith, + substCoVarBndr, + extendTvSubstAndInScope, getCvSubstEnv, + + -- ** Lifting + liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, + emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, + liftCoSubstVarBndrUsing, isMappedByLC, extendLiftingContextCvSubst, + updateLCSubst, + + mkSubstLiftingContext, liftingContextSubst, zapLiftingContext, + lcLookupCoVar, lcInScopeSet, + + LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, + substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, + + -- ** Comparison + eqCoercion, eqCoercionX, + + -- ** Forcing evaluation of coercions + seqCo, + + -- * Pretty-printing + pprCo, pprParendCo, + pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS, + pprCoAxBranchUser, tidyCoAxBndrsForUser, + etaExpandCoAxBranch, + + -- * Tidying + tidyCo, tidyCos, + + -- * Other + promoteCoercion, buildCoercion, + + multToCo, mkRuntimeRepCo, + + hasCoercionHole, + setCoHoleType + ) where + +import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs) + +import GHC.Prelude + +import GHC.Iface.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Tidy +import GHC.Core.TyCo.Compare +import GHC.Core.Type +import GHC.Core.Predicate( mkNomEqPred, mkReprEqPred ) +import GHC.Core.TyCon +import GHC.Core.TyCon.RecWalk +import GHC.Core.Coercion.Axiom +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Basic +import GHC.Types.Unique +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Types.SrcLoc +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim +import GHC.Data.List.SetOps +import GHC.Data.Maybe +import GHC.Types.Unique.FM +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Monad (foldM, zipWithM) +import Data.Function ( on ) +import Data.Char( isDigit ) +import qualified Data.Monoid as Monoid +import Data.List.NonEmpty ( NonEmpty (..) ) +import Control.DeepSeq + +{- +%************************************************************************ +%* * + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. See + -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep + +\subsection{Coercion variables} +%* * +%************************************************************************ +-} + +coVarName :: CoVar -> Name +coVarName = varName + +setCoVarUnique :: CoVar -> Unique -> CoVar +setCoVarUnique = setVarUnique + +setCoVarName :: CoVar -> Name -> CoVar +setCoVarName = setVarName + +{- +%************************************************************************ +%* * + Pretty-printing CoAxioms +%* * +%************************************************************************ + +Defined here to avoid module loops. CoAxiom is loaded very early on. + +-} + +etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type) +-- Return the (tvs,lhs,rhs) after eta-expanding, +-- to the way in which the axiom was originally written +-- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom +etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + -- ToDo: what about eta_cvs? + = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys) + where + eta_tys = mkTyVarTys eta_tvs + +pprCoAxiom :: CoAxiom br -> SDoc +-- Used in debug-printing only +pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = hang (text "axiom" <+> ppr ax) + 2 (braces $ vcat (map (pprCoAxBranchUser tc) (fromBranches branches))) + +pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc +-- Used when printing injectivity errors (FamInst.reportInjectivityErrors) +-- and inaccessible branches (GHC.Tc.Validity.inaccessibleCoAxBranch) +-- This happens in error messages: don't print the RHS of a data +-- family axiom, which is meaningless to a user +pprCoAxBranchUser tc br + | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br + | otherwise = pprCoAxBranch tc br + +pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc +-- Print the family-instance equation when reporting +-- a conflict between equations (FamInst.conflictInstErr) +-- For type families the RHS is important; for data families not so. +-- Indeed for data families the RHS is a mysterious internal +-- type constructor, so we suppress it (#14179) +-- See FamInstEnv Note [Family instance overlap conflicts] +pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs + where + pp_rhs _ _ = empty + +pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc +pprCoAxBranch = ppr_co_ax_branch ppr_rhs + where + ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs + +ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) + -> TyCon -> CoAxBranch -> SDoc +ppr_co_ax_branch ppr_rhs fam_tc branch + = foldr1 (flip hangNotEmpty 2) $ + pprUserForAll (mkForAllTyBinders Inferred bndrs') :| + -- See Note [Printing foralls in type family instances] in GHC.Iface.Type + (pp_lhs <+> ppr_rhs tidy_env ee_rhs) : + ( vcat [ text "-- Defined" <+> pp_loc + , ppUnless (null incomps) $ whenPprDebug $ + text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ] ) : + [] + where + incomps = coAxBranchIncomps branch + loc = coAxBranchSpan branch + pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc) + | otherwise = text "in" <+> ppr loc + + -- Eta-expand LHS and RHS types, because sometimes data family + -- instances are eta-reduced. + -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. + (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch + + pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) + (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs) + + (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs + +tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +-- Tidy wildcards "_1", "_2" to "_", and do not return them +-- in the list of binders to be printed +-- This is so that in error messages we see +-- forall a. F _ [a] _ = ... +-- rather than +-- forall a _1 _2. F _1 [a] _2 = ... +-- +-- This is a rather disgusting function +-- See Note [Wildcard names] in GHC.Tc.Gen.HsType +tidyCoAxBndrsForUser init_env tcvs + = (tidy_env, reverse tidy_bndrs) + where + (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs + + tidy_one (env@(occ_env, subst), rev_bndrs') bndr + | is_wildcard bndr = (env_wild, rev_bndrs') + | otherwise = (env', bndr' : rev_bndrs') + where + (env', bndr') = tidyVarBndr env bndr + env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) + wild_bndr = setVarName bndr $ + tidyNameOcc (varName bndr) (mkTyVarOccFS (fsLit "_")) + -- Tidy the binder to "_" + + is_wildcard :: Var -> Bool + is_wildcard tv = case occNameString (getOccName tv) of + ('_' : rest) -> all isDigit rest + _ -> False + + +{- ********************************************************************* +* * + MCoercion +* * +********************************************************************* -} + +coToMCo :: Coercion -> MCoercion +-- Convert a coercion to a MCoercion, +-- It's not clear whether or not isReflexiveCo would be better here +-- See #19815 for a bit of data and discussion on this point +coToMCo co | isReflCo co = MRefl + | otherwise = MCo co + +checkReflexiveMCo :: MCoercion -> MCoercion +checkReflexiveMCo MRefl = MRefl +checkReflexiveMCo (MCo co) | isReflexiveCo co = MRefl + | otherwise = MCo co + +-- | Tests if this MCoercion is obviously generalized reflexive +-- Guaranteed to work very quickly. +isGReflMCo :: MCoercion -> Bool +isGReflMCo MRefl = True +isGReflMCo (MCo co) | isGReflCo co = True +isGReflMCo _ = False + +-- | Make a generalized reflexive coercion +mkGReflCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflCo r ty mco + | isGReflMCo mco = if r == Nominal then Refl ty + else GRefl r ty MRefl + | otherwise + = -- I'd like to have this assert, but sadly it's not true during type + -- inference because the types are not fully zonked + -- assertPpr (case mco of + -- MCo co -> typeKind ty `eqType` coercionLKind co + -- MRefl -> True) + -- (vcat [ text "ty" <+> ppr ty <+> dcolon <+> ppr (typeKind ty) + -- , case mco of + -- MCo co -> text "co" <+> ppr co + -- <+> dcolon <+> ppr (coercionKind co) + -- MRefl -> text "MRefl" + -- , callStackDoc ]) $ + GRefl r ty mco + +mkGReflMCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion +mkGReflMCo r ty co = mkGReflCo r ty (MCo co) + +-- | Compose two MCoercions via transitivity +mkTransMCo :: MCoercion -> MCoercion -> MCoercion +mkTransMCo MRefl co2 = co2 +mkTransMCo co1 MRefl = co1 +mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2) + +mkTransMCoL :: MCoercion -> Coercion -> MCoercion +mkTransMCoL MRefl co2 = coToMCo co2 +mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2) + +mkTransMCoR :: Coercion -> MCoercion -> MCoercion +mkTransMCoR co1 MRefl = coToMCo co1 +mkTransMCoR co1 (MCo co2) = MCo (mkTransCo co1 co2) + +-- | Get the reverse of an 'MCoercion' +mkSymMCo :: MCoercion -> MCoercion +mkSymMCo MRefl = MRefl +mkSymMCo (MCo co) = MCo (mkSymCo co) + +-- | Cast a type by an 'MCoercion' +mkCastTyMCo :: Type -> MCoercion -> Type +mkCastTyMCo ty MRefl = ty +mkCastTyMCo ty (MCo co) = ty `mkCastTy` co + +mkPiMCos :: [Var] -> MCoercion -> MCoercion +mkPiMCos _ MRefl = MRefl +mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co) + +mkFunResMCo :: Id -> MCoercionR -> MCoercionR +mkFunResMCo _ MRefl = MRefl +mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co) + +mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflLeftMCo r ty MRefl = mkReflCo r ty +mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co + +mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflRightMCo r ty MRefl = mkReflCo r ty +mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co + +-- | Like 'mkCoherenceRightCo', but with an 'MCoercion' +mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion +mkCoherenceRightMCo _ _ MRefl co2 = co2 +mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2 + +isReflMCo :: MCoercion -> Bool +isReflMCo MRefl = True +isReflMCo _ = False + +{- +%************************************************************************ +%* * + Destructing coercions +%* * +%************************************************************************ +-} + +-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into +-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: +-- +-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] +decomposeCo :: Arity -> Coercion + -> Infinite Role -- the roles of the output coercions + -> [Coercion] +decomposeCo arity co rs + = [mkSelCo (SelTyCon n r) co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ] + -- Remember, SelTyCon is zero-indexed + +decomposeFunCo :: HasDebugCallStack + => Coercion -- Input coercion + -> (CoercionN, Coercion, Coercion) +-- Expects co :: (s1 %m1-> t1) ~ (s2 %m2-> t2) +-- Returns (cow :: m1 ~N m2, co1 :: s1~s2, co2 :: t1~t2) +-- actually cow will be a Phantom coercion if the input is a Phantom coercion + +decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) + = (w, co1, co2) + -- Short-circuits the calls to mkSelCo + +decomposeFunCo co + = assertPpr all_ok (ppr co) $ + ( mkSelCo (SelFun SelMult) co + , mkSelCo (SelFun SelArg) co + , mkSelCo (SelFun SelRes) co ) + where + Pair s1t1 s2t2 = coercionKind co + all_ok = isFunTy s1t1 && isFunTy s2t2 + +{- Note [Pushing a coercion into a pi-type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have this: + (f |> co) t1 .. tn +Then we want to push the coercion into the arguments, so as to make +progress. For example of why you might want to do so, see Note +[Respecting definitional equality] in GHC.Core.TyCo.Rep. + +This is done by decomposePiCos. Specifically, if + decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor) +then + (f |> co) t1 .. tn = (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn + +Notes: + +* k can be smaller than n! That is decomposePiCos can return *fewer* + coercions than there are arguments (ie k < n), if the kind provided + doesn't have enough binders. + +* If there is a type error, we might see + (f |> co) t1 + where co :: (forall a. ty) ~ (ty1 -> ty2) + Here 'co' is insoluble, but we don't want to crash in decoposePiCos. + So decomposePiCos carefully tests both sides of the coercion to check + they are both foralls or both arrows. Not doing this caused #15343. +-} + +decomposePiCos :: HasDebugCallStack + => CoercionN -> Pair Type -- Coercion and its kind + -> [Type] + -> ([CoercionN], CoercionN) +-- See Note [Pushing a coercion into a pi-type] +decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args + = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args + where + orig_subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co + + go :: [CoercionN] -- accumulator for argument coercions, reversed + -> (Subst,Kind) -- Lhs kind of coercion + -> CoercionN -- coercion originally applied to the function + -> (Subst,Kind) -- Rhs kind of coercion + -> [Type] -- Arguments to that function + -> ([CoercionN], Coercion) + -- Invariant: co :: subst1(k1) ~ subst2(k2) + + go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) + | Just (a, t1) <- splitForAllTyCoVar_maybe k1 + , Just (b, t2) <- splitForAllTyCoVar_maybe k2 + -- know co :: (forall a:s1.t1) ~ (forall b:s2.t2) + -- function :: forall a:s1.t1 (the function is not passed to decomposePiCos) + -- a :: s1 + -- b :: s2 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b] + = let arg_co = mkSelCo SelForAll (mkSymCo co) + res_co = mkInstCo co (mkGReflLeftCo Nominal ty arg_co) + subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co) + subst2' = extendTCvSubst subst2 b ty + in + go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys + + | Just (af1, _w1, _s1, t1) <- splitFunTy_maybe k1 + , Just (af2, _w1, _s2, t2) <- splitFunTy_maybe k2 + , af1 == af2 -- Same sort of arrow + -- know co :: (s1 -> t1) ~ (s2 -> t2) + -- function :: s1 -> t1 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1 ~ t2 + = let (_, sym_arg_co, res_co) = decomposeFunCo co + -- It should be fine to ignore the multiplicity bit + -- of the coercion for a Nominal coercion. + arg_co = mkSymCo sym_arg_co + in + go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys + + | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) + = go acc_arg_cos (zapSubst subst1, substTy subst1 k1) + co + (zapSubst subst2, substTy subst1 k2) + (ty:tys) + + -- tys might not be empty, if the left-hand type of the original coercion + -- didn't have enough binders + go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co) + +-- | Extract a covar, if possible. This check is dirty. Be ashamed +-- of yourself. (It's dirty because it cares about the structure of +-- a coercion, which is morally reprehensible.) +getCoVar_maybe :: Coercion -> Maybe CoVar +getCoVar_maybe (CoVarCo cv) = Just cv +getCoVar_maybe _ = Nothing + +multToCo :: Mult -> Coercion +multToCo r = mkNomReflCo r + +-- first result has role equal to input; third result is Nominal +splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +-- ^ Attempt to take a coercion application apart. +splitAppCo_maybe (AppCo co arg) = Just (co, arg) +splitAppCo_maybe (TyConAppCo r tc args) + | args `lengthExceeds` tyConArity tc + , Just (args', arg') <- snocView args + = Just ( mkTyConAppCo r tc args', arg' ) + + | not (tyConMustBeSaturated tc) + -- Never create unsaturated type family apps! + , Just (args', arg') <- snocView args + , Just arg'' <- setNominalRole_maybe (tyConRole r tc (length args')) arg' + = Just ( mkTyConAppCo r tc args', arg'' ) + -- Use mkTyConAppCo to preserve the invariant + -- that identity coercions are always represented by Refl + +splitAppCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + , Just (ty1, ty2) <- splitAppTy_maybe ty + = Just (mkReflCo r ty1, mkNomReflCo ty2) +splitAppCo_maybe _ = Nothing + +-- Only used in specialise/Rules +splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res) +splitFunCo_maybe _ = Nothing + +splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) +splitForAllCo_maybe (ForAllCo { fco_tcv = tv, fco_visL = vL, fco_visR = vR + , fco_kind = k_co, fco_body = co }) + = Just (tv, vL, vR, k_co, co) +splitForAllCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + , Just (Bndr tcv vis, body_ty) <- splitForAllForAllTyBinder_maybe ty + = Just (tcv, vis, vis, mkNomReflCo (varType tcv), mkReflCo r body_ty) +splitForAllCo_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder +splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) +splitForAllCo_ty_maybe co + | Just stuff@(tv, _, _, _, _) <- splitForAllCo_maybe co + , isTyVar tv + = Just stuff +splitForAllCo_ty_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder +splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) +splitForAllCo_co_maybe co + | Just stuff@(cv, _, _, _, _) <- splitForAllCo_maybe co + , isCoVar cv + = Just stuff +splitForAllCo_co_maybe _ = Nothing + +------------------------------------------------------- +-- and some coercion kind stuff + +coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type +coVarLType cv | (ty1, _, _) <- coVarTypesRole cv = ty1 +coVarRType cv | (_, ty2, _) <- coVarTypesRole cv = ty2 + +coVarTypes :: HasDebugCallStack => CoVar -> Pair Type +coVarTypes cv | (ty1, ty2, _) <- coVarTypesRole cv = Pair ty1 ty2 + +coVarTypesRole :: HasDebugCallStack => CoVar -> (Type,Type,Role) +coVarTypesRole cv + | Just (tc, [_,_,ty1,ty2]) <- splitTyConApp_maybe (varType cv) + = (ty1, ty2, eqTyConRole tc) + | otherwise + = pprPanic "coVarTypesRole, non coercion variable" + (ppr cv $$ ppr (varType cv)) + +coVarKind :: CoVar -> Type +coVarKind cv + = assert (isCoVar cv ) + varType cv + +coVarRole :: CoVar -> Role +coVarRole cv + = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of + Just tc0 -> tc0 + Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv)) + +eqTyConRole :: TyCon -> Role +-- Given (~#) or (~R#) return the Nominal or Representational respectively +eqTyConRole tc + | tc `hasKey` eqPrimTyConKey + = Nominal + | tc `hasKey` eqReprPrimTyConKey + = Representational + | otherwise + = pprPanic "eqTyConRole: unknown tycon" (ppr tc) + +-- | Given a coercion `co :: (t1 :: TYPE r1) ~ (t2 :: TYPE r2)` +-- produce a coercion `rep_co :: r1 ~ r2` +-- But actually it is possible that +-- co :: (t1 :: CONSTRAINT r1) ~ (t2 :: CONSTRAINT r2) +-- or co :: (t1 :: TYPE r1) ~ (t2 :: CONSTRAINT r2) +-- or co :: (t1 :: CONSTRAINT r1) ~ (t2 :: TYPE r2) +-- See Note [mkRuntimeRepCo] +mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion +mkRuntimeRepCo co + = assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $ + mkSelCo (SelTyCon 0 Nominal) kind_co + where + kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 + Pair k1 k2 = coercionKind kind_co + +{- Note [mkRuntimeRepCo] +~~~~~~~~~~~~~~~~~~~~~~~~ +Given + class C a where { op :: Maybe a } +we will get an axiom + axC a :: (C a :: CONSTRAINT r1) ~ (Maybe a :: TYPE r2) +(See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim.) + +Then we may call mkRuntimeRepCo on (axC ty), and that will return + mkSelCo (SelTyCon 0 Nominal) (Kind (axC ty)) :: r1 ~ r2 + +So mkSelCo needs to be happy with decomposing a coercion of kind + CONSTRAINT r1 ~ TYPE r2 + +Hence the use of `tyConIsTYPEorCONSTRAINT` in the assertion `good_call` +in `mkSelCo`. See #23018 for a concrete example. (In this context it's +important that TYPE and CONSTRAINT have the same arity and kind, not +merely that they are not-apart; otherwise SelCo would not make sense.) +-} + +isReflCoVar_maybe :: Var -> Maybe Coercion +-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) +-- Works on all kinds of Vars, not just CoVars +isReflCoVar_maybe cv + | isCoVar cv + , Pair ty1 ty2 <- coVarTypes cv + , ty1 `eqType` ty2 + = Just (mkReflCo (coVarRole cv) ty1) + | otherwise + = Nothing + +-- | Tests if this coercion is obviously a generalized reflexive coercion. +-- Guaranteed to work very quickly. +isGReflCo :: Coercion -> Bool +isGReflCo (GRefl{}) = True +isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl +isGReflCo _ = False + +-- | Tests if this coercion is obviously reflexive. Guaranteed to work +-- very quickly. Sometimes a coercion can be reflexive, but not obviously +-- so. c.f. 'isReflexiveCo' +isReflCo :: Coercion -> Bool +isReflCo (Refl{}) = True +isReflCo (GRefl _ _ mco) | isGReflMCo mco = True +isReflCo _ = False + +-- | Returns the type coerced if this coercion is a generalized reflexive +-- coercion. Guaranteed to work very quickly. +isGReflCo_maybe :: Coercion -> Maybe (Type, Role) +isGReflCo_maybe (GRefl r ty _) = Just (ty, r) +isGReflCo_maybe (Refl ty) = Just (ty, Nominal) +isGReflCo_maybe _ = Nothing + +-- | Returns the type coerced if this coercion is reflexive. Guaranteed +-- to work very quickly. Sometimes a coercion can be reflexive, but not +-- obviously so. c.f. 'isReflexiveCo_maybe' +isReflCo_maybe :: Coercion -> Maybe (Type, Role) +isReflCo_maybe (Refl ty) = Just (ty, Nominal) +isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflCo_maybe _ = Nothing + +-- | Slowly checks if the coercion is reflexive. Don't call this in a loop, +-- as it walks over the entire coercion. +isReflexiveCo :: Coercion -> Bool +isReflexiveCo = isJust . isReflexiveCo_maybe + +-- | Extracts the coerced type from a reflexive coercion. This potentially +-- walks over the entire coercion, so avoid doing this in a loop. +isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) +isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) +isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflexiveCo_maybe co + | ty1 `eqType` ty2 + = Just (ty1, r) + | otherwise + = Nothing + where (Pair ty1 ty2, r) = coercionKindRole co + + +{- +%************************************************************************ +%* * + Building coercions +%* * +%************************************************************************ + +These "smart constructors" maintain the invariants listed in the definition +of Coercion, and they perform very basic optimizations. + +Note [Role twiddling functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a plethora of functions for twiddling roles: + +mkSubCo: Requires a nominal input coercion and always produces a +representational output. This is used when you (the programmer) are sure you +know exactly that role you have and what you want. + +downgradeRole_maybe: This function takes both the input role and the output role +as parameters. (The *output* role comes first!) It can only *downgrade* a +role -- that is, change it from N to R or P, or from R to P. This one-way +behavior is why there is the "_maybe". If an upgrade is requested, this +function produces Nothing. This is used when you need to change the role of a +coercion, but you're not sure (as you're writing the code) of which roles are +involved. + +This function could have been written using coercionRole to ascertain the role +of the input. But, that function is recursive, and the caller of downgradeRole_maybe +often knows the input role. So, this is more efficient. + +downgradeRole: This is just like downgradeRole_maybe, but it panics if the +conversion isn't a downgrade. + +setNominalRole_maybe: This is the only function that can *upgrade* a coercion. +The result (if it exists) is always Nominal. The input can be at any role. It +works on a "best effort" basis, as it should never be strictly necessary to +upgrade a coercion during compilation. It is currently only used within GHC in +splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second +coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable +that splitAppCo_maybe is operating over a TyConAppCo that uses a +representational coercion. Hence the need for setNominalRole_maybe. +splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, +it is not absolutely critical that setNominalRole_maybe be complete. + +Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom +UnivCos are perfectly type-safe, whereas representational and nominal ones are +not. (Nominal ones are no worse than representational ones, so this function *will* +change a UnivCo Representational to a UnivCo Nominal.) + +Conal Elliott also came across a need for this function while working with the +GHC API, as he was decomposing Core casts. The Core casts use representational +coercions, as they must, but his use case required nominal coercions (he was +building a GADT). So, that's why this function is exported from this module. + +One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as +appropriate? I (Richard E.) have decided not to do this, because upgrading a +role is bizarre and a caller should have to ask for this behavior explicitly. + +-} + +-- | Make a reflexive coercion +mkReflCo :: Role -> Type -> Coercion +mkReflCo Nominal ty = Refl ty +mkReflCo r ty = GRefl r ty MRefl + +-- | Make a representational reflexive coercion +mkRepReflCo :: Type -> Coercion +mkRepReflCo ty = GRefl Representational ty MRefl + +-- | Make a nominal reflexive coercion +mkNomReflCo :: Type -> Coercion +mkNomReflCo = Refl + +-- | Apply a type constructor to a list of coercions. It is the +-- caller's responsibility to get the roles correct on argument coercions. +mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion +mkTyConAppCo r tc cos + | Just co <- tyConAppFunCo_maybe r tc cos + = co + + -- Expand type synonyms + | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos + = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos + + | Just tys_roles <- traverse isReflCo_maybe cos + = mkReflCo r (mkTyConApp tc (map fst tys_roles)) + -- See Note [Refl invariant] + + | otherwise = TyConAppCo r tc cos + +mkFunCoNoFTF :: HasDebugCallStack => Role -> CoercionN -> Coercion -> Coercion -> Coercion +-- This version of mkFunCo takes no FunTyFlags; it works them out +mkFunCoNoFTF r w arg_co res_co + = mkFunCo2 r afl afr w arg_co res_co + where + afl = chooseFunTyFlag argl_ty resl_ty + afr = chooseFunTyFlag argr_ty resr_ty + Pair argl_ty argr_ty = coercionKind arg_co + Pair resl_ty resr_ty = coercionKind res_co + +-- | Build a function 'Coercion' from two other 'Coercion's. That is, +-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@ +-- or @(a => x) ~ (b => y)@, depending on the kind of @a@/@b@. +-- This (most common) version takes a single FunTyFlag, which is used +-- for both fco_afl and ftf_afr of the FunCo +mkFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion +mkFunCo r af w arg_co res_co + = mkFunCo2 r af af w arg_co res_co + +mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion +-- This version of mkFunCo does not check FunCo invariants (checkFunCo) +-- It's a historical vestige; See Note [No assertion check on mkFunCo] +mkNakedFunCo = mkFunCo + +mkFunCo2 :: Role -> FunTyFlag -> FunTyFlag + -> CoercionN -> Coercion -> Coercion -> Coercion +-- This is the smart constructor for FunCo; it checks invariants +mkFunCo2 r afl afr w arg_co res_co + -- See Note [No assertion check on mkFunCo] + | Just (ty1, _) <- isReflCo_maybe arg_co + , Just (ty2, _) <- isReflCo_maybe res_co + , Just (w, _) <- isReflCo_maybe w + = mkReflCo r (mkFunTy afl w ty1 ty2) -- See Note [Refl invariant] + + | otherwise + = FunCo { fco_role = r, fco_afl = afl, fco_afr = afr + , fco_mult = w, fco_arg = arg_co, fco_res = res_co } + + +{- Note [No assertion check on mkFunCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have a checkFunCo assertion on mkFunCo, but during typechecking +we can (legitimately) have not-full-zonked types or coercion variables, so +the assertion spuriously fails (test T11480b is a case in point). Lint +checks all these things anyway. + +We used to get around the problem by calling mkNakedFunCo from within the +typechecker, which dodged the assertion check. But then mkAppCo calls +mkTyConAppCo, which calls tyConAppFunCo_maybe, which calls mkFunCo. +Duplicating this stack of calls with "naked" versions of each seems too much. + +-- Commented out: see Note [No assertion check on mkFunCo] +checkFunCo :: Role -> FunTyFlag -> FunTyFlag + -> CoercionN -> Coercion -> Coercion + -> Maybe SDoc +-- Checks well-formed-ness for FunCo +-- Used only in assertions and Lint +{-# NOINLINE checkFunCo #-} +checkFunCo _r afl afr _w arg_co res_co + | not (ok argl_ty && ok argr_ty && ok resl_ty && ok resr_ty) + = Just (hang (text "Bad arg or res types") 2 pp_inputs) + + | afl == computed_afl + , afr == computed_afr + = Nothing + | otherwise + = Just (vcat [ text "afl (provided,computed):" <+> ppr afl <+> ppr computed_afl + , text "afr (provided,computed):" <+> ppr afr <+> ppr computed_afr + , pp_inputs ]) + where + computed_afl = chooseFunTyFlag argl_ty resl_ty + computed_afr = chooseFunTyFlag argr_ty resr_ty + Pair argl_ty argr_ty = coercionKind arg_co + Pair resl_ty resr_ty = coercionKind res_co + + pp_inputs = vcat [ pp_ty "argl" argl_ty, pp_ty "argr" argr_ty + , pp_ty "resl" resl_ty, pp_ty "resr" resr_ty + , text "arg_co:" <+> ppr arg_co + , text "res_co:" <+> ppr res_co ] + + ok ty = isTYPEorCONSTRAINT (typeKind ty) + pp_ty str ty = text str <> colon <+> hang (ppr ty) + 2 (dcolon <+> ppr (typeKind ty)) +-} + +-- | Apply a 'Coercion' to another 'Coercion'. +-- The second coercion must be Nominal, unless the first is Phantom. +-- If the first is Phantom, then the second can be either Phantom or Nominal. +mkAppCo :: Coercion -- ^ :: t1 ~r t2 + -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 + -> Coercion -- ^ :: t1 s1 ~r t2 s2 +mkAppCo co arg + | Just (ty1, r) <- isReflCo_maybe co + , Just (ty2, _) <- isReflCo_maybe arg + = mkReflCo r (mkAppTy ty1 ty2) + + | Just (ty1, r) <- isReflCo_maybe co + , Just (tc, tys) <- splitTyConApp_maybe ty1 + -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) + = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) + where + zip_roles (Inf r1 _) [] = [downgradeRole r1 Nominal arg] + zip_roles (Inf r1 rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys + +mkAppCo (TyConAppCo r tc args) arg + = case r of + Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) + Representational -> mkTyConAppCo Representational tc (args ++ [arg']) + where new_role = tyConRolesRepresentational tc Inf.!! length args + arg' = downgradeRole new_role Nominal arg + Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) +mkAppCo co arg = AppCo co arg +-- Note, mkAppCo is careful to maintain invariants regarding +-- where Refl constructors appear; see the comments in the definition +-- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep. + +-- | Applies multiple 'Coercion's to another 'Coercion', from left to right. +-- See also 'mkAppCo'. +mkAppCos :: Coercion + -> [Coercion] + -> Coercion +mkAppCos co1 cos = foldl' mkAppCo co1 cos + + +-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. +mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion +mkForAllCo v visL visR kind_co co + | Just (ty, r) <- isReflCo_maybe co + , isReflCo kind_co + , visL `eqForAllVis` visR + = mkReflCo r (mkTyCoForAllTy v visL ty) + + | otherwise + = mkForAllCo_NoRefl v visL visR kind_co co + +-- mkForAllVisCos [tv{vis}] constructs a cast +-- forall tv. res ~R# forall tv{vis} res`. +-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep +mkForAllVisCos :: HasDebugCallStack => [ForAllTyBinder] -> Coercion -> Coercion +mkForAllVisCos bndrs orig_co = foldr go orig_co bndrs + where + go (Bndr tv vis) + = mkForAllCo tv coreTyLamForAllTyFlag vis (mkNomReflCo (varType tv)) + +-- | Make a Coercion quantified over a type/coercion variable; +-- the variable has the same kind and visibility in both sides of the coercion +mkHomoForAllCos :: [ForAllTyBinder] -> Coercion -> Coercion +mkHomoForAllCos vs orig_co + | Just (ty, r) <- isReflCo_maybe orig_co + = mkReflCo r (mkTyCoForAllTys vs ty) + | otherwise + = foldr go orig_co vs + where + go (Bndr var vis) co + = mkForAllCo_NoRefl var vis vis (mkNomReflCo (varType var)) co + +-- | Like 'mkForAllCo', but there is no need to check that the inner coercion isn't Refl; +-- the caller has done that. (For example, it is guaranteed in 'mkHomoForAllCos'.) +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +mkForAllCo_NoRefl :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion +mkForAllCo_NoRefl tcv visL visR kind_co co + = assertGoodForAllCo tcv visL visR kind_co co $ + assertPpr (not (isReflCo co && isReflCo kind_co && visL == visR)) (ppr co) $ + ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = co } + +assertGoodForAllCo :: HasDebugCallStack + => TyCoVar -> ForAllTyFlag -> ForAllTyFlag + -> CoercionN -> Coercion -> a -> a +-- Check ForAllCo invariants; see Note [ForAllCo] in GHC.Core.TyCo.Rep +assertGoodForAllCo tcv visL visR kind_co co + | isTyVar tcv + = assertPpr (tcv_type `eqType` kind_co_lkind) doc + + | otherwise + = assertPpr (tcv_type `eqType` kind_co_lkind) doc + -- The kind of the tycovar should be the left-hand kind of the kind coercion. + . assertPpr (almostDevoidCoVarOfCo tcv co) doc + -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep + . assertPpr (visL == coreTyLamForAllTyFlag + && visR == coreTyLamForAllTyFlag) doc + -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep + where + tcv_type = varType tcv + kind_co_lkind = coercionLKind kind_co + + doc = vcat [ text "Var:" <+> ppr tcv <+> dcolon <+> ppr tcv_type + , text "Vis:" <+> ppr visL <+> ppr visR + , text "kind_co:" <+> ppr kind_co + , text "kind_co_lkind" <+> ppr kind_co_lkind + , text "body_co" <+> ppr co ] + + +mkNakedForAllCo :: TyVar -- Never a CoVar + -> ForAllTyFlag -> ForAllTyFlag + -> CoercionN -> Coercion -> Coercion +-- This version lacks the assertion checks. +-- Used during type checking when the arguments may (legitimately) not be zonked +-- and so the assertions might (bogusly) fail +-- NB: since the coercions are un-zonked, we can't really deal with +-- (FC6) and (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep. +-- Fortunately we don't have to: this function is needed only for /type/ variables. +mkNakedForAllCo tv visL visR kind_co co + | assertPpr (isTyVar tv) (ppr tv) True + , Just (ty, r) <- isReflCo_maybe co + , isReflCo kind_co + , visL `eqForAllVis` visR + = mkReflCo r (mkForAllTy (Bndr tv visL) ty) + | otherwise + = ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = co } + + +mkCoVarCo :: CoVar -> Coercion +-- cv :: s ~# t +-- See Note [mkCoVarCo] +mkCoVarCo cv = CoVarCo cv + +mkCoVarCos :: [CoVar] -> [Coercion] +mkCoVarCos = map mkCoVarCo + +{- Note [mkCoVarCo] +~~~~~~~~~~~~~~~~~~~ +In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is +valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but +it's a relatively expensive test and perhaps better done in +optCoercion. Not a big deal either way. +-} + +mkAxInstCo :: Role + -> CoAxiomRule -- Always BranchedAxiom or UnbranchedAxiom + -> [Type] -> [Coercion] + -> Coercion +-- mkAxInstCo can legitimately be called over-saturated; +-- i.e. with more type arguments than the coercion requires +-- Only called with BranchedAxiom or UnbranchedAxiom +mkAxInstCo role axr tys cos + | arity == n_tys = downgradeRole role ax_role $ + AxiomCo axr (rtys `chkAppend` cos) + | otherwise = assert (arity < n_tys) $ + downgradeRole role ax_role $ + mkAppCos (AxiomCo axr (ax_args `chkAppend` cos)) + leftover_args + where + (ax_role, branch) = case coAxiomRuleBranch_maybe axr of + Just (_tc, ax_role, branch) -> (ax_role, branch) + Nothing -> pprPanic "mkAxInstCo" (ppr axr) + n_tys = length tys + arity = length (coAxBranchTyVars branch) + arg_roles = coAxBranchRoles branch + rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys + (ax_args, leftover_args) = splitAt arity rtys + +-- worker function +mkAxiomCo :: CoAxiomRule -> [Coercion] -> Coercion +mkAxiomCo = AxiomCo + +-- to be used only with unbranched axioms +mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched + -> [Type] -> [Coercion] -> Coercion +mkUnbranchedAxInstCo role ax tys cos + = mkAxInstCo role (UnbranchedAxiom ax) tys cos + +mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +-- Instantiate the axiom with specified types, +-- returning the instantiated RHS +-- A companion to mkAxInstCo: +-- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) +mkAxInstRHS ax index tys cos + = assert (tvs `equalLength` tys1) $ + mkAppTys rhs' tys2 + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + rhs' = substTyWith tvs tys1 $ + substTyWithCoVars cvs cos $ + coAxBranchRHS branch + +mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 + +-- | Return the left-hand type of the axiom, when the axiom is instantiated +-- at the types given. +mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +mkAxInstLHS ax index tys cos + = assert (tvs `equalLength` tys1) $ + mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + lhs_tys = substTysWith tvs tys1 $ + substTysWithCoVars cvs cos $ + coAxBranchLHS branch + fam_tc = coAxiomTyCon ax + +-- | Instantiate the left-hand side of an unbranched axiom +mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 + +-- | Make a coercion from a coercion hole +mkHoleCo :: CoercionHole -> Coercion +mkHoleCo h = HoleCo h + +-- | Make a universal coercion between two arbitrary types. +mkUnivCo :: UnivCoProvenance + -> [Coercion] -- ^ Coercions on which this depends + -> Role -- ^ role of the built coercion, "r" + -> Type -- ^ t1 :: k1 + -> Type -- ^ t2 :: k2 + -> Coercion -- ^ :: t1 ~r t2 +mkUnivCo prov deps role ty1 ty2 + | ty1 `eqType` ty2 = mkReflCo role ty1 + | otherwise = UnivCo { uco_prov = prov, uco_role = role + , uco_lty = ty1, uco_rty = ty2 + , uco_deps = deps } + +-- | Create a symmetric version of the given 'Coercion' that asserts +-- equality between the same types but in the other "direction", so +-- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. +mkSymCo :: Coercion -> Coercion + +-- Do a few simple optimizations, mainly to expose the underlying +-- constructors to other 'mk' functions. E.g. +-- mkInstCo (mkSymCo (ForAllCo ...)) ty +-- We want to push the SymCo inside the ForallCo, so that we can instantiate +-- This can make a big difference. E.g without coercion optimisation, GHC.Read +-- totally explodes; but when we push Sym inside ForAll, it's fine. +mkSymCo co | isReflCo co = co +mkSymCo (SymCo co) = co +mkSymCo (SubCo (SymCo co)) = SubCo co +mkSymCo co@(ForAllCo { fco_kind = kco, fco_body = body_co }) + | isReflCo kco = co { fco_body = mkSymCo body_co } +mkSymCo co = SymCo co + +-- | mkTransCo creates a new 'Coercion' by composing the two +-- given 'Coercion's transitively: (co1 ; co2) +mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion +mkTransCo co1 co2 + | isReflCo co1 = co2 + | isReflCo co2 = co1 + + | GRefl r t1 (MCo kco1) <- co1 + , GRefl _ _ (MCo kco2) <- co2 + = GRefl r t1 (MCo $ mkTransCo kco1 kco2) + + | otherwise + = TransCo co1 co2 + +-------------------- +{- Note [mkSelCo precondition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To satisfy the Purely Kinded Type Invariant (PKTI), we require that + in any call (mkSelCo cs co) + * selectFromType cs (coercionLKind co) works + * selectFromType cs (coercionRKind co) works + * and hence coercionKind (SelCo cs co) works (PKTI) +-} + +mkSelCo :: HasDebugCallStack + => CoSel + -> Coercion + -> Coercion +-- See Note [mkSelCo precondition] +mkSelCo n co = mkSelCo_maybe n co `orElse` SelCo n co + +mkSelCo_maybe :: HasDebugCallStack + => CoSel + -> Coercion + -> Maybe Coercion +-- Note [mkSelCo precondition] +mkSelCo_maybe cs co + = assertPpr (good_call cs) bad_call_msg $ + go cs co + where + + go SelForAll (ForAllCo { fco_kind = kind_co }) + = Just kind_co + -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) + -- then (nth SelForAll co :: k1 ~N k2) + -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) + -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4)) + + go (SelFun fs) (FunCo _ _ _ w arg res) + = Just (getNthFun fs w arg res) + + go (SelTyCon i r) (TyConAppCo r0 tc arg_cos) + = assertPpr (r == tyConRole r0 tc i) + (vcat [ ppr tc, ppr arg_cos, ppr r0, ppr i, ppr r ]) $ + Just (arg_cos `getNth` i) + + go cs (SymCo co) -- Recurse, hoping to get to a TyConAppCo or FunCo + = do { co' <- go cs co; return (mkSymCo co') } + + go cs co + | Just (ty, co_role) <- isReflCo_maybe co + = Just (mkReflCo (mkSelCoResRole cs co_role) (selectFromType cs ty)) + -- mkSelCoreResRole: The role of the result may not be + -- be equal to co_role, the role of co, per Note [SelCo]. + -- This was revealed by #23938. + + | Pair ty1 ty2 <- coercionKind co + , let sty1 = selectFromType cs ty1 + sty2 = selectFromType cs ty2 + co_role = coercionRole co + , sty1 `eqType` sty2 + = Just (mkReflCo (mkSelCoResRole cs co_role) sty1) + -- Checking for fully reflexive-ness (by seeing if sty1=sty2) + -- is worthwhile, because a non-Refl coercion `co` may well have a + -- reflexive (SelCo cs co). + -- E.g. co :: Either a b ~ Either a c + -- Then (SubCo (SelTyCon 0) co) is reflexive + + | otherwise = Nothing + + ----------- Assertion checking -------------- + -- NB: using coercionKind requires Note [mkSelCo precondition] + Pair ty1 ty2 = coercionKind co + bad_call_msg = vcat [ text "Coercion =" <+> ppr co + , text "LHS ty =" <+> ppr ty1 + , text "RHS ty =" <+> ppr ty2 + , text "cs =" <+> ppr cs + , text "coercion role =" <+> ppr (coercionRole co) ] + + -- good_call checks the typing rules given in Note [SelCo] + good_call SelForAll + | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1 + , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2 + = True + + good_call (SelFun {}) + = isFunTy ty1 && isFunTy ty2 + + good_call (SelTyCon n r) + | Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , let { len1 = length tys1 + ; len2 = length tys2 } + = (tc1 == tc2 || (tyConIsTYPEorCONSTRAINT tc1 && tyConIsTYPEorCONSTRAINT tc2)) + -- tyConIsTYPEorCONSTRAINT: see Note [mkRuntimeRepCo] + && len1 == len2 + && n < len1 + && r == tyConRole (coercionRole co) tc1 n + + good_call _ = False + +mkSelCoResRole :: CoSel -> Role -> Role +-- What is the role of (SelCo cs co), if co has role 'r'? +-- It is not just 'r'! +-- c.f. the SelCo case of coercionRole +mkSelCoResRole SelForAll _ = Nominal +mkSelCoResRole (SelTyCon _ r') _ = r' +mkSelCoResRole (SelFun fs) r = funRole r fs + +-- | Extract the nth field of a FunCo +getNthFun :: FunSel + -> a -- ^ multiplicity + -> a -- ^ argument + -> a -- ^ result + -> a -- ^ One of the above three +getNthFun SelMult mult _ _ = mult +getNthFun SelArg _ arg _ = arg +getNthFun SelRes _ _ res = res + +selectFromType :: HasDebugCallStack => CoSel -> Type -> Type +selectFromType (SelFun fs) ty + | Just (_af, mult, arg, res) <- splitFunTy_maybe ty + = getNthFun fs mult arg res + +selectFromType (SelTyCon n _) ty + | Just args <- tyConAppArgs_maybe ty + = assertPpr (args `lengthExceeds` n) (ppr n $$ ppr ty) $ + args `getNth` n + +selectFromType SelForAll ty -- Works for both tyvar and covar + | Just (tv,_) <- splitForAllTyCoVar_maybe ty + = tyVarKind tv + +selectFromType cs ty + = pprPanic "selectFromType" (ppr cs $$ ppr ty) + +-------------------- +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkLRCo lr co + | Just (ty, eq) <- isReflCo_maybe co + = mkReflCo eq (pickLR lr (splitAppTy ty)) + | otherwise + = LRCo lr co + +-- | Instantiates a 'Coercion'. +-- Works for both tyvar and covar +mkInstCo :: Coercion -> CoercionN -> Coercion +mkInstCo co_fun co_arg + | Just (tcv, _, _, kind_co, body_co) <- splitForAllCo_maybe co_fun + , Just (arg, _) <- isReflCo_maybe co_arg + = assertPpr (isReflexiveCo kind_co) (ppr co_fun $$ ppr co_arg) $ + -- If the arg is Refl, then kind_co must be reflexive too + substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co +mkInstCo co arg = InstCo co arg + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- produces @co' :: ty ~r (ty |> co)@ +mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion +mkGReflRightCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = mkGReflMCo r ty co + +-- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@, +-- produces @co' :: (ty |> co) ~r ty@ +mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion +mkGReflLeftCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = mkSymCo $ mkGReflMCo r ty co + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, +-- produces @co' :: (ty |> co) ~r ty' +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceLeftCo r ty co co2 + | isGReflCo co = co2 + | otherwise = (mkSymCo $ mkGReflMCo r ty co) `mkTransCo` co2 + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@, +-- produces @co' :: ty' ~r (ty |> co) +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceRightCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceRightCo r ty co co2 + | isGReflCo co = co2 + | otherwise = co2 `mkTransCo` mkGReflMCo r ty co + +-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@. +mkKindCo :: Coercion -> Coercion +mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty) +mkKindCo (GRefl _ _ (MCo co)) = co +mkKindCo co + | Pair ty1 ty2 <- coercionKind co + -- Generally, calling coercionKind during coercion creation is a bad idea, + -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, + -- so it's OK here. + , let tk1 = typeKind ty1 + tk2 = typeKind ty2 + , tk1 `eqType` tk2 + = Refl tk1 + | otherwise + = KindCo co + +mkSubCo :: HasDebugCallStack => Coercion -> Coercion +-- Input coercion is Nominal, result is Representational +-- see also Note [Role twiddling functions] +mkSubCo (Refl ty) = GRefl Representational ty MRefl +mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co +mkSubCo (TyConAppCo Nominal tc cos) + = TyConAppCo Representational tc (applyRoles tc cos) +mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res }) + = co { fco_role = Representational + , fco_arg = downgradeRole Representational Nominal arg + , fco_res = downgradeRole Representational Nominal res } +mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $ + SubCo co + +-- | Changes a role, but only a downgrade. See Note [Role twiddling functions] +downgradeRole_maybe :: Role -- ^ desired role + -> Role -- ^ current role + -> Coercion -> Maybe Coercion +-- In (downgradeRole_maybe dr cr co) it's a precondition that +-- cr = coercionRole co + +downgradeRole_maybe Nominal Nominal co = Just co +downgradeRole_maybe Nominal _ _ = Nothing + +downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) +downgradeRole_maybe Representational Representational co = Just co +downgradeRole_maybe Representational Phantom _ = Nothing + +downgradeRole_maybe Phantom Phantom co = Just co +downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) + +-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. +-- See Note [Role twiddling functions] +downgradeRole :: Role -- desired role + -> Role -- current role + -> Coercion -> Coercion +downgradeRole r1 r2 co + = case downgradeRole_maybe r1 r2 co of + Just co' -> co' + Nothing -> pprPanic "downgradeRole" (ppr co) + +-- | Make a "coercion between coercions". +mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" + -> CoercionN -- ^ :: phi1 ~N phi2 + -> Coercion -- ^ g1 :: phi1 + -> Coercion -- ^ g2 :: phi2 + -> Coercion -- ^ :: g1 ~r g2 + +-- if the two coercion prove the same fact, I just don't care what +-- the individual coercions are. +mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g) + -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@ +mkProofIrrelCo r kco g1 g2 = mkUnivCo ProofIrrelProv [kco] r + (mkCoercionTy g1) (mkCoercionTy g2) + +{- +%************************************************************************ +%* * + Roles +%* * +%************************************************************************ +-} + +-- | Converts a coercion to be nominal, if possible. +-- See Note [Role twiddling functions] +setNominalRole_maybe :: Role -- of input coercion + -> Coercion -> Maybe CoercionN +setNominalRole_maybe r co + | r == Nominal = Just co + | otherwise = setNominalRole_maybe_helper co + where + setNominalRole_maybe_helper (SubCo co) = Just co + setNominalRole_maybe_helper co@(Refl _) = Just co + setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co + setNominalRole_maybe_helper (TyConAppCo Representational tc cos) + = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos + ; return $ TyConAppCo Nominal tc cos' } + setNominalRole_maybe_helper co@(FunCo { fco_role = Representational + , fco_arg = co1, fco_res = co2 }) + = do { co1' <- setNominalRole_maybe Representational co1 + ; co2' <- setNominalRole_maybe Representational co2 + ; return $ co { fco_role = Nominal, fco_arg = co1', fco_res = co2' } + } + setNominalRole_maybe_helper (SymCo co) + = SymCo <$> setNominalRole_maybe_helper co + setNominalRole_maybe_helper (TransCo co1 co2) + = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2 + setNominalRole_maybe_helper (AppCo co1 co2) + = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2 + setNominalRole_maybe_helper co@(ForAllCo { fco_visL = visL, fco_visR = visR, fco_body = body_co }) + | visL `eqForAllVis` visR -- See (FC3) in Note [ForAllCo] in GHC.Core.TyCo.Rep + = do { body_co' <- setNominalRole_maybe_helper body_co + ; return (co { fco_body = body_co' }) } + setNominalRole_maybe_helper (SelCo cs co) = + -- NB, this case recurses via setNominalRole_maybe, not + -- setNominalRole_maybe_helper! + case cs of + SelTyCon n _r -> + -- Remember to update the role in SelTyCon to nominal; + -- not doing this caused #23362. + -- See the typing rule in Note [SelCo] in GHC.Core.TyCo.Rep. + SelCo (SelTyCon n Nominal) <$> setNominalRole_maybe (coercionRole co) co + SelFun fs -> + SelCo (SelFun fs) <$> setNominalRole_maybe (coercionRole co) co + SelForAll -> + pprPanic "setNominalRole_maybe: the coercion should already be nominal" (ppr co) + setNominalRole_maybe_helper (InstCo co arg) + = InstCo <$> setNominalRole_maybe_helper co <*> pure arg + setNominalRole_maybe_helper co@(UnivCo { uco_prov = prov }) + | case prov of PhantomProv {} -> False -- should always be phantom + ProofIrrelProv {} -> True -- it's always safe + PluginProv {} -> False -- who knows? This choice is conservative. + = Just $ co { uco_role = Nominal } + setNominalRole_maybe_helper _ = Nothing + +-- | Make a phantom coercion between two types. The coercion passed +-- in must be a nominal coercion between the kinds of the +-- types. +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkPhantomCo h t1 t2 + = mkUnivCo PhantomProv [h] Phantom t1 t2 + +-- takes any coercion and turns it into a Phantom coercion +toPhantomCo :: Coercion -> Coercion +toPhantomCo co + = mkPhantomCo (mkKindCo co) ty1 ty2 + where Pair ty1 ty2 = coercionKind co + +-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational +applyRoles :: TyCon -> [Coercion] -> [Coercion] +applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational + +-- The Role parameter is the Role of the TyConAppCo +-- defined here because this is intimately concerned with the implementation +-- of TyConAppCo +-- Always returns an infinite list (with a infinite tail of Nominal) +tyConRolesX :: Role -> TyCon -> Infinite Role +tyConRolesX Representational tc = tyConRolesRepresentational tc +tyConRolesX role _ = Inf.repeat role + +tyConRoleListX :: Role -> TyCon -> [Role] +tyConRoleListX role = Inf.toList . tyConRolesX role + +-- Returns the roles of the parameters of a tycon, with an infinite tail +-- of Nominal +tyConRolesRepresentational :: TyCon -> Infinite Role +tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal + +-- Returns the roles of the parameters of a tycon, with an infinite tail +-- of Nominal +tyConRoleListRepresentational :: TyCon -> [Role] +tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational + +tyConRole :: Role -> TyCon -> Int -> Role +tyConRole Nominal _ _ = Nominal +tyConRole Phantom _ _ = Phantom +tyConRole Representational tc n = tyConRolesRepresentational tc Inf.!! n + +funRole :: Role -> FunSel -> Role +funRole Nominal _ = Nominal +funRole Phantom _ = Phantom +funRole Representational fs = funRoleRepresentational fs + +funRoleRepresentational :: FunSel -> Role +funRoleRepresentational SelMult = Nominal +funRoleRepresentational SelArg = Representational +funRoleRepresentational SelRes = Representational + +ltRole :: Role -> Role -> Bool +-- Is one role "less" than another? +-- Nominal < Representational < Phantom +ltRole Phantom _ = False +ltRole Representational Phantom = True +ltRole Representational _ = False +ltRole Nominal Nominal = False +ltRole Nominal _ = True + +------------------------------- + +-- | like mkKindCo, but aggressively & recursively optimizes to avoid using +-- a KindCo constructor. The output role is nominal. +promoteCoercion :: HasDebugCallStack => Coercion -> CoercionN + +-- First cases handles anything that should yield refl. +promoteCoercion co = case co of + + Refl _ -> mkNomReflCo ki1 + + GRefl _ _ MRefl -> mkNomReflCo ki1 + + GRefl _ _ (MCo co) -> co + + _ | ki1 `eqType` ki2 + -> mkNomReflCo (typeKind ty1) + -- No later branch should return refl + -- The assert (False )s throughout + -- are these cases explicitly, but they should never fire. + + TyConAppCo _ tc args + | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args + -> co' + | otherwise + -> mkKindCo co + + AppCo co1 arg + | Just co' <- instCoercion (coercionKind (mkKindCo co1)) + (promoteCoercion co1) arg + -> co' + | otherwise + -> mkKindCo co + + ForAllCo { fco_tcv = tv, fco_body = g } + | isTyVar tv + -> promoteCoercion g + + ForAllCo {} + -> assert False $ + -- (ForAllCo {} :: (forall cv.t1) ~ (forall cv.t2) + -- The tyvar case is handled above, so the bound var is a + -- a coercion variable. So both sides have kind Type + -- (Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep). + -- So the result is Refl, and that should have been caught by + -- the first equation above. Hence `assert False` + mkNomReflCo liftedTypeKind + + FunCo {} -> mkKindCo co + -- We can get Type~Constraint or Constraint~Type + -- from FunCo {} :: (a -> (b::Type)) ~ (a -=> (b'::Constraint)) + + CoVarCo {} -> mkKindCo co + HoleCo {} -> mkKindCo co + AxiomCo {} -> mkKindCo co + UnivCo {} -> mkKindCo co -- We could instead return the (single) `uco_deps` coercion in + -- the `ProofIrrelProv` and `PhantomProv` cases, but it doesn't + -- quite seem worth doing. + + SymCo g + -> mkSymCo (promoteCoercion g) + + TransCo co1 co2 + -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) + + SelCo n co1 + | Just co' <- mkSelCo_maybe n co1 + -> promoteCoercion co' + + | otherwise + -> mkKindCo co + + LRCo lr co1 + | Just (lco, rco) <- splitAppCo_maybe co1 + -> case lr of + CLeft -> promoteCoercion lco + CRight -> promoteCoercion rco + + | otherwise + -> mkKindCo co + + InstCo g _ + | isForAllTy_ty ty1 + -> assert (isForAllTy_ty ty2) $ + promoteCoercion g + | otherwise + -> assert False $ + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep + + KindCo _ + -> assert False $ -- See the first equation above + mkNomReflCo liftedTypeKind + + SubCo g + -> promoteCoercion g + + where + Pair ty1 ty2 = coercionKind co + ki1 = typeKind ty1 + ki2 = typeKind ty2 + +-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, +-- where @g' = promoteCoercion (h w)@. +-- fails if this is not possible, if @g@ coerces between a forall and an -> +-- or if second parameter has a representational role and can't be used +-- with an InstCo. +instCoercion :: Pair Type -- g :: lty ~ rty + -> CoercionN -- ^ must be nominal + -> Coercion + -> Maybe CoercionN +instCoercion (Pair lty rty) g w + | (isForAllTy_ty lty && isForAllTy_ty rty) + || (isForAllTy_co lty && isForAllTy_co rty) + , Just w' <- setNominalRole_maybe (coercionRole w) w + -- g :: (forall t1. t2) ~ (forall t1. t3) + -- w :: s1 ~ s2 + -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] + = Just $ mkInstCo g w' + + | isFunTy lty && isFunTy rty + -- g :: (t1 -> t2) ~ (t3 -> t4) + -- returns t2 ~ t4 + = Just $ mkSelCo (SelFun SelRes) g -- extract result type + + | otherwise -- one forall, one funty... + = Nothing + +-- | Repeated use of 'instCoercion' +instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN +instCoercions g ws + = let arg_ty_pairs = map coercionKind ws in + snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) + where + go :: (Pair Type, Coercion) -> (Pair Type, Coercion) + -> Maybe (Pair Type, Coercion) + go (g_tys, g) (w_tys, w) + = do { g' <- instCoercion g_tys g w + ; return (piResultTy <$> g_tys <*> w_tys, g') } + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +castCoercionKind2 :: Coercion -> Role -> Type -> Type + -> CoercionN -> CoercionN -> Coercion +castCoercionKind2 g r t1 t2 h1 h2 + = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) + +-- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@ +-- That is, it's a specialised form of castCoercionKind, where the two +-- kind coercions are identical +-- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h) ~r (t2 |> h)@. +-- @h@ must be nominal. +-- See Note [castCoercionKind1] +castCoercionKind1 :: Coercion -> Role -> Type -> Type + -> CoercionN -> Coercion +castCoercionKind1 g r t1 t2 h + = case g of + Refl {} -> assert (r == Nominal) $ -- Refl is always Nominal + mkNomReflCo (mkCastTy t2 h) + GRefl _ _ mco -> case mco of + MRefl -> mkReflCo r (mkCastTy t2 h) + MCo kind_co -> mkGReflMCo r (mkCastTy t1 h) + (mkSymCo h `mkTransCo` kind_co `mkTransCo` h) + _ -> castCoercionKind2 g r t1 t2 h h + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for) +-- Use @castCoercionKind2@ instead if @t1@, @t2@, and @r@ are known beforehand. +castCoercionKind :: Coercion -> CoercionN -> CoercionN -> Coercion +castCoercionKind g h1 h2 + = castCoercionKind2 g r t1 t2 h1 h2 + where + (Pair t1 t2, r) = coercionKindRole g + +mkPiCos :: Role -> [Var] -> Coercion -> Coercion +mkPiCos r vs co = foldr (mkPiCo r) co vs + +-- | Make a forall 'Coercion', where both types related by the coercion +-- are quantified over the same variable. +mkPiCo :: Role -> Var -> Coercion -> Coercion +mkPiCo r v co | isTyVar v = mkHomoForAllCos [Bndr v coreTyLamForAllTyFlag] co + | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $ + -- We didn't call mkForAllCo here because if v does not appear + -- in co, the argument coercion will be nominal. But here we + -- want it to be r. It is only called in 'mkPiCos', which is + -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for + -- now (Aug 2018) v won't occur in co. + mkFunResCo r v co + | otherwise = mkFunResCo r v co + +mkFunResCo :: Role -> Id -> Coercion -> Coercion +-- Given res_co :: res1 ~ res2, +-- mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2) +-- Reflexive in the multiplicity argument +mkFunResCo role id res_co + = mkFunCoNoFTF role mult arg_co res_co + where + arg_co = mkReflCo role (varType id) + mult = multToCo (idMult id) + +-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 +-- The first coercion might be lifted or unlifted; thus the ~? above +-- Lifted and unlifted equalities take different numbers of arguments, +-- so we have to make sure to supply the right parameter to decomposeCo. +-- Also, note that the role of the first coercion is the same as the role of +-- the equalities related by the second coercion. The second coercion is +-- itself always representational. +mkCoCast :: Coercion -> CoercionR -> Coercion +mkCoCast c g + | (g2:g1:_) <- reverse co_list + = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 + + | otherwise + = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g)) + where + -- g :: (s1 ~# t1) ~# (s2 ~# t2) + -- g1 :: s1 ~# s2 + -- g2 :: t1 ~# t2 + (tc, _) = splitTyConApp (coercionLKind g) + co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc) + +{- Note [castCoercionKind1] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +castCoercionKind1 deals with the very important special case of castCoercionKind2 +where the two kind coercions are identical. In that case we can exploit the +situation where the main coercion is reflexive, via the special cases for Refl +and GRefl. + +This is important when rewriting (ty |> co). We rewrite ty, yielding + fco :: ty ~ ty' +and now we want a coercion xco between + xco :: (ty |> co) ~ (ty' |> co) +That's exactly what castCoercionKind1 does. And it's very very common for +fco to be Refl. In that case we do NOT want to get some terrible composition +of mkLeftCoherenceCo and mkRightCoherenceCo, which is what castCoercionKind2 +has to do in its full generality. See #18413. +-} + +{- +%************************************************************************ +%* * + Newtypes +%* * +%************************************************************************ +-} + +-- | If `instNewTyCon_maybe T ts = Just (rep_ty, co)` +-- then `co :: T ts ~R# rep_ty` +-- +-- Checks for a newtype, and for being saturated +instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) +instNewTyCon_maybe tc tys + | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype + , tvs `leLength` tys -- Check saturated enough + = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Type normalisation +* * +************************************************************************ +-} + +-- | A function to check if we can reduce a type by one step. Used +-- with 'topNormaliseTypeX'. +type NormaliseStepper ev = RecTcChecker + -> TyCon -- tc + -> [Type] -- tys + -> NormaliseStepResult ev + +-- | The result of stepping in a normalisation function. +-- See 'topNormaliseTypeX'. +data NormaliseStepResult ev + = NS_Done -- ^ Nothing more to do + | NS_Abort -- ^ Utter failure. The outer function should fail too. + | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; + -- ^ ev is evidence; + -- Usually a co :: old type ~ new type + deriving (Functor) + +instance Outputable ev => Outputable (NormaliseStepResult ev) where + ppr NS_Done = text "NS_Done" + ppr NS_Abort = text "NS_Abort" + ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev] + +-- | Try one stepper and then try the next, if the first doesn't make +-- progress. +-- So if it returns NS_Done, it means that both steppers are satisfied +composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev + -> NormaliseStepper ev +composeSteppers step1 step2 rec_nts tc tys + = case step1 rec_nts tc tys of + success@(NS_Step {}) -> success + NS_Done -> step2 rec_nts tc tys + NS_Abort -> NS_Abort + +-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into +-- a loop. If it would fall into a loop, it produces 'NS_Abort'. +unwrapNewTypeStepper :: NormaliseStepper Coercion +unwrapNewTypeStepper rec_nts tc tys + | Just (ty', co) <- instNewTyCon_maybe tc tys + = -- pprTrace "unNS" (ppr tc <+> ppr (getUnique tc) <+> ppr tys $$ ppr ty' $$ ppr rec_nts) $ + case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' ty' co + Nothing -> NS_Abort + + | otherwise + = NS_Done + +-- | A general function for normalising the top-level of a type. It continues +-- to use the provided 'NormaliseStepper' until that function fails, and then +-- this function returns. The roles of the coercions produced by the +-- 'NormaliseStepper' must all be the same, which is the role returned from +-- the call to 'topNormaliseTypeX'. +-- +-- Typically ev is Coercion. +-- +-- If topNormaliseTypeX step plus ty = Just (ev, ty') +-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty' +-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn +-- If it returns Nothing then no newtype unwrapping could happen +topNormaliseTypeX :: NormaliseStepper ev + -> (ev -> ev -> ev) + -> Type -> Maybe (ev, Type) +topNormaliseTypeX stepper plus ty + | Just (tc, tys) <- splitTyConApp_maybe ty + -- SPJ: The default threshold for initRecTc is 100 which is extremely dangerous + -- for certain type synonyms, we should think about reducing it (see #20990) + , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys + = go rec_nts ev ty' + | otherwise + = Nothing + where + go rec_nts ev ty + | Just (tc, tys) <- splitTyConApp_maybe ty + = case stepper rec_nts tc tys of + NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty' + NS_Done -> Just (ev, ty) + NS_Abort -> Nothing + + | otherwise + = Just (ev, ty) + +topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) +-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. +-- This function strips off @newtype@ layers enough to reveal something that isn't +-- a @newtype@. Specifically, here's the invariant: +-- +-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') +-- +-- then (a) @co : ty ~R ty'@. +-- (b) ty' is not a newtype. +-- +-- The function returns @Nothing@ for non-@newtypes@, +-- or unsaturated applications +-- +-- This function does *not* look through type families, because it has no access to +-- the type family environment. If you do have that at hand, consider to use +-- topNormaliseType_maybe, which should be a drop-in replacement for +-- topNormaliseNewType_maybe +-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty' +topNormaliseNewType_maybe ty + = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty + +{- +%************************************************************************ +%* * + Comparison of coercions +%* * +%************************************************************************ +-} + +-- | Syntactic equality of coercions +eqCoercion :: Coercion -> Coercion -> Bool +eqCoercion = eqType `on` coercionType + +-- | Compare two 'Coercion's, with respect to an RnEnv2 +eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool +eqCoercionX env = eqTypeX env `on` coercionType + +{- +%************************************************************************ +%* * + "Lifting" substitution + [(TyCoVar,Coercion)] -> Type -> Coercion +%* * +%************************************************************************ + +Note [Lifting coercions over types: liftCoSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The KPUSH rule deals with this situation + data T a = K (a -> Maybe a) + g :: T t1 ~ T t2 + x :: t1 -> Maybe t1 + + case (K @t1 x) |> g of + K (y:t2 -> Maybe t2) -> rhs + +We want to push the coercion inside the constructor application. +So we do this + + g' :: t1~t2 = SelCo (SelTyCon 0) g + + case K @t2 (x |> g' -> Maybe g') of + K (y:t2 -> Maybe t2) -> rhs + +The crucial operation is that we + * take the type of K's argument: a -> Maybe a + * and substitute g' for a +thus giving *coercion*. This is what liftCoSubst does. + +In the presence of kind coercions, this is a bit +of a hairy operation. So, we refer you to the paper introducing kind coercions, +available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf + +Note [extendLiftingContextEx] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider we have datatype + K :: /\k. /\a::k. P -> T k -- P be some type + g :: T k1 ~ T k2 + + case (K @k1 @t1 x) |> g of + K y -> rhs + +We want to push the coercion inside the constructor application. +We first get the coercion mapped by the universal type variable k: + lc = k |-> SelCo (SelTyCon 0) g :: k1~k2 + +Here, the important point is that the kind of a is coerced, and P might be +dependent on the existential type variable a. +Thus we first get the coercion of a's kind + g2 = liftCoSubst lc k :: k1 ~ k2 + +Then we store a new mapping into the lifting context + lc2 = a |-> (t1 ~ t1 |> g2), lc + +So later when we can correctly deal with the argument type P + liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)] + +This is exactly what extendLiftingContextEx does. +* For each (tyvar:k, ty) pair, we product the mapping + tyvar |-> (ty ~ ty |> (liftCoSubst lc k)) +* For each (covar:s1~s2, ty) pair, we produce the mapping + covar |-> (co ~ co') + co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2' + +This follows the lifting context extension definition in the +"FC with Explicit Kind Equality" paper. +-} + +-- ---------------------------------------------------- +-- See Note [Lifting coercions over types: liftCoSubst] +-- ---------------------------------------------------- + +data LiftingContext = LC Subst LiftCoEnv + -- in optCoercion, we need to lift when optimizing InstCo. + -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt + -- We thus propagate the substitution from GHC.Core.Coercion.Opt here. + +instance Outputable LiftingContext where + ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) + +type LiftCoEnv = VarEnv Coercion + -- Maps *type variables* to *coercions*. + -- That's the whole point of this function! + -- Also maps coercion variables to ProofIrrelCos. + +-- like liftCoSubstWith, but allows for existentially-bound types as well +liftCoSubstWithEx :: [TyVar] -- universally quantified tyvars + -> [Coercion] -- coercions to substitute for those + -> [TyCoVar] -- existentially quantified tycovars + -> [Type] -- types and coercions to be bound to ex vars + -> (Type -> CoercionR, [Type]) -- (lifting function, converted ex args) + -- Returned coercion has Representational role +liftCoSubstWithEx univs omegas exs rhos + = let theta = mkLiftingContext (zipEqual univs omegas) + psi = extendLiftingContextEx theta (zipEqual exs rhos) + in (ty_co_subst psi Representational, substTys (lcSubstRight psi) (mkTyCoVarTys exs)) + +liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion +liftCoSubstWith r tvs cos ty + = liftCoSubst r (mkLiftingContext $ zipEqual tvs cos) ty + +-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) +-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where +-- @lc_left@ is a substitution mapping type variables to the left-hand +-- types of the mapped coercions in @lc@, and similar for @lc_right@. +liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion +{-# INLINE liftCoSubst #-} +-- Inlining this function is worth 2% of allocation in T9872d, +liftCoSubst r lc@(LC subst env) ty + | isEmptyVarEnv env = mkReflCo r (substTy subst ty) + | otherwise = ty_co_subst lc r ty + +emptyLiftingContext :: InScopeSet -> LiftingContext +emptyLiftingContext in_scope = LC (mkEmptySubst in_scope) emptyVarEnv + +mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext +mkLiftingContext pairs + = LC (mkEmptySubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) + (mkVarEnv pairs) + +mkSubstLiftingContext :: Subst -> LiftingContext +mkSubstLiftingContext subst = LC subst emptyVarEnv + +liftingContextSubst :: LiftingContext -> Subst +liftingContextSubst (LC subst _) = subst + +-- | Extend a lifting context with a new mapping. +extendLiftingContext :: LiftingContext -- ^ original LC + -> TyCoVar -- ^ new variable to map... + -> Coercion -- ^ ...to this lifted version + -> LiftingContext + -- mappings to reflexive coercions are just substitutions +extendLiftingContext (LC subst env) tv arg + | Just (ty, _) <- isReflCo_maybe arg + = LC (extendTCvSubst subst tv ty) env + | otherwise + = LC subst (extendVarEnv env tv arg) + +-- | Extend the substitution component of a lifting context with +-- a new binding for a coercion variable. Used during coercion optimisation. +extendLiftingContextCvSubst :: LiftingContext + -> CoVar + -> Coercion + -> LiftingContext +extendLiftingContextCvSubst (LC subst env) cv co + = LC (extendCvSubst subst cv co) env + +-- | Extend a lifting context with a new mapping, and extend the in-scope set +extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC + -> TyCoVar -- ^ new variable to map... + -> Coercion -- ^ to this coercion + -> LiftingContext +extendLiftingContextAndInScope (LC subst env) tv co + = extendLiftingContext (LC (extendSubstInScopeSet subst (tyCoVarsOfCo co)) env) tv co + +-- | Extend a lifting context with existential-variable bindings. +-- See Note [extendLiftingContextEx] +extendLiftingContextEx :: LiftingContext -- ^ original lifting context + -> [(TyCoVar,Type)] -- ^ ex. var / value pairs + -> LiftingContext +-- Note that this is more involved than extendLiftingContext. That function +-- takes a coercion to extend with, so it's assumed that the caller has taken +-- into account any of the kind-changing stuff worried about here. +extendLiftingContextEx lc [] = lc +extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) +-- This function adds bindings for *Nominal* coercions. Why? Because it +-- works with existentially bound variables, which are considered to have +-- nominal roles. + | isTyVar v + = let lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfType ty) + (extendVarEnv env v $ + mkGReflRightCo Nominal + ty + (ty_co_subst lc Nominal (tyVarKind v))) + in extendLiftingContextEx lc' rest + | CoercionTy co <- ty + = -- co :: s1 ~r s2 + -- lift_s1 :: s1 ~r s1' + -- lift_s2 :: s2 ~r s2' + -- kco :: (s1 ~r s2) ~N (s1' ~r s2') + assert (isCoVar v) $ + let (s1, s2, r) = coVarTypesRole v + lift_s1 = ty_co_subst lc r s1 + lift_s2 = ty_co_subst lc r s2 + kco = mkTyConAppCo Nominal (equalityTyCon r) + [ mkKindCo lift_s1, mkKindCo lift_s2 + , lift_s1 , lift_s2 ] + lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfCo co) + (extendVarEnv env v + (mkProofIrrelCo Nominal kco co $ + (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) + in extendLiftingContextEx lc' rest + | otherwise + = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty) + + +-- | Erase the environments in a lifting context +zapLiftingContext :: LiftingContext -> LiftingContext +zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv + +updateLCSubst :: LiftingContext -> (Subst -> (Subst, a)) -> (LiftingContext, a) +-- Lift a Subst-update function over LiftingContext +updateLCSubst (LC subst lc_env) upd = (LC subst' lc_env, res) + where + (subst', res) = upd subst + +-- | The \"lifting\" operation which substitutes coercions for type +-- variables in a type to produce a coercion. +-- +-- For the inverse operation, see 'liftCoMatch' +ty_co_subst :: LiftingContext -> Role -> Type -> Coercion +ty_co_subst !lc role ty + -- !lc: making this function strict in lc allows callers to + -- pass its two components separately, rather than boxing them. + -- Unfortunately, Boxity Analysis concludes that we need lc boxed + -- because it's used that way in liftCoSubstTyVarBndrUsing. + = go role ty + where + go :: Role -> Type -> Coercion + go r ty | Just ty' <- coreView ty + = go r ty' + go Phantom ty = lift_phantom ty + go r (TyVarTy tv) = expectJust $ + liftCoSubstTyVar lc r tv + go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) + go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys) + go r (FunTy af w t1 t2) = mkFunCo r af (go Nominal w) (go r t1) (go r t2) + go r t@(ForAllTy (Bndr v vis) ty) + = let (lc', v', h) = liftCoSubstVarBndr lc v + body_co = ty_co_subst lc' r ty in + if isTyVar v' || almostDevoidCoVarOfCo v' body_co + -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo + -- imposes an extra restriction on where a covar can appear. See + -- (FC6) of Note [ForAllCo] in GHC.Tc.TyCo.Rep + -- We specifically check for this and panic because we know that + -- there's a hole in the type system here (see (FC6), and we'd rather + -- panic than fall into it. + then mkForAllCo v' vis vis h body_co + else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t) + go r ty@(LitTy {}) = assert (r == Nominal) $ + mkNomReflCo ty + go r (CastTy ty co) = castCoercionKind (go r ty) (substLeftCo lc co) + (substRightCo lc co) + go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) + (substRightCo lc co) + where kco = go Nominal (coercionType co) + + lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) + (substTy (lcSubstLeft lc) ty) + (substTy (lcSubstRight lc) ty) + +{- +Note [liftCoSubstTyVar] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This function can fail if a coercion in the environment is of too low a role. + +liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and +also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting +lemma guarantees that the roles work out. If we fail in this +case, we really should panic -- something is deeply wrong. But, in matchAxiom, +failing is fine. matchAxiom is trying to find a set of coercions +that match, but it may fail, and this is healthy behavior. +-} + +-- See Note [liftCoSubstTyVar] +liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion +liftCoSubstTyVar (LC subst env) r v + | Just co_arg <- lookupVarEnv env v + = downgradeRole_maybe r (coercionRole co_arg) co_arg + + | otherwise + = Just $ mkReflCo r (substTyVar subst v) + +{- Note [liftCoSubstVarBndr] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +callback: + 'liftCoSubstVarBndrUsing' needs to be general enough to work in two + situations: + + - in this module, which manipulates 'Coercion's, and + - in GHC.Core.FamInstEnv, where we work with 'Reduction's, which contain + a coercion as well as a type. + + To achieve this, we require that the return type of the 'callback' function + contain a coercion within it. This is witnessed by the first argument + to 'liftCoSubstVarBndrUsing': a getter, which allows us to retrieve + the coercion inside the return type. Thus: + + - in this module, we simply pass 'id' as the getter, + - in GHC.Core.FamInstEnv, we pass 'reductionCoercion' as the getter. + +liftCoSubstTyVarBndrUsing: + Given + forall tv:k. t + We want to get + forall (tv:k1) (kind_co :: k1 ~ k2) body_co + + We lift the kind k to get the kind_co + kind_co = ty_co_subst k :: k1 ~ k2 + + Now in the LiftingContext, we add the new mapping + tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2) + +liftCoSubstCoVarBndrUsing: + Given + forall cv:(s1 ~ s2). t + We want to get + forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co + + We lift s1 and s2 respectively to get + eta1 :: s1' ~ t1 + eta2 :: s2' ~ t2 + And + kind_co = TyConAppCo Nominal (~#) eta1 eta2 + + Now in the liftingContext, we add the new mapping + cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2) +-} + +-- See Note [liftCoSubstVarBndr] +liftCoSubstVarBndr :: LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, Coercion) +liftCoSubstVarBndr lc tv + = liftCoSubstVarBndrUsing id callback lc tv + where + callback lc' ty' = ty_co_subst lc' Nominal ty' + +-- the callback must produce a nominal coercion +liftCoSubstVarBndrUsing :: (r -> CoercionN) -- ^ coercion getter + -> (LiftingContext -> Type -> r) -- ^ callback + -> LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, r) +liftCoSubstVarBndrUsing view_co fun lc old_var + | isTyVar old_var + = liftCoSubstTyVarBndrUsing view_co fun lc old_var + | otherwise + = liftCoSubstCoVarBndrUsing view_co fun lc old_var + +-- Works for tyvar binder +liftCoSubstTyVarBndrUsing :: (r -> CoercionN) -- ^ coercion getter + -> (LiftingContext -> Type -> r) -- ^ callback + -> LiftingContext -> TyVar + -> (LiftingContext, TyVar, r) +liftCoSubstTyVarBndrUsing view_co fun lc@(LC subst cenv) old_var + = assert (isTyVar old_var) $ + ( LC (subst `extendSubstInScope` new_var) new_cenv + , new_var, stuff ) + where + old_kind = tyVarKind old_var + stuff = fun lc old_kind + eta = view_co stuff + k1 = coercionLKind eta + new_var = uniqAway (substInScopeSet subst) (setVarType old_var k1) + + lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta + -- :: new_var ~ new_var |> eta + new_cenv = extendVarEnv cenv old_var lifted + +-- Works for covar binder +liftCoSubstCoVarBndrUsing :: (r -> CoercionN) -- ^ coercion getter + -> (LiftingContext -> Type -> r) -- ^ callback + -> LiftingContext -> CoVar + -> (LiftingContext, CoVar, r) +liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var + = assert (isCoVar old_var) $ + ( LC (subst `extendSubstInScope` new_var) new_cenv + , new_var, stuff ) + where + old_kind = coVarKind old_var + stuff = fun lc old_kind + eta = view_co stuff + k1 = coercionLKind eta + new_var = uniqAway (substInScopeSet subst) (setVarType old_var k1) + + -- old_var :: s1 ~r s2 + -- eta :: (s1' ~r s2') ~N (t1 ~r t2) + -- eta1 :: s1' ~r t1 + -- eta2 :: s2' ~r t2 + -- co1 :: s1' ~r s2' + -- co2 :: t1 ~r t2 + -- lifted :: co1 ~N co2 + + role = coVarRole old_var + eta' = downgradeRole role Nominal eta + eta1 = mkSelCo (SelTyCon 2 role) eta' + eta2 = mkSelCo (SelTyCon 3 role) eta' + + co1 = mkCoVarCo new_var + co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 + lifted = mkProofIrrelCo Nominal eta co1 co2 + + new_cenv = extendVarEnv cenv old_var lifted + +-- | Is a var in the domain of a lifting context? +isMappedByLC :: TyCoVar -> LiftingContext -> Bool +isMappedByLC tv (LC _ env) = tv `elemVarEnv` env + +-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 +-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 +substLeftCo :: LiftingContext -> Coercion -> Coercion +substLeftCo lc co + = substCo (lcSubstLeft lc) co + +-- Ditto, but for t2 and g2 +substRightCo :: LiftingContext -> Coercion -> Coercion +substRightCo lc co + = substCo (lcSubstRight lc) co + +-- | Apply "sym" to all coercions in a 'LiftCoEnv' +swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv +swapLiftCoEnv = mapVarEnv mkSymCo + +lcSubstLeft :: LiftingContext -> Subst +lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env + +lcSubstRight :: LiftingContext -> Subst +lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env + +liftEnvSubstLeft :: Subst -> LiftCoEnv -> Subst +liftEnvSubstLeft = liftEnvSubst pFst + +liftEnvSubstRight :: Subst -> LiftCoEnv -> Subst +liftEnvSubstRight = liftEnvSubst pSnd + +liftEnvSubst :: (forall a. Pair a -> a) -> Subst -> LiftCoEnv -> Subst +liftEnvSubst selector subst lc_env + = composeTCvSubst (Subst in_scope emptyIdSubstEnv tenv cenv) subst + where + pairs = nonDetUFMToList lc_env + -- It's OK to use nonDetUFMToList here because we + -- immediately forget the ordering by creating + -- a VarEnv + (tpairs, cpairs) = partitionWith ty_or_co pairs + -- Make sure the in-scope set is wide enough to cover the range of the + -- substitution (#22235). + in_scope = mkInScopeSet $ + tyCoVarsOfTypes (map snd tpairs) `unionVarSet` + tyCoVarsOfCos (map snd cpairs) + tenv = mkVarEnv_Directly tpairs + cenv = mkVarEnv_Directly cpairs + + ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) + ty_or_co (u, co) + | Just equality_co <- isCoercionTy_maybe equality_ty + = Right (u, equality_co) + | otherwise + = Left (u, equality_ty) + where + equality_ty = selector (coercionKind co) + +-- | Lookup a 'CoVar' in the substitution in a 'LiftingContext' +lcLookupCoVar :: LiftingContext -> CoVar -> Maybe Coercion +lcLookupCoVar (LC subst _) cv = lookupCoVar subst cv + +-- | Get the 'InScopeSet' from a 'LiftingContext' +lcInScopeSet :: LiftingContext -> InScopeSet +lcInScopeSet (LC subst _) = substInScopeSet subst + +{- +%************************************************************************ +%* * + Sequencing on coercions +%* * +%************************************************************************ +-} + +seqMCo :: MCoercion -> () +seqMCo MRefl = () +seqMCo (MCo co) = seqCo co + +seqCo :: Coercion -> () +seqCo (Refl ty) = seqType ty +seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco +seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos +seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (CoVarCo cv) = cv `seq` () +seqCo (HoleCo h) = coHoleCoVar h `seq` () +seqCo (SymCo co) = seqCo co +seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (SelCo n co) = n `seq` seqCo co +seqCo (LRCo lr co) = lr `seq` seqCo co +seqCo (InstCo co arg) = seqCo co `seq` seqCo arg +seqCo (KindCo co) = seqCo co +seqCo (SubCo co) = seqCo co +seqCo (AxiomCo _ cs) = seqCos cs +seqCo (ForAllCo tv visL visR k co) + = seqType (varType tv) `seq` rnf visL `seq` rnf visR `seq` + seqCo k `seq` seqCo co +seqCo (FunCo r af1 af2 w co1 co2) + = r `seq` af1 `seq` af2 `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2 +seqCo (UnivCo { uco_prov = p, uco_role = r + , uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = p `seq` r `seq` seqType t1 `seq` seqType t2 `seq` seqCos deps + +seqCos :: [Coercion] -> () +seqCos [] = () +seqCos (co:cos) = seqCo co `seq` seqCos cos + +{- +%************************************************************************ +%* * + The kind of a type, and of a coercion +%* * +%************************************************************************ +-} + +{- Note [coercionKind performance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +coercionKind, coercionLKind, and coercionRKind are very "hot" functions; in some +coercion-heavy programs they can have a material effect on compile time/allocation. + +Hence +* Rather than making one function which returns a pair (lots of allocation and + de-allocation) we have two functions, coercionLKind and coercionRKind, which + return the left and right kind respectively. + +* Both are defined by a single worker function `coercion_lr_kind`, which takes a + flag of type `LeftOrRight`. This worker function is marked INLINE, and inlined + at its precisely-two call-sites in coercionLKind and coercionRKind. + +Take care when making changes here... it's easy to accidentally add allocation! +-} + +-- | Apply 'coercionKind' to multiple 'Coercion's +coercionKinds :: [Coercion] -> Pair [Type] +coercionKinds tys = sequenceA $ map coercionKind tys + +-- | Get a coercion's kind and role. +coercionKindRole :: Coercion -> (Pair Type, Role) +coercionKindRole co = (coercionKind co, coercionRole co) + +coercionType :: Coercion -> Type +coercionType co = case coercionKindRole co of + (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 + +------------------ +-- | If it is the case that +-- +-- > c :: (t1 ~ t2) +-- +-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. + +coercionKind :: HasDebugCallStack => Coercion -> Pair Type +-- See Note [coercionKind performance] +coercionKind co = Pair (coercionLKind co) (coercionRKind co) + +coercionLKind, coercionRKind :: HasDebugCallStack => Coercion -> Type +-- See Note [coercionKind performance] +coercionLKind co = coercion_lr_kind CLeft co +coercionRKind co = coercion_lr_kind CRight co + +coercion_lr_kind :: HasDebugCallStack => LeftOrRight -> Coercion -> Type +{-# INLINE coercion_lr_kind #-} +-- See Note [coercionKind performance] +coercion_lr_kind which orig_co + = go orig_co + where + go (Refl ty) = ty + go (GRefl _ ty MRefl) = ty + go (GRefl _ ty (MCo co1)) = pickLR which (ty, mkCastTy ty co1) + go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) + go (AppCo co1 co2) = mkAppTy (go co1) (go co2) + go (CoVarCo cv) = go_covar cv + go (HoleCo h) = go_covar (coHoleCoVar h) + go (SymCo co) = pickLR which (coercionRKind co, coercionLKind co) + go (TransCo co1 co2) = pickLR which (go co1, go co2) + go (LRCo lr co) = pickLR lr (splitAppTy (go co)) + go (InstCo aco arg) = go_app aco [go arg] + go (KindCo co) = typeKind (go co) + go (SubCo co) = go co + go (SelCo d co) = selectFromType d (go co) + go (AxiomCo ax cos) = go_ax ax cos + + go (UnivCo { uco_lty = lty, uco_rty = rty}) + = pickLR which (lty, rty) + go (FunCo { fco_afl = afl, fco_afr = afr, fco_mult = mult + , fco_arg = arg, fco_res = res}) + = -- See Note [FunCo] + FunTy { ft_af = pickLR which (afl, afr), ft_mult = go mult + , ft_arg = go arg, ft_res = go res } + + go co@(ForAllCo { fco_tcv = tv1, fco_visL = visL, fco_visR = visR + , fco_kind = k_co, fco_body = co1 }) + = case which of + CLeft -> mkTyCoForAllTy tv1 visL (go co1) + CRight | isGReflCo k_co -- kind_co always has kind `Type`, thus `isGReflCo` + -> mkTyCoForAllTy tv1 visR (go co1) + | otherwise + -> go_forall_right empty_subst co + where + empty_subst = mkEmptySubst (mkInScopeSet $ tyCoVarsOfCo co) + + ------------- + go_covar cv = pickLR which (coVarLType cv, coVarRType cv) + + ------------- + go_app :: Coercion -> [Type] -> Type + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co arg) args = go_app co (go arg:args) + go_app co args = piResultTys (go co) args + + ------------- + go_ax axr@(BuiltInFamRew bif) cos = check_bif_res axr (bifrw_proves bif (map coercionKind cos)) + go_ax axr@(BuiltInFamInj bif) [co] = check_bif_res axr (bifinj_proves bif (coercionKind co)) + go_ax axr@(BuiltInFamInj {}) _ = crash axr + go_ax (UnbranchedAxiom ax) cos = go_branch ax (coAxiomSingleBranch ax) cos + go_ax (BranchedAxiom ax i) cos = go_branch ax (coAxiomNthBranch ax i) cos + + ------------- + check_bif_res _ (Just (Pair lhs rhs)) = pickLR which (lhs,rhs) + check_bif_res axr Nothing = crash axr + + crash :: CoAxiomRule -> Type + crash axr = pprPanic "coercionKind" (ppr axr) + + ------------- + go_branch :: CoAxiom br -> CoAxBranch -> [Coercion] -> Type + go_branch ax (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs_tys, cab_rhs = rhs_ty }) cos + = assert (cos `equalLength` tcvs) $ + -- Invariant of AxiomRuleCo: cos should + -- exactly saturate the axiom branch + let (tys1, cotys1) = splitAtList tvs tys + cos1 = map stripCoercionTy cotys1 + in + -- You might think to use + -- substTy (zipTCvSubst tcvs ltys) (pickLR ...) + -- but #25066 makes it much less efficient than the silly calls below + substTyWith tvs tys1 $ + substTyWithCoVars cvs cos1 $ + pickLR which (mkTyConApp tc lhs_tys, rhs_ty) + where + tc = coAxiomTyCon ax + tcvs | null cvs = tvs -- Very common case (currently always!) + | otherwise = tvs ++ cvs + tys = map go cos + + ------------- + go_forall_right subst (ForAllCo { fco_tcv = tv1, fco_visR = visR + , fco_kind = k_co, fco_body = co }) + -- See Note [Nested ForAllCos] + | isTyVar tv1 + = mkForAllTy (Bndr tv2 visR) (go_forall_right subst' co) + where + k2 = coercionRKind k_co + tv2 = setTyVarKind tv1 (substTy subst k2) + subst' | isGReflCo k_co = extendSubstInScope subst tv1 + -- kind_co always has kind @Type@, thus @isGReflCo@ + | otherwise = extendTvSubst (extendSubstInScope subst tv2) tv1 $ + TyVarTy tv2 `mkCastTy` mkSymCo k_co + + go_forall_right subst (ForAllCo { fco_tcv = cv1, fco_visR = visR + , fco_kind = k_co, fco_body = co }) + | isCoVar cv1 + = mkTyCoForAllTy cv2 visR (go_forall_right subst' co) + where + k2 = coercionRKind k_co + r = coVarRole cv1 + k_co' = downgradeRole r Nominal k_co + eta1 = mkSelCo (SelTyCon 2 r) k_co' + eta2 = mkSelCo (SelTyCon 3 r) k_co' + + -- k_co :: (t1 ~r t2) ~N (s1 ~r s2) + -- k1 = t1 ~r t2 + -- k2 = s1 ~r s2 + -- cv1 :: t1 ~r t2 + -- cv2 :: s1 ~r s2 + -- eta1 :: t1 ~r s1 + -- eta2 :: t2 ~r s2 + -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2 + + cv2 = setVarType cv1 (substTy subst k2) + n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) + subst' | isReflCo k_co = extendSubstInScope subst cv1 + | otherwise = extendCvSubst (extendSubstInScope subst cv2) + cv1 n_subst + + go_forall_right subst other_co + -- when other_co is not a ForAllCo + = substTy subst (go other_co) + +{- Note [Nested ForAllCos] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an co)...) )`. +We do not want to perform `n` single-type-variable substitutions over the kind +of `co`; rather we want to do one substitution which substitutes for all of +`a1`, `a2` ... simultaneously. If we do one at a time we get the performance +hole reported in #11735. + +Solution: gather up the type variables for nested `ForAllCos`, and +substitute for them all at once. Remarkably, for #11735 this single +change reduces /total/ compile time by a factor of more than ten. + +Note [Nested InstCos] +~~~~~~~~~~~~~~~~~~~~~ +In #5631 we found that 70% of the entire compilation time was +being spent in coercionKind! The reason was that we had + (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos +where + g :: forall a1 a2 .. a100. phi +If we deal with the InstCos one at a time, we'll do this: + 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' + 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst +But this is a *quadratic* algorithm, and the blew up #5631. +So it's very important to do the substitution simultaneously; +cf Type.piResultTys (which in fact we call here). +-} + +-- | Retrieve the role from a coercion. +coercionRole :: Coercion -> Role +coercionRole = go + where + go (Refl _) = Nominal + go (GRefl r _ _) = r + go (TyConAppCo r _ _) = r + go (AppCo co1 _) = go co1 + go (ForAllCo { fco_body = co }) = go co + go (FunCo { fco_role = r }) = r + go (CoVarCo cv) = coVarRole cv + go (HoleCo h) = coVarRole (coHoleCoVar h) + go (UnivCo { uco_role = r }) = r + go (SymCo co) = go co + go (TransCo co1 _co2) = go co1 + go (SelCo cs co) = mkSelCoResRole cs (coercionRole co) + go (LRCo {}) = Nominal + go (InstCo co _) = go co + go (KindCo {}) = Nominal + go (SubCo _) = Representational + go (AxiomCo ax _) = coAxiomRuleRole ax + +-- | Makes a coercion type from two types: the types whose equality +-- is proven by the relevant 'Coercion' +mkCoercionType :: Role -> Type -> Type -> Type +mkCoercionType Nominal = mkNomEqPred +mkCoercionType Representational = mkReprEqPred +mkCoercionType Phantom = \ty1 ty2 -> + let ki1 = typeKind ty1 + ki2 = typeKind ty2 + in + TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] + +-- | Assuming that two types are the same, ignoring coercions, find +-- a nominal coercion between the types. This is useful when optimizing +-- transitivity over coercion applications, where splitting two +-- AppCos might yield different kinds. See Note [EtaAppCo] in +-- "GHC.Core.Coercion.Opt". +buildCoercion :: HasDebugCallStack => Type -> Type -> CoercionN +buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 + where + go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 + | Just ty2' <- coreView ty2 = go ty1 ty2' + + go (CastTy ty1 co) ty2 + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceLeftCo r ty1 co co' + + go ty1 (CastTy ty2 co) + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceRightCo r ty2 co co' + + go ty1@(TyVarTy tv1) _tyvarty + = assert (case _tyvarty of + { TyVarTy tv2 -> tv1 == tv2 + ; _ -> False }) $ + mkNomReflCo ty1 + + go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 }) + (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 }) + = assert (af1 == af2) $ + mkFunCo Nominal af1 (go w1 w2) (go arg1 arg2) (go res1 res2) + + go (TyConApp tc1 args1) (TyConApp tc2 args2) + = assertPpr (tc1 == tc2) (vcat [ ppr tc1 <+> ppr tc2 + , text "orig_ty1:" <+> ppr orig_ty1 + , text "orig_ty2:" <+> ppr orig_ty2 + ]) $ + mkTyConAppCo Nominal tc1 (zipWith go args1 args2) + + go (AppTy ty1a ty1b) ty2 + | Just (ty2a, ty2b) <- splitAppTyNoView_maybe ty2 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go ty1 (AppTy ty2a ty2b) + | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go (ForAllTy (Bndr tv1 flag1) ty1) (ForAllTy (Bndr tv2 flag2) ty2) + | isTyVar tv1 + = assert (isTyVar tv2) $ + mkForAllCo tv1 flag1 flag2 kind_co (go ty1 ty2') + where kind_co = go (tyVarKind tv1) (tyVarKind tv2) + in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTyWithInScope in_scope [tv2] + [mkTyVarTy tv1 `mkCastTy` kind_co] + ty2 + + go (ForAllTy (Bndr cv1 flag1) ty1) (ForAllTy (Bndr cv2 flag2) ty2) + = assert (isCoVar cv1 && isCoVar cv2) $ + mkForAllCo cv1 flag1 flag2 kind_co (go ty1 ty2') + where s1 = varType cv1 + s2 = varType cv2 + kind_co = go s1 s2 + + -- s1 = t1 ~r t2 + -- s2 = t3 ~r t4 + -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4) + -- eta1 :: t1 ~r t3 + -- eta2 :: t2 ~r t4 + + r = coVarRole cv1 + kind_co' = downgradeRole r Nominal kind_co + eta1 = mkSelCo (SelTyCon 2 r) kind_co' + eta2 = mkSelCo (SelTyCon 3 r) kind_co' + + subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` + mkCoVarCo cv1 `mkTransCo` + eta2) + ty2 + + go ty1@(LitTy lit1) _lit2 + = assert (case _lit2 of + { LitTy lit2 -> lit1 == lit2 + ; _ -> False }) $ + mkNomReflCo ty1 + + go (CoercionTy co1) (CoercionTy co2) + = mkProofIrrelCo Nominal kind_co co1 co2 + where + kind_co = go (coercionType co1) (coercionType co2) + + go ty1 ty2 + = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2 + , ppr ty1, ppr ty2 ]) + + +{- +%************************************************************************ +%* * + Coercion holes +%* * +%************************************************************************ +-} + +has_co_hole_ty :: Type -> Monoid.Any +(has_co_hole_ty, _, _, _) + = foldTyCo folder () + where + folder = TyCoFolder { tcf_view = noView + , tcf_tyvar = const2 (Monoid.Any False) + , tcf_covar = const2 (Monoid.Any False) + , tcf_hole = \_ _ -> Monoid.Any True + , tcf_tycobinder = const2 + } + +-- | Is there a coercion hole in this type? +-- See wrinkle (DE6) of Note [Defaulting equalities] in GHC.Tc.Solver.Default +hasCoercionHole :: Type -> Bool +hasCoercionHole = Monoid.getAny . has_co_hole_ty + +-- | Set the type of a 'CoercionHole' +setCoHoleType :: CoercionHole -> Type -> CoercionHole +setCoHoleType h t = setCoHoleCoVar h (setVarType (coHoleCoVar h) t) + diff --git a/GHC/Core/Coercion.hs-boot b/GHC/Core/Coercion.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/Coercion.hs-boot @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Core.Coercion where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep +import {-# SOURCE #-} GHC.Core.TyCon + +import GHC.Types.Basic ( LeftOrRight ) +import GHC.Core.Coercion.Axiom +import GHC.Types.Var +import GHC.Data.Pair +import GHC.Utils.Misc + +mkReflCo :: Role -> Type -> Coercion +mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion +mkAppCo :: Coercion -> Coercion -> Coercion +mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion +mkFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion +mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion +mkFunCo2 :: Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion +mkCoVarCo :: CoVar -> Coercion +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkUnivCo :: UnivCoProvenance -> [Coercion] -> Role -> Type -> Type -> Coercion +mkSymCo :: Coercion -> Coercion +mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion +mkSelCo :: HasDebugCallStack => CoSel -> Coercion -> Coercion +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkInstCo :: Coercion -> Coercion -> Coercion +mkGReflCo :: Role -> Type -> MCoercionN -> Coercion +mkNomReflCo :: Type -> Coercion +mkKindCo :: Coercion -> Coercion +mkSubCo :: HasDebugCallStack => Coercion -> Coercion +mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion +mkAxiomCo :: CoAxiomRule -> [Coercion] -> Coercion + +funRole :: Role -> FunSel -> Role + +isGReflCo :: Coercion -> Bool +isReflCo :: Coercion -> Bool +isReflexiveCo :: Coercion -> Bool +decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion) +coVarTypesRole :: HasDebugCallStack => CoVar -> (Type, Type, Role) +coVarRole :: CoVar -> Role + +mkCoercionType :: Role -> Type -> Type -> Type + +seqCo :: Coercion -> () + +coercionKind :: HasDebugCallStack => Coercion -> Pair Type +coercionLKind :: HasDebugCallStack => Coercion -> Type +coercionRKind :: HasDebugCallStack => Coercion -> Type +coercionType :: Coercion -> Type + +topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) + -- used to look through newtypes to the right of + -- function arrows, in 'GHC.Core.Type.getRuntimeArgTys' diff --git a/GHC/Core/Coercion/Axiom.hs b/GHC/Core/Coercion/Axiom.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Coercion/Axiom.hs @@ -0,0 +1,749 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- (c) The University of Glasgow 2012 + +-- | Module for coercion axioms, used to represent type family instances +-- and newtypes + +module GHC.Core.Coercion.Axiom ( + BranchFlag, Branched, Unbranched, BranchIndex, Branches(..), + manyBranches, unbranched, + fromBranches, numBranches, + mapAccumBranches, + + CoAxiom(..), CoAxBranch(..), + + toBranchedAxiom, toUnbranchedAxiom, + coAxiomName, coAxiomArity, coAxiomBranches, + coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, + coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, + coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars, + coAxBranchRoles, + coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, + placeHolderIncomps, + + Role(..), fsFromRole, + + CoAxiomRule(..), BuiltInFamRewrite(..), BuiltInFamInjectivity(..), TypeEqn, + coAxiomRuleArgRoles, coAxiomRuleRole, + coAxiomRuleBranch_maybe, isNewtypeAxiomRule_maybe, + BuiltInSynFamily(..), trivialBuiltInFamily + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Basic (Role(..)) + +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprTyVar ) +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon, isNewTyCon ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Var +import GHC.Utils.Misc +import GHC.Utils.Binary +import GHC.Utils.Panic +import GHC.Data.Pair +import GHC.Types.Basic +import Data.Typeable ( Typeable ) +import GHC.Types.SrcLoc +import qualified Data.Data as Data +import Data.Array +import Data.List ( mapAccumL ) +import Control.DeepSeq + +{- +Note [Coercion axiom branches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to allow closed type families, an axiom needs to contain an +ordered list of alternatives, called branches. The kind of the coercion built +from an axiom is determined by which index is used when building the coercion +from the axiom. + +For example, consider the axiom derived from the following declaration: + +type family F a where + F [Int] = Bool + F [a] = Double + F (a b) = Char + +This will give rise to this axiom: + +axF :: { F [Int] ~ Bool + ; forall (a :: *). F [a] ~ Double + ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char + } + +The axiom is used with the AxiomCo constructor of Coercion. If we wish +to have a coercion showing that F (Maybe Int) ~ Char, it will look like + +axF[2] <*> :: F (Maybe Int) ~ Char +-- or, written using concrete-ish syntax -- +AxiomRuleCo axF 2 [Refl *, Refl Maybe, Refl Int] + +Note that the index is 0-based. + +For type-checking, it is also necessary to check that no previous pattern +can unify with the supplied arguments. After all, it is possible that some +of the type arguments are lambda-bound type variables whose instantiation may +cause an earlier match among the branches. We wish to prohibit this behavior, +so the type checker rules out the choice of a branch where a previous branch +can unify. See also [Apartness] in GHC.Core.FamInstEnv. + +For example, the following is malformed, where 'a' is a lambda-bound type +variable: + +axF[2] <*> :: F (a Bool) ~ Char + +Why? Because a might be instantiated with [], meaning that branch 1 should +apply, not branch 2. This is a vital consistency check; without it, we could +derive Int ~ Bool, and that is a Bad Thing. + +Note [Branched axioms] +~~~~~~~~~~~~~~~~~~~~~~ +Although a CoAxiom has the capacity to store many branches, in certain cases, +we want only one. These cases are in data/newtype family instances, newtype +coercions, and type family instances. +Furthermore, these unbranched axioms are used in a +variety of places throughout GHC, and it would difficult to generalize all of +that code to deal with branched axioms, especially when the code can be sure +of the fact that an axiom is indeed a singleton. At the same time, it seems +dangerous to assume singlehood in various places through GHC. + +The solution to this is to label a CoAxiom with a phantom type variable +declaring whether it is known to be a singleton or not. The branches +are stored using a special datatype, declared below, that ensures that the +type variable is accurate. + +************************************************************************ +* * + Branches +* * +************************************************************************ +-} + +{- Note [BranchIndex] +~~~~~~~~~~~~~~~~~~~~ +A CoAxiom has 1 or more branches. Each branch has contains a list +of the free type variables in that branch, the LHS type patterns, +and the RHS type for that branch. When we apply an axiom to a list +of coercions, we must choose which branch of the axiom we wish to +use, as the different branches may have different numbers of free +type variables. (The number of type patterns is always the same +among branches, but that doesn't quite concern us here.) +-} + + +type BranchIndex = Int -- Counting from zero + -- The index of the branch in the list of branches + -- See Note [BranchIndex] + +-- promoted data type +data BranchFlag = Branched | Unbranched +type Branched = 'Branched +type Unbranched = 'Unbranched +-- By using type synonyms for the promoted constructors, we avoid needing +-- DataKinds and the promotion quote in client modules. This also means that +-- we don't need to export the term-level constructors, which should never be used. + +newtype Branches (br :: BranchFlag) + = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch } +type role Branches nominal + +manyBranches :: [CoAxBranch] -> Branches Branched +manyBranches brs = assert (snd bnds >= fst bnds ) + MkBranches (listArray bnds brs) + where + bnds = (0, length brs - 1) + +unbranched :: CoAxBranch -> Branches Unbranched +unbranched br = MkBranches (listArray (0, 0) [br]) + +toBranched :: Branches br -> Branches Branched +toBranched = MkBranches . unMkBranches + +toUnbranched :: Branches br -> Branches Unbranched +toUnbranched (MkBranches arr) = assert (bounds arr == (0,0) ) + MkBranches arr + +fromBranches :: Branches br -> [CoAxBranch] +fromBranches = elems . unMkBranches + +branchesNth :: Branches br -> BranchIndex -> CoAxBranch +branchesNth (MkBranches arr) n = arr ! n + +numBranches :: Branches br -> Int +numBranches (MkBranches arr) = snd (bounds arr) + 1 + +-- | The @[CoAxBranch]@ passed into the mapping function is a list of +-- all previous branches, reversed +mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch) + -> Branches br -> Branches br +mapAccumBranches f (MkBranches arr) + = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr))) + where + go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) + go prev_branches cur_branch = ( cur_branch : prev_branches + , f prev_branches cur_branch ) + + +{- +************************************************************************ +* * + Coercion axioms +* * +************************************************************************ + +Note [Storing compatibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During axiom application, we need to be aware of which branches are compatible +with which others. The full explanation is in Note [Compatibility] in +GHc.Core.FamInstEnv. (The code is placed there to avoid a dependency from +GHC.Core.Coercion.Axiom on the unification algorithm.) Although we could +theoretically compute compatibility on the fly, this is silly, so we store it +in a CoAxiom. + +Specifically, each branch refers to all other branches with which it is +incompatible. This list might well be empty, and it will always be for the +first branch of any axiom. + +CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk +stored in cab_incomps. The incompatibilities are properly a property of the +axiom as a whole, and they are computed only when the final axiom is built. + +During serialization, the list is converted into a list of the indices +of the branches. + +Note [CoAxioms are homogeneous] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All axioms must be *homogeneous*, meaning that the kind of the LHS must +match the kind of the RHS. In practice, this means: + + Given a CoAxiom { co_ax_tc = ax_tc }, + for every branch CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }: + typeKind (mkTyConApp ax_tc lhs) `eqType` typeKind rhs + +This is checked in FamInstEnv.mkCoAxBranch. +-} + +-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data CoAxiom br + = CoAxiom -- Type equality axiom. + { co_ax_unique :: Unique -- Unique identifier + , co_ax_name :: Name -- Name for pretty-printing + , co_ax_role :: Role -- Role of the axiom's equality + , co_ax_tc :: TyCon -- The head of the LHS patterns + -- e.g. the newtype or family tycon + , co_ax_branches :: Branches br -- The branches that form this axiom + , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" + -- See Note [Implicit axioms] + -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. + } + +-- | A branch of a coercion axiom, which provides the evidence for +-- unwrapping a newtype or a type-family reduction step using a single equation. +data CoAxBranch + = CoAxBranch + { cab_loc :: SrcSpan + -- ^ Location of the defining equation + -- See Note [CoAxiom locations] + , cab_tvs :: [TyVar] + -- ^ Bound type variables; not necessarily fresh + -- See Note [CoAxBranch type variables] + , cab_eta_tvs :: [TyVar] + -- ^ Eta-reduced tyvars + -- cab_tvs and cab_lhs may be eta-reduced; see + -- Note [Eta reduction for data families] + , cab_cvs :: [CoVar] + -- ^ Bound coercion variables + -- Always empty, for now. + -- See Note [Constraints in patterns] + -- in GHC.Tc.TyCl + , cab_roles :: [Role] + -- ^ See Note [CoAxBranch roles] + , cab_lhs :: [Type] + -- ^ Type patterns to match against + , cab_rhs :: Type + -- ^ Right-hand side of the equality + -- See Note [CoAxioms are homogeneous] + , cab_incomps :: [CoAxBranch] + -- ^ The previous incompatible branches + -- See Note [Storing compatibility] + } + deriving Data.Data + +toBranchedAxiom :: CoAxiom br -> CoAxiom Branched +toBranchedAxiom ax@(CoAxiom { co_ax_branches = branches }) + = ax { co_ax_branches = toBranched branches } + +toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched +toUnbranchedAxiom ax@(CoAxiom { co_ax_branches = branches }) + = ax { co_ax_branches = toUnbranched branches } + +coAxiomNumPats :: CoAxiom br -> Int +coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) + +coAxiomArity :: CoAxiom br -> BranchIndex -> Arity +coAxiomArity ax index + = length tvs + length cvs + where + CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index +coAxiomName :: CoAxiom br -> Name +coAxiomName = co_ax_name + +coAxiomRole :: CoAxiom br -> Role +coAxiomRole = co_ax_role + +coAxiomBranches :: CoAxiom br -> Branches br +coAxiomBranches = co_ax_branches + +coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch +coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index + = branchesNth bs index + +coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch +coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr }) + = arr ! 0 + +coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch +coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr }) + | snd (bounds arr) == 0 + = Just $ arr ! 0 + | otherwise + = Nothing + +coAxiomTyCon :: CoAxiom br -> TyCon +coAxiomTyCon = co_ax_tc + +coAxBranchTyVars :: CoAxBranch -> [TyVar] +coAxBranchTyVars = cab_tvs + +coAxBranchCoVars :: CoAxBranch -> [CoVar] +coAxBranchCoVars = cab_cvs + +coAxBranchLHS :: CoAxBranch -> [Type] +coAxBranchLHS = cab_lhs + +coAxBranchRHS :: CoAxBranch -> Type +coAxBranchRHS = cab_rhs + +coAxBranchRoles :: CoAxBranch -> [Role] +coAxBranchRoles = cab_roles + +coAxBranchSpan :: CoAxBranch -> SrcSpan +coAxBranchSpan = cab_loc + +isImplicitCoAxiom :: CoAxiom br -> Bool +isImplicitCoAxiom = co_ax_implicit + +coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] +coAxBranchIncomps = cab_incomps + +-- See Note [Compatibility] in GHC.Core.FamInstEnv +placeHolderIncomps :: [CoAxBranch] +placeHolderIncomps = panic "placeHolderIncomps" + +{- +Note [CoAxBranch type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of a CoAxBranch of an associated type-family instance, +we use the *same* type variables in cab_tvs (where possible) as the +enclosing class or instance. Consider + + instance C Int [z] where + type F Int [z] = ... -- Second param must be [z] + +In the CoAxBranch in the instance decl (F Int [z]) we use the +same 'z', so that it's easy to check that that type is the same +as that in the instance header. + +However, I believe that the cab_tvs of any CoAxBranch are distinct +from the cab_tvs of other CoAxBranches in the same CoAxiom. This is +important when checking for compatiblity and apartness; e.g. see +GHC.Core.FamInstEnv.compatibleBranches. (The story seems a bit wobbly +here, but it seems to work.) + +Note [CoAxBranch roles] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + newtype Age = MkAge Int + newtype Wrap a = MkWrap a + + convert :: Wrap Age -> Int + convert (MkWrap (MkAge i)) = i + +We want this to compile to: + + NTCo:Wrap :: forall a. Wrap a ~R a + NTCo:Age :: Age ~R Int + convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0]) + +But, note that NTCo:Age is at role R. Thus, we need to be able to pass +coercions at role R into axioms. However, we don't *always* want to be able to +do this, as it would be disastrous with type families. The solution is to +annotate the arguments to the axiom with roles, much like we annotate tycon +tyvars. Where do these roles get set? Newtype axioms inherit their roles from +the newtype tycon; family axioms are all at role N. + +Note [CoAxiom locations] +~~~~~~~~~~~~~~~~~~~~~~~~ +The source location of a CoAxiom is stored in two places in the +datatype tree. + * The first is in the location info buried in the Name of the + CoAxiom. This span includes all of the branches of a branched + CoAxiom. + * The second is in the cab_loc fields of the CoAxBranches. + +In the case of a single branch, we can extract the source location of +the branch from the name of the CoAxiom. In other cases, we need an +explicit SrcSpan to correctly store the location of the equation +giving rise to the FamInstBranch. + +Note [Implicit axioms] +~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Implicit TyThings] in GHC.Types.TyThing +* A CoAxiom arising from data/type family instances is not "implicit". + That is, it has its own IfaceAxiom declaration in an interface file + +* The CoAxiom arising from a newtype declaration *is* "implicit". + That is, it does not have its own IfaceAxiom declaration in an + interface file; instead the CoAxiom is generated by type-checking + the newtype declaration + +Note [Eta reduction for data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family T a b :: * + newtype instance T Int a = MkT (IO a) deriving( Monad ) +We'd like this to work. + +From the 'newtype instance' you might think we'd get: + newtype TInt a = MkT (IO a) + axiom ax1 a :: T Int a ~ TInt a -- The newtype-instance part + axiom ax2 a :: TInt a ~ IO a -- The newtype part + +But now what can we do? We have this problem + Given: d :: Monad IO + Wanted: d' :: Monad (T Int) = d |> ???? +What coercion can we use for the ??? + +Solution: eta-reduce both axioms, thus: + axiom ax1 :: T Int ~ TInt + axiom ax2 :: TInt ~ IO +Now + d' = d |> Monad (sym (ax2 ; ax1)) + +----- Bottom line ------ + +For a CoAxBranch for a data family instance with representation +TyCon rep_tc: + + - cab_tvs (of its CoAxiom) may be shorter + than tyConTyVars of rep_tc. + + - cab_lhs may be shorter than tyConArity of the family tycon + i.e. LHS is unsaturated + + - cab_rhs will be (rep_tc cab_tvs) + i.e. RHS is un-saturated + + - This eta reduction happens for data instances as well + as newtype instances. Here we want to eta-reduce the data family axiom. + + - This eta-reduction is done in GHC.Tc.TyCl.Instance.tcDataFamInstDecl. + +But for a /type/ family + - cab_lhs has the exact arity of the family tycon + +There are certain situations (e.g., pretty-printing) where it is necessary to +deal with eta-expanded data family instances. For these situations, the +cab_eta_tvs field records the stuff that has been eta-reduced away. +So if we have + axiom forall a b. F [a->b] = D b a +and cab_eta_tvs is [p,q], then the original user-written definition +looked like + axiom forall a b p q. F [a->b] p q = D b a p q +(See #9692, #14179, and #15845 for examples of what can go wrong if +we don't eta-expand when showing things to the user.) + +See also: + +* Note [Newtype eta] in GHC.Core.TyCon. This is notionally separate + and deals with the axiom connecting a newtype with its representation + type; but it too is eta-reduced. +* Note [Implementing eta reduction for data families] in "GHC.Tc.TyCl.Instance". This + describes the implementation details of this eta reduction happen. +* Note [RoughMap and rm_empty] for how this complicates the RoughMap implementation slightly. +-} + +{- ********************************************************************* +* * + Instances, especially pretty-printing +* * +********************************************************************* -} + +instance Eq (CoAxiom br) where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable (CoAxiom br) where + getUnique = co_ax_unique + +instance NamedThing (CoAxiom br) where + getName = co_ax_name + +instance Typeable br => Data.Data (CoAxiom br) where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiom" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiom" + +instance Outputable (CoAxiom br) where + -- You may want GHC.Core.Coercion.pprCoAxiom instead + ppr = ppr . getName + +instance Outputable CoAxBranch where + -- This instance doesn't know the name of the type family + -- If possible, use GHC.Core.Coercion.pprCoAxBranch instead + ppr (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs_tys, cab_rhs = rhs, cab_incomps = incomps }) + = text "CoAxBranch" <+> braces payload + where + payload = hang (text "forall" <+> pprWithCommas pprTyVar (tvs ++ cvs) <> dot) + 2 (vcat [ text "" <+> sep (map pprType lhs_tys) + , nest 2 (text "=" <+> ppr rhs) + , ppUnless (null incomps) $ + text "incomps:" <+> vcat (map ppr incomps) ]) + +{- +************************************************************************ +* * + Roles +* * +************************************************************************ + +Roles are defined here to avoid circular dependencies. +-} + +-- These names are slurped into the parser code. Changing these strings +-- will change the **surface syntax** that GHC accepts! If you want to +-- change only the pretty-printing, do some replumbing. See +-- mkRoleAnnotDecl in GHC.Parser.PostProcess +fsFromRole :: Role -> FastString +fsFromRole Nominal = fsLit "nominal" +fsFromRole Representational = fsLit "representational" +fsFromRole Phantom = fsLit "phantom" + +instance Outputable Role where + ppr = ftext . fsFromRole + +instance Binary Role where + put_ bh Nominal = putByte bh 1 + put_ bh Representational = putByte bh 2 + put_ bh Phantom = putByte bh 3 + + get bh = do tag <- getByte bh + case tag of 1 -> return Nominal + 2 -> return Representational + 3 -> return Phantom + _ -> panic ("get Role " ++ show tag) + +instance NFData Role where + rnf Nominal = () + rnf Representational = () + rnf Phantom = () + +{- +************************************************************************ +* * + CoAxiomRule + Rules for building Evidence +* * +************************************************************************ + +Note [CoAxiomRule] +~~~~~~~~~~~~~~~~~~ +A CoAxiomRule is a built-in axiom, one that we assume to be true: +CoAxiomRules come in four flavours: + +* BuiltInFamRew: provides evidence for, say + (ax1) 3+4 ----> 7 + (ax2) s+0 ----> s + The evidence looks like + AxiomCo ax1 [3,4] :: 3+4 ~ 7 + AxiomCo ax2 [s] :: s+0 ~ s + The arguments in the AxiomCo are the /instantiating types/, or + more generally coercions (see Note [Coercion axioms applied to coercions] + in GHC.Core.TyCo.Rep). + +* BuiltInFamInj: provides evidence for the injectivity of type families + For example + (ax3) g1: a+b ~ 0 ---> a~0 + (ax4) g2: a+b ~ 0 ---> b~0 + (ax5) g3: a+b1 ~ a~b2 ---> b1~b2 + The argument to the AxiomCo is the full coercion (always just one). + So then: + AxiomCo ax3 [g1] :: a ~ 0 + AxiomCo ax4 [g2] :: b ~ 0 + AxiomCo ax5 [g3] :: b1 ~ b2 + +* BranchedAxiom: used for closed type families + type family F a where + F Int = Bool + F Bool = Char + F a = a -> Int + We get one (CoAxiom Branched) for the entire family; when used in an + AxiomCo we pair it with the BranchIndex to say which branch to pick. + +* UnbranchedAxiom: used for several purposes; + - Newtypes + - Data family instances + - Open type family instances + +Note [Avoiding allocating lots of CoAxiomRules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CoAxiomRule is a sum type of four alternatives, which is very nice. But +there is a danger of allocating lots of (BuiltInFamRew bif) objects, every +time we (say) need a type-family rewrite. + +To avoid this allocation, we cache the appropraite CoAxiomRule inside each + BuiltInFamRewrite, BuiltInFamInjectivity +making a little circular data structure. See the `bifrw_axr` field of +BuiltInFamRewrite, and similarly the others. + +It's simple to do this, and saves a percent or two of allocation in programs +that do a lot of type-family work. +-} + +-- | CoAxiomRule describes a built-in axiom, one that we assume to be true +-- See Note [CoAxiomRule] +data CoAxiomRule + = BuiltInFamRew BuiltInFamRewrite -- Built-in type-family rewrites + -- e.g. 3+5 ~ 7 + + | BuiltInFamInj BuiltInFamInjectivity -- Built-in type-family deductions + -- e.g. a+b~0 ==> a~0 + -- Always unary + + | BranchedAxiom (CoAxiom Branched) BranchIndex -- Closed type family + + | UnbranchedAxiom (CoAxiom Unbranched) -- Open type family instance, + -- data family instances + -- and newtypes + +instance Eq CoAxiomRule where + (BuiltInFamRew bif1) == (BuiltInFamRew bif2) = bifrw_name bif1 == bifrw_name bif2 + (BuiltInFamInj bif1) == (BuiltInFamInj bif2) = bifinj_name bif1 == bifinj_name bif2 + (UnbranchedAxiom ax1) == (UnbranchedAxiom ax2) = getUnique ax1 == getUnique ax2 + (BranchedAxiom ax1 i1) == (BranchedAxiom ax2 i2) = getUnique ax1 == getUnique ax2 && i1 == i2 + _ == _ = False + +coAxiomRuleRole :: CoAxiomRule -> Role +coAxiomRuleRole (BuiltInFamRew {}) = Nominal +coAxiomRuleRole (BuiltInFamInj {}) = Nominal +coAxiomRuleRole (UnbranchedAxiom ax) = coAxiomRole ax +coAxiomRuleRole (BranchedAxiom ax _) = coAxiomRole ax + +coAxiomRuleArgRoles :: CoAxiomRule -> [Role] +coAxiomRuleArgRoles (BuiltInFamRew bif) = replicate (bifrw_arity bif) Nominal +coAxiomRuleArgRoles (BuiltInFamInj {}) = [Nominal] +coAxiomRuleArgRoles (UnbranchedAxiom ax) = coAxBranchRoles (coAxiomSingleBranch ax) +coAxiomRuleArgRoles (BranchedAxiom ax i) = coAxBranchRoles (coAxiomNthBranch ax i) + +coAxiomRuleBranch_maybe :: CoAxiomRule -> Maybe (TyCon, Role, CoAxBranch) +coAxiomRuleBranch_maybe (UnbranchedAxiom ax) = Just (co_ax_tc ax, co_ax_role ax, coAxiomSingleBranch ax) +coAxiomRuleBranch_maybe (BranchedAxiom ax i) = Just (co_ax_tc ax, co_ax_role ax, coAxiomNthBranch ax i) +coAxiomRuleBranch_maybe _ = Nothing + +isNewtypeAxiomRule_maybe :: CoAxiomRule -> Maybe (TyCon, CoAxBranch) +isNewtypeAxiomRule_maybe (UnbranchedAxiom ax) + | let tc = coAxiomTyCon ax, isNewTyCon tc = Just (tc, coAxiomSingleBranch ax) +isNewtypeAxiomRule_maybe _ = Nothing + +instance Data.Data CoAxiomRule where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiomRule" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiomRule" + +instance Outputable CoAxiomRule where + ppr (BuiltInFamRew bif) = ppr (bifrw_name bif) + ppr (BuiltInFamInj bif) = ppr (bifinj_name bif) + ppr (UnbranchedAxiom ax) = ppr (coAxiomName ax) + ppr (BranchedAxiom ax i) = ppr (coAxiomName ax) <> brackets (int i) + +{- ********************************************************************* +* * + Built-in families +* * +********************************************************************* -} + + +-- | A more explicit representation for `t1 ~ t2`. +type TypeEqn = Pair Type + +-- Type checking of built-in families +data BuiltInSynFamily = BuiltInSynFamily + { sfMatchFam :: [BuiltInFamRewrite] + , sfInteract :: [BuiltInFamInjectivity] + -- If given these type arguments and RHS, returns the equalities that + -- are guaranteed to hold. That is, if + -- (ar, Pair s1 s2) is an element of (sfInteract tys ty) + -- then AxiomRule ar [co :: F tys ~ ty] :: s1~s2 + } + +data BuiltInFamInjectivity -- Argument and result role are always Nominal + = BIF_Interact + { bifinj_name :: FastString + , bifinj_axr :: CoAxiomRule -- Cached copy of (BuiltInFamINj this-bif) + -- See Note [Avoiding allocating lots of CoAxiomRules] + + , bifinj_proves :: TypeEqn -> Maybe TypeEqn + -- ^ Always unary: just one TypeEqn argument + -- Returns @Nothing@ when it doesn't like the supplied argument. + -- When this happens in a coercion that means that the coercion is + -- ill-formed, and Core Lint checks for that. + } + +data BuiltInFamRewrite -- Argument roles and result role are always Nominal + = BIF_Rewrite + { bifrw_name :: FastString + , bifrw_axr :: CoAxiomRule -- Cached copy of (BuiltInFamRew this-bif) + -- See Note [Avoiding allocating lots of CoAxiomRules] + + , bifrw_fam_tc :: TyCon -- Needed for tyConsOfType + + , bifrw_arity :: Arity -- Number of type arguments needed + -- to instantiate this axiom + + , bifrw_match :: [Type] -> Maybe ([Type], Type) + -- coaxrMatch: does this reduce on the given arguments? + -- If it does, returns (types to instantiate the rule at, rhs type) + -- That is: mkAxiomCo ax (zipWith mkReflCo coAxiomRuleArgRoles ts) + -- :: F tys ~N rhs, + + , bifrw_proves :: [TypeEqn] -> Maybe TypeEqn } + -- length(inst_tys) = bifrw_arity + + -- INVARIANT: bifrw_match and bifrw_proves are related as follows: + -- If Just (inst_tys, res_ty) = bifrw_match ax arg_tys + -- then * length arg_tys = tyConArity fam_tc + -- * length inst_tys = bifrw_arity + -- * bifrw_proves (map (return @Pair) inst_tys) = Just (return @Pair res_ty) + + +-- Provides default implementations that do nothing. +trivialBuiltInFamily :: BuiltInSynFamily +trivialBuiltInFamily = BuiltInSynFamily { sfMatchFam = [], sfInteract = [] } diff --git a/GHC/Core/Coercion/Opt.hs b/GHC/Core/Coercion/Opt.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Coercion/Opt.hs @@ -0,0 +1,1513 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} + +module GHC.Core.Coercion.Opt + ( optCoercion + , OptCoercionOpts (..) + ) +where + +import GHC.Prelude + +import GHC.Tc.Utils.TcType ( exactTyCoVarsOfType ) + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Compare( eqType, eqForAllVis ) +import GHC.Core.Coercion +import GHC.Core.Type as Type hiding( substTyVarBndr, substTy ) +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.Unify + +import GHC.Types.Basic( SwapFlag(..), flipSwap, isSwapped, pickSwap, notSwapped ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Data.Pair + +import GHC.Utils.Outputable +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc +import GHC.Utils.Panic + +import Control.Monad ( zipWithM ) + +{- +%************************************************************************ +%* * + Optimising coercions +%* * +%************************************************************************ + +This module does coercion optimisation. See the paper + + Evidence normalization in Systtem FV (RTA'13) + https://simon.peytonjones.org/evidence-normalization/ + +The paper is also in the GHC repo, in docs/opt-coercion. + +Note [Optimising coercion optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Looking up a coercion's role or kind is linear in the size of the +coercion. Thus, doing this repeatedly during the recursive descent +of coercion optimisation is disastrous. We must be careful to avoid +doing this if at all possible. + +Because it is generally easy to know a coercion's components' roles +from the role of the outer coercion, we pass down the known role of +the input in the algorithm below. We also keep functions opt_co2 +and opt_co3 separate from opt_co4, so that the former two do Phantom +checks that opt_co4 can avoid. This is a big win because Phantom coercions +rarely appear within non-phantom coercions -- only in some TyConAppCos +and some AxiomInstCos. We handle these cases specially by calling +opt_co2. + +Note [Optimising InstCo] +~~~~~~~~~~~~~~~~~~~~~~~~ +Optimising InstCo is pretty subtle: #15725, #25387. + +(1) tv is a type variable. We want to optimise + + InstCo (ForAllCo tv kco g) g2 --> S(g) + +where S is some substitution. Let's look at the typing rules. + + kco : k1 ~ k2 + tv:k1 |- g : t1 ~ t2 + ----------------------------- + ForAllCo tv kco g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym kco]) + + g1 : (all tv:k1.t1') ~ (all tv:k2.t2') + g2 : (s1:k1) ~ (s2:k2) + -------------------- + InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] + +Putting these two together + + kco : k1 ~ k2 + tv:k1 |- g : t1 ~ t2 + g2 : (s1:k1) ~ (s2:k2) + -------------------- + InstCo (ForAllCo tv kco g) g2 : t1[tv |-> s1] ~ t2[tv |-> s2 |> sym kco] + +We thus want S(g) to have kind + + S(g) :: (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym kco]) + +All we need do is to substitute the coercion tv_co for tv: + S = [tv :-> tv_co] +where + tv_co : s1 ~ (s2 |> sym kco) +This looks bizarre, because we're substituting a /type variable/ with a +/coercion/. However, this operation already exists: it's called *lifting*, and +defined in GHC.Core.Coercion. We just need to enhance the lifting operation to +be able to deal with an ambient substitution, which is why a LiftingContext +stores a TCvSubst. + +In general if + S = [tv :-> tv_co] + tv_co : r1 ~ r2 + g : t1 ~ t2 +then + S(g) : t1[tv :-> r1] ~ t2[tv :-> r2] + +The substitution S is embodied in the LiftingContext argument of `opt_co4`; +See Note [The LiftingContext in optCoercion] + +(2) cv is a coercion variable +Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise. + +h : (t1 ~r t2) ~N (t3 ~r t4) +cv : t1 ~r t2 |- g : t1' ~r2 t2' +n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3 +n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4 +------------------------------------------------ +ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2 + (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2]) + +g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2') +g2 : h1 ~N h2 +h1 : t1 ~r t2 +h2 : t3 ~r t4 +------------------------------------------------ +InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2] + +We thus want some coercion proving this: + + t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2] + +So we substitute the coercion variable c for the coercion +(h1 ~N (n1; h2; sym n2)) in g. + +Note [The LiftingContext in optCoercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To suppport Note [Optimising InstCo] the coercion optimiser carries a +GHC.Core.Coercion.LiftingContext, which comprises + * An ordinary Subst + * The `lc_env`: a mapping from /type variables/ to /coercions/ + +We don't actually have a separate function + liftCoSubstCo :: LiftingContext -> Coercion -> Coercion +The substitution of a type variable by a coercion is done by the calls to +`liftCoSubst` (on a type) in the Refl and GRefl cases of `opt_co4`. + +We use the following invariants: + (LC1) The coercions in the range of `lc_env` have already had all substitutions + applied; they are "OutCoercions". If you re-optimise these coercions, you + must zap the LiftingContext first. + + (LC2) However they have /not/ had the "ambient sym" (the second argument of + `opt_co4`) applied. The ambient sym applies to the entire coercion not + to the little bits being substituted. +-} + +-- | Coercion optimisation options +newtype OptCoercionOpts = OptCoercionOpts + { optCoercionEnabled :: Bool -- ^ Enable coercion optimisation (reduce its size) + } + +optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo +-- ^ optCoercion applies a substitution to a coercion, +-- *and* optimises it to reduce its size +optCoercion opts env co + | optCoercionEnabled opts + = optCoercion' env co + +{- + = pprTrace "optCoercion {" (text "Co:" <> ppr (coercionSize co)) $ + let result = optCoercion' env co in + pprTrace "optCoercion }" + (vcat [ text "Co:" <+> ppr (coercionSize co) + , text "Optco:" <+> ppWhen (isReflCo result) (text "(refl)") + <+> ppr (coercionSize result) ]) $ + result +-} + + | otherwise + = substCo env co + +optCoercion' :: Subst -> Coercion -> NormalCo +optCoercion' env co + | debugIsOn + = let out_co = opt_co1 lc NotSwapped co + (Pair in_ty1 in_ty2, in_role) = coercionKindRole co + (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co + + details = vcat [ text "in_co:" <+> ppr co + , text "in_ty1:" <+> ppr in_ty1 + , text "in_ty2:" <+> ppr in_ty2 + , text "out_co:" <+> ppr out_co + , text "out_ty1:" <+> ppr out_ty1 + , text "out_ty2:" <+> ppr out_ty2 + , text "in_role:" <+> ppr in_role + , text "out_role:" <+> ppr out_role + ] + in + warnPprTrace (not (isReflCo out_co) && isReflexiveCo out_co) + "optCoercion: reflexive but not refl" details $ + -- The coercion optimiser should usually optimise + -- co:ty~ty --> Refl ty + -- But given a silly `newtype N = MkN N`, the axiom has type (N ~ N), + -- and so that can trigger this warning (e.g. test str002). + -- Maybe we should optimise that coercion to (Refl N), but it + -- just doesn't seem worth the bother + out_co + + | otherwise + = opt_co1 lc NotSwapped co + where + lc = mkSubstLiftingContext env +-- ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv) + + +type NormalCo = Coercion + -- Invariants: + -- * The substitution has been fully applied + -- * For trans coercions (co1 `trans` co2) + -- co1 is not a trans, and neither co1 nor co2 is identity + +type NormalNonIdCo = NormalCo -- Extra invariant: not the identity + +-- | Do we force the result to be representational? +type ReprFlag = Bool + +-- | Optimize a coercion, making no assumptions. All coercions in +-- the lifting context are already optimized (and sym'd if nec'y) +opt_co1 :: LiftingContext + -> SwapFlag -- IsSwapped => apply Sym to the result + -> Coercion -> NormalCo +opt_co1 env sym co = opt_co2 env sym (coercionRole co) co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's role. No other assumptions. +opt_co2 :: LiftingContext + -> SwapFlag -- ^IsSwapped => apply Sym to the result + -> Role -- ^ The role of the input coercion + -> Coercion -> NormalCo +opt_co2 env sym Phantom co = opt_phantom env sym co +opt_co2 env sym r co = opt_co4 env sym False r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's non-Phantom role, +-- and with an optional downgrade +opt_co3 :: LiftingContext -> SwapFlag -> Maybe Role -> Role -> Coercion -> NormalCo +opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co +opt_co3 env sym (Just Representational) r co = opt_co4 env sym True r co + -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore +opt_co3 env sym _ r co = opt_co4 env sym False r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a non-phantom coercion. +opt_co4, opt_co4' :: LiftingContext -> SwapFlag -> ReprFlag + -> Role -> Coercion -> NormalCo +-- Precondition: In every call (opt_co4 lc sym rep role co) +-- we should have role = coercionRole co +-- Precondition: role is not Phantom +-- Postcondition: The resulting coercion is equivalant to +-- wrapsub (wrapsym (mksub co) +-- where wrapsym is SymCo if sym=True +-- wrapsub is SubCo if rep=True + +-- opt_co4 is there just to support tracing, when debugging +-- Usually it just goes straight to opt_co4' +opt_co4 = opt_co4' + +{- +opt_co4 env sym rep r co + = pprTrace "opt_co4 {" + ( vcat [ text "Sym:" <+> ppr sym + , text "Rep:" <+> ppr rep + , text "Role:" <+> ppr r + , text "Co:" <+> ppr co ]) $ + assert (r == coercionRole co ) $ + let result = opt_co4' env sym rep r co in + pprTrace "opt_co4 }" (ppr co $$ text "---" $$ ppr result) $ + assertPpr (res_role == coercionRole result) + (vcat [ text "Role:" <+> ppr r + , text "Result: " <+> ppr result + , text "Result type:" <+> ppr (coercionType result) ]) $ + result + + where + res_role | rep = Representational + | otherwise = r +-} + +opt_co4' env sym rep r (Refl ty) + = assertPpr (r == Nominal) + (text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr Nominal $$ + text "Type:" <+> ppr ty) $ + wrapSym sym $ liftCoSubst (chooseRole rep r) env ty + -- wrapSym: see (LC2) of Note [The LiftingContext in optCoercion] + +opt_co4' env sym rep r (GRefl _r ty MRefl) + = assertPpr (r == _r) + (text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr ty) $ + wrapSym sym $ liftCoSubst (chooseRole rep r) env ty + -- wrapSym: see (LC2) of Note [The LiftingContext in optCoercion] + +opt_co4' env sym rep r (GRefl _r ty (MCo kco)) + = assertPpr (r == _r) + (text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr ty) $ + if isGReflCo kco || isGReflCo kco' + then wrapSym sym ty_co + else wrapSym sym $ mk_coherence_right_co r' (coercionRKind ty_co) kco' ty_co + -- ty :: k1 + -- kco :: k1 ~ k2 + -- Desired result coercion: ty ~ ty |> co + where + r' = chooseRole rep r + ty_co = liftCoSubst r' env ty + kco' = opt_co4 env NotSwapped False Nominal kco + +opt_co4' env sym rep r (SymCo co) = opt_co4 env (flipSwap sym) rep r co + -- surprisingly, we don't have to do anything to the env here. This is + -- because any "lifting" substitutions in the env are tied to ForAllCos, + -- which treat their left and right sides differently. We don't want to + -- exchange them. + +opt_co4' env sym rep r g@(TyConAppCo _r tc cos) + = assert (r == _r) $ + case (rep, r) of + (True, Nominal) -> + mkTyConAppCo Representational tc + (zipWith3 (opt_co3 env sym) + (map Just (tyConRoleListRepresentational tc)) + (repeat Nominal) + cos) + (False, Nominal) -> + mkTyConAppCo Nominal tc (map (opt_co4 env sym False Nominal) cos) + (_, Representational) -> + -- must use opt_co2 here, because some roles may be P + -- See Note [Optimising coercion optimisation] + mkTyConAppCo r tc (zipWith (opt_co2 env sym) + (tyConRoleListRepresentational tc) -- the current roles + cos) + (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) + +opt_co4' env sym rep r (AppCo co1 co2) + = mkAppCo (opt_co4 env sym rep r co1) + (opt_co4 env sym False Nominal co2) + +opt_co4' env sym rep r (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR + , fco_kind = k_co, fco_body = co }) + = mkForAllCo tv' visL' visR' k_co' $ + opt_co4 env' sym rep r co + -- Use the "mk" functions to check for nested Refls + where + !(env', tv', k_co') = optForAllCoBndr env sym tv k_co + !(visL', visR') = swapSym sym (visL, visR) + +opt_co4' env sym rep r (FunCo _r afl afr cow co1 co2) + = assert (r == _r) $ + mkFunCo2 r' afl' afr' cow' co1' co2' + where + co1' = opt_co4 env sym rep r co1 + co2' = opt_co4 env sym rep r co2 + cow' = opt_co1 env sym cow + !r' | rep = Representational + | otherwise = r + !(afl', afr') = swapSym sym (afl, afr) + +opt_co4' env sym rep r (CoVarCo cv) + | Just co <- lcLookupCoVar env cv -- see Note [Forall over coercion] for why + -- this is the right thing here + = -- pprTrace "CoVarCo" (ppr cv $$ ppr co) $ + opt_co4 (zapLiftingContext env) sym rep r co + + | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] + = mkReflCo (chooseRole rep r) ty1 + + | otherwise + = assert (isCoVar cv1) $ + wrapRole rep r $ wrapSym sym $ + CoVarCo cv1 + + where + Pair ty1 ty2 = coVarTypes cv1 + + cv1 = case lookupInScope (lcInScopeSet env) cv of + Just cv1 -> cv1 + Nothing -> warnPprTrace True + "opt_co: not in scope" + (ppr cv $$ ppr env) + cv + -- cv1 might have a substituted kind! + +opt_co4' _ _ _ _ (HoleCo h) + = pprPanic "opt_univ fell into a hole" (ppr h) + +opt_co4' env sym rep r (AxiomCo con cos) + -- Do *not* push sym inside top-level axioms + -- e.g. if g is a top-level axiom + -- g a : f a ~ a + -- then (sym (g ty)) /= g (sym ty) !! + = assert (r == coAxiomRuleRole con ) + wrapRole rep (coAxiomRuleRole con) $ + wrapSym sym $ + -- some sub-cos might be P: use opt_co2 + -- See Note [Optimising coercion optimisation] + AxiomCo con (zipWith (opt_co2 env NotSwapped) + (coAxiomRuleArgRoles con) + cos) + -- Note that the_co does *not* have sym pushed into it + +opt_co4' env sym rep r (UnivCo { uco_prov = prov, uco_lty = t1 + , uco_rty = t2, uco_deps = deps }) + = opt_univ env sym prov deps (chooseRole rep r) t1 t2 + +opt_co4' env sym rep r (TransCo co1 co2) + -- sym (g `o` h) = sym h `o` sym g + | isSwapped sym = opt_trans in_scope co2' co1' + | otherwise = opt_trans in_scope co1' co2' + where + co1' = opt_co4 env sym rep r co1 + co2' = opt_co4 env sym rep r co2 + in_scope = lcInScopeSet env + +opt_co4' env sym rep r (SelCo cs co) + -- Historical note 1: we used to check `co` for Refl, TyConAppCo etc + -- before optimising `co`; but actually the SelCo will have been built + -- with mkSelCo, so these tests always fail. + + -- Historical note 2: if rep=True and r=Nominal, we used to recursively + -- call opt_co4 to re-optimse the result. But (a) that is inefficient + -- and (b) wrapRole uses mkSubCo which does much the same job + = wrapRole rep r $ mkSelCo cs $ opt_co1 env sym co + +opt_co4' env sym rep r (LRCo lr co) + | Just pr_co <- splitAppCo_maybe co + = assert (r == Nominal ) + opt_co4 env sym rep Nominal (pick_lr lr pr_co) + | Just pr_co <- splitAppCo_maybe co' + = assert (r == Nominal) $ + if rep + then opt_co4 (zapLiftingContext env) NotSwapped True Nominal (pick_lr lr pr_co) + else pick_lr lr pr_co + | otherwise + = wrapRole rep Nominal $ LRCo lr co' + where + co' = opt_co4 env sym False Nominal co + + pick_lr CLeft (l, _) = l + pick_lr CRight (_, r) = r + +{- +Note [Forall over coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example: + type (:~:) :: forall k. k -> k -> Type + Refl :: forall k (a :: k) (b :: k). forall (cv :: (~#) k k a b). (:~:) k a b + k1,k2,k3,k4 :: Type + eta :: (k1 ~# k2) ~# (k3 ~# k4) == ((~#) Type Type k1 k2) ~# ((~#) Type Type k3 k4) + co1_3 :: k1 ~# k3 + co2_4 :: k2 ~# k4 + nth 2 eta :: k1 ~# k3 + nth 3 eta :: k2 ~# k4 + co11_31 :: ~# (sym co1_3) + co22_24 :: ~# co2_4 + (forall (cv :: eta). Refl co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) :: + (forall (cv :: k1 ~# k2). Refl Type k1 k2 ( ;; cv ;; ) ~# + (forall (cv :: k3 ~# k4). Refl Type k3 k4 + (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4)) + co1_2 :: k1 ~# k2 + co3_4 :: k3 ~# k4 + co5 :: co1_2 ~# co3_4 + InstCo (forall (cv :: eta). Refl co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) co5 :: + (Refl Type k1 k2 ( ;; cv ;; ))[cv |-> co1_2] ~# + (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))[cv |-> co3_4] + == + (Refl Type k1 k2 ( ;; co1_2 ;; )) ~# + (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; co3_4 ;; sym (nth 3 eta) ;; co2_4)) + ==> + Refl co1_3 co2_4 (co11_31 ;; co1_2 ;; co22_24) +Conclusion: Because of the way this all works, we want to put in the *left-hand* +coercion in co5's type. (In the code, co5 is called `arg`.) +So we extend the environment binding cv to arg's left-hand type. +-} + +-- See Note [Optimising InstCo] +opt_co4' env sym rep r (InstCo fun_co arg_co) + -- forall over type... + | Just (tv, _visL, _visR, k_co, body_co) <- splitForAllCo_ty_maybe fun_co + -- tv :: k1 + -- k_co :: k1 ~ k2 + -- body_co :: t1 ~ t2 + -- arg_co :: (s1:k1) ~ (s2:k2) + , let arg_co' = opt_co4 env NotSwapped False Nominal arg_co + -- Do /not/ push Sym into the arg_co, hence sym=False + -- see (LC2) of Note [The LiftingContext in optCoercion] + k_co' = opt_co4 env NotSwapped False Nominal k_co + s2' = coercionRKind arg_co' + tv_co = mk_coherence_right_co Nominal s2' (mkSymCo k_co') arg_co' + -- mkSymCo kind_co :: k2 ~ k1 + -- tv_co :: (s1 :: k1) ~ (((s2 :: k2) |> (sym kind_co)) :: k1) + = opt_co4 (extendLiftingContext env tv tv_co) sym rep r body_co + + -- See Note [Forall over coercion] + | Just (cv, _visL, _visR, _kind_co, body_co) <- splitForAllCo_co_maybe fun_co + , CoercionTy h1 <- coercionLKind arg_co + , let h1' = opt_co4 env NotSwapped False Nominal h1 + = opt_co4 (extendLiftingContextCvSubst env cv h1') sym rep r body_co + + -- OK so those cases didn't work. See if it is a forall /after/ optimization + -- If so, do an inefficient one-variable substitution, then re-optimize + + -- forall over type... + | Just (tv', _visL, _visR, k_co', body_co') <- splitForAllCo_ty_maybe fun_co' + , let s2' = coercionRKind arg_co' + tv_co = mk_coherence_right_co Nominal s2' (mkSymCo k_co') arg_co' + env' = extendLiftingContext (zapLiftingContext env) tv' tv_co + = opt_co4 env' NotSwapped False r' body_co' + + -- See Note [Forall over coercion] + | Just (cv', _visL, _visR, _kind_co', body_co') <- splitForAllCo_co_maybe fun_co' + , CoercionTy h1' <- coercionLKind arg_co' + , let env' = extendLiftingContextCvSubst (zapLiftingContext env) cv' h1' + = opt_co4 env' NotSwapped False r' body_co' + + -- Those cases didn't work either, so rebuild the InstCo + -- Push Sym into /both/ function /and/ arg_coument + | otherwise = InstCo fun_co' arg_co' + + where + -- fun_co' arg_co' are both optimised, /and/ we have pushed `sym` into both + -- So no more sym'ing on th results of fun_co' arg_co' + fun_co' = opt_co4 env sym rep r fun_co + arg_co' = opt_co4 env sym False Nominal arg_co + r' = chooseRole rep r + +opt_co4' env sym _rep r (KindCo co) + = assert (r == Nominal) $ + let kco' = promoteCoercion co in + case kco' of + KindCo co' -> promoteCoercion (opt_co1 env sym co') + _ -> opt_co4 env sym False Nominal kco' + -- This might be able to be optimized more to do the promotion + -- and substitution/optimization at the same time + +opt_co4' env sym _ r (SubCo co) + = assert (r == Representational) $ + opt_co4 env sym True Nominal co + +{- Note [Optimise CoVarCo to Refl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have (c :: t~t) we can optimise it to Refl. That increases the +chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t) + +We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo] +in GHC.Core.Coercion. +-} + +------------- +-- | Optimize a phantom coercion. The input coercion may not necessarily +-- be a phantom, but the output sure will be. +opt_phantom :: LiftingContext -> SwapFlag -> Coercion -> NormalCo +opt_phantom env sym (UnivCo { uco_prov = prov, uco_lty = t1 + , uco_rty = t2, uco_deps = deps }) + = opt_univ env sym prov deps Phantom t1 t2 + +opt_phantom env sym co + = opt_univ env sym PhantomProv [mkKindCo co] Phantom ty1 ty2 + where + Pair ty1 ty2 = coercionKind co + +{- Note [Differing kinds] + ~~~~~~~~~~~~~~~~~~~~~~ +The two types may not have the same kind (although that would be very unusual). +But even if they have the same kind, and the same type constructor, the number +of arguments in a `CoTyConApp` can differ. Consider + + Any :: forall k. k + + Any @Type Int :: Type + Any @(Type->Type) Maybe Int :: Type + +Hence the need to compare argument lengths; see #13658 + +Note [opt_univ needs injectivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If opt_univ sees a coercion between `T a1 a2` and `T b1 b2` it will optimize it +by producing a TyConAppCo for T, and pushing the UnivCo into the arguments. But +this works only if T is injective. Otherwise we can have something like + + type family F x where + F Int = Int + F Bool = Int + +where `UnivCo :: F Int ~ F Bool` is reasonable (it is effectively just an +alternative representation for a couple of uses of AxiomInstCos) but we do not +want to produce `F (UnivCo :: Int ~ Bool)` where the inner coercion is clearly +inconsistent. Hence the opt_univ case for TyConApps checks isInjectiveTyCon. +See #19509. + + -} + +opt_univ :: LiftingContext -> SwapFlag -> UnivCoProvenance + -> [Coercion] + -> Role -> Type -> Type -> Coercion +opt_univ env sym prov deps role ty1 ty2 + = let ty1' = substTyUnchecked (lcSubstLeft env) ty1 + ty2' = substTyUnchecked (lcSubstRight env) ty2 + deps' = map (opt_co1 env sym) deps + (ty1'', ty2'') = swapSym sym (ty1', ty2') + in + mkUnivCo prov deps' role ty1'' ty2'' + +{- +opt_univ env PhantomProv cvs _r ty1 ty2 + = mkUnivCo PhantomProv cvs Phantom ty1' ty2' + where + ty1' = substTy (lcSubstLeft env) ty1 + ty2' = substTy (lcSubstRight env) ty2 + +opt_univ1 env prov cvs' role oty1 oty2 + | Just (tc1, tys1) <- splitTyConApp_maybe oty1 + , Just (tc2, tys2) <- splitTyConApp_maybe oty2 + , tc1 == tc2 + , isInjectiveTyCon tc1 role -- see Note [opt_univ needs injectivity] + , equalLength tys1 tys2 -- see Note [Differing kinds] + -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); + -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps + = let roles = tyConRoleListX role tc1 + arg_cos = zipWith3 (mkUnivCo prov cvs') roles tys1 tys2 + arg_cos' = zipWith (opt_co4 env False False) roles arg_cos + in + mkTyConAppCo role tc1 arg_cos' + + -- can't optimize the AppTy case because we can't build the kind coercions. + + | Just (Bndr tv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1 + , isTyVar tv1 + , Just (Bndr tv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2 + , isTyVar tv2 + -- NB: prov isn't interesting here either + = let k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + eta = mkUnivCo prov cvs' Nominal k1 k2 + -- eta gets opt'ed soon, but not yet. + ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 + + (env', tv1', eta') = optForAllCoBndr env False tv1 eta + in + mkForAllCo tv1' vis1 vis2 eta' (opt_univ1 env' prov cvs' role ty1 ty2') + + | Just (Bndr cv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1 + , isCoVar cv1 + , Just (Bndr cv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2 + , isCoVar cv2 + -- NB: prov isn't interesting here either + = let k1 = varType cv1 + k2 = varType cv2 + r' = coVarRole cv1 + eta = mkUnivCo prov cvs' Nominal k1 k2 + eta_d = downgradeRole r' Nominal eta + -- eta gets opt'ed soon, but not yet. + n_co = (mkSymCo $ mkSelCo (SelTyCon 2 r') eta_d) `mkTransCo` + (mkCoVarCo cv1) `mkTransCo` + (mkSelCo (SelTyCon 3 r') eta_d) + ty2' = substTyWithCoVars [cv2] [n_co] ty2 + + (env', cv1', eta') = optForAllCoBndr env False cv1 eta + in + mkForAllCo cv1' vis1 vis2 eta' (opt_univ1 env' prov cvs' role ty1 ty2') + + | otherwise + = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 + ty2 = substTyUnchecked (lcSubstRight env) oty2 + in + mkUnivCo prov cvs' role ty1 ty2 +-} + +------------- +opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList is = zipWithEqual (opt_trans is) + -- The input lists must have identical length. + +opt_trans :: HasDebugCallStack => InScopeSet -> NormalCo -> NormalCo -> NormalCo + +-- opt_trans just allows us to add some debug tracing +-- Usually it just goes to opt_trans' +opt_trans is co1 co2 + = -- (if coercionRKind co1 `eqType` coercionLKind co2 + -- then (\x -> x) else + -- pprTrace "opt_trans" (vcat [ text "co1" <+> ppr co1 + -- , text "co2" <+> ppr co2 + -- , text "co1 kind" <+> ppr (coercionKind co1) + -- , text "co2 kind" <+> ppr (coercionKind co2) + -- , callStackDoc ])) $ + opt_trans' is co1 co2 + +{- +opt_trans is co1 co2 + = assertPpr (r1==r2) (vcat [ ppr r1 <+> ppr co1, ppr r2 <+> ppr co2]) $ + assertPpr (rres == r1) (vcat [ ppr r1 <+> ppr co1, ppr r2 <+> ppr co2, text "res" <+> ppr rres <+> ppr res ]) $ + res + where + res = opt_trans' is co1 co2 + rres = coercionRole res + r1 = coercionRole co1 + r2 = coercionRole co1 +-} + +opt_trans' :: HasDebugCallStack => InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans' is co1 co2 + | isReflCo co1 = co2 + -- optimize when co1 is a Refl Co + | otherwise = opt_trans1 is co1 co2 + +opt_trans1 :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo +-- First arg is not the identity +opt_trans1 is co1 co2 + | isReflCo co2 = co1 + -- optimize when co2 is a Refl Co + | otherwise = opt_trans2 is co1 co2 + +opt_trans2 :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo +-- Neither arg is the identity +opt_trans2 is (TransCo co1a co1b) co2 + -- Don't know whether the sub-coercions are the identity + = opt_trans is co1a (opt_trans is co1b co2) + +opt_trans2 is co1 co2 + | Just co <- opt_trans_rule is co1 co2 + = co + +opt_trans2 is co1 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule is co1 co2a + = if isReflCo co1_2a + then co2b + else opt_trans1 is co1_2a co2b + +opt_trans2 _ co1 co2 + = mk_trans_co co1 co2 + + +------ +-- Optimize coercions with a top-level use of transitivity. +opt_trans_rule :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo + +opt_trans_rule _ in_co1 in_co2 + | assertPpr (coercionRKind in_co1 `eqType` coercionLKind in_co2) + (vcat [ text "in_co1" <+> ppr in_co1 + , text "in_co2" <+> ppr in_co2 + , text "in_co1 kind" <+> ppr (coercionKind in_co1) + , text "in_co2 kind" <+> ppr (coercionKind in_co2) + , callStackDoc ]) $ + False + = panic "opt_trans_rule" -- This entire equation is purely assertion checking + +opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _t2 (MCo co2)) + = assert (r1 == r2) $ + fireTransRule "GRefl" in_co1 in_co2 $ + mk_grefl_right_co r1 t1 (opt_trans is co1 co2) + +-- Push transitivity through matching destructors +opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2) + | d1 == d2 + , coercionRole co1 == coercionRole co2 + , co1 `compatible_co` co2 + = fireTransRule "PushNth" in_co1 in_co2 $ + mkSelCo d1 (opt_trans is co1 co2) + +opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) + | d1 == d2 + , co1 `compatible_co` co2 + = fireTransRule "PushLR" in_co1 in_co2 $ + mkLRCo d1 (opt_trans is co1 co2) + +-- Push transitivity inside instantiation +opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) + | ty1 `eqCoercion` ty2 + , co1 `compatible_co` co2 + = fireTransRule "TrPushInst" in_co1 in_co2 $ + mkInstCo (opt_trans is co1 co2) ty1 + +opt_trans_rule _ + in_co1@(UnivCo { uco_prov = p1, uco_role = r1, uco_lty = tyl1, uco_deps = deps1 }) + in_co2@(UnivCo { uco_prov = p2, uco_role = r2, uco_rty = tyr2, uco_deps = deps2 }) + | p1 == p2 -- If the provenances are different, opt'ing will be very confusing + = assert (r1 == r2) $ + fireTransRule "UnivCo" in_co1 in_co2 $ + mkUnivCo p1 (deps1 ++ deps2) r1 tyl1 tyr2 + +-- Push transitivity down through matching top-level constructors. +opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) + | tc1 == tc2 + = assert (r1 == r2) $ + fireTransRule "PushTyConApp" in_co1 in_co2 $ + mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) + +opt_trans_rule is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b) + in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b) + = assert (r1 == r2) $ -- Just like the TyConAppCo/TyConAppCo case + assert (afr1 == afl2) $ + fireTransRule "PushFun" in_co1 in_co2 $ + mkFunCo2 r1 afl1 afr2 (opt_trans is w1 w2) + (opt_trans is co1a co2a) + (opt_trans is co1b co2b) + +opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) + -- Must call opt_trans_rule_app; see Note [EtaAppCo] + = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b] + +-- Eta rules +opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 + | Just cos2 <- etaTyConAppCo_maybe tc co2 + = fireTransRule "EtaCompL" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) + | Just cos1 <- etaTyConAppCo_maybe tc co1 + = fireTransRule "EtaCompR" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1@(AppCo co1a co1b) co2 + | Just (co2a,co2b) <- etaAppCo_maybe co2 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +opt_trans_rule is co1 co2@(AppCo co2a co2b) + | Just (co1a,co1b) <- etaAppCo_maybe co1 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +-- Push transitivity inside forall +-- forall over types. +opt_trans_rule is co1 co2 + | Just (tv1, visL1, _visR1, eta1, r1) <- splitForAllCo_ty_maybe co1 + , Just (tv2, _visL2, visR2, eta2, r2) <- etaForAllCo_ty_maybe co2 + = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2 + + | Just (tv2, _visL2, visR2, eta2, r2) <- splitForAllCo_ty_maybe co2 + , Just (tv1, visL1, _visR1, eta1, r1) <- etaForAllCo_ty_maybe co1 + = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2 + + where + push_trans tv1 eta1 r1 tv2 eta2 r2 visL visR + -- Given: + -- co1 = /\ tv1 : eta1 . r1 + -- co2 = /\ tv2 : eta2 . r2 + -- Wanted: + -- /\tv1 : (eta1;eta2) . (r1; r2[tv2 |-> tv1 |> eta1]) + = fireTransRule "EtaAllTy_ty" co1 co2 $ + mkForAllCo tv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` tv1 + r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 + +-- Push transitivity inside forall +-- forall over coercions. +opt_trans_rule is co1 co2 + | Just (cv1, visL1, _visR1, eta1, r1) <- splitForAllCo_co_maybe co1 + , Just (cv2, _visL2, visR2, eta2, r2) <- etaForAllCo_co_maybe co2 + = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2 + + | Just (cv2, _visL2, visR2, eta2, r2) <- splitForAllCo_co_maybe co2 + , Just (cv1, visL1, _visR1, eta1, r1) <- etaForAllCo_co_maybe co1 + = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2 + + where + push_trans cv1 eta1 r1 cv2 eta2 r2 visL visR + -- Given: + -- co1 = /\ (cv1 : eta1) . r1 + -- co2 = /\ (cv2 : eta2) . r2 + -- Wanted: + -- n1 = nth 2 eta1 + -- n2 = nth 3 eta1 + -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2]) + = fireTransRule "EtaAllTy_co" co1 co2 $ + mkForAllCo cv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` cv1 + role = coVarRole cv1 + eta1' = downgradeRole role Nominal eta1 + n1 = mkSelCo (SelTyCon 2 role) eta1' + n2 = mkSelCo (SelTyCon 3 role) eta1' + r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mk_trans_co` + (mkCoVarCo cv1) `mk_trans_co` n2]) + r2 + +-- Push transitivity inside axioms +opt_trans_rule is co1 co2 + + -- TrPushAxSym/TrPushSymAx + -- Put this first! Otherwise (#23619) we get + -- newtype N a = MkN a + -- axN :: forall a. N a ~ a + -- Now consider (axN ty ; sym (axN ty)) + -- If we put TrPushSymAxR first, we'll get + -- (axN ty ; sym (axN ty)) :: N ty ~ N ty -- Obviously Refl + -- --> axN (sym (axN ty)) :: N ty ~ N ty -- Very stupid + | Just (sym1, axr1, cos1) <- isAxiomCo_maybe co1 + , Just (sym2, axr2, cos2) <- isAxiomCo_maybe co2 + , axr1 == axr2 + , sym1 == flipSwap sym2 + , Just (tc, role, branch) <- coAxiomRuleBranch_maybe axr1 + , let qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch + lhs = mkTyConApp tc (coAxBranchLHS branch) + rhs = coAxBranchRHS branch + pivot_tvs = exactTyCoVarsOfType (pickSwap sym2 lhs rhs) + , all (`elemVarSet` pivot_tvs) qtvs + = fireTransRule "TrPushAxSym" co1 co2 $ + if isSwapped sym2 + -- TrPushAxSym + then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs + -- TrPushSymAx + else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs + + -- See Note [Push transitivity inside axioms] and + -- Note [Push transitivity inside newtype axioms only] + -- TrPushSymAxR + | Just (sym, axr, cos1) <- isAxiomCo_maybe co1 + , isSwapped sym + , Just cos2 <- matchNewtypeBranch sym axr co2 + , let newAxInst = AxiomCo axr (opt_transList is (map mkSymCo cos2) cos1) + = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst + + -- TrPushAxR + | Just (sym, axr, cos1) <- isAxiomCo_maybe co1 + , notSwapped sym + , Just cos2 <- matchNewtypeBranch sym axr co2 + , let newAxInst = AxiomCo axr (opt_transList is cos1 cos2) + = fireTransRule "TrPushAxR" co1 co2 newAxInst + + -- TrPushSymAxL + | Just (sym, axr, cos2) <- isAxiomCo_maybe co2 + , isSwapped sym + , Just cos1 <- matchNewtypeBranch (flipSwap sym) axr co1 + , let newAxInst = AxiomCo axr (opt_transList is cos2 (map mkSymCo cos1)) + = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst + + -- TrPushAxL + | Just (sym, axr, cos2) <- isAxiomCo_maybe co2 + , notSwapped sym + , Just cos1 <- matchNewtypeBranch (flipSwap sym) axr co1 + , let newAxInst = AxiomCo axr (opt_transList is cos1 cos2) + = fireTransRule "TrPushAxL" co1 co2 newAxInst + + +opt_trans_rule _ co1 co2 -- Identity rule + | let ty1 = coercionLKind co1 + r = coercionRole co1 + ty2 = coercionRKind co2 + , ty1 `eqType` ty2 + = fireTransRule "RedTypeDirRefl" co1 co2 $ + mkReflCo r ty2 + +opt_trans_rule _ _ _ = Nothing + +-- See Note [EtaAppCo] +opt_trans_rule_app :: InScopeSet + -> Coercion -- original left-hand coercion (printing only) + -> Coercion -- original right-hand coercion (printing only) + -> Coercion -- left-hand coercion "function" + -> [Coercion] -- left-hand coercion "args" + -> Coercion -- right-hand coercion "function" + -> [Coercion] -- right-hand coercion "args" + -> Maybe Coercion +opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs + | AppCo co1aa co1ab <- co1a + , Just (co2aa, co2ab) <- etaAppCo_maybe co2a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | AppCo co2aa co2ab <- co2a + , Just (co1aa, co1ab) <- etaAppCo_maybe co1a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | otherwise + = assert (co1bs `equalLength` co2bs) $ + fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $ + let rt1a = coercionRKind co1a + + lt2a = coercionLKind co2a + rt2a = coercionRole co2a + + rt1bs = map coercionRKind co1bs + lt2bs = map coercionLKind co2bs + rt2bs = map coercionRole co2bs + + kcoa = mkKindCo $ buildCoercion lt2a rt1a + kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs + + co2a' = mkCoherenceLeftCo rt2a lt2a kcoa co2a + co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs + co2bs'' = zipWith mk_trans_co co2bs' co2bs + in + mkAppCos (opt_trans is co1a co2a') + (zipWith (opt_trans is) co1bs co2bs'') + +fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion +fireTransRule _rule _co1 _co2 res + = Just res + +{- +Note [Push transitivity inside axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +opt_trans_rule tries to push transitivity inside axioms to deal with cases like +the following: + + newtype N a = MkN a + + axN :: N a ~R# a + + covar :: a ~R# b + co1 = axN :: N a ~R# a + co2 = axN :: N b ~R# b + + co :: a ~R# b + co = sym co1 ; N covar ; co2 + +When we are optimising co, we want to notice that the two axiom instantiations +cancel out. This is implemented by rules such as TrPushSymAxR, which transforms + sym (axN ) ; N covar +into + sym (axN covar) +so that TrPushSymAx can subsequently transform + sym (axN covar) ; axN +into + covar +which is much more compact. In some perf test cases this kind of pattern can be +generated repeatedly during simplification, so it is very important we squash it +to stop coercions growing exponentially. For more details see the paper: + + Evidence normalisation in System FC + Dimitrios Vytiniotis and Simon Peyton Jones + RTA'13, 2013 + https://www.microsoft.com/en-us/research/publication/evidence-normalization-system-fc-2/ + + +Note [Push transitivity inside newtype axioms only] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The optimization described in Note [Push transitivity inside axioms] is possible +for both newtype and type family axioms. However, for type family axioms it is +relatively common to have transitive sequences of axioms instantiations, for +example: + + data Nat = Zero | Suc Nat + + type family Index (n :: Nat) (xs :: [Type]) :: Type where + Index Zero (x : xs) = x + Index (Suc n) (x : xs) = Index n xs + + axIndex :: { forall x::Type. forall xs::[Type]. Index Zero (x : xs) ~ x + ; forall n::Nat. forall x::Type. forall xs::[Type]. Index (Suc n) (x : xs) ~ Index n xs } + + co :: Index (Suc (Suc Zero)) [a, b, c] ~ c + co = axIndex[1] <[b, c]> + ; axIndex[1] <[c]> + ; axIndex[0] <[]> + +Not only are there no cancellation opportunities here, but calling matchAxiom +repeatedly down the transitive chain is very expensive. Hence we do not attempt +to push transitivity inside type family axioms. See #8095, !9210 and related tickets. + +This is implemented by opt_trans_rule checking that the axiom is for a newtype +constructor (i.e. not a type family). Adding these guards substantially +improved performance (reduced bytes allocated by more than 10%) for the tests +CoOpt_Singletons, LargeRecord, T12227, T12545, T13386, T15703, T5030, T8095. + +A side benefit is that we do not risk accidentally creating an ill-typed +coercion; see Note [Why call checkAxInstCo during optimisation]. + +There may exist programs that previously relied on pushing transitivity inside +type family axioms to avoid creating huge coercions, which will regress in +compile time performance as a result of this change. We do not currently know +of any examples, but if any come to light we may need to reconsider this +behaviour. + + +Note [Why call checkAxInstCo during optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: The following is no longer relevant, because we no longer push transitivity +into type family axioms (Note [Push transitivity inside newtype axioms only]). +It is retained for reference in case we change this behaviour in the future. + +It is possible that otherwise-good-looking optimisations meet with disaster +in the presence of axioms with multiple equations. Consider + +type family Equal (a :: *) (b :: *) :: Bool where + Equal a a = True + Equal a b = False +type family Id (a :: *) :: * where + Id a = a + +axEq :: { [a::*]. Equal a a ~ True + ; [a::*, b::*]. Equal a b ~ False } +axId :: [a::*]. Id a ~ a + +co1 = Equal (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ Equal Int Bool +co2 = axEq[1] + :: Equal Int Bool ~ False + +We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that +co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what +happens when we push the coercions inside? We get + +co3 = axEq[1] (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ False + +which is bogus! This is because the type system isn't smart enough to know +that (Id Int) and (Id Bool) are SurelyApart, as they're headed by type +families. At the time of writing, I (Richard Eisenberg) couldn't think of +a way of detecting this any more efficient than just building the optimised +coercion and checking. + +Note [EtaAppCo] +~~~~~~~~~~~~~~~ +Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd +like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that +the resultant coercions might not be well kinded. Here is an example (things +labeled with x don't matter in this example): + + k1 :: Type + k2 :: Type + + a :: k1 -> Type + b :: k1 + + h :: k1 ~ k2 + + co1a :: x1 ~ (a |> (h -> ) + co1b :: x2 ~ (b |> h) + + co2a :: a ~ x3 + co2b :: b ~ x4 + +First, convince yourself of the following: + + co1a co1b :: x1 x2 ~ (a |> (h -> )) (b |> h) + co2a co2b :: a b ~ x3 x4 + + (a |> (h -> )) (b |> h) `eqType` a b + +That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep, +where we ignore coercions in types as long as two types' kinds are the same. +In our case, we meet this last condition, because + + (a |> (h -> )) (b |> h) :: Type + and + a b :: Type + +So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the +suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the +kinds don't match up. + +The solution here is to twiddle the kinds in the output coercions. First, we +need to find coercions + + ak :: kind(a |> (h -> )) ~ kind(a) + bk :: kind(b |> h) ~ kind(b) + +This can be done with mkKindCo and buildCoercion. The latter assumes two +types are identical modulo casts and builds a coercion between them. + +Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the +output coercions. These are well-kinded. + +Also, note that all of this is done after accumulated any nested AppCo +parameters. This step is to avoid quadratic behavior in calling coercionKind. + +The problem described here was first found in dependent/should_compile/dynamic-paper. + +-} + +----------- +swapSym :: SwapFlag -> (a,a) -> (a,a) +swapSym IsSwapped (x,y) = (y,x) +swapSym NotSwapped (x,y) = (x,y) + +wrapSym :: SwapFlag -> Coercion -> Coercion +wrapSym IsSwapped co = mkSymCo co +wrapSym NotSwapped co = co + +-- | Conditionally set a role to be representational +wrapRole :: ReprFlag + -> Role -- ^ current role + -> Coercion -> Coercion +wrapRole False _ = id +wrapRole True current = downgradeRole Representational current + +-- | If we require a representational role, return that. Otherwise, +-- return the "default" role provided. +chooseRole :: ReprFlag + -> Role -- ^ "default" role + -> Role +chooseRole True _ = Representational +chooseRole _ r = r + +----------- +isAxiomCo_maybe :: Coercion -> Maybe (SwapFlag, CoAxiomRule, [Coercion]) +-- We don't expect to see nested SymCo; and that lets us write a simple, +-- non-recursive function. (If we see a nested SymCo we'll just fail, +-- which is ok.) +isAxiomCo_maybe (SymCo (AxiomCo ax cos)) = Just (IsSwapped, ax, cos) +isAxiomCo_maybe (AxiomCo ax cos) = Just (NotSwapped, ax, cos) +isAxiomCo_maybe _ = Nothing + +matchNewtypeBranch :: SwapFlag -- IsSwapped = match LHS, NotSwapped = match RHS + -> CoAxiomRule + -> Coercion -> Maybe [Coercion] +matchNewtypeBranch sym axr co + | Just (tc,branch) <- isNewtypeAxiomRule_maybe axr + , CoAxBranch { cab_tvs = qtvs + , cab_cvs = [] -- can't infer these, so fail if there are any + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs } <- branch + , Just subst <- liftCoMatch (mkVarSet qtvs) + (pickSwap sym rhs (mkTyConApp tc lhs)) + co + , all (`isMappedByLC` subst) qtvs + = zipWithM (liftCoSubstTyVar subst) roles qtvs + + | otherwise + = Nothing + +------------- +compatible_co :: Coercion -> Coercion -> Bool +-- Check whether (co1 . co2) will be well-kinded +compatible_co co1 co2 + = x1 `eqType` x2 + where + x1 = coercionRKind co1 + x2 = coercionLKind co2 + +------------- +{- +etaForAllCo +~~~~~~~~~~~~~~~~~ +(1) etaForAllCo_ty_maybe +Suppose we have + + g : all a1:k1.t1 ~ all a2:k2.t2 + +but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: + + g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g)) + +Call the kind coercion h1 and the body coercion h2. We can see that + + h2 : t1 ~ t2[a2 |-> (a1 |> h1)] + +According to the typing rule for ForAllCo, we get that + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1]) + +or + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) + +as desired. + +(2) etaForAllCo_co_maybe +Suppose we have + + g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2 + +Similarly, we do this + + g' = all c1:h1. h2 + : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)] + [c1 |-> eta1;c1;sym eta2] + +Here, + + h1 = mkSelCo Nominal 0 g :: (s1~s2)~(s3~s4) + eta1 = mkSelCo (SelTyCon 2 r) h1 :: (s1 ~ s3) + eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4) + h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) +-} +etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) +-- Try to make the coercion be of form (forall tv:kind_co. co) +etaForAllCo_ty_maybe co + | Just (tv, visL, visR, kind_co, r) <- splitForAllCo_ty_maybe co + = Just (tv, visL, visR, kind_co, r) + + | (Pair ty1 ty2, role) <- coercionKindRole co + , Just (Bndr tv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1 + , isTyVar tv1 + , Just (Bndr tv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2 + , isTyVar tv2 + -- can't eta-expand at nominal role unless visibilities match + , (role /= Nominal) || (vis1 `eqForAllVis` vis2) + , let kind_co = mkSelCo SelForAll co + = Just ( tv1, vis1, vis2, kind_co + , mkInstCo co (mk_grefl_right_co Nominal (TyVarTy tv1) kind_co)) + + | otherwise + = Nothing + +etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) +-- Try to make the coercion be of form (forall cv:kind_co. co) +etaForAllCo_co_maybe co + | Just (cv, visL, visR, kind_co, r) <- splitForAllCo_co_maybe co + = Just (cv, visL, visR, kind_co, r) + + | (Pair ty1 ty2, role) <- coercionKindRole co + , Just (Bndr cv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1 + , isCoVar cv1 + , Just (Bndr cv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2 + , isCoVar cv2 + -- can't eta-expand at nominal role unless visibilities match + , (role /= Nominal) + = let kind_co = mkSelCo SelForAll co + r = coVarRole cv1 + l_co = mkCoVarCo cv1 + kind_co' = downgradeRole r Nominal kind_co + r_co = mkSymCo (mkSelCo (SelTyCon 2 r) kind_co') + `mk_trans_co` l_co + `mk_trans_co` mkSelCo (SelTyCon 3 r) kind_co' + in Just ( cv1, vis1, vis2, kind_co + , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) + + | otherwise + = Nothing + +etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) +-- If possible, split a coercion +-- g :: t1a t1b ~ t2a t2b +-- into a pair of coercions (left g, right g) +etaAppCo_maybe co + | Just (co1,co2) <- splitAppCo_maybe co + = Just (co1,co2) + | (Pair ty1 ty2, Nominal) <- coercionKindRole co + , Just (_,t1) <- splitAppTy_maybe ty1 + , Just (_,t2) <- splitAppTy_maybe ty2 + , let isco1 = isCoercionTy t1 + , let isco2 = isCoercionTy t2 + , isco1 == isco2 + = Just (LRCo CLeft co, LRCo CRight co) + | otherwise + = Nothing + +etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] +-- If possible, split a coercion +-- g :: T s1 .. sn ~ T t1 .. tn +-- into [ SelCo (SelTyCon 0) g :: s1~t1 +-- , ... +-- , SelCo (SelTyCon (n-1)) g :: sn~tn ] +etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) + = assert (tc == tc2) $ Just cos2 + +etaTyConAppCo_maybe tc co + | not (tyConMustBeSaturated tc) + , (Pair ty1 ty2, r) <- coercionKindRole co + , Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + , isInjectiveTyCon tc r -- See Note [SelCo and newtypes] in GHC.Core.TyCo.Rep + , let n = length tys1 + , tys2 `lengthIs` n -- This can fail in an erroneous program + -- E.g. T a ~# T a b + -- #14607 + = assert (tc == tc1) $ + Just (decomposeCo n co (tyConRolesX r tc1)) + -- NB: n might be <> tyConArity tc + -- e.g. data family T a :: * -> * + -- g :: T a b ~ T c d + + | otherwise + = Nothing + +{- +Note [Eta for AppCo] +~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: s1 t1 ~ s2 t2 + +Then we can't necessarily make + left g :: s1 ~ s2 + right g :: t1 ~ t2 +because it's possible that + s1 :: * -> * t1 :: * + s2 :: (*->*) -> * t2 :: * -> * +and in that case (left g) does not have the same +kind on either side. + +It's enough to check that + kind t1 = kind t2 +because if g is well-kinded then + kind (s1 t2) = kind (s2 t2) +and these two imply + kind s1 = kind s2 + +-} + +{- Note [Optimising ForAllCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If sym=NotSwapped, optimising ForAllCo is relatively easy: + opt env (ForAllCo tcv kco bodyco) + = ForAllCo tcv' (opt env kco) (opt env' bodyco) + where + (env', tcv') = substBndr env tcv + +Just apply the substitution to the kind of the binder, deal with +shadowing etc, and recurse. Remember in (ForAllCo tcv kco bodyco) + varKind tcv = coercionLKind kco + +But if sym=Swapped, things are trickier. Here is an identity that helps: + Sym (ForAllCo (tv:k1) (kco:k1~k2) bodyco) + = ForAllCo (tv:k2) (Sym kco : k2~k1) + (Sym (bodyco[tv:->tv:k2 |> Sym kco])) + +* We re-type tv:k1 to become tv:k2. +* We push Sym into kco +* We push Sym into bodyco +* BUT we must /also/ remember to replace all occurrences of + of tv:k1 in bodyco by (tv:k2 |> Sym kco) + This mirrors what happens in the typing rule for ForAllCo + See Note [ForAllCo] in GHC.Core.TyCo.Rep + +-} +optForAllCoBndr :: LiftingContext -> SwapFlag + -> TyCoVar -> Coercion + -> (LiftingContext, TyCoVar, Coercion) +-- See Note [Optimising ForAllCo] +optForAllCoBndr env sym tcv kco + = (env', tcv', kco') + where + kco' = opt_co4 env sym False Nominal kco -- Push sym into kco + (env', tcv') = updateLCSubst env upd_subst + + upd_subst :: Subst -> (Subst, TyCoVar) + upd_subst subst + | isTyVar tcv = upd_subst_tv subst + | otherwise = upd_subst_cv subst + + upd_subst_tv subst + | notSwapped sym || isReflCo kco' = (subst1, tv1) + | otherwise = (subst2, tv2) + where + -- subst1,tv1: apply the substitution to the binder and its kind + -- NB: varKind tv = coercionLKind kco + (subst1, tv1) = substTyVarBndr subst tcv + -- In the Swapped case, we re-kind the type variable, AND + -- override the substitution for the original variable to the + -- re-kinded one, suitably casted + tv2 = tv1 `setTyVarKind` coercionLKind kco' + subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` kco')) + `extendSubstInScope` tv2 + + upd_subst_cv subst -- ToDo: probably not right yet + | notSwapped sym || isReflCo kco' = (subst1, cv1) + | otherwise = (subst2, cv2) + where + (subst1, cv1) = substCoVarBndr subst tcv + cv2 = cv1 `setTyVarKind` coercionLKind kco' + subst2 = subst1 `extendSubstInScope` cv2 + + +{- ********************************************************************** +%* * + Assertion-checking versions of functions in Coercion.hs +%* * +%********************************************************************* -} + +-- We can't check the assertions in the "main" functions of these +-- functions, because the assertions don't hold during zonking. +-- But they are fantastically helpful in finding bugs in the coercion +-- optimiser itself, so I have copied them here with assertions. + +mk_trans_co :: HasDebugCallStack => Coercion -> Coercion -> Coercion +-- Do assertion checking in mk_trans_co +mk_trans_co co1 co2 + = assertPpr (coercionRKind co1 `eqType` coercionLKind co2) + (vcat [ text "co1" <+> ppr co1 + , text "co2" <+> ppr co2 + , text "co1 kind" <+> ppr (coercionKind co1) + , text "co2 kind" <+> ppr (coercionKind co2) + , callStackDoc ]) $ + mkTransCo co1 co2 + +mk_coherence_right_co :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion +mk_coherence_right_co r ty co co2 + = assertGRefl ty co $ + mkCoherenceRightCo r ty co co2 + +assertGRefl :: HasDebugCallStack => Type -> Coercion -> r -> r +assertGRefl ty co res + = assertPpr (typeKind ty `eqType` coercionLKind co) + (vcat [ pp_ty "ty" ty + , pp_co "co" co + , callStackDoc ]) $ + res + +mk_grefl_right_co :: Role -> Type -> CoercionN -> Coercion +mk_grefl_right_co r ty co + = assertGRefl ty co $ + mkGReflRightCo r ty co + +pp_co :: String -> Coercion -> SDoc +pp_co s co = text s <+> hang (ppr co) 2 (dcolon <+> ppr (coercionKind co)) + +pp_ty :: String -> Type -> SDoc +pp_ty s ty = text s <+> hang (ppr ty) 2 (dcolon <+> ppr (typeKind ty)) + diff --git a/GHC/Core/ConLike.hs b/GHC/Core/ConLike.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/ConLike.hs @@ -0,0 +1,241 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[ConLike]{@ConLike@: Constructor-like things} +-} + + + +module GHC.Core.ConLike ( + ConLike(..) + , conLikeConLikeName + , isVanillaConLike + , conLikeArity + , conLikeVisArity + , conLikeFieldLabels + , conLikeConInfo + , conLikeInstOrigArgTys + , conLikeUserTyVarBinders + , conLikeExTyCoVars + , conLikeName + , conLikeStupidTheta + , conLikeImplBangs + , conLikeFullSig + , conLikeResTy + , conLikeFieldType + , conLikeIsInfix + , conLikeHasBuilder + ) where + +import GHC.Prelude + +import GHC.Core.DataCon +import GHC.Core.Multiplicity +import GHC.Core.PatSyn +import GHC.Core.TyCo.Rep (Type, ThetaType) +import GHC.Core.TyCon (tyConDataCons) +import GHC.Core.Type(mkTyConApp) +import GHC.Types.Unique +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Basic + +import GHC.Types.GREInfo +import GHC.Types.Var +import GHC.Utils.Misc +import GHC.Utils.Outputable + +import Data.Maybe( isJust ) +import qualified Data.Data as Data + +{- +************************************************************************ +* * +\subsection{Constructor-like things} +* * +************************************************************************ +-} + +-- | A constructor-like thing +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + +-- | Is this a \'vanilla\' constructor-like thing +-- (no existentials, no provided constraints)? +isVanillaConLike :: ConLike -> Bool +isVanillaConLike (RealDataCon con) = isVanillaDataCon con +isVanillaConLike (PatSynCon ps ) = isVanillaPatSyn ps + +conLikeConLikeName :: ConLike -> ConLikeName +conLikeConLikeName (RealDataCon dc) = DataConName (dataConName dc) +conLikeConLikeName (PatSynCon ps) = PatSynName (patSynName ps) + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq ConLike where + (==) = eqConLike + +eqConLike :: ConLike -> ConLike -> Bool +eqConLike x y = getUnique x == getUnique y + +-- There used to be an Ord ConLike instance here that used Unique for ordering. +-- It was intentionally removed to prevent determinism problems. +-- See Note [Unique Determinism] in GHC.Types.Unique. + +instance Uniquable ConLike where + getUnique (RealDataCon dc) = getUnique dc + getUnique (PatSynCon ps) = getUnique ps + +instance NamedThing ConLike where + getName (RealDataCon dc) = getName dc + getName (PatSynCon ps) = getName ps + +instance Outputable ConLike where + ppr (RealDataCon dc) = ppr dc + ppr (PatSynCon ps) = ppr ps + +instance OutputableBndr ConLike where + pprInfixOcc (RealDataCon dc) = pprInfixOcc dc + pprInfixOcc (PatSynCon ps) = pprInfixOcc ps + pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc + pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps + +instance Data.Data ConLike where + -- don't traverse? + toConstr _ = abstractConstr "ConLike" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ConLike" + +-- | Number of value arguments +conLikeArity :: ConLike -> Arity +conLikeArity (RealDataCon data_con) = dataConSourceArity data_con +conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn + +-- | Number of visible arguments +conLikeVisArity :: ConLike -> VisArity +conLikeVisArity (RealDataCon data_con) = dataConVisArity data_con +conLikeVisArity (PatSynCon pat_syn) = patSynVisArity pat_syn + +-- | Names of fields used for selectors +conLikeFieldLabels :: ConLike -> [FieldLabel] +conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con +conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn + +-- | The 'ConInfo' (arity and field labels) associated to a 'ConLike'. +conLikeConInfo :: ConLike -> ConInfo +conLikeConInfo con = + mkConInfo (conLikeConLikeInfo con) (conLikeArity con) (conLikeFieldLabels con) + +-- | Compute a 'ConLikeInfo' from a 'ConLike'. +conLikeConLikeInfo :: ConLike -> ConLikeInfo +conLikeConLikeInfo (RealDataCon con) + = ConIsData { conLikeDataCons = getName <$> tyConDataCons (dataConTyCon con) } +conLikeConLikeInfo (PatSynCon {}) + = ConIsPatSyn + +-- | Returns just the instantiated /value/ argument types of a 'ConLike', +-- (excluding dictionary args) +conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type] +conLikeInstOrigArgTys (RealDataCon data_con) tys = + dataConInstOrigArgTys data_con tys +conLikeInstOrigArgTys (PatSynCon pat_syn) tys = + map unrestricted $ patSynInstArgTys pat_syn tys + +-- | 'TyVarBinder's for the type variables of the 'ConLike'. For pattern +-- synonyms, this will always consist of the universally quantified variables +-- followed by the existentially quantified type variables. For data +-- constructors, the situation is slightly more complicated—see +-- @Note [DataCon user type variable binders]@ in "GHC.Core.DataCon". +conLikeUserTyVarBinders :: ConLike -> [TyVarBinder] +conLikeUserTyVarBinders (RealDataCon data_con) = + dataConUserTyVarBinders data_con +conLikeUserTyVarBinders (PatSynCon pat_syn) = + tyVarSpecToBinders $ + patSynUnivTyVarBinders pat_syn ++ patSynExTyVarBinders pat_syn + -- The order here is because of the order in `GHC.Tc.TyCl.PatSyn`. + +-- | Existentially quantified type/coercion variables +conLikeExTyCoVars :: ConLike -> [TyCoVar] +conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1 +conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1 + +conLikeName :: ConLike -> Name +conLikeName (RealDataCon data_con) = dataConName data_con +conLikeName (PatSynCon pat_syn) = patSynName pat_syn + +-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +-- It is empty for `PatSynCon` as they do not allow such contexts. +-- See @Note [The stupid context]@ in "GHC.Core.DataCon". +conLikeStupidTheta :: ConLike -> ThetaType +conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con +conLikeStupidTheta (PatSynCon {}) = [] + +-- | 'conLikeHasBuilder' returns True except for +-- uni-directional pattern synonyms, which have no builder +conLikeHasBuilder :: ConLike -> Bool +conLikeHasBuilder (RealDataCon {}) = True +conLikeHasBuilder (PatSynCon pat_syn) = isJust (patSynBuilder pat_syn) + +-- | Returns the strictness information for each constructor +conLikeImplBangs :: ConLike -> [HsImplBang] +conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con +conLikeImplBangs (PatSynCon pat_syn) = + replicate (patSynArity pat_syn) HsLazy + +-- | Returns the type of the whole pattern +conLikeResTy :: ConLike -> [Type] -> Type +conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys +conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys + +-- | The \"full signature\" of the 'ConLike' returns, in order: +-- +-- 1) The universally quantified type variables +-- +-- 2) The existentially quantified type/coercion variables +-- +-- 3) The equality specification +-- +-- 4) The provided theta (the constraints provided by a match) +-- +-- 5) The required theta (the constraints required for a match) +-- +-- 6) The original argument types (i.e. before +-- any change of the representation of the type) +-- +-- 7) The original result type +conLikeFullSig :: ConLike + -> ([TyVar], [TyCoVar] + -- Why tyvars for universal but tycovars for existential? + -- See Note [Existential coercion variables] in GHC.Core.DataCon + , [EqSpec] + , ThetaType -- Provided theta + , ThetaType -- Required theta + , [Scaled Type] -- Arguments + , Type ) -- Result +conLikeFullSig (RealDataCon con) = + let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con + -- Required theta is empty as normal data cons require no additional + -- constraints for a match + in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty) +conLikeFullSig (PatSynCon pat_syn) = + let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn + -- eqSpec is empty + in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty) + +-- | Extract the type for any given labelled field of the 'ConLike' +conLikeFieldType :: ConLike -> FieldLabelString -> Type +conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label +conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label + +conLikeIsInfix :: ConLike -> Bool +conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc +conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps diff --git a/GHC/Core/DataCon.hs b/GHC/Core/DataCon.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/DataCon.hs @@ -0,0 +1,2016 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[DataCon]{@DataCon@: Data Constructors} +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary + +module GHC.Core.DataCon ( + -- * Main data types + DataCon, DataConRep(..), + SrcStrictness(..), SrcUnpackedness(..), + HsSrcBang(..), HsImplBang(..), + StrictnessMark(..), + ConTag, + DataConEnv, + + -- ** Equality specs + EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, + eqSpecPair, eqSpecPreds, + + -- ** Field labels + FieldLabel(..), flLabel, FieldLabelString, + + -- ** Type construction + mkDataCon, fIRST_TAG, + + -- ** Type deconstruction + dataConRepType, dataConInstSig, dataConFullSig, + dataConName, dataConIdentity, dataConTag, dataConTagZ, + dataConTyCon, dataConOrigTyCon, + dataConWrapperType, + dataConNonlinearType, + dataConDisplayType, + dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, + dataConConcreteTyVars, + dataConUserTyVars, dataConUserTyVarBinders, + dataConTheta, + dataConStupidTheta, + dataConOtherTheta, + dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, + dataConInstOrigArgTys, dataConRepArgTys, dataConResRepTyArgs, + dataConInstUnivs, + dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, + dataConSrcBangs, + dataConSourceArity, dataConVisArity, dataConRepArity, + dataConIsInfix, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, + dataConImplicitTyThings, + dataConRepStrictness, + dataConImplBangs, dataConBoxer, + + splitDataProductType_maybe, + + -- ** Predicates on DataCons + isNullarySrcDataCon, isNullaryRepDataCon, + isLazyDataConRep, + isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon, + isUnboxedSumDataCon, isCovertGadtDataCon, isUnaryClassDataCon, + isVanillaDataCon, isNewDataCon, isTypeDataCon, + classDataCon, dataConCannotMatch, + dataConUserTyVarBindersNeedWrapper, checkDataConTyVars, + isBanged, isUnpacked, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, + specialPromotedDc, + + -- ** Promotion related functions + promoteDataCon + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Basic +import Language.Haskell.Syntax.Module.Name + +import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) +import GHC.Core.Type as Type +import GHC.Core.Coercion +import GHC.Core.Unify +import GHC.Core.TyCon +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Compare( eqType, eqForAllVis ) +import GHC.Core.Multiplicity +import {-# SOURCE #-} GHC.Types.TyThing +import GHC.Types.FieldLabel +import GHC.Types.SourceText +import GHC.Core.Class +import GHC.Types.Name +import GHC.Builtin.Names +import GHC.Core.Predicate +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Basic +import GHC.Data.FastString +import GHC.Unit.Types +import GHC.Utils.Binary +import GHC.Types.Unique.FM ( UniqFM ) +import GHC.Types.Unique.Set +import GHC.Builtin.Uniques( mkAlphaTyVarUnique ) +import GHC.Data.Graph.UnVar -- UnVarSet and operations + +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars ) + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Data as Data +import Data.Char +import Data.List( find ) +import Control.DeepSeq + +{- +Note [Data constructor representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following Haskell data type declaration + + data T = T !Int ![Int] + +Using the strictness annotations, GHC will represent this as + + data T = T Int# [Int] + +That is, the Int has been unboxed. Furthermore, the Haskell source construction + + T e1 e2 + +is translated to + + case e1 of { I# x -> + case e2 of { r -> + T x r }} + +That is, the first argument is unboxed, and the second is evaluated. Finally, +pattern matching is translated too: + + case e of { T a b -> ... } + +becomes + + case e of { T a' b -> let a = I# a' in ... } + +To keep ourselves sane, we name the different versions of the data constructor +differently, as follows in Note [Data Constructor Naming]. + +The `dcRepType` field of a `DataCon` contains the type of the representation of +the constructor /worker/, also called the Core representation. + +The Core representation may differ from the type of the constructor /wrapper/ +(built by `mkDataConRep`). Besides unpacking (as seen in the example above), +dictionaries and coercions become explict arguments in the Core representation +of a constructor. + +Note that this representation is still *different* from runtime +representation. (Which is what STG uses after unarise). +See Note [Constructor applications in STG] in GHC.Stg.Syntax. + + +Note [Data Constructor Naming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each data constructor C has two, and possibly up to four, Names associated with it: + + OccName Name space Name of Notes + --------------------------------------------------------------------------- + The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) + The "worker data con" C VarName Id The worker + The "wrapper data con" $WC VarName Id The wrapper + The "newtype coercion" :CoT TcClsName TyCon + +EVERY data constructor (incl for newtypes) has the former two (the +data con itself, and its worker. But only some data constructors have a +wrapper (see Note [The need for a wrapper]). + +Each of these three has a distinct Unique. The "data con itself" name +appears in the output of the renamer, and names the Haskell-source +data constructor. The type checker translates it into either the wrapper Id +(if it exists) or worker Id (otherwise). + +The data con has one or two Ids associated with it: + +The "worker Id", is the actual data constructor. +* Every data constructor (newtype or data type) has a worker + +* The worker is very like a primop, in that it has no binding. + +* For a *data* type, the worker *is* the data constructor; + it has no unfolding + +* For a *newtype*, the worker has a compulsory unfolding which + does a cast, e.g. + newtype T = MkT Int + The worker for MkT has unfolding + \\(x:Int). x `cast` sym CoT + Here CoT is the type constructor, witnessing the FC axiom + axiom CoT : T = Int + +The "wrapper Id", \$WC, goes as follows + +* Its type is exactly what it looks like in the source program. + +* It is an ordinary function, and it gets a top-level binding + like any other function. + +* The wrapper Id isn't generated for a data type if there is + nothing for the wrapper to do. That is, if its defn would be + \$wC = C + +Note [Data constructor workers and wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Algebraic data types + - Always have a worker, with no unfolding + - May or may not have a wrapper; see Note [The need for a wrapper] + +* Newtypes + - Always have a worker, which has a compulsory unfolding (just a cast) + - May or may not have a wrapper; see Note [The need for a wrapper] + +* INVARIANT: the dictionary constructor for a class + never has a wrapper. + +* See Note [Data Constructor Naming] for how the worker and wrapper + are named + +* The workers don't take the dcStupidTheta dicts as arguments, while the + wrappers currently do + +* The wrapper (if it exists) takes dcOrigArgTys as its arguments. + The worker takes dataConRepArgTys as its arguments + If the wrapper is absent, dataConRepArgTys is the same as dcOrigArgTys + +* The 'NoDataConRep' case of DataConRep is important. Not only is it + efficient, but it also ensures that the wrapper is replaced by the + worker (because it *is* the worker) even when there are no + args. E.g. in + f (:) x + the (:) *is* the worker. This is really important in rule matching, + (We could match on the wrappers, but that makes it less likely that + rules will match when we bring bits of unfoldings together.) + +Note [The need for a wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why might the wrapper have anything to do? The full story is +in wrapper_reqd in GHC.Types.Id.Make.mkDataConRep. + +* Unboxing strict fields (with -funbox-strict-fields) + data T = MkT !(Int,Int) + \$wMkT :: (Int,Int) -> T + \$wMkT (x,y) = MkT x y + Notice that the worker has two fields where the wrapper has + just one. That is, the worker has type + MkT :: Int -> Int -> T + +* Equality constraints for GADTs + data T a where { MkT :: a -> T [a] } + + The worker gets a type with explicit equality + constraints, thus: + MkT :: forall a b. (a=[b]) => b -> T a + + The wrapper has the programmer-specified type: + \$wMkT :: a -> T [a] + \$wMkT a x = MkT [a] a [a] x + The third argument is a coercion + [a] :: [a]~[a] + +* Data family instances may do a cast on the result + +* Type variables may be permuted; see MkId + Note [Data con wrappers and GADT syntax] + +* Datatype contexts require dropping some dictionary arguments. + See Note [Instantiating stupid theta]. + +Note [The stupid context] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Data types can have a context: + + data (Eq a, Ord b) => T a b = T1 a b | T2 a + +And that makes the constructors have a context too. A constructor's context +isn't necessarily the same as the data type's context, however. Per the +Haskell98 Report, the part of the datatype context that is used in a data +constructor is the largest subset of the datatype context that constrains +only the type variables free in the data constructor's field types. For +example, here are the types of T1 and T2: + + T1 :: (Eq a, Ord b) => a -> b -> T a b + T2 :: (Eq a) => a -> T a b + +Notice that T2's context is "thinned". Since its field is of type `a`, only +the part of the datatype context that mentions `a`—that is, `Eq a`—is +included in T2's context. On the other hand, T1's fields mention both `a` +and `b`, so T1's context includes all of the datatype context. + +Furthermore, this context pops up when pattern matching +(though GHC hasn't implemented this, but it is in H98, and +I've fixed GHC so that it now does): + + f (T2 x) = x +gets inferred type + f :: Eq a => T a b -> a + +I say the context is "stupid" because the dictionaries passed +are immediately discarded -- they do nothing and have no benefit. +(See Note [Instantiating stupid theta].) +It's a flaw in the language. + +GHC has made some efforts to correct this flaw. In GHC, datatype contexts +are not available by default. Instead, one must explicitly opt in to them by +using the DatatypeContexts extension. To discourage their use, GHC has +deprecated DatatypeContexts. + +Some other notes about stupid contexts: + +* Stupid contexts can interact badly with `deriving`. For instance, it's + unclear how to make this derived Functor instance typecheck: + + data Eq a => T a = MkT a + deriving Functor + + This is because the derived instance would need to look something like + `instance Functor T where ...`, but there is nowhere to mention the + requisite `Eq a` constraint. For this reason, GHC will throw an error if a + user attempts to derive an instance for Functor (or a Functor-like class) + where the last type variable is used in a datatype context. For Generic(1), + the requirements are even harsher, as stupid contexts are not allowed at all + in derived Generic(1) instances. (We could consider relaxing this requirement + somewhat, although no one has asked for this yet.) + + Stupid contexts are permitted when deriving instances of non-Functor-like + classes, or when deriving instances of Functor-like classes where the last + type variable isn't mentioned in the stupid context. For example, the + following is permitted: + + data Show a => T a = MkT deriving Eq + + Note that because of the "thinning" behavior mentioned above, the generated + Eq instance should not mention `Show a`, as the type of MkT doesn't require + it. That is, the following should be generated (#20501): + + instance Eq (T a) where + (MkT == MkT) = True + +* It's not obvious how stupid contexts should interact with GADTs. For this + reason, GHC disallows combining datatype contexts with GADT syntax. As a + result, dcStupidTheta is always empty for data types defined using GADT + syntax. + +Note [Instantiating stupid theta] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a data type with a "stupid theta" (see +Note [The stupid context]): + + data Ord a => T a = MkT (Maybe a) + +We want to generate an Ord constraint for every use of MkT; but +we also want to allow visible type application, such as + + MkT @Int + +To achieve this, the wrapper for a data (or newtype) constructor +with a datatype context contains a lambda which drops the dictionary +argments corresponding to the datatype context: + + /\a \(_d:Ord a). MkT @a + +Notice that the wrapper discards the dictionary argument d. +We don't need it; it was only there to generate a Wanted constraint. +(That is why it is stupid.) + +This all happens in GHC.Types.Id.Make.mkDataConRep. + +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ +-} + +-- | A data constructor +data DataCon + = MkData { + dcName :: Name, -- This is the name of the *source data con* + -- (see "Note [Data Constructor Naming]" above) + dcUnique :: Unique, -- Cached from Name + dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's + + -- Running example: + -- + -- *** As declared by the user + -- data T a b c where + -- MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c + + -- *** As represented internally + -- data T a b c where + -- MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x) + -- => x -> y -> T a b c + -- + -- The next six fields express the type of the constructor, in pieces + -- e.g. + -- + -- dcUnivTyVars = [a,b,c] + -- dcExTyCoVars = [x,y] + -- dcUserTyVarBinders = [c,y,x,b] + -- dcEqSpec = [a~(x,y)] + -- dcOtherTheta = [x~y, Ord x] + -- dcOrigArgTys = [x,y] + -- dcRepTyCon = T + + -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE + -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously, + -- vanilla datacons guaranteed to have the same type variables as their + -- parent TyCon, but that seems ugly.) They can be different in the case + -- where a GADT constructor uses different names for the universal + -- tyvars than does the tycon. For example: + -- + -- data H a where + -- MkH :: b -> H b + -- + -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH + -- will be [b]. + + dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor + -- Its type is of form + -- forall a1..an . t1 -> ... tm -> T a1..an + -- No existentials, no coercions, nothing. + -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = [] + -- NB 1: newtypes always have a vanilla data con + -- NB 2: a vanilla constructor can still be declared in GADT-style + -- syntax, provided its type looks like the above. + -- The declaration format is held in the TyCon (algTcGadtSyntax) + + -- dcUnivTyVars: Universally-quantified type vars [a,b,c] + -- INVARIANT: length matches arity of the dcRepTyCon + -- INVARIANT: result type of data con worker is exactly (T a b c) + -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with + -- the tyConTyVars of the parent TyCon + dcUnivTyVars :: [TyVar], + + -- Existentially-quantified type and coercion vars [x,y] + -- For an example involving coercion variables, + -- Why TyCoVars? See Note [Existential coercion variables] + dcExTyCoVars :: [TyCoVar], + + -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames + -- Reason: less confusing, and easier to generate Iface syntax + + -- The type variables of this data constructor that must be + -- instantiated to concrete types. For example: the RuntimeRep + -- variables of unboxed tuples and unboxed sums. + -- + -- See Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. + dcConcreteTyVars :: ConcreteTyVars, + + -- The type/coercion vars in the order the user wrote them [c,y,x,b] + -- INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders is + -- exactly the set of tyvars (*not* covars) of dcExTyCoVars unioned + -- with the set of dcUnivTyVars whose tyvars do not appear in dcEqSpec + -- So dcUserTyVarBinders is a subset of (dcUnivTyVars ++ dcExTyCoVars) + -- See Note [DataCon user type variable binders] + dcUserTyVarBinders :: [TyVarBinder], + + dcEqSpec :: [EqSpec], -- Equalities derived from the result type, + -- _as written by the programmer_. + -- Only non-dependent GADT equalities (dependent + -- GADT equalities are in the covars of + -- dcExTyCoVars). + + -- This field allows us to move conveniently between the two ways + -- of representing a GADT constructor's type: + -- MkT :: forall a b. (a ~ [b]) => b -> T a + -- MkT :: forall b. b -> T [b] + -- Each equality is of the form (a ~ ty), where 'a' is one of + -- the universally quantified type variables. Moreover, the + -- only place in the DataCon where this 'a' will occur is in + -- dcUnivTyVars. See [The dcEqSpec domain invariant]. + + -- The next two fields give the type context of the data constructor + -- (aside from the GADT constraints, + -- which are given by the dcExpSpec) + -- In GADT form, this is *exactly* what the programmer writes, even if + -- the context constrains only universally quantified variables + -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b + dcOtherTheta :: ThetaType, -- The other constraints in the data con's type + -- other than those in the dcEqSpec + + dcStupidTheta :: ThetaType, -- The context of the data type declaration + -- data Eq a => T a = ... + -- or, rather, a "thinned" version thereof + -- "Thinned", because the Report says + -- to eliminate any constraints that don't mention + -- tyvars free in the arg types for this constructor. + -- See Note [The stupid context]. + -- + -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars + -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon + -- + -- "Stupid", because the dictionaries aren't used for anything. + -- Indeed, [as of March 02] they are no longer in the type of + -- the wrapper Id, because that makes it harder to use the wrap-id + -- to rebuild values after record selection or in generics. + + dcOrigArgTys :: [Scaled Type], -- Original argument types + -- (before unboxing and flattening of strict fields) + dcOrigResTy :: Type, -- Original result type, as seen by the user + -- NB: for a data instance, the original user result type may + -- differ from the DataCon's representation TyCon. Example + -- data instance T [a] where MkT :: a -> T [a] + -- The dcOrigResTy is T [a], but the dcRepTyCon might be R:TList + + -- Now the strictness annotations and field labels of the constructor + dcSrcBangs :: [HsSrcBang], + -- See Note [Bangs on data constructor arguments] + -- + -- The [HsSrcBang] as written by the programmer. + -- + -- Matches 1-1 with dcOrigArgTys + -- Hence length = dataConSourceArity dataCon + + dcImplBangs :: [HsImplBang], + -- The actual decisions made (including failures) + -- about the original arguments; 1-1 with orig_arg_tys + -- See Note [Bangs on data constructor arguments] + + dcStricts :: [StrictnessMark], + -- One mark for every field of the DataCon worker; + -- if it's empty, then all fields are lazy, + -- otherwise 1-1 with dataConRepArgTys. + -- See also Note [Strict fields in Core] in GHC.Core + -- for the effect on the strictness signature + + dcFields :: [FieldLabel], + -- Field labels for this constructor, in the + -- same order as the dcOrigArgTys; + -- length = 0 (if not a record) or dataConSourceArity. + + -- The curried worker function that corresponds to the constructor: + -- It doesn't have an unfolding; the code generator saturates these Ids + -- and allocates a real constructor when it finds one. + dcWorkId :: Id, + + -- Constructor representation + dcRep :: DataConRep, + + -- Cached; see Note [DataCon arities] + -- INVARIANT: dcRepArity == length dataConRepArgTys + count isCoVar (dcExTyCoVars) + -- INVARIANT: dcSourceArity == length dcOrigArgTys + dcRepArity :: Arity, + dcSourceArity :: Arity, + + -- Result type of constructor is T t1..tn + dcRepTyCon :: TyCon, -- Result tycon, T + + dcRepType :: Type, -- Type of the constructor + -- forall a x y. (a~(x,y), x~y, Ord x) => + -- x -> y -> T a + -- (this is *not* of the constructor wrapper Id: + -- see Note [Data constructor representation]) + -- Notice that the existential type parameters come *second*. + -- Reason: in a case expression we may find: + -- case (e :: T t) of + -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... + -- It's convenient to apply the rep-type of MkT to 't', to get + -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t + -- and use that to check the pattern. Mind you, this is really only + -- used in GHC.Core.Lint. + + + dcInfix :: Bool, -- True <=> declared infix + -- Used for Template Haskell and 'deriving' only + -- The actual fixity is stored elsewhere + + dcPromoted :: TyCon -- The promoted TyCon + -- See Note [Promoted data constructors] in GHC.Core.TyCon + } + + +{- Note [Existential coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For now (Aug 2018) we can't write coercion quantifications in source Haskell, but +we can in Core. Consider having: + + data T :: forall k. k -> k -> Constraint where + MkT :: forall k (a::k) (b::k). + forall k' (c::k') (co::k'~k). + (b ~# (c|>co)) => T k a b + + dcUnivTyVars = [k,a,b] + dcExTyCoVars = [k',c,co] + dcUserTyVarBinders = [k,a,k',c] + dcEqSpec = [b ~# (c|>co)] + dcOtherTheta = [] + dcOrigArgTys = [] + dcRepTyCon = T + +Function call 'dataConKindEqSpec' returns [k'~k] + +Note [DataCon arities] +~~~~~~~~~~~~~~~~~~~~~~ +A `DataCon`'s source and core representation may differ, meaning the source +arity (`dcSourceArity`) and the core representation arity (`dcRepArity`) may +differ too. + +Note that the source arity isn't exactly the number of arguments the data con +/wrapper/ has, since `dcSourceArity` doesn't count constraints -- which may +appear in the wrapper through `DatatypeContexts`, or if the constructor stores a +dictionary. In this sense, the source arity counts the number of non-constraint +arguments that appear at the source level. + On the other hand, the Core representation arity is the number of arguments +of the data constructor in its Core representation, which is also the number +of arguments of the data con /worker/. + +The arity might differ since `dcRepArity` takes into account arguments such as +quantified dictionaries and coercion arguments, lifted and unlifted (despite +the unlifted coercion arguments having a zero-width runtime representation). +For example: + MkT :: Ord a => a -> T a + dcSourceArity = 1 + dcRepArity = 2 + + MkU :: (b ~ '[]) => U b + dcSourceArity = 0 + dcRepArity = 1 + +The arity might also differ due to unpacking, for example, consider the +following datatype and its wrapper and worker's type: + data V = MkV !() !Int + $WMkV :: () -> Int -> V + MkV :: Int# -> V +As you see, because of unpacking we have both dropped the unit argument and +unboxed the Int. In this case, the source arity (which is the arity of the +wrapper) is 2, while the Core representation arity (the arity of the worker) is 1. + + +Note [DataCon user type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A DataCon has two different sets of type variables: + +* dcUserTyVarBinders, for the type variables binders in the order in which they + originally arose in the user-written type signature, and with user-specified + visibilities. + + - They are the forall'd binders of the data con /wrapper/, which the user calls. + + - With RequiredTypeArguments, some of the foralls may be visible, e.g. + MkT :: forall a b. forall c -> (a, b, c) -> T a b c + so the binders are full TyVarBinders, complete with visibilities. + + - Even if we only consider invisible foralls, the order and specificity of + binders matter for TypeApplications. + +* dcUnivTyVars and dcExTyCoVars, for the "true underlying" (i.e. of the data + con worker) universal type variable and existential type/coercion variables, + respectively. + + - They (i.e. univ ++ ex) are the forall'd variables of the data con /worker/ + + - They do not come equipped with visibilities: + dcUnivTyVars :: [TyVar] -- not [TyVarBinder] + dcExTyCoVars :: [TyCoVar] -- not [ForAllTyBinder] + Instead, we treat them as having the Specified (coreTyLamForAllTyFlag) + visibility. For example: + wrapper type: forall {a} b. forall c -> ... + worker type: forall a b c. ... + This is a design choice. Reasons: + * Workers are never called by the user. They are part of the Core + language where visibilities don't matter as much. + * Consistency with type lambdas in Core. As Note [Required foralls in Core] + in GHC.Core.TyCo.Rep explains, (/\a. e) :: (forall a. e_ty), and we need + a coercion to cast it to (forall a -> e_ty). + As a consequence, we may need to adjust visibilities with a cast in the + wrapper. See Note [Flag cast in data con wrappers]. + +Often (dcUnivTyVars ++ dcExTyCoVars) = binderVars dcUserTyVarBinders; but they +may differ for two reasons, coming next: + +--- Reason (R1): Order of quantification in GADT syntax --- + +In System FC, data constructor type signatures always quantify over all of +their universal type variables, followed by their existential type variables. +Normally, this isn't a problem, as most datatypes naturally quantify their type +variables in this order anyway. For example: + + data T a b = forall c. MkT b c + +Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`, +where k, a, and b are universal and c is existential. (The inferred variable k +isn't available for TypeApplications, hence why it's in braces.) This is a +perfectly reasonable order to use, as the syntax of H98-style datatypes +(+ ExistentialQuantification) suggests it. + +Things become more complicated when GADT syntax enters the picture. Consider +this example: + + data X a where + MkX :: forall b a. b -> Proxy a -> X a + +If we adopt the earlier approach of quantifying all the universal variables +followed by all the existential ones, GHC would come up with this type +signature for MkX: + + MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a + +But this is not what we want at all! After all, if a user were to use +TypeApplications on MkX, they would expect to instantiate `b` before `a`, +as that's the order in which they were written in the `forall`. (See #11721.) +Instead, we'd like GHC to come up with this type signature: + + MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a + +In fact, even if we left off the explicit forall: + + data X a where + MkX :: b -> Proxy a -> X a + +Then a user should still expect `b` to be quantified before `a`, since +according to the rules of TypeApplications, in the absence of `forall` GHC +performs a stable topological sort on the type variables in the user-written +type signature, which would place `b` before `a`. + +--- Reason (R2): GADT constructors quantify over different variables --- + +GADT constructors may quantify over different variables than the worker +would. Consider + data T a b where + MkT :: forall c d. c -> T [c] d + +The dcUserTyVarBinders must be [c, d] -- that's what the user quantified over. +But c is actually existential, as it is not equal to either of the two +universal variables. + +Here is what we'll get: + + dcUserTyVarBinders = [c, d] + dcUnivTyVars = [a, d] + dcExTyCoVars = [c] + +Note that dcUnivTyVars contains `a` from the type header (the `data T a b`) +and `d` from the signature for MkT. This is done because d is used in place +of b in the result of MkT, and so we use the name d for the universal, as that +might improve error messages. On the other hand, we need to use a fresh name +for the first universal (recalling that the result of a worker must be the +type constructor applied to a sequence of plain variables), so we use `a`, from +the header. This choice of universals is made in GHC.Tc.TyCl.mkGADTVars. + +Because c is not a universal, it is an existential. Here, we see that (even +ignoring order) dcUserTyVarBinders is not dcUnivTyVars ⋃ dcExTyCoVars, because +the latter has `a` while the former does not. To understand this better, let's +look at this type for the "true underlying" worker data con: + + MkT :: forall a d. forall c. (a ~# [c]) => c -> T a d + +We see here that the `a` universal is connected with the `c` existential via +an equality constraint. It will always be the case (see the code in mkGADTVars) +that the universals not mentioned in dcUserTyVarBinders will be used in a +GADT equality -- that is, used on the left-hand side of an element of dcEqSpec: + + dcEqSpec = [a ~# [c]] + +Putting this all together, all variables used on the left-hand side of an +equation in the dcEqSpec will be in dcUnivTyVars but *not* in +dcUserTyVarBinders. + +--- End of Reasons --- + +INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders +consists of: + +* The set of tyvars in dcUnivTyVars whose type variables do not appear in + dcEqSpec, unioned with: + +* The set of tyvars (*not* covars) in dcExTyCoVars + No covars here because because they're not user-written + +When comparing for equality, we ignore differences concerning type variables +whose kinds have kind Constraint. + +The word "set" is used above because the order in which the tyvars appear in +dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or +dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of +(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the +ordering, they in fact share the same type variables (with the same Uniques). We +sometimes refer to this as "the dcUserTyVarBinders invariant". It is checked +in checkDataConTyVars. + +dcUserTyVarBinders, as the name suggests, is the one that users will +see most of the time. It's used when computing the type signature of a +data constructor wrapper (see dataConWrapperType), and as a result, +it's what matters from a TypeApplications perspective. + +Note [The dcEqSpec domain invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example of a GADT constructor: + + data Y a where + MkY :: Bool -> Y Bool + +The user-written type of MkY is `Bool -> Y Bool`, but what is the underlying +Core type for MkY? There are two conceivable possibilities: + +1. MkY :: forall a. (a ~# Bool) => Bool -> Y a +2. MkY :: forall a. (a ~# Bool) => a -> Y a + +In practice, GHC picks (1) as the Core type for MkY. This is because we +maintain an invariant that the type variables in the domain of dcEqSpec will +only ever appear in the dcUnivTyVars. As a consequence, the type variables in +the domain of dcEqSpec will /never/ appear in the dcExTyCoVars, dcOtherTheta, +dcOrigArgTys, or dcOrigResTy; these can only ever mention variables from +dcUserTyVarBinders, which excludes things in the domain of dcEqSpec. +(See Note [DataCon user type variable binders].) This explains why GHC would +not pick (2) as the Core type, since the argument type `a` mentions a type +variable in the dcEqSpec. + +There are certain parts of the codebase where it is convenient to apply the +substitution arising from the dcEqSpec to the dcUnivTyVars in order to obtain +the user-written return type of a GADT constructor. A consequence of the +dcEqSpec domain invariant is that you /never/ need to apply the substitution +to any other part of the constructor type, as they don't require it. +-} + +-- | Data Constructor Representation +-- See Note [Data constructor workers and wrappers] +data DataConRep + = -- NoDataConRep means that the data con has no wrapper + NoDataConRep + + -- DCR means that the data con has a wrapper + | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens, + -- and constructs the representation + + , dcr_boxer :: DataConBoxer + + , dcr_arg_tys :: [Scaled Type] -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* all evidence args + + } + +type DataConEnv a = UniqFM DataCon a -- Keyed by DataCon + +------------------------- + +-- | Haskell Source Bang +-- +-- Bangs on data constructor arguments as written by the user, including the +-- source code for exact-printing. +-- +-- @(HsSrcBang _ SrcUnpack SrcLazy)@ and +-- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we +-- emit a warning (in checkValidDataCon) and treat it like +-- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ +-- +-- In the AST, the @SourceText@ is hidden inside the extension point +-- 'Language.Haskell.Syntax.Extension.XConDeclField'. +data HsSrcBang + = HsSrcBang SourceText SrcUnpackedness SrcStrictness -- See Note [Pragma source text] in "GHC.Types.SourceText" + deriving Data.Data + +-- | Haskell Implementation Bang +-- +-- Bangs of data constructor arguments as generated by the compiler +-- after consulting HsSrcBang, flags, etc. +data HsImplBang + = HsLazy -- ^ Lazy field, or one with an unlifted type + | HsStrict Bool -- ^ Strict but not unpacked field + -- True <=> we could have unpacked, but opted not to + -- because of -O0. + -- See Note [Detecting useless UNPACK pragmas] + | HsUnpack (Maybe Coercion) + -- ^ Strict and unpacked field + -- co :: arg-ty ~ product-ty HsBang + deriving Data.Data + + + +------------------------- +-- StrictnessMark is used to indicate strictness +-- of the DataCon *worker* fields +data StrictnessMark = MarkedStrict | NotMarkedStrict + deriving Eq + +-- | An 'EqSpec' is a tyvar/type pair representing an equality made in +-- rejigging a GADT constructor +data EqSpec = EqSpec TyVar Type + +-- | Make a non-dependent 'EqSpec' +mkEqSpec :: TyVar -> Type -> EqSpec +mkEqSpec tv ty = EqSpec tv ty + +eqSpecTyVar :: EqSpec -> TyVar +eqSpecTyVar (EqSpec tv _) = tv + +eqSpecType :: EqSpec -> Type +eqSpecType (EqSpec _ ty) = ty + +eqSpecPair :: EqSpec -> (TyVar, Type) +eqSpecPair (EqSpec tv ty) = (tv, ty) + +eqSpecPreds :: [EqSpec] -> ThetaType +eqSpecPreds spec = [ mkNomEqPred (mkTyVarTy tv) ty + | EqSpec tv ty <- spec ] + +instance Outputable EqSpec where + ppr (EqSpec tv ty) = ppr (tv, ty) + +{- Note [Bangs on data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Int {-# UNPACK #-} !Int Bool + +When compiling the module, GHC will decide how to represent +MkT, depending on the optimisation level, and settings of +flags like -funbox-small-strict-fields. + +Terminology: + * HsSrcBang: What the user wrote + Constructors: HsSrcBang + + * HsImplBang: What GHC decided + Constructors: HsLazy, HsStrict, HsUnpack + +* If T was defined in this module, MkT's dcSrcBangs field + records the [HsSrcBang] of what the user wrote; in the example + [ HsSrcBang _ NoSrcUnpack SrcStrict + , HsSrcBang _ SrcUnpack SrcStrict + , HsSrcBang _ NoSrcUnpack NoSrcStrictness] + +* However, if T was defined in an imported module, the importing module + must follow the decisions made in the original module, regardless of + the flag settings in the importing module. + Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make + +* The dcImplBangs field records the [HsImplBang] + If T was defined in this module, Without -O the dcImplBangs might be + [HsStrict _, HsStrict _, HsLazy] + With -O it might be + [HsStrict _, HsUnpack _, HsLazy] + With -funbox-small-strict-fields it might be + [HsUnpack, HsUnpack _, HsLazy] + With -XStrictData it might be + [HsStrict _, HsUnpack _, HsStrict _] + +* Core passes will often need to know whether the DataCon worker or wrapper in + an application is strict in some (lifted) field or not. This is tracked in the + demand signature attached to a DataCon's worker resp. wrapper Id. + + So if you've got a DataCon dc, you can get the demand signature by + `idDmdSig (dataConWorkId dc)` and make out strict args by testing with + `isStrictDmd`. Similarly, `idDmdSig <$> dataConWrapId_maybe dc` gives + you the demand signature of the wrapper, if it exists. + + These demand signatures are set in GHC.Types.Id.Make.mkDataConWorkId, + computed from the single source of truth `dataConRepStrictness`, which is + generated from `dcStricts`. + Note that `dataConRepStrictness` lines up 1-1 with `idDmdSig (dataConWorkId dc)`. + +Note [Detecting useless UNPACK pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to issue a warning when there's an UNPACK pragma in the source code, +but we decided not to unpack. +However, when compiling with -O0, we never unpack, and that'd generate +spurious warnings. +Therefore, we remember in HsStrict a boolean flag, whether we _could_ +have unpacked. This flag is set in GHC.Types.Id.Make.dataConSrcToImplBang. +Then, in GHC.Tc.TyCl.checkValidDataCon (sub-function check_bang), +if the user wrote an `{-# UNPACK #-}` pragma (i.e. HsSrcBang contains SrcUnpack) +we consult HsImplBang: + + HsUnpack _ => field unpacked, no warning + Example: data T = MkT {-# UNPACK #-} !Int [with -O] + HsStrict True => field not unpacked because -O0, no warning + Example: data T = MkT {-# UNPACK #-} !Int [with -O0] + HsStrict False => field not unpacked, warning + Example: data T = MkT {-# UNPACK #-} !(Int -> Int) + HsLazy => field not unpacked, warning + This can happen in two scenarios: + + 1) UNPACK without a bang + Example: data T = MkT {-# UNPACK #-} Int + This will produce a warning about missing ! before UNPACK. + + 2) UNPACK of an unlifted datatype + Because of bug #20204, we currently do not unpack type T, + and therefore issue a warning: + type IntU :: UnliftedType + data IntU = IntU Int# + data T = Test {-# UNPACK #-} IntU + +The boolean flag is used only for this warning. +See #11270 for motivation. + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq DataCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable DataCon where + getUnique = dcUnique + +instance NamedThing DataCon where + getName = dcName + +instance Outputable DataCon where + ppr con = ppr (dataConName con) + +instance OutputableBndr DataCon where + pprInfixOcc con = pprInfixName (dataConName con) + pprPrefixOcc con = pprPrefixName (dataConName con) + +instance Data.Data DataCon where + -- don't traverse? + toConstr _ = abstractConstr "DataCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "DataCon" + +instance Outputable HsSrcBang where + ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark + +instance Outputable HsImplBang where + ppr HsLazy = text "Lazy" + ppr (HsUnpack Nothing) = text "Unpacked" + ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) + ppr (HsStrict b) = text "StrictNotUnpacked" <> parens (ppr b) + +instance Outputable SrcStrictness where + ppr SrcLazy = char '~' + ppr SrcStrict = char '!' + ppr NoSrcStrict = empty + +instance Outputable SrcUnpackedness where + ppr SrcUnpack = text "{-# UNPACK #-}" + ppr SrcNoUnpack = text "{-# NOUNPACK #-}" + ppr NoSrcUnpack = empty + +instance Outputable StrictnessMark where + ppr MarkedStrict = text "!" + ppr NotMarkedStrict = empty + +instance Binary StrictnessMark where + put_ bh NotMarkedStrict = putByte bh 0 + put_ bh MarkedStrict = putByte bh 1 + get bh = + do h <- getByte bh + case h of + 0 -> return NotMarkedStrict + 1 -> return MarkedStrict + _ -> panic "Invalid binary format" + +instance Binary SrcStrictness where + put_ bh SrcLazy = putByte bh 0 + put_ bh SrcStrict = putByte bh 1 + put_ bh NoSrcStrict = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcLazy + 1 -> return SrcStrict + _ -> return NoSrcStrict + +instance Binary SrcUnpackedness where + put_ bh SrcNoUnpack = putByte bh 0 + put_ bh SrcUnpack = putByte bh 1 + put_ bh NoSrcUnpack = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcNoUnpack + 1 -> return SrcUnpack + _ -> return NoSrcUnpack + +instance NFData SrcStrictness where + rnf SrcLazy = () + rnf SrcStrict = () + rnf NoSrcStrict = () + +instance NFData SrcUnpackedness where + rnf SrcNoUnpack = () + rnf SrcUnpack = () + rnf NoSrcUnpack = () + +-- | Compare strictness annotations +eqHsBang :: HsImplBang -> HsImplBang -> Bool +eqHsBang HsLazy HsLazy = True +eqHsBang (HsStrict _) (HsStrict _) = True +eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True +eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) + = eqType (coercionType c1) (coercionType c2) +eqHsBang _ _ = False + +isBanged :: HsImplBang -> Bool +isBanged (HsUnpack {}) = True +isBanged (HsStrict {}) = True +isBanged HsLazy = False + +isUnpacked :: HsImplBang -> Bool +isUnpacked (HsUnpack {}) = True +isUnpacked (HsStrict {}) = False +isUnpacked HsLazy = False + +isSrcStrict :: SrcStrictness -> Bool +isSrcStrict SrcStrict = True +isSrcStrict _ = False + +isSrcUnpacked :: SrcUnpackedness -> Bool +isSrcUnpacked SrcUnpack = True +isSrcUnpacked _ = False + +isMarkedStrict :: StrictnessMark -> Bool +isMarkedStrict NotMarkedStrict = False +isMarkedStrict _ = True -- All others are strict + +cbvFromStrictMark :: StrictnessMark -> CbvMark +cbvFromStrictMark NotMarkedStrict = NotMarkedCbv +cbvFromStrictMark MarkedStrict = MarkedCbv + + +{- ********************************************************************* +* * +\subsection{Construction} +* * +********************************************************************* -} + +-- | Build a new data constructor +mkDataCon :: Name + -> Bool -- ^ Is the constructor declared infix? + -> TyConRepName -- ^ TyConRepName for the promoted TyCon + -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user + -> [HsImplBang] -- ^ Strictness/unpack annotations, as inferred by the compiler + -> [StrictnessMark] -- ^ Strictness marks for the DataCon worker's fields in Core + -> [FieldLabel] -- ^ Field labels for the constructor, + -- if it is a record, otherwise empty + -> [TyVar] -- ^ Universals. + -> [TyCoVar] -- ^ Existentials. + -> ConcreteTyVars + -- ^ TyVars which must be instantiated with + -- concrete types + -> [TyVarBinder] -- ^ User-written 'TyVarBinder's + -> [EqSpec] -- ^ GADT equalities + -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper + -> [KnotTied (Scaled Type)] -- ^ Original argument types + -> KnotTied Type -- ^ Original result type + -> PromDataConInfo -- ^ See comments on 'GHC.Core.TyCon.PromDataConInfo' + -> KnotTied TyCon -- ^ Representation type constructor + -> ConTag -- ^ Constructor tag + -> ThetaType -- ^ The "stupid theta", context of the data + -- declaration e.g. @data Eq a => T a ...@ + -> Id -- ^ Worker Id + -> DataConRep -- ^ Representation + -> DataCon + -- Can get the tag from the TyCon + +mkDataCon name declared_infix prom_info + arg_stricts -- Must match orig_arg_tys 1-1 + impl_bangs -- Must match orig_arg_tys 1-1 + str_marks -- Must be empty or match dataConRepArgTys 1-1 + fields + univ_tvs ex_tvs conc_tvs user_tvbs + eq_spec theta + orig_arg_tys orig_res_ty rep_info rep_tycon tag + stupid_theta work_id rep +-- Warning: mkDataCon is not a good place to check certain invariants. +-- If the programmer writes the wrong result type in the decl, thus: +-- data T a where { MkT :: S } +-- then it's possible that the univ_tvs may hit an assertion failure +-- if you pull on univ_tvs. This case is checked by checkValidDataCon, +-- so the error is detected properly... it's just that assertions here +-- are a little dodgy. + + = con + where + is_vanilla = null ex_tvs && null eq_spec && null theta + str_marks' | not $ any isMarkedStrict str_marks = [] + | otherwise = str_marks + + con = MkData {dcName = name, dcUnique = nameUnique name, + dcVanilla = is_vanilla, dcInfix = declared_infix, + dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs, + dcConcreteTyVars = conc_tvs, + dcUserTyVarBinders = user_tvbs, + dcEqSpec = eq_spec, + dcOtherTheta = theta, + dcStupidTheta = stupid_theta, + dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, + dcRepTyCon = rep_tycon, + dcSrcBangs = arg_stricts, dcImplBangs = impl_bangs, + dcStricts = str_marks', + dcFields = fields, dcTag = tag, dcRepType = rep_ty, + dcWorkId = work_id, + dcRep = rep, + dcSourceArity = length orig_arg_tys, + dcRepArity = length rep_arg_tys + count isCoVar ex_tvs, + dcPromoted = promoted } + + -- The 'arg_stricts' passed to mkDataCon are simply those for the + -- source-language arguments. We add extra ones for the + -- dictionary arguments right here. + + rep_arg_tys = dataConRepArgTys con + + rep_ty = + case rep of + -- If the DataCon has no wrapper, then the worker's type *is* the + -- user-facing type, so we can simply use dataConWrapperType. + NoDataConRep -> dataConWrapperType con + -- If the DataCon has a wrapper, then the worker's type is never seen + -- by the user. The visibilities we pick do not matter here. + DCR{} -> mkInfForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ + mkScaledFunctionTys rep_arg_tys $ + mkTyConApp rep_tycon (mkTyVarTys univ_tvs) + -- res_arg_tys is a mixture of TypeLike and ConstraintLike, + -- so we don't know which FunTyFlag to use + -- Hence using mkScaledFunctionTys. + + -- See Note [Promoted data constructors] in GHC.Core.TyCon + prom_tv_bndrs = [ mkNamedTyConBinder vis tv + | Bndr tv vis <- user_tvbs ] + + fresh_names = freshNames (map getName user_tvbs) + -- fresh_names: make sure that the "anonymous" tyvars don't + -- clash in name or unique with the universal/existential ones. + -- Tiresome! And unnecessary because these tyvars are never looked at + prom_arg_bndrs = [ mkAnonTyConBinder (mkTyVar n t) + {- Visible -} | (n,t) <- dropList theta fresh_names `zip` map scaledThing orig_arg_tys ] + prom_bndrs = prom_tv_bndrs ++ prom_arg_bndrs + prom_res_kind = orig_res_ty + promoted = mkPromotedDataCon con name prom_info prom_bndrs + prom_res_kind roles rep_info + + roles = map (\tv -> if isTyVar tv then Nominal else Phantom) + (univ_tvs ++ ex_tvs) + ++ map (const Representational) (theta ++ map scaledThing orig_arg_tys) + +freshNames :: [Name] -> [Name] +-- Make an infinite list of Names whose Uniques and OccNames +-- differ from those in the 'avoid' list +freshNames avoids + = [ mkSystemName uniq occ + | n <- [0..] + , let uniq = mkAlphaTyVarUnique n + occ = mkTyVarOccFS (mkFastString ('x' : show n)) + + , not (uniq `memberUniqueSet` avoid_uniqs) + , not (occ `elemOccSet` avoid_occs) ] + + where + avoid_uniqs :: UniqueSet + avoid_uniqs = fromListUniqueSet (map getUnique avoids) + + avoid_occs :: OccSet + avoid_occs = mkOccSet (map getOccName avoids) + +-- | The 'Name' of the 'DataCon', giving it a unique, rooted identification +dataConName :: DataCon -> Name +dataConName = dcName + +-- | The tag used for ordering 'DataCon's +dataConTag :: DataCon -> ConTag +dataConTag = dcTag + +dataConTagZ :: DataCon -> ConTagZ +dataConTagZ con = dataConTag con - fIRST_TAG + +-- | The type constructor that we are building via this data constructor +dataConTyCon :: DataCon -> TyCon +dataConTyCon = dcRepTyCon + +-- | The original type constructor used in the definition of this data +-- constructor. In case of a data family instance, that will be the family +-- type constructor. +dataConOrigTyCon :: DataCon -> TyCon +dataConOrigTyCon dc + | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc + | otherwise = dcRepTyCon dc + +-- | The representation type of the data constructor, i.e. the sort +-- type that will represent values of this type at runtime +dataConRepType :: DataCon -> Type +dataConRepType = dcRepType + +-- | Should the 'DataCon' be presented infix? +dataConIsInfix :: DataCon -> Bool +dataConIsInfix = dcInfix + +-- | The universally-quantified type variables of the constructor +dataConUnivTyVars :: DataCon -> [TyVar] +dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs + +-- | The existentially-quantified type/coercion variables of the constructor +-- including dependent (kind-) GADT equalities +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs + +-- | Both the universal and existential type/coercion variables of the constructor +dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar] +dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs }) + = univ_tvs ++ ex_tvs + +-- | Which type variables of this data constructor that must be +-- instantiated to concrete types? +-- For example: the RuntimeRep variables of unboxed tuples and unboxed sums. +-- +-- See Note [Representation-polymorphism checking built-ins] +-- in GHC.Tc.Utils.Concrete +dataConConcreteTyVars :: DataCon -> ConcreteTyVars +dataConConcreteTyVars (MkData { dcConcreteTyVars = concs }) = concs + +-- See Note [DataCon user type variable binders] +-- | The type variables of the constructor, in the order the user wrote them +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs + +-- See Note [DataCon user type variable binders] +-- | 'TyVarBinder's for the type variables of the constructor, in the order the +-- user wrote them +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] +dataConUserTyVarBinders = dcUserTyVarBinders + +-- | Dependent (kind-level) equalities in a constructor. +-- There are extracted from the existential variables. +-- See Note [Existential coercion variables] +dataConKindEqSpec :: DataCon -> [EqSpec] +dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs}) + -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future), + -- which are frequently used functions. + -- For now (Aug 2018) this function always return empty set as we don't really + -- have coercion variables. + -- In the future when we do, we might want to cache this information in DataCon + -- so it won't be computed every time when aforementioned functions are called. + = [ EqSpec tv ty + | cv <- ex_tcvs + , isCoVar cv + , let (ty1, ty, _) = coVarTypesRole cv + tv = getTyVar ty1 + ] + +-- | The *full* constraints on the constructor type, including dependent GADT +-- equalities. +dataConTheta :: DataCon -> ThetaType +dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta + +-- | Get the Id of the 'DataCon' worker: a function that is the "actual" +-- constructor and has no top level binding in the program. The type may +-- be different from the obvious one written in the source program. Panics +-- if there is no such 'Id' for this 'DataCon' +dataConWorkId :: DataCon -> Id +dataConWorkId dc = dcWorkId dc + +-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" +-- constructor so it has the type visible in the source program: c.f. +-- 'dataConWorkId'. +-- Returns Nothing if there is no wrapper, which occurs for an algebraic data +-- constructor and also for a newtype (whose constructor is inlined +-- compulsorily) +dataConWrapId_maybe :: DataCon -> Maybe Id +dataConWrapId_maybe dc = case dcRep dc of + NoDataConRep -> Nothing + DCR { dcr_wrap_id = wrap_id } -> Just wrap_id + +-- | Returns an Id which looks like the Haskell-source constructor by using +-- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to +-- the worker (see 'dataConWorkId') +dataConWrapId :: DataCon -> Id +dataConWrapId dc = case dcRep dc of + NoDataConRep-> dcWorkId dc -- worker=wrapper + DCR { dcr_wrap_id = wrap_id } -> wrap_id + +-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, +-- the union of the 'dataConWorkId' and the 'dataConWrapId' +dataConImplicitTyThings :: DataCon -> [TyThing] +dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep }) + = [mkAnId work] ++ wrap_ids + where + wrap_ids = case rep of + NoDataConRep -> [] + DCR { dcr_wrap_id = wrap } -> [mkAnId wrap] + +-- | The labels for the fields of this particular 'DataCon' +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConFieldLabels = dcFields + +-- | Extract the type for any given labelled field of the 'DataCon' +dataConFieldType :: DataCon -> FieldLabelString -> Type +dataConFieldType con label = case dataConFieldType_maybe con label of + Just (_, ty) -> ty + Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) + +-- | Extract the label and type for any given labelled field of the +-- 'DataCon', or return 'Nothing' if the field does not belong to it +dataConFieldType_maybe :: DataCon -> FieldLabelString + -> Maybe (FieldLabel, Type) +dataConFieldType_maybe con label + = find ((== label) . flLabel . fst) (dcFields con `zip` (scaledThing <$> dcOrigArgTys con)) + +-- | Strictness/unpack annotations, from user; or, for imported +-- DataCons, from the interface file +-- The list is in one-to-one correspondence with the arity of the 'DataCon' + +dataConSrcBangs :: DataCon -> [HsSrcBang] +dataConSrcBangs = dcSrcBangs + +-- | Number of value arguments of the data constructor +dataConSourceArity :: DataCon -> Arity +dataConSourceArity (MkData { dcSourceArity = arity }) = arity + +-- | Number of visible arguments of the data constructor +dataConVisArity :: DataCon -> VisArity +dataConVisArity (MkData { dcUserTyVarBinders = tvbs, dcSourceArity = arity }) + = n_of_required_ty_args + n_of_val_args + where + n_of_val_args = arity + n_of_required_ty_args = count isVisibleForAllTyBinder tvbs + +-- | Gives the number of value arguments (including zero-width coercions) +-- stored by the given `DataCon`'s worker in its Core representation. This may +-- differ from the number of arguments that appear in the source code; see also +-- Note [DataCon arities] +dataConRepArity :: DataCon -> Arity +dataConRepArity (MkData { dcRepArity = arity }) = arity + +-- | Return whether there are any argument types for this 'DataCon's original source type +-- See Note [DataCon arities] +isNullarySrcDataCon :: DataCon -> Bool +isNullarySrcDataCon dc = dataConSourceArity dc == 0 + +-- | Return whether this `DataCon`'s worker, in its Core representation, takes +-- any value arguments. +-- +-- In particular, remember that we include coercion arguments in the arity of +-- the Core representation of the `DataCon` -- both lifted and unlifted +-- coercions, despite the latter having zero-width runtime representation. +-- +-- See also Note [DataCon arities]. +isNullaryRepDataCon :: DataCon -> Bool +isNullaryRepDataCon dc = dataConRepArity dc == 0 + +isLazyDataConRep :: DataCon -> Bool +-- ^ True <==> All fields are lazy +isLazyDataConRep dc = null (dcStricts dc) + +dataConRepStrictness :: DataCon -> [StrictnessMark] +-- ^ Give the demands on the runtime arguments of a Core DataCon worker +-- application. +-- The length of the list matches `dataConRepArgTys` (e.g., the number +-- of runtime arguments). +dataConRepStrictness dc + | isLazyDataConRep dc + = replicate (dataConRepArity dc) NotMarkedStrict + | otherwise + = dcStricts dc + +dataConImplBangs :: DataCon -> [HsImplBang] +-- The implementation decisions about the strictness/unpack of each +-- source program argument to the data constructor +dataConImplBangs dc = dcImplBangs dc + +dataConBoxer :: DataCon -> Maybe DataConBoxer +dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer +dataConBoxer _ = Nothing + +dataConInstSig + :: DataCon + -> [Type] -- Instantiate the *universal* tyvars with these types + -> ([TyCoVar], ThetaType, [Type]) -- Return instantiated existentials + -- theta and arg tys +-- ^ Instantiate the universal tyvars of a data con, +-- returning +-- ( instantiated existentials +-- , instantiated constraints including dependent GADT equalities +-- which are *also* listed in the instantiated existentials +-- , instantiated args) +dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs + , dcOrigArgTys = arg_tys }) + univ_tys + = ( ex_tvs' + , substTheta subst (dataConTheta con) + , substTys subst (map scaledThing arg_tys)) + where + univ_subst = zipTvSubst univ_tvs univ_tys + (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs + + +-- | The \"full signature\" of the 'DataCon' returns, in order: +-- +-- 1) The result of 'dataConUnivTyVars' +-- +-- 2) The result of 'dataConExTyCoVars' +-- +-- 3) The non-dependent GADT equalities. +-- Dependent GADT equalities are implied by coercion variables in +-- return value (2). +-- +-- 4) The other constraints of the data constructor type, excluding GADT +-- equalities +-- +-- 5) The original argument types to the 'DataCon' (i.e. before +-- any change of the representation of the type) with linearity +-- annotations +-- +-- 6) The original result type of the 'DataCon' +dataConFullSig :: DataCon + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type) +dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, + dcEqSpec = eq_spec, dcOtherTheta = theta, + dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) + +dataConOrigResTy :: DataCon -> Type +dataConOrigResTy dc = dcOrigResTy dc + +-- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +-- +-- See @Note [The stupid context]@. +dataConStupidTheta :: DataCon -> ThetaType +dataConStupidTheta dc = dcStupidTheta dc + +{- +Note [Displaying linear fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A constructor with a linear field can be written either as +MkT :: a %1 -> T a (with -XLinearTypes) +or +MkT :: a -> T a (with -XNoLinearTypes) + +There are three different methods to retrieve a type of a datacon. +They differ in how linear fields are handled. + +1. dataConWrapperType: +The type of the wrapper in Core. +For example, dataConWrapperType for Maybe is a %1 -> Just a. + +2. dataConNonlinearType: +The type of the constructor, with linear arrows replaced by unrestricted ones. +Used when we don't want to introduce linear types to user (in holes +and in types in hie used by haddock). + +3. dataConDisplayType (takes a boolean indicating if -XLinearTypes is enabled): +The type we'd like to show in error messages, :info and -ddump-types. +Ideally, it should reflect the type written by the user; +the function returns a type with arrows that would be required +to write this constructor under the current setting of -XLinearTypes. +In principle, this type can be different from the user's source code +when the value of -XLinearTypes has changed, but we don't +expect this to cause much trouble. + +Due to internal plumbing in checkValidDataCon, we can't just return a Doc. +The multiplicity of arrows returned by dataConDisplayType and +dataConDisplayType is used only for pretty-printing. +-} + +dataConWrapperType :: DataCon -> Type +-- ^ The user-declared type of the data constructor +-- in the nice-to-read form: +-- +-- > T :: forall a b. a -> b -> T [a] +-- +-- rather than: +-- +-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c +-- +-- The type variables are quantified in the order that the user wrote them. +-- See @Note [DataCon user type variable binders]@. +-- +-- NB: If the constructor is part of a data instance, the result type +-- mentions the family tycon, not the internal one. +dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, + dcOrigResTy = res_ty, + dcStupidTheta = stupid_theta }) + = mkForAllTys user_tvbs $ + mkInvisFunTys (stupid_theta ++ theta) $ + mkScaledFunTys arg_tys $ + res_ty + +dataConNonlinearType :: DataCon -> Type +-- Just like dataConWrapperType, but with the +-- linearity on the arguments all zapped to Many +dataConNonlinearType (MkData { dcUserTyVarBinders = user_tvbs, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, + dcOrigResTy = res_ty, + dcStupidTheta = stupid_theta }) + = mkForAllTys user_tvbs $ + mkInvisFunTys (stupid_theta ++ theta) $ + mkScaledFunTys arg_tys' $ + res_ty + where + arg_tys' = map (\(Scaled w t) -> Scaled (case w of OneTy -> ManyTy; _ -> w) t) arg_tys + +dataConDisplayType :: Bool -> DataCon -> Type +dataConDisplayType show_linear_types dc + = if show_linear_types + then dataConWrapperType dc + else dataConNonlinearType dc + +-- | Finds the instantiated types of the arguments required to construct a +-- 'DataCon' representation +-- NB: these INCLUDE any dictionary args +-- but EXCLUDE the data-declaration context, which is discarded +-- It's all post-flattening etc; this is a representation type +dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints + -- However, it can have a dcTheta (notably it can be a + -- class dictionary, with superclasses) + -> [Type] -- ^ Instantiated at these types + -> [Scaled Type] +dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs}) inst_tys + = assertPpr (univ_tvs `equalLength` inst_tys) + (text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) $ + assertPpr (null ex_tvs) (ppr dc) $ + map (mapScaledType (substTyWith univ_tvs inst_tys)) (dataConRepArgTys dc) + +-- | Returns just the instantiated /value/ argument types of a 'DataCon', +-- (excluding dictionary args) +dataConInstOrigArgTys + :: DataCon -- Works for any DataCon + -> [Type] -- Includes existential tyvar args, but NOT + -- equality constraints or dicts + -> [Scaled Type] +-- For vanilla datacons, it's all quite straightforward +-- But for the call in GHC.HsToCore.Match.Constructor, we really do want just +-- the value args +dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, + dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs}) inst_tys + = assertPpr (tyvars `equalLength` inst_tys) + (text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys) $ + substScaledTys subst arg_tys + where + tyvars = univ_tvs ++ ex_tvs + subst = zipTCvSubst tyvars inst_tys + +-- | Given a data constructor @dc@ with /n/ universally quantified type +-- variables @a_{1}@, @a_{2}@, ..., @a_{n}@, and given a list of argument +-- types @dc_args@ of length /m/ where /m/ <= /n/, then: +-- +-- @ +-- dataConInstUnivs dc dc_args +-- @ +-- +-- Will return: +-- +-- @ +-- [dc_arg_{1}, dc_arg_{2}, ..., dc_arg_{m}, a_{m+1}, ..., a_{n}] +-- @ +-- +-- That is, return the list of universal type variables with +-- @a_{1}@, @a_{2}@, ..., @a_{m}@ instantiated with +-- @dc_arg_{1}@, @dc_arg_{2}@, ..., @dc_arg_{m}@. It is possible for @m@ to +-- be less than @n@, in which case the remaining @n - m@ elements will simply +-- be universal type variables (with their kinds possibly instantiated). +-- +-- Examples: +-- +-- * Given the data constructor @D :: forall a b. Foo a b@ and +-- @dc_args@ @[Int, Bool]@, then @dataConInstUnivs D dc_args@ will return +-- @[Int, Bool]@. +-- +-- * Given the data constructor @D :: forall a b. Foo a b@ and +-- @dc_args@ @[Int]@, then @@dataConInstUnivs D dc_args@ will return +-- @[Int, b]@. +-- +-- * Given the data constructor @E :: forall k (a :: k). Bar k a@ and +-- @dc_args@ @[Type]@, then @@dataConInstUnivs D dc_args@ will return +-- @[Type, (a :: Type)]@. +-- +-- This is primarily used in @GHC.Tc.Deriv.*@ in service of instantiating data +-- constructors' field types. +-- See @Note [Instantiating field types in stock deriving]@ for a notable +-- example of this. +dataConInstUnivs :: DataCon -> [Type] -> [Type] +dataConInstUnivs dc dc_args = chkAppend dc_args $ map mkTyVarTy dc_args_suffix + where + (dc_univs_prefix, dc_univs_suffix) + = -- Assert that m <= n + assertPpr (dc_args `leLength` dataConUnivTyVars dc) + (text "dataConInstUnivs" + <+> ppr dc_args + <+> ppr (dataConUnivTyVars dc)) $ + splitAtList dc_args $ dataConUnivTyVars dc + (_, dc_args_suffix) = substTyVarBndrs prefix_subst dc_univs_suffix + prefix_subst = mkTvSubst prefix_in_scope prefix_env + prefix_in_scope = mkInScopeSet $ tyCoVarsOfTypes dc_args + prefix_env = zipTyEnv dc_univs_prefix dc_args + +-- | Returns the argument types of the wrapper, excluding all dictionary arguments +-- and without substituting for any type variables +dataConOrigArgTys :: DataCon -> [Scaled Type] +dataConOrigArgTys dc = dcOrigArgTys dc + +-- | Returns constraints in the wrapper type, other than those in the dataConEqSpec +dataConOtherTheta :: DataCon -> ThetaType +dataConOtherTheta dc = dcOtherTheta dc + +-- | Returns the arg types of the worker, including *all* non-dependent +-- evidence, after any flattening has been done and without substituting for +-- any type variables +dataConRepArgTys :: DataCon -> [Scaled Type] +dataConRepArgTys (MkData { dcRep = rep + , dcEqSpec = eq_spec + , dcOtherTheta = theta + , dcOrigArgTys = orig_arg_tys + , dcRepTyCon = tc }) + = case rep of + DCR { dcr_arg_tys = arg_tys } -> arg_tys + NoDataConRep + | isTypeDataTyCon tc -> assert (null theta) $ + orig_arg_tys + -- `type data` declarations can be GADTs (and hence have an eq_spec) + -- but no wrapper. They cannot have a theta. + -- See Note [Type data declarations] in GHC.Rename.Module + -- You might wonder why we ever call dataConRepArgTys for `type data`; + -- I think it's because of the call in mkDataCon, which in turn feeds + -- into dcRepArity, which in turn is used in mkDataConWorkId. + -- c.f. #23022 + | otherwise -> assert (null eq_spec) $ + map unrestricted theta ++ orig_arg_tys + +-- | The string @package:module.name@ identifying a constructor, which is attached +-- to its info table and used by the GHCi debugger and the heap profiler +dataConIdentity :: DataCon -> ByteString +-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. +dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat + [ BSB.shortByteString $ fastStringToShortByteString $ + unitFS $ moduleUnit mod + , BSB.int8 $ fromIntegral (ord ':') + , BSB.shortByteString $ fastStringToShortByteString $ + moduleNameFS $ moduleName mod + , BSB.int8 $ fromIntegral (ord '.') + , BSB.shortByteString $ fastStringToShortByteString $ + occNameFS $ nameOccName name + ] + where name = dataConName dc + mod = assert (isExternalName name) $ nameModule name + +isTupleDataCon :: DataCon -> Bool +isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc + +isBoxedTupleDataCon :: DataCon -> Bool +isBoxedTupleDataCon (MkData {dcRepTyCon = tc}) = isBoxedTupleTyCon tc + +isUnboxedTupleDataCon :: DataCon -> Bool +isUnboxedTupleDataCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc + +isUnboxedSumDataCon :: DataCon -> Bool +isUnboxedSumDataCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc + +-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors +isVanillaDataCon :: DataCon -> Bool +isVanillaDataCon dc = dcVanilla dc + +-- | Is this the 'DataCon' of a newtype? +isNewDataCon :: DataCon -> Bool +isNewDataCon dc = isNewTyCon (dataConTyCon dc) + +-- | Is this data constructor in a "type data" declaration? +-- See Note [Type data declarations] in GHC.Rename.Module. +isTypeDataCon :: DataCon -> Bool +isTypeDataCon dc = isTypeDataTyCon (dataConTyCon dc) + +isCovertGadtDataCon :: DataCon -> Bool +-- See Note [isCovertGadtDataCon] +isCovertGadtDataCon (MkData { dcUnivTyVars = univ_tvs + , dcEqSpec = eq_spec + , dcRepTyCon = rep_tc }) + = not (null eq_spec) -- There are some constraints + && not (any is_visible_spec eq_spec) -- But none of them are visible + where + visible_univ_tvs :: [TyVar] -- Visible arguments in result type + visible_univ_tvs + = [ univ_tv | (univ_tv, tcb) <- univ_tvs `zip` tyConBinders rep_tc + , isVisibleTyConBinder tcb ] + + is_visible_spec :: EqSpec -> Bool + is_visible_spec (EqSpec univ_tv ty) + = univ_tv `elem` visible_univ_tvs + && not (isTyVarTy ty) -- See Note [isCovertGadtDataCon] for + -- an example where 'ty' is a tyvar + +isUnaryClassDataCon :: DataCon -> Bool +isUnaryClassDataCon dc = isUnaryClassTyCon (dataConTyCon dc) + +{- Note [isCovertGadtDataCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(isCovertGadtDataCon K) returns True if K is a GADT data constructor, but +does not /look/ like it. It is used only to help in error message printing. + +Consider (#21447) + type T :: TYPE r -> Type + data T a where { MkT :: b -> T b } +Here MkT doesn't look GADT-like, but it is. If we make the kind applications +explicit we'd see: + data T a where { MkT :: b -> T @LiftedRep b } + +The test for covert-ness is bit tricky, because we want to see if + - dcEqSpec is non-empty + - dcEqSpec does not constrain any of the /required/ (i.e. visible) + arguments of the TyCon to a non-tyvar + +In the example above, the DataCon for MkT will have + dcUnivTyVars: [(r::RuntimeRep), (a :: TYPE r)] + dcExTyVars: [(b :: Type)] + dcEqSpec: [(r, LiftedRep), (a, b)] +Here + * `r :: RuntimeRep` is constrained by dcEqSpec to LiftedRep + * `a :: TYPE r` is constrained by dcEqSpec to `b :: Type` +But the constraint on `a` is not visible to the user, so this counts +as a covert GADT data con. The declaration + MkT :: forall (b :: Type). b -> T b +looks entirely non-GADT-ish. + +Wrinkles: +* The visibility or otherwise is a property of the /TyCon/ binders +* The dcUnivTyVars may or may not be the same as the TyCon binders +* So we have to zip them together. +* For a data family the TyCon in question is the /representation/ TyCon + hence dcRepTyCon +-} + + +-- | Should this DataCon be allowed in a type even without -XDataKinds? +-- Currently, only Lifted & Unlifted +specialPromotedDc :: DataCon -> Bool +specialPromotedDc = isKindTyCon . dataConTyCon + +classDataCon :: Class -> DataCon +classDataCon clas = case tyConDataCons (classTyCon clas) of + (dict_constr:no_more) -> assert (null no_more) dict_constr + [] -> panic "classDataCon" + +dataConCannotMatch :: [Type] -> DataCon -> Bool +-- Returns True iff the data con *definitely cannot* match a +-- scrutinee of type (T tys) +-- where T is the dcRepTyCon for the data con +dataConCannotMatch tys con + -- See (U6) in Note [Implementing unsafeCoerce] + -- in base:Unsafe.Coerce + | dataConName con == unsafeReflDataConName + = False + | null inst_theta = False -- Common + | all isTyVarTy tys = False -- Also common + | otherwise = typesCantMatch (concatMap predEqs inst_theta) + where + (_, inst_theta, _) = dataConInstSig con tys + + -- TODO: could gather equalities from superclasses too + predEqs pred = case classifyPredType pred of + EqPred NomEq ty1 ty2 -> [(ty1, ty2)] + ClassPred eq args + | eq `hasKey` eqTyConKey + , [_, ty1, ty2] <- args -> [(ty1, ty2)] + | eq `hasKey` heqTyConKey + , [_, _, ty1, ty2] <- args -> [(ty1, ty2)] + _ -> [] + +-- | Were the type variables of the data con written in a different order +-- than the regular order (universal tyvars followed by existential tyvars)? +-- +-- This is not a cheap test, so we minimize its use in GHC as much as possible. +-- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in +-- "MkId", and so 'dataConUserTyVarsNeedWrapper' is only called at most once +-- during a data constructor's lifetime. + +dataConResRepTyArgs :: DataCon -> [Type] +-- Returns the arguments of a GADT version of the /representation/ TyCon +-- Thus data instance T [(x,y)] z where +-- MkT :: forall p q. Int -> T [(Int,p)] (Maybe q) +-- The "GADT version of the representation type" is +-- data R:T x y z where +-- MkT :: forall p q. Int -> R:T Int p (Maybe q) +-- so dataConResRepTyArgs for MkT returns [Int, p, Maybe q] +-- This is almost the same as (subst eq_spec univ_tvs); but not quite, +-- because eq_spec omits constraint-kinded equalities +dataConResRepTyArgs dc@(MkData { dcRepTyCon = rep_tc, dcOrigResTy = orig_res_ty }) + | Just (fam_tc, fam_args) <- tyConFamInst_maybe rep_tc + = -- fvs(fam_args) = tyConTyVars rep_tc + -- These tyvars are the domain of subst + -- Fvs(range(subst)) = tvars of the datacon + case tcMatchTy (mkTyConApp fam_tc fam_args) orig_res_ty of + Just subst -> map (substTyVar subst) (tyConTyVars rep_tc) + Nothing -> pprPanic "datacOnResRepTyArgs" $ + vcat [ ppr dc, ppr fam_tc <+> ppr fam_args + , ppr orig_res_ty ] + | otherwise + = tyConAppArgs orig_res_ty + +checkDataConTyVars :: DataCon -> Bool +-- Check that the worker and wrapper have the same set of type variables +-- See Note [DataCon user type variable binders] +-- Also ensures that no user tyvar is in the eq_spec (the eq_spec should +-- only relate fresh universals from (R2) of the note) +checkDataConTyVars dc@(MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs + , dcEqSpec = eq_spec }) + -- use of sets here: (R1) from the Note + = mkUnVarSet depleted_worker_vars == mkUnVarSet wrapper_vars && + all (not . is_eq_spec_var) wrapper_vars + where + worker_vars = univ_tvs ++ ex_tvs + eq_spec_tvs = mkUnVarSet (map eqSpecTyVar eq_spec) + is_eq_spec_var = (`elemUnVarSet` eq_spec_tvs) -- (R2) from the Note + depleted_worker_vars = filterOut is_eq_spec_var worker_vars + + wrapper_vars = dataConUserTyVars dc + +dataConUserTyVarBindersNeedWrapper :: DataCon -> Bool +-- Check whether the worker and wrapper have the same type variables +-- in the same order and with the same visibility. If not, we need a +-- wrapper to swizzle them. +-- See Note [DataCon user type variable binders], as well as +-- Note [Data con wrappers and GADT syntax] for an explanation of what +-- mkDataConRep is doing with this function. +dataConUserTyVarBindersNeedWrapper (MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs + , dcUserTyVarBinders = user_tvbs + , dcEqSpec = eq_spec }) + = assert (null eq_spec || answer) -- all GADTs should say "yes" here + answer + where + answer = need_reorder || need_flag_cast + need_reorder = (univ_tvs ++ ex_tvs) /= binderVars user_tvbs + need_flag_cast = any (not . eqForAllVis coreTyLamForAllTyFlag) + (binderFlags user_tvbs) + -- See Note [Flag cast in data con wrappers] + +{- Note [Flag cast in data con wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the data declaration + + data G a where + MkG :: forall a -> a -> G a + +The user-facing type of MkG has a 'Required' forall. Workers, on the other hand, +always use 'Specified' foralls (coreTyLamForAllTyFlag). So we need a wrapper: + + wrapper type: forall a -> a -> G a + worker type: forall a. a -> G a + +Concretely, it looks like this: + + $WMkG = /\a. \(x:a). MkG a x |> co + +where 'co' is a coercion constructed by GHC.Core.Coercion.mkForAllVisCos. +The cast is added by the call to mkCoreTyLams in GHC.Types.Id.Make.mkDataConRep. + +In general, wrappers may use 'Inferred', 'Specified', or 'Required' foralls. +However, we do /not/ need a cast to convert 'Inferred' to 'Specified' because they are +'eqType'-equal. Only a 'Required' forall necessitates a cast in the wrapper. + +See Note [ForAllTy and type equality], Note [Comparing visibility], +and Note [Required foralls in Core]. +-} + +{- +%************************************************************************ +%* * + Promoting of data types to the kind level +* * +************************************************************************ + +-} + +promoteDataCon :: DataCon -> TyCon +promoteDataCon (MkData { dcPromoted = tc }) = tc + +{- +************************************************************************ +* * +\subsection{Splitting products} +* * +************************************************************************ +-} + +-- | Extract the type constructor, type argument, data constructor and it's +-- /representation/ argument types from a type if it is a product type. +-- +-- Precisely, we return @Just@ for any data type that is all of: +-- +-- * Concrete (i.e. constructors visible) +-- * Single-constructor +-- * ... which has no existentials +-- +-- Whether the type is a @data@ type or a @newtype@. +splitDataProductType_maybe + :: Type -- ^ A product type, perhaps + -> Maybe (TyCon, -- The type constructor + [Type], -- Type args of the tycon + DataCon, -- The data constructor + [Scaled Type]) -- Its /representation/ arg types + + -- Rejecting existentials means we don't have to worry about + -- freshening and substituting type variables + -- (See "GHC.Type.Id.Make.dataConArgUnpack") + +splitDataProductType_maybe ty + | Just (tycon, ty_args) <- splitTyConApp_maybe ty + , Just con <- tyConSingleDataCon_maybe tycon + , null (dataConExTyCoVars con) -- no existentials! See above + = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) + | otherwise + = Nothing diff --git a/GHC/Core/DataCon.hs-boot b/GHC/Core/DataCon.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/DataCon.hs-boot @@ -0,0 +1,39 @@ +module GHC.Core.DataCon where + +import GHC.Prelude +import {-# SOURCE #-} GHC.Types.Var( Id, TyVar, TyCoVar, TyVarBinder ) +import {-# SOURCE #-} GHC.Types.Name( Name, NamedThing ) +import {-# SOURCE #-} GHC.Core.TyCon( TyCon ) +import GHC.Types.FieldLabel ( FieldLabel ) +import GHC.Types.Unique ( Uniquable ) +import GHC.Utils.Outputable ( Outputable, OutputableBndr ) +import GHC.Types.Basic (Arity) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType, Scaled ) + +data DataCon +data DataConRep +data EqSpec + +dataConName :: DataCon -> Name +dataConWorkId :: DataCon -> Id +dataConTyCon :: DataCon -> TyCon +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] +dataConSourceArity :: DataCon -> Arity +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConInstOrigArgTys :: DataCon -> [Type] -> [Scaled Type] +dataConStupidTheta :: DataCon -> ThetaType +dataConFullSig :: DataCon + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type) +isUnboxedSumDataCon :: DataCon -> Bool +isTypeDataCon :: DataCon -> Bool + +instance Eq DataCon +instance Uniquable DataCon +instance NamedThing DataCon +instance Outputable DataCon +instance OutputableBndr DataCon + +dataConWrapId :: DataCon -> Id +promoteDataCon :: DataCon -> TyCon diff --git a/GHC/Core/FVs.hs b/GHC/Core/FVs.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/FVs.hs @@ -0,0 +1,763 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Taken quite directly from the Peyton Jones/Lester paper. +-} + +{-# LANGUAGE TypeFamilies #-} + +-- | A module concerned with finding the free variables of an expression. +module GHC.Core.FVs ( + -- * Free variables of expressions and binding groups + exprFreeVars, exprsFreeVars, + exprFreeVarsDSet, + exprFreeVarsList, exprsFreeVarsList, + exprFreeIds, exprsFreeIds, + exprFreeIdsDSet, exprsFreeIdsDSet, + exprFreeIdsList, exprsFreeIdsList, + bindFreeVars, + + -- * Selective free variables of expressions + InterestingVarFun, + exprSomeFreeVars, exprsSomeFreeVars, + exprSomeFreeVarsList, exprsSomeFreeVarsList, + + -- * Free variables of Rules, Vars and Ids + varTypeTyCoVars, + varTypeTyCoFVs, + idUnfoldingVars, idFreeVars, dIdFreeVars, + bndrRuleAndUnfoldingVarsDSet, + bndrRuleAndUnfoldingIds, + idFVs, + idRuleVars, stableUnfoldingVars, + ruleFreeVars, rulesFreeVars, + rulesFreeVarsDSet, mkRuleInfo, + ruleLhsFreeIds, ruleLhsFreeIdsList, + ruleRhsFreeVars, rulesRhsFreeIds, + + exprFVs, exprLocalFVs, addBndrFV, addBndrsFV, + + -- * Orphan names + orphNamesOfType, orphNamesOfTypes, orphNamesOfAxiomLHS, + orphNamesOfExprs, + + -- * Core syntax tree annotation with free variables + FVAnn, -- annotation, abstract + CoreExprWithFVs, -- = AnnExpr Id FVAnn + CoreExprWithFVs', -- = AnnExpr' Id FVAnn + CoreBindWithFVs, -- = AnnBind Id FVAnn + CoreAltWithFVs, -- = AnnAlt Id FVAnn + freeVars, -- CoreExpr -> CoreExprWithFVs + freeVarsBind, -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs) + freeVarsOf, -- CoreExprWithFVs -> DIdSet + freeVarsOfAnn + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name.Set +import GHC.Types.Name +import GHC.Types.Tickish +import GHC.Types.Var.Set +import GHC.Types.Var +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Builtin.Types( unrestrictedFunTyConName ) +import GHC.Builtin.Types.Prim( fUNTyCon ) +import GHC.Data.Maybe( orElse ) + +import GHC.Utils.FV as FV +import GHC.Utils.Misc +import GHC.Utils.Panic.Plain + +{- +************************************************************************ +* * +\section{Finding the free variables of an expression} +* * +************************************************************************ + +This function simply finds the free variables of an expression. +So far as type variables are concerned, it only finds tyvars that are + + * free in type arguments, + * free in the type of a binder, + +but not those that are free in the type of variable occurrence. +-} + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a non-deterministic set. +exprFreeVars :: CoreExpr -> VarSet +exprFreeVars = fvVarSet . exprLocalFVs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV" +-- for why export it. +exprLocalFVs :: CoreExpr -> FV +exprLocalFVs = filterFV isLocalVar . exprFVs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a deterministic set. +exprFreeVarsDSet :: CoreExpr -> DVarSet +exprFreeVarsDSet = fvDVarSet . exprLocalFVs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a deterministically ordered list. +exprFreeVarsList :: CoreExpr -> [Var] +exprFreeVarsList = fvVarList . exprLocalFVs + +-- | Find all locally-defined free Ids in an expression +exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids +exprFreeIds = exprSomeFreeVars isLocalId + +exprsFreeIds :: [CoreExpr] -> IdSet -- Find all locally-defined free Ids +exprsFreeIds = exprsSomeFreeVars isLocalId + +-- | Find all locally-defined free Ids in an expression +-- returning a deterministic set. +exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids +exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId + +-- | Find all locally-defined free Ids in an expression +-- returning a deterministically ordered list. +exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids +exprFreeIdsList = exprSomeFreeVarsList isLocalId + +-- | Find all locally-defined free Ids in several expressions +-- returning a deterministic set. +exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids +exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId + +-- | Find all locally-defined free Ids in several expressions +-- returning a deterministically ordered list. +exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids +exprsFreeIdsList = exprsSomeFreeVarsList isLocalId + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a non-deterministic set. +exprsFreeVars :: [CoreExpr] -> VarSet +exprsFreeVars = fvVarSet . exprsLocalFVs + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV" +-- for why export it. +exprsLocalFVs :: [CoreExpr] -> FV +exprsLocalFVs exprs = mapUnionFV exprLocalFVs exprs + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a deterministically ordered list. +exprsFreeVarsList :: [CoreExpr] -> [Var] +exprsFreeVarsList = fvVarList . exprsLocalFVs + +-- | Find all locally defined free Ids in a binding group +bindFreeVars :: CoreBind -> VarSet +bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r) +bindFreeVars (Rec prs) = fvVarSet $ filterFV isLocalVar $ + addBndrsFV (map fst prs) + (mapUnionFV rhs_fvs prs) + +-- | Finds free variables in an expression selected by a predicate +exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> VarSet +exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ exprFVs e + +-- | Finds free variables in an expression selected by a predicate +-- returning a deterministically ordered list. +exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> [Var] +exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ exprFVs e + +-- | Finds free variables in an expression selected by a predicate +-- returning a deterministic set. +exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> DVarSet +exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ exprFVs e + +-- | Finds free variables in several expressions selected by a predicate +exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting + -> [CoreExpr] + -> VarSet +exprsSomeFreeVars fv_cand es = fvVarSet $ filterFV fv_cand $ mapUnionFV exprFVs es + +-- | Finds free variables in several expressions selected by a predicate +-- returning a deterministically ordered list. +exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting + -> [CoreExpr] + -> [Var] +exprsSomeFreeVarsList fv_cand es = fvVarList $ filterFV fv_cand $ mapUnionFV exprFVs es + +-- | Finds free variables in several expressions selected by a predicate +-- returning a deterministic set. +exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> [CoreExpr] + -> DVarSet +exprsSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ mapUnionFV exprFVs e + +-- Comment about obsolete code +-- We used to gather the free variables the RULES at a variable occurrence +-- with the following cryptic comment: +-- "At a variable occurrence, add in any free variables of its rule rhss +-- Curiously, we gather the Id's free *type* variables from its binding +-- site, but its free *rule-rhs* variables from its usage sites. This +-- is a little weird. The reason is that the former is more efficient, +-- but the latter is more fine grained, and a makes a difference when +-- a variable mentions itself one of its own rule RHSs" +-- Not only is this "weird", but it's also pretty bad because it can make +-- a function seem more recursive than it is. Suppose +-- f = ...g... +-- g = ... +-- RULE g x = ...f... +-- Then f is not mentioned in its own RHS, and needn't be a loop breaker +-- (though g may be). But if we collect the rule fvs from g's occurrence, +-- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB +-- code in GHC.Enum.) +-- +-- Anyway, it seems plain wrong. The RULE is like an extra RHS for the +-- function, so its free variables belong at the definition site. +-- +-- Deleted code looked like +-- foldVarSet add_rule_var var_itself_set (idRuleVars var) +-- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var +-- | otherwise = set +-- SLPJ Feb06 + +addBndrFV :: CoreBndr -> FV -> FV +addBndrFV bndr fv fv_cand in_scope acc + = (varTypeTyCoFVs bndr `unionFV` + -- Include type variables in the binder's type + -- (not just Ids; coercion variables too!) + FV.delFV bndr fv) fv_cand in_scope acc + +addBndrsFV :: [CoreBndr] -> FV -> FV +addBndrsFV bndrs fv = foldr addBndrFV fv bndrs + +exprsFVs :: [CoreExpr] -> FV +exprsFVs exprs = mapUnionFV exprFVs exprs + +exprFVs :: CoreExpr -> FV +exprFVs (Type ty) fv_cand in_scope acc = + tyCoFVsOfType ty fv_cand in_scope acc +exprFVs (Coercion co) fv_cand in_scope acc = + tyCoFVsOfCo co fv_cand in_scope acc +exprFVs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc +exprFVs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc +exprFVs (Tick t expr) fv_cand in_scope acc = + (tickish_fvs t `unionFV` exprFVs expr) fv_cand in_scope acc +exprFVs (App fun arg) fv_cand in_scope acc = + (exprFVs fun `unionFV` exprFVs arg) fv_cand in_scope acc +exprFVs (Lam bndr body) fv_cand in_scope acc = + addBndrFV bndr (exprFVs body) fv_cand in_scope acc +exprFVs (Cast expr co) fv_cand in_scope acc = + (exprFVs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc + +exprFVs (Case scrut bndr ty alts) fv_cand in_scope acc + = (exprFVs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndrFV bndr + (mapUnionFV alt_fvs alts)) fv_cand in_scope acc + where + alt_fvs (Alt _ bndrs rhs) = addBndrsFV bndrs (exprFVs rhs) + +exprFVs (Let (NonRec bndr rhs) body) fv_cand in_scope acc + = (rhs_fvs (bndr, rhs) `unionFV` addBndrFV bndr (exprFVs body)) + fv_cand in_scope acc + +exprFVs (Let (Rec pairs) body) fv_cand in_scope acc + = addBndrsFV (map fst pairs) + (mapUnionFV rhs_fvs pairs `unionFV` exprFVs body) + fv_cand in_scope acc + +--------- +rhs_fvs :: (Id, CoreExpr) -> FV +rhs_fvs (bndr, rhs) = exprFVs rhs `unionFV` + bndrRuleAndUnfoldingFVs bndr + -- Treat any RULES as extra RHSs of the binding + +--------- +tickish_fvs :: CoreTickish -> FV +tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids +tickish_fvs _ = emptyFV + +{- ********************************************************************** +%* * + Orphan names +%* * +%********************************************************************* -} + +{- Note [Finding orphan names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions here (orphNamesOfType, orphNamesOfExpr etc) traverse a template: + * the head of an class instance decl + * the LHS of a type-family instance + * the arguments of a RULE +to find TyCons or (in the case of a RULE) Ids, that will be matched against when +matching the template. If none of these orphNames are locally defined, the instance +or RULE is an orphan: see Note [Orphans] in GHC.Core + +Wrinkles: + (ON1) We do not need to look inside coercions, because we never match against + them. Indeed, it'd be wrong to do so, because it could make an instance + into a non-orphan, when it really is an orphan. + + (ON2) These orphNames functions are also (rather separately) used by GHCi, to + implement :info. When you say ":info Foo", we show all the instances that + involve `Foo`; that is, all the instances whose oprhNames include `Foo`. + + To support `:info (->)` we need to ensure that (->) is treated as an orphName + of FunTy, which is a bit messy since the "real" TyCon is `FUN` +-} + +orphNamesOfTyCon :: TyCon -> NameSet +orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of + Nothing -> emptyNameSet + Just cls -> unitNameSet (getName cls) + +orphNamesOfType :: Type -> NameSet +orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty' + -- Look through type synonyms (#4912) +orphNamesOfType (TyVarTy _) = emptyNameSet +orphNamesOfType (LitTy {}) = emptyNameSet +orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) + `unionNameSet` orphNamesOfType res +orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg + +orphNamesOfType (TyConApp tycon tys) = func + `unionNameSet` orphNamesOfTyCon tycon + `unionNameSet` orphNamesOfTypes tys + where func = case tys of + arg:_ | tycon == fUNTyCon -> orph_names_of_fun_ty_con arg + _ -> emptyNameSet + +orphNamesOfType (FunTy af w arg res) = func + `unionNameSet` unitNameSet fun_tc + `unionNameSet` orphNamesOfType w + `unionNameSet` orphNamesOfType arg + `unionNameSet` orphNamesOfType res + where func | isVisibleFunArg af = orph_names_of_fun_ty_con w + | otherwise = emptyNameSet + + fun_tc = tyConName (funTyFlagTyCon af) + +-- Coercions: see wrinkle (ON1) of Note [Finding orphan names] +orphNamesOfType (CastTy ty _co) = orphNamesOfType ty +orphNamesOfType (CoercionTy _co) = emptyNameSet + +orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet +orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet + +orphNamesOfTypes :: [Type] -> NameSet +orphNamesOfTypes = orphNamesOfThings orphNamesOfType + +-- | `orphNamesOfAxiomLHS` collects the names of the concrete types and +-- type constructors that make up the LHS of a type family instance, +-- including the family name itself. +-- +-- For instance, given `type family Foo a b`: +-- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H] +-- +-- Used (via orphNamesOfFamInst) in the implementation of ":info" in GHCi. +-- and when determining orphan-hood for a FamInst or module +orphNamesOfAxiomLHS :: CoAxiom br -> NameSet +orphNamesOfAxiomLHS axiom + = (orphNamesOfTypes $ concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) + `extendNameSet` getName (coAxiomTyCon axiom) + +-- Detect (FUN 'Many) as an application of (->), so that :i (->) works as expected +-- (see #8535) Issue #16475 describes a more robust solution +-- See wrinkle (ON2) of Note [Finding orphan names] +orph_names_of_fun_ty_con :: Mult -> NameSet +orph_names_of_fun_ty_con ManyTy = unitNameSet unrestrictedFunTyConName +orph_names_of_fun_ty_con _ = emptyNameSet + +-- | Finds the free /external/ names of an expression, notably +-- including the names of type constructors (which of course do not show +-- up in 'exprFreeVars'). +orphNamesOfExpr :: CoreExpr -> NameSet +-- There's no need to delete local binders, because they will all +-- be /internal/ names. +orphNamesOfExpr e + = go e + where + go (Var v) + | isExternalName n = unitNameSet n + | otherwise = emptyNameSet + where n = idName v + go (Lit _) = emptyNameSet + go (Type ty) = orphNamesOfType ty -- Don't need free tyvars + go (Coercion _co) = emptyNameSet -- See wrinkle (ON1) of Note [Finding orphan names] + go (App e1 e2) = go e1 `unionNameSet` go e2 + go (Lam v e) = go e `delFromNameSet` idName v + go (Tick _ e) = go e + go (Cast e _co) = go e -- See wrinkle (ON1) of Note [Finding orphan names] + go (Let (NonRec _ r) e) = go e `unionNameSet` go r + go (Let (Rec prs) e) = orphNamesOfExprs (map snd prs) `unionNameSet` go e + go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty + `unionNameSet` unionNameSets (map go_alt as) + + go_alt (Alt _ _ r) = go r + +-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details +orphNamesOfExprs :: [CoreExpr] -> NameSet +orphNamesOfExprs es = foldr (unionNameSet . orphNamesOfExpr) emptyNameSet es + + +{- +************************************************************************ +* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +* * +************************************************************************ +-} + +data RuleFVsFrom + = LhsOnly + | RhsOnly + | BothSides + +-- | Those locally-defined variables free in the left and/or right hand sides +-- of the rule, depending on the first argument. Returns an 'FV' computation. +ruleFVs :: RuleFVsFrom -> CoreRule -> FV +ruleFVs !_ (BuiltinRule {}) = emptyFV +ruleFVs from (Rule { ru_fn = _do_not_include + -- See Note [Rule free var hack] + , ru_bndrs = bndrs + , ru_rhs = rhs, ru_args = args }) + = filterFV isLocalVar $ addBndrsFV bndrs (exprsFVs exprs) + where + exprs = case from of + LhsOnly -> args + RhsOnly -> [rhs] + BothSides -> rhs:args + +-- | Those locally-defined variables free in the left and/or right hand sides +-- from several rules, depending on the first argument. +-- Returns an 'FV' computation. +rulesFVs :: RuleFVsFrom -> [CoreRule] -> FV +rulesFVs from = mapUnionFV (ruleFVs from) + +-- | Those variables free in the right hand side of a rule returned as a +-- non-deterministic set +ruleRhsFreeVars :: CoreRule -> VarSet +ruleRhsFreeVars = fvVarSet . ruleFVs RhsOnly + +-- | Those locally-defined free 'Id's in the right hand side of several rules +-- returned as a non-deterministic set +rulesRhsFreeIds :: [CoreRule] -> VarSet +rulesRhsFreeIds = fvVarSet . filterFV isLocalId . rulesFVs RhsOnly + +ruleLhsFreeIds :: CoreRule -> VarSet +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns them as a non-deterministic set +ruleLhsFreeIds = fvVarSet . filterFV isLocalId . ruleFVs LhsOnly + +ruleLhsFreeIdsList :: CoreRule -> [Var] +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns them as a deterministically ordered list +ruleLhsFreeIdsList = fvVarList . filterFV isLocalId . ruleFVs LhsOnly + +-- | Those variables free in the both the left right hand sides of a rule +-- returned as a non-deterministic set +ruleFreeVars :: CoreRule -> VarSet +ruleFreeVars = fvVarSet . ruleFVs BothSides + +-- | Those variables free in the both the left right hand sides of rules +-- returned as a deterministic set +rulesFreeVarsDSet :: [CoreRule] -> DVarSet +rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs BothSides rules + +-- | Those variables free in both the left right hand sides of several rules +rulesFreeVars :: [CoreRule] -> VarSet +rulesFreeVars rules = fvVarSet $ rulesFVs BothSides rules + +-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable +-- for putting into an 'IdInfo' +mkRuleInfo :: [CoreRule] -> RuleInfo +mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) + +{- +Note [Rule free var hack] (Not a hack any more) +~~~~~~~~~~~~~~~~~~~~~~~~~ +We used not to include the Id in its own rhs free-var set. +Otherwise the occurrence analyser makes bindings recursive: + f x y = x+y + RULE: f (f x y) z ==> f x (f y z) +However, the occurrence analyser distinguishes "non-rule loop breakers" +from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will +put this 'f' in a Rec block, but will mark the binding as a non-rule loop +breaker, which is perfectly inlinable. +-} + +{- +************************************************************************ +* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +* * +************************************************************************ + +The free variable pass annotates every node in the expression with its +NON-GLOBAL free variables and type variables. +-} + +type FVAnn = DVarSet -- See Note [The FVAnn invariant] + +{- Note [The FVAnn invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant: a FVAnn, say S, is closed: + That is: if v is in S, + then freevars( v's type/kind ) is also in S +-} + +-- | Every node in a binding group annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +type CoreBindWithFVs = AnnBind Id FVAnn + +-- | Every node in an expression annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +-- NB: see Note [The FVAnn invariant] +type CoreExprWithFVs = AnnExpr Id FVAnn +type CoreExprWithFVs' = AnnExpr' Id FVAnn + +-- | Every node in an expression annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +type CoreAltWithFVs = AnnAlt Id FVAnn + +freeVarsOf :: CoreExprWithFVs -> DIdSet +-- ^ Inverse function to 'freeVars' +freeVarsOf (fvs, _) = fvs + +-- | Extract the vars reported in a FVAnn +freeVarsOfAnn :: FVAnn -> DIdSet +freeVarsOfAnn fvs = fvs + +aFreeVar :: Var -> DVarSet +aFreeVar = unitDVarSet + +unionFVs :: DVarSet -> DVarSet -> DVarSet +unionFVs = unionDVarSet + +unionFVss :: [DVarSet] -> DVarSet +unionFVss = unionDVarSets + +delBindersFV :: [Var] -> DVarSet -> DVarSet +delBindersFV bs fvs = foldr delBinderFV fvs bs + +delBinderFV :: Var -> DVarSet -> DVarSet +-- This way round, so we can do it multiple times using foldr + +-- (b `delBinderFV` s) +-- * removes the binder b from the free variable set s, +-- * AND *adds* to s the free variables of b's type +-- +-- This is really important for some lambdas: +-- In (\x::a -> x) the only mention of "a" is in the binder. +-- +-- Also in +-- let x::a = b in ... +-- we should really note that "a" is free in this expression. +-- It'll be pinned inside the /\a by the binding for b, but +-- it seems cleaner to make sure that a is in the free-var set +-- when it is mentioned. +-- +-- This also shows up in recursive bindings. Consider: +-- /\a -> letrec x::a = x in E +-- Now, there are no explicit free type variables in the RHS of x, +-- but nevertheless "a" is free in its definition. So we add in +-- the free tyvars of the types of the binders, and include these in the +-- free vars of the group, attached to the top level of each RHS. +-- +-- This actually happened in the defn of errorIO in IOBase.hs: +-- errorIO (ST io) = case (errorIO# io) of +-- _ -> bottom +-- where +-- bottom = bottom -- Never evaluated + +delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b + -- Include coercion variables too! + +varTypeTyCoVars :: Var -> TyCoVarSet +-- Find the type/kind variables free in the type of the id/tyvar +varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var + +dVarTypeTyCoVars :: Var -> DTyCoVarSet +-- Find the type/kind/coercion variables free in the type of the id/tyvar +dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var + +varTypeTyCoFVs :: Var -> FV +-- Find the free variables of a binder. +-- In the case of ids, don't forget the multiplicity field! +varTypeTyCoFVs var + = tyCoFVsOfType (varType var) `unionFV` mult_fvs + where + mult_fvs = case varMultMaybe var of + Just mult -> tyCoFVsOfType mult + Nothing -> emptyFV + +idFreeVars :: Id -> VarSet +idFreeVars id = assert (isId id) $ fvVarSet $ idFVs id + +dIdFreeVars :: Id -> DVarSet +dIdFreeVars id = fvDVarSet $ idFVs id + +idFVs :: Id -> FV +-- Type variables, rule variables, and inline variables +idFVs id = assert (isId id) $ + varTypeTyCoFVs id `unionFV` + bndrRuleAndUnfoldingFVs id + +bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet +bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id + +bndrRuleAndUnfoldingIds :: Id -> IdSet +bndrRuleAndUnfoldingIds id = fvVarSet $ filterFV isId $ bndrRuleAndUnfoldingFVs id + +bndrRuleAndUnfoldingFVs :: Id -> FV +bndrRuleAndUnfoldingFVs id + | isId id = idRuleFVs id `unionFV` idUnfoldingFVs id + | otherwise = emptyFV + +idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars +idRuleVars id = fvVarSet $ idRuleFVs id + +idRuleFVs :: Id -> FV +idRuleFVs id = assert (isId id) $ + FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id)) + +idUnfoldingVars :: Id -> VarSet +-- Produce free vars for an unfolding, but NOT for an ordinary +-- (non-inline) unfolding, since it is a dup of the rhs +-- and we'll get exponential behaviour if we look at both unf and rhs! +-- But do look at the *real* unfolding, even for loop breakers, else +-- we might get out-of-scope variables +idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id + +idUnfoldingFVs :: Id -> FV +idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV + +stableUnfoldingVars :: Unfolding -> Maybe VarSet +stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf + +stableUnfoldingFVs :: Unfolding -> Maybe FV +stableUnfoldingFVs unf + = case unf of + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | isStableSource src + -> Just (exprLocalFVs rhs) + DFunUnfolding { df_bndrs = bndrs, df_args = args } + -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprsFVs args) + -- DFuns are top level, so no fvs from types of bndrs + _other -> Nothing + + +{- +************************************************************************ +* * +\subsection{Free variables (and types)} +* * +************************************************************************ +-} + +freeVarsBind :: CoreBind + -> DVarSet -- Free vars of scope of binding + -> (CoreBindWithFVs, DVarSet) -- Return free vars of binding + scope +freeVarsBind (NonRec binder rhs) body_fvs + = ( AnnNonRec binder rhs2 + , freeVarsOf rhs2 `unionFVs` body_fvs2 + `unionFVs` bndrRuleAndUnfoldingVarsDSet binder ) + where + rhs2 = freeVars rhs + body_fvs2 = binder `delBinderFV` body_fvs + +freeVarsBind (Rec binds) body_fvs + = ( AnnRec (binders `zip` rhss2) + , delBindersFV binders all_fvs ) + where + (binders, rhss) = unzip binds + rhss2 = map freeVars rhss + rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 + binders_fvs = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders + -- See Note [The FVAnn invariant] + all_fvs = rhs_body_fvs `unionFVs` binders_fvs + -- The "delBinderFV" happens after adding the idSpecVars, + -- since the latter may add some of the binders as fvs + +freeVars :: CoreExpr -> CoreExprWithFVs +-- ^ Annotate a 'CoreExpr' with its (non-global) free type +-- and value variables at every tree node. +freeVars = go + where + go :: CoreExpr -> CoreExprWithFVs + go (Var v) + | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs `unionFVs` mult_vars, AnnVar v) + | otherwise = (emptyDVarSet, AnnVar v) + where + mult_vars = tyCoVarsOfTypeDSet (idMult v) + ty_fvs = dVarTypeTyCoVars v + -- See Note [The FVAnn invariant] + + go (Lit lit) = (emptyDVarSet, AnnLit lit) + go (Lam b body) + = ( b_fvs `unionFVs` (b `delBinderFV` body_fvs) + , AnnLam b body' ) + where + body'@(body_fvs, _) = go body + b_ty = idType b + b_fvs = tyCoVarsOfTypeDSet b_ty + -- See Note [The FVAnn invariant] + + go (App fun arg) + = ( freeVarsOf fun' `unionFVs` freeVarsOf arg' + , AnnApp fun' arg' ) + where + fun' = go fun + arg' = go arg + + go (Case scrut bndr ty alts) + = ( (bndr `delBinderFV` alts_fvs) + `unionFVs` freeVarsOf scrut2 + `unionFVs` tyCoVarsOfTypeDSet ty + -- Don't need to look at (idType bndr) + -- because that's redundant with scrut + , AnnCase scrut2 bndr ty alts2 ) + where + scrut2 = go scrut + + (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts + alts_fvs = unionFVss alts_fvs_s + + fv_alt (Alt con args rhs) = (delBindersFV args (freeVarsOf rhs2), + (AnnAlt con args rhs2)) + where + rhs2 = go rhs + + go (Let bind body) + = (bind_fvs, AnnLet bind2 body2) + where + (bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2) + body2 = go body + + go (Cast expr co) + = ( freeVarsOf expr2 `unionFVs` cfvs + , AnnCast expr2 (cfvs, co) ) + where + expr2 = go expr + cfvs = tyCoVarsOfCoDSet co + + go (Tick tickish expr) + = ( tickishFVs tickish `unionFVs` freeVarsOf expr2 + , AnnTick tickish expr2 ) + where + expr2 = go expr + tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids + tickishFVs _ = emptyDVarSet + + go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) + go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) diff --git a/GHC/Core/FamInstEnv.hs b/GHC/Core/FamInstEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/FamInstEnv.hs @@ -0,0 +1,1607 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- (c) The University of Glasgow 2006 +-- +-- FamInstEnv: Type checked family instance declarations + +module GHC.Core.FamInstEnv ( + FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, + famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, + pprFamInst, pprFamInsts, orphNamesOfFamInst, + mkImportedFamInst, mkLocalFamInst, + + FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, + unionFamInstEnv, extendFamInstEnv, extendFamInstEnvList, + famInstEnvElts, famInstEnvSize, familyInstances, familyNameInstances, + + -- * CoAxioms + mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, + mkNewTypeCoAxiom, + + FamInstMatch(..), + lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, + + isDominatedBy, apartnessCheck, compatibleBranches, + + -- Injectivity + InjectivityCheckResult(..), + lookupFamInstEnvInjectivityConflicts, injectiveBranches, + + -- Normalisation + topNormaliseType, topNormaliseType_maybe, + normaliseType, normaliseTcApp, + topReduceTyFamApp_maybe, reduceTyFamApp_maybe + ) where + +import GHC.Prelude + +import GHC.Core( IsOrphan, chooseOrphanAnchor ) +import GHC.Core.Unify +import GHC.Core.Type as Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Tidy +import GHC.Core.TyCo.Compare( eqType, eqTypes ) +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import GHC.Core.Reduction +import GHC.Core.RoughMap +import GHC.Core.FVs( orphNamesOfAxiomLHS ) + +import GHC.Builtin.Types.Literals( tryMatchFam ) + +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name +import GHC.Types.Var +import GHC.Types.SrcLoc +import GHC.Types.Name.Set + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.Bag +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf + +import Control.Monad +import Data.List( mapAccumL ) +import Data.Array( Array, assocs ) + +{- +************************************************************************ +* * + Type checked family instance heads +* * +************************************************************************ + +Note [FamInsts and CoAxioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* CoAxioms and FamInsts are just like + DFunIds and ClsInsts + +* A CoAxiom is a System-FC thing: it can relate any two types + +* A FamInst is a Haskell source-language thing, corresponding + to a type/data family instance declaration. + - The FamInst contains a CoAxiom, which is the evidence + for the instance + + - The LHS of the CoAxiom is always of form F ty1 .. tyn + where F is a type family +-} + +data FamInst -- See Note [FamInsts and CoAxioms] + = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom + -- introduced by this family + -- instance + -- INVARIANT: apart from freshening (see below) + -- fi_tvs = cab_tvs of the (single) axiom branch + -- fi_cvs = cab_cvs ...ditto... + -- fi_tys = cab_lhs ...ditto... + -- fi_rhs = cab_rhs ...ditto... + + , fi_flavor :: FamFlavor + + -- Everything below here is a redundant, + -- cached version of the two things above + -- except that the TyVars are freshened + , fi_fam :: Name -- Family name + + -- Used for "rough matching"; same idea as for class instances + -- See Note [Rough matching in class and family instances] + -- in GHC.Core.Unify + , fi_tcs :: [RoughMatchTc] -- Top of type args + -- INVARIANT: fi_tcs = roughMatchTcs fi_tys + + -- Used for "proper matching"; ditto + , fi_tvs :: [TyVar] -- Template tyvars for full match + , fi_cvs :: [CoVar] -- Template covars for full match + -- Like ClsInsts, these variables are always fresh + -- See Note [Template tyvars are fresh] in GHC.Core.InstEnv + + , fi_tys :: [Type] -- The LHS type patterns + -- May be eta-reduced; see Note [Eta reduction for data families] + -- in GHC.Core.Coercion.Axiom + + , fi_rhs :: Type -- the RHS, with its freshened vars + + , fi_orphan :: IsOrphan + } + +data FamFlavor + = SynFamilyInst -- A synonym family + | DataFamilyInst TyCon -- A data family, with its representation TyCon + +{- +Note [Arity of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Data family instances might legitimately be over- or under-saturated. + +Under-saturation has two potential causes: + U1) Eta reduction. See Note [Eta reduction for data families] in + GHC.Core.Coercion.Axiom. + U2) When the user has specified a return kind instead of written out patterns. + Example: + + data family Sing (a :: k) + data instance Sing :: Bool -> Type + + The data family tycon Sing has an arity of 2, the k and the a. But + the data instance has only one pattern, Bool (standing in for k). + This instance is equivalent to `data instance Sing (a :: Bool)`, but + without the last pattern, we have an under-saturated data family instance. + On its own, this example is not compelling enough to add support for + under-saturation, but U1 makes this feature more compelling. + +Over-saturation is also possible: + O1) If the data family's return kind is a type variable (see also #12369), + an instance might legitimately have more arguments than the family. + Example: + + data family Fix :: (Type -> k) -> k + data instance Fix f = MkFix1 (f (Fix f)) + data instance Fix f x = MkFix2 (f (Fix f x) x) + + In the first instance here, the k in the data family kind is chosen to + be Type. In the second, it's (Type -> Type). + + However, we require that any over-saturation is eta-reducible. That is, + we require that any extra patterns be bare unrepeated type variables; + see Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. + Accordingly, the FamInst is never over-saturated. + +Why can we allow such flexibility for data families but not for type families? +Because data families can be decomposed -- that is, they are generative and +injective. A Type family is neither and so always must be applied to all its +arguments. +-} + +-- Obtain the axiom of a family instance +famInstAxiom :: FamInst -> CoAxiom Unbranched +famInstAxiom = fi_axiom + +-- Split the left-hand side of the FamInst +famInstSplitLHS :: FamInst -> (TyCon, [Type]) +famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) + = (coAxiomTyCon axiom, lhs) + +-- Get the RHS of the FamInst +famInstRHS :: FamInst -> Type +famInstRHS = fi_rhs + +-- Get the family TyCon of the FamInst +famInstTyCon :: FamInst -> TyCon +famInstTyCon = coAxiomTyCon . famInstAxiom + +-- Return the representation TyCons introduced by data family instances, if any +famInstsRepTyCons :: [FamInst] -> [TyCon] +famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] + +-- Extracts the TyCon for this *data* (or newtype) instance +famInstRepTyCon_maybe :: FamInst -> Maybe TyCon +famInstRepTyCon_maybe fi + = case fi_flavor fi of + DataFamilyInst tycon -> Just tycon + SynFamilyInst -> Nothing + +dataFamInstRepTyCon :: FamInst -> TyCon +dataFamInstRepTyCon fi + = case fi_flavor fi of + DataFamilyInst tycon -> tycon + SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) + +orphNamesOfFamInst :: FamInst -> NameSet +orphNamesOfFamInst (FamInst { fi_axiom = ax }) = orphNamesOfAxiomLHS ax + + +{- +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +instance NamedThing FamInst where + getName = coAxiomName . fi_axiom + +instance Outputable FamInst where + ppr = pprFamInst + +pprFamInst :: FamInst -> SDoc +-- Prints the FamInst as a family instance declaration +-- NB: This function, FamInstEnv.pprFamInst, is used only for internal, +-- debug printing. See GHC.Types.TyThing.Ppr.pprFamInst for printing for the user +pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax + , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs }) + = hang (ppr_tc_sort <+> text "instance" + <+> pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)) + 2 (whenPprDebug debug_stuff) + where + ppr_tc_sort = case flavor of + SynFamilyInst -> text "type" + DataFamilyInst tycon + | isBoxedDataTyCon tycon -> text "data" + | isNewTyCon tycon -> text "newtype" + | isAbstractTyCon tycon -> text "data" + | otherwise -> text "WEIRD" <+> ppr tycon + + debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax + , text "Tvs:" <+> ppr tvs + , text "LHS:" <+> ppr tys + , text "RHS:" <+> ppr rhs ] + +pprFamInsts :: [FamInst] -> SDoc +pprFamInsts finsts = vcat (map pprFamInst finsts) + +{- ********************************************************************* +* * + Making FamInsts +* * +********************************************************************* -} + +mkLocalFamInst :: FamFlavor -> CoAxiom Unbranched + -> [TyVar] -> [CoVar] -> [Type] -> Type + -> FamInst +mkLocalFamInst flavor axiom tvs cvs lhs rhs + = FamInst { fi_fam = fam_tc_name + , fi_flavor = flavor + , fi_tcs = roughMatchTcs lhs + , fi_tvs = tvs + , fi_cvs = cvs + , fi_tys = lhs + , fi_rhs = rhs + , fi_axiom = axiom + , fi_orphan = chooseOrphanAnchor orph_names } + where + mod = assert (isExternalName (coAxiomName axiom)) $ + nameModule (coAxiomName axiom) + is_local name = nameIsLocalOrFrom mod name + + orph_names = filterNameSet is_local $ + orphNamesOfAxiomLHS axiom `extendNameSet` fam_tc_name + + fam_tc_name = tyConName (coAxiomTyCon axiom) + + +{- +Note [Lazy axiom match] +~~~~~~~~~~~~~~~~~~~~~~~ +It is Vitally Important that mkImportedFamInst is *lazy* in its axiom +parameter. The axiom is loaded lazily, via a forkM, in GHC.IfaceToCore. Sometime +later, mkImportedFamInst is called using that axiom. However, the axiom +may itself depend on entities which are not yet loaded as of the time +of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the +axiom, a dependency loop spontaneously appears and GHC hangs. The solution +is simply for mkImportedFamInst never, ever to look inside of the axiom +until everything else is good and ready to do so. We can assume that this +readiness has been achieved when some other code pulls on the axiom in the +FamInst. Thus, we pattern match on the axiom lazily (in the where clause, +not in the parameter list) and we assert the consistency of names there +also. +-} + +-- Make a family instance representation from the information found in an +-- interface file. In particular, we get the rough match info from the iface +-- (instead of computing it here). +mkImportedFamInst :: Name -- Name of the family + -> [RoughMatchTc] -- Rough match info + -> CoAxiom Unbranched -- Axiom introduced + -> IsOrphan + -> FamInst -- Resulting family instance +mkImportedFamInst fam mb_tcs axiom orphan + = FamInst { + fi_fam = fam, + fi_tcs = mb_tcs, + fi_tvs = tvs, + fi_cvs = cvs, + fi_tys = tys, + fi_rhs = rhs, + fi_axiom = axiom, + fi_flavor = flavor, + fi_orphan = orphan } + where + -- See Note [Lazy axiom match] + ~(CoAxBranch { cab_lhs = tys + , cab_tvs = tvs + , cab_cvs = cvs + , cab_rhs = rhs }) = coAxiomSingleBranch axiom + + -- Derive the flavor for an imported FamInst rather disgustingly + -- Maybe we should store it in the IfaceFamInst? + flavor = case splitTyConApp_maybe rhs of + Just (tc, _) + | Just ax' <- tyConFamilyCoercion_maybe tc + , ax' == axiom + -> DataFamilyInst tc + _ -> SynFamilyInst + +{- +************************************************************************ +* * + FamInstEnv +* * +************************************************************************ + +Note [FamInstEnv] +~~~~~~~~~~~~~~~~~ +A FamInstEnv is a RoughMap of instance heads. Specifically, the keys are formed +by the family name and the instance arguments. That is, an instance: + + type instance Fam (Maybe Int) a + +would insert into the instance environment an instance with a key of the form + + [RM_KnownTc Fam, RM_KnownTc Maybe, RM_WildCard] + +See Note [RoughMap] in GHC.Core.RoughMap. + + +The same FamInstEnv includes both 'data family' and 'type family' instances. +Type families are reduced during type inference, but not data families; +the user explains when to use a data family instance by using constructors +and pattern matching. + +Nevertheless it is still useful to have data families in the FamInstEnv: + + - For finding overlaps and conflicts + + - For finding the representation type...see FamInstEnv.topNormaliseType + and its call site in GHC.Core.Opt.Simplify.Iteration + + - In standalone deriving instance Eq (T [Int]) we need to find the + representation type for T [Int] + +Note [Varying number of patterns for data family axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For data families, the number of patterns may vary between instances. +For example + data family T a b + data instance T Int a = T1 a | T2 + data instance T Bool [a] = T3 a + +Then we get a data type for each instance, and an axiom: + data TInt a = T1 a | T2 + data TBoolList a = T3 a + + axiom ax7 :: T Int ~ TInt -- Eta-reduced + axiom ax8 a :: T Bool [a] ~ TBoolList a + +These two axioms for T, one with one pattern, one with two; +see Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + +Note [FamInstEnv determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We turn FamInstEnvs into a list in some places that don't directly affect +the ABI. That happens in family consistency checks and when producing output +for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard +to tell what it affects without following a chain of functions. It's also +easy to accidentally make that nondeterminism affect the ABI. Furthermore +the envs should be relatively small, so it should be free to use deterministic +maps here. Testing with nofib and validate detected no difference between +UniqFM and UniqDFM. +See Note [Deterministic UniqFM]. +-} + +type FamInstEnvs = (FamInstEnv, FamInstEnv) + -- External package inst-env, Home-package inst-env + +data FamInstEnv + = FamIE !Int -- The number of instances, used to choose the smaller environment + -- when checking type family consistency of home modules. + !(RoughMap FamInst) + -- See Note [FamInstEnv] + -- See Note [FamInstEnv determinism] + + +instance Outputable FamInstEnv where + ppr (FamIE _ fs) = text "FamIE" <+> vcat (map ppr $ elemsRM fs) + +famInstEnvSize :: FamInstEnv -> Int +famInstEnvSize (FamIE sz _) = sz + +-- | Create a 'FamInstEnv' from 'Name' indices. +-- INVARIANTS: +-- * The fs_tvs are distinct in each FamInst +-- of a range value of the map (so we can safely unify them) + +emptyFamInstEnvs :: (FamInstEnv, FamInstEnv) +emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) + +emptyFamInstEnv :: FamInstEnv +emptyFamInstEnv = FamIE 0 emptyRM + +famInstEnvElts :: FamInstEnv -> [FamInst] +famInstEnvElts (FamIE _ rm) = elemsRM rm + -- See Note [FamInstEnv determinism] + + -- It's OK to use nonDetStrictFoldUDFM here since we're just computing the + -- size. + +familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] +familyInstances envs tc + = familyNameInstances envs (tyConName tc) + +familyNameInstances :: (FamInstEnv, FamInstEnv) -> Name -> [FamInst] +familyNameInstances (pkg_fie, home_fie) fam + = get home_fie ++ get pkg_fie + where + get :: FamInstEnv -> [FamInst] + get (FamIE _ env) = lookupRM [RML_KnownTc fam] env + + +-- | Makes no particular effort to detect conflicts. +unionFamInstEnv :: FamInstEnv -> FamInstEnv -> FamInstEnv +unionFamInstEnv (FamIE sa a) (FamIE sb b) = FamIE (sa + sb) (a `unionRM` b) + +extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv +extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis + +extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +extendFamInstEnv (FamIE s inst_env) + ins_item@(FamInst {fi_fam = cls_nm}) + = FamIE (s+1) $ insertRM rough_tmpl ins_item inst_env + where + rough_tmpl = RM_KnownTc cls_nm : fi_tcs ins_item + +{- +************************************************************************ +* * + Compatibility +* * +************************************************************************ + +Note [Apartness] +~~~~~~~~~~~~~~~~ +In dealing with closed type families, we must be able to check that one type +will never reduce to another. This check is called /apartness/. The check +is always between a target (which may be an arbitrary type) and a pattern. +Here is how we do it: + +apart(target, pattern) = not (unify(flatten(target), pattern)) + +where flatten (implemented in flattenTys, below) converts all type-family +applications into fresh variables. (See Note [Apartness and type families] +in GHC.Core.Unify.) + +Note [Compatibility] +~~~~~~~~~~~~~~~~~~~~ +Two patterns are /compatible/ if either of the following conditions hold: +1) The patterns are apart. +2) The patterns unify with a substitution S, and their right hand sides +equal under that substitution. + +For open type families, only compatible instances are allowed. For closed +type families, the story is slightly more complicated. Consider the following: + +type family F a where + F Int = Bool + F a = Int + +g :: Show a => a -> F a +g x = length (show x) + +Should that type-check? No. We need to allow for the possibility that 'a' +might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int +only when we can be sure that 'a' is not Int. + +To achieve this, after finding a possible match within the equations, we have to +go back to all previous equations and check that, under the substitution induced +by the match, other branches are surely apart, using `tcUnifyTysFG`. (See +Note [Apartness and type families] in GHC.Core.Unify.) This is similar to what +happens with class instance selection, when we need to guarantee that there is +only a match and no unifiers. The exact algorithm is different here because the +potentially-overlapping group is closed. + +As another example, consider this: + +type family G x where + G Int = Bool + G a = Double + +type family H y +-- no instances + +Now, we want to simplify (G (H Char)). We can't, because (H Char) might later +simplify to be Int. So, (G (H Char)) is stuck, for now. + +While everything above is quite sound, it isn't as expressive as we'd like. +Consider this: + +type family J a where + J Int = Int + J a = a + +Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if +b is instantiated with Int, but the RHSs coincide there, so it's all OK. + +So, the rule is this: when looking up a branch in a closed type family, we +find a branch that matches the target, but then we make sure that the target +is apart from every previous *incompatible* branch. We don't check the +branches that are compatible with the matching branch, because they are either +irrelevant (clause 1 of compatible) or benign (clause 2 of compatible). + +Note [Compatibility of eta-reduced axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In newtype instances of data families we eta-reduce the axioms, +See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. This means that +we sometimes need to test compatibility of two axioms that were eta-reduced to +different degrees, e.g.: + + +data family D a b c +newtype instance D a Int c = DInt (Maybe a) + -- D a Int ~ Maybe + -- lhs = [a, Int] +newtype instance D Bool Int Char = DIntChar Float + -- D Bool Int Char ~ Float + -- lhs = [Bool, Int, Char] + +These are obviously incompatible. We could detect this by saturating +(eta-expanding) the shorter LHS with fresh tyvars until the lists are of +equal length, but instead we can just remove the tail of the longer list, as +those types will simply unify with the freshly introduced tyvars. + +By doing this, in case the LHS are unifiable, the yielded substitution won't +mention the tyvars that appear in the tail we dropped off, and we might try +to test equality RHSes of different kinds, but that's fine since this case +occurs only for data families, where the RHS is a unique tycon and the equality +fails anyway. +-} + +-- See Note [Compatibility] +compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool +compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + = case tcUnifyTysFG alwaysBindFam alwaysBindTv commonlhs1 commonlhs2 of + -- Here we need the cab_tvs of the two branches to be disinct. + -- See Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom. + SurelyApart -> True + MaybeApart {} -> False + Unifiable subst -> Type.substTyAddInScope subst rhs1 `eqType` + Type.substTyAddInScope subst rhs2 + where + (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2 + -- See Note [Compatibility of eta-reduced axioms] + +-- | Result of testing two type family equations for injectiviy. +data InjectivityCheckResult + = InjectivityAccepted + -- ^ Either RHSs are distinct or unification of RHSs leads to unification of + -- LHSs + | InjectivityUnified CoAxBranch CoAxBranch + -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for + -- closed type families where equation after unification might be + -- overlapped (in which case it is OK if they don't unify). Constructor + -- stores axioms after unification. + +-- | Check whether two type family axioms don't violate injectivity annotation. +injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch + -> InjectivityCheckResult +injectiveBranches injectivity + ax1@(CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 }) + ax2@(CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 }) + -- See Note [Verifying injectivity annotation], case 1. + = let getInjArgs = filterByList injectivity + in_scope = mkInScopeSetList (tvs1 ++ tvs2) + in case tcUnifyTyForInjectivity True in_scope rhs1 rhs2 of + -- True = two-way pre-unification + Nothing -> InjectivityAccepted + -- RHS are different, so equations are injective. + -- This is case 1A from Note [Verifying injectivity annotation] + + Just subst -- RHS unify under a substitution + -- If LHSs are equal under the substitution used for RHSs then this pair + -- of equations does not violate injectivity annotation. If LHSs are not + -- equal under that substitution then this pair of equations violates + -- injectivity annotation, but for closed type families it still might + -- be the case that one LHS after substitution is unreachable. + | eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note. + -> InjectivityAccepted + | otherwise + -> InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 + , cab_rhs = Type.substTy subst rhs1 }) + ( ax2 { cab_lhs = Type.substTys subst lhs2 + , cab_rhs = Type.substTy subst rhs2 }) + -- Payload of InjectivityUnified used only for check 1B2, only + -- for closed type families + where + lhs1Subst = Type.substTys subst (getInjArgs lhs1) + lhs2Subst = Type.substTys subst (getInjArgs lhs2) + +-- takes a CoAxiom with unknown branch incompatibilities and computes +-- the compatibilities +-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom +computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch] +computeAxiomIncomps branches + = snd (mapAccumL go [] branches) + where + go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) + go prev_brs cur_br + = (new_br : prev_brs, new_br) + where + new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } + + mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch] + mk_incomps prev_brs cur_br + = filter (not . compatibleBranches cur_br) prev_brs + +{- +************************************************************************ +* * + Constructing axioms + These functions are here because tidyType / tcUnifyTysFG + are not available in GHC.Core.Coercion.Axiom + + Also computeAxiomIncomps is too sophisticated for CoAxiom +* * +************************************************************************ + +Note [Tidy axioms when we build them] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Like types and classes, we build axioms fully quantified over all +their variables, and tidy them when we build them. For example, +we print out axioms and don't want to print stuff like + F k k a b = ... +Instead we must tidy those kind variables. See #7524. + +We could instead tidy when we print, but that makes it harder to get +things like injectivity errors to come out right. Danger of + Type family equation violates injectivity annotation. + Kind variable ‘k’ cannot be inferred from the right-hand side. + In the type family equation: + PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2 + +Note [Always number wildcard types in CoAxBranch] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example (from the DataFamilyInstanceLHS test case): + + data family Sing (a :: k) + data instance Sing (_ :: MyKind) where + SingA :: Sing A + SingB :: Sing B + +If we're not careful during tidying, then when this program is compiled with +-ddump-types, we'll get the following information: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _ + +It's misleading to have a wildcard type appearing on the RHS like +that. To avoid this issue, when building a CoAxiom (which is what eventually +gets printed above), we tidy all the variables in an env that already contains +'_'. Thus, any variable named '_' will be renamed, giving us the nicer output +here: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1 + +Which is at least legal syntax. + +See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom; note that we +are tidying (changing OccNames only), not freshening, in accordance with +that Note. +-} + +-- all axiom roles are Nominal, as this is only used with type families +mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars + -> [TyVar] -- Extra eta tyvars + -> [CoVar] -- possibly stale covars + -> [Type] -- LHS patterns + -> Type -- RHS + -> [Role] + -> SrcSpan + -> CoAxBranch +mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc + = CoAxBranch { cab_tvs = tvs' + , cab_eta_tvs = eta_tvs' + , cab_cvs = cvs' + , cab_lhs = tidyTypes env lhs + , cab_roles = roles + , cab_rhs = tidyType env rhs + , cab_loc = loc + , cab_incomps = placeHolderIncomps } + where + (env1, tvs') = tidyVarBndrs init_tidy_env tvs + (env2, eta_tvs') = tidyVarBndrs env1 eta_tvs + (env, cvs') = tidyVarBndrs env2 cvs + -- See Note [Tidy axioms when we build them] + -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom + + init_occ_env = initTidyOccEnv [mkTyVarOccFS (fsLit "_")] + init_tidy_env = mkEmptyTidyEnv init_occ_env + -- See Note [Always number wildcard types in CoAxBranch] + +-- all of the following code is here to avoid mutual dependencies with +-- Coercion +mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched +mkBranchedCoAxiom ax_name fam_tc branches + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = manyBranches (computeAxiomIncomps branches) } + +mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched +mkUnbranchedCoAxiom ax_name fam_tc branch + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + +mkSingleCoAxiom :: Role -> Name + -> [TyVar] -> [TyVar] -> [CoVar] + -> TyCon -> [Type] -> Type + -> CoAxiom Unbranched +-- Make a single-branch CoAxiom, including making the branch itself +-- Used for both type family (Nominal) and data family (Representational) +-- axioms, hence passing in the Role +mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = role + , co_ax_implicit = False + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty + (map (const Nominal) tvs) + (getSrcSpan ax_name) + +-- | Create a coercion constructor (axiom) suitable for the given +-- newtype 'TyCon'. The 'Name' should be that of a new coercion +-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and +-- the type the appropriate right hand side of the @newtype@, with +-- the free variables a subset of those 'TyVar's. +mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched +mkNewTypeCoAxiom name tycon tvs roles rhs_ty + = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_implicit = True -- See Note [Implicit axioms] in GHC.Core.TyCon + , co_ax_role = Representational + , co_ax_tc = tycon + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty + roles (getSrcSpan name) + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ + +@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. +Multiple matches are only possible in case of type families (not data +families), and then, it doesn't matter which match we choose (as the +instances are guaranteed confluent). + +We return the matching family instances and the type instance at which it +matches. For example, if we lookup 'T [Int]' and have a family instance + + data instance T [a] = .. + +desugared to + + data :R42T a = .. + coe :Co:R42T a :: T [a] ~ :R42T a + +we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. +-} + +-- when matching a type family application, we get a FamInst, +-- and the list of types the axiom should be applied to +data FamInstMatch = FamInstMatch { fim_instance :: FamInst + , fim_tys :: [Type] + , fim_cos :: [Coercion] + } + -- See Note [Over-saturated matches] + +instance Outputable FamInstMatch where + ppr (FamInstMatch { fim_instance = inst + , fim_tys = tys + , fim_cos = cos }) + = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos + +lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] +lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc + = get pkg_ie ++ get home_ie + where + get (FamIE _ rm) = lookupRM [RML_KnownTc (tyConName fam_tc)] rm + +lookupFamInstEnv + :: FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnv + = lookup_fam_inst_env WantMatches + +lookupFamInstEnvConflicts + :: FamInstEnvs + -> FamInst -- Putative new instance + -> [FamInst] -- Conflicting matches (don't look at the fim_tys field) +-- E.g. when we are about to add +-- f : type instance F [a] = a->a +-- we do (lookupFamInstConflicts f [b]) +-- to find conflicting matches +-- +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnvConflicts envs fam_inst + = lookup_fam_inst_env (WantConflicts fam_inst) envs fam tys + where + (fam, tys) = famInstSplitLHS fam_inst + +-------------------------------------------------------------------------------- +-- Type family injectivity checking bits -- +-------------------------------------------------------------------------------- + +{- Note [Verifying injectivity annotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Injectivity means that the RHS of a type family uniquely determines the LHS (see +Note [Type inference for type families with injectivity]). The user informs us about +injectivity using an injectivity annotation and it is GHC's task to verify that +this annotation is correct w.r.t. type family equations. Whenever we see a new +equation of a type family we need to make sure that adding this equation to the +already known equations of a type family does not violate the injectivity annotation +supplied by the user (see Note [Injectivity annotation]). Of course if the type +family has no injectivity annotation then no check is required. But if a type +family has injectivity annotation we need to make sure that the following +conditions hold: + +1. For each pair of *different* equations of a type family, one of the following + conditions holds: + + A: RHSs are different. (Check done in GHC.Core.FamInstEnv.injectiveBranches) + + B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution + then it must be possible to unify the LHSs under the same substitution. + Example: + + type family FunnyId a = r | r -> a + type instance FunnyId Int = Int + type instance FunnyId a = a + + RHSs of these two equations unify under [ a |-> Int ] substitution. + Under this substitution LHSs are equal therefore these equations don't + violate injectivity annotation. (Check done in GHC.Core.FamInstEnv.injectiveBranches) + + B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some + substitution then either the LHSs unify under the same substitution or + the LHS of the latter equation is overlapped by earlier equations. + Example 1: + + type family SwapIntChar a = r | r -> a where + SwapIntChar Int = Char + SwapIntChar Char = Int + SwapIntChar a = a + + Say we are checking the last two equations. RHSs unify under [ a |-> + Int ] substitution but LHSs don't. So we apply the substitution to LHS + of last equation and check whether it is overlapped by any of previous + equations. Since it is overlapped by the first equation we conclude + that pair of last two equations does not violate injectivity + annotation. (Check done in GHC.Tc.Validity.checkValidCoAxiom#gather_conflicts) + + A special case of B is when RHSs unify with an empty substitution ie. they + are identical. + + If any of the above two conditions holds we conclude that the pair of + equations does not violate injectivity annotation. But if we find a pair + of equations where neither of the above holds we report that this pair + violates injectivity annotation because for a given RHS we don't have a + unique LHS. (Note that (B) actually implies (A).) + + Note that we only take into account these LHS patterns that were declared + as injective. + +2. If an RHS of a type family equation is a bare type variable then + all LHS variables (including implicit kind variables) also have to be bare. + In other words, this has to be a sole equation of that type family and it has + to cover all possible patterns. So for example this definition will be + rejected: + + type family W1 a = r | r -> a + type instance W1 [a] = a + + If it were accepted we could call `W1 [W1 Int]`, which would reduce to + `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`, + which is bogus. Checked FamInst.bareTvInRHSViolated. + +3. If the RHS of a type family equation is a type family application then the type + family is rejected as not injective. This is checked by FamInst.isTFHeaded. + +4. If a LHS type variable that is declared as injective is not mentioned in an + injective position in the RHS then the type family is rejected as not + injective. "Injective position" means either an argument to a type + constructor or argument to a type family on injective position. + There are subtleties here. See Note [Coverage condition for injective type families] + in GHC.Tc.Instance.Family. + +Check (1) must be done for all family instances (transitively) imported. Other +checks (2-4) should be done just for locally written equations, as they are checks +involving just a single equation, not about interactions. Doing the other checks for +imported equations led to #17405, as the behavior of check (4) depends on +-XUndecidableInstances (see Note [Coverage condition for injective type families] in +FamInst), which may vary between modules. + +See also Note [Injective type families] in GHC.Core.TyCon +-} + + +-- | Check whether an open type family equation can be added to already existing +-- instance environment without causing conflicts with supplied injectivity +-- annotations. Returns list of conflicting axioms (type instance +-- declarations). +lookupFamInstEnvInjectivityConflicts + :: [Bool] -- injectivity annotation for this type family instance + -- INVARIANT: list contains at least one True value + -> FamInstEnvs -- all type instances seen so far + -> FamInst -- new type instance that we're checking + -> [CoAxBranch] -- conflicting instance declarations +lookupFamInstEnvInjectivityConflicts injList fam_inst_envs + fam_inst@(FamInst { fi_axiom = new_axiom }) + | not $ isOpenFamilyTyCon fam + = [] + + | otherwise + -- See Note [Verifying injectivity annotation]. This function implements + -- check (1.B1) for open type families described there. + = map (coAxiomSingleBranch . fi_axiom) $ + filter isInjConflict $ + familyInstances fam_inst_envs fam + where + fam = famInstTyCon fam_inst + new_branch = coAxiomSingleBranch new_axiom + + -- filtering function used by `lookup_inj_fam_conflicts` to check whether + -- a pair of equations conflicts with the injectivity annotation. + isInjConflict (FamInst { fi_axiom = old_axiom }) + | InjectivityAccepted <- + injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch + = False -- no conflict + | otherwise = True + + +-------------------------------------------------------------------------------- +-- Type family overlap checking bits -- +-------------------------------------------------------------------------------- + +{- +Note [Family instance overlap conflicts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +- In the case of data family instances, any overlap is fundamentally a + conflict (as these instances imply injective type mappings). + +- In the case of type family instances, overlap is admitted as long as + the right-hand sides of the overlapping rules coincide under the + overlap substitution. eg + type instance F a Int = a + type instance F Int b = b + These two overlap on (F Int Int) but then both RHSs are Int, + so all is well. We require that they are syntactically equal; + anything else would be difficult to test for at this stage. +-} + +------------------------------------------------------------ +-- Might be a one-way match or a unifier +data FamInstLookupMode a where + -- The FamInst we are trying to find conflicts against + WantConflicts :: FamInst -> FamInstLookupMode FamInst + WantMatches :: FamInstLookupMode FamInstMatch + +lookup_fam_inst_env' -- The worker, local to this module + :: forall a . FamInstLookupMode a + -> FamInstEnv + -> TyCon -> [Type] -- What we are looking for + -> [a] +lookup_fam_inst_env' lookup_mode (FamIE _ ie) fam match_tys + | isOpenFamilyTyCon fam + , let xs = rm_fun (lookupRM' rough_tmpl ie) -- The common case + -- Avoid doing any of the allocation below if there are no instances to look at. + , not $ null xs + = mapMaybe' check_fun xs + | otherwise = [] + where + rough_tmpl :: [RoughMatchLookupTc] + rough_tmpl = RML_KnownTc (tyConName fam) : map typeToRoughMatchLookupTc match_tys + + rm_fun :: (Bag FamInst, [FamInst]) -> [FamInst] + (rm_fun, check_fun) = case lookup_mode of + WantConflicts fam_inst -> (snd, unify_fun fam_inst) + WantMatches -> (bagToList . fst, match_fun) + + -- Function used for finding unifiers + unify_fun orig_fam_inst item@(FamInst { fi_axiom = old_axiom, fi_tys = tpl_tys, fi_tvs = tpl_tvs }) + + = assertPpr (tyCoVarsOfTypes tys `disjointVarSet` mkVarSet tpl_tvs) + ((ppr fam <+> ppr tys) $$ + (ppr tpl_tvs <+> ppr tpl_tys)) $ + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch + then Nothing + else Just item + -- See Note [Family instance overlap conflicts] + where + new_branch = coAxiomSingleBranch (famInstAxiom orig_fam_inst) + (fam, tys) = famInstSplitLHS orig_fam_inst + + -- Function used for checking matches + match_fun item@(FamInst { fi_tvs = tpl_tvs, fi_cvs = tpl_cvs + , fi_tys = tpl_tys }) = do + subst <- tcMatchTys tpl_tys match_tys1 + return (FamInstMatch { fim_instance = item + , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 + , fim_cos = assert (all (isJust . lookupCoVar subst) tpl_cvs) $ + substCoVars subst tpl_cvs + }) + where + (match_tys1, match_tys2) = split_tys tpl_tys + + -- Precondition: the tycon is saturated (or over-saturated) + + -- Deal with over-saturation + -- See Note [Over-saturated matches] + split_tys tpl_tys + | isTypeFamilyTyCon fam + = pre_rough_split_tys + + | otherwise + = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys + in (match_tys1, match_tys2) + + (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys + pre_rough_split_tys + = (pre_match_tys1, pre_match_tys2) + +lookup_fam_inst_env -- The worker, local to this module + :: FamInstLookupMode a + -> FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [a] -- Successful matches + +-- Precondition: the tycon is saturated (or over-saturated) + +lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys + = lookup_fam_inst_env' match_fun home_ie fam tys + ++ lookup_fam_inst_env' match_fun pkg_ie fam tys + +{- +Note [Over-saturated matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's ok to look up an over-saturated type constructor. E.g. + type family F a :: * -> * + type instance F (a,b) = Either (a->b) + +The type instance gives rise to a newtype TyCon (at a higher kind +which you can't do in Haskell!): + newtype FPair a b = FP (Either (a->b)) + +Then looking up (F (Int,Bool) Char) will return a FamInstMatch + (FPair, [Int,Bool,Char]) +The "extra" type argument [Char] just stays on the end. + +We handle data families and type families separately here: + + * For type families, all instances of a type family must have the + same arity, so we can precompute the split between the match_tys + and the overflow tys. This is done in pre_rough_split_tys. + + * For data family instances, though, we need to re-split for each + instance, because the breakdown might be different for each + instance. Why? Because of eta reduction; see + Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. +-} + +-- checks if one LHS is dominated by a list of other branches +-- in other words, if an application would match the first LHS, it is guaranteed +-- to match at least one of the others. The RHSs are ignored. +-- This algorithm is conservative: +-- True -> the LHS is definitely covered by the others +-- False -> no information +-- It is currently (Oct 2012) used only for generating errors for +-- inaccessible branches. If these errors go unreported, no harm done. +-- This is defined here to avoid a dependency from CoAxiom to Unify +isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool +isDominatedBy branch branches + = or $ map match branches + where + lhs = coAxBranchLHS branch + match (CoAxBranch { cab_lhs = tys }) + = isJust $ tcMatchTys tys lhs + +{- +************************************************************************ +* * + Choosing an axiom application +* * +************************************************************************ + +The lookupFamInstEnv function does a nice job for *open* type families, +but we also need to handle closed ones when normalising a type: +-} + +reduceTyFamApp_maybe :: FamInstEnvs + -> Role -- Desired role of result coercion + -> TyCon -> [Type] + -> Maybe Reduction +-- Attempt to do a *one-step* reduction of a type-family application +-- but *not* newtypes +-- Works on type-synonym families always; data-families only if +-- the role we seek is representational +-- It does *not* normalise the type arguments first, so this may not +-- go as far as you want. If you want normalised type arguments, +-- use topReduceTyFamApp_maybe +-- +-- The TyCon can be oversaturated. +-- Works on both open and closed families +-- +-- Always returns a *homogeneous* coercion -- type family reductions are always +-- homogeneous +reduceTyFamApp_maybe envs role tc tys + | Phantom <- role + = Nothing + + | case role of + Representational -> isOpenFamilyTyCon tc + _ -> isOpenTypeFamilyTyCon tc + -- If we seek a representational coercion + -- (e.g. the call in topNormaliseType_maybe) then we can + -- unwrap data families as well as type-synonym families; + -- otherwise only type-synonym families + , FamInstMatch { fim_instance = FamInst { fi_axiom = ax } + , fim_tys = inst_tys + , fim_cos = inst_cos } : _ <- lookupFamInstEnv envs tc tys + -- NB: Allow multiple matches because of compatible overlap + + = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos + in Just $ coercionRedn co + + | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc + , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys + = let co = mkAxInstCo role (BranchedAxiom ax ind) inst_tys inst_cos + in Just $ coercionRedn co + + | Just builtin_fam <- isBuiltInSynFamTyCon_maybe tc + , Just (rewrite,ts,ty) <- tryMatchFam builtin_fam tys + = let co = mkAxiomCo rewrite (map mkNomReflCo ts) + in Just $ mkReduction co ty + + | otherwise + = Nothing + +-- The axiom can be oversaturated. (Closed families only.) +chooseBranch :: CoAxiom Branched -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) -- found match, with args +chooseBranch axiom tys + = do { let num_pats = coAxiomNumPats axiom + (target_tys, extra_tys) = splitAt num_pats tys + branches = coAxiomBranches axiom + ; (ind, inst_tys, inst_cos) + <- findBranch (unMkBranches branches) target_tys + ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) } + +-- The axiom must *not* be oversaturated +findBranch :: Array BranchIndex CoAxBranch + -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) + -- coercions relate requested types to returned axiom LHS at role N +findBranch branches target_tys + = foldr go Nothing (assocs branches) + where + go :: (BranchIndex, CoAxBranch) + -> Maybe (BranchIndex, [Type], [Coercion]) + -> Maybe (BranchIndex, [Type], [Coercion]) + go (index, branch) other + = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs + , cab_lhs = tpl_lhs }) = branch + in case tcMatchTys tpl_lhs target_tys of + Just subst -- Matching worked. now, check for apartness. + | apartnessCheck target_tys branch + -> -- Matching worked & we're apart from all incompatible branches. + -- success + assert (all (isJust . lookupCoVar subst) tpl_cvs) $ + Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) + + -- Failure. keep looking + _ -> other + +-- | Do an apartness check, as described in the "Closed Type Families" paper +-- (POPL '14). This should be used when determining if an equation +-- ('CoAxBranch') of a closed type family can be used to reduce a certain target +-- type family application. +apartnessCheck :: [Type] + -> CoAxBranch -- ^ The candidate equation we wish to use + -- Precondition: this matches the target + -> Bool -- ^ True <=> equation can fire +apartnessCheck target (CoAxBranch { cab_incomps = incomps }) + = all (isSurelyApart + . tcUnifyTysFG alwaysBindFam alwaysBindTv target + . coAxBranchLHS) incomps + where + isSurelyApart SurelyApart = True + isSurelyApart _ = False + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ + +Note [Normalising types] +~~~~~~~~~~~~~~~~~~~~~~~~ +The topNormaliseType function removes all occurrences of type families +and newtypes from the top-level structure of a type. normaliseTcApp does +the type family lookup and is fairly straightforward. normaliseType is +a little more involved. + +The complication comes from the fact that a type family might be used in the +kind of a variable bound in a forall. We wish to remove this type family +application, but that means coming up with a fresh variable (with the new +kind). Thus, we need a substitution to be built up as we recur through the +type. However, an ordinary TCvSubst just won't do: when we hit a type variable +whose kind has changed during normalisation, we need both the new type +variable *and* the coercion. We could conjure up a new VarEnv with just this +property, but a usable substitution environment already exists: +LiftingContexts from the liftCoSubst family of functions, defined in GHC.Core.Coercion. +A LiftingContext maps a type variable to a coercion and a coercion variable to +a pair of coercions. Let's ignore coercion variables for now. Because the +coercion a type variable maps to contains the destination type (via +coercionKind), we don't need to store that destination type separately. Thus, +a LiftingContext has what we need: a map from type variables to (Coercion, +Type) pairs. + +We also benefit because we can piggyback on the liftCoSubstVarBndr function to +deal with binders. However, I had to modify that function to work with this +application. Thus, we now have liftCoSubstVarBndrUsing, which takes +a function used to process the kind of the binder. We don't wish +to lift the kind, but instead normalise it. So, we pass in a callback function +that processes the kind of the binder. + +After that brilliant explanation of all this, I'm sure you've forgotten the +dangling reference to coercion variables. What do we do with those? Nothing at +all. The point of normalising types is to remove type family applications, but +there's no sense in removing these from coercions. We would just get back a +new coercion witnessing the equality between the same types as the original +coercion. Because coercions are irrelevant anyway, there is no point in doing +this. So, whenever we encounter a coercion, we just say that it won't change. +That's what the CoercionTy case is doing within normalise_type. + +Note [Normalisation and type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to be a bit careful about normalising in the presence of type +synonyms (#13035). Suppose S is a type synonym, and we have + S t1 t2 +If S is family-free (on its RHS) we can just normalise t1 and t2 and +reconstruct (S t1' t2'). Expanding S could not reveal any new redexes +because type families are saturated. + +But if S has a type family on its RHS we expand /before/ normalising +the args t1, t2. If we normalise t1, t2 first, we'll re-normalise them +after expansion, and that can lead to /exponential/ behaviour; see #13035. + +Notice, though, that expanding first can in principle duplicate t1,t2, +which might contain redexes. I'm sure you could conjure up an exponential +case by that route too, but it hasn't happened in practice yet! +-} + +topNormaliseType :: FamInstEnvs -> Type -> Type +topNormaliseType env ty + = case topNormaliseType_maybe env ty of + Just redn -> reductionReducedType redn + Nothing -> ty + +topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe Reduction + +-- ^ Get rid of *outermost* (or toplevel) +-- * type function redex +-- * data family redex +-- * newtypes +-- returning an appropriate Representational coercion. Specifically, if +-- topNormaliseType_maybe env ty = Just (co, ty') +-- then postconditions: +-- (a) co :: ty ~R ty' +-- (b) ty' is not a newtype, and is not a type-family or data-family redex +-- +-- However, ty' can be something like (Maybe (F ty)), where +-- (F ty) is a redex. +-- +-- Always operates homogeneously: the returned type has the same kind as the +-- original type, and the returned coercion is always homogeneous. +topNormaliseType_maybe env ty + = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty + ; let hredn = mkHetReduction (mkReduction co nty) mkind_co + ; return $ homogeniseHetRedn Representational hredn } + where + stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper + + combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2) + + unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) + unwrapNewTypeStepper' rec_nts tc tys + = (, MRefl) <$> unwrapNewTypeStepper rec_nts tc tys + + -- second coercion below is the kind coercion relating the original type's kind + -- to the normalised type's kind + tyFamStepper :: NormaliseStepper (Coercion, MCoercionN) + tyFamStepper rec_nts tc tys -- Try to step a type/data family + = case topReduceTyFamApp_maybe env tc tys of + Just (HetReduction (Reduction co rhs) res_co) + -> NS_Step rec_nts rhs (co, res_co) + _ -> NS_Done + +--------------- +-- | Try to simplify a type-family application, by *one* step +-- If topReduceTyFamApp_maybe env r F tys = Just (HetReduction (Reduction co rhs) res_co) +-- then co :: F tys ~R# rhs +-- res_co :: typeKind(F tys) ~ typeKind(rhs) +-- Type families and data families; always Representational role +topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type] + -> Maybe HetReduction +topReduceTyFamApp_maybe envs fam_tc arg_tys + | isFamilyTyCon fam_tc -- type families and data families + , Just redn <- reduceTyFamApp_maybe envs role fam_tc ntys + = Just $ + mkHetReduction + (mkTyConAppCo role fam_tc args_cos `mkTransRedn` redn) + res_co + | otherwise + = Nothing + where + role = Representational + ArgsReductions (Reductions args_cos ntys) res_co + = initNormM envs role (tyCoVarsOfTypes arg_tys) + $ normalise_tc_args fam_tc arg_tys + +--------------- +normaliseType :: FamInstEnvs + -> Role -- desired role of coercion + -> Type -> Reduction +normaliseType env role ty + = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty + +--------------- +normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> Reduction +-- See comments on normaliseType for the arguments of this function +normaliseTcApp env role tc tys + = initNormM env role (tyCoVarsOfTypes tys) $ + normalise_tc_app tc tys + +------------------------------------------------------- +-- Functions that work in the NormM monad +------------------------------------------------------- + +-- See Note [Normalising types] about the LiftingContext +normalise_tc_app :: TyCon -> [Type] -> NormM Reduction +normalise_tc_app tc tys + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys + , not (isFamFreeTyCon tc) -- Expand and try again + = -- A synonym with type families in the RHS + -- Expand and try again + -- See Note [Normalisation and type synonyms] + normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + + | isFamilyTyCon tc + = -- A type-family application + do { env <- getEnv + ; role <- getRole + ; ArgsReductions redns@(Reductions args_cos ntys) res_co <- normalise_tc_args tc tys + ; case reduceTyFamApp_maybe env role tc ntys of + Just redn1 + -> do { redn2 <- normalise_reduction redn1 + ; let redn3 = mkTyConAppCo role tc args_cos `mkTransRedn` redn2 + ; return $ assemble_result role redn3 res_co } + _ -> -- No unique matching family instance exists; + -- we do not do anything + return $ + assemble_result role (mkTyConAppRedn role tc redns) res_co } + + | otherwise + = -- A synonym with no type families in the RHS; or data type etc + -- Just normalise the arguments and rebuild + do { ArgsReductions redns res_co <- normalise_tc_args tc tys + ; role <- getRole + ; return $ + assemble_result role (mkTyConAppRedn role tc redns) res_co } + + where + assemble_result :: Role -- r, ambient role in NormM monad + -> Reduction -- orig_ty ~r nty, possibly heterogeneous (nty possibly of changed kind) + -> MCoercionN -- typeKind(orig_ty) ~N typeKind(nty) + -> Reduction -- orig_ty ~r nty_casted + -- where nty_casted has same kind as orig_ty + assemble_result r redn kind_co + = mkCoherenceRightMRedn r redn (mkSymMCo kind_co) + +normalise_tc_args :: TyCon -> [Type] -> NormM ArgsReductions +normalise_tc_args tc tys + = do { role <- getRole + ; normalise_args (tyConKind tc) (tyConRolesX role tc) tys } + +normalise_type :: Type -> NormM Reduction +-- Normalise the input type, by eliminating *all* type-function redexes +-- but *not* newtypes (which are visible to the programmer) +-- Returns with Refl if nothing happens +-- Does nothing to newtypes +-- The returned coercion *must* be *homogeneous* +-- See Note [Normalising types] +-- Try not to disturb type synonyms if possible + +normalise_type ty + = go ty + where + go :: Type -> NormM Reduction + go (TyConApp tc tys) = normalise_tc_app tc tys + go ty@(LitTy {}) + = do { r <- getRole + ; return $ mkReflRedn r ty } + go (AppTy ty1 ty2) = go_app_tys ty1 [ty2] + + go (FunTy { ft_af = vis, ft_mult = w, ft_arg = ty1, ft_res = ty2 }) + = do { arg_redn <- go ty1 + ; res_redn <- go ty2 + ; w_redn <- withRole Nominal $ go w + ; r <- getRole + ; return $ mkFunRedn r vis w_redn arg_redn res_redn } + go (ForAllTy (Bndr tcvar vis) ty) + = do { (lc', tv', k_redn) <- normalise_var_bndr tcvar + ; redn <- withLC lc' $ normalise_type ty + ; return $ mkForAllRedn vis tv' k_redn redn } + go (TyVarTy tv) = normalise_tyvar tv + go (CastTy ty co) + = do { redn <- go ty + ; lc <- getLC + ; let co' = substRightCo lc co + ; return $ mkCastRedn2 Nominal ty co redn co' + -- ^^^^^^^^^^^ uses castCoercionKind2 + } + go (CoercionTy co) + = do { lc <- getLC + ; r <- getRole + ; let kco = liftCoSubst Nominal lc (coercionType co) + co' = substRightCo lc co + ; return $ mkProofIrrelRedn r kco co co' } + + go_app_tys :: Type -- function + -> [Type] -- args + -> NormM Reduction + -- cf. GHC.Tc.Solver.Rewrite.rewrite_app_ty_args + go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys) + go_app_tys fun_ty arg_tys + = do { fun_redn@(Reduction fun_co nfun) <- go fun_ty + ; case tcSplitTyConApp_maybe nfun of + Just (tc, xis) -> + do { redn <- go (mkTyConApp tc (xis ++ arg_tys)) + -- rewrite_app_ty_args avoids redundantly processing the xis, + -- but that's a much more performance-sensitive function. + -- This type normalisation is not called in a loop. + ; return $ + mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransRedn` redn } + Nothing -> + do { ArgsReductions redns res_co + <- normalise_args (typeKind nfun) + (Inf.repeat Nominal) + arg_tys + ; role <- getRole + ; return $ + mkCoherenceRightMRedn role + (mkAppRedns fun_redn redns) + (mkSymMCo res_co) } } + +normalise_args :: Kind -- of the function + -> Infinite Role -- roles at which to normalise args + -> [Type] -- args + -> NormM ArgsReductions +-- returns ArgsReductions (Reductions cos xis) res_co, +-- where each xi is the normalised version of the corresponding type, +-- each co is orig_arg ~ xi, and res_co :: kind(f orig_args) ~ kind(f xis). +-- NB: The xis might *not* have the same kinds as the input types, +-- but the resulting application *will* be well-kinded +-- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow +normalise_args fun_ki roles args + = do { normed_args <- zipWithM normalise1 (Inf.toList roles) args + ; return $ simplifyArgsWorker ki_binders inner_ki fvs roles normed_args } + where + (ki_binders, inner_ki) = splitPiTys fun_ki + fvs = tyCoVarsOfTypes args + + normalise1 role ty + = withRole role $ normalise_type ty + +normalise_tyvar :: TyVar -> NormM Reduction +normalise_tyvar tv + = assert (isTyVar tv) $ + do { lc <- getLC + ; r <- getRole + ; return $ case liftCoSubstTyVar lc r tv of + Just co -> coercionRedn co + Nothing -> mkReflRedn r (mkTyVarTy tv) } + +normalise_reduction :: Reduction -> NormM Reduction +normalise_reduction (Reduction co ty) + = do { redn' <- normalise_type ty + ; return $ co `mkTransRedn` redn' } + +normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Reduction) +normalise_var_bndr tcvar + -- works for both tvar and covar + = do { lc1 <- getLC + ; env <- getEnv + ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal + ; return $ liftCoSubstVarBndrUsing reductionCoercion callback lc1 tcvar } + +-- | a monad for the normalisation functions, reading 'FamInstEnvs', +-- a 'LiftingContext', and a 'Role'. +newtype NormM a = NormM { runNormM :: + FamInstEnvs -> LiftingContext -> Role -> a } + deriving (Functor) + +initNormM :: FamInstEnvs -> Role + -> TyCoVarSet -- the in-scope variables + -> NormM a -> a +initNormM env role vars (NormM thing_inside) + = thing_inside env lc role + where + in_scope = mkInScopeSet vars + lc = emptyLiftingContext in_scope + +getRole :: NormM Role +getRole = NormM (\ _ _ r -> r) + +getLC :: NormM LiftingContext +getLC = NormM (\ _ lc _ -> lc) + +getEnv :: NormM FamInstEnvs +getEnv = NormM (\ env _ _ -> env) + +withRole :: Role -> NormM a -> NormM a +withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r + +withLC :: LiftingContext -> NormM a -> NormM a +withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r + +instance Monad NormM where + ma >>= fmb = NormM $ \env lc r -> + let a = runNormM ma env lc r in + runNormM (fmb a) env lc r + +instance Applicative NormM where + pure x = NormM $ \ _ _ _ -> x + (<*>) = ap diff --git a/GHC/Core/InstEnv.hs b/GHC/Core/InstEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/InstEnv.hs @@ -0,0 +1,1711 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[InstEnv]{Utilities for typechecking instance declarations} + +The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv. +-} + +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} + +module GHC.Core.InstEnv ( + DFunId, InstMatch, ClsInstLookupResult, + CanonicalEvidence(..), PotentialUnifiers(..), getCoherentUnifiers, nullUnifiers, + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprDFunId, pprInstances, + instanceWarning, instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst, + instanceDFunId, updateClsInstDFuns, updateClsInstDFun, + fuzzyClsInstCmp, orphNamesOfClsInst, + + InstEnvs(..), VisibleOrphanModules, InstEnv, + LookupInstanceErrReason (..), + mkInstEnv, emptyInstEnv, unionInstEnv, extendInstEnv, + filterInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv, + anyInstEnv, + identicalClsInstHead, + extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, mapInstEnv, + memberInstEnv, + instIsVisible, + classInstances, instanceBindFun, + classNameInstances, + instanceCantMatch, roughMatchTcs, + isOverlappable, isOverlapping, isIncoherent + ) where + +import GHC.Prelude hiding ( head, init, last, tail ) + +import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker, + -- and depends on TcType in many ways +import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) +import GHC.Core.RoughMap +import GHC.Core.Class +import GHC.Core.Unify +import GHC.Core.FVs( orphNamesOfTypes, orphNamesOfType ) +import GHC.Hs.Extension + +import GHC.Unit.Module.Env +import GHC.Unit.Module.Warnings +import GHC.Unit.Types +import GHC.Types.Var +import GHC.Types.Unique.DSet +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Generics (Generic) +import Data.Data ( Data ) +import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe ( isJust ) + +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.Panic +import Data.Semigroup + +{- +************************************************************************ +* * + ClsInst: the data type for type-class instances +* * +************************************************************************ +-} + +-- | A type-class instance. Note that there is some tricky laziness at work +-- here. See Note [ClsInst laziness and the rough-match fields] for more +-- details. +data ClsInst + = ClsInst { -- Used for "rough matching"; see + -- Note [ClsInst laziness and the rough-match fields] + -- INVARIANT: is_tcs = KnownTc is_cls_nm : roughMatchTcs is_tys + is_cls_nm :: Name -- ^ Class name + + , is_tcs :: [RoughMatchTc] -- ^ Top of type args + -- The class itself is always + -- the first element of this list + + -- | @is_dfun_name = idName . is_dfun@. + -- + -- We use 'is_dfun_name' for the visibility check, + -- 'instIsVisible', which needs to know the 'Module' which the + -- dictionary is defined in. However, we cannot use the 'Module' + -- attached to 'is_dfun' since doing so would mean we would + -- potentially pull in an entire interface file unnecessarily. + -- This was the cause of #12367. + , is_dfun_name :: Name + + -- Used for "proper matching"; see Note [Proper-match fields] + , is_tvs :: [TyVar] -- Fresh template tyvars for full match + -- See Note [Template tyvars are fresh] + , is_cls :: Class -- The real class + , is_tys :: [Type] -- Full arg types (mentioning is_tvs) + -- INVARIANT: is_dfun Id has type + -- forall is_tvs. (...) => is_cls is_tys + -- (modulo alpha conversion) + + , is_dfun :: DFunId -- See Note [Haddock assumptions] + + , is_flag :: OverlapFlag -- See detailed comments with + -- the decl of BasicTypes.OverlapFlag + , is_orphan :: IsOrphan + , is_warn :: Maybe (WarningTxt GhcRn) + -- Warning emitted when the instance is used + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict + } + deriving Data + +-- | A fuzzy comparison function for class instances, intended for sorting +-- instances before displaying them to the user. +fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering +fuzzyClsInstCmp x y = + foldMap cmp (zip (is_tcs x) (is_tcs y)) + where + cmp (RM_WildCard, RM_WildCard) = EQ + cmp (RM_WildCard, RM_KnownTc _) = LT + cmp (RM_KnownTc _, RM_WildCard) = GT + cmp (RM_KnownTc x, RM_KnownTc y) = stableNameCmp x y + +isOverlappable, isOverlapping, isIncoherent, isNonCanonical :: ClsInst -> Bool +isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) +isOverlapping i = hasOverlappingFlag (overlapMode (is_flag i)) +isIncoherent i = hasIncoherentFlag (overlapMode (is_flag i)) +isNonCanonical i = hasNonCanonicalFlag (overlapMode (is_flag i)) + +{- +Note [ClsInst laziness and the rough-match fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is +otherwise unused in the program. Then it's stupid to load B.hi, the data type +declaration for B.T -- and perhaps further instance declarations! + +We avoid this as follows: + +* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's + content. + +* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys + contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we + poke any of these fields we'll typecheck the DFunId declaration, and hence + pull in interfaces that it refers to. See Note [Proper-match fields]. + +* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and + is_tcs :: [RoughMatchTc] fields to perform a "rough match", *without* poking + inside the DFunId. The rough-match fields allow us to say "definitely does not + match", based only on Names. See GHC.Core.Unify + Note [Rough matching in class and family instances] + + This laziness is very important; see #12367. Try hard to avoid pulling on + the structured fields unless you really need the instance. + +* Another place to watch is InstEnv.instIsVisible, which needs the module to + which the ClsInst belongs. We can get this from is_dfun_name. +-} + +{- +Note [Template tyvars are fresh] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs field of a ClsInst has *completely fresh* tyvars. +That is, they are + * distinct from any other ClsInst + * distinct from any tyvars free in predicates that may + be looked up in the class instance environment +Reason for freshness: we use unification when checking for overlap +etc, and that requires the tyvars to be distinct. + +The invariant is checked by the ASSERT in instEnvMatchesAndUnifiers. + +Note [Proper-match fields] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs, is_cls, is_tys fields are simply cached values, pulled +out (lazily) from the dfun id. They are cached here simply so +that we don't need to decompose the DFunId each time we want +to match it. The hope is that the rough-match fields mean +that we often never poke the proper-match fields. + +However, note that: + * is_tvs must be a superset of the free vars of is_tys + + * is_tvs, is_tys may be alpha-renamed compared to the ones in + the dfun Id + +Note [Haddock assumptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For normal user-written instances, Haddock relies on + + * the SrcSpan of + * the Name of + * the is_dfun of + * an Instance + +being equal to + + * the SrcSpan of + * the instance head type of + * the InstDecl used to construct the Instance. +-} + +instanceDFunId :: ClsInst -> DFunId +instanceDFunId = is_dfun + +updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst +updateClsInstDFun tidy_dfun ispec + = ispec { is_dfun = tidy_dfun (is_dfun ispec) } + +updateClsInstDFuns :: (DFunId -> DFunId) -> InstEnv -> InstEnv +updateClsInstDFuns tidy_dfun (InstEnv rm) + = InstEnv $ fmap (updateClsInstDFun tidy_dfun) rm + +instance NamedThing ClsInst where + getName ispec = getName (is_dfun ispec) + +instance Outputable ClsInst where + ppr = pprInstance + +pprDFunId :: DFunId -> SDoc +-- Prints the analogous information to `pprInstance` +-- but with just the DFunId +pprDFunId dfun + = hang dfun_header + 2 (vcat [ text "--" <+> pprDefinedAt (getName dfun) + , whenPprDebug (ppr dfun) ]) + where + dfun_header = ppr_overlap_dfun_hdr empty dfun + +pprInstance :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstance ispec + = hang (pprInstanceHdr ispec) + 2 (vcat [ text "--" <+> pprDefinedAt (getName ispec) + , whenPprDebug (ppr (is_dfun ispec)) ]) + +-- * pprInstanceHdr is used in VStudio to populate the ClassView tree +pprInstanceHdr :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) + = ppr_overlap_dfun_hdr (ppr flag) dfun + +ppr_overlap_dfun_hdr :: SDoc -> DFunId -> SDoc +ppr_overlap_dfun_hdr flag_sdoc dfun + = text "instance" <+> flag_sdoc <+> pprSigmaType (idType dfun) + +pprInstances :: [ClsInst] -> SDoc +pprInstances ispecs = vcat (map pprInstance ispecs) + +instanceWarning :: ClsInst -> Maybe (WarningTxt GhcRn) +instanceWarning = is_warn + +instanceHead :: ClsInst -> ([TyVar], Class, [Type]) +-- Returns the head, using the fresh tyvars from the ClsInst +instanceHead (ClsInst { is_tvs = tvs, is_cls = cls, is_tys = tys }) + = (tvs, cls, tys) + +-- | Collects the names of concrete types and type constructors that make +-- up the head of a class instance. For instance, given `class Foo a b`: +-- +-- `instance Foo (Either (Maybe Int) a) Bool` would yield +-- [Either, Maybe, Int, Bool] +-- +-- Used in the implementation of ":info" in GHCi. +-- +-- The 'tcSplitSigmaTy' is because of +-- instance Foo a => Baz T where ... +-- The decl is an orphan if Baz and T are both not locally defined, +-- even if Foo *is* locally defined +orphNamesOfClsInst :: ClsInst -> NameSet +orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys }) + = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm + +instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type]) +-- Decomposes the DFunId +instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) + +mkLocalClsInst :: DFunId -> OverlapFlag + -> [TyVar] -> Class -> [Type] + -> Maybe (WarningTxt GhcRn) + -> ClsInst +-- Used for local instances, where we can safely pull on the DFunId. +-- Consider using newClsInst instead; this will also warn if +-- the instance is an orphan. +mkLocalClsInst dfun oflag tvs cls tys warn + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs + , is_dfun_name = dfun_name + , is_cls = cls, is_cls_nm = cls_name + , is_tys = tys, is_tcs = RM_KnownTc cls_name : roughMatchTcs tys + , is_orphan = orph, is_warn = warn + } + where + cls_name = className cls + dfun_name = idName dfun + this_mod = assert (isExternalName dfun_name) $ nameModule dfun_name + is_local name = nameIsLocalOrFrom this_mod name + + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv + (cls_tvs, fds) = classTvsFds cls + arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] + + -- See Note [When exactly is an instance decl an orphan?] + orph | is_local cls_name = NotOrphan (nameOccName cls_name) + | all notOrphan mb_ns = NE.head mb_ns + | otherwise = IsOrphan + + notOrphan NotOrphan{} = True + notOrphan _ = False + + mb_ns :: NonEmpty IsOrphan + -- One for each fundep; a locally-defined name + -- that is not in the "determined" arguments + mb_ns = case nonEmpty fds of + Nothing -> NE.singleton (choose_one arg_names) + Just fds -> fmap do_one fds + do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names + , not (tv `elem` rtvs)] + + choose_one nss = chooseOrphanAnchor (unionNameSets nss) + +mkImportedClsInst :: Name -- ^ the name of the class + -> [RoughMatchTc] -- ^ the rough match signature of the instance + -> Name -- ^ the 'Name' of the dictionary binding + -> DFunId -- ^ the 'Id' of the dictionary. + -> OverlapFlag -- ^ may this instance overlap? + -> IsOrphan -- ^ is this instance an orphan? + -> Maybe (WarningTxt GhcRn) -- ^ warning emitted when solved + -> ClsInst +-- Used for imported instances, where we get the rough-match stuff +-- from the interface file +-- The bound tyvars of the dfun are guaranteed fresh, because +-- the dfun has been typechecked out of the same interface file +mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan warn + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs, is_tys = tys + , is_dfun_name = dfun_name + , is_cls_nm = cls_nm, is_cls = cls + , is_tcs = RM_KnownTc cls_nm : mb_tcs + , is_orphan = orphan + , is_warn = warn } + where + (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + +{- +Note [When exactly is an instance decl an orphan?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(See GHC.Iface.Make.instanceToIfaceInst, which implements this.) +See Note [Orphans] in GHC.Core + +Roughly speaking, an instance is an orphan if its head (after the =>) +mentions nothing defined in this module. + +Functional dependencies complicate the situation though. Consider + + module M where { class C a b | a -> b } + +and suppose we are compiling module X: + + module X where + import M + data T = ... + instance C Int T where ... + +This instance is an orphan, because when compiling a third module Y we +might get a constraint (C Int v), and we'd want to improve v to T. So +we must make sure X's instances are loaded, even if we do not directly +use anything from X. + +More precisely, an instance is an orphan iff + + If there are no fundeps, then at least of the names in + the instance head is locally defined. + + If there are fundeps, then for every fundep, at least one of the + names free in a *non-determined* part of the instance head is + defined in this module. + +(Note that these conditions hold trivially if the class is locally +defined.) + + +************************************************************************ +* * + InstEnv, ClsInstEnv +* * +************************************************************************ + +A @ClsInstEnv@ all the instances of that class. The @Id@ inside a +ClsInstEnv mapping is the dfun for that instance. + +If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then + + forall a b, C t1 t2 t3 can be constructed by dfun + +or, to put it another way, we have + + instance (...) => C t1 t2 t3, witnessed by dfun +-} + +--------------------------------------------------- +{- +Note [InstEnv determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We turn InstEnvs into a list in some places that don't directly affect +the ABI. That happens when we create output for `:info`. +Unfortunately that nondeterminism is nonlocal and it's hard to tell what it +affects without following a chain of functions. It's also easy to accidentally +make that nondeterminism affect the ABI. Furthermore the envs should be +relatively small, so it should be free to use deterministic maps here. +Testing with nofib and validate detected no difference between UniqFM and +UniqDFM. See also Note [Deterministic UniqFM] +-} + +-- Internally it's safe to indexable this map by +-- by @Class@, the classes @Name@, the classes @TyCon@ +-- or it's @Unique@. +-- This is since: +-- getUnique cls == getUnique (className cls) == getUnique (classTyCon cls) +-- +-- We still use Class as key type as it's both the common case +-- and conveys the meaning better. But the implementation of +--InstEnv is a bit more lax internally. +newtype InstEnv = InstEnv (RoughMap ClsInst) -- Maps Class to instances for that class + -- See Note [InstEnv determinism] + +instance Outputable InstEnv where + ppr (InstEnv rm) = pprInstances $ elemsRM rm + +-- | 'InstEnvs' represents the combination of the global type class instance +-- environment, the local type class instance environment, and the set of +-- transitively reachable orphan modules (according to what modules have been +-- directly imported) used to test orphan instance visibility. +data InstEnvs = InstEnvs { + ie_global :: InstEnv, -- External-package instances + ie_local :: InstEnv, -- Home-package instances + ie_visible :: VisibleOrphanModules -- Set of all orphan modules transitively + -- reachable from the module being compiled + -- See Note [Instance lookup and orphan instances] + } + +-- | Set of visible orphan modules, according to what modules have been directly +-- imported. This is based off of the dep_orphs field, which records +-- transitively reachable orphan modules (modules that define orphan instances). +type VisibleOrphanModules = ModuleSet + + +-- INVARIANTS: +-- * The is_tvs are distinct in each ClsInst +-- of a ClsInstEnv (so we can safely unify them) + +-- Thus, the @ClsInstEnv@ for @Eq@ might contain the following entry: +-- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] +-- The "a" in the pattern must be one of the forall'd variables in +-- the dfun type. + +emptyInstEnv :: InstEnv +emptyInstEnv = InstEnv emptyRM + +mkInstEnv :: [ClsInst] -> InstEnv +mkInstEnv = extendInstEnvList emptyInstEnv + +instEnvElts :: InstEnv -> [ClsInst] +instEnvElts (InstEnv rm) = elemsRM rm + -- See Note [InstEnv determinism] + +instEnvEltsForClass :: InstEnv -> Name -> [ClsInst] +instEnvEltsForClass (InstEnv rm) cls_nm = lookupRM [RML_KnownTc cls_nm] rm + +-- N.B. this is not particularly efficient but used only by GHCi. +instEnvClasses :: InstEnv -> UniqDSet Class +instEnvClasses ie = mkUniqDSet $ map is_cls (instEnvElts ie) + +-- | Test if an instance is visible, by checking that its origin module +-- is in 'VisibleOrphanModules'. +-- See Note [Instance lookup and orphan instances] +instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool +instIsVisible vis_mods ispec + -- NB: Instances from the interactive package always are visible. We can't + -- add interactive modules to the set since we keep creating new ones + -- as a GHCi session progresses. + = case nameModule_maybe (is_dfun_name ispec) of + Nothing -> True + Just mod | isInteractiveModule mod -> True + | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods + | otherwise -> True + +classInstances :: InstEnvs -> Class -> [ClsInst] +classInstances envs cls = classNameInstances envs (className cls) + +classNameInstances :: InstEnvs -> Name -> [ClsInst] +classNameInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls + = get home_ie ++ get pkg_ie + where + get :: InstEnv -> [ClsInst] + get ie = filter (instIsVisible vis_mods) (instEnvEltsForClass ie cls) + +-- | Checks for an exact match of ClsInst in the instance environment. +-- We use this when we do signature checking in "GHC.Tc.Module" +memberInstEnv :: InstEnv -> ClsInst -> Bool +memberInstEnv (InstEnv rm) ins_item@(ClsInst { is_tcs = tcs } ) = + any (identicalDFunType ins_item) (fst $ lookupRM' (map roughMatchTcToLookup tcs) rm) + where + identicalDFunType cls1 cls2 = + eqType (varType (is_dfun cls1)) (varType (is_dfun cls2)) + +-- | Makes no particular effort to detect conflicts. +unionInstEnv :: InstEnv -> InstEnv -> InstEnv +unionInstEnv (InstEnv a) (InstEnv b) = InstEnv (a `unionRM` b) + +extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv +extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs + +extendInstEnv :: InstEnv -> ClsInst -> InstEnv +extendInstEnv (InstEnv rm) ins_item@(ClsInst { is_tcs = tcs }) + = InstEnv $ insertRM tcs ins_item rm + +filterInstEnv :: (ClsInst -> Bool) -> InstEnv -> InstEnv +filterInstEnv pred (InstEnv rm) + = InstEnv $ filterRM pred rm + +anyInstEnv :: (ClsInst -> Bool) -> InstEnv -> Bool +anyInstEnv pred (InstEnv rm) + = foldRM (\x rest -> pred x || rest) False rm + +mapInstEnv :: (ClsInst -> ClsInst) -> InstEnv -> InstEnv +mapInstEnv f (InstEnv rm) = InstEnv (f <$> rm) + +deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv +deleteFromInstEnv (InstEnv rm) ins_item@(ClsInst { is_tcs = tcs }) + = InstEnv $ filterMatchingRM (not . identicalClsInstHead ins_item) tcs rm + +deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv +-- Delete a specific instance fron an InstEnv +deleteDFunFromInstEnv (InstEnv rm) dfun + = InstEnv $ filterMatchingRM (not . same_dfun) [RM_KnownTc (className cls)] rm + where + (_, _, cls, _) = tcSplitDFunTy (idType dfun) + same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun' + +identicalClsInstHead :: ClsInst -> ClsInst -> Bool +-- ^ True when when the instance heads are the same +-- e.g. both are Eq [(a,b)] +-- Used for overriding in GHCi +-- Obviously should be insensitive to alpha-renaming +identicalClsInstHead (ClsInst { is_tcs = rough1, is_tys = tys1 }) + (ClsInst { is_tcs = rough2, is_tys = tys2 }) + = not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields; + -- also accounts for class name. + && isJust (tcMatchTys tys1 tys2) + && isJust (tcMatchTys tys2 tys1) + +{- +************************************************************************ +* * + Looking up an instance +* * +************************************************************************ + +@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since +the env is kept ordered, the first match must be the only one. The +thing we are looking up can have an arbitrary "flexi" part. + +Note [Instance lookup and orphan instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are compiling a module M, and we have a zillion packages +loaded, and we are looking up an instance for C (T W). If we find a +match in module 'X' from package 'p', should be "in scope"; that is, + + is p:X in the transitive closure of modules imported from M? + +The difficulty is that the "zillion packages" might include ones loaded +through earlier invocations of the GHC API, or earlier module loads in GHCi. +They might not be in the dependencies of M itself; and if not, the instances +in them should not be visible. #2182, #8427. + +There are two cases: + * If the instance is *not an orphan*, then module X defines C, T, or W. + And in order for those types to be involved in typechecking M, it + must be that X is in the transitive closure of M's imports. So we + can use the instance. + + * If the instance *is an orphan*, the above reasoning does not apply. + So we keep track of the set of orphan modules transitively below M; + this is the ie_visible field of InstEnvs, of type VisibleOrphanModules. + + If module p:X is in this set, then we can use the instance, otherwise + we can't. + +Note [Rules for instance lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions implement the carefully-written rules in the user +manual section on "overlapping instances". At risk of duplication, +here are the rules. If the rules change, change this text and the +user manual simultaneously. The link may be this: +https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/instances.html#instance-overlap + +The willingness to be overlapped or incoherent is a property of the +instance declaration itself, controlled by its `OverlapMode`, as follows + + * An instance is "incoherent" (OverlapMode = `Incoherent` or `NonCanonical`) + if it has an `INCOHERENT` pragma, or + if it appears in a module compiled with `-XIncoherentInstances`. + In those cases: + -fspecialise-incoherents on => Incoherent + -fspecialise-incoherents off => NonCanonical + NB: it is on by default + + * An instance is "overlappable" (OverlapMode = `Overlappable` or `Overlaps`) + if it has an `OVERLAPPABLE` or `OVERLAPS` pragma, or + if it appears in a module compiled with `-XOverlappingInstances`, or + if the instance is incoherent. + + * An instance is "overlapping" (OverlapMode = `Overlapping` or `Overlaps`) + if it has an `OVERLAPPING` or `OVERLAPS` pragma, or + if it appears in a module compiled with `-XOverlappingInstances`, or + if the instance is incoherent. + +Now suppose that, in some client module, we are searching for an instance +of the target constraint (C ty1 .. tyn). The search works like this. + +(IL0) If there are any local Givens that match (potentially unifying + any metavariables, even untouchable ones) the target constraint, + the search fails unless -XIncoherentInstances is enabled. See + Note [Instance and Given overlap] in GHC.Tc.Solver.Dict. This is + implemented by the first guard in matchClassInst. + +(IL1) Find `all_matches` and `all_unifs` in `lookupInstEnv`: + - all_matches: all instances `I` that *match* the target constraint (that + is, the target constraint is a substitution instance of `I`). These + instance declarations are the /candidates/. + - all_unifs: all non-incoherent instances that *unify with but do not match* + the target constraint. These are not candidates, but might match later if + the target constraint is furhter instantiated. See + `data PotentialUnifiers` for more precise details. + +(IL2) If there are no candidates, the search fails + (lookupInstEnv returns no final_matches). The PotentialUnifiers are returned + by lookupInstEnv for use in error message generation (mkDictErr). + +(IL3) Eliminate any candidate `IX` for which there is another candidate `IY` such + that both of the following hold: + - `IY` is strictly more specific than `IX`. That is, `IY` is a + substitution instance of `IX` but not vice versa. + - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This + "either/or" design, rather than a "both/and" design, allow a + client to deliberately override an instance from a library, + without requiring a change to the library.) + + In addition, provided there is at least one candidate, eliminate any other + candidates that are *incoherent*. (In particular, if all remaining candidates + are incoherent, all except an arbitrarily chosen one will be eliminated.) + + This is implemented by `pruneOverlappedMatches`, producing final_matches in + lookupInstEnv. See Note [Instance overlap and guards] and + Note [Incoherent instances]. + +(IL4) If exactly one *incoherent* candidate remains, the search succeeds. + (By the previous step, there cannot be more than one incoherent candidate + remaining.) + + In this case, lookupInstEnv returns the successful match, and it returns + NoUnifiers as the final_unifs, which amounts to skipping the following + steps. + +(IL5) If more than one candidate remains, the search fails. (We have already + eliminated the incoherent candidates, and we have no way to select + between non-incoherent candidates.) + +(IL6) Otherwise there is exactly one candidate remaining. The all_unifs + computed at step (IL1) are returned from lookupInstEnv as final_unifs. + + If there are no potential unifiers, the search succeeds (in matchInstEnv). + If there is at least one (non-incoherent) potential unifier, matchInstEnv + returns a NotSure result and refrains from committing to the instance. + + Incoherent instances are not returned as part of the potential unifiers. This + affects error messages: they will not be listed as "potentially matching instances" + in an "Overlapping instances" or "Ambiguous type variable" error. + See also Note [Recording coherence information in `PotentialUnifiers`]. + + +Notice that these rules are not influenced by flag settings in the +client module, where the instances are *used*. These rules make it +possible for a library author to design a library that relies on +overlapping instances without the client having to know. + +Note [Overlapping instances] (NB: these notes are quite old) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Overlap is permitted, but only in such a way that one can make +a unique choice when looking up. That is, overlap is only permitted if +one template matches the other, or vice versa. So this is ok: + + [a] [Int] + +but this is not + + (Int,a) (b,Int) + +If overlap is permitted, the list is kept most specific first, so that +the first lookup is the right choice. + + +For now we just use association lists. + +\subsection{Avoiding a problem with overlapping} + +Consider this little program: + +\begin{pseudocode} + class C a where c :: a + class C a => D a where d :: a + + instance C Int where c = 17 + instance D Int where d = 13 + + instance C a => C [a] where c = [c] + instance ({- C [a], -} D a) => D [a] where d = c + + instance C [Int] where c = [37] + + main = print (d :: [Int]) +\end{pseudocode} + +What do you think `main' prints (assuming we have overlapping instances, and +all that turned on)? Well, the instance for `D' at type `[a]' is defined to +be `c' at the same type, and we've got an instance of `C' at `[Int]', so the +answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because +the `C [Int]' instance is more specific). + +Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That +was easy ;-) Let's just consult hugs for good measure. Wait - if I use old +hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it +doesn't even compile! What's going on!? + +What hugs complains about is the `D [a]' instance decl. + +\begin{pseudocode} + ERROR "mj.hs" (line 10): Cannot build superclass instance + *** Instance : D [a] + *** Context supplied : D a + *** Required superclass : C [a] +\end{pseudocode} + +You might wonder what hugs is complaining about. It's saying that you +need to add `C [a]' to the context of the `D [a]' instance (as appears +in comments). But there's that `C [a]' instance decl one line above +that says that I can reduce the need for a `C [a]' instance to the +need for a `C a' instance, and in this case, I already have the +necessary `C a' instance (since we have `D a' explicitly in the +context, and `C' is a superclass of `D'). + +Unfortunately, the above reasoning indicates a premature commitment to the +generic `C [a]' instance. I.e., it prematurely rules out the more specific +instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to +add the context that hugs suggests (uncomment the `C [a]'), effectively +deferring the decision about which instance to use. + +Now, interestingly enough, 4.04 has this same bug, but it's covered up +in this case by a little known `optimization' that was disabled in +4.06. Ghc-4.04 silently inserts any missing superclass context into +an instance declaration. In this case, it silently inserts the `C +[a]', and everything happens to work out. + +(See `GHC.Types.Id.Make.mkDictFunId' for the code in question. Search for +`Mark Jones', although Mark claims no credit for the `optimization' in +question, and would rather it stopped being called the `Mark Jones +optimization' ;-) + +So, what's the fix? I think hugs has it right. Here's why. Let's try +something else out with ghc-4.04. Let's add the following line: + + d' :: D a => [a] + d' = c + +Everyone raise their hand who thinks that `d :: [Int]' should give a +different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The +`optimization' only applies to instance decls, not to regular +bindings, giving inconsistent behavior. + +Old hugs had this same bug. Here's how we fixed it: like GHC, the +list of instances for a given class is ordered, so that more specific +instances come before more generic ones. For example, the instance +list for C might contain: + ..., C Int, ..., C a, ... +When we go to look for a `C Int' instance we'll get that one first. +But what if we go looking for a `C b' (`b' is unconstrained)? We'll +pass the `C Int' instance, and keep going. But if `b' is +unconstrained, then we don't know yet if the more specific instance +will eventually apply. GHC keeps going, and matches on the generic `C +a'. The fix is to, at each step, check to see if there's a reverse +match, and if so, abort the search. This prevents hugs from +prematurely choosing a generic instance when a more specific one +exists. + +--Jeff + +BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in +this test. Suppose the instance envt had + ..., forall a b. C a a b, ..., forall a b c. C a b c, ... +(still most specific first) +Now suppose we are looking for (C x y Int), where x and y are unconstrained. + C x y Int doesn't match the template {a,b} C a a b +but neither does + C a a b match the template {x,y} C x y Int +But still x and y might subsequently be unified so they *do* match. + +Simple story: unify, don't match. + +Note [Coherence and specialisation: overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC's specialiser relies on the Coherence Assumption: that if + d1 :: C tys + d2 :: C tys +then the dictionary d1 can be used in place of d2 and vice versa; it is as if +(C tys) is a singleton type. If d1 and d2 are interchangeable, we say that +they constitute /canonical evidence/ for (C tys). We have a special data type, +`CanonoicalEvidence`, for recording whether evidence is canonical. + +Let's use this example + class C a where { op :: a -> Int } + instance C [a] where {...} -- (I1) + instance {-# OVERLAPPING #-} C [Int] where {...} -- (I2) + + instance C a => C (Maybe a) where {...} -- (I3) + instance {-# INCOHERENT #-} C (Maybe Int) where {...} -- (I4) + instance C Int where {...} -- (I5) + +* When solving (C tys) from the top-level instances, we generally insist that + there is a unique, most-specific match. (Incoherent instances change the + picture a bit: see Note [Rules for instance lookup].) Example: + [W] C [Int] -- Pick (I2) + [W] C [Char] -- Pick (I1); does not match (I2) + + Caveat: if different usage sites see different instances (which the + programmer can contrive, with some effort), all bets are off; we really + can't make any guarantees at all. + +* But what about [W] C [b]? This might arise from + risky :: b -> Int + risky x = op [x] + We can't pick (I2) because `b` is not Int. But if we pick (I1), and later + the simplifier inlines a call (risky @Int) we'll get a dictionary of type + (C [Int]) built by (I1), which might be utterly different to the dictionary + of type (C [Int]) built by (I2). That breaks the Coherence Assumption. + + So GHC declines to pick either, and rejects `risky`. You have to write a + different signature + notRisky :: C [b] => b -> Int + notRisky x = op [x] + so that the dictionary is resolved at the call site. + +* The INCOHERENT pragma tells GHC to choose an instance anyway: see + Note [Rules for instance lookup] step (IL6). Suppose we have + veryRisky :: C b => b -> Int + veryRisky x = op (Just x) + So we have [W] C (Maybe b). Because (I4) is INCOHERENT, GHC is allowed to + pick (I3). Of course, this risks breaking the Coherence Assumption, as + described above. + +* What about the incoherence from step (IL4)? For example + class D a b where { opD :: a -> b -> String } + instance {-# INCOHERENT #-} D Int b where {...} -- (I7) + instance {-# INCOHERENT #-} D a Int where {...} -- (I8) + + g (x::Int) = opD x x -- [W] D Int Int + + Here both (I7) and (I8) match, GHC picks an arbitrary one. + +So INCOHERENT may break the Coherence Assumption. But sometimes that +is fine, because the programmer promises that it doesn't matter which +one is chosen. A good example is in the `optics` library: + + data IxEq i is js where { IxEq :: IxEq i is is } + + class AppendIndices xs ys ks | xs ys -> ks where + appendIndices :: IxEq i (Curry xs (Curry ys i)) (Curry ks i) + + instance {-# INCOHERENT #-} xs ~ zs => AppendIndices xs '[] zs where + appendIndices = IxEq + + instance ys ~ zs => AppendIndices '[] ys zs where + appendIndices = IxEq + +Here `xs` and `ys` are type-level lists, and for type inference purposes we want to +solve the `AppendIndices` constraint when /either/ of them are the empty list. The +dictionaries are the same in both cases (indeed the dictionary type is a singleton!), +so we really don't care which is used. See #23287 for discussion. + + +In short, sometimes we want to specialise on these incoherently-selected dictionaries, +and sometimes we don't. It would be best to have a per-instance pragma, but for now +we have a global flag: + +* If an instance has an `{-# INCOHERENT #-}` pragma, we the `OverlapFlag` of the + `ClsInst` to label it as either + * `Incoherent`: meaning incoherent but still specialisable, or + * `NonCanonical`: meaning incoherent and not specialisable. + The module-wide `-fspecialise-incoherents` flag (on by default) determines + which choice is made. + + See GHC.Tc.Utils.Instantiate.getOverlapFlag. + +The rest of this note describes what happens for `NonCanonical` +instances, i.e. with `-fno-specialise-incoherents`. + +To avoid this incoherence breaking the specialiser, + +* We label as "non-canonical" any dictionary constructed by a (potentially) + incoherent use of an ClsInst. + +* We do not specialise a function if there is a non-canonical + dictionary in the /transistive dependencies/ of its dictionary + arguments. + +To see the transitive closure issue, consider + deeplyRisky :: C b => b -> Int + deeplyRisky x = op (Just (Just x)) + +From (op (Just (Just x))) we get + [W] d1 : C (Maybe (Maybe b)) +which we solve (coherently!) via (I3), giving + [W] d2 : C (Maybe b) +Now we can only solve this incoherently. So we end up with + + deeplyRisky @b (d1 :: C b) + = op @(Maybe (Maybe b)) d1 + where + d1 :: C (Maybe (Maybe b)) = $dfI3 d2 -- Coherent decision + d2 :: C (Maybe b) = $sfI3 d1 -- Incoherent decision + +So `d2` is incoherent, and hence (transitively) so is `d1`. + +Here are the moving parts: + +* GHC.Core.InstEnv.lookupInstEnv tells if any incoherent unifiers were discarded + in step (IL4) or (IL6) of the instance lookup: see + Note [Recording coherence information in `PotentialUnifiers`] and + Note [Canonicity for incoherent matches]. + +* That info is recorded in the `cir_is_coherent` field of `OneInst`, and thence + transferred to the `ep_is_coherent` field of the `EvBind` for the dictionary. + +* In the desugarer we exploit this info: + see Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr. + See also Note [nospecId magic] in GHC.Types.Id.Make. + + +Note [Canonicity for incoherent matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the selected instance is INCOHERENT at step (IL4) of +Note [Rules for instance lookup], we ignore all unifiers, +whether or not they are marked with INCOHERENT pragmas. +This is implemented by returning NoUnifiers in final_unifs. +NoUnifiers takes an argument indicating whether the match was canonical +as described in Note [Coherence and specialisation: overview] and +Note [Recording coherence information in `PotentialUnifiers`]. + +To determine whether an incoherent match was canonical, we look *only* +at the OverlapFlag of the instance being matched. For example: + + class C a + instance {-# INCOHERENT #-} C a -- (1) + instance C Int -- (2) + + [W] C tau + +Here we match instance (1) and discard instance (2). If (1) is Incoherent +(under -fspecialise-incoherents), it is important that we treat the match +as EvCanonical so that we do not block specialisation (see #25883). + +What about the following situation: + + instance {-# INCOHERENT #-} C a -- (1), in a module with -fspecialise-incoherents (Incoherent) + instance {-# INCOHERENT #-} C Int -- (2), in a module with -fno-specialise-incoherents (NonCanonical) + + [W] C tau + +Again we match instance (1) and discard instance (2). It is not obvious +whether Incoherent or NonCanonical should "win" here, but it seems more +consistent with the previous example to look only at the flag on instance (1). + +What about if the only instance that can match is marked as NonCanonical? +In this case are no unifiers at all, so all_unifs = NoUnifiers EvCanonical. +It is not obvious what -fno-specialise-incoherents should do here, but +currently it returns NoUnifiers EvCanonical. + +-} + +type DFunInstType = Maybe Type + -- Just ty => Instantiate with this type + -- Nothing => Instantiate with any type of this tyvar's kind + -- See Note [DFunInstType: instantiating types] + +type InstMatch = (ClsInst, [DFunInstType]) + +type ClsInstLookupResult + = ( [InstMatch] -- Successful matches + , PotentialUnifiers -- These don't match but do unify + , [InstMatch] ) -- Unsafe overlapped instances under Safe Haskell + -- (see Note [Safe Haskell Overlapping Instances] in + -- GHC.Tc.Solver). + +{- +Note [DFunInstType: instantiating types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A successful match is a ClsInst, together with the types at which + the dfun_id in the ClsInst should be instantiated +The instantiating types are (Either TyVar Type)s because the dfun +might have some tyvars that *only* appear in arguments + dfun :: forall a b. C a b, Ord b => D [a] +When we match this against D [ty], we return the instantiating types + [Just ty, Nothing] +where the 'Nothing' indicates that 'b' can be freely instantiated. +(The caller instantiates it to a flexi type variable, which will + presumably later become fixed via functional dependencies.) + +Note [Infinitary substitution in lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + class C a b + instance C c c + instance C d (Maybe d) + [W] C e (Maybe e) + +You would think we could just use the second instance, because the first doesn't +unify. But that's just ever so slightly wrong. The reason we check for unifiers +along with matchers is that we don't want the possibility that a type variable +instantiation could cause an instance choice to change. Yet if we have + type family M = Maybe M +and choose (e |-> M), then both instances match. This is absurd, but we cannot +rule it out. Yet, worrying about this case is awfully inconvenient to users, +and so we pretend the problem doesn't exist, by considering a lookup that runs into +this occurs-check issue to indicate that an instance surely does not apply (i.e. +is like the SurelyApart case). In the brief time that we didn't treat infinitary +substitutions specially, two tickets were filed: #19044 and #19052, both trying +to do Real Work. + +Why don't we just exclude any instances that are MaybeApart? Because we might +have a [W] C e (F e), where F is a type family. The second instance above does +not match, but it should be included as a future possibility. Unification will +return MaybeApart MARTypeFamily in this case. + +What can go wrong with this design choice? We might get incoherence -- but not +loss of type safety. In particular, if we have [W] C M M (for the M type family +above), then GHC might arbitrarily choose either instance, depending on how +M reduces (or doesn't). + +For type families, we can't just ignore the problem (as we essentially do here), +because doing so would give us a hole in the type safety proof (as explored in +Section 6 of "Closed Type Families with Overlapping Equations", POPL'14). This +possibility of an infinitary substitution manifests as closed type families that +look like they should reduce, but don't. Users complain: #9082 and #17311. For +open type families, we actually can have unsoundness if we don't take infinitary +substitutions into account: #8162. But, luckily, for class instances, we just +risk coherence -- not great, but it seems better to give users what they likely +want. (Also, note that this problem existed for the entire decade of 201x without +anyone noticing, so it's manifestly not ruining anyone's day.) +-} + +-- |Look up an instance in the given instance environment. The given class application must match exactly +-- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, +-- yield 'Left errorMessage'. +lookupUniqueInstEnv :: InstEnvs + -> Class -> [Type] + -> Either LookupInstanceErrReason (ClsInst, [Type]) +lookupUniqueInstEnv instEnv cls tys + = case lookupInstEnv False instEnv cls tys of + ([(inst, inst_tys)], _, _) + | noFlexiVar -> Right (inst, inst_tys') + | otherwise -> Left $ LookupInstErrFlexiVar + where + inst_tys' = [ty | Just ty <- inst_tys] + noFlexiVar = all isJust inst_tys + _other -> Left $ LookupInstErrNotFound + +-- | Why a particular typeclass application couldn't be looked up. +data LookupInstanceErrReason = + -- | Tyvars aren't an exact match. + LookupInstErrNotExact + | + -- | One of the tyvars is flexible. + LookupInstErrFlexiVar + | + -- | No matching instance was found. + LookupInstErrNotFound + deriving (Generic) + +-- | `CanonicalEvidence` says whether a piece of evidence has a singleton type; +-- For example, given (d1 :: C Int), will any other (d2 :: C Int) do equally well? +-- See Note [Coherence and specialisation: overview] above, and +-- Note [Desugaring non-canonical evidence] in GHC.HsToCore.Binds +data CanonicalEvidence + = EvCanonical + | EvNonCanonical + +andCanEv :: CanonicalEvidence -> CanonicalEvidence -> CanonicalEvidence +-- Only canonical if both are +andCanEv EvCanonical EvCanonical = EvCanonical +andCanEv _ _ = EvNonCanonical + +-- See Note [Recording coherence information in `PotentialUnifiers`] +data PotentialUnifiers + = NoUnifiers CanonicalEvidence + -- Either there were no unifiers, or all were incoherent + -- + -- NoUnifiers EvNonCanonical: + -- We discarded (via INCOHERENT) some instances that unify, + -- and that are marked NonCanonical; so the matching instance + -- should be traeated as EvNonCanonical + -- NoUnifiers EvCanonical: + -- We discarded no NonCanonical incoherent unifying instances, + -- so the matching instance can be treated as EvCanonical + + | OneOrMoreUnifiers (NonEmpty ClsInst) + -- There are some /coherent/ unifiers; here they are + -- + -- This list is lazy as we only look at all the unifiers when + -- printing an error message. It can be expensive to compute all + -- the unifiers because if you are matching something like C a[sk] then + -- all instances will unify. + +{- Note [Recording coherence information in `PotentialUnifiers`] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we find a matching instance, there might be other instances that +could potentially unify with the goal. For `INCOHERENT` instances, we +don't care (see step (IL6) in Note [Rules for instance lookup]). +But if we have potentially unifying coherent instance, we +report these `OneOrMoreUnifiers` so that `matchInstEnv` can go down +the `NotSure` route. + +If this hurdle is passed, i.e. we have a unique solution up to +`INCOHERENT` instances, the specialiser needs to know if that unique +solution is canonical or not (see Note [Coherence and specialisation: +overview] for why we care at all). So when the set of potential +unifiers is empty, we record in `NoUnifiers` if the one solution is +`Canonical`. + +For example, suppose we have: + + class C x y + instance C a Bool -- (1) + instance {-# INCOHERENT #-} C Int a -- (2) + + [W] C x Bool + +Here instance (1) matches the Wanted, and since instance (2) is INCOHERENT +we want to succeed with the match rather than getting stick at step (IL6). +But if -fno-specialise-incoherents was enabled for (2), the specialiser is +not permitted to specialise this dictionary later, so lookupInstEnv reports +the PotentialUnifiers as NoUnifiers EvNonCanonical. + +-} + +instance Outputable CanonicalEvidence where + ppr EvCanonical = text "canonical" + ppr EvNonCanonical = text "non-canonical" + +instance Outputable PotentialUnifiers where + ppr (NoUnifiers c) = text "NoUnifiers" <+> ppr c + ppr xs = ppr (getCoherentUnifiers xs) + +instance Semigroup PotentialUnifiers where + NoUnifiers c1 <> NoUnifiers c2 = NoUnifiers (c1 `andCanEv` c2) + NoUnifiers _ <> u = u + OneOrMoreUnifiers (unifier :| unifiers) <> u + = OneOrMoreUnifiers (unifier :| (unifiers <> getCoherentUnifiers u)) + +getCoherentUnifiers :: PotentialUnifiers -> [ClsInst] +getCoherentUnifiers NoUnifiers{} = [] +getCoherentUnifiers (OneOrMoreUnifiers cls) = NE.toList cls + +-- | Are there no *coherent* unifiers? +nullUnifiers :: PotentialUnifiers -> Bool +nullUnifiers NoUnifiers{} = True +nullUnifiers _ = False + +-- | Are there any unifiers, ignoring those marked Incoherent (but including any +-- marked NonCanonical)? +someUnifiers :: PotentialUnifiers -> Bool +someUnifiers (NoUnifiers EvCanonical) = False +someUnifiers _ = True + + +instEnvMatchesAndUnifiers + :: InstEnv -- InstEnv to look in + -> VisibleOrphanModules -- But filter against this + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + PotentialUnifiers) -- These don't match but do unify + -- (no incoherent ones in here) +-- The second component of the result pair happens when we look up +-- Foo [a] +-- in an InstEnv that has entries for +-- Foo [Int] +-- Foo [b] +-- Then which we choose would depend on the way in which 'a' +-- is instantiated. So we report that Foo [b] is a match (mapping b->a) +-- but Foo [Int] is a unifier. This gives the caller a better chance of +-- giving a suitable error message + +instEnvMatchesAndUnifiers (InstEnv rm) vis_mods cls tys + = (foldr check_match [] rough_matches, check_unifiers rough_unifiers) + where + (rough_matches, rough_unifiers) = lookupRM' rough_tcs rm + rough_tcs = RML_KnownTc (className cls) : roughMatchTcsLookup tys + + -------------- + check_match :: ClsInst -> [InstMatch] -> [InstMatch] + check_match item@(ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }) acc + | not (instIsVisible vis_mods item) + = acc -- See Note [Instance lookup and orphan instances] + + | Just subst <- tcMatchTys tpl_tys tys + = ((item, map (lookupTyVar subst) tpl_tvs) : acc) + + | otherwise + = acc + + check_unifiers :: [ClsInst] -> PotentialUnifiers + check_unifiers [] = NoUnifiers EvCanonical + check_unifiers (item@ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }:items) + + | not (instIsVisible vis_mods item) + = check_unifiers items -- See Note [Instance lookup and orphan instances] + + -- If it matches, check_match has gotten it, so skip over it here + | Just {} <- tcMatchTys tpl_tys tys + = check_unifiers items + + -- Does not match, so next check whether the things unify + -- See Note [Overlapping instances] + | otherwise + = assertPpr (tys_tv_set `disjointVarSet` tpl_tv_set) + ((ppr cls <+> ppr tys) $$ + (ppr tpl_tvs <+> ppr tpl_tys)) $ + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + -- See Note [Template tyvars are fresh] + case tcUnifyTysFG alwaysBindFam instanceBindFun tpl_tys tys of + -- alwaysBindFam: the family-application can't be in the instance head, + -- but it certainly can be in the Wanted constraint we are matching! + -- + -- We consider MaybeApart to be a case where the instance might + -- apply in the future. This covers an instance like C Int and + -- a target like [W] C (F a), where F is a type family. + -- See (ATF1) in Note [Apartness and type families] in GHC.Core.Unify + SurelyApart -> check_unifiers items + -- See Note [Infinitary substitution in lookup] + MaybeApart MARInfinite _ -> check_unifiers items + _ -> add_unifier item (check_unifiers items) + + where + tpl_tv_set = mkVarSet tpl_tvs + tys_tv_set = tyCoVarsOfTypes tys + + add_unifier :: ClsInst -> PotentialUnifiers -> PotentialUnifiers + -- Record that we encountered non-canonical instances: + -- Note [Coherence and specialisation: overview] + add_unifier item other_unifiers + | not (isIncoherent item) + = OneOrMoreUnifiers (item :| getCoherentUnifiers other_unifiers) + + -- So `item` is incoherent; see Note [Incoherent instances] + | otherwise + = case other_unifiers of + OneOrMoreUnifiers{} -> other_unifiers + NoUnifiers{} | isNonCanonical item -> NoUnifiers EvNonCanonical + | otherwise -> other_unifiers + + +--------------- +-- This is the common way to call this function. +lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions + -> InstEnvs -- External and home package inst-env + -> Class -> [Type] -- What we are looking for + -> ClsInstLookupResult +-- ^ See Note [Rules for instance lookup] +-- ^ See Note [Safe Haskell Overlapping Instances] in "GHC.Tc.Solver" +-- ^ See Note [Safe Haskell Overlapping Instances Implementation] in "GHC.Tc.Solver" +lookupInstEnv check_overlap_safe + (InstEnvs { ie_global = pkg_ie + , ie_local = home_ie + , ie_visible = vis_mods }) + cls + tys + = (final_matches, final_unifs, unsafe_overlapped) + where + -- (IL1): Find all instances that match the target constraint + (home_matches, home_unifs) = instEnvMatchesAndUnifiers home_ie vis_mods cls tys + (pkg_matches, pkg_unifs) = instEnvMatchesAndUnifiers pkg_ie vis_mods cls tys + all_matches = home_matches <> pkg_matches + all_unifs = home_unifs <> pkg_unifs + + -- (IL3): Eliminate candidates that are overlapped or incoherent + final_matches = pruneOverlappedMatches all_matches + -- Even if the unifs is non-empty (an error situation) + -- we still prune the matches, so that the error message isn't + -- misleading (complaining of multiple matches when some should be + -- overlapped away) + + unsafe_overlapped + = case final_matches of + [match] -> check_safe match + _ -> [] + + -- If the selected match is incoherent, discard all unifiers + -- See (IL4) of Note [Rules for instance lookup] + final_unifs = case final_matches of + (m:ms) | isIncoherent (fst m) + -- Incoherent match, so discard all unifiers, but + -- keep track of dropping coherent or non-canonical ones + -- if the match is non-canonical. + -- See Note [Canonicity for incoherent matches] + -> assertPpr (null ms) (ppr final_matches) $ + NoUnifiers $ + if isNonCanonical (fst m) && someUnifiers all_unifs + then EvNonCanonical + else EvCanonical + _ -> all_unifs + + -- Note [Safe Haskell isSafeOverlap] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We restrict code compiled in 'Safe' mode from overriding code + -- compiled in any other mode. The rationale is that code compiled + -- in 'Safe' mode is code that is untrusted by the ghc user. So + -- we shouldn't let that code change the behaviour of code the + -- user didn't compile in 'Safe' mode since that's the code they + -- trust. So 'Safe' instances can only overlap instances from the + -- same module. A same instance origin policy for safe compiled + -- instances. + check_safe (inst,_) + = case check_overlap_safe && unsafeTopInstance inst of + -- make sure it only overlaps instances from the same module + True -> go [] all_matches + -- most specific is from a trusted location. + False -> [] + where + go bad [] = bad + go bad (i@(x,_):unchecked) = + if inSameMod x || isOverlappable x + then go bad unchecked + else go (i:bad) unchecked + + inSameMod b = + let na = getName $ getName inst + la = isInternalName na + nb = getName $ getName b + lb = isInternalName nb + in (la && lb) || (nameModule na == nameModule nb) + + -- We consider the most specific instance unsafe when it both: + -- (1) Comes from a module compiled as `Safe` + -- (2) Is an orphan instance, OR, an instance for a MPTC + unsafeTopInstance inst = isSafeOverlap (is_flag inst) && + (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1) + +--------------- + + +{- Note [Instance overlap and guards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The first step is to find all instances that /match/ the constraint +we are trying to solve. Next, using pruneOverlapped Matches, we eliminate +from that list of instances any instances that are overlapped. For example: + +(A) instance C [a] where ... +(B) instance {-# OVERLAPPING #-} C [[a] where ... +(C) instance C (Maybe a) where + +Suppose we are trying to solve C [[Bool]]. The lookup will return a list [A,B] +of the first two instances, since both match. (The Maybe instance doesn't match, +so the lookup won't return (C).) Then pruneOverlappedMatches removes (A), +since (B) is more specific. So we end up with just one match, (B). + +However pruneOverlappedMatches is a bit more subtle than you might think (#20946). +Recall how we go about eliminating redundant instances, as described in +Note [Rules for instance lookup]. + + - When instance I1 is more specific than instance I2, + - and either I1 is overlapping or I2 is overlappable, + +then we can discard I2 in favour of I1. Note however that, as part of the instance +resolution process, we don't want to immediately discard I2, as it can still be useful. +For example, suppose we are trying to solve C [[Int]], and have instances: + + I1: instance C [[Int]] + I2: instance {-# OVERLAPS #-} C [[a]] + +Both instances match. I2 is both overlappable and overlapping (that's what `OVERLAPS` +means). Now I1 is more specific than I2, and I2 is overlappable, so we can discard I2. +However, we should still keep I2 around when looking up instances, because it is +overlapping and `I1` isn't: this means it can be used to eliminate other instances +that I1 can't, such as: + + I3: instance C [a] + +I3 is more general than both I1 and I2, but it is not overlappable, and I1 +is not overlapping. This means that we must use I2 to discard I3. + +To do this, in 'insert_overlapping', on top of keeping track of matching +instances, we also keep track of /guards/, which are instances like I2 +which we will discard in the end (because we have a more specific match +that overrides it) but might still be useful for eliminating other instances +(like I3 in this example). + + +(A) Definition of guarding instances (guards). + + To add a matching instance G as a guard, it must satisfy the following conditions: + + A1. G is overlapped by a more specific match, M, + A2. M is not overlapping, + A3. G is overlapping. + + This means that we eliminate G from the set of matches (it is overridden by M), + but we keep it around until we are done with instance resolution because + it might still be useful to eliminate other matches. + +(B) Guards eliminate matches. + + There are two situations in which guards can eliminate a match: + + B1. We want to add a new instance, but it is overridden by a guard. + We can immediately discard the instance. + + Example for B1: + + Suppose we want to solve C [[Int]], with instances: + + J1: instance C [[Int]] + J2: instance {-# OVERLAPS #-} C [[a]] + J3: instance C [a] + + Processing them in order: we add J1 as a match, then J2 as a guard. + Now, when we come across J3, we can immediately discard it because + it is overridden by the guard J2. + + B2. We have found a new guard. We must use it to discard matches + we have already found. This is necessary because we must obtain + the same result whether we process the instance or the guard first. + + Example for B2: + + Suppose we want to solve C [[Int]], with instances: + + K1: instance C [[Int]] + K2: instance C [a] + K3: instance {-# OVERLAPS #-} C [[a]] + + We start by considering K1 and K2. Neither has any overlapping flag set, + so we end up with two matches, {K1, K2}. + Next we look at K3: it is overridden by K1, but as K1 is not + overlapping this means K3 should function as a guard. + We must then ensure we eliminate K2 from the list of matches, + as K3 guards against it. + +(C) Adding guards. + + When we already have collected some guards, and have come across a new + guard, we can simply add it to the existing list of guards. + We don't need to keep the set of guards minimal, as they will simply + be thrown away at the end: we are only interested in the matches. + Not having a minimal set of guards does not harm us, but it makes + the code simpler. +-} + +-- | Collect class instance matches, including matches that we know +-- are overridden but might still be useful to override other instances +-- (which we call "guards"). +-- +-- See Note [Instance overlap and guards]. +data InstMatches + = InstMatches + { -- | Minimal matches: we have knocked out all strictly more general + -- matches that are overlapped by a match in this list. + instMatches :: [InstMatch] + + -- | Guards: matches that we know we won't pick in the end, + -- but might still be useful for ruling out other instances, + -- as per #20946. See Note [Instance overlap and guards], (A). + , instGuards :: [ClsInst] + } + +instance Outputable InstMatches where + ppr (InstMatches { instMatches = matches, instGuards = guards }) + = text "InstMatches" <+> + braces (vcat [ text "instMatches:" <+> ppr matches + , text "instGuards:" <+> ppr guards ]) + +noMatches :: InstMatches +noMatches = InstMatches { instMatches = [], instGuards = [] } + +pruneOverlappedMatches :: [InstMatch] -> [InstMatch] +-- ^ Remove from the argument list any InstMatches for which another +-- element of the list is more specific, and overlaps it, using the +-- rules of Note [Rules for instance lookup], esp (IL3) +-- +-- Incoherent instances are discarded, unless all are incoherent, +-- in which case exactly one is kept. +pruneOverlappedMatches all_matches = + instMatches $ foldr insert_overlapping noMatches all_matches + +-- | Computes whether the first class instance overrides the second, +-- i.e. the first is more specific and can overlap the second. +-- +-- More precisely, @instA `overrides` instB@ returns 'True' precisely when: +-- +-- - @instA@ is more specific than @instB@, +-- - @instB@ is not more specific than @instA@, +-- - @instA@ is overlapping OR @instB@ is overlappable. +overrides :: ClsInst -> ClsInst -> Bool +new_inst `overrides` old_inst + = (new_inst `more_specific_than` old_inst) + && (not $ old_inst `more_specific_than` new_inst) + && (isOverlapping new_inst || isOverlappable old_inst) + -- Overlap permitted if either the more specific instance + -- is marked as overlapping, or the more general one is + -- marked as overlappable. + -- Latest change described in: #9242. + -- Previous change: #3877, Dec 10. + where + -- `instB` can be instantiated to match `instA` + -- or the two are equal + instA `more_specific_than` instB + = isJust (tcMatchTys (is_tys instB) (is_tys instA)) + +insert_overlapping :: InstMatch -> InstMatches -> InstMatches +-- ^ Add a new solution, knocking out strictly less specific ones +-- See Note [Rules for instance lookup] and Note [Instance overlap and guards]. +-- +-- /Property/: the order of insertion doesn't matter, i.e. +-- @insert_overlapping inst1 (insert_overlapping inst2 matches)@ +-- gives the same result as @insert_overlapping inst2 (insert_overlapping inst1 matches)@. +insert_overlapping + new_item@(new_inst,_) + old@(InstMatches { instMatches = old_items, instGuards = guards }) + -- If any of the "guarding" instances override this item, discard it. + -- See Note [Instance overlap and guards], (B1). + | any (`overrides` new_inst) guards + = old + | otherwise + = insert_overlapping_new_item old_items + + where + insert_overlapping_new_item :: [InstMatch] -> InstMatches + insert_overlapping_new_item [] + = InstMatches { instMatches = [new_item], instGuards = guards } + insert_overlapping_new_item all_old_items@(old_item@(old_inst,_) : old_items) + + -- New strictly overrides old: throw out the old from the list of matches, + -- but potentially keep it around as a guard if it can still be used + -- to eliminate other instances. + | new_inst `overrides` old_inst + , InstMatches { instMatches = final_matches + , instGuards = prev_guards } + <- insert_overlapping_new_item old_items + = if isOverlapping new_inst || not (isOverlapping old_inst) + -- We're adding "new_inst" as a match. + -- If "new_inst" is not overlapping but "old_inst" is, we should + -- keep "old_inst" around as a guard. + -- See Note [Instance overlap and guards], (A). + then InstMatches { instMatches = final_matches + , instGuards = prev_guards } + else InstMatches { instMatches = final_matches + , instGuards = old_inst : prev_guards } + -- ^^^^^^^^^^^^^^^^^^^^^^ + -- See Note [Instance overlap and guards], (C). + + + -- Old strictly overrides new: throw it out from the list of matches, + -- but potentially keep it around as a guard if it can still be used + -- to eliminate other instances. + | old_inst `overrides` new_inst + = if isOverlapping old_inst || not (isOverlapping new_inst) + -- We're discarding "new_inst", as it is overridden by "old_inst". + -- However, it might still be useful as a guard if "old_inst" is not overlapping + -- but "new_inst" is. + -- See Note [Instance overlap and guards], (A). + then InstMatches { instMatches = all_old_items + , instGuards = guards } + else InstMatches + -- We're adding "new_inst" as a guard, so we must prune out + -- any matches it overrides. + -- See Note [Instance overlap and guards], (B2) + { instMatches = + filter + (\(old_inst,_) -> not (new_inst `overrides` old_inst)) + all_old_items + + -- See Note [Instance overlap and guards], (C) + , instGuards = new_inst : guards } + + -- Discard incoherent instances; see Note [Incoherent instances] + | isIncoherent old_inst -- Old is incoherent; discard it + = insert_overlapping_new_item old_items + | isIncoherent new_inst -- New is incoherent; discard it + = InstMatches { instMatches = all_old_items + , instGuards = guards } + + -- Equal or incomparable, and neither is incoherent; keep both + | otherwise + , InstMatches { instMatches = final_matches + , instGuards = final_guards } + <- insert_overlapping_new_item old_items + = InstMatches { instMatches = old_item : final_matches + , instGuards = final_guards } + +{- +Note [Incoherent instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some classes, the choice of a particular instance does not matter, any one +is good. E.g. consider + + class D a b where { opD :: a -> b -> String } + instance D Int b where ... + instance D a Int where ... + + g (x::Int) = opD x x -- Wanted: D Int Int + +For such classes this should work (without having to add an "instance D Int +Int", and using -XOverlappingInstances, which would then work). This is what +-XIncoherentInstances is for: Telling GHC "I don't care which instance you use; +if you can use one, use it." + +Should this logic only work when *all* candidates have the incoherent flag, or +even when all but one have it? The right choice is the latter, which can be +justified by comparing the behaviour with how -XIncoherentInstances worked when +it was only about the unify-check (Note [Overlapping instances]): + +Example: + class C a b c where foo :: (a,b,c) + instance C [a] b Int + instance {-# INCOHERENT #-} C [Int] b c + instance {-# INCOHERENT #-} C a Int c +Thanks to the incoherent flags, + [Wanted] C [a] b Int +works: Only instance one matches, the others just unify, but are marked +incoherent. + +So I can write + (foo :: ([a],b,Int)) :: ([Int], Int, Int). +but if that works then I really want to be able to write + foo :: ([Int], Int, Int) +as well. Now all three instances from above match. None is more specific than +another, so none is ruled out by the normal overlapping rules. One of them is +not incoherent, but we still want this to compile. Hence the +"all-but-one-logic". + +The implementation is in insert_overlapping, where we remove matching +incoherent instances as long as there are others. + +If the choice of instance *does* matter, all bets are still not off: +users can consult the detailed specification of the instance selection +algorithm in the GHC Users' Manual. However, this means we can end up +with different instances at the same types at different parts of the +program, and this difference has to be preserved. Note [Coherence and +specialisation: overview] details how we achieve that. + +************************************************************************ +* * + Binding decisions +* * +************************************************************************ +-} + +instanceBindFun :: BindTvFun +instanceBindFun tv _rhs_ty | isOverlappableTyVar tv = DontBindMe + | otherwise = BindMe + -- Note [Super skolems: binding when looking up instances] + +{- +Note [Super skolems: binding when looking up instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When looking up in the instance environment, or family-instance environment, +we are careful about multiple matches, as described above in +Note [Overlapping instances] + +The target tys can contain skolem constants. For existentials and instance variables, +we can guarantee that those +are never going to be instantiated to anything, so we should not involve +them in the unification test. These are called "super skolems". Example: + class Foo a where { op :: a -> Int } + instance Foo a => Foo [a] -- NB overlap + instance Foo [Int] -- NB overlap + data T = forall a. Foo a => MkT a + f :: T -> Int + f (MkT x) = op [x,x] +The op [x,x] means we need (Foo [a]). This `a` will never be instantiated, and +so it is a "super skolem". (See the use of tcInstSuperSkolTyVarsX in +GHC.Tc.Gen.Pat.tcDataConPat.) Super skolems respond True to +isOverlappableTyVar, and the use of DontBindMe in instanceBindFun, above, means +that these will be treated as fresh constants in the unification algorithm +during instance lookup. Without this treatment, GHC would complain, saying +that the choice of instance depended on the instantiation of 'a'; but of +course it isn't *going* to be instantiated. Note that it is necessary that +the unification algorithm returns SurelyApart for these super-skolems +for GHC to be able to commit to another instance. + +We do this only for super skolems. For example we reject + g :: forall a => [a] -> Int + g x = op x +on the grounds that the correct instance depends on the instantiation of 'a' +-} diff --git a/GHC/Core/LateCC.hs b/GHC/Core/LateCC.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/LateCC.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Adds cost-centers after the core pipline has run. +module GHC.Core.LateCC + ( -- * Inserting cost centres + addLateCostCenters + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.LateCC.OverloadedCalls +import GHC.Core.LateCC.TopLevelBinds +import GHC.Core.LateCC.Types +import GHC.Core.LateCC.Utils +import GHC.Core.Seq +import qualified GHC.Data.Strict as Strict +import GHC.Core.Utils +import GHC.Tc.Utils.TcType +import GHC.Types.SrcLoc +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Types.RepType (mightBeFunTy) + +-- | Late cost center insertion logic used by the driver +addLateCostCenters :: + Logger + -- ^ Logger + -> LateCCConfig + -- ^ Late cost center configuration + -> CoreProgram + -- ^ The program + -> IO (CoreProgram, LateCCState (Strict.Maybe SrcSpan)) +addLateCostCenters logger LateCCConfig{..} core_binds = do + + -- If top-level late CCs are enabled via either -fprof-late or + -- -fprof-late-overloaded, add them + (top_level_cc_binds, top_level_late_cc_state) <- + case lateCCConfig_whichBinds of + LateCCNone -> + return (core_binds, initLateCCState ()) + _ -> + withTiming + logger + (text "LateTopLevelCCs" <+> brackets (ppr this_mod)) + (\(binds, late_cc_state) -> seqBinds binds `seq` late_cc_state `seq` ()) + $ {-# SCC lateTopLevelCCs #-} do + pure $ + doLateCostCenters + lateCCConfig_env + (initLateCCState ()) + (topLevelBindsCC top_level_cc_pred) + core_binds + + -- If overloaded call CCs are enabled via -fprof-late-overloaded-calls, add + -- them + (late_cc_binds, late_cc_state) <- + if lateCCConfig_overloadedCalls then + withTiming + logger + (text "LateOverloadedCallsCCs" <+> brackets (ppr this_mod)) + (\(binds, late_cc_state) -> seqBinds binds `seq` late_cc_state `seq` ()) + $ {-# SCC lateoverloadedCallsCCs #-} do + pure $ + doLateCostCenters + lateCCConfig_env + (top_level_late_cc_state { lateCCState_extra = Strict.Nothing }) + overloadedCallsCC + top_level_cc_binds + else + return + ( top_level_cc_binds + , top_level_late_cc_state { lateCCState_extra = Strict.Nothing } + ) + + return (late_cc_binds, late_cc_state) + where + top_level_cc_pred :: CoreExpr -> Bool + top_level_cc_pred = + case lateCCConfig_whichBinds of + LateCCBinds -> \rhs -> + -- Make sure we record any functions. Even if it's something like `f = g`. + mightBeFunTy (exprType rhs) || + -- If the RHS is a CAF doing work also insert a CC. + not (exprIsWorkFree rhs) + LateCCOverloadedBinds -> + isOverloadedTy . exprType + LateCCNone -> + -- This is here for completeness, we won't actually use this + -- predicate in this case since we'll shortcut. + const False + + this_mod = lateCCEnv_module lateCCConfig_env diff --git a/GHC/Core/LateCC/OverloadedCalls.hs b/GHC/Core/LateCC/OverloadedCalls.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/LateCC/OverloadedCalls.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module GHC.Core.LateCC.OverloadedCalls + ( overloadedCallsCC + ) where + +import GHC.Prelude + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified GHC.Data.Strict as Strict + +import GHC.Data.FastString +import GHC.Core +import GHC.Core.LateCC.Utils +import GHC.Core.LateCC.Types +import GHC.Core.Make +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Utils +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Tickish +import GHC.Types.Var + +type OverloadedCallsCCState = Strict.Maybe SrcSpan + +{- Note [Overloaded Calls and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently GHC considers cost centres as destructive to +join contexts. Or in other words this is not considered valid: + + join f x = ... + in + ... -> scc jmp + +This makes the functionality of `-fprof-late-overloaded-calls` not feasible +for join points in general. We used to try to work around this by putting the +ticks on the rhs of the join point rather than around the jump. However beyond +the loss of accuracy this was broken for recursive join points as we ended up +with something like: + + rec-join f x = scc ... jmp f x + +Which similarly is not valid as the tick once again destroys the tail call. +One might think we could limit ourselves to non-recursive tail calls and do +something clever like: + + join f x = scc ... + in ... jmp f x + +And sometimes this works! But sometimes the full rhs would look something like: + + join g x = .... + join f x = scc ... -> jmp g x + +Which, would again no longer be valid. I believe in the long run we can make +cost centre ticks non-destructive to join points. Or we could keep track of +where we are/are not allowed to insert a cost centre. But in the short term I will +simply disable the annotation of join calls under this flag. +-} + +-- | Insert cost centres on function applications with dictionary arguments. The +-- source locations attached to the cost centres is approximated based on the +-- "closest" source note encountered in the traversal. +overloadedCallsCC :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind +overloadedCallsCC = + processBind + where + processBind :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind + processBind core_bind = + case core_bind of + NonRec b e -> + NonRec b <$> wrap_if_join b (processExpr e) + Rec es -> + Rec <$> mapM (\(b,e) -> (b,) <$> wrap_if_join b (processExpr e)) es + where + -- If an overloaded function is turned into a join point, we won't add + -- SCCs directly to calls since it makes them non-tail calls. Instead, + -- we look for join points here and add an SCC to their RHS if they are + -- overloaded. + wrap_if_join :: + CoreBndr + -> LateCCM OverloadedCallsCCState CoreExpr + -> LateCCM OverloadedCallsCCState CoreExpr + wrap_if_join _b pexpr = do + -- See Note [Overloaded Calls and join points] + expr <- pexpr + return expr + + processExpr :: CoreExpr -> LateCCM OverloadedCallsCCState CoreExpr + processExpr expr = + case expr of + -- The case we care about: Application + app@App{} -> do + -- Here we have some application like `f v1 ... vN`, where v1 ... vN + -- should be the function's type arguments followed by the value + -- arguments. To determine if the `f` is an overloaded function, we + -- check if any of the arguments v1 ... vN are dictionaries. + let + (f, xs) = collectArgs app + resultTy = applyTypeToArgs (exprType f) xs + + -- Recursively process the arguments first for no particular reason + args <- mapM processExpr xs + let app' = mkCoreApps f args + + if + -- Check if any of the arguments are dictionaries + any isDictExpr args + + -- Avoid instrumenting dictionary functions, which may be + -- overloaded if there are superclasses, by checking if the result + -- type of the function is a dictionary type. + && not (isDictTy resultTy) + + -- Avoid instrumenting constraint selectors like eq_sel + && (typeTypeOrConstraint resultTy /= ConstraintLike) + + -- Avoid instrumenting join points. + -- (See comment in processBind above) + -- Also see Note [Overloaded Calls and join points] + && not (isJoinVarExpr f) + then do + -- Extract a name and source location from the function being + -- applied + let + cc_name :: FastString + cc_name = + maybe (fsLit "") getOccFS (exprName app) + + cc_srcspan <- + fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $ + lift $ gets lateCCState_extra + + insertCC cc_name cc_srcspan app' + else + return app' + + -- For recursive constructors of Expr, we traverse the nested Exprs + Lam b e -> + mkCoreLams [b] <$> processExpr e + Let b e -> + mkCoreLet <$> processBind b <*> processExpr e + Case e b t alts -> + Case + <$> processExpr e + <*> pure b + <*> pure t + <*> mapM processAlt alts + Cast e co -> + mkCast <$> processExpr e <*> pure co + Tick t e -> do + trackSourceNote t $ + mkTick t <$> processExpr e + + -- For non-recursive constructors of Expr, we do nothing + x -> return x + + processAlt :: CoreAlt -> LateCCM OverloadedCallsCCState CoreAlt + processAlt (Alt c bs e) = Alt c bs <$> processExpr e + + trackSourceNote :: CoreTickish -> LateCCM OverloadedCallsCCState a -> LateCCM OverloadedCallsCCState a + trackSourceNote tick act = + case tick of + SourceNote rss _ -> do + -- Prefer source notes from the current file + in_current_file <- + maybe False ((== EQ) . lexicalCompareFS (srcSpanFile rss)) <$> + asks lateCCEnv_file + if not in_current_file then + act + else do + loc <- lift $ gets lateCCState_extra + lift . modify $ \s -> + s { lateCCState_extra = + Strict.Just $ RealSrcSpan rss mempty + } + x <- act + lift . modify $ \s -> + s { lateCCState_extra = loc + } + return x + _ -> + act + + -- Utility functions + + -- Extract a Name from an expression. If it is an application, attempt to + -- extract a name from the applied function. If it is a variable, return the + -- Name of the variable. If it is a tick/cast, attempt to extract a Name + -- from the expression held in the tick/cast. Otherwise return Nothing. + exprName :: CoreExpr -> Maybe Name + exprName = + \case + App f _ -> + exprName f + Var f -> + Just (idName f) + Tick _ e -> + exprName e + Cast e _ -> + exprName e + _ -> + Nothing + + -- Determine whether an expression is a dictionary + isDictExpr :: CoreExpr -> Bool + isDictExpr = + maybe False isDictTy . exprType' + where + exprType' :: CoreExpr -> Maybe Type + exprType' = \case + Type{} -> Nothing + expr -> Just $ exprType expr + + -- Determine whether an expression is a join variable + isJoinVarExpr :: CoreExpr -> Bool + isJoinVarExpr = + \case + Var var -> isJoinId var + Tick _ e -> isJoinVarExpr e + Cast e _ -> isJoinVarExpr e + _ -> False diff --git a/GHC/Core/LateCC/TopLevelBinds.hs b/GHC/Core/LateCC/TopLevelBinds.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/LateCC/TopLevelBinds.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TupleSections #-} +module GHC.Core.LateCC.TopLevelBinds where + +import GHC.Prelude + +import GHC.Core.LateCC.Types +import GHC.Core.LateCC.Utils + +import GHC.Core +import GHC.Core.Opt.Monad +import GHC.Driver.DynFlags +import GHC.Types.Id +import GHC.Types.Name +import GHC.Unit.Module.ModGuts + +import Data.Maybe + +{- Note [Collecting late cost centres] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Usually cost centres defined by a module are collected +during tidy by collectCostCentres. However with `-fprof-late` +we insert cost centres after inlining. So we keep a list of +all the cost centres we inserted and combine that with the list +of cost centres found during tidy. + +To avoid overhead when using -fprof-inline there is a flag to stop +us from collecting them here when we run this pass before tidy. + +Note [Adding late cost centres to top level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea is very simple. For a top level binder +`f = rhs` we compile it as if the user had written +`f = {-# SCC f #-} rhs`. + +If we do this after unfoldings for `f` have been created this +doesn't impact core-level optimizations at all. If we do it +before the cost centre will be included in the unfolding and +might inhibit optimizations at the call site. For this reason +we provide flags for both approaches as they have different +tradeoffs. + +To reduce overhead we ignore workfree bindings because they don't contribute +meaningfully to a performance profile. This reduces code size massively as it +allows us to allocate definitions like `val = Just 32` at compile time instead +of turning them into a CAF of the form `val = let x = Just 32 in x` which +would be the alternative. + +We make an exception for rhss with function types. This allows us to get +cost centres on eta-reduced definitions like `f = g`. By putting a tick onto +`f`s rhs we end up with + + f = \eta1 eta2 ... etan -> + g eta1 ... etan + +Which can make it easier to understand call graphs of an application. + +We also don't add a cost centre for any binder that is a constructor +worker or wrapper. These will never meaningfully enrich the resulting +profile so we improve efficiency by omitting those. + +-} + +-- | Add late cost centres directly to the 'ModGuts'. This is used inside the +-- core pipeline with the -fprof-late-inline flag. It should not be used after +-- tidy, since it does not manually track inserted cost centers. See +-- Note [Collecting late cost centres]. +topLevelBindsCCMG :: ModGuts -> CoreM ModGuts +topLevelBindsCCMG guts = do + dflags <- getDynFlags + let + env = + LateCCEnv + { lateCCEnv_module = mg_module guts + + -- We don't use this for topLevelBindsCC, so Nothing is okay + , lateCCEnv_file = Nothing + + , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags + , lateCCEnv_collectCCs = False + } + guts' = + guts + { mg_binds = + fst + ( doLateCostCenters + env + (initLateCCState ()) + (topLevelBindsCC (const True)) + (mg_binds guts) + ) + } + return guts' + +-- | Insert cost centres on top-level bindings in the module, depending on +-- whether or not they satisfy the given predicate. +topLevelBindsCC :: (CoreExpr -> Bool) -> CoreBind -> LateCCM s CoreBind +topLevelBindsCC pred core_bind = + case core_bind of + NonRec b rhs -> + NonRec b <$> doBndr b rhs + Rec bs -> + Rec <$> mapM doPair bs + where + doPair :: ((Id, CoreExpr) -> LateCCM s (Id, CoreExpr)) + doPair (b,rhs) = (b,) <$> doBndr b rhs + + doBndr :: Id -> CoreExpr -> LateCCM s CoreExpr + doBndr bndr rhs + -- Not a constructor worker. + -- Cost centres on constructor workers are pretty much useless so we don't emit them + -- if we are looking at the rhs of a constructor binding. + | isNothing (isDataConId_maybe bndr) + , pred rhs + = addCC bndr rhs + | otherwise = pure rhs + + -- We want to put the cost centre below the lambda as we only care about + -- executions of the RHS. Note that the lambdas might be hidden under ticks + -- or casts. So look through these as well. + addCC :: Id -> CoreExpr -> LateCCM s CoreExpr + addCC bndr (Cast rhs co) = pure Cast <*> addCC bndr rhs <*> pure co + addCC bndr (Tick t rhs) = (Tick t) <$> addCC bndr rhs + addCC bndr (Lam b rhs) = Lam b <$> addCC bndr rhs + addCC bndr rhs = do + let name = idName bndr + cc_loc = nameSrcSpan name + cc_name = getOccFS name + insertCC cc_name cc_loc rhs diff --git a/GHC/Core/LateCC/Types.hs b/GHC/Core/LateCC/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/LateCC/Types.hs @@ -0,0 +1,74 @@ +-- | Types related to late cost center insertion +module GHC.Core.LateCC.Types + ( LateCCConfig(..) + , LateCCBindSpec(..) + , LateCCEnv(..) + , LateCCState(..) + , initLateCCState + , LateCCM + ) where + +import GHC.Prelude + +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified Data.Set as S + +import GHC.Data.FastString +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State +import GHC.Unit.Types + +-- | Late cost center insertion configuration. +-- +-- Specifies whether cost centers are added to overloaded function call sites +-- and/or top-level bindings, and which top-level bindings they are added to. +-- Also holds the cost center insertion environment. +data LateCCConfig = + LateCCConfig + { lateCCConfig_whichBinds :: !LateCCBindSpec + , lateCCConfig_overloadedCalls :: !Bool + , lateCCConfig_env :: !LateCCEnv + } + +-- | The types of top-level bindings we support adding cost centers to. +data LateCCBindSpec = + LateCCNone + | LateCCBinds + | LateCCOverloadedBinds + +-- | Late cost centre insertion environment +data LateCCEnv = LateCCEnv + { lateCCEnv_module :: !Module + -- ^ Current module + , lateCCEnv_file :: Maybe FastString + -- ^ Current file, if we have one + , lateCCEnv_countEntries:: !Bool + -- ^ Whether the inserted cost centers should count entries + , lateCCEnv_collectCCs :: !Bool + -- ^ Whether to collect the cost centres we insert. See + -- Note [Collecting late cost centres] + + } + +-- | Late cost centre insertion state, indexed by some extra state type that an +-- insertion method may require. +data LateCCState s = LateCCState + { lateCCState_ccs :: !(S.Set CostCentre) + -- ^ Cost centres that have been inserted + , lateCCState_ccState :: !CostCentreState + -- ^ Per-module state tracking for cost centre indices + , lateCCState_extra :: !s + } + +-- | The empty late cost centre insertion state +initLateCCState :: s -> LateCCState s +initLateCCState s = + LateCCState + { lateCCState_ccState = newCostCentreState + , lateCCState_ccs = mempty + , lateCCState_extra = s + } + +-- | Late cost centre insertion monad +type LateCCM s = ReaderT LateCCEnv (State (LateCCState s)) diff --git a/GHC/Core/LateCC/Utils.hs b/GHC/Core/LateCC/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/LateCC/Utils.hs @@ -0,0 +1,80 @@ +module GHC.Core.LateCC.Utils + ( -- * Inserting cost centres + doLateCostCenters -- Might be useful for API users + + -- ** Helpers for defining insertion methods + , getCCFlavour + , insertCC + ) where + +import GHC.Prelude + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified Data.Set as S + +import GHC.Core +import GHC.Core.LateCC.Types +import GHC.Core.Utils +import GHC.Data.FastString +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State +import GHC.Types.SrcLoc +import GHC.Types.Tickish + +-- | Insert cost centres into the 'CoreProgram' using the provided environment, +-- initial state, and insertion method. +doLateCostCenters + :: LateCCEnv + -- ^ Environment to run the insertion in + -> LateCCState s + -- ^ Initial state to run the insertion with + -> (CoreBind -> LateCCM s CoreBind) + -- ^ Insertion method + -> CoreProgram + -- ^ Bindings to consider + -> (CoreProgram, LateCCState s) +doLateCostCenters env state method binds = + runLateCC env state $ mapM method binds + +-- | Evaluate late cost centre insertion +runLateCC :: LateCCEnv -> LateCCState s -> LateCCM s a -> (a, LateCCState s) +runLateCC env state = (`runState` state) . (`runReaderT` env) + +-- | Given the name of a cost centre, get its flavour +getCCFlavour :: FastString -> LateCCM s CCFlavour +getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name + where + getCCIndex' :: FastString -> LateCCM s CostCentreIndex + getCCIndex' name = do + cc_state <- lift $ gets lateCCState_ccState + let (index, cc_state') = getCCIndex name cc_state + lift . modify $ \s -> s { lateCCState_ccState = cc_state'} + return index + +-- | Insert a cost centre with the specified name and source span on the given +-- expression. The inserted cost centre will be appropriately tracked in the +-- late cost centre state. +insertCC + :: FastString + -- ^ Name of the cost centre to insert + -> SrcSpan + -- ^ Source location to associate with the cost centre + -> CoreExpr + -- ^ Expression to wrap in the cost centre + -> LateCCM s CoreExpr +insertCC cc_name cc_loc expr = do + cc_flavour <- getCCFlavour cc_name + env <- ask + let + cc_mod = lateCCEnv_module env + cc = NormalCC cc_flavour cc_name cc_mod cc_loc + note = ProfNote cc (lateCCEnv_countEntries env) True + when (lateCCEnv_collectCCs env) $ do + lift . modify $ \s -> + s { lateCCState_ccs = S.insert cc (lateCCState_ccs s) + } + return $ mkTick note expr + diff --git a/GHC/Core/Lint.hs b/GHC/Core/Lint.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Lint.hs @@ -0,0 +1,4017 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnboxedTuples #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +A ``lint'' pass to check for Core correctness. +See Note [Core Lint guarantee]. +-} + +module GHC.Core.Lint ( + LintPassResultConfig (..), + LintFlags (..), + StaticPtrCheck (..), + LintConfig (..), + WarnsAndErrs, + + lintCoreBindings', lintUnfolding, + lintPassResult, lintExpr, + lintAnnots, lintAxioms, + + -- ** Debug output + EndPassConfig (..), + endPassIO, + displayLintResults, dumpPassResult + ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags + +import GHC.Tc.Utils.TcType + ( ConcreteTvOrigin(..), ConcreteTyVars + , isFloatingPrimTy, isTyFamFree ) +import GHC.Tc.Types.Origin + ( FixedRuntimeRepOrigin(..) ) +import GHC.Unit.Module.ModGuts +import GHC.Platform + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Stats ( coreBindsStats ) +import GHC.Core.DataCon +import GHC.Core.Ppr +import GHC.Core.Coercion +import GHC.Core.Type as Type +import GHC.Core.Predicate( isCoVarType ) +import GHC.Core.Multiplicity +import GHC.Core.UsageEnv +import GHC.Core.TyCo.Rep -- checks validity of types/coercions +import GHC.Core.TyCo.Compare ( eqType, eqTypes, eqTypeIgnoringMultiplicity, eqForAllVis ) +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCon as TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.FamInstEnv( compatibleBranches ) +import GHC.Core.Unify +import GHC.Core.Opt.Arity ( typeArity, exprIsDeadEnd ) + +import GHC.Core.Opt.Monad + +import GHC.Types.Literal +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.SrcLoc +import GHC.Types.Tickish +import GHC.Types.Unique.FM ( isNullUFM, sizeUFM ) +import GHC.Types.RepType +import GHC.Types.Basic +import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv ) + +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim + +import GHC.Data.Bag +import GHC.Data.List.SetOps + +import GHC.Utils.Monad +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc +import GHC.Utils.Error +import qualified GHC.Utils.Error as Err +import GHC.Utils.Logger + +import GHC.Data.Pair +import GHC.Base (oneShot) +import GHC.Data.Unboxed + +import Control.Monad +import Data.Foldable ( for_, toList ) +import Data.List.NonEmpty ( NonEmpty(..), groupWith, nonEmpty ) +import Data.Maybe +import Data.IntMap.Strict ( IntMap ) +import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList ) + +{- +Note [Core Lint guarantee] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Core Lint is the type-checker for Core. Using it, we get the following guarantee: + +If all of: +1. Core Lint passes, +2. there are no unsafe coercions (i.e. unsafeEqualityProof), +3. all plugin-supplied coercions (i.e. PluginProv) are valid, and +4. all case-matches are complete +then running the compiled program will not seg-fault, assuming no bugs downstream +(e.g. in the code generator). This guarantee is quite powerful, in that it allows us +to decouple the safety of the resulting program from the type inference algorithm. + +However, do note point (4) above. Core Lint does not check for incomplete case-matches; +see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there, +an incomplete case-match might slip by Core Lint and cause trouble at runtime. + +Note [GHC Formalism] +~~~~~~~~~~~~~~~~~~~~ +This file implements the type-checking algorithm for System FC, the "official" +name of the Core language. Type safety of FC is heart of the claim that +executables produced by GHC do not have segmentation faults. Thus, it is +useful to be able to reason about System FC independently of reading the code. +To this purpose, there is a document core-spec.pdf built in docs/core-spec that +contains a formalism of the types and functions dealt with here. If you change +just about anything in this file or you change other types/functions throughout +the Core language (all signposted to this note), you should update that +formalism. See docs/core-spec/README for more info about how to do so. + +Note [check vs lint] +~~~~~~~~~~~~~~~~~~~~ +This file implements both a type checking algorithm and also general sanity +checking. For example, the "sanity checking" checks for TyConApp on the left +of an AppTy, which should never happen. These sanity checks don't really +affect any notion of type soundness. Yet, it is convenient to do the sanity +checks at the same time as the type checks. So, we use the following naming +convention: + +- Functions that begin with 'lint'... are involved in type checking. These + functions might also do some sanity checking. + +- Functions that begin with 'check'... are *not* involved in type checking. + They exist only for sanity checking. + +Issues surrounding variable naming, shadowing, and such are considered *not* +to be part of type checking, as the formalism omits these details. + +Summary of checks +~~~~~~~~~~~~~~~~~ +Checks that a set of core bindings is well-formed. The PprStyle and String +just control what we print in the event of an error. The Bool value +indicates whether we have done any specialisation yet (in which case we do +some extra checks). + +We check for + (a) type errors + (b) Out-of-scope type variables + (c) Out-of-scope local variables + (d) Ill-kinded types + (e) Incorrect unsafe coercions + +If we have done specialisation the we check that there are + (a) No top-level bindings of primitive (unboxed type) + +Note [Linting function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All saturated applications of funTyCon are represented with the FunTy constructor. +See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim + + We check this invariant in lintType. + +Note [Linting type lets] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the desugarer, it's very very convenient to be able to say (in effect) + let a = Type Bool in + let x::a = True in +That is, use a type let. See Note [Core type and coercion invariant] in "GHC.Core". +One place it is used is in mkWwBodies; see Note [Join points and beta-redexes] +in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this feature; I'm not sure). + +* Hence when linting we need to remember that a=Int, else we + might reject a correct program. So we carry a type substitution (in + this example [a -> Bool]) and apply this substitution before + comparing types. In effect, in Lint, type equality is always + equality-modulo-le-subst. This is in the le_subst field of + LintEnv. But nota bene: + + (SI1) The le_subst substitution is applied to types and coercions only + + (SI2) The result of that substitution is used only to check for type + equality, to check well-typed-ness, /but is then discarded/. + The result of substitution does not outlive the CoreLint pass. + + (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders. + +* The function + lintInTy :: Type -> LintM (Type, Kind) + returns a substituted type. + +* When we encounter a binder (like x::a) we must apply the substitution + to the type of the binding variable. lintBinders does this. + +* Clearly we need to clone tyvar binders as we go. + +* But take care (#17590)! We must also clone CoVar binders: + let a = TYPE (ty |> cv) + in \cv -> blah + blindly substituting for `a` might capture `cv`. + +* Alas, when cloning a coercion variable we might choose a unique + that happens to clash with an inner Id, thus + \cv_66 -> let wild_X7 = blah in blah + We decide to clone `cv_66` because it's already in scope. Fine, + choose a new unique. Aha, X7 looks good. So we check the lambda + body with le_subst of [cv_66 :-> cv_X7] + + This is all fine, even though we use the same unique as wild_X7. + As (SI2) says, we do /not/ return a new lambda + (\cv_X7 -> let wild_X7 = blah in ...) + We simply use the le_subst substitution in types/coercions only, when + checking for equality. + +* We still need to check that Id occurrences are bound by some + enclosing binding. We do /not/ use the InScopeSet for the le_subst + for this purpose -- it contains only TyCoVars. Instead we have a separate + le_ids for the in-scope Id binders. + +Sigh. We might want to explore getting rid of type-let! + +Note [Bad unsafe coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions +Linter introduces additional rules that checks improper coercion between +different types, called bad coercions. Following coercions are forbidden: + + (a) coercions between boxed and unboxed values; + (b) coercions between unlifted values of the different sizes, here + active size is checked, i.e. size of the actual value but not + the space allocated for value; + (c) coercions between floating and integral boxed values, this check + is not yet supported for unboxed tuples, as no semantics were + specified for that; + (d) coercions from / to vector type + (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be + coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules + (a-e) holds. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +We check the rules listed in Note [Invariants on join points] in GHC.Core. The +only one that causes any difficulty is the first: All occurrences must be tail +calls. To this end, along with the in-scope set, we remember in le_joins the +subset of in-scope Ids that are valid join ids. For example: + + join j x = ... in + case e of + A -> jump j y -- good + B -> case (jump j z) of -- BAD + C -> join h = jump j w in ... -- good + D -> let x = jump j v in ... -- BAD + +A join point remains valid in case branches, so when checking the A +branch, j is still valid. When we check the scrutinee of the inner +case, however, we set le_joins to empty, and catch the +error. Similarly, join points can occur free in RHSes of other join +points but not the RHSes of value bindings (thunks and functions). + +Note [Avoiding compiler perf traps when constructing error messages.] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's quite common to put error messages into a where clause when it might +be triggered by multiple branches. E.g. + + checkThing x y z = + case x of + X -> unless (correctX x) $ failWithL errMsg + Y -> unless (correctY y) $ failWithL errMsg + where + errMsg = text "My error involving:" $$ ppr x <+> ppr y + +However ghc will compile this to: + + checkThink x y z = + let errMsg = text "My error involving:" $$ ppr x <+> ppr y + in case x of + X -> unless (correctX x) $ failWithL errMsg + Y -> unless (correctY y) $ failWithL errMsg + +Putting the allocation of errMsg into the common non-error path. +One way to work around this is to turn errMsg into a function: + + checkThink x y z = + case x of + X -> unless (correctX x) $ failWithL (errMsg x y) + Y -> unless (correctY y) $ failWithL (errMsg x y) + where + errMsg x y = text "My error involving:" $$ ppr x <+> ppr y + +This way `errMsg` is a static function and it being defined in the common +path does not result in allocation in the hot path. This can be surprisingly +impactful. Changing `lint_app` reduced allocations for one test program I was +looking at by ~4%. + +Note [MCInfo for Lint] +~~~~~~~~~~~~~~~~~~~~~~ +When printing a Lint message, use the MCInfo severity so that the +message is printed on stderr rather than stdout (#13342). + +************************************************************************ +* * + Beginning and ending passes +* * +************************************************************************ +-} + +-- | Configuration for boilerplate operations at the end of a +-- compilation pass producing Core. +data EndPassConfig = EndPassConfig + { ep_dumpCoreSizes :: !Bool + -- ^ Whether core bindings should be dumped with the size of what they + -- are binding (i.e. the size of the RHS of the binding). + + , ep_lintPassResult :: !(Maybe LintPassResultConfig) + -- ^ Whether we should lint the result of this pass. + + , ep_namePprCtx :: !NamePprCtx + + , ep_dumpFlag :: !(Maybe DumpFlag) + + , ep_prettyPass :: !SDoc + + , ep_passDetails :: !SDoc + } + +endPassIO :: Logger + -> EndPassConfig + -> CoreProgram -> [CoreRule] + -> IO () +-- Used by the IO-is CorePrep too +endPassIO logger cfg binds rules + = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_namePprCtx cfg) mb_flag + (renderWithContext defaultSDocContext (ep_prettyPass cfg)) + (ep_passDetails cfg) binds rules + ; for_ (ep_lintPassResult cfg) $ \lp_cfg -> + lintPassResult logger lp_cfg binds + } + where + mb_flag = case ep_dumpFlag cfg of + Just flag | logHasDumpFlag logger flag -> Just flag + | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag + _ -> Nothing + +dumpPassResult :: Logger + -> Bool -- dump core sizes? + -> NamePprCtx + -> Maybe DumpFlag -- Just df => show details in a file whose + -- name is specified by df + -> String -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds rules + = do { forM_ mb_flag $ \flag -> do + logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr FormatCore dump_doc + + -- Report result size + -- This has the side effect of forcing the intermediate to be evaluated + -- if it's not already forced by a -ddump flag. + ; Err.debugTraceMsg logger 2 size_doc + } + + where + size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + + dump_doc = vcat [ nest 2 extra_info + , size_doc + , blankLine + , if dump_core_sizes + then pprCoreBindingsWithSize binds + else pprCoreBindings binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +{- +************************************************************************ +* * + Top-level interfaces +* * +************************************************************************ +-} + +data LintPassResultConfig = LintPassResultConfig + { lpr_diagOpts :: !DiagOpts + , lpr_platform :: !Platform + , lpr_makeLintFlags :: !LintFlags + , lpr_showLintWarnings :: !Bool + , lpr_passPpr :: !SDoc + , lpr_localsInScope :: ![Var] + } + +lintPassResult :: Logger -> LintPassResultConfig + -> CoreProgram -> IO () +lintPassResult logger cfg binds + = do { let warns_and_errs = lintCoreBindings' + (LintConfig + { l_diagOpts = lpr_diagOpts cfg + , l_platform = lpr_platform cfg + , l_flags = lpr_makeLintFlags cfg + , l_vars = lpr_localsInScope cfg + }) + binds + ; Err.showPass logger $ + "Core Linted result of " ++ + renderWithContext defaultSDocContext (lpr_passPpr cfg) + ; displayLintResults logger + (lpr_showLintWarnings cfg) (lpr_passPpr cfg) + (pprCoreBindings binds) warns_and_errs + } + +displayLintResults :: Logger + -> Bool -- ^ If 'True', display linter warnings. + -- If 'False', ignore linter warnings. + -> SDoc -- ^ The source of the linted program + -> SDoc -- ^ The linted program, pretty-printed + -> WarnsAndErrs + -> IO () +displayLintResults logger display_warnings pp_what pp_pgm (warns, errs) + | not (isEmptyBag errs) + = do { logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] + $ withPprStyle defaultDumpStyle + (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs + , text "*** Offending Program ***" + , pp_pgm + , text "*** End of Offense ***" ]) + ; Err.ghcExit logger 1 } + + | not (isEmptyBag warns) + , log_enable_debug (logFlags logger) + , display_warnings + = logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] + $ withPprStyle defaultDumpStyle + (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) + + | otherwise = return () + +lint_banner :: String -> SDoc -> SDoc +lint_banner string pass = text "*** Core Lint" <+> text string + <+> text ": in result of" <+> pass + <+> text "***" + +-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. +lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs +-- Returns (warnings, errors) +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreBindings' cfg binds + = initL cfg $ + addLoc TopLevelBindings $ + do { -- Check that all top-level binders are distinct + -- We do not allow [NonRec x=1, NonRec y=x, NonRec x=2] + -- because of glomming; see Note [Glomming] in GHC.Core.Opt.OccurAnal + checkL (null dups) (dupVars dups) + + -- Check for External top level binders with the same M.n name + ; checkL (null ext_dups) (dupExtVars ext_dups) + + -- Typecheck the bindings + ; lintRecBindings TopLevel all_pairs $ \_ -> + return () } + where + all_pairs = flattenBinds binds + -- Put all the top-level binders in scope at the start + -- This is because rewrite rules can bring something + -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal" + binders = map fst all_pairs + + (_, dups) = removeDups compare binders + + -- ext_dups checks for names with different uniques + -- but the same External name M.n. We don't + -- allow this at top level: + -- M.n{r3} = ... + -- M.n{r29} = ... + -- because they both get the same linker symbol + ext_dups = snd $ removeDupsOn ord_ext $ + filter isExternalName $ map Var.varName binders + ord_ext n = (nameModule n, nameOccName n) + +{- +************************************************************************ +* * +\subsection[lintUnfolding]{lintUnfolding} +* * +************************************************************************ + +Note [Linting Unfoldings from Interfaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use this to check all top-level unfoldings that come in from interfaces +(it is very painful to catch errors otherwise). + +We do not need to call lintUnfolding on unfoldings that are nested within +top-level unfoldings; they are linted when we lint the top-level unfolding; +hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore. + +-} + +lintUnfolding :: Bool -- ^ True <=> is a compulsory unfolding + -> LintConfig + -> SrcLoc + -> CoreExpr + -> Maybe (Bag SDoc) -- Nothing => OK + +lintUnfolding is_compulsory cfg locn expr + | isEmptyBag errs = Nothing + | otherwise = Just errs + where + (_warns, errs) = initL cfg $ + if is_compulsory + -- See Note [Checking for representation polymorphism] + then noFixedRuntimeRepChecks linter + else linter + linter = addLoc (ImportedUnfolding locn) $ + lintCoreExpr expr + +lintExpr :: LintConfig + -> CoreExpr + -> Maybe (Bag SDoc) -- Nothing => OK + +lintExpr cfg expr + | isEmptyBag errs = Nothing + | otherwise = Just errs + where + (_warns, errs) = initL cfg linter + linter = addLoc TopLevelBindings $ + lintCoreExpr expr + +{- +************************************************************************ +* * +\subsection[lintCoreBinding]{lintCoreBinding} +* * +************************************************************************ + +Check a core binding, returning the list of variables bound. +-} + +-- Returns a UsageEnv because this function is called in lintCoreExpr for +-- Let + +lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)] + -> ([OutId] -> LintM a) -> LintM (a, [UsageEnv]) +lintRecBindings top_lvl pairs thing_inside + = lintIdBndrs top_lvl bndrs $ \ bndrs' -> + do { ues <- zipWithM lint_pair bndrs' rhss + ; a <- thing_inside bndrs' + ; return (a, ues) } + where + (bndrs, rhss) = unzip pairs + lint_pair bndr' rhs + = addLoc (RhsOf bndr') $ + do { (rhs_ty, ue) <- lintRhs bndr' rhs -- Check the rhs + ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty + ; return ue } + +lintLetBody :: LintLocInfo -> [OutId] -> CoreExpr -> LintM (OutType, UsageEnv) +lintLetBody loc bndrs body + = do { (body_ty, body_ue) <- addLoc loc (lintCoreExpr body) + ; mapM_ (lintJoinBndrType body_ty) bndrs + ; return (body_ty, body_ue) } + +lintLetBind :: TopLevelFlag -> RecFlag -> OutId + -> CoreExpr -> OutType -> LintM () +-- Binder's type, and the RHS, have already been linted +-- This function checks other invariants +lintLetBind top_lvl rec_flag binder rhs rhs_ty + = do { let binder_ty = idType binder + ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty) + + -- If the binding is for a CoVar, the RHS should be (Coercion co) + -- See Note [Core type and coercion invariant] in GHC.Core + ; checkL (not (isCoVar binder) || isCoArg rhs) + (mkLetErr binder rhs) + + -- Check the let-can-float invariant + -- See Note [Core let-can-float invariant] in GHC.Core + ; checkL ( isJoinId binder + || mightBeLiftedType binder_ty + || (isNonRec rec_flag && exprOkForSpeculation rhs) + || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed + || exprIsTickedString rhs) + (badBndrTyMsg binder (text "unlifted")) + + -- Check that if the binder is at the top level and has type Addr#, + -- that it is a string literal. + -- See Note [Core top-level string literals]. + ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy) + || exprIsTickedString rhs) + (mkTopNonLitStrMsg binder) + + ; flags <- getLintFlags + + -- Check that a join-point binder has a valid type + -- NB: lintIdBinder has checked that it is not top-level bound + ; case idJoinPointHood binder of + NotJoinPoint -> return () + JoinPoint arity -> checkL (isValidJoinPointType arity binder_ty) + (mkInvalidJoinPointMsg binder binder_ty) + + ; when (lf_check_inline_loop_breakers flags + && isStableUnfolding (realIdUnfolding binder) + && isStrongLoopBreaker (idOccInfo binder) + && isInlinePragma (idInlinePragma binder)) + (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) + -- Only non-rule loop breakers inhibit inlining + + -- We used to check that the dmdTypeDepth of a demand signature never + -- exceeds idArity, but that is an unnecessary complication, see + -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal + + -- Check that the binder's arity is within the bounds imposed by the type + -- and the strictness signature. See Note [Arity invariants for bindings] + -- and Note [Trimming arity] + + ; checkL (typeArity (idType binder) >= idArity binder) + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds typeArity" <+> + ppr (typeArity (idType binder)) <> colon <+> + ppr binder) + + -- See Note [idArity varies independently of dmdTypeDepth] + -- in GHC.Core.Opt.DmdAnal + ; case splitDmdSig (idDmdSig binder) of + (demands, result_info) | isDeadEndDiv result_info -> + if (demands `lengthAtLeast` idArity binder) + then return () + else pprTrace "Hack alert: lintLetBind #24623" + (ppr (idArity binder) $$ ppr (idDmdSig binder)) $ + return () +-- checkL (demands `lengthAtLeast` idArity binder) +-- (text "idArity" <+> ppr (idArity binder) <+> +-- text "exceeds arity imposed by the strictness signature" <+> +-- ppr (idDmdSig binder) <> colon <+> +-- ppr binder) + + _ -> return () + + ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + + ; addLoc (UnfoldingOf binder) $ + lintIdUnfolding binder binder_ty (idUnfolding binder) + ; return () } + + -- We should check the unfolding, if any, but this is tricky because + -- the unfolding is a SimplifiableCoreExpr. Give up for now. + +-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' +-- in that it doesn't reject occurrences of the function 'makeStatic' when they +-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and +-- for join points, it skips the outer lambdas that take arguments to the +-- join point. +-- +-- See Note [Checking StaticPtrs]. +lintRhs :: Id -> CoreExpr -> LintM (OutType, UsageEnv) +-- NB: the Id can be Linted or not -- it's only used for +-- its OccInfo and join-pointer-hood +lintRhs bndr rhs + | JoinPoint arity <- idJoinPointHood bndr + = lintJoinLams arity (Just bndr) rhs + | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) + = lintJoinLams arity Nothing rhs + +-- Allow applications of the data constructor @StaticPtr@ at the top +-- but produce errors otherwise. +lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go + where + -- Allow occurrences of 'makeStatic' at the top-level but produce errors + -- otherwise. + go :: StaticPtrCheck -> LintM (OutType, UsageEnv) + go AllowAtTopLevel + | (binders0, rhs') <- collectTyBinders rhs + , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' + = markAllJoinsBad $ + foldr + -- imitate @lintCoreExpr (Lam ...)@ + lintLambda + -- imitate @lintCoreExpr (App ...)@ + (do fun_ty_ue <- lintCoreExpr fun + lintCoreArgs fun_ty_ue [Type t, info, e] + ) + binders0 + go _ = markAllJoinsBad $ lintCoreExpr rhs + +-- | Lint the RHS of a join point with expected join arity of @n@ (see Note +-- [Join points] in "GHC.Core"). +lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (OutType, UsageEnv) +lintJoinLams join_arity enforce rhs + = go join_arity rhs + where + go 0 expr = lintCoreExpr expr + go n (Lam var body) = lintLambda var $ go (n-1) body + go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas + = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs + | otherwise -- Future join point, not yet eta-expanded + = markAllJoinsBad $ lintCoreExpr expr + -- Body of lambda is not a tail position + +lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () +lintIdUnfolding bndr bndr_ty uf + | isStableUnfolding uf + , Just rhs <- maybeUnfoldingTemplate uf + = do { ty <- fst <$> (if isCompulsoryUnfolding uf + then noFixedRuntimeRepChecks $ lintRhs bndr rhs + -- ^^^^^^^^^^^^^^^^^^^^^^^ + -- See Note [Checking for representation polymorphism] + else lintRhs bndr rhs) + ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } +lintIdUnfolding _ _ _ + = return () -- Do not Lint unstable unfoldings, because that leads + -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + +{- Note [Checking for INLINE loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very suspicious if a strong loop breaker is marked INLINE. + +However, the desugarer generates instance methods with INLINE pragmas +that form a mutually recursive group. Only after a round of +simplification are they unravelled. So we suppress the test for +the desugarer. Here is an example: + instance Eq T where + t1 == t2 = blah + t1 /= t2 = not (t1 == t2) + {-# INLINE (/=) #-} + +This will generate something like + -- From the class decl for Eq + data Eq a = EqDict (a->a->Bool) (a->a->Bool) + eq_sel :: Eq a -> (a->a->Bool) + eq_sel (EqDict eq _) = eq + + -- From the instance Eq T + $ceq :: T -> T -> Bool + $ceq = blah + + Rec { $dfEqT :: Eq T {-# DFunId #-} + $dfEqT = EqDict $ceq $cnoteq + + $cnoteq :: T -> T -> Bool {-# INLINE #-} + $cnoteq x y = not (eq_sel $dfEqT x y) } + +Notice that + +* `$dfEqT` and `$cnotEq` are mutually recursive. + +* We do not want `$dfEqT` to be the loop breaker: it's a DFunId, and + we want to let it "cancel" with "eq_sel" (see Note [ClassOp/DFun + selection] in GHC.Tc.TyCl.Instance, which it can't do if it's a loop + breaker. + +So we make `$cnoteq` into the loop breaker. That means it can't +inline, despite the INLINE pragma. That's what gives rise to the +warning, which is perfectly appropriate for, say + Rec { {-# INLINE f #-} f = \x -> ...f.... } +We can't inline a recursive function -- it's a loop breaker. + +But now we can optimise `eq_sel $dfEqT` to `$ceq`, so we get + Rec { + $dfEqT :: Eq T {-# DFunId #-} + $dfEqT = EqDict $ceq $cnoteq + + $cnoteq :: T -> T -> Bool {-# INLINE #-} + $cnoteq x y = not ($ceq x y) } + +and now the dependencies of the Rec have gone, and we can split it up to give + NonRec { $dfEqT :: Eq T {-# DFunId #-} + $dfEqT = EqDict $ceq $cnoteq } + + NonRec { $cnoteq :: T -> T -> Bool {-# INLINE #-} + $cnoteq x y = not ($ceq x y) } + +Now $cnoteq is not a loop breaker any more, so the INLINE pragma can +take effect -- the warning turned out to be temporary. + +To stop excessive warnings, this warning for INLINE loop breakers is +switched off when linting the result of the desugarer. See +lf_check_inline_loop_breakers in GHC.Core.Lint. + + +Note [Checking for representation polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We ordinarily want to check for bad representation polymorphism. See +Note [Representation polymorphism invariants] in GHC.Core. However, we do *not* +want to do this in a compulsory unfolding. Compulsory unfoldings arise +only internally, for things like newtype wrappers, dictionaries, and +(notably) unsafeCoerce#. These might legitimately be representation-polymorphic; +indeed representation-polymorphic unfoldings are a primary reason for the +very existence of compulsory unfoldings (we can't compile code for +the original, representation-polymorphic, binding). + +It is vitally important that we do representation polymorphism checks *after* +performing the unfolding, but not beforehand. This is all safe because +we will check any unfolding after it has been unfolded; checking the +unfolding beforehand is merely an optimization, and one that actively +hurts us here. + +Note [Linting of runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~ +runRW# has some very special behavior (see Note [runRW magic] in +GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing +join points in its argument. For example, this is fine: + + join j x = ... + in runRW# (\s. case v of + A -> j 3 + B -> j 4) + +Usually those calls to the join point 'j' would not be valid tail calls, +because they occur in a function argument. But in the case of runRW# +they are fine, because runRW# (\s.e) behaves operationally just like e. +(runRW# is ultimately inlined in GHC.CoreToStg.Prep.) + +In the case that the continuation is /not/ a lambda we simply disable this +special behaviour. For example, this is /not/ fine: + + join j = ... + in runRW# @r @ty (jump j) + +Note [Coercions in terms] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The expression (Type ty) can occur only as the argument of an application, +or the RHS of a non-recursive Let. But what about (Coercion co)? + +Currently it appears in ghc-prim:GHC.Types.coercible_sel, a WiredInId whose +definition is: + coercible_sel :: Coercible a b => (a ~R# b) + coercible_sel d = case d of + MkCoercibleDict (co :: a ~# b) -> Coercion co + +So this function has a (Coercion co) in the alternative of a case. + +Richard says (!11908): it shouldn't appear outside of arguments, but we've been +loose about this. coercible_sel is some thin ice. Really we should be unpacking +Coercible using case, not a selector. I recall looking into this a few years +back and coming to the conclusion that the fix was worse than the disease. Don't +remember the details, but could probably recover it if we want to revisit. + +So Lint current accepts (Coercion co) in arbitrary places. There is no harm in +that: it really is a value, albeit a zero-bit value. + +************************************************************************ +* * +\subsection[lintCoreExpr]{lintCoreExpr} +* * +************************************************************************ +-} + +lintCoreExpr :: InExpr -> LintM (OutType, UsageEnv) +-- The returned type has the substitution from the monad +-- already applied to it: +-- lintCoreExpr e subst = exprType (subst e) +-- +-- The returned "type" can be a kind, if the expression is (Type ty) + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] + +lintCoreExpr (Var var) + = do { var_pair@(var_ty, _) <- lintIdOcc var 0 + -- See Note [Linting representation-polymorphic builtins] + ; checkRepPolyBuiltin (Var var) [] var_ty + --checkDataToTagPrimOpTyCon (Var var) [] + ; return var_pair } + +lintCoreExpr (Lit lit) + = return (literalType lit, zeroUE) + +lintCoreExpr (Cast expr co) + = do { (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr) + -- markAllJoinsBad: see Note [Join points and casts] + + ; lintCoercion co + ; lintRole co Representational (coercionRole co) + ; Pair from_ty to_ty <- substCoKindM co + ; checkValueType (typeKind to_ty) $ + text "target of cast" <+> quotes (ppr co) + ; ensureEqTys from_ty expr_ty (mkCastErr expr co from_ty expr_ty) + ; return (to_ty, ue) } + +lintCoreExpr (Tick tickish expr) + = do { case tickish of + Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0 + _ -> return () + ; markAllJoinsBadIf block_joins $ lintCoreExpr expr } + where + block_joins = not (tickish `tickishScopesLike` SoftScope) + -- TODO Consider whether this is the correct rule. It is consistent with + -- the simplifier's behaviour - cost-centre-scoped ticks become part of + -- the continuation, and thus they behave like part of an evaluation + -- context, but soft-scoped and non-scoped ticks simply wrap the result + -- (see Simplify.simplTick). + +lintCoreExpr (Let (NonRec tv (Type ty)) body) + | isTyVar tv + = -- See Note [Linting type lets] + do { ty' <- lintTypeAndSubst ty + ; lintTyCoBndr tv $ \ tv' -> + do { addLoc (RhsOf tv) $ lintTyKind tv' ty' + -- Now extend the substitution so we + -- take advantage of it in the body + ; extendTvSubstL tv ty' $ + addLoc (BodyOfLet tv) $ + lintCoreExpr body } } + +lintCoreExpr (Let (NonRec bndr rhs) body) + | isId bndr + = do { -- First Lint the RHS, before bringing the binder into scope + (rhs_ty, let_ue) <- lintRhs bndr rhs + + -- See Note [Multiplicity of let binders] in Var + -- Now lint the binder + ; lintBinder LetBind bndr $ \bndr' -> + do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty + ; addAliasUE bndr' let_ue $ + lintLetBody (BodyOfLet bndr') [bndr'] body } } + + | otherwise + = failWithL (mkLetErr bndr rhs) -- Not quite accurate + +lintCoreExpr e@(Let (Rec pairs) body) + = do { -- Check that the list of pairs is non-empty + checkL (not (null pairs)) (emptyRec e) + + -- Check that there are no duplicated binders + ; let (_, dups) = removeDups compare bndrs + ; checkL (null dups) (dupVars dups) + + -- Check that either all the binders are joins, or none + ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ + mkInconsistentRecMsg bndrs + + -- See Note [Multiplicity of let binders] in Var + ; ((body_type, body_ue), ues) <- + lintRecBindings NotTopLevel pairs $ \ bndrs' -> + lintLetBody (BodyOfLetRec bndrs') bndrs' body + ; return (body_type, body_ue `addUE` scaleUE ManyTy (foldr1WithDefault zeroUE addUE ues)) } + where + bndrs = map fst pairs + +lintCoreExpr e@(App _ _) + | Var fun <- fun + , fun `hasKey` runRWKey + -- See Note [Linting of runRW#] + -- N.B. we may have an over-saturated application of the form: + -- runRW (\s -> \x -> ...) y + , ty_arg1 : ty_arg2 : cont_arg : rest <- args + = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (OutType, UsageEnv) + lint_rw_cont expr@(Lam _ _) mult fun_ue + = do { (arg_ty, arg_ue) <- lintJoinLams 1 (Just fun) expr + ; let app_ue = addUE fun_ue (scaleUE mult arg_ue) + ; return (arg_ty, app_ue) } + + lint_rw_cont expr mult ue + = lintValArg expr mult ue + -- TODO: Look through ticks? + + ; runrw_pr <- lintApp (text "runRW# expression") + lintTyArg lint_rw_cont + (idType fun) [ty_arg1,ty_arg2,cont_arg] zeroUE + ; lintCoreArgs runrw_pr rest } + + | otherwise + = do { fun_pair <- lintCoreFun fun (length args) + ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args + + -- See Note [Linting representation-polymorphic builtins] + ; checkRepPolyBuiltin fun args app_ty + ; --checkDataToTagPrimOpTyCon fun args + + ; return app_pair} + where + skipTick t = case collectFunSimple e of + (Var v) -> etaExpansionTick v t + _ -> tickishFloatable t + (fun, args, _source_ticks) = collectArgsTicks skipTick e + -- We must look through source ticks to avoid #21152, for example: + -- + -- reallyUnsafePtrEquality + -- = \ @a -> + -- (src reallyUnsafePtrEquality#) + -- @Lifted @a @Lifted @a + -- + -- To do this, we use `collectArgsTicks tickishFloatable` to match + -- the eta expansion behaviour, as per Note [Eta expansion and source notes] + -- in GHC.Core.Opt.Arity. + -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow. + -- See Note [Ticks and mandatory eta expansion] + +lintCoreExpr (Lam var expr) + = markAllJoinsBad $ + lintLambda var $ lintCoreExpr expr + +lintCoreExpr (Case scrut var alt_ty alts) + = lintCaseExpr scrut var alt_ty alts + +-- This case can't happen; linting types in expressions gets routed through lintTyArg +lintCoreExpr (Type ty) + = failWithL (text "Type found as expression" <+> ppr ty) + +lintCoreExpr (Coercion co) + -- See Note [Coercions in terms] + = do { addLoc (InCo co) $ lintCoercion co + ; ty <- substTyM (coercionType co) + ; return (ty, zeroUE) } + +---------------------- +lintIdOcc :: InId -> Int -- Number of arguments (type or value) being passed + -> LintM (OutType, UsageEnv) -- returns type of the *variable* +lintIdOcc in_id nargs + = addLoc (OccOf in_id) $ + do { checkL (isNonCoVarId in_id) + (text "Non term variable" <+> ppr in_id) + -- See GHC.Core Note [Variable occurrences in Core] + + -- Check that the type of the occurrence is the same + -- as the type of the binding site. The inScopeIds are + -- /un-substituted/, so this checks that the occurrence type + -- is identical to the binder type. + -- This makes things much easier for things like: + -- /\a. \(x::Maybe a). /\a. ...(x::Maybe a)... + -- The "::Maybe a" on the occurrence is referring to the /outer/ a. + -- If we compared /substituted/ types we'd risk comparing + -- (Maybe a) from the binding site with bogus (Maybe a1) from + -- the occurrence site. Comparing un-substituted types finesses + -- this altogether + ; out_ty <- lintVarOcc in_id + + -- Check for a nested occurrence of the StaticPtr constructor. + -- See Note [Checking StaticPtrs]. + ; lf <- getLintFlags + ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ + checkL (idName in_id /= makeStaticName) $ + text "Found makeStatic nested in an expression" + + ; checkDeadIdOcc in_id + + ; case isDataConId_maybe in_id of + Nothing -> return () + Just dc -> checkTypeDataConOcc "expression" dc + + ; checkJoinOcc in_id nargs + ; usage <- varCallSiteUsage in_id + + ; return (out_ty, usage) } + + + +lintCoreFun :: CoreExpr + -> Int -- Number of arguments (type or val) being passed + -> LintM (OutType, UsageEnv) -- Returns type of the *function* +lintCoreFun (Var var) nargs + = lintIdOcc var nargs + +lintCoreFun (Lam var body) nargs + -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; + -- See Note [Beta redexes] + | nargs /= 0 + = lintLambda var $ lintCoreFun body (nargs - 1) + +lintCoreFun expr nargs + = markAllJoinsBadIf (nargs /= 0) $ + -- See Note [Join points are less general than the paper] + lintCoreExpr expr +------------------ +lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv) +lintLambda var lintBody = + addLoc (LambdaBodyOf var) $ + lintBinder LambdaBind var $ \ var' -> + do { (body_ty, ue) <- lintBody + ; ue' <- checkLinearity ue var' + ; return (mkLamType var' body_ty, ue') } +------------------ +checkDeadIdOcc :: Id -> LintM () +-- Occurrences of an Id should never be dead.... +-- except when we are checking a case pattern +checkDeadIdOcc id + | isDeadOcc (idOccInfo id) + = do { in_case <- inCasePat + ; checkL in_case + (text "Occurrence of a dead Id" <+> ppr id) } + | otherwise + = return () + +------------------ +lintJoinBndrType :: OutType -- Type of the body + -> OutId -- Possibly a join Id + -> LintM () +-- Checks that the return type of a join Id matches the body +-- E.g. join j x = rhs in body +-- The type of 'rhs' must be the same as the type of 'body' +lintJoinBndrType body_ty bndr + | JoinPoint arity <- idJoinPointHood bndr + , let bndr_ty = idType bndr + , (bndrs, res) <- splitPiTys bndr_ty + = checkL (length bndrs >= arity + && body_ty `eqType` mkPiTys (drop arity bndrs) res) $ + hang (text "Join point returns different type than body") + 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr) + , text "Join arity:" <+> ppr arity + , text "Body type:" <+> ppr body_ty ]) + | otherwise + = return () + +checkJoinOcc :: Id -> JoinArity -> LintM () +-- Check that if the occurrence is a JoinId, then so is the +-- binding site, and it's a valid join Id +checkJoinOcc var n_args + | JoinPoint join_arity_occ <- idJoinPointHood var + = do { mb_join_arity_bndr <- lookupJoinId var + ; case mb_join_arity_bndr of { + NotJoinPoint -> do { join_set <- getValidJoins + ; addErrL (text "join set " <+> ppr join_set $$ + invalidJoinOcc var) } ; + + JoinPoint join_arity_bndr -> + + do { checkL (join_arity_bndr == join_arity_occ) $ + -- Arity differs at binding site and occurrence + mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ + + ; checkL (n_args == join_arity_occ) $ + -- Arity doesn't match #args + mkBadJumpMsg var join_arity_occ n_args } } } + + | otherwise + = return () + +checkTypeDataConOcc :: String -> DataCon -> LintM () +-- Check that the Id is not a data constructor of a `type data` declaration +-- Invariant (I1) of Note [Type data declarations] in GHC.Rename.Module +checkTypeDataConOcc what dc + = checkL (not (isTypeDataTyCon (dataConTyCon dc))) $ + (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) + +{- +-- | Check that a use of a dataToTag# primop satisfies conditions DTT2 +-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class +-- +-- Ignores applications not headed by dataToTag# primops. + +-- Commented out because GHC.PrimopWrappers doesn't respect this condition yet. +-- See wrinkle DTW7 in Note [DataToTag overview]. +checkDataToTagPrimOpTyCon + :: CoreExpr -- ^ the function (head of the application) we are checking + -> [CoreArg] -- ^ The arguments to the application + -> LintM () +checkDataToTagPrimOpTyCon (Var fun_id) args + | Just op <- isPrimOpId_maybe fun_id + , op == DataToTagSmallOp || op == DataToTagLargeOp + = case args of + Type _levity : Type dty : _rest + | Just (tc, _) <- splitTyConApp_maybe dty + , isValidDTT2TyCon tc + -> do platform <- getPlatform + let numConstrs = tyConFamilySize tc + isSmallOp = op == DataToTagSmallOp + checkL (isSmallFamily platform numConstrs == isSmallOp) $ + text "dataToTag# primop-size/tycon-family-size mismatch" + | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:" + <+> ppr dty + _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:" + <+> ppr (take 2 args) + +checkDataToTagPrimOpTyCon _ _ = pure () +-} + +-- | Check representation-polymorphic invariants in an application of a +-- built-in function or newtype constructor. +-- +-- See Note [Linting representation-polymorphic builtins]. +checkRepPolyBuiltin :: CoreExpr -- ^ the function (head of the application) we are checking + -> [CoreArg] -- ^ the arguments to the application + -> OutType -- ^ the instantiated type of the overall application + -> LintM () +checkRepPolyBuiltin (Var fun_id) args app_ty + = do { do_rep_poly_checks <- lf_check_fixed_rep <$> getLintFlags + ; when (do_rep_poly_checks && hasNoBinding fun_id) $ + if + -- (2) representation-polymorphic unlifted newtypes + | Just dc <- isDataConId_maybe fun_id + , isNewDataCon dc + -> if tcHasFixedRuntimeRep $ dataConTyCon dc + then return () + else checkRepPolyNewtypeApp dc args app_ty + + -- (1) representation-polymorphic builtins + | otherwise + -> checkRepPolyBuiltinApp fun_id args + } +checkRepPolyBuiltin _ _ _ = return () + +checkRepPolyNewtypeApp :: DataCon -> [CoreArg] -> OutType -> LintM () +checkRepPolyNewtypeApp nt args app_ty + -- If the newtype is saturated, we're OK. + | any isValArg args + = return () + -- Otherwise, check we can eta-expand. + | otherwise + = case getRuntimeArgTys app_ty of + (Scaled _ first_val_arg_ty, _):_ + | not $ typeHasFixedRuntimeRep first_val_arg_ty + -> failWithL (err_msg first_val_arg_ty) + _ -> return () + + where + + err_msg :: Type -> SDoc + err_msg bad_arg_ty + = vcat [ text "Cannot eta expand unlifted newtype constructor" <+> quotes (ppr nt) <> dot + , text "Its argument type does not have a fixed runtime representation:" + , nest 2 $ ppr_ty_ki bad_arg_ty ] + + ppr_ty_ki :: Type -> SDoc + ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty) + +checkRepPolyBuiltinApp :: Id -> [CoreArg] -> LintM () +checkRepPolyBuiltinApp fun_id args = checkL (null not_concs) err_msg + where + + conc_binder_positions :: IntMap ConcreteTvOrigin + conc_binder_positions + = concreteTyVarPositions fun_id + $ idDetailsConcreteTvs + $ idDetails fun_id + + max_pos :: Int + max_pos = + case nonEmpty $ IntMap.keys conc_binder_positions of + Nothing -> 0 + Just positions -> maximum positions + + not_concs :: [(SDoc, ConcreteTvOrigin)] + not_concs = + mapMaybe is_bad (zip [1..max_pos] (map Just args ++ repeat Nothing)) + -- NB: 1-indexed + + is_bad :: (Int, Maybe CoreArg) -> Maybe (SDoc, ConcreteTvOrigin) + is_bad (pos, mb_arg) + | Just conc_reason <- IntMap.lookup pos conc_binder_positions + , Just bad_ty <- case mb_arg of + Just (Type ki) + | isConcreteType ki + -> Nothing + | otherwise + -- Here we handle the situation in which a "must be concrete" TyVar + -- has been instantiated with a type that is not concrete. + -> Just $ quotes (ppr ki) <+> text "is not concrete." + -- We expected a type argument in this position, and got something else: panic! + Just arg -> + pprPanic "checkRepPolyBuiltinApp: expected a type in this position" $ + vcat [ text "fun_id:" <+> ppr fun_id <+> dcolon <+> ppr (idType fun_id) + , text "pos:" <+> ppr pos + , text "arg:" <+> ppr arg ] + Nothing -> + -- Here we handle the situation in which a "must be concrete" TyVar + -- has not been instantiated at all. + case conc_reason of + ConcreteFRR frr_orig -> + let ty = frr_type frr_orig + in Just $ ppr ty <+> dcolon <+> ppr (typeKind ty) + = Just (bad_ty, conc_reason) + | otherwise + = Nothing + + err_msg :: SDoc + err_msg + = vcat $ map ((bullet <+>) . ppr_not_conc) not_concs + + ppr_not_conc :: (SDoc, ConcreteTvOrigin) -> SDoc + ppr_not_conc (bad_ty, conc) = + vcat + [ ppr_conc_orig conc + , nest 2 bad_ty ] + + ppr_conc_orig :: ConcreteTvOrigin -> SDoc + ppr_conc_orig (ConcreteFRR frr_orig) = + case frr_orig of + FixedRuntimeRepOrigin { frr_context = ctxt } -> + hsep [ ppr ctxt, text "does not have a fixed runtime representation:" ] + +-- | Compute the 1-indexed positions in the outer forall'd quantified type variables +-- of the type in which the concrete type variables occur. +-- +-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete. +concreteTyVarPositions :: Id -> ConcreteTyVars -> IntMap ConcreteTvOrigin +concreteTyVarPositions fun_id conc_tvs + | isNullUFM conc_tvs + = IntMap.empty + | otherwise + = case splitForAllTyCoVars (idType fun_id) of + ([], _) -> IntMap.empty + (tvs, _) -> + let positions = + IntMap.fromList + [ (pos, conc_orig) + | (tv, pos) <- zip tvs [1..] + , conc_orig <- maybeToList $ lookupNameEnv conc_tvs (tyVarName tv) + ] + -- Assert that we have as many positions as concrete type variables, + -- i.e. we are not missing any concreteness information. + in assertPpr (sizeUFM conc_tvs == length positions) + (vcat [ text "concreteTyVarPositions: missing concreteness information" + , text "fun_id:" <+> ppr fun_id + , text "tvs:" <+> ppr tvs + , text "Expected # of concrete tvs:" <+> ppr (sizeUFM conc_tvs) + , text " Actual # of concrete tvs:" <+> ppr (length positions) ]) + positions + +-- Check that the usage of var is consistent with var itself, and pop the var +-- from the usage environment (this is important because of shadowing). +checkLinearity :: UsageEnv -> OutVar -> LintM UsageEnv +checkLinearity body_ue lam_var = + case varMultMaybe lam_var of + Just mult -> do + let (lhs, body_ue') = popUE body_ue lam_var + err_msg = vcat [ text "Linearity failure in lambda:" <+> ppr lam_var + , ppr lhs <+> text "⊈" <+> ppr mult + , ppr body_ue ] + ensureSubUsage lhs mult err_msg + return body_ue' + Nothing -> return body_ue -- A type variable + +{- Note [Join points and casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that this should be OK: + join j x = rhs + in (case e of + A -> alt1 + B x -> (jump j x) |> co) + +You might think that, since the cast is ultimately erased, the jump to +`j` should still be OK as a join point. But no! See #21716. Suppose + + newtype Age = MkAge Int -- axAge :: Age ~ Int + f :: Int -> ... -- f strict in it's first argument + +and consider the expression + + f (join j :: Bool -> Age + j x = (rhs1 :: Age) + in case v of + Just x -> (j x |> axAge :: Int) + Nothing -> rhs2) + +Then, if the Simplifier pushes the strict call into the join points +and alternatives we'll get + + join j' x = f (rhs1 :: Age) + in case v of + Just x -> j' x |> axAge + Nothing -> f rhs2 + +Utterly bogus. `f` expects an `Int` and we are giving it an `Age`. +No no no. Casts destroy the tail-call property. Henc markAllJoinsBad +in the (Cast expr co) case of lintCoreExpr. + +Note [No alternatives lint check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case expressions with no alternatives are odd beasts, and it would seem +like they would worth be looking at in the linter (cf #10180). We +used to check two things: + +* exprIsHNF is false: it would *seem* to be terribly wrong if + the scrutinee was already in head normal form. + +* exprIsDeadEnd is true: we should be able to see why GHC believes the + scrutinee is diverging for sure. + +It was already known that the second test was not entirely reliable. +Unfortunately (#13990), the first test turned out not to be reliable +either. Getting the checks right turns out to be somewhat complicated. + +For example, suppose we have (comment 8) + + data T a where + TInt :: T Int + + absurdTBool :: T Bool -> a + absurdTBool v = case v of + + data Foo = Foo !(T Bool) + + absurdFoo :: Foo -> a + absurdFoo (Foo x) = absurdTBool x + +GHC initially accepts the empty case because of the GADT conditions. But then +we inline absurdTBool, getting + + absurdFoo (Foo x) = case x of + +x is in normal form (because the Foo constructor is strict) but the +case is empty. To avoid this problem, GHC would have to recognize +that matching on Foo x is already absurd, which is not so easy. + +More generally, we don't really know all the ways that GHC can +lose track of why an expression is bottom, so we shouldn't make too +much fuss when that happens. + + +Note [Beta redexes] +~~~~~~~~~~~~~~~~~~~ +Consider: + + join j @x y z = ... in + (\@x y z -> jump j @x y z) @t e1 e2 + +This is clearly ill-typed, since the jump is inside both an application and a +lambda, either of which is enough to disqualify it as a tail call (see Note +[Invariants on join points] in GHC.Core). However, strictly from a +lambda-calculus perspective, the term doesn't go wrong---after the two beta +reductions, the jump *is* a tail call and everything is fine. + +Why would we want to allow this when we have let? One reason is that a compound +beta redex (that is, one with more than one argument) has different scoping +rules: naively reducing the above example using lets will capture any free +occurrence of y in e2. More fundamentally, type lets are tricky; many passes, +such as Float Out, tacitly assume that the incoming program's type lets have +all been dealt with by the simplifier. Thus we don't want to let-bind any types +in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately +before Float Out. + +All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this +loophole, doing so to avoid re-traversing large functions (beta-reducing a type +lambda without introducing a type let requires a substitution). TODO: Improve +simpleOptPgm so that we can forget all this ever happened. + +************************************************************************ +* * +\subsection[lintCoreArgs]{lintCoreArgs} +* * +************************************************************************ + +The basic version of these functions checks that the argument is a +subtype of the required type, as one would expect. +-} + +-- Takes the functions type and arguments as argument. +-- Returns the *result* of applying the function to arguments. +-- e.g. f :: Int -> Bool -> Int would return `Int` as result type. +lintCoreArgs :: (OutType, UsageEnv) -> [InExpr] -> LintM (OutType, UsageEnv) +lintCoreArgs (fun_ty, fun_ue) args + = lintApp (text "expression") + lintTyArg lintValArg fun_ty args fun_ue + +lintTyArg :: InExpr -> LintM OutType + +-- Type argument +lintTyArg (Type arg_ty) + = do { checkL (not (isCoercionTy arg_ty)) + (text "Unnecessary coercion-to-type injection:" + <+> ppr arg_ty) + ; lintTypeAndSubst arg_ty } +lintTyArg arg + = failWithL (hang (text "Expected type argument but found") 2 (ppr arg)) + +lintValArg :: InExpr -> Mult -> UsageEnv -> LintM (OutType, UsageEnv) +lintValArg arg mult fun_ue + = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg + -- See Note [Representation polymorphism invariants] in GHC.Core + + ; flags <- getLintFlags + ; when (lf_check_fixed_rep flags) $ + -- Only check that 'arg_ty' has a fixed RuntimeRep + -- if 'lf_check_fixed_rep' is on. + do { checkL (typeHasFixedRuntimeRep arg_ty) + (text "Argument does not have a fixed runtime representation" + <+> ppr arg <+> dcolon + <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) } + + ; let app_ue = addUE fun_ue (scaleUE mult arg_ue) + ; return (arg_ty, app_ue) } + +----------------- +lintAltBinders :: UsageEnv + -> Var -- Case binder + -> OutType -- Scrutinee type + -> OutType -- Constructor type + -> [(Mult, OutVar)] -- Binders + -> LintM UsageEnv +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintAltBinders rhs_ue _case_bndr scrut_ty con_ty [] + = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) + ; return rhs_ue } +lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs) + | isTyVar bndr + = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) + ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty' bndrs } + | otherwise + = do { (con_ty', _) <- lintValApp (Var bndr) con_ty (idType bndr) zeroUE zeroUE + -- We can pass zeroUE to lintValApp because we ignore its usage + -- calculation and compute it in the call for checkCaseLinearity below. + ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr + ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs } + +-- | Implements the case rules for linearity +checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv +checkCaseLinearity ue case_bndr var_w bndr = do + ensureSubUsage lhs rhs err_msg + lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (idMult bndr) + return $ deleteUE ue bndr + where + lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage) + rhs = case_bndr_w `mkMultMul` var_w + err_msg = (text "Linearity failure in variable:" <+> ppr bndr + $$ ppr lhs <+> text "⊈" <+> ppr rhs + $$ text "Computed by:" + <+> text "LHS:" <+> lhs_formula + <+> text "RHS:" <+> rhs_formula) + lhs_formula = ppr bndr_usage <+> text "+" + <+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w) + rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w + case_bndr_w = idMult case_bndr + case_bndr_usage = lookupUE ue case_bndr + bndr_usage = lookupUE ue bndr + + + +----------------- +lintTyApp :: OutType -> OutType -> LintM OutType +lintTyApp fun_ty arg_ty + | Just (tv,body_ty) <- splitForAllTyVar_maybe fun_ty + = do { lintTyKind tv arg_ty + ; in_scope <- getInScope + -- substTy needs the set of tyvars in scope to avoid generating + -- uniques that are already in scope. + -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst + ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } + + | otherwise + = failWithL (mkTyAppMsg fun_ty arg_ty) + +----------------- + +-- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@ +-- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the +-- application. +lintValApp :: CoreExpr -> OutType -> OutType -> UsageEnv -> UsageEnv + -> LintM (OutType, UsageEnv) +lintValApp arg fun_ty arg_ty fun_ue arg_ue + | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty + = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg) + ; let app_ue = addUE fun_ue (scaleUE w arg_ue) + ; return (res_ty', app_ue) } + | otherwise + = failWithL err2 + where + err2 = mkNonFunAppMsg fun_ty arg_ty arg + +lintTyKind :: OutTyVar -> OutType -> LintM () +-- Both args have had substitution applied + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintTyKind tyvar arg_ty + = unless (arg_kind `eqType` tyvar_kind) $ + addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind)) + where + tyvar_kind = tyVarKind tyvar + arg_kind = typeKind arg_ty + +{- +************************************************************************ +* * +\subsection[lintCoreAlts]{lintCoreAlts} +* * +************************************************************************ +-} + +lintCaseExpr :: CoreExpr -> InId -> InType -> [CoreAlt] -> LintM (OutType, UsageEnv) +lintCaseExpr scrut case_bndr alt_ty alts + = do { let e = Case scrut case_bndr alt_ty alts -- Just for error messages + + -- Check the scrutinee + ; (scrut_ty', scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut + -- See Note [Join points are less general than the paper] + -- in GHC.Core + + ; alt_ty' <- addLoc (CaseTy scrut) $ lintValueType alt_ty + + ; checkCaseAlts e scrut scrut_ty' alts + + -- Lint the case-binder. Must do this after linting the scrutinee + -- because the case-binder isn't in scope in the scrutineex + ; lintBinder CaseBind case_bndr $ \case_bndr' -> + -- Don't use lintIdBndr on case_bndr, because unboxed tuple is legitimate + + do { let case_bndr_ty' = idType case_bndr' + scrut_mult = idMult case_bndr' + + ; ensureEqTys case_bndr_ty' scrut_ty' (mkScrutMsg case_bndr case_bndr_ty' scrut_ty') + -- See GHC.Core Note [Case expression invariants] item (7) + + ; -- Check the alternatives + ; alt_ues <- mapM (lintCoreAlt case_bndr' scrut_ty' scrut_mult alt_ty') alts + ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues + ; return (alt_ty', case_ue) } } + +checkCaseAlts :: InExpr -> InExpr -> OutType -> [CoreAlt] -> LintM () +-- a) Check that the alts are non-empty +-- b1) Check that the DEFAULT comes first, if it exists +-- b2) Check that the others are in increasing order +-- c) Check that there's a default for infinite types +-- d) Check that the scrutinee is not a floating-point type +-- if there are any literal alternatives +-- e) Check if the scrutinee type has no constructors +-- +-- We used to try to check whether a case expression with no +-- alternatives was legitimate, but this didn't work. +-- See Note [No alternatives lint check] for details. +-- +-- NB: Algebraic cases are not necessarily exhaustive, because +-- the simplifier correctly eliminates case that can't +-- possibly match. +checkCaseAlts e scrut scrut_ty alts + = do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) + -- See GHC.Core Note [Case expression invariants] item (2) + + ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) + -- See GHC.Core Note [Case expression invariants] item (3) + + -- For types Int#, Word# with an infinite (well, large!) number of + -- possible values, there should usually be a DEFAULT case + -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to + -- have *no* case alternatives. + -- In effect, this is a kind of partial test. I suppose it's possible + -- that we might *know* that 'x' was 1 or 2, in which case + -- case x of { 1 -> e1; 2 -> e2 } + -- would be fine. + ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) + (nonExhaustiveAltsMsg e) + + -- Check that the scrutinee is not a floating-point type + -- if there are any literal alternatives + -- See GHC.Core Note [Case expression invariants] item (5) + -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold + ; checkL (not $ isFloatingPrimTy scrut_ty && any is_lit_alt alts) + (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)." + $$ text "scrut" <+> ppr scrut) + + -- Check if scrutinee type has no constructors + -- Just a trace message for now + ; case tyConAppTyCon_maybe scrut_ty of + Just tycon + | debugIsOn + , isAlgTyCon tycon + , not (isAbstractTyCon tycon) + , null (tyConDataCons tycon) + , not (exprIsDeadEnd scrut) + -> pprTrace "Lint warning: case scrutinee type has no constructors" + (ppr scrut_ty) + -- This can legitimately happen for type families + $ return () + _otherwise -> return () + } + where + (con_alts, maybe_deflt) = findDefault alts + + -- Check that successive alternatives have strictly increasing tags + increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest + increasing_tag _ = True + + non_deflt (Alt DEFAULT _ _) = False + non_deflt _ = True + + is_lit_alt (Alt (LitAlt _) _ _) = True + is_lit_alt _ = False + + is_infinite_ty = case tyConAppTyCon_maybe scrut_ty of + Nothing -> False + Just tycon -> isPrimTyCon tycon + +lintAltExpr :: CoreExpr -> OutType -> LintM UsageEnv +lintAltExpr expr ann_ty + = do { (actual_ty, ue) <- lintCoreExpr expr + ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) + ; return ue } + -- See GHC.Core Note [Case expression invariants] item (6) + +lintCoreAlt :: OutId -- Case binder + -> OutType -- Type of scrutinee + -> Mult -- Multiplicity of scrutinee + -> OutType -- Type of the alternative + -> CoreAlt + -> LintM UsageEnv +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreAlt case_bndr _ scrut_mult alt_ty (Alt DEFAULT args rhs) = + do { lintL (null args) (mkDefaultArgsMsg args) + ; rhs_ue <- lintAltExpr rhs alt_ty + ; let (case_bndr_usage, rhs_ue') = popUE rhs_ue case_bndr + err_msg = vcat [ text "Linearity failure in the DEFAULT clause:" <+> ppr case_bndr + , ppr case_bndr_usage <+> text "⊈" <+> ppr scrut_mult ] + ; ensureSubUsage case_bndr_usage scrut_mult err_msg + ; return rhs_ue' } + +lintCoreAlt case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs) + | litIsLifted lit + = failWithL integerScrutinisedMsg + | otherwise + = do { lintL (null args) (mkDefaultArgsMsg args) + ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) + ; rhs_ue <- lintAltExpr rhs alt_ty + ; return (deleteUE rhs_ue case_bndr) -- No need for linearity checks + } + where + lit_ty = literalType lit + +lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs) + | isNewTyCon (dataConTyCon con) + = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt) + | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty + = addLoc (CaseAlt alt) $ do + { checkTypeDataConOcc "pattern" con + ; lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) + + -- Instantiate the universally quantified + -- type variables of the data constructor + ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys + ; binderMult (Named _) = ManyTy + ; binderMult (Anon st _) = scaledMult st + -- See Note [Validating multiplicities in a case] + ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty } + + -- And now bring the new binders into scope + ; lintBinders CasePatBind args $ \ args' -> do + { rhs_ue <- lintAltExpr rhs alt_ty + ; rhs_ue' <- addLoc (CasePat alt) $ + lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty + (zipEqual multiplicities args') + ; return $ deleteUE rhs_ue' case_bndr + } + } + + | otherwise -- Scrut-ty is wrong shape + = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt) + +{- +Note [Validating multiplicities in a case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose 'MkT :: a %m -> T m a'. +If we are validating 'case (x :: T Many a) of MkT y -> ...', +we have to substitute m := Many in the type of MkT - in particular, +y can be used Many times and that expression would still be linear in x. +We do this by looking at con_payload_ty, which is the type of the datacon +applied to the surrounding arguments. +Testcase: linear/should_compile/MultConstructor + +Data constructors containing existential tyvars will then have +Named binders, which are always multiplicity Many. +Testcase: indexed-types/should_compile/GADT1 +-} + +lintLinearBinder :: SDoc -> Mult -> Mult -> LintM () +lintLinearBinder doc actual_usage described_usage + = ensureSubMult actual_usage described_usage err_msg + where + err_msg = (text "Multiplicity of variable does not agree with its context" + $$ doc + $$ ppr actual_usage + $$ text "Annotation:" <+> ppr described_usage) + +{- +************************************************************************ +* * +\subsection[lint-types]{Types} +* * +************************************************************************ +-} + +-- When we lint binders, we (one at a time and in order): +-- 1. Lint var types or kinds (possibly substituting) +-- 2. Add the binder to the in scope set, and if its a coercion var, +-- we may extend the substitution to reflect its (possibly) new kind +lintBinders :: HasDebugCallStack => BindingSite -> [InVar] -> ([OutVar] -> LintM a) -> LintM a +lintBinders _ [] linterF = linterF [] +lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> + lintBinders site vars $ \ vars' -> + linterF (var':vars') + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintBinder :: HasDebugCallStack => BindingSite -> InVar -> (OutVar -> LintM a) -> LintM a +lintBinder site var linterF + | isTyCoVar var = lintTyCoBndr var linterF + | otherwise = lintIdBndr NotTopLevel site var linterF + +lintTyCoBndr :: HasDebugCallStack => TyCoVar -> (OutTyCoVar -> LintM a) -> LintM a +lintTyCoBndr tcv thing_inside + = do { tcv_type' <- lintTypeAndSubst (varType tcv) + ; let tcv_kind' = typeKind tcv_type' + + -- See (FORALL1) and (FORALL2) in GHC.Core.Type + ; if (isTyVar tcv) + then -- Check that in (forall (a:ki). blah) we have ki:Type + lintL (isLiftedTypeKind tcv_kind') $ + hang (text "TyVar whose kind does not have kind Type:") + 2 (ppr tcv <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr tcv_kind') + else -- Check that in (forall (cv::ty). blah), + -- then ty looks like (t1 ~# t2) + lintL (isCoVarType tcv_type') $ + text "CoVar with non-coercion type:" <+> pprTyVar tcv + + ; addInScopeTyCoVar tcv tcv_type' thing_inside } + +lintIdBndrs :: forall a. TopLevelFlag -> [InId] -> ([OutId] -> LintM a) -> LintM a +lintIdBndrs top_lvl ids thing_inside + = go ids thing_inside + where + go :: [Id] -> ([Id] -> LintM a) -> LintM a + go [] thing_inside = thing_inside [] + go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ \id' -> + go ids $ \ids' -> + thing_inside (id' : ids') + +lintIdBndr :: TopLevelFlag -> BindingSite + -> InVar -> (OutVar -> LintM a) -> LintM a +-- Do substitution on the type of a binder and add the var with this +-- new type to the in-scope set of the second argument +-- ToDo: lint its rules +lintIdBndr top_lvl bind_site id thing_inside + = assertPpr (isId id) (ppr id) $ + do { flags <- getLintFlags + ; checkL (not (lf_check_global_ids flags) || isLocalId id) + (text "Non-local Id binder" <+> ppr id) + -- See Note [Checking for global Ids] + + -- Check that if the binder is nested, it is not marked as exported + ; checkL (not (isExportedId id) || is_top_lvl) + (mkNonTopExportedMsg id) + + -- Check that if the binder is nested, it does not have an external name + ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl) + (mkNonTopExternalNameMsg id) + + -- See Note [Representation polymorphism invariants] in GHC.Core + ; lintL (isJoinId id || not (lf_check_fixed_rep flags) + || typeHasFixedRuntimeRep id_ty) $ + text "Binder does not have a fixed runtime representation:" <+> ppr id <+> dcolon <+> + parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty)) + + -- Check that a join-id is a not-top-level let-binding + ; when (isJoinId id) $ + checkL (not is_top_lvl && is_let_bind) $ + mkBadJoinBindMsg id + + -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); + -- if so, it should be a CoVar, and checked by lintCoVarBndr + ; lintL (not (isCoVarType id_ty)) + (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) + + -- Check that the lambda binder has no value or OtherCon unfolding. + -- See #21496 + ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id))) + (text "Lambda binder with value or OtherCon unfolding.") + + ; out_ty <- addLoc (IdTy id) (lintValueType id_ty) + + ; addInScopeId id out_ty thing_inside } + where + id_ty = idType id + + is_top_lvl = isTopLevel top_lvl + is_let_bind = case bind_site of + LetBind -> True + _ -> False + +{- +%************************************************************************ +%* * + Types +%* * +%************************************************************************ +-} + +{- Note [Linting types and coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that + lintType :: InType -> LintM () + lintCoercion :: InCoercion -> LintM () +Neither returns anything. + +If you need the kind of the type, then do `typeKind` and then apply +the ambient substitution using `substTyM`. Note that the substitution +empty unless there is shadowing or type-lets; and if the substitution is +empty, the `substTyM` is a no-op. + +It is better to take the kind and then substitute, rather than substitute +and then take the kind, becaues the kind is usually smaller. + +Note: you might wonder if we should apply the same logic to expressions. +Why do we have + lintExpr :: InExpr -> LintM OutType +Partly inertia; but also taking the type of an expresison involve looking +down a deep chain of let's, whereas that is not true of taking the kind +of a type. It'd be worth an experiment though. + +Historical note: in the olden days we had + lintType :: InType -> LintM OutType +but that burned a huge amount of allocation building an OutType that was +often discarded, or used only to get its kind. + +I also experimented with + lintType :: InType -> LintM OutKind +but that too was slower. It is also much simpler to return ()! If we +return the kind we have to duplicate the logic in `typeKind`; and it is +much worse for coercions. +-} + +lintValueType :: Type -> LintM OutType +-- Types only, not kinds +-- Check the type, and apply the substitution to it +-- See Note [Linting type lets] +lintValueType ty + = addLoc (InType ty) $ + do { ty' <- lintTypeAndSubst ty + ; let sk = typeKind ty' + ; lintL (isTYPEorCONSTRAINT sk) $ + hang (text "Ill-kinded type:" <+> ppr ty) + 2 (text "has kind:" <+> ppr sk) + ; return ty' } + +checkTyCon :: TyCon -> LintM () +checkTyCon tc + = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) + +------------------- +lintTypeAndSubst :: InType -> LintM OutType +lintTypeAndSubst ty = do { lintType ty; substTyM ty } + -- In GHCi we may lint an expression with a free + -- type variable. Then it won't be in the + -- substitution, but it should be in scope + +lintType :: InType -> LintM () +-- See Note [Linting types and coercions] +-- +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintType (TyVarTy tv) + | not (isTyVar tv) + = failWithL (mkBadTyVarMsg tv) + + | otherwise + = do { _ <- lintVarOcc tv + ; return () } + +lintType ty@(AppTy t1 t2) + | TyConApp {} <- t1 + = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty + | otherwise + = do { let (fun_ty, arg_tys) = collect t1 [t2] + ; lintType fun_ty + ; fun_kind <- substTyM (typeKind fun_ty) + ; lint_ty_app ty fun_kind arg_tys } + where + collect (AppTy f a) as = collect f (a:as) + collect fun as = (fun, as) + +lintType ty@(TyConApp tc tys) + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags + ; lintTySynFamApp report_unsat ty tc tys } + + | Just {} <- tyConAppFunTy_maybe tc tys + -- We should never see a saturated application of funTyCon; such + -- applications should be represented with the FunTy constructor. + -- See Note [Linting function types] + = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) 2 (ppr ty)) + + | otherwise -- Data types, data families, primitive types + = do { checkTyCon tc + ; lint_ty_app ty (tyConKind tc) tys } + +-- arrows can related *unlifted* kinds, so this has to be separate from +-- a dependent forall. +lintType ty@(FunTy af tw t1 t2) + = do { lintType t1 + ; lintType t2 + ; lintType tw + ; lintArrow (text "type or kind" <+> quotes (ppr ty)) af t1 t2 tw } + +lintType ty@(ForAllTy {}) + = go [] ty + where + go :: [OutTyCoVar] -> InType -> LintM () + -- Loop, collecting the forall-binders + go tcvs ty@(ForAllTy (Bndr tcv _) body_ty) + | not (isTyCoVar tcv) + = failWithL (text "Non-TyVar or Non-CoVar bound in type:" <+> ppr ty) + + | otherwise + = lintTyCoBndr tcv $ \tcv' -> + do { -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] + -- Suspicious because it works on InTyCoVar; c.f. ForAllCo + when (isCoVar tcv) $ + lintL (anyFreeVarsOfType (== tcv) body_ty) $ + text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty) + + ; go (tcv' : tcvs) body_ty } + + go tcvs body_ty + = do { lintType body_ty + ; lintForAllBody tcvs body_ty } + +lintType (CastTy ty co) + = do { lintType ty + ; ty_kind <- substTyM (typeKind ty) + ; co_lk <- lintStarCoercion co + ; ensureEqTys ty_kind co_lk (mkCastTyErr ty co ty_kind co_lk) } + +lintType (LitTy l) = lintTyLit l +lintType (CoercionTy co) = lintCoercion co + +----------------- +lintForAllBody :: [OutTyCoVar] -> InType -> LintM () +-- Do the checks for the body of a forall-type +lintForAllBody tcvs body_ty + = do { -- For type variables, check for skolem escape + -- See Note [Phantom type variables in kinds] in GHC.Core.Type + -- The kind of (forall cv. th) is liftedTypeKind, so no + -- need to check for skolem-escape in the CoVar case + body_kind <- substTyM (typeKind body_ty) + ; case occCheckExpand tcvs body_kind of + Just {} -> return () + Nothing -> failWithL $ + hang (text "Variable escape in forall:") + 2 (vcat [ text "tycovars (reversed):" <+> ppr tcvs + , text "type:" <+> ppr body_ty + , text "kind:" <+> ppr body_kind ]) + ; checkValueType body_kind (text "the body of forall:" <+> ppr body_ty) } + +----------------- +lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM () +-- The TyCon is a type synonym or a type family (not a data family) +-- See Note [Linting type synonym applications] +-- c.f. GHC.Tc.Validity.check_syn_tc_app +lintTySynFamApp report_unsat ty tc tys + | report_unsat -- Report unsaturated only if report_unsat is on + , tys `lengthLessThan` tyConArity tc + = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) + + -- Deal with type synonyms + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys + , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' + = do { when report_unsat $ do { _ <- lintType expanded_ty + ; return () } + + ; -- Kind-check the argument types, but without reporting + -- un-saturated type families/synonyms + ; setReportUnsat False $ + lint_ty_app ty (tyConKind tc) tys } + + -- Otherwise this must be a type family + | otherwise + = lint_ty_app ty (tyConKind tc) tys + +----------------- +-- Confirms that a kind is really TYPE r or Constraint +checkValueType :: OutKind -> SDoc -> LintM () +checkValueType kind doc + = lintL (isTYPEorCONSTRAINT kind) + (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$ + text "when checking" <+> doc) + +----------------- +lintArrow :: SDoc -> FunTyFlag -> InType -> InType -> InType -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintArrow what af t1 t2 tw -- Eg lintArrow "type or kind `blah'" k1 k2 kw + -- or lintArrow "coercion `blah'" k1 k2 kw + = do { k1 <- substTyM (typeKind t1) + ; k2 <- substTyM (typeKind t2) + ; kw <- substTyM (typeKind tw) + ; unless (isTYPEorCONSTRAINT k1) (report (text "argument") t1 k1) + ; unless (isTYPEorCONSTRAINT k2) (report (text "result") t2 k2) + ; unless (isMultiplicityTy kw) (report (text "multiplicity") tw kw) + + ; let real_af = chooseFunTyFlag t1 t2 + ; unless (real_af == af) $ addErrL $ + hang (text "Bad FunTyFlag") + 2 (vcat [ text "FunTyFlag =" <+> ppr af + , text "Computed FunTyFlag =" <+> ppr real_af + , text "in" <+> what ]) } + where + report ar t k = addErrL (hang (text "Ill-kinded" <+> ar) + 2 (vcat [ ppr t <+> dcolon <+> ppr k + , text "in" <+> what ])) + +----------------- +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = text "Negative type literal:" <+> integer n +lintTyLit (StrTyLit _) = return () +lintTyLit (CharTyLit _) = return () + +----------------- +lint_ty_app :: InType -> OutKind -> [InType] -> LintM () +lint_ty_app ty = lint_tyco_app (text "type" <+> quotes (ppr ty)) + +lint_co_app :: HasDebugCallStack => Coercion -> OutKind -> [InType] -> LintM () +lint_co_app co = lint_tyco_app (text "coercion" <+> quotes (ppr co)) + +lint_tyco_app :: SDoc -> OutKind -> [InType] -> LintM () +lint_tyco_app msg fun_kind arg_tys + -- See Note [Avoiding compiler perf traps when constructing error messages.] + = do { _ <- lintApp msg (\ty -> do { lintType ty; substTyM ty }) + (\ty _ _ -> do { lintType ty; ki <- substTyM (typeKind ty); return (ki,()) }) + fun_kind arg_tys () + ; return () } + +---------------- +lintApp :: forall in_a acc. Outputable in_a => + SDoc + -> (in_a -> LintM OutType) -- Lint the thing and return its value + -> (in_a -> Mult -> acc -> LintM (OutKind, acc)) -- Lint the thing and return its type + -> OutType + -> [in_a] -- The arguments, always "In" things + -> acc -- Used (only) for UsageEnv in /term/ applications + -> LintM (OutType,acc) +-- lintApp is a performance-critical function, which deals with multiple +-- applications such as (/\a./\b./\c. expr) @ta @tb @tc +-- When returning the type of this expression we want to avoid substituting a:=ta, +-- and /then/ substituting b:=tb, etc. That's quadratic, and can be a huge +-- perf hole. So we gather all the arguments [in_a], and then gather the +-- substitution incrementally in the `go` loop. +-- +-- lintApp is used: +-- * for term applications (lintCoreArgs) +-- * for type applications (lint_ty_app) +-- * for coercion application (lint_co_app) +-- To deal with these cases `lintApp` has two higher order arguments; +-- but we specialise it for each call site (by inlining) +{-# INLINE lintApp #-} -- INLINE: very few call sites; + -- not recursive; specialised at its call sites + +lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc + = do { !in_scope <- getInScope + -- We need the in_scope set to satisfy the invariant in + -- Note [The substitution invariant] in GHC.Core.TyCo.Subst + -- Forcing the in scope set eagerly here reduces allocations by up to 4%. + + ; let init_subst = mkEmptySubst in_scope + + go :: Subst -> OutType -> acc -> [in_a] -> LintM (OutType, acc) + -- The Subst applies (only) to the fun_ty + -- c.f. GHC.Core.Type.piResultTys, which has a similar loop + + go subst fun_ty acc [] + = return (substTy subst fun_ty, acc) + + go subst (ForAllTy (Bndr tv _vis) body_ty) acc (arg:args) + = do { arg' <- lint_forall_arg arg + ; let tv_kind = substTy subst (varType tv) + karg' = typeKind arg' + subst' = extendTCvSubst subst tv arg' + ; ensureEqTys karg' tv_kind $ + lint_app_fail_msg msg orig_fun_ty all_args + (hang (text "Forall:" <+> (ppr tv $$ ppr tv_kind)) + 2 (ppr arg' <+> dcolon <+> ppr karg')) + ; go subst' body_ty acc args } + + go subst fun_ty@(FunTy _ mult exp_arg_ty res_ty) acc (arg:args) + = do { (arg_ty, acc') <- lint_arrow_arg arg (substTy subst mult) acc + ; ensureEqTys (substTy subst exp_arg_ty) arg_ty $ + lint_app_fail_msg msg orig_fun_ty all_args + (hang (text "Fun:" <+> ppr fun_ty) + 2 (vcat [ text "exp_arg_ty:" <+> ppr exp_arg_ty + , text "arg:" <+> ppr arg <+> dcolon <+> ppr arg_ty ])) + ; go subst res_ty acc' args } + + go subst fun_ty acc args + | Just fun_ty' <- coreView fun_ty + = go subst fun_ty' acc args + + | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] + = go init_subst (substTy subst fun_ty) acc args + + | otherwise + = failWithL (lint_app_fail_msg msg orig_fun_ty all_args + (text "Not a fun:" <+> (ppr fun_ty $$ ppr args))) + + ; go init_subst orig_fun_ty acc all_args } + +-- This is a top level definition to ensure we pass all variables of the error message +-- explicitly and don't capture them as free variables. Otherwise this binder might +-- become a thunk that get's allocated in the hot code path. +-- See Note [Avoiding compiler perf traps when constructing error messages.] +lint_app_fail_msg :: (Outputable a2) => SDoc -> OutType -> a2 -> SDoc -> SDoc +lint_app_fail_msg msg kfn arg_tys extra + = vcat [ hang (text "Application error in") 2 msg + , nest 2 (text "Function type =" <+> ppr kfn) + , nest 2 (text "Args =" <+> ppr arg_tys) + , extra ] + +{- ********************************************************************* +* * + Linting rules +* * +********************************************************************* -} + +lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM () +lintCoreRule _ _ (BuiltinRule {}) + = return () -- Don't bother + +lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs + , ru_args = args, ru_rhs = rhs }) + = lintBinders LambdaBind bndrs $ \ _ -> + do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args + ; (rhs_ty, _) <- case idJoinPointHood fun of + JoinPoint join_arity + -> do { checkL (args `lengthIs` join_arity) $ + mkBadJoinPointRuleMsg fun join_arity rule + -- See Note [Rules for join points] + ; lintCoreExpr rhs } + _ -> markAllJoinsBad $ lintCoreExpr rhs + ; ensureEqTys lhs_ty rhs_ty $ + (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty + , text "rhs type:" <+> ppr rhs_ty + , text "fun_ty:" <+> ppr fun_ty ]) + ; let bad_bndrs = filter is_bad_bndr bndrs + + ; checkL (null bad_bndrs) + (rule_doc <+> text "unbound" <+> ppr bad_bndrs) + -- See Note [Linting rules] + } + where + rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon + + lhs_fvs = exprsFreeVars args + rhs_fvs = exprFreeVars rhs + + is_bad_bndr :: Var -> Bool + -- See Note [Unbound RULE binders] in GHC.Core.Rules + is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs) + && bndr `elemVarSet` rhs_fvs + && isNothing (isReflCoVar_maybe bndr) + + +{- Note [Linting rules] +~~~~~~~~~~~~~~~~~~~~~~~ +It's very bad if simplifying a rule means that one of the template +variables (ru_bndrs) that /is/ mentioned on the RHS becomes +not-mentioned in the LHS (ru_args). How can that happen? Well, in #10602, +SpecConstr stupidly constructed a rule like + + forall x,c1,c2. + f (x |> c1 |> c2) = .... + +But simplExpr collapses those coercions into one. (Indeed in #10602, +it collapsed to the identity and was removed altogether.) + +We don't have a great story for what to do here, but at least +this check will nail it. + +NB (#11643): it's possible that a variable listed in the +binders becomes not-mentioned on both LHS and RHS. Here's a silly +example: + RULE forall x y. f (g x y) = g (x+1) (y-1) +And suppose worker/wrapper decides that 'x' is Absent. Then +we'll end up with + RULE forall x y. f ($gw y) = $gw (x+1) +This seems sufficiently obscure that there isn't enough payoff to +try to trim the forall'd binder list. + +Note [Rules for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A join point cannot be partially applied. However, the left-hand side of a rule +for a join point is effectively a *pattern*, not a piece of code, so there's an +argument to be made for allowing a situation like this: + + join $sj :: Int -> Int -> String + $sj n m = ... + j :: forall a. Eq a => a -> a -> String + {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-} + j @a $dEq x y = ... + +Applying this rule can't turn a well-typed program into an ill-typed one, so +conceivably we could allow it. But we can always eta-expand such an +"undersaturated" rule (see 'GHC.Core.Opt.Arity.etaExpandToJoinPointRule'), and in fact +the simplifier would have to in order to deal with the RHS. So we take a +conservative view and don't allow undersaturated rules for join points. See +Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further discussion. +-} + +{- +************************************************************************ +* * + Linting coercions +* * +************************************************************************ +-} + +{- Note [Asymptotic efficiency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When linting coercions (and types actually) we return a linted +(substituted) coercion. Then we often have to take the coercionKind of +that returned coercion. If we get long chains, that can be asymptotically +inefficient, notably in +* TransCo +* InstCo +* SelCo (cf #9233) +* LRCo + +But the code is simple. And this is only Lint. Let's wait to see if +the bad perf bites us in practice. + +A solution would be to return the kind and role of the coercion, +as well as the linted coercion. Or perhaps even *only* the kind and role, +which is what used to happen. But that proved tricky and error prone +(#17923), so now we return the coercion. +-} + + +-- lintStarCoercion lints a coercion, confirming that its lh kind and +-- its rh kind are both *; also ensures that the role is Nominal +-- Returns the lh kind +lintStarCoercion :: InCoercion -> LintM OutType +lintStarCoercion g + = do { lintCoercion g + ; Pair t1 t2 <- substCoKindM g + ; checkValueType (typeKind t1) (text "the kind of the left type in" <+> ppr g) + ; checkValueType (typeKind t2) (text "the kind of the right type in" <+> ppr g) + ; lintRole g Nominal (coercionRole g) + ; return t1 } + +substCoKindM :: InCoercion -> LintM (Pair OutType) +substCoKindM co + = do { let !(Pair lk rk) = coercionKind co + ; lk' <- substTyM lk + ; rk' <- substTyM rk + ; return (Pair lk' rk') } + +lintCoercion :: HasDebugCallStack => InCoercion -> LintM () +-- See Note [Linting types and coercions] +-- +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] + +lintCoercion (CoVarCo cv) + | not (isCoVar cv) + = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) + 2 (text "With offending type:" <+> ppr (varType cv))) + + | otherwise -- C.f. lintType (TyVarTy tv), which has better docs + = do { _ <- lintVarOcc cv; return () } + +lintCoercion (Refl ty) = lintType ty +lintCoercion (GRefl _r ty MRefl) = lintType ty + +lintCoercion (GRefl _r ty (MCo co)) + = do { lintType ty + ; lintCoercion co + ; tk <- substTyM (typeKind ty) + ; tl <- substTyM (coercionLKind co) + ; ensureEqTys tk tl $ + hang (text "GRefl coercion kind mis-match:" <+> ppr co) + 2 (vcat [ppr ty, ppr tk, ppr tl]) + ; lintRole co Nominal (coercionRole co) } + +lintCoercion co@(TyConAppCo r tc cos) + | Just {} <- tyConAppFunCo_maybe r tc cos + = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) + 2 (ppr co)) + -- All saturated TyConAppCos should be FunCos + + | Just {} <- synTyConDefn_maybe tc + = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) + + | otherwise + = do { checkTyCon tc + ; mapM_ lintCoercion cos + ; let tc_kind = tyConKind tc + ; lint_co_app co tc_kind (map coercionLKind cos) + ; lint_co_app co tc_kind (map coercionRKind cos) + ; zipWithM_ (lintRole co) (tyConRoleListX r tc) (map coercionRole cos) } + + +lintCoercion co@(AppCo co1 co2) + | TyConAppCo {} <- co1 + = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) + | Just (TyConApp {}, _) <- isReflCo_maybe co1 + = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) + | otherwise + = do { lintCoercion co1 + ; lintCoercion co2 + ; let !(Pair lt1 rt1) = coercionKind co1 + ; lk1 <- substTyM (typeKind lt1) + ; rk1 <- substTyM (typeKind rt1) + ; lint_co_app co lk1 [coercionLKind co2] + ; lint_co_app co rk1 [coercionRKind co2] + + ; let r2 = coercionRole co2 + ; if coercionRole co1 == Phantom + then lintL (r2 == Phantom || r2 == Nominal) + (text "Second argument in AppCo cannot be R:" $$ + ppr co) + else lintRole co Nominal r2 } + +---------- +lintCoercion co@(ForAllCo {}) +-- See Note [ForAllCo] in GHC.Core.TyCo.Rep for the typing rule for ForAllCo + = do { _ <- go [] co; return () } + where + go :: [OutTyCoVar] -- Binders in reverse order + -> InCoercion -> LintM Role + go tcvs co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = body_co }) + | not (isTyCoVar tcv) + = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co) + + | otherwise + = do { lk <- lintStarCoercion kind_co + ; lintTyCoBndr tcv $ \tcv' -> + do { ensureEqTys (varType tcv') lk $ + text "Kind mis-match in ForallCo" <+> ppr co + + -- I'm not very sure about this part, because it traverses body_co + -- but at least it's on a cold path (a ForallCo for a CoVar) + -- Also it works on InTyCoVar and InCoercion, which is suspect + ; when (isCoVar tcv) $ + do { lintL (visL == coreTyLamForAllTyFlag && visR == coreTyLamForAllTyFlag) $ + text "Invalid visibility flags in CoVar ForAllCo" <+> ppr co + -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep + ; lintL (almostDevoidCoVarOfCo tcv body_co) $ + text "Covar can only appear in Refl and GRefl: " <+> ppr co } + -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep + + ; role <- go (tcv':tcvs) body_co + + ; when (role == Nominal) $ + lintL (visL `eqForAllVis` visR) $ + text "Nominal ForAllCo has mismatched visibilities: " <+> ppr co + + ; return role } } + + go tcvs body_co + = do { lintCoercion body_co + + -- Need to check that + -- (forall (tcv:k1). lty) and + -- (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv]) + -- are both well formed, including the skolem escape check. + -- Easiest way is to call lintForAllBody for each + ; let Pair lty rty = coercionKind body_co + ; lintForAllBody tcvs lty + ; lintForAllBody tcvs rty + + ; return (coercionRole body_co) } + + +lintCoercion (FunCo { fco_role = r, fco_afl = afl, fco_afr = afr + , fco_mult = cow, fco_arg = co1, fco_res = co2 }) + = do { lintCoercion co1 + ; lintCoercion co2 + ; lintCoercion cow + ; let Pair lt1 rt1 = coercionKind co1 + Pair lt2 rt2 = coercionKind co2 + Pair ltw rtw = coercionKind cow + ; lintArrow (bad_co_msg "arrowl") afl lt1 lt2 ltw + ; lintArrow (bad_co_msg "arrowr") afr rt1 rt2 rtw + ; lintRole co1 r (coercionRole co1) + ; lintRole co2 r (coercionRole co2) + ; let expected_mult_role = case r of + Phantom -> Phantom + _ -> Nominal + ; lintRole cow expected_mult_role (coercionRole cow) } + where + bad_co_msg s = hang (text "Bad coercion" <+> parens (text s)) + 2 (vcat [ text "afl:" <+> ppr afl + , text "afr:" <+> ppr afr + , text "arg_co:" <+> ppr co1 + , text "res_co:" <+> ppr co2 ]) + +-- See Note [Bad unsafe coercion] +lintCoercion co@(UnivCo { uco_role = r, uco_prov = prov + , uco_lty = ty1, uco_rty = ty2, uco_deps = deps }) + = do { -- Check the role. PhantomProv must have Phantom role, otherwise any role is fine + case prov of + PhantomProv -> lintRole co Phantom r + _ -> return () + + -- Check the to and from types + ; lintType ty1 + ; lintType ty2 + ; tk1 <- substTyM (typeKind ty1) + ; tk2 <- substTyM (typeKind ty2) + + ; when (r /= Phantom && isTYPEorCONSTRAINT tk1 && isTYPEorCONSTRAINT tk2) + (checkTypes ty1 ty2) + + -- Check the coercions on which this UnivCo depends + ; mapM_ lintCoercion deps } + where + report s = hang (text $ "Unsafe coercion: " ++ s) + 2 (vcat [ text "From:" <+> ppr ty1 + , text " To:" <+> ppr ty2]) + isUnBoxed :: PrimRep -> Bool + isUnBoxed = not . isGcPtrRep + + -- see #9122 for discussion of these checks + checkTypes t1 t2 + = do { checkWarnL fixed_rep_1 + (report "left-hand type does not have a fixed runtime representation") + ; checkWarnL fixed_rep_2 + (report "right-hand type does not have a fixed runtime representation") + ; when (fixed_rep_1 && fixed_rep_2) $ + do { checkWarnL (reps1 `equalLength` reps2) + (report "between values with different # of reps") + ; zipWithM_ validateCoercion reps1 reps2 }} + where + fixed_rep_1 = typeHasFixedRuntimeRep t1 + fixed_rep_2 = typeHasFixedRuntimeRep t2 + + -- don't look at these unless lev_poly1/2 are False + -- Otherwise, we get #13458 + reps1 = typePrimRep t1 + reps2 = typePrimRep t2 + + validateCoercion :: PrimRep -> PrimRep -> LintM () + validateCoercion rep1 rep2 + = do { platform <- getPlatform + ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) + (report "between unboxed and boxed value") + ; checkWarnL (TyCon.primRepSizeB platform rep1 + == TyCon.primRepSizeB platform rep2) + (report "between unboxed values of different size") + ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) + (TyCon.primRepIsFloat rep2) + ; case fl of + Nothing -> addWarnL (report "between vector types") + Just False -> addWarnL (report "between float and integral values") + _ -> return () + } + +lintCoercion (SymCo co) = lintCoercion co + +lintCoercion co@(TransCo co1 co2) + = do { lintCoercion co1 + ; lintCoercion co2 + ; rk1 <- substTyM (coercionRKind co1) + ; lk2 <- substTyM (coercionLKind co2) + ; ensureEqTys rk1 lk2 + (hang (text "Trans coercion mis-match:" <+> ppr co) + 2 (vcat [ppr (coercionKind co1), ppr (coercionKind co2)])) + ; lintRole co (coercionRole co1) (coercionRole co2) } + +lintCoercion the_co@(SelCo cs co) + = do { lintCoercion co + ; Pair s t <- substCoKindM co + + ; if -- forall (both TyVar and CoVar) + | Just _ <- splitForAllTyCoVar_maybe s + , Just _ <- splitForAllTyCoVar_maybe t + , SelForAll <- cs + , (isForAllTy_ty s && isForAllTy_ty t) + || (isForAllTy_co s && isForAllTy_co t) + -> return () + + -- function + | isFunTy s + , isFunTy t + , SelFun {} <- cs + -> return () + + -- TyCon + | Just (tc_s, tys_s) <- splitTyConApp_maybe s + , Just (tc_t, tys_t) <- splitTyConApp_maybe t + , tc_s == tc_t + , SelTyCon n r0 <- cs + , let co_role = coercionRole co + , isInjectiveTyCon tc_s co_role + -- see Note [SelCo and newtypes] in GHC.Core.TyCo.Rep + , tys_s `equalLength` tys_t + , tys_s `lengthExceeds` n + -> do { lintRole the_co (tyConRole co_role tc_s n) r0 + ; return () } + + | otherwise + -> failWithL (hang (text "Bad SelCo:") + 2 (ppr the_co $$ ppr s $$ ppr t)) } + +lintCoercion the_co@(LRCo _lr co) + = do { lintCoercion co + ; Pair s t <- substCoKindM co + ; lintRole co Nominal (coercionRole co) + ; case (splitAppTy_maybe s, splitAppTy_maybe t) of + (Just {}, Just {}) -> return () + _ -> failWithL (hang (text "Bad LRCo:") + 2 (ppr the_co $$ ppr s $$ ppr t)) } + + +lintCoercion orig_co@(InstCo co arg) + = go co [arg] + where + go (InstCo co arg) args = do { lintCoercion arg; go co (arg:args) } + go co args = do { lintCoercion co + ; let Pair lty rty = coercionKind co + ; lty' <- substTyM lty + ; rty' <- substTyM rty + ; in_scope <- getInScope + ; let subst = mkEmptySubst in_scope + ; go_args (subst, lty') (subst,rty') args } + + ------------- + go_args :: (Subst, OutType) -> (Subst,OutType) -> [InCoercion] + -> LintM () + go_args _ _ [] + = return () + go_args lty rty (arg:args) + = do { (lty1, rty1) <- go_arg lty rty arg + ; go_args lty1 rty1 args } + + ------------- + go_arg :: (Subst, OutType) -> (Subst,OutType) -> InCoercion + -> LintM ((Subst,OutType), (Subst,OutType)) + go_arg (lsubst,lty) (rsubst,rty) arg + = do { lintRole arg Nominal (coercionRole arg) + ; Pair arg_lty arg_rty <- substCoKindM arg + + ; case (splitForAllTyCoVar_maybe lty, splitForAllTyCoVar_maybe rty) of + -- forall over tvar + (Just (ltv,lty1), Just (rtv,rty1)) + | typeKind arg_lty `eqType` substTy lsubst (tyVarKind ltv) + , typeKind arg_rty `eqType` substTy rsubst (tyVarKind rtv) + -> return ( (extendTCvSubst lsubst ltv arg_lty, lty1) + , (extendTCvSubst rsubst rtv arg_rty, rty1) ) + | otherwise + -> failWithL (hang (text "Kind mis-match in inst coercion") + 2 (vcat [ text "arg" <+> ppr arg + , text "lty" <+> ppr lty <+> dcolon <+> ppr (typeKind lty) + , text "rty" <+> ppr rty <+> dcolon <+> ppr (typeKind rty) + , text "arg_lty" <+> ppr arg_lty <+> dcolon <+> ppr (typeKind arg_lty) + , text "arg_rty" <+> ppr arg_rty <+> dcolon <+> ppr (typeKind arg_rty) + , text "ltv" <+> ppr ltv <+> dcolon <+> ppr (tyVarKind ltv) + , text "rtv" <+> ppr rtv <+> dcolon <+> ppr (tyVarKind rtv) ])) + + _ -> failWithL (text "Bad argument of inst" <+> ppr orig_co) } + +lintCoercion this_co@(AxiomCo ax cos) + = do { mapM_ lintCoercion cos + ; lint_roles 0 (coAxiomRuleArgRoles ax) cos + ; prs <- mapM substCoKindM cos + ; lint_ax ax prs } + + where + lint_ax :: CoAxiomRule -> [Pair OutType] -> LintM () + lint_ax (BuiltInFamRew bif) prs + = checkL (isJust (bifrw_proves bif prs)) bad_bif + lint_ax (BuiltInFamInj bif) prs + = checkL (case prs of + [pr] -> isJust (bifinj_proves bif pr) + _ -> False) + bad_bif + lint_ax (UnbranchedAxiom ax) prs + = lintBranch this_co (coAxiomTyCon ax) (coAxiomSingleBranch ax) prs + lint_ax (BranchedAxiom ax ind) prs + = do { checkL (0 <= ind && ind < numBranches (coAxiomBranches ax)) + (bad_ax this_co (text "index out of range")) + ; lintBranch this_co (coAxiomTyCon ax) (coAxiomNthBranch ax ind) prs } + + bad_bif = bad_ax this_co (text "Proves returns Nothing") + + err :: forall a. String -> [SDoc] -> LintM a + err m xs = failWithL $ + hang (text m) 2 $ vcat (text "Rule:" <+> ppr ax : xs) + + lint_roles n (e : es) (co:cos) + | e == coercionRole co + = lint_roles (n+1) es cos + | otherwise = err "Argument roles mismatch" + [ text "In argument:" <+> int (n+1) + , text "Expected:" <+> ppr e + , text "Found:" <+> ppr (coercionRole co) ] + lint_roles _ [] [] = return () + lint_roles n [] rs = err "Too many coercion arguments" + [ text "Expected:" <+> int n + , text "Provided:" <+> int (n + length rs) ] + + lint_roles n es [] = err "Not enough coercion arguments" + [ text "Expected:" <+> int (n + length es) + , text "Provided:" <+> int n ] + +lintCoercion (KindCo co) = lintCoercion co + +lintCoercion (SubCo co) + = do { lintCoercion co + ; lintRole co Nominal (coercionRole co) } + +lintCoercion (HoleCo h) + = failWithL (text "Unfilled coercion hole:" <+> ppr h) + +{- +Note [Conflict checking for axiom applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following type family and axiom: + +type family Equal (a :: k) (b :: k) :: Bool +type instance where + Equal a a = True + Equal a b = False +-- +Equal :: forall k::*. k -> k -> Bool +axEqual :: { forall k::*. forall a::k. Equal k a a ~ True + ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } + +The coercion (axEqual[1] <*> ) :: (Equal * Int Int ~ False) + +and that all is OK. But, all is not OK: we want to use the first branch of the +axiom in this case, not the second. The problem is that the parameters of the +first branch can unify with the supplied coercions, thus meaning that the first +branch should be taken. See also Note [Apartness] in "GHC.Core.FamInstEnv". + +For more details, see the section "Branched axiom conflict checking" in +docs/core-spec, which defines the corresponding no_conflict function used by the +Co_AxiomInstCo rule in the section "Coercion typing". +-} + +-- | Check to make sure that an axiom application is internally consistent. +-- Returns the conflicting branch, if it exists +-- Note [Conflict checking for axiom applications] +lintBranch :: Coercion -> TyCon-> CoAxBranch -> [Pair Type] -> LintM () +-- defined here to avoid dependencies in GHC.Core.Coercion +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +lintBranch this_co fam_tc branch arg_kinds + | CoAxBranch { cab_tvs = ktvs, cab_cvs = cvs } <- branch + = do { checkL (arg_kinds `equalLength` (ktvs ++ cvs)) $ + (bad_ax this_co (text "lengths")) + + ; subst <- getSubst + ; let empty_subst = zapSubst subst + ; _ <- foldlM check_ki (empty_subst, empty_subst) + (zip (ktvs ++ cvs) arg_kinds) + + ; case check_no_conflict target incomps of + Nothing -> return () + Just bad_branch -> failWithL $ bad_ax this_co $ + text "inconsistent with" <+> + pprCoAxBranch fam_tc bad_branch } + where + check_ki (subst_l, subst_r) (ktv, Pair s' t') + = do { let sk' = typeKind s' + tk' = typeKind t' + ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) + ktv_kind_r = substTy subst_r (tyVarKind ktv) + ; checkL (sk' `eqType` ktv_kind_l) + (bad_ax this_co (text "check_ki1" <+> vcat [ ppr this_co, ppr sk', ppr ktv, ppr ktv_kind_l ] )) + ; checkL (tk' `eqType` ktv_kind_r) + (bad_ax this_co (text "check_ki2" <+> vcat [ ppr this_co, ppr tk', ppr ktv, ppr ktv_kind_r ] )) + ; return (extendTCvSubst subst_l ktv s', + extendTCvSubst subst_r ktv t') } + + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + incomps = coAxBranchIncomps branch + (tys, cotys) = splitAtList tvs (map pFst arg_kinds) + co_args = map stripCoercionTy cotys + subst = zipTvSubst tvs tys `composeTCvSubst` + zipCvSubst cvs co_args + target = Type.substTys subst (coAxBranchLHS branch) + + check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch + check_no_conflict _ [] = Nothing + check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) + -- See Note [Apartness] in GHC.Core.FamInstEnv + | SurelyApart <- tcUnifyTysFG alwaysBindFam alwaysBindTv flat lhs_incomp + = check_no_conflict flat rest + | otherwise + = Just b + +bad_ax :: Coercion -> SDoc -> SDoc +bad_ax this_co what + = hang (text "Bad axiom application" <+> parens what) 2 (ppr this_co) + + +{- +************************************************************************ +* * + Axioms +* * +************************************************************************ +-} + +lintAxioms :: Logger + -> LintConfig + -> SDoc -- ^ The source of the linted axioms + -> [CoAxiom Branched] + -> IO () +lintAxioms logger cfg what axioms = + displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $ + initL cfg $ + do { mapM_ lint_axiom axioms + ; let axiom_groups = groupWith coAxiomTyCon axioms + ; mapM_ lint_axiom_group axiom_groups } + +lint_axiom :: CoAxiom Branched -> LintM () +lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches + , co_ax_role = ax_role }) + = addLoc (InAxiom ax) $ + do { mapM_ (lint_branch tc) branch_list + ; extra_checks } + where + branch_list = fromBranches branches + + extra_checks + | isNewTyCon tc + = do { CoAxBranch { cab_tvs = ax_tvs + , cab_eta_tvs = eta_tvs + , cab_cvs = cvs + , cab_roles = roles + , cab_lhs = lhs_tys } + <- case branch_list of + [branch] -> return branch + _ -> failWithL (text "multi-branch axiom with newtype") + + -- The LHS of the axiom is (N lhs_tys) + -- We expect it to be (N ax_tvs) + ; lintL (mkTyVarTys ax_tvs `eqTypes` lhs_tys) + (text "Newtype axiom LHS does not match newtype definition") + ; lintL (null cvs) + (text "Newtype axiom binds coercion variables") + ; lintL (null eta_tvs) -- See Note [Eta reduction for data families] + -- which is not about newtype axioms + (text "Newtype axiom has eta-tvs") + ; lintL (ax_role == Representational) + (text "Newtype axiom role not representational") + ; lintL (roles `equalLength` ax_tvs) + (text "Newtype axiom roles list is the wrong length." $$ + text "roles:" <+> sep (map ppr roles)) + ; lintL (roles == takeList roles (tyConRoles tc)) + (vcat [ text "Newtype axiom roles do not match newtype tycon's." + , text "axiom roles:" <+> sep (map ppr roles) + , text "tycon roles:" <+> sep (map ppr (tyConRoles tc)) ]) + } + + | isFamilyTyCon tc + = do { if | isTypeFamilyTyCon tc + -> lintL (ax_role == Nominal) + (text "type family axiom is not nominal") + + | isDataFamilyTyCon tc + -> lintL (ax_role == Representational) + (text "data family axiom is not representational") + + | otherwise + -> addErrL (text "A family TyCon is neither a type family nor a data family:" <+> ppr tc) + + ; mapM_ (lint_family_branch tc) branch_list } + + | otherwise + = addErrL (text "Axiom tycon is neither a newtype nor a family.") + +lint_branch :: TyCon -> CoAxBranch -> LintM () +lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs_args, cab_rhs = rhs }) + = lintBinders LambdaBind (tvs ++ cvs) $ \_ -> + do { let lhs = mkTyConApp ax_tc lhs_args + ; lintType lhs + ; lintType rhs + ; lhs_kind <- substTyM (typeKind lhs) + ; rhs_kind <- substTyM (typeKind rhs) + ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $ + hang (text "Inhomogeneous axiom") + 2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$ + text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) } + -- Type and Constraint are not Apart, so this test allows + -- the newtype axiom for a single-method class. Indeed the + -- whole reason Type and Constraint are not Apart is to allow + -- such axioms! + +-- these checks do not apply to newtype axioms +lint_family_branch :: TyCon -> CoAxBranch -> LintM () +lint_family_branch fam_tc br@(CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_cvs = cvs + , cab_roles = roles + , cab_lhs = lhs + , cab_incomps = incomps }) + = do { lintL (isDataFamilyTyCon fam_tc || null eta_tvs) + (text "Type family axiom has eta-tvs") + ; lintL (all (`elemVarSet` tyCoVarsOfTypes lhs) tvs) + (text "Quantified variable in family axiom unused in LHS") + ; lintL (all isTyFamFree lhs) + (text "Type family application on LHS of family axiom") + ; lintL (all (== Nominal) roles) + (text "Non-nominal role in family axiom" $$ + text "roles:" <+> sep (map ppr roles)) + ; lintL (null cvs) + (text "Coercion variables bound in family axiom") + ; forM_ incomps $ \ br' -> + lintL (not (compatibleBranches br br')) $ + hang (text "Incorrect incompatible branches:") + 2 (vcat [text "Branch:" <+> ppr br, + text "Bogus incomp:" <+> ppr br']) } + +lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM () +lint_axiom_group (_ :| []) = return () +lint_axiom_group (ax :| axs) + = do { lintL (isOpenFamilyTyCon tc) + (text "Non-open-family with multiple axioms") + ; let all_pairs = [ (ax1, ax2) | ax1 <- all_axs + , ax2 <- all_axs ] + ; mapM_ (lint_axiom_pair tc) all_pairs } + where + all_axs = ax : axs + tc = coAxiomTyCon ax + +lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM () +lint_axiom_pair tc (ax1, ax2) + | Just br1@(CoAxBranch { cab_tvs = tvs1 + , cab_lhs = lhs1 + , cab_rhs = rhs1 }) <- coAxiomSingleBranch_maybe ax1 + , Just br2@(CoAxBranch { cab_tvs = tvs2 + , cab_lhs = lhs2 + , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2 + = lintL (compatibleBranches br1 br2) $ + vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2 + , text "are incompatible" ] + , text "tvs1 =" <+> pprTyVars tvs1 + , text "lhs1 =" <+> ppr (mkTyConApp tc lhs1) + , text "rhs1 =" <+> ppr rhs1 + , text "tvs2 =" <+> pprTyVars tvs2 + , text "lhs2 =" <+> ppr (mkTyConApp tc lhs2) + , text "rhs2 =" <+> ppr rhs2 ] + + | otherwise + = addErrL (text "Open type family axiom has more than one branch: either" <+> + ppr ax1 <+> text "or" <+> ppr ax2) + +{- +************************************************************************ +* * +\subsection[lint-monad]{The Lint monad} +* * +************************************************************************ +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] +data LintEnv + = LE { le_flags :: LintFlags -- Linting the result of this pass + , le_loc :: [LintLocInfo] -- Locations + + , le_subst :: Subst + -- Current substitution, for TyCoVars only. + -- Non-CoVar Ids don't appear in here, not even in the InScopeSet + -- Used for (a) cloning to avoid shadowing of TyCoVars, + -- so that eqType works ok + -- (b) substituting for let-bound tyvars, when we have + -- (let @a = Int -> Int in ...) + + , le_in_vars :: VarEnv (InVar, OutType) + -- Maps an InVar (i.e. its unique) to its binding InVar + -- and to its OutType + -- /All/ in-scope variables are here (term variables, + -- type variables, and coercion variables) + -- Used at an occurrence of the InVar + + , le_joins :: IdSet -- Join points in scope that are valid + -- A subset of the InScopeSet in le_subst + -- See Note [Join points] + + , le_ue_aliases :: NameEnv UsageEnv + -- See Note [Linting linearity] + -- Assigns usage environments to the alias-like binders, + -- as found in non-recursive lets. + -- Domain is OutIds + + , le_platform :: Platform -- ^ Target platform + , le_diagOpts :: DiagOpts -- ^ Target platform + } + +data LintFlags + = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] + , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] + , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] + , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] + , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] + , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism] + } + +-- See Note [Checking StaticPtrs] +data StaticPtrCheck + = AllowAnywhere + -- ^ Allow 'makeStatic' to occur anywhere. + | AllowAtTopLevel + -- ^ Allow 'makeStatic' calls at the top-level only. + | RejectEverywhere + -- ^ Reject any 'makeStatic' occurrence. + deriving Eq + +newtype LintM a = + LintM' { unLintM :: + LintEnv -> + WarnsAndErrs -> -- Warning and error messages so far + LResult a } -- Result and messages (if any) + + +pattern LintM :: (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern LintM m <- LintM' m + where + LintM m = LintM' (oneShot $ \env -> oneShot $ \we -> m env we) + -- LintM m = LintM' (oneShot $ oneShot m) +{-# COMPLETE LintM #-} + +instance Functor (LintM) where + fmap f (LintM m) = LintM $ \e w -> mapLResult f (m e w) + +type WarnsAndErrs = (Bag SDoc, Bag SDoc) + +-- Using a unboxed tuple here reduced allocations for a lint heavy +-- file by ~6%. Using MaybeUB reduced them further by another ~12%. +-- +-- Warning: if you don't inline the matcher for JustUB etc, Lint becomes +-- /tremendously/ inefficient, and compiling GHC.Tc.Errors.Types (which +-- contains gigantic types) is very very slow indeed. Conclusion: make +-- sure unfoldings are expose in GHC.Data.Unboxed, and that you compile +-- Lint.hs with optimistation on. +type LResult a = (# MaybeUB a, WarnsAndErrs #) + +pattern LResult :: MaybeUB a -> WarnsAndErrs -> LResult a +pattern LResult m w = (# m, w #) +{-# COMPLETE LResult #-} + +mapLResult :: (a1 -> a2) -> LResult a1 -> LResult a2 +mapLResult f (LResult r w) = LResult (fmapMaybeUB f r) w + +-- Just for testing. +fromBoxedLResult :: (Maybe a, WarnsAndErrs) -> LResult a +fromBoxedLResult (Just x, errs) = LResult (JustUB x) errs +fromBoxedLResult (Nothing,errs) = LResult NothingUB errs + +{- Note [Checking for global Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before CoreTidy, all locally-bound Ids must be LocalIds, even +top-level ones. See Note [Exported LocalIds] and #9857. + +Note [Checking StaticPtrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. + +Every occurrence of the function 'makeStatic' should be moved to the +top level by the FloatOut pass. It's vital that we don't have nested +'makeStatic' occurrences after CorePrep, because we populate the Static +Pointer Table from the top-level bindings. See SimplCore Note [Grand +plan for static forms]. + +The linter checks that no occurrence is left behind, nested within an +expression. The check is enabled only after the FloatOut, CorePrep, +and CoreTidy passes and only if the module uses the StaticPointers +language extension. Checking more often doesn't help since the condition +doesn't hold until after the first FloatOut pass. + +Note [Type substitution] +~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we need a type substitution? Consider + /\(a:*). \(x:a). /\(a:*). id a x +This is ill typed, because (renaming variables) it is really + /\(a:*). \(x:a). /\(b:*). id b x +Hence, when checking an application, we can't naively compare x's type +(at its binding site) with its expected type (at a use site). So we +rename type binders as we go, maintaining a substitution. + +The same substitution also supports let-type, current expressed as + (/\(a:*). body) ty +Here we substitute 'ty' for 'a' in 'body', on the fly. + +Note [Linting type synonym applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When linting a type-synonym, or type-family, application + S ty1 .. tyn +we behave as follows (#15057, #T15664): + +* If lf_report_unsat_syns = True, and S has arity < n, + complain about an unsaturated type synonym or type family + +* Switch off lf_report_unsat_syns, and lint ty1 .. tyn. + + Reason: catch out of scope variables or other ill-kinded gubbins, + even if S discards that argument entirely. E.g. (#15012): + type FakeOut a = Int + type family TF a + type instance TF Int = FakeOut a + Here 'a' is out of scope; but if we expand FakeOut, we conceal + that out-of-scope error. + + Reason for switching off lf_report_unsat_syns: with + LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they + are saturated when the type is expanded. Example + type T f = f Int + type S a = a -> a + type Z = T S + In Z's RHS, S appears unsaturated, but it is saturated when T is expanded. + +* If lf_report_unsat_syns is on, expand the synonym application and + lint the result. Reason: want to check that synonyms are saturated + when the type is expanded. + +Note [Linting linearity] +~~~~~~~~~~~~~~~~~~~~~~~~ +Lint ignores linearity unless `-dlinear-core-lint` is set. For why, see below. + +* When do we /check linearity/ in Lint? That is, when is `-dlinear-core-lint` + lint set? Answer: we check linearity in the output of the desugarer, shortly + after type checking. + +* When so we /not/ check linearity in Lint? On all passes after desugaring. Why? + Because optimisation passes are not (yet) guaranteed to maintain linearity. + They should do so semantically (GHC is careful not to duplicate computation) + but it is much harder to ensure that the statically-checkable constraints of + Linear Core are maintained. See examples below. + +The current Linear Core is described in the wiki at: +https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation. + +Concretely, "ignore linearity in Lint" specifically means two things: +* In `ensureEqTypes`, use `eqTypeIgnoringMultiplicity` +* In `ensureSubMult`, do nothing + +Here are some examples of how the optimiser can break linearity checking. Other +examples are documented in the linear-type implementation wiki page +[https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes] + +* EXAMPLE 1: the binder swap transformation + Consider + + data T = MkT {-# UNPACK #-} !Int + + The wrapper for MkT is + + $wMkT :: Int %1 -> T + $wMkT n = case %1 n of + I# n' -> MkT n' + + This introduces, in particular, a `case %1` (this is not actual Haskell or + Core syntax), where the `%1` means that the `case` expression consumes its + scrutinee linearly. + + Now, `case %1` interacts with the binder swap optimisation in a non-trivial + way. Take a slightly modified version of the code for $wMkT: + + case %1 x of z { + I# n' -> (x, n') + } + + Binder-swap changes this to + + case %1 x of z { + I# n' -> let x = z in (x, n') + } + + This is rejected by `-dlinear-core-lint` because 1/ n' must be used linearly + 2/ `-dlinear-core-lint` recognises a use of `z` as a use of `n'`. So it sees + two uses of n' where there should be a single one. + +* EXAMPLE 2: letrec + Some optimisations can create a letrec which uses a variable + linearly, e.g. + + letrec f True = f False + f False = x + in f True + + uses 'x' linearly, but this is not seen by the linter, which considers, + conservatively, that a letrec always has multiplicity Many (in particular + that every captured free variable must have multiplicity Many). This issue + is discussed in ticket #18694. + +* EXAMPLE 3: rewrite rules + Ignoring linearity means in particular that `a -> b` and `a %1 -> b` must be + treated the same by rewrite rules (see also Note [Rewrite rules ignore + multiplicities in FunTy] in GHC.Core.Unify). Consider + + m :: Bool -> A + m' :: (Bool -> Bool) -> A + {- RULES "ex" forall f. m (f True) = m' f -} + + f :: Bool %1 -> A + x = m (f True) + + The rule "ex" must match . So the linter must accept `m' f`. + +* EXAMPLE 4: eta-reduction + Eta-expansion can change linear functions into unrestricted functions + + f :: A %1 -> B + + g :: A %Many -> B + g = \x -> f x + + Eta-reduction undoes this and produces: + + g :: A %Many -> B + g = f + +Historical note: In the original linear-types implementation, we had tried to +make every optimisation pass produce code that passes `-dlinear-core-lint`. It +had proved very difficult. We kept finding corner case after corner +case. Furthermore, to attempt to achieve that goal we ended up restricting +transformations when `-dlinear-core-lint` couldn't typecheck the result. + +In the future, we may be able to lint the linearity of the output of +Core-to-Core passes (#19165). But this shouldn't be done at the expense of +producing efficient code. Therefore we lay the following principle. + +PRINCIPLE: The type system bends to the optimisation, not the other way around. + +There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123 + +Note [Linting representation-polymorphic builtins] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Representation-polymorphism checking built-ins], on +top of the two main representation-polymorphism invariants described in the +Note [Representation polymorphism invariants], we must perform additional +representation-polymorphism checks on builtin functions which don't have a +binding, for example to ensure that we don't run afoul of the +representation-polymorphism invariants when eta-expanding. + +There are two situations: + + 1. Builtins which have skolem type variables which must be instantiated to + concrete types, such as the RuntimeRep type argument r to the catch# primop. + + 2. Representation-polymorphic unlifted newtypes, which must always be instantiated + at a fixed runtime representation. + +For 1, consider for example 'coerce': + + coerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b + +We store in the IdDetails of the coerce Id that the first binder, r, must always +be instantiated to a concrete type. We thus check this in Core Lint: whenever we +see an application of the form + + coerce @{rep1} ... + +we ensure that 'rep1' is concrete. This is done in the function "checkRepPolyBuiltinApp". +Moreover, not instantiating these type variables at all is also an error, as +we would again not be able to perform eta-expansion. (This is a bit more theoretical, +as in user programs the typechecker will insert these type applications when +instantiating, but it can still arise when constructing Core expressions). + +For 2, whenever we have an unlifted newtype such as + + type RR :: Type -> RuntimeRep + type family RR a + + type F :: forall (a :: Type) -> TYPE (RR a) + type family F a + + type N :: forall (a :: Type) -> TYPE (RR a) + newtype N a = MkN (F a) + +and an unsaturated occurrence + + MkN @ty -- NB: no value argument! + +we check that the (instantiated) argument type has a fixed runtime representation. +This is done in the function "checkRepPolyNewtypeApp". +-} + +instance Applicative LintM where + pure x = LintM $ \ _ errs -> LResult (JustUB x) errs + --(Just x, errs) + (<*>) = ap + +instance Monad LintM where + m >>= k = LintM (\ env errs -> + let res = unLintM m env errs in + case res of + LResult (JustUB r) errs' -> unLintM (k r) env errs' + LResult NothingUB errs' -> LResult NothingUB errs' + ) + -- LError errs'-> LError errs') + -- let (res, errs') = unLintM m env errs in + -- Just r -> unLintM (k r) env errs' + -- Nothing -> (Nothing, errs')) + +instance MonadFail LintM where + fail err = failWithL (text err) + +getPlatform :: LintM Platform +getPlatform = LintM (\ e errs -> (LResult (JustUB $ le_platform e) errs)) + +data LintLocInfo + = RhsOf Id -- The variable bound + | OccOf Id -- Occurrence of id + | LambdaBodyOf Id -- The lambda-binder + | RuleOf Id -- Rules attached to a binder + | UnfoldingOf Id -- Unfolding of a binder + | BodyOfLet Id -- The let-bound variable + | BodyOfLetRec [Id] -- The binders of the let + | CaseAlt CoreAlt -- Case alternative + | CasePat CoreAlt -- The *pattern* of the case alternative + | CaseTy CoreExpr -- The type field of a case expression + -- with this scrutinee + | IdTy Id -- The type field of an Id binder + | AnExpr CoreExpr -- Some expression + | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + | TopLevelBindings + | InType Type -- Inside a type + | InCo Coercion -- Inside a coercion + | InAxiom (CoAxiom Branched) -- Inside a CoAxiom + +data LintConfig = LintConfig + { l_diagOpts :: !DiagOpts -- ^ Diagnostics opts + , l_platform :: !Platform -- ^ Target platform + , l_flags :: !LintFlags -- ^ Linting the result of this pass + , l_vars :: ![Var] -- ^ 'Id's that should be treated as being in scope + } + +initL :: LintConfig + -> LintM a -- ^ Action to run + -> WarnsAndErrs +initL cfg m + = case unLintM m env (emptyBag, emptyBag) of + LResult (JustUB _) errs -> errs + LResult NothingUB errs@(_, e) | not (isEmptyBag e) -> errs + | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ + "without reporting an error message") empty + where + vars = l_vars cfg + env = LE { le_flags = l_flags cfg + , le_subst = mkEmptySubst (mkInScopeSetList vars) + , le_in_vars = mkVarEnv [ (v,(v, varType v)) | v <- vars ] + , le_joins = emptyVarSet + , le_loc = [] + , le_ue_aliases = emptyNameEnv + , le_platform = l_platform cfg + , le_diagOpts = l_diagOpts cfg + } + +setReportUnsat :: Bool -> LintM a -> LintM a +-- Switch off lf_report_unsat_syns +setReportUnsat ru thing_inside + = LintM $ \ env errs -> + let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } } + in unLintM thing_inside env' errs + +-- See Note [Checking for representation polymorphism] +noFixedRuntimeRepChecks :: LintM a -> LintM a +noFixedRuntimeRepChecks thing_inside + = LintM $ \env errs -> + let env' = env { le_flags = (le_flags env) { lf_check_fixed_rep = False } } + in unLintM thing_inside env' errs + +getLintFlags :: LintM LintFlags +getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs) + +checkL :: Bool -> SDoc -> LintM () +checkL True _ = return () +checkL False msg = failWithL msg + +-- like checkL, but relevant to type checking +lintL :: Bool -> SDoc -> LintM () +lintL = checkL + +checkWarnL :: Bool -> SDoc -> LintM () +checkWarnL True _ = return () +checkWarnL False msg = addWarnL msg + +failWithL :: SDoc -> LintM a +failWithL msg = LintM $ \ env (warns,errs) -> + fromBoxedLResult (Nothing, (warns, addMsg True env errs msg)) + +addErrL :: SDoc -> LintM () +addErrL msg = LintM $ \ env (warns,errs) -> + fromBoxedLResult (Just (), (warns, addMsg True env errs msg)) + +addWarnL :: SDoc -> LintM () +addWarnL msg = LintM $ \ env (warns,errs) -> + fromBoxedLResult (Just (), (addMsg True env warns msg, errs)) + +addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc +addMsg show_context env msgs msg + = assertPpr (notNull loc_msgs) msg $ + msgs `snocBag` mk_msg msg + where + loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first + loc_msgs = map dumpLoc (le_loc env) + + cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs + , text "Substitution:" <+> ppr (le_subst env) ] + + context | show_context = cxt_doc + | otherwise = whenPprDebug cxt_doc + -- Print voluminous info for Lint errors + -- but not for warnings + + msg_span = case [ span | (loc,_) <- loc_msgs + , let span = srcLocSpan loc + , isGoodSrcSpan span ] of + [] -> noSrcSpan + (s:_) -> s + !diag_opts = le_diagOpts env + mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span + (msg $$ context) + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m + = LintM $ \ env errs -> + unLintM m (env { le_loc = extra_loc : le_loc env }) errs + +inCasePat :: LintM Bool -- A slight hack; see the unique call site +inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs) + where + is_case_pat (LE { le_loc = CasePat {} : _ }) = True + is_case_pat _other = False + +addInScopeId :: InId -> OutType -> (OutId -> LintM a) -> LintM a +-- Unlike addInScopeTyCoVar, this function does no cloning; Ids never get cloned +addInScopeId in_id out_ty thing_inside + = LintM $ \ env errs -> + let !(out_id, env') = add env + in unLintM (thing_inside out_id) env' errs + + where + add env@(LE { le_in_vars = id_vars, le_joins = join_set + , le_ue_aliases = aliases, le_subst = subst }) + = (out_id, env1) + where + env1 = env { le_in_vars = in_vars', le_joins = join_set', le_ue_aliases = aliases' } + + in_vars' = extendVarEnv id_vars in_id (in_id, out_ty) + aliases' = delFromNameEnv aliases (idName in_id) + -- aliases': when shadowing an alias, we need to make sure the + -- Id is no longer classified as such. E.g. + -- let x = in case x of x { _DEFAULT -> } + -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1. + + -- A very tiny optimisation, not sure if it's really worth it + -- Short-cut when the substitution is a no-op + out_id | isEmptyTCvSubst subst = in_id + | otherwise = setIdType in_id out_ty + + join_set' + | isJoinId out_id = extendVarSet join_set in_id -- Overwrite with new arity + | otherwise = delVarSet join_set in_id -- Remove any existing binding + +addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a +-- This function clones to avoid shadowing of TyCoVars +addInScopeTyCoVar tcv tcv_type thing_inside + = LintM $ \ env@(LE { le_in_vars = in_vars, le_subst = subst }) errs -> + let (tcv', subst') = subst_bndr subst + env' = env { le_in_vars = extendVarEnv in_vars tcv (tcv, tcv_type) + , le_subst = subst' } + in unLintM (thing_inside tcv') env' errs + where + subst_bndr subst + | isEmptyTCvSubst subst -- No change in kind + , not (tcv `elemInScopeSet` in_scope) -- Not already in scope + = -- Do not extend the substitution, just the in-scope set + (if (varType tcv `eqType` tcv_type) then (\x->x) else + pprTrace "addInScopeTyCoVar" ( + vcat [ text "tcv" <+> ppr tcv <+> dcolon <+> ppr (varType tcv) + , text "tcv_type" <+> ppr tcv_type ])) $ + (tcv, subst `extendSubstInScope` tcv) + + -- Clone, and extend the substitution + | let tcv' = uniqAway in_scope (setVarType tcv tcv_type) + = (tcv', extendTCvSubstWithClone subst tcv tcv') + where + in_scope = substInScopeSet subst + +getInVarEnv :: LintM (VarEnv (InId, OutType)) +getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_in_vars env), errs)) + +extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a +extendTvSubstL tv ty m + = LintM $ \ env errs -> + unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs + +markAllJoinsBad :: LintM a -> LintM a +markAllJoinsBad m + = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs + +markAllJoinsBadIf :: Bool -> LintM a -> LintM a +markAllJoinsBadIf True m = markAllJoinsBad m +markAllJoinsBadIf False m = m + +getValidJoins :: LintM IdSet +getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs)) + +getSubst :: LintM Subst +getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs)) + +substTyM :: InType -> LintM OutType +-- Apply the substitution to the type +-- The substitution is often empty, in which case it is a no-op +substTyM ty + = do { subst <- getSubst + ; return (substTy subst ty) } + +getUEAliases :: LintM (NameEnv UsageEnv) +getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs)) + +getInScope :: LintM InScopeSet +getInScope = LintM (\ env errs -> fromBoxedLResult (Just (substInScopeSet $ le_subst env), errs)) + +lintVarOcc :: InVar -> LintM OutType +-- Used at an occurrence of a variable: term variables, type variables, and coercion variables +-- Checks two things: +-- a) that it is in scope +-- b) that the InType at the ocurrences matches the InType at the binding site +lintVarOcc v_occ + = do { in_var_env <- getInVarEnv + ; case lookupVarEnv in_var_env v_occ of + Nothing | isGlobalId v_occ -> return (idType v_occ) + | otherwise -> failWithL (text pp_what <+> quotes (ppr v_occ) + <+> text "is out of scope") + Just (v_bndr, out_ty) -> do { check_bad_global v_bndr + ; ensureEqTys occ_ty bndr_ty $ -- Compares InTypes + mkBndrOccTypeMismatchMsg v_occ bndr_ty occ_ty + ; return out_ty } + where + occ_ty = varType v_occ + bndr_ty = varType v_bndr } + where + pp_what | isTyVar v_occ = "The type variable" + | isCoVar v_occ = "The coercion variable" + | otherwise = "The value variable" + + -- 'check_bad_global' checks for the case where an /occurrence/ is + -- a GlobalId, but there is an enclosing binding fora a LocalId. + -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, + -- but GHCi adds GlobalIds from the interactive context. These + -- are fine; hence the test (isLocalId id == isLocalId v) + -- NB: when compiling Control.Exception.Base, things like absentError + -- are defined locally, but appear in expressions as (global) + -- wired-in Ids after worker/wrapper + -- So we simply disable the test in this case + check_bad_global v_bndr + | isGlobalId v_occ + , isLocalId v_bndr + , not (isWiredIn v_occ) + = failWithL $ hang (text "Occurrence is GlobalId, but binding is LocalId") + 2 (vcat [ hang (text "occurrence:") 2 $ pprBndr LetBind v_occ + , hang (text "binder :") 2 $ pprBndr LetBind v_bndr ]) + | otherwise + = return () + +lookupJoinId :: Id -> LintM JoinPointHood +-- Look up an Id which should be a join point, valid here +-- If so, return its arity, if not return Nothing +lookupJoinId id + = do { join_set <- getValidJoins + ; case lookupVarSet join_set id of + Just id' -> return (idJoinPointHood id') + Nothing -> return NotJoinPoint } + +addAliasUE :: OutId -> UsageEnv -> LintM a -> LintM a +addAliasUE id ue thing_inside = LintM $ \ env errs -> + let new_ue_aliases = + extendNameEnv (le_ue_aliases env) (getName id) ue + in + unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs + +varCallSiteUsage :: OutId -> LintM UsageEnv +varCallSiteUsage id = + do m <- getUEAliases + return $ case lookupNameEnv m (getName id) of + Nothing -> singleUsageUE id + Just id_ue -> id_ue + +ensureEqTys :: OutType -> OutType -> SDoc -> LintM () +-- check ty2 is subtype of ty1 (ie, has same structure but usage +-- annotations need only be consistent, not equal) +-- Assumes ty1,ty2 are have already had the substitution applied +{-# INLINE ensureEqTys #-} -- See Note [INLINE ensureEqTys] +ensureEqTys ty1 ty2 msg + = do { flags <- getLintFlags + ; lintL (eq_type flags ty1 ty2) msg } + +eq_type :: LintFlags -> Type -> Type -> Bool +-- When `-dlinear-core-lint` is off, then consider `a -> b` and `a %1 -> b` to +-- be equal. See Note [Linting linearity]. +eq_type flags ty1 ty2 | lf_check_linearity flags = eqType ty1 ty2 + | otherwise = eqTypeIgnoringMultiplicity ty1 ty2 + +{- Note [INLINE ensureEqTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To make Lint fast, we want to avoid allocating a thunk for in + ensureEqTypes ty1 ty2 +because the test almost always succeeds, and isn't needed. +So we INLINE `ensureEqTys`. This actually make a difference of +1-2% when compiling programs with -dcore-lint. +-} + +ensureSubUsage :: Usage -> Mult -> SDoc -> LintM () +ensureSubUsage Bottom _ _ = return () +ensureSubUsage Zero described_mult err_msg = ensureSubMult ManyTy described_mult err_msg +ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg + +ensureSubMult :: Mult -> Mult -> SDoc -> LintM () +ensureSubMult actual_mult described_mult err_msg = do + flags <- getLintFlags + when (lf_check_linearity flags) $ + unless (deepSubMult actual_mult described_mult) $ + addErrL err_msg + where + -- Check for submultiplicity using the following rules: + -- 1. x*y <= z when x <= z and y <= z. + -- This rule follows from the fact that x*y = sup{x,y} for any + -- multiplicities x,y. + -- 2. x <= y*z when x <= y or x <= z. + -- This rule is not complete: when x = y*z, we cannot + -- change y*z <= y*z to y*z <= y or y*z <= z. + -- However, we eliminate products on the LHS in step 1. + -- 3. One <= x and x <= Many for any x, as checked by 'submult'. + -- 4. x <= x. + -- Otherwise, we fail. + deepSubMult :: Mult -> Mult -> Bool + deepSubMult m n + | Just (m1, m2) <- isMultMul m = deepSubMult m1 n && deepSubMult m2 n + | Just (n1, n2) <- isMultMul n = deepSubMult m n1 || deepSubMult m n2 + | Submult <- m `submult` n = True + | otherwise = m `eqType` n + +lintRole :: Outputable thing + => thing -- where the role appeared + -> Role -- expected + -> Role -- actual + -> LintM () +lintRole co r1 r2 + = lintL (r1 == r2) + (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> + text "got" <+> ppr r2 $$ + text "in" <+> ppr co) + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) + +dumpLoc (RhsOf v) + = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v]) + +dumpLoc (OccOf v) + = (getSrcLoc v, text "In an occurrence of" <+> pp_binder v) + +dumpLoc (LambdaBodyOf b) + = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b) + +dumpLoc (RuleOf b) + = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b) + +dumpLoc (UnfoldingOf b) + = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) + +dumpLoc (BodyOfLet b) + = (noSrcLoc, text "In the body of a let with binder" <+> pp_binder b) + +dumpLoc (BodyOfLetRec []) + = (noSrcLoc, text "In body of a letrec with no binders") + +dumpLoc (BodyOfLetRec bs@(b:_)) + = ( getSrcLoc b, text "In the body of a letrec with binders" <+> pp_binders bs) + +dumpLoc (AnExpr e) + = (noSrcLoc, text "In the expression:" <+> ppr e) + +dumpLoc (CaseAlt (Alt con args _)) + = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CasePat (Alt con args _)) + = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CaseTy scrut) + = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:") + 2 (ppr scrut)) + +dumpLoc (IdTy b) + = (getSrcLoc b, text "In the type of a binder:" <+> ppr b) + +dumpLoc (ImportedUnfolding locn) + = (locn, text "In an imported unfolding") +dumpLoc TopLevelBindings + = (noSrcLoc, Outputable.empty) +dumpLoc (InType ty) + = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) +dumpLoc (InCo co) + = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) +dumpLoc (InAxiom ax) + = (getSrcLoc ax, hang (text "In the coercion axiom") + 2 (pprCoAxiom ax)) + +pp_binders :: [Var] -> SDoc +pp_binders bs = sep (punctuate comma (map pp_binder bs)) + +pp_binder :: Var -> SDoc +pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] + | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] + +------------------------------------------------------ +-- Messages for case expressions + +mkDefaultArgsMsg :: [Var] -> SDoc +mkDefaultArgsMsg args + = hang (text "DEFAULT case with binders") + 4 (ppr args) + +mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc +mkCaseAltMsg e ty1 ty2 + = hang (text "Type of case alternatives not the same as the annotation on case:") + 4 (vcat [ text "Actual type:" <+> ppr ty1, + text "Annotation on case:" <+> ppr ty2, + text "Alt Rhs:" <+> ppr e ]) + +mkScrutMsg :: Id -> Type -> Type -> SDoc +mkScrutMsg var var_ty scrut_ty + = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, + text "Result binder type:" <+> ppr var_ty,--(idType var), + text "Scrutinee type:" <+> ppr scrut_ty] + +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc +mkNonDefltMsg e + = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) +mkNonIncreasingAltsMsg e + = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) + +nonExhaustiveAltsMsg :: CoreExpr -> SDoc +nonExhaustiveAltsMsg e + = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) + +mkBadConMsg :: TyCon -> DataCon -> SDoc +mkBadConMsg tycon datacon + = vcat [ + text "In a case alternative, data constructor isn't in scrutinee type:", + text "Scrutinee type constructor:" <+> ppr tycon, + text "Data con:" <+> ppr datacon + ] + +mkBadPatMsg :: Type -> Type -> SDoc +mkBadPatMsg con_result_ty scrut_ty + = vcat [ + text "In a case alternative, pattern result type doesn't match scrutinee type:", + text "Pattern result type:" <+> ppr con_result_ty, + text "Scrutinee type:" <+> ppr scrut_ty + ] + +integerScrutinisedMsg :: SDoc +integerScrutinisedMsg + = text "In a LitAlt, the literal is lifted (probably Integer)" + +mkBadAltMsg :: Type -> CoreAlt -> SDoc +mkBadAltMsg scrut_ty alt + = vcat [ text "Data alternative when scrutinee is not a tycon application", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + +mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc +mkNewTyDataConAltMsg scrut_ty alt + = vcat [ text "Data alternative for newtype datacon", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + + +------------------------------------------------------ +-- Other error messages + +mkAppMsg :: Type -> Type -> CoreExpr -> SDoc +mkAppMsg expected_arg_ty actual_arg_ty arg + = vcat [text "Argument value doesn't match argument type:", + hang (text "Expected arg type:") 4 (ppr expected_arg_ty), + hang (text "Actual arg type:") 4 (ppr actual_arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc +mkNonFunAppMsg fun_ty arg_ty arg + = vcat [text "Non-function type in function position", + hang (text "Fun type:") 4 (ppr fun_ty), + hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkLetErr :: TyVar -> CoreExpr -> SDoc +mkLetErr bndr rhs + = vcat [text "Bad `let' binding:", + hang (text "Variable:") + 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), + hang (text "Rhs:") + 4 (ppr rhs)] + +mkTyAppMsg :: OutType -> Type -> SDoc +mkTyAppMsg ty arg_ty + = vcat [text "Illegal type application:", + hang (text "Function type:") + 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), + hang (text "Type argument:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +emptyRec :: CoreExpr -> SDoc +emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) + +mkRhsMsg :: Id -> SDoc -> Type -> SDoc +mkRhsMsg binder what ty + = vcat + [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, + ppr binder], + hsep [text "Binder's type:", ppr (idType binder)], + hsep [text "Rhs type:", ppr ty]] + +badBndrTyMsg :: Id -> SDoc -> SDoc +badBndrTyMsg binder what + = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder + , text "Binder's type:" <+> ppr (idType binder) ] + +mkNonTopExportedMsg :: Id -> SDoc +mkNonTopExportedMsg binder + = hsep [text "Non-top-level binder is marked as exported:", ppr binder] + +mkNonTopExternalNameMsg :: Id -> SDoc +mkNonTopExternalNameMsg binder + = hsep [text "Non-top-level binder has an external name:", ppr binder] + +mkTopNonLitStrMsg :: Id -> SDoc +mkTopNonLitStrMsg binder + = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] + +mkKindErrMsg :: TyVar -> Type -> SDoc +mkKindErrMsg tyvar arg_ty + = vcat [text "Kinds don't match in type application:", + hang (text "Type variable:") + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (text "Arg type:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc +mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) + +mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc +mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) + +mk_cast_err :: String -- ^ What sort of casted thing this is + -- (\"expression\" or \"type\"). + -> String -- ^ What sort of coercion is being used + -- (\"type\" or \"kind\"). + -> SDoc -- ^ The thing being casted. + -> Coercion -> Type -> Type -> SDoc +mk_cast_err thing_str co_str pp_thing co from_ty thing_ty + = vcat [from_msg <+> text "of Cast differs from" <+> co_msg + <+> text "of" <+> enclosed_msg, + from_msg <> colon <+> ppr from_ty, + text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon + <+> ppr thing_ty, + text "Actual" <+> enclosed_msg <> colon <+> pp_thing, + text "Coercion used in cast:" <+> ppr co + ] + where + co_msg, from_msg, enclosed_msg :: SDoc + co_msg = text co_str + from_msg = text "From-" <> co_msg + enclosed_msg = text "enclosed" <+> text thing_str + +mkBadTyVarMsg :: Var -> SDoc +mkBadTyVarMsg tv + = text "Non-tyvar used in TyVarTy:" + <+> ppr tv <+> dcolon <+> ppr (varType tv) + +mkBadJoinBindMsg :: Var -> SDoc +mkBadJoinBindMsg var + = vcat [ text "Bad join point binding:" <+> ppr var + , text "Join points can be bound only by a non-top-level let" ] + +mkInvalidJoinPointMsg :: Var -> Type -> SDoc +mkInvalidJoinPointMsg var ty + = hang (text "Join point has invalid type:") + 2 (ppr var <+> dcolon <+> ppr ty) + +mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc +mkBadJoinArityMsg var ar n rhs + = vcat [ text "Join point has too few lambdas", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of lambdas:" <+> ppr (ar - n), + text "Rhs = " <+> ppr rhs + ] + +invalidJoinOcc :: Var -> SDoc +invalidJoinOcc var + = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var + , text "The binder is either not a join point, or not valid here" ] + +mkBadJumpMsg :: Var -> Int -> Int -> SDoc +mkBadJumpMsg var ar nargs + = vcat [ text "Join point invoked with wrong number of arguments", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of arguments:" <+> int nargs ] + +mkInconsistentRecMsg :: [Var] -> SDoc +mkInconsistentRecMsg bndrs + = vcat [ text "Recursive let binders mix values and join points", + text "Binders:" <+> hsep (map ppr_with_details bndrs) ] + where + ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr) + +mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc +mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ + = vcat [ text "Mismatch in join point arity between binder and occurrence" + , text "Var:" <+> ppr bndr + , text "Arity at binding site:" <+> ppr join_arity_bndr + , text "Arity at occurrence: " <+> ppr join_arity_occ ] + +mkBndrOccTypeMismatchMsg :: InVar -> InType -> InType -> SDoc +mkBndrOccTypeMismatchMsg var bndr_ty occ_ty + = vcat [ text "Mismatch in type between binder and occurrence" + , text "Binder: " <+> ppr var <+> dcolon <+> ppr bndr_ty + , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr occ_ty ] + +mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc +mkBadJoinPointRuleMsg bndr join_arity rule + = vcat [ text "Join point has rule with wrong number of arguments" + , text "Var:" <+> ppr bndr + , text "Join arity:" <+> ppr join_arity + , text "Rule:" <+> ppr rule ] + +dupVars :: [NonEmpty Var] -> SDoc +dupVars vars + = hang (text "Duplicate variables brought into scope") + 2 (ppr (map toList vars)) + +dupExtVars :: [NonEmpty Name] -> SDoc +dupExtVars vars + = hang (text "Duplicate top-level variables with the same qualified name") + 2 (ppr (map toList vars)) + +{- +************************************************************************ +* * +\subsection{Annotation Linting} +* * +************************************************************************ +-} + +-- | This checks whether a pass correctly looks through debug +-- annotations (@SourceNote@). This works a bit different from other +-- consistency checks: We check this by running the given task twice, +-- noting all differences between the results. +lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +lintAnnots pname pass guts = {-# SCC "lintAnnots" #-} do + -- Run the pass as we normally would + dflags <- getDynFlags + logger <- getLogger + when (gopt Opt_DoAnnotationLinting dflags) $ + liftIO $ Err.showPass logger "Annotation linting - first run" + -- If appropriate re-run it without debug annotations to make sure + -- that they made no difference. + if gopt Opt_DoAnnotationLinting dflags + then do + nguts <- pass guts + liftIO $ Err.showPass logger "Annotation linting - second run" + nguts' <- withoutAnnots pass guts + -- Finally compare the resulting bindings + liftIO $ Err.showPass logger "Annotation linting - comparison" + let binds = flattenBinds $ mg_binds nguts + binds' = flattenBinds $ mg_binds nguts' + (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' + when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat + [ lint_banner "warning" pname + , text "Core changes with annotations:" + , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs + ] + return nguts + else + pass guts + +-- | Run the given pass without annotations. This means that we both +-- set the debugLevel setting to 0 in the environment as well as all +-- annotations from incoming modules. +withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +withoutAnnots pass guts = do + -- Remove debug flag from environment. + -- TODO: supply tag here as well ? + let withoutFlag = mapDynFlagsCoreM $ \(!dflags) -> dflags { debugLevel = 0 } + -- Nuke existing ticks in module. + -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes + -- them in absence of debugLevel > 0. + let nukeTicks = stripTicksE (not . tickishIsCode) + nukeAnnotsBind :: CoreBind -> CoreBind + nukeAnnotsBind bind = case bind of + Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs + NonRec b e -> NonRec b $ nukeTicks e + nukeAnnotsMod mg@ModGuts{mg_binds=binds} + = mg{mg_binds = map nukeAnnotsBind binds} + -- Perform pass with all changes applied. Drop the simple count so it doesn't + -- effect the total also + dropSimplCount $ withoutFlag $ pass (nukeAnnotsMod guts) diff --git a/GHC/Core/Lint/Interactive.hs b/GHC/Core/Lint/Interactive.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Lint/Interactive.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +A ``lint'' pass to check for Core correctness. +See Note [Core Lint guarantee]. +-} + +module GHC.Core.Lint.Interactive ( + interactiveInScope, + ) where + +import GHC.Prelude + +import GHC.Runtime.Context + +import GHC.Core.Coercion +import GHC.Core.TyCo.FVs +import GHC.Core.InstEnv ( instanceDFunId, instEnvElts ) + +import GHC.Types.Id +import GHC.Types.TypeEnv + + +interactiveInScope :: InteractiveContext -> [Var] +-- In GHCi we may lint expressions, or bindings arising from 'deriving' +-- clauses, that mention variables bound in the interactive context. +-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context). +-- So we have to tell Lint about them, lest it reports them as out of scope. +-- +-- We do this by find local-named things that may appear free in interactive +-- context. This function is pretty revolting and quite possibly not quite right. +-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty +-- so this is a (cheap) no-op. +-- +-- See #8215 for an example +interactiveInScope ictxt + = tyvars ++ ids + where + -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr + (cls_insts, _fam_insts) = ic_instances ictxt + te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) + te = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts) + ids = typeEnvIds te + tyvars = tyCoVarsOfTypesList $ map idType ids + -- Why the type variables? How can the top level envt have free tyvars? + -- I think it's because of the GHCi debugger, which can bind variables + -- f :: [t] -> [t] + -- where t is a RuntimeUnk (see TcType) diff --git a/GHC/Core/Make.hs b/GHC/Core/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Make.hs @@ -0,0 +1,1305 @@ +-- | Handy functions for creating much Core syntax +module GHC.Core.Make ( + -- * Constructing normal syntax + mkCoreLet, mkCoreLets, + mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreConWrapApps, + mkCoreLams, mkCoreTyLams, + mkWildCase, mkIfThenElse, + mkWildValBinder, + mkSingleAltCase, + sortQuantVars, castBottomExpr, + + -- * Constructing boxed literals + mkLitRubbish, + mkWordExpr, + mkIntExpr, mkIntExprInt, mkUncheckedIntExpr, + mkIntegerExpr, mkNaturalExpr, + mkFloatExpr, mkDoubleExpr, + mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, + MkStringIds (..), getMkStringIds, + + -- * Floats + FloatBind(..), wrapFloat, wrapFloats, floatBindings, + + -- * Constructing small tuples + mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUnboxedSum, + mkCoreTupBoxity, unitExpr, + + -- * Constructing big tuples + mkChunkified, chunkify, + mkBigCoreVarTup, mkBigCoreVarTupSolo, + mkBigCoreVarTupTy, mkBigCoreTupTy, + mkBigCoreTup, + + -- * Deconstructing big tuples + mkBigTupleSelector, mkBigTupleSelectorSolo, mkBigTupleCase, + + -- * Constructing list expressions + mkNilExpr, mkConsExpr, mkListExpr, + mkFoldrExpr, mkBuildExpr, + + -- * Constructing Maybe expressions + mkNothingExpr, mkJustExpr, + + -- * Error Ids + mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, + rEC_CON_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, rEC_SEL_ERROR_ID, + tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID + ) where + +import GHC.Prelude +import GHC.Platform + +import GHC.Types.Id +import GHC.Types.Var ( setTyVarUnique, visArgConstraintLike ) +import GHC.Types.TyThing +import GHC.Types.Id.Info +import GHC.Types.Cpr +import GHC.Types.Basic( TypeOrConstraint(..) ) +import GHC.Types.Demand +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Literal +import GHC.Types.Unique.Supply + +import GHC.Core +import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec, mkCast ) +import GHC.Core.Type +import GHC.Core.Predicate ( scopedSort, isEqPred ) +import GHC.Core.TyCo.Compare ( eqType ) +import GHC.Core.Coercion ( isCoVar, mkRepReflCo, mkForAllVisCos ) +import GHC.Core.DataCon ( DataCon, dataConWorkId, dataConWrapId ) +import GHC.Core.Multiplicity + +import GHC.Builtin.Types +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import GHC.Settings.Constants( mAX_TUPLE_SIZE ) +import GHC.Data.FastString +import GHC.Data.Maybe ( expectJust ) + +import Data.List ( partition ) +import Data.List.NonEmpty ( NonEmpty (..) ) +import Data.Char ( ord ) + +infixl 4 `mkCoreApp`, `mkCoreApps` + +{- +************************************************************************ +* * +\subsection{Basic GHC.Core construction} +* * +************************************************************************ +-} +-- | Sort the variables, putting type and covars first, in scoped order, +-- and then other Ids +-- +-- It is a deterministic sort, meaning it doesn't look at the values of +-- Uniques. For explanation why it's important See Note [Unique Determinism] +-- in GHC.Types.Unique. +sortQuantVars :: [Var] -> [Var] +sortQuantVars vs = sorted_tcvs ++ ids + where + (tcvs, ids) = partition (isTyVar <||> isCoVar) vs + sorted_tcvs = scopedSort tcvs + +-- | Bind a binding group over an expression, using a @let@ or @case@ as +-- appropriate (see "GHC.Core#let_can_float_invariant") +mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr +mkCoreLet (NonRec bndr rhs) body -- See Note [Core let-can-float invariant] + = bindNonRec bndr rhs body +mkCoreLet bind body + = Let bind body + +-- | Create a lambda where the given expression has a number of variables +-- bound over it. The leftmost binder is that bound by the outermost +-- lambda in the result +mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr +mkCoreLams = mkLams + +-- | Create a type lambda (/\a b c. e) and apply a cast to fix up visibilities +-- if needed. See Note [Required foralls in Core] +mkCoreTyLams :: [TyVarBinder] -> CoreExpr -> CoreExpr +mkCoreTyLams binders body = mkCast lam co + where + lam = mkCoreLams (binderVars binders) body + co = mkForAllVisCos binders (mkRepReflCo (exprType body)) + +-- | Bind a list of binding groups over an expression. The leftmost binding +-- group becomes the outermost group in the resulting expression +mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr +mkCoreLets binds body = foldr mkCoreLet body binds + +-- | Construct an expression which represents the application of a number of +-- expressions to that of a data constructor expression. The leftmost expression +-- in the list is applied first +mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr +mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args + +-- | A variant of 'mkCoreConApps' constructs an expression which represents the +-- application of a number of expressions to that of a data constructor +-- expression using the wrapper, not the worker, of the data constructor. The +-- leftmost expression in the list is applied first +mkCoreConWrapApps :: DataCon -> [CoreExpr] -> CoreExpr +mkCoreConWrapApps con args = mkCoreApps (Var (dataConWrapId con)) args + +-- | Construct an expression which represents the application of a number of +-- expressions to another. The leftmost expression in the list is applied first +mkCoreApps :: CoreExpr -- ^ function + -> [CoreExpr] -- ^ arguments + -> CoreExpr +mkCoreApps fun args + = fst $ + foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args + where + doc_string = ppr fun_ty $$ ppr fun $$ ppr args + fun_ty = exprType fun + +-- | Construct an expression which represents the application of one expression +-- to the other +mkCoreApp :: SDoc + -> CoreExpr -- ^ function + -> CoreExpr -- ^ argument + -> CoreExpr +mkCoreApp s fun arg + = fst $ mkCoreAppTyped s (fun, exprType fun) arg + +-- | Construct an expression which represents the application of one expression +-- paired with its type to an argument. The result is paired with its type. This +-- function is not exported and used in the definition of 'mkCoreApp' and +-- 'mkCoreApps'. +mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) +mkCoreAppTyped _ (fun, fun_ty) (Type ty) + = (App fun (Type ty), piResultTy fun_ty ty) +mkCoreAppTyped _ (fun, fun_ty) (Coercion co) + = (App fun (Coercion co), funResultTy fun_ty) +mkCoreAppTyped d (fun, fun_ty) arg + = assertPpr (isFunTy fun_ty) (ppr fun $$ ppr arg $$ d) + (App fun arg, funResultTy fun_ty) + +{- ********************************************************************* +* * + Building case expressions +* * +********************************************************************* -} + +-- | Make a /wildcard binder/. This is typically used when you need a binder +-- that you expect to use only at a *binding* site. Do not use it at +-- occurrence sites because it has a single, fixed unique, and it's very +-- easy to get into difficulties with shadowing. That's why it is used so little. +-- +-- See Note [WildCard binders] in "GHC.Core.Opt.Simplify.Env" +mkWildValBinder :: Mult -> Type -> Id +mkWildValBinder w ty = mkLocalIdOrCoVar wildCardName w ty + -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors + -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. + +-- | Make a case expression whose case binder is unused +-- The alts and res_ty should not have any occurrences of WildId +mkWildCase :: CoreExpr -- ^ scrutinee + -> Scaled Type + -> Type -- ^ res_ty + -> [CoreAlt] -- ^ alts + -> CoreExpr +mkWildCase scrut (Scaled w scrut_ty) res_ty alts + = Case scrut (mkWildValBinder w scrut_ty) res_ty alts + +mkIfThenElse :: CoreExpr -- ^ guard + -> CoreExpr -- ^ then + -> CoreExpr -- ^ else + -> CoreExpr +mkIfThenElse guard then_expr else_expr +-- Not going to be refining, so okay to take the type of the "then" clause + = mkWildCase guard (linear boolTy) (exprType then_expr) + [ Alt (DataAlt falseDataCon) [] else_expr, -- Increasing order of tag! + Alt (DataAlt trueDataCon) [] then_expr ] + +castBottomExpr :: CoreExpr -> Type -> CoreExpr +-- (castBottomExpr e ty), assuming that 'e' diverges, +-- return an expression of type 'ty' +-- See Note [Empty case alternatives] in GHC.Core +castBottomExpr e res_ty + | e_ty `eqType` res_ty = e + | otherwise = Case e (mkWildValBinder OneTy e_ty) res_ty [] + where + e_ty = exprType e + +mkLitRubbish :: Type -> Maybe CoreExpr +-- Make a rubbish-literal CoreExpr of the given type. +-- Fail (returning Nothing) if +-- * the RuntimeRep of the Type is not monomorphic; +-- * the type is (a ~# b), the type of coercion +-- See INVARIANT 1 and 2 of item (2) in Note [Rubbish literals] +-- in GHC.Types.Literal +mkLitRubbish ty + | not (noFreeVarsOfType rep) + = Nothing -- Satisfy INVARIANT 1 + | isEqPred ty + = Nothing -- Satisfy INVARIANT 2 + | otherwise + = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty]) + where + (torc, rep) = expectJust $ sORTKind_maybe (typeKind ty) + +{- +************************************************************************ +* * +\subsection{Making literals} +* * +************************************************************************ +-} + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExpr :: Platform -> Integer -> CoreExpr -- Result = I# i :: Int +mkIntExpr platform i = mkCoreConApps intDataCon [mkIntLit platform i] + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@. Don't check +-- that the number is in the range of the target platform @Int@ +mkUncheckedIntExpr :: Integer -> CoreExpr -- Result = I# i :: Int +mkUncheckedIntExpr i = mkCoreConApps intDataCon [Lit (mkLitIntUnchecked i)] + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExprInt :: Platform -> Int -> CoreExpr -- Result = I# i :: Int +mkIntExprInt platform i = mkCoreConApps intDataCon [mkIntLit platform (fromIntegral i)] + +-- | Create a 'CoreExpr' which will evaluate to a @Word@ with the given value +mkWordExpr :: Platform -> Integer -> CoreExpr +mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w] + +-- | Create a 'CoreExpr' which will evaluate to the given @Integer@ +mkIntegerExpr :: Platform -> Integer -> CoreExpr -- Result :: Integer +mkIntegerExpr platform i + | platformInIntRange platform i = mkCoreConApps integerISDataCon [mkIntLit platform i] + | i < 0 = mkCoreConApps integerINDataCon [Lit (mkLitBigNat (negate i))] + | otherwise = mkCoreConApps integerIPDataCon [Lit (mkLitBigNat i)] + +-- | Create a 'CoreExpr' which will evaluate to the given @Natural@ +mkNaturalExpr :: Platform -> Integer -> CoreExpr +mkNaturalExpr platform w + | platformInWordRange platform w = mkCoreConApps naturalNSDataCon [mkWordLit platform w] + | otherwise = mkCoreConApps naturalNBDataCon [Lit (mkLitBigNat w)] + +-- | Create a 'CoreExpr' which will evaluate to the given @Float@ +mkFloatExpr :: Float -> CoreExpr +mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f] + +-- | Create a 'CoreExpr' which will evaluate to the given @Double@ +mkDoubleExpr :: Double -> CoreExpr +mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d] + + +-- | Create a 'CoreExpr' which will evaluate to the given @Char@ +mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int +mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c] + +-- | Create a 'CoreExpr' which will evaluate to the given @String@ +mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String +mkStringExpr str = mkStringExprFS (mkFastString str) + +-- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@ +mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String +mkStringExprFS = mkStringExprFSLookup lookupId + +mkStringExprFSLookup :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr +mkStringExprFSLookup lookupM str = do + mk <- getMkStringIds lookupM + pure (mkStringExprFSWith mk str) + +getMkStringIds :: Applicative m => (Name -> m Id) -> m MkStringIds +getMkStringIds lookupM = MkStringIds <$> lookupM unpackCStringName <*> lookupM unpackCStringUtf8Name + +data MkStringIds = MkStringIds + { unpackCStringId :: !Id + , unpackCStringUtf8Id :: !Id + } + +mkStringExprFSWith :: MkStringIds -> FastString -> CoreExpr +mkStringExprFSWith ids str + | nullFS str + = mkNilExpr charTy + + | all safeChar chars + = let !unpack_id = unpackCStringId ids + in App (Var unpack_id) lit + + | otherwise + = let !unpack_utf8_id = unpackCStringUtf8Id ids + in App (Var unpack_utf8_id) lit + + where + chars = unpackFS str + safeChar c = ord c >= 1 && ord c <= 0x7F + lit = Lit (LitString (bytesFS str)) + +{- +************************************************************************ +* * + Creating tuples and their types for Core expressions +* * +************************************************************************ +-} + +{- Note [Flattening one-tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This family of functions creates a tuple of variables/expressions/types. + mkCoreTup [e1,e2,e3] = (e1,e2,e3) +What if there is just one variable/expression/type in the argument? +We could do one of two things: + +* Flatten it out, so that + mkCoreTup [e1] = e1 + +* Build a one-tuple (see Note [One-tuples] in GHC.Builtin.Types) + mkCoreTupSolo [e1] = Solo e1 + We use a suffix "Solo" to indicate this. + +Usually we want the former, but occasionally the latter. + +NB: The logic in tupleDataCon knows about () and Solo and (,), etc. + +Note [Don't flatten tuples from HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we get an explicit 1-tuple from HsSyn somehow (likely: Template Haskell), +we should treat it really as a 1-tuple, without flattening. Note that a +1-tuple and a flattened value have different performance and laziness +characteristics, so should just do what we're asked. + +This arose from discussions in #16881. + +One-tuples that arise internally depend on the circumstance; often flattening +is a good idea. Decisions are made on a case-by-case basis. + +'mkCoreBoxedTuple` and `mkBigCoreVarTupSolo` build tuples without flattening. +-} + +-- | Build a small tuple holding the specified expressions +-- One-tuples are *not* flattened; see Note [Flattening one-tuples] +-- See also Note [Don't flatten tuples from HsSyn] +-- Arguments must have kind Type +mkCoreBoxedTuple :: HasDebugCallStack => [CoreExpr] -> CoreExpr +mkCoreBoxedTuple cs + = assertPpr (all (tcIsLiftedTypeKind . typeKind . exprType) cs) (ppr cs) + mkCoreConApps (tupleDataCon Boxed (length cs)) + (map (Type . exprType) cs ++ cs) + + +-- | Build a small unboxed tuple holding the specified expressions. +-- Do not include the RuntimeRep specifiers; this function calculates them +-- for you. +-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] +mkCoreUnboxedTuple :: [CoreExpr] -> CoreExpr +mkCoreUnboxedTuple exps + = mkCoreConApps (tupleDataCon Unboxed (length tys)) + (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) + where + tys = map exprType exps + +-- | Make a core tuple of the given boxity; don't flatten 1-tuples +mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr +mkCoreTupBoxity Boxed exps = mkCoreBoxedTuple exps +mkCoreTupBoxity Unboxed exps = mkCoreUnboxedTuple exps + +-- | Build the type of a small tuple that holds the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreVarTupTy :: [Id] -> Type +mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) + +-- | Build a small tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreTup :: [CoreExpr] -> CoreExpr +mkCoreTup [c] = c +mkCoreTup cs = mkCoreBoxedTuple cs -- non-1-tuples are uniform + +-- | Build an unboxed sum. +-- +-- Alternative number ("alt") starts from 1. +mkCoreUnboxedSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr +mkCoreUnboxedSum arity alt tys exp + = assert (length tys == arity) $ + assert (alt <= arity) $ + mkCoreConApps (sumDataCon alt arity) + (map (Type . getRuntimeRep) tys + ++ map Type tys + ++ [exp]) + +{- Note [Big tuples] +~~~~~~~~~~~~~~~~~~~~ +"Big" tuples (`mkBigCoreTup` and friends) are more general than "small" +ones (`mkCoreTup` and friends) in two ways. + +1. GHCs built-in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but + we might conceivably want to build such a massive tuple as part of the + output of a desugaring stage (notably that for list comprehensions). + + `mkBigCoreTup` encodes such big tuples by creating and pattern + matching on /nested/ small tuples that are directly expressible by + GHC. + + Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) + than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any + construction to be big. + +2. When desugaring arrows we gather up a tuple of free variables, which + may include dictionaries (of kind Constraint) and unboxed values. + + These can't live in a tuple. `mkBigCoreTup` encodes such tuples by + boxing up the offending arguments: see Note [Boxing constructors] + in GHC.Builtin.Types. + +If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkBigTupleSelector' +and 'mkBigTupleCase' functions to do all your work with tuples you should be +fine, and not have to worry about the arity limitation, or kind limitation at +all. + +The "big" tuple operations flatten 1-tuples just like "small" tuples. +But see Note [Don't flatten tuples from HsSyn] +-} + +mkBigCoreVarTupSolo :: [Id] -> CoreExpr +-- Same as mkBigCoreVarTup, but: +-- - one-tuples are not flattened +-- see Note [Flattening one-tuples] +-- - arguments should have kind Type +mkBigCoreVarTupSolo [id] = mkCoreBoxedTuple [Var id] +mkBigCoreVarTupSolo ids = mkChunkified mkCoreTup (map Var ids) + +-- | Build a big tuple holding the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +-- Arguments don't have to have kind Type +mkBigCoreVarTup :: [Id] -> CoreExpr +mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) + +-- | Build a "big" tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +-- Arguments don't have to have kind Type; ones that do not are boxed +-- This function crashes (in wrapBox) if given a non-Type +-- argument that it doesn't know how to box. +mkBigCoreTup :: [CoreExpr] -> CoreExpr +mkBigCoreTup exprs = mkChunkified mkCoreTup (map wrapBox exprs) + +-- | Build the type of a big tuple that holds the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreVarTupTy :: HasDebugCallStack => [Id] -> Type +mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) + +-- | Build the type of a big tuple that holds the specified type of thing +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreTupTy :: HasDebugCallStack => [Type] -> Type +mkBigCoreTupTy tys = mkChunkified mkBoxedTupleTy $ + map boxTy tys + +-- | The unit expression +unitExpr :: CoreExpr +unitExpr = Var unitDataConId + +-------------------------------------------------------------- +wrapBox :: CoreExpr -> CoreExpr +-- ^ If (e :: ty) and (ty :: Type), wrapBox is a no-op +-- But if (ty :: ki), and ki is not Type, wrapBox returns (K @ty e) +-- which has kind Type +-- where K is the boxing data constructor for ki +-- See Note [Boxing constructors] in GHC.Builtin.Types +-- Panics if there /is/ no boxing data con +wrapBox e + = case boxingDataCon e_ty of + BI_NoBoxNeeded -> e + BI_Box { bi_inst_con = boxing_expr } -> App boxing_expr e + BI_NoBoxAvailable -> pprPanic "wrapBox" (ppr e $$ ppr (exprType e)) + -- We should do better than panicing: #22336 + where + e_ty = exprType e + +boxTy :: HasDebugCallStack => Type -> Type +-- ^ `boxTy ty` is the boxed version of `ty`. That is, +-- if `e :: ty`, then `wrapBox e :: boxTy ty`. +-- Note that if `ty :: Type`, `boxTy ty` just returns `ty`. +-- Panics if it is not possible to box `ty`, like `wrapBox` (#22336) +-- See Note [Boxing constructors] in GHC.Builtin.Types +boxTy ty + = case boxingDataCon ty of + BI_NoBoxNeeded -> ty + BI_Box { bi_boxed_type = box_ty } -> box_ty + BI_NoBoxAvailable -> pprPanic "boxTy" (ppr ty) + -- We should do better than panicing: #22336 + +unwrapBox :: UniqSupply -> Id -> CoreExpr + -> (UniqSupply, Id, CoreExpr) +-- If v's type required boxing (i.e it is unlifted or a constraint) +-- then (unwrapBox us v body) returns +-- (case box_v of MkDict v -> body) +-- together with box_v +-- where box_v is a fresh variable +-- Otherwise unwrapBox is a no-op +-- Panics if no box is available (#22336) +unwrapBox us var body + = case boxingDataCon var_ty of + BI_NoBoxNeeded -> (us, var, body) + BI_NoBoxAvailable -> pprPanic "unwrapBox" (ppr var $$ ppr var_ty) + -- We should do better than panicing: #22336 + BI_Box { bi_data_con = box_con, bi_boxed_type = box_ty } + -> (us', var', body') + where + var' = mkSysLocal (fsLit "uc") uniq ManyTy box_ty + body' = Case (Var var') var' (exprType body) + [Alt (DataAlt box_con) [var] body] + where + var_ty = idType var + (uniq, us') = takeUniqFromSupply us + +-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition +mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' + -> [a] -- ^ Possible \"big\" list of things to construct from + -> a -- ^ Constructed thing made possible by recursive decomposition +mkChunkified small_tuple as = mk_big_tuple (chunkify as) + where + -- Each sub-list is short enough to fit in a tuple + mk_big_tuple [as] = small_tuple as + mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) + +chunkify :: [a] -> [[a]] +-- ^ Split a list into lists that are small enough to have a corresponding +-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' +-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists +chunkify xs + | n_xs <= mAX_TUPLE_SIZE = [xs] + | otherwise = split xs + where + n_xs = length xs + split [] = [] + split xs = let (as, bs) = splitAt mAX_TUPLE_SIZE xs + in as : split bs + + +{- +************************************************************************ +* * +\subsection{Tuple destructors} +* * +************************************************************************ +-} + +-- | Builds a selector which scrutinises the given +-- expression and extracts the one name from the list given. +-- If you want the no-shadowing rule to apply, the caller +-- is responsible for making sure that none of these names +-- are in scope. +-- +-- If there is just one 'Id' in the tuple, then the selector is +-- just the identity. +-- +-- If necessary, we pattern match on a \"big\" tuple. +-- +-- A tuple selector is not linear in its argument. Consequently, the case +-- expression built by `mkBigTupleSelector` must consume its scrutinee 'Many' +-- times. And all the argument variables must have multiplicity 'Many'. +mkBigTupleSelector, mkBigTupleSelectorSolo + :: [Id] -- ^ The 'Id's to pattern match the tuple against + -> Id -- ^ The 'Id' to select + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr -- ^ Selector expression + +-- mkBigTupleSelector [a,b,c,d] b v e +-- = case e of v { +-- (p,q) -> case p of p { +-- (a,b) -> b }} +-- We use 'tpl' vars for the p,q, since shadowing does not matter. +-- +-- In fact, it's more convenient to generate it innermost first, getting +-- +-- case (case e of v +-- (p,q) -> p) of p +-- (a,b) -> b +mkBigTupleSelector vars the_var scrut_var scrut + = mk_tup_sel (chunkify vars) the_var + where + mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut + mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $ + mk_tup_sel (chunkify tpl_vs) tpl_v + where + tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] + tpl_vs = mkTemplateLocals tpl_tys + (tpl_v, group) = case + [ (tpl,gp) + | (tpl,gp) <- zipEqual tpl_vs vars_s + , the_var `elem` gp + ] of + [x] -> x + _ -> panic "mkBigTupleSelector" +-- ^ 'mkBigTupleSelectorSolo' is like 'mkBigTupleSelector' +-- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) +mkBigTupleSelectorSolo vars the_var scrut_var scrut + | [_] <- vars + = mkSmallTupleSelector1 vars the_var scrut_var scrut + | otherwise + = mkBigTupleSelector vars the_var scrut_var scrut + +-- | `mkSmallTupleSelector` is like 'mkBigTupleSelector', but for tuples that +-- are guaranteed never to be "big". Also does not unwrap boxed types. +-- +-- > mkSmallTupleSelector [x] x v e = [| e |] +-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |] +mkSmallTupleSelector, mkSmallTupleSelector1 + :: [Id] -- The tuple args + -> Id -- The selected one + -> Id -- A variable of the same type as the scrutinee + -> CoreExpr -- Scrutinee + -> CoreExpr +mkSmallTupleSelector [var] should_be_the_same_var _ scrut + = assert (var == should_be_the_same_var) $ + scrut -- Special case for 1-tuples +mkSmallTupleSelector vars the_var scrut_var scrut + = mkSmallTupleSelector1 vars the_var scrut_var scrut + +-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector' +-- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) +mkSmallTupleSelector1 vars the_var scrut_var scrut + = assert (notNull vars) $ + Case scrut scrut_var (idType the_var) + [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)] + +-- | A generalization of 'mkBigTupleSelector', allowing the body +-- of the case to be an arbitrary expression. +-- +-- To avoid shadowing, we use uniques to invent new variables. +-- +-- If necessary we pattern match on a "big" tuple. +mkBigTupleCase :: MonadUnique m -- For inventing names of intermediate variables + => [Id] -- ^ The tuple identifiers to pattern match on; + -- Bring these into scope in the body + -> CoreExpr -- ^ Body of the case + -> CoreExpr -- ^ Scrutinee + -> m CoreExpr +-- ToDo: eliminate cases where none of the variables are needed. +-- +-- mkBigTupleCase uniqs [a,b,c,d] body v e +-- = case e of v { (p,q) -> +-- case p of p { (a,b) -> +-- case q of q { (c,d) -> +-- body }}} +mkBigTupleCase vars body scrut + = do us <- getUniqueSupplyM + let (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars + return $ mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body + where + scrut_ty = exprType scrut + + unwrap var (us,vars,body) + = (us', var':vars, body') + where + (us', var', body') = unwrapBox us var body + + mk_tuple_case :: UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr + -- mk_tuple_case [[a1..an], [b1..bm], ...] body + -- case scrut of (p,q, ...) -> + -- case p of (a1,..an) -> + -- case q of (b1,..bm) -> + -- ... -> body + -- This is the case where don't need any nesting + mk_tuple_case us [vars] body + = mkSmallTupleCase vars body scrut_var scrut + where + scrut_var = case scrut of + Var v -> v + _ -> snd (new_var us scrut_ty) + + -- This is the case where we must nest tuples at least once + mk_tuple_case us vars_s body + = mk_tuple_case us' (chunkify vars') body' + where + (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s + + one_tuple_case chunk_vars (us, vs, body) + = (us', scrut_var:vs, body') + where + tup_ty = mkBoxedTupleTy (map idType chunk_vars) + (us', scrut_var) = new_var us tup_ty + body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) + + new_var :: UniqSupply -> Type -> (UniqSupply, Id) + new_var us ty = (us', id) + where + (uniq, us') = takeUniqFromSupply us + id = mkSysLocal (fsLit "ds") uniq ManyTy ty + +-- | As 'mkBigTupleCase', but for a tuple that is small enough to be guaranteed +-- not to need nesting. +mkSmallTupleCase + :: [Id] -- ^ The tuple args + -> CoreExpr -- ^ Body of the case + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr + +mkSmallTupleCase [var] body _scrut_var scrut + = bindNonRec var scrut body +mkSmallTupleCase vars body scrut_var scrut + = Case scrut scrut_var (exprType body) + [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body] + +{- +************************************************************************ +* * + Floats +* * +************************************************************************ +-} + +data FloatBind + = FloatLet CoreBind + | FloatCase CoreExpr Id AltCon [Var] + -- case e of y { C ys -> ... } + -- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels + +instance Outputable FloatBind where + ppr (FloatLet b) = text "LET" <+> ppr b + ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> text "of" <+> ppr b) + 2 (ppr c <+> ppr bs) + +wrapFloat :: FloatBind -> CoreExpr -> CoreExpr +wrapFloat (FloatLet defns) body = Let defns body +wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body + +-- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] +-- u = let b1 in let b2 in … in let bn in u@ +wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr +wrapFloats floats expr = foldr wrapFloat expr floats + +bindBindings :: CoreBind -> [Var] +bindBindings (NonRec b _) = [b] +bindBindings (Rec bnds) = map fst bnds + +floatBindings :: FloatBind -> [Var] +floatBindings (FloatLet bnd) = bindBindings bnd +floatBindings (FloatCase _ b _ bs) = b:bs + +{- +************************************************************************ +* * +\subsection{Common list manipulation expressions} +* * +************************************************************************ + +Call the constructor Ids when building explicit lists, so that they +interact well with rules. +-} + +-- | Makes a list @[]@ for lists of the specified type +mkNilExpr :: Type -> CoreExpr +mkNilExpr ty = mkCoreConApps nilDataCon [Type ty] + +-- | Makes a list @(:)@ for lists of the specified type +mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr +mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl] + +-- | Make a list containing the given expressions, where the list has the given type +mkListExpr :: Type -> [CoreExpr] -> CoreExpr +mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs + +-- | Make a fully applied 'foldr' expression +mkFoldrExpr :: MonadThings m + => Type -- ^ Element type of the list + -> Type -- ^ Fold result type + -> CoreExpr -- ^ "Cons" function expression for the fold + -> CoreExpr -- ^ "Nil" expression for the fold + -> CoreExpr -- ^ List expression being folded acress + -> m CoreExpr +mkFoldrExpr elt_ty result_ty c n list = do + foldr_id <- lookupId foldrName + return (Var foldr_id `App` Type elt_ty + `App` Type result_ty + `App` c + `App` n + `App` list) + +-- | Make a 'build' expression applied to a locally-bound worker function +mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m) + => Type -- ^ Type of list elements to be built + -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's + -- of the binders for the build worker function, returns + -- the body of that worker + -> m CoreExpr +mkBuildExpr elt_ty mk_build_inside = do + n_tyvar <- newTyVar alphaTyVar + let n_ty = mkTyVarTy n_tyvar + c_ty = mkVisFunTysMany [elt_ty, n_ty] n_ty + [c, n] <- sequence [mkSysLocalM (fsLit "c") ManyTy c_ty, mkSysLocalM (fsLit "n") ManyTy n_ty] + + build_inside <- mk_build_inside (c, c_ty) (n, n_ty) + + build_id <- lookupId buildName + return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside + where + newTyVar tyvar_tmpl = do + uniq <- getUniqueM + return (setTyVarUnique tyvar_tmpl uniq) + +{- +************************************************************************ +* * + Manipulating Maybe data type +* * +************************************************************************ +-} + + +-- | Makes a Nothing for the specified type +mkNothingExpr :: Type -> CoreExpr +mkNothingExpr ty = mkConApp nothingDataCon [Type ty] + +-- | Makes a Just from a value of the specified type +mkJustExpr :: Type -> CoreExpr -> CoreExpr +mkJustExpr ty val = mkConApp justDataCon [Type ty, val] + + +{- +************************************************************************ +* * + Error expressions +* * +************************************************************************ +-} + +mkRuntimeErrorApp + :: Id -- Should be of type + -- forall (r::RuntimeRep) (a::TYPE r). Addr# -> a + -- or (a :: CONSTRAINT r) + -- where Addr# points to a UTF8 encoded string + -> Type -- The type to instantiate 'a' + -> String -- The string to print + -> CoreExpr + +mkRuntimeErrorApp err_id res_ty err_msg + = mkApps (Var err_id) [ Type (getRuntimeRep res_ty) + , Type res_ty, err_string ] + where + err_string = Lit (mkLitString err_msg) + +{- +************************************************************************ +* * + Error Ids +* * +************************************************************************ + +GHC randomly injects these into the code. + +@patError@ is just a version of @error@ for pattern-matching +failures. It knows various ``codes'' which expand to longer +strings---this saves space! + +@absentErr@ is a thing we put in for ``absent'' arguments. They jolly +well shouldn't be yanked on, but if one is, then you will get a +friendly message from @absentErr@ (rather than a totally random +crash). +-} + +errorIds :: [Id] +errorIds + = [ nON_EXHAUSTIVE_GUARDS_ERROR_ID, + nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, + rEC_CON_ERROR_ID, + rEC_SEL_ERROR_ID, + iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID, + aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID, + aBSENT_SUM_FIELD_ERROR_ID, + tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284 + ] + +recSelErrorName, recConErrorName, patErrorName :: Name +nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name +typeErrorName :: Name +absentSumFieldErrorName :: Name + +recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID +recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID +typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID + +noMethodBindingErrorName = err_nm "noMethodBindingError" + noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID +nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError" + nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID + +err_nm :: String -> Unique -> Id -> Name +err_nm str uniq id = mkWiredInIdName gHC_INTERNAL_CONTROL_EXCEPTION_BASE (fsLit str) uniq id + +rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID :: Id +pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id +tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id +rEC_SEL_ERROR_ID = mkRuntimeErrorId TypeLike recSelErrorName +rEC_CON_ERROR_ID = mkRuntimeErrorId TypeLike recConErrorName +pAT_ERROR_ID = mkRuntimeErrorId TypeLike patErrorName +nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId TypeLike noMethodBindingErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId TypeLike nonExhaustiveGuardsErrorName +tYPE_ERROR_ID = mkRuntimeErrorId TypeLike typeErrorName + +-- Note [aBSENT_SUM_FIELD_ERROR_ID] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Unboxed sums are transformed into unboxed tuples in GHC.Stg.Unarise.mkUbxSum +-- and fields that can't be reached are filled with rubbish values. +-- For instance, consider the case of the program: +-- +-- f :: (# Int | Float# #) -> Int +-- f = ... +-- +-- x = f (# | 2.0## #) +-- +-- Unarise will represent f's unboxed sum argument as a tuple (# Int#, Int, +-- Float# #), where Int# is a tag. Consequently, `x` will be rewritten to: +-- +-- x = f (# 2#, ???, 2.0## #) +-- +-- We must come up with some rubbish literal to use in place of `???`. In the +-- case of unboxed integer types this is easy: we can simply use 0 for +-- Int#/Word# and 0.0 Float#/Double#. +-- +-- However, coming up with a rubbish pointer value is more delicate as the +-- value must satisfy the following requirements: +-- +-- 1. it needs to be a valid closure pointer for the GC (not a NULL pointer) +-- +-- 2. it can't take arguments because it's used in unarise and applying an +-- argument would require allocating a thunk, which is both difficult to +-- do and costly. +-- +-- 3. it shouldn't be CAFfy since this would make otherwise non-CAFfy +-- bindings CAFfy, incurring a cost in GC performance. Given that unboxed +-- sums are intended to be used in performance-critical code, this is to +-- We work-around this by declaring the absentSumFieldError as non-CAFfy, +-- as described in Note [Wired-in exceptions are not CAFfy]. +-- +-- Getting this wrong causes hard-to-debug runtime issues, see #15038. +-- +-- 4. it can't be defined in `base` package. Afterall, not all code which +-- uses unboxed sums uses depends upon `base`. Specifically, this became +-- an issue when we wanted to use unboxed sums in boot libraries used by +-- `base`, see #17791. +-- +-- To fill this role we define `ghc-prim:GHC.Prim.Panic.absentSumFieldError` +-- with the type: +-- +-- absentSumFieldError :: forall a. a +-- +-- Note that this type is something of a lie since Unarise may use it at an +-- unlifted type. However, this lie is benign as absent sum fields are examined +-- only by the GC, which does not care about levity.. +-- +-- When entered, this closure calls `stg_panic#`, which immediately halts +-- execution and cannot be caught. This is in contrast to most other runtime +-- errors, which are thrown as proper Haskell exceptions. This design is +-- intentional since entering an absent sum field is an indication that +-- something has gone horribly wrong, very likely due to a compiler bug. +-- + +-- Note [Wired-in exceptions are not CAFfy] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- GHC has logic wiring-in a small number of exceptions, which may be thrown in +-- generated code. Specifically, these are implemented via closures (defined +-- in `GHC.Prim.Exception` in `ghc-prim`) which, when entered, raise the desired +-- exception. For instance, in the case of OverflowError we have +-- +-- raiseOverflow :: forall a. a +-- raiseOverflow = runRW# (\s -> +-- case raiseOverflow# s of +-- (# _, _ #) -> let x = x in x) +-- +-- where `raiseOverflow#` is defined in the rts/Exception.cmm. +-- +-- Note that `raiseOverflow` and friends, being top-level thunks, are CAFs. +-- Normally, this would be reflected in their IdInfo; however, as these +-- functions are widely used and CAFfyness is transitive, we very much want to +-- avoid declaring them as CAFfy. This is especially true in especially in +-- performance-critical code like that using unboxed sums and +-- absentSumFieldError. +-- +-- Consequently, `mkExceptionId` instead declares the exceptions to be +-- non-CAFfy and rather ensure in the RTS (in `initBuiltinGcRoots` in +-- rts/RtsStartup.c) that these closures remain reachable by creating a +-- StablePtr to each. Note that we are using the StablePtr mechanism not +-- because we need a StablePtr# object, but rather because the stable pointer +-- table is a source of GC roots. +-- +-- At some point we could consider removing this optimisation as it is quite +-- fragile, but we do want to be careful to avoid adding undue cost. Unboxed +-- sums in particular are intended to be used in performance-critical contexts. +-- +-- See #15038, #21141. + +absentSumFieldErrorName + = mkWiredInIdName + gHC_PRIM_PANIC + (fsLit "absentSumFieldError") + absentSumFieldErrorIdKey + aBSENT_SUM_FIELD_ERROR_ID + +aBSENT_SUM_FIELD_ERROR_ID = mkExceptionId absentSumFieldErrorName + +-- | Exception with type \"forall a. a\" +-- +-- Any exceptions added via this function needs to be added to +-- the RTS's initBuiltinGcRoots() function. +mkExceptionId :: Name -> Id +mkExceptionId name + = mkVanillaGlobalWithInfo name + (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a + (divergingIdInfo [] `setCafInfo` NoCafRefs) + -- See Note [Wired-in exceptions are not CAFfy] + +-- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID', that +-- throws an (imprecise) exception after being supplied one value arg for every +-- argument 'Demand' in the list. The demands end up in the demand signature. +-- +-- 1. Sets the demand signature to unleash the given arg dmds 'botDiv' +-- 2. Sets the arity info so that it matches the length of arg demands +-- 3. Sets a bottoming CPR sig with the correct arity +-- +-- It's important that all 3 agree on the arity, which is what this defn ensures. +divergingIdInfo :: [Demand] -> IdInfo +divergingIdInfo arg_dmds + = vanillaIdInfo `setArityInfo` arity + `setDmdSigInfo` mkClosedDmdSig arg_dmds botDiv + `setCprSigInfo` mkCprSig arity botCpr + where + arity = length arg_dmds + +{- Note [Error and friends have an "open-tyvar" forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'error' and 'undefined' have types + error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a + undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a +Notice the runtime-representation polymorphism. This ensures that +"error" can be instantiated at unboxed as well as boxed types. +This is OK because it never returns, so the return type is irrelevant. + + +************************************************************************ +* * + iMPOSSIBLE_ERROR_ID +* * +************************************************************************ +-} + +iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID :: Id +iMPOSSIBLE_ERROR_ID = mkRuntimeErrorId TypeLike impossibleErrorName +iMPOSSIBLE_CONSTRAINT_ERROR_ID = mkRuntimeErrorId ConstraintLike impossibleConstraintErrorName + +impossibleErrorName, impossibleConstraintErrorName :: Name +impossibleErrorName = err_nm "impossibleError" + impossibleErrorIdKey iMPOSSIBLE_ERROR_ID +impossibleConstraintErrorName = err_nm "impossibleConstraintError" + impossibleConstraintErrorIdKey iMPOSSIBLE_CONSTRAINT_ERROR_ID + +mkImpossibleExpr :: Type -> String -> CoreExpr +mkImpossibleExpr res_ty str + = mkRuntimeErrorApp err_id res_ty str + where -- See Note [Type vs Constraint for error ids] + err_id = case typeTypeOrConstraint res_ty of + TypeLike -> iMPOSSIBLE_ERROR_ID + ConstraintLike -> iMPOSSIBLE_CONSTRAINT_ERROR_ID + +{- Note [Type vs Constraint for error ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need both + iMPOSSIBLE_ERROR_ID :: forall (r::RuntimeRep) (a::TYPE r). Addr# -> a + iMPOSSIBLE_CONSTRAINT_ERROR_ID :: forall (r::RuntimeRep) (a::CONSTRAINT r). Addr# -> a + +because we don't have polymorphism over TYPE vs CONSTRAINT. You +might wonder if iMPOSSIBLE_CONSTRAINT_ERROR_ID is ever needed in +practice, but it is: see #22634. So: + +* In Control.Exception.Base we have + impossibleError :: forall (a::Type). Addr# -> a + impossibleConstraintError :: forall (a::Type). Addr# -> a + This generates the code for `impossibleError`, but because they are wired in + the interface file definitions are never looked at (indeed, they don't + even get serialised). + +* In this module GHC.Core.Make we define /wired-in/ Ids for + iMPOSSIBLE_ERROR_ID + iMPOSSIBLE_CONSTRAINT_ERROR_ID + with the desired above types (i.e. runtime-rep polymorphic, and returning a + constraint for the latter. + +Much the same plan works for aBSENT_ERROR_ID and aBSENT_CONSTRAINT_ERROR_ID + + +************************************************************************ +* * + aBSENT_ERROR_ID +* * +************************************************************************ + +Note [aBSENT_ERROR_ID] +~~~~~~~~~~~~~~~~~~~~~~ +We use aBSENT_ERROR_ID to build absent fillers for lifted types in workers. E.g. + + f x = (case x of (a,b) -> b) + 1::Int + +The demand analyser figures out that only the second component of x is +used, and does a w/w split thus + + f x = case x of (a,b) -> $wf b + + $wf b = let a = absentError "blah" + x = (a,b) + in + +After some simplification, the (absentError "blah") thunk normally goes away. +See also Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils. + +Historical Note +--------------- +We used to have exprIsHNF respond True to absentError and *not* mark it as diverging. +Here's the reason for the former. It doesn't apply anymore because we no longer say +that `a` is absent (A). Instead it gets (head strict) demand 1A and we won't +emit the absent error: + +#14285 had, roughly + + data T a = MkT a !a + {-# INLINABLE f #-} + f x = case x of MkT a b -> g (MkT b a) + +It turned out that g didn't use the second component, and hence f doesn't use +the first. But the stable-unfolding for f looks like + \x. case x of MkT a b -> g ($WMkT b a) +where $WMkT is the wrapper for MkT that evaluates its arguments. We +apply the same w/w split to this unfolding (see Note [Worker/wrapper +for INLINABLE functions] in GHC.Core.Opt.WorkWrap) so the template ends up like + \b. let a = absentError "blah" + x = MkT a b + in case x of MkT a b -> g ($WMkT b a) + +After doing case-of-known-constructor, and expanding $WMkT we get + \b -> g (case absentError "blah" of a -> MkT b a) + +Yikes! That bogusly appears to evaluate the absentError! + +This is extremely tiresome. Another way to think of this is that, in +Core, it is an invariant that a strict data constructor, like MkT, must +be applied only to an argument in HNF. So (absentError "blah") had +better be non-bottom. + +So the "solution" is to add a special case for absentError to exprIsHNFlike. +This allows Simplify.rebuildCase, in the Note [Case to let transformation] +branch, to convert the case on absentError into a let. We also make +absentError *not* be diverging, unlike the other error-ids, so that we +can be sure not to remove the case branches before converting the case to +a let. + +If, by some bug or bizarre happenstance, we ever call absentError, we should +throw an exception. This should never happen, of course, but we definitely +can't return anything. e.g. if somehow we had + case absentError "foo" of + Nothing -> ... + Just x -> ... +then if we return, the case expression will select a field and continue. +Seg fault city. Better to throw an exception. (Even though we've said +it is in HNF :-) + +It might seem a bit surprising that seq on absentError is simply erased + + absentError "foo" `seq` x ==> x + +but that should be okay; since there's no pattern match we can't really +be relying on anything from it. +-} + +-- We need two absentError Ids: +-- absentError :: forall (a :: Type). Addr# -> a +-- absentConstraintError :: forall (a :: Constraint). Addr# -> a +-- We don't have polymorphism over TypeOrConstraint! +-- mkAbsentErrorApp chooses which one to use, based on the kind +-- See Note [Type vs Constraint for error ids] + +mkAbsentErrorApp :: Type -- The type to instantiate 'a' + -> String -- The string to print + -> CoreExpr + +mkAbsentErrorApp res_ty err_msg + = mkApps (Var err_id) [ Type res_ty, err_string ] + where + err_id = case typeTypeOrConstraint res_ty of + TypeLike -> aBSENT_ERROR_ID + ConstraintLike -> aBSENT_CONSTRAINT_ERROR_ID + err_string = Lit (mkLitString err_msg) + +absentErrorName, absentConstraintErrorName :: Name +absentErrorName + = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentError") + absentErrorIdKey aBSENT_ERROR_ID + +absentConstraintErrorName -- See Note [Type vs Constraint for error ids] + = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentConstraintError") + absentConstraintErrorIdKey aBSENT_CONSTRAINT_ERROR_ID + +aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID :: Id + +aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID] + = mk_runtime_error_id absentErrorName absent_ty + where + -- absentError :: forall (a :: Type). Addr# -> a + absent_ty = mkSpecForAllTys [alphaTyVar] $ + mkVisFunTyMany addrPrimTy (mkTyVarTy alphaTyVar) + -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for + -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils + +aBSENT_CONSTRAINT_ERROR_ID -- See Note [aBSENT_ERROR_ID] + = mk_runtime_error_id absentConstraintErrorName absent_ty + -- See Note [Type vs Constraint for error ids] + where + -- absentConstraintError :: forall (a :: Constraint). Addr# -> a + absent_ty = mkSpecForAllTys [alphaConstraintTyVar] $ + mkFunTy visArgConstraintLike ManyTy + addrPrimTy (mkTyVarTy alphaConstraintTyVar) + + +{- +************************************************************************ +* * + mkRuntimeErrorId +* * +************************************************************************ +-} + +mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id +-- Error function +-- with type: forall (r::RuntimeRep) (a::TYPE r). Addr# -> a +-- with arity: 1 +-- which diverges after being given one argument +-- The Addr# is expected to be the address of +-- a UTF8-encoded error string +mkRuntimeErrorId torc name = mk_runtime_error_id name (mkRuntimeErrorTy torc) + + +mk_runtime_error_id :: Name -> Type -> Id +mk_runtime_error_id name ty + = mkVanillaGlobalWithInfo name ty (divergingIdInfo [evalDmd]) + -- Do *not* mark them as NoCafRefs, because they can indeed have + -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, + -- which has some CAFs + -- In due course we may arrange that these error-y things are + -- regarded by the GC as permanently live, in which case we + -- can give them NoCaf info. As it is, any function that calls + -- any pc_bottoming_Id will itself have CafRefs, which bloats + -- SRTs. + +mkRuntimeErrorTy :: TypeOrConstraint -> Type +-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a +-- See Note [Error and friends have an "open-tyvar" forall] +mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $ + mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar) + where + tyvar:|_ = expectNonEmpty $ mkTemplateTyVars [kind] + kind = case torc of + TypeLike -> mkTYPEapp runtimeRep1Ty + ConstraintLike -> mkCONSTRAINTapp runtimeRep1Ty + diff --git a/GHC/Core/Map/Expr.hs b/GHC/Core/Map/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Map/Expr.hs @@ -0,0 +1,470 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# OPTIONS_GHC -Wno-orphans #-} + -- Eq (DeBruijn CoreExpr) and Eq (DeBruijn CoreAlt) + +module GHC.Core.Map.Expr ( + -- * Maps over Core expressions + CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, + -- * Alpha equality + eqDeBruijnExpr, eqCoreExpr, + -- * 'TrieMap' class reexports + TrieMap(..), insertTM, deleteTM, + lkDFreeVar, xtDFreeVar, + lkDNamed, xtDNamed, + (>.>), (|>), (|>>), + ) where + +import GHC.Prelude + +import GHC.Data.TrieMap +import GHC.Core.Map.Type +import GHC.Core +import GHC.Core.Type +import GHC.Types.Tickish +import GHC.Types.Var + +import GHC.Utils.Misc +import GHC.Utils.Outputable + +import qualified Data.Map as Map +import GHC.Types.Name.Env +import Control.Monad( (>=>) ) +import GHC.Types.Literal (Literal) + +{- +This module implements TrieMaps over Core related data structures +like CoreExpr or Type. It is built on the Tries from the TrieMap +module. + +The code is very regular and boilerplate-like, but there is +some neat handling of *binders*. In effect they are deBruijn +numbered on the fly. + + +-} + +---------------------- +-- Recall that +-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c + +-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not +-- known when defining GenMap so we can only specialize them here. + +{-# SPECIALIZE lkG :: Key CoreMapX -> CoreMapG a -> Maybe a #-} +{-# SPECIALIZE xtG :: Key CoreMapX -> XT a -> CoreMapG a -> CoreMapG a #-} +{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a -> CoreMapG b #-} +{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a -> b -> b #-} + + +{- +************************************************************************ +* * + CoreMap +* * +************************************************************************ +-} + +{- +Note [Binders] +~~~~~~~~~~~~~~ + * In general we check binders as late as possible because types are + less likely to differ than expression structure. That's why + cm_lam :: CoreMapG (TypeMapG a) + rather than + cm_lam :: TypeMapG (CoreMapG a) + + * We don't need to look at the type of some binders, notably + - the case binder in (Case _ b _ _) + - the binders in an alternative + because they are totally fixed by the context + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* For a key (Case e b ty (alt:alts)) we don't need to look the return type + 'ty', because every alternative has that type. + +* For a key (Case e b ty []) we MUST look at the return type 'ty', because + otherwise (Case (error () "urk") _ Int []) would compare equal to + (Case (error () "urk") _ Bool []) + which is utterly wrong (#6097) + +We could compare the return type regardless, but the wildly common case +is that it's unnecessary, so we have two fields (cm_case and cm_ecase) +for the two possibilities. Only cm_ecase looks at the type. + +See also Note [Empty case alternatives] in GHC.Core. +-} + +-- | @CoreMap a@ is a map from 'CoreExpr' to @a@. If you are a client, this +-- is the type you want. +newtype CoreMap a = CoreMap (CoreMapG a) + +-- TODO(22292): derive +instance Functor CoreMap where + fmap f = \ (CoreMap m) -> CoreMap (fmap f m) + {-# INLINE fmap #-} + +instance TrieMap CoreMap where + type Key CoreMap = CoreExpr + emptyTM = CoreMap emptyTM + lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m + alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) + foldTM k (CoreMap m) = foldTM k m + filterTM f (CoreMap m) = CoreMap (filterTM f m) + mapMaybeTM f (CoreMap m) = CoreMap (mapMaybeTM f m) + +-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended +-- key makes it suitable for recursive traversal, since it can track binders, +-- but it is strictly internal to this module. If you are including a 'CoreMap' +-- inside another 'TrieMap', this is the type you want. +type CoreMapG = GenMap CoreMapX + +type LiteralMap a = Map.Map Literal a + +-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without +-- the 'GenMap' optimization. +data CoreMapX a + = CM { cm_var :: VarMap a + , cm_lit :: LiteralMap a + , cm_co :: CoercionMapG a + , cm_type :: TypeMapG a + , cm_cast :: CoreMapG (CoercionMapG a) + , cm_tick :: CoreMapG (TickishMap a) + , cm_app :: CoreMapG (CoreMapG a) + , cm_lam :: CoreMapG (BndrMap a) -- Note [Binders] + , cm_letn :: CoreMapG (CoreMapG (BndrMap a)) + , cm_letr :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a)) + , cm_case :: CoreMapG (ListMap AltMap a) + , cm_ecase :: CoreMapG (TypeMapG a) -- Note [Empty case alternatives] + } + +instance Eq (DeBruijn CoreExpr) where + (==) = eqDeBruijnExpr + +eqDeBruijnExpr :: DeBruijn CoreExpr -> DeBruijn CoreExpr -> Bool +eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where + go (Var v1) (Var v2) = eqDeBruijnVar (D env1 v1) (D env2 v2) + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = eqDeBruijnType (D env1 t1) (D env2 t2) + -- See Note [Alpha-equality for Coercion arguments] + go (Coercion {}) (Coercion {}) = True + go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2 + go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2 + go (Tick n1 e1) (Tick n2 e2) + = eqDeBruijnTickish (D env1 n1) (D env2 n2) + && go e1 e2 + + go (Lam b1 e1) (Lam b2 e2) + = eqDeBruijnType (D env1 (varType b1)) (D env2 (varType b2)) + && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2) + && eqDeBruijnExpr (D (extendCME env1 b1) e1) (D (extendCME env2 b2) e2) + + go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) + = go r1 r2 -- See Note [Alpha-equality for let-bindings] + && eqDeBruijnExpr (D (extendCME env1 v1) e1) (D (extendCME env2 v2) e2) + + go (Let (Rec ps1) e1) (Let (Rec ps2) e2) + = equalLength ps1 ps2 + -- See Note [Alpha-equality for let-bindings] + && all2 (\b1 b2 -> eqDeBruijnType (D env1 (varType b1)) + (D env2 (varType b2))) + bs1 bs2 + && D env1' rs1 == D env2' rs2 + && eqDeBruijnExpr (D env1' e1) (D env2' e2) + where + (bs1,rs1) = unzip ps1 + (bs2,rs2) = unzip ps2 + env1' = extendCMEs env1 bs1 + env2' = extendCMEs env2 bs2 + + go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | null a1 -- See Note [Empty case alternatives] + = null a2 && go e1 e2 && D env1 t1 == D env2 t2 + | otherwise + = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2 + + go _ _ = False + +eqDeBruijnTickish :: DeBruijn CoreTickish -> DeBruijn CoreTickish -> Bool +eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where + go (Breakpoint lext lid lids) (Breakpoint rext rid rids) + = lid == rid + && D env1 lids == D env2 rids + && lext == rext + go l r = l == r + +-- Compares for equality, modulo alpha +eqCoreExpr :: CoreExpr -> CoreExpr -> Bool +eqCoreExpr e1 e2 = eqDeBruijnExpr (deBruijnize e1) (deBruijnize e2) + +{- Note [Alpha-equality for Coercion arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'Coercion' constructor only appears in argument positions, and so, if the +functions are equal, then the arguments must have equal types. Because the +comparison for coercions (correctly) checks only their types, checking for +alpha-equality of the coercions is redundant. +-} + +{- Note [Alpha-equality for let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For /recursive/ let-bindings we need to check that the types of the binders +are alpha-equivalent. Otherwise + + letrec (x : Bool) = x in x + +and + + letrec (y : Char) = y in y + +would be considered alpha-equivalent, which they are obviously not. + +For /non-recursive/ let-bindings, we do not have to check that the types of +the binders are alpha-equivalent. When the RHSs (the expressions) of the +non-recursive let-binders are well-formed and well-typed (which we assume they +are at this point in the compiler), and the RHSs are alpha-equivalent, then the +bindings must have the same type. + +In addition, it is also worth pointing out that + + letrec { x = e1; y = e2 } in b + +is NOT considered equal to + + letrec { y = e2; x = e1 } in b +-} + +emptyE :: CoreMapX a +emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM + , cm_co = emptyTM, cm_type = emptyTM + , cm_cast = emptyTM, cm_app = emptyTM + , cm_lam = emptyTM, cm_letn = emptyTM + , cm_letr = emptyTM, cm_case = emptyTM + , cm_ecase = emptyTM, cm_tick = emptyTM } + +-- TODO(22292): derive +instance Functor CoreMapX where + fmap f CM + { cm_var = cvar, cm_lit = clit, cm_co = cco, cm_type = ctype, cm_cast = ccast + , cm_app = capp, cm_lam = clam, cm_letn = cletn, cm_letr = cletr, cm_case = ccase + , cm_ecase = cecase, cm_tick = ctick } = CM + { cm_var = fmap f cvar, cm_lit = fmap f clit, cm_co = fmap f cco, cm_type = fmap f ctype + , cm_cast = fmap (fmap f) ccast, cm_app = fmap (fmap f) capp, cm_lam = fmap (fmap f) clam + , cm_letn = fmap (fmap (fmap f)) cletn, cm_letr = fmap (fmap (fmap f)) cletr + , cm_case = fmap (fmap f) ccase, cm_ecase = fmap (fmap f) cecase + , cm_tick = fmap (fmap f) ctick } + +instance TrieMap CoreMapX where + type Key CoreMapX = DeBruijn CoreExpr + emptyTM = emptyE + lookupTM = lkE + alterTM = xtE + foldTM = fdE + filterTM = ftE + mapMaybeTM = mpE + +-------------------------- +ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a +ftE f (CM { cm_var = cvar, cm_lit = clit + , cm_co = cco, cm_type = ctype + , cm_cast = ccast , cm_app = capp + , cm_lam = clam, cm_letn = cletn + , cm_letr = cletr, cm_case = ccase + , cm_ecase = cecase, cm_tick = ctick }) + = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit + , cm_co = filterTM f cco, cm_type = filterTM f ctype + , cm_cast = fmap (filterTM f) ccast, cm_app = fmap (filterTM f) capp + , cm_lam = fmap (filterTM f) clam, cm_letn = fmap (fmap (filterTM f)) cletn + , cm_letr = fmap (fmap (filterTM f)) cletr, cm_case = fmap (filterTM f) ccase + , cm_ecase = fmap (filterTM f) cecase, cm_tick = fmap (filterTM f) ctick } + +mpE :: (a -> Maybe b) -> CoreMapX a -> CoreMapX b +mpE f (CM { cm_var = cvar, cm_lit = clit + , cm_co = cco, cm_type = ctype + , cm_cast = ccast , cm_app = capp + , cm_lam = clam, cm_letn = cletn + , cm_letr = cletr, cm_case = ccase + , cm_ecase = cecase, cm_tick = ctick }) + = CM { cm_var = mapMaybeTM f cvar, cm_lit = mapMaybeTM f clit + , cm_co = mapMaybeTM f cco, cm_type = mapMaybeTM f ctype + , cm_cast = fmap (mapMaybeTM f) ccast, cm_app = fmap (mapMaybeTM f) capp + , cm_lam = fmap (mapMaybeTM f) clam, cm_letn = fmap (fmap (mapMaybeTM f)) cletn + , cm_letr = fmap (fmap (mapMaybeTM f)) cletr, cm_case = fmap (mapMaybeTM f) ccase + , cm_ecase = fmap (mapMaybeTM f) cecase, cm_tick = fmap (mapMaybeTM f) ctick } + +-------------------------- +lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a +lookupCoreMap cm e = lookupTM e cm + +extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a +extendCoreMap m e v = alterTM e (\_ -> Just v) m + +foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b +foldCoreMap k z m = foldTM k m z + +emptyCoreMap :: CoreMap a +emptyCoreMap = emptyTM + +instance Outputable a => Outputable (CoreMap a) where + ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m []) + +------------------------- +fdE :: (a -> b -> b) -> CoreMapX a -> b -> b +fdE k m + = foldTM k (cm_var m) + . foldTM k (cm_lit m) + . foldTM k (cm_co m) + . foldTM k (cm_type m) + . foldTM (foldTM k) (cm_cast m) + . foldTM (foldTM k) (cm_tick m) + . foldTM (foldTM k) (cm_app m) + . foldTM (foldTM k) (cm_lam m) + . foldTM (foldTM (foldTM k)) (cm_letn m) + . foldTM (foldTM (foldTM k)) (cm_letr m) + . foldTM (foldTM k) (cm_case m) + . foldTM (foldTM k) (cm_ecase m) + +-- lkE: lookup in trie for expressions +lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a +lkE (D env expr) cm = go expr cm + where + go (Var v) = cm_var >.> lkVar env v + go (Lit l) = cm_lit >.> lookupTM l + go (Type t) = cm_type >.> lkG (D env t) + go (Coercion c) = cm_co >.> lkG (D env c) + go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env c) + go (Tick tickish e) = cm_tick >.> lkG (D env e) >=> lkTickish tickish + go (App e1 e2) = cm_app >.> lkG (D env e2) >=> lkG (D env e1) + go (Lam v e) = cm_lam >.> lkG (D (extendCME env v) e) + >=> lkBndr env v + go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r) + >=> lkG (D (extendCME env b) e) >=> lkBndr env b + go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr + >.> lkList (lkG . D env1) rhss + >=> lkG (D env1 e) + >=> lkList (lkBndr env1) bndrs + go (Case e b ty as) -- See Note [Empty case alternatives] + | null as = cm_ecase >.> lkG (D env e) >=> lkG (D env ty) + | otherwise = cm_case >.> lkG (D env e) + >=> lkList (lkA (extendCME env b)) as + +xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a +xtE (D env (Var v)) f m = m { cm_var = cm_var m + |> xtVar env v f } +xtE (D env (Type t)) f m = m { cm_type = cm_type m + |> xtG (D env t) f } +xtE (D env (Coercion c)) f m = m { cm_co = cm_co m + |> xtG (D env c) f } +xtE (D _ (Lit l)) f m = m { cm_lit = cm_lit m |> alterTM l f } +xtE (D env (Cast e c)) f m = m { cm_cast = cm_cast m |> xtG (D env e) + |>> xtG (D env c) f } +xtE (D env (Tick t e)) f m = m { cm_tick = cm_tick m |> xtG (D env e) + |>> xtTickish t f } +xtE (D env (App e1 e2)) f m = m { cm_app = cm_app m |> xtG (D env e2) + |>> xtG (D env e1) f } +xtE (D env (Lam v e)) f m = m { cm_lam = cm_lam m + |> xtG (D (extendCME env v) e) + |>> xtBndr env v f } +xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m + |> xtG (D (extendCME env b) e) + |>> xtG (D env r) + |>> xtBndr env b f } +xtE (D env (Let (Rec prs) e)) f m = m { cm_letr = + let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr m + |> xtList (xtG . D env1) rhss + |>> xtG (D env1 e) + |>> xtList (xtBndr env1) + bndrs f } +xtE (D env (Case e b ty as)) f m + | null as = m { cm_ecase = cm_ecase m |> xtG (D env e) + |>> xtG (D env ty) f } + | otherwise = m { cm_case = cm_case m |> xtG (D env e) + |>> let env1 = extendCME env b + in xtList (xtA env1) as f } + +-- TODO: this seems a bit dodgy, see 'eqTickish' +type TickishMap a = Map.Map CoreTickish a +lkTickish :: CoreTickish -> TickishMap a -> Maybe a +lkTickish = lookupTM + +xtTickish :: CoreTickish -> XT a -> TickishMap a -> TickishMap a +xtTickish = alterTM + +------------------------ +data AltMap a -- A single alternative + = AM { am_deflt :: CoreMapG a + , am_data :: DNameEnv (CoreMapG a) + , am_lit :: LiteralMap (CoreMapG a) } + +-- TODO(22292): derive +instance Functor AltMap where + fmap f AM { am_deflt = adeflt, am_data = adata, am_lit = alit } = AM + { am_deflt = fmap f adeflt, am_data = fmap (fmap f) adata, am_lit = fmap (fmap f) alit } + +instance TrieMap AltMap where + type Key AltMap = CoreAlt + emptyTM = AM { am_deflt = emptyTM + , am_data = emptyDNameEnv + , am_lit = emptyTM } + lookupTM = lkA emptyCME + alterTM = xtA emptyCME + foldTM = fdA + filterTM = ftA + mapMaybeTM = mpA + +instance Eq (DeBruijn CoreAlt) where + D env1 a1 == D env2 a2 = go a1 a2 where + go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2) + = D env1 rhs1 == D env2 rhs2 + go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2) + = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 + go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2) + = dc1 == dc2 && + D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 + go _ _ = False + +ftA :: (a->Bool) -> AltMap a -> AltMap a +ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) + = AM { am_deflt = filterTM f adeflt + , am_data = fmap (filterTM f) adata + , am_lit = fmap (filterTM f) alit } + +lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a +lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs) +lkA env (Alt (LitAlt lit) _ rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) +lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc + >=> lkG (D (extendCMEs env bs) rhs) + +xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a +xtA env (Alt DEFAULT _ rhs) f m = + m { am_deflt = am_deflt m |> xtG (D env rhs) f } +xtA env (Alt (LitAlt l) _ rhs) f m = + m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } +xtA env (Alt (DataAlt d) bs rhs) f m = + m { am_data = am_data m |> xtDNamed d + |>> xtG (D (extendCMEs env bs) rhs) f } + +fdA :: (a -> b -> b) -> AltMap a -> b -> b +fdA k m = foldTM k (am_deflt m) + . foldTM (foldTM k) (am_data m) + . foldTM (foldTM k) (am_lit m) + +mpA :: (a -> Maybe b) -> AltMap a -> AltMap b +mpA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) + = AM { am_deflt = mapMaybeTM f adeflt + , am_data = fmap (mapMaybeTM f) adata + , am_lit = fmap (mapMaybeTM f) alit } diff --git a/GHC/Core/Map/Type.hs b/GHC/Core/Map/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Map/Type.hs @@ -0,0 +1,656 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Core.Map.Type ( + -- * Re-export generic interface + TrieMap(..), XT, + + -- * Maps over 'Type's + TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, + LooseTypeMap, + -- ** With explicit scoping + CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope, + mkDeBruijnContext, extendCME, extendCMEs, emptyCME, + + -- * Utilities for use by friends only + TypeMapG, CoercionMapG, + + DeBruijn(..), deBruijnize, eqDeBruijnType, eqDeBruijnVar, + + BndrMap, xtBndr, lkBndr, + VarMap, xtVar, lkVar, lkDFreeVar, xtDFreeVar, + + xtDNamed, lkDNamed + + ) where + +-- This module is separate from GHC.Core.Map.Expr to avoid a module loop +-- between GHC.Core.Unify (which depends on this module) and GHC.Core + +import GHC.Prelude + +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon( isForgetfulSynTyCon ) +import GHC.Core.TyCo.Compare( eqForAllVis ) +import GHC.Data.TrieMap + +import GHC.Data.FastString +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Unique.FM +import GHC.Utils.Outputable + +import GHC.Utils.Panic + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap + +import Control.Monad ( (>=>) ) + +-- NB: Be careful about RULES and type families (#5821). So we should make sure +-- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form) + +{-# SPECIALIZE lkG :: Key TypeMapX -> TypeMapG a -> Maybe a #-} +{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-} + +{-# SPECIALIZE xtG :: Key TypeMapX -> XT a -> TypeMapG a -> TypeMapG a #-} +{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-} + +{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a -> TypeMapG b #-} +{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-} + +{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a -> b -> b #-} +{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-} + +{- +************************************************************************ +* * + Coercions +* * +************************************************************************ +-} + +-- We should really never care about the contents of a coercion. Instead, +-- just look up the coercion's type. +newtype CoercionMap a = CoercionMap (CoercionMapG a) + +-- TODO(22292): derive +instance Functor CoercionMap where + fmap f = \ (CoercionMap m) -> CoercionMap (fmap f m) + {-# INLINE fmap #-} + +instance TrieMap CoercionMap where + type Key CoercionMap = Coercion + emptyTM = CoercionMap emptyTM + lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m + alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) + foldTM k (CoercionMap m) = foldTM k m + filterTM f (CoercionMap m) = CoercionMap (filterTM f m) + mapMaybeTM f (CoercionMap m) = CoercionMap (mapMaybeTM f m) + +type CoercionMapG = GenMap CoercionMapX +newtype CoercionMapX a = CoercionMapX (TypeMapX a) + +-- TODO(22292): derive +instance Functor CoercionMapX where + fmap f = \ (CoercionMapX core_tm) -> CoercionMapX (fmap f core_tm) + {-# INLINE fmap #-} + +instance TrieMap CoercionMapX where + type Key CoercionMapX = DeBruijn Coercion + emptyTM = CoercionMapX emptyTM + lookupTM = lkC + alterTM = xtC + foldTM f (CoercionMapX core_tm) = foldTM f core_tm + filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm) + mapMaybeTM f (CoercionMapX core_tm) = CoercionMapX (mapMaybeTM f core_tm) + +instance Eq (DeBruijn Coercion) where + D env1 co1 == D env2 co2 + = D env1 (coercionType co1) == + D env2 (coercionType co2) + +lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a +lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co) + core_tm + +xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a +xtC (D env co) f (CoercionMapX m) + = CoercionMapX (xtT (D env $ coercionType co) f m) + +{- +************************************************************************ +* * + Types +* * +************************************************************************ +-} + +-- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@. The extended +-- key makes it suitable for recursive traversal, since it can track binders, +-- but it is strictly internal to this module. If you are including a 'TypeMap' +-- inside another 'TrieMap', this is the type you want. Note that this +-- lookup does not do a kind-check. Thus, all keys in this map must have +-- the same kind. Also note that this map respects the distinction between +-- @Type@ and @Constraint@, despite the fact that they are equivalent type +-- synonyms in Core. +type TypeMapG = GenMap TypeMapX + +-- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the +-- 'GenMap' optimization. See Note [Computing equality on types] in GHC.Core.Type. +data TypeMapX a + = TM { tm_var :: VarMap a + , tm_app :: TypeMapG (TypeMapG a) -- Note [Equality on AppTys] in GHC.Core.Type + , tm_tycon :: DNameEnv a + , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr + , tm_tylit :: TyLitMap a + , tm_coerce :: Maybe a + } + -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type + +-- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the +-- last one? See Note [Equality on AppTys] in GHC.Core.Type +-- +-- We also keep (Eq a => a) as a FunTy, distinct from ((->) (Eq a) a). +trieMapView :: Type -> Maybe Type +trieMapView ty + -- First check for TyConApps that need to be expanded to + -- AppTy chains. This includes eliminating FunTy entirely. + | Just (tc, tys@(_:_)) <- splitTyConApp_maybe ty + = Just $ foldl' AppTy (mkTyConTy tc) tys + + -- Then resolve any remaining nullary synonyms. + | Just ty' <- coreView ty + = Just ty' + +trieMapView _ = Nothing + +-- TODO(22292): derive +instance Functor TypeMapX where + fmap f TM + { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon, tm_forall = tforall + , tm_tylit = tlit, tm_coerce = tcoerce } = TM + { tm_var = fmap f tvar, tm_app = fmap (fmap f) tapp, tm_tycon = fmap f ttycon + , tm_forall = fmap (fmap f) tforall + , tm_tylit = fmap f tlit, tm_coerce = fmap f tcoerce } + +instance TrieMap TypeMapX where + type Key TypeMapX = DeBruijn Type + emptyTM = emptyT + lookupTM = lkT + alterTM = xtT + foldTM = fdT + filterTM = filterT + mapMaybeTM = mpT + +instance Eq (DeBruijn Type) where + (==) = eqDeBruijnType + +-- | An equality relation between two 'Type's (known below as @t1 :: k2@ +-- and @t2 :: k2@) +data TypeEquality = TNEQ -- ^ @t1 /= t2@ + | TEQ -- ^ @t1 ~ t2@ and there are not casts in either, + -- therefore we can conclude @k1 ~ k2@ + | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so + -- they may differ in kind + +eqDeBruijnType :: DeBruijn Type -> DeBruijn Type -> Bool +eqDeBruijnType env_t1@(D env1 t1) env_t2@(D env2 t2) = + -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + -- See Note [Computing equality on types] + case go env_t1 env_t2 of + TEQX -> toBool (go (D env1 k1) (D env2 k2)) + ty_eq -> toBool ty_eq + where + k1 = typeKind t1 + k2 = typeKind t2 + + toBool :: TypeEquality -> Bool + toBool TNEQ = False + toBool _ = True + + liftEquality :: Bool -> TypeEquality + liftEquality False = TNEQ + liftEquality _ = TEQ + + hasCast :: TypeEquality -> TypeEquality + hasCast TEQ = TEQX + hasCast eq = eq + + andEq :: TypeEquality -> TypeEquality -> TypeEquality + andEq TNEQ _ = TNEQ + andEq TEQX e = hasCast e + andEq TEQ e = e + + -- See Note [Comparing type synonyms] in GHC.Core.TyCo.Compare + go (D env1 (TyConApp tc1 tys1)) (D env2 (TyConApp tc2 tys2)) + | tc1 == tc2, not (isForgetfulSynTyCon tc1) + = gos env1 env2 tys1 tys2 + + go env_t@(D env t) env_t'@(D env' t') + | Just new_t <- coreView t = go (D env new_t) env_t' + | Just new_t' <- coreView t' = go env_t (D env' new_t') + | otherwise + = case (t, t') of + -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + (CastTy t1 _, _) -> hasCast (go (D env t1) (D env t')) + (_, CastTy t1' _) -> hasCast (go (D env t) (D env t1')) + + (TyVarTy v, TyVarTy v') + -> liftEquality $ eqDeBruijnVar (D env v) (D env' v') + -- See Note [Equality on AppTys] in GHC.Core.Type + (AppTy t1 t2, s) | Just (t1', t2') <- splitAppTyNoView_maybe s + -> go (D env t1) (D env' t1') `andEq` go (D env t2) (D env' t2') + (s, AppTy t1' t2') | Just (t1, t2) <- splitAppTyNoView_maybe s + -> go (D env t1) (D env' t1') `andEq` go (D env t2) (D env' t2') + (FunTy v1 w1 t1 t2, FunTy v1' w1' t1' t2') + + -> liftEquality (v1 == v1') `andEq` + -- NB: eqDeBruijnType does the kind check requested by + -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep + liftEquality (eqDeBruijnType (D env t1) (D env' t1')) `andEq` + liftEquality (eqDeBruijnType (D env t2) (D env' t2')) `andEq` + -- Comparing multiplicities last because the test is usually true + go (D env w1) (D env w1') + (TyConApp tc tys, TyConApp tc' tys') + -> liftEquality (tc == tc') `andEq` gos env env' tys tys' + (LitTy l, LitTy l') + -> liftEquality (l == l') + (ForAllTy (Bndr tv vis) ty, ForAllTy (Bndr tv' vis') ty') + -> -- See Note [ForAllTy and type equality] in + -- GHC.Core.TyCo.Compare for why we use `eqForAllVis` here + liftEquality (vis `eqForAllVis` vis') `andEq` + go (D env (varType tv)) (D env' (varType tv')) `andEq` + go (D (extendCME env tv) ty) (D (extendCME env' tv') ty') + (CoercionTy {}, CoercionTy {}) + -> TEQ + _ -> TNEQ + + -- These bangs make 'gos' strict in the CMEnv, which in turn + -- keeps the CMEnv unboxed across the go/gos mutual recursion + -- (If you want a test case, T9872c really exercises this code.) + gos !_ !_ [] [] = TEQ + gos e1 e2 (ty1:tys1) (ty2:tys2) = go (D e1 ty1) (D e2 ty2) `andEq` + gos e1 e2 tys1 tys2 + gos _ _ _ _ = TNEQ + +instance Eq (DeBruijn Var) where + (==) = eqDeBruijnVar + +eqDeBruijnVar :: DeBruijn Var -> DeBruijn Var -> Bool +eqDeBruijnVar (D env1 v1) (D env2 v2) = + case (lookupCME env1 v1, lookupCME env2 v2) of + (Just b1, Just b2) -> b1 == b2 + (Nothing, Nothing) -> v1 == v2 + _ -> False + +instance {-# OVERLAPPING #-} + Outputable a => Outputable (TypeMapG a) where + ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m []) + +emptyT :: TypeMapX a +emptyT = TM { tm_var = emptyTM + , tm_app = emptyTM + , tm_tycon = emptyDNameEnv + , tm_forall = emptyTM + , tm_tylit = emptyTyLitMap + , tm_coerce = Nothing } + +----------------- +lkT :: DeBruijn Type -> TypeMapX a -> Maybe a +lkT (D env ty) m = go ty m + where + go ty | Just ty' <- trieMapView ty = go ty' + go (TyVarTy v) = tm_var >.> lkVar env v + go (AppTy t1 t2) = tm_app >.> lkG (D env t1) + >=> lkG (D env t2) + go (TyConApp tc []) = tm_tycon >.> lkDNamed tc + go (LitTy l) = tm_tylit >.> lkTyLit l + go (ForAllTy (Bndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) + >=> lkBndr env tv + go (CastTy t _) = go t + go (CoercionTy {}) = tm_coerce + + -- trieMapView has eliminated non-nullary TyConApp + -- and FunTy into an AppTy chain + go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) + go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) + +----------------- +xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a +xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m + +xtT (D env (TyVarTy v)) f m = m { tm_var = tm_var m |> xtVar env v f } +xtT (D env (AppTy t1 t2)) f m = m { tm_app = tm_app m |> xtG (D env t1) + |>> xtG (D env t2) f } +xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f } +xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } +xtT (D env (CastTy t _)) f m = xtT (D env t) f m +xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } +xtT (D env (ForAllTy (Bndr tv _) ty)) f m + = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) + |>> xtBndr env tv f } + +-- trieMapView has eliminated non-nullary TyConApp +-- and FunTy into an AppTy chain +xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) +xtT (D _ ty@(FunTy {})) _ _ = pprPanic "xtT FunTy" (ppr ty) + +fdT :: (a -> b -> b) -> TypeMapX a -> b -> b +fdT k m = foldTM k (tm_var m) + . foldTM (foldTM k) (tm_app m) + . foldTM k (tm_tycon m) + . foldTM (foldTM k) (tm_forall m) + . foldTyLit k (tm_tylit m) + . foldMaybe k (tm_coerce m) + +filterT :: (a -> Bool) -> TypeMapX a -> TypeMapX a +filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon + , tm_forall = tforall, tm_tylit = tlit + , tm_coerce = tcoerce }) + = TM { tm_var = filterTM f tvar + , tm_app = fmap (filterTM f) tapp + , tm_tycon = filterTM f ttycon + , tm_forall = fmap (filterTM f) tforall + , tm_tylit = filterTM f tlit + , tm_coerce = filterMaybe f tcoerce } + +------------------------ +data TyLitMap a = TLM { tlm_number :: Map.Map Integer a + , tlm_string :: UniqFM FastString a + , tlm_char :: Map.Map Char a + } + +-- TODO(22292): derive +instance Functor TyLitMap where + fmap f TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc } = TLM + { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc } + +instance TrieMap TyLitMap where + type Key TyLitMap = TyLit + emptyTM = emptyTyLitMap + lookupTM = lkTyLit + alterTM = xtTyLit + foldTM = foldTyLit + filterTM = filterTyLit + mapMaybeTM = mpTyLit + +emptyTyLitMap :: TyLitMap a +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty } + +lkTyLit :: TyLit -> TyLitMap a -> Maybe a +lkTyLit l = + case l of + NumTyLit n -> tlm_number >.> Map.lookup n + StrTyLit n -> tlm_string >.> (`lookupUFM` n) + CharTyLit n -> tlm_char >.> Map.lookup n + +xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a +xtTyLit l f m = + case l of + NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) } + StrTyLit n -> m { tlm_string = alterUFM f (tlm_string m) n } + CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) } + +foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b +foldTyLit l m = flip (nonDetFoldUFM l) (tlm_string m) + . flip (Map.foldr l) (tlm_number m) + . flip (Map.foldr l) (tlm_char m) + +filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a +filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) + = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc } + +mpTyLit :: (a -> Maybe b) -> TyLitMap a -> TyLitMap b +mpTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) + = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUFM f ts, tlm_char = Map.mapMaybe f tc } + +------------------------------------------------- +-- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this +-- is the type you want. The keys in this map may have different kinds. +newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a)) + +-- TODO(22292): derive +instance Functor TypeMap where + fmap f = \ (TypeMap m) -> TypeMap (fmap (fmap f) m) + {-# INLINE fmap #-} + +lkTT :: DeBruijn Type -> TypeMap a -> Maybe a +lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m + >>= lkG (D env ty) + +xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a +xtTT (D env ty) f (TypeMap m) + = TypeMap (m |> xtG (D env $ typeKind ty) + |>> xtG (D env ty) f) + +-- Below are some client-oriented functions which operate on 'TypeMap'. + +instance TrieMap TypeMap where + type Key TypeMap = Type + emptyTM = TypeMap emptyTM + lookupTM k m = lkTT (deBruijnize k) m + alterTM k f m = xtTT (deBruijnize k) f m + foldTM k (TypeMap m) = foldTM (foldTM k) m + filterTM f (TypeMap m) = TypeMap (fmap (filterTM f) m) + mapMaybeTM f (TypeMap m) = TypeMap (fmap (mapMaybeTM f) m) + +foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b +foldTypeMap k z m = foldTM k m z + +emptyTypeMap :: TypeMap a +emptyTypeMap = emptyTM + +lookupTypeMap :: TypeMap a -> Type -> Maybe a +lookupTypeMap cm t = lookupTM t cm + +extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a +extendTypeMap m t v = alterTM t (const (Just v)) m + +lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a +lookupTypeMapWithScope m cm t = lkTT (D cm t) m + +-- | Extend a 'TypeMap' with a type in the given context. +-- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to +-- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over +-- multiple insertions. +extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a +extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m + +-- | Construct a deBruijn environment with the given variables in scope. +-- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@ +mkDeBruijnContext :: [Var] -> CmEnv +mkDeBruijnContext = extendCMEs emptyCME + +-- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g), +-- you'll find entries inserted under (t), even if (g) is non-reflexive. +newtype LooseTypeMap a = LooseTypeMap (TypeMapG a) + +-- TODO(22292): derive +instance Functor LooseTypeMap where + fmap f = \ (LooseTypeMap m) -> LooseTypeMap (fmap f m) + {-# INLINE fmap #-} + +instance TrieMap LooseTypeMap where + type Key LooseTypeMap = Type + emptyTM = LooseTypeMap emptyTM + lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m + alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) + foldTM f (LooseTypeMap m) = foldTM f m + filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m) + mapMaybeTM f (LooseTypeMap m) = LooseTypeMap (mapMaybeTM f m) + +{- +************************************************************************ +* * + Variables +* * +************************************************************************ +-} + +type BoundVar = Int -- Bound variables are deBruijn numbered +type BoundVarMap a = IntMap.IntMap a + +data CmEnv = CME { cme_next :: !BoundVar + , cme_env :: VarEnv BoundVar } + +emptyCME :: CmEnv +emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv } + +extendCME :: CmEnv -> Var -> CmEnv +extendCME (CME { cme_next = bv, cme_env = env }) v + = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv } + +extendCMEs :: CmEnv -> [Var] -> CmEnv +extendCMEs env vs = foldl' extendCME env vs + +lookupCME :: CmEnv -> Var -> Maybe BoundVar +lookupCME (CME { cme_env = env }) v = lookupVarEnv env v + +-- | @DeBruijn a@ represents @a@ modulo alpha-renaming. This is achieved +-- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn +-- numbering. This allows us to define an 'Eq' instance for @DeBruijn a@, even +-- if this was not (easily) possible for @a@. Note: we purposely don't +-- export the constructor. Make a helper function if you find yourself +-- needing it. +data DeBruijn a = D CmEnv a + +-- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no +-- bound binders (an empty 'CmEnv'). This is usually what you want if there +-- isn't already a 'CmEnv' in scope. +deBruijnize :: a -> DeBruijn a +deBruijnize = D emptyCME + +instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where + D _ [] == D _ [] = True + D env (x:xs) == D env' (x':xs') = D env x == D env' x' && + D env xs == D env' xs' + _ == _ = False + +instance Eq (DeBruijn a) => Eq (DeBruijn (Maybe a)) where + D _ Nothing == D _ Nothing = True + D env (Just x) == D env' (Just x') = D env x == D env' x' + _ == _ = False + +--------- Variable binders ------------- + +-- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between +-- binding forms whose binders have different types. For example, +-- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should +-- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@: +-- we can disambiguate this by matching on the type (or kind, if this +-- a binder in a type) of the binder. +-- +-- We also need to do the same for multiplicity! Which, since multiplicities are +-- encoded simply as a 'Type', amounts to have a Trie for a pair of types. Tries +-- of pairs are composition. +data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a)) + +-- TODO(22292): derive +instance Functor BndrMap where + fmap f = \ (BndrMap tm) -> BndrMap (fmap (fmap f) tm) + {-# INLINE fmap #-} + +instance TrieMap BndrMap where + type Key BndrMap = Var + emptyTM = BndrMap emptyTM + lookupTM = lkBndr emptyCME + alterTM = xtBndr emptyCME + foldTM = fdBndrMap + filterTM = ftBndrMap + mapMaybeTM = mpBndrMap + +fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b +fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm + +mpBndrMap :: (a -> Maybe b) -> BndrMap a -> BndrMap b +mpBndrMap f (BndrMap tm) = BndrMap (fmap (mapMaybeTM f) tm) + +-- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all +-- of these data types have binding forms. + +lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a +lkBndr env v (BndrMap tymap) = do + multmap <- lkG (D env (varType v)) tymap + lookupTM (D env <$> varMultMaybe v) multmap + + +xtBndr :: forall a . CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a +xtBndr env v xt (BndrMap tymap) = + BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt)) + +ftBndrMap :: (a -> Bool) -> BndrMap a -> BndrMap a +ftBndrMap f (BndrMap tm) = BndrMap (fmap (filterTM f) tm) + +--------- Variable occurrence ------------- +data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable + , vm_fvar :: DVarEnv a } -- Free variable + +-- TODO(22292): derive +instance Functor VarMap where + fmap f VM { vm_bvar = bv, vm_fvar = fv } = VM { vm_bvar = fmap f bv, vm_fvar = fmap f fv } + +instance TrieMap VarMap where + type Key VarMap = Var + emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv } + lookupTM = lkVar emptyCME + alterTM = xtVar emptyCME + foldTM = fdVar + filterTM = ftVar + mapMaybeTM = mpVar + +lkVar :: CmEnv -> Var -> VarMap a -> Maybe a +lkVar env v + | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv + | otherwise = vm_fvar >.> lkDFreeVar v + +xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a +xtVar env v f m + | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f } + | otherwise = m { vm_fvar = vm_fvar m |> xtDFreeVar v f } + +fdVar :: (a -> b -> b) -> VarMap a -> b -> b +fdVar k m = foldTM k (vm_bvar m) + . foldTM k (vm_fvar m) + +lkDFreeVar :: Var -> DVarEnv a -> Maybe a +lkDFreeVar var env = lookupDVarEnv env var + +xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a +xtDFreeVar v f m = alterDVarEnv f m v + +ftVar :: (a -> Bool) -> VarMap a -> VarMap a +ftVar f (VM { vm_bvar = bv, vm_fvar = fv }) + = VM { vm_bvar = filterTM f bv, vm_fvar = filterTM f fv } + +mpVar :: (a -> Maybe b) -> VarMap a -> VarMap b +mpVar f (VM { vm_bvar = bv, vm_fvar = fv }) + = VM { vm_bvar = mapMaybeTM f bv, vm_fvar = mapMaybeTM f fv } + +------------------------------------------------- +lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a +lkDNamed n env = lookupDNameEnv env (getName n) + +xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a +xtDNamed tc f m = alterDNameEnv f m (getName tc) + +mpT :: (a -> Maybe b) -> TypeMapX a -> TypeMapX b +mpT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon + , tm_forall = tforall, tm_tylit = tlit + , tm_coerce = tcoerce }) + = TM { tm_var = mapMaybeTM f tvar + , tm_app = fmap (mapMaybeTM f) tapp + , tm_tycon = mapMaybeTM f ttycon + , tm_forall = fmap (mapMaybeTM f) tforall + , tm_tylit = mapMaybeTM f tlit + , tm_coerce = tcoerce >>= f } diff --git a/GHC/Core/Multiplicity.hs b/GHC/Core/Multiplicity.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Multiplicity.hs @@ -0,0 +1,404 @@ +{-# LANGUAGE PatternSynonyms #-} + +{-| +This module defines the semi-ring of multiplicities, and associated functions. +Multiplicities annotate arrow types to indicate the linearity of the +arrow (in the sense of linear types). + +Mult is a type synonym for Type, used only when its kind is Multiplicity. +To simplify dealing with multiplicities, functions such as +mkMultMul perform simplifications such as Many * x = Many on the fly. +-} +module GHC.Core.Multiplicity + ( Mult + , pattern OneTy + , pattern ManyTy + , isMultMul + , mkMultAdd + , mkMultMul + , mkMultSup + , Scaled(..) + , scaledMult + , scaledThing + , unrestricted + , linear + , tymult + , irrelevantMult + , mkScaled + , scaledSet + , scaleScaled + , IsSubmult(..) + , submult + , mapScaledType + , pprArrowWithMultiplicity + , MultiplicityFlag(..) + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Types.Var( isFUNArg ) +import {-# SOURCE #-} GHC.Builtin.Types ( multMulTyCon ) +import GHC.Builtin.Names (multMulTyConKey) +import GHC.Types.Unique (hasKey) + +{- +Note [Linear types] +~~~~~~~~~~~~~~~~~~~ +This module is the entry point for linear types. + +The detailed design is in the _Linear Haskell_ article +[https://arxiv.org/abs/1710.09756]. Other important resources in the linear +types implementation wiki page +[https://gitlab.haskell.org/ghc/ghc/wikis/linear-types/implementation], and the +proposal [https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst] which +describes the concrete design at length. + +For the busy developer, though, here is a high-level view of linear types is the following: + +- Function arrows are annotated with a multiplicity (as defined by type `Mult` + and its smart constructors in this module) + - Multiplicities, in Haskell, are types of kind `GHC.Types.Multiplicity`. + as in + + map :: forall (p :: Multiplicity). (a %p -> b) -> [a] %p -> [b] + + - The type constructor for function types (FUN) has type + + FUN :: forall (m :: Multiplicity) -> forall {r1) {r2}. TYPE r1 -> TYPE r2 -> Type + + The argument order is explained in https://gitlab.haskell.org/ghc/ghc/-/issues/20164 + - (->) retains its backward compatible meaning: + + (->) a b = a -> b = a %'Many -> b + + To achieve this, `(->)` is defined as a type synonym to `FUN Many` (see + below). +- A ground multiplicity (that is, without a variable) can be `One` or `Many` + (`Many` is generally rendered as ω in the scientific literature). + Functions whose type is annotated with `One` are linear functions, functions whose + type is annotated with `Many` are regular functions, often called “unrestricted” + to contrast them with linear functions. +- A linear function is defined as a function such that *if* its result is + consumed exactly once, *then* its argument is consumed exactly once. You can + think of “consuming exactly once” as evaluating a value in normal form exactly + once (though not necessarily in one go). The _Linear Haskell_ article (see + supra) has a more precise definition of “consuming exactly once”. +- Data constructors are linear by default. + See Note [Data constructors are linear by default]. +- Multiplicities form a semiring. +- Multiplicities can also be variables and we can universally quantify over + these variables. This is referred to as “multiplicity + polymorphism”. Furthermore, multiplicity can be formal semiring expressions + combining variables. +- Contrary to the paper, the sum of two multiplicities is always `Many`. This + will have to change, however, if we want to add a multiplicity for 0. Whether + we want to is still debated. +- Case expressions have a multiplicity annotation too. A case expression with + multiplicity `One`, consumes its scrutinee exactly once (provided the entire + case expression is consumed exactly once); whereas a case expression with + multiplicity `Many` can consume its scrutinee as many time as it wishes (no + matter how much the case expression is consumed). + +For linear types in the linter see Note [Linting linearity] in GHC.Core.Lint. + +Note [Usages] +~~~~~~~~~~~~~ +In the _Linear Haskell_ paper, you'll find typing rules such as these: + + Γ ⊢ f : A #π-> B Δ ⊢ u : A + --------------------------- + Γ + kΔ ⊢ f u : B + +If you read this as a type-checking algorithm going from the bottom up, this +reads as: the algorithm has to find a split of some input context Ξ into an +appropriate Γ and a Δ such as Ξ = Γ + kΔ, *and the multiplicities are chosen to +make f and u typecheck*. + +This could be achieved by letting the typechecking of `f` use exactly the +variable it needs, then passing the remainder, as `Delta` to the typechecking of +u. But what does that mean if `x` is bound with multiplicity `p` (a variable) +and `f` consumes `x` once? `Delta` would have to contain `x` with multiplicity +`p-1`. It's not really clear how to make that works. In summary: bottom-up +multiplicity checking forgoes addition and multiplication in favour of +subtraction and division. And variables make the latter hard. + +The alternative is to read multiplicities from the top down: as an *output* from +the typechecking algorithm, rather than an input. We call these output +multiplicities Usages, to distinguish them from the multiplicities which come, +as input, from the types of functions. Usages are checked for compatibility with +multiplicity annotations using an ordering relation. In other words, the usage +of x in the expression u is the smallest multiplicity which can be ascribed to x +for u to typecheck. + +Usages are usually group in a UsageEnv, as defined in the UsageEnv module. + +So, in our function application example, the typechecking algorithm would +receive usage environments f_ue from the typechecking of f, and u_ue from the +typechecking of u. Then the output would be f_ue + (k * u_ue). Addition and +scaling of usage environment is the pointwise extension of the semiring +operations on multiplicities. + +Note [Zero as a usage] +~~~~~~~~~~~~~~~~~~~~~~ +In the current presentation usages are not exactly multiplicities, because they +can contain 0, and multiplicities can't. + +Why do we need a 0 usage? A function which doesn't use its argument will be +required to annotate it with `Many`: + + \(x % Many) -> 0 + +However, we cannot replace absence with Many when computing usages +compositionally: in + + (x, True) + +We expect x to have usage 1. But when computing the usage of x in True we would +find that x is absent, hence has multiplicity Many. The final multiplicity would +be One+Many = Many. Oops! + +Hence there is a usage Zero for absent variables. Zero is characterised by being +the neutral element to usage addition. + +We may decide to add Zero as a multiplicity in the future. In which case, this +distinction will go away. + +Note [Joining usages] +~~~~~~~~~~~~~~~~~~~~~ +The usage of a variable is defined, in Note [Usages], as the minimum usage which +can be ascribed to a variable. + +So what is the usage of x in + + case … of + { p1 -> u -- usage env: u_ue + ; p2 -> v } -- usage env: v_ue + +It must be the least upper bound, or _join_, of u_ue(x) and v_ue(x). + +So, contrary to a declarative presentation where the correct usage of x can be +conjured out of thin air, we need to be able to compute the join of two +multiplicities. Join is extended pointwise on usage environments. + +Note [Bottom as a usage] +~~~~~~~~~~~~~~~~~~~~~~ +What is the usage of x in + + case … of {} + +Per usual linear logic, as well as the _Linear Haskell_ article, x can have +every multiplicity. + +So we need a minimum usage _bottom_, which is also the neutral element for join. + +In fact, this is not such as nice solution, because it is not clear how to +define sum and multiplication with bottom. We give reasonable definitions, but +they are not complete (they don't respect the semiring laws, and it's possible +to come up with examples of Core transformation which are not well-typed) + +A better solution would probably be to annotate case expressions with a usage +environment, just like they are annotated with a type. Which, probably not +coincidentally, is also primarily for empty cases. + +A side benefit of this approach is that the linter would not need to join +multiplicities, anymore; hence would be closer to the presentation in the +article. That's because it could use the annotation as the multiplicity for each +branch. + +Note [Data constructors are linear by default] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All data constructors defined without -XLinearTypes, as well as data constructors +defined with the Haskell 98 in all circumstances, have all their fields linear. + +That is, in + + data Maybe a = Nothing | Just a + +We have + + Just :: a %1 -> Just a + +Irrespective of whether -XLinearTypes is turned on or not. Furthermore, when +-XLinearTypes is turned off, the declaration + + data Endo a where { MkIntEndo :: (Int -> Int) -> T Int } + +gives + + MkIntEndo :: (Int -> Int) %1 -> T Int + +With -XLinearTypes turned on, instead, this would give + + data EndoU a where { MkIntEndoU :: (Int -> Int) -> T Int } + MkIntEndoU :: (Int -> Int) -> T Int + +With -XLinearTypes turned on, to get a linear field with GADT syntax we +would need to write + + data EndoL a where { MkIntEndoL :: (Int -> Int) %1 -> T Int } + +The goal is to maximise reuse of types between linear code and traditional +code. This is argued at length in the proposal and the article (links in Note +[Linear types]). + +Unrestricted field don't need to be consumed for a value to be consumed exactly +once. So consuming a value of type `IntEndoU a` exactly once means forcing it at +least once. + +Why “at least once”? Because if `case u of { MkIntEndoL x -> f (MkIntEndoL x) }` +is linear (provided `f` is a linear function). But we might as well have done +`case u of { !z -> f z }`. So, we can observe constructors as many times as we +want, and we are actually allowed to force the same thing several times because +laziness means that we are really forcing the value once, and observing its +constructor several times. The type checker and the linter recognise some (but +not all) of these multiple forces as indeed linear. Mostly just enough to +support variable patterns. + +In summary: + +- Fields of data constructors defined with Haskell 98 syntax are always linear + (even if `-XLinearTypes` is off). This choice has been made to favour sharing + types between linearly typed Haskell and traditional Haskell. To avoid an + ecosystem split. +- When `-XLinearTypes` is off, GADT-syntax declaration can only use the regular + arrow `(->)`. However all the fields are linear. + + +Note [Polymorphisation of linear fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The choice in Note [Data constructors are linear by default] has an impact on +backwards compatibility. Consider + + map Just + +We have + + map :: (a -> b) -> f a -> f b + Just :: a %1 -> Just a + +Types don't match, we should get a type error. But this is legal Haskell 98 +code! Bad! Bad! Bad! + +It could be solved with subtyping, but subtyping doesn't combine well with +polymorphism. Instead, we generalise the type of Just, when used as term: + + Just :: forall {p}. a %p-> Just a + +This is solely a concern for higher-order code like this: when called fully +applied linear constructors are more general than constructors with unrestricted +fields. In particular, linear constructors can always be eta-expanded to their +Haskell 98 type. This is explained in the paper (but there, we had a different +strategy to resolve this type mismatch in higher-order code. It turned out to be +insufficient, which is explained in the wiki page as well as the proposal). + +We only generalise linear fields this way: fields with multiplicity Many, or +other multiplicity expressions are exclusive to -XLinearTypes, hence don't have +backward compatibility implications. + +The implementation is described in Note [Typechecking data constructors] +in GHC.Tc.Gen.Head. + +More details in the proposal. +-} + +{- +Note [Adding new multiplicities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To add a new multiplicity, you need to: +* Add the new type with Multiplicity kind +* Update cases in mkMultAdd, mkMultMul, mkMultSup, submult, tcSubMult +* Check supUE function that computes sup of a multiplicity + and Zero +-} + +isMultMul :: Mult -> Maybe (Mult, Mult) +isMultMul ty | Just (tc, [x, y]) <- splitTyConApp_maybe ty + , tc `hasKey` multMulTyConKey = Just (x, y) + | otherwise = Nothing + +{- +Note [Overapproximating multiplicities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions mkMultAdd, mkMultMul, mkMultSup perform operations +on multiplicities. They can return overapproximations: their result +is merely guaranteed to be a submultiplicity of the actual value. + +They should be used only when an upper bound is acceptable. +In most cases, they are used in usage environments (UsageEnv); +in usage environments, replacing a usage with a larger one can only +cause more programs to fail to typecheck. + +In future work, instead of approximating we might add type families +and allow users to write types involving operations on multiplicities. +In this case, we could enforce more invariants in Mult, for example, +enforce that it is in the form of a sum of products, and even +that the summands and factors are ordered somehow, to have more equalities. +-} + +-- With only two multiplicities One and Many, we can always replace +-- p + q by Many. See Note [Overapproximating multiplicities]. +mkMultAdd :: Mult -> Mult -> Mult +mkMultAdd _ _ = ManyTy + +mkMultMul :: Mult -> Mult -> Mult +mkMultMul OneTy p = p +mkMultMul p OneTy = p +mkMultMul ManyTy _ = ManyTy +mkMultMul _ ManyTy = ManyTy +mkMultMul p q = mkTyConApp multMulTyCon [p, q] + +scaleScaled :: Mult -> Scaled a -> Scaled a +scaleScaled m' (Scaled m t) = Scaled (m' `mkMultMul` m) t + +-- See Note [Joining usages] +-- | @mkMultSup w1 w2@ returns a multiplicity such that @mkMultSup w1 +-- w2 >= w1@ and @mkMultSup w1 w2 >= w2@. See Note [Overapproximating multiplicities]. +mkMultSup :: Mult -> Mult -> Mult +mkMultSup = mkMultMul +-- Note: If you are changing this logic, check 'supUE' in UsageEnv as well. + +-- +-- * Multiplicity ordering +-- + +data IsSubmult = Submult -- Definitely a submult + | Unknown -- Could be a submult, need to ask the typechecker + deriving (Show, Eq) + +instance Outputable IsSubmult where + ppr = text . show + +-- | @submult w1 w2@ check whether a value of multiplicity @w1@ is allowed where a +-- value of multiplicity @w2@ is expected. This is a partial order. + +submult :: Mult -> Mult -> IsSubmult +submult _ ManyTy = Submult +submult OneTy OneTy = Submult +-- The 1 <= p rule +submult OneTy _ = Submult +submult _ _ = Unknown + +pprArrowWithMultiplicity :: FunTyFlag -> Either Bool SDoc -> SDoc +-- Pretty-print a multiplicity arrow. The multiplicity itself +-- is described by the (Either Bool SDoc) +-- Left False -- Many +-- Left True -- One +-- Right doc -- Something else +-- In the Right case, the doc is in parens if not atomic +pprArrowWithMultiplicity af pp_mult + | isFUNArg af + = case pp_mult of + Left False -> arrow + Left True -> lollipop + Right doc -> text "%" <> doc <+> arrow + | otherwise + = ppr (funTyFlagTyCon af) + +-- | In Core, without `-dlinear-core-lint`, some function must ignore +-- multiplicities. See Note [Linting linearity] in GHC.Core.Lint. +data MultiplicityFlag + = RespectMultiplicities + | IgnoreMultiplicities diff --git a/GHC/Core/Opt/Arity.hs b/GHC/Core/Opt/Arity.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Arity.hs @@ -0,0 +1,3262 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + + Arity and eta expansion +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Arity and eta expansion +module GHC.Core.Opt.Arity + ( -- Finding arity + manifestArity, joinRhsArity, exprArity + , findRhsArity, cheapArityType + , ArityOpts(..) + + -- ** Eta expansion + , exprEtaExpandArity, etaExpand, etaExpandAT + + -- ** Eta reduction + , tryEtaReduce + + -- ** ArityType + , ArityType, mkBotArityType + , arityTypeArity, idArityType + + -- ** Bottoming things + , exprIsDeadEnd, exprBotStrictness_maybe, arityTypeBotSigs_maybe + + -- ** typeArity and the state hack + , typeArity, typeOneShots, typeOneShot + , isOneShotBndr + , isStateHackType + + -- * Lambdas + , zapLamBndrs + + + -- ** Join points + , etaExpandToJoinPoint, etaExpandToJoinPointRule + + -- ** Coercions and casts + , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg + , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo + ) +where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.DataCon +import GHC.Core.TyCon ( TyCon, tyConArity, isInjectiveTyCon ) +import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) +import GHC.Core.Predicate ( isDictTy, isEvId, isCallStackPredTy, isCallStackTy ) +import GHC.Core.Multiplicity + +-- We have two sorts of substitution: +-- GHC.Core.Subst.Subst, and GHC.Core.TyCo.Subst +-- Both have substTy, substCo Hence need for qualification +import GHC.Core.Subst as Core +import GHC.Core.Type as Type +import GHC.Core.Coercion as Type +import GHC.Core.TyCo.Compare( eqType ) + +import GHC.Types.Demand +import GHC.Types.Cpr( CprSig, mkCprSig, botCpr ) +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Tickish + +import GHC.Builtin.Types.Prim +import GHC.Builtin.Uniques + +import GHC.Data.FastString +import GHC.Data.Graph.UnVar +import GHC.Data.Pair + +import GHC.Utils.GlobalVars( unsafeHasNoStateHack ) +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import Data.List.NonEmpty ( nonEmpty ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe( isJust ) + +{- +************************************************************************ +* * + manifestArity and exprArity +* * +************************************************************************ + +exprArity is a cheap-and-cheerful version of exprEtaExpandArity. +It tells how many things the expression can be applied to before doing +any work. It doesn't look inside cases, lets, etc. The idea is that +exprEtaExpandArity will do the hard work, leaving something that's easy +for exprArity to grapple with. In particular, Simplify uses exprArity to +compute the ArityInfo for the Id. + +Originally I thought that it was enough just to look for top-level lambdas, but +it isn't. I've seen this + + foo = PrelBase.timesInt + +We want foo to get arity 2 even though the eta-expander will leave it +unchanged, in the expectation that it'll be inlined. But occasionally it +isn't, because foo is blacklisted (used in a rule). + +Similarly, see the ok_note check in exprEtaExpandArity. So + f = __inline_me (\x -> e) +won't be eta-expanded. + +And in any case it seems more robust to have exprArity be a bit more intelligent. +But note that (\x y z -> f x y z) +should have arity 3, regardless of f's arity. +-} + +manifestArity :: CoreExpr -> Arity +-- ^ manifestArity sees how many leading value lambdas there are, +-- after looking through casts +manifestArity (Lam v e) | isId v = 1 + manifestArity e + | otherwise = manifestArity e +manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e +manifestArity (Cast e _) = manifestArity e +manifestArity _ = 0 + +joinRhsArity :: CoreExpr -> JoinArity +-- Join points are supposed to have manifestly-visible +-- lambdas at the top: no ticks, no casts, nothing +-- Moreover, type lambdas count in JoinArity +-- NB: For non-recursive bindings, the join arity of the binding may actually be +-- less that the number of manifestly-visible lambdas. +-- See Note [Join arity prediction based on joinRhsArity] in GHC.Core.Opt.OccurAnal +joinRhsArity (Lam _ e) = 1 + joinRhsArity e +joinRhsArity _ = 0 + + +--------------- +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig, CprSig) +-- A cheap and cheerful function that identifies bottoming functions +-- and gives them a suitable strictness and CPR signatures. +-- It's used during float-out +exprBotStrictness_maybe e = arityTypeBotSigs_maybe (cheapArityType e) + +arityTypeBotSigs_maybe :: ArityType -> Maybe (Arity, DmdSig, CprSig) +-- Arity of a divergent function +arityTypeBotSigs_maybe (AT lams div) + | isDeadEndDiv div = Just ( arity + , mkVanillaDmdSig arity botDiv + , mkCprSig arity botCpr) + | otherwise = Nothing + where + arity = length lams + + +{- Note [exprArity for applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come to an application we check that the arg is trivial. + eg f (fac x) does not have arity 2, + even if f has arity 3! + +* We require that is trivial rather merely cheap. Suppose f has arity 2. + Then f (Just y) + has arity 0, because if we gave it arity 1 and then inlined f we'd get + let v = Just y in \w. + which has arity 0. And we try to maintain the invariant that we don't + have arity decreases. + +* The `max 0` is important! (\x y -> f x) has arity 2, even if f is + unknown, hence arity 0 + + +************************************************************************ +* * + typeArity and the "state hack" +* * +********************************************************************* -} + + +typeArity :: Type -> Arity +-- ^ (typeArity ty) says how many arrows GHC can expose in 'ty', after +-- looking through newtypes. More generally, (typeOneShots ty) returns +-- ty's [OneShotInfo], based only on the type itself, using typeOneShot +-- on the argument type to access the "state hack". +typeArity = length . typeOneShots + +typeOneShots :: Type -> [OneShotInfo] +-- How many value arrows are visible in the type? +-- We look through foralls, and newtypes +-- See Note [Arity invariants for bindings] +typeOneShots ty + = go initRecTc ty + where + go rec_nts ty + | Just (tcv, ty') <- splitForAllTyCoVar_maybe ty + = if isCoVar tcv + then idOneShotInfo tcv : go rec_nts ty' + else go rec_nts ty' + + | Just (_,_,arg,res) <- splitFunTy_maybe ty + = typeOneShot arg : go rec_nts res + + | Just (tc,tys) <- splitTyConApp_maybe ty + , Just (ty', _) <- instNewTyCon_maybe tc tys + , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes and products] + -- in GHC.Core.TyCon +-- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes +-- -- See Note [Newtype classes and eta expansion] +-- (no longer required) + = go rec_nts' ty' + -- Important to look through non-recursive newtypes, so that, eg + -- (f x) where f has arity 2, f :: Int -> IO () + -- Here we want to get arity 1 for the result! + -- + -- AND through a layer of recursive newtypes + -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) + + | otherwise + = [] + +typeOneShot :: Type -> OneShotInfo +typeOneShot ty + | isStateHackType ty = OneShotLam + | otherwise = NoOneShotInfo + +-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account +-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" +idStateHackOneShotInfo :: Id -> OneShotInfo +idStateHackOneShotInfo id + | isStateHackType (idType id) = OneShotLam + | otherwise = idOneShotInfo id + +-- | Returns whether the lambda associated with the 'Id' is +-- certainly applied at most once +-- This one is the "business end", called externally. +-- It works on type variables as well as Ids, returning True +-- Its main purpose is to encapsulate the Horrible State Hack +-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" +isOneShotBndr :: Var -> Bool +isOneShotBndr var + | isTyVar var = True + | OneShotLam <- idStateHackOneShotInfo var = True + | otherwise = False + +isStateHackType :: Type -> Bool +isStateHackType ty + | unsafeHasNoStateHack -- Switch off with -fno-state-hack + = False + | otherwise + = case tyConAppTyCon_maybe ty of + Just tycon -> tycon == statePrimTyCon + _ -> False + -- This is a gross hack. It claims that + -- every function over realWorldStatePrimTy is a one-shot + -- function. This is pretty true in practice, and makes a big + -- difference. For example, consider + -- a `thenST` \ r -> ...E... + -- The early full laziness pass, if it doesn't know that r is one-shot + -- will pull out E (let's say it doesn't mention r) to give + -- let lvl = E in a `thenST` \ r -> ...lvl... + -- When `thenST` gets inlined, we end up with + -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... + -- and we don't re-inline E. + -- + -- It would be better to spot that r was one-shot to start with, but + -- I don't want to rely on that. + -- + -- Another good example is in fill_in in PrelPack.hs. We should be able to + -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. + + +{- Note [Arity invariants for bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have the following invariants for let-bindings + + (1) In any binding f = e, + idArity f <= typeArity (idType f) + We enforce this with trimArityType, called in findRhsArity; + see Note [Arity trimming]. + + Note that we enforce this only for /bindings/. We do /not/ insist that + arityTypeArity (arityType e) <= typeArity (exprType e) + because that is quite a bit more expensive to guaranteed; it would + mean checking at every Cast in the recursive arityType, for example. + + (2) If typeArity (exprType e) = n, + then manifestArity (etaExpand e n) = n + + That is, etaExpand can always expand as much as typeArity says + (or less, of course). So the case analysis in etaExpand and in + typeArity must match. + + Consequence: because of (1), if we eta-expand to (idArity f), we will + end up with n manifest lambdas. + + (3) In any binding f = e, + idArity f <= arityTypeArity (safeArityType (arityType e)) + That is, we call safeArityType before attributing e's arityType to f. + See Note [SafeArityType]. + + So we call safeArityType in findRhsArity. + +Suppose we have + f :: Int -> Int -> Int + f x y = x+y -- Arity 2 + + g :: F Int + g = case of { True -> f |> co1 + ; False -> g |> co2 } + +where F is a type family. Now, we can't eta-expand g to have arity 2, +because etaExpand, which works off the /type/ of the expression +(albeit looking through newtypes), doesn't know how to make an +eta-expanded binding + g = (\a b. case x of ...) |> co +because it can't make up `co` or the types of `a` and `b`. + +So invariant (1) ensures that every binding has an arity that is no greater +than the typeArity of the RHS; and invariant (2) ensures that etaExpand +and handle what typeArity says. + +Why is this important? Because + + - In GHC.Iface.Tidy we use exprArity/manifestArity to fix the *final + arity* of each top-level Id, and in + + - In CorePrep we use etaExpand on each rhs, so that the visible + lambdas actually match that arity, which in turn means that the + StgRhs has a number of lambdas that precisely matches the arity. + +Note [Arity trimming] +~~~~~~~~~~~~~~~~~~~~~ +Invariant (1) of Note [Arity invariants for bindings] is upheld by findRhsArity, +which calls trimArityType to trim the ArityType to match the Arity of the +binding. Failing to do so, and hence breaking invariant (1) led to #5441. + +How to trim? If we end in topDiv, it's easy. But we must take great care with +dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"), +we'll get \??.⊥. We absolutely must not trim that to \?.⊥, because that +claims that ((\x y. error "urk") |> co) diverges when given one argument, +which it absolutely does not. And Bad Things happen if we think something +returns bottom when it doesn't (#16066). + +So, if we need to trim a dead-ending arity type, switch (conservatively) to +topDiv. + +Historical note: long ago, we unconditionally switched to topDiv when we +encountered a cast, but that is far too conservative: see #5475 + +Note [Newtype classes and eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NB: this nasty special case is no longer required, because + for newtype classes we don't use the class-op rule mechanism + at all. See Note [Single-method classes] in GHC.Tc.TyCl.Instance. SLPJ May 2013 + +-------- Old out of date comments, just for interest ----------- +We have to be careful when eta-expanding through newtypes. In general +it's a good idea, but annoyingly it interacts badly with the class-op +rule mechanism. Consider + + class C a where { op :: a -> a } + instance C b => C [b] where + op x = ... + +These translate to + + co :: forall a. (a->a) ~ C a + + $copList :: C b -> [b] -> [b] + $copList d x = ... + + $dfList :: C b -> C [b] + {-# DFunUnfolding = [$copList] #-} + $dfList d = $copList d |> co@[b] + +Now suppose we have: + + dCInt :: C Int + + blah :: [Int] -> [Int] + blah = op ($dfList dCInt) + +Now we want the built-in op/$dfList rule will fire to give + blah = $copList dCInt + +But with eta-expansion 'blah' might (and in #3772, which is +slightly more complicated, does) turn into + + blah = op (\eta. ($dfList dCInt |> sym co) eta) + +and now it is *much* harder for the op/$dfList rule to fire, because +exprIsConApp_maybe won't hold of the argument to op. I considered +trying to *make* it hold, but it's tricky and I gave up. + +The test simplCore/should_compile/T3722 is an excellent example. +-------- End of old out of date comments, just for interest ----------- +-} + +{- ******************************************************************** +* * + Zapping lambda binders +* * +********************************************************************* -} + +zapLamBndrs :: FullArgCount -> [Var] -> [Var] +-- If (\xyz. t) appears under-applied to only two arguments, +-- we must zap the occ-info on x,y, because they appear (in 't') under the \z. +-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal +-- +-- NB: both `arg_count` and `bndrs` include both type and value args/bndrs +zapLamBndrs arg_count bndrs + | no_need_to_zap = bndrs + | otherwise = zap_em arg_count bndrs + where + no_need_to_zap = all isOneShotBndr (drop arg_count bndrs) + + zap_em :: FullArgCount -> [Var] -> [Var] + zap_em 0 bs = bs + zap_em _ [] = [] + zap_em n (b:bs) | isTyVar b = b : zap_em (n-1) bs + | otherwise = zapLamIdInfo b : zap_em (n-1) bs + + +{- ********************************************************************* +* * + Computing the "arity" of an expression +* * +************************************************************************ + +Note [Definition of arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "arity" of an expression 'e' is n if + applying 'e' to *fewer* than n *value* arguments + converges rapidly + +Or, to put it another way + + there is no work lost in duplicating the partial + application (e x1 .. x(n-1)) + +In the divergent case, no work is lost by duplicating because if the thing +is evaluated once, that's the end of the program. + +Or, to put it another way, in any context C + + C[ (\x1 .. xn. e x1 .. xn) ] + is as efficient as + C[ e ] + +It's all a bit more subtle than it looks: + +Note [One-shot lambdas] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider one-shot lambdas + let x = expensive in \y z -> E +We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. + +Note [Dealing with bottom] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC does some transformations that are technically unsound wrt +bottom, because doing so improves arities... a lot! We describe +them in this Note. + +The flag -fpedantic-bottoms (off by default) restore technically +correct behaviour at the cots of efficiency. + +It's mostly to do with eta-expansion. Consider + + f = \x -> case x of + True -> \s -> e1 + False -> \s -> e2 + +This happens all the time when f :: Bool -> IO () +In this case we do eta-expand, in order to get that \s to the +top, and give f arity 2. + +This isn't really right in the presence of seq. Consider + (f bot) `seq` 1 + +This should diverge! But if we eta-expand, it won't. We ignore this +"problem" (unless -fpedantic-bottoms is on), because being scrupulous +would lose an important transformation for many programs. (See +#5587 for an example.) + +Consider also + f = \x -> error "foo" +Here, arity 1 is fine. But if it looks like this (see #22068) + f = \x -> case x of + True -> error "foo" + False -> \y -> x+y +then we want to get arity 2. Technically, this isn't quite right, because + (f True) `seq` 1 +should diverge, but it'll converge if we eta-expand f. Nevertheless, we +do so; it improves some programs significantly, and increasing convergence +isn't a bad thing. Hence the ABot/ATop in ArityType. + +So these two transformations aren't always the Right Thing, and we +have several tickets reporting unexpected behaviour resulting from +this transformation. So we try to limit it as much as possible: + + (1) Do NOT move a lambda outside a known-bottom case expression + case undefined of { (a,b) -> \y -> e } + This showed up in #5557 + + (2) Do NOT move a lambda outside a case unless + (a) The scrutinee is ok-for-speculation, or + (b) more liberally: the scrutinee is cheap (e.g. a variable), and + -fpedantic-bottoms is not enforced (see #2915 for an example) + +Of course both (1) and (2) are readily defeated by disguising the bottoms. + +There also is an interaction with Note [Combining arity type with demand info], +outlined in Wrinkle (CAD1). + +Note [Newtype arity] +~~~~~~~~~~~~~~~~~~~~ +Non-recursive newtypes are transparent, and should not get in the way. +We do (currently) eta-expand recursive newtypes too. So if we have, say + + newtype T = MkT ([T] -> Int) + +Suppose we have + e = coerce T f +where f has arity 1. Then: etaExpandArity e = 1; +that is, etaExpandArity looks through the coerce. + +When we eta-expand e to arity 1: eta_expand 1 e T +we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + + HOWEVER, note that if you use coerce bogusly you can ge + coerce Int negate + And since negate has arity 2, you might try to eta expand. But you can't + decompose Int to a function type. Hence the final case in eta_expand. + +Note [The state-transformer hack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + f = e +where e has arity n. Then, if we know from the context that f has +a usage type like + t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... +then we can expand the arity to m. This usage type says that +any application (x e1 .. en) will be applied to uniquely to (m-n) more args +Consider f = \x. let y = + in case x of + True -> foo + False -> \(s:RealWorld) -> e +where foo has arity 1. Then we want the state hack to +apply to foo too, so we can eta expand the case. + +Then we expect that if f is applied to one arg, it'll be applied to two +(that's the hack -- we don't really know, and sometimes it's false) +See also Id.isOneShotBndr. + +Note [State hack and bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's a terrible idea to use the state hack on a bottoming function. +Here's what happens (#2861): + + f :: String -> IO T + f = \p. error "..." + +Eta-expand, using the state hack: + + f = \p. (\s. ((error "...") |> g1) s) |> g2 + g1 :: IO T ~ (S -> (S,T)) + g2 :: (S -> (S,T)) ~ IO T + +Extrude the g2 + + f' = \p. \s. ((error "...") |> g1) s + f = f' |> (String -> g2) + +Discard args for bottoming function + + f' = \p. \s. ((error "...") |> g1 |> g3 + g3 :: (S -> (S,T)) ~ (S,T) + +Extrude g1.g3 + + f'' = \p. \s. (error "...") + f' = f'' |> (String -> S -> g1.g3) + +And now we can repeat the whole loop. Aargh! The bug is in applying the +state hack to a function which then swallows the argument. + +This arose in another guise in #3959. Here we had + + catch# (throw exn >> return ()) + +Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. +After inlining (>>) we get + + catch# (\_. throw {IO ()} exn) + +We must *not* eta-expand to + + catch# (\_ _. throw {...} exn) + +because 'catch#' expects to get a (# _,_ #) after applying its argument to +a State#, not another function! + +In short, we use the state hack to allow us to push let inside a lambda, +but not to introduce a new lambda. + + +Note [ArityType] +~~~~~~~~~~~~~~~~ +ArityType can be thought of as an abstraction of an expression. +The ArityType + AT [ (IsCheap, NoOneShotInfo) + , (IsExpensive, OneShotLam) + , (IsCheap, OneShotLam) ] Dunno) + +abstracts an expression like + \x. let in + \y{os}. + \z{os}. blah + +In general we have (AT lams div). Then +* In lams :: [(Cost,OneShotInfo)] + * The Cost flag describes the part of the expression down + to the first (value) lambda. + * The OneShotInfo flag gives the one-shot info on that lambda. + +* If 'div' is dead-ending ('isDeadEndDiv'), then application to + 'length lams' arguments will surely diverge, similar to the situation + with 'DmdType'. + +ArityType is the result of a compositional analysis on expressions, +from which we can decide the real arity of the expression (extracted +with function exprEtaExpandArity). + +We use the following notation: + at ::= \p1..pn.div + div ::= T | x | ⊥ + p ::= (c o) + c ::= X | C -- Expensive or Cheap + o ::= ? | 1 -- NotOneShot or OneShotLam +We may omit the \. if n = 0. +And ⊥ stands for `AT [] botDiv` + +Here is an example demonstrating the notation: + \(C?)(X1)(C1).T +stands for + AT [ (IsCheap,NoOneShotInfo) + , (IsExpensive,OneShotLam) + , (IsCheap,OneShotLam) ] + topDiv + +See the 'Outputable' instance for more information. It's pretty simple. + +How can we use ArityType? Example: + f = \x\y. let v = in + \s(one-shot) \t(one-shot). blah + 'f' has arity type \(C?)(C?)(X1)(C1).T + The one-shot-ness means we can, in effect, push that + 'let' inside the \st, and expand to arity 4 + +Suppose f = \xy. x+y +Then f :: \(C?)(C?).T + f v :: \(C?).T + f :: \(X?).T + +Here is what the fields mean. If an arbitrary expression 'f' has +ArityType 'at', then + + * If @at = AT [o1,..,on] botDiv@ (notation: \o1..on.⊥), then @f x1..xn@ + definitely diverges. Partial applications to fewer than n args may *or + may not* diverge. Ditto exnDiv. + + * If `f` has ArityType `at` we can eta-expand `f` to have (aritTypeOneShots at) + arguments without losing sharing. This function checks that the either + there are no expensive expressions, or the lambdas are one-shots. + + NB 'f' is an arbitrary expression, eg @f = g e1 e2@. This 'f' can have + arity type @AT oss _@, with @length oss > 0@, only if e1 e2 are themselves + cheap. + + * In both cases, @f@, @f x1@, ... @f x1 ... x(n-1)@ are definitely + really functions, or bottom, but *not* casts from a data type, in + at least one case branch. (If it's a function in one case branch but + an unsafe cast from a data type in another, the program is bogus.) + So eta expansion is dynamically ok; see Note [State hack and + bottoming functions], the part about catch# + +Wrinkles + +* Wrinkle [Bottoming functions]: see function 'arityLam'. + We treat bottoming functions as one-shot, because there is no point + in floating work outside the lambda, and it's fine to float it inside. + + For example, this is fine (see test stranal/sigs/BottomFromInnerLambda) + let x = in \y. error (g x y) + ==> \y. let x = in error (g x y) + + Idea: perhaps we could enforce this invariant with + data Arity Type = TopAT [(Cost, OneShotInfo)] | DivAT [Cost] + + +Note [SafeArityType] +~~~~~~~~~~~~~~~~~~~~ +The function safeArityType trims an ArityType to return a "safe" ArityType, +for which we use a type synonym SafeArityType. It is "safe" in the sense +that (arityTypeArity at) really reflects the arity of the expression, whereas +a regular ArityType might have more lambdas in its [ATLamInfo] that the +(cost-free) arity of the expression. + +For example + \x.\y.let v = expensive in \z. blah +has + arityType = AT [C?, C?, X?, C?] Top +But the expression actually has arity 2, not 4, because of the X. +So safeArityType will trim it to (AT [C?, C?] Top), whose [ATLamInfo] +now reflects the (cost-free) arity of the expression + +Why do we ever need an "unsafe" ArityType, such as the example above? +Because its (cost-free) arity may increased by combineWithCallCards +in findRhsArity. See Note [Combining arity type with demand info]. + +Thus the function `arityType` returns a regular "unsafe" ArityType, that +goes deeply into the lambdas (including under IsExpensive). But that is +very local; most ArityTypes are indeed "safe". We use the type synonym +SafeArityType to indicate where we believe the ArityType is safe. +-} + +-- | The analysis lattice of arity analysis. It is isomorphic to +-- +-- @ +-- data ArityType' +-- = AEnd Divergence +-- | ALam OneShotInfo ArityType' +-- @ +-- +-- Which is easier to display the Hasse diagram for: +-- +-- @ +-- ALam OneShotLam at +-- | +-- AEnd topDiv +-- | +-- ALam NoOneShotInfo at +-- | +-- AEnd exnDiv +-- | +-- AEnd botDiv +-- @ +-- +-- where the @at@ fields of @ALam@ are inductively subject to the same order. +-- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@. +-- +-- Why the strange Top element? +-- See Note [Combining case branches: optimistic one-shot-ness] +-- +-- We rely on this lattice structure for fixed-point iteration in +-- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType]. +data ArityType -- See Note [ArityType] + = AT ![ATLamInfo] !Divergence + -- ^ `AT oss div` is an abstraction of the expression, which describes + -- its lambdas, and how much work appears where. + -- See Note [ArityType] for more information + -- + -- If `div` is dead-ending ('isDeadEndDiv'), then application to + -- `length os` arguments will surely diverge, similar to the situation + -- with 'DmdType'. + deriving Eq + +type ATLamInfo = (Cost,OneShotInfo) + -- ^ Info about one lambda in an ArityType + -- See Note [ArityType] + +type SafeArityType = ArityType -- See Note [SafeArityType] + +data Cost = IsCheap | IsExpensive + deriving( Eq ) + +allCosts :: (a -> Cost) -> [a] -> Cost +allCosts f xs = foldr (addCost . f) IsCheap xs + +addCost :: Cost -> Cost -> Cost +addCost IsCheap IsCheap = IsCheap +addCost _ _ = IsExpensive + +-- | This is the BNF of the generated output: +-- +-- @ +-- @ +-- +-- We format +-- @AT [o1,..,on] topDiv@ as @\o1..on.T@ and +-- @AT [o1,..,on] botDiv@ as @\o1..on.⊥@, respectively. +-- More concretely, @AT [NOI,OS,OS] topDiv@ is formatted as @\?11.T@. +-- If the one-shot info is empty, we omit the leading @\.@. +instance Outputable ArityType where + ppr (AT oss div) + | null oss = pp_div div + | otherwise = char '\\' <> hcat (map pp_os oss) <> dot <> pp_div div + where + pp_div Diverges = char '⊥' + pp_div ExnOrDiv = char 'x' + pp_div Dunno = char 'T' + pp_os (IsCheap, OneShotLam) = text "(C1)" + pp_os (IsExpensive, OneShotLam) = text "(X1)" + pp_os (IsCheap, NoOneShotInfo) = text "(C?)" + pp_os (IsExpensive, NoOneShotInfo) = text "(X?)" + +mkBotArityType :: [OneShotInfo] -> ArityType +mkBotArityType oss = AT [(IsCheap,os) | os <- oss] botDiv + +botArityType :: ArityType +botArityType = mkBotArityType [] + +topArityType :: ArityType +topArityType = AT [] topDiv + +-- | The number of value args for the arity type +arityTypeArity :: SafeArityType -> Arity +arityTypeArity (AT lams _) = length lams + +arityTypeOneShots :: SafeArityType -> [OneShotInfo] +-- Returns a list only as long as the arity should be +arityTypeOneShots (AT lams _) = map snd lams + +safeArityType :: ArityType -> SafeArityType +-- ^ Assuming this ArityType is all we know, find the arity of +-- the function, and trim the argument info (and Divergence) +-- to match that arity. See Note [SafeArityType] +safeArityType at@(AT lams _) + = case go 0 IsCheap lams of + Nothing -> at -- No trimming needed + Just ar -> AT (take ar lams) topDiv + where + go :: Arity -> Cost -> [(Cost,OneShotInfo)] -> Maybe Arity + go _ _ [] = Nothing + go ar ch1 ((ch2,os):lams) + = case (ch1 `addCost` ch2, os) of + (IsExpensive, NoOneShotInfo) -> Just ar + (ch, _) -> go (ar+1) ch lams + +infixl 2 `trimArityType` + +trimArityType :: Arity -> ArityType -> ArityType +-- ^ Trim an arity type so that it has at most the given arity. +-- Any excess 'OneShotInfo's are truncated to 'topDiv', even if +-- they end in 'ABot'. See Note [Arity trimming] +trimArityType max_arity at@(AT lams _) + | lams `lengthAtMost` max_arity = at + | otherwise = AT (take max_arity lams) topDiv + +data ArityOpts = ArityOpts + { ao_ped_bot :: !Bool -- See Note [Dealing with bottom] + , ao_dicts_cheap :: !Bool -- See Note [Eta expanding through dictionaries] + } + +-- | The Arity returned is the number of value args the +-- expression can be applied to without doing much work +exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType +-- exprEtaExpandArity is used when eta expanding +-- e ==> \xy -> e x y +-- Nothing if the expression has arity 0 +exprEtaExpandArity opts e + | AT [] _ <- arity_type + = Nothing + | otherwise + = Just arity_type + where + arity_type = safeArityType (arityType (findRhsArityEnv opts False) e) + + +{- ********************************************************************* +* * + findRhsArity +* * +********************************************************************* -} + +findRhsArity :: ArityOpts -> RecFlag -> Id -> CoreExpr + -> (Bool, SafeArityType) +-- This implements the fixpoint loop for arity analysis +-- See Note [Arity analysis] +-- +-- The Bool is True if the returned arity is greater than (exprArity rhs) +-- so the caller should do eta-expansion +-- That Bool is never True for join points, which are never eta-expanded +-- +-- Returns an SafeArityType that is guaranteed trimmed to typeArity of 'bndr' +-- See Note [Arity trimming] + +findRhsArity opts is_rec bndr rhs + | isJoinId bndr + = (False, join_arity_type) + -- False: see Note [Do not eta-expand join points] + -- But do return the correct arity and bottom-ness, because + -- these are used to set the bndr's IdInfo (#15517) + -- Note [Invariants on join points] invariant 2b, in GHC.Core + + | otherwise + = (arity_increased, non_join_arity_type) + -- arity_increased: eta-expand if we'll get more lambdas + -- to the top of the RHS + where + old_arity = exprArity rhs + + init_env :: ArityEnv + init_env = findRhsArityEnv opts (isJoinId bndr) + + -- Non-join-points only + non_join_arity_type = case is_rec of + Recursive -> go 0 botArityType + NonRecursive -> step init_env + arity_increased = arityTypeArity non_join_arity_type > old_arity + + -- Join-points only + -- See Note [Arity for non-recursive join bindings] + -- and Note [Arity for recursive join bindings] + join_arity_type = case is_rec of + Recursive -> go 0 botArityType + NonRecursive -> trimArityType ty_arity (cheapArityType rhs) + + ty_arity = typeArity (idType bndr) + use_call_cards = useSiteCallCards bndr + + step :: ArityEnv -> SafeArityType + step env = trimArityType ty_arity $ + safeArityType $ -- See Note [Arity invariants for bindings], item (3) + combineWithCallCards env (arityType env rhs) use_call_cards + -- trimArityType: see Note [Trim arity inside the loop] + -- combineWithCallCards: take account of the demand on the + -- binder. Perhaps it is always called with 2 args + -- let f = \x. blah in (f 3 4, f 1 9) + -- f's demand-info says how many args it is called with + + -- The fixpoint iteration (go), done for recursive bindings. We + -- always do one step, but usually that produces a result equal + -- to old_arity, and then we stop right away, because old_arity + -- is assumed to be sound. In other words, arities should never + -- decrease. Result: the common case is that there is just one + -- iteration + go :: Int -> SafeArityType -> SafeArityType + go !n cur_at@(AT lams div) + | not (isDeadEndDiv div) -- the "stop right away" case + , length lams <= old_arity = cur_at -- from above + | next_at == cur_at = cur_at + | otherwise + -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity] + = warnPprTrace (debugIsOn && n > 2) + "Exciting arity" + (nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $ + go (n+1) next_at + where + next_at = step (extendSigEnv init_env bndr cur_at) + +combineWithCallCards :: ArityEnv -> ArityType -> [Card] -> ArityType +-- See Note [Combining arity type with demand info] +combineWithCallCards env at@(AT lams div) cards + | null lams = at + | otherwise = AT (zip_lams lams oss) div + where + oss = map card_to_oneshot cards + card_to_oneshot n + | isAtMostOnce n, not (pedanticBottoms env) + -- Take care for -fpedantic-bottoms; + -- see Note [Combining arity type with demand info], Wrinkle (CAD1) + = OneShotLam + | n == C_11 + -- Safe to eta-expand even in the presence of -fpedantic-bottoms + -- see Note [Combining arity type with demand info], Wrinkle (CAD1) + = OneShotLam + | otherwise + = NoOneShotInfo + zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo] + zip_lams lams [] = lams + zip_lams [] oss | isDeadEndDiv div = [] + | otherwise = [ (IsExpensive,OneShotLam) + | _ <- takeWhile isOneShotInfo oss] + zip_lams ((ch,os1):lams) (os2:oss) + = (ch, os1 `bestOneShot` os2) : zip_lams lams oss + +useSiteCallCards :: Id -> [Card] +useSiteCallCards bndr + = call_arity_one_shots `zip_cards` dmd_one_shots + where + call_arity_one_shots :: [Card] + call_arity_one_shots + | call_arity == 0 = [] + | otherwise = C_0N : replicate (call_arity-1) C_01 + -- Call Arity analysis says /however often the function is called/, it is + -- always applied to this many arguments. + -- The first C_0N is because of the "however often it is called" part. + -- Thus if Call Arity says "always applied to 3 args" then the one-shot info + -- we get is [C_0N, C_01, C_01] + call_arity = idCallArity bndr + + dmd_one_shots :: [Card] + -- If the demand info is C(x,C(1,C(1,.))) then we know that an + -- application to one arg is also an application to three + dmd_one_shots = case idDemandInfo bndr of + AbsDmd -> [] -- There is no use in eta expanding + BotDmd -> [] -- when the binding could be dropped instead + _ :* sd -> callCards sd + + -- Take the *longer* list + zip_cards (n1:ns1) (n2:ns2) = (n1 `glbCard` n2) : zip_cards ns1 ns2 + zip_cards [] ns2 = ns2 + zip_cards ns1 [] = ns1 + +{- Note [Arity analysis] +~~~~~~~~~~~~~~~~~~~~~~~~ +The motivating example for arity analysis is this: + + f = \x. let g = f (x+1) + in \y. ...g... + +What arity does f have? Really it should have arity 2, but a naive +look at the RHS won't see that. You need a fixpoint analysis which +says it has arity "infinity" the first time round. + +This example happens a lot; it first showed up in Andy Gill's thesis, +fifteen years ago! It also shows up in the code for 'rnf' on lists +in #4138. + +We do the necessary, quite simple fixed-point iteration in 'findRhsArity', +which assumes for a single binding 'ABot' on the first run and iterates +until it finds a stable arity type. Two wrinkles + +* We often have to ask (see the Case or Let case of 'arityType') whether some + expression is cheap. In the case of an application, that depends on the arity + of the application head! That's why we have our own version of 'exprIsCheap', + 'myExprIsCheap', that will integrate the optimistic arity types we have on + f and g into the cheapness check. + +* Consider this (#18793) + + go = \ds. case ds of + [] -> id + (x:ys) -> let acc = go ys in + case blah of + True -> acc + False -> \ x1 -> acc (negate x1) + + We must propagate go's optimistically large arity to @acc@, so that the + tail call to @acc@ in the True branch has sufficient arity. This is done + by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case + of 'arityType'. + +Note [Exciting arity] +~~~~~~~~~~~~~~~~~~~~~ +The fixed-point iteration in 'findRhsArity' stabilises very quickly in almost +all cases. To get notified of cases where we need an usual number of iterations, +we emit a warning in debug mode, so that we can investigate and make sure that +we really can't do better. It's a gross hack, but catches real bugs (#18870). + +Now, which number is "unusual"? We pick n > 2. Here's a pretty common and +expected example that takes two iterations and would ruin the specificity +of the warning (from T18937): + + f :: [Int] -> Int -> Int + f [] = id + f (x:xs) = let y = sum [0..x] + in \z -> f xs (y + z) + +Fixed-point iteration starts with arity type ⊥ for f. After the first +iteration, we get arity type \??.T, e.g. arity 2, because we unconditionally +'floatIn' the let-binding (see its bottom case). After the second iteration, +we get arity type \?.T, e.g. arity 1, because now we are no longer allowed +to floatIn the non-cheap let-binding. Which is all perfectly benign, but +means we do two iterations (well, actually 3 'step's to detect we are stable) +and don't want to emit the warning. + +Note [Trim arity inside the loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's an example (from gadt/nbe.hs) which caused trouble. + data Exp g t where + Lam :: Ty a -> Exp (g,a) b -> Exp g (a->b) + + eval :: Exp g t -> g -> t + eval (Lam _ e) g = \a -> eval e (g,a) + +The danger is that we get arity 3 from analysing this; and the +next time arity 4, and so on for ever. Solution: use trimArityType +on each iteration. + +Note [Combining arity type with demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let f = \x. let y = in \p \q{os}. blah + in ...(f a b)...(f c d)... + +* From the RHS we get an ArityType like + AT [ (IsCheap,?), (IsExpensive,?), (IsCheap,OneShotLam) ] Dunno + where "?" means NoOneShotInfo + +* From the body, the demand analyser (or Call Arity) will tell us + that the function is always applied to at least two arguments. + +Combining these two pieces of info, we can get the final ArityType + AT [ (IsCheap,?), (IsExpensive,OneShotLam), (IsCheap,OneShotLam) ] Dunno +result: arity=3, which is better than we could do from either +source alone. + +The "combining" part is done by combineWithCallCards. It +uses info from both Call Arity and demand analysis. + +We may have /more/ call demands from the calls than we have lambdas +in the binding. E.g. + let f1 = \x. g x x in ...(f1 p q r)... + -- Demand on f1 is C(x,C(1,C(1,L))) + + let f2 = \y. error y in ...(f2 p q r)... + -- Demand on f2 is C(x,C(1,C(1,L))) + +In both these cases we can eta expand f1 and f2 to arity 3. +But /only/ for called-once demands. Suppose we had + let f1 = \y. g x x in ...let h = f1 p q in ...(h r1)...(h r2)... + +Now we don't want to eta-expand f1 to have 3 args; only two. +Nor, in the case of f2, do we want to push that error call under +a lambda. Hence the takeWhile in combineWithDemandDoneShots. + +Wrinkles: + +(CAD1) #24296 exposed a subtle interaction with -fpedantic-bottoms + (See Note [Dealing with bottom]). Consider + + let f = \x y. error "blah" in + f 2 1 `seq` Just (f 3 2 1) + -- Demand on f is C(x,C(1,C(M,L))) + + Usually, it is OK to consider a lambda that is called *at most* once (so call + cardinality C_01, abbreviated M) a one-shot lambda and eta-expand over it. + But with -fpedantic-bottoms that is no longer true: If we were to eta-expand + f to arity 3, we'd discard the error raised when evaluating `f 2 1`. + Hence in the presence of -fpedantic-bottoms, we must have C_11 for + eta-expansion. + +Note [Do not eta-expand join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Similarly to CPR (see Note [Don't w/w join points for CPR] in +GHC.Core.Opt.WorkWrap), a join point stands well to gain from its outer binding's +eta-expansion, and eta-expanding a join point is fraught with issues like how to +deal with a cast: + + let join $j1 :: IO () + $j1 = ... + $j2 :: Int -> IO () + $j2 n = if n > 0 then $j1 + else ... + + => + + let join $j1 :: IO () + $j1 = (\eta -> ...) + `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) + ~ IO () + $j2 :: Int -> IO () + $j2 n = (\eta -> if n > 0 then $j1 + else ...) + `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) + ~ IO () + +The cast here can't be pushed inside the lambda (since it's not casting to a +function type), so the lambda has to stay, but it can't because it contains a +reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather +than try and detect this situation (and whatever other situations crop up!), we +don't bother; again, any surrounding eta-expansion will improve these join +points anyway, since an outer cast can *always* be pushed inside. By the time +CorePrep comes around, the code is very likely to look more like this: + + let join $j1 :: State# RealWorld -> (# State# RealWorld, ()) + $j1 = (...) eta + $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) + $j2 = if n > 0 then $j1 + else (...) eta + +Note [Arity for recursive join bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = joinrec j 0 = \ a b c -> (a,x,b) + j n = j (n-1) + in j 20 + +Obviously `f` should get arity 4. But it's a bit tricky: + +1. Remember, we don't eta-expand join points; see + Note [Do not eta-expand join points]. + +2. But even though we aren't going to eta-expand it, we still want `j` to get + idArity=4, via the findRhsArity fixpoint. Then when we are doing findRhsArity + for `f`, we'll call arityType on f's RHS: + - At the letrec-binding for `j` we'll whiz up an arity-4 ArityType + for `j` (See Note [arityType for non-recursive let-bindings] + in GHC.Core.Opt.Arity)b + - At the occurrence (j 20) that arity-4 ArityType will leave an arity-3 + result. + +3. All this, even though j's /join-arity/ (stored in the JoinId) is 1. + This is is the Main Reason that we want the idArity to sometimes be + larger than the join-arity c.f. Note [Invariants on join points] item 2b + in GHC.Core. + +4. Be very careful of things like this (#21755): + g x = let j 0 = \y -> (x,y) + j n = expensive n `seq` j (n-1) + in j x + Here we do /not/ want eta-expand `g`, lest we duplicate all those + (expensive n) calls. + + But it's fine: the findRhsArity fixpoint calculation will compute arity-1 + for `j` (not arity 2); and that's just what we want. But we do need that + fixpoint. + + Historical note: an earlier version of GHC did a hack in which we gave + join points an ArityType of ABot, but that did not work with this #21755 + case. + +5. arityType does not usually expect to encounter free join points; + see GHC.Core.Opt.Arity Note [No free join points in arityType]. + But consider + f x = join j1 y = .... in + joinrec j2 z = ...j1 y... in + j2 v + + When doing findRhsArity on `j2` we'll encounter the free `j1`. + But that is fine, because we aren't going to eta-expand `j2`; + we just want to know its arity. So we have a flag am_no_eta, + switched on when doing findRhsArity on a join point RHS. If + the flag is on, we allow free join points, but not otherwise. + + +Note [Arity for non-recursive join bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Arity for recursive join bindings] deals with recursive join +bindings. But what about /non-recursive/ones? If we just call +findRhsArity, it will call arityType. And that can be expensive when +we have deeply nested join points: + join j1 x1 = join j2 x2 = join j3 x3 = blah3 + in blah2 + in blah1 +(e.g. test T18698b). + +So we call cheapArityType instead. It's good enough for practical +purposes. + +(Side note: maybe we should use cheapArity for the RHS of let bindings +in the main arityType function.) +-} + + +{- ********************************************************************* +* * + arityType +* * +********************************************************************* -} + +arityLam :: Id -> ArityType -> ArityType +arityLam id (AT oss div) + = AT ((IsCheap, one_shot) : oss) div + where + one_shot | isDeadEndDiv div = OneShotLam + | otherwise = idStateHackOneShotInfo id + -- If the body diverges, treat it as one-shot: no point + -- in floating out, and no penalty for floating in + -- See Wrinkle [Bottoming functions] in Note [ArityType] + +floatIn :: Cost -> ArityType -> ArityType +-- We have something like (let x = E in b), +-- where b has the given arity type. +-- NB: be as lazy as possible in the Cost-of-E argument; +-- we can often get away without ever looking at it +-- See Note [Care with nested expressions] +floatIn ch at@(AT lams div) + = case lams of + [] -> at + (IsExpensive,_):_ -> at + (_,os):lams -> AT ((ch,os):lams) div + +addWork :: ArityType -> ArityType +-- Add work to the outermost level of the arity type +addWork at@(AT lams div) + = case lams of + [] -> at + lam:lams' -> AT (add_work lam : lams') div + +add_work :: ATLamInfo -> ATLamInfo +add_work (_,os) = (IsExpensive,os) + +arityApp :: ArityType -> Cost -> ArityType +-- Processing (fun arg) where at is the ArityType of fun, +-- Knock off an argument and behave like 'let' +arityApp (AT ((ch1,_):oss) div) ch2 = floatIn (ch1 `addCost` ch2) (AT oss div) +arityApp at _ = at + +-- | Least upper bound in the 'ArityType' lattice. +-- See the haddocks on 'ArityType' for the lattice. +-- +-- Used for branches of a @case@. +andArityType :: ArityEnv -> ArityType -> ArityType -> ArityType +andArityType env (AT (lam1:lams1) div1) (AT (lam2:lams2) div2) + | AT lams' div' <- andArityType env (AT lams1 div1) (AT lams2 div2) + = AT ((lam1 `and_lam` lam2) : lams') div' + where + (ch1,os1) `and_lam` (ch2,os2) + = ( ch1 `addCost` ch2, os1 `bestOneShot` os2) + -- bestOneShot: see Note [Combining case branches: optimistic one-shot-ness] + +andArityType env (AT [] div1) at2 = andWithTail env div1 at2 +andArityType env at1 (AT [] div2) = andWithTail env div2 at1 + +andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType +andWithTail env div1 at2@(AT lams2 _) + | isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e } + = at2 -- See Note + | pedanticBottoms env -- [Combining case branches: andWithTail] + = AT [] topDiv + + | otherwise -- case x of { T -> plusInt ; F -> \y.e } + = AT (map add_work lams2) topDiv -- We know div1 = topDiv + -- See Note [Combining case branches: andWithTail] + +{- Note [Combining case branches: optimistic one-shot-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When combining the ArityTypes for two case branches (with +andArityType) and both ArityTypes have ATLamInfo, then we just combine +their expensive-ness and one-shot info. The tricky point is when we +have + + case x of True -> \x{one-shot). blah1 + Fale -> \y. blah2 + +Since one-shot-ness is about the /consumer/ not the /producer/, we +optimistically assume that if either branch is one-shot, we combine +the best of the two branches, on the (slightly dodgy) basis that if we +know one branch is one-shot, then they all must be. Surprisingly, +this means that the one-shot arity type is effectively the top element +of the lattice. + +Hence the call to `bestOneShot` in `andArityType`. + +Here's an example: + go = \x. let z = go e0 + go2 = \x. case x of + True -> z + False -> \s(one-shot). e1 + in go2 x + +We *really* want to respect the one-shot annotation provided by the +user and eta-expand go and go2. In the first fixpoint iteration of +'go' we'll bind 'go' to botArityType (written \.⊥, see Note +[ArityType]). So 'z' will get arityType \.⊥; so we end up combining +the True and False branches: + + \.⊥ `andArityType` \1.T + +That gives \1.T (see Note [Combining case branches: andWithTail], +first bullet). So 'go2' gets an arityType of \(C?)(C1).T, which is +what we want. + +Note [Care with nested expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + arityType (Just ) +We will take + arityType Just = AT [(IsCheap,os)] topDiv +and then do + arityApp (AT [(IsCheap os)] topDiv) (exprCost ) +The result will be AT [] topDiv. It doesn't matter what +is! The same is true of + arityType (let x = in ) +where the cost of doesn't matter unless has a useful +arityType. + +TL;DR in `floatIn`, do not to look at the Cost argument until you have to. + +I found this when looking at #24471, although I don't think it was really +the main culprit. + +Note [Combining case branches: andWithTail] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When combining the ArityTypes for two case branches (with andArityType) +and one side or the other has run out of ATLamInfo; then we get +into `andWithTail`. + +* If one branch is guaranteed bottom (isDeadEndDiv), we just take + the other. Consider case x of + True -> \x. error "urk" + False -> \xy. error "urk2" + + Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely + diverge". So we need \??.⊥ for the whole thing, the /max/ of both + arities. + +* Otherwise, if pedantic-bottoms is on, we just have to return + AT [] topDiv. E.g. if we have + f x z = case x of True -> \y. blah + False -> z + then we can't eta-expand, because that would change the behaviour + of (f False bottom(). + +* But if pedantic-bottoms is not on, we allow ourselves to push + `z` under a lambda (much as we allow ourselves to put the `case x` + under a lambda). However we know nothing about the expensiveness + or one-shot-ness of `z`, so we'd better assume it looks like + (Expensive, NoOneShotInfo) all the way. Remembering + Note [Combining case branches: optimistic one-shot-ness], + we just add work to ever ATLamInfo, keeping the one-shot-ness. + +Note [Eta expanding through CallStacks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Just as it's good to eta-expand through dictionaries, so it is good to +do so through CallStacks. #20103 is a case in point, where we got + foo :: HasCallStack => Int -> Int + foo = \(d::CallStack). let d2 = pushCallStack blah d in + \(x:Int). blah + +We really want to eta-expand this! #20103 is quite convincing! +We do this regardless of -fdicts-cheap; it's not really a dictionary. + +We also want to check both for (IP blah CallStack) and for CallStack itself. +We might have either + d :: IP blah CallStack -- Or HasCallStack + d = (cs-expr :: CallStack) |> (nt-ax :: CallStack ~ IP blah CallStack) +or just + cs :: CallStack + cs = cs-expr + +Test T20103 is an example of the latter. + +Note [Eta expanding through dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the experimental -fdicts-cheap flag is on, we eta-expand through +dictionary bindings. This improves arities. Thereby, it also +means that full laziness is less prone to floating out the +application of a function to its dictionary arguments, which +can thereby lose opportunities for fusion. Example: + foo :: Ord a => a -> ... + foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... + -- So foo has arity 1 + + f = \x. foo dInt $ bar x + +The (foo DInt) is floated out, and makes ineffective a RULE + foo (bar x) = ... + +One could go further and make exprIsCheap reply True to any +dictionary-typed expression, but that's more work. +-} + +--------------------------- + +data ArityEnv + = AE { am_opts :: !ArityOpts + + , am_sigs :: !(IdEnv SafeArityType) + -- NB `SafeArityType` so we can use this in myIsCheapApp + -- See Note [Arity analysis] for details about fixed-point iteration. + + , am_free_joins :: !Bool -- True <=> free join points allowed + -- Used /only/ to support assertion checks + } + +instance Outputable ArityEnv where + ppr (AE { am_sigs = sigs, am_free_joins = free_joins }) + = text "AE" <+> braces (sep [ text "free joins:" <+> ppr free_joins + , text "sigs:" <+> ppr sigs ]) + +-- | The @ArityEnv@ used by 'findRhsArity'. +findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv +findRhsArityEnv opts free_joins + = AE { am_opts = opts + , am_free_joins = free_joins + , am_sigs = emptyVarEnv } + +freeJoinsOK :: ArityEnv -> Bool +freeJoinsOK (AE { am_free_joins = free_joins }) = free_joins + +-- First some internal functions in snake_case for deleting in certain VarEnvs +-- of the ArityType. Don't call these; call delInScope* instead! + +modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv +modifySigEnv f env@(AE { am_sigs = sigs }) = env { am_sigs = f sigs } +{-# INLINE modifySigEnv #-} + +del_sig_env :: Id -> ArityEnv -> ArityEnv -- internal! +del_sig_env id = modifySigEnv (\sigs -> delVarEnv sigs id) +{-# INLINE del_sig_env #-} + +del_sig_env_list :: [Id] -> ArityEnv -> ArityEnv -- internal! +del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids) +{-# INLINE del_sig_env_list #-} + +-- end of internal deletion functions + +extendSigEnv :: ArityEnv -> Id -> SafeArityType -> ArityEnv +extendSigEnv env id ar_ty + = modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) $ + env + +delInScope :: ArityEnv -> Id -> ArityEnv +delInScope env id = del_sig_env id env + +delInScopeList :: ArityEnv -> [Id] -> ArityEnv +delInScopeList env ids = del_sig_env_list ids env + +lookupSigEnv :: ArityEnv -> Id -> Maybe SafeArityType +lookupSigEnv (AE { am_sigs = sigs }) id = lookupVarEnv sigs id + +-- | Whether the analysis should be pedantic about bottoms. +-- 'exprBotStrictness_maybe' always is. +pedanticBottoms :: ArityEnv -> Bool +pedanticBottoms (AE { am_opts = ArityOpts{ ao_ped_bot = ped_bot }}) = ped_bot + +exprCost :: ArityEnv -> CoreExpr -> Maybe Type -> Cost +exprCost env e mb_ty + | myExprIsCheap env e mb_ty = IsCheap + | otherwise = IsExpensive + +-- | A version of 'exprIsCheap' that considers results from arity analysis +-- and optionally the expression's type. +-- Under 'exprBotStrictness_maybe', no expressions are cheap. +myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool +myExprIsCheap (AE { am_opts = opts, am_sigs = sigs }) e mb_ty + = cheap_dict || cheap_fun e + where + cheap_dict = case mb_ty of + Nothing -> False + Just ty -> (ao_dicts_cheap opts && isDictTy ty) + || isCallStackPredTy ty || isCallStackTy ty + -- See Note [Eta expanding through dictionaries] + -- See Note [Eta expanding through CallStacks] + + cheap_fun e = exprIsCheapX (myIsCheapApp sigs) False e + +-- | A version of 'isCheapApp' that considers results from arity analysis. +-- See Note [Arity analysis] for what's in the signature environment and why +-- it's important. +myIsCheapApp :: IdEnv SafeArityType -> CheapAppFun +myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of + + -- Nothing means not a local function, fall back to regular + -- 'GHC.Core.Utils.isCheapApp' + Nothing -> isCheapApp fn n_val_args + + -- `Just at` means local function with `at` as current SafeArityType. + -- NB the SafeArityType bit: that means we can ignore the cost flags + -- in 'lams', and just consider the length + -- Roughly approximate what 'isCheapApp' is doing. + Just (AT lams div) + | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils + | n_val_args == 0 -> True -- Essentially + | n_val_args < length lams -> True -- isWorkFreeApp + | otherwise -> False + +---------------- +arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType +-- Precondition: all the free join points of the expression +-- are bound by the ArityEnv +-- See Note [No free join points in arityType] +-- +-- Returns ArityType, not SafeArityType. The caller must do +-- trimArityType if necessary. +arityType env (Var v) + | Just at <- lookupSigEnv env v -- Local binding + = at + | otherwise + = assertPpr (freeJoinsOK env || not (isJoinId v)) (ppr v) $ + -- All join-point should be in the ae_sigs + -- See Note [No free join points in arityType] + idArityType v + +arityType env (Cast e _) + = arityType env e + + -- Lambdas; increase arity +arityType env (Lam x e) + | isId x = arityLam x (arityType env' e) + | otherwise = arityType env' e + where + env' = delInScope env x + + -- Applications; decrease arity, except for types +arityType env (App fun (Type _)) + = arityType env fun +arityType env (App fun arg ) + = arityApp fun_at arg_cost + where + fun_at = arityType env fun + arg_cost = exprCost env arg Nothing + + -- Case/Let; keep arity if either the expression is cheap + -- or it's a 1-shot lambda + -- The former is not really right for Haskell + -- f x = case x of { (a,b) -> \y. e } + -- ===> + -- f x y = case x of { (a,b) -> e } + -- The difference is observable using 'seq' + -- +arityType env (Case scrut bndr _ altList) + | not $ exprIsDeadEnd scrut, Just alts <- nonEmpty altList + = let env' = delInScope env bndr + arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs + alts_type = foldr1 (andArityType env) (NE.map arity_type_alt alts) + in if + | not (pedanticBottoms env) -- See (2) in Note [Dealing with bottom] + , myExprIsCheap env scrut (Just (idType bndr)) + -> alts_type + + | exprOkForSpeculation scrut + -> alts_type + + | otherwise -- In the remaining cases we may not push + -> addWork alts_type -- evaluation of the scrutinee in + | otherwise = botArityType -- Do not eta expand. See (1) in Note [Dealing with bottom] + +arityType env (Let (NonRec b rhs) e) + = -- See Note [arityType for non-recursive let-bindings] + floatIn rhs_cost (arityType env' e) + where + rhs_cost = exprCost env rhs (Just (idType b)) + env' = extendSigEnv env b (safeArityType (arityType env rhs)) + +arityType env (Let (Rec prs) e) + = -- See Note [arityType for recursive let-bindings] + floatIn (allCosts bind_cost prs) (arityType env' e) + where + bind_cost (b,e) = exprCost env' e (Just (idType b)) + env' = foldl extend_rec env prs + extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv + extend_rec env (b,_) = extendSigEnv env b $ + idArityType b + -- See Note [arityType for recursive let-bindings] + +arityType env (Tick t e) + | not (tickishIsCode t) = arityType env e + +arityType _ _ = topArityType + +-------------------- +idArityType :: Id -> ArityType +idArityType v + | strict_sig <- idDmdSig v + , (ds, div) <- splitDmdSig strict_sig + , isDeadEndDiv div + = AT (takeList ds one_shots) div + + | isEmptyTy id_ty + = botArityType + + | otherwise + = AT (take (idArity v) one_shots) topDiv + where + id_ty = idType v + + one_shots :: [(Cost,OneShotInfo)] -- One-shot-ness derived from the type + one_shots = repeat IsCheap `zip` typeOneShots id_ty + +-------------------- +cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType +-- A fast and cheap version of arityType. +-- Returns an ArityType with IsCheap everywhere +-- c.f. GHC.Core.Utils.exprIsDeadEnd +-- +-- /Can/ encounter a free join-point Id; e.g. via the call +-- in exprBotStrictness_maybe, which is called in lots +-- of places +-- +-- Returns ArityType, not SafeArityType. The caller must do +-- trimArityType if necessary. +cheapArityType e = go e + where + go (Var v) = idArityType v + go (Cast e _) = go e + go (Lam x e) | isId x = arityLam x (go e) + | otherwise = go e + go (App e a) | isTypeArg a = go e + | otherwise = arity_app a (go e) + + go (Tick t e) | not (tickishIsCode t) = go e + + -- Null alts: see Note [Empty case alternatives] in GHC.Core + go (Case _ _ _ alts) | null alts = botArityType + + -- Give up on let, case. In particular, unlike arityType, + -- we make no attempt to look inside let's. + go _ = topArityType + + -- Specialised version of arityApp; all costs in ArityType are IsCheap + -- See Note [exprArity for applications] + -- NB: (1) coercions count as a value argument + -- (2) we use the super-cheap exprIsTrivial rather than the + -- more complicated and expensive exprIsCheap + arity_app _ at@(AT [] _) = at + arity_app arg at@(AT ((cost,_):lams) div) + | assertPpr (cost == IsCheap) (ppr at $$ ppr arg) $ + isDeadEndDiv div = AT lams div + | exprIsTrivial arg = AT lams topDiv + | otherwise = topArityType + +--------------- +exprArity :: CoreExpr -> Arity +-- ^ An approximate, even faster, version of 'cheapArityType' +-- Roughly exprArity e = arityTypeArity (cheapArityType e) +-- But it's a bit less clever about bottoms +-- +-- We do /not/ guarantee that exprArity e <= typeArity e +-- You may need to do arity trimming after calling exprArity +-- See Note [Arity trimming] +-- Reason: if we do arity trimming here we have take exprType +-- and that can be expensive if there is a large cast +exprArity e = go e + where + go (Var v) = idArity v + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e _) = go e + go (App e (Type _)) = go e + go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 + -- See Note [exprArity for applications] + -- NB: coercions count as a value argument + + go _ = 0 + +--------------- +exprIsDeadEnd :: CoreExpr -> Bool +-- See Note [Bottoming expressions] +-- This function is, in effect, just a specialised (and hence cheap) +-- version of cheapArityType: +-- exprIsDeadEnd e = case cheapArityType e of +-- AT lams div -> null lams && isDeadEndDiv div +-- See also exprBotStrictness_maybe, which uses cheapArityType +exprIsDeadEnd e + = go 0 e + where + go :: Arity -> CoreExpr -> Bool + -- (go n e) = True <=> expr applied to n value args is bottom + go _ (Lit {}) = False + go _ (Type {}) = False + go _ (Coercion {}) = False + go n (App e a) | isTypeArg a = go n e + | otherwise = go (n+1) e + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (Let _ e) = go n e + go n (Lam v e) | isTyVar v = go n e + | otherwise = False + + go _ (Case _ _ _ alts) = null alts + -- See Note [Empty case alternatives] in GHC.Core + + go n (Var v) | isDeadEndAppSig (idDmdSig v) n = True + | isEmptyTy (idType v) = True + | otherwise = False + +{- Note [Bottoming expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A bottoming expression is guaranteed to diverge, or raise an +exception. We can test for it in two different ways, and exprIsDeadEnd +checks for both of these situations: + +* Visibly-bottom computations. For example + (error Int "Hello") + is visibly bottom. The strictness analyser also finds out if + a function diverges or raises an exception, and puts that info + in its strictness signature. + +* Empty types. If a type is empty, its only inhabitant is bottom. + For example: + data T + f :: T -> Bool + f = \(x:t). case x of Bool {} + Since T has no data constructors, the case alternatives are of course + empty. However note that 'x' is not bound to a visibly-bottom value; + it's the *type* that tells us it's going to diverge. + +A GADT may also be empty even though it has constructors: + data T a where + T1 :: a -> T Bool + T2 :: T Int + ...(case (x::T Char) of {})... +Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), +which is likewise uninhabited. + +Note [No free join points in arityType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we call arityType on this expression (EX1) + \x . case x of True -> \y. e + False -> $j 3 +where $j is a join point. It really makes no sense to talk of the arity +of this expression, because it has a free join point. In particular, we +can't eta-expand the expression because we'd have do the same thing to the +binding of $j, and we can't see that binding. + +If we had (EX2) + \x. join $j y = blah + case x of True -> \y. e + False -> $j 3 +then it would make perfect sense: we can determine $j's ArityType, and +propagate it to the usage site as usual. + +But how can we get (EX1)? It doesn't make much sense, because $j can't +be a join point under the \x anyway. So we make it a precondition of +arityType that the argument has no free join-point Ids. (This is checked +with an assert in the Var case of arityType.) + +Wrinkles + +* We /do/ allow free join point when doing findRhsArity for join-point + right-hand sides. See Note [Arity for recursive join bindings] + point (5) in GHC.Core.Opt.Simplify.Utils. + +* The invariant (no free join point in arityType) risks being + invalidated by one very narrow special case: runRW# + + join $j y = blah + runRW# (\s. case x of True -> \y. e + False -> $j x) + + We have special magic in OccurAnal, and Simplify to allow continuations to + move into the body of a runRW# call. + + So we are careful never to attempt to eta-expand the (\s.blah) in the + argument to runRW#, at least not when there is a literal lambda there, + so that OccurAnal has seen it and allowed join points bound outside. + See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration. + +Note [arityType for non-recursive let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For non-recursive let-bindings, we just get the arityType of the RHS, +and extend the environment. That works nicely for things like this +(#18793): + go = \ ds. case ds_a2CF of { + [] -> id + : y ys -> case y of { GHC.Types.I# x -> + let acc = go ys in + case x ># 42# of { + __DEFAULT -> acc + 1# -> \x1. acc (negate x2) + +Here we want to get a good arity for `acc`, based on the ArityType +of `go`. + +All this is particularly important for join points. Consider this (#18328) + + f x = join j y = case y of + True -> \a. blah + False -> \b. blah + in case x of + A -> j True + B -> \c. blah + C -> j False + +and suppose the join point is too big to inline. Now, what is the +arity of f? If we inlined the join point, we'd definitely say "arity +2" because we are prepared to push case-scrutinisation inside a +lambda. It's important that we extend the envt with j's ArityType, so +that we can use that information in the A/C branch of the case. + +Note [arityType for recursive let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For /recursive/ bindings it's more difficult, to call arityType +(as we do in Note [arityType for non-recursive let-bindings]) +because we don't have an ArityType to put in the envt for the +recursively bound Ids. So for we satisfy ourselves with whizzing up +up an ArityType from the idArity of the function, via idArityType. + +That is nearly equivalent to deleting the binder from the envt, at +which point we'll call idArityType at the occurrences. But doing it +here means + + (a) we only call idArityType once, no matter how many + occurrences, and + + (b) we can check (in the arityType (Var v) case) that + we don't mention free join-point Ids. See + Note [No free join points in arityType]. + +But see Note [Arity for recursive join bindings] in +GHC.Core.Opt.Simplify.Utils for dark corners. +-} + +{- +%************************************************************************ +%* * + The main eta-expander +%* * +%************************************************************************ + +We go for: + f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym + (n >= 0) + +where (in both cases) + + * The xi can include type variables + + * The yi are all value variables + + * N is a NORMAL FORM (i.e. no redexes anywhere) + wanting a suitable number of extra args. + +The biggest reason for doing this is for cases like + + f = \x -> case x of + True -> \y -> e1 + False -> \y -> e2 + +Here we want to get the lambdas together. A good example is the nofib +program fibheaps, which gets 25% more allocation if you don't do this +eta-expansion. + +We may have to sandwich some coerces between the lambdas +to make the types work. exprEtaExpandArity looks through coerces +when computing arity; and etaExpand adds the coerces as necessary when +actually computing the expansion. + +Note [No crap in eta-expanded code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The eta expander is careful not to introduce "crap". In particular, +given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it +returns a CoreExpr satisfying the same invariant. See Note [Eta +expansion and the CorePrep invariants] in CorePrep. + +This means the eta-expander has to do a bit of on-the-fly +simplification but it's not too hard. The alternative, of relying on +a subsequent clean-up phase of the Simplifier to de-crapify the result, +means you can't really use it in CorePrep, which is painful. + +Note [Eta expansion for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The no-crap rule is very tiresome to guarantee when +we have join points. Consider eta-expanding + let j :: Int -> Int -> Bool + j x = e + in b + +The simple way is + \(y::Int). (let j x = e in b) y + +The no-crap way is + \(y::Int). let j' :: Int -> Bool + j' x = e y + in b[j'/j] y +where I have written b[j'/j] to stress that j's type has +changed. Note that (of course!) we have to push the application +inside the RHS of the join as well as into the body. AND if j +has an unfolding we have to push it into there too. AND j might +be recursive... + +So for now I'm abandoning the no-crap rule in this case, conscious that this +causes the ugly Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]. + +(Moreover, I think that casts can make the no-crap rule fail too.) + +Note [Eta expansion and SCCs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that SCCs are not treated specially by etaExpand. If we have + etaExpand 2 (\x -> scc "foo" e) + = (\xy -> (scc "foo" e) y) +So the costs of evaluating 'e' (not 'e y') are attributed to "foo" + +Note [Eta expansion and source notes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CorePrep puts floatable ticks outside of value applications, but not +type applications. As a result we might be trying to eta-expand an +expression like + + (src<...> v) @a + +which we want to lead to code like + + \x -> src<...> v @a x + +This means that we need to look through type applications and be ready +to re-add floats on the top. + +Note [Eta expansion with ArityType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The etaExpandAT function takes an ArityType (not just an Arity) to +guide eta-expansion. Why? Because we want to preserve one-shot info. +Consider + foo = \x. case x of + True -> (\s{os}. blah) |> co + False -> wubble +We'll get an ArityType for foo of \?1.T. + +Then we want to eta-expand to + foo = (\x. \eta{os}. (case x of ...as before...) eta) |> some_co + +That 'eta' binder is fresh, and we really want it to have the +one-shot flag from the inner \s{os}. By expanding with the +ArityType gotten from analysing the RHS, we achieve this neatly. + +This makes a big difference to the one-shot monad trick; +see Note [The one-shot state monad trick] in GHC.Utils.Monad. +-} + +-- | @etaExpand n e@ returns an expression with +-- the same meaning as @e@, but with arity @n@. +-- +-- Given: +-- +-- > e' = etaExpand n e +-- +-- We should have that: +-- +-- > ty = exprType e = exprType e' + +etaExpand :: Arity -> CoreExpr -> CoreExpr +etaExpand n orig_expr + = eta_expand in_scope (replicate n NoOneShotInfo) orig_expr + where + in_scope = {-#SCC "eta_expand:in-scopeX" #-} + mkInScopeSet (exprFreeVars orig_expr) + +etaExpandAT :: InScopeSet -> SafeArityType -> CoreExpr -> CoreExpr +-- See Note [Eta expansion with ArityType] +-- +-- We pass in the InScopeSet from the simplifier to avoid recomputing +-- it here, which can be jolly expensive if the casts are big +-- In #18223 it took 10% of compile time just to do the exprFreeVars! +etaExpandAT in_scope at orig_expr + = eta_expand in_scope (arityTypeOneShots at) orig_expr + +-- etaExpand arity e = res +-- Then 'res' has at least 'arity' lambdas at the top +-- possibly with a cast wrapped around the outside +-- See Note [Eta expansion with ArityType] +-- +-- etaExpand deals with for-alls. For example: +-- etaExpand 1 E +-- where E :: forall a. a -> a +-- would return +-- (/\b. \y::a -> E b y) + +eta_expand :: InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr +eta_expand in_scope one_shots (Cast expr co) + = mkCast (eta_expand in_scope one_shots expr) co + -- This mkCast is important, because eta_expand might return an + -- expression with a cast at the outside; and tryCastWorkerWrapper + -- asssumes that we don't have nested casts. Makes a difference + -- in compile-time for T18223 + +eta_expand in_scope one_shots orig_expr + = go in_scope one_shots [] orig_expr + where + -- Strip off existing lambdas and casts before handing off to mkEtaWW + -- This is mainly to avoid spending time cloning binders and substituting + -- when there is actually nothing to do. It's slightly awkward to deal + -- with casts here, apart from the topmost one, and they are rare, so + -- if we find one we just hand off to mkEtaWW anyway + -- Note [Eta expansion and SCCs] + go _ [] _ _ = orig_expr -- Already has the specified arity; no-op + + go in_scope oss@(_:oss1) vs (Lam v body) + | isTyVar v = go (in_scope `extendInScopeSet` v) oss (v:vs) body + | otherwise = go (in_scope `extendInScopeSet` v) oss1 (v:vs) body + + go in_scope oss rev_vs expr + = -- pprTrace "ee" (vcat [ppr in_scope', ppr top_bndrs, ppr eis]) $ + retick $ + etaInfoAbs top_eis $ + etaInfoApp in_scope' sexpr eis + where + (in_scope', eis@(EI eta_bndrs mco)) + = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr) + top_bndrs = reverse rev_vs + top_eis = EI (top_bndrs ++ eta_bndrs) (mkPiMCos top_bndrs mco) + + -- Find ticks behind type apps. + -- See Note [Eta expansion and source notes] + -- I don't really understand this code SLPJ May 21 + (expr', args) = collectArgs expr + (ticks, expr'') = stripTicksTop tickishFloatable expr' + sexpr = mkApps expr'' args + retick expr = foldr mkTick expr ticks + +{- ********************************************************************* +* * + The EtaInfo mechanism + mkEtaWW, etaInfoAbs, etaInfoApp +* * +********************************************************************* -} + +{- Note [The EtaInfo mechanism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (e :: ty) and we want to eta-expand it to arity N. +This what eta_expand does. We do it in two steps: + +1. mkEtaWW: from 'ty' and 'N' build a EtaInfo which describes + the shape of the expansion necessary to expand to arity N. + +2. Build the term + \ v1..vn. e v1 .. vn + where those abstractions and applications are described by + the same EtaInfo. Specifically we build the term + + etaInfoAbs etas (etaInfoApp in_scope e etas) + + where etas :: EtaInfo + etaInfoAbs builds the lambdas + etaInfoApp builds the applications + + Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp + +To a first approximation EtaInfo is just [Var]. But casts complicate +the question. If we have + newtype N a = MkN (S -> a) + axN :: N a ~ S -> a +and + e :: N (N Int) +then the eta-expansion should look like + (\(x::S) (y::S) -> (e |> co) x y) |> sym co +where + co :: N (N Int) ~ S -> S -> Int + co = axN @(N Int) ; (S -> axN @Int) + +We want to get one cast, at the top, to account for all those +nested newtypes. This is expressed by the EtaInfo type: + + data EtaInfo = EI [Var] MCoercionR + +Precisely, here is the (EtaInfo Invariant): + + EI bs co :: EtaInfo + +describes a particular eta-expansion, thus: + + Abstraction: (\b1 b2 .. bn. []) |> sym co + Application: ([] |> co) b1 b2 .. bn + + e :: T + co :: T ~R (t1 -> t2 -> .. -> tn -> tr) + e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co + + +Note [Check for reflexive casts in eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It turns out that the casts created by the above mechanism are often Refl. +When casts are very deeply nested (as happens in #18223), the repetition +of types can make the overall term very large. So there is a big +payoff in cancelling out casts aggressively wherever possible. +(See also Note [No crap in eta-expanded code].) + +This matters particularly in etaInfoApp, where we +* Do beta-reduction on the fly +* Use getArg_maybe to get a cast out of the way, + so that we can do beta reduction +Together this makes a big difference. Consider when e is + case x of + True -> (\x -> e1) |> c1 + False -> (\p -> e2) |> c2 + +When we eta-expand this to arity 1, say, etaInfoAbs will wrap +a (\eta) around the outside and use etaInfoApp to apply each +alternative to 'eta'. We want to beta-reduce all that junk +away. + +#18223 was a dramatic example in which the intermediate term was +grotesquely huge, even though the next Simplifier iteration squashed +it. Better to kill it at birth. + +The crucial spots in etaInfoApp are: +* `checkReflexiveMCo` in the (Cast e co) case of `go` +* `checkReflexiveMCo` in `pushCoArg` +* Less important: checkReflexiveMCo in the final case of `go` +Collectively these make a factor-of-5 difference to the total +allocation of T18223, so take care if you change this stuff! + +Example: + newtype N = MkN (Y->Z) + f :: X -> N + f = \(x::X). ((\(y::Y). blah) |> fco) + +where fco :: (Y->Z) ~ N + +mkEtaWW makes an EtaInfo of (EI [(eta1:X), (eta2:Y)] eta_co + where + eta_co :: (X->N) ~ (X->Y->Z) + eta_co = ( -> nco) + nco :: N ~ (Y->Z) -- Comes from topNormaliseNewType_maybe + +Now, when we push that eta_co inward in etaInfoApp: +* In the (Cast e co) case, the 'fco' and 'nco' will meet, and + should cancel. +* When we meet the (\y.e) we want no cast on the y. + +-} + +-------------- +data EtaInfo = EI [Var] MCoercionR + -- See Note [The EtaInfo mechanism] + +instance Outputable EtaInfo where + ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco) + + +etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr +-- (etaInfoApp s e (EI bs mco) returns something equivalent to +-- ((substExpr s e) |> mco b1 .. bn) +-- See Note [The EtaInfo mechanism] +-- +-- NB: With very deeply nested casts, this function can be expensive +-- In T18223, this function alone costs 15% of allocation, all +-- spent in the calls to substExprSC and substBindSC + +etaInfoApp in_scope expr eis + = go (mkEmptySubst in_scope) expr eis + where + go :: Subst -> CoreExpr -> EtaInfo -> CoreExpr + -- 'go' pushed down the eta-infos into the branch of a case + -- and the body of a let; and does beta-reduction if possible + -- go subst fun co [b1,..,bn] returns (subst(fun) |> co) b1 .. bn + go subst (Tick t e) eis + = Tick (substTickish subst t) (go subst e eis) + + go subst (Cast e co) (EI bs mco) + = go subst e (EI bs mco') + where + mco' = checkReflexiveMCo (Core.substCo subst co `mkTransMCoR` mco) + -- See Note [Check for reflexive casts in eta expansion] + + go subst (Case e b ty alts) eis + = Case (Core.substExprSC subst e) b1 ty' alts' + where + (subst1, b1) = Core.substBndr subst b + alts' = map subst_alt alts + ty' = etaInfoAppTy (substTyUnchecked subst ty) eis + subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis) + where + (subst2,bs') = Core.substBndrs subst1 bs + + go subst (Let b e) eis + | not (isJoinBind b) -- See Note [Eta expansion for join points] + = Let b' (go subst' e eis) + where + (subst', b') = Core.substBindSC subst b + + -- Beta-reduction if possible, pushing any intervening casts past + -- the argument. See Note [The EtaInfo mechanism] + go subst (Lam v e) (EI (b:bs) mco) + | Just (arg,mco') <- pushMCoArg mco (varToCoreExpr b) + = go (Core.extendSubst subst v arg) e (EI bs mco') + + -- Stop pushing down; just wrap the expression up + -- See Note [Check for reflexive casts in eta expansion] + go subst e (EI bs mco) = Core.substExprSC subst e + `mkCastMCo` checkReflexiveMCo mco + `mkVarApps` bs + +-------------- +etaInfoAppTy :: Type -> EtaInfo -> Type +-- If e :: ty +-- then etaInfoApp e eis :: etaInfoApp ty eis +etaInfoAppTy ty (EI bs mco) + = applyTypeToArgs ty1 (map varToCoreExpr bs) + where + ty1 = case mco of + MRefl -> ty + MCo co -> coercionRKind co + +-------------- +etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr +-- See Note [The EtaInfo mechanism] +etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastMCo` mkSymMCo mco + +-------------- +-- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding +-- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the +-- free variables of @e@. +-- +-- Note that this function is entirely unconcerned about cost centres and other +-- semantically-irrelevant source annotations, so call sites must take care to +-- preserve that info. See Note [Eta expansion and SCCs]. +mkEtaWW + :: [OneShotInfo] + -- ^ How many value arguments to eta-expand + -> SDoc + -- ^ The pretty-printed original expression, for warnings. + -> InScopeSet + -- ^ A super-set of the free vars of the expression to eta-expand. + -> Type + -> (InScopeSet, EtaInfo) + -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'. + -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the + -- fresh variables in 'EtaInfo'. + +mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty + = go 0 orig_oss empty_subst orig_ty + where + empty_subst = mkEmptySubst in_scope + + go :: Int -- For fresh names + -> [OneShotInfo] -- Number of value args to expand to + -> Subst -> Type -- We are really looking at subst(ty) + -> (InScopeSet, EtaInfo) + -- (go [o1,..,on] subst ty) = (in_scope, EI [b1,..,bn] co) + -- co :: subst(ty) ~ b1_ty -> ... -> bn_ty -> tr + + go _ [] subst _ + ----------- Done! No more expansion needed + = (substInScopeSet subst, EI [] MRefl) + + go n oss@(one_shot:oss1) subst ty + ----------- Forall types (forall a. ty) + | Just (Bndr tcv vis, ty') <- splitForAllForAllTyBinder_maybe ty + , (subst', tcv') <- Type.substVarBndr subst tcv + , let oss' | isTyVar tcv = oss + | otherwise = oss1 + -- A forall can bind a CoVar, in which case + -- we consume one of the [OneShotInfo] + , (in_scope, EI bs mco) <- go n oss' subst' ty' + = (in_scope, EI (tcv' : bs) (mkEtaForAllMCo (Bndr tcv' vis) ty' mco)) + + ----------- Function types (t1 -> t2) + | Just (_af, mult, arg_ty, res_ty) <- splitFunTy_maybe ty + , typeHasFixedRuntimeRep arg_ty + -- See Note [Representation polymorphism invariants] in GHC.Core + -- See also test case typecheck/should_run/EtaExpandLevPoly + + , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty) + -- Avoid free vars of the original expression + + , let eta_id' = eta_id `setIdOneShotInfo` one_shot + , (in_scope, EI bs mco) <- go (n+1) oss1 subst' res_ty + = (in_scope, EI (eta_id' : bs) (mkFunResMCo eta_id' mco)) + + ----------- Newtypes + -- Given this: + -- newtype T = MkT ([T] -> Int) + -- Consider eta-expanding this + -- eta_expand 1 e T + -- We want to get + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + | Just (co, ty') <- topNormaliseNewType_maybe ty + , -- co :: ty ~ ty' + let co' = Type.substCo subst co + -- Remember to apply the substitution to co (#16979) + -- (or we could have applied to ty, but then + -- we'd have had to zap it for the recursive call) + , (in_scope, EI bs mco) <- go n oss subst ty' + -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr + = (in_scope, EI bs (mkTransMCoR co' mco)) + + | otherwise -- We have an expression of arity > 0, + -- but its type isn't a function, or a binder + -- does not have a fixed runtime representation + = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr) + (substInScopeSet subst, EI [] MRefl) + -- This *can* legitimately happen: + -- e.g. coerce Int (\x. x) Essentially the programmer is + -- playing fast and loose with types (Happy does this a lot). + -- So we simply decline to eta-expand. Otherwise we'd end up + -- with an explicit lambda having a non-function type + +mkEtaForAllMCo :: ForAllTyBinder -> Type -> MCoercion -> MCoercion +mkEtaForAllMCo (Bndr tcv vis) ty mco + = case mco of + MRefl | vis == coreTyLamForAllTyFlag -> MRefl + | otherwise -> mk_fco (mkRepReflCo ty) + MCo co -> mk_fco co + where + mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag + (mkNomReflCo (varType tcv)) co) + -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly + -- the (EtaInfo Invariant). (sym co) wraps a lambda that always has + -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core] + -- in GHC.Core.TyCo.Rep + +{- +************************************************************************ +* * + Eta reduction +* * +************************************************************************ + +Note [Eta reduction makes sense] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC's eta reduction transforms + \x y. x y ---> +We discuss when this is /sound/ in Note [Eta reduction soundness]. +But even assuming it is sound, when is it /desirable/. That +is what we discuss here. + +This test is made by `ok_fun` in tryEtaReduce. + +1. We want to eta-reduce only if we get all the way to a trivial + expression; we don't want to remove extra lambdas unless we are + going to avoid allocating this thing altogether. + + Trivial means *including* casts and type lambdas: + * `\x. f x |> co --> f |> (ty(x) -> co)` (provided `co` doesn't mention `x`) + * `/\a. \x. f @(Maybe a) x --> /\a. f @(Maybe a)` + See Note [Do not eta reduce PAPs] for why we insist on a trivial head. + +Of course, eta reduction is not always sound. See Note [Eta reduction soundness] +for when it is. + +When there are multiple arguments, we might get multiple eta-redexes. Example: + \x y. e x y + ==> { reduce \y. (e x) y in context \x._ } + \x. e x + ==> { reduce \x. e x in context _ } + e +And (1) implies that we never want to stop with `\x. e x`, because that is not a +trivial expression. So in practice, the implementation works by considering a +whole group of leading lambdas to reduce. + +These delicacies are why we don't simply use 'exprIsTrivial' and 'exprIsHNF' +in 'tryEtaReduce'. Alas. + +Note [Eta reduction soundness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC's eta reduction transforms + \x y. x y ---> +For soundness, we obviously require that `x` and `y` +to not occur free. But what /other/ restrictions are there for +eta reduction to be sound? + +We discuss separately what it means for eta reduction to be +/desirable/, in Note [Eta reduction makes sense]. + +Eta reduction is *not* a sound transformation in general, because it +may change termination behavior if *value* lambdas are involved: + `bot` /= `\x. bot x` (as can be observed by a simple `seq`) +The past has shown that oversight of this fact can not only lead to endless +loops or exceptions, but also straight out *segfaults*. + +Nevertheless, we can give the following criteria for when it is sound to +perform eta reduction on an expression with n leading lambdas `\xs. e xs` +(checked in 'is_eta_reduction_sound' in 'tryEtaReduce', which focuses on the +case where `e` is trivial): + +(A) It is sound to eta-reduce n arguments as long as n does not exceed the + `exprArity` of `e`. (Needs Arity analysis.) + This criterion exploits information about how `e` is *defined*. + + Example: If `e = \x. bot` then we know it won't diverge until it is called + with one argument. Hence it is safe to eta-reduce `\x. e x` to `e`. + By contrast, it would be *unsound* to eta-reduce 2 args, `\x y. e x y` to `e`: + `e 42` diverges when `(\x y. e x y) 42` does not. + +(S) It is sound to eta-reduce n arguments in an evaluation context in which all + calls happen with at least n arguments. (Needs Strictness analysis.) + NB: This treats evaluations like a call with 0 args. + NB: This criterion exploits information about how `e` is *used*. + + Example: Given a function `g` like + `g c = Just (c 1 2 + c 2 3)` + it is safe to eta-reduce the arg in `g (\x y. e x y)` to `g e` without + knowing *anything* about `e` (perhaps it's a parameter occ itself), simply + because `g` always calls its parameter with 2 arguments. + It is also safe to eta-reduce just one arg, e.g., `g (\x. e x)` to `g e`. + By contrast, it would *unsound* to eta-reduce 3 args in a call site + like `g (\x y z. e x y z)` to `g e`, because that diverges when + `e = \x y. bot`. + + Could we relax to "*At least one call in the same trace* is with n args"? + No. Consider what happens for + ``g2 c = c True `seq` c False 42`` + Here, `g2` will call `c` with 2 arguments (if there is a call at all). + But it is unsound to eta-reduce the arg in `g2 (\x y. e x y)` to `g2 e` + when `e = \x. if x then bot else id`, because the latter will diverge when + the former would not. Fortunately, the strictness analyser will report + "Not always called with two arguments" for `g2` and we won't eta-expand. + + See Note [Eta reduction based on evaluation context] for the implementation + details. This criterion is tested extensively in T21261. + +(R) Note [Eta reduction in recursive RHSs] tells us that we should not + eta-reduce `f` in its own RHS and describes our fix. + There we have `f = \x. f x` and we should not eta-reduce to `f=f`. Which + might change a terminating program (think @f `seq` e@) to a non-terminating + one. + +(E) (See fun_arity in tryEtaReduce.) As a perhaps special case on the + boundary of (A) and (S), when we know that a fun binder `f` is in + WHNF, we simply assume it has arity 1 and apply (A). Example: + g f = f `seq` \x. f x + Here it's sound eta-reduce `\x. f x` to `f`, because `f` can't be bottom + after the `seq`. This turned up in #7542. + + T. If the binders are all type arguments, it's always safe to eta-reduce, + regardless of the arity of f. + /\a b. f @a @b --> f + +2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it + is always sound to reduce /type lambdas/, thus: + (/\a -> f a) --> f + Moreover, we always want to, because it makes RULEs apply more often: + This RULE: `forall g. foldr (build (/\a -> g a))` + should match `foldr (build (/\b -> ...something complex...))` + and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`. + + More debatably, we extend this to dictionary arguments too, because the type + checker can insert these eta-expanded versions, with both type and dictionary + lambdas; hence the slightly ad-hoc (all ok_lam bndrs). That is, we eta-reduce + \(d::Num a). f d --> f + regardless of f's arity. Its not clear whether or not this is important, and + it is not in general sound. But that's the way it is right now. + +And here are a few more technical criteria for when it is *not* sound to +eta-reduce that are specific to Core and GHC: + +(J) We may not undersaturate join points. + See Note [Invariants on join points] in GHC.Core, and #20599. + +(B) We may not undersaturate functions with no binding. + See Note [Eta expanding primops]. + +(W) We may not undersaturate StrictWorkerIds. + See Note [CBV Function Ids] in GHC.Types.Id.Info. + +Here is a list of historic accidents surrounding unsound eta-reduction: + +* Consider + f = \x.f x + h y = case (case y of { True -> f `seq` True; False -> False }) of + True -> ...; False -> ... + If we (unsoundly) eta-reduce f to get f=f, the strictness analyser + says f=bottom, and replaces the (f `seq` True) with just + (f `cast` unsafe-co). + [SG in 2022: I don't think worker/wrapper would do this today.] + BUT, as things stand, 'f' got arity 1, and it *keeps* arity 1 (perhaps also + wrongly). So CorePrep eta-expands the definition again, so that it does not + terminate after all. + Result: seg-fault because the boolean case actually gets a function value. + See #1947. + +* Never *reduce* arity. For example + f = \xy. g x y + Then if h has arity 1 we don't want to eta-reduce because then + f's arity would decrease, and that is bad + [SG in 2022: I don't understand this point. There is no `h`, perhaps that + should have been `g`. Even then, this proposed eta-reduction is invalid by + criterion (A), which might actually be the point this anecdote is trying to + make. Perhaps the "no arity decrease" idea is also related to + Note [Arity robustness]?] + +Note [Do not eta reduce PAPs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I considered eta-reducing if the result is a PAP: + \x. f e1 e2 x ==> f e1 e2 + +This reduces clutter, sometimes a lot. See Note [Do not eta-expand PAPs] +in GHC.Core.Opt.Simplify.Utils, where we are careful not to eta-expand +a PAP. If eta-expanding is bad, then eta-reducing is good! + +Also the code generator likes eta-reduced PAPs; see GHC.CoreToStg.Prep +Note [No eta reduction needed in rhsToBody]. + +But note that we don't want to eta-reduce + \x y. f x y +to + f +The former has arity 2, and repeats for every call of the +function; the latter has arity 0, and shares . We don't want +to change behaviour. Hence the call to exprIsCheap in ok_fun. + +I noticed this when examining #18993 and, although it is delicate, +eta-reducing to a PAP happens to fix the regression in #18993. + +HOWEVER, if we transform + \x. f y x ==> f y +that might mean that f isn't saturated any more, and does not inline. +This led to some other regressions. + +TL;DR currently we do /not/ eta reduce if the result is a PAP. + +Note [Eta reduction with casted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\(x:t3). f (x |> g)) :: t3 -> t2 + where + f :: t1 -> t2 + g :: t3 ~ t1 +This should be eta-reduced to + + f |> (sym g -> t2) + +So we need to accumulate a coercion, pushing it inward (past +variable arguments only) thus: + f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x + f (x:t) |> co --> (f |> (t -> co)) x + f @ a |> co --> (f |> (forall a.co)) @ a + f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) +These are the equations for ok_arg. + +Note [Eta reduction with casted function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since we are pushing a coercion inwards, it is easy to accommodate + (\xy. (f x |> g) y) + (\xy. (f x y) |> g) + +See the `(Cast e co)` equation for `go` in `tryEtaReduce`. The +eta-expander pushes those casts outwards, so you might think we won't +ever see a cast here, but if we have + \xy. (f x y |> g) +we will call tryEtaReduce [x,y] (f x y |> g), and we'd like that to +work. This happens in GHC.Core.Opt.Simplify.Utils.mkLam, where +eta-expansion may be turned off (by sm_eta_expand). + +Note [Eta reduction based on evaluation context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Eta reduction soundness], criterion (S) allows us to eta-reduce +`g (\x y. e x y)` to `g e` when we know that `g` always calls its parameter with +at least 2 arguments. So how do we read that off `g`'s demand signature? + +Let's take the simple example of #21261, where `g` (actually, `f`) is defined as + g c = c 1 2 + c 3 4 +Then this is how the pieces are put together: + + * Demand analysis infers `` for `g`'s demand signature + + * When the Simplifier next simplifies the argument in `g (\x y. e x y)`, it + looks up the *evaluation context* of the argument in the form of the + sub-demand `C(S,C(1,L))` and stores it in the 'SimplCont'. + (Why does it drop the outer evaluation cardinality of the demand, `S`? + Because it's irrelevant! When we simplify an expression, we do so under the + assumption that it is currently under evaluation.) + This sub-demand literally says "Whenever this expression is evaluated, it + is called with at least two arguments, potentially multiple times". + + * Then the simplifier takes apart the lambda and simplifies the lambda group + and then calls 'tryEtaReduce' when rebuilding the lambda, passing the + evaluation context `C(S,C(1,L))` along. Then we simply peel off 2 call + sub-demands `Cn` and see whether all of the n's (here: `S=C_1N` and + `1=C_11`) were strict. And strict they are! Thus, it will eta-reduce + `\x y. e x y` to `e`. + +Note [Eta reduction in recursive RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following recursive function: + f = \x. ....g (\y. f y).... +The recursive call of f in its own RHS seems like a fine opportunity for +eta-reduction because f has arity 1. And often it is! + +Alas, that is unsound in general if the eta-reduction happens in a tail context. +Making the arity visible in the RHS allows us to eta-reduce + f = \x -> f x +to + f = f +which means we optimise terminating programs like (f `seq` ()) into +non-terminating ones. Nor is this problem just for tail calls. Consider + f = id (\x -> f x) +where we have (for some reason) not yet inlined `id`. We must not eta-reduce to + f = id f +because that will then simplify to `f = f` as before. + +An immediate idea might be to look at whether the called function is a local +loopbreaker and refrain from eta-expanding. But that doesn't work for mutually +recursive function like in #21652: + f = g + g* x = f x +Here, g* is the loopbreaker but f isn't. + +What can we do? + +Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when + entering the let body. + Has the disadvantage that other transformations which make use of arity + (such as dropping of `seq`s when arity > 0) will no longer work in the RHS. + Plus it requires non-trivial refactorings to both the simple optimiser (in + the way `subst_opt_bndr` is used) as well as the Simplifier (in the way + `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's + substitution twice in the process. A very complicated stop-gap. + +Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are + the ones we should not eta-reduce. All call-site must maintain this set. + Example: + rec { f1 = ....rec { g = ... (\x. g x)...(\y. f2 y)... }... + ; f2 = ...f1... } + when eta-reducing those inner lambdas, we need to know that we are in the + rec group for {f1, f2, g}. + This is very much like the solution in Note [Speculative evaluation] in + GHC.CoreToStg.Prep. + It is a bit tiresome to maintain this info, because it means another field + in SimplEnv and SimpleOptEnv. + +We implement Fix (2) because of it isn't as complicated to maintain as (1). +Plus, it is the correct fix to begin with. After all, the arity is correct, +but doing the transformation isn't. The moving parts are: + * A field `scRecIds` in `SimplEnv` tracks the enclosing recursive binders + * We extend the `scRecIds` set in `GHC.Core.Opt.Simplify.simplRecBind` + * We consult the set in `is_eta_reduction_sound` in `tryEtaReduce` +The situation is very similar to Note [Speculative evaluation] which has the +same fix. +-} + +-- | `tryEtaReduce [x,y,z] e sd` returns `Just e'` if `\x y z -> e` is evaluated +-- according to `sd` and can soundly and gainfully be eta-reduced to `e'`. +-- See Note [Eta reduction soundness] +-- and Note [Eta reduction makes sense] when that is the case. +tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr +-- Return an expression equal to (\bndrs. body) +tryEtaReduce rec_ids bndrs body eval_sd + = go (reverse bndrs) body (mkRepReflCo (exprType body)) + where + incoming_arity = count isId bndrs -- See Note [Eta reduction makes sense], point (2) + + go :: [Var] -- Binders, innermost first, types [a3,a2,a1] + -> CoreExpr -- Of type tr + -> Coercion -- Of type tr ~ ts + -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts + -- See Note [Eta reduction with casted arguments] + -- for why we have an accumulating coercion + -- + -- Invariant: (go bs body co) returns an expression + -- equivalent to (\(reverse bs). (body |> co)) + + -- See Note [Eta reduction with casted function] + go bs (Cast e co1) co2 + = go bs e (co1 `mkTransCo` co2) + + go bs (Tick t e) co + | tickishFloatable t + = fmap (Tick t) $ go bs e co + -- Float app ticks: \x -> Tick t (e x) ==> Tick t e + + go (b : bs) (App fun arg) co + | Just (co', ticks) <- ok_arg b arg co (exprType fun) + = fmap (flip (foldr mkTick) ticks) $ go bs fun co' + -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e + + go remaining_bndrs fun co + | all isTyVar remaining_bndrs + -- If all the remaining_bnrs are tyvars, then the etad_exp + -- will be trivial, which is what we want. + -- e.g. We might have /\a \b. f [a] b, and we want to + -- eta-reduce to /\a. f [a] + -- We don't want to give up on this one: see #20040 + -- See Note [Eta reduction makes sense], point (1) + , remaining_bndrs `ltLength` bndrs + -- Only reply Just if /something/ has happened + , ok_fun fun + , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co + reduced_bndrs = mkVarSet (dropList remaining_bndrs bndrs) + -- reduced_bndrs are the ones we are eta-reducing away + , used_vars `disjointVarSet` reduced_bndrs + -- Check for any of the reduced_bndrs (about to be dropped) + -- free in the result, including the accumulated coercion. + -- See Note [Eta reduction makes sense], intro and point (1) + -- NB: don't compute used_vars from exprFreeVars (mkCast fun co) + -- because the latter may be ill formed if the guard fails (#21801) + = Just (mkLams (reverse remaining_bndrs) (mkCast fun co)) + + go _remaining_bndrs _fun _ = -- pprTrace "tER fail" (ppr _fun $$ ppr _remaining_bndrs) $ + Nothing + + --------------- + -- See Note [Eta reduction makes sense], point (1) + ok_fun (App fun (Type {})) = ok_fun fun + ok_fun (Cast fun _) = ok_fun fun + ok_fun (Tick _ expr) = ok_fun expr + ok_fun (Var fun_id) = is_eta_reduction_sound fun_id + ok_fun _fun = False + + --------------- + -- See Note [Eta reduction soundness], this is THE place to check soundness! + is_eta_reduction_sound fun + | fun `elemUnVarSet` rec_ids -- Criterion (R) + = False -- Don't eta-reduce in fun in its own recursive RHSs + + | cantEtaReduceFun fun -- Criteria (J), (W), (B) + = False -- Function can't be eta reduced to arity 0 + -- without violating invariants of Core and GHC + + | otherwise + = -- Check that eta-reduction won't make the program stricter... + fun_arity fun >= incoming_arity -- Criterion (A) and (E) + || all_calls_with_arity incoming_arity -- Criterion (S) + || all ok_lam bndrs -- Criterion (T) + + all_calls_with_arity n = isStrict (fst $ peelManyCalls n eval_sd) + -- See Note [Eta reduction based on evaluation context] + + --------------- + fun_arity fun + | arity > 0 = arity + | isEvaldUnfolding (idUnfolding fun) = 1 + -- See Note [Eta reduction soundness], criterion (E) + | otherwise = 0 + where + arity = idArity fun + + --------------- + ok_lam v = isTyVar v || isEvId v + -- See Note [Eta reduction makes sense], point (2) + + --------------- + ok_arg :: Var -- Of type bndr_t + -> CoreExpr -- Of type arg_t + -> Coercion -- Of kind (t1~t2) + -> Type -- Type (arg_t -> t1) of the function + -- to which the argument is supplied + -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -- (and similarly for tyvars, coercion args) + , [CoreTickish]) + -- See Note [Eta reduction with casted arguments] + ok_arg bndr (Type arg_ty) co fun_ty + | Just tv <- getTyVar_maybe arg_ty + , bndr == tv = case splitForAllForAllTyBinder_maybe fun_ty of + Just (Bndr _ vis, _) -> Just (fco, []) + where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag kco co + -- The lambda we are eta-reducing always has visibility + -- 'coreTyLamForAllTyFlag' which may or may not match + -- the visibility on the inner function (#24014) + kco = mkNomReflCo (tyVarKind tv) + Nothing -> pprPanic "tryEtaReduce: type arg to non-forall type" + (text "fun:" <+> ppr bndr + $$ text "arg:" <+> ppr arg_ty + $$ text "fun_ty:" <+> ppr fun_ty) + ok_arg bndr (Var v) co fun_ty + | bndr == v + , let mult = idMult bndr + , Just (_af, fun_mult, _, _) <- splitFunTy_maybe fun_ty + , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort + = Just (mkFunResCo Representational bndr co, []) + ok_arg bndr (Cast e co_arg) co fun_ty + | (ticks, Var v) <- stripTicksTop tickishFloatable e + , Just (_, fun_mult, _, _) <- splitFunTy_maybe fun_ty + , bndr == v + , fun_mult `eqType` idMult bndr + = Just (mkFunCoNoFTF Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks) + -- The simplifier combines multiple casts into one, + -- so we can have a simple-minded pattern match here + ok_arg bndr (Tick t arg) co fun_ty + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty + = Just (co', t:ticks) + + ok_arg _ _ _ _ = Nothing + +-- | Can we eta-reduce the given function +-- See Note [Eta reduction soundness], criteria (B), (J), and (W). +cantEtaReduceFun :: Id -> Bool +cantEtaReduceFun fun + = hasNoBinding fun -- (B) + -- Don't undersaturate functions with no binding. + + || isJoinId fun -- (J) + -- Don't undersaturate join points. + -- See Note [Invariants on join points] in GHC.Core, and #20599 + + || (isJust (idCbvMarks_maybe fun)) -- (W) + -- Don't undersaturate StrictWorkerIds. + -- See Note [CBV Function Ids] in GHC.Types.Id.Info. + + +{- ********************************************************************* +* * + The "push rules" +* * +************************************************************************ + +Here we implement the "push rules" from FC papers: + +* The push-argument rules, where we can move a coercion past an argument. + We have + (fun |> co) arg + and we want to transform it to + (fun arg') |> co' + for some suitable co' and transformed arg'. + +* The PushK rule for data constructors. We have + (K e1 .. en) |> co + and we want to transform to + (K e1' .. en') + by pushing the coercion into the arguments +-} + +pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) +pushCoArgs co [] = return ([], MCo co) +pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg + ; case m_co1 of + MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args + ; return (arg':args', m_co2) } + MRefl -> return (arg':args, MRefl) } + +pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) +pushMCoArg MRefl arg = Just (arg, MRefl) +pushMCoArg (MCo co) arg = pushCoArg co arg + +pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) +-- We have (fun |> co) arg, and we want to transform it to +-- (fun arg) |> co +-- This may fail, e.g. if (fun :: N) where N is a newtype +-- C.f. simplCast in GHC.Core.Opt.Simplify +-- 'co' is always Representational +pushCoArg co arg + | Type ty <- arg + = do { (ty', m_co') <- pushCoTyArg co ty + ; return (Type ty', m_co') } + | otherwise + = do { (arg_mco, m_co') <- pushCoValArg co + ; let arg_mco' = checkReflexiveMCo arg_mco + -- checkReflexiveMCo: see Note [Check for reflexive casts in eta expansion] + -- The coercion is very often (arg_co -> res_co), but without + -- the argument coercion actually being ReflCo + ; return (arg `mkCastMCo` arg_mco', m_co') } + +pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) +-- We have (fun |> co) @ty +-- Push the coercion through to return +-- (fun @ty') |> co' +-- 'co' is always Representational +-- If the returned coercion is Nothing, then it would have been reflexive; +-- it's faster not to compute it, though. +pushCoTyArg co ty + -- The following is inefficient - don't do `eqType` here, the coercion + -- optimizer will take care of it. See #14737. + -- -- | tyL `eqType` tyR + -- -- = Just (ty, Nothing) + + | isReflCo co + = Just (ty, MRefl) + + | isForAllTy_ty tyL + = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $ + Just (ty `mkCastTy` co1, MCo co2) + + | otherwise + = Nothing + where + Pair tyL tyR = coercionKind co + -- co :: tyL ~R tyR + -- tyL = forall (a1 :: k1). ty1 + -- tyR = forall (a2 :: k2). ty2 + + co1 = mkSymCo (mkSelCo SelForAll co) + -- co1 :: k2 ~N k1 + -- Note that SelCo extracts a Nominal equality between the + -- kinds of the types related by a coercion between forall-types. + -- See the SelCo case in GHC.Core.Lint. + + co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1) + -- co2 :: ty1[ (ty|>co1)/a1 ] ~R ty2[ ty/a2 ] + -- Arg of mkInstCo is always nominal, hence Nominal + +-- | If @pushCoValArg co = Just (co_arg, co_res)@, then +-- +-- > (\x.body) |> co = (\y. let { x = y |> co_arg } in body) |> co_res) +-- +-- or, equivalently +-- +-- > (fun |> co) arg = (fun (arg |> co_arg)) |> co_res +-- +-- If the LHS is well-typed, then so is the RHS. In particular, the argument +-- @arg |> co_arg@ is guaranteed to have a fixed 'RuntimeRep', in the sense of +-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR) +pushCoValArg co + -- The following is inefficient - don't do `eqType` here, the coercion + -- optimizer will take care of it. See #14737. + -- -- | tyL `eqType` tyR + -- -- = Just (mkRepReflCo arg, Nothing) + + | isReflCo co + = Just (MRefl, MRefl) + + | isFunTy tyL + , (_, co1, co2) <- decomposeFunCo co + -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) + -- then co1 :: tyL1 ~ tyR1 + -- co2 :: tyL2 ~ tyR2 + + , typeHasFixedRuntimeRep new_arg_ty + -- We can't push the coercion inside if it would give rise to + -- a representation-polymorphic argument. + + = assertPpr (isFunTy tyL && isFunTy tyR) + (vcat [ text "co:" <+> ppr co + , text "old_arg_ty:" <+> ppr old_arg_ty + , text "new_arg_ty:" <+> ppr new_arg_ty ]) $ + Just (coToMCo (mkSymCo co1), coToMCo co2) + -- Critically, coToMCo to checks for ReflCo; the whole coercion may not + -- be reflexive, but either of its components might be + -- We could use isReflexiveCo, but it's not clear if the benefit + -- is worth the cost, and it makes no difference in #18223 + + | otherwise + = Nothing + where + old_arg_ty = funArgTy tyR + new_arg_ty = funArgTy tyL + Pair tyL tyR = coercionKind co + +pushCoercionIntoLambda + :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) +-- This implements the Push rule from the paper on coercions +-- (\x. e) |> co +-- ===> +-- (\x'. e |> co') +pushCoercionIntoLambda in_scope x e co + | assert (not (isTyVar x) && not (isCoVar x)) True + , Pair s1s2 t1t2 <- coercionKind co + , Just {} <- splitFunTy_maybe s1s2 + , Just (_, w1, t1,_t2) <- splitFunTy_maybe t1t2 + , (_, co1, co2) <- decomposeFunCo co + , typeHasFixedRuntimeRep t1 + -- We can't push the coercion into the lambda if it would create + -- a representation-polymorphic binder. + = let + -- Should we optimize the coercions here? + -- Otherwise they might not match too well + x' = x `setIdType` t1 `setIdMult` w1 + in_scope' = in_scope `extendInScopeSet` x' + subst = extendIdSubst (mkEmptySubst in_scope') + x + (mkCast (Var x') (mkSymCo co1)) + -- We substitute x' for x, except we need to preserve types. + -- The types are as follows: + -- x :: s1, x' :: t1, co1 :: s1 ~# t1, + -- so we extend the substitution with x |-> (x' |> sym co1). + in Just (x', substExpr subst e `mkCast` co2) + | otherwise + = Nothing + +pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercionR + -> Maybe (DataCon + , [Type] -- Universal type args + , [CoreExpr]) -- All other args incl existentials +-- Implement the KPush reduction rule as described in "Down with kinds" +-- The transformation applies iff we have +-- (C e1 ... en) `cast` co +-- where co :: (T t1 .. tn) ~ (T s1 .. sn) +-- The left-hand one must be a T, because exprIsConApp returned True +-- but the right-hand one might not be. (Though it usually will.) +pushCoDataCon dc dc_args MRefl = Just $! (push_dc_refl dc dc_args) +pushCoDataCon dc dc_args (MCo co) = push_dc_gen dc dc_args co (coercionKind co) + +push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr]) +push_dc_refl dc dc_args + = (dc, map exprToType univ_ty_args, rest_args) + where + !(univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args + +push_dc_gen :: DataCon -> [CoreExpr] -> CoercionR -> Pair Type + -> Maybe (DataCon, [Type], [CoreExpr]) +push_dc_gen dc dc_args co (Pair from_ty to_ty) + | from_ty `eqType` to_ty -- try cheap test first + = Just $! (push_dc_refl dc dc_args) + + | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty + , to_tc == dataConTyCon dc + -- These two tests can fail; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there's nothing wrong with it + = Just (push_data_con to_tc to_tc_arg_tys dc dc_args co Representational) + + | otherwise + = Nothing + + +push_data_con :: TyCon -> [Type] -> DataCon -> [CoreExpr] + -> CoercionR -> Role -- Coercion and its role + -> (DataCon, [Type], [CoreExpr]) +push_data_con to_tc to_tc_arg_tys dc dc_args co role + = assertPpr (eqType from_ty dc_app_ty) dump_doc $ + assertPpr (equalLength val_args arg_tys) dump_doc $ + assertPpr (role == coercionRole co) dump_doc $ + assertPpr (isInjectiveTyCon to_tc role) dump_doc $ + -- isInjectiveTyCon: see (UCM9) in Note [Unary class magic] + -- in GHC.Core.TyCon + (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) + where + Pair from_ty to_ty = coercionKind co + tc_arity = tyConArity to_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tcvars = dataConExTyCoVars dc + arg_tys = dataConRepArgTys dc + + dc_app_ty = mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) + + non_univ_args = dropList dc_univ_tyvars dc_args + (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args + + -- Make the "Psi" from the paper + omegas = decomposeCo tc_arity co (tyConRolesX role to_tc) + (psi_subst, to_ex_arg_tys) + = liftCoSubstWithEx dc_univ_tyvars + omegas + dc_ex_tcvars + (map exprToType ex_args) + + -- Cast the value arguments (which include dictionaries) + new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args + cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) + + to_ex_args = map Type to_ex_arg_tys + + dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars + , ppr arg_tys, ppr dc_args + , ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc + , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ] + +collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) +-- Collect lambda binders, pushing coercions inside if possible +-- E.g. (\x.e) |> g g :: -> blah +-- = (\x. e |> SelCo (SelFun SelRes) g) +-- +-- That is, +-- +-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> SelCo (SelFun SelRes) g) +collectBindersPushingCo e + = go [] e + where + -- Peel off lambdas until we hit a cast. + go :: [Var] -> CoreExpr -> ([Var], CoreExpr) + -- The accumulator is in reverse order + go bs (Lam b e) = go (b:bs) e + go bs (Cast e co) = go_c bs e co + go bs e = (reverse bs, e) + + -- We are in a cast; peel off casts until we hit a lambda. + go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr) + -- (go_c bs e c) is same as (go bs e (e |> c)) + go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) + go_c bs (Lam b e) co = go_lam bs b e co + go_c bs e co = (reverse bs, mkCast e co) + + -- We are in a lambda under a cast; peel off lambdas and build a + -- new coercion for the body. + go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) + -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) + go_lam bs b e co + | isTyVar b + , let Pair tyL tyR = coercionKind co + , assert (isForAllTy_ty tyL) $ + isForAllTy_ty tyR + , isReflCo (mkSelCo SelForAll co) -- See Note [collectBindersPushingCo] + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) + + | isCoVar b + , let Pair tyL tyR = coercionKind co + , assert (isForAllTy_co tyL) $ + isForAllTy_co tyR + , isReflCo (mkSelCo SelForAll co) -- See Note [collectBindersPushingCo] + , let cov = mkCoVarCo b + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) + + | isId b + , let Pair tyL tyR = coercionKind co + , assert (isFunTy tyL) $ isFunTy tyR + , (co_mult, co_arg, co_res) <- decomposeFunCo co + , isReflCo co_mult -- See Note [collectBindersPushingCo] + , isReflCo co_arg -- See Note [collectBindersPushingCo] + = go_c (b:bs) e co_res + + | otherwise = (reverse bs, mkCast (Lam b e) co) + +{- Note [collectBindersPushingCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We just look for coercions of form + % w -> blah +(and similarly for foralls) to keep this function simple. We could do +more elaborate stuff, but it'd involve substitution etc. +-} + +{- ********************************************************************* +* * + Join points +* * +********************************************************************* -} + +------------------- +-- | Split an expression into the given number of binders and a body, +-- eta-expanding if necessary. Counts value *and* type binders. +etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) +etaExpandToJoinPoint join_arity expr + = go join_arity [] expr + where + go 0 rev_bs e = (reverse rev_bs, e) + go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e + go n rev_bs e = case etaBodyForJoinPoint n e of + (bs, e') -> (reverse rev_bs ++ bs, e') + +etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule +etaExpandToJoinPointRule _ rule@(BuiltinRule {}) + = warnPprTrace True "Can't eta-expand built-in rule:" (ppr rule) + -- How did a local binding get a built-in rule anyway? Probably a plugin. + rule +etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs + , ru_args = args }) + | need_args == 0 + = rule + | need_args < 0 + = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) + | otherwise + = rule { ru_bndrs = bndrs ++ new_bndrs + , ru_args = args ++ new_args + , ru_rhs = new_rhs } + -- new_rhs really ought to be occ-analysed (see GHC.Core Note + -- [OccInfo in unfoldings and rules]), but it makes a module loop to + -- do so; it doesn't happen often; and it doesn't really matter if + -- the outer binders have bogus occurrence info; and new_rhs won't + -- have dead code if rhs didn't. + + where + need_args = join_arity - length args + (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs + new_args = varsToCoreExprs new_bndrs + +-- Adds as many binders as asked for; assumes expr is not a lambda +etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) +etaBodyForJoinPoint need_args body + = go need_args body_ty (mkEmptySubst in_scope) [] body + where + go 0 _ _ rev_bs e + = (reverse rev_bs, e) + go n ty subst rev_bs e + | Just (tv, res_ty) <- splitForAllTyCoVar_maybe ty + , let (subst', tv') = substVarBndr subst tv + = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') + -- The varToCoreExpr is important: `tv` might be a coercion variable + + | Just (_, mult, arg_ty, res_ty) <- splitFunTy_maybe ty + , let (subst', b) = freshEtaId n subst (Scaled mult arg_ty) + = go (n-1) res_ty subst' (b : rev_bs) (e `App` varToCoreExpr b) + -- The varToCoreExpr is important: `b` might be a coercion variable + + | otherwise + = pprPanic "etaBodyForJoinPoint" $ int need_args $$ + ppr body $$ ppr (exprType body) + + body_ty = exprType body + in_scope = mkInScopeSet (exprFreeVars body `unionVarSet` tyCoVarsOfType body_ty) + -- in_scope is a bit tricky. + -- - We are wrapping `body` in some value lambdas, so must not shadow + -- any free vars of `body` + -- - We are wrapping `body` in some type lambdas, so must not shadow any + -- tyvars in body_ty. Example: body is just a variable + -- (g :: forall (a::k). T k a -> Int) + -- We must not shadown that `k` when adding the /\a. So treat the free vars + -- of body_ty as in-scope. Showed up in #23026. + +-------------- +freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id) +-- Make a fresh Id, with specified type (after applying substitution) +-- It should be "fresh" in the sense that it's not in the in-scope set +-- of the TvSubstEnv; and it should itself then be added to the in-scope +-- set of the TvSubstEnv +-- +-- The Int is just a reasonable starting point for generating a unique; +-- it does not necessarily have to be unique itself. +freshEtaId n subst ty + = (subst', eta_id') + where + Scaled mult' ty' = Type.substScaledTyUnchecked subst ty + eta_id' = uniqAway (substInScopeSet subst) $ + mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty' + -- "OrCoVar" since this can be used to eta-expand + -- coercion abstractions + subst' = extendSubstInScope subst eta_id' diff --git a/GHC/Core/Opt/CSE.hs b/GHC/Core/Opt/CSE.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/CSE.hs @@ -0,0 +1,936 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section{Common subexpression} +-} + +module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where + +import GHC.Prelude + +import GHC.Core.Subst +import GHC.Types.Var.Env ( mkInScopeSet, mkInScopeSetList ) +import GHC.Types.Id +import GHC.Core.Utils ( mkAltExpr + , exprIsTickedString + , stripTicksE, stripTicksT, mkTicks ) +import GHC.Core.FVs ( exprFreeVars ) +import GHC.Core.Type ( tyConAppArgs ) +import GHC.Core +import GHC.Utils.Outputable +import GHC.Types.Basic +import GHC.Types.Tickish +import GHC.Core.Map.Expr +import GHC.Utils.Misc ( filterOut, equalLength ) +import GHC.Utils.Panic +import Data.Functor.Identity ( Identity (..) ) +import Data.List ( mapAccumL ) + +{- + Simple common sub-expression + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see + x1 = C a b + x2 = C x1 b +we build up a reverse mapping: C a b -> x1 + C x1 b -> x2 +and apply that to the rest of the program. + +When we then see + y1 = C a b + y2 = C y1 b +we replace the C a b with x1. But then we *don't* want to +add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 +so that a subsequent binding + y2 = C y1 b +will get transformed to C x1 b, and then to x2. + +So we carry an extra var->var substitution which we apply *before* looking up in the +reverse mapping. + + +Note [Shadowing in CSE] +~~~~~~~~~~~~~~~~~~~~~~~ +We have to be careful about shadowing. +For example, consider + f = \x -> let y = x+x in + h = \x -> x+x + in ... + +Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no +shadowing, but it doesn't any more (it proved too hard), so we clone as we go. +We can simply add clones to the substitution already described. + +A similar tricky situation is this, with x_123 and y_123 sharing the same unique: + + let x_123 = e1 in + let y_123 = e2 in + let foo = e1 + +Naively applying e1 = x_123 during CSE we would get: + + let x_123 = e1 in + let y_123 = e2 in + let foo = x_123 + +But x_123 is shadowed by y_123 and things would go terribly wrong! One more reason +why we have to substitute binders as we go so we will properly get: + + let x1 = e1 in + let x2 = e2 in + let foo = x1 + +Note [CSE for bindings] +~~~~~~~~~~~~~~~~~~~~~~~ +Let-bindings have two cases, implemented by extendCSEnvWithBinding. + +* SUBSTITUTE: applies when the RHS is a variable + + let x = y in ...(h x).... + + Here we want to extend the /substitution/ with x -> y, so that the + (h x) in the body might CSE with an enclosing (let v = h y in ...). + NB: the substitution maps InIds, so we extend the substitution with + a binding for the original InId 'x' + + How can we have a variable on the RHS? Doesn't the simplifier inline them? + + - First, the original RHS might have been (g z) which has CSE'd + with an enclosing (let y = g z in ...). This is super-important. + See #5996: + x1 = C a b + x2 = C x1 b + y1 = C a b + y2 = C y1 b + Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to + the substitution so that we can CSE the binding for y2. + + - Second, we use extendCSEnvWithBinding for case expression scrutinees too; + see Note [CSE for case expressions] + +* EXTEND THE REVERSE MAPPING: applies in all other cases + + let x = h y in ...(h y)... + + Here we want to extend the /reverse mapping (cs_map)/ so that + we CSE the (h y) call to x. + + Note that we use EXTEND even for a trivial expression, provided it + is not a variable or literal. In particular this /includes/ type + applications. This can be important (#13156); e.g. + case f @ Int of { r1 -> + case f @ Int of { r2 -> ... + Here we want to common-up the two uses of (f @ Int) so we can + remove one of the case expressions. + + See also Note [Corner case for case expressions] for another + reason not to use SUBSTITUTE for all trivial expressions. + +Notice that + - The SUBSTITUTE situation extends the substitution (cs_subst) + - The EXTEND situation extends the reverse mapping (cs_map) + +Notice also that in the SUBSTITUTE case we leave behind a binding + x = y +even though we /also/ carry a substitution x -> y. Can we just drop +the binding instead? Well, not at top level! See Note [Top level and +postInlineUnconditionally] in GHC.Core.Opt.Simplify.Utils; and in any +case CSE applies only to the /bindings/ of the program, and we leave +it to the simplifier to propagate effects to the RULES. Finally, it +doesn't seem worth the effort to discard the nested bindings because +the simplifier will do it next. + +Note [CSE for case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case scrut_expr of x { ...alts... } +This is very like a strict let-binding + let !x = scrut_expr in ... +So we use (extendCSEnvWithBinding x scrut_expr) to process scrut_expr and x, and as a +result all the stuff under Note [CSE for bindings] applies directly. + +For example: + +* Trivial scrutinee + f = \x -> case x of wild { + (a:as) -> case a of wild1 { + (p,q) -> ...(wild1:as)... + + Here, (wild1:as) is morally the same as (a:as) and hence equal to + wild. But that's not quite obvious. In the rest of the compiler we + want to keep it as (wild1:as), but for CSE purpose that's a bad + idea. + + By using extendCSEnvWithBinding we add the binding (wild1 -> a) to the substitution, + which does exactly the right thing. + + (Notice this is exactly backwards to what the simplifier does, which + is to try to replaces uses of 'a' with uses of 'wild1'.) + + This is the main reason that extendCSEnvWithBinding is called with a trivial rhs. + +* Non-trivial scrutinee + case (f x) of y { pat -> ...let z = f x in ... } + + By using extendCSEnvWithBinding we'll add (f x :-> y) to the cs_map, and + thereby CSE the inner (f x) to y. + +Note [CSE for INLINE and NOINLINE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are some subtle interactions of CSE with functions that the user +has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.) +Consider + + yes :: Int {-# NOINLINE yes #-} + yes = undefined + + no :: Int {-# NOINLINE no #-} + no = undefined + + foo :: Int -> Int -> Int {-# NOINLINE foo #-} + foo m n = n + + {-# RULES "foo/no" foo no = id #-} + + bar :: Int -> Int + bar = foo yes + +We do not expect the rule to fire. But if we do CSE, then we risk +getting yes=no, and the rule does fire. Actually, it won't because +NOINLINE means that 'yes' will never be inlined, not even if we have +yes=no. So that's fine (now; perhaps in the olden days, yes=no would +have substituted even if 'yes' was NOINLINE). + +But we do need to take care. Consider + + {-# NOINLINE bar #-} + bar = -- Same rhs as foo + + foo = + +If CSE produces + foo = bar +then foo will never be inlined to (when it should be, if +is small). The conclusion here is this: + + We should not add + :-> bar + to the CSEnv if 'bar' has any constraints on when it can inline; + that is, if its 'activation' not always active. Otherwise we + might replace by 'bar', and then later be unable to see that it + really was . + +An exception to the rule is when the INLINE pragma is not from the user, e.g. from +WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec +is then true. + +Note that we do not (currently) do CSE on the unfolding stored inside +an Id, even if it is a 'stable' unfolding. That means that when an +unfolding happens, it is always faithful to what the stable unfolding +originally was. + +Note [CSE for stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + {-# Unf = Stable (\pq. build blah) #-} + foo = x + +Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial. +(Turns out that this actually happens for the enumFromTo method of +the Integer instance of Enum in GHC.Enum.) Suppose moreover that foo's +stable unfolding originates from an INLINE or INLINEABLE pragma on foo. +Then we obviously do NOT want to extend the substitution with (foo->x), +because we promised to inline foo as what the user wrote. See similar Note +[Stable unfoldings and postInlineUnconditionally] in GHC.Core.Opt.Simplify.Utils. + +Nor do we want to change the reverse mapping. Suppose we have + + foo {-# Unf = Stable (\pq. build blah) #-} + = + bar = + +There could conceivably be merit in rewriting the RHS of bar: + bar = foo +but now bar's inlining behaviour will change, and importing +modules might see that. So it seems dodgy and we don't do it. + +Wrinkles + +* Stable unfoldings are also created during worker/wrapper when we + decide that a function's definition is so small that it should + always inline, or indeed for the wrapper function itself. In this + case we still want to do CSE (#13340). Hence the use of + isStableUserUnfolding/isStableSystemUnfolding rather than + isStableUnfolding. + +* Consider + foo = + bar {-# Unf = Stable ... #-} + = + where the unfolding was added by strictness analysis, say. Then + CSE goes ahead, so we get + bar = foo + and probably use SUBSTITUTE that will make 'bar' dead. But just + possibly not -- see Note [Dealing with ticks]. In that case we might + be left with + bar = tick t1 (tick t2 foo) + in which case we would really like to get rid of the stable unfolding + (generated by the strictness analyser, say). + + Hence the zapStableUnfolding in cse_bind. Not a big deal, and only + makes a difference when ticks get into the picture. + +Note [Corner case for case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is another reason that we do not use SUBSTITUTE for +all trivial expressions. Consider + case x |> co of (y::Array# Int) { ... } + +We do not want to extend the substitution with (y -> x |> co); since y +is of unlifted type, this would destroy the let-can-float invariant if +(x |> co) was not ok-for-speculation. + +But surely (x |> co) is ok-for-speculation, because it's a trivial +expression, and x's type is also unlifted, presumably. Well, maybe +not if you are using unsafe casts. I actually found a case where we +had + (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int) + +Note [CSE for join points?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must not be naive about join points in CSE: + join j = e in + if b then jump j else 1 + e +The expression (1 + jump j) is not good (see Note [Invariants on join points] in +GHC.Core). This seems to come up quite seldom, but it happens (first seen +compiling ppHtml in Haddock.Backends.Xhtml). + +We could try and be careful by tracking which join points are still valid at +each subexpression, but since join points aren't allocated or shared, there's +less to gain by trying to CSE them. (#13219) + +Note [Look inside join-point binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Another way how CSE for join points is tricky is + + let join foo x = (x, 42) + join bar x = (x, 42) + in … jump foo 1 … jump bar 2 … + +naively, CSE would turn this into + + let join foo x = (x, 42) + join bar = foo + in … jump foo 1 … jump bar 2 … + +but now bar is a join point that claims arity one, but its right-hand side +is not a lambda, breaking the join-point invariant (this was #15002). + +So `cse_bind` must zoom past the lambdas of a join point (using +`collectNBinders`) and resume searching for CSE opportunities only in +the body of the join point. + +Note [CSE for recursive bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = \x ... f.... + g = \y ... g ... +where the "..." are identical. Could we CSE them? In full generality +with mutual recursion it's quite hard; but for self-recursive bindings +(which are very common) it's rather easy: + +* Maintain a separate cs_rec_map, that maps + (\f. (\x. ...f...) ) -> f + Note the \f in the domain of the mapping! + +* When we come across the binding for 'g', look up (\g. (\y. ...g...)) + Bingo we get a hit. So we can replace the 'g' binding with + g = f + +We can't use cs_map for this, because the key isn't an expression of +the program; it's a kind of synthetic key for recursive bindings. + +Note [Separate envs for let rhs and body] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Substituting occurrences of the binder in the rhs with the + renamed binder is wrong for non-recursive bindings. Why? +Consider this core. + + let {x_123 = e} in + let {y_123 = \eta0 -> x_123} in ... + +In the second line the y_123 on the lhs and x_123 on the rhs refer to different binders +even if they share the same unique. + +If we apply the substitution `123 => x2_124}` to both the lhs and rhs we will transform +`let y_123 = \eta0 -> x_123` into `let x2_124 = \eta0 -> x2_124`. +However x2_124 on the rhs is not in scope and really shouldn't have been renamed at all. +Because really this should still be x_123! In fact this exact thing happened in #21685. + +To fix this we pass two different cse envs to cse_bind. One we use the cse the rhs of the binding. +And one we update with the result of cseing the rhs which we then use going forward for the +body/rest of the module. + +************************************************************************ +* * +\section{Common subexpression} +* * +************************************************************************ +-} + +cseProgram :: CoreProgram -> CoreProgram +cseProgram binds + = snd (mapAccumL (cseBind TopLevel) init_env binds) + where + init_env = emptyCSEnv $ + mkInScopeSetList (bindersOfBinds binds) + -- Put all top-level binders into scope; it is possible to have + -- forward references. See Note [Glomming] in GHC.Core.Opt.OccurAnal + -- Missing this caused #25468 + +cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind) +cseBind toplevel env (NonRec b e) + = (env2, NonRec b2 e2) + where + -- See Note [Separate envs for let rhs and body] + (env1, b1) = addNonRecBinder toplevel env b + (env2, (b2, e2)) = cse_bind toplevel env env1 (b,e) b1 + +cseBind toplevel env (Rec [(in_id, rhs)]) + | noCSE in_id + = (env1, Rec [(out_id, rhs')]) + + -- See Note [CSE for recursive bindings] + | Just previous <- lookupCSRecEnv env out_id rhs'' + , let previous' = mkTicks ticks previous + out_id' = delayInlining toplevel out_id + = -- We have a hit in the recursive-binding cache + (extendCSSubst env1 in_id previous', NonRec out_id' previous') + + | otherwise + = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')]) + + where + (env1, Identity out_id) = addRecBinders toplevel env (Identity in_id) + rhs' = cseExpr env1 rhs + rhs'' = stripTicksE tickishFloatable rhs' + ticks = stripTicksT tickishFloatable rhs' + id_expr' = varToCoreExpr out_id + zapped_id = zapIdUsageInfo out_id + +cseBind toplevel env (Rec pairs) + = (env2, Rec pairs') + where + (env1, bndrs1) = addRecBinders toplevel env (map fst pairs) + (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1) + + do_one env (pr, b1) = cse_bind toplevel env env pr b1 + +-- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer +-- to @in_id@ (@out_id@, created from addBinder or addRecBinders), +-- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd) +-- binding to the 'CSEnv', so that we attempt to CSE any expressions +-- which are equal to @out_rhs@. +-- We use a different env for cse on the rhs and for extendCSEnvWithBinding +-- for reasons explain in See Note [Separate envs for let rhs and body] +cse_bind :: TopLevelFlag -> CSEnv -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr)) +cse_bind toplevel env_rhs env_body (in_id, in_rhs) out_id + | isTopLevel toplevel, exprIsTickedString in_rhs + -- See Note [Take care with literal strings] + = (env_body', (out_id', in_rhs)) + + | JoinPoint arity <- idJoinPointHood out_id + -- See Note [Look inside join-point binders] + = let (params, in_body) = collectNBinders arity in_rhs + (env', params') = addBinders env_rhs params + out_body = tryForCSE env' in_body + in (env_body , (out_id, mkLams params' out_body)) + + | otherwise + = (env_body', (out_id'', out_rhs)) + where + (env_body', out_id') = extendCSEnvWithBinding env_body in_id out_id out_rhs cse_done + (cse_done, out_rhs) = try_for_cse env_rhs in_rhs + out_id'' | cse_done = zapStableUnfolding $ + delayInlining toplevel out_id' + | otherwise = out_id' + +delayInlining :: TopLevelFlag -> Id -> Id +-- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already +-- See Note [Delay inlining after CSE] +delayInlining top_lvl bndr + | isTopLevel top_lvl + , isAlwaysActive (idInlineActivation bndr) + , idHasRules bndr -- Only if the Id has some RULES, + -- which might otherwise get lost + -- These rules are probably auto-generated specialisations, + -- since Ids with manual rules usually have manually-inserted + -- delayed inlining anyway + = bndr `setInlineActivation` activateAfterInitial + | otherwise + = bndr + +extendCSEnvWithBinding + :: CSEnv -- Includes InId->OutId cloning + -> InVar -- Could be a let-bound type + -> OutId -> OutExpr -- Processed binding + -> Bool -- True <=> RHS was CSE'd and is a variable + -- or maybe (Tick t variable) + -> (CSEnv, OutId) -- Final env, final bndr +-- Extend the CSE env with a mapping [rhs -> out-id] +-- unless we can instead just substitute [in-id -> rhs] +-- +-- It's possible for the binder to be a type variable, +-- in which case we can just substitute. +-- See Note [CSE for bindings] +extendCSEnvWithBinding env in_id out_id rhs' cse_done + | not (isId out_id) = (extendCSSubst env in_id rhs', out_id) + | noCSE out_id = (env, out_id) + | use_subst = (extendCSSubst env in_id rhs', out_id) + | cse_done = (env, out_id) + -- See Note [Dealing with ticks] + | otherwise = (extendCSEnv env rhs' id_expr', zapped_id) + where + id_expr' = varToCoreExpr out_id + zapped_id = zapIdUsageInfo out_id + -- Putting the Id into the cs_map makes it possible that + -- it'll become shared more than it is now, which would + -- invalidate (the usage part of) its demand info. + -- This caused #100218. + -- Easiest thing is to zap the usage info; subsequently + -- performing late demand-analysis will restore it. Don't zap + -- the strictness info; it's not necessary to do so, and losing + -- it is bad for performance if you don't do late demand + -- analysis + + -- Should we use SUBSTITUTE or EXTEND? + -- See Note [CSE for bindings] + use_subst | Var {} <- rhs' = True + | otherwise = False + +-- | Given a binder `let x = e`, this function +-- determines whether we should add `e -> x` to the cs_map +noCSE :: InId -> Bool +noCSE id + | isJoinId id = no_cse -- See Note [CSE for join points?] + | isStableUserUnfolding unf = no_cse -- See Note [CSE for stable unfoldings] + | user_activation_control = no_cse -- See Note [CSE for INLINE and NOINLINE] + | otherwise = yes_cse + where + unf = idUnfolding id + user_activation_control = not (isAlwaysActive (idInlineActivation id)) + && not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id))) + yes_cse = False + no_cse = True + +{- Note [Take care with literal strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example: + + x = "foo"# + y = "foo"# + ...x...y...x...y.... + +We would normally turn this into: + + x = "foo"# + y = x + ...x...x...x...x.... + +But this breaks an invariant of Core, namely that the RHS of a top-level binding +of type Addr# must be a string literal, not another variable. See Note +[Core top-level string literals] in GHC.Core. + +For this reason, we special case top-level bindings to literal strings and leave +the original RHS unmodified. This produces: + + x = "foo"# + y = "foo"# + ...x...x...x...x.... + +Now 'y' will be discarded as dead code, and we are done. + +The net effect is that for the y-binding we want to + - Use SUBSTITUTE, by extending the substitution with y :-> x + - but leave the original binding for y undisturbed + +This is done by cse_bind. I got it wrong the first time (#13367). + +Note [Dealing with ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticks complicate CSE a bit, as I discovered in the fallout from +fixing #19360. + +* To get more CSE-ing, we strip all the tickishFloatable ticks from + an expression + - when inserting into the cs_map (see extendCSEnv) + - when looking up in the cs_map (see call to lookupCSEnv in try_for_cse) + Quite why only the tickishFloatable ticks, I'm not quite sure. + + AK: I think we only do this for floatable ticks since generally we don't mind them + being less accurate as much. E.g. consider + case e of + C1 -> f ( e1) + C2 -> f ( e1) + If the ticks are (floatable) source notes nothing too bad happens if the debug info for + both branches says the code comes from the same source location. Even if it will be inaccurate + for one of the branches. We should probably still consider this worthwhile. + However if the ticks are cost centres we really don't want the cost of both branches to be + attributed to the same cost centre. Because a user might explicitly have inserted different + cost centres in order to distinguish between evaluations resulting from the two different branches. + e.g. something like this: + case e of + C1 -> f ({ SCC "evalAlt1"} e1) + C1 -> f ({ SCC "evalAlt2"} e1) + But it's still a bit suspicious. + +* If we get a hit in cs_map, we wrap the result in the ticks from the + thing we are looking up (see try_for_cse) + +Net result: if we get a hit, we might replace + let x = tick t1 (tick t2 e) +with + let x = tick t1 (tick t2 y) +where 'y' is the variable that 'e' maps to. Now consider extendCSEnvWithBinding for +the binding for 'x': + +* We can't use SUBSTITUTE because those ticks might not be trivial (we + use tickishIsCode in exprIsTrivial) + +* We should not use EXTEND, because we definitely don't want to + add (tick t1 (tick t2 y)) :-> x + to the cs_map. Remember we strip off the ticks, so that would amount + to adding y :-> x, very silly. + +TL;DR: we do neither; hence the cse_done case in extendCSEnvWithBinding. + + +Note [Delay inlining after CSE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (#15445) we have + f,g :: Num a => a -> a + f x = ...f (x-1)..... + g y = ...g (y-1) .... + +and we make some specialisations of 'g', either automatically, or via +a SPECIALISE pragma. Then CSE kicks in and notices that the RHSs of +'f' and 'g' are identical, so we get + f x = ...f (x-1)... + g = f + {-# RULES g @Int _ = $sg #-} + +Now there is terrible danger that, in an importing module, we'll inline +'g' before we have a chance to run its specialisation! + +Solution: during CSE, after a "hit" in the CSE cache + * when adding a binding + g = f + * for a top-level function g + * and g has specialisation RULES +add a NOINLINE[2] activation to it, to ensure it's not inlined +right away. + +Notes: +* Why top level only? Because for nested bindings we are already past + phase 2 and will never return there. + +* Why "only if g has RULES"? Because there is no point in + doing this if there are no RULES; and other things being + equal it delays optimisation to delay inlining (#17409) + +* There can be a subtle order-dependency, as described in #25526; + it may matter whether we end up with f=g or g=f. + + +---- Historical note --- + +This patch is simpler and more direct than an earlier +version: + + commit 2110738b280543698407924a16ac92b6d804dc36 + Author: Simon Peyton Jones + Date: Mon Jul 30 13:43:56 2018 +0100 + + Don't inline functions with RULES too early + +We had to revert this patch because it made GHC itself slower. + +Why? It delayed inlining of /all/ functions with RULES, and that was +very bad in GHC.Tc.Solver.Flatten.flatten_ty_con_app + +* It delayed inlining of liftM +* That delayed the unravelling of the recursion in some dictionary + bindings. +* That delayed some eta expansion, leaving + flatten_ty_con_app = \x y. let in \z. blah +* That allowed the float-out pass to put sguff between + the \y and \z. +* And that permanently stopped eta expansion of the function, + even once was simplified. + +-} + +tryForCSE :: CSEnv -> InExpr -> OutExpr +tryForCSE env expr = snd (try_for_cse env expr) + +try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr) +-- (False, e') => We did not CSE the entire expression, +-- but we might have CSE'd some sub-expressions, +-- yielding e' +-- +-- (True, te') => We CSE'd the entire expression, +-- yielding the trivial expression te' +try_for_cse env expr + | Just e <- lookupCSEnv env expr'' = (True, mkTicks ticks e) + | otherwise = (False, expr') + -- The varToCoreExpr is needed if we have + -- case e of xco { ...case e of yco { ... } ... } + -- Then CSE will substitute yco -> xco; + -- but these are /coercion/ variables + where + expr' = cseExpr env expr + expr'' = stripTicksE tickishFloatable expr' + ticks = stripTicksT tickishFloatable expr' + -- We don't want to lose the source notes when a common sub + -- expression gets eliminated. Hence we push all (!) of them on + -- top of the replaced sub-expression. This is probably not too + -- useful in practice, but upholds our semantics. + +-- | Runs CSE on a single expression. +-- +-- This entry point is not used in the compiler itself, but is provided +-- as a convenient entry point for users of the GHC API. +cseOneExpr :: InExpr -> OutExpr +cseOneExpr e = cseExpr env e + where + env = emptyCSEnv (mkInScopeSet (exprFreeVars e)) + +cseExpr :: CSEnv -> InExpr -> OutExpr +cseExpr env (Type t) = Type (substTyUnchecked (csEnvSubst env) t) +cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) +cseExpr _ (Lit lit) = Lit lit +cseExpr env (Var v) = lookupSubst env v +cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) +cseExpr env (Tick t e) = Tick t (cseExpr env e) +cseExpr env (Cast e co) = Cast (tryForCSE env e) (substCo (csEnvSubst env) co) +cseExpr env (Lam b e) = let (env', b') = addBinder env b + in Lam b' (cseExpr env' e) +cseExpr env (Let bind e) = let (env', bind') = cseBind NotTopLevel env bind + in Let bind' (cseExpr env' e) +cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts + +cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr +cseCase env scrut bndr ty alts + = Case scrut1 bndr3 ty' $ + combineAlts (map cse_alt alts) + where + ty' = substTyUnchecked (csEnvSubst env) ty + (cse_done, scrut1) = try_for_cse env scrut + + bndr1 = zapIdOccInfo bndr + -- Zapping the OccInfo is needed because the extendCSEnv + -- in cse_alt may mean that a dead case binder + -- becomes alive, and Lint rejects that + (env1, bndr2) = addBinder env bndr1 + (alt_env, bndr3) = extendCSEnvWithBinding env1 bndr bndr2 scrut1 cse_done + -- extendCSEnvWithBinding: see Note [CSE for case expressions] + + con_target :: OutExpr + con_target = lookupSubst alt_env bndr + + arg_tys :: [OutType] + arg_tys = tyConAppArgs (idType bndr3) + + -- See Note [CSE for case alternatives] + cse_alt (Alt (DataAlt con) args rhs) + = Alt (DataAlt con) args' (tryForCSE new_env rhs) + where + (env', args') = addBinders alt_env args + new_env = extendCSEnv env' con_expr con_target + con_expr = mkAltExpr (DataAlt con) args' arg_tys + + cse_alt (Alt con args rhs) + = Alt con args' (tryForCSE env' rhs) + where + (env', args') = addBinders alt_env args + +combineAlts :: [OutAlt] -> [OutAlt] +-- See Note [Combine case alternatives] +combineAlts alts + | (Just alt1, rest_alts) <- find_bndr_free_alt alts + , Alt _ bndrs1 rhs1 <- alt1 + , let filtered_alts = filterOut (identical_alt rhs1) rest_alts + , not (equalLength rest_alts filtered_alts) + = assertPpr (all isDeadBinder bndrs1) (ppr alts) $ + Alt DEFAULT [] rhs1 : filtered_alts + + | otherwise + = alts + where + + find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt]) + -- The (Just alt) is an alt where all fields are dead + find_bndr_free_alt [] + = (Nothing, []) + find_bndr_free_alt (alt@(Alt _ bndrs _) : alts) + | all isDeadBinder bndrs = (Just alt, alts) + | otherwise = case find_bndr_free_alt alts of + (mb_bf, alts) -> (mb_bf, alt:alts) + + identical_alt rhs1 (Alt _ _ rhs) = eqCoreExpr rhs1 rhs + -- Even if this alt has binders, they will have been cloned + -- If any of these binders are mentioned in 'rhs', then + -- 'rhs' won't compare equal to 'rhs1' (which is from an + -- alt with no binders). + +{- Note [CSE for case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider case e of x + K1 y -> ....(K1 y)... + K2 -> ....K2.... + +We definitely want to CSE that (K1 y) into just x. + +But what about the lone K2? At first you would think "no" because +turning K2 into 'x' increases the number of live variables. But + +* Turning K2 into x increases the chance of combining identical alts. + Example case xs of + (_:_) -> f xs + [] -> f [] + See #17901 and simplCore/should_compile/T17901 for more examples + of this kind. + +* The next run of the simplifier will turn 'x' back into K2, so we won't + permanently bloat the free-var count. + + +Note [Combine case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +combineAlts is just a more heavyweight version of the use of +combineIdenticalAlts in GHC.Core.Opt.Simplify.Utils.prepareAlts. The basic idea is +to transform + + DEFAULT -> e1 + K x -> e1 + W y z -> e2 +===> + DEFAULT -> e1 + W y z -> e2 + +In the simplifier we use cheapEqExpr, because it is called a lot. +But here in CSE we use the full eqCoreExpr. After all, two alternatives usually +differ near the root, so it probably isn't expensive to compare the full +alternative. It seems like the same kind of thing that CSE is supposed +to be doing, which is why I put it here. + +I actually saw some examples in the wild, where some inlining made e1 too +big for cheapEqExpr to catch it. + +Note [Combine case alts: awkward corner] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We check isDeadBinder on field binders in order to collapse into a DEFAULT alt. +But alas, the simplifer often zaps occ-info on field binders in DataAlts when +the case binder is alive; see Note [DataAlt occ info] in GHC.Core.Opt.Simplify. + +* One alternative (perhaps a good one) would be to do OccAnal + just before CSE. Then perhaps we could get rid of combineIdenticalAlts + in the Simplifier, which might save work. + +* Another would be for CSE to return free vars as it goes. + +* But the current solution is to accept that we do not catch cases such as + case x of c + A _ -> blah[c] + B _ _ -> blah[c] + where the case binder c is alive and no alternative is DEFAULT. + But the current solution is at least cheap. + +************************************************************************ +* * +\section{The CSE envt} +* * +************************************************************************ +-} + +data CSEnv + = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs + -- The substitution variables to + -- /trivial/ OutExprs, not arbitrary expressions + + , cs_map :: CoreMap OutExpr + -- The "reverse" mapping. + -- Maps a OutExpr to a /trivial/ OutExpr + -- The key of cs_map is stripped of all Ticks + -- It maps arbitrary expressions to trivial expressions + -- representing the same value. E.g @C a b@ to @x1@. + + , cs_rec_map :: CoreMap OutExpr + -- See Note [CSE for recursive bindings] + } + +emptyCSEnv :: InScopeSet -> CSEnv +emptyCSEnv in_scope + = CS { cs_map = emptyCoreMap + , cs_rec_map = emptyCoreMap + , cs_subst = mkEmptySubst in_scope } + +lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr +lookupCSEnv (CS { cs_map = csmap }) expr + = lookupCoreMap csmap expr + +-- | @extendCSEnv env e triv_expr@ will replace any occurrence of @e@ with @triv_expr@ going forward. +extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv +extendCSEnv cse expr triv_expr + = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr } + where + sexpr = stripTicksE tickishFloatable expr + +extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv +-- See Note [CSE for recursive bindings] +extendCSRecEnv cse bndr expr triv_expr + = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr } + +lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr +-- See Note [CSE for recursive bindings] +lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr + = lookupCoreMap csmap (Lam bndr expr) + +csEnvSubst :: CSEnv -> Subst +csEnvSubst = cs_subst + +lookupSubst :: CSEnv -> Id -> OutExpr +lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst sub x + +extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv +extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs } + +-- | Add clones to the substitution to deal with shadowing. See +-- Note [Shadowing in CSE] for more details. You should call this whenever +-- you go under a binder. +addBinder :: CSEnv -> Var -> (CSEnv, Var) +addBinder cse v = (cse { cs_subst = sub' }, v') + where + (sub', v') = substBndr (cs_subst cse) v + +addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) +addBinders cse vs = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substBndrs (cs_subst cse) vs + +addNonRecBinder :: TopLevelFlag -> CSEnv -> Var -> (CSEnv, Var) +-- Don't clone at top level +addNonRecBinder top_lvl cse v + | isTopLevel top_lvl = (cse, v) + | otherwise = (cse { cs_subst = sub' }, v') + where + (sub', v') = substBndr (cs_subst cse) v + +addRecBinders :: Traversable f => TopLevelFlag -> CSEnv -> f Id -> (CSEnv, f Id) +-- Don't clone at top level +addRecBinders top_lvl cse vs + | isTopLevel top_lvl = (cse, vs) + | otherwise = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substRecBndrs (cs_subst cse) vs +{-# INLINE addRecBinders #-} diff --git a/GHC/Core/Opt/CallArity.hs b/GHC/Core/Opt/CallArity.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/CallArity.hs @@ -0,0 +1,763 @@ +-- +-- Copyright (c) 2014 Joachim Breitner +-- + + +module GHC.Core.Opt.CallArity + ( callArityAnalProgram + , callArityRHS -- for testing + ) where + +import GHC.Prelude + +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Types.Basic +import GHC.Core +import GHC.Types.Id +import GHC.Core.Opt.Arity ( typeArity ) +import GHC.Core.Utils ( exprIsCheap, exprIsTrivial ) +import GHC.Data.Graph.UnVar +import GHC.Types.Demand +import GHC.Utils.Misc + +import Control.Arrow ( first, second ) +import Data.List.NonEmpty ( NonEmpty (..) ) + + +{- +%************************************************************************ +%* * + Call Arity Analysis +%* * +%************************************************************************ + +Note [Call Arity: The goal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The goal of this analysis is to find out if we can eta-expand a local function +based on how it is being called. The motivating example is this code, +which comes up when we implement foldl using foldr, and do list fusion: + + let go = \x -> let d = case ... of + False -> go (x+1) + True -> id + in \z -> d (x + z) + in go 1 0 + +If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of +partial function applications, which would be bad. + +The function `go` has a type of arity two, but only one lambda is manifest. +Furthermore, an analysis that only looks at the RHS of go cannot be sufficient +to eta-expand go: If `go` is ever called with one argument (and the result used +multiple times), we would be doing the work in `...` multiple times. + +So `callArityAnalProgram` looks at the whole let expression to figure out if +all calls are nice, i.e. have a high enough arity. It then stores the result in +the `calledArity` field of the `IdInfo` of `go`, which the next simplifier +phase will eta-expand. + +The specification of the `calledArity` field is: + + No work will be lost if you eta-expand me to the arity in `calledArity`. + +What we want to know for a variable +----------------------------------- + +For every let-bound variable we'd like to know: + 1. A lower bound on the arity of all calls to the variable, and + 2. whether the variable is being called at most once or possibly multiple + times. + +It is always okay to lower the arity, or pretend that there are multiple calls. +In particular, "Minimum arity 0 and possibly called multiple times" is always +correct. + + +What we want to know from an expression +--------------------------------------- + +In order to obtain that information for variables, we analyze expression and +obtain bits of information: + + I. The arity analysis: + For every variable, whether it is absent, or called, + and if called, with what arity. + + II. The Co-Called analysis: + For every two variables, whether there is a possibility that both are being + called. + We obtain as a special case: For every variable, whether there is a + possibility that it is being called twice. + +For efficiency reasons, we gather this information only for a set of +*interesting variables*, to avoid spending time on, e.g., variables from pattern matches. + +The two analysis are not completely independent, as a higher arity can improve +the information about what variables are being called once or multiple times. + +Note [Analysis I: The arity analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The arity analysis is quite straightforward: The information about an +expression is an + VarEnv Arity +where absent variables are bound to Nothing and otherwise to a lower bound to +their arity. + +When we analyze an expression, we analyze it with a given context arity. +Lambdas decrease and applications increase the incoming arity. Analysing a +variable will put that arity in the environment. In `let`s or `case`s all the +results from the various subexpressions are lub'd, which takes the point-wise +minimum (considering Nothing an infinity). + + +Note [Analysis II: The Co-Called analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The second part is more sophisticated. For reasons explained below, it is not +sufficient to simply know how often an expression evaluates a variable. Instead +we need to know which variables are possibly called together. + +The data structure here is an undirected graph of variables, which is provided +by the abstract + UnVarGraph + +It is safe to return a larger graph, i.e. one with more edges. The worst case +(i.e. the least useful and always correct result) is the complete graph on all +free variables, which means that anything can be called together with anything +(including itself). + +Notation for the following: +C(e) is the co-called result for e. +G₁∪G₂ is the union of two graphs +fv is the set of free variables (conveniently the domain of the arity analysis result) +S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ } +S² is the complete graph on the set of variables S, S² = S×S +C'(e) is a variant for bound expression: + If e is called at most once, or it is and stays a thunk (after the analysis), + it is simply C(e). Otherwise, the expression can be called multiple times + and we return (fv e)² + +The interesting cases of the analysis: + * Var v: + No other variables are being called. + Return {} (the empty graph) + * Lambda v e, under arity 0: + This means that e can be evaluated many times and we cannot get + any useful co-call information. + Return (fv e)² + * Case alternatives alt₁,alt₂,...: + Only one can be executed, so + Return (alt₁ ∪ alt₂ ∪...) + * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂: + We get the results from both sides, with the argument evaluated at most once. + Additionally, anything called by e₁ can possibly be called with anything + from e₂. + Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂) + * App e₁ x: + As this is already in A-normal form, CorePrep will not separately lambda + bind (and hence share) x. So we conservatively assume multiple calls to x here + Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)} + * Let v = rhs in body: + In addition to the results from the subexpressions, add all co-calls from + everything that the body calls together with v to everything that is called + by v. + Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)} + * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body + Tricky. + We assume that it is really mutually recursive, i.e. that every variable + calls one of the others, and that this is strongly connected (otherwise we + return an over-approximation, so that's ok), see Note [Recursion and fixpointing]. + + Let V = {v₁,...vₙ}. + Assume that the vs have been analysed with an incoming demand and + cardinality consistent with the final result (this is the fixed-pointing). + Again we can use the results from all subexpressions. + In addition, for every variable vᵢ, we need to find out what it is called + with (call this set Sᵢ). There are two cases: + * If vᵢ is a function, we need to go through all right-hand-sides and bodies, + and collect every variable that is called together with any variable from V: + Sᵢ = {v' | j ∈ {1,...,n}, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } + * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to + exclude it from this set: + Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } + Finally, combine all this: + Return: C(body) ∪ + C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ + (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ) + +Using the result: Eta-Expansion +------------------------------- + +We use the result of these two analyses to decide whether we can eta-expand the +rhs of a let-bound variable. + +If the variable is already a function (exprIsCheap), and all calls to the +variables have a higher arity than the current manifest arity (i.e. the number +of lambdas), expand. + +If the variable is a thunk we must be careful: Eta-Expansion will prevent +sharing of work, so this is only safe if there is at most one call to the +function. Therefore, we check whether {v,v} ∈ G. + + Example: + + let n = case .. of .. -- A thunk! + in n 0 + n 1 + + vs. + + let n = case .. of .. + in case .. of T -> n 0 + F -> n 1 + + We are only allowed to eta-expand `n` if it is going to be called at most + once in the body of the outer let. So we need to know, for each variable + individually, that it is going to be called at most once. + + +Why the co-call graph? +---------------------- + +Why is it not sufficient to simply remember which variables are called once and +which are called multiple times? It would be in the previous example, but consider + + let n = case .. of .. + in case .. of + True -> let go = \y -> case .. of + True -> go (y + n 1) + False > n + in go 1 + False -> n + +vs. + + let n = case .. of .. + in case .. of + True -> let go = \y -> case .. of + True -> go (y+1) + False > n + in go 1 + False -> n + +In both cases, the body and the rhs of the inner let call n at most once. +But only in the second case that holds for the whole expression! The +crucial difference is that in the first case, the rhs of `go` can call +*both* `go` and `n`, and hence can call `n` multiple times as it recurses, +while in the second case find out that `go` and `n` are not called together. + + +Why co-call information for functions? +-------------------------------------- + +Although for eta-expansion we need the information only for thunks, we still +need to know whether functions are being called once or multiple times, and +together with what other functions. + + Example: + + let n = case .. of .. + f x = n (x+1) + in f 1 + f 2 + + vs. + + let n = case .. of .. + f x = n (x+1) + in case .. of T -> f 0 + F -> f 1 + + Here, the body of f calls n exactly once, but f itself is being called + multiple times, so eta-expansion is not allowed. + + +Note [Analysis type signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The workhorse of the analysis is the function `callArityAnal`, with the +following type: + + type CallArityRes = (UnVarGraph, VarEnv Arity) + callArityAnal :: + Arity -> -- The arity this expression is called with + VarSet -> -- The set of interesting variables + CoreExpr -> -- The expression to analyse + (CallArityRes, CoreExpr) + +and the following specification: + + ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr + + <=> + + Assume the expression `expr` is being passed `arity` arguments. Then it holds that + * The domain of `callArityEnv` is a subset of `interestingIds`. + * Any variable from `interestingIds` that is not mentioned in the `callArityEnv` + is absent, i.e. not called at all. + * Every call from `expr` to a variable bound to n in `callArityEnv` has at + least n value arguments. + * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`, + then in no execution of `expr` both are being called. + Furthermore, expr' is expr with the callArity field of the `IdInfo` updated. + + +Note [Which variables are interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The analysis would quickly become prohibitive expensive if we would analyse all +variables; for most variables we simply do not care about how often they are +called, i.e. variables bound in a pattern match. So interesting are variables that are + * top-level or let bound + * and possibly functions (typeArity > 0) + +Note [Taking boring variables into account] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If we decide that the variable bound in `let x = e1 in e2` is not interesting, +the analysis of `e2` will not report anything about `x`. To ensure that +`callArityBind` does still do the right thing we have to take that into account +every time we would be lookup up `x` in the analysis result of `e2`. + * Instead of calling lookupCallArityRes, we return (0, True), indicating + that this variable might be called many times with no arguments. + * Instead of checking `calledWith x`, we assume that everything can be called + with it. + * In the recursive case, when calclulating the `cross_calls`, if there is + any boring variable in the recursive group, we ignore all co-call-results + and directly go to a very conservative assumption. + +The last point has the nice side effect that the relatively expensive +integration of co-call results in a recursive groups is often skipped. This +helped to avoid the compile time blowup in some real-world code with large +recursive groups (#10293). + +Note [Recursion and fixpointing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For a mutually recursive let, we begin by + 1. analysing the body, using the same incoming arity as for the whole expression. + 2. Then we iterate, memoizing for each of the bound variables the last + analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes. + 3. We combine the analysis result from the body and the memoized results for + the arguments (if already present). + 4. For each variable, we find out the incoming arity and whether it is called + once, based on the current analysis result. If this differs from the + memoized results, we re-analyse the rhs and update the memoized table. + 5. If nothing had to be reanalyzed, we are done. + Otherwise, repeat from step 3. + + +Note [Thunks in recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We never eta-expand a thunk in a recursive group, on the grounds that if it is +part of a recursive group, then it will be called multiple times. + +This is not necessarily true, e.g. it would be safe to eta-expand t2 (but not +t1) in the following code: + + let go x = t1 + t1 = if ... then t2 else ... + t2 = if ... then go 1 else ... + in go 0 + +Detecting this would require finding out what variables are only ever called +from thunks. While this is certainly possible, we yet have to see this to be +relevant in the wild. + + +Note [Analysing top-level binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We can eta-expand top-level-binds if they are not exported, as we see all calls +to them. The plan is as follows: Treat the top-level binds as nested lets around +a body representing “all external calls”, which returns a pessimistic +CallArityRes (the co-call graph is the complete graph, all arityies 0). + +Note [Trimming arity] +~~~~~~~~~~~~~~~~~~~~~ +In the Call Arity papers, we are working on an untyped lambda calculus with no +other id annotations, where eta-expansion is always possible. But this is not +the case for Core! + 1. We need to ensure the invariant + callArity e <= typeArity (exprType e) + for the same reasons that exprArity needs this invariant (see Note + [typeArity invariants] in GHC.Core.Opt.Arity). + + If we are not doing that, a too-high arity annotation will be stored with + the id, confusing the simplifier later on. + + 2. Eta-expanding a right hand side might invalidate existing annotations. In + particular, if an id has a strictness annotation of <...><...>b, then + passing two arguments to it will definitely bottom out, so the simplifier + will throw away additional parameters. This conflicts with Call Arity! So + we ensure that we never eta-expand such a value beyond the number of + arguments mentioned in the strictness signature. + See #10176 for a real-world-example. + +Note [What is a thunk] +~~~~~~~~~~~~~~~~~~~~~~ + +Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a +thunk, not eta-expanded, to avoid losing any sharing. This is also how the +published papers on Call Arity describe it. + +In practice, there are thunks that do a just little work, such as +pattern-matching on a variable, and the benefits of eta-expansion likely +outweigh the cost of doing that repeatedly. Therefore, this implementation of +Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk. + +Note [Call Arity and Join Points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The Call Arity analysis does not care about join points, and treats them just +like normal functions. This is ok. + +The analysis *could* make use of the fact that join points are always evaluated +in the same context as the join-binding they are defined in and are always +one-shot, and handle join points separately, as suggested in +https://gitlab.haskell.org/ghc/ghc/issues/13479#note_134870. +This *might* be more efficient (for example, join points would not have to be +considered interesting variables), but it would also add redundant code. So for +now we do not do that. + +The simplifier never eta-expands join points (it instead pushes extra arguments from +an eta-expanded context into the join point’s RHS), so the call arity +annotation on join points is not actually used. As it would be equally valid +(though less efficient) to eta-expand join points, this is the simplifier's +choice, and hence Call Arity sets the call arity for join points as well. +-} + +-- Main entry point + +callArityAnalProgram :: CoreProgram -> CoreProgram +callArityAnalProgram binds = binds' + where + (_, binds') = callArityTopLvl [] emptyVarSet binds + +-- See Note [Analysing top-level binds] +callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind]) +callArityTopLvl exported _ [] + = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported]) + , [] ) +callArityTopLvl exported int1 (b:bs) + = (ae2, b':bs') + where + int2 = bindersOf b + exported' = filter isExportedId int2 ++ exported + int' = int1 `addInterestingBinds` b + (ae1, bs') = callArityTopLvl exported' int' bs + (ae2, b') = callArityBind (boringBinds b) ae1 int1 b + + +callArityRHS :: CoreExpr -> CoreExpr +callArityRHS = snd . callArityAnal 0 emptyVarSet + +-- The main analysis function. See Note [Analysis type signature] +callArityAnal :: + Arity -> -- The arity this expression is called with + VarSet -> -- The set of interesting variables + CoreExpr -> -- The expression to analyse + (CallArityRes, CoreExpr) + -- How this expression uses its interesting variables + -- and the expression with IdInfo updated + +-- The trivial base cases +callArityAnal _ _ e@(Lit _) + = (emptyArityRes, e) +callArityAnal _ _ e@(Type _) + = (emptyArityRes, e) +callArityAnal _ _ e@(Coercion _) + = (emptyArityRes, e) +-- The transparent cases +callArityAnal arity int (Tick t e) + = second (Tick t) $ callArityAnal arity int e +callArityAnal arity int (Cast e co) + = second (\e -> Cast e co) $ callArityAnal arity int e + +-- The interesting case: Variables, Lambdas, Lets, Applications, Cases +callArityAnal arity int e@(Var v) + | v `elemVarSet` int + = (unitArityRes v arity, e) + | otherwise + = (emptyArityRes, e) + +-- Non-value lambdas are ignored +callArityAnal arity int (Lam v e) | not (isId v) + = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e + +-- We have a lambda that may be called multiple times, so its free variables +-- can all be co-called. +callArityAnal 0 int (Lam v e) + = (ae', Lam v e') + where + (ae, e') = callArityAnal 0 (int `delVarSet` v) e + ae' = calledMultipleTimes ae +-- We have a lambda that we are calling. decrease arity. +callArityAnal arity int (Lam v e) + = (ae, Lam v e') + where + (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e + +-- Application. Increase arity for the called expression, nothing to know about +-- the second +callArityAnal arity int (App e (Type t)) + = second (\e -> App e (Type t)) $ callArityAnal arity int e +callArityAnal arity int (App e1 e2) + = (final_ae, App e1' e2') + where + (ae1, e1') = callArityAnal (arity + 1) int e1 + (ae2, e2') = callArityAnal 0 int e2 + -- If the argument is trivial (e.g. a variable), then it will _not_ be + -- let-bound in the Core to STG transformation (CorePrep actually), + -- so no sharing will happen here, and we have to assume many calls. + ae2' | exprIsTrivial e2 = calledMultipleTimes ae2 + | otherwise = ae2 + final_ae = ae1 `both` ae2' + +-- Case expression. +callArityAnal arity int (Case scrut bndr ty alts) + = -- pprTrace "callArityAnal:Case" + -- (vcat [ppr scrut, ppr final_ae]) + (final_ae, Case scrut' bndr ty alts') + where + (alt_aes, alts') = unzip $ map go alts + go (Alt dc bndrs e) = let (ae, e') = callArityAnal arity (int `delVarSetList` (bndr:bndrs)) e + in (ae, Alt dc bndrs e') + alt_ae = lubRess alt_aes + (scrut_ae, scrut') = callArityAnal 0 int scrut + final_ae = scrut_ae `both` alt_ae + +-- For lets, use callArityBind +callArityAnal arity int (Let bind e) + = -- pprTrace "callArityAnal:Let" + -- (vcat [ppr v, ppr arity, ppr n, ppr final_ae ]) + (final_ae, Let bind' e') + where + int_body = int `addInterestingBinds` bind + (ae_body, e') = callArityAnal arity int_body e + (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind + +-- Which bindings should we look at? +-- See Note [Which variables are interesting] +isInteresting :: Var -> Bool +isInteresting v = typeArity (idType v) > 0 + +interestingBinds :: CoreBind -> [Var] +interestingBinds = filter isInteresting . bindersOf + +boringBinds :: CoreBind -> VarSet +boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf + +addInterestingBinds :: VarSet -> CoreBind -> VarSet +addInterestingBinds int bind + = int `delVarSetList` bindersOf bind -- Possible shadowing + `extendVarSetList` interestingBinds bind + +-- Used for both local and top-level binds +-- Second argument is the demand from the body +callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind) +-- Non-recursive let +callArityBind boring_vars ae_body int (NonRec v rhs) + | otherwise + = -- pprTrace "callArityBind:NonRec" + -- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity]) + (final_ae, NonRec v' rhs') + where + is_thunk = not (exprIsCheap rhs) -- see Note [What is a thunk] + -- If v is boring, we will not find it in ae_body, but always assume (0, False) + boring = v `elemVarSet` boring_vars + + (arity, called_once) + | boring = (0, False) -- See Note [Taking boring variables into account] + | otherwise = lookupCallArityRes ae_body v + safe_arity | called_once = arity + | is_thunk = 0 -- A thunk! Do not eta-expand + | otherwise = arity + + -- See Note [Trimming arity] + trimmed_arity = trimArity v safe_arity + + (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs + + + ae_rhs'| called_once = ae_rhs + | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once + | otherwise = calledMultipleTimes ae_rhs + + called_by_v = domRes ae_rhs' + called_with_v + | boring = domRes ae_body + | otherwise = calledWith ae_body v `delUnVarSet` v + final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body + + v' = v `setIdCallArity` trimmed_arity + + +-- Recursive let. See Note [Recursion and fixpointing] +callArityBind boring_vars ae_body int b@(Rec binds) + = -- (if length binds > 300 then + -- pprTrace "callArityBind:Rec" + -- (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $ + (final_ae, Rec binds') + where + -- See Note [Taking boring variables into account] + any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds] + + int_body = int `addInterestingBinds` b + (ae_rhs, binds') = fix initial_binds + final_ae = bindersOf b `resDelList` ae_rhs + + initial_binds = [(i,Nothing,e) | (i,e) <- binds] + + fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)]) + fix ann_binds + | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $ + any_change + = fix ann_binds' + | otherwise + = (ae, map (\(i, _, e) -> (i, e)) ann_binds') + where + aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ] + ae = callArityRecEnv any_boring aes_old ae_body + + rerun (i, mbLastRun, rhs) + | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae) + -- No call to this yet, so do nothing + = (False, (i, Nothing, rhs)) + + | Just (old_called_once, old_arity, _) <- mbLastRun + , called_once == old_called_once + , new_arity == old_arity + -- No change, no need to re-analyze + = (False, (i, mbLastRun, rhs)) + + | otherwise + -- We previously analyzed this with a different arity (or not at all) + = let is_thunk = not (exprIsCheap rhs) -- see Note [What is a thunk] + + safe_arity | is_thunk = 0 -- See Note [Thunks in recursive groups] + | otherwise = new_arity + + -- See Note [Trimming arity] + trimmed_arity = trimArity i safe_arity + + (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs + + ae_rhs' | called_once = ae_rhs + | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once + | otherwise = calledMultipleTimes ae_rhs + + i' = i `setIdCallArity` trimmed_arity + + in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs')) + where + -- See Note [Taking boring variables into account] + (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False) + | otherwise = lookupCallArityRes ae i + + (changes, ann_binds') = unzip $ map rerun ann_binds + any_change = or changes + +-- Combining the results from body and rhs, (mutually) recursive case +-- See Note [Analysis II: The Co-Called analysis] +callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes +callArityRecEnv any_boring ae_rhss ae_body + = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $ + ae_new + where + vars = map fst ae_rhss + + ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body + + cross_calls + -- See Note [Taking boring variables into account] + | any_boring = completeGraph (domRes ae_combined) + -- Also, calculating cross_calls is expensive. Simply be conservative + -- if the mutually recursive group becomes too large. + | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined) + | otherwise = unionUnVarGraphs $ map cross_call ae_rhss + cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v + where + is_thunk = idCallArity v == 0 + -- What rhs are relevant as happening before (or after) calling v? + -- If v is a thunk, everything from all the _other_ variables + -- If v is not a thunk, everything can happen. + ae_before_v | is_thunk = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body + | otherwise = ae_combined + -- What do we want to know from these? + -- Which calls can happen next to any recursive call. + called_with_v + = unionUnVarSets $ map (calledWith ae_before_v) vars + called_by_v = domRes ae_rhs + + ae_new = first (cross_calls `unionUnVarGraph`) ae_combined + +-- See Note [Trimming arity] +trimArity :: Id -> Arity -> Arity +trimArity v a = minimum (a :| max_arity_by_type : max_arity_by_strsig : []) + where + max_arity_by_type = typeArity (idType v) + max_arity_by_strsig + | isDeadEndDiv result_info = length demands + | otherwise = a + + (demands, result_info) = splitDmdSig (idDmdSig v) + +--------------------------------------- +-- Functions related to CallArityRes -- +--------------------------------------- + +-- Result type for the two analyses. +-- See Note [Analysis I: The arity analysis] +-- and Note [Analysis II: The Co-Called analysis] +type CallArityRes = (UnVarGraph, VarEnv Arity) + +emptyArityRes :: CallArityRes +emptyArityRes = (emptyUnVarGraph, emptyVarEnv) + +unitArityRes :: Var -> Arity -> CallArityRes +unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity) + +resDelList :: [Var] -> CallArityRes -> CallArityRes +resDelList vs ae = foldl' (flip resDel) ae vs + +resDel :: Var -> CallArityRes -> CallArityRes +resDel v (!g, !ae) = (g `delNode` v, ae `delVarEnv` v) + +domRes :: CallArityRes -> UnVarSet +domRes (_, ae) = varEnvDomain ae + +-- In the result, find out the minimum arity and whether the variable is called +-- at most once. +lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool) +lookupCallArityRes (g, ae) v + = case lookupVarEnv ae v of + Just a -> (a, not (g `hasLoopAt` v)) + Nothing -> (0, False) + +calledWith :: CallArityRes -> Var -> UnVarSet +calledWith (g, _) v = neighbors g v + +addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes +addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`) + +-- Replaces the co-call graph by a complete graph (i.e. no information) +calledMultipleTimes :: CallArityRes -> CallArityRes +calledMultipleTimes res = first (const (completeGraph (domRes res))) res + +-- Used for application and cases +both :: CallArityRes -> CallArityRes -> CallArityRes +both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2 + +-- Used when combining results from alternative cases; take the minimum +lubRes :: CallArityRes -> CallArityRes -> CallArityRes +lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2) + +lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity +lubArityEnv = plusVarEnv_C min + +lubRess :: [CallArityRes] -> CallArityRes +lubRess = foldl' lubRes emptyArityRes diff --git a/GHC/Core/Opt/CallerCC.hs b/GHC/Core/Opt/CallerCC.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/CallerCC.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TupleSections #-} + +-- | Adds cost-centers to call sites selected with the @-fprof-caller=...@ +-- flag. +module GHC.Core.Opt.CallerCC + ( addCallerCostCentres + , CallerCcFilter(..) + , NamePattern(..) + , parseCallerCcFilter + ) where + +import Data.Maybe + +import Control.Applicative +import GHC.Utils.Monad.State.Strict +import Control.Monad + +import GHC.Prelude +import GHC.Utils.Outputable as Outputable +import GHC.Driver.DynFlags +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State +import GHC.Types.Name hiding (varName) +import GHC.Types.Tickish +import GHC.Unit.Module.ModGuts +import GHC.Types.SrcLoc +import GHC.Types.Var +import GHC.Unit.Types +import GHC.Data.FastString +import GHC.Core +import GHC.Core.Opt.Monad +import GHC.Core.Opt.CallerCC.Types + + +addCallerCostCentres :: ModGuts -> CoreM ModGuts +addCallerCostCentres guts = do + dflags <- getDynFlags + let filters = callerCcFilters dflags + let env :: Env + env = Env + { thisModule = mg_module guts + , ccState = newCostCentreState + , countEntries = gopt Opt_ProfCountEntries dflags + , revParents = [] + , filters = filters + } + let guts' = guts { mg_binds = doCoreProgram env (mg_binds guts) + } + return guts' + +doCoreProgram :: Env -> CoreProgram -> CoreProgram +doCoreProgram env binds = flip evalState newCostCentreState $ do + mapM (doBind env) binds + +doBind :: Env -> CoreBind -> M CoreBind +doBind env (NonRec b rhs) = NonRec b <$> doExpr (addParent b env) rhs +doBind env (Rec bs) = Rec <$> mapM doPair bs + where + doPair (b,rhs) = (b,) <$> doExpr (addParent b env) rhs + +doExpr :: Env -> CoreExpr -> M CoreExpr +doExpr env e@(Var v) + | needsCallSiteCostCentre env v = do + let nameDoc :: SDoc + nameDoc = withUserStyle alwaysQualify DefaultDepth $ + hcat (punctuate dot (map ppr (parents env))) <> parens (text "calling:" <> ppr v) + + ccName :: CcName + ccName = mkFastString $ renderWithContext defaultSDocContext nameDoc + ccIdx <- getCCIndex' ccName + let count = countEntries env + span = case revParents env of + top:_ -> nameSrcSpan $ varName top + _ -> noSrcSpan + cc = NormalCC (mkExprCCFlavour ccIdx) ccName (thisModule env) span + tick :: CoreTickish + tick = ProfNote cc count True + pure $ Tick tick e + | otherwise = pure e +doExpr _env e@(Lit _) = pure e +doExpr env (f `App` x) = App <$> doExpr env f <*> doExpr env x +doExpr env (Lam b x) = Lam b <$> doExpr env x +doExpr env (Let b rhs) = Let <$> doBind env b <*> doExpr env rhs +doExpr env (Case scrut b ty alts) = + Case <$> doExpr env scrut <*> pure b <*> pure ty <*> mapM doAlt alts + where + doAlt (Alt con bs rhs) = Alt con bs <$> doExpr env rhs +doExpr env (Cast expr co) = Cast <$> doExpr env expr <*> pure co +doExpr env (Tick t e) = Tick t <$> doExpr env e +doExpr _env e@(Type _) = pure e +doExpr _env e@(Coercion _) = pure e + +type M = State CostCentreState + +getCCIndex' :: FastString -> M CostCentreIndex +getCCIndex' name = state (getCCIndex name) + +data Env = Env + { thisModule :: Module + , countEntries :: !Bool + , ccState :: CostCentreState + , revParents :: [Id] + , filters :: [CallerCcFilter] + } + +addParent :: Id -> Env -> Env +addParent i env = env { revParents = i : revParents env } + +parents :: Env -> [Id] +parents env = reverse (revParents env) + +needsCallSiteCostCentre :: Env -> Id -> Bool +needsCallSiteCostCentre env i = + any matches (filters env) + where + matches :: CallerCcFilter -> Bool + matches ccf = + checkModule && checkFunc + where + checkModule = + case ccfModuleName ccf of + Just modFilt + | Just iMod <- nameModule_maybe (varName i) + -> moduleName iMod == modFilt + | otherwise -> False + Nothing -> True + checkFunc = + occNameMatches (ccfFuncName ccf) (getOccName i) + diff --git a/GHC/Core/Opt/CallerCC/Types.hs b/GHC/Core/Opt/CallerCC/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/CallerCC/Types.hs @@ -0,0 +1,122 @@ +module GHC.Core.Opt.CallerCC.Types ( NamePattern(..) + , CallerCcFilter(..) + , occNameMatches + , parseCallerCcFilter + , parseNamePattern + ) where + +import Data.Word (Word8) +import Data.Maybe + +import Control.Applicative +import Data.Either +import Control.Monad +import qualified Text.ParserCombinators.ReadP as P + +import GHC.Prelude +import GHC.Utils.Outputable as Outputable +import GHC.Types.Name hiding (varName) +import GHC.Utils.Panic +import qualified GHC.Utils.Binary as B +import Data.Char +import Control.DeepSeq + +import Language.Haskell.Syntax.Module.Name + + +data NamePattern + = PChar Char NamePattern + | PWildcard NamePattern + | PEnd + +instance Outputable NamePattern where + ppr (PChar c rest) = char c <> ppr rest + ppr (PWildcard rest) = char '*' <> ppr rest + ppr PEnd = Outputable.empty + +instance NFData NamePattern where + rnf (PChar c n) = rnf c `seq` rnf n + rnf (PWildcard np) = rnf np + rnf PEnd = () + +instance B.Binary NamePattern where + get bh = do + tag <- B.get bh + case tag :: Word8 of + 0 -> PChar <$> B.get bh <*> B.get bh + 1 -> PWildcard <$> B.get bh + 2 -> pure PEnd + _ -> panic "Binary(NamePattern): Invalid tag" + put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y + put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x + put_ bh PEnd = B.put_ bh (2 :: Word8) + +occNameMatches :: NamePattern -> OccName -> Bool +occNameMatches pat = go pat . occNameString + where + go :: NamePattern -> String -> Bool + go PEnd "" = True + go (PChar c rest) (d:s) + = d == c && go rest s + go (PWildcard rest) s + = go rest s || go (PWildcard rest) (tail s) + go _ _ = False + + + +type Parser = P.ReadP + +parseNamePattern :: Parser NamePattern +parseNamePattern = namePattern + where + namePattern = star P.<++ wildcard P.<++ char P.<++ end + star = PChar '*' <$ P.string "\\*" <*> namePattern + wildcard = do + void $ P.char '*' + PWildcard <$> namePattern + char = PChar <$> P.get <*> namePattern + end = PEnd <$ P.eof + +data CallerCcFilter + = CallerCcFilter { ccfModuleName :: Maybe ModuleName + , ccfFuncName :: NamePattern + } + +instance NFData CallerCcFilter where + rnf (CallerCcFilter mn n) = rnf mn `seq` rnf n + +instance Outputable CallerCcFilter where + ppr ccf = + maybe (char '*') ppr (ccfModuleName ccf) + <> char '.' + <> ppr (ccfFuncName ccf) + +instance B.Binary CallerCcFilter where + get bh = CallerCcFilter <$> B.get bh <*> B.get bh + put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y + +parseCallerCcFilter :: String -> Either String CallerCcFilter +parseCallerCcFilter inp = + case P.readP_to_S parseCallerCcFilter' inp of + ((result, ""):_) -> Right result + _ -> Left $ "parse error on " ++ inp + +parseCallerCcFilter' :: Parser CallerCcFilter +parseCallerCcFilter' = + CallerCcFilter + <$> moduleFilter + <* P.char '.' + <*> parseNamePattern + where + moduleFilter :: Parser (Maybe ModuleName) + moduleFilter = + (Just . mkModuleName <$> moduleName) + <|> + (Nothing <$ P.char '*') + + moduleName :: Parser String + moduleName = do + c <- P.satisfy isUpper + cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_') + rest <- optional $ P.char '.' >> fmap ('.':) moduleName + return $ c : (cs ++ fromMaybe "" rest) diff --git a/GHC/Core/Opt/ConstantFold.hs b/GHC/Core/Opt/ConstantFold.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/ConstantFold.hs @@ -0,0 +1,3634 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Conceptually, constant folding should be parameterized with the kind +of target machine to get identical behaviour during compilation time +and runtime. We cheat a little bit here... + +ToDo: + check boundaries before folding, e.g. we can fold the Float addition + (i1 + i2) only if it results in a valid Float. +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} + +-- | Constant Folder +module GHC.Core.Opt.ConstantFold + ( primOpRules + , builtinRules + , caseRules + , caseRules2 + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Float + +import GHC.Types.Id.Make ( unboxedUnitExpr ) +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Types.Name.Occurrence ( occNameFS ) +import GHC.Types.Tickish +import GHC.Types.Name ( Name, nameOccName ) +import GHC.Types.Basic + +import GHC.Core +import GHC.Core.Make +import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe ) +import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) +import GHC.Core.Utils ( cheapEqExpr, exprIsHNF + , stripTicksTop, stripTicksTopT, mkTicks ) +import GHC.Core.Multiplicity +import GHC.Core.Rules.Config +import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCon + ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConSingleDataCon, tyConFamilySize + , isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon ) +import GHC.Core.Map.Expr ( eqCoreExpr ) + +import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey ) +import GHC.Builtin.PrimOps.Ids (primOpId) +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names + +import GHC.Cmm.MachOp ( FMASign(..) ) +import GHC.Cmm.Type ( Width(..) ) + +import GHC.Data.FastString + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import Control.Applicative ( Alternative(..) ) +import Control.Monad +import Data.Functor (($>)) +import qualified Data.ByteString as BS +import Data.Ratio +import Data.Word +import Data.Maybe (fromMaybe, fromJust) + +{- +Note [Constant folding] +~~~~~~~~~~~~~~~~~~~~~~~ +primOpRules generates a rewrite rule for each primop +These rules do what is often called "constant folding" +E.g. the rules for +# might say + 4 +# 5 = 9 +Well, of course you'd need a lot of rules if you did it +like that, so we use a BuiltinRule instead, so that we +can match in any two literal values. So the rule is really +more like + (Lit x) +# (Lit y) = Lit (x+#y) +where the (+#) on the rhs is done at compile time + +That is why these rules are built in here. +-} + +primOpRules :: Name -> PrimOp -> Maybe CoreRule +primOpRules nm = \case + TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ] + DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + + -- Int8 operations + Int8AddOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+)) + , identity zeroI8 + , addFoldingRules Int8AddOp int8Ops + ] + Int8SubOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (-)) + , rightIdentity zeroI8 + , equalArgs $> Lit zeroI8 + , subFoldingRules Int8SubOp int8Ops + ] + Int8MulOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (*)) + , zeroElem + , identity oneI8 + , mulFoldingRules Int8MulOp int8Ops + ] + Int8QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 quot) + , leftZero + , rightIdentity oneI8 + , equalArgs $> Lit oneI8 + , quotFoldingRules int8Ops + ] + Int8RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 rem) + , leftZero + , oneLit 1 $> Lit zeroI8 + , equalArgs $> Lit zeroI8 ] + Int8NegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , semiInversePrimOp Int8NegOp ] + Int8SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 (const shiftL) + , rightIdentity zeroI8 ] + Int8SraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 (const shiftR) + , rightIdentity zeroI8 ] + Int8SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 $ const $ shiftRightLogical @Word8 + , rightIdentity zeroI8 ] + + -- Word8 operations + Word8AddOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (+)) + , identity zeroW8 + , addFoldingRules Word8AddOp word8Ops + ] + Word8SubOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (-)) + , rightIdentity zeroW8 + , equalArgs $> Lit zeroW8 + , subFoldingRules Word8SubOp word8Ops + ] + Word8MulOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (*)) + , identity oneW8 + , mulFoldingRules Word8MulOp word8Ops + ] + Word8QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 quot) + , rightIdentity oneW8 + , quotFoldingRules word8Ops + ] + Word8RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 rem) + , leftZero + , oneLit 1 $> Lit zeroW8 + , equalArgs $> Lit zeroW8 ] + Word8AndOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.&.)) + , idempotent + , zeroElem + , identity (mkLitWord8 0xFF) + , sameArgIdempotentCommut Word8AndOp + , andFoldingRules word8Ops + ] + Word8OrOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.|.)) + , idempotent + , identity zeroW8 + , sameArgIdempotentCommut Word8OrOp + , orFoldingRules word8Ops + ] + Word8XorOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 xor) + , identity zeroW8 + , equalArgs $> Lit zeroW8 ] + Word8NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , semiInversePrimOp Word8NotOp ] + Word8SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord8 (const shiftL) ] + Word8SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord8 $ const $ shiftRightLogical @Word8 ] + + + -- Int16 operations + Int16AddOp -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (+)) + , identity zeroI16 + , addFoldingRules Int16AddOp int16Ops + ] + Int16SubOp -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (-)) + , rightIdentity zeroI16 + , equalArgs $> Lit zeroI16 + , subFoldingRules Int16SubOp int16Ops + ] + Int16MulOp -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (*)) + , zeroElem + , identity oneI16 + , mulFoldingRules Int16MulOp int16Ops + ] + Int16QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 quot) + , leftZero + , rightIdentity oneI16 + , equalArgs $> Lit oneI16 + , quotFoldingRules int16Ops + ] + Int16RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 rem) + , leftZero + , oneLit 1 $> Lit zeroI16 + , equalArgs $> Lit zeroI16 ] + Int16NegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , semiInversePrimOp Int16NegOp ] + Int16SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 (const shiftL) + , rightIdentity zeroI16 ] + Int16SraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 (const shiftR) + , rightIdentity zeroI16 ] + Int16SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 $ const $ shiftRightLogical @Word16 + , rightIdentity zeroI16 ] + + -- Word16 operations + Word16AddOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (+)) + , identity zeroW16 + , addFoldingRules Word16AddOp word16Ops + ] + Word16SubOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (-)) + , rightIdentity zeroW16 + , equalArgs $> Lit zeroW16 + , subFoldingRules Word16SubOp word16Ops + ] + Word16MulOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (*)) + , identity oneW16 + , mulFoldingRules Word16MulOp word16Ops + ] + Word16QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 quot) + , rightIdentity oneW16 + , quotFoldingRules word16Ops + ] + Word16RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 rem) + , leftZero + , oneLit 1 $> Lit zeroW16 + , equalArgs $> Lit zeroW16 ] + Word16AndOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.&.)) + , idempotent + , zeroElem + , identity (mkLitWord16 0xFFFF) + , sameArgIdempotentCommut Word16AndOp + , andFoldingRules word16Ops + ] + Word16OrOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.|.)) + , idempotent + , identity zeroW16 + , sameArgIdempotentCommut Word16OrOp + , orFoldingRules word16Ops + ] + Word16XorOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 xor) + , identity zeroW16 + , equalArgs $> Lit zeroW16 ] + Word16NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , semiInversePrimOp Word16NotOp ] + Word16SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord16 (const shiftL) ] + Word16SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord16 $ const $ shiftRightLogical @Word16 ] + + + -- Int32 operations + Int32AddOp -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (+)) + , identity zeroI32 + , addFoldingRules Int32AddOp int32Ops + ] + Int32SubOp -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (-)) + , rightIdentity zeroI32 + , equalArgs $> Lit zeroI32 + , subFoldingRules Int32SubOp int32Ops + ] + Int32MulOp -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (*)) + , zeroElem + , identity oneI32 + , mulFoldingRules Int32MulOp int32Ops + ] + Int32QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 quot) + , leftZero + , rightIdentity oneI32 + , equalArgs $> Lit oneI32 + , quotFoldingRules int32Ops + ] + Int32RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 rem) + , leftZero + , oneLit 1 $> Lit zeroI32 + , equalArgs $> Lit zeroI32 ] + Int32NegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , semiInversePrimOp Int32NegOp ] + Int32SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 (const shiftL) + , rightIdentity zeroI32 ] + Int32SraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 (const shiftR) + , rightIdentity zeroI32 ] + Int32SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 $ const $ shiftRightLogical @Word32 + , rightIdentity zeroI32 ] + + -- Word32 operations + Word32AddOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (+)) + , identity zeroW32 + , addFoldingRules Word32AddOp word32Ops + ] + Word32SubOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (-)) + , rightIdentity zeroW32 + , equalArgs $> Lit zeroW32 + , subFoldingRules Word32SubOp word32Ops + ] + Word32MulOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (*)) + , identity oneW32 + , mulFoldingRules Word32MulOp word32Ops + ] + Word32QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 quot) + , rightIdentity oneW32 + , quotFoldingRules word32Ops + ] + Word32RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 rem) + , leftZero + , oneLit 1 $> Lit zeroW32 + , equalArgs $> Lit zeroW32 ] + Word32AndOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.&.)) + , idempotent + , zeroElem + , identity (mkLitWord32 0xFFFFFFFF) + , sameArgIdempotentCommut Word32AndOp + , andFoldingRules word32Ops + ] + Word32OrOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.|.)) + , idempotent + , identity zeroW32 + , sameArgIdempotentCommut Word32OrOp + , orFoldingRules word32Ops + ] + Word32XorOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 xor) + , identity zeroW32 + , equalArgs $> Lit zeroW32 ] + Word32NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , semiInversePrimOp Word32NotOp ] + Word32SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 (const shiftL) ] + Word32SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 $ const $ shiftRightLogical @Word32 ] + + -- Int64 operations + Int64AddOp -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (+)) + , identity zeroI64 + , addFoldingRules Int64AddOp int64Ops + ] + Int64SubOp -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (-)) + , rightIdentity zeroI64 + , equalArgs $> Lit zeroI64 + , subFoldingRules Int64SubOp int64Ops + ] + Int64MulOp -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (*)) + , zeroElem + , identity oneI64 + , mulFoldingRules Int64MulOp int64Ops + ] + Int64QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 quot) + , leftZero + , rightIdentity oneI64 + , equalArgs $> Lit oneI64 + , quotFoldingRules int64Ops + ] + Int64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 rem) + , leftZero + , oneLit 1 $> Lit zeroI64 + , equalArgs $> Lit zeroI64 ] + Int64NegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , semiInversePrimOp Int64NegOp ] + Int64SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftL) + , rightIdentity zeroI64 ] + Int64SraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftR) + , rightIdentity zeroI64 ] + Int64SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 $ const $ shiftRightLogical @Word64 + , rightIdentity zeroI64 ] + + -- Word64 operations + Word64AddOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (+)) + , identity zeroW64 + , addFoldingRules Word64AddOp word64Ops + ] + Word64SubOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (-)) + , rightIdentity zeroW64 + , equalArgs $> Lit zeroW64 + , subFoldingRules Word64SubOp word64Ops + ] + Word64MulOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (*)) + , identity oneW64 + , mulFoldingRules Word64MulOp word64Ops + ] + Word64QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 quot) + , rightIdentity oneW64 + , quotFoldingRules word64Ops + ] + Word64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 rem) + , leftZero + , oneLit 1 $> Lit zeroW64 + , equalArgs $> Lit zeroW64 ] + Word64AndOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.&.)) + , idempotent + , zeroElem + , identity (mkLitWord64 0xFFFFFFFFFFFFFFFF) + , sameArgIdempotentCommut Word64AndOp + , andFoldingRules word64Ops + ] + Word64OrOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.|.)) + , idempotent + , identity zeroW64 + , sameArgIdempotentCommut Word64OrOp + , orFoldingRules word64Ops + ] + Word64XorOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 xor) + , identity zeroW64 + , equalArgs $> Lit zeroW64 ] + Word64NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , semiInversePrimOp Word64NotOp ] + Word64SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 (const shiftL) ] + Word64SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 $ const $ shiftRightLogical @Word64 ] + + -- Int operations + IntAddOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) + , identityPlatform zeroi + , addFoldingRules IntAddOp intOps + ] + IntSubOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) + , rightIdentityPlatform zeroi + , equalArgs >> retLit zeroi + , subFoldingRules IntSubOp intOps + ] + IntAddCOp -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+)) + , identityCPlatform zeroi ] + IntSubCOp -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-)) + , rightIdentityCPlatform zeroi + , equalArgs >> retLitNoC zeroi ] + IntMulOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) + , zeroElem + , identityPlatform onei + , mulFoldingRules IntMulOp intOps + ] + IntMul2Op -> mkPrimOpRule nm 2 [ do + [Lit (LitNumber _ l1), Lit (LitNumber _ l2)] <- getArgs + platform <- getPlatform + let r = l1 * l2 + pure $ mkCoreUnboxedTuple + [ Lit (if platformInIntRange platform r then zeroi platform else onei platform) + , mkIntLitWrap platform (r `shiftR` platformWordSizeInBits platform) + , mkIntLitWrap platform r + ] + + , zeroElem >>= \z -> + pure (mkCoreUnboxedTuple [z,z,z]) + + -- timesInt2# 1# other + -- ~~~> + -- (# 0#, 0# -# (other >># (WORD_SIZE_IN_BITS-1)), other #) + -- The second element is the sign bit + -- repeated to fill a word. + , identityPlatform onei >>= \other -> do + platform <- getPlatform + pure $ mkCoreUnboxedTuple + [ Lit (zeroi platform) + , mkCoreApps (Var (primOpId IntSubOp)) + [ Lit (zeroi platform) + , mkCoreApps (Var (primOpId IntSrlOp)) + [ other + , mkIntLit platform (fromIntegral (platformWordSizeInBits platform - 1)) + ] + ] + , other + ] + ] + IntQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) + , leftZero + , rightIdentityPlatform onei + , equalArgs >> retLit onei + , quotFoldingRules intOps + ] + IntRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) + , leftZero + , oneLit 1 >> retLit zeroi + , equalArgs >> retLit zeroi ] + IntAndOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) + , idempotent + , zeroElem + , identityPlatform (\p -> mkLitInt p (-1)) + , sameArgIdempotentCommut IntAndOp + , andFoldingRules intOps + ] + IntOrOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) + , idempotent + , identityPlatform zeroi + , sameArgIdempotentCommut IntOrOp + , orFoldingRules intOps + ] + IntXorOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) + , identityPlatform zeroi + , equalArgs >> retLit zeroi ] + IntNotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , semiInversePrimOp IntNotOp ] + IntNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , semiInversePrimOp IntNegOp ] + IntSllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const shiftL) + , rightIdentityPlatform zeroi ] + IntSraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const shiftR) + , rightIdentityPlatform zeroi ] + IntSrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt shiftRightLogicalNative + , rightIdentityPlatform zeroi ] + + -- Word operations + WordAddOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) + , identityPlatform zerow + , addFoldingRules WordAddOp wordOps + ] + WordSubOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) + , rightIdentityPlatform zerow + , equalArgs >> retLit zerow + , subFoldingRules WordSubOp wordOps + ] + WordAddCOp -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+)) + , identityCPlatform zerow ] + WordSubCOp -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-)) + , rightIdentityCPlatform zerow + , equalArgs >> retLitNoC zerow ] + WordMulOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) + , identityPlatform onew + , mulFoldingRules WordMulOp wordOps + ] + WordQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) + , rightIdentityPlatform onew + , quotFoldingRules wordOps + ] + WordRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) + , leftZero + , oneLit 1 >> retLit zerow + , equalArgs >> retLit zerow ] + WordAndOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) + , idempotent + , zeroElem + , identityPlatform (\p -> mkLitWord p (platformMaxWord p)) + , sameArgIdempotentCommut WordAndOp + , andFoldingRules wordOps + ] + WordOrOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) + , idempotent + , identityPlatform zerow + , sameArgIdempotentCommut WordOrOp + , orFoldingRules wordOps + ] + WordXorOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) + , identityPlatform zerow + , equalArgs >> retLit zerow ] + WordNotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , semiInversePrimOp WordNotOp ] + WordSllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ] + WordSrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogicalNative ] + + PopCnt8Op -> mkPrimOpRule nm 1 [ pop_count @Word8 ] + PopCnt16Op -> mkPrimOpRule nm 1 [ pop_count @Word16 ] + PopCnt32Op -> mkPrimOpRule nm 1 [ pop_count @Word32 ] + PopCnt64Op -> mkPrimOpRule nm 1 [ pop_count @Word64 ] + PopCntOp -> mkPrimOpRule nm 1 [ getWordSize >>= \case + PW4 -> pop_count @Word32 + PW8 -> pop_count @Word64 + ] + + Ctz8Op -> mkPrimOpRule nm 1 [ ctz @Word8 ] + Ctz16Op -> mkPrimOpRule nm 1 [ ctz @Word16 ] + Ctz32Op -> mkPrimOpRule nm 1 [ ctz @Word32 ] + Ctz64Op -> mkPrimOpRule nm 1 [ ctz @Word64 ] + CtzOp -> mkPrimOpRule nm 1 [ getWordSize >>= \case + PW4 -> ctz @Word32 + PW8 -> ctz @Word64 + ] + + Clz8Op -> mkPrimOpRule nm 1 [ clz @Word8 ] + Clz16Op -> mkPrimOpRule nm 1 [ clz @Word16 ] + Clz32Op -> mkPrimOpRule nm 1 [ clz @Word32 ] + Clz64Op -> mkPrimOpRule nm 1 [ clz @Word64 ] + ClzOp -> mkPrimOpRule nm 1 [ getWordSize >>= \case + PW4 -> clz @Word32 + PW8 -> clz @Word64 + ] + + -- coercions + + Int8ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ] + Int16ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ] + Int32ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ] + Int64ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ] + IntToInt8Op -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit + , narrowSubsumesAnd IntAndOp IntToInt8Op 8 ] + IntToInt16Op -> mkPrimOpRule nm 1 [ liftLit narrowInt16Lit + , narrowSubsumesAnd IntAndOp IntToInt16Op 16 ] + IntToInt32Op -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit + , narrowSubsumesAnd IntAndOp IntToInt32Op 32 ] + IntToInt64Op -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ] + + Word8ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit + , extendNarrowPassthrough WordToWord8Op 0xFF + ] + Word16ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit + , extendNarrowPassthrough WordToWord16Op 0xFFFF + ] + Word32ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit + , extendNarrowPassthrough WordToWord32Op 0xFFFFFFFF + ] + Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit ] + + WordToWord8Op -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit + , narrowSubsumesAnd WordAndOp WordToWord8Op 8 ] + WordToWord16Op -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit + , narrowSubsumesAnd WordAndOp WordToWord16Op 16 ] + WordToWord32Op -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit + , narrowSubsumesAnd WordAndOp WordToWord32Op 32 ] + WordToWord64Op -> mkPrimOpRule nm 1 [ liftLit narrowWord64Lit ] + + Word8ToInt8Op -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8) ] + Int8ToWord8Op -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord8) ] + Word16ToInt16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt16) ] + Int16ToWord16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord16) ] + Word32ToInt32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt32) ] + Int32ToWord32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord32) ] + Word64ToInt64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt64) ] + Int64ToWord64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord64) ] + + WordToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt) ] + IntToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord) ] + + Narrow8IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt8) + , subsumedByPrimOp Narrow8IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd IntAndOp Narrow8IntOp 8 ] + Narrow16IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt16) + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd IntAndOp Narrow16IntOp 16 ] + Narrow32IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt32) + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , subsumedByPrimOp Narrow32IntOp + , removeOp32 + , narrowSubsumesAnd IntAndOp Narrow32IntOp 32 ] + Narrow8WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord8) + , subsumedByPrimOp Narrow8WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd WordAndOp Narrow8WordOp 8 ] + Narrow16WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord16) + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd WordAndOp Narrow16WordOp 16 ] + Narrow32WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord32) + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , subsumedByPrimOp Narrow32WordOp + , removeOp32 + , narrowSubsumesAnd WordAndOp Narrow32WordOp 32 ] + + CastWord64ToDoubleOp -> mkPrimOpRule nm 1 + [ unaryLit $ \_env -> \case + LitNumber _ n + | v <- castWord64ToDouble (fromInteger n) + -- we can't represent those float literals in Core until #18897 is fixed + , not (isNaN v || isInfinite v || isNegativeZero v) + -> Just (mkDoubleLitDouble v) + _ -> Nothing + ] + + CastWord32ToFloatOp -> mkPrimOpRule nm 1 + [ unaryLit $ \_env -> \case + LitNumber _ n + | v <- castWord32ToFloat (fromInteger n) + -- we can't represent those float literals in Core until #18897 is fixed + , not (isNaN v || isInfinite v || isNegativeZero v) + -> Just (mkFloatLitFloat v) + _ -> Nothing + ] + + CastDoubleToWord64Op -> mkPrimOpRule nm 1 + [ unaryLit $ \_env -> \case + LitDouble n -> Just (mkWord64LitWord64 (castDoubleToWord64 (fromRational n))) + _ -> Nothing + ] + + CastFloatToWord32Op -> mkPrimOpRule nm 1 + [ unaryLit $ \_env -> \case + LitFloat n -> Just (mkWord32LitWord32 (castFloatToWord32 (fromRational n))) + _ -> Nothing + ] + + OrdOp -> mkPrimOpRule nm 1 [ liftLit charToIntLit + , semiInversePrimOp ChrOp ] + ChrOp -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs + guard (litFitsInChar lit) + liftLit intToCharLit + , semiInversePrimOp OrdOp ] + FloatToIntOp -> mkPrimOpRule nm 1 [ liftLit floatToIntLit ] + IntToFloatOp -> mkPrimOpRule nm 1 [ liftLit intToFloatLit ] + DoubleToIntOp -> mkPrimOpRule nm 1 [ liftLit doubleToIntLit ] + IntToDoubleOp -> mkPrimOpRule nm 1 [ liftLit intToDoubleLit ] + -- SUP: Not sure what the standard says about precision in the following 2 cases + FloatToDoubleOp -> mkPrimOpRule nm 1 [ liftLit floatToDoubleLit ] + DoubleToFloatOp -> mkPrimOpRule nm 1 [ liftLit doubleToFloatLit ] + + -- Float + FloatAddOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) + , identity zerof ] + FloatSubOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) + , rightIdentity zerof ] + FloatMulOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) + , identity onef + , strengthReduction twof FloatAddOp ] + FloatFMAdd -> mkPrimOpRule nm 3 (fmaRules FMAdd W32) + FloatFMSub -> mkPrimOpRule nm 3 (fmaRules FMSub W32) + FloatFNMAdd -> mkPrimOpRule nm 3 (fmaRules FNMAdd W32) + FloatFNMSub -> mkPrimOpRule nm 3 (fmaRules FNMSub W32) + + -- zeroElem zerof doesn't hold because of NaN + FloatDivOp -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) + , rightIdentity onef ] + FloatNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , semiInversePrimOp FloatNegOp ] + FloatDecode_IntOp -> mkPrimOpRule nm 1 [ unaryLit floatDecodeOp ] + + -- Double + DoubleAddOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) + , identity zerod ] + DoubleSubOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) + , rightIdentity zerod ] + DoubleMulOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) + , identity oned + , strengthReduction twod DoubleAddOp ] + DoubleFMAdd -> mkPrimOpRule nm 3 (fmaRules FMAdd W64) + DoubleFMSub -> mkPrimOpRule nm 3 (fmaRules FMSub W64) + DoubleFNMAdd -> mkPrimOpRule nm 3 (fmaRules FNMAdd W64) + DoubleFNMSub -> mkPrimOpRule nm 3 (fmaRules FNMSub W64) + -- zeroElem zerod doesn't hold because of NaN + DoubleDivOp -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) + , rightIdentity oned ] + DoubleNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , semiInversePrimOp DoubleNegOp ] + DoubleDecode_Int64Op -> mkPrimOpRule nm 1 [ unaryLit doubleDecodeOp ] + + -- Relational operators, equality + + Int8EqOp -> mkRelOpRule nm (==) [ litEq True ] + Int8NeOp -> mkRelOpRule nm (/=) [ litEq False ] + + Int16EqOp -> mkRelOpRule nm (==) [ litEq True ] + Int16NeOp -> mkRelOpRule nm (/=) [ litEq False ] + + Int32EqOp -> mkRelOpRule nm (==) [ litEq True ] + Int32NeOp -> mkRelOpRule nm (/=) [ litEq False ] + + Int64EqOp -> mkRelOpRule nm (==) [ litEq True ] + Int64NeOp -> mkRelOpRule nm (/=) [ litEq False ] + + IntEqOp -> mkRelOpRule nm (==) [ litEq True ] + IntNeOp -> mkRelOpRule nm (/=) [ litEq False ] + + Word8EqOp -> mkRelOpRule nm (==) [ litEq True ] + Word8NeOp -> mkRelOpRule nm (/=) [ litEq False ] + + Word16EqOp -> mkRelOpRule nm (==) [ litEq True ] + Word16NeOp -> mkRelOpRule nm (/=) [ litEq False ] + + Word32EqOp -> mkRelOpRule nm (==) [ litEq True ] + Word32NeOp -> mkRelOpRule nm (/=) [ litEq False ] + + Word64EqOp -> mkRelOpRule nm (==) [ litEq True ] + Word64NeOp -> mkRelOpRule nm (/=) [ litEq False ] + + WordEqOp -> mkRelOpRule nm (==) [ litEq True ] + WordNeOp -> mkRelOpRule nm (/=) [ litEq False ] + + CharEqOp -> mkRelOpRule nm (==) [ litEq True ] + CharNeOp -> mkRelOpRule nm (/=) [ litEq False ] + + FloatEqOp -> mkFloatingRelOpRule nm (==) + FloatNeOp -> mkFloatingRelOpRule nm (/=) + + DoubleEqOp -> mkFloatingRelOpRule nm (==) + DoubleNeOp -> mkFloatingRelOpRule nm (/=) + + -- Relational operators, ordering + + Int8GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + Int8GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + Int8LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + Int8LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + Int16GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + Int16GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + Int16LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + Int16LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + Int32GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + Int32GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + Int32LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + Int32LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + Int64GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + Int64GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + Int64LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + Int64LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + IntGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + IntGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + IntLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + IntLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + Word8GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + Word8GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + Word8LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + Word8LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + Word16GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + Word16GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + Word16LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + Word16LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + Word32GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + Word32GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + Word32LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + Word32LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + Word64GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + Word64GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + Word64LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + Word64LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + WordGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + WordGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + WordLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + WordLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + CharGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + CharGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + CharLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + CharLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + FloatGtOp -> mkFloatingRelOpRule nm (>) + FloatGeOp -> mkFloatingRelOpRule nm (>=) + FloatLeOp -> mkFloatingRelOpRule nm (<=) + FloatLtOp -> mkFloatingRelOpRule nm (<) + + DoubleGtOp -> mkFloatingRelOpRule nm (>) + DoubleGeOp -> mkFloatingRelOpRule nm (>=) + DoubleLeOp -> mkFloatingRelOpRule nm (<=) + DoubleLtOp -> mkFloatingRelOpRule nm (<) + + -- Misc + + AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] + + SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] + + _ -> Nothing + +{- +************************************************************************ +* * +\subsection{Doing the business} +* * +************************************************************************ +-} + +-- useful shorthands +mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule +mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) + +mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) + -> [RuleM CoreExpr] -> Maybe CoreRule +mkRelOpRule nm cmp extra + = mkPrimOpRule nm 2 $ + binaryCmpLit cmp : equal_rule : extra + where + -- x `cmp` x does not depend on x, so + -- compute it for the arbitrary value 'True' + -- and use that result + equal_rule = do { equalArgs + ; platform <- getPlatform + ; return (if cmp True True + then trueValInt platform + else falseValInt platform) } + +{- Note [Rules for floating-point comparisons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need different rules for floating-point values because for floats +it is not true that x = x (for NaNs); so we do not want the equal_rule +rule that mkRelOpRule uses. + +Note also that, in the case of equality/inequality, we do /not/ +want to switch to a case-expression. For example, we do not want +to convert + case (eqFloat# x 3.8#) of + True -> this + False -> that +to + case x of + 3.8#::Float# -> this + _ -> that +See #9238. Reason: comparing floating-point values for equality +delicate, and we don't want to implement that delicacy in the code for +case expressions. So we make it an invariant of Core that a case +expression never scrutinises a Float# or Double#. + +This transformation is what the litEq rule does; +see Note [The litEq rule: converting equality to case]. +So we /refrain/ from using litEq for mkFloatingRelOpRule. +-} + +mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) + -> Maybe CoreRule +-- See Note [Rules for floating-point comparisons] +mkFloatingRelOpRule nm cmp + = mkPrimOpRule nm 2 [binaryCmpLit cmp] + +-- common constants +zeroi, onei, zerow, onew :: Platform -> Literal +zeroi platform = mkLitInt platform 0 +onei platform = mkLitInt platform 1 +zerow platform = mkLitWord platform 0 +onew platform = mkLitWord platform 1 + +zeroI8, oneI8, zeroW8, oneW8 :: Literal +zeroI8 = mkLitInt8 0 +oneI8 = mkLitInt8 1 +zeroW8 = mkLitWord8 0 +oneW8 = mkLitWord8 1 + +zeroI16, oneI16, zeroW16, oneW16 :: Literal +zeroI16 = mkLitInt16 0 +oneI16 = mkLitInt16 1 +zeroW16 = mkLitWord16 0 +oneW16 = mkLitWord16 1 + +zeroI32, oneI32, zeroW32, oneW32 :: Literal +zeroI32 = mkLitInt32 0 +oneI32 = mkLitInt32 1 +zeroW32 = mkLitWord32 0 +oneW32 = mkLitWord32 1 + +zeroI64, oneI64, zeroW64, oneW64 :: Literal +zeroI64 = mkLitInt64 0 +oneI64 = mkLitInt64 1 +zeroW64 = mkLitWord64 0 +oneW64 = mkLitWord64 1 + +zerof, onef, twof, zerod, oned, twod :: Literal +zerof = mkLitFloat 0.0 +onef = mkLitFloat 1.0 +twof = mkLitFloat 2.0 +zerod = mkLitDouble 0.0 +oned = mkLitDouble 1.0 +twod = mkLitDouble 2.0 + +cmpOp :: Platform -> (forall a . Ord a => a -> a -> Bool) + -> Literal -> Literal -> Maybe CoreExpr +cmpOp platform cmp = go + where + done True = Just $ trueValInt platform + done False = Just $ falseValInt platform + + -- These compares are at different types + go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2) + go (LitFloat i1) (LitFloat i2) = done (i1 `cmp` i2) + go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2) + go (LitNumber nt1 i1) (LitNumber nt2 i2) + | nt1 /= nt2 = Nothing + | otherwise = done (i1 `cmp` i2) + go _ _ = Nothing + +-------------------------- + +negOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Negate +negOp env = \case + (LitFloat 0.0) -> Nothing -- can't represent -0.0 as a Rational + (LitFloat f) -> Just (mkFloatVal env (-f)) + (LitDouble 0.0) -> Nothing + (LitDouble d) -> Just (mkDoubleVal env (-d)) + (LitNumber nt i) + | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i))) + _ -> Nothing + +complementOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Binary complement +complementOp env (LitNumber nt i) = + Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i))) +complementOp _ _ = Nothing + +int8Op2 + :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +int8Op2 op _ (LitNumber LitNumInt8 i1) (LitNumber LitNumInt8 i2) = + int8Result (fromInteger i1 `op` fromInteger i2) +int8Op2 _ _ _ _ = Nothing + +int16Op2 + :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +int16Op2 op _ (LitNumber LitNumInt16 i1) (LitNumber LitNumInt16 i2) = + int16Result (fromInteger i1 `op` fromInteger i2) +int16Op2 _ _ _ _ = Nothing + +int32Op2 + :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +int32Op2 op _ (LitNumber LitNumInt32 i1) (LitNumber LitNumInt32 i2) = + int32Result (fromInteger i1 `op` fromInteger i2) +int32Op2 _ _ _ _ = Nothing + +int64Op2 + :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +int64Op2 op _ (LitNumber LitNumInt64 i1) (LitNumber LitNumInt64 i2) = + int64Result (fromInteger i1 `op` fromInteger i2) +int64Op2 _ _ _ _ = Nothing + +intOp2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +intOp2 = intOp2' . const + +intOp2' :: (Integral a, Integral b) + => (RuleOpts -> a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +intOp2' op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) = + let o = op env + in intResult (roPlatform env) (fromInteger i1 `o` fromInteger i2) +intOp2' _ _ _ _ = Nothing + +intOpC2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) = + intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2) +intOpC2 _ _ _ _ = Nothing + +shiftRightLogical :: forall t. (Integral t, Bits t) => Integer -> Int -> Integer +shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: t) + +-- | Shift right, putting zeros in rather than sign-propagating as +-- 'Bits.shiftR' would do. Do this by converting to the appropriate Word +-- and back. Obviously this won't work for too-big values, but its ok as +-- we use it here. +shiftRightLogicalNative :: Platform -> Integer -> Int -> Integer +shiftRightLogicalNative platform = + case platformWordSize platform of + PW4 -> shiftRightLogical @Word32 + PW8 -> shiftRightLogical @Word64 + +-------------------------- +retLit :: (Platform -> Literal) -> RuleM CoreExpr +retLit l = do platform <- getPlatform + return $ Lit $ l platform + +retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr +retLitNoC l = do platform <- getPlatform + let lit = l platform + return $ mkCoreUnboxedTuple [Lit lit, Lit (zeroi platform)] + +word8Op2 + :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +word8Op2 op _ (LitNumber LitNumWord8 i1) (LitNumber LitNumWord8 i2) = + word8Result (fromInteger i1 `op` fromInteger i2) +word8Op2 _ _ _ _ = Nothing + +word16Op2 + :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +word16Op2 op _ (LitNumber LitNumWord16 i1) (LitNumber LitNumWord16 i2) = + word16Result (fromInteger i1 `op` fromInteger i2) +word16Op2 _ _ _ _ = Nothing + +word32Op2 + :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +word32Op2 op _ (LitNumber LitNumWord32 i1) (LitNumber LitNumWord32 i2) = + word32Result (fromInteger i1 `op` fromInteger i2) +word32Op2 _ _ _ _ = Nothing + +word64Op2 + :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +word64Op2 op _ (LitNumber LitNumWord64 i1) (LitNumber LitNumWord64 i2) = + word64Result (fromInteger i1 `op` fromInteger i2) +word64Op2 _ _ _ _ = Nothing + +wordOp2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +wordOp2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) + = wordResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) +wordOp2 _ _ _ _ = Nothing + +wordOpC2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +wordOpC2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) = + wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) +wordOpC2 _ _ _ _ = Nothing + +shiftRule :: LitNumType + -> (Platform -> Integer -> Int -> Integer) + -> RuleM CoreExpr +-- Shifts take an Int; hence third arg of op is Int +-- Used for shift primops +-- IntSllOp, IntSraOp, IntSrlOp :: Int# -> Int# -> Int# +-- SllOp, SrlOp :: Word# -> Int# -> Word# +shiftRule lit_num_ty shift_op = do + platform <- getPlatform + [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs + + bit_size <- case litNumBitSize platform lit_num_ty of + Nothing -> mzero + Just bs -> pure (toInteger bs) + + case e1 of + _ | shift_len == 0 -> pure e1 + + -- See Note [Guarding against silly shifts] + _ | shift_len < 0 || shift_len >= bit_size + -> pure $ Lit $ mkLitNumberWrap platform lit_num_ty 0 + -- Be sure to use lit_num_ty here, so we get a correctly typed zero. + -- See #18589 + + Lit (LitNumber nt x) + | 0 < shift_len && shift_len <= bit_size + -> assert (nt == lit_num_ty) $ + let op = shift_op platform + -- Do the shift at type Integer, but shift length is Int. + -- Using host's Int is ok even if target's Int has a different size + -- because we test that shift_len <= bit_size (which is at most 64) + y = x `op` fromInteger shift_len + in pure $ Lit $ mkLitNumberWrap platform nt y + + _ -> mzero + +-------------------------- +floatOp2 :: (Rational -> Rational -> Rational) + -> RuleOpts -> Literal -> Literal + -> Maybe (Expr CoreBndr) +floatOp2 op env (LitFloat f1) (LitFloat f2) + = Just (mkFloatVal env (f1 `op` f2)) +floatOp2 _ _ _ _ = Nothing + +-------------------------- +floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr +floatDecodeOp env (LitFloat ((decodeFloat . fromRational @Float) -> (m, e))) + = Just $ mkCoreUnboxedTuple [ mkIntVal (roPlatform env) (toInteger m) + , mkIntVal (roPlatform env) (toInteger e) ] +floatDecodeOp _ _ + = Nothing + +-------------------------- +doubleOp2 :: (Rational -> Rational -> Rational) + -> RuleOpts -> Literal -> Literal + -> Maybe (Expr CoreBndr) +doubleOp2 op env (LitDouble f1) (LitDouble f2) + = Just (mkDoubleVal env (f1 `op` f2)) +doubleOp2 _ _ _ _ = Nothing + +-------------------------- +doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr +doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e))) + = Just $ mkCoreUnboxedTuple [ Lit (mkLitInt64Wrap (toInteger m)) + , mkIntVal platform (toInteger e) ] + where + platform = roPlatform env +doubleDecodeOp _ _ + = Nothing + +-------------------------- + +-- | Constant folding rules for fused multiply-add operations. +fmaRules :: FMASign -> Width -> [RuleM CoreExpr] +fmaRules signs width = + [ fmaLit signs width + , fmaZero_z signs width + , fmaOne signs width ] + +-- | Compute @a * b + c@ when @a@, @b@, @c@ are all literals. +fmaLit :: FMASign -> Width -> RuleM CoreExpr +fmaLit signs width = do + env <- getRuleOpts + [Lit l1, Lit l2, Lit l3] <- getArgs + liftMaybe $ + op env + (convFloating env l1) + (convFloating env l2) + (convFloating env l3) + + where + op env l1 l2 l3 = + case width of + W32 + | LitFloat x <- l1 + , LitFloat y <- l2 + , LitFloat z <- l3 + -> Just $ mkFloatVal env $ + case signs of + FMAdd -> x * y + z + FMSub -> x * y - z + FNMAdd -> negate ( x * y ) + z + FNMSub -> negate ( x * y ) - z + W64 + | LitDouble x <- l1 + , LitDouble y <- l2 + , LitDouble z <- l3 + -> Just $ mkDoubleVal env $ + case signs of + FMAdd -> x * y + z + FMSub -> x * y - z + FNMAdd -> negate ( x * y ) + z + FNMSub -> negate ( x * y ) - z + _ -> Nothing + +-- | @x * y + 0 = x * y@. +fmaZero_z :: FMASign -> Width -> RuleM CoreExpr +fmaZero_z signs width = do + [x, y, Lit z] <- getArgs + let + -- TODO: we should additionally check the sign of z. + -- FMAdd, FNMAdd: should be -0.0. + -- FMSub, FNMSub: should be +0.0. + ok = + case width of + W32 + | LitFloat 0 <- z + -> True + W64 + | LitDouble 0 <- z + -> True + _ -> False + neg = case width of + W32 -> FloatNegOp + W64 -> DoubleNegOp + _ -> panic "fmaZero_xy: not Float# or Double#" + mul = case width of + W32 -> FloatMulOp + W64 -> DoubleMulOp + _ -> panic "fmaZero_z: not Float# or Double#" + if ok + then return $ case signs of + FMAdd -> Var (primOpId mul) `App` x `App` y + FMSub -> Var (primOpId mul) `App` x `App` y + FNMAdd -> Var (primOpId neg) `App` (Var (primOpId mul) `App` x `App` y) + FNMSub -> Var (primOpId neg) `App` (Var (primOpId mul) `App` x `App` y) + else mzero + +-- | @±1 * y + z ==> z ± y@ and @x * ±1 + z ==> z ± x@. +fmaOne :: FMASign -> Width -> RuleM CoreExpr +fmaOne signs width = do + [x, y, z] <- getArgs + let + posNegOne_maybe :: Rational -> Maybe Bool + posNegOne_maybe i + | i == 1 + = Just False + | i == -1 + = Just True + | otherwise + = Nothing + ok = + case width of + W32 + | Lit (LitFloat i) <- x + , Just sgn <- posNegOne_maybe i + -> Just (sgn, y) + | Lit (LitFloat i) <- y + , Just sgn <- posNegOne_maybe i + -> Just (sgn, x) + W64 + | Lit (LitDouble i) <- x + , Just sgn <- posNegOne_maybe i + -> Just (sgn, y) + | Lit (LitDouble i) <- y + , Just sgn <- posNegOne_maybe i + -> Just (sgn, x) + _ -> Nothing + neg = case width of + W32 -> FloatNegOp + W64 -> DoubleNegOp + _ -> panic "fmaOne: not Float# or Double#" + add = case width of + W32 -> FloatAddOp + W64 -> DoubleAddOp + _ -> panic "fmaOne: not Float# or Double#" + sub = case width of + W32 -> FloatSubOp + W64 -> DoubleSubOp + _ -> panic "fmaOne: not Float# or Double#" + case ok of + Nothing -> mzero + Just (sgn, t) -> return $ + if -- t + z + | ( signs == FMAdd && sgn == False ) + || ( signs == FNMAdd && sgn == True ) + -> Var (primOpId add) `App` t `App` z + -- - t + z + | signs == FMAdd + || signs == FNMAdd + -> Var (primOpId sub) `App` z `App` t + -- t - z + | ( signs == FMSub && sgn == False ) + || ( signs == FNMSub && sgn == True ) + -> Var (primOpId sub) `App` t `App` z + -- - t - z + | signs == FMSub + || signs == FNMSub + -> Var (primOpId neg) `App` (Var (primOpId add) `App` t `App` z) + | otherwise + -> pprPanic "fmaOne: non-exhaustive pattern match" $ + vcat [ text "signs:" <+> text (show signs) + , text "sign:" <+> ppr sgn ] + +-------------------------- +{- Note [The litEq rule: converting equality to case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This stuff turns + n ==# 3# +into + case n of + 3# -> True + m -> False + +This is a Good Thing, because it allows case-of case things +to happen, and case-default absorption to happen. For +example: + + if (n ==# 3#) || (n ==# 4#) then e1 else e2 +will transform to + case n of + 3# -> e1 + 4# -> e1 + m -> e2 +(modulo the usual precautions to avoid duplicating e1) +-} + +litEq :: Bool -- True <=> equality, False <=> inequality + -> RuleM CoreExpr +litEq is_eq = msum + [ do [Lit lit, expr] <- getArgs + platform <- getPlatform + do_lit_eq platform lit expr + , do [expr, Lit lit] <- getArgs + platform <- getPlatform + do_lit_eq platform lit expr ] + where + do_lit_eq platform lit expr = do + guard (not (litIsLifted lit)) + return (mkWildCase expr (unrestricted $ literalType lit) intPrimTy + [ Alt DEFAULT [] val_if_neq + , Alt (LitAlt lit) [] val_if_eq]) + where + val_if_eq | is_eq = trueValInt platform + | otherwise = falseValInt platform + val_if_neq | is_eq = falseValInt platform + | otherwise = trueValInt platform + + +-- | Check if there is comparison with minBound or maxBound, that is +-- always true or false. For instance, an Int cannot be smaller than its +-- minBound, so we can replace such comparison with False. +boundsCmp :: Comparison -> RuleM CoreExpr +boundsCmp op = do + platform <- getPlatform + [a, b] <- getArgs + liftMaybe $ mkRuleFn platform op a b + +data Comparison = Gt | Ge | Lt | Le + +mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr +mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform +mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt platform +mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt platform +mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform +mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt platform +mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform +mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform +mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt platform +mkRuleFn _ _ _ _ = Nothing + +-- | Create an Int literal expression while ensuring the given Integer is in the +-- target Int range +int8Result :: Integer -> Maybe CoreExpr +int8Result result = Just (int8Result' result) + +int8Result' :: Integer -> CoreExpr +int8Result' result = Lit (mkLitInt8Wrap result) + +-- | Create an Int literal expression while ensuring the given Integer is in the +-- target Int range +int16Result :: Integer -> Maybe CoreExpr +int16Result result = Just (int16Result' result) + +int16Result' :: Integer -> CoreExpr +int16Result' result = Lit (mkLitInt16Wrap result) + +-- | Create an Int literal expression while ensuring the given Integer is in the +-- target Int range +int32Result :: Integer -> Maybe CoreExpr +int32Result result = Just (int32Result' result) + +int32Result' :: Integer -> CoreExpr +int32Result' result = Lit (mkLitInt32Wrap result) + +intResult :: Platform -> Integer -> Maybe CoreExpr +intResult platform result = Just (intResult' platform result) + +intResult' :: Platform -> Integer -> CoreExpr +intResult' platform result = Lit (mkLitIntWrap platform result) + +-- | Create an unboxed pair of an Int literal expression, ensuring the given +-- Integer is in the target Int range and the corresponding overflow flag +-- (@0#@/@1#@) if it wasn't. +intCResult :: Platform -> Integer -> Maybe CoreExpr +intCResult platform result = Just (mkCoreUnboxedTuple [Lit lit, Lit c]) + where + (lit, b) = mkLitIntWrapC platform result + c = if b then onei platform else zeroi platform + +-- | Create a Word literal expression while ensuring the given Integer is in the +-- target Word range +word8Result :: Integer -> Maybe CoreExpr +word8Result result = Just (word8Result' result) + +word8Result' :: Integer -> CoreExpr +word8Result' result = Lit (mkLitWord8Wrap result) + +-- | Create a Word literal expression while ensuring the given Integer is in the +-- target Word range +word16Result :: Integer -> Maybe CoreExpr +word16Result result = Just (word16Result' result) + +word16Result' :: Integer -> CoreExpr +word16Result' result = Lit (mkLitWord16Wrap result) + +-- | Create a Word literal expression while ensuring the given Integer is in the +-- target Word range +word32Result :: Integer -> Maybe CoreExpr +word32Result result = Just (word32Result' result) + +word32Result' :: Integer -> CoreExpr +word32Result' result = Lit (mkLitWord32Wrap result) + +-- | Create a Word literal expression while ensuring the given Integer is in the +-- target Word range +wordResult :: Platform -> Integer -> Maybe CoreExpr +wordResult platform result = Just (wordResult' platform result) + +wordResult' :: Platform -> Integer -> CoreExpr +wordResult' platform result = Lit (mkLitWordWrap platform result) + +-- | Create an unboxed pair of a Word literal expression, ensuring the given +-- Integer is in the target Word range and the corresponding carry flag +-- (@0#@/@1#@) if it wasn't. +wordCResult :: Platform -> Integer -> Maybe CoreExpr +wordCResult platform result = Just (mkCoreUnboxedTuple [Lit lit, Lit c]) + where + (lit, b) = mkLitWordWrapC platform result + c = if b then onei platform else zeroi platform + +int64Result :: Integer -> Maybe CoreExpr +int64Result result = Just (int64Result' result) + +int64Result' :: Integer -> CoreExpr +int64Result' result = Lit (mkLitInt64Wrap result) + +word64Result :: Integer -> Maybe CoreExpr +word64Result result = Just (word64Result' result) + +word64Result' :: Integer -> CoreExpr +word64Result' result = Lit (mkLitWord64Wrap result) + + +-- | 'ambient (primop x) = x', but not necessarily 'primop (ambient x) = x'. +semiInversePrimOp :: PrimOp -> RuleM CoreExpr +semiInversePrimOp primop = do + [Var primop_id `App` e] <- getArgs + matchPrimOpId primop primop_id + return e + +subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr +this `subsumesPrimOp` that = do + [Var primop_id `App` e] <- getArgs + matchPrimOpId that primop_id + return (Var (primOpId this) `App` e) + +subsumedByPrimOp :: PrimOp -> RuleM CoreExpr +subsumedByPrimOp primop = do + [e@(Var primop_id `App` _)] <- getArgs + matchPrimOpId primop primop_id + return e + +-- | Transform `extendWordN (narrowWordN x)` into `x .&. 0xFF..FF` +extendNarrowPassthrough :: PrimOp -> Integer -> RuleM CoreExpr +extendNarrowPassthrough narrow_primop n = do + [Var primop_id `App` x] <- getArgs + matchPrimOpId narrow_primop primop_id + return (Var (primOpId WordAndOp) `App` x `App` Lit (LitNumber LitNumWord n)) + +-- | narrow subsumes bitwise `and` with full mask (cf #16402): +-- +-- narrowN (x .&. m) +-- m .&. (2^N-1) = 2^N-1 +-- ==> narrowN x +-- +-- e.g. narrow16 (x .&. 0xFFFF) +-- ==> narrow16 x +-- +narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr +narrowSubsumesAnd and_primop narrw n = do + [Var primop_id `App` x `App` y] <- getArgs + matchPrimOpId and_primop primop_id + let mask = bit n -1 + g v (Lit (LitNumber _ m)) = do + guard (m .&. mask == mask) + return (Var (primOpId narrw) `App` v) + g _ _ = mzero + g x y <|> g y x + +idempotent :: RuleM CoreExpr +idempotent = do [e1, e2] <- getArgs + guard $ cheapEqExpr e1 e2 + return e1 + +-- | Match +-- (op (op v e) e) +-- or (op e (op v e)) +-- or (op (op e v) e) +-- or (op e (op e v)) +-- and return the innermost (op v e) or (op e v). +sameArgIdempotentCommut :: PrimOp -> RuleM CoreExpr +sameArgIdempotentCommut op = do + [a,b] <- getArgs + case (a,b) of + (is_binop op -> Just (e1,e2), e3) + | cheapEqExpr e2 e3 -> return a + | cheapEqExpr e1 e3 -> return a + (e3, is_binop op -> Just (e1,e2)) + | cheapEqExpr e2 e3 -> return b + | cheapEqExpr e1 e3 -> return b + _ -> mzero + +{- +Note [Guarding against silly shifts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + import Data.Bits( (.|.), shiftL ) + chunkToBitmap :: [Bool] -> Word32 + chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] + +This optimises to: +Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) -> + case w1_sCT of _ { + [] -> 0##; + : x_aAW xs_aAX -> + case x_aAW of _ { + GHC.Types.False -> + case w_sCS of wild2_Xh { + __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX; + 9223372036854775807 -> 0## }; + GHC.Types.True -> + case GHC.Prim.>=# w_sCS 64 of _ { + GHC.Types.False -> + case w_sCS of wild3_Xh { + __DEFAULT -> + case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT -> + GHC.Prim.or# (GHC.Prim.narrow32Word# + (GHC.Prim.uncheckedShiftL# 1## wild3_Xh)) + ww_sCW + }; + 9223372036854775807 -> + GHC.Prim.narrow32Word# +!!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807) + }; + GHC.Types.True -> + case w_sCS of wild3_Xh { + __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX; + 9223372036854775807 -> 0## + } } } } + +Note the massive shift on line "!!!!". It can't happen, because we've checked +that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this! +Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we +can't constant fold it, but if it gets to the assembler we get + Error: operand type mismatch for `shl' + +So the best thing to do is to rewrite the shift with a call to error, +when the second arg is large. However, in general we cannot do this; consider +this case + + let x = I# (uncheckedIShiftL# n 80) + in ... + +Here x contains an invalid shift and consequently we would like to rewrite it +as follows: + + let x = I# (error "invalid shift") + in ... + +This was originally done in the fix to #16449 but this breaks the +let-can-float invariant (see Note [Core let-can-float invariant] in +GHC.Core) as noted in #16742. For the reasons discussed under +"NoEffect" in Note [Classifying primop effects] (in GHC.Builtin.PrimOps) +there is no safe way to rewrite the argument of I# such that it bottoms. + +Consequently we instead take advantage of the fact that the result of a +large shift is unspecified (see associated documentation in primops.txt.pp) +and transform the invalid shift into an "obviously incorrect" value. + +There are two cases: + +- Shifting fixed-width things: the primops IntSll, Sll, etc + These are handled by shiftRule. + + We are happy to shift by any amount up to wordSize but no more. + +- Shifting Bignums (Integer, Natural): these are handled by bignum_shift. + + Here we could in principle shift by any amount, but we arbitrary + limit the shift to 4 bits; in particular we do not want shift by a + huge amount, which can happen in code like that above. + +The two cases are more different in their code paths that is comfortable, +but that is only a historical accident. + + +************************************************************************ +* * +\subsection{Vaguely generic functions} +* * +************************************************************************ +-} + +mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule +-- Gives the Rule the same name as the primop itself +mkBasicRule op_name n_args rm + = BuiltinRule { ru_name = occNameFS (nameOccName op_name), + ru_fn = op_name, + ru_nargs = n_args, + ru_try = runRuleM rm } + +newtype RuleM r = RuleM + { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r } + deriving (Functor) + +instance Applicative RuleM where + pure x = RuleM $ \_ _ _ _ -> Just x + (<*>) = ap + +instance Monad RuleM where + RuleM f >>= g + = RuleM $ \env iu fn args -> + case f env iu fn args of + Nothing -> Nothing + Just r -> runRuleM (g r) env iu fn args + +instance MonadFail RuleM where + fail _ = mzero + +instance Alternative RuleM where + empty = RuleM $ \_ _ _ _ -> Nothing + RuleM f1 <|> RuleM f2 = RuleM $ \env iu fn args -> + f1 env iu fn args <|> f2 env iu fn args + +instance MonadPlus RuleM + +getPlatform :: RuleM Platform +getPlatform = roPlatform <$> getRuleOpts + +getWordSize :: RuleM PlatformWordSize +getWordSize = platformWordSize <$> getPlatform + +getRuleOpts :: RuleM RuleOpts +getRuleOpts = RuleM $ \rule_opts _ _ _ -> Just rule_opts + +liftMaybe :: Maybe a -> RuleM a +liftMaybe Nothing = mzero +liftMaybe (Just x) = return x + +liftLit :: (Literal -> Literal) -> RuleM CoreExpr +liftLit f = liftLitPlatform (const f) + +liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr +liftLitPlatform f = do + platform <- getPlatform + [Lit lit] <- getArgs + return $ Lit (f platform lit) + +removeOp32 :: RuleM CoreExpr +removeOp32 = do + platform <- getPlatform + case platformWordSize platform of + PW4 -> do + [e] <- getArgs + return e + PW8 -> + mzero + +getArgs :: RuleM [CoreExpr] +getArgs = RuleM $ \_ _ _ args -> Just args + +getInScopeEnv :: RuleM InScopeEnv +getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu + +getFunction :: RuleM Id +getFunction = RuleM $ \_ _ fn _ -> Just fn + +isLiteral :: CoreExpr -> RuleM Literal +isLiteral e = do + env <- getInScopeEnv + case exprIsLiteral_maybe env e of + Nothing -> mzero + Just l -> pure l + +-- | Match BigNat#, Integer and Natural literals +isBignumLiteral :: CoreExpr -> RuleM Integer +isBignumLiteral e = isNumberLiteral e <|> isIntegerLiteral e <|> isNaturalLiteral e + +-- | Match numeric literals +isNumberLiteral :: CoreExpr -> RuleM Integer +isNumberLiteral e = isLiteral e >>= \case + LitNumber _ x -> pure x + _ -> mzero + +-- | Match the application of a DataCon to a numeric literal. +-- +-- Can be used to match e.g.: +-- IS 123# +-- IP bigNatLiteral +-- W# 123## +isLitNumConApp :: CoreExpr -> RuleM (DataCon,Integer) +isLitNumConApp e = do + env <- getInScopeEnv + case exprIsConApp_maybe env e of + Just (_env,_fb,dc,_tys,[arg]) -> case exprIsLiteral_maybe env arg of + Just (LitNumber _ i) -> pure (dc,i) + _ -> mzero + _ -> mzero + +isIntegerLiteral :: CoreExpr -> RuleM Integer +isIntegerLiteral e = do + (dc,i) <- isLitNumConApp e + if | dc == integerISDataCon -> pure i + | dc == integerINDataCon -> pure (negate i) + | dc == integerIPDataCon -> pure i + | otherwise -> mzero + +isBigIntegerLiteral :: CoreExpr -> RuleM Integer +isBigIntegerLiteral e = do + (dc,i) <- isLitNumConApp e + if | dc == integerINDataCon -> pure (negate i) + | dc == integerIPDataCon -> pure i + | otherwise -> mzero + +isNaturalLiteral :: CoreExpr -> RuleM Integer +isNaturalLiteral e = do + (dc,i) <- isLitNumConApp e + if | dc == naturalNSDataCon -> pure i + | dc == naturalNBDataCon -> pure i + | otherwise -> mzero + +-- return the n-th argument of this rule, if it is a literal +-- argument indices start from 0 +getLiteral :: Int -> RuleM Literal +getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of + (Lit l:_) -> Just l + _ -> Nothing + +unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +unaryLit op = do + env <- getRuleOpts + [Lit l] <- getArgs + liftMaybe $ op env (convFloating env l) + +binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +binaryLit op = do + env <- getRuleOpts + [Lit l1, Lit l2] <- getArgs + liftMaybe $ op env (convFloating env l1) (convFloating env l2) + +binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr +binaryCmpLit op = do + platform <- getPlatform + binaryLit (\_ -> cmpOp platform op) + +leftIdentity :: Literal -> RuleM CoreExpr +leftIdentity id_lit = leftIdentityPlatform (const id_lit) + +rightIdentity :: Literal -> RuleM CoreExpr +rightIdentity id_lit = rightIdentityPlatform (const id_lit) + +identity :: Literal -> RuleM CoreExpr +identity lit = leftIdentity lit `mplus` rightIdentity lit + +leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +leftIdentityPlatform id_lit = do + platform <- getPlatform + [Lit l1, e2] <- getArgs + guard $ l1 == id_lit platform + return e2 + +-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in +-- addition to the result, we have to indicate that no carry/overflow occurred. +leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +leftIdentityCPlatform id_lit = do + platform <- getPlatform + [Lit l1, e2] <- getArgs + guard $ l1 == id_lit platform + let no_c = Lit (zeroi platform) + return (mkCoreUnboxedTuple [e2, no_c]) + +rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +rightIdentityPlatform id_lit = do + platform <- getPlatform + [e1, Lit l2] <- getArgs + guard $ l2 == id_lit platform + return e1 + +-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in +-- addition to the result, we have to indicate that no carry/overflow occurred. +rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +rightIdentityCPlatform id_lit = do + platform <- getPlatform + [e1, Lit l2] <- getArgs + guard $ l2 == id_lit platform + let no_c = Lit (zeroi platform) + return (mkCoreUnboxedTuple [e1, no_c]) + +identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +identityPlatform lit = + leftIdentityPlatform lit `mplus` rightIdentityPlatform lit + +-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition +-- to the result, we have to indicate that no carry/overflow occurred. +identityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +identityCPlatform lit = + leftIdentityCPlatform lit `mplus` rightIdentityCPlatform lit + +leftZero :: RuleM CoreExpr +leftZero = do + [Lit l1, _] <- getArgs + guard $ isZeroLit l1 + return $ Lit l1 + +rightZero :: RuleM CoreExpr +rightZero = do + [_, Lit l2] <- getArgs + guard $ isZeroLit l2 + return $ Lit l2 + +zeroElem :: RuleM CoreExpr +zeroElem = leftZero `mplus` rightZero + +equalArgs :: RuleM () +equalArgs = do + [e1, e2] <- getArgs + guard $ e1 `cheapEqExpr` e2 + +nonZeroLit :: Int -> RuleM () +nonZeroLit n = getLiteral n >>= guard . not . isZeroLit + +oneLit :: Int -> RuleM () +oneLit n = getLiteral n >>= guard . isOneLit + +lift_bits_op :: forall a. (Num a, FiniteBits a) => (a -> Integer) -> RuleM CoreExpr +lift_bits_op op = do + platform <- getPlatform + [Lit (LitNumber _ l)] <- getArgs + pure $ mkWordLit platform $ op (fromInteger l :: a) + +pop_count :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr +pop_count = lift_bits_op @a (fromIntegral . popCount) + +ctz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr +ctz = lift_bits_op @a (fromIntegral . countTrailingZeros) + +clz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr +clz = lift_bits_op @a (fromIntegral . countLeadingZeros) + +-- When excess precision is not requested, cut down the precision of the +-- Rational value to that of Float/Double. We confuse host architecture +-- and target architecture here, but it's convenient (and wrong :-). +convFloating :: RuleOpts -> Literal -> Literal +convFloating env (LitFloat f) | not (roExcessRationalPrecision env) = + LitFloat (toRational (fromRational f :: Float )) +convFloating env (LitDouble d) | not (roExcessRationalPrecision env) = + LitDouble (toRational (fromRational d :: Double)) +convFloating _ l = l + +guardFloatDiv :: RuleM () +guardFloatDiv = do + [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs + guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero] + && f2 /= 0 -- avoid NaN and Infinity/-Infinity + +guardDoubleDiv :: RuleM () +guardDoubleDiv = do + [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs + guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero] + && d2 /= 0 -- avoid NaN and Infinity/-Infinity +-- Note [negative zero] +-- ~~~~~~~~~~~~~~~~~~~~ +-- Avoid (0 / -d), otherwise 0/(-1) reduces to +-- zero, but we might want to preserve the negative zero here which +-- is representable in Float/Double but not in (normalised) +-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? + +strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr +strengthReduction two_lit add_op = do -- Note [Strength reduction] + arg <- msum [ do [arg, Lit mult_lit] <- getArgs + guard (mult_lit == two_lit) + return arg + , do [Lit mult_lit, arg] <- getArgs + guard (mult_lit == two_lit) + return arg ] + return $ Var (primOpId add_op) `App` arg `App` arg + +-- Note [Strength reduction] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- This rule turns floating point multiplications of the form 2.0 * x and +-- x * 2.0 into x + x addition, because addition costs less than multiplication. +-- See #7116 + +-- Note [What's true and false] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- trueValInt and falseValInt represent true and false values returned by +-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr. +-- True is represented as an unboxed 1# literal, while false is represented +-- as 0# literal. +-- We still need Bool data constructors (True and False) to use in a rule +-- for constant folding of equal Strings + +trueValInt, falseValInt :: Platform -> Expr CoreBndr +trueValInt platform = Lit $ onei platform -- see Note [What's true and false] +falseValInt platform = Lit $ zeroi platform + +trueValBool, falseValBool :: Expr CoreBndr +trueValBool = Var trueDataConId -- see Note [What's true and false] +falseValBool = Var falseDataConId + +ltVal, eqVal, gtVal :: Expr CoreBndr +ltVal = Var ordLTDataConId +eqVal = Var ordEQDataConId +gtVal = Var ordGTDataConId + +mkIntVal :: Platform -> Integer -> Expr CoreBndr +mkIntVal platform i = Lit (mkLitInt platform i) +mkFloatVal :: RuleOpts -> Rational -> Expr CoreBndr +mkFloatVal env f = Lit (convFloating env (LitFloat f)) +mkDoubleVal :: RuleOpts -> Rational -> Expr CoreBndr +mkDoubleVal env d = Lit (convFloating env (LitDouble d)) + +matchPrimOpId :: PrimOp -> Id -> RuleM () +matchPrimOpId op id = do + op' <- liftMaybe $ isPrimOpId_maybe id + guard $ op == op' + +{- +************************************************************************ +* * +\subsection{Special rules for seq, tagToEnum, dataToTag} +* * +************************************************************************ + +Note [tagToEnum#] +~~~~~~~~~~~~~~~~~ +Nasty check to ensure that tagToEnum# is applied to a type that is an +enumeration TyCon. Unification may refine the type later, but this +check won't see that, alas. It's crude but it works. + +Here's are two cases that should fail + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + +We used to make this check in the type inference engine, but it's quite +ugly to do so, because the delayed constraint solving means that we don't +really know what's going on until the end. It's very much a corner case +because we don't expect the user to call tagToEnum# at all; we merely +generate calls in derived instances of Enum. So we compromise: a +rewrite rule rewrites a bad instance of tagToEnum# to an error call, +and emits a warning. + +We also do something similar if we can see that the argument of tagToEnum is out +of bounds, e.g. `tagToEnum# 99# :: Bool`. +Replacing this with an error expression is better for two reasons: +* It allow us to eliminate more dead code in cases like `case tagToEnum# 99# :: Bool of ...` +* Should we actually end up executing the relevant code at runtime the user will + see a meaningful error message, instead of a segfault or incorrect result. +See #25976. +-} + +tagToEnumRule :: RuleM CoreExpr +-- If data T a = A | B | C +-- then tagToEnum# (T ty) 2# --> B ty +tagToEnumRule = do + [Type ty, Lit (LitNumber LitNumInt i)] <- getArgs + case splitTyConApp_maybe ty of + Just (tycon, tc_args) | isEnumerationTyCon tycon -> do + let tag = fromInteger i + correct_tag dc = (dataConTagZ dc) == tag + Just dataCons <- pure $ tyConDataCons_maybe tycon + case filter correct_tag dataCons of + (dc:rest) -> do + massert (null rest) + pure $ mkTyApps (Var (dataConWorkId dc)) tc_args + -- Literal is out of range, e.g. tagToEnum @Bool #4 + [] -> pure $ mkImpossibleExpr ty "tagToEnum: Argument out of range" + + -- See Note [tagToEnum#] + _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $ + return $ mkImpossibleExpr ty "tagToEnum# on non-enumeration type" + +------------------------------ +dataToTagRule :: RuleM CoreExpr +-- Used for both dataToTagSmall# and dataToTagLarge#. +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkle DTW5. +dataToTagRule = a `mplus` b + where + -- dataToTag (tagToEnum x) ==> x + a = do + [Type _lev, Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs + guard $ tag_to_enum `hasKey` tagToEnumKey + guard $ ty1 `eqType` ty2 + return tag + + -- dataToTag (K e1 e2) ==> tag-of K + -- This also works (via exprIsConApp_maybe) for + -- dataToTag x + -- where x's unfolding is a constructor application + b = do + platform <- getPlatform + [_lev, _ty, val_arg] <- getArgs + in_scope <- getInScopeEnv + (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg + massert (not (isNewTyCon (dataConTyCon dc))) + return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc))) + + +{- ********************************************************************* +* * + unsafeEqualityProof +* * +********************************************************************* -} + +-- unsafeEqualityProof k t t ==> UnsafeRefl (Refl t) +-- That is, if the two types are equal, it's not unsafe! + +unsafeEqualityProofRule :: RuleM CoreExpr +unsafeEqualityProofRule + = do { [Type rep, Type t1, Type t2] <- getArgs + ; guard (t1 `eqType` t2) + ; fn <- getFunction + ; let (_, ue) = splitForAllTyCoVars (idType fn) + tc = tyConAppTyCon ue -- tycon: UnsafeEquality + dc = tyConSingleDataCon tc -- data con: UnsafeRefl + -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r). + -- UnsafeEquality r a a + ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) } + + +{- ********************************************************************* +* * + Rules for spark# +* * +********************************************************************* -} + +-- spark# :: forall a s . a -> State# s -> (# State# s, a #) +sparkRule :: RuleM CoreExpr +sparkRule = do -- reduce on HNF + [Type _ty_a, Type _ty_s, a, s] <- getArgs + guard $ exprIsHNF a + return $ mkCoreUnboxedTuple [s, a] + -- XXX perhaps we shouldn't do this, because a spark eliminated by + -- this rule won't be counted as a dud at runtime? + +{- +************************************************************************ +* * +\subsection{Built in rules} +* * +************************************************************************ + +Note [Scoping for Builtin rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When compiling a (base-package) module that defines one of the +functions mentioned in the RHS of a built-in rule, there's a danger +that we'll see + + f = ...(eq String x).... + + ....and lower down... + + eqString = ... + +Then a rewrite would give + + f = ...(eqString x)... + ....and lower down... + eqString = ... + +and lo, eqString is not in scope. This only really matters when we +get to code generation. But the occurrence analyser does a GlomBinds +step when necessary, that does a new SCC analysis on the whole set of +bindings (see occurAnalysePgm), which sorts out the dependency, so all +is fine. +-} + +builtinRules :: [CoreRule] +-- Rules for non-primops that can't be expressed using a RULE pragma +builtinRules + = [BuiltinRule { ru_name = fsLit "CStringFoldrLit", + ru_fn = unpackCStringFoldrName, + ru_nargs = 4, ru_try = match_cstring_foldr_lit_C }, + BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8", + ru_fn = unpackCStringFoldrUtf8Name, + ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 }, + BuiltinRule { ru_name = fsLit "CStringAppendLit", + ru_fn = unpackCStringAppendName, + ru_nargs = 2, ru_try = match_cstring_append_lit_C }, + BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8", + ru_fn = unpackCStringAppendUtf8Name, + ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 }, + BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, + ru_nargs = 2, ru_try = match_eq_string }, + BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName, + ru_nargs = 1, ru_try = match_cstring_length }, + BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, + ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, + + mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule, + + mkBasicRule divIntName 2 $ msum + [ nonZeroLit 1 >> binaryLit (intOp2 div) + , leftZero + , do + [arg, Lit (LitNumber LitNumInt d)] <- getArgs + Just n <- return $ exactLog2 d + platform <- getPlatform + return $ Var (primOpId IntSraOp) `App` arg `App` mkIntVal platform n + ], + + mkBasicRule modIntName 2 $ msum + [ nonZeroLit 1 >> binaryLit (intOp2 mod) + , leftZero + , do + [arg, Lit (LitNumber LitNumInt d)] <- getArgs + Just _ <- return $ exactLog2 d + platform <- getPlatform + return $ Var (primOpId IntAndOp) + `App` arg `App` mkIntVal platform (d - 1) + ] + ] + ++ builtinBignumRules +{-# NOINLINE builtinRules #-} +-- there is no benefit to inlining these yet, despite this, GHC produces +-- unfoldings for this regardless since the floated list entries look small. + +builtinBignumRules :: [CoreRule] +builtinBignumRules = + [ -- conversions + lit_to_integer "Word# -> Integer" integerFromWordName + , lit_to_integer "Int64# -> Integer" integerFromInt64Name + , lit_to_integer "Word64# -> Integer" integerFromWord64Name + , lit_to_integer "Natural -> Integer" integerFromNaturalName + + , integer_to_lit "Integer -> Word# (wrap)" integerToWordName mkWordLitWrap + , integer_to_lit "Integer -> Int# (wrap)" integerToIntName mkIntLitWrap + , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger) + , integer_to_lit "Integer -> Int64# (wrap)" integerToInt64Name (\_ -> mkInt64LitInt64 . fromInteger) + , integer_to_lit "Integer -> Float#" integerToFloatName (\_ -> mkFloatLitFloat . fromInteger) + , integer_to_lit "Integer -> Double#" integerToDoubleName (\_ -> mkDoubleLitDouble . fromInteger) + + , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampName False True + , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalName False False + , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False + + , natural_to_word "Natural -> Word# (wrap)" naturalToWordName + + -- comparisons (return an unlifted Int#) + , bignum_bin_pred "bigNatEq#" bignatEqName (==) + + -- comparisons (return an Ordering) + , bignum_compare "bignatCompare" bignatCompareName + , bignum_compare "bignatCompareWord#" bignatCompareWordName + + -- binary operations + , integer_binop "integerAdd" integerAddName (+) + , integer_binop "integerSub" integerSubName (-) + , integer_binop "integerMul" integerMulName (*) + , integer_binop "integerGcd" integerGcdName gcd + , integer_binop "integerLcm" integerLcmName lcm + , integer_binop "integerAnd" integerAndName (.&.) + , integer_binop "integerOr" integerOrName (.|.) + , integer_binop "integerXor" integerXorName xor + + , natural_binop "naturalAdd" naturalAddName (+) + , natural_binop "naturalMul" naturalMulName (*) + , natural_binop "naturalGcd" naturalGcdName gcd + , natural_binop "naturalLcm" naturalLcmName lcm + , natural_binop "naturalAnd" naturalAndName (.&.) + , natural_binop "naturalOr" naturalOrName (.|.) + , natural_binop "naturalXor" naturalXorName xor + + -- Natural subtraction: it's a binop but it can fail because of underflow so + -- we have several primitives to handle here. + , natural_sub "naturalSubUnsafe" naturalSubUnsafeName + , natural_sub "naturalSubThrow" naturalSubThrowName + , mkRule "naturalSub" naturalSubName 2 $ do + [a0,a1] <- getArgs + x <- isNaturalLiteral a0 + y <- isNaturalLiteral a1 + -- return an unboxed sum: (# (# #) | Natural #) + let ret n v = pure $ mkCoreUnboxedSum 2 n [unboxedUnitTy,naturalTy] v + platform <- getPlatform + if x < y + then ret 1 unboxedUnitExpr + else ret 2 $ mkNaturalExpr platform (x - y) + + -- unary operations + , bignum_unop "integerNegate" integerNegateName mkIntegerExpr negate + , bignum_unop "integerAbs" integerAbsName mkIntegerExpr abs + , bignum_unop "integerComplement" integerComplementName mkIntegerExpr complement + + , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap + , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap + + -- Bits.bit + , bignum_bit "integerBit" integerBitName mkIntegerExpr + , bignum_bit "naturalBit" naturalBitName mkNaturalExpr + + -- Bits.testBit + , bignum_testbit "integerTestBit" integerTestBitName + , bignum_testbit "naturalTestBit" naturalTestBitName + + -- Bits.shift + , bignum_shift "integerShiftL" integerShiftLName shiftL mkIntegerExpr + , bignum_shift "integerShiftR" integerShiftRName shiftR mkIntegerExpr + , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkNaturalExpr + , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkNaturalExpr + + -- division + , divop_one "integerQuot" integerQuotName quot mkIntegerExpr + , divop_one "integerRem" integerRemName rem mkIntegerExpr + , divop_one "integerDiv" integerDivName div mkIntegerExpr + , divop_one "integerMod" integerModName mod mkIntegerExpr + , divop_both "integerDivMod" integerDivModName divMod mkIntegerExpr + , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr + + , divop_one "naturalQuot" naturalQuotName quot mkNaturalExpr + , divop_one "naturalRem" naturalRemName rem mkNaturalExpr + , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr + + -- conversions from Rational for Float/Double literals + , rational_to "rationalToFloat" rationalToFloatName mkFloatExpr + , rational_to "rationalToDouble" rationalToDoubleName mkDoubleExpr + + -- conversions from Integer for Float/Double literals + , integer_encode_float "integerEncodeFloat" integerEncodeFloatName mkFloatLitFloat + , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble + ] + where + mkRule str name nargs f = BuiltinRule + { ru_name = fsLit str + , ru_fn = name + , ru_nargs = nargs + , ru_try = runRuleM $ do + env <- getRuleOpts + guard (roBignumRules env) + f + } + + integer_to_lit str name convert = mkRule str name 1 $ do + [a0] <- getArgs + platform <- getPlatform + -- we only match on Big Integer literals. Small literals + -- are matched by the "Int# -> Integer -> *" rules + x <- isBigIntegerLiteral a0 + pure (convert platform x) + + natural_to_word str name = mkRule str name 1 $ do + [a0] <- getArgs + n <- isNaturalLiteral a0 + platform <- getPlatform + pure (Lit (mkLitWordWrap platform n)) + + integer_to_natural str name thrw clamp = mkRule str name 1 $ do + [a0] <- getArgs + x <- isIntegerLiteral a0 + platform <- getPlatform + if | x >= 0 -> pure $ mkNaturalExpr platform x + | thrw -> mzero + | clamp -> pure $ mkNaturalExpr platform 0 -- clamp to 0 + | otherwise -> pure $ mkNaturalExpr platform (abs x) -- negate/wrap + + lit_to_integer str name = mkRule str name 1 $ do + [a0] <- getArgs + platform <- getPlatform + i <- isBignumLiteral a0 + -- convert any numeric literal into an Integer literal + pure (mkIntegerExpr platform i) + + integer_binop str name op = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isIntegerLiteral a0 + y <- isIntegerLiteral a1 + platform <- getPlatform + pure (mkIntegerExpr platform (x `op` y)) + + natural_binop str name op = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isNaturalLiteral a0 + y <- isNaturalLiteral a1 + platform <- getPlatform + pure (mkNaturalExpr platform (x `op` y)) + + natural_sub str name = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isNaturalLiteral a0 + y <- isNaturalLiteral a1 + guard (x >= y) + platform <- getPlatform + pure (mkNaturalExpr platform (x - y)) + + bignum_bin_pred str name op = mkRule str name 2 $ do + platform <- getPlatform + [a0,a1] <- getArgs + x <- isBignumLiteral a0 + y <- isBignumLiteral a1 + pure $ if x `op` y + then trueValInt platform + else falseValInt platform + + bignum_compare str name = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isBignumLiteral a0 + y <- isBignumLiteral a1 + pure $ case x `compare` y of + LT -> ltVal + EQ -> eqVal + GT -> gtVal + + bignum_unop str name mk_lit op = mkRule str name 1 $ do + [a0] <- getArgs + x <- isBignumLiteral a0 + platform <- getPlatform + pure $ mk_lit platform (op x) + + bignum_popcount str name mk_lit = mkRule str name 1 $ do + platform <- getPlatform + -- We use a host Int to compute the popCount. If we compile on a 32-bit + -- host for a 64-bit target, the result may be different than if computed + -- by the target. So we disable this rule if sizes don't match. + guard (platformWordSizeInBits platform <= finiteBitSize (0 :: Word)) + [a0] <- getArgs + x <- isBignumLiteral a0 + pure $ Lit (mk_lit platform (fromIntegral (popCount x))) + + bignum_bit str name mk_lit = mkRule str name 1 $ do + [a0] <- getArgs + platform <- getPlatform + n <- isNumberLiteral a0 + -- Make sure n is positive and small enough to yield a decently + -- small number. Attempting to construct the Integer for + -- (integerBit 9223372036854775807#) + -- would be a bad idea (#14959) + guard (n >= 0 && n <= fromIntegral (platformWordSizeInBits platform)) + -- it's safe to convert a target Int value into a host Int value + -- to perform the "bit" operation because n is very small (<= 64). + pure $ mk_lit platform (bit (fromIntegral n)) + + bignum_testbit str name = mkRule str name 2 $ do + [a0,a1] <- getArgs + platform <- getPlatform + x <- isBignumLiteral a0 + n <- isNumberLiteral a1 + -- ensure that we can store 'n' in a host Int + guard (n >= 0 && n <= fromIntegral (maxBound :: Int)) + pure $ if testBit x (fromIntegral n) + then trueValInt platform + else falseValInt platform + + bignum_shift str name shift_op mk_lit = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isBignumLiteral a0 + n <- isNumberLiteral a1 + -- See Note [Guarding against silly shifts] + -- Restrict constant-folding of shifts on Integers, somewhat arbitrary. + -- We can get huge shifts in inaccessible code (#15673) + guard (n <= 4) + platform <- getPlatform + pure $ mk_lit platform (x `shift_op` fromIntegral n) + + divop_one str name divop mk_lit = mkRule str name 2 $ do + [a0,a1] <- getArgs + n <- isBignumLiteral a0 + d <- isBignumLiteral a1 + guard (d /= 0) + platform <- getPlatform + pure $ mk_lit platform (n `divop` d) + + divop_both str name divop mk_lit = mkRule str name 2 $ do + [a0,a1] <- getArgs + n <- isBignumLiteral a0 + d <- isBignumLiteral a1 + guard (d /= 0) + let (r,s) = n `divop` d + platform <- getPlatform + pure $ mkCoreUnboxedTuple [mk_lit platform r, mk_lit platform s] + + integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule + integer_encode_float str name mk_lit = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isIntegerLiteral a0 + y <- isNumberLiteral a1 + -- check that y (a target Int) is in the host Int range + guard (y <= fromIntegral (maxBound :: Int)) + pure (mk_lit $ encodeFloat x (fromInteger y)) + + rational_to :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule + rational_to str name mk_lit = mkRule str name 2 $ do + -- This turns `rationalToFloat n d` where `n` and `d` are literals into + -- a literal Float (and similarly for Double). + [a0,a1] <- getArgs + n <- isIntegerLiteral a0 + d <- isIntegerLiteral a1 + -- it's important to not match d == 0, because that may represent a + -- literal "0/0" or similar, and we can't produce a literal value for + -- NaN or +-Inf + guard (d /= 0) + pure $ mk_lit (fromRational (n % d)) + + +--------------------------------------------------- +-- The rules are: +-- unpackAppendCString*# "foo"# (unpackCString*# "baz"#) +-- = unpackCString*# "foobaz"# +-- +-- unpackAppendCString*# "foo"# (unpackAppendCString*# "baz"# e) +-- = unpackAppendCString*# "foobaz"# e +-- + +-- CString version +match_cstring_append_lit_C :: RuleFun +match_cstring_append_lit_C = match_cstring_append_lit unpackCStringAppendIdKey unpackCStringIdKey + +-- CStringUTF8 version +match_cstring_append_lit_utf8 :: RuleFun +match_cstring_append_lit_utf8 = match_cstring_append_lit unpackCStringAppendUtf8IdKey unpackCStringUtf8IdKey + +{-# INLINE match_cstring_append_lit #-} +match_cstring_append_lit :: Unique -> Unique -> RuleFun +match_cstring_append_lit append_key unpack_key _ env _ [lit1, e2] + | Just (LitString s1) <- exprIsLiteral_maybe env lit1 + , (strTicks, Var unpk `App` lit2) <- stripStrTopTicks env e2 + , unpk `hasKey` unpack_key + , Just (LitString s2) <- exprIsLiteral_maybe env lit2 + = Just $ mkTicks strTicks + $ Var unpk `App` Lit (LitString (s1 `BS.append` s2)) + + | Just (LitString s1) <- exprIsLiteral_maybe env lit1 + , (strTicks, Var appnd `App` lit2 `App` e) <- stripStrTopTicks env e2 + , appnd `hasKey` append_key + , Just (LitString s2) <- exprIsLiteral_maybe env lit2 + = Just $ mkTicks strTicks + $ Var appnd `App` Lit (LitString (s1 `BS.append` s2)) `App` e + +match_cstring_append_lit _ _ _ _ _ _ = Nothing + +--------------------------------------------------- +-- The rule is this: +-- unpackFoldrCString*# "foo"# c (unpackFoldrCString*# "baz"# c n) +-- = unpackFoldrCString*# "foobaz"# c n +-- +-- See also Note [String literals in GHC] in CString.hs + +-- CString version +match_cstring_foldr_lit_C :: RuleFun +match_cstring_foldr_lit_C = match_cstring_foldr_lit unpackCStringFoldrIdKey + +-- CStringUTF8 version +match_cstring_foldr_lit_utf8 :: RuleFun +match_cstring_foldr_lit_utf8 = match_cstring_foldr_lit unpackCStringFoldrUtf8IdKey + +{-# INLINE match_cstring_foldr_lit #-} +match_cstring_foldr_lit :: Unique -> RuleFun +match_cstring_foldr_lit foldVariant _ env _ + [ Type ty1 + , lit1 + , c1 + , e2 + ] + | (strTicks, Var unpk `App` Type ty2 + `App` lit2 + `App` c2 + `App` n) <- stripStrTopTicks env e2 + , unpk `hasKey` foldVariant + , Just (LitString s1) <- exprIsLiteral_maybe env lit1 + , Just (LitString s2) <- exprIsLiteral_maybe env lit2 + , eqCoreExpr c1 c2 + , (c1Ticks, c1') <- stripStrTopTicks env c1 + , c2Ticks <- stripStrTopTicksT c2 + = assert (ty1 `eqType` ty2) $ + Just $ mkTicks strTicks + $ Var unpk `App` Type ty1 + `App` Lit (LitString (s1 `BS.append` s2)) + `App` mkTicks (c1Ticks ++ c2Ticks) c1' + `App` n + +match_cstring_foldr_lit _ _ _ _ _ = Nothing + + +-- N.B. Ensure that we strip off any ticks (e.g. source notes) from the +-- argument, lest this may fail to fire when building with -g3. See #16740. +-- +-- Also, look into variable's unfolding just in case the expression we look for +-- is in a top-level thunk. +stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr) +stripStrTopTicks (ISE _ id_unf) e = case e of + Var v + | Just rhs <- expandUnfolding_maybe (id_unf v) + -> stripTicksTop tickishFloatable rhs + _ -> stripTicksTop tickishFloatable e + +stripStrTopTicksT :: CoreExpr -> [CoreTickish] +stripStrTopTicksT e = stripTicksTopT tickishFloatable e + +--------------------------------------------------- +-- The rule is this: +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 +-- Also matches unpackCStringUtf8# + +match_eq_string :: RuleFun +match_eq_string _ env _ [e1, e2] + | (ticks1, Var unpk1 `App` lit1) <- stripStrTopTicks env e1 + , (ticks2, Var unpk2 `App` lit2) <- stripStrTopTicks env e2 + , unpk_key1 <- getUnique unpk1 + , unpk_key2 <- getUnique unpk2 + , unpk_key1 == unpk_key2 + -- For now we insist the literals have to agree in their encoding + -- to keep the rule simple. But we could check if the decoded strings + -- compare equal in here as well. + , unpk_key1 `elem` [unpackCStringUtf8IdKey, unpackCStringIdKey] + , Just (LitString s1) <- exprIsLiteral_maybe env lit1 + , Just (LitString s2) <- exprIsLiteral_maybe env lit2 + = Just $ mkTicks (ticks1 ++ ticks2) + $ (if s1 == s2 then trueValBool else falseValBool) + +match_eq_string _ _ _ _ = Nothing + +----------------------------------------------------------------------- +-- Illustration of this rule: +-- +-- cstringLength# "foobar"# --> 6 +-- cstringLength# "fizz\NULzz"# --> 4 +-- +-- Nota bene: Addr# literals are suffixed by a NUL byte when they are +-- compiled to read-only data sections. That's why cstringLength# is +-- well defined on Addr# literals that do not explicitly have an embedded +-- NUL byte. +-- +-- See GHC issue #5218, MR 2165, and bytestring PR 191. This is particularly +-- helpful when using OverloadedStrings to create a ByteString since the +-- function computing the length of such ByteStrings can often be constant +-- folded. +match_cstring_length :: RuleFun +match_cstring_length rule_env env _ [lit1] + | Just (LitString str) <- exprIsLiteral_maybe env lit1 + -- If elemIndex returns Just, it has the index of the first embedded NUL + -- in the string. If no NUL bytes are present (the common case) then use + -- full length of the byte string. + = let len = fromMaybe (BS.length str) (BS.elemIndex 0 str) + in Just (Lit (mkLitInt (roPlatform rule_env) (fromIntegral len))) +match_cstring_length _ _ _ _ = Nothing + +{- Note [inlineId magic] +~~~~~~~~~~~~~~~~~~~~~~~~ +The call 'inline f' arranges that 'f' is inlined, regardless of +its size. More precisely, the call 'inline f' rewrites to the +right-hand side of 'f's definition. This allows the programmer to +control inlining from a particular call site rather than the +definition site of the function. + +The moving parts are simple: + +* A very simple definition in the library base:GHC.Magic + {-# NOINLINE[0] inline #-} + inline :: a -> a + inline x = x + So in phase 0, 'inline' will be inlined, so its use imposes + no overhead. + +* A rewrite rule, in GHC.Core.Opt.ConstantFold, which makes + (inline f) inline, implemented by match_inline. + The rule for the 'inline' function is this: + inline f_ty (f a b c) = a b c + (if f has an unfolding, EVEN if it's a loop breaker) + + Additionally the rule looks through ticks/casts as well (#24808): + inline f_ty (f a b c |> co) = a b c |> co + inline f_ty ( f a b c ) = a b c + + It's important to allow the argument to 'inline' to have args itself + (a) because its more forgiving to allow the programmer to write + either inline f a b c + or inline (f a b c) + (b) because a polymorphic f wll get a type argument that the + programmer can't avoid, so the call may look like + inline (map @Int @Bool) g xs + + Also, don't forget about 'inline's type argument! +-} + +match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_inline (Type _ : e : _) = go e + -- Maybe Monad ahead: + where + go (Var f) = -- Ignore the IdUnfoldingFun here! + (maybeUnfoldingTemplate (realIdUnfolding f)) + go (App f a) = do { f' <- go f; pure $ App f' a } + -- inline (f |> co) + go (Cast e co) = do { app <- go e; pure (Cast app co) } + -- inline ( f) + go (Tick t e) = do { app <- go e; pure (Tick t app) } + go _ = Nothing + +match_inline _ = Nothing + +-------------------------------------------------------- +-- Note [Constant folding through nested expressions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- GHC has some support for constant folding through nested expressions (i.e. +-- when constants are not only arguments of the considered App node but to one +-- of its own argument (an App node too), see examples below). +-- +-- For performance reason, this optimization is only enabled with -O1 and above. +-- As with all optimizations, it can also be independently enabled with its own +-- command-line flag too: -fnum-constant-folding (grep Opt_NumConstantFolding). +-- +-- We use rewrites rules to perform constant folding. It means that we don't +-- have a global view of the expression we are trying to optimise. As a +-- consequence we only perform local (small-step) transformations that either: +-- 1) reduce the number of operations +-- 2) rearrange the expression to increase the odds that other rules will +-- match +-- +-- We don't try to handle more complex expression optimisation cases that would +-- require a global view. For example, rewriting expressions to increase +-- sharing (e.g., Horner's method); optimisations that require local +-- transformations increasing the number of operations; rearrangements to +-- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0). +-- +-- We already have rules to perform constant folding on expressions with the +-- following shape (where a and/or b are literals): +-- +-- D) op +-- /\ +-- / \ +-- / \ +-- a b +-- +-- To support nested expressions, we match three other shapes of expression +-- trees: +-- +-- A) op1 B) op1 C) op1 +-- /\ /\ /\ +-- / \ / \ / \ +-- / \ / \ / \ +-- a op2 op2 c op2 op3 +-- /\ /\ /\ /\ +-- / \ / \ / \ / \ +-- b c a b a b c d +-- +-- +-- R1) +/- simplification: +-- ops = + or -, two literals (not siblings) +-- +-- Examples: +-- A: 5 + (10-x) ==> 15-x +-- B: (10+x) + 5 ==> 15+x +-- C: (5+a)-(5-b) ==> 0+(a+b) +-- +-- R2) *, `and`, `or` simplification +-- ops = *, `and`, `or` two literals (not siblings) +-- +-- Examples: +-- A: 5 * (10*x) ==> 50*x +-- B: (10*x) * 5 ==> 50*x +-- C: (5*a)*(5*b) ==> 25*(a*b) +-- +-- R3) * distribution over +/- +-- op1 = *, op2 = + or -, two literals (not siblings) +-- +-- This transformation doesn't reduce the number of operations but switches +-- the outer and the inner operations so that the outer is (+) or (-) instead +-- of (*). It increases the odds that other rules will match after this one. +-- +-- Examples: +-- A: 5 * (10-x) ==> 50 - (5*x) +-- B: (10+x) * 5 ==> 50 + (5*x) +-- C: Not supported as it would increase the number of operations: +-- (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b +-- +-- R4) Simple factorization +-- +-- op1 = + or -, op2/op3 = *, +-- one literal for each innermost * operation (except in the D case), +-- the two other terms are equals +-- +-- Examples: +-- A: x - (10*x) ==> (-9)*x +-- B: (10*x) + x ==> 11*x +-- C: (5*x)-(x*3) ==> 2*x +-- D: x+x ==> 2*x +-- +-- R5) +/- propagation +-- +-- ops = + or -, one literal +-- +-- This transformation doesn't reduce the number of operations but propagates +-- the constant to the outer level. It increases the odds that other rules +-- will match after this one. +-- +-- Examples: +-- A: x - (10-y) ==> (x+y) - 10 +-- B: (10+x) - y ==> 10 + (x-y) +-- C: N/A (caught by the A and B cases) +-- +-------------------------------------------------------- + +-- Rules to perform constant folding into nested expressions +-- +--See Note [Constant folding through nested expressions] + +addFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr +addFoldingRules op num_ops = do + massert (op == numAdd num_ops) + env <- getRuleOpts + guard (roNumConstantFolding env) + [arg1,arg2] <- getArgs + platform <- getPlatform + liftMaybe + -- commutativity for + is handled here + (addFoldingRules' platform arg1 arg2 num_ops + <|> addFoldingRules' platform arg2 arg1 num_ops) + +subFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr +subFoldingRules op num_ops = do + massert (op == numSub num_ops) + env <- getRuleOpts + guard (roNumConstantFolding env) + [arg1,arg2] <- getArgs + platform <- getPlatform + liftMaybe (subFoldingRules' platform arg1 arg2 num_ops) + +mulFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr +mulFoldingRules op num_ops = do + massert (op == numMul num_ops) + env <- getRuleOpts + guard (roNumConstantFolding env) + [arg1,arg2] <- getArgs + platform <- getPlatform + liftMaybe + -- commutativity for * is handled here + (mulFoldingRules' platform arg1 arg2 num_ops + <|> mulFoldingRules' platform arg2 arg1 num_ops) + +andFoldingRules :: NumOps -> RuleM CoreExpr +andFoldingRules num_ops = do + env <- getRuleOpts + guard (roNumConstantFolding env) + [arg1,arg2] <- getArgs + platform <- getPlatform + liftMaybe + -- commutativity for `and` is handled here + (andFoldingRules' platform arg1 arg2 num_ops + <|> andFoldingRules' platform arg2 arg1 num_ops) + +orFoldingRules :: NumOps -> RuleM CoreExpr +orFoldingRules num_ops = do + env <- getRuleOpts + guard (roNumConstantFolding env) + [arg1,arg2] <- getArgs + platform <- getPlatform + liftMaybe + -- commutativity for `or` is handled here + (orFoldingRules' platform arg1 arg2 num_ops + <|> orFoldingRules' platform arg2 arg1 num_ops) + +quotFoldingRules :: NumOps -> RuleM CoreExpr +quotFoldingRules num_ops = do + env <- getRuleOpts + guard (roNumConstantFolding env) + [arg1,arg2] <- getArgs + platform <- getPlatform + liftMaybe (quotFoldingRules' platform arg1 arg2 num_ops) + +addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr +addFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of + + -- x + (-y) ==> x-y + (x, is_neg num_ops -> Just y) + -> Just (x `sub` y) + + -- R1) +/- simplification + + -- l1 + (l2 + x) ==> (l1+l2) + x + (L l1, is_lit_add num_ops -> Just (l2,x)) + -> Just (mkL (l1+l2) `add` x) + + -- l1 + (l2 - x) ==> (l1+l2) - x + (L l1, is_sub num_ops -> Just (L l2,x)) + -> Just (mkL (l1+l2) `sub` x) + + -- l1 + (x - l2) ==> (l1-l2) + x + (L l1, is_sub num_ops -> Just (x,L l2)) + -> Just (mkL (l1-l2) `add` x) + + -- (l1 + x) + (l2 + y) ==> (l1+l2) + (x+y) + (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y)) + -> Just (mkL (l1+l2) `add` (x `add` y)) + + -- (l1 + x) + (l2 - y) ==> (l1+l2) + (x-y) + (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y)) + -> Just (mkL (l1+l2) `add` (x `sub` y)) + + -- (l1 + x) + (y - l2) ==> (l1-l2) + (x+y) + (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2)) + -> Just (mkL (l1-l2) `add` (x `add` y)) + + -- (l1 - x) + (l2 - y) ==> (l1+l2) - (x+y) + (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y)) + -> Just (mkL (l1+l2) `sub` (x `add` y)) + + -- (l1 - x) + (y - l2) ==> (l1-l2) + (y-x) + (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2)) + -> Just (mkL (l1-l2) `add` (y `sub` x)) + + -- (x - l1) + (y - l2) ==> (0-l1-l2) + (x+y) + (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2)) + -> Just (mkL (0-l1-l2) `add` (x `add` y)) + + -- R4) Simple factorization + + -- x + x ==> 2 * x + _ | Just l1 <- is_expr_mul num_ops arg1 arg2 + -> Just (mkL (l1+1) `mul` arg1) + + -- (l1 * x) + x ==> (l1+1) * x + _ | Just l1 <- is_expr_mul num_ops arg2 arg1 + -> Just (mkL (l1+1) `mul` arg2) + + -- (l1 * x) + (l2 * x) ==> (l1+l2) * x + (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2) + -> Just (mkL (l1+l2) `mul` x) + + -- R5) +/- propagation: these transformations push literals outwards + -- with the hope that other rules can then be applied. + + -- In the following rules, x can't be a literal otherwise another + -- rule would have combined it with the other literal in arg2. So we + -- don't have to check this to avoid loops here. + + -- x + (l1 + y) ==> l1 + (x + y) + (_, is_lit_add num_ops -> Just (l1,y)) + -> Just (mkL l1 `add` (arg1 `add` y)) + + -- x + (l1 - y) ==> l1 + (x - y) + (_, is_sub num_ops -> Just (L l1,y)) + -> Just (mkL l1 `add` (arg1 `sub` y)) + + -- x + (y - l1) ==> (x + y) - l1 + (_, is_sub num_ops -> Just (y,L l1)) + -> Just ((arg1 `add` y) `sub` mkL l1) + + _ -> Nothing + + where + mkL = Lit . mkNumLiteral platform num_ops + add x y = BinOpApp x (numAdd num_ops) y + sub x y = BinOpApp x (numSub num_ops) y + mul x y = BinOpApp x (numMul num_ops) y + +subFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr +subFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of + -- x - (-y) ==> x+y + (x, is_neg num_ops -> Just y) + -> Just (x `add` y) + + -- R1) +/- simplification + + -- l1 - (l2 + x) ==> (l1-l2) - x + (L l1, is_lit_add num_ops -> Just (l2,x)) + -> Just (mkL (l1-l2) `sub` x) + + -- l1 - (l2 - x) ==> (l1-l2) + x + (L l1, is_sub num_ops -> Just (L l2,x)) + -> Just (mkL (l1-l2) `add` x) + + -- l1 - (x - l2) ==> (l1+l2) - x + (L l1, is_sub num_ops -> Just (x, L l2)) + -> Just (mkL (l1+l2) `sub` x) + + -- (l1 + x) - l2 ==> (l1-l2) + x + (is_lit_add num_ops -> Just (l1,x), L l2) + -> Just (mkL (l1-l2) `add` x) + + -- (l1 - x) - l2 ==> (l1-l2) - x + (is_sub num_ops -> Just (L l1,x), L l2) + -> Just (mkL (l1-l2) `sub` x) + + -- (x - l1) - l2 ==> x - (l1+l2) + (is_sub num_ops -> Just (x,L l1), L l2) + -> Just (x `sub` mkL (l1+l2)) + + + -- (l1 + x) - (l2 + y) ==> (l1-l2) + (x-y) + (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y)) + -> Just (mkL (l1-l2) `add` (x `sub` y)) + + -- (l1 + x) - (l2 - y) ==> (l1-l2) + (x+y) + (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y)) + -> Just (mkL (l1-l2) `add` (x `add` y)) + + -- (l1 + x) - (y - l2) ==> (l1+l2) + (x-y) + (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2)) + -> Just (mkL (l1+l2) `add` (x `sub` y)) + + -- (l1 - x) - (l2 + y) ==> (l1-l2) - (x+y) + (is_sub num_ops -> Just (L l1,x), is_lit_add num_ops -> Just (l2,y)) + -> Just (mkL (l1-l2) `sub` (x `add` y)) + + -- (x - l1) - (l2 + y) ==> (0-l1-l2) + (x-y) + (is_sub num_ops -> Just (x,L l1), is_lit_add num_ops -> Just (l2,y)) + -> Just (mkL (0-l1-l2) `add` (x `sub` y)) + + -- (l1 - x) - (l2 - y) ==> (l1-l2) + (y-x) + (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y)) + -> Just (mkL (l1-l2) `add` (y `sub` x)) + + -- (l1 - x) - (y - l2) ==> (l1+l2) - (x+y) + (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2)) + -> Just (mkL (l1+l2) `sub` (x `add` y)) + + -- (x - l1) - (l2 - y) ==> (0-l1-l2) + (x+y) + (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (L l2,y)) + -> Just (mkL (0-l1-l2) `add` (x `add` y)) + + -- (x - l1) - (y - l2) ==> (l2-l1) + (x-y) + (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2)) + -> Just (mkL (l2-l1) `add` (x `sub` y)) + + -- R4) Simple factorization + + -- x - (l1 * x) ==> (1-l1) * x + _ | Just l1 <- is_expr_mul num_ops arg1 arg2 + -> Just (mkL (1-l1) `mul` arg1) + + -- (l1 * x) - x ==> (l1-1) * x + _ | Just l1 <- is_expr_mul num_ops arg2 arg1 + -> Just (mkL (l1-1) `mul` arg2) + + -- (l1 * x) - (l2 * x) ==> (l1-l2) * x + (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2) + -> Just (mkL (l1-l2) `mul` x) + + -- R5) +/- propagation: these transformations push literals outwards + -- with the hope that other rules can then be applied. + + -- In the following rules, x can't be a literal otherwise another + -- rule would have combined it with the other literal in arg2. So we + -- don't have to check this to avoid loops here. + + -- x - (l1 + y) ==> (x - y) - l1 + (_, is_lit_add num_ops -> Just (l1,y)) + -> Just ((arg1 `sub` y) `sub` mkL l1) + + -- (l1 + x) - y ==> l1 + (x - y) + (is_lit_add num_ops -> Just (l1,x), _) + -> Just (mkL l1 `add` (x `sub` arg2)) + + -- x - (l1 - y) ==> (x + y) - l1 + (_, is_sub num_ops -> Just (L l1,y)) + -> Just ((arg1 `add` y) `sub` mkL l1) + + -- x - (y - l1) ==> l1 + (x - y) + (_, is_sub num_ops -> Just (y,L l1)) + -> Just (mkL l1 `add` (arg1 `sub` y)) + + -- (l1 - x) - y ==> l1 - (x + y) + (is_sub num_ops -> Just (L l1,x), _) + -> Just (mkL l1 `sub` (x `add` arg2)) + + -- (x - l1) - y ==> (x - y) - l1 + (is_sub num_ops -> Just (x,L l1), _) + -> Just ((x `sub` arg2) `sub` mkL l1) + + _ -> Nothing + where + mkL = Lit . mkNumLiteral platform num_ops + add x y = BinOpApp x (numAdd num_ops) y + sub x y = BinOpApp x (numSub num_ops) y + mul x y = BinOpApp x (numMul num_ops) y + +mulFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr +mulFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of + -- (-x) * (-y) ==> x*y + (is_neg num_ops -> Just x, is_neg num_ops -> Just y) + -> Just (x `mul` y) + + -- l1 * (-x) ==> (-l1) * x + (L l1, is_neg num_ops -> Just x) + -> Just (mkL (-l1) `mul` x) + + -- l1 * (l2 * x) ==> (l1*l2) * x + (L l1, is_lit_mul num_ops -> Just (l2,x)) + -> Just (mkL (l1*l2) `mul` x) + + -- l1 * (l2 + x) ==> (l1*l2) + (l1 * x) + (L l1, is_lit_add num_ops -> Just (l2,x)) + -> Just (mkL (l1*l2) `add` (arg1 `mul` x)) + + -- l1 * (l2 - x) ==> (l1*l2) - (l1 * x) + (L l1, is_sub num_ops -> Just (L l2,x)) + -> Just (mkL (l1*l2) `sub` (arg1 `mul` x)) + + -- l1 * (x - l2) ==> (l1 * x) - (l1*l2) + (L l1, is_sub num_ops -> Just (x, L l2)) + -> Just ((arg1 `mul` x) `sub` mkL (l1*l2)) + + -- (l1 * x) * (l2 * y) ==> (l1*l2) * (x * y) + (is_lit_mul num_ops -> Just (l1,x), is_lit_mul num_ops -> Just (l2,y)) + -> Just (mkL (l1*l2) `mul` (x `mul` y)) + + _ -> Nothing + where + mkL = Lit . mkNumLiteral platform num_ops + add x y = BinOpApp x (numAdd num_ops) y + sub x y = BinOpApp x (numSub num_ops) y + mul x y = BinOpApp x (numMul num_ops) y + +andFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr +andFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of + -- R2) * `or` `and` simplifications + -- l1 and (l2 and x) ==> (l1 and l2) and x + (L l1, is_lit_and num_ops -> Just (l2, x)) + -> Just (mkL (l1 .&. l2) `and` x) + + -- l1 and (l2 or x) ==> (l1 and l2) or (l1 and x) + -- does not decrease operations + + -- (l1 and x) and (l2 and y) ==> (l1 and l2) and (x and y) + (is_lit_and num_ops -> Just (l1, x), is_lit_and num_ops -> Just (l2, y)) + -> Just (mkL (l1 .&. l2) `and` (x `and` y)) + + -- (l1 and x) and (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y) + -- (l1 or x) and (l2 or y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y) + -- increase operation numbers + + -- x and (y or ... or x or ... or z) ==> x + (x, is_or_list num_ops -> Just xs) + | any (cheapEqExpr x) xs + -> Just x + + _ -> Nothing + where + mkL = Lit . mkNumLiteral platform num_ops + and x y = BinOpApp x (fromJust (numAnd num_ops)) y + +orFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr +orFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of + -- R2) * `or` `and` simplifications + -- l1 or (l2 or x) ==> (l1 or l2) or x + (L l1, is_lit_or num_ops -> Just (l2, x)) + -> Just (mkL (l1 .|. l2) `or` x) + + -- l1 or (l2 and x) ==> (l1 or l2) and (l1 and x) + -- does not decrease operations + + -- (l1 or x) or (l2 or y) ==> (l1 or l2) or (x or y) + (is_lit_or num_ops -> Just (l1, x), is_lit_or num_ops -> Just (l2, y)) + -> Just (mkL (l1 .|. l2) `or` (x `or` y)) + + -- (l1 and x) or (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y) + -- (l1 and x) or (l2 and y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y) + -- increase operation numbers + + -- x or (y and ... and x and ... and z) ==> x + (x, is_and_list num_ops -> Just xs) + | any (cheapEqExpr x) xs + -> Just x + + _ -> Nothing + where + mkL = Lit . mkNumLiteral platform num_ops + or x y = BinOpApp x (fromJust (numOr num_ops)) y + +quotFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr +quotFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of + + -- (x / l1) / l2 + -- l1 and l2 /= 0 + -- l1*l2 doesn't overflow + -- ==> x / (l1 * l2) + (is_div num_ops -> Just (x, L l1), L l2) + | l1 /= 0 + , l2 /= 0 + -- check that the result of the multiplication is in range + , Just l <- mkNumLiteralMaybe platform num_ops (l1 * l2) + -> Just (div x (Lit l)) + -- NB: we could directly return 0 or (-1) in case of overflow, + -- but we would need to know + -- (1) if we're dealing with a quot or a div operation + -- (2) if it's an underflow or an overflow. + -- Left as future work for now. + + _ -> Nothing + where + div x y = BinOpApp x (fromJust (numDiv num_ops)) y + +is_binop :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr) +is_binop op e = case e of + BinOpApp x op' y | op == op' -> Just (x,y) + _ -> Nothing + +is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr) +is_op op e = case e of + App (OpVal op') x | op == op' -> Just x + _ -> Nothing + +is_add, is_sub, is_mul, is_and, is_or, is_div :: NumOps -> CoreExpr -> Maybe (CoreArg, CoreArg) +is_add num_ops e = is_binop (numAdd num_ops) e +is_sub num_ops e = is_binop (numSub num_ops) e +is_mul num_ops e = is_binop (numMul num_ops) e +is_and num_ops e = numAnd num_ops >>= \op -> is_binop op e +is_or num_ops e = numOr num_ops >>= \op -> is_binop op e +is_div num_ops e = numDiv num_ops >>= \op -> is_binop op e + +is_neg :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr) +is_neg num_ops e = numNeg num_ops >>= \op -> is_op op e + +-- Return a list of operands for a given operation. +-- E.e. is_and_list (a and ... and z) => [a,...,z] for any nesting of the and +-- operation +is_list :: (CoreExpr -> Maybe (CoreArg,CoreArg)) -> CoreExpr -> Maybe [CoreArg] +is_list f e_org = case f e_org of -- do we have the operator at all? + Just (a,b) -> Just (go [a,b]) + Nothing -> Nothing + where + go = \case + [] -> [] + (e:es) -> case f e of + -- we can't split any more: add to the result list + Nothing -> e : go es + Just (a,b) -> go (a:b:es) + +is_and_list, is_or_list :: NumOps -> CoreExpr -> Maybe [CoreArg] +is_and_list ops = is_list (is_and ops) +is_or_list ops = is_list (is_or ops) + +-- match operation with a literal (handles commutativity) +is_lit_add, is_lit_mul, is_lit_and, is_lit_or :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr) +is_lit_add num_ops e = is_lit' is_add num_ops e +is_lit_mul num_ops e = is_lit' is_mul num_ops e +is_lit_and num_ops e = is_lit' is_and num_ops e +is_lit_or num_ops e = is_lit' is_or num_ops e + +is_lit' :: (NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)) -> NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr) +is_lit' f num_ops e = case f num_ops e of + Just (L l, x ) -> Just (l,x) + Just (x , L l) -> Just (l,x) + _ -> Nothing + +-- match given "x": return 1 +-- match "lit * x": return lit value (handles commutativity) +is_expr_mul :: NumOps -> Expr CoreBndr -> Expr CoreBndr -> Maybe Integer +is_expr_mul num_ops x e = if + | x `cheapEqExpr` e + -> Just 1 + | Just (k,x') <- is_lit_mul num_ops e + , x `cheapEqExpr` x' + -> return k + | otherwise + -> Nothing + + +-- | Match the application of a binary primop +pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr +pattern BinOpApp x op y = OpVal op `App` x `App` y + +-- | Match a primop +pattern OpVal:: PrimOp -> Arg CoreBndr +pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where + OpVal op = Var (primOpId op) + +-- | Match a literal +pattern L :: Integer -> Arg CoreBndr +pattern L i <- Lit (LitNumber _ i) + +-- | Explicit "type-class"-like dictionary for numeric primops +data NumOps = NumOps + { numAdd :: !PrimOp -- ^ Add two numbers + , numSub :: !PrimOp -- ^ Sub two numbers + , numMul :: !PrimOp -- ^ Multiply two numbers + , numDiv :: !(Maybe PrimOp) -- ^ Divide two numbers + , numAnd :: !(Maybe PrimOp) -- ^ And two numbers + , numOr :: !(Maybe PrimOp) -- ^ Or two numbers + , numNeg :: !(Maybe PrimOp) -- ^ Negate a number + , numLitType :: !LitNumType -- ^ Literal type + } + +-- | Create a numeric literal +mkNumLiteral :: Platform -> NumOps -> Integer -> Literal +mkNumLiteral platform ops i = mkLitNumberWrap platform (numLitType ops) i + +-- | Create a numeric literal if it is in range +mkNumLiteralMaybe :: Platform -> NumOps -> Integer -> Maybe Literal +mkNumLiteralMaybe platform ops i = mkLitNumberMaybe platform (numLitType ops) i + +int8Ops :: NumOps +int8Ops = NumOps + { numAdd = Int8AddOp + , numSub = Int8SubOp + , numMul = Int8MulOp + , numDiv = Just Int8QuotOp + , numAnd = Nothing + , numOr = Nothing + , numNeg = Just Int8NegOp + , numLitType = LitNumInt8 + } + +word8Ops :: NumOps +word8Ops = NumOps + { numAdd = Word8AddOp + , numSub = Word8SubOp + , numMul = Word8MulOp + , numDiv = Just Word8QuotOp + , numAnd = Just Word8AndOp + , numOr = Just Word8OrOp + , numNeg = Nothing + , numLitType = LitNumWord8 + } + +int16Ops :: NumOps +int16Ops = NumOps + { numAdd = Int16AddOp + , numSub = Int16SubOp + , numMul = Int16MulOp + , numDiv = Just Int16QuotOp + , numAnd = Nothing + , numOr = Nothing + , numNeg = Just Int16NegOp + , numLitType = LitNumInt16 + } + +word16Ops :: NumOps +word16Ops = NumOps + { numAdd = Word16AddOp + , numSub = Word16SubOp + , numMul = Word16MulOp + , numDiv = Just Word16QuotOp + , numAnd = Just Word16AndOp + , numOr = Just Word16OrOp + , numNeg = Nothing + , numLitType = LitNumWord16 + } + +int32Ops :: NumOps +int32Ops = NumOps + { numAdd = Int32AddOp + , numSub = Int32SubOp + , numMul = Int32MulOp + , numDiv = Just Int32QuotOp + , numAnd = Nothing + , numOr = Nothing + , numNeg = Just Int32NegOp + , numLitType = LitNumInt32 + } + +word32Ops :: NumOps +word32Ops = NumOps + { numAdd = Word32AddOp + , numSub = Word32SubOp + , numMul = Word32MulOp + , numDiv = Just Word32QuotOp + , numAnd = Just Word32AndOp + , numOr = Just Word32OrOp + , numNeg = Nothing + , numLitType = LitNumWord32 + } + +int64Ops :: NumOps +int64Ops = NumOps + { numAdd = Int64AddOp + , numSub = Int64SubOp + , numMul = Int64MulOp + , numDiv = Just Int64QuotOp + , numAnd = Nothing + , numOr = Nothing + , numNeg = Just Int64NegOp + , numLitType = LitNumInt64 + } + +word64Ops :: NumOps +word64Ops = NumOps + { numAdd = Word64AddOp + , numSub = Word64SubOp + , numMul = Word64MulOp + , numDiv = Just Word64QuotOp + , numAnd = Just Word64AndOp + , numOr = Just Word64OrOp + , numNeg = Nothing + , numLitType = LitNumWord64 + } + +intOps :: NumOps +intOps = NumOps + { numAdd = IntAddOp + , numSub = IntSubOp + , numMul = IntMulOp + , numDiv = Just IntQuotOp + , numAnd = Just IntAndOp + , numOr = Just IntOrOp + , numNeg = Just IntNegOp + , numLitType = LitNumInt + } + +wordOps :: NumOps +wordOps = NumOps + { numAdd = WordAddOp + , numSub = WordSubOp + , numMul = WordMulOp + , numDiv = Just WordQuotOp + , numAnd = Just WordAndOp + , numOr = Just WordOrOp + , numNeg = Nothing + , numLitType = LitNumWord + } + +-------------------------------------------------------- +-- Constant folding through case-expressions +-- +-- cf Scrutinee Constant Folding in simplCore/GHC.Core.Opt.Simplify.Utils +-------------------------------------------------------- + +-- | Match the scrutinee of a case and potentially return a new scrutinee and a +-- function to apply to each literal alternative. +caseRules :: Platform + -> CoreExpr -- Scrutinee + -> Maybe ( CoreExpr -- New scrutinee + , AltCon -> Maybe AltCon -- How to fix up the alt pattern + -- Nothing <=> Unreachable + -- See Note [Unreachable caseRules alternatives] + , Id -> CoreExpr) -- How to reconstruct the original scrutinee + -- from the new case-binder +-- e.g case e of b { +-- ...; +-- con bs -> rhs; +-- ... } +-- ==> +-- case e' of b' { +-- ...; +-- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs; +-- ... } + +caseRules platform (App (App (Var f) v) (Lit l)) -- v `op` x# + | Just op <- isPrimOpId_maybe f + , LitNumber _ x <- l + , Just adjust_lit <- adjustDyadicRight op x + = Just (v, tx_lit_con platform adjust_lit + , \v -> (App (App (Var f) (Var v)) (Lit l))) + +caseRules platform (App (App (Var f) (Lit l)) v) -- x# `op` v + | Just op <- isPrimOpId_maybe f + , LitNumber _ x <- l + , Just adjust_lit <- adjustDyadicLeft x op + = Just (v, tx_lit_con platform adjust_lit + , \v -> (App (App (Var f) (Lit l)) (Var v))) + + +caseRules platform (App (Var f) v ) -- op v + | Just op <- isPrimOpId_maybe f + , Just adjust_lit <- adjustUnary op + = Just (v, tx_lit_con platform adjust_lit + , \v -> App (Var f) (Var v)) + +-- See Note [caseRules for tagToEnum] +caseRules platform (App (App (Var f) type_arg) v) + | Just TagToEnumOp <- isPrimOpId_maybe f + = Just (v, tx_con_tte platform + , \v -> (App (App (Var f) type_arg) (Var v))) + +-- See Note [caseRules for dataToTag] +caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x + | Just op <- isPrimOpId_maybe f + , op == DataToTagSmallOp || op == DataToTagLargeOp + = case splitTyConApp_maybe ty of + Just (tc, _) | isValidDTT2TyCon tc + -> Just (v, tx_con_dtt tc + , \v' -> Var f `App` Type lev `App` Type ty `App` Var v') + _ -> pprTraceUserWarning warnMsg Nothing + where + warnMsg = vcat $ map text + [ "Found dataToTag primop applied to a non-ADT type. This could" + , "be a future bug in GHC, or it may be caused by an unsupported" + , "use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#." + , "In either case, the GHC developers would like to know about it!" + , "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug" + ] + +caseRules _ _ = Nothing + + +-- | Case rules +-- +-- It's important that occurrence info are present, hence the use of In* types. +caseRules2 + :: InExpr -- ^ Scutinee + -> InId -- ^ Case-binder + -> [InAlt] -- ^ Alternatives in standard (increasing) order + -> Maybe (InExpr, InId, [InAlt]) +caseRules2 scrut bndr alts + + -- case quotRem# x y of + -- (# q, _ #) -> body + -- ====> + -- case quot# x y of + -- q -> body + -- + -- case quotRem# x y of + -- (# _, r #) -> body + -- ====> + -- case rem# x y of + -- r -> body + | BinOpApp x op y <- scrut + , Just (quot,rem) <- is_any_quot_rem op + , [Alt (DataAlt _) [q,r] body] <- alts + , isDeadBinder bndr + , dead_q <- isDeadBinder q + , dead_r <- isDeadBinder r + , dead_q || dead_r + = if + | dead_q -> Just $ (BinOpApp x rem y, r, [Alt DEFAULT [] body]) + | dead_r -> Just $ (BinOpApp x quot y, q, [Alt DEFAULT [] body]) + | otherwise -> Nothing + + | otherwise + = Nothing + + +-- | If the given primop is a quotRem, return the corresponding (quot,rem). +is_any_quot_rem :: PrimOp -> Maybe (PrimOp, PrimOp) +is_any_quot_rem = \case + IntQuotRemOp -> Just (IntQuotOp , IntRemOp) + Int8QuotRemOp -> Just (Int8QuotOp, Int8RemOp) + Int16QuotRemOp -> Just (Int16QuotOp, Int16RemOp) + Int32QuotRemOp -> Just (Int32QuotOp, Int32RemOp) + -- Int64QuotRemOp doesn't exist (yet) + + WordQuotRemOp -> Just (WordQuotOp, WordRemOp) + Word8QuotRemOp -> Just (Word8QuotOp, Word8RemOp) + Word16QuotRemOp -> Just (Word16QuotOp, Word16RemOp) + Word32QuotRemOp -> Just (Word32QuotOp, Word32RemOp) + -- Word64QuotRemOp doesn't exist (yet) + + _ -> Nothing + + +tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon +tx_lit_con _ _ DEFAULT = Just DEFAULT +tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l) +tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) + -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the + -- literal alternatives remain in Word/Int target ranges + -- (See Note [Word/Int underflow/overflow] in GHC.Types.Literal and #13172). + +adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer) +-- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x +adjustDyadicRight op lit + = case op of + WordAddOp -> Just (\y -> y-lit ) + IntAddOp -> Just (\y -> y-lit ) + WordSubOp -> Just (\y -> y+lit ) + IntSubOp -> Just (\y -> y+lit ) + WordXorOp -> Just (\y -> y `xor` lit) + IntXorOp -> Just (\y -> y `xor` lit) + _ -> Nothing + +adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer) +-- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x +adjustDyadicLeft lit op + = case op of + WordAddOp -> Just (\y -> y-lit ) + IntAddOp -> Just (\y -> y-lit ) + WordSubOp -> Just (\y -> lit-y ) + IntSubOp -> Just (\y -> lit-y ) + WordXorOp -> Just (\y -> y `xor` lit) + IntXorOp -> Just (\y -> y `xor` lit) + _ -> Nothing + + +adjustUnary :: PrimOp -> Maybe (Integer -> Integer) +-- Given (op x) return a function 'f' s.t. f (op x) = x +adjustUnary op + = case op of + WordNotOp -> Just (\y -> complement y) + IntNotOp -> Just (\y -> complement y) + IntNegOp -> Just (\y -> negate y ) + _ -> Nothing + +tx_con_tte :: Platform -> AltCon -> Maybe AltCon +tx_con_tte _ DEFAULT = Just DEFAULT +tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt) +tx_con_tte platform (DataAlt dc) -- See Note [caseRules for tagToEnum] + = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc + +tx_con_dtt :: TyCon -> AltCon -> Maybe AltCon +tx_con_dtt _ DEFAULT = Just DEFAULT +tx_con_dtt tc (LitAlt (LitNumber LitNumInt i)) + | tag >= 0 + , tag < n_data_cons + = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!) + | otherwise + = Nothing + where + tag = fromInteger i :: ConTagZ + n_data_cons = tyConFamilySize tc + data_cons = tyConDataCons tc + +tx_con_dtt _ alt = pprPanic "caseRules/dataToTag: bad alt" (ppr alt) + + +{- Note [caseRules for tagToEnum] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to transform + case tagToEnum# x of + False -> e1 + True -> e2 +into + case x of + 0# -> e1 + 1# -> e2 + +See #8317. This rule eliminates a lot of boilerplate. For + if (x>y) then e2 else e1 +we generate + case tagToEnum# (x ># y) of + False -> e1 + True -> e2 +and it is nice to then get rid of the tagToEnum#. + +Beware (#14768): avoid the temptation to map constructor 0 to +DEFAULT, in the hope of getting this + case (x ># y) of + DEFAULT -> e1 + 1# -> e2 +That fails utterly in the case of + data Colour = Red | Green | Blue + case tagToEnum x of + DEFAULT -> e1 + Red -> e2 + +We don't want to get this! + case x of + DEFAULT -> e1 + DEFAULT -> e2 + +Instead, when possible, we turn one branch into DEFAULT in +GHC.Core.Opt.Simplify.Utils.mkCase2; see Note [Literal cases] +in that module. + +Note [caseRules for dataToTag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [DataToTag overview] in GHC.Tc.Instance.Class. + +We want to transform + case dataToTagSmall# x of + DEFAULT -> e1 + 1# -> e2 +into + case x of + DEFAULT -> e1 + (:) _ _ -> e2 + +(Note the need for some wildcard binders in the 'cons' case.) + +This transformation often enables further optimisation via +case-flattening and case-of-known-constructor and can be very +important for code using derived Eq instances. + +We can apply this transformation only when we can easily get the +constructors from the type at which dataToTagSmall# is used. And we +cannot apply this transformation at "type data"-related types without +breaking invariant I1 from Note [Type data declarations] in +GHC.Rename.Module. That leaves exactly the types satisfying condition +DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class. + +All of the above applies identically for `dataToTagLarge#`. And +thanks to wrinkle DTW5, there is no need to worry about large-tag +arguments for `dataToTagSmall#`; those cause undefined behavior anyway. + + +Note [Unreachable caseRules alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Take care if we see something like + case dataToTag x of + DEFAULT -> e1 + -1# -> e2 + 100 -> e3 +because there isn't a data constructor with tag -1 or 100. In this case the +out-of-range alternative is dead code -- we know the range of tags for x. + +Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating +an alternative that is unreachable. + +You may wonder how this can happen: check out #15436. +-} diff --git a/GHC/Core/Opt/ConstantFold.hs-boot b/GHC/Core/Opt/ConstantFold.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/ConstantFold.hs-boot @@ -0,0 +1,8 @@ +module GHC.Core.Opt.ConstantFold where + +import GHC.Prelude +import GHC.Core +import GHC.Builtin.PrimOps +import GHC.Types.Name + +primOpRules :: Name -> PrimOp -> Maybe CoreRule diff --git a/GHC/Core/Opt/CprAnal.hs b/GHC/Core/Opt/CprAnal.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/CprAnal.hs @@ -0,0 +1,1315 @@ +{-# LANGUAGE MultiWayIf #-} + +-- | Constructed Product Result analysis. Identifies functions that surely +-- return heap-allocated records on every code path, so that we can eliminate +-- said heap allocation by performing a worker/wrapper split. +-- +-- See https://www.microsoft.com/en-us/research/publication/constructed-product-result-analysis-haskell/. +-- CPR analysis should happen after strictness analysis. +-- See Note [Phase ordering]. +module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where + +import GHC.Prelude + +import GHC.Driver.Flags ( DumpFlag (..) ) + +import GHC.Builtin.Names ( runRWKey ) + +import GHC.Types.Var.Env +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Unique.MemoFun + +import GHC.Core +import GHC.Core.FamInstEnv +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Utils +import GHC.Core.Coercion +import GHC.Core.Reduction +import GHC.Core.Seq +import GHC.Core.TyCon +import GHC.Core.Opt.WorkWrap.Utils + +import GHC.Data.Graph.UnVar -- for UnVarSet + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Logger ( Logger, putDumpFileMaybe, DumpFormat (..) ) + +import Data.List ( mapAccumL ) + +{- Note [Constructed Product Result] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The goal of Constructed Product Result analysis is to identify functions that +surely return heap-allocated records on every code path, so that we can +eliminate said heap allocation by performing a worker/wrapper split +(via 'GHC.Core.Opt.WorkWrap.Utils.mkWWcpr_entry'). + +`swap` below is such a function: +``` + swap (a, b) = (b, a) +``` +A `case` on an application of `swap`, like +`case swap (10, 42) of (a, b) -> a + b` could cancel away +(by case-of-known-constructor) if we \"inlined\" `swap` and simplified. We then +say that `swap` has the CPR property. + +We can't inline recursive functions, but similar reasoning applies there: +``` + f x n = case n of + 0 -> (x, 0) + _ -> f (x+1) (n-1) +``` +Inductively, `case f 1 2 of (a, b) -> a + b` could cancel away the constructed +product with the case. So `f`, too, has the CPR property. But we can't really +"inline" `f`, because it's recursive. Also, non-recursive functions like `swap` +might be too big to inline (or even marked NOINLINE). We still want to exploit +the CPR property, and that is exactly what the worker/wrapper transformation +can do for us: +``` + $wf x n = case n of + 0 -> case (x, 0) of -> (a, b) -> (# a, b #) + _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #) + f x n = case $wf x n of (# a, b #) -> (a, b) +``` +where $wf readily simplifies (by case-of-known-constructor and inlining `f`) to: +``` + $wf x n = case n of + 0 -> (# x, 0 #) + _ -> $wf (x+1) (n-1) +``` +Now, a call site like `case f 1 2 of (a, b) -> a + b` can inline `f` and +eliminate the heap-allocated pair constructor. + +Note [Nested CPR] +~~~~~~~~~~~~~~~~~ +We can apply Note [Constructed Product Result] deeper than just the top-level +result constructor of a function, e.g., +``` + g x + | even x = (x+1,x+2) :: (Int, Int) + | odd x = (x+2,x+3) +``` +Not only does `g` return a constructed pair, the pair components /also/ have the +CPR property. We can split `g` for its /nested/ CPR property, as follows: +``` + $wg (x :: Int#) + | .. x .. = (# x +# 1#, x +# 2# #) :: (# Int#, Int# #) + | .. x .. = (# x +# 2#, x +# 3# #) + g (I# x) = case $wf x of (# y, z #) -> (I# y, I# z) +``` +Note however that in the following we will only unbox the second component, +even if `foo` has the CPR property: +``` + h x + | even x = (foo x, x+2) :: (Int, Int) + | odd x = (x+2, x+3) + -- where `foo` has the CPR property +``` +Why can't we also unbox `foo x`? Because in order to do so, we have to evaluate +it and that might diverge, so we cannot give `h` the nested CPR property in the +first component of the result. + +The Right Thing is to do a termination analysis, to see if we can guarantee that +`foo` terminates quickly, in which case we can speculatively evaluate `foo x` and +hence give `h` a nested CPR property. That is done in !1866. But for now we +have an incredibly simple termination analysis; an expression terminates fast +iff it is in HNF: see `exprTerminates`. We call `exprTerminates` in +`cprTransformDataConWork`, which is the main function figuring out whether it's +OK to propagate nested CPR info (in `extract_nested_cpr`). + +In addition to `exprTerminates`, `extract_nested_cpr` also looks at the +`StrictnessMark` of the corresponding constructor field. Example: +``` + data T a = MkT !a + h2 x + | even x = MkT (foo x) :: T Int + | odd x = MkT (x+2) + -- where `foo` has the CPR property +``` +Regardless of whether or not `foo` terminates, we may unbox the strict field, +because it has to be evaluated (the Core for `MkT (foo x)` will look more like +`case foo x of y { __DEFAULT -> MkT y }`). + +Surprisingly, there are local binders with a strict demand that *do not* +terminate quickly in a sense that is useful to us! The following function +demonstrates that: +``` + j x = (let t = x+1 in t+t, 42) +``` +Here, `t` is used strictly, *but only within its scope in the first pair +component*. `t` satisfies Note [CPR for binders that will be unboxed], so it has +the CPR property, nevertheless we may not unbox `j` deeply lest evaluation of +`x` diverges. The termination analysis must say "Might diverge" for `t` and we +won't unbox the first pair component. +There are a couple of tests in T18174 that show case Nested CPR. Some of them +only work with the termination analysis from !1866. + +Giving the (Nested) CPR property to deep data structures can lead to loss of +sharing; see Note [CPR for data structures can destroy sharing]. + +Note [Phase ordering] +~~~~~~~~~~~~~~~~~~~~~ +We need to perform strictness analysis before CPR analysis, because that might +unbox some arguments, in turn leading to more constructed products. +Ideally, we would want the following pipeline: + +1. Strictness +2. worker/wrapper (for strictness) +3. CPR +4. worker/wrapper (for CPR) + +Currently, we omit 2. and anticipate the results of worker/wrapper. +See Note [CPR for binders that will be unboxed]. +An additional w/w pass would simplify things, but probably add slight overhead. +So currently we have + +1. Strictness +2. CPR +3. worker/wrapper (for strictness and CPR) +-} + +-- +-- * Analysing programs +-- + +cprAnalProgram :: Logger -> FamInstEnvs -> CoreProgram -> IO CoreProgram +cprAnalProgram logger fam_envs binds = do + let env = emptyAnalEnv fam_envs + let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds + putDumpFileMaybe logger Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ + dumpIdInfoOfProgram False (ppr . cprSigInfo) binds_plus_cpr + -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal + seqBinds binds_plus_cpr `seq` return binds_plus_cpr + +-- Analyse a (group of) top-level binding(s) +cprAnalTopBind :: AnalEnv + -> CoreBind + -> (AnalEnv, CoreBind) +cprAnalTopBind env (NonRec id rhs) + = (env', NonRec id' rhs') + where + (id', rhs', env') = cprAnalBind env id rhs + +cprAnalTopBind env (Rec pairs) + = (env', Rec pairs') + where + (env', pairs') = cprFix env pairs + +-- +-- * Analysing expressions +-- + +-- | The abstract semantic function ⟦_⟧ : Expr -> Env -> A from +-- "Constructed Product Result Analysis for Haskell" +cprAnal, cprAnal' + :: AnalEnv + -> CoreExpr -- ^ expression to be denoted by a 'CprType' + -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType' + +cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $ + cprAnal' env e + +cprAnal' _ (Lit lit) = (topCprType, Lit lit) +cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact +cprAnal' _ (Coercion co) = (topCprType, Coercion co) + +cprAnal' env (Cast e co) + = (cpr_ty', Cast e' co) + where + (cpr_ty, e') = cprAnal env e + cpr_ty' + | cpr_ty == topCprType = topCprType -- cheap case first + | isRecNewTyConApp env (coercionRKind co) = topCprType -- See Note [CPR for recursive data constructors] + | otherwise = cpr_ty + +cprAnal' env (Tick t e) + = (cpr_ty, Tick t e') + where + (cpr_ty, e') = cprAnal env e + +cprAnal' env e@(Var{}) + = cprAnalApp env e [] +cprAnal' env e@(App{}) + = cprAnalApp env e [] + +cprAnal' env (Lam var body) + | isTyVar var + , (body_ty, body') <- cprAnal env body + = (body_ty, Lam var body') + | otherwise + = (lam_ty, Lam var body') + where + -- See Note [CPR for binders that will be unboxed] + env' = extendSigEnvForArg env var + (body_ty, body') = cprAnal env' body + lam_ty = abstractCprTy body_ty + +cprAnal' env (Case scrut case_bndr ty alts) + = (res_ty, Case scrut' case_bndr ty alts') + where + (scrut_ty, scrut') = cprAnal env scrut + env' = extendSigEnv env case_bndr (CprSig scrut_ty) + (alt_tys, alts') = mapAndUnzip (cprAnalAlt env' scrut_ty) alts + res_ty = foldl' lubCprType botCprType alt_tys + +cprAnal' env (Let (NonRec id rhs) body) + = (body_ty, Let (NonRec id' rhs') body') + where + (id', rhs', env') = cprAnalBind env id rhs + (body_ty, body') = cprAnal env' body + +cprAnal' env (Let (Rec pairs) body) + = body_ty `seq` (body_ty, Let (Rec pairs') body') + where + (env', pairs') = cprFix env pairs + (body_ty, body') = cprAnal env' body + +cprAnalAlt + :: AnalEnv + -> CprType -- ^ CPR type of the scrutinee + -> Alt Var -- ^ current alternative + -> (CprType, Alt Var) +cprAnalAlt env scrut_ty (Alt con bndrs rhs) + = (rhs_ty, Alt con bndrs rhs') + where + ids = filter isId bndrs + env_alt + | DataAlt dc <- con + , CprType arity cpr <- scrut_ty + , arity == 0 -- See Note [Dead code may contain type confusions] + = case unpackConFieldsCpr dc cpr of + AllFieldsSame field_cpr + | let sig = mkCprSig 0 field_cpr + -> extendSigEnvAllSame env ids sig + ForeachField field_cprs + | let sigs = zipWith (mkCprSig . idArity) ids field_cprs + -> extendSigEnvList env (zipEqual ids sigs) + | otherwise + = extendSigEnvAllSame env ids topCprSig + (rhs_ty, rhs') = cprAnal env_alt rhs + +-- +-- * CPR transformer +-- + +data TermFlag -- Better than using a Bool + = Terminates + | MightDiverge + +-- See Note [Nested CPR] +exprTerminates :: CoreExpr -> TermFlag +-- ^ A /very/ simple termination analysis. +exprTerminates e + | exprIsHNF e = Terminates + | exprOkForSpeculation e = Terminates + | otherwise = MightDiverge + -- Annoyingly, we have to check both for HNF and ok-for-spec. + -- * `I# (x# *# 2#)` is ok-for-spec, but not in HNF. Still worth CPR'ing! + -- * `lvl` is an HNF if its unfolding is evaluated + -- (perhaps `lvl = I# 0#` at top-level). But, tiresomely, it is never + -- ok-for-spec due to Note [exprOkForSpeculation and evaluated variables]. + +cprAnalApp :: AnalEnv -> CoreExpr -> [(CprType, CoreArg)] -> (CprType, CoreExpr) +-- Main function that takes care of /nested/ CPR. See Note [Nested CPR] +cprAnalApp env e arg_infos = go e arg_infos [] + where + go e arg_infos args' + -- Collect CprTypes for (value) args (inlined collectArgs): + | App fn arg <- e, isTypeArg arg -- Don't analyse Type args + = go fn arg_infos (arg:args') + | App fn arg <- e + , arg_info@(_arg_ty, arg') <- cprAnal env arg + -- See Note [Nested CPR] on the need for termination analysis + = go fn (arg_info:arg_infos) (arg':args') + + | Var fn <- e + = (cprTransform env fn arg_infos, mkApps e args') + + | (e_ty, e') <- cprAnal env e -- e is not an App and not a Var + = (applyCprTy e_ty (length arg_infos), mkApps e' args') + +cprTransform :: AnalEnv -- ^ The analysis environment + -> Id -- ^ The function + -> [(CprType, CoreArg)] -- ^ info about incoming /value/ arguments + -> CprType -- ^ The demand type of the application +cprTransform env id args + -- Any local binding, except for data structure bindings + -- See Note [Efficient Top sigs in SigEnv] + | Just sig <- lookupSigEnv env id + = applyCprTy (getCprSig sig) (length args) + -- See Note [CPR for data structures] + | Just rhs <- cprDataStructureUnfolding_maybe id + = fst $ cprAnal env rhs + -- Some (mostly global, known-key) Ids have bespoke CPR transformers + | Just cpr_ty <- cprTransformBespoke id args + = cpr_ty + -- Other local Ids that respond True to 'isDataStructure' but don't have an + -- expandable unfolding, such as NOINLINE bindings. They all get a top sig + | isLocalId id + = assertPpr (isDataStructure id) (ppr id) topCprType + -- See Note [CPR for DataCon wrappers] + | Just rhs <- dataConWrapUnfolding_maybe id + = fst $ cprAnalApp env rhs args + -- DataCon worker + | Just con <- isDataConWorkId_maybe id + = cprTransformDataConWork env con args + -- Imported function + | otherwise + = applyCprTy (getCprSig (idCprSig id)) (length args) + +-- | Precise, hand-written CPR transformers for select Ids +cprTransformBespoke :: Id -> [(CprType, CoreArg)] -> Maybe CprType +cprTransformBespoke id args + -- See Note [Simplification of runRW#] in GHC.CoreToStg.Prep + | idUnique id == runRWKey -- `runRW (\s -> e)` + , [(arg_ty, _arg)] <- args -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`) + = Just $ applyCprTy arg_ty 1 -- `e` has CPR type `2` + | otherwise + = Nothing + +-- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker, +-- given a saturated number of 'CprType's for its field expressions. +-- Implements the Nested part of Note [Nested CPR]. +cprTransformDataConWork :: AnalEnv -> DataCon + -> [(CprType, CoreArg)] -- Info about /value/ arguments + -> CprType +cprTransformDataConWork env con args + | null (dataConExTyCoVars con) -- No existentials + , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE] + , args `lengthIs` wkr_arity + , ae_rec_dc env con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors] + = -- pprTraceWith "cprTransformDataConWork" (\r -> ppr con <+> ppr wkr_arity <+> ppr args <+> ppr r) $ + CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks)) + | otherwise + = topCprType + where + wkr_arity = dataConRepArity con + wkr_str_marks = dataConRepStrictness con + -- See Note [Nested CPR] + extract_nested_cpr (CprType 0 cpr, arg) str + | MarkedStrict <- str = cpr + | Terminates <- exprTerminates arg = cpr + extract_nested_cpr _ _ = topCpr -- intervening lambda or doesn't terminate + +-- | See Note [Trimming to mAX_CPR_SIZE]. +mAX_CPR_SIZE :: Arity +mAX_CPR_SIZE = 10 + +isRecNewTyConApp :: AnalEnv -> Type -> Bool +-- See Note [CPR for recursive newtype constructors] +isRecNewTyConApp env ty + --- | pprTrace "isRecNewTyConApp" (ppr ty) False = undefined + | Just (tc, tc_args) <- splitTyConApp_maybe ty = + if | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe (ae_fam_envs env) tc tc_args + -> isRecNewTyConApp env rhs + | Just dc <- newTyConDataCon_maybe tc + -> ae_rec_dc env dc == DefinitelyRecursive + | otherwise + -> False + | otherwise = False + +-- +-- * Bindings +-- + +-- Recursive bindings +cprFix :: AnalEnv -- Does not include bindings for this binding + -> [(Id,CoreExpr)] + -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info +cprFix orig_env orig_pairs + = loop 1 init_env init_pairs + where + init_sig id + -- See Note [CPR for data structures] + -- Don't set the sig to bottom in this case, because cprAnalBind won't + -- update it to something reasonable. Result: Assertion error in WW + | isDataStructure id || isDFunId id = topCprSig + | otherwise = mkCprSig 0 botCpr + -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal + orig_virgin = ae_virgin orig_env + init_pairs | orig_virgin = [(setIdCprSig id (init_sig id), rhs) | (id, rhs) <- orig_pairs ] + | otherwise = orig_pairs + init_env = extendSigEnvFromIds orig_env (map fst init_pairs) + + -- If fixed-point iteration does not yield a result we use this instead + -- See Note [Safe abortion in the fixed-point iteration] + abort :: (AnalEnv, [(Id,CoreExpr)]) + abort = step (nonVirgin orig_env) [(setIdCprSig id topCprSig, rhs) | (id, rhs) <- orig_pairs ] + + -- The fixed-point varies the idCprSig field of the binders and and their + -- entries in the AnalEnv, and terminates if that annotation does not change + -- any more. + loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) + loop n env pairs + | found_fixpoint = (reset_env', pairs') + | n == 10 = pprTraceUserWarning (text "cprFix aborts. This is not terrible, but worth reporting a GHC issue." <+> ppr (map fst pairs)) $ abort + | otherwise = loop (n+1) env' pairs' + where + -- In all but the first iteration, delete the virgin flag + -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal + (env', pairs') = step (applyWhen (n/=1) nonVirgin env) pairs + -- Make sure we reset the virgin flag to what it was when we are stable + reset_env' = env'{ ae_virgin = orig_virgin } + found_fixpoint = map (idCprSig . fst) pairs' == map (idCprSig . fst) pairs + + step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)]) + step env pairs = mapAccumL go env pairs + where + go env (id, rhs) = (env', (id', rhs')) + where + (id', rhs', env') = cprAnalBind env id rhs + +{- +Note [Dead code may contain type confusions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In T23862, we have a nested case match that looks like this + + data CheckSingleton (check :: Bool) where + Checked :: CheckSingleton True + Unchecked :: CheckSingleton False + data family Result (check :: Bool) a + data instance Result True a = CheckedResult a + newtype instance Result True a = UncheckedResult a + + case m () of Checked co1 -> + case m () of Unchecked co2 -> + case ((\_ -> True) + |> .. UncheckedResult .. + |> sym co2 + |> co1) :: Result True (Bool -> Bool) of + CheckedResult f -> CheckedResult (f True) + +Clearly, the innermost case is dead code, because the `Checked` and `Unchecked` +cases are apart. +However, both constructors introduce mutually contradictory coercions `co1` and +`co2` along which GHC generates a type confusion: + + 1. (\_ -> True) :: Bool -> Bool + 2. newtype coercion UncheckedResult (\_ -> True) :: Result False (Bool -> Bool) + 3. |> ... sym co1 ... :: Result check (Bool -> Bool) + 4. |> ... co2 ... :: Result True (Bool -> Bool) + +Note that we started with a function, injected into `Result` via a newtype +instance and then match on it with a datatype instance. + +We have to handle this case gracefully in `cprAnalAlt`, where for the innermost +case we see a `DataAlt` for `CheckedResult`, yet have a scrutinee type that +abstracts the function `(\_ -> True)` with arity 1. +In this case, don't pretend we know anything about the fields of `CheckedResult`! + +Note [The OPAQUE pragma and avoiding the reboxing of results] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + + {-# OPAQUE f #-} + f x = (x,y) + + g True = f 2 x + g False = (0,0) + +Where if we didn't strip the CPR info from 'f' we would end up with the +following W/W pair for 'g': + + $wg True = case f 2 of (x, y) -> (# x, y #) + $wg False = (# 0, 0 #) + + g b = case wg$ b of (# x, y #) -> (x, y) + +Where the worker unboxes the result of 'f', only for wrapper to box it again. +That's because the non-stripped CPR signature of 'f' is saying to W/W-transform +'f'. However, OPAQUE-annotated binders aren't W/W transformed (see +Note [OPAQUE pragma]), so we should strip 'f's CPR signature. +-} + +-- | Process the RHS of the binding for a sensible arity, add the CPR signature +-- to the Id, and augment the environment with the signature as well. +cprAnalBind + :: AnalEnv + -> Id + -> CoreExpr + -> (Id, CoreExpr, AnalEnv) +cprAnalBind env id rhs + | isDFunId id -- Never give DFuns the CPR property; we'll never save allocs. + = (id, rhs, extendSigEnv env id topCprSig) + -- See Note [CPR for data structures] + | isDataStructure id -- Data structure => no code => no need to analyse rhs + = (id, rhs, env) + | otherwise + = -- pprTrace "cprAnalBind" (ppr id <+> ppr sig <+> ppr sig') + (id `setIdCprSig` sig', rhs', env') + where + (rhs_ty, rhs') = cprAnal env rhs + -- possibly trim thunk CPR info + rhs_ty' + -- See Note [CPR for thunks] + | rhs_ty == topCprType = topCprType -- cheap case first + | stays_thunk = trimCprTy rhs_ty + | otherwise = rhs_ty + -- See Note [Arity trimming for CPR signatures] + sig = mkCprSigForArity (idArity id) rhs_ty' + -- See Note [OPAQUE pragma] + -- See Note [The OPAQUE pragma and avoiding the reboxing of results] + sig' | isOpaquePragma (idInlinePragma id) = topCprSig + | otherwise = sig + env' = extendSigEnv env id sig' + + -- See Note [CPR for thunks] + stays_thunk = is_thunk && not_strict + is_thunk = not (exprIsHNF rhs) && not (isJoinId id) + not_strict = not (isStrUsedDmd (idDemandInfo id)) + +isDataStructure :: Id -> Bool +-- See Note [CPR for data structures] +isDataStructure id = + not (isJoinId id) && idArity id == 0 && isEvaldUnfolding (idUnfolding id) + +-- | Returns an expandable unfolding +-- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has +-- So effectively is a constructor application. +cprDataStructureUnfolding_maybe :: Id -> Maybe CoreExpr +cprDataStructureUnfolding_maybe id + -- There are only FinalPhase Simplifier runs after CPR analysis + | activeInFinalPhase (idInlineActivation id) + , isDataStructure id + = expandUnfolding_maybe (idUnfolding id) + | otherwise + = Nothing + +{- Note [Arity trimming for CPR signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Although it doesn't affect correctness of the analysis per se, we have to trim +CPR signatures to idArity. Here's what might happen if we don't: + + f x = if expensive + then \y. Box y + else \z. Box z + g a b = f a b + +The two lambdas will have a CPR type of @1m@ (so construct a product after +applied to one argument). Thus, @f@ will have a CPR signature of @2m@ +(constructs a product after applied to two arguments). +But WW will never eta-expand @f@! In this case that would amount to possibly +duplicating @expensive@ work. + +(Side note: Even if @f@'s 'idArity' happened to be 2, it would not do so, see +Note [Don't eta expand in w/w].) + +So @f@ will not be worker/wrappered. But @g@ also inherited its CPR signature +from @f@'s, so it *will* be WW'd: + + f x = if expensive + then \y. Box y + else \z. Box z + $wg a b = case f a b of Box x -> x + g a b = Box ($wg a b) + +And the case in @g@ can never cancel away, thus we introduced extra reboxing. +Hence we always trim the CPR signature of a binding to idArity. + +Note [CPR for DataCon wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to give DataCon wrappers a (necessarily flat) CPR signature in +'GHC.Types.Id.Make.mkDataConRep'. Now we transform DataCon wrappers simply by +analysing their unfolding. A few reasons for the change: + + 1. DataCon wrappers are generally inlined in the Final phase (so before CPR), + all leftover occurrences are in a boring context like `f x y = $WMkT y x`. + It's simpler to analyse the unfolding anew at every such call site, and the + unfolding will be pretty cheap to analyse. Also they occur seldom enough + that performance-wise it doesn't matter. + 2. 'GHC.Types.Id.Make' no longer precomputes CPR signatures for DataCon + *workers*, because their transformers need to adapt to CPR for their + arguments in 'cprTransformDataConWork' to enable Note [Nested CPR]. + Better keep it all in this module! The alternative would be that + 'GHC.Types.Id.Make' depends on CprAnal. + 3. In the future, Nested CPR could take a better account of incoming args + in cprAnalApp and do some beta-reduction on the fly, like !1866 did. If + any of those args had the CPR property, then we'd even get Nested CPR for + DataCon wrapper calls, for free. Not so if we simply give the wrapper a + single CPR sig in 'GHC.Types.Id.Make.mkDataConRep'! + +DmdAnal also looks through the wrapper's unfolding: +See Note [DmdAnal for DataCon wrappers]. + +Note [Trimming to mAX_CPR_SIZE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not treat very big tuples as CPR-ish: + + a) For a start, we get into trouble because there aren't + "enough" unboxed tuple types (a tiresome restriction, + but hard to fix), + b) More importantly, big unboxed tuples get returned mainly + on the stack, and are often then allocated in the heap + by the caller. So doing CPR for them may in fact make + things worse, especially if the wrapper doesn't cancel away + and we move to the stack in the worker and then to the heap + in the wrapper. + +So we (nested) CPR for functions that would otherwise pass more than than +'mAX_CPR_SIZE' fields. +That effect is exacerbated for the unregisterised backend, where we +don't have any hardware registers to return the fields in. Returning +everything on the stack results in much churn and increases compiler +allocation by 15% for T15164 in a validate build. +-} + +data AnalEnv + = AE + { ae_sigs :: SigEnv + -- ^ Current approximation of signatures for local ids + , ae_virgin :: Bool + -- ^ True only on every first iteration in a fixed-point + -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal" + , ae_fam_envs :: FamInstEnvs + -- ^ Needed when expanding type families and synonyms of product types. + , ae_rec_dc :: DataCon -> IsRecDataConResult + -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataType + } + +instance Outputable AnalEnv where + ppr (AE { ae_sigs = env, ae_virgin = virgin }) + = text "AE" <+> braces (vcat + [ text "ae_virgin =" <+> ppr virgin + , text "ae_sigs =" <+> ppr env ]) + +-- | An environment storing 'CprSig's for local Ids. +-- Puts binders with 'topCprSig' in a space-saving 'IntSet'. +-- See Note [Efficient Top sigs in SigEnv]. +data SigEnv + = SE + { se_tops :: !UnVarSet + -- ^ All these Ids have 'topCprSig'. Like a 'VarSet', but more efficient. + , se_sigs :: !(VarEnv CprSig) + -- ^ Ids that have something other than 'topCprSig'. + } + +instance Outputable SigEnv where + ppr (SE { se_tops = tops, se_sigs = sigs }) + = text "SE" <+> braces (vcat + [ text "se_tops =" <+> ppr tops + , text "se_sigs =" <+> ppr sigs ]) + +emptyAnalEnv :: FamInstEnvs -> AnalEnv +emptyAnalEnv fam_envs + = AE + { ae_sigs = SE emptyUnVarSet emptyVarEnv + , ae_virgin = True + , ae_fam_envs = fam_envs + , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs fuel) + } where + fuel = 3 -- If we can unbox more than 3 constructors to find a + -- recursive occurrence, then we can just as well unbox it + -- See Note [CPR for recursive data constructors], point (4) + +modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv +modifySigEnv f env = env { ae_sigs = f (ae_sigs env) } + +lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig +-- See Note [Efficient Top sigs in SigEnv] +lookupSigEnv AE{ae_sigs = SE tops sigs} id + | id `elemUnVarSet` tops = Just topCprSig + | otherwise = lookupVarEnv sigs id + +extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv +-- See Note [Efficient Top sigs in SigEnv] +extendSigEnv env id sig + | isTopCprSig sig + = modifySigEnv (\se -> se{se_tops = extendUnVarSet id (se_tops se)}) env + | otherwise + = modifySigEnv (\se -> se{se_sigs = extendVarEnv (se_sigs se) id sig}) env + +-- | Extend an environment with the (Id, CPR sig) pairs +extendSigEnvList :: AnalEnv -> [(Id, CprSig)] -> AnalEnv +extendSigEnvList env ids_cprs + = foldl' (\env (id, sig) -> extendSigEnv env id sig) env ids_cprs + +-- | Extend an environment with the CPR sigs attached to the ids +extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv +extendSigEnvFromIds env ids + = foldl' (\env id -> extendSigEnv env id (idCprSig id)) env ids + +-- | Extend an environment with the same CPR sig for all ids +extendSigEnvAllSame :: AnalEnv -> [Id] -> CprSig -> AnalEnv +extendSigEnvAllSame env ids sig + = foldl' (\env id -> extendSigEnv env id sig) env ids + +nonVirgin :: AnalEnv -> AnalEnv +nonVirgin env = env { ae_virgin = False } + +-- | A version of 'extendSigEnv' for a binder of which we don't see the RHS +-- needed to compute a 'CprSig' (e.g. lambdas and DataAlt field binders). +-- In this case, we can still look at their demand to attach CPR signatures +-- anticipating the unboxing done by worker/wrapper. +-- See Note [CPR for binders that will be unboxed]. +extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv +extendSigEnvForArg env id + = extendSigEnv env id (CprSig (argCprType (idDemandInfo id))) + +-- | Produces a 'CprType' according to how a strict argument will be unboxed. +-- Examples: +-- +-- * A head-strict demand @1!L@ would translate to @1@ +-- * A product demand @1!P(1!L,L)@ would translate to @1(1,)@ +-- * A product demand @1!P(1L,L)@ would translate to @1(,)@, +-- because the first field will not be unboxed. +argCprType :: Demand -> CprType +argCprType dmd = CprType 0 (go dmd) + where + go (n :* sd) + | isAbs n = topCpr + | Prod Unboxed ds <- sd = ConCpr fIRST_TAG (strictMap go ds) + | Poly Unboxed _ <- sd = ConCpr fIRST_TAG [] + | otherwise = topCpr + +{- Note [Safe abortion in the fixed-point iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Fixed-point iteration may fail to terminate. But we cannot simply give up and +return the environment and code unchanged! We still need to do one additional +round, to ensure that all expressions have been traversed at least once, and any +unsound CPR annotations have been updated. + +Note [Efficient Top sigs in SigEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's pretty common for binders in the SigEnv to have a 'topCprSig'. +Wide records with 100 fields like in T9675 even will generate code where the +majority of binders has Top signature. To save some allocations, we store +those binders with a Top signature in a separate UnVarSet (which is an IntSet +with a convenient Var-tailored API). + +Why store top signatures at all in the SigEnv? After all, when 'cprTransform' +encounters a locally-bound Id without an entry in the SigEnv, it should behave +as if that binder has a Top signature! +Well, the problem is when case binders should have a Top signatures. They always +have an unfolding and thus look to 'cprTransform' as if they bind a data +structure, Note [CPR for data structures], and thus would always have the CPR +property. So we need some mechanism to separate data structures from case +binders with a Top signature, and the UnVarSet provides that in the least +convoluted way I can think of. + +Note [CPR for binders that will be unboxed] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a lambda-bound variable will be unboxed by worker/wrapper (so it must be +demanded strictly), then give it a CPR signature. Here's a concrete example +('f1' in test T10482a), assuming h is strict: + + f1 :: Int -> Int + f1 x = case h x of + A -> x + B -> f1 (x-1) + C -> x+1 + +If we notice that 'x' is used strictly, we can give it the CPR +property; and hence f1 gets the CPR property too. It's sound (doesn't +change strictness) to give it the CPR property because by the time 'x' +is returned (case A above), it'll have been evaluated (by the wrapper +of 'h' in the example). + +Moreover, if f itself is strict in x, then we'll pass x unboxed to +f1, and so the boxed version *won't* be available; in that case it's +very helpful to give 'x' the CPR property. + +This is all done in 'extendSigEnvForArg'. + +Note that + + * Whether or not something unboxes is decided by 'canUnboxArg', else we may + get over-optimistic CPR results (e.g., from \(x :: a) -> x!). + + * If the demand unboxes deeply, we can give the binder a /nested/ CPR + property, e.g. + + g :: (Int, Int) -> Int + g p = case p of + (x, y) | x < 0 -> 0 + | otherwise -> x + + `x` should have the CPR property because it will be unboxed. We do so + by giving `p` the Nested CPR property `1(1,)`, indicating that we not only + have `p` available unboxed, but also its field `x`. Analysis of the Case + will then transfer the CPR property to `x`. + + Before we were able to express Nested CPR, we used to guess which field + binders should get the CPR property. + See Historic Note [Optimistic field binder CPR]. + + * See Note [CPR examples] + +Note [CPR for thunks] +~~~~~~~~~~~~~~~~~~~~~ +If the rhs is a thunk, we usually forget the CPR info, because +it is presumably shared (else it would have been inlined, and +so we'd lose sharing if w/w'd it into a function). E.g. + + let r = case expensive of + (a,b) -> (b,a) + in ... + +If we marked r as having the CPR property, then we'd w/w into + + let $wr = \() -> case expensive of + (a,b) -> (# b, a #) + r = case $wr () of + (# b,a #) -> (b,a) + in ... + +But now r is a thunk, which won't be inlined, so we are no further ahead. +But consider + + f x = let r = case expensive of (a,b) -> (b,a) + in if foo r then r else (x,x) + +Does f have the CPR property? Well, no. + +However, if the strictness analyser has figured out (in a previous +iteration) that it's strict, then we DON'T need to forget the CPR info. +Instead we can retain the CPR info and do the thunk-splitting transform +(see WorkWrap.splitThunk). + +This made a big difference to PrelBase.modInt, which had something like + modInt = \ x -> let r = ... -> I# v in + ...body strict in r... +r's RHS isn't a value yet; but modInt returns r in various branches, so +if r doesn't have the CPR property then neither does modInt +Another case I found in practice (in Complex.magnitude), looks like this: + let k = if ... then I# a else I# b + in ... body strict in k .... +(For this example, it doesn't matter whether k is returned as part of +the overall result; but it does matter that k's RHS has the CPR property.) +Left to itself, the simplifier will make a join point thus: + let $j k = ...body strict in k... + if ... then $j (I# a) else $j (I# b) +With thunk-splitting, we get instead + let $j x = let k = I#x in ...body strict in k... + in if ... then $j a else $j b +This is much better; there's a good chance the I# won't get allocated. + +But what about botCpr? Consider + lvl = error "boom" + fac -1 = lvl + fac 0 = 1 + fac n = n * fac (n-1) +fac won't have the CPR property here when we trim every thunk! But the +assumption is that error cases are rarely entered and we are diverging anyway, +so WW doesn't hurt. + +Should we also trim CPR on DataCon application bindings? +See Note [CPR for data structures]! + +Note [CPR for data structures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Long static data structures (whether top-level or not) like + + xs = x1 : xs1 + xs1 = x2 : xs2 + xs2 = x3 : xs3 + +should not get (nested) CPR signatures (#18154), because they + + * Never get WW'd, so their CPR signature should be irrelevant after analysis + (in fact the signature might even be harmful for that reason) + * Would need to be inlined/expanded to see their constructed product + * BUT MOST IMPORTANTLY, Problem P1: + Recording CPR on them blows up interface file sizes and is redundant with + their unfolding. In case of Nested CPR, this blow-up can be quadratic! + Reason: the CPR info for xs1 contains the CPR info for xs; the CPR info + for xs2 contains that for xs1. And so on. + By contrast, the size of unfoldings and types stays linear. That's why + quadratic blowup is problematic; it makes an asymptotic difference. + +Hence (Solution S1) we don't give data structure bindings a CPR *signature* and +hence don't to analyse them in 'cprAnalBind'. +What do we mean by "data structure binding"? Answer: + + (1) idArity id == 0 (otherwise it's a function) + (2) is eval'd (otherwise it's a thunk, Note [CPR for thunks] applies) + (3) not (isJoinId id) (otherwise it's a function and its more efficient to + analyse it just once rather than at each call site) + +But (S1) leads to a new Problem P2: We can't just stop giving DataCon application +bindings the CPR *property*, for example the factorial function after FloatOut + + lvl = I# 1# + fac 0 = lvl + fac n = n * fac (n-1) + +lvl is a data structure, and hence (see above) will not have a CPR *signature*. +But if lvl doesn't have the CPR *property*, fac won't either and we allocate a +box for the result on every iteration of the loop. + +So (Solution S2) when 'cprAnal' meets a variable lacking a CPR signature to +extrapolate into a CPR transformer, 'cprTransform' tries to get its unfolding +(via 'cprDataStructureUnfolding_maybe'), and analyses that instead. + +The Result R1: Everything behaves as if there was a CPR signature, but without +the blowup in interface files. + +There is one exception to (R1): + + x = (y, z); {-# NOINLINE x #-} + f p = (y, z); {-# NOINLINE f #-} + +While we still give the NOINLINE *function* 'f' the CPR property (and WW +accordingly, see Note [Worker/wrapper for NOINLINE functions]), we won't +give the NOINLINE *data structure* 'x' the CPR property, because it lacks an +unfolding. In particular, KindRep bindings are NOINLINE data structures (see +the noinline wrinkle in Note [Grand plan for Typeable]). We'll behave as if the +bindings had 'topCprSig', and that is fine, as a case on the binding would never +cancel away after WW! + +It's also worth pointing out how ad-hoc (S1) is: If we instead had + + f1 x = x:[] + f2 x = x : f1 x + f3 x = x : f2 x + ... + +we still give every function an ever deepening CPR signature. But it's very +uncommon to find code like this, whereas the long static data structures from +the beginning of this Note are very common because of GHC's strategy of ANF'ing +data structure RHSs. + +Note [CPR for data structures can destroy sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Note [CPR for data structures], we argued that giving data structure bindings +the CPR property is useful to give functions like fac the CPR property: + + lvl = I# 1# + fac 0 = lvl + fac n = n * fac (n-1) + +Worker/wrappering fac for its CPR property means we get a very fast worker +function with type Int# -> Int#, without any heap allocation at all. + +But consider what happens if we call `map fac (replicate n 0)`, where the +wrapper doesn't cancel away: Then we rebox the result of $wfac *on each call*, +n times, instead of reusing the static thunk for 1, e.g. an asymptotic increase +in allocations. If you twist it just right, you can actually write programs that +that take O(n) space if you do CPR and O(1) if you don't: + + fac :: Int -> Int + fac 0 = 1 -- this clause will trigger CPR and destroy sharing for O(n) space + -- fac 0 = lazy 1 -- this clause will prevent CPR and run in O(1) space + fac n = n * fac (n-1) + + const0 :: Int -> Int + const0 n = signum n - 1 -- will return 0 for [1..n] + {-# NOINLINE const0 #-} + + main = print $ foldl' (\acc n -> acc + lazy n) 0 $ map (fac . const0) [1..100000000] + +Generally, this kind of asymptotic increase in allocation can happen whenever we +give a data structure the CPR property that is bound outside of a recursive +function. So far we don't have a convincing remedy; giving fac the CPR property +is just too attractive. #19309 documents a futile idea. #13331 tracks the +general issue of WW destroying sharing and also contains above reproducer. +#19326 is about CPR destroying sharing in particular. + +With Nested CPR, sharing can also be lost within the same "lambda level", for +example: + + f (I# x) = let y = I# (x*#x) in (y, y) + +Nestedly unboxing would destroy the box shared through 'y'. (Perhaps we can call +this "internal sharing", in contrast to "external sharing" beyond lambda or even +loop levels above.) But duplicate occurrences like that are pretty rare and may +never lead to an asymptotic difference in allocations of 'f'. + +Note [CPR for recursive data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [CPR for data structures can destroy sharing] gives good reasons not to +give shared data structure bindings the CPR property. But we shouldn't even +give *functions* that return *recursive* data constructor applications the CPR +property. Here's an example for why: + + c = C# 'a' + replicateC :: Int -> [Int] + replicateC 1 = [c] + replicateC n = c : replicateC (n-1) + +What happens if we give `replicateC` the (nested) CPR property? We get a WW +split for 'replicateC', the wrapper of which is certain to inline, like this: + + replicateC (I# n) = case $wreplicateC n of (# x, xs #) -> C# x : xs + $wreplicateC 1# = (# 'a', [] #) + $wreplicateC n = (# 'a', replicateC (I# (n -# 1#)) #) + +Eliminating the shared 'c' binding in the process. And then + + * We *might* save allocation of the topmost (of most likely several) (:) + constructor if it cancels away at the call site. Similarly for the 'C#' + constructor. + * But we will now re-allocate the C# box on every iteration of the loop, + because we separated the character literal from the C# application. + That means n times as many C# allocations as before. Yikes!! + * We make all other call sites where the wrapper inlines a bit larger, most of + them for no gain. But this shouldn't matter much. + * The inlined wrapper may inhibit eta-expansion in some cases. Here's how: + If the wrapper is inlined in a strict arg position, the Simplifier will + transform as follows + + f (replicateC n) + ==> { inline } + f (case $wreplicateC n of (# x, xs #) -> (C# x, xs)) + ==> { strict arg } + case $wreplicateC n of (# x, xs #) -> f (C# x, xs) + + Now we can't float out the case anymore. In fact, we can't even float out + `$wreplicateC n`, because it returns an unboxed tuple. + This can inhibit eta-expansion if we later find out that `f` has arity > 1 + (such as when we define `foldl` in terms of `foldr`). #19970 shows how + abstaining from worker/wrappering made a difference of -20% in reptile. So + while WW'ing for CPR didn't make the program slower directly, the resulting + program got much harder to optimise because of the returned unboxed tuple + (which can't easily float because unlifted). + +`replicateC` comes up in T5536, which regresses significantly if CPR'd nestedly. + +What can we do about it? + + A. Don't give recursive data constructors or casts representing recursive newtype constructors + the CPR property (the list in this case). This is the solution we adopt. + Rationale: the benefit of CPR on recursive data structures is slight, + because it only affects the outer layer of a potentially massive data + structure. + B. Don't CPR any *recursive function*. That would be quite conservative, as it + would also affect e.g. the factorial function. + C. Flat CPR only for recursive functions. This prevents the asymptotic + worsening part arising through unsharing the C# box, but it's still quite + conservative. + D. No CPR at occurrences of shared data structure in hot paths (e.g. the use of + `c` in the second eqn of `replicateC`). But we'd need to know which paths + were hot. We want such static branch frequency estimates in #20378. + +We adopt solution (A). It is ad-hoc, but appears to work reasonably well. +Specifically: + +* For data constructors, in `cprTransformDataConWork` we check for a recursive + data constructor by calling `ae_rec_dc env`, which is just a memoised version + of `isRecDataCon`. See Note [Detecting recursive data constructors] +* For newtypes, in the `Cast` case of `cprAnal`, we check for a recursive newtype + by calling `isRecNewTyConApp`, which in turn calls `ae_rec_dc env`. + See Note [CPR for recursive newtype constructors] + +Note [Detecting recursive data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What qualifies as a "recursive data constructor" as per +Note [CPR for recursive data constructors]? That is up to +'GHC.Core.Opt.WorkWrapW.Utils.isRecDataCon' to decide. It does a DFS search over +the field types of the DataCon and looks for term-level recursion into the data +constructor's type constructor. Assuming infinite fuel (point (4) below), it +looks inside the following class of types, represented by `ty` (and responds +`NonRecursiveOrUnsure` in all other cases): + + A. If `ty = forall v. ty'`, then look into `ty'` + B. If `ty = Tc tc_args` and `Tc` is an `AlgTyCon`, look into the arg + types of its data constructors and check `tc_args` for recursion. + C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to + `rhs`, look into the `rhs` type. + D. If `ty = f a`, then look into `f` and `a` + E. If `ty = ty' |> co`, then look into `ty'` + +A few perhaps surprising points: + + 1. It deems any function type as non-recursive, because it's unlikely that + a recursion through a function type builds up a recursive data structure. + 2. It doesn't look into kinds, literals or coercion types because we are + ultimately looking for value-level recursion. + Same for promoted data constructors. + 3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not; + we simply look at its definition/DataCons and its field tys and look for + recursive occs in the `tc_args` we are given. This is so that we expand + the `ST` in `StateT Int (ST s) a`. + 4. We don't recurse deeper than 3 (at the moment of this writing) TyCons and + assume the DataCon is non-recursive after that. One reason for this "fuel" + approach is guaranteed constant-time efficiency; the other is that it's + fair to say that a recursion over 3 or more TyCons doesn't really count as + a list-like data structure anymore and a bit of unboxing doesn't hurt much. + 5. It checks AlgTyCon apps like `T tc_args` by eagerly checking the `tc_args` + *before* it looks into the expanded DataCons/NewTyCon, so that it + terminates before doing a deep nest of expansions only to discover that the + first level already contained a recursion. + 6. As a result of keeping the implementation simple, it says "recursive" + for `data T = MkT [T]`, even though we could argue that the inner recursion + (through the `[]` TyCon) by way of which `T` is recursive will already be + "broken" and thus never unboxed. Consequently, it might be OK to CPR a + function returning `T`. Lacking arguments for or against the current simple + behavior, we stick to it. + 7. When the search hits an abstract TyCon (algebraic, but without visible + DataCons, e.g., from an .hs-boot file), it returns 'NonRecursiveOrUnsure', + the same as when we run out of fuel. If there is ever a recursion through + an abstract TyCon, then it's not part of the same function we are looking + at in CPR, so we can treat it as if it wasn't recursive. + We handle stuck type and data families much the same. + +Here are a few examples of data constructors or data types with a single data +con and the answers of our function: + + data T = T (Int, (Bool, Char)) NonRec + (:) Rec + [] NonRec + data U = U [Int] NonRec + data U2 = U2 [U2] Rec (see point (6)) + data T1 = T1 T2; data T2 = T2 T1 Rec + newtype Fix f = Fix (f (Fix f)) Rec + data N = N (Fix (Either Int)) NonRec + data M = M (Fix (Either M)) Rec + data F = F (F -> Int) NonRec (see point (1)) + data G = G (Int -> G) NonRec (see point (1)) + newtype MyM s a = MyM (StateT Int (ST s) a NonRec + type S = (Int, Bool) NonRec + + { type family E a where + E Int = Char + E (a,b) = (E a, E b) + E Char = Blub + data Blah = Blah (E (Int, (Int, Int))) NonRec + data Blub = Blub (E (Char, Int)) Rec + data Blub2 = Blub2 (E (Bool, Int)) } Unsure, because stuck (see point (7)) + + { data T1 = T1 T2; data T2 = T2 T3; + ... data T5 = T5 T1 } Unsure (out of fuel) (see point (4)) + + { module A where -- A.hs-boot + data T + module B where + import {-# SOURCE #-} A + data U = MkU T + f :: T -> U + f t = MkU t Unsure (T is abstract) (see point (7)) + module A where -- A.hs + import B + data T = MkT U } + +These examples are tested by the testcase RecDataConCPR. + +I've played with the idea to make points (1) through (3) of 'isRecDataCon' +configurable like (4) to enable more re-use throughout the compiler, but haven't +found a killer app for that yet, so ultimately didn't do that. + +Note [CPR for recursive newtype constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A newtype constructor is considered recursive iff the data constructor of the +equivalent datatype definition is recursive. +See Note [CPR for recursive data constructors]. +Detection is a bit complicated by the fact that newtype constructor applications +reflect as Casts in Core: + + newtype List a = C (Maybe (a, List a)) + xs = C (Just (0, C Nothing)) + ==> {desugar to Core} + xs = Just (0, Nothing |> sym N:List) |> sym N:List + +So the check for `isRecNewTyConApp` is in the Cast case of `cprAnal` rather than +in `cprTransformDataConWork` as for data constructors. + +Note [CPR examples] +~~~~~~~~~~~~~~~~~~~ +Here are some examples (stranal/should_compile/T10482a) of the +usefulness of Note [Optimistic field binder CPR]. The main +point: all of these functions can have the CPR property. + + ------- f1 ----------- + -- x is used strictly by h, so it'll be available + -- unboxed before it is returned in the True branch + + f1 :: Int -> Int + f1 x = case h x x of + True -> x + False -> f1 (x-1) + + ------- f3 ----------- + -- h is strict in x, so x will be unboxed before it + -- is rerturned in the otherwise case. + + data T3 = MkT3 Int Int + + f1 :: T3 -> Int + f1 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) + | otherwise = x + +Historic Note [Optimistic field binder CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes how we used to guess whether fields have the CPR property +before we were able to express Nested CPR for arguments. + +Consider + + data T a = MkT a + f :: T Int -> Int + f x = ... (case x of + MkT y -> y) ... + +And assume we know from strictness analysis that `f` is strict in `x` and its +field `y` and we unbox both. Then we give `x` the CPR property according +to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y` +likewise will be unboxed and it should also get the CPR property. We'd +need a *nested* CPR property here for `x` to express that and unwrap one level +when we analyse the Case to give the CPR property to `y`. + +Lacking Nested CPR (hence this Note is historic now that we have Nested CPR), we +have to guess a bit, by looking for + + (A) Flat CPR on the scrutinee + (B) A variable scrutinee. Otherwise surely it can't be a parameter. + (C) Strict demand on the field binder `y` (or it binds a strict field) + +While (A) is a necessary condition to give a field the CPR property, there are +ways in which (B) and (C) are too lax, leading to unsound analysis results and +thus reboxing in the wrapper: + + (b) We could scrutinise some other variable than a parameter, like in + + g :: T Int -> Int + g x = let z = foo x in -- assume `z` has CPR property + case z of MkT y -> y + + Lacking Nested CPR and multiple levels of unboxing, only the outer box + of `z` will be available and a case on `y` won't actually cancel away. + But it's simple, and nothing terrible happens if we get it wrong. e.g. + #10694. + + (c) A strictly used field binder doesn't mean the function is strict in it. + + h :: T Int -> Int -> Int + h !x 0 = 0 + h x 0 = case x of MkT y -> y + + Here, `y` is used strictly, but the field of `x` certainly is not and + consequently will not be available unboxed. + Why not look at the demand of `x` instead to determine whether `y` is + unboxed? Because the 'idDemandInfo' on `x` will not have been propagated + to its occurrence in the scrutinee when CprAnal runs directly after + DmdAnal. + +We used to give the case binder the CPR property unconditionally instead of +deriving it from the case scrutinee. +See Historic Note [Optimistic case binder CPR]. + +Historic Note [Optimistic case binder CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to give the case binder the CPR property unconditionally, which is too +optimistic (#19232). Here are the details: + +Inside the alternative, the case binder always has the CPR property, meaning +that a case on it will successfully cancel. +Example: + f True x = case x of y { I# x' -> if x' ==# 3 + then y + else I# 8 } + f False x = I# 3 +By giving 'y' the CPR property, we ensure that 'f' does too, so we get + f b x = case fw b x of { r -> I# r } + fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } + fw False x = 3 +Of course there is the usual risk of re-boxing: we have 'x' available boxed +and unboxed, but we return the unboxed version for the wrapper to box. If the +wrapper doesn't cancel with its caller, we'll end up re-boxing something that +we did have available in boxed form. + +-} diff --git a/GHC/Core/Opt/DmdAnal.hs b/GHC/Core/Opt/DmdAnal.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/DmdAnal.hs @@ -0,0 +1,2751 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + + ----------------- + A demand analysis + ----------------- +-} + + +module GHC.Core.Opt.DmdAnal + ( DmdAnalOpts(..) + , dmdAnalProgram + ) +where + +import GHC.Prelude + +import GHC.Types.Demand -- All of it + +import GHC.Core +import GHC.Core.DataCon +import GHC.Core.Utils +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) +import GHC.Core.Coercion ( Coercion ) +import GHC.Core.TyCo.FVs ( coVarsOfCos ) +import GHC.Core.TyCo.Compare ( eqType ) +import GHC.Core.Multiplicity ( scaledThing ) +import GHC.Core.FamInstEnv +import GHC.Core.Opt.Arity ( typeArity ) +import GHC.Core.Opt.WorkWrap.Utils + +import GHC.Builtin.Names +import GHC.Builtin.PrimOps +import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) + +import GHC.Types.Unique.Set +import GHC.Types.Unique.MemoFun +import GHC.Types.RepType +import GHC.Types.ForeignCall ( isSafeForeignCall ) +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable + +import Data.List ( mapAccumL ) + +{- +************************************************************************ +* * +\subsection{Top level stuff} +* * +************************************************************************ +-} + +-- | Options for the demand analysis +data DmdAnalOpts = DmdAnalOpts + { dmd_strict_dicts :: !Bool + -- ^ Value of `-fdicts-strict` (on by default). + -- When set, all functons are implicitly strict in dictionary args. + , dmd_do_boxity :: !Bool + -- ^ Governs whether the analysis should update boxity signatures. + -- See Note [Don't change boxity without worker/wrapper]. + , dmd_unbox_width :: !Int + -- ^ Value of `-fdmd-unbox-width`. + -- See Note [Unboxed demand on function bodies returning small products] + , dmd_max_worker_args :: !Int + -- ^ Value of `-fmax-worker-args`. + -- Don't unbox anything if we end up with more than this many args. + } + +-- This is a strict alternative to (,) +-- See Note [Space Leaks in Demand Analysis] +data WithDmdType a = WithDmdType !DmdType !a + +getAnnotated :: WithDmdType a -> a +getAnnotated (WithDmdType _ a) = a + +data DmdResult a b = R !a !b + +-- | Outputs a new copy of the Core program in which binders have been annotated +-- with demand and strictness information. +-- +-- Note: use `seqBinds` on the result to avoid leaks due to laziness (cf Note +-- [Stamp out space leaks in demand analysis]) +dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram +dmdAnalProgram opts fam_envs rules binds + = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds + where + -- See Note [Analysing top-level bindings] + -- and Note [Why care for top-level demand annotations?] + go _ [] = WithDmdType nopDmdType [] + go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body + where + anal_body env' + | WithDmdType body_ty bs' <- go env' bs + = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs' + + cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b] + cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') + + keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv + -- See Note [Absence analysis for stable unfoldings and RULES] + -- Here we keep alive "roots", e.g., exported ids and stuff mentioned in + -- orphan RULES + keep_alive_roots env ids = plusDmdEnvs (map (demandRoot env) (filter is_root ids)) + + is_root :: Id -> Bool + is_root id = isExportedId id || elemVarSet id rule_fvs + + rule_fvs :: IdSet + rule_fvs = rulesRhsFreeIds rules + +demandRoot :: AnalEnv -> Id -> DmdEnv +-- See Note [Absence analysis for stable unfoldings and RULES] +demandRoot env id = fst (dmdAnalStar env topDmd (Var id)) + +demandRoots :: AnalEnv -> [Id] -> DmdEnv +-- See Note [Absence analysis for stable unfoldings and RULES] +demandRoots env roots = plusDmdEnvs (map (demandRoot env) roots) + +demandRootSet :: AnalEnv -> IdSet -> DmdEnv +demandRootSet env ids = demandRoots env (nonDetEltsUniqSet ids) + -- It's OK to use nonDetEltsUniqSet here because plusDmdType is commutative + +-- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings +-- that satisfy this function. +-- +-- Basically, we want to know how top-level *functions* are *used* +-- (e.g. called). The information will always be lazy. +-- Any other top-level bindings are boring. +-- +-- See also Note [Why care for top-level demand annotations?]. +isInterestingTopLevelFn :: Id -> Bool +-- SG tried to set this to True and got a +2% ghc/alloc regression in T5642 +-- (which is dominated by the Simplifier) at no gain in analysis precision. +-- If there was a gain, that regression might be acceptable. +-- Plus, we could use LetUp for thunks and share some code with local let +-- bindings. +isInterestingTopLevelFn id = typeArity (idType id) > 0 + +{- Note [Stamp out space leaks in demand analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand analysis pass outputs a new copy of the Core program in +which binders have been annotated with demand and strictness +information. It's tiresome to ensure that this information is fully +evaluated everywhere that we produce it, so we just run a single +seqBinds over the output before returning it, to ensure that there are +no references holding on to the input Core program. + +This makes a ~30% reduction in peak memory usage when compiling +DynFlags (cf #9675 and #13426). + +This is particularly important when we are doing late demand analysis, +since we don't do a seqBinds at any point thereafter. Hence code +generation would hold on to an extra copy of the Core program, via +unforced thunks in demand or strictness information; and it is the +most memory-intensive part of the compilation process, so this added +seqBinds makes a big difference in peak memory usage. + +Note [Don't change boxity without worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (T21754) + f n = n+1 + {-# NOINLINE f #-} +With `-fno-worker-wrapper`, we should not give `f` a boxity signature that says +that it unboxes its argument! Client modules would never be able to cancel away +the box for n. Likewise we shouldn't give `f` the CPR property. + +Similarly, in the last run of DmdAnal before codegen (which does not have a +worker/wrapper phase) we should not change boxity in any way. Remember: an +earlier result of the demand analyser, complete with worker/wrapper, has aleady +given a demand signature (with boxity info) to the function. +(The "last run" is mainly there to attach demanded-once info to let-bindings.) + +In general, we should not run Note [Boxity analysis] unless worker/wrapper +follows to exploit the boxity and make sure that calling modules can observe the +reported boxity. + +Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only +if worker/wrapper follows after DmdAnal. If it is not set, and the signature +is not subject to Note [Boxity for bottoming functions], DmdAnal tries +to transfer over the previous boxity to the new demand signature, in +`setIdDmdAndBoxSig`. + +Why isn't CprAnal configured with a similar flag? Because if we aren't going to +do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline) + +It might be surprising that we only try to preserve *arg* boxity, not boxity on +FVs. But FV demands won't make it into interface files anyway, so it's a waste +of energy. +Besides, W/W zaps the `DmdEnv` portion of a signature, so we don't know the old +boxity to begin with; see Note [Zapping DmdEnv after Demand Analyzer]. + +Note [Analysing top-level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a CoreProgram like + e1 = ... + n1 = ... + e2 = \a b -> ... fst (n1 a b) ... + n2 = \c d -> ... snd (e2 c d) ... + ... +where e* are exported, but n* are not. +Intuitively, we can see that @n1@ is only ever called with two arguments +and in every call site, the first component of the result of the call +is evaluated. Thus, we'd like it to have idDemandInfo @LC(L,C(M,P(1L,A))@. +NB: We may *not* give e2 a similar annotation, because it is exported and +external callers might use it in arbitrary ways, expressed by 'topDmd'. +This can then be exploited by Nested CPR and eta-expansion, +see Note [Why care for top-level demand annotations?]. + +How do we get this result? Answer: By analysing the program as if it was a let +expression of this form: + let e1 = ... in + let n1 = ... in + let e2 = ... in + let n2 = ... in + (e1,e2, ...) +E.g. putting all bindings in nested lets and returning all exported binders in a tuple. +Of course, we will not actually build that CoreExpr! Instead we faithfully +simulate analysis of said expression by adding the free variable 'DmdEnv' +of @e*@'s strictness signatures to the 'DmdType' we get from analysing the +nested bindings. + +And even then the above form blows up analysis performance in T10370: +If @e1@ uses many free variables, we'll unnecessarily carry their demands around +with us from the moment we analyse the pair to the moment we bubble back up to +the binding for @e1@. So instead we analyse as if we had + let e1 = ... in + (e1, let n1 = ... in + ( let e2 = ... in + (e2, let n2 = ... in + ( ...)))) +That is, a series of right-nested pairs, where the @fst@ are the exported +binders of the last enclosing let binding and @snd@ continues the nested +lets. + +Variables occurring free in RULE RHSs are to be handled the same as exported Ids. +See also Note [Absence analysis for stable unfoldings and RULES]. + +Note [Why care for top-level demand annotations?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Reading Note [Analysing top-level bindings], you might think that we go through +quite some trouble to get useful demands for top-level bindings. They can never +be strict, for example, so why bother? + +First, we get to eta-expand top-level bindings that we weren't able to +eta-expand before without Call Arity. From T18894b: + module T18894b (f) where + eta :: Int -> Int -> Int + eta x = if fst (expensive x) == 13 then \y -> ... else \y -> ... + f m = ... eta m 2 ... eta 2 m ... +Since only @f@ is exported, we see all call sites of @eta@ and can eta-expand to +arity 2. + +The call demands we get for some top-level bindings will also allow Nested CPR +to unbox deeper. From T18894: + module T18894 (h) where + g m n = (2 * m, 2 `div` n) + {-# NOINLINE g #-} + h :: Int -> Int + h m = ... snd (g m 2) ... uncurry (+) (g 2 m) ... +Only @h@ is exported, hence we see that @g@ is always called in contexts were we +also force the division in the second component of the pair returned by @g@. +This allows Nested CPR to evaluate the division eagerly and return an I# in its +position. +-} + +{- +************************************************************************ +* * +\subsection{The analyser itself} +* * +************************************************************************ +-} + +-- | Analyse a binding group and its \"body\", e.g. where it is in scope. +-- +-- It calls a function that knows how to analyse this \"body\" given +-- an 'AnalEnv' with updated demand signatures for the binding group +-- (reflecting their 'idDmdSigInfo') and expects to receive a +-- 'DmdType' in return, which it uses to annotate the binding group with their +-- 'idDemandInfo'. +dmdAnalBind + :: TopLevelFlag + -> AnalEnv + -> SubDemand -- ^ Demand put on the "body" + -- (important for join points) + -> CoreBind + -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. + -- where the binding is in scope + -> WithDmdType (DmdResult CoreBind a) +dmdAnalBind top_lvl env dmd bind anal_body = case bind of + NonRec id rhs + | useLetUp top_lvl id + -> dmdAnalBindLetUp top_lvl env_rhs id rhs anal_body + _ -> dmdAnalBindLetDown top_lvl env_rhs dmd bind anal_body + where + env_rhs = enterDFun bind env + +-- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') +-- with 'topDmd', the rest with the given demand. +setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id +setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of + TopLevel | not (isInterestingTopLevelFn id) -> topDmd + _ -> dmd + +-- | Update the demand signature, but be careful not to change boxity info if +-- `dmd_do_boxity` is True or if the signature is bottom. +-- See Note [Don't change boxity without worker/wrapper] +-- and Note [Boxity for bottoming functions]. +setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id +setIdDmdAndBoxSig opts id sig = setIdDmdSig id $ + if dmd_do_boxity opts || isBottomingSig sig + then sig + else transferArgBoxityDmdSig (idDmdSig id) sig + +-- | Let bindings can be processed in two ways: +-- Down (RHS before body) or Up (body before RHS). +-- This function handles the up variant. +-- +-- It is very simple. For let x = rhs in body +-- * Demand-analyse 'body' in the current environment +-- * Find the demand, 'rhs_dmd' placed on 'x' by 'body' +-- * Demand-analyse 'rhs' in 'rhs_dmd' +-- +-- This is used for a non-recursive local let without manifest lambdas (see +-- 'useLetUp'). +-- +-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”. +dmdAnalBindLetUp :: TopLevelFlag + -> AnalEnv + -> Id + -> CoreExpr + -> (AnalEnv -> WithDmdType a) + -> WithDmdType (DmdResult CoreBind a) +dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) + where + WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id) + -- See Note [Bringing a new variable into scope] + WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id + -- See Note [Finalising boxity for demand signatures] + + id_dmd' = finaliseLetBoxity env (idType id) id_dmd + !id' = setBindIdDemandInfo top_lvl id id_dmd' + (rhs_ty, rhs') = dmdAnalStar env id_dmd' rhs + + -- See Note [Absence analysis for stable unfoldings and RULES] + rule_fvs = bndrRuleAndUnfoldingIds id + final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + +-- | Let bindings can be processed in two ways: +-- Down (RHS before body) or Up (body before RHS). +-- This function handles the down variant. +-- +-- It computes a demand signature (by means of 'dmdAnalRhsSig') and uses +-- that at call sites in the body. +-- +-- It is used for toplevel definitions, recursive definitions and local +-- non-recursive definitions that have manifest lambdas (cf. 'useLetUp'). +-- Local non-recursive definitions without a lambda are handled with LetUp. +-- +-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. +dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) +dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of + NonRec id rhs + | (env', weak_fv, id1, rhs1) <- + dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs + -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only) + Rec pairs + | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs + -> do_rest env' weak_fv pairs' Rec + where + do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') + where + WithDmdType body_ty body' = anal_body env' + -- see Note [Lazy and unleashable free variables] + dmd_ty = addWeakFVs body_ty weak_fv + WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1) + -- Important to force this as build_bind might not force it. + !pairs2 = strictZipWith do_one pairs1 id_dmds + do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs' + -- If the actual demand is better than the vanilla call + -- demand, you might think that we might do better to re-analyse + -- the RHS with the stronger demand. + -- But (a) That seldom happens, because it means that *every* path in + -- the body of the let has to use that stronger demand + -- (b) It often happens temporarily in when fixpointing, because + -- the recursive function at first seems to place a massive demand. + -- But we don't want to go to extra work when the function will + -- probably iterate to something less demanding. + -- In practice, all the times the actual demand on id2 is more than + -- the vanilla call demand seem to be due to (b). So we don't + -- bother to re-analyse the RHS. + +-- | Mimic the effect of 'GHC.Core.Prep.mkFloat', turning non-trivial argument +-- expressions/RHSs into a proper let-bound thunk (lifted) or a case (with +-- unlifted scrutinee). +anticipateANF :: CoreExpr -> Card -> Card +anticipateANF e n + | exprIsTrivial e = n -- trivial expr won't have a binding + | definitelyUnliftedType (exprType e) + , not (isAbs n && exprOkForSpeculation e) = case_bind n + | otherwise = let_bind n + where + case_bind _ = C_11 -- evaluated exactly once + let_bind = oneifyCard -- evaluated at most once + +-- Do not process absent demands +-- Otherwise act like in a normal demand analysis +-- See ↦* relation in the Cardinality Analysis paper +dmdAnalStar :: AnalEnv + -> Demand -- This one takes a *Demand* + -> CoreExpr + -> (DmdEnv, CoreExpr) +dmdAnalStar env (n :* sd) e + -- NB: (:*) expands AbsDmd and BotDmd as needed + | WithDmdType dmd_ty e' <- dmdAnal env sd e + , n' <- anticipateANF e n + -- See Note [Anticipating ANF in demand analysis] + -- and Note [Analysing with absent demand] + = (multDmdEnv n' (discardArgDmds dmd_ty), e') + +-- Main Demand Analysis machinery +dmdAnal, dmdAnal' :: AnalEnv + -> SubDemand -- The main one takes a *SubDemand* + -> CoreExpr -> WithDmdType CoreExpr + +dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ + dmdAnal' env d e + +dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit) +dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact +dmdAnal' _ _ (Coercion co) + = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co) + +dmdAnal' env dmd (Var var) + = WithDmdType (dmdTransform env var dmd) (Var var) + +dmdAnal' env dmd (Cast e co) + = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co) + where + WithDmdType dmd_ty e' = dmdAnal env dmd e + +dmdAnal' env dmd (Tick t e) + = WithDmdType dmd_ty (Tick t e') + where + WithDmdType dmd_ty e' = dmdAnal env dmd e + +dmdAnal' env dmd (App fun (Type ty)) + = WithDmdType fun_ty (App fun' (Type ty)) + where + WithDmdType fun_ty fun' = dmdAnal env dmd fun + +-- Lots of the other code is there to make this +-- beautiful, compositional, application rule :-) +dmdAnal' env dmd (App fun arg) + = -- This case handles value arguments (type args handled above) + -- Crucially, coercions /are/ handled here, because they are + -- value arguments (#10288) + let + call_dmd = mkCalledOnceDmd dmd + WithDmdType fun_ty fun' = dmdAnal env call_dmd fun + (arg_dmd, res_ty) = splitDmdTy fun_ty + (arg_ty, arg') = dmdAnalStar env arg_dmd arg + in +-- pprTrace "dmdAnal:app" (vcat +-- [ text "dmd =" <+> ppr dmd +-- , text "expr =" <+> ppr (App fun arg) +-- , text "fun dmd_ty =" <+> ppr fun_ty +-- , text "arg dmd =" <+> ppr arg_dmd +-- , text "arg dmd_ty =" <+> ppr arg_ty +-- , text "res dmd_ty =" <+> ppr res_ty +-- , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ]) + WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg') + +dmdAnal' env dmd (Lam var body) + | isTyVar var + = let + WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body + -- See Note [Bringing a new variable into scope] + in + WithDmdType body_ty (Lam var body') + + | otherwise + = let (n, body_dmd) = peelCallDmd dmd + -- body_dmd: a demand to analyze the body + + WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body + -- See Note [Bringing a new variable into scope] + WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var + new_dmd_type = multDmdType n lam_ty + in + WithDmdType new_dmd_type (Lam var' body') + +dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) + -- Only one alternative. + -- If it's a DataAlt, it should be the only constructor of the type and we + -- can consider its field demands when analysing the scrutinee. + | want_precise_field_dmds alt_con + = let + rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs + WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs + WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr + !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + + -- Evaluation cardinality on the case binder is irrelevant and a no-op. + -- What matters is its nested sub-demand! + -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is + -- what we want, because then `seq` will put a `seqDmd` on its scrut. + (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd + + -- Compute demand on the scrutinee + -- FORCE the result, otherwise thunks will end up retaining the + -- whole DmdEnv + !(!bndrs', !scrut_sd) + | DataAlt _ <- alt_con + -- See Note [Demand on the scrutinee of a product case] + , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds + -- See Note [Demand on case-alternative binders] + , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds) + , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' + = (bndrs', scrut_sd) + | otherwise + -- DEFAULT alts. Simply add demands and discard the evaluation + -- cardinality, as we evaluate the scrutinee exactly once. + = assert (null bndrs) (bndrs, case_bndr_sd) + + alt_ty3 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException (ae_fam_envs env) scrut + = deferAfterPreciseException alt_ty2 + | otherwise + = alt_ty2 + + WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut + res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty + in +-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut +-- , text "dmd" <+> ppr dmd +-- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') +-- , text "scrut_sd" <+> ppr scrut_sd +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) $ + WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs']) + where + want_precise_field_dmds (DataAlt dc) + | let tc = dataConTyCon dc + , assertPpr (not (isNewTyCon tc)) (ppr dc) True -- DataAlt is never newtype + , Nothing <- tyConSingleDataCon_maybe $ dataConTyCon dc + = False -- Not a product type, even though this is the + -- only remaining possible data constructor + | DefinitelyRecursive <- ae_rec_dc env dc + = False -- See Note [Demand analysis for recursive data constructors] + | otherwise + = True + want_precise_field_dmds (LitAlt {}) = False -- Like the non-product datacon above + want_precise_field_dmds DEFAULT = True + +dmdAnal' env dmd (Case scrut case_bndr ty alts) + = let -- Case expression with multiple alternatives + WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut + + WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr + !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + WithDmdType alt_ty alts' = dmdAnalSumAlts env dmd case_bndr alts + + fam_envs = ae_fam_envs env + alt_ty2 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty1 + | otherwise + = alt_ty1 + res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 + + in +-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty1" <+> ppr alt_ty1 +-- , text "alt_ty2" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) $ + WithDmdType res_ty (Case scrut' case_bndr' ty alts') + +dmdAnal' env dmd (Let bind body) + = WithDmdType final_ty (Let bind' body') + where + !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go' + go' !env' = dmdAnal env' dmd body + +-- | A simple, syntactic analysis of whether an expression MAY throw a precise +-- exception when evaluated. It's always sound to return 'True'. +-- See Note [Which scrutinees may throw precise exceptions]. +exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool +exprMayThrowPreciseException envs e + | not (forcesRealWorld envs (exprType e)) + = False -- 1. in the Note + | Var f <- fn + , Just op <- isPrimOpId_maybe f + , op /= RaiseIOOp + = False -- 2. in the Note + | Var f <- fn + , f `hasKey` seqHashKey + = False -- 3. in the Note + | Var f <- fn + , Just fcall <- isFCallId_maybe f + , not (isSafeForeignCall fcall) + = False -- 4. in the Note + | otherwise + = True -- _. in the Note + where + (fn, _) = collectArgs e + +-- | Recognises types that are +-- * @State# RealWorld@ +-- * Unboxed tuples with a @State# RealWorld@ field +-- modulo coercions. This will detect 'IO' actions (even post Nested CPR! See +-- T13380e) and user-written variants thereof by their type. +forcesRealWorld :: FamInstEnvs -> Type -> Bool +forcesRealWorld fam_envs ty + | ty `eqType` realWorldStatePrimTy + = True + | Just (tc, tc_args, _co) <- normSplitTyConApp_maybe fam_envs ty + , isUnboxedTupleTyCon tc + , let field_tys = dataConInstArgTys (tyConSingleDataCon tc) tc_args + = any (eqType realWorldStatePrimTy . scaledThing) field_tys + | otherwise + = False + +dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt] +dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType [] + -- Base case is botDmdType, for empty case alternatives + -- This is a unit for lubDmdType, and the right result + -- when there really are no alternatives +dmdAnalSumAlts env dmd case_bndr (alt:alts) + = let + WithDmdType cur_ty alt' = dmdAnalSumAlt env dmd case_bndr alt + WithDmdType rest_ty alts' = dmdAnalSumAlts env dmd case_bndr alts + in WithDmdType (lubDmdType cur_ty rest_ty) (alt':alts') + + +dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt +dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) + | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs + , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs + , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr + -- See Note [Demand on case-alternative binders] + -- we can't use the scrut_sd, because it says 'Prod' and we'll use + -- topSubDmd anyway for scrutinees of sum types. + scrut_sd = scrutSubDmd case_bndr_sd dmds + dmds' = fieldBndrDmds scrut_sd (length dmds) + -- Do not put a thunk into the Alt + !new_ids = setBndrsDemandInfo bndrs dmds' + = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $ + WithDmdType alt_ty (Alt con new_ids rhs') + +-- See Note [Demand on the scrutinee of a product case] +scrutSubDmd :: SubDemand -> [Demand] -> SubDemand +scrutSubDmd case_sd fld_dmds = + -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $ + case_sd `plusSubDmd` mkProd Unboxed fld_dmds + +-- See Note [Demand on case-alternative binders] +fieldBndrDmds :: SubDemand -- on the scrutinee + -> Arity + -> [Demand] -- Final demands for the components of the DataCon +fieldBndrDmds scrut_sd n_flds = + case viewProd n_flds scrut_sd of + Just (_, ds) -> ds + Nothing -> replicate n_flds topDmd + -- Either an arity mismatch or scrut_sd was a call demand. + -- See Note [Untyped demand on case-alternative binders] + +{- +Note [Anticipating ANF in demand analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When analysing non-complex (e.g., trivial) thunks and complex function +arguments, we have to pretend that the expression is really in administrative +normal form (ANF), the conversion to which is done by CorePrep. + +Consider +``` +f x = let y = x |> co in y `seq` y `seq` () +``` +E.g., 'y' is a let-binding with a trivial RHS. That may occur if 'y' can't be +inlined, for example. Now, is 'x' used once? It may appear as if that is the +case, since its only occurrence is in 'y's memoised RHS. But actually, CorePrep +will *not* allocate a thunk for 'y', because it is trivial and could just +re-use the memoisation mechanism of 'x'! By saying that 'x' is used once it +becomes a single-entry thunk and a call to 'f' will evaluate it twice. +The same applies to trivial arguments, e.g., `f z` really evaluates `z` twice. + +So, somewhat counter-intuitively, trivial arguments and let RHSs will *not* be +memoised. On the other hand, evaluation of non-trivial arguments and let RHSs +*will* be memoised. In fact, consider the effect of conversion to ANF on complex +function arguments (as done by 'GHC.Core.Prep.mkFloat'): +``` +f2 (g2 x) ===> let y = g2 x in f2 y (if `y` is lifted) +f3 (g3 x) ===> case g3 x of y { __DEFAULT -> f3 y } (if `y` is not lifted) +``` +So if a lifted argument like `g2 x` is complex enough, it will be memoised. +Regardless how many times 'f2' evaluates its parameter, the argument will be +evaluated at most once to WHNF. +Similarly, when an unlifted argument like `g3 x` is complex enough, we will +evaluate it *exactly* once to WHNF, no matter how 'f3' evaluates its parameter. + +Note that any evaluation beyond WHNF is not affected by memoisation. So this +Note affects the outer 'Card' of a 'Demand', but not its nested 'SubDemand'. +'anticipateANF' predicts the effect of case-binding and let-binding complex +arguments, as well as the lack of memoisation for trivial let RHSs. +In particular, this takes care of the gripes in +Note [Analysing with absent demand] relating to unlifted types. + +Note [Analysing with absent demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we analyse an expression with demand A. The "A" means +"absent", so this expression will never be needed. What should happen? +There are several wrinkles: + +* We *do* want to analyse the expression regardless. + Reason: Note [Always analyse in virgin pass] + + But we can post-process the results to ignore all the usage + demands coming back. This is done by 'multDmdType' with the appropriate + (absent) evaluation cardinality A or B. + +* Nevertheless, which sub-demand should we pick for analysis? + Since the demand was absent, any would do. Worker/wrapper will replace + absent bindings with an absent filler anyway, so annotations in the RHS + of an absent binding don't matter much. + Picking 'botSubDmd' would be the most useful, but would also look a bit + misleading in the Core output of DmdAnal, because all nested annotations would + be bottoming. Better pick 'seqSubDmd', so that we annotate many of those + nested bindings with A themselves. + +* Since we allow unlifted arguments that are not ok-for-speculation, + we need to be extra careful in the following situation, because unlifted + values are evaluated even if they are not used. Example from #9254: + f :: (() -> (# Int#, () #)) -> () + -- Strictness signature is + -- <1C(1,P(A,1L))> + -- I.e. calls k, but discards first component of result + f k = case k () of (# _, r #) -> r + + g :: Int -> () + g y = f (\n -> (# case y of I# y2 -> y2, n #)) + + Here, f's strictness signature says (correctly) that it calls its argument + function and ignores the first component of its result. + + But in function g, we *will* evaluate the 'case y of ...', because it has type + Int#. So in the program as written, 'y' will be evaluated. Hence we must + record this usage of 'y', else 'g' will say 'y' is absent, and will w/w so + that 'y' is bound to an absent filler (see Note [Absent fillers]), leading + to a crash when 'y' is evaluated. + + Now, worker/wrapper could be smarter and replace `case y of I# y2 -> y2` + with a suitable absent filler such as `RUBBISH[IntRep] @Int#`. + But as long as worker/wrapper isn't equipped to do so, we must be cautious, + and follow Note [Anticipating ANF in demand analysis]. That is, in + 'dmdAnalStar', we will set the evaluation cardinality to C_11, anticipating + the case binding of the complex argument `case y of I# y2 -> y2`. This + cardinlities' only effect is in the call to 'multDmdType', where it makes sure + that the demand on the arg's free variable 'y' is not absent and strict, so + that it is ultimately passed unboxed to 'g'. + +Note [Always analyse in virgin pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tricky point: make sure that we analyse in the 'virgin' pass. Consider + rec { f acc x True = f (...rec { g y = ...g... }...) + f acc x False = acc } +In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. +That might mean that we analyse the sub-expression containing the +E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* +E, but just returned botType. + +Then in the *next* (non-virgin) iteration for 'f', we might analyse E +in a weaker demand, and that will trigger doing a fixpoint iteration +for g. But *because it's not the virgin pass* we won't start g's +iteration at bottom. Disaster. (This happened in $sfibToList' of +nofib/spectral/fibheaps.) + +So in the virgin pass we make sure that we do analyse the expression +at least once, to initialise its signatures. + +Note [Which scrutinees may throw precise exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is the specification of 'exprMayThrowPreciseExceptions', +which is important for Scenario 2 of +Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. + +For an expression @f a1 ... an :: ty@ we determine that + 1. False If ty is *not* @State# RealWorld@ or an unboxed tuple thereof. + This check is done by 'forcesRealWorld'. + (Why not simply unboxed pairs as above? This is motivated by + T13380{d,e}.) + 2. False If f is a PrimOp, and it is *not* raiseIO# + 3. False If f is the PrimOp-like `seq#`, cf. Note [seq# magic]. + 4. False If f is an unsafe FFI call ('PlayRisky') + _. True Otherwise "give up". + +It is sound to return False in those cases, because + 1. We don't give any guarantees for unsafePerformIO, so no precise exceptions + from pure code. + 2. raiseIO# is the only primop that may throw a precise exception. + 3. `seq#` used to be a primop that did not throw a precise exception. + We keep it that way for back-compat. + See the implementation bits of Note [seq# magic] in GHC.Types.Id.Make. + 4. Unsafe FFI calls may not interact with the RTS (to throw, for example). + See haddock on GHC.Types.ForeignCall.PlayRisky. + +We *need* to return False in those cases, because + 1. We would lose too much strictness in pure code, all over the place. + 2. We would lose strictness for primops like getMaskingState#, which + introduces a substantial regression in + GHC.IO.Handle.Internals.wantReadableHandle. + 3. `seq#` used to be a PrimOp and we want to stay backwards compatible. + 4. We would lose strictness for code like GHC.Fingerprint.fingerprintData, + where an intermittent FFI call to c_MD5Init would otherwise lose + strictness on the arguments len and buf, leading to regressions in T9203 + (2%) and i386's haddock.base (5%). Tested by T13380f. + +In !3014 we tried a more sophisticated analysis by introducing ConOrDiv (nic) +to the Divergence lattice, but in practice it turned out to be hard to untaint +from 'topDiv' to 'conDiv', leading to bugs, performance regressions and +complexity that didn't justify the single fixed testcase T13380c. + +You might think that we should check for side-effects rather than just for +precise exceptions. Right you are! See Note [Side-effects and strictness] +for why we unfortunately do not. + +Note [Demand analysis for recursive data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +T11545 features a single-product, recursive data type + data A = A A A ... A + deriving Eq +Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That +leads to very large (exponential in the depth) demand signatures and fruitless +churn in boxity analysis, demand analysis and worker/wrapper. + +So we detect `A` as a recursive data constructor (see +Note [Detecting recursive data constructors]) analysing `case x of A ...` +and simply assume L for the demand on field binders, which is the same code +path as we take for sum types. This code happens in want_precise_field_dmds +in the Case equation for dmdAnal. + +Combined with the B demand on the case binder, we get the very small demand +signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545 +tenfold! See also Note [CPR for recursive data constructors] which describes the +sibling mechanism in CPR analysis. + +Note [Demand on the scrutinee of a product case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When figuring out the demand on the scrutinee of a product case, +we use the demands of the case alternative, i.e. id_dmds. +But note that these include the demand on the case binder; +see Note [Demand on case-alternative binders]. +This is crucial. Example: + f x = case x of y { (a,b) -> k y a } +If we just take scrut_demand = 1P(L,A), then we won't pass x to the +worker, so the worker will rebuild + x = (a, absent-error) +and that'll crash. + +Note [Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand on a binder in a case alternative comes + (a) From the demand on the binder itself + (b) From the demand on the case binder +Forgetting (b) led directly to #10148. + +Example. Source code: + f x@(p,_) = if p then foo x else True + + foo (p,True) = True + foo (p,q) = foo (q,p) + +After strictness analysis, forgetting (b): + f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> + case x_an1 + of wild_X7 [Dmd=MP(ML,ML)] + { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> foo wild_X7 } + +Note that ds_dnz is syntactically dead, but the expression bound to it is +reachable through the case binder wild_X7. Now watch what happens if we inline +foo's wrapper: + f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> + case x_an1 + of _ [Dmd=MP(ML,ML)] + { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> $wfoo_soq GHC.Types.True ds_dnz } + +Look at that! ds_dnz has come back to life in the call to $wfoo_soq! A second +run of demand analysis would no longer infer ds_dnz to be absent. +But unlike occurrence analysis, which infers properties of the *syntactic* +shape of the program, the results of demand analysis describe expressions +*semantically* and are supposed to be mostly stable across Simplification. +That's why we should better account for (b). +In #10148, we ended up emitting a single-entry thunk instead of an updateable +thunk for a let binder that was an an absent case-alt binder during DmdAnal. + +This is needed even for non-product types, in case the case-binder +is used but the components of the case alternative are not. + +Note [Untyped demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder +may be a call demand or have a different number of fields than the constructor +of the case alternative it is used in. From T22039: + + blarg :: (Int, Int) -> Int + blarg (x,y) = x+y + -- blarg :: <1!P(1L,1L)> + + f :: Either Int Int -> Int + f Left{} = 0 + f e = blarg (unsafeCoerce e) + ==> { desugars to } + f = \ (ds_d1nV :: Either Int Int) -> + case ds_d1nV of wild_X1 { + Left ds_d1oV -> lvl_s1Q6; + Right ipv_s1Pl -> + blarg + (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of + { UnsafeRefl co_a1oT -> + wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int)) + }) + } + +The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call +to `blarg`, but `Right` only has one field. Although the code will crash when +executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively +approximate with Top instead of panicking because of the mismatch. +In #22039, this kind of code was guarded behind a safe `cast` and thus dead +code, but nevertheless led to a panic of the compiler. + +You might wonder why the same problem doesn't come up when scrutinising a +product type instead of a sum type. It appears that for products, `wild_X1` +will be inlined before DmdAnal. + +See also Note [mkWWstr and unsafeCoerce] for a related issue. + +Note [Aggregated demand for cardinality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +FIXME: This Note should be named [LetUp vs. LetDown] and probably predates +said separation. SG + +We use different strategies for strictness and usage/cardinality to +"unleash" demands captured on free variables by bindings. Let us +consider the example: + +f1 y = let {-# NOINLINE h #-} + h = y + in (h, h) + +We are interested in obtaining cardinality demand U1 on |y|, as it is +used only in a thunk, and, therefore, is not going to be updated any +more. Therefore, the demand on |y|, captured and unleashed by usage of +|h| is U1. However, if we unleash this demand every time |h| is used, +and then sum up the effects, the ultimate demand on |y| will be U1 + +U1 = U. In order to avoid it, we *first* collect the aggregate demand +on |h| in the body of let-expression, and only then apply the demand +transformer: + +transf[x](U) = {y |-> U1} + +so the resulting demand on |y| is U1. + +The situation is, however, different for strictness, where this +aggregating approach exhibits worse results because of the nature of +|both| operation for strictness. Consider the example: + +f y c = + let h x = y |seq| x + in case of + True -> h True + False -> y + +It is clear that |f| is strict in |y|, however, the suggested analysis +will infer from the body of |let| that |h| is used lazily (as it is +used in one branch only), therefore lazy demand will be put on its +free variable |y|. Conversely, if the demand on |h| is unleashed right +on the spot, we will get the desired result, namely, that |f| is +strict in |y|. + + +************************************************************************ +* * + Demand transformer +* * +************************************************************************ +-} + +dmdTransform :: AnalEnv -- ^ The analysis environment + -> Id -- ^ The variable + -> SubDemand -- ^ The evaluation context of the var + -> DmdType -- ^ The demand type unleashed by the variable in this + -- context. The returned DmdEnv includes the demand on + -- this function plus demand on its free variables +-- See Note [DmdSig: demand signatures, and demand-sig arity] in "GHC.Types.Demand" +dmdTransform env var sd + -- Data constructors + | Just con <- isDataConWorkId_maybe var + = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $ + dmdTransformDataConSig (dataConRepStrictness con) sd + -- See Note [DmdAnal for DataCon wrappers] + | Just rhs <- dataConWrapUnfolding_maybe var + , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs + = dmd_ty + -- Dictionary component selectors + -- Used to be controlled by a flag. + -- See #18429 for some perf measurements. + | Just _ <- isClassOpId_maybe var + = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $ + dmdTransformDictSelSig (idDmdSig var) sd + -- Imported functions + | isGlobalId var + , let res = dmdTransformSig (idDmdSig var) sd + = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr sd, ppr res]) + res + -- Top-level or local let-bound thing for which we use LetDown ('useLetUp'). + -- In that case, we have a strictness signature to unleash in our AnalEnv. + | Just (sig, top_lvl) <- lookupSigEnv env var + , let fn_ty = dmdTransformSig sig sd + = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr sd, ppr fn_ty]) $ + case top_lvl of + NotTopLevel -> addVarDmd fn_ty var (C_11 :* sd) + TopLevel + | isInterestingTopLevelFn var + -- Top-level things will be used multiple times or not at + -- all anyway, hence the `floatifyDmd`: it means we don't + -- have to track whether @var@ is used strictly or at most + -- once, because ultimately it never will + -> addVarDmd fn_ty var (floatifyDmd (C_11 :* sd)) + | otherwise + -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later + -- Everything else: + -- * Local let binders for which we use LetUp (cf. 'useLetUp') + -- * Lambda binders + -- * Case and constructor field binders + | otherwise + = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $ + noArgsDmdType (addVarDmdEnv nopDmdEnv var (C_11 :* sd)) + +{- ********************************************************************* +* * + Binding right-hand sides +* * +********************************************************************* -} + +-- | An environment in which all demands are weak according to 'isWeakDmd'. +-- See Note [Lazy and unleashable free variables]. +type WeakDmds = VarEnv Demand + +-- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature +-- for the LetDown rule. It works as follows: +-- +-- * assuming the weakest possible body sub-demand, L +-- * looking at the definition +-- * determining a strictness signature +-- +-- Since it assumed a body sub-demand of L, the resulting signature is +-- applicable at any call site. +dmdAnalRhsSig + :: TopLevelFlag + -> RecFlag + -> AnalEnv -> SubDemand + -> Id -> CoreExpr + -> (AnalEnv, WeakDmds, Id, CoreExpr) +-- Process the RHS of the binding, add the strictness signature +-- to the Id, and augment the environment with the signature as well. +-- See Note [NOINLINE and strictness] +dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs + = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $ + (final_env, weak_fvs, final_id, final_rhs) + where + ww_arity = workWrapArity id rhs + -- See Note [Worker/wrapper arity and join points] point (1) + + body_sd | isJoinId id = let_sd + | otherwise = topSubDmd + -- See Note [Demand analysis for join points] + -- See Note [Invariants on join points] invariant 2b, in GHC.Core + -- ww_arity matches the join arity of the join point + + adjusted_body_sd = unboxedWhenSmall env rec_flag (resultType_maybe id) body_sd + -- See Note [Unboxed demand on function bodies returning small products] + + rhs_sd = mkCalledOnceDmds ww_arity adjusted_body_sd + + WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_sd rhs + DmdType rhs_env rhs_dmds = rhs_dmd_ty + (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity + rhs_dmds (de_div rhs_env) rhs' + + dmd_sig_arity = ww_arity + strictCallArity body_sd + sig = mkDmdSigForArity dmd_sig_arity (DmdType sig_env final_rhs_dmds) + -- strictCallArity is > 0 only for join points + -- See Note [mkDmdSigForArity] + + opts = ae_opts env + final_id = setIdDmdAndBoxSig opts id sig + !final_env = extendAnalEnv top_lvl env final_id sig + + -- See Note [Aggregated demand for cardinality] + -- FIXME: That Note doesn't explain the following lines at all. The reason + -- is really much different: When we have a recursive function, we'd + -- have to also consider the free vars of the strictness signature + -- when checking whether we found a fixed-point. That is expensive; + -- we only want to check whether argument demands of the sig changed. + -- reuseEnv makes it so that the FV results are stable as long as the + -- last argument demands were. Strictness won't change. But used-once + -- might turn into used-many even if the signature was stable and + -- we'd have to do an additional iteration. reuseEnv makes sure that + -- we never get used-once info for FVs of recursive functions. + -- See #14816 where we try to get rid of reuseEnv. + rhs_env1 = case rec_flag of + Recursive -> reuseEnv rhs_env + NonRecursive -> rhs_env + + -- See Note [Absence analysis for stable unfoldings and RULES] + rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id) + + -- See Note [Lazy and unleashable free variables] + !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 + +splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) +splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) + where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs + +-- | The result type after applying 'idArity' many arguments. Returns 'Nothing' +-- when the type doesn't have exactly 'idArity' many arrows. +resultType_maybe :: Id -> Maybe Type +resultType_maybe id + | (pis,ret_ty) <- splitPiTys (idType id) + , count isAnonPiTyBinder pis == idArity id + = Just $! ret_ty + | otherwise + = Nothing + +unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand +-- See Note [Unboxed demand on function bodies returning small products] +unboxedWhenSmall _ _ Nothing sd = sd +unboxedWhenSmall env rec_flag (Just ret_ty) sd = go 1 ret_ty sd + where + -- Magic constant, bounding the depth of optimistic 'Unboxed' flags. We + -- might want to minmax in the future. + max_depth | isRec rec_flag = 3 -- So we get at most something as deep as !P(L!P(L!L)) + | otherwise = 1 -- Otherwise be unbox too deep in T18109, T18174 and others and get a bunch of stack overflows + go :: Int -> Type -> SubDemand -> SubDemand + go depth ty sd + | depth <= max_depth + , Just (tc, tc_args, _co) <- normSplitTyConApp_maybe (ae_fam_envs env) ty + , Just [dc] <- canUnboxTyCon tc -- tc is not a newtype + , null (dataConExTyCoVars dc) -- Can't unbox results with existentials + , dataConRepArity dc <= dmd_unbox_width (ae_opts env) + , Just (_, ds) <- viewProd (dataConRepArity dc) sd + , arg_tys <- map scaledThing $ dataConInstArgTys dc tc_args + , equalLength ds arg_tys + = mkProd Unboxed $! strictZipWith (go_dmd (depth+1)) arg_tys ds + | otherwise + = sd + + go_dmd :: Int -> Type -> Demand -> Demand + go_dmd depth ty dmd = case dmd of + AbsDmd -> AbsDmd + BotDmd -> BotDmd + n :* sd -> n :* go depth ty sd + +-- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines +-- whether we should process the binding up (body before rhs) or down (rhs +-- before body). +-- +-- We use LetDown if there is a chance to get a useful strictness signature to +-- unleash at call sites. LetDown is generally more precise than LetUp if we can +-- correctly guess how it will be used in the body, that is, for which incoming +-- demand the strictness signature should be computed, which allows us to +-- unleash higher-order demands on arguments at call sites. This is mostly the +-- case when +-- +-- * The binding takes any arguments before performing meaningful work (cf. +-- 'idArity'), in which case we are interested to see how it uses them. +-- * The binding is a join point, hence acting like a function, not a value. +-- As a big plus, we know *precisely* how it will be used in the body; since +-- it's always tail-called, we can directly unleash the incoming demand of +-- the let binding on its RHS when computing a strictness signature. See +-- [Demand analysis for join points]. +-- +-- Thus, if the binding is not a join point and its arity is 0, we have a thunk +-- and use LetUp, implying that we have no usable demand signature available +-- when we analyse the let body. +-- +-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free +-- vars at most once, regardless of how many times it was forced in the body. +-- This makes a real difference wrt. usage demands. The other reason is being +-- able to unleash a more precise product demand on its RHS once we know how the +-- thunk was used in the let body. +-- +-- Characteristic examples, always assuming a single evaluation: +-- +-- * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that +-- the expression uses @y@ at most once. +-- * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that +-- @b@ is absent. +-- * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that +-- the expression uses @y@ strictly, because we have @f@'s demand signature +-- available at the call site. +-- * @join exit = 2*y in if a then exit else if b then exit else 3*y@ => +-- LetDown. Compared to LetUp, we find out that the expression uses @y@ +-- strictly, because we can unleash @exit@'s signature at each call site. +-- * For a more convincing example with join points, see Note [Demand analysis +-- for join points]. +-- +useLetUp :: TopLevelFlag -> Var -> Bool +useLetUp top_lvl f = isNotTopLevel top_lvl && idArity f == 0 && not (isJoinId f) + +{- Note [Demand analysis for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + g :: (Int,Int) -> Int + g (p,q) = p+q + + f :: T -> Int -> Int + f x p = g (join j y = (p,y) + in case x of + A -> j 3 + B -> j 4 + C -> (p,7)) + +If j was a vanilla function definition, we'd analyse its body with evalDmd, and +think that it was lazy in p. But for join points we can do better! We know +that j's body will (if called at all) be evaluated with the demand that consumes +the entire join-binding, in this case the argument demand from g. Whizzo! g +evaluates both components of its argument pair, so p will certainly be evaluated +if j is called. + +For f to be strict in p, we need /all/ paths to evaluate p; in this case the C +branch does so too, so we are fine. So, as usual, we need to transport demands +on free variables to the call site(s). Compare Note [Lazy and unleashable free +variables]. + +The implementation is easy: see `body_sd` in`dmdAnalRhsSig`. When analysing +a join point, we can analyse its body (after stripping off the join binders, +here just 'y') with the demand from the entire join-binding (written `let_sd` +here). + +Another win for join points! #13543. + +BUT see Note [Worker/wrapper arity and join points]. + +Note we may analyse the rhs of a join point with a demand that is either +bigger than, or smaller than, the number of lambdas syntactically visible. +* More lambdas than call demands: + join j x = \p q r -> blah in ... + in a context with demand Top. + +* More call demands than lambdas: + (join j x = h in ..(j 2)..(j 3)) a b c + +Note [Worker/wrapper arity and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (join j x = \y. error "urk") + (in case v of ) + ( A -> j 3 ) x + ( B -> j 4 ) + ( C -> \y. blah ) + +The entire thing is in a C(1,L) context, so we will analyse j's body, namely + \y. error "urk" +with demand C(C(1,L)). See `rhs_sd` in `dmdAnalRhsSig`. That will produce +a demand signature of b: and indeed `j` diverges when given two arguments. + +BUT we do /not/ want to worker/wrapper `j` with two arguments. Suppose we have + join j2 :: Int -> Int -> blah + j2 x = rhs + in ...(j2 3)...(j2 4)... + +where j2's join-arity is 1, so calls to `j` will all have /one/ argument. +Suppose the entire expression is in a called context (like `j` above) and `j2` +gets the demand signature <1!P(L)><1!P(L)>, that is, strict in both arguments. + +we worker/wrapper'd `j2` with two args we'd get + join $wj2 x# y# = let x = I# x#; y = I# y# in rhs + j2 x = \y. case x of I# x# -> case y of I# y# -> $wj2 x# y# + in ...(j2 3)...(j2 4)... +But now `$wj2`is no longer a join point. Boo. + +Instead if we w/w at all, we want to do so only with /one/ argument: + join $wj2 x# = let x = I# x# in rhs + j2 x = case x of I# x# -> $wj2 x# + in ...(j2 3)...(j2 4)... +Now all is fine. BUT in `finaliseArgBoxities` we should trim y's boxity, +to reflect the fact tta we aren't going to unbox `y` at all. + +Conclusion: + +(1) The "worker/wrapper arity" of an Id is + * For non-join-points: idArity + * The join points: the join arity (Id part only of course) + This is the number of args we will use in worker/wrapper. + See `ww_arity` in `dmdAnalRhsSig`, and the function `workWrapArity`. + +(2) A join point's demand-signature arity may exceed the Id's worker/wrapper + arity. See the `arity_ok` assertion in `mkWwBodies`. + +(3) In `finaliseArgBoxities`, do trimBoxity on any argument demands beyond + the worker/wrapper arity. + +(4) In WorkWrap.splitFun, make sure we split based on the worker/wrapper + arity (re)-computed by workWrapArity. + +Note [The demand for the RHS of a binding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a binding { f = rhs }, in `dmdAnalRhsSig` we compute a `rhs_sd` in +which to analyse `rhs`. + +The demand we use is: + +* Ordinary bindings: a call-demand of depth (idArity f). + Why idArity arguments? Because that's a conservative estimate of how many + arguments we must feed a function before it does anything interesting with + them. Also it elegantly subsumes the trivial RHS and PAP case. E.g. for + f = g + we want to use a threshold arity based on g, not 0! + + idArity is /at least/ the number of manifest lambdas, but might be higher for + PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]). + +* Join points: a call-demand of depth (value-binder subset of JoinArity), + wrapped around the incoming demand for the entire expression; see + Note [Demand analysis for join points] + +Note that the idArity of a function varies independently of its cardinality +properties (cf. Note [idArity varies independently of dmdTypeDepth]), so we +implicitly encode the arity for when a demand signature is sound to unleash in +its 'dmdTypeDepth', not in its idArity (cf. Note [Understanding DmdType and +DmdSig] in GHC.Types.Demand). It is unsound to unleash a demand signature when +the incoming number of arguments is less than that. See GHC.Types.Demand +Note [DmdSig: demand signatures, and demand-sig arity]. + +Note that there might, in principle, be functions for which we might want to +analyse for more incoming arguments than idArity. Example: + + f x = + if expensive + then \y -> ... y ... + else \y -> ... y ... + +We'd analyse `f` under a unary call demand C(1,L), corresponding to idArity +being 1. That's enough to look under the manifest lambda and find out how a +unary call would use `x`, but not enough to look into the lambdas in the if +branches. + +On the other hand, if we analysed for call demand C(1,C(1,L)), we'd get useful +strictness info for `y` (and more precise info on `x`) and possibly CPR +information, but + + * We would no longer be able to unleash the signature at unary call sites + + * Performing the worker/wrapper split based on this information would be + implicitly eta-expanding `f`, playing fast and loose with divergence and + even being unsound in the presence of newtypes, so we refrain from doing so. + Also see Note [Don't eta expand in w/w] in GHC.Core.Opt.WorkWrap. + +Since we only compute one signature, we do so for arity 1. Computing multiple +signatures for different arities (i.e., polyvariance) would be entirely +possible, if it weren't for the additional runtime and implementation +complexity. + +Note [mkDmdSigForArity] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = if expensive x + then \y. blah1 + else \y. blah2 +We will analyse the body with demand C(1L), reflecting the single visible +argument x. But dmdAnal will return a DmdType looking like + DmdType fvs [x-dmd, y-dmd] +because it has seen two lambdas, \x and \y. Since the length of the argument +demands in a DmdSig gives the "threshold" for applying the signature +(see Note [DmdSig: demand signatures, and demand-sig arity] in GHC.Types.Demand) +we must trim that DmdType to just + DmdSig (DmdTypte fvs [x-dmd]) +when making that DmdType into the DmdSig for f. This trimming is the job of +`mkDmdSigForArity`. + +Alternative. An alternative would be be to ensure that if + (dmd_ty, e') = dmdAnal env subdmd e +then the length dmds in dmd_ty is always less than (or maybe equal to?) the +call-depth of subdmd. To do that we'd need to adjust the Lam case of dmdAnal. +Probably not hard, but a job for another day; see discussion on !12873, #23113, +and #21392. + +Note [idArity varies independently of dmdTypeDepth] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, an Id `f` has two independently varying attributes: + +* f's idArity, and +* the dmdTypeDepth of f's demand signature + +For example, if f's demand signature is , f's arity could be +greater than, or less than 2. Why? Because both are conservative +approximations: + +* Arity n means "does no expensive work until applied to at least n args" + (e.g. (f x1..xm) is cheap to bring to HNF for m co + +`go` might have a strictness signature of `<1L>`. The simplifier will identify +`go` as a nullary join point through `joinPointBinding_maybe` and float the +coercion into the binding, leading to an arity decrease: + + join go = (\x y -> `x` seq ...) |> co in go + +With the CoreLint check, we would have to zap `go`'s perfectly viable strictness +signature. + +However, in the case of a /bottoming/ signature, f : b, we /can/ +say that f's arity is no greater than 2, because it'd be false to say +that f does no work when applied to 3 args. Lint checks this constraint, +in `GHC.Core.Lint.lintLetBind`. + +Note [Demand analysis for trivial right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo = plusInt |> co +where plusInt is an arity-2 function with known strictness. Clearly +we want plusInt's strictness to propagate to foo! But because it has +no manifest lambdas, it won't do so automatically, and indeed 'co' might +have type (Int->Int->Int) ~ T. + +Fortunately, GHC.Core.Opt.Arity gives 'foo' arity 2, which is enough for LetDown to +forward plusInt's demand signature, and all is well (see Note [Newtype arity] in +GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity. + +Note [Absence analysis for stable unfoldings and RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Among others, tickets #18638 and #23208 show that it's really important to treat +stable unfoldings as demanded. Consider + + g = blah + + f = \x. ...no use of g.... + {- f's stable unfolding is f = \x. ...g... -} + +If f is ever inlined we use 'g'. But f's current RHS makes no use +of 'g', so if we don't look at the unfolding we'll mark g as Absent, +and transform to + + g = error "Entered absent value" + f = \x. ... + {- f's stable unfolding is f = \x. ...g... -} + +Now if f is subsequently inlined, we'll use 'g' and ... disaster. + +SOLUTION: if f has a stable unfolding, treat every free variable as a +/demand root/, that is: Analyse it as if it was a variable occurring in a +'topDmd' context. This is done in `demandRoot` (which we also use for exported +top-level ids). Do the same for Ids free in the RHS of any RULES for f. + +Wrinkles: + + (W1) You may wonder how it can be that f's optimised RHS has somehow + discarded 'g', but when f is inlined we /don't/ discard g in the same + way. I think a simple example is + g = (a,b) + f = \x. fst g + {-# INLINE f #-} + + Now f's optimised RHS will be \x.a, but if we change g to (error "..") + (since it is apparently Absent) and then inline (\x. fst g) we get + disaster. But regardless, #18638 was a more complicated version of + this, that actually happened in practice. + + (W2) You might wonder why we don't simply take the free vars of the + unfolding/RULE and map them to topDmd. The reason is that any of the free vars + might have demand signatures themselves that in turn demand transitive free + variables and that we hence need to unleash! This came up in #23208. + Consider + + err :: Int -> b + err = error "really important message" + + sg :: Int -> Int + sg _ = case err of {} -- Str=<1B>b {err:->S} + + g :: a -> a -- g is exported + g x = x + {-# RULES "g" g @Int = sg #-} + + Here, `err` is only demanded by `sg`'s demand signature: It doesn't occur + in the weak_fvs of `sg`'s RHS at all. Hence when we `demandRoots` `sg` + because it occurs in the RULEs of `g` (which is exported), we better unleash + the demand signature of `sg`, too! Before #23208 we simply added a 'topDmd' + for `sg`, failing to unleash the signature and hence observed an absent + error instead of the `really important message`. + +Note [DmdAnal for DataCon wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We give DataCon wrappers a (necessarily flat) demand signature in +`GHC.Types.Id.Make.mkDataConRep`, so that passes such as the Simplifier can +exploit it via the call to `GHC.Core.Opt.Simplify.Utils.isStrictArgInfo` in +`GHC.Core.Opt.Simplify.Iteration.rebuildCall`. But during DmdAnal, we *ignore* +the demand signature of a DataCon wrapper, and instead analyse its unfolding at +every call site. + +The reason is that DataCon *worker*s have very precise demand transformers, +computed by `dmdTransformDataConSig`. It would be awkward if DataCon *wrappers* +would behave much less precisely during DmdAnal. Example: + + data T1 = MkT1 { get_x1 :: Int, get_y1 :: Int } + data T2 = MkT2 { get_x2 :: !Int, get_y2 :: Int } + f1 x y = get_x1 (MkT1 x y) + f2 x y = get_x2 (MkT2 x y) + +Here `MkT1` has no wrapper. `get_x1` puts a demand `!P(1!L,A)` on its argument, +and `dmdTransformDataConSig` will transform that demand to an absent demand on +`y` in `f1` and an unboxing demand on `x`. +But `MkT2` has a wrapper (to evaluate the first field). If demand analysis deals +with `MkT2` only through its demand signature, demand signatures can't transform +an incoming demand `P(1!L,A)` in a useful way, so we won't get an absent demand +on `y` in `f2` or see that `x` can be unboxed. That's a serious loss. + +The example above will not actually occur, because $WMkT2 would be inlined. +Nevertheless, we can get interesting sub-demands on DataCon wrapper +applications in boring contexts; see T22241. + +You might worry about the efficiency cost of demand-analysing datacon wrappers +at every call site. But in fact they are inlined /anyway/ in the Final phase, +which happens before DmdAnal, so few wrappers remain. And analysing the +unfoldings for the remaining calls (which are those in a boring context) will be +exactly as (in)efficent as if we'd inlined those calls. It turns out to be not +measurable in practice. + +See also Note [CPR for DataCon wrappers] in `GHC.Core.Opt.CprAnal`. + +Note [Boxity for bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (A) + indexError :: Show a => (a, a) -> a -> String -> b + -- Str=<..><1!P(S,S)><1S>b + indexError rng i s = error (show rng ++ show i ++ show s) + + get :: (Int, Int) -> Int -> [a] -> a + get p@(l,u) i xs + | l <= i, i < u = xs !! (i-u) + | otherwise = indexError p i "get" + +The hot path of `get` certainly wants to unbox `p` as well as `l` and +`u`, but the unimportant, diverging error path needs `l::a` and `u::a` +boxed, since `indexError` can't unbox them because they are polymorphic. +This pattern often occurs in performance sensitive code that does +bounds-checking. + +So we want to give `indexError` a signature like `<1!P(!S,!S)><1!S>b` +where the !S (meaning Poly Unboxed C1N) says that the polymorphic arguments +are unboxed (recursively). The wrapper for `indexError` won't /actually/ +unbox them (because their polymorphic type doesn't allow that) but when +demand-analysing /callers/, we'll behave as if that call needs the args +unboxed. + +Then at call sites of `indexError`, we will end up doing some +reboxing, because `$windexError` still takes boxed arguments. This +reboxing should usually float into the slow, diverging code path; but +sometimes (sadly) it doesn't: see Note [Reboxed crud for bottoming calls]. + +Here is another important case (B): + f x = Just x -- Suppose f is not inlined for some reason + -- Main point: f takes its argument boxed + + wombat x = error (show (f x)) + + g :: Bool -> Int -> a + g True x = x+1 + g False x = wombat x + +Again we want `wombat` to pretend to take its Int-typed argument unboxed, +even though it has to pass it boxed to `f`, so that `g` can take its +argument unboxed (and rebox it before calling `wombat`). + +So here's what we do: while summarising `indexError`'s boxity signature in +`finaliseArgBoxities`: + +* To address (B), for bottoming functions, we start by using `unboxDeeplyDmd` + to make all its argument demands unboxed, right to the leaves; regardless + of what the analysis said. + +* To address (A), for bottoming functions, in the DontUnbox case when the + argument is a type variable, we /refrain/ from using trimBoxity. + (Remember the previous bullet: we have already doen `unboxDeeplyDmd`.) + +Wrinkle: + +* Remember Note [No lazy, Unboxed demands in demand signature]. So + unboxDeeplyDmd doesn't recurse into lazy demands. It's extremely unusual + to have lazy demands in the arguments of a bottoming function anyway. + But it can happen, when the demand analyser gives up because it + encounters a recursive data type; see Note [Demand analysis for recursive + data constructors]. + +Note [Reboxed crud for bottoming calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For functions like `get` in Note [Boxity for bottoming functions], it's clear +that the reboxed crud will be floated inside to the call site of `$windexError`. +But here's an example where that is not the case: +```hs +import GHC.Ix + +theresCrud :: Int -> Int -> Int +theresCrud x y = go x + where + go 0 = index (0,y) 0 + go 1 = index (x,y) 1 + go n = go (n-1) + {-# NOINLINE theresCrud #-} +``` +If you look at the Core, you'll see that `y` will be reboxed and used in the +two exit join points for the `$windexError` calls, while `x` is only reboxed in the +exit join point for `index (x,y) 1` (happens in lvl below): +``` +$wtheresCrud = \ ww ww1 -> + let { y = I# ww1 } in + join { lvl2 = ... case lvl1 ww y of wild { }; ... } in + join { lvl3 = ... case lvl y of wild { }; ... } in + ... +``` +This is currently a bug that we willingly accept and it's documented in #21128. + +See also Note [indexError] in base:GHC.Ix, which describes how we use +SPECIALISE to mitigate this problem for indexError. +-} + +{- ********************************************************************* +* * + Finalising boxity +* * +********************************************************************* -} + +{- Note [Finalising boxity for demand signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The worker/wrapper pass must strictly adhere to the boxity decisions +encoded in the demand signature, because that is the information that +demand analysis propagates throughout the program. Failing to +implement the strategy laid out in the signature can result in +reboxing in unexpected places. Hence, we must completely anticipate +unboxing decisions during demand analysis and reflect these decisions +in demand annotations. That is the job of 'finaliseArgBoxities', +which is defined here and called from demand analysis. + +Here is a list of different Notes it has to take care of: + + * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in + general, but still allow Note [Unboxing evaluated arguments] + * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)` + * Note [mkWWstr and unsafeCoerce] + +NB: Then, the worker/wrapper blindly trusts the boxity info in the +demand signature; that is why 'canUnboxArg' does not look at +strictness -- it is redundant to do so. + +Note [Finalising boxity for let-bound Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let x = e in body +where the demand on 'x' is 1!P(blah). We want to unbox x according to +Note [Thunk splitting] in GHC.Core.Opt.WorkWrap. We must do this because +worker/wrapper ignores strictness and looks only at boxity flags; so if +x's demand is L!P(blah) we might still split it (wrongly). We want to +switch to Boxed on any lazy demand. + +That is what finaliseLetBoxity does. It has no worker-arg budget, so it +is much simpler than finaliseArgBoxities. + +Note [No nested Unboxed inside Boxed in demand signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider +``` +f p@(x,y) + | even (x+y) = [] + | otherwise = [p] +``` +Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)` +on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper +can't unbox the pair components without unboxing the pair! So we better say +`1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info. +That happens via the call to trimBoxity in 'finaliseArgBoxities'/'finaliseLetBoxity'. + +Note [No lazy, Unboxed demands in demand signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider T19407: + + data Huge = Huge Bool () ... () -- think: DynFlags + data T = T { h :: Huge, n :: Int } + f t@(T h _) = g h t + g (H b _ ... _) t = if b then 1 else n t + +The body of `g` puts (approx.) demand `L!P(A,1)` on `t`. But we better +not put that demand in `g`'s demand signature, because worker/wrapper will not +in general unbox a lazy-and-unboxed demand like `L!P(..)`. +(The exception are known-to-be-evaluated arguments like strict fields, +see Note [Unboxing evaluated arguments].) + +The program above is an example where spreading misinformed boxity through the +signature is particularly egregious. If we give `g` that signature, then `f` +puts demand `S!P(1!P(1L,A,..),ML)` on `t`. Now we will unbox `t` in `f` it and +we get + + f (T (H b _ ... _) n) = $wf b n + $wf b n = $wg b (T (H b x ... x) n) + $wg = ... + +Massive reboxing in `$wf`! Solution: Trim boxity on lazy demands in +'trimBoxity', modulo Note [Unboxing evaluated arguments]. + +Note [Unboxing evaluated arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this program (due to Roman): + + data X a = X !a + + foo :: X Int -> Int -> Int + foo x@(X a) n = go 0 + where + go i | i < n = a + go (i+1) + | otherwise = 0 + +We want the worker for 'foo' to look like this: + + $wfoo :: Int# -> Int# -> Int# + +with the first argument unboxed, so that it is not eval'd each time around the +'go' loop (which would otherwise happen, since 'foo' is not strict in 'a'). It +is sound for the wrapper to pass an unboxed arg because X is strict +(see Note [Strictness and Unboxing] in "GHC.Core.Opt.DmdAnal"), so its argument +must be evaluated. And if we *don't* pass an unboxed argument, we can't even +repair it by adding a `seq` thus: + + foo (X a) n = a `seq` go 0 + +because the seq is discarded (very early) since X is strict! + +So here's what we do + +* Since this has nothing to do with how 'foo' uses 'a', we leave demand + analysis alone, but account for the additional evaluatedness when + annotating the binder 'finaliseArgBoxities', which will retain the Unboxed + boxity on 'a' in the definition of 'foo' in the demand 'L!P(L)'; meaning + it's used lazily but unboxed nonetheless. This seems to contradict Note + [No lazy, Unboxed demands in demand signature], but we know that 'a' is + evaluated and thus can be unboxed. + +* When 'finaliseArgBoxities' decides to unbox a record, it will zip the field demands + together with the respective 'StrictnessMark'. In case of 'x', it will pair + up the lazy field demand 'L!P(L)' on 'a' with 'MarkedStrict' to account for + the strict field. + +* Said 'StrictnessMark' is passed to the recursive invocation of 'go_args' in + 'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but + since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'. + +* Worker/wrapper will consult 'canUnboxArg' for its unboxing decision. It will + /not/ look at the strictness bits of the demand, only at Boxity flags. As such, + it will happily unbox 'a' despite the lazy demand on it. + +The net effect is that boxity analysis and the w/w transformation are more +aggressive about unboxing the strict arguments of a data constructor than when +looking at strictness info exclusively. It is very much like (Nested) CPR, which +needs its nested fields to be evaluated in order for it to unbox nestedly. + +There is the usual danger of reboxing, which as usual we ignore. But +if X is monomorphic, and has an UNPACK pragma, then this optimisation +is even more important. We don't want the wrapper to rebox an unboxed +argument, and pass an Int to $wfoo! + +This works in nested situations like T10482 + + data family Bar a + data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) + newtype instance Bar Int = Bar Int + + foo :: Bar ((Int, Int), Int) -> Int -> Int + foo f k = case f of BarPair x y -> + case burble of + True -> case x of + BarPair p q -> ... + False -> ... + +The extra eagerness lets us produce a worker of type: + $wfoo :: Int# -> Int# -> Int# -> Int -> Int + $wfoo p# q# y# = ... + +even though the `case x` is only lazily evaluated. + +--------- Historical note ------------ +We used to add data-con strictness demands when demand analysing case +expression. However, it was noticed in #15696 that this misses some cases. For +instance, consider the program (from T10482) + + data family Bar a + data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) + newtype instance Bar Int = Bar Int + + foo :: Bar ((Int, Int), Int) -> Int -> Int + foo f k = + case f of + BarPair x y -> case burble of + True -> case x of + BarPair p q -> ... + False -> ... + +We really should be able to assume that `p` is already evaluated since it came +from a strict field of BarPair. This strictness would allow us to produce a +worker of type: + + $wfoo :: Int# -> Int# -> Int# -> Int -> Int + $wfoo p# q# y# = ... + +even though the `case x` is only lazily evaluated + +Indeed before we fixed #15696 this would happen since we would float the inner +`case x` through the `case burble` to get: + + foo f k = + case f of + BarPair x y -> case x of + BarPair p q -> case burble of + True -> ... + False -> ... + +However, after fixing #15696 this could no longer happen (for the reasons +discussed in ticket:15696#comment:76). This means that the demand placed on `f` +would then be significantly weaker (since the False branch of the case on +`burble` is not strict in `p` or `q`). + +Consequently, we now instead account for data-con strictness in mkWWstr_one, +applying the strictness demands to the final result of DmdAnal. The result is +that we get the strict demand signature we wanted even if we can't float +the case on `x` up through the case on `burble`. + +Note [Worker argument budget] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In 'finaliseArgBoxities' we don't want to generate workers with zillions of +argument when, say given a strict record with zillions of fields. So we +limit the maximum number of worker args ('max_wkr_args') to the maximum of + - -fmax-worker-args=N + - The number of args in the original function; if it already has has + zillions of arguments we don't want to seek /fewer/ args in the worker. +(Maybe we should /add/ them instead of maxing?) + +We pursue a "layered" strategy for unboxing: we unbox the top level of the +argument(s), subject to budget; if there are any arguments left we unbox the +next layer, using that depleted budget. +Unboxing an argument *increases* the budget for the inner layer roughly +according to how many registers that argument takes (unboxed tuples take +multiple registers, see below), as determined by 'unariseArity'. +Budget is spent when we have to pass a non-absent field as a parameter. + +To achieve this, we use the classic almost-circular programming technique in +which we we write one pass that takes a lazy list of the Budgets for every +layer. The effect is that of a breadth-first search (over argument type and +demand structure) to compute Budgets followed by a depth-first search to +construct the product demands, but laziness allows us to do it all in one +pass and without intermediate data structures. + +Suppose we have -fmax-worker-args=4 for the remainder of this Note. +Then consider this example function: + + boxed :: (Int, Int) -> (Int, (Int, Int, Int)) -> Int + boxed (a,b) (c, (d,e,f)) = a + b + c + d + e + f + +With a budget of 4 args to spend (number of args is only 2), we'd be served well +to unbox both pairs, but not the triple. Indeed, that is what the algorithm +computes, and the following pictogram shows how the budget layers are computed. +Each layer is started with `n ~>`, where `n` is the budget at the start of the +layer. We write -n~> when we spend budget (and n is the remaining budget) and ++n~> when we earn budget. We separate unboxed args with ][ and indicate +inner budget threads becoming negative in braces {{}}, so that we see which +unboxing decision we do *not* commit to. Without further ado: + + 4 ~> ][ (a,b) -3~> ][ (c, ...) -2~> + ][ | | ][ | | + ][ | +-------------+ ][ | +-----------------+ + ][ | | ][ | | + ][ v v ][ v v + 2 ~> ][ +3~> a -2~> ][ b -1~> ][ +2~> c -1~> ][ (d, e, f) -0~> + ][ | ][ | ][ | ][ {{ | | | }} + ][ | ][ | ][ | ][ {{ | | +----------------+ }} + ][ v ][ v ][ v ][ {{ v +------v v }} + 0 ~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ {{ +1~> d -0~> ][ e -(-1)~> ][ f -(-2)~> }} + +Unboxing increments the budget we have on the next layer (because we don't need +to retain the boxed arg), but in turn the inner layer must afford to retain all +non-absent fields, each decrementing the budget. Note how the budget becomes +negative when trying to unbox the triple and the unboxing decision is "rolled +back". This is done by the 'positiveTopBudget' guard. + +There's a bit of complication as a result of handling unboxed tuples correctly; +specifically, handling nested unboxed tuples. Consider (#21737) + + unboxed :: (Int, Int) -> (# Int, (# Int, Int, Int #) #) -> Int + unboxed (a,b) (# c, (# d, e, f #) #) = a + b + c + d + e + f + +Recall that unboxed tuples will be flattened to individual arguments during +unarisation. Here, `unboxed` will have 5 arguments at runtime because of the +nested unboxed tuple, which will be flattened to 4 args. So it's best to leave +`(a,b)` boxed (because we already are above our arg threshold), but unbox `c` +through `f` because that doesn't increase the number of args post unarisation. + +Note that the challenge is that syntactically, `(# d, e, f #)` occurs in a +deeper layer than `(a, b)`. Treating unboxed tuples as a regular data type, we'd +make the same unboxing decisions as for `boxed` above; although our starting +budget is 5 (Here, the number of args is greater than -fmax-worker-args), it's +not enough to unbox the triple (we'd finish with budget -1). So we'd unbox `a` +through `c`, but not `d` through `f`, which is silly, because then we'd end up +having 6 arguments at runtime, of which `d` through `f` weren't unboxed. + +Hence we pretend that the fields of unboxed tuples appear in the same budget +layer as the tuple itself. For example at the top-level, `(# x,y #)` is to be +treated just like two arguments `x` and `y`. +Of course, for that to work, our budget calculations must initialise +'max_wkr_args' to 5, based on the 'unariseArity' of each Core arg: That would be +1 for the pair and 4 for the unboxed pair. Then when we decide whether to unbox +the unboxed pair, we *directly* recurse into the fields, spending our budget +on retaining `c` and (after recursing once more) `d` through `f` as arguments, +depleting our budget completely in the first layer. Pictorially: + + 5 ~> ][ (a,b) -4~> ][ (# c, ... #) + ][ {{ | | }} ][ c -3~> ][ (# d, e, f #) + ][ {{ | +-------+ }} ][ | ][ d -2~> ][ e -1~> ][ f -0~> + ][ {{ | | }} ][ | ][ | ][ | ][ | + ][ {{ v v }} ][ v ][ v ][ v ][ v + 0 ~> ][ {{ +1~> a -0~> ][ b -(-1)~> }} ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> + +As you can see, we have no budget left to justify unboxing `(a,b)` on the second +layer, which is good, because it would increase the number of args. Also note +that we can still unbox `c` through `f` in this layer, because doing so has a +net zero effect on budget. + +Note [The OPAQUE pragma and avoiding the reboxing of arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In https://gitlab.haskell.org/ghc/ghc/-/issues/13143 it was identified that when +a function 'f' with a NOINLINE pragma is W/W transformed, then the worker for +'f' should get the NOINLINE annotation, while the wrapper /should/ be inlined. + +That's because if the wrapper for 'f' had stayed NOINLINE, then any worker of a +W/W-transformed /caller of/ 'f' would immediately rebox any unboxed arguments +that is applied to the wrapper of 'f'. When the wrapper is inlined, that kind of +reboxing does not happen. + +But now we have functions with OPAQUE pragmas, which by definition +(See Note [OPAQUE pragma]) do not get W/W-transformed. So in order to avoid +reboxing workers of any W/W-transformed /callers of/ 'f' we need to strip all +boxity information from 'f' in the demand analysis. This will inform the +W/W-transformation code that boxed arguments of 'f' must definitely be passed +along in boxed form and as such dissuade the creation of reboxing workers. +-} + +-- | How many registers does this type take after unarisation? +unariseArity :: Type -> Arity +unariseArity ty = length (typePrimRep ty) + +data Budgets = MkB !Arity Budgets -- An infinite list of arity budgets + +earnTopBudget :: Budgets -> Budgets +earnTopBudget (MkB n bg) = MkB (n+1) bg + +spendTopBudget :: Arity -> Budgets -> Budgets +spendTopBudget m (MkB n bg) = MkB (n-m) bg + +positiveTopBudget :: Budgets -> Bool +positiveTopBudget (MkB n _) = n >= 0 + +finaliseArgBoxities :: AnalEnv -> Id -> Arity + -> [Demand] -> Divergence + -> CoreExpr -> ([Demand], CoreExpr) +-- POSTCONDITION: +-- If: (dmds', rhs') = finaliseArgBoxitities ... dmds .. rhs +-- Then: +-- dmds' is the same as dmds (including length), except for boxity info +-- rhs' is the same as rhs, except for dmd info on lambda binders +-- NB: For join points, length dmds might be greater than ww_arity +finaliseArgBoxities env fn ww_arity arg_dmds div rhs + + -- Check for an OPAQUE function: see Note [OPAQUE pragma] + -- In that case, trim off all boxity info from argument demands + -- and demand info on lambda binders + -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] + | isOpaquePragma (idInlinePragma fn) + , let trimmed_arg_dmds = map trimBoxity arg_dmds + = (trimmed_arg_dmds, set_lam_dmds trimmed_arg_dmds rhs) + + -- Check that we have enough visible binders to match the + -- ww arity; if not, we won't do worker/wrapper + -- This happens if we have simply {f = g} or a PAP {f = h 13} + -- we simply want to give f the same demand signature as g + -- How can such bindings arise? Perhaps from {-# NOLINE[2] f #-}, + -- or if the call to `f` is currently not-applied (map f xs). + -- It's a bit of a corner case. Anyway for now we pass on the + -- unadulterated demands from the RHS, without any boxity trimming. + | ww_arity > count isId bndrs + = (arg_dmds, rhs) + + -- The normal case + | otherwise + = -- pprTrace "finaliseArgBoxities" ( + -- vcat [text "function:" <+> ppr fn + -- , text "max" <+> ppr max_wkr_args + -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs)) + -- , text "dmds after: " <+> ppr arg_dmds' ]) $ + (arg_dmds', set_lam_dmds arg_dmds' rhs) + -- set_lam_dmds: we must attach the final boxities to the lambda-binders + -- of the function, both because that's kosher, and because CPR analysis + -- uses the info on the binders directly. + where + opts = ae_opts env + (bndrs, _body) = collectBinders rhs + -- NB: in the interesting code path, count isId bndrs >= ww_arity + + arg_triples :: [(Type, StrictnessMark, Demand)] + arg_triples = take ww_arity $ + [ (idType bndr, NotMarkedStrict, get_dmd bndr) + | bndr <- bndrs, isRuntimeVar bndr ] + + arg_dmds' = ww_arg_dmds ++ map trimBoxity (drop ww_arity arg_dmds) + -- If ww_arity < length arg_dmds, the leftover ones + -- will not be w/w'd, so trimBoxity them + -- See Note [Worker/wrapper arity and join points] point (3) + + -- This is the key line, which uses almost-circular programming + -- The remaining budget from one layer becomes the initial + -- budget for the next layer down. See Note [Worker argument budget] + (remaining_budget, ww_arg_dmds) = go_args (MkB max_wkr_args remaining_budget) arg_triples + unarise_arity = sum [ unariseArity (idType b) | b <- bndrs, isId b ] + max_wkr_args = dmd_max_worker_args opts `max` unarise_arity + -- This is the budget initialisation step of + -- Note [Worker argument budget] + + get_dmd :: Id -> Demand + get_dmd bndr + | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions], + | otherwise = dmd -- case (B) + where + dmd = idDemandInfo bndr + + -- is_bot_fn: see Note [Boxity for bottoming functions] + is_bot_fn = div == botDiv + + go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand]) + go_args bg triples = mapAccumL go_arg bg triples + + go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand) + go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _)) + = case wantToUnboxArg env ty str_mark dmd of + DropAbsent -> (bg, dmd) + + DontUnbox | is_bot_fn, isTyVarTy ty -> (retain_budget, dmd) + | otherwise -> (retain_budget, trimBoxity dmd) + -- If bot: Keep deep boxity even though WW won't unbox + -- See Note [Boxity for bottoming functions] case (A) + -- trimBoxity: see Note [No lazy, Unboxed demands in demand signature] + where + retain_budget = spendTopBudget (unariseArity ty) bg + -- spendTopBudget: spend from our budget the cost of the + -- retaining the arg + -- The unboxed case does happen here, for example + -- app g x = g x :: (# Int, Int #) + -- here, `x` is used `L`azy and thus Boxed + + DoUnbox triples + | isUnboxedTupleType ty + , (bg', dmds') <- go_args bg triples + -> (bg', n :* (mkProd Unboxed $! dmds')) + -- See Note [Worker argument budget] + -- unboxed tuples are always unboxed, deeply + -- NB: Recurse with bg, *not* bg_inner! The unboxed fields + -- are at the same budget layer. + + | isUnboxedSumType ty + -> pprPanic "Unboxing through unboxed sum" (ppr fn <+> ppr ty) + -- We currently don't return DoUnbox for unboxed sums. + -- But hopefully we will at some point. When that happens, + -- it would still be impossible to predict the effect + -- of dropping absent fields and unboxing others on the + -- unariseArity of the sum without losing sanity. + -- We could overwrite bg_top with the one from + -- retain_budget while still unboxing inside the alts as in + -- the tuple case for a conservative solution, though. + + | otherwise + -> (spendTopBudget 1 (MkB bg_top final_bg_inner), final_dmd) + where + (bg_inner', dmds') = go_args (earnTopBudget bg_inner) triples + -- earnTopBudget: give back the cost of retaining the + -- arg we are insted unboxing. + dmd' = n :* (mkProd Unboxed $! dmds') + ~(final_bg_inner, final_dmd) -- "~": This match *must* be lazy! + | positiveTopBudget bg_inner' = (bg_inner', dmd') + | otherwise = (bg_inner, trimBoxity dmd) + + set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr + -- Attach the demands to the outer lambdas of this expression + set_lam_dmds (dmd:dmds) (Lam v e) + | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e) + | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e) + set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co + -- This case happens for an OPAQUE function, which may look like + -- f = (\x y. blah) |> co + -- We give it strictness but no boxity (#22502) + set_lam_dmds _ e = e + -- In the OPAQUE case, the list of demands at this point might be + -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997). + +finaliseLetBoxity + :: AnalEnv + -> Type -- ^ Type of the let-bound Id + -> Demand -- ^ How the Id is used + -> Demand +-- See Note [Finalising boxity for let-bound Ids] +-- This function is like finaliseArgBoxities, but much simpler because +-- it has no "budget". It simply unboxes strict demands, and stops +-- when it reaches a lazy one. +finaliseLetBoxity env ty dmd + = go (ty, NotMarkedStrict, dmd) + where + go :: (Type,StrictnessMark,Demand) -> Demand + go (ty, str, dmd@(n :* _)) = + case wantToUnboxArg env ty str dmd of + DropAbsent -> dmd + DontUnbox -> trimBoxity dmd + DoUnbox triples -> n :* (mkProd Unboxed $! map go triples) + +wantToUnboxArg :: AnalEnv -> Type -> StrictnessMark -> Demand + -> UnboxingDecision [(Type, StrictnessMark, Demand)] +wantToUnboxArg env ty str_mark dmd@(n :* _) + = case canUnboxArg (ae_fam_envs env) ty dmd of + DropAbsent -> DropAbsent + DontUnbox -> DontUnbox + + DoUnbox (DataConPatContext{ dcpc_dc = dc + , dcpc_tc_args = tc_args + , dcpc_args = dmds }) + -- OK, so we /can/ unbox it; but do we /want/ to? + | not (isStrict n || isMarkedStrict str_mark) -- Don't unbox a lazy field + -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal + -> DontUnbox + + | DefinitelyRecursive <- ae_rec_dc env dc + -- See Note [Which types are unboxed?] + -- and Note [Demand analysis for recursive data constructors] + -> DontUnbox + + | otherwise -- Bad cases dealt with: we want to unbox! + -> DoUnbox (zip3 (dubiousDataConInstArgTys dc tc_args) + (dataConRepStrictness dc) + dmds) + +{- ********************************************************************* +* * + Fixpoints +* * +********************************************************************* -} + +-- Recursive bindings +dmdFix :: TopLevelFlag + -> AnalEnv -- Does not include bindings for this binding + -> SubDemand + -> [(Id,CoreExpr)] + -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info +dmdFix top_lvl env let_dmd orig_pairs + = loop 1 initial_pairs + where + opts = ae_opts env + -- See Note [Initialising strictness] + initial_pairs | ae_virgin env = [(setIdDmdAndBoxSig opts id botSig, rhs) | (id, rhs) <- orig_pairs ] + | otherwise = orig_pairs + + -- If fixed-point iteration does not yield a result we use this instead + -- See Note [Safe abortion in the fixed-point iteration] + abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)]) + abort = (env, weak_fv', zapped_pairs) + where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs) + -- Note [Lazy and unleashable free variables] + weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs' + weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs + zapped_pairs = zapIdDmdSig pairs' + + -- The fixed-point varies the idDmdSig field of the binders, and terminates if that + -- annotation does not change any more. + loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) + loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) + -- | (id,_) <- pairs]) $ + loop' n pairs + + loop' n pairs + | found_fixpoint = (final_anal_env, weak_fv, pairs') + | n == 10 = abort + | otherwise = loop (n+1) pairs' + where + found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs + first_round = n == 1 + (weak_fv, pairs') = step first_round pairs + final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') + + step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)]) + step first_round pairs = (weak_fv, pairs') + where + -- In all but the first iteration, delete the virgin flag + start_env | first_round = env + | otherwise = nonVirgin env + + start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) + + !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs + -- mapAccumL: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + + my_downRhs (env, weak_fv) (id,rhs) + = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ + ((env', weak_fv'), (id', rhs')) + where + !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs + !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 + + zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] + zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ] + +{- Note [Safe abortion in the fixed-point iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Fixed-point iteration may fail to terminate. But we cannot simply give up and +return the environment and code unchanged! We still need to do one additional +round, for two reasons: + + * To get information on used free variables (both lazy and strict!) + (see Note [Lazy and unleashable free variables]) + * To ensure that all expressions have been traversed at least once, and any left-over + strictness annotations have been updated. + +This final iteration does not add the variables to the strictness signature +environment, which effectively assigns them 'nopSig' (see "getStrictness") + +Note [Trimming a demand to a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are two reasons we sometimes trim a demand to match a type. + 1. GADTs + 2. Recursive products and widening + +More on both below. But the bottom line is: we really don't want to +have a binder whose demand is more deeply-nested than its type +"allows". So in findBndrDmd we call trimToType and findTypeShape to +trim the demand on the binder to a form that matches the type + +Now to the reasons. For (1) consider + f :: a -> Bool + f x = case ... of + A g1 -> case (x |> g1) of (p,q) -> ... + B -> error "urk" + +where A,B are the constructors of a GADT. We'll get a 1P(L,L) demand +on x from the A branch, but that's a stupid demand for x itself, which +has type 'a'. Indeed we get ASSERTs going off (notably in +splitUseProdDmd, #8569). + +For (2) consider + data T = MkT Int T -- A recursive product + f :: Int -> T -> Int + f 0 _ = 0 + f _ (MkT n t) = f n t + +Here f is lazy in T, but its *usage* is infinite: P(L,P(L,P(L, ...))). +Notice that this happens because T is a product type, and is recursive. +If we are not careful, we'll fail to iterate to a fixpoint in dmdFix, +and bale out entirely, which is inefficient and over-conservative. + +Worse, as we discovered in #18304, the size of the usages we compute +can grow /exponentially/, so even 10 iterations costs far too much. +Especially since we then discard the result. + +To avoid this we use the same findTypeShape function as for (1), but +arrange that it trims the demand if it encounters the same type constructor +twice (or three times, etc). We use our standard RecTcChecker mechanism +for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape. + +This is usually call "widening". We could do it just in dmdFix, but +since are doing this findTypeShape business /anyway/ because of (1), +and it has all the right information to hand, it's extremely +convenient to do it there. + +-} + +{- ********************************************************************* +* * + Strictness signatures and types +* * +********************************************************************* -} + +noArgsDmdType :: DmdEnv -> DmdType +noArgsDmdType dmd_env = DmdType dmd_env [] + +coercionDmdEnv :: Coercion -> DmdEnv +coercionDmdEnv co = coercionsDmdEnv [co] + +coercionsDmdEnv :: [Coercion] -> DmdEnv +coercionsDmdEnv cos + = mkTermDmdEnv $ mapVarEnv (const topDmd) $ getUniqSet $ coVarsOfCos cos + -- The VarSet from coVarsOfCos is really a VarEnv Var + +addVarDmd :: DmdType -> Var -> Demand -> DmdType +addVarDmd (DmdType fv ds) var dmd + = DmdType (addVarDmdEnv fv var dmd) ds + +addWeakFVs :: DmdType -> WeakDmds -> DmdType +addWeakFVs dmd_ty weak_fvs + = dmd_ty `plusDmdType` mkTermDmdEnv weak_fvs + -- Using plusDmdType (rather than just plus'ing the envs) + -- is vital. Consider + -- let f = \x -> (x,y) + -- in error (f 3) + -- Here, y is treated as a lazy-fv of f, but we must `plusDmd` that L + -- demand with the bottom coming up from 'error' + -- + -- I got a loop in the fixpointer without this, due to an interaction + -- with the weak_fv filtering in dmdAnalRhsSig. Roughly, it was + -- letrec f n x + -- = letrec g y = x `fatbar` + -- letrec h z = z + ...g... + -- in h (f (n-1) x) + -- in ... + -- In the initial iteration for f, f=Bot + -- Suppose h is found to be strict in z, but the occurrence of g in its RHS + -- is lazy. Now consider the fixpoint iteration for g, esp the demands it + -- places on its free variables. Suppose it places none. Then the + -- x `fatbar` ...call to h... + -- will give a x->V demand for x. That turns into a L demand for x, + -- which floats out of the defn for h. Without the modifyEnv, that + -- L demand doesn't get both'd with the Bot coming up from the inner + -- call to f. So we just get an L demand for x for g. + +setBndrsDemandInfo :: HasDebugCallStack => [Var] -> [Demand] -> [Var] +setBndrsDemandInfo (b:bs) ds + | isTyVar b = b : setBndrsDemandInfo bs ds +setBndrsDemandInfo (b:bs) (d:ds) = + let !new_info = setIdDemandInfo b d + !vars = setBndrsDemandInfo bs ds + in new_info : vars +setBndrsDemandInfo [] ds = assert (null ds) [] +setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) + +annotateLamIdBndr :: AnalEnv + -> DmdType -- Demand type of body + -> Id -- Lambda binder + -> WithDmdType Id -- Demand type of lambda + -- and binder annotated with demand + +annotateLamIdBndr env dmd_ty id +-- For lambdas we add the demand to the argument demands +-- Only called for Ids + = assert (isId id) $ + -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ + WithDmdType main_ty new_id + where + new_id = setIdDemandInfo id dmd + main_ty = addDemand dmd dmd_ty' + WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id + +{- Note [NOINLINE and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point we disabled strictness for NOINLINE functions, on the +grounds that they should be entirely opaque. But that lost lots of +useful semantic strictness information, so now we analyse them like +any other function, and pin strictness information on them. + +That in turn forces us to worker/wrapper them; see +Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + + +Note [Lazy and unleashable free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We put the strict and once-used FVs in the DmdType of the Id, so +that at its call sites we unleash demands on its strict fvs. +An example is 'roll' in imaginary/wheel-sieve2 +Something like this: + roll x = letrec + go y = if ... then roll (x-1) else x+1 + in + go ms +We want to see that roll is strict in x, which is because +go is called. So we put the DmdEnv for x in go's DmdType. + +Another example: + + f :: Int -> Int -> Int + f x y = let t = x+1 + h z = if z==0 then t else + if z==1 then x+1 else + x + h (z-1) + in h y + +Calling h does indeed evaluate x, but we can only see +that if we unleash a demand on x at the call site for t. + +Incidentally, here's a place where lambda-lifting h would +lose the cigar --- we couldn't see the joint strictness in t/x + + ON THE OTHER HAND + +We don't want to put *all* the fv's from the RHS into the +DmdType. Because + + * it makes the strictness signatures larger, and hence slows down fixpointing + +and + + * it is useless information at the call site anyways: + For lazy, used-many times fv's we will never get any better result than + that, no matter how good the actual demand on the function at the call site + is (unless it is always absent, but then the whole binder is useless). + +Therefore we exclude lazy multiple-used fv's from the environment in the +DmdType. + +But now the signature lies! (Missing variables are assumed to be absent.) To +make up for this, the code that analyses the binding keeps the demand on those +variable separate (usually called "weak_fv") and adds it to the demand of the +whole binding later. + +What if we decide _not_ to store a strictness signature for a binding at all, as +we do when aborting a fixed-point iteration? The we risk losing the information +that the strict variables are being used. In that case, we take all free variables +mentioned in the (unsound) strictness signature, conservatively approximate the +demand put on them (topDmd), and add that to the "weak_fv" returned by "dmdFix". + + +************************************************************************ +* * +\subsection{Strictness signatures} +* * +************************************************************************ +-} + + +data AnalEnv = AE + { ae_opts :: !DmdAnalOpts + -- ^ Analysis options + , ae_sigs :: !SigEnv + , ae_virgin :: !Bool + -- ^ True on first iteration only. See Note [Initialising strictness] + , ae_fam_envs :: !FamInstEnvs + , ae_rec_dc :: DataCon -> IsRecDataConResult + -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon' + } + + -- We use the se_env to tell us whether to + -- record info about a variable in the DmdEnv + -- We do so if it's a LocalId, but not top-level + -- + -- The DmdEnv gives the demand on the free vars of the function + -- when it is given enough args to satisfy the strictness signature + +type SigEnv = VarEnv (DmdSig, TopLevelFlag) + +instance Outputable AnalEnv where + ppr env = text "AE" <+> braces (vcat + [ text "ae_virgin =" <+> ppr (ae_virgin env) + , text "ae_sigs =" <+> ppr (ae_sigs env) + ]) + +emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv +emptyAnalEnv opts fam_envs + = AE { ae_opts = opts + , ae_sigs = emptySigEnv + , ae_virgin = True + , ae_fam_envs = fam_envs + , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs 3) + } + +-- | Unset the 'dmd_strict_dicts' flag if any of the given bindings is a DFun +-- binding. Part of the mechanism that detects +-- Note [Do not strictify a DFun's parameter dictionaries]. +enterDFun :: CoreBind -> AnalEnv -> AnalEnv +enterDFun bind env + | any isDFunId (bindersOf bind) + = env { ae_opts = (ae_opts env) { dmd_strict_dicts = False } } + | otherwise + = env + +emptySigEnv :: SigEnv +emptySigEnv = emptyVarEnv + +-- | Extend an environment with the strictness sigs attached to the Ids +extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv +extendAnalEnvs top_lvl env vars + = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } + +extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv +extendSigEnvs top_lvl sigs vars + = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] + +extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv +extendAnalEnv top_lvl env var sig + = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } + +extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv +extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) + +lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag) +lookupSigEnv env id = lookupVarEnv (ae_sigs env) id + +addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv +addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id } + +addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv +addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids } + +nonVirgin :: AnalEnv -> AnalEnv +nonVirgin env = env { ae_virgin = False } + +findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] +-- Return the demands on the Ids in the [Var] +findBndrsDmds env dmd_ty bndrs + = go dmd_ty bndrs + where + go dmd_ty [] = WithDmdType dmd_ty [] + go dmd_ty (b:bs) + | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs + WithDmdType dmd_ty2 dmd = findBndrDmd env dmd_ty1 b + in WithDmdType dmd_ty2 (dmd : dmds) + | otherwise = go dmd_ty bs + +findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand +-- See Note [Trimming a demand to a type] +findBndrDmd env dmd_ty id + = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ + WithDmdType dmd_ty' dmd' + where + dmd' = strictify $ + trimToType starting_dmd (findTypeShape fam_envs id_ty) + + (dmd_ty', starting_dmd) = peelFV dmd_ty id + + id_ty = idType id + + strictify dmd + -- See Note [Making dictionary parameters strict] + -- and Note [Do not strictify a DFun's parameter dictionaries] + | dmd_strict_dicts (ae_opts env) + = strictifyDictDmd id_ty dmd + | otherwise + = dmd + + fam_envs = ae_fam_envs env + +{- Note [Bringing a new variable into scope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = blah + g = ...(\f. ...f...)... + +In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`, +not the top-level `f` (which will be in `ae_sigs`). So it's very important +to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`. +Otherwise chaos results (#22718). + +Note [Making dictionary parameters strict] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries. Why? + +* Generally CBV is more efficient. + +* A datatype dictionary is always non-bottom and never takes much work to + compute. E.g. a DFun from an instance decl always returns a dictionary + record immediately. See DFunUnfolding in CoreSyn. + See also Note [Recursive superclasses] in TcInstDcls. + +See #17758 for more background and perf numbers. + +Wrinkles: + +* A newtype dictionary is *not* always non-bottom. E.g. + class C a where op :: a -> a + instance C Int where op = error "urk" + Now a value of type (C Int) is just a newtype wrapper (a cast) around + the error thunk. Don't strictify these! + +* Strictifying DFuns risks destroying the invariant that DFuns never take much + work to compute, so we don't do it. + See Note [Do not strictify a DFun's parameter dictionaries] for details. + +* Although worker/wrapper *could* unbox strictly used dictionaries, we do not do + so; see Note [Do not unbox class dictionaries]. + +The implementation is extremely simple: just make the strictness +analyser strictify the demand on a dictionary binder in +'findBndrDmd' if the binder does not belong to a DFun. + +Note [Do not strictify a DFun's parameter dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker can tie recursive knots involving (non-recursive) DFuns, so +we must not strictify a DFun's parameter dictionaries (#22549). +T22549 has an example involving undecidable instances that <>s when we +strictify the DFun of, e.g., `$fEqSeqT`: + + Main.$fEqSeqT + = \@m @a ($dEq :: Eq (m (ViewT m a))) ($dMonad :: Monad m) -> + GHC.Classes.C:Eq @(SeqT m a) ($c== @m @a $dEq $dMonad) + ($c/= @m @a $dEq $dMonad) + + Rec { + $dEq_a = Main.$fEqSeqT @Identity @Int $dEq_b Main.$fMonadIdentity + $dEq_b = ... $dEq_a ... + } + +If we make `$fEqSeqT` strict in `$dEq`, we'll collapse the Rec group into a +giant, <>ing thunk. + +To prevent that, we never strictify dictionary params when inside a DFun. +That is implemented by unsetting 'dmd_strict_dicts' when entering a DFun. + +See also Note [Speculative evaluation] in GHC.CoreToStg.Prep which has a rather +similar example in #20836. We may never speculate *arguments* of (recursive) +DFun calls, likewise we should not mark *formal parameters* of recursive DFuns +as strict. + +Note [Initialising strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See section 9.2 (Finding fixpoints) of the paper. + +Our basic plan is to initialise the strictness of each Id in a +recursive group to "bottom", and find a fixpoint from there. However, +this group B might be inside an *enclosing* recursive group A, in +which case we'll do the entire fixpoint shebang on for each iteration +of A. This can be illustrated by the following example: + +Example: + + f [] = [] + f (x:xs) = let g [] = f xs + g (y:ys) = y+1 : g ys + in g (h x) + +At each iteration of the fixpoint for f, the analyser has to find a +fixpoint for the enclosed function g. In the meantime, the demand +values for g at each iteration for f are *greater* than those we +encountered in the previous iteration for f. Therefore, we can begin +the fixpoint for g not with the bottom value but rather with the +result of the previous analysis. I.e., when beginning the fixpoint +process for g, we can start from the demand signature computed for g +previously and attached to the binding occurrence of g. + +To speed things up, we initialise each iteration of A (the enclosing +one) from the result of the last one, which is neatly recorded in each +binder. That way we make use of earlier iterations of the fixpoint +algorithm. (Cunning plan.) + +But on the *first* iteration we want to *ignore* the current strictness +of the Id, and start from "bottom". Nowadays the Id can have a current +strictness, because interface files record strictness for nested bindings. +To know when we are in the first iteration, we look at the ae_virgin +field of the AnalEnv. + + +Note [Final Demand Analyser run] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some of the information that the demand analyser determines is not always +preserved by the simplifier. For example, the simplifier will happily rewrite + \y [Demand=MU] let x = y in x + x +to + \y [Demand=MU] y + y +which is quite a lie: Now y occurs more than just once. + +The once-used information is (currently) only used by the code +generator, though. So: + + * We zap the used-once info in the worker-wrapper; + see Note [Zapping Used Once info in WorkWrap] in + GHC.Core.Opt.WorkWrap. + If it's not reliable, it's better not to have it at all. + + * Just before TidyCore, we add a pass of the demand analyser, + but WITHOUT subsequent worker/wrapper and simplifier, + right before TidyCore. See SimplCore.getCoreToDo. + + This way, correct information finds its way into the module interface + (strictness signatures!) and the code generator (single-entry thunks!) + +Note that, in contrast, the single-call information (C(M,..)) /can/ be +relied upon, as the simplifier tends to be very careful about not +duplicating actual function calls. + +Also see #11731. + +Note [Space Leaks in Demand Analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticket: #15455 +MR: !5399 + +In the past the result of demand analysis was not forced until the whole module +had finished being analysed. In big programs, this led to a big build up of thunks +which were all ultimately forced at the end of the analysis. + +This was because the return type of the analysis was a lazy pair: + dmdAnal :: AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) +To avoid space leaks we added extra bangs to evaluate the DmdType component eagerly; but +we were never sure we had added enough. +The easiest way to systematically fix this was to use a strict pair type for the +return value of the analysis so that we can be more confident that the result +is incrementally computed rather than all at the end. + +A second, only loosely related point is that +the updating of Ids was not forced because the result of updating +an Id was placed into a lazy field in CoreExpr. This meant that until the end of +demand analysis, the unforced Ids would retain the DmdEnv which the demand information +was fetch from. Now we are quite careful to force Ids before putting them +back into core expressions so that we can garbage-collect the environments more eagerly. +For example see the `Case` branch of `dmdAnal'` where `case_bndr'` is forced +or `dmdAnalSumAlt`. + +The net result of all these improvements is the peak live memory usage of compiling +jsaddle-dom decreases about 4GB (from 6.5G to 2.5G). A bunch of bytes allocated benchmarks also +decrease because we allocate a lot fewer thunks which we immediately overwrite and +also runtime for the pass is faster! Overall, good wins. + +-} diff --git a/GHC/Core/Opt/Exitify.hs b/GHC/Core/Opt/Exitify.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Exitify.hs @@ -0,0 +1,503 @@ +module GHC.Core.Opt.Exitify ( exitifyProgram ) where + +{- +Note [Exitification] +~~~~~~~~~~~~~~~~~~~~ + +This module implements Exitification. The goal is to pull as much code out of +recursive functions as possible, as the simplifier is better at inlining into +call-sites that are not in recursive functions. + +Example: + + let t = foo bar + joinrec go 0 x y = t (x*x) + go (n-1) x y = jump go (n-1) (x+y) + in … + +We’d like to inline `t`, but that does not happen: Because t is a thunk and is +used in a recursive function, doing so might lose sharing in general. In +this case, however, `t` is on the _exit path_ of `go`, so called at most once. +How do we make this clearly visible to the simplifier? + +A code path (i.e., an expression in a tail-recursive position) in a recursive +function is an exit path if it does not contain a recursive call. We can bind +this expression outside the recursive function, as a join-point. + +Example result: + + let t = foo bar + join exit x = t (x*x) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +Now `t` is no longer in a recursive function, and good things happen! +-} + +import GHC.Prelude +import GHC.Builtin.Uniques +import GHC.Core +import GHC.Core.Utils +import GHC.Core.FVs +import GHC.Core.Type + +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Basic( JoinPointHood(..) ) + +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Misc( mapSnd ) + +import GHC.Data.FastString + +import Data.Bifunctor +import Control.Monad + +-- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them. +-- The really interesting function is exitifyRec +exitifyProgram :: CoreProgram -> CoreProgram +exitifyProgram binds = map goTopLvl binds + where + goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e) + goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs) + -- Top-level bindings are never join points + + in_scope_toplvl = emptyInScopeSet `extendInScopeSetBndrs` binds + + go :: InScopeSet -> CoreExpr -> CoreExpr + go _ e@(Var{}) = e + go _ e@(Lit {}) = e + go _ e@(Type {}) = e + go _ e@(Coercion {}) = e + go in_scope (Cast e' c) = Cast (go in_scope e') c + go in_scope (Tick t e') = Tick t (go in_scope e') + go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2) + + go in_scope (Lam v e') + = Lam v (go in_scope' e') + where in_scope' = in_scope `extendInScopeSet` v + + go in_scope (Case scrut bndr ty alts) + = Case (go in_scope scrut) bndr ty (map go_alt alts) + where + in_scope1 = in_scope `extendInScopeSet` bndr + go_alt (Alt dc pats rhs) = Alt dc pats (go in_scope' rhs) + where in_scope' = in_scope1 `extendInScopeSetList` pats + + go in_scope (Let (NonRec bndr rhs) body) + = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body) + where + in_scope' = in_scope `extendInScopeSet` bndr + + go in_scope (Let (Rec pairs) body) + | is_join_rec = mkLets (exitifyRec in_scope' pairs') body' + | otherwise = Let (Rec pairs') body' + where + is_join_rec = any (isJoinId . fst) pairs + in_scope' = in_scope `extendInScopeSetBind` (Rec pairs) + pairs' = mapSnd (go in_scope') pairs + body' = go in_scope' body + + +-- | State Monad used inside `exitify` +type ExitifyM = State [(JoinId, CoreExpr)] + +-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as +-- join-points outside the joinrec. +exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] +exitifyRec in_scope pairs + = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs'] + where + -- We need the set of free variables of many subexpressions here, so + -- annotate the AST with them + -- see Note [Calculating free variables] + ann_pairs = map (second freeVars) pairs + + -- Which are the recursive calls? + recursive_calls = mkVarSet $ map fst pairs + + (pairs',exits) = (`runState` []) $ + forM ann_pairs $ \(x,rhs) -> do + -- go past the lambdas of the join point + let (args, body) = collectNAnnBndrs (idJoinArity x) rhs + body' <- go args body + let rhs' = mkLams args body' + return (x, rhs') + + --------------------- + -- 'go' is the main working function. + -- It goes through the RHS (tail-call positions only), + -- checks if there are no more recursive calls, if so, abstracts over + -- variables bound on the way and lifts it out as a join point. + -- + -- ExitifyM is a state monad to keep track of floated binds + go :: [Var] -- Variables that are in-scope here, but + -- not in scope at the joinrec; that is, + -- we must potentially abstract over them. + -- Invariant: they are kept in dependency order + -> CoreExprWithFVs -- Current expression in tail position + -> ExitifyM CoreExpr + + -- We first look at the expression (no matter what it shape is) + -- and determine if we can turn it into a exit join point + go captured ann_e + | -- An exit expression has no recursive calls + let fvs = dVarSetToVarSet (freeVarsOf ann_e) + , disjointVarSet fvs recursive_calls + = go_exit captured (deAnnotate ann_e) fvs + + -- We could not turn it into a exit join point. So now recurse + -- into all expression where eligible exit join points might sit, + -- i.e. into all tail-call positions: + + -- Case right hand sides are in tail-call position + go captured (_, AnnCase scrut bndr ty alts) = do + alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do + rhs' <- go (captured ++ [bndr] ++ pats) rhs + return (Alt dc pats rhs') + return $ Case (deAnnotate scrut) bndr ty alts' + + go captured (_, AnnLet ann_bind body) + -- join point, RHS and body are in tail-call position + | AnnNonRec j rhs <- ann_bind + , JoinPoint join_arity <- idJoinPointHood j + = do let (params, join_body) = collectNAnnBndrs join_arity rhs + join_body' <- go (captured ++ params) join_body + let rhs' = mkLams params join_body' + body' <- go (captured ++ [j]) body + return $ Let (NonRec j rhs') body' + + -- rec join point, RHSs and body are in tail-call position + | AnnRec pairs <- ann_bind + , isJoinId (fst (head pairs)) + = do let js = map fst pairs + pairs' <- forM pairs $ \(j,rhs) -> do + let join_arity = idJoinArity j + (params, join_body) = collectNAnnBndrs join_arity rhs + join_body' <- go (captured ++ js ++ params) join_body + let rhs' = mkLams params join_body' + return (j, rhs') + body' <- go (captured ++ js) body + return $ Let (Rec pairs') body' + + -- normal Let, only the body is in tail-call position + | otherwise + = do body' <- go (captured ++ bindersOf bind ) body + return $ Let bind body' + where bind = deAnnBind ann_bind + + -- Cannot be turned into an exit join point, but also has no + -- tail-call subexpression. Nothing to do here. + go _ ann_e = return (deAnnotate ann_e) + + --------------------- + go_exit :: [Var] -- Variables captured locally + -> CoreExpr -- An exit expression + -> VarSet -- Free vars of the expression + -> ExitifyM CoreExpr + -- go_exit deals with a tail expression that is floatable + -- out as an exit point; that is, it mentions no recursive calls + go_exit captured e fvs + -- Do not touch an expression that is already a join jump where all arguments + -- are captured variables. See Note [Idempotency] + -- But _do_ float join jumps with interesting arguments. + -- See Note [Jumps can be interesting] + | (Var f, args) <- collectArgs e + , isJoinId f + , all isCapturedVarArg args + = return e + + -- Do not touch a boring expression (see Note [Interesting expression]) + | not is_interesting + = return e + + -- Cannot float out if local join points are used, as + -- we cannot abstract over them + | captures_join_points + = return e + + -- We have something to float out! + | otherwise + = do { -- Assemble the RHS of the exit join point + let rhs = mkLams abs_vars e + avoid = in_scope `extendInScopeSetList` captured + -- Remember this binding under a suitable name + ; v <- addExit avoid (length abs_vars) rhs + -- And jump to it from here + ; return $ mkVarApps (Var v) abs_vars } + + where + -- Used to detect exit expressions that are already proper exit jumps + isCapturedVarArg (Var v) = v `elem` captured + isCapturedVarArg _ = False + + -- An interesting exit expression has free, non-imported + -- variables from outside the recursive group + -- See Note [Interesting expression] + is_interesting = anyVarSet isLocalId $ + fvs `minusVarSet` mkVarSet captured + + -- The arguments of this exit join point + -- See Note [Picking arguments to abstract over] + abs_vars = snd $ foldr pick (fvs, []) captured + where + pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc) + | otherwise = (fvs', acc) + + -- We are going to abstract over these variables, so we must + -- zap any IdInfo they have; see #15005 + -- cf. GHC.Core.Opt.SetLevels.abstractVars + zap v | isId v = setIdInfo v vanillaIdInfo + | otherwise = v + + -- We cannot abstract over join points + captures_join_points = any isJoinId abs_vars + + +-- Picks a new unique, which is disjoint from +-- * the free variables of the whole joinrec +-- * any bound variables (captured) +-- * any exit join points created so far. +mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId +mkExitJoinId in_scope ty join_arity = do + fs <- get + let avoid = in_scope `extendInScopeSetList` (map fst fs) + `extendInScopeSet` exit_id_tmpl -- just cosmetics + return (uniqAway avoid exit_id_tmpl) + where + exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty + `asJoinId` join_arity + +addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId +addExit in_scope join_arity rhs = do + -- Pick a suitable name + let ty = exprType rhs + v <- mkExitJoinId in_scope ty join_arity + fs <- get + put ((v,rhs):fs) + return v + +{- +Note [Interesting expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not want this to happen: + + joinrec go 0 x y = x + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x = x + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +because the floated exit path (`x`) is simply a parameter of `go`; there are +not useful interactions exposed this way. + +Neither do we want this to happen + + joinrec go 0 x y = x+x + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x = x+x + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +where the floated expression `x+x` is a bit more complicated, but still not +interesting. + +Expressions are interesting when they move an occurrence of a variable outside +the recursive `go` that can benefit from being obviously called once, for example: + * a local thunk that can then be inlined (see example in Note [Exitification]) + * the parameter of a function, where the demand analyzer then can then + see that it is called at most once, and hence improve the function’s + strictness signature + +So we only hoist an exit expression out if it mentions at least one free, +non-imported variable. + +Note [Jumps can be interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A jump to a join point can be interesting, if its arguments contain free +non-exported variables (z in the following example): + + joinrec go 0 x y = jump j (x+z) + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x y = jump j (x+z) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + + +The join point itself can be interesting, even if none if its +arguments have free variables free in the joinrec. For example + + join j p = case p of (x,y) -> x+y + joinrec go 0 x y = jump j (x,y) + go (n-1) x y = jump go (n-1) (x+y) y + in … + +Here, `j` would not be inlined because we do not inline something that looks +like an exit join point (see Note [Do not inline exit join points]). But +if we exitify the 'jump j (x,y)' we get + + join j p = case p of (x,y) -> x+y + join exit x y = jump j (x,y) + joinrec go 0 x y = jump exit x y + go (n-1) x y = jump go (n-1) (x+y) y + in … + +and now 'j' can inline, and we get rid of the pair. Here's another +example (assume `g` to be an imported function that, on its own, +does not make this interesting): + + join j y = map f y + joinrec go 0 x y = jump j (map g x) + go (n-1) x y = jump go (n-1) (x+y) + in … + +Again, `j` would not be inlined because we do not inline something that looks +like an exit join point (see Note [Do not inline exit join points]). + +But after exitification we have + + join j y = map f y + join exit x = jump j (map g x) + joinrec go 0 x y = jump j (map g x) + go (n-1) x y = jump go (n-1) (x+y) + in … + +and now we can inline `j` and this will allow `map/map` to fire. + + +Note [Idempotency] +~~~~~~~~~~~~~~~~~~ + +We do not want this to happen, where we replace the floated expression with +essentially the same expression: + + join exit x = t (x*x) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x = t (x*x) + join exit' x = jump exit x + joinrec go 0 x y = jump exit' x + go (n-1) x y = jump go (n-1) (x+y) + in … + +So when the RHS is a join jump, and all of its arguments are captured variables, +then we leave it in place. + +Note that `jump exit x` in this example looks interesting, as `exit` is a free +variable. Therefore, idempotency does not simply follow from floating only +interesting expressions. + +Note [Calculating free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have two options where to annotate the tree with free variables: + + A) The whole tree. + B) Each individual joinrec as we come across it. + +Downside of A: We pay the price on the whole module, even outside any joinrecs. +Downside of B: We pay the price per joinrec, possibly multiple times when +joinrecs are nested. + +Further downside of A: If the exitify function returns annotated expressions, +it would have to ensure that the annotations are correct. + +We therefore choose B, and calculate the free variables in `exitify`. + + +Note [Do not inline exit join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + + let t = foo bar + join exit x = t (x*x) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +we do not want the simplifier to simply inline `exit` back in (which it happily +would). + +To prevent this, we need to recognize exit join points, and then disable +inlining. + +Exit join points, recognizable using `isExitJoinId` are join points with an +occurrence in a recursive group, and can be recognized (after the occurrence +analyzer ran!) using `isExitJoinId`. +This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`, +because the lambdas of a non-recursive join point are not considered for +`occ_in_lam`. For example, in the following code, `j1` is /not/ marked +occ_in_lam, because `j2` is called only once. + + join j1 x = x+1 + join j2 y = join j1 (y+2) + +To prevent inlining, we check for isExitJoinId +* In `preInlineUnconditionally` directly. +* In `simplLetUnfolding` we simply give exit join points no unfolding, which + prevents inlining in `postInlineUnconditionally` and call sites. + +Note [Placement of the exitification pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I (Joachim) experimented with multiple positions for the Exitification pass in +the Core2Core pipeline: + + A) Before the `simpl_phases` + B) Between the `simpl_phases` and the "main" simplifier pass + C) After demand_analyser + D) Before the final simplification phase + +Here is the table (this is without inlining join exit points in the final +simplifier run): + + Program | Allocs | Instrs + | ABCD.log A.log B.log C.log D.log | ABCD.log A.log B.log C.log D.log +----------------|---------------------------------------------------|------------------------------------------------- + fannkuch-redux | -99.9% +0.0% -99.9% -99.9% -99.9% | -3.9% +0.5% -3.0% -3.9% -3.9% + fasta | -0.0% +0.0% +0.0% -0.0% -0.0% | -8.5% +0.0% +0.0% -0.0% -8.5% + fem | 0.0% 0.0% 0.0% 0.0% +0.0% | -2.2% -0.1% -0.1% -2.1% -2.1% + fish | 0.0% 0.0% 0.0% 0.0% +0.0% | -3.1% +0.0% -1.1% -1.1% -0.0% + k-nucleotide | -91.3% -91.0% -91.0% -91.3% -91.3% | -6.3% +11.4% +11.4% -6.3% -6.2% + scs | -0.0% -0.0% -0.0% -0.0% -0.0% | -3.4% -3.0% -3.1% -3.3% -3.3% + simple | -6.0% 0.0% -6.0% -6.0% +0.0% | -3.4% +0.0% -5.2% -3.4% -0.1% + spectral-norm | -0.0% 0.0% 0.0% -0.0% +0.0% | -2.7% +0.0% -2.7% -5.4% -5.4% +----------------|---------------------------------------------------|------------------------------------------------- + Min | -95.0% -91.0% -95.0% -95.0% -95.0% | -8.5% -3.0% -5.2% -6.3% -8.5% + Max | +0.2% +0.2% +0.2% +0.2% +1.5% | +0.4% +11.4% +11.4% +0.4% +1.5% + Geometric Mean | -4.7% -2.1% -4.7% -4.7% -4.6% | -0.4% +0.1% -0.1% -0.3% -0.2% + +Position A is disqualified, as it does not get rid of the allocations in +fannkuch-redux. +Position A and B are disqualified because it increases instructions in k-nucleotide. +Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta. + +Assuming we have a budget of _one_ run of Exitification, then C wins (but we +could get more from running it multiple times, as seen in fish). + +Note [Picking arguments to abstract over] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When we create an exit join point, so we need to abstract over those of its +free variables that are be out-of-scope at the destination of the exit join +point. So we go through the list `captured` and pick those that are actually +free variables of the join point. + +We do not just `filter (`elemVarSet` fvs) captured`, as there might be +shadowing, and `captured` may contain multiple variables with the same Unique. I +these cases we want to abstract only over the last occurrence, hence the `foldr` +(with emphasis on the `r`). This is #15110. + +-} diff --git a/GHC/Core/Opt/FloatIn.hs b/GHC/Core/Opt/FloatIn.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/FloatIn.hs @@ -0,0 +1,867 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +************************************************************************ +* * +\section[FloatIn]{Floating Inwards pass} +* * +************************************************************************ + +The main purpose of @floatInwards@ is floating into branches of a +case, so that we don't allocate things, save them on the stack, and +then discover that they aren't needed in the chosen branch. +-} + + +{-# OPTIONS_GHC -fprof-auto #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Core.Opt.FloatIn ( floatInwards ) where + +import GHC.Prelude +import GHC.Platform + +import GHC.Core +import GHC.Core.Opt.Arity( isOneShotBndr ) +import GHC.Core.Make hiding ( wrapFloats ) +import GHC.Core.Utils +import GHC.Core.FVs +import GHC.Core.Type + +import GHC.Types.Basic ( RecFlag(..), isRec ) +import GHC.Types.Id ( idType, isJoinId, idJoinPointHood ) +import GHC.Types.Tickish +import GHC.Types.Var +import GHC.Types.Var.Set + +import GHC.Utils.Misc +import GHC.Utils.Panic.Plain + +import GHC.Utils.Outputable + +import Data.List ( mapAccumL ) + +{- +Top-level interface function, @floatInwards@. Note that we do not +actually float any bindings downwards from the top-level. +-} + +floatInwards :: Platform -> CoreProgram -> CoreProgram +floatInwards platform binds = map (fi_top_bind platform) binds + where + fi_top_bind platform (NonRec binder rhs) + = NonRec binder (fiExpr platform [] (freeVars rhs)) + fi_top_bind platform (Rec pairs) + = Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ] + + +{- +************************************************************************ +* * +\subsection{Mail from Andr\'e [edited]} +* * +************************************************************************ + +{\em Will wrote: What??? I thought the idea was to float as far +inwards as possible, no matter what. This is dropping all bindings +every time it sees a lambda of any kind. Help! } + +You are assuming we DO DO full laziness AFTER floating inwards! We +have to [not float inside lambdas] if we don't. + +If we indeed do full laziness after the floating inwards (we could +check the compilation flags for that) then I agree we could be more +aggressive and do float inwards past lambdas. + +Actually we are not doing a proper full laziness (see below), which +was another reason for not floating inwards past a lambda. + +This can easily be fixed. The problem is that we float lets outwards, +but there are a few expressions which are not let bound, like case +scrutinees and case alternatives. After floating inwards the +simplifier could decide to inline the let and the laziness would be +lost, e.g. + +\begin{verbatim} +let a = expensive ==> \b -> case expensive of ... +in \ b -> case a of ... +\end{verbatim} +The fix is +\begin{enumerate} +\item +to let bind the algebraic case scrutinees (done, I think) and +the case alternatives (except the ones with an +unboxed type)(not done, I think). This is best done in the +GHC.Core.Opt.SetLevels module, which tags things with their level numbers. +\item +do the full laziness pass (floating lets outwards). +\item +simplify. The simplifier inlines the (trivial) lets that were + created but were not floated outwards. +\end{enumerate} + +With the fix I think Will's suggestion that we can gain even more from +strictness by floating inwards past lambdas makes sense. + +We still gain even without going past lambdas, as things may be +strict in the (new) context of a branch (where it was floated to) or +of a let rhs, e.g. +\begin{verbatim} +let a = something case x of +in case x of alt1 -> case something of a -> a + a + alt1 -> a + a ==> alt2 -> b + alt2 -> b + +let a = something let b = case something of a -> a + a +in let b = a + a ==> in (b,b) +in (b,b) +\end{verbatim} +Also, even if a is not found to be strict in the new context and is +still left as a let, if the branch is not taken (or b is not entered) +the closure for a is not built. + +************************************************************************ +* * +\subsection{Main floating-inwards code} +* * +************************************************************************ +-} + +type FreeVarSet = DVarSet +type BoundVarSet = DIdSet + +data FloatInBind = FB BoundVarSet FreeVarSet FloatBind + -- The FreeVarSet is the free variables of the binding. In the case + -- of recursive bindings, the set doesn't include the bound + -- variables. + +type FloatInBinds = [FloatInBind] -- In normal dependency order + -- (outermost binder first) +type RevFloatInBinds = [FloatInBind] -- In reverse dependency order + -- (innermost binder first) + +instance Outputable FloatInBind where + ppr (FB bvs fvs _) = text "FB" <> braces (sep [ text "bndrs =" <+> ppr bvs + , text "fvs =" <+> ppr fvs ]) + +fiExpr :: Platform + -> RevFloatInBinds -- Binds we're trying to drop + -- as far "inwards" as possible + -> CoreExprWithFVs -- Input expr + -> CoreExpr -- Result + +fiExpr _ to_drop (_, AnnLit lit) = wrapFloats to_drop (Lit lit) + -- See Note [Dead bindings] +fiExpr _ to_drop (_, AnnType ty) = assert (null to_drop) $ Type ty +fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) +fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) +fiExpr platform to_drop (_, AnnCast expr (co_ann, co)) + = wrapFloats drop_here $ + Cast (fiExpr platform e_drop expr) co + where + (drop_here, [e_drop]) + = sepBindsByDropPoint platform False to_drop + (freeVarsOfAnn co_ann) [freeVarsOf expr] + +{- +Applications: we do float inside applications, mainly because we +need to get at all the arguments. The next simplifier run will +pull out any silly ones. +-} + +fiExpr platform to_drop ann_expr@(_,AnnApp {}) + = wrapFloats drop_here $ + mkTicks ticks $ + mkApps (fiExpr platform fun_drop ann_fun) + (zipWithEqual (fiExpr platform) arg_drops ann_args) + -- use zipWithEqual, we should have + -- length ann_args = length arg_fvs = length arg_drops + where + (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr + fun_fvs = freeVarsOf ann_fun + + (drop_here, fun_drop : arg_drops) + = sepBindsByDropPoint platform False to_drop + here_fvs (fun_fvs : arg_fvs) + + -- Shortcut behaviour: if to_drop is empty, + -- sepBindsByDropPoint returns a suitable bunch of empty + -- lists without evaluating extra_fvs, and hence without + -- peering into each argument + + (here_fvs, arg_fvs) = mapAccumL add_arg here_fvs0 ann_args + here_fvs0 = case ann_fun of + (_, AnnVar _) -> fun_fvs + _ -> emptyDVarSet + -- Don't float the binding for f into f x y z; see Note [Join points] + -- for why we *can't* do it when f is a join point. (If f isn't a + -- join point, floating it in isn't especially harmful but it's + -- useless since the simplifier will immediately float it back out.) + + add_arg :: FreeVarSet -> CoreExprWithFVs -> (FreeVarSet,FreeVarSet) + -- We can't float into some arguments, so put them into the here_fvs + add_arg here_fvs (arg_fvs, arg) + | noFloatIntoArg arg = (here_fvs `unionDVarSet` arg_fvs, emptyDVarSet) + | otherwise = (here_fvs, arg_fvs) + +{- Note [Dead bindings] +~~~~~~~~~~~~~~~~~~~~~~~ +At a literal we won't usually have any floated bindings; the +only way that can happen is if the binding wrapped the literal +/in the original input program/. e.g. + case x of { DEFAULT -> 1# } +But, while this may be unusual it is not actually wrong, and it did +once happen (#15696). + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +Generally, we don't need to worry about join points - there are places we're +not allowed to float them, but since they can't have occurrences in those +places, we're not tempted. + +We do need to be careful about jumps, however: + + joinrec j x y z = ... in + jump j a b c + +Previous versions often floated the definition of a recursive function into its +only non-recursive occurrence. But for a join point, this is a disaster: + + (joinrec j x y z = ... in + jump j) a b c -- wrong! + +Every jump must be exact, so the jump to j must have three arguments. Hence +we're careful not to float into the target of a jump (though we can float into +the arguments just fine). + +Floating in can /enhance/ join points. Consider this (#3458) + f2 x = let g :: Int -> Int + g y = if y==0 then y+x else g (y-1) + in case g x of + 0 -> True + _ -> False + +Here `g` is not a join point. But if we float inwards it becomes one! We +float in; the occurrence analyser identifies `g` as a join point; the Simplifier +retains that property, so we get + f2 x = case (joinrec + g y = if y==0 then y+x else g (y-1) + in jump g x) of + 0 -> True + _ -> False + +Now that outer case gets pushed into the RHS of the joinrec, giving + f2 x = joinrec g y = if y==0 + then case y+x of { 0 -> True; _ -> False } + else jump g (y-1) + in jump g x +Nice! + +Note [Floating in past a lambda group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We must be careful about floating inside a value lambda. + That risks losing laziness. + The float-out pass might rescue us, but then again it might not. + +* We must be careful about type lambdas too. At one time we did, and + there is no risk of duplicating work thereby, but we do need to be + careful. In particular, here is a bad case (it happened in the + cichelli benchmark: + let v = ... + in let f = /\t -> \a -> ... + ==> + let f = /\t -> let v = ... in \a -> ... + This is bad as now f is an updatable closure (update PAP) + and has arity 0. + +* Hack alert! We only float in through one-shot lambdas, + not (as you might guess) through lone big lambdas. + Reason: we float *out* past big lambdas (see the test in the Lam + case of FloatOut.floatExpr) and we don't want to float straight + back in again. + + It *is* important to float into one-shot lambdas, however; + see the remarks with noFloatIntoRhs. + +So we treat lambda in groups, using the following rule: + + Float in if (a) there is at least one Id, + and (b) there are no non-one-shot Ids + + Otherwise drop all the bindings outside the group. + +This is what the 'go' function in the AnnLam case is doing. + +(Join points are handled similarly: a join point is considered one-shot iff +it's non-recursive, so we float only into non-recursive join points.) + +Urk! if all are tyvars, and we don't float in, we may miss an + opportunity to float inside a nested case branch + +Note [Floating coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We could, in principle, have a coercion binding like + case f x of co { DEFAULT -> e1 e2 } +It's not common to have a function that returns a coercion, but nothing +in Core prohibits it. If so, 'co' might be mentioned in e1 or e2 +/only in a type/. E.g. suppose e1 was + let (x :: Int |> co) = blah in blah2 + + +But, with coercions appearing in types, there is a complication: we +might be floating in a "strict let" -- that is, a case. Case expressions +mention their return type. We absolutely can't float a coercion binding +inward to the point that the type of the expression it's about to wrap +mentions the coercion. So we include the union of the sets of free variables +of the types of all the drop points involved. If any of the floaters +bind a coercion variable mentioned in any of the types, that binder must +be dropped right away. + +Note [Shadowing and name capture] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + let x = y+1 in + case p of + (y:ys) -> ...x... + [] -> blah +It is obviously bogus for FloatIn to transform to + case p of + (y:ys) -> ...(let x = y+1 in x)... + [] -> blah +because the y is captured. This doesn't happen much, because shadowing is +rare (see Note [Shadowing in Core]), but it did happen in #22662. + +One solution would be to clone as we go. But a simpler one is this: + + at a binding site (like that for (y:ys) above), abandon float-in for + any floating bindings that mention the binders (y, ys in this case) + +We achieve that by calling sepBindsByDropPoint with the binders in +the "used-here" set: + +* In fiExpr (AnnLam ...). For the body there is no need to delete + the lambda-binders from the body_fvs, because any bindings that + mention these binders will be dropped here anyway. + +* In fiExpr (AnnCase ...). Remember to include the case_bndr in the + binders. Again, no need to delete the alt binders from the rhs + free vars, because any bindings mentioning them will be dropped + here unconditionally. +-} + +fiExpr platform to_drop lam@(_, AnnLam _ _) + | noFloatIntoLam bndrs -- Dump it all here + -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088 + = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body)) + + | otherwise -- Float inside + = wrapFloats drop_here $ + mkLams bndrs (fiExpr platform body_drop body) + + where + (bndrs, body) = collectAnnBndrs lam + body_fvs = freeVarsOf body + + -- Why sepBindsByDropPoint? Because of potential capture + -- See Note [Shadowing and name capture] + (drop_here, [body_drop]) = sepBindsByDropPoint platform False to_drop + (mkDVarSet bndrs) [body_fvs] + +{- +We don't float lets inwards past an SCC. + ToDo: keep info on current cc, and when passing + one, if it is not the same, annotate all lets in binds with current + cc, change current cc to the new one and float binds into expr. +-} + +fiExpr platform to_drop (_, AnnTick tickish expr) + | tickish `tickishScopesLike` SoftScope + = Tick tickish (fiExpr platform to_drop expr) + + | otherwise -- Wimp out for now - we could push values in + = wrapFloats to_drop (Tick tickish (fiExpr platform [] expr)) + +{- +For @Lets@, the possible ``drop points'' for the \tr{to_drop} +bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding, +or~(b2), in each of the RHSs of the pairs of a @Rec@. + +Note that we do {\em weird things} with this let's binding. Consider: +\begin{verbatim} +let + w = ... +in { + let v = ... w ... + in ... v .. w ... +} +\end{verbatim} +Look at the inner \tr{let}. As \tr{w} is used in both the bind and +body of the inner let, we could panic and leave \tr{w}'s binding where +it is. But \tr{v} is floatable further into the body of the inner let, and +{\em then} \tr{w} will also be only in the body of that inner let. + +So: rather than drop \tr{w}'s binding here, we add it onto the list of +things to drop in the outer let's body, and let nature take its +course. + +Note [extra_fvs (1)]: avoid floating into RHS +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider let x=\y....t... in body. We do not necessarily want to float +a binding for t into the RHS, because it'll immediately be floated out +again. (It won't go inside the lambda else we risk losing work.) +In letrec, we need to be more careful still. We don't want to transform + let x# = y# +# 1# + in + letrec f = \z. ...x#...f... + in ... +into + letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... +because now we can't float the let out again, because a letrec +can't have unboxed bindings. + +So we make "extra_fvs" which is the rhs_fvs of such bindings, and +arrange to dump bindings that bind extra_fvs before the entire let. + +Note [extra_fvs (2)]: free variables of rules +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let x{rule mentioning y} = rhs in body +Here y is not free in rhs or body; but we still want to dump bindings +that bind y outside the let. So we augment extra_fvs with the +idRuleAndUnfoldingVars of x. No need for type variables, hence not using +idFreeVars. +-} + +fiExpr platform to_drop (_,AnnLet bind body) + = fiExpr platform (after ++ new_float : before) body + -- to_drop is in reverse dependency order + where + (before, new_float, after) = fiBind platform to_drop bind body_fvs + body_fvs = freeVarsOf body + +{- Note [Floating primops] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We try to float-in a case expression over an unlifted type. The +motivating example was #5658: in particular, this change allows +array indexing operations, which have a single DEFAULT alternative +without any binders, to be floated inward. + +In particular, we want to be able to transform + + case indexIntArray# arr i of vi { + __DEFAULT -> case <# j n of _ { + __DEFAULT -> False + 1# -> case indexIntArray# arr j of vj { + __DEFAULT -> ... vi ... vj ... + } + } + } + +by floating in `indexIntArray# arr i` to produce + + case <# j n of _ { + __DEFAULT -> False + 1# -> case indexIntArray# arr i of vi { + __DEFAULT -> case indexIntArray# arr j of vj { + __DEFAULT -> ... vi ... vj ... + } + } + } + +...which skips the `indexIntArray# arr i` call entirely in the out-of-bounds branch. + +SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed +scalars also need to be floated inward, but unpacks have a single non-DEFAULT +alternative that binds the elements of the tuple. We now therefore also support +floating in cases with a single alternative that may bind values. + +But there are wrinkles + +* Which unlifted cases do we float? + See Note [Transformations affected by primop effects] in GHC.Builtin.PrimOps + which explains: + - We can float in or discard CanFail primops, but we can't float them out. + - We don't want to discard a synchronous exception or side effect + so we don't float those at all. Hence exprOkToDiscard. + - Throwing precise exceptions is a special case of the previous point: We + may /never/ float in a call to (something that ultimately calls) + 'raiseIO#'. + See Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. + +* Because we can float can-fail primops (array indexing, division) inwards + but not outwards, we must be careful not to transform + case a /# b of r -> f (F# r) + ===> + f (case a /# b of r -> F# r) + because that creates a new thunk that wasn't there before. And + because it can't be floated out (CanFail), the thunk will stay + there. Disaster! (This happened in nofib 'simple' and 'scs'.) + + Solution: only float cases into the branches of other cases, and + not into the arguments of an application, or the RHS of a let. This + is somewhat conservative, but it's simple. And it still hits the + cases like #5658. This is implemented in sepBindsByJoinPoint; + if is_case is False we dump all floating cases right here. + +* #14511 is another example of why we want to restrict float-in + of case-expressions. Consider + case indexArray# a n of (# r #) -> writeArray# ma i (f r) + Now, floating that indexing operation into the (f r) thunk will + not create any new thunks, but it will keep the array 'a' alive + for much longer than the programmer expected. + + So again, not floating a case into a let or argument seems like + the Right Thing + +For @Case@, the possible drop points for the 'to_drop' +bindings are: + (a) inside the scrutinee + (b) inside one of the alternatives/default (default FVs always /first/!). + +-} + +fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs]) + | isUnliftedType (idType case_bndr) + -- binders have a fixed RuntimeRep so it's OK to call isUnliftedType + , exprOkToDiscard (deAnnotate scrut) + -- See Note [Floating primops] + = wrapFloats shared_binds $ + fiExpr platform (case_float : rhs_binds) rhs + where + case_float = FB all_bndrs scrut_fvs + (FloatCase scrut' case_bndr con alt_bndrs) + scrut' = fiExpr platform scrut_binds scrut + rhs_fvs = freeVarsOf rhs -- No need to delete alt_bndrs + scrut_fvs = freeVarsOf scrut -- See Note [Shadowing and name capture] + all_bndrs = mkDVarSet alt_bndrs `extendDVarSet` case_bndr + + (shared_binds, [scrut_binds, rhs_binds]) + = sepBindsByDropPoint platform False to_drop + all_bndrs [scrut_fvs, rhs_fvs] + +fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) + = wrapFloats drop_here1 $ + wrapFloats drop_here2 $ + Case (fiExpr platform scrut_drops scrut) case_bndr ty + (zipWithEqual fi_alt alts_drops_s alts) + -- use zipWithEqual, we should have length alts_drops_s = length alts + where + -- Float into the scrut and alts-considered-together just like App + (drop_here1, [scrut_drops, alts_drops]) + = sepBindsByDropPoint platform False to_drop + all_alt_bndrs [scrut_fvs, all_alt_fvs] + -- all_alt_bndrs: see Note [Shadowing and name capture] + + -- Float into the alts with the is_case flag set + (drop_here2, alts_drops_s) + = sepBindsByDropPoint platform True alts_drops emptyDVarSet alts_fvs + + scrut_fvs = freeVarsOf scrut + + all_alt_bndrs = foldr (unionDVarSet . ann_alt_bndrs) (unitDVarSet case_bndr) alts + ann_alt_bndrs (AnnAlt _ bndrs _) = mkDVarSet bndrs + + alts_fvs :: [DVarSet] + alts_fvs = [freeVarsOf rhs | AnnAlt _ _ rhs <- alts] + -- No need to delete binders + -- See Note [Shadowing and name capture] + + all_alt_fvs :: DVarSet + all_alt_fvs = foldr unionDVarSet (unitDVarSet case_bndr) alts_fvs + + fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs) + +------------------ +fiBind :: Platform + -> RevFloatInBinds -- Binds we're trying to drop + -- as far "inwards" as possible + -> CoreBindWithFVs -- Input binding + -> DVarSet -- Free in scope of binding + -> ( RevFloatInBinds -- Land these before + , FloatInBind -- The binding itself + , RevFloatInBinds) -- Land these after + +fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs + = ( shared_binds -- Land these before + -- See Note [extra_fvs (1)] and Note [extra_fvs (2)] + , FB (unitDVarSet id) rhs_fvs' -- The new binding itself + (FloatLet (NonRec id rhs')) + , body_binds ) -- Land these after + + where + body_fvs2 = body_fvs `delDVarSet` id + + rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2)] + extra_fvs | noFloatIntoRhs NonRecursive id rhs + = rule_fvs `unionDVarSet` rhs_fvs + | otherwise + = rule_fvs + -- See Note [extra_fvs (1)] + -- No point in floating in only to float straight out again + -- We *can't* float into ok-for-speculation unlifted RHSs + -- But do float into join points + + (shared_binds, [rhs_binds, body_binds]) + = sepBindsByDropPoint platform False to_drop + extra_fvs [rhs_fvs, body_fvs2] + + -- Push rhs_binds into the right hand side of the binding + rhs' = fiRhs platform rhs_binds id ann_rhs + rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs + -- Don't forget the rule_fvs; the binding mentions them! + +fiBind platform to_drop (AnnRec bindings) body_fvs + = ( shared_binds + , FB (mkDVarSet ids) rhs_fvs' + (FloatLet (Rec (fi_bind rhss_binds bindings))) + , body_binds ) + where + (ids, rhss) = unzip bindings + rhss_fvs = map freeVarsOf rhss + + -- See Note [extra_fvs (1)] and Note [extra_fvs (2)] + rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids + extra_fvs = rule_fvs `unionDVarSet` + unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings + , noFloatIntoRhs Recursive bndr rhs ] + + (shared_binds, body_binds:rhss_binds) + = sepBindsByDropPoint platform False to_drop + extra_fvs (body_fvs:rhss_fvs) + + rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet` + unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet` + rule_fvs -- Don't forget the rule variables! + + -- Push rhs_binds into the right hand side of the binding + fi_bind :: [RevFloatInBinds] -- One per "drop pt" conjured w/ fvs_of_rhss + -> [(Id, CoreExprWithFVs)] + -> [(Id, CoreExpr)] + + fi_bind to_drops pairs + = [ (binder, fiRhs platform to_drop binder rhs) + | ((binder, rhs), to_drop) <- zipEqual pairs to_drops ] + +------------------ +fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr +fiRhs platform to_drop bndr rhs + | JoinPoint join_arity <- idJoinPointHood bndr + , let (bndrs, body) = collectNAnnBndrs join_arity rhs + = mkLams bndrs (fiExpr platform to_drop body) + | otherwise + = fiExpr platform to_drop rhs + +------------------ +noFloatIntoLam :: [Var] -> Bool +noFloatIntoLam bndrs = any bad bndrs + where + bad b = isId b && not (isOneShotBndr b) + -- Don't float inside a non-one-shot lambda + +noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool +-- ^ True if it's a bad idea to float bindings into this RHS +noFloatIntoRhs is_rec bndr rhs + | isJoinId bndr + = isRec is_rec -- Joins are one-shot iff non-recursive + + | definitelyUnliftedType (idType bndr) + = True -- Preserve let-can-float invariant, see Note [noFloatInto considerations] + + | otherwise + = noFloatIntoArg rhs + +noFloatIntoArg :: CoreExprWithFVs' -> Bool +noFloatIntoArg expr + | AnnLam bndr e <- expr + , (bndrs, _) <- collectAnnBndrs e + = noFloatIntoLam (bndr:bndrs) -- Wrinkle 1 (a) + || all isTyVar (bndr:bndrs) -- Wrinkle 1 (b) + -- See Note [noFloatInto considerations] wrinkle 2 + + | otherwise -- See Note [noFloatInto considerations] wrinkle 2 + = exprIsTrivial deann_expr || exprIsHNF deann_expr + where + deann_expr = deAnnotate' expr + +{- Note [noFloatInto considerations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When do we want to float bindings into + - noFloatIntoRhs: the RHS of a let-binding + - noFloatIntoArg: the argument of a function application + +Definitely don't float into RHS if it has unlifted type; +that would destroy the let-can-float invariant. + +* Wrinkle 1: do not float in if + (a) any non-one-shot value lambdas + or (b) all type lambdas + In both cases we'll float straight back out again + NB: Must line up with fiExpr (AnnLam...); see #7088 + + (a) is important: we /must/ float into a one-shot lambda group + (which includes join points). This makes a big difference + for things like + f x# = let x = I# x# + in let j = \() -> ...x... + in if then normal-path else j () + If x is used only in the error case join point, j, we must float the + boxing constructor into it, else we box it every time which is very + bad news indeed. + +* Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right + back out again... not tragic, but a waste of time. + + For function arguments we will still end up with this + in-then-out stuff; consider + letrec x = e in f x + Here x is not a HNF, so we'll produce + f (letrec x = e in x) + which is OK... it's not that common, and we'll end up + floating out again, in CorePrep if not earlier. + Still, we use exprIsTrivial to catch this case (sigh) + + +************************************************************************ +* * +\subsection{@sepBindsByDropPoint@} +* * +************************************************************************ + +This is the crucial function. The idea is: We have a wad of bindings +that we'd like to distribute inside a collection of {\em drop points}; +insides the alternatives of a \tr{case} would be one example of some +drop points; the RHS and body of a non-recursive \tr{let} binding +would be another (2-element) collection. + +So: We're given a list of sets-of-free-variables, one per drop point, +and a list of floating-inwards bindings. If a binding can go into +only one drop point (without suddenly making something out-of-scope), +in it goes. If a binding is used inside {\em multiple} drop points, +then it has to go in a you-must-drop-it-above-all-these-drop-points +point. + +We have to maintain the order on these drop-point-related lists. +-} + +-- pprFIB :: RevFloatInBinds -> SDoc +-- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs] + +sepBindsByDropPoint + :: Platform + -> Bool -- True <=> is case expression + -> RevFloatInBinds -- Candidate floaters + -> FreeVarSet -- here_fvs: if these vars are free in a binding, + -- don't float that binding inside any drop point + -> [FreeVarSet] -- fork_fvs: one set of FVs per drop point + -> ( RevFloatInBinds -- Bindings which must not be floated inside + , [RevFloatInBinds] ) -- Corresponds 1-1 with the input list of FV sets + +-- Every input floater is returned somewhere in the result; +-- none are dropped, not even ones which don't seem to be +-- free in *any* of the drop-point fvs. Why? Because, for example, +-- a binding (let x = E in B) might have a specialised version of +-- x (say x') stored inside x, but x' isn't free in E or B. +-- +-- The here_fvs argument is used for two things: +-- * Avoid shadowing bugs: see Note [Shadowing and name capture] +-- * Drop some of the bindings at the top, e.g. of an application + +type DropBox = (FreeVarSet, FloatInBinds) + +dropBoxFloats :: DropBox -> RevFloatInBinds +dropBoxFloats (_, floats) = reverse floats + +usedInDropBox :: DIdSet -> DropBox -> Bool +usedInDropBox bndrs (db_fvs, _) = db_fvs `intersectsDVarSet` bndrs + +initDropBox :: DVarSet -> DropBox +initDropBox fvs = (fvs, []) + +sepBindsByDropPoint platform is_case floaters here_fvs fork_fvs + | null floaters -- Shortcut common case + = ([], [[] | _ <- fork_fvs]) + + | otherwise + = go floaters (initDropBox here_fvs) (map initDropBox fork_fvs) + where + n_alts = length fork_fvs + + go :: RevFloatInBinds -> DropBox -> [DropBox] + -> (RevFloatInBinds, [RevFloatInBinds]) + -- The *first* one in the pair is the drop_here set + + go [] here_box fork_boxes + = (dropBoxFloats here_box, map dropBoxFloats fork_boxes) + + go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) here_box fork_boxes + | drop_here = go binds (insert here_box) fork_boxes + | otherwise = go binds here_box new_fork_boxes + where + -- "here" means the group of bindings dropped at the top of the fork + + used_here = bndrs `usedInDropBox` here_box + used_in_flags = case fork_boxes of + [] -> [] + [_] -> [True] -- Push all bindings into a single branch + -- No need to look at its free vars + _ -> map (bndrs `usedInDropBox`) fork_boxes + -- Short-cut for the singleton case; + -- used for lambdas and singleton cases + + drop_here = used_here || cant_push + + n_used_alts = count id used_in_flags -- returns number of Trues in list. + + cant_push + | is_case = (n_alts > 1 && n_used_alts == n_alts) + -- Used in all, muliple branches, don't push + || (n_used_alts > 1 && not (floatIsDupable platform bind)) + -- floatIsDupable: see Note [Duplicating floats] + + | otherwise = floatIsCase bind || n_used_alts > 1 + -- floatIsCase: see Note [Floating primops] + + new_fork_boxes = zipWithEqual insert_maybe + fork_boxes used_in_flags + + insert :: DropBox -> DropBox + insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops) + + insert_maybe box True = insert box + insert_maybe box False = box + + +{- Note [Duplicating floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For case expressions we duplicate the binding if it is reasonably +small, and if it is not used in all the RHSs This is good for +situations like + let x = I# y in + case e of + C -> error x + D -> error x + E -> ...not mentioning x... + +If the thing is used in all RHSs there is nothing gained, +so we don't duplicate then. +-} + +floatedBindsFVs :: RevFloatInBinds -> FreeVarSet +floatedBindsFVs binds = mapUnionDVarSet fbFVs binds + +fbFVs :: FloatInBind -> DVarSet +fbFVs (FB _ fvs _) = fvs + +wrapFloats :: RevFloatInBinds -> CoreExpr -> CoreExpr +-- Remember RevFloatInBinds is in *reverse* dependency order +wrapFloats [] e = e +wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) + +floatIsDupable :: Platform -> FloatBind -> Bool +floatIsDupable platform (FloatCase scrut _ _ _) = exprIsDupable platform scrut +floatIsDupable platform (FloatLet (Rec prs)) = all (exprIsDupable platform . snd) prs +floatIsDupable platform (FloatLet (NonRec _ r)) = exprIsDupable platform r + +floatIsCase :: FloatBind -> Bool +floatIsCase (FloatCase {}) = True +floatIsCase (FloatLet {}) = False diff --git a/GHC/Core/Opt/FloatOut.hs b/GHC/Core/Opt/FloatOut.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/FloatOut.hs @@ -0,0 +1,681 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[FloatOut]{Float bindings outwards (towards the top level)} + +``Long-distance'' floating of bindings towards the top level. +-} + + + +module GHC.Core.Opt.FloatOut ( floatOutwards ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Make +-- import GHC.Core.Opt.Arity ( exprArity, etaExpand ) +import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) + +import GHC.Driver.Flags ( DumpFlag (..) ) +import GHC.Utils.Logger +import GHC.Types.Id ( Id, idType, +-- idArity, isDeadEndId, + isJoinId, idJoinPointHood ) +import GHC.Types.Tickish +import GHC.Core.Opt.SetLevels +import GHC.Types.Unique.Supply ( UniqSupply ) +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Core.Type +import qualified Data.IntMap as M + +import Data.List ( partition ) + +{- + ----------------- + Overall game plan + ----------------- + +The Big Main Idea is: + + To float out sub-expressions that can thereby get outside + a non-one-shot value lambda, and hence may be shared. + + +To achieve this we may need to do two things: + + a) Let-bind the sub-expression: + + f (g x) ==> let lvl = f (g x) in lvl + + Now we can float the binding for 'lvl'. + + b) More than that, we may need to abstract wrt a type variable + + \x -> ... /\a -> let v = ...a... in .... + + Here the binding for v mentions 'a' but not 'x'. So we + abstract wrt 'a', to give this binding for 'v': + + vp = /\a -> ...a... + v = vp a + + Now the binding for vp can float out unimpeded. + I can't remember why this case seemed important enough to + deal with, but I certainly found cases where important floats + didn't happen if we did not abstract wrt tyvars. + +With this in mind we can also achieve another goal: lambda lifting. +We can make an arbitrary (function) binding float to top level by +abstracting wrt *all* local variables, not just type variables, leaving +a binding that can be floated right to top level. Whether or not this +happens is controlled by a flag. + + +Random comments +~~~~~~~~~~~~~~~ + +At the moment we never float a binding out to between two adjacent +lambdas. For example: + +@ + \x y -> let t = x+x in ... +===> + \x -> let t = x+x in \y -> ... +@ +Reason: this is less efficient in the case where the original lambda +is never partially applied. + +But there's a case I've seen where this might not be true. Consider: +@ +elEm2 x ys + = elem' x ys + where + elem' _ [] = False + elem' x (y:ys) = x==y || elem' x ys +@ +It turns out that this generates a subexpression of the form +@ + \deq x ys -> let eq = eqFromEqDict deq in ... +@ +which might usefully be separated to +@ + \deq -> let eq = eqFromEqDict deq in \xy -> ... +@ +Well, maybe. We don't do this at the moment. + + +************************************************************************ +* * +\subsection[floatOutwards]{@floatOutwards@: let-floating interface function} +* * +************************************************************************ +-} + +floatOutwards :: Logger + -> FloatOutSwitches + -> UniqSupply + -> CoreProgram -> IO CoreProgram + +floatOutwards logger float_sws us pgm + = do { + let { annotated_w_levels = setLevels float_sws pgm us ; + (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) + } ; + + putDumpFileMaybe logger Opt_D_verbose_core2core "Levels added:" + FormatCore + (vcat (map ppr annotated_w_levels)); + + let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; + + putDumpFileMaybe logger Opt_D_dump_simpl_stats "FloatOut stats:" + FormatText + (hcat [ int tlets, text " Lets floated to top level; ", + int ntlets, text " Lets floated elsewhere; from ", + int lams, text " Lambda groups"]); + + return (bagToList (unionManyBags binds_s')) + } + +floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind) +floatTopBind bind + = case (floatBind bind) of { (fs, floats, bind') -> + let float_bag = flattenTopFloats floats + in case bind' of + -- bind' can't have unlifted values or join points, so can only be one + -- value bind, rec or non-rec (see comment on floatBind) + [Rec prs] -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs))) + [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e) + _ -> pprPanic "floatTopBind" (ppr bind') } + +{- +************************************************************************ +* * +\subsection[FloatOut-Bind]{Floating in a binding (the business end)} +* * +************************************************************************ +-} + +floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind]) + -- Returns a list with either + -- * A single non-recursive binding (value or join point), or + -- * The following, in order: + -- * Zero or more non-rec unlifted bindings + -- * One or both of: + -- * A recursive group of join binds + -- * A recursive group of value binds + -- See Note [Floating out of Rec rhss] for why things get arranged this way. +floatBind (NonRec (TB var _) rhs) + = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') -> + (fs, rhs_floats, [NonRec var rhs']) } + +floatBind (Rec pairs) + = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> + let (new_ul_pairss, new_other_pairss) = unzip new_pairs + (new_join_pairs, new_l_pairs) = partition (isJoinId . fst) + (concat new_other_pairss) + -- Can't put the join points and the values in the same rec group + new_rec_binds | null new_join_pairs = [ Rec new_l_pairs ] + | null new_l_pairs = [ Rec new_join_pairs ] + | otherwise = [ Rec new_l_pairs + , Rec new_join_pairs ] + new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ] + in + (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) } + where + do_pair :: (LevelledBndr, LevelledExpr) + -> (FloatStats, FloatBinds, + ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings + [(Id,CoreExpr)])) -- Join points and lifted value bindings + do_pair (TB name spec, rhs) + | isTopLvl dest_lvl -- See Note [floatBind for top level] + = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> + (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats) + [(name, rhs')]))} + | otherwise -- Note [Floating out of Rec rhss] + = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> + case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) -> + case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) -> + let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in + (fs, rhs_floats', (ul_pairs, pairs')) }}} + where + dest_lvl = floatSpecLevel spec + +splitRecFloats :: Bag FloatBind + -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings + [(Id,CoreExpr)], -- Join points and lifted value bindings + Bag FloatBind) -- A tail of further bindings +-- The "tail" begins with a case +-- See Note [Floating out of Rec rhss] +splitRecFloats fs + = go [] [] (bagToList fs) + where + go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b) + -- NB: isUnliftedType is OK here as binders always + -- have a fixed RuntimeRep. + , not (isJoinId b) + = go ((b,r):ul_prs) prs fs + | otherwise + = go ul_prs ((b,r):prs) fs + go ul_prs prs (FloatLet (Rec prs') : fs) = go ul_prs (prs' ++ prs) fs + go ul_prs prs fs = (reverse ul_prs, prs, + listToBag fs) + -- Order only matters for + -- non-rec + +installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr +-- See Note [Floating out of Rec rhss] +installUnderLambdas floats e + | isEmptyBag floats = e + | otherwise = go e + where + go (Lam b e) = Lam b (go e) + go e = install floats e + +--------------- +floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) +floatList _ [] = (zeroStats, emptyFloats, []) +floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> + case floatList f as of { (fs_as, binds_as, bs) -> + (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} + +{- +Note [Floating out of Rec rhss] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider Rec { f<1,0> = \xy. body } +From the body we may get some floats. The ones with level <1,0> must +stay here, since they may mention f. Ideally we'd like to make them +part of the Rec block pairs -- but we can't if there are any +FloatCases involved. + +Nor is it a good idea to dump them in the rhs, but outside the lambda + f = case x of I# y -> \xy. body +because now f's arity might get worse, which is Not Good. (And if +there's an SCC around the RHS it might not get better again. +See #5342.) + +So, gruesomely, we split the floats into + * the outer FloatLets, which can join the Rec, and + * an inner batch starting in a FloatCase, which are then + pushed *inside* the lambdas. +This loses full-laziness the rare situation where there is a +FloatCase and a Rec interacting. + +If there are unlifted FloatLets (that *aren't* join points) among the floats, +we can't add them to the recursive group without angering Core Lint, but since +they must be ok-for-speculation, they can't actually be making any recursive +calls, so we can safely pull them out and keep them non-recursive. + +(Why is something getting floated to <1,0> that doesn't make a recursive call? +The case that came up in testing was that f *and* the unlifted binding were +getting floated *to the same place*: + + \x<2,0> -> + ... <3,0> + letrec { f> = + ... let x'> = x +# 1# in ... + } in ... + +Everything gets labeled "float to <2,0>" because it all depends on x, but this +makes f and x' look mutually recursive when they're not. + +The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the +wip/join-points branch. + +TODO: This can probably be solved somehow in GHC.Core.Opt.SetLevels. The difference between +"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very +important.) + +Note [floatBind for top level] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus + letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... } +The binding for bar will be in the "tops" part of the floating binds, +and thus not partitioned by floatBody. + +We could perhaps get rid of the 'tops' component of the floating binds, +but this case works just as well. + + +************************************************************************ + +\subsection[FloatOut-Expr]{Floating in expressions} +* * +************************************************************************ +-} + +floatBody :: Level + -> LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) + +floatBody lvl arg -- Used rec rhss, and case-alternative rhss + = case (floatExpr arg) of { (fsa, floats, arg') -> + case (partitionByLevel lvl floats) of { (floats', heres) -> + -- Dump bindings are bound here + (fsa, floats', install heres arg') }} + +----------------- + +{- Note [Floating past breakpoints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to disallow floating out of breakpoint ticks (see #10052). However, I +think this is too restrictive. + +Consider the case of an expression scoped over by a breakpoint tick, + + tick<...> (let x = ... in f x) + +In this case it is completely legal to float out x, despite the fact that +breakpoint ticks are scoped, + + let x = ... in (tick<...> f x) + +The reason here is that we know that the breakpoint will still be hit when the +expression is entered since the tick still scopes over the RHS. + +-} + +floatExpr :: LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) +floatExpr (Var v) = (zeroStats, emptyFloats, Var v) +floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty) +floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co) +floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit) + +floatExpr (App e a) + = case (floatExpr e) of { (fse, floats_e, e') -> + case (floatExpr a) of { (fsa, floats_a, a') -> + (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }} + +floatExpr lam@(Lam (TB _ lam_spec) _) + = let (bndrs_w_lvls, body) = collectBinders lam + bndrs = [b | TB b _ <- bndrs_w_lvls] + bndr_lvl = floatSpecLevel lam_spec + -- All the binders have the same level + -- See GHC.Core.Opt.SetLevels.lvlLamBndrs + -- Use asJoinCeilLvl to make this the join ceiling + in + case (floatBody bndr_lvl body) of { (fs, floats, body') -> + (add_to_stats fs floats, floats, mkLams bndrs body') } + +floatExpr (Tick tickish expr) + | tickish `tickishScopesLike` SoftScope -- not scoped, can just float + = case (floatExpr expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, Tick tickish expr') } + + | not (tickishCounts tickish) || tickishCanSplit tickish + = case (floatExpr expr) of { (fs, floating_defns, expr') -> + let -- Annotate bindings floated outwards past an scc expression + -- with the cc. We mark that cc as "duplicated", though. + annotated_defns = wrapTick (mkNoCount tickish) floating_defns + in + (fs, annotated_defns, Tick tickish expr') } + + -- See Note [Floating past breakpoints] + | Breakpoint{} <- tickish + = case (floatExpr expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, Tick tickish expr') } + + | otherwise + = pprPanic "floatExpr tick" (ppr tickish) + +floatExpr (Cast expr co) + = case (floatExpr expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, Cast expr' co) } + +floatExpr (Let bind body) + = case bind_spec of + FloatMe dest_lvl + -> case (floatBind bind) of { (fsb, bind_floats, binds') -> + case (floatExpr body) of { (fse, body_floats, body') -> + let new_bind_floats = foldr plusFloats emptyFloats + (map (unitLetFloat dest_lvl) binds') in + ( add_stats fsb fse + , bind_floats `plusFloats` new_bind_floats + `plusFloats` body_floats + , body') }} + + StayPut bind_lvl -- See Note [Avoiding unnecessary floating] + -> case (floatBind bind) of { (fsb, bind_floats, binds') -> + case (floatBody bind_lvl body) of { (fse, body_floats, body') -> + ( add_stats fsb fse + , bind_floats `plusFloats` body_floats + , foldr Let body' binds' ) }} + where + bind_spec = case bind of + NonRec (TB _ s) _ -> s + Rec ((TB _ s, _) : _) -> s + Rec [] -> panic "floatExpr:rec" + +floatExpr (Case scrut (TB case_bndr case_spec) ty alts) + = case case_spec of + FloatMe dest_lvl -- Case expression moves + | [Alt con@(DataAlt {}) bndrs rhs] <- alts + -> case floatExpr scrut of { (fse, fde, scrut') -> + case floatExpr rhs of { (fsb, fdb, rhs') -> + let + float = unitCaseFloat dest_lvl scrut' + case_bndr con [b | TB b _ <- bndrs] + in + (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }} + | otherwise + -> pprPanic "Floating multi-case" (ppr alts) + + StayPut bind_lvl -- Case expression stays put + -> case floatExpr scrut of { (fse, fde, scrut') -> + case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') -> + (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') + }} + where + float_alt bind_lvl (Alt con bs rhs) + = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> + (fs, rhs_floats, Alt con [b | TB b _ <- bs] rhs') } + +floatRhs :: CoreBndr + -> LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) +floatRhs bndr rhs + | JoinPoint join_arity <- idJoinPointHood bndr + , Just (bndrs, body) <- try_collect join_arity rhs [] + = case bndrs of + [] -> floatExpr rhs + (TB _ lam_spec):_ -> + let lvl = floatSpecLevel lam_spec in + case floatBody lvl body of { (fs, floats, body') -> + (fs, floats, mkLams [b | TB b _ <- bndrs] body') } + | otherwise + = floatExpr rhs + where + try_collect 0 expr acc = Just (reverse acc, expr) + try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc) + try_collect _ _ _ = Nothing + +{- +Note [Avoiding unnecessary floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we want to avoid floating a let unnecessarily, because +it might worsen strictness: + let + x = ...(let y = e in y+y).... +Here y is demanded. If we float it outside the lazy 'x=..' then +we'd have to zap its demand info, and it may never be restored. + +So at a 'let' we leave the binding right where the are unless +the binding will escape a value lambda, e.g. + +(\x -> let y = fac 100 in y) + +That's what the partitionByMajorLevel does in the floatExpr (Let ...) +case. + +Notice, though, that we must take care to drop any bindings +from the body of the let that depend on the staying-put bindings. + +We used instead to do the partitionByMajorLevel on the RHS of an '=', +in floatRhs. But that was quite tiresome. We needed to test for +values or trivial rhss, because (in particular) we don't want to insert +new bindings between the "=" and the "\". E.g. + f = \x -> let in +We do not want + f = let in \x -> +(a) The simplifier will immediately float it further out, so we may + as well do so right now; in general, keeping rhss as manifest + values is good +(b) If a float-in pass follows immediately, it might add yet more + bindings just after the '='. And some of them might (correctly) + be strict even though the 'let f' is lazy, because f, being a value, + gets its demand-info zapped by the simplifier. +And even all that turned out to be very fragile, and broke +altogether when profiling got in the way. + +So now we do the partition right at the (Let..) itself. + +************************************************************************ +* * +\subsection{Utility bits for floating stats} +* * +************************************************************************ + +I didn't implement this with unboxed numbers. I don't want to be too +strict in this stuff, as it is rarely turned on. (WDP 95/09) +-} + +data FloatStats + = FlS Int -- Number of top-floats * lambda groups they've been past + Int -- Number of non-top-floats * lambda groups they've been past + Int -- Number of lambda (groups) seen + +get_stats :: FloatStats -> (Int, Int, Int) +get_stats (FlS a b c) = (a, b, c) + +zeroStats :: FloatStats +zeroStats = FlS 0 0 0 + +sum_stats :: [FloatStats] -> FloatStats +sum_stats xs = foldr add_stats zeroStats xs + +add_stats :: FloatStats -> FloatStats -> FloatStats +add_stats (FlS a1 b1 c1) (FlS a2 b2 c2) + = FlS (a1 + a2) (b1 + b2) (c1 + c2) + +add_to_stats :: FloatStats -> FloatBinds -> FloatStats +add_to_stats (FlS a b c) (FB tops others) + = FlS (a + lengthBag tops) + (b + lengthBag (flattenMajor others)) + (c + 1) + +{- +************************************************************************ +* * +\subsection{Utility bits for floating} +* * +************************************************************************ + +Note [Representation of FloatBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The FloatBinds types is somewhat important. We can get very large numbers +of floating bindings, often all destined for the top level. A typical example +is x = [4,2,5,2,5, .... ] +Then we get lots of small expressions like (fromInteger 4), which all get +lifted to top level. + +The trouble is that + (a) we partition these floating bindings *at every binding site* + (b) GHC.Core.Opt.SetLevels introduces a new bindings site for every float +So we had better not look at each binding at each binding site! + +That is why MajorEnv is represented as a finite map. + +We keep the bindings destined for the *top* level separate, because +we float them out even if they don't escape a *value* lambda; see +partitionByMajorLevel. +-} + +type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted +type MajorEnv = M.IntMap MinorEnv -- Keyed by major level +type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level + +data FloatBinds = FB !(Bag FloatLet) -- Destined for top level + !MajorEnv -- Other levels + -- See Note [Representation of FloatBinds] + +instance Outputable FloatBinds where + ppr (FB fbs defs) + = text "FB" <+> (braces $ vcat + [ text "tops =" <+> ppr fbs + , text "non-tops =" <+> ppr defs ]) + +flattenTopFloats :: FloatBinds -> Bag CoreBind +flattenTopFloats (FB tops defs) + = assertPpr (isEmptyBag (flattenMajor defs)) (ppr defs) $ + tops + +addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] +addTopFloatPairs float_bag prs + = foldr add prs float_bag + where + add (NonRec b r) prs = (b,r):prs + add (Rec prs1) prs2 = prs1 ++ prs2 + +flattenMajor :: MajorEnv -> Bag FloatBind +flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag + +flattenMinor :: MinorEnv -> Bag FloatBind +flattenMinor = M.foldr unionBags emptyBag + +emptyFloats :: FloatBinds +emptyFloats = FB emptyBag M.empty + +unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds +unitCaseFloat (Level major minor) e b con bs + = FB emptyBag (M.singleton major (M.singleton minor floats)) + where + floats = unitBag (FloatCase e b con bs) + +unitLetFloat :: Level -> FloatLet -> FloatBinds +unitLetFloat lvl@(Level major minor) b + | isTopLvl lvl = FB (unitBag b) M.empty + | otherwise = FB emptyBag (M.singleton major (M.singleton minor floats)) + where + floats = unitBag (FloatLet b) + +plusFloats :: FloatBinds -> FloatBinds -> FloatBinds +plusFloats (FB t1 l1) (FB t2 l2) + = FB (t1 `unionBags` t2) (l1 `plusMajor` l2) + +plusMajor :: MajorEnv -> MajorEnv -> MajorEnv +plusMajor = M.unionWith plusMinor + +plusMinor :: MinorEnv -> MinorEnv -> MinorEnv +plusMinor = M.unionWith unionBags + +install :: Bag FloatBind -> CoreExpr -> CoreExpr +install defn_groups expr + = foldr wrapFloat expr defn_groups + +partitionByLevel + :: Level -- Partitioning level + -> FloatBinds -- Defns to be divided into 2 piles... + -> (FloatBinds, -- Defns with level strictly < partition level, + Bag FloatBind) -- The rest + +{- +-- ---- partitionByMajorLevel ---- +-- Float it if we escape a value lambda, +-- *or* if we get to the top level +-- *or* if it's a case-float and its minor level is < current +-- +-- If we can get to the top level, say "yes" anyway. This means that +-- x = f e +-- transforms to +-- lvl = e +-- x = f lvl +-- which is as it should be + +partitionByMajorLevel (Level major _) (FB tops defns) + = (FB tops outer, heres `unionBags` flattenMajor inner) + where + (outer, mb_heres, inner) = M.splitLookup major defns + heres = case mb_heres of + Nothing -> emptyBag + Just h -> flattenMinor h +-} + +partitionByLevel (Level major minor) (FB tops defns) + = (FB tops (outer_maj `plusMajor` M.singleton major outer_min), + here_min `unionBags` flattenMinor inner_min + `unionBags` flattenMajor inner_maj) + + where + (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns + (outer_min, mb_here_min, inner_min) = case mb_here_maj of + Nothing -> (M.empty, Nothing, M.empty) + Just min_defns -> M.splitLookup minor min_defns + here_min = mb_here_min `orElse` emptyBag + +wrapTick :: CoreTickish -> FloatBinds -> FloatBinds +wrapTick t (FB tops defns) + = FB (mapBag wrap_bind tops) + (M.map (M.map wrap_defns) defns) + where + wrap_defns = mapBag wrap_one + + wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs) + wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs) + + wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) + wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs + + maybe_tick e | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e + -- we don't need to wrap a tick around an HNF when we float it + -- outside a tick: that is an invariant of the tick semantics + -- Conversely, inlining of HNFs inside an SCC is allowed, and + -- indeed the HNF we're floating here might well be inlined back + -- again, and we don't want to end up with duplicate ticks. diff --git a/GHC/Core/Opt/LiberateCase.hs b/GHC/Core/Opt/LiberateCase.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/LiberateCase.hs @@ -0,0 +1,460 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} +-} + + +module GHC.Core.Opt.LiberateCase + ( LibCaseOpts(..) + , liberateCase + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Unfold +import GHC.Core.Opt.Simplify.Inline +import GHC.Builtin.Types ( unitDataConId ) +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Utils.Misc ( notNull ) + +{- +The liberate-case transformation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module walks over @Core@, and looks for @case@ on free variables. +The criterion is: + if there is case on a free on the route to the recursive call, + then the recursive call is replaced with an unfolding. + +Example + + f = \ t -> case v of + V a b -> a : f t + +=> the inner f is replaced. + + f = \ t -> case v of + V a b -> a : (letrec + f = \ t -> case v of + V a b -> a : f t + in f) t +(note the NEED for shadowing) + +=> Simplify + + f = \ t -> case v of + V a b -> a : (letrec + f = \ t -> a : f t + in f t) + +Better code, because 'a' is free inside the inner letrec, rather +than needing projection from v. + +Note that this deals with *free variables*. SpecConstr deals with +*arguments* that are of known form. E.g. + + last [] = error + last (x:[]) = x + last (x:xs) = last xs + + +Note [Scrutinee with cast] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + f = \ t -> case (v `cast` co) of + V a b -> a : f t + +Exactly the same optimisation (unrolling one call to f) will work here, +despite the cast. See mk_alt_env in the Case branch of libCase. + + +To think about (Apr 94) +~~~~~~~~~~~~~~ +Main worry: duplicating code excessively. At the moment we duplicate +the entire binding group once at each recursive call. But there may +be a group of recursive calls which share a common set of evaluated +free variables, in which case the duplication is a plain waste. + +Another thing we could consider adding is some unfold-threshold thing, +so that we'll only duplicate if the size of the group rhss isn't too +big. + +Data types +~~~~~~~~~~ +The ``level'' of a binder tells how many +recursive defns lexically enclose the binding +A recursive defn "encloses" its RHS, not its +scope. For example: +\begin{verbatim} + letrec f = let g = ... in ... + in + let h = ... + in ... +\end{verbatim} +Here, the level of @f@ is zero, the level of @g@ is one, +and the level of @h@ is zero (NB not one). + + +************************************************************************ +* * + Top-level code +* * +************************************************************************ +-} + +liberateCase :: LibCaseOpts -> CoreProgram -> CoreProgram +liberateCase opts binds = do_prog (initLiberateCaseEnv opts) binds + where + do_prog _ [] = [] + do_prog env (bind:binds) = bind' : do_prog env' binds + where + (env', bind') = libCaseBind env bind + +initLiberateCaseEnv :: LibCaseOpts -> LibCaseEnv +initLiberateCaseEnv opts = LibCaseEnv + { lc_opts = opts + , lc_lvl = 0 + , lc_lvl_env = emptyVarEnv + , lc_rec_env = emptyVarEnv + , lc_scruts = [] + } + +{- +************************************************************************ +* * + Main payload +* * +************************************************************************ + +Bindings +~~~~~~~~ +-} + +libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind) + +libCaseBind env (NonRec binder rhs) + = (addBinders env [binder], NonRec binder (libCase env rhs)) + +libCaseBind env (Rec pairs) + = (env_body, Rec pairs') + where + binders = map fst pairs + + env_body = addBinders env binders + + pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs] + + -- We extend the rec-env by binding each Id to its rhs, first + -- processing the rhs with an *un-extended* environment, so + -- that the same process doesn't occur for ever! + env_rhs | is_dupable_bind = addRecBinds env dup_pairs + | otherwise = env + + dup_pairs = [ (localiseId binder, libCase env_body rhs) + | (binder, rhs) <- pairs ] + -- localiseID : see Note [Need to localiseId in libCaseBind] + + is_dupable_bind = small_enough && all ok_pair pairs + + -- Size: we are going to duplicate dup_pairs; to find their + -- size, build a fake binding (let { dup_pairs } in (), + -- and find the size of that + -- See Note [Small enough] + small_enough = case lc_threshold env of + Nothing -> True -- Infinity + Just size -> couldBeSmallEnoughToInline (lc_uf_opts env) size $ + Let (Rec dup_pairs) (Var unitDataConId) + + ok_pair (id,_) + = idArity id > 0 -- Note [Only functions!] + && not (isDeadEndId id) -- Note [Not bottoming Ids] + +{- Note [Not bottoming Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not specialise error-functions (this is unusual, but I once saw it, +(actually in Data.Typeable.Internal) + +Note [Only functions!] +~~~~~~~~~~~~~~~~~~~~~~ +Consider the following code + + f = g (case v of V a b -> a : t f) + +where g is expensive. If we aren't careful, liberate case will turn this into + + f = g (case v of + V a b -> a : t (letrec f = g (case v of V a b -> a : f t) + in f) + ) + +Yikes! We evaluate g twice. This leads to a O(2^n) explosion +if g calls back to the same code recursively. + +Solution: make sure that we only do the liberate-case thing on *functions* + +Note [Small enough] +~~~~~~~~~~~~~~~~~~~ +Consider + \fv. letrec + f = \x. BIG...(case fv of { (a,b) -> ...g.. })... + g = \y. SMALL...f... + +Then we *can* in principle do liberate-case on 'g' (small RHS) but not +for 'f' (too big). But doing so is not profitable, because duplicating +'g' at its call site in 'f' doesn't get rid of any cases. So we just +ask for the whole group to be small enough. + +Note [Need to localiseId in libCaseBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The call to localiseId is needed for two subtle reasons +(a) Reset the export flags on the binders so + that we don't get name clashes on exported things if the + local binding floats out to top level. This is most unlikely + to happen, since the whole point concerns free variables. + But resetting the export flag is right regardless. + +(b) Make the name an Internal one. External Names should never be + nested; if it were floated to the top level, we'd get a name + clash at code generation time. + +Expressions +~~~~~~~~~~~ +-} + +libCase :: LibCaseEnv + -> CoreExpr + -> CoreExpr + +libCase env (Var v) = libCaseApp env v [] +libCase _ (Lit lit) = Lit lit +libCase _ (Type ty) = Type ty +libCase _ (Coercion co) = Coercion co +libCase env e@(App {}) | let (fun, args) = collectArgs e + , Var v <- fun + = libCaseApp env v args +libCase env (App fun arg) = App (libCase env fun) (libCase env arg) +libCase env (Tick tickish body) = Tick tickish (libCase env body) +libCase env (Cast e co) = Cast (libCase env e) co + +libCase env (Lam binder body) + = Lam binder (libCase (addBinders env [binder]) body) + +libCase env (Let bind body) + = Let bind' (libCase env_body body) + where + (env_body, bind') = libCaseBind env bind + +libCase env (Case scrut bndr ty alts) + = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) + where + env_alts = addBinders (mk_alt_env scrut) [bndr] + mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var + mk_alt_env (Cast scrut _) = mk_alt_env scrut -- Note [Scrutinee with cast] + mk_alt_env _ = env + +libCaseAlt :: LibCaseEnv -> Alt CoreBndr -> Alt CoreBndr +libCaseAlt env (Alt con args rhs) = Alt con args (libCase (addBinders env args) rhs) + +{- +Ids +~~~ + +To unfold, we can't just wrap the id itself in its binding if it's a join point: + + jump j a b c => (joinrec j x y z = ... in jump j) a b c -- wrong!!! + +Every jump must provide all arguments, so we have to be careful to wrap the +whole jump instead: + + jump j a b c => joinrec j x y z = ... in jump j a b c -- right + +-} + +libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr +libCaseApp env v args + | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing + , notNull free_scruts -- with free vars scrutinised in RHS + = Let the_bind expr' + + | otherwise + = expr' + + where + rec_id_level = lookupLevel env v + free_scruts = freeScruts env rec_id_level + expr' = mkApps (Var v) (map (libCase env) args) + +freeScruts :: LibCaseEnv + -> LibCaseLevel -- Level of the recursive Id + -> [Id] -- Ids that are scrutinised between the binding + -- of the recursive Id and here +freeScruts env rec_bind_lvl + = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env + , scrut_bind_lvl <= rec_bind_lvl + , scrut_at_lvl > rec_bind_lvl] + -- Note [When to specialise] + -- Note [Avoiding fruitless liberate-case] + +{- +Note [When to specialise] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = \x. letrec g = \y. case x of + True -> ... (f a) ... + False -> ... (g b) ... + +We get the following levels + f 0 + x 1 + g 1 + y 2 + +Then 'x' is being scrutinised at a deeper level than its binding, so +it's added to lc_sruts: [(x,1)] + +We do *not* want to specialise the call to 'f', because 'x' is not free +in 'f'. So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0). + +We *do* want to specialise the call to 'g', because 'x' is free in g. +Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1). + +Note [Avoiding fruitless liberate-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider also: + f = \x. case top_lvl_thing of + I# _ -> let g = \y. ... g ... + in ... + +Here, top_lvl_thing is scrutinised at a level (1) deeper than its +binding site (0). Nevertheless, we do NOT want to specialise the call +to 'g' because all the structure in its free variables is already +visible at the definition site for g. Hence, when considering specialising +an occurrence of 'g', we want to check that there's a scruted-var v st + + a) v's binding site is *outside* g + b) v's scrutinisation site is *inside* g + + +************************************************************************ +* * + Utility functions +* * +************************************************************************ +-} + +addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv +addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders + = env { lc_lvl_env = lvl_env' } + where + lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl) + +addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv +addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env, + lc_rec_env = rec_env}) pairs + = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' } + where + lvl' = lvl + 1 + lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs] + rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs] + +addScrutedVar :: LibCaseEnv + -> Id -- This Id is being scrutinised by a case expression + -> LibCaseEnv + +addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env, + lc_scruts = scruts }) scrut_var + | bind_lvl < lvl + = env { lc_scruts = scruts' } + -- Add to scruts iff the scrut_var is being scrutinised at + -- a deeper level than its defn + + | otherwise = env + where + scruts' = (scrut_var, bind_lvl, lvl) : scruts + bind_lvl = case lookupVarEnv lvl_env scrut_var of + Just lvl -> lvl + Nothing -> topLevel + +lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind +lookupRecId env id = lookupVarEnv (lc_rec_env env) id + +lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel +lookupLevel env id + = case lookupVarEnv (lc_lvl_env env) id of + Just lvl -> lvl + Nothing -> topLevel + +{- +************************************************************************ +* * + Options +* * +************************************************************************ +-} + +-- | Options for the liberate case pass. +data LibCaseOpts = LibCaseOpts + { -- | Bomb-out size for deciding if potential liberatees are too big. + lco_threshold :: !(Maybe Int) + -- | Unfolding options + , lco_unfolding_opts :: !UnfoldingOpts + } + +{- +************************************************************************ +* * + The environment +* * +************************************************************************ +-} + +type LibCaseLevel = Int + +topLevel :: LibCaseLevel +topLevel = 0 + +lc_threshold :: LibCaseEnv -> Maybe Int +lc_threshold = lco_threshold . lc_opts + +lc_uf_opts :: LibCaseEnv -> UnfoldingOpts +lc_uf_opts = lco_unfolding_opts . lc_opts + +data LibCaseEnv + = LibCaseEnv { + lc_opts :: !LibCaseOpts, + -- ^ liberate case options + + lc_lvl :: LibCaseLevel, -- ^ Current level + -- The level is incremented when (and only when) going + -- inside the RHS of a (sufficiently small) recursive + -- function. + + lc_lvl_env :: IdEnv LibCaseLevel, + -- ^ Binds all non-top-level in-scope Ids (top-level and + -- imported things have a level of zero) + + lc_rec_env :: IdEnv CoreBind, + -- ^ Binds *only* recursively defined ids, to their own + -- binding group, and *only* in their own RHSs + + lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)] + -- ^ Each of these Ids was scrutinised by an enclosing + -- case expression, at a level deeper than its binding + -- level. + -- + -- The first LibCaseLevel is the *binding level* of + -- the scrutinised Id, + -- The second is the level *at which it was scrutinised*. + -- (see Note [Avoiding fruitless liberate-case]) + -- The former is a bit redundant, since you could always + -- look it up in lc_lvl_env, but it's just cached here + -- + -- The order is insignificant; it's a bag really + -- + -- There's one element per scrutinisation; + -- in principle the same Id may appear multiple times, + -- although that'd be unusual: + -- case x of { (a,b) -> ....(case x of ...) .. } + } diff --git a/GHC/Core/Opt/Monad.hs b/GHC/Core/Opt/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Monad.hs @@ -0,0 +1,404 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + + +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Core.Opt.Monad ( + -- * Types used in core-to-core passes + FloatOutSwitches(..), + + -- * The monad + CoreM, runCoreM, + + mapDynFlagsCoreM, dropSimplCount, + + -- ** Reading from the monad + getHscEnv, getModule, + initRuleEnv, getExternalRuleBase, + getDynFlags, getPackageFamInstEnv, + getInteractiveContext, + getUniqTag, + getNamePprCtx, getSrcSpanM, + + -- ** Writing to the monad + addSimplCount, + + -- ** Lifting into the monad + liftIO, liftIOWithCount, + + -- ** Dealing with annotations + getAnnotations, getFirstAnnotations, + + -- ** Screen output + putMsg, putMsgS, errorMsg, msg, + fatalErrorMsg, fatalErrorMsgS, + debugTraceMsg, debugTraceMsgS, + ) where + +import GHC.Prelude hiding ( read ) + +import GHC.Driver.DynFlags +import GHC.Driver.Env + +import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv ) +import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount ) + +import GHC.Types.Annotations +import GHC.Types.Unique.Supply +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Types.Error + +import GHC.Utils.Error ( errorDiagnostic ) +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Logger +import GHC.Utils.Monad + +import GHC.Data.IOEnv hiding ( liftIO, failM, failWithM ) +import qualified GHC.Data.IOEnv as IOEnv + +import GHC.Runtime.Context ( InteractiveContext ) + +import GHC.Unit.Module +import GHC.Unit.Module.ModGuts +import GHC.Unit.External + +import Data.Bifunctor ( bimap ) +import Data.Dynamic +import Data.Maybe (listToMaybe) +import Data.Word +import Control.Monad +import Control.Applicative ( Alternative(..) ) + +data FloatOutSwitches = FloatOutSwitches + { floatOutLambdas :: Maybe Int -- ^ Just n <=> float lambdas to top level, if + -- doing so will abstract over n or fewer + -- value variables + -- Nothing <=> float all lambdas to top level, + -- regardless of how many free variables + -- Just 0 is the vanilla case: float a lambda + -- iff it has no free vars + + , floatOutConstants :: Bool -- ^ True <=> float constants to top level, + -- even if they do not escape a lambda + + , floatOutOverSatApps :: Bool -- ^ True <=> float out over-saturated applications + -- based on arity information. + -- See Note [Floating over-saturated applications] + -- in GHC.Core.Opt.SetLevels + , floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. + + , floatJoinsToTop :: Bool -- ^ Float join points to top level if possible + -- See Note [Floating join point bindings] + -- in GHC.Core.Opt.SetLevels + } +instance Outputable FloatOutSwitches where + ppr = pprFloatOutSwitches + +pprFloatOutSwitches :: FloatOutSwitches -> SDoc +pprFloatOutSwitches sw + = text "FOS" <+> (braces $ + sep $ punctuate comma $ + [ text "Lam =" <+> ppr (floatOutLambdas sw) + , text "Consts =" <+> ppr (floatOutConstants sw) + , text "JoinsToTop =" <+> ppr (floatJoinsToTop sw) + , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) + +{- +************************************************************************ +* * + Monad and carried data structure definitions +* * +************************************************************************ +-} + +data CoreReader = CoreReader { + cr_hsc_env :: HscEnv, + cr_rule_base :: RuleBase, -- Home package table rules + cr_module :: Module, + cr_name_ppr_ctx :: NamePprCtx, + cr_loc :: SrcSpan, -- Use this for log/error messages so they + -- are at least tagged with the right source file + cr_uniq_tag :: !Char -- Tag for creating unique values +} + +-- Note: CoreWriter used to be defined with data, rather than newtype. If it +-- is defined that way again, the cw_simpl_count field, at least, must be +-- strict to avoid a space leak (#7702). +newtype CoreWriter = CoreWriter { + cw_simpl_count :: SimplCount +} + +emptyWriter :: Bool -- ^ -ddump-simpl-stats + -> CoreWriter +emptyWriter dump_simpl_stats = CoreWriter { + cw_simpl_count = zeroSimplCount dump_simpl_stats + } + +plusWriter :: CoreWriter -> CoreWriter -> CoreWriter +plusWriter w1 w2 = CoreWriter { + cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2) + } + +type CoreIOEnv = IOEnv CoreReader + +-- | The monad used by Core-to-Core passes to register simplification statistics. +-- Also used to have common state (in the form of UniqueSupply) for generating Uniques. +newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } + deriving (Functor) + +instance Monad CoreM where + mx >>= f = CoreM $ do + (x, w1) <- unCoreM mx + (y, w2) <- unCoreM (f x) + let w = w1 `plusWriter` w2 + return $ seq w (y, w) + -- forcing w before building the tuple avoids a space leak + -- (#7702) + +instance Applicative CoreM where + pure x = CoreM $ nop x + (<*>) = ap + m *> k = m >>= \_ -> k + +instance Alternative CoreM where + empty = CoreM Control.Applicative.empty + m <|> n = CoreM (unCoreM m <|> unCoreM n) + +instance MonadPlus CoreM + +instance MonadUnique CoreM where + getUniqueSupplyM = do + tag <- read cr_uniq_tag + liftIO $! mkSplitUniqSupply tag + + getUniqueM = do + tag <- read cr_uniq_tag + liftIO $! uniqFromTag tag + +runCoreM :: HscEnv + -> RuleBase + -> Char -- ^ Mask + -> Module + -> NamePprCtx + -> SrcSpan + -> CoreM a + -> IO (a, SimplCount) +runCoreM hsc_env rule_base tag mod name_ppr_ctx loc m + = liftM extract $ runIOEnv reader $ unCoreM m + where + reader = CoreReader { + cr_hsc_env = hsc_env, + cr_rule_base = rule_base, + cr_module = mod, + cr_name_ppr_ctx = name_ppr_ctx, + cr_loc = loc, + cr_uniq_tag = tag + } + + extract :: (a, CoreWriter) -> (a, SimplCount) + extract (value, writer) = (value, cw_simpl_count writer) + +{- +************************************************************************ +* * + Core combinators, not exported +* * +************************************************************************ +-} + +nop :: a -> CoreIOEnv (a, CoreWriter) +nop x = do + logger <- hsc_logger . cr_hsc_env <$> getEnv + return (x, emptyWriter $ logHasDumpFlag logger Opt_D_dump_simpl_stats) + +read :: (CoreReader -> a) -> CoreM a +read f = CoreM $ getEnv >>= (\r -> nop (f r)) + +write :: CoreWriter -> CoreM () +write w = CoreM $ return ((), w) + +-- \subsection{Lifting IO into the monad} + +-- | Lift an 'IOEnv' operation into 'CoreM' +liftIOEnv :: CoreIOEnv a -> CoreM a +liftIOEnv mx = CoreM (mx >>= (\x -> nop x)) + +instance MonadIO CoreM where + liftIO = liftIOEnv . IOEnv.liftIO + +-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount' +liftIOWithCount :: IO (SimplCount, a) -> CoreM a +liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x) + +{- +************************************************************************ +* * + Reader, writer and state accessors +* * +************************************************************************ +-} + +getHscEnv :: CoreM HscEnv +getHscEnv = read cr_hsc_env + +getHomeRuleBase :: CoreM RuleBase +getHomeRuleBase = read cr_rule_base + +initRuleEnv :: ModGuts -> CoreM RuleEnv +initRuleEnv guts + = do { hpt_rules <- getHomeRuleBase + ; eps_rules <- getExternalRuleBase + ; return (mkRuleEnv guts eps_rules hpt_rules) } + +getExternalRuleBase :: CoreM RuleBase +getExternalRuleBase = eps_rule_base <$> get_eps + +getNamePprCtx :: CoreM NamePprCtx +getNamePprCtx = read cr_name_ppr_ctx + +getSrcSpanM :: CoreM SrcSpan +getSrcSpanM = read cr_loc + +addSimplCount :: SimplCount -> CoreM () +addSimplCount count = write (CoreWriter { cw_simpl_count = count }) + +getUniqTag :: CoreM Char +getUniqTag = read cr_uniq_tag + +-- Convenience accessors for useful fields of HscEnv + +-- | Adjust the dyn flags passed to the argument action +mapDynFlagsCoreM :: (DynFlags -> DynFlags) -> CoreM a -> CoreM a +mapDynFlagsCoreM f m = CoreM $ do + !e <- getEnv + let !e' = e { cr_hsc_env = hscUpdateFlags f $ cr_hsc_env e } + liftIO $ runIOEnv e' $! unCoreM m + +-- | Drop the single count of the argument action so it doesn't effect +-- the total. +dropSimplCount :: CoreM a -> CoreM a +dropSimplCount m = CoreM $ do + (a, _) <- unCoreM m + unCoreM $ pure a + +instance HasDynFlags CoreM where + getDynFlags = fmap hsc_dflags getHscEnv + +instance HasLogger CoreM where + getLogger = fmap hsc_logger getHscEnv + +instance HasModule CoreM where + getModule = read cr_module + +getInteractiveContext :: CoreM InteractiveContext +getInteractiveContext = hsc_IC <$> getHscEnv + +getPackageFamInstEnv :: CoreM PackageFamInstEnv +getPackageFamInstEnv = eps_fam_inst_env <$> get_eps + +get_eps :: CoreM ExternalPackageState +get_eps = do + hsc_env <- getHscEnv + liftIO $ hscEPS hsc_env + +{- +************************************************************************ +* * + Dealing with annotations +* * +************************************************************************ +-} + +-- | Get all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +-- +-- This should be done once at the start of a Core-to-Core pass that uses +-- annotations. +-- +-- See Note [Annotations] +getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a]) +getAnnotations deserialize guts = do + hsc_env <- getHscEnv + ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) + return (deserializeAnns deserialize ann_env) + +-- | Get at most one annotation of a given type per annotatable item. +getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a) +getFirstAnnotations deserialize guts + = bimap mod name <$> getAnnotations deserialize guts + where + mod = mapMaybeModuleEnv (const listToMaybe) + name = mapMaybeNameEnv listToMaybe + +{- +Note [Annotations] +~~~~~~~~~~~~~~~~~~ +A Core-to-Core pass that wants to make use of annotations calls +getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with +annotations of a specific type. This produces all annotations from interface +files read so far. However, annotations from interface files read during the +pass will not be visible until getAnnotations is called again. This is similar +to how rules work and probably isn't too bad. + +The current implementation could be optimised a bit: when looking up +annotations for a thing from the HomePackageTable, we could search directly in +the module where the thing is defined rather than building one UniqFM which +contains all annotations we know of. This would work because annotations can +only be given to things defined in the same module. However, since we would +only want to deserialise every annotation once, we would have to build a cache +for every module in the HTP. In the end, it's probably not worth it as long as +we aren't using annotations heavily. + +************************************************************************ +* * + Direct screen output +* * +************************************************************************ +-} + +msg :: MessageClass -> SDoc -> CoreM () +msg msg_class doc = do + logger <- getLogger + loc <- getSrcSpanM + name_ppr_ctx <- getNamePprCtx + let sty = case msg_class of + MCDiagnostic _ _ _ -> err_sty + MCDump -> dump_sty + _ -> user_sty + err_sty = mkErrStyle name_ppr_ctx + user_sty = mkUserStyle name_ppr_ctx AllTheWay + dump_sty = mkDumpStyle name_ppr_ctx + liftIO $ logMsg logger msg_class loc (withPprStyle sty doc) + +-- | Output a String message to the screen +putMsgS :: String -> CoreM () +putMsgS = putMsg . text + +-- | Output a message to the screen +putMsg :: SDoc -> CoreM () +putMsg = msg MCInfo + +-- | Output an error to the screen. Does not cause the compiler to die. +errorMsg :: SDoc -> CoreM () +errorMsg doc = msg errorDiagnostic doc + +-- | Output a fatal error to the screen. Does not cause the compiler to die. +fatalErrorMsgS :: String -> CoreM () +fatalErrorMsgS = fatalErrorMsg . text + +-- | Output a fatal error to the screen. Does not cause the compiler to die. +fatalErrorMsg :: SDoc -> CoreM () +fatalErrorMsg = msg MCFatal + +-- | Output a string debugging message at verbosity level of @-v@ or higher +debugTraceMsgS :: String -> CoreM () +debugTraceMsgS = debugTraceMsg . text + +-- | Outputs a debugging message at verbosity level of @-v@ or higher +debugTraceMsg :: SDoc -> CoreM () +debugTraceMsg = msg MCDump diff --git a/GHC/Core/Opt/OccurAnal.hs b/GHC/Core/Opt/OccurAnal.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/OccurAnal.hs @@ -0,0 +1,4075 @@ +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -cpp -Wno-incomplete-record-updates #-} + +{-# OPTIONS_GHC -fmax-worker-args=12 #-} +-- The -fmax-worker-args=12 is there because the main functions +-- are strict in the OccEnv, and it turned out that with the default settting +-- some functions would unbox the OccEnv ad some would not, depending on how +-- many /other/ arguments the function has. Inconsistent unboxing is very +-- bad for performance, so I increased the limit to allow it to unbox +-- consistently. + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +************************************************************************ +* * +\section[OccurAnal]{Occurrence analysis pass} +* * +************************************************************************ + +The occurrence analyser re-typechecks a core expression, returning a new +core expression with (hopefully) improved usage information. +-} + +module GHC.Core.Opt.OccurAnal ( + occurAnalysePgm, + occurAnalyseExpr, + zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap + ) where + +import GHC.Prelude hiding ( head, init, last, tail ) + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, + mkCastMCo, mkTicks ) +import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) +import GHC.Core.Coercion +import GHC.Core.Type +import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo ) + +import GHC.Data.Maybe( orElse ) +import GHC.Data.Graph.Directed ( SCC(..), Node(..) + , stronglyConnCompFromEdgedVerticesUniq + , stronglyConnCompFromEdgedVerticesUniqR ) +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Basic +import GHC.Types.Tickish +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Var +import GHC.Types.Demand ( argOneShots, argsOneShots, isDeadEndSig ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Builtin.Names( runRWKey ) +import GHC.Unit.Module( Module ) + +import Data.List (mapAccumL) +import Data.List.NonEmpty (NonEmpty (..)) + +{- +************************************************************************ +* * + occurAnalysePgm, occurAnalyseExpr +* * +************************************************************************ + +Here's the externally-callable interface: +-} + +-- | Do occurrence analysis, and discard occurrence info returned +occurAnalyseExpr :: CoreExpr -> CoreExpr +occurAnalyseExpr expr = expr' + where + WUD _ expr' = occAnal initOccEnv expr + +occurAnalysePgm :: Module -- Used only in debug output + -> (Id -> Bool) -- Active unfoldings + -> (Activation -> Bool) -- Active rules + -> [CoreRule] -- Local rules for imported Ids + -> CoreProgram -> CoreProgram +occurAnalysePgm this_mod active_unf active_rule imp_rules binds + | isEmptyDetails final_usage + = occ_anald_binds + + | otherwise -- See Note [Glomming] + = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage)) + occ_anald_glommed_binds + where + init_env = initOccEnv { occ_rule_act = active_rule + , occ_unf_act = active_unf } + + WUD final_usage occ_anald_binds = go binds init_env + WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel + imp_rule_edges + (flattenBinds binds) + initial_uds + -- It's crucial to re-analyse the glommed-together bindings + -- so that we establish the right loop breakers. Otherwise + -- we can easily create an infinite loop (#9583 is an example) + -- + -- Also crucial to re-analyse the /original/ bindings + -- in case the first pass accidentally discarded as dead code + -- a binding that was actually needed (albeit before its + -- definition site). #17724 threw this up. + + initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules) + -- The RULES declarations keep things alive! + + -- imp_rule_edges maps a top-level local binder 'f' to the + -- RHS free vars of any IMP-RULE, a local RULE for an imported function, + -- where 'f' appears on the LHS + -- e.g. RULE foldr f = blah + -- imp_rule_edges contains f :-> fvs(blah) + -- We treat such RULES as extra rules for 'f' + -- See Note [Preventing loops due to imported functions rules] + imp_rule_edges :: ImpRuleEdges + imp_rule_edges = foldr (plusVarEnv_C (++)) emptyVarEnv + [ mapVarEnv (const [(act,rhs_fvs)]) $ getUniqSet $ + exprsFreeIds args `delVarSetList` bndrs + | Rule { ru_act = act, ru_bndrs = bndrs + , ru_args = args, ru_rhs = rhs } <- imp_rules + -- Not BuiltinRules; see Note [Plugin rules] + , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ] + + go :: [CoreBind] -> OccEnv -> WithUsageDetails [CoreBind] + go [] _ = WUD initial_uds [] + go (bind:binds) env = occAnalBind env TopLevel + imp_rule_edges bind (go binds) (++) + +{- ********************************************************************* +* * + IMP-RULES + Local rules for imported functions +* * +********************************************************************* -} + +type ImpRuleEdges = IdEnv [(Activation, VarSet)] + -- Mapping from a local Id 'f' to info about its IMP-RULES, + -- i.e. /local/ rules for an imported Id that mention 'f' on the LHS + -- We record (a) its Activation and (b) the RHS free vars + -- See Note [IMP-RULES: local rules for imported functions] + +noImpRuleEdges :: ImpRuleEdges +noImpRuleEdges = emptyVarEnv + +lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)] +lookupImpRules imp_rule_edges bndr + = case lookupVarEnv imp_rule_edges bndr of + Nothing -> [] + Just vs -> vs + +impRulesScopeUsage :: [(Activation,VarSet)] -> UsageDetails +-- Variable mentioned in RHS of an IMP-RULE for the bndr, +-- whether active or not +impRulesScopeUsage imp_rules_info + = foldr add emptyDetails imp_rules_info + where + add (_,vs) usage = addManyOccs usage vs + +impRulesActiveFvs :: (Activation -> Bool) -> VarSet + -> [(Activation,VarSet)] -> VarSet +impRulesActiveFvs is_active bndr_set vs + = foldr add emptyVarSet vs `intersectVarSet` bndr_set + where + add (act,vs) acc | is_active act = vs `unionVarSet` acc + | otherwise = acc + +{- Note [IMP-RULES: local rules for imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We quite often have + * A /local/ rule + * for an /imported/ function +like this: + foo x = blah + {-# RULE "map/foo" forall xs. map foo xs = xs #-} +We call them IMP-RULES. They are important in practice, and occur a +lot in the libraries. + +IMP-RULES are held in mg_rules of ModGuts, and passed in to +occurAnalysePgm. + +Main Invariant: + +* Throughout, we treat an IMP-RULE that mentions 'f' on its LHS + just like a RULE for f. + +Note [IMP-RULES: unavoidable loops] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + f = /\a. B.g a + RULE B.g Int = 1 + f Int +Note that + * The RULE is for an imported function. + * f is non-recursive +Now we +can get + f Int --> B.g Int Inlining f + --> 1 + f Int Firing RULE +and so the simplifier goes into an infinite loop. This +would not happen if the RULE was for a local function, +because we keep track of dependencies through rules. But +that is pretty much impossible to do for imported Ids. Suppose +f's definition had been + f = /\a. C.h a +where (by some long and devious process), C.h eventually inlines to +B.g. We could only spot such loops by exhaustively following +unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) +f. + +We regard this potential infinite loop as a *programmer* error. +It's up the programmer not to write silly rules like + RULE f x = f x +and the example above is just a more complicated version. + +Note [Specialising imported functions] (referred to from Specialise) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For *automatically-generated* rules, the programmer can't be +responsible for the "programmer error" in Note [IMP-RULES: unavoidable +loops]. In particular, consider specialising a recursive function +defined in another module. If we specialise a recursive function B.g, +we get + g_spec = .....(B.g Int)..... + RULE B.g Int = g_spec +Here, g_spec doesn't look recursive, but when the rule fires, it +becomes so. And if B.g was mutually recursive, the loop might not be +as obvious as it is here. + +To avoid this, + * When specialising a function that is a loop breaker, + give a NOINLINE pragma to the specialised function + +Note [Preventing loops due to imported functions rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + import GHC.Base (foldr) + + {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} + filter p xs = build (\c n -> foldr (filterFB c p) n xs) + filterFB c p = ... + + f = filter p xs + +Note that filter is not a loop-breaker, so what happens is: + f = filter p xs + = {inline} build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +We are in an infinite loop. + +A more elaborate example (that I actually saw in practice when I went to +mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: + {-# LANGUAGE RankNTypes #-} + module GHCList where + + import Prelude hiding (filter) + import GHC.Base (build) + + {-# INLINABLE filter #-} + filter :: (a -> Bool) -> [a] -> [a] + filter p [] = [] + filter p (x:xs) = if p x then x : filter p xs else filter p xs + + {-# NOINLINE [0] filterFB #-} + filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b + filterFB c p x r | p x = x `c` r + | otherwise = r + + {-# RULES + "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr + (filterFB c p) n xs) + "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p + #-} + +Then (because RULES are applied inside INLINABLE unfoldings, but inlinings +are not), the unfolding given to "filter" in the interface file will be: + filter p [] = [] + filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs + +Note that because this unfolding does not mention "filter", filter is not +marked as a strong loop breaker. Therefore at a use site in another module: + filter p xs + = {inline} + case xs of [] -> [] + (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs) + + build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +And we are in an infinite loop again, except that this time the loop is producing an +infinitely large *term* (an unrolling of filter) and so the simplifier finally +dies with "ticks exhausted" + +SOLUTION: we treat the rule "filterList" as an extra rule for 'filterFB' +because it mentions 'filterFB' on the LHS. This is the Main Invariant +in Note [IMP-RULES: local rules for imported functions]. + +So, during loop-breaker analysis: + +- for each active RULE for a local function 'f' we add an edge between + 'f' and the local FVs of the rule RHS + +- for each active RULE for an *imported* function we add dependency + edges between the *local* FVS of the rule LHS and the *local* FVS of + the rule RHS. + +Even with this extra hack we aren't always going to get things +right. For example, it might be that the rule LHS mentions an imported +Id, and another module has a RULE that can rewrite that imported Id to +one of our local Ids. + +Note [Plugin rules] +~~~~~~~~~~~~~~~~~~~ +Conal Elliott (#11651) built a GHC plugin that added some +BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to +do some domain-specific transformations that could not be expressed +with an ordinary pattern-matching CoreRule. But then we can't extract +the dependencies (in imp_rule_edges) from ru_rhs etc, because a +BuiltinRule doesn't have any of that stuff. + +So we simply assume that BuiltinRules have no dependencies, and filter +them out from the imp_rule_edges comprehension. + +Note [Glomming] +~~~~~~~~~~~~~~~ +RULES for imported Ids can make something at the top refer to +something at the bottom: + + foo = ...(B.f @Int)... + $sf = blah + RULE: B.f @Int = $sf + +Applying this rule makes foo refer to $sf, although foo doesn't appear to +depend on $sf. (And, as in Note [IMP-RULES: local rules for imported functions], the +dependency might be more indirect. For example, foo might mention C.t +rather than B.f, where C.t eventually inlines to B.f.) + +NOTICE that this cannot happen for rules whose head is a +locally-defined function, because we accurately track dependencies +through RULES. It only happens for rules whose head is an imported +function (B.f in the example above). + +Solution: + - When simplifying, bring all top level identifiers into + scope at the start, ignoring the Rec/NonRec structure, so + that when 'h' pops up in f's rhs, we find it in the in-scope set + (as the simplifier generally expects). This happens in simplTopBinds. + + - In the occurrence analyser, if there are any out-of-scope + occurrences that pop out of the top, which will happen after + firing the rule: f = \x -> h x + h = \y -> 3 + then just glom all the bindings into a single Rec, so that + the *next* iteration of the occurrence analyser will sort + them all out. This part happens in occurAnalysePgm. + +This is a legitimate situation where the need for glomming doesn't +point to any problems. However, when GHC is compiled with -DDEBUG, we +produce a warning addressed to the GHC developers just in case we +require glomming due to an out-of-order reference that is caused by +some earlier transformation stage misbehaving. +-} + +{- +************************************************************************ +* * + Bindings +* * +************************************************************************ + +Note [Recursive bindings: the grand plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Loop breaking is surprisingly subtle. First read the section 4 of +"Secrets of the GHC inliner". This describes our basic plan. We +avoid infinite inlinings by choosing loop breakers, and ensuring that +a loop breaker cuts each loop. + +See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which +deals with a closely related source of infinite loops. + +When we come across a binding group + Rec { x1 = r1; ...; xn = rn } +we treat it like this (occAnalRecBind): + +1. Note [Forming Rec groups] + Occurrence-analyse each right hand side, and build a + "Details" for each binding to capture the results. + Wrap the details in a LetrecNode, ready for SCC analysis. + All this is done by makeNode. + + The edges of this graph are the "scope edges". + +2. Do SCC-analysis on these Nodes: + - Each CyclicSCC will become a new Rec + - Each AcyclicSCC will become a new NonRec + + The key property is that every free variable of a binding is + accounted for by the scope edges, so that when we are done + everything is still in scope. + +3. For each AcyclicSCC, just make a NonRec binding. + +4. For each CyclicSCC of the scope-edge SCC-analysis in (2), we + identify suitable loop-breakers to ensure that inlining terminates. + This is done by occAnalRec. + + To do so, form the loop-breaker graph, do SCC analysis. For each + CyclicSCC we choose a loop breaker, delete all edges to that node, + re-analyse the SCC, and iterate. See Note [Choosing loop breakers] + for the details + + +Note [Dead code] +~~~~~~~~~~~~~~~~ +Dropping dead code for a cyclic Strongly Connected Component is done +in a very simple way: + + the entire SCC is dropped if none of its binders are mentioned + in the body; otherwise the whole thing is kept. + +The key observation is that dead code elimination happens after +dependency analysis: so 'occAnalBind' processes SCCs instead of the +original term's binding groups. + +Thus 'occAnalBind' does indeed drop 'f' in an example like + + letrec f = ...g... + g = ...(...g...)... + in + ...g... + +when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in +'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes +'AcyclicSCC f', where 'body_usage' won't contain 'f'. + +Note [Forming Rec groups] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The key point about the "Forming Rec groups" step is that it /preserves +scoping/. If 'x' is mentioned, it had better be bound somewhere. So if +we start with + Rec { f = ...h... + ; g = ...f... + ; h = ...f... } +we can split into SCCs + Rec { f = ...h... + ; h = ..f... } + NonRec { g = ...f... } + +We put bindings {f = ef; g = eg } in a Rec group if "f uses g" and "g +uses f", no matter how indirectly. We do a SCC analysis with an edge +f -> g if "f mentions g". That is, g is free in: + a) the rhs 'ef' + b) or the RHS of a rule for f, whether active or inactive + Note [Rules are extra RHSs] + c) or the LHS or a rule for f, whether active or inactive + Note [Rule dependency info] + d) the RHS of an /active/ local IMP-RULE + Note [IMP-RULES: local rules for imported functions] + +(b) and (c) apply regardless of the activation of the RULE, because even if +the rule is inactive its free variables must be bound. But (d) doesn't need +to worry about this because IMP-RULES are always notionally at the bottom +of the file. + + * Note [Rules are extra RHSs] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" + keeps the specialised "children" alive. If the parent dies + (because it isn't referenced any more), then the children will die + too (unless they are already referenced directly). + + So in Example [eftInt], eftInt and eftIntFB will be put in the + same Rec, even though their 'main' RHSs are both non-recursive. + + We must also include inactive rules, so that their free vars + remain in scope. + + * Note [Rule dependency info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The VarSet in a RuleInfo is used for dependency analysis in the + occurrence analyser. We must track free vars in *both* lhs and rhs. + Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. + Why both? Consider + x = y + RULE f x = v+4 + Then if we substitute y for x, we'd better do so in the + rule's LHS too, so we'd better ensure the RULE appears to mention 'x' + as well as 'v' + + * Note [Rules are visible in their own rec group] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We want the rules for 'f' to be visible in f's right-hand side. + And we'd like them to be visible in other functions in f's Rec + group. E.g. in Note [Specialisation rules] we want f' rule + to be visible in both f's RHS, and fs's RHS. + + This means that we must simplify the RULEs first, before looking + at any of the definitions. This is done by Simplify.simplRecBind, + when it calls addLetIdInfo. + +Note [TailUsageDetails when forming Rec groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The `TailUsageDetails` stored in the `nd_uds` field of a `NodeDetails` is +computed by `occAnalLamTail` applied to the RHS, not `occAnalExpr`. +That is because the binding might still become a *non-recursive join point* in +the AcyclicSCC case of dependency analysis! +Hence we do the delayed `adjustTailUsage` in `occAnalRec`/`tagRecBinders` to get +a regular, adjusted UsageDetails. +See Note [Join points and unfoldings/rules] for more details on the contract. + +Note [Stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~ +None of the above stuff about RULES applies to a stable unfolding +stored in a CoreUnfolding. The unfolding, if any, is simplified +at the same time as the regular RHS of the function (ie *not* like +Note [Rules are visible in their own rec group]), so it should be +treated *exactly* like an extra RHS. + +Or, rather, when computing loop-breaker edges, + * If f has an INLINE pragma, and it is active, we treat the + INLINE rhs as f's rhs + * If it's inactive, we treat f as having no rhs + * If it has no INLINE pragma, we look at f's actual rhs + + +There is a danger that we'll be sub-optimal if we see this + f = ...f... + [INLINE f = ..no f...] +where f is recursive, but the INLINE is not. This can just about +happen with a sufficiently odd set of rules; eg + + foo :: Int -> Int + {-# INLINE [1] foo #-} + foo x = x+1 + + bar :: Int -> Int + {-# INLINE [1] bar #-} + bar x = foo x + 1 + + {-# RULES "foo" [~1] forall x. foo x = bar x #-} + +Here the RULE makes bar recursive; but it's INLINE pragma remains +non-recursive. It's tempting to then say that 'bar' should not be +a loop breaker, but an attempt to do so goes wrong in two ways: + a) We may get + $df = ...$cfoo... + $cfoo = ...$df.... + [INLINE $cfoo = ...no-$df...] + But we want $cfoo to depend on $df explicitly so that we + put the bindings in the right order to inline $df in $cfoo + and perhaps break the loop altogether. (Maybe this + b) + + +Example [eftInt] +~~~~~~~~~~~~~~~ +Example (from GHC.Enum): + + eftInt :: Int# -> Int# -> [Int] + eftInt x y = ...(non-recursive)... + + {-# INLINE [0] eftIntFB #-} + eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r + eftIntFB c n x y = ...(non-recursive)... + + {-# RULES + "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) + "eftIntList" [1] eftIntFB (:) [] = eftInt + #-} + +Note [Specialisation rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this group, which is typical of what SpecConstr builds: + + fs a = ....f (C a).... + f x = ....f (C a).... + {-# RULE f (C a) = fs a #-} + +So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). + +But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: + - the RULE is applied in f's RHS (see Note [Rules for recursive functions] in GHC.Core.Opt.Simplify + - fs is inlined (say it's small) + - now there's another opportunity to apply the RULE + +This showed up when compiling Control.Concurrent.Chan.getChanContents. +Hence the transitive rule_fv_env stuff described in +Note [Rules and loop breakers]. + +Note [Occurrence analysis for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two somewhat artificial programs (#22404) + + Program (P1) Program (P2) + ------------------------------ ------------------------------------- + let v = in let v = in + join j = case v of (a,b) -> a + in case x of in case x of + A -> case v of (a,b) -> a A -> j + B -> case v of (a,b) -> a B -> j + C -> case v of (a,b) -> b C -> case v of (a,b) -> b + D -> [] D -> [] + +In (P1), `v` gets allocated, as a thunk, every time this code is executed. But +notice that `v` occurs at most once in any case branch; the occurrence analyser +spots this and returns a OneOcc{ occ_n_br = 3 } for `v`. Then the code in +GHC.Core.Opt.Simplify.Utils.postInlineUnconditionally inlines `v` at its three +use sites, and discards the let-binding. That way, we avoid allocating `v` in +the A,B,C branches (though we still compute it of course), and branch D +doesn't involve at all. This sometimes makes a Really Big +Difference. + +In (P2) we have shared the common RHS of A, B, in a join point `j`. We would +like to inline `v` in just the same way as in (P1). But the usual strategy +for let bindings is conservative and uses `andUDs` to combine usage from j's +RHS to its body; as if `j` was called on every code path (once, albeit). In +the case of (P2), we'll get ManyOccs for `v`. Important optimisation lost! + +Solving this problem makes the Simplifier less fragile. For example, +the Simplifier might inline `j`, and convert (P2) into (P1)... or it might +not, depending in a perhaps-fragile way on the size of the join point. +I was motivated to implement this feature of the occurrence analyser +when trying to make optimisation join points simpler and more robust +(see e.g. #23627). + +The occurrence analyser therefore has clever code that behaves just as +if you inlined `j` at all its call sites. Here is a tricky variant +to keep in mind: + + Program (P3) + ------------------------------- + join j = case v of (a,b) -> a + in case f v of + A -> j + B -> j + C -> [] + +If you mentally inline `j` you'll see that `v` is used twice on the path +through A, so it should have ManyOcc. Bear this case in mind! + +* We treat /non-recursive/ join points specially. Recursive join points are + treated like any other letrec, as before. Moreover, we only give this special + treatment to /pre-existing/ non-recursive join points, not the ones that we + discover for the first time in this sweep of the occurrence analyser. + +* In occ_env, the new (occ_join_points :: IdEnv OccInfoEnv) maps + each in-scope non-recursive join point, such as `j` above, to + a "zeroed form" of its RHS's usage details. The "zeroed form" + * deletes ManyOccs + * maps a OneOcc to OneOcc{ occ_n_br = 0 } + In our example, occ_join_points will be extended with + [j :-> [v :-> OneOcc{occ_n_br=0}]] + See addJoinPoint. + +* At an occurrence of a join point, we do everything as normal, but add in the + UsageDetails from the occ_join_points. See mkOneOcc. + +* Crucially, at the NonRec binding of the join point, in `occAnalBind`, we use + `orUDs`, not `andUDs` to combine the usage from the RHS with the usage from + the body. + +Here are the consequences + +* Because of the perhaps-surprising OneOcc{occ_n_br=0} idea of the zeroed + form, the occ_n_br field of a OneOcc binder still counts the number of + /actual lexical occurrences/ of the variable. In Program P2, for example, + `v` will end up with OneOcc{occ_n_br=2}, not occ_n_br=3. + There are two lexical occurrences of `v`! + (NB: `orUDs` adds occ_n_br together, so occ_n_br=1 is impossible, too.) + +* In the tricky (P3) we'll get an `andUDs` of + * OneOcc{occ_n_br=0} from the occurrences of `j`) + * OneOcc{occ_n_br=1} from the (f v) + These are `andUDs` together in `addOccInfo`, and hence + `v` gets ManyOccs, just as it should. Clever! + +There are a couple of tricky wrinkles + +(W1) Consider this example which shadows `j`: + join j = rhs in + in case x of { K j -> ..j..; ... } + Clearly when we come to the pattern `K j` we must drop the `j` + entry in occ_join_points. + + This is done by `drop_shadowed_joins` in `addInScope`. + +(W2) Consider this example which shadows `v`: + join j = ...v... + in case x of { K v -> ..j..; ... } + + We can't make j's occurrences in the K alternative give rise to an + occurrence of `v` (via occ_join_points), because it'll just be deleted by + the `K v` pattern. Yikes. This is rare because shadowing is rare, but + it definitely can happen. Solution: when bringing `v` into scope at + the `K v` pattern, chuck out of occ_join_points any elements whose + UsageDetails mentions `v`. Instead, just `andUDs` all that usage in + right here. + + This requires work in two places. + * In `preprocess_env`, we detect if the newly-bound variables intersect + the free vars of occ_join_points. (These free vars are conveniently + simply the domain of the OccInfoEnv for that join point.) If so, + we zap the entire occ_join_points. + * In `postprcess_uds`, we add the chucked-out join points to the + returned UsageDetails, with `andUDs`. + +(W3) Consider this example, which shadows `j`, but this time in an argument + join j = rhs + in f (case x of { K j -> ...; ... }) + We can zap the entire occ_join_points when looking at the argument, + because `j` can't posibly occur -- it's a join point! And the smaller + occ_join_points is, the better. Smaller to look up in mkOneOcc, and + more important, less looking-up when checking (W2). + + This is done in setNonTailCtxt. It's important /not/ to do this for + join-point RHS's because of course `j` can occur there! + + NB: this is just about efficiency: it is always safe /not/ to zap the + occ_join_points. + +(W4) What if the join point binding has a stable unfolding, or RULES? + They are just alternative right-hand sides, and at each call site we + will use only one of them. So again, we can use `orUDs` to combine + usage info from all these alternatives RHSs. + +Wrinkles (W1) and (W2) are very similar to Note [Binder swap] (BS3). + +Note [Finding join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's the occurrence analyser's job to find bindings that we can turn into join +points, but it doesn't perform that transformation right away. Rather, it marks +the eligible bindings as part of their occurrence data, leaving it to the +simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'. +The simplifier then eta-expands the RHS if needed and then updates the +occurrence sites. Dividing the work this way means that the occurrence analyser +still only takes one pass, yet one can always tell the difference between a +function call and a jump by looking at the occurrence (because the same pass +changes the 'IdDetails' and propagates the binders to their occurrence sites). + +To track potential join points, we use the 'occ_tail' field of OccInfo. A value +of `AlwaysTailCalled n` indicates that every occurrence of the variable is a +tail call with `n` arguments (counting both value and type arguments). Otherwise +'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the +rest of 'OccInfo' until it goes on the binder. + +Note [Join arity prediction based on joinRhsArity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, the join arity from tail occurrences of a join point (O) may be +higher or lower than the manifest join arity of the join body (M). E.g., + + -- M > O: + let f x y = x + y -- M = 2 + in if b then f 1 else f 2 -- O = 1 + ==> { Contify for join arity 1 } + join f x = \y -> x + y + in if b then jump f 1 else jump f 2 + + -- M < O + let f = id -- M = 0 + in if ... then f 12 else f 13 -- O = 1 + ==> { Contify for join arity 1, eta-expand f } + join f x = id x + in if b then jump f 12 else jump f 13 + +But for *recursive* let, it is crucial that both arities match up, consider + + letrec f x y = if ... then f x else True + in f 42 + +Here, M=2 but O=1. If we settled for a joinrec arity of 1, the recursive jump +would not happen in a tail context! Contification is invalid here. +So indeed it is crucial to demand that M=O. + +(Side note: Actually, we could be more specific: Let O1 be the join arity of +occurrences from the letrec RHS and O2 the join arity from the let body. Then +we need M=O1 and M<=O2 and could simply eta-expand the RHS to match O2 later. +M=O is the specific case where we don't want to eta-expand. Neither the join +points paper nor GHC does this at the moment.) + +We can capitalise on this observation and conclude that *if* f could become a +joinrec (without eta-expansion), it will have join arity M. +Now, M is just the result of 'joinRhsArity', a rather simple, local analysis. +It is also the join arity inside the 'TailUsageDetails' returned by +'occAnalLamTail', so we can predict join arity without doing any fixed-point +iteration or really doing any deep traversal of let body or RHS at all. +We check for M in the 'adjustTailUsage' call inside 'tagRecBinders'. + +All this is quite apparent if you look at the contification transformation in +Fig. 5 of "Compiling without Continuations" (which does not account for +eta-expansion at all, mind you). The letrec case looks like this + + letrec f = /\as.\xs. L[us] in L'[es] + ... and a bunch of conditions establishing that f only occurs + in app heads of join arity (len as + len xs) inside us and es ... + +The syntactic form `/\as.\xs. L[us]` forces M=O iff `f` occurs in `us`. However, +for non-recursive functions, this is the definition of contification from the +paper: + + let f = /\as.\xs.u in L[es] ... conditions ... + +Note that u could be a lambda itself, as we have seen. No relationship between M +and O to exploit here. + +Note [Join points and unfoldings/rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let j2 y = blah + let j x = j2 (x+x) + {-# INLINE [2] j #-} + in case e of { A -> j 1; B -> ...; C -> j 2 } + +Before j is inlined, we'll have occurrences of j2 in +both j's RHS and in its stable unfolding. We want to discover +j2 as a join point. So 'occAnalUnfolding' returns an unadjusted +'TailUsageDetails', like 'occAnalLamTail'. We adjust the usage details of the +unfolding to the actual join arity using the same 'adjustTailArity' as for +the RHS, see Note [Adjusting right-hand sides]. + +Same with rules. Suppose we have: + + let j :: Int -> Int + j y = 2 * y + let k :: Int -> Int -> Int + {-# RULES "SPEC k 0" k 0 y = j y #-} + k x y = x + 2 * y + in case e of { A -> k 1 2; B -> k 3 5; C -> blah } + +We identify k as a join point, and we want j to be a join point too. +Without the RULE it would be, and we don't want the RULE to mess it +up. So provided the join-point arity of k matches the args of the +rule we can allow the tail-call info from the RHS of the rule to +propagate. + +* Note that the join arity of the RHS and that of the unfolding or RULE might + mismatch: + + let j x y = j2 (x+x) + {-# INLINE[2] j = \x. g #-} + {-# RULE forall x y z. j x y z = h 17 #-} + in j 1 2 + + So it is crucial that we adjust each TailUsageDetails individually + with the actual join arity 2 here before we combine with `andUDs`. + Here, that means losing tail call info on `g` and `h`. + +* Wrinkle for Rec case: We store one TailUsageDetails in the node Details for + RHS, unfolding and RULE combined. Clearly, if they don't agree on their join + arity, we have to do some adjusting. We choose to adjust to the join arity + of the RHS, because that is likely the join arity that the join point will + have; see Note [Join arity prediction based on joinRhsArity]. + + If the guess is correct, then tail calls in the RHS are preserved; a necessary + condition for the whole binding becoming a joinrec. + The guess can only be incorrect in the 'AcyclicSCC' case when the binding + becomes a non-recursive join point with a different join arity. But then the + eventual call to 'adjustTailUsage' in 'tagRecBinders'/'occAnalRec' will + be with a different join arity and destroy unsound tail call info with + 'markNonTail'. + +* Wrinkle for RULES. Suppose the example was a bit different: + let j :: Int -> Int + j y = 2 * y + k :: Int -> Int -> Int + {-# RULES "SPEC k 0" k 0 = j #-} + k x y = x + 2 * y + in ... + If we eta-expanded the rule all would be well, but as it stands the + one arg of the rule don't match the join-point arity of 2. + + Conceivably we could notice that a potential join point would have + an "undersaturated" rule and account for it. This would mean we + could make something that's been specialised a join point, for + instance. But local bindings are rarely specialised, and being + overly cautious about rules only costs us anything when, for some `j`: + + * Before specialisation, `j` has non-tail calls, so it can't be a join point. + * During specialisation, `j` gets specialised and thus acquires rules. + * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say), + and so now `j` *could* become a join point. + + This appears to be very rare in practice. TODO Perhaps we should gather + statistics to be sure. + +------------------------------------------------------------ +Note [Adjusting right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a bit of a dance we need to do after analysing a lambda expression or +a right-hand side. In particular, we need to + + a) call 'markAllNonTail' *unless* the binding is for a join point, and + the TailUsageDetails from the RHS has the right join arity; e.g. + join j x y = case ... of + A -> j2 p + B -> j2 q + in j a b + Here we want the tail calls to j2 to be tail calls of the whole expression + b) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot + lambda, or a non-recursive join point + +Some examples, with how the free occurrences in e (assumed not to be a value +lambda) get marked: + + inside lam non-tail-called + ------------------------------------------------------------ + let x = e No Yes + let f = \x -> e Yes Yes + let f = \x{OneShot} -> e No Yes + \x -> e Yes Yes + join j x = e No No + joinrec j x = e Yes No + +There are a few other caveats; most importantly, if we're marking a binding as +'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so +that the effect cascades properly. Consequently, at the time the RHS is +analysed, we won't know what adjustments to make; thus 'occAnalLamTail' must +return the unadjusted 'TailUsageDetails', to be adjusted by 'adjustTailUsage' +once join-point-hood has been decided and eventual one-shot annotations have +been added through 'markNonRecJoinOneShots'. + +It is not so simple to see that 'occAnalNonRecBind' and 'occAnalRecBind' indeed +perform a similar sequence of steps. Thus, here is an interleaving of events +of both functions, serving as a specification: + + 1. Call 'occAnalLamTail' to find usage information for the RHS. + Recursive case: 'makeNode' + Non-recursive case: 'occAnalNonRecBind' + 2. (Analyse the binding's scope. Done in 'occAnalBind'/`occAnal Let{}`. + Same whether recursive or not.) + 3. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make + the binding a join point. + Cyclic Recursive case: 'mkLoopBreakerNodes' + Acyclic Recursive case: `occAnalRec AcyclicSCC{}` + Non-recursive case: 'occAnalNonRecBind' + 4. Non-recursive join point: Call 'markNonRecJoinOneShots' so that e.g., + FloatOut sees one-shot annotations on lambdas + Acyclic Recursive case: `occAnalRec AcyclicSCC{}` calls 'adjustNonRecRhs' + Non-recursive case: 'occAnalNonRecBind' calls 'adjustNonRecRhs' + 5. Call 'adjustTailUsage' accordingly. + Cyclic Recursive case: 'tagRecBinders' + Acyclic Recursive case: 'adjustNonRecRhs' + Non-recursive case: 'adjustNonRecRhs' +-} + +------------------------------------------------------------------ +-- occAnalBind +------------------------------------------------------------------ + +occAnalBind + :: OccEnv + -> TopLevelFlag + -> ImpRuleEdges + -> CoreBind + -> (OccEnv -> WithUsageDetails r) -- Scope of the bind + -> ([CoreBind] -> r -> r) -- How to combine the scope with new binds + -> WithUsageDetails r -- Of the whole let(rec) + +occAnalBind env lvl ire (Rec pairs) thing_inside combine + = addInScopeList env (map fst pairs) $ \env -> + let WUD body_uds body' = thing_inside env + WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds + in WUD bind_uds (combine binds' body') + +occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine + | isTyVar bndr -- A type let; we don't gather usage info + = let !(WUD body_uds res) = addInScopeOne env bndr thing_inside + in WUD body_uds (combine [NonRec bndr rhs] res) + + -- /Existing/ non-recursive join points + -- See Note [Occurrence analysis for join points] + | mb_join@(JoinPoint {}) <- idJoinPointHood bndr + = -- Analyse the RHS and /then/ the body + let -- Analyse the rhs first, generating rhs_uds + !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs + rhs_uds = foldr1 orUDs rhs_uds_s -- NB: orUDs. See (W4) of + -- Note [Occurrence analysis for join points] + + -- Now analyse the body, adding the join point + -- into the environment with addJoinPoint + !(WUD body_uds (occ, body)) = occAnalNonRecBody env bndr' $ \env -> + thing_inside (addJoinPoint env bndr' rhs_uds) + in + if isDeadOcc occ -- Drop dead code; see Note [Dead code] + then WUD body_uds body + else WUD (rhs_uds `orUDs` body_uds) -- Note `orUDs` + (combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs'] + body) + + -- The normal case, including newly-discovered join points + -- Analyse the body and /then/ the RHS + | WUD body_uds (occ,body) <- occAnalNonRecBody env bndr thing_inside + = if isDeadOcc occ -- Drop dead code; see Note [Dead code] + then WUD body_uds body + else let + -- Get the join info from the *new* decision; NB: bndr is not already a JoinId + -- See Note [Join points and unfoldings/rules] + -- => join arity O of Note [Join arity prediction based on joinRhsArity] + (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr + + !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env lvl ire mb_join tagged_bndr rhs + in WUD (foldr andUDs body_uds rhs_uds_s) -- Note `andUDs` + (combine [NonRec final_bndr rhs'] body) + +----------------- +occAnalNonRecBody :: OccEnv -> Id + -> (OccEnv -> WithUsageDetails r) -- Scope of the bind + -> (WithUsageDetails (OccInfo, r)) +occAnalNonRecBody env bndr thing_inside + = addInScopeOne env bndr $ \env -> + let !(WUD inner_uds res) = thing_inside env + !occ = lookupLetOccInfo inner_uds bndr + in WUD inner_uds (occ, res) + +----------------- +occAnalNonRecRhs :: OccEnv -> TopLevelFlag -> ImpRuleEdges + -> JoinPointHood -> Id -> CoreExpr + -> (NonEmpty UsageDetails, Id, CoreExpr) +occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs + | null rules, null imp_rule_infos + = -- Fast path for common case of no rules. This is only worth + -- 0.1% perf on average, but it's also only a line or two of code + ( adj_rhs_uds :| adj_unf_uds : [], final_bndr_no_rules, final_rhs ) + | otherwise + = ( adj_rhs_uds :| adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs ) + where + --------- Right hand side --------- + -- For join points, set occ_encl to OccVanilla, via setTailCtxt. If we have + -- join j = Just (f x) in ... + -- we do not want to float the (f x) to + -- let y = f x in join j = Just y in ... + -- That's that OccRhs would do; but there's no point because + -- j will never be scrutinised. + rhs_env = mkRhsOccEnv env NonRecursive rhs_ctxt mb_join bndr rhs + rhs_ctxt = mkNonRecRhsCtxt lvl bndr unf + + -- See Note [Join arity prediction based on joinRhsArity] + -- Match join arity O from mb_join_arity with manifest join arity M as + -- returned by of occAnalLamTail. It's totally OK for them to mismatch; + -- hence adjust the UDs from the RHS + WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $ + occAnalLamTail rhs_env rhs + final_bndr_with_rules + | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] + | otherwise = bndr `setIdSpecialisation` mkRuleInfo rules' + `setIdUnfolding` unf1 + final_bndr_no_rules + | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] + | otherwise = bndr `setIdUnfolding` unf1 + + --------- Unfolding --------- + -- See Note [Join points and unfoldings/rules] + unf = idUnfolding bndr + WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf + adj_unf_uds = adjustTailArity mb_join unf_tuds + + --------- Rules --------- + -- See Note [Rules are extra RHSs] and Note [Rule dependency info] + -- and Note [Join points and unfoldings/rules] + rules = idCoreRules bndr + rules_w_uds = map (occAnalRule rhs_env) rules + rules' = map fstOf3 rules_w_uds + imp_rule_infos = lookupImpRules imp_rule_edges bndr + imp_rule_uds = [impRulesScopeUsage imp_rule_infos] + -- imp_rule_uds: consider + -- h = ... + -- g = ... + -- RULE map g = h + -- Then we want to ensure that h is in scope everywhere + -- that g is (since the RULE might turn g into h), so + -- we make g mention h. + + adj_rule_uds :: [UsageDetails] + adj_rule_uds = imp_rule_uds ++ + [ l `andUDs` adjustTailArity mb_join r + | (_,l,r) <- rules_w_uds ] + +mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl +-- Precondition: Id is not a join point +mkNonRecRhsCtxt lvl bndr unf + | certainly_inline = OccVanilla -- See Note [Cascading inlines] + | otherwise = OccRhs + where + certainly_inline -- See Note [Cascading inlines] + = -- mkNonRecRhsCtxt is only used for non-join points, so occAnalBind + -- has set the OccInfo for this binder before calling occAnalNonRecRhs + case idOccInfo bndr of + OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 } + -> active && not stable_unf && not top_bottoming + _ -> False + + active = isAlwaysActive (idInlineActivation bndr) + stable_unf = isStableUnfolding unf + top_bottoming = isTopLevel lvl && isDeadEndId bndr + +----------------- +occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)] + -> UsageDetails -> WithUsageDetails [CoreBind] +-- For a recursive group, we +-- * occ-analyse all the RHSs +-- * compute strongly-connected components +-- * feed those components to occAnalRec +-- See Note [Recursive bindings: the grand plan] +occAnalRecBind !rhs_env lvl imp_rule_edges pairs body_usage + = foldr (occAnalRec rhs_env lvl) (WUD body_usage []) sccs + where + sccs :: [SCC NodeDetails] + sccs = stronglyConnCompFromEdgedVerticesUniq nodes + + nodes :: [LetrecNode] + nodes = map (makeNode rhs_env imp_rule_edges bndr_set) pairs + + bndrs = map fst pairs + bndr_set = mkVarSet bndrs + +----------------------------- +occAnalRec :: OccEnv -> TopLevelFlag + -> SCC NodeDetails + -> WithUsageDetails [CoreBind] + -> WithUsageDetails [CoreBind] + +-- The NonRec case is just like a Let (NonRec ...) above +occAnalRec !_ lvl + (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds })) + (WUD body_uds binds) + | isDeadOcc occ -- Check for dead code: see Note [Dead code] + = WUD body_uds binds + | otherwise + = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr + !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds + in WUD (body_uds `andUDs` rhs_uds') + (NonRec bndr' rhs' : binds) + where + occ = lookupLetOccInfo body_uds bndr + +-- The Rec case is the interesting one +-- See Note [Recursive bindings: the grand plan] +-- See Note [Loop breaking] +occAnalRec env lvl (CyclicSCC details_s) (WUD body_uds binds) + | not (any needed details_s) + = -- Check for dead code: see Note [Dead code] + -- NB: Only look at body_uds, ignoring uses in the SCC + WUD body_uds binds + + | otherwise + = WUD final_uds (Rec pairs : binds) + where + all_simple = all nd_simple details_s + + needed :: NodeDetails -> Bool + needed (ND { nd_bndr = bndr }) = isExportedId bndr || bndr `elemVarEnv` body_env + body_env = ud_env body_uds + + ------------------------------ + -- Make the nodes for the loop-breaker analysis + -- See Note [Choosing loop breakers] for loop_breaker_nodes + final_uds :: UsageDetails + loop_breaker_nodes :: [LoopBreakerNode] + WUD final_uds loop_breaker_nodes = mkLoopBreakerNodes env lvl body_uds details_s + + ------------------------------ + weak_fvs :: VarSet + weak_fvs = mapUnionVarSet nd_weak_fvs details_s + + --------------------------- + -- Now reconstruct the cycle + pairs :: [(Id,CoreExpr)] + pairs | all_simple = reOrderNodes 0 weak_fvs loop_breaker_nodes [] + | otherwise = loopBreakNodes 0 weak_fvs loop_breaker_nodes [] + -- In the common case when all are "simple" (no rules at all) + -- the loop_breaker_nodes will include all the scope edges + -- so a SCC computation would yield a single CyclicSCC result; + -- and reOrderNodes deals with exactly that case. + -- Saves a SCC analysis in a common case + + +{- ********************************************************************* +* * + Loop breaking +* * +********************************************************************* -} + +{- Note [Choosing loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Step 4 in Note [Recursive bindings: the grand plan]), occAnalRec does +loop-breaking on each CyclicSCC of the original program: + +* mkLoopBreakerNodes: Form the loop-breaker graph for that CyclicSCC + +* loopBreakNodes: Do SCC analysis on it + +* reOrderNodes: For each CyclicSCC, pick a loop breaker + * Delete edges to that loop breaker + * Do another SCC analysis on that reduced SCC + * Repeat + +To form the loop-breaker graph, we construct a new set of Nodes, the +"loop-breaker nodes", with the same details but different edges, the +"loop-breaker edges". The loop-breaker nodes have both more and fewer +dependencies than the scope edges: + + More edges: + If f calls g, and g has an active rule that mentions h then + we add an edge from f -> h. See Note [Rules and loop breakers]. + + Fewer edges: we only include dependencies + * only on /active/ rules, + * on rule /RHSs/ (not LHSs) + +The scope edges, by contrast, must be much more inclusive. + +The nd_simple flag tracks the common case when a binding has no RULES +at all, in which case the loop-breaker edges will be identical to the +scope edges. + +Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is +chosen as a loop breaker, because their RHSs don't mention each other. +And indeed both can be inlined safely. + +Note [inl_fvs] +~~~~~~~~~~~~~~ +Note that the loop-breaker graph includes edges for occurrences in +/both/ the RHS /and/ the stable unfolding. Consider this, which actually +occurred when compiling BooleanFormula.hs in GHC: + + Rec { lvl1 = go + ; lvl2[StableUnf = go] = lvl1 + ; go = ...go...lvl2... } + +From the point of view of infinite inlining, we need only these edges: + lvl1 :-> go + lvl2 :-> go -- The RHS lvl1 will never be used for inlining + go :-> go, lvl2 + +But the danger is that, lacking any edge to lvl1, we'll put it at the +end thus + Rec { lvl2[ StableUnf = go] = lvl1 + ; go[LoopBreaker] = ...go...lvl2... } + ; lvl1[Occ=Once] = go } + +And now the Simplifer will try to use PreInlineUnconditionally on lvl1 +(which occurs just once), but because it is last we won't actually +substitute in lvl2. Sigh. + +To avoid this possibility, we include edges from lvl2 to /both/ its +stable unfolding /and/ its RHS. Hence the defn of inl_fvs in +makeNode. Maybe we could be more clever, but it's very much a corner +case. + +Note [Weak loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a last nasty wrinkle. Suppose we have + + Rec { f = f_rhs + RULE f [] = g + + h = h_rhs + g = h + ...more... } + +Remember that we simplify the RULES before any RHS (see Note +[Rules are visible in their own rec group] above). + +So we must *not* postInlineUnconditionally 'g', even though +its RHS turns out to be trivial. (I'm assuming that 'g' is +not chosen as a loop breaker.) Why not? Because then we +drop the binding for 'g', which leaves it out of scope in the +RULE! + +Here's a somewhat different example of the same thing + Rec { q = r + ; r = ...p... + ; p = p_rhs + RULE p [] = q } +Here the RULE is "below" q, but we *still* can't postInlineUnconditionally +q, because the RULE for p is active throughout. So the RHS of r +might rewrite to r = ...q... +So q must remain in scope in the output program! + +We "solve" this by: + + Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True) + iff q is a mentioned in the RHS of any RULE (active on not) + in the Rec group + +Note the "active or not" comment; even if a RULE is inactive, we +want its RHS free vars to stay alive (#20820)! + +A normal "strong" loop breaker has IAmLoopBreaker False. So: + + Inline postInlineUnconditionally +strong IAmLoopBreaker False no no +weak IAmLoopBreaker True yes no + other yes yes + +The **sole** reason for this kind of loop breaker is so that +postInlineUnconditionally does not fire. Ugh. + +Annoyingly, since we simplify the rules *first* we'll never inline +q into p's RULE. That trivial binding for q will hang around until +we discard the rule. Yuk. But it's rare. + +Note [Rules and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we form the loop-breaker graph (Step 4 in Note [Recursive +bindings: the grand plan]), we must be careful about RULEs. + +For a start, we want a loop breaker to cut every cycle, so inactive +rules play no part; we need only consider /active/ rules. +See Note [Finding rule RHS free vars] + +The second point is more subtle. A RULE is like an equation for +'f' that is *always* inlined if it is applicable. We do *not* disable +rules for loop-breakers. It's up to whoever makes the rules to make +sure that the rules themselves always terminate. See Note [Rules for +recursive functions] in GHC.Core.Opt.Simplify + +Hence, if + f's RHS (or its stable unfolding if it has one) mentions g, and + g has a RULE that mentions h, and + h has a RULE that mentions f + +then we *must* choose f to be a loop breaker. Example: see Note +[Specialisation rules]. So our plan is this: + + Take the free variables of f's RHS, and augment it with all the + variables reachable by a transitive sequence RULES from those + starting points. + +That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes. +Wrinkles: + +* We only consider /active/ rules. See Note [Finding rule RHS free vars] + +* We need only consider free vars that are also binders in this Rec + group. See also Note [Finding rule RHS free vars] + +* We only consider variables free in the *RHS* of the rule, in + contrast to the way we build the Rec group in the first place (Note + [Rule dependency info]) + +* Why "transitive sequence of rules"? Because active rules apply + unconditionally, without checking loop-breaker-ness. + See Note [Loop breaker dependencies]. + +Note [Finding rule RHS free vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this real example from Data Parallel Haskell + tagZero :: Array Int -> Array Tag + {-# INLINE [1] tagZeroes #-} + tagZero xs = pmap (\x -> fromBool (x==0)) xs + + {-# RULES "tagZero" [~1] forall xs n. + pmap fromBool = tagZero xs #-} +So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. +However, tagZero can only be inlined in phase 1 and later, while +the RULE is only active *before* phase 1. So there's no problem. + +To make this work, we look for the RHS free vars only for +*active* rules. That's the reason for the occ_rule_act field +of the OccEnv. + +Note [loopBreakNodes] +~~~~~~~~~~~~~~~~~~~~~ +loopBreakNodes is applied to the list of nodes for a cyclic strongly +connected component (there's guaranteed to be a cycle). It returns +the same nodes, but + a) in a better order, + b) with some of the Ids having a IAmALoopBreaker pragma + +The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means +that the simplifier can guarantee not to loop provided it never records an inlining +for these no-inline guys. + +Furthermore, the order of the binds is such that if we neglect dependencies +on the no-inline Ids then the binds are topologically sorted. This means +that the simplifier will generally do a good job if it works from top bottom, +recording inlinings for any Ids which aren't marked as "no-inline" as it goes. +-} + +type Binding = (Id,CoreExpr) + +-- See Note [loopBreakNodes] +loopBreakNodes :: Int + -> VarSet -- Binders whose dependencies may be "missing" + -- See Note [Weak loop breakers] + -> [LoopBreakerNode] + -> [Binding] -- Append these to the end + -> [Binding] + +-- Return the bindings sorted into a plausible order, and marked with loop breakers. +-- See Note [loopBreakNodes] +loopBreakNodes depth weak_fvs nodes binds + = -- pprTrace "loopBreakNodes" (ppr nodes) $ + go (stronglyConnCompFromEdgedVerticesUniqR nodes) + where + go [] = binds + go (scc:sccs) = loop_break_scc scc (go sccs) + + loop_break_scc scc binds + = case scc of + AcyclicSCC node -> nodeBinding (mk_non_loop_breaker weak_fvs) node : binds + CyclicSCC nodes -> reOrderNodes depth weak_fvs nodes binds + +---------------------------------- +reOrderNodes :: Int -> VarSet -> [LoopBreakerNode] -> [Binding] -> [Binding] + -- Choose a loop breaker, mark it no-inline, + -- and call loopBreakNodes on the rest +reOrderNodes _ _ [] _ = panic "reOrderNodes" +reOrderNodes _ _ [node] binds = nodeBinding mk_loop_breaker node : binds +reOrderNodes depth weak_fvs (node : nodes) binds + = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen + -- , text "chosen" <+> ppr chosen_nodes ]) $ + loopBreakNodes new_depth weak_fvs unchosen $ + (map (nodeBinding mk_loop_breaker) chosen_nodes ++ binds) + where + (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb + (snd_score (node_payload node)) + [node] [] nodes + + approximate_lb = depth >= 2 + new_depth | approximate_lb = 0 + | otherwise = depth+1 + -- After two iterations (d=0, d=1) give up + -- and approximate, returning to d=0 + +nodeBinding :: (Id -> Id) -> LoopBreakerNode -> Binding +nodeBinding set_id_occ (node_payload -> SND { snd_bndr = bndr, snd_rhs = rhs}) + = (set_id_occ bndr, rhs) + +mk_loop_breaker :: Id -> Id +mk_loop_breaker bndr + = bndr `setIdOccInfo` occ' + where + occ' = strongLoopBreaker { occ_tail = tail_info } + tail_info = tailCallInfo (idOccInfo bndr) + +mk_non_loop_breaker :: VarSet -> Id -> Id +-- See Note [Weak loop breakers] +mk_non_loop_breaker weak_fvs bndr + | bndr `elemVarSet` weak_fvs = setIdOccInfo bndr occ' + | otherwise = bndr + where + occ' = weakLoopBreaker { occ_tail = tail_info } + tail_info = tailCallInfo (idOccInfo bndr) + +---------------------------------- +chooseLoopBreaker :: Bool -- True <=> Too many iterations, + -- so approximate + -> NodeScore -- Best score so far + -> [LoopBreakerNode] -- Nodes with this score + -> [LoopBreakerNode] -- Nodes with higher scores + -> [LoopBreakerNode] -- Unprocessed nodes + -> ([LoopBreakerNode], [LoopBreakerNode]) + -- This loop looks for the bind with the lowest score + -- to pick as the loop breaker. The rest accumulate in +chooseLoopBreaker _ _ loop_nodes acc [] + = (loop_nodes, acc) -- Done + + -- If approximate_loop_breaker is True, we pick *all* + -- nodes with lowest score, else just one + -- See Note [Complexity of loop breaking] +chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes) + | approx_lb + , rank sc == rank loop_sc + = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes + + | sc `betterLB` loop_sc -- Better score so pick this new one + = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes + + | otherwise -- Worse score so don't pick it + = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes + where + sc = snd_score (node_payload node) + +{- +Note [Complexity of loop breaking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The loop-breaking algorithm knocks out one binder at a time, and +performs a new SCC analysis on the remaining binders. That can +behave very badly in tightly-coupled groups of bindings; in the +worst case it can be (N**2)*log N, because it does a full SCC +on N, then N-1, then N-2 and so on. + +To avoid this, we switch plans after 2 (or whatever) attempts: + Plan A: pick one binder with the lowest score, make it + a loop breaker, and try again + Plan B: pick *all* binders with the lowest score, make them + all loop breakers, and try again +Since there are only a small finite number of scores, this will +terminate in a constant number of iterations, rather than O(N) +iterations. + +You might thing that it's very unlikely, but RULES make it much +more likely. Here's a real example from #1969: + Rec { $dm = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm1 + forall d. $dm Bool d = $s$dm2 #-} + + dInt = MkD .... opInt ... + dInt = MkD .... opBool ... + opInt = $dm dInt + opBool = $dm dBool + + $s$dm1 = \x. op dInt + $s$dm2 = \x. op dBool } +The RULES stuff means that we can't choose $dm as a loop breaker +(Note [Choosing loop breakers]), so we must choose at least (say) +opInt *and* opBool, and so on. The number of loop breakers is +linear in the number of instance declarations. + +Note [Loop breakers and INLINE/INLINABLE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Avoid choosing a function with an INLINE pramga as the loop breaker! +If such a function is mutually-recursive with a non-INLINE thing, +then the latter should be the loop-breaker. + +It's vital to distinguish between INLINE and INLINABLE (the +Bool returned by hasStableCoreUnfolding_maybe). If we start with + Rec { {-# INLINABLE f #-} + f x = ...f... } +and then worker/wrapper it through strictness analysis, we'll get + Rec { {-# INLINABLE $wf #-} + $wf p q = let x = (p,q) in ...f... + + {-# INLINE f #-} + f x = case x of (p,q) -> $wf p q } + +Now it is vital that we choose $wf as the loop breaker, so we can +inline 'f' in '$wf'. + +Note [DFuns should not be loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's particularly bad to make a DFun into a loop breaker. See +Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance + +We give DFuns a higher score than ordinary CONLIKE things because +if there's a choice we want the DFun to be the non-loop breaker. Eg + +rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) + + $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) + {-# DFUN #-} + $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) + } + +Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it +if we can't unravel the DFun first. + +Note [Constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's really really important to inline dictionaries. Real +example (the Enum Ordering instance from GHC.Base): + + rec f = \ x -> case d of (p,q,r) -> p x + g = \ x -> case d of (p,q,r) -> q x + d = (v, f, g) + +Here, f and g occur just once; but we can't inline them into d. +On the other hand we *could* simplify those case expressions if +we didn't stupidly choose d as the loop breaker. +But we won't because constructor args are marked "Many". +Inlining dictionaries is really essential to unravelling +the loops in static numeric dictionaries, see GHC.Float. + +Note [Closure conversion] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. +The immediate motivation came from the result of a closure-conversion transformation +which generated code like this: + + data Clo a b = forall c. Clo (c -> a -> b) c + + ($:) :: Clo a b -> a -> b + Clo f env $: x = f env x + + rec { plus = Clo plus1 () + + ; plus1 _ n = Clo plus2 n + + ; plus2 Zero n = n + ; plus2 (Succ m) n = Succ (plus $: m $: n) } + +If we inline 'plus' and 'plus1', everything unravels nicely. But if +we choose 'plus1' as the loop breaker (which is entirely possible +otherwise), the loop does not unravel nicely. + + +@occAnalUnfolding@ deals with the question of bindings where the Id is marked +by an INLINE pragma. For these we record that anything which occurs +in its RHS occurs many times. This pessimistically assumes that this +inlined binder also occurs many times in its scope, but if it doesn't +we'll catch it next time round. At worst this costs an extra simplifier pass. +ToDo: try using the occurrence info for the inline'd binder. + +[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. +[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. + + +************************************************************************ +* * + Making nodes +* * +************************************************************************ +-} + +-- | Digraph node as constructed by 'makeNode' and consumed by 'occAnalRec'. +-- The Unique key is gotten from the Id. +type LetrecNode = Node Unique NodeDetails + +-- | Node details as consumed by 'occAnalRec'. +data NodeDetails + = ND { nd_bndr :: Id -- Binder + + , nd_rhs :: !(WithTailUsageDetails CoreExpr) + -- ^ RHS, already occ-analysed + -- With TailUsageDetails from RHS, and RULES, and stable unfoldings, + -- ignoring phase (ie assuming all are active). + -- NB: Unadjusted TailUsageDetails, as if this Node becomes a + -- non-recursive join point! + -- See Note [TailUsageDetails when forming Rec groups] + + , nd_inl :: IdSet -- Free variables of the stable unfolding and the RHS + -- but excluding any RULES + -- This is the IdSet that may be used if the Id is inlined + + , nd_simple :: Bool -- True iff this binding has no local RULES + -- If all nodes are simple we don't need a loop-breaker + -- dep-anal before reconstructing. + + , nd_weak_fvs :: IdSet -- Variables bound in this Rec group that are free + -- in the RHS of any rule (active or not) for this bndr + -- See Note [Weak loop breakers] + + , nd_active_rule_fvs :: IdSet -- Variables bound in this Rec group that are free + -- in the RHS of an active rule for this bndr + -- See Note [Rules and loop breakers] + } + +instance Outputable NodeDetails where + ppr nd = text "ND" <> braces + (sep [ text "bndr =" <+> ppr (nd_bndr nd) + , text "uds =" <+> ppr uds + , text "inl =" <+> ppr (nd_inl nd) + , text "simple =" <+> ppr (nd_simple nd) + , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd) + ]) + where + WTUD uds _ = nd_rhs nd + +-- | Digraph with simplified and completely occurrence analysed +-- 'SimpleNodeDetails', retaining just the info we need for breaking loops. +type LoopBreakerNode = Node Unique SimpleNodeDetails + +-- | Condensed variant of 'NodeDetails' needed during loop breaking. +data SimpleNodeDetails + = SND { snd_bndr :: IdWithOccInfo -- OccInfo accurate + , snd_rhs :: CoreExpr -- properly occur-analysed + , snd_score :: NodeScore + } + +instance Outputable SimpleNodeDetails where + ppr nd = text "SND" <> braces + (sep [ text "bndr =" <+> ppr (snd_bndr nd) + , text "score =" <+> ppr (snd_score nd) + ]) + +-- The NodeScore is compared lexicographically; +-- e.g. lower rank wins regardless of size +type NodeScore = ( Int -- Rank: lower => more likely to be picked as loop breaker + , Int -- Size of rhs: higher => more likely to be picked as LB + -- Maxes out at maxExprSize; we just use it to prioritise + -- small functions + , Bool ) -- Was it a loop breaker before? + -- True => more likely to be picked + -- Note [Loop breakers, node scoring, and stability] + +rank :: NodeScore -> Int +rank (r, _, _) = r + +makeNode :: OccEnv -> ImpRuleEdges -> VarSet + -> (Var, CoreExpr) -> LetrecNode +-- See Note [Recursive bindings: the grand plan] +makeNode !env imp_rule_edges bndr_set (bndr, rhs) + = -- pprTrace "makeNode" (ppr bndr <+> ppr (sizeVarSet bndr_set)) $ + DigraphNode { node_payload = details + , node_key = varUnique bndr + , node_dependencies = nonDetKeysUniqSet scope_fvs } + -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR + -- is still deterministic with edges in nondeterministic order as + -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. + where + details = ND { nd_bndr = bndr' + , nd_rhs = WTUD (TUD rhs_ja unadj_scope_uds) rhs' + , nd_inl = inl_fvs + , nd_simple = null rules_w_uds && null imp_rule_info + , nd_weak_fvs = weak_fvs + , nd_active_rule_fvs = active_rule_fvs } + + bndr' | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] + | otherwise = bndr `setIdUnfolding` unf' + `setIdSpecialisation` mkRuleInfo rules' + + -- NB: Both adj_unf_uds and adj_rule_uds have been adjusted to match the + -- JoinArity rhs_ja of unadj_rhs_uds. + unadj_inl_uds = unadj_rhs_uds `andUDs` adj_unf_uds + unadj_scope_uds = unadj_inl_uds `andUDs` adj_rule_uds + -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + scope_fvs = udFreeVars bndr_set unadj_scope_uds + -- scope_fvs: all occurrences from this binder: RHS, unfolding, + -- and RULES, both LHS and RHS thereof, active or inactive + + inl_fvs = udFreeVars bndr_set unadj_inl_uds + -- inl_fvs: vars that would become free if the function was inlined. + -- We conservatively approximate that by the free vars from the RHS + -- and the unfolding together. + -- See Note [inl_fvs] + + + --------- Right hand side --------- + -- Constructing the edges for the main Rec computation + -- See Note [Forming Rec groups] + -- and Note [TailUsageDetails when forming Rec groups] + -- Compared to occAnalNonRecBind, we can't yet adjust the RHS because + -- (a) we don't yet know the final joinpointhood. It might not become a + -- join point after all! + -- (b) we don't even know whether it stays a recursive RHS after the SCC + -- analysis we are about to seed! So we can't markAllInsideLam in + -- advance, because if it ends up as a non-recursive join point we'll + -- consider it as one-shot and don't need to markAllInsideLam. + -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage + -- until occAnalRec. In effect, we pretend that the RHS becomes a + -- non-recursive join point and fix up later with adjustTailUsage. + rhs_env = mkRhsOccEnv env Recursive OccRhs (idJoinPointHood bndr) bndr rhs + -- If bndr isn't an /existing/ join point (so idJoinPointHood = NotJoinPoint), + -- it's safe to zap the occ_join_points, because they can't occur in RHS. + WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs + -- The corresponding call to adjustTailUsage is in occAnalRec and tagRecBinders + + --------- Unfolding --------- + -- See Note [Join points and unfoldings/rules] + unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness + -- here because that is what we are setting! + WTUD unf_tuds unf' = occAnalUnfolding rhs_env unf + adj_unf_uds = adjustTailArity (JoinPoint rhs_ja) unf_tuds + -- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source M + -- of Note [Join arity prediction based on joinRhsArity] + + --------- IMP-RULES -------- + is_active = occ_rule_act env :: Activation -> Bool + imp_rule_info = lookupImpRules imp_rule_edges bndr + imp_rule_uds = impRulesScopeUsage imp_rule_info + imp_rule_fvs = impRulesActiveFvs is_active bndr_set imp_rule_info + + --------- All rules -------- + -- See Note [Join points and unfoldings/rules] + -- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source M + -- of Note [Join arity prediction based on joinRhsArity] + rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] + rules_w_uds = [ (r,l,adjustTailArity (JoinPoint rhs_ja) rhs_wuds) + | rule <- idCoreRules bndr + , let (r,l,rhs_wuds) = occAnalRule rhs_env rule ] + rules' = map fstOf3 rules_w_uds + + adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds + add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds + + -------- active_rule_fvs ------------ + active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds + add_active_rule (rule, _, rhs_uds) fvs + | is_active (ruleActivation rule) + = udFreeVars bndr_set rhs_uds `unionVarSet` fvs + | otherwise + = fvs + + -------- weak_fvs ------------ + -- See Note [Weak loop breakers] + weak_fvs = foldr add_rule emptyVarSet rules_w_uds + add_rule (_, _, rhs_uds) fvs = udFreeVars bndr_set rhs_uds `unionVarSet` fvs + +mkLoopBreakerNodes :: OccEnv -> TopLevelFlag + -> UsageDetails -- for BODY of let + -> [NodeDetails] + -> WithUsageDetails [LoopBreakerNode] -- with OccInfo up-to-date +-- See Note [Choosing loop breakers] +-- This function primarily creates the Nodes for the +-- loop-breaker SCC analysis. More specifically: +-- a) tag each binder with its occurrence info +-- b) add a NodeScore to each node +-- c) make a Node with the right dependency edges for +-- the loop-breaker SCC analysis +-- d) adjust each RHS's usage details according to +-- the binder's (new) shotness and join-point-hood +mkLoopBreakerNodes !env lvl body_uds details_s + = WUD final_uds (zipWithEqual mk_lb_node details_s bndrs') + where + WUD final_uds bndrs' = tagRecBinders lvl body_uds details_s + + mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs + , nd_rhs = WTUD _ rhs }) new_bndr + = DigraphNode { node_payload = simple_nd + , node_key = varUnique old_bndr + , node_dependencies = nonDetKeysUniqSet lb_deps } + -- It's OK to use nonDetKeysUniqSet here as + -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges + -- in nondeterministic order as explained in + -- Note [Deterministic SCC] in GHC.Data.Graph.Directed. + where + simple_nd = SND { snd_bndr = new_bndr, snd_rhs = rhs, snd_score = score } + score = nodeScore env new_bndr lb_deps nd + lb_deps = extendFvs_ rule_fv_env inl_fvs + -- See Note [Loop breaker dependencies] + + rule_fv_env :: IdEnv IdSet + -- Maps a variable f to the variables from this group + -- reachable by a sequence of RULES starting with f + -- Domain is *subset* of bound vars (others have no rule fvs) + -- See Note [Finding rule RHS free vars] + -- Why transClosureFV? See Note [Loop breaker dependencies] + rule_fv_env = transClosureFV $ mkVarEnv $ + [ (b, rule_fvs) + | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s + , not (isEmptyVarSet rule_fvs) ] + +{- Note [Loop breaker dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The loop breaker dependencies of x in a recursive +group { f1 = e1; ...; fn = en } are: + +- The "inline free variables" of f: the fi free in + f's stable unfolding and RHS; see Note [inl_fvs] + +- Any fi reachable from those inline free variables by a sequence + of RULE rewrites. Remember, rule rewriting is not affected + by fi being a loop breaker, so we have to take the transitive + closure in case f is the only possible loop breaker in the loop. + + Hence rule_fv_env. We need only account for /active/ rules. +-} + +------------------------------------------ +nodeScore :: OccEnv + -> Id -- Binder with new occ-info + -> VarSet -- Loop-breaker dependencies + -> NodeDetails + -> NodeScore +nodeScore !env new_bndr lb_deps + (ND { nd_bndr = old_bndr, nd_rhs = WTUD _ bind_rhs }) + + | not (isId old_bndr) -- A type or coercion variable is never a loop breaker + = (100, 0, False) + + | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers + = (0, 0, True) -- See Note [Self-recursion and loop breakers] + + | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has + = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker + + | exprIsTrivial rhs + = mk_score 10 -- Practically certain to be inlined + -- Used to have also: && not (isExportedId bndr) + -- But I found this sometimes cost an extra iteration when we have + -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } + -- where df is the exported dictionary. Then df makes a really + -- bad choice for loop breaker + + | DFunUnfolding { df_args = args } <- old_unf + -- Never choose a DFun as a loop breaker + -- Note [DFuns should not be loop breakers] + = (9, length args, is_lb) + + -- Data structures are more important than INLINE pragmas + -- so that dictionary/method recursion unravels + + | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf + = mk_score 6 + + | is_con_app rhs -- Data types help with cases: + = mk_score 5 -- Note [Constructor applications] + + | isStableUnfolding old_unf + , can_unfold + = mk_score 3 + + | isOneOcc (idOccInfo new_bndr) + = mk_score 2 -- Likely to be inlined + + | can_unfold -- The Id has some kind of unfolding + = mk_score 1 + + | otherwise + = (0, 0, is_lb) + + where + mk_score :: Int -> NodeScore + mk_score rank = (rank, rhs_size, is_lb) + + -- is_lb: see Note [Loop breakers, node scoring, and stability] + is_lb = isStrongLoopBreaker (idOccInfo old_bndr) + + old_unf = realIdUnfolding old_bndr + can_unfold = canUnfold old_unf + rhs = case old_unf of + CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } + | isStableSource src + -> unf_rhs + _ -> bind_rhs + -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding + rhs_size = case old_unf of + CoreUnfolding { uf_guidance = guidance } + | UnfIfGoodArgs { ug_size = size } <- guidance + -> size + _ -> cheapExprSize rhs + + + -- Checking for a constructor application + -- Cheap and cheerful; the simplifier moves casts out of the way + -- The lambda case is important to spot x = /\a. C (f a) + -- which comes up when C is a dictionary constructor and + -- f is a default method. + -- Example: the instance for Show (ST s a) in GHC.ST + -- + -- However we *also* treat (\x. C p q) as a con-app-like thing, + -- Note [Closure conversion] + is_con_app (Var v) = isConLikeId v + is_con_app (App f _) = is_con_app f + is_con_app (Lam _ e) = is_con_app e + is_con_app (Tick _ e) = is_con_app e + is_con_app (Let _ e) = is_con_app e -- let x = let y = blah in (a,b) + is_con_app _ = False -- We will float the y out, so treat + -- the x-binding as a con-app (#20941) + +maxExprSize :: Int +maxExprSize = 20 -- Rather arbitrary + +cheapExprSize :: CoreExpr -> Int +-- Maxes out at maxExprSize +cheapExprSize e + = go 0 e + where + go n e | n >= maxExprSize = n + | otherwise = go1 n e + + go1 n (Var {}) = n+1 + go1 n (Lit {}) = n+1 + go1 n (Type {}) = n + go1 n (Coercion {}) = n + go1 n (Tick _ e) = go1 n e + go1 n (Cast e _) = go1 n e + go1 n (App f a) = go (go1 n f) a + go1 n (Lam b e) + | isTyVar b = go1 n e + | otherwise = go (n+1) e + go1 n (Let b e) = gos (go1 n e) (rhssOfBind b) + go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as) + + gos n [] = n + gos n (e:es) | n >= maxExprSize = n + | otherwise = gos (go1 n e) es + +betterLB :: NodeScore -> NodeScore -> Bool +-- If n1 `betterLB` n2 then choose n1 as the loop breaker +betterLB (rank1, size1, lb1) (rank2, size2, _) + | rank1 < rank2 = True + | rank1 > rank2 = False + | size1 < size2 = False -- Make the bigger n2 into the loop breaker + | size1 > size2 = True + | lb1 = True -- Tie-break: if n1 was a loop breaker before, choose it + | otherwise = False -- See Note [Loop breakers, node scoring, and stability] + +{- Note [Self-recursion and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + rec { f = ...f...g... + ; g = .....f... } +then 'f' has to be a loop breaker anyway, so we may as well choose it +right away, so that g can inline freely. + +This is really just a cheap hack. Consider + rec { f = ...g... + ; g = ..f..h... + ; h = ...f....} +Here f or g are better loop breakers than h; but we might accidentally +choose h. Finding the minimal set of loop breakers is hard. + +Note [Loop breakers, node scoring, and stability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To choose a loop breaker, we give a NodeScore to each node in the SCC, +and pick the one with the best score (according to 'betterLB'). + +We need to be jolly careful (#12425, #12234) about the stability +of this choice. Suppose we have + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...f.. + False -> ..f... + +In each iteration of the simplifier the occurrence analyser OccAnal +chooses a loop breaker. Suppose in iteration 1 it choose g as the loop +breaker. That means it is free to inline f. + +Suppose that GHC decides to inline f in the branches of the case, but +(for some reason; eg it is not saturated) in the rhs of g. So we get + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...g...g..... + False -> ..g..g.... + +Now suppose that, for some reason, in the next iteration the occurrence +analyser chooses f as the loop breaker, so it can freely inline g. And +again for some reason the simplifier inlines g at its calls in the case +branches, but not in the RHS of f. Then we get + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...(...f...f...)...(...f..f..)..... + False -> ..(...f...f...)...(..f..f...).... + +You can see where this is going! Each iteration of the simplifier +doubles the number of calls to f or g. No wonder GHC is slow! + +(In the particular example in comment:3 of #12425, f and g are the two +mutually recursive fmap instances for CondT and Result. They are both +marked INLINE which, oddly, is why they don't inline in each other's +RHS, because the call there is not saturated.) + +The root cause is that we flip-flop on our choice of loop breaker. I +always thought it didn't matter, and indeed for any single iteration +to terminate, it doesn't matter. But when we iterate, it matters a +lot!! + +So The Plan is this: + If there is a tie, choose the node that + was a loop breaker last time round + +Hence the is_lb field of NodeScore +-} + +{- ********************************************************************* +* * + Lambda groups +* * +********************************************************************* -} + +{- Note [Occurrence analysis for lambda binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For value lambdas we do a special hack. Consider + (\x. \y. ...x...) +If we did nothing, x is used inside the \y, so would be marked +as dangerous to dup. But in the common case where the abstraction +is applied to two arguments this is over-pessimistic, which delays +inlining x, which forces more simplifier iterations. + +So the occurrence analyser collaborates with the simplifier to treat +a /lambda-group/ specially. A lambda-group is a contiguous run of +lambda and casts, e.g. + Lam x (Lam y (Cast (Lam z body) co)) + +* Occurrence analyser: we just mark each binder in the lambda-group + (here: x,y,z) with its occurrence info in the *body* of the + lambda-group. See occAnalLamTail. + +* Simplifier. The simplifier is careful when partially applying + lambda-groups. See the call to zapLambdaBndrs in + GHC.Core.Opt.Simplify.simplExprF1 + GHC.Core.SimpleOpt.simple_app + +* Why do we take care to account for intervening casts? Answer: + currently we don't do eta-expansion and cast-swizzling in a stable + unfolding (see Historical-note [Eta-expansion in stable unfoldings]). + So we can get + f = \x. ((\y. ...x...y...) |> co) + Now, since the lambdas aren't together, the occurrence analyser will + say that x is OnceInLam. Now if we have a call + (f e1 |> co) e2 + we'll end up with + let x = e1 in ...x..e2... + and it'll take an extra iteration of the Simplifier to substitute for x. + +A thought: a lambda-group is pretty much what GHC.Core.Opt.Arity.manifestArity +recognises except that the latter looks through (some) ticks. Maybe a lambda +group should also look through (some) ticks? +-} + +isOneShotFun :: CoreExpr -> Bool +-- The top level lambdas, ignoring casts, of the expression +-- are all one-shot. If there aren't any lambdas at all, this is True +isOneShotFun (Lam b e) = isOneShotBndr b && isOneShotFun e +isOneShotFun (Cast e _) = isOneShotFun e +isOneShotFun _ = True + +zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr +-- If (\xyz. t) appears under-applied to only two arguments, +-- we must zap the occ-info on x,y, because they appear under the \z +-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal +-- +-- NB: `arg_count` includes both type and value args +zapLambdaBndrs fun arg_count + = -- If the lambda is fully applied, leave it alone; if not + -- zap the OccInfo on the lambdas that do have arguments, + -- so they beta-reduce to use-many Lets rather than used-once ones. + zap arg_count fun `orElse` fun + where + zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr + -- Nothing => No need to change the occ-info + -- Just e => Had to change + zap 0 e | isOneShotFun e = Nothing -- All remaining lambdas are one-shot + | otherwise = Just e -- in which case no need to zap + zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) } + zap n (Lam b e) = do { e' <- zap (n-1) e + ; return (Lam (zap_bndr b) e') } + zap _ _ = Nothing -- More arguments than lambdas + + zap_bndr b | isTyVar b = b + | otherwise = zapLamIdInfo b + +occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr +-- ^ See Note [Occurrence analysis for lambda binders]. +-- It does the following: +-- * Sets one-shot info on the lambda binder from the OccEnv, and +-- removes that one-shot info from the OccEnv +-- * Sets the OccEnv to OccVanilla when going under a value lambda +-- * Tags each lambda with its occurrence information +-- * Walks through casts +-- * Package up the analysed lambda with its manifest join arity +-- +-- This function does /not/ do +-- markAllInsideLam or +-- markAllNonTail +-- The caller does that, via adjustTailUsage (mostly calls go through +-- adjustNonRecRhs). Every call to occAnalLamTail must ultimately call +-- adjustTailUsage to discharge the assumed join arity. +-- +-- In effect, the analysis result is for a non-recursive join point with +-- manifest arity and adjustTailUsage does the fixup. +-- See Note [Adjusting right-hand sides] +occAnalLamTail env expr + = let !(WUD usage expr') = occ_anal_lam_tail env expr + in WTUD (TUD (joinRhsArity expr) usage) expr' + +occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr +-- Does not markInsideLam etc for the outmost batch of lambdas +occ_anal_lam_tail env expr@(Lam {}) + = go env [] expr + where + go :: OccEnv -> [Var] -> CoreExpr -> WithUsageDetails CoreExpr + go env rev_bndrs (Lam bndr body) + | isTyVar bndr + = go env (bndr:rev_bndrs) body + -- Important: Unlike a value binder, do not modify occ_encl + -- to OccVanilla, so that with a RHS like + -- \(@ x) -> K @x (f @x) + -- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain + -- from inlining f. See the beginning of Note [Cascading inlines]. + + | otherwise + = let (env_one_shots', bndr') + = case occ_one_shots env of + [] -> ([], bndr) + (os : oss) -> (oss, updOneShotInfo bndr os) + -- Use updOneShotInfo, not setOneShotInfo, as pre-existing + -- one-shot info might be better than what we can infer, e.g. + -- due to explicit use of the magic 'oneShot' function. + -- See Note [oneShot magic] + env' = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' } + in go env' (bndr':rev_bndrs) body + + go env rev_bndrs body + = addInScope env rev_bndrs $ \env -> + let !(WUD usage body') = occ_anal_lam_tail env body + wrap_lam body bndr = Lam (tagLamBinder usage bndr) body + in WUD (usage `addLamCoVarOccs` rev_bndrs) + (foldl' wrap_lam body' rev_bndrs) + +-- For casts, keep going in the same lambda-group +-- See Note [Occurrence analysis for lambda binders] +occ_anal_lam_tail env (Cast expr co) + = let WUD usage expr' = occ_anal_lam_tail env expr + -- usage1: see Note [Gather occurrences of coercion variables] + usage1 = addManyOccs usage (coVarsOfCo co) + + -- usage2: see Note [Occ-anal and cast worker/wrapper] + usage2 = case expr of + Var {} | isRhsEnv env -> markAllMany usage1 + _ -> usage1 + + -- usage3: you might think this was not necessary, because of + -- the markAllNonTail in adjustTailUsage; but not so! For a + -- join point, adjustTailUsage doesn't do this; yet if there is + -- a cast, we must! Also: why markAllNonTail? See + -- GHC.Core.Lint: Note Note [Join points and casts] + usage3 = markAllNonTail usage2 + + in WUD usage3 (Cast expr' co) + +occ_anal_lam_tail env expr -- Not Lam, not Cast + = occAnal env expr + +{- Note [Occ-anal and cast worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider y = e; x = y |> co +If we mark y as used-once, we'll inline y into x, and the Cast +worker/wrapper transform will float it straight back out again. See +Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify. + +So in this particular case we want to mark 'y' as Many. It's very +ad-hoc, but it's also simple. It's also what would happen if we gave +the binding for x a stable unfolding (as we usually do for wrappers, thus + y = e + {-# INLINE x #-} + x = y |> co +Now y appears twice -- once in x's stable unfolding, and once in x's +RHS. So it'll get a Many occ-info. (Maybe Cast w/w should create a stable +unfolding, which would obviate this Note; but that seems a bit of a +heavyweight solution.) + +We only need to this in occAnalLamTail, not occAnal, because the top leve +of a right hand side is handled by occAnalLamTail. +-} + + +{- ********************************************************************* +* * + Right hand sides +* * +********************************************************************* -} + +occAnalUnfolding :: OccEnv + -> Unfolding + -> WithTailUsageDetails Unfolding +-- Occurrence-analyse a stable unfolding; +-- discard a non-stable one altogether and return empty usage details. +occAnalUnfolding !env unf + = case unf of + unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + | isStableSource src -> + let + WTUD (TUD rhs_ja uds) rhs' = occAnalLamTail env rhs + unf' = unf { uf_tmpl = rhs' } + in WTUD (TUD rhs_ja (markAllMany uds)) unf' + -- markAllMany: see Note [Occurrences in stable unfoldings] + + | otherwise -> WTUD (TUD 0 emptyDetails) unf + -- For non-Stable unfoldings we leave them undisturbed, but + -- don't count their usage because the simplifier will discard them. + -- We leave them undisturbed because nodeScore uses their size info + -- to guide its decisions. It's ok to leave un-substituted + -- expressions in the tree because all the variables that were in + -- scope remain in scope; there is no cloning etc. + + unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + -> let WUD uds args' = addInScopeList env bndrs $ \ env -> + occAnalList env args + in WTUD (TUD 0 uds) (unf { df_args = args' }) + -- No need to use tagLamBinders because we + -- never inline DFuns so the occ-info on binders doesn't matter + + unf -> WTUD (TUD 0 emptyDetails) unf + +occAnalRule :: OccEnv + -> CoreRule + -> (CoreRule, -- Each (non-built-in) rule + UsageDetails, -- Usage details for LHS + TailUsageDetails) -- Usage details for RHS +occAnalRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) + = (rule', lhs_uds', TUD rhs_ja rhs_uds') + where + rule' = rule { ru_args = args', ru_rhs = rhs' } + + WUD lhs_uds args' = addInScopeList env bndrs $ \env -> + occAnalList env args + + lhs_uds' = markAllManyNonTail lhs_uds + WUD rhs_uds rhs' = addInScopeList env bndrs $ \env -> + occAnal env rhs + -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + rhs_uds' = markAllMany rhs_uds + rhs_ja = length args -- See Note [Join points and unfoldings/rules] + +occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails) + +{- Note [Occurrences in stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f p = BIG + {-# INLINE g #-} + g y = not (f y) +where this is the /only/ occurrence of 'f'. So 'g' will get a stable +unfolding. Now suppose that g's RHS gets optimised (perhaps by a rule +or inlining f) so that it doesn't mention 'f' any more. Now the last +remaining call to f is in g's Stable unfolding. But, even though there +is only one syntactic occurrence of f, we do /not/ want to do +preinlineUnconditionally here! + +The INLINE pragma says "inline exactly this RHS"; perhaps the +programmer wants to expose that 'not', say. If we inline f that will make +the Stable unfoldign big, and that wasn't what the programmer wanted. + +Another way to think about it: if we inlined g as-is into multiple +call sites, now there's be multiple calls to f. + +Bottom line: treat all occurrences in a stable unfolding as "Many". +We still leave tail call information intact, though, as to not spoil +potential join points. + +Note [Unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally unfoldings and rules are already occurrence-analysed, so we +don't want to reconstruct their trees; we just want to analyse them to +find how they use their free variables. + +EXCEPT if there is a binder-swap going on, in which case we do want to +produce a new tree. + +So we have a fast-path that keeps the old tree if the occ_bs_env is +empty. This just saves a bit of allocation and reconstruction; not +a big deal. + +Two tricky corners: + +* Dead bindings (#22761). Supose we have + Unfolding = \x. let y = foo in x+1 + which includes a dead binding for `y`. In occAnalUnfolding we occ-anal + the unfolding and produce /no/ occurrences of `foo` (since `y` is + dead). But if we discard the occ-analysed syntax tree (which we do on + our fast path), and use the old one, we still /have/ an occurrence of + `foo` -- and that can lead to out-of-scope variables (#22761). + + Solution: always keep occ-analysed trees in unfoldings and rules, so they + have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core. + +* One-shot binders. Consider + {- f has Stable unfolding \p q -> blah + Demand on f is LC(L,C(1,!P(L)); that is, one-shot in its second ar -} + f = \x y. blah + + Now we `mkRhsOccEnv` will build an OccEnv for f's RHS that has + occ_one_shots = [NoOneShortInfo, OneShotLam] + This will put OneShotLam on the \y. And it'll put it on the \q. But the + noBinderSwap check will mean that we discard this new occ-anal'd unfolding + and keep the old one, with no OneShotInfo. + + This looks a little inconsistent, but the Stable unfolding is just used for + inlinings; OneShotInfo isn't a lot of use here. + +Note [Cascading inlines] +~~~~~~~~~~~~~~~~~~~~~~~~ +By default we use an OccRhs for the RHS of a binding. This tells the +occ anal n that it's looking at an RHS, which has an effect in +occAnalApp. In particular, for constructor applications, it makes +the arguments appear to have NoOccInfo, so that we don't inline into +them. Thus x = f y + k = Just x +we do not want to inline x. + +But there's a problem. Consider + x1 = a0 : [] + x2 = a1 : x1 + x3 = a2 : x2 + g = f x3 +First time round, it looks as if x1 and x2 occur as an arg of a +let-bound constructor ==> give them a many-occurrence. +But then x3 is inlined (unconditionally as it happens) and +next time round, x2 will be, and the next time round x1 will be +Result: multiple simplifier iterations. Sigh. + +So, when analysing the RHS of x3 we notice that x3 will itself +definitely inline the next time round, and so we analyse x3's rhs in +an OccVanilla context, not OccRhs. Hence the "certainly_inline" stuff. + +Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally. +If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and + (b) certainly_inline says "yes" when preInlineUnconditionally says "no" +then the simplifier iterates indefinitely: + x = f y + k = Just x -- We decide that k is 'certainly_inline' + v = ...k... -- but preInlineUnconditionally doesn't inline it +inline ==> + k = Just (f y) + v = ...k... +float ==> + x1 = f y + k = Just x1 + v = ...k... + +This is worse than the slow cascade, so we only want to say "certainly_inline" +if it really is certain. Look at the note with preInlineUnconditionally +for the various clauses. See #24582 for an example of the two getting out of sync. + + +************************************************************************ +* * + Expressions +* * +************************************************************************ +-} + +occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr] +occAnalList !_ [] = WUD emptyDetails [] +occAnalList env (e:es) = let + (WUD uds1 e') = occAnal env e + (WUD uds2 es') = occAnalList env es + in WUD (uds1 `andUDs` uds2) (e' : es') + +occAnal :: OccEnv + -> CoreExpr + -> WithUsageDetails CoreExpr -- Gives info only about the "interesting" Ids + +occAnal !_ expr@(Lit _) = WUD emptyDetails expr + +occAnal env expr@(Var _) = occAnalApp env (expr, [], []) + -- At one stage, I gathered the idRuleVars for the variable here too, + -- which in a way is the right thing to do. + -- But that went wrong right after specialisation, when + -- the *occurrences* of the overloaded function didn't have any + -- rules in them, so the *specialised* versions looked as if they + -- weren't used at all. + +occAnal _ expr@(Type ty) + = WUD (addManyOccs emptyDetails (coVarsOfType ty)) expr +occAnal _ expr@(Coercion co) + = WUD (addManyOccs emptyDetails (coVarsOfCo co)) expr + -- See Note [Gather occurrences of coercion variables] + +{- Note [Gather occurrences of coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to gather info about what coercion variables appear, for two reasons: + +1. So that we can sort them into the right place when doing dependency analysis. + +2. So that we know when they are surely dead. + +It is useful to know when they a coercion variable is surely dead, +when we want to discard a case-expression, in GHC.Core.Opt.Simplify.rebuildCase. +For example (#20143): + + case unsafeEqualityProof @blah of + UnsafeRefl cv -> ...no use of cv... + +Here we can discard the case, since unsafeEqualityProof always terminates. +But only if the coercion variable 'cv' is unused. + +Another example from #15696: we had something like + case eq_sel d of co -> ...(typeError @(...co...) "urk")... +Then 'd' was substituted by a dictionary, so the expression +simpified to + case (Coercion ) of cv -> ...(typeError @(...cv...) "urk")... + +We can only drop the case altogether if 'cv' is unused, which is not +the case here. + +Conclusion: we need accurate dead-ness info for CoVars. +We gather CoVar occurrences from: + + * The (Type ty) and (Coercion co) cases of occAnal + + * The type 'ty' of a lambda-binder (\(x:ty). blah) + See addCoVarOccs + +But it is not necessary to gather CoVars from the types of other binders. + +* For let-binders, if the type mentions a CoVar, so will the RHS (since + it has the same type) + +* For case-alt binders, if the type mentions a CoVar, so will the scrutinee + (since it has the same type) +-} + +occAnal env (Tick tickish body) + = WUD usage' (Tick tickish body') + where + WUD usage body' = occAnal env body + + usage' + | tickish `tickishScopesLike` SoftScope + = usage -- For soft-scoped ticks (including SourceNotes) we don't want + -- to lose join-point-hood, so we don't mess with `usage` (#24078) + + -- For a non-soft tick scope, we can inline lambdas only, so we + -- abandon tail calls, and do markAllInsideLam too: usage_lam + + | Breakpoint _ _ ids <- tickish + = -- Never substitute for any of the Ids in a Breakpoint + addManyOccs usage_lam (mkVarSet ids) + + | otherwise + = usage_lam + + usage_lam = markAllNonTail (markAllInsideLam usage) + + -- TODO There may be ways to make ticks and join points play + -- nicer together, but right now there are problems: + -- let j x = ... in tick (j 1) + -- Making j a join point may cause the simplifier to drop t + -- (if the tick is put into the continuation). So we don't + -- count j 1 as a tail call. + -- See #14242. + +occAnal env (Cast expr co) + = let (WUD usage expr') = occAnal env expr + usage1 = addManyOccs usage (coVarsOfCo co) + -- usage2: see Note [Gather occurrences of coercion variables] + usage2 = markAllNonTail usage1 + -- usage3: calls inside expr aren't tail calls any more + in WUD usage2 (Cast expr' co) + +occAnal env app@(App _ _) + = occAnalApp env (collectArgsTicks tickishFloatable app) + +occAnal env expr@(Lam {}) + = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail + occAnalLamTail env expr + +occAnal env (Case scrut bndr ty alts) + = let + WUD scrut_usage scrut' = occAnal (setScrutCtxt env alts) scrut + + WUD alts_usage (tagged_bndr, alts') + = addInScopeOne env bndr $ \env -> + let alt_env = addBndrSwap scrut' bndr $ + setTailCtxt env -- Kill off OccRhs + WUD alts_usage alts' = do_alts alt_env alts + tagged_bndr = tagLamBinder alts_usage bndr + in WUD alts_usage (tagged_bndr, alts') + + total_usage = markAllNonTail scrut_usage `andUDs` alts_usage + -- Alts can have tail calls, but the scrutinee can't + + in WUD total_usage (Case scrut' tagged_bndr ty alts') + where + do_alts :: OccEnv -> [CoreAlt] -> WithUsageDetails [CoreAlt] + do_alts _ [] = WUD emptyDetails [] + do_alts env (alt:alts) = WUD (uds1 `orUDs` uds2) (alt':alts') + where + WUD uds1 alt' = do_alt env alt + WUD uds2 alts' = do_alts env alts + + do_alt !env (Alt con bndrs rhs) + = addInScopeList env bndrs $ \ env -> + let WUD rhs_usage rhs' = occAnal env rhs + tagged_bndrs = tagLamBinders rhs_usage bndrs + in -- See Note [Binders in case alternatives] + WUD rhs_usage (Alt con tagged_bndrs rhs') + +occAnal env (Let bind body) + = occAnalBind env NotTopLevel noImpRuleEdges bind + (\env -> occAnal env body) mkLets + +occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] + -> [OneShots] -- Very commonly empty, notably prior to dmd anal + -> WithUsageDetails CoreExpr +-- The `fun` argument is just an accumulating parameter, +-- the base for building the application we return +occAnalArgs !env fun args !one_shots + = go emptyDetails fun args one_shots + where + env_args = setNonTailCtxt encl env + + -- Make bottoming functions interesting + -- See Note [Bottoming function calls] + encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut + | otherwise = OccVanilla + + go uds fun [] _ = WUD uds fun + go uds fun (arg:args) one_shots + = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots' + where + !(WUD arg_uds arg') = occAnal arg_env arg + !(arg_env, one_shots') + | isTypeArg arg + = (env_args, one_shots) + | otherwise + = case one_shots of + [] -> (env_args, []) -- Fast path; one_shots is often empty + (os : one_shots') -> (setOneShots os env_args, one_shots') + +{- +Applications are dealt with specially because we want +the "build hack" to work. + +Note [Bottoming function calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let x = (a,b) in + case p of + A -> ...(error x).. + B -> ...(ertor x)... + +postInlineUnconditionally may duplicate x's binding, but sometimes it +does so only if the use site IsInteresting. Pushing allocation into error +branches is good, so we try to make bottoming calls look interesting, by +setting occ_encl = OccScrut for such calls. + +The slightly-artificial test T21128 is a good example. It's probably +not a huge deal. + +Note [Arguments of let-bound constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let y = expensive x in + let z = (True,y) in + (case z of {(p,q)->q}, case z of {(p,q)->q}) +We feel free to duplicate the WHNF (True,y), but that means +that y may be duplicated thereby. + +If we aren't careful we duplicate the (expensive x) call! +Constructors are rather like lambdas in this way. +-} + +occAnalApp :: OccEnv + -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish]) + -> WithUsageDetails (Expr CoreBndr) +-- Naked variables (not applied) end up here too +occAnalApp !env (Var fun, args, ticks) + -- Account for join arity of runRW# continuation + -- See Note [Simplification of runRW#] + -- + -- NB: Do not be tempted to make the next (Var fun, args, tick) + -- equation into an 'otherwise' clause for this equation + -- The former has a bang-pattern to occ-anal the args, and + -- we don't want to occ-anal them twice in the runRW# case! + -- This caused #18296 + | fun `hasKey` runRWKey + , [t1, t2, arg] <- args + , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg + = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']) + +occAnalApp env (Var fun_id, args, ticks) + = WUD all_uds (mkTicks ticks app') + where + -- Lots of banged bindings: this is a very heavily bit of code, + -- so it pays not to make lots of thunks here, all of which + -- will ultimately be forced. + !(fun', fun_id') = lookupBndrSwap env fun_id + !(WUD args_uds app') = occAnalArgs env fun' args one_shots + + fun_uds = mkOneOcc env fun_id' int_cxt n_args + -- NB: fun_uds is computed for fun_id', not fun_id + -- See (BS1) in Note [The binder-swap substitution] + + all_uds = fun_uds `andUDs` final_args_uds + + !final_args_uds = markAllNonTail $ + markAllInsideLamIf (isRhsEnv env && is_exp) $ + -- isRhsEnv: see Note [OccEncl] + args_uds + -- We mark the free vars of the argument of a constructor or PAP + -- as "inside-lambda", if it is the RHS of a let(rec). + -- This means that nothing gets inlined into a constructor or PAP + -- argument position, which is what we want. Typically those + -- constructor arguments are just variables, or trivial expressions. + -- We use inside-lam because it's like eta-expanding the PAP. + -- + -- This is the *whole point* of the isRhsEnv predicate + -- See Note [Arguments of let-bound constructors] + + !n_val_args = valArgCount args + !n_args = length args + !int_cxt = case occ_encl env of + OccScrut -> IsInteresting + _other | n_val_args > 0 -> IsInteresting + | otherwise -> NotInteresting + + !is_exp = isExpandableApp fun_id n_val_args + -- See Note [CONLIKE pragma] in GHC.Types.Basic + -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs + + one_shots = argsOneShots (idDmdSig fun_id) guaranteed_val_args + guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo + (occ_one_shots env)) + -- See Note [Sources of one-shot information], bullet point A'] + +occAnalApp env (fun, args, ticks) + = WUD (markAllNonTail (fun_uds `andUDs` args_uds)) + (mkTicks ticks app') + where + !(WUD args_uds app') = occAnalArgs env fun' args [] + !(WUD fun_uds fun') = occAnal (addAppCtxt env args) fun + -- The addAppCtxt is a bit cunning. One iteration of the simplifier + -- often leaves behind beta redexes like + -- (\x y -> e) a1 a2 + -- Here we would like to mark x,y as one-shot, and treat the whole + -- thing much like a let. We do this by pushing some OneShotLam items + -- onto the context stack. + +addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv +addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args + | n_val_args > 0 + = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt + , occ_encl = OccVanilla } + -- OccVanilla: the function part of the application + -- is no longer on OccRhs or OccScrut + | otherwise + = env + where + n_val_args = valArgCount args + + +{- +Note [Sources of one-shot information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The occurrence analyser obtains one-shot-lambda information from two sources: + +A: Saturated applications: eg f e1 .. en + + In general, given a call (f e1 .. en) we can propagate one-shot info from + f's strictness signature into e1 .. en, but /only/ if n is enough to + saturate the strictness signature. A strictness signature like + + f :: C(1,C(1,L))LS + + means that *if f is applied to three arguments* then it will guarantee to + call its first argument at most once, and to call the result of that at + most once. But if f has fewer than three arguments, all bets are off; e.g. + + map (f (\x y. expensive) e2) xs + + Here the \x y abstraction may be called many times (once for each element of + xs) so we should not mark x and y as one-shot. But if it was + + map (f (\x y. expensive) 3 2) xs + + then the first argument of f will be called at most once. + + The one-shot info, derived from f's strictness signature, is + computed by 'argsOneShots', called in occAnalApp. + +A': Non-obviously saturated applications: eg build (f (\x y -> expensive)) + where f is as above. + + In this case, f is only manifestly applied to one argument, so it does not + look saturated. So by the previous point, we should not use its strictness + signature to learn about the one-shotness of \x y. But in this case we can: + build is fully applied, so we may use its strictness signature; and from + that we learn that build calls its argument with two arguments *at most once*. + + So there is really only one call to f, and it will have three arguments. In + that sense, f is saturated, and we may proceed as described above. + + Hence the computation of 'guaranteed_val_args' in occAnalApp, using + '(occ_one_shots env)'. See also #13227, comment:9 + +B: Let-bindings: eg let f = \c. let ... in \n -> blah + in (build f, build f) + + Propagate one-shot info from the demand-info on 'f' to the + lambdas in its RHS (which may not be syntactically at the top) + + This information must have come from a previous run of the demand + analyser. + +Previously, the demand analyser would *also* set the one-shot information, but +that code was buggy (see #11770), so doing it only in on place, namely here, is +saner. + +Note [OneShots] +~~~~~~~~~~~~~~~ +When analysing an expression, the occ_one_shots argument contains information +about how the function is being used. The length of the list indicates +how many arguments will eventually be passed to the analysed expression, +and the OneShotInfo indicates whether this application is once or multiple times. + +Example: + + Context of f occ_one_shots when analysing f + + f 1 2 [OneShot, OneShot] + map (f 1) [OneShot, NoOneShotInfo] + build f [OneShot, OneShot] + f 1 2 `seq` f 2 1 [NoOneShotInfo, OneShot] + +Note [Binders in case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case x of y { (a,b) -> f y } +We treat 'a', 'b' as dead, because they don't physically occur in the +case alternative. (Indeed, a variable is dead iff it doesn't occur in +its scope in the output of OccAnal.) It really helps to know when +binders are unused. See esp the call to isDeadBinder in +Simplify.mkDupableAlt + +In this example, though, the Simplifier will bring 'a' and 'b' back to +life, because it binds 'y' to (a,b) (imagine got inlined and +scrutinised y). +-} + +{- +************************************************************************ +* * + OccEnv +* * +************************************************************************ +-} + +data OccEnv + = OccEnv { occ_encl :: !OccEncl -- Enclosing context information + , occ_one_shots :: !OneShots -- See Note [OneShots] + , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active + , occ_rule_act :: Activation -> Bool -- Which rules are active + -- See Note [Finding rule RHS free vars] + + -- See Note [The binder-swap substitution] + -- If x :-> (y, co) is in the env, + -- then please replace x by (y |> mco) + -- Invariant of course: idType x = exprType (y |> mco) + , occ_bs_env :: !(IdEnv (OutId, MCoercion)) + -- Domain is Global and Local Ids + -- Range is just Local Ids + , occ_bs_rng :: !VarSet + -- Vars (TyVars and Ids) free in the range of occ_bs_env + + -- Usage details of the RHS of in-scope non-recursive join points + -- Invariant: no Id maps to an empty OccInfoEnv + -- See Note [Occurrence analysis for join points] + , occ_join_points :: !JoinPointInfo + } + +type JoinPointInfo = IdEnv OccInfoEnv + +----------------------------- +{- Note [OccEncl] +~~~~~~~~~~~~~~~~~ +OccEncl is used to control whether to inline into constructor arguments. + +* OccRhs: consider + let p = in + let x = Just p + in ...case p of ... + + Here `p` occurs syntactically once, but we want to mark it as InsideLam + to stop `p` inlining. We want to leave the x-binding as a constructor + applied to variables, so that the Simplifier can simplify that inner `case`. + + The OccRhs just tells occAnalApp to mark occurrences in constructor args + +* OccScrut: consider (case x of ...). Here we want to give `x` OneOcc + with "interesting context" field int_cxt = True. The OccScrut tells + occAnalApp (which deals with lone variables too) when to set this field + to True. +-} + +data OccEncl -- See Note [OccEncl] + = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda + | OccScrut -- Scrutintee of a case + | OccVanilla -- Everything else + +instance Outputable OccEncl where + ppr OccRhs = text "occRhs" + ppr OccScrut = text "occScrut" + ppr OccVanilla = text "occVanilla" + +-- See Note [OneShots] +type OneShots = [OneShotInfo] + +initOccEnv :: OccEnv +initOccEnv + = OccEnv { occ_encl = OccVanilla + , occ_one_shots = [] + + -- To be conservative, we say that all + -- inlines and rules are active + , occ_unf_act = \_ -> True + , occ_rule_act = \_ -> True + + , occ_join_points = emptyVarEnv + , occ_bs_env = emptyVarEnv + , occ_bs_rng = emptyVarSet } + +noBinderSwaps :: OccEnv -> Bool +noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env + +setScrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv +setScrutCtxt !env alts + = setNonTailCtxt encl env + where + encl | interesting_alts = OccScrut + | otherwise = OccVanilla + + interesting_alts = case alts of + [] -> False + [alt] -> not (isDefaultAlt alt) + _ -> True + -- 'interesting_alts' is True if the case has at least one + -- non-default alternative. That in turn influences + -- pre/postInlineUnconditionally. Grep for "occ_int_cxt"! + +{- Note [The OccEnv for a right hand side] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we create the OccEnv for a RHS (in mkRhsOccEnv)? + +For a non-join point binding, x = rhs + + * occ_encl: set to OccRhs; but see `mkNonRecRhsCtxt` for wrinkles + + * occ_join_points: zap them! + + * occ_one_shots: initialise from the idDemandInfo; + see Note [Sources of one-shot information] + +For a join point binding, j x = rhs + + * occ_encl: Consider + x = e + join j = Just x + We want to inline x into j right away, so we don't want to give the join point + a OccRhs (#14137); we want OccVanilla. It's not a huge deal, because the + FloatIn pass knows to float into join point RHSs; and the simplifier does not + float things out of join point RHSs. But it's a simple, cheap thing to do. + + * occ_join_points: no need to zap. + + * occ_one_shots: we start with one-shot-info from the context, which indeed + applies to the /body/ of the join point, after walking past the binders. + So we add to the front a OneShotInfo for each value-binder of the join + point: see `extendOneShotsForJoinPoint`. (Failing to account for the join-point + binders caused #25096.) + + For the join point binders themselves, of a /non-recursive/ join point, + we make the binder a OneShotLam. Again see `extendOneShotsForJoinPoint`. + + These one-shot infos then get attached to the binder by `occAnalLamTail`. +-} + +setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv +setNonTailCtxt ctxt !env + = env { occ_encl = ctxt + , occ_one_shots = [] + , occ_join_points = zapJoinPointInfo (occ_join_points env) } + +setTailCtxt :: OccEnv -> OccEnv +setTailCtxt !env = env { occ_encl = OccVanilla } + -- Preserve occ_one_shots, occ_join points + -- Do not use OccRhs for the RHS of a join point (which is a tail ctxt): + +mkRhsOccEnv :: OccEnv -> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv +-- See Note [The OccEnv for a right hand side] +-- For a join point: +-- - Keep occ_one_shots, occ_joinPoints from the context +-- - But push enough OneShotInfo onto occ_one_shots to account +-- for the join-point value binders +-- - Set occ_encl to OccVanilla +-- For non-join points +-- - Zap occ_one_shots and occ_join_points +-- - Set occ_encl to specified OccEncl +mkRhsOccEnv env@(OccEnv { occ_one_shots = ctxt_one_shots, occ_join_points = ctxt_join_points }) + is_rec encl jp_hood bndr rhs + | JoinPoint join_arity <- jp_hood + = env { occ_encl = OccVanilla + , occ_one_shots = extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots + , occ_join_points = ctxt_join_points } + + | otherwise + = env { occ_encl = encl + , occ_one_shots = argOneShots (idDemandInfo bndr) + -- argOneShots: see Note [Sources of one-shot information] + , occ_join_points = zapJoinPointInfo ctxt_join_points } + +zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo +-- (zapJoinPointInfo jp_info) basically just returns emptyVarEnv (hence zapped). +-- See (W3) of Note [Occurrence analysis for join points] +-- +-- Zapping improves efficiency, slightly, if you accidentally introduce a bug, +-- in which you zap [jx :-> uds] and then find an occurrence of jx anyway, you +-- might lose those uds, and that might mean we don't record all occurrencs, and +-- that means we duplicate a redex.... a very nasty bug (which I encountered!). +-- Hence this DEBUG code which doesn't remove jx from the envt; it just gives it +-- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch this +-- bug before it does any damage. +#ifdef DEBUG +zapJoinPointInfo jp_info = mapVarEnv (\ _ -> emptyVarEnv) jp_info +#else +zapJoinPointInfo _ = emptyVarEnv +#endif + +extendOneShotsForJoinPoint + :: RecFlag -> JoinArity -> CoreExpr + -> [OneShotInfo] -> [OneShotInfo] +-- Push enough OneShortInfos on the front of ctxt_one_shots +-- to account for the value lambdas of the join point +extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots + = go join_arity rhs + where + -- For a /non-recursive/ join point we can mark all + -- its join-lambda as one-shot; and it's a good idea to do so + -- But not so for recursive ones + os = case is_rec of + NonRecursive -> OneShotLam + Recursive -> NoOneShotInfo + + go 0 _ = ctxt_one_shots + go n (Lam b rhs) + | isId b = os : go (n-1) rhs + | otherwise = go (n-1) rhs + go _ _ = [] -- Not enough lambdas. This can legitimately happen. + -- e.g. let j = case ... in j True + -- This will become an arity-1 join point after the + -- simplifier has eta-expanded it; but it may not have + -- enough lambdas /yet/. (Lint checks that JoinIds do + -- have enough lambdas.) + +setOneShots :: OneShots -> OccEnv -> OccEnv +setOneShots os !env + | null os = env -- Fast path for common case + | otherwise = env { occ_one_shots = os } + +isRhsEnv :: OccEnv -> Bool +isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of + OccRhs -> True + _ -> False + +addInScopeList :: OccEnv -> [Var] + -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a +{-# INLINE addInScopeList #-} +addInScopeList env bndrs thing_inside + | null bndrs = thing_inside env -- E.g. nullary constructors in a `case` + | otherwise = addInScope env bndrs thing_inside + +addInScopeOne :: OccEnv -> Id + -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a +{-# INLINE addInScopeOne #-} +addInScopeOne env bndr = addInScope env [bndr] + +addInScope :: OccEnv -> [Var] + -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a +{-# INLINE addInScope #-} +-- This function is called a lot, so we want to inline the fast path +-- so we don't have to allocate thing_inside and call it +-- The bndrs must include TyVars as well as Ids, because of +-- (BS3) in Note [Binder swap] +-- We do not assume that the bndrs are in scope order; in fact the +-- call in occ_anal_lam_tail gives them to addInScope in /reverse/ order + +-- Fast path when the is no environment-munging to do +-- This is rather common: notably at top level, but nested too +addInScope env bndrs thing_inside + | isEmptyVarEnv (occ_bs_env env) + , isEmptyVarEnv (occ_join_points env) + , WUD uds res <- thing_inside env + = WUD (delBndrsFromUDs bndrs uds) res + +addInScope env bndrs thing_inside + = WUD uds' res + where + bndr_set = mkVarSet bndrs + !(env', bad_joins) = preprocess_env env bndr_set + !(WUD uds res) = thing_inside env' + uds' = postprocess_uds bndrs bad_joins uds + +preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo) +preprocess_env env@(OccEnv { occ_join_points = join_points + , occ_bs_rng = bs_rng_vars }) + bndr_set + | bad_joins = (drop_shadowed_swaps (drop_shadowed_joins env), join_points) + | otherwise = (drop_shadowed_swaps env, emptyVarEnv) + where + drop_shadowed_swaps :: OccEnv -> OccEnv + -- See Note [The binder-swap substitution] (BS3) + drop_shadowed_swaps env@(OccEnv { occ_bs_env = swap_env }) + | isEmptyVarEnv swap_env + = env + | bs_rng_vars `intersectsVarSet` bndr_set + = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet } + | otherwise + = env { occ_bs_env = swap_env `minusUFM` bndr_fm } + + drop_shadowed_joins :: OccEnv -> OccEnv + -- See Note [Occurrence analysis for join points] wrinkle2 (W1) and (W2) + drop_shadowed_joins env = env { occ_join_points = emptyVarEnv } + + -- bad_joins is true if it would be wrong to push occ_join_points inwards + -- (a) `bndrs` includes any of the occ_join_points + -- (b) `bndrs` includes any variables free in the RHSs of occ_join_points + bad_joins :: Bool + bad_joins = nonDetStrictFoldVarEnv_Directly is_bad False join_points + + bndr_fm :: UniqFM Var Var + bndr_fm = getUniqSet bndr_set + + is_bad :: Unique -> OccInfoEnv -> Bool -> Bool + is_bad uniq join_uds rest + = uniq `elemUniqSet_Directly` bndr_set || + not (bndr_fm `disjointUFM` join_uds) || + rest + +postprocess_uds :: [Var] -> JoinPointInfo -> UsageDetails -> UsageDetails +postprocess_uds bndrs bad_joins uds + = add_bad_joins (delBndrsFromUDs bndrs uds) + where + add_bad_joins :: UsageDetails -> UsageDetails + -- Add usage info for occ_join_points that we cannot push inwards + -- because of shadowing + -- See Note [Occurrence analysis for join points] wrinkle (W2) + add_bad_joins uds + | isEmptyVarEnv bad_joins = uds + | otherwise = modifyUDEnv extend_with_bad_joins uds + + extend_with_bad_joins :: OccInfoEnv -> OccInfoEnv + extend_with_bad_joins env + = nonDetStrictFoldUFM_Directly add_bad_join env bad_joins + + add_bad_join :: Unique -> OccInfoEnv -> OccInfoEnv -> OccInfoEnv + -- Behave like `andUDs` when adding in the bad_joins + add_bad_join uniq join_env env + | uniq `elemVarEnvByKey` env = plusVarEnv_C andLocalOcc env join_env + | otherwise = env + +addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv +addJoinPoint env bndr rhs_uds + | isEmptyVarEnv zeroed_form + = env + | otherwise + = env { occ_join_points = extendVarEnv (occ_join_points env) bndr zeroed_form } + where + zeroed_form = mkZeroedForm rhs_uds + +mkZeroedForm :: UsageDetails -> OccInfoEnv +-- See Note [Occurrence analysis for join points] for "zeroed form" +mkZeroedForm (UD { ud_env = rhs_occs }) + = mapMaybeUFM do_one rhs_occs + where + do_one :: LocalOcc -> Maybe LocalOcc + do_one (ManyOccL {}) = Nothing + do_one occ@(OneOccL {}) = Just (occ { lo_n_br = 0 }) + +-------------------- +transClosureFV :: VarEnv VarSet -> VarEnv VarSet +-- If (f,g), (g,h) are in the input, then (f,h) is in the output +-- as well as (f,g), (g,h) +transClosureFV env + | no_change = env + | otherwise = transClosureFV (listToUFM_Directly new_fv_list) + where + (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env) + -- It's OK to use nonDetUFMToList here because we'll forget the + -- ordering by creating a new set with listToUFM + bump no_change (b,fvs) + | no_change_here = (no_change, (b,fvs)) + | otherwise = (False, (b,new_fvs)) + where + (new_fvs, no_change_here) = extendFvs env fvs + +------------- +extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet +extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag + +extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool) +-- (extendFVs env s) returns +-- (s `union` env(s), env(s) `subset` s) +extendFvs env s + | isNullUFM env + = (s, True) + | otherwise + = (s `unionVarSet` extras, extras `subVarSet` s) + where + extras :: VarSet -- env(s) + extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $ + -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes + intersectUFM_C (\x _ -> x) env (getUniqSet s) + +{- +************************************************************************ +* * + Binder swap +* * +************************************************************************ + +Note [Binder swap] +~~~~~~~~~~~~~~~~~~ +The "binder swap" transformation swaps occurrence of the +scrutinee of a case for occurrences of the case-binder: + + (1) case x of b { pi -> ri } + ==> + case x of b { pi -> ri[b/x] } + + (2) case (x |> co) of b { pi -> ri } + ==> + case (x |> co) of b { pi -> ri[b |> sym co/x] } + +The substitution ri[b/x] etc is done by the occurrence analyser. +See Note [The binder-swap substitution]. + +There are two reasons for making this swap: + +(A) It reduces the number of occurrences of the scrutinee, x. + That in turn might reduce its occurrences to one, so we + can inline it and save an allocation. E.g. + let x = factorial y in case x of b { I# v -> ...x... } + If we replace 'x' by 'b' in the alternative we get + let x = factorial y in case x of b { I# v -> ...b... } + and now we can inline 'x', thus + case (factorial y) of b { I# v -> ...b... } + +(B) The case-binder b has unfolding information; in the + example above we know that b = I# v. That in turn allows + nested cases to simplify. Consider + case x of b { I# v -> + ...(case x of b2 { I# v2 -> rhs })... + If we replace 'x' by 'b' in the alternative we get + case x of b { I# v -> + ...(case b of b2 { I# v2 -> rhs })... + and now it is trivial to simplify the inner case: + case x of b { I# v -> + ...(let b2 = b in rhs)... + + The same can happen even if the scrutinee is a variable + with a cast: see Note [Case of cast] + +The reason for doing these transformations /here in the occurrence +analyser/ is because it allows us to adjust the OccInfo for 'x' and +'b' as we go. + + * Suppose the only occurrences of 'x' are the scrutinee and in the + ri; then this transformation makes it occur just once, and hence + get inlined right away. + + * If instead the Simplifier replaces occurrences of x with + occurrences of b, that will mess up b's occurrence info. That in + turn might have consequences. + +There is a danger though. Consider + let v = x +# y + in case (f v) of w -> ...v...v... +And suppose that (f v) expands to just v. Then we'd like to +use 'w' instead of 'v' in the alternative. But it may be too +late; we may have substituted the (cheap) x+#y for v in the +same simplifier pass that reduced (f v) to v. + +I think this is just too bad. CSE will recover some of it. + +Note [The binder-swap substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binder-swap is implemented by the occ_bs_env field of OccEnv. +There are two main pieces: + +* Given case x |> co of b { alts } + we add [x :-> (b, sym co)] to the occ_bs_env environment; this is + done by addBndrSwap. + +* Then, at an occurrence of a variable, we look up in the occ_bs_env + to perform the swap. This is done by lookupBndrSwap. + +Some tricky corners: + +(BS1) We do the substitution before gathering occurrence info. So in + the above example, an occurrence of x turns into an occurrence + of b, and that's what we gather in the UsageDetails. It's as + if the binder-swap occurred before occurrence analysis. See + the computation of fun_uds in occAnalApp. + +(BS2) When doing a lookup in occ_bs_env, we may need to iterate, + as you can see implemented in lookupBndrSwap. Why? + Consider case x of a { 1# -> e1; DEFAULT -> + case x of b { 2# -> e2; DEFAULT -> + case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}} + At the first case addBndrSwap will extend occ_bs_env with + [x :-> a] + At the second case we occ-anal the scrutinee 'x', which looks up + 'x in occ_bs_env, returning 'a', as it should. + Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding + occ_bs_env = [x :-> a, a :-> b] + At the third case we'll again look up 'x' which returns 'a'. + But we don't want to stop the lookup there, else we'll end up with + case x of a { 1# -> e1; DEFAULT -> + case a of b { 2# -> e2; DEFAULT -> + case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}} + Instead, we want iterate the lookup in addBndrSwap, to give + case x of a { 1# -> e1; DEFAULT -> + case a of b { 2# -> e2; DEFAULT -> + case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}} + This makes a particular difference for case-merge, which works + only if the scrutinee is the case-binder of the immediately enclosing + case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils + See #19581 for the bug report that showed this up. + +(BS3) We need care when shadowing. Suppose [x :-> b] is in occ_bs_env, + and we encounter: + (i) \x. blah + Here we want to delete the x-binding from occ_bs_env + + (ii) \b. blah + This is harder: we really want to delete all bindings that + have 'b' free in the range. That is a bit tiresome to implement, + so we compromise. We keep occ_bs_rng, which is the set of + free vars of rng(occc_bs_env). If a binder shadows any of these + variables, we discard all of occ_bs_env. Safe, if a bit + brutal. NB, however: the simplifer de-shadows the code, so the + next time around this won't happen. + + These checks are implemented in addInScope. + (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623) + because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we + must not replace `x` by `...a...` under /\a. ...x..., or similarly + under a case pattern match that binds `a`. + + An alternative would be for the occurrence analyser to do cloning as + it goes. In principle it could do so, but it'd make it a bit more + complicated and there is no great benefit. The simplifer uses + cloning to get a no-shadowing situation, the care-when-shadowing + behaviour above isn't needed for long. + +(BS4) The domain of occ_bs_env can include GlobaIds. Eg + case M.foo of b { alts } + We extend occ_bs_env with [M.foo :-> b]. That's fine. + +(BS5) We have to apply the occ_bs_env substitution uniformly, + including to (local) rules and unfoldings. + +(BS6) For interest (only), + see Historical Note [Care with binder-swap on dictionaries] + +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (x `cast` co) of b { I# -> + ... (case (x `cast` co) of {...}) ... +We'd like to eliminate the inner case. That is the motivation for +equation (2) in Note [Binder swap]. When we get to the inner case, we +inline x, cancel the casts, and away we go. + +Historical Note [Care with binder-swap on dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note is now out-dated; it has been rendered irrelevant by +Note [Unary class magic] in GHC.Core.TyCon. I'm leaving it here in +case we are every tempted to return to newtype classes. + +This (historical) Note explains why we need isDictId in scrutOkForBinderSwap. +Consider this tricky example (#21229, #21470): + + class Sing (b :: Bool) where sing :: Bool + instance Sing 'True where sing = True + instance Sing 'False where sing = False + + f :: forall a. Sing a => blah + + h = \ @(a :: Bool) ($dSing :: Sing a) + let the_co = Main.N:Sing[0] :: Sing a ~R# Bool + case ($dSing |> the_co) of wild + True -> f @'True (True |> sym the_co) + False -> f @a dSing + +Now do a binder-swap on the case-expression: + + h = \ @(a :: Bool) ($dSing :: Sing a) + let the_co = Main.N:Sing[0] :: Sing a ~R# Bool + case ($dSing |> the_co) of wild + True -> f @'True (True |> sym the_co) + False -> f @a (wild |> sym the_co) + +And now substitute `False` for `wild` (since wild=False in the False branch): + + h = \ @(a :: Bool) ($dSing :: Sing a) + let the_co = Main.N:Sing[0] :: Sing a ~R# Bool + case ($dSing |> the_co) of wild + True -> f @'True (True |> sym the_co) + False -> f @a (False |> sym the_co) + +And now we have a problem. The specialiser will specialise (f @a d)a (for all +vtypes a and dictionaries d!!) with the dictionary (False |> sym the_co), using +Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise. + +The real problem is the binder-swap. It swaps a dictionary variable $dSing +(of kind Constraint) for a term variable wild (of kind Type). And that is +dangerous: a dictionary is a /singleton/ type whereas a general term variable is +not. In this particular example, Bool is most certainly not a singleton type! + +Conclusion: + for a /dictionary variable/ do not perform + the clever cast version of the binder-swap + +Hence the subtle isDictId in scrutOkForBinderSwap. + +Why this Note is now outdated. Using Note [Unary class magic] in GHC.Core.TyCon +the program above becomes + h = \ @(a :: Bool) ($dSing :: Sing a) + case sing @a $dSing of (wild::Bool) + True -> f @'True $dSing + False -> f @a $dSing +so the issue of binder-swapping doesn't arise. + +End of Historical Note. + +Note [Zap case binders in proxy bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From the original + case x of cb(dead) { p -> ...x... } +we will get + case x of cb(live) { p -> ...cb... } + +Core Lint never expects to find an *occurrence* of an Id marked +as Dead, so we must zap the OccInfo on cb before making the +binding x = cb. See #5028. + +NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier +doesn't use it. So this is only to satisfy the perhaps-over-picky Lint. + +-} + +addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv +-- See Note [The binder-swap substitution] +addBndrSwap scrut case_bndr + env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) + | DoBinderSwap scrut_var mco <- scrutOkForBinderSwap scrut + , scrut_var /= case_bndr + -- Consider: case x of x { ... } + -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop + = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco) + , occ_bs_rng = rng_vars `extendVarSet` case_bndr' + `unionVarSet` tyCoVarsOfMCo mco } + + | otherwise + = env + where + case_bndr' = zapIdOccInfo case_bndr + -- See Note [Zap case binders in proxy bindings] + +-- | See bBinderSwaOk. +data BinderSwapDecision + = NoBinderSwap + | DoBinderSwap OutVar MCoercion + +scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision +-- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then +-- v = e |> mco +-- See Note [Case of cast] +-- See Historical Note [Care with binder-swap on dictionaries] +-- +-- We use this same function in SpecConstr, and Simplify.Iteration, +-- when something binder-swap-like is happening +scrutOkForBinderSwap e + = case e of + Tick _ e -> scrutOkForBinderSwap e -- Drop ticks + Var v -> DoBinderSwap v MRefl + Cast (Var v) co -> DoBinderSwap v (MCo (mkSymCo co)) + -- Cast: see Note [Case of cast] + _ -> NoBinderSwap + +lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id) +-- See Note [The binder-swap substitution] +-- Returns an expression of the same type as Id +lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env }) bndr + = case lookupVarEnv bs_env bndr of { + Nothing -> (Var bndr, bndr) ; + Just (bndr1, mco) -> + + -- Why do we iterate here? + -- See (BS2) in Note [The binder-swap substitution] + case lookupBndrSwap env bndr1 of + (fun, fun_id) -> (mkCastMCo fun mco, fun_id) } + +{- Historical note [Proxy let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to do the binder-swap transformation by introducing +a proxy let-binding, thus; + + case x of b { pi -> ri } + ==> + case x of b { pi -> let x = b in ri } + +But that had two problems: + +1. If 'x' is an imported GlobalId, we'd end up with a GlobalId + on the LHS of a let-binding which isn't allowed. We worked + around this for a while by "localising" x, but it turned + out to be very painful #16296, + +2. In CorePrep we use the occurrence analyser to do dead-code + elimination (see Note [Dead code in CorePrep]). But that + occasionally led to an unlifted let-binding + case x of b { DEFAULT -> let x::Int# = b in ... } + which disobeys one of CorePrep's output invariants (no unlifted + let-bindings) -- see #5433. + +Doing a substitution (via occ_bs_env) is much better. + +Historical Note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We *used* to suppress the binder-swap in case expressions when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + which might prevent some full laziness happening. I've seen this + in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] + Hence the check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. + +Historical Note [Suppressing the case binder-swap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This old note describes a problem that is also fixed by doing the +binder-swap in OccAnal: + + There is another situation when it might make sense to suppress the + case-expression binde-swap. If we have + + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } + + We'll perform the binder-swap for the outer case, giving + + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } + + But there is no point in doing it for the inner case, because w1 can't + be inlined anyway. Furthermore, doing the case-swapping involves + zapping w2's occurrence info (see paragraphs that follow), and that + forces us to bind w2 when doing case merging. So we get + + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } + + This is plain silly in the common case where w2 is dead. + + Even so, I can't see a good way to implement this idea. I tried + not doing the binder-swap if the scrutinee was already evaluated + but that failed big-time: + + data T = MkT !Int + + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... + + Notice that because MkT is strict, x is marked "evaluated". But to + eliminate the last case, we must either make sure that x (as well as + x1) has unfolding MkT y1. The straightforward thing to do is to do + the binder-swap. So this whole note is a no-op. + +It's fixed by doing the binder-swap in OccAnal because we can do the +binder-swap unconditionally and still get occurrence analysis +information right. + + +************************************************************************ +* * +\subsection[OccurAnal-types]{OccEnv} +* * +************************************************************************ + +Note [UsageDetails and zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On many occasions, we must modify all gathered occurrence data at once. For +instance, all occurrences underneath a (non-one-shot) lambda set the +'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but +that takes O(n) time and we will do this often---in particular, there are many +places where tail calls are not allowed, and each of these causes all variables +to get marked with 'NoTailCallInfo'. + +Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along +with the 'OccInfoEnv'. Each of these extra environments is a "zapped set" +recording which variables have been zapped in some way. Zapping all occurrence +info then simply means setting the corresponding zapped set to the whole +'OccInfoEnv', a fast O(1) operation. + +Note [LocalOcc] +~~~~~~~~~~~~~~~ +LocalOcc is used purely internally, in the occurrence analyser. It differs from +GHC.Types.Basic.OccInfo because it has only OneOcc and ManyOcc; it does not need +IAmDead or IAmALoopBreaker. + +Note that `OneOccL` doesn't meant that it occurs /syntactially/ only once; it +means that it is /used/ only once. It might occur syntactically many times. +For example, in (case x of A -> y; B -> y; C -> True), +* `y` is used only once +* but it occurs syntactically twice + +-} + +type OccInfoEnv = IdEnv LocalOcc -- A finite map from an expression's + -- free variables to their usage + +data LocalOcc -- See Note [LocalOcc] + = OneOccL { lo_n_br :: {-# UNPACK #-} !BranchCount -- Number of syntactic occurrences + , lo_tail :: !TailCallInfo + -- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3) + -- gives NoTailCallInfo + , lo_int_cxt :: !InterestingCxt } + | ManyOccL !TailCallInfo + +instance Outputable LocalOcc where + ppr (OneOccL { lo_n_br = n, lo_tail = tci }) + = text "OneOccL" <> braces (ppr n <> comma <> ppr tci) + ppr (ManyOccL tci) = text "ManyOccL" <> braces (ppr tci) + +localTailCallInfo :: LocalOcc -> TailCallInfo +localTailCallInfo (OneOccL { lo_tail = tci }) = tci +localTailCallInfo (ManyOccL tci) = tci + +type ZappedSet = OccInfoEnv -- Values are ignored + +data UsageDetails + = UD { ud_env :: !OccInfoEnv + , ud_z_many :: !ZappedSet -- apply 'markMany' to these + , ud_z_in_lam :: !ZappedSet -- apply 'markInsideLam' to these + , ud_z_tail :: !ZappedSet -- zap tail-call info for these + } + -- INVARIANT: All three zapped sets are subsets of ud_env + +instance Outputable UsageDetails where + ppr ud@(UD { ud_env = env, ud_z_tail = z_tail }) + = text "UD" <+> (braces $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr (lookupOccInfoByUnique ud uq) + | (uq, _) <- nonDetStrictFoldVarEnv_Directly do_one [] env ]) + $$ nest 2 (text "ud_z_tail" <+> ppr z_tail) + where + do_one :: Unique -> LocalOcc -> [(Unique,LocalOcc)] -> [(Unique,LocalOcc)] + do_one uniq occ occs = (uniq, occ) : occs + +--------------------- +-- | TailUsageDetails captures the result of applying 'occAnalLamTail' +-- to a function `\xyz.body`. The TailUsageDetails pairs together +-- * the number of lambdas (including type lambdas: a JoinArity) +-- * UsageDetails for the `body` of the lambda, unadjusted by `adjustTailUsage`. +-- If the binding turns out to be a join point with the indicated join +-- arity, this unadjusted usage details is just what we need; otherwise we +-- need to discard tail calls. That's what `adjustTailUsage` does. +data TailUsageDetails = TUD !JoinArity !UsageDetails + +instance Outputable TailUsageDetails where + ppr (TUD ja uds) = lambda <> ppr ja <> ppr uds + +--------------------- +data WithUsageDetails a = WUD !UsageDetails !a +data WithTailUsageDetails a = WTUD !TailUsageDetails !a + +------------------- +-- UsageDetails API + +andUDs, orUDs + :: UsageDetails -> UsageDetails -> UsageDetails +andUDs = combineUsageDetailsWith andLocalOcc +orUDs = combineUsageDetailsWith orLocalOcc + +mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails +mkOneOcc !env id int_cxt arity + | not (isLocalId id) + = emptyDetails + + | Just join_uds <- lookupVarEnv (occ_join_points env) id + = -- See Note [Occurrence analysis for join points] + assertPpr (not (isEmptyVarEnv join_uds)) (ppr id) $ + -- We only put non-empty join-points into occ_join_points + mkSimpleDetails (extendVarEnv join_uds id occ) + + | otherwise + = mkSimpleDetails (unitVarEnv id occ) + + where + occ = OneOccL { lo_n_br = 1, lo_int_cxt = int_cxt + , lo_tail = AlwaysTailCalled arity } + +-- Add several occurrences, assumed not to be tail calls +add_many_occ :: Var -> OccInfoEnv -> OccInfoEnv +add_many_occ v env | isId v = extendVarEnv env v (ManyOccL NoTailCallInfo) + | otherwise = env + -- Give a non-committal binder info (i.e noOccInfo) because + -- a) Many copies of the specialised thing can appear + -- b) We don't want to substitute a BIG expression inside a RULE + -- even if that's the only occurrence of the thing + -- (Same goes for INLINE.) + +addManyOccs :: UsageDetails -> VarSet -> UsageDetails +addManyOccs uds var_set + | isEmptyVarSet var_set = uds + | otherwise = uds { ud_env = add_to (ud_env uds) } + where + add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set + -- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes + +addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails +-- Add any CoVars free in the type of a lambda-binder +-- See Note [Gather occurrences of coercion variables] +addLamCoVarOccs uds bndrs + = foldr add uds bndrs + where + add bndr uds = uds `addManyOccs` coVarsOfType (varType bndr) + +emptyDetails :: UsageDetails +emptyDetails = mkSimpleDetails emptyVarEnv + +isEmptyDetails :: UsageDetails -> Bool +isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env + +mkSimpleDetails :: OccInfoEnv -> UsageDetails +mkSimpleDetails env = UD { ud_env = env + , ud_z_many = emptyVarEnv + , ud_z_in_lam = emptyVarEnv + , ud_z_tail = emptyVarEnv } + +modifyUDEnv :: (OccInfoEnv -> OccInfoEnv) -> UsageDetails -> UsageDetails +modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env } + +delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails +-- Delete these binders from the UsageDetails +delBndrsFromUDs bndrs (UD { ud_env = env, ud_z_many = z_many + , ud_z_in_lam = z_in_lam, ud_z_tail = z_tail }) + = UD { ud_env = env `delVarEnvList` bndrs + , ud_z_many = z_many `delVarEnvList` bndrs + , ud_z_in_lam = z_in_lam `delVarEnvList` bndrs + , ud_z_tail = z_tail `delVarEnvList` bndrs } + +markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail + :: UsageDetails -> UsageDetails +markAllMany ud@(UD { ud_env = env }) = ud { ud_z_many = env } +markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env } +markAllNonTail ud@(UD { ud_env = env }) = ud { ud_z_tail = env } +markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo + +markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails + +markAllInsideLamIf True ud = markAllInsideLam ud +markAllInsideLamIf False ud = ud + +markAllNonTailIf True ud = markAllNonTail ud +markAllNonTailIf False ud = ud + +lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo +lookupTailCallInfo uds id + | UD { ud_z_tail = z_tail, ud_env = env } <- uds + , not (id `elemVarEnv` z_tail) + , Just occ <- lookupVarEnv env id + = localTailCallInfo occ + | otherwise + = NoTailCallInfo + +udFreeVars :: VarSet -> UsageDetails -> VarSet +-- Find the subset of bndrs that are mentioned in uds +udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env + +restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet +restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs + +------------------- +-- Auxiliary functions for UsageDetails implementation + +combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc) + -> UsageDetails -> UsageDetails -> UsageDetails +{-# INLINE combineUsageDetailsWith #-} +combineUsageDetailsWith plus_occ_info + uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 }) + uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 }) + | isEmptyVarEnv env1 = uds2 + | isEmptyVarEnv env2 = uds1 + | otherwise + = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2 + , ud_z_many = plusVarEnv z_many1 z_many2 + , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 + , ud_z_tail = plusVarEnv z_tail1 z_tail2 } + +lookupLetOccInfo :: UsageDetails -> Id -> OccInfo +-- Don't use locally-generated occ_info for exported (visible-elsewhere) +-- things. Instead just give noOccInfo. +-- NB: setBinderOcc will (rightly) erase any LoopBreaker info; +-- we are about to re-generate it and it shouldn't be "sticky" +lookupLetOccInfo ud id + | isExportedId id = noOccInfo + | otherwise = lookupOccInfoByUnique ud (idUnique id) + +lookupOccInfo :: UsageDetails -> Id -> OccInfo +lookupOccInfo ud id = lookupOccInfoByUnique ud (idUnique id) + +lookupOccInfoByUnique :: UsageDetails -> Unique -> OccInfo +lookupOccInfoByUnique (UD { ud_env = env + , ud_z_many = z_many + , ud_z_in_lam = z_in_lam + , ud_z_tail = z_tail }) + uniq + = case lookupVarEnv_Directly env uniq of + Nothing -> IAmDead + Just (OneOccL { lo_n_br = n_br, lo_int_cxt = int_cxt + , lo_tail = tail_info }) + | uniq `elemVarEnvByKey`z_many + -> ManyOccs { occ_tail = mk_tail_info tail_info } + | otherwise + -> OneOcc { occ_in_lam = in_lam + , occ_n_br = n_br + , occ_int_cxt = int_cxt + , occ_tail = mk_tail_info tail_info } + where + in_lam | uniq `elemVarEnvByKey` z_in_lam = IsInsideLam + | otherwise = NotInsideLam + + Just (ManyOccL tail_info) -> ManyOccs { occ_tail = mk_tail_info tail_info } + where + mk_tail_info ti + | uniq `elemVarEnvByKey` z_tail = NoTailCallInfo + | otherwise = ti + + + +------------------- +-- See Note [Adjusting right-hand sides] + +adjustNonRecRhs :: JoinPointHood + -> WithTailUsageDetails CoreExpr + -> WithUsageDetails CoreExpr +-- ^ This function concentrates shared logic between occAnalNonRecBind and the +-- AcyclicSCC case of occAnalRec. +-- It returns the adjusted rhs UsageDetails combined with the body usage +adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs) + = WUD (adjustTailUsage mb_join_arity rhs_wuds) rhs + + +adjustTailUsage :: JoinPointHood + -> WithTailUsageDetails CoreExpr -- Rhs usage, AFTER occAnalLamTail + -> UsageDetails +adjustTailUsage mb_join_arity (WTUD (TUD rhs_ja uds) rhs) + = -- c.f. occAnal (Lam {}) + markAllInsideLamIf (not one_shot) $ + markAllNonTailIf (not exact_join) $ + uds + where + one_shot = isOneShotFun rhs + exact_join = mb_join_arity == JoinPoint rhs_ja + +adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails +adjustTailArity mb_rhs_ja (TUD ja usage) + = markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage + +type IdWithOccInfo = Id + +tagLamBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> [IdWithOccInfo] -- Tagged binders +tagLamBinders usage binders + = map (tagLamBinder usage) binders + +tagLamBinder :: UsageDetails -- Of scope + -> Id -- Binder + -> IdWithOccInfo -- Tagged binders +-- Used for lambda and case binders +-- No-op on TyVars +-- A lambda binder never has an unfolding, so no need to look for that +tagLamBinder usage bndr + = setBinderOcc (markNonTail occ) bndr + -- markNonTail: don't try to make an argument into a join point + where + occ = lookupOccInfo usage bndr + +tagNonRecBinder :: TopLevelFlag -- At top level? + -> OccInfo -- Of scope + -> CoreBndr -- Binder + -> (IdWithOccInfo, JoinPointHood) -- Tagged binder +-- No-op on TyVars +-- Precondition: OccInfo is not IAmDead +tagNonRecBinder lvl occ bndr + | okForJoinPoint lvl bndr tail_call_info + , AlwaysTailCalled ar <- tail_call_info + = (setBinderOcc occ bndr, JoinPoint ar) + | otherwise + = (setBinderOcc zapped_occ bndr, NotJoinPoint) + where + tail_call_info = tailCallInfo occ + zapped_occ = markNonTail occ + +tagRecBinders :: TopLevelFlag -- At top level? + -> UsageDetails -- Of body of let ONLY + -> [NodeDetails] + -> WithUsageDetails -- Adjusted details for whole scope, + -- with binders removed + [IdWithOccInfo] -- Tagged binders +-- Substantially more complicated than non-recursive case. Need to adjust RHS +-- details *before* tagging binders (because the tags depend on the RHSes). +tagRecBinders lvl body_uds details_s + = let + bndrs = map nd_bndr details_s + + -- 1. See Note [Join arity prediction based on joinRhsArity] + -- Determine possible join-point-hood of whole group, by testing for + -- manifest join arity M. + -- This (re-)asserts that makeNode had made tuds for that same arity M! + unadj_uds = foldr (andUDs . test_manifest_arity) body_uds details_s + test_manifest_arity ND{nd_rhs = WTUD tuds rhs} + = adjustTailArity (JoinPoint (joinRhsArity rhs)) tuds + + will_be_joins = decideRecJoinPointHood lvl unadj_uds bndrs + + mb_join_arity :: Id -> JoinPointHood + -- mb_join_arity: See Note [Join arity prediction based on joinRhsArity] + -- This is the source O + mb_join_arity bndr + -- Can't use willBeJoinId_maybe here because we haven't tagged + -- the binder yet (the tag depends on these adjustments!) + | will_be_joins + , AlwaysTailCalled arity <- lookupTailCallInfo unadj_uds bndr + = JoinPoint arity + | otherwise + = assert (not will_be_joins) -- Should be AlwaysTailCalled if + NotJoinPoint -- we are making join points! + + -- 2. Adjust usage details of each RHS, taking into account the + -- join-point-hood decision + rhs_udss' = [ adjustTailUsage (mb_join_arity bndr) rhs_wuds + -- Matching occAnalLamTail in makeNode + | ND { nd_bndr = bndr, nd_rhs = rhs_wuds } <- details_s ] + + -- 3. Compute final usage details from adjusted RHS details + adj_uds = foldr andUDs body_uds rhs_udss' + + -- 4. Tag each binder with its adjusted details + bndrs' = [ setBinderOcc (lookupLetOccInfo adj_uds bndr) bndr + | bndr <- bndrs ] + + in + WUD adj_uds bndrs' + +setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr +setBinderOcc occ_info bndr + | isTyVar bndr = bndr + | occ_info == idOccInfo bndr = bndr + | otherwise = setIdOccInfo bndr occ_info + +-- | Decide whether some bindings should be made into join points or not, based +-- on its occurrences. This is +-- Returns `False` if they can't be join points. Note that it's an +-- all-or-nothing decision, as if multiple binders are given, they're +-- assumed to be mutually recursive. +-- +-- It must, however, be a final decision. If we say `True` for 'f', +-- and then subsequently decide /not/ make 'f' into a join point, then +-- the decision about another binding 'g' might be invalidated if (say) +-- 'f' tail-calls 'g'. +-- +-- See Note [Invariants on join points] in "GHC.Core". +decideRecJoinPointHood :: TopLevelFlag -> UsageDetails + -> [CoreBndr] -> Bool +decideRecJoinPointHood lvl usage bndrs + = all ok bndrs -- Invariant 3: Either all are join points or none are + where + ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr) + +okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool + -- See Note [Invariants on join points]; invariants cited by number below. + -- Invariant 2 is always satisfiable by the simplifier by eta expansion. +okForJoinPoint lvl bndr tail_call_info + | isJoinId bndr -- A current join point should still be one! + = warnPprTrace lost_join "Lost join point" lost_join_doc $ + True + | valid_join + = True + | otherwise + = False + where + valid_join | NotTopLevel <- lvl + , AlwaysTailCalled arity <- tail_call_info + + , -- Invariant 1 as applied to LHSes of rules + all (ok_rule arity) (idCoreRules bndr) + + -- Invariant 2a: stable unfoldings + -- See Note [Join points and INLINE pragmas] + , ok_unfolding arity (realIdUnfolding bndr) + + -- Invariant 4: Satisfies polymorphism rule + , isValidJoinPointType arity (idType bndr) + = True + | otherwise + = False + + lost_join | JoinPoint ja <- idJoinPointHood bndr + = not valid_join || + (case tail_call_info of -- Valid join but arity differs + AlwaysTailCalled ja' -> ja /= ja' + _ -> False) + | otherwise = False + + ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans + ok_rule join_arity (Rule { ru_args = args }) + = args `lengthIs` join_arity + -- Invariant 1 as applied to LHSes of rules + + -- ok_unfolding returns False if we should /not/ convert a non-join-id + -- into a join-id, even though it is AlwaysTailCalled + ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs }) + = not (isStableSource src && join_arity > joinRhsArity rhs) + ok_unfolding _ (DFunUnfolding {}) + = False + ok_unfolding _ _ + = True + + lost_join_doc + = vcat [ text "bndr:" <+> ppr bndr + , text "tc:" <+> ppr tail_call_info + , text "rules:" <+> ppr (idCoreRules bndr) + , case tail_call_info of + AlwaysTailCalled arity -> + vcat [ text "ok_unf:" <+> ppr (ok_unfolding arity (realIdUnfolding bndr)) + , text "ok_type:" <+> ppr (isValidJoinPointType arity (idType bndr)) ] + _ -> empty ] + +{- Note [Join points and INLINE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let g = \x. not -- Arity 1 + {-# INLINE g #-} + in case x of + A -> g True True + B -> g True False + C -> blah2 + +Here 'g' is always tail-called applied to 2 args, but the stable +unfolding captured by the INLINE pragma has arity 1. If we try to +convert g to be a join point, its unfolding will still have arity 1 +(since it is stable, and we don't meddle with stable unfoldings), and +Lint will complain (see Note [Invariants on join points], (2a), in +GHC.Core. #13413. + +Moreover, since g is going to be inlined anyway, there is no benefit +from making it a join point. + +If it is recursive, and uselessly marked INLINE, this will stop us +making it a join point, which is annoying. But occasionally +(notably in class methods; see Note [Instances and loop breakers] in +GHC.Tc.TyCl.Instance) we mark recursive things as INLINE but the recursion +unravels; so ignoring INLINE pragmas on recursive things isn't good +either. + +See Invariant 2a of Note [Invariants on join points] in GHC.Core + + +************************************************************************ +* * +\subsection{Operations over OccInfo} +* * +************************************************************************ +-} + +markNonTail :: OccInfo -> OccInfo +markNonTail IAmDead = IAmDead +markNonTail occ = occ { occ_tail = NoTailCallInfo } + +andLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc +andLocalOcc occ1 occ2 = ManyOccL (tci1 `andTailCallInfo` tci2) + where + !tci1 = localTailCallInfo occ1 + !tci2 = localTailCallInfo occ2 + +orLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc +-- (orLocalOcc occ1 occ2) is used +-- when combining occurrence info from branches of a case +orLocalOcc (OneOccL { lo_n_br = nbr1, lo_int_cxt = int_cxt1, lo_tail = tci1 }) + (OneOccL { lo_n_br = nbr2, lo_int_cxt = int_cxt2, lo_tail = tci2 }) + = OneOccL { lo_n_br = nbr1 + nbr2 + , lo_int_cxt = int_cxt1 `mappend` int_cxt2 + , lo_tail = tci1 `andTailCallInfo` tci2 } +orLocalOcc occ1 occ2 = andLocalOcc occ1 occ2 + +andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo +andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2) + | arity1 == arity2 = info +andTailCallInfo _ _ = NoTailCallInfo diff --git a/GHC/Core/Opt/Pipeline.hs b/GHC/Core/Opt/Pipeline.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Pipeline.hs @@ -0,0 +1,582 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[SimplCore]{Driver for simplifying @Core@ programs} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) +import GHC.Driver.Env +import GHC.Driver.Config.Core.Lint ( endPass ) +import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts ) +import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode ) +import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts ) +import GHC.Driver.Config.Core.Rules ( initRuleOpts ) +import GHC.Platform.Ways ( hasWay, Way(WayProf) ) + +import GHC.Core +import GHC.Core.Opt.CSE ( cseProgram ) +import GHC.Core.Rules ( RuleBase, ruleCheckProgram, getRules ) +import GHC.Core.Ppr ( pprCoreBindings ) +import GHC.Core.Utils ( dumpIdInfoOfProgram ) +import GHC.Core.Lint ( lintAnnots ) +import GHC.Core.Lint.Interactive ( interactiveInScope ) +import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm ) +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Opt.Monad +import GHC.Core.Opt.Pipeline.Types +import GHC.Core.Opt.FloatIn ( floatInwards ) +import GHC.Core.Opt.FloatOut ( floatOutwards ) +import GHC.Core.Opt.LiberateCase ( liberateCase ) +import GHC.Core.Opt.StaticArgs ( doStaticArgs ) +import GHC.Core.Opt.Specialise ( specProgram) +import GHC.Core.Opt.SpecConstr ( specConstrProgram) +import GHC.Core.Opt.DmdAnal +import GHC.Core.Opt.CprAnal ( cprAnalProgram ) +import GHC.Core.Opt.CallArity ( callArityAnalProgram ) +import GHC.Core.Opt.Exitify ( exitifyProgram ) +import GHC.Core.Opt.WorkWrap ( wwTopBinds ) +import GHC.Core.Opt.CallerCC ( addCallerCostCentres ) +import GHC.Core.LateCC.TopLevelBinds (topLevelBindsCCMG) +import GHC.Core.Seq (seqBinds) +import GHC.Core.FamInstEnv + +import GHC.Utils.Error ( withTiming ) +import GHC.Utils.Logger as Logger +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Unit.Module.ModGuts + +import GHC.Types.Id.Info +import GHC.Types.Basic +import GHC.Types.Demand ( zapDmdEnvSig ) +import GHC.Types.Name.Ppr +import GHC.Types.Var ( Var ) + +import Control.Monad +import qualified GHC.LanguageExtensions as LangExt +import GHC.Unit.Module + +{- +************************************************************************ +* * +\subsection{The driver for the simplifier} +* * +************************************************************************ +-} + +core2core :: HscEnv -> ModGuts -> IO ModGuts +core2core hsc_env guts@(ModGuts { mg_module = mod + , mg_loc = loc + , mg_rdr_env = rdr_env }) + = do { hpt_rule_base <- home_pkg_rules + ; let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars + uniq_tag = 's' + + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod + name_ppr_ctx loc $ + do { hsc_env' <- getHscEnv + ; all_passes <- withPlugins (hsc_plugins hsc_env') + installCoreToDos + builtin_passes + ; runCorePasses all_passes guts } + + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats + "Grand total simplifier statistics" + FormatText + (pprSimplCount stats) + + ; return guts2 } + where + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + unit_env = hsc_unit_env hsc_env + extra_vars = interactiveInScope (hsc_IC hsc_env) + home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod) + (GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot }) + name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env + ptc = initPromotionTickContext dflags + -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. + -- This is very convienent for the users of the monad (e.g. plugins do not have to + -- consume the ModGuts to find the module) but somewhat ugly because mg_module may + -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which + -- would mean our cached value would go out of date. + +{- +************************************************************************ +* * + Generating the main optimisation pipeline +* * +************************************************************************ +-} + +getCoreToDo :: DynFlags -> RuleBase -> [Var] -> [CoreToDo] +-- This function builds the pipeline of optimisations +getCoreToDo dflags hpt_rule_base extra_vars + = flatten_todos core_todo + where + phases = simplPhases dflags + max_iter = maxSimplIterations dflags + rule_check = ruleCheck dflags + const_fold = gopt Opt_CoreConstantFolding dflags + call_arity = gopt Opt_CallArity dflags + exitification = gopt Opt_Exitification dflags + strictness = gopt Opt_Strictness dflags + full_laziness = gopt Opt_FullLaziness dflags + do_specialise = gopt Opt_Specialise dflags + do_float_in = gopt Opt_FloatIn dflags + cse = gopt Opt_CSE dflags + spec_constr = gopt Opt_SpecConstr dflags + liberate_case = gopt Opt_LiberateCase dflags + late_dmd_anal = gopt Opt_LateDmdAnal dflags + late_specialise = gopt Opt_LateSpecialise dflags + static_args = gopt Opt_StaticArgumentTransformation dflags + rules_on = gopt Opt_EnableRewriteRules dflags + ww_on = gopt Opt_WorkerWrapper dflags + static_ptrs = xopt LangExt.StaticPointers dflags + profiling = ways dflags `hasWay` WayProf + + do_presimplify = do_specialise -- TODO: any other optimizations benefit from pre-simplification? + do_simpl3 = const_fold || rules_on -- TODO: any other optimizations benefit from three-phase simplification? + + maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) + + maybe_strictness_before (Phase phase) + | phase `elem` strictnessBefore dflags = CoreDoDemand False + maybe_strictness_before _ + = CoreDoNothing + + simpl_phase phase name iter + = CoreDoPasses + $ [ maybe_strictness_before phase + , CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter + (initSimplMode dflags phase name) hpt_rule_base + , maybe_rule_check phase ] + + -- Run GHC's internal simplification phase, after all rules have run. + -- See Note [Compiler phases] in GHC.Types.Basic + simplify name = simpl_phase FinalPhase name max_iter + + -- initial simplify: mk specialiser happy: minimum effort please + -- See Note [Inline in InitialPhase] + -- See Note [RULEs enabled in InitialPhase] + simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter + (initGentleSimplMode dflags) hpt_rule_base + + dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper] + else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper] + + + demand_analyser = (CoreDoPasses ( + dmd_cpr_ww ++ + [simplify "post-worker-wrapper"] + )) + + -- Static forms are moved to the top level with the FloatOut pass. + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. + static_ptrs_float_outwards = + runWhen static_ptrs $ CoreDoPasses + [ simpl_gently -- Float Out can't handle type lets (sometimes created + -- by simpleOptPgm via mkParallelBindings) + , CoreDoFloatOutwards $ FloatOutSwitches + { floatOutLambdas = Just 0 + , floatOutConstants = True + , floatOutOverSatApps = False + , floatToTopLevelOnly = True + , floatJoinsToTop = False + } + ] + + add_caller_ccs = + runWhen (profiling && not (null $ callerCcFilters dflags)) CoreAddCallerCcs + + add_late_ccs = + runWhen (profiling && gopt Opt_ProfLateInlineCcs dflags) $ CoreAddLateCcs + + core_todo = + [ + -- We want to do the static argument transform before full laziness as it + -- may expose extra opportunities to float things outwards. However, to fix + -- up the output of the transformation we need at do at least one simplify + -- after this before anything else + runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), + + -- initial simplify: mk specialiser happy: minimum effort please + runWhen do_presimplify simpl_gently, + + -- Specialisation is best done before full laziness + -- so that overloaded functions have all their dictionary lambdas manifest + runWhen do_specialise CoreDoSpecialising, + + if full_laziness then + CoreDoFloatOutwards $ FloatOutSwitches + { floatOutLambdas = Just 0 + , floatOutConstants = True + , floatOutOverSatApps = False + , floatToTopLevelOnly = False + , floatJoinsToTop = False -- Initially, don't float join points at all + } + -- I have no idea why, but not floating constants to + -- top level is very bad in some cases. + -- + -- Notably: p_ident in spectral/rewrite + -- Changing from "gentle" to "constantsOnly" + -- improved rewrite's allocation by 19%, and + -- made 0.0% difference to any other nofib + -- benchmark + -- + -- Not doing floatOutOverSatApps yet, we'll do + -- that later on when we've had a chance to get more + -- accurate arity information. In fact it makes no + -- difference at all to performance if we do it here, + -- but maybe we save some unnecessary to-and-fro in + -- the simplifier. + else + -- Even with full laziness turned off, we still need to float static + -- forms to the top level. See Note [Grand plan for static forms] in + -- GHC.Iface.Tidy.StaticPtrTable. + static_ptrs_float_outwards, + + -- Run the simplifier phases 2,1,0 to allow rewrite rules to fire + runWhen do_simpl3 + (CoreDoPasses $ [ simpl_phase (Phase phase) "main" max_iter + | phase <- [phases, phases-1 .. 1] ] ++ + [ simpl_phase (Phase 0) "main" (max max_iter 3) ]), + -- Phase 0: allow all Ids to be inlined now + -- This gets foldr inlined before strictness analysis + + -- At least 3 iterations because otherwise we land up with + -- huge dead expressions because of an infelicity in the + -- simplifier. + -- let k = BIG in foldr k z xs + -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs + -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs + -- Don't stop now! + + runWhen do_float_in CoreDoFloatInwards, + -- Run float-inwards immediately before the strictness analyser + -- Doing so pushes bindings nearer their use site and hence makes + -- them more likely to be strict. These bindings might only show + -- up after the inlining from simplification. Example in fulsom, + -- Csg.calc, where an arg of timesDouble thereby becomes strict. + + runWhen call_arity $ CoreDoPasses + [ CoreDoCallArity + , simplify "post-call-arity" + ], + + -- Strictness analysis + runWhen strictness demand_analyser, + + runWhen exitification CoreDoExitify, + -- See Note [Placement of the exitification pass] + + -- nofib/spectral/hartel/wang doubles in speed if you + -- do full laziness late in the day. It only happens + -- after fusion and other stuff, so the early pass doesn't + -- catch it. For the record, the redex is + -- f_el22 (f_el21 r_midblock) + runWhen full_laziness $ CoreDoFloatOutwards $ FloatOutSwitches + { floatOutLambdas = floatLamArgs dflags + , floatOutConstants = True + , floatOutOverSatApps = True + , floatToTopLevelOnly = False + , floatJoinsToTop = True }, + -- floatJoinsToTop: floating joins to the top makes a huge difference to + -- spectral/minimax; see XXX + + + runWhen cse CoreCSE, + -- We want CSE to follow the final full-laziness pass, because it may + -- succeed in commoning up things floated out by full laziness. + -- CSE used to rely on the no-shadowing invariant, but it doesn't any more + + runWhen do_float_in CoreDoFloatInwards, + + simplify "final", -- Final tidy-up + + maybe_rule_check FinalPhase, + + -------- After this we have -O2 passes ----------------- + -- None of them run with -O + + -- Case-liberation for -O2. This should be after + -- strictness analysis and the simplification which follows it. + runWhen liberate_case $ CoreDoPasses + [ CoreLiberateCase, simplify "post-liberate-case" ], + -- Run the simplifier after LiberateCase to vastly + -- reduce the possibility of shadowing + -- Reason: see Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecConstr + + runWhen spec_constr $ CoreDoPasses + [ CoreDoSpecConstr, simplify "post-spec-constr"], + -- See Note [Simplify after SpecConstr] + + maybe_rule_check FinalPhase, + + runWhen late_specialise $ CoreDoPasses + [ CoreDoSpecialising, simplify "post-late-spec"], + + -- LiberateCase can yield new CSE opportunities because it peels + -- off one layer of a recursive function (concretely, I saw this + -- in wheel-sieve1), and I'm guessing that SpecConstr can too + -- And CSE is a very cheap pass. So it seems worth doing here. + runWhen ((liberate_case || spec_constr) && cse) $ CoreDoPasses + [ CoreCSE, simplify "post-final-cse" ], + + --------- End of -O2 passes -------------- + + runWhen late_dmd_anal $ CoreDoPasses ( + dmd_cpr_ww ++ [simplify "post-late-ww"] + ), + + -- Final run of the demand_analyser, ensures that one-shot thunks are + -- really really one-shot thunks. Only needed if the demand analyser + -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal + -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution + -- can become /exponentially/ more expensive. See #11731, #12996. + runWhen (strictness || late_dmd_anal) (CoreDoDemand False), + + maybe_rule_check FinalPhase, + + add_caller_ccs, + add_late_ccs + ] + + -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity. + flatten_todos [] = [] + flatten_todos (CoreDoNothing : rest) = flatten_todos rest + flatten_todos (CoreDoPasses passes : rest) = + flatten_todos passes ++ flatten_todos rest + flatten_todos (todo : rest) = todo : flatten_todos rest + +-- The core-to-core pass ordering is derived from the DynFlags: +runWhen :: Bool -> CoreToDo -> CoreToDo +runWhen True do_this = do_this +runWhen False _ = CoreDoNothing + +runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo +runMaybe (Just x) f = f x +runMaybe Nothing _ = CoreDoNothing + +{- Note [Inline in InitialPhase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is +confusing for users because when they say INLINE they expect the function to inline +right away. + +So now we do inlining immediately, even in the InitialPhase, assuming that the +Id's Activation allows it. + +This is a surprisingly big deal. Compiler performance improved a lot +when I made this change: + + perf/compiler/T5837.run T5837 [stat too good] (normal) + perf/compiler/parsing001.run parsing001 [stat too good] (normal) + perf/compiler/T12234.run T12234 [stat too good] (optasm) + perf/compiler/T9020.run T9020 [stat too good] (optasm) + perf/compiler/T3064.run T3064 [stat too good] (normal) + perf/compiler/T9961.run T9961 [stat too good] (normal) + perf/compiler/T13056.run T13056 [stat too good] (optasm) + perf/compiler/T9872d.run T9872d [stat too good] (normal) + perf/compiler/T783.run T783 [stat too good] (normal) + perf/compiler/T12227.run T12227 [stat too good] (normal) + perf/should_run/lazy-bs-alloc.run lazy-bs-alloc [stat too good] (normal) + perf/compiler/T1969.run T1969 [stat too good] (normal) + perf/compiler/T9872a.run T9872a [stat too good] (normal) + perf/compiler/T9872c.run T9872c [stat too good] (normal) + perf/compiler/T9872b.run T9872b [stat too good] (normal) + perf/compiler/T9872d.run T9872d [stat too good] (normal) + +Note [RULEs enabled in InitialPhase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +RULES are enabled when doing "gentle" simplification in InitialPhase, +or with -O0. Two reasons: + + * We really want the class-op cancellation to happen: + op (df d1 d2) --> $cop3 d1 d2 + because this breaks the mutual recursion between 'op' and 'df' + + * I wanted the RULE + lift String ===> ... + to work in Template Haskell when simplifying + splices, so we get simpler code for literal strings + +But watch out: list fusion can prevent floating. So use phase control +to switch off those rules until after floating. + +Note [Simplify after SpecConstr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to run the simplifier after SpecConstr, and before late-Specialise, +for two reasons, both shown up in test perf/compiler/T16473, +with -O2 -flate-specialise + +1. I found that running late-Specialise after SpecConstr, with no + simplification in between meant that the carefully constructed + SpecConstr rule never got to fire. (It was something like + lvl = f a -- Arity 1 + ....g lvl.... + SpecConstr specialised g for argument lvl; but Specialise then + specialised lvl = f a to lvl = $sf, and inlined. Or something like + that.) + +2. Specialise relies on unfoldings being available for top-level dictionary + bindings; but SpecConstr kills them all! The Simplifer restores them. + +This extra run of the simplifier has a cost, but this is only with -O2. + + +************************************************************************ +* * + The CoreToDo interpreter +* * +************************************************************************ +-} + +runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts +runCorePasses passes guts + = foldM do_pass guts passes + where + do_pass guts CoreDoNothing = return guts + do_pass guts (CoreDoPasses ps) = runCorePasses ps guts + do_pass guts pass = do + logger <- getLogger + withTiming logger (ppr pass <+> brackets (ppr mod)) + (const ()) $ do + guts' <- lintAnnots (ppr pass) (doCorePass pass) guts + endPass pass (mg_binds guts') (mg_rules guts') + return guts' + + mod = mg_module guts + +doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts +doCorePass pass guts = do + logger <- getLogger + hsc_env <- getHscEnv + dflags <- getDynFlags + us <- getUniqueSupplyM + p_fam_env <- getPackageFamInstEnv + let platform = targetPlatform dflags + let fam_envs = (p_fam_env, mg_fam_inst_env guts) + let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } + let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' } + -- Important to force this now as name_ppr_ctx lives through an entire phase in + -- the optimiser and if it's not forced then the entire previous `ModGuts` will + -- be retained until the end of the phase. (See #24328 for more analysis) + let !rdr_env = mg_rdr_env guts + let name_ppr_ctx = + mkNamePprCtx + (initPromotionTickContext dflags) + (hsc_unit_env hsc_env) + rdr_env + + + case pass of + CoreDoSimplify opts -> {-# SCC "Simplify" #-} + liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) name_ppr_ctx opts guts + + CoreCSE -> {-# SCC "CommonSubExpr" #-} + updateBinds cseProgram + + CoreLiberateCase -> {-# SCC "LiberateCase" #-} + updateBinds (liberateCase (initLiberateCaseOpts dflags)) + + CoreDoFloatInwards -> {-# SCC "FloatInwards" #-} + updateBinds (floatInwards platform) + + CoreDoFloatOutwards f -> {-# SCC "FloatOutwards" #-} + updateBindsM (liftIO . floatOutwards logger f us) + + CoreDoStaticArgs -> {-# SCC "StaticArgs" #-} + updateBinds (doStaticArgs us) + + CoreDoCallArity -> {-# SCC "CallArity" #-} + updateBinds callArityAnalProgram + + CoreDoExitify -> {-# SCC "Exitify" #-} + updateBinds exitifyProgram + + CoreDoDemand before_ww -> {-# SCC "DmdAnal" #-} + updateBindsM (liftIO . dmdAnal logger before_ww dflags fam_envs (mg_rules guts)) + + CoreDoCpr -> {-# SCC "CprAnal" #-} + updateBindsM (liftIO . cprAnalProgram logger fam_envs) + + CoreDoWorkerWrapper -> {-# SCC "WorkWrap" #-} + updateBinds (wwTopBinds + (initWorkWrapOpts (mg_module guts) dflags fam_envs) + us) + + CoreDoSpecialising -> {-# SCC "Specialise" #-} + specProgram guts + + CoreDoSpecConstr -> {-# SCC "SpecConstr" #-} + specConstrProgram guts + + CoreAddCallerCcs -> {-# SCC "AddCallerCcs" #-} + addCallerCostCentres guts + + CoreAddLateCcs -> {-# SCC "AddLateCcs" #-} + topLevelBindsCCMG guts + + CoreDoPrintCore -> {-# SCC "PrintCore" #-} + liftIO $ printCore logger (mg_binds guts) >> return guts + + CoreDoRuleCheck phase pat -> {-# SCC "RuleCheck" #-} + ruleCheckPass phase pat guts + CoreDoNothing -> return guts + CoreDoPasses passes -> runCorePasses passes guts + + CoreDoPluginPass _ p -> {-# SCC "Plugin" #-} p guts + + CoreDesugar -> pprPanic "doCorePass" (ppr pass) + CoreDesugarOpt -> pprPanic "doCorePass" (ppr pass) + CoreTidy -> pprPanic "doCorePass" (ppr pass) + CorePrep -> pprPanic "doCorePass" (ppr pass) + +{- +************************************************************************ +* * +\subsection{Core pass combinators} +* * +************************************************************************ +-} + +printCore :: Logger -> CoreProgram -> IO () +printCore logger binds + = Logger.logDumpMsg logger "Print Core" (pprCoreBindings binds) + +ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts +ruleCheckPass current_phase pat guts = do + dflags <- getDynFlags + logger <- getLogger + withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) + (const ()) $ do + rule_env <- initRuleEnv guts + let rule_fn fn = getRules rule_env fn + ropts = initRuleOpts dflags + liftIO $ logDumpMsg logger "Rule check" + (ruleCheckProgram ropts current_phase pat + rule_fn (mg_binds guts)) + return guts + +dmdAnal :: Logger -> Bool -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram +dmdAnal logger before_ww dflags fam_envs rules binds = do + let !opts = DmdAnalOpts + { dmd_strict_dicts = gopt Opt_DictsStrict dflags + , dmd_do_boxity = before_ww -- only run Boxity Analysis immediately preceding WW + , dmd_unbox_width = dmdUnboxWidth dflags + , dmd_max_worker_args = maxWorkerArgs dflags + } + binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds + Logger.putDumpFileMaybe logger Opt_D_dump_dmd_signatures "Demand signatures" FormatText $ + dumpIdInfoOfProgram (hasPprDebug dflags) (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds + -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal + seqBinds binds_plus_dmds `seq` return binds_plus_dmds diff --git a/GHC/Core/Opt/Pipeline/Types.hs b/GHC/Core/Opt/Pipeline/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Pipeline/Types.hs @@ -0,0 +1,103 @@ +module GHC.Core.Opt.Pipeline.Types ( + -- * Configuration of the core-to-core passes + CorePluginPass, CoreToDo(..), + bindsOnlyPass, pprPassDetails, + ) where + +import GHC.Prelude + +import GHC.Core ( CoreProgram ) +import GHC.Core.Opt.Monad ( CoreM, FloatOutSwitches ) +import GHC.Core.Opt.Simplify ( SimplifyOpts(..) ) + +import GHC.Types.Basic ( CompilerPhase(..) ) +import GHC.Unit.Module.ModGuts +import GHC.Utils.Outputable as Outputable + +{- +************************************************************************ +* * + The CoreToDo type and related types + Abstraction of core-to-core passes to run. +* * +************************************************************************ +-} + +-- | A description of the plugin pass itself +type CorePluginPass = ModGuts -> CoreM ModGuts + +bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts +bindsOnlyPass pass guts + = do { binds' <- pass (mg_binds guts) + ; return (guts { mg_binds = binds' }) } + +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify !SimplifyOpts + -- ^ The core-to-core simplifier. + | CoreDoPluginPass String CorePluginPass + | CoreDoFloatInwards + | CoreDoFloatOutwards FloatOutSwitches + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoCallArity + | CoreDoExitify + | CoreDoDemand Bool -- Bool: Do worker/wrapper afterwards? + -- See Note [Don't change boxity without worker/wrapper] + | CoreDoCpr + | CoreDoWorkerWrapper + | CoreDoSpecialising + | CoreDoSpecConstr + | CoreCSE + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string + | CoreDoNothing -- Useful when building up + | CoreDoPasses [CoreToDo] -- lists of these things + + | CoreDesugar -- Right after desugaring, no simple optimisation yet! + | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces + -- Core output, and hence useful to pass to endPass + + | CoreTidy + | CorePrep + | CoreAddCallerCcs + | CoreAddLateCcs + +instance Outputable CoreToDo where + ppr (CoreDoSimplify _) = text "Simplifier" + ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s + ppr CoreDoFloatInwards = text "Float inwards" + ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) + ppr CoreLiberateCase = text "Liberate case" + ppr CoreDoStaticArgs = text "Static argument" + ppr CoreDoCallArity = text "Called arity analysis" + ppr CoreDoExitify = text "Exitification transformation" + ppr (CoreDoDemand True) = text "Demand analysis (including Boxity)" + ppr (CoreDoDemand False) = text "Demand analysis" + ppr CoreDoCpr = text "Constructed Product Result analysis" + ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" + ppr CoreDoSpecialising = text "Specialise" + ppr CoreDoSpecConstr = text "SpecConstr" + ppr CoreCSE = text "Common sub-expression" + ppr CoreDesugar = text "Desugar (before optimization)" + ppr CoreDesugarOpt = text "Desugar (after optimization)" + ppr CoreTidy = text "Tidy Core" + ppr CoreAddCallerCcs = text "Add caller cost-centres" + ppr CoreAddLateCcs = text "Add late core cost-centres" + ppr CorePrep = text "CorePrep" + ppr CoreDoPrintCore = text "Print core" + ppr (CoreDoRuleCheck {}) = text "Rule check" + ppr CoreDoNothing = text "CoreDoNothing" + ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes + +pprPassDetails :: CoreToDo -> SDoc +pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n + , ppr md ] + where + n = so_iterations cfg + md = so_mode cfg + +pprPassDetails _ = Outputable.empty diff --git a/GHC/Core/Opt/SetLevels.hs b/GHC/Core/Opt/SetLevels.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/SetLevels.hs @@ -0,0 +1,1979 @@ +{-# LANGUAGE PatternSynonyms #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{GHC.Core.Opt.SetLevels} + + *************************** + Overview + *************************** + +1. We attach binding levels to Core bindings, in preparation for floating + outwards (@FloatOut@). + +2. We also let-ify many expressions (notably case scrutinees), so they + will have a fighting chance of being floated sensibly. + +3. Note [Need for cloning during float-out] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We clone the binders of any floatable let-binding, so that when it is + floated out it will be unique. Example + (let x=2 in x) + (let x=3 in x) + we must clone before floating so we get + let x1=2 in + let x2=3 in + x1+x2 + + NOTE: this can't be done using the uniqAway idea, because the variable + must be unique in the whole program, not just its current scope, + because two variables in different scopes may float out to the + same top level place + + NOTE: Very tiresomely, we must apply this substitution to + the rules stored inside a variable too. + + We do *not* clone top-level bindings, because some of them must not change, + but we *do* clone bindings that are heading for the top level + +4. Note [Binder-swap during float-out] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + In the expression + case x of wild { p -> ...wild... } + we substitute x for wild in the RHS of the case alternatives: + case x of wild { p -> ...x... } + This means that a sub-expression involving x is not "trapped" inside the RHS + (i.e. it can now be floated out, whereas if it mentioned wild it could not). + And it's not inconvenient because we already have a substitution. + + For example, consider: + + f x = letrec go y = case x of z { (a,b) -> ...(expensive z)... } + in ... + + If we do the reverse binder-swap we get + + f x = letrec go y = case x of z { (a,b) -> ...(expensive x)... } + in ... + + and now we can float out: + + f x = let t = expensive x + in letrec go y = case x of z { (a,b) -> ...(t)... } + in ... + + Now (expensive x) is computed once, rather than once each time around the 'go' loop. + + Note that this is EXACTLY BACKWARDS from the what the simplifier does. + The simplifier tries to get rid of occurrences of x, in favour of wild, + in the hope that there will only be one remaining occurrence of x, namely + the scrutinee of the case, and we can inline it. + +-} + +module GHC.Core.Opt.SetLevels ( + setLevels, + + Level(..), tOP_LEVEL, + LevelledBind, LevelledExpr, LevelledBndr, + FloatSpec(..), floatSpecLevel, + + incMinorLvl, ltMajLvl, ltLvl, isTopLvl + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) +import GHC.Core.Utils +import GHC.Core.Opt.Arity ( exprBotStrictness_maybe, isOneShotBndr ) +import GHC.Core.FVs -- all of it +import GHC.Core.Subst +import GHC.Core.Make ( sortQuantVars ) +import GHC.Core.Type ( Type, tyCoVarsOfType + , mightBeUnliftedType, closeOverKindsDSet + , typeHasFixedRuntimeRep + ) +import GHC.Core.Multiplicity ( pattern ManyTy ) + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet ) +import GHC.Types.Unique.DSet ( getUniqDSet ) +import GHC.Types.Var.Env +import GHC.Types.Literal ( litIsTrivial ) +import GHC.Types.Demand ( DmdSig, prependArgsDmdSig ) +import GHC.Types.Cpr ( CprSig, prependArgsCprSig ) +import GHC.Types.Name ( getOccName, mkSystemVarName ) +import GHC.Types.Name.Occurrence ( occNameFS ) +import GHC.Types.Unique ( hasKey ) +import GHC.Types.Tickish ( tickishIsCode ) +import GHC.Types.Unique.Supply +import GHC.Types.Unique.DFM +import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) + +import GHC.Builtin.Types +import GHC.Builtin.Names ( runRWKey ) + +import GHC.Data.FastString + +import GHC.Utils.FV +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Maybe + +{- +************************************************************************ +* * +\subsection{Level numbers} +* * +************************************************************************ +-} + +type LevelledExpr = TaggedExpr FloatSpec +type LevelledBind = TaggedBind FloatSpec +type LevelledBndr = TaggedBndr FloatSpec + +data Level = Level Int -- Level number of enclosing lambdas + Int -- Number of big-lambda and/or case expressions and/or + -- context boundaries between + -- here and the nearest enclosing lambda + +data FloatSpec + = FloatMe Level -- Float to just inside the binding + -- tagged with this level + | StayPut Level -- Stay where it is; binding is + -- tagged with this level + +floatSpecLevel :: FloatSpec -> Level +floatSpecLevel (FloatMe l) = l +floatSpecLevel (StayPut l) = l + +{- +The {\em level number} on a (type-)lambda-bound variable is the +nesting depth of the (type-)lambda which binds it. The outermost lambda +has level 1, so (Level 0 0) means that the variable is bound outside any lambda. + +On an expression, it's the maximum level number of its free +(type-)variables. On a let(rec)-bound variable, it's the level of its +RHS. On a case-bound variable, it's the number of enclosing lambdas. + +Top-level variables: level~0. Those bound on the RHS of a top-level +definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown +as ``subscripts'')... +\begin{verbatim} +a_0 = let b_? = ... in + x_1 = ... b ... in ... +\end{verbatim} + +The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@). +That's meant to be the level number of the enclosing binder in the +final (floated) program. If the level number of a sub-expression is +less than that of the context, then it might be worth let-binding the +sub-expression so that it will indeed float. + +If you can float to level @Level 0 0@ worth doing so because then your +allocation becomes static instead of dynamic. We always start with +context @Level 0 0@. + +Note [FloatOut inside INLINE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose: +to say "don't float anything out of here". That's exactly what we +want for the body of an INLINE, where we don't want to float anything +out at all. See notes with lvlMFE below. + +But, check this out: + +-- At one time I tried the effect of not floating anything out of an InlineMe, +-- but it sometimes works badly. For example, consider PrelArr.done. It +-- has the form __inline (\d. e) +-- where e doesn't mention d. If we float this to +-- __inline (let x = e in \d. x) +-- things are bad. The inliner doesn't even inline it because it doesn't look +-- like a head-normal form. So it seems a lesser evil to let things float. +-- In GHC.Core.Opt.SetLevels we do set the context to (Level 0 0) when we get to an InlineMe +-- which discourages floating out. + +So the conclusion is: don't do any floating at all inside an InlineMe. +(In the above example, don't float the {x=e} out of the \d.) + +One particular case is that of workers: we don't want to float the +call to the worker outside the wrapper, otherwise the worker might get +inlined into the floated expression, and an importing module won't see +the worker at all. +-} + +instance Outputable FloatSpec where + ppr (FloatMe l) = char 'F' <> ppr l + ppr (StayPut l) = ppr l + +tOP_LEVEL :: Level +tOP_LEVEL = Level 0 0 + +incMajorLvl :: Level -> Level +incMajorLvl (Level major _) = Level (major + 1) 0 + +incMinorLvl :: Level -> Level +incMinorLvl (Level major minor) = Level major (minor+1) + +maxLvl :: Level -> Level -> Level +maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2) + | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 + | otherwise = l2 + +ltLvl :: Level -> Level -> Bool +ltLvl (Level maj1 min1) (Level maj2 min2) + = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) + +ltMajLvl :: Level -> Level -> Bool + -- Tells if one level belongs to a difft *lambda* level to another +ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2 + +isTopLvl :: Level -> Bool +isTopLvl (Level 0 0) = True +isTopLvl _ = False + +instance Outputable Level where + ppr (Level maj min) + = hcat [ char '<', int maj, char ',', int min, char '>' ] + +instance Eq Level where + (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2 + +{- +************************************************************************ +* * +\subsection{Main level-setting code} +* * +************************************************************************ +-} + +setLevels :: FloatOutSwitches + -> CoreProgram + -> UniqSupply + -> [LevelledBind] + +setLevels float_lams binds us + = initLvl us (do_them binds) + where + env = initialEnv float_lams binds + + do_them :: [CoreBind] -> LvlM [LevelledBind] + do_them [] = return [] + do_them (b:bs) + = do { lvld_bind <- lvlTopBind env b + ; lvld_binds <- do_them bs + ; return (lvld_bind : lvld_binds) } + +lvlTopBind :: LevelEnv -> Bind Id -> LvlM LevelledBind +lvlTopBind env (NonRec bndr rhs) + = do { (bndr', rhs') <- lvl_top env NonRecursive bndr rhs + ; return (NonRec bndr' rhs') } + +lvlTopBind env (Rec pairs) + = do { prs' <- mapM (\(b,r) -> lvl_top env Recursive b r) pairs + ; return (Rec prs') } + +lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr + -> LvlM (LevelledBndr, LevelledExpr) +-- NB: 'env' has all the top-level binders in scope, so +-- there is no need call substAndLvlBndrs here +lvl_top env is_rec bndr rhs + = do { rhs' <- lvlRhs env is_rec (isDeadEndId bndr) + NotJoinPoint + (freeVars rhs) + ; return (stayPut tOP_LEVEL bndr, rhs') } + +{- +************************************************************************ +* * +\subsection{Setting expression levels} +* * +************************************************************************ + +Note [Floating over-saturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see (f x y), and (f x) is a redex (ie f's arity is 1), +we call (f x) an "over-saturated application" + +Should we float out an over-sat app, if can escape a value lambda? +It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2). +But we don't want to do it for class selectors, because the work saved +is minimal, and the extra local thunks allocated cost money. + +Arguably we could float even class-op applications if they were going to +top level -- but then they must be applied to a constant dictionary and +will almost certainly be optimised away anyway. +-} + +lvlExpr :: LevelEnv -- Context + -> CoreExprWithFVs -- Input expression + -> LvlM LevelledExpr -- Result expression + +{- +The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing +binder. Here's an example + + v = \x -> ...\y -> let r = case (..x..) of + ..x.. + in .. + +When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's +the level of @r@, even though it's inside a level-2 @\y@. It's +important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we +don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE +--- because it isn't a *maximal* free expression. + +If there were another lambda in @r@'s rhs, it would get level-2 as well. +-} + +lvlExpr env (_, AnnType ty) = return (Type (substTyUnchecked (le_subst env) ty)) +lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co)) +lvlExpr env (_, AnnVar v) = return (lookupVar env v) +lvlExpr _ (_, AnnLit lit) = return (Lit lit) + +lvlExpr env (_, AnnCast expr (_, co)) = do + expr' <- lvlNonTailExpr env expr + return (Cast expr' (substCo (le_subst env) co)) + +lvlExpr env (_, AnnTick tickish expr) = do + expr' <- lvlNonTailExpr env expr + let tickish' = substTickish (le_subst env) tickish + return (Tick tickish' expr') + +lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr) + +-- We don't split adjacent lambdas. That is, given +-- \x y -> (x+1,y) +-- we don't float to give +-- \x -> let v = x+1 in \y -> (v,y) +-- Why not? Because partial applications are fairly rare, and splitting +-- lambdas makes them more expensive. + +lvlExpr env expr@(_, AnnLam {}) + = do { new_body <- lvlNonTailMFE new_env True body + ; return (mkLams new_bndrs new_body) } + where + (bndrs, body) = collectAnnBndrs expr + (env1, bndrs1) = substBndrsSL NonRecursive env bndrs + (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1 + -- At one time we called a special version of collectBinders, + -- which ignored coercions, because we don't want to split + -- a lambda like this (\x -> coerce t (\s -> ...)) + -- This used to happen quite a bit in state-transformer programs, + -- but not nearly so much now non-recursive newtypes are transparent. + -- [See GHC.Core.Opt.SetLevels rev 1.50 for a version with this approach.] + +lvlExpr env (_, AnnLet bind body) + = do { (bind', new_env) <- lvlBind env bind + ; body' <- lvlExpr new_env body + -- No point in going via lvlMFE here. If the binding is alive + -- (mentioned in body), and the whole let-expression doesn't + -- float, then neither will the body + ; return (Let bind' body') } + +lvlExpr env (_, AnnCase scrut case_bndr ty alts) + = do { scrut' <- lvlNonTailMFE env True scrut + ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts } + +lvlNonTailExpr :: LevelEnv -- Context + -> CoreExprWithFVs -- Input expression + -> LvlM LevelledExpr -- Result expression +lvlNonTailExpr env expr + = lvlExpr env expr + +------------------------------------------- +lvlApp :: LevelEnv + -> CoreExprWithFVs + -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application + -> LvlM LevelledExpr -- Result expression +lvlApp env orig_expr ((_,AnnVar fn), args) + -- Try to ensure that runRW#'s continuation isn't floated out. + -- See Note [Simplification of runRW#]. + | fn `hasKey` runRWKey + = do { args' <- mapM (lvlExpr env) args + ; return (foldl' App (lookupVar env fn) args') } + + | floatOverSat env -- See Note [Floating over-saturated applications] + , arity > 0 + , arity < n_val_args + , Nothing <- isClassOpId_maybe fn + = do { rargs' <- mapM (lvlNonTailMFE env False) rargs + ; lapp' <- lvlNonTailMFE env False lapp + ; return (foldl' App lapp' rargs') } + + | otherwise + = do { args' <- mapM (lvlMFE env False) args + -- False: see "Arguments" in Note [Floating to the top] + ; return (foldl' App (lookupVar env fn) args') } + where + n_val_args = count (isValArg . deAnnotate) args + arity = idArity fn + + -- Separate out the PAP that we are floating from the extra + -- arguments, by traversing the spine until we have collected + -- (n_val_args - arity) value arguments. + (lapp, rargs) = left (n_val_args - arity) orig_expr [] + + left 0 e rargs = (e, rargs) + left n (_, AnnApp f a) rargs + | isValArg (deAnnotate a) = left (n-1) f (a:rargs) + | otherwise = left n f (a:rargs) + left _ _ _ = panic "GHC.Core.Opt.SetLevels.lvlExpr.left" + +lvlApp env _ (fun, args) + = -- No PAPs that we can float: just carry on with the + -- arguments and the function. + do { args' <- mapM (lvlNonTailMFE env False) args + ; fun' <- lvlNonTailExpr env fun + ; return (foldl' App fun' args') } + +------------------------------------------- +lvlCase :: LevelEnv -- Level of in-scope names/tyvars + -> DVarSet -- Free vars of input scrutinee + -> LevelledExpr -- Processed scrutinee + -> Id -> Type -- Case binder and result type + -> [CoreAltWithFVs] -- Input alternatives + -> LvlM LevelledExpr -- Result expression +lvlCase env scrut_fvs scrut' case_bndr ty alts + -- See Note [Floating single-alternative cases] + | [AnnAlt con@(DataAlt {}) bs body] <- alts + , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] + , not (isTopLvl dest_lvl) -- Can't have top-level cases + , not (floatTopLvlOnly env) -- Can float anywhere + , ManyTy <- idMult case_bndr -- See Note [Floating linear case] + = -- Always float the case if possible + -- Unlike lets we don't insist that it escapes a value lambda + do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) + ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut' + ; body' <- lvlMFE rhs_env True body + ; let alt' = Alt con (map (stayPut dest_lvl) bs') body' + ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) } + + | otherwise -- Stays put + = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr] + alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut' + ; alts' <- mapM (lvl_alt alts_env) alts + ; return (Case scrut' case_bndr' ty' alts') } + where + ty' = substTyUnchecked (le_subst env) ty + + incd_lvl = incMinorLvl (le_ctxt_lvl env) + dest_lvl = maxFvLevel (const True) env scrut_fvs + -- Don't abstract over type variables, hence const True + + lvl_alt alts_env (AnnAlt con bs rhs) + = do { rhs' <- lvlMFE new_env True rhs + ; return (Alt con bs' rhs') } + where + (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs + +{- Note [Floating single-alternative cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + data T a = MkT !a + f :: T Int -> blah + f x vs = case x of { MkT y -> + let f vs = ...(case y of I# w -> e)...f.. + in f vs + +Here we can float the (case y ...) out, because y is sure +to be evaluated, to give + f x vs = case x of { MkT y -> + case y of I# w -> + let f vs = ...(e)...f.. + in f vs + +That saves unboxing it every time round the loop. It's important in +some DPH stuff where we really want to avoid that repeated unboxing in +the inner loop. + +Things to note: + + * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation. + + - exprIsHNF catches the key case of an evaluated variable + + - exprOkForSpeculation is /false/ of an evaluated variable; + See Note [exprOkForSpeculation and evaluated variables] in GHC.Core.Utils + So we'd actually miss the key case! + + - Nothing is gained from the extra generality of exprOkForSpeculation + since we only consider floating a case whose single alternative + is a DataAlt K a b -> rhs + + * We can't float a case to top level + + * It's worth doing this float even if we don't float + the case outside a value lambda. Example + case x of { + MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...) + If we floated the cases out we could eliminate one of them. + + * We only do this with a single-alternative case + + +Note [Floating linear case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Linear case can't be floated past case branches: + case u of { p1 -> case[1] v of { C x -> ...x...}; p2 -> ... } +Is well typed, but + case[1] v of { C x -> case u of { p1 -> ...x...; p2 -> ... }} +Will not be, because of how `x` is used in one alternative but not the other. + +It is not easy to float this linear cases precisely, so, instead, we elect, for +the moment, to simply not float linear case. + + +Note [Setting levels when floating single-alternative cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Handling level-setting when floating a single-alternative case binding +is a bit subtle, as evidenced by #16978. In particular, we must keep +in mind that we are merely moving the case and its binders, not the +body. For example, suppose 'a' is known to be evaluated and we have + + \z -> case a of + (x,_) -> + +After floating we may have: + + case a of + (x,_) -> \z -> + {- some expression involving x and z -} + +When analysing we want to use the /ambient/ level, +and /not/ the destination level of the 'case a of (x,-) ->' binding. + +#16978 was caused by us setting the context level to the destination +level of `x` when analysing . This led us to conclude that we +needed to quantify over some of its free variables (e.g. z), resulting +in shadowing and very confusing Core Lint failures. + + +Note [Check the output scrutinee for exprIsHNF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + case x of y { + A -> ....(case y of alts).... + } + +Because of the binder-swap, the inner case will get substituted to +(case x of ..). So when testing whether the scrutinee is in HNF we +must be careful to test the *result* scrutinee ('x' in this case), not +the *input* one 'y'. The latter *is* in HNF here (because y is +evaluated), but the former is not -- and indeed we can't float the +inner case out, at least not unless x is also evaluated at its binding +site. See #5453. + +That's why we apply exprIsHNF to scrut' and not to scrut. + +See Note [Floating single-alternative cases] for why +we use exprIsHNF in the first place. +-} + +lvlNonTailMFE :: LevelEnv -- Level of in-scope names/tyvars + -> Bool -- True <=> strict context [body of case + -- or let] + -> CoreExprWithFVs -- input expression + -> LvlM LevelledExpr -- Result expression +lvlNonTailMFE env strict_ctxt ann_expr + = lvlMFE env strict_ctxt ann_expr + +lvlMFE :: LevelEnv -- Level of in-scope names/tyvars + -> Bool -- True <=> strict context [body of case or let] + -> CoreExprWithFVs -- input expression + -> LvlM LevelledExpr -- Result expression +-- lvlMFE is just like lvlExpr, except that it might let-bind +-- the expression, so that it can itself be floated. + +lvlMFE env _ (_, AnnType ty) + = return (Type (substTyUnchecked (le_subst env) ty)) + +-- No point in floating out an expression wrapped in a coercion or note +-- If we do we'll transform lvl = e |> co +-- to lvl' = e; lvl = lvl' |> co +-- and then inline lvl. Better just to float out the payload. +lvlMFE env strict_ctxt (_, AnnTick t e) + = do { e' <- lvlMFE env strict_ctxt e + ; let t' = substTickish (le_subst env) t + ; return (Tick t' e') } + +lvlMFE env strict_ctxt (_, AnnCast e (_, co)) + = do { e' <- lvlMFE env strict_ctxt e + ; return (Cast e' (substCo (le_subst env) co)) } + +lvlMFE env strict_ctxt e@(_, AnnCase {}) + | strict_ctxt -- Don't share cases in a strict context + = lvlExpr env e -- See Note [Case MFEs] + +lvlMFE env strict_ctxt ann_expr + | notWorthFloating expr abs_vars + || not float_me + || floatTopLvlOnly env && not (isTopLvl dest_lvl) + -- Only floating to the top level is allowed. + || hasFreeJoin env fvs -- If there is a free join, don't float + -- See Note [Free join points] + || not (typeHasFixedRuntimeRep (exprType expr)) + -- We can't let-bind an expression if we don't know + -- how it will be represented at runtime. + -- See Note [Representation polymorphism invariants] in GHC.Core + = -- Don't float it out + lvlExpr env ann_expr + + | float_is_new_lam || exprIsTopLevelBindable expr expr_ty + -- No wrapping needed if the type is lifted, or is a literal string + -- or if we are wrapping it in one or more value lambdas + = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive + is_bot_lam NotJoinPoint ann_expr + -- Treat the expr just like a right-hand side + ; var <- newLvlVar expr1 NotJoinPoint is_mk_static + ; let var2 = annotateBotStr var float_n_lams mb_bot_str + ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1) + (mkVarApps (Var var2) abs_vars)) } + + -- OK, so the float has an unlifted type (not top-level bindable) + -- and no new value lambdas (float_is_new_lam is False) + -- Try for the boxing strategy + -- See Note [Floating MFEs of unlifted type] + | escapes_value_lam + , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions + -- See Note [Test cheapness with exprOkForSpeculation] + , BI_Box { bi_data_con = box_dc, bi_inst_con = boxing_expr + , bi_boxed_type = box_ty } <- boxingDataCon expr_ty + , let [bx_bndr, ubx_bndr] = mkTemplateLocals [box_ty, expr_ty] + = do { expr1 <- lvlExpr rhs_env ann_expr + ; let l1r = incMinorLvlFrom rhs_env + float_rhs = mkLams abs_vars_w_lvls $ + Case expr1 (stayPut l1r ubx_bndr) box_ty + [Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))] + + ; var <- newLvlVar float_rhs NotJoinPoint is_mk_static + ; let l1u = incMinorLvlFrom env + use_expr = Case (mkVarApps (Var var) abs_vars) + (stayPut l1u bx_bndr) expr_ty + [Alt (DataAlt box_dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)] + ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) + use_expr) } + + | otherwise -- e.g. do not float unboxed tuples + = lvlExpr env ann_expr + + where + expr = deAnnotate ann_expr + expr_ty = exprType expr + fvs = freeVarsOf ann_expr + fvs_ty = tyCoVarsOfType expr_ty + is_bot_lam = isJust mb_bot_str -- True of bottoming thunks too! + is_function = isFunction ann_expr + mb_bot_str = exprBotStrictness_maybe expr + -- See Note [Bottoming floats] + -- esp Bottoming floats (2) + expr_ok_for_spec = exprOkForSpeculation expr + abs_vars = abstractVars dest_lvl env fvs + dest_lvl = destLevel env fvs fvs_ty is_function is_bot_lam + -- NB: is_bot_lam not is_bot; see (3) in + -- Note [Bottoming floats] + + -- float_is_new_lam: the floated thing will be a new value lambda + -- replacing, say (g (x+4)) by (lvl x). No work is saved, nor is + -- allocation saved. The benefit is to get it to the top level + -- and hence out of the body of this function altogether, making + -- it smaller and more inlinable + float_is_new_lam = float_n_lams > 0 + float_n_lams = count isId abs_vars + + (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars + + is_mk_static = isJust (collectMakeStaticArgs expr) + -- Yuk: See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable + + -- A decision to float entails let-binding this thing, and we only do + -- that if we'll escape a value lambda, or will go to the top level. + -- Never float trivial expressions; + -- notably, save_work might be true of a lone evaluated variable. + float_me = saves_work || saves_alloc || is_mk_static + + -- See Note [Saving work] + is_hnf = exprIsHNF expr + saves_work = escapes_value_lam -- (a) + && not is_hnf -- (b) + && not float_is_new_lam -- (c) + escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env) + + -- See Note [Saving allocation] and Note [Floating to the top] + saves_alloc = isTopLvl dest_lvl + && floatConsts env + && ( not strict_ctxt -- (a) + || is_hnf -- (b) + || (is_bot_lam && escapes_value_lam)) -- (c) + +hasFreeJoin :: LevelEnv -> DVarSet -> Bool +-- Has a free join point which is not being floated to top level. +-- (In the latter case it won't be a join point any more.) +-- Not treating top-level ones specially had a massive effect +-- on nofib/minimax/Prog.prog +hasFreeJoin env fvs + = not (maxFvLevel isJoinId env fvs == tOP_LEVEL) + +{- Note [Saving work] +~~~~~~~~~~~~~~~~~~~~~ +The key idea in let-floating is to + * float a redex out of a (value) lambda +Doing so can save an unbounded amount of work. +But see also Note [Saving allocation]. + +So we definitely float an expression out if +(a) It will escape a value lambda (escapes_value_lam) +(b) The expression is not a head-normal form (exprIsHNF); see (SW1, SW2). +(c) Floating does not require wrapping it in value lambdas (float_is_new_lam). + See (SW3) below + +Wrinkles: + +(SW1) Concerning (b) I experimented with using `exprIsCheap` rather than + `exprIsHNF` but the latter seems better, according to nofib + (`spectral/mate` got 10% worse with exprIsCheap). It's really a bit of a + heuristic. + +(SW2) What about omitting (b), and hence floating HNFs as well? The danger of + doing so is that we end up floating out a HNF from a cold path (where it + might never get allocated at all) and allocating it all the time + regardless. Example + f xs = case xs of + [x] | x>3 -> (y,y) + | otherwise -> (x,y) + (x:xs) -> ...f xs... + We can float (y,y) out, but in a particular call to `f` that path might + not be taken, so allocating it before the definition of `f` is a waste. + + See !12410 for some data comparing the effect of omitting (b) altogether, + This doesn't apply, though, if we float the thing to the top level; see + Note [Floating to the top]. Bottom line (data from !12410): adding the + not.exprIsHNF test to `saves_work`: + - Decreases compiler allocations by 0.5% + - Occasionally decreases runtime allocation (T12996 -2.5%) + - Slightly mixed effect on nofib: (puzzle -10%, mate -5%, cichelli +5%) + but geometric mean is -0.09%. + Overall, a win. + +(SW3) Concerning (c), if we are wrapping the thing in extra value lambdas (in + abs_vars), then nothing is saved. E.g. + f = \xyz. ...(e1[y],e2).... + If we float + lvl = \y. (e1[y],e2) + f = \xyz. ...(lvl y)... + we have saved nothing: one pair will still be allocated for each + call of `f`. Hence the (not float_is_new_lam) in saves_work. + +Note [Saving allocation] +~~~~~~~~~~~~~~~~~~~~~~~~ +Even if `saves_work` is false, we we may want to float even cheap/HNF +expressions out of value lambdas, for several reasons: + +* Doing so may save allocation. Consider + f = \x. .. (\y.e) ... + Then we'd like to avoid allocating the (\y.e) every time we call f, + (assuming e does not mention x). An example where this really makes a + difference is simplrun009. + +* It may allow SpecContr to fire on functions. Consider + f = \x. ....(f (\y.e)).... + After floating we get + lvl = \y.e + f = \x. ....(f lvl)... + Now it's easier for SpecConstr to generate a robust specialisation for f. + +* It makes the function smaller, and hence more likely to inline. This can make + a big difference for string literals and bottoming expressions: see Note + [Floating to the top] + +Data suggests, however, that it is better /only/ to float HNFS, /if/ they can go +to top level. See (SW2) of Note [Saving work]. If the expression goes to top +level we don't pay the cost of allocating cold-path thunks described in (SW2). + +Hence `isTopLvl dest_lvl` in `saves_alloc`. + +Note [Floating to the top] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even though Note [Saving allocation] suggests that we should not, in +general, float HNFs, the balance change if it goes to the top: + +* We don't pay an allocation cost for the floated expression; it + just becomes static data. + +* Floating string literals is valuable -- no point in duplicating the + at each call site! + +* Floating bottoming expressions is valuable: they are always cold + paths; we don't want to duplicate them at each call site; and they + can be quite big, inhibiting inlining. See Note [Bottoming floats] + +So we float an expression to the top if: + (a) the context is lazy (so we get allocation), or + (b) the expression is a HNF (so we get allocation), or + (c) the expression is bottoming and floating would escape a + value lambda (NB: if the expression itself is a lambda, (b) + will apply; so this case only catches bottoming thunks) + +Examples: + +* (a) Strict. Case scrutinee + f = case g True of .... + Don't float (g True) to top level; then we have the admin of a + top-level thunk to worry about, with zero gain. + +* (a) Strict. Case alternative + h = case y of + True -> g True + False -> False + Don't float (g True) to the top level + +* (b) HNF + f = case y of + True -> p:q + False -> blah + We may as well float the (p:q) so it becomes a static data structure. + +* (c) Bottoming expressions; see also Note [Bottoming floats] + f x = case x of + 0 -> error + _ -> x+1 + Here we want to float (error ) to top level, abstracting + over 'x', so as to make f's RHS smaller. + + But (#22494) if it's more like + foo = case error of { ... } + then there is no point in floating; we are never going to inline + 'foo' anyway. So float bottoming things only if they escape + a lambda. + +* Arguments + t = f (g True) + Prior to Apr 22 we didn't float (g True) to the top if f was strict. + But (a) this only affected CAFs, because if it escapes a value lambda + we'll definitely float it; so the complication of working out + argument strictness doesn't seem worth it. + (b) floating to the top helps SpecContr; see GHC.Core.Opt.SpecConstr + Note [Specialising on dictionaries]. + So now we don't use strictness to affect argument floating. + +It's controlled by a flag (floatConsts), because doing this too +early loses opportunities for RULES which (needless to say) are +important in some nofib programs (gcd is an example). [SPJ note: +I think this is obsolete; the flag seems always on.] + +Note [Floating join point bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Mostly we don't float join points at all -- we want them to /stay/ join points. +This decision is made in `wantToFloat`. + +But there is one exception: if it can go to the top level (#13286). +Consider + f x = joinrec j y n = <...j y' n'...> + in jump j x 0 +Here we may just as well produce + j y n = <....j y' n'...> + f x = j x 0 +and now there is a chance that 'f' will be inlined at its call sites. +It shouldn't make a lot of difference, but these tests + perf/should_run/MethSharing + simplCore/should_compile/spec-inline +and one nofib program, all improve if you do float to top, because +of the resulting inlining of f. + +Another reason for floating join points to the top. spectral/minimax has: + prog input = join $j y = in + case (input == "doesnt happen") of + True -> $j (testBoard + testBoard) + False -> $j testBoard +Now, iff we float $j to the top, we can /also/ float ($j (tb+tb)) and ($j tb). +Result: asymptotic improvement in perf, if `prof` is called many times. + +However there are also bad consequences of floating join points to the top: + +* If a continuation consumes (let $j x = Just x in case y of {...}) + we may get much less duplication of the continuation if we don't + float $j to the top, because the contination goes into $j's RHS + +* See #21392 for an example of how demand analysis can get worse if you + float a join point to the top level. + +Compromise (determined experimentally): + +* Always float /recursive/ join points to the top. + +* For /non-recursive/ join points, float them to the top in the second + invocation of FloatOut, near the end of the pipeline. This is controlled by + the FloatOutSwitch floatJoinsToTop. + +Missed opportunity +------------------ +There is another benfit of floating local join points. Stream fusion +has been known to produce nested loops like this: + + joinrec j1 x1 = + joinrec j2 x2 = + joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... + in jump j3 x2 + in jump j2 x1 + in jump j1 x + +(Assume x1 and x2 do *not* occur free in j3.) + +Here j1 and j2 are wholly superfluous---each of them merely forwards its +argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make +everything one big mutual recursion: + + joinrec j1 x1 = jump j2 x1 + j2 x2 = jump j3 x2 + j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... + in jump j1 x + +Now the simplifier will happily inline the trivial j1 and j2, leaving only j3. +Without floating, we're stuck with three loops instead of one. + +Currently we don't do this -- a missed opportunity. + +Note [Free join points] +~~~~~~~~~~~~~~~~~~~~~~~ +We never float a MFE that has a free join-point variable. You might think +this can never occur. After all, consider + join j x = ... + in ....(jump j x).... +How might we ever want to float that (jump j x)? + * If it would escape a value lambda, thus + join j x = ... in (\y. ...(jump j x)... ) + then 'j' isn't a valid join point in the first place. + +But consider + join j x = .... in + joinrec j2 y = ...(jump j x)...(a+b).... + +Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec. +But it is emphatically /not/ good to float the (jump j x) out: + (a) 'j' will stop being a join point + (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no + work would be saved by floating it out of the \y. + +Even if we floated 'j' to top level, (b) would still hold. + +Bottom line: never float a MFE that has a free JoinId. + +Note [Floating MFEs of unlifted type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + case f x of (r::Int#) -> blah +we'd like to float (f x). But it's not trivial because it has type +Int#, and we don't want to evaluate it too early. But we can instead +float a boxed version + y = case f x of r -> I# r +and replace the original (f x) with + case (case y of I# r -> r) of r -> blah + +Being able to float unboxed expressions is sometimes important; see #12603. +I'm not sure how /often/ it is important, but it's not hard to achieve. + +We only do it for a fixed collection of types for which we have a +convenient boxing constructor (see boxingDataCon_maybe). In +particular we /don't/ do it for unboxed tuples; it's better to float +the components of the tuple individually. + +I did experiment with a form of boxing that works for any type, namely +wrapping in a function. In our example + + let y = case f x of r -> \v. f x + in case y void of r -> blah + +It works fine, but it's 50% slower (based on some crude benchmarking). +I suppose we could do it for types not covered by boxingDataCon_maybe, +but it's more code and I'll wait to see if anyone wants it. + +Note [Test cheapness with exprOkForSpeculation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to float very cheap expressions by boxing and unboxing. +But we use exprOkForSpeculation for the test, not exprIsCheap. +Why? Because it's important /not/ to transform + let x = a /# 3 +to + let x = case bx of I# a -> a /# 3 +because the let binding no +longer obeys the let-can-float invariant. But (a /# 3) is ok-for-spec +due to a special hack that says division operators can't fail +when the denominator is definitely non-zero. And yet that +same expression says False to exprIsCheap. Simplest way to +guarantee the let-can-float invariant is to use the same function! + +If an expression is okay for speculation, we could also float it out +*without* boxing and unboxing, since evaluating it early is okay. +However, it turned out to usually be better not to float such expressions, +since they tend to be extremely cheap things like (x +# 1#). Even the +cost of spilling the let-bound variable to the stack across a call may +exceed the cost of recomputing such an expression. (And we can't float +unlifted bindings to top-level.) + +We could try to do something smarter here, and float out expensive yet +okay-for-speculation things, such as division by non-zero constants. +But I suspect it's a narrow target. + +Note [Bottoming floats] +~~~~~~~~~~~~~~~~~~~~~~~ +If we see + f = \x. g (error "urk") +we'd like to float the call to error, to get + lvl = error "urk" + f = \x. g lvl + +But, as ever, we need to be careful: + +(1) We want to float a bottoming + expression even if it has free variables: + f = \x. g (let v = h x in error ("urk" ++ v)) + Then we'd like to abstract over 'x', and float the whole arg of g: + lvl = \x. let v = h x in error ("urk" ++ v) + f = \x. g (lvl x) + To achieve this we pass is_bot to destLevel + +(2) We do not do this for lambdas that return + bottom. Instead we treat the /body/ of such a function specially, + via point (1). For example: + f = \x. ....(\y z. if x then error y else error z).... + If we float the whole lambda thus + lvl = \x. \y z. if x then error y else error z + f = \x. ...(lvl x)... + we may well end up eta-expanding that PAP to + f = \x. ...(\y z. lvl x y z)... + + ===> + lvl = \x z y. if b then error y else error z + f = \x. ...(\y z. lvl x z y)... + (There is no guarantee that we'll choose the perfect argument order.) + +(3) If we have a /binding/ that returns bottom, we want to float it to top + level, even if it has free vars (point (1)), and even it has lambdas. + Example: + ... let { v = \y. error (show x ++ show y) } in ... + We want to abstract over x and float the whole thing to top: + lvl = \xy. error (show x ++ show y) + ...let {v = lvl x} in ... + + Then of course we don't want to separately float the body (error ...) + as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot + argument. + + Do /not/ do this for bottoming /join-point/ bindings. They may call other + join points (#24768), and floating to the top would abstract over those join + points, which we should never do. + + +See Maessen's paper 1999 "Bottom extraction: factoring error handling out +of functional programs" (unpublished I think). + +When we do this, we set the strictness and arity of the new bottoming +Id, *immediately*, for three reasons: + + * To prevent the abstracted thing being immediately inlined back in again + via preInlineUnconditionally. The latter has a test for bottoming Ids + to stop inlining them, so we'd better make sure it *is* a bottoming Id! + + * So that it's properly exposed as such in the interface file, even if + this is all happening after strictness analysis. + + * In case we do CSE with the same expression that *is* marked bottom + lvl = error "urk" + x{str=bot) = error "urk" + Here we don't want to replace 'x' with 'lvl', else we may get Lint + errors, e.g. via a case with empty alternatives: (case x of {}) + Lint complains unless the scrutinee of such a case is clearly bottom. + + This was reported in #11290. But since the whole bottoming-float + thing is based on the cheap-and-cheerful exprIsDeadEnd, I'm not sure + that it'll nail all such cases. + +Note [Case MFEs] +~~~~~~~~~~~~~~~~ +We don't float a case expression as an MFE from a strict context. Why not? +Because in doing so we share a tiny bit of computation (the switch) but +in exchange we build a thunk, which is bad. This case reduces allocation +by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem. +Doesn't change any other allocation at all. + +We will make a separate decision for the scrutinee and alternatives. + +However this can have a knock-on effect for fusion: consider + \v -> foldr k z (case x of I# y -> build ..y..) +Perhaps we can float the entire (case x of ...) out of the \v. Then +fusion will not happen, but we will get more sharing. But if we don't +float the case (as advocated here) we won't float the (build ...y..) +either, so fusion will happen. It can be a big effect, esp in some +artificial benchmarks (e.g. integer, queens), but there is no perfect +answer. +-} + +annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig, CprSig) -> Id +-- See Note [Bottoming floats] for why we want to add +-- bottoming information right now +-- +-- n_extra are the number of extra value arguments added during floating +annotateBotStr id n_extra mb_bot_str + | Just (arity, str_sig, cpr_sig) <- mb_bot_str + = id `setIdArity` (arity + n_extra) + `setIdDmdSig` prependArgsDmdSig n_extra str_sig + `setIdCprSig` prependArgsCprSig n_extra cpr_sig + | otherwise + = id + +notWorthFloating :: CoreExpr -> [Var] -> Bool +-- See Note [notWorthFloating] +notWorthFloating e abs_vars + = go e 0 + where + n_abs_vars = count isId abs_vars -- See (NWF5) + + go :: CoreExpr -> Int -> Bool + -- (go e n) return True if (e x1 .. xn) is not worth floating + -- where `e` has n trivial value arguments x1..xn + -- See (NWF4) + go (Lit lit) n = (n==0) -- See (NWF1b) + && litIsTrivial lit -- See (NWF1a) + go (Type {}) _ = True + go (Tick t e) n = not (tickishIsCode t) && go e n + go (Cast e _) n = n==0 || go e n -- See (NWF3) + go (Coercion {}) _ = True + go (App e arg) n + | Type {} <- arg = go e n -- Just types, not coercions (NWF2) + | exprIsTrivial arg = go e (n+1) + | otherwise = n==0 && exprIsUnaryClassFun e + -- (f non-triv) is worth floating, + -- unless if is a unary class fun + go (Case e b _ as) _ + -- Do not float the `case` part of trivial cases (NWF3) + -- We'll have a look at the RHS when we get there + | null as + = True -- See Note [Empty case is trivial] + | Just {} <- isUnsafeEqualityCase e b as + = True -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce + | otherwise + = False + + go (Var v) n + | isUnaryClassId v = n==1 -- (op x) is not worth floating, but (op x y) is!! + -- See (NWF3) + | n==0 = True -- Naked variable + | n <= n_abs_vars = True -- (f a b c) is not worth floating if + | otherwise = False -- a,b,c are all abstracted; see (NWF5) + + go _ _ = False -- Let etc is worth floating + +{- Note [notWorthFloating] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +`notWorthFloating` returns True if the expression would be replaced by something +bigger than it is now. One big goal is that floating should be idempotent. Eg +if we replace e with (lvl79 x y) and then run FloatOut again, don't want to +replace (lvl79 x y) with (lvl83 x y)! + +For example: + abs_vars = tvars only: return True if e is trivial, + but False for anything bigger + abs_vars = [x] (an Id): return True for trivial, or an application (f x) + but False for (f x x) + +(NWF1a) It's important to float Integer literals, so that they get shared, rather + than being allocated every time round the loop. Hence the litIsTrivial. + + Ditto literal strings (LitString), which we'd like to float to top + level, which is now possible. + +(NWF1b) You might think that a literal should never be applied to a value + (hence n=0) but actually we can get (see test T23024): + RUBBISH @(a->b) (x::a) + See Note [Rubbish literals] in GHC.Types.Literal. (Mind you, we should be + in dead code at this point!) + +(NWF2) We don’t float out variables applied only to type arguments, since the + extra binding would be pointless: type arguments are completely erased. + But *coercion* arguments aren’t (see Note [Coercion tokens] in + "GHC.CoreToStg" and Note [inlineBoringOk] in"GHC.Core.Unfold"), + so we still want to float out variables applied only to + coercion arguments. + +(NWF3) Some expressions have trivial wrappers: + - Casts (e |> co) + - Unary-class applications: + - Dictionary applications (MkC meth) + - Class-op applictions (op dict) + - Case of empty alts + - Unsafe-equality case + In all these cases we say "not worth floating", and we do so /regardless/ + of the wrapped expression. The SetLevels stuff may subsequently float the + components of the expression. + + Example: is it worth floating (f x |> co)? No! If we did we'd get + lvl = f x |> co + ...lvl.... + Then we'd do cast worker/wrapper and end up with. + lvl' = f x + ...(lvl' |> co)... + Silly! Better not to float it in the first place. If we say "no" here, + we'll subsequently say "yes" for (f x) and get + lvl = f x + ....(lvl |> co)... + which is what we want. In short: don't float trivial wrappers. + +(NWF4) The only non-trivial expression that we say "not worth floating" for + is an application + f x y z + where the number of value arguments is <= the number of abstracted Ids. + This is what makes floating idempotent. Hence counting the number of + value arguments in `go` + +(NWF5) In #24471 we had something like + x1 = I# 1 + ... + x1000 = I# 1000 + foo = f x1 (f x2 (f x3 ....)) + So every sub-expression in `foo` has lots and lots of free variables. But + none of these sub-expressions float anywhere; the entire float-out pass is a + no-op. + + So `notWorthFloating` tries to avoid evaluating `n_abs_vars`, in cases where + it obviously /is/ worth floating. (In #24471 it turned out that we were + testing `abs_vars` (a relatively complicated calculation that takes at least + O(n-free-vars) time to compute) for every sub-expression.) + + Hence testing `n_abs_vars only` at the very end. +-} + +{- ********************************************************************* +* * + Bindings + This binding stuff works for top level too. +* * +********************************************************************* -} + +lvlBind :: LevelEnv + -> CoreBindWithFVs + -> LvlM (LevelledBind, LevelEnv) + +lvlBind env (AnnNonRec bndr rhs) + | isTyVar bndr -- Don't float TyVar binders (simplifier gets rid of them pronto) + || isCoVar bndr -- Don't float CoVars: difficult to fix up CoVar occurrences + -- (see extendPolyLvlEnv) + || not (wantToFloat env NonRecursive dest_lvl is_join is_top_bindable) + = -- No float + do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs + ; let bind_lvl = incMinorLvl (le_ctxt_lvl env) + (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr] + ; return (NonRec bndr' rhs', env') } + + -- Otherwise we are going to float + | null abs_vars + = do { -- No type abstraction; clone existing binder + rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive + is_bot_lam NotJoinPoint rhs + ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr] + ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str + ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } + + | otherwise + = do { -- Yes, type abstraction; create a new binder, extend substitution, etc + rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive + is_bot_lam NotJoinPoint rhs + ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr] + ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str + ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } + + where + bndr_ty = idType bndr + ty_fvs = tyCoVarsOfType bndr_ty + rhs_fvs = freeVarsOf rhs + bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr + abs_vars = abstractVars dest_lvl env bind_fvs + dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot_lam + + deann_rhs = deAnnotate rhs + mb_bot_str = exprBotStrictness_maybe deann_rhs + is_bot_lam = not is_join && isJust mb_bot_str + -- is_bot_lam: looks like (\xy. bot), maybe zero lams + -- NB: not isBottomThunk! + -- NB: not is_join: don't send bottoming join points to the top. + -- See Note [Bottoming floats] point (3) + + is_top_bindable = exprIsTopLevelBindable deann_rhs bndr_ty + n_extra = count isId abs_vars + mb_join_arity = idJoinPointHood bndr + is_join = isJoinPoint mb_join_arity + +lvlBind env (AnnRec pairs) + | not (wantToFloat env Recursive dest_lvl is_join is_top_bindable) + = -- No float + do { let bind_lvl = incMinorLvl (le_ctxt_lvl env) + (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs + lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (idJoinPointHood b) r + ; rhss' <- mapM lvl_rhs pairs + ; return (Rec (bndrs' `zip` rhss'), env') } + + -- Otherwise we are going to float + | null abs_vars + = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs + ; new_rhss <- mapM (do_rhs new_env) pairs + ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , new_env) } + +-- ToDo: when enabling the floatLambda stuff, +-- I think we want to stop doing this + | [(bndr,rhs)] <- pairs + , count isId abs_vars > 1 + = do -- Special case for self recursion where there are + -- several variables carried around: build a local loop: + -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars + -- This just makes the closures a bit smaller. If we don't do + -- this, allocation rises significantly on some programs + -- + -- We could elaborate it for the case where there are several + -- mutually recursive functions, but it's quite a bit more complicated + -- + -- This all seems a bit ad hoc -- sigh + let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars + rhs_lvl = le_ctxt_lvl rhs_env + + (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr] + let + (lam_bndrs, rhs_body) = collectAnnBndrs rhs + (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs + (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1 + new_rhs_body <- lvlRhs body_env2 Recursive is_bot NotJoinPoint rhs_body + (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr] + return (Rec [(TB poly_bndr (FloatMe dest_lvl) + , mkLams abs_vars_w_lvls $ + mkLams lam_bndrs2 $ + Let (Rec [( TB new_bndr (StayPut rhs_lvl) + , mkLams lam_bndrs2 new_rhs_body)]) + (mkVarApps (Var new_bndr) lam_bndrs1))] + , poly_env) + + | otherwise -- Non-null abs_vars + = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs + ; new_rhss <- mapM (do_rhs new_env) pairs + ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , new_env) } + + where + (bndrs,rhss) = unzip pairs + is_join = isJoinId (head bndrs) + -- bndrs is always non-empty and if one is a join they all are + -- Both are checked by Lint + is_fun = all isFunction rhss + is_bot = False -- It's odd to have an unconditionally divergent + -- function in a Rec, and we don't much care what + -- happens to it. False is simple! + + do_rhs env (_,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive + is_bot NotJoinPoint + rhs + + -- Finding the free vars of the binding group is annoying + bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs]) + `unionDVarSet` + (fvDVarSet $ unionsFV [ idFVs bndr + | (bndr, (_,_)) <- pairs])) + `delDVarSetList` + bndrs + + ty_fvs = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs + dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot + abs_vars = abstractVars dest_lvl env bind_fvs + + is_top_bindable = not (any (mightBeUnliftedType . idType) bndrs) + -- This mightBeUnliftedType stuff is the same test as in the non-rec case + -- You might wonder whether we can have a recursive binding for + -- an unlifted value -- but we can if it's a /join binding/ (#16978) + +wantToFloat :: LevelEnv + -> RecFlag + -> Level -- This is how far it could float + -> Bool -- Join point + -> Bool -- True <=> top-level-bindadable + -> Bool -- True <=> Yes! Float me + +wantToFloat env is_rec dest_lvl is_join is_top_bindable + | not (profitableFloat env dest_lvl) + = False + + | floatTopLvlOnly env && not (isTopLvl dest_lvl) + = False + + | isTopLvl dest_lvl, not is_top_bindable + = False -- We can't float an unlifted binding to top level (except + -- literal strings), so we don't float it at all. It's a + -- bit brutal, but unlifted bindings aren't expensive either + + | is_join -- Join points either stay put, or float to top + -- See Note [Floating join point bindings] + = isTopLvl dest_lvl && (isRec is_rec || floatJoinsToTop (le_switches env)) + + | otherwise + = True -- Yes! Float me + + +profitableFloat :: LevelEnv -> Level -> Bool +profitableFloat env dest_lvl + = (dest_lvl `ltMajLvl` le_ctxt_lvl env) -- Escapes a value lambda + || (isTopLvl dest_lvl && floatConsts env) -- Going all the way to top level + + +---------------------------------------------------- +-- Three help functions for the type-abstraction case + +lvlRhs :: LevelEnv + -> RecFlag + -> Bool -- Is this a bottoming function + -> JoinPointHood + -> CoreExprWithFVs + -> LvlM LevelledExpr +lvlRhs env rec_flag is_bot mb_join_arity expr + = lvlFloatRhs [] (le_ctxt_lvl env) env + rec_flag is_bot mb_join_arity expr + +lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag + -> Bool -- Binding is for a bottoming function + -> JoinPointHood + -> CoreExprWithFVs + -> LvlM (Expr LevelledBndr) +-- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline +lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs + = do { body' <- if not is_bot -- See Note [Floating from a RHS] + && any isId bndrs + then lvlMFE body_env True body + else lvlExpr body_env body + ; return (mkLams bndrs' body') } + where + (bndrs, body) | JoinPoint join_arity <- mb_join_arity + = collectNAnnBndrs join_arity rhs + | otherwise + = collectAnnBndrs rhs + (env1, bndrs1) = substBndrsSL NonRecursive env bndrs + all_bndrs = abs_vars ++ bndrs1 + (body_env, bndrs') | JoinPoint {} <- mb_join_arity + = lvlJoinBndrs env1 dest_lvl rec all_bndrs + | otherwise + = lvlLamBndrs env1 dest_lvl all_bndrs + -- The important thing here is that we call lvlLamBndrs on + -- all these binders at once (abs_vars and bndrs), so they + -- all get the same major level. Otherwise we create stupid + -- let-bindings inside, joyfully thinking they can float; but + -- in the end they don't because we never float bindings in + -- between lambdas + +{- Note [Floating from a RHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When floating the RHS of a let-binding, we don't always want to apply +lvlMFE to the body of a lambda, as we usually do, because the entire +binding body is already going to the right place (dest_lvl). + +A particular example is the top level. Consider + concat = /\ a -> foldr ..a.. (++) [] +We don't want to float the body of the lambda to get + lvl = /\ a -> foldr ..a.. (++) [] + concat = /\ a -> lvl a +That would be stupid. + +Previously this was avoided in a much nastier way, by testing strict_ctxt +in float_me in lvlMFE. But that wasn't even right because it would fail +to float out the error sub-expression in + f = \x. case x of + True -> error ("blah" ++ show x) + False -> ... + +But we must be careful: + +* If we had + f = \x -> factorial 20 + we /would/ want to float that (factorial 20) out! Functions are treated + differently: see the use of isFunction in the calls to destLevel. If + there are only type lambdas, then destLevel will say "go to top, and + abstract over the free tyvars" and we don't want that here. + +* But if we had + f = \x -> error (...x....) + we would NOT want to float the bottoming expression out to give + lvl = \x -> error (...x...) + f = \x -> lvl x + +Conclusion: use lvlMFE if there are + * any value lambdas in the original function, and + * this is not a bottoming function (the is_bot argument) +Use lvlExpr otherwise. A little subtle, and I got it wrong at least twice +(e.g. #13369). +-} + +{- +************************************************************************ +* * +\subsection{Deciding floatability} +* * +************************************************************************ +-} + +substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr]) +substAndLvlBndrs is_rec env lvl bndrs + = lvlBndrs subst_env lvl subst_bndrs + where + (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs + +substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar]) +-- So named only to avoid the name clash with GHC.Core.Subst.substBndrs +substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs + = ( env { le_subst = subst' + , le_env = foldl' add_id id_env (bndrs `zip` bndrs') } + , bndrs') + where + (subst', bndrs') = case is_rec of + NonRecursive -> substBndrs subst bndrs + Recursive -> substRecBndrs subst bndrs + +lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr]) +-- Compute the levels for the binders of a lambda group +lvlLamBndrs env lvl bndrs + = lvlBndrs env new_lvl bndrs + where + new_lvl | any is_major bndrs = incMajorLvl lvl + | otherwise = incMinorLvl lvl + + is_major bndr = not (isOneShotBndr bndr) + -- Only non-one-shot lambdas bump a major level, which in + -- turn triggers floating. NB: isOneShotBndr is always + -- true of a type variable -- there is no point in floating + -- out of a big lambda. + -- See Note [Computing one-shot info] in GHC.Types.Demand + +lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar] + -> (LevelEnv, [LevelledBndr]) +lvlJoinBndrs env lvl rec bndrs + = lvlBndrs env new_lvl bndrs + where + new_lvl | isRec rec = incMajorLvl lvl + | otherwise = incMinorLvl lvl + -- Non-recursive join points are one-shot; recursive ones are not + +lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr]) +-- The binders returned are exactly the same as the ones passed, +-- apart from applying the substitution, but they are now paired +-- with a (StayPut level) +-- +-- The returned envt has le_ctxt_lvl updated to the new_lvl +-- +-- All the new binders get the same level, because +-- any floating binding is either going to float past +-- all or none. We never separate binders. +lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs + = ( env { le_ctxt_lvl = new_lvl + , le_lvl_env = addLvls new_lvl lvl_env bndrs } + , map (stayPut new_lvl) bndrs) + +stayPut :: Level -> OutVar -> LevelledBndr +stayPut new_lvl bndr = TB bndr (StayPut new_lvl) + + -- Destination level is the max Id level of the expression + -- (We'll abstract the type variables, if any.) +destLevel :: LevelEnv + -> DVarSet -- Free vars of the term + -> TyCoVarSet -- Free in the /type/ of the term + -- (a subset of the previous argument) + -> Bool -- True <=> is function + -> Bool -- True <=> looks like \x1..xn.bottom (n>=0) + -> Level +destLevel env fvs fvs_ty is_function is_bot + | isTopLvl max_fv_id_level -- Float even joins if they get to top level + -- See Note [Floating join point bindings] + = tOP_LEVEL + + | is_bot -- Send bottoming bindings to the top + = as_far_as_poss -- regardless; see Note [Bottoming floats] + -- Esp Bottoming floats (1) and (3) + + | Just n_args <- floatLams env + , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case + , is_function + , countFreeIds fvs <= n_args + = as_far_as_poss -- Send functions to top level; see + -- the comments with isFunction + + | otherwise = max_fv_id_level + where + max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the + -- tyvars will be abstracted + + as_far_as_poss = maxFvLevel' isId env fvs_ty + -- See Note [Floating and kind casts] + +{- Note [Floating and kind casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + case x of + K (co :: * ~# k) -> let v :: Int |> co + v = e + in blah + +Then, even if we are abstracting over Ids, or if e is bottom, we can't +float v outside the 'co' binding. Reason: if we did we'd get + v' :: forall k. (Int ~# Age) => Int |> co +and now 'co' isn't in scope in that type. The underlying reason is +that 'co' is a value-level thing and we can't abstract over that in a +type (else we'd get a dependent type). So if v's /type/ mentions 'co' +we can't float it out beyond the binding site of 'co'. + +That's why we have this as_far_as_poss stuff. Usually as_far_as_poss +is just tOP_LEVEL; but occasionally a coercion variable (which is an +Id) mentioned in type prevents this. + +Example #14270 comment:15. +-} + + +isFunction :: CoreExprWithFVs -> Bool +-- The idea here is that we want to float *functions* to +-- the top level. This saves no work, but +-- (a) it can make the host function body a lot smaller, +-- and hence inlinable. +-- (b) it can also save allocation when the function is recursive: +-- h = \x -> letrec f = \y -> ...f...y...x... +-- in f x +-- becomes +-- f = \x y -> ...(f x)...y...x... +-- h = \x -> f x x +-- No allocation for f now. +-- We may only want to do this if there are sufficiently few free +-- variables. We certainly only want to do it for values, and not for +-- constructors. So the simple thing is just to look for lambdas +isFunction (_, AnnLam b e) | isId b = True + | otherwise = isFunction e +-- isFunction (_, AnnTick _ e) = isFunction e -- dubious +isFunction _ = False + +countFreeIds :: DVarSet -> Int +countFreeIds = nonDetStrictFoldUDFM add 0 . getUniqDSet + -- It's OK to use nonDetStrictFoldUDFM here because we're just counting things. + where + add :: Var -> Int -> Int + add v n | isId v = n+1 + | otherwise = n + +{- +************************************************************************ +* * +\subsection{Free-To-Level Monad} +* * +************************************************************************ +-} + +data LevelEnv + = LE { le_switches :: FloatOutSwitches + , le_ctxt_lvl :: Level -- The current level + , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids + + -- See Note [le_subst and le_env] + , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids + -- The Id -> CoreExpr in the Subst is ignored + -- (since we want to substitute a LevelledExpr for + -- an Id via le_env) but we do use the Co/TyVar substs + , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids + } + +{- Note [le_subst and le_env] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We clone nested let- and case-bound variables so that they are still +distinct when floated out; hence the le_subst/le_env. (see point 3 of +the module overview comment). We also use these envs when making a +variable polymorphic because we want to float it out past a big +lambda. + +The le_subst and le_env always implement the same mapping, + in_x :-> out_x a b +where out_x is an OutVar, and a,b are its arguments (when +we perform abstraction at the same time as floating). + + le_subst maps to CoreExpr + le_env maps to LevelledExpr + +Since the range is always a variable or application, there is never +any difference between the two, but sadly the types differ. The +le_subst is used when substituting in a variable's IdInfo; the le_env +when we find a Var. + +In addition the le_env records a [OutVar] of variables free in the +OutExpr/LevelledExpr, just so we don't have to call freeVars +repeatedly. This list is always non-empty, and the first element is +out_x + +The domain of the both envs is *pre-cloned* Ids, though + +The domain of the le_lvl_env is the *post-cloned* Ids +-} + +initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv +initialEnv float_lams binds + = LE { le_switches = float_lams + , le_ctxt_lvl = tOP_LEVEL + , le_lvl_env = emptyVarEnv + , le_subst = mkEmptySubst in_scope_toplvl + , le_env = emptyVarEnv } + where + in_scope_toplvl = emptyInScopeSet `extendInScopeSetBndrs` binds + -- The Simplifier (see Note [Glomming] in GHC.Core.Opt.OccurAnal) and + -- the specialiser (see Note [Top level scope] in GHC.Core.Opt.Specialise) + -- may both produce top-level bindings where an early binding refers + -- to a later one. So here we put all the top-level binders in scope before + -- we start, to satisfy the lookupIdSubst invariants (#20200 and #20294) + +addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level +addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl + +addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level +addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs + +floatLams :: LevelEnv -> Maybe Int +floatLams le = floatOutLambdas (le_switches le) + +floatConsts :: LevelEnv -> Bool +floatConsts le = floatOutConstants (le_switches le) + +floatOverSat :: LevelEnv -> Bool +floatOverSat le = floatOutOverSatApps (le_switches le) + +floatTopLvlOnly :: LevelEnv -> Bool +floatTopLvlOnly le = floatToTopLevelOnly (le_switches le) + +incMinorLvlFrom :: LevelEnv -> Level +incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env) + +-- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can +-- See Note [Binder-swap during float-out] +extendCaseBndrEnv :: LevelEnv + -> Id -- Pre-cloned case binder + -> Expr LevelledBndr -- Post-cloned scrutinee + -> LevelEnv +extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env }) + case_bndr (Var scrut_var) + -- We could use OccurAnal. scrutOkForBinderSwap here, and perhaps + -- get a bit more floating. But we didn't in the past and it's + -- an unforced change, so I'm leaving it. + = le { le_subst = extendSubstWithVar subst case_bndr scrut_var + , le_env = add_id id_env (case_bndr, scrut_var) } +extendCaseBndrEnv env _ _ = env + +maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level +maxFvLevel max_me env var_set + = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set + -- It's OK to use a non-deterministic fold here because maxIn commutes. + +maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level +-- Same but for TyCoVarSet +maxFvLevel' max_me env var_set + = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set + -- It's OK to use a non-deterministic fold here because maxIn commutes. + +maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level +maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl + = case lookupVarEnv id_env in_var of + Just (abs_vars, _) -> foldr max_out lvl abs_vars + Nothing -> max_out in_var lvl + where + max_out out_var lvl + | max_me out_var = case lookupVarEnv lvl_env out_var of + Just lvl' -> maxLvl lvl' lvl + Nothing -> lvl + | otherwise = lvl -- Ignore some vars depending on max_me + +lookupVar :: LevelEnv -> Id -> LevelledExpr +lookupVar le v = case lookupVarEnv (le_env le) v of + Just (_, expr) -> expr + _ -> Var v + +abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar] + -- Find the variables in fvs, free vars of the target expression, + -- whose level is greater than the destination level + -- These are the ones we are going to abstract out + -- + -- Note that to get reproducible builds, the variables need to be + -- abstracted in deterministic order, not dependent on the values of + -- Uniques. This is achieved by using DVarSets, deterministic free + -- variable computation and deterministic sort. + -- See Note [Unique Determinism] in GHC.Types.Unique for explanation of why + -- Uniques are not deterministic. +abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs + = -- NB: sortQuantVars might not put duplicates next to each other + map zap $ sortQuantVars $ + filter abstract_me $ + dVarSetElems $ + closeOverKindsDSet $ + substDVarSet subst in_fvs + -- NB: it's important to call abstract_me only on the OutIds the + -- come from substDVarSet (not on fv, which is an InId) + where + abstract_me v = case lookupVarEnv lvl_env v of + Just lvl -> dest_lvl `ltLvl` lvl + Nothing -> False + + -- We are going to lambda-abstract, so nuke any IdInfo, + -- and add the tyvars of the Id (if necessary) + zap v | isId v = warnPprTrace (isStableUnfolding (idUnfolding v) || + not (isEmptyRuleInfo (idSpecialisation v))) + "absVarsOf: discarding info on" (ppr v) $ + setIdInfo v vanillaIdInfo + | otherwise = v + +type LvlM result = UniqSM result + +initLvl :: UniqSupply -> UniqSM a -> a +initLvl = initUs_ + +newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] + -> LvlM (LevelEnv, [OutId]) +-- The envt is extended to bind the new bndrs to dest_lvl, but +-- the le_ctxt_lvl is unaffected +newPolyBndrs dest_lvl + env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) + abs_vars bndrs + = assert (all (not . isCoVar) bndrs) $ -- What would we add to the CoSubst in this case. No easy answer. + do { uniqs <- getUniquesM + ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs + bndr_prs = bndrs `zip` new_bndrs + env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs + , le_subst = foldl' add_subst subst bndr_prs + , le_env = foldl' add_id id_env bndr_prs } + ; return (env', new_bndrs) } + where + add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) + add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) + + mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id + transfer_join_info bndr $ + mkSysLocal str uniq (idMult bndr) poly_ty + where + str = fsLit "poly_" `appendFS` occNameFS (getOccName bndr) + poly_ty = mkLamTypes abs_vars (substTyUnchecked subst (idType bndr)) + + -- If we are floating a join point to top level, it stops being + -- a join point. Otherwise it continues to be a join point, + -- but we may need to adjust its arity + dest_is_top = isTopLvl dest_lvl + transfer_join_info bndr new_bndr + | JoinPoint join_arity <- idJoinPointHood bndr + , not dest_is_top + = new_bndr `asJoinId` join_arity + length abs_vars + | otherwise + = new_bndr + +newLvlVar :: LevelledExpr -- The RHS of the new binding + -> JoinPointHood -- Its join arity, if it is a join point + -> Bool -- True <=> the RHS looks like (makeStatic ...) + -> LvlM Id +newLvlVar lvld_rhs join_arity_maybe is_mk_static + = do { uniq <- getUniqueM + ; return (add_join_info (mk_id uniq rhs_ty)) + } + where + add_join_info var = var `asJoinId_maybe` join_arity_maybe + de_tagged_rhs = deTagExpr lvld_rhs + rhs_ty = exprType de_tagged_rhs + + mk_id uniq rhs_ty + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. + | is_mk_static + = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) + rhs_ty + | otherwise + = mkSysLocal (mkFastString "lvl") uniq ManyTy rhs_ty + +-- | Clone the binders bound by a single-alternative case. +cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) +cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) + new_lvl vs + = do { (subst', vs') <- cloneBndrsM subst vs + -- N.B. We are not moving the body of the case, merely its case + -- binders. Consequently we should *not* set le_ctxt_lvl. + -- See Note [Setting levels when floating single-alternative cases]. + ; let env' = env { le_lvl_env = addLvls new_lvl lvl_env vs' + , le_subst = subst' + , le_env = foldl' add_id id_env (vs `zip` vs') } + + ; return (env', vs') } + +cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar] + -> LvlM (LevelEnv, [OutVar]) +-- See Note [Need for cloning during float-out] +-- Works for Ids bound by let(rec) +-- The dest_lvl is attributed to the binders in the new env, +-- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env +cloneLetVars is_rec + env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) + dest_lvl vs + = do { let vs1 = map zap vs + ; (subst', vs2) <- case is_rec of + NonRecursive -> cloneBndrsM subst vs1 + Recursive -> cloneRecIdBndrsM subst vs1 + + ; let prs = vs `zip` vs2 + env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2 + , le_subst = subst' + , le_env = foldl' add_id id_env prs } + + ; return (env', vs2) } + where + zap :: Var -> Var + -- See Note [Floatifying demand info when floating] + -- and Note [Zapping JoinId when floating] + zap v | isId v = zap_join (floatifyIdDemandInfo v) + | otherwise = v + + -- See Note [Zapping JoinId when floating] + zap_join | isTopLvl dest_lvl = zapJoinId + | otherwise = id + +add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr) +add_id id_env (v, v1) + | isTyVar v = delVarEnv id_env v + | otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1) + +{- Note [Zapping JoinId when floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we are floating a join point, it won't be one anymore, so we zap +the join point information. + +Note [Floatifying demand info when floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When floating we must lazify the outer demand info on the Id +because it may be less demanded than at its original binding site. +For example: + f :: Int -> Int + f x = let v = 3*4 in v+x +Here v is strict and used at most once; but if we float v to top level, +that isn't true any more. Specifically, we lose track of v's cardinality info: + * if `f` is called multiple times, then `v` is used more than once + * if `f` is never called, then `v` is never evaluated. + +But NOTE that we only need to adjust the /top-level/ cardinality info. +For example + let x = (e1,e2) + in ...(case x of (a,b) -> a+b)... +If we float x outwards, it may no longer be strict, but IF it is ever +evaluated THEN its components will be evaluated. So we to lazify and +many-ify its demand-info, not discard it entirely. + +Same if we have + let f = \x y . blah + in ...(f a b)...(f c d)... +Here `f` will get a demand like SC(S,C(1,L)). If we float it out, we can +keep that `1C` called-once inner demand. It's only the outer strictness +that we kill. + +Conclusion: to floatify a demand, just do `multDmd C_0N` to reflect the +fact that `v` may be used any number of times, from zero upwards. +-} diff --git a/GHC/Core/Opt/Simplify.hs b/GHC/Core/Opt/Simplify.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify.hs @@ -0,0 +1,566 @@ +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.Simplify + ( SimplifyExprOpts(..), SimplifyOpts(..) + , simplifyExpr, simplifyPgm + ) where + +import GHC.Prelude + +import GHC.Driver.Flags + +import GHC.Core +import GHC.Core.Rules +import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) +import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) +import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) +import GHC.Core.Utils ( mkTicks, stripTicksTop ) +import GHC.Core.Lint ( LintPassResultConfig, dumpPassResult, lintPassResult ) +import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) +import GHC.Core.Opt.Simplify.Utils ( activeRule ) +import GHC.Core.Opt.Simplify.Inline ( activeUnfolding ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Opt.Stats ( simplCountN ) +import GHC.Core.FamInstEnv + +import GHC.Utils.Error ( withTiming ) +import GHC.Utils.Logger as Logger +import GHC.Utils.Outputable +import GHC.Utils.Constants (debugIsOn) + +import GHC.Unit.Env ( UnitEnv, ueEPS ) +import GHC.Unit.External +import GHC.Unit.Module.ModGuts + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Basic +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Tickish +import GHC.Types.Unique.FM + +import Control.Monad +import Data.Foldable ( for_ ) + +{- +************************************************************************ +* * + Gentle simplification +* * +************************************************************************ +-} + +-- | Configuration record for `simplifyExpr`. +-- The values of this datatype are /only/ driven by the demands of that function. +data SimplifyExprOpts = SimplifyExprOpts + { se_fam_inst :: ![FamInst] + , se_mode :: !SimplMode + , se_top_env_cfg :: !TopEnvConfig + } + +simplifyExpr :: Logger + -> ExternalUnitCache + -> SimplifyExprOpts + -> CoreExpr + -> IO CoreExpr +-- simplifyExpr is called by the driver to simplify an +-- expression typed in at the interactive prompt +simplifyExpr logger euc opts expr + = withTiming logger (text "Simplify [expr]") (const ()) $ + do { eps <- eucEPS euc ; + ; let fam_envs = ( eps_fam_inst_env eps + , extendFamInstEnvList emptyFamInstEnv $ se_fam_inst opts + ) + simpl_env = mkSimplEnv (se_mode opts) fam_envs + top_env_cfg = se_top_env_cfg opts + read_eps_rules = eps_rule_base <$> eucEPS euc + read_ruleenv = updExternalPackageRules emptyRuleEnv <$> read_eps_rules + + ; let sz = exprSize expr + + ; (expr', counts) <- initSmpl logger read_ruleenv top_env_cfg sz $ + simplExprGently simpl_env expr + + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats + "Simplifier statistics" FormatText (pprSimplCount counts) + + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression" + FormatCore + (pprCoreExpr expr') + + ; return expr' + } + +simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr +-- Simplifies an expression +-- does occurrence analysis, then simplification +-- and repeats (twice currently) because one pass +-- alone leaves tons of crud. +-- Used (a) for user expressions typed in at the interactive prompt +-- (b) the LHS and RHS of a RULE +-- (c) Template Haskell splices +-- +-- The name 'Gently' suggests that the SimplMode is InitialPhase, +-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't +-- enforce that; it just simplifies the expression twice + +-- It's important that simplExprGently does eta reduction; see +-- Note [Simplify rule LHS] above. The +-- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam) +-- but only if -O is on. + +simplExprGently env expr = do + expr1 <- simplExpr env (occurAnalyseExpr expr) + simplExpr env (occurAnalyseExpr expr1) + +{- +************************************************************************ +* * +\subsection{The driver for the simplifier} +* * +************************************************************************ +-} + +-- | Configuration record for `simplifyPgm`. +-- The values of this datatype are /only/ driven by the demands of that function. +data SimplifyOpts = SimplifyOpts + { so_dump_core_sizes :: !Bool + , so_iterations :: !Int + , so_mode :: !SimplMode + + , so_pass_result_cfg :: !(Maybe LintPassResultConfig) + -- Nothing => Do not Lint + -- Just cfg => Lint like this + + , so_hpt_rules :: !RuleBase + , so_top_env_cfg :: !TopEnvConfig + } + +simplifyPgm :: Logger + -> UnitEnv + -> NamePprCtx -- For dumping + -> SimplifyOpts + -> ModGuts + -> IO (SimplCount, ModGuts) -- New bindings + +simplifyPgm logger unit_env name_ppr_ctx opts + guts@(ModGuts { mg_module = this_mod + , mg_binds = binds, mg_rules = local_rules + , mg_fam_inst_env = fam_inst_env }) + = do { (termination_msg, it_count, counts_out, guts') + <- do_iteration 1 [] binds local_rules + + ; when (logHasDumpFlag logger Opt_D_verbose_core2core + && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ + logDumpMsg logger + "Simplifier statistics for following pass" + (vcat [text termination_msg <+> text "after" <+> ppr it_count + <+> text "iterations", + blankLine, + pprSimplCount counts_out]) + + ; return (counts_out, guts') + } + where + dump_core_sizes = so_dump_core_sizes opts + mode = so_mode opts + max_iterations = so_iterations opts + top_env_cfg = so_top_env_cfg opts + active_rule = activeRule mode + active_unf = activeUnfolding mode + -- Note the bang in !guts_no_binds. If you don't force `guts_no_binds` + -- the old bindings are retained until the end of all simplifier iterations + !guts_no_binds = guts { mg_binds = [], mg_rules = [] } + + hpt_rule_env :: RuleEnv + hpt_rule_env = mkRuleEnv guts emptyRuleBase (so_hpt_rules opts) + -- emptyRuleBase: no EPS rules yet; we will update + -- them on each iteration to pick up the most up to date set + + do_iteration :: Int -- Counts iterations + -> [SimplCount] -- Counts from earlier iterations, reversed + -> CoreProgram -- Bindings + -> [CoreRule] -- Local rules for imported Ids + -> IO (String, Int, SimplCount, ModGuts) + + do_iteration iteration_no counts_so_far binds local_rules + -- iteration_no is the number of the iteration we are + -- about to begin, with '1' for the first + | iteration_no > max_iterations -- Stop if we've run out of iterations + = warnPprTrace (debugIsOn && (max_iterations > 2)) + "Simplifier bailing out" + ( hang (ppr this_mod <> text ", after" + <+> int max_iterations <+> text "iterations" + <+> (brackets $ hsep $ punctuate comma $ + map (int . simplCountN) (reverse counts_so_far))) + 2 (text "Size =" <+> ppr (coreBindsStats binds))) $ + + -- Subtract 1 from iteration_no to get the + -- number of iterations we actually completed + return ( "Simplifier bailed out", iteration_no - 1 + , totalise counts_so_far + , guts_no_binds { mg_binds = binds, mg_rules = local_rules } ) + + -- Try and force thunks off the binds; significantly reduces + -- space usage, especially with -O. JRS, 000620. + | let sz = coreBindsSize binds + , () <- sz `seq` () -- Force it + = do { + -- Occurrence analysis + let { tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm this_mod active_unf active_rule + local_rules binds + } ; + Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" + FormatCore + (pprCoreBindings tagged_binds); + + -- read_eps_rules: + -- We need to read rules from the EPS regularly because simplification can + -- poke on IdInfo thunks, which in turn brings in new rules + -- behind the scenes. Otherwise there's a danger we'll simply + -- miss the rules for Ids hidden inside imported inlinings + -- Hence just before attempting to match a rule we read the EPS + -- value (via read_rule_env) and then combine it with the existing rule base. + -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`. + eps <- ueEPS unit_env ; + let { -- base_rule_env contains + -- (a) home package rules, fixed across all iterations + -- (b) local rules (substituted) from `local_rules` arg to do_iteration + -- Forcing base_rule_env to avoid unnecessary allocations. + -- Not doing so results in +25.6% allocations of LargeRecord. + ; !base_rule_env = updLocalRules hpt_rule_env local_rules + + ; read_eps_rules :: IO PackageRuleBase + ; read_eps_rules = eps_rule_base <$> ueEPS unit_env + + ; read_rule_env :: IO RuleEnv + ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules + + ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) + ; simpl_env = mkSimplEnv mode fam_envs } ; + + -- Simplify the program + ((binds1, rules1), counts1) <- + initSmpl logger read_rule_env top_env_cfg sz $ + do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} + simplTopBinds simpl_env tagged_binds + + -- Apply the substitution to rules defined in this module + -- for imported Ids. Eg RULE map my_f = blah + -- If we have a substitution my_f :-> other_f, we'd better + -- apply it to the rule to, or it'll never match + ; rules1 <- simplImpRules env1 local_rules + + ; return (getTopFloatBinds floats, rules1) } ; + + -- Stop if nothing happened; don't dump output + -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Stats + if isZeroSimplCount counts1 then + return ( "Simplifier reached fixed point", iteration_no + , totalise (counts1 : counts_so_far) -- Include "free" ticks + , guts_no_binds { mg_binds = binds1, mg_rules = rules1 } ) + else do { + -- Short out indirections + -- We do this *after* at least one run of the simplifier + -- because indirection-shorting uses the export flag on *occurrences* + -- and that isn't guaranteed to be ok until after the first run propagates + -- stuff from the binding site to its occurrences + -- + -- ToDo: alas, this means that indirection-shorting does not happen at all + -- if the simplifier does nothing (not common, I know, but unsavoury) + let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; + + -- Dump the result of this iteration + dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts1 binds2 rules1 ; + + for_ (so_pass_result_cfg opts) $ \pass_result_cfg -> + lintPassResult logger pass_result_cfg binds2 ; + + -- Loop + do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 + } } + where + -- Remember the counts_so_far are reversed + totalise :: [SimplCount] -> SimplCount + totalise = foldr (\c acc -> acc `plusSimplCount` c) + (zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats) + +dump_end_iteration :: Logger -> Bool -> NamePprCtx -> Int + -> SimplCount -> CoreProgram -> [CoreRule] -> IO () +dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts binds rules + = dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr pp_counts binds rules + where + mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations + | otherwise = Nothing + -- Show details if Opt_D_dump_simpl_iterations is on + + hdr = "Simplifier iteration=" ++ show iteration_no + pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr + , pprSimplCount counts + , text "---- End of simplifier counts for" <+> text hdr ] + +{- +************************************************************************ +* * + Shorting out indirections +* * +************************************************************************ + +If we have this: + + x_local = + ...bindings... + x_exported = x_local + +where x_exported is exported, and x_local is not, then we replace it with this: + + x_exported = + x_local = x_exported + ...bindings... + +Without this we never get rid of the x_exported = x_local thing. This +save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and +makes strictness information propagate better. This used to happen in +the final phase, but it's tidier to do it here. + +Note [Messing up the exported Id's RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must be careful about discarding (obviously) or even merging the +RULES on the exported Id. The example that went bad on me at one stage +was this one: + + iterate :: (a -> a) -> a -> [a] + [Exported] + iterate = iterateList + + iterateFB c f x = x `c` iterateFB c f (f x) + iterateList f x = x : iterateList f (f x) + [Not exported] + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterateList + #-} + +This got shorted out to: + + iterateList :: (a -> a) -> a -> [a] + iterateList = iterate + + iterateFB c f x = x `c` iterateFB c f (f x) + iterate f x = x : iterate f (f x) + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterate + #-} + +And now we get an infinite loop in the rule system + iterate f x -> build (\cn -> iterateFB c f x) + -> iterateFB (:) f x + -> iterate f x + +Old "solution": + use rule switching-off pragmas to get rid + of iterateList in the first place + +But in principle the user *might* want rules that only apply to the Id +they say. And inline pragmas are similar + {-# NOINLINE f #-} + f = local + local = +Then we do not want to get rid of the NOINLINE. + +Hence hasShortableIdinfo. + + +Note [Rules and indirection-zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: what if x_exported has a RULE that mentions something in ...bindings...? +Then the things mentioned can be out of scope! Solution + a) Make sure that in this pass the usage-info from x_exported is + available for ...bindings... + b) If there are any such RULES, rec-ify the entire top-level. + It'll get sorted out next time round + +Other remarks +~~~~~~~~~~~~~ +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we do one only: +\begin{verbatim} + x_local = .... + x_exported1 = x_local + x_exported2 = x_local +==> + x_exported1 = .... + + x_exported2 = x_exported1 +\end{verbatim} + +We rely on prior eta reduction to simplify things like +\begin{verbatim} + x_exported = /\ tyvars -> x_local tyvars +==> + x_exported = x_local +\end{verbatim} +Hence,there's a possibility of leaving unchanged something like this: +\begin{verbatim} + x_local = .... + x_exported1 = x_local Int +\end{verbatim} +By the time we've thrown away the types in STG land this +could be eliminated. But I don't think it's very common +and it's dangerous to do this fiddling in STG land +because we might eliminate a binding that's mentioned in the +unfolding for something. + +Note [Indirection zapping and ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unfortunately this is another place where we need a special case for +ticks. The following happens quite regularly: + + x_local = + x_exported = tick x_local + +Which we want to become: + + x_exported = tick + +As it makes no sense to keep the tick and the expression on separate +bindings. Note however that this might increase the ticks scoping +over the execution of x_local, so we can only do this for floatable +ticks. More often than not, other references will be unfoldings of +x_exported, and therefore carry the tick anyway. +-} + +type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks + +shortOutIndirections :: CoreProgram -> CoreProgram +shortOutIndirections binds + | isEmptyVarEnv ind_env = binds + | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] + | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff + where + ind_env = makeIndEnv binds + -- These exported Ids are the subjects of the indirection-elimination + exp_ids = map fst $ nonDetEltsUFM ind_env + -- It's OK to use nonDetEltsUFM here because we forget the ordering + -- by immediately converting to a set or check if all the elements + -- satisfy a predicate. + exp_id_set = mkVarSet exp_ids + no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids + binds' = concatMap zap binds + + zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] + zap (Rec pairs) = [Rec (concatMap zapPair pairs)] + + zapPair (bndr, rhs) + | bndr `elemVarSet` exp_id_set + = [] -- Kill the exported-id binding + + | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr + , (exp_id', lcl_id') <- transferIdInfo exp_id bndr + = -- Turn a local-id binding into two bindings + -- exp_id = rhs; lcl_id = exp_id + [ (exp_id', mkTicks ticks rhs), + (lcl_id', Var exp_id') ] + + | otherwise + = [(bndr,rhs)] + +makeIndEnv :: [CoreBind] -> IndEnv +makeIndEnv binds + = foldl' add_bind emptyVarEnv binds + where + add_bind :: IndEnv -> CoreBind -> IndEnv + add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs) + add_bind env (Rec pairs) = foldl' add_pair env pairs + + add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv + add_pair env (exported_id, exported) + | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported + , shortMeOut env exported_id local_id + = extendVarEnv env local_id (exported_id, ticks) + add_pair env _ = env + +shortMeOut :: IndEnv -> Id -> Id -> Bool +shortMeOut ind_env exported_id local_id +-- The if-then-else stuff is just so I can get a pprTrace to see +-- how often I don't get shorting out because of IdInfo stuff + = if isExportedId exported_id && -- Only if this is exported + + isLocalId local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! + + not (isExportedId local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it + + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for + then + if hasShortableIdInfo exported_id + then True -- See Note [Messing up the exported Id's RULES] + else warnPprTrace True "Not shorting out" (ppr exported_id) False + else + False + +hasShortableIdInfo :: Id -> Bool +-- True if there is no user-attached IdInfo on exported_id, +-- so we can safely discard it +-- See Note [Messing up the exported Id's RULES] +hasShortableIdInfo id + = isEmptyRuleInfo (ruleInfo info) + && isDefaultInlinePragma (inlinePragInfo info) + && not (isStableUnfolding (realUnfoldingInfo info)) + where + info = idInfo id + +{- Note [Transferring IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + lcl_id = e; exp_id = lcl_id + +and lcl_id has useful IdInfo, we don't want to discard it by going + gbl_id = e; lcl_id = gbl_id + +Instead, transfer IdInfo from lcl_id to exp_id, specifically +* (Stable) unfolding +* Strictness +* Rules +* Inline pragma + +Overwriting, rather than merging, seems to work ok. + +For the lcl_id we + +* Zap the InlinePragma. It might originally have had a NOINLINE, which + we have now transferred; and we really want the lcl_id to inline now + that its RHS is trivial! + +* Zap any Stable unfolding. agian, we want lcl_id = gbl_id to inline, + replacing lcl_id by gbl_id. That won't happen if lcl_id has its original + great big Stable unfolding +-} + +transferIdInfo :: Id -> Id -> (Id, Id) +-- See Note [Transferring IdInfo] +transferIdInfo exported_id local_id + = ( modifyIdInfo transfer exported_id + , modifyIdInfo zap_info local_id ) + where + local_info = idInfo local_id + transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info + `setCprSigInfo` cprSigInfo local_info + `setUnfoldingInfo` realUnfoldingInfo local_info + `setInlinePragInfo` inlinePragInfo local_info + `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info + new_info = setRuleInfoHead (idName exported_id) + (ruleInfo local_info) + -- Remember to set the function-name field of the + -- rules as we transfer them from one function to another + + zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma + `setUnfoldingInfo` noUnfolding diff --git a/GHC/Core/Opt/Simplify/Env.hs b/GHC/Core/Opt/Simplify/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify/Env.hs @@ -0,0 +1,1333 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} +-} + + + +module GHC.Core.Opt.Simplify.Env ( + -- * The simplifier mode + SimplMode(..), updMode, smPlatform, + + -- * Environments + SimplEnv(..), pprSimplEnv, -- Temp not abstract + seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle, + seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames, + seOptCoercionOpts, sePhase, sePlatform, sePreInline, + seRuleOpts, seRules, seUnfoldingOpts, + mkSimplEnv, extendIdSubst, extendCvIdSubst, + extendTvSubst, extendCvSubst, + zapSubstEnv, setSubstEnv, bumpCaseDepth, + getInScope, setInScopeFromE, setInScopeFromF, + setInScopeSet, modifyInScope, addNewInScopeIds, + getSimplRules, enterRecGroupRHSs, + reSimplifying, + + SimplEnvIS, checkSimplEnvIS, pprBadSimplEnvIS, + + -- * Substitution results + SimplSR(..), mkContEx, substId, lookupRecBndr, + + -- * Simplifying 'Id' binders + simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, + simplBinder, simplBinders, + substTy, substTyVar, getFullSubst, getTCvSubst, + substCo, substCoVar, + + -- * Floats + SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats, + mkFloatBind, addLetFloats, addJoinFloats, addFloats, + extendFloats, wrapFloats, + isEmptyJoinFloats, isEmptyLetFloats, + doFloatFromRhs, getTopFloatBinds, + + -- * LetFloats + LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat, + addLetFlts, mapLetFloats, + + -- * JoinFloats + JoinFloat, JoinFloats, emptyJoinFloats, + wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts + ) where + +import GHC.Prelude + +import GHC.Core.Coercion.Opt ( OptCoercionOpts ) +import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Core.Opt.Arity ( ArityOpts(..) ) +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Rules.Config ( RuleOpts(..) ) +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Subst( substExprSC ) +import GHC.Core.Unfold +import GHC.Core.TyCo.Subst (emptyIdSubstEnv, mkSubst) +import GHC.Core.Multiplicity( Scaled(..), mkMultMul ) +import GHC.Core.Make ( mkWildValBinder, mkCoreLet ) +import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, substCo + , extendTvSubst, extendCvSubst ) +import qualified GHC.Core.Coercion as Coercion +import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) +import qualified GHC.Core.Type as Type + +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Id as Id +import GHC.Types.Basic +import GHC.Types.Unique.FM ( pprUniqFM ) + +import GHC.Data.OrdList +import GHC.Data.Graph.UnVar + +import GHC.Builtin.Types +import GHC.Platform ( Platform ) + +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import Data.List ( intersperse, mapAccumL ) + +{- +************************************************************************ +* * +\subsubsection{The @SimplEnv@ type} +* * +************************************************************************ +-} + +{- +Note [The environments of the Simplify pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions of the Simplify pass draw their contextual data from two +environments: `SimplEnv`, which is passed to the functions as an argument, and +`SimplTopEnv`, which is part of the `SimplM` monad. For both environments exist +corresponding configuration records `SimplMode` and `TopEnvConfig` respectively. +A configuration record denotes a unary datatype bundeling the various options +and switches we provide to control the behaviour of the respective part of the +Simplify pass. The value is provided by the driver using the functions found in +the GHC.Driver.Config.Core.Opt.Simplify module. + +These configuration records are part in the environment to avoid needless +copying of their values. This raises the question which data value goes in which +of the four datatypes. For each value needed by the pass we ask the following +two questions: + + * Does the value only make sense in a monadic environment? + + * Is it part of the configuration of the pass and provided by the user or is it + it an internal value? + +Examples of values that make only sense in conjunction with `SimplM` are the +logger and the values related to counting. As it does not make sense to use them +in a pure function (the logger needs IO and counting needs access to the +accumulated counts in the monad) we want these to live in `SimplTopEnv`. +Other values, like the switches controlling the behaviour of the pass (e.g. +whether to do case merging or not) are perfectly usable in a non-monadic setting. +Indeed many of those are used in guard expressions and it would be cumbersome to +query them from the monadic environment and feed them to the pure functions as +an argument. Hence we conveniently store them in the `SpecEnv` environment which +can be passed to pure functions as a whole. + +Now that we know in which of the two environments a particular value lives we +turn to the second question to determine if the value is part of the +configuration record embedded in the environment or if it is stored in an own +field in the environment type. Some values like the tick factor must be provided +from outside as we can neither derive it from other values provided to us nor +does a constant value make sense. Other values like the maximal number of ticks +are computed on environment initialization and we wish not to expose the field +to the "user" or the pass -- it is an internal value. Therefore the distinction +here is between "freely set by the caller" and "internally managed by the pass". + +Note that it doesn't matter for the decision procedure wheter a value is altered +throughout an iteration of the Simplify pass: The fields sm_phase, sm_inline, +sm_rules, sm_cast_swizzle and sm_eta_expand are updated locally (See the +definitions of `updModeForStableUnfoldings` and `updModeForRules` in +GHC.Core.Opt.Simplify.Utils) but they are still part of `SimplMode` as the +caller of the Simplify pass needs to provide the initial values for those fields. + +The decision which value goes into which datatype can be summarized by the +following table: + | Usable in a | + | pure setting | monadic setting | + |----------------------------|--------------|-----------------| + | Set by user | SimplMode | TopEnvConfig | + | Computed on initialization | SimplEnv | SimplTopEnv | + +Note [Inline depth] +~~~~~~~~~~~~~~~~~~~ +When we inline an /already-simplified/ unfolding, we +* Zap the substitution environment; the inlined thing is an OutExpr +* Bump the seInlineDepth in the SimplEnv +Both these tasks are done in zapSubstEnv. + +The seInlineDepth tells us how deep in inlining we are. Currently, +seInlineDepth is used for just one purpose: when we encounter a +coercion we don't apply optCoercion to it if seInlineDepth>0. +Reason: it has already been optimised once, no point in doing so again. +-} + +data SimplEnv + = SimplEnv { + ----------- Static part of the environment ----------- + -- Static in the sense of lexically scoped, + -- wrt the original expression + + -- See Note [The environments of the Simplify pass] + seMode :: !SimplMode + , seFamEnvs :: !(FamInstEnv, FamInstEnv) + + -- The current substitution + , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType + , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion + , seIdSubst :: SimplIdSubst -- InId |--> OutExpr + + -- | Fast OutVarSet tracking which recursive RHSs we are analysing. + -- See Note [Eta reduction in recursive RHSs] in GHC.Core.Opt.Arity. + , seRecIds :: !UnVarSet + + ----------- Dynamic part of the environment ----------- + -- Dynamic in the sense of describing the setup where + -- the expression finally ends up + + -- The current set of in-scope variables + -- They are all OutVars, and all bound in this module + , seInScope :: !InScopeSet -- OutVars only + + , seCaseDepth :: !Int -- Depth of multi-branch case alternatives + + , seInlineDepth :: !Int -- 0 initially, 1 when we inline an already-simplified + -- unfolding, and simplify again; and so on + -- See Note [Inline depth] + } + +type SimplEnvIS = SimplEnv + -- Invariant: the substitution is empty + -- We want this SimplEnv for its InScopeSet and flags + +checkSimplEnvIS :: SimplEnvIS -> Bool +-- Check the invariant for SimplEnvIS +checkSimplEnvIS (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env }) + = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env + +pprBadSimplEnvIS :: SimplEnvIS -> SDoc +-- Print a SimplEnv that fails checkSimplEnvIS +pprBadSimplEnvIS env = ppr (getFullSubst (seInScope env) env) + +seArityOpts :: SimplEnv -> ArityOpts +seArityOpts env = sm_arity_opts (seMode env) + +seCaseCase :: SimplEnv -> Bool +seCaseCase env = sm_case_case (seMode env) + +seCaseFolding :: SimplEnv -> Bool +seCaseFolding env = sm_case_folding (seMode env) + +seCaseMerge :: SimplEnv -> Bool +seCaseMerge env = sm_case_merge (seMode env) + +seCastSwizzle :: SimplEnv -> Bool +seCastSwizzle env = sm_cast_swizzle (seMode env) + +seDoEtaReduction :: SimplEnv -> Bool +seDoEtaReduction env = sm_do_eta_reduction (seMode env) + +seEtaExpand :: SimplEnv -> Bool +seEtaExpand env = sm_eta_expand (seMode env) + +seFloatEnable :: SimplEnv -> FloatEnable +seFloatEnable env = sm_float_enable (seMode env) + +seInline :: SimplEnv -> Bool +seInline env = sm_inline (seMode env) + +seNames :: SimplEnv -> [String] +seNames env = sm_names (seMode env) + +seOptCoercionOpts :: SimplEnv -> OptCoercionOpts +seOptCoercionOpts env = sm_co_opt_opts (seMode env) + +sePhase :: SimplEnv -> CompilerPhase +sePhase env = sm_phase (seMode env) + +sePlatform :: SimplEnv -> Platform +sePlatform env = smPlatform (seMode env) + +sePreInline :: SimplEnv -> Bool +sePreInline env = sm_pre_inline (seMode env) + +seRuleOpts :: SimplEnv -> RuleOpts +seRuleOpts env = sm_rule_opts (seMode env) + +seRules :: SimplEnv -> Bool +seRules env = sm_rules (seMode env) + +seUnfoldingOpts :: SimplEnv -> UnfoldingOpts +seUnfoldingOpts env = sm_uf_opts (seMode env) + +-- See Note [The environments of the Simplify pass] +data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad + { sm_phase :: !CompilerPhase + , sm_names :: ![String] -- ^ Name(s) of the phase + , sm_rules :: !Bool -- ^ Whether RULES are enabled + , sm_inline :: !Bool -- ^ Whether inlining is enabled + , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled + , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? + , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options + , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled + , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled + , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out + , sm_do_eta_reduction :: !Bool + , sm_arity_opts :: !ArityOpts + , sm_rule_opts :: !RuleOpts + , sm_case_folding :: !Bool + , sm_case_merge :: !Bool + , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options + } + +instance Outputable SimplMode where + ppr (SimplMode { sm_phase = p , sm_names = ss + , sm_rules = r, sm_inline = i + , sm_cast_swizzle = cs + , sm_eta_expand = eta, sm_case_case = cc }) + = text "SimplMode" <+> braces ( + sep [ text "Phase =" <+> ppr p <+> + brackets (text (concat $ intersperse "," ss)) <> comma + , pp_flag i (text "inline") <> comma + , pp_flag r (text "rules") <> comma + , pp_flag eta (text "eta-expand") <> comma + , pp_flag cs (text "cast-swizzle") <> comma + , pp_flag cc (text "case-of-case") ]) + where + pp_flag f s = ppUnless f (text "no") <+> s + +smPlatform :: SimplMode -> Platform +smPlatform opts = roPlatform (sm_rule_opts opts) + +data FloatEnable -- Controls local let-floating + = FloatDisabled -- Do no local let-floating + | FloatNestedOnly -- Local let-floating for nested (NotTopLevel) bindings only + | FloatEnabled -- Do local let-floating on all bindings + +{- +Note [Local floating] +~~~~~~~~~~~~~~~~~~~~~ +The Simplifier can perform local let-floating: it floats let-bindings +out of the RHS of let-bindings. See + Let-floating: moving bindings to give faster programs (ICFP'96) + https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/ + +Here's an example + x = let y = v+1 in (y,true) + +The RHS of x is a thunk. Much better to float that y-binding out to give + y = v+1 + x = (y,true) + +Not only have we avoided building a thunk, but any (case x of (p,q) -> ...) in +the scope of the x-binding can now be simplified. + +This local let-floating is done in GHC.Core.Opt.Simplify.prepareBinding, +controlled by the predicate GHC.Core.Opt.Simplify.Env.doFloatFromRhs. + +The `FloatEnable` data type controls where local let-floating takes place; +it allows you to specify that it should be done only for nested bindings; +or for top-level bindings as well; or not at all. + +Note that all of this is quite separate from the global FloatOut pass; +see GHC.Core.Opt.FloatOut. + +-} + +data SimplFloats + = SimplFloats + { -- Ordinary let bindings + sfLetFloats :: LetFloats + -- See Note [LetFloats] + + -- Join points + , sfJoinFloats :: JoinFloats + -- Handled separately; they don't go very far + -- We consider these to be /inside/ sfLetFloats + -- because join points can refer to ordinary bindings, + -- but not vice versa + + -- Includes all variables bound by sfLetFloats and + -- sfJoinFloats, plus at least whatever is in scope where + -- these bindings land up. + , sfInScope :: InScopeSet -- All OutVars + } + +instance Outputable SimplFloats where + ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is }) + = text "SimplFloats" + <+> braces (vcat [ text "lets: " <+> ppr lf + , text "joins:" <+> ppr jf + , text "in_scope:" <+> ppr is ]) + +emptyFloats :: SimplEnv -> SimplFloats +emptyFloats env + = SimplFloats { sfLetFloats = emptyLetFloats + , sfJoinFloats = emptyJoinFloats + , sfInScope = seInScope env } + +isEmptyFloats :: SimplFloats -> Bool +-- Precondition: used only when sfJoinFloats is empty +isEmptyFloats (SimplFloats { sfLetFloats = LetFloats fs _ + , sfJoinFloats = js }) + = assertPpr (isNilOL js) (ppr js ) $ + isNilOL fs + +pprSimplEnv :: SimplEnv -> SDoc +-- Used for debugging; selective +pprSimplEnv env + = vcat [text "TvSubst:" <+> ppr (seTvSubst env), + text "CvSubst:" <+> ppr (seCvSubst env), + text "IdSubst:" <+> id_subst_doc, + text "InScope:" <+> in_scope_vars_doc + ] + where + id_subst_doc = pprUniqFM ppr (seIdSubst env) + in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env)) + (vcat . map ppr_one) + ppr_one v | isId v = ppr v <+> ppr (idUnfolding v) + | otherwise = ppr v + +type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr + -- See Note [Extending the IdSubstEnv] in GHC.Core.Subst + +-- | A substitution result. +data SimplSR + = DoneEx OutExpr JoinPointHood + -- If x :-> DoneEx e ja is in the SimplIdSubst + -- then replace occurrences of x by e + -- and ja = Just a <=> x is a join-point of arity a + -- See Note [Join arity in SimplIdSubst] + + + | DoneId OutId + -- If x :-> DoneId v is in the SimplIdSubst + -- then replace occurrences of x by v + -- and v is a join-point of arity a + -- <=> x is a join-point of arity a + + | ContEx TvSubstEnv -- A suspended substitution + CvSubstEnv + SimplIdSubst + InExpr + -- If x :-> ContEx tv cv id e is in the SimplISubst + -- then replace occurrences of x by (subst (tv,cv,id) e) + +instance Outputable SimplSR where + ppr (DoneId v) = text "DoneId" <+> ppr v + ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e + where + pp_mj = case mj of + NotJoinPoint -> empty + JoinPoint n -> parens (int n) + + ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, + ppr (filter_env tv), ppr (filter_env id) -}] + -- where + -- fvs = exprFreeVars e + -- filter_env env = filterVarEnv_Directly keep env + -- keep uniq _ = uniq `elemUFM_Directly` fvs + +{- +Note [SimplEnv invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +seInScope: + The in-scope part of Subst includes *all* in-scope TyVars and Ids + The elements of the set may have better IdInfo than the + occurrences of in-scope Ids, and (more important) they will + have a correctly-substituted type. So we use a lookup in this + set to replace occurrences + + The Ids in the InScopeSet are replete with their Rules, + and as we gather info about the unfolding of an Id, we replace + it in the in-scope set. + + The in-scope set is actually a mapping OutVar -> OutVar, and + in case expressions we sometimes bind + +seIdSubst: + The substitution is *apply-once* only, because InIds and OutIds + can overlap. + For example, we generally omit mappings + a77 -> a77 + from the substitution, when we decide not to clone a77, but it's quite + legitimate to put the mapping in the substitution anyway. + + Furthermore, consider + let x = case k of I# x77 -> ... in + let y = case k of I# x77 -> ... in ... + and suppose the body is strict in both x and y. Then the simplifier + will pull the first (case k) to the top; so the second (case k) will + cancel out, mapping x77 to, well, x77! But one is an in-Id and the + other is an out-Id. + + Of course, the substitution *must* applied! Things in its domain + simply aren't necessarily bound in the result. + +* substId adds a binding (DoneId new_id) to the substitution if + the Id's unique has changed + + Note, though that the substitution isn't necessarily extended + if the type of the Id changes. Why not? Because of the next point: + +* We *always, always* finish by looking up in the in-scope set + any variable that doesn't get a DoneEx or DoneVar hit in the substitution. + Reason: so that we never finish up with a "old" Id in the result. + An old Id might point to an old unfolding and so on... which gives a space + leak. + + [The DoneEx and DoneVar hits map to "new" stuff.] + +* It follows that substExpr must not do a no-op if the substitution is empty. + substType is free to do so, however. + +* When we come to a let-binding (say) we generate new IdInfo, including an + unfolding, attach it to the binder, and add this newly adorned binder to + the in-scope set. So all subsequent occurrences of the binder will get + mapped to the full-adorned binder, which is also the one put in the + binding site. + +* The in-scope "set" usually maps x->x; we use it simply for its domain. + But sometimes we have two in-scope Ids that are synonyms, and should + map to the same target: x->x, y->x. Notably: + case y of x { ... } + That's why the "set" is actually a VarEnv Var + +Note [Join arity in SimplIdSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have to remember which incoming variables are join points: the occurrences +may not be marked correctly yet, and we're in change of propagating the change if +OccurAnal makes something a join point). + +Normally the in-scope set is where we keep the latest information, but +the in-scope set tracks only OutVars; if a binding is unconditionally +inlined (via DoneEx), it never makes it into the in-scope set, and we +need to know at the occurrence site that the variable is a join point +so that we know to drop the context. Thus we remember which join +points we're substituting. -} + +mkSimplEnv :: SimplMode -> (FamInstEnv, FamInstEnv) -> SimplEnv +mkSimplEnv mode fam_envs + = SimplEnv { seMode = mode + , seFamEnvs = fam_envs + , seInScope = init_in_scope + , seTvSubst = emptyVarEnv + , seCvSubst = emptyVarEnv + , seIdSubst = emptyVarEnv + , seRecIds = emptyUnVarSet + , seCaseDepth = 0 + , seInlineDepth = 0 } + -- The top level "enclosing CC" is "SUBSUMED". + +init_in_scope :: InScopeSet +init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder ManyTy unitTy)) + -- See Note [WildCard binders] + +{- +Note [WildCard binders] +~~~~~~~~~~~~~~~~~~~~~~~ +The program to be simplified may have wild binders + case e of wild { p -> ... } +We want to *rename* them away, so that there are no +occurrences of 'wild-id' (with wildCardKey). The easy +way to do that is to start of with a representative +Id in the in-scope set + +There can be *occurrences* of wild-id. For example, +GHC.Core.Make.mkCoreApp transforms + e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } +This is ok provided 'wild' isn't free in 'e', and that's the delicate +thing. Generally, you want to run the simplifier to get rid of the +wild-ids before doing much else. + +It's a very dark corner of GHC. Maybe it should be cleaned up. +-} + +updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv +updMode upd env + = -- Avoid keeping env alive in case inlining fails. + let mode = upd $! (seMode env) + in env { seMode = mode } + +bumpCaseDepth :: SimplEnv -> SimplEnv +bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 } + +reSimplifying :: SimplEnv -> Bool +reSimplifying (SimplEnv { seInlineDepth = n }) = n>0 + +--------------------- +extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv +extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res + = assertPpr (isId var && not (isCoVar var)) (ppr var) $ + env { seIdSubst = extendVarEnv subst var res } + +extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv +extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res + = assertPpr (isTyVar var) (ppr var $$ ppr res) $ + env {seTvSubst = extendVarEnv tsubst var res} + +extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv +extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co + = assert (isCoVar var) $ + env {seCvSubst = extendVarEnv csubst var co} + +extendCvIdSubst :: SimplEnv -> Id -> OutExpr -> SimplEnv +extendCvIdSubst env bndr (Coercion co) = extendCvSubst env bndr co +extendCvIdSubst env bndr rhs = extendIdSubst env bndr (DoneEx rhs NotJoinPoint) + +--------------------- +getInScope :: SimplEnv -> InScopeSet +getInScope env = seInScope env + +setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv +setInScopeSet env in_scope = env {seInScope = in_scope} + +setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv +-- See Note [Setting the right in-scope set] +setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env } + +setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv +setInScopeFromF env floats = env { seInScope = sfInScope floats } + +addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv + -- The new Ids are guaranteed to be freshly allocated +addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs +-- See Note [Bangs in the Simplifier] + = let !in_scope1 = in_scope `extendInScopeSetList` vs + !id_subst1 = id_subst `delVarEnvList` vs + in + env { seInScope = in_scope1, + seIdSubst = id_subst1 } + -- Why delete? Consider + -- let x = a*b in (x, \x -> x+3) + -- We add [x |-> a*b] to the substitution, but we must + -- _delete_ it from the substitution when going inside + -- the (\x -> ...)! + +modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv +-- The variable should already be in scope, but +-- replace the existing version with this new one +-- which has more information +modifyInScope env@(SimplEnv {seInScope = in_scope}) v + = env {seInScope = extendInScopeSet in_scope v} + +enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv)) + -> SimplM (r, SimplEnv) +enterRecGroupRHSs env bndrs k = do + --pprTraceM "enterRecGroupRHSs" (ppr bndrs) + (r, env'') <- k env{seRecIds = extendUnVarSetList bndrs (seRecIds env)} + return (r, env''{seRecIds = seRecIds env}) + +{- Note [Setting the right in-scope set] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + \x. (let x = e in b) arg[x] +where the let shadows the lambda. Really this means something like + \x1. (let x2 = e in b) arg[x1] + +- When we capture the 'arg' in an ApplyToVal continuation, we capture + the environment, which says what 'x' is bound to, namely x1 + +- Then that continuation gets pushed under the let + +- Finally we simplify 'arg'. We want + - the static, lexical environment binding x :-> x1 + - the in-scopeset from "here", under the 'let' which includes + both x1 and x2 + +It's important to have the right in-scope set, else we may rename a +variable to one that is already in scope. So we must pick up the +in-scope set from "here", but otherwise use the environment we +captured along with 'arg'. This transfer of in-scope set is done by +setInScopeFromE. +-} + +--------------------- +zapSubstEnv :: SimplEnv -> SimplEnv +-- See Note [Inline depth] +-- We call zapSubstEnv precisely when we are about to +-- simplify an already-simplified term +zapSubstEnv env@(SimplEnv { seInlineDepth = n }) + = env { seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv + , seInlineDepth = n+1 } + +setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv +setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } + +mkContEx :: SimplEnv -> InExpr -> SimplSR +mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e + +{- +************************************************************************ +* * +\subsection{LetFloats} +* * +************************************************************************ + +Note [LetFloats] +~~~~~~~~~~~~~~~~ +The LetFloats is a bunch of bindings, classified by a FloatFlag. + +The `FloatFlag` contains summary information about the bindings, see the data +type declaration of `FloatFlag` + +Examples + + NonRec x (y:ys) FltLifted + Rec [(x,rhs)] FltLifted + + NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? + NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n + + NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge + NonRec x# (a /# b) FltCareful -- Might fail; does not satisfy let-can-float invariant + NonRec x# (f y) FltCareful -- Might diverge; does not satisfy let-can-float invariant +-} + +data LetFloats = LetFloats (OrdList OutBind) FloatFlag + -- See Note [LetFloats] + +type JoinFloat = OutBind +type JoinFloats = OrdList JoinFloat + +data FloatFlag + = FltLifted -- All bindings are lifted and lazy *or* + -- consist of a single primitive string literal + -- Hence ok to float to top level, or recursive + -- NB: consequence: all bindings satisfy let-can-float invariant + + | FltOkSpec -- All bindings are FltLifted *or* + -- strict (perhaps because unlifted, + -- perhaps because of a strict binder), + -- *and* ok-for-speculation + -- Hence ok to float out of the RHS + -- of a lazy non-recursive let binding + -- (but not to top level, or into a rec group) + -- NB: consequence: all bindings satisfy let-can-float invariant + + | FltCareful -- At least one binding is strict (or unlifted) + -- and not guaranteed cheap + -- Do not float these bindings out of a lazy let! + -- NB: some bindings may not satisfy let-can-float + +instance Outputable LetFloats where + ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds) + +instance Outputable FloatFlag where + ppr FltLifted = text "FltLifted" + ppr FltOkSpec = text "FltOkSpec" + ppr FltCareful = text "FltCareful" + +andFF :: FloatFlag -> FloatFlag -> FloatFlag +andFF FltCareful _ = FltCareful +andFF FltOkSpec FltCareful = FltCareful +andFF FltOkSpec _ = FltOkSpec +andFF FltLifted flt = flt + + +doFloatFromRhs :: FloatEnable -> TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool +-- If you change this function look also at FloatIn.noFloatIntoRhs +doFloatFromRhs fe lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs + = floatEnabled lvl fe + && not (isNilOL fs) + && want_to_float + && can_float + where + want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs + -- See Note [Float when cheap or expandable] + can_float = case ff of + FltLifted -> True + FltOkSpec -> isNotTopLevel lvl && isNonRec rec + FltCareful -> isNotTopLevel lvl && isNonRec rec && strict_bind + + -- Whether any floating is allowed by flags. + floatEnabled :: TopLevelFlag -> FloatEnable -> Bool + floatEnabled _ FloatDisabled = False + floatEnabled lvl FloatNestedOnly = not (isTopLevel lvl) + floatEnabled _ FloatEnabled = True + +{- +Note [Float when cheap or expandable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to float a let from a let if the residual RHS is + a) cheap, such as (\x. blah) + b) expandable, such as (f b) if f is CONLIKE +But there are + - cheap things that are not expandable (eg \x. expensive) + - expandable things that are not cheap (eg (f b) where b is CONLIKE) +so we must take the 'or' of the two. +-} + +emptyLetFloats :: LetFloats +emptyLetFloats = LetFloats nilOL FltLifted + +isEmptyLetFloats :: LetFloats -> Bool +isEmptyLetFloats (LetFloats fs _) = isNilOL fs + +emptyJoinFloats :: JoinFloats +emptyJoinFloats = nilOL + +isEmptyJoinFloats :: JoinFloats -> Bool +isEmptyJoinFloats = isNilOL + +unitLetFloat :: OutBind -> LetFloats +-- This key function constructs a singleton float with the right form +unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $ + LetFloats (unitOL bind) (flag bind) + where + flag (Rec {}) = FltLifted + flag (NonRec bndr rhs) + | not (isStrictId bndr) = FltLifted + | exprIsTickedString rhs = FltLifted + -- String literals can be floated freely. + -- See Note [Core top-level string literals] in GHC.Core. + | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) + | otherwise = FltCareful + +unitJoinFloat :: OutBind -> JoinFloats +unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $ + unitOL bind + +mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv) +-- Make a singleton SimplFloats, and +-- extend the incoming SimplEnv's in-scope set with its binders +-- These binders may already be in the in-scope set, +-- but may have by now been augmented with more IdInfo +mkFloatBind env bind + = (floats, env { seInScope = in_scope' }) + where + floats + | isJoinBind bind + = SimplFloats { sfLetFloats = emptyLetFloats + , sfJoinFloats = unitJoinFloat bind + , sfInScope = in_scope' } + | otherwise + = SimplFloats { sfLetFloats = unitLetFloat bind + , sfJoinFloats = emptyJoinFloats + , sfInScope = in_scope' } + -- See Note [Bangs in the Simplifier] + !in_scope' = seInScope env `extendInScopeSetBind` bind + +extendFloats :: SimplFloats -> OutBind -> SimplFloats +-- Add this binding to the floats, and extend the in-scope env too +extendFloats (SimplFloats { sfLetFloats = floats + , sfJoinFloats = jfloats + , sfInScope = in_scope }) + bind + | isJoinBind bind + = SimplFloats { sfInScope = in_scope' + , sfLetFloats = floats + , sfJoinFloats = jfloats' } + | otherwise + = SimplFloats { sfInScope = in_scope' + , sfLetFloats = floats' + , sfJoinFloats = jfloats } + where + in_scope' = in_scope `extendInScopeSetBind` bind + floats' = floats `addLetFlts` unitLetFloat bind + jfloats' = jfloats `addJoinFlts` unitJoinFloat bind + +addLetFloats :: SimplFloats -> LetFloats -> SimplFloats +-- Add the let-floats for env2 to env1; +-- *plus* the in-scope set for env2, which is bigger +-- than that for env1 +addLetFloats floats let_floats + = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats + , sfInScope = sfInScope floats `extendInScopeFromLF` let_floats } + +extendInScopeFromLF :: InScopeSet -> LetFloats -> InScopeSet +extendInScopeFromLF in_scope (LetFloats binds _) + = foldlOL extendInScopeSetBind in_scope binds + +addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats +addJoinFloats floats join_floats + = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats + , sfInScope = foldlOL extendInScopeSetBind + (sfInScope floats) join_floats } + +addFloats :: SimplFloats -> SimplFloats -> SimplFloats +-- Add both let-floats and join-floats for env2 to env1; +-- *plus* the in-scope set for env2, which is bigger +-- than that for env1 +addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 }) + (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope }) + = SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2 + , sfJoinFloats = jf1 `addJoinFlts` jf2 + , sfInScope = in_scope } + +addLetFlts :: LetFloats -> LetFloats -> LetFloats +addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2) + = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2) + +letFloatBinds :: LetFloats -> [CoreBind] +letFloatBinds (LetFloats bs _) = fromOL bs + +addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats +addJoinFlts = appOL + +mkRecFloats :: SimplFloats -> SimplFloats +-- Flattens the floats into a single Rec group, +-- They must either all be lifted LetFloats or all JoinFloats +mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff + , sfJoinFloats = jbs + , sfInScope = in_scope }) + = assertPpr (isNilOL bs || isNilOL jbs) (ppr floats) $ + SimplFloats { sfLetFloats = floats' + , sfJoinFloats = jfloats' + , sfInScope = in_scope } + where + -- See Note [Bangs in the Simplifier] + !floats' | isNilOL bs = emptyLetFloats + | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs))) + !jfloats' | isNilOL jbs = emptyJoinFloats + | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) + +wrapFloats :: SimplFloats -> OutExpr -> OutExpr +-- Wrap the floats around the expression +wrapFloats (SimplFloats { sfLetFloats = LetFloats bs flag + , sfJoinFloats = jbs }) body + = foldrOL mk_let (wrapJoinFloats jbs body) bs + -- Note: Always safe to put the joins on the inside + -- since the values can't refer to them + where + mk_let | FltCareful <- flag = mkCoreLet -- need to enforce let-can-float-invariant + | otherwise = Let -- let-can-float invariant hold + +wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr) +-- Wrap the sfJoinFloats of the env around the expression, +-- and take them out of the SimplEnv +wrapJoinFloatsX floats body + = ( floats { sfJoinFloats = emptyJoinFloats } + , wrapJoinFloats (sfJoinFloats floats) body ) + +wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr +-- Wrap the sfJoinFloats of the env around the expression, +-- and take them out of the SimplEnv +wrapJoinFloats join_floats body + = foldrOL Let body join_floats + +getTopFloatBinds :: SimplFloats -> [CoreBind] +getTopFloatBinds (SimplFloats { sfLetFloats = lbs + , sfJoinFloats = jbs}) + = assert (isNilOL jbs) $ -- Can't be any top-level join bindings + letFloatBinds lbs + +{-# INLINE mapLetFloats #-} +mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats +mapLetFloats (LetFloats fs ff) fun + = LetFloats fs1 ff + where + app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' + app (Rec bs) = Rec (strictMap fun bs) + !fs1 = (mapOL' app fs) -- See Note [Bangs in the Simplifier] + +{- +************************************************************************ +* * + Substitution of Vars +* * +************************************************************************ + +Note [Global Ids in the substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We look up even a global (eg imported) Id in the substitution. Consider + case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } +The binder-swap in the occurrence analyser will add a binding +for a LocalId version of g (with the same unique though): + case X.g_34 of b { (a,b) -> let g_34 = b in + ... case X.g_34 of { (p,q) -> ...} ... } +So we want to look up the inner X.g_34 in the substitution, where we'll +find that it has been substituted by b. (Or conceivably cloned.) +-} + +substId :: SimplEnv -> InId -> SimplSR +-- Returns DoneEx only on a non-Var expression +substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] + Nothing -> DoneId (refineFromInScope in_scope v) + Just (DoneId v) -> DoneId (refineFromInScope in_scope v) + Just res -> res -- DoneEx non-var, or ContEx + + -- Get the most up-to-date thing from the in-scope set + -- Even though it isn't in the substitution, it may be in + -- the in-scope set with better IdInfo. + -- + -- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify. + +refineFromInScope :: InScopeSet -> Var -> Var +refineFromInScope in_scope v + | isLocalId v = case lookupInScope in_scope v of + Just v' -> v' + Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v) + -- c.f #19074 for a subtle place where this went wrong + | otherwise = v + +lookupRecBndr :: SimplEnv -> InId -> OutId +-- Look up an Id which has been put into the envt by simplRecBndrs, +-- but where we have not yet done its RHS +lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of + Just (DoneId v) -> v + Just _ -> pprPanic "lookupRecBndr" (ppr v) + Nothing -> refineFromInScope in_scope v + +{- +************************************************************************ +* * +\section{Substituting an Id binder} +* * +************************************************************************ + + +These functions are in the monad only so that they can be made strict via seq. + +Note [Return type for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + (join j :: Char -> Int -> Int) 77 + ( j x = \y. y + ord x ) + (in case v of ) + ( A -> j 'x' ) + ( B -> j 'y' ) + ( C -> ) + +The simplifier pushes the "apply to 77" continuation inwards to give + + join j :: Char -> Int + j x = (\y. y + ord x) 77 + in case v of + A -> j 'x' + B -> j 'y' + C -> 77 + +Notice that the "apply to 77" continuation went into the RHS of the +join point. And that meant that the return type of the join point +changed!! + +That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr +takes a (Just res_ty) argument so that it knows to do the type-changing +thing. + +See also Note [Scaling join point arguments]. +-} + +simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplBinders !env bndrs = mapAccumLM simplBinder env bndrs + +------------- +simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- Used for lambda and case-bound variables +-- Clone Id if necessary, substitute type +-- Return with IdInfo already substituted, but (fragile) occurrence info zapped +-- The substitution is extended only if the variable is cloned, because +-- we *don't* need to use it to track occurrence info. +simplBinder !env bndr + | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr + ; seqTyVar tv `seq` return (env', tv) } + | otherwise = do { let (env', id) = substIdBndr env bndr + ; seqId id `seq` return (env', id) } + +--------------- +simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- A non-recursive let binder +simplNonRecBndr !env id + -- See Note [Bangs in the Simplifier] + = do { let (!env1, id1) = substIdBndr env id + ; seqId id1 `seq` return (env1, id1) } + +--------------- +simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv +-- Recursive let binders +simplRecBndrs env@(SimplEnv {}) ids + -- See Note [Bangs in the Simplifier] + = assert (all (not . isJoinId) ids) $ + do { let (!env1, ids1) = mapAccumL substIdBndr env ids + ; seqIds ids1 `seq` return env1 } + +--------------- +substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) +-- Might be a coercion variable +substIdBndr env bndr + | isCoVar bndr = substCoVarBndr env bndr + | otherwise = substNonCoVarIdBndr env bndr + +--------------- +substNonCoVarIdBndr + :: SimplEnv + -> InBndr -- Env and binder to transform + -> (SimplEnv, OutBndr) +-- Clone Id if necessary, substitute its type +-- Return an Id with its +-- * Type substituted +-- * UnfoldingInfo, Rules, WorkerInfo zapped +-- * Fragile OccInfo (only) zapped: Note [Robust OccInfo] +-- * Robust info, retained especially arity and demand info, +-- so that they are available to occurrences that occur in an +-- earlier binding of a letrec +-- +-- For the robust info, see Note [Arity robustness] +-- +-- Augment the substitution if the unique changed +-- Extend the in-scope set with the new Id +-- +-- Similar to GHC.Core.Subst.substIdBndr, except that +-- the type of id_subst differs +-- all fragile info is zapped +substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x) + +-- Inline to make the (OutId -> OutId) function a known call. +-- This is especially important for `substNonCoVarIdBndr` which +-- passes an identity lambda. +{-# INLINE subst_id_bndr #-} +subst_id_bndr :: SimplEnv + -> InBndr -- Env and binder to transform + -> (OutId -> OutId) -- Adjust the type + -> (SimplEnv, OutBndr) +subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) + old_id adjust_type + = assertPpr (not (isCoVar old_id)) (ppr old_id) + (env { seInScope = new_in_scope, + seIdSubst = new_subst }, new_id) + -- It's important that both seInScope and seIdSubst are updated with + -- the new_id, /after/ applying adjust_type. That's why adjust_type + -- is done here. If we did adjust_type in simplJoinBndr (the only + -- place that gives a non-identity adjust_type) we'd have to fiddle + -- afresh with both seInScope and seIdSubst + where + -- See Note [Bangs in the Simplifier] + !id1 = uniqAway in_scope old_id + !id2 = substIdType env id1 + !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding + -- and fragile OccInfo + !new_id = adjust_type id3 + + -- Extend the substitution if the unique has changed, + -- or there's some useful occurrence information + -- See the notes with substTyVarBndr for the delSubstEnv + !new_subst | new_id /= old_id + = extendVarEnv id_subst old_id (DoneId new_id) + | otherwise + = delVarEnv id_subst old_id + + !new_in_scope = in_scope `extendInScopeSet` new_id + +------------------------------------ +seqTyVar :: TyVar -> () +seqTyVar b = b `seq` () + +seqId :: Id -> () +seqId id = seqType (idType id) `seq` + idInfo id `seq` + () + +seqIds :: [Id] -> () +seqIds [] = () +seqIds (id:ids) = seqId id `seq` seqIds ids + +{- +Note [Arity robustness] +~~~~~~~~~~~~~~~~~~~~~~~ +We *do* transfer the arity from the in_id of a let binding to the +out_id so that its arity is visible in its RHS. Examples: + + * f = \x y. let g = \p q. f (p+q) in Just (...g..g...) + Here we want to give `g` arity 3 and eta-expand. `findRhsArity` will have a + hard time figuring that out when `f` only has arity 0 in its own RHS. + * f = \x y. ....(f `seq` blah).... + We want to drop the seq. + * f = \x. g (\y. f y) + You'd think we could eta-reduce `\y. f y` to `f` here. And indeed, that is true. + Unfortunately, it is not sound in general to eta-reduce in f's RHS. + Example: `f = \x. f x`. See Note [Eta reduction in recursive RHSs] for how + we prevent that. + +Note [Robust OccInfo] +~~~~~~~~~~~~~~~~~~~~~ +It's important that we *do* retain the loop-breaker OccInfo, because +that's what stops the Id getting inlined infinitely, in the body of +the letrec. +-} + + +{- ********************************************************************* +* * + Join points +* * +********************************************************************* -} + +simplNonRecJoinBndr :: SimplEnv -> InBndr + -> Mult -> OutType + -> SimplM (SimplEnv, OutBndr) + +-- A non-recursive let binder for a join point; +-- context being pushed inward may change the type +-- See Note [Return type for join points] +simplNonRecJoinBndr env id mult res_ty + = do { let (env1, id1) = simplJoinBndr mult res_ty env id + ; seqId id1 `seq` return (env1, id1) } + +simplRecJoinBndrs :: SimplEnv -> [InBndr] + -> Mult -> OutType + -> SimplM SimplEnv +-- Recursive let binders for join points; +-- context being pushed inward may change types +-- See Note [Return type for join points] +simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty + = assert (all isJoinId ids) $ + do { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids + ; seqIds ids1 `seq` return env1 } + +--------------- +simplJoinBndr :: Mult -> OutType + -> SimplEnv -> InBndr + -> (SimplEnv, OutBndr) +simplJoinBndr mult res_ty env id + = subst_id_bndr env id (adjustJoinPointType mult res_ty) + +--------------- +adjustJoinPointType :: Mult + -> Type -- New result type + -> Id -- Old join-point Id + -> Id -- Adjusted join-point Id +-- (adjustJoinPointType mult new_res_ty join_id) does two things: +-- +-- 1. Set the return type of the join_id to new_res_ty +-- See Note [Return type for join points] +-- +-- 2. Adjust the multiplicity of arrows in join_id's type, as +-- directed by 'mult'. See Note [Scaling join point arguments] +-- +-- INVARIANT: If any of the first n binders are foralls, those tyvars +-- cannot appear in the original result type. See isValidJoinPointType. +adjustJoinPointType mult new_res_ty join_id + = assert (isJoinId join_id) $ + setIdType join_id new_join_ty + where + join_arity = idJoinArity join_id + orig_ty = idType join_id + res_torc = typeTypeOrConstraint new_res_ty :: TypeOrConstraint + + new_join_ty = go join_arity orig_ty :: Type + + go :: JoinArity -> Type -> Type + go n ty + | n == 0 + = new_res_ty + + | Just (arg_bndr, body_ty) <- splitPiTy_maybe ty + , let body_ty' = go (n-1) body_ty + = case arg_bndr of + Named b -> mkForAllTy b body_ty' + Anon (Scaled arg_mult arg_ty) af -> mkFunTy af' arg_mult' arg_ty body_ty' + where + -- Using "!": See Note [Bangs in the Simplifier] + -- mkMultMul: see Note [Scaling join point arguments] + !arg_mult' = arg_mult `mkMultMul` mult + + -- the new_res_ty might be ConstraintLike while the original + -- one was TypeLike. So we may need to adjust the FunTyFlag. + -- (see #23952) + !af' = mkFunTyFlag (funTyFlagArgTypeOrConstraint af) res_torc + + | otherwise + = pprPanic "adjustJoinPointType" (ppr join_arity <+> ppr orig_ty) + +{- Note [Scaling join point arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a join point which is linear in its variable, in some context E: + +E[join j :: a %1 -> a + j x = x + in case v of + A -> j 'x' + B -> ] + +The simplifier changes to: + +join j :: a %1 -> a + j x = E[x] +in case v of + A -> j 'x' + B -> E[] + +If E uses its argument in a nonlinear way (e.g. a case['Many]), then +this is wrong: the join point has to change its type to a -> a. +Otherwise, we'd get a linearity error. + +See also Note [Return type for join points] and Note [Join points and case-of-case]. +-} + +{- +************************************************************************ +* * + Impedance matching to type substitution +* * +************************************************************************ +-} + +getTCvSubst :: SimplEnv -> Subst +getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) + = mkSubst in_scope emptyVarEnv tv_env cv_env + +getFullSubst :: InScopeSet -> SimplEnv -> Subst +getFullSubst in_scope (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env }) + = mk_full_subst in_scope tv_env cv_env id_env + +mk_full_subst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> Subst +mk_full_subst in_scope tv_env cv_env id_env + = mkSubst in_scope (mapVarEnv to_expr id_env) tv_env cv_env + where + to_expr :: SimplSR -> CoreExpr + -- A tiresome impedence-matcher + to_expr (DoneEx e _) = e + to_expr (DoneId v) = Var v + to_expr (ContEx tvs cvs ids e) = GHC.Core.Subst.substExprSC (mk_full_subst in_scope tvs cvs ids) e + +substTy :: HasDebugCallStack => SimplEnv -> Type -> Type +substTy env ty = Type.substTy (getTCvSubst env) ty + +substTyVar :: SimplEnv -> TyVar -> Type +substTyVar env tv = Type.substTyVar (getTCvSubst env) tv + +substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) +substTyVarBndr env tv + = case Type.substTyVarBndr (getTCvSubst env) tv of + (Subst in_scope' _ tv_env' cv_env', tv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') + +substCoVar :: SimplEnv -> CoVar -> Coercion +substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv + +substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) +substCoVarBndr env cv + = case Coercion.substCoVarBndr (getTCvSubst env) cv of + (Subst in_scope' _ tv_env' cv_env', cv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') + +substCo :: SimplEnv -> Coercion -> Coercion +substCo env co = Coercion.substCo (getTCvSubst env) co + +------------------ +substIdType :: SimplEnv -> Id -> Id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) + || no_free_vars + = id + | otherwise = Id.updateIdTypeAndMult (Type.substTyUnchecked subst) id + -- The tyCoVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w + subst = Subst in_scope emptyIdSubstEnv tv_env cv_env + old_ty = idType id + old_w = idMult id diff --git a/GHC/Core/Opt/Simplify/Inline.hs b/GHC/Core/Opt/Simplify/Inline.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify/Inline.hs @@ -0,0 +1,751 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + +This module contains inlining logic used by the simplifier. +-} + + + +module GHC.Core.Opt.Simplify.Inline ( + -- * Cheap and cheerful inlining checks. + couldBeSmallEnoughToInline, + smallEnoughToInline, activeUnfolding, + + -- * The smart inlining decisions are made by callSiteInline + callSiteInline, CallCtxt(..), + ) where + +import GHC.Prelude + +import GHC.Driver.Flags + +import GHC.Core.Opt.Simplify.Env + +import GHC.Core +import GHC.Core.Unfold +import GHC.Core.FVs( exprFreeIds ) + +import GHC.Types.Id +import GHC.Types.Var.Env( InScopeSet, lookupInScope ) +import GHC.Types.Var.Set +import GHC.Types.Basic ( Arity, RecFlag(..), isActive ) +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Types.Name + +import Data.List (isPrefixOf) + +{- +************************************************************************ +* * +\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} +* * +************************************************************************ + +We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that +we ``couldn't possibly use'' on the other side. Can be overridden w/ +flaggery. Just the same as smallEnoughToInline, except that it has no +actual arguments. +-} + +couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool +couldBeSmallEnoughToInline opts threshold rhs + = case sizeExpr opts threshold [] body of + TooBig -> False + _ -> True + where + (_, body) = collectBinders rhs + +---------------- +smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool +smallEnoughToInline opts (CoreUnfolding {uf_guidance = guidance}) + = case guidance of + UnfIfGoodArgs {ug_size = size} -> size <= unfoldingUseThreshold opts + UnfWhen {} -> True + UnfNever -> False +smallEnoughToInline _ _ + = False + +{- +************************************************************************ +* * +\subsection{callSiteInline} +* * +************************************************************************ + +This is the key function. It decides whether to inline a variable at a call site + +callSiteInline is used at call sites, so it is a bit more generous. +It's a very important function that embodies lots of heuristics. +A non-WHNF can be inlined if it doesn't occur inside a lambda, +and occurs exactly once or + occurs once in each branch of a case and is small + +If the thing is in WHNF, there's no danger of duplicating work, +so we can inline if it occurs once, or is small + +NOTE: we don't want to inline top-level functions that always diverge. +It just makes the code bigger. Tt turns out that the convenient way to prevent +them inlining is to give them a NOINLINE pragma, which we do in +StrictAnal.addStrictnessInfoToTopId +-} + +callSiteInline :: SimplEnv + -> Logger + -> Id -- The Id + -> Bool -- True if there are no arguments at all (incl type args) + -> [ArgSummary] -- One for each value arg; True if it is interesting + -> CallCtxt -- True <=> continuation is interesting + -> Maybe CoreExpr -- Unfolding, if any +callSiteInline env logger id lone_variable arg_infos cont_info + = case idUnfolding id of + -- idUnfolding checks for loop-breakers, returning NoUnfolding + -- Things with an INLINE pragma may have an unfolding *and* + -- be a loop breaker (maybe the knot is not yet untied) + CoreUnfolding { uf_tmpl = unf_template + , uf_cache = unf_cache + , uf_guidance = guidance } + | active_unf -> tryUnfolding env logger id lone_variable + arg_infos cont_info unf_template + unf_cache guidance + | otherwise -> traceInline logger uf_opts id "Inactive unfolding:" (ppr id) Nothing + NoUnfolding -> Nothing + BootUnfolding -> Nothing + OtherCon {} -> Nothing + DFunUnfolding {} -> Nothing -- Never unfold a DFun + where + uf_opts = seUnfoldingOpts env + active_unf = activeUnfolding (seMode env) id + +activeUnfolding :: SimplMode -> Id -> Bool +activeUnfolding mode id + | isCompulsoryUnfolding (realIdUnfolding id) + = True -- Even sm_inline can't override compulsory unfoldings + | otherwise + = isActive (sm_phase mode) (idInlineActivation id) + && sm_inline mode + -- `or` isStableUnfolding (realIdUnfolding id) + -- Inline things when + -- (a) they are active + -- (b) sm_inline says so, except that for stable unfoldings + -- (ie pragmas) we inline anyway + +-- | Report the inlining of an identifier's RHS to the user, if requested. +traceInline :: Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a +traceInline logger opts inline_id str doc result + -- We take care to ensure that doc is used in only one branch, ensuring that + -- the simplifier can push its allocation into the branch. See Note [INLINE + -- conditional tracing utilities]. + | enable = logTraceMsg logger str doc result + | otherwise = result + where + enable + | logHasDumpFlag logger Opt_D_dump_verbose_inlinings + = True + | Just prefix <- unfoldingReportPrefix opts + = prefix `isPrefixOf` occNameString (getOccName inline_id) + | otherwise + = False +{-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities] + +{- Note [Avoid inlining into deeply nested cases] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Also called "exponential inlining". + +Consider a function f like this: (#18730) + + f arg1 arg2 = + case ... + ... -> g arg1 + ... -> g arg2 + +This function is small. So should be safe to inline. +However sometimes this doesn't quite work out like that. +Consider this code: + + f1 arg1 arg2 ... = ... + case _foo of + alt1 -> ... f2 arg1 ... + alt2 -> ... f2 arg2 ... + + f2 arg1 arg2 ... = ... + case _foo of + alt1 -> ... f3 arg1 ... + alt2 -> ... f3 arg2 ... + + f3 arg1 arg2 ... = ... + + ... repeats up to n times. And then f1 is + applied to some arguments: + + foo = ... f1 ... + +Initially f2..fn are not interesting to inline so we don't. However we see +that f1 is applied to interesting args. So it's an obvious choice to inline +those: + + foo = ... + case _foo of + alt1 -> ... f2 ... + alt2 -> ... f2 ... + +As a result we go and inline f2 both mentions of f2 in turn are now applied to +interesting arguments and f2 is small: + + foo = ... + case _foo of + alt1 -> ... case _foo of + alt1 -> ... f3 ... + alt2 -> ... f3 ... + + alt2 -> ... case _foo of + alt1 -> ... f3 ... + alt2 -> ... f3 ... + +The same thing happens for each binding up to f_n, duplicating the amount of inlining +done in each step. Until at some point we are either done or run out of simplifier +ticks/RAM. This pattern happened #18730. + +To combat this we introduce one more heuristic when weighing inlining decision. +We keep track of a "case-depth". Which increases each time we look inside a case +expression with more than one alternative. + +We then apply a penalty to inlinings based on the case-depth at which they would +be inlined. Bounding the number of inlinings in such a scenario. + +The heuristic can be tuned in two ways: + +* We can ignore the first n levels of case nestings for inlining decisions using + -funfolding-case-threshold. + +* The penalty grows linear with the depth. It's computed as + size*(depth-threshold)/scaling. + Scaling can be set with -funfolding-case-scaling. + +Reflections and wrinkles + +* See also Note [Do not add unfoldings to join points at birth] in + GHC.Core.Opt.Simplify.Iteration + +* The total case depth is really the wrong thing; it will inhibit inlining of a + local function, just because there is some giant case nest further out. What we + want is the /difference/ in case-depth between the binding site and the call site. + That could be done quite easily by adding the case-depth to the Unfolding of the + function. + +* What matters more than /depth/ is total /width/; that is how many alternatives + are in the tree. We could perhaps multiply depth by width at each case expression. + +* There might be a case nest with many alternatives, but the function is called in + only a handful of them. So maybe we should ignore case-depth, and instead penalise + funtions that are called many times -- after all, inlining them bloats code. + + But in the scenario above, we are simplifying an inlined fuction, without doing a + global occurrence analysis each time. So if we based the penalty on multiple + occurences, we should /also/ add a penalty when simplifying an already-simplified + expression. We do track this (seInlineDepth) but currently we barely use it. + + An advantage of using occurrences+inline depth is that it'll work when no + case expressions are involved. See #15488. + +* Test T18730 did not involve join points. But join points are very prone to + the same kind of thing. For exampe in #13253, and several related tickets, + we got an exponential blowup in code size from a program that looks like + this. + + let j1a x = case f y of { True -> p; False -> q } + j1b x = case f y of { True -> q; False -> p } + j2a x = case f (y+1) of { True -> j1a x; False -> j1b x} + j2b x = case f (y+1) of { True -> j1b x; False -> j1a x} + ... + in case f (y+10) of { True -> j10a 7; False -> j10b 8 } + + The first danger is this: in Simplifier iteration 1 postInlineUnconditionally + inlines the last functions, j10a and j10b (they are both small). Now we have + two calls to j9a and two to j9b. In the next Simplifer iteration, + postInlineUnconditionally inlines all four of these calls, leaving four calls + to j8a and j8b. Etc. + + Happily, this probably /won't/ happen because the Simplifier works top down, so it'll + inline j1a/j1b into j2a/j2b, which will make the latter bigger; so the process + will stop. But we still need to stop the inline cascade described at the head + of this Note. + +Some guidance on setting these defaults: + +* A low threshold (<= 2) is needed to prevent exponential cases from spiraling out of + control. We picked 2 for no particular reason. + +* Scaling the penalty by any more than 30 means the reproducer from + T18730 won't compile even with reasonably small values of n. Instead + it will run out of runs/ticks. This means to positively affect the reproducer + a scaling <= 30 is required. + +* A scaling of >= 15 still causes a few very large regressions on some nofib benchmarks. + (+80% for gc/fulsom, +90% for real/ben-raytrace, +20% for spectral/fibheaps) + +* A scaling of >= 25 showed no regressions on nofib. However it showed a number of + (small) regression for compiler perf benchmarks. + +The end result is that we are settling for a scaling of 30, with a threshold of 2. +This gives us minimal compiler perf regressions. No nofib runtime regressions and +will still avoid this pattern sometimes. This is a "safe" default, where we err on +the side of compiler blowup instead of risking runtime regressions. + +For cases where the default falls short the flag can be changed to allow +more/less inlining as needed on a per-module basis. + +-} + +tryUnfolding :: SimplEnv -> Logger -> Id -> Bool -> [ArgSummary] -> CallCtxt + -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance + -> Maybe CoreExpr +tryUnfolding env logger id lone_variable arg_infos + cont_info unf_template unf_cache guidance + = case guidance of + UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing + + UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive opts) + -- See Note [INLINE for small functions] (3) + -> traceInline logger opts id str (mk_doc some_benefit empty True) (Just unf_template) + | otherwise + -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing + where + some_benefit = calc_some_benefit uf_arity True + enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0) + + UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } + | isJoinId id, small_enough -> inline_join_point + | unfoldingVeryAggressive opts -> yes + | is_wf, some_benefit, small_enough -> yes + | otherwise -> no + where + yes = traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template) + no = traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing + + some_benefit = calc_some_benefit (length arg_discounts) False + + -- depth_penalty: see Note [Avoid inlining into deeply nested cases] + depth_threshold = unfoldingCaseThreshold opts + depth_scaling = unfoldingCaseScaling opts + depth_penalty | case_depth <= depth_threshold = 0 + | otherwise = (size * (case_depth - depth_threshold)) `div` depth_scaling + + adjusted_size = size + depth_penalty - discount + small_enough = adjusted_size <= unfoldingUseThreshold opts + discount = computeDiscount arg_discounts res_discount arg_infos cont_info + + extra_doc = vcat [ ppWhen (isJoinId id) $ + text "join" <+> fsep [ ppr (v, hasCoreUnfolding (idUnfolding v) + , fmap (isEvaldUnfolding . idUnfolding) (lookupInScope in_scope v) + , is_more_evald in_scope v) + | v <- vselems (exprFreeIds unf_template) ] + , text "depth based penalty =" <+> int depth_penalty + , text "adjusted size =" <+> int adjusted_size ] + + inline_join_point -- See Note [Inlining join points] + | or (zipWith scrut_arg arg_discounts arg_infos) = yes + | anyVarSet (is_more_evald in_scope) $ + exprFreeIds unf_template = yes + | otherwise = no + -- scrut_arg is True if the function body has a discount and the arg is a value + scrut_arg disc ValueArg = disc > 0 + scrut_arg _ _ = False + + where + opts = seUnfoldingOpts env + case_depth = seCaseDepth env + inline_depth = seInlineDepth env + in_scope = seInScope env + + -- Unpack the UnfoldingCache lazily because it may not be needed, and all + -- its fields are strict; so evaluating unf_cache at all forces all the + -- isWorkFree etc computations to take place. That risks wasting effort for + -- Ids that are never going to inline anyway. + -- See Note [UnfoldingCache] in GHC.Core + UnfoldingCache{ uf_is_work_free = is_wf, uf_expandable = is_exp } = unf_cache + + mk_doc some_benefit extra_doc yes_or_no + = vcat [ text "arg infos" <+> ppr arg_infos + , text "interesting continuation" <+> ppr cont_info + , text "some_benefit" <+> ppr some_benefit + , text "is exp:" <+> ppr is_exp + , text "is work-free:" <+> ppr is_wf + , text "guidance" <+> ppr guidance + , text "case depth =" <+> int case_depth + , text "inline depth =" <+> int inline_depth + , extra_doc + , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] + + ctx = log_default_dump_context (logFlags logger) + str = "Considering inlining: " ++ showSDocOneLine ctx (ppr id) + n_val_args = length arg_infos + + -- some_benefit is used when the RHS is small enough + -- and the call has enough (or too many) value + -- arguments (ie n_val_args >= arity). But there must + -- be *something* interesting about some argument, or the + -- result context, to make it worth inlining + calc_some_benefit :: Arity -> Bool -> Bool -- The Arity is the number of args + -- expected by the unfolding + calc_some_benefit uf_arity is_inline + | not saturated = interesting_args -- Under-saturated + -- Note [Unsaturated applications] + | otherwise = interesting_args -- Saturated or over-saturated + || interesting_call + where + saturated = n_val_args >= uf_arity + over_saturated = n_val_args > uf_arity + interesting_args = any nonTriv arg_infos + -- NB: (any nonTriv arg_infos) looks at the + -- over-saturated args too which is "wrong"; + -- but if over-saturated we inline anyway. + + interesting_call + | over_saturated + = True + | otherwise + = case cont_info of + CaseCtxt -> not (lone_variable && is_exp) -- Note [Lone variables] + ValAppCtxt -> True -- Note [Cast then apply] + RuleArgCtxt -> uf_arity > 0 -- See Note [RHS of lets] + DiscArgCtxt -> uf_arity > 0 -- Note [Inlining in ArgCtxt] + RhsCtxt NonRecursive | is_inline + -> uf_arity > 0 -- See Note [RHS of lets] + _other -> False -- See Note [Nested functions] + + +vselems :: VarSet -> [Var] +vselems s = nonDetStrictFoldVarSet (\v vs -> v : vs) [] s + +is_more_evald :: InScopeSet -> Id -> Bool +-- See Note [Inlining join points] +is_more_evald in_scope v + | Just v1 <- lookupInScope in_scope v + , idUnfolding v1 `isBetterUnfoldingThan` idUnfolding v + = True + | otherwise + = False + +{- Note [RHS of lets] +~~~~~~~~~~~~~~~~~~~~~ +When the call is the argument of a function with a RULE, or the RHS of a let, +we are a little bit keener to inline (in tryUnfolding). For example + f y = (y,y,y) + g y = let x = f y in ...(case x of (a,b,c) -> ...) ... +We'd inline 'f' if the call was in a case context, and it kind-of-is, +only we can't see it. Also + x = f v +could be expensive whereas + x = case v of (a,b) -> a +is patently cheap and may allow more eta expansion. + +So, in `interesting_call` in `tryUnfolding`, we treat the RHS of a +/non-recursive/ let as not-totally-boring. A /recursive/ let isn't +going be inlined so there is much less point. Hence the (only reason +for the) RecFlag in RhsCtxt + +We inline only if `f` has an `UnfWhen` guidance. I found that being more eager +led to fruitless inlining. See Note [Seq is boring] wrinkle (SB1) in +GHC.Core.Opt.Simplify.Utils. + +Note [Inlining join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we /do not/ want to inline join points /even if they are small/. +See Note [Duplicating join points] in GHC.Core.Opt.Simplify.Iteration. + +But, assuming it is small, there are various times when we /do/ want to +inline a (non-recursive) join point. Namely, if either of these hold: + +(1) A /scrutinised/ argument (non-zero discount) has a /ValueArg/ info. + Inlining will give some benefit. + +(2) A free variable of the RHS is + * Is /not/ evaluated at the join point defn site + * Is evaluated at the join point call site. + This is the is_more_evald predicate. + +(1) is fairly obvious but (2) is less so. Here is the code for `integerGT` +without (2): + + integerGt = \ (x :: Integer) (y :: Integer) -> + join fail _ = case x of { + IS x1 -> case y of { + IS y1 -> case <# x1 y1 of + _DEFAULT -> case ==# x1 y1 of + DEFAULT -> True; + 1# -> False + 1# -> False + IP ds1 -> False + IN ds1 -> True + + IP x1 -> case y of { + _DEFAULT -> True; + IP y1 -> case bigNatCompare x1 y1 of + _DEFAULT -> False; + GT -> True + IN x1 -> case y of { + _DEFAULT -> False; + IN y1 -> case bigNatCompare y1 x1 of + _DEFAULT -> False; + GT -> True + in case x of { + _DEFAULT -> jump fail GHC.Prim.(##); + IS x1 -> case y of { + _DEFAULT -> jump fail GHC.Prim.(##); + IS y1 -> tagToEnum# @Bool (># x1 y1) + +If we inline `fail` we get /much/ better code. The only clue is that +`x` and `y` (a) are not evaluated at the definition site, and (b) are +evaluated at the call site. This predicate is `isBetterUnfoldingThan`. + +You might think that the variable should also be /scrutinised/ in the +join-point RHS, but here are two reasons for not taking that into +account. + +First, we see code somewhat like this in imaginary/wheel-sieve1: + let x = in + join $j = (x,y) in + case z of + A -> case x of + P -> $j + Q -> blah + B -> (x,x) + C -> True +Here `x` can't be duplicated into the branches becuase it is used +in both the join point and the A branch. But if we inline $j we get + let x = in + case z of + A -> case x of x' + P -> (x', y) + Q -> blah + B -> x + C -> True +and now we /can/ duplicate x into the branches, at which point: + * it is used strictly in the A branch (evaluated, but no thunk) + * it is used lazily in the B branch (still a thunk) + * it is not used at all in the C branch (no thunk) + +Second, spectral/treejoin gets a big win from SpecConstr due +to evaluated-ness. Something like this: + join $j x = ...(foo fv)... + in case fv of I# x -> + ... jump $j True ... +If we inline $j, SpecConstr sees a call (foo (I# x)) and specialises. + +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a call is not saturated, we *still* inline if one of the +arguments has interesting structure. That's sometimes very important. +A good example is the Ord instance for Bool in Base: + + Rec { + $fOrdBool =GHC.Classes.D:Ord + @ Bool + ... + $cmin_ajX + + $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool + $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool + } + +But the defn of GHC.Classes.$dmmin is: + + $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a + {- Arity: 3, HasNoCafRefs, Strictness: SLL, + Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> + case @ a GHC.Classes.<= @ a $dOrd x y of wild { + GHC.Types.False -> y GHC.Types.True -> x }) -} + +We *really* want to inline $dmmin, even though it has arity 3, in +order to unravel the recursion. + + +Note [Things to watch] +~~~~~~~~~~~~~~~~~~~~~~ +* { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } + Assume x is exported, so not inlined unconditionally. + Then we want x to inline unconditionally; no reason for it + not to, and doing so avoids an indirection. + +* { x = I# 3; ....f x.... } + Make sure that x does not inline unconditionally! + Lest we get extra allocation. + +Note [Nested functions] +~~~~~~~~~~~~~~~~~~~~~~~ +At one time we treated a call of a non-top-level function as +"interesting" (regardless of how boring the context) in the hope +that inlining it would eliminate the binding, and its allocation. +Specifically, in the default case of interesting_call we had + _other -> not is_top && uf_arity > 0 + +But actually postInlineUnconditionally does some of this and overall +it makes virtually no difference to nofib. So I simplified away this +special case + +Note [Cast then apply] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + myIndex = __inline_me ( (/\a. ) |> co ) + co :: (forall a. a -> a) ~ (forall a. T a) + ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ... + +We need to inline myIndex to unravel this; but the actual call (myIndex a) has +no value arguments. The ValAppCtxt gives it enough incentive to inline. + +Note [Inlining in ArgCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The condition (arity > 0) here is very important, because otherwise +we end up inlining top-level stuff into useless places; eg + x = I# 3# + f = \y. g x +This can make a very big difference: it adds 16% to nofib 'integer' allocs, +and 20% to 'power'. + +At one stage I replaced this condition by 'True' (leading to the above +slow-down). The motivation was test eyeball/inline1.hs; but that seems +to work ok now. + +NOTE: arguably, we should inline in ArgCtxt only if the result of the +call is at least CONLIKE. At least for the cases where we use ArgCtxt +for the RHS of a 'let', we only profit from the inlining if we get a +CONLIKE thing (modulo lets). + +Note [Lone variables] +~~~~~~~~~~~~~~~~~~~~~ +See also Note [Interaction of exprIsWorkFree and lone variables] +which appears below + +The "lone-variable" case is important. I spent ages messing about +with unsatisfactory variants, but this is nice. The idea is that if a +variable appears all alone + + as an arg of lazy fn, or rhs BoringCtxt + as scrutinee of a case CaseCtxt + as arg of a fn ArgCtxt +AND + it is bound to a cheap expression + +then we should not inline it (unless there is some other reason, +e.g. it is the sole occurrence). That is what is happening at +the use of 'lone_variable' in 'interesting_call'. + +Why? At least in the case-scrutinee situation, turning + let x = (a,b) in case x of y -> ... +into + let x = (a,b) in case (a,b) of y -> ... +and thence to + let x = (a,b) in let y = (a,b) in ... +is bad if the binding for x will remain. + +Another example: I discovered that strings +were getting inlined straight back into applications of 'error' +because the latter is strict. + s = "foo" + f = \x -> ...(error s)... + +Fundamentally such contexts should not encourage inlining because, provided +the RHS is "expandable" (see Note [exprIsExpandable] in GHC.Core.Utils) the +context can ``see'' the unfolding of the variable (e.g. case or a +RULE) so there's no gain. + +However, watch out: + + * Consider this: + foo = \n. [n]) {-# INLINE foo #-} + bar = foo 20 {-# INLINE bar #-} + baz = \n. case bar of { (m:_) -> m + n } + Here we really want to inline 'bar' so that we can inline 'foo' + and the whole thing unravels as it should obviously do. This is + important: in the NDP project, 'bar' generates a closure data + structure rather than a list. + + So the non-inlining of lone_variables should only apply if the + unfolding is regarded as expandable; because that is when + exprIsConApp_maybe looks through the unfolding. Hence the "&& + is_exp" in the CaseCtxt branch of interesting_call + + * Even a type application or coercion isn't a lone variable. + Consider + case $fMonadST @ RealWorld of { :DMonad a b c -> c } + We had better inline that sucker! The case won't see through it. + + For now, I'm treating treating a variable applied to types + in a *lazy* context "lone". The motivating example was + f = /\a. \x. BIG + g = /\a. \y. h (f a) + There's no advantage in inlining f here, and perhaps + a significant disadvantage. Hence some_val_args in the Stop case + +Note [Interaction of exprIsWorkFree and lone variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lone-variable test says "don't inline if a case expression +scrutinises a lone variable whose unfolding is cheap". It's very +important that, under these circumstances, exprIsConApp_maybe +can spot a constructor application. So, for example, we don't +consider + let x = e in (x,x) +to be cheap, and that's good because exprIsConApp_maybe doesn't +think that expression is a constructor application. + +In the 'not (lone_variable && is_wf)' test, I used to test is_value +rather than is_wf, which was utterly wrong, because the above +expression responds True to exprIsHNF, which is what sets is_value. + +This kind of thing can occur if you have + + {-# INLINE foo #-} + foo = let x = e in (x,x) + +which Roman did. + + +-} + +computeDiscount :: [Int] -> Int -> [ArgSummary] -> CallCtxt + -> Int +computeDiscount arg_discounts res_discount arg_infos cont_info + + = 10 -- Discount of 10 because the result replaces the call + -- so we count 10 for the function itself + + + 10 * length actual_arg_discounts + -- Discount of 10 for each arg supplied, + -- because the result replaces the call + + + total_arg_discount + res_discount' + where + actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos + total_arg_discount = sum actual_arg_discounts + + mk_arg_discount _ TrivArg = 0 + mk_arg_discount _ NonTrivArg = 10 + mk_arg_discount discount ValueArg = discount + + res_discount' + | LT <- arg_discounts `compareLength` arg_infos + = res_discount -- Over-saturated + | otherwise + = case cont_info of + BoringCtxt -> 0 + CaseCtxt -> res_discount -- Presumably a constructor + ValAppCtxt -> res_discount -- Presumably a function + _ -> 40 `min` res_discount + -- ToDo: this 40 `min` res_discount doesn't seem right + -- for DiscArgCtxt it shouldn't matter because the function will + -- get the arg discount for any non-triv arg + -- for RuleArgCtxt we do want to be keener to inline; but not only + -- constructor results + -- for RhsCtxt I suppose that exposing a data con is good in general + -- And 40 seems very arbitrary + -- + -- res_discount can be very large when a function returns + -- constructors; but we only want to invoke that large discount + -- when there's a case continuation. + -- Otherwise we, rather arbitrarily, threshold it. Yuk. + -- But we want to avoid inlining large functions that return + -- constructors into contexts that are simply "interesting" diff --git a/GHC/Core/Opt/Simplify/Iteration.hs b/GHC/Core/Opt/Simplify/Iteration.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify/Iteration.hs @@ -0,0 +1,4827 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[Simplify]{The main module of the simplifier} +-} + + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where + +import GHC.Prelude + +import GHC.Driver.Flags + +import GHC.Core +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Opt.ConstantFold +import GHC.Core.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst ) +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Simplify.Inline +import GHC.Core.Opt.Simplify.Utils +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) ) +import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) +import qualified GHC.Core.Make +import GHC.Core.Coercion hiding ( substCo, substCoVar ) +import GHC.Core.Reduction +import GHC.Core.Coercion.Opt ( optCoercion ) +import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) +import GHC.Core.DataCon +import GHC.Core.Opt.Stats ( Tick(..) ) +import GHC.Core.Ppr ( pprCoreExpr ) +import GHC.Core.Unfold +import GHC.Core.Unfold.Make +import GHC.Core.Utils +import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe + , pushCoTyArg, pushCoValArg, exprIsDeadEnd + , typeArity, arityTypeArity, etaExpandAT ) +import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) +import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} ) +import GHC.Core.Rules ( lookupRule, getRules ) +import GHC.Core.Multiplicity + +import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326 +import GHC.Types.SourceText +import GHC.Types.Id +import GHC.Types.Id.Make ( seqId ) +import GHC.Types.Id.Info +import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) +import GHC.Types.Demand +import GHC.Types.Unique ( hasKey ) +import GHC.Types.Basic +import GHC.Types.Tickish +import GHC.Types.Var ( isTyCoVar ) +import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) +import GHC.Builtin.Names( runRWKey, seqHashKey ) + +import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) +import GHC.Data.FastString +import GHC.Unit.Module ( moduleName ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Monad ( mapAccumLM, liftIO ) +import GHC.Utils.Logger +import GHC.Utils.Misc + +import Control.Monad +import Data.List.NonEmpty (NonEmpty (..)) + +{- +The guts of the simplifier is in this module, but the driver loop for +the simplifier is in GHC.Core.Opt.Pipeline + +Note [The big picture] +~~~~~~~~~~~~~~~~~~~~~~ +The general shape of the simplifier is this: + + simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + + * SimplEnv contains + - Simplifier mode + - Ambient substitution + - InScopeSet + + * SimplFloats contains + - Let-floats (which includes ok-for-spec case-floats) + - Join floats + - InScopeSet (including all the floats) + + * Expressions + simplExpr :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + The result of simplifying an /expression/ is (floats, expr) + - A bunch of floats (let bindings, join bindings) + - A simplified expression. + The overall result is effectively (let floats in expr) + + * Bindings + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + The result of simplifying a binding is + - A bunch of floats, the last of which is the simplified binding + There may be auxiliary bindings too; see prepareRhs + - An environment suitable for simplifying the scope of the binding + + The floats may also be empty, if the binding is inlined unconditionally; + in that case the returned SimplEnv will have an augmented substitution. + + The returned floats and env both have an in-scope set, and they are + guaranteed to be the same. + +Eta expansion +~~~~~~~~~~~~~~ +For eta expansion, we want to catch things like + + case e of (a,b) -> \x -> case a of (p,q) -> \y -> r + +If the \x was on the RHS of a let, we'd eta expand to bring the two +lambdas together. And in general that's a good thing to do. Perhaps +we should eta expand wherever we find a (value) lambda? Then the eta +expansion at a let RHS can concentrate solely on the PAP case. + +Note [In-scope set as a substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Lookups in in-scope set], an in-scope set can act as +a substitution. Specifically, it acts as a substitution from variable to +variables /with the same unique/. + +Why do we need this? Well, during the course of the simplifier, we may want to +adjust inessential properties of a variable. For instance, when performing a +beta-reduction, we change + + (\x. e) u ==> let x = u in e + +We typically want to add an unfolding to `x` so that it inlines to (the +simplification of) `u`. + +We do that by adding the unfolding to the binder `x`, which is added to the +in-scope set. When simplifying occurrences of `x` (every occurrence!), they are +replaced by their “updated” version from the in-scope set, hence inherit the +unfolding. This happens in `SimplEnv.substId`. + +Another example. Consider + + case x of y { Node a b -> ...y... + ; Leaf v -> ...y... } + +In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we +want y's unfolding to be (Leaf v). We achieve this by adding the appropriate +unfolding to y, and re-adding it to the in-scope set. See the calls to +`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere. + +It's quite convenient. This way we don't need to manipulate the substitution all +the time: every update to a binder is automatically reflected to its bound +occurrences. + +Note [Bangs in the Simplifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both SimplFloats and SimplEnv do *not* generally benefit from making +their fields strict. I don't know if this is because of good use of +laziness or unintended side effects like closures capturing more variables +after WW has run. + +But the end result is that we keep these lazy, but force them in some places +where we know it's beneficial to the compiler. + +Similarly environments returned from functions aren't *always* beneficial to +force. In some places they would never be demanded so forcing them early +increases allocation. In other places they almost always get demanded so +it's worthwhile to force them early. + +Would it be better to through every allocation of e.g. SimplEnv and decide +wether or not to make this one strict? Absolutely! Would be a good use of +someones time? Absolutely not! I made these strict that showed up during +a profiled build or which I noticed while looking at core for one reason +or another. + +The result sadly is that we end up with "random" bangs in the simplifier +where we sometimes force e.g. the returned environment from a function and +sometimes we don't for the same function. Depending on the context around +the call. The treatment is also not very consistent. I only added bangs +where I saw it making a difference either in the core or benchmarks. Some +patterns where it would be beneficial aren't convered as a consequence as +I neither have the time to go through all of the core and some cases are +too small to show up in benchmarks. + + + +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) +-- See Note [The big picture] +simplTopBinds env0 binds0 + = do { -- Put all the top-level binders into scope at the start + -- so that if a rewrite rule has unexpectedly brought + -- anything into scope, then we don't get a complaint about that. + -- It's rather as if the top-level binders were imported. + -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal". + -- See Note [Bangs in the Simplifier] + ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) + ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 + ; freeTick SimplifierDone + ; return (floats, env2) } + where + -- We need to track the zapped top-level binders, because + -- they should have their fragile IdInfo zapped (notably occurrence info) + -- That's why we run down binds and bndrs' simultaneously. + -- + simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) + simpl_binds env [] = return (emptyFloats env, env) + simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind + ; (floats, env2) <- simpl_binds env1 binds + -- See Note [Bangs in the Simplifier] + ; let !floats1 = float `addFloats` floats + ; return (floats1, env2) } + + simpl_bind env (Rec pairs) + = simplRecBind env (BC_Let TopLevel Recursive) pairs + simpl_bind env (NonRec b r) + = do { let bind_cxt = BC_Let TopLevel NonRecursive + ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt + ; simplRecOrTopPair env' bind_cxt b b' r } + +{- +************************************************************************ +* * + Lazy bindings +* * +************************************************************************ + +simplRecBind is used for + * recursive bindings only +-} + +simplRecBind :: SimplEnv -> BindContext + -> [(InId, InExpr)] + -> SimplM (SimplFloats, SimplEnv) +simplRecBind env0 bind_cxt pairs0 + = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0 + ; let new_bndrs = map sndOf3 triples + ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env -> + go env triples + ; return (mkRecFloats rec_floats, env2) } + where + add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) + -- Add the (substituted) rules to the binder + add_rules env (bndr, rhs) + = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt + ; return (env', (bndr, bndr', rhs)) } + + go env [] = return (emptyFloats env, env) + + go env ((old_bndr, new_bndr, rhs) : pairs) + = do { (float, env1) <- simplRecOrTopPair env bind_cxt + old_bndr new_bndr rhs + ; (floats, env2) <- go env1 pairs + ; return (float `addFloats` floats, env2) } + +{- +simplOrTopPair is used for + * recursive bindings (whether top level or not) + * top-level non-recursive bindings + +It assumes the binder has already been simplified, but not its IdInfo. +-} + +simplRecOrTopPair :: SimplEnv + -> BindContext + -> InId -> OutBndr -> InExpr -- Binder and rhs + -> SimplM (SimplFloats, SimplEnv) + +simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs + | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) + old_bndr rhs env + = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} + simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $ + do { tick (PreInlineUnconditionally old_bndr) + ; return ( emptyFloats env, env' ) } + + | otherwise + = case bind_cxt of + BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $ + simplJoinBind is_rec cont + (old_bndr,env) (new_bndr,env) (rhs,env) + + BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $ + simplLazyBind top_lvl is_rec + (old_bndr,env) (new_bndr,env) (rhs,env) + +simplTrace :: String -> SDoc -> SimplM a -> SimplM a +simplTrace herald doc thing_inside = do + logger <- getLogger + if logHasDumpFlag logger Opt_D_verbose_core2core + then logTraceMsg logger herald doc thing_inside + else thing_inside + +-------------------------- +simplLazyBind :: TopLevelFlag -> RecFlag + -> (InId, SimplEnv) -- InBinder, and static env for its unfolding (if any) + -> (OutId, SimplEnv) -- OutBinder, and SimplEnv after simplifying that binder + -- The OutId has IdInfo (notably RULES), + -- except arity, unfolding + -> (InExpr, SimplEnv) -- The RHS and its static environment + -> SimplM (SimplFloats, SimplEnv) +-- Precondition: Ids only, no TyVars; not a JoinId +-- Precondition: rhs obeys the let-can-float invariant +simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se) + = assert (isId bndr ) + assertPpr (not (isJoinId bndr)) (ppr bndr) $ + -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ + do { let !rhs_env = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier] + (tvs, body) = case collectTyAndValBinders rhs of + (tvs, [], body) + | surely_not_lam body -> (tvs, body) + _ -> ([], rhs) + + surely_not_lam (Lam {}) = False + surely_not_lam (Tick t e) + | not (tickishFloatable t) = surely_not_lam e + -- eta-reduction could float + surely_not_lam _ = True + -- Do not do the "abstract tyvar" thing if there's + -- a lambda inside, because it defeats eta-reduction + -- f = /\a. \x. g a x + -- should eta-reduce. + + ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs + -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils + + -- Simplify the RHS + ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) + is_rec (idDemandInfo bndr) + ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont + + -- ANF-ise a constructor or PAP rhs + ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-} + prepareBinding env top_lvl is_rec + False -- Not strict; this is simplLazyBind + bndr1 body_floats0 body0 + -- Subtle point: we do not need or want tvs' in the InScope set + -- of body_floats2, so we pass in 'env' not 'body_env'. + -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do + -- more renaming than necessary => extra work (see !7777 and test T16577). + -- Don't need: we wrap tvs' around the RHS anyway. + + ; (rhs_floats, body3) + <- if isEmptyFloats body_floats2 || null tvs then -- Simple floating + {-#SCC "simplLazyBind-simple-floating" #-} + return (body_floats2, body2) + + else -- Non-empty floats, and non-empty tyvars: do type-abstraction first + {-#SCC "simplLazyBind-type-abstraction-first" #-} + do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl + tvs' body_floats2 body2 + ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds + ; return (poly_floats, body3) } + + ; let env1 = env `setInScopeFromF` rhs_floats + ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont + ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1) + ; return (rhs_floats `addFloats` bind_float, env2) } + +-------------------------- +simplJoinBind :: RecFlag + -> SimplCont + -> (InId, SimplEnv) -- InBinder, with static env for its unfolding + -> (OutId, SimplEnv) -- OutBinder; SimplEnv has the binder in scope + -- The OutId has IdInfo, except arity, unfolding + -> (InExpr, SimplEnv) -- The right hand side and its env + -> SimplM (SimplFloats, SimplEnv) +simplJoinBind is_rec cont (old_bndr, unf_se) (new_bndr, env) (rhs, rhs_se) + = do { let rhs_env = rhs_se `setInScopeFromE` env + ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont + ; completeBind (BC_Join is_rec cont) (old_bndr, unf_se) (new_bndr, rhs', env) } + +-------------------------- +simplAuxBind :: String + -> SimplEnv + -> InId -- Old binder; not a JoinId + -> OutExpr -- Simplified RHS + -> SimplM (SimplFloats, SimplEnv) +-- A specialised variant of completeBindX used to construct non-recursive +-- auxiliary bindings, notably in knownCon. +-- +-- The binder comes from a case expression (case binder or alternative) +-- and so does not have rules, unfolding, inline pragmas etc. +-- +-- Precondition: rhs satisfies the let-can-float invariant + +simplAuxBind _str env bndr new_rhs + | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $ + isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } + = return (emptyFloats env, env) -- Here c is dead, and we avoid + -- creating the binding c = (a,b) + + -- Next we have a fast-path for cases that would be inlined unconditionally by + -- completeBind: but it seems not uncommon, and it turns to be a little more + -- efficient (in compile time allocations) to do it here. + -- Effectively this is just a vastly-simplified postInlineUnconditionally + -- See Note [Post-inline for single-use things] in GHC.Core.Opt.Simplify.Utils + -- We could instead use postInlineUnconditionally itself, but I think it's simpler + -- and more direct to focus on the "hot" cases. + -- e.g. auxiliary bindings have no NOLINE pragmas, RULEs, or stable unfoldings + | exprIsTrivial new_rhs -- Short-cut for let x = y in ... + || case (idOccInfo bndr) of + OneOcc{ occ_n_br = 1, occ_in_lam = NotInsideLam } -> True + _ -> False + = return ( emptyFloats env + , extendCvIdSubst env bndr new_rhs ) -- bndr can be a CoVar + + | otherwise + = do { -- ANF-ise the RHS + let !occ_fs = getOccFS bndr + ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs + ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet) + ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats + + -- Simplify the binder and complete the binding + ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr + ; (bind_float, env2) <- completeBind (BC_Let NotTopLevel NonRecursive) + (bndr,env) (new_bndr, rhs1, env1) + + ; return (rhs_floats `addFloats` bind_float, env2) } + + +{- ********************************************************************* +* * + Cast worker/wrapper +* * +************************************************************************ + +Note [Cast worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have a binding + x = e |> co +we want to do something very similar to worker/wrapper: + $wx = e + x = $wx |> co + +We call this making a cast worker/wrapper in tryCastWorkerWrapper. + +The main motivaiton is that x can be inlined freely. There's a chance +that e will be a constructor application or function, or something +like that, so moving the coercion to the usage site may well cancel +the coercions and lead to further optimisation. Example: + + data family T a :: * + data instance T Int = T Int + + foo :: Int -> Int -> Int + foo m n = ... + where + t = T m + go 0 = 0 + go n = case t of { T m -> go (n-m) } + -- This case should optimise + +A second reason for doing cast worker/wrapper is that the worker/wrapper +pass after strictness analysis can't deal with RHSs like + f = (\ a b c. blah) |> co +Instead, it relies on cast worker/wrapper to get rid of the cast, +leaving a simpler job for demand-analysis worker/wrapper. See #19874. + +Wrinkles + +1. We must /not/ do cast w/w on + f = g |> co + otherwise it'll just keep repeating forever! You might think this + is avoided because the call to tryCastWorkerWrapper is guarded by + preInlineUnconditinally, but I'm worried that a loop-breaker or an + exported Id might say False to preInlineUnonditionally. + +2. We need to be careful with inline/noinline pragmas: + rec { {-# NOINLINE f #-} + f = (...g...) |> co + ; g = ...f... } + This is legitimate -- it tells GHC to use f as the loop breaker + rather than g. Now we do the cast thing, to get something like + rec { $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + Where should the NOINLINE pragma go? If we leave it on f we'll get + rec { $wf = ...g... + ; {-# NOINLINE f #-} + f = $wf |> co + ; g = ...f... } + and that is bad: the whole point is that we want to inline that + cast! We want to transfer the pagma to $wf: + rec { {-# NOINLINE $wf #-} + $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + +3. We should still do cast w/w even if `f` is INLINEABLE. E.g. + {- f: Stable unfolding = -} + f = (\xy. ) |> co + Then we want to w/w to + {- $wf: Stable unfolding = |> sym co -} + $wf = \xy. + f = $wf |> co + Notice that the stable unfolding moves to the worker! Now demand analysis + will work fine on $wf, whereas it has trouble with the original f. + c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap. + This point also applies to strong loopbreakers with INLINE pragmas, see + wrinkle (4). + +4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence + hasInlineUnfolding in tryCastWorkerWrapper, which responds False to + loop-breakers) because they'll definitely be inlined anyway, cast and + all. And if we do cast w/w for an INLINE function with arity zero, we get + something really silly: we inline that "worker" right back into the wrapper! + Worse than a no-op, because we have then lost the stable unfolding. + +All these wrinkles are exactly like worker/wrapper for strictness analysis: + f is the wrapper and must inline like crazy + $wf is the worker and must carry f's original pragma +See Note [Worker/wrapper for INLINABLE functions] +and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + +See #17673, #18093, #18078, #19890. + +Note [Preserve strictness in cast w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the Note [Cast worker/wrapper] transformation, keep the strictness info. +Eg + f = e `cast` co -- f has strictness SSL +When we transform to + f' = e -- f' also has strictness SSL + f = f' `cast` co -- f still has strictness SSL + +Its not wrong to drop it on the floor, but better to keep it. + +Note [Preserve RuntimeRep info in cast w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must not do cast w/w when the presence of the coercion is needed in order +to determine the runtime representation. + +Example: + + Suppose we have a type family: + + type F :: RuntimeRep + type family F where + F = LiftedRep + + together with a type `ty :: TYPE F` and a top-level binding + + a :: ty |> TYPE F[0] + + The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding. + However, were we to apply cast w/w, we would get: + + b :: ty + b = ... + + a :: ty |> TYPE F[0] + a = b `cast` GRefl (TYPE F[0]) + + Now we are in trouble because `ty :: TYPE F` does not have a known runtime + representation, because we need to be able to reduce the nullary type family + application `F` to find that out. + +Conclusion: only do cast w/w when doing so would not lose the RuntimeRep +information. That is, when handling `Cast rhs co`, don't attempt cast w/w +unless the kind of the type of rhs is concrete, in the sense of +Note [Concrete types] in GHC.Tc.Utils.Concrete. +-} + +tryCastWorkerWrapper :: SimplEnv -> BindContext + -> InId -> OutId -> OutExpr + -> SimplM (SimplFloats, SimplEnv) +-- See Note [Cast worker/wrapper] +tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co) + | BC_Let top_lvl is_rec <- bind_cxt -- Not join points + , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform + -- a DFunUnfolding in mk_worker_unfolding + , not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1 + , not (hasInlineUnfolding info) -- Not INLINE things: Wrinkle 4 + , typeHasFixedRuntimeRep work_ty -- Don't peel off a cast if doing so would + -- lose the underlying runtime representation. + -- See Note [Preserve RuntimeRep info in cast w/w] + , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings + -- See Note [OPAQUE pragma] + = do { uniq <- getUniqueM + ; let work_name = mkSystemVarName uniq occ_fs + work_id = mkLocalIdWithInfo work_name ManyTy work_ty work_info + is_strict = isStrictId bndr + + ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict + work_id (emptyFloats env) rhs + + ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs + ; let work_id_w_unf = work_id `setIdUnfolding` work_unf + floats = rhs_floats `addLetFloats` + unitLetFloat (NonRec work_id_w_unf work_rhs) + + triv_rhs = Cast (Var work_id_w_unf) co + + ; if postInlineUnconditionally env bind_cxt old_bndr bndr triv_rhs + -- Almost always True, because the RHS is trivial + -- In that case we want to eliminate the binding fast + -- We conservatively use postInlineUnconditionally so that we + -- check all the right things + then do { tick (PostInlineUnconditionally bndr) + ; return ( floats + , extendIdSubst (setInScopeFromF env floats) old_bndr $ + DoneEx triv_rhs NotJoinPoint ) } + + else do { wrap_unf <- mkLetUnfolding env top_lvl VanillaSrc bndr False triv_rhs + ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr) + `setIdUnfolding` wrap_unf + floats' = floats `extendFloats` NonRec bndr' triv_rhs + ; return ( floats', setInScopeFromF env floats' ) } } + where + -- Force the occ_fs so that the old Id is not retained in the new Id. + !occ_fs = getOccFS bndr + work_ty = coercionLKind co + info = idInfo bndr + work_arity = arityInfo info `min` typeArity work_ty + + work_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info + `setCprSigInfo` cprSigInfo info + `setDemandInfo` demandInfo info + `setInlinePragInfo` inlinePragInfo info + `setArityInfo` work_arity + -- We do /not/ want to transfer OccInfo, Rules + -- Note [Preserve strictness in cast w/w] + -- and Wrinkle 2 of Note [Cast worker/wrapper] + + ----------- Worker unfolding ----------- + -- Stable case: if there is a stable unfolding we have to compose with (Sym co); + -- the next round of simplification will do the job + -- Non-stable case: use work_rhs + -- Wrinkle 3 of Note [Cast worker/wrapper] + mk_worker_unfolding top_lvl work_id work_rhs + = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) }) + _ -> mkLetUnfolding env top_lvl VanillaSrc work_id False work_rhs + +tryCastWorkerWrapper env _ _ bndr rhs -- All other bindings + = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr + , text "rhs:" <+> ppr rhs ]) + ; return (mkFloatBind env (NonRec bndr rhs)) } + +mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma +-- See Note [Cast worker/wrapper] +mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info }) + = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" + , inl_inline = fn_inl -- See Note [Worker/wrapper for INLINABLE functions] + , inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap + , inl_act = wrap_act -- See Note [Wrapper activation] + , inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap + -- RuleMatchInfo is (and must be) unaffected + where + -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap + -- But simpler, because we don't need to disable during InitialPhase + wrap_act | isNeverActive fn_act = activateDuringFinal + | otherwise = fn_act + + +{- ********************************************************************* +* * + prepareBinding, prepareRhs, makeTrivial +* * +********************************************************************* -} + +prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool + -> Id -- Used only for its OccName; can be InId or OutId + -> SimplFloats -> OutExpr + -> SimplM (SimplFloats, OutExpr) +-- In (prepareBinding ... bndr floats rhs), the binding is really just +-- bndr = let floats in rhs +-- Maybe we can ANF-ise this binding and float out; e.g. +-- bndr = let a = f x in K a a (g x) +-- we could float out to give +-- a = f x +-- tmp = g x +-- bndr = K a a tmp +-- That's what prepareBinding does +-- Precondition: binder is not a JoinId +-- Postcondition: the returned SimplFloats contains only let-floats +prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs + = do { -- Never float join-floats out of a non-join let-binding (which this is) + -- So wrap the body in the join-floats right now + -- Hence: rhs_floats1 consists only of let-floats + let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs + + -- rhs_env: add to in-scope set the binders from rhs_floats + -- so that prepareRhs knows what is in scope in rhs + ; let rhs_env = env `setInScopeFromF` rhs_floats1 + -- Force the occ_fs so that the old Id is not retained in the new Id. + !occ_fs = getOccFS bndr + + -- Now ANF-ise the remaining rhs + ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl occ_fs rhs1 + + -- Finally, decide whether or not to float + ; let all_floats = rhs_floats1 `addLetFloats` anf_floats + ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2 + then -- Float! + do { tick LetFloatFromLet + ; return (all_floats, rhs2) } + + else -- Abandon floating altogether; revert to original rhs + -- Since we have already built rhs1, we just need to add + -- rhs_floats1 to it + return (emptyFloats env, wrapFloats rhs_floats1 rhs1) } + +{- Note [prepareRhs] +~~~~~~~~~~~~~~~~~~~~ +prepareRhs takes a putative RHS, checks whether it's a PAP or +constructor application and, if so, converts it to ANF, so that the +resulting thing can be inlined more easily. Thus + x = (f a, g b) +becomes + t1 = f a + t2 = g b + x = (t1,t2) + +We also want to deal well cases like this + v = (f e1 `cast` co) e2 +Here we want to make e1,e2 trivial and get + x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 +That's what the 'go' loop in prepareRhs does +-} + +prepareRhs :: HasDebugCallStack + => SimplEnv -> TopLevelFlag + -> FastString -- Base for any new variables + -> OutExpr + -> SimplM (LetFloats, OutExpr) +-- Transforms a RHS into a better RHS by ANF'ing args +-- for expandable RHSs: constructors and PAPs +-- e.g x = Just e +-- becomes a = e -- 'a' is fresh +-- x = Just a +-- See Note [prepareRhs] +prepareRhs env top_lvl occ rhs0 + | is_expandable = anfise rhs0 + | otherwise = return (emptyLetFloats, rhs0) + where + -- We can't use exprIsExpandable because the WHOLE POINT is that + -- we want to treat (K ) as expandable, because we are just + -- about "anfise" the expression. exprIsExpandable would + -- just say no! + is_expandable = go rhs0 0 + where + go (Var fun) n_val_args = isExpandableApp fun n_val_args + go (App fun arg) n_val_args + | isTypeArg arg = go fun n_val_args + | otherwise = go fun (n_val_args + 1) + go (Cast rhs _) n_val_args = go rhs n_val_args + go (Tick _ rhs) n_val_args = go rhs n_val_args + go _ _ = False + + anfise :: OutExpr -> SimplM (LetFloats, OutExpr) + anfise (Cast rhs co) + = do { (floats, rhs') <- anfise rhs + ; return (floats, Cast rhs' co) } + anfise (App fun (Type ty)) + = do { (floats, rhs') <- anfise fun + ; return (floats, App rhs' (Type ty)) } + anfise (App fun arg) + = do { (floats1, fun') <- anfise fun + ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg + ; return (floats1 `addLetFlts` floats2, App fun' arg') } + anfise (Var fun) + = return (emptyLetFloats, Var fun) + + anfise (Tick t rhs) + -- We want to be able to float bindings past this + -- tick. Non-scoping ticks don't care. + | tickishScoped t == NoScope + = do { (floats, rhs') <- anfise rhs + ; return (floats, Tick t rhs') } + + -- On the other hand, for scoping ticks we need to be able to + -- copy them on the floats, which in turn is only allowed if + -- we can obtain non-counting ticks. + | (not (tickishCounts t) || tickishCanSplit t) + = do { (floats, rhs') <- anfise rhs + ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) + floats' = mapLetFloats floats tickIt + ; return (floats', Tick t rhs') } + + anfise other = return (emptyLetFloats, other) + +makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec) +makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd }) + = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e + ; return (floats, arg { as_arg = e' }) } +makeTrivialArg _ arg@(TyArg {}) + = return (emptyLetFloats, arg) + +makeTrivial :: HasDebugCallStack + => SimplEnv -> TopLevelFlag -> Demand + -> FastString -- ^ A "friendly name" to build the new binder from + -> OutExpr + -> SimplM (LetFloats, OutExpr) +-- Binds the expression to a variable, if it's not trivial, returning the variable +-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] +makeTrivial env top_lvl dmd occ_fs expr + | exprIsTrivial expr -- Already trivial + || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] + = return (emptyLetFloats, expr) + + | Cast expr' co <- expr + = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr' + ; return (floats, Cast triv_expr co) } + + | otherwise -- 'expr' is not of form (Cast e co) + = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr + ; uniq <- getUniqueM + ; let name = mkSystemVarName uniq occ_fs + var = mkLocalIdWithInfo name ManyTy expr_ty id_info + + -- Now something very like completeBind, + -- but without the postInlineUnconditionally part + ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1 + -- Technically we should extend the in-scope set in 'env' with + -- the 'floats' from prepareRHS; but they are all fresh, so there is + -- no danger of introducing name shadowing in eta expansion + + ; unf <- mkLetUnfolding env top_lvl VanillaSrc var False expr2 + + ; let final_id = addLetBndrInfo var arity_type unf + bind = NonRec final_id expr2 + + ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ]) + ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) } + where + id_info = vanillaIdInfo `setDemandInfo` dmd + expr_ty = exprType expr + +bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +-- True iff we can have a binding of this expression at this level +-- Precondition: the type is the type of the expression +bindingOk top_lvl expr expr_ty + | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty + | otherwise = True + +{- Note [Cannot trivialise] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + f :: Int -> Addr# + + foo :: Bar + foo = Bar (f 3) + +Then we can't ANF-ise foo, even though we'd like to, because +we can't make a top-level binding for the Addr# (f 3). And if +so we don't want to turn it into + foo = let x = f 3 in Bar x +because we'll just end up inlining x back, and that makes the +simplifier loop. Better not to ANF-ise it at all. + +Literal strings are an exception. + + foo = Ptr "blob"# + +We want to turn this into: + + foo1 = "blob"# + foo = Ptr foo1 + +See Note [Core top-level string literals] in GHC.Core. + +************************************************************************ +* * + Completing a lazy binding +* * +************************************************************************ + +completeBind + * deals only with Ids, not TyVars + * takes an already-simplified binder and RHS + * is used for both recursive and non-recursive bindings + * is used for both top-level and non-top-level bindings + +It does the following: + - tries discarding a dead binding + - tries PostInlineUnconditionally + - add unfolding [this is the only place we add an unfolding] + - add arity + - extend the InScopeSet of the SimplEnv + +It does *not* attempt to do let-to-case. Why? Because it is used for + - top-level bindings (when let-to-case is impossible) + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). + +Nor does it do the atomic-argument thing +-} + +completeBind :: BindContext + -> (InId, SimplEnv) -- Old binder, and the static envt in which to simplify + -- its stable unfolding (if any) + -> (OutId, OutExpr, SimplEnv) -- New binder and rhs; can be a JoinId. + -- And the SimplEnv with that OutId in scope. + -> SimplM (SimplFloats, SimplEnv) +-- completeBind may choose to do its work +-- * by extending the substitution (e.g. let x = y in ...) +-- * or by adding to the floats in the envt +-- +-- Binder /can/ be a JoinId +-- Precondition: rhs obeys the let-can-float invariant +completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env) + | isCoVar old_bndr + = case new_rhs of + Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) + _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) + + | otherwise + = assert (isId new_bndr) $ + do { let old_info = idInfo old_bndr + old_unf = realUnfoldingInfo old_info + + -- Do eta-expansion on the RHS of the binding + -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils + ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs + + -- Simplify the unfolding; see Note [Environment for simplLetUnfolding] + ; new_unfolding <- simplLetUnfolding (unf_se `setInScopeFromE` env) + bind_cxt old_bndr + eta_rhs (idType new_bndr) new_arity old_unf + + ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding + -- See Note [In-scope set as a substitution] + + ; if postInlineUnconditionally env bind_cxt old_bndr new_bndr_w_info eta_rhs + + then -- Inline and discard the binding + do { tick (PostInlineUnconditionally old_bndr) + ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs + -- See Note [Use occ-anald RHS in postInlineUnconditionally] + ; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $ + return ( emptyFloats env + , extendIdSubst env old_bndr $ + DoneEx unf_rhs (idJoinPointHood new_bndr)) } + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding + + else -- Keep the binding; do cast worker/wrapper +-- simplTrace "completeBind" (vcat [ text "bndrs" <+> ppr old_bndr <+> ppr new_bndr +-- , text "eta_rhs" <+> ppr eta_rhs ]) $ + tryCastWorkerWrapper env bind_cxt old_bndr new_bndr_w_info eta_rhs } + +addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId +addLetBndrInfo new_bndr new_arity_type new_unf + = new_bndr `setIdInfo` info5 + where + new_arity = arityTypeArity new_arity_type + info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unf + + -- Demand info: Note [Setting the demand info] + info3 | isEvaldUnfolding new_unf + = lazifyDemandInfo info2 `orElse` info2 + | otherwise + = info2 + + -- Bottoming bindings: see Note [Bottoming bindings] + info4 = case arityTypeBotSigs_maybe new_arity_type of + Nothing -> info3 + Just (ar, str_sig, cpr_sig) -> assert (ar == new_arity) $ + info3 `setDmdSigInfo` str_sig + `setCprSigInfo` cpr_sig + + -- Zap call arity info. We have used it by now (via + -- `tryEtaExpandRhs`), and the simplifier can invalidate this + -- information, leading to broken code later (e.g. #13479) + info5 = zapCallArityInfo info4 + + +{- Note [Bottoming bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + let x = error "urk" + in ...(case x of )... +or + let f = \y. error (y ++ "urk") + in ...(case f "foo" of )... + +Then we'd like to drop the dead immediately. So it's good to +propagate the info that x's (or f's) RHS is bottom to x's (or f's) +IdInfo as rapidly as possible. + +We use tryEtaExpandRhs on every binding, and it turns out that the +arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already +does a simple bottoming-expression analysis. So all we need to do +is propagate that info to the binder's IdInfo. + +This showed up in #12150; see comment:16. + +There is a second reason for settting the strictness signature. Consider + let -- f :: <[S]b> + f = \x. error "urk" + in ...(f a b c)... +Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f` +to eta-expand to + let f = \x y z. error "urk" + in ...(f a b c)... + +But now f's strictness signature has too short an arity; see +GHC.Core.Opt.DmdAnal Note [idArity varies independently of dmdTypeDepth]. +Fortuitously, the same strictness-signature-fixup code +gives the function a new strictness signature with the right number of +arguments. Example in stranal/should_compile/EtaExpansion. + +Note [Setting the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the unfolding is a value, the demand info may +go pear-shaped, so we nuke it. Example: + let x = (a,b) in + case x of (p,q) -> h p q x +Here x is certainly demanded. But after we've nuked +the case, we'll get just + let x = (a,b) in h a b x +and now x is not demanded (I'm assuming h is lazy) +This really happens. Similarly + let f = \x -> e in ...f..f... +After inlining f at some of its call sites the original binding may +(for example) be no longer strictly demanded. +The solution here is a bit ad hoc... + +Note [Use occ-anald RHS in postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we postInlineUnconditionally 'f in + let f = \x -> x True in ...(f blah)... +then we'd like to inline the /occ-anald/ RHS for 'f'. If we +use the non-occ-anald version, we'll end up with a + ...(let x = blah in x True)... +and hence an extra Simplifier iteration. + +We already /have/ the occ-anald version in the Unfolding for +the Id. Well, maybe not /quite/ always. If the binder is Dead, +postInlineUnconditionally will return True, but we may not have an +unfolding because it's too big. Hence the belt-and-braces `orElse` +in the defn of unf_rhs. The Nothing case probably never happens. + +Note [Environment for simplLetUnfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to be rather careful about the static environment in which +we simplify a stable unfolding. Consider (#24242): + + f x = let y_Xb = ... in + let step1_Xb {Stable unfolding = ....y_Xb...} = rhs in + ... + +Note that `y_Xb` and `step1_Xb` have the same unique (`Xb`). This can happen; +see Note [Shadowing in Core] in GHC.Core, and Note [Shadowing in the Simplifier]. +This is perfectly fine. The `y_Xb` in the stable unfolding of the non- +recursive binding for `step1` refers, of course, to `let y_Xb = ....`. +When simplifying the binder `step1_Xb` we'll give it a new unique, and +extend the static environment with [Xb :-> step1_Xc], say. + +But when simplifying step1's stable unfolding, we must use static environment +/before/ simplifying the binder `step1_Xb`; that is, a static envt that maps +[Xb :-> y_Xb], /not/ [Xb :-> step1_Xc]. + +That is why we pass around a pair `(InId, SimplEnv)` for the binder, keeping +track of the right environment for the unfolding of that InId. See the type +of `simplLazyBind`, `simplJoinBind`, `completeBind`. + +This only matters when we have + - A non-recursive binding for f + - has a stable unfolding + - and that unfolding mentions a variable y + - that has the same unique as f. +So triggering a bug here is really hard! + +************************************************************************ +* * +\subsection[Simplify-simplExpr]{The main function: simplExpr} +* * +************************************************************************ + +The reason for this OutExprStuff stuff is that we want to float *after* +simplifying a RHS, not before. If we do so naively we get quadratic +behaviour as things float out. + +To see why it's important to do it after, consider this (real) example: + + let t = f x + in fst t +==> + let t = let a = e1 + b = e2 + in (a,b) + in fst t +==> + let a = e1 + b = e2 + t = (a,b) + in + a -- Can't inline a this round, cos it appears twice +==> + e1 + +Each of the ==> steps is a round of simplification. We'd save a +whole round if we float first. This can cascade. Consider + + let f = g d + in \x -> ...f... +==> + let f = let d1 = ..d.. in \y -> e + in \x -> ...f... +==> + let d1 = ..d.. + in \x -> ...(\y ->e)... + +Only in this second round can the \y be applied, and it +might do the same again. +-} + +simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr +simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier] + = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] + ; return (Type ty') } + +simplExpr env expr + = simplExprC env expr (mkBoringStop expr_out_ty) + where + expr_out_ty :: OutType + expr_out_ty = substTy env (exprType expr) + -- NB: Since 'expr' is term-valued, not (Type ty), this call + -- to exprType will succeed. exprType fails on (Type ty). + +simplExprC :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM OutExpr + -- Simplify an expression, given a continuation +simplExprC env expr cont + = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $ + do { (floats, expr') <- simplExprF env expr cont + ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ + -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ + -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $ + return (wrapFloats floats expr') } + +-------------------------------------------------- +simplExprF :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF !env e !cont -- See Note [Bangs in the Simplifier] + = -- pprTrace "simplExprF" (vcat + -- [ ppr e + -- , text "cont =" <+> ppr cont + -- , text "inscope =" <+> ppr (seInScope env) + -- , text "tvsubst =" <+> ppr (seTvSubst env) + -- , text "idsubst =" <+> ppr (seIdSubst env) + -- , text "cvsubst =" <+> ppr (seCvSubst env) + -- ]) $ + simplExprF1 env e cont + +simplExprF1 :: HasDebugCallStack + => SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF1 _ (Type ty) cont + = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont) + -- simplExprF does only with term-valued expressions + -- The (Type ty) case is handled separately by simplExpr + -- and by the other callers of simplExprF + +simplExprF1 env (Var v) cont = {-#SCC "simplInId" #-} simplInId env v cont +simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont +simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont +simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont +simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont + +simplExprF1 env (App fun arg) cont + = {-#SCC "simplExprF1-App" #-} case arg of + Type ty -> do { -- The argument type will (almost) certainly be used + -- in the output program, so just force it now. + -- See Note [Avoiding space leaks in OutType] + arg' <- simplType env ty + + -- But use substTy, not simplType, to avoid forcing + -- the hole type; it will likely not be needed. + -- See Note [The hole type in ApplyToTy] + ; let hole' = substTy env (exprType fun) + + ; simplExprF env fun $ + ApplyToTy { sc_arg_ty = arg' + , sc_hole_ty = hole' + , sc_cont = cont } } + _ -> + -- Crucially, sc_hole_ty is a /lazy/ binding. It will + -- be forced only if we need to run contHoleType. + -- When these are forced, we might get quadratic behavior; + -- this quadratic blowup could be avoided by drilling down + -- to the function and getting its multiplicities all at once + -- (instead of one-at-a-time). But in practice, we have not + -- observed the quadratic behavior, so this extra entanglement + -- seems not worthwhile. + simplExprF env fun $ + ApplyToVal { sc_arg = arg, sc_env = env + , sc_hole_ty = substTy env (exprType fun) + , sc_dup = NoDup, sc_cont = cont } + +simplExprF1 env expr@(Lam {}) cont + = {-#SCC "simplExprF1-Lam" #-} + simplLam env (zapLambdaBndrs expr n_args) cont + -- zapLambdaBndrs: the issue here is under-saturated lambdas + -- (\x1. \x2. e) arg1 + -- Here x1 might have "occurs-once" occ-info, because occ-info + -- is computed assuming that a group of lambdas is applied + -- all at once. If there are too few args, we must zap the + -- occ-info, UNLESS the remaining binders are one-shot + where + n_args = countArgs cont + -- NB: countArgs counts all the args (incl type args) + -- and likewise drop counts all binders (incl type lambdas) + +simplExprF1 env (Case scrut bndr _ alts) cont + = {-#SCC "simplExprF1-Case" #-} + simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr + , sc_alts = alts + , sc_env = env, sc_cont = cont }) + +simplExprF1 env (Let (Rec pairs) body) cont + | Just pairs' <- joinPointBindings_maybe pairs + = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont + + | otherwise + = {-#SCC "simplRecE" #-} simplRecE env pairs body cont + +simplExprF1 env (Let (NonRec bndr rhs) body) cont + | Type ty <- rhs -- First deal with type lets (let a = Type ty in e) + = {-#SCC "simplExprF1-NonRecLet-Type" #-} + assert (isTyVar bndr) $ + do { ty' <- simplType env ty + ; simplExprF (extendTvSubst env bndr ty') body cont } + + | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env + -- Because of the let-can-float invariant, it's ok to + -- inline freely, or to drop the binding if it is dead. + = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $ + tick (PreInlineUnconditionally bndr) + ; simplExprF env' body cont } + + -- Now check for a join point. It's better to do the preInlineUnconditionally + -- test first, because joinPointBinding_maybe has to eta-expand, so a trivial + -- binding like { j = j2 |> co } would first be eta-expanded and then inlined + -- Better to test preInlineUnconditionally first. + | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs + = {-#SCC "simplNonRecJoinPoint" #-} + simplNonRecJoinPoint env bndr' rhs' body cont + + | otherwise + = {-#SCC "simplNonRecE" #-} + simplNonRecE env FromLet bndr (rhs, env) body cont + +{- Note [Avoiding space leaks in OutType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the simplifier is run for multiple iterations, we need to ensure +that any thunks in the output of one simplifier iteration are forced +by the evaluation of the next simplifier iteration. Otherwise we may +retain multiple copies of the Core program and leak a terrible amount +of memory (as in #13426). + +The simplifier is naturally strict in the entire "Expr part" of the +input Core program, because any expression may contain binders, which +we must find in order to extend the SimplEnv accordingly. But types +do not contain binders and so it is tempting to write things like + + simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! + +This is Bad because the result includes a thunk (substTy env ty) which +retains a reference to the whole simplifier environment; and the next +simplifier iteration will not force this thunk either, because the +line above is not strict in ty. + +So instead our strategy is for the simplifier to fully evaluate +OutTypes when it emits them into the output Core program, for example + + simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good + ; return (Type ty') } + +where the only difference from above is that simplType calls seqType +on the result of substTy. + +However, SimplCont can also contain OutTypes and it's not necessarily +a good idea to force types on the way in to SimplCont, because they +may end up not being used and forcing them could be a lot of wasted +work. T5631 is a good example of this. + +- For ApplyToTy's sc_arg_ty, we force the type on the way in because + the type will almost certainly appear as a type argument in the + output program. + +- For the hole types in Stop and ApplyToTy, we force the type when we + emit it into the output program, after obtaining it from + contResultType. (The hole type in ApplyToTy is only directly used + to form the result type in a new Stop continuation.) +-} + +--------------------------------- +-- Simplify a join point, adding the context. +-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: +-- \x1 .. xn -> e => \x1 .. xn -> E[e] +-- Note that we need the arity of the join point, since e may be a lambda +-- (though this is unlikely). See Note [Join points and case-of-case]. +simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont + -> SimplM OutExpr +simplJoinRhs env bndr expr cont + | JoinPoint arity <- idJoinPointHood bndr + = do { let (join_bndrs, join_body) = collectNBinders arity expr + mult = contHoleScaling cont + ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs) + ; join_body' <- simplExprC env' join_body cont + ; return $ mkLams join_bndrs' join_body' } + + | otherwise + = pprPanic "simplJoinRhs" (ppr bndr) + +--------------------------------- +simplType :: SimplEnv -> InType -> SimplM OutType + -- Kept monadic just so we can do the seqType + -- See Note [Avoiding space leaks in OutType] +simplType env ty + = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ + seqType new_ty `seq` return new_ty + where + new_ty = substTy env ty + +--------------------------------- +simplCoercionF :: SimplEnv -> InCoercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCoercionF env co cont + = do { co' <- simplCoercion env co + ; rebuild env (Coercion co') cont } + +simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion +simplCoercion env co + = do { let opt_co | reSimplifying env = substCo env co + | otherwise = optCoercion opts subst co + -- If (reSimplifying env) is True we have already simplified + -- this coercion once, and we don't want do so again; doing + -- so repeatedly risks non-linear behaviour + -- See Note [Inline depth] in GHC.Core.Opt.Simplify.Env + ; seqCo opt_co `seq` return opt_co } + where + subst = getTCvSubst env + opts = seOptCoercionOpts env + +----------------------------------- +-- | Push a TickIt context outwards past applications and cases, as +-- long as this is a non-scoping tick, to let case and application +-- optimisations apply. + +simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplTick env tickish expr cont + -- A scoped tick turns into a continuation, so that we can spot + -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do + -- it this way, then it would take two passes of the simplifier to + -- reduce ((scc t (\x . e)) e'). + -- NB, don't do this with counting ticks, because if the expr is + -- bottom, then rebuildCall will discard the continuation. + +-------------------------- +-- | tickishScoped tickish && not (tickishCounts tickish) +-- = simplExprF env expr (TickIt tickish cont) +-- XXX: we cannot do this, because the simplifier assumes that +-- the context can be pushed into a case with a single branch. e.g. +-- scc case expensive of p -> e +-- becomes +-- case expensive of p -> scc e +-- +-- So I'm disabling this for now. It just means we will do more +-- simplifier iterations that necessary in some cases. +-------------------------- + + -- For unscoped or soft-scoped ticks, we are allowed to float in new + -- cost, so we simply push the continuation inside the tick. This + -- has the effect of moving the tick to the outside of a case or + -- application context, allowing the normal case and application + -- optimisations to fire. + | tickish `tickishScopesLike` SoftScope + = do { (floats, expr') <- simplExprF env expr cont + ; return (floats, mkTick tickish expr') + } + + -- Push tick inside if the context looks like this will allow us to + -- do a case-of-case - see Note [case-of-scc-of-case] + | Select {} <- cont, Just expr' <- push_tick_inside + = simplExprF env expr' cont + + -- We don't want to move the tick, but we might still want to allow + -- floats to pass through with appropriate wrapping (or not, see + -- wrap_floats below) + --- | not (tickishCounts tickish) || tickishCanSplit tickish + -- = wrap_floats + + | otherwise + = no_floating_past_tick + + where + + -- Try to push tick inside a case, see Note [case-of-scc-of-case]. + push_tick_inside = + case expr0 of + Case scrut bndr ty alts + -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) + _other -> Nothing + where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) + movable t = not (tickishCounts t) || + t `tickishScopesLike` NoScope || + tickishCanSplit t + tickScrut e = foldr mkTick e ticks + -- Alternatives get annotated with all ticks that scope in some way, + -- but we don't want to count entries. + tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope) + ts_scope = map mkNoCount $ + filter (not . (`tickishScopesLike` NoScope)) ticks + + no_floating_past_tick = + do { let (inc,outc) = splitCont cont + ; (floats, expr1) <- simplExprF env expr inc + ; let expr2 = wrapFloats floats expr1 + tickish' = simplTickish env tickish + ; rebuild env (mkTick tickish' expr2) outc + } + +-- Alternative version that wraps outgoing floats with the tick. This +-- results in ticks being duplicated, as we don't make any attempt to +-- eliminate the tick if we re-inline the binding (because the tick +-- semantics allows unrestricted inlining of HNFs), so I'm not doing +-- this any more. FloatOut will catch any real opportunities for +-- floating. +-- +-- wrap_floats = +-- do { let (inc,outc) = splitCont cont +-- ; (env', expr') <- simplExprF (zapFloats env) expr inc +-- ; let tickish' = simplTickish env tickish +-- ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0), +-- mkTick (mkNoCount tickish') rhs) +-- -- when wrapping a float with mkTick, we better zap the Id's +-- -- strictness info and arity, because it might be wrong now. +-- ; let env'' = addFloats env (mapFloats env' wrap_float) +-- ; rebuild env'' expr' (TickIt tickish' outc) +-- } + + + simplTickish env tickish + | Breakpoint ext bid ids <- tickish + = Breakpoint ext bid (mapMaybe (getDoneId . substId env) ids) + | otherwise = tickish + + -- Push type application and coercion inside a tick + splitCont :: SimplCont -> (SimplCont, SimplCont) + splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) + where (inc,outc) = splitCont tail + splitCont cont@(CastIt { sc_cont = tail }) = (cont { sc_cont = inc }, outc) + where (inc,outc) = splitCont tail + splitCont other = (mkBoringStop (contHoleType other), other) + + getDoneId (DoneId id) = Just id + getDoneId (DoneEx (Var id) _) = Just id + getDoneId (DoneEx e _) = getIdFromTrivialExpr_maybe e -- Note [substTickish] in GHC.Core.Subst + getDoneId other = pprPanic "getDoneId" (ppr other) + +-- Note [case-of-scc-of-case] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- It's pretty important to be able to transform case-of-case when +-- there's an SCC in the way. For example, the following comes up +-- in nofib/real/compress/Encode.hs: +-- +-- case scctick +-- 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 +-- (ww_s12Y, +-- ww1_s12Z, +-- PTTrees.PT +-- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) +-- } +-- +-- We really want this case-of-case to fire, because then the 3-tuple +-- will go away (indeed, the CPR optimisation is relying on this +-- happening). But the scctick is in the way - we need to push it +-- inside to expose the case-of-case. So we perform this +-- transformation on the inner case: +-- +-- scctick c (case e of { p1 -> e1; ...; pn -> en }) +-- ==> +-- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } +-- +-- So we've moved a constant amount of work out of the scc to expose +-- the case. We only do this when the continuation is interesting: in +-- for now, it has to be another Case (maybe generalise this later). + +{- +************************************************************************ +* * +\subsection{The main rebuilder} +* * +************************************************************************ +-} + +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) +rebuild env expr cont = rebuild_go (zapSubstEnv env) expr cont + +rebuild_go :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) +-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant; +-- only the in-scope set matters, plus the flags. +rebuild_go env expr cont + = assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) $ + case cont of + Stop {} -> return (emptyFloats env, expr) + TickIt t cont -> rebuild_go env (mkTick t expr) cont + CastIt { sc_co = co, sc_opt = opt, sc_cont = cont } + -> rebuild_go env (mkCast expr co') cont + -- NB: mkCast implements the (Coercion co |> g) optimisation + where + co' = optOutCoercion env co opt + + Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } + -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont + + StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } + -> rebuildCall env (addValArgTo fun expr fun_ty) cont + + StrictBind { sc_bndr = b, sc_body = body, sc_env = se + , sc_cont = cont, sc_from = from_what } + -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont + + ApplyToTy { sc_arg_ty = ty, sc_cont = cont} + -> rebuild_go env (App expr (Type ty)) cont + + ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag + , sc_cont = cont, sc_hole_ty = fun_ty } + -- See Note [Avoid redundant simplification] + -> do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty Nothing se arg + ; rebuild_go env (App expr arg') cont } + +completeBindX :: SimplEnv + -> FromWhat + -> InId -> OutExpr -- Non-recursively bind this Id to this (simplified) expression + -- (the let-can-float invariant may not be satisfied) + -> InExpr -- In this body + -> SimplCont -- Consumed by this continuation + -> SimplM (SimplFloats, OutExpr) +completeBindX env from_what bndr rhs body cont + | FromBeta arg_levity <- from_what + , needsCaseBindingL arg_levity rhs -- Enforcing the let-can-float-invariant + = do { (env1, bndr1) <- simplNonRecBndr env bndr -- Lambda binders don't have rules + ; (floats, expr') <- simplNonRecBody env1 from_what body cont + -- Do not float floats past the Case binder below + ; let expr'' = wrapFloats floats expr' + case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr''] + ; return (emptyFloats env, case_expr) } + + | otherwise -- Make a let-binding + = do { (env1, bndr1) <- simplNonRecBndr env bndr + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) + + ; let is_strict = isStrictId bndr2 + -- isStrictId: use simplified binder because the InId bndr might not have + -- a fixed runtime representation, which isStrictId doesn't expect + -- c.f. Note [Dark corner with representation polymorphism] + + ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict + bndr2 (emptyFloats env) rhs + -- NB: it makes a surprisingly big difference (5% in compiler allocation + -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env', + -- because this is completeBindX, so bndr is not in scope in the RHS. + + ; let env3 = env2 `setInScopeFromF` rhs_floats + ; (bind_float, env4) <- completeBind (BC_Let NotTopLevel NonRecursive) + (bndr,env) (bndr2, rhs1, env3) + -- Must pass env1 to completeBind in case simplBinder had to clone, + -- and extended the substitution with [bndr :-> new_bndr] + + -- Simplify the body + ; (body_floats, body') <- simplNonRecBody env4 from_what body cont + + ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats + ; return ( all_floats, body' ) } + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +{- Note [Optimising reflexivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important (for compiler performance) to get rid of reflexivity as soon +as it appears. See #11735, #14737, and #15019. + +In particular, we want to behave well on + + * e |> co1 |> co2 + where the two happen to cancel out entirely. That is quite common; + e.g. a newtype wrapping and unwrapping cancel. + + + * (f |> co) @t1 @t2 ... @tn x1 .. xm + Here we will use pushCoTyArg and pushCoValArg successively, which + build up SelCo stacks. Silly to do that if co is reflexive. + +However, we don't want to call isReflexiveCo too much, because it uses +type equality which is expensive on big types (#14737 comment:7). + +A good compromise (determined experimentally) seems to be to call +isReflexiveCo + * when composing casts, and + * at the end + +In investigating this I saw missed opportunities for on-the-fly +coercion shrinkage. See #15090. + +Note [Avoid re-simplifying coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In some benchmarks (with deeply nested cases) we successively push +casts onto the SimplCont. We don't want to call the coercion optimiser +on each successive composition -- that's at least quadratic. So: + +* The CastIt constructor in SimplCont has a `sc_opt :: Bool` flag to + record whether the coercion optimiser has been applied to the coercion. + +* In `simplCast`, when we see (Cast e co), we simplify `co` to get + an OutCoercion, and built a CastIt with sc_opt=True. + + Actually not quite: if we are simplifying the result of inlining an + unfolding (seInlineDepth > 0), then instead of /optimising/ it again, + just /substitute/ which is cheaper. See `simplCoercion`. + +* In `addCoerce` (in `simplCast`) if we combine this new coercion with + an existing once, we build a CastIt for (co1 ; co2) with sc_opt=False. + +* When unpacking a CastIt, in `rebuildCall` and `rebuild`, we optimise + the (presumably composed) coercion if sc_opt=False; this is done + by `optOutCoercion`. + +* When duplicating a continuation in `mkDupableContWithDmds`, before + duplicating a CastIt, optimise the coercion. Otherwise we'll end up + optimising it separately in the duplicate copies. +-} + + +optOutCoercion :: SimplEnvIS -> OutCoercion -> Bool -> OutCoercion +-- See Note [Avoid re-simplifying coercions] +optOutCoercion env co already_optimised + | already_optimised = co -- See Note [Avoid re-simplifying coercions] + | otherwise = optCoercion opts empty_subst co + where + empty_subst = mkEmptySubst (seInScope env) + opts = seOptCoercionOpts env + +simplCast :: SimplEnv -> InExpr -> InCoercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCast env body co0 cont0 + = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 + ; cont1 <- {-#SCC "simplCast-addCoerce" #-} + if isReflCo co1 + then return cont0 -- See Note [Optimising reflexivity] + else addCoerce co1 True cont0 + -- True <=> co1 is optimised + ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } + where + + -- If the first parameter is MRefl, then simplifying revealed a + -- reflexive coercion. Omit. + addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont + addCoerceM MRefl _ cont = return cont + addCoerceM (MCo co) opt cont = addCoerce co opt cont + + addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont + addCoerce co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] + = addCoerce (mkTransCo co1 co2) False cont + -- False: (mkTransCo co1 co2) is not fully optimised + -- See Note [Avoid re-simplifying coercions] + + addCoerce co opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + = {-#SCC "addCoerce-pushCoTyArg" #-} + do { tail' <- addCoerceM m_co' opt tail + ; return (ApplyToTy { sc_arg_ty = arg_ty' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } + -- NB! As the cast goes past, the + -- type of the hole changes (#16312) + -- (f |> co) e ===> (f (e |> co1)) |> co2 + -- where co :: (s1->s2) ~ (t1->t2) + -- co1 :: t1 ~ s1 + -- co2 :: s2 ~ t2 + addCoerce co opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup, sc_cont = tail + , sc_hole_ty = fun_ty }) + | not opt -- pushCoValArg duplicates the coercion, so optimise first + = addCoerce (optOutCoercion (zapSubstEnv env) co opt) True cont + + | Just (m_co1, m_co2) <- pushCoValArg co + , fixed_rep m_co1 + = {-#SCC "addCoerce-pushCoValArg" #-} + do { tail' <- addCoerceM m_co2 opt tail + ; case m_co1 of { + MRefl -> return (cont { sc_cont = tail' + , sc_hole_ty = coercionLKind co }) ; + -- See Note [Avoiding simplifying repeatedly] + + MCo co1 -> + do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg + -- When we build the ApplyTo we can't mix the OutCoercion + -- 'co' with the InExpr 'arg', so we simplify + -- to make it all consistent. It's a bit messy. + -- But it isn't a common case. + -- Example of use: #995 + ; return (ApplyToVal { sc_arg = mkCast arg' co1 + , sc_env = arg_se' + , sc_dup = dup' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } } } + + addCoerce co opt cont + | isReflCo co = return cont -- Having this at the end makes a huge + -- difference in T12227, for some reason + -- See Note [Optimising reflexivity] + | otherwise = return (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) + + fixed_rep :: MCoercionR -> Bool + fixed_rep MRefl = True + fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co + -- Without this check, we can get an argument which does not + -- have a fixed runtime representation. + -- See Note [Representation polymorphism invariants] in GHC.Core + -- test: typecheck/should_run/EtaExpandLevPoly + +simplLazyArg :: SimplEnvIS -- ^ Used only for its InScopeSet + -> DupFlag + -> OutType -- ^ Type of the function applied to this arg + -> Maybe ArgInfo -- ^ Just <=> This arg `ai` occurs in an app + -- `f a1 ... an` where we have ArgInfo on + -- how `f` uses `ai`, affecting the Stop + -- continuation passed to 'simplExprC' + -> StaticEnv -> CoreExpr -- ^ Expression with its static envt + -> SimplM (DupFlag, StaticEnv, OutExpr) +simplLazyArg env dup_flag fun_ty mb_arg_info arg_env arg + | isSimplified dup_flag + = return (dup_flag, arg_env, arg) + | otherwise + = do { let arg_env' = arg_env `setInScopeFromE` env + ; let arg_ty = funArgTy fun_ty + ; let stop = case mb_arg_info of + Nothing -> mkBoringStop arg_ty + Just ai -> mkLazyArgStop arg_ty ai + ; arg' <- simplExprC arg_env' arg stop + ; return (Simplified, zapSubstEnv arg_env', arg') } + -- Return a StaticEnv that includes the in-scope set from 'env', + -- because arg' may well mention those variables (#20639) + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +simplNonRecBody :: SimplEnv -> FromWhat + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplNonRecBody env from_what body cont + = case from_what of + FromLet -> simplExprF env body cont + FromBeta {} -> simplLam env body cont + +simplLam :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont +simplLam env expr cont = simplExprF env expr cont + +simpl_lam :: HasDebugCallStack + => SimplEnv -> InBndr -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- Type beta-reduction +simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) + = do { tick (BetaReduction bndr) + ; simplLam (extendTvSubst env bndr arg_ty) body cont } + +-- Coercion beta-reduction +simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se + , sc_cont = cont }) + = assertPpr (isCoVar bndr) (ppr bndr) $ + do { tick (BetaReduction bndr) + ; let arg_co' = substCo (arg_se `setInScopeFromE` env) arg_co + ; simplLam (extendCvSubst env bndr arg_co') body cont } + +-- Value beta-reduction +-- This works for /coercion/ lambdas too +simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont, sc_dup = dup + , sc_hole_ty = fun_ty}) + = do { tick (BetaReduction bndr) + ; let from_what = FromBeta arg_levity + arg_levity + | isForAllTy fun_ty = assertPpr (isCoVar bndr) (ppr bndr) Unlifted + | otherwise = typeLevity (funArgTy fun_ty) + -- Example: (\(cv::a ~# b). blah) co + -- The type of (\cv.blah) can be (forall cv. ty); see GHC.Core.Utils.mkLamType + + -- Using fun_ty: see Note [Dark corner with representation polymorphism] + -- e.g (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg + -- When we come to `x=arg` we must choose lazy/strict correctly + -- It's wrong to err in either direction + -- But fun_ty is an OutType, so is fully substituted + + ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se + , not (needsCaseBindingL arg_levity arg) + -- Ok to test arg::InExpr in needsCaseBinding because + -- exprOkForSpeculation is stable under simplification + , not ( isSimplified dup && -- See (SR2) in Note [Avoiding simplifying repeatedly] + not (exprIsTrivial arg) && + not (isDeadOcc (idOccInfo bndr)) ) + -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $ + tick (PreInlineUnconditionally bndr) + ; simplLam env' body cont } + + | isSimplified dup -- Don't re-simplify if we've simplified it once + -- Including don't preInlineUnconditionally + -- See Note [Avoiding simplifying repeatedly] + -> completeBindX env from_what bndr arg body cont + + | otherwise + -> simplNonRecE env from_what bndr (arg, arg_se) body cont } + +-- Discard a non-counting tick on a lambda. This may change the +-- cost attribution slightly (moving the allocation of the +-- lambda elsewhere), but we don't care: optimisation changes +-- cost attribution all the time. +simpl_lam env bndr body (TickIt tickish cont) + | not (tickishCounts tickish) + = simpl_lam env bndr body cont + +-- Not enough args, so there are real lambdas left to put in the result +simpl_lam env bndr body cont + = do { let (inner_bndrs, inner_body) = collectBinders body + ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs) + ; body' <- simplExpr env' inner_body + ; new_lam <- rebuildLam env' bndrs' body' cont + ; rebuild env' new_lam cont } + +------------- +simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- Historically this had a special case for when a lambda-binder +-- could have a stable unfolding; +-- see Historical Note [Case binders and join points] +-- But now it is much simpler! We now only remove unfoldings. +-- See Note [Never put `OtherCon` unfoldings on lambda binders] +simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr) + +simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs + +------------------ +simplNonRecE :: HasDebugCallStack + => SimplEnv + -> FromWhat + -> InId -- The binder, always an Id + -- Never a join point + -- The static env for its unfolding (if any) is the first parameter + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> InExpr -- Body of the let/lambda + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplNonRecE is used for +-- * from=FromLet: a non-top-level non-recursive non-join-point let-expression +-- * from=FromBeta: a binding arising from a beta reduction +-- +-- simplNonRecE env b (rhs, rhs_se) body k +-- = let env in +-- cont< let b = rhs_se(rhs) in body > +-- +-- It deals with strict bindings, via the StrictBind continuation, +-- which may abort the whole process. +-- +-- from_what=FromLet => the RHS satisfies the let-can-float invariant +-- Otherwise it may or may not satisfy it. + +simplNonRecE env from_what bndr (rhs, rhs_se) body cont + | assert (isId bndr && not (isJoinId bndr) ) $ + is_strict_bind + = -- Evaluate RHS strictly + simplExprF (rhs_se `setInScopeFromE` env) rhs + (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what + , sc_env = env, sc_cont = cont, sc_dup = NoDup }) + + | otherwise -- Evaluate RHS lazily + = do { (env1, bndr1) <- simplNonRecBndr env bndr + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) + ; (floats1, env3) <- simplLazyBind NotTopLevel NonRecursive + (bndr,env) (bndr2,env2) (rhs,rhs_se) + ; (floats2, expr') <- simplNonRecBody env3 from_what body cont + ; return (floats1 `addFloats` floats2, expr') } + + where + is_strict_bind = case from_what of + FromBeta Unlifted -> True + -- If we are coming from a beta-reduction (FromBeta) we must + -- establish the let-can-float invariant, so go via StrictBind + -- If not, the invariant holds already, and it's optional. + + -- (FromBeta Lifted) or FromLet: look at the demand info + _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr) + + +------------------ +simplRecE :: SimplEnv + -> [(InId, InExpr)] + -> InExpr + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplRecE is used for +-- * non-top-level recursive lets in expressions +-- Precondition: not a join-point binding +simplRecE env pairs body cont + = do { let bndrs = map fst pairs + ; massert (all (not . isJoinId) bndrs) + ; env1 <- simplRecBndrs env bndrs + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs + ; (floats2, expr') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, expr') } + +{- Note [Dark corner with representation polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail +if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r). +So we are careful to call `isStrictId` on the OutId, not the InId, in case we have + ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg) +That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell +if x is lifted or unlifted from that. + +We only get such redexes from the compulsory inlining of a wired-in, +representation-polymorphic function like `rightSection` (see +GHC.Types.Id.Make). Mind you, SimpleOpt should probably have inlined +such compulsory inlinings already, but belt and braces does no harm. + +Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the +Simplifier without first calling SimpleOpt, so anything involving +GHCi or TH and operator sections will fall over if we don't take +care here. + +Note [Avoiding simplifying repeatedly] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One way in which we can get exponential behaviour is if we simplify a +big expression, and then re-simplify it -- and then this happens in a +deeply-nested way. So we must be jolly careful about re-simplifying +an expression (#13379). + +Example: + f BIG, where f has a RULE +Then + * We simplify BIG before trying the rule; but the rule does not fire + (forcing this simplification is why we have the RULE in this example) + * We inline f = \x. g x, in `simpl_lam` + * So if `simpl_lam` did preInlineUnconditionally we get (g BIG) + * Now if g has a RULE we'll simplify BIG again, and this whole thing can + iterate. + * However, if `f` did not have a RULE, so that BIG has /not/ already been + simplified, we /want/ to do preInlineUnconditionally in simpl_lam. + +So we go to some effort to avoid repeatedly simplifying the same thing: + +* ApplyToVal has a (sc_dup :: DupFlag) field which records if the argument + has been evaluated. + +* simplArg checks this flag to avoid re-simplifying. + +* simpl_lam has: + - a case for (isSimplified dup), which goes via completeBindX, and + - a case for an un-simplified argument, which tries preInlineUnconditionally + +* We go to some efforts to avoid unnecessarily simplifying ApplyToVal, + in at least two places + - In simplCast/addCoerce, where we check for isReflCo + - We sometimes try rewrite RULES befoe simplifying arguments; + see Note [tryRules: plan (BEFORE)] + +Wrinkles: + +(SR1) All that said /postInlineUnconditionally/ (called in `completeBind`) does + fire in the above (f BIG) situation. See Note [Post-inline for single-use + things] in Simplify.Utils. This certainly risks repeated simplification, + but in practice seems to be a small win. + +(SR2) When considering preInlineUnconditionally in `simpl_lam`, if the + expression is trivial, or it is dead (the binder doesn't occur), then there + is no danger of simplifying repeatedly. But there is a benefit: it can save + a simplifier iteration. So we check for that. + + +************************************************************************ +* * + Join points +* * +********************************************************************* -} + +{- Note [Rules and unfolding for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + simplExpr (join j x = rhs ) cont + ( {- RULE j (p:ps) = blah -} ) + ( {- StableUnfolding j = blah -} ) + (in blah ) + +Then we will push 'cont' into the rhs of 'j'. But we should *also* push +'cont' into the RHS of + * Any RULEs for j, e.g. generated by SpecConstr + * Any stable unfolding for j, e.g. the result of an INLINE pragma + +Simplifying rules and stable-unfoldings happens a bit after +simplifying the right-hand side, so we remember whether or not it +is a join point, and what 'cont' is, in a value of type MaybeJoinCont + +#13900 was caused by forgetting to push 'cont' into the RHS +of a SpecConstr-generated RULE for a join point. +-} + +simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplNonRecJoinPoint env bndr rhs body cont + = assert (isJoinId bndr ) $ + wrapJoinCont env cont $ \ env cont -> + do { -- We push join_cont into the join RHS and the body; + -- and wrap wrap_cont around the whole thing + ; let mult = contHoleScaling cont + res_ty = contResultType cont + ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) + ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) + ; (floats2, body') <- simplExprF env3 body cont + ; return (floats1 `addFloats` floats2, body') } + + +------------------ +simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplRecJoinPoint env pairs body cont + = wrapJoinCont env cont $ \ env cont -> + do { let bndrs = map fst pairs + mult = contHoleScaling cont + res_ty = contResultType cont + ; env1 <- simplRecJoinBndrs env bndrs mult res_ty + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs + ; (floats2, body') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, body') } + +-------------------- +wrapJoinCont :: SimplEnv -> SimplCont + -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) + -> SimplM (SimplFloats, OutExpr) +-- Deal with making the continuation duplicable if necessary, +-- and with the no-case-of-case situation. +wrapJoinCont env cont thing_inside + | contIsStop cont -- Common case; no need for fancy footwork + = thing_inside env cont + + | not (seCaseCase env) + -- See Note [Join points with -fno-case-of-case] + = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) + ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 + ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont + ; return (floats2 `addFloats` floats3, expr3) } + + | otherwise + -- Normal case; see Note [Join points and case-of-case] + = do { (floats1, cont') <- mkDupableCont env cont + ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' + ; return (floats1 `addFloats` floats2, result) } + + +-------------------- +trimJoinCont :: Id -- Used only in error message + -> JoinPointHood + -> SimplCont -> SimplCont +-- Drop outer context from join point invocation (jump) +-- See Note [Join points and case-of-case] + +trimJoinCont _ NotJoinPoint cont + = cont -- Not a jump +trimJoinCont var (JoinPoint arity) cont + = trim arity cont + where + trim 0 cont@(Stop {}) + = cont + trim 0 cont + = mkBoringStop (contResultType cont) + trim n cont@(ApplyToVal { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } + trim n cont@(ApplyToTy { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } -- join arity counts types! + trim _ cont + = pprPanic "completeCall" $ ppr var $$ ppr cont + + +{- Note [Join points and case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we perform the case-of-case transform (or otherwise push continuations +inward), we want to treat join points specially. Since they're always +tail-called and we want to maintain this invariant, we can do this (for any +evaluation context E): + + E[join j = e + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> f 3] + + --> + + join j = E[e] + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> E[f 3] + +As is evident from the example, there are two components to this behavior: + + 1. When entering the RHS of a join point, copy the context inside. + 2. When a join point is invoked, discard the outer context. + +We need to be very careful here to remain consistent---neither part is +optional! + +We need do make the continuation E duplicable (since we are duplicating it) +with mkDupableCont. + + +Note [Join points with -fno-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose case-of-case is switched off, and we are simplifying + + case (join j x = in + case y of + A -> j 1 + B -> j 2 + C -> e) of + +Usually, we'd push the outer continuation (case . of ) 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 of in + case (case y of + A -> j 1 + B -> j 2 + C -> e) of + +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 of in + case y of + A -> j 1 + B -> j 2 + C -> case e of + +which is great. + +Bottom line: if case-of-case is off, we must stop pushing the continuation +inwards altogether at any join point. Instead simplify the (join ... in ...) +with a Stop continuation, and wrap the original continuation around the +outside. Surprisingly tricky! + + +************************************************************************ +* * + Variables +* * +************************************************************************ + +Note [zapSubstEnv] +~~~~~~~~~~~~~~~~~~ +When simplifying something that has already been simplified, be sure to +zap the SubstEnv. This is VITAL. Consider + let x = e in + let y = \z -> ...x... in + \ x -> ...y... + +We'll clone the inner \x, adding x->x' in the id_subst Then when we +inline y, we must *not* replace x by x' in the inlined copy!! + +Note [Fast path for lazy data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For applications of a /lazy/ data constructor worker, the full glory of +rebuildCall is a waste of effort; +* They never inline, obviously +* They have no rewrite rules +* Lazy constructors don't need the `StrictArg` treatment. +So it's fine to zoom straight to `rebuild` which just rebuilds the +call in a very straightforward way. + +For a data constructor worker that is strict (see Note [Strict fields in Core]) +we take the slow path, so that we'll transform + K (case x of (a,b) -> a) --> case x of (a,b) -> K a +via the StrictArg case of rebuildCall + +Some programs have a /lot/ of data constructors in the source program +(compiler/perf/T9961 is an example), so this fast path can be very +valuable. +-} + +simplInVar :: SimplEnv -> InVar -> SimplM OutExpr +-- Look up an InVar in the environment +simplInVar env var + -- Why $! ? See Note [Bangs in the Simplifier] + | isTyVar var = return $! Type $! (substTyVar env var) + | isCoVar var = return $! Coercion $! (substCoVar env var) + | otherwise + = case substId env var of + ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids + in simplExpr env' e + DoneId var1 -> return (Var var1) + DoneEx e _ -> return e + +simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) +simplInId env var cont + | Just dc <- isDataConWorkId_maybe var + , isLazyDataConRep dc -- See Note [Fast path for lazy data constructors] + = rebuild zapped_env (Var var) cont + | otherwise + = case substId env var of + ContEx tvs cvs ids e -> simplExprF env' e cont + -- Don't trimJoinCont; haven't already simplified e, + -- so the cont is not embodied in e + where + env' = setSubstEnv env tvs cvs ids + + DoneId out_id -> simplOutId zapped_env out_id cont' + where + cont' = trimJoinCont out_id (idJoinPointHood out_id) cont + + DoneEx e mb_join -> simplExprF zapped_env e cont' + where + cont' = trimJoinCont var mb_join cont + where + zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] + +--------------------------------------------------------- +simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) + +---------- The runRW# rule ------ +-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep. +-- +-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o +-- K[ runRW# @rr @hole_ty body ] --> runRW @rr' @ty' (\s. K[ body s ]) +simplOutId env fun cont + | fun `hasKey` runRWKey + , ApplyToTy { sc_cont = cont1 } <- cont + , ApplyToTy { sc_cont = cont2, sc_arg_ty = hole_ty } <- cont1 + , ApplyToVal { sc_cont = cont3, sc_arg = arg + , sc_env = arg_se, sc_hole_ty = fun_ty } <- cont2 + -- Do this even if (contIsStop cont), or if seCaseCase is off. + -- See Note [No eta-expansion in runRW#] + = do { let arg_env = arg_se `setInScopeFromE` env + + overall_res_ty = contResultType cont3 + -- hole_ty is the type of the current runRW# application + (outer_cont, new_runrw_res_ty, inner_cont) + | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont3) + | otherwise = (cont3, hole_ty, mkBoringStop hole_ty) + -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] + + -- If the argument is a literal lambda already, take a short cut + -- This isn't just efficiency: + -- * If we don't do this we get a beta-redex every time, so the + -- simplifier keeps doing more iterations. + -- * Even more important: see Note [No eta-expansion in runRW#] + ; arg' <- case arg of + Lam s body -> do { (env', s') <- simplBinder arg_env s + ; body' <- simplExprC env' body inner_cont + ; return (Lam s' body') } + -- Important: do not try to eta-expand this lambda + -- See Note [No eta-expansion in runRW#] + + _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy + ; let (m,_,_) = splitFunTy fun_ty + env' = arg_env `addNewInScopeIds` [s'] + cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s' + , sc_env = env', sc_cont = inner_cont + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty } + -- cont' applies to s', then K + ; body' <- simplExprC env' arg cont' + ; return (Lam s' body') } + + ; let rr' = getRuntimeRep new_runrw_res_ty + call' = mkApps (Var fun) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg'] + ; rebuild env call' outer_cont } + +-- Normal case for (f e1 .. en) +simplOutId env fun cont + = -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules] + do { rule_base <- getSimplRules + ; let rules_for_me = getRules rule_base fun + out_args = contOutArgs env cont :: [OutExpr] + ; mb_match <- if not (null rules_for_me) && + (isClassOpId fun || activeUnfolding (seMode env) fun) + then tryRules env rules_for_me fun out_args + else return Nothing + ; case mb_match of { + Just (rule_arity, rhs) -> simplExprF env rhs $ + dropContArgs rule_arity cont ; + Nothing -> + + -- Try inlining + do { logger <- getLogger + ; mb_inline <- tryInlining env logger fun cont + ; case mb_inline of{ + Just expr -> do { checkedTick (UnfoldingDone fun) + ; simplExprF env expr cont } ; + Nothing -> + + -- Neither worked, so just rebuild + do { let arg_info = mkArgInfo env fun rules_for_me cont + ; rebuildCall env arg_info cont + } } } } } + +--------------------------------------------------------- +-- Dealing with a call site + +rebuildCall :: SimplEnvIS -> ArgInfo -> SimplCont + -> SimplM (SimplFloats, OutExpr) +-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant; +-- it is usually empty, and regardless should be ignored. +-- Only the in-scope set matters, plus the seMode flags + +-- Check the invariant +rebuildCall env arg_info _cont + | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env $$ ppr arg_info) False + = pprPanic "rebuildCall" empty + +---------- Bottoming applications -------------- +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont + -- When we run out of strictness args, it means + -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo + -- Then we want to discard the entire strict continuation. E.g. + -- * case (error "hello") of { ... } + -- * (error "Hello") arg + -- * f (error "Hello") where f is strict + -- etc + -- Then, especially in the first of these cases, we'd like to discard + -- the continuation, leaving just the bottoming expression. But the + -- type might not be right, so we may have to add a coerce. + | not (contIsTrivial cont) -- Only do this if there is a non-trivial + -- continuation to discard, else we do it + -- again and again! + = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] + return (emptyFloats env, castBottomExpr res cont_ty) + where + res = argInfoExpr fun rev_args + cont_ty = contResultType cont + +---------- Simplify type applications -------------- +rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }) + = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont + +---------- Simplify value arguments -------------------- +rebuildCall env fun_info + (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup_flag, sc_hole_ty = fun_ty + , sc_cont = cont }) + -- Argument is already simplified + | isSimplified dup_flag -- See Note [Avoid redundant simplification] + = rebuildCall env (addValArgTo fun_info arg fun_ty) cont + + -- Strict arguments + | isStrictArgInfo fun_info + , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] + = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ + simplExprF (arg_se `setInScopeFromE` env) arg + (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty + , sc_dup = Simplified + , sc_cont = cont }) + -- Note [Shadowing in the Simplifier] + + -- Lazy arguments + | otherwise + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty (Just fun_info) arg_se arg + ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } + +---------- No further useful info, revert to generic rebuild ------------ +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont + | null rules + = rebuild env (argInfoExpr fun rev_args) cont + | otherwise -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules] + = do { let args = reverse rev_args + ; mb_match <- tryRules env rules fun (map argSpecArg args) + ; case mb_match of + Just (rule_arity, rhs) -> simplExprF env rhs $ + pushSimplifiedArgs env (drop rule_arity args) cont + Nothing -> rebuild env (argInfoExpr fun rev_args) cont } + +----------------------------------- +tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr) +tryInlining env logger var cont + | Just expr <- callSiteInline env logger var lone_variable arg_infos interesting_cont + = do { dump_inline expr cont + ; return (Just expr) } + + | otherwise + = return Nothing + + where + (lone_variable, arg_infos, call_cont) = contArgs cont + interesting_cont = interestingCallContext env call_cont + + log_inlining doc + = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) + Opt_D_dump_inlinings + "" FormatText doc + + dump_inline unfolding cont + | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return () + | not (logHasDumpFlag logger Opt_D_verbose_core2core) + = when (isExternalName (idName var)) $ + log_inlining $ + sep [text "Inlining done:", nest 4 (ppr var)] + | otherwise + = log_inlining $ + sep [text "Inlining done: " <> ppr var, + nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr cont])] + + +{- Note [When to apply rewrite rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should we apply rewrite rules before simplifying the arguments, or after? +Each is highly desirable in some cases, and in fact we do both! + + - Plan (BEFORE) selectively, in `simplOutId` + See Note [tryRules: plan (BEFORE)] + + - Plan (AFTER) always, in the finishing-up case of `rebuildCall` + See Note [tryRules: plan (AFTER)] + +Historical note. Pre-2025, GHC only did tryRules once, when it had simplified +enough arguments to saturate all the RULEs it had in hand. But alas, if a new +unrelated RULE showed up (but did not fire), it could nevertheless change the +simplifier's behaviour a bit; and that messed up deterministic compilation +(#25170). (This was particularly nasty if the rule wasn't even transitively +below the module being compiled.) Current solution: ensure that adding a new, +unrelated rule that never fires does not change the simplifier behaviour. End +of historical note. + +Note [tryRules: plan (BEFORE)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is sometimes desirable to apply RULES before simplifying the function +arguments. We do so in `simplOutId`. + +We do so /selectively/ (see (BF2)), in two particular cases: + +* Class ops + (+) dNumInt e2 e3 + If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the + latter's strictness when simplifying e2, e3. Moreover, if + (+) dNumInt e2 e3 --> (\x y -> ....) e2 e3 + Frequently `x` is used just once in the body of the (\x y -> ...). + If `e2` is un-simplified we can preInlineUnconditinally and that saves + simplifying `e2` twice. See Note [Avoiding simplifying repeatedly]. + +* Specialisation RULES. In general we try to arrange that inlining is disabled + (via a pragma) if a rewrite rule should apply, so that the rule has a decent + chance to fire before we inline the function. + + But it turns out that (especially when type-class specialisation or + SpecConstr is involved) it is very helpful for the the rewrite rule to + "win" over inlining when both are active at once: see #21851, #22097. + + So if the Id has an unfolding, we want to try RULES before we try inlining. + +Wrinkles: + +(BF1) Each un-simplified argument has its own static environment, stored + in its `ApplyToVal` nodes. So we can't just match on the un-simplified + arguments: we have to apply that static environment as a substitution + first! This is done lazily in `GHC.Core.Opt.Simplify.Utils.contOutArgs`, + so it'll be done just enough to allow the rule to match, or not. + +(BF2) The "selectively" in Plan (BEFORE) is a bit ad-hoc: + + * We want Plan (BEFORE) for class ops (see above in this Note) + + * But we do NOT want Plan (BEFORE) for primops, because the constant-folding + rules are quite complicated and expensive, and we don't want to try them + twice. Moreover the benefts of Plan (BEFORE), described in the Note, don't + apply to primops. + +Note [tryRules: plan (AFTER)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very desirable to try RULES once the arguments have been simplified, +because doing so ensures that rule cascades work in one pass. We do this +in the finishing-up case of `rebuildCall`. + +Consider + {-# RULES g (h x) = k x + f (k x) = x #-} + ...f (g (h x))... +Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If +we match f's rules against the un-simplified RHS, it won't match. This +makes a particularly big difference for + +* Superclass selectors + op ($p1 ($p2 (df d))) + We want all this to unravel in one sweep + +* Constant folding + +# 3# (+# 4# 5#) + We want this to happen in one pass + +Note [Avoid redundant simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because RULES often apply to simplified arguments (see Note [Plan (AFTER)]), +there's a danger of simplifying already-simplified arguments. For example, +suppose we have + RULE f (x,y) = $sf x y +and the expression + f (p,q) e1 e2 +With Plan (AFTER) by the time the rule fires, we will have already simplified e1, e2, +and we want to avoid doing so a second time. So ApplyToVal records if the argument +is already Simplified. + +Note [Shadowing in the Simplifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This part of the simplifier may return an expression that has shadowing. +(See Note [Shadowing in Core] in GHC.Core.hs.) Consider + f (...(\a -> e)...) (case y of (a,b) -> e') +where f is strict in its second arg +If we simplify the innermost one first we get (...(\a -> e)...) +Simplifying the second arg makes us float the case out, so we end up with + case y of (a,b) -> f (...(\a -> e)...) e' +So the output does not have the no-shadowing invariant. However, there is +no danger of getting name-capture, because when the first arg was simplified +we used an in-scope set that at least mentioned all the variables free in its +static environment, and that is enough. + +We can't just do innermost first, or we'd end up with a dual problem: + case x of (a,b) -> f e (...(\a -> e')...) + +I spent hours trying to recover the no-shadowing invariant, but I just could +not think of an elegant way to do it. The simplifier is already knee-deep in +continuations. We have to keep the right in-scope set around; AND we have +to get the effect that finding (error "foo") in a strict arg position will +discard the entire application and replace it with (error "foo"). Getting +all this at once is TOO HARD! + +See also Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils. + +Note [No eta-expansion in runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see `runRW# (\s. blah)` we must not attempt to eta-expand that +lambda. Why not? Because +* `blah` can mention join points bound outside the runRW# +* eta-expansion uses arityType, and +* `arityType` cannot cope with free join Ids: + +So the simplifier spots the literal lambda, and simplifies inside it. +It's a very special lambda, because it is the one the OccAnal spots and +allows join points bound /outside/ to be called /inside/. + +See Note [No free join points in arityType] in GHC.Core.Opt.Arity + +************************************************************************ +* * + Rewrite rules +* * +************************************************************************ +-} + +tryRules :: SimplEnv -> [CoreRule] + -> OutId -> [OutExpr] + -> SimplM (Maybe (FullArgCount, CoreExpr)) + +tryRules env rules fn args + | Just (rule, rule_rhs) <- lookupRule ropts in_scope_env + act_fun fn args rules + -- Fire a rule for the function + = do { logger <- getLogger + ; checkedTick (RuleFired (ruleName rule)) + ; let occ_anald_rhs = occurAnalyseExpr rule_rhs + -- See Note [Occurrence-analyse after rule firing] + ; dump logger rule rule_rhs + ; return (Just (ruleArity rule, occ_anald_rhs)) } + + | otherwise -- No rule fires + = do { logger <- getLogger + ; nodump logger -- This ensures that an empty file is written + ; return Nothing } + + where + ropts = seRuleOpts env :: RuleOpts + in_scope_env = getUnfoldingInRuleMatch env :: InScopeEnv + act_fun = activeRule (seMode env) :: Activation -> Bool + + printRuleModule rule + = parens (maybe (text "BUILTIN") + (pprModuleName . moduleName) + (ruleModule rule)) + + dump logger rule rule_rhs + | logHasDumpFlag logger Opt_D_dump_rule_rewrites + = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat + [ text "Rule:" <+> ftext (ruleName rule) + , text "Module:" <+> printRuleModule rule + , text "Full arity:" <+> ppr (ruleArity rule) + , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) + , text "After: " <+> pprCoreExpr rule_rhs ] + + | logHasDumpFlag logger Opt_D_dump_rule_firings + = log_rule Opt_D_dump_rule_firings "Rule fired:" $ + ftext (ruleName rule) + <+> printRuleModule rule + + | otherwise + = return () + + nodump logger + | logHasDumpFlag logger Opt_D_dump_rule_rewrites + = liftIO $ + touchDumpFile logger Opt_D_dump_rule_rewrites + + | logHasDumpFlag logger Opt_D_dump_rule_firings + = liftIO $ + touchDumpFile logger Opt_D_dump_rule_firings + + | otherwise + = return () + + log_rule flag hdr details + = do + { logger <- getLogger + ; liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText + $ sep [text hdr, nest 4 details] + } + +trySeqRules :: SimplEnv + -> OutExpr -> InExpr -- Scrutinee and RHS + -> SimplCont + -> SimplM (Maybe (CoreExpr, SimplCont)) +-- See Note [User-defined RULES for seq] +-- `in_env` applies to `rhs :: InExpr` but not to `scrut :: OutExpr` +trySeqRules in_env scrut rhs cont + = do { rule_base <- getSimplRules + ; let seq_rules = getRules rule_base seqId + ; mb_match <- tryRules in_env seq_rules seqId out_args + ; case mb_match of + Nothing -> return Nothing + Just (rule_arity, rhs) -> return (Just (rhs, cont')) + where + cont' = pushSimplifiedArgs in_env (drop rule_arity out_arg_specs) rule_cont + } + where + no_cast_scrut = drop_casts scrut + + -- All these are OutTypes + scrut_ty = exprType no_cast_scrut + seq_id_ty = idType seqId -- forall r a (b::TYPE r). a -> b -> b + res1_ty = piResultTy seq_id_ty rhs_rep -- forall a (b::TYPE rhs_rep). a -> b -> b + res2_ty = piResultTy res1_ty scrut_ty -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b + res3_ty = piResultTy res2_ty rhs_ty -- scrut_ty -> rhs_ty -> rhs_ty + res4_ty = funResultTy res3_ty -- rhs_ty -> rhs_ty + rhs_ty = substTy in_env (exprType rhs) + rhs_rep = getRuntimeRep rhs_ty + + out_args = [Type rhs_rep, Type scrut_ty, Type rhs_ty, no_cast_scrut] + -- Cheaper than (map argSpecArg out_arg_specs) + out_arg_specs = [ TyArg { as_arg_ty = rhs_rep + , as_hole_ty = seq_id_ty } + , TyArg { as_arg_ty = scrut_ty + , as_hole_ty = res1_ty } + , TyArg { as_arg_ty = rhs_ty + , as_hole_ty = res2_ty } + , ValArg { as_arg = no_cast_scrut + , as_dmd = seqDmd + , as_hole_ty = res3_ty } ] + rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs + , sc_env = in_env, sc_cont = cont + , sc_hole_ty = res4_ty } + + -- Lazily evaluated, so we don't do most of this + drop_casts (Cast e _) = drop_casts e + drop_casts e = e + +{- Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given + case (scrut |> co) of _ -> rhs +look for rules that match the expression + seq @t1 @t2 scrut +where scrut :: t1 + rhs :: t2 + +If you find a match, rewrite it, and apply to 'rhs'. + +Notice that we can simply drop casts on the fly here, which +makes it more likely that a rule will match. + +See Note [User-defined RULES for seq] in GHC.Types.Id.Make. + +Note [Occurrence-analyse after rule firing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After firing a rule, we occurrence-analyse the instantiated RHS before +simplifying it. Usually this doesn't make much difference, but it can +be huge. Here's an example (simplCore/should_compile/T7785) + + map f (map f (map f xs) + += -- Use build/fold form of map, twice + map f (build (\cn. foldr (mapFB c f) n + (build (\cn. foldr (mapFB c f) n xs)))) + += -- Apply fold/build rule + map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) + += -- Beta-reduce + -- Alas we have no occurrence-analysed, so we don't know + -- that c is used exactly once + map f (build (\cn. let c1 = mapFB c f in + foldr (mapFB c1 f) n xs)) + += -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) + -- We can do this because (mapFB c n) is a PAP and hence expandable + map f (build (\cn. let c1 = mapFB c n in + foldr (mapFB c (f.f)) n x)) + +This is not too bad. But now do the same with the outer map, and +we get another use of mapFB, and t can interact with /both/ remaining +mapFB calls in the above expression. This is stupid because actually +that 'c1' binding is dead. The outer map introduces another c2. If +there is a deep stack of maps we get lots of dead bindings, and lots +of redundant work as we repeatedly simplify the result of firing rules. + +The easy thing to do is simply to occurrence analyse the result of +the rule firing. Note that this occ-anals not only the RHS of the +rule, but also the function arguments, which by now are OutExprs. +E.g. + RULE f (g x) = x+1 + +Call f (g BIG) --> (\x. x+1) BIG + +The rule binders are lambda-bound and applied to the OutExpr arguments +(here BIG) which lack all internal occurrence info. + +Is this inefficient? Not really: we are about to walk over the result +of the rule firing to simplify it, so occurrence analysis is at most +a constant factor. + +Note, however, that the rule RHS is /already/ occ-analysed; see +Note [OccInfo in unfoldings and rules] in GHC.Core. There is something +unsatisfactory about doing it twice; but the rule RHS is usually very +small, and this is simple. + +Note [Rules for recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that we shouldn't apply rules for a loop breaker: +doing so might give rise to an infinite loop, because a RULE is +rather like an extra equation for the function: + RULE: f (g x) y = x+y + Eqn: f a y = a-y + +But it's too drastic to disable rules for loop breakers. +Even the foldr/build rule would be disabled, because foldr +is recursive, and hence a loop breaker: + foldr k z (build g) = g k z +So it's up to the programmer: rules can cause divergence + + +************************************************************************ +* * + Rebuilding a case expression +* * +************************************************************************ + +Note [Case elimination] +~~~~~~~~~~~~~~~~~~~~~~~ +The case-elimination transformation discards redundant case expressions. +Start with a simple situation: + + case x# of ===> let y# = x# in e + y# -> e + +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! + +The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise +this idea to look for a case where we're scrutinising a variable, and we know +that only the default case can match. For example: + + case x of + 0# -> ... + DEFAULT -> ...(case x of + 0# -> ... + DEFAULT -> ...) ... + +Here the inner case is first trimmed to have only one alternative, the +DEFAULT, after which it's an instance of the previous case. This +really only shows up in eliminating error-checking code. + +Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs. So + + case e of ===> case e of DEFAULT -> r + True -> r + False -> r + +Now again the case may be eliminated by the CaseElim transformation. +This includes things like (==# a# b#)::Bool so that we simplify + case ==# a# b# of { True -> x; False -> x } +to just + x +This particular example shows up in default methods for +comparison operations (e.g. in (>=) for Int.Int32) + +Note [Case to let transformation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a case over a lifted type has a single alternative, and is being +used as a strict 'let' (all isDeadBinder bndrs), we may want to do +this transformation: + + case e of r ===> let r = e in ...r... + _ -> ...r... + +We treat the unlifted and lifted cases separately: + +* Unlifted case: 'e' satisfies exprOkForSpeculation + (ok-for-spec is needed to satisfy the let-can-float invariant). + This turns case a +# b of r -> ...r... + into let r = a +# b in ...r... + and thence .....(a +# b).... + + However, if we have + case indexArray# a i of r -> ...r... + we might like to do the same, and inline the (indexArray# a i). + But indexArray# is not okForSpeculation, so we don't build a let + in rebuildCase (lest it get floated *out*), so the inlining doesn't + happen either. Annoying. + +* Lifted case: we need to be sure that the expression is already + evaluated (exprIsHNF). If it's not already evaluated + - we risk losing exceptions, divergence or + user-specified thunk-forcing + - even if 'e' is guaranteed to converge, we don't want to + create a thunk (call by need) instead of evaluating it + right away (call by value) + + However, we can turn the case into a /strict/ let if the 'r' is + used strictly in the body. Then we won't lose divergence; and + we won't build a thunk because the let is strict. + See also Note [Case-to-let for strictly-used binders] + +Note [Case-to-let for strictly-used binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have this: + case of r { _ -> ..r.. } +where 'r' is used strictly in (..r..), we /could/ safely transform to + let r = in ...r... +As a special case, we have a plain `seq` like + case r of r1 { _ -> ...r1... } +where `r` is used strictly, we /could/ simply drop the `case` to get + ...r.... + +HOWEVER, there are some serious downsides to this transformation, so +GHC doesn't do it any longer (#24251): + +* Suppose the Simplifier sees + case x of y* { __DEFAULT -> + let z = case y of { __DEFAULT -> expr } in + z+1 } + The "y*" means "y is used strictly in its scope. Now we may: + - Eliminate the inner case because `y` is evaluated. + Now the demand-info on `y` is not right, because `y` is no longer used + strictly in its scope. But it is hard to spot that without doing a new + demand analysis. So there is a danger that we will subsequently: + - Eliminate the outer case because `y` is used strictly + Yikes! We can't eliminate both! + +* It introduces space leaks (#24251). Consider + go 0 where go x = x `seq` go (x + 1) + It is an infinite loop, true, but it should not leak space. Yet if we drop + the `seq`, it will. Another great example is #21741. + +* Dropping the outer `case` can change the error behaviour. For example, + we might transform + case x of { _ -> error "bad" } --> error "bad" + which is might be puzzling if 'x' currently lambda-bound, but later gets + let-bound to (error "good"). Tht is OK accoring to the paper "A semantics for + imprecise exceptions", but see #8900 for an example where the loss of this + transformation bit us in practice. + +* If we have (case e of x -> f x), where `f` is strict, then it looks as if `x` + is strictly used, and we could soundly transform to + let x = e in f x + But if f's strictness info got worse (which can happen in in obscure cases; + see #21392) then we might have turned a non-thunk into a thunk! Bad. + +Lacking this "drop-strictly-used-seq" transformation means we can end up with +some redundant-looking evals. For example, consider + f x y = case x of DEFAULT -> -- A redundant-looking eval + case y of + True -> case x of { Nothing -> False; Just z -> z } + False -> case x of { Nothing -> True; Just z -> z } +That outer eval will be retained right through to code generation. But, +perhaps surprisingly, that is probably a /good/ thing: + + Key point: those inner (case x) expressions will be compiled a simple 'if', + because the code generator can see that `x` is, at those points, evaluated + and properly tagged. + +If we dropped the outer eval, both the inner (case x) expressions would need to +do a proper eval, pushing a return address, with an info table. See the example +in #15631 where, in the Description, the (case ys) will be a simple multi-way +jump. + +In fact (#24251), when I stopped GHC implementing the drop-strictly-used-seqs +transformation, binary sizes fell by 1%, and a few programs actually allocated +less and ran faster. A case in point is nofib/imaginary/digits-of-e2. (I'm not +sure exactly why it improves so much, though.) + +Slightly related: Note [Empty case alternatives] in GHC.Core. + +Historical notes: + +There have been various earlier versions of this patch: + +* By Sept 18 the code looked like this: + || scrut_is_demanded_var scrut + + scrut_is_demanded_var :: CoreExpr -> Bool + scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s + scrut_is_demanded_var (Var _) = isStrUsedDmd (idDemandInfo case_bndr) + scrut_is_demanded_var _ = False + + This only fired if the scrutinee was a /variable/, which seems + an unnecessary restriction. So in #15631 I relaxed it to allow + arbitrary scrutinees. Less code, less to explain -- but the change + had 0.00% effect on nofib. + +* Previously, in Jan 13 the code looked like this: + || case_bndr_evald_next rhs + + case_bndr_evald_next :: CoreExpr -> Bool + -- See Note [Case binder next] + case_bndr_evald_next (Var v) = v == case_bndr + case_bndr_evald_next (Cast e _) = case_bndr_evald_next e + case_bndr_evald_next (App e _) = case_bndr_evald_next e + case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e + case_bndr_evald_next _ = False + + This patch was part of fixing #7542. See also + Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.) + + +Further notes about case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: test :: Integer -> IO () + test = print + +Turns out that this compiles to: + Print.test + = \ eta :: Integer + eta1 :: Void# -> + case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> + case hPutStr stdout + (PrelNum.jtos eta ($w[] @ Char)) + eta1 + of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} + +Notice the strange '<' which has no effect at all. This is a funny one. +It started like this: + +f x y = if x < 0 then jtos x + else if y==0 then "" else jtos x + +At a particular call site we have (f v 1). So we inline to get + + if v < 0 then jtos x + else if 1==0 then "" else jtos x + +Now simplify the 1==0 conditional: + + if v<0 then jtos v else jtos v + +Now common-up the two branches of the case: + + case (v<0) of DEFAULT -> jtos v + +Why don't we drop the case? Because it's strict in v. It's technically +wrong to drop even unnecessary evaluations, and in practice they +may be a result of 'seq' so we *definitely* don't want to drop those. +I don't really know how to improve this situation. + + +Note [FloatBinds from constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have FloatBinds coming from the constructor wrapper +(as in Note [exprIsConApp_maybe on data constructors with wrappers]), +we cannot float past them. We'd need to float the FloatBind +together with the simplify floats, unfortunately the +simplifier doesn't have case-floats. The simplest thing we can +do is to wrap all the floats here. The next iteration of the +simplifier will take care of all these cases and lets. + +Given data T = MkT !Bool, this allows us to simplify +case $WMkT b of { MkT x -> f x } +to +case b of { b' -> f b' }. + +We could try and be more clever (like maybe wfloats only contain +let binders, so we could float them). But the need for the +extra complication is not clear. + +Note [Do not duplicate constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#20125) + let x = (a,b) + in ...(case x of x' -> blah)...x...x... + +We want that `case` to vanish (since `x` is bound to a data con) leaving + let x = (a,b) + in ...(let x'=x in blah)...x..x... + +In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`, +since is bound to (a,b). But in eliminating the case, if the scrutinee +is trivial, we want to bind the case-binder to the scrutinee, /not/ to +the constructor application. Hence the case_bndr_rhs in rebuildCase. + +This applies equally to a non-DEFAULT case alternative, say + let x = (a,b) in ...(case x of x' { (p,q) -> blah })... +This variant is handled by bind_case_bndr in knownCon. + +We want to bind x' to x, and not to a duplicated (a,b)). +-} + +--------------------------------------------------------- +-- Eliminate the case if possible + +rebuildCase, reallyRebuildCase + :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Alternatives (increasing order) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-------------------------------------------------- +-- 1. Eliminate the case if there's a known constructor +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts cont + | Lit lit <- scrut -- No need for same treatment as constructors + -- because literals are inlined more vigorously + , not (litIsLifted lit) + = do { tick (KnownBranch case_bndr) + ; case findAlt (LitAlt lit) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs } + + | Just (in_scope', wfloats, con, ty_args, other_args) + <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + , let env0 = setInScopeSet env in_scope' + = do { tick (KnownBranch case_bndr) + ; let scaled_wfloats = map scale_float wfloats + -- case_bndr_unf: see Note [Do not duplicate constructor applications] + case_bndr_rhs | exprIsTrivial scrut = scrut + | otherwise = con_app + con_app = Var (dataConWorkId con) `mkTyApps` ty_args + `mkApps` other_args + ; case findAlt (DataAlt con) alts of + Nothing -> missingAlt env0 case_bndr alts cont + Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs + Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args + other_args case_bndr bs rhs cont + } + where + simple_rhs env wfloats case_bndr_rhs bs rhs = + assert (null bs) $ + do { (floats1, env') <- simplAuxBind "rebuildCase" env case_bndr case_bndr_rhs + -- scrut is a constructor application, + -- hence satisfies let-can-float invariant + ; (floats2, expr') <- simplExprF env' rhs cont + ; case wfloats of + [] -> return (floats1 `addFloats` floats2, expr') + _ -> return + -- See Note [FloatBinds from constructor wrappers] + ( emptyFloats env, + GHC.Core.Make.wrapFloats wfloats $ + wrapFloats (floats1 `addFloats` floats2) expr' )} + + -- This scales case floats by the multiplicity of the continuation hole (see + -- Note [Scaling in case-of-case]). Let floats are _not_ scaled, because + -- they are aliases anyway. + scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) = + let + scale_id id = scaleVarBy holeScaling id + in + GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) + scale_float f = f + + holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr + -- We are in the following situation + -- case[p] case[q] u of { D x -> C v } of { C x -> w } + -- And we are producing case[??] u of { D x -> w[x\v]} + -- + -- What should the multiplicity `??` be? In order to preserve the usage of + -- variables in `u`, it needs to be `pq`. + -- + -- As an illustration, consider the following + -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) } + -- Where C :: A %1 -> T is linear + -- If we were to produce a case[1], like the inner case, we would get + -- case[1] of { C x -> (x, x) } + -- Which is ill-typed with respect to linearity. So it needs to be a + -- case[Many]. + +-------------------------------------------------- +-- 2. Eliminate the case if scrutinee is evaluated +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont + -- See if we can get rid of the case altogether + -- See Note [Case elimination] + -- mkCase made sure that if all the alternatives are equal, + -- then there is now only one (DEFAULT) rhs + + -- 2a. Dropping the case altogether, if + -- a) it binds nothing (so it's really just a 'seq') + -- b) evaluating the scrutinee has no side effects + | is_plain_seq + , exprOkToDiscard scrut + -- The entire case is dead, so we can drop it + -- if the scrutinee converges without having imperative + -- side effects or raising a Haskell exception + = simplExprF env rhs cont + + -- 2b. Turn the case into a let, if + -- a) it binds only the case-binder + -- b) unlifted case: the scrutinee is ok-for-speculation + -- lifted case: the scrutinee is in HNF (or will later be demanded) + -- See Note [Case to let transformation] + | all_dead_bndrs + , doCaseToLet scrut case_bndr + = do { tick (CaseElim case_bndr) + ; (floats1, env') <- simplAuxBind "rebuildCaseAlt1" env case_bndr scrut + ; (floats2, expr') <- simplExprF env' rhs cont + ; return (floats1 `addFloats` floats2, expr') } + + -- 2c. Try the seq rules if + -- a) it binds only the case binder + -- b) a rule for seq applies + -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make + | is_plain_seq + = do { mb_rule <- trySeqRules env scrut rhs cont + ; case mb_rule of + Just (rule_rhs, cont') -> simplExprF (zapSubstEnv env) rule_rhs cont' + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + +-------------------------------------------------- +-- 3. Primop-related case-rules +-------------------------------------------------- + + |Just (scrut', case_bndr', alts') <- caseRules2 scrut case_bndr alts + = reallyRebuildCase env scrut' case_bndr' alts' cont + + where + all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] + is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect + +rebuildCase env scrut case_bndr alts cont + = reallyRebuildCase env scrut case_bndr alts cont + +doCaseToLet :: OutExpr -- Scrutinee + -> InId -- Case binder + -> Bool +-- The situation is case scrut of b { DEFAULT -> body } +-- Can we transform thus? let { b = scrut } in body +doCaseToLet scrut case_bndr + | isTyCoVar case_bndr -- Respect GHC.Core + = isTyCoArg scrut -- Note [Core type and coercion invariant] + + | isUnliftedType (exprType scrut) + -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase). + -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr' + -- (which is an 'InId'): see Note [Dark corner with representation polymorphism]. + -- Using `exprType` is typically cheap because `scrut` is typically a variable. + -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts + -- the brain more. Consider that if this test ever turns out to be a perf + -- problem (which seems unlikely). + = exprOkForSpeculation scrut + + | otherwise -- Scrut has a lifted type + = exprIsHNF scrut + -- || isStrUsedDmd (idDemandInfo case_bndr) + -- We no longer look at the demand on the case binder + -- See Note [Case-to-let for strictly-used binders] + +-------------------------------------------------- +-- 3. Catch-all case +-------------------------------------------------- + +reallyRebuildCase env scrut case_bndr alts cont + | not (seCaseCase env) -- Only when case-of-case is on. + -- See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] + = do { case_expr <- simplAlts env scrut case_bndr alts + (mkBoringStop (contHoleType cont)) + ; rebuild (zapSubstEnv env) case_expr cont } + + | otherwise + = do { (floats, env', cont') <- mkDupableCaseCont env alts cont + ; case_expr <- simplAlts env' scrut + (scaleIdBy holeScaling case_bndr) + (scaleAltsBy holeScaling alts) + cont' + ; return (floats, case_expr) } + where + holeScaling = contHoleScaling cont + -- Note [Scaling in case-of-case] + +{- +simplCaseBinder checks whether the scrutinee is a variable, v. If so, +try to eliminate uses of v in the RHSs in favour of case_bndr; that +way, there's a chance that v will now only be used once, and hence +inlined. + +Historical note: we use to do the "case binder swap" in the Simplifier +so there were additional complications if the scrutinee was a variable. +Now the binder-swap stuff is done in the occurrence analyser; see +"GHC.Core.Opt.OccurAnal" Note [Binder swap]. + +Note [knownCon occ info] +~~~~~~~~~~~~~~~~~~~~~~~~ +If the case binder is not dead, then neither are the pattern bound +variables: + case of x { (a,b) -> + case x of { (p,q) -> p } } +Here (a,b) both look dead, but come alive after the inner case is eliminated. +The point is that we bring into the envt a binding + let x = (a,b) +after the outer case, and that makes (a,b) alive. At least we do unless +the case binder is guaranteed dead. + +Note [DataAlt occ info] +~~~~~~~~~~~~~~~~~~~~~~~ +Our general goal is to preserve dead-ness occ-info on the field binders of a +case alternative. Why? It's generally a good idea, but one specific reason is to +support (SEQ4) of Note [seq# magic]. + +But we have to be careful: even if the field binder is not mentioned in the case +alternative and thus annotated IAmDead by OccurAnal, it might "come back to +life" in one of two ways: + + 1. If the case binder is alive, its unfolding might bring back the field + binder, as in Note [knownCon occ info]: + case blah of y { I# _ -> $wf (case y of I# v -> v) } + ==> + case blah of y { I# v -> $wf v } + 2. Even if the case binder appears to be dead, there is the scenario in + Note [Add unfolding for scrutinee], in which the fields come back to live + through the unfolding of variable scrutinee, as follows: + join j = case x of Just v -> blah v; Nothing -> ... in + case x of Just _ -> jump j; Nothing -> ... + ==> { inline j, unfold x to Just v, simplify } + join j = case x of Just v -> blah v; Nothing -> ... in + case x of Just v -> blah v; Nothing -> ... + +Thus, when we are simply reconstructing a case (the common case), and the +case binder is not dead, or the scrutinee is a variable, we zap the +occurrence info on DataAlt field binders. See `adjustFieldOccInfo`. + +Note [Improving seq] +~~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: * -> * + type instance F Int = Int + +We'd like to transform + case e of (x :: F Int) { DEFAULT -> rhs } +===> + case e `cast` co of (x'::Int) + I# x# -> let x = x' `cast` sym co + in rhs + +so that 'rhs' can take advantage of the form of x'. Notice that Note +[Case of cast] (in OccurAnal) may then apply to the result. + +We'd also like to eliminate empty types (#13468). So if + + data Void + type instance F Bool = Void + +then we'd like to transform + case (x :: F Bool) of { _ -> error "urk" } +===> + case (x |> co) of (x' :: Void) of {} + +Nota Bene: we used to have a built-in rule for 'seq' that dropped +casts, so that + case (x |> co) of { _ -> blah } +dropped the cast; in order to improve the chances of trySeqRules +firing. But that works in the /opposite/ direction to Note [Improving +seq] so there's a danger of flip/flopping. Better to make trySeqRules +insensitive to the cast, which is now is. + +The need for [Improving seq] showed up in Roman's experiments. Example: + foo :: F Int -> Int -> Int + foo t n = t `seq` bar n + where + bar 0 = 0 + bar n = bar (n - case t of TI i -> i) +Here we'd like to avoid repeated evaluating t inside the loop, by +taking advantage of the `seq`. + +At one point I did transformation in LiberateCase, but it's more +robust here. (Otherwise, there's a danger that we'll simply drop the +'seq' altogether, before LiberateCase gets to see it.) + +Note [Scaling in case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When two cases commute, if done naively, the multiplicities will be wrong: + + case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many] + { (z[Many], t[Many]) -> z + } + +The multiplicities here, are correct, but if I perform a case of case: + + case u of w[1] + { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and +`y` must have multiplicities `Many` not `1`! The correct solution is to make +all the `1`-s be `Many`-s instead: + + case u of w[Many] + { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +In general, when commuting two cases, the rule has to be: + + case (case … of x[p] {…}) of y[q] { … } + ===> case … of x[p*q] { … case … of y[q] { … } } + +This is materialised, in the simplifier, by the fact that every time we simplify +case alternatives with a continuation (the surrounded case (or more!)), we must +scale the entire case we are simplifying, by a scaling factor which can be +computed in the continuation (with function `contHoleScaling`). +-} + +simplAlts :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Non-empty + -> SimplCont + -> SimplM OutExpr -- Returns the complete simplified case expression + +simplAlts env0 scrut case_bndr alts cont' + = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr + , text "cont':" <+> ppr cont' + , text "in_scope" <+> ppr (seInScope env0) ]) + ; (env1, case_bndr1) <- simplBinder env0 case_bndr + ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding + env2 = modifyInScope env1 case_bndr2 + -- See Note [Case binder evaluated-ness] + fam_envs = seFamEnvs env0 + + ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut + case_bndr case_bndr2 alts + + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts + -- NB: it's possible that the returned in_alts is empty: this is handled + -- by the caller (rebuildCase) in the missingAlt function + -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts + -- See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils + + ; alts' <- forM in_alts $ + simplAlt alt_env' (Just scrut') imposs_deflt_cons + case_bndr' (scrutOkForBinderSwap scrut) cont' + + ; let alts_ty' = contResultType cont' + -- See Note [Avoiding space leaks in OutType] + ; seqType alts_ty' `seq` + mkCase (seMode env0) scrut' case_bndr' alts_ty' alts' } + + +------------------------------------ +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- Note [Improving seq] +improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] + | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) + = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2 + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) NotJoinPoint + env2 = extendIdSubst env case_bndr rhs + ; return (env2, scrut `Cast` co, case_bndr2) } + +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) + + +------------------------------------ +simplAlt :: SimplEnv + -> Maybe OutExpr -- The scrutinee + -> [AltCon] -- These constructors can't be present when + -- matching the DEFAULT alternative + -> OutId -- The case binder `bndr` + -> BinderSwapDecision -- DoBinderSwap v co <==> scrut = Just (v |> co), + -- add unfolding `v :-> bndr |> sym co` + -> SimplCont + -> InAlt + -> SimplM OutAlt + +simplAlt env _scrut' imposs_deflt_cons case_bndr' bndr_swap' cont' (Alt DEFAULT bndrs rhs) + = assert (null bndrs) $ + do { let env' = addDefaultUnfoldings env case_bndr' bndr_swap' imposs_deflt_cons + ; rhs' <- simplExprC env' rhs cont' + ; return (Alt DEFAULT [] rhs') } + +simplAlt env _scrut' _ case_bndr' bndr_swap' cont' (Alt (LitAlt lit) bndrs rhs) + = assert (null bndrs) $ + do { let env' = addAltUnfoldings env case_bndr' bndr_swap' (Lit lit) + ; rhs' <- simplExprC env' rhs cont' + ; return (Alt (LitAlt lit) [] rhs') } + +simplAlt env scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rhs) + = do { -- See Note [Adding evaluatedness info to pattern-bound variables] + -- and Note [DataAlt occ info] + ; let vs_with_info = adjustFieldsIdInfo scrut' case_bndr' bndr_swap' con vs + -- Adjust evaluated-ness and occ-info flags before `simplBinders` + -- because the latter extends the in-scope set, which propagates this + -- adjusted info to use sites. + ; (env', vs') <- simplBinders env vs_with_info + + -- Bind the case-binder to (con args) + ; let inst_tys' = tyConAppArgs (idType case_bndr') + con_app :: OutExpr + con_app = mkConApp2 con inst_tys' vs' + env'' = addAltUnfoldings env' case_bndr' bndr_swap' con_app + + ; rhs' <- simplExprC env'' rhs cont' + ; return (Alt (DataAlt con) vs' rhs') } + +{- Note [Adding evaluatedness info to pattern-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +addEvals records the evaluated-ness of the bound variables of +a case pattern. This is *important*. Consider + + data T = T !Int !Int + + case x of { T a b -> T (a+1) b } + +We really must record that b is already evaluated so that we don't +go and re-evaluate it when constructing the result. +See Note [Strict fields in Core] in GHC.Core. + +NB: simplLamBndrs preserves this eval info + +In addition to handling data constructor fields with !s, addEvals +also records the fact that the result of seq# is always in WHNF. +See Note [seq# magic] in GHC.Types.Id.Make. Example (#15226): + + case seq# v s of + (# s', v' #) -> E + +we want the compiler to be aware that v' is in WHNF in E. + +Open problem: we don't record that v itself is in WHNF (and we can't +do it here). The right thing is to do some kind of binder-swap; +see #15226 for discussion. +-} + +adjustFieldsIdInfo :: Maybe OutExpr -> OutId -> BinderSwapDecision -> DataCon -> [Id] -> [Id] +-- See Note [Adding evaluatedness info to pattern-bound variables] +-- and Note [DataAlt occ info] +adjustFieldsIdInfo scrut case_bndr bndr_swap con vs + -- Deal with seq# applications + | Just scr <- scrut + , isUnboxedTupleDataCon con + , [s,x] <- vs + -- Use stripNArgs rather than collectArgsTicks to avoid building + -- a list of arguments only to throw it away immediately. + , Just (Var f) <- stripNArgs 4 scr + , f `hasKey` seqHashKey + , let x' = setCaseBndrEvald MarkedStrict x + = map (adjustFieldOccInfo case_bndr bndr_swap) [s, x'] + + -- Deal with banged datacon fields + -- This case is quite allocation sensitive to T9233 which has a large record + -- with strict fields. Hence we try not to update vs twice! +adjustFieldsIdInfo _scrut case_bndr bndr_swap con vs + | Nothing <- dataConWrapId_maybe con + -- A common fast path; no need to allocate the_strs when they are all lazy + -- anyway! It shaves off 2% in T9675 + = map (adjustFieldOccInfo case_bndr bndr_swap) vs + | otherwise + = go vs the_strs + where + the_strs = dataConRepStrictness con + + go [] [] = [] + go (v:vs') strs | isTyVar v = v : go vs' strs + go (v:vs') (str:strs) = adjustFieldOccInfo case_bndr bndr_swap (setCaseBndrEvald str v) : go vs' strs + go _ _ = pprPanic "Simplify.adjustFieldsIdInfo" + (ppr con $$ + ppr vs $$ + ppr_with_length (map strdisp the_strs) $$ + ppr_with_length (dataConRepArgTys con) $$ + ppr_with_length (dataConRepStrictness con)) + where + ppr_with_length list + = ppr list <+> parens (text "length =" <+> ppr (length list)) + strdisp :: StrictnessMark -> SDoc + strdisp MarkedStrict = text "MarkedStrict" + strdisp NotMarkedStrict = text "NotMarkedStrict" + +adjustFieldOccInfo :: OutId -> BinderSwapDecision -> CoreBndr -> CoreBndr +-- Kill occ info if we do binder swap and the case binder is alive; +-- see Note [DataAlt occ info] +adjustFieldOccInfo case_bndr bndr_swap field_bndr + | isTyVar field_bndr + = field_bndr + + | not (isDeadBinder case_bndr) -- (1) in the Note: If the case binder is alive, + = zapIdOccInfo field_bndr -- the field binders might come back alive + + | DoBinderSwap{} <- bndr_swap -- (2) in the Note: If binder swap might take place, + = zapIdOccInfo field_bndr -- the case binder might come back alive + + | otherwise + = field_bndr -- otherwise the field binders stay dead + +addDefaultUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> [AltCon] -> SimplEnv +addDefaultUnfoldings env case_bndr bndr_swap imposs_deflt_cons + = env2 + where + unf = mkOtherCon imposs_deflt_cons + -- Record the constructors that the case-binder *can't* be. + env1 = addBinderUnfolding env case_bndr unf + env2 | DoBinderSwap v _mco <- bndr_swap + = addBinderUnfolding env1 v unf + | otherwise = env1 + + +addAltUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> OutExpr -> SimplEnv +addAltUnfoldings env case_bndr bndr_swap con_app + = env2 + where + con_app_unf = mk_simple_unf con_app + env1 = addBinderUnfolding env case_bndr con_app_unf + + -- See Note [Add unfolding for scrutinee] + env2 | DoBinderSwap v mco <- bndr_swap + = addBinderUnfolding env1 v $ + if isReflMCo mco -- isReflMCo: avoid calling mk_simple_unf + then con_app_unf -- twice in the common case + else mk_simple_unf (mkCastMCo con_app mco) + + | otherwise = env1 + + -- Force the opts, so that the whole SimplEnv isn't retained + !opts = seUnfoldingOpts env + mk_simple_unf = mkSimpleUnfolding opts + +addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv +addBinderUnfolding env bndr unf + | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf + = warnPprTrace (not (eqType (idType bndr) (exprType tmpl))) + "unfolding type mismatch" + (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $ + modifyInScope env (bndr `setIdUnfolding` unf) + + | otherwise + = modifyInScope env (bndr `setIdUnfolding` unf) + +zapBndrOccInfo :: Bool -> Id -> Id +-- Consider case e of b { (a,b) -> ... } +-- Then if we bind b to (a,b) in "...", and b is not dead, +-- then we must zap the deadness info on a,b +zapBndrOccInfo keep_occ_info pat_id + | keep_occ_info = pat_id + | otherwise = zapIdOccInfo pat_id + +{- Note [Case binder evaluated-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin on a (OtherCon []) unfolding to the case-binder of a Case, +even though it'll be over-ridden in every case alternative with a more +informative unfolding. Why? Because suppose a later, less clever, pass +simply replaces all occurrences of the case binder with the binder itself; +then Lint may complain about the let-can-float invariant. Example + case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in .... + ; K -> blah } + +The let-can-float invariant requires that y is evaluated in the call to +reallyUnsafePtrEquality#, which it is. But we still want that to be true if we +propagate binders to occurrences. + +This showed up in #13027. + +Note [Add unfolding for scrutinee] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general it's unlikely that a variable scrutinee will appear +in the case alternatives case x of { ...x unlikely to appear... } +because the binder-swap in OccurAnal has got rid of all such occurrences +See Note [Binder swap] in "GHC.Core.Opt.OccurAnal". + +BUT it is still VERY IMPORTANT to add a suitable unfolding for a +variable scrutinee, in simplAlt. Here's why + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +There is no occurrence of 'b' in the (...(f y)...). But y gets +the unfolding (a,b), and *that* mentions b. If f has a RULE + RULE f (p, I# q) = ... +we want that rule to match, so we must extend the in-scope env with a +suitable unfolding for 'y'. It's *essential* for rule matching; but +it's also good for case-elimination -- suppose that 'f' was inlined +and did multi-level case analysis, then we'd solve it in one +simplifier sweep instead of two. + +HOWEVER, given + case x of y { Just a -> r1; Nothing -> r2 } +we do not want to add the unfolding x -> y to 'x', which might seem cool, +since 'y' itself has different unfoldings in r1 and r2. Reason: if we +did that, we'd have to zap y's deadness info and that is a very useful +piece of information. + +So instead we add the unfolding x -> Just a, and x -> Nothing in the +respective RHSs. + +Since this transformation is tantamount to a binder swap, we use +GHC.Core.Opt.OccurAnal.scrutOkForBinderSwap to do the check. + +Exactly the same issue arises in GHC.Core.Opt.SpecConstr; +see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr + + +************************************************************************ +* * +\subsection{Known constructor} +* * +************************************************************************ + +We are a bit careful with occurrence info. Here's an example + + (\x* -> case x of (a*, b) -> f a) (h v, e) + +where the * means "occurs once". This effectively becomes + case (h v, e) of (a*, b) -> f a) +and then + let a* = h v; b = e in f a +and then + f (h v) + +All this should happen in one sweep. +-} + +knownCon :: SimplEnv + -> OutExpr -- The scrutinee + -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont + = do { (floats1, env1) <- bind_args env bs dc_args + ; (floats2, env2) <- bind_case_bndr env1 + ; (floats3, expr') <- simplExprF env2 rhs cont + ; case dc_floats of + [] -> + return (floats1 `addFloats` floats2 `addFloats` floats3, expr') + _ -> + return ( emptyFloats env + -- See Note [FloatBinds from constructor wrappers] + , GHC.Core.Make.wrapFloats dc_floats $ + wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } + where + zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId + + -- Ugh! + bind_args env' [] _ = return (emptyFloats env', env') + + bind_args env' (b:bs') (Type ty : args) + = assert (isTyVar b ) + bind_args (extendTvSubst env' b ty) bs' args + + bind_args env' (b:bs') (Coercion co : args) + = assert (isCoVar b ) + bind_args (extendCvSubst env' b co) bs' args + + bind_args env' (b:bs') (arg : args) + = assert (isId b) $ + do { let b' = zap_occ b + -- zap_occ: the binder might be "dead", because it doesn't + -- occur in the RHS; and simplAuxBind may therefore discard it. + -- Nevertheless we must keep it if the case-binder is alive, + -- because it may be used in the con_app. See Note [knownCon occ info] + ; (floats1, env2) <- simplAuxBind "knownCon" env' b' arg -- arg satisfies let-can-float invariant + ; (floats2, env3) <- bind_args env2 bs' args + ; return (floats1 `addFloats` floats2, env3) } + + bind_args _ _ _ = + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ + text "scrut:" <+> ppr scrut + + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bind_case_bndr env + | isDeadBinder bndr = return (emptyFloats env, env) + | exprIsTrivial scrut = return (emptyFloats env + , extendIdSubst env bndr (DoneEx scrut NotJoinPoint)) + -- See Note [Do not duplicate constructor applications] + | otherwise = do { dc_args <- mapM (simplInVar env) bs + -- dc_ty_args are already OutTypes, + -- but bs are InBndrs + ; let con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` dc_args + ; simplAuxBind "case-bndr" env bndr con_app } + +------------------- +missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont + -> SimplM (SimplFloats, OutExpr) + -- This isn't strictly an error, although it is unusual. + -- It's possible that the simplifier might "see" that + -- an inner case has no accessible alternatives before + -- it "sees" that the entire branch of an outer case is + -- inaccessible. So we simply put an error case here instead. +missingAlt env case_bndr _ cont + = warnPprTrace True "missingAlt" (ppr case_bndr) $ + -- See Note [Avoiding space leaks in OutType] + let cont_ty = contResultType cont + in seqType cont_ty `seq` + return (emptyFloats env, mkImpossibleExpr cont_ty "Simplify.Iteration.missingAlt") + +{- +************************************************************************ +* * +\subsection{Duplicating continuations} +* * +************************************************************************ + +Consider + let x* = case e of { True -> e1; False -> e2 } + in b +where x* is a strict binding. Then mkDupableCont will be given +the continuation + case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop +and will split it into + dupable: case [] of { True -> $j1; False -> $j2 } ; stop + join floats: $j1 = e1, $j2 = e2 + non_dupable: let x* = [] in b; stop + +Putting this back together would give + let x* = let { $j1 = e1; $j2 = e2 } in + case e of { True -> $j1; False -> $j2 } + in b +(Of course we only do this if 'e' wants to duplicate that continuation.) +Note how important it is that the new join points wrap around the +inner expression, and not around the whole thing. + +In contrast, any let-bindings introduced by mkDupableCont can wrap +around the entire thing. + +Note [Bottom alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + case (case x of { A -> error .. ; B -> e; C -> error ..) + of alts +then we can just duplicate those alts because the A and C cases +will disappear immediately. This is more direct than creating +join points and inlining them away. See #4930. +-} + +-------------------- +mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont + -> SimplM ( SimplFloats -- Join points (if any) + , SimplEnv -- Use this for the alts + , SimplCont) +mkDupableCaseCont env alts cont + | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont + ; let env' = bumpCaseDepth $ + env `setInScopeFromF` floats + ; return (floats, env', cont) } + | otherwise = return (emptyFloats env, env, cont) + +altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative +altsWouldDup [] = False -- See Note [Bottom alternatives] +altsWouldDup [_] = False +altsWouldDup (alt:alts) + | is_bot_alt alt = altsWouldDup alts + | otherwise = not (all is_bot_alt alts) + -- otherwise case: first alt is non-bot, so all the rest must be bot + where + is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs + +------------------------- +mkDupableCont :: SimplEnv + -> SimplCont + -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with + -- extra let/join-floats and in-scope variables + , SimplCont) -- dup_cont: duplicable continuation +mkDupableCont env cont + = mkDupableContWithDmds (zapSubstEnv env) (repeat topDmd) cont + +mkDupableContWithDmds + :: SimplEnvIS -> [Demand] -- Demands on arguments; always infinite + -> SimplCont -> SimplM ( SimplFloats, SimplCont) + +mkDupableContWithDmds env _ cont + -- Check the invariant + | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) False + = pprPanic "mkDupableContWithDmds" empty + + | contIsDupable cont + = return (emptyFloats env, cont) + +mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn + +mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, CastIt { sc_co = optOutCoercion env co opt + , sc_opt = True, sc_cont = cont' }) } + -- optOutCoercion: see Note [Avoid re-simplifying coercions] + +-- Duplicating ticks for now, not sure if this is good or not +mkDupableContWithDmds env dmds (TickIt t cont) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, TickIt t cont') } + +mkDupableContWithDmds env _ + (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what + , sc_env = se, sc_cont = cont}) +-- See Note [Duplicating StrictBind] +-- K[ let x = <> in b ] --> join j x = K[ b ] +-- j <> + = do { let sb_env = se `setInScopeFromE` env + ; (sb_env1, bndr') <- simplBinder sb_env bndr + ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont + -- No need to use mkDupableCont before simplNonRecBody; we + -- use cont once here, and then share the result if necessary + + ; let join_body = wrapFloats floats1 join_inner + res_ty = contResultType cont + + ; mkDupableStrictBind env bndr' join_body res_ty } + +mkDupableContWithDmds env _ + (StrictArg { sc_fun = fun, sc_cont = cont + , sc_fun_ty = fun_ty }) + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + | isNothing (isDataConId_maybe (ai_fun fun)) + -- isDataConId: see point (DJ4) of Note [Duplicating join points] + , thumbsUpPlanA cont + = -- Use Plan A of Note [Duplicating StrictArg] +-- pprTrace "Using plan A" (ppr (ai_fun fun) $$ text "args" <+> ppr (ai_args fun) $$ text "cont" <+> ppr cont) $ + do { let _ :| dmds = expectNonEmpty $ ai_dmds fun + ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + -- Use the demands from the function to add the right + -- demand info on any bindings we make for further args + ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env) + (ai_args fun) + ; return ( foldl' addLetFloats floats1 floats_s + , StrictArg { sc_fun = fun { ai_args = args' } + , sc_cont = cont' + , sc_fun_ty = fun_ty + , sc_dup = OkToDup} ) } + + | otherwise + = -- Use Plan B of Note [Duplicating StrictArg] + -- K[ f a b <> ] --> join j x = K[ f a b x ] + -- j <> + do { let rhs_ty = contResultType cont + (m,arg_ty,_) = splitFunTy fun_ty + ; arg_bndr <- newId (fsLit "arg") m arg_ty + ; let env' = env `addNewInScopeIds` [arg_bndr] + ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont + ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } + where + thumbsUpPlanA (StrictArg {}) = False + thumbsUpPlanA (StrictBind {}) = True + thumbsUpPlanA (Stop {}) = True + thumbsUpPlanA (Select {}) = True + thumbsUpPlanA (CastIt { sc_cont = k }) = thumbsUpPlanA k + thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k + thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k + thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k + +mkDupableContWithDmds env dmds + (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, ApplyToTy { sc_cont = cont' + , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env dmds + (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se + , sc_cont = cont, sc_hole_ty = hole_ty }) + = -- e.g. [...hole...] (...arg...) + -- ==> + -- let a = ...arg... + -- in [...hole...] a + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { let dmd:|cont_dmds = expectNonEmpty dmds + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont + ; let env' = env `setInScopeFromF` floats1 + ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg + ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' + ; let all_floats = floats1 `addLetFloats` let_floats2 + ; return ( all_floats + , ApplyToVal { sc_arg = arg'' + , sc_env = se' `setInScopeFromF` all_floats + -- Ensure that sc_env includes the free vars of + -- arg'' in its in-scope set, even if makeTrivial + -- has turned arg'' into a fresh variable + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup, sc_cont = cont' + , sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env _ + (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) + = -- e.g. (case [...hole...] of { pi -> ei }) + -- ===> + -- let ji = \xij -> ei + -- in case [...hole...] of { pi -> ji xij } + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { tick (CaseOfCase case_bndr) + ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont + -- NB: We call mkDupableCaseCont here to make cont duplicable + -- (if necessary, depending on the number of alts) + -- And this is important: see Note [Fusing case continuations] + + ; let cont_scaling = contHoleScaling cont + -- See Note [Scaling in case-of-case] + ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr) + ; alts' <- forM (scaleAltsBy cont_scaling alts) $ + simplAlt alt_env' Nothing [] case_bndr' NoBinderSwap alt_cont + -- Safe to say that there are no handled-cons for the DEFAULT case + -- NB: simplBinder does not zap deadness occ-info, so + -- a dead case_bndr' will still advertise its deadness + -- This is really important because in + -- case e of b { (# p,q #) -> ... } + -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), + -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. + -- In the new alts we build, we have the new case binder, so it must retain + -- its deadness. + -- NB: we don't use alt_env further; it has the substEnv for + -- the alternatives, and we don't want that + + ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt env case_bndr') + emptyJoinFloats alts' + + ; let all_floats = floats `addJoinFloats` join_floats + -- Note [Duplicated env] + ; return (all_floats + , Select { sc_dup = OkToDup + , sc_bndr = case_bndr' + , sc_alts = alts'' + , sc_env = zapSubstEnv se `setInScopeFromF` all_floats + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_cont = mkBoringStop (contResultType cont) } ) } + +mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType + -> SimplM (SimplFloats, SimplCont) +mkDupableStrictBind env arg_bndr join_rhs res_ty + | uncondInlineJoin [arg_bndr] join_rhs + -- See point (DJ2) of Note [Duplicating join points] + = return (emptyFloats env + , StrictBind { sc_bndr = arg_bndr + , sc_body = join_rhs + , sc_env = zapSubstEnv env + , sc_from = FromLet + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup + , sc_cont = mkBoringStop res_ty } ) + | otherwise + = do { join_bndr <- newJoinId [arg_bndr] res_ty + ; let arg_info = ArgInfo { ai_fun = join_bndr + , ai_rules = [], ai_args = [] + , ai_encl = False, ai_dmds = repeat topDmd + , ai_discs = repeat 0 } + ; return ( addJoinFloats (emptyFloats env) $ + unitJoinFloat $ + NonRec join_bndr $ + Lam (setOneShotLambda arg_bndr) join_rhs + , StrictArg { sc_dup = OkToDup + , sc_fun = arg_info + , sc_fun_ty = idType join_bndr + , sc_cont = mkBoringStop res_ty + } ) } + +mkDupableAlt :: SimplEnv -> OutId + -> JoinFloats -> OutAlt + -> SimplM (JoinFloats, OutAlt) +mkDupableAlt _env case_bndr jfloats (Alt con alt_bndrs alt_rhs_in) + | uncondInlineJoin alt_bndrs alt_rhs_in + -- See point (DJ2) of Note [Duplicating join points] + = return (jfloats, Alt con alt_bndrs alt_rhs_in) + + | otherwise + = do { let rhs_ty' = exprType alt_rhs_in + + bangs + | DataAlt c <- con + = dataConRepStrictness c + | otherwise = [] + + abstracted_binders = abstract_binders alt_bndrs bangs + + abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)] + abstract_binders [] [] + -- Abstract over the case binder too if it's used. + | isDeadBinder case_bndr = [] + | otherwise = [(case_bndr,MarkedStrict)] + abstract_binders (alt_bndr:alt_bndrs) marks + -- Abstract over all type variables just in case + | isTyVar alt_bndr = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks + abstract_binders (alt_bndr:alt_bndrs) (mark:marks) + -- The deadness info on the new Ids is preserved by simplBinders + -- We don't abstract over dead ids here. + | isDeadBinder alt_bndr = abstract_binders alt_bndrs marks + | otherwise = (alt_bndr,mark) : abstract_binders alt_bndrs marks + abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in) + + filtered_binders = map fst abstracted_binders + -- We want to make any binder with an evaldUnfolding strict in the rhs. + -- See Note [Call-by-value for worker args] (which also applies to join points) + rhs_with_seqs = mkStrictFieldSeqs abstracted_binders alt_rhs_in + + final_args = varsToCoreExprs filtered_binders + -- Note [Join point abstraction] + + -- We make the lambdas into one-shot-lambdas. The + -- join point is sure to be applied at most once, and doing so + -- prevents the body of the join point being floated out by + -- the full laziness pass + final_bndrs = map one_shot filtered_binders + one_shot v | isId v = setOneShotLambda v + | otherwise = v + + -- No lambda binder has an unfolding, but (currently) case binders can, + -- so we must zap them here. + join_rhs = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs + + ; join_bndr <- newJoinId filtered_binders rhs_ty' + ; let -- join_bndr_w_unf = join_bndr `setIdUnfolding` + -- mkUnfolding uf_opts VanillaSrc False False join_rhs Nothing + -- See Note [Do not add unfoldings to join points at birth] + join_call = mkApps (Var join_bndr) final_args + alt' = Alt con alt_bndrs join_call + + ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) + , alt') } + -- See Note [Duplicated env] + +{- +Note [Do not add unfoldings to join points at birth] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#15360) + + case (case (case (case ...))) of + Left x -> e1 + Right y -> e2 + +We will make a join point for e1, e2, thus + $j1a x = e1 + $j1b y = e2 + +Now those join point calls count as "duplicable" , so we feel free to duplicate +them into the loop nest. And each of those calls are then subject to +callSiteInline, which might inline them, if e1, e2 are reasonably small. Now, +if this applies recursive to the next `case` inwards, and so on, the net +effect is that we can get an exponential number of calls to $j1a and $j1b, and +an exponential number of inlinings (since each is done independently). + +This hit #15360 (not a complicated program!) badly. Our simple solution is this: +when a join point is born, we don't give it an unfolding, so it will not be inlined +at its call sites, at least not in that pass. So we end up with + $j1a x = e1 + $j1b y = e2 + $j2a x = ...$j1a ... $j1b... + $j2b x = ...$j1a ... $j1b... + ... and so on... + +In the next iteration of the Simplifier we are into Note [Avoid inlining into +deeply nested cases] in Simplify.Inline, which is still a challenge. But at +least we have a chance. If we add inlinings at birth we never get that chance. + +Wrinkle + +(JU1) It turns out that the same problem shows up in a different guise, via + Note [Post-inline for single-use things] in Simplify.Utils. I think + we have something like + case K (join $j x = in jblah) of K y{OneOcc} -> blah + where $j is a freshly-born join point. After case-of-known-constructor + wo we end up substituting (join $j x = in jblah) for `y` in `blah`; + and thus we re-simplify that join binding. In test T15630 this results in + massive duplication. + + So in `simplLetUnfolding` we spot this case a bit hackily; a freshly-born + join point will have OccInfo of ManyOccs, unlike an existing join point which + will have OneOcc. So in simplLetUnfolding we kill the unfolding of a freshly + born join point. + +I can't quite articulate precisely why this is so important. But it makes a +MASSIVE difference in T15630 (a fantastic test case); and at worst it'll merely +delay inlining join points by one simplifier iteration. + +In effect (JU1) just extends the original Note [Do not add unfoldings to join +points at birth] to occasions where we re-visit the same join-point in the same +Simplifier iteration. + +Note [Fusing case continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to fuse two successive case continuations when the +first has one alternative. That's why we call prepareCaseCont here. +Consider this, which arises from thunk splitting (see Note [Thunk +splitting] in GHC.Core.Opt.WorkWrap): + + let + x* = case (case v of {pn -> rn}) of + I# a -> I# a + in body + +The simplifier will find + (Var v) with continuation + Select (pn -> rn) ( + Select [I# a -> I# a] ( + StrictBind body Stop + +So we'll call mkDupableCont on + Select [I# a -> I# a] (StrictBind body Stop) +There is just one alternative in the first Select, so we want to +simplify the rhs (I# a) with continuation (StrictBind body Stop) +Supposing that body is big, we end up with + let $j a = + in case v of { pn -> case rn of + I# a -> $j a } +This is just what we want because the rn produces a box that +the case rn cancels with. + +See #4957 a fuller example. + +Note [Duplicating join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #19996 we discovered that we want to be really careful about +inlining join points. Consider + case (join $j x = K f x ) + (in case v of ) + ( p1 -> $j x1 ) of + ( p2 -> $j x2 ) + ( p3 -> $j x3 ) + K g y -> blah[g,y] + +Here the join-point RHS is very small, just a constructor +application (K f x). So we might inline it to get + case (case v of ) + ( p1 -> K f x1 ) of + ( p2 -> K f x2 ) + ( p3 -> K f x3 ) + K g y -> blah[g,y] + +But now we have to make `blah` into a join point, /abstracted/ +over `g` and `y`. We get + join $j2 g y = blah + in case v of + p1 -> $j2 f x1 + p2 -> $j2 f x2 + p3 -> $j2 f x3 +So now we can't see that `g` is always `f` in `blah`. + +In contrast, if we /don't/ inline $j we +don't need a new join point for `blah` and we'll get + join $j' x = let g=f, y=x in blah[g,y] + in case v of + p1 -> $j' x1 + p2 -> $j' x2 + p3 -> $j' x3 + +This can make a /massive/ difference, because `blah` can see +what `f` is, instead of lambda-abstracting over it. + +If instead the RHS of the join point is a simple application that has no free +variables, as in + + case (join $j x f = K f x ) + (in case v of ) + ( p1 -> $j x1 f1 ) of + ( p2 -> $j x2 f2 ) + ( p3 -> $j x3 f3 ) + K g y -> blah[g,y] + +then no information can be gained by preserving the join point (c.f. `f` being +free in the join point above and being useful to `blah`). In this case, it's +more beneficial to inline the join point (see (DJ3)(c)) to allow further +optimisations to fire. An example where failing to do this went wrong is #25723. + +Beyond this, not-inlining join points reduces duplication. In the above +example, if `blah` was small enough we'd inline it, but that duplicates code, +for no gain. Best just to keep not-inline the join point in the first place. +So not-inlining join points is our default: but see Note [Inlining join points] +in GHC.Core.Opt.Simplify.Inline for when we /do/ inline them. + +To achieve this parsimonious inlining of join points, we need to do two things: +(a) create a join point even if the RHS is small; and (b) don't do +unconditional-inlining for join points. + +(DJ1) Do not postInlineUnconditionally a join point, ever. Doing + postInlineUnconditionally is primarily to push allocation into cold + branches; but a join point doesn't allocate, so that's a non-motivation. + +(DJ2) In mkDupableAlt and mkDupableStrictBind, generate an alterative for /all/ + alternatives, /except/ for ones that will definitely inline unconditionally + straight away. (In that case it's silly to make a join point in the first + place; it just takes an extra Simplifier iteration to undo.) This choice is + made by GHC.Core.Unfold.uncondInlineJoin. + + This plan generates a lot of join points, but makes them much more + case-of-case friendly. + +(DJ3) When should `uncondInlineJoin` return True? + (a) (exprIsTrivial rhs); this includes uses of unsafeEqualityProof etc; see + the defn of exprIsTrivial. Also nullary constructors. + + (b) The RHS is a call ($j x y z), where the arguments are all trivial and $j + is a join point: there is no point in creating an indirection. + + (c) The RHS is a data constructor application (K x y z) where + + - all the args x,y,z are trivial + - the free LocalIds of `f x y z` are a subset of the join point binders + + Examples that return True + $j x y = K y (x |> co) + $j x y = x (y @Int) + Examples that return False + $j x = K y x -- y is free + $j y = f y -- f is free + + Not duplicating these join points has no benefits and blocks other important + optimisations from firing (see #25723) + +(DJ4) By the same token we want to use Plan B in Note [Duplicating StrictArg] when + the RHS of the new join point is a data constructor application. See the + call to isDataConId in the StrictArg case of mkDupableContWithDmds. + + That same Note [Duplicating StrictArg] explains why we sometimes want Plan A + when the RHS of the new join point would be a non-data-constructor + application + +(DJ5) You might worry that $j = K x y might look so small that it is inlined + by the call site inliner, defeating (DJ3). But in fact + + - The UnfoldingGuidance for a join point is only UnfWhen (unconditional) + if `uncondInlineJoin` is true; see GHC.Core.Unfold.uncondInline + + - `GHC.Core.Opt.Simplify.Inline.tryUnfolding` has a special case for join + points, described Note [Inlining join points] in that module. + +Historical Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: this entire Note is now irrelevant. In Jun 21 we stopped +adding unfoldings to lambda binders (#17530). It was always a +hack and bit us in multiple small and not-so-small ways + +Consider this + case (case .. ) of c { + I# c# -> ....c.... + +If we make a join point with c but not c# we get + $j = \c -> ....c.... + +But if later inlining scrutinises the c, thus + + $j = \c -> ... case c of { I# y -> ... } ... + +we won't see that 'c' has already been scrutinised. This actually +happens in the 'tabulate' function in wave4main, and makes a significant +difference to allocation. + +An alternative plan is this: + + $j = \c# -> let c = I# c# in ...c.... + +but that is bad if 'c' is *not* later scrutinised. + +So instead we do both: we pass 'c' and 'c#' , and record in c's inlining +(a stable unfolding) that it's really I# c#, thus + + $j = \c# -> \c[=I# c#] -> ...c.... + +Absence analysis may later discard 'c'. + +NB: take great care when doing strictness analysis; + see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal. + +Also note that we can still end up passing stuff that isn't used. Before +strictness analysis we have + let $j x y c{=(x,y)} = (h c, ...) + in ... +After strictness analysis we see that h is strict, we end up with + let $j x y c{=(x,y)} = ($wh x y, ...) +and c is unused. + +Note [Duplicated env] +~~~~~~~~~~~~~~~~~~~~~ +Some of the alternatives are simplified, but have not been turned into a join point +So they *must* have a zapped subst-env. So we can't use completeNonRecX to +bind the join point, because it might to do PostInlineUnconditionally, and +we'd lose that when zapping the subst-env. We could have a per-alt subst-env, +but zapping it (as we do in mkDupableCont, the Select case) is safe, and +at worst delays the join-point inlining. + +Note [Funky mkLamTypes] +~~~~~~~~~~~~~~~~~~~~~~ +Notice the funky mkLamTypes. If the constructor has existentials +it's possible that the join point will be abstracted over +type variables as well as term variables. + Example: Suppose we have + data T = forall t. C [t] + Then faced with + case (case e of ...) of + C t xs::[t] -> rhs + We get the join point + let j :: forall t. [t] -> ... + j = /\t \xs::[t] -> rhs + in + case (case e of ...) of + C t xs::[t] -> j t xs + +Note [Duplicating StrictArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dealing with making a StrictArg continuation duplicable has turned out +to be one of the trickiest corners of the simplifier, giving rise +to several cases in which the simplier expanded the program's size +*exponentially*. They include + #13253 exponential inlining + #10421 ditto + #18140 strict constructors + #18282 another nested-function call case + +Suppose we have a call + f e1 (case x of { True -> r1; False -> r2 }) e3 +and f is strict in its second argument. Then we end up in +mkDupableCont with a StrictArg continuation for (f e1 <> e3). +There are two ways to make it duplicable. + +* Plan A: move the entire call inwards, being careful not + to duplicate e1 or e3, thus: + let a1 = e1 + a3 = e3 + in case x of { True -> f a1 r1 a3 + ; False -> f a1 r2 a3 } + +* Plan B: make a join point: + join $j x = f e1 x e3 + in case x of { True -> jump $j r1 + ; False -> jump $j r2 } + + Notice that Plan B is very like the way we handle strict bindings; + see Note [Duplicating StrictBind]. And Plan B is exactly what we'd + get if we turned use a case expression to evaluate the strict arg: + + case (case x of { True -> r1; False -> r2 }) of + r -> f e1 r e3 + + So, looking at Note [Duplicating join points], we also want Plan B + when `f` is a data constructor. + +Plan A is often good: + +* The calls to `f` may well be able to inline, since they are now applied + to more informative arguments, `r1`, `r2`. For example: + && E (case x of { T -> F; F -> T }) + Pushing the call inward (being careful not to duplicate E) we get + let a = E + in case x of { T -> && a F; F -> && a T } + and now the (&& a F) etc can optimise. + +* Moreover there might be a RULE for the function that can fire when it "sees" + the particular case alternative. + +* More specialisation can happen. Here's an example from #3116 + go (n+1) (case l of + 1 -> bs' + _ -> Chunk p fpc (o+1) (l-1) bs') + + If we pushed the entire call for 'go' inside the case, we get + call-pattern specialisation for 'go', which is *crucial* for + this particular program. + +But Plan A can have terrible, terrible behaviour. Here is a classic +case: + f (f (f (f (f True)))) + +Suppose f is strict, and has a body that is small enough to inline. +The innermost call inlines (seeing the True) to give + f (f (f (f (case v of { True -> e1; False -> e2 })))) + +Now, suppose we naively push the entire continuation into both +case branches (it doesn't look large, just f.f.f.f). We get + case v of + True -> f (f (f (f e1))) + False -> f (f (f (f e2))) + +And now the process repeats, so we end up with an exponentially large +number of copies of f. No good! + +CONCLUSION: we want Plan A in general, but do Plan B is there a +danger of this nested call behaviour. The function that decides +this is called thumbsUpPlanA. + +Note [Keeping demand info in StrictArg Plan A] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Following on from Note [Duplicating StrictArg], another common code +pattern that can go bad is this: + f (case x1 of { T -> F; F -> T }) + (case x2 of { T -> F; F -> T }) + ...etc... +when f is strict in all its arguments. (It might, for example, be a +strict data constructor whose wrapper has not yet been inlined.) + +We use Plan A (because there is no nesting) giving + let a2 = case x2 of ... + a3 = case x3 of ... + in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... } + +Now we must be careful! a2 and a3 are small, and the OneOcc code in +postInlineUnconditionally may inline them both at both sites; see Note +Note [Inline small things to avoid creating a thunk] in +Simplify.Utils. But if we do inline them, the entire process will +repeat -- back to exponential behaviour. + +So we are careful to keep the demand-info on a2 and a3. Then they'll +be /strict/ let-bindings, which will be dealt with by StrictBind. +That's why contIsDupableWithDmds is careful to propagage demand +info to the auxiliary bindings it creates. See the Demand argument +to makeTrivial. + +Note [Duplicating StrictBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We make a StrictBind duplicable in a very similar way to +that for case expressions. After all, + let x* = e in b is similar to case e of x -> b + +So we potentially make a join-point for the body, thus: + let x = <> in b ==> join j x = b + in j <> + +Just like StrictArg in fact -- and indeed they share code. + +Note [Join point abstraction] Historical note +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: This note is now historical, describing how (in the past) we used +to add a void argument to nullary join points. But now that "join +point" is not a fuzzy concept but a formal syntactic construct (as +distinguished by the JoinId constructor of IdDetails), each of these +concerns is handled separately, with no need for a vestigial extra +argument. + +Join points always have at least one value argument, +for several reasons + +* If we try to lift a primitive-typed something out + for let-binding-purposes, we will *caseify* it (!), + with potentially-disastrous strictness results. So + instead we turn it into a function: \v -> e + where v::Void#. The value passed to this function is void, + which generates (almost) no code. + +* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now + we make the join point into a function whenever used_bndrs' + is empty. This makes the join-point more CPR friendly. + Consider: let j = if .. then I# 3 else I# 4 + in case .. of { A -> j; B -> j; C -> ... } + + Now CPR doesn't w/w j because it's a thunk, so + that means that the enclosing function can't w/w either, + which is a lose. Here's the example that happened in practice: + kgmod :: Int -> Int -> Int + kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 + then 78 + else 5 + +* Let-no-escape. We want a join point to turn into a let-no-escape + so that it is implemented as a jump, and one of the conditions + for LNE is that it's not updatable. In CoreToStg, see + Note [What is a non-escaping let] + +* Floating. Since a join point will be entered once, no sharing is + gained by floating out, but something might be lost by doing + so because it might be allocated. + +I have seen a case alternative like this: + True -> \v -> ... +It's a bit silly to add the realWorld dummy arg in this case, making + $j = \s v -> ... + True -> $j s +(the \v alone is enough to make CPR happy) but I think it's rare + +There's a slight infelicity here: we pass the overall +case_bndr to all the join points if it's used in *any* RHS, +because we don't know its usage in each RHS separately + + + +************************************************************************ +* * + Unfoldings +* * +************************************************************************ +-} + +simplLetUnfolding :: SimplEnv + -> BindContext + -> InId + -> OutExpr -> OutType -> ArityType + -> Unfolding -> SimplM Unfolding +simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf + | isStableUnfolding unf + = simplStableUnfolding env bind_cxt id rhs_ty arity unf + + | freshly_born_join_point id + = -- This is a tricky one! + -- See wrinkle (JU1) in Note [Do not add unfoldings to join points at birth] + return noUnfolding + + | isExitJoinId id + = -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify + return noUnfolding + + | otherwise + = mkLetUnfolding env (bindContextLevel bind_cxt) VanillaSrc id is_join_point new_rhs + + where + is_join_point = isJoinId id + freshly_born_join_point id = is_join_point && isManyOccs (idOccInfo id) + -- OLD: too_many_occs (OneOcc { occ_n_br = n }) = n > 10 -- See #23627 + +------------------- +mkLetUnfolding :: SimplEnv -> TopLevelFlag -> UnfoldingSource + -> InId -> Bool -- True <=> this is a join point + -> OutExpr -> SimplM Unfolding +mkLetUnfolding env top_lvl src id is_join new_rhs + = return (mkUnfolding uf_opts src is_top_lvl is_bottoming is_join new_rhs Nothing) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In GHC.Iface.Tidy we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. + where + -- !opts: otherwise, we end up retaining all the SimpleEnv + !uf_opts = seUnfoldingOpts env + + -- Might as well force this, profiles indicate up to + -- 0.5MB of thunks just from this site. + !is_top_lvl = isTopLevel top_lvl + -- See Note [Force bottoming field] + !is_bottoming = isDeadEndId id + +------------------- +simplStableUnfolding :: SimplEnv -> BindContext + -> InId + -> OutType + -> ArityType -- Used to eta expand, but only for non-join-points + -> Unfolding + ->SimplM Unfolding +-- Note [Setting the new unfolding] +simplStableUnfolding env bind_cxt id rhs_ty id_arity unf + = case unf of + NoUnfolding -> return unf + BootUnfolding -> return unf + OtherCon {} -> return unf + + DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } + -> do { (env', bndrs') <- simplBinders unf_env bndrs + ; args' <- mapM (simplExpr env') args + ; return (mkDFunUnfolding bndrs' con args') } + + CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } + | isStableSource src + -> do { expr' <- case bind_cxt of + BC_Join _ cont -> -- Binder is a join point + -- See Note [Rules and unfolding for join points] + simplJoinRhs unf_env id expr cont + BC_Let _ is_rec -> -- Binder is not a join point + do { let cont = mkRhsStop rhs_ty is_rec topDmd + -- mkRhsStop: switch off eta-expansion at the top level + ; expr' <- simplExprC unf_env expr cont + ; return (eta_expand expr') } + ; case guide of + UnfWhen { ug_boring_ok = boring_ok } + -- Happens for INLINE things + -- Really important to force new_boring_ok since otherwise + -- `ug_boring_ok` is a thunk chain of + -- inlineBoringExprOk expr0 || inlineBoringExprOk expr1 || ... + -- See #20134 + -> let !new_boring_ok = boring_ok || inlineBoringOk expr' + guide' = guide { ug_boring_ok = new_boring_ok } + -- Refresh the boring-ok flag, in case expr' + -- has got small. This happens, notably in the inlinings + -- for dfuns for single-method classes; see + -- Note [Single-method classes] in GHC.Tc.TyCl.Instance. + -- A test case is #4138 + -- But retain a previous boring_ok of True; e.g. see + -- the way it is set in calcUnfoldingGuidanceWithArity + in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide') + -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold + + _other -- Happens for INLINABLE things + -> mkLetUnfolding env top_lvl src id False expr' } + -- If the guidance is UnfIfGoodArgs, this is an INLINABLE + -- unfolding, and we need to make sure the guidance is kept up + -- to date with respect to any changes in the unfolding. + + | otherwise -> return noUnfolding -- Discard unstable unfoldings + where + -- Forcing this can save about 0.5MB of max residency and the result + -- is small and easy to compute so might as well force it. + top_lvl = bindContextLevel bind_cxt + !is_top_lvl = isTopLevel top_lvl + act = idInlineActivation id + unf_env = updMode (updModeForStableUnfoldings act) env + -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils + + -- See Note [Eta-expand stable unfoldings] + -- Use the arity from the main Id (in id_arity), rather than computing it from rhs + -- Not used for join points + eta_expand expr | seEtaExpand env + , exprArity expr < arityTypeArity id_arity + , wantEtaExpansion expr + = etaExpandAT (getInScope env) id_arity expr + | otherwise + = expr + +{- Note [Eta-expand stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For INLINE/INLINABLE things (which get stable unfoldings) there's a danger +of getting + f :: Int -> Int -> Int -> Blah + [ Arity = 3 -- Good arity + , Unf=Stable (\xy. blah) -- Less good arity, only 2 + f = \pqr. e + +This can happen because f's RHS is optimised more vigorously than +its stable unfolding. Now suppose we have a call + g = f x +Because f has arity=3, g will have arity=2. But if we inline f (using +its stable unfolding) g's arity will reduce to 1, because +hasn't been optimised yet. This happened in the 'parsec' library, +for Text.Pasec.Char.string. + +Generally, if we know that 'f' has arity N, it seems sensible to +eta-expand the stable unfolding to arity N too. Simple and consistent. + +Wrinkles + +* See Historical-note [Eta-expansion in stable unfoldings] in + GHC.Core.Opt.Simplify.Utils + +* Don't eta-expand a trivial expr, else each pass will eta-reduce it, + and then eta-expand again. See Note [Which RHSs do we eta-expand?] + in GHC.Core.Opt.Simplify.Utils. + +* Don't eta-expand join points; see Note [Do not eta-expand join points] + in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point + case (bind_cxt = BC_Join {}) doesn't use eta_expand. + +Note [Force bottoming field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to force bottoming, or the new unfolding holds +on to the old unfolding (which is part of the id). + +Note [Setting the new unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If there's an INLINE pragma, we simplify the RHS gently. Maybe we + should do nothing at all, but simplifying gently might get rid of + more crap. + +* If not, we make an unfolding from the new RHS. But *only* for + non-loop-breakers. Making loop breakers not have an unfolding at all + means that we can avoid tests in exprIsConApp, for example. This is + important: if exprIsConApp says 'yes' for a recursive thing, then we + can get into an infinite loop + +If there's a stable unfolding on a loop breaker (which happens for +INLINABLE), we hang on to the inlining. It's pretty dodgy, but the +user did say 'INLINE'. May need to revisit this choice. + +************************************************************************ +* * + Rules +* * +************************************************************************ + +Note [Rules in a letrec] +~~~~~~~~~~~~~~~~~~~~~~~~ +After creating fresh binders for the binders of a letrec, we +substitute the RULES and add them back onto the binders; this is done +*before* processing any of the RHSs. This is important. Manuel found +cases where he really, really wanted a RULE for a recursive function +to apply in that function's own right-hand side. + +See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal" +-} + +addBndrRules :: SimplEnv -> InBndr -> OutBndr + -> BindContext + -> SimplM (SimplEnv, OutBndr) +-- Rules are added back into the bin +addBndrRules env in_id out_id bind_cxt + | null old_rules + = return (env, out_id) + | otherwise + = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt + ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules + ; return (modifyInScope env final_id, final_id) } + where + old_rules = ruleInfoRules (idSpecialisation in_id) + +simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule] +-- Simplify local rules for imported Ids +simplImpRules env rules + = simplRules env Nothing rules (BC_Let TopLevel NonRecursive) + +simplRules :: SimplEnv -> Maybe OutId -> [CoreRule] + -> BindContext -> SimplM [CoreRule] +simplRules env mb_new_id rules bind_cxt + = mapM simpl_rule rules + where + simpl_rule rule@(BuiltinRule {}) + = return rule + + simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs + , ru_act = act }) + = do { (env', bndrs') <- simplBinders env bndrs + ; let rhs_ty = substTy env' (exprType rhs) + rhs_cont = case bind_cxt of -- See Note [Rules and unfolding for join points] + BC_Let {} -> mkBoringStop rhs_ty + BC_Join _ cont -> assertPpr join_ok bad_join_msg cont + lhs_env = updMode updModeForRules env' + rhs_env = updMode (updModeForStableUnfoldings act) env' + -- See Note [Simplifying the RHS of a RULE] + -- Force this to avoid retaining reference to old Id + !fn_name' = case mb_new_id of + Just id -> idName id + Nothing -> fn_name + + -- join_ok is an assertion check that the join-arity of the + -- binder matches that of the rule, so that pushing the + -- continuation into the RHS makes sense + join_ok = case mb_new_id of + Just id | JoinPoint join_arity <- idJoinPointHood id + -> length args == join_arity + _ -> False + bad_join_msg = vcat [ ppr mb_new_id, ppr rule + , ppr (fmap idJoinPointHood mb_new_id) ] + + ; args' <- mapM (simplExpr lhs_env) args + ; rhs' <- simplExprC rhs_env rhs rhs_cont + ; return (rule { ru_bndrs = bndrs' + , ru_fn = fn_name' + , ru_args = args' + , ru_rhs = occurAnalyseExpr rhs' }) } + -- Remember to occ-analyse, to drop dead code. + -- See Note [OccInfo in unfoldings and rules] in GHC.Core + +{- Note [Simplifying the RHS of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can simplify the RHS of a RULE much as we do the RHS of a stable +unfolding. We used to use the much more conservative updModeForRules +for the RHS as well as the LHS, but that seems more conservative +than necesary. Allowing some inlining might, for example, eliminate +a binding. +-} diff --git a/GHC/Core/Opt/Simplify/Monad.hs b/GHC/Core/Opt/Simplify/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify/Monad.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE PatternSynonyms #-} +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} +-} + +module GHC.Core.Opt.Simplify.Monad ( + -- The monad + TopEnvConfig(..), SimplM, + initSmpl, traceSmpl, + getSimplRules, + + -- Unique supply + MonadUnique(..), newId, newJoinId, + + -- Counting + SimplCount, tick, freeTick, checkedTick, + getSimplCount, zeroSimplCount, pprSimplCount, + plusSimplCount, isZeroSimplCount + ) where + +import GHC.Prelude + +import GHC.Types.Var ( Var, isId, mkLocalVar ) +import GHC.Types.Name ( mkSystemVarName ) +import GHC.Types.Id ( Id, mkSysLocalOrCoVarM ) +import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) +import GHC.Core.Type ( Type, Mult ) +import GHC.Core.Opt.Stats +import GHC.Core.Rules +import GHC.Core.Utils ( mkLamTypes ) +import GHC.Types.Unique.Supply +import GHC.Driver.Flags +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Monad +import GHC.Utils.Logger as Logger +import GHC.Utils.Misc ( count ) +import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..)) +import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) +import Control.Monad ( ap ) +import GHC.Core.Multiplicity ( pattern ManyTy ) +import GHC.Exts( oneShot ) + +{- +************************************************************************ +* * +\subsection{Monad plumbing} +* * +************************************************************************ +-} + +newtype SimplM result + = SM' { unSM :: SimplTopEnv + -> SimplCount + -> IO (result, SimplCount)} + -- We only need IO here for dump output, but since we already have it + -- we might as well use it for uniques. + +pattern SM :: (SimplTopEnv -> SimplCount + -> IO (result, SimplCount)) + -> SimplM result +-- This pattern synonym makes the simplifier monad eta-expand, +-- which as a very beneficial effect on compiler performance +-- (worth a 1-2% reduction in bytes-allocated). See #18202. +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern SM m <- SM' m + where + SM m = SM' (oneShot $ \env -> oneShot $ \ct -> m env ct) + +-- See Note [The environments of the Simplify pass] +data TopEnvConfig = TopEnvConfig + { te_history_size :: !Int + , te_tick_factor :: !Int + } + +data SimplTopEnv + = STE { -- See Note [The environments of the Simplify pass] + st_config :: !TopEnvConfig + , st_logger :: !Logger + , st_max_ticks :: !IntWithInf -- ^ Max #ticks in this simplifier run + , st_read_ruleenv :: !(IO RuleEnv) + -- ^ The action to retrieve an up-to-date EPS RuleEnv + -- See Note [Overall plumbing for rules] + } + +initSmpl :: Logger + -> IO RuleEnv + -> TopEnvConfig + -> Int -- ^ Size of the bindings, used to limit the number of ticks we allow + -> SimplM a + -> IO (a, SimplCount) + +initSmpl logger read_ruleenv cfg size m + = do -- No init count; set to 0 + let simplCount = zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats + unSM m env simplCount + where + env = STE { st_config = cfg + , st_logger = logger + , st_max_ticks = computeMaxTicks cfg size + , st_read_ruleenv = read_ruleenv + } + +computeMaxTicks :: TopEnvConfig -> Int -> IntWithInf +-- Compute the max simplifier ticks as +-- (base-size + pgm-size) * magic-multiplier * tick-factor/100 +-- where +-- magic-multiplier is a constant that gives reasonable results +-- base-size is a constant to deal with size-zero programs +computeMaxTicks cfg size + = treatZeroAsInf $ + fromInteger ((toInteger (size + base_size) + * toInteger (tick_factor * magic_multiplier)) + `div` 100) + where + tick_factor = te_tick_factor cfg + base_size = 100 + magic_multiplier = 40 + -- MAGIC NUMBER, multiplies the simplTickFactor + -- We can afford to be generous; this is really + -- just checking for loops, and shouldn't usually fire + -- A figure of 20 was too small: see #5539. + +{-# INLINE thenSmpl #-} +{-# INLINE thenSmpl_ #-} +{-# INLINE returnSmpl #-} +{-# INLINE mapSmpl #-} + +instance Functor SimplM where + fmap = mapSmpl + +instance Applicative SimplM where + pure = returnSmpl + (<*>) = ap + (*>) = thenSmpl_ + +instance Monad SimplM where + (>>) = (*>) + (>>=) = thenSmpl + +mapSmpl :: (a -> b) -> SimplM a -> SimplM b +mapSmpl f m = thenSmpl m (returnSmpl . f) + +returnSmpl :: a -> SimplM a +returnSmpl e = SM (\_st_env sc -> return (e, sc)) + +thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b +thenSmpl_ :: SimplM a -> SimplM b -> SimplM b + +thenSmpl m k + = SM $ \st_env sc0 -> do + (m_result, sc1) <- unSM m st_env sc0 + unSM (k m_result) st_env sc1 + +thenSmpl_ m k + = SM $ \st_env sc0 -> do + (_, sc1) <- unSM m st_env sc0 + unSM k st_env sc1 + +-- TODO: this specializing is not allowed +-- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-} +-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-} +-- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-} + +traceSmpl :: String -> SDoc -> SimplM () +traceSmpl herald doc + = do logger <- getLogger + liftIO $ Logger.putDumpFileMaybe logger Opt_D_dump_simpl_trace "Simpl Trace" + FormatText + (hang (text herald) 2 doc) +{-# INLINE traceSmpl #-} -- see Note [INLINE conditional tracing utilities] + +{- +************************************************************************ +* * +\subsection{The unique supply} +* * +************************************************************************ +-} + +-- See Note [Uniques for wired-in prelude things and known tags] in GHC.Builtin.Uniques +simplTag :: Char +simplTag = 's' + +instance MonadUnique SimplM where + getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplTag + getUniqueM = liftIO $ uniqFromTag simplTag + +instance HasLogger SimplM where + getLogger = gets st_logger + +instance MonadIO SimplM where + liftIO = liftIOWithEnv . const + +getSimplRules :: SimplM RuleEnv +getSimplRules = liftIOWithEnv st_read_ruleenv + +liftIOWithEnv :: (SimplTopEnv -> IO a) -> SimplM a +liftIOWithEnv m = SM (\st_env sc -> do + x <- m st_env + return (x, sc)) + +gets :: (SimplTopEnv -> a) -> SimplM a +gets f = liftIOWithEnv (return . f) + +newId :: FastString -> Mult -> Type -> SimplM Id +newId fs w ty = mkSysLocalOrCoVarM fs w ty + +-- | Make a join id with given type and arity but without call-by-value annotations. +newJoinId :: [Var] -> Type -> SimplM Id +newJoinId bndrs body_ty + = do { uniq <- getUniqueM + ; let name = mkSystemVarName uniq (fsLit "$j") + join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes] + arity = count isId bndrs + -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core + join_arity = length bndrs + details = JoinId join_arity Nothing + id_info = vanillaIdInfo `setArityInfo` arity + + ; return (mkLocalVar details name ManyTy join_id_ty id_info) } + +{- +************************************************************************ +* * +\subsection{Counting up what we've done} +* * +************************************************************************ +-} + +getSimplCount :: SimplM SimplCount +getSimplCount = SM (\_st_env sc -> return (sc, sc)) + +tick :: Tick -> SimplM () +tick t = SM (\st_env sc -> let + history_size = te_history_size (st_config st_env) + sc' = doSimplTick history_size t sc + in sc' `seq` return ((), sc')) + +checkedTick :: Tick -> SimplM () +-- Try to take a tick, but fail if too many +checkedTick t + = SM (\st_env sc -> + if st_max_ticks st_env <= mkIntWithInf (simplCountN sc) + then throwGhcExceptionIO $ + PprProgramError "Simplifier ticks exhausted" (msg sc) + else let + history_size = te_history_size (st_config st_env) + sc' = doSimplTick history_size t sc + in sc' `seq` return ((), sc')) + where + msg sc = vcat + [ text "When trying" <+> ppr t + , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)." + , space + , text "In addition try adjusting -funfolding-case-threshold=N and" + , text "-funfolding-case-scaling=N for the module in question." + , text "Using threshold=1 and scaling=5 should break most inlining loops." + , space + , text "If you need to increase the tick factor substantially, while also" + , text "adjusting unfolding parameters please file a bug report and" + , text "indicate the factor you needed." + , space + , text "If GHC was unable to complete compilation even" + <+> text "with a very large factor" + , text "(a thousand or more), please consult the" + <+> doubleQuotes (text "Known bugs or infelicities") + , text "section in the Users Guide before filing a report. There are a" + , text "few situations unlikely to occur in practical programs for which" + , text "simplifier non-termination has been judged acceptable." + , space + , pp_details sc + , pprSimplCount sc ] + pp_details sc + | hasDetailedCounts sc = empty + | otherwise = text "To see detailed counts use -ddump-simpl-stats" + + +freeTick :: Tick -> SimplM () +-- Record a tick, but don't add to the total tick count, which is +-- used to decide when nothing further has happened +freeTick t + = SM (\_st_env sc -> let sc' = doFreeSimplTick t sc + in sc' `seq` return ((), sc')) diff --git a/GHC/Core/Opt/Simplify/Utils.hs b/GHC/Core/Opt/Simplify/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify/Utils.hs @@ -0,0 +1,2817 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +The simplifier utilities +-} + + + +module GHC.Core.Opt.Simplify.Utils ( + -- Rebuilding + rebuildLam, mkCase, prepareAlts, + tryEtaExpandRhs, wantEtaExpansion, + + -- Inlining, + preInlineUnconditionally, postInlineUnconditionally, + activeRule, + getUnfoldingInRuleMatch, + updModeForStableUnfoldings, updModeForRules, + + -- The BindContext type + BindContext(..), bindContextLevel, + + -- The continuation type + SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv, + isSimplified, contIsStop, + contIsDupable, contResultType, contHoleType, contHoleScaling, + contIsTrivial, contArgs, contIsRhs, + countArgs, contOutArgs, dropContArgs, + mkBoringStop, mkRhsStop, mkLazyArgStop, + interestingCallContext, + + -- ArgInfo + ArgInfo(..), ArgSpec(..), mkArgInfo, + addValArgTo, addTyArgTo, + argInfoExpr, argSpecArg, + pushSimplifiedArgs, + isStrictArgInfo, lazyArgContext, + + abstractFloats, + + -- Utilities + isExitJoinId + ) where + +import GHC.Prelude hiding (head, init, last, tail) +import qualified GHC.Prelude as Partial (head) + +import GHC.Core +import GHC.Types.Literal ( isLitRubbish ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Simplify.Inline( smallEnoughToInline ) +import GHC.Core.Opt.Stats ( Tick(..) ) +import qualified GHC.Core.Subst +import GHC.Core.Ppr +import GHC.Core.TyCo.Ppr ( pprParendType ) +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Opt.Arity +import GHC.Core.Unfold +import GHC.Core.Unfold.Make +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Type hiding( substTy ) +import GHC.Core.Coercion hiding( substCo ) +import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) +import GHC.Core.Multiplicity +import GHC.Core.Opt.ConstantFold + +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Tickish +import GHC.Types.Demand +import GHC.Types.Var.Set +import GHC.Types.Basic + +import GHC.Data.OrdList ( isNilOL ) +import GHC.Data.FastString ( fsLit ) + +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Monad ( when ) +import Data.List ( sortBy ) +import GHC.Types.Name.Env +import Data.Graph + +{- ********************************************************************* +* * + The BindContext type +* * +********************************************************************* -} + +-- What sort of binding is this? A let-binding or a join-binding? +data BindContext + = BC_Let -- A regular let-binding + TopLevelFlag RecFlag + + | BC_Join -- A join point with continuation k + RecFlag -- See Note [Rules and unfolding for join points] + SimplCont -- in GHC.Core.Opt.Simplify + +bindContextLevel :: BindContext -> TopLevelFlag +bindContextLevel (BC_Let top_lvl _) = top_lvl +bindContextLevel (BC_Join {}) = NotTopLevel + +bindContextRec :: BindContext -> RecFlag +bindContextRec (BC_Let _ rec_flag) = rec_flag +bindContextRec (BC_Join rec_flag _) = rec_flag + +isJoinBC :: BindContext -> Bool +isJoinBC (BC_Let {}) = False +isJoinBC (BC_Join {}) = True + + +{- ********************************************************************* +* * + The SimplCont and DupFlag types +* * +************************************************************************ + +A SimplCont allows the simplifier to traverse the expression in a +zipper-like fashion. The SimplCont represents the rest of the expression, +"above" the point of interest. + +You can also think of a SimplCont as an "evaluation context", using +that term in the way it is used for operational semantics. This is the +way I usually think of it, For example you'll often see a syntax for +evaluation context looking like + C ::= [] | C e | case C of alts | C `cast` co +That's the kind of thing we are doing here, and I use that syntax in +the comments. + + +Key points: + * A SimplCont describes a *strict* context (just like + evaluation contexts do). E.g. Just [] is not a SimplCont + + * A SimplCont describes a context that *does not* bind + any variables. E.g. \x. [] is not a SimplCont +-} + +data SimplCont + = Stop -- ^ Stop[e] = e + OutType -- ^ Type of the + CallCtxt -- ^ Tells if there is something interesting about + -- the syntactic context, and hence the inliner + -- should be a bit keener (see interestingCallContext) + -- Specifically: + -- This is an argument of a function that has RULES + -- Inlining the call might allow the rule to fire + -- Never ValAppCxt (use ApplyToVal instead) + -- or CaseCtxt (use Select instead) + SubDemand -- ^ The evaluation context of e. Tells how e is evaluated. + -- This fuels eta-expansion or eta-reduction without looking + -- at lambda bodies, for example. + -- + -- See Note [Eta reduction based on evaluation context] + -- The evaluation context for other SimplConts can be + -- reconstructed with 'contEvalContext' + + + | CastIt -- (CastIt co K)[e] = K[ e `cast` co ] + { sc_co :: OutCoercion -- The coercion simplified + -- Invariant: never an identity coercion + , sc_opt :: Bool -- True <=> sc_co has had optCoercion applied to it + -- See Note [Avoid re-simplifying coercions] + -- in GHC.Core.Opt.Simplify.Iteration + , sc_cont :: SimplCont } + + | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + -- See Note [The hole type in ApplyToTy] + , sc_arg :: InExpr -- The argument, + , sc_env :: StaticEnv -- see Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] + { sc_arg_ty :: OutType -- Argument type + , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + -- See Note [The hole type in ApplyToTy] + , sc_cont :: SimplCont } + + | Select -- (Select alts K)[e] = K[ case e of alts ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_bndr :: InId -- case binder + , sc_alts :: [InAlt] -- Alternatives + , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + -- The two strict forms have no DupFlag, because we never duplicate them + | StrictBind -- (StrictBind x b K)[e] = let x = e in K[b] + -- or, equivalently, = K[ (\x.b) e ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_from :: FromWhat + , sc_bndr :: InId + , sc_body :: InExpr + , sc_env :: StaticEnv -- Static env for both sc_bndr (stable unfolding thereof) + -- and sc_body. Also see Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] + { sc_dup :: DupFlag -- Always Simplified or OkToDup + , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc + -- plus demands and discount flags for *this* arg + -- and further args + -- So ai_dmds and ai_discs are never empty + , sc_fun_ty :: OutType -- Type of the function (f e1 .. en), + -- presumably (arg_ty -> res_ty) + -- where res_ty is expected by sc_cont + , sc_cont :: SimplCont } + + | TickIt -- (TickIt t K)[e] = K[ tick t e ] + CoreTickish -- Tick tickish + SimplCont + +type StaticEnv = SimplEnv -- Just the static part is relevant + +data FromWhat = FromLet | FromBeta Levity + +-- See Note [DupFlag invariants] +data DupFlag = NoDup -- Unsimplified, might be big + | Simplified -- Simplified + | OkToDup -- Simplified and small + +isSimplified :: DupFlag -> Bool +isSimplified NoDup = False +isSimplified _ = True -- Invariant: the subst-env is empty + +perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type +perhapsSubstTy dup env ty + | isSimplified dup = ty + | otherwise = substTy env ty + +{- Note [StaticEnv invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pair up an InExpr or InAlts with a StaticEnv, which establishes the +lexical scope for that InExpr. + +When we simplify that InExpr/InAlts, we use + - Its captured StaticEnv + - Overriding its InScopeSet with the larger one at the + simplification point. + +Why override the InScopeSet? Example: + (let y = ey in f) ex +By the time we simplify ex, 'y' will be in scope. + +However the InScopeSet in the StaticEnv is not irrelevant: it should +include all the free vars of applying the substitution to the InExpr. +Reason: contHoleType uses perhapsSubstTy to apply the substitution to +the expression, and that (rightly) gives ASSERT failures if the InScopeSet +isn't big enough. + +Note [DupFlag invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In both ApplyToVal { se_dup = dup, se_env = env, se_cont = k} + and Select { se_dup = dup, se_env = env, se_cont = k} +the following invariants hold + + (a) if dup = OkToDup, then continuation k is also ok-to-dup + (b) if dup = OkToDup or Simplified, the subst-env is empty, + or at least is always ignored; the payload is + already an OutThing +-} + +instance Outputable DupFlag where + ppr OkToDup = text "ok" + ppr NoDup = text "nodup" + ppr Simplified = text "simpl" + +instance Outputable SimplCont where + ppr (Stop ty interesting eval_sd) + = text "Stop" <> brackets (sep $ punctuate comma pps) <+> ppr ty + where + pps = [ppr interesting] ++ [ppr eval_sd | eval_sd /= topSubDmd] + ppr (CastIt { sc_co = co, sc_cont = cont }) + = (text "CastIt" <+> pprOptCo co) $$ ppr cont + ppr (TickIt t cont) + = (text "TickIt" <+> ppr t) $$ ppr cont + ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) + = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont + ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty }) + = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole-ty:" <+> pprParendType hole_ty) + 2 (pprParendExpr arg)) + $$ ppr cont + ppr (StrictBind { sc_bndr = b, sc_cont = cont }) + = (text "StrictBind" <+> ppr b) $$ ppr cont + ppr (StrictArg { sc_fun = ai, sc_cont = cont }) + = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont + ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_cont = cont }) + = (text "Select" <+> ppr dup <+> ppr bndr) $$ + whenPprDebug (nest 2 $ ppr alts) $$ ppr cont + + +{- Note [The hole type in ApplyToTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_hole_ty field of ApplyToTy records the type of the "hole" in the +continuation. It is absolutely necessary to compute contHoleType, but it is +not used for anything else (and hence may not be evaluated). + +Why is it necessary for contHoleType? Consider the continuation + ApplyToType Int (Stop Int) +corresponding to + ( @Int) :: Int +What is the type of ? It could be (forall a. Int) or (forall a. a), +and there is no way to know which, so we must record it. + +In a chain of applications (f @t1 @t2 @t3) we'll lazily compute exprType +for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably +doesn't matter because we'll never compute them all. + +************************************************************************ +* * + ArgInfo and ArgSpec +* * +************************************************************************ +-} + +data ArgInfo + = ArgInfo { + ai_fun :: OutId, -- The function + ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) + -- NB: all these argumennts are already simplified + + ai_rules :: [CoreRule], -- Rules for this function + ai_encl :: Bool, -- Flag saying whether this function + -- or an enclosing one has rules (recursively) + -- True => be keener to inline in all args + + ai_dmds :: [Demand], -- Demands on remaining value arguments (beyond ai_args) + -- Usually infinite, but if it is finite it guarantees + -- that the function diverges after being given + -- that number of args + + ai_discs :: [Int] -- Discounts for remaining value arguments (beyond ai_args) + -- non-zero => be keener to inline + -- Always infinite + } + +data ArgSpec + = ValArg { as_dmd :: Demand -- Demand placed on this argument + , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal + , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2) + + | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy + , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) + +instance Outputable ArgInfo where + ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds, ai_rules = rules }) + = text "ArgInfo" <+> braces + (sep [ text "fun =" <+> ppr fun + , text "dmds(first 10) =" <+> ppr (take 10 dmds) + , text "args =" <+> ppr args + , text "rewrite =" <+> ppr rules ]) + +instance Outputable ArgSpec where + ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg + ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty + +addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo +addValArgTo ai arg hole_ty + | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs } <- ai + -- Pop the top demand and and discounts off + , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd } + = ai { ai_args = arg_spec : ai_args ai + , ai_dmds = dmds + , ai_discs = discs } + | otherwise + = pprPanic "addValArgTo" (ppr ai $$ ppr arg) + -- There should always be enough demands and discounts + +addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo +addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai } + where + arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } + +isStrictArgInfo :: ArgInfo -> Bool +-- True if the function is strict in the next argument +isStrictArgInfo (ArgInfo { ai_dmds = dmds }) + | dmd:_ <- dmds = isStrUsedDmd dmd + | otherwise = False + +pushSimplifiedArgs :: SimplEnv + -> [ArgSpec] -- In normal, forward order + -> SimplCont -> SimplCont +pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args +-- pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args + +pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont +pushSimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont + = ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont } +pushSimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont + = ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified + -- The SubstEnv will be ignored since sc_dup=Simplified + , sc_hole_ty = hole_ty, sc_cont = cont } + +argSpecArg :: ArgSpec -> OutExpr +argSpecArg (ValArg { as_arg = arg }) = arg +argSpecArg (TyArg { as_arg_ty = ty }) = Type ty + +argInfoExpr :: OutId -> [ArgSpec] -> OutExpr +-- NB: the [ArgSpec] is reversed so that the first arg +-- in the list is the last one in the application +argInfoExpr fun rev_args + = go rev_args + where + go [] = Var fun + go (ValArg { as_arg = arg } : as) = go as `App` arg + go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty + +{- +************************************************************************ +* * + Functions on SimplCont +* * +************************************************************************ +-} + +mkBoringStop :: OutType -> SimplCont +mkBoringStop ty = Stop ty BoringCtxt topSubDmd + +mkRhsStop :: OutType -> RecFlag -> Demand -> SimplCont +-- See Note [RHS of lets] in GHC.Core.Unfold +mkRhsStop ty is_rec bndr_dmd = Stop ty (RhsCtxt is_rec) (subDemandIfEvaluated bndr_dmd) + +mkLazyArgStop :: OutType -> ArgInfo -> SimplCont +mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd + where + arg_sd = subDemandIfEvaluated (Partial.head (ai_dmds fun_info)) + +------------------- +contIsRhs :: SimplCont -> Maybe RecFlag +contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec +contIsRhs (CastIt { sc_cont = k }) = contIsRhs k -- For f = e |> co, treat e as Rhs context +contIsRhs _ = Nothing + +------------------- +contIsStop :: SimplCont -> Bool +contIsStop (Stop {}) = True +contIsStop _ = False + +contIsDupable :: SimplCont -> Bool +contIsDupable (Stop {}) = True +contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k +contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants] +contIsDupable (Select { sc_dup = OkToDup }) = True -- ...ditto... +contIsDupable (StrictArg { sc_dup = OkToDup }) = True -- ...ditto... +contIsDupable (CastIt { sc_cont = k }) = contIsDupable k +contIsDupable _ = False + +------------------- +contIsTrivial :: SimplCont -> Bool +contIsTrivial (Stop {}) = True +contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k +-- This one doesn't look right. A value application is not trivial +-- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k +contIsTrivial (CastIt { sc_cont = k }) = contIsTrivial k +contIsTrivial _ = False + +------------------- +contResultType :: SimplCont -> OutType +contResultType (Stop ty _ _) = ty +contResultType (CastIt { sc_cont = k }) = contResultType k +contResultType (StrictBind { sc_cont = k }) = contResultType k +contResultType (StrictArg { sc_cont = k }) = contResultType k +contResultType (Select { sc_cont = k }) = contResultType k +contResultType (ApplyToTy { sc_cont = k }) = contResultType k +contResultType (ApplyToVal { sc_cont = k }) = contResultType k +contResultType (TickIt _ k) = contResultType k + +contHoleType :: SimplCont -> OutType +contHoleType (Stop ty _ _) = ty +contHoleType (TickIt _ k) = contHoleType k +contHoleType (CastIt { sc_co = co }) = coercionLKind co +contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) + = perhapsSubstTy dup se (idType b) +contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty +contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] +contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] +contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) + = perhapsSubstTy d se (idType b) + + +-- Computes the multiplicity scaling factor at the hole. That is, in (case [] of +-- x ::(p) _ { … }) (respectively for arguments of functions), the scaling +-- factor is p. And in E[G[]], the scaling factor is the product of the scaling +-- factor of E and that of G. +-- +-- The scaling factor at the hole of E[] is used to determine how a binder +-- should be scaled if it commutes with E. This appears, in particular, in the +-- case-of-case transformation. +contHoleScaling :: SimplCont -> Mult +contHoleScaling (Stop _ _ _) = OneTy +contHoleScaling (CastIt { sc_cont = k }) + = contHoleScaling k +contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) + = idMult id `mkMultMul` contHoleScaling k +contHoleScaling (Select { sc_bndr = id, sc_cont = k }) + = idMult id `mkMultMul` contHoleScaling k +contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k }) + = w `mkMultMul` contHoleScaling k + where + (w, _, _) = splitFunTy fun_ty +contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k +contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k +contHoleScaling (TickIt _ k) = contHoleScaling k + +------------------- +countArgs :: SimplCont -> Int +-- Count all arguments, including types, coercions, +-- and other values; skipping over casts. +countArgs (ApplyToTy { sc_cont = cont }) = 1 + countArgs cont +countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont +countArgs (CastIt { sc_cont = cont }) = countArgs cont +countArgs _ = 0 + +countValArgs :: SimplCont -> Int +-- Count value arguments only +countValArgs (ApplyToTy { sc_cont = cont }) = countValArgs cont +countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont +countValArgs (CastIt { sc_cont = cont }) = countValArgs cont +countValArgs _ = 0 + +------------------- +contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) +-- Summarises value args, discards type args and coercions +-- The returned continuation of the call is only used to +-- answer questions like "are you interesting?" +contArgs cont + | lone cont = (True, [], cont) + | otherwise = go [] cont + where + lone (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold + lone (ApplyToVal {}) = False -- NB: even a type application or cast + lone (CastIt {}) = False -- stops it being "lone" + lone _ = True + + go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) + = go (is_interesting arg se : args) k + go args (ApplyToTy { sc_cont = k }) = go args k + go args (CastIt { sc_cont = k }) = go args k + go args k = (False, reverse args, k) + + is_interesting arg se = interestingArg se arg + -- Do *not* use short-cutting substitution here + -- because we want to get as much IdInfo as possible + +contOutArgs :: SimplEnv -> SimplCont -> [OutExpr] +-- Get the leading arguments from the `SimplCont`, as /OutExprs/ +contOutArgs env cont + = go cont + where + in_scope = seInScope env + + go (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) + = Type ty : go cont + + go (ApplyToVal { sc_dup = dup, sc_arg = arg, sc_env = env, sc_cont = cont }) + | isSimplified dup = arg : go cont + | otherwise = GHC.Core.Subst.substExpr (getFullSubst in_scope env) arg : go cont + -- Make sure we apply the static environment `sc_env` as a substitution + -- to get an OutExpr. See (BF1) in Note [tryRules: plan (BEFORE)] + -- in GHC.Core.Opt.Simplify.Iteration + -- NB: we use substExpr, not substExprSC: we want to get the benefit of + -- knowing what is evaluated etc, via the in-scope set + + -- No more arguments + go _ = [] + +dropContArgs :: FullArgCount -> SimplCont -> SimplCont +dropContArgs 0 cont = cont +dropContArgs n (ApplyToTy { sc_cont = cont }) = dropContArgs (n-1) cont +dropContArgs n (ApplyToVal { sc_cont = cont }) = dropContArgs (n-1) cont +dropContArgs n cont = pprPanic "dropContArgs" (ppr n $$ ppr cont) + +-- | Describes how the 'SimplCont' will evaluate the hole as a 'SubDemand'. +-- This can be more insightful than the limited syntactic context that +-- 'SimplCont' provides, because the 'Stop' constructor might carry a useful +-- 'SubDemand'. +-- For example, when simplifying the argument `e` in `f e` and `f` has the +-- demand signature ``, this function will give you back `P(S,A)` when +-- simplifying `e`. +-- +-- PRECONDITION: Don't call with 'ApplyToVal'. We haven't thoroughly thought +-- about what to do then and no call sites so far seem to care. +contEvalContext :: SimplCont -> SubDemand +contEvalContext k = case k of + Stop _ _ sd -> sd + TickIt _ k -> contEvalContext k + CastIt { sc_cont = k } -> contEvalContext k + ApplyToTy{ sc_cont = k } -> contEvalContext k + -- ApplyToVal{sc_cont=k} -> mkCalledOnceDmd $ contEvalContext k + -- Not 100% sure that's correct, . Here's an example: + -- f (e x) and f :: + -- then what is the evaluation context of 'e' when we simplify it? E.g., + -- simpl e (ApplyToVal x $ Stop "C(S,C(1,L))") + -- then it *should* be "C(1,C(S,C(1,L))", so perhaps correct after all. + -- But for now we just panic: + ApplyToVal{} -> pprPanic "contEvalContext" (ppr k) + StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (Partial.head (ai_dmds fun_info)) + StrictBind{sc_bndr=bndr} -> subDemandIfEvaluated (idDemandInfo bndr) + Select{} -> topSubDmd + -- Perhaps reconstruct the demand on the scrutinee by looking at field + -- and case binder dmds, see addCaseBndrDmd. No priority right now. + +------------------- +mkArgInfo :: SimplEnv -> Id -> [CoreRule] -> SimplCont -> ArgInfo +mkArgInfo env fun rules_for_fun cont + | n_val_args < idArity fun -- Note [Unsaturated functions] + = ArgInfo { ai_fun = fun, ai_args = [] + , ai_rules = rules_for_fun + , ai_encl = False + , ai_dmds = vanilla_dmds + , ai_discs = vanilla_discounts } + | otherwise + = ArgInfo { ai_fun = fun + , ai_args = [] + , ai_rules = rules_for_fun + , ai_encl = fun_has_rules || contHasRules cont + , ai_dmds = add_type_strictness (idType fun) arg_dmds + , ai_discs = arg_discounts } + where + n_val_args = countValArgs cont + + fun_has_rules = not (null rules_for_fun) + + vanilla_discounts, arg_discounts :: [Int] + vanilla_discounts = repeat 0 + arg_discounts = case idUnfolding fun of + CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} + -> discounts ++ vanilla_discounts + _ -> vanilla_discounts + + vanilla_dmds, arg_dmds :: [Demand] + vanilla_dmds = repeat topDmd + + arg_dmds + | not (seInline env) + = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] + | otherwise + = -- add_type_str fun_ty $ + case splitDmdSig (idDmdSig fun) of + (demands, result_info) + | not (demands `lengthExceeds` n_val_args) + -> -- Enough args, use the strictness given. + -- For bottoming functions we used to pretend that the arg + -- is lazy, so that we don't treat the arg as an + -- interesting context. This avoids substituting + -- top-level bindings for (say) strings into + -- calls to error. But now we are more careful about + -- inlining lone variables, so its ok + -- (see GHC.Core.Op.Simplify.Utils.analyseCont) + if isDeadEndDiv result_info then + demands -- Finite => result is bottom + else + demands ++ vanilla_dmds + | otherwise + -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun) + <+> ppr n_val_args <+> ppr demands) $ + vanilla_dmds -- Not enough args, or no strictness + + add_type_strictness :: Type -> [Demand] -> [Demand] + -- If the function arg types are strict, record that in the 'strictness bits' + -- No need to instantiate because unboxed types (which dominate the strict + -- types) can't instantiate type variables. + -- add_type_strictness is done repeatedly (for each call); + -- might be better once-for-all in the function + -- But beware primops/datacons with no strictness + + add_type_strictness fun_ty dmds + | null dmds = [] + + | Just (_, fun_ty') <- splitForAllTyCoVar_maybe fun_ty + = add_type_strictness fun_ty' dmds -- Look through foralls + + | Just (_, _, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info + , dmd : rest_dmds <- dmds + , let dmd' + | definitelyUnliftedType arg_ty + = strictifyDmd dmd + | otherwise + -- Something that's not definitely unlifted. + -- If the type is representation-polymorphic, we can't know whether + -- it's strict. + = dmd + = dmd' : add_type_strictness fun_ty' rest_dmds + + | otherwise + = dmds + +{- Note [Unsaturated functions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (test eyeball/inline4) + x = a:as + y = f x +where f has arity 2. Then we do not want to inline 'x', because +it'll just be floated out again. Even if f has lots of discounts +on its first argument -- it must be saturated for these to kick in + +Note [Do not expose strictness if sm_inline=False] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#15163 showed a case in which we had + + {-# INLINE [1] zip #-} + zip = undefined + + {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-} + +If we expose zip's bottoming nature when simplifying the LHS of the +RULE we get + {-# RULES "foo" forall as bs. + stream (case zip of {}) = ..blah... #-} +discarding the arguments to zip. Usually this is fine, but on the +LHS of a rule it's not, because 'as' and 'bs' are now not bound on +the LHS. + +This is a pretty pathological example, so I'm not losing sleep over +it, but the simplest solution was to check sm_inline; if it is False, +which it is on the LHS of a rule (see updModeForRules), then don't +make use of the strictness info for the function. +-} + + +{- +************************************************************************ +* * + Interesting arguments +* * +************************************************************************ + +Note [Interesting call context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to avoid inlining an expression where there can't possibly be +any gain, such as in an argument position. Hence, if the continuation +is interesting (eg. a case scrutinee that isn't just a seq, application etc.) +then we inline, otherwise we don't. + +Previously some_benefit used to return True only if the variable was +applied to some value arguments. This didn't work: + + let x = _coerce_ (T Int) Int (I# 3) in + case _coerce_ Int (T Int) x of + I# y -> .... + +we want to inline x, but can't see that it's a constructor in a case +scrutinee position, and some_benefit is False. + +Another example: + +dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) + +.... case dMonadST _@_ x0 of (a,b,c) -> .... + +we'd really like to inline dMonadST here, but we *don't* want to +inline if the case expression is just + + case x of y { DEFAULT -> ... } + +since we can just eliminate this case instead (x is in WHNF). Similar +applies when x is bound to a lambda expression. Hence +contIsInteresting looks for case expressions with just a single +default case. + +Note [No case of case is boring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see + case f x of + +we'd usually treat the context as interesting, to encourage 'f' to +inline. But if case-of-case is off, it's really not so interesting +after all, because we are unlikely to be able to push the case +expression into the branches of any case in f's unfolding. So, to +reduce unnecessary code expansion, we just make the context look boring. +This made a small compile-time perf improvement in perf/compiler/T6048, +and it looks plausible to me. + +Note [Seq is boring] +~~~~~~~~~~~~~~~~~~~~ +Suppose + f x = case v of + True -> Just x + False -> Just (x-1) + +Now consider these variants of + case (f x) of ... + +1. [Dead case binder]: inline f + case f x of b{-dead-} { DEFAULT -> blah[no b] } + Inlining (f x) will allow us to avoid ever allocating (Just x), + since the case binder `b` is dead. We will end up with a + join point for blah, thus + join j = blah in + case v of { True -> j; False -> j } + which will turn into (case v of DEFAULT -> blah) + All good + +2. [Live case binder, live alt binders]: inline f + case f x of b { Just y -> blah[y,b] } + Inlining (f x) will mean we still allocate (Just x), + but we also get to bind `y` without fetching it out of the Just, thus + join j y b = blah[y,b] + case v of { True -> j x (Just x) + ; False -> let y = x-1 in j y (Just y) } + Inlining (f x) has a small benefit, perhaps. + (To T14955 it makes a surprisingly large difference of ~30% to inline here.) + +3. [Live case binder, dead alt binders]: maybe don't inline f + case f x of b { DEFAULT -> blah[b] } + Inlining (f x) will still mean we allocate (Just x). We'd get: + join j b = blah[b] + case v of { True -> j (Just x); False -> j (Just (x-1)) } + No new optimisations are revealed. Nothing is gained. + (This is the situation in T22317.) + + A variant is when we have a data constructor with dead binders: + case g x of b { (x{-dead-}, x{-dead-}) -> blah[b, no x, no y] } + Instead of DEFAULT we have a single constructor alternative + with all dead binders. Again, no gain from inlining (f x) + +4. [Live case binder, dead alt binders]: small f + Suppose f is CPR'd, so it looks like + f x = case $wf x of (# a #) -> Just a + Then even in case (3) we want to inline: + case f x of b { DEFAULT -> blah[b] } + --> + case $wf x of (# a #) -> + let b = Just a in blah[b] + This is very good; we now know a lot about `b` (instead of nothing) + and `blah` might benefit. Similarly if `f` has a join point + f x = join $j y = Just y in ... + Again the case (f x) is now consuming a constructor (Just y). + + This is very like the situation described in Note [RHS of lets] + in GHC.Core.Opt.Simplify.Inline; (case e of b -> blah) is just + like a strict `let`. + +Conclusion: in interestingCallCtxt, a case-expression (i.e. Select continuation) +usually gives a CaseCtxt (cases 1,2); but when (cases 3,4): + * It has a non-dead case-binder + * It has one alternative + * All the binders in the alternative are dead +then the `case` is just a strict let-binding, so use RhsCtxt NonRecursive. +This RhsCtxt gives a small incentive for small functions to inline. +That incentive is what is needed in case (4). + +Wrinkle (SB1). The 'small incentive' is implemented by `calc_some_benefit` in +GHC.Core.Opt.Simplify.Inline.tryUnfolding. We restrict the incentive just to +funtions that have unfolding guidance of `UnfWhen`, which particularly includes +wrappers created by CPR, exactly case (4) above. Without this limitation I +got too much fruitless inlining, which led to regressions (#22317 is an example). + +A good example of a function where this 'small incentive' is important is +GHC.Internal.Bignum.Integer where we ended up with calls like this: + case (integerSignum a b) of r -> ... +but were failing to inline integerSignum, even though it always returns +a single constructor, so it is very helpful to inline it. There is also an +issue of confluence-of-the-simplifier. Suppose we have + f x = case x of r -> ... +and the Simplifier sees + f (integerSigNum a b) +Because `f` scrutines `x`, the unfolding guidance for f gives a discount +for `x`; and that discount makes interestingCallContext for the context +`f <>` return DiscArgCtxt, which again gives that incentive. We don't want +the incentive to disappear when we inline `f`! +-} + +lazyArgContext :: ArgInfo -> CallCtxt +-- Use this for lazy arguments +lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) + | encl_rules = RuleArgCtxt + | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting + +strictArgContext :: ArgInfo -> CallCtxt +strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) +-- Use this for strict arguments + | encl_rules = RuleArgCtxt + | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = RhsCtxt NonRecursive + -- Why RhsCtxt? if we see f (g x), and f is strict, we + -- want to be a bit more eager to inline g, because it may + -- expose an eval (on x perhaps) that can be eliminated or + -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1 + -- It's worth an 18% improvement in allocation for this + -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier' + -- + -- Why NonRecursive? Becuase it's a bit like + -- let a = g x in f a + +interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt +-- See Note [Interesting call context] +interestingCallContext env cont + = interesting cont + where + interesting (Select {sc_alts=alts, sc_bndr=case_bndr}) + | not (seCaseCase env) = BoringCtxt -- See Note [No case of case is boring] + | [Alt _ bs _] <- alts + , all isDeadBinder bs + , not (isDeadBinder case_bndr) = RhsCtxt NonRecursive -- See Note [Seq is boring] + | otherwise = CaseCtxt + + + interesting (ApplyToVal {}) = ValAppCtxt + -- Can happen if we have (f Int |> co) y + -- If f has an INLINE prag we need to give it some + -- motivation to inline. See Note [Cast then apply] + -- in GHC.Core.Unfold + + interesting (StrictArg { sc_fun = fun }) = strictArgContext fun + interesting (StrictBind {}) = BoringCtxt + interesting (Stop _ cci _) = cci + interesting (TickIt _ k) = interesting k + interesting (ApplyToTy { sc_cont = k }) = interesting k + interesting (CastIt { sc_cont = k }) = interesting k + -- If this call is the arg of a strict function, the context + -- is a bit interesting. If we inline here, we may get useful + -- evaluation information to avoid repeated evals: e.g. + -- x + (y * z) + -- Here the contIsInteresting makes the '*' keener to inline, + -- which in turn exposes a constructor which makes the '+' inline. + -- Assuming that +,* aren't small enough to inline regardless. + -- + -- It's also very important to inline in a strict context for things + -- like + -- foldr k z (f x) + -- Here, the context of (f x) is strict, and if f's unfolding is + -- a build it's *great* to inline it here. So we must ensure that + -- the context for (f x) is not totally uninteresting. + +contHasRules :: SimplCont -> Bool +-- If the argument has form (f x y), where x,y are boring, +-- and f is marked INLINE, then we don't want to inline f. +-- But if the context of the argument is +-- g (f x y) +-- where g has rules, then we *do* want to inline f, in case it +-- exposes a rule that might fire. Similarly, if the context is +-- h (g (f x x)) +-- where h has rules, then we do want to inline f. So contHasRules +-- tries to see if the context of the f-call is a call to a function +-- with rules. +-- +-- The ai_encl flag makes this happen; if it's +-- set, the inliner gets just enough keener to inline f +-- regardless of how boring f's arguments are, if it's marked INLINE +-- +-- The alternative would be to *always* inline an INLINE function, +-- regardless of how boring its context is; but that seems overkill +-- For example, it'd mean that wrapper functions were always inlined +contHasRules cont + = go cont + where + go (ApplyToVal { sc_cont = cont }) = go cont + go (ApplyToTy { sc_cont = cont }) = go cont + go (CastIt { sc_cont = cont }) = go cont + go (StrictArg { sc_fun = fun }) = ai_encl fun + go (Stop _ RuleArgCtxt _) = True + go (TickIt _ c) = go c + go (Select {}) = False + go (StrictBind {}) = False -- ?? + go (Stop _ _ _) = False + +{- Note [Interesting arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An argument is interesting if it deserves a discount for unfoldings +with a discount in that argument position. The idea is to avoid +unfolding a function that is applied only to variables that have no +unfolding (i.e. they are probably lambda bound): f x y z There is +little point in inlining f here. + +Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But +we must look through lets, eg (let x = e in C a b), because the let will +float, exposing the value, if we inline. That makes it different to +exprIsHNF. + +Before 2009 we said it was interesting if the argument had *any* structure +at all; i.e. (hasSomeUnfolding v). But does too much inlining; see #3016. + +But we don't regard (f x y) as interesting, unless f is unsaturated. +If it's saturated and f hasn't inlined, then it's probably not going +to now! + +Note [Conlike is interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f d = ...((*) d x y)... + ... f (df d')... +where df is con-like. Then we'd really like to inline 'f' so that the +rule for (*) (df d) can fire. To do this + a) we give a discount for being an argument of a class-op (eg (*) d) + b) we say that a con-like argument (eg (df d)) is interesting +-} + +interestingArg :: SimplEnv -> CoreExpr -> ArgSummary +-- See Note [Interesting arguments] +interestingArg env e = go env 0 e + where + -- n is # value args to which the expression is applied + go env n (Var v) + = case substId env v of + DoneId v' -> go_var n v' + DoneEx e _ -> go (zapSubstEnv env) n e + ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e + + go _ _ (Lit l) + | isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035 + | otherwise = ValueArg + go _ _ (Type _) = TrivArg + go _ _ (Coercion _) = TrivArg + go env n (App fn (Type _)) = go env n fn + go env n (App fn _) = go env (n+1) fn + go env n (Tick _ a) = go env n a + go env n (Cast e _) = go env n e + go env n (Lam v e) + | isTyVar v = go env n e + | n>0 = NonTrivArg -- (\x.b) e is NonTriv + | otherwise = ValueArg + go _ _ (Case {}) = NonTrivArg + go env n (Let b e) = case go env' n e of + ValueArg -> ValueArg + _ -> NonTrivArg + where + env' = env `addNewInScopeIds` bindersOf b + + go_var n v + | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that + -- data constructors here + -- DFuns are con-like; see Note [Conlike is interesting] + | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding + | n > 0 = NonTrivArg -- Saturated or unknown call + | otherwise -- n==0, no value arguments; look for an interesting unfolding + = case idUnfolding v of + OtherCon [] -> NonTrivArg -- It's evaluated, but that's all we know + OtherCon _ -> ValueArg -- Evaluated and we know it isn't these constructors + -- See Note [OtherCon and interestingArg] + DFunUnfolding {} -> ValueArg -- We konw that idArity=0 + CoreUnfolding{ uf_cache = cache } + | uf_is_conlike cache -> ValueArg -- Includes constructor applications + | uf_is_value cache -> NonTrivArg -- Things like partial applications + | otherwise -> TrivArg + BootUnfolding -> TrivArg + NoUnfolding -> TrivArg + +{- Note [OtherCon and interestingArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +interstingArg returns + (a) NonTrivArg for an arg with an OtherCon [] unfolding + (b) ValueArg for an arg with an OtherCon [c1,c2..] unfolding. + +Reason for (a): I found (in the GHC.Internal.Bignum.Integer module) that I was +inlining a pretty big function when all we knew was that its arguments +were evaluated, nothing more. That in turn make the enclosing function +too big to inline elsewhere. + +Reason for (b): we want to inline integerCompare here + integerLt# :: Integer -> Integer -> Bool# + integerLt# (IS x) (IS y) = x <# y + integerLt# x y | LT <- integerCompare x y = 1# + integerLt# _ _ = 0# + +************************************************************************ +* * + SimplMode +* * +************************************************************************ +-} + +updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode +-- See Note [The environments of the Simplify pass] +updModeForStableUnfoldings unf_act current_mode + = current_mode { sm_phase = phaseFromActivation unf_act + , sm_eta_expand = False + , sm_inline = True } + -- sm_eta_expand: see Note [Eta expansion in stable unfoldings and rules] + -- sm_rules: just inherit; sm_rules might be "off" + -- because of -fno-enable-rewrite-rules + where + phaseFromActivation (ActiveAfter _ n) = Phase n + phaseFromActivation _ = InitialPhase + +updModeForRules :: SimplMode -> SimplMode +-- See Note [Simplifying rules] +-- See Note [The environments of the Simplify pass] +updModeForRules current_mode + = current_mode { sm_phase = InitialPhase + , sm_inline = False + -- See Note [Do not expose strictness if sm_inline=False] + , sm_rules = False + , sm_cast_swizzle = False + -- See Note [Cast swizzling on rule LHSs] + , sm_eta_expand = False } + +{- Note [Simplifying rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying a rule LHS, refrain from /any/ inlining or applying +of other RULES. Doing anything to the LHS is plain confusing, because +it means that what the rule matches is not what the user +wrote. c.f. #10595, and #10528. + +* sm_inline, sm_rules: inlining (or applying rules) on rule LHSs risks + introducing Ticks into the LHS, which makes matching + trickier. #10665, #10745. + + Doing this to either side confounds tools like HERMIT, which seek to reason + about and apply the RULES as originally written. See #10829. + + See also Note [Do not expose strictness if sm_inline=False] + +* sm_eta_expand: the template (LHS) of a rule must only mention coercion + /variables/ not arbitrary coercions. See Note [Casts in the template] in + GHC.Core.Rules. Eta expansion can create new coercions; so we switch + it off. + +There is, however, one case where we are pretty much /forced/ to transform the +LHS of a rule: postInlineUnconditionally. For instance, in the case of + + let f = g @Int in f + +We very much want to inline f into the body of the let. However, to do so (and +be able to safely drop f's binding) we must inline into all occurrences of f, +including those in the LHS of rules. + +This can cause somewhat surprising results; for instance, in #18162 we found +that a rule template contained ticks in its arguments, because +postInlineUnconditionally substituted in a trivial expression that contains +ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for +details. + +Note [Cast swizzling on rule LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the LHS of a RULE we may have + (\x. blah |> CoVar cv) +where `cv` is a coercion variable. Critically, we really only want +coercion /variables/, not general coercions, on the LHS of a RULE. So +we don't want to swizzle this to + (\x. blah) |> (Refl xty `FunCo` CoVar cv) +So we switch off cast swizzling in updModeForRules. + +Note [Eta expansion in stable unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SPJ Jul 22: whether or not eta-expansion is switched on in a stable +unfolding, or the RHS of a RULE, seems to be a bit moot. But switching +it on adds clutter, so I'm experimenting with switching off +eta-expansion in such places. + +In the olden days, we really /wanted/ to switch it off. + + Old note: If we have a stable unfolding + f :: Ord a => a -> IO () + -- Unfolding template + -- = /\a \(d:Ord a) (x:a). bla + we do not want to eta-expand to + f :: Ord a => a -> IO () + -- Unfolding template + -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co + because now specialisation of the overloading doesn't work properly + (see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509. + So we disable eta-expansion in stable unfoldings. + +But this old note is no longer relevant because the specialiser has +improved: see Note [Account for casts in binding] in +GHC.Core.Opt.Specialise. So we seem to have a free choice. + +Note [Inlining in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Something is inlined if + (i) the sm_inline flag is on, AND + (ii) the thing has an INLINE pragma, AND + (iii) the thing is inlinable in the earliest phase. + +Example of why (iii) is important: + {-# INLINE [~1] g #-} + g = ... + + {-# INLINE f #-} + f x = g (g x) + +If we were to inline g into f's inlining, then an importing module would +never be able to do + f e --> g (g e) ---> RULE fires +because the stable unfolding for f has had g inlined into it. + +On the other hand, it is bad not to do ANY inlining into an +stable unfolding, because then recursive knots in instance declarations +don't get unravelled. + +However, *sometimes* SimplGently must do no call-site inlining at all +(hence sm_inline = False). Before full laziness we must be careful +not to inline wrappers, because doing so inhibits floating + e.g. ...(case f x of ...)... + ==> ...(case (case x of I# x# -> fw x#) of ...)... + ==> ...(case x of I# x# -> case fw x# of ...)... +and now the redex (f x) isn't floatable any more. + +The no-inlining thing is also important for Template Haskell. You might be +compiling in one-shot mode with -O2; but when TH compiles a splice before +running it, we don't want to use -O2. Indeed, we don't want to inline +anything, because the byte-code interpreter might get confused about +unboxed tuples and suchlike. + +Note [Simplifying inside stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must take care with simplification inside stable unfoldings (which come from +INLINE pragmas). + +First, consider the following example + let f = \pq -> BIG + in + let g = \y -> f y y + {-# INLINE g #-} + in ...g...g...g...g...g... +Now, if that's the ONLY occurrence of f, it might be inlined inside g, +and thence copied multiple times when g is inlined. HENCE we treat +any occurrence in a stable unfolding as a multiple occurrence, not a single +one; see OccurAnal.addRuleUsage. + +Second, we do want *do* to some modest rules/inlining stuff in stable +unfoldings, partly to eliminate senseless crap, and partly to break +the recursive knots generated by instance declarations. + +However, suppose we have + {-# INLINE f #-} + f = +meaning "inline f in phases p where activation (p) holds". +Then what inlinings/rules can we apply to the copy of captured in +f's stable unfolding? Our model is that literally is substituted for +f when it is inlined. So our conservative plan (implemented by +updModeForStableUnfoldings) is this: + + ------------------------------------------------------------- + When simplifying the RHS of a stable unfolding, set the phase + to the phase in which the stable unfolding first becomes active + ------------------------------------------------------------- + +That ensures that + + a) Rules/inlinings that *cease* being active before p will + not apply to the stable unfolding, consistent with it being + inlined in its *original* form in phase p. + + b) Rules/inlinings that only become active *after* p will + not apply to the stable unfolding, again to be consistent with + inlining the *original* rhs in phase p. + +For example, + {-# INLINE f #-} + f x = ...g... + + {-# NOINLINE [1] g #-} + g y = ... + + {-# RULE h g = ... #-} +Here we must not inline g into f's RHS, even when we get to phase 0, +because when f is later inlined into some other module we want the +rule for h to fire. + +Similarly, consider + {-# INLINE f #-} + f x = ...g... + + g y = ... +and suppose that there are auto-generated specialisations and a strictness +wrapper for g. The specialisations get activation AlwaysActive, and the +strictness wrapper get activation (ActiveAfter 0). So the strictness +wrepper fails the test and won't be inlined into f's stable unfolding. That +means f can inline, expose the specialised call to g, so the specialisation +rules can fire. + +A note about wrappers +~~~~~~~~~~~~~~~~~~~~~ +It's also important not to inline a worker back into a wrapper. +A wrapper looks like + wraper = inline_me (\x -> ...worker... ) +Normally, the inline_me prevents the worker getting inlined into +the wrapper (initially, the worker's only call site!). But, +if the wrapper is sure to be called, the strictness analyser will +mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf +continuation. +-} + +getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv +-- When matching in RULE, we want to "look through" an unfolding +-- (to see a constructor) if *rules* are on, even if *inlinings* +-- are not. A notable example is DFuns, which really we want to +-- match in rules like (op dfun) in gentle mode. Another example +-- is 'otherwise' which we want exprIsConApp_maybe to be able to +-- see very early on +getUnfoldingInRuleMatch env + = ISE in_scope id_unf + where + in_scope = seInScope env + phase = sePhase env + id_unf = whenActiveUnfoldingFun (isActive phase) + -- When sm_rules was off we used to test for a /stable/ unfolding, + -- but that seems wrong (#20941) + +---------------------- +activeRule :: SimplMode -> Activation -> Bool +-- Nothing => No rules at all +activeRule mode + | not (sm_rules mode) = \_ -> False -- Rewriting is off + | otherwise = isActive (sm_phase mode) + +{- +************************************************************************ +* * + preInlineUnconditionally +* * +************************************************************************ + +preInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~ +@preInlineUnconditionally@ examines a bndr to see if it is used just +once in a completely safe way, so that it is safe to discard the +binding inline its RHS at the (unique) usage site, REGARDLESS of how +big the RHS might be. If this is the case we don't simplify the RHS +first, but just inline it un-simplified. + +This is much better than first simplifying a perhaps-huge RHS and then +inlining and re-simplifying it. Indeed, it can be at least quadratically +better. Consider + + x1 = e1 + x2 = e2[x1] + x3 = e3[x2] + ...etc... + xN = eN[xN-1] + +We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. +This can happen with cascades of functions too: + + f1 = \x1.e1 + f2 = \xs.e2[f1] + f3 = \xs.e3[f3] + ...etc... + +THE MAIN INVARIANT is this: + + ---- preInlineUnconditionally invariant ----- + IF preInlineUnconditionally chooses to inline x = + THEN doing the inlining should not change the occurrence + info for the free vars of + ---------------------------------------------- + +For example, it's tempting to look at trivial binding like + x = y +and inline it unconditionally. But suppose x is used many times, +but this is the unique occurrence of y. Then inlining x would change +y's occurrence info, which breaks the invariant. It matters: y +might have a BIG rhs, which will now be dup'd at every occurrence of x. + + +Even RHSs labelled InlineMe aren't caught here, because there might be +no benefit from inlining at the call site. + +[Sept 01] Don't unconditionally inline a top-level thing, because that +can simply make a static thing into something built dynamically. E.g. + x = (a,b) + main = \s -> h x + +[Remember that we treat \s as a one-shot lambda.] No point in +inlining x unless there is something interesting about the call site. + +But watch out: if you aren't careful, some useful foldr/build fusion +can be lost (most notably in spectral/hartel/parstof) because the +foldr didn't see the build. Doing the dynamic allocation isn't a big +deal, in fact, but losing the fusion can be. But the right thing here +seems to be to do a callSiteInline based on the fact that there is +something interesting about the call site (it's strict). Hmm. That +seems a bit fragile. + +Conclusion: inline top level things gaily until FinalPhase (the last +phase), at which point don't. + +Note [pre/postInlineUnconditionally in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in gentle mode we want to do preInlineUnconditionally. The +reason is that too little clean-up happens if you don't inline +use-once things. Also a bit of inlining is *good* for full laziness; +it can expose constant sub-expressions. Example in +spectral/mandel/Mandel.hs, where the mandelset function gets a useful +let-float if you inline windowToViewport + +However, as usual for Gentle mode, do not inline things that are +inactive in the initial stages. See Note [Gentle mode]. + +Note [Stable unfoldings and preInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! +Example + + {-# INLINE f #-} + f :: Eq a => a -> a + f x = ... + + fInt :: Int -> Int + fInt = f Int dEqInt + + ...fInt...fInt...fInt... + +Here f occurs just once, in the RHS of fInt. But if we inline it there +it might make fInt look big, and we'll lose the opportunity to inline f +at each of fInt's call sites. The INLINE pragma will only inline when +the application is saturated for exactly this reason; and we don't +want PreInlineUnconditionally to second-guess it. A live example is #3736. + c.f. Note [Stable unfoldings and postInlineUnconditionally] + +NB: this only applies for INLINE things. Do /not/ switch off +preInlineUnconditionally for + +* INLINABLE. It just says to GHC "inline this if you like". If there + is a unique occurrence, we want to inline the stable unfolding, not + the RHS. + +* NONLINE[n] just switches off inlining until phase n. We should + respect that, but after phase n, just behave as usual. + +* NoUserInlinePrag. There is no pragma at all. This ends up on wrappers. + (See #18815.) + +Note [Top-level bottoming Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't inline top-level Ids that are bottoming, even if they are used just +once, because FloatOut has gone to some trouble to extract them out. +Inlining them won't make the program run faster! + +Note [Do not inline CoVars unconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Coercion variables appear inside coercions, and the RHS of a let-binding +is a term (not a coercion) so we can't necessarily inline the latter in +the former. +-} + +preInlineUnconditionally + :: SimplEnv -> TopLevelFlag -> InId + -> InExpr -> StaticEnv -- These two go together + -> Maybe SimplEnv -- Returned env has extended substitution +-- Precondition: rhs satisfies the let-can-float invariant +-- See Note [Core let-can-float invariant] in GHC.Core +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-ful bindings +preInlineUnconditionally env top_lvl bndr rhs rhs_env + | not pre_inline_unconditionally = Nothing + | not active = Nothing + | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] + | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] + | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points] + -- in module Exitify + | not (one_occ (idOccInfo bndr)) = Nothing + | not (isStableUnfolding unf) = Just $! (extend_subst_with rhs) + + -- See Note [Stable unfoldings and preInlineUnconditionally] + | not (isInlinePragma inline_prag) + , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl) + | otherwise = Nothing + where + unf = idUnfolding bndr + extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs) + + one_occ IAmDead = True -- Happens in ((\x.1) v) + one_occ OneOcc{ occ_n_br = 1 + , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase + one_occ OneOcc{ occ_n_br = 1 + , occ_in_lam = IsInsideLam + , occ_int_cxt = IsInteresting } = canInlineInLam rhs + one_occ _ = False + + pre_inline_unconditionally = sePreInline env + active = isActive (sePhase env) (inlinePragmaActivation inline_prag) + -- See Note [pre/postInlineUnconditionally in gentle mode] + inline_prag = idInlinePragma bndr + +-- Be very careful before inlining inside a lambda, because (a) we must not +-- invalidate occurrence information, and (b) we want to avoid pushing a +-- single allocation (here) into multiple allocations (inside lambda). +-- Inlining a *function* with a single *saturated* call would be ok, mind you. +-- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) +-- where +-- is_cheap = exprIsCheap rhs +-- ok = is_cheap && int_cxt + + -- int_cxt The context isn't totally boring + -- E.g. let f = \ab.BIG in \y. map f xs + -- Don't want to substitute for f, because then we allocate + -- its closure every time the \y is called + -- But: let f = \ab.BIG in \y. map (f y) xs + -- Now we do want to substitute for f, even though it's not + -- saturated, because we're going to allocate a closure for + -- (f y) every time round the loop anyhow. + + -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, + -- so substituting rhs inside a lambda doesn't change the occ info. + -- Sadly, not quite the same as exprIsHNF. + canInlineInLam (Lit _) = True + canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e + canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e + canInlineInLam (Var v) = case idOccInfo v of + OneOcc { occ_in_lam = IsInsideLam } -> True + ManyOccs {} -> True + _ -> False + canInlineInLam _ = False + -- not ticks. Counting ticks cannot be duplicated, and non-counting + -- ticks around a Lam will disappear anyway. + + early_phase = sePhase env /= FinalPhase + -- If we don't have this early_phase test, consider + -- x = length [1,2,3] + -- The full laziness pass carefully floats all the cons cells to + -- top level, and preInlineUnconditionally floats them all back in. + -- Result is (a) static allocation replaced by dynamic allocation + -- (b) many simplifier iterations because this tickles + -- a related problem; only one inlining per pass + -- + -- On the other hand, I have seen cases where top-level fusion is + -- lost if we don't inline top level thing (e.g. string constants) + -- Hence the test for phase zero (which is the phase for all the final + -- simplifications). Until phase zero we take no special notice of + -- top level things, but then we become more leery about inlining + -- them. + -- + -- What exactly to check in `early_phase` above is the subject of #17910. + -- + -- !10088 introduced an additional Simplifier iteration in LargeRecord + -- because we first FloatOut `case unsafeEqualityProof of ... -> I# 2#` + -- (a non-trivial value) which we immediately inline back in. + -- Ideally, we'd never have inlined it because the binding turns out to + -- be expandable; unfortunately we need an iteration of the Simplifier to + -- attach the proper unfolding and can't check isExpandableUnfolding right + -- here. + -- (Nor can we check for `exprIsExpandable rhs`, because that needs to look + -- at the non-existent unfolding for the `I# 2#` which is also floated out.) + +{- +************************************************************************ +* * + postInlineUnconditionally +* * +************************************************************************ + +postInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~~ +@postInlineUnconditionally@ decides whether to unconditionally inline +a thing based on the form of its RHS; in particular if it has a +trivial RHS. If so, we can inline and discard the binding altogether. + +NB: a loop breaker has must_keep_binding = True and non-loop-breakers +only have *forward* references. Hence, it's safe to discard the binding + +NOTE: This isn't our last opportunity to inline. We're at the binding +site right now, and we'll get another opportunity when we get to the +occurrence(s) + +Note that we do this unconditional inlining only for trivial RHSs. +Don't inline even WHNFs inside lambdas; doing so may simply increase +allocation when the function is called. This isn't the last chance; see +NOTE above. + +NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why? +Because we don't even want to inline them into the RHS of constructor +arguments. See NOTE above + +NB: At one time even NOINLINE was ignored here: if the rhs is trivial +it's best to inline it anyway. We often get a=E; b=a from desugaring, +with both a and b marked NOINLINE. But that seems incompatible with +our new view that inlining is like a RULE, so I'm sticking to the 'active' +story for now. + +NB: unconditional inlining of this sort can introduce ticks in places that +may seem surprising; for instance, the LHS of rules. See Note [Simplifying +rules] for details. +-} + +postInlineUnconditionally + :: SimplEnv -> BindContext + -> InId -> OutId -- The binder (*not* a CoVar), including its unfolding + -> OutExpr + -> Bool +-- Precondition: rhs satisfies the let-can-float invariant +-- See Note [Core let-can-float invariant] in GHC.Core +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-ful bindings +postInlineUnconditionally env bind_cxt old_bndr bndr rhs + | not active = False + | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline + -- because it might be referred to "earlier" + | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] + | isTopLevel (bindContextLevel bind_cxt) + = False -- Note [Top level and postInlineUnconditionally] + | exprIsTrivial rhs = True + | BC_Join {} <- bind_cxt = False -- See point (1) of Note [Duplicating join points] + -- in GHC.Core.Opt.Simplify.Iteration + | otherwise + = case occ_info of + OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br } + -- See Note [Inline small things to avoid creating a thunk] + + | n_br >= 100 -> False -- See #23627 + + | n_br == 1, NotInsideLam <- in_lam -- One syntactic occurrence + -> True -- See Note [Post-inline for single-use things] + +-- | is_unlifted -- Unlifted binding, hence ok-for-spec +-- -> True -- hence cheap to inline probably just a primop +-- -- Not a big deal either way +-- No, this is wrong. {v = p +# q; x = K v}. +-- Don't inline v; it'll just get floated out again. Stupid. + + | is_demanded + -> False -- No allocation (it'll be a case expression in the end) + -- so inlining duplicates code but nothing more + + | otherwise + -> work_ok in_lam int_cxt && smallEnoughToInline uf_opts unfolding + -- Multiple syntactic occurences; but lazy, and small enough to dup + -- ToDo: consider discount on smallEnoughToInline if int_cxt is true + + IAmDead -> True -- This happens; for example, the case_bndr during case of + -- known constructor: case (a,b) of x { (p,q) -> ... } + -- Here x isn't mentioned in the RHS, so we don't want to + -- create the (dead) let-binding let x = (a,b) in ... + + _ -> False + + where + work_ok NotInsideLam _ = True + work_ok IsInsideLam IsInteresting = isCheapUnfolding unfolding + work_ok IsInsideLam NotInteresting = False + -- NotInsideLam: outside a lambda, we want to be reasonably aggressive + -- about inlining into multiple branches of case + -- e.g. let x = + -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } + -- Inlining can be a big win if C3 is the hot-spot, even if + -- the uses in C1, C2 are not 'interesting' + -- An example that gets worse if you add int_cxt here is 'clausify' + + -- InsideLam: check for acceptable work duplication, using isCheapUnfoldign + -- int_cxt to prevent us inlining inside a lambda without some + -- good reason. See the notes on int_cxt in preInlineUnconditionally + +-- is_unlifted = isUnliftedType (idType bndr) + is_demanded = isStrUsedDmd (idDemandInfo bndr) + occ_info = idOccInfo old_bndr + unfolding = idUnfolding bndr + uf_opts = seUnfoldingOpts env + phase = sePhase env + active = isActive phase (idInlineActivation bndr) + -- See Note [pre/postInlineUnconditionally in gentle mode] + +{- Note [Inline small things to avoid creating a thunk] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The point of examining occ_info here is that for *non-values* that +occur outside a lambda, the call-site inliner won't have a chance +(because it doesn't know that the thing only occurs once). The +pre-inliner won't have gotten it either, if the thing occurs in more +than one branch So the main target is things like + + let x = f y in + case v of + True -> case x of ... + False -> case x of ... + +This is very important in practice; e.g. wheel-seive1 doubles +in allocation if you miss this out. And bits of GHC itself start +to allocate more. An egregious example is test perf/compiler/T14697, +where GHC.Driver.CmdLine.$wprocessArgs allocated hugely more. + +Note [Post-inline for single-use things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + + let x = rhs in ...x... + +and `x` is used exactly once, and not inside a lambda, then we will usually +preInlineUnconditinally. But we can still get this situation in +postInlineUnconditionally: + + case K rhs of K x -> ...x.... + +Here we'll use `simplAuxBind` to bind `x` to (the already-simplified) `rhs`; +and `x` is used exactly once. It's beneficial to inline right away; otherwise +we risk creating + + let x = rhs in ...x... + +which will take another iteration of the Simplifier to eliminate. We do this in +two places + +1. In the full `postInlineUnconditionally` look for the special case + of "one occurrence, not under a lambda", and inline unconditionally then. + + This is a bit risky: see Note [Avoiding simplifying repeatedly] in + Simplify.Iteration. But in practice it seems to be a small win. + +2. `simplAuxBind` does a kind of poor-man's `postInlineUnconditionally`. It + does not need to account for many of the cases (e.g. top level) that the + full `postInlineUnconditionally` does. Moreover, we don't have an + OutId, which `postInlineUnconditionally` needs. I got a slight improvement + in compiler performance when I added this test. + +Here's an example that we don't currently handle well: + let f = if b then Left (\x.BIG) else Right (\y.BIG) + in \y. ....case f of {...} .... +Here f is used just once, and duplicating the case work is fine (exprIsCheap). +But + - We can't preInlineUnconditionally because that would invalidate + the occ info for b. + - We can't postInlineUnconditionally because the RHS is big, and + that risks exponential behaviour + - We can't call-site inline, because the rhs is big +Alas! + + +Note [Top level and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't do postInlineUnconditionally for top-level things (even for +ones that are trivial): + + * Doing so will inline top-level error expressions that have been + carefully floated out by FloatOut. More generally, it might + replace static allocation with dynamic. + + * Even for trivial expressions there's a problem. Consider + {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-} + blah xs = reverse xs + ruggle = sort + In one simplifier pass we might fire the rule, getting + blah xs = ruggle xs + but in *that* simplifier pass we must not do postInlineUnconditionally + on 'ruggle' because then we'll have an unbound occurrence of 'ruggle' + + If the rhs is trivial it'll be inlined by callSiteInline, and then + the binding will be dead and discarded by the next use of OccurAnal + + * There is less point, because the main goal is to get rid of local + bindings used in multiple case branches. + + * The inliner should inline trivial things at call sites anyway. + + * The Id might be exported. We could check for that separately, + but since we aren't going to postInlineUnconditionally /any/ + top-level bindings, we don't need to test. + +Note [Stable unfoldings and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not do postInlineUnconditionally if the Id has a stable unfolding, +otherwise we lose the unfolding. Example + + -- f has stable unfolding with rhs (e |> co) + -- where 'e' is big + f = e |> co + +Then there's a danger we'll optimise to + + f' = e + f = f' |> co + +and now postInlineUnconditionally, losing the stable unfolding on f. Now f' +won't inline because 'e' is too big. + + c.f. Note [Stable unfoldings and preInlineUnconditionally] + + +************************************************************************ +* * + Rebuilding a lambda +* * +************************************************************************ +-} + +rebuildLam :: SimplEnv + -> [OutBndr] -> OutExpr + -> SimplCont + -> SimplM OutExpr +-- (rebuildLam env bndrs body cont) +-- returns expr which means the same as \bndrs. body +-- +-- But it tries +-- a) eta reduction, if that gives a trivial expression +-- b) eta expansion [only if there are some value lambdas] +-- +-- NB: the SimplEnv already includes the [OutBndr] in its in-scope set + +rebuildLam _env [] body _cont + = return body + +rebuildLam env bndrs@(bndr:_) body cont + = {-# SCC "rebuildLam" #-} try_eta bndrs body + where + rec_ids = seRecIds env + in_scope = getInScope env -- Includes 'bndrs' + mb_rhs = contIsRhs cont + + -- See Note [Eta reduction based on evaluation context] + eval_sd = contEvalContext cont + -- NB: cont is never ApplyToVal, because beta-reduction would + -- have happened. So contEvalContext can panic on ApplyToVal. + + try_eta :: [OutBndr] -> OutExpr -> SimplM OutExpr + try_eta bndrs body + | -- Try eta reduction + seDoEtaReduction env + , Just etad_lam <- tryEtaReduce rec_ids bndrs body eval_sd + = do { tick (EtaReduction bndr) + ; return etad_lam } + + | -- Try eta expansion + Nothing <- mb_rhs -- See Note [Eta expanding lambdas] + , seEtaExpand env + , any isRuntimeVar bndrs -- Only when there is at least one value lambda already + , Just body_arity <- exprEtaExpandArity (seArityOpts env) body + = do { tick (EtaExpansion bndr) + ; let body' = etaExpandAT in_scope body_arity body + ; traceSmpl "eta expand" (vcat [text "before" <+> ppr body + , text "after" <+> ppr body']) + -- NB: body' might have an outer Cast, but if so + -- mk_lams will pull it further out, past 'bndrs' to the top + ; return (mk_lams bndrs body') } + + | otherwise + = return (mk_lams bndrs body) + + mk_lams :: [OutBndr] -> OutExpr -> OutExpr + -- mk_lams pulls casts and ticks to the top + mk_lams bndrs body@(Lam {}) + = mk_lams (bndrs ++ bndrs1) body1 + where + (bndrs1, body1) = collectBinders body + + mk_lams bndrs (Tick t expr) + | tickishFloatable t + = mkTick t (mk_lams bndrs expr) + + mk_lams bndrs (Cast body co) + | -- Note [Casts and lambdas] + seCastSwizzle env + , not (any bad bndrs) + = mkCast (mk_lams bndrs body) (mkPiCos Representational bndrs co) + where + co_vars = tyCoVarsOfCo co + bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars + + mk_lams bndrs body + = mkLams bndrs body + +{- +Note [Eta expanding lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we *do* want to eta-expand lambdas. Consider + f (\x -> case x of (a,b) -> \s -> blah) +where 's' is a state token, and hence can be eta expanded. This +showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather +important function! + +The eta-expansion will never happen unless we do it now. (Well, it's +possible that CorePrep will do it, but CorePrep only has a half-baked +eta-expander that can't deal with casts. So it's much better to do it +here.) + +However, when the lambda is let-bound, as the RHS of a let, we have a +better eta-expander (in the form of tryEtaExpandRhs), so we don't +bother to try expansion in mkLam in that case; hence the contIsRhs +guard. + +Note [Casts and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\(x:tx). (\(y:ty). e) `cast` co) + +We float the cast out, thus + (\(x:tx) (y:ty). e) `cast` (tx -> co) + +We do this for at least three reasons: + +1. There is a danger here that the two lambdas look separated, and the + full laziness pass might float an expression to between the two. + +2. The occurrence analyser will mark x as InsideLam if the Lam nodes + are separated (see the Lam case of occAnal). By floating the cast + out we put the two Lams together, so x can get a vanilla Once + annotation. If this lambda is the RHS of a let, which we inline, + we can do preInlineUnconditionally on that x=arg binding. With the + InsideLam OccInfo, we can't do that, which results in an extra + iteration of the Simplifier. + +3. It may cancel with another cast. E.g + (\x. e |> co1) |> co2 + If we float out co1 it might cancel with co2. Similarly + let f = (\x. e |> co1) in ... + If we float out co1, and then do cast worker/wrapper, we get + let f1 = \x.e; f = f1 |> co1 in ... + and now we can inline f, hoping that co1 may cancel at a call site. + +TL;DR: put the lambdas together if at all possible. + +In general, here's the transformation: + \x. e `cast` co ===> (\x. e) `cast` (tx -> co) + /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co) + /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) + (if not (g `in` co)) + +We call this "cast swizzling". It is controlled by sm_cast_swizzle. +See also Note [Cast swizzling on rule LHSs] + +Wrinkles + +* Notice that it works regardless of 'e'. Originally it worked only + if 'e' was itself a lambda, but in some cases that resulted in + fruitless iteration in the simplifier. A good example was when + compiling Text.ParserCombinators.ReadPrec, where we had a definition + like (\x. Get `cast` g) + where Get is a constructor with nonzero arity. Then mkLam eta-expanded + the Get, and the next iteration eta-reduced it, and then eta-expanded + it again. + +* Note also the side condition for the case of coercion binders, namely + not (any bad bndrs). It does not make sense to transform + /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) + because the latter is not well-kinded. + + +************************************************************************ +* * + Eta expansion +* * +************************************************************************ +-} + +tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr + -> SimplM (ArityType, OutExpr) +-- See Note [Eta-expanding at let bindings] +tryEtaExpandRhs env bind_cxt bndr rhs + | seEtaExpand env -- If Eta-expansion is on + , wantEtaExpansion rhs -- and we'd like to eta-expand e + , do_eta_expand -- and e's manifest arity is lower than + -- what it could be + -- (never true for join points) + = -- Do eta-expansion. + assertPpr( not (isJoinBC bind_cxt) ) (ppr bndr) $ + -- assert: this never happens for join points; see GHC.Core.Opt.Arity + -- Note [Do not eta-expand join points] + do { tick (EtaExpansion bndr) + ; return (arity_type, etaExpandAT in_scope arity_type rhs) } + + | otherwise + = return (arity_type, rhs) + + where + in_scope = getInScope env + arity_opts = seArityOpts env + is_rec = bindContextRec bind_cxt + (do_eta_expand, arity_type) = findRhsArity arity_opts is_rec bndr rhs + +wantEtaExpansion :: CoreExpr -> Bool +-- Mostly True; but False of PAPs which will immediately eta-reduce again +-- See Note [Which RHSs do we eta-expand?] +wantEtaExpansion (Cast e _) = wantEtaExpansion e +wantEtaExpansion (Tick _ e) = wantEtaExpansion e +wantEtaExpansion (Lam b e) | isTyVar b = wantEtaExpansion e +wantEtaExpansion (App e _) = wantEtaExpansion e +wantEtaExpansion (Var {}) = False +wantEtaExpansion (Lit {}) = False +wantEtaExpansion _ = True + +{- +Note [Eta-expanding at let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We now eta expand at let-bindings, which is where the payoff comes. +The most significant thing is that we can do a simple arity analysis +(in GHC.Core.Opt.Arity.findRhsArity), which we can't do for free-floating lambdas + +One useful consequence of not eta-expanding lambdas is this example: + genMap :: C a => ... + {-# INLINE genMap #-} + genMap f xs = ... + + myMap :: D a => ... + {-# INLINE myMap #-} + myMap = genMap + +Notice that 'genMap' should only inline if applied to two arguments. +In the stable unfolding for myMap we'll have the unfolding + (\d -> genMap Int (..d..)) +We do not want to eta-expand to + (\d f xs -> genMap Int (..d..) f xs) +because then 'genMap' will inline, and it really shouldn't: at least +as far as the programmer is concerned, it's not applied to two +arguments! + +Note [Which RHSs do we eta-expand?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't eta-expand: + +* Trivial RHSs, e.g. f = g + If we eta expand do + f = \x. g x + we'll just eta-reduce again, and so on; so the + simplifier never terminates. + +* PAPs: see Note [Do not eta-expand PAPs] + +What about things like this? + f = case y of p -> \x -> blah + +Here we do eta-expand. This is a change (Jun 20), but if we have +really decided that f has arity 1, then putting that lambda at the top +seems like a Good idea. + +Note [Do not eta-expand PAPs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have old_arity = manifestArity rhs, which meant that we +would eta-expand even PAPs. But this gives no particular advantage, +and can lead to a massive blow-up in code size, exhibited by #9020. +Suppose we have a PAP + foo :: IO () + foo = returnIO () +Then we can eta-expand to + foo = (\eta. (returnIO () |> sym g) eta) |> g +where + g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #) + +But there is really no point in doing this, and it generates masses of +coercions and whatnot that eventually disappear again. For T9020, GHC +allocated 6.6G before, and 0.8G afterwards; and residency dropped from +1.8G to 45M. + +Moreover, if we eta expand + f = g d ==> f = \x. g d x +that might in turn make g inline (if it has an inline pragma), which +we might not want. After all, INLINE pragmas say "inline only when +saturated" so we don't want to be too gung-ho about saturating! + +But note that this won't eta-expand, say + f = \g -> map g +Does it matter not eta-expanding such functions? I'm not sure. Perhaps +strictness analysis will have less to bite on? + + +************************************************************************ +* * +\subsection{Floating lets out of big lambdas} +* * +************************************************************************ + +Note [Floating and type abstraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + x = /\a. C e1 e2 +We'd like to float this to + y1 = /\a. e1 + y2 = /\a. e2 + x = /\a. C (y1 a) (y2 a) +for the usual reasons: we want to inline x rather vigorously. + +You may think that this kind of thing is rare. But in some programs it is +common. For example, if you do closure conversion you might get: + + data a :-> b = forall e. (e -> a -> b) :$ e + + f_cc :: forall a. a :-> a + f_cc = /\a. (\e. id a) :$ () + +Now we really want to inline that f_cc thing so that the +construction of the closure goes away. + +So I have elaborated simplLazyBind to understand right-hand sides that look +like + /\ a1..an. body + +and treat them specially. The real work is done in +GHC.Core.Opt.Simplify.Utils.abstractFloats, but there is quite a bit of plumbing +in simplLazyBind as well. + +The same transformation is good when there are lets in the body: + + /\abc -> let(rec) x = e in b + ==> + let(rec) x' = /\abc -> let x = x' a b c in e + in + /\abc -> let x = x' a b c in b + +This is good because it can turn things like: + + let f = /\a -> letrec g = ... g ... in g +into + letrec g' = /\a -> ... g' a ... + in + let f = /\ a -> g' a + +which is better. In effect, it means that big lambdas don't impede +let-floating. + +This optimisation is CRUCIAL in eliminating the junk introduced by +desugaring mutually recursive definitions. Don't eliminate it lightly! + +[May 1999] If we do this transformation *regardless* then we can +end up with some pretty silly stuff. For example, + + let + st = /\ s -> let { x1=r1 ; x2=r2 } in ... + in .. +becomes + let y1 = /\s -> r1 + y2 = /\s -> r2 + st = /\s -> ...[y1 s/x1, y2 s/x2] + in .. + +Unless the "..." is a WHNF there is really no point in doing this. +Indeed it can make things worse. Suppose x1 is used strictly, +and is of the form + + x1* = case f y of { (a,b) -> e } + +If we abstract this wrt the tyvar we then can't do the case inline +as we would normally do. + +That's why the whole transformation is part of the same process that +floats let-bindings and constructor arguments out of RHSs. In particular, +it is guarded by the doFloatFromRhs call in simplLazyBind. + +Note [Which type variables to abstract over] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Abstract only over the type variables free in the rhs wrt which the +new binding is abstracted. Several points worth noting + +(AB1) The naive approach of abstracting wrt the + tyvars free in the Id's /type/ fails. Consider: + /\ a b -> let t :: (a,b) = (e1, e2) + x :: a = fst t + in ... + Here, b isn't free in x's type, but we must nevertheless + abstract wrt b as well, because t's type mentions b. + Since t is floated too, we'd end up with the bogus: + poly_t = /\ a b -> (e1, e2) + poly_x = /\ a -> fst (poly_t a *b*) + +(AB2) We must do closeOverKinds. Example (#10934): + f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... + Here we want to float 't', but we must remember to abstract over + 'k' as well, even though it is not explicitly mentioned in the RHS, + otherwise we get + t = /\ (f:k->*) (a:k). AccFailure @ (f a) + which is obviously bogus. + +(AB3) We get the variables to abstract over by filtering down the + the main_tvs for the original function, picking only ones + mentioned in the abstracted body. This means: + - they are automatically in dependency order, because main_tvs is + - there is no issue about non-determinism + - we don't gratuitously change order, which may help (in a tiny + way) with CSE and/or the compiler-debugging experience + +(AB4) For a recursive group, it's a bit of a pain to work out the minimal + set of tyvars over which to abstract: + /\ a b c. let x = ...a... in + letrec { p = ...x...q... + q = .....p...b... } in + ... + Since 'x' is abstracted over 'a', the {p,q} group must be abstracted + over 'a' (because x is replaced by (poly_x a)) as well as 'b'. + Remember this bizarre case too: + x::a = x + Here, we must abstract 'x' over 'a'. + + Why is it worth doing this? Partly tidiness; and partly #22459 + which showed that it's harder to do polymorphic specialisation well + if there are dictionaries abstracted over unnecessary type variables. + See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise + +(AB5) We do dependency analysis on recursive groups prior to determining + which variables to abstract over. + This is useful, because ANFisation in prepareBinding may float out + values out of a complex recursive binding, e.g., + letrec { xs = g @a "blah"# ((:) 1 []) xs } in ... + ==> { prepareBinding } + letrec { foo = "blah"# + bar = [42] + xs = g @a foo bar xs } in + ... + and we don't want to abstract foo and bar over @a. + + (Why is it OK to float the unlifted `foo` there? + See Note [Core top-level string literals] in GHC.Core; + it is controlled by GHC.Core.Opt.Simplify.Env.unitLetFloat.) + + It is also necessary to do dependency analysis, because + otherwise (in #24551) we might get `foo = \@_ -> "missing"#` at the + top-level, and that triggers a CoreLint error because `foo` is *not* + manifestly a literal string. +-} + +abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats + -> OutExpr -> SimplM ([OutBind], OutExpr) +abstractFloats uf_opts top_lvl main_tvs floats body + = assert (notNull body_floats) $ + assert (isNilOL (sfJoinFloats floats)) $ + do { let sccs = concatMap to_sccs body_floats + ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs + ; return (float_binds, GHC.Core.Subst.substExpr subst body) } + where + is_top_lvl = isTopLevel top_lvl + body_floats = letFloatBinds (sfLetFloats floats) + empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) + + -- See wrinkle (AB5) in Note [Which type variables to abstract over] + -- for why we need to re-do dependency analysis + to_sccs :: OutBind -> [SCC (Id, CoreExpr, VarSet)] + to_sccs (NonRec id e) = [AcyclicSCC (id, e, emptyVarSet)] -- emptyVarSet: abstract doesn't need it + to_sccs (Rec prs) = sccs + where + (ids,rhss) = unzip prs + sccs = depAnal (\(id,_rhs,_fvs) -> [getName id]) + (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3) + (zip3 ids rhss (map exprFreeVars rhss)) + + abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind) + abstract subst (AcyclicSCC (id, rhs, _empty_var_set)) + = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id + ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs' + !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app + ; return (subst', NonRec poly_id2 poly_rhs) } + where + rhs' = GHC.Core.Subst.substExpr subst rhs + + -- tvs_here: see Note [Which type variables to abstract over] + tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs') + + abstract subst (CyclicSCC trpls) + = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids + ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps) + poly_pairs = [ mk_poly2 poly_id tvs_here rhs' + | (poly_id, rhs) <- poly_ids `zip` rhss + , let rhs' = GHC.Core.Subst.substExpr subst' rhs ] + ; return (subst', Rec poly_pairs) } + where + (ids,rhss,_fvss) = unzip3 trpls + + -- tvs_here: see Note [Which type variables to abstract over] + tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs trpls) + + -- See wrinkle (AB4) in Note [Which type variables to abstract over] + get_bind_fvs (id,_rhs,rhs_fvs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs_fvs + get_rec_rhs_tvs rhs_fvs = nonDetStrictFoldVarSet get_tvs emptyVarSet rhs_fvs + -- nonDet is safe because of wrinkle (AB3) + + get_tvs :: Var -> VarSet -> VarSet + get_tvs var free_tvs + | isTyVar var -- CoVars have been substituted away + = extendVarSet free_tvs var + | isCoVar var -- CoVars can be free in the RHS, but they are never let-bound; + = free_tvs -- Do not call lookupIdSubst_maybe, though (#23426) + -- because it has a non-CoVar precondition + | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var + = -- 'var' is like 'x' in (AB4) + exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs + | otherwise + = free_tvs + + choose_tvs free_tvs + = filter (`elemVarSet` all_free_tvs) main_tvs -- (AB3) + where + all_free_tvs = closeOverKinds free_tvs -- (AB2) + + mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr) + mk_poly1 tvs_here var + = do { uniq <- getUniqueM + ; let poly_name = setNameUnique (idName var) uniq -- Keep same name + poly_ty = mkInfForAllTys tvs_here (idType var) -- But new type of course + poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id + mkLocalId poly_name (idMult var) poly_ty + ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } + -- In the olden days, it was crucial to copy the occInfo of the original var, + -- because we were looking at occurrence-analysed but as yet unsimplified code! + -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking + -- at already simplified code, so it doesn't matter + -- + -- It's even right to retain single-occurrence or dead-var info: + -- Suppose we started with /\a -> let x = E in B + -- where x occurs once in B. Then we transform to: + -- let x' = /\a -> E in /\a -> let x* = x' a in B + -- where x* has an INLINE prag on it. Now, once x* is inlined, + -- the occurrences of x' will be just the occurrences originally + -- pinned on x. + + mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr) + mk_poly2 poly_id tvs_here rhs + = (poly_id `setIdUnfolding` unf, poly_rhs) + where + poly_rhs = mkLams tvs_here rhs + unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False False poly_rhs Nothing + + -- We want the unfolding. Consider + -- let + -- x = /\a. let y = ... in Just y + -- in body + -- Then we float the y-binding out (via abstractFloats and addPolyBind) + -- but 'x' may well then be inlined in 'body' in which case we'd like the + -- opportunity to inline 'y' too. + +{- +Note [Abstract over coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the +type variable a. Rather than sort this mess out, we simply bale out and abstract +wrt all the type variables if any of them are coercion variables. + + +Historical note: if you use let-bindings instead of a substitution, beware of this: + + -- Suppose we start with: + -- + -- x = /\ a -> let g = G in E + -- + -- Then we'll float to get + -- + -- x = let poly_g = /\ a -> G + -- in /\ a -> let g = poly_g a in E + -- + -- But now the occurrence analyser will see just one occurrence + -- of poly_g, not inside a lambda, so the simplifier will + -- PreInlineUnconditionally poly_g back into g! Badk to square 1! + -- (I used to think that the "don't inline lone occurrences" stuff + -- would stop this happening, but since it's the *only* occurrence, + -- PreInlineUnconditionally kicks in first!) + -- + -- Solution: put an INLINE note on g's RHS, so that poly_g seems + -- to appear many times. (NB: mkInlineMe eliminates + -- such notes on trivial RHSs, so do it manually.) + +************************************************************************ +* * + prepareAlts +* * +************************************************************************ + +prepareAlts tries these things: + +1. filterAlts: eliminate alternatives that cannot match, including + the DEFAULT alternative. Here "cannot match" includes knowledge + from GADTs + +2. refineDefaultAlt: if the DEFAULT alternative can match only one + possible constructor, then make that constructor explicit. + e.g. + case e of x { DEFAULT -> rhs } + ===> + case e of x { (a,b) -> rhs } + where the type is a single constructor type. This gives better code + when rhs also scrutinises x or e. + See GHC.Core.Utils Note [Refine DEFAULT case alternatives] + +3. combineIdenticalAlts: combine identical alternatives into a DEFAULT. + See CoreUtils Note [Combine identical alternatives], which also + says why we do this on InAlts not on OutAlts + +4. Returns a list of the constructors that cannot holds in the + DEFAULT alternative (if there is one) + +It's a good idea to do this stuff before simplifying the alternatives, to +avoid simplifying alternatives we know can't happen, and to come up with +the list of constructors that are handled, to put into the IdInfo of the +case binder, for use when simplifying the alternatives. + +Eliminating the default alternative in (1) isn't so obvious, but it can +happen: + +data Colour = Red | Green | Blue + +f x = case x of + Red -> .. + Green -> .. + DEFAULT -> h x + +h y = case y of + Blue -> .. + DEFAULT -> [ case y of ... ] + +If we inline h into f, the default case of the inlined h can't happen. +If we don't notice this, we may end up filtering out *all* the cases +of the inner case y, which give us nowhere to go! + +Note [Shadowing in prepareAlts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an +/OutId/. This is vital, because `refineDefaultAlt` uses `tys` to build +a new /InAlt/. If you pass an OutId, we'll end up applying the +substitution twice: disaster (#23012). + +However this does mean that filling in the default alt might be +delayed by a simplifier cycle, because an InId has less info than an +OutId. Test simplCore/should_compile/simpl013 apparently shows this +up, although I'm not sure exactly how.. +-} + +prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt]) +-- The returned alternatives can be empty, none are possible +-- +-- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts] +prepareAlts scrut case_bndr alts + | Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr) + = do { us <- getUniquesM + ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts + (yes2, alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1 + -- The multiplicity on case_bndr's is the multiplicity of the + -- case expression The newly introduced patterns in + -- refineDefaultAlt must be scaled by this multiplicity + (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 + -- "idcs" stands for "impossible default data constructors" + -- i.e. the constructors that can't match the default case + ; when yes2 $ tick (FillInCaseDefault case_bndr) + ; when yes3 $ tick (AltMerge case_bndr) + ; return (idcs3, alts3) } + + | otherwise -- Not a data type, so nothing interesting happens + = return ([], alts) + where + imposs_cons = case scrut of + Var v -> otherCons (idUnfolding v) + _ -> [] + +{- Note [Merging nested cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic case-merge stuff is described in Note [Merge Nested Cases] in GHC.Core.Utils + +We do it here in `prepareAlts` (on InAlts) rather than after (on OutAlts) for two reasons: + +* It "belongs" here with `filterAlts`, `refineDefaultAlt` and `combineIdenticalAlts`. + +* In test perf/compiler/T22428 I found that I was getting extra Simplifer iterations: + 1. Create a join point + 2. That join point gets inlined at all call sites, so it is now dead. + 3. Case-merge happened, but left behind some trivial bindings (see `mergeCaseAlts`) + 4. Get rid of the trivial bindings + The first two seem reasonable. It's imaginable that we could do better on + (3), by making case-merge join-point-aware, but it's not trivial. But the + fourth is just stupid. Rather than always do an extra iteration, it's better + to do the transformation on the input-end of teh Simplifier. +-} + +{- +************************************************************************ +* * + mkCase +* * +************************************************************************ + +mkCase tries these things + +* Note [Eliminate Identity Case] +* Note [Scrutinee Constant Folding] + +Note [Eliminate Identity Case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + case e of ===> e + True -> True; + False -> False + +and similar friends. + +Note [Scrutinee Constant Folding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + case x op# k# of _ { ===> case x of _ { + a1# -> e1 (a1# inv_op# k#) -> e1 + a2# -> e2 (a2# inv_op# k#) -> e2 + ... ... + DEFAULT -> ed DEFAULT -> ed + + where (x op# k#) inv_op# k# == x + +And similarly for commuted arguments and for some unary operations. + +The purpose of this transformation is not only to avoid an arithmetic +operation at runtime but to allow other transformations to apply in cascade. + +Example with the "Merge Nested Cases" optimization (from #12877): + + main = case t of t0 + 0## -> ... + DEFAULT -> case t0 `minusWord#` 1## of t1 + 0## -> ... + DEFAULT -> case t1 `minusWord#` 1## of t2 + 0## -> ... + DEFAULT -> case t2 `minusWord#` 1## of _ + 0## -> ... + DEFAULT -> ... + + becomes: + + main = case t of _ + 0## -> ... + 1## -> ... + 2## -> ... + 3## -> ... + DEFAULT -> ... + +There are some wrinkles. + +Wrinkle 1: + Do not apply caseRules if there is just a single DEFAULT alternative, + unless the case-binder is dead. Example: + case e +# 3# of b { DEFAULT -> rhs } + If we applied the transformation here we would (stupidly) get + case e of b' { DEFAULT -> let b = b' +# 3# in rhs } + and now the process may repeat, because that let will really + be a case. But if the original case binder b is dead, we instead get + case e of b' { DEFAULT -> rhs } + and there is no such problem. + + See Note [Example of case-merging and caseRules] for a compelling + example of why this dead-binder business can be really important. + + +Wrinkle 2: + The type of the scrutinee might change. E.g. + case tagToEnum (x :: Int#) of (b::Bool) + False -> e1 + True -> e2 + ==> + case x of (b'::Int#) + DEFAULT -> e1 + 1# -> e2 + +Wrinkle 3: + The case binder may be used in the right hand sides, so we need + to make a local binding for it, if it is alive. e.g. + case e +# 10# of b + DEFAULT -> blah...b... + 44# -> blah2...b... + ===> + case e of b' + DEFAULT -> let b = b' +# 10# in blah...b... + 34# -> let b = 44# in blah2...b... + + Note that in the non-DEFAULT cases we know what to bind 'b' to, + whereas in the DEFAULT case we must reconstruct the original value. + But NB: we use b'; we do not duplicate 'e'. + +Wrinkle 4: + In dataToTag we might need to make up some fake binders; + see Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold + + +Note [Example of case-merging and caseRules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The case-transformation rules are quite powerful. Here's a +subtle example from #22375. We start with + + data T = A | B | ... + deriving Eq + + f :: T -> String + f x = if | x==A -> "one" + | x==B -> "two" + | ... + +In Core after a bit of simplification we get: + + f x = case dataToTagLarge# x of a# { _DEFAULT -> + case a# of + _DEFAULT -> case dataToTagLarge# x of b# { _DEFAULT -> + case b# of + _DEFAULT -> ... + 1# -> "two" + } + 0# -> "one" + } + +Now consider what mkCase does to these case expressions. +The case-merge transformation Note [Merge Nested Cases] +does this (affecting both pairs of cases): + + f x = case dataToTagLarge# x of a# { + _DEFAULT -> case dataToTagLarge# x of b# { + _DEFAULT -> ... + 1# -> "two" + } + 0# -> "one" + } + +Now Note [caseRules for dataToTag] does its work, again +on both dataToTagLarge# cases: + + f x = case x of x1 { + _DEFAULT -> case dataToTagLarge# x1 of a# { _DEFAULT -> + case x of x2 { + _DEFAULT -> case dataToTagLarge# x2 of b# { _DEFAULT -> ... } + B -> "two" + }} + A -> "one" + } + + +The new dataToTagLarge# calls come from the "reconstruct scrutinee" part of +caseRules (note that a# and b# were not dead in the original program +before all this merging). However, since a# and b# /are/ in fact dead +in the resulting program, we are left with redundant dataToTagLarge# calls. +But they are easily eliminated by doing caseRules again, in +the next Simplifier iteration, this time noticing that a# and b# are +dead. Hence the "dead-binder" sub-case of Wrinkle 1 of Note +[Scrutinee Constant Folding] above. Once we do this we get + + f x = case x of x1 { + _DEFAULT -> case x1 of x2 { _DEFAULT -> + case x1 of x2 { + _DEFAULT -> case x2 of x3 { _DEFAULT -> ... } + B -> "two" + }} + A -> "one" + } + +and now we can do case-merge again, getting the desired + + f x = case x of + A -> "one" + B -> "two" + ... + +-} + +mkCase, mkCase1, mkCase2, mkCase3 + :: SimplMode + -> OutExpr -> OutId + -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order + -> SimplM OutExpr + +-------------------------------------------------- +-- 1. Merge Nested Cases +-- See Note [Merge Nested Cases] +-- Note [Example of case-merging and caseRules] +-- Note [Cascading case merge] +-------------------------------------------------- + +mkCase mode scrut outer_bndr alts_ty alts + | sm_case_merge mode + , Just (joins, alts') <- mergeCaseAlts outer_bndr alts + = do { tick (CaseMerge outer_bndr) + ; case_expr <- mkCase1 mode scrut outer_bndr alts_ty alts' + ; return (mkLets joins case_expr) } + -- mkCase1: don't call mkCase recursively! + -- Firstly, there's no point, because inner alts have already had + -- mkCase applied to them, so they won't have a case in their default + -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr + -- in munge_rhs may put a case into the DEFAULT branch! + | otherwise + = mkCase1 mode scrut outer_bndr alts_ty alts + +-------------------------------------------------- +-- 2. Eliminate Identity Case +-- See Note [Eliminate Identity Case] +-------------------------------------------------- + +mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case + | all identity_alt alts + = do { tick (CaseIdentity case_bndr) + ; return (mkTicks ticks $ re_cast scrut rhs1) } + where + ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) alts' + identity_alt (Alt con args rhs) = check_eq rhs con args + + check_eq (Cast rhs co) con args -- See Note [RHS casts] + = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args + check_eq (Tick t e) alt args + = tickishFloatable t && check_eq e alt args + + check_eq (Lit lit) (LitAlt lit') _ = lit == lit' + check_eq (Var v) _ _ | v == case_bndr = True + check_eq (Var v) (DataAlt con) args + | null arg_tys, null args = v == dataConWorkId con + -- Optimisation only + check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ + mkConApp2 con arg_tys args + check_eq _ _ _ = False + + arg_tys = tyConAppArgs (idType case_bndr) + + -- Note [RHS casts] + -- ~~~~~~~~~~~~~~~~ + -- We've seen this: + -- case e of x { _ -> x `cast` c } + -- And we definitely want to eliminate this case, to give + -- e `cast` c + -- So we throw away the cast from the RHS, and reconstruct + -- it at the other end. All the RHS casts must be the same + -- if (all identity_alt alts) holds. + -- + -- Don't worry about nested casts, because the simplifier combines them + + re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co + re_cast scrut _ = scrut + +mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts + + +-------------------------------------------------- +-- 2. Scrutinee Constant Folding +-- See Note [Scrutinee Constant Folding] +-------------------------------------------------- + +mkCase2 mode scrut bndr alts_ty alts + | -- See Note [Scrutinee Constant Folding] + case alts of + [Alt DEFAULT _ _] -> isDeadBinder bndr -- see wrinkle 1 + _ -> True + , sm_case_folding mode + , Just (scrut', tx_con, mk_orig) <- caseRules (smPlatform mode) scrut + = do { bndr' <- newId (fsLit "lwild") ManyTy (exprType scrut') + + ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts + -- mapMaybeM: discard unreachable alternatives + -- See Note [Unreachable caseRules alternatives] + -- in GHC.Core.Opt.ConstantFold + + ; mkCase3 mode scrut' bndr' alts_ty $ + add_default (re_sort alts') + } + + | otherwise + = mkCase3 mode scrut bndr alts_ty alts + where + -- We need to keep the correct association between the scrutinee and its + -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with + -- "let bndr = ... in": + -- + -- case v + 10 of y =====> case v of y' + -- 20 -> e1 10 -> let y = 20 in e1 + -- DEFAULT -> e2 DEFAULT -> let y = y' + 10 in e2 + -- + -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules, + -- to construct an expression equivalent to the original one, for use + -- in the DEFAULT case + + tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id + -> CoreAlt -> SimplM (Maybe CoreAlt) + tx_alt tx_con mk_orig new_bndr (Alt con bs rhs) + = case tx_con con of + Nothing -> return Nothing + Just con' -> do { bs' <- mk_new_bndrs new_bndr con' + ; return (Just (Alt con' bs' rhs')) } + where + rhs' | isDeadBinder bndr = rhs + | otherwise = bindNonRec bndr orig_val rhs + + orig_val = case con of + DEFAULT -> mk_orig new_bndr + LitAlt l -> Lit l + DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs + + mk_new_bndrs new_bndr (DataAlt dc) + | not (isNullaryRepDataCon dc) + = -- For non-nullary data cons we must invent some fake binders + -- See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold + do { us <- getUniquesM + ; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc + (tyConAppArgs (idType new_bndr)) + ; return (ex_tvs ++ arg_ids) } + mk_new_bndrs _ _ = return [] + + re_sort :: [CoreAlt] -> [CoreAlt] + -- Sort the alternatives to re-establish + -- GHC.Core Note [Case expression invariants] + re_sort alts = sortBy cmpAlt alts + + add_default :: [CoreAlt] -> [CoreAlt] + -- See Note [Literal cases] + add_default (Alt (LitAlt {}) bs rhs : alts) = Alt DEFAULT bs rhs : alts + add_default alts = alts + +{- Note [Literal cases] +~~~~~~~~~~~~~~~~~~~~~~~ +If we have + case tagToEnum (a ># b) of + False -> e1 + True -> e2 + +then caseRules for TagToEnum will turn it into + case tagToEnum (a ># b) of + 0# -> e1 + 1# -> e2 + +Since the case is exhaustive (all cases are) we can convert it to + case tagToEnum (a ># b) of + DEFAULT -> e1 + 1# -> e2 + +This may generate slightly better code (although it should not, since +all cases are exhaustive) and/or optimise better. I'm not certain that +it's necessary, but currently we do make this change. We do it here, +NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum] +in GHC.Core.Opt.ConstantFold) +-} + +-------------------------------------------------- +-- Catch-all +-------------------------------------------------- +mkCase3 _mode scrut bndr alts_ty alts + = return (Case scrut bndr alts_ty alts) + +-- See Note [Exitification] and Note [Do not inline exit join points] in +-- GHC.Core.Opt.Exitify +-- This lives here (and not in Id) because occurrence info is only valid on +-- InIds, so it's crucial that isExitJoinId is only called on freshly +-- occ-analysed code. It's not a generic function you can call anywhere. +isExitJoinId :: Var -> Bool +isExitJoinId id + = isJoinId id + && case idOccInfo id of + OneOcc { occ_in_lam = IsInsideLam } -> True + _ -> False + +{- +Note [Dead binders] +~~~~~~~~~~~~~~~~~~~~ +Note that dead-ness is maintained by the simplifier, so that it is +accurate after simplification as well as before. + +-} diff --git a/GHC/Core/Opt/SpecConstr.hs b/GHC/Core/Opt/SpecConstr.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/SpecConstr.hs @@ -0,0 +1,2946 @@ +{-# LANGUAGE LambdaCase #-} +{- +ToDo [Oct 2013] +~~~~~~~~~~~~~~~ +1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim) +2. Nuke NoSpecConstr + + +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[SpecConstr]{Specialise over constructors} +-} + +module GHC.Core.Opt.SpecConstr( + specConstrProgram, + SpecConstrAnnotation(..), + SpecFailWarning(..) + ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) + , gopt, hasPprDebug ) + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.Utils +import GHC.Core.Unfold +import GHC.Core.Opt.Simplify.Inline +import GHC.Core.FVs ( exprsFreeVarsList, exprFreeVars ) +import GHC.Core.Opt.Monad +import GHC.Core.Opt.WorkWrap.Utils +import GHC.Core.Opt.OccurAnal( BinderSwapDecision(..), scrutOkForBinderSwap ) +import GHC.Core.DataCon +import GHC.Core.Class( classTyVars ) +import GHC.Core.Coercion hiding( substCo ) +import GHC.Core.Rules +import GHC.Core.Predicate ( scopedSort, typeDeterminesValue ) +import GHC.Core.Type hiding ( substTy ) +import GHC.Core.TyCon (TyCon, tyConName ) +import GHC.Core.Multiplicity +import GHC.Core.Ppr ( pprParendExpr ) +import GHC.Core.Make ( mkImpossibleExpr ) + +import GHC.Unit.Module +import GHC.Unit.Module.ModGuts + +import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..)) +import GHC.Types.Literal ( litIsLifted ) +import GHC.Types.Id +import GHC.Types.Id.Info ( IdDetails(..) ) +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Tickish +import GHC.Types.Basic +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Unique.Supply +import GHC.Types.Unique.FM +import GHC.Types.Unique( hasKey ) + +import GHC.Data.Maybe ( fromMaybe, orElse, catMaybes, isJust, isNothing ) +import GHC.Data.FastString + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Monad + +import GHC.Builtin.Names ( specTyConKey ) + +import GHC.Exts( SpecConstrAnnotation(..) ) +import GHC.Serialized ( deserializeWithData ) + +import Control.Monad +import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL ) +import Data.List.NonEmpty ( NonEmpty (..) ) +import Data.Maybe( mapMaybe ) +import Data.Ord( comparing ) +import Data.Tuple + +{- +----------------------------------------------------- + Game plan +----------------------------------------------------- + +Consider + drop n [] = [] + drop 0 xs = [] + drop n (x:xs) = drop (n-1) xs + +After the first time round, we could pass n unboxed. This happens in +numerical code too. Here's what it looks like in Core: + + drop n xs = case xs of + [] -> [] + (y:ys) -> case n of + I# n# -> case n# of + 0 -> [] + _ -> drop (I# (n# -# 1#)) xs + +Notice that the recursive call has an explicit constructor as argument. +Noticing this, we can make a specialised version of drop + + RULE: drop (I# n#) xs ==> drop' n# xs + + drop' n# xs = let n = I# n# in ...orig RHS... + +Now the simplifier will apply the specialisation in the rhs of drop', giving + + drop' n# xs = case xs of + [] -> [] + (y:ys) -> case n# of + 0 -> [] + _ -> drop' (n# -# 1#) xs + +Much better! + +We'd also like to catch cases where a parameter is carried along unchanged, +but evaluated each time round the loop: + + f i n = if i>0 || i>n then i else f (i*2) n + +Here f isn't strict in n, but we'd like to avoid evaluating it each iteration. +In Core, by the time we've w/wd (f is strict in i) we get + + f i# n = case i# ># 0 of + False -> I# i# + True -> case n of { I# n# -> + case i# ># n# of + False -> I# i# + True -> f (i# *# 2#) n + +At the call to f, we see that the argument, n is known to be (I# n#), +and n is evaluated elsewhere in the body of f, so we can play the same +trick as above. + + +Note [Reboxing] +~~~~~~~~~~~~~~~ +We must be careful not to allocate the same constructor twice. Consider + f p = (...(case p of (a,b) -> e)...p..., + ...let t = (r,s) in ...t...(f t)...) +At the recursive call to f, we can see that t is a pair. But we do NOT want +to make a specialised copy: + f' a b = let p = (a,b) in (..., ...) +because now t is allocated by the caller, then r and s are passed to the +recursive call, which allocates the (r,s) pair again. + +This happens if + (a) the argument p is used in other than a case-scrutinisation way. + (b) the argument to the call is not a 'fresh' tuple; you have to + look into its unfolding to see that it's a tuple + +Hence the "OR" part of Note [Good arguments] below. + +ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves +allocation, but does perhaps save evals. In the RULE we'd have +something like + + f (I# x#) = f' (I# x#) x# + +If at the call site the (I# x) was an unfolding, then we'd have to +rely on CSE to eliminate the duplicate allocation.... This alternative +doesn't look attractive enough to pursue. + +ALTERNATIVE 3: ignore the reboxing problem. The trouble is that +the conservative reboxing story prevents many useful functions from being +specialised. Example: + foo :: Maybe Int -> Int -> Int + foo (Just m) 0 = 0 + foo x@(Just m) n = foo x (n-m) +Here the use of 'x' will clearly not require boxing in the specialised function. + +The strictness analyser has the same problem, in fact. Example: + f p@(a,b) = ... +If we pass just 'a' and 'b' to the worker, it might need to rebox the +pair to create (a,b). A more sophisticated analysis might figure out +precisely the cases in which this could happen, but the strictness +analyser does no such analysis; it just passes 'a' and 'b', and hopes +for the best. + +So my current choice is to make SpecConstr similarly aggressive, and +ignore the bad potential of reboxing. + + +Note [Good arguments] +~~~~~~~~~~~~~~~~~~~~~ +So we look for + +* A self-recursive function. Ignore mutual recursion for now, + because it's less common, and the code is simpler for self-recursion. + +* EITHER + + a) At a recursive call, one or more parameters is an explicit + constructor application + AND + That same parameter is scrutinised by a case somewhere in + the RHS of the function + + OR + + b) At a recursive call, one or more parameters has an unfolding + that is an explicit constructor application + AND + That same parameter is scrutinised by a case somewhere in + the RHS of the function + AND + Those are the only uses of the parameter (see Note [Reboxing]) + + +What to abstract over +~~~~~~~~~~~~~~~~~~~~~ +There's a bit of a complication with type arguments. If the call +site looks like + + f p = ...f ((:) [a] x xs)... + +then our specialised function look like + + f_spec x xs = let p = (:) [a] x xs in ....as before.... + +This only makes sense if either + a) the type variable 'a' is in scope at the top of f, or + b) the type variable 'a' is an argument to f (and hence fs) + +Actually, (a) may hold for value arguments too, in which case +we may not want to pass them. Suppose 'x' is in scope at f's +defn, but xs is not. Then we'd like + + f_spec xs = let p = (:) [a] x xs in ....as before.... + +Similarly (b) may hold too. If x is already an argument at the +call, no need to pass it again. + +Finally, if 'a' is not in scope at the call site, we could abstract +it as we do the term variables: + + f_spec a x xs = let p = (:) [a] x xs in ...as before... + +So the grand plan is: + + * abstract the call site to a constructor-only pattern + e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3) + + * Find the free variables of the abstracted pattern + + * Pass these variables, less any that are in scope at + the fn defn. But see Note [Shadowing in SpecConstr] below. + + +NOTICE that we only abstract over variables that are not in scope, +so we're in no danger of shadowing variables used in "higher up" +in f_spec's RHS. + + +Note [Shadowing in SpecConstr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In this pass we gather up usage information that may mention variables +that are bound between the usage site and the definition site; or (more +seriously) may be bound to something different at the definition site. +For example: + + f x = letrec g y v = let x = ... + in ...(g (a,b) x)... + +Since 'x' is in scope at the call site, we may make a rewrite rule that +looks like + RULE forall a,b. g (a,b) x = ... +But this rule will never match, because it's really a different 'x' at +the call site -- and that difference will be manifest by the time the +simplifier gets to it. [A worry: the simplifier doesn't *guarantee* +no-shadowing, so perhaps it may not be distinct?] + +Anyway, the rule isn't actually wrong, it's just not useful. One possibility +is to run deShadowBinds before running SpecConstr, but instead we run the +simplifier. That gives the simplest possible program for SpecConstr to +chew on; and it virtually guarantees no shadowing. + +Note [Specialising for constant parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This one is about specialising on a *constant* (but not necessarily +constructor) argument + + foo :: Int -> (Int -> Int) -> Int + foo 0 f = 0 + foo m f = foo (f m) (+1) + +It produces + + lvl_rmV :: GHC.Base.Int -> GHC.Base.Int + lvl_rmV = + \ (ds_dlk :: GHC.Base.Int) -> + case ds_dlk of wild_alH { GHC.Base.I# x_alG -> + GHC.Base.I# (GHC.Prim.+# x_alG 1) + + T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> + GHC.Prim.Int# + T.$wfoo = + \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) -> + case ww_sme of ds_Xlw { + __DEFAULT -> + case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz -> + T.$wfoo ww1_Xmz lvl_rmV + }; + 0 -> 0 + } + +The recursive call has lvl_rmV as its argument, so we could create a specialised copy +with that argument baked in; that is, not passed at all. Now it can perhaps be inlined. + +When is this worth it? Call the constant 'lvl' +- If 'lvl' has an unfolding that is a constructor, see if the corresponding + parameter is scrutinised anywhere in the body. + +- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding + parameter is applied (...to enough arguments...?) + + Also do this is if the function has RULES? + +Also + +Note [Specialising for lambda parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + foo :: Int -> (Int -> Int) -> Int + foo 0 f = 0 + foo m f = foo (f m) (\n -> n-m) + +This is subtly different from the previous one in that we get an +explicit lambda as the argument: + + T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> + GHC.Prim.Int# + T.$wfoo = + \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) -> + case ww_sm8 of ds_Xlr { + __DEFAULT -> + case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq -> + T.$wfoo + ww1_Xmq + (\ (n_ad3 :: GHC.Base.Int) -> + case n_ad3 of wild_alB { GHC.Base.I# x_alA -> + GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr) + }) + }; + 0 -> 0 + } + +I wonder if SpecConstr couldn't be extended to handle this? After all, +lambda is a sort of constructor for functions and perhaps it already +has most of the necessary machinery? + +Furthermore, there's an immediate win, because you don't need to allocate the lambda +at the call site; and if perchance it's called in the recursive call, then you +may avoid allocating it altogether. Just like for constructors. + +Looks cool, but probably rare...but it might be easy to implement. + + +Note [SpecConstr for casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a :: * + data instance T Int = T Int + + foo n = ... + where + go (T 0) = 0 + go (T n) = go (T (n-1)) + +The recursive call ends up looking like + go (T (I# ...) `cast` g) +So we want to spot the constructor application inside the cast. +That's why we have the Cast case in argToPat + +Note [Seeding recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a recursive group that is either + * nested, or + * top-level, but with no exported Ids +we can see all the calls to the function, so we seed the specialisation +loop from the calls in the body, and /not/ from the calls in the RHS. +Consider: + + bar m n = foo n (n,n) (n,n) (n,n) (n,n) + where + foo n p q r s + | n == 0 = m + | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s } + | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s } + | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s } + | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) } + +If we start with the RHSs of 'foo', we get lots and lots of specialisations, +most of which are not needed. But if we start with the (single) call +in the rhs of 'bar' we get exactly one fully-specialised copy, and all +the recursive calls go to this fully-specialised copy. Indeed, the original +function is later collected as dead code. This is very important in +specialising the loops arising from stream fusion, for example in NDP where +we were getting literally hundreds of (mostly unused) specialisations of +a local function. + +In a case like the above we end up never calling the original un-specialised +function. (Although we still leave its code around just in case.) + +Wrinkles + +* Boring calls. If we find any boring calls in the body, including + *unsaturated* ones, such as + letrec foo x y = ....foo... + in map foo xs + then we will end up calling the un-specialised function, so then we + *should* use the calls in the un-specialised RHS as seeds. We call + these "boring call patterns", and callsToNewPats reports if it finds + any of these. Then 'specialise' unleashes the usage info from the + un-specialised RHS. + +* Exported Ids. `specialise` /also/ unleashes `si_mb_unspec` + for exported Ids. That way we are sure to generate usage info from + the /un-specialised/ RHS of an exported function. + +More precisely: + +* Always start from the calls in the body of the let or (for top level) + calls in the rest of the module. See the body_calls in the call to + `specialise` in `specNonRec`, and to `go` in `specRec`. + +* si_mb_unspec holds the usage from the unspecialised RHS. + See `initSpecInfo`. + +* `specialise` will unleash si_mb_unspec, if + - `callsToNewPats` reports "boring calls found", or + - this is a top-level exported Id. + +Historical note. At an earlier point, if a top-level Id was exported, +we used only seeds from the RHS, and /not/from the body. But Dimitrios +had an example where using call patterns from the body (the other defns +in the module) was crucial. And doing so improved nofib allocation results: + multiplier: 4% better + minimax: 2.8% better +In any case, it is easier to do! + +Note [Do not specialise diverging functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Specialising a function that just diverges is a waste of code. +Furthermore, it broke GHC (simpl014) thus: + {-# STR Sb #-} + f = \x. case x of (a,b) -> f x +If we specialise f we get + f = \x. case x of (a,b) -> fspec a b +But fspec doesn't have decent strictness info. As it happened, +(f x) :: IO t, so the state hack applied and we eta expanded fspec, +and hence f. But now f's strictness is less than its arity, which +breaks an invariant. + + +Note [Forcing specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With stream fusion and in other similar cases, we want to fully +specialise some (but not necessarily all!) loops regardless of their +size and the number of specialisations. + +We allow a library to do this, in one of two ways (one which is +deprecated): + + 1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body. + + 2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts, + and then add *that* type as a parameter to the loop body + +The reason #2 is deprecated is because it requires GHCi, which isn't +available for things like a cross compiler using stage1. + +Here's a (simplified) example from the `vector` package. You may bring +the special 'force specialization' type into scope by saying: + + import GHC.Types (SPEC(..)) + +or by defining your own type (again, deprecated): + + data SPEC = SPEC | SPEC2 + {-# ANN type SPEC ForceSpecConstr #-} + +(Note this is the exact same definition of GHC.Types.SPEC, just +without the annotation.) + +After that, you say: + + foldl :: (a -> b -> a) -> a -> Stream b -> a + {-# INLINE foldl #-} + foldl f z (Stream step s _) = foldl_loop SPEC z s + where + foldl_loop !sPEC z s = case step s of + Yield x s' -> foldl_loop sPEC (f z x) s' + Skip -> foldl_loop sPEC z s' + Done -> z + +SpecConstr will spot the SPEC parameter and always fully specialise +foldl_loop. Note that + + * We have to prevent the SPEC argument from being removed by + w/w which is why (a) SPEC is a sum type, and (b) we have to seq on + the SPEC argument. + + * And lastly, the SPEC argument is ultimately eliminated by + SpecConstr itself so there is no runtime overhead. + +This is all quite ugly; we ought to come up with a better design. + +ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set +sc_force to True when calling specLoop. This flag does four things: + +(FS1) Ignore specConstrThreshold, to specialise functions of arbitrary size + (see scTopBind) +(FS2) Ignore specConstrCount, to make arbitrary numbers of specialisations + (see specialise) +(FS3) Specialise even for arguments that are not scrutinised in the loop + (see argToPat; #4448) +(FS4) Only specialise on recursive types a finite number of times + (see sc_recursive; #5550; Note [Limit recursive specialisation]) +(FS5) Use a different restriction on the maximum number of arguments which + the optimisation will specialise. We tried removing the limit on worker + args for forced specs (#14003) but this caused issues when specializing + code for large data structures (#25197). + This is handled by `too_many_worker_args` in `callsToNewPats` + +The flag holds only for specialising a single binding group, and NOT +for nested bindings. (So really it should be passed around explicitly +and not stored in ScEnv.) #14379 turned out to be caused by + f SPEC x = let g1 x = ... + in ... +We force-specialise f (because of the SPEC), but that generates a specialised +copy of g1 (as well as the original). Alas g1 has a nested binding g2; and +in each copy of g1 we get an unspecialised and specialised copy of g2; and so +on. Result, exponential. So the force-spec flag now only applies to one +level of bindings at a time. + +Mechanism for this one-level-only thing: + + - Switch it on at the call to specRec, in scExpr and scTopBinds + - Switch it off when doing the RHSs; + this can be done very conveniently in decreaseSpecCount + +What alternatives did I consider? + +* Annotating the loop itself doesn't work because (a) it is local and + (b) it will be w/w'ed and having w/w propagating annotations somehow + doesn't seem like a good idea. The types of the loop arguments + really seem to be the most persistent thing. + +* Annotating the types that make up the loop state doesn't work, + either, because (a) it would prevent us from using types like Either + or tuples here, (b) we don't want to restrict the set of types that + can be used in Stream states and (c) some types are fixed by the + user (e.g., the accumulator here) but we still want to specialise as + much as possible. + +Alternatives to ForceSpecConstr +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of giving the loop an extra argument of type SPEC, we +also considered *wrapping* arguments in SPEC, thus + data SPEC a = SPEC a | SPEC2 + + loop = \arg -> case arg of + SPEC state -> + case state of (x,y) -> ... loop (SPEC (x',y')) ... + S2 -> error ... +The idea is that a SPEC argument says "specialise this argument +regardless of whether the function case-analyses it". But this +doesn't work well: + * SPEC must still be a sum type, else the strictness analyser + eliminates it + * But that means that 'loop' won't be strict in its real payload +This loss of strictness in turn screws up specialisation, because +we may end up with calls like + loop (SPEC (case z of (p,q) -> (q,p))) +Without the SPEC, if 'loop' were strict, the case would move out +and we'd see loop applied to a pair. But if 'loop' isn't strict +this doesn't look like a specialisable call. + +Note [Limit recursive specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible for ForceSpecConstr to cause an infinite loop of specialisation. +Because there is no limit on the number of specialisations, a recursive call with +a recursive constructor as an argument (for example, list cons) will generate +a specialisation for that constructor. If the resulting specialisation also +contains a recursive call with the constructor, this could proceed indefinitely. + +For example, if ForceSpecConstr is on: + loop :: [Int] -> [Int] -> [Int] + loop z [] = z + loop z (x:xs) = loop (x:z) xs +this example will create a specialisation for the pattern + loop (a:b) c = loop' a b c + + loop' a b [] = (a:b) + loop' a b (x:xs) = loop (x:(a:b)) xs +and a new pattern is found: + loop (a:(b:c)) d = loop'' a b c d +which can continue indefinitely. + +Roman's suggestion to fix this was to stop after a couple of times on recursive types, +but still specialising on non-recursive types as much as possible. + +To implement this, we count the number of times we have gone round the +"specialise recursively" loop ('go' in 'specRec'). Once have gone round +more than N times (controlled by -fspec-constr-recursive=N) we check + + - If sc_force is off, and sc_count is (Just max) then we don't + need to do anything: trim_pats will limit the number of specs + + - Otherwise check if any function has now got more than (sc_count env) + specialisations. If sc_count is "no limit" then we arbitrarily + choose 10 as the limit (ugh). + +See #5550. Also #13623, where this test had become over-aggressive, +and we lost a wonderful specialisation that we really wanted! + +Note [NoSpecConstr] +~~~~~~~~~~~~~~~~~~~ +The ignoreDataCon stuff allows you to say + {-# ANN type T NoSpecConstr #-} +to mean "don't specialise on arguments of this type". It was added +before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised +regardless of size; and then we needed a way to turn that *off*. Now +that we have ForceSpecConstr, this NoSpecConstr is probably redundant. +(Used only for PArray, TODO: remove?) + +Note [SpecConstr and strict fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat strict fields in SpecConstr the same way we do in W/W. +That is we make the specialized function strict in arguments +representing strict fields. See Note [Call-by-value for worker args] +for why we do this. + +(SCF1) The arg_id might be an /imported/ Id like M.foo_acf (see #24944). + We don't want to make + case M.foo_acf of M.foo_acf { DEFAULT -> blah } + because the binder of a case-expression should never be imported. Rather, + we must localise it thus: + case M.foo_acf of foo_acf { DEFAULT -> blah } + We keep the same unique, so in the next round of simplification we'll replace + any M.foo_acf's in `blah` by `foo_acf`. + + c.f. Note [Localise pattern binders] in GHC.HsToCore.Utils. + +Note [Specialising on dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #21386, SpecConstr saw this call: + + $wgo 100# @.. ($fMonadStateT @.. @.. $fMonadIdentity) + +where $wgo :: Int# -> forall m. Monad m => blah + +You might think that the type-class Specialiser would have specialised +this, but there are good reasons why not: the Specialiser ran too early. +But regardless, SpecConstr can and should! It's easy: + +* isValue: treat ($fblah d1 .. dn) + like a constructor application. + +* scApp: treat (op_sel d), a class method selection, + like a case expression + +* Float that dictionary application to top level, thus + lvl = $fMonadStateT @.. @.. $fMonadIdentity + so the call looks like + ($wgo 100# @.. lvl) + + Why? This way dictionaries will appear as top level binders which we + can trivially match in rules. (CSE runs before SpecConstr, so we + may hope to common-up duplicate top-level dictionaries.) + For the floating part, see the "Arguments" case of Note + [Floating to the top] in GHC.Core.Opt.SetLevels. + + We could be more clever, perhaps, and generate a RULE like + $wgo _ @.. ($fMonadStateT @.. @.. $fMonadIdentity) = $s$wgo ... + but that would mean making argToPat able to spot dfun applications as + well as constructor applications. + +Wrinkles: + +* This should all work perfectly fine for newtype classes. Mind you, + currently newtype classes are inlined fairly agressively, but we + may change that. And it would take extra code to exclude them, as + well as being unnecessary. + +* In isValue, we (mis-) use LambdaVal for this ($fblah d1 .. dn) + because ConVal requires us to list the data constructor and + fields, and that is (a) inconvenient and (b) unnecessary for + class methods. + +----------------------------------------------------- + Stuff not yet handled +----------------------------------------------------- + +Here are notes arising from Roman's work that I don't want to lose. + +Example 1 +~~~~~~~~~ + data T a = T !a + + foo :: Int -> T Int -> Int + foo 0 t = 0 + foo x t | even x = case t of { T n -> foo (x-n) t } + | otherwise = foo (x-1) t + +SpecConstr does no specialisation, because the second recursive call +looks like a boxed use of the argument. A pity. + + $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# + $wfoo_sFw = + \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) -> + case ww_sFo of ds_Xw6 [Just L] { + __DEFAULT -> + case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] { + __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq; + 0 -> + case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] -> + case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] -> + $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy + } } }; + 0 -> 0 + +Example 2 +~~~~~~~~~ + data a :*: b = !a :*: !b + data T a = T !a + + foo :: (Int :*: T Int) -> Int + foo (0 :*: t) = 0 + foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) } + | otherwise = foo ((x-1) :*: t) + +Very similar to the previous one, except that the parameters are now in +a strict tuple. Before SpecConstr, we have + + $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# + $wfoo_sG3 = + \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T + GHC.Base.Int) -> + case ww_sFU of ds_Xws [Just L] { + __DEFAULT -> + case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] { + __DEFAULT -> + case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] -> + $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1 + }; + 0 -> + case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] -> + case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] -> + $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2 + } } }; + 0 -> 0 } + +We get two specialisations: +"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#} + Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB) + = Foo.$s$wfoo1 a_sFB sc_sGC ; +"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#} + Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp)) + = Foo.$s$wfoo y_aFp sc_sGC ; + +But perhaps the first one isn't good. After all, we know that tpl_B2 is +a T (I# x) really, because T is strict and Int has one constructor. (We can't +unbox the strict fields, because T is polymorphic!) + +************************************************************************ +* * +\subsection{Top level wrapper stuff} +* * +************************************************************************ +-} + +specConstrProgram :: ModGuts -> CoreM ModGuts +specConstrProgram guts + = do { env0 <- initScEnv guts + ; us <- getUniqueSupplyM + ; let (_usg, binds', warnings) = initUs_ us $ + scTopBinds env0 (mg_binds guts) + + ; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings) + + ; return (guts { mg_binds = binds' }) } + + where + specConstr_warn_class = MCDiagnostic SevWarning (ResolvedDiagnosticReason WarningWithoutFlag) Nothing + warn_msg :: SpecFailWarnings -> SDoc + warn_msg warnings = text "SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," $$ + text "which resulted in no specialization being generated for these functions:" $$ + nest 2 (vcat (map ppr warnings)) $$ + (text "If this is expected you might want to increase -fmax-forced-spec-args to force specialization anyway.") +scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind], [SpecFailWarning]) +scTopBinds _env [] = return (nullUsage, [], []) +scTopBinds env (b:bs) = do { (usg, b', bs', warnings) <- scBind TopLevel env b $ + (\env -> scTopBinds env bs) + ; return (usg, b' ++ bs', warnings) } + +{- +************************************************************************ +* * +\subsection{Environment: goes downwards} +* * +************************************************************************ + +Note [ConVal work-free-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_vals field keeps track of in-scope value bindings, and is used in +two ways: + +(1) To do case-of-known-constructor in a case expression. E.g. if sc_vals + includes [x :-> ConVal Just e], then we can simplify + case x of Just y -> ... + with the case-of-known-constructor transformation. (Yes this is + done by the Simplifier, but SpecConstr creates new opportunities when + it makes a specialised RHS for a function.) + + For (1) it is crucial that the arguments are /work-free/; see (CV1) + below. + +(2) To figure out call pattresns. E.g. if sc_vals includes + [x :-> ConVal Just e], and we have call (f x), then we might want + to specialise `f (Just _)` + + For (2) it is /not/ important that the constructor arguments are work-free; + indeed, it would be bad to insist on that. For example + let x = Just + in ....(f x)... + Here we want to specialise for `f (Just _)`, and we won't do so if we + don't allow [x :-> ConVal Just e] into the environment. Does this ever happen? + Yes: see #24282. + + (Yes, the Simplifier will ANF that let-binding, but SpecConstr can + make more: see (CV1) for an example.) + +Wrinkle: + +(CV1) Why is work-free-ness important for (1)? In the example in (1) above, of `e` is + expensive, we do /not/ want to simplify + case x of { Just y -> ... } ==> let y = e in ... + because the x-binding still exists and we've now duplicated `e`. + + This seldom happens because let-bound constructor applications are ANF-ised, but + it can happen as a result of on-the-fly transformations in SpecConstr itself. + Here is #7865: + + let { a'_shr = + case xs_af8 of _ { + [] -> acc_af6; + : ds_dgt [Dmd=] ds_dgu [Dmd=] -> + (expensive x_af7, x_af7 + } } in + let { ds_sht = + case a'_shr of _ { (p'_afd, q'_afe) -> + TSpecConstr_DoubleInline.recursive + (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd) + } } in + + When processed knowing that xs_af8 was bound to a cons, we simplify to + a'_shr = (expensive x_af7, x_af7) + and we do NOT want to inline that at the occurrence of a'_shr in ds_sht. + (There are other occurrences of a'_shr.) No no no. + + It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned + into a work-free value again, thus + a1 = expensive x_af7 + a'_shr = (a1, x_af7) + but that's more work, so until its shown to be important I'm going to + leave it for now. + +Note [Making SpecConstr keener] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this, in (perf/should_run/T9339) + last (filter odd [1..1000]) + +After optimisation, including SpecConstr, we get: + f :: Int# -> Int -> Int + f x y = case remInt# x 2# of + __DEFAULT -> case x of + __DEFAULT -> f (+# wild_Xp 1#) (I# x) + 1000000# -> ... + 0# -> case x of + __DEFAULT -> f (+# wild_Xp 1#) y + 1000000# -> y + +Not good! We build an (I# x) box every time around the loop. +SpecConstr (as described in the paper) does not specialise f, despite +the call (f ... (I# x)) because 'y' is not scrutinised in the body. +But it is much better to specialise f for the case where the argument +is of form (I# x); then we build the box only when returning y, which +is on the cold path. + +Another example: + + f x = ...(g x).... + +Here 'x' is not scrutinised in f's body; but if we did specialise 'f' +then the call (g x) might allow 'g' to be specialised in turn. + +So sc_keen controls whether or not we take account of whether argument is +scrutinised in the body. True <=> ignore that, and specialise whenever +the function is applied to a data constructor. +-} + +-- | Options for Specializing over constructors in Core. +data SpecConstrOpts = SpecConstrOpts + { sc_max_args :: !Int + -- ^ The threshold at which a worker-wrapper transformation used as part of + -- this pass will no longer happen, measured in the number of arguments. + + , sc_max_forced_args :: !Int + -- ^ The threshold at which a worker-wrapper transformation used as part of + -- this pass will no longer happen even if a SPEC arg was used to force + -- specialization. Measured in the number of arguments. + -- See Note [Forcing specialisation] + + , sc_debug :: !Bool + -- ^ Whether to print debug information + + , sc_uf_opts :: !UnfoldingOpts + -- ^ Unfolding options + + , sc_module :: !Module + -- ^ The name of the module being processed + + , sc_size :: !(Maybe Int) + -- ^ Size threshold: Nothing => no limit + + , sc_count :: !(Maybe Int) + -- ^ Max # of specialisations for any one function. Nothing => no limit. + -- See Note [Avoiding exponential blowup] and decreaseSpecCount + + , sc_recursive :: !Int + -- ^ Max # of specialisations over recursive type. Stops + -- ForceSpecConstr from diverging. + + , sc_keen :: !Bool + -- ^ Specialise on arguments that are known constructors, even if they are + -- not scrutinised in the body. See Note [Making SpecConstr keener]. + } + +data ScEnv = SCE { sc_opts :: !SpecConstrOpts, + sc_force :: Bool, -- Force specialisation? + -- See Note [Forcing specialisation] + + sc_subst :: Subst, -- Current substitution + -- Maps InIds to OutExprs + + sc_how_bound :: HowBoundEnv, + -- Binds interesting non-top-level variables + -- Domain is OutVars (*after* applying the substitution) + + sc_vals :: ValueEnv, + -- Domain is OutIds (*after* applying the substitution) + -- Used even for top-level bindings (but not imported ones) + + sc_annotations :: UniqFM Name SpecConstrAnnotation + } + +--------------------- +type HowBoundEnv = VarEnv HowBound -- Domain is OutVars + +--------------------- +type ValueEnv = IdEnv Value -- Domain is OutIds + +data Value = ConVal -- Constructor application + Bool -- True <=> all args are work-free + -- See Note [ConVal work-free-ness] + AltCon -- Never DEFAULT + [CoreArg] -- Saturates the constructor + | LambdaVal -- Inlinable lambdas or PAPs + +instance Outputable Value where + ppr LambdaVal = text "" + ppr (ConVal wf con args) + | null args = ppr con + | otherwise = parens (ppr con <> braces pp_wf <+> interpp'SP args) + where + pp_wf | wf = text "wf" + | otherwise = text "not-wf" + + +--------------------- +initScOpts :: DynFlags -> Module -> SpecConstrOpts +initScOpts dflags this_mod = SpecConstrOpts + { sc_max_args = maxWorkerArgs dflags, + sc_max_forced_args = maxForcedSpecArgs dflags, + sc_debug = hasPprDebug dflags, + sc_uf_opts = unfoldingOpts dflags, + sc_module = this_mod, + sc_size = specConstrThreshold dflags, + sc_count = specConstrCount dflags, + sc_recursive = specConstrRecursive dflags, + sc_keen = gopt Opt_SpecConstrKeen dflags + } + +initScEnv :: ModGuts -> CoreM ScEnv +initScEnv guts + = do { dflags <- getDynFlags + ; (_, anns) <- getFirstAnnotations deserializeWithData guts + ; this_mod <- getModule + ; return (SCE { sc_opts = initScOpts dflags this_mod, + sc_force = False, + sc_subst = init_subst, + sc_how_bound = emptyVarEnv, + sc_vals = emptyVarEnv, + sc_annotations = anns }) } + where + init_subst = mkEmptySubst $ mkInScopeSetBndrs (mg_binds guts) + -- Acccount for top-level bindings that are not in dependency order; + -- see Note [Glomming] in GHC.Core.Opt.OccurAnal + -- Easiest thing is to bring all the top level binders into scope at once, + -- as if at once, as if all the top-level decls were mutually recursive. + +data HowBound = RecFun -- These are the recursive functions for which + -- we seek interesting call patterns + + | RecArg -- These are those functions' arguments, or their sub-components; + -- we gather occurrence information for these + +instance Outputable HowBound where + ppr RecFun = text "RecFun" + ppr RecArg = text "RecArg" + +scForce :: ScEnv -> Bool -> ScEnv +scForce env b = env { sc_force = b } + +lookupHowBound :: ScEnv -> OutId -> Maybe HowBound +lookupHowBound env id = lookupVarEnv (sc_how_bound env) id + +scSubstId :: ScEnv -> InId -> OutExpr +scSubstId env v = lookupIdSubst (sc_subst env) v + + + + +-- The !subst ensures that we force the selection `(sc_subst env)`, which avoids +-- retaining all of `env` when we only need `subst`. The `Solo` means that the +-- substitution itself is lazy, because that type is often discarded. +-- The callers of `scSubstTy` always force the result (to unpack the `Solo`) +-- so we get the desired effect: we leave a thunk, but retain only the subst, +-- not the whole env. +-- +-- Fully forcing the result of `scSubstTy` regresses performance (#22102) +scSubstTy :: ScEnv -> InType -> Solo OutType +scSubstTy env ty = + let !subst = sc_subst env + in MkSolo (substTyUnchecked subst ty) + +scSubstCo :: ScEnv -> Coercion -> Coercion +scSubstCo env co = substCo (sc_subst env) co + +zapScSubst :: ScEnv -> ScEnv +zapScSubst env = env { sc_subst = zapSubst (sc_subst env) } + +extendScInScope :: ScEnv -> [Var] -> ScEnv + -- Bring the quantified variables into scope +extendScInScope env qvars + = env { sc_subst = extendSubstInScopeList (sc_subst env) qvars } + + -- Extend the substitution +extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv +extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr } + +extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv +extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs } + +extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv +extendHowBound env bndrs how_bound + = env { sc_how_bound = extendVarEnvList (sc_how_bound env) + [(bndr,how_bound) | bndr <- bndrs] } + +extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var]) +extendBndrsWith how_bound env bndrs + = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs') + where + (subst', bndrs') = substBndrs (sc_subst env) bndrs + hb_env' = sc_how_bound env `extendVarEnvList` + [(bndr,how_bound) | bndr <- bndrs'] + +extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var) +extendBndrWith how_bound env bndr + = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr') + where + (subst', bndr') = substBndr (sc_subst env) bndr + hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound + +extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var]) +extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs') + where + (subst', bndrs') = substRecBndrs (sc_subst env) bndrs + +extendBndrs :: ScEnv -> [Var] -> (ScEnv, [Var]) +extendBndrs env bndrs = mapAccumL extendBndr env bndrs + +extendBndr :: ScEnv -> Var -> (ScEnv, Var) +extendBndr env bndr = (env { sc_subst = subst' }, bndr') + where + (subst', bndr') = substBndr (sc_subst env) bndr + +extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv +extendValEnv env id mb_val + = case mb_val of + Nothing -> env + Just cv -> env { sc_vals = extendVarEnv (sc_vals env) id cv } + +extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) +-- When we encounter +-- case scrut of b +-- C x y -> ... +-- we want to bind b, to (C x y) +-- NB1: Extends only the sc_vals part of the envt +-- NB2: Kill the dead-ness info on the pattern binders x,y, since +-- they are potentially made alive by the [b -> C x y] binding +extendCaseBndrs env scrut case_bndr con alt_bndrs + = (env2, alt_bndrs') + where + live_case_bndr = not (isDeadBinder case_bndr) + env1 | DoBinderSwap v mco <- scrutOkForBinderSwap scrut + , isReflMCo mco = extendValEnv env v cval + | otherwise = env -- See Note [Add scrutinee to ValueEnv too] + env2 | live_case_bndr = extendValEnv env1 case_bndr cval + | otherwise = env1 + + alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr } + = map zap alt_bndrs + | otherwise + = alt_bndrs + + cval = case con of + DEFAULT -> Nothing + LitAlt {} -> Just (ConVal True con []) + DataAlt {} -> Just (ConVal True con vanilla_args) + where + vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ + varsToCoreExprs alt_bndrs + + zap v | isTyVar v = v -- See NB2 above + | otherwise = zapIdOccInfo v + + +decreaseSpecCount :: ScEnv -> Int -> ScEnv +-- See Note [Avoiding exponential blowup] +decreaseSpecCount env _n_specs + = env { sc_force = False -- See Note [Forcing specialisation] + , sc_opts = opts { sc_count = case sc_count opts of + Nothing -> Nothing + Just n -> Just $! dec n + } + } + where + opts = sc_opts env + dec n = n `div` 2 -- See Note [Avoiding exponential blowup] + + -- Or: n `div` (n_specs + 1) + -- See the historical note part of Note [Avoiding exponential blowup] + -- The "+1" takes account of the original function; + +--------------------------------------------------- +-- See Note [Forcing specialisation] +ignoreType :: ScEnv -> Type -> Bool +ignoreDataCon :: ScEnv -> DataCon -> Bool +forceSpecBndr :: ScEnv -> Var -> Bool + +ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) + +ignoreType env ty + = case tyConAppTyCon_maybe ty of + Just tycon -> ignoreTyCon env tycon + _ -> False + +ignoreTyCon :: ScEnv -> TyCon -> Bool +ignoreTyCon env tycon + = lookupUFM (sc_annotations env) (tyConName tycon) == Just NoSpecConstr + +forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTyCoVars . varType $ var + +forceSpecFunTy :: ScEnv -> Type -> Bool +forceSpecFunTy env = any (forceSpecArgTy env) . map scaledThing . fst . splitFunTys + +forceSpecArgTy :: ScEnv -> Type -> Bool +forceSpecArgTy env ty + | isFunTy ty + = False + + | Just (tycon, tys) <- splitTyConApp_maybe ty + = tycon `hasKey` specTyConKey + || lookupUFM (sc_annotations env) (tyConName tycon) == Just ForceSpecConstr + || any (forceSpecArgTy env) tys + +forceSpecArgTy _ _ = False + +{- +Note [Add scrutinee to ValueEnv too] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +By the time we get to the call (f y), the ValueEnv +will have a binding for y, and for c + y -> (a,b) + c -> I# v +BUT that's not enough! Looking at the call (f y) we +see that y is pair (a,b), but we also need to know what 'b' is. +So in extendCaseBndrs we must *also* add the binding + b -> I# v +else we lose a useful specialisation for f. This is necessary even +though the simplifier has systematically replaced uses of 'x' with 'y' +and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came +from outside the case. See #4908 for the live example. + +It's very like the binder-swap story, so we use scrutOkForBinderSwap +to identify suitable scrutinees -- but only if there is no cast +(isReflMCo) because that's all that the ValueEnv allows. + +Note [Avoiding exponential blowup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_count field of the ScEnv says how many times we are prepared to +duplicate a single function. But we must take care with recursive +specialisations. Consider + + let $j1 = let $j2 = let $j3 = ... + in + ...$j3... + in + ...$j2... + in + ...$j1... + +If we specialise $j1 then in each specialisation (as well as the original) +we can specialise $j2, and similarly $j3. Even if we make just *one* +specialisation of each, because we also have the original we'll get 2^n +copies of $j3, which is not good. + +So when recursively specialising we divide the sc_count (the maximum +number of specialisations, in the ScEnv) by two. You might think that +gives us n*(n/2)*(n/4)... copies of the innnermost thing, which is +still exponential the depth. But we use integer division, rounding +down, so if the starting sc_count is 3, we'll get 3 -> 1 -> 0, and +stop. In fact, simply subtracting 1 would be good enough, for the same +reason. + +Historical note: in the past we divided by (n_specs+1), where n_specs +is the number of specialisations at this level; but that gets us down +to zero jolly quickly, which I found led to some regressions. (An +example is nofib/spectral/fibheaps, the getMin' function inside the +outer function $sfibToList, which has several interesting call +patterns.) + +************************************************************************ +* * +\subsection{Usage information: flows upwards} +* * +************************************************************************ +-} + +data ScUsage + = SCU { + scu_calls :: CallEnv, -- Calls + -- The functions are a subset of the + -- RecFuns in the ScEnv + + scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences + } -- The domain is OutIds + +type CallEnv = IdEnv [Call] -- Domain is OutIds +data Call = Call OutId [CoreArg] ValueEnv + -- The arguments of the call, together with the + -- env giving the constructor bindings at the call site + -- We keep the function mainly for debug output + -- + -- The call is not necessarily saturated; we just put + -- in however many args are visible at the call site + +instance Outputable ScUsage where + ppr (SCU { scu_calls = calls, scu_occs = occs }) + = text "SCU" <+> braces (sep [ text "calls =" <+> ppr calls + , text "occs =" <+> ppr occs ]) + +instance Outputable Call where + ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args) + +nullUsage :: ScUsage +nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv } + +combineCalls :: CallEnv -> CallEnv -> CallEnv +combineCalls = plusVarEnv_C (++) + +delCallsFor :: ScUsage -> [Var] -> ScUsage +delCallsFor env bndrs = env { scu_calls = scu_calls env `delVarEnvList` bndrs } + +combineUsage :: ScUsage -> ScUsage -> ScUsage +combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2), + scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) } + +combineUsages :: [ScUsage] -> ScUsage +combineUsages = foldr1WithDefault nullUsage combineUsage + +lookupOccs :: Traversable f => ScUsage -> f OutVar -> (ScUsage, f ArgOcc) +lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs + = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, + fromMaybe NoOcc . lookupVarEnv sc_occs <$> bndrs) + +data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument + | UnkOcc -- Used in some unknown way + + | ScrutOcc -- See Note [ScrutOcc] + (DataConEnv [ArgOcc]) + -- [ArgOcc]: how the sub-components are used + +deadArgOcc :: ArgOcc -> Bool +deadArgOcc (ScrutOcc {}) = False +deadArgOcc UnkOcc = False +deadArgOcc NoOcc = True + +specialisableArgOcc :: ArgOcc -> Bool +-- | Does this occurrence represent one worth specializing for. +specialisableArgOcc UnkOcc = False +specialisableArgOcc NoOcc = False +specialisableArgOcc (ScrutOcc {}) = True + + +{- Note [ScrutOcc] +~~~~~~~~~~~~~~~~~~ +An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, +is *only* taken apart or applied. + + Functions, literal: ScrutOcc emptyUFM + Data constructors: ScrutOcc subs, + +where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components, +The domain of the UniqFM is the Unique of the data constructor + +The [ArgOcc] is the occurrences of the *pattern-bound* components +of the data structure. E.g. + data T a = forall b. MkT a b (b->a) +A pattern binds b, x::a, y::b, z::b->a, but not 'a'! + +-} + +instance Outputable ArgOcc where + ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs + ppr UnkOcc = text "unk-occ" + ppr NoOcc = text "no-occ" + +evalScrutOcc :: ArgOcc +-- We use evalScrutOcc for +-- - mkVarUsage: applied functions +-- - scApp: dicts that are the argument of a classop +evalScrutOcc = ScrutOcc emptyUFM + +-- Experimentally, this version of combineOcc makes ScrutOcc "win", so +-- that if the thing is scrutinised anywhere then we get to see that +-- in the overall result, even if it's also used in a boxed way +-- This might be too aggressive; see Note [Reboxing] Alternative 3 +combineOcc :: ArgOcc -> ArgOcc -> ArgOcc +combineOcc NoOcc occ = occ +combineOcc occ NoOcc = occ +combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys) +combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys +combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs +combineOcc UnkOcc UnkOcc = UnkOcc + +combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] +combineOccs xs ys = zipWithEqual combineOcc xs ys + +setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage +-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee +-- is a variable, and an interesting variable +setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ +setScrutOcc env usg (Tick _ e) occ = setScrutOcc env usg e occ +setScrutOcc env usg (Var v) occ + | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ } + | otherwise = usg +setScrutOcc _env usg _other _occ -- Catch-all + = usg + +{- +************************************************************************ +* * +\subsection{The main recursive function} +* * +************************************************************************ + +The main recursive function gathers up usage information, and +creates specialised versions of functions. +-} + +scBind :: TopLevelFlag -> ScEnv -> InBind + -> (ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning])) -- Specialise the scope of the binding + -> UniqSM (ScUsage, [OutBind], a, [SpecFailWarning]) +scBind top_lvl env (NonRec bndr rhs) do_body + | isTyVar bndr -- Type-lets may be created by doBeta + = do { (final_usage, body', warnings) <- do_body (extendScSubst env bndr rhs) + ; return (final_usage, [], body', warnings) } + + | not (isTopLevel top_lvl) -- Nested non-recursive value binding + -- See Note [Specialising local let bindings] + = do { let (body_env, bndr') = extendBndr env bndr + -- Not necessary at top level; but here we are nested + + ; (rhs_info, rhs_ws) <- scRecRhs env (bndr',rhs) + + ; let body_env2 = extendHowBound body_env [bndr'] RecFun + rhs' = ri_new_rhs rhs_info + body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') + + ; (body_usg, body', warnings_body) <- do_body body_env3 + + -- Now make specialised copies of the binding, + -- based on calls in body_usg + ; (spec_usg, specs, warnings_bnd) <- specNonRec env (scu_calls body_usg) rhs_info + -- NB: For non-recursive bindings we inherit sc_force flag from + -- the parent function (see Note [Forcing specialisation]) + + -- Specialized + original binding + ; let spec_bnds = [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] + bind_usage = (body_usg `delCallsFor` [bndr']) + `combineUsage` spec_usg -- Note [spec_usg includes rhs_usg] + + ; return (bind_usage, spec_bnds, body', mconcat [warnings_bnd, warnings_body, rhs_ws]) + } + + | otherwise -- Top-level, non-recursive value binding + -- At top level we do not specialise non-recursive bindings; that + -- is, we do not call specNonRec, passing the calls from the body. + -- The original paper only specialised /recursive/ bindings, but + -- we later started specialising nested non-recursive bindings: + -- see Note [Specialising local let bindings] + -- + -- I tried always specialising non-recursive top-level bindings too, + -- but found some regressions (see !8135). So I backed off. + = do { (rhs_usage, rhs', ws_rhs) <- scExpr env rhs + + -- At top level, we've already put all binders into scope; see initScEnv + -- Hence no need to call `extendBndr`. But we still want to + -- extend the `ValueEnv` to record the value of this binder. + ; let body_env = extendValEnv env bndr (isValue (sc_vals env) rhs') + ; (body_usage, body', body_warnings) <- do_body body_env + + ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body', body_warnings ++ ws_rhs) } + +scBind top_lvl env (Rec prs) do_body + | isTopLevel top_lvl + , Just threshold <- sc_size (sc_opts env) + , not force_spec -- See Note [Forcing specialisation], point (FS1) + , not (all (couldBeSmallEnoughToInline (sc_uf_opts (sc_opts env)) threshold) rhss) + = -- Do no specialisation if the RHSs are too big + -- ToDo: I'm honestly not sure of the rationale of this size-testing, nor + -- why it only applies at top level. But that's the way it has been + -- for a while. See #21456. + do { (body_usg, body', warnings_body) <- do_body rhs_env2 + ; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (scExpr env) rhss + ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg) + `delCallsFor` bndrs' + bind' = Rec (bndrs' `zip` rhss') + ; return (all_usg, [bind'], body', warnings_body ++ concat rhs_ws) } + + | otherwise + = do { (rhs_infos, rhs_wss) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) + ; let rhs_ws = mconcat rhs_wss + ; (body_usg, body', warnings_body) <- do_body rhs_env2 + + ; (spec_usg, specs, spec_ws) <- specRec (scForce rhs_env2 force_spec) + (scu_calls body_usg) rhs_infos + -- Do not unconditionally generate specialisations from rhs_usgs + -- Instead use them only if we find an unspecialised call + -- See Note [Seeding recursive groups] + + ; let all_usg = (spec_usg `combineUsage` body_usg) -- Note [spec_usg includes rhs_usg] + `delCallsFor` bndrs' + bind' = Rec (concat (zipWithEqual ruleInfoBinds rhs_infos specs)) + -- zipWithEqual: length of returned [SpecInfo] + -- should be the same as incoming [RhsInfo] + + ; return (all_usg, [bind'], body', mconcat [warnings_body,rhs_ws,spec_ws]) } + where + (bndrs,rhss) = unzip prs + force_spec = any (forceSpecBndr env) bndrs -- Note [Forcing specialisation] + + (rhs_env1,bndrs') | isTopLevel top_lvl = (env, bndrs) + | otherwise = extendRecBndrs env bndrs + -- At top level, we've already put all binders into scope; see initScEnv + + rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun + +{- Note [Specialising local let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is not uncommon to find this + + let $j = \x. in ...$j True...$j True... + +Here $j is an arbitrary let-bound function, but it often comes up for +join points. We might like to specialise $j for its call patterns. +Notice the difference from a letrec, where we look for call patterns +in the *RHS* of the function. Here we look for call patterns in the +*body* of the let. + +At one point I predicated this on the RHS mentioning the outer +recursive function, but that's not essential and might even be +harmful. I'm not sure. +-} + +withWarnings :: SpecFailWarnings -> (ScUsage, CoreExpr, SpecFailWarnings) -> (ScUsage, CoreExpr, SpecFailWarnings) +withWarnings ws (use,expr,ws2) = (use,expr,ws ++ ws2) + +------------------------ +scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings) + -- The unique supply is needed when we invent + -- a new name for the specialised function and its args + +scExpr env e = scExpr' env e + +scExpr' env (Var v) = case scSubstId env v of + Var v' -> return (mkVarUsage env v' [], Var v', []) + e' -> scExpr (zapScSubst env) e' + +scExpr' env (Type t) = + let !(MkSolo ty') = scSubstTy env t + in return (nullUsage, Type ty', []) +scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c), []) +scExpr' _ e@(Lit {}) = return (nullUsage, e, []) +scExpr' env (Tick t e) = do (usg, e', ws) <- scExpr env e + return (usg, Tick (scTickish env t) e', ws) +scExpr' env (Cast e co) = do (usg, e', ws) <- scExpr env e + return (usg, mkCast e' (scSubstCo env co), ws) + -- Important to use mkCast here + -- See Note [SpecConstr call patterns] +scExpr' env e@(App _ _) = scApp env (collectArgs e) +scExpr' env (Lam b e) = do let (env', b') = extendBndr env b + (usg, e', ws) <- scExpr env' e + return (usg, Lam b' e', ws) + +scExpr' env (Let bind body) + = do { (final_usage, binds', body', ws) <- scBind NotTopLevel env bind $ + (\env -> scExpr env body) + ; return (final_usage, mkLets binds' body', ws) } + +scExpr' env (Case scrut b ty alts) + = do { (scrut_usg, scrut', ws) <- scExpr env scrut + ; case isValue (sc_vals env) scrut' of + Just (ConVal args_are_work_free con args) + | args_are_work_free -> sc_con_app con args scrut' ws + -- Don't duplicate work!! #7865 + -- See Note [ConVal work-free-ness] (1) + _other -> sc_vanilla scrut_usg scrut' ws + } + where + sc_con_app con args scrut' ws -- Known constructor; simplify + = do { let Alt _ bs rhs = findAlt con alts + `orElse` Alt DEFAULT [] (mkImpossibleExpr ty "SpecConstr") + alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) + ; (use',expr',ws_new) <- scExpr alt_env' rhs + ; return (use',expr',ws ++ ws_new) } + + sc_vanilla scrut_usg scrut' ws -- Normal case + = do { let (alt_env,b') = extendBndrWith RecArg env b + -- Record RecArg for the components + + ; (alt_usgs, alt_occs, alts', ws_alts) <- mapAndUnzip4M (sc_alt alt_env scrut' b') alts + + ; let scrut_occ = foldr combineOcc NoOcc alt_occs + scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ + -- The combined usage of the scrutinee is given + -- by scrut_occ, which is passed to setScrutOcc, which + -- in turn treats a bare-variable scrutinee specially + ; let !(MkSolo ty') = scSubstTy env ty + + ; return (foldr combineUsage scrut_usg' alt_usgs, + Case scrut' b' ty' alts', ws ++ concat ws_alts) } + + single_alt = isSingleton alts + + sc_alt env scrut' b' (Alt con bs rhs) + = do { let (env1, bs1) = extendBndrsWith RecArg env bs + (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 + ; (usg, rhs', ws) <- scExpr env2 rhs + ; let (usg', b_occ:|arg_occs) = lookupOccs usg (b':|bs2) + scrut_occ = case con of + DataAlt dc -- See Note [Do not specialise evals] + | not (single_alt && all deadArgOcc arg_occs) + -> ScrutOcc (unitUFM dc arg_occs) + _ -> UnkOcc + ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs', ws) } + + +-- | Substitute the free variables captured by a breakpoint. +-- Variables are dropped if they have a non-variable substitution, like in +-- 'GHC.Opt.Specialise.specTickish'. +scTickish :: ScEnv -> CoreTickish -> CoreTickish +scTickish SCE {sc_subst = subst} = substTickish subst + +{- Note [Do not specialise evals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x y = case x of I# _ -> + if y>1 then f x (y-1) else x + +Here `x` is scrutinised by a case, but only in an eval-like way; the +/component/ of the I# is unused. We don't want to specialise this +function, even if we find a call (f (I# z)), because nothing is gained + * No case branches are discarded + * No allocation in removed +The specialised version would take an unboxed Int#, pass it along, +and rebox it at the end. + +In fact this can cause significant regression. In #21763 we had: +like + f = ... case x of x' { I# n -> + join j y = rhs + in ...jump j x'... + +Now if we specialise `j` for the argument `I# n`, we'll end up reboxing +it in `j`, without even removing an allocation from the call site. + +Reboxing is always a worry. But here we can ameliorate the problem as +follows. + +* In scExpr (Case ...), for a /single-alternative/ case expression, in + which the pattern binders are all unused, we build a UnkOcc for + the scrutinee, not one that maps the data constructor; we don't treat + this occurrence as a reason for specialisation. + +* Conveniently, SpecConstr is doing its own occurrence analysis, so + the "unused" bit is just looking for NoOcc + +* Note that if we have + f x = case x of { True -> e1; False -> e2 } + then even though the pattern binders are unused (there are none), it is + still worth specialising on x. Hence the /single-alternative/ guard. +-} + +scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings) + +scApp env (Var fn, args) -- Function is a variable + = assert (not (null args)) $ + do { args_w_usgs <- mapM (scExpr env) args + ; let (arg_usgs, args', arg_ws) = unzip3 args_w_usgs + arg_usg = combineUsages arg_usgs + arg_w = concat arg_ws + ; case scSubstId env fn of + fn'@(Lam {}) -> withWarnings arg_w <$> scExpr (zapScSubst env) (doBeta fn' args') + -- Do beta-reduction and try again + + Var fn' -> return (arg_usg' `combineUsage` mkVarUsage env fn' args', + mkApps (Var fn') args', arg_w ) + where + -- arg_usg': see Note [Specialising on dictionaries] + arg_usg' | Just cls <- isClassOpId_maybe fn' + , dict_arg : _ <- dropList (classTyVars cls) args' + = setScrutOcc env arg_usg dict_arg evalScrutOcc + | otherwise + = arg_usg + + other_fn' -> return (arg_usg, mkApps other_fn' args', arg_w) } + -- NB: doing this ignores any usage info from the substituted + -- function, but I don't think that matters. If it does + -- we can fix it. + where + doBeta :: OutExpr -> [OutExpr] -> OutExpr + doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args) + doBeta fn args = mkApps fn args + +-- The function is almost always a variable, but not always. +-- In particular, if this pass follows float-in, +-- which it may, we can get +-- (let f = ...f... in f) arg1 arg2 +scApp env (other_fn, args) + = do { (fn_usg, fn', fn_ws) <- scExpr env other_fn + ; (arg_usgs, args', arg_ws) <- mapAndUnzip3M (scExpr env) args + ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args', combineSpecWarning fn_ws (concat arg_ws)) } + +---------------------- +mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage +mkVarUsage env fn args + = case lookupHowBound env fn of + Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)] + , scu_occs = emptyVarEnv } + Just RecArg -> SCU { scu_calls = emptyVarEnv + , scu_occs = unitVarEnv fn arg_occ } + Nothing -> nullUsage + where + arg_occ | null args = UnkOcc + | otherwise = evalScrutOcc + +---------------------- +scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (RhsInfo, SpecFailWarnings) +scRecRhs env (bndr,rhs) + = do { let (arg_bndrs,body) = collectBinders rhs + (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs + ; (body_usg, body', body_ws) <- scExpr body_env body + ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' + ; return (RI { ri_rhs_usg = rhs_usg + , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body' + , ri_lam_bndrs = arg_bndrs, ri_lam_body = body + , ri_arg_occs = arg_occs }, body_ws) } + -- The arg_occs says how the visible, + -- lambda-bound binders of the RHS are used + -- (including the TyVar binders) + -- Two pats are the same if they match both ways + +---------------------- +ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)] +ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs }) + (SI { si_specs = specs }) + = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] ++ + -- First the specialised bindings + + [(fn `addIdSpecialisations` rules, new_rhs)] + -- And now the original binding + where + rules = [r | OS { os_rule = r } <- specs] + +{- +************************************************************************ +* * + The specialiser itself +* * +************************************************************************ +-} + +data RhsInfo + = RI { ri_fn :: OutId -- The binder + , ri_new_rhs :: OutExpr -- The specialised RHS (in current envt) + , ri_rhs_usg :: ScUsage -- Usage info from specialising RHS + + , ri_lam_bndrs :: [InVar] -- The *original* RHS (\xs.body) + , ri_lam_body :: InExpr -- Note [Specialise original body] + , ri_arg_occs :: [ArgOcc] -- Info on how the xs occur in body + } + +data SpecInfo -- Info about specialisations for a particular Id + = SI { si_specs :: [OneSpec] -- The specialisations we have + -- generated for this function + + , si_n_specs :: Int -- Length of si_specs; used for numbering them + + , si_mb_unspec :: Maybe ScUsage -- Just cs => we have not yet used calls in the + } -- from calls in the *original* RHS as + -- seeds for new specialisations; + -- if you decide to do so, here is the + -- RHS usage (which has not yet been + -- unleashed) + -- Nothing => we have + -- See Note [Seeding recursive groups] + -- See Note [spec_usg includes rhs_usg] + + -- One specialisation: Rule plus definition +data OneSpec = + OS { os_pat :: CallPat -- Call pattern that generated this specialisation + , os_rule :: CoreRule -- Rule connecting original id with the specialisation + , os_id :: OutId -- Spec id + , os_rhs :: OutExpr } -- Spec rhs + +initSpecInfo :: RhsInfo -> SpecInfo +initSpecInfo (RI { ri_rhs_usg = rhs_usg }) + = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Just rhs_usg } + -- si_mb_unspec: add in rhs_usg if there are any boring calls, + -- or if the bndr is exported + +---------------------- +specNonRec :: ScEnv + -> CallEnv -- Calls in body + -> RhsInfo -- Structure info usage info for un-specialised RHS + -> UniqSM (ScUsage, SpecInfo, [SpecFailWarning]) -- Usage from RHSs (specialised and not) + -- plus details of specialisations + +specNonRec env body_calls rhs_info + = specialise env body_calls rhs_info (initSpecInfo rhs_info) + +---------------------- +specRec :: ScEnv + -> CallEnv -- Calls in body + -> [RhsInfo] -- Structure info and usage info for un-specialised RHSs + -> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings) + -- Usage from all RHSs (specialised and not) + -- plus details of specialisations + +specRec env body_calls rhs_infos + = go 1 body_calls nullUsage (map initSpecInfo rhs_infos) [] + -- body_calls: see Note [Seeding recursive groups] + -- NB: 'go' always calls 'specialise' once, which in turn unleashes + -- si_mb_unspec if there are any boring calls in body_calls, + -- or if any of the Id(s) are exported + where + opts = sc_opts env + + -- Loop, specialising, until you get no new specialisations + go, go_again :: Int -- Which iteration of the "until no new specialisations" + -- loop we are on; first iteration is 1 + -> CallEnv -- Seed calls + -- Two accumulating parameters: + -> ScUsage -- Usage from earlier specialisations + -> [SpecInfo] -- Details of specialisations so far + -> SpecFailWarnings -- Warnings so far + -> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings) + go n_iter seed_calls usg_so_far spec_infos ws_so_far + = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos) + -- , text "iteration" <+> int n_iter + -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos) + -- ]) $ + do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos + + ; let (extra_usg_s, all_spec_infos, extra_ws ) = unzip3 specs_w_usg + extra_usg = combineUsages extra_usg_s + all_usg = usg_so_far `combineUsage` extra_usg + new_calls = scu_calls extra_usg + ; go_again n_iter new_calls all_usg all_spec_infos (ws_so_far ++ concat extra_ws) } + + -- go_again deals with termination + go_again n_iter seed_calls usg_so_far spec_infos ws_so_far + | isEmptyVarEnv seed_calls + = return (usg_so_far, spec_infos, ws_so_far) + + -- Limit recursive specialisation + -- See Note [Limit recursive specialisation] + | n_iter > sc_recursive opts -- Too many iterations of the 'go' loop + , sc_force env || isNothing (sc_count opts) + -- If both of these are false, the sc_count + -- threshold will prevent non-termination + -- See Note [Forcing specialisation], point (FS4) and (FS2) + , any ((> the_limit) . si_n_specs) spec_infos + = -- Give up on specialisation, but don't forget to include the rhs_usg + -- for the unspecialised function, since it may now be called + -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $ + let rhs_usgs = combineUsages (mapMaybe si_mb_unspec spec_infos) + in return (usg_so_far `combineUsage` rhs_usgs, spec_infos, ws_so_far) + + | otherwise + = go (n_iter + 1) seed_calls usg_so_far spec_infos ws_so_far + + -- See Note [Limit recursive specialisation] + the_limit = case sc_count opts of + Nothing -> 10 -- Ugh! + Just max -> max + +---------------------- +specialise + :: ScEnv + -> CallEnv -- Info on newly-discovered calls to this function + -> RhsInfo + -> SpecInfo -- Original RHS plus patterns dealt with + -> UniqSM (ScUsage, SpecInfo, [SpecFailWarning]) -- New specialised versions and their usage + +-- See Note [spec_usg includes rhs_usg] + +-- Note: this only generates *specialised* bindings +-- The original binding is added by ruleInfoBinds +-- +-- Note: the rhs here is the optimised version of the original rhs +-- So when we make a specialised copy of the RHS, we're starting +-- from an RHS whose nested functions have been optimised already. + +specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs + , ri_lam_body = body, ri_arg_occs = arg_occs }) + spec_info@(SI { si_specs = specs, si_n_specs = spec_count + , si_mb_unspec = mb_unspec }) + | isDeadEndId fn -- Note [Do not specialise diverging functions] + -- /and/ do not generate specialisation seeds from its RHS + = -- pprTrace "specialise bot" (ppr fn) $ + return (nullUsage, spec_info, []) + + | not (isNeverActive (idInlineActivation fn)) + -- See Note [Transfer activation] + -- Don't specialise OPAQUE things, see Note [OPAQUE pragma]. + -- Since OPAQUE things are always never-active (see + -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for + -- OPAQUE things. + , not (null arg_bndrs) -- Only specialise functions + , Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it + = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $ + do { (boring_call, pats_discarded, new_pats, warnings) + <- callsToNewPats env fn spec_info arg_occs all_calls + + ; let n_pats = length new_pats +-- ; when (not (null new_pats) || isJust mb_unspec) $ +-- pprTraceM "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns" +-- , text "boring_call:" <+> ppr boring_call +-- , text "pats_discarded:" <+> ppr pats_discarded +-- , text "old spec_count" <+> ppr spec_count +-- , text "spec count limit" <+> ppr (sc_count (sc_opts env)) +-- , text "mb_unspec" <+> ppr (isJust mb_unspec) +-- , text "arg_occs" <+> ppr arg_occs +-- , text "new_pats" <+> ppr new_pats]) + + ; let spec_env = decreaseSpecCount env n_pats + ; (spec_usgs, new_specs, new_wss) <- mapAndUnzip3M (spec_one spec_env fn arg_bndrs body) + (new_pats `zip` [spec_count..]) + -- See Note [Specialise original body] + + ; let spec_usg = combineUsages spec_usgs + + unspec_rhs_needed = pats_discarded || boring_call || isExportedId fn + + -- If there were any boring calls among the seeds (= all_calls), then those + -- calls will call the un-specialised function. So we should use the seeds + -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning + -- then in new_usg. + (new_usg, mb_unspec') = case mb_unspec of + Just rhs_usg | unspec_rhs_needed + -> (spec_usg `combineUsage` rhs_usg, Nothing) + _ -> (spec_usg, mb_unspec) + +-- ; pprTraceM "specialise return }" $ +-- vcat [ ppr fn +-- , text "unspec_rhs_needed:" <+> ppr unspec_rhs_needed +-- , text "new calls:" <+> ppr (scu_calls new_usg)] + + ; return (new_usg, SI { si_specs = new_specs ++ specs + , si_n_specs = spec_count + n_pats + , si_mb_unspec = mb_unspec' } + ,warnings ++ concat new_wss) } + + | otherwise -- No calls, inactive, or not a function + -- Behave as if there was a single, boring call + = -- pprTrace "specialise inactive" (ppr fn $$ ppr mb_unspec) $ + case mb_unspec of -- Behave as if there was a single, boring call + Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }, []) + -- See Note [spec_usg includes rhs_usg] + Nothing -> return (nullUsage, spec_info, []) + + +--------------------- +spec_one :: ScEnv + -> OutId -- Function + -> [InVar] -- Lambda-binders of RHS; should match patterns + -> InExpr -- Body of the original function + -> (CallPat, Int) + -> UniqSM (ScUsage, OneSpec, SpecFailWarnings) -- Rule and binding, warnings if any + +-- spec_one creates a specialised copy of the function, together +-- with a rule for using it. I'm very proud of how short this +-- function is, considering what it does :-). + +{- + Example + + In-scope: a, x::a + f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))... + [c::*, v::(b,c) are presumably bound by the (...) part] + ==> + f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] -> + (...entire body of f...) [b -> (b,c), + y -> ((:) (a,(b,c)) (x,v) hw)] + + RULE: forall b::* c::*, -- Note, *not* forall a, x + v::(b,c), + hw::[(a,(b,c))] . + + f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw +-} + +spec_one env fn arg_bndrs body (call_pat, rule_number) + | CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat + = do { -- pprTraceM "spec_one {" (ppr fn <+> ppr pats) + + ; spec_uniq <- getUniqueM + ; let env1 = extendScSubstList (extendScInScope env qvars) + (arg_bndrs `zip` pats) + (body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs) + -- Remember, there may be fewer pats than arg_bndrs + -- See Note [SpecConstr call patterns] + -- extra_bndrs will then be arguments in the specialized version + -- which are *not* applied to arguments immediately at the call sites. + -- e.g. let f x y = ... in map (f True) xs + -- will result in y becoming an extra_bndr + + fn_name = idName fn + fn_loc = nameSrcSpan fn_name + fn_occ = nameOccName fn_name + spec_occ = mkSpecOcc fn_occ + -- We use fn_occ rather than fn in the rule_name string + -- as we don't want the uniq to end up in the rule, and + -- hence in the ABI, as that can cause spurious ABI + -- changes (#4012). + rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) + spec_name = mkInternalName spec_uniq spec_occ fn_loc + + -- Specialise the body + -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env) + ; (spec_usg, spec_body, body_warnings) <- scExpr body_env body + + -- And build the results + ; (qvars', pats') <- generaliseDictPats qvars pats + ; let spec_body_ty = exprType spec_body + (spec_lam_args, spec_call_args, spec_sig) + = calcSpecInfo fn arg_bndrs call_pat extra_bndrs + + spec_arity = count isId spec_lam_args + spec_join_arity | isJoinId fn = JoinPoint (length spec_call_args) + | otherwise = NotJoinPoint + spec_id = asWorkerLikeId $ + mkLocalId spec_name ManyTy + (mkLamTypes spec_lam_args spec_body_ty) + -- See Note [Transfer strictness] + `setIdDmdSig` spec_sig + `setIdCprSig` topCprSig + `setIdArity` spec_arity + `asJoinId_maybe` spec_join_arity + + -- Conditionally use result of new worker-wrapper transform + -- mkSeqs: see Note [SpecConstr and strict fields] + spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body) + rule_rhs = mkVarApps (Var spec_id) spec_call_args + inline_act = idInlineActivation fn + this_mod = sc_module $ sc_opts env + rule = mkRule this_mod True {- Auto -} True {- Local -} + rule_name inline_act + fn_name qvars' pats' rule_rhs + -- See Note [Transfer activation] + +-- ; pprTraceM "spec_one end }" $ +-- vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn)) +-- , text "pats:" <+> ppr pats +-- , text "call_pat:" <+> ppr call_pat +-- , text "-->" <+> ppr spec_name +-- , text "bndrs" <+> ppr arg_bndrs +-- , text "extra_bndrs" <+> ppr extra_bndrs +-- , text "cbv_args" <+> ppr cbv_args +-- , text "spec_lam_args" <+> ppr spec_lam_args +-- , text "spec_call_args" <+> ppr spec_call_args +-- , text "rule_rhs" <+> ppr rule_rhs +-- , text "adds_void_worker_arg" <+> ppr add_void_arg +---- , text "body" <+> ppr body +---- , text "spec_rhs" <+> ppr spec_rhs +---- , text "how_bound" <+> ppr (sc_how_bound env) ] +-- ] + ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule + , os_id = spec_id + , os_rhs = spec_rhs }, body_warnings) } + +generaliseDictPats :: [Var] -> [CoreExpr] -- Quantified vars and pats + -> UniqSM ([Var], [CoreExpr]) -- New quantified vars and pats +-- See Note [generaliseDictPats] +generaliseDictPats qvars pats + = do { (extra_qvars, pats') <- mapAccumLM go [] pats + ; case extra_qvars of + [] -> return (qvars, pats) + _ -> return (qvars ++ extra_qvars, pats') } + where + qvar_set = mkVarSet qvars + go :: [Id] -> CoreExpr -> UniqSM ([Id], CoreExpr) + go extra_qvs pat + | not (isTyCoArg pat) + , let pat_ty = exprType pat + , typeDeterminesValue pat_ty + , exprFreeVars pat `disjointVarSet` qvar_set + = do { id <- mkSysLocalOrCoVarM (fsLit "dict") ManyTy pat_ty + ; return (id:extra_qvs, Var id) } + | otherwise + = return (extra_qvs, pat) + +mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr +-- See Note [SpecConstr and strict fields] +mkSeqs seqees res_ty rhs = + foldr addEval rhs seqees + where + addEval :: Var -> CoreExpr -> CoreExpr + addEval arg_id rhs + -- Argument representing strict field and it's worth passing via cbv + | shouldStrictifyIdForCbv arg_id + = Case (Var arg_id) + (localiseId arg_id) -- See (SCF1) in Note [SpecConstr and strict fields] + res_ty + ([Alt DEFAULT [] rhs]) + + | otherwise + = rhs + + +{- Note [SpecConstr void argument insertion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a function + f :: Bool -> forall t. blah + f start @t = e +We want to specialize for a partially applied call `f True`. +See also Note [SpecConstr call patterns], second Wrinkle. +Naively we would expect to get + $sf :: forall t. blah + $sf @t = $se + RULE: f True = $sf +The specialized function only takes a single type argument so we add a +void argument to prevent it from turning into a thunk. See Note +[Protecting the last value argument] for details why. Normally we +would add the void argument after the type argument giving us: + + $sf :: forall t. Void# -> bla + $sf @t void = $se + RULE: f True = $sf void# (wrong) + +But if you look closely this wouldn't typecheck! If we substitute `f +True` with `$sf void#` we expect the type argument to be applied first +but we apply void# first. The easiest fix seems to be just to add the +void argument to the front of the arguments. Now we get: + + $sf :: Void# -> forall t. bla + $sf void @t = $se + RULE: f True = $sf void# + +And now we can substitute `f True` with `$sf void#` with everything working out nicely! + +More precisely, in `calcSpecInfo` +(i) we need the void arg to /precede/ the `extra_bndrs`, but +(ii) it must still /follow/ `qvar_bndrs`. + +Example to illustrate (ii): + f :: forall r (a :: TYPE r). Bool -> a + f = /\r. /\(a::TYPE r). \b. body + + {- Specialise for f _ _ True -} + + $sf :: forall r (a :: TYPE r). Void# -> a + $sf = /\r. /\(a::TYPE r). \v. body[True/b] + RULE: forall r (a :: TYPE r). f @r @a True = $sf @r @a void# + +The void argument must follow the foralls, lest the forall be +ill-kinded. See Note [Worker/wrapper needs to add void arg last] in +GHC.Core.Opt.WorkWrap.Utils. + +Note [generaliseDictPats] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two rules (#21831, item 2): + RULE "SPEC:foo" forall d1 d2. foo @Int @Integer d1 d2 = $sfoo1 + RULE "SC:foo" forall a. foo @Int @a $fNumInteger = $sfoo2 @a +The former comes from the type class specialiser, the latter from SpecConstr. +Note that $fNumInteger is a top-level binding for Num Integer. + +The trouble is that neither is more general than the other. In a call + (foo @Int @Integer $fNumInteger d) +it isn't clear which rule to fire. + +The trouble is that the SpecConstr rule fires on a /specific/ dict, $fNumInteger, +but actually /could/ fire regardless. That is, it could be + RULE "SC:foo" forall a d. foo @Int @a d = $sfoo2 @a + +Now, it is clear that SPEC:foo is more specific. But GHC can't tell +that, because SpecConstr doesn't know that dictionary arguments are +singleton types! So generaliseDictPats teaches it this fact. It +spots such patterns (using typeDeterminesValue), and quantifies over +the dictionary. Now we get + + RULE "SC:foo" forall a d. foo @Int @a d = $sfoo2 @a + +And /now/ "SPEC:foo" is clearly more specific: we can instantiate the new +"SC:foo" to match the (prefix of) "SPEC:foo". +-} + +calcSpecInfo :: Id -- The original function + -> [InVar] -- Lambda binders of original RHS + -> CallPat -- Call pattern + -> [Var] -- Extra bndrs + -> ( [Var] -- Demand-decorated lambda binders + -- for RHS of specialised function + , [Var] -- Args for call site + , DmdSig ) -- Strictness of specialised thing +-- Calculate bits of IdInfo for the specialised function +-- See Note [Transfer strictness] +-- See Note [Strictness information in worker binders] +calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs + = ( spec_lam_bndrs_w_dmds + , spec_call_args + , zapDmdEnvSig (DmdSig (dt{dt_args = spec_fn_dmds})) ) + where + DmdSig dt@DmdType{dt_args=fn_dmds} = idDmdSig fn + spec_fn_dmds = [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b] + + val_pats = filterOut isTypeArg pats + -- Value args at call sites, used to determine how many demands to drop + -- from the original functions demand and for setting up arg_dmd_env. + arg_dmd_env = go emptyVarEnv fn_dmds val_pats + qvar_dmds = [ lookupVarEnv arg_dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] + extra_dmds = dropList val_pats fn_dmds + + -- Annotate the variables with the strictness information from + -- the function (see Note [Strictness information in worker binders]) + qvars_w_dmds = set_dmds qvars qvar_dmds + extras_w_dmds = set_dmds extra_bndrs extra_dmds + spec_lam_bndrs_w_dmds = final_qvars_w_dmds ++ extras_w_dmds + + (final_qvars_w_dmds, spec_call_args) + | needsVoidWorkerArg fn arg_bndrs (qvars ++ extra_bndrs) + -- Usual w/w hack to avoid generating + -- a spec_rhs of unlifted or ill-kinded type and no args. + -- See Note [SpecConstr void argument insertion] + = ( qvars_w_dmds ++ [voidArgId], qvars ++ [voidPrimId] ) + | otherwise + = ( qvars_w_dmds, qvars ) + + set_dmds :: [Var] -> [Demand] -> [Var] + set_dmds [] _ = [] + set_dmds vs [] = vs -- Run out of demands + set_dmds (v:vs) ds@(d:ds') | isTyVar v = v : set_dmds vs ds + | otherwise = setIdDemandInfo v d : set_dmds vs ds' + + go :: VarEnv Demand -> [Demand] -> [CoreExpr] -> VarEnv Demand + -- We've filtered out all the type patterns already + go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats + go env _ _ = env + + go_one :: VarEnv Demand -> Demand -> CoreExpr -> VarEnv Demand + go_one env d (Var v) = extendVarEnv_C plusDmd env v d + go_one env (_n :* cd) e -- NB: _n does not have to be strict + | (Var _, args) <- collectArgs e + , Just (_b, ds) <- viewProd (length args) cd -- TODO: We may want to look at boxity _b, though... + = go env ds args + go_one env _ _ = env + +{- +Note [spec_usg includes rhs_usg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In calls to 'specialise', the returned ScUsage must include the rhs_usg in +the passed-in SpecInfo in si_mb_unspec, unless there are no calls at all to +the function. + +The caller can, indeed must, assume this. They should not combine in rhs_usg +themselves, or they'll get rhs_usg twice -- and that can lead to an exponential +blowup of duplicates in the CallEnv. This is what gave rise to the massive +performance loss in #8852. + +Note [Specialise original body] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RhsInfo for a binding keeps the *original* body of the binding. We +must specialise that, *not* the result of applying specExpr to the RHS +(which is also kept in RhsInfo). Otherwise we end up specialising a +specialised RHS, and that can lead directly to exponential behaviour. + +Note [Transfer activation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + This note is for SpecConstr, but exactly the same thing + happens in the overloading specialiser; see + Note [Auto-specialisation and RULES] in GHC.Core.Opt.Specialise. + +In which phase should the specialise-constructor rules be active? +Originally I made them always-active, but Manuel found that this +defeated some clever user-written rules. Then I made them active only +in FinalPhase; after all, currently, the specConstr transformation is +only run after the simplifier has reached FinalPhase, but that meant +that specialisations didn't fire inside wrappers; see test +simplCore/should_compile/spec-inline. + +So now I just use the inline-activation of the parent Id, as the +activation for the specialisation RULE, just like the main specialiser; + +This in turn means there is no point in specialising NOINLINE things, +so we test for that. + +Note [Transfer strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must transfer strictness information from the original function to +the specialised one. Suppose, for example + + f has strictness SSx + and a RULE f (a:as) b = f_spec a as b + +Now we want f_spec to have strictness LLSx, otherwise we'll use call-by-need +when calling f_spec instead of call-by-value. And that can result in +unbounded worsening in space (cf the classic foldl vs foldl') + +See #3437 for a good example. + +The function calcSpecStrictness performs the calculation. + +Note [Strictness information in worker binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After having calculated the strictness annotation for the worker (see Note +[Transfer strictness] above), we also want to have this information attached to +the worker’s arguments, for the benefit of later passes. The function +handOutStrictnessInformation decomposes the strictness annotation calculated by +calcSpecStrictness and attaches them to the variables. + + +************************************************************************ +* * +\subsection{Argument analysis} +* * +************************************************************************ + +This code deals with analysing call-site arguments to see whether +they are constructor applications. + +Note [Free type variables of the qvar types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a call (f @a x True), that we want to specialise, what variables should +we quantify over. Clearly over 'a' and 'x', but what about any type variables +free in x's type? In fact we don't need to worry about them because (f @a) +can only be a well-typed application if its type is compatible with x, so any +variables free in x's type must be free in (f @a), and hence either be gathered +via 'a' itself, or be in scope at f's defn. Hence we just take + (exprsFreeVars pats). + +BUT phantom type synonyms can mess this reasoning up, + eg x::T b with type T b = Int +So we apply expandTypeSynonyms to the bound Ids. +See # 5458. Yuk. + +Note [SpecConstr call patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "call patterns" that we collect is going to become the LHS of a RULE. + +Wrinkles: + +* The list of argument patterns, cp_args, is no longer than the + visible lambdas of the binding, ri_arg_occs. This is done via + the zipWithM in callToPat. + +* The list of argument patterns can certainly be shorter than the + lambdas in the function definition (under-saturated). For example + f x y = case x of { True -> e1; False -> e2 } + ....map (f True) e... + We want to specialise `f` for `f True`. + +* In fact we deliberately shrink the list of argument patterns, + cp_args, by trimming off all the boring ones at the end (see + `dropWhileEnd is_boring` in callToPat). Since the RULE only + applies when it is saturated, this shrinking makes the RULE more + applicable. But it does mean that the argument patterns do not + necessarily saturate the lambdas of the function. + +* It's important that the pattern arguments do not look like + e |> Refl + or + e |> g1 |> g2 + because both of these will be optimised by Simplify.simplRule. In the + former case such optimisation benign, because the rule will match more + terms; but in the latter we may lose a binding of 'g1' or 'g2', and + end up with a rule LHS that doesn't bind the template variables + (#10602). + + The simplifier eliminates such things, but SpecConstr itself constructs + new terms by substituting. So the 'mkCast' in the Cast case of scExpr + is very important! + +Note [Choosing patterns] +~~~~~~~~~~~~~~~~~~~~~~~~ +If we get lots of patterns we may not want to make a specialisation +for each of them (code bloat), so we choose as follows, implemented +by trim_pats. + +* The flag -fspec-constr-count-N sets the sc_count field + of the ScEnv to (Just n). This limits the total number + of specialisations for a given function to N. + +* -fno-spec-constr-count sets the sc_count field to Nothing, + which switches of the limit. + +* The ghastly ForceSpecConstr trick also switches of the limit + for a particular function + +* Otherwise we sort the patterns to choose the most general + ones first; more general => more widely applicable. + +Note [SpecConstr and casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14270) a call like + + let f = e + in ... f (K @(a |> cv)) ... + +where 'cv' is a coercion variable not in scope at f's definition site. +If we aren't careful we'll get + + let $sf a cv = e (K @(a |> cv)) + RULE "SC:f" forall a cv. f (K @(a |> cv)) = $sf a co + f = e + in ... + +But alas, when we match the call we may fail to bind 'co', because the rule +matcher in GHC.Core.Rules cannot reliably bind coercion variables that appear +in casts (see Note [Casts in the template] in GHC.Core.Rules). + +This seems intractable (see #23209). So: + +* Key point: we /never/ quantify over coercion variables in a SpecConstr rule. + If we would need to quantify over a coercion variable, we just discard the + call pattern. See the test for `bad_covars` in callToPat. + +* However (#14936) we /do/ still allow casts in call patterns. For example + f ((e1,e2) |> sym co) + where, say, + f :: Foo -> blah -- Foo is a newtype + f = f_rhs + co :: Foo ~R (Int,Int) + We want to specialise on that pair! + +So for our function f, we might generate + RULE forall x y. f ((x,y) |> co) = $sf x y + $sf x y = f_rhs ((x,y) |> co) + +This works provided the free vars of `co` are either in-scope at the +definition of `f`, or quantified. For the latter, suppose `f` was polymorphic: + + f2 :: Foo2 a -> blah -- Foo is a newtype + f2 = f2_rhs + co2 :: Foo a ~R (a,a) + +Then it's fine for `co2` to mention `a`. We'll get + RULE forall a (x::a) (y::a). f2 @a ((x,y) |> co2) = $sf2 a x y + $sf2 @a x y = f2_rhs ((x,y) |> co2) +-} + +data CallPat = CP { cp_qvars :: [Var] -- Quantified variables + , cp_args :: [CoreExpr] -- Arguments + , cp_strict_args :: [Var] } -- Arguments we want to pass unlifted even if they are boxed + -- See Note [SpecConstr and strict fields] + + -- See Note [SpecConstr call patterns] + +instance Outputable CallPat where + ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args = strict }) + = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma + , text "cp_args =" <+> ppr args + , text "cp_strict_args = " <> ppr strict ]) + +newtype SpecFailWarning = SpecFailForcedArgCount { spec_failed_fun_name :: Name } + +type SpecFailWarnings = [SpecFailWarning] + +instance Outputable SpecFailWarning where + ppr (SpecFailForcedArgCount name) = ppr name <+> pprDefinedAt name + +combineSpecWarning :: SpecFailWarnings -> SpecFailWarnings -> SpecFailWarnings +combineSpecWarning = (++) + +data ArgCountResult = WorkerSmallEnough | WorkerTooLarge | WorkerTooLargeForced Name + +callsToNewPats :: ScEnv -> Id + -> SpecInfo + -> [ArgOcc] -> [Call] + -> UniqSM ( Bool -- At least one boring call + , Bool -- Patterns were discarded + , [CallPat] -- Patterns to specialise + , [SpecFailWarning] -- Things that didn't specialise we want to warn the user about) + ) +-- Result has no duplicate patterns, +-- nor ones mentioned in si_specs (hence "new" patterns) +-- Bool indicates that there was at least one boring pattern +-- The "New" in the name means "patterns that are not already covered +-- by an existing specialisation" +callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls + = do { mb_pats <- mapM (callToPat env bndr_occs) calls + + ; let have_boring_call = any isNothing mb_pats + + good_pats :: [CallPat] + good_pats = catMaybes mb_pats + + in_scope = substInScopeSet (sc_subst env) + + -- Remove patterns we have already done + new_pats = filterOut is_done good_pats + is_done p = any is_better done_specs + where + is_better done = betterPat in_scope (os_pat done) p + + -- Remove duplicates + non_dups = subsumePats in_scope new_pats + + -- Remove ones that have too many worker variables + (small_pats, arg_count_warnings) = partitionByWorkerSize too_many_worker_args non_dups + + -- too_many_worker_args :: CallPat -> Either SpecFailWarning Bool + too_many_worker_args (CP { cp_qvars = vars, cp_args = args }) + | sc_force env + -- See (FS5) of Note [Forcing specialisation] + = if (isWorkerSmallEnough (sc_max_forced_args $ sc_opts env) (valArgCount args) vars) + then WorkerSmallEnough + else WorkerTooLargeForced (idName fn) + | (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars) + = WorkerSmallEnough + | otherwise = WorkerTooLarge + -- We are about to construct w/w pair in 'spec_one'. + -- Omit specialisation leading to high arity workers. + -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils + + -- Discard specialisations if there are too many of them + (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats + +-- ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls +-- , text "good_pats:" <+> ppr good_pats +-- , text "new_pats:" <+> ppr new_pats +-- , text "non_dups:" <+> ppr non_dups +-- , text "small_pats:" <+> ppr small_pats +-- , text "done_specs:" <+> ppr (map os_pat done_specs) +-- , text "trimmed_pats:" <+> ppr trimmed_pats ]) + + ; return (have_boring_call, pats_were_discarded, trimmed_pats, arg_count_warnings) } + -- If any of the calls does not give rise to a specialisation, either + -- because it is boring, or because there are too many specialisations, + -- return a flag to say so, so that we know to keep the original function. + where + partitionByWorkerSize worker_size pats = go pats [] [] + where + go [] small warnings = (small, warnings) + go (p:ps) small warnings = + case worker_size p of + WorkerSmallEnough -> go ps (p:small) warnings + WorkerTooLarge -> go ps small warnings + WorkerTooLargeForced name -> go ps small (SpecFailForcedArgCount name : warnings) + + +trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat]) +-- True <=> some patterns were discarded +-- See Note [Choosing patterns] +trim_pats env fn (SI { si_n_specs = done_spec_count }) pats + | False <- sc_force env + , Just max_specs <- mb_scc + , let n_remaining = max_specs - done_spec_count + , n_remaining < n_pats + = emit_trace max_specs n_remaining $ -- Need to trim, so keep the best ones + (True, take n_remaining sorted_pats) + + | otherwise + = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats) + (False, pats) -- No need to trim + + where + n_pats = length pats + spec_count' = n_pats + done_spec_count + mb_scc = sc_count $ sc_opts env + + sorted_pats = map fst $ + sortBy (comparing snd) $ + [(pat, pat_cons pat) | pat <- pats] + -- Sort in order of increasing number of constructors + -- (i.e. decreasing generality) and pick the initial + -- segment of this list + + pat_cons :: CallPat -> Int + -- How many data constructors of literals are in + -- the pattern. More data-cons => less general + pat_cons (CP { cp_qvars = qs, cp_args = ps }) + = foldr ((+) . n_cons) 0 ps + where + q_set = mkVarSet qs + n_cons (Var v) | v `elemVarSet` q_set = 0 + | otherwise = 1 + n_cons (Cast e _) = n_cons e + n_cons (App e1 e2) = n_cons e1 + n_cons e2 + n_cons (Lit {}) = 1 + n_cons _ = 0 + + emit_trace max_specs n_remaining result + | debugIsOn || sc_debug (sc_opts env) + -- Suppress this scary message for ordinary users! #5125 + = pprTrace "SpecConstr" msg result + | otherwise + = result + where + msg = vcat + [ sep + [ text "Function" <+> quotes (ppr fn) + , nest 2 + ( text "has" <+> + speakNOf spec_count' (text "call pattern") <> comma <+> + text "but the limit is" <+> int max_specs ) ] + , text "Use -fspec-constr-count=n to set the bound" + , text "done_spec_count =" <+> int done_spec_count + , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats + , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ] + +callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) + -- The [Var] is the variables to quantify over in the rule + -- Type variables come first, since they may scope + -- over the following term variables + -- The [CoreExpr] are the argument patterns for the rule +callToPat env bndr_occs call@(Call fn args con_env) + = do { let in_scope = substInScopeSet (sc_subst env) + + ; arg_triples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args) + -- This zip trims the args to be no longer than + -- the lambdas in the function definition (bndr_occs) + + -- Drop boring patterns from the end + -- See Note [SpecConstr call patterns] + ; let arg_triples' | isJoinId fn = arg_triples + | otherwise = dropWhileEnd is_boring arg_triples + is_boring (interesting, _,_) = not interesting + (interesting_s, pats, cbv_ids) = unzip3 arg_triples' + interesting = or interesting_s + + ; let pat_fvs = exprsFreeVarsList pats + -- To get determinism we need the list of free variables in + -- deterministic order. Otherwise we end up creating + -- lambdas with different argument orders. See + -- determinism/simplCore/should_compile/spec-inline-determ.hs + -- for an example. For explanation of determinism + -- considerations See Note [Unique Determinism] in GHC.Types.Unique. + + in_scope_vars = getInScopeVars in_scope + is_in_scope v = v `elemVarSet` in_scope_vars + qvars = filterOut is_in_scope pat_fvs + -- Quantify over variables that are not in scope + -- at the call site + -- See Note [Free type variables of the qvar types] + -- See Note [Shadowing in SpecConstr] at the top + + (qktvs, qids) = partition isTyVar qvars + qvars' = scopedSort qktvs ++ map sanitise qids + -- Order into kind variables, type variables, term variables + -- The kind of a type variable may mention a kind variable + -- and the type of a term variable may mention a type variable + + sanitise id = updateIdTypeAndMult expandTypeSynonyms id + -- See Note [Free type variables of the qvar types] + + -- Check for bad coercion variables: see Note [SpecConstr and casts] + ; let bad_covars = filter isCoVar qids + ; warnPprTrace (not (null bad_covars)) + "SpecConstr: bad covars" + (ppr bad_covars $$ ppr call) $ + + if interesting && null bad_covars + then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats + , cp_strict_args = concat cbv_ids } +-- ; pprTraceM "callToPatOut" $ +-- vcat [ text "fn:" <+> ppr fn +-- , text "args:" <+> ppr args +-- , text "bndr_occs:" <+> ppr bndr_occs +-- , text "pat_fvs:" <+> ppr pat_fvs +-- , text "cp_res:" <+> ppr cp_res ] + ; return (Just cp_res) } + else return Nothing } + + -- argToPat takes an actual argument, and returns an abstracted + -- version, consisting of just the "constructor skeleton" of the + -- argument, with non-constructor sub-expression replaced by new + -- placeholder variables. For example: + -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) + +argToPat :: ScEnv + -> InScopeSet -- What's in scope at the fn defn site + -> ValueEnv -- ValueEnv at the call site + -> CoreArg -- A call arg (or component thereof) + -> ArgOcc + -> StrictnessMark -- Tells us if this argument is a strict field of a data constructor + -- See Note [SpecConstr and strict fields] + -> UniqSM (Bool, CoreArg, [Id]) + +-- Returns (interesting, pat), +-- where pat is the pattern derived from the argument +-- interesting=True if the pattern is non-trivial (not a variable or type) +-- E.g. x:xs --> (True, x:xs) +-- f xs --> (False, w) where w is a fresh wildcard +-- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard +-- \x. x+y --> (True, \x. x+y) +-- lvl7 --> (True, lvl7) if lvl7 is bound +-- somewhere further out + +argToPat env in_scope val_env arg arg_occ arg_str + = do + -- pprTraceM "argToPatIn" (ppr arg) + !res <- argToPat1 env in_scope val_env arg arg_occ arg_str + -- pprTraceM "argToPatOut" (ppr res) + return res + +argToPat1 :: ScEnv + -> InScopeSet + -> ValueEnv + -> Expr CoreBndr + -> ArgOcc + -> StrictnessMark + -> UniqSM (Bool, Expr CoreBndr, [Id]) +argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str + = return (False, arg, []) + +argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str + = argToPat env in_scope val_env arg arg_occ arg_str + -- Note [Tick annotations in call patterns] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Ignore Notes. In particular, we want to ignore any InlineMe notes + -- Perhaps we should not ignore profiling notes, but I'm going to + -- ride roughshod over them all for now. + --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules + +argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str + = argToPat env in_scope val_env arg arg_occ arg_str + -- See Note [Matching lets] in "GHC.Core.Rules" + -- Look through let expressions + -- e.g. f (let v = rhs in (v,w)) + -- Here we can specialise for f (v,w) + -- because the rule-matcher will look through the let. + + -- Casts: see Note [SpecConstr and casts] +argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str + | not (ignoreType env ty2) + = do { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str + ; if not interesting then + wildCardPat ty2 arg_str + else + return (interesting, Cast arg' co, strict_args) } + where + ty2 = coercionRKind co + + -- Check for a constructor application + -- NB: this *precedes* the Var case, so that we catch nullary constrs +argToPat1 env in_scope val_env arg arg_occ _arg_str + | Just (ConVal _wf (DataAlt dc) args) <- isValue val_env arg + -- Ignore `_wf` here; see Note [ConVal work-free-ness] (2) + , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] + , Just arg_occs <- mb_scrut dc + = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args + con_str, matched_str :: [StrictnessMark] + -- con_str corresponds 1-1 with the /value/ arguments + -- matched_str corresponds 1-1 with /all/ arguments + con_str = dataConRepStrictness dc + matched_str = match_vals con_str rest_args + -- ; pprTraceM "bangs" (ppr (length rest_args == length con_str) $$ + -- ppr dc $$ + -- ppr con_str $$ + -- ppr rest_args $$ + -- ppr (map isTypeArg rest_args)) + ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str + ; let args' = map sndOf3 prs :: [CoreArg] + ; assertPpr (length con_str == length (filter isRuntimeArg rest_args)) + ( ppr con_str $$ ppr rest_args $$ + ppr (length con_str) $$ ppr (length rest_args) + ) $ return () + ; return (True, mkConApp dc (ty_args ++ args'), concat (map thdOf3 prs)) } + where + mb_scrut dc = case arg_occ of + ScrutOcc bs | Just occs <- lookupUFM bs dc + -> Just (occs) -- See Note [Reboxing] + _other | sc_force env || sc_keen (sc_opts env) + -> Just (repeat UnkOcc) + | otherwise + -> Nothing + match_vals bangs (arg:args) + | isTypeArg arg + = NotMarkedStrict : match_vals bangs args + | (b:bs) <- bangs + = b : match_vals bs args + match_vals [] [] = [] + match_vals as bs = + pprPanic "spec-constr:argToPat - Bangs don't match value arguments" + (text "arg:" <> ppr arg $$ + text "remaining args:" <> ppr as $$ + text "remaining bangs:" <> ppr bs) + + -- Check if the argument is a variable that + -- (a) is used in an interesting way in the function body + --- i.e. ScrutOcc. UnkOcc and NoOcc are not interesting + -- (NoOcc means we could drop the argument, but that's the + -- business of absence analysis, not SpecConstr.) + -- (b) we know what its value is + -- In that case it counts as "interesting" +argToPat1 env in_scope val_env (Var v) arg_occ arg_str + | sc_force env || specialisableArgOcc arg_occ -- (a) + -- See Note [Forcing specialisation], point (FS3) + , is_value -- (b) + -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing] + -- So sc_keen focused just on f (I# x), where we have freshly-allocated + -- box that we can eliminate in the caller + , not (ignoreType env (varType v)) + -- See Note [SpecConstr and strict fields] + = return (True, Var v, if isMarkedStrict arg_str then [v] else mempty) + where + is_value + | isLocalId v = v `elemInScopeSet` in_scope + && isJust (lookupVarEnv val_env v) + -- Local variables have values in val_env + | otherwise = isValueUnfolding (idUnfolding v) + -- Imports have unfoldings + +-- I'm really not sure what this comment means +-- And by not wild-carding we tend to get forall'd +-- variables that are in scope, which in turn can +-- expose the weakness in let-matching +-- See Note [Matching lets] in GHC.Core.Rules + + -- Check for a variable bound inside the function. + -- Don't make a wild-card, because we may usefully share + -- e.g. f a = let x = ... in f (x,x) + -- NB: this case follows the lambda and con-app cases!! +-- argToPat _in_scope _val_env (Var v) _arg_occ +-- = return (False, Var v) + -- SLPJ : disabling this to avoid proliferation of versions + -- also works badly when thinking about seeding the loop + -- from the body of the let + -- f x y = letrec g z = ... in g (x,y) + -- We don't want to specialise for that *particular* x,y + + +{- Disabled; see Note [Matching cases] in "GHC.Core.Rules" +argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ + | exprOkForSpeculation scrut -- See Note [Matching cases] in "GHC.Core.Rules" + = argToPat env in_scope val_env rhs arg_occ +-} + +{- Disabling lambda specialisation for now + It's fragile, and the spec_loop can be infinite +argToPat in_scope val_env arg arg_occ + | is_value_lam arg + = return (True, arg) + where + is_value_lam (Lam v e) -- Spot a value lambda, even if + | isId v = True -- it is inside a type lambda + | otherwise = is_value_lam e + is_value_lam other = False +-} + + -- The default case: make a wild-card + -- We use this for coercions too +argToPat1 _env _in_scope _val_env arg _arg_occ arg_str + = wildCardPat (exprType arg) arg_str + +-- | wildCardPats are always boring +wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id]) +wildCardPat ty str + = do { id <- mkSysLocalOrCoVarM (fsLit "sc") ManyTy ty + -- ; pprTraceM "wildCardPat" (ppr id' <+> ppr (idUnfolding id')) + ; return (False, varToCoreExpr id, if isMarkedStrict str then [id] else []) } + +isValue :: ValueEnv -> CoreExpr -> Maybe Value +isValue _env (Lit lit) + | litIsLifted lit = Nothing + | otherwise = Just (ConVal True (LitAlt lit) []) + +isValue env (Var v) + | Just cval <- lookupVarEnv env v + = Just cval -- You might think we could look in the idUnfolding here + -- but that doesn't take account of which branch of a + -- case we are in, which is the whole point + + | not (isLocalId v) + , isCheapUnfolding unf + , Just rhs <- maybeUnfoldingTemplate unf -- Succeds if isCheapUnfolding does + = isValue env rhs -- Can't use isEvaldUnfolding because + -- we want to consult the `env` + where + unf = idUnfolding v + -- However we do want to consult the unfolding + -- as well, for let-bound constructors! + +isValue env (Lam b e) + | isTyVar b = case isValue env e of + Just _ -> Just LambdaVal + Nothing -> Nothing + | otherwise = Just LambdaVal + +isValue env (Tick t e) + | not (tickishIsCode t) + = isValue env e + +isValue _env expr -- Maybe it's a constructor application + | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr + = case idDetails fun of + DataConWorkId con | args `lengthAtLeast` dataConRepArity con + -- Check saturated; might be > because the + -- arity excludes type args + -> Just (ConVal (all exprIsWorkFree args) (DataAlt con) args) + + DFunId {} -> Just LambdaVal + -- DFunId: see Note [Specialising on dictionaries] + + _other | valArgCount args < idArity fun + -- Under-applied function + -> Just LambdaVal -- Partial application + + _other -> Nothing + +isValue _env _expr = Nothing + +betterPat :: InScopeSet -> CallPat -> CallPat -> Bool +-- pat1 f @a (Just @a (x::a)) +-- is better than +-- pat2 f @Int (Just @Int (x::Int)) +-- That is, we can instantiate pat1 to get pat2, using only type instantiate +-- See Note [Pattern duplicate elimination] +betterPat is (CP { cp_qvars = vs1, cp_args = as1 }) + (CP { cp_qvars = vs2, cp_args = as2 }) + | equalLength as1 as2 + = case matchExprs ise vs1 as1 as2 of + Just (_, ms) -> all exprIsTrivial ms + Nothing -> False + + | otherwise -- We must handle patterns of unequal length separately (#24282) + = False -- For the pattern with more args, the last arg is "interesting" + -- but the corresponding one on the other is "not interesting"; + -- So we can't get from one to the other with only exprIsTrivial + -- instantiation. Example nofib/spectral/ansi, function `loop`: + -- P1: loop (I# x) (a : b) + -- P2: loop (I# y) -- Pattern eta-reduced + -- Neither is better than the other, in the sense of betterPat + where + ise = ISE (is `extendInScopeSetList` vs2) (const noUnfolding) + +subsumePats :: InScopeSet -> [CallPat] -> [CallPat] +-- Remove any patterns subsumed by others +-- See Note [Pattern duplicate elimination] +-- Other than deleting subsumed patterns, this operation is a no-op; +-- in particular it does not reverse the input. It should not matter +-- but in #24282 it did; doing it this way keeps the existing behaviour. +subsumePats is pats = foldl add [] pats + where + add :: [CallPat] -> CallPat -> [CallPat] + add [] ci = [ci] + add (ci1:cis) ci2 | betterPat is ci1 ci2 = ci1 : cis + | betterPat is ci2 ci1 = ci2 : cis + | otherwise = ci1 : add cis ci2 + +{- +Note [Pattern duplicate elimination] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider f :: (a,a) -> blah, and two calls + f @Int (x,y) + f @Bool (p,q) + +The danger is that we'll generate two *essentially identical* specialisations, +both for pairs, but with different types instantiating `a` (see #24229). + +But we'll only make a `CallPat` for an argument (a,b) if `foo` scrutinises +that argument. So SpecConstr should never need to specialise f's polymorphic +type arguments. Even with only one of these calls we should be able to +generalise to the `CallPat` + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + +Doing so isn't trivial, though. + +For now we content ourselves with a simpler plan: eliminate a call pattern +if another pattern subsumes it; this is done by `subsumePats`. +For example here are two patterns + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + cp_qvars = [x::Int, y::Int], cp_args = [@Int (x,y)] + +The first can be instantiated to the second, /by instantiating types only/. +This subsumption relationship is checked by `betterPat`. Note that if +we have + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + cp_qvars = [], cp_args = [@Bool (True,False)] + +the first does *not* subsume the second; the second is more specific. + +In our initial example with `f @Int` and `f @Bool` neither subsumes the other, +so we will get two essentially-identical specialisations. Boo. We rely on our +crude throttling mechanisms to stop this getting out of control -- with +polymorphic recursion we can generate an infinite number of specialisations. +Example is Data.Sequence.adjustTree, I think. +-} diff --git a/GHC/Core/Opt/Specialise.hs b/GHC/Core/Opt/Specialise.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Specialise.hs @@ -0,0 +1,3736 @@ +{-# LANGUAGE MultiWayIf #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[Specialise]{Stamping out overloading, and (optionally) polymorphism} +-} + +module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Driver.Config +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Core.Rules ( initRuleOpts ) + +import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) +import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe ) +import GHC.Core.Predicate +import GHC.Core.Class( classMethods ) +import GHC.Core.Coercion( Coercion ) +import GHC.Core.Opt.Monad +import qualified GHC.Core.Subst as Core +import GHC.Core.Unfold.Make +import GHC.Core +import GHC.Core.Make ( mkLitRubbish ) +import GHC.Core.Unify ( tcMatchTy ) +import GHC.Core.Rules +import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable + , mkCast, exprType, exprIsHNF + , stripTicksTop, mkInScopeSetBndrs ) +import GHC.Core.FVs +import GHC.Core.Opt.Arity( collectBindersPushingCo ) + +import GHC.Builtin.Types ( unboxedUnitTy ) + +import GHC.Data.Maybe ( isJust ) +import GHC.Data.Bag +import GHC.Data.OrdList +import GHC.Data.List.SetOps + +import GHC.Types.Basic +import GHC.Types.Unique.Supply +import GHC.Types.Unique.DFM +import GHC.Types.Name +import GHC.Types.Tickish +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Error + +import GHC.Utils.Error ( mkMCDiagnostic ) +import GHC.Utils.Monad ( foldlM ) +import GHC.Utils.Misc +import GHC.Utils.FV +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Unit.Module( Module ) +import GHC.Unit.Module.ModGuts +import GHC.Core.Unfold + +import Data.List( partition ) +import Data.List.NonEmpty ( NonEmpty (..) ) +import GHC.Core.Subst (substTickish) +import GHC.Core.TyCon (tyConClass_maybe) +import GHC.Core.DataCon (dataConTyCon) + +{- +************************************************************************ +* * +\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} +* * +************************************************************************ + +These notes describe how we implement specialisation to eliminate +overloading. + +The specialisation pass works on Core +syntax, complete with all the explicit dictionary application, +abstraction and construction as added by the type checker. The +existing type checker remains largely as it is. + +One important thought: the {\em types} passed to an overloaded +function, and the {\em dictionaries} passed are mutually redundant. +If the same function is applied to the same type(s) then it is sure to +be applied to the same dictionary(s)---or rather to the same {\em +values}. (The arguments might look different but they will evaluate +to the same value.) + +Second important thought: we know that we can make progress by +treating dictionary arguments as static and worth specialising on. So +we can do without binding-time analysis, and instead specialise on +dictionary arguments and no others. + +The basic idea +~~~~~~~~~~~~~~ +Suppose we have + + let f = + in + +and suppose f is overloaded. + +STEP 1: CALL-INSTANCE COLLECTION + +We traverse , accumulating all applications of f to types and +dictionaries. + +(Might there be partial applications, to just some of its types and +dictionaries? In principle yes, but in practice the type checker only +builds applications of f to all its types and dictionaries, so partial +applications could only arise as a result of transformation, and even +then I think it's unlikely. In any case, we simply don't accumulate such +partial applications.) + + +STEP 2: EQUIVALENCES + +So now we have a collection of calls to f: + f t1 t2 d1 d2 + f t3 t4 d3 d4 + ... +Notice that f may take several type arguments. To avoid ambiguity, we +say that f is called at type t1/t2 and t3/t4. + +We take equivalence classes using equality of the *types* (ignoring +the dictionary args, which as mentioned previously are redundant). + +STEP 3: SPECIALISATION + +For each equivalence class, choose a representative (f t1 t2 d1 d2), +and create a local instance of f, defined thus: + + f@t1/t2 = t1 t2 d1 d2 + +f_rhs presumably has some big lambdas and dictionary lambdas, so lots +of simplification will now result. However we don't actually *do* that +simplification. Rather, we leave it for the simplifier to do. If we +*did* do it, though, we'd get more call instances from the specialised +RHS. We can work out what they are by instantiating the call-instance +set from f's RHS with the types t1, t2. + +Add this new id to f's IdInfo, to record that f has a specialised version. + +Before doing any of this, check that f's IdInfo doesn't already +tell us about an existing instance of f at the required type/s. +(This might happen if specialisation was applied more than once, or +it might arise from user SPECIALIZE pragmas.) + +Recursion +~~~~~~~~~ +Wait a minute! What if f is recursive? Then we can't just plug in +its right-hand side, can we? + +But it's ok. The type checker *always* creates non-recursive definitions +for overloaded recursive functions. For example: + + f x = f (x+x) -- Yes I know its silly + +becomes + + f a (d::Num a) = let p = +.sel a d + in + letrec fl (y::a) = fl (p y y) + in + fl + +We still have recursion for non-overloaded functions which we +specialise, but the recursive call should get specialised to the +same recursive version. + + +Polymorphism 1 +~~~~~~~~~~~~~~ + +All this is crystal clear when the function is applied to *constant +types*; that is, types which have no type variables inside. But what if +it is applied to non-constant types? Suppose we find a call of f at type +t1/t2. There are two possibilities: + +(a) The free type variables of t1, t2 are in scope at the definition point +of f. In this case there's no problem, we proceed just as before. A common +example is as follows. Here's the Haskell: + + g y = let f x = x+x + in f y + f y + +After typechecking we have + + g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x + in +.sel a d (f a d y) (f a d y) + +Notice that the call to f is at type type "a"; a non-constant type. +Both calls to f are at the same type, so we can specialise to give: + + g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x + in +.sel a d (f@a y) (f@a y) + + +(b) The other case is when the type variables in the instance types +are *not* in scope at the definition point of f. The example we are +working with above is a good case. There are two instances of (+.sel a d), +but "a" is not in scope at the definition of +.sel. Can we do anything? +Yes, we can "common them up", a sort of limited common sub-expression deal. +This would give: + + g a (d::Num a) (y::a) = let +.sel@a = +.sel a d + f@a (x::a) = +.sel@a x x + in +.sel@a (f@a y) (f@a y) + +This can save work, and can't be spotted by the type checker, because +the two instances of +.sel weren't originally at the same type. + +Further notes on (b) + +* There are quite a few variations here. For example, the defn of + +.sel could be floated outside the \y, to attempt to gain laziness. + It certainly mustn't be floated outside the \d because the d has to + be in scope too. + +* We don't want to inline f_rhs in this case, because +that will duplicate code. Just commoning up the call is the point. + +* Nothing gets added to +.sel's IdInfo. + +* Don't bother unless the equivalence class has more than one item! + +Not clear whether this is all worth it. It is of course OK to +simply discard call-instances when passing a big lambda. + +Polymorphism 2 -- Overloading +~~~~~~~~~~~~~~ +Consider a function whose most general type is + + f :: forall a b. Ord a => [a] -> b -> b + +There is really no point in making a version of g at Int/Int and another +at Int/Bool, because it's only instantiating the type variable "a" which +buys us any efficiency. Since g is completely polymorphic in b there +ain't much point in making separate versions of g for the different +b types. + +That suggests that we should identify which of g's type variables +are constrained (like "a") and which are unconstrained (like "b"). +Then when taking equivalence classes in STEP 2, we ignore the type args +corresponding to unconstrained type variable. In STEP 3 we make +polymorphic versions. Thus: + + f@t1/ = /\b -> t1 b d1 d2 + +We do this. + + +Dictionary floating +~~~~~~~~~~~~~~~~~~~ +Consider this + + f a (d::Num a) = let g = ... + in + ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... + +Here, g is only called at one type, but the dictionary isn't in scope at the +definition point for g. Usually the type checker would build a +definition for d1 which enclosed g, but the transformation system +might have moved d1's defn inward. Solution: float dictionary bindings +outwards along with call instances. + +Consider + + f x = let g p q = p==q + h r s = (r+s, g r s) + in + h x x + + +Before specialisation, leaving out type abstractions we have + + f df x = let g :: Eq a => a -> a -> Bool + g dg p q = == dg p q + h :: Num a => a -> a -> (a, Bool) + h dh r s = let deq = eqFromNum dh + in (+ dh r s, g deq r s) + in + h df x x + +After specialising h we get a specialised version of h, like this: + + h' r s = let deq = eqFromNum df + in (+ df r s, g deq r s) + +But we can't naively make an instance for g from this, because deq is not in scope +at the defn of g. Instead, we have to float out the (new) defn of deq +to widen its scope. Notice that this floating can't be done in advance -- it only +shows up when specialisation is done. + +User SPECIALIZE pragmas +~~~~~~~~~~~~~~~~~~~~~~~ +Specialisation pragmas can be digested by the type checker, and implemented +by adding extra definitions along with that of f, in the same way as before + + f@t1/t2 = t1 t2 d1 d2 + +Indeed the pragmas *have* to be dealt with by the type checker, because +only it knows how to build the dictionaries d1 and d2! For example + + g :: Ord a => [a] -> [a] + {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} + +Here, the specialised version of g is an application of g's rhs to the +Ord dictionary for (Tree Int), which only the type checker can conjure +up. There might not even *be* one, if (Tree Int) is not an instance of +Ord! (All the other specialisation has suitable dictionaries to hand +from actual calls.) + +Problem. The type checker doesn't have to hand a convenient , because +it is buried in a complex (as-yet-un-desugared) binding group. +Maybe we should say + + f@t1/t2 = f* t1 t2 d1 d2 + +where f* is the Id f with an IdInfo which says "inline me regardless!". +Indeed all the specialisation could be done in this way. +That in turn means that the simplifier has to be prepared to inline absolutely +any in-scope let-bound thing. + + +Again, the pragma should permit polymorphism in unconstrained variables: + + h :: Ord a => [a] -> b -> b + {-# SPECIALIZE h :: [Int] -> b -> b #-} + +We *insist* that all overloaded type variables are specialised to ground types, +(and hence there can be no context inside a SPECIALIZE pragma). +We *permit* unconstrained type variables to be specialised to + - a ground type + - or left as a polymorphic type variable +but nothing in between. So + + {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} + +is *illegal*. (It can be handled, but it adds complication, and gains the +programmer nothing.) + + +SPECIALISING INSTANCE DECLARATIONS +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance Foo a => Foo [a] where + ... + {-# SPECIALIZE instance Foo [Int] #-} + +The original instance decl creates a dictionary-function +definition: + + dfun.Foo.List :: forall a. Foo a -> Foo [a] + +The SPECIALIZE pragma just makes a specialised copy, just as for +ordinary function definitions: + + dfun.Foo.List@Int :: Foo [Int] + dfun.Foo.List@Int = dfun.Foo.List Int dFooInt + +The information about what instance of the dfun exist gets added to +the dfun's IdInfo in the same way as a user-defined function too. + + +Automatic instance decl specialisation? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can instance decls be specialised automatically? It's tricky. +We could collect call-instance information for each dfun, but +then when we specialised their bodies we'd get new call-instances +for ordinary functions; and when we specialised their bodies, we might get +new call-instances of the dfuns, and so on. This all arises because of +the unrestricted mutual recursion between instance decls and value decls. + +Still, there's no actual problem; it just means that we may not do all +the specialisation we could theoretically do. + +Furthermore, instance decls are usually exported and used non-locally, +so we'll want to compile enough to get those specialisations done. + +Lastly, there's no such thing as a local instance decl, so we can +survive solely by spitting out *usage* information, and then reading that +back in as a pragma when next compiling the file. So for now, +we only specialise instance decls in response to pragmas. + + +SPITTING OUT USAGE INFORMATION +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To spit out usage information we need to traverse the code collecting +call-instance information for all imported (non-prelude?) functions +and data types. Then we equivalence-class it and spit it out. + +This is done at the top-level when all the call instances which escape +must be for imported functions and data types. + +*** Not currently done *** + + +Partial specialisation by pragmas +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What about partial specialisation: + + k :: (Ord a, Eq b) => [a] -> b -> b -> [a] + {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} + +or even + + {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} + +Seems quite reasonable. Similar things could be done with instance decls: + + instance (Foo a, Foo b) => Foo (a,b) where + ... + {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} + {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} + +Ho hum. Things are complex enough without this. I pass. + + +Requirements for the simplifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simplifier has to be able to take advantage of the specialisation. + +* When the simplifier finds an application of a polymorphic f, it looks in +f's IdInfo in case there is a suitable instance to call instead. This converts + + f t1 t2 d1 d2 ===> f_t1_t2 + +Note that the dictionaries get eaten up too! + +* Dictionary selection operations on constant dictionaries must be + short-circuited: + + +.sel Int d ===> +Int + +The obvious way to do this is in the same way as other specialised +calls: +.sel has inside it some IdInfo which tells that if it's applied +to the type Int then it should eat a dictionary and transform to +Int. + +In short, dictionary selectors need IdInfo inside them for constant +methods. + +* Exactly the same applies if a superclass dictionary is being + extracted: + + Eq.sel Int d ===> dEqInt + +* Something similar applies to dictionary construction too. Suppose +dfun.Eq.List is the function taking a dictionary for (Eq a) to +one for (Eq [a]). Then we want + + dfun.Eq.List Int d ===> dEq.List_Int + +Where does the Eq [Int] dictionary come from? It is built in +response to a SPECIALIZE pragma on the Eq [a] instance decl. + +In short, dfun Ids need IdInfo with a specialisation for each +constant instance of their instance declaration. + +All this uses a single mechanism: the SpecEnv inside an Id + + +What does the specialisation IdInfo look like? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The SpecEnv of an Id maps a list of types (the template) to an expression + + [Type] |-> Expr + +For example, if f has this RuleInfo: + + [Int, a] -> \d:Ord Int. f' a + +it means that we can replace the call + + f Int t ===> (\d. f' t) + +This chucks one dictionary away and proceeds with the +specialised version of f, namely f'. + + +What can't be done this way? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no way, post-typechecker, to get a dictionary for (say) +Eq a from a dictionary for Eq [a]. So if we find + + ==.sel [t] d + +we can't transform to + + eqList (==.sel t d') + +where + eqList :: (a->a->Bool) -> [a] -> [a] -> Bool + +Of course, we currently have no way to automatically derive +eqList, nor to connect it to the Eq [a] instance decl, but you +can imagine that it might somehow be possible. Taking advantage +of this is permanently ruled out. + +Still, this is no great hardship, because we intend to eliminate +overloading altogether anyway! + +A note about non-tyvar dictionaries +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Ids have types like + + forall a,b,c. Eq a -> Ord [a] -> tau + +This seems curious at first, because we usually only have dictionary +args whose types are of the form (C a) where a is a type variable. +But this doesn't hold for the functions arising from instance decls, +which sometimes get arguments with types of form (C (T a)) for some +type constructor T. + +Should we specialise wrt this compound-type dictionary? We used to say +"no", saying: + "This is a heuristic judgement, as indeed is the fact that we + specialise wrt only dictionaries. We choose *not* to specialise + wrt compound dictionaries because at the moment the only place + they show up is in instance decls, where they are simply plugged + into a returned dictionary. So nothing is gained by specialising + wrt them." + +But it is simpler and more uniform to specialise wrt these dicts too; +and in future GHC is likely to support full fledged type signatures +like + f :: Eq [(a,b)] => ... + + +Note [Specialisation and overlapping instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is at tricky case (see a comment in MR !8916): + + module A where + class C a where + meth :: a -> String + instance {-# OVERLAPPABLE #-} C (Maybe a) where + meth _ = "Maybe" + + {-# SPECIALISE f :: Maybe a -> Bool -> String #-} + f :: C a => a -> Bool -> String + f a True = f a False + f a _ = meth a + + module B where + import A + + instance C (Maybe Int) where + meth _ = "Int" + + main = putStrLn $ f (Just 42 :: Maybe Int) True + +Running main without optimisations yields "Int", the correct answer. +Activating optimisations yields "Maybe" due to a rewrite rule in module +A generated by the SPECIALISE pragma: + + RULE "USPEC f" forall a (d :: C a). f @a d = $sf + +In B we get the call (f @(Maybe Int) (d :: C (Maybe Int))), and +that rewrites to $sf, but that isn't really right. + +Overlapping instances mean that `C (Maybe Int)` is not a singleton +type: there two distinct dictionaries that have this type. And that +spells trouble for specialistion, which really asssumes singleton +types. + +For now, we just accept this problem, but it may bite us one day. +One solution would be to decline to expose any specialisation rules +to an importing module -- but that seems a bit drastic. + + +************************************************************************ +* * +\subsubsection{The new specialiser} +* * +************************************************************************ + +Our basic game plan is this. For let(rec) bound function + f :: (C a, D c) => (a,b,c,d) -> Bool + +* Find any specialised calls of f, (f ts ds), where + ts are the type arguments t1 .. t4, and + ds are the dictionary arguments d1 .. d2. + +* Add a new definition for f1 (say): + + f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 + + Note that we abstract over the unconstrained type arguments. + +* Add the mapping + + [t1,b,t3,d] |-> \d1 d2 -> f1 b d + + to the specialisations of f. This will be used by the + simplifier to replace calls + (f t1 t2 t3 t4) da db + by + (\d1 d1 -> f1 t2 t4) da db + + All the stuff about how many dictionaries to discard, and what types + to apply the specialised function to, are handled by the fact that the + SpecEnv contains a template for the result of the specialisation. + +We don't build *partial* specialisations for f. For example: + + f :: Eq a => a -> a -> Bool + {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-} + +Here, little is gained by making a specialised copy of f. +There's a distinct danger that the specialised version would +first build a dictionary for (Eq b, Eq c), and then select the (==) +method from it! Even if it didn't, not a great deal is saved. + +We do, however, generate polymorphic, but not overloaded, specialisations: + + f :: Eq a => [a] -> b -> b -> b + ... SPECIALISE f :: [Int] -> b -> b -> b ... + +Hence, the invariant is this: + + *** no specialised version is overloaded *** + + +************************************************************************ +* * +\subsubsection{The exported function} +* * +************************************************************************ +-} + +-- | Specialise calls to type-class overloaded functions occurring in a program. +specProgram :: ModGuts -> CoreM ModGuts +specProgram guts@(ModGuts { mg_module = this_mod + , mg_rules = local_rules + , mg_binds = binds }) + = do { dflags <- getDynFlags + ; rule_env <- initRuleEnv guts + -- See Note [Fire rules in the specialiser] + + -- We need to start with a Subst that knows all the things + -- that are in scope, so that the substitution engine doesn't + -- accidentally re-use a unique that's already in use + -- Easiest thing is to do it all at once, as if all the top-level + -- decls were mutually recursive + ; let top_env = SE { se_subst = Core.mkEmptySubst $ + mkInScopeSetBndrs binds + -- mkInScopeSetList $ + -- bindersOfBinds binds + , se_module = this_mod + , se_rules = rule_env + , se_dflags = dflags } + + go [] = return ([], emptyUDs) + go (bind:binds) = do (bind', binds', uds') <- specBind TopLevel top_env bind $ \_ -> + go binds + return (bind' ++ binds', uds') + + -- Specialise the bindings of this module + ; (binds', uds) <- runSpecM (go binds) + + ; (spec_rules, spec_binds) <- specImports top_env uds + + ; return (guts { mg_binds = spec_binds ++ binds' + , mg_rules = spec_rules ++ local_rules }) } + +{- +Note [Wrap bindings returned by specImports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'specImports' returns a set of specialized bindings. However, these are lacking +necessary floated dictionary bindings, which are returned by +UsageDetails(ud_binds). These dictionaries need to be brought into scope with +'wrapDictBinds' before the bindings returned by 'specImports' can be used. See, +for instance, the 'specImports' call in 'specProgram'. + + +Note [Disabling cross-module specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since GHC 7.10 we have performed specialisation of INLINABLE bindings living +in modules outside of the current module. This can sometimes uncover user code +which explodes in size when aggressively optimized. The +-fno-cross-module-specialise option was introduced to allow users to being +bitten by such instances to revert to the pre-7.10 behavior. + +See #10491 +-} + + +{- ********************************************************************* +* * + Specialising imported functions +* * +********************************************************************* -} + +{- Note [Specialising imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +specImports specialises imported functions, based on calls in this module. + +When -fspecialise-aggressively is on, we specialise any imported +function for which we have an unfolding. The +-fspecialise-aggressively flag is usually off, because we risk lots of +orphan modules from over-vigorous specialisation. (See Note [Orphans] +in GHC.Core.) However it's not a big deal: anything non-recursive with +an unfolding-template will probably have been inlined already. + +When -fspecialise-aggressively is off, we are more selective about +specialisation (see canSpecImport): + +(1) Without -fspecialise-aggressively, do not specialise + DFunUnfoldings. Note [Do not specialise imported DFuns]. + +(2) Without -fspecialise-aggressively, specialise only imported things + that have a /user-supplied/ INLINE or INLINABLE pragma (hence + isAnyInlinePragma rather than isStableSource). + + In particular, we don't want to specialise workers created by + worker/wrapper (for functions with no pragma) because they won't + specialise usefully, and they generate quite a bit of useless code + bloat. + + Specialise even INLINE things; it hasn't inlined yet, so perhaps + it never will. Moreover it may have calls inside it that we want + to specialise + +Wrinkle (W1): If we specialise an imported Id M.foo, we make a /local/ +binding $sfoo. But specImports may further specialise $sfoo. So we end up +with RULES for both M.foo (imported) and $sfoo (local). Rules for local +Ids should be attached to the Ids themselves (see GHC.HsToCore +Note [Attach rules to local ids]); so we must partition the rules and +attach the local rules. That is done in specImports, via addRulesToId. + +Note [Glom the bindings if imported functions are specialised] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an imported, *recursive*, INLINABLE function + f :: Eq a => a -> a + f = /\a \d x. ...(f a d)... +In the module being compiled we have + g x = f (x::Int) +Now we'll make a specialised function + f_spec :: Int -> Int + f_spec = \x -> ...(f Int dInt)... + {-# RULE f Int _ = f_spec #-} + g = \x. f Int dInt x +Note that f_spec doesn't look recursive +After rewriting with the RULE, we get + f_spec = \x -> ...(f_spec)... +BUT since f_spec was non-recursive before it'll *stay* non-recursive. +The occurrence analyser never turns a NonRec into a Rec. So we must +make sure that f_spec is recursive. Easiest thing is to make all +the specialisations for imported bindings recursive. +-} + +specImports :: SpecEnv + -> UsageDetails + -> CoreM ([CoreRule], [CoreBind]) +specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls }) + | not $ gopt Opt_CrossModuleSpecialise (se_dflags top_env) + -- See Note [Disabling cross-module specialisation] + = return ([], wrapDictBinds dict_binds []) + + | otherwise + = do { let env_w_dict_bndrs = top_env `bringFloatedDictsIntoScope` dict_binds + ; (_env, spec_rules, spec_binds) <- spec_imports env_w_dict_bndrs [] dict_binds calls + + -- Make a Rec: see Note [Glom the bindings if imported functions are specialised] + -- + -- wrapDictBinds: don't forget to wrap the specialized bindings with + -- bindings for the needed dictionaries. + -- See Note [Wrap bindings returned by specImports] + -- + -- addRulesToId: see Wrinkle (W1) in Note [Specialising imported functions] + -- c.f. GHC.HsToCore.addExportFlagsAndRules + ; let (rules_for_locals, rules_for_imps) = partition isLocalRule spec_rules + local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals + final_binds + | null spec_binds = wrapDictBinds dict_binds [] + | otherwise = [Rec $ mapFst (addRulesToId local_rule_base) $ + flattenBinds $ + wrapDictBinds dict_binds $ + spec_binds] + + ; return (rules_for_imps, final_binds) + } + +-- | Specialise a set of calls to imported bindings +spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in scope + ---In-scope set includes the FloatedDictBinds + -> [Id] -- Stack of imported functions being specialised + -- See Note [specImport call stack] + -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls + -- See Note [Avoiding loops in specImports] + -> CallDetails -- Calls for imported things + -> CoreM ( SpecEnv -- Env contains the new rules + , [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings +spec_imports env callers dict_binds calls + = do { let import_calls = dVarEnvElts calls +-- ; debugTraceMsg (text "specImports {" <+> +-- vcat [ text "calls:" <+> ppr import_calls +-- , text "dict_binds:" <+> ppr dict_binds ]) + ; (env, rules, spec_binds) <- go env import_calls +-- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls) + + ; return (env, rules, spec_binds) } + where + go :: SpecEnv -> [CallInfoSet] -> CoreM (SpecEnv, [CoreRule], [CoreBind]) + go env [] = return (env, [], []) + go env (cis : other_calls) + = do { -- debugTraceMsg (text "specImport {" <+> ppr cis) + ; (env, rules1, spec_binds1) <- spec_import env callers dict_binds cis + ; -- debugTraceMsg (text "specImport }" <+> ppr cis) + + ; (env, rules2, spec_binds2) <- go env other_calls + ; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) } + +spec_import :: SpecEnv -- Passed in so that all top-level Ids are in scope + ---In-scope set includes the FloatedDictBinds + -> [Id] -- Stack of imported functions being specialised + -- See Note [specImport call stack] + -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls + -- See Note [Avoiding loops in specImports] + -> CallInfoSet -- Imported function and calls for it + -> CoreM ( SpecEnv + , [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings +spec_import env callers dict_binds cis@(CIS fn _) + | isIn "specImport" fn callers + = return (env, [], []) -- No warning. This actually happens all the time + -- when specialising a recursive function, because + -- the RHS of the specialised function contains a recursive + -- call to the original function + + | null good_calls + = return (env, [], []) + + | Just rhs <- canSpecImport dflags fn + = do { -- Get rules from the external package state + -- We keep doing this in case we "page-fault in" + -- more rules as we go along + ; eps_rules <- getExternalRuleBase + ; let rule_env = se_rules env `updExternalPackageRules` eps_rules + +-- ; debugTraceMsg (text "specImport1" <+> vcat +-- [ text "function:" <+> ppr fn +-- , text "good calls:" <+> ppr good_calls +-- , text "existing rules:" <+> ppr (getRules rule_env fn) +-- , text "rhs:" <+> ppr rhs +-- , text "dict_binds:" <+> ppr dict_binds ]) + + ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) + <- runSpecM $ specCalls True env (getRules rule_env fn) good_calls fn rhs + + ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] + -- After the rules kick in, via fireRewriteRules, we may get recursion, + -- but we rely on a global GlomBinds to sort that out later + -- See Note [Glom the bindings if imported functions are specialised] + -- Meanwhile, though, bring the binders into scope + + new_subst = se_subst env `Core.extendSubstInScopeList` map fst spec_pairs + new_env = env { se_rules = rule_env `addLocalRules` rules1 + , se_subst = new_subst } + `bringFloatedDictsIntoScope` dict_binds1 + + -- Now specialise any cascaded calls +-- ; debugTraceMsg (text "specImport 2" <+> vcat +-- [ text "function:" <+> ppr fn +-- , text "rules1:" <+> ppr rules1 +-- , text "spec_binds1" <+> ppr spec_binds1 +-- , text "dict_binds1" <+> ppr dict_binds1 +-- , text "new_calls" <+> ppr new_calls ]) + + ; (env, rules2, spec_binds2) + <- spec_imports new_env (fn:callers) + (dict_binds `thenFDBs` dict_binds1) + new_calls + + ; let final_binds = wrapDictBinds dict_binds1 $ + spec_binds2 ++ spec_binds1 + + ; return (env, rules2 ++ rules1, final_binds) } + + | otherwise + = do { tryWarnMissingSpecs dflags callers fn good_calls + ; return (env, [], [])} + + where + dflags = se_dflags env + good_calls = filterCalls cis dict_binds + -- SUPER IMPORTANT! Drop calls that (directly or indirectly) refer to fn + -- See Note [Avoiding loops in specImports] + +canSpecImport :: DynFlags -> Id -> Maybe CoreExpr +canSpecImport dflags fn + | isDataConWrapId fn + = Nothing -- Don't specialise data-con wrappers, even if they + -- have dict args; there is no benefit. + + | CoreUnfolding { uf_tmpl = rhs } <- unf + -- CoreUnfolding: see Note [Specialising imported functions] point (1). + , isAnyInlinePragma (idInlinePragma fn) + -- See Note [Specialising imported functions] point (2). + = Just rhs + + | gopt Opt_SpecialiseAggressively dflags + = maybeUnfoldingTemplate unf + -- With -fspecialise-aggressively, specialise anything + -- with an unfolding, stable or not, DFun or not + + | otherwise = Nothing + where + unf = realIdUnfolding fn -- We want to see the unfolding even for loop breakers + +-- | Returns whether or not to show a missed-spec warning. +-- If -Wall-missed-specializations is on, show the warning. +-- Otherwise, if -Wmissed-specializations is on, only show a warning +-- if there is at least one imported function being specialized, +-- and if all imported functions are marked with an inline pragma +-- Use the most specific warning as the reason. +tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () +-- See Note [Warning about missed specialisations] +tryWarnMissingSpecs dflags callers fn calls_for_fn + | isClassOpId fn = return () -- See Note [Missed specialisation for ClassOps] + | wopt Opt_WarnMissedSpecs dflags + && not (null callers) + && allCallersInlined = doWarn $ WarningWithFlag Opt_WarnMissedSpecs + | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs + | otherwise = return () + where + allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers + diag_opts = initDiagOpts dflags + doWarn reason = + msg (mkMCDiagnostic diag_opts reason Nothing) + (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) + 2 (vcat [ text "when specialising" <+> quotes (ppr caller) + | caller <- callers]) + , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) + , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) + +{- Note [Missed specialisation for ClassOps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #19592 I saw a number of missed specialisation warnings +which were the result of things like: + + case isJumpishInstr @X86.Instr $dInstruction_s7f8 eta3_a78C of { ... + +where isJumpishInstr is part of the Instruction class and defined like +this: + + class Instruction instr where + ... + isJumpishInstr :: instr -> Bool + ... + +isJumpishInstr is a ClassOp which will select the right method +from within the dictionary via our built in rules. See also +Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance. + +We don't give these unfoldings, and as a result the specialiser +complains. But usually this doesn't matter. The simplifier will +apply the rule and we end up with + + case isJumpishInstrImplX86 eta3_a78C of { ... + +Since isJumpishInstrImplX86 is defined for a concrete instance (given +by the dictionary) it is usually already well specialised! +Theoretically the implementation of a method could still be overloaded +over a different type class than what it's a method of. But I wasn't able +to make this go wrong, and SPJ thinks this should be fine as well. + +So I decided to remove the warnings for failed specialisations on ClassOps +alltogether as they do more harm than good. +-} + +{- Note [Do not specialise imported DFuns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticket #18223 shows that specialising calls of DFuns is can cause a huge +and entirely unnecessary blowup in program size. Consider a call to + f @[[[[[[[[T]]]]]]]] d1 x +where df :: C a => C [a] + d1 :: C [[[[[[[[T]]]]]]]] = dfC[] @[[[[[[[T]]]]]]] d1 + d2 :: C [[[[[[[T]]]]]]] = dfC[] @[[[[[[T]]]]]] d3 + ... +Now we'll specialise f's RHS, which may give rise to calls to 'g', +also overloaded, which we will specialise, and so on. However, if +we specialise the calls to dfC[], we'll generate specialised copies of +all methods of C, at all types; and the same for C's superclasses. + +And many of these specialised functions will never be called. We are +going to call the specialised 'f', and the specialised 'g', but DFuns +group functions into a tuple, many of whose elements may never be used. + +With deeply-nested types this can lead to a simply overwhelming number +of specialisations: see #18223 for a simple example (from the wild). +I measured the number of specialisations for various numbers of calls +of `flip evalStateT ()`, and got this + + Size after one simplification + #calls #SPEC rules Terms Types + 5 56 3100 10600 + 9 108 13660 77206 + +The real tests case has 60+ calls, which blew GHC out of the water. + +Solution: don't specialise DFuns. The downside is that if we end +up with (h (dfun d)), /and/ we don't specialise 'h', then we won't +pass to 'h' a tuple of specialised functions. + +However, the flag -fspecialise-aggressively (experimental, off by default) +allows DFuns to specialise as well. + +Note [Avoiding loops in specImports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must take great care when specialising instance declarations +(DFuns like $fOrdList) lest we accidentally build a recursive +dictionary. See Note [Avoiding loops (DFuns)]. + +The basic strategy of Note [Avoiding loops (DFuns)] is to use filterCalls +to discard loopy specialisations. But to do that we must ensure +that the in-scope dict-binds (passed to filterCalls) contains +all the needed dictionary bindings. In particular, in the recursive +call to spec_imports in spec_import, we must include the dict-binds +from the parent. Lacking this caused #17151, a really nasty bug. + +Here is what happened. +* Class structure: + Source is a superclass of Mut + Index is a superclass of Source + +* We started with these dict binds + dSource = $fSourcePix @Int $fIndexInt + dIndex = sc_sel dSource + dMut = $fMutPix @Int dIndex + and these calls to specialise + $fMutPix @Int dIndex + $fSourcePix @Int $fIndexInt + +* We specialised the call ($fMutPix @Int dIndex) + ==> new call ($fSourcePix @Int dIndex) + (because Source is a superclass of Mut) + +* We specialised ($fSourcePix @Int dIndex) + ==> produces specialised dict $s$fSourcePix, + a record with dIndex as a field + plus RULE forall d. ($fSourcePix @Int d) = $s$fSourcePix + *** This is the bogus step *** + +* Now we decide not to specialise the call + $fSourcePix @Int $fIndexInt + because we alredy have a RULE that matches it + +* Finally the simplifer rewrites + dSource = $fSourcePix @Int $fIndexInt + ==> dSource = $s$fSourcePix + +Disaster. Now we have + +Rewrite dSource's RHS to $s$fSourcePix Disaster + dSource = $s$fSourcePix + dIndex = sc_sel dSource + $s$fSourcePix = MkSource dIndex ... + +Solution: filterCalls should have stopped the bogus step, +by seeing that dIndex transitively uses $fSourcePix. But +it can only do that if it sees all the dict_binds. Wow. + +-------------- +Here's another example (#13429). Suppose we have + class Monoid v => C v a where ... + +We start with a call + f @ [Integer] @ Integer $fC[]Integer + +Specialising call to 'f' gives dict bindings + $dMonoid_1 :: Monoid [Integer] + $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer + + $dC_1 :: C [Integer] (Node [Integer] Integer) + $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 + +...plus a recursive call to + f @ [Integer] @ (Node [Integer] Integer) $dC_1 + +Specialising that call gives + $dMonoid_2 :: Monoid [Integer] + $dMonoid_2 = M.$p1C @ [Integer] $dC_1 + + $dC_2 :: C [Integer] (Node [Integer] Integer) + $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2 + +Now we have two calls to the imported function + M.$fCvNode :: Monoid v => C v a + M.$fCvNode @v @a m = C m some_fun + +But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2) +for specialisation, else we get: + + $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 + $dMonoid_2 = M.$p1C @ [Integer] $dC_1 + $s$fCvNode = C $dMonoid_2 ... + RULE M.$fCvNode [Integer] _ _ = $s$fCvNode + +Now use the rule to rewrite the call in the RHS of $dC_1 +and we get a loop! + + +Note [specImport call stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising an imports function 'f', we may get new calls +of an imported function 'g', which we want to specialise in turn, +and similarly specialising 'g' might expose a new call to 'h'. + +We track the stack of enclosing functions. So when specialising 'h' we +have a specImport call stack of [g,f]. We do this for two reasons: +* Note [Warning about missed specialisations] +* Note [Avoiding recursive specialisation] + +Note [Warning about missed specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose + * In module Lib, you carefully mark a function 'foo' INLINABLE + * Import Lib(foo) into another module M + * Call 'foo' at some specialised type in M +Then you jolly well expect it to be specialised in M. But what if +'foo' calls another function 'Lib.bar'. Then you'd like 'bar' to be +specialised too. But if 'bar' is not marked INLINABLE it may well +not be specialised. The warning Opt_WarnMissedSpecs warns about this. + +It's more noisy to warning about a missed specialisation opportunity +for /every/ overloaded imported function, but sometimes useful. That +is what Opt_WarnAllMissedSpecs does. + +ToDo: warn about missed opportunities for local functions. + +Note [Avoiding recursive specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise 'f' we may find new overloaded calls to 'g', 'h' in +'f's RHS. So we want to specialise g,h. But we don't want to +specialise f any more! It's possible that f's RHS might have a +recursive yet-more-specialised call, so we'd diverge in that case. +And if the call is to the same type, one specialisation is enough. +Avoiding this recursive specialisation loop is one reason for the +'callers' stack passed to specImports and specImport. + + +************************************************************************ +* * +\subsubsection{@specExpr@: the main function} +* * +************************************************************************ +-} + +data SpecEnv + = SE { se_subst :: Core.Subst + -- We carry a substitution down: + -- a) we must clone any binding that might float outwards, + -- to avoid name clashes + -- b) we carry a type substitution to use when analysing + -- the RHS of specialised bindings (no type-let!) + + , se_module :: Module + , se_rules :: RuleEnv -- From the home package and this module + , se_dflags :: DynFlags + } + +instance Outputable SpecEnv where + ppr (SE { se_subst = subst }) + = text "SE" <+> braces (text "subst =" <+> ppr subst) + +specVar :: SpecEnv -> InId -> SpecM (OutExpr, UsageDetails) +specVar env@(SE { se_subst = Core.Subst in_scope ids _ _ }) v + | not (isLocalId v) = return (Var v, emptyUDs) + | Just e <- lookupVarEnv ids v = specExpr (zapSubst env) e -- Note (1) + | Just v' <- lookupInScope in_scope v = return (Var v', emptyUDs) + | otherwise = pprPanic "specVar" (ppr v $$ ppr in_scope) + -- c.f. GHC.Core.Subst.lookupIdSubst + -- Note (1): we recurse so we do the lookupInScope thing on any Vars in e + -- probably has little effect, but it's the right thing. + -- We need zapSubst because `e` is an OutExpr + +specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) + +---------------- First the easy cases -------------------- +specExpr env (Var v) = specVar env v +specExpr env (Type ty) = return (Type (substTy env ty), emptyUDs) +specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs) +specExpr _ (Lit lit) = return (Lit lit, emptyUDs) +specExpr env (Cast e co) + = do { (e', uds) <- specExpr env e + ; return ((mkCast e' (substCo env co)), uds) } +specExpr env (Tick tickish body) + = do { (body', uds) <- specExpr env body + ; return (Tick (specTickish env tickish) body', uds) } + +---------------- Applications might generate a call instance -------------------- +specExpr env expr@(App {}) + = do { let (fun_in, args_in) = collectArgs expr + ; (fun_out, uds_fun) <- specExpr env fun_in + ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in + ; let uds_app = uds_fun `thenUDs` uds_args + env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app + -- zapSubst: we have now fully applied the substitution + -- bringFloatedDictsIntoScope: some dicts may have floated out of + -- args_in; they should be in scope for fireRewriteRules (#21689) + + -- Try firing rewrite rules + -- See Note [Fire rules in the specialiser] + ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out + + -- Make a call record, and return + ; let uds_call = mkCallUDs env fun_out' args_out' + ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) } + +---------------- Lambda/case require dumping of usage details -------------------- +specExpr env e@(Lam {}) + = specLam env' bndrs' body + where + (bndrs, body) = collectBinders e + (env', bndrs') = substBndrs env bndrs + -- More efficient to collect a group of binders together all at once + -- and we don't want to split a lambda group with dumped bindings + +specExpr env (Case scrut case_bndr ty alts) + = do { (scrut', scrut_uds) <- specExpr env scrut + ; (scrut'', case_bndr', alts', alts_uds) + <- specCase env scrut' case_bndr alts +-- ; pprTrace "specExpr:case" (vcat +-- [ text "scrut" <+> ppr scrut, text "scrut'" <+> ppr scrut' +-- , text "case_bndr'" <+> ppr case_bndr' +-- , text "alts_uds" <+> ppr alts_uds +-- ]) + ; return (Case scrut'' case_bndr' (substTy env ty) alts' + , scrut_uds `thenUDs` alts_uds) } + +---------------- Finally, let is the interesting case -------------------- +specExpr env (Let bind body) + = do { (binds', body', uds) <- specBind NotTopLevel env bind $ \body_env -> + -- pprTrace "specExpr:let" (ppr (se_subst body_env) $$ ppr body) $ + specExpr body_env body + -- All done + ; return (foldr Let body' binds', uds) } + +-- See Note [Specialisation modulo dictionary selectors] +-- Note [ClassOp/DFun selection] +-- Note [Fire rules in the specialiser] +fireRewriteRules :: SpecEnv -- Substitution is already zapped + -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr]) +fireRewriteRules env (Var f) args + | let rules = getRules (se_rules env) f + , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules + , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] + zapped_subst = se_subst env -- Just needed for the InScopeSet + expr' = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args) + -- simplOptExpr needed because lookupRule returns + -- (\x y. rhs) arg1 arg2 + , (fun', args') <- collectArgs expr' + = fireRewriteRules env fun' args' +fireRewriteRules _ fun args = (fun, args) + +-------------- +specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails) +-- The binders have been substituted, but the body has not +specLam env bndrs body + | null bndrs + = specExpr env body + | otherwise + = do { (body', uds) <- specExpr env body + ; let (free_uds, dumped_dbs) = dumpUDs bndrs uds + ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) } + +-------------- +specTickish :: SpecEnv -> CoreTickish -> CoreTickish +specTickish (SE { se_subst = subst }) bp = substTickish subst bp + +-------------- +specCase :: SpecEnv + -> OutExpr -- Scrutinee, already done + -> InId -> [InAlt] + -> SpecM ( OutExpr -- New scrutinee + , OutId + , [OutAlt] + , UsageDetails) +specCase env scrut' case_bndr [Alt con args rhs] + | -- See Note [Floating dictionaries out of cases] + isDictTy (idType case_bndr) + , interestingDict env scrut' + , not (isDeadBinder case_bndr && null sc_args') + = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args') + + ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut' + scrut_bind = mkDB (NonRec case_bndr_flt scrut') + + sc_args_flt' = zipWith addDictUnfolding sc_args_flt sc_rhss + sc_rhss = [ Case (Var case_bndr_flt') case_bndr' (idType sc_arg') + [Alt con args' (Var sc_arg')] + | sc_arg' <- sc_args' ] + cb_set = unitVarSet case_bndr_flt' + sc_binds = [ DB { db_bind = NonRec sc_arg_flt sc_rhs, db_fvs = cb_set } + | (sc_arg_flt, sc_rhs) <- sc_args_flt' `zip` sc_rhss ] + + flt_binds = scrut_bind : sc_binds + + -- Extend the substitution for RHS to map the *original* binders + -- to their floated versions. + mb_sc_flts :: [Maybe DictId] + mb_sc_flts = map (lookupVarEnv clone_env) args' + clone_env = zipVarEnv sc_args' sc_args_flt' + + subst_prs = (case_bndr, Var case_bndr_flt) + : [ (arg, Var sc_flt) + | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] + subst' = se_subst env_rhs + `Core.extendSubstInScopeList` (case_bndr_flt' : sc_args_flt') + `Core.extendIdSubstList` subst_prs + env_rhs' = env_rhs { se_subst = subst' } + + ; (rhs', rhs_uds) <- specExpr env_rhs' rhs + ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds + all_uds = flt_binds `consDictBinds` free_uds + alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs') +-- ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $ + ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } + where + (env_rhs, (case_bndr':|args')) = substBndrs env (case_bndr:|args) + sc_args' = filter is_flt_sc_arg args' + + clone_me bndr = do { uniq <- getUniqueM + ; return (mkUserLocalOrCoVar occ uniq wght ty loc) } + where + name = idName bndr + wght = idMult bndr + ty = idType bndr + occ = nameOccName name + loc = getSrcSpan name + + arg_set = mkVarSet args' + is_flt_sc_arg var = isId var + && not (isDeadBinder var) + && isDictTy var_ty + && tyCoVarsOfType var_ty `disjointVarSet` arg_set + where + var_ty = idType var + +specCase env scrut case_bndr alts + = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts + ; return (scrut, case_bndr', alts', uds_alts) } + where + (env_alt, case_bndr') = substBndr env case_bndr + spec_alt (Alt con args rhs) + = do { (rhs', uds) <- specExpr env_rhs rhs + ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds +-- ; unless (isNilOL dumped_dbs) $ +-- pprTrace "specAlt" (vcat +-- [text "case_bndr', args" <+> (ppr case_bndr' $$ ppr args) +-- ,text "dumped" <+> ppr dumped_dbs ]) return () + ; return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) } + where + (env_rhs, args') = substBndrs env_alt args + + +{- Note [Fire rules in the specialiser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#21851) + + module A where + f :: Num b => b -> (b, b) + f x = (x + 1, snd (f x)) + {-# SPECIALIZE f :: Int -> (Int, Int) #-} + + module B (g') where + import A + + g :: Num a => a -> a + g x = fst (f x) + {-# NOINLINE[99] g #-} + + h :: Int -> Int + h = g + +Note that `f` has the CPR property, and so will worker/wrapper. + +The call to `g` in `h` will make us specialise `g @Int`. And the specialised +version of `g` will contain the call `f @Int`; but in the subsequent run of +the Simplifier, there will be a competition between: + * The user-supplied SPECIALISE rule for `f` + * The inlining of the wrapper for `f` +In fact, the latter wins -- see Note [tryRules: plan (BEFORE)] +GHC.Core.Opt.Simplify.Iteration. However, it a bit fragile. + +Moreover consider (test T21851_2): + + module A + f :: (Ord a, Show b) => a -> b -> blah + {-# RULE forall b. f @Int @b = wombat #-} + + wombat :: Show b => Int -> b -> blah + wombat = blah + + module B + import A + g :: forall a. Ord a => blah + g @a = ...g...f @a @Char.... + + h = ....g @Int.... + +Now, in module B, GHC will specialise `g @Int`, which will lead to a +call `f @Int @Char`. If we immediately (in the specialiser) rewrite +that to `womabat @Char`, we have a chance to specialise `wombat`. + +Conclusion: it's treat if the Specialiser fires RULEs itself. +It's not hard to achieve: see `fireRewriteRules`. The only tricky bit is +making sure that we have a reasonably up to date EPS rule base. Currently +we load it up just once, in `initRuleEnv`, called at the beginning of +`specProgram`. + +NB: you might wonder if running rules in the specialiser (this Note) renders +Note [tryRules: plan (BEFORE)] in the Simplifier (partly) redundant. That is, +if we run rules in the specialiser, does it matter if we make rules "win" over +inlining in the Simplifier? Yes, it does! See the discussion in #21851. + +Note [Floating dictionaries out of cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + g = \d. case d of { MkD sc ... -> ...(f sc)... } +Naively we can't float d2's binding out of the case expression, +because 'sc' is bound by the case, and that in turn means we can't +specialise f, which seems a pity. + +So we invert the case, by floating out a binding +for 'sc_flt' thus: + sc_flt = case d of { MkD sc ... -> sc } +Now we can float the call instance for 'f'. Indeed this is just +what'll happen if 'sc' was originally bound with a let binding, +but case is more efficient, and necessary with equalities. So it's +good to work with both. + +You might think that this won't make any difference, because the +call instance will only get nuked by the \d. BUT if 'g' itself is +specialised, then transitively we should be able to specialise f. + +In general, given + case e of cb { MkD sc ... -> ...(f sc)... } +we transform to + let cb_flt = e + sc_flt = case cb_flt of { MkD sc ... -> sc } + in + case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... } + +The "_flt" things are the floated binds; we use the current substitution +to substitute sc -> sc_flt in the RHS + +************************************************************************ +* * + Dealing with a binding +* * +************************************************************************ +-} + +bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv +bringFloatedDictsIntoScope env (FDB { fdb_bndrs = dx_bndrs }) + = -- pprTrace "brought into scope" (ppr dx_bndrs) $ + env {se_subst=subst'} + where + subst' = se_subst env `Core.extendSubstInScopeSet` dx_bndrs + +specBind :: TopLevelFlag + -> SpecEnv -- At top-level only, this env already has the + -- top level binders in scope + -> InBind + -> (SpecEnv -> SpecM (body, UsageDetails)) -- Process the body + -> SpecM ( [OutBind] -- New bindings + , body -- Body + , UsageDetails) -- And info to pass upstream + +-- Returned UsageDetails: +-- No calls for binders of this bind +specBind top_lvl env (NonRec fn rhs) do_body + = do { (rhs', rhs_uds) <- specExpr env rhs + + ; (body_env1, fn1) <- case top_lvl of + TopLevel -> return (env, fn) + NotTopLevel -> cloneBndrSM env fn + + ; let fn2 | isStableUnfolding (idUnfolding fn1) = fn1 + | otherwise = fn1 `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs' + -- Update the unfolding with the perhaps-simpler or more specialised rhs' + -- This is important: see Note [Update unfolding after specialisation] + -- And in any case cloneBndrSM discards non-Stable unfoldings + + fn3 = floatifyIdDemandInfo fn2 + -- We zap the demand info because the binding may float, + -- which would invalidate the demand info (see #17810 for example). + -- Destroying demand info is not terrible; specialisation is + -- always followed soon by demand analysis. + -- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels + + body_env2 = body_env1 `bringFloatedDictsIntoScope` ud_binds rhs_uds + `extendInScope` fn3 + -- bringFloatedDictsIntoScope: see #23567 + + ; (body', body_uds) <- do_body body_env2 + + ; (fn4, spec_defns, body_uds1) <- specDefn env body_uds fn3 rhs + + ; let (free_uds, dump_dbs, float_all) = dumpBindUDs [fn4] body_uds1 + all_free_uds = free_uds `thenUDs` rhs_uds + + pairs = spec_defns ++ [(fn4, rhs')] + -- fn4 mentions the spec_defns in its rules, + -- so put the latter first + + final_binds :: [DictBind] + -- See Note [From non-recursive to recursive] + final_binds | not (isNilOL dump_dbs) + , not (null spec_defns) + = [recWithDumpedDicts pairs dump_dbs] + | otherwise + = [mkDB $ NonRec b r | (b,r) <- pairs] + ++ fromOL dump_dbs + + can_float_this_one = exprIsTopLevelBindable rhs (idType fn) + -- exprIsTopLevelBindable: see Note [Care with unlifted bindings] + + ; if float_all && can_float_this_one then + -- Rather than discard the calls mentioning the bound variables + -- we float this (dictionary) binding along with the others + return ([], body', all_free_uds `snocDictBinds` final_binds) + else + -- No call in final_uds mentions bound variables, + -- so we can just leave the binding here + return (map db_bind final_binds, body', all_free_uds) } + + +specBind top_lvl env (Rec pairs) do_body + -- Note [Specialising a recursive group] + = do { let (bndrs,rhss) = unzip pairs + + ; (rec_env, bndrs1) <- case top_lvl of + TopLevel -> return (env, bndrs) + NotTopLevel -> cloneRecBndrsSM env bndrs + + ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rec_env) rhss + ; (body', body_uds) <- do_body rec_env + + ; let scope_uds = body_uds `thenUDs` rhs_uds + -- Includes binds and calls arising from rhss + + ; (bndrs2, spec_defns2, uds2) <- specDefns rec_env scope_uds (bndrs1 `zip` rhss) + -- bndrs2 is like bndrs1, but with RULES added + + ; (bndrs3, spec_defns3, uds3) + <- if null spec_defns2 -- Common case: no specialisation + then return (bndrs2, [], uds2) + else do { -- Specialisation occurred; do it again + (bndrs3, spec_defns3, uds3) + <- specDefns rec_env uds2 (bndrs2 `zip` rhss) + ; return (bndrs3, spec_defns3 ++ spec_defns2, uds3) } + + ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs1 uds3 + final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss') + dumped_dbs + + ; if float_all then + return ([], body', final_uds `snocDictBind` final_bind) + else + return ([db_bind final_bind], body', final_uds) } + + +--------------------------- +specDefns :: SpecEnv + -> UsageDetails -- Info on how it is used in its scope + -> [(OutId,InExpr)] -- The things being bound and their un-processed RHS + -> SpecM ([OutId], -- Original Ids with RULES added + [(OutId,OutExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions + +-- Specialise a list of bindings (the contents of a Rec), but flowing usages +-- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } +-- Then if the input CallDetails has a specialised call for 'g', whose specialisation +-- in turn generates a specialised call for 'f', we catch that in this one sweep. +-- But not vice versa (it's a fixpoint problem). + +specDefns _env uds [] + = return ([], [], uds) +specDefns env uds ((bndr,rhs):pairs) + = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs + ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs + ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) } + +--------------------------- +specDefn :: SpecEnv + -> UsageDetails -- Info on how it is used in its scope + -> OutId -> InExpr -- The thing being bound and its un-processed RHS + -> SpecM (Id, -- Original Id with added RULES + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions + +specDefn env body_uds fn rhs + = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds + rules_for_me = idCoreRules fn + -- Bring into scope the binders from the floated dicts + env_w_dict_bndrs = bringFloatedDictsIntoScope env (ud_binds body_uds) + + ; (rules, spec_defns, spec_uds) <- specCalls False env_w_dict_bndrs + rules_for_me calls_for_me fn rhs + + ; return ( fn `addIdSpecialisations` rules + , spec_defns + , body_uds_without_me `thenUDs` spec_uds) } + -- It's important that the `thenUDs` is this way + -- round, because body_uds_without_me may bind + -- dictionaries that are used in calls_for_me passed + -- to specDefn. So the dictionary bindings in + -- spec_uds may mention dictionaries bound in + -- body_uds_without_me + +--------------------------- +specCalls :: Bool -- True => specialising imported fn + -- False => specialising local fn + -> SpecEnv + -> [CoreRule] -- Existing RULES for the fn + -> [CallInfo] + -> OutId -> InExpr + -> SpecM SpecInfo -- New rules, specialised bindings, and usage details + +-- This function checks existing rules, and does not create +-- duplicate ones. So the caller does not need to do this filtering. +-- See `alreadyCovered` + +type SpecInfo = ( [CoreRule] -- Specialisation rules + , [(Id,CoreExpr)] -- Specialised definition + , UsageDetails ) -- Usage details from specialised RHSs + +specCalls spec_imp env existing_rules calls_for_me fn rhs + -- The first case is the interesting one + | notNull calls_for_me -- And there are some calls to specialise + && not (isNeverActive (idInlineActivation fn)) + -- Don't specialise NOINLINE things + -- See Note [Auto-specialisation and RULES] + -- + -- Don't specialise OPAQUE things, see Note [OPAQUE pragma]. + -- Since OPAQUE things are always never-active (see + -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for + -- OPAQUE things. + +-- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small +-- See Note [Inline specialisations] for why we do not +-- switch off specialisation for inline functions + + = -- pprTrace "specCalls: some" (vcat + -- [ text "function" <+> ppr fn + -- , text "calls:" <+> ppr calls_for_me + -- , text "subst" <+> ppr (se_subst env) ]) $ + foldlM spec_call ([], [], emptyUDs) calls_for_me + + | otherwise -- No calls or RHS doesn't fit our preconceptions + = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me) + "Missed specialisation opportunity for" (ppr fn $$ trace_doc) $ + -- Note [Specialisation shape] + -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $ + return ([], [], emptyUDs) + where + trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ] + + fn_type = idType fn + fn_arity = idArity fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here + inl_prag = idInlinePragma fn + inl_act = inlinePragmaActivation inl_prag + is_active = isActive (beginPhase inl_act) :: Activation -> Bool + -- is_active: inl_act is the activation we are going to put in the new + -- SPEC rule; so we want to see if it is covered by another rule with + -- that same activation. + is_local = isLocalId fn + is_dfun = isDFunId fn + dflags = se_dflags env + this_mod = se_module env + subst = se_subst env + in_scope = Core.substInScopeSet subst + -- Figure out whether the function has an INLINE pragma + -- See Note [Inline specialisations] + + (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs + -- See Note [Account for casts in binding] + + -- Copy InlinePragma information from the parent Id. + -- So if f has INLINE[1] so does spec_fn + spec_inl_prag + | not is_local -- See Note [Specialising imported functions] + , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal + = neverInlinePragma + | otherwise + = inl_prag + + not_in_scope :: InterestingVarFun + not_in_scope v = isLocalVar v && not (v `elemInScopeSet` in_scope) + + ---------------------------------------------------------- + -- Specialise to one particular call pattern + spec_call :: SpecInfo -- Accumulating parameter + -> CallInfo -- Call instance + -> SpecM SpecInfo + spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args }) + = -- See Note [Specialising Calls] + do { let all_call_args | is_dfun = saturating_call_args -- See Note [Specialising DFuns] + | otherwise = call_args + saturating_call_args = call_args ++ map mk_extra_dfun_arg (dropList call_args rhs_bndrs) + mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType + | otherwise = UnspecArg + + -- Find qvars, the type variables to add to the binders for the rule + -- Namely those free in `ty` that aren't in scope + -- See (MP2) in Note [Specialising polymorphic dictionaries] + ; let poly_qvars = scopedSort $ fvVarList $ specArgsFVs not_in_scope call_args + subst' = subst `Core.extendSubstInScopeList` poly_qvars + -- Maybe we should clone the poly_qvars telescope? + + -- Any free Ids will have caused the call to be dropped + ; massertPpr (all isTyCoVar poly_qvars) + (ppr fn $$ ppr all_call_args $$ ppr poly_qvars) + + ; (useful, subst'', rule_bndrs, rule_lhs_args, spec_bndrs, dx_binds, spec_args) + <- specHeader subst' rhs_bndrs all_call_args + ; let all_rule_bndrs = poly_qvars ++ rule_bndrs + env' = env { se_subst = subst'' } + + -- Check for (a) usefulness and (b) not already covered + -- See (SC1) in Note [Specialisations already covered] + ; let all_rules = rules_acc ++ existing_rules + -- all_rules: we look both in the rules_acc (generated by this invocation + -- of specCalls), and in existing_rules (passed in to specCalls) + already_covered = alreadyCovered env' all_rule_bndrs fn + rule_lhs_args is_active all_rules + +{- ; pprTrace "spec_call" (vcat + [ text "fun: " <+> ppr fn + , text "call info: " <+> ppr _ci + , text "useful: " <+> ppr useful + , text "already_covered:" <+> ppr already_covered + , text "poly_qvars: " <+> ppr poly_qvars + , text "useful: " <+> ppr useful + , text "all_rule_bndrs:" <+> ppr all_rule_bndrs + , text "rule_lhs_args:" <+> ppr rule_lhs_args + , text "spec_bndrs:" <+> ppr spec_bndrs + , text "dx_binds:" <+> ppr dx_binds + , text "spec_args: " <+> ppr spec_args + , text "rhs_bndrs" <+> ppr rhs_bndrs + , text "rhs_body" <+> ppr rhs_body + , text "subst''" <+> ppr subst'' ]) $ + return () +-} + + ; if not useful -- No useful specialisation + || already_covered -- Useful, but done already + then return spec_acc + else + + -- Not useless, not already covered: make a specialised binding + do { let inner_rhs_bndrs = dropList all_call_args rhs_bndrs + (env'', inner_rhs_bndrs') = substBndrs env' inner_rhs_bndrs + + -- Run the specialiser on the specialised RHS + ; (rhs_body', rhs_uds) <- specExpr env'' rhs_body + +{- ; pprTrace "spec_call2" (vcat + [ text "fun:" <+> ppr fn + , text "rhs_body':" <+> ppr rhs_body' ]) $ + return () +-} + + -- Make the RHS of the specialised function + ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs' + (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds + (rhs_uds2, outer_dumped_dbs) = dumpUDs poly_qvars (dx_binds `consDictBinds` rhs_uds1) + -- dx_binds comes from the arguments to the call, and so can mention + -- poly_qvars but no other local binders + spec_rhs = mkLams poly_qvars $ + wrapDictBindsE outer_dumped_dbs $ + mkLams spec_rhs_bndrs $ + wrapDictBindsE inner_dumped_dbs rhs_body' + rule_rhs_args = poly_qvars ++ spec_bndrs + + -- Maybe add a void arg to the specialised function, + -- to avoid unlifted bindings + -- See Note [Specialisations Must Be Lifted] + -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg + + spec_fn_ty = exprType spec_rhs + add_void_arg = isUnliftedType spec_fn_ty && not (isJoinId fn) + (rule_rhs_args1, spec_rhs1, spec_fn_ty1) + | add_void_arg = ( voidPrimId : rule_rhs_args + , Lam voidArgId spec_rhs + , mkVisFunTyMany unboxedUnitTy spec_fn_ty ) + | otherwise = (rule_rhs_args, spec_rhs, spec_fn_ty) + + -------------------------------------- + -- Add a suitable unfolding; see Note [Inline specialisations] + -- The wrap_unf_body applies the original unfolding to the specialised + -- arguments, not forgetting to wrap the dx_binds around the outside (#22358) + simpl_opts = initSimpleOpts dflags + wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds + spec_unf = specUnfolding simpl_opts rule_rhs_args1 wrap_unf_body + rule_lhs_args fn_unf + + -------------------------------------- + -- Adding arity information just propagates it a bit faster + -- See Note [Arity decrease] in GHC.Core.Opt.Simplify + join_arity_decr = length rule_lhs_args - length rule_rhs_args1 + arity_decr = count isValArg rule_lhs_args - count isId rule_rhs_args1 + + spec_fn_info + = vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr) + `setInlinePragInfo` spec_inl_prag + `setUnfoldingInfo` spec_unf + + -- Compute the IdDetails of the specialise Id + -- See Note [Transfer IdDetails during specialisation] + spec_fn_details + = case idDetails fn of + JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing + DFunId unary -> DFunId unary + _ -> VanillaId + + ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty1 spec_fn_details spec_fn_info + ; let + -- The rule to put in the function's specialisation is: + -- forall x @b d1' d2'. + -- f x @T1 @b @T2 d1' d2' = f1 x @b + -- See Note [Specialising Calls] + herald | spec_imp = -- Specialising imported fn + text "SPEC/" <> ppr this_mod + | otherwise = -- Specialising local fn + text "SPEC" + + spec_rule = mkSpecRule dflags this_mod True inl_act + herald fn all_rule_bndrs rule_lhs_args + (mkVarApps (Var spec_fn) rule_rhs_args1) + + _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type + , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty1 + , ppr rhs_bndrs, ppr call_args + , ppr spec_rule + , text "acc" <+> ppr rules_acc + , text "existing" <+> ppr existing_rules + ] + + ; -- pprTrace "spec_call: rule" _rule_trace_doc + return ( spec_rule : rules_acc + , (spec_fn, spec_rhs1) : pairs_acc + , rhs_uds2 `thenUDs` uds_acc + ) } } + +alreadyCovered :: SpecEnv + -> [Var] -> Id -> [CoreExpr] -- LHS of possible new rule + -> (Activation -> Bool) -- Which rules are active + -> [CoreRule] -> Bool +-- Note [Specialisations already covered] esp (SC2) +alreadyCovered env bndrs fn args is_active rules + = case specLookupRule env fn args is_active rules of + Nothing -> False + Just (rule, _) + | isAutoRule rule -> -- Discard identical rules + -- We know that (fn args) is an instance of RULE + -- Check if RULE is an instance of (fn args) + ruleLhsIsMoreSpecific in_scope bndrs args rule + | otherwise -> True -- User rules dominate + where + in_scope = substInScopeSet (se_subst env) + +-- Convenience function for invoking lookupRule from Specialise +-- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr] +specLookupRule :: HasDebugCallStack + => SpecEnv -> Id -> [CoreExpr] + -> (Activation -> Bool) -- Which rules are active + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) +specLookupRule env fn args is_active rules + | null rules + = Nothing -- Saves building a few thunks in the common case + | otherwise + = lookupRule ropts in_scope_env is_active fn args rules + where + dflags = se_dflags env + in_scope = substInScopeSet (se_subst env) + in_scope_env = ISE in_scope (whenActiveUnfoldingFun is_active) + ropts = initRuleOpts dflags + +{- Note [Specialising DFuns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DFuns have a special sort of unfolding (DFunUnfolding), and it is +hard to specialise a DFunUnfolding to give another DFunUnfolding +unless the DFun is fully applied (#18120). So, in the case of DFunIds +we simply extend the CallKey with trailing UnspecTypes/UnspecArgs, +so that we'll generate a rule that completely saturates the DFun. + +There is an ASSERT that checks this, in the DFunUnfolding case of +GHC.Core.Unfold.Make.specUnfolding. + +Note [Transfer IdDetails during specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising a function, `newSpecIdSM` comes up with a fresh Id the +specialised RHS will be bound to. It is critical that we get the `IdDetails` of +the specialised Id correct: + +* JoinId: We want the specialised Id to be a join point, too. But + we have to carefully adjust the arity + +* DFunId: It is crucial that we also make the new Id a DFunId. + - First, because it obviously /is/ a DFun, having a DFunUnfolding and + all that; see Note [Specialising DFuns] + + - Second, DFuns get very delicate special treatment in the demand analyser; + see GHC.Core.Opt.DmdAnal.enterDFun. If the specialised function isn't + also a DFunId, this special treatment doesn't happen, so the demand + analyser makes a too-strict DFun, and we get an infinite loop. See Note + [Do not strictify a DFun's parameter dictionaries] in GHC.Core.Opt.DmdAnal. + #22549 describes the loop, and (lower down) a case where a /specialised/ + DFun caused a loop. + +* WorkerLikeId: Introduced by WW, so after Specialise. Nevertheless, they come + up when specialising imports. We must keep them as VanillaIds because WW + will detect them as WorkerLikeIds again. That is, unless specialisation + allows unboxing of all previous CBV args, in which case sticking to + VanillaIds was the only correct choice to begin with. + +* RecSelId, DataCon*Id, ClassOpId, PrimOpId, FCallId, CoVarId, TickBoxId: + Never specialised. + +Note [Specialisation Must Preserve Sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a function: + + f :: forall a. Eq a => a -> blah + f = + if expensive + then f1 + else f2 + +As written, all calls to 'f' will share 'expensive'. But if we specialise 'f' +at 'Int', eg: + + $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2) + + RULE "SPEC f" + forall (d :: Eq Int). + f Int _ = $sfIntf + +We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes! + +To avoid this, we only generate specialisations for functions whose arity is +enough to bind all of the arguments we need to specialise. This ensures our +specialised functions don't do any work before receiving all of their dicts, +and thus avoids the 'f' case above. + +Note [Specialisations Must Be Lifted] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a function 'f': + + f = forall a. Eq a => Array# a + +used like + + case x of + True -> ...f @Int dEqInt... + False -> 0 + +Naively, we might generate an (expensive) specialisation + + $sfInt :: Array# Int + +even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to +the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to +preserve laziness. + +Note [Care with unlifted bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#22998) + f x = let x::ByteArray# = + n::Natural = NB x + in wombat @192827 (n |> co) +where + co :: Natural ~ KnownNat 192827 + wombat :: forall (n:Nat). KnownNat n => blah + +Left to itself, the specialiser would float the bindings for `x` and `n` to top +level, so we can specialise `wombat`. But we can't have a top-level ByteArray# +(see Note [Core letrec invariant] in GHC.Core). Boo. + +This is pretty exotic, so we take a simple way out: in specBind (the NonRec +case) do not float the binding itself unless it satisfies exprIsTopLevelBindable. +This is conservative: maybe the RHS of `x` has a free var that would stop it +floating to top level anyway; but that is hard to spot (since we don't know what +the non-top-level in-scope binders are) and rare (since the binding must satisfy +Note [Core let-can-float invariant] in GHC.Core). + + +Note [Specialising Calls] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a function with a complicated type: + + f :: forall a b c. Int -> Eq a => Show b => c -> Blah + f @a @b @c i dEqA dShowA x = blah + +and suppose it is called at: + + f @T1 @T2 @T3 7 dEqT1 ($dfShow dShowT2) t3 + +This call is described as a 'CallInfo' whose 'ci_key' is: + + [ SpecType T1, SpecType T2, UnspecType + , UnspecArg + , SpecDict dEqT1 + , SpecDict ($dfShow dShowT2) + , UnspecArg ] + +Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'? +Because we must specialise the function on type variables that appear +free in its *dictionary* arguments; but not on type variables that do not +appear in any dictionaries, i.e. are fully polymorphic. + +Because this call has dictionaries applied, we'd like to specialise +the call on any type argument that appears free in those dictionaries. +In this case, those are [a :-> T1, b :-> T2]. + +We also need to substitute the dictionary binders with their +specialised dictionaries. The simplest substitution would be +[dEqA :-> dEqT1, dShowA :-> $dfShow dShowT2], but this duplicates +work, since `$dfShow dShowT2` is a function application. Therefore, we +also want to *float the dictionary out* (via bindAuxiliaryDict), +creating a new dict binding + + dShow1 = $dfShow dShowT2 + +and the substitution [dEqA :-> dEqT1, dShowA :-> dShow1]. + +With the substitutions in hand, we can generate a specialised function: + + $sf :: forall c. Int -> c -> Blah + $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah) + +Note that the substitution is applied to the whole thing. This is +convenient, but just slightly fragile. Notably: + * There had better be no name clashes in a/b/c + +We must construct a rewrite rule: + + RULE "SPEC f @T1 @T2 _" + forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). + f @T1 @T2 @c i d1 d2 = $sf @c i + +In the rule, d1 and d2 are just wildcards, not used in the RHS. Note +additionally that 'x' isn't captured by this rule --- we bind only +enough etas in order to capture all of the *specialised* arguments. + +Note [Drop dead args from specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising a function, it’s possible some of the arguments may +actually be dead. For example, consider: + + f :: forall a. () -> Show a => a -> String + f x y = show y ++ "!" + +We might generate the following CallInfo for `f @Int`: + + [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg] + +Normally we’d include both the x and y arguments in the +specialisation, since we’re not specialising on either of them. But +that’s silly, since x is actually unused! So we might as well drop it +in the specialisation: + + $sf :: Int -> String + $sf y = show y ++ "!" + + {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-} + +This doesn’t save us much, since the arg would be removed later by +worker/wrapper, anyway, but it’s easy to do. + +Wrinkles + +* Note that we only drop dead arguments if: + 1. We don’t specialise on them. + 2. They come before an argument we do specialise on. + Doing the latter would require eta-expanding the RULE, which could + make it match less often, so it’s not worth it. Doing the former could + be more useful --- it would stop us from generating pointless + specialisations --- but it’s more involved to implement and unclear if + it actually provides much benefit in practice. + +* If the function has a stable unfolding, specHeader has to come up with + arguments to pass to that stable unfolding, when building the stable + unfolding of the specialised function: this is the last field in specHeader's + big result tuple. + + The right thing to do is to produce a LitRubbish; it should rapidly + disappear. Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let. + +Note [Specialisation modulo dictionary selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #19644, we discovered that the ClassOp/DFun rules from +Note [ClassOp/DFun selection] inhibit transitive specialisation. +Example, inspired by T17966: + + class C a where + m :: Show b => a -> b -> String + dummy :: a -> () -- Force a datatype dictionary representation + + instance C Int where + m a b = show a ++ show b + dummy _ = () + + f :: (C a, Show b) => a -> b -> String + f a b = m a b ++ "!" + {-# INLINABLE[0] f #-} + + main = putStrLn (f (42::Int) (True::Bool)) + +Here, we specialise `f` at `Int` and `Bool`, giving + + $dC = $fCInt + $dShow = GHC.Show.$fShowBool + $sf (a::Int) (b::Bool) = + ... (m @Int $dC @Bool $dShow a b) ... + +Here `m` is just a DictSel, so there is (apparently) nothing to specialise! +However, the next Simplifier run will expose the rewritten instance method: + + ... $fCInt_$cm @Bool $fShowBool a b ... + +where $fCInt_$cm is the instance method for `m` in `instance C Int`: + + $fCInt_$cm :: forall b. Show b => Int -> b -> String + $fCInt_$cm b d x y = show @Int $dShowInt x ++ show @b d y + +We want to specialise this! How? By doing the method-selection rewrite in +the Specialiser. Hence + +1. In the App case of 'specExpr', try to apply the ClassOp/DFun rule on the + head of the application, repeatedly, via 'fireRewriteRules'. +2. Attach an unfolding to freshly-bound dictionary ids such as `$dC` and + `$dShow` in `bindAuxiliaryDict`, so that we can exploit the unfolding + in 'fireRewriteRules' to do the ClassOp/DFun rewrite. + +NB: Without (2), (1) would be pointless, because 'lookupRule' wouldn't be able +to look into the RHS of `$dC` to see the DFun. + +Note [Zap occ info in rule binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we generate a specialisation RULE, we need to drop occurrence +info on the binders. If we don’t, things go wrong when we specialise a +function like + + f :: forall a. () -> Show a => a -> String + f x y = show y ++ "!" + +since we’ll generate a RULE like + + RULE "SPEC f @Int" forall x [Occ=Dead]. + f @Int x $dShow = $sf + +and Core Lint complains, even though x only appears on the LHS (due to +Note [Drop dead args from specialisations]). + +Why is that a Lint error? Because the arguments on the LHS of a rule +are syntactically expressions, not patterns, so Lint treats the +appearance of x as a use rather than a binding. Fortunately, the +solution is simple: we just make sure to zap the occ info before +using ids as wildcard binders in a rule. + +Note [Account for casts in binding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: Eq a => a -> IO () + {-# INLINABLE f + StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g + #-} + f = ... + +In f's stable unfolding we have done some modest simplification which +has pushed the cast to the outside. (I wonder if this is the Right +Thing, but it's what happens now; see GHC.Core.Opt.Simplify.Utils Note [Casts and +lambdas].) Now that stable unfolding must be specialised, so we want +to push the cast back inside. It would be terrible if the cast +defeated specialisation! Hence the use of collectBindersPushingCo. + +Note [Evidence foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (#12212) that we are specialising + f :: forall a b. (Num a, F a ~# F b) => blah +with a=b=Int. Then the RULE will be something like + RULE forall (d:Num Int) (g :: F Int ~# F Int). + f Int Int d g = f_spec +where that `g` is really (Coercion (CoVar g)), since `g` is a +coercion variable and can't appear as (Var g). + +But both varToCoreExpr (when constructing the LHS args), and the +simplifier (when simplifying the LHS args), will transform to + RULE forall (d:Num Int) (g :: F Int ~ F Int). + f Int Int d = f_spec +by replacing g with Refl. So now 'g' is unbound, which results in a later +crash. So we use Refl right off the bat, and do not forall-quantify 'g': + * varToCoreExpr generates a (Coercion Refl) + * exprsFreeIdsList returns the Ids bound by the args, + which won't include g + +You might wonder if this will match as often, but the simplifier replaces +complicated Refl coercions with Refl pretty aggressively. + +Note [Orphans and auto-generated rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise an INLINABLE function, or when we have +-fspecialise-aggressively, we auto-generate RULES that are orphans. +We don't want to warn about these, or we'd generate a lot of warnings. +Thus, we only warn about user-specified orphan rules. + +Indeed, we don't even treat the module as an orphan module if it has +auto-generated *rule* orphans. Orphan modules are read every time we +compile, so they are pretty obtrusive and slow down every compilation, +even non-optimised ones. (Reason: for type class instances it's a +type correctness issue.) But specialisation rules are strictly for +*optimisation* only so it's fine not to read the interface. + +What this means is that a SPEC rules from auto-specialisation in +module M will be used in other modules only if M.hi has been read for +some other reason, which is actually pretty likely. + +Note [From non-recursive to recursive] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in the non-recursive case, if any dict-binds depend on 'fn' we might +have built a recursive knot + + f a d x = + MkUD { ud_binds = NonRec d7 (MkD ..f..) + , ud_calls = ...(f T d7)... } + +The we generate + + Rec { fs x = [T/a, d7/d] + f a d x = + RULE f T _ = fs + d7 = ...f... } + +Here the recursion is only through the RULE. + +However we definitely should /not/ make the Rec in this wildly common +case: + d = ... + MkUD { ud_binds = NonRec d7 (...d...) + , ud_calls = ...(f T d7)... } + +Here we want simply to add d to the floats, giving + MkUD { ud_binds = NonRec d (...) + NonRec d7 (...d...) + , ud_calls = ...(f T d7)... } + +In general, we need only make this Rec if + - there are some specialisations (spec_binds non-empty) + - there are some dict_binds that depend on f (dump_dbs non-empty) + +Note [Avoiding loops (DFuns)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising /dictionary functions/ we must be very careful to +avoid building loops. Here is an example that bit us badly, on +several distinct occasions. + +Here is one: #3591 + class Eq a => C a + instance Eq [a] => C [a] + +This translates to + dfun :: Eq [a] -> C [a] + dfun a d = MkD a d (meth d) + + d4 :: Eq [T] = + d2 :: C [T] = dfun T d4 + d1 :: Eq [T] = $p1 d2 + d3 :: C [T] = dfun T d1 + +None of these definitions is recursive. What happened was that we +generated a specialisation: + RULE forall d. dfun T d = dT :: C [T] + dT = (MkD a d (meth d)) [T/a, d1/d] + = MkD T d1 (meth d1) + +But now we use the RULE on the RHS of d2, to get + d2 = dT = MkD d1 (meth d1) + d1 = $p1 d2 + +and now d1 is bottom! The problem is that when specialising 'dfun' we +should first dump "below" the binding all floated dictionary bindings +that mention 'dfun' itself. So d2 and d3 (and hence d1) must be +placed below 'dfun', and thus unavailable to it when specialising +'dfun'. That in turn means that the call (dfun T d1) must be +discarded. On the other hand, the call (dfun T d4) is fine, assuming +d4 doesn't mention dfun. + +Solution: + Discard all calls that mention dictionaries that depend + (directly or indirectly) on the dfun we are specialising. + This is done by 'filterCalls' + +Note [Avoiding loops (non-DFuns)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The whole Note [Avoiding loops (DFuns)] things applies only to DFuns. +It's important /not/ to apply filterCalls to non-DFuns. For example: + + class C a where { foo,bar :: [a] -> [a] } + + instance C Int where + foo x = r_bar x + bar xs = reverse xs + + r_bar :: C a => [a] -> [a] + r_bar xs = bar (xs ++ xs) + +That translates to: + + r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) + + Rec { $fCInt :: C Int = MkC foo_help reverse + foo_help (xs::[Int]) = r_bar Int $fCInt xs } + +The call (r_bar $fCInt) mentions $fCInt, + which mentions foo_help, + which mentions r_bar + +But we DO want to specialise r_bar at Int: + Rec { $fCInt :: C Int = MkC foo_help reverse + foo_help (xs::[Int]) = r_bar Int $fCInt xs + + r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) + RULE r_bar Int _ = r_bar_Int + + r_bar_Int xs = bar Int $fCInt (xs ++ xs) + } + +Note that, because of its RULE, r_bar joins the recursive +group. (In this case it'll unravel a short moment later.) +See test simplCore/should_compile/T19599a. + +Another example is #19599, which looked like this: + + class (Show a, Enum a) => MyShow a where + myShow :: a -> String + + myShow_impl :: MyShow a => a -> String + + foo :: Int -> String + foo = myShow_impl @Int $fMyShowInt + + Rec { $fMyShowInt = MkMyShowD $fEnumInt $fShowInt $cmyShow + ; $cmyShow = myShow_impl @Int $fMyShowInt } + +Here, we really do want to specialise `myShow_impl @Int $fMyShowInt`. + + +Note [Specialising a recursive group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let rec { f x = ...g x'... + ; g y = ...f y'.... } + in f 'a' +Here we specialise 'f' at Char; but that is very likely to lead to +a specialisation of 'g' at Char. We must do the latter, else the +whole point of specialisation is lost. + +But we do not want to keep iterating to a fixpoint, because in the +presence of polymorphic recursion we might generate an infinite number +of specialisations. + +So we use the following heuristic: + * Arrange the rec block in dependency order, so far as possible + (the occurrence analyser already does this) + + * Specialise it much like a sequence of lets + + * Then go through the block a second time, feeding call-info from + the RHSs back in the bottom, as it were + +In effect, the ordering maxmimises the effectiveness of each sweep, +and we do just two sweeps. This should catch almost every case of +monomorphic recursion -- the exception could be a very knotted-up +recursion with multiple cycles tied up together. + +This plan is implemented in the Rec case of specBindItself. + +Note [Specialisations already covered] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously don't want to generate two specialisations for the same +argument pattern. Wrinkles + +(SC1) We do the already-covered test in specDefn, not when we generate + the CallInfo in mkCallUDs. We used to test in the latter place, but + we now iterate the specialiser somewhat, and the Id at the call site + might therefore not have all the RULES that we can see in specDefn + +(SC2) What about two specialisations where the second is an *instance* + of the first? It's a bit arbitrary, but here's what we do: + * If the existing one is user-specified, via a SPECIALISE pragma, we + suppress the further specialisation. + * If the existing one is auto-generated, we generate a second RULE + for the more specialised version. + The latter is important because we don't want the accidental order + of calls to determine what specialisations we generate. + +(SC3) Annoyingly, we /also/ eliminate duplicates in `filterCalls`. + See (MP3) in Note [Specialising polymorphic dictionaries] + +Note [Auto-specialisation and RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + g :: Num a => a -> a + g = ... + + f :: (Int -> Int) -> Int + f w = ... + {-# RULE f g = 0 #-} + +Suppose that auto-specialisation makes a specialised version of +g::Int->Int. That version won't appear in the LHS of the RULE for f. +So if the specialisation rule fires too early, the rule for f may +never fire. + +It might be possible to add new rules, to "complete" the rewrite system. +Thus when adding + RULE forall d. g Int d = g_spec +also add + RULE f g_spec = 0 + +But that's a bit complicated. For now we ask the programmer's help, +by *copying the INLINE activation pragma* to the auto-specialised +rule. So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule +will also not be active until phase 2. And that's what programmers +should jolly well do anyway, even aside from specialisation, to ensure +that g doesn't inline too early. + +This in turn means that the RULE would never fire for a NOINLINE +thing so not much point in generating a specialisation at all. + +Note [Specialisation shape] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only specialise a function if it has visible top-level lambdas +corresponding to its overloading. E.g. if + f :: forall a. Eq a => .... +then its body must look like + f = /\a. \d. ... + +Reason: when specialising the body for a call (f ty dexp), we want to +substitute dexp for d, and pick up specialised calls in the body of f. + +We do allow casts, however; see Note [Account for casts in binding]. + +This doesn't always work. One example I came across was this: + newtype Gen a = MkGen{ unGen :: Int -> a } + + choose :: Eq a => a -> Gen a + choose n = MkGen (\r -> n) + + oneof = choose (1::Int) + +It's a silly example, but we get + choose = /\a. g `cast` co +where choose doesn't have any dict arguments. Thus far I have not +tried to fix this (wait till there's a real example). + +Mind you, then 'choose' will be inlined (since RHS is trivial) so +it doesn't matter. This comes up with single-method classes + + class C a where { op :: a -> a } + instance C a => C [a] where .... +==> + $fCList :: C a => C [a] + $fCList = $copList |> (...coercion>...) + ....(uses of $fCList at particular types)... + +So we suppress the WARN if the rhs is trivial. + +Note [Inline specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is what we do with the InlinePragma of the original function + + * Activation/RuleMatchInfo: both inherited from the original function + + * InlineSpec: inherit from original function + + * Unfolding: transfer a StableUnfolding iff it is UnfWhen + See GHC.Core.Unfold.Make.specUnfolding + and its Note [Specialising unfoldings] + +InlineSpec: you might wonder why we specialise INLINE functions at all. +After all they should be inlined, right? Two reasons: + + * Even INLINE functions are sometimes not inlined, when they aren't + applied to interesting arguments. But perhaps the type arguments + alone are enough to specialise (even though the args are too boring + to trigger inlining), and it's certainly better to call the + specialised version. + + * The RHS of an INLINE function might call another overloaded function, + and we'd like to generate a specialised version of that function too. + This actually happens a lot. Consider + replicateM_ :: (Monad m) => Int -> m a -> m () + {-# INLINABLE replicateM_ #-} + replicateM_ d x ma = ... + The strictness analyser may transform to + replicateM_ :: (Monad m) => Int -> m a -> m () + {-# INLINE replicateM_ #-} + replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma + + $wreplicateM_ :: (Monad m) => Int# -> m a -> m () + {-# INLINABLE $wreplicateM_ #-} + $wreplicateM_ = ... + Now an importing module has a specialised call to replicateM_, say + (replicateM_ dMonadIO). We certainly want to specialise $wreplicateM_! + This particular example had a huge effect on the call to replicateM_ + in nofib/shootout/n-body. +-} + +{- ********************************************************************* +* * + SpecArg, and specHeader +* * +********************************************************************* -} + +-- | An argument that we might want to specialise. +-- See Note [Specialising Calls] for the nitty gritty details. +data SpecArg + = + -- | Type arguments that should be specialised, due to appearing + -- free in the type of a 'SpecDict'. + SpecType Type + + -- | Type arguments that should remain polymorphic. + | UnspecType + + -- | Dictionaries that should be specialised. mkCallUDs ensures + -- that only "interesting" dictionary arguments get a SpecDict; + -- see Note [Interesting dictionary arguments] + | SpecDict DictExpr + + -- | Value arguments that should not be specialised. + | UnspecArg + +instance Outputable SpecArg where + ppr (SpecType t) = text "SpecType" <+> ppr t + ppr (SpecDict d) = text "SpecDict" <+> ppr d + ppr UnspecType = text "UnspecType" + ppr UnspecArg = text "UnspecArg" + +specArgsFVs :: InterestingVarFun -> [SpecArg] -> FV +-- Find the free vars of the SpecArgs that are not already in scope +specArgsFVs interesting args + = filterFV interesting $ + foldr (unionFV . get) emptyFV args + where + get :: SpecArg -> FV + get (SpecType ty) = tyCoFVsOfType ty + get (SpecDict dx) = exprFVs dx + get UnspecType = emptyFV + get UnspecArg = emptyFV + +isSpecDict :: SpecArg -> Bool +isSpecDict (SpecDict {}) = True +isSpecDict _ = False + +-- | Given binders from an original function 'f', and the 'SpecArg's +-- corresponding to its usage, compute everything necessary to build +-- a specialisation. +-- +-- We will use the running example from Note [Specialising Calls]: +-- +-- f :: forall a b c. Int -> Eq a => Show b => c -> Blah +-- f @a @b @c i dEqA dShowB x = blah +-- +-- Suppose we decide to specialise it at the following pattern: +-- +-- [ SpecType T1, SpecType T2, UnspecType, UnspecArg +-- , SpecDict dEqT1, SpecDict ($dfShow dShowT2), UnspecArg ] +-- +-- We'd eventually like to build the RULE +-- +-- RULE "SPEC f @T1 @T2 _" +-- forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). +-- f @T1 @T2 @c i d1 d2 = $sf @c i +-- +-- and the specialisation '$sf' +-- +-- $sf :: forall c. Int -> c -> Blah +-- $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowB :-> dShow1] (\@c i x -> blah) +-- +-- where dShow1 is a floated binding created by bindAuxiliaryDict. +-- +-- The cases for 'specHeader' below are presented in the same order as this +-- running example. The result of 'specHeader' for this example is as follows: +-- +-- ( -- Returned arguments +-- env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowB :-> dShow1] +-- , [x] +-- +-- -- RULE helpers +-- , [c, i, d1, d2] +-- , [T1, T2, c, i, d1, d2] +-- +-- -- Specialised function helpers +-- , [c, i, x] +-- , [dShow1 = $dfShow dShowT2] +-- , [T1, T2, c, i, dEqT1, dShow1] +-- ) +specHeader + :: Core.Subst -- This substitution applies to the [InBndr] + -> [InBndr] -- Binders from the original function `f` + -> [SpecArg] -- From the CallInfo + -> SpecM ( Bool -- True <=> some useful specialisation happened + -- Not the same as any (isSpecDict args) because + -- the args might be longer than bndrs + + , Core.Subst -- Apply this to the body + + -- RULE helpers + -- `RULE forall rule_bndrs. f rule_es = $sf spec_bndrs` + , [OutBndr] -- rule_bndrs: Binders for the RULE + , [OutExpr] -- rule_es: Args for the LHS of the rule + + -- Specialised function helpers + -- `$sf = \spec_bndrs. let { dx_binds } in spec_arg` + , [OutBndr] -- spec_bndrs: Binders for $sf, and args for the RHS + -- of the RULE. Subset of rule_bndrs. + , [DictBind] -- dx_binds: Auxiliary dictionary bindings + , [OutExpr] -- spec_args: Specialised arguments for unfolding + -- Same length as "Args for LHS of rule" + ) + +-- If we run out of binders, stop immediately +-- See Note [Specialisation Must Preserve Sharing] +specHeader subst [] _ = pure (False, subst, [], [], [], [], []) +specHeader subst _ [] = pure (False, subst, [], [], [], [], []) + +-- We want to specialise on type 'T1', and so we must construct a substitution +-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding +-- details. +specHeader subst (bndr:bndrs) (SpecType ty : args) + = do { let subst1 = Core.extendTvSubst subst bndr ty + ; (useful, subst2, rule_bs, rule_args, spec_bs, dx, spec_args) + <- specHeader subst1 bndrs args + ; pure ( useful, subst2 + , rule_bs, Type ty : rule_args + , spec_bs, dx, Type ty : spec_args ) } + +-- Next we have a type that we don't want to specialise. We need to perform +-- a substitution on it (in case the type refers to 'a'). Additionally, we need +-- to produce a binder, LHS argument and RHS argument for the resulting rule, +-- /and/ a binder for the specialised body. +specHeader subst (bndr:bndrs) (UnspecType : args) + = do { let (subst1, bndr') = Core.substBndr subst bndr + ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) + <- specHeader subst1 bndrs args + ; let ty_e' = Type (mkTyVarTy bndr') + ; pure ( useful, subst2 + , bndr' : rule_bs, ty_e' : rule_es + , bndr' : spec_bs, dx, ty_e' : spec_args ) } + +specHeader subst (bndr:bndrs) (_ : args) + | isDeadBinder bndr + , let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) + , Just rubbish_lit <- mkLitRubbish (idType bndr') + = -- See Note [Drop dead args from specialisations] + do { (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args + ; pure ( useful, subst2 + , bndr' : rule_bs, Var bndr' : rule_es + , spec_bs, dx, rubbish_lit : spec_args ) } + +-- Next we want to specialise the 'Eq a' dict away. We need to construct +-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for +-- the nitty-gritty), as a LHS rule and unfolding details. +specHeader subst (bndr:bndrs) (SpecDict dict_arg : args) + = do { -- Make up a fresh binder to use in the RULE + -- It might turn into a dict binding (via bindAuxiliaryDict) which we + -- then float, so we use cloneIdBndr to get a completely fresh binder + us <- getUniqueSupplyM + ; let (subst1, bndr') = Core.cloneIdBndr subst us (zapIdOccInfo bndr) + -- zapIdOccInfo: see Note [Zap occ info in rule binders] + + -- Extend the substitution to map bndr :-> dict_arg, for use in the RHS + ; let (subst2, dx_bind, spec_dict) = bindAuxiliaryDict subst1 bndr bndr' dict_arg + + ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst2 bndrs args + + ; let dx' = case dx_bind of { Nothing -> dx; Just d -> d : dx } + ; pure ( True, subst3 -- Ha! A useful specialisation! + , bndr' : rule_bs, Var bndr' : rule_es + , spec_bs, dx', spec_dict : spec_args ) } + +-- Finally, we don't want to specialise on this argument 'i': +-- We need to produce a binder, LHS and RHS argument for the RULE, and +-- a binder for the specialised body. +-- +-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is +-- why 'i' doesn't appear in our RULE above. But we have no guarantee that +-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so +-- this case must be here. +specHeader subst (bndr:bndrs) (UnspecArg : args) + = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) + -- zapIdOccInfo: see Note [Zap occ info in rule binders] + ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args + + ; let dummy_arg = varToCoreExpr bndr' + -- dummy_arg is usually just (Var bndr), + -- but if bndr :: t1 ~# t2, it'll be (Coercion (CoVar bndr)) + -- or even Coercion Refl (if t1=t2) + -- See Note [Evidence foralls] + bndrs = exprFreeIdsList dummy_arg + + ; pure ( useful, subst2 + , bndrs ++ rule_bs, dummy_arg : rule_es + , bndrs ++ spec_bs, dx, dummy_arg : spec_args ) } + + +-- | Binds a dictionary argument to a fresh name, to preserve sharing +bindAuxiliaryDict + :: Subst + -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression + -> ( Subst -- Substitutes for orig_dict_id + , Maybe DictBind -- Auxiliary dict binding, if any + , OutExpr) -- Witnessing expression (always trivial) +bindAuxiliaryDict subst orig_dict_id fresh_dict_id dict_arg + + -- If the dictionary argument is trivial, + -- don’t bother creating a new dict binding; just substitute + | exprIsTrivial dict_arg + , let subst' = Core.extendSubst subst orig_dict_id dict_arg + = -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $ + (subst', Nothing, dict_arg) + + | otherwise -- Non-trivial dictionary arg; make an auxiliary binding + , let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_arg + + dict_bind = mkDB (NonRec fresh_dict_id' dict_arg) + subst' = Core.extendSubst subst orig_dict_id (Var fresh_dict_id') + `Core.extendSubstInScope` fresh_dict_id' + -- Ensure the new unfolding is in the in-scope set + = -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $ + (subst', Just dict_bind, Var fresh_dict_id') + +addDictUnfolding :: Id -> CoreExpr -> Id +-- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting] +-- and Note [Specialisation modulo dictionary selectors] +addDictUnfolding id rhs + = id `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs + +{- +Note [Make the new dictionaries interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Important! We're going to substitute dx_id1 for d +and we want it to look "interesting", else we won't gather *any* +consequential calls. E.g. + f d = ...g d.... +If we specialise f for a call (f (dfun dNumInt)), we'll get +a consequent call (g d') with an auxiliary definition + d' = df dNumInt +We want that consequent call to look interesting; so we add an unfolding +in the dictionary Id. +-} + + +{- ********************************************************************* +* * + UsageDetails and suchlike +* * +********************************************************************* -} + +data UsageDetails + = MkUD { ud_binds :: !FloatedDictBinds + , ud_calls :: !CallDetails } + -- INVARIANT: suppose bs = fdb_bndrs ud_binds + -- Then 'calls' may *mention* 'bs', + -- but there should be no calls *for* bs + +data FloatedDictBinds -- See Note [Floated dictionary bindings] + = FDB { fdb_binds :: !(OrdList DictBind) + -- The order is important; + -- in ds1 `appOL` ds2, bindings in ds2 can depend on those in ds1 + + , fdb_bndrs :: !IdSet + } -- ^ The binders of 'fdb_binds'. + -- Caches a superset of the expression + -- `mkVarSet (bindersOfDictBinds fdb_binds))` + -- for later addition to an InScopeSet + +-- | A 'DictBind' is a binding along with a cached set containing its free +-- variables (both type variables and dictionaries). We need this set +-- in splitDictBinds, when filtering bindings to decide which are +-- captured by a binder +data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet } + +bindersOfDictBind :: DictBind -> [Id] +bindersOfDictBind = bindersOf . db_bind + +bindersOfDictBinds :: Foldable f => f DictBind -> [Id] +bindersOfDictBinds = bindersOfBinds . foldr ((:) . db_bind) [] + +{- Note [Floated dictionary bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We float out dictionary bindings for the reasons described under +"Dictionary floating" above. But not /just/ dictionary bindings. +Consider + + f :: Eq a => blah + f a d = rhs + + $c== :: T -> T -> Bool + $c== x y = ... + + $df :: Eq T + $df = Eq $c== ... + + gurgle = ...(f @T $df)... + +We gather the call info for (f @T $df), and we don't want to drop it +when we come across the binding for $df. So we add $df to the floats +and continue. But then we have to add $c== to the floats, and so on. +These all float above the binding for 'f', and now we can +successfully specialise 'f'. + +So the DictBinds in (ud_binds :: OrdList DictBind) may contain +non-dictionary bindings too. + +Note [Specialising polymorphic dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note June 2023: This has proved to be quite a tricky optimisation to get right +see (#23469, #23109, #21229, #23445) so it is now guarded by a flag +`-fpolymorphic-specialisation`. + +Consider + class M a where { foo :: a -> Int } + + instance M (ST s) where ... + -- dMST :: forall s. M (ST s) + + wimwam :: forall a. M a => a -> Int + wimwam = /\a \(d::M a). body + + f :: ST s -> Int + f = /\s \(x::ST s). wimwam @(ST s) (dMST @s) dx + 1 + +We'd like to specialise wimwam at (ST s), thus + $swimwam :: forall s. ST s -> Int + $swimwam = /\s. body[ST s/a, (dMST @s)/d] + + RULE forall s (d :: M (ST s)). + wimwam @(ST s) d = $swimwam @s + +Here are the moving parts: + +(MP1) We must /not/ dump the CallInfo + CIS wimwam (CI { ci_key = [@(ST s), dMST @s] + , ci_fvs = {dMST} }) + when we come to the /\s. Instead, we simply let it continue to float + upwards. Hence ci_fvs is an IdSet, listing the /Ids/ that + are free in the call, but not the /TyVars/. Hence using specArgFreeIds + in singleCall. + + NB to be fully kosher we should explicitly quantifying the CallInfo + over 's', but we don't bother. This would matter if there was an + enclosing binding of the same 's', which I don't expect to happen. + +(MP2) When we come to specialise the call, we must remember to quantify + over 's'. That is done in the SpecType case of specHeader, where + we add 's' (called qvars) to the binders of the RULE and the specialised + function. + +(MP3) If we have f :: forall m. Monoid m => blah, and two calls + (f @(Endo b) (d1 :: Monoid (Endo b)) + (f @(Endo (c->c)) (d2 :: Monoid (Endo (c->c))) + we want to generate a specialisation only for the first. The second + is just a substitution instance of the first, with no greater specialisation. + Hence the use of `removeDupCalls` in `filterCalls`. + + You might wonder if `d2` might be more specialised than `d1`; but no. + This `removeDupCalls` thing is at the definition site of `f`, and both `d1` + and `d2` are in scope. So `d1` is simply more polymorphic than `d2`, but + is just as specialised. + + This distinction is sadly lost once we build a RULE, so `alreadyCovered` + can't be so clever. E.g if we have an existing RULE + forall @a (d1:Ord Int) (d2: Eq a). f @a @Int d1 d2 = ... + and a putative new rule + forall (d1:Ord Int) (d2: Eq Int). f @Int @Int d1 d2 = ... + we /don't/ want the existing rule to subsume the new one. + + So we sadly put up with having two rather different places where we + eliminate duplicates: `alreadyCovered` and `removeDupCalls`. + +All this arose in #13873, in the unexpected form that a SPECIALISE +pragma made the program slower! The reason was that the specialised +function $sinsertWith arising from the pragma looked rather like `f` +above, and failed to specialise a call in its body like wimwam. +Without the pragma, the original call to `insertWith` was completely +monomorpic, and specialised in one go. + +Wrinkles. + +* See Note [Weird special case for SpecDict] + +* With -XOverlappingInstances you might worry about this: + class C a where ... + instance C (Maybe Int) where ... -- $df1 :: C (Maybe Int) + instance C (Maybe a) where ... -- $df2 :: forall a. C (Maybe a) + + f :: C a => blah + f = rhs + + g = /\a. ...(f @(Maybe a) ($df2 a))... + h = ...f @(Maybe Int) $df1 + + There are two calls to f, but with different evidence. This patch will + combine them into one. But it's OK: this code will never arise unless you + use -XIncoherentInstances. Even with -XOverlappingInstances, GHC tries hard + to keep dictionaries as singleton types. But that goes out of the window + with -XIncoherentInstances -- and that is true even with ordianry type-class + specialisation (at least if any inlining has taken place). + + GHC makes very few guarantees when you use -XIncoherentInstances, and its + not worth crippling the normal case for the incoherent corner. (The best + thing might be to switch off specialisation altogether if incoherence is + involved... but incoherence is a property of an instance, not a class, so + it's a hard test to make.) + + But see Note [Specialisation and overlapping instances]. + +Note [Weird special case for SpecDict] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are trying to specialise for this this call: + $wsplit @T (mkD @k @(a::k) :: C T) +where + mkD :: forall k (a::k). C T +is a top-level dictionary-former. This actually happened in #22459, +because of (MP1) of Note [Specialising polymorphic dictionaries]. + +How can we specialise $wsplit? We might try + + RULE "SPEC" forall (d :: C T). $wsplit @T d = $s$wsplit + +but then in the body of $s$wsplit what will we use for the dictionary +evidence? We can't use (mkD @k @(a::k)) because k and a aren't in scope. +We could zap `k` to (Any @Type) and `a` to (Any @(Any @Type)), but that +is a lot of hard work for a very strange case. + +So we simply refrain from specialising in this case; hence the guard + allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d) +in the SpecDict cased of specHeader. + +How did this strange polymorphic mkD arise in the first place? +From GHC.Core.Opt.Utils.abstractFloats, which was abstracting +over too many type variables. But that too is now fixed; +see Note [Which type variables to abstract over] in that module. +-} + +instance Outputable DictBind where + ppr (DB { db_bind = bind, db_fvs = fvs }) + = text "DB" <+> braces (sep [ text "fvs: " <+> ppr fvs + , text "bind:" <+> ppr bind ]) + +instance Outputable UsageDetails where + ppr (MkUD { ud_binds = dbs, ud_calls = calls }) + = text "MkUD" <+> braces (sep (punctuate comma + [text "binds" <+> equals <+> ppr dbs, + text "calls" <+> equals <+> ppr calls])) + +instance Outputable FloatedDictBinds where + ppr (FDB { fdb_binds = binds }) = ppr binds + +emptyUDs :: UsageDetails +emptyUDs = MkUD { ud_binds = emptyFDBs, ud_calls = emptyDVarEnv } + + +emptyFDBs :: FloatedDictBinds +emptyFDBs = FDB { fdb_binds = nilOL, fdb_bndrs = emptyVarSet } + +------------------------------------------------------------ +type CallDetails = DIdEnv CallInfoSet + -- The order of specialized binds and rules depends on how we linearize + -- CallDetails, so to get determinism we must use a deterministic set here. + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM + +data CallInfoSet = CIS Id (Bag CallInfo) + -- The list of types and dictionaries is guaranteed to + -- match the type of f + -- The Bag may contain duplicate calls (i.e. f @T and another f @T) + -- These dups are eliminated by alreadyCovered in specCalls + +data CallInfo + = CI { ci_key :: [SpecArg] -- Arguments of the call + -- See Note [The (CI-KEY) invariant] + + , ci_fvs :: IdSet -- Free Ids of the ci_key call + -- /not/ including the main id itself, of course + -- NB: excluding tyvars: + -- See Note [Specialising polymorphic dictionaries] + } + +{- Note [The (CI-KEY) invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant (CI-KEY): + In the `ci_key :: [SpecArg]` field of `CallInfo`, + * The list is non-empty + * The least element is always a `SpecDict` + +In this way the RULE has as few args as possible, which broadens its +applicability, since rules only fire when saturated. +-} + +type DictExpr = CoreExpr + +ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet +ciSetFilter p (CIS id a) = CIS id (filterBag p a) + +instance Outputable CallInfoSet where + ppr (CIS fn map) = hang (text "CIS" <+> ppr fn) + 2 (ppr map) + +pprCallInfo :: Id -> CallInfo -> SDoc +pprCallInfo fn (CI { ci_key = key }) + = ppr fn <+> ppr key + +instance Outputable CallInfo where + ppr (CI { ci_key = key, ci_fvs = _fvs }) + = text "CI" <> braces (sep (map ppr key)) + +unionCalls :: CallDetails -> CallDetails -> CallDetails +unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2 + +unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet +unionCallInfoSet (CIS f calls1) (CIS _ calls2) = + CIS f (calls1 `unionBags` calls2) + +callDetailsFVs :: CallDetails -> VarSet +callDetailsFVs calls = + nonDetStrictFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls + -- It's OK to use nonDetStrictFoldUDFM here because we forget the ordering + -- immediately by converting to a nondeterministic set. + +callInfoFVs :: CallInfoSet -> VarSet +callInfoFVs (CIS _ call_info) = + foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info + +getTheta :: [PiTyBinder] -> [PredType] +getTheta = fmap piTyBinderType . filter isInvisiblePiTyBinder . filter isAnonPiTyBinder + + +------------------------------------------------------------ +singleCall :: SpecEnv -> Id -> [SpecArg] -> UsageDetails +singleCall spec_env id args + = MkUD {ud_binds = emptyFDBs, + ud_calls = unitDVarEnv id $ CIS id $ + unitBag (CI { ci_key = args + , ci_fvs = fvVarSet call_fvs }) } + where + poly_spec = gopt Opt_PolymorphicSpecialisation (se_dflags spec_env) + + -- With -fpolymorphic-specialisation, keep just local /Ids/ + -- Otherwise, keep /all/ free vars including TyVars + -- See (MP1) in Note [Specialising polymorphic dictionaries] + -- But NB: we don't include the 'id' itself. + call_fvs | poly_spec = specArgsFVs isLocalId args + | otherwise = specArgsFVs isLocalVar args + +mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails +mkCallUDs env fun args + | (_, Var f) <- stripTicksTop tickishFloatable fun -- See Note [Ticks on applications] + = -- pprTraceWith "mkCallUDs" (\res -> vcat [ ppr f, ppr args, ppr res ]) $ + mkCallUDs' env f args + | otherwise + = emptyUDs + +mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails +mkCallUDs' env f args + | wantCallsFor env f -- We want it, and... + , not (null ci_key) -- this call site has a useful specialisation + = -- pprTrace "mkCallUDs: keeping" _trace_doc + singleCall env f ci_key + + | otherwise -- See also Note [Specialisations already covered] + = -- pprTrace "mkCallUDs: discarding" _trace_doc + emptyUDs + + where + _trace_doc = vcat [ppr f, ppr args, ppr ci_key] + pis = fst $ splitPiTys $ idType f + constrained_tyvars = tyCoVarsOfTypes $ getTheta pis + + ci_key :: [SpecArg] + ci_key = dropWhileEndLE (not . isSpecDict) $ + zipWith mk_spec_arg args pis + -- Establish (CI-KEY): drop trailing args until we get to a SpecDict + + mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg + mk_spec_arg (Type ty) (Named bndr) + | binderVar bndr `elemVarSet` constrained_tyvars + = SpecType ty + | otherwise + = UnspecType + mk_spec_arg non_type_arg (Named bndr) + = pprPanic "ci_key" $ (ppr non_type_arg $$ ppr bndr) + + -- For "invisibleFunArg", which are the type-class dictionaries, + -- we decide on a case by case basis if we want to specialise + -- on this argument; if so, SpecDict, if not UnspecArg + mk_spec_arg arg (Anon _pred af) + | isInvisibleFunArg af + , interestingDict env arg + -- See Note [Interesting dictionary arguments] + = SpecDict arg + + | otherwise = UnspecArg + +wantCallsFor :: SpecEnv -> Id -> Bool +-- See Note [wantCallsFor] +wantCallsFor _env f + = case idDetails f of + RecSelId {} -> False + DataConWorkId {} -> False + DataConWrapId {} -> False + ClassOpId {} -> False + PrimOpId {} -> False + FCallId {} -> False + TickBoxOpId {} -> False + CoVarId {} -> False + + DFunId {} -> True + VanillaId {} -> True + JoinId {} -> True + WorkerLikeId {} -> True + RepPolyId {} -> True + +interestingDict :: SpecEnv -> CoreExpr -> Bool +-- This is a subtle and important function +-- See Note [Interesting dictionary arguments] +interestingDict env (Var v) -- See (ID3) and (ID5) + | Just rhs <- maybeUnfoldingTemplate (idUnfolding v) + -- Might fail for loop breaker dicts but that seems fine. + = interestingDict env rhs + +interestingDict env arg -- Main Plan: use exprIsConApp_maybe + | Cast inner_arg _ <- arg -- See (ID5) + = if | isConstraintKind $ typeKind $ exprType inner_arg + -- If coercions were always homo-kinded, we'd know + -- that this would be the only case + -> interestingDict env inner_arg + + -- Check for an implicit parameter at the top + | Just (cls,_) <- getClassPredTys_maybe arg_ty + , isIPClass cls -- See (ID5) + -> False + + -- Otherwise we are unwrapping a unary type class + | otherwise + -> exprIsHNF arg -- See (ID7) + + | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg + , Just cls <- tyConClass_maybe (dataConTyCon data_con) + , definitely_not_ip_like -- See (ID4) + = if null (classMethods cls) -- See (ID6) + then any (interestingDict env) args + else True + + | otherwise + = not (exprIsTrivial arg) && definitely_not_ip_like -- See (ID8) + where + arg_ty = exprType arg + definitely_not_ip_like = not (couldBeIPLike arg_ty) + in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding + +{- Note [Ticks on applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticks such as source location annotations can sometimes make their way +onto applications (see e.g. #21697). So if we see something like + + App (Tick _ f) e + +we need to descend below the tick to find what the real function being +applied is. + +The resulting RULE also has to be able to match this annotated use +site, so we only look through ticks that RULE matching looks through +(see Note [Tick annotations in RULE matching] in GHC.Core.Rules). + +Note [wantCallsFor] +~~~~~~~~~~~~~~~~~~~ +`wantCallsFor env f` says whether the Specialiser should collect calls for +function `f`; other thing being equal, the fewer calls we collect the better. It +is False for things we can't specialise: + +* ClassOpId: never inline and we don't have a defn to specialise; we specialise + them through fireRewriteRules. +* PrimOpId: are never overloaded +* Data constructors: we never specialise them + +We could reduce the size of the UsageDetails by being less eager about +collecting calls for some LocalIds: there is no point for ones that are +lambda-bound. We can't decide this by looking at the (absence of an) unfolding, +because unfoldings for local functions are discarded by cloneBindSM, so no local +binder will have an unfolding at this stage. We'd have to keep a candidate set +of let-binders. + +Not many lambda-bound variables have dictionary arguments, so this would make +little difference anyway. + +For imported Ids we could check for an unfolding, but we have to do so anyway in +canSpecImport, and it seems better to have it all in one place. So we simply +collect usage info for imported overloaded functions. + +Note [Interesting dictionary arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + \a.\d:Eq a. let f = ... in ...(f d)... +There really is not much point in specialising f wrt the dictionary d, +because the code for the specialised f is not improved at all, because +d is lambda-bound. We simply get junk specialisations. + +What is "interesting"? Our Main Plan is to use `exprIsConApp_maybe` to see +if the argument is a dictionary constructor applied to some arguments, in which +case we can clearly specialise. But there are wrinkles: + +(ID1) Note that we look at the argument /term/, not its /type/. Suppose the + argument is + (% d1, d2 %) |> co + where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family. + Then its type (F Int a) looks very un-informative, but the term is super + helpful. See #19747 (where missing this point caused a 70x slow down) + and #7785. + +(ID2) Note that the Main Plan works fine for an argument that is a DFun call, + e.g. $fOrdList $dOrdInt + because `exprIsConApp_maybe` cleverly deals with DFunId applications. Good! + +(ID3) For variables, we look in the variable's /unfolding/. And that means + that we must be careful to ensure that dictionaries /have/ unfoldings: + * cloneBndrSM discards non-Stable unfoldings + * specBind updates the unfolding after specialisation + See Note [Update unfolding after specialisation] + * bindAuxiliaryDict adds an unfolding for an aux dict + see Note [Specialisation modulo dictionary selectors] + * specCase adds unfoldings for the new bindings it creates + + We accidentally lost accurate tracking of local variables for a long + time, because cloned variables didn't have unfoldings. But makes a + massive difference in a few cases, eg #5113. For nofib as a + whole it's only a small win: 2.2% improvement in allocation for ansi, + 1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. + +(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains + an implicit parameter, because implicit parameters are emphatically not singleton + types. See #25999: + useImplicit :: (?i :: Int) => Int + useImplicit = ?i + 1 + + foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit) + Both calls to `useImplicit` are at type `?i::Int`, but they pass different values. + We must not specialise on implicit parameters! Hence the call to `couldBeIPLike` + in `definitely_not_ip_like`. + +(ID5) Suppose the argument is (e |> co). Can we rely on `exprIsConApp_maybe` to deal + with the coercion. No! That only works if (co :: C t1 ~ C t2) with the same type + constructor at the top of both sides. But see the example in (ID1), where that + is not true. For the same reason, we can't rely on `exprIsConApp_maybe` to look + through unfoldings (because there might be a cast inside), hence dealing with + expandable unfoldings in `interestingDict` directly. + + For the same reasons as in (ID4), we must take care to not allow an implicit + parameter to sneak through, so we must not unwrap the newtype cast for the + unary IP class; hence the `isIPClass` call. (We don't need to call + `couldBeIPLike`, as implicit parameters hidden behind a type family are + detected by the recursive call to `interestingDict` on the argument inside the + cast.) + +(ID6) The Main Plan says that it's worth specialising if the argument is an application + of a dictionary contructor. But what if the dictionary has no methods? Then we + gain nothing by specialising, unless the /superclasses/ are interesting. A case + in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class + with N superclasses and no methods. + +(ID7) A unary (single-method) class is currently represented by (meth |> co). We + will unwrap the cast (see (ID5)) and then want to reply "yes" if the method + has any struture. We rather arbitrarily use `exprIsHNF` for this. (We plan a + new story for unary classes, see #23109, and this special case will become + irrelevant.) + +(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a + non-trivial argument as interesting. In T19695 we have this: + askParams :: Monad m => blah + mhelper :: MonadIO m => blah + mhelper (d:MonadIO m) = ...(askParams @m ($p1 d)).... + where `$p1` is the superclass selector for `MonadIO`. Now, if `mhelper` is + specialised at `Handler` we'll get this call in the specialised `$smhelper`: + askParams @Handler ($p1 $fMonadIOHandler) + and we /definitely/ want to specialise that, even though the argument isn't + visibly a dictionary application. In fact the specialiser fires the superclass + selector rule (see Note [Fire rules in the specialiser]), so we get + askParams @Handler ($cp1MonadIO $fMonadIOIO) + but it /still/ doesn't look like a dictionary application. + + Conclusion: we optimistically assume that any non-trivial argument is worth + specialising on. + + So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look + under type-family casts (ID1) and constraint tuples (ID6). + +Note [Update unfolding after specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#21848) + + wombat :: Show b => Int -> b -> String + wombat a b | a>0 = wombat (a-1) b + | otherwise = show a ++ wombat a b + + class C a where + meth :: Show b => a -> b -> String + dummy :: a -> () -- Force a datatype dictionary representation + + instance C Int where + meth = wombat + dummy _ = () + + class C a => D a -- D has C as a superclass + instance D Int + + f :: (D a, Show b) => a -> b -> String + {-# INLINABLE[0] f #-} + f a b = meth a b ++ "!" ++ meth a b + +Now `f` turns into: + + f @a @b (dd :: D a) (ds :: Show b) a b + + = let dc :: D a = %p1 dd -- Superclass selection + in meth @a dc .... + meth @a dc .... + +When we specialise `f`, at a=Int say, that superclass selection can +fire (via rewiteClassOps), but that info (that 'dc' is now a +particular dictionary `C`, of type `C Int`) must be available to +the call `meth @a dc`, so that we can fire the `meth` class-op, and +thence specialise `wombat`. + +We deliver on this idea by updating the unfolding for the binder +in the NonRec case of specBind. (This is too exotic to trouble with +the Rec case.) +-} + +thenUDs :: UsageDetails -> UsageDetails -> UsageDetails +thenUDs (MkUD {ud_binds = db1, ud_calls = calls1}) + (MkUD {ud_binds = db2, ud_calls = calls2}) + = MkUD { ud_binds = db1 `thenFDBs` db2 + , ud_calls = calls1 `unionCalls` calls2 } + +thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds +-- Combine FloatedDictBinds +-- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa +thenFDBs (FDB { fdb_binds = dbs1, fdb_bndrs = bs1 }) + (FDB { fdb_binds = dbs2, fdb_bndrs = bs2 }) + = FDB { fdb_binds = dbs1 `appOL` dbs2 + , fdb_bndrs = bs1 `unionVarSet` bs2 } + +----------------------------- +_dictBindBndrs :: OrdList DictBind -> [Id] +_dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs + +-- | Construct a 'DictBind' from a 'CoreBind' +mkDB :: CoreBind -> DictBind +mkDB bind = DB { db_bind = bind, db_fvs = bind_fvs bind } + +-- | Identify the free variables of a 'CoreBind' +bind_fvs :: CoreBind -> VarSet +bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) +bind_fvs (Rec prs) = rhs_fvs `delVarSetList` (map fst prs) + where + rhs_fvs = unionVarSets (map pair_fvs prs) + +pair_fvs :: (Id, CoreExpr) -> VarSet +pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs + `unionVarSet` idFreeVars bndr + -- idFreeVars: don't forget variables mentioned in + -- the rules of the bndr. C.f. OccAnal.addRuleUsage + -- Also tyvars mentioned in its type; they may not appear + -- in the RHS + -- type T a = Int + -- x :: T a = 3 + where + interesting :: InterestingVarFun + interesting v = isLocalVar v || (isId v && isDFunId v) + -- Very important: include DFunIds /even/ if it is imported + -- Reason: See Note [Avoiding loops in specImports], the #13429 + -- example involving an imported dfun. We must know + -- whether a dictionary binding depends on an imported + -- DFun in case we try to specialise that imported DFun + +-- | Flatten a set of "dumped" 'DictBind's, and some other binding +-- pairs, into a single recursive binding. +recWithDumpedDicts :: [(Id,CoreExpr)] -> OrdList DictBind -> DictBind +recWithDumpedDicts pairs dbs + = DB { db_bind = Rec bindings + , db_fvs = fvs `delVarSetList` map fst bindings } + where + (bindings, fvs) = foldr add ([], emptyVarSet) + (dbs `snocOL` mkDB (Rec pairs)) + add (DB { db_bind = bind, db_fvs = fvs }) (prs_acc, fvs_acc) + = case bind of + NonRec b r -> ((b,r) : prs_acc, fvs') + Rec prs1 -> (prs1 ++ prs_acc, fvs') + where + fvs' = fvs_acc `unionVarSet` fvs + +snocDictBind :: UsageDetails -> DictBind -> UsageDetails +snocDictBind uds@MkUD{ud_binds= FDB { fdb_binds = dbs, fdb_bndrs = bs }} db + = uds { ud_binds = FDB { fdb_binds = dbs `snocOL` db + , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } } + +snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails +-- Add ud_binds to the tail end of the bindings in uds +snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs + = uds { ud_binds = FDB { fdb_binds = binds `appOL` (toOL dbs) + , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } } + +consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails +consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}} + = uds { ud_binds = FDB{ fdb_binds = toOL dbs `appOL` binds + , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } } + +wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind] +wrapDictBinds (FDB { fdb_binds = dbs }) binds + = foldr add binds dbs + where + add (DB { db_bind = bind }) binds = bind : binds + +wrapDictBindsE :: OrdList DictBind -> CoreExpr -> CoreExpr +wrapDictBindsE dbs expr + = foldr add expr dbs + where + add (DB { db_bind = bind }) expr = Let bind expr + +---------------------- +dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind) +-- Used at a lambda or case binder; just dump anything mentioning the binder +dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + | null bndrs = (uds, nilOL) -- Common in case alternatives + | otherwise = -- pprTrace "dumpUDs" (vcat + -- [ text "bndrs" <+> ppr bndrs + -- , text "uds" <+> ppr uds + -- , text "free_uds" <+> ppr free_uds + -- , text "dump-dbs" <+> ppr dump_dbs ]) $ + (free_uds, dump_dbs) + where + free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls } + bndr_set = mkVarSet bndrs + (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor + deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be + -- no calls for any of the dicts in dump_dbs + +dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind, Bool) +-- Used at a let(rec) binding. +-- We return a boolean indicating whether the binding itself is mentioned, +-- directly or indirectly, by any of the ud_calls; in that case we want to +-- float the binding itself; +-- See Note [Floated dictionary bindings] +dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs $$ ppr float_all) $ + (free_uds, dump_dbs, float_all) + where + free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } + bndr_set = mkVarSet bndrs + (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_calls = deleteCallsFor bndrs orig_calls + float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls + +callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) +callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls } + = -- pprTrace ("callsForMe") + -- (vcat [ppr fn, + -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), + -- text "Orig calls =" <+> ppr orig_calls, + -- text "Calls for me =" <+> ppr calls_for_me]) $ + (uds_without_me, calls_for_me) + where + uds_without_me = uds { ud_calls = delDVarEnv orig_calls fn } + calls_for_me = case lookupDVarEnv orig_calls fn of + Nothing -> [] + Just cis -> filterCalls cis orig_dbs + +---------------------- +filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo] +-- Remove +-- (a) dominated calls: (MP3) in Note [Specialising polymorphic dictionaries] +-- (b) loopy DFuns: Note [Avoiding loops (DFuns)] +filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs }) + | isDFunId fn = filter ok_call de_dupd_calls -- Deals with (b) + | otherwise = de_dupd_calls + where + de_dupd_calls = removeDupCalls call_bag -- Deals with (a) + + dump_set = foldl' go (unitVarSet fn) dbs + -- This dump-set could also be computed by splitDictBinds + -- (_,_,dump_set) = splitDictBinds dbs {fn} + -- But this variant is shorter + + go so_far (DB { db_bind = bind, db_fvs = fvs }) + | fvs `intersectsVarSet` so_far + = extendVarSetList so_far (bindersOf bind) + | otherwise = so_far + + ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set + +removeDupCalls :: Bag CallInfo -> [CallInfo] +-- Calls involving more generic instances beat more specific ones. +-- See (MP3) in Note [Specialising polymorphic dictionaries] +removeDupCalls calls = foldr add [] calls + where + add :: CallInfo -> [CallInfo] -> [CallInfo] + add ci [] = [ci] + add ci1 (ci2:cis) | ci2 `beats_or_same` ci1 = ci2:cis + | ci1 `beats_or_same` ci2 = ci1:cis + | otherwise = ci2 : add ci1 cis + +beats_or_same :: CallInfo -> CallInfo -> Bool +-- (beats_or_same ci1 ci2) is True if specialising on ci1 subsumes ci2 +-- That is: ci1's types are less specialised than ci2 +-- ci1 specialises on the same dict args as ci2 +beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 }) + = go args1 args2 + where + go [] [] = True + go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2 + + -- If one or the other runs dry, the other must still have a SpecDict + -- because of the (CI-KEY) invariant. So neither subsumes the other; + -- one is more specialised (faster code) but the other is more generally + -- applicable. + go _ _ = False + + go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2) + go_arg (SpecDict {}) (SpecDict {}) = True + go_arg UnspecType UnspecType = True + go_arg UnspecArg UnspecArg = True + go_arg _ _ = False + +---------------------- +splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet) +-- splitDictBinds dbs bndrs returns +-- (free_dbs, dump_dbs, dump_set) +-- where +-- * dump_dbs depends, transitively on bndrs +-- * free_dbs does not depend on bndrs +-- * dump_set = bndrs `union` bndrs(dump_dbs) +splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set + = (FDB { fdb_binds = free_dbs + , fdb_bndrs = bs `minusVarSet` dump_set } + , dump_dbs, dump_set) + where + (free_dbs, dump_dbs, dump_set) + = foldl' split_db (nilOL, nilOL, bndr_set) dbs + -- Important that it's foldl' not foldr; + -- we're accumulating the set of dumped ids in dump_set + + split_db (free_dbs, dump_dbs, dump_idset) db + | DB { db_bind = bind, db_fvs = fvs } <- db + , dump_idset `intersectsVarSet` fvs -- Dump it + = (free_dbs, dump_dbs `snocOL` db, + extendVarSetList dump_idset (bindersOf bind)) + + | otherwise -- Don't dump it + = (free_dbs `snocOL` db, dump_dbs, dump_idset) + + +---------------------- +deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails +-- Remove calls mentioning any Id in bndrs +-- NB: The call is allowed to mention TyVars in bndrs +-- Note [Specialising polymorphic dictionaries] +-- ci_fvs are just the free /Ids/ +deleteCallsMentioning bndrs calls + = mapDVarEnv (ciSetFilter keep_call) calls + where + keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bndrs + +deleteCallsFor :: [Id] -> CallDetails -> CallDetails +-- Remove calls *for* bndrs +deleteCallsFor bndrs calls = delDVarEnvList calls bndrs + +{- +************************************************************************ +* * +\subsubsection{Boring helper functions} +* * +************************************************************************ +-} + +type SpecM a = UniqSM a + +runSpecM :: SpecM a -> CoreM a +runSpecM thing_inside + = do { us <- getUniqueSupplyM + ; return (initUs_ us thing_inside) } + +mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) +mapAndCombineSM _ [] = return ([], emptyUDs) +mapAndCombineSM f (x:xs) = do (y, uds1) <- f x + (ys, uds2) <- mapAndCombineSM f xs + return (y:ys, uds1 `thenUDs` uds2) + +-- extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv +-- extendTvSubst env tv ty +-- = env { se_subst = Core.extendTvSubst (se_subst env) tv ty } + +extendInScope :: SpecEnv -> OutId -> SpecEnv +extendInScope env@(SE { se_subst = subst }) bndr + = env { se_subst = subst `Core.extendSubstInScope` bndr } + +zapSubst :: SpecEnv -> SpecEnv +zapSubst env@(SE { se_subst = subst }) + = env { se_subst = Core.zapSubst subst } + +substTy :: SpecEnv -> Type -> Type +substTy env ty = substTyUnchecked (se_subst env) ty + +substCo :: SpecEnv -> Coercion -> Coercion +substCo env co = Core.substCo (se_subst env) co + +substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr) +substBndr env bs = case Core.substBndr (se_subst env) bs of + (subst', bs') -> (env { se_subst = subst' }, bs') + +substBndrs :: Traversable f => SpecEnv -> f CoreBndr -> (SpecEnv, f CoreBndr) +substBndrs env bs = case Core.substBndrs (se_subst env) bs of + (subst', bs') -> (env { se_subst = subst' }, bs') + +cloneBndrSM :: SpecEnv -> Id -> SpecM (SpecEnv, Id) +-- Clone the binders of the bind; return new bind with the cloned binders +-- Return the substitution to use for RHSs, and the one to use for the body +-- Discards non-Stable unfoldings +cloneBndrSM env@(SE { se_subst = subst }) bndr + = do { us <- getUniqueSupplyM + ; let (subst', bndr') = Core.cloneIdBndr subst us bndr + ; return (env { se_subst = subst' }, bndr') } + +cloneRecBndrsSM :: SpecEnv -> [Id] -> SpecM (SpecEnv, [Id]) +cloneRecBndrsSM env@(SE { se_subst = subst }) bndrs + = do { (subst', bndrs') <- Core.cloneRecIdBndrsM subst bndrs + ; let env' = env { se_subst = subst' } + ; return (env', bndrs') } + +newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id + -- Give the new Id a similar occurrence name to the old one +newSpecIdSM old_name new_ty details info + = do { uniq <- getUniqueM + ; let new_occ = mkSpecOcc (nameOccName old_name) + new_name = mkInternalName uniq new_occ (getSrcSpan old_name) + ; return (assert (not (isCoVarType new_ty)) $ + mkLocalVar details new_name ManyTy new_ty info) } + +{- + Old (but interesting) stuff about unboxed bindings + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +What should we do when a value is specialised to a *strict* unboxed value? + + map_*_* f (x:xs) = let h = f x + t = map f xs + in h:t + +Could convert let to case: + + map_*_Int# f (x:xs) = case f x of h# -> + let t = map f xs + in h#:t + +This may be undesirable since it forces evaluation here, but the value +may not be used in all branches of the body. In the general case this +transformation is impossible since the mutual recursion in a letrec +cannot be expressed as a case. + +There is also a problem with top-level unboxed values, since our +implementation cannot handle unboxed values at the top level. + +Solution: Lift the binding of the unboxed value and extract it when it +is used: + + map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h# + t = map f xs + in case h of + _Lift h# -> h#:t + +Now give it to the simplifier and the _Lifting will be optimised away. + +The benefit is that we have given the specialised "unboxed" values a +very simple lifted semantics and then leave it up to the simplifier to +optimise it --- knowing that the overheads will be removed in nearly +all cases. + +In particular, the value will only be evaluated in the branches of the +program which use it, rather than being forced at the point where the +value is bound. For example: + + filtermap_*_* p f (x:xs) + = let h = f x + t = ... + in case p x of + True -> h:t + False -> t + ==> + filtermap_*_Int# p f (x:xs) + = let h = case (f x) of h# -> _Lift h# + t = ... + in case p x of + True -> case h of _Lift h# + -> h#:t + False -> t + +The binding for h can still be inlined in the one branch and the +_Lifting eliminated. + + +Question: When won't the _Lifting be eliminated? + +Answer: When they at the top-level (where it is necessary) or when +inlining would duplicate work (or possibly code depending on +options). However, the _Lifting will still be eliminated if the +strictness analyser deems the lifted binding strict. +-} diff --git a/GHC/Core/Opt/StaticArgs.hs b/GHC/Core/Opt/StaticArgs.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/StaticArgs.hs @@ -0,0 +1,437 @@ + + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +************************************************************************ + + Static Argument Transformation pass + +************************************************************************ + +May be seen as removing invariants from loops: +Arguments of recursive functions that do not change in recursive +calls are removed from the recursion, which is done locally +and only passes the arguments which effectively change. + +Example: +map = /\ ab -> \f -> \xs -> case xs of + [] -> [] + (a:b) -> f a : map f b + +as map is recursively called with the same argument f (unmodified) +we transform it to + +map = /\ ab -> \f -> \xs -> let map' ys = case ys of + [] -> [] + (a:b) -> f a : map' b + in map' xs + +Notice that for a compiler that uses lambda lifting this is +useless as map' will be transformed back to what map was. + +We could possibly do the same for big lambdas, but we don't as +they will eventually be removed in later stages of the compiler, +therefore there is no penalty in keeping them. + +We only apply the SAT when the number of static args is > 2. This +produces few bad cases. See + should_transform +in saTransform. + +Here are the headline nofib results: + Size Allocs Runtime +Min +0.0% -13.7% -21.4% +Max +0.1% +0.0% +5.4% +Geometric Mean +0.0% -0.2% -6.9% + +The previous patch, to fix polymorphic floatout demand signatures, is +essential to make this work well! +-} + +module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCo.Compare( eqType ) + +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Var.Env +import GHC.Types.Unique.Supply +import GHC.Types.Unique.FM +import GHC.Types.Var.Set +import GHC.Types.Unique +import GHC.Types.Unique.Set + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.List (mapAccumL) +import GHC.Data.FastString + +doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram +doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds + where + sat_bind_threaded_us us bind = + let (us1, us2) = splitUniqSupply us + in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet)) + +-- We don't bother to SAT recursive groups since it can lead +-- to massive code expansion: see Andre Santos' thesis for details. +-- This means we only apply the actual SAT to Rec groups of one element, +-- but we want to recurse into the others anyway to discover other binds +satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo) +satBind (NonRec binder expr) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (NonRec binder expr', finalizeApp expr_app sat_info_expr) +satBind (Rec [(binder, rhs)]) interesting_ids = do + let interesting_ids' = interesting_ids `addOneToUniqSet` binder + (rhs_binders, rhs_body) = collectBinders rhs + (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids' + let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders) + sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body + + shadowing = binder `elementOfUniqSet` interesting_ids + sat_info_rhs'' = if shadowing + then sat_info_rhs' `delFromUFM` binder -- For safety + else sat_info_rhs' + + bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder) + rhs_binders rhs_body' + return (bind', sat_info_rhs'') +satBind (Rec pairs) interesting_ids = do + let (binders, rhss) = unzip pairs + rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss + let (rhss', sat_info_rhss') = unzip rhss_SATed + return (Rec (zipEqual binders rhss'), mergeIdSATInfos sat_info_rhss') + +data App = VarApp Id | TypeApp Type | CoApp Coercion +data Staticness a = Static a | NotStatic + +type IdAppInfo = (Id, SATInfo) + +type SATInfo = [Staticness App] +type IdSATInfo = IdEnv SATInfo +emptyIdSATInfo :: IdSATInfo +emptyIdSATInfo = emptyUFM + +{- +pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info)) + where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info) +-} + +pprSATInfo :: SATInfo -> SDoc +pprSATInfo staticness = hcat $ map pprStaticness staticness + +pprStaticness :: Staticness App -> SDoc +pprStaticness (Static (VarApp _)) = text "SV" +pprStaticness (Static (TypeApp _)) = text "ST" +pprStaticness (Static (CoApp _)) = text "SC" +pprStaticness NotStatic = text "NS" + + +mergeSATInfo :: SATInfo -> SATInfo -> SATInfo +mergeSATInfo l r = zipWith mergeSA l r + where + mergeSA NotStatic _ = NotStatic + mergeSA _ NotStatic = NotStatic + mergeSA (Static (VarApp v)) (Static (VarApp v')) + | v == v' = Static (VarApp v) + | otherwise = NotStatic + mergeSA (Static (TypeApp t)) (Static (TypeApp t')) + | t `eqType` t' = Static (TypeApp t) + | otherwise = NotStatic + mergeSA (Static (CoApp c)) (Static (CoApp c')) + | c `eqCoercion` c' = Static (CoApp c) + | otherwise = NotStatic + mergeSA _ _ = pprPanic "mergeSATInfo" $ + text "Left:" + <> pprSATInfo l <> text ", " + <> text "Right:" + <> pprSATInfo r + +mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo +mergeIdSATInfo = plusUFM_C mergeSATInfo + +mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo +mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo + +bindersToSATInfo :: [Id] -> SATInfo +bindersToSATInfo vs = map (Static . binderToApp) vs + where binderToApp v | isId v = VarApp v + | isTyVar v = TypeApp $ mkTyVarTy v + | otherwise = CoApp $ mkCoVarCo v + +finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo +finalizeApp Nothing id_sat_info = id_sat_info +finalizeApp (Just (v, sat_info')) id_sat_info = + let sat_info'' = case lookupUFM id_sat_info v of + Nothing -> sat_info' + Just sat_info -> mergeSATInfo sat_info sat_info' + in extendVarEnv id_sat_info v sat_info'' + +satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo) +satTopLevelExpr expr interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (expr', finalizeApp expr_app sat_info_expr) + +satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) +satExpr var@(Var v) interesting_ids = do + let app_info = if v `elementOfUniqSet` interesting_ids + then Just (v, []) + else Nothing + return (var, emptyIdSATInfo, app_info) + +satExpr lit@(Lit _) _ = + return (lit, emptyIdSATInfo, Nothing) + +satExpr (Lam binders body) interesting_ids = do + (body', sat_info, this_app) <- satExpr body interesting_ids + return (Lam binders body', finalizeApp this_app sat_info, Nothing) + +satExpr (App fn arg) interesting_ids = do + (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids + let satRemainder = boring fn' sat_info_fn + case fn_app of + Nothing -> satRemainder Nothing + Just (fn_id, fn_app_info) -> + -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface) + let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness]) + in case arg of + Type t -> satRemainderWithStaticness $ Static (TypeApp t) + Coercion c -> satRemainderWithStaticness $ Static (CoApp c) + Var v -> satRemainderWithStaticness $ Static (VarApp v) + _ -> satRemainderWithStaticness $ NotStatic + where + boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) + boring fn' sat_info_fn app_info = + do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids + let sat_info_arg' = finalizeApp arg_app sat_info_arg + sat_info = mergeIdSATInfo sat_info_fn sat_info_arg' + return (App fn' arg', sat_info, app_info) + +satExpr (Case expr bndr ty alts) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + let sat_info_expr' = finalizeApp expr_app sat_info_expr + + zipped_alts' <- mapM satAlt alts + let (alts', sat_infos_alts) = unzip zipped_alts' + return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing) + where + satAlt (Alt con bndrs expr) = do + (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids + return (Alt con bndrs expr', sat_info_expr) + +satExpr (Let bind body) interesting_ids = do + (body', sat_info_body, body_app) <- satExpr body interesting_ids + (bind', sat_info_bind) <- satBind bind interesting_ids + return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app) + +satExpr (Tick tickish expr) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (Tick tickish expr', sat_info_expr, expr_app) + +satExpr ty@(Type _) _ = + return (ty, emptyIdSATInfo, Nothing) + +satExpr co@(Coercion _) _ = + return (co, emptyIdSATInfo, Nothing) + +satExpr (Cast expr coercion) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (Cast expr' coercion, sat_info_expr, expr_app) + +{- +************************************************************************ + + Static Argument Transformation Monad + +************************************************************************ +-} + +type SatM result = UniqSM result + +runSAT :: UniqSupply -> SatM a -> a +runSAT = initUs_ + +newUnique :: SatM Unique +newUnique = getUniqueM + +{- +************************************************************************ + + Static Argument Transformation Monad + +************************************************************************ + +To do the transformation, the game plan is to: + +1. Create a small nonrecursive RHS that takes the + original arguments to the function but discards + the ones that are static and makes a call to the + SATed version with the remainder. We intend that + this will be inlined later, removing the overhead + +2. Bind this nonrecursive RHS over the original body + WITH THE SAME UNIQUE as the original body so that + any recursive calls to the original now go via + the small wrapper + +3. Rebind the original function to a new one which contains + our SATed function and just makes a call to it: + we call the thing making this call the local body + +Example: transform this + + map :: forall a b. (a->b) -> [a] -> [b] + map = /\ab. \(f:a->b) (as:[a]) -> body[map] +to + map :: forall a b. (a->b) -> [a] -> [b] + map = /\ab. \(f:a->b) (as:[a]) -> + letrec map' :: [a] -> [b] + -- The "worker function + map' = \(as:[a]) -> + let map :: forall a' b'. (a -> b) -> [a] -> [b] + -- The "shadow function + map = /\a'b'. \(f':(a->b) (as:[a]). + map' as + in body[map] + in map' as + +Note [Shadow binding] +~~~~~~~~~~~~~~~~~~~~~ +The calls to the inner map inside body[map] should get inlined +by the local re-binding of 'map'. We call this the "shadow binding". + +But we can't use the original binder 'map' unchanged, because +it might be exported, in which case the shadow binding won't be +discarded as dead code after it is inlined. + +So we use a hack: we make a new SysLocal binder with the *same* unique +as binder. (Another alternative would be to reset the export flag.) + +Note [Binder type capture] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that in the inner map (the "shadow function"), the static arguments +are discarded -- it's as if they were underscores. Instead, mentions +of these arguments (notably in the types of dynamic arguments) are bound +by the *outer* lambdas of the main function. So we must make up fresh +names for the static arguments so that they do not capture variables +mentioned in the types of dynamic args. + +In the map example, the shadow function must clone the static type +argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a' +is bound by the outer forall. We clone f' too for consistency, but +that doesn't matter either way because static Id arguments aren't +mentioned in the shadow binding at all. + +If we don't we get something like this: + +[Exported] +[Arity 3] +GHC.Base.until = + \ (@ a_aiK) + (p_a6T :: a_aiK -> GHC.Types.Bool) + (f_a6V :: a_aiK -> a_aiK) + (x_a6X :: a_aiK) -> + letrec { + sat_worker_s1aU :: a_aiK -> a_aiK + [] + sat_worker_s1aU = + \ (x_a6X :: a_aiK) -> + let { + sat_shadow_r17 :: forall a_a3O. + (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O + [] + sat_shadow_r17 = + \ (@ a_aiK) + (p_a6T :: a_aiK -> GHC.Types.Bool) + (f_a6V :: a_aiK -> a_aiK) + (x_a6X :: a_aiK) -> + sat_worker_s1aU x_a6X } in + case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] { + GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X); + GHC.Types.True -> x_a6X + }; } in + sat_worker_s1aU x_a6X + +Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK +type argument. This is bad because it means the application sat_worker_s1aU x_a6X +is not well typed. +-} + +saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind +saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body + | Just arg_staticness <- maybe_arg_staticness + , should_transform arg_staticness + = saTransform binder arg_staticness rhs_binders rhs_body + | otherwise + = return (Rec [(binder, mkLams rhs_binders rhs_body)]) + where + should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT + where + n_static_args = count isStaticValue staticness + +saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind +saTransform binder arg_staticness rhs_binders rhs_body + = do { shadow_lam_bndrs <- mapM clone binders_w_staticness + ; uniq <- newUnique + ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) } + where + -- Running example: foldr + -- foldr \alpha \beta c n xs = e, for some e + -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic] + -- rhs_binders = [\alpha, \beta, c, n, xs] + -- rhs_body = e + + binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic) + -- Any extra args are assumed NotStatic + + non_static_args :: [Var] + -- non_static_args = [xs] + -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs] + non_static_args = [v | (v, NotStatic) <- binders_w_staticness] + + clone (bndr, NotStatic) = return bndr + clone (bndr, _ ) = do { uniq <- newUnique + ; return (setVarUnique bndr uniq) } + + -- new_rhs = \alpha beta c n xs -> + -- let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs -> + -- sat_worker xs + -- in e + -- in sat_worker xs + mk_new_rhs uniq shadow_lam_bndrs + = mkLams rhs_binders $ + Let (Rec [(rec_body_bndr, rec_body)]) + local_body + where + local_body = mkVarApps (Var rec_body_bndr) non_static_args + + rec_body = mkLams non_static_args $ + Let (NonRec shadow_bndr shadow_rhs) rhs_body + + -- See Note [Binder type capture] + shadow_rhs = mkLams shadow_lam_bndrs local_body + -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs + + rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq ManyTy (exprType rec_body) + -- rec_body_bndr = sat_worker + + -- See Note [Shadow binding]; make a SysLocal + shadow_bndr = mkSysLocal (occNameFS (getOccName binder)) + (idUnique binder) + ManyTy + (exprType shadow_rhs) + +isStaticValue :: Staticness App -> Bool +isStaticValue (Static (VarApp _)) = True +isStaticValue _ = False diff --git a/GHC/Core/Opt/Stats.hs b/GHC/Core/Opt/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Stats.hs @@ -0,0 +1,337 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE DerivingVia #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.Opt.Stats ( + SimplCount, doSimplTick, doFreeSimplTick, simplCountN, + pprSimplCount, plusSimplCount, zeroSimplCount, + isZeroSimplCount, hasDetailedCounts, Tick(..) + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Error + +import GHC.Utils.Outputable as Outputable + +import GHC.Data.FastString + +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Ord +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import GHC.Utils.Panic (throwGhcException, GhcException(..)) + +getVerboseSimplStats :: (Bool -> SDoc) -> SDoc +getVerboseSimplStats = getPprDebug -- For now, anyway + +zeroSimplCount :: Bool -- ^ -ddump-simpl-stats + -> SimplCount +isZeroSimplCount :: SimplCount -> Bool +hasDetailedCounts :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doSimplTick :: Int -- ^ History size of the elaborate counter + -> Tick -> SimplCount -> SimplCount +doFreeSimplTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount + +data SimplCount + = VerySimplCount !Int -- Used when don't want detailed stats + + | SimplCount { + ticks :: !Int, -- Total ticks + details :: !TickCounts, -- How many of each type + + n_log :: !Int, -- N + log1 :: [Tick], -- Last N events; <= opt_HistorySize, + -- most recent first + log2 :: [Tick] -- Last opt_HistorySize events before that + -- Having log1, log2 lets us accumulate the + -- recent history reasonably efficiently + } + +type TickCounts = Map Tick Int + +simplCountN :: SimplCount -> Int +simplCountN (VerySimplCount n) = n +simplCountN (SimplCount { ticks = n }) = n + +zeroSimplCount dump_simpl_stats + -- This is where we decide whether to do + -- the VerySimpl version or the full-stats version + | dump_simpl_stats + = SimplCount {ticks = 0, details = Map.empty, + n_log = 0, log1 = [], log2 = []} + | otherwise + = VerySimplCount 0 + +isZeroSimplCount (VerySimplCount n) = n==0 +isZeroSimplCount (SimplCount { ticks = n }) = n==0 + +hasDetailedCounts (VerySimplCount {}) = False +hasDetailedCounts (SimplCount {}) = True + +doFreeSimplTick tick sc@SimplCount { details = dts } + = sc { details = dts `addTick` tick } +doFreeSimplTick _ sc = sc + +doSimplTick history_size tick + sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) + | nl >= history_size = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } + where + sc1 = sc { ticks = tks+1, details = dts `addTick` tick } + +doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) + + +addTick :: TickCounts -> Tick -> TickCounts +addTick fm tick = MapStrict.insertWith (+) tick 1 fm + +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2 + , details = MapStrict.unionWith (+) dts1 dts2 } + where + -- A hackish way of getting recent log info + log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 + | null (log2 sc2) = sc2 { log2 = log1 sc1 } + | otherwise = sc2 + +plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) +plusSimplCount lhs rhs = + throwGhcException . PprProgramError "plusSimplCount" $ vcat + [ text "lhs" + , pprSimplCount lhs + , text "rhs" + , pprSimplCount rhs + ] + -- We use one or the other consistently + +pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n +pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) + = vcat [text "Total ticks: " <+> int tks, + blankLine, + pprTickCounts dts, + getVerboseSimplStats $ \dbg -> if dbg + then + vcat [blankLine, + text "Log (most recent first)", + nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] + else Outputable.empty + ] + +{- Note [Which transformations are innocuous] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point (Jun 18) I wondered if some transformations (ticks) +might be "innocuous", in the sense that they do not unlock a later +transformation that does not occur in the same pass. If so, we could +refrain from bumping the overall tick-count for such innocuous +transformations, and perhaps terminate the simplifier one pass +earlier. + +But alas I found that virtually nothing was innocuous! This Note +just records what I learned, in case anyone wants to try again. + +These transformations are not innocuous: + +*** NB: I think these ones could be made innocuous + EtaExpansion + LetFloatFromLet + +LetFloatFromLet + x = K (let z = e2 in Just z) + prepareRhs transforms to + x2 = let z=e2 in Just z + x = K xs + And now more let-floating can happen in the + next pass, on x2 + +PreInlineUnconditionally + Example in spectral/cichelli/Auxil + hinsert = ...let lo = e in + let j = ...lo... in + case x of + False -> () + True -> case lo of I# lo' -> + ...j... + When we PreInlineUnconditionally j, lo's occ-info changes to once, + so it can be PreInlineUnconditionally in the next pass, and a + cascade of further things can happen. + +PostInlineUnconditionally + let x = e in + let y = ...x.. in + case .. of { A -> ...x...y... + B -> ...x...y... } + Current postinlineUnconditinaly will inline y, and then x; sigh. + + But PostInlineUnconditionally might also unlock subsequent + transformations for the same reason as PreInlineUnconditionally, + so it's probably not innocuous anyway. + + One annoying variant is this. CaseMerge introduces auxiliary bindings + let b = b' in ... + This takes another full run of the simplifier to elimiante. But if + the PostInlineUnconditionally, replacing b with b', is the only thing + that happens in a Simplifier run, that probably really is innocuous. + Perhaps an opportunity here. + +KnownBranch, BetaReduction: + May drop chunks of code, and thereby enable PreInlineUnconditionally + for some let-binding which now occurs once + +EtaExpansion: + Example in imaginary/digits-of-e1 + fail = \void. e where e :: IO () + --> etaExpandRhs + fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) + --> Next iteration of simplify + fail1 = \void. \s. (e |> g) s + fail = fail1 |> Void# -> sym g + And now inline 'fail' + +CaseMerge: + case x of y { + DEFAULT -> case y of z { pi -> ei } + alts2 } + ---> CaseMerge + case x of { pi -> let z = y in ei + ; alts2 } + The "let z=y" case-binder-swap gets dealt with in the next pass +-} + +pprTickCounts :: Map Tick Int -> SDoc +pprTickCounts counts + = vcat (map pprTickGroup groups) + where + groups :: [NonEmpty (Tick, Int)] -- Each group shares a common tag + -- toList returns common tags adjacent + groups = NE.groupWith (tickToTag . fst) (Map.toList counts) + +pprTickGroup :: NonEmpty (Tick, Int) -> SDoc +pprTickGroup group@((tick1,_) :| _) + = hang (int (sum (fmap snd group)) <+> pprTickType tick1) + 2 (vcat [ int n <+> pprTickCts tick + -- flip as we want largest first + | (tick,n) <- sortOn (Down . snd) (NE.toList group)]) + +data Tick -- See Note [Which transformations are innocuous] + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FastString -- Rule name + + | LetFloatFromLet + | EtaExpansion Id -- LHS binder + | EtaReduction Id -- Binder on outer lambda + | BetaReduction Id -- Lambda binder + + + | CaseOfCase Id -- Bndr on *inner* case + | KnownBranch Id -- Case binder + | CaseMerge Id -- Binder on outer case + | AltMerge Id -- Case binder + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | SimplifierDone -- Ticked at each iteration of the simplifier + +instance Outputable Tick where + ppr tick = pprTickType tick <+> pprTickCts tick + +instance Eq Tick where + a == b = case a `cmpTick` b of + EQ -> True + _ -> False + +instance Ord Tick where + compare = cmpTick + +tickToTag :: Tick -> Int +tickToTag (PreInlineUnconditionally _) = 0 +tickToTag (PostInlineUnconditionally _) = 1 +tickToTag (UnfoldingDone _) = 2 +tickToTag (RuleFired _) = 3 +tickToTag LetFloatFromLet = 4 +tickToTag (EtaExpansion _) = 5 +tickToTag (EtaReduction _) = 6 +tickToTag (BetaReduction _) = 7 +tickToTag (CaseOfCase _) = 8 +tickToTag (KnownBranch _) = 9 +tickToTag (CaseMerge _) = 10 +tickToTag (CaseElim _) = 11 +tickToTag (CaseIdentity _) = 12 +tickToTag (FillInCaseDefault _) = 13 +tickToTag SimplifierDone = 16 +tickToTag (AltMerge _) = 17 + +pprTickType :: Tick -> SDoc +pprTickType (PreInlineUnconditionally _) = text "PreInlineUnconditionally" +pprTickType (PostInlineUnconditionally _)= text "PostInlineUnconditionally" +pprTickType (UnfoldingDone _) = text "UnfoldingDone" +pprTickType (RuleFired _) = text "RuleFired" +pprTickType LetFloatFromLet = text "LetFloatFromLet" +pprTickType (EtaExpansion _) = text "EtaExpansion" +pprTickType (EtaReduction _) = text "EtaReduction" +pprTickType (BetaReduction _) = text "BetaReduction" +pprTickType (CaseOfCase _) = text "CaseOfCase" +pprTickType (KnownBranch _) = text "KnownBranch" +pprTickType (CaseMerge _) = text "CaseMerge" +pprTickType (AltMerge _) = text "AltMerge" +pprTickType (CaseElim _) = text "CaseElim" +pprTickType (CaseIdentity _) = text "CaseIdentity" +pprTickType (FillInCaseDefault _) = text "FillInCaseDefault" +pprTickType SimplifierDone = text "SimplifierDone" + +pprTickCts :: Tick -> SDoc +pprTickCts (PreInlineUnconditionally v) = ppr v +pprTickCts (PostInlineUnconditionally v)= ppr v +pprTickCts (UnfoldingDone v) = ppr v +pprTickCts (RuleFired v) = ppr v +pprTickCts LetFloatFromLet = Outputable.empty +pprTickCts (EtaExpansion v) = ppr v +pprTickCts (EtaReduction v) = ppr v +pprTickCts (BetaReduction v) = ppr v +pprTickCts (CaseOfCase v) = ppr v +pprTickCts (KnownBranch v) = ppr v +pprTickCts (CaseMerge v) = ppr v +pprTickCts (AltMerge v) = ppr v +pprTickCts (CaseElim v) = ppr v +pprTickCts (CaseIdentity v) = ppr v +pprTickCts (FillInCaseDefault v) = ppr v +pprTickCts _ = Outputable.empty + +cmpTick :: Tick -> Tick -> Ordering +cmpTick a b = case (tickToTag a `compare` tickToTag b) of + GT -> GT + EQ -> cmpEqTick a b + LT -> LT + +cmpEqTick :: Tick -> Tick -> Ordering +cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b +cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b +cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b +cmpEqTick (RuleFired a) (RuleFired b) = a `uniqCompareFS` b +cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b +cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b +cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b +cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b +cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b +cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b +cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b +cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b +cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b +cmpEqTick _ _ = EQ diff --git a/GHC/Core/Opt/WorkWrap.hs b/GHC/Core/Opt/WorkWrap.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/WorkWrap.hs @@ -0,0 +1,1067 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} +-} + + +module GHC.Core.Opt.WorkWrap + ( WwOpts (..) + , wwTopBinds + ) +where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Unfold.Make +import GHC.Core.Utils ( exprType, exprIsHNF ) +import GHC.Core.Type +import GHC.Core.Opt.WorkWrap.Utils +import GHC.Core.SimpleOpt + +import GHC.Data.FastString + +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Unique.Supply +import GHC.Types.Basic +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.SourceText +import GHC.Types.Unique + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Monad +import GHC.Core.DataCon + +{- +We take Core bindings whose binders have: + +\begin{enumerate} + +\item Strictness attached (by the front-end of the strictness +analyser), and / or + +\item Constructed Product Result information attached by the CPR +analysis pass. + +\end{enumerate} + +and we return some ``plain'' bindings which have been +worker/wrapper-ified, meaning: + +\begin{enumerate} + +\item Functions have been split into workers and wrappers where +appropriate. If a function has both strictness and CPR properties +then only one worker/wrapper doing both transformations is produced; + +\item Binders' @IdInfos@ have been updated to reflect the existence of +these workers/wrappers (this is where we get STRICTNESS and CPR pragma +info for exported values). +\end{enumerate} +-} + +wwTopBinds :: WwOpts -> UniqSupply -> CoreProgram -> CoreProgram + +wwTopBinds ww_opts us top_binds + = initUs_ us $ concatMapM (wwBind ww_opts) top_binds + +{- +************************************************************************ +* * +\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@} +* * +************************************************************************ + +@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in +turn. Non-recursive case first, then recursive... +-} + +wwBind :: WwOpts + -> CoreBind + -> UniqSM [CoreBind] -- returns a WwBinding intermediate form; + -- the caller will convert to Expr/Binding, + -- as appropriate. + +wwBind ww_opts (NonRec binder rhs) = do + new_rhs <- wwExpr ww_opts rhs + new_pairs <- tryWW ww_opts NonRecursive binder new_rhs + return [NonRec b e | (b,e) <- new_pairs] + -- Generated bindings must be non-recursive + -- because the original binding was. + +wwBind ww_opts (Rec pairs) + = return . Rec <$> concatMapM do_one pairs + where + do_one (binder, rhs) = do new_rhs <- wwExpr ww_opts rhs + tryWW ww_opts Recursive binder new_rhs + +{- +@wwExpr@ basically just walks the tree, looking for appropriate +annotations that can be used. Remember it is @wwBind@ that does the +matching by looking for strict arguments of the correct type. +@wwExpr@ is a version that just returns the ``Plain'' Tree. +-} + +wwExpr :: WwOpts -> CoreExpr -> UniqSM CoreExpr + +wwExpr _ e@(Type {}) = return e +wwExpr _ e@(Coercion {}) = return e +wwExpr _ e@(Lit {}) = return e +wwExpr _ e@(Var {}) = return e + +wwExpr ww_opts (Lam binder expr) + = Lam new_binder <$> wwExpr ww_opts expr + where new_binder | isId binder = zapIdUsedOnceInfo binder + | otherwise = binder + -- See Note [Zapping Used Once info in WorkWrap] + +wwExpr ww_opts (App f a) + = App <$> wwExpr ww_opts f <*> wwExpr ww_opts a + +wwExpr ww_opts (Tick note expr) + = Tick note <$> wwExpr ww_opts expr + +wwExpr ww_opts (Cast expr co) = do + new_expr <- wwExpr ww_opts expr + return (Cast new_expr co) + +wwExpr ww_opts (Let bind expr) + = mkLets <$> wwBind ww_opts bind <*> wwExpr ww_opts expr + +wwExpr ww_opts (Case expr binder ty alts) = do + new_expr <- wwExpr ww_opts expr + new_alts <- mapM ww_alt alts + let new_binder = zapIdUsedOnceInfo binder + -- See Note [Zapping Used Once info in WorkWrap] + return (Case new_expr new_binder ty new_alts) + where + ww_alt (Alt con binders rhs) = do + new_rhs <- wwExpr ww_opts rhs + let new_binders = [ if isId b then zapIdUsedOnceInfo b else b + | b <- binders ] + -- See Note [Zapping Used Once info in WorkWrap] + return (Alt con new_binders new_rhs) + +{- +************************************************************************ +* * +\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair} +* * +************************************************************************ + +@tryWW@ just accumulates arguments, converts strictness info from the +front-end into the proper form, then calls @mkWwBodies@ to do +the business. + +The only reason this is monadised is for the unique supply. + +Note [Don't w/w INLINE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very important to refrain from w/w-ing an INLINE function (ie one +with a stable unfolding) because the wrapper will then overwrite the +old stable unfolding with the wrapper code. + +Furthermore, if the programmer has marked something as INLINE, +we may lose by w/w'ing it. + +If the strictness analyser is run twice, this test also prevents +wrappers (which are INLINEd) from being re-done. (You can end up with +several liked-named Ids bouncing around at the same time---absolute +mischief.) + +Notice that we refrain from w/w'ing an INLINE function even if it is +in a recursive group. It might not be the loop breaker. (We could +test for loop-breaker-hood, but I'm not sure that ever matters.) + +Note [Worker/wrapper for INLINABLE functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + {-# INLINABLE f #-} + f :: Ord a => [a] -> Int -> a + f x y = ....f.... + +where f is strict in y, we might get a more efficient loop by w/w'ing +f. But that would make a new unfolding which would overwrite the old +one! So the function would no longer be INLINABLE, and in particular +will not be specialised at call sites in other modules. + +This comes up in practice (#6056). + +Solution: + +* Do the w/w for strictness analysis, even for INLINABLE functions + +* Transfer the Stable unfolding to the *worker*. How do we "transfer + the unfolding"? Easy: by using the old one, wrapped in work_fn! See + GHC.Core.Unfold.Make.mkWorkerUnfolding. + +* We use the /original, user-specified/ function's InlineSpec pragma + for both the wrapper and the worker (see `mkStrWrapperInlinePrag`). + So if f is INLINEABLE, both worker and wrapper will get an InlineSpec + of (Inlinable "blah"). + + It's important that both get this, because the specialiser uses + the existence of a /user-specified/ INLINE/INLINABLE pragma to + drive specialisation of imported functions. See GHC.Core.Opt.Specialise + Note [Specialising imported functions] + +* Remember, the subsequent inlining behaviour of the wrapper is expressed by + (a) the stable unfolding + (b) the unfolding guidance of UnfWhen + (c) the inl_act activation (see Note [Wrapper activation] + +For our {-# INLINEABLE f #-} example above, we will get something a +bit like like this: + + {-# Has stable unfolding, active in phase 2; + plus InlineSpec = INLINEABLE #-} + f :: Ord a => [a] -> Int -> a + f d x y = case y of I# y' -> fw d x y' + + {-# Has stable unfolding, plus InlineSpec = INLINEABLE #-} + fw :: Ord a => [a] -> Int# -> a + fw d x y' = let y = I# y' in ...f... + + +(Historical note: we used to always give the wrapper an INLINE pragma, +but CSE will not happen if there is a user-specified pragma, but +should happen for w/w’ed things (#14186). But now we simply propagate +any user-defined pragma info, so we'll defeat CSE (rightly) only when +there is a user-supplied INLINE/INLINEABLE pragma.) + +Note [No worker/wrapper for record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We sometimes generate a lot of record selectors, and generally the +don't benefit from worker/wrapper. Yes, mkWwBodies would find a w/w split, +but it is then suppressed by the certainlyWillInline test in splitFun. + +The wasted effort in mkWwBodies makes a measurable difference in +compile time (see MR !2873), so although it's a terribly ad-hoc test, +we just check here for record selectors, and do a no-op in that case. + +I did look for a generalisation, so that it's not just record +selectors that benefit. But you'd need a cheap test for "this +function will definitely get a w/w split" and that's hard to predict +in advance...the logic in mkWwBodies is complex. So I've left the +super-simple test, with this Note to explain. + +NB: record selectors are ordinary functions, inlined iff GHC wants to, +so won't be caught by the preceding isInlineUnfolding test in tryWW. + +Note [Worker/wrapper for NOINLINE functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to disable worker/wrapper for NOINLINE things, but it turns out +this can cause unnecessary reboxing of values. Consider + + {-# NOINLINE f #-} + f :: Int -> a + f x = error (show x) + + g :: Bool -> Bool -> Int -> Int + g True True p = f p + g False True p = p + 1 + g b False p = g b True p + +the strictness analysis will discover f and g are strict, but because f +has no wrapper, the worker for g will rebox p. So we get + + $wg x y p# = + let p = I# p# in -- Yikes! Reboxing! + case x of + False -> + case y of + False -> $wg False True p# + True -> +# p# 1# + True -> + case y of + False -> $wg True True p# + True -> case f p of { } + + g x y p = case p of (I# p#) -> $wg x y p# + +Now, in this case the reboxing will float into the True branch, and so +the allocation will only happen on the error path. But it won't float +inwards if there are multiple branches that call (f p), so the reboxing +will happen on every call of g. Disaster. + +Solution: do worker/wrapper even on NOINLINE things; but move the +NOINLINE pragma to the worker. + +(See #13143 for a real-world example.) + +It is crucial that we do this for *all* NOINLINE functions. #10069 +demonstrates what happens when we promise to w/w a (NOINLINE) leaf +function, but fail to deliver: + + data C = C Int# Int# + + {-# NOINLINE c1 #-} + c1 :: C -> Int# + c1 (C _ n) = n + + {-# NOINLINE fc #-} + fc :: C -> Int# + fc c = 2 *# c1 c + +Failing to w/w `c1`, but still w/wing `fc` leads to the following code: + + c1 :: C -> Int# + c1 (C _ n) = n + + $wfc :: Int# -> Int# + $wfc n = let c = C 0# n in 2 #* c1 c + + fc :: C -> Int# + fc (C _ n) = $wfc n + +Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place. +This generalises to any function that derives its strictness signature from +its callees, so we have to make sure that when a function announces particular +strictness properties, we have to w/w them accordingly, even if it means +splitting a NOINLINE function. + +Note [Worker activation] +~~~~~~~~~~~~~~~~~~~~~~~~ +Follows on from Note [Worker/wrapper for INLINABLE functions] + +It is *vital* that if the worker gets an INLINABLE pragma (from the +original function), then the worker has the same phase activation as +the wrapper (or later). That is necessary to allow the wrapper to +inline into the worker's unfolding: see GHC.Core.Opt.Simplify.Utils +Note [Simplifying inside stable unfoldings]. + +If the original is NOINLINE, it's important that the worker inherits the +original activation. Consider + + {-# NOINLINE expensive #-} + expensive x = x + 1 + + f y = let z = expensive y in ... + +If expensive's worker inherits the wrapper's activation, +we'll get this (because of the compromise in point (2) of +Note [Wrapper activation]) + + {-# NOINLINE[Final] $wexpensive #-} + $wexpensive x = x + 1 + {-# INLINE[Final] expensive #-} + expensive x = $wexpensive x + + f y = let z = expensive y in ... + +and $wexpensive will be immediately inlined into expensive, followed by +expensive into f. This effectively removes the original NOINLINE! + +Otherwise, nothing is lost by giving the worker the same activation as the +wrapper, because the worker won't have any chance of inlining until the +wrapper does; there's no point in giving it an earlier activation. + +Note [Don't w/w inline small non-loop-breaker things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, we refrain from w/w-ing *small* functions, which are not +loop breakers, because they'll inline anyway. But we must take care: +it may look small now, but get to be big later after other inlining +has happened. So we take the precaution of adding a StableUnfolding +for any such functions. + +I made this change when I observed a big function at the end of +compilation with a useful strictness signature but no w-w. (It was +small during demand analysis, we refrained from w/w, and then got big +when something was inlined in its rhs.) When I measured it on nofib, +it didn't make much difference; just a few percent improved allocation +on one benchmark (bspt/Euclid.space). But nothing got worse. + +There is an infelicity though. We may get something like + f = g val +==> + g x = case gw x of r -> I# r + + f {- InlineStable, Template = g val -} + f = case gw x of r -> I# r + +The code for f duplicates that for g, without any real benefit. It +won't really be executed, because calls to f will go via the inlining. + +Note [Don't w/w join points for CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's no point in exploiting CPR info on a join point. If the whole function +is getting CPR'd, then the case expression around the worker function will get +pushed into the join point by the simplifier, which will have the same effect +that w/w'ing for CPR would have - the result will be returned in an unboxed +tuple. + + f z = let join j x y = (x+1, y+1) + in case z of A -> j 1 2 + B -> j 2 3 + + => + + f z = case $wf z of (# a, b #) -> (a, b) + $wf z = case (let join j x y = (x+1, y+1) + in case z of A -> j 1 2 + B -> j 2 3) of (a, b) -> (# a, b #) + + => + + f z = case $wf z of (# a, b #) -> (a, b) + $wf z = let join j x y = (# x+1, y+1 #) + in case z of A -> j 1 2 + B -> j 2 3 + +Note that we still want to give `j` the CPR property, so that `f` has it. So +CPR *analyse* join points as regular functions, but don't *transform* them. + +We could retain the CPR /signature/ on the worker after W/W, but it would +become outright wrong if the Simplifier pushes a non-trivial continuation +into it. For example: + case (let $j x = (x,x) in ...) of alts + ==> + let $j x = case (x,x) of alts in case ... of alts +Before pushing the case in, `$j` has the CPR property, but not afterwards. + +So we simply zap the CPR signature for join pints as part of the W/W pass. +The signature served its purpose during CPR analysis in propagating the +CPR property of `$j`. + +Doing W/W for returned products on a join point would be tricky anyway, as the +worker could not be a join point because it would not be tail-called. However, +doing the *argument* part of W/W still works for join points, since the wrapper +body will make a tail call: + + f z = let join j x y = x + y + in ... + + => + + f z = let join $wj x# y# = x# +# y# + j x y = case x of I# x# -> + case y of I# y# -> + $wj x# y# + in ... + +Note [Wrapper activation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When should the wrapper inlining be active? + +1. It must not be active earlier than the current Activation of the Id, + because we must give rewrite rules mentioning the wrapper and + specialisation a chance to fire. + See Note [Worker/wrapper for INLINABLE functions] + and Note [Worker activation] + +2. It should be active at some point, despite (1) because of + Note [Worker/wrapper for NOINLINE functions] + +3. For ordinary functions with no pragmas we want to inline the + wrapper as early as possible (#15056). Suppose another module + defines f !x xs = ... foldr k z xs ... + and suppose we have the usual foldr/build RULE. Then if we have + a call `f x [1..x]`, we'd expect to inline f and the RULE will fire. + But if f is w/w'd (which it might be), we want the inlining to + occur just as if it hadn't been. + + (This only matters if f's RHS is big enough to w/w, but small + enough to inline given the call site, but that can happen.) + +4. We do not want to inline the wrapper before specialisation. + module Foo where + f :: Num a => a -> Int -> a + f n 0 = n -- Strict in the Int, hence wrapper + f n x = f (n+n) (x-1) + + g :: Int -> Int + g x = f x x -- Provokes a specialisation for f + + module Bar where + import Foo + + h :: Int -> Int + h x = f 3 x + + In module Bar we want to give specialisations a chance to fire + before inlining f's wrapper. + + (Historical note: At one stage I tried making the wrapper inlining + always-active, and that had a very bad effect on nofib/imaginary/x2n1; + a wrapper was inlined before the specialisation fired.) + +4a. If we have + {-# SPECIALISE foo :: (Int,Int) -> Bool -> Int #-} + {-# NOINLINE [n] foo #-} + then specialisation will generate a SPEC rule active from Phase n. + See Note [Auto-specialisation and RULES] in GHC.Core.Opt.Specialise + This SPEC specialisation rule will compete with inlining, but we don't + mind that, because if inlining succeeds, it should be better. + + Now, if we w/w foo, we must ensure that the wrapper (which is very + keen to inline) has a phase /after/ 'n', else it'll always "win" over + the SPEC rule -- disaster (#20709). + +Conclusion: the activation for the wrapper should be the /later/ of + (a) the current activation of the function, or FinalPhase if it is NOINLINE + (b) one phase /after/ the activation of any rules +This is implemented by mkStrWrapperInlinePrag. + +Reminder: Note [Don't w/w INLINE things], so we don't need to worry + about INLINE things here. + + +What if `foo` has no specialisations, is worker/wrappered (with the +wrapper inlining very early), and exported; and then in an importing +module we have {-# SPECIALISE foo : ... #-}? + +Well then, we'll specialise foo's wrapper, which will expose a +specialisation for foo's worker, which we will do too. That seems +fine. (To work reliably, `foo` would need an INLINABLE pragma, +in which case we don't unpack dictionaries for the worker; see +see Note [Do not unbox class dictionaries].) + +Note [Drop absent bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#19824): + let t = ...big... + in ...(f t x)... + +were `f` ignores its first argument. With luck f's wrapper will inline +thereby dropping `t`, but maybe not: the arguments to f all look boring. + +So we pre-empt the problem by replacing t's RHS with an absent filler. +Simple and effective. +-} + +tryWW :: WwOpts + -> RecFlag + -> Id -- The fn binder + -> CoreExpr -- The bound rhs; its innards + -- are already ww'd + -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs; + -- if one, then no worker (only + -- the orig "wrapper" lives on); + -- if two, then a worker and a + -- wrapper. +tryWW ww_opts is_rec fn_id rhs + -- See Note [Drop absent bindings] + | isAbsDmd (demandInfo fn_info) + , not (isJoinId fn_id) + , Just filler <- mkAbsentFiller ww_opts fn_id NotMarkedStrict + = return [(new_fn_id, filler)] + + -- See Note [Don't w/w INLINE things] + | hasInlineUnfolding fn_info + = return [(new_fn_id, rhs)] + + -- See Note [No worker/wrapper for record selectors] + | isRecordSelector fn_id + = return [ (new_fn_id, rhs ) ] + + -- Don't w/w OPAQUE things + -- See Note [OPAQUE pragma] + -- + -- Whilst this check might seem superfluous, since we strip boxity + -- information in GHC.Core.Opt.DmdAnal.finaliseArgBoxities and + -- CPR information in GHC.Core.Opt.CprAnal.cprAnalBind, it actually + -- isn't. That is because we would still perform w/w when: + -- + -- - An argument is used strictly, and -fworker-wrapper-cbv is + -- enabled, or, + -- - When demand analysis marks an argument as absent. + -- + -- In a debug build we do assert that boxity and CPR information + -- are actually stripped, since we want to prevent callers of OPAQUE + -- things to do reboxing. See: + -- - Note [The OPAQUE pragma and avoiding the reboxing of arguments] + -- - Note [The OPAQUE pragma and avoiding the reboxing of results] + | isOpaquePragma (inlinePragInfo fn_info) + = assertPpr (onlyBoxedArguments (dmdSigInfo fn_info) && + isTopCprSig (cprSigInfo fn_info)) + (text "OPAQUE fun with boxity" $$ + ppr new_fn_id $$ + ppr (dmdSigInfo fn_info) $$ + ppr (cprSigInfo fn_info) $$ + ppr rhs) $ + return [ (new_fn_id, rhs) ] + + -- Do this even if there is a NOINLINE pragma + -- See Note [Worker/wrapper for NOINLINE functions] + | is_fun + = splitFun ww_opts new_fn_id rhs + + -- See Note [Thunk splitting] + | isNonRec is_rec, is_thunk + = splitThunk ww_opts is_rec new_fn_id rhs + + | otherwise + = return [ (new_fn_id, rhs) ] + + where + fn_info = idInfo fn_id + (wrap_dmds, _) = splitDmdSig (dmdSigInfo fn_info) + new_fn_id = zap_join_cpr $ zap_usage fn_id + + zap_usage = zapIdUsedOnceInfo . zapIdUsageEnvInfo + -- See Note [Zapping DmdEnv after Demand Analyzer] and + -- See Note [Zapping Used Once info in WorkWrap] + + zap_join_cpr id + | isJoinId id = id `setIdCprSig` topCprSig + | otherwise = id + -- See Note [Don't w/w join points for CPR] + + is_fun = notNull wrap_dmds || isJoinId fn_id + is_thunk = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id) + && not (isUnliftedType (idType fn_id)) + +{- +Note [Zapping DmdEnv after Demand Analyzer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the worker-wrapper pass we zap the DmdEnv. Why? + (a) it is never used again + (b) it wastes space + (c) it becomes incorrect as things are cloned, because + we don't push the substitution into it + +Why here? + * Because we don’t want to do it in the Demand Analyzer, as we never know + there when we are doing the last pass. + * We want them to be still there at the end of DmdAnal, so that + -ddump-str-anal contains them. + * We don’t want a second pass just for that. + * WorkWrap looks at all bindings anyway. + +We also need to do it in TidyCore.tidyLetBndr to clean up after the +final, worker/wrapper-less run of the demand analyser (see +Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal). + +Note [Zapping Used Once info in WorkWrap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During the work/wrap pass, using zapIdUsedOnceInfo, we zap the "used once" info +* on every binder (let binders, case binders, lambda binders) +* in both demands and in strictness signatures +* recursively + +Why? + * The simplifier may happen to transform code in a way that invalidates the + data (see #11731 for an example). + * It is not used in later passes, up to code generation. + +At first it's hard to see how the simplifier might invalidate it (and +indeed for a while I thought it couldn't: #19482), but it's not quite +as simple as I thought. Consider this: + {-# STRICTNESS SIG #-} + f p = let v = case p of (a,b) -> a + in p `seq` (v,v) + +I think we'll give `f` the strictness signature ``, where the +`M` says that we'll evaluate the first component of the pair at most +once. Why? Because the RHS of the thunk `v` is evaluated at most +once. + +But now let's worker/wrapper f: + {-# STRICTNESS SIG #-} + $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 #-} + $wf p1 = let v = p1 in + (v,v) + +and thence to `(p1,p1)` by inlining the trivial let. Now the demand on `p1` should +not be at most once!! + +Conclusion: used-once info is fragile to simplification, because of +the non-monotonic behaviour of let's, which turn used-many into +used-once. So indeed we should zap this info in worker/wrapper. + +Conclusion: kill it during worker/wrapper, using `zapUsedOnceInfo`. +Both the *demand signature* of the binder, and the *demand-info* of +the binder. Moreover, do so recursively. + +You might wonder: why do we generate used-once info if we then throw +it away. The main reason is that we do a final run of the demand analyser, +immediately before CoreTidy, which is /not/ followed by worker/wrapper; it +is there only to generate used-once info for single-entry thunks. + +Note [Don't eta expand in w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A binding where the manifestArity of the RHS is less than idArity of +the binder means GHC.Core.Opt.Arity didn't eta expand that binding +When this happens, it does so for a reason (see Note [Arity invariants for bindings] +in GHC.Core.Opt.Arity) and we probably have a PAP, cast or trivial expression +as RHS. + +Below is a historical account of what happened when w/w still did eta expansion. +Nowadays, it doesn't do that, but will simply w/w for the wrong arity, unleashing +a demand signature meant for e.g. 2 args to be unleashed for e.g. 1 arg +(manifest arity). That's at least as terrible as doing eta expansion, so don't +do it. +--- +When worker/wrapper did eta expansion, it implictly eta expanded the binding to +idArity, overriding GHC.Core.Opt.Arity's decision. Other than playing fast and loose with +divergence, it's also broken for newtypes: + + f = (\xy.blah) |> co + where + co :: (Int -> Int -> Char) ~ T + +Then idArity is 2 (despite the type T), and it can have a DmdSig based on a +threshold of 2. But we can't w/w it without a type error. + +The situation is less grave for PAPs, but the implicit eta expansion caused a +compiler allocation regression in T15164, where huge recursive instance method +groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the +simplifier, when simply waiting for the PAPs to inline arrived at the same +output program. + +Note there is the worry here that such PAPs and trivial RHSs might not *always* +be inlined. That would lead to reboxing, because the analysis tacitly assumes +that we W/W'd for idArity and will propagate analysis information under that +assumption. So far, this doesn't seem to matter in practice. +See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. + +Note [Inline pragma for certainlyWillInline] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#19824 comment on 15 May 21): + f _ (x,y) = ...big... + v = ...big... + g x = f v x + 1 + +So `f` will generate a worker/wrapper split; and `g` (since it is small) +will trigger the certainlyWillInline case of splitFun. The danger is that +we end up with + g {- StableUnfolding = \x -> f v x + 1 -} + = ...blah... + +Since (a) that unfolding for g is AlwaysActive + (b) the unfolding for f's wrapper is ActiveAfterInitial +the call of f will never inline in g's stable unfolding, thereby +keeping `v` alive. + +I thought of changing g's unfolding to be ActiveAfterInitial, but that +too is bad: it delays g's inlining into other modules, which makes fewer +specialisations happen. Example in perf/should_run/DeriveNull. + +So I decided to live with the problem. In fact v's RHS will be replaced +by LitRubbish (see Note [Drop absent bindings]) so there is no great harm. +-} + + +--------------------- +splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)] +splitFun ww_opts fn_id rhs + | Just (arg_vars, body) <- collectNValBinders_maybe ww_arity rhs + = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info))) + "splitFun" + (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $ + do { mb_stuff <- mkWwBodies ww_opts fn_id ww_arity arg_vars (exprType body) wrap_dmds cpr + ; case mb_stuff of + Nothing -> -- No useful wrapper; leave the binding alone + return [(fn_id, rhs)] + + Just stuff + | let opt_wwd_rhs = mkLams arg_vars $ + simpleOptExpr (wo_simple_opts ww_opts) body + -- Run the simple optimiser on the WW'd body, to get rid of + -- junk. Keep all the original `arg_vars` binders though: this + -- might be a join point, and we don't want to lose the + -- one-shot annotations. At least I think that's the reason + -- (honestly, I have forgottne), but doing it this way + -- certainly does no harm and is slightly more efficient. + + , Just stable_unf <- certainlyWillInline uf_opts fn_info opt_wwd_rhs + -- We could make a w/w split, but in fact the RHS is small + -- See Note [Don't w/w inline small non-loop-breaker things] + + , let id_w_unf = fn_id `setIdUnfolding` stable_unf + -- See Note [Inline pragma for certainlyWillInline] + -> return [ (id_w_unf, rhs) ] + + | otherwise + -> do { work_uniq <- getUniqueM + ; return (mkWWBindPair ww_opts fn_id fn_info arg_vars body + work_uniq div stuff) } } + + | otherwise -- See Note [Don't eta expand in w/w] + = return [(fn_id, rhs)] + + where + uf_opts = so_uf_opts (wo_simple_opts ww_opts) + fn_info = idInfo fn_id + ww_arity = workWrapArity fn_id rhs + -- workWrapArity: see (4) in Note [Worker/wrapper arity and join points] in DmdAnal + + (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) + + cpr_ty = getCprSig (cprSigInfo fn_info) + -- Arity of the CPR sig should match idArity when it's not a join point. + -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal + cpr = assertPpr (isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info) + (ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) + <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $ + ct_cpr cpr_ty + +mkWWBindPair :: WwOpts -> Id -> IdInfo + -> [Var] -> CoreExpr -> Unique -> Divergence + -> ([Demand],JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr) + -> [(Id, CoreExpr)] +mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div + (work_demands, join_arity, wrap_fn, work_fn) + = -- pprTrace "mkWWBindPair" (ppr fn_id <+> ppr wrap_id <+> ppr work_id $$ ppr wrap_rhs) $ + [(work_id, work_rhs), (wrap_id, wrap_rhs)] + -- Worker first, because wrapper mentions it + where + arity = arityInfo fn_info + -- The arity is set by the simplifier using exprEtaExpandArity + -- So it may be more than the number of top-level-visible lambdas + + simpl_opts = wo_simple_opts ww_opts + + work_rhs = work_fn (mkLams fn_args fn_body) + work_act = case fn_inline_spec of -- See Note [Worker activation] + NoInline _ -> inl_act fn_inl_prag + _ -> inl_act wrap_prag + + work_prag = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" + , inl_inline = fn_inline_spec + , inl_sat = Nothing + , inl_act = work_act + , inl_rule = FunLike } + -- inl_inline: copy from fn_id; see Note [Worker/wrapper for INLINABLE functions] + -- inl_act: see Note [Worker activation] + -- inl_rule: it does not make sense for workers to be constructorlike. + + work_join_arity | isJoinId fn_id = JoinPoint join_arity + | otherwise = NotJoinPoint + -- worker is join point iff wrapper is join point + -- (see Note [Don't w/w join points for CPR]) + + work_id = asWorkerLikeId $ + mkWorkerId work_uniq fn_id (exprType work_rhs) + `setIdOccInfo` occInfo fn_info + -- Copy over occurrence info from parent + -- Notably whether it's a loop breaker + -- Doesn't matter much, since we will simplify next, but + -- seems right-er to do so + + `setInlinePragma` work_prag + + `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding + -- See Note [Worker/wrapper for INLINABLE functions] + + `setIdDmdSig` mkClosedDmdSig work_demands div + -- Even though we may not be at top level, + -- it's ok to give it an empty DmdEnv + + `setIdCprSig` topCprSig + + `setIdDemandInfo` worker_demand + + `setIdArity` work_arity + -- Set the arity so that the Core Lint check that the + -- arity is consistent with the demand type goes + -- through + + `asJoinId_maybe` work_join_arity + + work_arity = length work_demands :: Int + + -- See Note [Demand on the worker] + single_call = saturatedByOneShots arity (demandInfo fn_info) + worker_demand | single_call = mkWorkerDemand work_arity + | otherwise = topDmd + + wrap_rhs = wrap_fn work_id + wrap_prag = mkStrWrapperInlinePrag fn_inl_prag fn_rules + wrap_unf = mkWrapperUnfolding simpl_opts wrap_rhs arity + + wrap_id = fn_id `setIdUnfolding` wrap_unf + `setInlinePragma` wrap_prag + `setIdOccInfo` noOccInfo + -- Zap any loop-breaker-ness, to avoid bleating from Lint + -- about a loop breaker with an INLINE rule + + fn_inl_prag = inlinePragInfo fn_info + fn_inline_spec = inl_inline fn_inl_prag + fn_unfolding = realUnfoldingInfo fn_info + fn_rules = ruleInfoRules (ruleInfo fn_info) + +mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma +mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl + , inl_act = fn_act + , inl_rule = rule_info }) rules + = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" + , inl_sat = Nothing + + , inl_inline = fn_inl + -- See Note [Worker/wrapper for INLINABLE functions] + + , inl_act = activeAfter wrapper_phase + -- See Note [Wrapper activation] + + , inl_rule = rule_info } -- RuleMatchInfo is (and must be) unaffected + where + -- See Note [Wrapper activation] + wrapper_phase = foldr (laterPhase . get_rule_phase) earliest_inline_phase rules + earliest_inline_phase = beginPhase fn_act `laterPhase` nextPhase InitialPhase + -- laterPhase (nextPhase InitialPhase) is a temporary hack + -- to inline no earlier than phase 2. I got regressions in + -- 'mate', due to changes in full laziness due to Note [Case + -- MFEs], when I did earlier inlining. + + get_rule_phase :: CoreRule -> CompilerPhase + -- The phase /after/ the rule is first active + get_rule_phase rule = nextPhase (beginPhase (ruleActivation rule)) + +{- +Note [Demand on the worker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If the original function is called once, according to its demand info, then +so is the worker. This is important so that the occurrence analyser can +attach OneShot annotations to the worker’s lambda binders. + + +Example: + + -- Original function + f [Demand=] :: (a,a) -> a + f = \p -> ... + + -- Wrapper + f [Demand=] :: a -> a -> a + f = \p -> case p of (a,b) -> $wf a b + + -- Worker + $wf [Demand=] :: Int -> Int + $wf = \a b -> ... + +We need to check whether the original function is called once, with +sufficiently many arguments. This is done using saturatedByOneShots, which +takes the arity of the original function (resp. the wrapper) and the demand on +the original function. + +The demand on the worker is then calculated using mkWorkerDemand, and always of +the form [Demand=] + +Note [Thunk splitting] +~~~~~~~~~~~~~~~~~~~~~~ +Suppose x is used strictly; never mind whether it has the CPR +property. I'll use a '*' to mean "x* is demanded strictly". + + let + x* = x-rhs + in body + +splitThunk transforms like this: + let + x* = let x = x-rhs in + case x of { I# a -> I# a } + in body + +This is a little strange: we are re-using the same `x` in the RHS; and +the RHS takes `x` apart and reboxes it. But because the outer 'let' is +strict, and the inner let mentions `x` only once, the simplifier +transform it to + case x-rhs of + I# a -> let x* = I# a + in body + +That is good: in `body` we know the form of `x`, which + * gives the CPR property, and + * allows case-of-case to happen on x + +Notes +* I tried transforming like this: + let + x* = let x = x-rhs in + case x of { I# a -> x } + in body + where I return `x` itself, rather than reboxing it. But this + turned out to cause some regressions, which I never fully + investigated. + +* Suppose x-rhs is itself a case: + x-rhs = case e of { T -> I# e1; F -> I# e2 } + Then we'll get + join j a = let x* = I# a in body + in case e of { T -> j e1; F -> j e2 } + which is good (no boxing). But in the original, unsplit program + we would transform + let x* = case e of ... in body + ==> join j2 x = body + in case e of { T -> j2 (I# e1); F -> j (I# e2) } + which is not good (boxing). + +* In fact, splitThunk uses the function argument w/w splitting + function, mkWWstr_one, so that if x's demand is deeper (say U(U(L,L),L)) + then the splitting will go deeper too. + +* For recursive thunks, the Simplifier is unable to float `x-rhs` out of + `x*`'s RHS, because `x*` occurs freely in `x-rhs`, and will just change it + back to the original definition, so we just split non-recursive thunks. + +Note [Thunk splitting for top-level binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Top-level bindings are never strict. Yet they can be absent, as T14270 shows: + + module T14270 (mkTrApp) where + mkTrApp x y + | Just ... <- ... typeRepKind x ... + = undefined + | otherwise + = undefined + typeRepKind = Tick scc undefined + +(T19180 is a profiling-free test case for this) +Note that `typeRepKind` is not exported and its only use site in +`mkTrApp` guards a bottoming expression. Thus, demand analysis +figures out that `typeRepKind` is absent and splits the thunk to + + typeRepKind = + let typeRepKind = Tick scc undefined in + let typeRepKind = absentError in + typeRepKind + +But now we have a local binding with an External Name +(See Note [About the NameSorts]). That will trigger a CoreLint error, which we +get around by localising the Id for the auxiliary bindings in 'splitThunk'. +-} + +-- | See Note [Thunk splitting]. +-- +-- splitThunk converts the *non-recursive* binding +-- x = e +-- into +-- x = let x' = e in +-- case x' of I# y -> let x' = I# y in x' +-- See comments above. Is it not beautifully short? +-- Moreover, it works just as well when there are +-- several binders, and if the binders are lifted +-- E.g. x = e +-- --> x = let x' = e in +-- case x' of (a,b) -> let x' = (a,b) in x' +-- Here, x' is a localised version of x, in case x is a +-- top-level Id with an External Name, because Lint rejects local binders with +-- External Names; see Note [About the NameSorts] in GHC.Types.Name. +-- +-- How can we do thunk-splitting on a top-level binder? See +-- Note [Thunk splitting for top-level binders]. +splitThunk :: WwOpts -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] +splitThunk ww_opts is_rec x rhs + = assert (not (isJoinId x)) $ + do { let x' = localiseId x -- See comment above + ; (useful,_args, wrap_fn, fn_arg) + <- mkWWstr_one ww_opts x' NotMarkedStrict + ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn fn_arg)) ] + ; if useful then assertPpr (isNonRec is_rec) (ppr x) -- The thunk must be non-recursive + return res + else return [(x, rhs)] } diff --git a/GHC/Core/Opt/WorkWrap/Utils.hs b/GHC/Core/Opt/WorkWrap/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/WorkWrap/Utils.hs @@ -0,0 +1,1870 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +A library for the ``worker\/wrapper'' back-end to the strictness analyser +-} + + +{-# LANGUAGE ViewPatterns #-} + +module GHC.Core.Opt.WorkWrap.Utils + ( WwOpts(..), mkWwBodies, mkWWstr, mkWWstr_one + , needsVoidWorkerArg + , DataConPatContext(..) + , UnboxingDecision(..), canUnboxArg + , findTypeShape, IsRecDataConResult(..), isRecDataCon + , mkAbsentFiller + , isWorkerSmallEnough, dubiousDataConInstArgTys + , boringSplit, usefulSplit, workWrapArity + , canUnboxType, canUnboxTyCon + ) +where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Utils +import GHC.Core.DataCon +import GHC.Core.Make +import GHC.Core.Subst +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.Coercion +import GHC.Core.Predicate( isDictTy ) +import GHC.Core.Reduction +import GHC.Core.FamInstEnv +import GHC.Core.Predicate( isEqualityClass ) +import GHC.Core.TyCon +import GHC.Core.TyCon.Set +import GHC.Core.TyCon.RecWalk +import GHC.Core.SimpleOpt( SimpleOpts ) + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) +import GHC.Types.Var.Env +import GHC.Types.Basic +import GHC.Types.Unique.Supply +import GHC.Types.Name ( getOccFS ) + +import GHC.Data.FastString +import GHC.Data.OrdList +import GHC.Data.List.SetOps + +import GHC.Builtin.Types ( tupleDataCon ) + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Applicative ( (<|>) ) +import Control.Monad ( zipWithM ) +import Data.List ( unzip4 ) + +import GHC.Types.RepType +import GHC.Unit.Types +import GHC.Core.TyCo.Rep + +{- +************************************************************************ +* * +\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@} +* * +************************************************************************ + +Here's an example. The original function is: + +\begin{verbatim} +g :: forall a . Int -> [a] -> a + +g = \/\ a -> \ x ys -> + case x of + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +From this, we want to produce: +\begin{verbatim} +-- wrapper (an unfolding) +g :: forall a . Int -> [a] -> a + +g = \/\ a -> \ x ys -> + case x of + I# x# -> $wg a x# ys + -- call the worker; don't forget the type args! + +-- worker +$wg :: forall a . Int# -> [a] -> a + +$wg = \/\ a -> \ x# ys -> + let + x = I# x# + in + case x of -- note: body of g moved intact + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +Something we have to be careful about: Here's an example: + +\begin{verbatim} +-- "f" strictness: U(P)U(P) +f (I# a) (I# b) = a +# b + +g = f -- "g" strictness same as "f" +\end{verbatim} + +\tr{f} will get a worker all nice and friendly-like; that's good. +{\em But we don't want a worker for \tr{g}}, even though it has the +same strictness as \tr{f}. Doing so could break laziness, at best. + +Consequently, we insist that the number of strictness-info items is +exactly the same as the number of lambda-bound arguments. (This is +probably slightly paranoid, but OK in practice.) If it isn't the +same, we ``revise'' the strictness info, so that we won't propagate +the unusable strictness-info into the interfaces. + + +************************************************************************ +* * +\subsection{The worker wrapper core} +* * +************************************************************************ + +@mkWwBodies@ is called when doing the worker\/wrapper split inside a module. +-} + +data WwOpts + = MkWwOpts + { -- | Environment of type/data family instances + wo_fam_envs :: !FamInstEnvs + , -- | Options for the "Simple optimiser" + wo_simple_opts :: !SimpleOpts + , -- | Whether to enable "Constructed Product Result" analysis. + -- (Originally from DOI: 10.1017/S0956796803004751) + wo_cpr_anal :: !Bool + , -- | Used for absent argument error message + wo_module :: !Module + , -- | Generate workers even if the only effect is some args get passed + -- unlifted. See Note [WW for calling convention] + wo_unlift_strict :: !Bool } + +type WwResult + = ([Demand], -- Demands for worker (value) args + JoinArity, -- Number of worker (type OR value) args + Id -> CoreExpr, -- Wrapper body, lacking only the worker Id + CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs + +nop_fn :: CoreExpr -> CoreExpr +nop_fn body = body + + +mkWwBodies :: WwOpts + -> Id -- ^ The original function + -> Arity -- ^ Worker/wrapper arity + -> [Var] -- ^ Manifest args of original function + -> Type -- ^ Result type of the original function, + -- after being stripped of args + -> [Demand] -- ^ Strictness of original function + -> Cpr -- ^ Info about function result + -> UniqSM (Maybe WwResult) +-- ^ Given a function definition +-- +-- > data T = MkT Int Bool Char +-- > f :: (a, b) -> Int -> T +-- > f = \x y -> E +-- +-- @mkWwBodies _ 'f' ['x::(a,b)','y::Int'] '(a,b)' ['1P(L,L)', '1P(L)'] '1'@ +-- returns +-- +-- * The wrapper body context for the call to the worker function, lacking +-- only the 'Id' for the worker function: +-- +-- > W[_] :: Id -> CoreExpr +-- > W[work_fn] = \x y -> -- args of the wrapper (cloned_arg_vars) +-- > case x of (a, b) -> -- unbox wrapper args (wrap_fn_str) +-- > case y of I# n -> -- +-- > case 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 x y of -- call to the original RHS (call_rhs) +-- > MkT i b c -> (# i, b, c #) -- return CPR transit vars (work_fn_cpr) +-- +-- NB: The wrap_rhs hole is to be filled with the original wrapper RHS +-- @\x y -> E@. This is so that we can also use @w@ to transform stable +-- unfoldings, the lambda args of which may be different than x and y. +-- +-- * Id details for the worker function like demands on arguments and its join +-- arity. +-- +-- All without looking at E (except for beta reduction, see Note [Join points +-- and beta-redexes]), which allows us to apply the same split to function body +-- and its unfolding(s) alike. +-- +mkWwBodies opts fun_id ww_arity arg_vars res_ty demands res_cpr + = do { massertPpr arity_ok + (text "wrong wrapper arity" $$ ppr fun_id $$ ppr arg_vars $$ ppr res_ty $$ ppr demands) + + -- Clone and prepare arg_vars of the original fun RHS + -- See Note [Freshen WW arguments] + -- and Note [Zap IdInfo on worker args] + ; let args_free_tcvs = tyCoVarsOfTypes (res_ty : map varType arg_vars) + empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs) + zapped_arg_vars = map zap_var arg_vars + ; (subst, cloned_arg_vars) <- cloneBndrsM empty_subst zapped_arg_vars + ; let res_ty' = substTyUnchecked subst res_ty + init_str_marks = map (const NotMarkedStrict) cloned_arg_vars + + ; (useful1, work_args_str, wrap_fn_str, fn_args) + <- -- pprTrace "mkWWbodies" (ppr fun_id $$ ppr (arg_vars `zip` cloned_arg_vars) $$ ppr demands) $ + mkWWstr opts cloned_arg_vars init_str_marks + + ; let (work_args, work_marks) = unzip work_args_str + + -- Do CPR w/w. See Note [Always do CPR w/w] + ; (useful2, wrap_fn_cpr, work_fn_cpr) + <- mkWWcpr_entry opts res_ty' res_cpr + + ; let (work_lam_args, work_call_args, work_call_str) + | needsVoidWorkerArg fun_id arg_vars work_args + = addVoidWorkerArg work_args work_marks + | otherwise + = (work_args, work_args, work_marks) + + call_work work_fn = mkVarApps (Var work_fn) work_call_args + call_rhs fn_rhs = mkAppsBeta fn_rhs fn_args + -- See Note [Join points and beta-redexes] + wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work + -- See Note [Call-by-value for worker args] + work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_str) + worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs + worker_args_dmds= [ idDemandInfo v | v <- work_call_args, isId v] + + ; if ((useful1 && not only_one_void_argument) || useful2) + then return (Just (worker_args_dmds, length work_call_args, + wrapper_body, worker_body)) + else return Nothing + } + -- We use an INLINE unconditionally, even if the wrapper turns out to be + -- something trivial like + -- fw = ... + -- f = __inline__ (coerce T fw) + -- The point is to propagate the coerce to f's call sites, so even though + -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent + -- fw from being inlined into f's RHS + where + zap_var v | isTyVar v = v + | otherwise = modifyIdInfo zap_info v + zap_info info -- See Note [Zap IdInfo on worker args] + = info `setOccInfo` noOccInfo + + -- Note [Do not split void functions] + only_one_void_argument + | [d] <- demands + , [v] <- filter isId arg_vars + , isAbsDmd d && isZeroBitTy (idType v) + = True + | otherwise + = False + + n_dmds = length demands + arity_ok | isJoinId fun_id = ww_arity <= n_dmds + | otherwise = ww_arity == n_dmds + +-- | Version of 'GHC.Core.mkApps' that does beta reduction on-the-fly. +-- PRECONDITION: The arg expressions are not free in any of the lambdas binders. +mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr +-- The precondition holds for our call site in mkWwBodies, because all the FVs +-- of as are either cloned_arg_vars (and thus fresh) or fresh worker args. +mkAppsBeta (Lam b body) (a:as) = bindNonRec b a $! mkAppsBeta body as +mkAppsBeta f as = mkApps f as + +-- See Note [Limit w/w arity] +isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool +isWorkerSmallEnough max_worker_args old_n_args vars + = count isId vars <= max old_n_args max_worker_args + -- We count only Free variables (isId) to skip Type, Kind + -- variables which have no runtime representation. + -- Also if the function took 82 arguments before (old_n_args), it's fine if + -- it takes <= 82 arguments afterwards. + +workWrapArity :: Id -> CoreExpr -> Arity +-- See Note [Worker/wrapper arity and join points] in DmdAnal +workWrapArity fn rhs + = case idJoinPointHood fn of + JoinPoint join_arity -> count isId $ fst $ collectNBinders join_arity rhs + NotJoinPoint -> idArity fn + +{- +Note [Always do CPR w/w] +~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we refrained from doing CPR w/w for thunks, on the grounds that +we might duplicate work. But that is already handled by the demand analyser, +which doesn't give the CPR property if w/w might waste work: see +Note [CPR for thunks] in GHC.Core.Opt.DmdAnal. + +And if something *has* been given the CPR property and we don't w/w, it's +a disaster, because then the enclosing function might say it has the CPR +property, but now doesn't and there a cascade of disaster. A good example +is #5920. + +Note [Limit w/w arity] +~~~~~~~~~~~~~~~~~~~~~~~~ +Guard against high worker arity as it generates a lot of stack traffic. +A simplified example is #11565#comment:6 + +Current strategy is very simple: don't perform w/w transformation at all +if the result produces a wrapper with arity higher than -fmax-worker-args +and the number arguments before w/w (see #18122). + +It is a bit all or nothing, consider + + f (x,y) (a,b,c,d,e ... , z) = rhs + +Currently we will remove all w/w ness entirely. But actually we could +w/w on the (x,y) pair... it's the huge product that is the problem. + +Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd +solve f. But we can get a lot of args from deeply-nested products: + + g (a, (b, (c, (d, ...)))) = rhs + +This is harder to spot on an arg-by-arg basis. Previously mkWwStr was +given some "fuel" saying how many arguments it could add; when we ran +out of fuel it would stop w/wing. + +Still not very clever because it had a left-right bias. + +Note [Zap IdInfo on worker args] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have to zap the following IdInfo when re-using arg variables of the original +function for the worker: + + * OccInfo: Dead wrapper args now occur in Apps of the worker's call to the + original fun body. Those occurrences will quickly cancel away with the lambdas + of the fun body in the next run of the Simplifier, but CoreLint will complain + in the meantime, so zap it. + +We zap in mkWwBodies because we need the zapped variables when binding them in +mkWWstr (mkAbsentFiller, specifically). + +Note [Do not split void functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this rather common form of binding: + $j = \x:Void# -> ...no use of x... + +Since x is not used it'll be marked as absent. But there is no point +in w/w-ing because we'll simply add (\y:Void#), see addVoidWorkerArg. + +If x has a more interesting type (eg Int, or Int#), there *is* a point +in w/w so that we don't pass the argument at all. + +************************************************************************ +* * +\subsection{Making wrapper args} +* * +************************************************************************ + +During worker-wrapper stuff we may end up with an unlifted thing +which we want to let-bind without losing laziness. So we +add a void argument. E.g. + + f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z +==> + fw = /\ a -> \void -> E + f = /\ a -> \x y z -> fw realworld + +We use the state-token type which generates no code. +-} + +-- | Whether the worker needs an additional `Void#` arg as per +-- Note [Protecting the last value argument] or +-- Note [Preserving float barriers]. +needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool +needsVoidWorkerArg fn_id wrap_args work_args + = thunk_problem -- See Note [Protecting the last value argument] + || needs_float_barrier -- See Note [Preserving float barriers] + where + -- thunk_problem: see Note [Protecting the last value argument] + -- For join points we are only worried about (4), not (1-4). + -- And (4) can't happen if (null work_args) + -- (We could be more clever, by looking at the result type, but + -- this approach is simple and conservative.) + thunk_problem | isJoinId fn_id = no_value_arg && not (null work_args) + | otherwise = no_value_arg + no_value_arg = not (any isId work_args) + + -- needs_float_barrier: see Note [Preserving float barriers] + needs_float_barrier = wrap_had_barrier && not work_has_barrier + is_float_barrier v = isId v && hasNoOneShotInfo (idOneShotInfo v) + wrap_had_barrier = any is_float_barrier wrap_args + work_has_barrier = any is_float_barrier work_args + +-- | Inserts a `Void#` arg as the last argument. +-- Why last? See Note [Worker/wrapper needs to add void arg last] +addVoidWorkerArg :: [Var] -> [StrictnessMark] + -> ( [Var] -- Lambda bound args + , [Var] -- Args at call site + , [StrictnessMark]) -- str semantics for the worker args +addVoidWorkerArg work_args str_marks + = ( work_args ++ [voidArgId] + , work_args ++ [voidPrimId] + , str_marks ++ [NotMarkedStrict] ) + +{- +Note [Protecting the last value argument] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the user writes (\_ -> E), they might be intentionally disallowing +the sharing of E. Since absence analysis and worker-wrapper are keen +to remove such unused arguments, we add in a void argument to prevent +the function from becoming a thunk. Here are several reasons why turning +a function into a thunk might be bad: + +1) It can create a space leak. e.g. + f x = let y () = [1..x] + in (sum (y ()) + length (y ())) + As written it'll calculate [1..x] twice, and avoid keeping a big + list around. (Of course let-floating may introduce the leak; but + at least w/w doesn't.) + +2) It can prevent inlining *under a lambda*. e.g. + g = \y. [1..100] + f = \t. g () + Here we can inline g under the \t. But we won't if we remove the \y. + +3) It can create an unlifted binding. E.g. + g :: Int -> Int# + g = \x. 30# + Removing the \x would leave an unlifted binding. + +4) It can create a worker of ill-kinded type (#22275). Consider + f :: forall r (a :: TYPE r). () -> a + f x = f x + Here `x` is absent, but if we simply drop it we'd end up with + $wf :: forall r (a :: TYPE r). a + But alas $wf's type is ill-kinded: the kind of (/\r (a::TYPE r).a) + is (TYPE r), which mentions the bound variable `r`. See also + Note [Worker/wrapper needs to add void arg last] + +See also Note [Preserving float barriers] + +NB: Of these, only (1-3) don't apply to a join point, which can be +unlifted even if the RHS is not ok-for-speculation. + +Note [Preserving float barriers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider +``` +let + t = sum [0..x] + f a{os} b[Dmd=A] c{os} = ... t ... +in f 1 2 3 + f 4 5 6 +``` +Here, we would like to drop the argument `b` because it's absent. But doing so +leaves behind only one-shot lambdas, `$wf a{os} c{os} = ...`, and then the +Simplifier will inline `t` into `$wf`, because `$wf` says "I'm only called +once". That's bad, because we lost sharing of `t`! Similarly, FloatIn would +happily float `t` into `$wf`, see Note [Floating in past a lambda group]. + +Why does floating happen after dropping `b` but not before? Because `b` was the +only non-one-shot value lambda left, acting as our "float barrier". + +Definition: A float barrier is a non-one-shot value lambda. +Key insight: If `f` had a float barrier, `$wf` has to have one, too. + +To this end, in `needsVoidWorkerArg`, we check whether the wrapper had a float +barrier and if the worker has none so far. If that is the case, we add a `Void#` +argument at the end as an artificial float barrier. + +The issue is tracked in #21150. It came up when compiling GHC itself, in +GHC.Tc.Gen.Bind.mkEdges. There the key_map thunk was inlined after WW dropped a +leading absent non-one-shot arg. Here are some example wrapper arguments of +which some are absent or one-shot and the resulting worker arguments: + + * \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)... + Wrapper arg `a` was the only float barrier and had been dropped. Hence Void# +p * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c... + Worker arg `c` is a float barrier. + * \a.\b{Abs}.\c{os}... ==> \a.\c{os}... + Worker arg `a` is a float barrier. + * \a{os}.\b{Abs,os}.\c{os}... ==> \a{os}.\c{os}... + Wrapper didn't have a float barrier, no need for Void#. + * \a{Abs,os}.... ==> ... (no value lambda left) + This examples simply demonstrates that preserving float barriers is not + enough to subsume Note [Protecting the last value argument]. + +Executable examples in T21150. + +Note [Worker/wrapper needs to add void arg last] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider point (4) of Note [Protecting the last value argument] + + f :: forall r (a :: TYPE r). () -> a + f x = f x + +As pointed out in (4) we need to add a void argument. But if we add +it /first/ we'd get + + $wf :: Void# -> forall r (a :: TYPE r). a + $wf = ... + +But alas $wf's type is /still/ still-kinded, just as before in (4). +Solution is simple: put the void argument /last/: + + $wf :: forall r (a :: TYPE r). Void# -> a + $wf = ... + +c.f Note [SpecConstr void argument insertion] in GHC.Core.Opt.SpecConstr + +Note [Join points and beta-redexes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Originally, the worker would invoke the original function by calling it with +arguments, thus producing a beta-redex for the simplifier to munch away: + + \x y z -> e => (\x y z -> e) wx wy wz + +Now that we have special rules about join points, however, this is Not Good if +the original function is itself a join point, as then it may contain invocations +of other join points: + + join j1 x = ... + join j2 y = if y == 0 then 0 else j1 y + + => + + join j1 x = ... + join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy + join j2 y = case y of I# y# -> jump $wj2 y# + +There can't be an intervening lambda between a join point's declaration and its +occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix: + + ... + let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y + ... + +Hence we simply do the beta-reduction here. (This would be harder if we had to +worry about hygiene, but luckily wy is freshly generated.) + +Note [Freshen WW arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we do a worker/wrapper split, we must freshen the arg vars of the original +fun RHS because they might shadow each other. E.g. + + f :: forall a. Maybe a -> forall a. Maybe a -> Int -> Int + f @a x @a y z = case x <|> y of + Nothing -> z + Just _ -> z + 1 + + ==> {WW split unboxing the Int} + + $wf :: forall a. Maybe a -> forall a. Maybe a -> Int# -> Int + $wf @a x @a y wz = (\@a x @a y z -> case x <|> y of ...) ??? x @a y (I# wz) + +(Notice that the code we actually emit will sort-of ANF-ise the lambda args, +leading to even more shadowing issues. The above demonstrates that even if we +try harder we'll still get shadowing issues.) + +What should we put in place for ??? ? Certainly not @a, because that would +reference the wrong, inner a. A similar situation occurred in #12562, we even +saw a type variable in the worker shadowing an outer term-variable binding. + +We avoid the issue by freshening the argument variables from the original fun +RHS through 'cloneBndrs', which will also take care of substitution in binder +types. Fortunately, it's sufficient to pick the FVs of the arg vars as in-scope +set, so that we don't need to do a FV traversal over the whole body of the +original function. + +At the moment, #12562 has no regression test. As such, this Note is not covered +by any test logic or when bootstrapping the compiler. Yet we clearly want to +freshen the binders, as the example above demonstrates. +Adding a Core pass that maximises shadowing for testing purposes might help, +see #17478. +-} + +{- +************************************************************************ +* * +\subsection{Unboxing Decision for Strictness and CPR} +* * +************************************************************************ +-} + +-- | The information needed to build a pattern for a DataCon to be unboxed. +-- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via +-- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype +-- wrappers. +-- +-- If we get @DataConPatContext dc tys co@ for some type @ty@ +-- and @dataConRepInstPat ... dc tys = (exs, flds)@, then +-- +-- * @dc @exs flds :: T tys@ +-- * @co :: T tys ~ ty@ +-- +-- 's' will be 'Demand' or 'Cpr'. +data DataConPatContext s + = DataConPatContext + { dcpc_dc :: !DataCon -- INVARIANT: canUnboxTyCon is true of this DataCon's tycon + , dcpc_tc_args :: ![Type] + , dcpc_co :: !Coercion + , dcpc_args :: ![s] + } + +-- | Describes the outer shape of an argument to be unboxed or left as-is +-- Depending on how @s@ is instantiated (e.g., 'Demand' or 'Cpr'). +data UnboxingDecision unboxing_info + = DontUnbox -- ^ We ran out of strictness info. Leave untouched. + | DoUnbox !unboxing_info -- ^ The argument is used strictly or the + -- returned product was constructed, so unbox it. + | DropAbsent -- ^ The argument/field was absent. Drop it. + +instance Outputable i => Outputable (UnboxingDecision i) where + ppr DontUnbox = text "DontUnbox" + ppr DropAbsent = text "DropAbsent" + ppr (DoUnbox i) = text "DoUnbox" <> braces (ppr i) + +-- | Do we want to create workers just for unlifting? +wwUseForUnlifting :: WwOpts -> WwUse +wwUseForUnlifting !opts + -- Always unlift if possible + | wo_unlift_strict opts = usefulSplit + -- Don't unlift it would cause additional W/W splits. + | otherwise = boringSplit + +-- | Is the worker/wrapper split profitable? +type WwUse = Bool + +-- | WW split not profitable +boringSplit :: WwUse +boringSplit = False + +-- | WW split profitable +usefulSplit :: WwUse +usefulSplit = True + +-- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns +-- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon' +-- to unbox. +canUnboxArg + :: FamInstEnvs + -> Type -- ^ Type of the argument + -> Demand -- ^ How the arg was used + -> UnboxingDecision (DataConPatContext Demand) +-- See Note [Which types are unboxed?] +canUnboxArg fam_envs ty (n :* sd) + | isAbs n + = DropAbsent + + -- From here we are strict and not absent + | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty + , Just [dc] <- canUnboxTyCon tc -- tc is never a newtype + , let arity = dataConRepArity dc + , Just (Unboxed, dmds) <- viewProd arity sd -- See Note [Boxity analysis] + , dmds `lengthIs` dataConRepArity dc + = DoUnbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co, dcpc_args = dmds }) + + | otherwise + = DontUnbox + + +-- | Unboxing strategy for constructed results. +canUnboxResult :: FamInstEnvs -> Type -> Cpr + -> UnboxingDecision (DataConPatContext Cpr) +-- See Note [Which types are unboxed?] +canUnboxResult fam_envs ty cpr + | Just (con_tag, arg_cprs) <- asConCpr cpr + , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty + , Just dcs <- canUnboxTyCon tc <|> open_body_ty_warning + , dcs `lengthAtLeast` con_tag -- This might not be true if we import the + -- type constructor via a .hs-boot file (#8743) + , let dc = dcs `getNth` (con_tag - fIRST_TAG) + , null (dataConExTyCoVars dc) -- no existentials; + -- See (CPR1) in Note [Which types are unboxed?] + -- and GHC.Core.Opt.CprAnal.argCprType + -- where we also check this. + , null (dataConTheta dc) -- no constraints; + -- See (CPR2) in Note [Which types are unboxed?] + = DoUnbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co, dcpc_args = arg_cprs }) + + | otherwise + = DontUnbox + + where + -- See Note [non-algebraic or open body type warning] + open_body_ty_warning = warnPprTrace True "canUnboxResult: non-algebraic or open body type" (ppr ty) Nothing + + + +canUnboxType :: HasDebugCallStack => Type -> Maybe [DataCon] +canUnboxType arg_ty = case tyConAppTyCon_maybe arg_ty of + Just tc -> canUnboxTyCon tc + Nothing -> Nothing + +canUnboxTyCon :: HasDebugCallStack => TyCon -> Maybe [DataCon] +-- True for +-- boxed algebraic datatypes +-- unboxed tuples and sums +-- +-- False for +-- class dictionaries, except equality classes and tuples +-- See Note [Do not unbox class dictionaries] +-- +-- Precondition: tc is not a newtype +canUnboxTyCon tc + | Just cls <- tyConClass_maybe tc + , not (isEqualityClass cls) + = Nothing -- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries] + + | otherwise + = assertPpr (not (isNewTyCon tc)) (ppr tc) $ -- Check precondition + tyConDataCons_maybe tc + +{- Note [Do not unbox class dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never unbox class dictionaries in worker/wrapper. + +1. INLINABLE functions + If we have + f :: Ord a => [a] -> Int -> a + {-# INLINABLE f #-} + and we worker/wrapper f, we'll get a worker with an INLINABLE pragma + (see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap), + which can still be specialised by the type-class specialiser, something like + fw :: Ord a => [a] -> Int# -> a + + BUT if f is strict in the Ord dictionary, we might unpack it, to get + fw :: (a->a->Bool) -> [a] -> Int# -> a + and the type-class specialiser can't specialise that. An example is #6056. + + Historical note: #14955 describes how I got this fix wrong the first time. + I got aware of the issue in T5075 by the change in boxity of loop between + demand analysis runs. + +2. -fspecialise-aggressively. As #21286 shows, the same phenomenon can occur + occur without INLINABLE, when we use -fexpose-all-unfoldings and + -fspecialise-aggressively to do vigorous cross-module specialisation. + +3. #18421 found that unboxing a dictionary can also make the worker less likely + to inline; the inlining heuristics seem to prefer to inline a function + applied to a dictionary over a function applied to a bunch of functions. + +TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing +a raft of higher-order functions isn't a huge win anyway -- you really want to +specialise the function. + +Wrinkle (DNB1): we /do not/ to unbox tuple dictionaries either. We used to + have a special case to unbox tuple dictionaries (#23398), but it ultimately + turned out to be a very bad idea (see !19747#note_626297). In summary: + + - If w/w unboxes tuple dictionaries we get things like + case d of CTuple2 d1 d2 -> blah + rather than + let { d1 = sc_sel1 d; d2 = sc_sel2 d } in blah + The latter works much better with the specialiser: when `d` is instantiated + to some useful dictionary the `sc_sel1 d` selection can fire. + + - The attempt to deal with unpacking dictionaries with `case` led to + significant extra complexity in the type-class specialiser (#26158) that is + rendered unnecessary if we only take do superclass selection with superclass + selectors, never with `case` expressions. + + Even with that extra complexity, specialisation was /still/ sometimes worse, + and sometimes /tremendously/ worse (a factor of 70x); see #19747. + + - Suppose f :: forall a. (% Eq a, Show a %) => blah + The specialiser is perfectly capable of specialising a call like + f @Int (% dEqInt, dShowInt %) + so the tuple doesn't get in the way. + + - It's simpler and more uniform. There is nothing special about constraint + tuples; anyone can write class (C1 a, C2 a) => D a where {} + +Wrinkle (DNB2): we /do/ want to unbox equality dictionaries, + for (~), (~~), and Coercible (#23398). Their payload is a single unboxed + coercion. We never want to specialise on `(t1 ~ t2)`. All that would do is + to make a copy of the function's RHS with a particular coercion. Unlike + normal class methods, that does not unlock any new optimisation + opportunities in the specialised RHS. + +Note [Which types are unboxed?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Worker/wrapper will unbox + + 1. A strict data type argument, that + * is an algebraic data type (not a newtype) + * is not recursive (as per 'isRecDataCon') + * has a single constructor (thus is a "product") + * that may bind existentials (#18982) + We can transform + > data D a = forall b. D a b + > f (D @ex a b) = e + to + > $wf @ex a b = e + via 'mkWWstr'. + + 2. The constructed result of a function, if + * its type is an algebraic data type (not a newtype) + * is not recursive (as per 'isRecDataCon') + * (might have multiple constructors, in contrast to (1)) + * the applied data constructor *does not* bind existentials + * nor does it bind constraints (equalities or dictionaries) + We can transform + > f x y = let ... in D a b + to + > $wf x y = let ... in (# a, b #) + via 'mkWWcpr'. + + (CPR1). We don't allow existentials for CPR W/W, because we don't have + unboxed dependent tuples (yet?). Otherwise, we could transform + > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..) + to + > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #) + + (CPR2) we don't allow constraints for CPR W/W, because an unboxed tuple + contains types of kind `TYPE rr`, but not of kind `CONSTRAINT rr`. + This is annoying; there is no real reason for this except that we don't + have TYPE/CONSTAINT polymorphism. See Note [TYPE and CONSTRAINT] + in GHC.Builtin.Types.Prim. + +The respective tests are in 'canUnboxArg' and +'canUnboxResult', respectively. + +Note [mkWWstr and unsafeCoerce] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +By using unsafeCoerce, it is possible to make the number of demands fail to +match the number of constructor arguments; this happened in #8037. +If so, the worker/wrapper split doesn't work right and we get a Core Lint +bug. The fix here is simply to decline to do w/w if that happens. + +Note [non-algebraic or open body type warning] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a few cases where the W/W transformation is told that something +returns a constructor, but the type at hand doesn't really match this. One +real-world example involves unsafeCoerce: + foo = IO a + foo = unsafeCoerce c_exit + foreign import ccall "c_exit" c_exit :: IO () +Here CPR will tell you that `foo` returns a () constructor for sure, but trying +to create a worker/wrapper for type `a` obviously fails. +(This was a real example until ee8e792 in libraries/base.) + +It does not seem feasible to avoid all such cases already in the analyser (and +after all, the analysis is not really wrong), so we simply do nothing here in +mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch +other cases where something went avoidably wrong. + +This warning also triggers for the stream fusion library within `text`. +We can't easily W/W constructed results like `Stream` because we have no simple +way to express existential types in the worker's type signature. + +Note [WW for calling convention] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we know a function f will always evaluate a particular argument +we might decide that it should rather get evaluated by the caller. +We call this "unlifting" the argument. +Sometimes the caller knows that the argument is already evaluated, +so we won't generate any code to enter/evaluate the argument. +This evaluation avoidance can be quite beneficial. +Especially for recursive functions who pass the same lifted argument +along on each iteration or walk over strict data structures. + +One way to achieve this is to do a W/W split, where the wrapper does +the evaluation, and the worker can treat its arguments as unlifted. +The wrapper is small and will be inlined at almost all call sites and +the evaluation code in the wrapper can then cancel out with evaluation +done by the calling context if the argument is evaluated there. +Same idea as W/W to avoid allocation really, just for a different kind +of work. + +Performing W/W might not always be a win. In particular it's easy to break +(badly written, but common) rule frameworks by doing additional W/W splits. +See #20364 for a more detailed explanation. + +Hence we have the following strategies with different trade-offs: + +A) Never do W/W *just* for unlifting of arguments. + + Very conservative - doesn't break any rules + - Lot's of performance left on the table + +B) Do W/W on just about anything where it might be + beneficial. + + Exploits pretty much every opportunity for unlifting. + - A bit of compile time/code size cost for all the wrappers. + - Can break rules which would otherwise fire. See #20364. + +C) Unlift *any* (non-boot exported) functions arguments if they are strict. + That is instead of creating a Worker with the new calling convention we + change the calling convention of the binding itself. + + Exploits every opportunity for unlifting. + + Maybe less bad interactions with rules. + - Requires tracking of boot-exported definitions. + - Requires either: + ~ Eta-expansion at *all* call sites in order to generate + an impedance matcher function. Leading to massive code bloat. + Essentially we end up creating a impromptu wrapper function + wherever we wouldn't inline the wrapper with a W/W approach. + ~ There is the option of achieving this without eta-expansion if we instead expand + the partial application code to check for demands on the calling convention and + for it to evaluate the arguments. The main downsides there would be the complexity + of the implementation and that it carries a certain overhead even for functions who + don't take advantage of this functionality. I haven't tried this approach because it's + not trivial to implement and doing W/W splits seems to work well enough. + +Currently we use the first approach A) by default, with a flag that allows users to fall back to the +more aggressive approach B). + +I also tried the third approach C) using eta-expansion at call sites to avoid modifying the PAP-handling +code which wasn't fruitful. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5614#note_389903. +We could still try to do C) in the future by having PAP calls which will evaluate the required arguments +before calling the partially applied function. But this would be neither a small nor simple change so we +stick with A) and a flag for B) for now. + +See also Note [EPT enforcement] and Note [CBV Function Ids] + +Note [Worker/wrapper for strict arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = case x of + [] -> blah + (y:ys) -> f ys + +Clearly `f` is strict, but its argument is not a product type, so by default +we don't worker/wrapper it. But it is arguably valuable to do so. We could +do this: + + f x = case x of xx { DEFAULT -> $wf xx } + $wf xx = case xx of + [] -> blah + (y:ys) -> f ys + +Now the worker `$wf` knows that its argument `xx` will be evaluated +and properly tagged, so the code for the `case xx` does not need to do +an "eval" (see `GHC.StgToCmm.Expr.cgCase`). A call (f (a:as)) will +have the wrapper inlined, and will drop the `case x`, so no eval +happens at all. + +The worker `$wf` is a CBV function (see `Note [CBV Function Ids]` +in GHC.Types.Id.Info) and the code generator guarantees that every +call to `$wf` has a properly tagged argument (see `GHC.Stg.EnforceEpt.Rewrite`). + +Is this a win? Not always: +* It can cause slight codesize increases. This is since we push evals to every + call sites which there might be many. And the evals will only disappear at + call sites where we already known that the argument is evaluated. + +* It will also cause many more functions to get a worker/wrapper split + which can play badly with rules (see Ticket #20364). In particular + if you depend on rules firing on functions marked as NOINLINE + without marking use sites of these functions as INLINE or INLINEABLE + then things will break. + But if you want a function to match in a RULE, it is /in any case/ good practice to + have a `INLINE[1]` or `NOINLNE[1]` pragma, to ensure that it doesn't inline until + the rule has had a chance to fire. + +So there is a flag, `-fworker-wrapper-cbv`, to control whether we do +w/w on strict arguments (internally `Opt_WorkerWrapperUnlift`). The +flag is off by default. The choice is made in +GHC.Core.Opt.WorkWrape.Utils.wwUseForUnlifting + +See also `Note [WW for calling convention]` in GHC.Core.Opt.WorkWrap.Utils +-} + +{- +************************************************************************ +* * +\subsection{Worker/wrapper for Strictness and Absence} +* * +************************************************************************ +-} + +mkWWstr :: WwOpts + -> [Var] -- Wrapper args; have their demand info on them + -- *Includes type variables* + -> [StrictnessMark] -- Strictness-mark info for arguments + -> UniqSM (WwUse, -- Will this result in a useful worker + [(Var,StrictnessMark)], -- Worker args/their call-by-value semantics. + CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call + -- and without its lambdas + -- This fn adds the unboxing + [CoreExpr]) -- Reboxed args for the call to the + -- original RHS. Corresponds one-to-one + -- with the wrapper arg vars +mkWWstr opts args str_marks + = -- pprTrace "mkWWstr" (ppr args) $ + go args str_marks + where + go [] _ = return (boringSplit, [], nop_fn, []) + go (arg : args) (str:strs) + = do { (useful1, args1, wrap_fn1, wrap_arg) <- mkWWstr_one opts arg str + ; (useful2, args2, wrap_fn2, wrap_args) <- go args strs + ; return ( useful1 || useful2 + , args1 ++ args2 + , wrap_fn1 . wrap_fn2 + , wrap_arg:wrap_args ) } + go _ _ = panic "mkWWstr: Impossible - str/arg length mismatch" + +---------------------- +-- mkWWstr_one wrap_var = (useful, work_args, wrap_fn, wrap_arg) +-- * wrap_fn assumes wrap_var is in scope, +-- brings into scope work_args (via cases) +-- * wrap_arg assumes work_args are in scope, and builds a ConApp that +-- reconstructs the RHS of wrap_var that we pass to the original RHS +-- See Note [Worker/wrapper for Strictness and Absence] +mkWWstr_one :: WwOpts + -> Var + -> StrictnessMark + -> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr) +mkWWstr_one opts arg str_mark = + -- pprTrace "mkWWstr_one" (ppr arg <+> (if isId arg then ppr arg_ty $$ ppr arg_dmd else text "type arg")) $ + case canUnboxArg fam_envs arg_ty arg_dmd of + _ | isTyVar arg -> do_nothing + + DropAbsent + | Just absent_filler <- mkAbsentFiller opts arg str_mark + -- Absent case. Drop the argument from the worker. + -- We can't always handle absence for arbitrary + -- unlifted types, so we need to choose just the cases we can + -- (that's what mkAbsentFiller does) + -> return (usefulSplit, [], nop_fn, absent_filler) + | otherwise -> do_nothing + + DoUnbox dcpc -> -- pprTrace "mkWWstr_one:1" (ppr (dcpc_dc dcpc) <+> ppr (dcpc_tc_args dcpc) $$ ppr (dcpc_args dcpc)) $ + unbox_one_arg opts arg dcpc + + DontUnbox + | isStrictDmd arg_dmd || isMarkedStrict str_mark + , wwUseForUnlifting opts -- See Note [CBV Function Ids] + , not (isFunTy arg_ty) + , not (isUnliftedType arg_ty) -- Already unlifted! + -- NB: function arguments have a fixed RuntimeRep, + -- so it's OK to call isUnliftedType here + -> return (usefulSplit, [(arg, MarkedStrict)], nop_fn, varToCoreExpr arg ) + + | otherwise -> do_nothing + + where + fam_envs = wo_fam_envs opts + arg_ty = idType arg + arg_dmd = idDemandInfo arg + arg_str | isTyVar arg = NotMarkedStrict -- Type args don't get strictness marks + | otherwise = str_mark + do_nothing = return (boringSplit, [(arg,arg_str)], nop_fn, varToCoreExpr arg) + +unbox_one_arg :: WwOpts + -> Var -> DataConPatContext Demand + -> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr) +unbox_one_arg opts arg_var + DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co, dcpc_args = ds } + = do { pat_bndrs_uniqs <- getUniquesM + ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc + + -- Create new arguments we get when unboxing dc + (ex_tvs', arg_ids) = dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) + pat_bndrs_uniqs (idMult arg_var) dc tc_args + con_str_marks = dataConRepStrictness dc + + -- Apply str info to new args. Also remove OtherCon unfoldings so they + -- don't end up in lambda binders of the worker. + -- See Note [Never put `OtherCon` unfoldings on lambda binders] + arg_ids' = map zapIdUnfolding $ + zipWithEqual setIdDemandInfo arg_ids ds + + unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var) + dc (ex_tvs' ++ arg_ids') + + -- Mark arguments coming out of strict fields so we can seq them in the worker + -- See Note [Call-by-value for worker args] + all_str_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks + + ; (nested_useful, worker_args, wrap_fn, wrap_args) + <- mkWWstr opts (ex_tvs' ++ arg_ids') all_str_marks + + ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co + -- See Note [Unboxing through unboxed tuples] + ; return $ if isUnboxedTupleDataCon dc && not nested_useful + then (boringSplit, [(arg_var,NotMarkedStrict)], nop_fn, varToCoreExpr arg_var) + else (usefulSplit, worker_args, unbox_fn . wrap_fn, wrap_arg) } + +-- | Tries to find a suitable absent filler to bind the given absent identifier +-- to. See Note [Absent fillers]. +-- +-- If @mkAbsentFiller _ id == Just e@, then @e@ is an absent filler with the +-- same type as @id@. Otherwise, no suitable filler could be found. +mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr +mkAbsentFiller opts arg str + -- The lifted case: bind 'absentError'. See (AF1) in Note [Absent fillers] + -- We want to use this case if possible, because we get a nice runtime panic message + -- if we are wrong (like we were in #11126). Otherwise we fall through to the + -- less-desirable mkLitRubbish case. + | mightBeLiftedType arg_ty + , not (isDictTy arg_ty) -- See (AF4) in Note [Absent fillers] + , not (isStrictDmd (idDemandInfo arg)) -- See (AF2) + , not (isMarkedStrict str) -- in Note [Absent fillers] + = Just (mkAbsentErrorApp arg_ty msg) + + -- The default case for mono rep: Bind `RUBBISH[rr] arg_ty` + -- See Note [Absent fillers] + -- (AF3): mkLitRubbish returns Nothing if the representation is not + -- monomorphic, in which case we can't make a filler + | otherwise + = mkLitRubbish arg_ty + + where + arg_ty = idType arg + + msg = renderWithContext + (defaultSDocContext { sdocSuppressUniques = True }) + (vcat + [ text "Arg:" <+> ppr arg + , text "Type:" <+> ppr arg_ty + , file_msg ]) + -- We need to suppress uniques here because otherwise they'd + -- end up in the generated code as strings. This is bad for + -- determinism, because with different uniques the strings + -- will have different lengths and hence different costs for + -- the inliner leading to different inlining. + -- See also Note [Unique Determinism] in GHC.Types.Unique + file_msg = text "In module" <+> quotes (ppr $ wo_module opts) + +{- Note [Worker/wrapper for Strictness and Absence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The worker/wrapper transformation, mkWWstr_one, takes concrete action +based on the 'UnboxingDecision' returned by 'canUnboxArg'. +The latter takes into account several possibilities to decide if the +function is worthy for splitting: + +1. If an argument is absent, it would be silly to pass it to + the worker. Hence the DropAbsent case. This case must come + first because the bottom demand B is also strict. + E.g. B comes from a function like + f x = error "urk" + and the absent demand A can come from Note [Unboxing evaluated arguments] + in GHC.Core.Opt.DmdAnal. + +2. If the argument is evaluated strictly (or known to be eval'd), + we can take a view into the product demand ('viewProd'). In accordance + with Note [Boxity analysis], 'canUnboxArg' will say 'DoUnbox'. + 'mkWWstr_one' then follows suit it and recurses into the fields of the + product demand. For example + + f :: (Int, Int) -> Int + f p = (case p of (a,b) -> a) + 1 + is split to + f :: (Int, Int) -> Int + f p = case p of (a,b) -> $wf a + + $wf :: Int -> Int + $wf a = a + 1 + + and + g :: Bool -> (Int, Int) -> Int + g c p = case p of (a,b) -> + if c then a else b + is split to + g c p = case p of (a,b) -> $gw c a b + $gw c a b = if c then a else b + +2a But do /not/ unbox if Boxity Analysis said "Boxed". + In this case, 'canUnboxArg' returns 'DontUnbox'. + Otherwise we risk decomposing and reboxing a massive + tuple which is barely used. Example: + + f :: ((Int,Int) -> String) -> (Int,Int) -> a + f g pr = error (g pr) + + main = print (f fst (1, error "no")) + + Here, f does not take 'pr' apart, and it's stupid to do so. + Imagine that it had millions of fields. This actually happened + in GHC itself where the tuple was DynFlags + +2b But if e.g. a large tuple or product type is always demanded we might + decide to "unlift" it. That is tighten the calling convention for that + argument to require it to be passed as a pointer to the value itself. + See Note [WW for calling convention]. + +3. In all other cases (e.g., lazy, used demand and not eval'd), + 'finaliseArgBoxities' will have cleared the Boxity flag to 'Boxed' + (see Note [Finalising boxity for demand signatures] in GHC.Core.Opt.DmdAnal) + and 'canUnboxArg' returns 'DontUnbox' so that 'mkWWstr_one' + stops unboxing. + +Note [Worker/wrapper for bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used not to split if the result is bottom. +[Justification: there's no efficiency to be gained.] + +But it's sometimes bad not to make a wrapper. Consider + fw = \x# -> let x = I# x# in case e of + p1 -> error_fn x + p2 -> error_fn x + p3 -> the real stuff +The re-boxing code won't go away unless error_fn gets a wrapper too. +[We don't do reboxing now, but in general it's better to pass an +unboxed thing to f, and have it reboxed in the error cases....] + +Note [Record evaluated-ness in worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + data T = MkT !Int Int + + f :: T -> T + f x = e + +and f's is strict, and has the CPR property. The we are going to generate +this w/w split + + f x = case x of + MkT x1 x2 -> case $wf x1 x2 of + (# r1, r2 #) -> MkT r1 r2 + + $wfw x1 x2 = let x = MkT x1 x2 in + case e of + MkT r1 r2 -> (# r1, r2 #) + +Note that + +* In the worker $wf, inside 'e' we can be sure that x1 will be + evaluated (it came from unpacking the argument MkT. But that's no + immediately apparent in $wf + +* In the wrapper 'f', which we'll inline at call sites, we can be sure + that 'r1' has been evaluated (because it came from unpacking the result + MkT. But that is not immediately apparent from the wrapper code. + +Missing these facts isn't unsound, but it loses possible future +opportunities for optimisation. + +Solution: use setCaseBndrEvald when creating + (A) The arg binders x1,x2 in mkWstr_one via mkUnpackCase + See #13077, test T13077 + (B) The result binders r1,r2 in mkWWcpr_entry + See Trace #13077, test T13077a + And #13027 comment:20, item (4) +to record that the relevant binder is evaluated. + +Note [Absent fillers] +~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T = MkT [Int] [Int] ![Int] -- NB: last field is strict + f :: T -> Int# -> blah + f ps w = case ps of MkT xs ys zs -> + +Then f gets a strictness sig of . We make a worker $wf thus: + + $wf :: [Int] -> blah + $wf xs = case ps of MkT xs _ _ -> + where + ys = absentError "ys :: [Int]" + zs = RUBBISH[LiftedRep] @[Int] + ps = MkT xs ys zs + w = RUBBISH[IntRep] @Int# + +The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker. +And neither should they! They are never used, their value is irrelevant (hence +they are *dead code*) and they are probably discarded after the next run of the +Simplifier (when they are in fact *unreachable code*). Yet, we have to come up +with "filler" values that we bind the absent arg Ids to. + +That is exactly what Note [Rubbish literals] are for: A convenient way to +conjure filler values at any type (and any representation or levity!). + +Needless to say, there are some wrinkles: + +(AF1) In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk + instead. If absence analysis was wrong (e.g., #11126) and the binding + in fact is used, then we get a nice panic message instead of undefined + runtime behavior (See Modes of failure from Note [Rubbish literals]). + + Obviously, we can't use an error-thunk if the value is of unlifted rep + (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic. + +(AF2) We also mustn't put an error-thunk (that fills in for an absent value of + lifted rep) in a strict field, because #16970 establishes the invariant + that strict fields are always evaluated, by possibly (re-)evaluating what is put in + a strict field. That's the reason why 'zs' binds a rubbish literal instead + of an error-thunk, see #19133. + + How do we detect when we are about to put an error-thunk in a strict field? + Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field. So that's + what we do! + + There are other necessary conditions for strict fields: + Note [Unboxing evaluated arguments] in DmdAnal makes it so that the demand on + 'zs' is absent and /strict/: It will get cardinality 'C_10', the empty + interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It further + guarantees e never fill in an error-thunk for an absent strict field. + But that also means we emit a rubbish lit for other args that have + cardinality 'C_10' (say, the arg to a bottoming function) where we could've + used an error-thunk. + NB from Andreas: But I think using an error thunk there would be dodgy no matter what + for example if we decide to pass the argument to the bottoming function cbv. + As we might do if the function in question is a worker. + See Note [CBV Function Ids] in GHC.Types.Id.Info. So I just left the strictness check + in place on top of threading through the marks from the constructor. It's a *really* cheap + and easy check to make anyway. + +(AF3) We can only emit a LitRubbish if the arg's type `arg_ty` is mono-rep, e.g. + of the form `TYPE rep` where `rep` is not (and doesn't contain) a variable. + Why? Because if we don't know its representation (e.g. size in memory, + register class), we don't know what or how much rubbish to emit in codegen. + 'mkLitRubbish' returns 'Nothing' in this case and we simply fall + back to passing the original parameter to the worker. + + Note that currently this case should not occur, because binders always + have to be representation monomorphic. But in the future, we might allow + levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'. + +(AF4) Consider (#24934) + f :: (a~b) => blah {-# INLINE f #-} + f d x = case eq_sel d of co -> body + In #24934 it turned out that `co` was unused; and we discarded the + entire case-scrutinisation via the `exprOkToDiscard` test in + `GHC.Core.Opt.Simplify.Iteration.rebuildCase`. So now `d` is absent. + But in the /unfolding/ for some reason we did not discard the `case`; + so when we inline `f` we end up evaluating that `d` argument. So we had + better not replace it with an error thunk! + + The root of it is this: `exprOkToDiscard` assumes that a dictionary is + non-bottom (Note [exprOkForSpeculation and type classes]); but then we replace + the (a~b) dictionary with an error thunk, breaking the invariant that every + dictionary is non-bottom. (If -XDictsStrict is on, the invariant is even + more important.) + + Simple solution: never use an error thunk for a dictionary; instead fall + through to mkRubbishLit. (The only downside is that we lose the compiler + debugging advantages of (AF1).) + + This is quite delicate. + +While (AF1) and (AF2) are simply an optimisation in terms of compiler debugging +experience, (AF3) should be irrelevant in most programs, if not all. + +Historical note: I did try the experiment of using an error thunk for unlifted +things too, relying on the simplifier to drop it as dead code. But this is +fragile + + - It fails when profiling is on, which disables various optimisations + + - It fails when reboxing happens. E.g. + data T = MkT Int Int# + f p@(MkT a _) = ...g p.... + where g is /lazy/ in 'p', but only uses the first component. Then + 'f' is /strict/ in 'p', and only uses the first component. So we only + pass that component to the worker for 'f', which reconstructs 'p' to + pass it to 'g'. Alas we can't say + ...f (MkT a (absentError Int# "blah"))... + because `MkT` is strict in its Int# argument, so we get an absentError + exception when we shouldn't. Very annoying! + +Note [Unboxing through unboxed tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We should not to a worker/wrapper split just for unboxing the components of +an unboxed tuple (in the result *or* argument, #22388). Consider + boring_res x y = (# y, x #) +It's entirely pointless to split for the constructed unboxed pair to + $wboring_res x y = (# y, x #) + boring_res = case $wboring_res x y of (# a, b #) -> (# a, b #) +`boring_res` will immediately simplify to an alias for `$wboring_res`! + +Similarly, the unboxed tuple might occur in argument position + boring_arg (# x, y, z #) = (# z, x, y #) +It's entirely pointless to "unbox" the triple + $wboring_arg x y z = (# z, x, y #) + boring_arg (# x, y, z #) = $wboring_arg x y z +because after unarisation, `boring_arg` is just an alias for `$wboring_arg`. + +Conclusion: Only consider unboxing an unboxed tuple useful when we will +also unbox its components. That is governed by the `usefulSplit` mechanism. + +************************************************************************ +* * + Type scrutiny that is specific to demand analysis +* * +************************************************************************ +-} + +-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that +-- the 'DataCon' may not have existentials. The lack of cloning the +-- existentials this function \"dubious\"; only use it where type variables +-- aren't substituted for! Why may the data con bind existentials? +-- See Note [Which types are unboxed?] +dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type] +dubiousDataConInstArgTys dc tc_args = arg_tys + where + univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyCoVars dc + univ_subst = zipTvSubst univ_tvs tc_args + (full_subst, _) = substTyVarBndrs univ_subst ex_tvs + arg_tys = map (substTy full_subst . scaledThing) $ + dataConRepArgTys dc + -- NB: use substTyVarBndrs on ex_tvs to ensure that we + -- substitute in their kinds. For example (#22849) + -- Consider data T a where + -- MkT :: forall k (t::k->*) (ix::k). t ix -> T @k a + -- Then dubiousDataConInstArgTys MkT [Type, Foo] should return + -- [Foo (ix::Type)], not [Foo (ix::k)]! + +findTypeShape :: FamInstEnvs -> Type -> TypeShape +-- Uncover the arrow and product shape of a type +-- The data type TypeShape is defined in GHC.Types.Demand +-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal +findTypeShape fam_envs ty + = go (setRecTcMaxBound 2 initRecTc) ty + -- You might think this bound of 2 is low, but actually + -- I think even 1 would be fine. This only bites for recursive + -- product types, which are rare, and we really don't want + -- to look deep into such products -- see #18034 + where + go rec_tc ty + | Just (_, _, _, res) <- splitFunTy_maybe ty + = TsFun (go rec_tc res) + + | Just (tc, tc_args) <- splitTyConApp_maybe ty + = go_tc rec_tc tc tc_args + + | Just (_, ty') <- splitForAllTyCoVar_maybe ty + = go rec_tc ty' + + | otherwise + = TsUnk + + go_tc rec_tc tc tc_args + | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args + = go rec_tc rhs + + | not (isNewTyCon tc) + , Just con <- tyConSingleDataCon_maybe tc + , Just rec_tc <- if isTupleTyCon tc + then Just rec_tc + else checkRecTc rec_tc tc + -- We treat tuples specially because they can't cause loops. + -- Maybe we should do so in checkRecTc. + -- The use of 'dubiousDataConInstArgTys' is OK, since this + -- function performs no substitution at all, hence the uniques + -- don't matter. + -- We really do encounter existentials here, see + -- Note [Which types are unboxed?] for an example. + = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args)) + + | Just (ty', _) <- instNewTyCon_maybe tc tc_args + , Just rec_tc <- checkRecTc rec_tc tc + = go rec_tc ty' + + | otherwise + = TsUnk + +-- | Returned by 'isRecDataCon'. +-- See also Note [Detecting recursive data constructors]. +data IsRecDataConResult + = DefinitelyRecursive -- ^ The algorithm detected a loop + | NonRecursiveOrUnsure -- ^ The algorithm detected no loop, went out of fuel + -- or hit an .hs-boot file + deriving (Eq, Show) + +instance Outputable IsRecDataConResult where + ppr = text . show + +combineIRDCR :: IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult +combineIRDCR DefinitelyRecursive _ = DefinitelyRecursive +combineIRDCR _ DefinitelyRecursive = DefinitelyRecursive +combineIRDCR _ _ = NonRecursiveOrUnsure + +combineIRDCRs :: [IsRecDataConResult] -> IsRecDataConResult +combineIRDCRs = foldl' combineIRDCR NonRecursiveOrUnsure +{-# INLINE combineIRDCRs #-} + +-- | @isRecDataCon _ fuel dc@, where @tc = dataConTyCon dc@ returns +-- +-- * @DefinitelyRecursive@ if the analysis found that @tc@ is reachable +-- through one of @dc@'s @arg_tys@. +-- * @NonRecursiveOrUnsure@ if the analysis found that @tc@ is not reachable +-- through one of @dc@'s fields (so surely non-recursive). +-- * @NonRecursiveOrUnsure@ when @fuel /= Infinity@ +-- and @fuel@ expansions of nested data TyCons were not enough to prove +-- non-recursiveness, nor arrive at an occurrence of @tc@ thus proving +-- recursiveness. (So not sure if non-recursive.) +-- * @NonRecursiveOrUnsure@ when we hit an abstract TyCon (one without +-- visible DataCons), such as those imported from .hs-boot files. +-- Similarly for stuck type and data families. +-- +-- If @fuel = 'Infinity'@ and there are no boot files involved, then the result +-- is never @Nothing@ and the analysis is a depth-first search. If @fuel = 'Int' +-- f@, then the analysis behaves like a depth-limited DFS and returns @Nothing@ +-- if the search was inconclusive. +-- +-- See Note [Detecting recursive data constructors] for which recursive DataCons +-- we want to flag. +isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult +isRecDataCon fam_envs fuel orig_dc + | isTupleDataCon orig_dc || isUnboxedSumDataCon orig_dc + = NonRecursiveOrUnsure + | otherwise + = -- pprTraceWith "isRecDataCon" (\answer -> ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer) $ + go_dc fuel emptyTyConSet orig_dc + where + go_dc :: IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult + go_dc fuel visited_tcs dc = + combineIRDCRs [ go_arg_ty fuel visited_tcs arg_ty + | arg_ty <- map scaledThing (dataConRepArgTys dc) ] + + go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult + go_arg_ty fuel visited_tcs ty = -- pprTrace "arg_ty" (ppr ty) $ + case coreFullView ty of + TyConApp tc tc_args -> go_tc_app fuel visited_tcs tc tc_args + -- See Note [Detecting recursive data constructors], points (B) and (C) + + ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty' + -- See Note [Detecting recursive data constructors], point (A) + + CastTy ty' _ -> go_arg_ty fuel visited_tcs ty' + + AppTy f a -> go_arg_ty fuel visited_tcs f `combineIRDCR` go_arg_ty fuel visited_tcs a + -- See Note [Detecting recursive data constructors], point (D) + + FunTy{} -> NonRecursiveOrUnsure + -- See Note [Detecting recursive data constructors], point (1) + + -- (TyVarTy{} | LitTy{} | CastTy{}) + _ -> NonRecursiveOrUnsure + + go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult + go_tc_app fuel visited_tcs tc tc_args = + case tyConDataCons_maybe tc of + ---_ | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False -> undefined + _ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args + -- This is the only place where we look at tc_args, which might have + -- See Note [Detecting recursive data constructors], point (C) and (5) + -> go_arg_ty fuel visited_tcs rhs + + _ | tc == dataConTyCon orig_dc + -> DefinitelyRecursive -- loop found! + + Just dcs + | DefinitelyRecursive <- combineIRDCRs [ go_arg_ty fuel visited_tcs' ty | ty <- tc_args ] + -- Check tc_args, See Note [Detecting recursive data constructors], point (5) + -- The new visited_tcs', so that we don't recursively check tc, + -- promising that we will check it below. + -- Do the tc_args check *before* the dcs check below, otherwise + -- we might miss an obvious rec occ in tc_args when we run out of + -- fuel and respond NonRecursiveOrUnsure instead + -> DefinitelyRecursive + + | fuel >= 0 + -- See Note [Detecting recursive data constructors], point (4) + , not (tc `elemTyConSet` visited_tcs) + -- only need to check tc if we haven't visited it already. NB: original visited_tcs + -> combineIRDCRs [ go_dc (subWithInf fuel 1) visited_tcs' dc | dc <- dcs ] + -- Finally: check ds + + _ -> NonRecursiveOrUnsure + where + visited_tcs' = extendTyConSet visited_tcs tc + +{- +************************************************************************ +* * +\subsection{Worker/wrapper for CPR} +* * +************************************************************************ +See Note [Worker/wrapper for CPR] for an overview. +-} + +mkWWcpr_entry + :: WwOpts + -> Type -- function body + -> Cpr -- CPR analysis results + -> UniqSM (WwUse, -- Is w/w'ing useful? + CoreExpr -> CoreExpr, -- New wrapper. 'nop_fn' if not useful + CoreExpr -> CoreExpr) -- New worker. 'nop_fn' if not useful +-- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview. +mkWWcpr_entry opts body_ty body_cpr + | not (wo_cpr_anal opts) = return (boringSplit, nop_fn, nop_fn) + | otherwise = do + -- Part (1) + res_bndr <- mk_res_bndr body_ty + let bind_res_bndr body scope = mkDefaultCase body res_bndr scope + + -- Part (2) + (useful, fromOL -> transit_vars, rebuilt_result, work_unpack_res) <- + mkWWcpr_one opts res_bndr body_cpr + + -- Part (3) + let (unbox_transit_tup, transit_tup) = move_transit_vars transit_vars + + -- Stacking unboxer (work_fn) and builder (wrap_fn) together + let wrap_fn = unbox_transit_tup rebuilt_result -- 3 2 + work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3 + return $ if not useful + then (boringSplit, nop_fn, nop_fn) + else (usefulSplit, wrap_fn, work_fn) + +-- | Part (1) of Note [Worker/wrapper for CPR]. +mk_res_bndr :: Type -> UniqSM Id +mk_res_bndr body_ty = do + -- See Note [Linear types and CPR] + bndr <- mkSysLocalOrCoVarM ww_prefix cprCaseBndrMult body_ty + -- See Note [Record evaluated-ness in worker/wrapper] + pure (setCaseBndrEvald MarkedStrict bndr) + +-- | What part (2) of Note [Worker/wrapper for CPR] collects. +-- +-- 1. A 'WwUse' capturing whether the split does anything useful. +-- 2. The list of transit variables (see the Note). +-- 3. The result builder expression for the wrapper. The original case binder if not useful. +-- 4. The result unpacking expression for the worker. 'nop_fn' if not useful. +type CprWwResultOne = (WwUse, OrdList Var, CoreExpr , CoreExpr -> CoreExpr) +type CprWwResultMany = (WwUse, OrdList Var, [CoreExpr], CoreExpr -> CoreExpr) + +mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany +mkWWcpr _opts vars [] = + -- special case: No CPRs means all top (for example from FlatConCpr), + -- hence stop WW. + return (boringSplit, toOL vars, map varToCoreExpr vars, nop_fn) +mkWWcpr opts vars cprs = do + -- No existentials in 'vars'. 'canUnboxResult' should have checked that. + massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs) + massertPpr (equalLength vars cprs) (ppr vars $$ ppr cprs) + (usefuls, varss, rebuilt_results, work_unpack_ress) <- + unzip4 <$> zipWithM (mkWWcpr_one opts) vars cprs + return ( or usefuls + , concatOL varss + , rebuilt_results + , foldl' (.) nop_fn work_unpack_ress ) + +mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResultOne +-- ^ See if we want to unbox the result and hand off to 'unbox_one_result'. +mkWWcpr_one opts res_bndr cpr + | assert (not (isTyVar res_bndr) ) True + , DoUnbox dcpc <- canUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr + = unbox_one_result opts res_bndr dcpc + | otherwise + = return (boringSplit, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn) + +unbox_one_result + :: WwOpts -> Id -> DataConPatContext Cpr -> UniqSM CprWwResultOne +-- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR] +unbox_one_result opts res_bndr + DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co, dcpc_args = arg_cprs } = do + -- unboxer (free in `res_bndr`): | builder (where builds what was + -- ( case res_bndr of (i, j) -> ) | bound to i) + -- ( case i of I# a -> ) | + -- ( case j of I# b -> ) | ( (, ) ) + -- ( ) | + pat_bndrs_uniqs <- getUniquesM + let (_exs, arg_ids) = + dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args + massert (null _exs) -- Should have been caught by canUnboxResult + + (nested_useful, transit_vars, con_args, work_unbox_res) <- + mkWWcpr opts arg_ids arg_cprs + + let -- rebuilt_result = (C a b |> sym co) + rebuilt_result = mkConApp dc (map Type tc_args ++ con_args) `mkCast` mkSymCo co + -- this_work_unbox_res alt = (case res_bndr |> co of C a b -> [a,b]) + this_work_unbox_res = mkUnpackCase (Var res_bndr) co cprCaseBndrMult dc arg_ids + + -- See Note [Unboxing through unboxed tuples] + return $ if isUnboxedTupleDataCon dc && not nested_useful + then ( boringSplit, unitOL res_bndr, Var res_bndr, nop_fn ) + else ( usefulSplit + , transit_vars + , rebuilt_result + , this_work_unbox_res . work_unbox_res + ) + +-- | Implements part (3) of Note [Worker/wrapper for CPR]. +-- +-- If `move_transit_vars [a,b] = (unbox, tup)` then +-- * `a` and `b` are the *transit vars* to be returned from the worker +-- to the wrapper +-- * `unbox scrut alt = (case of (# a, b #) -> )` +-- * `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 of a -> )` + -- * 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 of (# a, b #) -> )` + -- * Worker: `tup = (# a, b #)` + = ( \build_res wkr_call -> mkSingleAltCase wkr_call case_bndr + (DataAlt tup_con) vars build_res + , ubx_tup_app ) + where + ubx_tup_app = mkCoreUnboxedTuple (map varToCoreExpr vars) + tup_con = tupleDataCon Unboxed (length vars) + -- See also Note [Linear types and CPR] + case_bndr = mkWildValBinder cprCaseBndrMult (exprType ubx_tup_app) + + +{- Note [Worker/wrapper for CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'mkWWcpr_entry' is the entry-point to the worker/wrapper transformation that +exploits CPR info. Here's an example: +``` + f :: ... -> (Int, Int) + f ... = +``` +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 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 of (# a, b #) -> ) -- (3) + ( (I# a, I# b) ) -- (2) + ``` + * The result type of the worker, e.g., `(# Int#, Int# #)` above. + +To achieve said transformation, 'mkWWcpr_entry' + + 1. First allocates a fresh result binder `r`, giving a name to the `body` + expression and contributing part (1) of the unpacker and builder. + 2. Then it delegates to 'mkWWcpr_one', which recurses into all result fields + to unbox, contributing the parts marked with (2). Crucially, it knows + what belongs in the case scrutinee of the unpacker through the communicated + Id `r`: The unpacking expression will be free in that variable. + (This is a similar contract as that of 'mkWWstr_one' for strict args.) + 3. 'mkWWstr_one' produces a bunch of *transit vars*: Those result variables + that have to be transferred from the worker to the wrapper, where the + constructed result can be rebuilt, `a` and `b` above. Part (3) is + responsible for tupling them up in the worker and taking the tuple apart + in the wrapper. This is implemented in 'move_transit_vars'. + +Note [No unboxed tuple for single, unlifted transit var] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When there's only a single, unlifted transit var (Note [Worker/wrapper for CPR]), +we don't wrap an unboxed singleton tuple around it (which otherwise would be +needed to suspend evaluation) and return the unlifted thing directly. E.g. +``` + f :: Int -> Int + f x = x+1 +``` +We certainly want `$wf :: Int# -> Int#`, not `$wf :: Int# -> (# Int# #)`. +This is OK as long as we know that evaluation of the returned thing terminates +quickly, as is the case for fields of unlifted type like `Int#`. + +But more generally, this should also be true for *lifted* types that terminate +quickly! Consider from `T18109`: +``` + data F = F (Int -> Int) + f :: Int -> F + f n = F (+n) + + data T = T (Int, Int) + g :: T -> T + g t@(T p) = p `seq` t + + data U = U ![Int] + h :: Int -> U + h n = U [0..n] +``` +All of the nested fields are actually ok-for-speculation and thus OK to +return unboxed instead of in an unboxed singleton tuple: + + 1. The field of `F` is a HNF. + We want `$wf :: Int -> Int -> Int`. + We get `$wf :: Int -> (# Int -> Int #)`. + 2. The field of `T` is `seq`'d in `g`. + We want `$wg :: (Int, Int) -> (Int, Int)`. + We get `$wg :: (Int, Int) -> (# (Int, Int) #)`. + 3. The field of `U` is strict and thus always evaluated. + We want `$wh :: Int# -> [Int]`. + We'd get `$wh :: Int# -> (# [Int] #)`. + +By considering vars as unlifted that satisfy 'exprIsHNF', we catch (3). +Why not check for 'exprOkForSpeculation'? Quite perplexingly, evaluated vars +are not ok-for-spec, see Note [exprOkForSpeculation and evaluated variables]. +For (1) and (2) we would have to look at the term. WW only looks at the +type and the CPR signature, so the only way to fix (1) and (2) would be to +have a nested termination signature, like in MR !1866. + +Note [Linear types and CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Remark on linearity: in both the case of the wrapper and the worker, +we build a linear case to unpack constructed products. All the +multiplicity information is kept in the constructors (both C and (#, #)). +In particular (#,#) is parameterised by the multiplicity of its fields. +Specifically, in this instance, the multiplicity of the fields of (#,#) +is chosen to be the same as those of C. + + +************************************************************************ +* * +\subsection{Utilities} +* * +************************************************************************ +-} + +mkUnpackCase :: CoreExpr -> Coercion -> Mult -> DataCon -> [Id] -> CoreExpr -> CoreExpr +-- (mkUnpackCase e co Con args body) +-- returns +-- case e |> co of _dead { Con args -> body } +mkUnpackCase (Tick tickish e) co mult con args body -- See Note [Profiling and unpacking] + = Tick tickish (mkUnpackCase e co mult con args body) +mkUnpackCase scrut co mult boxing_con unpk_args body + = mkSingleAltCase casted_scrut bndr + (DataAlt boxing_con) unpk_args body + where + casted_scrut = scrut `mkCast` co + bndr = mkWildValBinder mult (exprType casted_scrut) + +-- | The multiplicity of a case binder unboxing a constructed result. +-- See Note [Linear types and CPR] +cprCaseBndrMult :: Mult +cprCaseBndrMult = OneTy + +ww_prefix :: FastString +ww_prefix = fsLit "ww" + +{- Note [Profiling and unpacking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the original function looked like + f = \ x -> {-# SCC "foo" #-} E + +then we want the CPR'd worker to look like + \ x -> {-# SCC "foo" #-} (case E of I# x -> x) +and definitely not + \ x -> case ({-# SCC "foo" #-} E) of I# x -> x) + +This transform doesn't move work or allocation +from one cost centre to another. + +Later [SDM]: presumably this is because we want the simplifier to +eliminate the case, and the scc would get in the way? I'm ok with +including the case itself in the cost centre, since it is morally +part of the function (post transformation) anyway. +-} diff --git a/GHC/Core/PatSyn.hs b/GHC/Core/PatSyn.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/PatSyn.hs @@ -0,0 +1,521 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[PatSyn]{@PatSyn@: Pattern synonyms} +-} + + + +module GHC.Core.PatSyn ( + -- * Main data types + PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn, + + -- ** Type deconstruction + patSynName, patSynArity, patSynVisArity, + patSynIsInfix, patSynResultType, + isVanillaPatSyn, + patSynArgs, + patSynMatcher, patSynBuilder, + patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, + patSynSig, patSynSigBndr, + patSynInstArgTys, patSynInstResTy, patSynFieldLabels, + patSynFieldType, + + pprPatSynType + ) where + +import GHC.Prelude + +import GHC.Core.Type +import GHC.Core.TyCo.Ppr +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Basic +import GHC.Types.Var +import GHC.Types.FieldLabel + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import qualified Data.Data as Data +import Data.Function +import Data.List (find) + +{- +************************************************************************ +* * +\subsection{Pattern synonyms} +* * +************************************************************************ +-} + +-- | Pattern Synonym +-- +-- See Note [Pattern synonym representation] +-- See Note [Pattern synonym signature contexts] +data PatSyn + = MkPatSyn { + psName :: Name, + psUnique :: Unique, -- Cached from Name + + psArgs :: [FRRType], -- ^ Argument types + psArity :: Arity, -- == length psArgs + psInfix :: Bool, -- True <=> declared infix + psFieldLabels :: [FieldLabel], -- List of fields for a + -- record pattern synonym + -- INVARIANT: either empty if no + -- record pat syn or same length as + -- psArgs + + -- Universally-quantified type variables + psUnivTyVars :: [InvisTVBinder], + + -- Required dictionaries (may mention psUnivTyVars) + psReqTheta :: ThetaType, + + -- Existentially-quantified type vars + psExTyVars :: [InvisTVBinder], + + -- Provided dictionaries (may mention psUnivTyVars or psExTyVars) + psProvTheta :: ThetaType, + + -- Result type + psResultTy :: Type, -- Mentions only psUnivTyVars + -- See Note [Pattern synonym result type] + + -- See Note [Matchers and builders for pattern synonyms] + -- See Note [Keep Ids out of PatSyn] + psMatcher :: PatSynMatcher, + psBuilder :: PatSynBuilder + } + +type PatSynMatcher = (Name, Type, Bool) + -- Matcher function. + -- If Bool is True then prov_theta and arg_tys are empty + -- and type is + -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. Void# -> r) + -- -> (Void# -> r) + -- -> r + -- + -- Otherwise type is + -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. prov_theta => arg_tys -> r) + -- -> (Void# -> r) + -- -> r + +type PatSynBuilder = Maybe (Name, Type, Bool) + -- Nothing => uni-directional pattern synonym + -- Just (builder, is_unlifted) => bi-directional + -- Builder function, of type + -- forall univ_tvs, ex_tvs. (req_theta, prov_theta) + -- => arg_tys -> res_ty + -- See Note [Builder for pattern synonyms with unboxed type] + +{- Note [Pattern synonym signature contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a pattern synonym signature we write + pattern P :: req => prov => t1 -> ... tn -> res_ty + +Note that the "required" context comes first, then the "provided" +context. Moreover, the "required" context must not mention +existentially-bound type variables; that is, ones not mentioned in +res_ty. See lots of discussion in #10928. + +If there is no "provided" context, you can omit it; but you +can't omit the "required" part (unless you omit both). + +Example 1: + pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b) + pattern P1 x = Just (3,x) + + We require (Num a, Eq a) to match the 3; there is no provided + context. + +Example 2: + data T2 where + MkT2 :: (Num a, Eq a) => a -> a -> T2 + + pattern P2 :: () => (Num a, Eq a) => a -> T2 + pattern P2 x = MkT2 3 x + + When we match against P2 we get a Num dictionary provided. + We can use that to check the match against 3. + +Example 3: + pattern P3 :: Eq a => a -> b -> T3 b + + This signature is illegal because the (Eq a) is a required + constraint, but it mentions the existentially-bound variable 'a'. + You can see it's existential because it doesn't appear in the + result type (T3 b). + +Note [Pattern synonym result type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b = MkT b a + + pattern P :: a -> T [a] Bool + pattern P x = MkT True [x] + +P's psResultTy is (T a Bool), and it really only matches values of +type (T [a] Bool). For example, this is ill-typed + + f :: T p q -> String + f (P x) = "urk" + +This is different to the situation with GADTs: + + data S a where + MkS :: Int -> S Bool + +Now MkS (and pattern synonyms coming from MkS) can match a +value of type (S a), not just (S Bool); we get type refinement. + +That in turn means that if you have a pattern + + P x :: T [ty] Bool + +it's not entirely straightforward to work out the instantiation of +P's universal tyvars. You have to /match/ + the type of the pattern, (T [ty] Bool) +against + the psResultTy for the pattern synonym, T [a] Bool +to get the instantiation a := ty. + +This is very unlike DataCons, where univ tyvars match 1-1 the +arguments of the TyCon. + +Side note: I (SG) get the impression that instantiated return types should +generate a *required* constraint for pattern synonyms, rather than a *provided* +constraint like it's the case for GADTs. For example, I'd expect these +declarations to have identical semantics: + + pattern Just42 :: Maybe Int + pattern Just42 = Just 42 + + pattern Just'42 :: (a ~ Int) => Maybe a + pattern Just'42 = Just 42 + +The latter generates the proper required constraint, the former does not. +Also rather different to GADTs is the fact that Just42 doesn't have any +universally quantified type variables, whereas Just'42 or MkS above has. + +Note [Keep Ids out of PatSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We carefully arrange that PatSyn does not contain the Ids for the matcher +and builder. We want PatSyn, like TyCon and DataCon, to be completely +immutable. But, the matcher and builder are relatively sophisticated +functions, and we want to get their final IdInfo in the same way as +any other Id, so we'd have to update the Ids in the PatSyn too. + +Rather than try to tidy PatSyns (which is easy to forget and is a bit +tricky, see #19074), it seems cleaner to make them entirely immutable, +like TyCons and Classes. To that end PatSynBuilder and PatSynMatcher +contain Names not Ids. Which, it turns out, is absolutely fine. + +c.f. DefMethInfo in Class, which contains the Name, but not the Id, +of the default method. + +Note [Pattern synonym representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following pattern synonym declaration + + pattern P x = MkT [x] (Just 42) + +where + data T a where + MkT :: (Show a, Ord b) => [b] -> a -> T a + +so pattern P has type + + b -> T (Maybe t) + +with the following typeclass constraints: + + requires: (Eq t, Num t) + provides: (Show (Maybe t), Ord b) + +In this case, the fields of MkPatSyn will be set as follows: + + psArgs = [b] + psArity = 1 + psInfix = False + + psUnivTyVars = [t] + psExTyVars = [b] + psProvTheta = (Show (Maybe t), Ord b) + psReqTheta = (Eq t, Num t) + psResultTy = T (Maybe t) + +Note [Matchers and builders for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For each pattern synonym P, we generate + + * a "matcher" function, used to desugar uses of P in patterns, + which implements pattern matching + + * A "builder" function (for bidirectional pattern synonyms only), + used to desugar uses of P in expressions, which constructs P-values. + +For the above example, the matcher function has type: + + $mP :: forall (r :: ?) t. (Eq t, Num t) + => T (Maybe t) + -> (forall b. (Show (Maybe t), Ord b) => b -> r) + -> (Void# -> r) + -> r + +with the following implementation: + + $mP @r @t $dEq $dNum scrut cont fail + = case scrut of + MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x + _ -> fail Void# + +Notice that the return type 'r' has an open kind, so that it can +be instantiated by an unboxed type; for example where we see + f (P x) = 3# + +The extra Void# argument for the failure continuation is needed so that +it is lazy even when the result type is unboxed. + +For the same reason, if the pattern has no arguments, an extra Void# +argument is added to the success continuation as well. + +For *bidirectional* pattern synonyms, we also generate a "builder" +function which implements the pattern synonym in an expression +context. For our running example, it will be: + + $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b) + => b -> T (Maybe t) + $bP x = MkT [x] (Just 42) + +NB: the existential/universal and required/provided split does not +apply to the builder since you are only putting stuff in, not getting +stuff out. + +Injectivity of bidirectional pattern synonyms is checked in +tcPatToExpr which walks the pattern and returns its corresponding +expression when available. + +Note [Builder for pattern synonyms with unboxed type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For bidirectional pattern synonyms that have no arguments and have an +unboxed type, we add an extra Void# argument to the builder, else it +would be a top-level declaration with an unboxed type. + + pattern P = 0# + + $bP :: Void# -> Int# + $bP _ = 0# + +This means that when typechecking an occurrence of P in an expression, +we must remember that the builder has this void argument. This is +done by GHC.Tc.TyCl.PatSyn.patSynBuilderOcc. + +Note [Pattern synonyms and the data type Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type of a pattern synonym is of the form (See Note +[Pattern synonym signatures] in GHC.Tc.Gen.Sig): + + forall univ_tvs. req => forall ex_tvs. prov => ... + +We cannot in general represent this by a value of type Type: + + - if ex_tvs is empty, then req and prov cannot be distinguished from + each other + - if req is empty, then univ_tvs and ex_tvs cannot be distinguished + from each other, and moreover, prov is seen as the "required" context + (as it is the only context) + + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq PatSyn where + (==) = (==) `on` getUnique + (/=) = (/=) `on` getUnique + +instance Uniquable PatSyn where + getUnique = psUnique + +instance NamedThing PatSyn where + getName = patSynName + +instance Outputable PatSyn where + ppr = ppr . getName + +instance OutputableBndr PatSyn where + pprInfixOcc = pprInfixName . getName + pprPrefixOcc = pprPrefixName . getName + +instance Data.Data PatSyn where + -- don't traverse? + toConstr _ = abstractConstr "PatSyn" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "PatSyn" + +{- +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +-- | Build a new pattern synonym +mkPatSyn :: Name + -> Bool -- ^ Is the pattern synonym declared infix? + -> ([InvisTVBinder], ThetaType) -- ^ Universally-quantified type + -- variables and required dicts + -> ([InvisTVBinder], ThetaType) -- ^ Existentially-quantified type + -- variables and provided dicts + -> [FRRType] -- ^ Original arguments + -> Type -- ^ Original result type + -> PatSynMatcher -- ^ Matcher + -> PatSynBuilder -- ^ Builder + -> [FieldLabel] -- ^ Names of fields for + -- a record pattern synonym + -> PatSyn + -- NB: The univ and ex vars are both in PiTyVarBinder form and TyVar form for + -- convenience. All the TyBinders should be Named! +mkPatSyn name declared_infix + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + orig_args + orig_res_ty + matcher builder field_labels + = MkPatSyn {psName = name, psUnique = getUnique name, + psUnivTyVars = univ_tvs, + psExTyVars = ex_tvs, + psProvTheta = prov_theta, psReqTheta = req_theta, + psInfix = declared_infix, + psArgs = orig_args, + psArity = length orig_args, + psResultTy = orig_res_ty, + psMatcher = matcher, + psBuilder = builder, + psFieldLabels = field_labels + } + +-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification +patSynName :: PatSyn -> Name +patSynName = psName + +-- | Should the 'PatSyn' be presented infix? +patSynIsInfix :: PatSyn -> Bool +patSynIsInfix = psInfix + +-- | Arity of the pattern synonym +patSynArity :: PatSyn -> Arity +patSynArity = psArity + +-- | Number of visible arguments of the pattern synonym +patSynVisArity :: PatSyn -> VisArity +patSynVisArity ps = n_of_required_ty_args + n_of_val_args + where + n_of_val_args = psArity ps + n_of_required_ty_args = 0 -- no visible forall in pattern synonyms yet (#23704) + +-- | Is this a \'vanilla\' pattern synonym (no existentials, no provided constraints)? +isVanillaPatSyn :: PatSyn -> Bool +isVanillaPatSyn ps = null (psExTyVars ps) && null (psProvTheta ps) + +patSynArgs :: PatSyn -> [Type] +patSynArgs = psArgs + +patSynFieldLabels :: PatSyn -> [FieldLabel] +patSynFieldLabels = psFieldLabels + +-- | Extract the type for any given labelled field of the 'DataCon' +patSynFieldType :: PatSyn -> FieldLabelString -> Type +patSynFieldType ps label + = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of + Just (_, ty) -> ty + Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) + +patSynUnivTyVarBinders :: PatSyn -> [InvisTVBinder] +patSynUnivTyVarBinders = psUnivTyVars + +patSynExTyVars :: PatSyn -> [TyVar] +patSynExTyVars ps = binderVars (psExTyVars ps) + +patSynExTyVarBinders :: PatSyn -> [InvisTVBinder] +patSynExTyVarBinders = psExTyVars + +patSynSigBndr :: PatSyn -> ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type) +patSynSigBndr (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs + , psProvTheta = prov, psReqTheta = req + , psArgs = arg_tys, psResultTy = res_ty }) + = (univ_tvs, req, ex_tvs, prov, map unrestricted arg_tys, res_ty) + +patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Scaled Type], Type) +patSynSig ps = let (u_tvs, req, e_tvs, prov, arg_tys, res_ty) = patSynSigBndr ps + in (binderVars u_tvs, req, binderVars e_tvs, prov, arg_tys, res_ty) + +patSynMatcher :: PatSyn -> PatSynMatcher +patSynMatcher = psMatcher + +patSynBuilder :: PatSyn -> PatSynBuilder +patSynBuilder = psBuilder + +patSynResultType :: PatSyn -> Type +patSynResultType = psResultTy + +patSynInstArgTys :: PatSyn -> [Type] -> [Type] +-- Return the types of the argument patterns +-- e.g. data D a = forall b. MkD a b (b->a) +-- pattern P f x y = MkD (x,True) y f +-- D :: forall a. forall b. a -> b -> (b->a) -> D a +-- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c +-- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb] +-- NB: the inst_tys should be both universal and existential +patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psExTyVars = ex_tvs, psArgs = arg_tys }) + inst_tys + = assertPpr (tyvars `equalLength` inst_tys) + (text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys) $ + map (substTyWith tyvars inst_tys) arg_tys + where + tyvars = binderVars (univ_tvs ++ ex_tvs) + +patSynInstResTy :: PatSyn -> [Type] -> Type +-- Return the type of whole pattern +-- E.g. pattern P x y = Just (x,x,y) +-- P :: a -> b -> Just (a,a,b) +-- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) +-- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars +patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psResultTy = res_ty }) + inst_tys + = assertPpr (univ_tvs `equalLength` inst_tys) + (text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys) $ + substTyWith (binderVars univ_tvs) inst_tys res_ty + +-- | Print the type of a pattern synonym. The foralls are printed explicitly +pprPatSynType :: PatSyn -> SDoc +pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta + , psExTyVars = ex_tvs, psProvTheta = prov_theta + , psArgs = orig_args, psResultTy = orig_res_ty }) + = sep [ pprForAll $ tyVarSpecToBinders univ_tvs + , pprThetaArrowTy req_theta + , ppWhen insert_empty_ctxt $ parens empty <+> darrow + , pprType sigma_ty ] + where + sigma_ty = mkInvisForAllTys ex_tvs $ + mkInvisFunTys prov_theta $ + mkVisFunTysMany orig_args orig_res_ty + insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/GHC/Core/Ppr.hs b/GHC/Core/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Ppr.hs @@ -0,0 +1,711 @@ +{-# LANGUAGE LambdaCase #-} + +{- + these are needed for the Outputable instance for GenTickish, + since we need XTickishId to be Outputable. This should immediately + resolve to something like Id. + -} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +Printing of Core syntax +-} + +module GHC.Core.Ppr ( + pprCoreExpr, pprParendExpr, + pprCoreBinding, pprCoreBindings, pprCoreAlt, + pprCoreBindingWithSize, pprCoreBindingsWithSize, + pprCoreBinder, pprCoreBinders, pprId, pprIds, + pprRule, pprRules, pprOptCo, + pprOcc, pprOccWithTick + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Stats (exprStats) +import GHC.Types.Fixity (LexicalFixity(..)) +import GHC.Types.Literal( pprLiteral ) +import GHC.Types.Name( pprInfixName, pprPrefixName ) +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr +import GHC.Core.Coercion +import GHC.Types.Basic +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Types.SrcLoc ( pprUserRealSpan ) +import GHC.Types.Tickish + +{- +************************************************************************ +* * +\subsection{Public interfaces for Core printing (excluding instances)} +* * +************************************************************************ + +@pprParendCoreExpr@ puts parens around non-atomic Core expressions. +-} + +pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc +pprCoreBinding :: OutputableBndr b => Bind b -> SDoc +pprCoreExpr :: OutputableBndr b => Expr b -> SDoc +pprParendExpr :: OutputableBndr b => Expr b -> SDoc + +pprCoreBindings = pprTopBinds noAnn +pprCoreBinding = pprTopBind noAnn + +pprCoreBindingsWithSize :: [CoreBind] -> SDoc +pprCoreBindingWithSize :: CoreBind -> SDoc + +pprCoreBindingsWithSize = pprTopBinds sizeAnn +pprCoreBindingWithSize = pprTopBind sizeAnn + +instance OutputableBndr b => Outputable (Bind b) where + ppr bind = ppr_bind noAnn bind + +instance OutputableBndr b => Outputable (Expr b) where + ppr expr = pprCoreExpr expr + +instance OutputableBndr b => Outputable (Alt b) where + ppr expr = pprCoreAlt expr + +{- +************************************************************************ +* * +\subsection{The guts} +* * +************************************************************************ +-} + +-- | A function to produce an annotation for a given right-hand-side +type Annotation b = Expr b -> SDoc + +-- | Annotate with the size of the right-hand-side +sizeAnn :: CoreExpr -> SDoc +sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e) + +-- | No annotation +noAnn :: Expr b -> SDoc +noAnn _ = empty + +pprTopBinds :: OutputableBndr a + => Annotation a -- ^ generate an annotation to place before the + -- binding + -> [Bind a] -- ^ bindings to show + -> SDoc -- ^ the pretty result +pprTopBinds ann binds = vcat (map (pprTopBind ann) binds) + +pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc +pprTopBind ann (NonRec binder expr) + = ppr_binding ann (binder,expr) $$ blankLine + +pprTopBind _ (Rec []) + = text "Rec { }" +pprTopBind ann (Rec (b:bs)) + = vcat [text "Rec {", + ppr_binding ann b, + vcat [blankLine $$ ppr_binding ann b | b <- bs], + text "end Rec }", + blankLine] + +ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc + +ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr) +ppr_bind ann (Rec binds) = vcat (map pp binds) + where + pp bind = ppr_binding ann bind <> semi + +ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc +ppr_binding ann (val_bdr, expr) + = vcat [ ann expr + , ppUnlessOption sdocSuppressTypeSignatures + (pprBndr LetBind val_bdr) + , pp_bind + ] + where + pp_val_bdr = pprPrefixOcc val_bdr + + pp_bind = case bndrIsJoin_maybe val_bdr of + NotJoinPoint -> pp_normal_bind + JoinPoint ar -> pp_join_bind ar + + pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr) + + -- For a join point of join arity n, we want to print j = \x1 ... xn -> e + -- as "j x1 ... xn = e" to differentiate when a join point returns a + -- lambda (the first rendering looks like a nullary join point returning + -- an n-argument function). + pp_join_bind join_arity + | bndrs `lengthAtLeast` join_arity + = hang (pp_val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs)) + 2 (equals <+> pprCoreExpr rhs) + | otherwise -- Yikes! A join-binding with too few lambda + -- Lint will complain, but we don't want to crash + -- the pretty-printer else we can't see what's wrong + -- So refer to printing j = e + = pp_normal_bind + where + (bndrs, body) = collectBinders expr + (lhs_bndrs, rest) = splitAt join_arity bndrs + rhs = mkLams rest body + +pprParendExpr expr = ppr_expr parens expr +pprCoreExpr expr = ppr_expr noParens expr + +noParens :: SDoc -> SDoc +noParens pp = pp + +pprOptCo :: Coercion -> SDoc +-- Print a coercion optionally; i.e. honouring -dsuppress-coercions +pprOptCo co = sdocOption sdocSuppressCoercions $ \case + True -> angleBrackets (text "Co:" <> int (coercionSize co)) <+> dcolon <+> co_type + False -> parens $ sep [ppr co, dcolon <+> co_type] + where + co_type = sdocOption sdocSuppressCoercionTypes $ \case + True -> text "..." + False -> ppr (coercionType co) + +ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc +ppr_id_occ add_par id + | isJoinId id = add_par ((text "jump") <+> pp_id) + | otherwise = pp_id + where + pp_id = ppr id -- We could use pprPrefixOcc to print (+) etc, but this is + -- Core where we don't print things infix anyway, so doing + -- so just adds extra redundant parens + +ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) + +ppr_expr add_par (Var id) = ppr_id_occ add_par id +ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird +ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co) +ppr_expr add_par (Lit lit) = pprLiteral add_par lit + +ppr_expr add_par (Cast expr co) + = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co] + +ppr_expr add_par expr@(Lam _ _) + = let + (bndrs, body) = collectBinders expr + in + add_par $ + hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (pprCoreExpr body) + +ppr_expr add_par expr@(App {}) + = sdocOption sdocSuppressTypeApplications $ \supp_ty_app -> + case collectArgs expr of { (fun, args) -> + let + pp_args = sep (map pprArg args) + val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples + pp_tup_args = pprWithCommas pprCoreExpr val_args + args' + | supp_ty_app = val_args + | otherwise = args + parens + | null args' = id + | otherwise = add_par + in + case fun of + Var f -> case isDataConWorkId_maybe f of + -- Notice that we print the *worker* + -- for tuples in paren'd format. + Just dc | saturated + , Just sort <- tyConTuple_maybe tc + -> tupleParens sort pp_tup_args + where + tc = dataConTyCon dc + saturated = val_args `lengthIs` idArity f + + _ -> parens (hang fun_doc 2 pp_args) + where + fun_doc = ppr_id_occ noParens f + + _ -> parens (hang (pprParendExpr fun) 2 pp_args) + } + +ppr_expr add_par (Case expr _ ty []) -- Empty Case + = add_par $ sep [text "case" + <+> pprCoreExpr expr + <+> whenPprDebug (text "return" <+> ppr ty), + text "of {}"] + +ppr_expr add_par (Case expr var ty [Alt con args rhs]) -- Single alt Case + = sdocOption sdocPrintCaseAsLet $ \case + True -> add_par $ -- See Note [Print case as let] + sep [ sep [ text "let! {" + <+> ppr_case_pat con args + <+> text "~" + <+> ppr_bndr var + , text "<-" <+> ppr_expr id expr + <+> text "} in" ] + , pprCoreExpr rhs + ] + False -> add_par $ + sep [sep [sep [ text "case" <+> pprCoreExpr expr + , whenPprDebug (text "return" <+> ppr ty) + , text "of" <+> ppr_bndr var + ] + , char '{' <+> ppr_case_pat con args <+> arrow + ] + , pprCoreExpr rhs + , char '}' + ] + where + ppr_bndr = pprBndr CaseBind + +ppr_expr add_par (Case expr var ty alts) -- Multi alt Case + = add_par $ + sep [sep [text "case" + <+> pprCoreExpr expr + <+> whenPprDebug (text "return" <+> ppr ty), + text "of" <+> ppr_bndr var <+> char '{'], + nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), + char '}' + ] + where + ppr_bndr = pprBndr CaseBind + + +-- special cases: let ... in let ... +-- ("disgusting" SLPJ) + +{- +ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) + = add_par $ + vcat [ + hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], + nest 2 (pprCoreExpr rhs), + text "} in", + pprCoreExpr body ] + +ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) + = add_par + (hang (text "let {") + 2 (hsep [ppr_binding (val_bdr,rhs), + text "} in"]) + $$ + pprCoreExpr expr) +-} + + +-- General case (recursive case, too) +ppr_expr add_par (Let bind expr) + = add_par $ + sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"), + pprCoreExpr expr] + where + keyword (NonRec b _) + | isJoinPoint (bndrIsJoin_maybe b) = text "join" + | otherwise = text "let" + keyword (Rec pairs) + | ((b,_):_) <- pairs + , isJoinPoint (bndrIsJoin_maybe b) = text "joinrec" + | otherwise = text "letrec" + +ppr_expr add_par (Tick tickish expr) + = sdocOption sdocSuppressTicks $ \case + -- Only hide non-runtime relevant ticks. + True + | not (tickishIsCode tickish) -> ppr_expr add_par expr + _ -> add_par (sep [ppr tickish, pprCoreExpr expr]) + +pprCoreAlt :: OutputableBndr a => Alt a -> SDoc +pprCoreAlt (Alt con args rhs) + = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) + +ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc +ppr_case_pat (DataAlt dc) args + | Just sort <- tyConTuple_maybe tc + = tupleParens sort (pprWithCommas ppr_bndr args) + where + ppr_bndr = pprBndr CasePatBind + tc = dataConTyCon dc + +ppr_case_pat con args + = ppr con <+> (fsep (map ppr_bndr args)) + where + ppr_bndr = pprBndr CasePatBind + + +-- | Pretty print the argument in a function application. +pprArg :: OutputableBndr a => Expr a -> SDoc +pprArg (Type ty) + = ppUnlessOption sdocSuppressTypeApplications + (text "@" <> pprParendType ty) +pprArg (Coercion co) = text "@~" <> pprOptCo co +pprArg expr = pprParendExpr expr + +{- +Note [Print case as let] +~~~~~~~~~~~~~~~~~~~~~~~~ +Single-branch case expressions are very common: + case x of y { I# x' -> + case p of q { I# p' -> ... } } +These are, in effect, just strict let's, with pattern matching. +With -dppr-case-as-let we print them as such: + let! { I# x' ~ y <- x } in + let! { I# p' ~ q <- p } in ... + + +Other printing bits-and-bobs used with the general @pprCoreBinding@ +and @pprCoreExpr@ functions. + + +Note [Binding-site specific printing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust +the information printed. + +Let-bound binders are printed with their full type and idInfo. + +Case-bound variables (both the case binder and pattern variables) are printed +without a type and without their unfolding. + +Furthermore, a dead case-binder is completely ignored, while otherwise, dead +binders are printed as "_". +-} + +-- These instances are sadly orphans + +instance OutputableBndr Var where + pprBndr = pprCoreBinder + pprInfixOcc = pprInfixName . varName + pprPrefixOcc = pprPrefixName . varName + bndrIsJoin_maybe = idJoinPointHood + +instance Outputable b => OutputableBndr (TaggedBndr b) where + pprBndr _ b = ppr b -- Simple + pprInfixOcc b = ppr b + pprPrefixOcc b = ppr b + bndrIsJoin_maybe (TB b _) = idJoinPointHood b + +pprOcc :: OutputableBndr a => LexicalFixity -> a -> SDoc +pprOcc Infix = pprInfixOcc +pprOcc Prefix = pprPrefixOcc + +pprOccWithTick :: OutputableBndr a => LexicalFixity -> PromotionFlag -> a -> SDoc +pprOccWithTick fixity prom op + | isPromoted prom + = quote (pprOcc fixity op) + | otherwise + = pprOcc fixity op + +pprCoreBinder :: BindingSite -> Var -> SDoc +pprCoreBinder LetBind binder + | isTyVar binder = pprKindedTyVarBndr binder + | otherwise = pprTypedLetBinder binder $$ + ppIdInfo binder (idInfo binder) + +-- Lambda bound type variables are preceded by "@" +pprCoreBinder bind_site bndr + = getPprDebug $ \debug -> + pprTypedLamBinder bind_site debug bndr + +pprCoreBinders :: [Var] -> SDoc +-- Print as lambda-binders, i.e. with their type +pprCoreBinders vs = sep (map (pprCoreBinder LambdaBind) vs) + +pprUntypedBinder :: Var -> SDoc +pprUntypedBinder binder + | isTyVar binder = text "@" <> ppr binder -- NB: don't print kind + | otherwise = pprIdBndr binder + +pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc +-- For lambda and case binders, show the unfolding info (usually none) +pprTypedLamBinder bind_site debug_on var + = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs -> + case () of + _ + | not debug_on -- Show case-bound wild binders only if debug is on + , CaseBind <- bind_site + , isDeadBinder var -> empty + + | not debug_on -- Even dead binders can be one-shot + , isDeadBinder var -> char '_' <+> ppWhen (isId var) + (pprIdBndrInfo (idInfo var)) + + | not debug_on -- No parens, no kind info + , CaseBind <- bind_site -> pprUntypedBinder var + + | not debug_on + , CasePatBind <- bind_site -> pprUntypedBinder var + + | suppress_sigs -> pprUntypedBinder var + + | isTyVar var -> parens (pprKindedTyVarBndr var) + + | otherwise -> parens (hang (pprIdBndr var) + 2 (vcat [ dcolon <+> pprType (idType var) + , pp_unf])) + where + unf_info = realUnfoldingInfo (idInfo var) + pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info + | otherwise = empty + +pprTypedLetBinder :: Var -> SDoc +-- Print binder with a type or kind signature (not paren'd) +pprTypedLetBinder binder + = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs -> + case () of + _ + | isTyVar binder -> pprKindedTyVarBndr binder + | suppress_sigs -> pprIdBndr binder + | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) + +pprKindedTyVarBndr :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +pprKindedTyVarBndr tyvar + = text "@" <> pprTyVar tyvar + +-- pprId x prints x :: ty +pprId :: Id -> SDoc +pprId x = ppr x <+> dcolon <+> ppr (idType x) + +pprIds :: [Id] -> SDoc +pprIds xs = sep (map pprId xs) + +-- pprIdBndr does *not* print the type +-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness +pprIdBndr :: Id -> SDoc +pprIdBndr id = pprPrefixOcc id <+> pprIdBndrInfo (idInfo id) + +pprIdBndrInfo :: IdInfo -> SDoc +pprIdBndrInfo info + = ppUnlessOption sdocSuppressIdInfo + (info `seq` doc) -- The seq is useful for poking on black holes + where + prag_info = inlinePragInfo info + occ_info = occInfo info + dmd_info = demandInfo info + lbv_info = oneShotInfo info + + has_prag = not (isDefaultInlinePragma prag_info) + has_occ = not (isNoOccInfo occ_info) + has_dmd = not $ isTopDmd dmd_info + has_lbv = not (hasNoOneShotInfo lbv_info) + + doc = showAttributes + [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) + , (has_occ, text "Occ=" <> ppr occ_info) + , (has_dmd, text "Dmd=" <> ppr dmd_info) + , (has_lbv , text "OS=" <> ppr lbv_info) + ] + +instance Outputable IdInfo where + ppr info = showAttributes + [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) + , (has_occ, text "Occ=" <> ppr occ_info) + , (has_dmd, text "Dmd=" <> ppr dmd_info) + , (has_lbv , text "OS=" <> ppr lbv_info) + , (has_arity, text "Arity=" <> int arity) + , (has_called_arity, text "CallArity=" <> int called_arity) + , (has_caf_info, text "Caf=" <> ppr caf_info) + , (has_str_info, text "Str=" <> pprStrictness str_info) + , (has_unf, text "Unf=" <> ppr unf_info) + , (has_rules, text "RULES:" <+> vcat (map pprRule rules)) + ] + where + prag_info = inlinePragInfo info + has_prag = not (isDefaultInlinePragma prag_info) + + occ_info = occInfo info + has_occ = not (isManyOccs occ_info) + + dmd_info = demandInfo info + has_dmd = not $ isTopDmd dmd_info + + lbv_info = oneShotInfo info + has_lbv = not (hasNoOneShotInfo lbv_info) + + arity = arityInfo info + has_arity = arity /= 0 + + called_arity = callArityInfo info + has_called_arity = called_arity /= 0 + + caf_info = cafInfo info + has_caf_info = not (mayHaveCafRefs caf_info) + + str_info = dmdSigInfo info + has_str_info = not (isNopSig str_info) + + unf_info = realUnfoldingInfo info + has_unf = hasSomeUnfolding unf_info + + rules = ruleInfoRules (ruleInfo info) + has_rules = not (null rules) + +{- +----------------------------------------------------- +-- IdDetails and IdInfo +----------------------------------------------------- +-} + +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo id info + = ppUnlessOption sdocSuppressIdInfo $ + showAttributes + [ (True, pp_scope <> ppr (idDetails id)) + , (has_arity, text "Arity=" <> int arity) + , (has_called_arity, text "CallArity=" <> int called_arity) + , (has_caf_info, text "Caf=" <> ppr caf_info) + , (has_str_info, text "Str=" <> pprStrictness str_info) + , (has_cpr_info, text "Cpr=" <> ppr cpr_info) + , (has_unf, text "Unf=" <> ppr unf_info) + , (not (null rules), text "RULES:" <+> vcat (map pprRule rules)) + ] -- Inline pragma, occ, demand, one-shot info + -- printed out with all binders (when debug is on); + -- see GHC.Core.Ppr.pprIdBndr + where + pp_scope | isGlobalId id = text "GblId" + | isExportedId id = text "LclIdX" + | otherwise = text "LclId" + + arity = arityInfo info + has_arity = arity /= 0 + + called_arity = callArityInfo info + has_called_arity = called_arity /= 0 + + caf_info = cafInfo info + has_caf_info = not (mayHaveCafRefs caf_info) + + str_info = dmdSigInfo info + has_str_info = not (isNopSig str_info) + + cpr_info = cprSigInfo info + has_cpr_info = cpr_info /= topCprSig + + unf_info = realUnfoldingInfo info + has_unf = hasSomeUnfolding unf_info + + rules = ruleInfoRules (ruleInfo info) + +showAttributes :: [(Bool,SDoc)] -> SDoc +showAttributes stuff + | null docs = empty + | otherwise = brackets (sep (punctuate comma docs)) + where + docs = [d | (True,d) <- stuff] + +{- +----------------------------------------------------- +-- Unfolding and UnfoldingGuidance +----------------------------------------------------- +-} + +instance Outputable UnfoldingGuidance where + ppr UnfNever = text "NEVER" + ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) + = text "ALWAYS_IF" <> + parens (text "arity=" <> int arity <> comma <> + text "unsat_ok=" <> ppr unsat_ok <> comma <> + text "boring_ok=" <> ppr boring_ok) + ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) + = hsep [ text "IF_ARGS", + brackets (hsep (map int cs)), + int size, + int discount ] + +instance Outputable Unfolding where + ppr NoUnfolding = text "No unfolding" + ppr BootUnfolding = text "No unfolding (from boot)" + ppr (OtherCon cs) = text "OtherCon" <+> ppr cs + ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = hang (text "DFun:" <+> char '\\' + <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (ppr con <+> sep (map ppr args)) + ppr (CoreUnfolding { uf_src = src + , uf_tmpl=rhs, uf_is_top=top + , uf_cache=cache, uf_guidance=g }) + = text "Unf" <> braces (pp_info $$ pp_rhs) + where + pp_info = fsep $ punctuate comma + [ text "Src=" <> ppr src + , text "TopLvl=" <> ppr top + , ppr cache + , text "Guidance=" <> ppr g ] + pp_tmpl = ppUnlessOption sdocSuppressUnfoldings + (text "Tmpl=" <+> ppr rhs) + pp_rhs | isStableSource src = pp_tmpl + | otherwise = empty + -- Don't print the RHS or we get a quadratic + -- blowup in the size of the printout! + +instance Outputable UnfoldingCache where + ppr (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike + , uf_is_work_free = wf, uf_expandable = exp }) + = fsep $ punctuate comma + [ text "Value=" <> ppr hnf + , text "ConLike=" <> ppr conlike + , text "WorkFree=" <> ppr wf + , text "Expandable=" <> ppr exp ] + +{- +----------------------------------------------------- +-- Rules +----------------------------------------------------- +-} + +instance Outputable CoreRule where + ppr = pprRule + +pprRules :: [CoreRule] -> SDoc +pprRules rules = vcat (map pprRule rules) + +pprRule :: CoreRule -> SDoc +pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) + = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name) + +pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, + ru_bndrs = tpl_vars, ru_args = tpl_args, + ru_rhs = rhs }) + = hang (doubleQuotes (ftext name) <+> ppr act) + 4 (sep [text "forall" <+> pprCoreBinders tpl_vars <> dot, + nest 2 (ppr fn <+> sep (map pprArg tpl_args)), + nest 2 (text "=" <+> pprCoreExpr rhs) + ]) + +{- +----------------------------------------------------- +-- Tickish +----------------------------------------------------- +-} + +instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where + ppr (HpcTick modl ix) = + hcat [text "hpc<", + ppr modl, comma, + ppr ix, + text ">"] + ppr (Breakpoint _ext bid vars) = + hcat [text "break<", + ppr (bi_tick_mod bid), comma, + ppr (bi_tick_index bid), + text ">", + parens (hcat (punctuate comma (map ppr vars)))] + ppr (ProfNote { profNoteCC = cc, + profNoteCount = tick, + profNoteScope = scope }) = + case (tick,scope) of + (True,True) -> hcat [text "scctick<", ppr cc, char '>'] + (True,False) -> hcat [text "tick<", ppr cc, char '>'] + _ -> hcat [text "scc<", ppr cc, char '>'] + ppr (SourceNote span _) = + hcat [ text "src<", pprUserRealSpan True span, char '>'] diff --git a/GHC/Core/Ppr.hs-boot b/GHC/Core/Ppr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/Ppr.hs-boot @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.Core.Ppr where + +import {-# SOURCE #-} GHC.Core +import {-# SOURCE #-} GHC.Types.Var (Var) +import GHC.Utils.Outputable (OutputableBndr, Outputable) + +instance OutputableBndr b => Outputable (Expr b) + +instance OutputableBndr Var diff --git a/GHC/Core/Predicate.hs b/GHC/Core/Predicate.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Predicate.hs @@ -0,0 +1,812 @@ +{-# LANGUAGE DerivingStrategies #-} + +{- + +Describes predicates as they are considered by the solver. + +-} + +module GHC.Core.Predicate ( + Pred(..), classifyPredType, + isPredTy, isSimplePredTy, + + -- Equality predicates + EqRel(..), eqRelRole, + isEqPred, isReprEqPred, isEqClassPred, isCoVarType, + getEqPredTys, getEqPredTys_maybe, getEqPredRole, + predTypeEqRel, pprPredType, + mkNomEqPred, mkReprEqPred, mkEqPred, mkEqPredRole, + + -- Class predicates + mkClassPred, isDictTy, typeDeterminesValue, + isClassPred, isEqualityClass, isCTupleClass, isUnaryClass, + getClassPredTys, getClassPredTys_maybe, + classMethodTy, classMethodInstTy, + + -- Implicit parameters + couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass, decomposeIPPred, + isCallStackTy, isCallStackPred, isCallStackPredTy, + isExceptionContextPred, isExceptionContextTy, + isIPPred_maybe, + + -- Evidence variables + DictId, isEvId, isDictId, + + -- * Well-scoped free variables + scopedSort, tyCoVarsOfTypeWellScoped, + tyCoVarsOfTypesWellScoped, + + -- Equality left-hand sides + CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe, + canEqLHSKind, canEqLHSType, eqCanEqLHS + + ) where + +import GHC.Prelude + +import GHC.Core.Type +import GHC.Core.Class +import GHC.Core.TyCo.Compare( tcEqTyConApps ) +import GHC.Core.TyCo.FVs( tyCoVarsOfTypeList, tyCoVarsOfTypesList ) +import GHC.Core.TyCon +import GHC.Core.TyCon.RecWalk +import GHC.Types.Name( getOccName ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Core.Multiplicity ( scaledThing ) + +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon ) + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Data.FastString + + +{- ********************************************************************* +* * +* Pred and PredType * +* * +********************************************************************* -} + +{- Note [Types for coercions, predicates, and evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "predicate" or "predicate type", + type synonym `PredType` + returns True to `isPredTy` +is any type of kind (CONSTRAINT r) for some `r`. + + (a) A "class predicate" (aka dictionary type) is the type of a (boxed) + type-class dictionary + Test: isDictTy + Binders: DictIds + Kind: Constraint + Examples: (Eq a), and (a ~ b) + + (b) An "equality predicate" is a primitive, unboxed equalities + Test: isEqPred + Binders: CoVars (can appear in coercions) + Kind: CONSTRAINT (TupleRep []) + Examples: (t1 ~# t2) or (t1 ~R# t2) + + (c) A "simple predicate type" is either a class predicate or an equality predicate + Test: isSimplePredTy + Kind: Constraint or CONSTRAINT (TupleRep []) + Examples: all coercion types and dictionary types + + (d) A "forall-predicate" is the type of a possibly-polymorphic function + returning a predicate; e.g. + forall a. Eq a => Eq [a] + + (e) An "irred predicate" is any other type of kind (CONSTRAINT r), + typically something like `c` or `c Int`, for some suitably-kinded `c` + + +* Predicates are classified by `classifyPredType`. + +* Equality types and dictionary types are mutually exclusive. + +* Predicates are the things solved by the constraint solver; and + /evidence terms/ witness those solutions. An /evidence variable/ + (or EvId) has a type that is a PredType. + +* Generally speaking, the /type/ of a predicate determines its /value/; + that is, predicates are singleton types. The big exception is implicit + parameters. See Note [Type determines value] + +* In a FunTy { ft_af = af }, where af = FTF_C_T or FTF_C_C, + the argument type is always a Predicate type. +-} + +-- | A predicate in the solver. The solver tries to prove Wanted predicates +-- from Given ones. +data Pred + + -- | A typeclass predicate. + = ClassPred Class [Type] + + -- | A type equality predicate, (t1 ~#N t2) or (t1 ~#R t2) + | EqPred EqRel Type Type + + -- | An irreducible predicate. + | IrredPred PredType + + -- | A quantified predicate. + -- + -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve + | ForAllPred [TyVar] [PredType] PredType + + -- NB: There is no TuplePred case + -- Tuple predicates like (Eq a, Ord b) are just treated + -- as ClassPred, as if we had a tuple class with two superclasses + -- class (c1, c2) => CTuple2 c1 c2 + +classifyPredType :: HasDebugCallStack => PredType -> Pred +-- Precondition: the argument is a predicate type, with kind (CONSTRAINT _) +classifyPredType ev_ty + = assertPpr (isPredTy ev_ty) (ppr ev_ty) $ + case splitTyConApp_maybe ev_ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2 + | tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2 + + Just (tc, tys) + | Just clas <- tyConClass_maybe tc + -> ClassPred clas tys + + _ | (tvs, rho) <- splitForAllTyCoVars ev_ty + , (theta, pred) <- splitFunTys rho + , not (null tvs && null theta) + -> ForAllPred tvs (map scaledThing theta) pred + + | otherwise + -> IrredPred ev_ty + +isSimplePredTy :: HasDebugCallStack => Type -> Bool +-- Return True for (t1 ~# t2) regardless of role, and (C tys) +-- /Not/ true of quantified-predicate type like (forall a. Eq a => Eq [a]) +-- Precondition: expects a type that classifies values (i.e. not a type constructor) +-- See Note [Types for coercions, predicates, and evidence] +isSimplePredTy ty + = case tyConAppTyCon_maybe ty of + Nothing -> False + Just tc -> isClassTyCon tc || + tc `hasKey` eqPrimTyConKey || + tc `hasKey` eqReprPrimTyConKey + +isPredTy :: Type -> Bool +-- True of all types of kind (CONSTRAINT r) for some `r` +-- See Note [Types for coercions, predicates, and evidence] +-- +-- In particular it is True of +-- - the constraints handled by the constraint solver, +-- including quantified constraints +-- - dictionary functions (forall a. Eq a => Eq [a]) +isPredTy ty = case typeTypeOrConstraint ty of + TypeLike -> False + ConstraintLike -> True + +typeDeterminesValue :: PredType -> Bool +-- ^ Is the type *guaranteed* to determine the value? +-- Might say No even if the type does determine the value. +-- See Note [Type determines value] +typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty) + + +{- +Note [Evidence for quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The superclass mechanism in GHC.Tc.Solver.Dict.makeSuperClasses risks +taking a quantified constraint like + (forall a. C a => a ~ b) +and generate superclass evidence + (forall a. C a => a ~# b) + +This is a funny thing: neither isPredTy nor isCoVarType are true +of it. So we are careful not to generate it in the first place: +see Note [Equality superclasses in quantified constraints] +in GHC.Tc.Solver.Dict. +-} + +-- --------------------- Equality predicates --------------------------------- + +-- | Does this type classify a core (unlifted) Coercion? +-- At either role nominal or representational +-- (t1 ~# t2) or (t1 ~R# t2) +-- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep" +isEqPred :: PredType -> Bool +-- True of (s ~# t) (s ~R# t) +-- NB: but NOT true of (s ~ t) or (s ~~ t) or (Coecible s t) +isEqPred ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + | otherwise + = False + +isCoVarType :: Type -> Bool +-- Just a synonym for isEqPred +isCoVarType = isEqPred + +isReprEqPred :: PredType -> Bool +-- True of (s ~R# t) +isReprEqPred ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` eqReprPrimTyConKey + | otherwise + = False + +-- --------------------- Class predicates --------------------------------- + +mkClassPred :: Class -> [Type] -> PredType +mkClassPred clas tys = mkTyConApp (classTyCon clas) tys + +isClassPred :: PredType -> Bool +isClassPred ty = case tyConAppTyCon_maybe ty of + Just tc -> isClassTyCon tc + _ -> False + +isDictTy :: Type -> Bool +isDictTy = isClassPred + +isEqClassPred :: PredType -> Bool +isEqClassPred ty -- True of (s ~ t) and (s ~~ t) + -- ToDo: should we check saturation? + | Just tc <- tyConAppTyCon_maybe ty + , Just cls <- tyConClass_maybe tc + = isEqualityClass cls + | otherwise + = False + +isEqualityClass :: Class -> Bool +-- True of (~), (~~), and Coercible +-- These all have a single primitive-equality superclass, either (~N# or ~R#) +isEqualityClass cls + = cls `hasKey` heqTyConKey + || cls `hasKey` eqTyConKey + || cls `hasKey` coercibleTyConKey + +isCTupleClass :: Class -> Bool +isCTupleClass cls = isTupleTyCon (classTyCon cls) + +isUnaryClass :: Class -> Bool +isUnaryClass cls = isUnaryClassTyCon (classTyCon cls) + +getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) +getClassPredTys ty = case getClassPredTys_maybe ty of + Just (clas, tys) -> (clas, tys) + Nothing -> pprPanic "getClassPredTys" (ppr ty) + +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) +getClassPredTys_maybe ty = case splitTyConApp_maybe ty of + Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys) + _ -> Nothing + +classMethodTy :: Id -> Type +-- Takes a class selector op :: forall a. C a => meth_ty +-- and returns the type of its method, meth_ty +-- The selector can be a superclass selector, in which case +-- you get back a superclass +classMethodTy sel_id + = funResultTy $ -- meth_ty + dropForAlls $ -- C a => meth_ty + varType sel_id -- forall a. C n => meth_ty + +classMethodInstTy :: Id -> [Type] -> Type +-- Takes a class selector op :: forall a b. C a b => meth_ty +-- and the types [ty1, ty2] at which it is instantiated, +-- returns the instantiated type of its method, meth_ty[t1/a,t2/b] +-- The selector can be a superclass selector, in which case +-- you get back a superclass +classMethodInstTy sel_id arg_tys + = funResultTy $ + piResultTys (varType sel_id) arg_tys + +{- Note [Type determines value] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only specialise on non-impicit-parameter predicates, because these +are the ones whose *type* determines their *value*. In particular, +with implicit params, the type args *don't* say what the value of the +implicit param is! See #7101. + +So we treat implicit params just like ordinary arguments for the +purposes of specialisation. Note that we still want to specialise +functions with implicit params if they have *other* dicts which are +class params; see #17930. + +It's also not always possible to infer that a type determines the value +if type families are in play. See #19747 for one such example. + +-} + +-- --------------------- Equality predicates --------------------------------- + +-- | A choice of equality relation. This is separate from the type 'Role' +-- because 'Phantom' does not define a (non-trivial) equality relation. +data EqRel = NomEq | ReprEq + deriving (Eq, Ord) + +instance Outputable EqRel where + ppr NomEq = text "nominal equality" + ppr ReprEq = text "representational equality" + +eqRelRole :: EqRel -> Role +eqRelRole NomEq = Nominal +eqRelRole ReprEq = Representational + +-- | Creates a primitive nominal type equality predicate. +-- t1 ~# t2 +-- Invariant: the types are not Coercions +mkNomEqPred :: Type -> Type -> Type +mkNomEqPred ty1 ty2 + = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Creates a primitive representational type equality predicate. +-- t1 ~R# t2 +-- Invariant: the types are not Coercions +mkReprEqPred :: Type -> Type -> Type +mkReprEqPred ty1 ty2 + = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Makes a lifted equality predicate at the given role +mkEqPred :: EqRel -> Type -> Type -> PredType +mkEqPred NomEq = mkNomEqPred +mkEqPred ReprEq = mkReprEqPred + +-- | Makes a lifted equality predicate at the given role +mkEqPredRole :: Role -> Type -> Type -> PredType +mkEqPredRole Nominal = mkNomEqPred +mkEqPredRole Representational = mkReprEqPred +mkEqPredRole Phantom = panic "mkEqPred phantom" + +getEqPredTys :: PredType -> (Type, Type) +getEqPredTys ty + = case splitTyConApp_maybe ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqPrimTyConKey + || tc `hasKey` eqReprPrimTyConKey + -> (ty1, ty2) + _ -> pprPanic "getEqPredTys" (ppr ty) + +getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type) +getEqPredTys_maybe ty + = case splitTyConApp_maybe ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqPrimTyConKey -> Just (Nominal, ty1, ty2) + | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2) + _ -> Nothing + +getEqPredRole :: PredType -> Role +-- Precondition: the PredType is (s ~#N t) or (s ~#R t) +getEqPredRole ty = eqRelRole (predTypeEqRel ty) + +-- | Get the equality relation relevant for a pred type +-- Returns NomEq for dictionary predicates, etc +predTypeEqRel :: PredType -> EqRel +predTypeEqRel ty + | isReprEqPred ty = ReprEq + | otherwise = NomEq + +pprPredType :: PredType -> SDoc +-- Special case for (t1 ~# t2) and (t1 ~R# t2) +pprPredType pred + = case classifyPredType pred of + EqPred eq_rel t1 t2 -> sep [ ppr t1, ppr (getOccName eq_tc) <+> ppr t2 ] + where + eq_tc = case eq_rel of + NomEq -> eqPrimTyCon + ReprEq -> eqReprPrimTyCon + _ -> ppr pred + +{- ********************************************************************* +* * + Implicit parameters +* * +********************************************************************* -} + +-- --------------------- Nomal implicit-parameter predicates --------------- + +isIPTyCon :: TyCon -> Bool +isIPTyCon tc = tc `hasKey` ipClassKey + -- Class and its corresponding TyCon have the same Unique + +isIPClass :: Class -> Bool +isIPClass cls = cls `hasKey` ipClassKey + +-- | Decomposes a predicate if it is an implicit parameter. Does not look in +-- superclasses. See also [Local implicit parameters]. +isIPPred_maybe :: Class -> [Type] -> Maybe (Type, Type) +isIPPred_maybe cls tys + | isIPClass cls + , [t1,t2] <- tys + = Just (t1,t2) + | otherwise + = Nothing + +-- | Take a type (IP sym ty), where IP is the built in IP class +-- and return (ip, MkIP, [sym,ty]), where +-- `ip` is the class-op for class IP +-- `MkIP` is the data constructor for class IP +decomposeIPPred :: Type -> (Id, [Type]) +decomposeIPPred ty + | Just (cls, tys) <- getClassPredTys_maybe ty + , [ip_op] <- classMethods cls + = assertPpr (isIPClass cls && isUnaryClass cls) (ppr ty) $ + (ip_op, tys) + | otherwise = pprPanic "decomposeIP" (ppr ty) + +-- --------------------- ExceptionContext predicates -------------------------- + +-- | Is a 'PredType' an @ExceptionContext@ implicit parameter? +-- +-- If so, return the name of the parameter. +isExceptionContextPred :: Class -> [Type] -> Maybe FastString +isExceptionContextPred cls tys + | [ty1, ty2] <- tys + , isIPClass cls + , isExceptionContextTy ty2 + = isStrLitTy ty1 + | otherwise + = Nothing + +-- | Is a type an 'ExceptionContext'? +isExceptionContextTy :: Type -> Bool +isExceptionContextTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` exceptionContextTyConKey + | otherwise + = False + +-- --------------------- CallStack predicates --------------------------------- + +isCallStackPredTy :: Type -> Bool +-- True of HasCallStack, or IP "blah" CallStack +isCallStackPredTy ty + | Just (tc, tys) <- splitTyConApp_maybe ty + , Just cls <- tyConClass_maybe tc + , Just {} <- isCallStackPred cls tys + = True + | otherwise + = False + +-- | Is a 'PredType' a 'CallStack' implicit parameter? +-- +-- If so, return the name of the parameter. +isCallStackPred :: Class -> [Type] -> Maybe FastString +isCallStackPred cls tys + | [ty1, ty2] <- tys + , isIPClass cls + , isCallStackTy ty2 + = isStrLitTy ty1 + | otherwise + = Nothing + +-- | Is a type a 'CallStack'? +isCallStackTy :: Type -> Bool +isCallStackTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` callStackTyConKey + | otherwise + = False + +-- --------------------- couldBeIPLike and mightMentionIP -------------------------- +-- See Note [Local implicit parameters] + +couldBeIPLike :: Type -> Bool +-- Is `pred`, or any of its superclasses, an implicit parameter? +-- See Note [Local implicit parameters] +couldBeIPLike pred + = might_mention_ip1 initIPRecTc (const True) (const True) pred + +mightMentionIP :: (Type -> Bool) -- ^ predicate on the string + -> (Type -> Bool) -- ^ predicate on the type + -> Class + -> [Type] -> Bool +-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if: +-- +-- - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@ +-- are both @True@, +-- - or any superclass of @cls tys@ has this property. +-- +-- See Note [Local implicit parameters] +mightMentionIP = might_mention_ip initIPRecTc + +might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool +might_mention_ip rec_clss str_cond ty_cond cls tys + | Just (str_ty, ty) <- isIPPred_maybe cls tys + = str_cond str_ty && ty_cond ty + | otherwise + = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys) + | sc_sel_id <- classSCSelIds cls ] + + +might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool +might_mention_ip1 rec_clss str_cond ty_cond ty + | Just (cls, tys) <- getClassPredTys_maybe ty + , let tc = classTyCon cls + , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss + else checkRecTc rec_clss tc + = might_mention_ip rec_clss' str_cond ty_cond cls tys + | otherwise + = False -- Includes things like (D []) where D is + -- a Constraint-ranged family; #7785 + +initIPRecTc :: RecTcChecker +initIPRecTc = setRecTcMaxBound 1 initRecTc + +{- Note [Local implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in +GHC.Tc.Solver.Dict. + +The function couldBeIPLike tells if this predicate, or any of its +superclasses, is an implicit parameter. + +Why are implicit parameters special? Unlike normal classes, we can +have local instances for implicit parameters, in the form of + let ?x = True in ... +So in various places we must be careful not to assume that any value +of the right type will do; we must carefully look for the innermost binding. +So couldBeIPLike checks whether this is an implicit parameter, or has +a superclass that is an implicit parameter. + +Several wrinkles + +* We must be careful with superclasses, as #18649 showed. Haskell + doesn't allow an implicit parameter as a superclass + class (?x::a) => C a where ... + but with a constraint tuple we might have + (% Eq a, ?x::Int %) + and /its/ superclasses, namely (Eq a) and (?x::Int), /do/ include an + implicit parameter. + + With ConstraintKinds this can apply to /any/ class, e.g. + class sc => C sc where ... + Then (C (?x::Int)) has (?x::Int) as a superclass. So we must + instantiate and check each superclass, one by one, in + hasIPSuperClasses. + +* With -XUndecidableSuperClasses, the superclass hunt can go on forever, + so we need a RecTcChecker to cut it off. + +* Another apparent additional complexity involves type families. For + example, consider + type family D (v::*->*) :: Constraint + type instance D [] = () + f :: D v => v Char -> Int + If we see a call (f "foo"), we'll pass a "dictionary" + () |> (g :: () ~ D []) + and it's good to specialise f at this dictionary. + +So the question is: can an implicit parameter "hide inside" a +type-family constraint like (D a). Well, no. We don't allow + type instance D Maybe = ?x:Int +Hence the umbrella 'otherwise' case in is_ip_like_pred. See #7785. + +Small worries (Sept 20): +* I don't see what stops us having that 'type instance'. Indeed I + think nothing does. +* I'm a little concerned about type variables; such a variable might + be instantiated to an implicit parameter. I don't think this + matters in the cases for which couldBeIPLike is used, and it's pretty + obscure anyway. +* The superclass hunt stops when it encounters the same class again, + but in principle we could have the same class, differently instantiated, + and the second time it could have an implicit parameter +I'm going to treat these as problems for another day. They are all exotic. + +Note [Using typesAreApart when calling mightMentionIP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We call 'mightMentionIP' in two situations: + + (1) to check that a predicate does not contain any implicit parameters + IP str ty, for a fixed literal str and any type ty, + (2) to check that a predicate does not contain any HasCallStack or + HasExceptionContext constraints. + +In both of these cases, we want to be sure, so we should be conservative: + + For (1), the predicate might contain an implicit parameter IP Str a, where + Str is a type family such as: + + type family MyStr where MyStr = "abc" + + To safeguard against this (niche) situation, instead of doing a simple + type equality check, we use 'typesAreApart'. This allows us to recognise + that 'IP MyStr a' contains an implicit parameter of the form 'IP "abc" ty'. + + For (2), we similarly might have + + type family MyCallStack where MyCallStack = CallStack + + Again, here we use 'typesAreApart'. This allows us to see that + + (?foo :: MyCallStack) + + is indeed a CallStack constraint, hidden under a type family. +-} + +{- ********************************************************************* +* * + Evidence variables +* * +********************************************************************* -} + +isEvId :: Var -> Bool +isEvId var = isPredTy (varType var) + +isDictId :: Id -> Bool +isDictId id = isDictTy (varType id) + + +{- ********************************************************************* +* * + scopedSort + + This function lives here becuase it uses isEvId +* * +********************************************************************* -} + +{- Note [ScopedSort] +~~~~~~~~~~~~~~~~~~~~ +Consider + + foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () + +This function type is implicitly generalised over [a, b, k, k2]. These +variables will be Specified; that is, they will be available for visible +type application. This is because they are written in the type signature +by the user. + +However, we must ask: what order will they appear in? In cases without +dependency, this is easy: we just use the lexical left-to-right ordering +of first occurrence. With dependency, we cannot get off the hook so +easily. + +We thus state: + + * These variables appear in the order as given by ScopedSort, where + the input to ScopedSort is the left-to-right order of first occurrence. + +Note that this applies only to *implicit* quantification, without a +`forall`. If the user writes a `forall`, then we just use the order given. + +ScopedSort is defined thusly (as proposed in #15743): + * Work left-to-right through the input list, with a cursor. + * If variable v at the cursor is depended on by any earlier variable w, + move v immediately before the leftmost such w. + +INVARIANT: The prefix of variables before the cursor form a valid telescope. + +Note that ScopedSort makes sense only after type inference is done and all +types/kinds are fully settled and zonked. + +-} + +-- | Do a topological sort on a list of tyvars, +-- so that binders occur before occurrences +-- E.g. given @[ a::k, k::Type, b::k ]@ +-- it'll return a well-scoped list @[ k::Type, a::k, b::k ]@. +-- +-- This is a deterministic sorting operation +-- (that is, doesn't depend on Uniques). +-- +-- It is also meant to be stable: that is, variables should not +-- be reordered unnecessarily. This is specified in Note [ScopedSort] +-- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType" + +scopedSort :: [Var] -> [Var] +scopedSort = go [] [] + where + go :: [Var] -- already sorted, in reverse order + -> [TyCoVarSet] -- each set contains all the variables which must be placed + -- before the tv corresponding to the set; they are accumulations + -- of the fvs in the sorted Var's types + + -- This list is in 1-to-1 correspondence with the sorted Vars + -- INVARIANT: + -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) + -- That is, each set in the list is a superset of all later sets. + + -> [Var] -- yet to be sorted + -> [Var] + go acc _fv_list [] = reverse acc + go acc fv_list (tv:tvs) + = go acc' fv_list' tvs + where + (acc', fv_list') = insert tv acc fv_list + + insert :: Var -- var to insert + -> [Var] -- sorted list, in reverse order + -> [TyCoVarSet] -- list of fvs, as above + -> ([Var], [TyCoVarSet]) -- augmented lists + -- Generally we put the new Var at the front of the accumulating list + -- (leading to a stable sort) unless there is are reason to put it later. + insert v [] [] = ([v], [tyCoVarsOfType (varType v)]) + insert v (a:as) (fvs:fvss) + | (isTyVar v && isId a) || -- TyVars precede Ids + (isEvId v && isId a && not (isEvId a)) || -- DictIds precede non-DictIds + (v `elemVarSet` fvs) + -- (a) put Ids after TyVars, and (b) respect dependencies + , (as', fvss') <- insert v as fvss + = (a:as', fvs `unionVarSet` fv_v : fvss') + + | otherwise -- Put `v` at the front + = (v:a:as, fvs `unionVarSet` fv_v : fvs : fvss) + where + fv_v = tyCoVarsOfType (varType v) + + -- lists not in correspondence + insert _ _ _ = panic "scopedSort" + +-- | Get the free vars of a type in scoped order +tyCoVarsOfTypeWellScoped :: Type -> [TyVar] +tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList + +-- | Get the free vars of types in scoped order +tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] +tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList + + +{- ********************************************************************* +* * +* Equality left-hand sides +* * +********************************************************************* -} + +-- | A 'CanEqLHS' is a type that can appear on the left of a canonical +-- equality: a type variable or /exactly-saturated/ type family application. +data CanEqLHS + = TyVarLHS TyVar + | TyFamLHS TyCon -- ^ TyCon of the family + [Type] -- ^ Arguments, /exactly saturating/ the family + +instance Outputable CanEqLHS where + ppr (TyVarLHS tv) = ppr tv + ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args) + +----------------------------------- +-- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated +-- type family application? +-- Does not look through type synonyms. +canEqLHS_maybe :: Type -> Maybe CanEqLHS +canEqLHS_maybe xi + | Just tv <- getTyVar_maybe xi + = Just $ TyVarLHS tv + + | otherwise + = canTyFamEqLHS_maybe xi + +canTyFamEqLHS_maybe :: Type -> Maybe CanEqLHS +canTyFamEqLHS_maybe xi + | Just (tc, args) <- tcSplitTyConApp_maybe xi + , isTypeFamilyTyCon tc + , args `lengthIs` tyConArity tc + = Just $ TyFamLHS tc args + + | otherwise + = Nothing + +-- | Convert a 'CanEqLHS' back into a 'Type' +canEqLHSType :: CanEqLHS -> Type +canEqLHSType (TyVarLHS tv) = mkTyVarTy tv +canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args + +-- | Retrieve the kind of a 'CanEqLHS' +canEqLHSKind :: CanEqLHS -> Kind +canEqLHSKind (TyVarLHS tv) = tyVarKind tv +canEqLHSKind (TyFamLHS fam_tc fam_args) = piResultTys (tyConKind fam_tc) fam_args + +-- | Are two 'CanEqLHS's equal? +eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool +eqCanEqLHS (TyVarLHS tv1) (TyVarLHS tv2) = tv1 == tv2 +eqCanEqLHS (TyFamLHS fam_tc1 fam_args1) (TyFamLHS fam_tc2 fam_args2) + = tcEqTyConApps fam_tc1 fam_args1 fam_tc2 fam_args2 +eqCanEqLHS _ _ = False + diff --git a/GHC/Core/Reduction.hs b/GHC/Core/Reduction.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Reduction.hs @@ -0,0 +1,875 @@ + +module GHC.Core.Reduction + ( + -- * Reductions + Reduction(..), ReductionN, ReductionR, HetReduction(..), + Reductions(..), + mkReduction, mkReductions, mkHetReduction, coercionRedn, + reductionOriginalType, + downgradeRedn, mkSubRedn, + mkTransRedn, mkCoherenceRightRedn, mkCoherenceRightMRedn, + mkCastRedn1, mkCastRedn2, + mkReflRedn, mkGReflRightRedn, mkGReflRightMRedn, + mkGReflLeftRedn, mkGReflLeftMRedn, + mkAppRedn, mkAppRedns, mkFunRedn, + mkForAllRedn, mkHomoForAllRedn, mkTyConAppRedn, mkClassPredRedn, + mkProofIrrelRedn, mkReflCoRedn, + homogeniseHetRedn, + unzipRedns, + + -- * Rewriting type arguments + ArgsReductions(..), + simplifyArgsWorker + + ) where + +import GHC.Prelude + +import GHC.Core.Class ( Class(classTyCon) ) +import GHC.Core.Coercion +import GHC.Core.Predicate ( mkClassPred ) +import GHC.Core.TyCon ( TyCon ) +import GHC.Core.Type + +import GHC.Data.Pair ( Pair(Pair) ) +import GHC.Data.List.Infinite ( Infinite (..) ) +import qualified GHC.Data.List.Infinite as Inf + +import GHC.Types.Var ( VarBndr(..), setTyVarKind ) +import GHC.Types.Var.Env ( mkInScopeSet ) +import GHC.Types.Var.Set ( TyCoVarSet ) + +import GHC.Utils.Misc ( HasDebugCallStack, equalLength ) +import GHC.Utils.Outputable +import GHC.Utils.Panic ( assertPpr ) + +{- +%************************************************************************ +%* * + Reductions +%* * +%************************************************************************ + +Note [The Reduction type] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Many functions in the type-checker rewrite a type, using Given type equalitie +or type-family reductions, and return a Reduction, which is just a pair of the +coercion and the RHS type of the coercion: + data Reduction = Reduction Coercion !Type + +The order of the arguments to the constructor serves as a reminder +of what the Type is. In + Reduction co ty +`ty` appears to the right of `co`, reminding us that we must have: + co :: unrewritten_ty ~ ty + +Example functions that use this datatype: + GHC.Core.FamInstEnv.topNormaliseType_maybe + :: FamInstEnvs -> Type -> Maybe Reduction + GHC.Tc.Solver.Rewrite.rewrite + :: CtEvidence -> TcType -> TcS Reduction + +Having Reduction as a data type, with a strict Type field, rather than using +a pair (Coercion,Type) gives several advantages (see #20161) +* The strictness in Type improved performance in rewriting of type families + (around 2.5% improvement in T9872), +* Compared to the situation before, it gives improved consistency around + orientation of rewritings, as a Reduction is always left-to-right + (the coercion's RHS type is always the type stored in the 'Reduction'). + No more 'mkSymCo's needed to convert between left-to-right and right-to-left. + +One could imagine storing the LHS type of the coercion in the Reduction as well, +but in fact `reductionOriginalType` is very seldom used, so it's not worth it. +-} + +-- | A 'Reduction' is the result of an operation that rewrites a type @ty_in@. +-- The 'Reduction' includes the rewritten type @ty_out@ and a 'Coercion' @co@ +-- such that @co :: ty_in ~ ty_out@, where the role of the coercion is determined +-- by the context. That is, the LHS type of the coercion is the original type +-- @ty_in@, while its RHS type is the rewritten type @ty_out@. +-- +-- A Reduction is always homogeneous, unless it is wrapped inside a 'HetReduction', +-- which separately stores the kind coercion. +-- +-- See Note [The Reduction type]. +data Reduction = + Reduction + { reductionCoercion :: Coercion + , reductionReducedType :: !Type + } +-- N.B. the 'Coercion' field must be lazy: see for instance GHC.Tc.Solver.Rewrite.rewrite_tyvar2 +-- which returns an error in the 'Coercion' field when dealing with a Derived constraint +-- (which is OK as this Coercion gets ignored later). +-- We might want to revisit the strictness once Deriveds are removed. + +-- | Stores a heterogeneous reduction. +-- +-- The stored kind coercion must relate the kinds of the +-- stored reduction. That is, in @HetReduction (Reduction co xi) kco@, +-- we must have: +-- +-- > co :: ty ~ xi +-- > kco :: typeKind ty ~ typeKind xi +data HetReduction = + HetReduction + Reduction + MCoercionN + -- N.B. strictness annotations don't seem to make a difference here + +-- | Create a heterogeneous reduction. +-- +-- Pre-condition: the provided kind coercion (second argument) +-- relates the kinds of the stored reduction. +-- That is, if the coercion stored in the 'Reduction' is of the form +-- +-- > co :: ty ~ xi +-- +-- Then the kind coercion supplied must be of the form: +-- +-- > kco :: typeKind ty ~ typeKind xi +mkHetReduction :: Reduction -- ^ heterogeneous reduction + -> MCoercionN -- ^ kind coercion + -> HetReduction +mkHetReduction redn mco = HetReduction redn mco +{-# INLINE mkHetReduction #-} + +-- | Homogenise a heterogeneous reduction. +-- +-- Given @HetReduction (Reduction co xi) kco@, with +-- +-- > co :: ty ~ xi +-- > kco :: typeKind(ty) ~ typeKind(xi) +-- +-- this returns the homogeneous reduction: +-- +-- > hco :: ty ~ ( xi |> sym kco ) +homogeniseHetRedn :: Role -> HetReduction -> Reduction +homogeniseHetRedn role (HetReduction redn kco) + = mkCoherenceRightMRedn role redn (mkSymMCo kco) +{-# INLINE homogeniseHetRedn #-} + +-- | Create a 'Reduction' from a pair of a 'Coercion' and a 'Type. +-- +-- Pre-condition: the RHS type of the coercion matches the provided type +-- (perhaps up to zonking). +-- +-- Use 'coercionRedn' when you only have the coercion. +mkReduction :: Coercion -> Type -> Reduction +mkReduction co ty = Reduction co ty +{-# INLINE mkReduction #-} + +instance Outputable Reduction where + ppr redn = + braces $ vcat + [ text "reductionOriginalType:" <+> ppr (reductionOriginalType redn) + , text " reductionReducedType:" <+> ppr (reductionReducedType redn) + , text " reductionCoercion:" <+> ppr (reductionCoercion redn) + ] + +-- | A 'Reduction' in which the 'Coercion' has 'Nominal' role. +type ReductionN = Reduction + +-- | A 'Reduction' in which the 'Coercion' has 'Representational' role. +type ReductionR = Reduction + +-- | Get the original, unreduced type corresponding to a 'Reduction'. +-- +-- This is obtained by computing the LHS kind of the stored coercion, +-- which may be slow. +reductionOriginalType :: Reduction -> Type +reductionOriginalType = coercionLKind . reductionCoercion +{-# INLINE reductionOriginalType #-} + +-- | Turn a 'Coercion' into a 'Reduction' +-- by inspecting the RHS type of the coercion. +-- +-- Prefer using 'mkReduction' when you already know +-- the RHS type of the coercion, to avoid computing it anew. +coercionRedn :: Coercion -> Reduction +coercionRedn co = Reduction co (coercionRKind co) +{-# INLINE coercionRedn #-} + +-- | Downgrade the role of the coercion stored in the 'Reduction'. +downgradeRedn :: Role -- ^ desired role + -> Role -- ^ current role + -> Reduction + -> Reduction +downgradeRedn new_role old_role redn@(Reduction co _) + = redn { reductionCoercion = downgradeRole new_role old_role co } +{-# INLINE downgradeRedn #-} + +-- | Downgrade the role of the coercion stored in the 'Reduction', +-- from 'Nominal' to 'Representational'. +mkSubRedn :: Reduction -> Reduction +mkSubRedn redn@(Reduction co _) = redn { reductionCoercion = mkSubCo co } +{-# INLINE mkSubRedn #-} + +-- | Compose a reduction with a coercion on the left. +-- +-- Pre-condition: the provided coercion's RHS type must match the LHS type +-- of the coercion that is stored in the reduction. +mkTransRedn :: Coercion -> Reduction -> Reduction +mkTransRedn co1 redn@(Reduction co2 _) + = redn { reductionCoercion = co1 `mkTransCo` co2 } +{-# INLINE mkTransRedn #-} + +-- | The reflexive reduction. +mkReflRedn :: Role -> Type -> Reduction +mkReflRedn r ty = mkReduction (mkReflCo r ty) ty + +-- | Create a 'Reduction' from a kind cast, in which +-- the casted type is the rewritten type. +-- +-- Given @ty :: k1@, @mco :: k1 ~ k2@, +-- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@ +-- at the given 'Role'. +mkGReflRightRedn :: Role -> Type -> CoercionN -> Reduction +mkGReflRightRedn role ty co + = mkReduction + (mkGReflRightCo role ty co) + (mkCastTy ty co) +{-# INLINE mkGReflRightRedn #-} + +-- | Create a 'Reduction' from a kind cast, in which +-- the casted type is the rewritten type. +-- +-- Given @ty :: k1@, @mco :: k1 ~ k2@, +-- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@ +-- at the given 'Role'. +mkGReflRightMRedn :: Role -> Type -> MCoercionN -> Reduction +mkGReflRightMRedn role ty mco + = mkReduction + (mkGReflRightMCo role ty mco) + (mkCastTyMCo ty mco) +{-# INLINE mkGReflRightMRedn #-} + +-- | Create a 'Reduction' from a kind cast, in which +-- the casted type is the original (non-rewritten) type. +-- +-- Given @ty :: k1@, @mco :: k1 ~ k2@, +-- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@ +-- at the given 'Role'. +mkGReflLeftRedn :: Role -> Type -> CoercionN -> Reduction +mkGReflLeftRedn role ty co + = mkReduction + (mkGReflLeftCo role ty co) + ty +{-# INLINE mkGReflLeftRedn #-} + +-- | Create a 'Reduction' from a kind cast, in which +-- the casted type is the original (non-rewritten) type. +-- +-- Given @ty :: k1@, @mco :: k1 ~ k2@, +-- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@ +-- at the given 'Role'. +mkGReflLeftMRedn :: Role -> Type -> MCoercionN -> Reduction +mkGReflLeftMRedn role ty mco + = mkReduction + (mkGReflLeftMCo role ty mco) + ty +{-# INLINE mkGReflLeftMRedn #-} + +-- | Apply a cast to the result of a 'Reduction'. +-- +-- Given a 'Reduction' @ty1 ~co1~> (ty2 :: k2)@ and a kind coercion @kco@ +-- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> kco )@ +-- of the given 'Role' (which must match the role of the coercion stored +-- in the 'Reduction' argument). +mkCoherenceRightRedn :: Role -> Reduction -> CoercionN -> Reduction +mkCoherenceRightRedn r (Reduction co1 ty2) kco + = mkReduction + (mkCoherenceRightCo r ty2 kco co1) + (mkCastTy ty2 kco) +{-# INLINE mkCoherenceRightRedn #-} + +-- | Apply a cast to the result of a 'Reduction', using an 'MCoercionN'. +-- +-- Given a 'Reduction' @ty1 ~co1~> (ty2 :: k2)@ and a kind coercion @mco@ +-- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> mco )@ +-- of the given 'Role' (which must match the role of the coercion stored +-- in the 'Reduction' argument). +mkCoherenceRightMRedn :: Role -> Reduction -> MCoercionN -> Reduction +mkCoherenceRightMRedn r (Reduction co1 ty2) kco + = mkReduction + (mkCoherenceRightMCo r ty2 kco co1) + (mkCastTyMCo ty2 kco) +{-# INLINE mkCoherenceRightMRedn #-} + +-- | Apply a cast to a 'Reduction', casting both the original and the reduced type. +-- +-- Given @cast_co@ and 'Reduction' @ty ~co~> xi@, this function returns +-- the 'Reduction' @(ty |> cast_co) ~return_co~> (xi |> cast_co)@ +-- of the given 'Role' (which must match the role of the coercion stored +-- in the 'Reduction' argument). +-- +-- Pre-condition: the 'Type' passed in is the same as the LHS type +-- of the coercion stored in the 'Reduction'. +mkCastRedn1 :: Role + -> Type -- ^ original type + -> CoercionN -- ^ coercion to cast with + -> Reduction -- ^ rewritten type, with rewriting coercion + -> Reduction +mkCastRedn1 r ty cast_co (Reduction co xi) + -- co :: ty ~r ty' + -- return_co :: (ty |> cast_co) ~r (ty' |> cast_co) + = mkReduction + (castCoercionKind1 co r ty xi cast_co) + (mkCastTy xi cast_co) +{-# INLINE mkCastRedn1 #-} + +-- | Apply casts on both sides of a 'Reduction' (of the given 'Role'). +-- +-- Use 'mkCastRedn1' when you want to cast both the original and reduced types +-- in a 'Reduction' using the same coercion. +-- +-- Pre-condition: the 'Type' passed in is the same as the LHS type +-- of the coercion stored in the 'Reduction'. +mkCastRedn2 :: Role + -> Type -- ^ original type + -> CoercionN -- ^ coercion to cast with on the left + -> Reduction -- ^ rewritten type, with rewriting coercion + -> CoercionN -- ^ coercion to cast with on the right + -> Reduction +mkCastRedn2 r ty cast_co (Reduction nco nty) cast_co' + = mkReduction + (castCoercionKind2 nco r ty nty cast_co cast_co') + (mkCastTy nty cast_co') +{-# INLINE mkCastRedn2 #-} + +-- | Apply one 'Reduction' to another. +-- +-- Combines 'mkAppCo' and 'mkAppTy`. +mkAppRedn :: Reduction -> Reduction -> Reduction +mkAppRedn (Reduction co1 ty1) (Reduction co2 ty2) + = mkReduction (mkAppCo co1 co2) (mkAppTy ty1 ty2) +{-# INLINE mkAppRedn #-} + +-- | Create a function 'Reduction'. +-- +-- Combines 'mkFunCo' and 'mkFunTy'. +mkFunRedn :: Role + -> FunTyFlag + -> ReductionN -- ^ multiplicity reduction + -> Reduction -- ^ argument reduction + -> Reduction -- ^ result reduction + -> Reduction +mkFunRedn r af + (Reduction w_co w_ty) + (Reduction arg_co arg_ty) + (Reduction res_co res_ty) + = mkReduction + (mkFunCo r af w_co arg_co res_co) + (mkFunTy af w_ty arg_ty res_ty) +{-# INLINE mkFunRedn #-} + +-- | Create a 'Reduction' associated to a Π type, +-- from a kind 'Reduction' and a body 'Reduction'. +-- +-- Combines 'mkForAllCo' and 'mkForAllTy'. +mkForAllRedn :: ForAllTyFlag + -> TyVar + -> ReductionN -- ^ kind reduction + -> Reduction -- ^ body reduction + -> Reduction +mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty) + = mkReduction + (mkForAllCo tv1 vis vis h co) + (mkForAllTy (Bndr tv2 vis) ty) + where + tv2 = setTyVarKind tv1 ki' +{-# INLINE mkForAllRedn #-} + +-- | Create a 'Reduction' of a quantified type from a +-- 'Reduction' of the body. +-- +-- Combines 'mkHomoForAllCos' and 'mkForAllTys'. +mkHomoForAllRedn :: [TyVarBinder] -> Reduction -> Reduction +mkHomoForAllRedn bndrs (Reduction co ty) + = mkReduction + (mkHomoForAllCos bndrs co) + (mkForAllTys bndrs ty) +{-# INLINE mkHomoForAllRedn #-} + +-- | Create a 'Reduction' from a coercion between coercions. +-- +-- Combines 'mkProofIrrelCo' and 'mkCoercionTy'. +mkProofIrrelRedn :: Role -- ^ role of the created coercion, "r" + -> CoercionN -- ^ co :: phi1 ~N phi2 + -> Coercion -- ^ g1 :: phi1 + -> Coercion -- ^ g2 :: phi2 + -> Reduction -- ^ res_co :: g1 ~r g2 +mkProofIrrelRedn role co g1 g2 + = mkReduction + (mkProofIrrelCo role co g1 g2) + (mkCoercionTy g2) +{-# INLINE mkProofIrrelRedn #-} + +-- | Create a reflexive 'Reduction' whose RHS is the given 'Coercion', +-- with the specified 'Role'. +mkReflCoRedn :: Role -> Coercion -> Reduction +mkReflCoRedn role co + = mkReduction + (mkReflCo role co_ty) + co_ty + where + co_ty = mkCoercionTy co +{-# INLINE mkReflCoRedn #-} + +-- | A collection of 'Reduction's where the coercions and the types are stored separately. +-- +-- Use 'unzipRedns' to obtain 'Reductions' from a list of 'Reduction's. +-- +-- This datatype is used in 'mkAppRedns', 'mkClassPredRedns' and 'mkTyConAppRedn', +-- which expect separate types and coercions. +-- +-- Invariant: the two stored lists are of the same length, +-- and the RHS type of each coercion is the corresponding type. +data Reductions = Reductions [Coercion] [Type] + +-- | Create 'Reductions' from individual lists of coercions and types. +-- +-- The lists should be of the same length, and the RHS type of each coercion +-- should match the specified type in the other list. +mkReductions :: [Coercion] -> [Type] -> Reductions +mkReductions cos tys = Reductions cos tys +{-# INLINE mkReductions #-} + +-- | Combines 'mkAppCos' and 'mkAppTys'. +mkAppRedns :: Reduction -> Reductions -> Reduction +mkAppRedns (Reduction co ty) (Reductions cos tys) + = mkReduction (mkAppCos co cos) (mkAppTys ty tys) +{-# INLINE mkAppRedns #-} + +-- | 'TyConAppCo' for 'Reduction's: combines 'mkTyConAppCo' and `mkTyConApp`. +mkTyConAppRedn :: Role -> TyCon -> Reductions -> Reduction +mkTyConAppRedn role tc (Reductions cos tys) + = mkReduction (mkTyConAppCo role tc cos) (mkTyConApp tc tys) +{-# INLINE mkTyConAppRedn #-} + +-- | Reduce the arguments of a 'Class' 'TyCon'. +mkClassPredRedn :: Class -> Reductions -> Reduction +mkClassPredRedn cls (Reductions cos tys) + = mkReduction + (mkTyConAppCo Nominal (classTyCon cls) cos) + (mkClassPred cls tys) +{-# INLINE mkClassPredRedn #-} + +-- | Obtain 'Reductions' from a list of 'Reduction's by unzipping. +unzipRedns :: [Reduction] -> Reductions +unzipRedns = foldr accRedn (Reductions [] []) + where + accRedn :: Reduction -> Reductions -> Reductions + accRedn (Reduction co xi) (Reductions cos xis) + = Reductions (co:cos) (xi:xis) +{-# INLINE unzipRedns #-} +-- NB: this function is currently used in two locations: +-- +-- - GHC.Tc.Gen.Foreign.normaliseFfiType', with one call of the form: +-- +-- unzipRedns <$> zipWithM f tys roles +-- +-- - GHC.Tc.Solver.Monad.breakTyEqCycle_maybe, with two calls of the form: +-- +-- unzipRedns <$> mapM f tys +-- +-- It is possible to write 'mapAndUnzipM' functions to handle these cases, +-- but the above locations aren't performance critical, so it was deemed +-- to not be worth it. + +{- +%************************************************************************ +%* * + Simplifying types +%* * +%************************************************************************ + +The function below morally belongs in GHC.Tc.Solver.Rewrite, but it is used also in +FamInstEnv, and so lives here. + +Note [simplifyArgsWorker] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant (F2) of Note [Rewriting] in GHC.Tc.Solver.Rewrite says that +rewriting is homogeneous. +This causes some trouble when rewriting a function applied to a telescope +of arguments, perhaps with dependency. For example, suppose + + type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k] + +and we wish to rewrite the args of (with kind applications explicit) + + F @a @b (Just @a c) (Right @a @b d) False + +where all variables are skolems and + + a :: Type + b :: Type + c :: a + d :: b + + [G] aco :: a ~ fa + [G] bco :: b ~ fb + [G] cco :: c ~ fc + [G] dco :: d ~ fd + +The first step is to rewrite all the arguments. This is done before calling +simplifyArgsWorker. We start from + + a + b + Just @a c + Right @a @b d + False + +and get left-to-right reductions whose coercions are as follows: + + co1 :: a ~ fa + co2 :: b ~ fb + co3 :: (Just @a c) ~ (Just @fa (fc |> aco) |> co6) + co4 :: (Right @a @b d) ~ (Right @fa @fb (fd |> bco) |> co7) + co5 :: False ~ False + +where + co6 = Maybe (sym aco) :: Maybe fa ~ Maybe a + co7 = Either (sym aco) (sym bco) :: Either fa fb ~ Either a b + +We now process the rewritten args in left-to-right order. The first two args +need no further processing. But now consider the third argument. Let f3 = the rewritten +result, Just fa (fc |> aco) |> co6. +This f3 rewritten argument has kind (Maybe a), due to homogeneity of rewriting (F2). +And yet, when we build the application (F @fa @fb ...), we need this +argument to have kind (Maybe fa), not (Maybe a). We must cast this argument. +The coercion to use is determined by the kind of F: +we see in F's kind that the third argument has kind Maybe j. +Critically, we also know that the argument corresponding to j +(in our example, a) rewrote with a coercion co1. We can thus know the +coercion needed for the 3rd argument is (Maybe co1), thus building +(f3 |> Maybe co1) + +More generally, we must use the Lifting Lemma, as implemented in +Coercion.liftCoSubst. As we work left-to-right, any variable that is a +dependent parameter (j and k, in our example) gets mapped in a lifting context +to the coercion that is output from rewriting the corresponding argument (co1 +and co2, in our example). Then, after rewriting later arguments, we lift the +kind of these arguments in the lifting context that we've be building up. +This coercion is then used to keep the result of rewriting well-kinded. + +Working through our example, this is what happens: + + 1. Extend the (empty) LC with [j |-> co1]. No new casting must be done, + because the binder associated with the first argument has a closed type (no + variables). + + 2. Extend the LC with [k |-> co2]. No casting to do. + + 3. Lifting the kind (Maybe j) with our LC + yields co8 :: Maybe a ~ Maybe fa. Use (f3 |> co8) as the argument to F. + + 4. Lifting the kind (Either j k) with our LC + yields co9 :: Either a b ~ Either fa fb. Use (f4 |> co9) as the 4th + argument to F, where f4 is the rewritten form of argument 4, written above. + + 5. We lift Bool with our LC, getting ; casting has no effect. + +We're now almost done, but the new application + + F @fa @fb (f3 |> co8) (f4 |> co9) False + +has the wrong kind. Its kind is [fb], instead of the original [b]. +So we must use our LC one last time to lift the result kind [k], +getting res_co :: [fb] ~ [b], and we cast our result. + +Accordingly, the final result is + + F + @fa + @fb + (Just @fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco))) + (Right @fa @fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco))) + False + |> [sym bco] + +The res_co (in this case, [sym bco]) is the third component of the +tuple returned by simplifyArgsWorker. + +Note [Last case in simplifyArgsWorker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In writing simplifyArgsWorker's `go`, we know here that args cannot be empty, +because that case is first. We've run out of +binders. But perhaps inner_ki is a tyvar that has been instantiated with a +Π-type. + +Here is an example. + + a :: forall (k :: Type). k -> k + Proxy :: forall j. j -> Type + type family Star + axStar :: Star ~ Type + type family NoWay :: Bool + axNoWay :: NoWay ~ False + bo :: Type + [G] bc :: bo ~ Bool (in inert set) + + co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star) + co = forall (j :: sym axStar). ( -> sym axStar) + + We are rewriting: + a (forall (j :: Star). (j |> axStar) -> Star) -- 1 + (Proxy |> co) -- 2 + (bo |> sym axStar) -- 3 + (NoWay |> sym bc) -- 4 + :: Star + +First, we rewrite all the arguments (before simplifyArgsWorker), like so: + + co1 :: (forall (j :: Star). (j |> axStar) -> Star) ~ (forall j. j -> Type) -- 1 + co2 :: (Proxy |> co) ~ (Proxy |> co) -- 2 + co3 :: (bo |> sym axStar) ~ (Bool |> sym axStar) -- 3 + co4 :: (NoWay |> sym bc) ~ (False |> sym bc) -- 4 + +Then we do the process described in Note [simplifyArgsWorker]. + +1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we + don't use it. But we do build a lifting context [k -> co1] (where co1 is a + result of rewriting an argument, written above). + +2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> co1). + This is not a dependent argument, so we don't extend the lifting context. + +Now we need to deal with argument (3). +The way we normally proceed is to lift the kind of the binder, to see whether +it's dependent. +But here, the remainder of the kind of `a` that we're left with +after processing two arguments is just `k`. + +The way forward is look up k in the lifting context, getting co1. If we're at +all well-typed, co1 will be a coercion between Π-types, with at least one binder. +So, let's decompose co1 with decomposePiCos. This decomposition needs arguments to use +to instantiate any kind parameters. Look at the type of co1. If we just +decomposed it, we would end up with coercions whose types include j, which is +out of scope here. Accordingly, decomposePiCos takes a list of types whose +kinds are the *unrewritten* types in the decomposed coercion. (See comments on +decomposePiCos.) Because the rewritten types have unrewritten kinds (because +rewriting is homogeneous), passing the list of rewritten types to decomposePiCos +just won't do: later arguments' kinds won't be as expected. So we need to get +the *unrewritten* types to pass to decomposePiCos. We can do this easily enough +by taking the kind of the argument coercions, passed in originally. + +(Alternative 1: We could re-engineer decomposePiCos to deal with this situation. +But that function is already gnarly, and other call sites of decomposePiCos +would suffer from the change, even though they are much more common than this one.) + +(Alternative 2: We could avoid calling decomposePiCos entirely, integrating its +behavior into simplifyArgsWorker. This would work, I think, but then all of the +complication of decomposePiCos would end up layered on top of all the complication +here. Please, no.) + +(Alternative 3: We could pass the unrewritten arguments into simplifyArgsWorker +so that we don't have to recreate them. But that would complicate the interface +of this function to handle a very dark, dark corner case. Better to keep our +demons to ourselves here instead of exposing them to callers. This decision is +easily reversed if there is ever any performance trouble due to the call of +coercionKind.) + +So we now call + + decomposePiCos co1 + (Pair (forall (j :: Star). (j |> axStar) -> Star) (forall j. j -> Type)) + [bo |> sym axStar, NoWay |> sym bc] + +to get + + co5 :: Star ~ Type + co6 :: (j |> axStar) ~ (j |> co5), substituted to + (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5) + == bo ~ bo + res_co :: Type ~ Star + +We then use these casts on (the rewritten) (3) and (4) to get + + (Bool |> sym axStar |> co5 :: Type) -- (C3) + (False |> sym bc |> co6 :: bo) -- (C4) + +We can simplify to + + Bool -- (C3) + (False |> sym bc :: bo) -- (C4) + +Of course, we still must do the processing in Note [simplifyArgsWorker] to finish +the job. We thus want to recur. Our new function kind is the left-hand type of +co1 (gotten, recall, by lifting the variable k that was the return kind of the +original function). Why the left-hand type (as opposed to the right-hand type)? +Because we have casted all the arguments according to decomposePiCos, which gets +us from the right-hand type to the left-hand one. We thus recur with that new +function kind, zapping our lifting context, because we have essentially applied +it. + +This recursive call returns ([Bool, False], [...], Refl). The Bool and False +are the correct arguments we wish to return. But we must be careful about the +result coercion: our new, rewritten application will have kind Type, but we +want to make sure that the result coercion casts this back to Star. (Why? +Because we started with an application of kind Star, and rewriting is homogeneous.) + +So, we have to twiddle the result coercion appropriately. + +Let's check whether this is well-typed. We know + + a :: forall (k :: Type). k -> k + + a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type + + a (forall j. j -> Type) + Proxy + :: forall j. j -> Type + + a (forall j. j -> Type) + Proxy + Bool + :: Bool -> Type + + a (forall j. j -> Type) + Proxy + Bool + False + :: Type + + a (forall j. j -> Type) + Proxy + Bool + False + |> res_co + :: Star + +as desired. + +Whew. + +Historical note: I (Richard E) once thought that the final part of the kind +had to be a variable k (as in the example above). But it might not be: it could +be an application of a variable. Here is the example: + + let f :: forall (a :: Type) (b :: a -> Type). b (Any @a) + k :: Type + x :: k + + rewrite (f @Type @((->) k) x) + +After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)` +is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded. + +-} + +-- | Stores 'Reductions' as well as a kind coercion. +-- +-- Used when rewriting arguments to a type function @f@. +-- +-- Invariant: +-- when the stored reductions are of the form +-- co_i :: ty_i ~ xi_i, +-- the kind coercion is of the form +-- kco :: typeKind (f ty_1 ... ty_n) ~ typeKind (f xi_1 ... xi_n) +-- +-- The type function @f@ depends on context. +data ArgsReductions = + ArgsReductions + {-# UNPACK #-} !Reductions + !MCoercionN + -- The strictness annotations and UNPACK pragma here are crucial + -- to getting good performance in simplifyArgsWorker's tight loop. + +-- This is shared between the rewriter and the normaliser in GHC.Core.FamInstEnv. +-- See Note [simplifyArgsWorker] +{-# INLINE simplifyArgsWorker #-} +-- NB. INLINE yields a ~1% decrease in allocations in T9872d compared to INLINEABLE +-- This function is only called in two locations, so the amount of code duplication +-- should be rather reasonable despite the size of the function. +simplifyArgsWorker :: HasDebugCallStack + => [PiTyBinder] -> Kind + -- the binders & result kind (not a Π-type) of the function applied to the args + -- list of binders can be shorter or longer than the list of args + -> TyCoVarSet -- free vars of the args + -> Infinite Role-- list of roles, r + -> [Reduction] -- rewritten type arguments, arg_i + -- each comes with the coercion used to rewrite it, + -- arg_co_i :: ty_i ~ arg_i + -> ArgsReductions +-- Returns ArgsReductions (Reductions cos xis) res_co, where co_i :: ty_i ~ xi_i, +-- and res_co :: kind (f ty_1 ... ty_n) ~ kind (f xi_1 ... xi_n), where f is the function +-- that we are applying. +-- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in), +-- then (f ty_1 ... ty_n) is well kinded. Note that (f arg_1 ... arg_n) might *not* be well-kinded. +-- Massaging the arg_i in order to make the function application well-kinded is what this +-- function is all about. That is, (f xi_1 ... xi_n), where xi_i are the returned arguments, +-- *is* well kinded. +simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs + orig_roles orig_simplified_args + = go orig_lc + orig_ki_binders orig_inner_ki + orig_roles orig_simplified_args + where + orig_lc = emptyLiftingContext $ mkInScopeSet orig_fvs + + go :: LiftingContext -- mapping from tyvars to rewriting coercions + -> [PiTyBinder] -- Unsubsted binders of function's kind + -> Kind -- Unsubsted result kind of function (not a Pi-type) + -> Infinite Role -- Roles at which to rewrite these ... + -> [Reduction] -- rewritten arguments, with their rewriting coercions + -> ArgsReductions + go !lc binders inner_ki _ [] + -- The !lc makes the function strict in the lifting context + -- which means GHC can unbox that pair. A modest win. + = ArgsReductions + (mkReductions [] []) + kind_co + where + final_kind = mkPiTys binders inner_ki + kind_co | noFreeVarsOfType final_kind = MRefl + | otherwise = MCo $ liftCoSubst Nominal lc final_kind + + go lc (binder:binders) inner_ki (Inf role roles) (arg_redn:arg_redns) + = -- We rewrite an argument ty with arg_redn = Reduction arg_co arg + -- By Note [Rewriting] in GHC.Tc.Solver.Rewrite invariant (F2), + -- typeKind(ty) = typeKind(arg). + -- However, it is possible that arg will be used as an argument to a function + -- whose kind is different, if earlier arguments have been rewritten. + -- We thus need to compose the reduction with a kind coercion to ensure + -- well-kindedness (see the call to mkCoherenceRightRedn below). + -- + -- The bangs here have been observed to improve performance + -- significantly in optimized builds; see #18502 + let !kind_co = liftCoSubst Nominal lc (piTyBinderType binder) + !(Reduction casted_co casted_xi) + = mkCoherenceRightRedn role arg_redn kind_co + -- now, extend the lifting context with the new binding + !new_lc | Just tv <- namedPiTyBinder_maybe binder + = extendLiftingContextAndInScope lc tv casted_co + | otherwise + = lc + !(ArgsReductions (Reductions cos xis) final_kind_co) + = go new_lc binders inner_ki roles arg_redns + in ArgsReductions + (Reductions (casted_co:cos) (casted_xi:xis)) + final_kind_co + + -- See Note [Last case in simplifyArgsWorker] + go lc [] inner_ki roles arg_redns + = let co1 = liftCoSubst Nominal lc inner_ki + co1_kind = coercionKind co1 + unrewritten_tys = map reductionOriginalType arg_redns + (arg_cos, res_co) = decomposePiCos co1 co1_kind unrewritten_tys + casted_args = assertPpr (equalLength arg_redns arg_cos) + (ppr arg_redns $$ ppr arg_cos) + $ zipWith3 mkCoherenceRightRedn (Inf.toList roles) arg_redns arg_cos + -- In general decomposePiCos can return fewer cos than tys, + -- but not here; because we're well typed, there will be enough + -- binders. Note that decomposePiCos does substitutions, so even + -- if the original substitution results in something ending with + -- ... -> k, that k will be substituted to perhaps reveal more + -- binders. + zapped_lc = zapLiftingContext lc + Pair rewritten_kind _ = co1_kind + (bndrs, new_inner) = splitPiTys rewritten_kind + + ArgsReductions redns_out res_co_out + = go zapped_lc bndrs new_inner roles casted_args + in + ArgsReductions redns_out (res_co `mkTransMCoR` res_co_out) diff --git a/GHC/Core/RoughMap.hs b/GHC/Core/RoughMap.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/RoughMap.hs @@ -0,0 +1,546 @@ +-- | 'RoughMap' is an approximate finite map data structure keyed on +-- @['RoughMatchTc']@. This is useful when keying maps on lists of 'Type's +-- (e.g. an instance head). +module GHC.Core.RoughMap + ( -- * RoughMatchTc + RoughMatchTc(..) + , isRoughWildcard + , typeToRoughMatchTc + , RoughMatchLookupTc(..) + , typeToRoughMatchLookupTc + , roughMatchTcToLookup + , roughMatchTcs + , roughMatchTcsLookup + , instanceCantMatch + + -- * RoughMap + , RoughMap + , emptyRM + , lookupRM + , lookupRM' + , insertRM + , filterRM + , filterMatchingRM + , elemsRM + , sizeRM + , foldRM + , unionRM + ) where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Utils.Outputable +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Builtin.Types.Prim( cONSTRAINTTyConName, tYPETyConName ) + +import Control.Monad (join) +import Data.Data (Data) +import GHC.Utils.Panic + +{- +Note [RoughMap] +~~~~~~~~~~~~~~~ +We often want to compute whether one type matches another. That is, given +`ty1` and `ty2`, we want to know whether `ty1` is a substitution instance of `ty2`. + +We can bail out early by taking advantage of the following observation: + + If `ty2` is headed by a generative type constructor, say `tc`, + but `ty1` is not headed by that same type constructor, + then `ty1` does not match `ty2`. + +The idea is that we can use a `RoughMap` as a pre-filter, to produce a +short-list of candidates to examine more closely. + +This means we can avoid computing a full substitution if we represent types +as applications of known generative type constructors. So, after type synonym +expansion, we classify application heads into two categories ('RoughMatchTc') + + - `RM_KnownTc tc`: the head is the generative type constructor `tc`, + - `RM_Wildcard`: anything else. + +A (RoughMap val) is semantically a list of (key,[val]) pairs, where + key :: [RoughMatchTc] +So, writing # for `OtherTc`, and Int for `KnownTc "Int"`, we might have + [ ([#, Int, Maybe, #, Int], v1) + , ([Int, #, List], v2 ] + +This map is stored as a trie, so looking up a key is very fast. +See Note [Matching a RoughMap] and Note [Simple Matching Semantics] for details on +lookup. + +We lookup a key of type [RoughMatchLookupTc], and return the list of all values whose +keys "match": + +Given the above map, here are the results of some lookups: + Lookup key Result + ------------------------- + [Int, Int] [v1,v2] -- Matches because the prefix of both entries matches + [Int,Int,List] [v2] + [Bool] [] + +Notice that a single key can map to /multiple/ values. E.g. if we started +with (Maybe Int, val1) and (Maybe Bool, val2), we'd generate a RoughMap +that is semantically the list [( Maybe, [val1,val2] )] + +Note [RoughMap and beta reduction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is one tricky case we have to account for when matching a rough map due +to Note [Eta reduction for data families] in `GHC.Core.Coercion.Axiom`: +Consider that the user has written a program containing a data family: + +> data family Fam a b +> data instance Fam Int a = SomeType -- known henceforth as FamIntInst + +The LHS of this instance will be eta reduced, as described in Note [Eta +reduction for data families]. Consequently, we will end up with a `FamInst` +with `fi_tcs = [KnownTc Int]`. Naturally, we need RoughMap to return this +instance when queried for an instance with template, e.g., `[KnownTc Fam, +KnownTc Int, KnownTc Char]`. + +This explains the third clause of the mightMatch specification in Note [Simple Matching Semantics]. +As soon as the lookup key runs out, the remaining instances might match. + +This only matters for the data-family case of a FamInstEnv (see Note [Over-saturated matches] +in GHC.Core.FamInstEnv; it's irrelevantfor ClsInstEnv and for type-family instances. +But we use RoughMaps for all cases, so we are conservative. + +Note [Matching a RoughMap] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The /lookup key/ into a rough map (RoughMatchLookupTc) is slightly +different to the /insertion key/ (RoughMatchTc). Like the insertion +key each lookup argument is classified to a simpler key which +describes what could match that position. There are three +possibilities: + +* RML_KnownTc Name: The argument is headed by a known type + constructor. Example: 'Bool' is classified as 'RML_KnownTc Bool' + and '[Int]' is classified as `RML_KnownTc []` + +* RML_NoKnownTc: The argument is definitely not headed by any known + type constructor. Example: For instance matching 'a[sk], a[tau]' and 'F a[sk], F a[tau]' + are classified as 'RML_NoKnownTc', for family instance matching no examples. + +* RML_WildCard: The argument could match anything, we don't know + enough about it. For instance matching no examples, for type family matching, + things to do with variables. + +The interesting case for instance matching is the second case, because it does not appear in +an insertion key. The second case arises in two situations: + +1. The head of the application is a type variable. The type variable definitely + doesn't match with any of the KnownTC instances so we can discard them all. For example: + Show a[sk] or Show (a[sk] b[sk]). One place constraints like this arise is when + typechecking derived instances. + +2. The head of the application is a known type family. + For example: F a[sk]. The application of F is stuck, and because + F is a type family it won't match any KnownTC instance so it's safe to discard + all these instances. + +Of course, these two cases can still match instances of the form `forall a . Show a =>`, +and those instances are retained as they are classified as RM_WildCard instances. + +Note [Matches vs Unifiers] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lookupRM' function returns a pair of potential /matches/ and potential /unifiers/. +The potential matches is likely to be much smaller than the bag of potential unifiers due +to the reasoning about rigid type variables described in Note [Matching a RoughMap]. +On the other hand, the instances captured by the RML_NoKnownTC case can still potentially unify +with any instance (depending on the substitution of said rigid variable) so they can't be discounted +from the list of potential unifiers. This is achieved by the RML_NoKnownTC case continuing +the lookup for unifiers by replacing RML_NoKnownTC with RML_LookupOtherTC. + +This distinction between matches and unifiers is also important for type families. +During normal type family lookup, we care about matches and when checking for consistency +we care about the unifiers. This is evident in the code as `lookup_fam_inst_env` is +parameterised over a lookup function which either performs matching checking or unification +checking. + +In addition to this, we only care whether there are zero or non-zero potential +unifiers, even if we have many candidates, the search can stop before consulting +each candidate. We only need the full list of unifiers when displaying error messages. +Therefore the list is computed lazily so much work can be avoided constructing the +list in the first place. + +Note [Simple Matching Semantics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose `rm` is a RoughMap representing a set of (key,vals) pairs, + where key::[RoughMapTc] and val::a. +Suppose I look up a key lk :: [RoughMapLookupTc] in `rm` +Then I get back (matches, unifiers) where + matches = [ vals | (key,vals) <- rm, key `mightMatch` lk ] + unifiers = [ vals | (key,vals) <- rm, key `mightUnify` lk ] + +Where mightMatch is defined like this: + + mightMatch :: [RoughMapTc] -> [RoughMapLookupTc] -> Bool + mightMatch [] [] = True -- A perfectly sized match might match + mightMatch key [] = True -- A shorter lookup key matches everything + mightMatch [] (_:_) = True -- If the lookup key is longer, then still might match + -- Note [RoughMap and beta reduction] + mightMatch (k:ks) (lk:lks) = + = case (k,lk) of + -- Standard case, matching on a specific known TyCon. + (RM_KnownTc n1, RML_KnownTc n2) -> n1==n2 && mightMatch ks lks + -- For example, if the key for 'Show Bool' is [RM_KnownTc Show, RM_KnownTc Bool] + ---and we match against (Show a[sk]) [RM_KnownTc Show, RML_NoKnownTc] + -- then Show Bool can never match Show a[sk] so return False. + (RM_KnownTc _, RML_NoKnownTc) -> False + -- Wildcard cases don't inform us anything about the match. + (RM_WildCard, _ ) -> mightMatch ks lks + (_, RML_WildCard) -> mightMatch ks lks + + -- Might unify is very similar to mightMatch apart from RML_NoKnownTc may + -- unify with any instance. + mightUnify :: [RoughMapTc] -> [RoughMapLookupTc] -> Bool + mightUnify [] [] = True -- A perfectly sized match might unify + mightUnify key [] = True -- A shorter lookup key matches everything + mightUnify [] (_:_) = True + mightUnify (k:ks) (lk:lks) = + = case (k,lk) of + (RM_KnownTc n1, RML_KnownTc n2) -> n1==n2 && mightUnify ks lks + (RM_KnownTc _, RML_NoKnownTc) -> mightUnify (k:ks) (RML_WildCard:lks) + (RM_WildCard, _ ) -> mightUnify ks lks + (_, RML_WildCard) -> mightUnify ks lks + + +The guarantee that RoughMap provides is that + +if + insert_ty `tcMatchTy` lookup_ty +then definitely + typeToRoughMatchTc insert_ty `mightMatch` typeToRoughMatchLookupTc lookup_ty +but not vice versa + +this statement encodes the intuition that the RoughMap is used as a quick pre-filter +to remove instances from the matching pool. The contrapositive states that if the +RoughMap reports that the instance doesn't match then `tcMatchTy` will report that the +types don't match as well. + +-} + +{- ********************************************************************* +* * + Rough matching +* * +********************************************************************* -} + +{- Note [Rough matching in class and family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + instance C (Maybe [Tree a]) Bool +and suppose we are looking up + C Bool Bool + +We can very quickly rule the instance out, because the first +argument is headed by Maybe, whereas in the constraint we are looking +up has first argument headed by Bool. These "headed by" TyCons are +called the "rough match TyCons" of the constraint or instance. +They are used for a quick filter, to check when an instance cannot +possibly match. + +The main motivation is to avoid sucking in whole instance +declarations that are utterly useless. See GHC.Core.InstEnv +Note [ClsInst laziness and the rough-match fields]. + +INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon, +like Maybe or Either, including a newtype or a data family, both of +which are generative. It replies True to `isGenerativeTyCon tc Nominal`. + +But it is never + - A type synonym + E.g. Int and (S Bool) might match + if (S Bool) is a synonym for Int + + - A type family (#19336) + E.g. (Just a) and (F a) might match if (F a) reduces to (Just a) + albeit perhaps only after 'a' is instantiated. +-} + + +-- Key for insertion into a RoughMap +data RoughMatchTc + = RM_KnownTc Name -- INVARIANT: Name refers to a TyCon tc that responds + -- true to `isGenerativeTyCon tc Nominal`. See + -- Note [Rough matching in class and family instances] + | RM_WildCard -- e.g. type variable at the head + deriving( Data ) + +-- Key for lookup into a RoughMap +-- See Note [Matching a RoughMap] +data RoughMatchLookupTc + = RML_KnownTc Name -- ^ The position only matches the specified KnownTc + | RML_NoKnownTc -- ^ The position definitely doesn't match any KnownTc + | RML_WildCard -- ^ The position can match anything + deriving ( Data ) + +instance Outputable RoughMatchLookupTc where + ppr (RML_KnownTc nm) = text "RML_KnownTc" <+> ppr nm + ppr RML_NoKnownTc = text "RML_NoKnownTC" + ppr RML_WildCard = text "_" + +instance Outputable RoughMatchTc where + ppr (RM_KnownTc nm) = text "KnownTc" <+> ppr nm + ppr RM_WildCard = text "OtherTc" + +instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool +-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot +-- possibly be instantiated to actual, nor vice versa; +-- False is non-committal +instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as +instanceCantMatch _ _ = False -- Safe + +itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool +itemCantMatch (RM_KnownTc t) (RM_KnownTc a) = t /= a +itemCantMatch _ _ = False + +roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc +roughMatchTcToLookup (RM_KnownTc n) = RML_KnownTc n +roughMatchTcToLookup RM_WildCard = RML_WildCard + +isRoughWildcard :: RoughMatchTc -> Bool +isRoughWildcard RM_WildCard = True +isRoughWildcard (RM_KnownTc {}) = False + +roughMatchTcs :: [Type] -> [RoughMatchTc] +roughMatchTcs tys = map typeToRoughMatchTc tys + +roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc] +roughMatchTcsLookup tys = map typeToRoughMatchLookupTc tys + +typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc +typeToRoughMatchLookupTc ty + -- Expand synonyms first, as explained in Note [Rough matching in class and family instances]. + -- Failing to do so led to #22985. + | Just ty' <- coreView ty + = typeToRoughMatchLookupTc ty' + | CastTy ty' _ <- ty + = typeToRoughMatchLookupTc ty' + | otherwise + = case splitAppTys ty of + -- Case 1: Head of application is a type variable, does not match any KnownTc. + (TyVarTy {}, _) -> RML_NoKnownTc + + (TyConApp tc _, _) + -- Case 2: Head of application is a known type constructor, hence KnownTc. + | not (isTypeFamilyTyCon tc) -> RML_KnownTc $! roughMatchTyConName tc + -- Case 3: Head is a type family so it's stuck and therefore doesn't match + -- any KnownTc + | isTypeFamilyTyCon tc -> RML_NoKnownTc + + -- Fallthrough: Otherwise, anything might match this position + _ -> RML_WildCard + +typeToRoughMatchTc :: Type -> RoughMatchTc +typeToRoughMatchTc ty + | Just (ty', _) <- splitCastTy_maybe ty = typeToRoughMatchTc ty' + | Just (tc,_) <- splitTyConApp_maybe ty + , not (isTypeFamilyTyCon tc) = RM_KnownTc $! roughMatchTyConName tc + -- See Note [Rough matching in class and family instances] + | otherwise = RM_WildCard + +roughMatchTyConName :: TyCon -> Name +roughMatchTyConName tc + | tc_name == cONSTRAINTTyConName + = tYPETyConName -- TYPE and CONSTRAINT are not apart, so they must use + -- the same rough-map key. We arbitrarily use TYPE. + -- See Note [Type and Constraint are not apart] + -- wrinkle (W1) in GHC.Builtin.Types.Prim + | otherwise + = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) tc_name + where + tc_name = tyConName tc + + +-- | Trie of @[RoughMatchTc]@ +-- +-- *Examples* +-- @ +-- insert [OtherTc] 1 +-- insert [OtherTc] 2 +-- lookup [OtherTc] == [1,2] +-- @ +data RoughMap a + = RMEmpty -- An optimised (finite) form of emptyRM + -- Invariant: Empty RoughMaps are always represented with RMEmpty + + | RM { rm_empty :: Bag a + -- Keyed by an empty [RoughMapTc] + + , rm_known :: DNameEnv (RoughMap a) + -- Keyed by (RM_KnownTc tc : rm_tcs) + -- DNameEnv: see Note [InstEnv determinism] in GHC.Core.InstEnv + + , rm_wild :: RoughMap a } + -- Keyed by (RM_WildCard : rm_tcs) + deriving (Functor) + +instance Outputable a => Outputable (RoughMap a) where + ppr (RM empty known unknown) = + vcat [text "RM" + , nest 2 (vcat [ text "Empty:" <+> ppr empty + , text "Known:" <+> ppr known + , text "Unknown:" <+> ppr unknown])] + ppr RMEmpty = text "{}" + +emptyRM :: RoughMap a +emptyRM = RMEmpty + +-- | Order of result is deterministic. +lookupRM :: [RoughMatchLookupTc] -> RoughMap a -> [a] +lookupRM tcs rm = bagToList (fst $ lookupRM' tcs rm) + + +-- | N.B. Returns a 'Bag' for matches, which allows us to avoid rebuilding all of the lists +-- we find in 'rm_empty', which would otherwise be necessary due to '++' if we +-- returned a list. We use a list for unifiers because the tail is computed lazily and +-- we often only care about the first couple of potential unifiers. Constructing a +-- bag forces the tail which performs much too much work. +-- +-- See Note [Matching a RoughMap] +-- See Note [Matches vs Unifiers] +lookupRM' :: [RoughMatchLookupTc] -> RoughMap a -> (Bag a -- Potential matches + , [a]) -- Potential unifiers +lookupRM' _ RMEmpty -- The RoughMap is empty + = (emptyBag, []) + +lookupRM' [] rm -- See Note [Simple Matching Semantics] about why + = (listToBag m, m) -- we return everything when the lookup key runs out + where + m = elemsRM rm + +lookupRM' (RML_KnownTc tc : tcs) rm = + let (common_m, common_u) = lookupRM' tcs (rm_wild rm) + (m, u) = maybe (emptyBag, []) (lookupRM' tcs) (lookupDNameEnv (rm_known rm) tc) + in ( rm_empty rm `unionBags` common_m `unionBags` m + , bagToList (rm_empty rm) ++ common_u ++ u) + +-- A RML_NoKnownTC does **not** match any KnownTC but can unify +lookupRM' (RML_NoKnownTc : tcs) rm = + let (u_m, _u_u) = lookupRM' tcs (rm_wild rm) + in ( rm_empty rm `unionBags` u_m -- Definitely don't match + , snd $ lookupRM' (RML_WildCard : tcs) rm) -- But could unify.. + +lookupRM' (RML_WildCard : tcs) rm = +-- pprTrace "RM wild" (ppr tcs $$ ppr (eltsDNameEnv (rm_known rm))) $ + let (m, u) = foldDNameEnv add_one (emptyBag, []) (rm_known rm) + (u_m, u_u) = lookupRM' tcs (rm_wild rm) + in ( rm_empty rm `unionBags` u_m `unionBags` m + , bagToList (rm_empty rm) ++ u_u ++ u ) + where + add_one :: RoughMap a -> (Bag a, [a]) -> (Bag a, [a]) + add_one rm ~(m2, u2) = (m1 `unionBags` m2, u1 ++ u2) + where + (m1,u1) = lookupRM' tcs rm + +unionRM :: RoughMap a -> RoughMap a -> RoughMap a +unionRM RMEmpty a = a +unionRM a RMEmpty = a +unionRM a b = + RM { rm_empty = rm_empty a `unionBags` rm_empty b + , rm_known = plusDNameEnv_C unionRM (rm_known a) (rm_known b) + , rm_wild = rm_wild a `unionRM` rm_wild b + } + + +insertRM :: [RoughMatchTc] -> a -> RoughMap a -> RoughMap a +insertRM k v RMEmpty = + insertRM k v $ RM { rm_empty = emptyBag + , rm_known = emptyDNameEnv + , rm_wild = emptyRM } +insertRM [] v rm@(RM {}) = + -- See Note [Simple Matching Semantics] + rm { rm_empty = v `consBag` rm_empty rm } + +insertRM (RM_KnownTc k : ks) v rm@(RM {}) = + rm { rm_known = alterDNameEnv f (rm_known rm) k } + where + f Nothing = Just $ (insertRM ks v emptyRM) + f (Just m) = Just $ (insertRM ks v m) + +insertRM (RM_WildCard : ks) v rm@(RM {}) = + rm { rm_wild = insertRM ks v (rm_wild rm) } + +filterRM :: (a -> Bool) -> RoughMap a -> RoughMap a +filterRM _ RMEmpty = RMEmpty +filterRM pred rm = + normalise $ RM { + rm_empty = filterBag pred (rm_empty rm), + rm_known = mapDNameEnv (filterRM pred) (rm_known rm), + rm_wild = filterRM pred (rm_wild rm) + } + +-- | Place a 'RoughMap' in normal form, turning all empty 'RM's into +-- 'RMEmpty's. Necessary after removing items. +normalise :: RoughMap a -> RoughMap a +normalise RMEmpty = RMEmpty +normalise (RM empty known RMEmpty) + | isEmptyBag empty + , isEmptyDNameEnv known = RMEmpty +normalise rm = rm + +-- | Filter all elements that might match a particular key with the given +-- predicate. +filterMatchingRM :: (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a +filterMatchingRM _ _ RMEmpty = RMEmpty +filterMatchingRM pred [] rm = filterRM pred rm +filterMatchingRM pred (RM_KnownTc tc : tcs) rm = + normalise $ RM { + rm_empty = filterBag pred (rm_empty rm), + rm_known = alterDNameEnv (join . fmap (dropEmpty . filterMatchingRM pred tcs)) (rm_known rm) tc, + rm_wild = filterMatchingRM pred tcs (rm_wild rm) + } +filterMatchingRM pred (RM_WildCard : tcs) rm = + normalise $ RM { + rm_empty = filterBag pred (rm_empty rm), + rm_known = mapDNameEnv (filterMatchingRM pred tcs) (rm_known rm), + rm_wild = filterMatchingRM pred tcs (rm_wild rm) + } + +dropEmpty :: RoughMap a -> Maybe (RoughMap a) +dropEmpty RMEmpty = Nothing +dropEmpty rm = Just rm + +elemsRM :: RoughMap a -> [a] +elemsRM = foldRM (:) [] + +foldRM :: (a -> b -> b) -> b -> RoughMap a -> b +foldRM f = go + where + -- N.B. local worker ensures that the loop can be specialised to the fold + -- function. + go z RMEmpty = z + go z (RM{ rm_wild = unk, rm_known = known, rm_empty = empty}) = + foldr + f + (foldDNameEnv + (flip go) + (go z unk) + known + ) + empty + +nonDetStrictFoldRM :: (b -> a -> b) -> b -> RoughMap a -> b +nonDetStrictFoldRM f = go + where + -- N.B. local worker ensures that the loop can be specialised to the fold + -- function. + go !z RMEmpty = z + go z rm@(RM{}) = + foldl' + f + (nonDetStrictFoldDNameEnv + (flip go) + (go z (rm_wild rm)) + (rm_known rm) + ) + (rm_empty rm) + +sizeRM :: RoughMap a -> Int +sizeRM = nonDetStrictFoldRM (\acc _ -> acc + 1) 0 diff --git a/GHC/Core/Rules.hs b/GHC/Core/Rules.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Rules.hs @@ -0,0 +1,2027 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[CoreRules]{Rewrite rules} +-} + + +-- | Functions for collecting together and applying rewrite rules to a module. +-- The 'CoreRule' datatype itself is declared elsewhere. +module GHC.Core.Rules ( + -- ** Looking up rules + lookupRule, matchExprs, ruleLhsIsMoreSpecific, + + -- ** RuleBase, RuleEnv + RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, + updExternalPackageRules, addLocalRules, updLocalRules, + emptyRuleBase, mkRuleBase, extendRuleBaseList, + pprRuleBase, + + -- ** Checking rule applications + ruleCheckProgram, + + -- ** Manipulating 'RuleInfo' rules + extendRuleInfo, addRuleInfo, + addIdSpecialisations, addRulesToId, + + -- ** RuleBase and RuleEnv + + -- * Misc. CoreRule helpers + rulesOfBinds, getRules, pprRulesForUser, + + -- * Making rules + mkRule, mkSpecRule, roughTopNames, + ruleIsOrphan + + ) where + +import GHC.Prelude + +import GHC.Unit.Module ( Module ) +import GHC.Unit.Module.Env +import GHC.Unit.Module.ModGuts( ModGuts(..) ) +import GHC.Unit.Module.Deps( Dependencies(..) ) + +import GHC.Driver.DynFlags( DynFlags ) +import GHC.Driver.Ppr( showSDoc ) + +import GHC.Core -- All of it +import GHC.Core.Subst +import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) +import GHC.Core.FVs ( exprFreeVars, bindFreeVars + , rulesFreeVarsDSet, orphNamesOfExprs ) +import GHC.Core.Utils ( exprType, mkTick, mkTicks + , stripTicksTopT, stripTicksTopE + , isJoinBind, mkCastMCo ) +import GHC.Core.Ppr ( pprRules ) +import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) +import GHC.Core.Type as Type + ( Type, extendTvSubst, extendCvSubst + , substTy, getTyVar_maybe ) +import GHC.Core.TyCo.Ppr( pprParendType ) +import GHC.Core.Coercion as Coercion +import GHC.Core.Tidy ( tidyRules ) +import GHC.Core.Map.Expr ( eqCoreExpr ) +import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) +import GHC.Core.Make ( mkCoreLams ) +import GHC.Core.Opt.OccurAnal( occurAnalyseExpr ) + +import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) +import GHC.Builtin.Types ( anyTypeOfKind ) + +import GHC.Types.Id +import GHC.Types.Id.Info ( RuleInfo( RuleInfo ) ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Name.Occurrence( occNameFS ) +import GHC.Types.Unique.FM +import GHC.Types.Tickish +import GHC.Types.Basic + +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.Bag +import GHC.Data.List.SetOps( hasNoDups ) + +import GHC.Utils.FV( filterFV, fvVarSet ) +import GHC.Utils.Misc as Utils +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) + +import Data.List (sortBy, mapAccumL, isPrefixOf) +import Data.Function ( on ) +import Control.Monad ( guard ) + +{- +Note [Overall plumbing for rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* After the desugarer: + - The ModGuts initially contains mg_rules :: [CoreRule] of + locally-declared rules for imported Ids. + - Locally-declared rules for locally-declared Ids are attached to + the IdInfo for that Id. See Note [Attach rules to local ids] in + GHC.HsToCore.Binds + +* GHC.Iface.Tidy strips off all the rules from local Ids and adds them to + mg_rules, so that the ModGuts has *all* the locally-declared rules. + +* The HomePackageTable contains a ModDetails for each home package + module. Each contains md_rules :: [CoreRule] of rules declared in + that module. The HomePackageTable grows as ghc --make does its + up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules + are treated by the "external" route, discussed next, regardless of + which package they come from. + +* The ExternalPackageState has a single eps_rule_base :: RuleBase for + Ids in other packages. This RuleBase simply grow monotonically, as + ghc --make compiles one module after another. + + During simplification, interface files may get demand-loaded, + as the simplifier explores the unfoldings for Ids it has in + its hand. (Via an unsafePerformIO; the EPS is really a cache.) + That in turn may make the EPS rule-base grow. In contrast, the + HPT never grows in this way. + +* The result of all this is that during Core-to-Core optimisation + there are four sources of rules: + + (a) Rules in the IdInfo of the Id they are a rule for. These are + easy: fast to look up, and if you apply a substitution then + it'll be applied to the IdInfo as a matter of course. + + (b) Rules declared in this module for imported Ids, kept in the + ModGuts. If you do a substitution, you'd better apply the + substitution to these. There are seldom many of these. + + (c) Rules declared in the HomePackageTable. These never change. + + (d) Rules in the ExternalPackageTable. These can grow in response + to lazy demand-loading of interfaces. + +* At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad. + The HomePackageTable doesn't have a single RuleBase because technically + we should only be able to "see" rules "below" this module; so we + generate a RuleBase for (c) by combining rules from all the modules + "below" us. That's why we can't just select the home-package RuleBase + from HscEnv. + + [NB: we are inconsistent here. We should do the same for external + packages, but we don't. Same for type-class instances.] + +* So in the outer simplifier loop (simplifyPgmIO), we combine (b & c) into a single + RuleBase, reading + (b) from the ModGuts, + (c) from the GHC.Core.Opt.Monad, and + just before doing rule matching we read + (d) from its mutable variable + and combine it with the results from (b & c). + + In a single simplifier run new rules can be added into the EPS so it matters + to keep an up-to-date view of which rules have been loaded. For examples of + where this went wrong and caused cryptic performance regressions + see T19790 and !6735. + + +************************************************************************ +* * +\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} +* * +************************************************************************ + +A CoreRule holds details of one rule for an Id, which +includes its specialisations. + +For example, if a rule for f is + RULE "f" forall @a @b d. f @(List a) @b d = f' a b + +then when we find an application of f to matching types, we simply replace +it by the matching RHS: + f (List Int) Bool dict ===> f' Int Bool +All the stuff about how many dictionaries to discard, and what types +to apply the specialised function to, are handled by the fact that the +Rule contains a template for the result of the specialisation. +-} + +mkRule :: Module -> Bool -> Bool -> RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- compiled. See also 'GHC.Core.CoreRule' +mkRule this_mod is_auto is_local name act fn bndrs args rhs + = Rule { ru_name = name + , ru_act = act + , ru_fn = fn + , ru_bndrs = bndrs + , ru_args = args + , ru_rhs = occurAnalyseExpr rhs + -- See Note [OccInfo in unfoldings and rules] + , ru_rough = roughTopNames args + , ru_origin = this_mod + , ru_orphan = orph + , ru_auto = is_auto + , ru_local = is_local } + where + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv + -- A rule is an orphan only if none of the variables + -- mentioned on its left-hand side are locally defined + lhs_names = extendNameSet (orphNamesOfExprs args) fn + + -- Since rules get eventually attached to one of the free names + -- from the definition when compiling the ABI hash, we should make + -- it deterministic. This chooses the one with minimal OccName + -- as opposed to uniq value. + local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names + orph = chooseOrphanAnchor local_lhs_names + +-------------- +mkSpecRule :: DynFlags -> Module -> Bool -> Activation -> SDoc + -> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- Make a specialisation rule, for Specialise or SpecConstr +mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs + = case idJoinPointHood fn of + JoinPoint join_arity -> etaExpandToJoinPointRule join_arity rule + NotJoinPoint -> rule + where + rule = mkRule this_mod is_auto is_local + rule_name + inl_act -- Note [Auto-specialisation and RULES] + (idName fn) + bndrs args rhs + + is_local = isLocalId fn + rule_name = mkSpecRuleName dflags herald fn args + +mkSpecRuleName :: DynFlags -> SDoc -> Id -> [CoreExpr] -> FastString +mkSpecRuleName dflags herald fn args + = mkFastString $ showSDoc dflags $ + herald <+> ftext (occNameFS (getOccName fn)) + -- This name ends up in interface files, so use occNameFS. + -- Otherwise uniques end up there, making builds + -- less deterministic (See #4012 comment:61 ff) + <+> hsep (mapMaybe ppr_call_key_ty args) + where + ppr_call_key_ty :: CoreExpr -> Maybe SDoc + ppr_call_key_ty (Type ty) = case getTyVar_maybe ty of + Just {} -> Just (text "@_") + Nothing -> Just $ char '@' <> pprParendType ty + ppr_call_key_ty _ = Nothing + + +-------------- +roughTopNames :: [CoreExpr] -> [Maybe Name] +-- ^ Find the \"top\" free names of several expressions. +-- Such names are either: +-- +-- 1. The function finally being applied to in an application chain +-- (if that name is a GlobalId: see "GHC.Types.Var#globalvslocal"), or +-- +-- 2. The 'TyCon' if the expression is a 'Type' +-- +-- This is used for the fast-match-check for rules; +-- if the top names don't match, the rest can't +roughTopNames args = map roughTopName args + +roughTopName :: CoreExpr -> Maybe Name +roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> Just (getName tc) + Nothing -> Nothing +roughTopName (Coercion _) = Nothing +roughTopName (App f _) = roughTopName f +roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] + , isDataConWorkId f || idArity f > 0 + = Just (idName f) +roughTopName (Tick t e) | tickishFloatable t + = roughTopName e +roughTopName _ = Nothing + +ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ +-- definitely can't match @tpl@ by instantiating @tpl@. +-- It's only a one-way match; unlike instance matching we +-- don't consider unification. +-- +-- Notice that [_$_] +-- @ruleCantMatch [Nothing] [Just n2] = False@ +-- Reason: a template variable can be instantiated by a constant +-- Also: +-- @ruleCantMatch [Just n1] [Nothing] = False@ +-- Reason: a local variable @v@ in the actuals might [_$_] + +ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as +ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as +ruleCantMatch _ _ = False + +{- +Note [Care with roughTopName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + module M where { x = a:b } + module N where { ...f x... + RULE f (p:q) = ... } +You'd expect the rule to match, because the matcher can +look through the unfolding of 'x'. So we must avoid roughTopName +returning 'M.x' for the call (f x), or else it'll say "can't match" +and we won't even try!! + +However, suppose we have + RULE g (M.h x) = ... + foo = ...(g (M.k v)).... +where k is a *function* exported by M. We never really match +functions (lambdas) except by name, so in this case it seems like +a good idea to treat 'M.k' as a roughTopName of the call. +-} + +pprRulesForUser :: [CoreRule] -> SDoc +-- (a) tidy the rules +-- (b) sort them into order based on the rule name +-- (c) suppress uniques (unless -dppr-debug is on) +-- This combination makes the output stable so we can use in testing +-- It's here rather than in GHC.Core.Ppr because it calls tidyRules +pprRulesForUser rules + = withPprStyle defaultUserStyle $ + pprRules $ + sortBy (lexicalCompareFS `on` ruleName) $ + tidyRules emptyTidyEnv rules + +{- +************************************************************************ +* * + RuleInfo: the rules in an IdInfo +* * +************************************************************************ +-} + +extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo +extendRuleInfo (RuleInfo rs1 fvs1) rs2 + = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) + +addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo +addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) + = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2) + +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id rules + | null rules + = id + | otherwise + = setIdSpecialisation id $ + extendRuleInfo (idSpecialisation id) rules + +addRulesToId :: RuleBase -> Id -> Id +-- Add rules in the RuleBase to the rules in the Id +addRulesToId rule_base bndr + | Just rules <- lookupNameEnv rule_base (idName bndr) + = bndr `addIdSpecialisations` rules + | otherwise + = bndr + +-- | Gather all the rules for locally bound identifiers from the supplied bindings +rulesOfBinds :: [CoreBind] -> [CoreRule] +rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + + +{- +************************************************************************ +* * + RuleBase +* * +************************************************************************ +-} + +-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules +type RuleBase = NameEnv [CoreRule] + -- The rules are unordered; + -- we sort out any overlaps on lookup + +emptyRuleBase :: RuleBase +emptyRuleBase = emptyNameEnv + +mkRuleBase :: [CoreRule] -> RuleBase +mkRuleBase rules = extendRuleBaseList emptyRuleBase rules + +extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl' extendRuleBase rule_base new_guys + +extendRuleBase :: RuleBase -> CoreRule -> RuleBase +extendRuleBase rule_base rule + = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase rules = pprUFM rules $ \rss -> + vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- rss ] + +-- | A full rule environment which we can apply rules from. Like a 'RuleBase', +-- but it also includes the set of visible orphans we use to filter out orphan +-- rules which are not visible (even though we can see them...) +-- See Note [Orphans] in GHC.Core +data RuleEnv + = RuleEnv { re_local_rules :: !RuleBase -- Rules from this module + , re_home_rules :: !RuleBase -- Rule from the home package + -- (excl this module) + , re_eps_rules :: !RuleBase -- Rules from other packages + -- see Note [External package rules] + , re_visible_orphs :: !ModuleSet + } + +mkRuleEnv :: ModGuts -> RuleBase -> RuleBase -> RuleEnv +mkRuleEnv (ModGuts { mg_module = this_mod + , mg_deps = deps + , mg_rules = local_rules }) + eps_rules hpt_rules + = RuleEnv { re_local_rules = mkRuleBase local_rules + , re_home_rules = hpt_rules + , re_eps_rules = eps_rules + , re_visible_orphs = mkModuleSet vis_orphs } + where + vis_orphs = this_mod : dep_orphs deps + +updExternalPackageRules :: RuleEnv -> RuleBase -> RuleEnv +-- Completely over-ride the external rules in RuleEnv +updExternalPackageRules rule_env eps_rules + = rule_env { re_eps_rules = eps_rules } + +updLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv +-- Completely over-ride the local rules in RuleEnv +updLocalRules rule_env local_rules + = rule_env { re_local_rules = mkRuleBase local_rules } + +addLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv +-- Add new local rules +addLocalRules rule_env rules + = rule_env { re_local_rules = extendRuleBaseList (re_local_rules rule_env) rules } + +emptyRuleEnv :: RuleEnv +emptyRuleEnv = RuleEnv { re_local_rules = emptyNameEnv + , re_home_rules = emptyNameEnv + , re_eps_rules = emptyNameEnv + , re_visible_orphs = emptyModuleSet } + +getRules :: RuleEnv -> Id -> [CoreRule] +-- Given a RuleEnv and an Id, find the visible rules for that Id +-- See Note [Where rules are found] +-- +-- This function is quite heavily used, so it's worth trying to make it efficient +getRules (RuleEnv { re_local_rules = local_rule_base + , re_home_rules = home_rule_base + , re_eps_rules = eps_rule_base + , re_visible_orphs = orphs }) fn + + | Just {} <- isDataConId_maybe fn -- Short cut for data constructor workers + = [] -- and wrappers, which never have any rules + + | Just export_flag <- isLocalId_maybe fn + = -- LocalIds can't have rules in the local_rule_base (used for imported fns) + -- nor external packages; but there can (just) be rules in another module + -- in the home package, if it is exported + case export_flag of + NotExported -> idCoreRules fn + Exported -> case get home_rule_base of + [] -> idCoreRules fn + home_rules -> drop_orphs home_rules ++ idCoreRules fn + + | otherwise + = -- This case expression is a fast path, to avoid calling the + -- recursive (++) in the common case where there are no rules at all + case (get local_rule_base, get home_rule_base, get eps_rule_base) of + ([], [], []) -> idCoreRules fn + (local_rules, home_rules, eps_rules) -> local_rules ++ + drop_orphs home_rules ++ + drop_orphs eps_rules ++ + idCoreRules fn + where + fn_name = idName fn + drop_orphs [] = [] -- Fast path; avoid invoking recursive filter + drop_orphs xs = filter (ruleIsVisible orphs) xs + get rb = lookupNameEnv rb fn_name `orElse` [] + +ruleIsVisible :: ModuleSet -> CoreRule -> Bool +ruleIsVisible _ BuiltinRule{} = True +ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } + = notOrphan orph || origin `elemModuleSet` vis_orphs + +ruleIsOrphan :: CoreRule -> Bool +ruleIsOrphan (BuiltinRule {}) = False +ruleIsOrphan (Rule { ru_orphan = orph }) = isOrphan orph + +{- Note [Where rules are found] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rules for an Id come from two places: + (a) the ones it is born with, stored inside the Id itself (idCoreRules fn), + (b) rules added in other modules, stored in the global RuleBase (imp_rules) + +It's tempting to think that + - LocalIds have only (a) + - non-LocalIds have only (b) + +but that isn't quite right: + + - PrimOps and ClassOps are born with a bunch of rules inside the Id, + even when they are imported + + - The rules in GHC.Core.Opt.ConstantFold.builtinRules should be active even + in the module defining the Id (when it's a LocalId), but + the rules are kept in the global RuleBase + + Note [External package rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Note [Overall plumbing for rules], it is explained that the final +RuleBase which we must consider is combined from 4 different sources. + +During simplifier runs, the fourth source of rules is constantly being updated +as new interfaces are loaded into the EPS. Therefore just before we check to see +if any rules match we get the EPS RuleBase and combine it with the existing RuleBase +and then perform exactly 1 lookup into the new map. + +It is more efficient to avoid combining the environments and store the uncombined +environments as we can instead perform 1 lookup into each environment and then combine +the results. + +Essentially we use the identity: + +> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2) +> = lookupNameEnv n rb1 ++ lookupNameEnv n rb2 + +The latter being more efficient as we don't construct an intermediate +map. +-} + +{- +************************************************************************ +* * + Matching +* * +************************************************************************ +-} + +-- | The main rule matching function. Attempts to apply all (active) +-- supplied rules to this instance of an application in a given +-- context, returning the rule applied and the resulting expression if +-- successful. +lookupRule :: HasDebugCallStack + => RuleOpts -> InScopeEnv + -> (Activation -> Bool) -- When rule is active + -> Id -- Function head + -> [CoreExpr] -- Args + -> [CoreRule] -- Rules + -> Maybe (CoreRule, CoreExpr) + +-- See Note [Extra args in the target] +-- See comments on matchRule +lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules + = -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $ + case go [] rules of + [] -> Nothing + (m:ms) -> Just (findBest in_scope (fn,args') m ms) + where + rough_args = map roughTopName args + + -- Strip ticks from arguments, see Note [Tick annotations in RULE + -- matching]. We only collect ticks if a rule actually matches - + -- this matters for performance tests. + args' = map (stripTicksTopE tickishFloatable) args + ticks = concatMap (stripTicksTopT tickishFloatable) args + + go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] + go ms [] = ms + go ms (r:rs) + | Just e <- matchRule opts rule_env is_active fn args' rough_args r + = go ((r,mkTicks ticks e):ms) rs + | otherwise + = -- pprTrace "match failed" (ppr r $$ ppr args $$ + -- ppr [ (arg_id, maybeUnfoldingTemplate unf) + -- | Var arg_id <- args + -- , let unf = idUnfolding arg_id + -- , isCheapUnfolding unf] ) + go ms rs + +findBest :: InScopeSet -> (Id, [CoreExpr]) + -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) +-- All these pairs matched the expression +-- Return the pair the most specific rule +-- The (fn,args) is just for overlap reporting + +findBest _ _ (rule,ans) [] = (rule,ans) +findBest in_scope target (rule1,ans1) ((rule2,ans2):prs) + | ruleIsMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs + | ruleIsMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs + | debugIsOn = let pp_rule rule + = ifPprDebug (ppr rule) + (doubleQuotes (ftext (ruleName rule))) + in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" + (vcat [ whenPprDebug $ + text "Expression to match:" <+> ppr fn + <+> sep (map ppr args) + , text "Rule 1:" <+> pp_rule rule1 + , text "Rule 2:" <+> pp_rule rule2]) $ + findBest in_scope target (rule1,ans1) prs + | otherwise = findBest in_scope target (rule1,ans1) prs + where + (fn,args) = target + +ruleIsMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool +-- The call (rule1 `ruleIsMoreSpecific` rule2) +-- sees if rule2 can be instantiated to look like rule1 +-- See Note [ruleIsMoreSpecific] +ruleIsMoreSpecific in_scope rule1 rule2 + = case rule1 of + BuiltinRule {} -> False + Rule { ru_bndrs = bndrs1, ru_args = args1 } + -> ruleLhsIsMoreSpecific in_scope bndrs1 args1 rule2 + +ruleLhsIsMoreSpecific :: InScopeSet + -> [Var] -> [CoreExpr] -- LHS of a possible new rule + -> CoreRule -- An existing rule + -> Bool -- New one is more specific +ruleLhsIsMoreSpecific in_scope bndrs1 args1 rule2 + = case rule2 of + BuiltinRule {} -> True + Rule { ru_bndrs = bndrs2, ru_args = args2 } + -> isJust (matchExprs in_scope_env bndrs2 args2 args1) + where + full_in_scope = in_scope `extendInScopeSetList` bndrs1 + in_scope_env = ISE full_in_scope noUnfoldingFun + -- noUnfoldingFun: don't expand in templates + +noBlackList :: Activation -> Bool +noBlackList _ = False -- Nothing is black listed + +{- Note [ruleIsMoreSpecific] +~~~~~~~~~~~~~~~~~~~~~~~~ +The call (rule1 `ruleIsMoreSpecific` rule2) +sees if rule2 can be instantiated to look like rule1. + +Wrinkle: + +* We take the view that a BuiltinRule is less specific than + anything else, because we want user-defined rules to "win" + In particular, class ops have a built-in rule, but we + prefer any user-specific rules to win: + eg (#4397) + truncate :: (RealFrac a, Integral b) => a -> b + {-# RULES "truncate/Double->Int" truncate = double2Int #-} + double2Int :: Double -> Int + We want the specific RULE to beat the built-in class-op rule + +Note [Extra args in the target] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find a matching rule, we return (Just (rule, rhs)), +/but/ the rule firing has only consumed as many of the input args +as the ruleArity says. The unused arguments are handled by the code in +GHC.Core.Opt.Simplify.tryRules, using the arity of the returned rule. + +E.g. Rule "foo": forall a b. f p1 p2 = rhs + Target: f e1 e2 e3 + +Then lookupRule returns Just (Rule "foo", rhs), where Rule "foo" +has ruleArity 2. The real rewrite is + f e1 e2 e3 ==> rhs e3 + +You might think it'd be cleaner for lookupRule to deal with the +leftover arguments, by applying 'rhs' to them, but the main call +in the Simplifier works better as it is. Reason: the 'args' passed +to lookupRule are the result of a lazy substitution + +Historical note: + +At one stage I tried to match even if there are more args in the +/template/ than the target. I now think this is probably a bad idea. +Should the template (map f xs) match (map g)? I think not. For a +start, in general eta expansion wastes work. SLPJ July 99 +-} + +------------------------------------ +matchRule :: HasDebugCallStack + => RuleOpts -> InScopeEnv -> (Activation -> Bool) + -> Id -> [CoreExpr] -> [Maybe Name] + -> CoreRule -> Maybe CoreExpr + +-- If (matchRule rule args) returns Just (name,rhs) +-- then (f args) matches the rule, and the corresponding +-- rewritten RHS is rhs +-- +-- The returned expression is occurrence-analysed +-- +-- Example +-- +-- The rule +-- forall f g x. map f (map g x) ==> map (f . g) x +-- is stored +-- CoreRule "map/map" +-- [f,g,x] -- tpl_vars +-- [f,map g x] -- tpl_args +-- map (f.g) x) -- rhs +-- +-- Then the expression +-- map e1 (map e2 e3) e4 +-- results in a call to +-- matchRule the_rule [e1,map e2 e3,e4] +-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) +-- +-- NB: The 'surplus' argument e4 in the input is simply dropped. +-- See Note [Extra args in the target] + +matchRule opts rule_env _is_active fn args _rough_args + (BuiltinRule { ru_try = match_fn }) +-- Built-in rules can't be switched off, it seems + = case match_fn opts rule_env fn args of + Nothing -> Nothing + Just expr -> Just expr + +matchRule _ rule_env is_active _ args rough_args + (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops + , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) + | not (is_active act) = Nothing + | ruleCantMatch tpl_tops rough_args = Nothing + | otherwise = matchN rule_env rule_name tpl_vars tpl_args args rhs + + +--------------------------------------- +matchN :: HasDebugCallStack + => InScopeEnv + -> RuleName -> [Var] -> [CoreExpr] + -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template + -> Maybe CoreExpr +-- For a given match template and context, find bindings to wrap around +-- the entire result and what should be substituted for each template variable. +-- +-- Fail if there are too few actual arguments from the target to match the template +-- +-- See Note [Extra args in the target] +-- If there are too /many/ actual arguments, we simply ignore the +-- trailing ones, returning the result of applying the rule to a prefix +-- of the actual arguments. + +matchN ise _rule_name tmpl_vars tmpl_es target_es rhs + = do { (bind_wrapper, matched_es) <- matchExprs ise tmpl_vars tmpl_es target_es + ; return (bind_wrapper $ + mkLams tmpl_vars rhs `mkApps` matched_es) } + +matchExprs :: HasDebugCallStack + => InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr] + -> Maybe (BindWrapper, [CoreExpr]) -- 1-1 with the [Var] +matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es + = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es + ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) + (mkEmptySubst in_scope) $ + tmpl_vars `zip` tmpl_vars1 + + ; let bind_wrapper = rs_binds rule_subst + -- Floated bindings; see Note [Matching lets] + + ; return (bind_wrapper, matched_es) } + where + (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars + -- See Note [Cloning the template binders] + + init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1 + , rv_lcl = init_rn_env + , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) + , rv_unf = id_unf } + + lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr) + -- Need to return a RuleSubst solely for the benefit of fake_ty + lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) + tcv_subst (tmpl_var, tmpl_var1) + | isId tmpl_var1 + = case lookupVarEnv id_subst tmpl_var1 of + Just e | Coercion co <- e + -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) + | otherwise + -> (tcv_subst, e) + Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1 + , let co = Coercion.substCo tcv_subst refl_co + -> -- See Note [Unbound RULE binders] + (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) + | otherwise + -> unbound tmpl_var + + | otherwise + = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty') + where + ty' = case lookupVarEnv tv_subst tmpl_var1 of + Just ty -> ty + Nothing -> fake_ty -- See Note [Unbound RULE binders] + fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1)) + -- This substitution is the sole reason we accumulate + -- TCvSubst in lookup_tmpl + + unbound tmpl_var + = pprPanic "Template variable unbound in rewrite rule" $ + vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) + , text "Rule bndrs:" <+> ppr tmpl_vars + , text "LHS args:" <+> ppr tmpl_es + , text "Actual args:" <+> ppr target_es ] + +---------------------- +match_exprs :: HasDebugCallStack + => RuleMatchEnv -> RuleSubst + -> [CoreExpr] -- Templates + -> [CoreExpr] -- Targets + -> Maybe RuleSubst +-- If the targets are longer than templates, succeed, simply ignoring +-- the leftover targets. This matters in the call in matchN. +-- +-- Precondition: corresponding elements of es1 and es2 have the same +-- type, assuming earlier elements match. +-- Example: f :: forall v. v -> blah +-- match_exprs [Type a, y::a] [Type Int, 3] +-- Then, after matching Type a against Type Int, +-- the type of (y::a) matches that of (3::Int) +match_exprs _ subst [] _ + = Just subst +match_exprs renv subst (e1:es1) (e2:es2) + = do { subst' <- match renv subst e1 e2 MRefl + ; match_exprs renv subst' es1 es2 } +match_exprs _ _ _ _ = Nothing + + +{- Note [Unbound RULE binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be the case that the binder in a rule is not actually +bound on the LHS: + +* Type variables. Type synonyms with phantom args can give rise to + unbound template type variables. Consider this (#10689, + simplCore/should_compile/T10689): + + type Foo a b = b + + f :: Eq a => a -> Bool + f x = x==x + + {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} + finkle = f 'c' + + The rule looks like + forall (a::*) (d::Eq Char) (x :: Foo a Char). + f @(Foo a Char) d x = True + + Matching the rule won't bind 'a', and legitimately so. We fudge by + pretending that 'a' is bound to (Any :: *). + +* Coercion variables. On the LHS of a RULE for a local binder + we might have + RULE forall (c :: a~b). f (x |> c) = e + Now, if that binding is inlined, so that a=b=Int, we'd get + RULE forall (c :: Int~Int). f (x |> c) = e + and now when we simplify the LHS (Simplify.simplRule) we + optCoercion (look at the CoVarCo case) will turn that 'c' into Refl: + RULE forall (c :: Int~Int). f (x |> ) = 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 for c. + + This actually happened (in a RULE for a local function) + in #13410, and also in test T10602. + +Note [Cloning the template binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following match (example 1): + Template: forall x. f x + Target: f (x+1) +This should succeed, because the template variable 'x' has nothing to +do with the 'x' in the target. + +Likewise this one (example 2): + Template: forall x. f (\x.x) + Target: f (\y.y) + +We achieve this simply by using rnBndrL to clone the template +binders if they are already in scope. + +------ Historical note ------- +At one point I tried simply adding the template binders to the +in-scope set /without/ cloning them, but that failed in a horribly +obscure way in #14777. Problem was that during matching we look +up target-term variables in the in-scope set (see Note [Lookup +in-scope]). If a target-term variable happens to name-clash with a +template variable, that lookup will find the template variable, which +is /utterly/ bogus. In #14777, this transformed a term variable +into a type variable, and then crashed when we wanted its idInfo. +------ End of historical note ------- + + +************************************************************************ +* * + The main matcher +* * +********************************************************************* -} + +data RuleMatchEnv + = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* + -- (lambda/case) + , rv_tmpls :: VarSet -- Template variables + -- (after applying envL of rv_lcl) + , rv_fltR :: Subst -- Renamings for floated let-bindings + -- (domain disjoint from envR of rv_lcl) + -- See Note [Matching lets] + -- N.B. The InScopeSet of rv_fltR is always ignored; + -- see (4) in Note [Matching lets]. + , rv_unf :: IdUnfoldingFun + } + +{- Note [rv_lcl in RuleMatchEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider matching + Template: \x->f + Target: \f->f + +where 'f' is free in the template. When we meet the lambdas we must +remember to rename f :-> f' in the target, as well as x :-> f +in the template. The rv_lcl::RnEnv2 does that. + +Similarly, consider matching + Template: {a} \b->b + Target: \a->3 +We must rename the \a. Otherwise when we meet the lambdas we might +substitute [b :-> a] in the template, and then erroneously succeed in +matching what looks like the template variable 'a' against 3. + +So we must add the template vars to the in-scope set before starting; +see `init_menv` in `matchN`. +-} + +-- * The domain of the TvSubstEnv and IdSubstEnv are the template +-- variables passed into the match. +-- +-- * The BindWrapper in a RuleSubst are the bindings floated out +-- from nested matches; see the Let case of match, below +-- +data RuleSubst = RS { -- Substitution; applied only to the template, not the target + -- Domain is the template variables + -- Range never includes template variables + rs_tv_subst :: TvSubstEnv + , rs_id_subst :: IdSubstEnv + + -- Floated bindings + , rs_binds :: BindWrapper -- Floated bindings + , rs_bndrs :: [Var] -- Variables bound by floated lets + } + +type BindWrapper = CoreExpr -> CoreExpr + -- See Notes [Matching lets] and [Matching cases] + -- we represent the floated bindings as a core-to-core function + +emptyRuleSubst :: RuleSubst +emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv + , rs_binds = \e -> e, rs_bndrs = [] } + + +{- Note [Casts in the target] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As far as possible we don't want casts in the target to get in the way of +matching. E.g. +* (let bind in e) |> co +* (case e of alts) |> co +* (\ a b. f a b) |> co + +In the first two cases we want to float the cast inwards so we can match on +the let/case. This is not important in practice because the Simplifier does +this anyway. + +But the third case /is/ important: we don't want the cast to get in the way +of eta-reduction. See Note [Cancel reflexive casts] for a real life example. + +The most convenient thing is to make 'match' take an MCoercion argument, thus: + +* The main matching function + match env subst template target mco + matches template ~ (target |> mco) + +* Invariant: typeof( subst(template) ) = typeof( target |> mco ) + +Note that for applications + (e1 e2) ~ (d1 d2) |> co +where 'co' is non-reflexive, we simply fail. You might wonder about + (e1 e2) ~ ((d1 |> co1) d2) |> co2 +but the Simplifer pushes the casts in an application to to the +right, if it can, so this doesn't really arise. + +Note [Casts in the template] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note concerns `matchTemplateCast`. Consider the definition + f x = e, +and SpecConstr on call pattern + f ((e1,e2) |> co) + +The danger is that We'll make a RULE + RULE forall a,b,g. f ((a,b)|> g) = $sf a b g + $sf a b g = e[ ((a,b)|> g) / x ] + +This requires the rule-matcher to bind the coercion variable `g`. +That is Very Deeply Suspicious: + +* It would be unreasonable to match on a structured coercion in a pattern, + such as RULE forall g. f (x |> Sym g) = ... + because the strucure of a coercion is arbitrary and may change -- it's their + /type/ that matters. + +* We considered insisting that in a template, in a cast (e |> co), the the cast + `co` is always a /variable/ cv. That looks a bit more plausible, but #23209 + (and related tickets) shows that it's very fragile. For example suppose `e` + is a variable `f`, and the simplifier has an unconditional substitution + [f :-> g |> co2] + Now the rule LHS becomes (f |> (co2 ; cv)); not a coercion variable any more! + +In short, it is Very Deeply Suspicious for a rule to quantify over a coercion +variable. And SpecConstr no longer does so: see Note [SpecConstr and casts] in +SpecConstr. + +Wrinkles: + +(CT0) It is, however, OK for a cast to appear in a template provided the cast mentions + none of the template variables. For example + newtype N a = MkN (a,a) -- Axiom ax:N a :: (a,a) ~R N a + f :: N a -> bah + RULE forall b x:b y:b. f @b ((x,y) |> (axN @b)) = ... + When matching we can just move these casts to the other side: + match (tmpl |> co) tgt --> match tmpl (tgt |> sym co) + See matchTemplateCast. + +(CT1) We need to be careful about scoping, and to match left-to-right, so that we + know the substitution [a :-> b] before we meet (co :: (a,a) ~R N a), and so we + can apply that substitition + +(CT2) Annoyingly, we still want support one case in which the RULE quantifies + over a coercion variable: the dreaded map/coerce RULE. + See Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt. + + Since that can happen, matchTemplateCast laboriously checks whether the + coercion mentions a template coercion variable; and if so does the Very Deeply + Suspicious `match_co` instead. It works fine for map/coerce, where the + coercion is always a variable and will (robustly) remain so. + +See also +* Note [Coercion arguments] +* Note [Matching coercion variables] in GHC.Core.Unify. +* Note [Cast swizzling on rule LHSs] in GHC.Core.Opt.Simplify.Utils: + sm_cast_swizzle is switched off in the template of a RULE + +Note [Coercion arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~ +What if we have (f (Coercion co)) in the template, where the 'co' is a coercion +argument to f? Right now we have nothing in place to ensure that a +coercion /argument/ in the template is a variable. We really should, +perhaps by abstracting over that variable. + +C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs. + +For now, though, we simply behave badly, by failing in match_co. +We really should never rely on matching the structure of a coercion +(which is just a proof). +-} + +---------------------- +match :: HasDebugCallStack + => RuleMatchEnv + -> RuleSubst -- Substitution applies to template only + -> CoreExpr -- Template + -> CoreExpr -- Target + -> MCoercion + -> Maybe RuleSubst + +-- Postcondition (TypeInv): if matching succeeds, then +-- typeof( subst(template) ) = typeof( target |> mco ) +-- But this is /not/ a pre-condition! The types of template and target +-- may differ, see the (App e1 e2) case +-- +-- Invariant (CoInv): if mco :: ty ~ ty, then it is MRefl, not MCo co +-- See Note [Cancel reflexive casts] +-- +-- See the notes with Unify.match, which matches types +-- Everything is very similar for terms + + +------------------------ Ticks --------------------- +-- We look through certain ticks. See Note [Tick annotations in RULE matching] +match renv subst e1 (Tick t e2) mco + | tickishFloatable t + = match renv subst' e1 e2 mco + | otherwise + = Nothing + where + subst' = subst { rs_binds = rs_binds subst . mkTick t } + +match renv subst e@(Tick t e1) e2 mco + | tickishFloatable t -- Ignore floatable ticks in rule template. + = match renv subst e1 e2 mco + | otherwise + = pprPanic "Tick in rule" (ppr e) + +------------------------ Types --------------------- +match renv subst (Type ty1) (Type ty2) _mco + = match_ty renv subst ty1 ty2 + +------------------------ Coercions --------------------- +-- See Note [Coercion arguments] for why this isn't really right +match renv subst (Coercion co1) (Coercion co2) MRefl + = match_co renv subst co1 co2 + -- The MCo case corresponds to matching co ~ (co2 |> co3) + -- and I have no idea what to do there -- or even if it can occur + -- Failing seems the simplest thing to do; it's certainly safe. + +------------------------ Casts --------------------- +-- See Note [Casts in the template] +-- Note [Casts in the target] +-- Note [Cancel reflexive casts] + +match renv subst e1 (Cast e2 co2) mco + = match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoR co2 mco)) + -- checkReflexiveMCo: cancel casts if possible + -- This is important: see Note [Cancel reflexive casts] + +match renv subst (Cast e1 co1) e2 mco + = matchTemplateCast renv subst e1 co1 e2 mco + +------------------------ Literals --------------------- +match _ subst (Lit lit1) (Lit lit2) mco + | lit1 == lit2 + = assertPpr (isReflMCo mco) (ppr mco) $ + Just subst + +------------------------ Variables --------------------- +-- The Var case follows closely what happens in GHC.Core.Unify.match +match renv subst (Var v1) e2 mco + = match_var renv subst v1 (mkCastMCo e2 mco) + +match renv subst e1 (Var v2) mco -- Note [Expanding variables] + | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] + , Just e2' <- expandUnfolding_maybe (rv_unf renv v2') + = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' mco + where + v2' = lookupRnInScope rn_env v2 + rn_env = rv_lcl renv + -- Notice that we look up v2 in the in-scope set + -- See Note [Lookup in-scope] + -- No need to apply any renaming first (hence no rnOccR) + -- because of the not-inRnEnvR + +------------------------ Applications --------------------- +-- See Note [Matching higher order patterns] +match renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env }) + subst e1@App{} e2 + MRefl -- Like the App case we insist on Refl here + -- See Note [Casts in the target] + | (Var f, args) <- collectArgs e1 + , let f' = rnOccL rn_env f -- See similar rnOccL in match_var + , f' `elemVarSet` tmpls -- (HOP1) + , Just vs2 <- traverse arg_as_lcl_var args -- (HOP2), (HOP3) + , hasNoDups vs2 -- (HOP4) + , not can_decompose_app_instead + = match_tmpl_var renv subst f' (mkCoreLams vs2 e2) + -- match_tmpl_var checks (HOP5) and (HOP6) + where + arg_as_lcl_var :: CoreExpr -> Maybe Var + arg_as_lcl_var (Var v) + | Just v' <- rnOccL_maybe rn_env v + , not (v' `elemVarSet` tmpls) -- rnEnvL contains the template variables + = Just (to_target v') -- to_target: see (W1) + -- in Note [Matching higher order patterns] + arg_as_lcl_var _ = Nothing + + can_decompose_app_instead -- Template (e1 v), target (e2 v), and v # fvs(e2) + = case (e1, e2) of -- See (W2) in Note [Matching higher order patterns] + (App _ (Var v1), App f2 (Var v2)) + -> rnOccL rn_env v1 == rnOccR rn_env v2 + && not (v2 `elemVarSet` exprFreeVars f2) + _ -> False + + ---------------- + -- to_target: see (W1) in Note [Matching higher order patterns] + to_target :: Var -> Var -- From canonical variable back to target-expr variable + to_target v = lookupVarEnv rev_envR v `orElse` v + + rev_envR :: VarEnv Var -- Inverts rnEnvR: from canonical variable + -- back to target-expr variable + rev_envR = nonDetStrictFoldVarEnv_Directly add_one emptyVarEnv (rnEnvR rn_env) + add_one uniq var env = extendVarEnv env var (var `setVarUnique` uniq) + +{- Note [Matching higher order patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Higher order patterns provide a limited form of higher order matching. +See GHC Proposal #555 + https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0555-template-patterns.rst +and #22465 for more details and related work. + +Consider the potential match: + + Template: forall f. foo (\x -> f x) + Target: foo (\x -> x*2 + x) + +The expression `x*2 + x` in the target is not literally an application of a +function to the variable `x`, so the simple application rule does not apply. +However, we can match them modulo beta equivalence with the substitution: + + [f :-> \x -> x*2 + x] + +The general problem of higher order matching is tricky to implement, but +the subproblem which we call /higher order pattern matching/ is sufficient +for the given example and much easier to implement. + +Design: + +We start with terminology. + +* /Template variables/. The forall'd variables are called the template + variables. In the example match above, `f` is a template variable. + +* /Local binders/. The local binders of a rule are the variables bound + inside the template. In the example match above, `x` is a local binder. + Note that local binders can be term variables and type variables. + +A /higher order pattern/ (HOP) is a sub-expression of the template, +of form (f x y z) where: + +* (HOP1) f is a template variable +* (HOP2) x, y, z are local binders (like y in rule "wombat" above; see definitions). +* (HOP3) The arguments x, y, z are term variables +* (HOP4) The arguments x, y, z are distinct (no duplicates) + +Matching of higher order patterns (HOP-matching). A higher order pattern (f x y z) +(in the template) matches any target expression e provided: + +* (HOP5) The target has the same type as the template +* (HOP6) No local binder is free in e, other than x, y, z. + +If these two condition hold, the higher order pattern (f x y z) matches +the target expression e, yielding the substitution [f :-> \x y z. e]. +Notice that this substitution is type preserving, and the RHS +of the substitution has no free local binders. + +HOP matching is small enough to be done in-line in the `match` function. +Two wrinkles: + +(W1) Consider the potential match: + Template: forall f. foo (\x -> f x) + Target: foo (\y -> (y, y)) + During matching we make `x` the canonical variable for the lambdas + and then we see: + Template: f x rnEnvL = [] + Target: (y, y) rnEnvR = [y :-> x] + We could bind [f :-> \x. (x,x)], by applying rnEnvR substitution to the target + expression. But that is tiresome (a) because it involves a traversal, and + (b) because rnEnvR is a VarEnv Var, and we don't have a substitution function + for that. + + So instead, we invert rnEnvR, and apply it to the binders, to get + [f :-> \y. (y,y)]. This is done by `to_target` in the HOP-matching case. + It takes a little bit of thinking to be sure this will work right in the case + of shadowing. E.g. Template (\x y. f x y) Target (\p p. p*p) + Here rnEnvR will be just [p :-> y], so after inversion we'll get + [f :-> \x p. p*p] + but that is fine. + +(W2) This wrinkle concerns the overlap between the new HOP rule and the existing + decompose-application rule. See 3.1 of GHC Proposal #555 for a discussion. + + Consider potential match: + Template: forall f. foo (\x y. Just (f y x)) + Target: foo (\p q. Just (h (1+q) p))) + During matching we will encounter: + Template: f x y + Target: h (1+q) p rnEnvR = [p:->x, q:->y] + The rnEnvR renaming `[p:->x, q:->y]` is done by the matcher (today) on the fly, + to make the bound variables of the template and target "line up". + But now we can: + * Either use the new HOP rule to succeed with + [f :-> \x y. h (1+x) y] + * Or use the existing decompose-application rule to match + (f x) against (h (1+q)) and `y` against `p`. + This will succeed with + [f :-> \y. h (1+y)] + + Note that the result of the HOP rule will always be eta-equivalent to + the result of the decompose-application rule. But the proposal specifies + that we should use the decompose-application rule because it involves + less eta-expansion. + + But take care: + Template: forall f. foo (\x y. Just (f y x)) + Target: foo (\p q. Just (h (p+q) p))) + Then during matching we will encounter: + Template: f x y + Target: h (p+q) p rnEnvR = [p:->x, q:->y] + Now, we cannot use the decompose-application rule, because p is free in + (h (p+q)). So, we can only use the new HOP rule. + +(W3) You might wonder if a HOP can have /type/ arguments, thus (in Core) + RULE forall h. + f (\(MkT @b (d::Num b) (x::b)) -> h @b d x) = ... + where the HOP is (h @b d x). In principle this might be possible, but + it seems fragile; e.g. we would still need to insist that the (invisible) + @b was a type variable. And since `h` gets a polymorphic type, that + type would have to be declared by the programmer. + + Maybe one day. But for now, we insist (in `arg_as_lcl_var`)that a HOP + has only term-variable arguments. +-} + +-- Note the match on MRefl! We fail if there is a cast in the target +-- (e1 e2) ~ (d1 d2) |> co +-- See Note [Cancel reflexive casts]: in the Cast equations for 'match' +-- we aggressively ensure that if MCo is reflective, it really is MRefl. +match renv subst (App f1 a1) (App f2 a2) MRefl + = do { subst' <- match renv subst f1 f2 MRefl + ; match renv subst' a1 a2 MRefl } + +------------------------ Float lets --------------------- +match renv subst e1 (Let bind e2) mco + | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ + not (isJoinBind bind) -- can't float join point out of argument position + , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] + = match (renv { rv_fltR = flt_subst' + , rv_lcl = rv_lcl renv `extendRnInScopeSetList` new_bndrs }) + -- We are floating the let-binding out, as if it had enclosed + -- the entire target from Day 1. So we must add its binders to + -- the in-scope set (#20200) + (subst { rs_binds = rs_binds subst . Let bind' + , rs_bndrs = new_bndrs ++ rs_bndrs subst }) + e1 e2 mco + | otherwise + = Nothing + where + in_scope = rnInScopeSet (rv_lcl renv) `extendInScopeSetList` rs_bndrs subst + -- in_scope: see (4) in Note [Matching lets] + flt_subst = rv_fltR renv `setInScope` in_scope + (flt_subst', bind') = substBind flt_subst bind + new_bndrs = bindersOf bind' + +------------------------ Lambdas --------------------- +match renv subst (Lam x1 e1) e2 mco + | let casted_e2 = mkCastMCo e2 mco + in_scope = extendInScopeSetSet (rnInScopeSet (rv_lcl renv)) + (exprFreeVars casted_e2) + in_scope_env = ISE in_scope (rv_unf renv) + -- extendInScopeSetSet: The InScopeSet of rn_env is not necessarily + -- a superset of the free vars of e2; it is only guaranteed a superset of + -- applying the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe + -- wants an in-scope set that includes all the free vars of its argument. + -- Hence adding adding (exprFreeVars casted_e2) to the in-scope set (#23630) + , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2 + -- See Note [Lambdas in the template] + = let renv' = rnMatchBndr2 renv x1 x2 + subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } + in match renv' subst' e1 e2' MRefl + +match renv subst e1 e2@(Lam {}) mco + | Just (renv', e2') <- eta_reduce renv e2 -- See Note [Eta reduction in the target] + = match renv' subst e1 e2' mco + +{- Note [Lambdas in the template] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we match + Template: (\x. blah_template) + Target: (\y. blah_target) +then we want to match inside the lambdas, using rv_lcl to match up +x and y. + +But what about this? + Template (\x. (blah1 |> cv)) + Target (\y. blah2) |> co + +This happens quite readily, because the Simplifier generally moves +casts outside lambdas: see Note [Casts and lambdas] in +GHC.Core.Opt.Simplify.Utils. So, tiresomely, we want to push `co` +back inside, which is what `exprIsLambda_maybe` does. But we've +stripped off that cast, so now we need to put it back, hence mkCastMCo. + +Unlike the target, where we attempt eta-reduction, we do not attempt +to eta-reduce the template, and may therefore fail on + Template: \x. f True x + Target f True + +It's not especially easy to deal with eta reducing the template, +and never happens, because no one write eta-expanded left-hand-sides. +-} + +------------------------ Case expression --------------------- +{- Disabled: see Note [Matching cases] below +match renv (tv_subst, id_subst, binds) e1 + (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) + | exprOkForSpeculation scrut -- See Note [Matching cases] + , okToFloat rn_env bndrs (exprFreeVars scrut) + = match (renv { me_env = rn_env' }) + (tv_subst, id_subst, binds . case_wrap) + e1 rhs + where + rn_env = me_env renv + rn_env' = extendRnInScopeList rn_env bndrs + bndrs = case_bndr : alt_bndrs + case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] +-} + +match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) mco + = do { subst1 <- match_ty renv subst ty1 ty2 + ; subst2 <- match renv subst1 e1 e2 MRefl + ; let renv' = rnMatchBndr2 renv x1 x2 + ; match_alts renv' subst2 alts1 alts2 mco -- Alts are both sorted + } + +-- Everything else fails +match _ _ _e1 _e2 _mco = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ + Nothing + +------------- +eta_reduce :: RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr) +-- See Note [Eta reduction in the target] +eta_reduce renv e@(Lam {}) + = go renv id [] e + where + go :: RuleMatchEnv -> BindWrapper -> [Var] -> CoreExpr + -> Maybe (RuleMatchEnv, CoreExpr) + go renv bw vs (Let b e) = go renv (bw . Let b) vs e + + go renv bw vs (Lam v e) = go renv' bw (v':vs) e + where + (rn_env', v') = rnBndrR (rv_lcl renv) v + renv' = renv { rv_lcl = rn_env' } + + go renv bw (v:vs) (App f arg) + | Var a <- arg, v == rnOccR (rv_lcl renv) a + = go renv bw vs f + + | Type ty <- arg, Just tv <- getTyVar_maybe ty + , v == rnOccR (rv_lcl renv) tv + = go renv bw vs f + + go renv bw [] e = Just (renv, bw e) + go _ _ (_:_) _ = Nothing + +eta_reduce _ _ = Nothing + +{- Note [Eta reduction in the target] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are faced with this (#19790) + Template {x} f x + Target (\a b c. let blah in f x a b c) + +You might wonder why we have an eta-expanded target (see first subtle +point below), but regardless of how it came about, we'd like +eta-expansion not to impede matching. + +So eta_reduce does on-the-fly eta-reduction of the target expression. +Given (\a b c. let blah in e a b c), it returns (let blah in e). + +Subtle points: +* Consider a target: \x. f 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 + ). But for rule-matching we /do/ want to match template + (f a) against target (\x. f x), with a := + + This is a compelling reason for not relying on the Simplifier's + eta-reducer. + +* The Lam case of eta_reduce renames as it goes. Consider + (\x. \x. f x x). We should not eta-reduce this. As we go we rename + the first x to x1, and the second to x2; then both argument x's are x2. + +* eta_reduce does /not/ need to check that the bindings 'blah' + and expression 'e' don't mention a b c; but it /does/ extend the + rv_lcl RnEnv2 (see rn_bndr in eta_reduce). + * If 'blah' mentions the binders, the let-float rule won't + fire; and + * if 'e' mentions the binders we we'll also fail to match + e.g. because of the exprFreeVars test in match_tmpl_var. + + Example: Template: {x} f a -- Some top-level 'a' + Target: (\a b. f a a b) -- The \a shadows top level 'a' + Then eta_reduce will /succeed/, with + (rnEnvR = [a :-> a'], f a) + The returned RnEnv will map [a :-> a'], where a' is fresh. (There is + no need to rename 'b' because (in this example) it is not in scope. + So it's as if we'd returned (f a') from eta_reduce; the renaming applied + to the target is simply deferred. + +Note [Cancel reflexive casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is an example (from #19790) which we want to catch + (f x) ~ (\a b. (f x |> co) a b) |> sym co +where + f :: Int -> Stream + co :: Stream ~ T1 -> T2 -> T3 + +when we eta-reduce (\a b. blah a b) to 'blah', we'll get + (f x) ~ (f x) |> co |> sym co + +and we really want to spot that the co/sym-co cancels out. +Hence + * We keep an invariant that the MCoercion is always MRefl + if the MCoercion is reflexive + * We maintain this invariant via the call to checkReflexiveMCo + in the Cast case of 'match'. +-} + +------------- +matchTemplateCast + :: RuleMatchEnv -> RuleSubst + -> CoreExpr -> Coercion + -> CoreExpr -> MCoercion + -> Maybe RuleSubst +matchTemplateCast renv subst e1 co1 e2 mco + | isEmptyVarSet $ fvVarSet $ + filterFV (`elemVarSet` rv_tmpls renv) $ -- Check that the coercion does not + tyCoFVsOfCo substed_co -- mention any of the template variables + = -- This is the good path + -- See Note [Casts in the template] wrinkle (CT0) + match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoL mco (mkSymCo substed_co))) + + | otherwise + = -- This is the Deeply Suspicious Path + -- See Note [Casts in the template] + do { let co2 = case mco of + MRefl -> mkRepReflCo (exprType e2) + MCo co2 -> co2 + ; subst1 <- match_co renv subst co1 co2 + -- If match_co succeeds, then (exprType e1) = (exprType e2) + -- Hence the MRefl in the next line + ; match renv subst1 e1 e2 MRefl } + where + substed_co = substCo current_subst co1 + + current_subst :: Subst + current_subst = mkTCvSubst (rnInScopeSet (rv_lcl renv)) + (rs_tv_subst subst) + emptyCvSubstEnv + -- emptyCvSubstEnv: ugh! + -- If there were any CoVar substitutions they would be in + -- rs_id_subst; but we don't expect there to be any; see + -- Note [Casts in the template] + +match_co :: RuleMatchEnv + -> RuleSubst + -> Coercion + -> Coercion + -> Maybe RuleSubst +-- We only match if the template is a coercion variable or Refl: +-- see Note [Casts in the template] +-- Like 'match' it is /not/ guaranteed that +-- coercionKind template = coercionKind target +-- But if match_co succeeds, it /is/ guaranteed that +-- coercionKind (subst template) = coercionKind target + +match_co renv subst co1 co2 + | Just cv <- getCoVar_maybe co1 + = match_var renv subst cv (Coercion co2) + + | Just (ty1, r1) <- isReflCo_maybe co1 + = do { (ty2, r2) <- isReflCo_maybe co2 + ; guard (r1 == r2) + ; match_ty renv subst ty1 ty2 } + + | debugIsOn + = pprTrace "match_co: needs more cases" (ppr co1 $$ ppr co2) Nothing + -- Currently just deals with CoVarCo and Refl + + | otherwise + = Nothing + +------------- +rnMatchBndr2 :: RuleMatchEnv -> Var -> Var -> RuleMatchEnv +rnMatchBndr2 renv x1 x2 + = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + + +------------------------------------------ +match_alts :: RuleMatchEnv + -> RuleSubst + -> [CoreAlt] -- Template + -> [CoreAlt] -> MCoercion -- Target + -> Maybe RuleSubst +match_alts _ subst [] [] _ + = return subst +match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2) mco + | c1 == c2 + = do { subst1 <- match renv' subst r1 r2 mco + ; match_alts renv subst1 alts1 alts2 mco } + where + renv' = foldl' mb renv (vs1 `zip` vs2) + mb renv (v1,v2) = rnMatchBndr2 renv v1 v2 + +match_alts _ _ _ _ _ + = Nothing + +------------------------------------------ +okToFloat :: RnEnv2 -> VarSet -> Bool +okToFloat rn_env bind_fvs + = allVarSet not_captured bind_fvs + where + not_captured fv = not (inRnEnvR rn_env fv) + +------------------------------------------ +match_var :: HasDebugCallStack + => RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst +match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) + subst v1 e2 + | v1' `elemVarSet` tmpls + = match_tmpl_var renv subst v1' e2 + + | otherwise -- v1' is not a template variable; check for an exact match with e2 + = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR + Var v2 | Just v2' <- rnOccR_maybe rn_env v2 + -> -- v2 was bound by a nested lambda or case + if v1' == v2' then Just subst + else Nothing + + -- v2 is not bound nestedly; it is free + -- in the whole expression being matched + -- So it will be in the InScopeSet for flt_env (#20200) + | Var v2' <- lookupIdSubst flt_env v2 + , v1' == v2' + -> Just subst + | otherwise + -> Nothing + + _ -> Nothing + + where + v1' = rnOccL rn_env v1 + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! + +------------------------------------------ +match_tmpl_var :: HasDebugCallStack + => RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) + subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) + v1' e2 + -- anyInRnEnvR is lazy in the 2nd arg which allows us to avoid computing fvs + -- if the right side of the env is empty. + | anyInRnEnvR rn_env (exprFreeVars e2) + = Nothing -- Skolem-escape failure + -- e.g. match forall a. (\x -> a) against (\y -> y) + + | Just e1' <- lookupVarEnv id_subst v1' + = if eqCoreExpr e1' e2' + then Just subst + else Nothing + + | otherwise -- See Note [Matching variable types] + = do { subst' <- match_ty renv subst (idType v1') (exprType e2) + ; return (subst' { rs_id_subst = id_subst' }) } + where + -- e2' is the result of applying flt_env to e2 + e2' | null let_bndrs = e2 + | otherwise = substExpr flt_env e2 + + id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' + -- No further renaming to do on e2', + -- because no free var of e2' is in the rnEnvR of the envt + +------------------------------------------ + +match_ty :: RuleMatchEnv + -> RuleSubst + -> Type -- Template + -> Type -- Target + -> Maybe RuleSubst +-- Matching Core types: use the matcher in GHC.Tc.Utils.TcType. +-- Notice that we treat newtypes as opaque. For example, suppose +-- we have a specialised version of a function at a newtype, say +-- newtype T = MkT Int +-- We only want to replace (f T) with f', not (f Int). + +match_ty (RV { rv_tmpls = tmpls, rv_lcl = rn_env }) + subst@(RS { rs_tv_subst = tv_subst }) + ty1 ty2 + = do { tv_subst' <- Unify.ruleMatchTyKiX tmpls rn_env tv_subst ty1 ty2 + -- NB: ruleMatchTyKiX applis tv_subst to ty1 only + -- and of course only binds 'tmpls' + ; return (subst { rs_tv_subst = tv_subst' }) } + +{- Note [Matching variable types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When matching x ~ e, where 'x' is a template variable, we must check that +x's type matches e's type, to establish (TypeInv). For example + forall (c::Char->Int) (x::Char). + f (c x) = "RULE FIRED" +We must not match on, say (f (pred (3::Int))). + +It's actually quite difficult to come up with an example that shows +you need type matching, esp since matching is left-to-right, so type +args get matched first. But it's possible (e.g. simplrun008) and this +is the Right Thing to do. + +An alternative would be to make (TypeInf) into a /pre-condition/. It +is threatened only by the App rule. So when matching an application +(e1 e2) ~ (d1 d2) would be to collect args of the application chain, +match the types of the head, then match arg-by-arg. + +However that alternative seems a bit more complicated. And by +matching types at variables we do one match_ty for each template +variable, rather than one for each application chain. Usually there are +fewer template variables, although for simple rules it could be the other +way around. + +Note [Expanding variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is another Very Important rule: if the term being matched is a +variable, we expand it so long as its unfolding is "expandable". (Its +occurrence information is not necessarily up to date, so we don't use +it.) By "expandable" we mean a WHNF or a "constructor-like" application. +This is the key reason for "constructor-like" Ids. If we have + {-# NOINLINE [1] CONLIKE g #-} + {-# RULE f (g x) = h x #-} +then in the term + let v = g 3 in ....(f v).... +we want to make the rule fire, to replace (f v) with (h 3). + +Note [Do not expand locally-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* expand locally-bound variables, else there's a worry that the +unfolding might mention variables that are themselves renamed. +Example + case x of y { (p,q) -> ...y... } +Don't expand 'y' to (p,q) because p,q might themselves have been +renamed. Essentially we only expand unfoldings that are "outside" +the entire match. + +Hence, (a) the guard (not (isLocallyBoundR v2)) + (b) when we expand we nuke the renaming envt (nukeRnEnvR). + +Note [Tick annotations in RULE matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to unconditionally look through ticks in both template and +expression being matched. This is actually illegal for counting or +cost-centre-scoped ticks, because we have no place to put them without +changing entry counts and/or costs. So now we just fail the match in +these cases. + +On the other hand, where we are allowed to insert new cost into the +tick scope, we can float them upwards to the rule application site. + +Moreover, we may encounter ticks in the template of a rule. There are a few +ways in which these may be introduced (e.g. #18162, #17619). Such ticks are +ignored by the matcher. See Note [Simplifying rules] in +GHC.Core.Opt.Simplify.Utils for details. + +cf Note [Tick annotations in call patterns] in GHC.Core.Opt.SpecConstr + + +Note [Matching lets] +~~~~~~~~~~~~~~~~~~~~ +Matching a let-expression. Consider + RULE forall x. f (g x) = +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. ) E +In effect, we want to float the let-binding outward, to enable +the match to happen. This is the WHOLE REASON for accumulating +bindings in the RuleSubst + +We can only do this if the free variables of R are not bound by the +part of the target expression outside the let binding; e.g. + f (\v. let w = v+1 in g E) +Here we obviously cannot float the let-binding for w. Hence the +use of okToFloat. + +There are a couple of tricky points: + (a) What if floating the binding captures a variable that is + free in the entire expression? + f (let v = x+1 in v) v + --> NOT! + let v = x+1 in f (x+1) v + + (b) What if the let shadows a local binding? + f (\v -> (v, let v = x+1 in (v,v)) + --> NOT! + let v = x+1 in f (\v -> (v, (v,v))) + + (c) What if two non-nested let bindings bind the same variable? + f (let v = e1 in b1) (let v = e2 in b2) + --> NOT! + let v = e1 in let v = e2 in (f b2 b2) + See testsuite test `T4814`. + +Our cunning plan is this: + (1) Along with the growing substitution for template variables + we maintain a growing set of floated let-bindings (rs_binds) + plus the set of variables thus bound (rs_bndrs). + + (2) The RnEnv2 in the MatchEnv binds only the local binders + in the term (lambdas, case), not the floated let-bndrs. + + (3) When we encounter a `let` in the term to be matched, in the Let + case of `match`, we use `okToFloat` to check that it does not mention any + locally bound (lambda, case) variables. If so we fail. + + (4) In the Let case of `match`, we use GHC.Core.Subst.substBind to + freshen the binding (which, remember (3), mentions no locally + bound variables), in a lexically-scoped way (via rv_fltR in + MatchEnv). + + The subtle point is that we want an in-scope set for this + substitution that includes /two/ sets: + * The in-scope variables at this point, so that we avoid using + those local names for the floated binding; points (a) and (b) above. + * All "earlier" floated bindings, so that we avoid using the + same name for two different floated bindings; point (c) above. + + Because we have to compute the in-scope set here, the in-scope set + stored in `rv_fltR` is always ignored; we leave it only because it's + convenient to have `rv_fltR :: Subst` (with an always-ignored `InScopeSet`) + rather than storing three separate substitutions. + + (5) We apply that freshening substitution, in a lexically-scoped + way to the term, although lazily; this is the rv_fltR field. + +See #4814, which is an issue resulting from getting this wrong. + +Note [Matching cases] +~~~~~~~~~~~~~~~~~~~~~ +{- NOTE: This idea is currently disabled. It really only works if + the primops involved are OkForSpeculation, and, since + they have side effects readIntOfAddr and touch are not. + Maybe we'll get back to this later . -} + +Consider + f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + I# n# } } ) +This happened in a tight loop generated by stream fusion that +Roman encountered. We'd like to treat this just like the let +case, because the primops concerned are ok-for-speculation. +That is, we'd like to behave as if it had been + case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + f (I# n# } } ) + +Note [Lookup in-scope] +~~~~~~~~~~~~~~~~~~~~~~ +Consider this example + foo :: Int -> Maybe Int -> Int + foo 0 (Just n) = n + foo m (Just n) = foo (m-n) (Just n) + +SpecConstr sees this fragment: + + case w_smT of wild_Xf [Just A] { + Data.Maybe.Nothing -> lvl_smf; + Data.Maybe.Just n_acT [Just S(L)] -> + case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + }}; + +and correctly generates the rule + + RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# + sc_snn :: GHC.Prim.Int#} + $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) + = $s$wfoo_sno y_amr sc_snn ;] + +BUT we must ensure that this rule matches in the original function! +Note that the call to $wfoo is + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + +During matching we expand wild_Xf to (Just n_acT). But then we must also +expand n_acT to (I# y_amr). And we can only do that if we look up n_acT +in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding +at all. + +That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' +is so important. + + +************************************************************************ +* * + Rule-check the program +* * +************************************************************************ + + We want to know what sites have rules that could have fired but didn't. + This pass runs over the tree (without changing it) and reports such. +-} + +-- | Report partial matches for rules beginning with the specified +-- string for the purposes of error reporting +ruleCheckProgram :: RuleOpts -- ^ Rule options + -> CompilerPhase -- ^ Rule activation test + -> String -- ^ Rule pattern + -> (Id -> [CoreRule]) -- ^ Rules for an Id + -> CoreProgram -- ^ Bindings to check in + -> SDoc -- ^ Resulting check message +ruleCheckProgram ropts phase rule_pat rules binds + | isEmptyBag results + = text "Rule check results: no rule application sites" + | otherwise + = vcat [text "Rule check results:", + line, + vcat [ p $$ line | p <- bagToList results ] + ] + where + line = text (replicate 20 '-') + env = RuleCheckEnv { rc_is_active = isActive phase + , rc_id_unf = idUnfolding -- Not quite right + -- Should use activeUnfolding + , rc_pattern = rule_pat + , rc_rules = rules + , rc_ropts = ropts + , rc_in_scope = emptyInScopeSet } + + results = go env binds + + go _ [] = emptyBag + go env (bind:binds) = let (env', ds) = ruleCheckBind env bind + in ds `unionBags` go env' binds + +data RuleCheckEnv = RuleCheckEnv + { rc_is_active :: Activation -> Bool + , rc_id_unf :: IdUnfoldingFun + , rc_pattern :: String + , rc_rules :: Id -> [CoreRule] + , rc_ropts :: RuleOpts + , rc_in_scope :: InScopeSet } + +extendInScopeRC :: RuleCheckEnv -> Var -> RuleCheckEnv +extendInScopeRC env@(RuleCheckEnv { rc_in_scope = in_scope }) v + = env { rc_in_scope = in_scope `extendInScopeSet` v } + +extendInScopeListRC :: RuleCheckEnv -> [Var] -> RuleCheckEnv +extendInScopeListRC env@(RuleCheckEnv { rc_in_scope = in_scope }) vs + = env { rc_in_scope = in_scope `extendInScopeSetList` vs } + +ruleCheckBind :: RuleCheckEnv -> CoreBind -> (RuleCheckEnv, Bag SDoc) + -- The Bag returned has one SDoc for each call site found +ruleCheckBind env (NonRec b r) = (env `extendInScopeRC` b, ruleCheck env r) +ruleCheckBind env (Rec prs) = (env', unionManyBags (map (ruleCheck env') rhss)) + where + (bs, rhss) = unzip prs + env' = env `extendInScopeListRC` bs + +ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc +ruleCheck _ (Var _) = emptyBag +ruleCheck _ (Lit _) = emptyBag +ruleCheck _ (Type _) = emptyBag +ruleCheck _ (Coercion _) = emptyBag +ruleCheck env (App f a) = ruleCheckApp env (App f a) [] +ruleCheck env (Tick _ e) = ruleCheck env e +ruleCheck env (Cast e _) = ruleCheck env e +ruleCheck env (Let bd e) = let (env', ds) = ruleCheckBind env bd + in ds `unionBags` ruleCheck env' e +ruleCheck env (Lam b e) = ruleCheck (env `extendInScopeRC` b) e +ruleCheck env (Case e b _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck (env `extendInScopeListRC` (b:bs)) r + | Alt _ bs r <- as] + +ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc +ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) +ruleCheckApp env (Var f) as = ruleCheckFun env f as +ruleCheckApp env other _ = ruleCheck env other + +ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc +-- Produce a report for all rules matching the predicate +-- saying why it doesn't match the specified application + +ruleCheckFun env fn args + | null name_match_rules = emptyBag + | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) + where + name_match_rules = filter match (rc_rules env fn) + match rule = rc_pattern env `isPrefixOf` unpackFS (ruleName rule) + +ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help env fn args rules + = -- The rules match the pattern, so we want to print something + vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), + vcat (map check_rule rules)] + where + in_scope = rc_in_scope env + n_args = length args + i_args = args `zip` [1::Int ..] + rough_args = map roughTopName args + + check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule + + rule_herald (BuiltinRule { ru_name = name }) + = text "Builtin rule" <+> doubleQuotes (ftext name) + rule_herald (Rule { ru_name = name }) + = text "Rule" <+> doubleQuotes (ftext name) + + rule_info opts rule + | Just _ <- matchRule opts (ISE emptyInScopeSet (rc_id_unf env)) + noBlackList fn args rough_args rule + = text "matches (which is very peculiar!)" + + rule_info _ (BuiltinRule {}) = text "does not match" + + rule_info _ (Rule { ru_act = act, + ru_bndrs = rule_bndrs, ru_args = rule_args}) + | not (rc_is_active env act) = text "active only in later phase" + | n_args < n_rule_args = text "too few arguments" + | n_mismatches == n_rule_args = text "no arguments match" + | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" + | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" + where + n_rule_args = length rule_args + n_mismatches = length mismatches + mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, + not (isJust (match_fn rule_arg arg))] + + match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl + where + renv = RV { rv_lcl = mkRnEnv2 in_scope + , rv_tmpls = mkVarSet rule_bndrs + , rv_fltR = mkEmptySubst in_scope + , rv_unf = rc_id_unf env } diff --git a/GHC/Core/Rules/Config.hs b/GHC/Core/Rules/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Rules/Config.hs @@ -0,0 +1,19 @@ +module GHC.Core.Rules.Config where + +import GHC.Prelude +import GHC.Platform + +-- | Rule options +data RuleOpts = RuleOpts + { roPlatform :: !Platform + -- ^ Target platform + , roNumConstantFolding :: !Bool + -- ^ Enable constant folding through nested expressions. + -- + -- See Note [Constant folding through nested expressions] in GHC.Core.Opt.ConstantFold + , roExcessRationalPrecision :: !Bool + -- ^ Cut down precision of Rational values to that of Float/Double if disabled + , roBignumRules :: !Bool + -- ^ Enable rules for bignums + } + diff --git a/GHC/Core/Seq.hs b/GHC/Core/Seq.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Seq.hs @@ -0,0 +1,117 @@ +-- | +-- Various utilities for forcing Core structures +-- +-- It can often be useful to force various parts of the AST. This module +-- provides a number of @seq@-like functions to accomplish this. + +module GHC.Core.Seq ( + -- * Utilities for forcing Core structures + seqExpr, seqExprs, seqUnfolding, seqRules, + megaSeqIdInfo, seqRuleInfo, seqBinds, + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Types.Id.Info +import GHC.Types.Demand( seqDemand, seqDmdSig ) +import GHC.Types.Cpr( seqCprSig ) +import GHC.Types.Basic( seqOccInfo ) +import GHC.Types.Tickish +import GHC.Types.Var.Set( seqDVarSet ) +import GHC.Types.Var( varType, tyVarKind ) +import GHC.Core.Type( seqType, isTyVar ) +import GHC.Core.Coercion( seqCo ) +import GHC.Types.Id( idInfo ) + +-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the +-- compiler +megaSeqIdInfo :: IdInfo -> () +megaSeqIdInfo info + = seqRuleInfo (ruleInfo info) `seq` + +-- Omitting this improves runtimes a little, presumably because +-- some unfoldings are not calculated at all +-- seqUnfolding (realUnfoldingInfo info) `seq` + + seqDemand (demandInfo info) `seq` + seqDmdSig (dmdSigInfo info) `seq` + seqCprSig (cprSigInfo info) `seq` + seqCaf (cafInfo info) `seq` + seqOneShot (oneShotInfo info) `seq` + seqOccInfo (occInfo info) + +seqOneShot :: OneShotInfo -> () +seqOneShot l = l `seq` () + +seqRuleInfo :: RuleInfo -> () +seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqDVarSet fvs + +seqCaf :: CafInfo -> () +seqCaf c = c `seq` () + +seqRules :: [CoreRule] -> () +seqRules [] = () +seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) + = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules +seqRules (BuiltinRule {} : rules) = seqRules rules + +seqExpr :: CoreExpr -> () +seqExpr (Var v) = v `seq` () +seqExpr (Lit lit) = lit `seq` () +seqExpr (App f a) = seqExpr f `seq` seqExpr a +seqExpr (Lam b e) = seqBndr b `seq` seqExpr e +seqExpr (Let b e) = seqBind b `seq` seqExpr e +seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as +seqExpr (Cast e co) = seqExpr e `seq` seqCo co +seqExpr (Tick n e) = seqTickish n `seq` seqExpr e +seqExpr (Type t) = seqType t +seqExpr (Coercion co) = seqCo co + +seqExprs :: [CoreExpr] -> () +seqExprs [] = () +seqExprs (e:es) = seqExpr e `seq` seqExprs es + +seqTickish :: CoreTickish -> () +seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () +seqTickish HpcTick{} = () +seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids +seqTickish SourceNote{} = () + +seqBndr :: CoreBndr -> () +seqBndr b | isTyVar b = seqType (tyVarKind b) + | otherwise = seqType (varType b) `seq` + megaSeqIdInfo (idInfo b) + +seqBndrs :: [CoreBndr] -> () +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs + +seqBinds :: [Bind CoreBndr] -> () +seqBinds bs = foldr (seq . seqBind) () bs + +seqBind :: Bind CoreBndr -> () +seqBind (NonRec b e) = seqBndr b `seq` seqExpr e +seqBind (Rec prs) = seqPairs prs + +seqPairs :: [(CoreBndr, CoreExpr)] -> () +seqPairs [] = () +seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs + +seqAlts :: [CoreAlt] -> () +seqAlts [] = () +seqAlts (Alt c bs e:alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts + +seqUnfolding :: Unfolding -> () +seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, + uf_cache = cache, uf_guidance = g}) + = seqExpr e `seq` top `seq` cache `seq` seqGuidance g + -- The unf_cache :: UnfoldingCache field is a strict data type, + -- so it is sufficient to use plain `seq` for this field + -- See Note [UnfoldingCache] in GHC.Core + +seqUnfolding _ = () + +seqGuidance :: UnfoldingGuidance -> () +seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () +seqGuidance _ = () diff --git a/GHC/Core/SimpleOpt.hs b/GHC/Core/SimpleOpt.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/SimpleOpt.hs @@ -0,0 +1,1612 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + + +module GHC.Core.SimpleOpt ( + SimpleOpts (..), defaultSimpleOpts, + + -- ** Simple expression optimiser + simpleOptPgm, simpleOptExpr, simpleOptExprNoInline, simpleOptExprWith, + + -- ** Join points + joinPointBinding_maybe, joinPointBindings_maybe, + + -- ** Predicates on expressions + exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, + + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Opt.Arity +import GHC.Core.Subst +import GHC.Core.Utils +import GHC.Core.FVs +import GHC.Core.Unfold +import GHC.Core.Unfold.Make +import GHC.Core.Make ( FloatBind(..), mkWildValBinder ) +import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) +import GHC.Core.DataCon +import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) +import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import GHC.Core.Predicate( isCoVarType ) +import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) + +import GHC.Types.Literal +import GHC.Types.Id +import GHC.Types.Id.Info ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) +import GHC.Types.Var ( isNonCoVarId ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Demand( etaConvertDmdSig, topSubDmd ) +import GHC.Types.Tickish +import GHC.Types.Basic + +import GHC.Builtin.Types +import GHC.Builtin.Names + +import GHC.Unit.Module ( Module ) +import GHC.Utils.Encoding +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Data.Maybe ( orElse ) +import GHC.Data.Graph.UnVar +import Data.List (mapAccumL) +import qualified Data.ByteString as BS + +{- +************************************************************************ +* * + The Simple Optimiser +* * +************************************************************************ + +Note [The simple optimiser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simple optimiser is a lightweight, pure (non-monadic) function +that rapidly does a lot of simple optimisations, including + + - inlining things that occur just once, + or whose RHS turns out to be trivial + - beta reduction + - case of known constructor + - dead code elimination + +It does NOT do any call-site inlining; it only inlines a function if +it can do so unconditionally, dropping the binding. It thereby +guarantees to leave no un-reduced beta-redexes. + +It is careful to follow the guidance of "Secrets of the GHC inliner", +and in particular the pre-inline-unconditionally and +post-inline-unconditionally story, to do effective beta reduction on +functions called precisely once, without repeatedly optimising the same +expression. In fact, the simple optimiser is a good example of this +little dance in action; the full Simplifier is a lot more complicated. + +Note [The InScopeSet for simpleOptExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Care must be taken to remove unfoldings from `Var`s collected by exprFreeVars +before using them to construct an in-scope set hence `zapIdUnfolding` in `init_subst`. +Consider calling `simpleOptExpr` on an expression like + +``` + case x of (a,b) -> (x,a) +``` + +* One of those two occurrences of x has an unfolding (the one in (x,a), with +unfolding x = (a,b)) and the other does not. (Inside a case GHC adds +unfolding-info to the scrutinee's Id.) +* But exprFreeVars just builds a set, so it's a bit random which occurrence is collected. +* Then simpleOptExpr replaces each occurrence of x with the one in the in-scope set. +* Bad bad bad: then the x in case x of ... may be replaced with a version that has an unfolding. + +See ticket #25790 +-} + +-- | Simple optimiser options +data SimpleOpts = SimpleOpts + { so_uf_opts :: !UnfoldingOpts -- ^ Unfolding options + , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options + , so_eta_red :: !Bool -- ^ Eta reduction on? + , so_inline :: !Bool -- ^ False <=> do no inlining whatsoever, + -- even for trivial or used-once things + } + +-- | Default options for the Simple optimiser. +defaultSimpleOpts :: SimpleOpts +defaultSimpleOpts = SimpleOpts + { so_uf_opts = defaultUnfoldingOpts + , so_co_opts = OptCoercionOpts { optCoercionEnabled = False } + , so_eta_red = False + , so_inline = True + } + +simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr +-- See Note [The simple optimiser] +-- Do simple optimisation on an expression +-- The optimisation is very straightforward: just +-- inline non-recursive bindings that are used only once, +-- or where the RHS is trivial +-- +-- We also inline bindings that bind a Eq# box: see +-- See Note [Getting the map/coerce RULE to work]. +-- +-- Also we convert functions to join points where possible (as +-- the occurrence analyser does most of the work anyway). +-- +-- The result is NOT guaranteed occurrence-analysed, because +-- in (let x = y in ....) we substitute for x; so y's occ-info +-- may change radically +-- +-- Note that simpleOptExpr is a pure function that we want to be able to call +-- from lots of places, including ones that don't have DynFlags (e.g to optimise +-- unfoldings of statically defined Ids via mkCompulsoryUnfolding). It used to +-- fetch its options directly from the DynFlags, however, so some callers had to +-- resort to using unsafeGlobalDynFlags (a global mutable variable containing +-- the DynFlags). It has been modified to take its own SimpleOpts that may be +-- created from DynFlags, but not necessarily. + +simpleOptExpr opts expr + = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) + simpleOptExprWith opts init_subst expr + where + init_subst = mkEmptySubst (mkInScopeSet (mapVarSet zapIdUnfolding (exprFreeVars expr))) + -- zapIdUnfolding: see Note [The InScopeSet for simpleOptExpr] + + -- It's a bit painful to call exprFreeVars, because it makes + -- three passes instead of two (occ-anal, and go) + +simpleOptExprNoInline :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr +-- A variant of simpleOptExpr, but without +-- occurrence analysis or inlining of any kind. +-- Result: we don't inline evidence bindings, which is useful for the specialiser +simpleOptExprNoInline opts expr + = simple_opt_expr init_env expr + where + init_opts = opts { so_inline = False } + init_env = (emptyEnv init_opts) { soe_subst = init_subst } + init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) + +simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr +-- See Note [The simple optimiser] +simpleOptExprWith opts subst expr + = simple_opt_expr init_env (occurAnalyseExpr expr) + where + init_env = (emptyEnv opts) { soe_subst = subst } + +---------------------- +simpleOptPgm :: SimpleOpts + -> Module + -> CoreProgram + -> [CoreRule] + -> (CoreProgram, [CoreRule], CoreProgram) +-- See Note [The simple optimiser] +simpleOptPgm opts this_mod binds rules = + (reverse binds', rules', occ_anald_binds) + where + occ_anald_binds = occurAnalysePgm this_mod + (\_ -> True) {- All unfoldings active -} + (\_ -> False) {- No rules active -} + rules binds + + (final_env, binds') = foldl' do_one (emptyEnv opts, []) occ_anald_binds + final_subst = soe_subst final_env + + rules' = substRulesForImportedIds final_subst rules + -- We never unconditionally inline into rules, + -- hence paying just a substitution + + do_one (env, binds') bind + = case simple_opt_bind env bind TopLevel of + (env', Nothing) -> (env', binds') + (env', Just bind') -> (env', bind':binds') + +-- In these functions the substitution maps InVar -> OutExpr + +---------------------- +type SimpleClo = (SimpleOptEnv, InExpr) + +data SimpleOptEnv + = SOE { soe_opts :: {-# UNPACK #-} !SimpleOpts + -- ^ Simplifier options + + , soe_inl :: IdEnv SimpleClo + -- ^ Deals with preInlineUnconditionally; things + -- that occur exactly once and are inlined + -- without having first been simplified + + , soe_subst :: Subst + -- ^ Deals with cloning; includes the InScopeSet + + , soe_rec_ids :: !UnVarSet + -- ^ Fast OutVarSet tracking which recursive RHSs we are analysing. + -- See Note [Eta reduction in recursive RHSs] + } + +instance Outputable SimpleOptEnv where + ppr (SOE { soe_inl = inl, soe_subst = subst }) + = text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl + , text "soe_subst =" <+> ppr subst ] + <+> text "}" + +emptyEnv :: SimpleOpts -> SimpleOptEnv +emptyEnv opts = SOE { soe_inl = emptyVarEnv + , soe_subst = emptySubst + , soe_rec_ids = emptyUnVarSet + , soe_opts = opts } + +soeZapSubst :: SimpleOptEnv -> SimpleOptEnv +soeZapSubst env@(SOE { soe_subst = subst }) + = env { soe_inl = emptyVarEnv, soe_subst = zapSubst subst } + +soeInScope :: SimpleOptEnv -> InScopeSet +soeInScope (SOE { soe_subst = subst }) = substInScopeSet subst + +soeSetInScope :: InScopeSet -> SimpleOptEnv -> SimpleOptEnv +soeSetInScope in_scope env2@(SOE { soe_subst = subst2 }) + = env2 { soe_subst = setInScope subst2 in_scope } + +enterRecGroupRHSs :: SimpleOptEnv -> [OutBndr] -> (SimpleOptEnv -> (SimpleOptEnv, r)) + -> (SimpleOptEnv, r) +enterRecGroupRHSs env bndrs k + = (env'{soe_rec_ids = soe_rec_ids env}, r) + where + (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)} + +--------------- +simple_opt_clo :: HasDebugCallStack + => InScopeSet + -> SimpleClo + -> OutExpr +simple_opt_clo in_scope (e_env, e) + = simple_opt_expr (soeSetInScope in_scope e_env) e + +simple_opt_expr :: HasDebugCallStack => SimpleOptEnv -> InExpr -> OutExpr +simple_opt_expr env expr + = go expr + where + rec_ids = soe_rec_ids env + subst = soe_subst env + in_scope = substInScopeSet subst + in_scope_env = ISE in_scope alwaysActiveUnfoldingFun + + --------------- + go (Var v) + | Just clo <- lookupVarEnv (soe_inl env) v + = simple_opt_clo in_scope clo + | otherwise + = lookupIdSubst (soe_subst env) v + + go (App e1 e2) = simple_app env e1 [(env,e2)] + go (Type ty) = Type (substTyUnchecked subst ty) + go (Coercion co) = Coercion (go_co co) + go (Lit lit) = Lit lit + go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) + go (Cast e co) = mk_cast (go e) (go_co co) + go (Let bind body) = case simple_opt_bind env bind NotTopLevel of + (env', Nothing) -> simple_opt_expr env' body + (env', Just bind) -> Let bind (simple_opt_expr env' body) + + go lam@(Lam {}) = go_lam env [] lam + go (Case e b ty as) + | isDeadBinder b + , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' + -- We don't need to be concerned about floats when looking for coerce. + , Just (Alt altcon bs rhs) <- findAlt (DataAlt con) as + = case altcon of + DEFAULT -> go rhs + _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs + where + (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $ + zipEqual bs es + + -- See Note [Getting the map/coerce RULE to work] + | isDeadBinder b + , [Alt DEFAULT _ rhs] <- as + , isCoVarType (varType b) + , (Var fun, _args) <- collectArgs e + , fun `hasKey` coercibleSCSelIdKey + -- without this last check, we get #11230 + = go rhs + + | otherwise + = Case e' b' (substTyUnchecked subst ty) + (map (go_alt env') as) + where + e' = go e + (env', b') = subst_opt_bndr env b + + ---------------------- + go_co co = optCoercion (so_co_opts (soe_opts env)) subst co + + ---------------------- + go_alt env (Alt con bndrs rhs) + = Alt con bndrs' (simple_opt_expr env' rhs) + where + (env', bndrs') = subst_opt_bndrs env bndrs + + ---------------------- + -- go_lam tries eta reduction + -- It is quite important that it does so. I tried removing this code and + -- got a lot of regressions, e.g., +11% ghc/alloc in T18223 and many + -- run/alloc increases. Presumably RULEs are affected. + go_lam env bs' (Lam b e) + = go_lam env' (b':bs') e + where + (env', b') = subst_opt_bndr env b + go_lam env bs' e + | so_eta_red (soe_opts env) + , Just etad_e <- tryEtaReduce rec_ids bs e' topSubDmd = etad_e + | otherwise = mkLams bs e' + where + bs = reverse bs' + e' = simple_opt_expr env e + +mk_cast :: CoreExpr -> CoercionR -> CoreExpr +-- Like GHC.Core.Utils.mkCast, but does a full reflexivity check. +-- mkCast doesn't do that because the Simplifier does (in simplCast) +-- But in SimpleOpt it's nice to kill those nested casts (#18112) +mk_cast (Cast e co1) co2 = mk_cast e (co1 `mkTransCo` co2) +mk_cast (Tick t e) co = Tick t (mk_cast e co) +mk_cast e co | isReflexiveCo co = e + | otherwise = Cast e co + +---------------------- +-- simple_app collects arguments for beta reduction +simple_app :: HasDebugCallStack => SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr + +simple_app env (Var v) as + | Just (env', e) <- lookupVarEnv (soe_inl env) v + = simple_app (soeSetInScope (soeInScope env) env') e as + + | let unf = idUnfolding v + , isCompulsoryUnfolding unf + , isAlwaysActive (idInlineActivation v) + -- See Note [Unfold compulsory unfoldings in RULE LHSs] + , Just rhs <- maybeUnfoldingTemplate unf + -- Always succeeds if isCompulsoryUnfolding does + = simple_app (soeZapSubst env) rhs as + + | otherwise + , let out_fn = lookupIdSubst (soe_subst env) v + = finish_app env out_fn as + +simple_app env (App e1 e2) as + = simple_app env e1 ((env, e2) : as) + +simple_app env e@(Lam {}) as@(_:_) + = do_beta env (zapLambdaBndrs e n_args) as + -- Be careful to zap the lambda binders if necessary + -- c.f. the Lam case of simplExprF1 in GHC.Core.Opt.Simplify + -- Lacking this zap caused #19347, when we had a redex + -- (\ a b. K a b) e1 e2 + -- where (as it happens) the eta-expanded K is produced by + -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head + where + n_args = length as + + do_beta env (Lam b body) (a:as) + | -- simpl binder before looking at its type + -- See Note [Dark corner with representation polymorphism] + needsCaseBinding (idType b') (snd a) + -- This arg must not be inlined (side-effects) and cannot be let-bound, + -- due to the let-can-float invariant. So simply case-bind it here. + , let a' = simple_opt_clo (soeInScope env) a + = mkDefaultCase a' b' $ do_beta env' body as + + | (env'', mb_pr) <- simple_bind_pair env' b (Just b') a NotTopLevel + = wrapLet mb_pr $ do_beta env'' body as + + where (env', b') = subst_opt_bndr env b + + do_beta env body as + = simple_app env body as + +simple_app env (Tick t e) as + -- Okay to do "(Tick t e) x ==> Tick t (e x)"? + | t `tickishScopesLike` SoftScope + = mkTick t $ simple_app env e as + +-- (let x = e in b) a1 .. an => let x = e in (b a1 .. an) +-- The let might appear there as a result of inlining +-- e.g. let f = let x = e in b +-- in f a1 a2 +-- (#13208) +-- However, do /not/ do this transformation for join points +-- See Note [simple_app and join points] +simple_app env (Let bind body) args + = case simple_opt_bind env bind NotTopLevel of + (env', Nothing) -> simple_app env' body args + (env', Just bind') + | isJoinBind bind' -> finish_app env expr' args + | otherwise -> Let bind' (simple_app env' body args) + where + expr' = Let bind' (simple_opt_expr env' body) + +simple_app env e as + = finish_app env (simple_opt_expr env e) as + +finish_app :: HasDebugCallStack + => SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr +-- See Note [Eliminate casts in function position] +finish_app env (Cast (Lam x e) co) as@(_:_) + | not (isTyVar x) && not (isCoVar x) + , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True + , Just (x',e') <- pushCoercionIntoLambda (soeInScope env) x e co + = simple_app (soeZapSubst env) (Lam x' e') as + +finish_app env fun args + = foldl mk_app fun args + where + in_scope = soeInScope env + mk_app fun arg = App fun (simple_opt_clo in_scope arg) + +---------------------- +simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag + -> (SimpleOptEnv, Maybe OutBind) +simple_opt_bind env (NonRec b r) top_level + = (env', case mb_pr of + Nothing -> Nothing + Just (b,r) -> Just (NonRec b r)) + where + (b', r') = joinPointBinding_maybe b r `orElse` (b, r) + (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level + +simple_opt_bind env (Rec prs) top_level + = (env2, res_bind) + where + res_bind = Just (Rec (reverse rev_prs')) + prs' = joinPointBindings_maybe prs `orElse` prs + (env1, bndrs') = subst_opt_bndrs env (map fst prs') + (env2, rev_prs') = enterRecGroupRHSs env1 bndrs' $ \env -> + foldl' do_pr (env, []) (prs' `zip` bndrs') + do_pr (env, prs) ((b,r), b') + = (env', case mb_pr of + Just pr -> pr : prs + Nothing -> prs) + where + (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) top_level + +---------------------- +simple_bind_pair :: SimpleOptEnv + -> InVar -> Maybe OutVar + -> SimpleClo + -> TopLevelFlag + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) + -- (simple_bind_pair subst in_var out_rhs) + -- either extends subst with (in_var -> out_rhs) + -- or returns Nothing +simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst, soe_opts = opts }) + in_bndr mb_out_bndr clo@(rhs_env, in_rhs) + top_level + | Type ty <- in_rhs -- let a::* = TYPE ty in + , let out_ty = substTyUnchecked (soe_subst rhs_env) ty + = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr in_rhs) $ + (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) + + | Coercion co <- in_rhs + , let out_co = optCoercion (so_co_opts (soe_opts env)) (soe_subst rhs_env) co + = assert (isCoVar in_bndr) + (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) + + | assertPpr (isNonCoVarId in_bndr) (ppr in_bndr) + -- The previous two guards got rid of tyvars and coercions + -- See Note [Core type and coercion invariant] in GHC.Core + pre_inline_unconditionally + = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing) + + | otherwise + = simple_out_bind_pair env in_bndr mb_out_bndr out_rhs + occ active stable_unf top_level + where + stable_unf = isStableUnfolding (idUnfolding in_bndr) + active = isAlwaysActive (idInlineActivation in_bndr) + occ = idOccInfo in_bndr + in_scope = substInScopeSet subst + + out_rhs | JoinPoint join_arity <- idJoinPointHood in_bndr + = simple_join_rhs join_arity + | otherwise + = simple_opt_clo in_scope clo + + simple_join_rhs join_arity -- See Note [Preserve join-binding arity] + = mkLams join_bndrs' (simple_opt_expr env_body join_body) + where + env0 = soeSetInScope in_scope rhs_env + (join_bndrs, join_body) = collectNBinders join_arity in_rhs + (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs + + pre_inline_unconditionally :: Bool + pre_inline_unconditionally + | not (so_inline opts) = False -- Not if so_inline is False + | isExportedId in_bndr = False + | stable_unf = False + | not active = False -- Note [Inline prag in simplOpt] + | not (safe_to_inline occ) = False + | otherwise = True + + -- Unconditionally safe to inline +safe_to_inline :: OccInfo -> Bool +safe_to_inline IAmALoopBreaker{} = False +safe_to_inline IAmDead = True +safe_to_inline OneOcc{ occ_in_lam = NotInsideLam + , occ_n_br = 1 } = True +safe_to_inline OneOcc{} = False +safe_to_inline ManyOccs{} = False + +do_beta_by_substitution :: Id -> CoreExpr -> Bool +-- True <=> you can inline (bndr = rhs) by substitution +-- See Note [Exploit occ-info in exprIsConApp_maybe] +do_beta_by_substitution bndr rhs + = exprIsTrivial rhs -- Can duplicate + || safe_to_inline (idOccInfo bndr) -- Occurs at most once + +do_case_elim :: CoreExpr -> Id -> [Id] -> Bool +do_case_elim scrut case_bndr alt_bndrs + = exprIsHNF scrut + && safe_to_inline (idOccInfo case_bndr) + && all isDeadBinder alt_bndrs + +------------------- +simple_out_bind :: TopLevelFlag + -> SimpleOptEnv + -> (InVar, OutExpr) + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) +simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) + | Type out_ty <- out_rhs + = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr out_ty $$ ppr out_rhs) + (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) + + | Coercion out_co <- out_rhs + = assert (isCoVar in_bndr) + (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) + + | otherwise + = simple_out_bind_pair env in_bndr Nothing out_rhs + (idOccInfo in_bndr) True False top_level + +------------------- +simple_out_bind_pair :: SimpleOptEnv + -> InId -> Maybe OutId -> OutExpr + -> OccInfo -> Bool -> Bool -> TopLevelFlag + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) +simple_out_bind_pair env@(SOE { soe_subst = subst, soe_opts = opts }) + in_bndr mb_out_bndr out_rhs + occ_info active stable_unf top_level + | assertPpr (isNonCoVarId in_bndr) (ppr in_bndr) + -- Type and coercion bindings are caught earlier + -- See Note [Core type and coercion invariant] + post_inline_unconditionally + = ( env' { soe_subst = extendIdSubst subst in_bndr out_rhs } + , Nothing) + + | otherwise + = ( env', Just (out_bndr, out_rhs) ) + where + (env', bndr1) = case mb_out_bndr of + Just out_bndr -> (env, out_bndr) + Nothing -> subst_opt_bndr env in_bndr + out_bndr = add_info env' in_bndr top_level out_rhs bndr1 + + post_inline_unconditionally :: Bool + post_inline_unconditionally + | not (so_inline opts) = False -- Not if so_inline is False + | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs] + | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally] + | not active = False -- in GHC.Core.Opt.Simplify.Utils + | is_loop_breaker = False -- If it's a loop-breaker of any kind, don't inline + -- because it might be referred to "earlier" + | exprIsTrivial out_rhs = True + | coercible_hack = True + | otherwise = False + + is_loop_breaker = isWeakLoopBreaker occ_info + + -- See Note [Getting the map/coerce RULE to work] + coercible_hack | (Var fun, args) <- collectArgs out_rhs + , Just dc <- isDataConWorkId_maybe fun + , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey + = all exprIsTrivial args + | otherwise + = False + +{- Note [Exported Ids and trivial RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously do not want to unconditionally inline an Id that is exported. +In GHC.Core.Opt.Simplify.Utils, Note [Top level and postInlineUnconditionally], we +explain why we don't inline /any/ top-level things unconditionally, even +trivial ones. But we do here! Why? In the simple optimiser + + * We do no rule rewrites + * We do no call-site inlining + +Those differences obviate the reasons for not inlining a trivial rhs, +and increase the benefit for doing so. So we unconditionally inline trivial +rhss here. + +Note [Eliminate casts in function position] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following program: + + type R :: Type -> RuntimeRep + type family R a where { R Float = FloatRep; R Double = DoubleRep } + type F :: forall (a :: Type) -> TYPE (R a) + type family F a where { F Float = Float# ; F Double = Double# } + + type N :: forall (a :: Type) -> TYPE (R a) + newtype N a = MkN (F a) + +As MkN is a newtype, its unfolding is a lambda which wraps its argument +in a cast: + + MkN :: forall (a :: Type). F a -> N a + MkN = /\a \(x::F a). x |> co_ax + -- recall that F a :: TYPE (R a) + +This is a representation-polymorphic lambda, in which the binder has an unknown +representation (R a). We can't compile such a lambda on its own, but we can +compile instantiations, such as `MkN @Float` or `MkN @Double`. + +Our strategy to avoid running afoul of the representation-polymorphism +invariants of Note [Representation polymorphism invariants] in GHC.Core is thus: + + 1. Give the newtype a compulsory unfolding (it has no binding, as we can't + define lambdas with representation-polymorphic value binders in source Haskell). + 2. Rely on the optimiser to beta-reduce away any representation-polymorphic + value binders. + +For example, consider the application + + MkN @Float 34.0# + +After inlining MkN we'll get + + ((/\a \(x:F a). x |> co_ax) @Float) |> co 34# + +where co :: (F Float -> N Float) ~ (Float# ~ N Float) + +But to actually beta-reduce that lambda, we need to push the 'co' +inside the `\x` with pushCoecionIntoLambda. Hence the extra +equation for Cast-of-Lam in finish_app. + +This is regrettably delicate. + +Note [Preserve join-binding arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Be careful /not/ to eta-reduce the RHS of a join point, lest we lose +the join-point arity invariant. #15108 was caused by simplifying +the RHS with simple_opt_expr, which does eta-reduction. Solution: +simplify the RHS of a join point by simplifying under the lambdas +(which of course should be there). + +Note [simple_app and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general for let-bindings we can do this: + (let { x = e } in b) a ==> let { x = e } in b a + +But not for join points! For two reasons: + +- We would need to push the continuation into the RHS: + (join { j = e } in b) a ==> let { j' = e a } in b[j'/j] a + NB ----^^ + and also change the type of j, hence j'. + That's a bit sophisticated for the very simple optimiser. + +- We might end up with something like + join { j' = e a } in + (case blah of ) + ( True -> j' void# ) a + ( False -> blah ) + and now the call to j' doesn't look like a tail call, and + Lint may reject. I say "may" because this is /explicitly/ + allowed in the "Compiling without Continuations" paper + (Section 3, "Managing \Delta"). But GHC currently does not + allow this slightly-more-flexible form. See GHC.Core + Note [Join points are less general than the paper]. + +The simple thing to do is to disable this transformation +for join points in the simple optimiser + +Note [The Let-Unfoldings Invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A program has the Let-Unfoldings property iff: + +- For every let-bound variable f, whether top-level or nested, whether + recursive or not: + - Both the binding Id of f, and every occurrence Id of f, has an idUnfolding. + - For non-INLINE things, that unfolding will be f's right hand sids + - For INLINE things (which have a "stable" unfolding) that unfolding is + semantically equivalent to f's RHS, but derived from the original RHS of f + rather that its current RHS. + +Informally, we can say that in a program that has the Let-Unfoldings property, +all let-bound Id's have an explicit unfolding attached to them. + +Currently, the simplifier guarantees the Let-Unfoldings invariant for anything +it outputs. + +-} + +---------------------- +subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar]) +subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs + +subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar) +subst_opt_bndr env bndr + | isTyVar bndr = (env { soe_subst = subst_tv }, tv') + | isCoVar bndr = (env { soe_subst = subst_cv }, cv') + | otherwise = subst_opt_id_bndr env bndr + where + subst = soe_subst env + (subst_tv, tv') = substTyVarBndr subst bndr + (subst_cv, cv') = substCoVarBndr subst bndr + +subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) +-- Nuke all fragile IdInfo, unfolding, and RULES; it gets added back later by +-- add_info. +-- +-- Rather like SimplEnv.substIdBndr +-- +-- It's important to zap fragile OccInfo (which GHC.Core.Subst.substIdBndr +-- carefully does not do) because simplOptExpr invalidates it + +subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id + = (env { soe_subst = new_subst, soe_inl = new_inl }, new_id) + where + Subst in_scope id_subst tv_subst cv_subst = subst + + id1 = uniqAway in_scope old_id + id2 = updateIdTypeAndMult (substTyUnchecked subst) id1 + new_id = zapFragileIdInfo id2 + -- Zaps rules, unfolding, and fragile OccInfo + -- The unfolding and rules will get added back later, by add_info + + new_in_scope = in_scope `extendInScopeSet` new_id + + no_change = new_id == old_id + + -- Extend the substitution if the unique has changed, + -- See the notes with substTyVarBndr for the delSubstEnv + new_id_subst + | no_change = delVarEnv id_subst old_id + | otherwise = extendVarEnv id_subst old_id (Var new_id) + + new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst + new_inl = delVarEnv inl old_id + +---------------------- +add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar +add_info env old_bndr top_level new_rhs new_bndr + | isTyVar old_bndr = new_bndr + | otherwise = lazySetIdInfo new_bndr new_info + where + subst = soe_subst env + uf_opts = so_uf_opts (soe_opts env) + old_info = idInfo old_bndr + + -- Add back in the rules and unfolding which were + -- removed by zapFragileIdInfo in subst_opt_id_bndr. + -- + -- See Note [The Let-Unfoldings Invariant] + new_info = idInfo new_bndr `setRuleInfo` new_rules + `setUnfoldingInfo` new_unfolding + + old_rules = ruleInfo old_info + new_rules = substRuleInfo subst new_bndr old_rules + + old_unfolding = realUnfoldingInfo old_info + new_unfolding | isStableUnfolding old_unfolding + = substUnfolding subst old_unfolding + | otherwise + = unfolding_from_rhs + + unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc + (isTopLevel top_level) + False -- may be bottom or not + False -- Not a join point + new_rhs Nothing + +wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr +wrapLet Nothing body = body +wrapLet (Just (b,r)) body = Let (NonRec b r) body + +{- +Note [Inline prag in simplOpt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there's an INLINE/NOINLINE pragma that restricts the phase in +which the binder can be inlined, we don't inline here; after all, +we don't know what phase we're in. Here's an example + + foo :: Int -> Int -> Int + {-# INLINE foo #-} + foo m n = inner m + where + {-# INLINE [1] inner #-} + inner m = m+n + + bar :: Int -> Int + bar n = foo n 1 + +When inlining 'foo' in 'bar' we want the let-binding for 'inner' +to remain visible until Phase 1 + +Note [Unfold compulsory unfoldings in RULE LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user writes `RULES map coerce = coerce` as a rule, the rule +will only ever match if simpleOptExpr replaces coerce by its unfolding +on the LHS, because that is the core that the rule matching engine +will find. So do that for everything that has a compulsory +unfolding. Also see Note [Desugaring coerce as cast] in GHC.HsToCore. + +However, we don't want to inline 'seq', which happens to also have a +compulsory unfolding, so we only do this unfolding only for things +that are always-active. See Note [User-defined RULES for seq] in GHC.Types.Id.Make. + +Note [Getting the map/coerce RULE to work] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to allow the "map/coerce" RULE to fire: + + {-# RULES "map/coerce" map coerce = coerce #-} + +The naive core produced for this is + + forall a b (dict :: Coercible * a b). + map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict' + + where dict' :: Coercible [a] [b] + dict' = ... + +This matches literal uses of `map coerce` in code, but that's not what we +want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) +too. Achieving all this is surprisingly tricky: + +(MC1) We must compulsorily unfold MkAge to a cast. + See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make + +(MC2) We must compulsorily unfold coerce on the rule LHS, yielding + forall a b (dict :: Coercible * a b). + map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + + Getting better. But this isn't exactly what gets produced. This is because + Coercible essentially has ~R# as a superclass, and superclasses get eagerly + extracted during solving. So we get this: + + forall a b (dict :: Coercible * a b). + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + + Unfortunately, this still abstracts over a Coercible dictionary. We really + want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, + which transforms the above to + + forall a b (co :: a ~R# b). + let dict = MkCoercible @* @a @b co in + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... + + See Note [Desugaring coerce as cast] in GHC.HsToCore + +(MC3) Now, we need simpleOptExpr to fix this up. It does so by taking three + separate actions: + 1. Inline certain non-recursive bindings. The choice whether to inline + is made in simple_bind_pair. Note the rather specific check for + MkCoercible in there. + + 2. Stripping case expressions like the Coercible_SCSel one. + See the `Case` case of simple_opt_expr's `go` function. + + 3. Look for case expressions that unpack something that was + just packed and inline them. This is also done in simple_opt_expr's + `go` function. + +(MC4) The map/coerce rule is the only compelling reason for having a RULE that + quantifies over a coercion variable, something that is otherwise Very Deeply + Suspicious. See Note [Casts in the template] in GHC.Core.Rules. Ugh! + +This is all a fair amount of special-purpose hackery, but it's for +a good cause. And it won't hurt other RULES and such that it comes across. + + +************************************************************************ +* * + Join points +* * +************************************************************************ +-} + +{- Note [Strictness and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + let f = \x. if x>200 then e1 else e1 + +and we know that f is strict in x. Then if we subsequently +discover that f is an arity-2 join point, we'll eta-expand it to + + let f = \x y. if x>200 then e1 else e1 + +and now it's only strict if applied to two arguments. So we should +adjust the strictness info. + +A more common case is when + + f = \x. error ".." + +and again its arity increases (#15517) +-} + + +-- | Returns Just (bndr,rhs) if the binding is a join point: +-- If it's a JoinId, just return it +-- If it's not yet a JoinId but is always tail-called, +-- make it into a JoinId and return it. +-- In the latter case, eta-expand the RHS if necessary, to make the +-- lambdas explicit, as is required for join points +-- +-- Precondition: the InBndr has been occurrence-analysed, +-- so its OccInfo is valid +joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr) +joinPointBinding_maybe bndr rhs + | not (isId bndr) + = Nothing + + | isJoinId bndr + = Just (bndr, rhs) + + | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) + , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs + , let str_sig = idDmdSig bndr + str_arity = count isId bndrs -- Strictness demands are for Ids only + join_bndr = bndr `asJoinId` join_arity + `setIdDmdSig` etaConvertDmdSig str_arity str_sig + = Just (join_bndr, mkLams bndrs body) + + | otherwise + = Nothing + +joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] +joinPointBindings_maybe bndrs + = mapM (uncurry joinPointBinding_maybe) bndrs + + +{- ********************************************************************* +* * + exprIsConApp_maybe +* * +************************************************************************ + +Note [exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsConApp_maybe is a very important function. There are two principal +uses: + * case e of { .... } + * cls_op e, where cls_op is a class operation + +In both cases you want to know if e is of form (C e1..en) where C is +a data constructor. + +However e might not *look* as if + + +Note [exprIsConApp_maybe on literal strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #9400 and #13317. + +Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core +they are represented as unpackCString# "abc"# by GHC.Core.Make.mkStringExprFS, or +unpackCStringUtf8# when the literal contains multi-byte UTF8 characters. + +For optimizations we want to be able to treat it as a list, so they can be +decomposed when used in a case-statement. exprIsConApp_maybe detects those +calls to unpackCString# and returns: + +Just (':', [Char], ['a', unpackCString# "bc"]). + +We need to be careful about UTF8 strings here. ""# contains an encoded ByteString, so +we call utf8UnconsByteString to correctly deal with the encoding and splitting. + +We must also be careful about + lvl = "foo"# + ...(unpackCString# lvl)... +to ensure that we see through the let-binding for 'lvl'. Hence the +(exprIsLiteral_maybe .. arg) in the guard before the call to +dealWithStringLiteral. + +The tests for this function are in T9400. + +Note [Push coercions in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #13025 I found a case where we had + op (df @t1 @t2) -- op is a ClassOp +where + df = (/\a b. K e1 e2) |> g + +To get this to come out we need to simplify on the fly + ((/\a b. K e1 e2) |> g) @t1 @t2 + +Hence the use of pushCoArgs. + +Note [exprIsConApp_maybe on data constructors with wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: +- some data constructors have wrappers +- these wrappers inline late (see MkId Note [Activation for data constructor wrappers]) +- but we still want case-of-known-constructor to fire early. + +Example: + data T = MkT !Int + $WMkT n = case n of n' -> MkT n' -- Wrapper for MkT + foo x = case $WMkT e of MkT y -> blah + +Here we want the case-of-known-constructor transformation to fire, giving + foo x = case e of x' -> let y = x' in blah + +Here's how exprIsConApp_maybe achieves this: + +0. Start with scrutinee = $WMkT e + +1. Inline $WMkT on-the-fly. That's why data-constructor wrappers are marked + as expandable. (See GHC.Core.Utils.isExpandableApp.) Now we have + scrutinee = (\n. case n of n' -> MkT n') e + +2. Beta-reduce the application, generating a floated 'let'. + See Note [beta-reduction in exprIsConApp_maybe] below. Now we have + scrutinee = case n of n' -> MkT n' + with floats {Let n = e} + +3. Float the "case x of x' ->" binding out. Now we have + scrutinee = MkT n' + with floats {Let n = e; case n of n' ->} + +And now we have a known-constructor MkT that we can return. + +Notice that both (2) and (3) require exprIsConApp_maybe to gather and return +a bunch of floats, both let and case bindings. + +Note that this strategy introduces some subtle scenarios where a data-con +wrapper can be replaced by a data-con worker earlier than we’d like, see +Note [exprIsConApp_maybe for data-con wrappers: tricky corner]. + +Note [beta-reduction in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is +typically a function. For instance, take the wrapper for MkT in Note +[exprIsConApp_maybe on data constructors with wrappers]: + + $WMkT n = case n of { n' -> T n' } + +If `exprIsConApp_maybe` is trying to analyse `$MkT arg`, upon unfolding of $MkT, +it will see + + (\n -> case n of { n' -> T n' }) arg + +In order to go progress, `exprIsConApp_maybe` must perform a beta-reduction. + +We don't want to blindly substitute `arg` in the body of the function, because +it duplicates work. We can (and, in fact, used to) substitute `arg` in the body, +but only when `arg` is a variable (or something equally work-free). + +But, because of Note [exprIsConApp_maybe on data constructors with wrappers], +'exprIsConApp_maybe' now returns floats. So, instead, we can beta-reduce +_always_: + + (\x -> body) arg + +Is transformed into + + let x = arg in body + +Which, effectively, means emitting a float `let x = arg` and recursively +analysing the body. + +For newtypes, this strategy requires that their wrappers have compulsory unfoldings. +Suppose we have + newtype T a b where + MkT :: a -> T b a -- Note args swapped + +This defines a worker function MkT, a wrapper function $WMkT, and an axT: + $WMkT :: forall a b. a -> T b a + $WMkT = /\b a. \(x:a). MkT a b x -- A real binding + + MkT :: forall a b. a -> T a b + MkT = /\a b. \(x:a). x |> (ax a b) -- A compulsory unfolding + + axiom axT :: a ~R# T a b + +Now we are optimising + case $WMkT (I# 3) |> sym axT of I# y -> ... +we clearly want to simplify this. If $WMkT did not have a compulsory +unfolding, we would end up with + let a = I# 3 in case a of I# y -> ... +because in general, we do this on-the-fly beta-reduction + (\x. e) blah --> let x = blah in e +and then float the let. (Substitution would risk duplicating 'blah'.) + +But if the case-of-known-constructor doesn't actually fire (i.e. +exprIsConApp_maybe does not return Just) then nothing happens, and nothing +will happen the next time either. + +See test T16254, which checks the behavior of newtypes. + +Note [Exploit occ-info in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (#23159) we have a simple data constructor wrapper like this (this one +might have come from a data family instance): + $WK x y = K x y |> co +Now suppose the simplifier sees + case ($WK e1 e2) |> co2 of + K p q -> case q of ... + +`exprIsConApp_maybe` expands the wrapper on the fly +(see Note [beta-reduction in exprIsConApp_maybe]). It effectively expands +that ($WK e1 e2) to + let x = e1; y = e2 in K x y |> co + +So the Simplifier might end up producing this: + let x = e1; y = e2 + in case x of ... + +But suppose `q` was used just once in the body of the `K p q` alternative; we +don't want to wait a whole Simplifier iteration to inline that `x`. (e1 might +be another constructor for example.) This would happen if `exprIsConApp_maybe` +we created a let for every (non-trivial) argument. So let's not do that when +the binder is used just once! + +Instead, take advantage of the occurrence-info on `x` and `y` in the unfolding +of `$WK`. Since in `$WK` both `x` and `y` occur once, we want to effectively +expand `($WK e1 e2)` to `(K e1 e2 |> co)`. Hence in +`do_beta_by_substitution` we say "yes" if + + (a) the RHS is trivial (so we can duplicate it); + see call to `exprIsTrivial` +or + (b) the binder occurs at most once (so there is no worry about duplication); + see call to `safe_to_inline`. + +To see this in action, look at testsuite/tests/perf/compiler/T15703. The +initial Simlifier run takes 5 iterations without (b), but only 3 when we add +(b). + +Note [Don't float join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsConApp_maybe should succeed on + let v = e in Just v +returning [x=e] as one of the [FloatBind]. But it must +NOT succeed on + join j x = rhs in Just v +because join-points can't be gaily floated. Consider + case (join j x = rhs in Just) of + K p q -> blah +We absolutely must not "simplify" this to + join j x = rhs + in blah +because j's return type is (Maybe t), quite different to blah's. + +You might think this could never happen, because j can't be +tail-called in the body if the body returns a constructor. But +in !3113 we had a /dead/ join point (which is not illegal), +and its return type was wonky. + +The simple thing is not to float a join point. The next iteration +of the simplifier will sort everything out. And it there is +a join point, the chances are that the body is not a constructor +application, so failing faster is good. + +Note [exprIsConApp_maybe for data-con wrappers: tricky corner] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking + + * exprIsConApp_maybe honours the inline phase; that is, it does not look + inside the unfolding for an Id unless its unfolding is active in this phase. + That phase-sensitivity is expressed in the InScopeEnv (specifically, the + IdUnfoldingFun component of the InScopeEnv) passed to exprIsConApp_maybe. + + * Data-constructor wrappers are active only in phase 0 (the last phase); + see Note [Activation for data constructor wrappers] in GHC.Types.Id.Make. + +On the face of it that means that exprIsConApp_maybe won't look inside data +constructor wrappers until phase 0. But that seems pretty Bad. So we cheat. +For data con wrappers we unconditionally look inside its unfolding, regardless +of phase, so that we get case-of-known-constructor to fire in every phase. + +Perhaps unsurprisingly, this cheating can backfire. An example: + + data T = C !A B + foo p q = let x = C e1 e2 in seq x $ f x + {-# RULE "wurble" f (C a b) = b #-} + +In Core, the RHS of foo is + + let x = $WC e1 e2 in case x of y { C _ _ -> f x } + +and after doing a binder swap and inlining x, we have: + + case $WC e1 e2 of y { C _ _ -> f y } + +Case-of-known-constructor fires, but now we have to reconstruct a binding for +`y` (which was dead before the binder swap) on the RHS of the case alternative. +Naturally, we’ll use the worker: + + case e1 of a { DEFAULT -> let y = C a e2 in f y } + +and after inlining `y`, we have: + + case e1 of a { DEFAULT -> f (C a e2) } + +Now we might hope the "wurble" rule would fire, but alas, it will not: we have +replaced $WC with C, but the (desugared) rule matches on $WC! We weren’t +supposed to inline $WC yet for precisely that reason (see Note [Activation for +data constructor wrappers]), but our cheating in exprIsConApp_maybe came back to +bite us. + +This is rather unfortunate, especially since this can happen inside stable +unfoldings as well as ordinary code (which really happened, see !3041). But +there is no obvious solution except to delay case-of-known-constructor on +data-con wrappers, and that cure would be worse than the disease. + +This Note exists solely to document the problem. +-} + +data ConCont = CC [CoreExpr] MCoercion + -- Substitution already applied + +-- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument +-- expression is a *saturated* constructor application of the form @let b1 in +-- .. let bp in dc t1..tk x1 .. xn@, where t1..tk are the +-- *universally-quantified* type args of 'dc'. Floats can also be (and most +-- likely are) single-alternative case expressions. Why does +-- 'exprIsConApp_maybe' return floats? We may have to look through lets and +-- cases to detect that we are in the presence of a data constructor wrapper. In +-- this case, we need to return the lets and cases that we traversed. See Note +-- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers +-- are unfolded late, but we really want to trigger case-of-known-constructor as +-- early as possible. See also Note [Activation for data constructor wrappers] +-- in "GHC.Types.Id.Make". +-- +-- We also return the incoming InScopeSet, augmented with +-- the binders from any [FloatBind] that we return +exprIsConApp_maybe :: HasDebugCallStack + => InScopeEnv -> CoreExpr + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) +exprIsConApp_maybe ise@(ISE in_scope id_unf) expr + = go (Left in_scope) [] expr (CC [] MRefl) + where + go :: Either InScopeSet Subst + -- Left in-scope means "empty substitution" + -- Right subst means "apply this substitution to the CoreExpr" + -- NB: in the call (go subst floats expr cont) + -- the substitution applies to 'expr', but /not/ to 'floats' or 'cont' + -> [FloatBind] -> CoreExpr -> ConCont + -- Notice that the floats here are in reverse order + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) + go subst floats (Tick t expr) cont + | not (tickishIsCode t) = go subst floats expr cont + + go subst floats (Cast expr co1) (CC args m_co2) + | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args + -- See Note [Push coercions in exprIsConApp_maybe] + = go subst floats expr (CC args' (m_co1' `mkTransMCo` m_co2)) + + go subst floats (App fun arg) (CC args mco) + | let arg_type = exprType arg + , not (isTypeArg arg) && needsCaseBinding arg_type arg + -- An unlifted argument that’s not ok for speculation must not simply be + -- put into the args, as these are going to be substituted into the case + -- alternatives, and possibly lost on the way. + -- + -- Instead, we need need to + -- make sure they are evaluated right here (using a case float), and + -- the case binder can then be substituted into the case alternaties. + -- + -- Example: + -- Simplifying case Mk# exp of Mk# a → rhs + -- will use exprIsConApp_maybe (Mk# exp) + -- + -- Bad: returning (Mk#, [exp]) with no floats + -- simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec + -- Good: returning (Mk#, [x]) with a float of case exp of x { DEFAULT -> [] } + -- simplifier produces case exp of a { DEFAULT -> exp[x/a] } + , (subst', float, bndr) <- case_bind subst arg arg_type + = go subst' (float:floats) fun (CC (Var bndr : args) mco) + | otherwise + = go subst floats fun (CC (subst_expr subst arg : args) mco) + + go subst floats (Lam bndr body) (CC (arg:args) mco) + | do_beta_by_substitution bndr arg + = go (extend subst bndr arg) floats body (CC args mco) + | otherwise + = let (subst', bndr') = subst_bndr subst bndr + float = FloatLet (NonRec bndr' arg) + in go subst' (float:floats) body (CC args mco) + + go subst floats (Let (NonRec bndr rhs) expr) cont + | not (isJoinId bndr) + -- Crucial guard! See Note [Don't float join points] + = let rhs' = subst_expr subst rhs + (subst', bndr') = subst_bndr subst bndr + float = FloatLet (NonRec bndr' rhs') + in go subst' (float:floats) expr cont + + go subst floats (Case scrut b _ [Alt con vars expr]) cont + | do_case_elim scrut' b vars -- See Note [Case elim in exprIsConApp_maybe] + = go (extend subst b scrut') floats expr cont + | otherwise + = let + (subst', b') = subst_bndr subst b + (subst'', vars') = subst_bndrs subst' vars + float = FloatCase scrut' b' con vars' + in + go subst'' (float:floats) expr cont + where + scrut' = subst_expr subst scrut + + go (Right sub) floats (Var v) cont + = go (Left (substInScopeSet sub)) + floats + (lookupIdSubst sub v) + cont + + go (Left in_scope) floats (Var fun) cont@(CC args mco) + + | Just con <- isDataConWorkId_maybe fun + , count isValArg args == idArity fun + , (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args + -- mkFieldSeqFloats: See (SFC2) in Note [Strict fields in Core] + = succeedWith in_scope' (seq_floats ++ floats) $ + pushCoDataCon con args' mco + + -- Look through data constructor wrappers: they inline late (See Note + -- [Activation for data constructor wrappers]) but we want to do + -- case-of-known-constructor optimisation eagerly (see Note + -- [exprIsConApp_maybe on data constructors with wrappers]). + | Just rhs <- dataConWrapUnfolding_maybe fun + = go (Left in_scope) floats rhs cont + + -- Look through dictionary functions; see Note [Unfolding DFuns] + | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding + , bndrs `equalLength` args -- See Note [DFun arity check] + , let in_scope' = extend_in_scope (exprsFreeVars dfun_args) + subst = mkOpenSubst in_scope' (bndrs `zip` args) + -- We extend the in-scope set here to silence warnings from + -- substExpr when it finds not-in-scope Ids in dfun_args. + -- simplOptExpr initialises the in-scope set with exprFreeVars, + -- but that doesn't account for DFun unfoldings + = succeedWith in_scope floats $ + pushCoDataCon con (map (substExpr subst) dfun_args) mco + + -- Look through unfoldings, but only arity-zero one; + -- if arity > 0 we are effectively inlining a function call, + -- and that is the business of callSiteInline. + -- In practice, without this test, most of the "hits" were + -- CPR'd workers getting inlined back into their wrappers, + | idArity fun == 0 + , Just rhs <- expandUnfolding_maybe unfolding + , let in_scope' = extend_in_scope (exprFreeVars rhs) + = go (Left in_scope') floats rhs cont + + -- See Note [exprIsConApp_maybe on literal strings] + | (fun `hasKey` unpackCStringIdKey) || + (fun `hasKey` unpackCStringUtf8IdKey) + , [arg] <- args + , Just (LitString str) <- exprIsLiteral_maybe ise arg + = succeedWith in_scope floats $ + dealWithStringLiteral fun str mco + where + unfolding = id_unf fun + extend_in_scope unf_fvs + | isLocalId fun = in_scope `extendInScopeSetSet` unf_fvs + | otherwise = in_scope + -- A GlobalId has no (LocalId) free variables; and the + -- in-scope set tracks only LocalIds + + go _ _ _ _ = Nothing + + succeedWith :: InScopeSet -> [FloatBind] + -> Maybe (DataCon, [Type], [CoreExpr]) + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) + succeedWith in_scope rev_floats x + = do { (con, tys, args) <- x + ; let floats = reverse rev_floats + ; return (in_scope, floats, con, tys, args) } + + ---------------------------- + -- Operations on the (Either InScopeSet GHC.Core.Subst) + -- The Left case is wildly dominant + + subst_in_scope (Left in_scope) = in_scope + subst_in_scope (Right s) = substInScopeSet s + + subst_extend_in_scope (Left in_scope) v = Left (in_scope `extendInScopeSet` v) + subst_extend_in_scope (Right s) v = Right (s `extendSubstInScope` v) + + subst_co (Left {}) co = co + subst_co (Right s) co = GHC.Core.Subst.substCo s co + + subst_expr (Left {}) e = e + subst_expr (Right s) e = substExpr s e + + subst_bndr msubst bndr + = (Right subst', bndr') + where + (subst', bndr') = substBndr subst bndr + subst = case msubst of + Left in_scope -> mkEmptySubst in_scope + Right subst -> subst + + subst_bndrs subst bs = mapAccumL subst_bndr subst bs + + extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) + extend (Right s) v e = Right (extendSubst s v e) + + case_bind :: Either InScopeSet Subst -> CoreExpr -> Type -> (Either InScopeSet Subst, FloatBind, Id) + case_bind subst expr expr_ty = (subst', float, bndr) + where + bndr = setCaseBndrEvald MarkedStrict $ + uniqAway (subst_in_scope subst) $ + mkWildValBinder ManyTy expr_ty + subst' = subst_extend_in_scope subst bndr + expr' = subst_expr subst expr + float = FloatCase expr' bndr DEFAULT [] + + mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, [FloatBind], [CoreExpr]) + -- See Note [Strict fields in Core] for what a field seq is and (SFC2) for + -- why we insert them + mkFieldSeqFloats in_scope dc args + | isLazyDataConRep dc + = (in_scope, [], args) + | otherwise + = (in_scope', floats', ty_args ++ val_args') + where + (ty_args, val_args) = splitAtList (dataConUnivAndExTyCoVars dc) args + (in_scope', floats', val_args') = foldr do_one (in_scope, [], []) $ zipEqual str_marks val_args + str_marks = dataConRepStrictness dc + do_one (str, arg) (in_scope,floats,args) + | NotMarkedStrict <- str = no_seq + | exprIsHNF arg = no_seq + | otherwise = (in_scope', float:floats, Var bndr:args) + where + no_seq = (in_scope, floats, arg:args) + (in_scope', float, bndr) = + case case_bind (Left in_scope) arg (exprType arg) of + (Left in_scope', float, bndr) -> (in_scope', float, bndr) + (right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right) + +-- See Note [exprIsConApp_maybe on literal strings] +dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion + -> Maybe (DataCon, [Type], [CoreExpr]) + +-- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS +-- turns those into [] automatically, but just in case something else in GHC +-- generates a string literal directly. +dealWithStringLiteral fun str mco = + case utf8UnconsByteString str of + Nothing -> pushCoDataCon nilDataCon [Type charTy] mco + Just (char, charTail) -> + let char_expr = mkConApp charDataCon [mkCharLit char] + -- In singleton strings, just add [] instead of unpackCstring# ""#. + rest = if BS.null charTail + then mkConApp nilDataCon [Type charTy] + else App (Var fun) + (Lit (LitString charTail)) + + in pushCoDataCon consDataCon [Type charTy, char_expr, rest] mco + +{- +Note [Case elim in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data K a = MkK !a + + $WMkK x = case x of y -> K y -- Wrapper for MkK + + ...case $WMkK v of K w -> + +We call `exprIsConApp_maybe` on ($WMkK v); we inline the wrapper +and beta-reduce, so we get to + exprIsConApp_maybe (case v of y -> K y) + +So we may float the case, and end up with + case v of y -> [y/w] + +But if `v` is already evaluated, the next run of the Simplifier will +eliminate the case, and we may then make more progress with . +Better to do it in one iteration. Hence the `do_case_elim` +check in `exprIsConApp_maybe`. + +Note [Unfolding DFuns] +~~~~~~~~~~~~~~~~~~~~~~ +DFuns look like + + df :: forall a b. (Eq a, Eq b) -> Eq (a,b) + df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) + ($c2 a b d_a d_b) + +So to split it up we just need to apply the ops $c1, $c2 etc +to the very same args as the dfun. It takes a little more work +to compute the type arguments to the dictionary constructor. + +Note [DFun arity check] +~~~~~~~~~~~~~~~~~~~~~~~ +Here we check that the total number of supplied arguments (including +type args) matches what the dfun is expecting. This may be *less* +than the ordinary arity of the dfun: see Note [DFun unfoldings] in GHC.Core +-} + +exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal +-- Same deal as exprIsConApp_maybe, but much simpler +-- Nevertheless we do need to look through unfoldings for +-- string literals, which are vigorously hoisted to top level +-- and not subsequently inlined +exprIsLiteral_maybe env@(ISE _ id_unf) e + = case e of + Lit l -> Just l + Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? + Var v -> expandUnfolding_maybe (id_unf v) + >>= exprIsLiteral_maybe env + _ -> Nothing + +{- +Note [exprIsLambda_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsLambda_maybe will, given an expression `e`, try to turn it into the form +`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through +casts (using the Push rule), and it unfolds function calls if the unfolding +has a greater arity than arguments are present. + +Currently, it is used in GHC.Core.Rules.match, and is required to make +"map coerce = coerce" match. +-} + +exprIsLambda_maybe :: HasDebugCallStack + => InScopeEnv -> CoreExpr + -> Maybe (Var, CoreExpr,[CoreTickish]) + -- See Note [exprIsLambda_maybe] + +-- The simple case: It is a lambda already +exprIsLambda_maybe _ (Lam x e) + = Just (x, e, []) + +-- Still straightforward: Ticks that we can float out of the way +exprIsLambda_maybe ise (Tick t e) + | tickishFloatable t + , Just (x, e, ts) <- exprIsLambda_maybe ise e + = Just (x, e, t:ts) + +-- Also possible: A casted lambda. Push the coercion inside +exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co) + | Just (x, e,ts) <- exprIsLambda_maybe ise casted_e + -- Only do value lambdas. + -- this implies that x is not in scope in gamma (makes this code simpler) + , not (isTyVar x) && not (isCoVar x) + , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True + , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co + , let res = Just (x',e',ts) + = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) + res + +-- Another attempt: See if we find a partial unfolding +exprIsLambda_maybe ise@(ISE in_scope_set id_unf) e + | (Var f, as, ts) <- collectArgsTicks tickishFloatable e + , idArity f > count isValArg as + -- Make sure there is hope to get a lambda + , Just rhs <- expandUnfolding_maybe (id_unf f) + -- Optimize, for beta-reduction + , let e' = simpleOptExprWith defaultSimpleOpts (mkEmptySubst in_scope_set) (rhs `mkApps` as) + -- Recurse, because of possible casts + , Just (x', e'', ts') <- exprIsLambda_maybe ise e' + , let res = Just (x', e'', ts++ts') + = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) + res + +exprIsLambda_maybe _ _e + = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) + Nothing diff --git a/GHC/Core/SimpleOpt.hs-boot b/GHC/Core/SimpleOpt.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/SimpleOpt.hs-boot @@ -0,0 +1,11 @@ +module GHC.Core.SimpleOpt where + +import GHC.Core +import {-# SOURCE #-} GHC.Core.Unfold +import GHC.Utils.Misc (HasDebugCallStack) + +data SimpleOpts + +so_uf_opts :: SimpleOpts -> UnfoldingOpts + +simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr diff --git a/GHC/Core/Stats.hs b/GHC/Core/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Stats.hs @@ -0,0 +1,138 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-2015 +-} + +-- | Functions to computing the statistics reflective of the "size" +-- of a Core expression +module GHC.Core.Stats ( + -- * Expression and bindings size + coreBindsSize, exprSize, + CoreStats(..), coreBindsStats, exprStats, + ) where + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Core +import GHC.Utils.Outputable +import GHC.Core.Coercion +import GHC.Types.Tickish +import GHC.Types.Var +import GHC.Core.Type(Type, typeSize) +import GHC.Types.Id (isJoinId) + +data CoreStats = CS { cs_tm :: !Int -- Terms + , cs_ty :: !Int -- Types + , cs_co :: !Int -- Coercions + , cs_vb :: !Int -- Local value bindings + , cs_jb :: !Int } -- Local join bindings + + +instance Outputable CoreStats where + ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3, cs_vb = i4, cs_jb = i5 }) + = braces (sep [text "terms:" <+> intWithCommas i1 <> comma, + text "types:" <+> intWithCommas i2 <> comma, + text "coercions:" <+> intWithCommas i3 <> comma, + text "joins:" <+> intWithCommas i5 <> char '/' <> + intWithCommas (i4 + i5) ]) + +plusCS :: CoreStats -> CoreStats -> CoreStats +plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1, cs_vb = v1, cs_jb = j1 }) + (CS { cs_tm = p2, cs_ty = q2, cs_co = r2, cs_vb = v2, cs_jb = j2 }) + = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2, cs_vb = v1+v2 + , cs_jb = j1+j2 } + +zeroCS, oneTM :: CoreStats +zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0, cs_vb = 0, cs_jb = 0 } +oneTM = zeroCS { cs_tm = 1 } + +sumCS :: (a -> CoreStats) -> [a] -> CoreStats +sumCS f = foldl' (\s a -> plusCS s (f a)) zeroCS + +coreBindsStats :: [CoreBind] -> CoreStats +coreBindsStats = sumCS (bindStats TopLevel) + +bindStats :: TopLevelFlag -> CoreBind -> CoreStats +bindStats top_lvl (NonRec v r) = bindingStats top_lvl v r +bindStats top_lvl (Rec prs) = sumCS (\(v,r) -> bindingStats top_lvl v r) prs + +bindingStats :: TopLevelFlag -> Var -> CoreExpr -> CoreStats +bindingStats top_lvl v r = letBndrStats top_lvl v `plusCS` exprStats r + +bndrStats :: Var -> CoreStats +bndrStats v = oneTM `plusCS` tyStats (varType v) + +letBndrStats :: TopLevelFlag -> Var -> CoreStats +letBndrStats top_lvl v + | isTyVar v || isTopLevel top_lvl = bndrStats v + | isJoinId v = oneTM { cs_jb = 1 } `plusCS` ty_stats + | otherwise = oneTM { cs_vb = 1 } `plusCS` ty_stats + where + ty_stats = tyStats (varType v) + +exprStats :: CoreExpr -> CoreStats +exprStats (Var {}) = oneTM +exprStats (Lit {}) = oneTM +exprStats (Type t) = tyStats t +exprStats (Coercion c) = coStats c +exprStats (App f a) = exprStats f `plusCS` exprStats a +exprStats (Lam b e) = bndrStats b `plusCS` exprStats e +exprStats (Let b e) = bindStats NotTopLevel b `plusCS` exprStats e +exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b + `plusCS` sumCS altStats as +exprStats (Cast e co) = coStats co `plusCS` exprStats e +exprStats (Tick _ e) = exprStats e + +altStats :: CoreAlt -> CoreStats +altStats (Alt _ bs r) = altBndrStats bs `plusCS` exprStats r + +altBndrStats :: [Var] -> CoreStats +-- Charge one for the alternative, not for each binder +altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs + +tyStats :: Type -> CoreStats +tyStats ty = zeroCS { cs_ty = typeSize ty } + +coStats :: Coercion -> CoreStats +coStats co = zeroCS { cs_co = coercionSize co } + +coreBindsSize :: [CoreBind] -> Int +-- We use coreBindsStats for user printout +-- but this one is a quick and dirty basis for +-- the simplifier's tick limit +coreBindsSize bs = sum (map bindSize bs) + +exprSize :: CoreExpr -> Int +-- ^ A measure of the size of the expressions, strictly greater than 0 +-- Counts *leaves*, not internal nodes. Types and coercions are not counted. +exprSize (Var _) = 1 +exprSize (Lit _) = 1 +exprSize (App f a) = exprSize f + exprSize a +exprSize (Lam b e) = bndrSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +exprSize (Case e b _ as) = exprSize e + bndrSize b + 1 + sum (map altSize as) +exprSize (Cast e _) = 1 + exprSize e +exprSize (Tick n e) = tickSize n + exprSize e +exprSize (Type _) = 1 +exprSize (Coercion _) = 1 + +tickSize :: CoreTickish -> Int +tickSize (ProfNote _ _ _) = 1 +tickSize _ = 1 + +bndrSize :: Var -> Int +bndrSize _ = 1 + +bndrsSize :: [Var] -> Int +bndrsSize = sum . map bndrSize + +bindSize :: CoreBind -> Int +bindSize (NonRec b e) = bndrSize b + exprSize e +bindSize (Rec prs) = sum (map pairSize prs) + +pairSize :: (Var, CoreExpr) -> Int +pairSize (b,e) = bndrSize b + exprSize e + +altSize :: CoreAlt -> Int +altSize (Alt _ bs e) = bndrsSize bs + exprSize e diff --git a/GHC/Core/Subst.hs b/GHC/Core/Subst.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Subst.hs @@ -0,0 +1,686 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +module GHC.Core.Subst ( + -- * Main data types + Subst(..), -- Implementation exported for supercompiler's Renaming.hs only + TvSubstEnv, IdSubstEnv, InScopeSet, + + -- ** Substituting into expressions and related types + deShadowBinds, substRuleInfo, substRulesForImportedIds, + substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC, + substUnfolding, substUnfoldingSC, + lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc, + substTickish, substDVarSet, substIdInfo, + + -- ** Operations on substitutions + emptySubst, mkEmptySubst, mkTCvSubst, mkOpenSubst, isEmptySubst, + extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, + extendIdSubstWithClone, + extendSubst, extendSubstList, extendSubstWithVar, + extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, + isInScope, setInScope, substInScopeSet, + extendTvSubst, extendCvSubst, + delBndr, delBndrs, zapSubst, + + -- ** Substituting and cloning binders + substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, + cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + cloneBndrsM, cloneRecIdBndrsM, + + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Seq +import GHC.Core.Utils + + -- We are defining local versions +import GHC.Core.Type hiding ( substTy ) +import GHC.Core.Coercion + ( tyCoFVsOfCo, mkCoVarCo, substCoVarBndr ) + +import GHC.Types.Var.Set +import GHC.Types.Var.Env as InScopeSet +import GHC.Types.Id +import GHC.Types.Name ( Name ) +import GHC.Types.Var +import GHC.Types.Tickish +import GHC.Types.Id.Info +import GHC.Types.Unique.Supply + +import GHC.Builtin.Names +import GHC.Data.Maybe + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Functor.Identity (Identity (..)) +import Data.List (mapAccumL) + +{- +************************************************************************ +* * +\subsection{Substitutions} +* * +************************************************************************ +-} + +{- +Note [Extending the IdSubstEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We make a different choice for Ids than we do for TyVars. + +For TyVars, see Note [Extending the TvSubstEnv and CvSubstEnv] in GHC.Core.TyCo.Subst. + +For Ids, we have a different invariant + The IdSubstEnv is extended *only* when the Unique on an Id changes + Otherwise, we just extend the InScopeSet + +In consequence: + +* If all subst envs are empty, substExpr would be a + no-op, so substExprSC ("short cut") does nothing. + + However, substExpr still goes ahead and substitutes. Reason: we may + want to replace existing Ids with new ones from the in-scope set, to + avoid space leaks. + +* In substIdBndr, we extend the IdSubstEnv only when the unique changes + +* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty, + substExpr does nothing (Note that the above rule for substIdBndr + maintains this property. If the incoming envts are both empty, then + substituting the type and IdInfo can't change anything.) + +* In lookupIdSubst, we *must* look up the Id in the in-scope set, because + it may contain non-trivial changes. Example: + (/\a. \x:a. ...x...) Int + We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change + so we only extend the in-scope set. Then we must look up in the in-scope + set when we find the occurrence of x. + +* The requirement to look up the Id in the in-scope set means that we + must NOT take no-op short cut when the IdSubst is empty. + We must still look up every Id in the in-scope set. + +* (However, we don't need to do so for expressions found in the IdSubst + itself, whose range is assumed to be correct wrt the in-scope set.) + +Why do we make a different choice for the IdSubstEnv than the +TvSubstEnv and CvSubstEnv? + +* For Ids, we change the IdInfo all the time (e.g. deleting the + unfolding), and adding it back later, so using the TyVar convention + would entail extending the substitution almost all the time + +* The simplifier wants to look up in the in-scope set anyway, in case it + can see a better unfolding from an enclosing case expression + +* For TyVars, only coercion variables can possibly change, and they are + easy to spot +-} + +---------------------------- + +-- We keep GHC.Core.Subst separate from GHC.Core.TyCo.Subst to avoid creating +-- circular dependencies. Functions in this file that don't depend on +-- the definition of CoreExpr can be moved to GHC.Core.TyCo.Subst, as long +-- as it does not require importing too many additional hs-boot files and +-- cause a significant drop in performance. + +-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is +-- such that TyCoSubst Note [The substitution invariant] +-- holds after extending the substitution like this +extendIdSubst :: Subst -> Id -> CoreExpr -> Subst +-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set +extendIdSubst (Subst in_scope ids tvs cvs) v r + = assertPpr (isNonCoVarId v) (ppr v $$ ppr r) $ + Subst in_scope (extendVarEnv ids v r) tvs cvs + +extendIdSubstWithClone :: Subst -> Id -> Id -> Subst +extendIdSubstWithClone (Subst in_scope ids tvs cvs) v v' + = assertPpr (isNonCoVarId v) (ppr v $$ ppr v') $ + Subst (extendInScopeSetSet in_scope new_in_scope) + (extendVarEnv ids v (varToCoreExpr v')) tvs cvs + where + new_in_scope = tyCoVarsOfType (varType v') `extendVarSet` v' + +-- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' +extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst +extendIdSubstList (Subst in_scope ids tvs cvs) prs + = assert (all (isNonCoVarId . fst) prs) $ + Subst in_scope (extendVarEnvList ids prs) tvs cvs + +-- | Add a substitution appropriate to the thing being substituted +-- (whether an expression, type, or coercion). See also +-- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' +extendSubst :: HasDebugCallStack => Subst -> Var -> CoreArg -> Subst +extendSubst subst var arg + = case arg of + Type ty -> assertPpr (isTyVar var) doc $ extendTvSubst subst var ty + Coercion co -> assertPpr (isCoVar var) doc $ extendCvSubst subst var co + _ -> assertPpr (isId var) doc $ extendIdSubst subst var arg + where + doc = ppr var <+> text ":=" <+> ppr arg + +extendSubstWithVar :: Subst -> Var -> Var -> Subst +extendSubstWithVar subst v1 v2 + | isTyVar v1 = assert (isTyVar v2) $ extendTvSubst subst v1 (mkTyVarTy v2) + | isCoVar v1 = assert (isCoVar v2) $ extendCvSubst subst v1 (mkCoVarCo v2) + | otherwise = assert (isId v2) $ extendIdSubst subst v1 (Var v2) + +-- | Add a substitution as appropriate to each of the terms being +-- substituted (whether expressions, types, or coercions). See also +-- 'extendSubst'. +extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst +extendSubstList subst [] = subst +extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs + +-- | Find the substitution for an 'Id' in the 'Subst' +-- The Id should not be a CoVar +lookupIdSubst :: HasDebugCallStack => Subst -> Id -> CoreExpr +lookupIdSubst (Subst in_scope ids _ _) v + | assertPpr (isId v && not (isCoVar v)) (ppr v) + not (isLocalId v) = Var v + | Just e <- lookupVarEnv ids v = e + | Just v' <- lookupInScope in_scope v = Var v' + -- Vital! See Note [Extending the IdSubstEnv] + -- If v isn't in the InScopeSet, we panic, because + -- it's a bad bug and we really want to know + | otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope) + +lookupIdSubst_maybe :: HasDebugCallStack => Subst -> Id -> Maybe CoreExpr +-- Just look up in the substitution; do not check the in-scope set +lookupIdSubst_maybe (Subst _ ids _ _) v + = assertPpr (isId v && not (isCoVar v)) (ppr v) $ + lookupVarEnv ids v + +delBndr :: Subst -> Var -> Subst +delBndr (Subst in_scope ids tvs cvs) v + | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) + | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs + | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs + +delBndrs :: Subst -> [Var] -> Subst +delBndrs (Subst in_scope ids tvs cvs) vs + = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs) + -- Easiest thing is just delete all from all! + +-- | Simultaneously substitute for a bunch of variables +-- No left-right shadowing +-- ie the substitution for (\x \y. e) a1 a2 +-- so neither x nor y scope over a1 a2 +mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst +mkOpenSubst in_scope pairs = Subst in_scope + (mkVarEnv [(id,e) | (id, e) <- pairs, isId id]) + (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) + (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) + +------------------------------ + +{- +************************************************************************ +* * + Substituting expressions +* * +************************************************************************ +-} + +substExprSC :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr +-- Just like substExpr, but a no-op if the substitution is empty +-- Note that this does /not/ replace occurrences of free vars with +-- their canonical representatives in the in-scope set +substExprSC subst orig_expr + | isEmptySubst subst = orig_expr + | otherwise = substExpr subst orig_expr + +-- | substExpr applies a substitution to an entire 'CoreExpr'. Remember, +-- you may only apply the substitution /once/: +-- See Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst" +-- +-- Do *not* attempt to short-cut in the case of an empty substitution! +-- See Note [Extending the IdSubstEnv] +substExpr :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr + -- HasDebugCallStack so we can track failures in lookupIdSubst +substExpr subst expr + = go expr + where + go (Var v) = lookupIdSubst subst v + go (Type ty) = Type (substTyUnchecked subst ty) + go (Coercion co) = Coercion (substCo subst co) + go (Lit lit) = Lit lit + go (App fun arg) = App (go fun) (go arg) + go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) + go (Cast e co) = Cast (go e) (substCo subst co) + -- Do not optimise even identity coercions + -- Reason: substitution applies to the LHS of RULES, and + -- if you "optimise" an identity coercion, you may + -- lose a binder. We optimise the LHS of rules at + -- construction time + + go (Lam bndr body) = Lam bndr' (substExpr subst' body) + where + (subst', bndr') = substBndr subst bndr + + go (Let bind body) = Let bind' (substExpr subst' body) + where + (subst', bind') = substBind subst bind + + go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTyUnchecked subst ty) (map (go_alt subst') alts) + where + (subst', bndr') = substBndr subst bndr + + go_alt subst (Alt con bndrs rhs) = Alt con bndrs' (substExpr subst' rhs) + where + (subst', bndrs') = substBndrs subst bndrs + +-- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' +-- that should be used by subsequent substitutions. +substBind, substBindSC :: HasDebugCallStack => Subst -> CoreBind -> (Subst, CoreBind) + +substBindSC subst bind -- Short-cut if the substitution is empty + | not (isEmptySubst subst) + = substBind subst bind + | otherwise + = case bind of + NonRec bndr rhs -> (subst', NonRec bndr' rhs) + where + (subst', bndr') = substBndr subst bndr + Rec pairs -> (subst', Rec (bndrs' `zip` rhss')) + where + (bndrs, rhss) = unzip pairs + (subst', bndrs') = substRecBndrs subst bndrs + rhss' | isEmptySubst subst' + = rhss + | otherwise + = map (substExpr subst') rhss + +substBind subst (NonRec bndr rhs) + = (subst', NonRec bndr' (substExpr subst rhs)) + where + (subst', bndr') = substBndr subst bndr + +substBind subst (Rec pairs) + = (subst', Rec (bndrs' `zip` rhss')) + where + (bndrs, rhss) = unzip pairs + (subst', bndrs') = substRecBndrs subst bndrs + rhss' = map (substExpr subst') rhss + +-- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply +-- by running over the bindings with an empty substitution, because substitution +-- returns a result that has no-shadowing guaranteed. +-- +-- (Actually, within a single /type/ there might still be shadowing, because +-- 'substTy' is a no-op for the empty substitution, but that's probably OK.) +-- +-- [Aug 09] This function is not used in GHC at the moment, but seems so +-- short and simple that I'm going to leave it here +deShadowBinds :: CoreProgram -> CoreProgram +deShadowBinds binds = snd (mapAccumL substBind emptySubst binds) + +{- +************************************************************************ +* * + Substituting binders +* * +************************************************************************ + +Remember that substBndr and friends are used when doing expression +substitution only. Their only business is substitution, so they +preserve all IdInfo (suitably substituted). For example, we *want* to +preserve occ info in rules. +-} + +-- | Substitutes a 'Var' for another one according to the 'Subst' given, returning +-- the result and an updated 'Subst' that should be used by subsequent substitutions. +-- 'IdInfo' is preserved by this process, although it is substituted into appropriately. +substBndr :: Subst -> Var -> (Subst, Var) +substBndr subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | isCoVar bndr = substCoVarBndr subst bndr + | otherwise = substIdBndr (text "var-bndr") subst subst bndr + +-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right +substBndrs :: Traversable f => Subst -> f Var -> (Subst, f Var) +substBndrs = mapAccumL substBndr +{-# INLINE substBndrs #-} + +-- | Substitute in a mutually recursive group of 'Id's +substRecBndrs :: Traversable f => Subst -> f Id -> (Subst, f Id) +substRecBndrs subst bndrs + = (new_subst, new_bndrs) + where -- Here's the reason we need to pass rec_subst to subst_id + (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs +{-# SPECIALIZE substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) #-} +{-# SPECIALIZE substRecBndrs :: Subst -> Identity Id -> (Subst, Identity Id) #-} + +substIdBndr :: SDoc + -> Subst -- ^ Substitution to use for the IdInfo + -> Subst -> Id -- ^ Substitution and Id to transform + -> (Subst, Id) -- ^ Transformed pair + -- NB: unfolding may be zapped + +substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id + = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ + (Subst new_in_scope new_env tvs cvs, new_id) + where + id1 = uniqAway in_scope old_id -- id1 is cloned if necessary + id2 | no_type_change = id1 + | otherwise = updateIdTypeAndMult (substTyUnchecked subst) id1 + + old_ty = idType old_id + old_w = idMult old_id + no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || + (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) + + -- new_id has the right IdInfo + -- The lazy-set is because we're in a loop here, with + -- rec_subst, when dealing with a mutually-recursive group + !new_id = maybeModifyIdInfo mb_new_info id2 + mb_new_info = substIdInfo rec_subst id2 (idInfo id2) + -- NB: unfolding info may be zapped + + -- Extend the substitution if the unique has changed + -- See the notes with substTyVarBndr for the delVarEnv + !new_in_scope = in_scope `InScopeSet.extendInScopeSet` new_id + -- Forcing new_in_scope improves T9675 by 1.7% + !new_env | no_change = delVarEnv env old_id + | otherwise = extendVarEnv env old_id (Var new_id) + + no_change = id1 == old_id + -- See Note [Extending the IdSubstEnv] + -- it's /not/ necessary to check mb_new_info and no_type_change + +{- +Now a variant that unconditionally allocates a new unique. +It also unconditionally zaps the OccInfo. +-} + +-- | Very similar to 'substBndr', but it always allocates a new 'Unique' for +-- each variable in its output. It substitutes the IdInfo though. +-- Discards non-Stable unfoldings +cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) +cloneIdBndr subst us old_id + = clone_id subst subst (old_id, uniqFromSupply us) + +-- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final +-- substitution from left to right +-- Discards non-Stable unfoldings +cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneIdBndrs subst us ids + = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) + +cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) +-- Works for all kinds of variables (typically case binders) +-- not just Ids +cloneBndrs subst us vs + = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us) + +cloneBndrsM :: MonadUnique m => Subst -> [Var] -> m (Subst, [Var]) +-- Works for all kinds of variables (typically case binders) +-- not just Ids +cloneBndrsM subst vs = cloneBndrs subst `flip` vs <$> getUniqueSupplyM + +cloneBndr :: Subst -> Unique -> Var -> (Subst, Var) +cloneBndr subst uniq v + | isTyVar v = cloneTyVarBndr subst v uniq + | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too + +-- | Clone a mutually recursive group of 'Id's +cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneRecIdBndrs subst us ids = + let x@(subst', _) = mapAccumL (clone_id subst') subst (ids `zip` uniqsFromSupply us) + in x + +-- | Clone a mutually recursive group of 'Id's +cloneRecIdBndrsM :: MonadUnique m => Subst -> [Id] -> m (Subst, [Id]) +cloneRecIdBndrsM subst ids = cloneRecIdBndrs subst `flip` ids <$> getUniqueSupplyM + +-- Just like substIdBndr, except that it always makes a new unique +-- It is given the unique to use +-- Discards non-Stable unfoldings +clone_id :: Subst -- Substitution for the IdInfo + -> Subst -> (Id, Unique) -- Substitution and Id to transform + -> (Subst, Id) -- Transformed pair + +clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) + = (Subst new_in_scope new_idvs tvs new_cvs, new_id) + where + id1 = setVarUnique old_id uniq + id2 = substIdType subst id1 + !new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2 + !new_in_scope = in_scope `InScopeSet.extendInScopeSet` new_id + -- Forcing new_in_scope improves T9675 by 1.7% + (!new_idvs, !new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id)) + | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs) + +{- +************************************************************************ +* * + Types and Coercions +* * +************************************************************************ +-} + +{- +************************************************************************ +* * +\section{IdInfo substitution} +* * +************************************************************************ +-} + +substIdType :: Subst -> Id -> Id +substIdType subst@(Subst _ _ tv_env cv_env) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) + || (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) = id + | otherwise = + updateIdTypeAndMult (substTyUnchecked subst) id + -- The tyCoVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + old_ty = idType id + old_w = idMult id + +------------------ +-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. +-- Discards unfoldings, unless they are Stable +substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo +substIdInfo subst new_id info + | nothing_to_do = Nothing + | otherwise = Just (info `setRuleInfo` substRuleInfo subst new_id old_rules + `setUnfoldingInfo` substUnfolding subst old_unf) + where + old_rules = ruleInfo info + old_unf = realUnfoldingInfo info + nothing_to_do = isEmptyRuleInfo old_rules && not (hasCoreUnfolding old_unf) + +------------------ +-- | Substitutes for the 'Id's within an unfolding +-- NB: substUnfolding /discards/ any unfolding without +-- without a Stable source. This is usually what we want, +-- but it may be a bit unexpected +substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding + -- Seq'ing on the returned Unfolding is enough to cause + -- all the substitutions to happen completely + +substUnfoldingSC subst unf -- Short-cut version + | isEmptySubst subst = unf + | otherwise = substUnfolding subst unf + +substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = df { df_bndrs = bndrs', df_args = args' } + where + (subst',bndrs') = substBndrs subst bndrs + args' = map (substExpr subst') args + +substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) + -- Retain stable unfoldings + | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work + = NoUnfolding + | otherwise -- But keep a stable one! + = seqExpr new_tmpl `seq` + unf { uf_tmpl = new_tmpl } + where + new_tmpl = substExpr subst tmpl + +substUnfolding _ unf = unf -- NoUnfolding, OtherCon + +------------------ +substIdOcc :: Subst -> Id -> Id +-- These Ids should not be substituted to non-Ids +substIdOcc subst v = case lookupIdSubst subst v of + Var v' -> v' + other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) + +------------------ +-- | Substitutes for the 'Id's within the 'RuleInfo' given the new function 'Id' +substRuleInfo :: Subst -> Id -> RuleInfo -> RuleInfo +substRuleInfo subst new_id (RuleInfo rules rhs_fvs) + = RuleInfo (map (substRule subst subst_ru_fn) rules) + (substDVarSet subst rhs_fvs) + where + subst_ru_fn = const (idName new_id) + +------------------ +substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] +substRulesForImportedIds subst rules + = map (substRule subst not_needed) rules + where + not_needed name = pprPanic "substRulesForImportedIds" (ppr name) + +------------------ +substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule + +-- The subst_ru_fn argument is applied to substitute the ru_fn field +-- of the rule: +-- - Rules for *imported* Ids never change ru_fn +-- - Rules for *local* Ids are in the IdInfo for that Id, +-- and the ru_fn field is simply replaced by the new name +-- of the Id +substRule _ _ rule@(BuiltinRule {}) = rule +substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs + , ru_local = is_local }) + = rule { ru_bndrs = bndrs' + , ru_fn = if is_local + then subst_ru_fn fn_name + else fn_name + , ru_args = map (substExpr subst') args + , ru_rhs = substExpr subst' rhs } + -- Do NOT optimise the RHS (previously we did simplOptExpr here) + -- See Note [Substitute lazily] + where + (subst', bndrs') = substBndrs subst bndrs + +------------------ +substDVarSet :: HasDebugCallStack => Subst -> DVarSet -> DVarSet +substDVarSet subst@(Subst _ _ tv_env cv_env) fvs + = mkDVarSet $ fst $ foldr subst_fv ([], emptyVarSet) $ dVarSetElems fvs + where + subst_fv :: Var -> ([Var], VarSet) -> ([Var], VarSet) + subst_fv fv acc + | isTyVar fv + , let fv_ty = lookupVarEnv tv_env fv `orElse` mkTyVarTy fv + = tyCoFVsOfType fv_ty (const True) emptyVarSet $! acc + | isCoVar fv + , let fv_co = lookupVarEnv cv_env fv `orElse` mkCoVarCo fv + = tyCoFVsOfCo fv_co (const True) emptyVarSet $! acc + | otherwise + , let fv_expr = lookupIdSubst subst fv + = exprLocalFVs fv_expr (const True) emptyVarSet $! acc + +------------------ +-- | Drop free vars from the breakpoint if they have a non-variable substitution. +substTickish :: Subst -> CoreTickish -> CoreTickish +substTickish subst (Breakpoint ext bid ids) + = Breakpoint ext bid (mapMaybe do_one ids) + where + do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst + +substTickish _subst other = other + +{- Note [Substitute lazily] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions that substitute over IdInfo must be pretty lazy, because +they are knot-tied by substRecBndrs. + +One case in point was #10627 in which a rule for a function 'f' +referred to 'f' (at a different type) on the RHS. But instead of just +substituting in the rhs of the rule, we were calling simpleOptExpr, which +looked at the idInfo for 'f'; result <>. + +In any case we don't need to optimise the RHS of rules, or unfoldings, +because the simplifier will do that. + +Another place this went wrong was in `substRuleInfo`, which would immediately force +the lazy call to substExpr, which led to an infinite loop (as reported by #20112). + +This time the call stack looked something like: + +* `substRecBndrs` +* `substIdBndr` +* `substIdInfo` +* `substRuleInfo` +* `substRule` +* `substExpr` +* `mkTick` +* `isSaturatedConApp` +* Look at `IdInfo` for thing we are currently substituting because the rule is attached to `transpose` and mentions it in the `RHS` of the rule. + +and the rule was + +{-# RULES +"transpose/overlays1" forall xs. transpose (overlays1 xs) = overlays1 (fmap transpose xs) #-} + +This rule was attached to `transpose`, but also mentions itself in the RHS so we have +to be careful to not force the `IdInfo` for transpose when dealing with the RHS of the rule. + + + +Note [substTickish] +~~~~~~~~~~~~~~~~~~~~~~ +A Breakpoint contains a list of Ids. What happens if we ever want to +substitute an expression for one of these Ids? + +First, we ensure that we only ever substitute trivial expressions for +these Ids, by marking them as NoOccInfo in the occurrence analyser. +Then, when substituting for the Id, we unwrap any type applications +and abstractions to get back to an Id, with getIdFromTrivialExpr. + +Second, we have to ensure that we never try to substitute a literal +for an Id in a breakpoint. We ensure this by never storing an Id with +an unlifted type in a Breakpoint - see GHC.HsToCore.Ticks.mkTickish. +Breakpoints can't handle free variables with unlifted types anyway. + +These measures are only reliable with unoptimized code. +Since we can now enable optimizations for GHCi with +@-fno-unoptimized-core-for-interpreter -O@, nontrivial expressions can be +substituted, e.g. by specializations. +Therefore we resort to discarding free variables from breakpoints when this +situation occurs. +-} + +{- +Note [Worker inlining] +~~~~~~~~~~~~~~~~~~~~~~ +A worker can get substituted away entirely. + - it might be trivial + - it might simply be very small +We do not treat an InlWrapper as an 'occurrence' in the occurrence +analyser, so it's possible that the worker is not even in scope any more. + +In all these cases we simply drop the special case, returning to +InlVanilla. The WARN is just so I can see if it happens a lot. +-} diff --git a/GHC/Core/Tidy.hs b/GHC/Core/Tidy.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Tidy.hs @@ -0,0 +1,440 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +This module contains "tidying" code for *nested* expressions, bindings, rules. +The code for *top-level* bindings is in GHC.Iface.Tidy. +-} + + +module GHC.Core.Tidy ( + tidyExpr, tidyRules, tidyCbvInfoTop, tidyBndrs + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Type +import GHC.Core.TyCo.Tidy +import GHC.Core.Seq ( seqUnfolding ) + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand ( zapDmdEnvSig, isStrUsedDmd ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Unique (getUnique) +import GHC.Types.Unique.FM +import GHC.Types.Name hiding (tidyNameOcc) +import GHC.Types.Name.Set +import GHC.Types.SrcLoc +import GHC.Types.Tickish + +import GHC.Data.Maybe +import GHC.Utils.Misc +import Data.List (mapAccumL) +import GHC.Utils.Outputable +import GHC.Types.RepType (typePrimRep) +import GHC.Utils.Panic +import GHC.Types.Basic (isMarkedCbv, CbvMark (..)) +import GHC.Core.Utils (shouldUseCbvForId) + +{- +************************************************************************ +* * +\subsection{Tidying expressions, rules} +* * +************************************************************************ +-} + +tidyBind :: TidyEnv + -> CoreBind + -> (TidyEnv, CoreBind) + +tidyBind env (NonRec bndr rhs) + = -- pprTrace "tidyBindNonRec" (ppr bndr) $ + let cbv_bndr = (tidyCbvInfoLocal bndr rhs) + (env', bndr') = tidyLetBndr env env cbv_bndr + tidy_rhs = (tidyExpr env' rhs) + in (env', NonRec bndr' tidy_rhs) + +tidyBind env (Rec prs) + = -- pprTrace "tidyBindRec" (ppr $ map fst prs) $ + let + cbv_bndrs = map ((\(bnd,rhs) -> tidyCbvInfoLocal bnd rhs)) prs + (_bndrs, rhss) = unzip prs + (env', bndrs') = mapAccumL (tidyLetBndr env') env cbv_bndrs + in + map (tidyExpr env') rhss =: \ rhss' -> + (env', Rec (zip bndrs' rhss')) + + +-- Note [Attaching CBV Marks to ids] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- See Note [CBV Function Ids] for the *why*. +-- Before tidy, we turn all worker functions into worker like ids. +-- This way we can later tell if we can assume the existence of a wrapper. This also applies to +-- specialized versions of functions generated by SpecConstr for which we, in a sense, +-- consider the unspecialized version to be the wrapper. +-- During tidy we take the demands on the arguments for these ids and compute +-- CBV (call-by-value) semantics for each individual argument. +-- The marks themselves then are put onto the function id itself. +-- This means the code generator can get the full calling convention by only looking at the function +-- itself without having to inspect the RHS. +-- +-- The actual logic is in computeCbvInfo and takes: +-- * The function id +-- * The functions rhs +-- And gives us back the function annotated with the marks. +-- We call it in: +-- * tidyTopPair for top level bindings +-- * tidyBind for local bindings. +-- +-- Not that we *have* to look at the untidied rhs. +-- During tidying some knot-tying occurs which can blow up +-- if we look at the post-tidy types of the arguments here. +-- However we only care if the types are unlifted and that doesn't change during tidy. +-- so we can just look at the untidied types. +-- +-- If the id is boot-exported we don't use a cbv calling convention via marks, +-- as the boot file won't contain them. Which means code calling boot-exported +-- ids might expect these ids to have a vanilla calling convention even if we +-- determine a different one here. +-- To be able to avoid this we pass a set of boot exported ids for this module around. +-- For non top level ids we can skip this. Local ids are never boot-exported +-- as boot files don't have unfoldings. So there this isn't a concern. +-- See also Note [CBV Function Ids] + + +-- See Note [CBV Function Ids] +tidyCbvInfoTop :: HasDebugCallStack => NameSet -> Id -> CoreExpr -> Id +tidyCbvInfoTop boot_exports id rhs + -- Can't change calling convention for boot exported things + | elemNameSet (idName id) boot_exports = id + | otherwise = computeCbvInfo id rhs + +-- See Note [CBV Function Ids] +tidyCbvInfoLocal :: HasDebugCallStack => Id -> CoreExpr -> Id +tidyCbvInfoLocal id rhs = computeCbvInfo id rhs + +-- | For a binding we: +-- * Look at the args +-- * Mark any argument as call-by-value if: +-- - It's argument to a worker and demanded strictly +-- - Unless it's an unlifted type already +-- * Update the id +-- See Note [CBV Function Ids] +-- See Note [Attaching CBV Marks to ids] + +computeCbvInfo :: HasCallStack + => Id -- The function + -> CoreExpr -- It's RHS + -> Id +-- computeCbvInfo fun_id rhs = fun_id +computeCbvInfo fun_id rhs + | is_wkr_like || isJoinPoint mb_join_id + , valid_unlifted_worker val_args + = -- pprTrace "computeCbvInfo" + -- (text "fun" <+> ppr fun_id $$ + -- text "arg_tys" <+> ppr (map idType val_args) $$ + + -- text "prim_rep" <+> ppr (map typePrimRep_maybe $ map idType val_args) $$ + -- text "rrarg" <+> ppr (map isRuntimeVar val_args) $$ + -- text "cbv_marks" <+> ppr cbv_marks $$ + -- text "out_id" <+> ppr cbv_bndr $$ + -- ppr rhs) + cbv_bndr + + | otherwise = fun_id + where + mb_join_id = idJoinPointHood fun_id + is_wkr_like = isWorkerLikeId fun_id + + val_args = filter isId lam_bndrs + -- When computing CbvMarks, we limit the arity of join points to + -- the JoinArity, because that's the arity we are going to use + -- when calling it. There may be more lambdas than that on the RHS. + lam_bndrs | JoinPoint join_arity <- mb_join_id + = fst $ collectNBinders join_arity rhs + | otherwise + = fst $ collectBinders rhs + + cbv_marks = -- assert: CBV marks are only set during tidy so none should be present already. + assertPpr (maybe True null $ idCbvMarks_maybe fun_id) + (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $ + map mkMark val_args + + cbv_bndr | any isMarkedCbv cbv_marks + = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks + -- seqList: avoid retaining the original rhs + + | otherwise + = -- pprTraceDebug "computeCbvInfo: Worker seems to take unboxed tuple/sum types!" + -- (ppr fun_id <+> ppr rhs) + asNonWorkerLikeId fun_id + + -- We don't set CBV marks on functions which take unboxed tuples or sums as + -- arguments. Doing so would require us to compute the result of unarise + -- here in order to properly determine argument positions at runtime. + -- + -- In practice this doesn't matter much. Most "interesting" functions will + -- get a W/W split which will eliminate unboxed tuple arguments, and unboxed + -- sums are rarely used. But we could change this in the future and support + -- unboxed sums/tuples as well. + valid_unlifted_worker args = + -- pprTrace "valid_unlifted" (ppr fun_id $$ ppr args) $ + all isSingleUnarisedArg args + + isSingleUnarisedArg v + | isUnboxedSumType ty = False + | isUnboxedTupleType ty = isSimplePrimRep (typePrimRep ty) + | otherwise = isSimplePrimRep (typePrimRep ty) + where + ty = idType v + isSimplePrimRep [] = True + isSimplePrimRep [_] = True + isSimplePrimRep _ = False + + mkMark arg + | not $ shouldUseCbvForId arg = NotMarkedCbv + -- We can only safely use cbv for strict arguments + | (isStrUsedDmd (idDemandInfo arg)) + , not (isDeadEndId fun_id) = MarkedCbv + | otherwise = NotMarkedCbv + + +------------ Expressions -------------- +tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr +tidyExpr env (Var v) = Var (tidyVarOcc env v) +tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Coercion co) = Coercion (tidyCo env co) +tidyExpr _ (Lit lit) = Lit lit +tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) +tidyExpr env (Tick t e) = Tick (tidyTickish env t) (tidyExpr env e) +tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co) + +tidyExpr env (Let b e) + = tidyBind env b =: \ (env', b') -> + Let b' (tidyExpr env' e) + +tidyExpr env (Case e b ty alts) + = tidyBndr env b =: \ (env', b) -> + Case (tidyExpr env e) b (tidyType env ty) + (map (tidyAlt env') alts) + +tidyExpr env (Lam b e) + = tidyBndr env b =: \ (env', b) -> + Lam b (tidyExpr env' e) + +------------ Case alternatives -------------- +tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt +tidyAlt env (Alt con vs rhs) + = tidyBndrs env vs =: \ (env', vs) -> + (Alt con vs (tidyExpr env' rhs)) + +------------ Tickish -------------- +tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish +tidyTickish env (Breakpoint ext bid ids) + = Breakpoint ext bid (map (tidyVarOcc env) ids) +tidyTickish _ other_tickish = other_tickish + +------------ Rules -------------- +tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule] +tidyRules _ [] = [] +tidyRules env (rule : rules) + = tidyRule env rule =: \ rule -> + tidyRules env rules =: \ rules -> + (rule : rules) + +tidyRule :: TidyEnv -> CoreRule -> CoreRule +tidyRule _ rule@(BuiltinRule {}) = rule +tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, + ru_fn = fn, ru_rough = mb_ns }) + = tidyBndrs env bndrs =: \ (env', bndrs) -> + map (tidyExpr env') args =: \ args -> + rule { ru_bndrs = bndrs, ru_args = args, + ru_rhs = tidyExpr env' rhs, + ru_fn = tidyNameOcc env fn, + ru_rough = map (fmap (tidyNameOcc env')) mb_ns } + +{- +************************************************************************ +* * +\subsection{Tidying non-top-level binders} +* * +************************************************************************ +-} + +tidyNameOcc :: TidyEnv -> Name -> Name +-- In rules and instances, we have Names, and we must tidy them too +-- Fortunately, we can lookup in the VarEnv with a name +tidyNameOcc (_, var_env) n = case lookupUFM_Directly var_env (getUnique n) of + Nothing -> n + Just v -> idName v + +tidyVarOcc :: TidyEnv -> Var -> Var +tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v + +-- tidyBndr is used for lambda and case binders +tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) +tidyBndr env var + | isTyCoVar var = tidyVarBndr env var + | otherwise = tidyIdBndr env var + +tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +tidyBndrs env vars = mapAccumL tidyBndr env vars + +-- Non-top-level variables, not covars +tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) +tidyIdBndr env@(tidy_env, var_env) id + = -- Do this pattern match strictly, otherwise we end up holding on to + -- stuff in the OccName. + case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + -- Give the Id a fresh print-name, *and* rename its type + -- The SrcLoc isn't important now, + -- though we could extract it from the Id + -- + ty' = tidyType env (idType id) + mult' = tidyType env (idMult id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + id' = mkLocalIdWithInfo name' mult' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + new_info = vanillaIdInfo `setOccInfo` occInfo old_info + `setUnfoldingInfo` new_unf + -- see Note [Preserve OneShotInfo] + `setOneShotInfo` oneShotInfo old_info + old_info = idInfo id + old_unf = realUnfoldingInfo old_info + new_unf = trimUnfolding old_unf -- See Note [Preserve evaluatedness] + in + ((tidy_env', var_env'), id') + } + +tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings + -> TidyEnv -- The one to extend + -> Id -> (TidyEnv, Id) +-- Used for local (non-top-level) let(rec)s +-- Just like tidyIdBndr above, but with more IdInfo +tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id + = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + ty' = tidyType env (idType id) + mult' = tidyType env (idMult id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + details = idDetails id + id' = mkLocalVar details name' mult' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + -- We need to keep around any interesting strictness and + -- demand info because later on we may need to use it when + -- converting to A-normal form. + -- eg. + -- f (g x), where f is strict in its argument, will be converted + -- into case (g x) of z -> f z by CorePrep, but only if f still + -- has its strictness info. + -- + -- Similarly for the demand info - on a let binder, this tells + -- CorePrep to turn the let into a case. + -- But: Remove the usage demand here + -- (See Note [Zapping DmdEnv after Demand Analyzer] in GHC.Core.Opt.WorkWrap) + -- + -- Similarly arity info for eta expansion in CorePrep + -- Don't attempt to recompute arity here; this is just tidying! + -- Trying to do so led to #17294 + -- + -- Set inline-prag info so that we preserve it across + -- separate compilation boundaries + old_info = idInfo id + new_info = vanillaIdInfo + `setOccInfo` occInfo old_info + `setArityInfo` arityInfo old_info + `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info) + `setDemandInfo` demandInfo old_info + `setInlinePragInfo` inlinePragInfo old_info + `setUnfoldingInfo` new_unf + + old_unf = realUnfoldingInfo old_info + new_unf = tidyNestedUnfolding rec_tidy_env old_unf + + in + ((tidy_env', var_env'), id') } + +------------ Unfolding -------------- +tidyNestedUnfolding :: TidyEnv -> Unfolding -> Unfolding +tidyNestedUnfolding _ NoUnfolding = NoUnfolding +tidyNestedUnfolding _ BootUnfolding = BootUnfolding +tidyNestedUnfolding _ (OtherCon {}) = evaldUnfolding + +tidyNestedUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args } + where + (tidy_env', bndrs') = tidyBndrs tidy_env bndrs + +tidyNestedUnfolding tidy_env + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_cache = cache }) + | isStableSource src + = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo + -- This seqIt avoids a space leak: otherwise the uf_cache + -- field may retain a reference to the pre-tidied + -- expression forever (GHC.CoreToIface doesn't look at + -- them) + + -- Discard unstable unfoldings, but see Note [Preserve evaluatedness] + | uf_is_value cache = evaldUnfolding + | otherwise = noUnfolding + + where + seqIt unf = seqUnfolding unf `seq` unf + +{- +Note [Tidy IdInfo] +~~~~~~~~~~~~~~~~~~ +All nested Ids now have the same IdInfo, namely vanillaIdInfo, which +should save some space; except that we preserve occurrence info for +two reasons: + + (a) To make printing tidy core nicer + + (b) Because we tidy RULES and unfoldings, which may then propagate + via --make into the compilation of the next module, and we want + the benefit of that occurrence analysis when we use the rule or + or inline the function. In particular, it's vital not to lose + loop-breaker info, else we get an infinite inlining loop + +Note that tidyLetBndr puts more IdInfo back. + +Note [Preserve evaluatedness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Bool + ....(case v of MkT y -> + let z# = case y of + True -> 1# + False -> 2# + in ...) + +The z# binding is ok because the RHS is ok-for-speculation, +but Lint will complain unless it can *see* that. So we +preserve the evaluated-ness on 'y' in tidyBndr. + +(Another alternative would be to tidy unboxed lets into cases, +but that seems more indirect and surprising.) + +Note [Preserve OneShotInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We keep the OneShotInfo because we want it to propagate into the interface. +Not all OneShotInfo is determined by a compiler analysis; some is added by a +call of GHC.Exts.oneShot, which is then discarded before the end of the +optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we +must preserve this info in inlinings. See Note [oneShot magic] in GHC.Types.Id.Make. + +This applies to lambda binders only, hence it is stored in IfaceLamBndr. +-} + +(=:) :: a -> (a -> b) -> b +m =: k = m `seq` k m diff --git a/GHC/Core/TyCo/Compare.hs b/GHC/Core/TyCo/Compare.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Compare.hs @@ -0,0 +1,853 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1998 + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} + +-- | Type equality and comparison +module GHC.Core.TyCo.Compare ( + + -- * Type equality + eqType, eqTypeIgnoringMultiplicity, eqTypeX, eqTypes, + eqVarBndrs, + + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, + tcEqTyConApps, tcEqTyConAppArgs, + mayLookIdentical, + + -- * Type comparison + nonDetCmpType, + + -- * Visiblity comparision + eqForAllVis, cmpForAllVis + + ) where + +import GHC.Prelude + +import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe + , isLevityTy, isRuntimeRepTy, isMultiplicityTy ) + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCon +import GHC.Core.Multiplicity( MultiplicityFlag(..) ) + +import GHC.Types.Var +import GHC.Types.Unique +import GHC.Types.Var.Env +import GHC.Types.Var.Set + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import GHC.Base (reallyUnsafePtrEquality#) + +import qualified Data.Semigroup as S + +{- GHC.Core.TyCo.Compare overview +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module implements type equality and comparison + +It uses a few functions from GHC.Core.Type, notably `typeKind`, +so it currently sits "on top of" GHC.Core.Type. +-} + +{- ********************************************************************* +* * + Type equality + + We don't use (==) from class Eq, partly so that we know where + type equality is called, and partly because there are multiple + variants. +* * +********************************************************************* -} + +{- Note [Computing equality on types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module implements type equality, notably `eqType`. This is +"definitional equality" or just "equality" for short. + +There are several places within GHC that depend on the precise choice of +definitional equality used. If we change that definition, all these places +must be updated. This Note merely serves as a place for all these places +to refer to, so searching for references to this Note will find every place +that needs to be updated. + +* See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. + +* See Historical Note [Typechecker equality vs definitional equality] + below + +Note [Casts and coercions in type comparision] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As (EQTYPE) in Note [Non-trivial definitional equality] says, our +general plan, implemented by `fullEq`, is: + (1) ignore both casts and coercions when comparing types, + (2) instead, compare the /kinds/ of the two types, + as well as the types themselves + +If possible we want to avoid step (2), comparing the kinds; doing so involves +calling `typeKind` and doing another comparision. + +When can we avoid doing so? Answer: we can certainly avoid doing so if the +types we are comparing have no casts or coercions. But we can do better. +Consider + eqType (TyConApp T [s1, ..., sn]) (TyConApp T [t1, .., tn]) +We are going to call (eqType s1 t1), (eqType s2 t2) etc. + +The kinds of `s1` and `t1` must be equal, because these TyConApps are well-kinded, +and both TyConApps are headed by the same T. So the first recursive call to `eqType` +certainly doesn't need to check kinds. If that call returns False, we stop. Otherwise, +we know that `s1` and `t1` are themselves equal (not just their kinds). This +makes the kinds of `s2` and `t2` to be equal, because those kinds come from the +kind of T instantiated with `s1` and `t1` -- which are the same. Thus we do not +need to check the kinds of `s2` and `t2`. By induction, we don't need to check +the kinds of *any* of the types in a TyConApp, and we also do not need to check +the kinds of the TyConApps themselves. + +Conclusion: + +* casts and coercions under a TyConApp don't matter -- even including type synonyms + +* In step (2), use `hasCasts` to tell if there are any casts to worry about. It + does not look very deep, because TyConApps and FunTys are so common, and it + doesn't allocate. The only recursive cases are AppTy and ForAllTy. + +Alternative implementation. Instead of `hasCasts`, we could make the +generic_eq_type function return + data EqResult = NotEq | EqWithNoCasts | EqWithCasts +Practically free; but stylistically I prefer useing `hasCasts`: + * `generic_eq_type` can just uses familiar booleans + * There is a lot more branching with the three-value variant. + * It separates concerns. No need to think about cast-tracking when doing the + equality comparison. + * Indeed sometimes we omit the kind check unconditionally, so tracking it is just wasted + work. +I did try both; there was no perceptible perf difference so I chose `hasCasts` version. + +Note [Equality on AppTys] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In our cast-ignoring equality, we want to say that the following two +are equal: + + (Maybe |> co) (Int |> co') ~? Maybe Int + +But the left is an AppTy while the right is a TyConApp. The solution is +to use splitAppTyNoView_maybe to break up the TyConApp into its pieces and +then continue. Easy to do, but also easy to forget to do. + +Note [Comparing type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the task of testing equality between two 'Type's of the form + + TyConApp tc tys1 = TyConApp tc tys2 + +where `tc` is a type synonym. A naive way to perform this comparison these +would first expand the synonym and then compare the resulting expansions. + +However, this is obviously wasteful and the RHS of `tc` may be large. We'd +prefer to compare `tys1 = tys2`. When is that sound? Precisely when the +synonym is not /forgetful/; that is, all its type variables appear in its +RHS -- see `GHC.Core.TyCon.isForgetfulSynTyCon`. + +Of course, if we find that the TyCons are *not* equal then we still need to +perform the expansion as their RHSs may still be equal. + +This works fine for /equality/, but not for /comparison/. Consider + type S a b = (b, a) +Now consider + S Int Bool `compare` S Char Char +The ordering may depend on whether we expand the synonym or not, and we +don't want the result to depend on that. So for comparison we stick to +/nullary/ synonyms only, which is still useful. + +We perform this optimisation in a number of places: + + * GHC.Core.TyCo.Compare.eqType (works for non-nullary synonyms) + * GHC.Core.Map.TYpe.eqDeBruijnType (works for non-nullary synonyms) + * GHC.Core.Types.nonDetCmpType (nullary only) + +This optimisation is especially helpful for the ubiquitous GHC.Types.Type, +since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications +whenever possible. See Note [Using synonyms to compress types] in +GHC.Core.Type for details. + +Currently-missed opportunity (#25009): +* In the case of forgetful synonyms, we could still compare the args, pairwise, + and then compare the RHS's with a suitably extended RnEnv2. That would avoid + comparing the same arg repeatedly. e.g. + type S a b = (a,a) + Compare S y ~ S y + If we expand, we end up compare with itself twice. + + But since forgetful synonyms are rare, we have not tried this. + +Note [Type comparisons using object pointer comparisons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Quite often we substitute the type from a definition site into +occurrences without a change. This means for code like: + \x -> (x,x,x) +The type of every `x` will often be represented by a single object +in the heap. We can take advantage of this by shortcutting the equality +check if two types are represented by the same pointer under the hood. +In some cases this reduces compiler allocations by ~2%. + +See Note [Pointer comparison operations] in GHC.Builtin.primops.txt.pp + +Note [Respecting multiplicity when comparing types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, we respect multiplicities (i.e. the linear part of the type +system) when comparing types. Doing so is of course crucial during typechecking. + +But for reasons described in Note [Linting linearity] in GHC.Core.Lint, it is hard +to ensure that Core is always type-correct when it comes to linearity. So +* `eqTypeIgnoringMultiplicity` provides a way to compare types that /ignores/ multiplicities +* We use this multiplicity-blind comparison very occasionally, notably + - in Core Lint: see Note [Linting linearity] in GHC.Core.Lint + - in rule matching: see Note [Rewrite rules ignore multiplicities in FunTy] + in GHC.Core.Unify +-} + + +tcEqKind :: HasDebugCallStack => Kind -> Kind -> Bool +tcEqKind = tcEqType + +tcEqType :: HasDebugCallStack => Type -> Type -> Bool +tcEqType = eqType + +-- | Just like 'tcEqType', but will return True for types of different kinds +-- as long as their non-coercion structure is identical. +tcEqTypeNoKindCheck :: Type -> Type -> Bool +tcEqTypeNoKindCheck = eqTypeNoKindCheck + +-- | Check whether two TyConApps are the same; if the number of arguments +-- are different, just checks the common prefix of arguments. +tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool +tcEqTyConApps tc1 args1 tc2 args2 + = tc1 == tc2 && tcEqTyConAppArgs args1 args2 + +tcEqTyConAppArgs :: [Type] -> [Type] -> Bool +-- Args do not have to have equal length; +-- we discard the excess of the longer one +tcEqTyConAppArgs args1 args2 + = and (zipWith tcEqTypeNoKindCheck args1 args2) + -- No kind check necessary: if both arguments are well typed, then + -- any difference in the kinds of later arguments would show up + -- as differences in earlier (dependent) arguments + +-- | Type equality on lists of types, looking through type synonyms +eqTypes :: [Type] -> [Type] -> Bool +eqTypes [] [] = True +eqTypes (t1:ts1) (t2:ts2) = eqType t1 t2 && eqTypes ts1 ts2 +eqTypes _ _ = False + +eqVarBndrs :: HasCallStack => RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 +-- Check that the var lists are the same length +-- and have matching kinds; if so, extend the RnEnv2 +-- Returns Nothing if they don't match +eqVarBndrs env [] [] + = Just env +eqVarBndrs env (tv1:tvs1) (tv2:tvs2) + | eqTypeX env (varType tv1) (varType tv2) + = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 +eqVarBndrs _ _ _= Nothing + +initRnEnv :: Type -> Type -> RnEnv2 +initRnEnv ta tb = mkRnEnv2 $ mkInScopeSet $ + tyCoVarsOfType ta `unionVarSet` tyCoVarsOfType tb + +eqTypeNoKindCheck :: Type -> Type -> Bool +eqTypeNoKindCheck ty1 ty2 = eq_type_expand_respect ty1 ty2 + +-- | Type equality comparing both visible and invisible arguments, +-- expanding synonyms and respecting multiplicities. +eqType :: HasCallStack => Type -> Type -> Bool +eqType ta tb = fullEq eq_type_expand_respect ta tb + +-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. +eqTypeX :: HasCallStack => RnEnv2 -> Type -> Type -> Bool +eqTypeX env ta tb = fullEq (eq_type_expand_respect_x env) ta tb + +eqTypeIgnoringMultiplicity :: Type -> Type -> Bool +-- See Note [Respecting multiplicity when comparing types] +eqTypeIgnoringMultiplicity ta tb = fullEq eq_type_expand_ignore ta tb + +-- | Like 'pickyEqTypeVis', but returns a Bool for convenience +pickyEqType :: Type -> Type -> Bool +-- Check when two types _look_ the same, _including_ synonyms. +-- So (pickyEqType String [Char]) returns False +-- This ignores kinds and coercions, because this is used only for printing. +pickyEqType ta tb = eq_type_keep_respect ta tb + +{- Note [Specialising type equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type equality predicates in Type are hit pretty hard by GHC. Consequently +we take pains to ensure that these paths are compiled to efficient, +minimally-allocating code. Plan: + +* The main workhorse is `inline_generic_eq_type_x`. It is /non-recursive/ + and is marked INLINE. + +* `inline_generic_eq_type_x` has various parameters that control what it does: + * syn_flag::SynFlag whether type synonyms are expanded or kept. + * mult_flag::MultiplicityFlag whether multiplicities are ignored or respected + * mb_env::Maybe RnEnv2 an optional RnEnv2. + +* `inline_generic_eq_type_x` has a handful of call sites, namely the ones + in `eq_type_expand_respect`, `eq_type_expand_repect_x` etc. It inlines + at all these sites, specialising to the data values passed for the + control parameters. + +* All /other/ calls to `inline_generic_eq_type_x` go via + generic_eq_type_x = inline_generic_eq_type_x + {-# NOINLNE generic_eq_type_x #-} + The idea is that all calls to `generic_eq_type_x` are specialised by the + RULES, so this NOINLINE version is seldom, if ever, actually called. + +* For each of specialised copy of `inline_generic_eq_type_x, there is a + corresponding rewrite RULE that rewrites a call to (generic_eq_type_x args) + into the appropriate specialied version. + +See #19226. +-} + +-- | This flag controls whether we expand synonyms during comparison +data SynFlag = ExpandSynonyms | KeepSynonyms + +eq_type_expand_respect, eq_type_expand_ignore, eq_type_keep_respect + :: Type -> Type -> Bool +eq_type_expand_respect_x, eq_type_expand_ignore_x, eq_type_keep_respect_x + :: RnEnv2 -> Type -> Type -> Bool + +eq_type_expand_respect = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing +eq_type_expand_respect_x env = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env) +eq_type_expand_ignore = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities Nothing +eq_type_expand_ignore_x env = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities (Just env) +eq_type_keep_respect = inline_generic_eq_type_x KeepSynonyms RespectMultiplicities Nothing +eq_type_keep_respect_x env = inline_generic_eq_type_x KeepSynonyms RespectMultiplicities (Just env) + +{-# RULES +"eqType1" generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing + = eq_type_expand_respect +"eqType2" forall env. generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env) + = eq_type_expand_respect_x env +"eqType3" generic_eq_type_x ExpandSynonyms IgnoreMultiplicities Nothing + = eq_type_expand_ignore +"eqType4" forall env. generic_eq_type_x ExpandSynonyms IgnoreMultiplicities (Just env) + = eq_type_expand_ignore_x env +"eqType5" generic_eq_type_x KeepSynonyms RespectMultiplicities Nothing + = eq_type_keep_respect +"eqType6" forall env. generic_eq_type_x KeepSynonyms RespectMultiplicities (Just env) + = eq_type_keep_respect_x env + #-} + +-- --------------------------------------------------------------- +-- | Real worker for 'eqType'. No kind check! +-- Inline it at the (handful of local) call sites +-- The "generic" bit refers to the flag paramerisation +-- See Note [Specialising type equality]. +generic_eq_type_x, inline_generic_eq_type_x + :: SynFlag -> MultiplicityFlag -> Maybe RnEnv2 -> Type -> Type -> Bool + +{-# NOINLINE generic_eq_type_x #-} +generic_eq_type_x = inline_generic_eq_type_x +-- See Note [Computing equality on types] in Type + +{-# INLINE inline_generic_eq_type_x #-} +-- This non-recursive function can inline at its (few) call sites. The +-- recursion goes via generic_eq_type_x, which is the loop-breaker. +inline_generic_eq_type_x syn_flag mult_flag mb_env + = \ t1 t2 -> t1 `seq` t2 `seq` + let go = generic_eq_type_x syn_flag mult_flag mb_env + -- Abbreviation for recursive calls + + gos [] [] = True + gos (t1:ts1) (t2:ts2) = go t1 t2 && gos ts1 ts2 + gos _ _ = False + + in case (t1,t2) of + _ | 1# <- reallyUnsafePtrEquality# t1 t2 -> True + -- See Note [Type comparisons using object pointer comparisons] + + (TyConApp tc1 tys1, TyConApp tc2 tys2) + | tc1 == tc2, not (isForgetfulSynTyCon tc1) -- See Note [Comparing type synonyms] + -> gos tys1 tys2 + + _ | ExpandSynonyms <- syn_flag, Just t1' <- coreView t1 -> go t1' t2 + | ExpandSynonyms <- syn_flag, Just t2' <- coreView t2 -> go t1 t2' + + (TyConApp tc1 ts1, TyConApp tc2 ts2) + | tc1 == tc2 -> gos ts1 ts2 + | otherwise -> False + + (TyVarTy tv1, TyVarTy tv2) + -> case mb_env of + Nothing -> tv1 == tv2 + Just env -> rnOccL env tv1 == rnOccR env tv2 + + (LitTy lit1, LitTy lit2) -> lit1 == lit2 + (CastTy t1' _, _) -> go t1' t2 -- Ignore casts + (_, CastTy t2' _) -> go t1 t2' -- Ignore casts + (CoercionTy {}, CoercionTy {}) -> True -- Ignore coercions + + -- Make sure we handle all FunTy cases since falling through to the + -- AppTy case means that tcSplitAppTyNoView_maybe may see an unzonked + -- kind variable, which causes things to blow up. + -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check + -- kinds here + (FunTy _ w1 arg1 res1, FunTy _ w2 arg2 res2) + -> fullEq go arg1 arg2 + && fullEq go res1 res2 + && (case mult_flag of + RespectMultiplicities -> go w1 w2 + IgnoreMultiplicities -> True) + + -- See Note [Equality on AppTys] in GHC.Core.Type + (AppTy s1 t1', _) + | Just (s2, t2') <- tcSplitAppTyNoView_maybe t2 + -> go s1 s2 && go t1' t2' + (_, AppTy s2 t2') + | Just (s1, t1') <- tcSplitAppTyNoView_maybe t1 + -> go s1 s2 && go t1' t2' + + (ForAllTy (Bndr tv1 vis1) body1, ForAllTy (Bndr tv2 vis2) body2) + -> case mb_env of + Nothing -> generic_eq_type_x syn_flag mult_flag + (Just (initRnEnv t1 t2)) t1 t2 + Just env + | vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality] + -> go (varType tv1) (varType tv2) -- Always do kind-check + && generic_eq_type_x syn_flag mult_flag + (Just (rnBndr2 env tv1 tv2)) body1 body2 + | otherwise + -> False + + _ -> False + +fullEq :: (Type -> Type -> Bool) -> Type -> Type -> Bool +-- Do "full equality" including the kind check +-- See Note [Casts and coercions in type comparision] +{-# INLINE fullEq #-} +fullEq eq ty1 ty2 + = case eq ty1 ty2 of + False -> False + True | hasCasts ty1 || hasCasts ty2 + -> eq (typeKind ty1) (typeKind ty2) + | otherwise + -> True + +hasCasts :: Type -> Bool +-- Fast, does not look deep, does not allocate +hasCasts (CastTy {}) = True +hasCasts (CoercionTy {}) = True +hasCasts (AppTy t1 t2) = hasCasts t1 || hasCasts t2 +hasCasts (ForAllTy _ ty) = hasCasts ty +hasCasts _ = False -- TyVarTy, TyConApp, FunTy, LitTy + + +{- ********************************************************************* +* * + Comparing ForAllTyFlags +* * +********************************************************************* -} + +-- | Do these denote the same level of visibility? 'Required' +-- arguments are visible, others are not. So this function +-- equates 'Specified' and 'Inferred'. Used for printing. +eqForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Bool +-- See Note [ForAllTy and type equality] +eqForAllVis Required Required = True +eqForAllVis (Invisible _) (Invisible _) = True +eqForAllVis _ _ = False + +-- | Do these denote the same level of visibility? 'Required' +-- arguments are visible, others are not. So this function +-- equates 'Specified' and 'Inferred'. Used for printing. +cmpForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Ordering +-- See Note [ForAllTy and type equality] +cmpForAllVis Required Required = EQ +cmpForAllVis Required (Invisible {}) = LT +cmpForAllVis (Invisible _) Required = GT +cmpForAllVis (Invisible _) (Invisible _) = EQ + + +{- Note [ForAllTy and type equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we compare (ForAllTy (Bndr tv1 vis1) ty1) + and (ForAllTy (Bndr tv2 vis2) ty2) +what should we do about `vis1` vs `vis2`? + +We had a long debate about this: see #22762 and GHC Proposal 558. +Here is the conclusion. + +* In Haskell, we really do want (forall a. ty) and (forall a -> ty) to be + distinct types, not interchangeable. The latter requires a type argument, + but the former does not. See GHC Proposal 558. + +* We /really/ do not want the typechecker and Core to have different notions of + equality. That is, we don't want `tcEqType` and `eqType` to differ. Why not? + Not so much because of code duplication but because it is virtually impossible + to cleave the two apart. Here is one particularly awkward code path: + The type checker calls `substTy`, which calls `mkAppTy`, + which calls `mkCastTy`, which calls `isReflexiveCo`, which calls `eqType`. + +* Moreover the resolution of the TYPE vs CONSTRAINT story was to make the + typechecker and Core have a single notion of equality. + +* So in GHC: + - `tcEqType` and `eqType` implement the same equality + - (forall a. ty) and (forall a -> ty) are distinct types in both Core and typechecker + - That is, both `eqType` and `tcEqType` distinguish them. + +* But /at representational role/ we can relate the types. That is, + (forall a. ty) ~R (forall a -> ty) + After all, since types are erased, they are represented the same way. + See Note [ForAllCo] and the typing rule for ForAllCo given there + +* What about (forall a. ty) and (forall {a}. ty)? See Note [Comparing visibility]. + +Note [Comparing visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are sure that we want to distinguish (forall a. ty) and (forall a -> ty); see +Note [ForAllTy and type equality]. But we have /three/ settings for the ForAllTyFlag: + * Specified: forall a. ty + * Inferred: forall {a}. ty + * Required: forall a -> ty + +We could (and perhaps should) distinguish all three. But for now we distinguish +Required from Specified/Inferred, and ignore the distinction between Specified +and Inferred. + +The answer doesn't matter too much, provided we are consistent. And we are consistent +because we always compare ForAllTyFlags with + * `eqForAllVis` + * `cmpForAllVis`. +(You can only really check this by inspecting all pattern matches on ForAllTyFlags.) +So if we change the decision, we just need to change those functions. + +Why don't we distinguish all three? Should GHC type-check the following program +(adapted from #15740)? + + {-# LANGUAGE PolyKinds, ... #-} + data D a + type family F :: forall k. k -> Type + type instance F = D + +Due to the way F is declared, any instance of F must have a right-hand side +whose kind is equal to `forall k. k -> Type`. The kind of D is +`forall {k}. k -> Type`, which is very close, but technically uses distinct +Core: + + ----------------------------------------------------------- + | Source Haskell | Core | + ----------------------------------------------------------- + | forall k. <...> | ForAllTy (Bndr k Specified) (<...>) | + | forall {k}. <...> | ForAllTy (Bndr k Inferred) (<...>) | + ----------------------------------------------------------- + +We could deem these kinds to be unequal, but that would imply rejecting +programs like the one above. Whether a kind variable binder ends up being +specified or inferred can be somewhat subtle, however, especially for kinds +that aren't explicitly written out in the source code (like in D above). + +For now, we decide + + the specified/inferred status of an invisible type variable binder + does not affect GHC's notion of equality. + +That is, we have the following: + + -------------------------------------------------- + | Type 1 | Type 2 | Equal? | + --------------------|----------------------------- + | forall k. <...> | forall k. <...> | Yes | + | | forall {k}. <...> | Yes | + | | forall k -> <...> | No | + -------------------------------------------------- + | forall {k}. <...> | forall k. <...> | Yes | + | | forall {k}. <...> | Yes | + | | forall k -> <...> | No | + -------------------------------------------------- + | forall k -> <...> | forall k. <...> | No | + | | forall {k}. <...> | No | + | | forall k -> <...> | Yes | + -------------------------------------------------- + +Examples: T16946, T15079. + +Historical Note [Typechecker equality vs definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes some history, in case there are vestiges of this +history lying around in the code. + +Summary: prior to summer 2022, GHC had have two notions of equality +over Core types. But now there is only one: definitional equality, +or just equality for short. + +The old setup was: + +* Definitional equality, as implemented by GHC.Core.Type.eqType. + See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. + +* Typechecker equality, as implemented by tcEqType. + GHC.Tc.Solver.Equality.canonicaliseEquality also respects typechecker equality. + +Typechecker equality implied definitional equality: if two types are equal +according to typechecker equality, then they are also equal according to +definitional equality. The converse is not always true, as typechecker equality +is more finer-grained than definitional equality in two places: + +* Constraint vs Type. Definitional equality equated Type and + Constraint, but typechecker treats them as distinct types. + +* Unlike definitional equality, which does not care about the ForAllTyFlag of a + ForAllTy, typechecker equality treats Required type variable binders as + distinct from Invisible type variable binders. + See Note [ForAllTy and type equality] + + +************************************************************************ +* * + Comparison for types + + Not so heavily used, less carefully optimised +* * +************************************************************************ + +-- Now here comes the real worker + +Note [nonDetCmpType nondeterminism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX +uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for +ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, +comparing type variables is nondeterministic, note the call to nonDetCmpVar in +nonDetCmpTypeX. +See Note [Unique Determinism] for more details. +-} + +nonDetCmpType :: Type -> Type -> Ordering +{-# INLINE nonDetCmpType #-} +nonDetCmpType !t1 !t2 + -- See Note [Type comparisons using object pointer comparisons] + | 1# <- reallyUnsafePtrEquality# t1 t2 + = EQ +nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 + = EQ +nonDetCmpType t1 t2 + -- we know k1 and k2 have the same kind, because they both have kind *. + = nonDetCmpTypeX rn_env t1 t2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) + +-- | An ordering relation between two 'Type's (known below as @t1 :: k1@ +-- and @t2 :: k2@) +data TypeOrdering = TLT -- ^ @t1 < t2@ + | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, + -- therefore we can conclude @k1 ~ k2@ + | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so + -- they may differ in kind. + | TGT -- ^ @t1 > t2@ + deriving (Eq, Ord, Enum, Bounded) + +nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse + -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + -- See Note [Computing equality on types] + -- Always respects multiplicities, unlike eqType +nonDetCmpTypeX env orig_t1 orig_t2 = + case go env orig_t1 orig_t2 of + -- If there are casts then we also need to do a comparison of + -- the kinds of the types being compared + TEQX -> toOrdering $ go env k1 k2 + ty_ordering -> toOrdering ty_ordering + where + k1 = typeKind orig_t1 + k2 = typeKind orig_t2 + + toOrdering :: TypeOrdering -> Ordering + toOrdering TLT = LT + toOrdering TEQ = EQ + toOrdering TEQX = EQ + toOrdering TGT = GT + + liftOrdering :: Ordering -> TypeOrdering + liftOrdering LT = TLT + liftOrdering EQ = TEQ + liftOrdering GT = TGT + + thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering + thenCmpTy TEQ rel = rel + thenCmpTy TEQX rel = hasCast rel + thenCmpTy rel _ = rel + + hasCast :: TypeOrdering -> TypeOrdering + hasCast TEQ = TEQX + hasCast rel = rel + + -- Returns both the resulting ordering relation between + -- the two types and whether either contains a cast. + go :: RnEnv2 -> Type -> Type -> TypeOrdering + + go _ (TyConApp tc1 []) (TyConApp tc2 []) + | tc1 == tc2 + = TEQ -- See Note [Comparing type synonyms] + + go env t1 t2 + | Just t1' <- coreView t1 = go env t1' t2 + | Just t2' <- coreView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) + = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 + go env (ForAllTy (Bndr tv1 vis1) t1) (ForAllTy (Bndr tv2 vis2) t2) + = liftOrdering (vis1 `cmpForAllVis` vis2) -- See Note [ForAllTy and type equality] + `thenCmpTy` go env (varType tv1) (varType tv2) + `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 + + -- See Note [Equality on AppTys] + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- splitAppTyNoView_maybe ty2 + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- splitAppTyNoView_maybe ty1 + = go env s1 s2 `thenCmpTy` go env t1 t2 + + go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) + -- NB: nonDepCmpTypeX does the kind check requested by + -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep + = liftOrdering (nonDetCmpTypeX env s1 s2 S.<> nonDetCmpTypeX env t1 t2) + `thenCmpTy` go env w1 w2 + -- Comparing multiplicities last because the test is usually true + + go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) + = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 + + go _ (LitTy l1) (LitTy l2) = liftOrdering (nonDetCmpTyLit l1 l2) + go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 + go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 + + go _ (CoercionTy {}) (CoercionTy {}) = TEQ + + -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy + go _ ty1 ty2 + = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) + where get_rank :: Type -> Int + get_rank (CastTy {}) + = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) + get_rank (TyVarTy {}) = 0 + get_rank (CoercionTy {}) = 1 + get_rank (AppTy {}) = 3 + get_rank (LitTy {}) = 4 + get_rank (TyConApp {}) = 5 + get_rank (FunTy {}) = 6 + get_rank (ForAllTy {}) = 7 + + gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering + gos _ [] [] = TEQ + gos _ [] _ = TLT + gos _ _ [] = TGT + gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 + + +------------- +-- | Compare two 'TyCon's. +-- See Note [nonDetCmpType nondeterminism] +nonDetCmpTc :: TyCon -> TyCon -> Ordering +nonDetCmpTc tc1 tc2 + = u1 `nonDetCmpUnique` u2 + where + u1 = tyConUnique tc1 + u2 = tyConUnique tc2 + + +{- ********************************************************************* +* * + mayLookIdentical +* * +********************************************************************* -} + +mayLookIdentical :: Type -> Type -> Bool +-- | Returns True if the /visible/ part of the types +-- might look equal, even if they are really unequal (in the invisible bits) +-- +-- This function is very similar to tc_eq_type but it is much more +-- heuristic. Notably, it is always safe to return True, even with types +-- that might (in truth) be unequal -- this affects error messages only +-- (Originally this test was done by eqType with an extra flag, but the result +-- was hard to understand.) +mayLookIdentical orig_ty1 orig_ty2 + = go orig_env orig_ty1 orig_ty2 + where + orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] + + go :: RnEnv2 -> Type -> Type -> Bool + + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) + | tc1 == tc2, not (isForgetfulSynTyCon tc1) -- See Note [Comparing type synonyms] + = gos env (tyConBinders tc1) ts1 ts2 + + go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2 + go env t1 t2 | Just t2' <- coreView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 + go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2 + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = True + + go env (ForAllTy (Bndr tv1 vis1) ty1) + (ForAllTy (Bndr tv2 vis2) ty2) + = vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality] + && go (rnBndr2 env tv1 tv2) ty1 ty2 + -- Visible stuff only: ignore kinds of binders + + -- If we have (forall (r::RunTimeRep). ty1 ~ blah) then respond + -- with True. Reason: the type pretty-printer defaults RuntimeRep + -- foralls (see Ghc.Iface.Type.hideNonStandardTypes). That can make, + -- say (forall r. TYPE r -> Type) into (Type -> Type), so it looks the + -- same as a very different type (#24553). By responding True, we + -- tell GHC (see calls of mayLookIdentical) to display without defaulting. + -- See Note [Showing invisible bits of types in error messages] + -- in GHC.Tc.Errors.Ppr + go _ (ForAllTy b _) _ | isDefaultableBndr b = True + go _ _ (ForAllTy b _) | isDefaultableBndr b = True + + go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) + = go env arg1 arg2 && go env res1 res2 && go env w1 w2 + -- Visible stuff only: ignore agg kinds + + -- See Note [Equality on AppTys] in GHC.Core.Type + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2 + = go env s1 s2 && go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1 + = go env s1 s2 && go env t1 t2 + + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) + = tc1 == tc2 && gos env (tyConBinders tc1) ts1 ts2 + + go _ _ _ = False + + gos :: RnEnv2 -> [TyConBinder] -> [Type] -> [Type] -> Bool + gos _ _ [] [] = True + gos env bs (t1:ts1) (t2:ts2) + | (invisible, bs') <- case bs of + [] -> (False, []) + (b:bs) -> (isInvisibleTyConBinder b, bs) + = (invisible || go env t1 t2) && gos env bs' ts1 ts2 + + gos _ _ _ _ = False + + +isDefaultableBndr :: ForAllTyBinder -> Bool +-- This function should line up with the defaulting done +-- by GHC.Iface.Type.defaultIfaceTyVarsOfKind +-- See Note [Showing invisible bits of types in error messages] +-- in GHC.Tc.Errors.Ppr +isDefaultableBndr (Bndr tv vis) + = isInvisibleForAllTyFlag vis && is_defaultable (tyVarKind tv) + where + is_defaultable ki = isLevityTy ki || isRuntimeRepTy ki || isMultiplicityTy ki + diff --git a/GHC/Core/TyCo/FVs.hs b/GHC/Core/TyCo/FVs.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/FVs.hs @@ -0,0 +1,1264 @@ +{-# LANGUAGE MultiWayIf #-} + +module GHC.Core.TyCo.FVs + ( shallowTyCoVarsOfType, shallowTyCoVarsOfTypes, + tyCoVarsOfType, tyCoVarsOfTypes, + tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, + + tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoFVsOfType, tyCoVarsOfTypeList, + tyCoFVsOfTypes, tyCoVarsOfTypesList, + deepTcvFolder, + + shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv, + + shallowTyCoVarsOfCo, shallowTyCoVarsOfCos, + tyCoVarsOfCo, tyCoVarsOfCos, tyCoVarsOfMCo, + coVarsOfType, coVarsOfTypes, + coVarsOfCo, coVarsOfCos, + tyCoVarsOfCoDSet, + tyCoFVsOfCo, tyCoFVsOfCos, + tyCoVarsOfCoList, + coVarsOfCoDSet, coVarsOfCosDSet, + + almostDevoidCoVarOfCo, + + -- Injective free vars + injectiveVarsOfType, injectiveVarsOfTypes, isInjectiveInType, + invisibleVarsOfType, invisibleVarsOfTypes, + + -- Any and No Free vars + anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo, + noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, + + -- * Free type constructors + tyConsOfType, tyConsOfTypes, + + -- * Free vars with visible/invisible separate + visVarsOfTypes, visVarsOfType, + + -- * Occurrence-check expansion + occCheckExpand, + + -- * Closing over kinds + closeOverKindsDSet, closeOverKindsList, + closeOverKinds, + + -- * Raw materials + Endo(..), runTyCoVars + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.Type( partitionInvisibleTypes, coreView, rewriterView ) +import {-# SOURCE #-} GHC.Core.Coercion( coercionLKind ) + +import GHC.Builtin.Types.Prim( funTyFlagTyCon ) + +import Data.Monoid as DM ( Any(..) ) +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom( CoAxiomRule(..), BuiltInFamRewrite(..), coAxiomTyCon ) +import GHC.Utils.FV + +import GHC.Types.Var +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set + +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Utils.Misc +import GHC.Data.Pair + +import Data.Semigroup + +{- +%************************************************************************ +%* * + Free variables of types and coercions +%* * +%************************************************************************ +-} + +{- Note [Shallow and deep free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Definitions + +* Shallow free variables of a type: the variables + affected by substitution. Specifically, the (TyVarTy tv) + and (CoVar cv) that appear + - In the type and coercions appearing in the type + - In shallow free variables of the kind of a Forall binder + but NOT in the kind of the /occurrences/ of a type variable. + +* Deep free variables of a type: shallow free variables, plus + the deep free variables of the kinds of those variables. + That is, deepFVs( t ) = closeOverKinds( shallowFVs( t ) ) + +Examples: + + Type Shallow Deep + --------------------------------- + (a : (k:Type)) {a} {a,k} + forall (a:(k:Type)). a {k} {k} + (a:k->Type) (b:k) {a,b} {a,b,k} +-} + + +{- Note [Free variables of types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns +a VarSet that is closed over the types of its variables. More precisely, + if S = tyCoVarsOfType( t ) + and (a:k) is in S + then tyCoVarsOftype( k ) is a subset of S + +Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. + +We could /not/ close over the kinds of the variable occurrences, and +instead do so at call sites, but it seems that we always want to do +so, so it's easiest to do it here. + +It turns out that getting the free variables of types is performance critical, +so we profiled several versions, exploring different implementation strategies. + +1. Baseline version: uses FV naively. Essentially: + + tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty + + This is not nice, because FV introduces some overhead to implement + determinism, and through its "interesting var" function, neither of which + we need here, so they are a complete waste. + +2. UnionVarSet version: instead of reusing the FV-based code, we simply used + VarSets directly, trying to avoid the overhead of FV. E.g.: + + -- FV version: + tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c + + -- UnionVarSet version: + tyCoVarsOfType (AppTy fun arg) = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg) + + This looks deceptively similar, but while FV internally builds a list- and + set-generating function, the VarSet functions manipulate sets directly, and + the latter performs a lot worse than the naive FV version. + +3. Accumulator-style VarSet version: this is what we use now. We do use VarSet + as our data structure, but delegate the actual work to a new + ty_co_vars_of_... family of functions, which use accumulator style and the + "in-scope set" filter found in the internals of FV, but without the + determinism overhead. + +See #14880. + +Note [Closing over free variable kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over +free variable kinds. In previous GHC versions, this happened naively: whenever +we would encounter an occurrence of a free type variable, we would close over +its kind. This, however is wrong for two reasons (see #14880): + +1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then + we don't want to have to traverse k more than once. + +2. Correctness. Imagine we have forall k. b -> k, where b has + kind k, for some k bound in an outer scope. If we look at b's kind inside + the forall, we'll collect that k is free and then remove k from the set of + free variables. This is plain wrong. We must instead compute that b is free + and then conclude that b's kind is free. + +An obvious first approach is to move the closing-over-kinds from the +occurrences of a type variable to after finding the free vars - however, this +turns out to introduce performance regressions, and isn't even entirely +correct. + +In fact, it isn't even important *when* we close over kinds; what matters is +that we handle each type var exactly once, and that we do it in the right +context. + +So the next approach we tried was to use the "in-scope set" part of FV or the +equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to +say "don't bother with variables we have already closed over". This should work +fine in theory, but the code is complicated and doesn't perform well. + +But there is a simpler way, which is implemented here. Consider the two points +above: + +1. Efficiency: we now have an accumulator, so the second time we encounter 'a', + we'll ignore it, certainly not looking at its kind - this is why + pre-checking set membership before inserting ends up not only being faster, + but also being correct. + +2. Correctness: we have an "in-scope set" (I think we should call it it a + "bound-var set"), specifying variables that are bound by a forall in the type + we are traversing; we simply ignore these variables, certainly not looking at + their kind. + +So now consider: + + forall k. b -> k + +where b :: k->Type is free; but of course, it's a different k! When looking at +b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose +this is our first encounter with b; we want the free vars of its kind. But we +want to behave as if we took the free vars of its kind at the end; that is, +with no bound vars in scope. + +So the solution is easy. The old code was this: + + ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v) + +Now all we need to do is take the free vars of tyVarKind v *with an empty +bound-var set*, thus: + +ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v) + ^^^^^^^^^^^ + +And that's it. This works because a variable is either bound or free. If it is bound, +then we won't look at it at all. If it is free, then all the variables free in its +kind are free -- regardless of whether some local variable has the same Unique. +So if we're looking at a variable occurrence at all, then all variables in its +kind are free. + +Note [Free vars and synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When finding free variables we generally do not expand synonyms. So given + type T a = Int +the type (T [b]) will return `b` as a free variable, even though expanding the +synonym would get rid of it. Expanding synonyms might lead to types that look +ill-scoped; an alternative we have not explored. + +But see `occCheckExpand` in this module for a function that does, selectively, +expand synonyms to reduce free-var occurences. +-} + +{- ********************************************************************* +* * + Endo for free variables +* * +********************************************************************* -} + +{- Note [Accumulating parameter free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can use foldType to build an accumulating-parameter version of a +free-var finder, thus: + + fvs :: Type -> TyCoVarSet + fvs ty = appEndo (foldType folder ty) emptyVarSet + +Recall that + foldType :: TyCoFolder env a -> env -> Type -> a + + newtype Endo a = Endo (a -> a) -- In Data.Monoid + instance Monoid a => Monoid (Endo a) where + (Endo f) `mappend` (Endo g) = Endo (f.g) + + appEndo :: Endo a -> a -> a + appEndo (Endo f) x = f x + +So `mappend` for Endos is just function composition. + +It's very important that, after optimisation, we end up with +* an arity-three function +* that is strict in the accumulator + + fvs env (TyVarTy v) acc + | v `elemVarSet` env = acc + | v `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` v + fvs env (AppTy t1 t2) = fvs env t1 (fvs env t2 acc) + ... + +The "strict in the accumulator" part is to ensure that in the +AppTy equation we don't build a thunk for (fvs env t2 acc). + +The optimiser does do all this, but not very robustly. It depends +critically on the basic arity-2 function not being exported, so that +all its calls are visibly to three arguments. This analysis is +done by the Call Arity pass. + +TL;DR: check this regularly! +-} + +runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet +{-# INLINE runTyCoVars #-} +runTyCoVars f = appEndo f emptyVarSet + +{- ********************************************************************* +* * + Deep free variables + See Note [Shallow and deep free variables] +* * +********************************************************************* -} + +tyCoVarsOfType :: Type -> TyCoVarSet +-- The "deep" TyCoVars of the the type +tyCoVarsOfType ty = runTyCoVars (deep_ty ty) +-- Alternative: +-- tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty) + +tyCoVarsOfTypes :: [Type] -> TyCoVarSet +-- The "deep" TyCoVars of the the type +tyCoVarsOfTypes tys = runTyCoVars (deep_tys tys) +-- Alternative: +-- tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys) + +tyCoVarsOfCo :: Coercion -> TyCoVarSet +-- The "deep" TyCoVars of the the coercion +-- See Note [Free variables of types] +tyCoVarsOfCo co = runTyCoVars (deep_co co) + +tyCoVarsOfMCo :: MCoercion -> TyCoVarSet +tyCoVarsOfMCo MRefl = emptyVarSet +tyCoVarsOfMCo (MCo co) = tyCoVarsOfCo co + +tyCoVarsOfCos :: [Coercion] -> TyCoVarSet +tyCoVarsOfCos cos = runTyCoVars (deep_cos cos) + +deep_ty :: Type -> Endo TyCoVarSet +deep_tys :: [Type] -> Endo TyCoVarSet +deep_co :: Coercion -> Endo TyCoVarSet +deep_cos :: [Coercion] -> Endo TyCoVarSet +(deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet + +deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +deepTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = appEndo (deep_ty (varType v)) $ + acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole is hole = do_tcv is (coHoleCoVar hole) + -- See Note [CoercionHoles and coercion free variables] + -- in GHC.Core.TyCo.Rep + +{- ********************************************************************* +* * + Shallow free variables + See Note [Shallow and deep free variables] +* * +********************************************************************* -} + + +shallowTyCoVarsOfType :: Type -> TyCoVarSet +-- See Note [Free variables of types] +shallowTyCoVarsOfType ty = runTyCoVars (shallow_ty ty) + +shallowTyCoVarsOfTypes :: [Type] -> TyCoVarSet +shallowTyCoVarsOfTypes tys = runTyCoVars (shallow_tys tys) + +shallowTyCoVarsOfCo :: Coercion -> TyCoVarSet +shallowTyCoVarsOfCo co = runTyCoVars (shallow_co co) + +shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet +shallowTyCoVarsOfCos cos = runTyCoVars (shallow_cos cos) + +-- | Returns free variables of types, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. +shallowTyCoVarsOfTyVarEnv :: TyVarEnv Type -> TyCoVarSet +-- See Note [Free variables of types] +shallowTyCoVarsOfTyVarEnv tys = shallowTyCoVarsOfTypes (nonDetEltsUFM tys) + -- It's OK to use nonDetEltsUFM here because we immediately + -- forget the ordering by returning a set + +shallowTyCoVarsOfCoVarEnv :: CoVarEnv Coercion -> TyCoVarSet +shallowTyCoVarsOfCoVarEnv cos = shallowTyCoVarsOfCos (nonDetEltsUFM cos) + -- It's OK to use nonDetEltsUFM here because we immediately + -- forget the ordering by returning a set + +shallow_ty :: Type -> Endo TyCoVarSet +shallow_tys :: [Type] -> Endo TyCoVarSet +shallow_co :: Coercion -> Endo TyCoVarSet +shallow_cos :: [Coercion] -> Endo TyCoVarSet +(shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet + +shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +shallowTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole _ _ = mempty -- Ignore coercion holes + + +{- ********************************************************************* +* * + Free coercion variables +* * +********************************************************************* -} + + +{- Note [Finding free coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here we are only interested in the free /coercion/ variables. +We can achieve this through a slightly different TyCo folder. + +Notice that we look deeply, into kinds. + +See #14880. +-} + +-- See Note [Finding free coercion variables] +coVarsOfType :: Type -> CoVarSet +coVarsOfTypes :: [Type] -> CoVarSet +coVarsOfCo :: Coercion -> CoVarSet +coVarsOfCos :: [Coercion] -> CoVarSet + +coVarsOfType ty = runTyCoVars (deep_cv_ty ty) +coVarsOfTypes tys = runTyCoVars (deep_cv_tys tys) +coVarsOfCo co = runTyCoVars (deep_cv_co co) +coVarsOfCos cos = runTyCoVars (deep_cv_cos cos) + +deep_cv_ty :: Type -> Endo CoVarSet +deep_cv_tys :: [Type] -> Endo CoVarSet +deep_cv_co :: Coercion -> Endo CoVarSet +deep_cv_cos :: [Coercion] -> Endo CoVarSet +(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet + +deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet) +deepCoVarFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tyvar, tcf_covar = do_covar + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tyvar _ _ = mempty + -- This do_tyvar means we won't see any CoVars in this + -- TyVar's kind. This may be wrong; but it's the way it's + -- always been. And its awkward to change, because + -- the tyvar won't end up in the accumulator, so + -- we'd look repeatedly. Blargh. + + do_covar is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = appEndo (deep_cv_ty (varType v)) $ + acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole is hole = do_covar is (coHoleCoVar hole) + -- See Note [CoercionHoles and coercion free variables] + -- in GHC.Core.TyCo.Rep + +------- Same again, but for DCoVarSet ---------- +-- But this time the free vars are shallow + +coVarsOfCosDSet :: [Coercion] -> DCoVarSet +coVarsOfCosDSet cos = fvDVarSetSome isCoVar (tyCoFVsOfCos cos) + +coVarsOfCoDSet :: Coercion -> DCoVarSet +coVarsOfCoDSet co = fvDVarSetSome isCoVar (tyCoFVsOfCo co) + + +{- ********************************************************************* +* * + Closing over kinds +* * +********************************************************************* -} + +------------- Closing over kinds ----------------- + +closeOverKinds :: TyCoVarSet -> TyCoVarSet +-- For each element of the input set, +-- add the deep free variables of its kind +closeOverKinds vs = nonDetStrictFoldVarSet do_one vs vs + where + do_one v acc = appEndo (deep_ty (varType v)) acc + +{- --------------- Alternative version 1 (using FV) ------------ +closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet +-} + +{- ---------------- Alternative version 2 ------------- + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. +closeOverKinds :: TyCoVarSet -> TyCoVarSet +closeOverKinds vs + = go vs vs + where + go :: VarSet -- Work list + -> VarSet -- Accumulator, always a superset of wl + -> VarSet + go wl acc + | isEmptyVarSet wl = acc + | otherwise = go wl_kvs (acc `unionVarSet` wl_kvs) + where + k v inner_acc = ty_co_vars_of_type (varType v) acc inner_acc + wl_kvs = nonDetFoldVarSet k emptyVarSet wl + -- wl_kvs = union of shallow free vars of the kinds of wl + -- but don't bother to collect vars in acc + +-} + +{- ---------------- Alternative version 3 ------------- +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. +closeOverKinds :: TyVarSet -> TyVarSet +closeOverKinds vs = close_over_kinds vs emptyVarSet + + +close_over_kinds :: TyVarSet -- Work list + -> TyVarSet -- Accumulator + -> TyVarSet +-- Precondition: in any call (close_over_kinds wl acc) +-- for every tv in acc, the shallow kind-vars of tv +-- are either in the work list wl, or in acc +-- Postcondition: result is the deep free vars of (wl `union` acc) +close_over_kinds wl acc + = nonDetFoldVarSet do_one acc wl + where + do_one :: Var -> TyVarSet -> TyVarSet + -- (do_one v acc) adds v and its deep free-vars to acc + do_one v acc | v `elemVarSet` acc + = acc + | otherwise + = close_over_kinds (shallowTyCoVarsOfType (varType v)) $ + acc `extendVarSet` v +-} + + +{- ********************************************************************* +* * + The FV versions return deterministic results +* * +********************************************************************* -} + +-- | Given a list of tyvars returns a deterministic FV computation that +-- returns the given tyvars with the kind variables free in the kinds of the +-- given tyvars. +closeOverKindsFV :: [TyVar] -> FV +closeOverKindsFV tvs = + mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministically ordered list. +closeOverKindsList :: [TyVar] -> [TyVar] +closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministic set. +closeOverKindsDSet :: DTyVarSet -> DTyVarSet +closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems + +-- | `tyCoFVsOfType` that returns free variables of a type in a deterministic +-- set. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty + +-- | `tyCoFVsOfType` that returns free variables of a type in deterministic +-- order. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfTypeList :: Type -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty + +-- | Returns free variables of types, including kind variables as +-- a deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys + +-- | Returns free variables of types, including kind variables as +-- a deterministically ordered list. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesList :: [Type] -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys + +-- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`. +-- The previous implementation used `unionVarSet` which is O(n+m) and can +-- make the function quadratic. +-- It's exported, so that it can be composed with +-- other functions that compute free variables. +-- See Note [FV naming conventions] in "GHC.Utils.FV". +-- +-- Eta-expanded because that makes it run faster (apparently) +-- See Note [FV eta expansion] in "GHC.Utils.FV" for explanation. +tyCoFVsOfType :: Type -> FV +-- See Note [Free variables of types] +tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) + | not (f v) = (acc_list, acc_set) + | v `elemVarSet` bound_vars = (acc_list, acc_set) + | v `elemVarSet` acc_set = (acc_list, acc_set) + | otherwise = tyCoFVsOfType (tyVarKind v) f + emptyVarSet -- See Note [Closing over free variable kinds] + (v:acc_list, extendVarSet acc_set v) +tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc + -- See Note [Free vars and synonyms] +tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc +tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc +tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc = (tyCoFVsOfType w `unionFV` tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc +tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc +tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc +tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc + +tyCoFVsBndr :: ForAllTyBinder -> FV -> FV +-- Free vars of (forall b. ) +tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs + +tyCoFVsVarBndrs :: [Var] -> FV -> FV +tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars + +tyCoFVsVarBndr :: Var -> FV -> FV +tyCoFVsVarBndr var fvs + = tyCoFVsOfType (varType var) -- Free vars of its type/kind + `unionFV` delFV var fvs -- Delete it from the thing-inside + +tyCoFVsOfTypes :: [Type] -> FV +-- See Note [Free variables of types] +tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc +tyCoFVsOfTypes [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +-- | Get a deterministic set of the vars free in a coercion +tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co + +tyCoVarsOfCoList :: Coercion -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co + +tyCoFVsOfMCo :: MCoercion -> FV +tyCoFVsOfMCo MRefl = emptyFV +tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co + +tyCoFVsOfCo :: Coercion -> FV +-- Extracts type and coercion variables from a coercion +-- See Note [Free variables of types] +tyCoFVsOfCo (Refl ty) fv_cand in_scope acc + = tyCoFVsOfType ty fv_cand in_scope acc +tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc + = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc +tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc + = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc +tyCoFVsOfCo (ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = co }) fv_cand in_scope acc + = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc +tyCoFVsOfCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) fv_cand in_scope acc + = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2 `unionFV` tyCoFVsOfCo w) fv_cand in_scope acc +tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc + = tyCoFVsOfCoVar v fv_cand in_scope acc +tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc + = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc + -- See Note [CoercionHoles and coercion free variables] +tyCoFVsOfCo (AxiomCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc +tyCoFVsOfCo (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps}) fv_cand in_scope acc + = (tyCoFVsOfCos deps `unionFV` tyCoFVsOfType t1 + `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc +tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc +tyCoFVsOfCo (SelCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc +tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc + +tyCoFVsOfCoVar :: CoVar -> FV +tyCoFVsOfCoVar v fv_cand in_scope acc + = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc + +tyCoFVsOfCos :: [Coercion] -> FV +tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc + + +----- Whether a covar is /Almost Devoid/ in a type or coercion ---- + +-- | Given a covar and a coercion, returns True if covar is almost devoid in +-- the coercion. That is, covar can only appear in Refl and GRefl. +-- See (FC6) in Note [ForAllCo] in "GHC.Core.TyCo.Rep" +almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool +almostDevoidCoVarOfCo cv co = + almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool +almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and +almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into + -- the coercions +almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv + = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (AppCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_co arg cv +almost_devoid_co_var_of_co (ForAllCo { fco_tcv = v, fco_kind = kind_co, fco_body = co }) cv + = almost_devoid_co_var_of_co kind_co cv + && (v == cv || almost_devoid_co_var_of_co co cv) +almost_devoid_co_var_of_co (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) cv + = almost_devoid_co_var_of_co w cv + && almost_devoid_co_var_of_co co1 cv + && almost_devoid_co_var_of_co co2 cv +almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv +almost_devoid_co_var_of_co (HoleCo h) cv = (coHoleCoVar h) /= cv +almost_devoid_co_var_of_co (AxiomCo _ cs) cv + = almost_devoid_co_var_of_cos cs cv +almost_devoid_co_var_of_co (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps }) cv + = almost_devoid_co_var_of_cos deps cv + && almost_devoid_co_var_of_type t1 cv + && almost_devoid_co_var_of_type t2 cv +almost_devoid_co_var_of_co (SymCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (TransCo co1 co2) cv + = almost_devoid_co_var_of_co co1 cv + && almost_devoid_co_var_of_co co2 cv +almost_devoid_co_var_of_co (SelCo _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (LRCo _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (InstCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_co arg cv +almost_devoid_co_var_of_co (KindCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (SubCo co) cv + = almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool +almost_devoid_co_var_of_cos [] _ = True +almost_devoid_co_var_of_cos (co:cos) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_cos cos cv + +almost_devoid_co_var_of_type :: Type -> CoVar -> Bool +almost_devoid_co_var_of_type (TyVarTy _) _ = True +almost_devoid_co_var_of_type (TyConApp _ tys) cv + = almost_devoid_co_var_of_types tys cv +almost_devoid_co_var_of_type (LitTy {}) _ = True +almost_devoid_co_var_of_type (AppTy fun arg) cv + = almost_devoid_co_var_of_type fun cv + && almost_devoid_co_var_of_type arg cv +almost_devoid_co_var_of_type (FunTy _ w arg res) cv + = almost_devoid_co_var_of_type w cv + && almost_devoid_co_var_of_type arg cv + && almost_devoid_co_var_of_type res cv +almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv + = almost_devoid_co_var_of_type (varType v) cv + && (v == cv || almost_devoid_co_var_of_type ty cv) +almost_devoid_co_var_of_type (CastTy ty co) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_type (CoercionTy co) cv + = almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool +almost_devoid_co_var_of_types [] _ = True +almost_devoid_co_var_of_types (ty:tys) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_types tys cv + + + +{- +%************************************************************************ +%* * + Free tyvars, but with visible/invisible info +%* * +%************************************************************************ + +-} +-- | Retrieve the free variables in this type, splitting them based +-- on whether they are used visibly or invisibly. Invisible ones come +-- first. +visVarsOfType :: Type -> Pair TyCoVarSet +visVarsOfType orig_ty = Pair invis_vars vis_vars + where + Pair invis_vars1 vis_vars = go orig_ty + invis_vars = invis_vars1 `minusVarSet` vis_vars + + go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) + go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyConApp tc tys) = go_tc tc tys + go (FunTy _ w t1 t2) = go w `mappend` go t1 `mappend` go t2 + go (ForAllTy (Bndr tv _) ty) + = ((`delVarSet` tv) <$> go ty) `mappend` + (invisible (tyCoVarsOfType $ varType tv)) + go (LitTy {}) = mempty + go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) + go (CoercionTy co) = invisible $ tyCoVarsOfCo co + + invisible vs = Pair vs emptyVarSet + + go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in + invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis + +visVarsOfTypes :: [Type] -> Pair TyCoVarSet +visVarsOfTypes = foldMap visVarsOfType + + +{- ********************************************************************* +* * + Injective free vars +* * +********************************************************************* -} + +isInjectiveInType :: TyVar -> Type -> Bool +-- True <=> tv /definitely/ appears injectively in ty +-- A bit more efficient that (tv `elemVarSet` injectiveTyVarsOfType ty) +-- Ignore occurrence in coercions, and even in injective positions of +-- type families. +isInjectiveInType tv ty + = go ty + where + go ty | Just ty' <- rewriterView ty = go ty' + go (TyVarTy tv') = tv' == tv + go (AppTy f a) = go f || go a + go (FunTy _ w ty1 ty2) = go w || go ty1 || go ty2 + go (TyConApp tc tys) = go_tc tc tys + go (ForAllTy (Bndr tv' _) ty) = go (tyVarKind tv') + || (tv /= tv' && go ty) + go LitTy{} = False + go (CastTy ty _) = go ty + go CoercionTy{} = False + + go_tc tc tys | isTypeFamilyTyCon tc = False + | otherwise = any go tys + +-- | Returns the free variables of a 'Type' that are in injective positions. +-- Specifically, it finds the free variables while: +-- +-- * Expanding type synonyms +-- +-- * Ignoring the coercion in @(ty |> co)@ +-- +-- * Ignoring the non-injective fields of a 'TyConApp' +-- +-- +-- For example, if @F@ is a non-injective type family, then: +-- +-- @ +-- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c} +-- @ +-- +-- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@. +-- More formally, if +-- @a@ is in @'injectiveVarsOfType' ty@ +-- and @S1(ty) ~ S2(ty)@, +-- then @S1(a) ~ S2(a)@, +-- where @S1@ and @S2@ are arbitrary substitutions. +-- +-- See @Note [When does a tycon application need an explicit kind signature?]@. +injectiveVarsOfType :: Bool -- ^ Should we look under injective type families? + -- See Note [Coverage condition for injective type families] + -- in "GHC.Tc.Instance.Family". + -> Type -> FV +injectiveVarsOfType look_under_tfs = go + where + go ty | Just ty' <- rewriterView ty = go ty' + go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) + go (AppTy f a) = go f `unionFV` go a + go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2 + go (TyConApp tc tys) = go_tc tc tys + go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty) + go LitTy{} = emptyFV + go (CastTy ty _) = go ty + go CoercionTy{} = emptyFV + + go_tc tc tys + | isTypeFamilyTyCon tc + = if | look_under_tfs + , Injective flags <- tyConInjectivityInfo tc + -> mapUnionFV go $ + filterByList (flags ++ repeat True) tys + -- Oversaturated arguments to a tycon are + -- always injective, hence the repeat True + | otherwise -- No injectivity info for this type family + -> emptyFV + + | otherwise -- Data type, injective in all positions + = mapUnionFV go tys + +-- | Returns the free variables of a 'Type' that are in injective positions. +-- Specifically, it finds the free variables while: +-- +-- * Expanding type synonyms +-- +-- * Ignoring the coercion in @(ty |> co)@ +-- +-- * Ignoring the non-injective fields of a 'TyConApp' +-- +-- See @Note [When does a tycon application need an explicit kind signature?]@. +injectiveVarsOfTypes :: Bool -- ^ look under injective type families? + -- See Note [Coverage condition for injective type families] + -- in "GHC.Tc.Instance.Family". + -> [Type] -> FV +injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under_tfs) + + +{- ********************************************************************* +* * + Invisible vars +* * +********************************************************************* -} + + +-- | Returns the set of variables that are used invisibly anywhere within +-- the given type. A variable will be included even if it is used both visibly +-- and invisibly. An invisible use site includes: +-- * In the kind of a variable +-- * In the kind of a bound variable in a forall +-- * In a coercion +-- * In a Specified or Inferred argument to a function +-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" +invisibleVarsOfType :: Type -> FV +invisibleVarsOfType = go + where + go ty | Just ty' <- coreView ty + = go ty' + go (TyVarTy v) = go (tyVarKind v) + go (AppTy f a) = go f `unionFV` go a + go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2 + go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV` + invisibleVarsOfTypes visibles + where (invisibles, visibles) = partitionInvisibleTypes tc tys + go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty + go LitTy{} = emptyFV + go (CastTy ty co) = tyCoFVsOfCo co `unionFV` go ty + go (CoercionTy co) = tyCoFVsOfCo co + +-- | Like 'invisibleVarsOfType', but for many types. +invisibleVarsOfTypes :: [Type] -> FV +invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType + + +{- ********************************************************************* +* * + Any free vars +* * +********************************************************************* -} + +{-# INLINE afvFolder #-} -- so that specialization to (const True) works +afvFolder :: (TyCoVar -> Bool) -> TyCoFolder TyCoVarSet DM.Any +-- 'afvFolder' is short for "any-free-var folder", good for checking +-- if any free var of a type satisfies a predicate `check_fv` +afvFolder check_fv = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is tv = Any (not (tv `elemVarSet` is) && check_fv tv) + do_hole _ _ = Any False -- I'm unsure; probably never happens + do_bndr is tv _ = is `extendVarSet` tv + +anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool +anyFreeVarsOfType check_fv ty = DM.getAny (f ty) + where (f, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet + +anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool +anyFreeVarsOfTypes check_fv tys = DM.getAny (f tys) + where (_, f, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet + +anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool +anyFreeVarsOfCo check_fv co = DM.getAny (f co) + where (_, _, f, _) = foldTyCo (afvFolder check_fv) emptyVarSet + +noFreeVarsOfType :: Type -> Bool +noFreeVarsOfType ty = not $ DM.getAny (f ty) + where (f, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet + +noFreeVarsOfTypes :: [Type] -> Bool +noFreeVarsOfTypes tys = not $ DM.getAny (f tys) + where (_, f, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet + +noFreeVarsOfCo :: Coercion -> Bool +noFreeVarsOfCo co = not $ DM.getAny (f co) + where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet + + +{- +************************************************************************ +* * + Free type constructors +* * +************************************************************************ +-} + +{- Note [tyConsOfType] +~~~~~~~~~~~~~~~~~~~~~~ +It is slightly odd to find the TyCons of a type. Especially since, via a type +family reduction or axiom, a type that doesn't mention T might start to mention T. + +This function is used in only three places: +* In GHC.Tc.Validity.validDerivPred, when identifying "exotic" predicates. +* In GHC.Tc.Errors.Ppr.pprTcSolverReportMsg, when trying to print a helpful + error about overlapping instances +* In utils/dump-decls/Main.hs, an ill-documented module. + +None seem critical. Currently tyConsOfType looks inside coercions, but perhaps +it doesn't even need to do that. +-} + +-- | All type constructors occurring in the type; looking through type +-- synonyms, but not newtypes. +-- When it finds a Class, it returns the class TyCon. +tyConsOfType :: Type -> UniqSet TyCon +tyConsOfType ty + = go ty + where + go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy {}) = emptyUniqSet + go (LitTy {}) = emptyUniqSet + go (TyConApp tc tys) = go_tc tc `unionUniqSets` tyConsOfTypes tys + go (AppTy a b) = go a `unionUniqSets` go b + go (FunTy af w a b) = go w `unionUniqSets` + go a `unionUniqSets` go b + `unionUniqSets` go_tc (funTyFlagTyCon af) + go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) + go (CastTy ty co) = go ty `unionUniqSets` go_co co + go (CoercionTy co) = go_co co + + go_co (Refl ty) = go ty + go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco + go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args + go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (ForAllCo { fco_kind = kind_co, fco_body = co }) + = go_co kind_co `unionUniqSets` go_co co + go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r }) + = go_co m `unionUniqSets` go_co a `unionUniqSets` go_co r + go_co (AxiomCo ax args) = go_ax ax `unionUniqSets` go_cos args + go_co (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = cos }) + = go t1 `unionUniqSets` go t2 `unionUniqSets` go_cos cos + go_co (CoVarCo {}) = emptyUniqSet + go_co (HoleCo {}) = emptyUniqSet + go_co (SymCo co) = go_co co + go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 + go_co (SelCo _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + + go_mco MRefl = emptyUniqSet + go_mco (MCo co) = go_co co + + go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos + + go_tc tc = unitUniqSet tc + + go_ax (UnbranchedAxiom ax) = go_tc $ coAxiomTyCon ax + go_ax (BranchedAxiom ax _) = go_tc $ coAxiomTyCon ax + go_ax (BuiltInFamRew bif) = go_tc $ bifrw_fam_tc bif + go_ax (BuiltInFamInj {}) = emptyUniqSet -- A free-floating axiom + +tyConsOfTypes :: [Type] -> UniqSet TyCon +tyConsOfTypes tys = foldr (unionUniqSets . tyConsOfType) emptyUniqSet tys + +{- ********************************************************************** +* * + Occurs check expansion +%* * +%********************************************************************* -} + +{- Note [Occurs check expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid +of occurrences of tv outside type function arguments, if that is +possible; otherwise, it returns Nothing. + +For example, suppose we have + type F a b = [a] +Then + occCheckExpand b (F Int b) = Just [Int] +but + occCheckExpand a (F a Int) = Nothing + +We don't promise to do the absolute minimum amount of expanding +necessary, but we try not to do expansions we don't need to. We +prefer doing inner expansions first. For example, + type F a b = (a, Int, a, [a]) + type G b = Char +We have + occCheckExpand b (F (G b)) = Just (F Char) +even though we could also expand F to get rid of b. + +Note [Occurrence checking: look inside kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are considering unifying + (alpha :: *) ~ Int -> (beta :: alpha -> alpha) +This may be an error (what is that alpha doing inside beta's kind?), +but we must not make the mistake of actually unifying or we'll +build an infinite data structure. So when looking for occurrences +of alpha in the rhs, we must look in the kinds of type variables +that occur there. + +occCheckExpand tries to expand type synonyms to remove +unnecessary occurrences of a variable, and thereby get past an +occurs-check failure. This is good; but + we can't do it in the /kind/ of a variable /occurrence/ + +For example #18451 built an infinite type: + type Const a b = a + data SameKind :: k -> k -> Type + type T (k :: Const Type a) = forall (b :: k). SameKind a b + +We have + b :: k + k :: Const Type a + a :: k (must be same as b) + +So if we aren't careful, a's kind mentions a, which is bad. +And expanding an /occurrence/ of 'a' doesn't help, because the +/binding site/ is the master copy and all the occurrences should +match it. + +Here's a related example: + f :: forall a b (c :: Const Type b). Proxy '[a, c] + +The list means that 'a' gets the same kind as 'c'; but that +kind mentions 'b', so the binders are out of order. + +Bottom line: in occCheckExpand, do not expand inside the kinds +of occurrences. See bad_var_occ in occCheckExpand. And +see #18451 for more debate. +-} + +occCheckExpand :: [Var] -> Type -> Maybe Type +-- See Note [Occurs check expansion] +-- We may have needed to do some type synonym unfolding in order to +-- get rid of the variable (or forall), so we also return the unfolded +-- version of the type, which is guaranteed to be syntactically free +-- of the given type variable. If the type is already syntactically +-- free of the variable, then the same type is returned. +occCheckExpand vs_to_avoid ty + | null vs_to_avoid -- Efficient shortcut + = Just ty -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase + + | otherwise + = go (mkVarSet vs_to_avoid, emptyVarEnv) ty + where + go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type + -- The VarSet is the set of variables we are trying to avoid + -- The VarEnv carries mappings necessary + -- because of kind expansion + go (as, env) ty@(TyVarTy tv) + | Just tv' <- lookupVarEnv env tv = return (mkTyVarTy tv') + | bad_var_occ as tv = Nothing + | otherwise = return ty + + go _ ty@(LitTy {}) = return ty + go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (AppTy ty1' ty2') } + go cxt ty@(FunTy _ w ty1 ty2) + = do { w' <- go cxt w + ; ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (ty { ft_mult = w', ft_arg = ty1', ft_res = ty2' }) } + go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) + = do { ki' <- go cxt (varType tv) + ; let tv' = setVarType tv ki' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go (as', env') body_ty + ; return (ForAllTy (Bndr tv' vis) body') } + + -- For a type constructor application, first try expanding away the + -- offending variable from the arguments. If that doesn't work, next + -- see if the type constructor is a type synonym, and if so, expand + -- it and try again. + go cxt ty@(TyConApp tc tys) + = case mapM (go cxt) tys of + Just tys' -> return (TyConApp tc tys') + Nothing | Just ty' <- coreView ty -> go cxt ty' + | otherwise -> Nothing + -- Failing that, try to expand a synonym + + go cxt (CastTy ty co) = do { ty' <- go cxt ty + ; co' <- go_co cxt co + ; return (CastTy ty' co') } + go cxt (CoercionTy co) = do { co' <- go_co cxt co + ; return (CoercionTy co') } + + ------------------ + bad_var_occ :: VarSet -> Var -> Bool + -- Works for TyVar and CoVar + -- See Note [Occurrence checking: look inside kinds] + bad_var_occ vs_to_avoid v + = v `elemVarSet` vs_to_avoid + || tyCoVarsOfType (varType v) `intersectsVarSet` vs_to_avoid + + ------------------ + go_mco _ MRefl = return MRefl + go_mco ctx (MCo co) = MCo <$> go_co ctx co + + ------------------ + go_co cxt (Refl ty) = do { ty' <- go cxt ty + ; return (Refl ty') } + go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco + ; ty' <- go cxt ty + ; return (GRefl r ty' mco') } + -- Note: Coercions do not contain type synonyms + go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args + ; return (TyConAppCo r tc args') } + go_co cxt (AppCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (AppCo co' arg') } + go_co cxt (SymCo co) = do { co' <- go_co cxt co + ; return (SymCo co') } + go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; return (TransCo co1' co2') } + go_co cxt (SelCo n co) = do { co' <- go_co cxt co + ; return (SelCo n co') } + go_co cxt (LRCo lr co) = do { co' <- go_co cxt co + ; return (LRCo lr co') } + go_co cxt (InstCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (InstCo co' arg') } + go_co cxt (KindCo co) = do { co' <- go_co cxt co + ; return (KindCo co') } + go_co cxt (SubCo co) = do { co' <- go_co cxt co + ; return (SubCo co') } + + go_co cxt@(as, env) co@(ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = body_co }) + = do { kind_co' <- go_co cxt kind_co + ; let tv' = setVarType tv $ + coercionLKind kind_co' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go_co (as', env') body_co + ; return (co { fco_tcv = tv', fco_kind = kind_co', fco_body = body' }) } + + go_co cxt co@(FunCo { fco_mult = w, fco_arg = co1 ,fco_res = co2 }) + = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; w' <- go_co cxt w + ; return (co { fco_mult = w', fco_arg = co1', fco_res = co2' })} + + go_co (as,env) co@(CoVarCo c) + | Just c' <- lookupVarEnv env c = return (CoVarCo c') + | bad_var_occ as c = Nothing + | otherwise = return co + + go_co (as,_) co@(HoleCo h) + | bad_var_occ as (ch_co_var h) = Nothing + | otherwise = return co + + go_co cxt (AxiomCo ax cs) = do { cs' <- mapM (go_co cxt) cs + ; return (AxiomCo ax cs') } + go_co cxt co@(UnivCo { uco_lty = ty1, uco_rty = ty2, uco_deps = cos }) + = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; cos' <- mapM (go_co cxt) cos + ; return (co { uco_lty = ty1', uco_rty = ty2', uco_deps = cos' }) } + diff --git a/GHC/Core/TyCo/FVs.hs-boot b/GHC/Core/TyCo/FVs.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/FVs.hs-boot @@ -0,0 +1,8 @@ +module GHC.Core.TyCo.FVs where + +import GHC.Prelude ( Bool ) +import GHC.Types.Var.Set( TyCoVarSet ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) + +noFreeVarsOfType :: Type -> Bool +tyCoVarsOfType :: Type -> TyCoVarSet diff --git a/GHC/Core/TyCo/Ppr.hs b/GHC/Core/TyCo/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Ppr.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | Pretty-printing types and coercions. +module GHC.Core.TyCo.Ppr + ( + -- * Precedence + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, + + -- * Pretty-printing types + pprType, pprParendType, pprTidiedType, pprPrecType, pprPrecTypeX, + pprTypeApp, pprTCvBndr, pprTCvBndrs, + pprSigmaType, + pprTheta, pprParendTheta, pprForAll, pprUserForAll, + pprTyVar, pprTyVars, + pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprTyLit, + pprDataCons, pprWithInvisibleBitsWhen, + pprWithTYPE, pprSourceTyCon, + + + -- * Pretty-printing coercions + pprCo, pprParendCo, + + debugPprType, + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.CoreToIface + ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndrs + , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) + +import {-# SOURCE #-} GHC.Core.DataCon + ( dataConFullSig , dataConUserTyVarBinders, DataCon ) + +import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern OneTy, pattern ManyTy, + splitForAllReqTyBinders, splitForAllInvisTyBinders ) + +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Tidy +import GHC.Core.TyCo.FVs +import GHC.Core.Class +import GHC.Core.Predicate( scopedSort ) +import GHC.Core.Multiplicity( pprArrowWithMultiplicity ) + +import GHC.Types.Var + +import GHC.Iface.Type + +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.Basic ( PprPrec(..), topPrec, sigPrec, opPrec + , funPrec, appPrec, maybeParen ) + +{- +%************************************************************************ +%* * + Pretty-printing types + + Defined very early because of debug printing in assertions +%* * +%************************************************************************ + +@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is +defined to use this. @pprParendType@ is the same, except it puts +parens around the type, except for the atomic cases. @pprParendType@ +works just by setting the initial context precedence very high. + +Note that any function which pretty-prints a @Type@ first converts the @Type@ +to an @IfaceType@. See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr. + +See Note [Precedence in types] in GHC.Types.Basic. +-} + +pprType, pprParendType, pprTidiedType :: Type -> SDoc +pprType = pprPrecType topPrec +pprParendType = pprPrecType appPrec + +-- already pre-tidied +pprTidiedType = pprIfaceType . toIfaceTypeX emptyVarSet + +pprPrecType :: PprPrec -> Type -> SDoc +pprPrecType = pprPrecTypeX emptyTidyEnv + +pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc +pprPrecTypeX env prec ty + = getPprStyle $ \sty -> + getPprDebug $ \debug -> + if debug -- Use debugPprType when in + then debug_ppr_ty prec ty -- when in debug-style + else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) + -- NB: debug-style is used for -dppr-debug + -- dump-style is used for -ddump-tc-trace etc + +tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType +tidyToIfaceTypeStyX env ty sty + | userStyle sty = tidyToIfaceTypeX env ty + | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty + -- in latter case, don't tidy, as we'll be printing uniques. + + +pprTyLit :: TyLit -> SDoc +pprTyLit = pprIfaceTyLit . toIfaceTyLit + +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType + +tidyToIfaceType :: Type -> IfaceType +tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv + +tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceTypeX to +-- leave them as IfaceFreeTyVar. This is super-important +-- for debug printing. +tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty) + -- NB: if the type has /already/ been tidied (for example by the typechecker) + -- the tidy step here is a no-op. See Note [Tidying is idempotent] + -- in GHC.Core.TyCo.Tidy + where + env' = tidyFreeTyCoVars env free_tcvs + free_tcvs = tyCoVarsOfTypeList ty + +------------ +pprCo, pprParendCo :: Coercion -> SDoc +pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) +pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) + +tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion +tidyToIfaceCoSty co sty + | userStyle sty = tidyToIfaceCo co + | otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceCo :: Coercion -> IfaceCoercion +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceCoercionX to +-- leave them as IfaceFreeCoVar. This is super-important +-- for debug printing. +tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) + where + env = tidyFreeTyCoVars emptyTidyEnv free_tcvs + free_tcvs = scopedSort $ tyCoVarsOfCoList co +------------ +pprClassPred :: Class -> [Type] -> SDoc +pprClassPred clas tys = pprTypeApp (classTyCon clas) tys + +------------ +pprTheta :: ThetaType -> SDoc +pprTheta = pprIfaceContext topPrec . map tidyToIfaceType + +pprParendTheta :: ThetaType -> SDoc +pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType + +pprThetaArrowTy :: ThetaType -> SDoc +pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType + +------------------ +pprSigmaType :: Type -> SDoc +pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType + +pprForAll :: [ForAllTyBinder] -> SDoc +pprForAll tvs = pprIfaceForAll (toIfaceForAllBndrs tvs) + +-- | Print a user-level forall; see @Note [When to print foralls]@ in +-- "GHC.Iface.Type". +pprUserForAll :: [ForAllTyBinder] -> SDoc +pprUserForAll = pprUserIfaceForAll . toIfaceForAllBndrs + +pprTCvBndrs :: [ForAllTyBinder] -> SDoc +pprTCvBndrs tvs = sep (map pprTCvBndr tvs) + +pprTCvBndr :: ForAllTyBinder -> SDoc +pprTCvBndr = pprTyVar . binderVar + +pprTyVars :: [TyVar] -> SDoc +pprTyVars tvs = sep (map pprTyVar tvs) + +pprTyVar :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +-- Here we do not go via IfaceType, because the duplication with +-- pprIfaceTvBndr is minimal, and the loss of uniques etc in +-- debug printing is disastrous +pprTyVar tv + | pickyIsLiftedTypeKind kind = ppr tv -- See Note [Suppressing * kinds] + | otherwise = parens (ppr tv <+> dcolon <+> ppr kind) + where + kind = tyVarKind tv + +{- Note [Suppressing * kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally we want to print + forall a. a->a +not forall (a::*). a->a +or forall (a::Type). a->a +That is, for brevity we suppress a kind ascription of '*' (or Type). + +But what if the kind is (Const Type x)? + type Const p q = p + +Then (Const Type x) is just a long way of saying Type. But it may be +jolly confusing to suppress the 'x'. Suppose we have (polykinds/T18451a) + foo :: forall a b (c :: Const Type b). Proxy '[a, c] + +Then this error message + • These kind and type variables: a b (c :: Const Type b) + are out of dependency order. Perhaps try this ordering: + (b :: k) (a :: Const (*) b) (c :: Const (*) b) +would be much less helpful if we suppressed the kind ascription on 'a'. + +Hence the use of pickyIsLiftedTypeKind. +-} + +----------------- +debugPprType :: Type -> SDoc +-- ^ debugPprType is a simple pretty printer that prints a type +-- without going through IfaceType. It does not format as prettily +-- as the normal route, but it's much more direct, and that can +-- be useful for debugging. E.g. with -dppr-debug it prints the +-- kind on type-variable /occurrences/ which the normal route +-- fundamentally cannot do. +debugPprType ty = debug_ppr_ty topPrec ty + +debug_ppr_ty :: PprPrec -> Type -> SDoc +debug_ppr_ty _ (LitTy l) + = ppr l + +debug_ppr_ty _ (TyVarTy tv) + = ppr tv -- With -dppr-debug we get (tv :: kind) + +debug_ppr_ty prec (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) + = maybeParen prec funPrec $ + sep [debug_ppr_ty funPrec arg, arr <+> debug_ppr_ty prec res] + where + arr = pprArrowWithMultiplicity af $ + case mult of + OneTy -> Left True + ManyTy -> Left False + _ -> Right (debug_ppr_ty appPrec mult) + +debug_ppr_ty prec (TyConApp tc tys) + | null tys = ppr tc + | otherwise = maybeParen prec appPrec $ + hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys)) + +debug_ppr_ty _ (AppTy t1 t2) + = hang (debug_ppr_ty appPrec t1) -- Print parens so we see ((a b) c) + 2 (debug_ppr_ty appPrec t2) -- so that we can distinguish + -- TyConApp from AppTy + +debug_ppr_ty prec (CastTy ty co) + = maybeParen prec topPrec $ + hang (debug_ppr_ty topPrec ty) + 2 (text "|>" <+> ppr co) + +debug_ppr_ty _ (CoercionTy co) + = parens (text "CO" <+> ppr co) + +-- Invisible forall: forall {k} (a :: k). t +debug_ppr_ty prec t + | (bndrs, body) <- splitForAllInvisTyBinders t + , not (null bndrs) + = maybeParen prec funPrec $ + sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <> dot, + ppr body ] + where + -- (ppr tv) will print the binder kind-annotated + -- when in debug-style + ppr_bndr (Bndr tv InferredSpec) = braces (ppr tv) + ppr_bndr (Bndr tv SpecifiedSpec) = ppr tv + +-- Visible forall: forall x y -> t +debug_ppr_ty prec t + | (bndrs, body) <- splitForAllReqTyBinders t + , not (null bndrs) + = maybeParen prec funPrec $ + sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <+> arrow, + ppr body ] + where + -- (ppr tv) will print the binder kind-annotated + -- when in debug-style + ppr_bndr (Bndr tv ()) = ppr tv + +-- Impossible case: neither visible nor invisible forall. +debug_ppr_ty _ ForAllTy{} + = panic "debug_ppr_ty: neither splitForAllInvisTyBinders nor splitForAllReqTyBinders returned any binders" + +{- +Note [Infix type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With TypeOperators you can say + + f :: (a ~> b) -> b + +and the (~>) is considered a type variable. However, the type +pretty-printer in this module will just see (a ~> b) as + + App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") + +So it'll print the type in prefix form. To avoid confusion we must +remember to parenthesise the operator, thus + + (~>) a b -> b + +See #2766. +-} + +pprDataCons :: TyCon -> SDoc +pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons + where + sepWithVBars [] = empty + sepWithVBars docs = sep (punctuate (space <> vbar) docs) + +pprDataConWithArgs :: DataCon -> SDoc +pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] + where + (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc + user_bndrs = dataConUserTyVarBinders dc + forAllDoc = pprUserForAll user_bndrs + thetaDoc = pprThetaArrowTy theta + argsDoc = hsep (fmap pprParendType (map scaledThing arg_tys)) + + +pprTypeApp :: TyCon -> [Type] -> SDoc +pprTypeApp tc tys + = pprIfaceTypeApp topPrec (toIfaceTyCon tc) + (toIfaceTcArgs tc tys) + -- TODO: toIfaceTcArgs seems rather wasteful here + +------------------ +-- | Display all foralls, runtime-reps, and kind information +-- when provided 'Bool' argument is 'True'. See GHC.Tc.Errors.Ppr +-- Note [Showing invisible bits of types in error messages] +pprWithInvisibleBitsWhen :: Bool -> SDoc -> SDoc +pprWithInvisibleBitsWhen b + = updSDocContext $ \ctx -> + if b then ctx { sdocPrintExplicitKinds = True + , sdocPrintExplicitRuntimeReps = True } + else ctx + +-- | This variant preserves any use of TYPE in a type, effectively +-- locally setting -fprint-explicit-runtime-reps. +pprWithTYPE :: Type -> SDoc +pprWithTYPE ty = updSDocContext (\ctx -> ctx { sdocPrintExplicitRuntimeReps = True }) $ + ppr ty + +-- | Pretty prints a 'TyCon', using the family instance in case of a +-- representation tycon. For example: +-- +-- > data T [a] = ... +-- +-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' +pprSourceTyCon :: TyCon -> SDoc +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon diff --git a/GHC/Core/TyCo/Ppr.hs-boot b/GHC/Core/TyCo/Ppr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Ppr.hs-boot @@ -0,0 +1,12 @@ +module GHC.Core.TyCo.Ppr where + +import {-# SOURCE #-} GHC.Types.Var ( TyVar ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit) +import GHC.Utils.Outputable ( SDoc ) + +pprType :: Type -> SDoc +debugPprType :: Type -> SDoc +pprKind :: Kind -> SDoc +pprCo :: Coercion -> SDoc +pprTyLit :: TyLit -> SDoc +pprTyVar :: TyVar -> SDoc diff --git a/GHC/Core/TyCo/Rep.hs b/GHC/Core/TyCo/Rep.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Rep.hs @@ -0,0 +1,2060 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +{-# OPTIONS_HADDOCK not-home #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +\section[GHC.Core.TyCo.Rep]{Type and Coercion - friends' interface} + +Note [The Type-related module hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + GHC.Core.Class + GHC.Core.Coercion.Axiom + GHC.Core.TyCon imports GHC.Core.{Class, Coercion.Axiom} + GHC.Core.TyCo.Rep imports GHC.Core.{Class, Coercion.Axiom, TyCon} + GHC.Core.TyCo.Ppr imports GHC.Core.TyCo.Rep + GHC.Core.TyCo.FVs imports GHC.Core.TyCo.Rep + GHC.Core.TyCo.Subst imports GHC.Core.TyCo.{Rep, FVs, Ppr} + GHC.Core.TyCo.Tidy imports GHC.Core.TyCo.{Rep, FVs} + GHC.Builtin.Types.Prim imports GHC.Core.TyCo.Rep ( including mkTyConTy ) + GHC.Core.Coercion imports GHC.Core.Type +-} + +-- We expose the relevant stuff from this module via the Type module +module GHC.Core.TyCo.Rep ( + + -- * Types + Type(..), + + TyLit(..), + KindOrType, Kind, + RuntimeRepType, LevityType, + KnotTied, + PredType, ThetaType, FRRType, -- Synonyms + ForAllTyFlag(..), FunTyFlag(..), + + -- * Coercions + Coercion(..), CoSel(..), FunSel(..), + UnivCoProvenance(..), + CoercionHole(..), coHoleCoVar, setCoHoleCoVar, + CoercionN, CoercionR, CoercionP, KindCoercion, + MCoercion(..), MCoercionR, MCoercionN, + + -- * Functions over types + mkNakedTyConTy, mkTyVarTy, mkTyVarTys, + mkTyCoVarTy, mkTyCoVarTys, + mkFunTy, mkNakedFunTy, + mkVisFunTy, mkScaledFunTys, + mkInvisFunTy, mkInvisFunTys, + tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTy, tcMkScaledFunTys, + mkForAllTy, mkForAllTys, mkInvisForAllTys, + mkPiTy, mkPiTys, + mkVisFunTyMany, mkVisFunTysMany, + nonDetCmpTyLit, cmpTyLit, + + -- * Functions over coercions + pickLR, + + -- ** Analyzing types + TyCoFolder(..), foldTyCo, noView, + + -- * Sizes + typeSize, typesSize, coercionSize, + + -- * Multiplicities + Scaled(..), scaledMult, scaledThing, mapScaledType, Mult + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) +import {-# SOURCE #-} GHC.Builtin.Types +import {-# SOURCE #-} GHC.Core.TyCo.FVs( tyCoVarsOfType ) -- Use in assertions +import {-# SOURCE #-} GHC.Core.Type( chooseFunTyFlag, typeKind, typeTypeOrConstraint ) + + -- Transitively pulls in a LOT of stuff, better to break the loop + +-- friends: +import GHC.Types.Var +import GHC.Types.Var.Set( elemVarSet ) +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom + +-- others +import GHC.Builtin.Names + +import GHC.Types.Basic ( LeftOrRight(..), pickLR ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Binary + +-- libraries +import qualified Data.Data as Data hiding ( TyCon ) +import Data.IORef ( IORef ) -- for CoercionHole +import Control.DeepSeq + +{- ********************************************************************** +* * + Type +* * +********************************************************************** -} + +-- | The key representation of types within the compiler + +type KindOrType = Type -- See Note [Arguments to type constructors] + +-- | The key type representing kinds in the compiler. +type Kind = Type + +-- | Type synonym used for types of kind RuntimeRep. +type RuntimeRepType = Type + +-- | Type synonym used for types of kind Levity. +type LevityType = Type + +-- A type with a syntactically fixed RuntimeRep, in the sense +-- of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +type FRRType = Type + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Type + -- See Note [Non-trivial definitional equality] + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) + + | AppTy + Type + Type -- ^ Type application to something other than a 'TyCon'. Parameters: + -- + -- 1) Function: must /not/ be a 'TyConApp' or 'CastTy', + -- must be another 'AppTy', or 'TyVarTy' + -- See Note [Respecting definitional equality] \(EQ1) about the + -- no 'CastTy' requirement + -- + -- 2) Argument type + + | TyConApp + TyCon + [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. + -- Invariant: saturated applications of 'FunTyCon' must + -- use 'FunTy' and saturated synonyms must use their own + -- constructors. However, /unsaturated/ 'FunTyCon's + -- do appear as 'TyConApp's. + -- Parameters: + -- + -- 1) Type constructor being applied to. + -- + -- 2) Type arguments. Might not have enough type arguments + -- here to saturate the constructor. + -- Even type synonyms are not necessarily saturated; + -- for example unsaturated type synonyms + -- can appear as the right hand side of a type synonym. + + | ForAllTy -- See Note [ForAllTy] + {-# UNPACK #-} !ForAllTyBinder + -- ForAllTyBinder: see GHC.Types.Var + -- Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] + Type + -- INVARIANT: If the binder is a coercion variable, it must + -- be mentioned in the Type. + -- See Note [Unused coercion variable in ForAllTy] + -- See Note [Why ForAllTy can quantify over a coercion variable] + + | FunTy -- ^ FUN m t1 t2 Very common, so an important special case + -- See Note [Function types] + { ft_af :: FunTyFlag -- Is this (->/FUN) or (=>) or (==>)? + -- This info is fully specified by the kinds in + -- ft_arg and ft_res + -- Note [FunTyFlag] in GHC.Types.Var + + , ft_mult :: Mult -- Multiplicity; always Many for (=>) and (==>) + , ft_arg :: Type -- Argument type + , ft_res :: Type } -- Result type + + | LitTy TyLit -- ^ Type literals are similar to type constructors. + + | CastTy + Type + KindCoercion -- ^ A kind cast. The coercion is always nominal. + -- INVARIANT: The cast is never reflexive \(EQ2) + -- INVARIANT: The Type is not a CastTy (use TransCo instead) \(EQ3) + -- INVARIANT: The Type is not a ForAllTy over a tyvar \(EQ4) + -- See Note [Respecting definitional equality] + + | CoercionTy + Coercion -- ^ Injection of a Coercion into a type + -- This should only ever be used in the RHS of an AppTy, + -- in the list of a TyConApp, when applying a promoted + -- GADT data constructor + + deriving Data.Data + +instance Outputable Type where + ppr = pprType + +-- NOTE: Other parts of the code assume that type literals do not contain +-- types or type variables. +data TyLit + = NumTyLit Integer + | StrTyLit FastString + | CharTyLit Char + deriving (Eq, Data.Data) + +-- Non-determinism arises due to uniqCompareFS +nonDetCmpTyLit :: TyLit -> TyLit -> Ordering +nonDetCmpTyLit = cmpTyLitWith NonDetFastString + +-- Slower than nonDetCmpTyLit but deterministic +cmpTyLit :: TyLit -> TyLit -> Ordering +cmpTyLit = cmpTyLitWith LexicalFastString + +{-# INLINE cmpTyLitWith #-} +cmpTyLitWith :: Ord r => (FastString -> r) -> TyLit -> TyLit -> Ordering +cmpTyLitWith _ (NumTyLit x) (NumTyLit y) = compare x y +cmpTyLitWith w (StrTyLit x) (StrTyLit y) = compare (w x) (w y) +cmpTyLitWith _ (CharTyLit x) (CharTyLit y) = compare x y +cmpTyLitWith _ a b = compare (tag a) (tag b) + where + tag :: TyLit -> Int + tag NumTyLit{} = 0 + tag StrTyLit{} = 1 + tag CharTyLit{} = 2 + +instance Outputable TyLit where + ppr = pprTyLit + +{- Note [Function types] +~~~~~~~~~~~~~~~~~~~~~~~~ +FunTy is the constructor for a function type. Here are the details: + +* The primitive function type constructor FUN has kind + FUN :: forall (m :: Multiplicity) -> + forall {r1 :: RuntimeRep} {r2 :: RuntimeRep}. + TYPE r1 -> + TYPE r2 -> + Type + mkTyConApp ensures that we convert a saturated application + TyConApp FUN [m,r1,r2,t1,t2] into FunTy FTF_T_T m t1 t2 + dropping the 'r1' and 'r2' arguments; they are easily recovered + from 't1' and 't2'. The FunTyFlag is always FTF_T_T, because + we build constraint arrows (=>) with e.g. mkPhiTy and friends, + never `mkTyConApp funTyCon args`. + +* For the time being its RuntimeRep quantifiers are left + inferred. This is to allow for it to evolve. + +* Because the RuntimeRep args came first historically (that is, + the arrow type constructor gained these arguments before gaining + the Multiplicity argument), we wanted to be able to say + type (->) = FUN Many + which we do in library module GHC.Types. This means that the + Multiplicity argument must precede the RuntimeRep arguments -- + and it means changing the name of the primitive constructor from + (->) to FUN. + +* The multiplicity argument is dependent, because Typeable does not + support a type such as `Multiplicity -> forall {r1 r2 :: RuntimeRep}. ...`. + There is a plan to change the argument order and make the + multiplicity argument nondependent in #20164. + +* Re the ft_af field: see Note [FunTyFlag] in GHC.Types.Var + See Note [Types for coercions, predicates, and evidence] in + GHC.Core.Predicate. This visibility info makes no difference in Core; + it matter only when we regard the type as a Haskell source type. + +Note [Weird typing rule for ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here are the typing rules for ForAllTy: + +tyvar : Type +inner : TYPE r +tyvar does not occur in r +------------------------------------ +ForAllTy (Bndr tyvar vis) inner : TYPE r + +inner : TYPE r +------------------------------------ +ForAllTy (Bndr covar vis) inner : Type + +Note that the kind of the result depends on whether the binder is a +tyvar or a covar. The kind of a forall-over-tyvar is the same as +the kind of the inner type. This is because quantification over types +is erased before runtime. By contrast, the kind of a forall-over-covar +is always Type, because a forall-over-covar is compiled into a function +taking a 0-bit-wide erased coercion argument. + +Because the tyvar form above includes r in its result, we must +be careful not to let any variables escape -- thus the last premise +of the rule above. + +Note [Arguments to type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of kind polymorphism, in addition to type application we now +have kind instantiation. We reuse the same notations to do so. + +For example: + + Just (* -> *) Maybe + Right * Nat Zero + +are represented by: + + TyConApp (PromotedDataCon Just) [* -> *, Maybe] + TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] + +Important note: Nat is used as a *kind* and not as a type. This can be +confusing, since type-level Nat and kind-level Nat are identical. We +use the kind of (PromotedDataCon Right) to know if its arguments are +kinds or types. + +This kind instantiation only happens in TyConApp currently. + +Note [Non-trivial definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is ((IO |> co1) Int |> co2) equal to (IO Int)? +Assume + co1 :: (Type->Type) ~ (Type->Wombat) + co2 :: Wombat ~ Type +Well, yes. The casts are just getting in the way. +See also Note [Respecting definitional equality]. + +So we do this: + +(EQTYPE) + The `eqType` function, which defines Core's type equality relation, + - /ignores/ casts, and + - /ignores/ coercion arguments + - /provided/ two types have the same kind + +This allows us to be a little sloppier in keeping track of coercions, which is a +good thing. It also means that eqType does not depend on eqCoercion, which is +also a good thing. + +Why is this sensible? That is, why is something different than α-equivalence +appropriate for the implementation of eqType? + +Anything smaller than ~ and homogeneous is an appropriate definition for +equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any +expression of type τ can be transmuted to one of type σ at any point by +casting. The same is true of expressions of type σ. So in some sense, τ and σ +are interchangeable. + +But let's be more precise. If we examine the typing rules of FC (say, those in +https://richarde.dev/papers/2015/equalities/equalities.pdf) +there are several places where the same metavariable is used in two different +premises to a rule. (For example, see Ty_App.) There is an implicit equality +check here. What definition of equality should we use? By convention, we use +α-equivalence. Take any rule with one (or more) of these implicit equality +checks. Then there is an admissible rule that uses ~ instead of the implicit +check, adding in casts as appropriate. + +The only problem here is that ~ is heterogeneous. To make the kinds work out +in the admissible rule that uses ~, it is necessary to homogenize the +coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η; +we use η |> kind η, which is homogeneous. + +The effect of this all is that eqType, the implementation of the implicit +equality check, can use any homogeneous relation that is smaller than ~, as +those rules must also be admissible. + +A more drawn out argument around all of this is presented in Section 7.2 of +Richard E's thesis (http://richarde.dev/papers/2016/thesis/eisenberg-thesis.pdf). + +What would go wrong if we insisted on the casts matching? See the beginning of +Section 8 in the unpublished paper above. Theoretically, nothing at all goes +wrong. But in practical terms, getting the coercions right proved to be +nightmarish. And types would explode: during kind-checking, we often produce +reflexive kind coercions. When we try to cast by these, mkCastTy just discards +them. But if we used an eqType that distinguished between Int and Int |> <*>, +then we couldn't discard -- the output of kind-checking would be enormous, +and we would need enormous casts with lots of CoherenceCo's to straighten +them out. + +Would anything go wrong if eqType looked through type families? No, not at +all. But that makes eqType rather hard to implement. + +Thus, the guideline for eqType is that it should be the largest +easy-to-implement relation that is still smaller than ~ and homogeneous. The +precise choice of relation is somewhat incidental, as long as the smart +constructors and destructors in Type respect whatever relation is chosen. + +Another helpful principle with eqType is this: + + (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere. + +This principle also tells us that eqType must relate only types with the +same kinds. + +Interestingly, it must be the case that the free variables of t1 and t2 +might be different, even if t1 `eqType` t2. A simple example of this is +if we have both cv1 :: k1 ~ k2 and cv2 :: k1 ~ k2 in the environment. +Then t1 = t |> cv1 and t2 = t |> cv2 are eqType; yet cv1 is in the free +vars of t1 and cv2 is in the free vars of t2. Unless we choose to implement +eqType to be just α-equivalence, this wrinkle around free variables +remains. + +Yet not all is lost: we can say that any two equal types share the same +*relevant* free variables. Here, a relevant variable is a shallow +free variable (see Note [Shallow and deep free variables] in GHC.Core.TyCo.FVs) +that does not appear within a coercion. Note that type variables can +appear within coercions (in, say, a Refl node), but that coercion variables +cannot appear outside a coercion. We do not (yet) have a function to +extract relevant free variables, but it would not be hard to write if +the need arises. + +Note [Respecting definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Non-trivial definitional equality] introduces the property (EQ). +How is this upheld? + +Any function that pattern matches on all the constructors will have to +consider the possibility of CastTy. Presumably, those functions will handle +CastTy appropriately and we'll be OK. + +More dangerous are the splitXXX functions. Let's focus on splitTyConApp. +We don't want it to fail on (T a b c |> co). Happily, if we have + (T a b c |> co) `eqType` (T d e f) +then co must be reflexive. Why? eqType checks that the kinds are equal, as +well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f). +By the kind check, we know that (T a b c |> co) and (T d e f) have the same +kind. So the only way that co could be non-reflexive is for (T a b c) to have +a different kind than (T d e f). But because T's kind is closed (all tycon kinds +are closed), the only way for this to happen is that one of the arguments has +to differ, leading to a contradiction. Thus, co is reflexive. + +Accordingly, by eliminating reflexive casts, splitTyConApp need not worry +about outermost casts to uphold (EQ). Eliminating reflexive casts is done +in mkCastTy. This is (EQ2) below. + +Unfortunately, that's not the end of the story. Consider comparing + (T a b c) =? (T a b |> (co -> )) (c |> co) +These two types have the same kind (Type), but the left type is a TyConApp +while the right type is not. To handle this case, we say that the right-hand +type is ill-formed, requiring an AppTy never to have a casted TyConApp +on its left. It is easy enough to pull around the coercions to maintain +this invariant, as done in Type.mkAppTy. In the example above, trying to +form the right-hand type will instead yield (T a b (c |> co |> sym co) |> ). +Both the casts there are reflexive and will be dropped. Huzzah. + +This idea of pulling coercions to the right works for splitAppTy as well. + +However, there is one hiccup: it's possible that a coercion doesn't relate two +Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@, +then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't +be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not +`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate +our (EQ) property. + +In order to detect reflexive casts reliably, we must make sure not +to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). +This is (EQ3) below. + +One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy]. +The kind of the body is the same as the kind of the ForAllTy. Accordingly, + + ForAllTy tv (ty |> co) and (ForAllTy tv ty) |> co + +are `eqType`. But only the first can be split by splitForAllTy. So we forbid +the second form, instead pushing the coercion inside to get the first form. +This is done in mkCastTy. + +In sum, in order to uphold (EQ), we need the following invariants: + + (EQ1) No decomposable CastTy to the left of an AppTy, + where a "decomposable cast" is one that relates + either a FunTy to a FunTy, or a ForAllTy to a ForAllTy. + (EQ2) No reflexive casts in CastTy. + (EQ3) No nested CastTys. + (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). + See Note [Weird typing rule for ForAllTy] + +These invariants are all documented above, in the declaration for Type. + +Note [Equality on FunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~ +A (FunTy vis mult arg res) is just an abbreviation for a + TyConApp funTyCon [mult, arg_rep, res_rep, arg, res] +where + arg :: TYPE arg_rep + res :: TYPE res_rep +Note that the vis field of a FunTy appears nowhere in the +equivalent TyConApp. In Core, this is OK, because we no longer +care about the visibility of the argument in a FunTy +(the vis distinguishes between arg -> res and arg => res). +In the type-checker, we are careful not to decompose FunTys +with an invisible argument. See also Note [Decomposing fat arrow c=>t] +in GHC.Core.Type. + +In order to compare FunTys while respecting how they could +expand into TyConApps, we must check +the kinds of the arg and the res. + +Note [ForAllTy] +~~~~~~~~~~~~~~~ +A (ForAllTy (Bndr tcv vis) ty) can quantify over a TyVar or, less commonly, a CoVar. +See Note [Why ForAllTy can quantify over a coercion variable] for why we need the latter. + +(FT1) Invariant: See Note [Weird typing rule for ForAllTy] + +(FT2) Invariant: in (ForAllTy (Bndr tcv vis) ty), + if tcv is a CoVar, then vis = coreTyLamForAllTyFlag. + Visibility is not important for coercion abstractions, + because they are not user-visible. + +(FT3) Invariant: see Note [Unused coercion variable in ForAllTy] + +Note [Why ForAllTy can quantify over a coercion variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ForAllTyBinder in a ForAllTy can be (most often) a TyVar or (rarely) +a CoVar. We support quantifying over a CoVar here in order to support +a homogeneous (~#) relation (someday -- not yet implemented). Here is +the example: + + type (:~~:) :: forall k1 k2. k1 -> k2 -> Type + data a :~~: b where + HRefl :: a :~~: a + +Assuming homogeneous equality (that is, with + (~#) :: forall k. k -> k -> TYPE (TupleRep '[]) +) after rejigging to make equalities explicit, we get a constructor that +looks like + + HRefl :: forall k1 k2 (a :: k1) (b :: k2). + forall (cv :: k1 ~# k2). (a |> cv) ~# b + => (:~~:) k1 k2 a b + +Note that we must cast `a` by a cv bound in the same type in order to +make this work out. + +See also https://gitlab.haskell.org/ghc/ghc/-/wikis/dependent-haskell/phase2 +which gives a general road map that covers this space. Having this feature in +Core does *not* mean we have it in source Haskell. See #15710 about that. + +Note [Unused coercion variable in ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + \(co:t1 ~# t2). e + +What type should we give to the above expression? + (1) forall (co:t1 ~# t2) -> t + (2) (t1 ~# t2) -> t + +If co is used in t, (1) should be the right choice. +if co is not used in t, we would like to have (1) and (2) equivalent. + +However, we want to keep eqType simple and don't want eqType (1) (2) to return +True in any case. + +We decide to always construct (2) if co is not used in t. + +Thus in mkLamType, we check whether the variable is a coercion +variable (of type (t1 ~# t2), and whether it is un-used in the +body. If so, it returns a FunTy instead of a ForAllTy. + +There are cases we want to skip the check. For example, the check is +unnecessary when it is known from the context that the input variable +is a type variable. In those cases, we use mkForAllTy. + +Note [Weird typing rule for ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is the (truncated) typing rule for the dependent ForAllTy: + + inner : TYPE r + tyvar is not free in r + ---------------------------------------- + ForAllTy (Bndr tyvar vis) inner : TYPE r + +Note that the kind of `inner` is the kind of the overall ForAllTy. This is +necessary because every ForAllTy over a type variable is erased at runtime. +Thus the runtime representation of a ForAllTy (as encoded, via TYPE rep, in +the kind) must be the same as the representation of the body. We must check +for skolem-escape, though. The skolem-escape would prevent a definition like + + undefined :: forall (r :: RuntimeRep) (a :: TYPE r). a + +because the type's kind (TYPE r) mentions the out-of-scope r. Luckily, the real +type of undefined is + + undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a + +and that HasCallStack constraint neatly sidesteps the potential skolem-escape +problem. + +If the bound variable is a coercion variable: + + inner : TYPE r + covar is free in inner + ------------------------------------ + ForAllTy (Bndr covar vis) inner : Type + +Here, the kind of the ForAllTy is just Type, because coercion abstractions +are *not* erased. The "covar is free in inner" premise is solely to maintain +the representation invariant documented in +Note [Unused coercion variable in ForAllTy]. Though there is surface similarity +between this free-var check and the one in the tyvar rule, these two restrictions +are truly unrelated. + +-} + +-- | A type labeled 'KnotTied' might have knot-tied tycons in it. See +-- Note [Type checking recursive type and class declarations] in +-- "GHC.Tc.TyCl" +type KnotTied ty = ty + +{- ********************************************************************** +* * + PredType +* * +********************************************************************** -} + + +-- | A type of the form @p@ of constraint kind represents a value whose type is +-- the Haskell predicate @p@, where a predicate is what occurs before +-- the @=>@ in a Haskell type. +-- +-- We use 'PredType' as documentation to mark those types that we guarantee to +-- have this kind. +-- +-- It can be expanded into its representation, but: +-- +-- * The type checker must treat it as opaque +-- +-- * The rest of the compiler treats it as transparent +-- +-- Consider these examples: +-- +-- > f :: (Eq a) => a -> Int +-- > g :: (?x :: Int -> Int) => a -> Int +-- > h :: (r\l) => {r} => {l::Int | r} +-- +-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" +type PredType = Type + +-- | A collection of 'PredType's +type ThetaType = [PredType] + +{- +(We don't support TREX records yet, but the setup is designed +to expand to allow them.) + +A Haskell qualified type, such as that for f,g,h above, is +represented using + * a FunTy for the double arrow + * with a type of kind Constraint as the function argument + +The predicate really does turn into a real extra argument to the +function. If the argument has type (p :: Constraint) then the predicate p is +represented by evidence of type p. + + +%************************************************************************ +%* * + Simple constructors +%* * +%************************************************************************ + +These functions are here so that they can be used by GHC.Builtin.Types.Prim, +which in turn is imported by Type +-} + +mkTyVarTy :: TyVar -> Type +mkTyVarTy v = assertPpr (isTyVar v) (ppr v <+> dcolon <+> ppr (tyVarKind v)) $ + TyVarTy v + +mkTyVarTys :: [TyVar] -> [Type] +mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy + +mkTyCoVarTy :: TyCoVar -> Type +mkTyCoVarTy v + | isTyVar v + = TyVarTy v + | otherwise + = CoercionTy (CoVarCo v) + +mkTyCoVarTys :: [TyCoVar] -> [Type] +mkTyCoVarTys = map mkTyCoVarTy + +infixr 3 `mkFunTy`, `mkInvisFunTy`, `mkVisFunTyMany` + +mkNakedFunTy :: FunTyFlag -> Kind -> Kind -> Kind +-- See Note [Naked FunTy] in GHC.Builtin.Types +-- Always Many multiplicity; kinds have no linearity +mkNakedFunTy af arg res + = FunTy { ft_af = af, ft_mult = manyDataConTy + , ft_arg = arg, ft_res = res } + +mkFunTy :: HasDebugCallStack => FunTyFlag -> Mult -> Type -> Type -> Type +mkFunTy af mult arg res + = assertPpr (af == chooseFunTyFlag arg res) (vcat + [ text "af" <+> ppr af + , text "chooseAAF" <+> ppr (chooseFunTyFlag arg res) + , text "arg" <+> ppr arg <+> dcolon <+> ppr (typeKind arg) + , text "res" <+> ppr res <+> dcolon <+> ppr (typeKind res) ]) $ + FunTy { ft_af = af + , ft_mult = mult + , ft_arg = arg + , ft_res = res } + +mkInvisFunTy :: HasDebugCallStack => Type -> Type -> Type +mkInvisFunTy arg res + = mkFunTy (invisArg (typeTypeOrConstraint res)) manyDataConTy arg res + +mkInvisFunTys :: HasDebugCallStack => [Type] -> Type -> Type +mkInvisFunTys args res + = foldr (mkFunTy af manyDataConTy) res args + where + af = invisArg (typeTypeOrConstraint res) + +mkVisFunTy :: HasDebugCallStack => Mult -> Type -> Type -> Type +-- Always TypeLike, user-specified multiplicity. +mkVisFunTy = mkFunTy visArgTypeLike + +-- | Make nested arrow types +-- | Special, common, case: Arrow type with mult Many +mkVisFunTyMany :: HasDebugCallStack => Type -> Type -> Type +-- Always TypeLike, multiplicity Many +mkVisFunTyMany = mkVisFunTy manyDataConTy + +mkVisFunTysMany :: [Type] -> Type -> Type +-- Always TypeLike, multiplicity Many +mkVisFunTysMany tys ty = foldr mkVisFunTyMany ty tys + +--------------- +mkScaledFunTy :: HasDebugCallStack => FunTyFlag -> Scaled Type -> Type -> Type +mkScaledFunTy af (Scaled mult arg) res = mkFunTy af mult arg res + +mkScaledFunTys :: HasDebugCallStack => [Scaled Type] -> Type -> Type +-- All visible args +-- Result type can be TypeLike or ConstraintLike +-- Example of the latter: dataConWrapperType for the data con of a class +mkScaledFunTys tys ty = foldr (mkScaledFunTy af) ty tys + where + af = visArg (typeTypeOrConstraint ty) + +--------------- +-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder +-- See Note [Unused coercion variable in ForAllTy] +mkForAllTy :: ForAllTyBinder -> Type -> Type +mkForAllTy bndr body + = assertPpr (good_bndr bndr) (ppr bndr <+> ppr body) $ + ForAllTy bndr body + where + -- Check ForAllTy invariants + good_bndr (Bndr cv vis) + | isCoVar cv = vis == coreTyLamForAllTyFlag + -- See (FT2) in Note [ForAllTy] + && (cv `elemVarSet` tyCoVarsOfType body) + -- See (FT3) in Note [ForAllTy] + | otherwise = True + +-- | Wraps foralls over the type using the provided 'TyCoVar's from left to right +mkForAllTys :: [ForAllTyBinder] -> Type -> Type +mkForAllTys tyvars ty = foldr ForAllTy ty tyvars + +-- | Wraps foralls over the type using the provided 'InvisTVBinder's from left to right +mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type +mkInvisForAllTys tyvars = mkForAllTys (tyVarSpecToBinders tyvars) + +mkPiTy :: HasDebugCallStack => PiTyBinder -> Type -> Type +mkPiTy (Anon ty1 af) ty2 = mkScaledFunTy af ty1 ty2 +mkPiTy (Named bndr) ty = mkForAllTy bndr ty + +mkPiTys :: HasDebugCallStack => [PiTyBinder] -> Type -> Type +mkPiTys tbs ty = foldr mkPiTy ty tbs + +-- | 'mkNakedTyConTy' creates a nullary 'TyConApp'. In general you +-- should rather use 'GHC.Core.Type.mkTyConTy', which picks the shared +-- nullary TyConApp from inside the TyCon (via tyConNullaryTy. But +-- we have to build the TyConApp tc [] in that TyCon field; that's +-- what 'mkNakedTyConTy' is for. +mkNakedTyConTy :: TyCon -> Type +mkNakedTyConTy tycon = TyConApp tycon [] + +tcMkVisFunTy :: Mult -> Type -> Type -> Type +-- Always TypeLike result, user-specified multiplicity. +-- Does not have the assert-checking in mkFunTy: used by the typechecker +-- to avoid looking at the result kind, which may not be zonked +tcMkVisFunTy mult arg res + = FunTy { ft_af = visArgTypeLike, ft_mult = mult + , ft_arg = arg, ft_res = res } + +tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type +-- Always invisible (constraint) argument, result specified by res_torc +-- Does not have the assert-checking in mkFunTy: used by the typechecker +-- to avoid looking at the result kind, which may not be zonked +tcMkInvisFunTy res_torc arg res + = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy + , ft_arg = arg, ft_res = res } + +tcMkScaledFunTys :: [Scaled Type] -> Type -> Type +-- All visible args +-- Result type must be TypeLike +-- No mkFunTy assert checking; result kind may not be zonked +tcMkScaledFunTys tys ty = foldr tcMkScaledFunTy ty tys + +tcMkScaledFunTy :: Scaled Type -> Type -> Type +tcMkScaledFunTy (Scaled mult arg) res = tcMkVisFunTy mult arg res + +{- +%************************************************************************ +%* * + Coercions +%* * +%************************************************************************ +-} + +-- | A 'Coercion' is concrete evidence of the equality/convertibility +-- of two types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Coercion + -- Each constructor has a "role signature", indicating the way roles are + -- propagated through coercions. + -- - P, N, and R stand for coercions of the given role + -- - e stands for a coercion of a specific unknown role + -- (think "role polymorphism") + -- - "e" stands for an explicit role parameter indicating role e. + -- - _ stands for a parameter that is not a Role or Coercion. + + -- These ones mirror the shape of types + = -- Refl :: _ -> N + -- A special case reflexivity for a very common case: Nominal reflexivity + -- If you need Representational, use (GRefl Representational ty MRefl) + -- not (SubCo (Refl ty)) + Refl Type -- See Note [Refl invariant] + + -- GRefl :: "e" -> _ -> Maybe N -> e + -- See Note [Generalized reflexive coercion] + | GRefl Role Type MCoercionN -- See Note [Refl invariant] + -- Use (Refl ty), not (GRefl Nominal ty MRefl) + -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _)) + + -- These ones simply lift the correspondingly-named + -- Type constructors into Coercions + + -- TyConAppCo :: "e" -> _ -> ?? -> e + -- See Note [TyConAppCo roles] + | TyConAppCo Role TyCon [Coercion] -- lift TyConApp + -- The TyCon is never a synonym; + -- we expand synonyms eagerly + -- But it can be a type function + -- TyCon is never a saturated (->); use FunCo instead + + | AppCo Coercion CoercionN -- lift AppTy + -- AppCo :: e -> N -> e + + -- See Note [ForAllCo] + | ForAllCo + { fco_tcv :: TyCoVar + , fco_visL :: !ForAllTyFlag -- Visibility of coercionLKind + , fco_visR :: !ForAllTyFlag -- Visibility of coercionRKind + -- See (FC7) of Note [ForAllCo] + , fco_kind :: KindCoercion + , fco_body :: Coercion } + -- ForAllCo :: _ -> N -> e -> e + + | FunCo -- FunCo :: "e" -> N/P -> e -> e -> e + -- See Note [FunCo] for fco_afl, fco_afr + { fco_role :: Role + , fco_afl :: FunTyFlag -- Arrow for coercionLKind + , fco_afr :: FunTyFlag -- Arrow for coercionRKind + , fco_mult :: CoercionN + , fco_arg, fco_res :: Coercion } + -- (if the role "e" is Phantom, the first coercion is, too) + -- the first coercion is for the multiplicity + + -- These are special + | CoVarCo CoVar -- :: _ -> (N or R) + -- result role depends on the tycon of the variable's type + + | AxiomCo CoAxiomRule [Coercion] + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. + -- See [Coercion axioms applied to coercions] + -- The roles of the argument coercions are determined + -- by the cab_roles field of the relevant branch of the CoAxiom + + | UnivCo -- See Note [UnivCo] + -- Of kind (lty ~role rty) + { uco_prov :: UnivCoProvenance + , uco_role :: Role + , uco_lty, uco_rty :: Type + , uco_deps :: [Coercion] -- Coercions on which it depends + -- See Note [The importance of tracking UnivCo dependencies] + } + + | SymCo Coercion -- :: e -> e + | TransCo Coercion Coercion -- :: e -> e -> e + + | SelCo CoSel Coercion -- See Note [SelCo] + + | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) + -- :: _ -> N -> N + | InstCo Coercion CoercionN + -- :: e -> N -> e + -- See Note [InstCo roles] + + -- Extract a kind coercion from a (heterogeneous) type coercion + -- NB: all kind coercions are Nominal + | KindCo Coercion + -- :: e -> N + + | SubCo CoercionN -- Turns a ~N into a ~R + -- :: N -> R + + | HoleCo CoercionHole -- ^ See Note [Coercion holes] + -- Only present during typechecking + deriving Data.Data + +data CoSel -- See Note [SelCo] + = SelTyCon Int Role -- Decomposes (T co1 ... con); zero-indexed + -- Invariant: Given: SelCo (SelTyCon i r) co + -- we have r == tyConRole (coercionRole co) tc + -- and tc1 == tc2 + -- where T tc1 _ = coercionLKind co + -- T tc2 _ = coercionRKind co + -- See Note [SelCo] + + | SelFun FunSel -- Decomposes (co1 -> co2) + + | SelForAll -- Decomposes (forall a. co) + + deriving( Eq, Data.Data, Ord ) + +data FunSel -- See Note [SelCo] + = SelMult -- Multiplicity + | SelArg -- Argument of function + | SelRes -- Result of function + deriving( Eq, Data.Data, Ord ) + +type CoercionN = Coercion -- always nominal +type CoercionR = Coercion -- always representational +type CoercionP = Coercion -- always phantom +type KindCoercion = CoercionN -- always nominal + +instance Outputable Coercion where + ppr = pprCo + +instance Outputable CoSel where + ppr (SelTyCon n r) = text "Tc" <> parens (int n <> comma <> pprOneCharRole r) + ppr SelForAll = text "All" + ppr (SelFun fs) = text "Fun" <> parens (ppr fs) + +pprOneCharRole :: Role -> SDoc +pprOneCharRole Nominal = char 'N' +pprOneCharRole Representational = char 'R' +pprOneCharRole Phantom = char 'P' + +instance Outputable FunSel where + ppr SelMult = text "mult" + ppr SelArg = text "arg" + ppr SelRes = text "res" + +instance NFData FunSel where + rnf SelMult = () + rnf SelArg = () + rnf SelRes = () + +instance Binary CoSel where + put_ bh (SelTyCon n r) = do { putByte bh 0; put_ bh n; put_ bh r } + put_ bh SelForAll = putByte bh 1 + put_ bh (SelFun SelMult) = putByte bh 2 + put_ bh (SelFun SelArg) = putByte bh 3 + put_ bh (SelFun SelRes) = putByte bh 4 + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { n <- get bh; r <- get bh; return (SelTyCon n r) } + 1 -> return SelForAll + 2 -> return (SelFun SelMult) + 3 -> return (SelFun SelArg) + _ -> return (SelFun SelRes) } + +instance NFData CoSel where + rnf (SelTyCon n r) = rnf n `seq` rnf r `seq` () + rnf SelForAll = () + rnf (SelFun fs) = rnf fs `seq` () + +-- | A semantically more meaningful type to represent what may or may not be a +-- useful 'Coercion'. +data MCoercion + = MRefl + -- A trivial Reflexivity coercion + | MCo Coercion + -- Other coercions + deriving Data.Data +type MCoercionR = MCoercion +type MCoercionN = MCoercion + +instance Outputable MCoercion where + ppr MRefl = text "MRefl" + ppr (MCo co) = text "MCo" <+> ppr co + +{- Note [Refl invariant] +~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant 1: Refl lifting + Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. + For example + (Refl T) (Refl a) (Refl b) is normalised (by mkAppCo) to (Refl (T a b)). + + You might think that a consequences is: + Every identity coercion has Refl at the root + + But that's not quite true because of coercion variables. Consider + g where g :: Int~Int + Left h where h :: Maybe Int ~ Maybe Int + etc. So the consequence is only true of coercions that + have no coercion variables. + +Invariant 2: TyConAppCo + An application of (Refl T) to some coercions, at least one of which is + NOT the identity, is normalised to TyConAppCo. (They may not be + fully saturated however.) TyConAppCo coercions (like all coercions + other than Refl) are NEVER the identity. + +Note [Generalized reflexive coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GRefl is a generalized reflexive coercion (see #15192). It wraps a kind +coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing +rules for GRefl: + + ty : k1 + ------------------------------------ + GRefl r ty MRefl: ty ~r ty + + ty : k1 co :: k1 ~ k2 + ------------------------------------ + GRefl r ty (MCo co) : ty ~r ty |> co + +Consider we have + + g1 :: s ~r t + s :: k1 + g2 :: k1 ~ k2 + +and we want to construct a coercions co which has type + + (s |> g2) ~r t + +We can define + + co = Sym (GRefl r s g2) ; g1 + +It is easy to see that + + Refl == GRefl Nominal ty MRefl :: ty ~n ty + +A nominal reflexive coercion is quite common, so we keep the special form Refl to +save allocation. + +Note [SelCo] +~~~~~~~~~~~~ +The Coercion form SelCo allows us to decompose a structural coercion, one +between ForallTys, or TyConApps, or FunTys. + +There are three forms, split by the CoSel field inside the SelCo: +SelTyCon, SelForAll, and SelFun. The typing rules below are directly +checked by the SelCo case of GHC.Core.Lint.lintCoercion. + +* SelTyCon: + + co : (T s1..sn) ~r (T t1..tn) + T is not a saturated FunTyCon (use SelFun for that) + T is injective at role r + ri = tyConRole tc r i + i < n (i is zero-indexed) + ---------------------------------- + SelCo (SelTyCon i ri) co : si ~ri ti + + "Injective at role r": see Note [SelCo and newtypes] + "Not saturated FunTyCon": see SelFun below + + See Note [SelCo Cached Roles] + +* SelForAll: + co : forall (a:k1).t1 ~r0 forall (a:k2).t2 + ---------------------------------- + SelCo SelForAll co : k1 ~N k2 + + NB: SelForAll always gives a Nominal coercion. + +* The SelFun form, for functions, has three sub-forms for the three + components of the function type (multiplicity, argument, result). + + co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) + r = funRole r0 SelMult + ---------------------------------- + SelCo (SelFun SelMult) co : m1 ~r m2 + + co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) + r = funRole r0 SelArg + ---------------------------------- + SelCo (SelFun SelArg) co : s1 ~r s2 + + co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) + r = funRole r0 SelRes + ---------------------------------- + SelCo (SelFun SelRes) co : t1 ~r t2 + +Note [FunCo] +~~~~~~~~~~~~ +Just as FunTy has a ft_af :: FunTyFlag field, FunCo (which connects +two function types) has two FunTyFlag fields: + funco_afl, funco_afr :: FunTyFlag +In all cases, the FunTyFlag is recoverable from the kinds of the argument +and result types/coercions; but experiments show that it's better to +cache it. + +Why does FunCo need /two/ flags? If we have a single method class, +implemented as a newtype + class C a where { op :: [a] -> a } +then we can have a coercion + co :: C Int ~R ([Int]->Int) +So now we can define + FunCo co : (C Int => Bool) ~R (([Int]->Int) -> Bool) +Notice that the left and right arrows are different! Hence two flags, +one for coercionLKind and one for coercionRKind. + +Note [Coercion axioms applied to coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The reason coercion axioms can be applied to coercions and not just +types is to allow for better optimization. There are some cases where +we need to be able to "push transitivity inside" an axiom in order to +expose further opportunities for optimization. + +For example, suppose we have + + C a : t[a] ~ F a + g : b ~ c + +and we want to optimize + + sym (C b) ; t[g] ; C c + +which has the kind + + F b ~ F c + +(stopping through t[b] and t[c] along the way). + +We'd like to optimize this to just F g -- but how? The key is +that we need to allow axioms to be instantiated by *coercions*, +not just by types. Then we can (in certain cases) push +transitivity inside the axiom instantiations, and then react +opposite-polarity instantiations of the same axiom. In this +case, e.g., we match t[g] against the LHS of (C c)'s kind, to +obtain the substitution a |-> g (note this operation is sort +of the dual of lifting!) and hence end up with + + C g : t[b] ~ F c + +which indeed has the same kind as t[g] ; C c. + +Now we have + + sym (C b) ; C g + +which can be optimized to F g. + +Note [Required foralls in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the CoreExpr (Lam a e) where `a` is a TyVar, and (e::e_ty). +It has type + forall a. e_ty +Note the Specified visibility of (forall a. e_ty); the Core type just isn't able +to express more than one visiblity, and we pick `Specified`. See `exprType` and +`mkLamType` in GHC.Core.Utils, and `GHC.Type.Var.coreTyLamForAllTyFlag`. + +So how can we ever get a term of type (forall a -> e_ty)? Answer: /only/ via a +cast built with ForAllCo. See `GHC.Core.Coercion.mkForAllVisCos`, +`GHC.Tc.Types.Evidence.mkWpForAllCast` and `GHC.Core.Make.mkCoreTyLams`. +This does not seem very satisfying, but it does the job. + +An alternative would be to put a visibility flag into `Lam` (a huge change), +or into a `TyVar` (a more plausible change), but we leave that for the future. + +See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare. + +Note [ForAllCo] +~~~~~~~~~~~~~~~ +See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare. + +Constructing coercions between forall-types can be a bit tricky, +because the kinds of the bound tyvars can be different. + +The typing rule is: + + G |- kind_co : k1 ~N k2 + tv1 \not\in fv(typeKind(t1),typeKind(t2)) -- Skolem escape + G, tv1:k1 |- co : t1 ~r t2 + if r=N, then vis1=vis2 + ------------------------------------ + G |- ForAllCo (tv1:k1) vis1 vis2 kind_co co + : forall (tv1:k1) . t1 + ~r + forall (tv1:k2) . (t2[tv1 |-> (tv1:k2) |> sym kind_co]) + +Several things to note here + +(FC1) First, the TyCoVar stored in a ForAllCo is really just a convenience: this + field should be a Name, as its kind is redundant. Thinking of the field as a + Name is helpful in understanding what a ForAllCo means. The kind of TyCoVar + always matches the left-hand kind of the coercion. + + * The idea is that kind_co gives the two kinds of the tyvar. See how, in the + conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. + + * Of course, a type variable can't have different kinds at the same time. + So, in `co` itself we use (tv1 : k1); hence the premise + tv1:k1 |- co : t1 ~r t2 + + * The last wrinkle is that we need to fix the kinds in the conclusion. In + t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of + the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with + (tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it + mentions the same name with different kinds, but it *is* well-kinded, noting + that `(tv1:k2) |> sym kind_co` has kind k1. + + We could instead store just a Name in the ForAllCo, and it might even be + more efficient to do so. But we can't add Names to, e.g., VarSets, and + there generally is just an impedance mismatch in a bunch of places. So we + use tv1. When we need tv2, we can use setTyVarKind. + +(FC2) Note that the kind coercion must be Nominal; and that the role `r` of + the final coercion is the same as that of the body coercion. + +(FC3) A ForAllCo allows casting between visibilities. For example: + ForAllCo a Required Specified (SubCo (Refl ty)) + : (forall a -> ty) ~R (forall a. ty) + But you can only cast between visiblities at Representational role; + Hence the premise + if r=N, then vis1=vis2 + in the typing rule. See also Note [ForAllTy and type equality] in + GHC.Core.TyCo.Compare. + +(FC4) See Note [Required foralls in Core]. + +(FC5) In a /type/, in (ForAllTy cv ty) where cv is a CoVar, we insist that + `cv` must appear free in `ty`; see Note [Unused coercion variable in ForAllTy] + in GHC.Core.TyCo.Rep for the motivation. If it does not appear free, + use FunTy. + + However we do /not/ impose the same restriction on ForAllCo in /coercions/. + Instead, in coercionLKind and coercionRKind, we use mkTyCoForAllTy to perform + the check and construct a FunTy when necessary. Why? + * For a coercion, all that matters is its kind, So ForAllCo vs FunCo does not + make a difference. + * Even if cv occurs in body_co, it is possible that cv does not occur in the kind + of body_co. Therefore the check in coercionKind is inevitable. + +(FC6) Invariant: in a ForAllCo where fco_tcv is a coercion variable, `cv`, + we insist that `cv` appears only in positions that are erased. In fact we use + a conservative approximation of this: we require that + (almostDevoidCoVarOfCo cv fco_body) + holds. This function checks that `cv` appers only within the type in a Refl + node and under a GRefl node (including in the Coercion stored in a GRefl). + It's possible other places are OK, too, but this is a safe approximation. + + Why all this fuss? See Section 5.8.5.2 of Richard's thesis. The idea is that + we cannot prove that the type system is consistent with unrestricted use of this + cv; the consistency proof uses an untyped rewrite relation that works over types + with all coercions and casts removed. So, we can allow the cv to appear only in + positions that are erased. + + Sadly, with heterogeneous equality, this restriction might be able to be + violated; Richard's thesis is unable to prove that it isn't. Specifically, the + liftCoSubst function might create an invalid coercion. Because a violation of + the restriction might lead to a program that "goes wrong", it is checked all + the time, even in a production compiler and without -dcore-lint. We *have* + proved that the problem does not occur with homogeneous equality, so this + check can be dropped once ~# is made to be homogeneous. + +(FC7) Invariant: in a ForAllCo, if fco_tcv is a CoVar, then + fco_visL = fco_visR = coreTyLamForAllTyFlag + c.f. (FT2) in Note [ForAllTy] + +Note [Predicate coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: a~b +How can we coerce between types + ([c]~a) => [a] -> c +and + ([c]~b) => [b] -> c +where the equality predicate *itself* differs? + +Answer: we simply treat (~) as an ordinary type constructor, so these +types really look like + + ((~) [c] a) -> [a] -> c + ((~) [c] b) -> [b] -> c + +So the coercion between the two is obviously + + ((~) [c] g) -> [g] -> c + +Another way to see this to say that we simply collapse predicates to +their representation type (see Type.coreView and Type.predTypeRep). + +This collapse is done by mkPredCo; there is no PredCo constructor +in Coercion. This is important because we need Nth to work on +predicates too: + SelCo (SelTyCon 1) ((~) [c] g) = g +See Simplify.simplCoercionF, which generates such selections. + +Note [Roles] +~~~~~~~~~~~~ +Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated +in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see +https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation + +Here is one way to phrase the problem: + +Given: +newtype Age = MkAge Int +type family F x +type instance F Age = Bool +type instance F Int = Char + +This compiles down to: +axAge :: Age ~ Int +axF1 :: F Age ~ Bool +axF2 :: F Int ~ Char + +Then, we can make: +(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char + +Yikes! + +The solution is _roles_, as articulated in "Generative Type Abstraction and +Type-level Computation" (POPL 2010), available at +http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf + +The specification for roles has evolved somewhat since that paper. For the +current full details, see the documentation in docs/core-spec. Here are some +highlights. + +We label every equality with a notion of type equivalence, of which there are +three options: Nominal, Representational, and Phantom. A ground type is +nominally equivalent only with itself. A newtype (which is considered a ground +type in Haskell) is representationally equivalent to its representation. +Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" +to denote the equivalences. + +The axioms above would be: +axAge :: Age ~R Int +axF1 :: F Age ~N Bool +axF2 :: F Age ~N Char + +Then, because transitivity applies only to coercions proving the same notion +of equivalence, the above construction is impossible. + +However, there is still an escape hatch: we know that any two types that are +nominally equivalent are representationally equivalent as well. This is what +the form SubCo proves -- it "demotes" a nominal equivalence into a +representational equivalence. So, it would seem the following is possible: + +sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG + +What saves us here is that the arguments to a type function F, lifted into a +coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and +we are safe. + +Roles are attached to parameters to TyCons. When lifting a TyCon into a +coercion (through TyConAppCo), we need to ensure that the arguments to the +TyCon respect their roles. For example: + +data T a b = MkT a (F b) + +If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know +that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because +the type function F branches on b's *name*, not representation. So, we say +that 'a' has role Representational and 'b' has role Nominal. The third role, +Phantom, is for parameters not used in the type's definition. Given the +following definition + +data Q a = MkQ Int + +the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we +can construct the coercion Bool ~P Char (using UnivCo). + +See the paper cited above for more examples and information. + +Note [TyConAppCo roles] +~~~~~~~~~~~~~~~~~~~~~~~ +The TyConAppCo constructor has a role parameter, indicating the role at +which the coercion proves equality. The choice of this parameter affects +the required roles of the arguments of the TyConAppCo. To help explain +it, assume the following definition: + + type instance F Int = Bool -- Axiom axF : F Int ~N Bool + newtype Age = MkAge Int -- Axiom axAge : Age ~R Int + data Foo a = MkFoo a -- Role on Foo's parameter is Representational + +TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool + For (TyConAppCo Nominal) all arguments must have role Nominal. Why? + So that Foo Age ~N Foo Int does *not* hold. + +TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool +TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int + For (TyConAppCo Representational), all arguments must have the roles + corresponding to the result of tyConRoles on the TyCon. This is the + whole point of having roles on the TyCon to begin with. So, we can + have Foo Age ~R Foo Int, if Foo's parameter has role R. + + If a Representational TyConAppCo is over-saturated (which is otherwise fine), + the spill-over arguments must all be at Nominal. This corresponds to the + behavior for AppCo. + +TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool + All arguments must have role Phantom. This one isn't strictly + necessary for soundness, but this choice removes ambiguity. + +The rules here dictate the roles of the parameters to mkTyConAppCo +(should be checked by Lint). + +Note [SelCo and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype N a = MkN Int + type role N representational + +This yields axiom + + NTCo:N :: forall a. N a ~R Int + +We can then build + + co :: forall a b. N a ~R N b + co = NTCo:N a ; sym (NTCo:N b) + +for any `a` and `b`. Because of the role annotation on N, if we use +SelCo, we'll get out a representational coercion. That is: + + SelCo (SelTyCon 0 r) co :: forall a b. a ~r b + +Yikes! Clearly, this is terrible. The solution is simple: forbid +SelCo to be used on newtypes if the internal coercion is representational. +More specifically, we use isInjectiveTyCon to determine whether +T is injective at role r: +* Newtypes and datatypes are both injective at Nominal role, but +* Newtypes are not injective at Representational role +See the SelCo equation for GHC.Core.Lint.lintCoercion. + +This is not just some corner case discovered by a segfault somewhere; +it was discovered in the proof of soundness of roles and described +in the "Safe Coercions" paper (ICFP '14). + +Note [SelCo Cached Roles] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we cache the role of SelCo in the SelCo constructor? +Because computing role(Nth i co) involves figuring out that + + co :: T tys1 ~ T tys2 + +using coercionKind, and finding (coercionRole co), and then looking +at the tyConRoles of T. Avoiding bad asymptotic behaviour here means +we have to compute the kind and role of a coercion simultaneously, +which makes the code complicated and inefficient. + +This only happens for SelCo. Caching the role solves the problem, and +allows coercionKind and coercionRole to be simple. + +See #11735 + +Note [InstCo roles] +~~~~~~~~~~~~~~~~~~~ +Here is (essentially) the typing rule for InstCo: + +g :: (forall a. t1) ~r (forall a. t2) +w :: s1 ~N s2 +------------------------------- InstCo +InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) + +Note that the Coercion w *must* be nominal. This is necessary +because the variable a might be used in a "nominal position" +(that is, a place where role inference would require a nominal +role) in t1 or t2. If we allowed w to be representational, we +could get bogus equalities. + +A more nuanced treatment might be able to relax this condition +somewhat, by checking if t1 and/or t2 use their bound variables +in nominal ways. If not, having w be representational is OK. + + +%************************************************************************ +%* * + UnivCo +%* * +%************************************************************************ + +Note [UnivCo] +~~~~~~~~~~~~~ +A UnivCo is a coercion whose proof does not directly express its role +and kind (indeed for some UnivCos, like PluginProv, there /is/ no proof). + +The different kinds of UnivCo are described by UnivCoProvenance. Really each +is entirely separate, but they all share the need to represent these fields: + + UnivCo + { uco_prov :: UnivCoProvenance + , uco_role :: Role + , uco_lty, uco_rty :: Type + , uco_deps :: [Coercion] -- Coercions on which it depends + +Here, + * uco_role, uco_lty, uco_rty express the type of the coercion + * uco_prov says where it came from + * uco_deps specifies the coercions on which this proof (which is not + explicity given) depends. See + Note [The importance of tracking UnivCo dependencies] +-} + +-- | For simplicity, we have just one UnivCo that represents a coercion from +-- some type to some other type, with (in general) no restrictions on the +-- type. The UnivCoProvenance specifies more exactly what the coercion really +-- is and why a program should (or shouldn't!) trust the coercion. +-- It is reasonable to consider each constructor of 'UnivCoProvenance' +-- as a totally independent coercion form; their only commonality is +-- that they don't tell you what types they coercion between. (That info +-- is in the 'UnivCo' constructor of 'Coercion'. +data UnivCoProvenance + = PhantomProv -- ^ See Note [Phantom coercions]. Only in Phantom + -- roled coercions + + | ProofIrrelProv -- ^ From the fact that any two coercions are + -- considered equivalent. See Note [ProofIrrelProv]. + -- Can be used in Nominal or Representational coercions + + | PluginProv String + -- ^ From a plugin, which asserts that this coercion is sound. + -- The string and the variable set are for the use by the plugin. + + deriving (Eq, Ord, Data.Data) + -- Why Ord? See Note [Ord instance of IfaceType] in GHC.Iface.Type + +instance Outputable UnivCoProvenance where + ppr PhantomProv = text "(phantom)" + ppr (ProofIrrelProv {}) = text "(proof irrel)" + ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) + +instance NFData UnivCoProvenance where + rnf p = p `seq` () + +instance Binary UnivCoProvenance where + put_ bh PhantomProv = putByte bh 1 + put_ bh ProofIrrelProv = putByte bh 2 + put_ bh (PluginProv a) = putByte bh 3 >> put_ bh a + get bh = do + tag <- getByte bh + case tag of + 1 -> return PhantomProv + 2 -> return ProofIrrelProv + 3 -> do a <- get bh + return $ PluginProv a + _ -> panic ("get UnivCoProvenance " ++ show tag) + + +{- Note [Phantom coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = T1 | T2 +Then we have + T s ~R T t +for any old s,t. The witness for this is (TyConAppCo T Rep co), +where (co :: s ~P t) is a phantom coercion built with PhantomProv. +The role of the UnivCo is always Phantom. The Coercion stored is the +(nominal) kind coercion between the types + kind(s) ~N kind (t) + +Note [ProofIrrelProv] +~~~~~~~~~~~~~~~~~~~~~ +A ProofIrrelProv is a coercion between coercions. For example: + + data G a where + MkG :: G Bool + +In core, we get + + G :: * -> * + MkG :: forall (a :: *). (a ~# Bool) -> G a + +Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want +a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be + + TyConAppCo Nominal MkG [co3, co4] + where + co3 :: co1 ~ co2 + co4 :: a1 ~ a2 + +Note that + co1 :: a1 ~ Bool + co2 :: a2 ~ Bool + +Here, + co3 = UnivCo ProofIrrelProv Nominal (CoercionTy co1) (CoercionTy co2) [co5] + where + co5 :: (a1 ~# Bool) ~# (a2 ~# Bool) + co5 = TyConAppCo Nominal (~#) [, , co4, ] + + +Note [The importance of tracking UnivCo dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is vital that `UnivCo` (a coercion that lacks a proper proof) +tracks the coercions on which it depends. To see why, consider this program: + + type S :: Nat -> Nat + + data T (a::Nat) where + T1 :: T 0 + T2 :: ... + + f :: T a -> S (a+1) -> S 1 + f = /\a (x:T a) (y:a). + case x of + T1 (gco : a ~# 0) -> y |> wco + +For this to typecheck we need `wco :: S (a+1) ~# S 1`, given that `gco : a ~# 0`. +To prove that we need to know that `a+1 = 1` if `a=0`, which a plugin might know. +So it solves `wco` by providing a `UnivCo (PluginProv "my-plugin") (a+1) 1 [gco]`. + + But the `uco_deps` in `PluginProv` must mention `gco`! + +Why? Otherwise we might float the entire expression (y |> wco) out of the +the case alternative for `T1` which brings `gco` into scope. If this +happens then we aren't far from a segmentation fault or much worse. +See #23923 for a real-world example of this happening. + +So it is /crucial/ for the `UnivCo` to mention, in `uco_deps`, the coercion +variables used by the plugin to justify the `UnivCo` that it builds. You +should think of it like `TyConAppCo`: the `UnivCo` proof constructor is +applied to a list of coercions, just as `TyConAppCo` is + +It's very convenient to record a full coercion, not just a set of free coercion +variables, because during typechecking those coercions might contain coercion +holes `HoleCo`, which get filled in later. +-} + +{- ********************************************************************** +%* * + Coercion holes +%* * +%********************************************************************* -} + +-- | A coercion to be filled in by the type-checker. See Note [Coercion holes] +data CoercionHole + = CoercionHole { ch_co_var :: CoVar + -- See Note [CoercionHoles and coercion free variables] + + , ch_ref :: IORef (Maybe Coercion) + } + +coHoleCoVar :: CoercionHole -> CoVar +coHoleCoVar = ch_co_var + +setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole +setCoHoleCoVar h cv = h { ch_co_var = cv } + +instance Data.Data CoercionHole where + -- don't traverse? + toConstr _ = abstractConstr "CoercionHole" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoercionHole" + +instance Outputable CoercionHole where + ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) + +instance Uniquable CoercionHole where + getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv + +{- Note [Coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~ +During typechecking, constraint solving for type classes works by + - Generate an evidence Id, d7 :: Num a + - Wrap it in a Wanted constraint, [W] d7 :: Num a + - Use the evidence Id where the evidence is needed + - Solve the constraint later + - When solved, add an enclosing let-binding let d7 = .... in .... + which actually binds d7 to the (Num a) evidence + +For equality constraints we use a different strategy. See Note [The +equality types story] in GHC.Builtin.Types.Prim for background on equality constraints. + - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just + like type classes above. (Indeed, boxed equality constraints *are* classes.) + - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2) + we use a different plan + +For unboxed equalities: + - Generate a CoercionHole, a mutable variable just like a unification + variable + - Wrap the CoercionHole in a Wanted constraint; see GHC.Tc.Utils.TcEvDest + - Use the CoercionHole in a Coercion, via HoleCo + - Solve the constraint later + - When solved, fill in the CoercionHole by side effect, instead of + doing the let-binding thing + +The main reason for all this is that there may be no good place to let-bind +the evidence for unboxed equalities: + + - We emit constraints for kind coercions, to be used to cast a + type's kind. These coercions then must be used in types. Because + they might appear in a top-level type, there is no place to bind + these (unlifted) coercions in the usual way. + + - A coercion for (forall a. t1) ~ (forall a. t2) will look like + forall a. (coercion for t1~t2) + But the coercion for (t1~t2) may mention 'a', and we don't have + let-bindings within coercions. We could add them, but coercion + holes are easier. + + - Moreover, nothing is lost from the lack of let-bindings. For + dictionaries want to achieve sharing to avoid recomputing the + dictionary. But coercions are entirely erased, so there's little + benefit to sharing. Indeed, even if we had a let-binding, we + always inline types and coercions at every use site and drop the + binding. + +Other notes about HoleCo: + + * INVARIANT: CoercionHole and HoleCo are used only during type checking, + and should never appear in Core. Just like unification variables; a Type + can contain a TcTyVar, but only during type checking. If, one day, we + use type-level information to separate out forms that can appear during + type-checking vs forms that can appear in core proper, holes in Core will + be ruled out. + + * See Note [CoercionHoles and coercion free variables] + + * Coercion holes can be compared for equality like other coercions: + by looking at the types coerced. + + +Note [CoercionHoles and coercion free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why does a CoercionHole contain a CoVar, as well as reference to +fill in? Because we want to treat that CoVar as a free variable of +the coercion. See #14584, and Note [What prevents a +constraint from floating] in GHC.Tc.Solver, item (4): + + forall k. [W] co1 :: t1 ~# t2 |> co2 + [W] co2 :: k ~# * + +Here co2 is a CoercionHole. But we /must/ know that it is free in +co1, because that's all that stops it floating outside the +implication. +-} + + + +{- ********************************************************************* +* * + foldType and foldCoercion +* * +********************************************************************* -} + +{- Note [foldType] +~~~~~~~~~~~~~~~~~~ +foldType is a bit more powerful than perhaps it looks: + +* You can fold with an accumulating parameter, via + TyCoFolder env (Endo a) + Recall newtype Endo a = Endo (a->a) + +* You can fold monadically with a monad M, via + TyCoFolder env (M a) + provided you have + instance .. => Monoid (M a) + +Note [mapType vs foldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define foldType here, but mapType in module Type. Why? + +* foldType is used in GHC.Core.TyCo.FVs for finding free variables. + It's a very simple function that analyses a type, + but does not construct one. + +* mapType constructs new types, and so it needs to call + the "smart constructors", mkAppTy, mkCastTy, and so on. + These are sophisticated functions, and can't be defined + here in GHC.Core.TyCo.Rep. + +Note [Specialising foldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We inline foldType at every call site (there are not many), so that it +becomes specialised for the particular monoid *and* TyCoFolder at +that site. This is just for efficiency, but walking over types is +done a *lot* in GHC, so worth optimising. + +We were worried that + TyCoFolder env (Endo a) +might not eta-expand. Recall newtype Endo a = Endo (a->a). + +In particular, given + fvs :: Type -> TyCoVarSet + fvs ty = appEndo (foldType tcf emptyVarSet ty) emptyVarSet + + tcf :: TyCoFolder enf (Endo a) + tcf = TyCoFolder { tcf_tyvar = do_tv, ... } + where + do_tvs is tv = Endo do_it + where + do_it acc | tv `elemVarSet` is = acc + | tv `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` tv + +we want to end up with + fvs ty = go emptyVarSet ty emptyVarSet + where + go env (TyVarTy tv) acc = acc `extendVarSet` tv + ..etc.. + +And indeed this happens. + - Selections from 'tcf' are done at compile time + - 'go' is nicely eta-expanded. + +We were also worried about + deep_fvs :: Type -> TyCoVarSet + deep_fvs ty = appEndo (foldType deep_tcf emptyVarSet ty) emptyVarSet + + deep_tcf :: TyCoFolder enf (Endo a) + deep_tcf = TyCoFolder { tcf_tyvar = do_tv, ... } + where + do_tvs is tv = Endo do_it + where + do_it acc | tv `elemVarSet` is = acc + | tv `elemVarSet` acc = acc + | otherwise = deep_fvs (varType tv) + `unionVarSet` acc + `extendVarSet` tv + +Here deep_fvs and deep_tcf are mutually recursive, unlike fvs and tcf. +But, amazingly, we get good code here too. GHC is careful not to mark +TyCoFolder data constructor for deep_tcf as a loop breaker, so the +record selections still cancel. And eta expansion still happens too. + +Note [Use explicit recursion in foldTyCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In foldTyCo you'll see things like: + go_tys _ [] = mempty + go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts +where we use /explicit recursion/. You might wonder about using foldl instead: + go_tys env = foldl (\t acc -> go_ty env t `mappend` acc) mempty +Or maybe foldl', or foldr. + +But don't do that for two reasons (see #24591) + +* We sometimes instantiate `a` to (Endo VarSet). Remembering + newtype Endo a = Endo (a->a) + after inlining `foldTyCo` bodily, the explicit recursion looks like + go_tys _ [] = \acc -> acc + go_tys env (t:ts) = \acc -> go_ty env t (go_tys env ts acc) + The strictness analyser has no problem spotting that this function is + strict in `acc`, provided `go_ty` is. + + But in the foldl form that is /much/ less obvious, and the strictness + analyser fails utterly. Result: lots and lots of thunks get built. In + !12037, Mikolaj found that GHC allocated /six times/ as much heap + on test perf/compiler/T9198 as a result of this single problem! + +* Second, while I think that using `foldr` would be fine (simple experiments in + #24591 suggest as much), it builds a local loop (with env free) and I'm not 100% + confident it'll be lambda lifted in the end. It seems more direct just to write + the code we want. + + On the other hand in `go_cvs` we might hope that the `foldr` will fuse with the + `dVarSetElems` so I have used `foldr`. +-} + +data TyCoFolder env a + = TyCoFolder + { tcf_view :: Type -> Maybe Type -- Optional "view" function + -- E.g. expand synonyms + , tcf_tyvar :: env -> TyVar -> a -- Does not automatically recur + , tcf_covar :: env -> CoVar -> a -- into kinds of variables + , tcf_hole :: env -> CoercionHole -> a + -- ^ What to do with coercion holes. + -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". + + , tcf_tycobinder :: env -> TyCoVar -> ForAllTyFlag -> env + -- ^ The returned env is used in the extended scope + } + +{-# INLINE foldTyCo #-} -- See Note [Specialising foldType] +foldTyCo :: Monoid a => TyCoFolder env a -> env + -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a) +foldTyCo (TyCoFolder { tcf_view = view + , tcf_tyvar = tyvar + , tcf_tycobinder = tycobinder + , tcf_covar = covar + , tcf_hole = cohole }) env + = (go_ty env, go_tys env, go_co env, go_cos env) + where + go_ty env ty | Just ty' <- view ty = go_ty env ty' + go_ty env (TyVarTy tv) = tyvar env tv + go_ty env (AppTy t1 t2) = go_ty env t1 `mappend` go_ty env t2 + go_ty _ (LitTy {}) = mempty + go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co + go_ty env (CoercionTy co) = go_co env co + go_ty env (FunTy _ w arg res) = go_ty env w `mappend` go_ty env arg `mappend` go_ty env res + go_ty env (TyConApp _ tys) = go_tys env tys + go_ty env (ForAllTy (Bndr tv vis) inner) + = let !env' = tycobinder env tv vis -- Avoid building a thunk here + in go_ty env (varType tv) `mappend` go_ty env' inner + + -- See Note [Use explicit recursion in foldTyCo] + go_tys _ [] = mempty + go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts + + -- See Note [Use explicit recursion in foldTyCo] + go_cos _ [] = mempty + go_cos env (c:cs) = go_co env c `mappend` go_cos env cs + + go_co env (Refl ty) = go_ty env ty + go_co env (GRefl _ ty MRefl) = go_ty env ty + go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co + go_co env (TyConAppCo _ _ args) = go_cos env args + go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (CoVarCo cv) = covar env cv + go_co env (AxiomCo _ cos) = go_cos env cos + go_co env (HoleCo hole) = cohole env hole + go_co env (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = go_ty env t1 `mappend` go_ty env t2 + `mappend` go_cos env deps + go_co env (SymCo co) = go_co env co + go_co env (TransCo c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (SelCo _ co) = go_co env co + go_co env (LRCo _ co) = go_co env co + go_co env (InstCo co arg) = go_co env co `mappend` go_co env arg + go_co env (KindCo co) = go_co env co + go_co env (SubCo co) = go_co env co + + go_co env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 }) + = go_co env cw `mappend` go_co env c1 `mappend` go_co env c2 + + go_co env (ForAllCo tv _vis1 _vis2 kind_co co) + = go_co env kind_co `mappend` go_ty env (varType tv) + `mappend` go_co env' co + where + env' = tycobinder env tv Inferred + +-- | A view function that looks through nothing. +noView :: Type -> Maybe Type +noView _ = Nothing + +{- ********************************************************************* +* * + typeSize, coercionSize +* * +********************************************************************* -} + +-- NB: We put typeSize/coercionSize here because they are mutually +-- recursive, and have the CPR property. If we have mutual +-- recursion across a hi-boot file, we don't get the CPR property +-- and these functions allocate a tremendous amount of rubbish. +-- It's not critical (because typeSize is really only used in +-- debug mode, but I tripped over an example (T5642) in which +-- typeSize was one of the biggest single allocators in all of GHC. +-- And it's easy to fix, so I did. + +-- NB: typeSize does not respect `eqType`, in that two types that +-- are `eqType` may return different sizes. This is OK, because this +-- function is used only in reporting, not decision-making. + +typeSize :: Type -> Int +-- The size of the syntax tree of a type. No special treatment +-- for type synonyms or type families. +typeSize (LitTy {}) = 1 +typeSize (TyVarTy {}) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (FunTy _ _ t1 t2) = typeSize t1 + typeSize t2 +typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t +typeSize (TyConApp _ ts) = 1 + typesSize ts +typeSize (CastTy ty co) = typeSize ty + coercionSize co +typeSize (CoercionTy co) = coercionSize co + +typesSize :: [Type] -> Int +typesSize tys = foldr ((+) . typeSize) 0 tys + +coercionSize :: Coercion -> Int +coercionSize (Refl ty) = typeSize ty +coercionSize (GRefl _ ty MRefl) = typeSize ty +coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co +coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) +coercionSize (AppCo co arg) = coercionSize co + coercionSize arg +coercionSize (ForAllCo { fco_kind = h, fco_body = co }) + = 1 + coercionSize co + coercionSize h +coercionSize (FunCo _ _ _ w c1 c2) = 1 + coercionSize c1 + coercionSize c2 + + coercionSize w +coercionSize (CoVarCo _) = 1 +coercionSize (HoleCo _) = 1 +coercionSize (AxiomCo _ cs) = 1 + sum (map coercionSize cs) +coercionSize (UnivCo { uco_lty = t1, uco_rty = t2 }) = 1 + typeSize t1 + typeSize t2 +coercionSize (SymCo co) = 1 + coercionSize co +coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (SelCo _ co) = 1 + coercionSize co +coercionSize (LRCo _ co) = 1 + coercionSize co +coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg +coercionSize (KindCo co) = 1 + coercionSize co +coercionSize (SubCo co) = 1 + coercionSize co + +{- +************************************************************************ +* * + Multiplicities +* * +************************************************************************ + +These definitions are here to avoid module loops, and to keep +GHC.Core.Multiplicity above this module. + +-} + +-- | A shorthand for data with an attached 'Mult' element (the multiplicity). +data Scaled a = Scaled !Mult a + deriving (Data.Data) + -- You might think that this would be a natural candidate for + -- Functor, Traversable but Krzysztof says (!3674) "it was too easy + -- to accidentally lift functions (substitutions, zonking etc.) from + -- Type -> Type to Scaled Type -> Scaled Type, ignoring + -- multiplicities and causing bugs". So we don't. + -- + -- Being strict in a is worse for performance, so we are only strict on the + -- Mult part of scaled. + + +instance (Outputable a) => Outputable (Scaled a) where + ppr (Scaled _cnt t) = ppr t + -- Do not print the multiplicity here because it tends to be too verbose + +scaledMult :: Scaled a -> Mult +scaledMult (Scaled m _) = m + +scaledThing :: Scaled a -> a +scaledThing (Scaled _ t) = t + +-- | Apply a function to both the Mult and the Type in a 'Scaled Type' +mapScaledType :: (Type -> Type) -> Scaled Type -> Scaled Type +mapScaledType f (Scaled m t) = Scaled (f m) (f t) + +{- | +Mult is a type alias for Type. + +Mult must contain Type because multiplicity variables are mere type variables +(of kind Multiplicity) in Haskell. So the simplest implementation is to make +Mult be Type. + +Multiplicities can be formed with: +- One: GHC.Types.One (= oneDataCon) +- Many: GHC.Types.Many (= manyDataCon) +- Multiplication: GHC.Types.MultMul (= multMulTyCon) + +So that Mult feels a bit more structured, we provide pattern synonyms and smart +constructors for these. +-} +type Mult = Type diff --git a/GHC/Core/TyCo/Rep.hs-boot b/GHC/Core/TyCo/Rep.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Rep.hs-boot @@ -0,0 +1,43 @@ +{-# LANGUAGE NoPolyKinds #-} +module GHC.Core.TyCo.Rep where + +import GHC.Utils.Outputable ( Outputable ) +import Data.Data ( Data ) +import {-# SOURCE #-} GHC.Types.Var( Var, VarBndr, FunTyFlag ) +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import Language.Haskell.Syntax.Specificity (ForAllTyFlag) + +data Type +data Coercion +data FunSel +data CoSel +data UnivCoProvenance +data TyLit +data MCoercion + +data Scaled a +scaledThing :: Scaled a -> a + +type Mult = Type + +type PredType = Type +type RuntimeRepType = Type +type Kind = Type +type ThetaType = [PredType] +type CoercionN = Coercion +type MCoercionN = MCoercion + +mkForAllTy :: VarBndr Var ForAllTyFlag -> Type -> Type +mkNakedTyConTy :: TyCon -> Type +mkNakedFunTy :: FunTyFlag -> Type -> Type -> Type + + +-- To support Data instances in GHC.Core.Coercion.Axiom +instance Data Type + +-- To support instances PiTyBinder in Var +instance Data a => Data (Scaled a) + +-- To support debug pretty-printing +instance Outputable Type +instance Outputable a => Outputable (Scaled a) diff --git a/GHC/Core/TyCo/Subst.hs b/GHC/Core/TyCo/Subst.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Subst.hs @@ -0,0 +1,1121 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +Type and Coercion - friends' interface +-} + + + +-- | Substitution into types and coercions. +module GHC.Core.TyCo.Subst + ( + -- * Substitutions + Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv, + emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst, + emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst, + mkSubst, mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst, + getTvSubstEnv, getIdSubstEnv, + getCvSubstEnv, substInScopeSet, setInScope, getSubstRangeTyCoFVs, + isInScope, elemSubst, notElemSubst, zapSubst, + extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, + extendTCvSubst, extendTCvSubstWithClone, + extendCvSubst, extendCvSubstWithClone, + extendTvSubst, extendTvSubstWithClone, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + unionSubst, zipTyEnv, zipCoEnv, + zipTvSubst, zipCvSubst, + zipTCvSubst, + mkTvSubstPrs, + + substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, + substCoWith, + substTy, substTyAddInScope, substScaledTy, + substTyUnchecked, substTysUnchecked, substScaledTysUnchecked, substThetaUnchecked, + substTyWithUnchecked, substScaledTyUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTyWithInScope, + substTys, substScaledTys, substTheta, + lookupTyVar, + substCo, substCos, substCoVar, substCoVars, lookupCoVar, + cloneTyVarBndr, cloneTyVarBndrs, + substVarBndr, substVarBndrs, + substTyVarBndr, substTyVarBndrs, + substCoVarBndr, substDCoVarSet, + substTyVar, substTyVars, substTyVarToTyVar, + substTyCoVars, + substTyCoBndr, substForAllCoBndr, + substVarBndrUsing, substForAllCoBndrUsing, + checkValidSubst, isValidTCvSubst, + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.Type + ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp, getTyVar_maybe ) +import {-# SOURCE #-} GHC.Core.Coercion + ( mkCoVarCo, mkKindCo, mkSelCo, mkTransCo + , mkNomReflCo, mkSubCo, mkSymCo + , mkFunCo2, mkForAllCo, mkUnivCo + , mkAxiomCo, mkAppCo, mkGReflCo + , mkInstCo, mkLRCo, mkTyConAppCo + , mkCoercionType + , coercionLKind, coVarTypesRole ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) +import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr +import {-# SOURCE #-} GHC.Core ( CoreExpr ) + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs + +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc +import GHC.Types.Unique.Supply +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.List (mapAccumL) + +{- +%************************************************************************ +%* * + Substitutions + Data type defined here to avoid unnecessary mutual recursion +%* * +%************************************************************************ +-} + +-- | Type & coercion & id substitution +-- +-- The "Subst" data type defined in this module contains substitution +-- for tyvar, covar and id. However, operations on IdSubstEnv (mapping +-- from "Id" to "CoreExpr") that require the definition of the "Expr" +-- data type are defined in GHC.Core.Subst to avoid circular module +-- dependency. +data Subst + = Subst InScopeSet -- Variables in scope (both Ids and TyVars) /after/ + -- applying the substitution + IdSubstEnv -- Substitution from InId to OutExpr + TvSubstEnv -- Substitution from InTyVar to OutType + CvSubstEnv -- Substitution from InCoVar to OutCoercion + + -- INVARIANT 1: See Note [The substitution invariant] + -- This is what lets us deal with name capture properly + -- + -- INVARIANT 2: The substitution is apply-once; + -- see Note [Substitutions apply only once] + -- + -- INVARIANT 3: See Note [Extending the IdSubstEnv] in "GHC.Core.Subst" + -- and Note [Extending the TvSubstEnv and CvSubstEnv] + -- + -- INVARIANT 4: See Note [Substituting types, coercions, and expressions] + +-- | A substitution of 'Expr's for non-coercion 'Id's +type IdSubstEnv = IdEnv CoreExpr -- Domain is NonCoVarIds, i.e. not coercions + +-- | A substitution of 'Type's for 'TyVar's +-- and 'Kind's for 'KindVar's +type TvSubstEnv = TyVarEnv Type + -- NB: A TvSubstEnv is used + -- both inside a TCvSubst (with the apply-once invariant + -- discussed in Note [Substitutions apply only once], + -- and also independently in the middle of matching, + -- and unification (see Types.Unify). + -- So you have to look at the context to know if it's idempotent or + -- apply-once or whatever + +-- | A substitution of 'Coercion's for 'CoVar's +type CvSubstEnv = CoVarEnv Coercion + +{- Note [The substitution invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When calling (substTy subst ty) it should be the case that +the in-scope set in the substitution is a superset of both: + + (SIa) The free vars of the range of the substitution + (SIb) The free vars of ty minus the domain of the substitution + +* Reason for (SIa). Consider + substTy [a :-> Maybe b] (forall b. b->a) + we must rename the forall b, to get + forall b2. b2 -> Maybe b + Making 'b' part of the in-scope set forces this renaming to + take place. + +* Reason for (SIb). Consider + substTy [a :-> Maybe b] (forall b. (a,b,x)) + Then if we use the in-scope set {b}, satisfying (SIa), there is + a danger we will rename the forall'd variable to 'x' by mistake, + getting this: + forall x. (Maybe b, x, x) + Breaking (SIb) caused the bug from #11371. + +Note: if the free vars of the range of the substitution are freshly created, +then the problems of (SIa) can't happen, and so it would be sound to +ignore (SIa). + +Note [Substitutions apply only once] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use TCvSubsts to instantiate things, and we might instantiate + forall a b. ty +with the types + [a, b], or [b, a]. +So the substitution might go [a->b, b->a]. A similar situation arises in Core +when we find a beta redex like + (/\ a /\ b -> e) b a +Then we also end up with a substitution that permutes type variables. Other +variations happen to; for example [a -> (a, b)]. + + ******************************************************** + *** So a substitution must be applied precisely once *** + ******************************************************** + +A TCvSubst is not idempotent, but, unlike the non-idempotent substitution +we use during unifications, it must not be repeatedly applied. + +Note [Extending the TvSubstEnv and CvSubstEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TvSubstEnv and CvSubstEnv have a binding for each TyCoVar + - whose unique has changed, OR + - whose kind has changed + +This invariant allows a short-cut when the subst envs are empty: +if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) +holds --- then (substTy subst ty) does nothing. + +For example, consider: + (/\a. /\b:(a~Int). ...b..) Int +We substitute Int for 'a'. The Unique of 'b' does not change, but +nevertheless we add 'b' to the TvSubstEnv, because b's kind does change + +This invariant has several crucial consequences: + +* In substVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed + +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough + +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty + +Note [Substituting types, coercions, and expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Types and coercions are mutually recursive, and either may have variables +"belonging" to the other. Thus, every time we wish to substitute in a +type, we may also need to substitute in a coercion, and vice versa. +Likewise, expressions may contain type variables or coercion variables. +However, we use different constructors for constructing expression variables, +coercion variables, and type variables, so we carry three VarEnvs for each +variable type. Note that it would be possible to use the CoercionTy constructor +and the Type constructor to combine these environments, but that seems like a +false economy. + +Note that the domain of the VarEnvs must be respected, despite the fact that +TyVar, Id, and CoVar are all type synonyms of the Var type. For example, +TvSubstEnv should *never* map a CoVar (built with the Id constructor) +and the CvSubstEnv should *never* map a TyVar. Furthermore, the range +of the TvSubstEnv should *never* include a type headed with +CoercionTy. +-} + +emptyIdSubstEnv :: IdSubstEnv +emptyIdSubstEnv = emptyVarEnv + +emptyTvSubstEnv :: TvSubstEnv +emptyTvSubstEnv = emptyVarEnv + +emptyCvSubstEnv :: CvSubstEnv +emptyCvSubstEnv = emptyVarEnv + +-- | Composes two substitutions, applying the second one provided first, +-- like in function composition. This function leaves IdSubstEnv untouched +-- because IdSubstEnv is not used during substitution for types. +composeTCvSubst :: Subst -> Subst -> Subst +composeTCvSubst subst1@(Subst is1 ids1 tenv1 cenv1) (Subst is2 _ tenv2 cenv2) + = Subst is3 ids1 tenv3 cenv3 + where + is3 = is1 `unionInScope` is2 + tenv3 = tenv1 `plusVarEnv` mapVarEnv (substTy extended_subst1) tenv2 + cenv3 = cenv1 `plusVarEnv` mapVarEnv (substCo extended_subst1) cenv2 + + -- Make sure the in-scope set in the first substitution is wide enough to + -- cover the free variables in the range of the second substitution before + -- applying it (#22235). + extended_subst1 = subst1 `setInScope` is3 + +emptySubst :: Subst +emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv + +mkEmptySubst :: InScopeSet -> Subst +mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv + +isEmptySubst :: Subst -> Bool +isEmptySubst (Subst _ id_env tv_env cv_env) + = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env + +-- | Checks whether the tyvar and covar environments are empty. +-- This function should be used over 'isEmptySubst' when substituting +-- for types, because types currently do not contain expressions; we can +-- safely disregard the expression environment when deciding whether +-- to skip a substitution. Using 'isEmptyTCvSubst' gives us a non-trivial +-- performance boost (up to 70% less allocation for T18223) +isEmptyTCvSubst :: Subst -> Bool +isEmptyTCvSubst (Subst _ _ tv_env cv_env) + = isEmptyVarEnv tv_env && isEmptyVarEnv cv_env + +mkSubst :: InScopeSet -> IdSubstEnv -> TvSubstEnv -> CvSubstEnv -> Subst +mkSubst = Subst + +mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst +mkTCvSubst in_scope tvs cvs = Subst in_scope emptyIdSubstEnv tvs cvs + +mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst +mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv + +mkTvSubst :: InScopeSet -> TvSubstEnv -> Subst +-- ^ Make a TCvSubst with specified tyvar subst and empty covar subst +mkTvSubst in_scope tenv = Subst in_scope emptyIdSubstEnv tenv emptyCvSubstEnv + +mkCvSubst :: InScopeSet -> CvSubstEnv -> Subst +-- ^ Make a TCvSubst with specified covar subst and empty tyvar subst +mkCvSubst in_scope cenv = Subst in_scope emptyIdSubstEnv emptyTvSubstEnv cenv + +getIdSubstEnv :: Subst -> IdSubstEnv +getIdSubstEnv (Subst _ ids _ _) = ids + +getTvSubstEnv :: Subst -> TvSubstEnv +getTvSubstEnv (Subst _ _ tenv _) = tenv + +getCvSubstEnv :: Subst -> CvSubstEnv +getCvSubstEnv (Subst _ _ _ cenv) = cenv + +-- | Find the in-scope set: see Note [The substitution invariant] +substInScopeSet :: Subst -> InScopeSet +substInScopeSet (Subst in_scope _ _ _) = in_scope + +setInScope :: Subst -> InScopeSet -> Subst +setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs + +-- | Returns the free variables of the types in the range of a substitution as +-- a non-deterministic set. +getSubstRangeTyCoFVs :: Subst -> VarSet +getSubstRangeTyCoFVs (Subst _ _ tenv cenv) + = tenvFVs `unionVarSet` cenvFVs + where + tenvFVs = shallowTyCoVarsOfTyVarEnv tenv + cenvFVs = shallowTyCoVarsOfCoVarEnv cenv + +isInScope :: Var -> Subst -> Bool +isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope + +elemSubst :: Var -> Subst -> Bool +elemSubst v (Subst _ ids tenv cenv) + | isTyVar v + = v `elemVarEnv` tenv + | isCoVar v + = v `elemVarEnv` cenv + | otherwise + = v `elemVarEnv` ids + +notElemSubst :: Var -> Subst -> Bool +notElemSubst v = not . elemSubst v + +-- | Remove all substitutions that might have been built up +-- while preserving the in-scope set +-- originally called zapSubstEnv +zapSubst :: Subst -> Subst +zapSubst (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv + +-- | Add the 'Var' to the in-scope set +extendSubstInScope :: Subst -> Var -> Subst +extendSubstInScope (Subst in_scope ids tvs cvs) v + = Subst (in_scope `extendInScopeSet` v) + ids tvs cvs + +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendSubstInScopeList :: Subst -> [Var] -> Subst +extendSubstInScopeList (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + ids tvs cvs + +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendSubstInScopeSet :: Subst -> VarSet -> Subst +extendSubstInScopeSet (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetSet` vs) + ids tvs cvs + +extendTCvSubst :: Subst -> TyCoVar -> Type -> Subst +extendTCvSubst subst v ty + | isTyVar v + = extendTvSubst subst v ty + | CoercionTy co <- ty + = extendCvSubst subst v co + | otherwise + = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) + +extendTCvSubstWithClone :: Subst -> TyCoVar -> TyCoVar -> Subst +extendTCvSubstWithClone subst tcv + | isTyVar tcv = extendTvSubstWithClone subst tcv + | otherwise = extendCvSubstWithClone subst tcv + +-- | Add a substitution for a 'TyVar' to the 'Subst' +-- The 'TyVar' *must* be a real TyVar, and not a CoVar +-- You must ensure that the in-scope set is such that +-- Note [The substitution invariant] holds +-- after extending the substitution like this. +extendTvSubst :: Subst -> TyVar -> Type -> Subst +extendTvSubst (Subst in_scope ids tvs cvs) tv ty + = assert (isTyVar tv) $ + Subst in_scope ids (extendVarEnv tvs tv ty) cvs + +extendTvSubstWithClone :: Subst -> TyVar -> TyVar -> Subst +-- Adds a new tv -> tv mapping, /and/ extends the in-scope set with the clone +-- Does not look in the kind of the new variable; +-- those variables should be in scope already +extendTvSubstWithClone (Subst in_scope idenv tenv cenv) tv tv' + = Subst (extendInScopeSet in_scope tv') + idenv + (extendVarEnv tenv tv (mkTyVarTy tv')) + cenv + +-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': +-- you must ensure that the in-scope set satisfies +-- Note [The substitution invariant] +-- after extending the substitution like this +extendCvSubst :: Subst -> CoVar -> Coercion -> Subst +extendCvSubst (Subst in_scope ids tvs cvs) v r + = assert (isCoVar v) $ + Subst in_scope ids tvs (extendVarEnv cvs v r) + +extendCvSubstWithClone :: Subst -> CoVar -> CoVar -> Subst +extendCvSubstWithClone (Subst in_scope ids tenv cenv) cv cv' + = Subst (extendInScopeSetSet in_scope new_in_scope) + ids + tenv + (extendVarEnv cenv cv (mkCoVarCo cv')) + where + new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' + +extendTvSubstAndInScope :: Subst -> TyVar -> Type -> Subst +-- Also extends the in-scope set +extendTvSubstAndInScope (Subst in_scope ids tenv cenv) tv ty + = Subst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) + ids + (extendVarEnv tenv tv ty) + cenv + +-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' +extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTvSubstList subst vrs + = foldl' extend subst vrs + where + extend subst (v, r) = extendTvSubst subst v r + +extendTCvSubstList :: Subst -> [Var] -> [Type] -> Subst +extendTCvSubstList subst tvs tys + = foldl2 extendTCvSubst subst tvs tys + +unionSubst :: Subst -> Subst -> Subst +-- Works when the ranges are disjoint +unionSubst (Subst in_scope1 ids1 tenv1 cenv1) (Subst in_scope2 ids2 tenv2 cenv2) + = assert (ids1 `disjointVarEnv` ids2 + && tenv1 `disjointVarEnv` tenv2 + && cenv1 `disjointVarEnv` cenv2 ) + Subst (in_scope1 `unionInScope` in_scope2) + (ids1 `plusVarEnv` ids2) + (tenv1 `plusVarEnv` tenv2) + (cenv1 `plusVarEnv` cenv2) + +-- | Generates the in-scope set for the 'Subst' from the types in the incoming +-- environment. No CoVars or Ids, please! +zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> Subst +zipTvSubst tvs tys + = mkTvSubst (mkInScopeSet (shallowTyCoVarsOfTypes tys)) tenv + where + tenv = zipTyEnv tvs tys + +-- | Generates the in-scope set for the 'Subst' from the types in the incoming +-- environment. No TyVars, please! +zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> Subst +zipCvSubst cvs cos + = mkCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) cenv + where + cenv = zipCoEnv cvs cos + + +zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> Subst +zipTCvSubst tcvs tys + = zip_tcvsubst tcvs tys $ + mkEmptySubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys + where zip_tcvsubst :: [TyCoVar] -> [Type] -> Subst -> Subst + zip_tcvsubst (tv:tvs) (ty:tys) subst + = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) + zip_tcvsubst [] [] subst = subst -- empty case + zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" + (ppr tcvs <+> ppr tys) + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the +-- incoming environment. No CoVars, please! The InScopeSet is just a thunk +-- so with a bit of luck it'll never be evaluated +mkTvSubstPrs :: [(TyVar, Type)] -> Subst +mkTvSubstPrs [] = emptySubst +mkTvSubstPrs prs = + assertPpr onlyTyVarsAndNoCoercionTy (text "prs" <+> ppr prs) $ + mkTvSubst in_scope tenv + where tenv = mkVarEnv prs + in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ map snd prs + onlyTyVarsAndNoCoercionTy = + and [ isTyVar tv && not (isCoercionTy ty) + | (tv, ty) <- prs ] + +-- | The InScopeSet is just a thunk so with a bit of luck it'll never be evaluated +zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv tyvars tys + | debugIsOn + , not (all isTyVar tyvars && (tyvars `equalLength` tys)) + = pprPanic "zipTyEnv" (ppr tyvars $$ ppr tys) + | otherwise + = assert (all (not . isCoercionTy) tys ) + zipToUFM tyvars tys + -- There used to be a special case for when + -- ty == TyVarTy tv + -- (a not-uncommon case) in which case the substitution was dropped. + -- But the type-tidier changes the print-name of a type variable without + -- changing the unique, and that led to a bug. Why? Pre-tidying, we had + -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. + -- And it happened that t was the type variable of the class. Post-tiding, + -- it got turned into {Foo t2}. The ext-core printer expanded this using + -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, + -- and so generated a rep type mentioning t not t2. + -- + -- Simplest fix is to nuke the "optimisation" + +zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv +zipCoEnv cvs cos + | debugIsOn + , not (all isCoVar cvs) + = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) + | otherwise + = mkVarEnv (zipEqual cvs cos) + +-- Pretty printing, for debugging only + +instance Outputable Subst where + ppr (Subst in_scope ids tvs cvs) + = text " in_scope_doc + $$ text " IdSubst =" <+> ppr ids + $$ text " TvSubst =" <+> ppr tvs + $$ text " CvSubst =" <+> ppr cvs + <> char '>' + where + in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) + +{- +%************************************************************************ +%* * + Performing type or kind substitutions +%* * +%************************************************************************ + +Note [Sym and ForAllCo] +~~~~~~~~~~~~~~~~~~~~~~~ +In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, +how do we push sym into a ForAllCo? It's a little ugly. + +Ignoring visibility, here is the typing rule +(see Note [ForAllCo] in GHC.Core.TyCo.Rep). + +h : k1 ~# k2 +(tv : k1) |- g : ty1 ~# ty2 +---------------------------- +ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# + (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) + +Here is what we want: + +ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# + (ForAllTy (tv : k1) ty1) + + +Because the kinds of the type variables to the right of the colon are the kinds +coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). + +Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want + +ForAllCo tv h' g' : + (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# + (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) + +We thus see that we want + +g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] + +and thus g' = sym (g[tv |-> tv |> h']). + +Putting it all together, we get this: + +sym (ForAllCo tv h g) +==> +ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) + +Note [Substituting in a coercion hole] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It seems highly suspicious to be substituting in a coercion that still +has coercion holes. Yet, this can happen in a situation like this: + + f :: forall k. k :~: Type -> () + f Refl = let x :: forall (a :: k). [a] -> ... + x = ... + +When we check x's type signature, we require that k ~ Type. We indeed +know this due to the Refl pattern match, but the eager unifier can't +make use of givens. So, when we're done looking at x's type, a coercion +hole will remain. Then, when we're checking x's definition, we skolemise +x's type (in order to, e.g., bring the scoped type variable `a` into scope). +This requires performing a substitution for the fresh skolem variables. + +This substitution needs to affect the kind of the coercion hole, too -- +otherwise, the kind will have an out-of-scope variable in it. More problematically +in practice (we won't actually notice the out-of-scope variable ever), skolems +in the kind might have too high a level, triggering a failure to uphold the +invariant that no free variables in a type have a higher level than the +ambient level in the type checker. In the event of having free variables in the +hole's kind, I'm pretty sure we'll always have an erroneous program, so we +don't need to worry what will happen when the hole gets filled in. After all, +a hole relating a locally-bound type variable will be unable to be solved. This +is why it's OK not to look through the IORef of a coercion hole during +substitution. + +-} + +-- | Type substitution, see 'zipTvSubst' +substTyWith :: HasDebugCallStack => [TyVar] -> [Type] -> Type -> Type +-- Works only if the domain of the substitution is a +-- superset of the type being substituted into +substTyWith tvs tys = {-#SCC "substTyWith" #-} + assert (tvs `equalLength` tys ) + substTy (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type +substTyWithUnchecked tvs tys + = assert (tvs `equalLength` tys ) + substTyUnchecked (zipTvSubst tvs tys) + +-- | Substitute tyvars within a type using a known 'InScopeSet'. +-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution +-- invariant]; specifically it should include the free vars of 'tys', +-- and of 'ty' minus the domain of the subst. +substTyWithInScope :: HasDebugCallStack => InScopeSet -> [TyVar] -> [Type] -> Type -> Type +substTyWithInScope in_scope tvs tys ty = + assert (tvs `equalLength` tys ) + substTy (mkTvSubst in_scope tenv) ty + where tenv = zipTyEnv tvs tys + +-- | Coercion substitution, see 'zipTvSubst' +substCoWith :: HasDebugCallStack => [TyVar] -> [Type] -> Coercion -> Coercion +substCoWith tvs tys = assert (tvs `equalLength` tys ) + substCo (zipTvSubst tvs tys) + +-- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion +substCoWithUnchecked tvs tys + = assert (tvs `equalLength` tys ) + substCoUnchecked (zipTvSubst tvs tys) + + + +-- | Substitute covars within a type +substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type +substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) + +-- | Type substitution, see 'zipTvSubst' +substTysWith :: HasDebugCallStack => [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith tvs tys = assert (tvs `equalLength` tys ) + substTys (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst' +substTysWithCoVars :: HasDebugCallStack => [CoVar] -> [Coercion] -> [Type] -> [Type] +substTysWithCoVars cvs cos = assert (cvs `equalLength` cos ) + substTys (zipCvSubst cvs cos) + +-- | Substitute within a 'Type' after adding the free variables of the type +-- to the in-scope set. This is useful for the case when the free variables +-- aren't already in the in-scope set or easily available. +-- See also Note [The substitution invariant]. +substTyAddInScope :: HasDebugCallStack => Subst -> Type -> Type +substTyAddInScope subst ty = + substTy (extendSubstInScopeSet subst $ tyCoVarsOfType ty) ty + +-- | When calling `substTy` it should be the case that the in-scope set in +-- the substitution is a superset of the free vars of the range of the +-- substitution. +-- See also Note [The substitution invariant]. +-- TODO: take into account ids and rename as isValidSubst +isValidTCvSubst :: Subst -> Bool +isValidTCvSubst (Subst in_scope _ tenv cenv) = + (tenvFVs `varSetInScope` in_scope) && + (cenvFVs `varSetInScope` in_scope) + where + tenvFVs = shallowTyCoVarsOfTyVarEnv tenv + cenvFVs = shallowTyCoVarsOfCoVarEnv cenv + +-- | This checks if the substitution satisfies the invariant from +-- Note [The substitution invariant]. +checkValidSubst :: HasDebugCallStack => Subst -> [Type] -> [Coercion] -> a -> a +checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a + = assertPpr (isValidTCvSubst subst) + (text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$ + text "cenv" <+> ppr cenv $$ + text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos) $ + assertPpr tysCosFVsInScope + (text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "cenv" <+> ppr cenv $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos $$ + text "needInScope" <+> ppr needInScope) + a + where + substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv + -- It's OK to use nonDetKeysUFM here, because we only use this list to + -- remove some elements from a set + needInScope = (shallowTyCoVarsOfTypes tys `unionVarSet` + shallowTyCoVarsOfCos cos) + `delListFromUniqSet_Directly` substDomain + tysCosFVsInScope = needInScope `varSetInScope` in_scope + + +-- | Substitute within a 'Type' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTy :: HasDebugCallStack => Subst -> Type -> Type +substTy subst ty + | isEmptyTCvSubst subst = ty + | otherwise = checkValidSubst subst [ty] [] $ + subst_ty subst ty + +-- | Substitute within a 'Type' disabling the sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyUnchecked :: Subst -> Type -> Type +substTyUnchecked subst ty + | isEmptyTCvSubst subst = ty + | otherwise = subst_ty subst ty + +substScaledTy :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type +substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty + +substScaledTyUnchecked :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type +substScaledTyUnchecked subst scaled_ty = mapScaledType (substTyUnchecked subst) scaled_ty + +-- | Substitute within several 'Type's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTys :: HasDebugCallStack => Subst -> [Type] -> [Type] +substTys subst tys + | isEmptyTCvSubst subst = tys + | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys + +substScaledTys :: HasDebugCallStack => Subst -> [Scaled Type] -> [Scaled Type] +substScaledTys subst scaled_tys + | isEmptyTCvSubst subst = scaled_tys + | otherwise = checkValidSubst subst (map scaledMult scaled_tys ++ map scaledThing scaled_tys) [] $ + map (mapScaledType (subst_ty subst)) scaled_tys + +-- | Substitute within several 'Type's disabling the sanity checks. +-- The problems that the sanity checks in substTys catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTysUnchecked to +-- substTys and remove this function. Please don't use in new code. +substTysUnchecked :: Subst -> [Type] -> [Type] +substTysUnchecked subst tys + | isEmptyTCvSubst subst = tys + | otherwise = map (subst_ty subst) tys + +substScaledTysUnchecked :: Subst -> [Scaled Type] -> [Scaled Type] +substScaledTysUnchecked subst tys + | isEmptyTCvSubst subst = tys + | otherwise = map (mapScaledType (subst_ty subst)) tys + +-- | Substitute within a 'ThetaType' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTheta :: HasDebugCallStack => Subst -> ThetaType -> ThetaType +substTheta = substTys + +-- | Substitute within a 'ThetaType' disabling the sanity checks. +-- The problems that the sanity checks in substTys catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substThetaUnchecked to +-- substTheta and remove this function. Please don't use in new code. +substThetaUnchecked :: Subst -> ThetaType -> ThetaType +substThetaUnchecked = substTysUnchecked + + +subst_ty :: Subst -> Type -> Type +-- subst_ty is the main workhorse for type substitution +-- +-- Note that the in_scope set is poked only if we hit a forall +-- so it may often never be fully computed +subst_ty subst ty + = go ty + where + go (TyVarTy tv) = substTyVar subst tv + go (AppTy fun arg) = (mkAppTy $! (go fun)) $! (go arg) + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- by [Int], represented with TyConApp + go ty@(TyConApp tc []) = tc `seq` ty -- avoid allocation in this common case + go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys + -- NB: mkTyConApp, not TyConApp. + -- mkTyConApp has optimizations. + -- See Note [Using synonyms to compress types] + -- in GHC.Core.Type + go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res }) + = let !mult' = go mult + !arg' = go arg + !res' = go res + in ty { ft_mult = mult', ft_arg = arg', ft_res = res' } + go (ForAllTy (Bndr tv vis) ty) + = case substVarBndrUnchecked subst tv of + (subst', tv') -> + (ForAllTy $! ((Bndr $! tv') vis)) $! + (subst_ty subst' ty) + go (LitTy n) = LitTy $! n + go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) + go (CoercionTy co) = CoercionTy $! (subst_co subst co) + +substTyVar :: Subst -> TyVar -> Type +substTyVar (Subst _ _ tenv _) tv + = assert (isTyVar tv) $ + case lookupVarEnv tenv tv of + Just ty -> ty + Nothing -> TyVarTy tv + +substTyVarToTyVar :: HasDebugCallStack => Subst -> TyVar -> TyVar +-- Apply the substitution, expecting the result to be a TyVarTy +substTyVarToTyVar (Subst _ _ tenv _) tv + = assert (isTyVar tv) $ + case lookupVarEnv tenv tv of + Just ty -> case getTyVar_maybe ty of + Just tv -> tv + Nothing -> pprPanic "substTyVarToTyVar" (ppr tv $$ ppr ty) + Nothing -> tv + +substTyVars :: Subst -> [TyVar] -> [Type] +substTyVars subst = map $ substTyVar subst + +substTyCoVars :: Subst -> [TyCoVar] -> [Type] +substTyCoVars subst = map $ substTyCoVar subst + +substTyCoVar :: Subst -> TyCoVar -> Type +substTyCoVar subst tv + | isTyVar tv = substTyVar subst tv + | otherwise = CoercionTy $ substCoVar subst tv + +lookupTyVar :: Subst -> TyVar -> Maybe Type + -- See Note [Extending the TvSubstEnv and CvSubstEnv] +lookupTyVar (Subst _ _ tenv _) tv + = assert (isTyVar tv ) + lookupVarEnv tenv tv + +-- | Substitute within a 'Coercion' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCo :: HasDebugCallStack => Subst -> Coercion -> Coercion +substCo subst co + | isEmptyTCvSubst subst = co + | otherwise = checkValidSubst subst [] [co] $ subst_co subst co + +-- | Substitute within a 'Coercion' disabling sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoUnchecked :: Subst -> Coercion -> Coercion +substCoUnchecked subst co + | isEmptyTCvSubst subst = co + | otherwise = subst_co subst co + +-- | Substitute within several 'Coercion's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCos :: HasDebugCallStack => Subst -> [Coercion] -> [Coercion] +substCos subst cos + | isEmptyTCvSubst subst = cos + | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos + +subst_co :: Subst -> Coercion -> Coercion +subst_co subst co + = go co + where + go_ty :: Type -> Type + go_ty = subst_ty subst + + go_mco :: MCoercion -> MCoercion + go_mco MRefl = MRefl + go_mco (MCo co) = MCo (go co) + + go :: Coercion -> Coercion + go (Refl ty) = mkNomReflCo $! (go_ty ty) + go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) + go (TyConAppCo r tc args)= mkTyConAppCo r tc $! go_cos args + go (AxiomCo con cos) = mkAxiomCo con $! go_cos cos + go (AppCo co arg) = (mkAppCo $! go co) $! go arg + go (ForAllCo tv visL visR kind_co co) + = case substForAllCoBndrUnchecked subst tv kind_co of + (subst', tv', kind_co') -> + ((mkForAllCo $! tv') visL visR $! kind_co') $! subst_co subst' co + go (FunCo r afl afr w co1 co2) = ((mkFunCo2 r afl afr $! go w) $! go co1) $! go co2 + go (CoVarCo cv) = substCoVar subst cv + go (UnivCo { uco_prov = p, uco_role = r + , uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = ((((mkUnivCo $! p) $! go_cos deps) $! r) $! + (go_ty t1)) $! (go_ty t2) + go (SymCo co) = mkSymCo $! (go co) + go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) + go (SelCo d co) = mkSelCo d $! (go co) + go (LRCo lr co) = mkLRCo lr $! (go co) + go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg + go (KindCo co) = mkKindCo $! (go co) + go (SubCo co) = mkSubCo $! (go co) + go (HoleCo h) = HoleCo $! go_hole h + + go_cos cos = let cos' = map go cos + in cos' `seqList` cos' + + -- See Note [Substituting in a coercion hole] + go_hole h@(CoercionHole { ch_co_var = cv }) + = h { ch_co_var = updateVarType go_ty cv } + +-- | Perform a substitution within a 'DVarSet' of free variables, +-- returning the shallow free coercion variables. +substDCoVarSet :: Subst -> DCoVarSet -> DCoVarSet +substDCoVarSet subst cvs = coVarsOfCosDSet $ map (substCoVar subst) $ + dVarSetElems cvs + +substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion + -> (Subst, TyCoVar, Coercion) +substForAllCoBndr subst + = substForAllCoBndrUsing (substCo subst) subst + +-- | Like 'substForAllCoBndr', but disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion + -> (Subst, TyCoVar, Coercion) +substForAllCoBndrUnchecked subst + = substForAllCoBndrUsing (substCoUnchecked subst) subst + +-- See Note [Sym and ForAllCo] +substForAllCoBndrUsing :: (Coercion -> Coercion) -- transformation to kind co + -> Subst -> TyCoVar -> KindCoercion + -> (Subst, TyCoVar, KindCoercion) +substForAllCoBndrUsing sco subst old_var + | isTyVar old_var = substForAllCoTyVarBndrUsing sco subst old_var + | otherwise = substForAllCoCoVarBndrUsing sco subst old_var + +substForAllCoTyVarBndrUsing :: (Coercion -> Coercion) -- transformation to kind co + -> Subst -> TyVar -> KindCoercion + -> (Subst, TyVar, KindCoercion) +substForAllCoTyVarBndrUsing sco (Subst in_scope idenv tenv cenv) old_var old_kind_co + = assert (isTyVar old_var ) + ( Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv + , new_var, new_kind_co ) + where + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + new_ki1 = coercionLKind new_kind_co + -- We could do substitution to (tyVarKind old_var). We don't do so because + -- we already substituted new_kind_co, which contains the kind information + -- we want. We don't want to do substitution once more. Also, in most cases, + -- new_kind_co is a Refl, in which case coercionKind is really fast. + + new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) + +substForAllCoCoVarBndrUsing :: (Coercion -> Coercion) -- transformation to kind co + -> Subst -> CoVar -> KindCoercion + -> (Subst, CoVar, KindCoercion) +substForAllCoCoVarBndrUsing sco (Subst in_scope idenv tenv cenv) + old_var old_kind_co + = assert (isCoVar old_var ) + ( Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv + , new_var, new_kind_co ) + where + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + new_ki1 = coercionLKind new_kind_co + new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_ki1 + +substCoVar :: Subst -> CoVar -> Coercion +substCoVar (Subst _ _ _ cenv) cv + = case lookupVarEnv cenv cv of + Just co -> co + Nothing -> CoVarCo cv + +substCoVars :: Subst -> [CoVar] -> [Coercion] +substCoVars subst cvs = map (substCoVar subst) cvs + +lookupCoVar :: Subst -> Var -> Maybe Coercion +lookupCoVar (Subst _ _ _ cenv) v = lookupVarEnv cenv v + +substTyVarBndr :: HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar) +substTyVarBndr = substTyVarBndrUsing substTy + +substTyVarBndrs :: HasDebugCallStack => Subst -> [TyVar] -> (Subst, [TyVar]) +substTyVarBndrs = mapAccumL substTyVarBndr + +substVarBndr :: HasDebugCallStack => Subst -> TyCoVar -> (Subst, TyCoVar) +substVarBndr = substVarBndrUsing substTy + +substVarBndrs :: HasDebugCallStack => Subst -> [TyCoVar] -> (Subst, [TyCoVar]) +substVarBndrs = mapAccumL substVarBndr + +substCoVarBndr :: HasDebugCallStack => Subst -> CoVar -> (Subst, CoVar) +substCoVarBndr = substCoVarBndrUsing substTy + +-- | Like 'substVarBndr', but disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substVarBndrUnchecked :: Subst -> TyCoVar -> (Subst, TyCoVar) +substVarBndrUnchecked = substVarBndrUsing substTyUnchecked + +substVarBndrUsing :: (Subst -> Type -> Type) + -> Subst -> TyCoVar -> (Subst, TyCoVar) +substVarBndrUsing subst_fn subst v + | isTyVar v = substTyVarBndrUsing subst_fn subst v + | otherwise = substCoVarBndrUsing subst_fn subst v + +-- | Substitute a tyvar in a binding position, returning an +-- extended subst and a new tyvar. +-- Use the supplied function to substitute in the kind +substTyVarBndrUsing + :: (Subst -> Type -> Type) -- ^ Use this to substitute in the kind + -> Subst -> TyVar -> (Subst, TyVar) +substTyVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var + = assertPpr _no_capture (pprTyVar old_var $$ pprTyVar new_var $$ ppr subst) $ + assert (isTyVar old_var ) + (Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv, new_var) + where + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + _no_capture = not (new_var `elemVarSet` shallowTyCoVarsOfTyVarEnv tenv) + -- Assertion check that we are not capturing something in the substitution + + old_ki = tyVarKind old_var + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + no_change = no_kind_change && (new_var == old_var) + -- no_change means that the new_var is identical in + -- all respects to the old_var (same unique, same kind) + -- See Note [Extending the TvSubstEnv and CvSubstEnv] + -- + -- In that case we don't need to extend the substitution + -- to map old to new. But instead we must zap any + -- current substitution for the variable. For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + + new_var | no_kind_change = uniqAway in_scope old_var + | otherwise = uniqAway in_scope $ + setTyVarKind old_var (subst_fn subst old_ki) + -- The uniqAway part makes sure the new variable is not already in scope + +-- | Substitute a covar in a binding position, returning an +-- extended subst and a new covar. +-- Use the supplied function to substitute in the kind +substCoVarBndrUsing + :: (Subst -> Type -> Type) + -> Subst -> CoVar -> (Subst, CoVar) +substCoVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var + = assert (isCoVar old_var) + (Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv, new_var) + where + new_co = mkCoVarCo new_var + no_kind_change = noFreeVarsOfTypes [t1, t2] + no_change = new_var == old_var && no_kind_change + + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var new_co + + new_var = uniqAway in_scope subst_old_var + subst_old_var = mkCoVar (varName old_var) new_var_type + + (t1, t2, role) = coVarTypesRole old_var + t1' = subst_fn subst t1 + t2' = subst_fn subst t2 + new_var_type = mkCoercionType role t1' t2' + -- It's important to do the substitution for coercions, + -- because they can have free type variables + +cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) +cloneTyVarBndr subst@(Subst in_scope id_env tv_env cv_env) tv uniq + = assertPpr (isTyVar tv) (ppr tv) -- I think it's only called on TyVars + ( Subst (extendInScopeSet in_scope tv') + id_env + (extendVarEnv tv_env tv (mkTyVarTy tv')) + cv_env + , tv') + where + old_ki = tyVarKind tv + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + + tv1 | no_kind_change = tv + | otherwise = setTyVarKind tv (substTy subst old_ki) + + tv' = setVarUnique tv1 uniq + +cloneTyVarBndrs :: Subst -> [TyVar] -> UniqSupply -> (Subst, [TyVar]) +cloneTyVarBndrs subst [] _usupply = (subst, []) +cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) + where + (uniq, usupply') = takeUniqFromSupply usupply + (subst' , tv ) = cloneTyVarBndr subst t uniq + (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' + +substTyCoBndr :: Subst -> PiTyBinder -> (Subst, PiTyBinder) +substTyCoBndr subst (Anon ty af) = (subst, Anon (substScaledTy subst ty) af) +substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis)) + where + (subst', tv') = substVarBndr subst tv diff --git a/GHC/Core/TyCo/Tidy.hs b/GHC/Core/TyCo/Tidy.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Tidy.hs @@ -0,0 +1,364 @@ +-- | Tidying types and coercions for printing in error messages. +module GHC.Core.TyCo.Tidy + ( + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyCo, tidyCos, + tidyTopType, + + tidyOpenType, tidyOpenTypes, + tidyOpenTypeX, tidyOpenTypesX, + tidyFreeTyCoVars, tidyFreeTyCoVarX, tidyFreeTyCoVarsX, + + tidyAvoiding, + tidyVarBndr, tidyVarBndrs, avoidNameClashes, + tidyForAllTyBinder, tidyForAllTyBinders, + tidyTyCoVarOcc + ) where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Core.Predicate( scopedSort ) +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Types.Name hiding (varName) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Utils.Misc (strictMap) + +import Data.List (mapAccumL) + +{- ********************************************************************** + + TidyType + +********************************************************************** -} + +{- Note [Tidying open types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When tidying some open types [t1,..,tn], we find their free vars, and tidy them first. + +But (tricky point) we restrict the occ_env part of inner_env to just the /free/ +vars of [t1..tn], so that we don't gratuitously rename the /bound/ variables. + +Example: assume the TidyEnv + ({"a1","b"} , [a_4 :-> a1, b_7 :-> b]) +and call tidyOpenTypes on + [a_1, forall a_2. Maybe (a_2,a_4), forall b. (b,a_1)] +All the a's have the same OccName, but different uniques. + +The TidyOccEnv binding for "b" relates b_7, which doesn't appear free in the +these types at all, so we don't want that to mess up the tidying for the +(forall b...). + +So we proceed as follows: + 1. Find the free vars. + In our example:the free vars are a_1 and a_4: + + 2. Use tidyFreeTyCoVars to tidy them (workhorse: `tidyFreeCoVarX`) + In our example: + * a_4 already has a tidy form, a1, so don't change that + * a_1 gets tidied to a2 + + 3. Trim the TidyOccEnv to OccNames of the tidied free vars (`trimTidyEnv`) + In our example "a1" and "a2" + + 4. Now tidy the types. In our example we get + [a2, forall a3. Maybe (a3,a1), forall b. (b, a2)] + +Note [Tidying is idempotent] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Key invariant: tidyFreeTyCoVars is idempotent, at least if you start with +an empty TidyEnv. This is important because: + + * The typechecker error message processing carefully tidies types, using + global knowledge; see for example calls to `tidyCt` in GHC.Tc.Errors. + + * Then the type pretty-printer, GHC.Core.TyCo.Ppr.pprType tidies the type + again, because that's important for pretty-printing types in general. + +But the second tidying is a no-op if the first step has happened, because +all the free vars will have distinct OccNames, so no renaming needs to happen. + +Note [tidyAvoiding] +~~~~~~~~~~~~~~~~~~~ +Consider tidying this unsolved constraint in GHC.Tc.Errors.report_unsolved. + C a_33, (forall a. Eq a => D a) +Here a_33 is a free unification variable. If we firs tidy [a_33 :-> "a"] +then we have no choice but to tidy the `forall a` to something else. But it +is confusing (sometimes very confusing) to gratuitously rename skolems in +this way -- see #24868. So it is better to : + + * Find the /bound/ skolems (just `a` in this case) + * Initialise the TidyOccEnv to avoid using "a" + * Now tidy the free a_33 to, say, "a1" + * Delete "a" from the TidyOccEnv + +This is done by `tidyAvoiding`. + +The last step is very important; if we leave "a" in the TidyOccEnv, when +we get to the (forall a. blah) we'll rename `a` to "a2", avoiding "a". +-} + +-- | This tidies up a type for printing in an error message, or in +-- an interface file. +-- +-- It doesn't change the uniques at all, just the print names. +tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyVarBndrs tidy_env tvs + = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs + +tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +tidyVarBndr tidy_env@(occ_env, subst) var + = case tidyOccName occ_env (getHelpfulOccName var) of + (occ_env', occ') -> ((occ_env', subst'), var') + where + subst' = extendVarEnv subst var var' + var' = updateVarType (tidyType tidy_env) (setVarName var name') + name' = tidyNameOcc name occ' + name = varName var + +avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv +-- Seed the occ_env with clashes among the names, see +-- Note [Tidying multiple names at once] in GHC.Types.Name.Occurrence +avoidNameClashes tvs (occ_env, subst) + = (avoidClashesOccEnv occ_env occs, subst) + where + occs = map getHelpfulOccName tvs + +getHelpfulOccName :: TyCoVar -> OccName +-- A TcTyVar with a System Name is probably a +-- unification variable; when we tidy them we give them a trailing +-- "0" (or 1 etc) so that they don't take precedence for the +-- un-modified name. Plus, indicating a unification variable in +-- this way is a helpful clue for users +getHelpfulOccName tv + | isSystemName name, isTcTyVar tv + = mkTyVarOccFS (occNameFS occ `appendFS` fsLit "0") + | otherwise + = occ + where + name = varName tv + occ = getOccName name + +tidyForAllTyBinder :: TidyEnv -> VarBndr TyCoVar vis + -> (TidyEnv, VarBndr TyCoVar vis) +tidyForAllTyBinder tidy_env (Bndr tv vis) + = (tidy_env', Bndr tv' vis) + where + (tidy_env', tv') = tidyVarBndr tidy_env tv + +tidyForAllTyBinders :: TidyEnv -> [VarBndr TyCoVar vis] + -> (TidyEnv, [VarBndr TyCoVar vis]) +tidyForAllTyBinders tidy_env tvbs + = mapAccumL tidyForAllTyBinder + (avoidNameClashes (binderVars tvbs) tidy_env) tvbs + +--------------- +tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv +-- ^ Add the free 'TyVar's to the env in tidy form, +-- so that we can tidy the type they are free in +-- Precondition: input free vars are closed over kinds and +-- This function does a scopedSort, so that tidied variables +-- have tidied kinds. +-- See Note [Tidying is idempotent] +tidyFreeTyCoVars tidy_env tyvars = fst (tidyFreeTyCoVarsX tidy_env tyvars) + +--------------- +tidyFreeTyCoVarsX :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +-- Precondition: input free vars are closed over kinds and +-- This function does a scopedSort, so that tidied variables +-- have tidied kinds. +-- See Note [Tidying is idempotent] +tidyFreeTyCoVarsX env tyvars = mapAccumL tidyFreeTyCoVarX env $ + scopedSort tyvars + +--------------- +tidyFreeTyCoVarX :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +-- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name +-- using the environment if one has not already been allocated. See +-- also 'tidyVarBndr' +-- See Note [Tidying is idempotent] +tidyFreeTyCoVarX env@(_, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> tidyVarBndr env tyvar -- Treat it as a binder + +--------------- +tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar +tidyTyCoVarOcc env@(_, subst) tcv + = case lookupVarEnv subst tcv of + Nothing -> updateVarType (tidyType env) tcv + Just tcv' -> tcv' + +--------------- + +{- +Note [Strictness in tidyType and friends] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Since the result of tidying will be inserted into the HPT, a potentially +long-lived structure, we generally want to avoid pieces of the old AST +being retained by the thunks produced by tidying. + +For this reason we take great care to ensure that all pieces of the tidied AST +are evaluated strictly. So you will see lots of strict applications ($!) and +uses of `strictMap` in `tidyType`, `tidyTypes` and `tidyCo`. + +In the case of tidying of lists (e.g. lists of arguments) we prefer to use +`strictMap f xs` rather than `seqList (map f xs)` as the latter will +unnecessarily allocate a thunk, which will then be almost-immediately +evaluated, for each list element. + +Making `tidyType` strict has a rather large effect on performance: see #14738. +Sometimes as much as a 5% reduction in allocation. +-} + +-- | Tidy a list of Types +-- +-- See Note [Strictness in tidyType and friends] +tidyTypes :: TidyEnv -> [Type] -> [Type] +tidyTypes env tys = strictMap (tidyType env) tys + +--------------- + + +-- | Tidy a Type +-- +-- See Note [Strictness in tidyType and friends] +tidyType :: TidyEnv -> Type -> Type +tidyType _ t@(LitTy {}) = t -- Preserve sharing +tidyType env (TyVarTy tv) = TyVarTy $! tidyTyCoVarOcc env tv +tidyType _ t@(TyConApp _ []) = t -- Preserve sharing if possible +tidyType env (TyConApp tycon tys) = TyConApp tycon $! tidyTypes env tys +tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) +tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) +tidyType env ty@(FunTy _ w arg res) = let { !w' = tidyType env w + ; !arg' = tidyType env arg + ; !res' = tidyType env res } + in ty { ft_mult = w', ft_arg = arg', ft_res = res' } +tidyType env (ty@(ForAllTy{})) = tidyForAllType env ty + + +tidyForAllType :: TidyEnv -> Type -> Type +tidyForAllType env ty + = (mkForAllTys' $! (zip tcvs' vis)) $! tidyType body_env body_ty + where + (tcvs, vis, body_ty) = splitForAllTyCoVars' ty + (body_env, tcvs') = tidyVarBndrs env tcvs + +-- The following two functions differ from mkForAllTys and splitForAllTyCoVars in that +-- they expect/preserve the ForAllTyFlag argument. These belong to "GHC.Core.Type", but +-- how should they be named? +mkForAllTys' :: [(TyCoVar, ForAllTyFlag)] -> Type -> Type +mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs + where + strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty + +splitForAllTyCoVars' :: Type -> ([TyCoVar], [ForAllTyFlag], Type) +splitForAllTyCoVars' ty = go ty [] [] + where + go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) + go ty tvs viss = (reverse tvs, reverse viss, ty) + + +--------------- +tidyAvoiding :: [OccName] + -> (TidyEnv -> a -> TidyEnv) + -> a -> TidyEnv +-- Initialise an empty TidyEnv with some bound vars to avoid, +-- run the do_tidy function, and then remove the bound vars again. +-- See Note [tidyAvoiding] +tidyAvoiding bound_var_avoids do_tidy thing + = (occs' `delTidyOccEnvList` bound_var_avoids, vars') + where + (occs', vars') = do_tidy init_tidy_env thing + init_tidy_env = mkEmptyTidyEnv (initTidyOccEnv bound_var_avoids) + +--------------- +trimTidyEnv :: TidyEnv -> [TyCoVar] -> TidyEnv +trimTidyEnv (occ_env, var_env) tcvs + = (trimTidyOccEnv occ_env (map getOccName tcvs), var_env) + +--------------- +-- | Grabs the free type variables, tidies them +-- and then uses 'tidyType' to work over the type itself +tidyOpenTypesX :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +-- See Note [Tidying open types] +tidyOpenTypesX env tys + = (env1, tidyTypes inner_env tys) + where + free_tcvs :: [TyCoVar] -- Closed over kinds + free_tcvs = tyCoVarsOfTypesList tys + (env1, free_tcvs') = tidyFreeTyCoVarsX env free_tcvs + inner_env = trimTidyEnv env1 free_tcvs' + +--------------- +tidyOpenTypeX :: TidyEnv -> Type -> (TidyEnv, Type) +-- See Note [Tidying open types] +tidyOpenTypeX env ty + = (env1, tidyType inner_env ty) + where + free_tcvs = tyCoVarsOfTypeList ty + (env1, free_tcvs') = tidyFreeTyCoVarsX env free_tcvs + inner_env = trimTidyEnv env1 free_tcvs' + +--------------- +tidyOpenTypes :: TidyEnv -> [Type] -> [Type] +tidyOpenTypes env ty = snd (tidyOpenTypesX env ty) + +tidyOpenType :: TidyEnv -> Type -> Type +tidyOpenType env ty = snd (tidyOpenTypeX env ty) + +--------------- +-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty + +--------------- + +-- | Tidy a Coercion +-- +-- See Note [Strictness in tidyType and friends] +tidyCo :: TidyEnv -> Coercion -> Coercion +tidyCo env co + = go co + where + go_mco MRefl = MRefl + go_mco (MCo co) = MCo $! go co + + go (Refl ty) = Refl $! tidyType env ty + go (GRefl r ty mco) = (GRefl r $! tidyType env ty) $! go_mco mco + go (TyConAppCo r tc cos) = TyConAppCo r tc $! strictMap go cos + go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 + go (ForAllCo tv visL visR h co) + = ((((ForAllCo $! tvp) $! visL) $! visR) $! (go h)) $! (tidyCo envp co) + where (envp, tvp) = tidyVarBndr env tv + -- the case above duplicates a bit of work in tidying h and the kind + -- of tv. But the alternative is to use coercionKind, which seems worse. + go (FunCo r afl afr w co1 co2) = ((FunCo r afl afr $! go w) $! go co1) $! go co2 + go (CoVarCo cv) = CoVarCo $! go_cv cv + go (HoleCo h) = HoleCo $! go_hole h + go (AxiomCo ax cos) = AxiomCo ax $ strictMap go cos + go (UnivCo prov role t1 t2 cos) + = ((UnivCo prov role + $! tidyType env t1) + $! tidyType env t2) + $! strictMap go cos + go (SymCo co) = SymCo $! go co + go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 + go (SelCo d co) = SelCo d $! go co + go (LRCo lr co) = LRCo lr $! go co + go (InstCo co ty) = (InstCo $! go co) $! go ty + go (KindCo co) = KindCo $! go co + go (SubCo co) = SubCo $! go co + + go_cv cv = tidyTyCoVarOcc env cv + + go_hole (CoercionHole cv r) = (CoercionHole $! go_cv cv) r + -- Tidy even the holes; tidied types should have tidied kinds + +tidyCos :: TidyEnv -> [Coercion] -> [Coercion] +tidyCos env = strictMap (tidyCo env) diff --git a/GHC/Core/TyCon.hs b/GHC/Core/TyCon.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCon.hs @@ -0,0 +1,3188 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveDataTypeable #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The @TyCon@ datatype +-} + +module GHC.Core.TyCon( + -- * Main TyCon data types + TyCon, + AlgTyConRhs(..), visibleDataCons, + AlgTyConFlav(..), isNoParent, + FamTyConFlav(..), Role(..), Injectivity(..), + PromDataConInfo(..), TyConFlavour(..), + + -- * TyConBinder + TyConBinder, TyConBndrVis(..), + mkNamedTyConBinder, mkNamedTyConBinders, + mkRequiredTyConBinder, + mkAnonTyConBinder, mkAnonTyConBinders, + tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder, + isVisibleTyConBinder, isInvisSpecTyConBinder, isInvisibleTyConBinder, + isInferredTyConBinder, + isVisibleTcbVis, isInvisSpecTcbVis, + + -- ** Field labels + tyConFieldLabels, lookupTyConFieldLabel, + + -- ** Constructing TyCons + mkAlgTyCon, + mkClassTyCon, + mkPrimTyCon, + mkTupleTyCon, + mkSumTyCon, + mkDataTyConRhs, + mkLevPolyDataTyConRhs, + mkSynonymTyCon, + mkFamilyTyCon, + mkPromotedDataCon, + mkTcTyCon, + noTcTyConScopedTyVars, + + -- ** Predicates on TyCons + isAlgTyCon, isVanillaAlgTyCon, isClassTyCon, + isUnaryClassTyCon, isUnaryClassTyCon_maybe, + isFamInstTyCon, + isPrimTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, + isUnboxedSumTyCon, isPromotedTupleTyCon, + isLiftedAlgTyCon, + isTypeSynonymTyCon, + tyConMustBeSaturated, + isPromotedDataCon, isPromotedDataCon_maybe, + isDataKindsPromotedDataCon, + isKindTyCon, isKindName, isLiftedTypeKindTyConName, + isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, + + isBoxedDataTyCon, + isTypeDataTyCon, + isEnumerationTyCon, + isNewTyCon, isAbstractTyCon, + isFamilyTyCon, isOpenFamilyTyCon, + isTypeFamilyTyCon, isDataFamilyTyCon, + isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, + tyConInjectivityInfo, + isBuiltInSynFamTyCon_maybe, + isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, + isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, + isImplicitTyCon, + isTyConWithSrcDataCons, + isTcTyCon, setTcTyConKind, + tcHasFixedRuntimeRep, + isConcreteTyCon, + isValidDTT2TyCon, + + -- ** Extracting information out of TyCons + tyConName, + tyConSkolem, + tyConKind, + tyConUnique, + tyConTyVars, tyConVisibleTyVars, + tyConCType_maybe, + tyConDataCons, tyConDataCons_maybe, + tyConSingleDataCon_maybe, tyConSingleDataCon, + tyConFamilySize, + tyConStupidTheta, + tyConArity, + tyConNullaryTy, mkTyConTy, + tyConRoles, + tyConFlavour, + tyConTuple_maybe, tyConClass_maybe, tyConATs, + tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, + tyConFamilyResVar_maybe, + synTyConDefn_maybe, synTyConRhs_maybe, + famTyConFlav_maybe, + algTyConRhs, + newTyConRhs, newTyConEtadArity, newTyConEtadRhs, + unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, + newTyConDataCon_maybe, + algTcFields, + tyConPromDataConInfo, + tyConBinders, tyConResKind, tyConInvisTVBinders, + tcTyConScopedTyVars, isMonoTcTyCon, + tyConHasClosedResKind, + mkTyConTagMap, + + -- ** Manipulating TyCons + ExpandSynResult(..), + expandSynTyCon_maybe, + newTyConCo, newTyConCo_maybe, + pprPromotionQuote, mkTyConKind, + + -- ** Predicated on TyConFlavours + tcFlavourIsOpen, + + -- * Runtime type representation + TyConRepName, tyConRepName_maybe, + mkPrelTyConRepName, + tyConRepModOcc, + + -- * Primitive representations of Types + PrimRep(..), PrimElemRep(..), Levity(..), + PrimOrVoidRep(..), + primElemRepToPrimRep, + isGcPtrRep, + primRepSizeB, primRepSizeW64_B, + primElemRepSizeB, primElemRepSizeW64_B, + primRepIsFloat, + primRepsCompatible, + primRepCompatible, + primRepIsWord, + primRepIsInt, + +) where + +import GHC.Prelude +import GHC.Platform + +import {-# SOURCE #-} GHC.Core.TyCo.Rep + ( Kind, Type, PredType, mkForAllTy, mkNakedFunTy, mkNakedTyConTy ) +import {-# SOURCE #-} GHC.Core.TyCo.FVs + ( noFreeVarsOfType ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr + ( pprType ) +import {-# SOURCE #-} GHC.Builtin.Types + ( runtimeRepTyCon, constraintKind, levityTyCon + , multiplicityTyCon + , vecCountTyCon, vecElemTyCon ) +import {-# SOURCE #-} GHC.Core.DataCon + ( DataCon, dataConFieldLabels + , dataConTyCon, dataConFullSig + , isUnboxedSumDataCon, isTypeDataCon ) +import {-# SOURCE #-} GHC.Core.Type + ( isLiftedTypeKind ) +import GHC.Builtin.Uniques + ( tyConRepNameUnique + , dataConTyRepNameUnique ) + +import GHC.Utils.Binary +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Core.Class +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Core.Coercion.Axiom +import GHC.Builtin.Names +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.FastString.Env +import GHC.Types.FieldLabel +import GHC.Settings.Constants +import GHC.Utils.Misc +import GHC.Types.Unique.Set +import GHC.Unit.Module +import Control.DeepSeq + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import qualified Data.Data as Data + +{- +----------------------------------------------- + Notes about type families +----------------------------------------------- + +Note [Type synonym families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Type synonym families, also known as "type functions", map directly + onto the type functions in FC: + + type family F a :: Type + type instance F Int = Bool + ..etc... + +* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon + +* From the user's point of view (F Int) and Bool are simply + equivalent types. + +* A Haskell 98 type synonym is a degenerate form of a type synonym + family. + +* Type functions can't appear in the LHS of a type function: + type instance F (F Int) = ... -- BAD! + +* Translation of type family decl: + type family F a :: Type + translates to + a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon + + type family G a :: Type where + G Int = Bool + G Bool = Char + G a = () + translates to + a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the + appropriate CoAxiom representing the equations + +We also support injective type families -- see Note [Injective type families] + +Note [Data type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make + +* Data type families are declared thus + data family T a :: Type + data instance T Int = T1 | T2 Bool + + Here T is the "family TyCon". + +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + +* The user does not see any "equivalent types" as they did with type + synonym families. They just see constructors with types + T1 :: T Int + T2 :: Bool -> T Int + +* Here's the FC version of the above declarations: + + data T a + data R:TInt = T1 | T2 Bool + axiom ax_ti : T Int ~R R:TInt + + Note that this is a *representational* coercion + The R:TInt is the "representation TyCons". + It has an AlgTyConFlav of + DataFamInstTyCon T [Int] ax_ti + +* The axiom ax_ti may be eta-reduced; see + Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + +* Data family instances may have a different arity than the data family. + See Note [Arity of data families] in GHC.Core.FamInstEnv + +* The data constructor T2 has a wrapper (which is what the + source-level "T2" invokes): + + $WT2 :: Bool -> T Int + $WT2 b = T2 b `cast` sym ax_ti + +* A data instance can declare a fully-fledged GADT: + + data instance T (a,b) where + X1 :: T (Int,Bool) + X2 :: a -> b -> T (a,b) + + Here's the FC version of the above declaration: + + data R:TPair a b where + X1 :: R:TPair Int Bool + X2 :: a -> b -> R:TPair a b + axiom ax_pr :: T (a,b) ~R R:TPair a b + + $WX1 :: forall a b. a -> b -> T (a,b) + $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) + + The R:TPair are the "representation TyCons". + We have a bit of work to do, to unpick the result types of the + data instance declaration for T (a,b), to get the result type in the + representation; e.g. T (a,b) --> R:TPair a b + + The representation TyCon R:TList, has an AlgTyConFlav of + + DataFamInstTyCon T [(a,b)] ax_pr + +* Notice that T is NOT translated to a FC type function; it just + becomes a "data type" with no constructors, which can be coerced + into R:TInt, R:TPair by the axioms. These axioms + axioms come into play when (and *only* when) you + - use a data constructor + - do pattern matching + Rather like newtype, in fact + + As a result + + - T behaves just like a data type so far as decomposition is concerned + + - (T Int) is not implicitly converted to R:TInt during type inference. + Indeed the latter type is unknown to the programmer. + + - There *is* an instance for (T Int) in the type-family instance + environment, but it is looked up (via tcLookupDataFamilyInst) + in can_eq_nc (via tcTopNormaliseNewTypeTF_maybe) when trying to + solve representational equalities like + T Int ~R# Bool + Here we look up (T Int), convert it to R:TInt, and then unwrap the + newtype R:TInt. + + It is also looked up in reduceTyFamApp_maybe. + + - It's fine to have T in the LHS of a type function: + type instance F (T a) = [a] + + It was this last point that confused me! The big thing is that you + should not think of a data family T as a *type function* at all, not + even an injective one! We can't allow even injective type functions + on the LHS of a type function: + type family injective G a :: Type + type instance F (G Int) = Bool + is no good, even if G is injective, because consider + type instance G Int = Bool + type instance F Bool = Char + + So a data type family is not an injective type function. It's just a + data type with some axioms that connect it to other data types. + +* The tyConTyVars of the representation tycon are the tyvars that the + user wrote in the patterns. This is important in GHC.Tc.Deriv, where we + bring these tyvars into scope before type-checking the deriving + clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. + +Note [Associated families and their parent class] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Associated* families are just like *non-associated* families, except +that they have a famTcParent field of (Just cls_tc), which identifies the +parent class. + +However there is an important sharing relationship between + * the tyConTyVars of the parent Class + * the tyConTyVars of the associated TyCon + + class C a b where + data T p a + type F a q b + +Here the 'a' and 'b' are shared with the 'Class'; that is, they have +the same Unique. + +This is important. In an instance declaration we expect + * all the shared variables to be instantiated the same way + * the non-shared variables of the associated type should not + be instantiated at all + + instance C [x] (Tree y) where + data T p [x] = T1 x | T2 p + type F [x] q (Tree y) = (x,y,q) + +Note [TyCon Role signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every tycon has a role signature, assigning a role to each of the tyConTyVars +(or of equal length to the tyConArity, if there are no tyConTyVars). An +example demonstrates these best: say we have a tycon T, with parameters a at +nominal, b at representational, and c at phantom. Then, to prove +representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have +nominal equality between a1 and a2, representational equality between b1 and +b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This +might happen, say, with the following declaration: + + data T a b c where + MkT :: b -> T Int b c + +Data and class tycons have their roles inferred (see inferRoles in GHC.Tc.TyCl.Utils), +as do vanilla synonym tycons. Family tycons have all parameters at role N, +though it is conceivable that we could relax this restriction. (->)'s and +tuples' parameters are at role R. Each primitive tycon declares its roles; +it's worth noting that (~#)'s parameters are at role N. Promoted data +constructors' type arguments are at role R. All kind arguments are at role +N. + +Note [Unboxed tuple RuntimeRep vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The contents of an unboxed tuple may have any representation. Accordingly, +the kind of the unboxed tuple constructor is runtime-representation +polymorphic. + +Type constructor (2 kind arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). + TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) +Data constructor (4 type arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) + (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) + +These extra tyvars (q and r) cause some delicate processing around tuples, +where we need to manually insert RuntimeRep arguments. +The same situation happens with unboxed sums: each alternative +has its own RuntimeRep. +For boxed tuples, there is no representation polymorphism, and therefore +we add RuntimeReps only for the unboxed version. + +Type constructor (no kind arguments) + (,) :: Type -> Type -> Type +Data constructor (2 type arguments) + (,) :: forall a b. a -> b -> (a, b) + + +Note [Injective type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow injectivity annotations for type families (both open and closed): + + type family F (a :: k) (b :: k) = r | r -> a + type family G a b = res | res -> a b where ... + +Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. +`famTcInj` maybe stores a list of Bools, where each entry corresponds to a +single element of `tyConTyVars` (both lists should have identical length). If no +injectivity annotation was provided `famTcInj` is Nothing. From this follows an +invariant that if `famTcInj` is a Just then at least one element in the list +must be True. + +See also: + * [Injectivity annotation] in GHC.Hs.Decls + * [Renaming injectivity annotation] in GHC.Rename.Module + * [Verifying injectivity annotation] in GHC.Core.FamInstEnv + * [Type inference for type families with injectivity] in GHC.Tc.Solver.Equality + +Note [Sharing nullary TyConApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nullary type constructor applications are extremely common. For this reason +each TyCon carries with it a @TyConApp tycon []@. This ensures that +'mkTyConTy' does not need to allocate and eliminates quite a bit of heap +residency. Furthermore, we use 'mkTyConTy' in the nullary case of 'mkTyConApp', +ensuring that this function also benefits from sharing. + +This optimisation improves allocations in the Cabal test by around 0.3% and +decreased cache misses measurably. + +See #19367. + + +************************************************************************ +* * + TyConBinder +* * +************************************************************************ +-} + +type TyConBinder = VarBndr TyVar TyConBndrVis + +data TyConBndrVis + = NamedTCB ForAllTyFlag -- ^ A named, forall-bound variable (invisible or not) + | AnonTCB -- ^ an ordinary, visible type argument + +instance Outputable TyConBndrVis where + ppr (NamedTCB flag) = ppr flag + ppr AnonTCB = text "AnonTCB" + +mkAnonTyConBinder :: TyVar -> TyConBinder +-- Make a visible anonymous TyCon binder +mkAnonTyConBinder tv = assert (isTyVar tv) $ + Bndr tv AnonTCB + +mkAnonTyConBinders :: [TyVar] -> [TyConBinder] +mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs + +mkNamedTyConBinder :: ForAllTyFlag -> TyVar -> TyConBinder +-- The odd argument order supports currying +mkNamedTyConBinder vis tv = assert (isTyVar tv) $ + Bndr tv (NamedTCB vis) + +mkNamedTyConBinders :: ForAllTyFlag -> [TyVar] -> [TyConBinder] +-- The odd argument order supports currying +mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs + +-- | Make a Required TyConBinder. It chooses between NamedTCB and +-- AnonTCB based on whether the tv is mentioned in the dependent set +mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently + -> TyVar + -> TyConBinder +mkRequiredTyConBinder dep_set tv + | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv + | otherwise = mkAnonTyConBinder tv + +tyConBinderForAllTyFlag :: VarBndr a TyConBndrVis -> ForAllTyFlag +tyConBinderForAllTyFlag (Bndr _ vis) = tyConBndrVisForAllTyFlag vis + +tyConBndrVisForAllTyFlag :: TyConBndrVis -> ForAllTyFlag +tyConBndrVisForAllTyFlag (NamedTCB vis) = vis +tyConBndrVisForAllTyFlag AnonTCB = Required + +isNamedTyConBinder :: TyConBinder -> Bool +-- Identifies kind variables +-- E.g. data T k (a:k) = blah +-- Here 'k' is a NamedTCB, a variable used in the kind of other binders +isNamedTyConBinder (Bndr _ (NamedTCB {})) = True +isNamedTyConBinder _ = False + +isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis + +isVisibleTcbVis :: TyConBndrVis -> Bool +isVisibleTcbVis (NamedTCB vis) = isVisibleForAllTyFlag vis +isVisibleTcbVis AnonTCB = True + +isInvisSpecTcbVis :: TyConBndrVis -> Bool +isInvisSpecTcbVis (NamedTCB Specified) = True +isInvisSpecTcbVis _ = False + +isInvisInferTcbVis :: TyConBndrVis -> Bool +isInvisInferTcbVis (NamedTCB Inferred) = True +isInvisInferTcbVis _ = False + +isInvisSpecTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInvisSpecTyConBinder (Bndr _ tcb_vis) = isInvisSpecTcbVis tcb_vis + +isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) + +isInferredTyConBinder :: VarBndr var TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInferredTyConBinder (Bndr _ tcb_vis) = isInvisInferTcbVis tcb_vis + +-- Build the 'tyConKind' from the binders and the result kind. +-- Keep in sync with 'mkTyConKind' in GHC.Iface.Type. +mkTyConKind :: [TyConBinder] -> Kind -> Kind +mkTyConKind bndrs res_kind = foldr mk res_kind bndrs + where + mk :: TyConBinder -> Kind -> Kind + mk (Bndr tv (NamedTCB vis)) k = mkForAllTy (Bndr tv vis) k + mk (Bndr tv AnonTCB) k = mkNakedFunTy FTF_T_T (varType tv) k + -- mkNakedFunTy: see Note [Naked FunTy] in GHC.Builtin.Types + +-- | (mkTyConTy tc) returns (TyConApp tc []) +-- but arranges to share that TyConApp among all calls +-- See Note [Sharing nullary TyConApps] +-- So it's just an alias for tyConNullaryTy! +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = tyConNullaryTy tycon + +tyConInvisTVBinders :: [TyConBinder] -- From the TyCon + -> [InvisTVBinder] -- Suitable for the foralls of a term function +-- See Note [Building TyVarBinders from TyConBinders] +tyConInvisTVBinders tc_bndrs + = map mk_binder tc_bndrs + where + mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv + where + vis = case tc_vis of + AnonTCB -> SpecifiedSpec + NamedTCB Required -> SpecifiedSpec + NamedTCB (Invisible vis) -> vis + +-- Returns only tyvars, as covars are always inferred +tyConVisibleTyVars :: TyCon -> [TyVar] +tyConVisibleTyVars tc + = [ tv | Bndr tv vis <- tyConBinders tc + , isVisibleTcbVis vis ] + +{- Note [Building TyVarBinders from TyConBinders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We sometimes need to build the quantified type of a value from +the TyConBinders of a type or class. For that we need not +TyConBinders but TyVarBinders (used in forall-type) E.g: + + * From data T a = MkT (Maybe a) + we are going to make a data constructor with type + MkT :: forall a. Maybe a -> T a + See the ForAllTyBinders passed to buildDataCon + + * From class C a where { op :: a -> Maybe a } + we are going to make a default method + $dmop :: forall a. C a => a -> Maybe a + See the ForAllTyBinders passed to mkSigmaTy in mkDefaultMethodType + +Both of these are user-callable. (NB: default methods are not callable +directly by the user but rather via the code generated by 'deriving', +which uses visible type application; see mkDefMethBind.) + +Since they are user-callable we must get their type-argument visibility +information right; and that info is in the TyConBinders. +Here is an example: + + data App a b = MkApp (a b) -- App :: forall {k}. (k->Type) -> k -> Type + +The TyCon has + + tyConTyBinders = [ Named (Bndr (k :: Type) Inferred), Anon (k->Type), Anon k ] + +The TyConBinders for App line up with App's kind, given above. + +But the DataCon MkApp has the type + MkApp :: forall {k} (a:k->Type) (b:k). a b -> App k a b + +That is, its ForAllTyBinders should be + + dataConUnivTyVarBinders = [ Bndr (k:Type) Inferred + , Bndr (a:k->Type) Specified + , Bndr (b:k) Specified ] + +So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: + - variable names from the TyConBinders + - but changing Anon/Required to Specified + +The last part about Required->Specified comes from this: + data T k (a :: k) b = MkT (a b) +Here k is Required in T's kind, but we didn't have Required binders in +types of terms before the advent of the new, experimental RequiredTypeArguments +extension. So we historically changed Required to Specified when making MkT's PiTyBinders +and now continue to do so to avoid a breaking change. +-} + + +{- Note [The binders/kind/arity fields of a TyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All TyCons have this group of fields + tyConBinders :: [TyConBinder] + tyConResKind :: Kind + tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders + -- NB: Currently (Aug 2018), TyCons that own this + -- field really only contain TyVars. So it is + -- [TyVar] instead of [TyCoVar]. + tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind + tyConArity :: Arity -- Cached = length tyConBinders + +They fit together like so: + +* tyConBinders gives the telescope of type variables on the LHS of the + type declaration. For example: + + type App a (b :: k) = a b + + tyConBinders = [ Bndr (k::Type) (NamedTCB Inferred) + , Bndr (a:k->Type) AnonTCB + , Bndr (b:k) AnonTCB ] + + Note that there are three binders here, including the + kind variable k. + + See Note [tyConBinders and lexical scoping] + +* See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep + for what the visibility flag means. + +* Each TyConBinder in tyConBinders has a TyVar, and + that TyVar may scope over some other part of the TyCon's definition. Eg + type T a = a -> a + we have + tyConBinders = [ Bndr (a:Type) AnonTCB ] + synTcRhs = a -> a + So the 'a' scopes over the synTcRhs + +* From the tyConBinders and tyConResKind we can get the tyConKind + E.g for our App example: + App :: forall k. (k->Type) -> k -> Type + + We get a 'forall' in the kind for each NamedTCB, and an arrow + for each AnonTCB + + tyConKind is the full kind of the TyCon, not just the result kind + +* For type families, tyConArity is the arguments this TyCon must be + applied to, to be considered saturated. Here we mean "applied to in + the actual Type", not surface syntax; i.e. including implicit kind + variables. So it's just (length tyConBinders) + +* For an algebraic data type, or data instance, the tyConResKind is + always (TYPE r); that is, the tyConBinders are enough to saturate + the type constructor. I'm not quite sure why we have this invariant, + but it's enforced by splitTyConKind + +Note [tyConBinders and lexical scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a TyCon, and a PolyTcTyCon, we obey the following rule: + + The Name of the TyConBinder is precisely + the lexically scoped Name from the original declaration + (precisely = both OccName and Unique) + +For example, + data T a (b :: wombat) = MkT +We will get tyConBinders of [k, wombat, a::k, b::wombat] +The 'k' is made up; the user didn't specify it. But for the kind of 'b' +we must use 'wombat'. + +Why do we have this invariant? + +* Similarly, when typechecking default definitions for class methods, in + GHC.Tc.TyCl.Class.tcClassDecl2, we only have the (final) Class available; + but the variables bound in that class must be in scope. Example (#19738): + + type P :: k -> Type + data P a = MkP + + type T :: k -> Constraint + class T (a :: j) where + f :: P a + f = MkP @j @a -- 'j' must be in scope when we typecheck 'f' + +* When typechecking `deriving` clauses for top-level data declarations, the + tcTyConScopedTyVars are brought into scope in through the `di_scoped_tvs` + field of GHC.Tc.Deriv.DerivInfo. Example (#16731): + + class C x1 x2 + + type T :: a -> Type + data T (x :: z) deriving (C z) + + When typechecking `C z`, we want `z` to map to `a`, which is exactly what the + tcTyConScopedTyVars for T give us. +-} + +instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where + ppr (Bndr v bi) = ppr bi <+> parens (pprBndr LetBind v) + +instance Binary TyConBndrVis where + put_ bh AnonTCB = do { putByte bh 0 } + put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } + + get bh = do { h <- getByte bh + ; case h of + 0 -> return AnonTCB + _ -> do { vis <- get bh; return (NamedTCB vis) } } + +instance NFData TyConBndrVis where + rnf AnonTCB = () + rnf (NamedTCB vis) = rnf vis + + + +{- ********************************************************************* +* * + The TyCon type +* * +************************************************************************ +-} + + +-- | TyCons represent type constructors. Type constructors are introduced by +-- things such as: +-- +-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of +-- kind @Type@ +-- +-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor +-- +-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor +-- of kind @Type -> Type@ +-- +-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor +-- of kind @Constraint@ +-- +-- This data type also encodes a number of primitive, built in type constructors +-- such as those for function and tuple types. +-- +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data TyCon = TyCon { + tyConUnique :: !Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: !Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConHasClosedResKind :: Bool, + + -- Cached values + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ + + tyConRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + tyConDetails :: !TyConDetails } + +data TyConDetails = + -- | Algebraic data types, from + -- - @data@ declarations + -- - @newtype@ declarations + -- - data instance declarations + -- - type instance declarations + -- - the TyCon generated by a class declaration + -- - boxed tuples + -- - unboxed tuples + -- - constraint tuples + -- - unboxed sums + -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. + -- See 'AlgTyConRhs' for more information. + AlgTyCon { + -- The tyConTyVars scope over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in algTyConRhs.NewTyCon + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. + + tyConCType :: Maybe CType,-- ^ The C type that should be used + -- for this type when using the FFI + -- and CAPI + + algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT + -- syntax? If so, that doesn't mean it's a + -- true GADT; only that the "where" form + -- was used. This field is used only to + -- guide pretty-printing + + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data + -- type (always empty for GADTs). A + -- \"stupid theta\" is the context to + -- the left of an algebraic type + -- declaration, e.g. @Eq a@ in the + -- declaration @data Eq a => T a ...@. + -- See @Note [The stupid context]@ in + -- "GHC.Core.DataCon". + + algTcRhs :: AlgTyConRhs, -- ^ Contains information about the + -- data constructors of the algebraic type + + algTcFields :: FieldLabelEnv, -- ^ Maps a label to information + -- about the field + + algTcFlavour :: AlgTyConFlav -- ^ The flavour of this algebraic tycon. + -- Gives the class or family declaration + -- 'TyCon' for derived 'TyCon's representing + -- class or family instances, respectively. + + } + + -- | Represents type synonyms + | SynonymTyCon { + -- tyConTyVars scope over: synTcRhs + + synTcRhs :: Type, -- ^ Contains information about the expansion + -- of the synonym + + synIsTau :: Bool, -- True <=> the RHS of this synonym does not + -- have any foralls, after expanding any + -- nested synonyms + synIsFamFree :: Bool, -- True <=> the RHS of this synonym does not mention + -- any type synonym families (data families + -- are fine), again after expanding any + -- nested synonyms + + synIsForgetful :: Bool, -- See Note [Forgetful type synonyms] + -- True <= at least one argument is not mentioned + -- in the RHS (or is mentioned only under + -- forgetful synonyms) + -- Test is conservative, so True does not guarantee + -- forgetfulness. False conveys definite information + -- (definitely not forgetful); True is always safe. + + synIsConcrete :: Bool -- True <= If 'tys' are concrete then the expansion + -- of (S tys) is definitely concrete + -- But False is always safe + } + + -- | Represents families (both type and data) + -- Argument roles are all Nominal + | FamilyTyCon { + -- tyConTyVars connect an associated family TyCon + -- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst + + famTcResVar :: Maybe Name, -- ^ Name of result type variable, used + -- for pretty-printing with --show-iface + -- and for reifying TyCon in Template + -- Haskell + + famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, + -- abstract, built-in. See comments for + -- FamTyConFlav + + famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families + -- The class tycon in which the family is declared + -- See Note [Associated families and their parent class] + + famTcInj :: Injectivity -- ^ is this a type family injective in + -- its type variables? Nothing if no + -- injectivity annotation was given + } + + -- | Primitive types; cannot be defined in Haskell. This includes + -- the usual suspects (such as @Int#@) as well as foreign-imported + -- types and kinds (@*@, @#@, and @?@) + | PrimTyCon { + primRepName :: TyConRepName -- ^ The 'Typeable' representation. + -- A cached version of + -- @'mkPrelTyConRepName' ('tyConName' tc)@. + } + + -- | Represents promoted data constructor. + -- The kind of a promoted data constructor is the *wrapper* type of + -- the original data constructor. This type must not have constraints + -- (as checked in GHC.Tc.Gen.HsType.tcTyVar). + | PromotedDataCon { -- See Note [Promoted data constructors] + dataCon :: DataCon, -- ^ Corresponding data constructor + tcRepName :: TyConRepName, + promDcInfo :: PromDataConInfo -- ^ See comments with 'PromDataConInfo' + } + + -- | These exist only during type-checking. + -- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in "GHC.Tc.TyCl" + | TcTyCon { + -- NB: the tyConArity of a TcTyCon must match + -- the number of Required (positional, user-specified) + -- arguments to the type constructor; see the use + -- of tyConArity in generaliseTcTyCon + + tctc_scoped_tvs :: [(Name,TcTyVar)], + -- ^ Scoped tyvars over the tycon's body + -- The range is always a skolem or TcTyVar, be + -- MonoTcTyCon only: see Note [Scoped tyvars in a TcTyCon] + + tctc_is_poly :: Bool, -- ^ Is this TcTyCon already generalized? + -- Used only to make zonking more efficient + + tctc_flavour :: TyConFlavour TyCon + -- ^ What sort of 'TyCon' this represents. + } + +{- Note [Scoped tyvars in a TcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The tcTyConScopedTyVars field records the lexicial-binding connection +between the original, user-specified Name (i.e. thing in scope) and +the TcTyVar that the Name is bound to. + +Order *does* matter; the tcTyConScopedTyVars list consists of + specified_tvs ++ required_tvs + +where + * specified ones first + * required_tvs the same as tyConTyVars + * tyConArity = length required_tvs + +tcTyConScopedTyVars are used only for MonoTcTyCons, not PolyTcTyCons. +See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl + +Note [Representation-polymorphic TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To check for representation-polymorphism directly in the typechecker, +e.g. when using GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep, +we need to compute whether a type has a syntactically fixed RuntimeRep, +as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. + +It's useful to have a quick way to check whether a saturated application +of a type constructor has a fixed RuntimeRep. That is, we want +to know, given a TyCon 'T' of arity 'n', does + + T a_1 ... a_n + +always have a fixed RuntimeRep? That is, is it always the case +that this application has a kind of the form + + T a_1 ... a_n :: TYPE rep + +in which 'rep' is a concrete 'RuntimeRep'? +('Concrete' in the sense of Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete: +it contains no type-family applications or type variables.) + +To answer this question, we have 'tcHasFixedRuntimeRep'. +If 'tcHasFixedRuntimeRep' returns 'True', it means we're sure that +every saturated application of `T` has a fixed RuntimeRep. +However, if it returns 'False', we don't know: perhaps some application might not +have a fixed RuntimeRep. + +Examples: + + - For type families, we won't know in general whether an application + will have a fixed RuntimeRep: + + type F :: k -> k + type family F a where {..} + + `tcHasFixedRuntimeRep F = False' + + - For newtypes, we're usually OK: + + newtype N a b c = MkN Int + + No matter what arguments we apply `N` to, we always get something of + kind `Type`, which has a fixed RuntimeRep. + Thus `tcHasFixedRuntimeRep N = True`. + + However, with `-XUnliftedNewtypes`, we can have representation-polymorphic + newtypes: + + type UN :: TYPE rep -> TYPE rep + newtype UN a = MkUN a + + `tcHasFixedRuntimeRep UN = False` + + For example, `UN @Int8Rep Int8#` is represented by an 8-bit value, + while `UN @LiftedRep Int` is represented by a heap pointer. + + To distinguish whether we are dealing with a representation-polymorphic newtype, + we keep track of which situation we are in using the 'nt_fixed_rep' + field of the 'NewTyCon' constructor of 'AlgTyConRhs', and read this field + to compute 'tcHasFixedRuntimeRep'. + + - A similar story can be told for datatypes: we're usually OK, + except with `-XUnliftedDatatypes` which allows for levity polymorphism, + e.g.: + + type UC :: TYPE (BoxedRep l) -> TYPE (BoxedRep l) + type UC a = MkUC a + + `tcHasFixedRuntimeRep UC = False` + + Here, we keep track of whether we are dealing with a levity-polymorphic + unlifted datatype using the 'data_fixed_lev' field of the 'DataTyCon' + constructor of 'AlgTyConRhs'. + + N.B.: technically, the representation of a datatype is fixed, + as it is always a pointer. However, we currently require that we + know the specific `RuntimeRep`: knowing that it's `BoxedRep l` + for a type-variable `l` isn't enough. See #15532. +-} + +-- | Represents right-hand-sides of 'TyCon's for algebraic types +data AlgTyConRhs + + -- | Says that we know nothing about this data type, except that + -- it's represented by a pointer. Used when we export a data type + -- abstractly into an .hi file. + = AbstractTyCon + + -- | Information about those 'TyCon's derived from a @data@ + -- declaration. This includes data types with no constructors at + -- all. + | DataTyCon { + data_cons :: [DataCon], + -- ^ The data type constructors; can be empty if the + -- user declares the type to have no constructors + -- + -- INVARIANT: Kept in order of increasing 'DataCon' + -- tag (see the tag assignment in mkTyConTagMap) + data_cons_size :: Int, + -- ^ Cached value: length data_cons + is_enum :: Bool, -- ^ Cached value: is this an enumeration type? + -- See Note [Enumeration types] + is_type_data :: Bool, + -- from a "type data" declaration + -- See Note [Type data declarations] in GHC.Rename.Module + data_fixed_lev :: Bool + -- ^ 'True' if the data type constructor has + -- a known, fixed levity when fully applied + -- to its arguments, False otherwise. + -- + -- This can only be 'False' with UnliftedDatatypes, + -- e.g. + -- + -- > data A :: TYPE (BoxedRep l) where { MkA :: Int -> A } + -- + -- This boolean is cached to make it cheaper to check + -- for levity and representation-polymorphism in + -- tcHasFixedRuntimeRep. + } + + | TupleTyCon { -- A boxed, unboxed, or constraint tuple + data_con :: DataCon, -- NB: it can be an *unboxed* tuple + tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint + -- tuple? + } + + -- | An unboxed sum type. + | SumTyCon { + data_cons :: [DataCon], + data_cons_size :: Int -- ^ Cached value: length data_cons + } + + -- | Information about those 'TyCon's derived from a @newtype@ declaration + | NewTyCon { + data_con :: DataCon, -- ^ The unique constructor for the @newtype@. + -- It has no existentials + + nt_rhs :: Type, -- ^ Cached value: the argument type of the + -- constructor, which is just the representation + -- type of the 'TyCon' (remember that @newtype@s + -- do not exist at runtime so need a different + -- representation type). + -- + -- The free 'TyVar's of this type are the + -- 'tyConTyVars' from the corresponding 'TyCon' + + nt_etad_rhs :: ([TyVar], Type), + -- ^ Same as the 'nt_rhs', but this time eta-reduced. + -- Hence the list of 'TyVar's in this field may be + -- shorter than the declared arity of the 'TyCon'. + + -- See Note [Newtype eta] + nt_co :: CoAxiom Unbranched, + -- The axiom coercion that creates the @newtype@ + -- from the representation 'Type'. The axiom witnesses + -- a representational coercion: + -- nt_co :: N ty1 ~R# rep_tys + + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check #1072. + nt_fixed_rep :: Bool + -- ^ 'True' if the newtype has a known, fixed representation + -- when fully applied to its arguments, 'False' otherwise. + -- This can only ever be 'False' with UnliftedNewtypes. + -- + -- Example: + -- + -- > newtype N (a :: TYPE r) = MkN a + -- + -- Invariant: nt_fixed_rep nt = tcHasFixedRuntimeRep (nt_rhs nt) + -- + -- This boolean is cached to make it cheaper to check if a + -- variable binding is representation-polymorphic + -- in tcHasFixedRuntimeRep. + } + + | UnaryClassTyCon { -- See Note [Unary class magic], esp (UCM2) + -- INVARIANT: the algTcFlavour of this TyCon is ClassTyCon + data_con :: DataCon + } + +mkSumTyConRhs :: [DataCon] -> AlgTyConRhs +mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) + +-- | Create an 'AlgTyConRhs' from the data constructors, +-- for a potentially levity-polymorphic datatype (with `UnliftedDatatypes`). +mkLevPolyDataTyConRhs :: Bool -- ^ whether the 'DataCon' has a fixed levity + -> Bool -- ^ True if this is a "type data" declaration + -- See Note [Type data declarations] + -- in GHC.Rename.Module + -> [DataCon] + -> AlgTyConRhs +mkLevPolyDataTyConRhs fixed_lev type_data cons + = DataTyCon { + data_cons = cons, + data_cons_size = length cons, + is_enum = not (null cons) && all is_enum_con cons, + -- See Note [Enumeration types] in GHC.Core.TyCon + is_type_data = type_data, + data_fixed_lev = fixed_lev + } + where + is_enum_con con + | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) + <- dataConFullSig con + = null ex_tvs && null eq_spec && null theta && null arg_tys + +-- | Create an 'AlgTyConRhs' from the data constructors. +-- +-- Use 'mkLevPolyDataConRhs' if the datatype can be levity-polymorphic +-- or if it comes from a "data type" declaration +mkDataTyConRhs :: [DataCon] -> AlgTyConRhs +mkDataTyConRhs = mkLevPolyDataTyConRhs True False + +-- | Some promoted datacons signify extra info relevant to GHC. For example, +-- the `IntRep` constructor of `RuntimeRep` corresponds to the 'IntRep' +-- constructor of 'PrimRep'. This data structure allows us to store this +-- information right in the 'TyCon'. The other approach would be to look +-- up things like `RuntimeRep`'s `PrimRep` by known-key every time. +-- See also Note [Getting from RuntimeRep to PrimRep] in "GHC.Types.RepType" +data PromDataConInfo + = NoPromInfo -- ^ an ordinary promoted data con + | RuntimeRep ([Type] -> [PrimRep]) + -- ^ A constructor of `RuntimeRep`. The argument to the function should + -- be the list of arguments to the promoted datacon. + + | VecCount Int -- ^ A constructor of `VecCount` + + | VecElem PrimElemRep -- ^ A constructor of `VecElem` + + | Levity Levity -- ^ A constructor of `Levity` + +-- | Extract those 'DataCon's that we are able to learn about. Note +-- that visibility in this sense does not correspond to visibility in +-- the context of any particular user program! +visibleDataCons :: AlgTyConRhs -> [DataCon] +visibleDataCons (AbstractTyCon {}) = [] +visibleDataCons (DataTyCon{ data_cons = cs }) = cs +visibleDataCons (NewTyCon{ data_con = c }) = [c] +visibleDataCons (UnaryClassTyCon{ data_con = c }) = [c] +visibleDataCons (TupleTyCon{ data_con = c }) = [c] +visibleDataCons (SumTyCon{ data_cons = cs }) = cs + +-- | Describes the flavour of an algebraic type constructor. For +-- classes and data families, this flavour includes a reference to +-- the parent 'TyCon'. +data AlgTyConFlav + = -- | An ordinary algebraic type constructor. This includes unlifted and + -- representation-polymorphic datatypes and newtypes and unboxed tuples, + -- but NOT unboxed sums; see UnboxedSumTyCon. + VanillaAlgTyCon + TyConRepName -- For Typeable + + -- | An unboxed sum type constructor. This is distinct from VanillaAlgTyCon + -- because we currently don't allow unboxed sums to be Typeable since + -- there are too many of them. See #13276. + | UnboxedSumTyCon + + -- | Type constructors representing a class dictionary. + -- See Note [ATyCon for classes] in "GHC.Types.TyThing" + -- INVARIANT: the algTcRhs is never NewTyCon; it could be + -- TupleTyCon, DataTyCon, UnaryClassTyCon + | ClassTyCon + Class -- INVARIANT: the classTyCon of this Class is the + -- current tycon + TyConRepName + + -- | Type constructors representing an *instance* of a *data* family. + -- Parameters: + -- + -- 1) The type family in question + -- + -- 2) Instance types; free variables are the 'tyConTyVars' + -- of the current 'TyCon' (not the family one). INVARIANT: + -- the number of types matches the arity of the family 'TyCon' + -- + -- 3) A 'CoTyCon' identifying the representation + -- type with the type instance family + | DataFamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) -- The coercion axiom. + -- A *Representational* coercion, + -- of kind T ty1 ty2 ~R R:T a b c + -- where T is the family TyCon, + -- and R:T is the representation TyCon (ie this one) + -- and a,b,c are the tyConTyVars of this TyCon + -- + -- BUT may be eta-reduced; see + -- Note [Eta reduction for data families] in + -- GHC.Core.Coercion.Axiom + + -- Cached fields of the CoAxiom, but adjusted to + -- use the tyConTyVars of this TyCon + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- No shorter in length than the tyConTyVars of the family TyCon + -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv + + -- E.g. data instance T [a] = ... + -- gives a representation tycon: + -- data R:TList a = ... + -- axiom co a :: T [a] ~ R:TList a + -- with R:TList's algTcFlavour = DataFamInstTyCon T [a] co + +instance Outputable AlgTyConFlav where + ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" + ppr (UnboxedSumTyCon {}) = text "Unboxed sum" + ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls + ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" + <+> ppr tc <+> sep (map pprType tys) + +-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class +-- name, if any +okParent :: Name -> AlgTyConFlav -> Bool +okParent _ (VanillaAlgTyCon {}) = True +okParent _ (UnboxedSumTyCon {}) = True +okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) +okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc + +isNoParent :: AlgTyConFlav -> Bool +isNoParent (VanillaAlgTyCon {}) = True +isNoParent _ = False + +-------------------- + +data Injectivity + = NotInjective + | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) + deriving( Eq ) + +-- | Information pertaining to the expansion of a type synonym (@type@) +data FamTyConFlav + = -- | Represents an open type family without a fixed right hand + -- side. Additional instances can appear at any time. + -- + -- These are introduced by either a top level declaration: + -- + -- > data family T a :: Type + -- + -- Or an associated data type declaration, within a class declaration: + -- + -- > class C a b where + -- > data T b :: Type + DataFamilyTyCon + TyConRepName + + -- | An open type synonym family e.g. @type family F x y :: Type -> Type@ + | OpenSynFamilyTyCon + + -- | A closed type synonym family e.g. + -- @type family F x where { F Int = Bool }@ + | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) + -- See Note [Closed type families] + + -- | A closed type synonym family declared in an hs-boot file with + -- type family F a where .. + | AbstractClosedSynFamilyTyCon + + -- | Built-in type family used by the TypeNats solver + | BuiltInSynFamTyCon BuiltInSynFamily + +instance Outputable FamTyConFlav where + ppr (DataFamilyTyCon n) = text "data family" <+> ppr n + ppr OpenSynFamilyTyCon = text "open type family" + ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" + ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax + ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" + ppr (BuiltInSynFamTyCon _) = text "built-in type family" + +{- Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* In an open type family you can add new instances later. This is the + usual case. + +* In a closed type family you can only put equations where the family + is defined. + +A non-empty closed type family has a single axiom with multiple +branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed +type family with no equations does not have an axiom, because there is +nothing for the axiom to prove! + + +Note [Promoted data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All data constructors can be promoted to become a type constructor, +via the PromotedDataCon alternative in GHC.Core.TyCon. + +* The TyCon promoted from a DataCon has the *same* Name and Unique as + the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78) + is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) + +* We promote the *user* type of the DataCon. Eg + data T = MkT {-# UNPACK #-} !(Bool, Bool) + The promoted kind is + 'MkT :: (Bool,Bool) -> T + *not* + 'MkT :: Bool -> Bool -> T + +* Similarly for GADTs: + data G a where + MkG :: forall b. b -> G [b] + The promoted data constructor has kind + 'MkG :: forall b. b -> G [b] + *not* + 'MkG :: forall a b. (a ~# [b]) => b -> G a + +Note [Enumeration types] +~~~~~~~~~~~~~~~~~~~~~~~~ +We define datatypes with no constructors to *not* be +enumerations; this fixes #2578, Otherwise we +end up generating an empty table for + __closure_tbl +which is used by tagToEnum# to map Int# to constructors +in an enumeration. The empty table apparently upset +the linker. + +Moreover, all the data constructor must be enumerations, meaning +they have type (forall abc. T a b c). GADTs are not enumerations. +For example consider + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a +What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. +See #4528. + +Note [Newtype coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +The NewTyCon field nt_co is a CoAxiom which is used for coercing from +the representation type of the newtype, to the newtype itself. For +example, + + newtype T a = MkT (a -> a) + +the NewTyCon for T will contain nt_co = CoT where CoT :: forall a. T a ~ a -> a. + +We might also eta-contract the axiom: see Note [Newtype eta]. + +Note [Newtype eta] +~~~~~~~~~~~~~~~~~~ +Consider + newtype Parser a = MkParser (IO a) deriving Monad +Are these two types equal? That is, does a coercion exist between them? + Monad Parser + Monad IO +(We need this coercion to make the derived instance for Monad Parser.) + +Well, yes. But to see that easily we eta-reduce the RHS type of +Parser, in this case to IO, so that even unsaturated applications of +Parser will work right. So instead of + axParser :: forall a. Parser a ~ IO a +we generate an eta-reduced axiom + axParser :: Parser ~ IO + +This eta reduction is done when the type constructor is built, in +GHC.Tc.TyCl.Build.mkNewTyConRhs, and cached in NewTyCon. + +Here's an example that I think showed up in practice. +Source code: + newtype T a = MkT [a] + newtype Foo m = MkFoo (forall a. m a -> Int) + + w1 :: Foo [] + w1 = ... + + w2 :: Foo T + w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) + +After desugaring, and discarding the data constructors for the newtypes, +we would like to get: + w2 = w1 `cast` Foo axT + +so that w2 and w1 share the same code. To do this, the coercion axiom +axT must have + kind: axT :: T ~ [] + and arity: 0 + +See also Note [Newtype eta and homogeneous axioms] in GHC.Tc.TyCl.Build. + +Note [Unary class magic] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a class with just one method, or with no methods and one +superclass: + class UC a where { op :: a -> a } + class Eq a => UD a where {} +Such a class is called a /unary class/. + +We could represent the dictionary for a unary class with a data type: + data UC a where { MkUC :: (a->a) -> UC a } + data UD a where { MkUD :: Eq a => UD a } +But it would be more efficent to use a newtype; and for decades GHC did +exactly that, because: + + * Unary classes are surprisingly common, so it's a useful optimisation. + + * The `reflection` library uses `unsafeCoerce` to /rely/ on the fact that + a unary class is ultimately represented by its payload. We may not like + it, and I hope to ultimately eliminate the necessity for this by using + `withDict` (see Note [withDict] in GHC.Tc.Instance.Class). But meanwhile + we'd prefer not to break this usage. + +But alas, using a newtype representation (surprisingly) led multiple, subtle, +Bad Things: see Note [Representing unary classes with newtypes: bad, bad, bad]. + +This Note explains what GHC now does for unary classes. + +(UCM0) Throughout the compiler, right up to the code generator, GHC thinks that a + unary class is just like a non-unary class: + - Represented by a data type, + - with one constructor, + - which has one field + +(UCM1) Then when converting from Core to STG, in GHC.CoreToStg, we effectively + transform + - op ta tb tc dict_arg --> dict_arg + - MkUC ta tb tc meth_arg --> meth_arg + + Note that we do this transformation well /after/ generating an interface file, + so importing modules only see the data constructor. + + This late transformation has a lot in common with the treatment of + `unsafeEqualityProof`; see (U2) in Note [Implementing unsafeCoerce] + in GHC.Internal.Unsafe.Coerce. + +In this way we get the efficiency of a newtype without the bugs that we get +by exposing the newtype representation too early. + +There are a number of wrinkles + +(UCM2) The TyCon for a unary class is /not/ identified as a newtype. + Rather, it has its own AlgTyConRhs, namely `UnaryClassTyCon` + +(UCM3) Unlike non-unary classes, a value of type (C ty), where `C` is a unary + class, might be bottom, because it is represented by the method type alone. + See GHC.Core.Type.isTerminatingType. + + Similarly in exprOkForSpeculation/exprOkToDiscard/exprOkForSpecEval, + in GHC.Core.Utils. In the utility funcion `app_ok` we need a special + case for the DFunIds; they generally terminate, but not for unary classes. + +(UMC4) To avoid regressions, in Core we want to remember that + (MkUC x) is really just x + (op d) is really just d + We account for this in several places: + + - `GHC.Core.Utils.exprIsTrivial` treats the above two forms as trivial + + - `GHC.Core.Unfold.sizeExpr` (which computes the size of an expression to + guide inlining) treats (MkUC e) as the same size as `e`, and similarly + (op d). + + - `GHC.Core.Unfold.inlineBoringOK` where we want to ensure that we + always-inline (MkUC op), even into a boring context. See (IB6) + in Note [inlineBoringOk] + +(UCM5) `GHC.Core.Unfold.Make.mkDFunUnfolding` builds a `DFunUnfolding` for + non-unary classes, but just an /ordinary/ unfolding for unary classes. + instance Num a => Num [a] where { .. } -- (I1) + instance UC a => UC [a] where { op = $cop } -- (I2) + From (I1) we get + $fNumList = /\a \(d:Num a). MkNum (..) (..) (..) + -- $fNumList has a DFunUnfolding + But from (I2) we get + $fUCList = /\a (d:UC a). MkUC ($cop a d) + -- $fUCList has a regular CoreUnfolding + + Why? Because we can safely inline $fUCList without code-size blow-up. + Just one less indirection. It'd probably work ok with a DFunUnfolding; + and it'd add another case for (UCM4) to spot. + +(UCM6) In the constraint solver, when constructing evidence for a unary class + (e.g. implicit parameters, withDict) be careful to use + - the data constructor to build it: see `evDictApp`, `evUnaryDictAppE` + - the class op to take it apart: see `evUnwrapIP` + +(UCM7) You might worry about + class UC1 a where { op :: Int# } -- Single unboxed field + class (a ~# b) => UC2 a b where {} -- Unboxed equality superclass + But these are illegal: predicates are always boxed, and all classes must have + lifted fields. + +(UCM8) The data constructor for a unary class has no wrapper, just a worker. + (And the worker is turned into a cast by GHC.CoreToStg.Prep.isUnaryClassApp, + as described above.) + +(UCM9) Unary classes are treated as injective by `isInjectiveTyCon`, just like + non-unary classes (which are TupleTyCons or DataTyCons). This matters, + because of the injectivity check done by lintCoercion (SelCo cs co) + in GHC.Core.Lint. There is a similar injectivity check in + GHC.Core.Opt.Arity.pushCoDataCon. + + Generally, we want unary classes to behave like ordinary non-unary ones. + +(UCM10) When, precisely, is a class unary? It is unary iff + it has one field (superclass or method) + of boxed type + The boxed-ness important. Consider + class (a ~# b) => a ~ b where {} + which is `eqClass` in GHC.Builtin.Types. This has only one field, but it is + definitely not a unary class: it is definitely represented by an ordinary + algebraic data type with a single field of type (a ~# b). + + See `unary_class` in `GHC.Tc.TyCl.tcClassDecl1` + +(UCM11) When building evidence for classes (unary or not) and implicit parameters, + the constraint solver is careful to use functions that hide the precise + evidence construction method. Eg.g `evWrapIPE`. + +(UCM12) In an interface-file description of a Class, we record whether or not + the class is unary. In theory this field is redundant, but because its value + depends on the superclass and method fields, it's very easy to end up with + a black hole when rehydrating interface the interface file. Easiest just to + store the bit! See `ifUnary` in GHC.Iface.Synatax.IfaceClassBody. + + +Note [Representing unary classes with newtypes: bad, bad, bad] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the past we represented a unary class with a newtype, but that led to +some at least three really subtle bad consequences. + +* Problem 1: When we represented unary classes via a newtype, the + newtype axiom looked like + t1::CONSTRAINT r ~ t2::TYPE r + If TYPE and CONSTRAINT are apart, this can create unsoundness, via KindCo; + see #21623. Now we never make such a coercion, so that worry about TYPE + being apart from CONSTRAINT has gone away entirely. Hooray. + +* Problem 2: a horrible hack in GHC.Core.Opt.OccurAnal.scrutOkForBinderSwap; + see Historical Note [Care with binder-swap on dictionaries]. + Now the hack is gone. + +* Problem 3: bogus specialisation. The gory details are explained + at https://gitlab.haskell.org/ghc/ghc/-/issues/23109#note_499130 + + We had (using newtype classes) + newtype SNat a = MKSNat Natural -- axiom snCo a :: SNat a ~ Natural + class KNat a where { natSing :: SNat a } -- axiom knCo a :: KNat a ~ SNat a + and a pattern match + K @a (g : 32 ~ a+1) -> ...(foo @a (d :: KNat a))... + where K is a data constructor binding `a` as an existential. + + In the code I was looking at, after lots of inlining an simplification, we find + that (d::KNat a) is built like this: + (d1 :: KNat 32) = 32 |> sym (snCo 32) |> sym (knCo 32) + (d2 :: SNat (a+1)) = d1 |> knCo g + (d3 :: Natural) = d2 |> snCo (a+1) + (d4 :: Natural) = d3 - 1 + (d :: KNat a) = d4 |> sym (snCo a) |> sym (knCo a) + + But d3 :: Natural = 32 |> (co's involving g) :: Natural ~ Natural + and that is just Refl. So we drop all the co's, including the crucial `g`, + and just say d3 = 32; and + d :: KNat a = (32-1) |> sym (snCo a) |> sym (knCo a) + Now, we can float `d` outwards, crucially aided by polymorphic specialisation, + (Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise) + and use that evidence to get an utterly bogus specialisation for the function + foo :: forall b. KNat b => blah + + Solution: don't use newtype classes. Then we get + (d1 :: KNat 32) = MkKN @32 (32 |> sym (snCo 32)) + (d2 :: SNat (a+1)) = natSing d1 |> SN g + (d3 :: Natural) = d2 |> snCo (a+1) + (d4 :: Natural) = d3 -1 + (d :: KNat a) = MkKN @a (d4 |> sym (snCo a)) + Now we don't get cancelling-out coercions. + + +************************************************************************ +* * + TyConRepName +* * +********************************************************************* -} + +type TyConRepName = Name + -- The Name of the top-level declaration for the Typeable world + -- $tcMaybe :: Data.Typeable.Internal.TyCon + -- $tcMaybe = TyCon { tyConName = "Maybe", ... } + +tyConRepName_maybe :: TyCon -> Maybe TyConRepName +tyConRepName_maybe (TyCon { tyConDetails = details }) = get_rep_nm details + where + get_rep_nm (PrimTyCon { primRepName = rep_nm }) + = Just rep_nm + get_rep_nm (AlgTyCon { algTcFlavour = parent }) + = case parent of + VanillaAlgTyCon rep_nm -> Just rep_nm + UnboxedSumTyCon -> Nothing + ClassTyCon _ rep_nm -> Just rep_nm + DataFamInstTyCon {} -> Nothing + get_rep_nm (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) + = Just rep_nm + get_rep_nm (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) + | isUnboxedSumDataCon dc -- see #13276 + = Nothing + | otherwise + = Just rep_nm + get_rep_nm _ = Nothing + +-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type +mkPrelTyConRepName :: Name -> TyConRepName +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +mkPrelTyConRepName tc_name -- Prelude tc_name is always External, + -- so nameModule will work + = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) + where + name_occ = nameOccName tc_name + name_mod = nameModule tc_name + name_uniq = nameUnique tc_name + rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq + | otherwise = dataConTyRepNameUnique name_uniq + (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ + +-- | The name (and defining module) for the Typeable representation (TyCon) of a +-- type constructor. +-- +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +tyConRepModOcc :: Module -> OccName -> (Module, OccName) +tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) + where + rep_module + | tc_module == gHC_PRIM = gHC_TYPES + | otherwise = tc_module + + +{- ********************************************************************* +* * + PrimRep +* * +************************************************************************ + +Note [rep swamp] +~~~~~~~~~~~~~~~~ +GHC has a rich selection of types that represent "primitive types" of +one kind or another. Each of them makes a different set of +distinctions, and mostly the differences are for good reasons, +although it's probably true that we could merge some of these. + +Roughly in order of "includes more information": + + - A Width ("GHC.Cmm.Type") is simply a binary value with the specified + number of bits. It may represent a signed or unsigned integer, a + floating-point value, or an address. + + data Width = W8 | W16 | W32 | W64 | W128 + + - Size, which is used in the native code generator, is Width + + floating point information. + + data Size = II8 | II16 | II32 | II64 | FF32 | FF64 + + it is necessary because e.g. the instruction to move a 64-bit float + on x86 (movsd) is different from the instruction to move a 64-bit + integer (movq), so the mov instruction is parameterised by Size. + + - CmmType wraps Width with more information: GC ptr, float, or + other value. + + data CmmType = CmmType CmmCat Width + + data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + + It is important to have GcPtr information in Cmm, since we generate + info tables containing pointerhood for the GC from this. As for + why we have float (and not signed/unsigned) here, see Note [Signed + vs unsigned]. + + - ArgRep makes only the distinctions necessary for the call and + return conventions of the STG machine. It is essentially CmmType + + void. + + - PrimRep makes a few more distinctions than ArgRep: it divides + non-GC-pointers into signed/unsigned and addresses, information + that is necessary for passing these values to foreign functions. + +There's another tension here: whether the type encodes its size in +bytes, or whether its size depends on the machine word size. Width +and CmmType have the size built-in, whereas ArgRep and PrimRep do not. + +This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. + +On the other hand, CmmType includes some "nonsense" values, such as +CmmType GcPtrCat W32 on a 64-bit machine. + +The PrimRep type is closely related to the user-visible RuntimeRep type. +See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. + +-} + + +-- | A 'PrimRep' is an abstraction of a /non-void/ type. +-- (Use 'PrimRepOrVoidRep' if you want void types too.) +-- It contains information that the code generator needs +-- in order to pass arguments, return results, +-- and store values of this type. See also Note [RuntimeRep and PrimRep] in +-- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". +data PrimRep +-- Unpacking of sum types is only supported since 9.6.1 + = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value + | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value + | Int32Rep -- ^ Signed, 32-bit value + | Int64Rep -- ^ Signed, 64 bit value + | IntRep -- ^ Signed, word-sized value + | Word8Rep -- ^ Unsigned, 8 bit value + | Word16Rep -- ^ Unsigned, 16 bit value + | Word32Rep -- ^ Unsigned, 32 bit value + | Word64Rep -- ^ Unsigned, 64 bit value + | WordRep -- ^ Unsigned, word-sized value + | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use 'BoxedRep') + | FloatRep + | DoubleRep + | VecRep Int PrimElemRep -- ^ A vector + deriving( Data.Data, Eq, Ord, Show ) + +data PrimOrVoidRep = VoidRep | NVRep PrimRep + -- See Note [VoidRep] in GHC.Types.RepType + deriving (Data.Data, Eq, Ord, Show) + +data PrimElemRep + = Int8ElemRep + | Int16ElemRep + | Int32ElemRep + | Int64ElemRep + | Word8ElemRep + | Word16ElemRep + | Word32ElemRep + | Word64ElemRep + | FloatElemRep + | DoubleElemRep + deriving( Data.Data, Eq, Ord, Show, Enum ) + +instance Outputable PrimRep where + ppr r = text (show r) + +instance Outputable PrimElemRep where + ppr r = text (show r) + +instance Binary PrimRep where + put_ bh (BoxedRep ml) = case ml of + -- cheaper storage of the levity than using + -- the Binary (Maybe Levity) instance + Nothing -> putByte bh 0 + Just Lifted -> putByte bh 1 + Just Unlifted -> putByte bh 2 + put_ bh Int8Rep = putByte bh 3 + put_ bh Int16Rep = putByte bh 4 + put_ bh Int32Rep = putByte bh 5 + put_ bh Int64Rep = putByte bh 6 + put_ bh IntRep = putByte bh 7 + put_ bh Word8Rep = putByte bh 8 + put_ bh Word16Rep = putByte bh 9 + put_ bh Word32Rep = putByte bh 10 + put_ bh Word64Rep = putByte bh 11 + put_ bh WordRep = putByte bh 12 + put_ bh AddrRep = putByte bh 13 + put_ bh FloatRep = putByte bh 14 + put_ bh DoubleRep = putByte bh 15 + put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per + get bh = do + h <- getByte bh + case h of + 0 -> pure $ BoxedRep Nothing + 1 -> pure $ BoxedRep (Just Lifted) + 2 -> pure $ BoxedRep (Just Unlifted) + 3 -> pure Int8Rep + 4 -> pure Int16Rep + 5 -> pure Int32Rep + 6 -> pure Int64Rep + 7 -> pure IntRep + 8 -> pure Word8Rep + 9 -> pure Word16Rep + 10 -> pure Word32Rep + 11 -> pure Word64Rep + 12 -> pure WordRep + 13 -> pure AddrRep + 14 -> pure FloatRep + 15 -> pure DoubleRep + 16 -> VecRep <$> get bh <*> get bh + _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h)) + +instance Binary PrimElemRep where + put_ bh per = putByte bh (fromIntegral (fromEnum per)) + get bh = toEnum . fromIntegral <$> getByte bh + +isGcPtrRep :: PrimRep -> Bool +isGcPtrRep (BoxedRep _) = True +isGcPtrRep _ = False + +-- A PrimRep is compatible with another iff one can be coerced to the other. +-- See Note [Bad unsafe coercion] in GHC.Core.Lint for when are two types coercible. +primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool +primRepCompatible platform rep1 rep2 = + (isUnboxed rep1 == isUnboxed rep2) && + (primRepSizeB platform rep1 == primRepSizeB platform rep2) && + (primRepIsFloat rep1 == primRepIsFloat rep2) + where + isUnboxed = not . isGcPtrRep + +-- More general version of `primRepCompatible` for types represented by zero or +-- more than one PrimReps. +primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool +primRepsCompatible platform reps1 reps2 = + length reps1 == length reps2 && + and (zipWith (primRepCompatible platform) reps1 reps2) + +-- | The size of a 'PrimRep' in bytes. +-- +-- This applies also when used in a constructor, where we allow packing the +-- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will +-- take only 8 bytes, which for 64-bit arch will be equal to 1 word. +-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are +-- laid out. +primRepSizeB :: Platform -> PrimRep -> Int +primRepSizeB platform = \case + IntRep -> platformWordSizeInBytes platform + WordRep -> platformWordSizeInBytes platform + Int8Rep -> 1 + Int16Rep -> 2 + Int32Rep -> 4 + Int64Rep -> 8 + Word8Rep -> 1 + Word16Rep -> 2 + Word32Rep -> 4 + Word64Rep -> 8 + FloatRep -> fLOAT_SIZE + DoubleRep -> dOUBLE_SIZE + AddrRep -> platformWordSizeInBytes platform + BoxedRep _ -> platformWordSizeInBytes platform + (VecRep len rep) -> len * primElemRepSizeB platform rep + +-- | Like primRepSizeB but assumes pointers/words are 8 words wide. +-- +-- This can be useful to compute the size of a rep as if we were compiling +-- for a 64bit platform. +primRepSizeW64_B :: PrimRep -> Int +primRepSizeW64_B = \case + IntRep -> 8 + WordRep -> 8 + Int8Rep -> 1 + Int16Rep -> 2 + Int32Rep -> 4 + Int64Rep -> 8 + Word8Rep -> 1 + Word16Rep -> 2 + Word32Rep -> 4 + Word64Rep -> 8 + FloatRep -> fLOAT_SIZE + DoubleRep -> dOUBLE_SIZE + AddrRep -> 8 + BoxedRep{} -> 8 + (VecRep len rep) -> len * primElemRepSizeW64_B rep + +primElemRepSizeB :: Platform -> PrimElemRep -> Int +primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep + +-- | Like primElemRepSizeB but assumes pointers/words are 8 words wide. +-- +-- This can be useful to compute the size of a rep as if we were compiling +-- for a 64bit platform. +primElemRepSizeW64_B :: PrimElemRep -> Int +primElemRepSizeW64_B = primRepSizeW64_B . primElemRepToPrimRep + +primElemRepToPrimRep :: PrimElemRep -> PrimRep +primElemRepToPrimRep Int8ElemRep = Int8Rep +primElemRepToPrimRep Int16ElemRep = Int16Rep +primElemRepToPrimRep Int32ElemRep = Int32Rep +primElemRepToPrimRep Int64ElemRep = Int64Rep +primElemRepToPrimRep Word8ElemRep = Word8Rep +primElemRepToPrimRep Word16ElemRep = Word16Rep +primElemRepToPrimRep Word32ElemRep = Word32Rep +primElemRepToPrimRep Word64ElemRep = Word64Rep +primElemRepToPrimRep FloatElemRep = FloatRep +primElemRepToPrimRep DoubleElemRep = DoubleRep + +-- | Return if Rep stands for floating type, +-- returns Nothing for vector types. +primRepIsFloat :: PrimRep -> Maybe Bool +primRepIsFloat FloatRep = Just True +primRepIsFloat DoubleRep = Just True +primRepIsFloat (VecRep _ _) = Nothing +primRepIsFloat _ = Just False + +-- Rep is one of the word reps. +primRepIsWord :: PrimRep -> Bool +primRepIsWord WordRep = True +primRepIsWord (Word8Rep) = True +primRepIsWord (Word16Rep) = True +primRepIsWord (Word32Rep) = True +primRepIsWord (Word64Rep) = True +primRepIsWord _ = False + +-- Rep is one of the int reps. +primRepIsInt :: PrimRep -> Bool +primRepIsInt (IntRep) = True +primRepIsInt (Int8Rep) = True +primRepIsInt (Int16Rep) = True +primRepIsInt (Int32Rep) = True +primRepIsInt (Int64Rep) = True +primRepIsInt _ = False + +{- +************************************************************************ +* * + Field labels +* * +************************************************************************ +-} + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabels :: TyCon -> [FieldLabel] +tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabelEnv :: TyCon -> FieldLabelEnv +tyConFieldLabelEnv (TyCon { tyConDetails = details }) + | AlgTyCon { algTcFields = fields } <- details = fields + | otherwise = emptyDFsEnv + +-- | Look up a field label belonging to this 'TyCon' +lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel +lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) (field_label lbl) + +-- | Make a map from strings to FieldLabels from all the data +-- constructors of this algebraic tycon +fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv +fieldsOfAlgTcRhs rhs = mkDFsEnv [ (field_label $ flLabel fl, fl) + | fl <- dataConsFields (visibleDataCons rhs) ] + where + -- Duplicates in this list will be removed by 'mkFsEnv' + dataConsFields dcs = concatMap dataConFieldLabels dcs + + +{- +************************************************************************ +* * +\subsection{TyCon Construction} +* * +************************************************************************ + +Note: the TyCon constructors all take a Kind as one argument, even though +they could, in principle, work out their Kind from their other arguments. +But to do so they need functions from Types, and that makes a nasty +module mutual-recursion. And they aren't called from many places. +So we compromise, and move their Kind calculation to the call site. +-} + +mkTyCon :: Name -> [TyConBinder] -> Kind -> [Role] -> TyConDetails -> TyCon +mkTyCon name binders res_kind roles details + = tc + where + -- Recurisve binding because of tcNullaryTy + tc = TyCon { tyConName = name + , tyConUnique = nameUnique name + , tyConBinders = binders + , tyConResKind = res_kind + , tyConRoles = roles + , tyConDetails = details + + -- Cached things + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tyConNullaryTy = mkNakedTyConTy tc + , tyConHasClosedResKind = noFreeVarsOfType res_kind + , tyConTyVars = binderVars binders } + +-- | This is the making of an algebraic 'TyCon'. +mkAlgTyCon :: Name + -> [TyConBinder] -- ^ Binders of the 'TyCon' + -> Kind -- ^ Result kind + -> [Role] -- ^ The roles for each TyVar + -> Maybe CType -- ^ The C type this type corresponds to + -- when using the CAPI FFI + -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' + -> AlgTyConRhs -- ^ Information about data constructors + -> AlgTyConFlav -- ^ What flavour is it? + -- (e.g. vanilla, type family) + -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? + -> TyCon +mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn + = mkTyCon name binders res_kind roles $ + AlgTyCon { tyConCType = cType + , algTcStupidTheta = stupid + , algTcRhs = rhs + , algTcFields = fieldsOfAlgTcRhs rhs + , algTcFlavour = assertPpr (okParent name parent) + (ppr name $$ ppr parent) parent + , algTcGadtSyntax = gadt_syn } + +-- | Simpler specialization of 'mkAlgTyCon' for classes +mkClassTyCon :: Name -> [TyConBinder] + -> [Role] -> AlgTyConRhs -> Class + -> Name -> TyCon +mkClassTyCon name binders roles rhs clas tc_rep_name + = mkAlgTyCon name binders constraintKind roles Nothing [] rhs + (ClassTyCon clas tc_rep_name) + False + +mkTupleTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Result kind of the 'TyCon' + -> DataCon + -> TupleSort -- ^ Whether the tuple is boxed or unboxed + -> AlgTyConFlav + -> TyCon +mkTupleTyCon name binders res_kind con sort parent + = mkTyCon name binders res_kind (constRoles binders Representational) $ + AlgTyCon { tyConCType = Nothing + , algTcGadtSyntax = False + , algTcStupidTheta = [] + , algTcRhs = TupleTyCon { data_con = con + , tup_sort = sort } + , algTcFields = emptyDFsEnv + , algTcFlavour = parent } + +constRoles :: [TyConBinder] -> Role -> [Role] +constRoles bndrs role = [role | _ <- bndrs] + +mkSumTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Kind of the resulting 'TyCon' + -> [DataCon] + -> AlgTyConFlav + -> TyCon +mkSumTyCon name binders res_kind cons parent + = mkTyCon name binders res_kind (constRoles binders Representational) $ + AlgTyCon { tyConCType = Nothing + , algTcGadtSyntax = False + , algTcStupidTheta = [] + , algTcRhs = mkSumTyConRhs cons + , algTcFields = emptyDFsEnv + , algTcFlavour = parent } + +-- | Makes a tycon suitable for use during type-checking. It stores +-- a variety of details about the definition of the TyCon, but no +-- right-hand side. It lives only during the type-checking of a +-- mutually-recursive group of tycons; it is then zonked to a proper +-- TyCon in zonkTcTyCon. +-- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in "GHC.Tc.TyCl" +mkTcTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ /result/ kind only + -> [(Name,TcTyVar)] -- ^ Scoped type variables; + -> Bool -- ^ Is this TcTyCon generalised already? + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' this represents + -> TyCon +mkTcTyCon name binders res_kind scoped_tvs poly flav + = mkTyCon name binders res_kind (constRoles binders Nominal) $ + TcTyCon { tctc_scoped_tvs = scoped_tvs + , tctc_is_poly = poly + , tctc_flavour = flav } + +-- | No scoped type variables (to be used with mkTcTyCon). +noTcTyConScopedTyVars :: [(Name, TcTyVar)] +noTcTyConScopedTyVars = [] + +-- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld@ +-- Primitive TyCons are marshalable iff not lifted. +-- If you'd like to change this, modify marshalablePrimTyCon. +mkPrimTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind + -- Must answer 'True' to 'isFixedRuntimeRepKind' (i.e., no representation polymorphism). + -- (If you need a representation-polymorphic PrimTyCon, + -- change tcHasFixedRuntimeRep, marshalablePrimTyCon, reifyTyCon for PrimTyCons.) + -> [Role] + -> TyCon +mkPrimTyCon name binders res_kind roles + = mkTyCon name binders res_kind roles $ + PrimTyCon { primRepName = mkPrelTyConRepName name } + +-- | Create a type synonym 'TyCon' +mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> Type + -> Bool -> Bool -> Bool -> Bool + -> TyCon +mkSynonymTyCon name binders res_kind roles rhs is_tau + is_fam_free is_forgetful is_concrete + = mkTyCon name binders res_kind roles $ + SynonymTyCon { synTcRhs = rhs + , synIsTau = is_tau + , synIsFamFree = is_fam_free + , synIsForgetful = is_forgetful + , synIsConcrete = is_concrete } + +-- | Create a type family 'TyCon' +mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> Maybe Name -> FamTyConFlav + -> Maybe Class -> Injectivity -> TyCon +mkFamilyTyCon name binders res_kind resVar flav parent inj + = mkTyCon name binders res_kind (constRoles binders Nominal) $ + FamilyTyCon { famTcResVar = resVar + , famTcFlav = flav + , famTcParent = classTyCon <$> parent + , famTcInj = inj } + +-- | Create a promoted data constructor 'TyCon' +-- Somewhat dodgily, we give it the same Name +-- as the data constructor itself; when we pretty-print +-- the TyCon we add a quote; see the Outputable TyCon instance +mkPromotedDataCon :: DataCon -> Name -> TyConRepName + -> [TyConBinder] -> Kind -> [Role] + -> PromDataConInfo -> TyCon +mkPromotedDataCon con name rep_name binders res_kind roles rep_info + = mkTyCon name binders res_kind roles $ + PromotedDataCon { dataCon = con + , tcRepName = rep_name + , promDcInfo = rep_info } + +-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) +isAbstractTyCon :: TyCon -> Bool +isAbstractTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = AbstractTyCon {} } <- details = True + | otherwise = False + +-- | Does this 'TyCon' represent something that cannot be defined in Haskell? +isPrimTyCon :: TyCon -> Bool +isPrimTyCon (TyCon { tyConDetails = details }) + | PrimTyCon {} <- details = True + | otherwise = False + +-- | Returns @True@ if the supplied 'TyCon' resulted from either a +-- @data@ or @newtype@ declaration +isAlgTyCon :: TyCon -> Bool +isAlgTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {} <- details = True + | otherwise = False + +-- | Returns @True@ for vanilla AlgTyCons -- that is, those created +-- with a @data@ or @newtype@ declaration. +isVanillaAlgTyCon :: TyCon -> Bool +isVanillaAlgTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcFlavour = VanillaAlgTyCon _ } <- details = True + | otherwise = False + +-- | Returns @True@ if a boxed type headed by the given @TyCon@ +-- satisfies condition DTT2 of Note [DataToTag overview] in +-- GHC.Tc.Instance.Class +isValidDTT2TyCon :: TyCon -> Bool +isValidDTT2TyCon = isBoxedDataTyCon + +isBoxedDataTyCon :: TyCon -> Bool +-- ^ Returns @True@ for data types that are /definitely/ represented by +-- heap-allocated constructors. These are scrutinised by Core-level +-- @case@ expressions, and they get info tables allocated for them. +-- +-- Generally, the function will be +-- true for all `data` types and +-- false for newtype +-- unboxed tuples +-- unboxed sums +-- type family +-- type data +-- 'TyCon's. But it is not guaranteed to return `True` in all cases +-- that it could. +-- +-- NB: for a data type family, only the /instance/ 'TyCon's +-- get an info table. The family declaration 'TyCon' does not +isBoxedDataTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = rhs} <- details + = case rhs of + TupleTyCon { tup_sort = sort } + -> isBoxed (tupleSortBoxity sort) + SumTyCon {} -> False + -- Constructors from "type data" declarations exist only at + -- the type level. + -- See Note [Type data declarations] in GHC.Rename.Module. + DataTyCon { is_type_data = type_data } -> not type_data + NewTyCon {} -> False + UnaryClassTyCon {} -> False + AbstractTyCon {} -> False -- We don't know, so return False +isBoxedDataTyCon _ = False + +-- | Was this 'TyCon' declared as "type data"? +-- See Note [Type data declarations] in GHC.Rename.Module. +isTypeDataTyCon :: TyCon -> Bool +isTypeDataTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = DataTyCon {is_type_data = type_data }} <- details + = type_data + | otherwise = False + +-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds +-- (where r is the role passed in): +-- If (T a1 b1 c1) ~r (T a2 b2 c2), then (a1 ~r1 a2), (b1 ~r2 b2), and (c1 ~r3 c2) +-- (where r1, r2, and r3, are the roles given by tyConRolesX tc r) +-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality" +isInjectiveTyCon :: TyCon -> Role -> Bool +isInjectiveTyCon (TyCon { tyConDetails = details }) role + = go details + where + go _ | Phantom <- role = True -- Vacuously; (t1 ~P t2) holds for all t1, t2! + + go (AlgTyCon {algTcRhs = rhs}) + | Nominal <- role = True + | Representational <- role = go_alg_rep rhs + + go (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) + | Nominal <- role = True + go (FamilyTyCon { famTcInj = Injective inj }) + | Nominal <- role = and inj + go (FamilyTyCon {}) = False + + go (SynonymTyCon {}) = False + go (PrimTyCon {}) = True + go (PromotedDataCon {}) = True + go (TcTyCon {}) = True + -- Reply True for TcTyCon to minimise knock on type errors + -- See (W1) in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl + + -- go_alg_rep used only at Representational role + go_alg_rep (TupleTyCon {}) = True + go_alg_rep (SumTyCon {}) = True + go_alg_rep (DataTyCon {}) = True + go_alg_rep (UnaryClassTyCon {}) = True -- See (UCM9) in Note [Unary class magic] + go_alg_rep (AbstractTyCon {}) = False + go_alg_rep (NewTyCon {}) = False + +-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds +-- (where r is the role passed in): +-- If (T tys ~r t), then (t's head ~r T). +-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality" +-- +-- NB: at Nominal role, isGenerativeTyCon is simple: +-- isGenerativeTyCon tc Nominal +-- = not (isTypeFamilyTyCon tc || isSynonymTyCon tc) +isGenerativeTyCon :: TyCon -> Role -> Bool +isGenerativeTyCon tc@(TyCon { tyConDetails = details }) role + = go role details + where + go Nominal (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) = True + go _ (FamilyTyCon {}) = False + + -- In all other cases, injectivity implies generativity + go r _ = isInjectiveTyCon tc r + +-- | Is this 'TyCon' that for a @newtype@ +isNewTyCon :: TyCon -> Bool +isNewTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon {}} <- details = True + | otherwise = False + +-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it +-- expands into, and (possibly) a coercion from the representation type to the +-- @newtype@. +-- Returns @Nothing@ if this is not possible. +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyCon_maybe (TyCon { tyConTyVars = tvs, tyConDetails = details }) + | AlgTyCon { algTcRhs = NewTyCon { nt_co = co, nt_rhs = rhs }} <- details + = Just (tvs, rhs, co) + | otherwise = Nothing + +unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyConEtad_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = NewTyCon { nt_co = co + , nt_etad_rhs = (tvs,rhs) }} <- details + = Just (tvs, rhs, co) + | otherwise = Nothing + +-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? +{-# INLINE isTypeSynonymTyCon #-} -- See Note [Inlining coreView] in GHC.Core.Type +isTypeSynonymTyCon :: TyCon -> Bool +isTypeSynonymTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon {} <- details = True + | otherwise = False + +isTauTyCon :: TyCon -> Bool +isTauTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon { synIsTau = is_tau } <- details = is_tau + | otherwise = True + +-- | Is this tycon neither a type family nor a synonym that expands +-- to a type family? +isFamFreeTyCon :: TyCon -> Bool +isFamFreeTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon { synIsFamFree = fam_free } <- details = fam_free + | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav + | otherwise = True + +-- | Is this a forgetful type synonym? If this is a type synonym whose +-- RHS does not mention one (or more) of its bound variables, returns +-- True. Thus, False means that all bound variables appear on the RHS; +-- True may not mean anything, as the test to set this flag is +-- conservative. +-- +-- See Note [Forgetful type synonyms] +isForgetfulSynTyCon :: TyCon -> Bool +isForgetfulSynTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon { synIsForgetful = forget } <- details = forget + | otherwise = False + +{- Note [Forgetful type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type synonyms is /forgetful/ if its RHS fails to mention one (or more) of its bound variables. + +Forgetfulness is conservative: + * A non-forgetful synonym /guarantees/ to mention all its bound variables in its RHS. + * It is always safe to classify a synonym as forgetful. + +Examples: + type R = Int -- Not forgetful + type S a = Int -- Forgetful + type T1 a = Int -> S a -- Forgetful + type T2 a = a -> S a -- Not forgetful + type T3 a = Int -> F a -- Not forgetful + where type family F a + +* R shows that nullary synonyms are not forgetful. + +* T2 shows that forgetfulness needs to account for uses of forgetful + synonyms. `a` appears on the RHS, but only under a forgetful S + +* T3 shows that non-forgetfulness is not the same as injectivity. T3 mentions its + bound variable on its RHS, but under a type family. So it is entirely possible + that T3 Int ~ T3 Bool + +* Since type synonyms are non-recursive, we don't need a fixpoint analysis to + determine forgetfulness. It's rather easy -- see `GHC.Core.Type.buildSynTyCon`, + which is a bit over-conservative for over-saturated synonyms. +-} + +-- As for newtypes, it is in some contexts important to distinguish between +-- closed synonyms and synonym families, as synonym families have no unique +-- right hand side to which a synonym family application can expand. +-- + +-- | True iff we can decompose (T a b c) into ((T a b) c) +-- I.e. is it injective and generative w.r.t nominal equality? +-- That is, if (T a b) ~N d e f, is it always the case that +-- (T ~N d), (a ~N e) and (b ~N f)? +-- Specifically NOT true of synonyms (open and otherwise) +-- +-- It'd be unusual to call tyConMustBeSaturated on a regular H98 +-- type synonym, because you should probably have expanded it first +-- But regardless, it's not decomposable +tyConMustBeSaturated :: TyCon -> Bool +tyConMustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour + +-- | Is this an algebraic 'TyCon' declared with the GADT syntax? +isGadtSyntaxTyCon :: TyCon -> Bool +isGadtSyntaxTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcGadtSyntax = res } <- details = res + | otherwise = False + +-- | Is this an algebraic 'TyCon' which is just an enumeration of values? +isEnumerationTyCon :: TyCon -> Bool +-- See Note [Enumeration types] in GHC.Core.TyCon +isEnumerationTyCon (TyCon { tyConArity = arity, tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + = case rhs of + DataTyCon { is_enum = res } -> res + TupleTyCon { tup_sort = tsort } + | arity == 0 -> isBoxed (tupleSortBoxity tsort) + -- () is an enumeration, but (##) is not + _ -> False + | otherwise = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family? +isFamilyTyCon :: TyCon -> Bool +isFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon {} <- details = True + | otherwise = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family with +-- instances? +isOpenFamilyTyCon :: TyCon -> Bool +isOpenFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = flav } <- details + = case flav of + OpenSynFamilyTyCon -> True + DataFamilyTyCon {} -> True + _ -> False + | otherwise = False + +-- | Is this a type family 'TyCon' (whether open or closed)? +isTypeFamilyTyCon :: TyCon -> Bool +isTypeFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon { famTcFlav = flav } <- details = not (isDataFamFlav flav) + | otherwise = False + +-- | Is this a data family 'TyCon'? +isDataFamilyTyCon :: TyCon -> Bool +isDataFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav + | otherwise = False + +-- | Is this an open type family TyCon? +isOpenTypeFamilyTyCon :: TyCon -> Bool +isOpenTypeFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = OpenSynFamilyTyCon } <- details = True + | otherwise = False + +-- | Is this a non-empty closed type family? Returns 'Nothing' for +-- abstract or empty closed families. +isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) +isClosedSynFamilyTyConWithAxiom_maybe (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb} <- details = mb + | otherwise = Nothing + +isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily +isBuiltInSynFamTyCon_maybe (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops} <- details = Just ops + | otherwise = Nothing + +-- | Extract type variable naming the result of injective type family +tyConFamilyResVar_maybe :: TyCon -> Maybe Name +tyConFamilyResVar_maybe (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcResVar = res} <- details = res + | otherwise = Nothing + +-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an +-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is +-- injective), or 'NotInjective' otherwise. +tyConInjectivityInfo :: TyCon -> Injectivity +tyConInjectivityInfo tc@(TyCon { tyConDetails = details }) + | FamilyTyCon { famTcInj = inj } <- details + = inj + | isInjectiveTyCon tc Nominal + = Injective (replicate (tyConArity tc) True) + | otherwise + = NotInjective + +isDataFamFlav :: FamTyConFlav -> Bool +isDataFamFlav (DataFamilyTyCon {}) = True -- Data family +isDataFamFlav _ = False -- Type synonym family + +-- | Is this TyCon for an associated type? +isTyConAssoc :: TyCon -> Bool +isTyConAssoc = isJust . tyConAssoc_maybe + +-- | Get the enclosing class TyCon (if there is one) for the given TyCon. +tyConAssoc_maybe :: TyCon -> Maybe TyCon +tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour + +-- The unit tycon didn't used to be classed as a tuple tycon +-- but I thought that was silly so I've undone it +-- If it can't be for some reason, it should be a AlgTyCon +isTupleTyCon :: TyCon -> Bool +-- ^ Does this 'TyCon' represent a tuple? +-- +-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to +-- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they +-- get spat into the interface file as tuple tycons, so I don't think +-- it matters. +isTupleTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = TupleTyCon {} } <- details = True + | otherwise = False + +tyConTuple_maybe :: TyCon -> Maybe TupleSort +tyConTuple_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , TupleTyCon { tup_sort = sort} <- rhs = Just sort + | otherwise = Nothing + +-- | Is this the 'TyCon' for an unboxed tuple? +isUnboxedTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , TupleTyCon { tup_sort = sort } <- rhs + = not (isBoxed (tupleSortBoxity sort)) + | otherwise = False + +-- | Is this the 'TyCon' for a boxed tuple? +isBoxedTupleTyCon :: TyCon -> Bool +isBoxedTupleTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , TupleTyCon { tup_sort = sort } <- rhs + = isBoxed (tupleSortBoxity sort) + | otherwise = False + +-- | Is this the 'TyCon' for an unboxed sum? +isUnboxedSumTyCon :: TyCon -> Bool +isUnboxedSumTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , SumTyCon {} <- rhs + = True + | otherwise = False + +isLiftedAlgTyCon :: TyCon -> Bool +isLiftedAlgTyCon (TyCon { tyConResKind = res_kind, tyConDetails = details }) + | AlgTyCon {} <- details = isLiftedTypeKind res_kind + | otherwise = False + +-- | Retrieves the promoted DataCon if this is a PromotedDataCon; +isPromotedDataCon_maybe :: TyCon -> Maybe DataCon +isPromotedDataCon_maybe (TyCon { tyConDetails = details }) + | PromotedDataCon { dataCon = dc } <- details = Just dc + | otherwise = Nothing + +-- | Is this the 'TyCon' for a /promoted/ tuple? +isPromotedTupleTyCon :: TyCon -> Bool +isPromotedTupleTyCon tyCon + | Just dataCon <- isPromotedDataCon_maybe tyCon + , isTupleTyCon (dataConTyCon dataCon) = True + | otherwise = False + +-- | Is this a PromotedDataCon? +isPromotedDataCon :: TyCon -> Bool +isPromotedDataCon (TyCon { tyConDetails = details }) + | PromotedDataCon {} <- details = True + | otherwise = False + +-- | This function identifies PromotedDataCon's from data constructors in +-- `data T = K1 | K2`, promoted by -XDataKinds. These type constructors +-- are printed with a tick mark 'K1 and 'K2, and similarly have a tick +-- mark added to their OccName's. +-- +-- In contrast, constructors in `type data T = K1 | K2` are printed and +-- represented with their original undecorated names. +-- See Note [Type data declarations] in GHC.Rename.Module +isDataKindsPromotedDataCon :: TyCon -> Bool +isDataKindsPromotedDataCon (TyCon { tyConDetails = details }) + | PromotedDataCon { dataCon = dc } <- details + = not (isTypeDataCon dc) + | otherwise = False + +-- | Is this 'TyCon' really meant for use at the kind level? That is, +-- should it be permitted without @DataKinds@? +isKindTyCon :: TyCon -> Bool +isKindTyCon = isKindUniquable + +-- | This is 'Name' really meant for use at the kind level? That is, +-- should it be permitted wihout @DataKinds@? +isKindName :: Name -> Bool +isKindName = isKindUniquable + +-- | The workhorse for 'isKindTyCon' and 'isKindName'. +isKindUniquable :: Uniquable a => a -> Bool +isKindUniquable thing = getUnique thing `memberUniqueSet` kindTyConKeys + +-- | These TyCons should be allowed at the kind level, even without +-- -XDataKinds. +kindTyConKeys :: UniqueSet +kindTyConKeys = fromListUniqueSet $ + -- Make sure to keep this in sync with the following: + -- + -- - The Overview section in docs/users_guide/exts/data_kinds.rst in the GHC + -- User's Guide. + -- + -- - The typecheck/should_compile/T22141f.hs test case, which ensures that all + -- of these can successfully be used without DataKinds. + [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey, cONSTRAINTTyConKey ] + ++ concatMap tycon_with_datacons [ runtimeRepTyCon, levityTyCon + , multiplicityTyCon + , vecCountTyCon, vecElemTyCon ] + where + tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) + +isLiftedTypeKindTyConName :: Name -> Bool +isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) + +-- | Identifies implicit tycons that, in particular, do not go into interface +-- files (because they are implicitly reconstructed when the interface is +-- read). +-- +-- Note that: +-- +-- * Associated families are implicit, as they are re-constructed from +-- the class declaration in which they reside, and +-- +-- * Family instances are /not/ implicit as they represent the instance body +-- (similar to a @dfun@ does that for a class instance). +-- +-- * Tuples are implicit iff they have a wired-in name +-- (namely: boxed and unboxed tuples are wired-in and implicit, +-- but constraint tuples are not) +isImplicitTyCon :: TyCon -> Bool +isImplicitTyCon (TyCon { tyConName = name, tyConDetails = details }) = go details + where + go (PrimTyCon {}) = True + go (PromotedDataCon {}) = True + go (SynonymTyCon {}) = False + go (TcTyCon {}) = False + go (FamilyTyCon { famTcParent = parent }) = isJust parent + go (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon {} <- rhs = isWiredInName name + | SumTyCon {} <- rhs = True + | otherwise = False + +tyConCType_maybe :: TyCon -> Maybe CType +tyConCType_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { tyConCType = mb_ctype} <- details = mb_ctype + | otherwise = Nothing + +-- | Does this 'TyCon' have a syntactically fixed RuntimeRep when fully applied, +-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete? +-- +-- False is safe. True means we're sure. +-- Does only a quick check, based on the TyCon's category. +-- +-- See Note [Representation-polymorphic TyCons] +tcHasFixedRuntimeRep :: TyCon -> Bool +tcHasFixedRuntimeRep tc@(TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + = case rhs of + AbstractTyCon {} -> False + -- An abstract TyCon might not have a fixed runtime representation. + -- Note that this is an entirely different matter from the concreteness + -- of the 'TyCon', in the sense of 'isConcreteTyCon'. + + DataTyCon { data_fixed_lev = fixed_lev } -> fixed_lev + -- A datatype might not have a fixed levity with UnliftedDatatypes (#20423). + -- NB: the current representation-polymorphism checks require that + -- the representation be fully-known, including levity variables. + -- This might be relaxed in the future (#15532). + + TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort) || + -- (# #) also has fixed rep. + tyConArity tc == 0 + + SumTyCon {} -> False -- only unboxed sums here + + UnaryClassTyCon {} -> True -- Always boxed + + NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep + -- A newtype might not have a fixed runtime representation + -- with UnliftedNewtypes (#17360) + + | SynonymTyCon {} <- details = False -- conservative choice + | FamilyTyCon{} <- details = False + | PrimTyCon{} <- details = True + | TcTyCon{} <- details = False + | PromotedDataCon{} <- details = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc) + +-- | Is this 'TyCon' concrete? +-- More specifically, if 'tys' are all concrete, is (T tys) concrete? +-- (for synonyms this requires us to look at the RHS) +-- Used for representation polymorphism checks. +-- See Note [Concrete types] in GHC.Tc.Utils.Concrete +isConcreteTyCon :: TyCon -> Bool +isConcreteTyCon tc@(TyCon { tyConDetails = details }) + = case details of + AlgTyCon {} -> True -- Includes AbstractTyCon + PrimTyCon {} -> True + PromotedDataCon {} -> True + FamilyTyCon {} -> False + + SynonymTyCon { synIsConcrete = is_conc } -> is_conc + + TcTyCon {} -> pprPanic "isConcreteTyCon" (ppr tc) + -- isConcreteTyCon is only used on "real" tycons + +{- +----------------------------------------------- +-- TcTyCon +----------------------------------------------- +-} + +-- | Is this a TcTyCon? (That is, one only used during type-checking?) +isTcTyCon :: TyCon -> Bool +isTcTyCon (TyCon { tyConDetails = details }) + | TcTyCon {} <- details = True + | otherwise = False + +setTcTyConKind :: TyCon -> Kind -> TyCon +-- Update the Kind of a TcTyCon +-- The new kind is always a zonked version of its previous +-- kind, so we don't need to update any other fields. +-- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType +setTcTyConKind tc kind + = assert (isMonoTcTyCon tc) $ + let tc' = tc { tyConKind = kind + , tyConNullaryTy = mkNakedTyConTy tc' } + -- See Note [Sharing nullary TyConApps] + in tc' + +isMonoTcTyCon :: TyCon -> Bool +isMonoTcTyCon (TyCon { tyConDetails = details }) + | TcTyCon { tctc_is_poly = is_poly } <- details = not is_poly + | otherwise = False + +tcTyConScopedTyVars :: TyCon -> [(Name,TcTyVar)] +tcTyConScopedTyVars tc@(TyCon { tyConDetails = details }) + | TcTyCon { tctc_scoped_tvs = scoped_tvs } <- details = scoped_tvs + | otherwise = pprPanic "tcTyConScopedTyVars" (ppr tc) + +{- +----------------------------------------------- +-- Expand type-constructor applications +----------------------------------------------- +-} + +data ExpandSynResult tyco + = NoExpansion + | ExpandsSyn [(TyVar,tyco)] Type [tyco] + +expandSynTyCon_maybe + :: TyCon + -> [tyco] -- ^ Arguments to 'TyCon' + -> ExpandSynResult tyco -- ^ Returns a 'TyVar' substitution, the body + -- type of the synonym (not yet substituted) + -- and any arguments remaining from the + -- application +-- ^ Expand a type synonym application +-- Return Nothing if the TyCon is not a synonym, +-- or if not enough arguments are supplied +expandSynTyCon_maybe (TyCon { tyConTyVars = tvs, tyConArity = arity + , tyConDetails = details }) tys + | SynonymTyCon { synTcRhs = rhs } <- details + = if arity == 0 + then ExpandsSyn [] rhs tys -- Avoid a bit of work in the case of nullary synonyms + else case tys `listLengthCmp` arity of + GT -> ExpandsSyn (tvs `zip` tys) rhs (drop arity tys) + EQ -> ExpandsSyn (tvs `zip` tys) rhs [] + LT -> NoExpansion + | otherwise + = NoExpansion + +---------------- + +-- | Check if the tycon actually refers to a proper `data` or `newtype` +-- with user defined constructors rather than one from a class or other +-- construction. + +-- NB: This is only used in GHC.Tc.Gen.Export.checkPatSynParent to determine if an +-- exported tycon can have a pattern synonym bundled with it, e.g., +-- module Foo (TyCon(.., PatSyn)) where +isTyConWithSrcDataCons :: TyCon -> Bool +isTyConWithSrcDataCons (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs, algTcFlavour = parent } <- details + , let isSrcParent = isNoParent parent + = case rhs of + DataTyCon {} -> isSrcParent + NewTyCon {} -> isSrcParent + TupleTyCon {} -> isSrcParent + _ -> False + | FamilyTyCon { famTcFlav = DataFamilyTyCon {} } <- details + = True -- #14058 + | otherwise = False + + +-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no +-- constructors could be found +tyConDataCons :: TyCon -> [DataCon] +-- It's convenient for tyConDataCons to return the +-- empty list for type synonyms etc +tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] + +-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' +-- is the sort that can have any constructors (note: this does not include +-- abstract algebraic types) +tyConDataCons_maybe :: TyCon -> Maybe [DataCon] +tyConDataCons_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = rhs} <- details + = case rhs of + DataTyCon { data_cons = cons } -> Just cons + NewTyCon { data_con = con } -> Just [con] + UnaryClassTyCon { data_con = con } -> Just [con] + TupleTyCon { data_con = con } -> Just [con] + SumTyCon { data_cons = cons } -> Just cons + _ -> Nothing +tyConDataCons_maybe _ = Nothing + +-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ +-- type with one alternative, a tuple type or a @newtype@ then that constructor +-- is returned. If the 'TyCon' has more than one constructor, or represents a +-- primitive or function type constructor then @Nothing@ is returned. +tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon +tyConSingleDataCon_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + = case rhs of + DataTyCon { data_cons = [c] } -> Just c + TupleTyCon { data_con = c } -> Just c + NewTyCon { data_con = c } -> Just c + UnaryClassTyCon { data_con = c } -> Just c + _ -> Nothing + | otherwise = Nothing + +-- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'. +tyConSingleDataCon :: TyCon -> DataCon +tyConSingleDataCon tc + = case tyConSingleDataCon_maybe tc of + Just c -> c + Nothing -> pprPanic "tyConDataCon" (ppr tc) + +-- | Determine the number of value constructors a 'TyCon' has. Panics if the +-- 'TyCon' is not algebraic or a tuple +tyConFamilySize :: TyCon -> Int +tyConFamilySize tc@(TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + = case rhs of + DataTyCon { data_cons_size = size } -> size + NewTyCon {} -> 1 + UnaryClassTyCon {} -> 1 + TupleTyCon {} -> 1 + SumTyCon { data_cons_size = size } -> size + _ -> pprPanic "tyConFamilySize 1" (ppr tc) + | otherwise = pprPanic "tyConFamilySize 2" (ppr tc) + +-- | Extract an 'AlgTyConRhs' with information about data constructors from an +-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' +algTyConRhs :: TyCon -> AlgTyConRhs +algTyConRhs tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = rhs} <- details = rhs + | otherwise = pprPanic "algTyConRhs" (ppr tc) + +-- | Extract the bound type variables and type expansion of a type synonym +-- 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConRhs :: TyCon -> ([TyVar], Type) +newTyConRhs tc@(TyCon { tyConTyVars = tvs, tyConDetails = details }) + | AlgTyCon { algTcRhs = NewTyCon { nt_rhs = rhs }} <- details + = (tvs, rhs) + | otherwise + = pprPanic "newTyConRhs" (ppr tc) + +-- | The number of type parameters that need to be passed to a newtype to +-- resolve it. May be less than in the definition if it can be eta-contracted. +newTyConEtadArity :: TyCon -> Int +newTyConEtadArity tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details + = length (fst tvs_rhs) + | otherwise + = pprPanic "newTyConEtadArity" (ppr tc) + +-- | Extract the bound type variables and type expansion of an eta-contracted +-- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConEtadRhs :: TyCon -> ([TyVar], Type) +newTyConEtadRhs tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details = tvs_rhs + | otherwise = pprPanic "newTyConEtadRhs" (ppr tc) + +-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to +-- construct something with the @newtype@s type from its representation type +-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns +-- @Nothing@ +newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +newTyConCo_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { nt_co = co }} <- details = Just co + | otherwise = Nothing + +newTyConCo :: TyCon -> CoAxiom Unbranched +newTyConCo tc = case newTyConCo_maybe tc of + Just co -> co + Nothing -> pprPanic "newTyConCo" (ppr tc) + +newTyConDataCon_maybe :: TyCon -> Maybe DataCon +newTyConDataCon_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { data_con = con }} <- details = Just con + | otherwise = Nothing + +-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context +-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration +-- @data Eq a => T a ...@. See @Note [The stupid context]@ in "GHC.Core.DataCon". +tyConStupidTheta :: TyCon -> [PredType] +tyConStupidTheta tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid + | PrimTyCon {} <- details = [] + | PromotedDataCon {} <- details = [] + | otherwise = pprPanic "tyConStupidTheta" (ppr tc) + +-- | Extract the 'TyVar's bound by a vanilla type synonym +-- and the corresponding (unsubstituted) right hand side. +synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) +synTyConDefn_maybe (TyCon { tyConTyVars = tyvars, tyConDetails = details }) + | SynonymTyCon {synTcRhs = ty} <- details + = Just (tyvars, ty) + | otherwise + = Nothing + +-- | Extract the information pertaining to the right hand side of a type synonym +-- (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe Type +synTyConRhs_maybe (TyCon { tyConDetails = details }) + | SynonymTyCon {synTcRhs = rhs} <- details = Just rhs + | otherwise = Nothing + +-- | Extract the flavour of a type family (with all the extra information that +-- it carries) +famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav +famTyConFlav_maybe (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = flav} <- details = Just flav + | otherwise = Nothing + +isUnaryClassTyCon :: TyCon -> Bool +isUnaryClassTyCon tc@(TyCon { tyConDetails = details }) + | AlgTyCon { algTcFlavour = flav, algTcRhs = UnaryClassTyCon {} } <- details + = assertPpr (case flav of { ClassTyCon {} -> True; _ -> False }) (ppr tc) $ + True + | otherwise + = False + +isUnaryClassTyCon_maybe :: TyCon -> Maybe (Class, DataCon) +isUnaryClassTyCon_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { algTcFlavour = ClassTyCon cls _ + , algTcRhs = UnaryClassTyCon { data_con = dc } } <- details + = Just (cls, dc) + | otherwise + = Nothing + +-- | Is this 'TyCon' that for a class instance? +isClassTyCon :: TyCon -> Bool +isClassTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = ClassTyCon {}} <- details = True + | otherwise = False + +-- | If this 'TyCon' is that for a class instance, return the class it is for. +-- Otherwise returns @Nothing@ +tyConClass_maybe :: TyCon -> Maybe Class +tyConClass_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = Just clas + | otherwise = Nothing + +-- | Return the associated types of the 'TyCon', if any +tyConATs :: TyCon -> [TyCon] +tyConATs (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = classATs clas + | otherwise = [] + +---------------------------------------------------------------------------- +-- | Is this 'TyCon' that for a data family instance? +isFamInstTyCon :: TyCon -> Bool +isFamInstTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon {} } <- details = True + | otherwise = False + +tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) +tyConFamInstSig_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon ax f ts } <- details = Just (f, ts, ax) + | otherwise = Nothing + +-- | If this 'TyCon' is that of a data family instance, return the family in question +-- and the instance types. Otherwise, return @Nothing@ +tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) +tyConFamInst_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon _ f ts } <- details = Just (f, ts) + | otherwise = Nothing + +-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which +-- represents a coercion identifying the representation type with the type +-- instance family. Otherwise, return @Nothing@ +tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +tyConFamilyCoercion_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon ax _ _ } <- details = Just ax + | otherwise = Nothing + +-- | Extract any 'RuntimeRepInfo' from this TyCon +tyConPromDataConInfo :: TyCon -> PromDataConInfo +tyConPromDataConInfo (TyCon { tyConDetails = details }) + | PromotedDataCon { promDcInfo = rri } <- details = rri + | otherwise = NoPromInfo + -- could panic in that second case. But Douglas Adams told me not to. + +{- +Note [Constructor tag allocation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking we need to allocate constructor tags to constructors. +They are allocated based on the position in the data_cons field of TyCon, +with the first constructor getting fIRST_TAG. + +We used to pay linear cost per constructor, with each constructor looking up +its relative index in the constructor list. That was quadratic and prohibitive +for large data types with more than 10k constructors. + +The current strategy is to build a NameEnv with a mapping from constructor's +Name to ConTag and pass it down to buildDataCon for efficient lookup. + +Relevant ticket: #14657 +-} + +mkTyConTagMap :: TyCon -> NameEnv ConTag +mkTyConTagMap tycon = + mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] + -- See Note [Constructor tag allocation] + +{- +************************************************************************ +* * +\subsection[TyCon-instances]{Instance declarations for @TyCon@} +* * +************************************************************************ + +@TyCon@s are compared by comparing their @Unique@s. +-} + +instance Eq TyCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable TyCon where + getUnique tc = tyConUnique tc + +instance Outputable TyCon where + -- At the moment a promoted TyCon has the same Name as its + -- corresponding TyCon, so we add the quote to distinguish it here + ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc + where + pp_tc = getPprStyle $ \sty -> + getPprDebug $ \debug -> + if ((debug || dumpStyle sty) && isTcTyCon tc) + then text "[tc]" + else empty + +tyConFlavour :: TyCon -> TyConFlavour TyCon +tyConFlavour (TyCon { tyConDetails = details }) + | AlgTyCon { algTcFlavour = parent, algTcRhs = rhs } <- details + = case parent of + ClassTyCon {} -> ClassFlavour + _ -> case rhs of + TupleTyCon { tup_sort = sort } + -> TupleFlavour (tupleSortBoxity sort) + SumTyCon {} -> SumFlavour + DataTyCon {} -> DataTypeFlavour + NewTyCon {} -> NewtypeFlavour + UnaryClassTyCon {} -> ClassFlavour + AbstractTyCon {} -> AbstractTypeFlavour + + | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details + = case flav of + DataFamilyTyCon{} -> OpenFamilyFlavour (IAmData DataType) parent + OpenSynFamilyTyCon -> OpenFamilyFlavour IAmType parent + ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour + AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour + BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour + + | SynonymTyCon {} <- details = TypeSynonymFlavour + | PrimTyCon {} <- details = BuiltInTypeFlavour + | PromotedDataCon {} <- details = PromotedDataConFlavour + | TcTyCon { tctc_flavour = flav } <-details = flav + +-- | Can this flavour of 'TyCon' appear unsaturated? +tcFlavourMustBeSaturated :: TyConFlavour tc -> Bool +tcFlavourMustBeSaturated ClassFlavour = False +tcFlavourMustBeSaturated DataTypeFlavour = False +tcFlavourMustBeSaturated NewtypeFlavour = False +tcFlavourMustBeSaturated TupleFlavour{} = False +tcFlavourMustBeSaturated SumFlavour = False +tcFlavourMustBeSaturated AbstractTypeFlavour {} = False +tcFlavourMustBeSaturated BuiltInTypeFlavour = False +tcFlavourMustBeSaturated PromotedDataConFlavour = False +tcFlavourMustBeSaturated (OpenFamilyFlavour td _)= case td of { IAmData {} -> False; IAmType -> True } +tcFlavourMustBeSaturated TypeSynonymFlavour = True +tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True + +-- | Is this flavour of 'TyCon' an open type family or a data family? +tcFlavourIsOpen :: TyConFlavour tc -> Bool +tcFlavourIsOpen OpenFamilyFlavour{} = True +tcFlavourIsOpen ClosedTypeFamilyFlavour = False +tcFlavourIsOpen ClassFlavour = False +tcFlavourIsOpen DataTypeFlavour = False +tcFlavourIsOpen NewtypeFlavour = False +tcFlavourIsOpen TupleFlavour{} = False +tcFlavourIsOpen SumFlavour = False +tcFlavourIsOpen AbstractTypeFlavour {} = False +tcFlavourIsOpen BuiltInTypeFlavour = False +tcFlavourIsOpen PromotedDataConFlavour = False +tcFlavourIsOpen TypeSynonymFlavour = False + +pprPromotionQuote :: TyCon -> SDoc +-- Promoted data constructors already have a tick in their OccName +pprPromotionQuote tc = + getPprStyle $ \sty -> + let + name = getOccName tc + ticked = isDataKindsPromotedDataCon tc && promTick sty (PromotedItemDataCon name) + in + if ticked + then char '\'' + else empty + +instance NamedThing TyCon where + getName = tyConName + +instance Data.Data TyCon where + -- don't traverse? + toConstr _ = abstractConstr "TyCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "TyCon" + +instance Binary Injectivity where + put_ bh NotInjective = putByte bh 0 + put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs + + get bh = do { h <- getByte bh + ; case h of + 0 -> return NotInjective + _ -> do { xs <- get bh + ; return (Injective xs) } } + +instance NFData Injectivity where + rnf NotInjective = () + rnf (Injective xs) = rnf xs + +-- | Returns whether or not this 'TyCon' is definite, or a hole +-- that may be filled in at some later point. See Note [Skolem abstract data] +tyConSkolem :: TyCon -> Bool +tyConSkolem = isHoleName . tyConName + +-- Note [Skolem abstract data] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Skolem abstract data arises from data declarations in an hsig file. +-- +-- The best analogy is to interpret the types declared in signature files as +-- elaborating to universally quantified type variables; e.g., +-- +-- unit p where +-- signature H where +-- data T +-- data S +-- module M where +-- import H +-- f :: (T ~ S) => a -> b +-- f x = x +-- +-- elaborates as (with some fake structural types): +-- +-- p :: forall t s. { f :: forall a b. t ~ s => a -> b } +-- p = { f = \x -> x } -- ill-typed +-- +-- It is clear that inside p, t ~ s is not provable (and +-- if we tried to write a function to cast t to s, that +-- would not work), but if we call p @Int @Int, clearly Int ~ Int +-- is provable. The skolem variables are all distinct from +-- one another, but we can't make assumptions like "f is +-- inaccessible", because the skolem variables will get +-- instantiated eventually! +-- +-- Skolem abstractness can apply to "non-abstract" data as well): +-- +-- unit p where +-- signature H1 where +-- data T = MkT +-- signature H2 where +-- data T = MkT +-- module M where +-- import qualified H1 +-- import qualified H2 +-- f :: (H1.T ~ H2.T) => a -> b +-- f x = x +-- +-- This is why the test is on the original name of the TyCon, +-- not whether it is abstract or not. diff --git a/GHC/Core/TyCon.hs-boot b/GHC/Core/TyCon.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCon.hs-boot @@ -0,0 +1,21 @@ +module GHC.Core.TyCon where + +import GHC.Prelude +import GHC.Types.Unique ( Uniquable ) +import {-# SOURCE #-} GHC.Types.Name +import GHC.Utils.Outputable + +data TyCon + +instance Uniquable TyCon +instance Outputable TyCon + +type TyConRepName = Name + +isNewTyCon :: TyCon -> Bool +isTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon :: TyCon -> Bool + +tyConRepName_maybe :: TyCon -> Maybe TyConRepName +mkPrelTyConRepName :: Name -> TyConRepName +tyConName :: TyCon -> Name diff --git a/GHC/Core/TyCon/Env.hs b/GHC/Core/TyCon/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCon/Env.hs @@ -0,0 +1,145 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[TyConEnv]{@TyConEnv@: tyCon environments} +-} + + +{-# LANGUAGE ScopedTypeVariables #-} + + +module GHC.Core.TyCon.Env ( + -- * TyCon environment (map) + TyConEnv, + + -- ** Manipulating these environments + mkTyConEnv, mkTyConEnvWith, + emptyTyConEnv, isEmptyTyConEnv, + unitTyConEnv, nonDetTyConEnvElts, + extendTyConEnv_C, extendTyConEnv_Acc, extendTyConEnv, + extendTyConEnvList, extendTyConEnvList_C, + filterTyConEnv, anyTyConEnv, + plusTyConEnv, plusTyConEnv_C, plusTyConEnv_CD, plusTyConEnv_CD2, alterTyConEnv, + lookupTyConEnv, lookupTyConEnv_NF, delFromTyConEnv, delListFromTyConEnv, + elemTyConEnv, mapTyConEnv, disjointTyConEnv, + + DTyConEnv, + + emptyDTyConEnv, isEmptyDTyConEnv, + lookupDTyConEnv, + delFromDTyConEnv, filterDTyConEnv, + mapDTyConEnv, mapMaybeDTyConEnv, + adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv, foldDTyConEnv + ) where + +import GHC.Prelude + +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Core.TyCon (TyCon) + +import GHC.Data.Maybe + +{- +************************************************************************ +* * +\subsection{TyCon environment} +* * +************************************************************************ +-} + +-- | TyCon Environment +type TyConEnv a = UniqFM TyCon a -- Domain is TyCon + +emptyTyConEnv :: TyConEnv a +isEmptyTyConEnv :: TyConEnv a -> Bool +mkTyConEnv :: [(TyCon,a)] -> TyConEnv a +mkTyConEnvWith :: (a -> TyCon) -> [a] -> TyConEnv a +nonDetTyConEnvElts :: TyConEnv a -> [a] +alterTyConEnv :: (Maybe a-> Maybe a) -> TyConEnv a -> TyCon -> TyConEnv a +extendTyConEnv_C :: (a->a->a) -> TyConEnv a -> TyCon -> a -> TyConEnv a +extendTyConEnv_Acc :: (a->b->b) -> (a->b) -> TyConEnv b -> TyCon -> a -> TyConEnv b +extendTyConEnv :: TyConEnv a -> TyCon -> a -> TyConEnv a +plusTyConEnv :: TyConEnv a -> TyConEnv a -> TyConEnv a +plusTyConEnv_C :: (a->a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a +plusTyConEnv_CD :: (a->a->a) -> TyConEnv a -> a -> TyConEnv a -> a -> TyConEnv a +plusTyConEnv_CD2 :: (Maybe a->Maybe a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a +extendTyConEnvList :: TyConEnv a -> [(TyCon,a)] -> TyConEnv a +extendTyConEnvList_C :: (a->a->a) -> TyConEnv a -> [(TyCon,a)] -> TyConEnv a +delFromTyConEnv :: TyConEnv a -> TyCon -> TyConEnv a +delListFromTyConEnv :: TyConEnv a -> [TyCon] -> TyConEnv a +elemTyConEnv :: TyCon -> TyConEnv a -> Bool +unitTyConEnv :: TyCon -> a -> TyConEnv a +lookupTyConEnv :: TyConEnv a -> TyCon -> Maybe a +lookupTyConEnv_NF :: TyConEnv a -> TyCon -> a +filterTyConEnv :: (elt -> Bool) -> TyConEnv elt -> TyConEnv elt +anyTyConEnv :: (elt -> Bool) -> TyConEnv elt -> Bool +mapTyConEnv :: (elt1 -> elt2) -> TyConEnv elt1 -> TyConEnv elt2 +disjointTyConEnv :: TyConEnv a -> TyConEnv a -> Bool + +nonDetTyConEnvElts x = nonDetEltsUFM x +emptyTyConEnv = emptyUFM +isEmptyTyConEnv = isNullUFM +unitTyConEnv x y = unitUFM x y +extendTyConEnv x y z = addToUFM x y z +extendTyConEnvList x l = addListToUFM x l +lookupTyConEnv x y = lookupUFM x y +alterTyConEnv = alterUFM +mkTyConEnv l = listToUFM l +mkTyConEnvWith f = mkTyConEnv . map (\a -> (f a, a)) +elemTyConEnv x y = elemUFM x y +plusTyConEnv x y = plusUFM x y +plusTyConEnv_C f x y = plusUFM_C f x y +plusTyConEnv_CD f x d y b = plusUFM_CD f x d y b +plusTyConEnv_CD2 f x y = plusUFM_CD2 f x y +extendTyConEnv_C f x y z = addToUFM_C f x y z +mapTyConEnv f x = mapUFM f x +extendTyConEnv_Acc x y z a b = addToUFM_Acc x y z a b +extendTyConEnvList_C x y z = addListToUFM_C x y z +delFromTyConEnv x y = delFromUFM x y +delListFromTyConEnv x y = delListFromUFM x y +filterTyConEnv x y = filterUFM x y +anyTyConEnv f x = nonDetFoldUFM ((||) . f) False x +disjointTyConEnv x y = disjointUFM x y + +lookupTyConEnv_NF env n = expectJust (lookupTyConEnv env n) + +-- | Deterministic TyCon Environment +-- +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why +-- we need DTyConEnv. +type DTyConEnv a = UniqDFM TyCon a + +emptyDTyConEnv :: DTyConEnv a +emptyDTyConEnv = emptyUDFM + +isEmptyDTyConEnv :: DTyConEnv a -> Bool +isEmptyDTyConEnv = isNullUDFM + +lookupDTyConEnv :: DTyConEnv a -> TyCon -> Maybe a +lookupDTyConEnv = lookupUDFM + +delFromDTyConEnv :: DTyConEnv a -> TyCon -> DTyConEnv a +delFromDTyConEnv = delFromUDFM + +filterDTyConEnv :: (a -> Bool) -> DTyConEnv a -> DTyConEnv a +filterDTyConEnv = filterUDFM + +mapDTyConEnv :: (a -> b) -> DTyConEnv a -> DTyConEnv b +mapDTyConEnv = mapUDFM + +mapMaybeDTyConEnv :: (a -> Maybe b) -> DTyConEnv a -> DTyConEnv b +mapMaybeDTyConEnv = mapMaybeUDFM + +adjustDTyConEnv :: (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a +adjustDTyConEnv = adjustUDFM + +alterDTyConEnv :: (Maybe a -> Maybe a) -> DTyConEnv a -> TyCon -> DTyConEnv a +alterDTyConEnv = alterUDFM + +extendDTyConEnv :: DTyConEnv a -> TyCon -> a -> DTyConEnv a +extendDTyConEnv = addToUDFM + +foldDTyConEnv :: (elt -> a -> a) -> a -> DTyConEnv elt -> a +foldDTyConEnv = foldUDFM diff --git a/GHC/Core/TyCon/RecWalk.hs b/GHC/Core/TyCon/RecWalk.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCon/RecWalk.hs @@ -0,0 +1,101 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Check for recursive type constructors. + +-} + + + +module GHC.Core.TyCon.RecWalk ( + + -- * Recursion breaking + RecTcChecker, initRecTc, defaultRecTcMaxBound, + setRecTcMaxBound, checkRecTc + + ) where + +import GHC.Prelude + +import GHC.Core.TyCon +import GHC.Core.TyCon.Env +import GHC.Utils.Outputable + +{- +************************************************************************ +* * + Walking over recursive TyCons +* * +************************************************************************ + +Note [Expanding newtypes and products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When expanding a type to expose a data-type constructor, we need to be +careful about newtypes, lest we fall into an infinite loop. Here are +the key examples: + + newtype Id x = MkId x + newtype Fix f = MkFix (f (Fix f)) + newtype T = MkT (T -> T) + + Type Expansion + -------------------------- + T T -> T + Fix Maybe Maybe (Fix Maybe) + Id (Id Int) Int + Fix Id NO NO NO + +Notice that + * We can expand T, even though it's recursive. + * We can expand Id (Id Int), even though the Id shows up + twice at the outer level, because Id is non-recursive + +So, when expanding, we keep track of when we've seen a recursive +newtype at outermost level; and bail out if we see it again. + +We sometimes want to do the same for product types, so that the +strictness analyser doesn't unbox infinitely deeply. + +More precisely, we keep a *count* of how many times we've seen it. +This is to account for + data instance T (a,b) = MkT (T a) (T b) +Then (#10482) if we have a type like + T (Int,(Int,(Int,(Int,Int)))) +we can still unbox deeply enough during strictness analysis. +We have to treat T as potentially recursive, but it's still +good to be able to unwrap multiple layers. + +The function that manages all this is checkRecTc. +-} + +data RecTcChecker = RC !Int (TyConEnv Int) + -- The upper bound, and the number of times + -- we have encountered each TyCon + +instance Outputable RecTcChecker where + ppr (RC n env) = text "RC:" <> int n <+> ppr env + +-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'. +initRecTc :: RecTcChecker +initRecTc = RC defaultRecTcMaxBound emptyTyConEnv + +-- | The default upper bound (100) for the number of times a 'RecTcChecker' is +-- allowed to encounter each 'TyCon'. +defaultRecTcMaxBound :: Int +defaultRecTcMaxBound = 100 +-- Should we have a flag for this? + +-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed +-- to encounter each 'TyCon'. +setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker +setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts + +checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker +-- Nothing => Recursion detected +-- Just rec_tcs => Keep going +checkRecTc (RC bound rec_nts) tc + = case lookupTyConEnv rec_nts tc of + Just n | n >= bound -> Nothing + | otherwise -> Just (RC bound (extendTyConEnv rec_nts tc (n+1))) + Nothing -> Just (RC bound (extendTyConEnv rec_nts tc 1)) diff --git a/GHC/Core/TyCon/Set.hs b/GHC/Core/TyCon/Set.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCon/Set.hs @@ -0,0 +1,71 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + + + +module GHC.Core.TyCon.Set ( + -- * TyCons set type + TyConSet, + + -- ** Manipulating these sets + emptyTyConSet, unitTyConSet, mkTyConSet, unionTyConSet, unionTyConSets, + minusTyConSet, elemTyConSet, extendTyConSet, extendTyConSetList, + delFromTyConSet, delListFromTyConSet, isEmptyTyConSet, filterTyConSet, + intersectsTyConSet, disjointTyConSet, intersectTyConSet, + nameSetAny, nameSetAll + ) where + +import GHC.Prelude + +import GHC.Types.Unique.Set +import GHC.Core.TyCon (TyCon) + +type TyConSet = UniqSet TyCon + +emptyTyConSet :: TyConSet +unitTyConSet :: TyCon -> TyConSet +extendTyConSetList :: TyConSet -> [TyCon] -> TyConSet +extendTyConSet :: TyConSet -> TyCon -> TyConSet +mkTyConSet :: [TyCon] -> TyConSet +unionTyConSet :: TyConSet -> TyConSet -> TyConSet +unionTyConSets :: [TyConSet] -> TyConSet +minusTyConSet :: TyConSet -> TyConSet -> TyConSet +elemTyConSet :: TyCon -> TyConSet -> Bool +isEmptyTyConSet :: TyConSet -> Bool +delFromTyConSet :: TyConSet -> TyCon -> TyConSet +delListFromTyConSet :: TyConSet -> [TyCon] -> TyConSet +filterTyConSet :: (TyCon -> Bool) -> TyConSet -> TyConSet +intersectTyConSet :: TyConSet -> TyConSet -> TyConSet +intersectsTyConSet :: TyConSet -> TyConSet -> Bool +-- ^ True if there is a non-empty intersection. +-- @s1 `intersectsTyConSet` s2@ doesn't compute @s2@ if @s1@ is empty +disjointTyConSet :: TyConSet -> TyConSet -> Bool + +isEmptyTyConSet = isEmptyUniqSet +emptyTyConSet = emptyUniqSet +unitTyConSet = unitUniqSet +mkTyConSet = mkUniqSet +extendTyConSetList = addListToUniqSet +extendTyConSet = addOneToUniqSet +unionTyConSet = unionUniqSets +unionTyConSets = unionManyUniqSets +minusTyConSet = minusUniqSet +elemTyConSet = elementOfUniqSet +delFromTyConSet = delOneFromUniqSet +filterTyConSet = filterUniqSet +intersectTyConSet = intersectUniqSets +disjointTyConSet = disjointUniqSets + + +delListFromTyConSet set ns = foldl' delFromTyConSet set ns + +intersectsTyConSet s1 s2 = not (isEmptyTyConSet (s1 `intersectTyConSet` s2)) + +nameSetAny :: (TyCon -> Bool) -> TyConSet -> Bool +nameSetAny = uniqSetAny + +nameSetAll :: (TyCon -> Bool) -> TyConSet -> Bool +nameSetAll = uniqSetAll diff --git a/GHC/Core/Type.hs b/GHC/Core/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Type.hs @@ -0,0 +1,3438 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1998 +-- +-- Type - public interface + +{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf, RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Main functions for manipulating types and type-related things +module GHC.Core.Type ( + -- Note some of this is just re-exports from TyCon.. + + -- * Main data types representing Types + -- $type_classification + + -- $representation_types + Type, ForAllTyFlag(..), FunTyFlag(..), + Specificity(..), + KindOrType, PredType, ThetaType, FRRType, + Var, TyVar, isTyVar, TyCoVar, PiTyBinder, ForAllTyBinder, TyVarBinder, + Mult, Scaled, + KnotTied, RuntimeRepType, + + -- ** Constructing and deconstructing types + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, + getCastedTyVar_maybe, tyVarKind, varType, + + mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTysNoView, + splitAppTy_maybe, splitAppTyNoView_maybe, tcSplitAppTyNoView_maybe, + + mkFunTy, mkVisFunTy, + mkVisFunTyMany, mkVisFunTysMany, + mkScaledFunTys, + mkInvisFunTy, mkInvisFunTys, + tcMkVisFunTy, tcMkScaledFunTys, tcMkInvisFunTy, + splitFunTy, splitFunTy_maybe, splitVisibleFunTy_maybe, + splitFunTys, funResultTy, funArgTy, + funTyConAppTy_maybe, funTyFlagTyCon, + tyConAppFunTy_maybe, tyConAppFunCo_maybe, + mkFunctionType, mkScaledFunctionTys, chooseFunTyFlag, + + mkTyConApp, mkTyConTy, + tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, + tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, + + splitTyConApp_maybe, splitTyConAppNoView_maybe, splitTyConApp, + tcSplitTyConApp, tcSplitTyConApp_maybe, + + mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, + mkSpecForAllTy, mkSpecForAllTys, + mkVisForAllTys, mkTyCoForAllTy, mkTyCoForAllTys, mkTyCoInvForAllTy, + mkInfForAllTy, mkInfForAllTys, + splitForAllTyCoVars, splitForAllTyVars, + splitForAllReqTyBinders, splitForAllInvisTyBinders, + splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe, + splitForAllTyCoVar_maybe, splitForAllTyCoVar, + splitForAllTyVar_maybe, splitForAllCoVar_maybe, + splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders, + getRuntimeArgTys, + mkTyConBindersPreferAnon, + mkPiTy, mkPiTys, + piResultTy, piResultTys, + applyTysX, dropForAlls, + mkFamilyTyConApp, + buildSynTyCon, + + mkNumLitTy, isNumLitTy, + mkStrLitTy, isStrLitTy, + mkCharLitTy, isCharLitTy, + isLitTy, + + getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep, + getLevity, levityType_maybe, + + mkCastTy, mkCoercionTy, splitCastTy_maybe, + + ErrorMsgType, + userTypeError_maybe, deepUserTypeError_maybe, pprUserTypeErrorTy, + + coAxNthLHS, + stripCoercionTy, + + splitInvisPiTys, splitInvisPiTysN, invisibleBndrCount, + filterOutInvisibleTypes, filterOutInferredTypes, + partitionInvisibleTypes, partitionInvisibles, + tyConForAllTyFlags, appTyForAllTyFlags, + + -- ** Analyzing types + TyCoMapper(..), mapTyCo, mapTyCoX, + TyCoFolder(..), foldTyCo, noView, + + -- (Newtypes) + newTyConInstRhs, + + -- ** Binders + mkForAllTyBinder, mkForAllTyBinders, + mkTyVarBinder, mkTyVarBinders, + tyVarSpecToBinders, + isAnonPiTyBinder, + binderVar, binderVars, binderType, binderFlag, binderFlags, + piTyBinderType, namedPiTyBinder_maybe, + anonPiTyBinderType_maybe, + isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isVisiblePiTyBinder, + isInvisiblePiTyBinder, isNamedPiTyBinder, + tyConBindersPiTyBinders, + + -- ** Predicates on types + isTyVarTy, isFunTy, isCoercionTy, + isCoercionTy_maybe, isForAllTy, + isForAllTy_ty, isForAllTy_co, + isForAllTy_invis_ty, + isPiTy, isTauTy, isFamFreeTy, + isAtomicTy, + + isValidJoinPointType, + tyConAppNeedsKindSig, + + -- * Space-saving construction + mkTYPEapp, mkTYPEapp_maybe, + mkCONSTRAINTapp, mkCONSTRAINTapp_maybe, + mkBoxedRepApp_maybe, mkTupleRepApp_maybe, + typeOrConstraintKind, liftedTypeOrConstraintKind, + + -- *** Levity and boxity + sORTKind_maybe, typeTypeOrConstraint, + typeLevity, typeLevity_maybe, tyConIsTYPEorCONSTRAINT, + isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind, + isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe, + isBoxedRuntimeRep, + isLiftedLevity, isUnliftedLevity, + isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType, + kindBoxedRepLevity_maybe, + mightBeLiftedType, mightBeUnliftedType, + definitelyLiftedType, definitelyUnliftedType, + isAlgType, isDataFamilyApp, isSatTyFamApp, + isPrimitiveType, isStrictType, isTerminatingType, + isLevityTy, isLevityVar, + isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, + dropRuntimeRepArgs, + + -- * Multiplicity + + isMultiplicityTy, isMultiplicityVar, + unrestricted, linear, tymult, + mkScaled, irrelevantMult, scaledSet, + pattern OneTy, pattern ManyTy, + isOneTy, isManyTy, + isLinearType, + + -- * Main data types representing Kinds + Kind, + + -- ** Finding the kind of a type + typeKind, typeHasFixedRuntimeRep, + tcIsLiftedTypeKind, + isConstraintKind, isConstraintLikeKind, returnsConstraintKind, + tcIsBoxedTypeKind, isTypeLikeKind, + + -- ** Common Kind + liftedTypeKind, unliftedTypeKind, + + -- * Type free variables + tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoVarsOfType, tyCoVarsOfTypes, + tyCoVarsOfTypeDSet, + coVarsOfType, + coVarsOfTypes, + + anyFreeVarsOfType, anyFreeVarsOfTypes, + noFreeVarsOfType, + expandTypeSynonyms, expandSynTyConApp_maybe, + typeSize, occCheckExpand, + + -- ** Closing over kinds + closeOverKindsDSet, closeOverKindsList, + closeOverKinds, + + -- * Forcing evaluation of types + seqType, seqTypes, + + -- * Other views onto Types + coreView, coreFullView, rewriterView, + + tyConsOfType, + + -- * Main type substitution data types + TvSubstEnv, -- Representation widely visible + IdSubstEnv, + Subst(..), -- Representation visible to a few friends + + -- ** Manipulating type substitutions + emptyTvSubstEnv, emptySubst, mkEmptySubst, + + mkTCvSubst, zipTvSubst, mkTvSubstPrs, + zipTCvSubst, + notElemSubst, + getTvSubstEnv, + zapSubst, substInScopeSet, setInScope, getSubstRangeTyCoFVs, + extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, + extendTCvSubst, extendCvSubst, + extendTvSubst, extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + extendTvSubstWithClone, + extendTCvSubstWithClone, + isInScope, composeTCvSubst, zipTyEnv, zipCoEnv, + isEmptySubst, unionSubst, isEmptyTCvSubst, + + -- ** Performing substitution on types and kinds + substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta, + substTyAddInScope, + substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked, + substThetaUnchecked, substTyWithUnchecked, + substCo, substCoUnchecked, substCoWithUnchecked, + substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, + substVarBndr, substVarBndrs, + substTyCoBndr, substTyVarToTyVar, + cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, + + -- * Kinds + isTYPEorCONSTRAINT, + isConcreteType, + isFixedRuntimeRepKind + ) where + +import GHC.Prelude + +import GHC.Types.Basic + +-- We import the representation and primitive functions from GHC.Core.TyCo.Rep. +-- Many things are reexported, but not the representation! + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.FVs + +-- friends: +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set + +import GHC.Core.TyCon +import GHC.Builtin.Types.Prim + +import {-# SOURCE #-} GHC.Builtin.Types + ( charTy, naturalTy + , typeSymbolKind, liftedTypeKind, unliftedTypeKind + , constraintKind, zeroBitTypeKind + , manyDataConTy, oneDataConTy + , liftedRepTy, unliftedRepTy, zeroBitRepTy ) + +import GHC.Types.Name( Name ) +import GHC.Builtin.Names +import GHC.Core.Coercion.Axiom + +import {-# SOURCE #-} GHC.Core.Coercion + ( mkNomReflCo, mkGReflCo, mkReflCo + , mkTyConAppCo, mkAppCo + , mkForAllCo, mkFunCo2, mkAxiomCo, mkUnivCo + , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo + , mkKindCo, mkSubCo, mkFunCo, funRole + , decomposePiCos, coercionKind + , coercionRKind, coercionType + , isReflexiveCo, seqCo + , topNormaliseNewType_maybe + ) +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar ) + +-- others +import GHC.Utils.Misc +import GHC.Utils.FV +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.FastString + +import GHC.Data.Maybe ( orElse, isJust, firstJust ) +import GHC.List (build) + +-- $type_classification +-- #type_classification# +-- +-- Types are any, but at least one, of: +-- +-- [Boxed] Iff its representation is a pointer to an object on the +-- GC'd heap. Operationally, heap objects can be entered as +-- a means of evaluation. +-- +-- [Lifted] Iff it has bottom as an element: An instance of a +-- lifted type might diverge when evaluated. +-- GHC Haskell's unboxed types are unlifted. +-- An unboxed, but lifted type is not very useful. +-- (Example: A byte-represented type, where evaluating 0xff +-- computes the 12345678th collatz number modulo 0xff.) +-- Only lifted types may be unified with a type variable. +-- +-- [Algebraic] Iff it is a type with one or more constructors, whether +-- declared with @data@ or @newtype@. +-- An algebraic type is one that can be deconstructed +-- with a case expression. There are algebraic types that +-- are not lifted types, like unlifted data types or +-- unboxed tuples. +-- +-- [Data] Iff it is a type declared with @data@, or a boxed tuple. +-- There are also /unlifted/ data types. +-- +-- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. +-- +-- [Unlifted] Anything that isn't lifted is considered unlifted. +-- +-- Currently, all primitive types are unlifted, but that's not necessarily +-- the case: for example, @Int@ could be primitive. +-- +-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed +-- but unlifted (such as @ByteArray#@). The only primitive types that we +-- classify as algebraic are the unboxed tuples. +-- +-- Some examples of type classifications that may make this a bit clearer are: +-- +-- @ +-- Type primitive boxed lifted algebraic +-- ----------------------------------------------------------------------------- +-- Int# Yes No No No +-- ByteArray# Yes Yes No No +-- (\# a, b \#) Yes No No Yes +-- (\# a | b \#) Yes No No Yes +-- ( a, b ) No Yes Yes Yes +-- [a] No Yes Yes Yes +-- @ + +-- $representation_types +-- A /source type/ is a type that is a separate type as far as the type checker is +-- concerned, but which has a more low-level representation as far as Core-to-Core +-- passes and the rest of the back end is concerned. +-- +-- You don't normally have to worry about this, as the utility functions in +-- this module will automatically convert a source into a representation type +-- if they are spotted, to the best of its abilities. If you don't want this +-- to happen, use the equivalent functions from the "TcType" module. + +{- +************************************************************************ +* * + Type representation +* * +************************************************************************ +-} + +rewriterView :: Type -> Maybe Type +-- Unwrap a type synonym only when either: +-- The type synonym is forgetful, or +-- the type synonym mentions a type family in its expansion +-- See Note [Rewriting synonyms] +{-# INLINE rewriterView #-} +rewriterView (TyConApp tc tys) + | isTypeSynonymTyCon tc + , isForgetfulSynTyCon tc || not (isFamFreeTyCon tc) + = expandSynTyConApp_maybe tc tys +rewriterView _other + = Nothing + +coreView :: Type -> Maybe Type +-- ^ This function strips off the /top layer only/ of a type synonym +-- application (if any) its underlying representation type. +-- Returns 'Nothing' if there is nothing to look through. +-- +-- This function does not look through type family applications. +-- +-- By being non-recursive and inlined, this case analysis gets efficiently +-- joined onto the case analysis that the caller is already doing +coreView (TyConApp tc tys) = expandSynTyConApp_maybe tc tys +coreView _ = Nothing +-- See Note [Inlining coreView]. +{-# INLINE coreView #-} + +coreFullView, core_full_view :: Type -> Type +-- ^ Iterates 'coreView' until there is no more to synonym to expand. +-- NB: coreFullView is non-recursive and can be inlined; +-- core_full_view is the recursive one +-- See Note [Inlining coreView]. +coreFullView ty@(TyConApp tc _) + | isTypeSynonymTyCon tc = core_full_view ty +coreFullView ty = ty +{-# INLINE coreFullView #-} + +core_full_view ty + | Just ty' <- coreView ty = core_full_view ty' + | otherwise = ty + +----------------------------------------------- +-- | @expandSynTyConApp_maybe tc tys@ expands the RHS of type synonym @tc@ +-- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a +-- synonym. +expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type +{-# INLINE expandSynTyConApp_maybe #-} +-- This INLINE will inline the call to expandSynTyConApp_maybe in coreView, +-- which will eliminate the allocation Just/Nothing in the result +-- Don't be tempted to make `expand_syn` (which is NOINLINE) return the +-- Just/Nothing, else you'll increase allocation +expandSynTyConApp_maybe tc arg_tys + | Just (tvs, rhs) <- synTyConDefn_maybe tc + , arg_tys `saturates` tyConArity tc + = Just $! (expand_syn tvs rhs arg_tys) + -- Why strict application? Because every client of this function will evaluat + -- that (expand_syn ...) thunk, so it's more efficient not to build a thunk. + -- Mind you, this function is always INLINEd, so the client context is probably + -- enough to avoid thunk construction and so the $! is just belt-and-braces. + | otherwise + = Nothing + +saturates :: [Type] -> Arity -> Bool +saturates _ 0 = True +saturates [] _ = False +saturates (_:tys) n = assert( n >= 0 ) $ saturates tys (n-1) + -- Arities are always positive; the assertion just checks + -- that, to avoid an infinite loop in the bad case + +-- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path +-- into call-sites. +-- +-- Precondition: the call is saturated or over-saturated; +-- i.e. length tvs <= length arg_tys +expand_syn :: [TyVar] -- ^ the variables bound by the synonym + -> Type -- ^ the RHS of the synonym + -> [Type] -- ^ the type arguments the synonym is instantiated at. + -> Type +{-# NOINLINE expand_syn #-} -- We never want to inline this cold-path. + +expand_syn tvs rhs arg_tys + -- No substitution necessary if either tvs or tys is empty + -- This is both more efficient, and steers clear of an infinite + -- loop; see Note [Care using synonyms to compress types] + | null arg_tys = assert (null tvs) rhs + | null tvs = mkAppTys rhs arg_tys + | otherwise = go empty_subst tvs arg_tys + where + empty_subst = mkEmptySubst in_scope + in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ arg_tys + -- The free vars of 'rhs' should all be bound by 'tenv', + -- so we only need the free vars of tys + -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. + + go subst [] tys + | null tys = rhs' -- Exactly Saturated + | otherwise = mkAppTys rhs' tys + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because the function part might well return a + -- partially-applied type constructor; indeed, usually will! + where + rhs' = substTy subst rhs + + go subst (tv:tvs) (ty:tys) = go (extendTvSubst subst tv ty) tvs tys + + go _ (_:_) [] = pprPanic "expand_syn" (ppr tvs $$ ppr rhs $$ ppr arg_tys) + -- Under-saturated, precondition failed + +{- Note [Inlining coreView] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very common to have a function + + f :: Type -> ... + f ty | Just ty' <- coreView ty = f ty' + f (TyVarTy ...) = ... + f ... = ... + +If f is not otherwise recursive, the initial call to coreView +causes f to become recursive, which kills the possibility of +inlining. Instead, for non-recursive functions, we prefer to +use coreFullView, which guarantees to unwrap top-level type +synonyms. It can be inlined and is efficient and non-allocating +in its fast path. For this to really be fast, all calls made +on its fast path must also be inlined, linked back to this Note. +-} + + +{- ********************************************************************* +* * + expandTypeSynonyms +* * +********************************************************************* -} + +expandTypeSynonyms :: Type -> Type +-- ^ Expand out all type synonyms. Actually, it'd suffice to expand out +-- just the ones that discard type variables (e.g. type Funny a = Int) +-- But we don't know which those are currently, so we just expand all. +-- +-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, +-- not in the kinds of any TyCon or TyVar mentioned in the type. +-- +-- Keep this synchronized with 'synonymTyConsOfType' +expandTypeSynonyms ty + = go (mkEmptySubst in_scope) ty + where + in_scope = mkInScopeSet (tyCoVarsOfType ty) + + go subst (TyConApp tc tys) + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc expanded_tys + = let subst' = mkTvSubst in_scope (mkVarEnv tenv) + -- Make a fresh substitution; rhs has nothing to + -- do with anything that has happened so far + -- NB: if you make changes here, be sure to build an + -- /idempotent/ substitution, even in the nested case + -- type T a b = a -> b + -- type S x y = T y x + -- (#11665) + in mkAppTys (go subst' rhs) tys' + | otherwise + = TyConApp tc expanded_tys + where + expanded_tys = (map (go subst) tys) + + go _ (LitTy l) = LitTy l + go subst (TyVarTy tv) = substTyVar subst tv + go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) + go subst ty@(FunTy _ mult arg res) + = ty { ft_mult = go subst mult, ft_arg = go subst arg, ft_res = go subst res } + go subst (ForAllTy (Bndr tv vis) t) + = let (subst', tv') = substVarBndrUsing go subst tv in + ForAllTy (Bndr tv' vis) (go subst' t) + go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) + go subst (CoercionTy co) = mkCoercionTy (go_co subst co) + + go_mco _ MRefl = MRefl + go_mco subst (MCo co) = MCo (go_co subst co) + + go_co subst (Refl ty) + = mkNomReflCo (go subst ty) + go_co subst (GRefl r ty mco) + = mkGReflCo r (go subst ty) (go_mco subst mco) + -- NB: coercions are always expanded upon creation + go_co subst (TyConAppCo r tc args) + = mkTyConAppCo r tc (map (go_co subst) args) + go_co subst (AppCo co arg) + = mkAppCo (go_co subst co) (go_co subst arg) + go_co subst (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = co }) + = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in + mkForAllCo tv' visL visR kind_co' (go_co subst' co) + go_co subst (FunCo r afl afr w co1 co2) + = mkFunCo2 r afl afr (go_co subst w) (go_co subst co1) (go_co subst co2) + go_co subst (CoVarCo cv) + = substCoVar subst cv + go_co subst (AxiomCo ax cs) + = mkAxiomCo ax (map (go_co subst) cs) + go_co subst co@(UnivCo { uco_lty = lty, uco_rty = rty }) + = co { uco_lty = go subst lty, uco_rty = go subst rty } + go_co subst (SymCo co) + = mkSymCo (go_co subst co) + go_co subst (TransCo co1 co2) + = mkTransCo (go_co subst co1) (go_co subst co2) + go_co subst (SelCo n co) + = mkSelCo n (go_co subst co) + go_co subst (LRCo lr co) + = mkLRCo lr (go_co subst co) + go_co subst (InstCo co arg) + = mkInstCo (go_co subst co) (go_co subst arg) + go_co subst (KindCo co) + = mkKindCo (go_co subst co) + go_co subst (SubCo co) + = mkSubCo (go_co subst co) + go_co _ (HoleCo h) + = pprPanic "expandTypeSynonyms hit a hole" (ppr h) + + go_cobndr subst = substForAllCoBndrUsing (go_co subst) subst + +{- Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms wherever possible. Thus + + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in GHC.Tc.Gen.Bind. +-} + +{- ********************************************************************* +* * + Random functions (todo: organise) +* * +********************************************************************* -} + +-- | An INLINE helper for function such as 'kindRep_maybe' below. +-- +-- @isTyConKeyApp_maybe key ty@ returns @Just tys@ iff +-- the type @ty = T tys@, where T's unique = key +-- key must not be `fUNTyConKey`; to test for functions, use `splitFunTy_maybe`. +-- Thanks to this fact, we don't have to pattern match on `FunTy` here. +isTyConKeyApp_maybe :: Unique -> Type -> Maybe [Type] +isTyConKeyApp_maybe key ty + | TyConApp tc args <- coreFullView ty + , tc `hasKey` key + = Just args + | otherwise + = Nothing +{-# INLINE isTyConKeyApp_maybe #-} + +-- | Extract the RuntimeRep classifier of a type from its kind. For example, +-- @kindRep * = LiftedRep@; Panics if this is not possible. +-- Treats * and Constraint as the same +kindRep :: HasDebugCallStack => Kind -> RuntimeRepType +kindRep k = case kindRep_maybe k of + Just r -> r + Nothing -> pprPanic "kindRep" (ppr k) + +-- | Given a kind (TYPE rr) or (CONSTRAINT rr), extract its RuntimeRep classifier rr. +-- For example, @kindRep_maybe * = Just LiftedRep@ +-- Returns 'Nothing' if the kind is not of form (TYPE rr) +kindRep_maybe :: HasDebugCallStack => Kind -> Maybe RuntimeRepType +kindRep_maybe kind + | Just (_, rep) <- sORTKind_maybe kind = Just rep + | otherwise = Nothing + +-- | Returns True if the argument is (lifted) Type or Constraint +-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim +isLiftedTypeKind :: Kind -> Bool +isLiftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isLiftedRuntimeRep rep + Nothing -> False + +-- | Returns True if the kind classifies unlifted types (like 'Int#') and False +-- otherwise. Note that this returns False for representation-polymorphic +-- kinds, which may be specialized to a kind that classifies unlifted types. +isUnliftedTypeKind :: Kind -> Bool +isUnliftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isUnliftedRuntimeRep rep + Nothing -> False + +pickyIsLiftedTypeKind :: Kind -> Bool +-- Checks whether the kind is literally +-- TYPE LiftedRep +-- or TYPE ('BoxedRep 'Lifted) +-- or Type +-- without expanding type synonyms or anything +-- Used only when deciding whether to suppress the ":: *" in +-- (a :: *) when printing kinded type variables +-- See Note [Suppressing * kinds] in GHC.Core.TyCo.Ppr +pickyIsLiftedTypeKind kind + | TyConApp tc [arg] <- kind + , tc `hasKey` tYPETyConKey + , TyConApp rr_tc rr_args <- arg = case rr_args of + [] -> rr_tc `hasKey` liftedRepTyConKey + [rr_arg] + | rr_tc `hasKey` boxedRepDataConKey + , TyConApp lev [] <- rr_arg + , lev `hasKey` liftedDataConKey -> True + _ -> False + | TyConApp tc [] <- kind + , tc `hasKey` liftedTypeKindTyConKey = True + | otherwise = False + +-- | Check whether a kind is of the form `TYPE (BoxedRep Lifted)` +-- or `TYPE (BoxedRep Unlifted)`. +-- +-- Returns: +-- +-- - `Just Lifted` for `TYPE (BoxedRep Lifted)` and `Type`, +-- - `Just Unlifted` for `TYPE (BoxedRep Unlifted)` and `UnliftedType`, +-- - `Nothing` for anything else, e.g. `TYPE IntRep`, `TYPE (BoxedRep l)`, etc. +kindBoxedRepLevity_maybe :: Type -> Maybe Levity +kindBoxedRepLevity_maybe ty + | Just rep <- kindRep_maybe ty + , isBoxedRuntimeRep rep + = runtimeRepLevity_maybe rep + | otherwise + = Nothing + +-- | Check whether a type of kind 'RuntimeRep' is lifted. +-- +-- 'isLiftedRuntimeRep' is: +-- +-- * True of @LiftedRep :: RuntimeRep@ +-- * False of type variables, type family applications, +-- and of other reps such as @IntRep :: RuntimeRep@. +isLiftedRuntimeRep :: RuntimeRepType -> Bool +isLiftedRuntimeRep rep + = runtimeRepLevity_maybe rep == Just Lifted + +-- | Check whether a type of kind 'RuntimeRep' is unlifted. +-- +-- * True of definitely unlifted 'RuntimeRep's such as +-- 'UnliftedRep', 'IntRep', 'FloatRep', ... +-- * False of 'LiftedRep', +-- * False for type variables and type family applications. +isUnliftedRuntimeRep :: RuntimeRepType -> Bool +isUnliftedRuntimeRep rep = + runtimeRepLevity_maybe rep == Just Unlifted + +-- | An INLINE helper for functions such as 'isLiftedLevity' and 'isUnliftedLevity'. +-- +-- Checks whether the type is a nullary 'TyCon' application, +-- for a 'TyCon' with the given 'Unique'. +isNullaryTyConKeyApp :: Unique -> Type -> Bool +isNullaryTyConKeyApp key ty + | Just args <- isTyConKeyApp_maybe key ty + = assert (null args) True + | otherwise + = False +{-# INLINE isNullaryTyConKeyApp #-} + +isLiftedLevity :: Type -> Bool +isLiftedLevity = isNullaryTyConKeyApp liftedDataConKey + +isUnliftedLevity :: Type -> Bool +isUnliftedLevity = isNullaryTyConKeyApp unliftedDataConKey + +-- | Is this the type 'Levity'? +isLevityTy :: Type -> Bool +isLevityTy = isNullaryTyConKeyApp levityTyConKey + +-- | Is this the type 'RuntimeRep'? +isRuntimeRepTy :: Type -> Bool +isRuntimeRepTy = isNullaryTyConKeyApp runtimeRepTyConKey + +-- | Is a tyvar of type 'RuntimeRep'? +isRuntimeRepVar :: TyVar -> Bool +isRuntimeRepVar = isRuntimeRepTy . tyVarKind + +-- | Is a tyvar of type 'Levity'? +isLevityVar :: TyVar -> Bool +isLevityVar = isLevityTy . tyVarKind + +-- | Is this the type 'Multiplicity'? +isMultiplicityTy :: Type -> Bool +isMultiplicityTy = isNullaryTyConKeyApp multiplicityTyConKey + +-- | Is a tyvar of type 'Multiplicity'? +isMultiplicityVar :: TyVar -> Bool +isMultiplicityVar = isMultiplicityTy . tyVarKind + +-------------------------------------------- +-- Splitting RuntimeRep +-------------------------------------------- + +-- | (splitRuntimeRep_maybe rr) takes a Type rr :: RuntimeRep, and +-- returns the (TyCon,[Type]) for the RuntimeRep, if possible, where +-- the TyCon is one of the promoted DataCons of RuntimeRep. +-- Remember: the unique on TyCon that is a a promoted DataCon is the +-- same as the unique on the DataCon +-- See Note [Promoted data constructors] in GHC.Core.TyCon +-- May not be possible if `rr` is a type variable or type +-- family application +splitRuntimeRep_maybe :: RuntimeRepType -> Maybe (TyCon, [Type]) +splitRuntimeRep_maybe rep + | TyConApp rr_tc args <- coreFullView rep + , isPromotedDataCon rr_tc + -- isPromotedDataCon: be careful of type families (F tys) :: RuntimeRep, + = Just (rr_tc, args) + | otherwise + = Nothing + +-- | See 'isBoxedRuntimeRep_maybe'. +isBoxedRuntimeRep :: RuntimeRepType -> Bool +isBoxedRuntimeRep rep = isJust (isBoxedRuntimeRep_maybe rep) + +-- | `isBoxedRuntimeRep_maybe (rep :: RuntimeRep)` returns `Just lev` if `rep` +-- expands to `Boxed lev` and returns `Nothing` otherwise. +-- +-- Types with this runtime rep are represented by pointers on the GC'd heap. +isBoxedRuntimeRep_maybe :: RuntimeRepType -> Maybe LevityType +isBoxedRuntimeRep_maybe rep + | Just (rr_tc, args) <- splitRuntimeRep_maybe rep + , rr_tc `hasKey` boxedRepDataConKey + , [lev] <- args + = Just lev + | otherwise + = Nothing + +-- | Check whether a type (usually of kind 'RuntimeRep') is lifted, unlifted, +-- or unknown. Returns Nothing if the type isn't of kind 'RuntimeRep'. +-- +-- `runtimeRepLevity_maybe rr` returns: +-- +-- * `Just Lifted` if `rr` is `LiftedRep :: RuntimeRep` +-- * `Just Unlifted` if `rr` is definitely unlifted, e.g. `IntRep` +-- * `Nothing` if not known (e.g. it's a type variable or a type family application). +runtimeRepLevity_maybe :: RuntimeRepType -> Maybe Levity +runtimeRepLevity_maybe rep + | Just (rr_tc, args) <- splitRuntimeRep_maybe rep + = -- NB: args might be non-empty e.g. TupleRep [r1, .., rn] + if (rr_tc `hasKey` boxedRepDataConKey) + then case args of + [lev] -> levityType_maybe lev + _ -> Nothing -- Type isn't of kind RuntimeRep + -- The latter case happens via the call to isLiftedRuntimeRep + -- in GHC.Tc.Errors.Ppr.pprMismatchMsg (#22742) + else Just Unlifted + -- Avoid searching all the unlifted RuntimeRep type cons + -- In the RuntimeRep data type, only LiftedRep is lifted + | otherwise + = Nothing + +-------------------------------------------- +-- Splitting Levity +-------------------------------------------- + +-- | `levityType_maybe` takes a Type of kind Levity, and returns its levity +-- May not be possible for a type variable or type family application +levityType_maybe :: LevityType -> Maybe Levity +levityType_maybe lev + | TyConApp lev_tc args <- coreFullView lev + = if | lev_tc `hasKey` liftedDataConKey -> assert( null args) $ Just Lifted + | lev_tc `hasKey` unliftedDataConKey -> assert( null args) $ Just Unlifted + | otherwise -> Nothing + | otherwise + = Nothing + + +{- ********************************************************************* +* * + mapType +* * +************************************************************************ + +These functions do a map-like operation over types, performing some operation +on all variables and binding sites. Primarily used for zonking. + +Note [Efficiency for ForAllCo case of mapTyCoX] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [ForAllCo] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant. +It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches +the left-hand kind of the coercion. This is convenient lots of the time, but +not when mapping a function over a coercion. + +The problem is that tcm_tybinder will affect the TyCoVar's kind and +mapCoercion will affect the Coercion, and we hope that the results will be +the same. Even if they are the same (which should generally happen with +correct algorithms), then there is an efficiency issue. In particular, +this problem seems to make what should be a linear algorithm into a potentially +exponential one. But it's only going to be bad in the case where there's +lots of foralls in the kinds of other foralls. Like this: + + forall a : (forall b : (forall c : ...). ...). ... + +This construction seems unlikely. So we'll do the inefficient, easy way +for now. + +Note [Specialising mappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These INLINE pragmas are indispensable. mapTyCo and mapTyCoX are used +to implement zonking, and it's vital that they get specialised to the TcM +monad and the particular mapper in use. + +Even specialising to the monad alone made a 20% allocation difference +in perf/compiler/T5030. + +See Note [Specialising foldType] in "GHC.Core.TyCo.Rep" for more details of this +idiom. +-} + +-- | This describes how a "map" operation over a type/coercion should behave +data TyCoMapper env m + = TyCoMapper + { tcm_tyvar :: env -> TyVar -> m Type + , tcm_covar :: env -> CoVar -> m Coercion + , tcm_hole :: env -> CoercionHole -> m Coercion + -- ^ What to do with coercion holes. + -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". + + , tcm_tycobinder :: forall r. env -> TyCoVar -> ForAllTyFlag + -> (env -> TyCoVar -> m r) -> m r + -- ^ The returned env is used in the extended scope + + , tcm_tycon :: TyCon -> m TyCon + -- ^ This is used only for TcTyCons + -- a) To zonk TcTyCons + -- b) To turn TcTyCons into TyCons. + -- See Note [Type checking recursive type and class declarations] + -- in "GHC.Tc.TyCl" + } + +{-# INLINE mapTyCo #-} -- See Note [Specialising mappers] +mapTyCo :: Monad m => TyCoMapper () m + -> ( Type -> m Type + , [Type] -> m [Type] + , Coercion -> m Coercion + , [Coercion] -> m [Coercion] ) +mapTyCo mapper + = case mapTyCoX mapper of + (go_ty, go_tys, go_co, go_cos) + -> (go_ty (), go_tys (), go_co (), go_cos ()) + +{-# INLINE mapTyCoX #-} -- See Note [Specialising mappers] +mapTyCoX :: forall m env. Monad m + => TyCoMapper env m + -> ( env -> Type -> m Type + , env -> [Type] -> m [Type] + , env -> Coercion -> m Coercion + , env -> [Coercion] -> m [Coercion] ) +mapTyCoX (TyCoMapper { tcm_tyvar = tyvar + , tcm_tycobinder = tycobinder + , tcm_tycon = tycon + , tcm_covar = covar + , tcm_hole = cohole }) + = (go_ty, go_tys, go_co, go_cos) + where + -- See Note [Use explicit recursion in mapTyCo] + go_tys !_ [] = return [] + go_tys !env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys + + go_ty !env (TyVarTy tv) = tyvar env tv + go_ty !env (AppTy t1 t2) = mkAppTy <$> go_ty env t1 <*> go_ty env t2 + go_ty !_ ty@(LitTy {}) = return ty + go_ty !env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_co env co + go_ty !env (CoercionTy co) = CoercionTy <$> go_co env co + + go_ty !env ty@(FunTy _ w arg res) + = do { w' <- go_ty env w; arg' <- go_ty env arg; res' <- go_ty env res + ; return (ty { ft_mult = w', ft_arg = arg', ft_res = res' }) } + + go_ty !env ty@(TyConApp tc tys) + | isTcTyCon tc + = do { tc' <- tycon tc + ; mkTyConApp tc' <$> go_tys env tys } + + -- Not a TcTyCon + | null tys -- Avoid allocation in this very + = return ty -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConApp tc <$> go_tys env tys + + go_ty !env (ForAllTy (Bndr tv vis) inner) + = do { tycobinder env tv vis $ \env' tv' -> do + ; inner' <- go_ty env' inner + ; return $ ForAllTy (Bndr tv' vis) inner' } + + -- See Note [Use explicit recursion in mapTyCo] + go_cos !_ [] = return [] + go_cos !env (co:cos) = (:) <$> go_co env co <*> go_cos env cos + + go_mco !_ MRefl = return MRefl + go_mco !env (MCo co) = MCo <$> (go_co env co) + + go_co :: env -> Coercion -> m Coercion + go_co !env (Refl ty) = Refl <$> go_ty env ty + go_co !env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco + go_co !env (AppCo c1 c2) = mkAppCo <$> go_co env c1 <*> go_co env c2 + go_co !env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw + <*> go_co env c1 <*> go_co env c2 + go_co !env (CoVarCo cv) = covar env cv + go_co !env (HoleCo hole) = cohole env hole + go_co !env (UnivCo { uco_prov = p, uco_role = r + , uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = mkUnivCo <$> pure p + <*> go_cos env deps + <*> pure r + <*> go_ty env t1 <*> go_ty env t2 + go_co !env (SymCo co) = mkSymCo <$> go_co env co + go_co !env (TransCo c1 c2) = mkTransCo <$> go_co env c1 <*> go_co env c2 + go_co !env (AxiomCo r cos) = mkAxiomCo r <$> go_cos env cos + go_co !env (SelCo i co) = mkSelCo i <$> go_co env co + go_co !env (LRCo lr co) = mkLRCo lr <$> go_co env co + go_co !env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg + go_co !env (KindCo co) = mkKindCo <$> go_co env co + go_co !env (SubCo co) = mkSubCo <$> go_co env co + go_co !env co@(TyConAppCo r tc cos) + | isTcTyCon tc + = do { tc' <- tycon tc + ; mkTyConAppCo r tc' <$> go_cos env cos } + + -- Not a TcTyCon + | null cos -- Avoid allocation in this very + = return co -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConAppCo r tc <$> go_cos env cos + go_co !env (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = co }) + = do { kind_co' <- go_co env kind_co + ; tycobinder env tv visL $ \env' tv' -> do + ; co' <- go_co env' co + ; return $ mkForAllCo tv' visL visR kind_co' co' } + -- See Note [Efficiency for ForAllCo case of mapTyCoX] + + +{- Note [Use explicit recursion in mapTyCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use explicit recursion in `mapTyCo`, rather than calling, say, `strictFoldDVarSet`, +for exactly the same reason as in Note [Use explicit recursion in foldTyCo] in +GHC.Core.TyCo.Rep. We are in a monadic context, and using too-clever higher order +functions makes the strictness analyser produce worse results. + +We could probably use `foldr`, since it is inlined bodily, fairly early; but +I'm doing the simple thing and inlining it by hand. + +See !12037 for performance glitches caused by using `strictFoldDVarSet` (which is +definitely not inlined bodily). +-} + +{- ********************************************************************* +* * + TyVarTy +* * +********************************************************************* -} + +-- | Attempts to obtain the type variable underlying a 'Type', and panics with the +-- given message if this is not a type variable type. See also 'getTyVar_maybe' +getTyVar :: HasDebugCallStack => Type -> TyVar +getTyVar ty = case getTyVar_maybe ty of + Just tv -> tv + Nothing -> pprPanic "getTyVar" (ppr ty) + +-- | Attempts to obtain the type variable underlying a 'Type' +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe = repGetTyVar_maybe . coreFullView + +-- | Attempts to obtain the type variable underlying a 'Type', without +-- any expansion +repGetTyVar_maybe :: Type -> Maybe TyVar +repGetTyVar_maybe (TyVarTy tv) = Just tv +repGetTyVar_maybe _ = Nothing + +isTyVarTy :: Type -> Bool +isTyVarTy ty = isJust (getTyVar_maybe ty) + +-- | If the type is a tyvar, possibly under a cast, returns it, along +-- with the coercion. Thus, the co is :: kind tv ~N kind ty +getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) +getCastedTyVar_maybe ty = case coreFullView ty of + CastTy (TyVarTy tv) co -> Just (tv, co) + TyVarTy tv -> Just (tv, mkReflCo Nominal (tyVarKind tv)) + _ -> Nothing + + +{- ********************************************************************* +* * + AppTy +* * +********************************************************************* -} + +{- We need to be pretty careful with AppTy to make sure we obey the +invariant that a TyConApp is always visibly so. mkAppTy maintains the +invariant: use it. + +Note [Decomposing fat arrow c=>t] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can we unify (a b) with (Eq a => ty)? If we do so, we end up with +a partial application like ((=>) (Eq a)) which doesn't make sense in +source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). +Here's an example (#9858) of how you might do it: + i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep + i p = typeRep p + + j = i (Proxy :: Proxy (Eq Int => Int)) +The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, +but suppose we want that. But then in the call to 'i', we end +up decomposing (Eq Int => Int), and we definitely don't want that. + +We are willing to split (t1 -=> t2) because the argument is still of +kind Type, not Constraint. So the criterion is isVisibleFunArg. + +In Core there is no real reason to avoid such decomposition. But for now I've +put the test in splitAppTyNoView_maybe, which applies throughout, because the +other calls to splitAppTy are in GHC.Core.Unify, which is also used by the +type checker (e.g. when matching type-function equations). +-} + +-- | Applies a type to another, as in e.g. @k a@ +mkAppTy :: Type -> Type -> Type + -- See Note [Respecting definitional equality], invariant (EQ1). +mkAppTy (CastTy fun_ty co) arg_ty + | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] + = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co + +mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) +mkAppTy ty1 ty2 = AppTy ty1 ty2 + -- Note that the TyConApp could be an + -- under-saturated type synonym. GHC allows that; e.g. + -- type Foo k = k a -> k a + -- type Id x = x + -- foo :: Foo Id -> Foo Id + -- + -- Here Id is partially applied in the type sig for Foo, + -- but once the type synonyms are expanded all is well + -- + -- Moreover in GHC.Tc.Types.tcInferTyApps we build up a type + -- (T t1 t2 t3) one argument at a type, thus forming + -- (T t1), (T t1 t2), etc + +mkAppTys :: Type -> [Type] -> Type +mkAppTys ty1 [] = ty1 +mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy + -- Why do this? See (EQ1) of + -- Note [Respecting definitional equality] + -- in GHC.Core.TyCo.Rep + = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers + where + (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys + (args_to_cast, leftovers) = splitAtList arg_cos arg_tys + casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos +mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) +mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 + +------------- +splitAppTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempt to take a type application apart, whether it is a +-- function, type constructor, or plain type application. Note +-- that type family applications are NEVER unsaturated by this! +splitAppTy_maybe = splitAppTyNoView_maybe . coreFullView + +splitAppTy :: Type -> (Type, Type) +-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', +-- and panics if this is not possible +splitAppTy ty = splitAppTy_maybe ty `orElse` pprPanic "splitAppTy" (ppr ty) + +------------- +splitAppTyNoView_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that +-- any coreView stuff is already done +splitAppTyNoView_maybe (AppTy ty1 ty2) + = Just (ty1, ty2) + +splitAppTyNoView_maybe (FunTy af w ty1 ty2) + | Just (tc, tys) <- funTyConAppTy_maybe af w ty1 ty2 + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') + +splitAppTyNoView_maybe (TyConApp tc tys) + | not (tyConMustBeSaturated tc) || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! + +splitAppTyNoView_maybe _other = Nothing + +tcSplitAppTyNoView_maybe :: Type -> Maybe (Type,Type) +-- ^ Just like splitAppTyNoView_maybe, but does not split (c => t) +-- See Note [Decomposing fat arrow c=>t] +tcSplitAppTyNoView_maybe ty + | FunTy { ft_af = af } <- ty + , not (isVisibleFunArg af) -- See Note [Decomposing fat arrow c=>t] + = Nothing + | otherwise + = splitAppTyNoView_maybe ty + +------------- +splitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) +-- ^ Recursively splits a type as far as is possible, leaving a residual +-- type being applied to and the type arguments applied to it. Never fails, +-- even if that means returning an empty list of type applications. +splitAppTys ty = split ty ty [] + where + split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args + split _ (AppTy ty arg) args = split ty ty (arg:args) + split _ (TyConApp tc tc_args) args + = let -- keep type families saturated + n | tyConMustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split _ (FunTy af w ty1 ty2) args + | Just (tc,tys) <- funTyConAppTy_maybe af w ty1 ty2 + = assert (null args ) + (TyConApp tc [], tys) + + split orig_ty _ args = (orig_ty, args) + +-- | Like 'splitAppTys', but doesn't look through type synonyms +splitAppTysNoView :: HasDebugCallStack => Type -> (Type, [Type]) +splitAppTysNoView ty = split ty [] + where + split (AppTy ty arg) args = split ty (arg:args) + split (TyConApp tc tc_args) args + = let n | tyConMustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split (FunTy af w ty1 ty2) args + | Just (tc, tys) <- funTyConAppTy_maybe af w ty1 ty2 + = assert (null args ) + (TyConApp tc [], tys) + + split ty args = (ty, args) + + +{- ********************************************************************* +* * + LitTy +* * +********************************************************************* -} + +mkNumLitTy :: Integer -> Type +mkNumLitTy n = LitTy (NumTyLit n) + +-- | Is this a numeric literal. We also look through type synonyms. +isNumLitTy :: Type -> Maybe Integer +isNumLitTy ty + | LitTy (NumTyLit n) <- coreFullView ty = Just n + | otherwise = Nothing + +mkStrLitTy :: FastString -> Type +mkStrLitTy s = LitTy (StrTyLit s) + +-- | Is this a symbol literal. We also look through type synonyms. +isStrLitTy :: Type -> Maybe FastString +isStrLitTy ty + | LitTy (StrTyLit s) <- coreFullView ty = Just s + | otherwise = Nothing + +mkCharLitTy :: Char -> Type +mkCharLitTy c = LitTy (CharTyLit c) + +-- | Is this a char literal? We also look through type synonyms. +isCharLitTy :: Type -> Maybe Char +isCharLitTy ty + | LitTy (CharTyLit s) <- coreFullView ty = Just s + | otherwise = Nothing + + +-- | Is this a type literal (symbol, numeric, or char)? +isLitTy :: Type -> Maybe TyLit +isLitTy ty + | LitTy l <- coreFullView ty = Just l + | otherwise = Nothing + +-- | A type of kind 'ErrorMessage' (from the 'GHC.TypeError' module). +type ErrorMsgType = Type + +-- | Is this type a custom user error? +-- If so, give us the error message. +userTypeError_maybe :: Type -> Maybe ErrorMsgType +userTypeError_maybe ty + | Just ty' <- coreView ty = userTypeError_maybe ty' +userTypeError_maybe (TyConApp tc (_kind : msg : _)) + | tyConName tc == errorMessageTypeErrorFamName + -- There may be more than 2 arguments, if the type error is + -- used as a type constructor (e.g. at kind `Type -> Type`). + = Just msg +userTypeError_maybe _ + = Nothing + +deepUserTypeError_maybe :: Type -> Maybe ErrorMsgType +-- Look for custom user error, deeply inside the type +deepUserTypeError_maybe ty + | Just ty' <- coreView ty = userTypeError_maybe ty' +deepUserTypeError_maybe (TyConApp tc tys) + | tyConName tc == errorMessageTypeErrorFamName + , _kind : msg : _ <- tys + -- There may be more than 2 arguments, if the type error is + -- used as a type constructor (e.g. at kind `Type -> Type`). + = Just msg + + | tyConMustBeSaturated tc -- Don't go looking for user type errors + -- inside type family arguments (see #20241). + = foldr (firstJust . deepUserTypeError_maybe) Nothing (drop (tyConArity tc) tys) + | otherwise + = foldr (firstJust . deepUserTypeError_maybe) Nothing tys +deepUserTypeError_maybe (ForAllTy _ ty) = deepUserTypeError_maybe ty +deepUserTypeError_maybe (FunTy { ft_arg = arg, ft_res = res }) + = deepUserTypeError_maybe arg `firstJust` deepUserTypeError_maybe res +deepUserTypeError_maybe (AppTy t1 t2) + = deepUserTypeError_maybe t1 `firstJust` deepUserTypeError_maybe t2 +deepUserTypeError_maybe (CastTy ty _) + = deepUserTypeError_maybe ty +deepUserTypeError_maybe _ -- TyVarTy, CoercionTy, LitTy + = Nothing + +-- | Render a type corresponding to a user type error into a SDoc. +pprUserTypeErrorTy :: ErrorMsgType -> SDoc +pprUserTypeErrorTy ty = + case splitTyConApp_maybe ty of + + -- Text "Something" + Just (tc,[txt]) + | tyConName tc == typeErrorTextDataConName + , Just str <- isStrLitTy txt -> ftext str + + -- ShowType t + Just (tc,[_k,t]) + | tyConName tc == typeErrorShowTypeDataConName -> ppr t + + -- t1 :<>: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorAppendDataConName -> + pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 + + -- t1 :$$: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorVAppendDataConName -> + pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 + + -- An unevaluated type function + _ -> ppr ty + +{- ********************************************************************* +* * + FunTy +* * +********************************************************************* -} + +{- Note [Representation of function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Functions (e.g. Int -> Char) can be thought of as being applications +of funTyCon (known in Haskell surface syntax as (->)), (note that +`RuntimeRep' quantifiers are left inferred) + + (->) :: forall {r1 :: RuntimeRep} {r2 :: RuntimeRep} + (a :: TYPE r1) (b :: TYPE r2). + a -> b -> Type + +However, for efficiency's sake we represent saturated applications of (->) +with FunTy. For instance, the type, + + (->) r1 r2 a b + +is equivalent to, + + FunTy (Anon a) b + +Note how the RuntimeReps are implied in the FunTy representation. For this +reason we must be careful when reconstructing the TyConApp representation (see, +for instance, splitTyConApp_maybe). + +In the compiler we maintain the invariant that all saturated applications of +(->) are represented with FunTy. + +See #11714. +-} + +----------------------------------------------- +funTyConAppTy_maybe :: FunTyFlag -> Type -> Type -> Type + -> Maybe (TyCon, [Type]) +-- ^ Given the components of a FunTy +-- figure out the corresponding TyConApp. +funTyConAppTy_maybe af mult arg res + | Just arg_rep <- getRuntimeRep_maybe arg + , Just res_rep <- getRuntimeRep_maybe res + -- If you're changing the lines below, you'll probably want to adapt the + -- `fUNTyCon` case of GHC.Core.Unify.unify_ty correspondingly. + , let args | isFUNArg af = [mult, arg_rep, res_rep, arg, res] + | otherwise = [ arg_rep, res_rep, arg, res] + = Just $ (funTyFlagTyCon af, args) + | otherwise + = Nothing + +tyConAppFunTy_maybe :: HasDebugCallStack => TyCon -> [Type] -> Maybe Type +-- ^ Return Just if this TyConApp should be represented as a FunTy +tyConAppFunTy_maybe tc tys + | Just (af, mult, arg, res) <- ty_con_app_fun_maybe manyDataConTy tc tys + = Just (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) + | otherwise = Nothing + +tyConAppFunCo_maybe :: HasDebugCallStack => Role -> TyCon -> [Coercion] + -> Maybe Coercion +-- ^ Return Just if this TyConAppCo should be represented as a FunCo +tyConAppFunCo_maybe r tc cos + | Just (af, mult, arg, res) <- ty_con_app_fun_maybe mult_refl tc cos + = Just (mkFunCo r af mult arg res) + | otherwise + = Nothing + where + mult_refl = mkReflCo (funRole r SelMult) manyDataConTy + +ty_con_app_fun_maybe :: (HasDebugCallStack, Outputable a) => a -> TyCon -> [a] + -> Maybe (FunTyFlag, a, a, a) +{-# INLINE ty_con_app_fun_maybe #-} +-- Specialise this function for its two call sites +ty_con_app_fun_maybe many_ty_co tc args + | tc_uniq == fUNTyConKey = fUN_case + | tc_uniq == tcArrowTyConKey = non_FUN_case FTF_T_C + | tc_uniq == ctArrowTyConKey = non_FUN_case FTF_C_T + | tc_uniq == ccArrowTyConKey = non_FUN_case FTF_C_C + | otherwise = Nothing + where + tc_uniq = tyConUnique tc + + fUN_case + | (w:_r1:_r2:a1:a2:rest) <- args + = assertPpr (null rest) (ppr tc <+> ppr args) $ + Just (FTF_T_T, w, a1, a2) + | otherwise = Nothing + + non_FUN_case ftf + | (_r1:_r2:a1:a2:rest) <- args + = assertPpr (null rest) (ppr tc <+> ppr args) $ + Just (ftf, many_ty_co, a1, a2) + | otherwise + = Nothing + +mkFunctionType :: HasDebugCallStack => Mult -> Type -> Type -> Type +-- ^ This one works out the FunTyFlag from the argument type +-- See GHC.Types.Var Note [FunTyFlag] +mkFunctionType mult arg_ty res_ty + = FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty + , ft_mult = assertPpr mult_ok (ppr [mult, arg_ty, res_ty]) $ + mult } + where + af = chooseFunTyFlag arg_ty res_ty + mult_ok = isVisibleFunArg af || isManyTy mult + +mkScaledFunctionTys :: [Scaled Type] -> Type -> Type +-- ^ Like mkFunctionType, compute the FunTyFlag from the arguments +mkScaledFunctionTys arg_tys res_ty + = foldr mk res_ty arg_tys + where + mk (Scaled mult arg_ty) res_ty + = mkFunTy (chooseFunTyFlag arg_ty res_ty) + mult arg_ty res_ty + +chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag +-- ^ See GHC.Types.Var Note [FunTyFlag] +chooseFunTyFlag arg_ty res_ty + = mkFunTyFlag (typeTypeOrConstraint arg_ty) (typeTypeOrConstraint res_ty) + +splitFunTy :: Type -> (Mult, Type, Type) +-- ^ Attempts to extract the multiplicity, argument and result types from a type, +-- and panics if that is not possible. See also 'splitFunTy_maybe' +splitFunTy ty = case splitFunTy_maybe ty of + Just (_af, mult, arg, res) -> (mult,arg,res) + Nothing -> pprPanic "splitFunTy" (ppr ty) + +{-# INLINE splitFunTy_maybe #-} +splitFunTy_maybe :: Type -> Maybe (FunTyFlag, Mult, Type, Type) +-- ^ Attempts to extract the multiplicity, argument and result types from a type +splitFunTy_maybe ty + | FunTy af w arg res <- coreFullView ty = Just (af, w, arg, res) + | otherwise = Nothing + +{-# INLINE splitVisibleFunTy_maybe #-} +splitVisibleFunTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Works on visible function types only (t1 -> t2), and +-- returns t1 and t2, but not the multiplicity +splitVisibleFunTy_maybe ty + | FunTy af _ arg res <- coreFullView ty + , isVisibleFunArg af = Just (arg, res) + | otherwise = Nothing + +splitFunTys :: Type -> ([Scaled Type], Type) +splitFunTys ty = split [] ty ty + where + -- common case first + split args _ (FunTy _ w arg res) = split (Scaled w arg : args) res res + split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' + split args orig_ty _ = (reverse args, orig_ty) + +funResultTy :: HasDebugCallStack => Type -> Type +-- ^ Extract the function result type and panic if that is not possible +funResultTy ty + | FunTy { ft_res = res } <- coreFullView ty = res + | otherwise = pprPanic "funResultTy" (ppr ty) + +funArgTy :: HasDebugCallStack => Type -> Type +-- ^ Extract the function argument type and panic if that is not possible +funArgTy ty + | FunTy { ft_arg = arg } <- coreFullView ty = arg + | otherwise = pprPanic "funArgTy" (ppr ty) + +-- ^ Just like 'piResultTys' but for a single argument +-- Try not to iterate 'piResultTy', because it's inefficient to substitute +-- one variable at a time; instead use 'piResultTys" +piResultTy :: HasDebugCallStack => Type -> Type -> Type +piResultTy ty arg = case piResultTy_maybe ty arg of + Just res -> res + Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) + +piResultTy_maybe :: Type -> Type -> Maybe Type +-- We don't need a 'tc' version, because +-- this function behaves the same for Type and Constraint +piResultTy_maybe ty arg = case coreFullView ty of + FunTy { ft_res = res } -> Just res + + ForAllTy (Bndr tv _) res + -> let empty_subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfTypes [arg,res] + in Just (substTy (extendTCvSubst empty_subst tv arg) res) + + _ -> Nothing + +-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) +-- where f :: f_ty +-- 'piResultTys' is interesting because: +-- 1. 'f_ty' may have more for-alls than there are args +-- 2. Less obviously, it may have fewer for-alls +-- For case 2. think of: +-- piResultTys (forall a.a) [forall b.b, Int] +-- This really can happen, but only (I think) in situations involving +-- undefined. For example: +-- undefined :: forall a. a +-- Term: undefined @(forall b. b->b) @Int +-- This term should have type (Int -> Int), but notice that +-- there are more type args than foralls in 'undefined's type. + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint + +-- This is a heavily used function (e.g. from typeKind), +-- so we pay attention to efficiency, especially in the special case +-- where there are no for-alls so we are just dropping arrows from +-- a function type/kind. +piResultTys :: HasDebugCallStack => Type -> [Type] -> Type +piResultTys ty [] = ty +piResultTys ty orig_args@(arg:args) + | FunTy { ft_res = res } <- ty + = piResultTys res args + + | ForAllTy (Bndr tcv _) res <- ty + = -- Both type and coercion variables + go (extendTCvSubst init_subst tcv arg) res args + + | Just ty' <- coreView ty + = piResultTys ty' orig_args + + | otherwise + = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) + where + init_subst = mkEmptySubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) + + go :: Subst -> Type -> [Type] -> Type + go subst ty [] = substTyUnchecked subst ty + + go subst ty all_args@(arg:args) + | FunTy { ft_res = res } <- ty + = go subst res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst subst tv arg) res args + + | Just ty' <- coreView ty + = go subst ty' all_args + + | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] + = go init_subst + (substTy subst ty) + all_args + + | otherwise + = -- We have not run out of arguments, but the function doesn't + -- have the right kind to apply to them; so panic. + -- Without the explicit isEmptyVarEnv test, an ill-kinded type + -- would give an infinite loop, which is very unhelpful + -- c.f. #15473 + pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) + +applyTysX :: HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type +-- applyTysX beta-reduces (/\tvs. body_ty) arg_tys +-- Assumes that (/\tvs. body_ty) is closed +applyTysX tvs body_ty arg_tys + = assertPpr (tvs `leLength` arg_tys) pp_stuff $ + assertPpr (tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs) pp_stuff $ + mkAppTys (substTyWith tvs arg_tys_prefix body_ty) + arg_tys_rest + where + pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] + (arg_tys_prefix, arg_tys_rest) = splitAtList tvs arg_tys + + +{- Note [Care with kind instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + T :: forall k. k +and we are finding the kind of + T (forall b. b -> b) * Int +Then + T (forall b. b->b) :: k[ k :-> forall b. b->b] + :: forall b. b -> b +So + T (forall b. b->b) * :: (b -> b)[ b :-> *] + :: * -> * + +In other words we must instantiate the forall! + +Similarly (#15428) + S :: forall k f. k -> f k +and we are finding the kind of + S * (* ->) Int Bool +We have + S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] + :: * -> * -> * +So again we must instantiate. + +The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. +-} + + +{- ********************************************************************* +* * + TyConApp +* * +********************************************************************* -} + +-- splitTyConApp "looks through" synonyms, because they don't +-- mean a distinct type, but all other type-constructor applications +-- including functions are returned as Just .. + +-- | Retrieve the tycon heading this type, if there is one. Does /not/ +-- look through synonyms. +tyConAppTyConPicky_maybe :: Type -> Maybe TyCon +tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc +tyConAppTyConPicky_maybe (FunTy { ft_af = af }) = Just (funTyFlagTyCon af) +tyConAppTyConPicky_maybe _ = Nothing + + +-- | The same as @fst . splitTyConApp@ +-- We can short-cut the FunTy case +{-# INLINE tyConAppTyCon_maybe #-} +tyConAppTyCon_maybe :: Type -> Maybe TyCon +tyConAppTyCon_maybe ty = case coreFullView ty of + TyConApp tc _ -> Just tc + FunTy { ft_af = af } -> Just (funTyFlagTyCon af) + _ -> Nothing + +tyConAppTyCon :: HasDebugCallStack => Type -> TyCon +tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) + +-- | The same as @snd . splitTyConApp@ +tyConAppArgs_maybe :: Type -> Maybe [Type] +tyConAppArgs_maybe ty = case splitTyConApp_maybe ty of + Just (_, tys) -> Just tys + Nothing -> Nothing + +tyConAppArgs :: HasDebugCallStack => Type -> [Type] +tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor. Panics if that is not possible. +-- See also 'splitTyConApp_maybe' +splitTyConApp :: Type -> (TyCon, [Type]) +splitTyConApp ty = splitTyConApp_maybe ty `orElse` pprPanic "splitTyConApp" (ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +splitTyConApp_maybe ty = splitTyConAppNoView_maybe (coreFullView ty) + +splitTyConAppNoView_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +-- Same as splitTyConApp_maybe but without looking through synonyms +splitTyConAppNoView_maybe ty + = case ty of + FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} + -> funTyConAppTy_maybe af w arg res + TyConApp tc tys -> Just (tc, tys) + _ -> Nothing + +-- | tcSplitTyConApp_maybe splits a type constructor application into +-- its type constructor and applied types. +-- +-- Differs from splitTyConApp_maybe in that it does *not* split types +-- headed with (=>), as that's not a TyCon in the type-checker. +-- +-- Note that this may fail (in funTyConAppTy_maybe) in the case +-- of a 'FunTy' with an argument of unknown kind 'FunTy' +-- (e.g. `FunTy (a :: k) Int`, since the kind of @a@ isn't of +-- the form `TYPE rep`. This isn't usually a problem but may +-- be temporarily the case during canonicalization: +-- see Note [Decomposing FunTy] in GHC.Tc.Solver.Equality +-- and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType, +-- Wrinkle around FunTy +-- +-- Consequently, you may need to zonk your type before +-- using this function. +tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +-- Defined here to avoid module loops between Unify and TcType. +tcSplitTyConApp_maybe ty + = case coreFullView ty of + FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} + | isVisibleFunArg af -- Visible args only + -- See Note [Decomposing fat arrow c=>t] + -> funTyConAppTy_maybe af w arg res + TyConApp tc tys -> Just (tc, tys) + _ -> Nothing + +tcSplitTyConApp :: Type -> (TyCon, [Type]) +tcSplitTyConApp ty + = tcSplitTyConApp_maybe ty `orElse` pprPanic "tcSplitTyConApp" (ppr ty) + +--------------------------- +newTyConInstRhs :: TyCon -> [Type] -> Type +-- ^ Unwrap one 'layer' of newtype on a type constructor and its +-- arguments, using an eta-reduced version of the @newtype@ if possible. +-- This requires tys to have at least @newTyConInstArity tycon@ elements. +newTyConInstRhs tycon tys + = assertPpr (tvs `leLength` tys) (ppr tycon $$ ppr tys $$ ppr tvs) $ + applyTysX tvs rhs tys + where + (tvs, rhs) = newTyConEtadRhs tycon + + +{- ********************************************************************* +* * + CastTy +* * +********************************************************************* -} + +splitCastTy_maybe :: Type -> Maybe (Type, Coercion) +splitCastTy_maybe ty + | CastTy ty' co <- coreFullView ty = Just (ty', co) + | otherwise = Nothing + +-- | Make a 'CastTy'. The Coercion must be nominal. Checks the +-- Coercion for reflexivity, dropping it if it's reflexive. +-- See @Note [Respecting definitional equality]@ in "GHC.Core.TyCo.Rep" +mkCastTy :: Type -> Coercion -> Type +mkCastTy orig_ty co | isReflexiveCo co = orig_ty -- (EQ2) from the Note +-- NB: Do the slow check here. This is important to keep the splitXXX +-- functions working properly. Otherwise, we may end up with something +-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) +-- fails under splitFunTy_maybe. This happened with the cheaper check +-- in test dependent/should_compile/dynamic-paper. +mkCastTy orig_ty co = mk_cast_ty orig_ty co + +-- | Like 'mkCastTy', but avoids checking the coercion for reflexivity, +-- as that can be expensive. +mk_cast_ty :: Type -> Coercion -> Type +mk_cast_ty orig_ty co = go orig_ty + where + go :: Type -> Type + -- See Note [Using coreView in mk_cast_ty] + go ty | Just ty' <- coreView ty = go ty' + + go (CastTy ty co1) + -- (EQ3) from the Note + = mkCastTy ty (co1 `mkTransCo` co) + -- call mkCastTy again for the reflexivity check + + go (ForAllTy (Bndr tv vis) inner_ty) + -- (EQ4) from the Note + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep. + | isTyVar tv + , let fvs = tyCoVarsOfCo co + = -- have to make sure that pushing the co in doesn't capture the bound var! + if tv `elemVarSet` fvs + then let empty_subst = mkEmptySubst (mkInScopeSet fvs) + (subst, tv') = substVarBndr empty_subst tv + in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mk_cast_ty` co) + else ForAllTy (Bndr tv vis) (inner_ty `mk_cast_ty` co) + + go _ = CastTy orig_ty co -- NB: orig_ty: preserve synonyms if possible + +{- +Note [Using coreView in mk_cast_ty] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariants (EQ3) and (EQ4) of Note [Respecting definitional equality] in +GHC.Core.TyCo.Rep must apply regardless of type synonyms. For instance, +consider this example (#19742): + + type EqSameNat = () |> co + useNatEq :: EqSameNat |> sym co + +(Those casts aren't visible in the user-source code, of course; see #19742 for +what the user might write.) + +The type `EqSameNat |> sym co` looks as if it satisfies (EQ3), as it has no +nested casts, but if we expand EqSameNat, we see that it doesn't. +And then Bad Things happen. + +The solution is easy: just use `coreView` when establishing (EQ3) and (EQ4) in +`mk_cast_ty`. +-} + +{- ********************************************************************* +* * + CoercionTy + CoercionTy allows us to inject coercions into types. A CoercionTy + should appear only in the right-hand side of an application. +* * +********************************************************************* -} + +mkCoercionTy :: Coercion -> Type +mkCoercionTy = CoercionTy + +isCoercionTy :: Type -> Bool +isCoercionTy (CoercionTy _) = True +isCoercionTy _ = False + +isCoercionTy_maybe :: Type -> Maybe Coercion +isCoercionTy_maybe (CoercionTy co) = Just co +isCoercionTy_maybe _ = Nothing + +stripCoercionTy :: Type -> Coercion +stripCoercionTy (CoercionTy co) = co +stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) + + +{- ********************************************************************* +* * + ForAllTy +* * +********************************************************************* -} + +tyConBindersPiTyBinders :: [TyConBinder] -> [PiTyBinder] +-- Return the tyConBinders in PiTyBinder form +tyConBindersPiTyBinders = map to_tyb + where + to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) + to_tyb (Bndr tv AnonTCB) = Anon (tymult (varType tv)) FTF_T_T + +-- | Make a dependent forall over a TyCoVar +mkTyCoForAllTy :: TyCoVar -> ForAllTyFlag -> Type -> Type +mkTyCoForAllTy tv vis ty + | isCoVar tv + , not (tv `elemVarSet` tyCoVarsOfType ty) + -- Maintain ForAllTy's invariants + -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep + = mkVisFunTyMany (varType tv) ty + | otherwise + = ForAllTy (mkForAllTyBinder vis tv) ty + +-- | Make a dependent forall over a TyCoVar +mkTyCoForAllTys :: [ForAllTyBinder] -> Type -> Type +mkTyCoForAllTys bndrs ty + = foldr (\(Bndr var vis) -> mkTyCoForAllTy var vis) ty bndrs + +-- | Make a dependent forall over an 'Inferred' variable +mkTyCoInvForAllTy :: TyCoVar -> Type -> Type +mkTyCoInvForAllTy tv ty = mkTyCoForAllTy tv Inferred ty + +-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar +mkInfForAllTy :: TyVar -> Type -> Type +mkInfForAllTy tv ty = assert (isTyVar tv ) + ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Inferred', a common case +mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type +mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs + +-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar +mkInfForAllTys :: [TyVar] -> Type -> Type +mkInfForAllTys tvs ty = foldr mkInfForAllTy ty tvs + +-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', +-- a common case +mkSpecForAllTy :: TyVar -> Type -> Type +mkSpecForAllTy tv ty = assert (isTyVar tv ) + -- covar is always Inferred, so input should be tyvar + ForAllTy (Bndr tv Specified) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Specified', a common case +mkSpecForAllTys :: [TyVar] -> Type -> Type +mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs + +-- | Like mkForAllTys, but assumes all variables are dependent and visible +mkVisForAllTys :: [TyVar] -> Type -> Type +mkVisForAllTys tvs = assert (all isTyVar tvs ) + -- covar is always Inferred, so all inputs should be tyvar + mkForAllTys [ Bndr tv Required | tv <- tvs ] + +-- | Given a list of type-level vars and the free vars of a result kind, +-- makes PiTyBinders, preferring anonymous binders +-- if the variable is, in fact, not dependent. +-- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) +-- We want (k:*) Named, (b:k) Anon, (c:k) Anon +-- +-- All non-coercion binders are /visible/. +mkTyConBindersPreferAnon :: [TyVar] -- ^ binders + -> TyCoVarSet -- ^ free variables of result + -> [TyConBinder] +mkTyConBindersPreferAnon vars inner_tkvs = assert (all isTyVar vars) + fst (go vars) + where + go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars + go [] = ([], inner_tkvs) + go (v:vs) | v `elemVarSet` fvs + = ( Bndr v (NamedTCB Required) : binders + , fvs `delVarSet` v `unionVarSet` kind_vars ) + | otherwise + = ( Bndr v AnonTCB : binders + , fvs `unionVarSet` kind_vars ) + where + (binders, fvs) = go vs + kind_vars = tyCoVarsOfType $ tyVarKind v + +-- | Take a ForAllTy apart, returning the binders and result type +splitForAllForAllTyBinders :: Type -> ([ForAllTyBinder], Type) +splitForAllForAllTyBinders ty = split ty ty [] + where + split _ (ForAllTy b res) bs = split res res (b:bs) + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split orig_ty _ bs = (reverse bs, orig_ty) +{-# INLINE splitForAllForAllTyBinders #-} + +-- | Take a ForAllTy apart, returning the list of tycovars and the result type. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitForAllTyCoVars :: Type -> ([TyCoVar], Type) +splitForAllTyCoVars ty = split ty ty [] + where + split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like 'splitForAllTyCoVars', but split only for tyvars. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitForAllTyVars :: Type -> ([TyVar], Type) +splitForAllTyVars ty = split ty ty [] + where + split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Required' type +-- variable binders. Furthermore, each returned tyvar is annotated with '()'. +splitForAllReqTyBinders :: Type -> ([ReqTyBinder], Type) +splitForAllReqTyBinders ty = split ty ty [] + where + split _ (ForAllTy (Bndr tv Required) ty) tvs = split ty ty (Bndr tv ():tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Invisible' type +-- variable binders. Furthermore, each returned tyvar is annotated with its +-- 'Specificity'. +splitForAllInvisTyBinders :: Type -> ([InvisTyBinder], Type) +splitForAllInvisTyBinders ty = split ty ty [] + where + split _ (ForAllTy (Bndr tv (Invisible spec)) ty) tvs = split ty ty (Bndr tv spec:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Checks whether this is a proper forall (with a named binder) +isForAllTy :: Type -> Bool +isForAllTy ty + | ForAllTy {} <- coreFullView ty = True + | otherwise = False + +-- | Like `isForAllTy`, but returns True only if it is a tyvar binder +isForAllTy_ty :: Type -> Bool +isForAllTy_ty ty + | ForAllTy (Bndr tv _) _ <- coreFullView ty + , isTyVar tv + = True + + | otherwise = False + +-- | Like `isForAllTy`, but returns True only if it is an inferred tyvar binder +isForAllTy_invis_ty :: Type -> Bool +isForAllTy_invis_ty ty + | ForAllTy (Bndr tv (Invisible InferredSpec)) _ <- coreFullView ty + , isTyVar tv + = True + + | otherwise = False + +-- | Like `isForAllTy`, but returns True only if it is a covar binder +isForAllTy_co :: Type -> Bool +isForAllTy_co ty + | ForAllTy (Bndr tv _) _ <- coreFullView ty + , isCoVar tv + = True + + | otherwise = False + +-- | Is this a function or forall? +isPiTy :: Type -> Bool +isPiTy ty = case coreFullView ty of + ForAllTy {} -> True + FunTy {} -> True + _ -> False + +-- | Is this a function? +-- Note: `forall {b}. Show b => b -> IO b` will not be considered a function by this function. +-- It would merely be a forall wrapping a function type. +isFunTy :: Type -> Bool +isFunTy ty + | FunTy {} <- coreFullView ty = True + | otherwise = False + +-- | Take a forall type apart, or panics if that is not possible. +splitForAllTyCoVar :: Type -> (TyCoVar, Type) +splitForAllTyCoVar ty + | Just answer <- splitForAllTyCoVar_maybe ty = answer + | otherwise = pprPanic "splitForAllTyCoVar" (ppr ty) + +-- | Drops all ForAllTys +dropForAlls :: Type -> Type +dropForAlls ty = go ty + where + go (ForAllTy _ res) = go res + go ty | Just ty' <- coreView ty = go ty' + go res = res + +-- | Attempts to take a ForAllTy apart, returning the full ForAllTyBinder +splitForAllForAllTyBinder_maybe :: Type -> Maybe (ForAllTyBinder, Type) +splitForAllForAllTyBinder_maybe ty + | ForAllTy bndr inner_ty <- coreFullView ty = Just (bndr, inner_ty) + | otherwise = Nothing + + +-- | Attempts to take a ForAllTy apart, returning the Var +splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTyCoVar_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty) + | otherwise = Nothing + +-- | Attempts to take a ForAllTy apart, but only if the binder is a TyVar +splitForAllTyVar_maybe :: Type -> Maybe (TyVar, Type) +splitForAllTyVar_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty + , isTyVar tv + = Just (tv, inner_ty) + + | otherwise = Nothing + +-- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a covar binder. +splitForAllCoVar_maybe :: Type -> Maybe (CoVar, Type) +splitForAllCoVar_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty + , isCoVar tv + = Just (tv, inner_ty) + + | otherwise = Nothing + +-- | Attempts to take a forall type apart; works with proper foralls and +-- functions +{-# INLINE splitPiTy_maybe #-} -- callers will immediately deconstruct +splitPiTy_maybe :: Type -> Maybe (PiTyBinder, Type) +splitPiTy_maybe ty = case coreFullView ty of + ForAllTy bndr ty -> Just (Named bndr, ty) + FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} + -> Just (Anon (mkScaled w arg) af, res) + _ -> Nothing + +-- | Takes a forall type apart, or panics +splitPiTy :: Type -> (PiTyBinder, Type) +splitPiTy ty + | Just answer <- splitPiTy_maybe ty = answer + | otherwise = pprPanic "splitPiTy" (ppr ty) + +-- | Split off all PiTyBinders to a type, splitting both proper foralls +-- and functions +splitPiTys :: Type -> ([PiTyBinder], Type) +splitPiTys ty = split ty ty [] + where + split _ (ForAllTy b res) bs = split res res (Named b : bs) + split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) bs + = split res res (Anon (Scaled w arg) af : bs) + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split orig_ty _ bs = (reverse bs, orig_ty) + +collectPiTyBinders :: Type -> [PiTyBinder] +collectPiTyBinders ty = build $ \c n -> + let + split (ForAllTy b res) = Named b `c` split res + split (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + = Anon (Scaled w arg) af `c` split res + split ty | Just ty' <- coreView ty = split ty' + split _ = n + in + split ty +{-# INLINE collectPiTyBinders #-} + +-- | Extracts a list of run-time arguments from a function type, +-- looking through newtypes to the right of arrows. +-- +-- Examples: +-- +-- @ +-- newtype Identity a = I a +-- +-- getRuntimeArgTys (Int -> Bool -> Double) == [(Int, FTF_T_T), (Bool, FTF_T_T)] +-- getRuntimeArgTys (Identity Int -> Bool -> Double) == [(Identity Int, FTF_T_T), (Bool, FTF_T_T)] +-- getRuntimeArgTys (Int -> Identity (Bool -> Identity Double)) == [(Int, FTF_T_T), (Bool, FTF_T_T)] +-- getRuntimeArgTys (forall a. Show a => Identity a -> a -> Int -> Bool) +-- == [(Show a, FTF_C_T), (Identity a, FTF_T_T),(a, FTF_T_T),(Int, FTF_T_T)] +-- @ +-- +-- Note that, in the last case, the returned types might mention an out-of-scope +-- type variable. This function is used only when we really care about the /kinds/ +-- of the returned types, so this is OK. +-- +-- **Warning**: this function can return an infinite list. For example: +-- +-- @ +-- newtype N a = MkN (a -> N a) +-- getRuntimeArgTys (N a) == repeat (a, FTF_T_T) +-- @ +getRuntimeArgTys :: Type -> [(Scaled Type, FunTyFlag)] +getRuntimeArgTys = go + where + go :: Type -> [(Scaled Type, FunTyFlag)] + go (ForAllTy _ res) + = go res + go (FunTy { ft_mult = w, ft_arg = arg, ft_res = res, ft_af = af }) + = (Scaled w arg, af) : go res + go ty + | Just ty' <- coreView ty + = go ty' + | Just (_,ty') <- topNormaliseNewType_maybe ty + = go ty' + | otherwise + = [] + +invisibleBndrCount :: Type -> Int +-- Returns the number of leading invisible forall'd binders in the type +-- Includes invisible predicate arguments; e.g. for +-- e.g. forall {k}. (k ~ *) => k -> k +-- returns 2 not 1 +invisibleBndrCount ty = length (fst (splitInvisPiTys ty)) + +-- | Like 'splitPiTys', but returns only *invisible* binders, including constraints. +-- Stops at the first visible binder. +splitInvisPiTys :: Type -> ([PiTyBinder], Type) +splitInvisPiTys ty = split ty ty [] + where + split _ (ForAllTy b res) bs + | Bndr _ vis <- b + , isInvisibleForAllTyFlag vis = split res res (Named b : bs) + split _ (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) bs + | isInvisibleFunArg af = split res res (Anon (mkScaled mult arg) af : bs) + split orig_ty ty bs + | Just ty' <- coreView ty = split orig_ty ty' bs + split orig_ty _ bs = (reverse bs, orig_ty) + +splitInvisPiTysN :: Int -> Type -> ([PiTyBinder], Type) +-- ^ Same as 'splitInvisPiTys', but stop when +-- - you have found @n@ 'PiTyBinder's, +-- - or you run out of invisible binders +splitInvisPiTysN n ty = split n ty ty [] + where + split n orig_ty ty bs + | n == 0 = (reverse bs, orig_ty) + | Just ty' <- coreView ty = split n orig_ty ty' bs + | ForAllTy b res <- ty + , Bndr _ vis <- b + , isInvisibleForAllTyFlag vis = split (n-1) res res (Named b : bs) + | FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res } <- ty + , isInvisibleFunArg af = split (n-1) res res (Anon (Scaled mult arg) af : bs) + | otherwise = (reverse bs, orig_ty) + +-- | Given a 'TyCon' and a list of argument types, filter out any invisible +-- (i.e., 'Inferred' or 'Specified') arguments. +filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] +filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys + +-- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' +-- arguments. +filterOutInferredTypes :: TyCon -> [Type] -> [Type] +filterOutInferredTypes tc tys = + filterByList (map (/= Inferred) $ tyConForAllTyFlags tc tys) tys + +-- | Given a 'TyCon' and a list of argument types, partition the arguments +-- into: +-- +-- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and +-- +-- 2. 'Required' (i.e., visible) arguments +partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) +partitionInvisibleTypes tc tys = + partitionByList (map isInvisibleForAllTyFlag $ tyConForAllTyFlags tc tys) tys + +-- | Given a list of things paired with their visibilities, partition the +-- things into (invisible things, visible things). +partitionInvisibles :: [(a, ForAllTyFlag)] -> ([a], [a]) +partitionInvisibles = partitionWith pick_invis + where + pick_invis :: (a, ForAllTyFlag) -> Either a a + pick_invis (thing, vis) | isInvisibleForAllTyFlag vis = Left thing + | otherwise = Right thing + +-- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Wrinkle: consider the following scenario: +-- +-- > T :: forall k. k -> k +-- > tyConForAllTyFlags T [forall m. m -> m -> m, S, R, Q] +-- +-- After substituting, we get +-- +-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n +-- +-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, +-- and @Q@ is visible. +tyConForAllTyFlags :: TyCon -> [Type] -> [ForAllTyFlag] +tyConForAllTyFlags tc = fun_kind_arg_flags (tyConKind tc) + +-- | Given a 'Type' and a list of argument types to which the 'Type' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Most of the time, the arguments will be 'Required', but not always. Consider +-- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is +-- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely +-- this sort of higher-rank situation in which 'appTyForAllTyFlags' comes in handy, +-- since @f Type Bool@ would be represented in Core using 'AppTy's. +-- (See also #15792). +appTyForAllTyFlags :: Type -> [Type] -> [ForAllTyFlag] +appTyForAllTyFlags ty = fun_kind_arg_flags (typeKind ty) + +-- | Given a function kind and a list of argument types (where each argument's +-- kind aligns with the corresponding position in the argument kind), determine +-- each argument's visibility ('Inferred', 'Specified', or 'Required'). +fun_kind_arg_flags :: Kind -> [Type] -> [ForAllTyFlag] +fun_kind_arg_flags = go emptySubst + where + go subst ki arg_tys + | Just ki' <- coreView ki = go subst ki' arg_tys + go _ _ [] = [] + go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) + = argf : go subst' res_ki arg_tys + where + subst' = extendTvSubst subst tv arg_ty + go subst (TyVarTy tv) arg_tys + | Just ki <- lookupTyVar subst tv = go subst ki arg_tys + -- This FunTy case is important to handle kinds with nested foralls, such + -- as this kind (inspired by #16518): + -- + -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type + -- + -- Here, we want to get the following ForAllTyFlags: + -- + -- [Inferred, Specified, Required, Required, Specified, Required] + -- forall {k1}. forall k2. k1 -> k2 -> forall k3. k3 -> Type + go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys) + = argf : go subst res_ki arg_tys + where + argf | isVisibleFunArg af = Required + | otherwise = Inferred + go _ _ arg_tys = map (const Required) arg_tys + -- something is ill-kinded. But this can happen + -- when printing errors. Assume everything is Required. + +-- @isTauTy@ tests if a type has no foralls or (=>) +isTauTy :: Type -> Bool +isTauTy ty | Just ty' <- coreView ty = isTauTy ty' +isTauTy (TyVarTy _) = True +isTauTy (LitTy {}) = True +isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b }) + | isInvisibleFunArg af = False -- e.g., Eq a => b + | otherwise = isTauTy w && isTauTy a && isTauTy b -- e.g., a -> b +isTauTy (ForAllTy {}) = False +isTauTy (CastTy ty _) = isTauTy ty +isTauTy (CoercionTy _) = False -- Not sure about this + +isAtomicTy :: Type -> Bool +-- True if the type is just a single token, and can be printed compactly +-- Used when deciding how to lay out type error messages; see the +-- call in GHC.Tc.Errors +isAtomicTy (TyVarTy {}) = True +isAtomicTy (LitTy {}) = True +isAtomicTy (TyConApp _ []) = True + +isAtomicTy ty | isLiftedTypeKind ty = True + -- 'Type' prints compactly as * + -- See GHC.Iface.Type.ppr_kind_type + +isAtomicTy _ = False + +{- +************************************************************************ +* * +\subsection{Type families} +* * +************************************************************************ +-} + +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- ^ Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance tycon is :RTL, so: +-- +-- > mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let tvs = tyConTyVars tc + fam_subst = assertPpr (tvs `equalLength` tys) (ppr tc <+> ppr tys) $ + zipTvSubst tvs tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys + +-- | Get the type on the LHS of a coercion induced by a type/data +-- family instance. +coAxNthLHS :: CoAxiom br -> Int -> Type +coAxNthLHS ax ind = + mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) + +isFamFreeTy :: Type -> Bool +isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' +isFamFreeTy (TyVarTy _) = True +isFamFreeTy (LitTy {}) = True +isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc +isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b +isFamFreeTy (FunTy _ w a b) = isFamFreeTy w && isFamFreeTy a && isFamFreeTy b +isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty +isFamFreeTy (CastTy ty _) = isFamFreeTy ty +isFamFreeTy (CoercionTy _) = False -- Not sure about this + +-- | Check whether a type is a data family type +isDataFamilyApp :: Type -> Bool +isDataFamilyApp ty = case tyConAppTyCon_maybe ty of + Just tc -> isDataFamilyTyCon tc + _ -> False + +isSatTyFamApp :: Type -> Maybe (TyCon, [Type]) +-- Return the argument if we have a saturated type family application +-- Why saturated? See (ATF4) in Note [Apartness and type families] +isSatTyFamApp (TyConApp tc tys) + | isTypeFamilyTyCon tc + && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated + = Just (tc, tys) +isSatTyFamApp _ = Nothing + +buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> KnotTied Type -> TyCon +-- This function is here because here is where we have +-- isFamFree and isTauTy +buildSynTyCon name binders res_kind roles rhs + = mkSynonymTyCon name binders res_kind roles rhs + is_tau is_fam_free is_forgetful is_concrete + where + qtvs = mkVarSet (map binderVar binders) + is_tau = isTauTy rhs + is_fam_free = isFamFreeTy rhs + is_concrete = isConcreteTypeWith qtvs rhs + is_forgetful = not (qtvs `subVarSet` expanded_rhs_tyvars) + + expanded_rhs_tyvars = tyCoVarsOfType (expandTypeSynonyms rhs) + -- See Note [Forgetful type synonyms] in GHC.Core.TyCon + -- To find out if this TyCon is forgetful, expand the synonyms in its RHS + -- and check that all of the binders are free in the expanded type. + -- We really only need to expand the /forgetful/ synonyms on the RHS, + -- but we don't currently have a function to do that. + -- Failing to expand the RHS led to #25094, e.g. + -- type Bucket a b c = Key (a,b,c) + -- type Key x = Any + -- Here Bucket is definitely forgetful! + +{- +************************************************************************ +* * +\subsection{Liftedness} +* * +************************************************************************ +-} + +-- | Tries to compute the 'Levity' of the given type. Returns either +-- a definite 'Levity', or 'Nothing' if we aren't sure (e.g. the +-- type is representation-polymorphic). +-- +-- Panics if the kind does not have the shape @TYPE r@. +typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity +typeLevity_maybe ty = runtimeRepLevity_maybe (getRuntimeRep ty) + +typeLevity :: HasDebugCallStack => Type -> Levity +typeLevity ty = case typeLevity_maybe ty of + Just lev -> lev + Nothing -> pprPanic "typeLevity" (ppr ty) + +-- | Is the given type definitely unlifted? +-- See "Type#type_classification" for what an unlifted type is. +-- +-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for +-- a more approximate predicate that behaves better in the presence of +-- representation polymorphism. +isUnliftedType :: HasDebugCallStack => Type -> Bool + -- isUnliftedType returns True for forall'd unlifted types: + -- x :: forall a. Int# + -- I found bindings like these were getting floated to the top level. +isUnliftedType ty = + case typeLevity_maybe ty of + Just Lifted -> False + Just Unlifted -> True + Nothing -> pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +-- | Returns: +-- +-- * 'False' if the type is /guaranteed/ unlifted or +-- * 'True' if it lifted, OR we aren't sure +-- (e.g. in a representation-polymorphic case) +mightBeLiftedType :: Type -> Bool +mightBeLiftedType = mightBeLifted . typeLevity_maybe + +definitelyLiftedType :: Type -> Bool +definitelyLiftedType = not . mightBeUnliftedType + +-- | Returns: +-- +-- * 'False' if the type is /guaranteed/ lifted or +-- * 'True' if it is unlifted, OR we aren't sure +-- (e.g. in a representation-polymorphic case) +mightBeUnliftedType :: Type -> Bool +mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe + +definitelyUnliftedType :: Type -> Bool +definitelyUnliftedType = not . mightBeLiftedType + +-- | See "Type#type_classification" for what a boxed type is. +-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for +-- a more approximate predicate that behaves better in the presence of +-- representation polymorphism. +isBoxedType :: Type -> Bool +isBoxedType ty = isBoxedRuntimeRep (getRuntimeRep ty) + +-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) +isRuntimeRepKindedTy :: Type -> Bool +isRuntimeRepKindedTy = isRuntimeRepTy . typeKind + +-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. +-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: +-- +-- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep +-- , String, Int# ] == [String, Int#] +-- +dropRuntimeRepArgs :: [Type] -> [Type] +dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = Just LiftedRep@. Returns 'Nothing' if this is not +-- possible. +getRuntimeRep_maybe :: HasDebugCallStack + => Type -> Maybe RuntimeRepType +getRuntimeRep_maybe = kindRep_maybe . typeKind + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. +getRuntimeRep :: HasDebugCallStack => Type -> RuntimeRepType +getRuntimeRep ty + = case getRuntimeRep_maybe ty of + Just r -> r + Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +-- | Extract the 'Levity' of a type. For example, @getLevity_maybe Int = Just Lifted@, +-- @getLevity (Array# Int) = Just Unlifted@, @getLevity Float# = Nothing@. +-- +-- Returns 'Nothing' if this is not possible. Does not look through type family applications. +getLevity_maybe :: HasDebugCallStack => Type -> Maybe Type +getLevity_maybe ty + | Just rep <- getRuntimeRep_maybe ty + -- Directly matching on TyConApp after expanding type synonyms + -- saves allocations compared to `splitTyConApp_maybe`. See #22254. + -- Given that this is a pretty hot function we make use of the fact + -- and use isTyConKeyApp_maybe instead. + , Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep + = Just lev + | otherwise + = Nothing + +-- | Extract the 'Levity' of a type. For example, @getLevity Int = Lifted@, +-- or @getLevity (Array# Int) = Unlifted@. +-- +-- Panics if this is not possible. Does not look through type family applications. +getLevity :: HasDebugCallStack => Type -> Type +getLevity ty + | Just lev <- getLevity_maybe ty + = lev + | otherwise + = pprPanic "getLevity" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +isUnboxedTupleType :: Type -> Bool +isUnboxedTupleType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey + -- NB: Do not use typePrimRep, as that can't tell the difference between + -- unboxed tuples and unboxed sums + + +isUnboxedSumType :: Type -> Bool +isUnboxedSumType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey + +-- | See "Type#type_classification" for what an algebraic type is. +-- Should only be applied to /types/, as opposed to e.g. partially +-- saturated type constructors +isAlgType :: Type -> Bool +isAlgType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) + isAlgTyCon tc + _other -> False + +-- | Computes whether an argument (or let right hand side) should +-- be computed strictly or lazily, based only on its type. +-- Currently, it's just 'isUnliftedType'. +-- Panics on representation-polymorphic types. +isStrictType :: HasDebugCallStack => Type -> Bool +isStrictType = isUnliftedType + +isTerminatingType :: HasDebugCallStack => Type -> Bool +-- ^ True <=> a term of this type cannot be bottom +-- This identifies the types described by +-- Note [NON-BOTTOM-DICTS invariant] in GHC.Core +-- NB: unlifted types are not terminating types! +-- e.g. you can write a term (loop 1)::Int# that diverges. +isTerminatingType ty = case tyConAppTyCon_maybe ty of + Just tc -> isClassTyCon tc && not (isUnaryClassTyCon tc) + -- A non-unary class TyCon is terminating + -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon + _ -> False + +isPrimitiveType :: Type -> Bool +-- ^ Returns true of types that are opaque to Haskell. +isPrimitiveType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) + isPrimTyCon tc + _ -> False + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Determine whether a type could be the type of a join point of given total +-- arity, according to the polymorphism rule. A join point cannot be polymorphic +-- in its return type, since given +-- join j @a @b x y z = e1 in e2, +-- the types of e1 and e2 must be the same, and a and b are not in scope for e2. +-- (See Note [The polymorphism rule of join points] in "GHC.Core".) Returns False +-- also if the type simply doesn't have enough arguments. +-- +-- Note that we need to know how many arguments (type *and* value) the putative +-- join point takes; for instance, if +-- j :: forall a. a -> Int +-- then j could be a binary join point returning an Int, but it could *not* be a +-- unary join point returning a -> Int. +-- +-- TODO: See Note [Excess polymorphism and join points] +isValidJoinPointType :: JoinArity -> Type -> Bool +isValidJoinPointType arity ty + = valid_under emptyVarSet arity ty + where + valid_under tvs arity ty + | arity == 0 + = tvs `disjointVarSet` tyCoVarsOfType ty + | Just (t, ty') <- splitForAllTyCoVar_maybe ty + = valid_under (tvs `extendVarSet` t) (arity-1) ty' + | Just (_, _, _, res_ty) <- splitFunTy_maybe ty + = valid_under tvs (arity-1) res_ty + | otherwise + = False + +{- Note [Excess polymorphism and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In principle, if a function would be a join point except that it fails +the polymorphism rule (see Note [The polymorphism rule of join points] in +GHC.Core), it can still be made a join point with some effort. This is because +all tail calls must return the same type (they return to the same context!), and +thus if the return type depends on an argument, that argument must always be the +same. + +For instance, consider: + + let f :: forall a. a -> Char -> [a] + f @a x c = ... f @a y 'a' ... + in ... f @Int 1 'b' ... f @Int 2 'c' ... + +(where the calls are tail calls). `f` fails the polymorphism rule because its +return type is [a], where [a] is bound. But since the type argument is always +'Int', we can rewrite it as: + + let f' :: Int -> Char -> [Int] + f' x c = ... f' y 'a' ... + in ... f' 1 'b' ... f 2 'c' ... + +and now we can make f' a join point: + + join f' :: Int -> Char -> [Int] + f' x c = ... jump f' y 'a' ... + in ... jump f' 1 'b' ... jump f' 2 'c' ... + +It's not clear that this comes up often, however. TODO: Measure how often and +add this analysis if necessary. See #14620. + + +************************************************************************ +* * +\subsection{Sequencing on types} +* * +************************************************************************ +-} + +seqType :: Type -> () +seqType (LitTy n) = n `seq` () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy _ w t1 t2) = seqType w `seq` seqType t1 `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty +seqType (CastTy ty co) = seqType ty `seq` seqCo co +seqType (CoercionTy co) = seqCo co + +seqTypes :: [Type] -> () +seqTypes [] = () +seqTypes (ty:tys) = seqType ty `seq` seqTypes tys + +{- +************************************************************************ +* * + The kind of a type +* * +************************************************************************ + +Note [Kinding rules for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here are the key kinding rules for types + + torc1 is TYPE or CONSTRAINT + torc2 is TYPE or CONSTRAINT + t1 : torc1 rep1 + t2 : torc2 rep2 + (FUN) ---------------- + t1 -> t2 : torc2 LiftedRep + -- In fact the arrow varies with torc1/torc2 + -- See Note [Function type constructors and FunTy] + -- in GHC.Builtin.Types.Prim + + torc is TYPE or CONSTRAINT + ty : body_torc rep + ki : Type + `a` is a type variable + `a` is not free in rep +(FORALL1) ----------------------- + forall (a::ki). ty : body_torc rep + + torc is TYPE or CONSTRAINT + ty : body_torc rep + `c` is a coercion variable + `c` is not free in rep + `c` is free in ty -- Surprise 1! +(FORALL2) ------------------------- + forall (cv::k1 ~#{N,R} k2). ty : body_torc LiftedRep + -- Surprise 2! + +Note that: +* (FORALL1) rejects (forall (a::Maybe). blah) + +* (FORALL2) Surprise 1: + See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] + +* (FORALL2) Surprise 2: coercion abstractions are not erased, so + this must be LiftedRep, just like (FUN). (FORALL2) is just a + dependent form of (FUN). + + +Note [Phantom type variables in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type K (r :: RuntimeRep) = Type -- Note 'r' is unused + data T r :: K r -- T :: forall r -> K r + foo :: forall r. T r + +The body of the forall in foo's type has kind (K r), and +normally it would make no sense to have + forall r. (ty :: K r) +because the kind of the forall would escape the binding +of 'r'. But in this case it's fine because (K r) expands +to Type, so we explicitly /permit/ the type + forall r. T r + +To accommodate such a type, in typeKind (forall a.ty) we use +occCheckExpand to expand any type synonyms in the kind of 'ty' +to eliminate 'a'. See kinding rule (FORALL) in +Note [Kinding rules for types] + + +See also + * GHC.Core.Type.occCheckExpand + * GHC.Core.Utils.coreAltsType + * GHC.Tc.Validity.checkEscapingKind +all of which grapple with the same problem. + +See #14939. +-} + +----------------------------- +typeKind :: HasDebugCallStack => Type -> Kind +-- No need to expand synonyms +typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +typeKind (LitTy l) = typeLiteralKind l +typeKind (FunTy { ft_af = af }) = liftedTypeOrConstraintKind (funTyFlagResultTypeOrConstraint af) +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (CastTy _ty co) = coercionRKind co +typeKind (CoercionTy co) = coercionType co + +typeKind (AppTy fun arg) + = go fun [arg] + where + -- Accumulate the type arguments, so we can call piResultTys, + -- rather than a succession of calls to piResultTy (which is + -- asymptotically costly as the number of arguments increases) + go (AppTy fun arg) args = go fun (arg:args) + go fun args = piResultTys (typeKind fun) args + +typeKind ty@(ForAllTy {}) + = assertPpr (not (null tcvs)) (ppr ty) $ + -- If tcvs is empty somehow we'll get an infinite loop! + case occCheckExpand tcvs body_kind of + -- We must make sure tvs do not occur in kind, + -- as they would be out of scope! + -- See Note [Phantom type variables in kinds] + Nothing -> pprPanic "typeKind" + (ppr ty $$ ppr tcvs $$ ppr body <+> dcolon <+> ppr body_kind) + + Just k' | all isTyVar tcvs -> k' -- Rule (FORALL1) + | otherwise -> lifted_kind_from_body -- Rule (FORALL2) + where + (tcvs, body) = splitForAllTyCoVars ty -- Important: splits both TyVar and CoVar binders + body_kind = typeKind body + + lifted_kind_from_body -- Implements (FORALL2) + = case sORTKind_maybe body_kind of + Just (torc, _) -> liftedTypeOrConstraintKind torc + Nothing -> pprPanic "typeKind" (ppr body_kind) + + +--------------------------------------------- + +sORTKind_maybe :: Kind -> Maybe (TypeOrConstraint, Type) +-- Sees if the argument is of form (TYPE rep) or (CONSTRAINT rep) +-- and if so returns which, and the runtime rep +-- +-- This is a "hot" function. Do not call splitTyConApp_maybe here, +-- to avoid the faff with FunTy +sORTKind_maybe (TyConApp tc tys) + -- First, short-cuts for Type and Constraint that do no allocation + | tc_uniq == liftedTypeKindTyConKey = assert( null tys ) $ Just (TypeLike, liftedRepTy) + | tc_uniq == constraintKindTyConKey = assert( null tys ) $ Just (ConstraintLike, liftedRepTy) + | tc_uniq == tYPETyConKey = get_rep TypeLike + | tc_uniq == cONSTRAINTTyConKey = get_rep ConstraintLike + | Just ty' <- expandSynTyConApp_maybe tc tys = sORTKind_maybe ty' + where + !tc_uniq = tyConUnique tc + -- This bang on tc_uniq is important. It means that sORTKind_maybe starts + -- by evaluating tc_uniq, and then ends up with a single case with a 4-way branch + + get_rep torc = case tys of + (rep:_reps) -> assert (null _reps) $ Just (torc, rep) + [] -> Nothing + +sORTKind_maybe _ = Nothing + +typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint +-- Precondition: expects a type that classifies values. +-- Returns whether it is TypeLike or ConstraintLike. +-- Equivalent to calling sORTKind_maybe, but faster in the FunTy case +typeTypeOrConstraint ty + = case coreFullView ty of + FunTy { ft_af = af } -> funTyFlagResultTypeOrConstraint af + ty' | Just (torc, _) <- sORTKind_maybe (typeKind ty') + -> torc + | otherwise + -> pprPanic "typeOrConstraint" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +-- | Does this classify a type allowed to have values? Responds True to things +-- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint. +isTYPEorCONSTRAINT :: Kind -> Bool +-- ^ True of a kind `TYPE _` or `CONSTRAINT _` +isTYPEorCONSTRAINT k = isJust (sORTKind_maybe k) + +tyConIsTYPEorCONSTRAINT :: TyCon -> Bool +tyConIsTYPEorCONSTRAINT tc + = tc_uniq == tYPETyConKey || tc_uniq == cONSTRAINTTyConKey + where + !tc_uniq = tyConUnique tc + +isConstraintLikeKind :: Kind -> Bool +-- True of (CONSTRAINT _) +isConstraintLikeKind kind + = case sORTKind_maybe kind of + Just (ConstraintLike, _) -> True + _ -> False + +isConstraintKind :: Kind -> Bool +-- True of (CONSTRAINT LiftedRep) +isConstraintKind kind + = case sORTKind_maybe kind of + Just (ConstraintLike, rep) -> isLiftedRuntimeRep rep + _ -> False + +tcIsLiftedTypeKind :: Kind -> Bool +-- ^ Is this kind equivalent to 'Type' i.e. TYPE LiftedRep? +tcIsLiftedTypeKind kind + | Just (TypeLike, rep) <- sORTKind_maybe kind + = isLiftedRuntimeRep rep + | otherwise + = False + +tcIsBoxedTypeKind :: Kind -> Bool +-- ^ Is this kind equivalent to @TYPE (BoxedRep l)@ for some @l :: Levity@? +tcIsBoxedTypeKind kind + | Just (TypeLike, rep) <- sORTKind_maybe kind + = isBoxedRuntimeRep rep + | otherwise + = False + +-- | Is this kind equivalent to @TYPE r@ (for some unknown r)? +-- +-- This considers 'Constraint' to be distinct from @*@. +isTypeLikeKind :: Kind -> Bool +isTypeLikeKind kind + = case sORTKind_maybe kind of + Just (TypeLike, _) -> True + _ -> False + +returnsConstraintKind :: Kind -> Bool +-- True <=> the Kind ultimately returns a Constraint +-- E.g. * -> Constraint +-- forall k. k -> Constraint +returnsConstraintKind kind + | Just kind' <- coreView kind = returnsConstraintKind kind' +returnsConstraintKind (ForAllTy _ ty) = returnsConstraintKind ty +returnsConstraintKind (FunTy { ft_res = ty }) = returnsConstraintKind ty +returnsConstraintKind kind = isConstraintLikeKind kind + +-------------------------- +typeLiteralKind :: TyLit -> Kind +typeLiteralKind (NumTyLit {}) = naturalTy +typeLiteralKind (StrTyLit {}) = typeSymbolKind +typeLiteralKind (CharTyLit {}) = charTy + +-- | Returns True if a type has a syntactically fixed runtime rep, +-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- +-- This function is equivalent to `isFixedRuntimeRepKind . typeKind` +-- but much faster. +-- +-- __Precondition:__ The type has kind @('TYPE' blah)@ +typeHasFixedRuntimeRep :: HasDebugCallStack => Type -> Bool +typeHasFixedRuntimeRep = go + where + go (TyConApp tc _) + | tcHasFixedRuntimeRep tc = True + go (FunTy {}) = True + go (LitTy {}) = True + go (ForAllTy _ ty) = go ty + go ty = isFixedRuntimeRepKind (typeKind ty) + +-- | Checks that a kind of the form 'Type', 'Constraint' +-- or @'TYPE r@ is concrete. See 'isConcreteType'. +-- +-- __Precondition:__ The type has kind `TYPE blah` or `CONSTRAINT blah` +isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool +isFixedRuntimeRepKind k + = assertPpr (isTYPEorCONSTRAINT k) (ppr k) $ + -- the isLiftedTypeKind check is necessary b/c of Constraint + isConcreteType k + +-- | Tests whether the given type is concrete, i.e. it +-- whether it consists only of concrete type constructors, +-- concrete type variables, and applications. +-- +-- See Note [Concrete types] in GHC.Tc.Utils.Concrete. +isConcreteType :: Type -> Bool +isConcreteType = isConcreteTypeWith emptyVarSet + +-- | Like 'isConcreteType', but allows passing in a set of 'TyVar's that +-- should be considered concrete. +-- +-- See Note [Concrete types] in GHC.Tc.Utils.Concrete. +isConcreteTypeWith :: TyVarSet -> Type -> Bool +-- This version, with a 'TyVarSet' argument, supports 'mkSynonymTyCon', +-- which needs to test the RHS for concreteness, under the assumption that +-- the binders are instantiated to concrete types +isConcreteTypeWith conc_tvs = go + where + go (TyVarTy tv) = isConcreteTyVar tv || tv `elemVarSet` conc_tvs + go (AppTy ty1 ty2) = go ty1 && go ty2 + go (TyConApp tc tys) = go_tc tc tys + go ForAllTy{} = False + go (FunTy _ w t1 t2) = go w + && go (typeKind t1) && go t1 + && go (typeKind t2) && go t2 + go LitTy{} = True + go CastTy{} = False + go CoercionTy{} = False + + go_tc :: TyCon -> [Type] -> Bool + go_tc tc tys + | isForgetfulSynTyCon tc -- E.g. type S a = Int + -- Then (S x) is concrete even if x isn't + , Just ty' <- expandSynTyConApp_maybe tc tys + = go ty' + + -- Apart from forgetful synonyms, isConcreteTyCon + -- is enough; no need to expand. This is good for e.g + -- type LiftedRep = BoxedRep Lifted + | isConcreteTyCon tc + = all go tys + + | otherwise -- E.g. type families + = False + +{- +%************************************************************************ +%* * + Pretty-printing +%* * +%************************************************************************ + +Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type. + +-} + +-- | Does a 'TyCon' (that is applied to some number of arguments) need to be +-- ascribed with an explicit kind signature to resolve ambiguity if rendered as +-- a source-syntax type? +-- (See @Note [When does a tycon application need an explicit kind signature?]@ +-- for a full explanation of what this function checks for.) +tyConAppNeedsKindSig + :: Bool -- ^ Should specified binders count towards injective positions in + -- the kind of the TyCon? (If you're using visible kind + -- applications, then you want True here. + -> TyCon + -> Int -- ^ The number of args the 'TyCon' is applied to. + -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the + -- number of arguments) +tyConAppNeedsKindSig spec_inj_pos tc n_args + | LT <- listLengthCmp tc_binders n_args + = False + | otherwise + = let (dropped_binders, remaining_binders) + = splitAt n_args tc_binders + result_kind = mkTyConKind remaining_binders tc_res_kind + result_vars = tyCoVarsOfType result_kind + dropped_vars = fvVarSet $ + mapUnionFV injective_vars_of_binder dropped_binders + + in not (subVarSet result_vars dropped_vars) + where + tc_binders = tyConBinders tc + tc_res_kind = tyConResKind tc + + -- Returns the variables that would be fixed by knowing a TyConBinder. See + -- Note [When does a tycon application need an explicit kind signature?] + -- for a more detailed explanation of what this function does. + injective_vars_of_binder :: TyConBinder -> FV + injective_vars_of_binder (Bndr tv vis) = + case vis of + AnonTCB -> injectiveVarsOfType False -- conservative choice + (varType tv) + NamedTCB argf | source_of_injectivity argf + -> unitFV tv `unionFV` + injectiveVarsOfType False (varType tv) + _ -> emptyFV + + source_of_injectivity Required = True + source_of_injectivity Specified = spec_inj_pos + source_of_injectivity Inferred = False + +{- +Note [When does a tycon application need an explicit kind signature?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a couple of places in GHC where we convert Core Types into forms that +more closely resemble user-written syntax. These include: + +1. Template Haskell Type reification (see, for instance, GHC.Tc.Gen.Splice.reify_tc_app) +2. Converting Types to LHsTypes (such as in Haddock.Convert in haddock) + +This conversion presents a challenge: how do we ensure that the resulting type +has enough kind information so as not to be ambiguous? To better motivate this +question, consider the following Core type: + + -- Foo :: Type -> Type + type Foo = Proxy Type + +There is nothing ambiguous about the RHS of Foo in Core. But if we were to, +say, reify it into a TH Type, then it's tempting to just drop the invisible +Type argument and simply return `Proxy`. But now we've lost crucial kind +information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` +or `Proxy Int` or something else! We've inadvertently introduced ambiguity. + +Unlike in other situations in GHC, we can't just turn on +-fprint-explicit-kinds, as we need to produce something which has the same +structure as a source-syntax type. Moreover, we can't rely on visible kind +application, since the first kind argument to Proxy is inferred, not specified. +Our solution is to annotate certain tycons with their kinds whenever they +appear in applied form in order to resolve the ambiguity. For instance, we +would reify the RHS of Foo like so: + + type Foo = (Proxy :: Type -> Type) + +We need to devise an algorithm that determines precisely which tycons need +these explicit kind signatures. We certainly don't want to annotate _every_ +tycon with a kind signature, or else we might end up with horribly bloated +types like the following: + + (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) + +We only want to annotate tycons that absolutely require kind signatures in +order to resolve some sort of ambiguity, and nothing more. + +Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type +require a kind signature? It might require it when we need to fill in any of +T's omitted arguments. By "omitted argument", we mean one that is dropped when +reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and +specified arguments (e.g., TH reification in GHC.Tc.Gen.Splice), and sometimes the +omitted arguments are only the inferred ones (e.g., in situations where +specified arguments are reified through visible kind application). +Regardless, the key idea is that _some_ arguments are going to be omitted after +reification, and the only mechanism we have at our disposal for filling them in +is through explicit kind signatures. + +What do we mean by "fill in"? Let's consider this small example: + + T :: forall {k}. Type -> (k -> Type) -> k + +Moreover, we have this application of T: + + T @{j} Int aty + +When we reify this type, we omit the inferred argument @{j}. Is it fixed by the +other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then +we'll generate an equality constraint (kappa -> Type) and, assuming we can +solve it, that will fix `kappa`. (Here, `kappa` is the unification variable +that we instantiate `k` with.) + +Therefore, for any application of a tycon T to some arguments, the Question We +Must Answer is: + +* Given the first n arguments of T, do the kinds of the non-omitted arguments + fill in the omitted arguments? + +(This is still a bit hand-wavy, but we'll refine this question incrementally +as we explain more of the machinery underlying this process.) + +Answering this question is precisely the role that the `injectiveVarsOfType` +and `injective_vars_of_binder` functions exist to serve. If an omitted argument +`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing +`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a +bit.) + +More formally, if +`a` is in `injectiveVarsOfType ty` +and S1(ty) ~ S2(ty), +then S1(a) ~ S2(a), +where S1 and S2 are arbitrary substitutions. + +For example, is `F` is a non-injective type family, then + + injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} + +Now that we know what this function does, here is a second attempt at the +Question We Must Answer: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. Do the injective + variables of these binders fill in the remainder of T's kind? + +Alright, we're getting closer. Next, we need to clarify what the injective +variables of a tycon binder are. This the role that the +`injective_vars_of_binder` function serves. Here is what this function does for +each form of tycon binder: + +* Anonymous binders are injective positions. For example, in the promoted data + constructor '(:): + + '(:) :: forall a. a -> [a] -> [a] + + The second and third tyvar binders (of kinds `a` and `[a]`) are both + anonymous, so if we had '(:) 'True '[], then the kinds of 'True and + '[] would contribute to the kind of '(:) 'True '[]. Therefore, + injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. + (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) +* Named binders: + - Inferred binders are never injective positions. For example, in this data + type: + + data Proxy a + Proxy :: forall {k}. k -> Type + + If we had Proxy 'True, then the kind of 'True would not contribute to the + kind of Proxy 'True. Therefore, + injective_vars_of_binder(forall {k}. ...) = {}. + - Required binders are injective positions. For example, in this data type: + + data Wurble k (a :: k) :: k + Wurble :: forall k -> k -> k + + The first tyvar binder (of kind `forall k`) has required visibility, so if + we had Wurble (Maybe a) Nothing, then the kind of Maybe a would + contribute to the kind of Wurble (Maybe a) Nothing. Hence, + injective_vars_of_binder(forall a -> ...) = {a}. + - Specified binders /might/ be injective positions, depending on how you + approach things. Continuing the '(:) example: + + '(:) :: forall a. a -> [a] -> [a] + + Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind + of '(:) 'True '[], since it's not explicitly instantiated by the user. But + if visible kind application is enabled, then this is possible, since the + user can write '(:) @Bool 'True '[]. (In that case, + injective_vars_of_binder(forall a. ...) = {a}.) + + There are some situations where using visible kind application is appropriate + and others where it is not (e.g., TH + reification), so the `injective_vars_of_binder` function is parameterized by + a Bool which decides if specified binders should be counted towards + injective positions or not. + +Now that we've defined injective_vars_of_binder, we can refine the Question We +Must Answer once more: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the remainder of T's kind? + +If the answer to this question is "no", then (T ty_1 ... ty_n) needs an +explicit kind signature, since T's kind has kind variables leftover that +aren't fixed by the non-omitted arguments. + +One last sticking point: what does "the remainder of T's kind" mean? You might +be tempted to think that it corresponds to all of the arguments in the kind of +T that would normally be instantiated by omitted arguments. But this isn't +quite right, strictly speaking. Consider the following (silly) example: + + S :: forall {k}. Type -> Type + +And suppose we have this application of S: + + S Int Bool + +The Int argument would be omitted, and +injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which +might suggest that (S Bool) needs an explicit kind signature. But +(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature +only affects the /result/ of the application, not all of the individual +arguments. So adding a kind signature here won't make a difference. Therefore, +the fourth (and final) iteration of the Question We Must Answer is: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the kind of (T ty_1 ... ty_n)? + +Phew, that was a lot of work! + +How can be sure that this is correct? That is, how can we be sure that in the +event that we leave off a kind annotation, that one could infer the kind of the +tycon application from its arguments? It's essentially a proof by induction: if +we can infer the kinds of every subtree of a type, then the whole tycon +application will have an inferrable kind--unless, of course, the remainder of +the tycon application's kind has uninstantiated kind variables. + +What happens if T is oversaturated? That is, if T's kind has fewer than n +arguments, in the case that the concrete application instantiates a result +kind variable with an arrow kind? If we run out of arguments, we do not attach +a kind annotation. This should be a rare case, indeed. Here is an example: + + data T1 :: k1 -> k2 -> * + data T2 :: k1 -> k2 -> * + + type family G (a :: k) :: k + type instance G T1 = T2 + + type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above + +Here G's kind is (forall k. k -> k), and the desugared RHS of that last +instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to +the algorithm above, there are 3 arguments to G so we should peel off 3 +arguments in G's kind. But G's kind has only two arguments. This is the +rare special case, and we choose not to annotate the application of G with +a kind signature. After all, we needn't do this, since that instance would +be reified as: + + type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool + +So the kind of G isn't ambiguous anymore due to the explicit kind annotation +on its argument. See #8953 and test th/T8953. +-} + +{- +************************************************************************ +* * + Multiplicities +* * +************************************************************************ + +These functions would prefer to be in GHC.Core.Multiplicity, but +they some are used elsewhere in this module, and wanted to bring +their friends here with them. +-} + +unrestricted, linear, tymult :: a -> Scaled a + +-- | Scale a payload by Many +unrestricted = Scaled ManyTy + +-- | Scale a payload by One +linear = Scaled OneTy + +-- | Scale a payload by Many; used for type arguments in core +tymult = Scaled ManyTy + +irrelevantMult :: Scaled a -> a +irrelevantMult = scaledThing + +mkScaled :: Mult -> a -> Scaled a +mkScaled = Scaled + +scaledSet :: Scaled a -> b -> Scaled b +scaledSet (Scaled m _) b = Scaled m b + +pattern OneTy :: Mult +pattern OneTy <- (isOneTy -> True) + where OneTy = oneDataConTy + +pattern ManyTy :: Mult +pattern ManyTy <- (isManyTy -> True) + where ManyTy = manyDataConTy + +isManyTy :: Mult -> Bool +isManyTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` manyDataConKey +isManyTy _ = False + +isOneTy :: Mult -> Bool +isOneTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` oneDataConKey +isOneTy _ = False + +isLinearType :: Type -> Bool +-- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function +-- where at least one argument is linear (or otherwise non-unrestricted). We use +-- this function to check whether it is safe to eta reduce an Id in CorePrep. It +-- is always safe to return 'True', because 'True' deactivates the optimisation. +isLinearType ty = case ty of + FunTy _ ManyTy _ res -> isLinearType res + FunTy _ _ _ _ -> True + ForAllTy _ res -> isLinearType res + _ -> False + +{- ********************************************************************* +* * + Space-saving construction +* * +********************************************************************* -} + +{- Note [Using synonyms to compress types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Was: [Prefer Type over TYPE (BoxedRep Lifted)] + +The Core of nearly any program will have numerous occurrences of the Types + + TyConApp BoxedRep [TyConApp Lifted []] -- Synonym LiftedRep + TyConApp BoxedRep [TyConApp Unlifted []] -- Synonym UnliftedREp + TyConApp TYPE [TyConApp LiftedRep []] -- Synonym Type + TyConApp TYPE [TyConApp UnliftedRep []] -- Synonym UnliftedType + +While investigating #17292 we found that these constituted a majority +of all TyConApp constructors on the heap: + + (From a sample of 100000 TyConApp closures) + 0x45f3523 - 28732 - `Type` + 0x420b840702 - 9629 - generic type constructors + 0x42055b7e46 - 9596 + 0x420559b582 - 9511 + 0x420bb15a1e - 9509 + 0x420b86c6ba - 9501 + 0x42055bac1e - 9496 + 0x45e68fd - 538 - `TYPE ...` + +Consequently, we try hard to ensure that operations on such types are +efficient. Specifically, we strive to + + a. Avoid heap allocation of such types; use a single static TyConApp + b. Use a small (shallow in the tree-depth sense) representation + for such types + +Goal (b) is particularly useful as it makes traversals (e.g. free variable +traversal, substitution, and comparison) more efficient. +Comparison in particular takes special advantage of nullary type synonym +applications (e.g. things like @TyConApp typeTyCon []@). See +* Note [Comparing type synonyms] in "GHC.Core.TyCo.Compare" +* Note [Unifying type synonyms] in "GHC.Core.Unify" + +To accomplish these we use a number of tricks, implemented by mkTyConApp. + + 1. Instead of (TyConApp BoxedRep [TyConApp Lifted []]), + we prefer a statically-allocated (TyConApp LiftedRep []) + where `LiftedRep` is a type synonym: + type LiftedRep = BoxedRep Lifted + Similarly for UnliftedRep + + 2. Instead of (TyConApp TYPE [TyConApp LiftedRep []]) + we prefer the statically-allocated (TyConApp Type []) + where `Type` is a type synonym + type Type = TYPE LiftedRep + Similarly for UnliftedType + +These serve goal (b) since there are no applied type arguments to traverse, +e.g., during comparison. + + 3. We have a single, statically allocated top-level binding to + represent `TyConApp GHC.Types.Type []` (namely + 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we don't + need to allocate such types (goal (a)). See functions + mkTYPEapp and mkBoxedRepApp + + 4. We use the sharing mechanism described in Note [Sharing nullary TyConApps] + in GHC.Core.TyCon to ensure that we never need to allocate such + nullary applications (goal (a)). + +See #17958, #20541 +-} + +-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon [] + = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon + mkTyConTy tycon + +mkTyConApp tycon tys@(ty1:rest) + | Just fun_ty <- tyConAppFunTy_maybe tycon tys + = fun_ty + + -- See Note [Using synonyms to compress types] + | key == tYPETyConKey + , Just ty <- mkTYPEapp_maybe ty1 + = assert (null rest) ty + + | key == cONSTRAINTTyConKey + , Just ty <- mkCONSTRAINTapp_maybe ty1 + = assert (null rest) ty + + -- See Note [Using synonyms to compress types] + | key == boxedRepDataConTyConKey + , Just ty <- mkBoxedRepApp_maybe ty1 + = assert (null rest) ty + + | key == tupleRepDataConTyConKey + , Just ty <- mkTupleRepApp_maybe ty1 + = assert (null rest) ty + + -- The catch-all case + | otherwise + = TyConApp tycon tys + where + key = tyConUnique tycon + + +{- Note [Care using synonyms to compress types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Using a synonym to compress a types has a tricky wrinkle. Consider +coreView applied to (TyConApp LiftedRep []) + +* coreView expands the LiftedRep synonym: + type LiftedRep = BoxedRep Lifted + +* Danger: we might apply the empty substitution to the RHS of the + synonym. And substTy calls mkTyConApp BoxedRep [Lifted]. And + mkTyConApp compresses that back to LiftedRep. Loop! + +* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary + type synonyms. That's more efficient anyway. +-} + + +mkTYPEapp :: RuntimeRepType -> Type +mkTYPEapp rr + = case mkTYPEapp_maybe rr of + Just ty -> ty + Nothing -> TyConApp tYPETyCon [rr] + +mkTYPEapp_maybe :: RuntimeRepType -> Maybe Type +-- ^ Given a @RuntimeRep@, applies @TYPE@ to it. +-- On the fly it rewrites +-- TYPE LiftedRep --> liftedTypeKind (a synonym) +-- TYPE UnliftedRep --> unliftedTypeKind (ditto) +-- TYPE ZeroBitRep --> zeroBitTypeKind (ditto) +-- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted) +-- because those inner types should already have been rewritten +-- to LiftedRep and UnliftedRep respectively, by mkTyConApp +-- +-- see Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkTYPEapp_maybe #-} +mkTYPEapp_maybe (TyConApp tc args) + | key == liftedRepTyConKey = assert (null args) $ Just liftedTypeKind -- TYPE LiftedRep + | key == unliftedRepTyConKey = assert (null args) $ Just unliftedTypeKind -- TYPE UnliftedRep + | key == zeroBitRepTyConKey = assert (null args) $ Just zeroBitTypeKind -- TYPE ZeroBitRep + where + key = tyConUnique tc +mkTYPEapp_maybe _ = Nothing + +------------------ +mkCONSTRAINTapp :: RuntimeRepType -> Type +-- ^ Just like mkTYPEapp +mkCONSTRAINTapp rr + = case mkCONSTRAINTapp_maybe rr of + Just ty -> ty + Nothing -> TyConApp cONSTRAINTTyCon [rr] + +mkCONSTRAINTapp_maybe :: RuntimeRepType -> Maybe Type +-- ^ Just like mkTYPEapp_maybe +{-# NOINLINE mkCONSTRAINTapp_maybe #-} +mkCONSTRAINTapp_maybe (TyConApp tc args) + | tc `hasKey` liftedRepTyConKey = assert (null args) $ + Just constraintKind -- CONSTRAINT LiftedRep +mkCONSTRAINTapp_maybe _ = Nothing + +------------------ +mkBoxedRepApp_maybe :: LevityType -> Maybe Type +-- ^ Given a `Levity`, apply `BoxedRep` to it +-- On the fly, rewrite +-- BoxedRep Lifted --> liftedRepTy (a synonym) +-- BoxedRep Unlifted --> unliftedRepTy (ditto) +-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkBoxedRepApp_maybe #-} +mkBoxedRepApp_maybe (TyConApp tc args) + | key == liftedDataConKey = assert (null args) $ Just liftedRepTy -- BoxedRep Lifted + | key == unliftedDataConKey = assert (null args) $ Just unliftedRepTy -- BoxedRep Unlifted + where + key = tyConUnique tc +mkBoxedRepApp_maybe _ = Nothing + +mkTupleRepApp_maybe :: Type -> Maybe Type +-- ^ Given a `[RuntimeRep]`, apply `TupleRep` to it +-- On the fly, rewrite +-- TupleRep [] -> zeroBitRepTy (a synonym) +-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkTupleRepApp_maybe #-} +mkTupleRepApp_maybe (TyConApp tc args) + | key == nilDataConKey = assert (isSingleton args) $ Just zeroBitRepTy -- ZeroBitRep + where + key = tyConUnique tc +mkTupleRepApp_maybe _ = Nothing + +typeOrConstraintKind :: TypeOrConstraint -> RuntimeRepType -> Kind +typeOrConstraintKind TypeLike rep = mkTYPEapp rep +typeOrConstraintKind ConstraintLike rep = mkCONSTRAINTapp rep + +liftedTypeOrConstraintKind :: TypeOrConstraint -> Kind +liftedTypeOrConstraintKind TypeLike = liftedTypeKind +liftedTypeOrConstraintKind ConstraintLike = constraintKind diff --git a/GHC/Core/Type.hs-boot b/GHC/Core/Type.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/Type.hs-boot @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Core.Type where + +import GHC.Prelude +import {-# SOURCE #-} GHC.Core.TyCon +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion ) +import GHC.Utils.Misc +import GHC.Types.Var( FunTyFlag, TyVar ) +import GHC.Types.Basic( TypeOrConstraint ) + + +coreView :: Type -> Maybe Type +rewriterView :: Type -> Maybe Type +chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag +typeKind :: HasDebugCallStack => Type -> Type +isCoercionTy :: Type -> Bool +mkAppTy :: Type -> Type -> Type +mkCastTy :: Type -> Coercion -> Type +mkTyConApp :: TyCon -> [Type] -> Type +getLevity :: HasDebugCallStack => Type -> Type +getTyVar_maybe :: Type -> Maybe TyVar +isLiftedTypeKind :: Type -> Bool + +partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) +typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint diff --git a/GHC/Core/Unfold.hs b/GHC/Core/Unfold.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Unfold.hs @@ -0,0 +1,1081 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +Core-syntax unfoldings + +Unfoldings (which can travel across module boundaries) are in Core +syntax (namely @CoreExpr@s). + +The type @Unfolding@ sits ``above'' simply-Core-expressions +unfoldings, capturing ``higher-level'' things we know about a binding, +usually things that the simplifier found out (e.g., ``it's a +literal''). In the corner of a @CoreUnfolding@ unfolding, you will +find, unsurprisingly, a Core expression. +-} + + + +module GHC.Core.Unfold ( + Unfolding, UnfoldingGuidance, -- Abstract types + + ExprSize(..), sizeExpr, + + ArgSummary(..), nonTriv, + CallCtxt(..), + + UnfoldingOpts (..), defaultUnfoldingOpts, + updateCreationThreshold, updateUseThreshold, + updateFunAppDiscount, updateDictDiscount, + updateVeryAggressive, updateCaseScaling, + updateCaseThreshold, updateReportPrefix, + + inlineBoringOk, calcUnfoldingGuidance, + uncondInlineJoin + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Utils +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Class( Class ) +import GHC.Core.Predicate( isUnaryClass ) + +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Types.Id.Info +import GHC.Types.RepType ( isZeroBitTy ) +import GHC.Types.Basic ( Arity, RecFlag ) +import GHC.Types.ForeignCall +import GHC.Types.Tickish + +import GHC.Builtin.PrimOps +import GHC.Builtin.Names + +import GHC.Data.Bag + +import GHC.Utils.Misc +import GHC.Utils.Outputable + +import qualified Data.ByteString as BS +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NE + +-- | Unfolding options +data UnfoldingOpts = UnfoldingOpts + { unfoldingCreationThreshold :: !Int + -- ^ Threshold above which unfoldings are not *created* + + , unfoldingUseThreshold :: !Int + -- ^ Threshold above which unfoldings are not *inlined* + + , unfoldingFunAppDiscount :: !Int + -- ^ Discount for lambdas that are used (applied) + + , unfoldingDictDiscount :: !Int + -- ^ Discount for dictionaries + + , unfoldingVeryAggressive :: !Bool + -- ^ Force inlining in many more cases + + , unfoldingCaseThreshold :: !Int + -- ^ Don't consider depth up to x + + , unfoldingCaseScaling :: !Int + -- ^ Penalize depth with 1/x + + , unfoldingReportPrefix :: !(Maybe String) + -- ^ Only report inlining decisions for names with this prefix + } + +defaultUnfoldingOpts :: UnfoldingOpts +defaultUnfoldingOpts = UnfoldingOpts + { unfoldingCreationThreshold = 750 + -- The unfoldingCreationThreshold threshold must be reasonably high + -- to take account of possible discounts. + -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to + -- inline into Csg.calc (The unfolding for sqr never makes it + -- into the interface file.) + + , unfoldingUseThreshold = 90 + -- Last adjusted upwards in #18282, when I reduced + -- the result discount for constructors. + + , unfoldingFunAppDiscount = 60 + -- Be fairly keen to inline a function if that means + -- we'll be able to pick the right method from a dictionary + + , unfoldingDictDiscount = 30 + -- Be fairly keen to inline a function if that means + -- we'll be able to pick the right method from a dictionary + + , unfoldingVeryAggressive = False + + -- Only apply scaling once we are deeper than threshold cases + -- in an RHS. + , unfoldingCaseThreshold = 2 + + -- Penalize depth with (size*depth)/scaling + , unfoldingCaseScaling = 30 + + -- Don't filter inlining decision reports + , unfoldingReportPrefix = Nothing + } + +-- Helpers for "GHC.Driver.Session" + +updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts +updateCreationThreshold n opts = opts { unfoldingCreationThreshold = n } + +updateUseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts +updateUseThreshold n opts = opts { unfoldingUseThreshold = n } + +updateFunAppDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts +updateFunAppDiscount n opts = opts { unfoldingFunAppDiscount = n } + +updateDictDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts +updateDictDiscount n opts = opts { unfoldingDictDiscount = n } + +updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts +updateVeryAggressive n opts = opts { unfoldingVeryAggressive = n } + + +updateCaseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts +updateCaseThreshold n opts = opts { unfoldingCaseThreshold = n } + +updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts +updateCaseScaling n opts = opts { unfoldingCaseScaling = n } + +updateReportPrefix :: Maybe String -> UnfoldingOpts -> UnfoldingOpts +updateReportPrefix n opts = opts { unfoldingReportPrefix = n } + +data ArgSummary = TrivArg -- Nothing interesting + | NonTrivArg -- Arg has structure + | ValueArg -- Arg is a con-app or PAP + -- ..or con-like. Note [Conlike is interesting] + +instance Outputable ArgSummary where + ppr TrivArg = text "TrivArg" + ppr NonTrivArg = text "NonTrivArg" + ppr ValueArg = text "ValueArg" + +nonTriv :: ArgSummary -> Bool +nonTriv TrivArg = False +nonTriv _ = True + +data CallCtxt + = BoringCtxt + | RhsCtxt RecFlag -- Rhs of a let-binding; see Note [RHS of lets] + | DiscArgCtxt -- Argument of a function with non-zero arg discount + | RuleArgCtxt -- We are somewhere in the argument of a function with rules + + | ValAppCtxt -- We're applied to at least one value arg + -- This arises when we have ((f x |> co) y) + -- Then the (f x) has argument 'x' but in a ValAppCtxt + + | CaseCtxt -- We're the scrutinee of a case + -- that decomposes its scrutinee + +instance Outputable CallCtxt where + ppr CaseCtxt = text "CaseCtxt" + ppr ValAppCtxt = text "ValAppCtxt" + ppr BoringCtxt = text "BoringCtxt" + ppr (RhsCtxt ir)= text "RhsCtxt" <> parens (ppr ir) + ppr DiscArgCtxt = text "DiscArgCtxt" + ppr RuleArgCtxt = text "RuleArgCtxt" + +{- +Note [Calculate unfolding guidance on the non-occ-anal'd expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we give the non-occur-analysed expression to +calcUnfoldingGuidance. In some ways it'd be better to occur-analyse +first; for example, sometimes during simplification, there's a large +let-bound thing which has been substituted, and so is now dead; so +'expr' contains two copies of the thing while the occurrence-analysed +expression doesn't. + +Nevertheless, we *don't* and *must not* occ-analyse before computing +the size because + +a) The size computation bales out after a while, whereas occurrence + analysis does not. + +b) Residency increases sharply if you occ-anal first. I'm not + 100% sure why, but it's a large effect. Compiling Cabal went + from residency of 534M to over 800M with this one change. + +This can occasionally mean that the guidance is very pessimistic; +it gets fixed up next round. And it should be rare, because large +let-bound things that are dead are usually caught by preInlineUnconditionally + + +************************************************************************ +* * +\subsection{The UnfoldingGuidance type} +* * +************************************************************************ +-} + +{- Note [inlineBoringOk] +~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [INLINE for small functions] + +The function `inlineBoringOk` returns True (boringCxtOk) if the supplied +unfolding, which looks like (\x y z. body), is such that the result of +inlining a saturated call is no bigger than `body`. Some wrinkles: + +(IB1) An important case is + - \x. (x `cast` co) + +(IB2) If `body` looks like a data constructor worker, we become keener + to inline, by ignoring the number of arguments; we just insist they + are all trivial. Reason: in a call like `f (g x y)`, if `g` unfolds + to a data construtor, we can allocate a data constructor instead of + a thunk (g x y). + + A case in point where a GADT data constructor failed to inline (#25713) + $WK = /\a \x. K @a x + We really want to inline a boring call to $WK so that we allocate + a data constructor not a thunk ($WK @ty x). + + But not for nullary constructors! We don't want to turn + f ($WRefl @ty) + into + f (Refl @ty ) + because the latter might allocate, whereas the former shares. + (You might wonder if (Refl @ty ) should allocate, but I think + that currently it does.) So for nullary constructors, `inlineBoringOk` + returns False. + +(IB3) Types and coercions do not count towards the expression size. + They are ultimately erased. + +(IB4) If there are no value arguments, `inlineBoringOk` we have to be + careful (#17182). If we have + let y = x @Int in f y y + there’s no reason not to inline y at both use sites — no work is + actually duplicated. + + But not so for coercion arguments! Unlike type arguments, which have + no runtime representation, coercion arguments *do* have a runtime + representation (albeit the zero-width VoidRep, see Note [Coercion + tokens] in "GHC.CoreToStg"). For example: + let y = g @Int in g y y + Here `co` is a value argument, and calling it twice might duplicate + work. + + Even if `g` is a data constructor, so no work is duplicated, + inlining `y` might duplicate allocation of a data constructor object + (#17787). See also (IB2). + + TL;DR: if `is_fun` is False, so we have no value arguments, we /do/ + count coercion arguments, despite (IB3). + +(IB5) You might wonder about an unfolding like (\x y z -> x (y z)), + whose body is, in some sense, just as small as (g x y z). + But `inlineBoringOk` doesn't attempt anything fancy; it just looks + for a function call with trivial arguments, Keep it simple. + +(IB6) If we have an unfolding (K op) where K is a unary-class data constructor, + we want to inline it! So that we get calls (f op), which in turn can see (in + STG land) that `op` is already evaluated and properly tagged. (If `op` isn't + trivial we will have baled out before we get to the Var case.) This made + a big difference in benchmarks for the `effectful` library; details in !10479. + + See Note [Unary class magic] in GHC/Core/TyCon. +-} + +inlineBoringOk :: CoreExpr -> Bool +-- True => the result of inlining the expression is +-- no bigger than the expression itself +-- eg (\x y -> f y x) +-- See Note [inlineBoringOk] +inlineBoringOk e + = go 0 e + where + is_fun = isValFun e + + go :: Int -> CoreExpr -> Bool + -- credit = #(value lambdas) = #(value args) + go credit (Lam x e) | isRuntimeVar x = go (credit+1) e + | otherwise = go credit e -- See (IB3) + + go credit (App f (Type {})) = go credit f -- See (IB3) + go credit (App f (Coercion {})) + | is_fun = go credit f -- See (IB3) + | otherwise = go (credit-1) f -- See (IB4) + go credit (App f a) | exprIsTrivial a = go (credit-1) f + + go credit (Case e b _ alts) + | null alts + = go credit e -- EmptyCase is like e + | Just rhs <- isUnsafeEqualityCase e b alts + = go credit rhs -- See Note [Inline unsafeCoerce] + + go credit (Tick _ e) = go credit e -- dubious + go credit (Cast e _) = go credit e -- See (IB3) + + -- Lit: we assume credit >= 0; literals aren't functions + go _ (Lit l) = litIsTrivial l && boringCxtOk + + go credit (Var v) | isDataConWorkId v, is_fun = boringCxtOk -- See (IB2) + | isUnaryClassId v = boringCxtOk -- See (IB6) + | credit >= 0 = boringCxtOk + | otherwise = boringCxtNotOk + + go _ _ = boringCxtNotOk + +isValFun :: CoreExpr -> Bool +-- True of functions with at least +-- one top-level value lambda +isValFun (Lam b e) | isRuntimeVar b = True + | otherwise = isValFun e +isValFun _ = False + +calcUnfoldingGuidance + :: UnfoldingOpts + -> Bool -- Definitely a top-level, bottoming binding + -> Bool -- True <=> join point + -> CoreExpr -- Expression to look at + -> UnfoldingGuidance +calcUnfoldingGuidance opts is_top_bottoming is_join (Tick t expr) + | not (tickishIsCode t) -- non-code ticks don't matter for unfolding + = calcUnfoldingGuidance opts is_top_bottoming is_join expr +calcUnfoldingGuidance opts is_top_bottoming is_join expr + = case sizeExpr opts bOMB_OUT_SIZE val_bndrs body of + TooBig -> UnfNever + SizeIs size cased_bndrs scrut_discount + | uncondInline is_join expr bndrs n_val_bndrs body size + -> UnfWhen { ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boringCxtOk + , ug_arity = n_val_bndrs } -- Note [INLINE for small functions] + + | is_top_bottoming + -> UnfNever -- See Note [Do not inline top-level bottoming functions] + + | otherwise + -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs + , ug_size = size + , ug_res = scrut_discount } + + where + (bndrs, body) = collectBinders expr + bOMB_OUT_SIZE = unfoldingCreationThreshold opts + -- Bomb out if size gets bigger than this + val_bndrs = filter isId bndrs + n_val_bndrs = length val_bndrs + + mk_discount :: Bag (Id,Int) -> Id -> Int + mk_discount cbs bndr = foldl' combine 0 cbs + where + combine acc (bndr', disc) + | bndr == bndr' = acc `plus_disc` disc + | otherwise = acc + + plus_disc :: Int -> Int -> Int + plus_disc | isFunTy (idType bndr) = max + | otherwise = (+) + -- See Note [Function and non-function discounts] + +{- Note [Inline unsafeCoerce] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We really want to inline unsafeCoerce, even when applied to boring +arguments. It doesn't look as if its RHS is smaller than the call + unsafeCoerce x = case unsafeEqualityProof @a @b of UnsafeRefl -> x +but that case is discarded in CoreToStg -- see Note [Implementing unsafeCoerce] +in base:Unsafe.Coerce. + +Moreover, if we /don't/ inline it, we may be left with + f (unsafeCoerce x) +which will build a thunk -- bad, bad, bad. + +Conclusion: we really want inlineBoringOk to be True of the RHS of +unsafeCoerce. And it really is, because we regard + case unsafeEqualityProof @a @b of UnsafeRefl -> rhs +as trivial iff rhs is. This is (U4) in Note [Implementing unsafeCoerce]. + +Note [Computing the size of an expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of sizeExpr is obvious enough: count nodes. But getting the +heuristics right has taken a long time. Here's the basic strategy: + + * Variables, literals: 0 + (Exception for string literals, see litSize.) + + * Function applications (f e1 .. en): 1 + #value args + + * Constructor applications: 1, regardless of #args + + * Let(rec): 1 + size of components + + * Note, cast: 0 + +Examples + + Size Term + -------------- + 0 42# + 0 x + 0 True + 2 f x + 1 Just x + 4 f (g x) + +Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's +a function call to account for. Notice also that constructor applications +are very cheap, because exposing them to a caller is so valuable. + +[25/5/11] All sizes are now multiplied by 10, except for primops +(which have sizes like 1 or 4. This makes primops look fantastically +cheap, and seems to be almost universally beneficial. Done partly as a +result of #4978. + +Note [Do not inline top-level bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The FloatOut pass has gone to some trouble to float out calls to 'error' +and similar friends. See Note [Bottoming floats] in GHC.Core.Opt.SetLevels. +Do not re-inline them! But we *do* still inline if they are very small +(the uncondInline stuff). + +Note [INLINE for small functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider {-# INLINE f #-} + f x = Just x + g y = f y +Then f's RHS is no larger than its LHS, so we should inline it into +even the most boring context. In general, f the function is +sufficiently small that its body is as small as the call itself, the +inline unconditionally, regardless of how boring the context is. + +Things to note: + +(1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr) + than the thing it's replacing. Notice that + (f x) --> (g 3) -- YES, unconditionally + (f x) --> x : [] -- YES, *even though* there are two + -- arguments to the cons + x --> g 3 -- NO + x --> Just v -- NO + + It's very important not to unconditionally replace a variable by + a non-atomic term. + +(2) We do this even if the thing isn't saturated, else we end up with the + silly situation that + f x y = x + ...map (f 3)... + doesn't inline. Even in a boring context, inlining without being + saturated will give a lambda instead of a PAP, and will be more + efficient at runtime. + +(3) However, when the function's arity > 0, we do insist that it + has at least one value argument at the call site. (This check is + made in the UnfWhen case of callSiteInline.) Otherwise we find this: + f = /\a \x:a. x + d = /\b. MkD (f b) + If we inline f here we get + d = /\b. MkD (\x:b. x) + and then prepareRhs floats out the argument, abstracting the type + variables, so we end up with the original again! + +(4) We must be much more cautious about arity-zero things. Consider + let x = y +# z in ... + In *size* terms primops look very small, because the generate a + single instruction, but we do not want to unconditionally replace + every occurrence of x with (y +# z). So we only do the + unconditional-inline thing for *trivial* expressions. + + NB: you might think that PostInlineUnconditionally would do this + but it doesn't fire for top-level things; see GHC.Core.Opt.Simplify.Utils + Note [Top level and postInlineUnconditionally] +-} + +uncondInline :: Bool -> CoreExpr -> [Var] -> Arity -> CoreExpr -> Int -> Bool +-- Inline unconditionally if there no size increase +-- Size of call is arity (+1 for the function) +-- See Note [INLINE for small functions] +uncondInline is_join rhs bndrs arity body size + | is_join = uncondInlineJoin bndrs body + | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1) + | otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4) + +uncondInlineJoin :: [Var] -> CoreExpr -> Bool +-- See Note [Duplicating join points] point (DJ3) in GHC.Core.Opt.Simplify.Iteration +uncondInlineJoin bndrs body + + -- (DJ3)(a) + | exprIsTrivial body + = True -- Nullary constructors, literals + + -- (DJ3)(b) and (DJ3)(c) combined + | indirectionOrAppWithoutFVs + = True + + | otherwise + = False + + where + -- (DJ3)(b): + -- - $j1 x = $j2 y x |> co -- YES, inline indirection regardless of free vars + -- (DJ3)(c): + -- - $j1 x y = K y x |> co -- YES, inline! + -- - $j2 x = K f x -- No, don't! (because f is free) + indirectionOrAppWithoutFVs = go False body + + go !seen_fv (App f a) + | Just has_fv <- go_arg a + = go (seen_fv || has_fv) f + | otherwise = False -- Not trivial + go seen_fv (Var v) + | isJoinId v = True -- Indirection to another join point; always inline + | isDataConId v = not seen_fv -- e.g. $j a b = K a b + | v `elem` bndrs = not seen_fv -- e.g. $j a b = b a + go seen_fv (Cast e _) = go seen_fv e + go seen_fv (Tick _ e) = go seen_fv e + go _ _ = False + + -- go_arg returns: + -- - `Nothing` if arg is not trivial + -- - `Just True` if arg is trivial but contains free var, literal, or constructor + -- - `Just False` if arg is trivial without free vars + go_arg (Type {}) = Just False + go_arg (Coercion {}) = Just False + go_arg (Lit l) + | litIsTrivial l = Just True -- e.g. $j x = $j2 x 7 YES, but $j x = K x 7 NO + | otherwise = Nothing + go_arg (App f a) + | isTyCoArg a = go_arg f -- e.g. $j f = K (f @a) + | otherwise = Nothing + go_arg (Cast e _) = go_arg e + go_arg (Tick _ e) = go_arg e + go_arg (Var f) = Just $! f `notElem` bndrs + go_arg _ = Nothing + + +sizeExpr :: UnfoldingOpts + -> Int -- Bomb out if it gets bigger than this + -> [Id] -- Arguments; we're interested in which of these + -- get case'd + -> CoreExpr + -> ExprSize + +-- Note [Computing the size of an expression] + +-- Forcing bOMB_OUT_SIZE early prevents repeated +-- unboxing of the Int argument. +sizeExpr opts !bOMB_OUT_SIZE top_args expr + = size_up expr + where + size_up (Cast e _) = size_up e + size_up (Tick _ e) = size_up e + size_up (Type _) = sizeZero -- Types cost nothing + size_up (Coercion _) = sizeZero + size_up (Lit lit) = sizeN (litSize lit) + size_up (Var f) | isZeroBitId f = sizeZero + -- Make sure we get constructor discounts even + -- on nullary constructors + | otherwise = size_up_call f [] 0 + + size_up (App fun arg) + | isTyCoArg arg = size_up fun + | otherwise = size_up arg `addSizeNSD` + size_up_app fun [arg] (if isZeroBitExpr arg then 1 else 0) + + size_up (Lam b e) + | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up e `addSizeN` 10) + | otherwise = size_up e + + size_up (Let (NonRec binder rhs) body) + = size_up_rhs (binder, rhs) `addSizeNSD` + size_up body `addSizeN` + size_up_alloc binder + + size_up (Let (Rec pairs) body) + = foldr (addSizeNSD . size_up_rhs) + (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) + pairs + + size_up (Case e _ _ alts) = case nonEmpty alts of + Nothing -> size_up e -- case e of {} never returns, so take size of scrutinee + Just alts + | Just v <- is_top_arg e -> -- We are scrutinising an argument variable + let + alt_sizes = NE.map size_up_alt alts + + -- alts_size tries to compute a good discount for + -- the case when we are scrutinising an argument variable + alts_size (SizeIs tot tot_disc tot_scrut) + -- Size of all alternatives + (SizeIs max _ _) + -- Size of biggest alternative + = SizeIs tot (unitBag (v, 20 + tot - max) + `unionBags` tot_disc) tot_scrut + -- If the variable is known, we produce a + -- discount that will take us back to 'max', + -- the size of the largest alternative The + -- 1+ is a little discount for reduced + -- allocation in the caller + -- + -- Notice though, that we return tot_disc, + -- the total discount from all branches. I + -- think that's right. + + alts_size tot_size _ = tot_size + in + alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty + (foldr1 maxSize alt_sizes) + -- Good to inline if an arg is scrutinised, because + -- that may eliminate allocation in the caller + -- And it eliminates the case itself + + | otherwise -> size_up e `addSizeNSD` + foldr (addAltSize . size_up_alt) case_size alts + + where + is_top_arg (Var v) | v `elem` top_args = Just v + is_top_arg (Cast e _) = is_top_arg e + is_top_arg _ = Nothing + + where + case_size + | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10) + | otherwise = sizeZero + -- Normally we don't charge for the case itself, but + -- we charge one per alternative (see size_up_alt, + -- below) to account for the cost of the info table + -- and comparisons. + -- + -- However, in certain cases (see is_inline_scrut + -- below), no code is generated for the case unless + -- there are multiple alts. In these cases we + -- subtract one, making the first alt free. + -- e.g. case x# +# y# of _ -> ... should cost 1 + -- case touch# x# of _ -> ... should cost 0 + -- (see #4978) + -- + -- I would like to not have the "lengthAtMost alts 1" + -- condition above, but without that some programs got worse + -- (spectral/hartel/event and spectral/para). I don't fully + -- understand why. (SDM 24/5/11) + + -- unboxed variables, inline primops and unsafe foreign calls + -- are all "inline" things: + is_inline_scrut (Var v) = + isUnliftedType (idType v) + -- isUnliftedType is OK here: scrutinees have a fixed RuntimeRep (search for FRRCase) + is_inline_scrut scrut + | (Var f, _) <- collectArgs scrut + = case idDetails f of + FCallId fc -> not (isSafeForeignCall fc) + PrimOpId op _ -> not (primOpOutOfLine op) + _other -> False + | otherwise + = False + + size_up_rhs (bndr, rhs) + | JoinPoint join_arity <- idJoinPointHood bndr + -- Skip arguments to join point + , (_bndrs, body) <- collectNBinders join_arity rhs + = size_up body + | otherwise + = size_up rhs + + ------------ + -- size_up_app is used when there's ONE OR MORE value args + size_up_app (App fun arg) args voids + | isTyCoArg arg = size_up_app fun args voids + | isZeroBitExpr arg = size_up_app fun (arg:args) (voids + 1) + | otherwise = size_up arg `addSizeNSD` + size_up_app fun (arg:args) voids + size_up_app (Var fun) args voids = size_up_call fun args voids + size_up_app (Tick _ expr) args voids = size_up_app expr args voids + size_up_app (Cast expr _) args voids = size_up_app expr args voids + size_up_app other args voids = size_up other `addSizeN` + callSize (length args) voids + -- if the lhs is not an App or a Var, or an invisible thing like a + -- Tick or Cast, then we should charge for a complete call plus the + -- size of the lhs itself. + + ------------ + size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize + size_up_call fun val_args voids + = case idDetails fun of + FCallId _ -> sizeN (callSize (length val_args) voids) + DataConWorkId dc -> conSize dc (length val_args) + PrimOpId op _ -> primOpSize op (length val_args) + ClassOpId cls _ -> classOpSize opts cls top_args val_args + _ | fun `hasKey` buildIdKey -> buildSize + | fun `hasKey` augmentIdKey -> augmentSize + | otherwise -> funSize opts top_args fun (length val_args) voids + + ------------ + size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10 + -- Don't charge for args, so that wrappers look cheap + -- (See comments about wrappers with Case) + -- + -- IMPORTANT: *do* charge 1 for the alternative, else we + -- find that giant case nests are treated as practically free + -- A good example is Foreign.C.Error.errnoToIOError + + ------------ + -- Cost to allocate binding with given binder + size_up_alloc bndr + | isTyVar bndr -- Doesn't exist at runtime + || isJoinId bndr -- Not allocated at all + || not (isBoxedType (idType bndr)) -- Doesn't live in heap + = 0 + | otherwise + = 10 + + ------------ + -- These addSize things have to be here because + -- I don't want to give them bOMB_OUT_SIZE as an argument + addSizeN TooBig _ = TooBig + addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n + m) xs d + + -- addAltSize is used to add the sizes of case alternatives + addAltSize TooBig _ = TooBig + addAltSize _ TooBig = TooBig + addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 + n2) + (xs `unionBags` ys) + (d1 + d2) -- Note [addAltSize result discounts] + + -- This variant ignores the result discount from its LEFT argument + -- It's used when the second argument isn't part of the result + addSizeNSD TooBig _ = TooBig + addSizeNSD _ TooBig = TooBig + addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 + n2) + (xs `unionBags` ys) + d2 -- Ignore d1 + + -- don't count expressions such as State# RealWorld + -- exclude join points, because they can be rep-polymorphic + -- and typePrimRep will crash + isZeroBitId id = not (isJoinId id) && isZeroBitTy (idType id) + + isZeroBitExpr (Var id) = isZeroBitId id + isZeroBitExpr (Tick _ e) = isZeroBitExpr e + isZeroBitExpr _ = False + +-- | Finds a nominal size of a string literal. +litSize :: Literal -> Int +-- Used by GHC.Core.Unfold.sizeExpr +litSize (LitNumber LitNumBigNat _) = 100 +litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4) + -- If size could be 0 then @f "x"@ might be too small + -- [Sept03: make literal strings a bit bigger to avoid fruitless + -- duplication of little strings] +litSize _other = 0 -- Must match size of nullary constructors + -- Key point: if x |-> 4, then x must inline unconditionally + -- (eg via case binding) + +classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize +-- See Note [Conlike is interesting] +classOpSize opts cls top_args args + | isUnaryClass cls + = sizeZero -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon + | otherwise + = case args of + [] -> sizeZero + (arg1:other_args) -> SizeIs (size other_args) (arg_discount arg1) 0 + where + size other_args = 20 + (10 * length other_args) + + -- If the class op is scrutinising a lambda bound dictionary then + -- give it a discount, to encourage the inlining of this function + -- The actual discount is rather arbitrarily chosen + arg_discount (Var dict) | dict `elem` top_args + = unitBag (dict, unfoldingDictDiscount opts) + arg_discount _ = emptyBag + +-- | The size of a function call +callSize + :: Int -- ^ number of value args + -> Int -- ^ number of value args that are void + -> Int +callSize n_val_args voids = 10 * (1 + n_val_args - voids) + -- The 1+ is for the function itself + -- Add 1 for each non-trivial arg; + -- the allocation cost, as in let(rec) + +-- | The size of a jump to a join point +jumpSize + :: Int -- ^ number of value args + -> Int -- ^ number of value args that are void + -> Int +jumpSize _n_val_args _voids = 0 -- Jumps are small, and we don't want penalise them + + -- Old version: + -- 2 * (1 + n_val_args - voids) + -- A jump is 20% the size of a function call. Making jumps free reopens + -- bug #6048, but making them any more expensive loses a 21% improvement in + -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a + -- better solution? + +funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize +-- Size for function calls where the function is not a constructor or primops +-- Note [Function applications] +funSize opts top_args fun n_val_args voids + | otherwise = SizeIs size arg_discount res_discount + where + some_val_args = n_val_args > 0 + is_join = isJoinId fun + + size | is_join = jumpSize n_val_args voids + | not some_val_args = 0 + | otherwise = callSize n_val_args voids + + -- DISCOUNTS + -- See Note [Function and non-function discounts] + arg_discount | some_val_args && fun `elem` top_args + = unitBag (fun, unfoldingFunAppDiscount opts) + | otherwise = emptyBag + -- If the function is an argument and is applied + -- to some values, give it an arg-discount + + res_discount | idArity fun > n_val_args = unfoldingFunAppDiscount opts + | otherwise = 0 + -- If the function is partially applied, show a result discount +-- XXX maybe behave like ConSize for eval'd variable + +conSize :: DataCon -> Int -> ExprSize +conSize dc n_val_args + | n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables + +-- See Note [Unboxed tuple size and result discount] + | isUnboxedTupleDataCon dc = SizeIs 0 emptyBag 10 + + | isUnaryClassDataCon dc = sizeZero + +-- See Note [Constructor size and result discount] + | otherwise = SizeIs 10 emptyBag 10 + +{- Note [Constructor size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Treat a constructors application as size 10, regardless of how many +arguments it has; we are keen to expose them (and we charge separately +for their args). We can't treat them as size zero, else we find that +(Just x) has size 0, which is the same as a lone variable; and hence +'v' will always be replaced by (Just x), where v is bound to Just x. + +The "result discount" is applied if the result of the call is +scrutinised (say by a case). For a constructor application that will +mean the constructor application will disappear, so we don't need to +charge it to the function. So the discount should at least match the +cost of the constructor application, namely 10. + +Historical note 1: Until Jun 2020 we gave it a "bit of extra +incentive" via a discount of 10*(1 + n_val_args), but that was FAR too +much (#18282). In particular, consider a huge case tree like + + let r = case y1 of + Nothing -> B1 a b c + Just v1 -> case y2 of + Nothing -> B1 c b a + Just v2 -> ... + +If conSize gives a cost of 10 (regardless of n_val_args) and a +discount of 10, that'll make each alternative RHS cost zero. We +charge 10 for each case alternative (see size_up_alt). If we give a +bigger discount (say 20) in conSize, we'll make the case expression +cost *nothing*, and that can make a huge case tree cost nothing. This +leads to massive, sometimes exponential inlinings (#18282). In short, +don't give a discount that give a negative size to a sub-expression! + +Historical note 2: Much longer ago, Simon M tried a MUCH bigger +discount: (10 * (10 + n_val_args)), and said it was an "unambiguous +win", but its terribly dangerous because a function with many many +case branches, each finishing with a constructor, can have an +arbitrarily large discount. This led to terrible code bloat: see #6099. + +Note [Unboxed tuple size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +However, unboxed tuples count as size zero. I found occasions where we had + f x y z = case op# x y z of { s -> (# s, () #) } +and f wasn't getting inlined. + +I tried giving unboxed tuples a *result discount* of zero (see the +commented-out line). Why? When returned as a result they do not +allocate, so maybe we don't want to charge so much for them. If you +have a non-zero discount here, we find that workers often get inlined +back into wrappers, because it look like + f x = case $wf x of (# a,b #) -> (a,b) +and we are keener because of the case. However while this change +shrank binary sizes by 0.5% it also made spectral/boyer allocate 5% +more. All other changes were very small. So it's not a big deal but I +didn't adopt the idea. + +When fixing #18282 (see Note [Constructor size and result discount]) +I changed the result discount to be just 10, not 10*(1+n_val_args). + +Note [Function and non-function discounts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want a discount if the function is applied. A good example is +monadic combinators with continuation arguments, where inlining is +quite important. + +But we don't want a big discount when a function is called many times +(see the detailed comments with #6048) because if the function is +big it won't be inlined at its many call sites and no benefit results. +Indeed, we can get exponentially big inlinings this way; that is what +#6048 is about. + +On the other hand, for data-valued arguments, if there are lots of +case expressions in the body, each one will get smaller if we apply +the function to a constructor application, so we *want* a big discount +if the argument is scrutinised by many case expressions. + +Conclusion: + - For functions, take the max of the discounts + - For data values, take the sum of the discounts + + +Note [Literal integer size] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal integers *can* be big (mkInteger [...coefficients...]), but +need not be (IS n). We just use an arbitrary big-ish constant here +so that, in particular, we don't inline top-level defns like + n = IS 5 +There's no point in doing so -- any optimisations will see the IS +through n's unfolding. Nor will a big size inhibit unfoldings functions +that mention a literal Integer, because the float-out pass will float +all those constants to top level. +-} + +primOpSize :: PrimOp -> Int -> ExprSize +primOpSize op n_val_args + = if primOpOutOfLine op + then sizeN (op_size + n_val_args) + else sizeN op_size + where + op_size = primOpCodeSize op + + +buildSize :: ExprSize +buildSize = SizeIs 0 emptyBag 40 + -- We really want to inline applications of build + -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later) + -- Indeed, we should add a result_discount because build is + -- very like a constructor. We don't bother to check that the + -- build is saturated (it usually is). The "-2" discounts for the \c n, + -- The "4" is rather arbitrary. + +augmentSize :: ExprSize +augmentSize = SizeIs 0 emptyBag 40 + -- Ditto (augment t (\cn -> e) ys) should cost only the cost of + -- e plus ys. The -2 accounts for the \cn + +-- When we return a lambda, give a discount if it's used (applied) +lamScrutDiscount :: UnfoldingOpts -> ExprSize -> ExprSize +lamScrutDiscount opts (SizeIs n vs _) = SizeIs n vs (unfoldingFunAppDiscount opts) +lamScrutDiscount _ TooBig = TooBig + +{- +Note [addAltSize result discounts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When adding the size of alternatives, we *add* the result discounts +too, rather than take the *maximum*. For a multi-branch case, this +gives a discount for each branch that returns a constructor, making us +keener to inline. I did try using 'max' instead, but it makes nofib +'rewrite' and 'puzzle' allocate significantly more, and didn't make +binary sizes shrink significantly either. + +Note [Discounts and thresholds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Constants for discounts and thresholds are defined in 'UnfoldingOpts'. They are: + +unfoldingCreationThreshold + At a definition site, if the unfolding is bigger than this, we + may discard it altogether + +unfoldingUseThreshold + At a call site, if the unfolding, less discounts, is smaller than + this, then it's small enough inline + +unfoldingDictDiscount + The discount for each occurrence of a dictionary argument + as an argument of a class method. Should be pretty small + else big functions may get inlined + +unfoldingFunAppDiscount + Discount for a function argument that is applied. Quite + large, because if we inline we avoid the higher-order call. + +unfoldingVeryAggressive + If True, the compiler ignores all the thresholds and inlines very + aggressively. It still adheres to arity, simplifier phase control and + loop breakers. + + +Historical Note: Before April 2020 we had another factor, +ufKeenessFactor, which would scale the discounts before they were subtracted +from the size. This was justified with the following comment: + + -- We multiply the raw discounts (args_discount and result_discount) + -- ty opt_UnfoldingKeenessFactor because the former have to do with + -- *size* whereas the discounts imply that there's some extra + -- *efficiency* to be gained (e.g. beta reductions, case reductions) + -- by inlining. + +However, this is highly suspect since it means that we subtract a *scaled* size +from an absolute size, resulting in crazy (e.g. negative) scores in some cases +(#15304). We consequently killed off ufKeenessFactor and bumped up the +ufUseThreshold to compensate. + + +Note [Function applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a function application (f a b) + + - If 'f' is an argument to the function being analysed, + and there's at least one value arg, record a FunAppDiscount for f + + - If the application if a PAP (arity > 2 in this example) + record a *result* discount (because inlining + with "extra" args in the call may mean that we now + get a saturated application) + +Code for manipulating sizes +-} + +-- | The size of a candidate expression for unfolding +data ExprSize + = TooBig + | SizeIs { _es_size_is :: {-# UNPACK #-} !Int -- ^ Size found + , _es_args :: !(Bag (Id,Int)) + -- ^ Arguments cased herein, and discount for each such + , _es_discount :: {-# UNPACK #-} !Int + -- ^ Size to subtract if result is scrutinised by a case + -- expression + } + +instance Outputable ExprSize where + ppr TooBig = text "TooBig" + ppr (SizeIs a _ c) = brackets (int a <+> int c) + +-- subtract the discount before deciding whether to bale out. eg. we +-- want to inline a large constructor application into a selector: +-- tup = (a_1, ..., a_99) +-- x = case tup of ... +-- +mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize +mkSizeIs max n xs d | (n - d) > max = TooBig + | otherwise = SizeIs n xs d + +maxSize :: ExprSize -> ExprSize -> ExprSize +maxSize TooBig _ = TooBig +maxSize _ TooBig = TooBig +maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2 = s1 + | otherwise = s2 + +sizeZero :: ExprSize +sizeN :: Int -> ExprSize + +sizeZero = SizeIs 0 emptyBag 0 +sizeN n = SizeIs n emptyBag 0 diff --git a/GHC/Core/Unfold.hs-boot b/GHC/Core/Unfold.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/Unfold.hs-boot @@ -0,0 +1,15 @@ +module GHC.Core.Unfold where + +import GHC.Prelude + +data UnfoldingOpts + +defaultUnfoldingOpts :: UnfoldingOpts + +updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts +updateUseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts +updateFunAppDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts +updateDictDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts +updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts +updateCaseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts +updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts diff --git a/GHC/Core/Unfold/Make.hs b/GHC/Core/Unfold/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Unfold/Make.hs @@ -0,0 +1,508 @@ +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Unfolding creation +module GHC.Core.Unfold.Make + ( noUnfolding + , mkUnfolding + , mkCoreUnfolding + , mkFinalUnfolding + , mkFinalUnfolding' + , mkSimpleUnfolding + , mkWorkerUnfolding + , mkInlineUnfoldingWithArity, mkInlineUnfoldingNoArity + , mkInlinableUnfolding + , mkWrapperUnfolding + , mkCompulsoryUnfolding, mkCompulsoryUnfolding' + , mkDFunUnfolding + , mkDataConUnfolding + , specUnfolding + , certainlyWillInline + ) +where + +import GHC.Prelude +import GHC.Core +import GHC.Core.Unfold +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.Opt.Arity ( manifestArity ) +import GHC.Core.DataCon +import GHC.Core.Utils +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand ( DmdSig, isDeadEndSig ) + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import Data.Maybe ( fromMaybe ) + +-- the very simple optimiser is used to optimise unfoldings +import {-# SOURCE #-} GHC.Core.SimpleOpt + + + +mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Unfolding +-- "Final" in the sense that this is a GlobalId that will not be further +-- simplified; so the unfolding should be occurrence-analysed +mkFinalUnfolding opts src strict_sig expr = mkFinalUnfolding' opts src strict_sig expr Nothing + +-- See Note [Tying the 'CoreUnfolding' knot] for why interfaces need +-- to pass a precomputed 'UnfoldingCache' +mkFinalUnfolding' :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Maybe UnfoldingCache -> Unfolding +-- "Final" in the sense that this is a GlobalId that will not be further +-- simplified; so the unfolding should be occurrence-analysed +mkFinalUnfolding' opts src strict_sig expr + = mkUnfolding opts src + True {- Top level -} + (isDeadEndSig strict_sig) + False {- Not a join point -} + expr + +-- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first +mkCompulsoryUnfolding' :: SimpleOpts -> CoreExpr -> Unfolding +mkCompulsoryUnfolding' opts expr = mkCompulsoryUnfolding (simpleOptExpr opts expr) + +-- | Used for things that absolutely must be unfolded +mkCompulsoryUnfolding :: CoreExpr -> Unfolding +mkCompulsoryUnfolding expr + = mkCoreUnfolding CompulsorySrc True + expr Nothing + (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter + , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) + +-- Note [Top-level flag on inline rules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Slight hack: note that mk_inline_rules conservatively sets the +-- top-level flag to True. It gets set more accurately by the simplifier +-- Simplify.simplUnfolding. + +mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding +mkSimpleUnfolding !opts rhs + = mkUnfolding opts VanillaSrc False False False rhs Nothing + +mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding +mkDFunUnfolding bndrs con ops + | isUnaryClassDataCon con + = -- See (UCM5) in Note [Unary class magic] in GHC.Core.TyCon + mkDataConUnfolding $ + mkLams bndrs $ + mkApps (Var (dataConWrapId con)) ops + -- This application will satisfy the Core invariants + -- from Note [Representation polymorphism invariants] in GHC.Core, + -- because typeclass method types are never unlifted. + + | otherwise + = DFunUnfolding { df_bndrs = bndrs + , df_con = con + , df_args = map occurAnalyseExpr ops } + -- See Note [OccInfo in unfoldings and rules] in GHC.Core + +mkDataConUnfolding :: CoreExpr -> Unfolding +-- Used for non-newtype data constructors with non-trivial wrappers +mkDataConUnfolding expr + = mkCoreUnfolding StableSystemSrc True expr Nothing guide + -- No need to simplify the expression + where + guide = UnfWhen { ug_arity = manifestArity expr + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = inlineBoringOk expr } + -- inineBoringOk; sometimes wrappers are very simple, like + -- \@a p q. K @a p q + -- and then we definitely want to inline it #25713 + +mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding +-- Make the unfolding for the wrapper in a worker/wrapper split +-- after demand/CPR analysis +mkWrapperUnfolding opts expr arity + = mkCoreUnfolding StableSystemSrc True + (simpleOptExpr opts expr) Nothing + (UnfWhen { ug_arity = arity + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boringCxtNotOk }) + +mkWorkerUnfolding :: SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding +-- See Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap +mkWorkerUnfolding opts work_fn + (CoreUnfolding { uf_src = src, uf_tmpl = tmpl + , uf_is_top = top_lvl }) + | isStableSource src + = mkCoreUnfolding src top_lvl new_tmpl Nothing guidance + where + new_tmpl = simpleOptExpr opts (work_fn tmpl) + guidance = calcUnfoldingGuidance (so_uf_opts opts) False False new_tmpl + +mkWorkerUnfolding _ _ _ = noUnfolding + +-- | Make an INLINE unfolding that may be used unsaturated +-- (ug_unsat_ok = unSaturatedOk) and that is reported as having its +-- manifest arity (the number of outer lambdas applications will +-- resolve before doing any work). +mkInlineUnfoldingNoArity :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding +mkInlineUnfoldingNoArity opts src expr + = mkCoreUnfolding src + True -- Note [Top-level flag on inline rules] + expr' Nothing guide + where + expr' = simpleOptExpr opts expr + guide = UnfWhen { ug_arity = manifestArity expr' + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boring_ok } + boring_ok = inlineBoringOk expr' + +-- | Make an INLINE unfolding that will be used once the RHS has been saturated +-- to the given arity. +mkInlineUnfoldingWithArity :: SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding +mkInlineUnfoldingWithArity opts src arity expr + = mkCoreUnfolding src + True -- Note [Top-level flag on inline rules] + expr' Nothing guide + where + expr' = simpleOptExpr opts expr + guide = UnfWhen { ug_arity = arity + , ug_unsat_ok = needSaturated + , ug_boring_ok = boring_ok } + -- See Note [INLINE pragmas and boring contexts] as to why we need to look + -- at the arity here. + boring_ok | arity == 0 = True + | otherwise = inlineBoringOk expr' + +mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding +mkInlinableUnfolding opts src expr + = mkUnfolding (so_uf_opts opts) src False False False expr' Nothing + where + expr' = simpleOptExpr opts expr + +specUnfolding :: SimpleOpts + -> [Var] -> (CoreExpr -> CoreExpr) + -> [CoreArg] -- LHS arguments in the RULE + -> Unfolding -> Unfolding +-- See Note [Specialising unfoldings] +-- specUnfolding spec_bndrs spec_args unf +-- = \spec_bndrs. unf spec_args +-- +specUnfolding opts spec_bndrs spec_app rule_lhs_args + df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args }) + = assertPpr (rule_lhs_args `equalLength` old_bndrs) + (ppr df $$ ppr rule_lhs_args) $ + -- For this ASSERT see Note [Specialising DFuns] in GHC.Core.Opt.Specialise + mkDFunUnfolding spec_bndrs con (map spec_arg args) + -- For DFunUnfoldings we transform + -- \obs. MkD ... + -- to + -- \sbs. MkD ((\obs. ) spec_args) ... ditto + where + spec_arg arg = simpleOptExpr opts $ + spec_app (mkLams old_bndrs arg) + -- The beta-redexes created by spec_app will be + -- simplified away by simplOptExpr + -- ToDo: this is VERY DELICATE for type args. We make + -- (\@a @b x y. TYPE ty) ty1 ty2 d1 d2 + -- and rely on it simplifying to ty[ty1/a, ty2/b] + +specUnfolding opts spec_bndrs spec_app rule_lhs_args + (CoreUnfolding { uf_src = src, uf_tmpl = tmpl + , uf_is_top = top_lvl + , uf_guidance = old_guidance }) + | isStableSource src -- See Note [Specialising unfoldings] + , UnfWhen { ug_arity = old_arity } <- old_guidance + = mkCoreUnfolding src top_lvl new_tmpl Nothing + (old_guidance { ug_arity = old_arity - arity_decrease }) + where + new_tmpl = simpleOptExpr opts $ + mkLams spec_bndrs $ + spec_app tmpl -- The beta-redexes created by spec_app + -- will be simplified away by simplOptExpr + arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs + + +specUnfolding _ _ _ _ _ = noUnfolding + +{- Note [Specialising unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise a function for some given type-class arguments, we use +specUnfolding to specialise its unfolding. Some important points: + +* If the original function has a DFunUnfolding, the specialised one + must do so too! Otherwise we lose the magic rules that make it + interact with ClassOps + +* For a /stable/ CoreUnfolding, we specialise the unfolding, no matter + how big, iff it has UnfWhen guidance. This happens for INLINE + functions, and for wrappers. For these, it would be very odd if a + function marked INLINE was specialised (because of some local use), + and then forever after (including importing modules) the specialised + version wasn't INLINEd! After all, the programmer said INLINE. + +* However, for a stable CoreUnfolding with guidance UnfoldIfGoodArgs, + which arises from INLINABLE functions, we drop the unfolding. + See #4874 for persuasive examples. Suppose we have + {-# INLINABLE f #-} + f :: Ord a => [a] -> Int f xs = letrec f' = ...f'... in f' + + Then, when f is specialised and optimised we might get + wgo :: [Int] -> Int# + wgo = ...wgo... + f_spec :: [Int] -> Int + f_spec xs = case wgo xs of { r -> I# r } + + and we clearly want to inline f_spec at call sites. But if we still + have the big, un-optimised of f (albeit specialised) captured in the + stable unfolding for f_spec, we won't get that optimisation. + + This happens with Control.Monad.liftM3, and can cause a lot more + allocation as a result (nofib n-body shows this). + + Moreover, keeping the stable unfolding isn't much help, because + the specialised function (probably) isn't overloaded any more. + + TL;DR: we simply drop the stable unfolding when specialising. It's not + really a complete solution; ignoring specialisation for now, INLINABLE + functions don't get properly strictness analysed, for example. + Moreover, it means that the specialised function has an INLINEABLE + pragma, but no stable unfolding. But it works well for examples + involving specialisation, which is the dominant use of INLINABLE. + +Note [Honour INLINE on 0-ary bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + x = + {-# INLINE x #-} + + f y = ...x... + +The semantics of an INLINE pragma is + + inline x at every call site, provided it is saturated; + that is, applied to at least as many arguments as appear + on the LHS of the Haskell source definition. + +(This source-code-derived arity is stored in the `ug_arity` field of +the `UnfoldingGuidance`.) + +In the example, x's ug_arity is 0, so we should inline it at every use +site. It's rare to have such an INLINE pragma (usually INLINE is on +functions), but it's occasionally very important (#15578, #15519). +In #15519 we had something like + x = case (g a b) of I# r -> T r + {-# INLINE x #-} + f y = ...(h x).... + +where h is strict. So we got + f y = ...(case g a b of I# r -> h (T r))... + +and that in turn allowed SpecConstr to ramp up performance. + +How do we deliver on this? By adjusting the ug_boring_ok +flag in mkInlineUnfoldingWithArity; see +Note [INLINE pragmas and boring contexts] + +NB: there is a real risk that full laziness will float it right back +out again. Consider again + x = factorial 200 + {-# INLINE x #-} + f y = ...x... + +After inlining we get + f y = ...(factorial 200)... + +but it's entirely possible that full laziness will do + lvl23 = factorial 200 + f y = ...lvl23... + +That's a problem for another day. + +Note [INLINE pragmas and boring contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An INLINE pragma uses mkInlineUnfoldingWithArity to build the +unfolding. That sets the ug_boring_ok flag to False if the function +is not tiny (inlineBoringOK), so that even INLINE functions are not +inlined in an utterly boring context. E.g. + \x y. Just (f y x) +Nothing is gained by inlining f here, even if it has an INLINE +pragma. + +But for 0-ary bindings, we want to inline regardless; see +Note [Honour INLINE on 0-ary bindings]. + +I'm a bit worried that it's possible for the same kind of problem +to arise for non-0-ary functions too, but let's wait and see. +-} + +mkUnfolding :: UnfoldingOpts + -> UnfoldingSource + -> Bool -- Is top-level + -> Bool -- Definitely a bottoming binding + -- (only relevant for top-level bindings) + -> Bool -- True <=> join point + -> CoreExpr + -> Maybe UnfoldingCache + -> Unfolding +-- Calculates unfolding guidance +-- Occurrence-analyses the expression before capturing it +mkUnfolding opts src top_lvl is_bottoming is_join expr cache + = mkCoreUnfolding src top_lvl expr cache guidance + where + is_top_bottoming = top_lvl && is_bottoming + guidance = calcUnfoldingGuidance opts is_top_bottoming is_join expr + -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))! + -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] + +mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr + -> Maybe UnfoldingCache -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding src top_lvl expr precomputed_cache guidance + = CoreUnfolding { uf_tmpl = cache `seq` + occurAnalyseExpr expr + -- occAnalyseExpr: see Note [OccInfo in unfoldings and rules] in GHC.Core + -- See #20905 for what a discussion of this 'seq'. + -- We are careful to make sure we only + -- have one copy of an unfolding around at once. + -- Note [Thoughtful forcing in mkCoreUnfolding] + + , uf_src = src + , uf_is_top = top_lvl + , uf_cache = cache + , uf_guidance = guidance } + where + is_value = exprIsHNF expr + is_conlike = exprIsConLike expr + is_work_free = exprIsWorkFree expr + is_expandable = exprIsExpandable expr + + recomputed_cache = UnfoldingCache { uf_is_value = is_value + , uf_is_conlike = is_conlike + , uf_is_work_free = is_work_free + , uf_expandable = is_expandable } + + cache = fromMaybe recomputed_cache precomputed_cache + +---------------- +certainlyWillInline :: UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding +-- ^ Sees if the unfolding is pretty certain to inline. +-- If so, return a *stable* unfolding for it, that will always inline. +-- The CoreExpr is the WW'd and simplified RHS. In contrast, the unfolding +-- template might not have been WW'd yet. +certainlyWillInline opts fn_info rhs' + = case fn_unf of + CoreUnfolding { uf_guidance = guidance, uf_src = src } + | noinline -> Nothing -- See Note [Worker/wrapper for NOINLINE functions] + | otherwise + -> case guidance of + UnfNever -> Nothing + UnfWhen {} -> Just (fn_unf { uf_src = src', uf_tmpl = tmpl' }) + -- INLINE functions have UnfWhen + UnfIfGoodArgs { ug_size = size, ug_args = args } + -> do_cunf size args src' tmpl' + where + src' | isCompulsorySource src = src -- Do not change InlineCompulsory! + | otherwise = StableSystemSrc + + tmpl' | isStableSource src = uf_tmpl fn_unf + | otherwise = occurAnalyseExpr rhs' + -- Do not overwrite stable unfoldings! + + DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense + -- to do so, and even if it is currently a + -- loop breaker, it may not be later + + _other_unf -> Nothing + + where + noinline = isNoInlinePragma (inlinePragInfo fn_info) + fn_unf = unfoldingInfo fn_info -- NB: loop-breakers never inline + + -- The UnfIfGoodArgs case seems important. If we w/w small functions + -- binary sizes go up by 10%! (This is with SplitObjs.) + -- I'm not totally sure why. + -- INLINABLE functions come via this path + -- See Note [certainlyWillInline: INLINABLE] + do_cunf size args src' tmpl' + | arityInfo fn_info > 0 -- See Note [certainlyWillInline: be careful of thunks] + , not (isDeadEndSig (dmdSigInfo fn_info)) + -- Do not unconditionally inline a bottoming functions even if + -- it seems smallish. We've carefully lifted it out to top level, + -- so we don't want to re-inline it. + , let unf_arity = length args + , size - (10 * (unf_arity + 1)) <= unfoldingUseThreshold opts + = Just (fn_unf { uf_src = src' + , uf_tmpl = tmpl' + , uf_guidance = UnfWhen { ug_arity = unf_arity + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = inlineBoringOk tmpl' } }) + -- Note the "unsaturatedOk". A function like f = \ab. a + -- will certainly inline, even if partially applied (f e), so we'd + -- better make sure that the transformed inlining has the same property + | otherwise + = Nothing + +{- Note [certainlyWillInline: be careful of thunks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't claim that thunks will certainly inline, because that risks work +duplication. Even if the work duplication is not great (eg is_cheap +holds), it can make a big difference in an inner loop In #5623 we +found that the WorkWrap phase thought that + y = case x of F# v -> F# (v +# v) +was certainlyWillInline, so the addition got duplicated. + +Note that we check arityInfo instead of the arity of the unfolding to detect +this case. This is so that we don't accidentally fail to inline small partial +applications, like `f = g 42` (where `g` recurses into `f`) where g has arity 2 +(say). Here there is no risk of work duplication, and the RHS is tiny, so +certainlyWillInline should return True. But `unf_arity` is zero! However f's +arity, gotten from `arityInfo fn_info`, is 1. + +Failing to say that `f` will inline forces W/W to generate a potentially huge +worker for f that will immediately cancel with `g`'s wrapper anyway, causing +unnecessary churn in the Simplifier while arriving at the same result. + +Note [certainlyWillInline: INLINABLE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +certainlyWillInline /must/ return Nothing for a large INLINABLE thing, +even though we have a stable inlining, so that strictness w/w takes +place. It makes a big difference to efficiency, and the w/w pass knows +how to transfer the INLINABLE info to the worker; see WorkWrap +Note [Worker/wrapper for INLINABLE functions] + +Note [Thoughtful forcing in mkCoreUnfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Core expressions retained in unfoldings is one of biggest uses of memory when compiling +a program. Therefore we have to be careful about retaining copies of old or redundant +templates (see !6202 for a particularly bad case). + +With that in mind we want to maintain the invariant that each unfolding only references +a single CoreExpr. One place where we have to be careful is in mkCoreUnfolding. + +* The template of the unfolding is the result of performing occurrence analysis + (Note [OccInfo in unfoldings and rules] in GHC.Core) +* Predicates are applied to the unanalysed expression + +Therefore if we are not thoughtful about forcing you can end up in a situation where the +template is forced but not all the predicates are forced so the unfolding will retain +both the old and analysed expressions. + +I investigated this using ghc-debug and it was clear this situation did often arise: + +``` +(["ghc:GHC.Core:Lam","ghc-prim:GHC.Types:True","THUNK_1_0","THUNK_1_0","THUNK_1_0"],Count 4307) +``` + +Here the predicates are unforced but the template is forced. + +Therefore we basically had two options in order to fix this: + +1. Perform the predicates on the analysed expression. +2. Force the predicates to remove retainer to the old expression if we force the template. + +Option 1 is bad because occurrence analysis is expensive and destroys any sharing of the unfolding +with the actual program. (Testing this approach showed peak 25G memory usage) + +Therefore we got for Option 2 which performs a little more work but compensates by +reducing memory pressure. + +The result of fixing this led to a 1G reduction in peak memory usage (12G -> 11G) when +compiling a very large module (peak 3 million terms). For more discussion see #20905. +-} diff --git a/GHC/Core/Unify.hs b/GHC/Core/Unify.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Unify.hs @@ -0,0 +1,2541 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf #-} + +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Core.Unify ( + tcMatchTy, tcMatchTyKi, + tcMatchTys, tcMatchTyKis, + tcMatchTyX, tcMatchTysX, tcMatchTyKisX, + tcMatchTyX_BM, ruleMatchTyKiX, + + -- Side-effect free unification + tcUnifyTy, tcUnifyTys, tcUnifyFunDeps, tcUnifyDebugger, + tcUnifyTysFG, tcUnifyTyForInjectivity, + BindTvFun, BindFamFun, BindFlag(..), + matchBindTv, alwaysBindTv, alwaysBindFam, dontCareBindFam, + UnifyResult, UnifyResultM(..), MaybeApartReason(..), + typesCantMatch, typesAreApart, + + -- Matching a type against a lifted type (coercion) + liftCoMatch + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey ) +import GHC.Core.Type hiding ( getTvSubstEnv ) +import GHC.Core.Coercion hiding ( getCvSubstEnv ) +import GHC.Core.Predicate( scopedSort ) +import GHC.Core.TyCon +import GHC.Core.Predicate( CanEqLHS(..), canEqLHS_maybe ) +import GHC.Core.TyCon.Env +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare ( eqType, tcEqType, tcEqTyConAppArgs ) +import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) +import GHC.Core.TyCo.Subst ( mkTvSubst ) +import GHC.Core.Map.Type +import GHC.Core.Multiplicity + +import GHC.Utils.FV( FV, fvVarList ) +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Types.Basic( SwapFlag(..) ) +import GHC.Types.Unique.FM +import GHC.Exts( oneShot ) +import GHC.Utils.Panic + +import GHC.Data.Pair +import GHC.Data.TrieMap +import GHC.Data.Maybe( orElse ) + +import Control.Monad +import qualified Data.Semigroup as S +import GHC.Builtin.Types.Prim (fUNTyCon) + +{- Note [The Core unifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module contains the (pure) unifier two types. It is subtle in a number +of ways. Here we summarise, but see Note [Specification of unification]. + +(CU1) It creates a substition only for "bindable" or "template" type variables. + These are identified by a `um_bind_tv_fun` function passed down in the `UMEnv` + environment. + +(CU2) We want to match in the presence of foralls; + e.g (forall a. t1) ~ (forall b. t2) + That is what the `um_rn_env :: RnEnv2` field of `UMEnv` is for; it does the + alpha-renaming that makes it as if `a` and `b` were the same variable. + Initialising the `RnEnv2`, so that it can generate a fresh binder when + necessary, entails knowing the free variables of both types. + + Of course, we must be careful not to bind a template type variable to a + locally bound variable. E.g. + (forall a. x) ~ (forall b. b) + where `x` is the template type variable. Then we do not want to + bind `x` to a/b! See `mentionsForAllBoundTyVarsL/R`. + +(CU3) We want to take special care for type families. + See the big Note [Apartness and type families] + +(CU4) Rather than returning just "unifiable" or "not-unifiable" we do "fine-grained" + unification (hence "fg" or "FG" in this module) returning three possiblities, + captured in `UnifyResult`: + - Unifiable subst : certainly unifiable with this type substitution + - SurelyApart : cannot be unifiable, regardless of how type familes reduce + - MaybeApart : neither of the above + See Note [Unification result]. + + Four reasons for MaybeApart (see `MaybeApartReason`). The first two are the + big ones! + * MARTypeFamily: + Family reduction might make the two types equal + Maybe (F Int) ~ Maybe Bool + See Note [Apartness and type families] + * MARInfinite (occurs check): + See Note [Infinitary substitutions] + * MARTypeVsConstraint: + See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim + * MARCast (obscure): + See (KCU2) in Note [Kind coercions in Unify] + +(CU5) We need to take care with kinds. See Note [tcMatchTy vs tcMatchTyKi] + +(CU6) The "unifier" can also do /matching/, governed by `um_unif :: AmIUnifying`. + When matching, the LHS and RHS namespaces are unrelated. In particular, the + bindable type variable can occur (unrelatedly) in the RHS. E.g. + match (a,Maybe a) ~ ([a], Maybe [a]) + We get the substitution [a :-> [a]], without confusing the + LHS `a` with the RHS `a`. The substitition is "one-shot", and should not be + iterated. + +Note [Infinitary substitutions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- +no substitution to finite types makes these match. This is the famous +"occurs check". + +But, a substitution to *infinite* types can unify these two types: + [x |-> [[...]]], y |-> [[[...]]] ]. + +Why do we care? Consider these two type family instances: + + type instance F x x = Int + type instance F [y] y = Bool + +If we also have + + type instance Looper = [Looper] + +then the instances potentially overlap -- they are not "apart". So we must +distinguish failure-to-unify from definitely-apart. The solution is to use +unification over infinite terms. This is possible (see [1] for lots of gory +details), but a full algorithm is a little more powerful than we need. Instead, +we make a conservative approximation and just omit the occurs check. + + [1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf + +tcUnifyTys considers an occurs-check problem as the same as general unification +failure. + +See also #8162. + +It's worth noting that unification in the presence of infinite types is not +complete. This means that, sometimes, a closed type family does not reduce +when it should. See test case indexed-types/should_fail/Overlap15 for an +example. + +Note [tcMatchTy vs tcMatchTyKi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module offers two variants of matching: with kinds and without. +The TyKi variant takes two types, of potentially different kinds, +and matches them. Along the way, it necessarily also matches their +kinds. The Ty variant instead assumes that the kinds are already +eqType and so skips matching up the kinds. + +How do you choose between them? + +1. If you know that the kinds of the two types are eqType, use + the Ty variant. It is more efficient, as it does less work. + +2. If the kinds of variables in the template type might mention type families, + use the Ty variant (and do other work to make sure the kinds + work out). These pure unification functions do a straightforward + syntactic unification and do no complex reasoning about type + families. Note that the types of the variables in instances can indeed + mention type families, so instance lookup must use the Ty variant. + + (Nothing goes terribly wrong -- no panics -- if there might be type + families in kinds in the TyKi variant. You just might get match + failure even though a reducing a type family would lead to success.) + +3. Otherwise, if you're sure that the variable kinds do not mention + type families and you're not already sure that the kind of the template + equals the kind of the target, then use the TyKi version. + +Note [Unification result] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See `UnifyResult` and `UnifyResultM`. When unifying t1 ~ t2, we return +* Unifiable s, if s is a substitution such that s(t1) is syntactically the + same as s(t2), modulo type-synonym expansion. +* SurelyApart, if there is no substitution s such that s(t1) = s(t2), + where "=" includes type-family reductions. +* MaybeApart mar s, when we aren't sure. `mar` is a MaybeApartReason. + +Examples +* [a] ~ Maybe b: SurelyApart, because [] and Maybe can't unify + +* [(a,Int)] ~ [(Bool,b)]: Unifiable + +* [F Int] ~ [Bool]: MaybeApart MARTypeFamily, because F Int might reduce to Bool + (the unifier does not try this) + +* a ~ Maybe a: MaybeApart MARInfinite. Not Unifiable clearly, but not SurelyApart + either; consider + a := Loop + where type family Loop where Loop = Maybe Loop + +Wrinkle (UR1): see `combineMAR` + There is the possibility that two types are MaybeApart for *both* reasons: + + * (a, F Int) ~ (Maybe a, Bool) + + What reason should we use? The *only* consumer of the reason is described + in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv. The goal + there is identify which instances might match a target later (but don't + match now) -- except that we want to ignore the possibility of infinitary + substitutions. So let's examine a concrete scenario: + + class C a b c + instance C a (Maybe a) Bool + -- other instances, including one that will actually match + [W] C b b (F Int) + + Do we want the instance as a future possibility? No. The only way that + instance can match is in the presence of an infinite type (infinitely nested + Maybes). We thus say that `MARInfinite` takes precedence, so that InstEnv treats + this case as an infinitary substitution case; the fact that a type family is + involved is only incidental. We thus define `combineMAR` to prefer + `MARInfinite`. + +Note [Apartness and type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + type family F a b where + F Int Bool = Char + F a b = Double + type family G a -- open, no instances + +How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't +match immediately while the second equation does. But, before reducing, we must +make sure that the target can never become (F Int Bool). Well, no matter what G +Float becomes, it certainly won't become *both* Int and Bool, so indeed we're +safe reducing (F (G Float) (G Float)) to Double. + +So we must say that the argument list + (G Float) (G Float) is SurelyApart from Int Bool + +This is necessary not only to get more reductions (which we might be willing to +give up on), but for /substitutivity/. If we have (F x x), we can see that (F x x) +can reduce to Double. So, it had better be the case that (F blah blah) can +reduce to Double, no matter what (blah) is! + +To achieve this, `go` in `uVarOrFam` does this; + +* We maintain /two/ substitutions, not just one: + * um_tv_env: the regular substitution, mapping TyVar :-> Type + * um_fam_env: maps (TyCon,[Type]) :-> Type, where the LHS is a type-fam application + In effect, these constitute one substitution mapping + CanEqLHS :-> Types + +* When we attempt to unify (G Float) ~ Int, we return MaybeApart.. + but we /also/ add a "family substitution" [G Float :-> Int], + to `um_fam_env`. See the `BindMe` case of `go` in `uVarOrFam`. + +* When we later encounter (G Float) ~ Bool, we apply the family substitution, + very much as we apply the conventional [tyvar :-> type] substitution + when we encounter a type variable. See the `lookupFamEnv` in `go` in + `uVarOrFam`. + + So (G Float ~ Bool) becomes (Int ~ Bool) which is SurelyApart. Bingo. + + +Wrinkles + +(ATF0) Once we encounter a type-family application, we only ever return + MaybeApart or SurelyApart + but never `Unifiable`. Accordingly, we only return a TyCoVar substitution + from `tcUnifyTys` and friends; we don't return a type-family substitution as + well. (We could imagine doing so, though.) + +(ATF1) Exactly the same mechanism is used in class-instance checking. + If we have + instance C (Maybe b) + instance {-# OVERLAPPING #-} C (Maybe Bool) + [W] C (Maybe (F a)) + we want to know that the second instance might match later, when we know more about `a`. + The function `GHC.Core.InstEnv.instEnvMatchesAndUnifiers` uses `tcUnifyTysFG` to + account for type families in the type being matched. + +(ATF2) A very similar check is made in `GHC.Tc.Utils.Unify.mightEqualLater`, which + again uses `tcUnifyTysFG` to account for the possibility of type families. See + Note [What might equal later?] in GHC.Tc.Utils.Unify, esp example (10). + +(ATF3) What about foralls? For example, supppose we are unifying + (forall a. F a) -> (forall a. F a) + against some other type. Those two (F a) types are unrelated, bound by + different foralls; we cannot extend the um_fam_env with a binding [F a :-> blah] + + So to keep things simple, the entire family-substitution machinery is used + only if there are no enclosing foralls (see the `under_forall` check in + `uSatFamApp`). That's fine, because the apartness business is used only for + reducing type-family applications, and class instances, and their arguments + can't have foralls anyway. + + The bottom line is that we won't discover that + (forall a. (a, F Int, F Int)) + is surely apart from + (forall a. (a, Int, Bool)) + but that doesn't matter. Fixing this would be possible, but would require + quite a bit of head-scratching. + +(ATF4) The family substitution only has /saturated/ family applications in + its domain. Consider the following concrete example from #16995: + + type family Param :: Type -> Type -- arity 0 + + type family LookupParam (a :: Type) :: Type where + LookupParam (f Char) = Bool + LookupParam x = Int + + foo :: LookupParam (Param ()) + foo = 42 + + In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to + `Int`. So (f Char) ~ (Param ()) must be SurelyApart. Remember, since + `Param` is a nullary type family, it is over-saturated in (Param ()). + This unification will only be SurelyApart if we decompose the outer AppTy + separately, to then give (() ~ Char). + + Not only does this allow more programs to be accepted, it's also important + for correctness. Not doing this was the root cause of the Core Lint error + in #16995. + +(ATF5) Consider + instance (Generic1 f, Ord (Rep1 f a)) + => Ord (Generically1 f a) where ... + -- The "..." gives rise to [W] Ord (Generically1 f a) + where Rep1 is a type family. + + We must use the instance decl (recursively) to simplify the [W] constraint; + we do /not/ want to worry that the `[G] Ord (Rep1 f a)` might be an + alternative path. So `noMatchableGivenDicts` must return False; + so `mightMatchLater` must return False; so when um_bind_fam_fun returns + `DontBindMe`, the unifier must return `SurelyApart`, not `MaybeApart`. See + `go` in `uVarOrFam` + + This looks a bit sketchy, because they aren't SurelyApart, but see + Note [What might equal later?] in GHC.Tc.Utils.Unify, esp "Red Herring". + + If we are under a forall, we return `MaybeApart`; that seems more conservative, + and class constraints are on tau-types so it doesn't matter. + +(ATF6) When /matching/ can we ever have a type-family application on the LHS, in + the template? You might think not, because type-class-instance and + type-family-instance heads can't include type families. E.g. + instance C (F a) where ... -- Illegal + + But you'd be wrong: even when matching, we can see type families in the LHS template: + * In `checkValidClass`, in `check_dm` we check that the default method has the + right type, using matching, both ways. And that type may have type-family + applications in it. Examples in test CoOpt_Singletons and T26457. + + * In the specialiser: see the call to `tcMatchTy` in + `GHC.Core.Opt.Specialise.beats_or_same` + + * With -fpolymorphic-specialisation, we might get a specialiation rule like + RULE forall a (d :: Eq (Maybe (F a))) . + f @(Maybe (F a)) d = ... + See #25965. + + * A user-written RULE could conceivably have a type-family application + in the template. It might not be a good rule, but I don't think we currently + check for this. + + In all these cases we are only interested in finding a substitution /for + type variables/ that makes the match work. So we simply want to recurse into + the arguments of the type family. E.g. + Template: forall a. Maybe (F a) + Target: Maybe (F Int) + We want to succeed with substitution [a :-> Int]. See (ATF9). + + Conclusion: where we enter via `tcMatchTy`, `tcMatchTys`, `tc_match_tys`, + etc, we always end up in `tc_match_tys_x`. There we invoke the unifier + but we do not distinguish between `SurelyApart` and `MaybeApart`. So in + these cases we can set `um_bind_fam_fun` to `neverBindFam`. + +(ATF7) There is one other, very special case of matching where we /do/ want to + bind type families in `um_fam_env`, namely in GHC.Tc.Solver.Equality, the call + to `tcUnifyTyForInjectivity False` in `improve_injective_wanted_top`. + Consider + of a match. Consider + type family G6 a = r | r -> a + type instance G6 [a] = [G a] + type instance G6 Bool = Int + and suppose we have a Wanted constraint + [W] G6 alpha ~ [Int] + According to Section 5.2 of "Injective type families for Haskell", we /match/ + the RHS each of type instance with [Int]. So we try + Template: [G a] Target: [Int] + and we want to succeed with MaybeApart, so that we can generate the improvement + constraint + [W] alpha ~ [beta] + where beta is fresh. We do this by binding [G a :-> Int] + +(ATF8) The treatment of type families is governed by + um_bind_fam_fun :: BindFamFun + in UMEnv, where + type BindFamFun = TyCon -> [Type] -> Type -> BindFlag + There are some simple BindFamFun functions provided: + alwaysBindFam do the clever stuff above + neverBindFam treat type families as SurelyApart + dontCareBindFam type families shouldn't exist at all + This function only affects the difference between the results MaybeApart and + SurelyApart; it never does not affect whether or not we return Unifiable. + +(ATF9) Decomposition. Consider unifying + F a ~ F Int + when `um_bind_fam_fun` says DontBindMe. There is a unifying substitition [a :-> Int], + and we want to find it, returning Unifiable. Why? + - Remember, this is the Core unifier -- we are not doing type inference + - When we have two equal types, like F a ~ F a, it is ridiculous to say that they + are MaybeApart. Example: the two-way tcMatchTy in `checkValidClass` and #26457. + + (ATF9-1) But consider unifying + F Int ~ F Bool + Although Int and Bool are SurelyApart, we must return MaybeApart for the outer + unification. Hence the use of `don'tBeSoSure` in `go_fam_fam`; it leaves Unifiable + alone, but weakens `SurelyApart` to `MaybeApart`. + + (ATF9-2) We want this decomposition to occur even under a forall (this was #26457). + E.g. (forall a. F Int) -> Int ~ (forall a. F Int) ~ Int + + +(ATF10) Injectivity. Consider (AFT9) where F is known to be injective. Then if we + are unifying + F Int ~ F Bool + we /can/ say SurelyApart. See the inj/noninj stuff in `go_fam_fam`. + +(ATF11) Consider unifying + [F Int, F Int, F Bool] ~ [F Bool, Char, Double] + We find (F Int ~ F Bool), so we can decompose. But we /also/ want to remember + the substitution [F Int :-> F Bool]. Then from (F Int ~ Char) we get the + substitution [F Bool :-> Char]. And that flat-out contradicts (F Bool ~ Double) + so we should get SurelyApart. + + Key point: when decomposing (F tys1 ~ F tys2), we should /also/ extend the + type-family substitution. + + (ATF11-1) All this cleverness only matters when unifying, not when matching + +(ATF12) There is a horrid exception for the injectivity check. See (UR1) in + in Note [Specification of unification]. + +(ATF13) We have to be careful about the occurs check. + See Note [The occurs check in the Core unifier] + +SIDE NOTE. The paper "Closed type families with overlapping equations" +http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf +tries to achieve the same effect with a standard yes/no unifier, by "flattening" +the types (replacing each type-family application with a fresh type variable) +and then unifying. But that does not work well. Consider (#25657) + + type MyEq :: k -> k -> Bool + type family MyEq a b where + MyEq a a = 'True + MyEq _ _ = 'False + + type Var :: forall {k}. Tag -> k + type family Var tag = a | a -> tag + +Then, because Var is injective, we want + MyEq (Var A) (Var B) --> False + MyEq (Var A) (Var A) --> True + +But if we flattten the types (Var A) and (Var B) we'll just get fresh type variables, +and all is lost. But with the current algorithm we have that + a a ~ (Var A) (Var B) +is SurelyApart, so the first equation definitely doesn't match and we can try the +second, which does. END OF SIDE NOTE. + +Note [Shortcomings of the apartness test] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Apartness and type families] is very clever. + +But it still has shortcomings (#26358). Consider unifying + [F a, F Int, Int] ~ [Bool, Char, a] +Working left to right you might think we would build the mapping + F a :-> Bool + F Int :-> Char +Now we discover that `a` unifies with `Int`. So really these two lists are Apart +because F Int can't be both Bool and Char. + +Just the same applies when adding a type-family binding to um_fam_env: + [F (G Float), F Int, G Float] ~ [Bool, Char, Iont] +Again these are Apart, because (G Float = Int), +and (F Int) can't be both Bool and Char + +But achieving this is very tricky! Perhaps whenever we unify a type variable, +or a type family, we should run it over the domain and (maybe range) of the +type-family mapping too? Sigh. + +For now we make no such attempt. +* The um_fam_env has only /un-substituted/ types. +* We look up only /un-substituted/ types in um_fam_env + +This may make us say MaybeApart when we could say SurelyApart, but it has no +effect on the correctness of unification: if we return Unifiable, it really is +Unifiable. + +This is all quite subtle. suppose we have: + um_tv_env: c :-> b + um_fam_env F b :-> a +and we are trying to add a :-> F c. We will call lookupFamEnv on (F, [c]), which will +fail because b and c are not equal. So we go ahead and add a :-> F c as a new tyvar eq, +getting: + um_tv_env: a :-> F c, c :-> b + um_fam_env F b :-> a + +Does that loop, like this: + a --> F c --> F b --> a? +No, because we do not substitute (F c) to (F b) and then look up in um_fam_env; +we look up only un-substituted types. +-} + +{- ********************************************************************* +* * + Binding decisions +* * +********************************************************************* -} + +data BindFlag + = BindMe -- ^ A bindable type variable + + | DontBindMe -- ^ Do not bind this type variable is /apart/ + -- See also Note [Super skolems: binding when looking up instances] + -- in GHC.Core.InstEnv. + deriving Eq + +-- | Some unification functions are parameterised by a 'BindTvFun', which +-- says whether or not to allow a certain unification to take place. +-- A 'BindTvFun' takes the 'TyVar' involved along with the 'Type' it will +-- potentially be bound to. +-- +-- It is possible for the variable to actually be a coercion variable +-- (Note [Matching coercion variables]), but only when one-way matching. +-- In this case, the 'Type' will be a 'CoercionTy'. +type BindTvFun = TyCoVar -> Type -> BindFlag + +-- | BindFamFun is similiar to BindTvFun, but deals with a saturated +-- type-family application. See Note [Apartness and type families]. +type BindFamFun = TyCon -> [Type] -> Type -> BindFlag + +-- | Allow binding only for any variable in the set. Variables may +-- be bound to any type. +-- Used when doing simple matching; e.g. can we find a substitution +-- +-- @ +-- S = [a :-> t1, b :-> t2] such that +-- S( Maybe (a, b->Int ) = Maybe (Bool, Char -> Int) +-- @ +matchBindTv :: TyCoVarSet -> BindTvFun +matchBindTv tvs tv _ty + | tv `elemVarSet` tvs = BindMe + | otherwise = DontBindMe + +-- | Allow the binding of any variable to any type +alwaysBindTv :: BindTvFun +alwaysBindTv _tv _ty = BindMe + +-- | Allow the binding of a type-family application to any type +alwaysBindFam :: BindFamFun +-- See (ATF8) in Note [Apartness and type families] +alwaysBindFam _tc _args _rhs = BindMe + +dontCareBindFam :: HasCallStack => BindFamFun +-- See (ATF8) in Note [Apartness and type families] +dontCareBindFam tc args rhs + = pprPanic "dontCareBindFam" $ + vcat [ ppr tc <+> ppr args, text "rhs" <+> ppr rhs ] + +-- | Don't allow the binding of a type-family application at all +neverBindFam :: BindFamFun +-- See (ATF8) in Note [Apartness and type families] +neverBindFam _tc _args _rhs = DontBindMe + + +{- ********************************************************************* +* * + Various wrappers for matching +* * +********************************************************************* -} + +-- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) +-- @s@ such that @s(t1)@ equals @t2@. +-- The returned substitution might bind coercion variables, +-- if the variable is an argument to a GADT constructor. +-- +-- Precondition: typeKind ty1 `eqType` typeKind ty2 +-- +-- We don't pass in a set of "template variables" to be bound +-- by the match, because tcMatchTy (and similar functions) are +-- always used on top-level types, so we can bind any of the +-- free variables of the LHS. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTy :: HasDebugCallStack => Type -> Type -> Maybe Subst +tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] + +tcMatchTyX_BM :: HasDebugCallStack + => BindTvFun -> Subst + -> Type -> Type -> Maybe Subst +tcMatchTyX_BM bind_tv subst ty1 ty2 + = tc_match_tys_x bind_tv False subst [ty1] [ty2] + +-- | Like 'tcMatchTy', but allows the kinds of the types to differ, +-- and thus matches them as well. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKi :: HasDebugCallStack => Type -> Type -> Maybe Subst +tcMatchTyKi ty1 ty2 + = tc_match_tys alwaysBindTv True [ty1] [ty2] + +-- | This is similar to 'tcMatchTy', but extends a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyX :: HasDebugCallStack + => Subst -- ^ Substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe Subst +tcMatchTyX subst ty1 ty2 + = tc_match_tys_x alwaysBindTv False subst [ty1] [ty2] + +-- | Like 'tcMatchTy' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTys :: HasDebugCallStack + => [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe Subst -- ^ One-shot; in principle the template + -- variables could be free in the target + -- See (CU6) in Note [The Core unifier] +tcMatchTys tys1 tys2 + = tc_match_tys alwaysBindTv False tys1 tys2 + +-- | Like 'tcMatchTyKi' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKis :: HasDebugCallStack + => [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe Subst -- ^ One-shot substitution + -- See (CU6) in Note [The Core unifier] +tcMatchTyKis tys1 tys2 + = tc_match_tys alwaysBindTv True tys1 tys2 + +-- | Like 'tcMatchTys', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTysX :: HasDebugCallStack + => Subst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe Subst -- ^ One-shot substitution +tcMatchTysX subst tys1 tys2 + = tc_match_tys_x alwaysBindTv False subst tys1 tys2 + +-- | Like 'tcMatchTyKis', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKisX :: HasDebugCallStack + => Subst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe Subst -- ^ One-shot substitution +tcMatchTyKisX subst tys1 tys2 + = tc_match_tys_x alwaysBindTv True subst tys1 tys2 + +-- | Same as tc_match_tys_x, but starts with an empty substitution +tc_match_tys :: HasDebugCallStack + => BindTvFun + -> Bool -- ^ match kinds? + -> [Type] + -> [Type] + -> Maybe Subst +tc_match_tys bind_me match_kis tys1 tys2 + = tc_match_tys_x bind_me match_kis (mkEmptySubst in_scope) tys1 tys2 + where + in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) + +-- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' +tc_match_tys_x :: HasDebugCallStack + => BindTvFun + -> Bool -- ^ match kinds? + -> Subst + -> [Type] + -> [Type] + -> Maybe Subst +tc_match_tys_x bind_tv match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2 + = case tc_unify_tys neverBindFam -- (ATF7) in Note [Apartness and type families] + bind_tv + False -- Matching, not unifying + False -- Not an injectivity check + match_kis + RespectMultiplicities + (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of + Unifiable (tv_env', cv_env') + -> Just $ Subst in_scope id_env tv_env' cv_env' + _ -> Nothing + +-- | This one is called from the expression matcher, +-- which already has a MatchEnv in hand +ruleMatchTyKiX + :: TyCoVarSet -- ^ template variables + -> RnEnv2 + -> TvSubstEnv -- ^ type substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TvSubstEnv +ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target +-- See Note [Kind coercions in Unify] + = case tc_unify_tys neverBindFam (matchBindTv tmpl_tvs) + -- neverBindFam: a type family probably shouldn't appear + -- on the LHS of a RULE, although we don't currently prevent it. + -- But even if it did, (ATF8) in Note [Apartness and type families] + -- says it doesn't matter becuase here we only care about Unifiable. + -- So neverBindFam is efficient, and sufficient. + False -- Matching, not unifying + False -- No doing an injectivity check + True -- Match the kinds + IgnoreMultiplicities + -- See Note [Rewrite rules ignore multiplicities in FunTy] + rn_env tenv emptyCvSubstEnv [tmpl] [target] of + Unifiable (tenv', _) -> Just tenv' + _ -> Nothing + +{- +************************************************************************ +* * + GADTs +* * +************************************************************************ + +Note [Pruning dead case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider data T a where + T1 :: T Int + T2 :: T a + + newtype X = MkX Int + newtype Y = MkY Char + + type family F a + type instance F Bool = Int + +Now consider case x of { T1 -> e1; T2 -> e2 } + +The question before the house is this: if I know something about the type +of x, can I prune away the T1 alternative? + +Suppose x::T Char. It's impossible to construct a (T Char) using T1, + Answer = YES we can prune the T1 branch (clearly) + +Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated +to 'Bool', in which case x::T Int, so + ANSWER = NO (clearly) + +We see here that we want precisely the apartness check implemented within +tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely +apart. Note that since we are simply dropping dead code, a conservative test +suffices. +-} + +-- | Given a list of pairs of types, are any two members of a pair surely +-- apart, even after arbitrary type function evaluation and substitution? +typesCantMatch :: [(Type,Type)] -> Bool +-- See Note [Pruning dead case alternatives] +typesCantMatch prs = any (uncurry typesAreApart) prs + +typesAreApart :: Type -> Type -> Bool +typesAreApart t1 t2 = case tcUnifyTysFG alwaysBindFam alwaysBindTv [t1] [t2] of + SurelyApart -> True + _ -> False +{- +************************************************************************ +* * + Various wrappers for unification +* * +********************************************************************* -} + +-- | Simple unification of two types; all type variables are bindable +-- Precondition: the kinds are already equal +tcUnifyTy :: Type -> Type -- All tyvars are bindable + -> Maybe Subst + -- A regular one-shot (idempotent) substitution +tcUnifyTy t1 t2 = tcUnifyTys alwaysBindTv [t1] [t2] + +tcUnifyDebugger :: Type -> Type -> Maybe Subst +tcUnifyDebugger t1 t2 + = case tc_unify_tys_fg + True -- Unify kinds + neverBindFam -- Does not affect Unifiable, so pick max efficient + -- See (ATF8) in Note [Apartness and type families] + alwaysBindTv + [t1] [t2] of + Unifiable subst -> Just subst + _ -> Nothing + +-- | Like 'tcUnifyTys' but also unifies the kinds +tcUnifyFunDeps :: TyCoVarSet + -> [Type] -> [Type] + -> Maybe Subst +tcUnifyFunDeps qtvs tys1 tys2 + = case tc_unify_tys_fg + True -- Unify kinds + dontCareBindFam -- Class-instance heads never mention type families + (matchBindTv qtvs) + tys1 tys2 of + Unifiable subst -> Just subst + _ -> Nothing + +-- | Unify or match a type-family RHS with a type (possibly another type-family RHS) +-- Precondition: kinds are the same +tcUnifyTyForInjectivity + :: AmIUnifying -- ^ True <=> do two-way unification; + -- False <=> do one-way matching. + -- See end of sec 5.2 from the paper + -> InScopeSet -- Should include the free tyvars of both Type args + -> Type -> Type -- Types to unify + -> Maybe Subst +-- This algorithm is an implementation of the "Algorithm U" presented in +-- the paper "Injective type families for Haskell", Figures 2 and 3. +-- The code is incorporated with the standard unifier for convenience, but +-- its operation should match the specification in the paper. +tcUnifyTyForInjectivity unif in_scope t1 t2 + = case tc_unify_tys alwaysBindFam alwaysBindTv + unif -- Am I unifying? + True -- Do injectivity checks + False -- Don't check outermost kinds + RespectMultiplicities + rn_env emptyTvSubstEnv emptyCvSubstEnv + [t1] [t2] of + Unifiable (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst + MaybeApart _reason (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst + -- We want to *succeed* in questionable cases. + -- This is a pre-unification algorithm. + SurelyApart -> Nothing + where + rn_env = mkRnEnv2 in_scope + + maybe_fix | unif = niFixSubst in_scope + | otherwise = mkTvSubst in_scope -- when matching, don't confuse + -- domain with range + +----------------- +tcUnifyTys :: BindTvFun + -> [Type] -> [Type] + -> Maybe Subst + -- ^ A regular one-shot (idempotent) substitution + -- that unifies the erased types. See comments + -- for 'tcUnifyTysFG' + +-- The two types may have common type variables, and indeed do so in the +-- second call to tcUnifyTys in GHC.Tc.Instance.FunDeps.checkClsFD +tcUnifyTys bind_fn tys1 tys2 + = case tcUnifyTysFG neverBindFam bind_fn tys1 tys2 of + Unifiable result -> Just result + _ -> Nothing + +-- | (tcUnifyTysFG bind_fam bind_tv tys1 tys2) does "fine-grain" unification +-- of tys1 and tys2, under the control of `bind_fam` and `bind_tv`. +-- This version requires that the kinds of the types are the same, +-- if you unify left-to-right. +-- See Note [The Core unifier] +tcUnifyTysFG :: BindFamFun -> BindTvFun + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTysFG bind_fam bind_tv tys1 tys2 + = tc_unify_tys_fg False bind_fam bind_tv tys1 tys2 + +tc_unify_tys_fg :: Bool + -> BindFamFun -> BindTvFun + -> [Type] -> [Type] + -> UnifyResult +tc_unify_tys_fg match_kis bind_fam bind_tv tys1 tys2 + = do { (tv_env, _) <- tc_unify_tys bind_fam bind_tv + True -- Unifying + False -- Not doing an injectivity check + match_kis -- Match outer kinds + RespectMultiplicities rn_env + emptyTvSubstEnv emptyCvSubstEnv + tys1 tys2 + ; return $ niFixSubst in_scope tv_env } + where + in_scope = mkInScopeSet $ tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 + rn_env = mkRnEnv2 in_scope + +-- | This function is actually the one to call the unifier -- a little +-- too general for outside clients, though. +tc_unify_tys :: BindFamFun -> BindTvFun + -> AmIUnifying -- ^ True <=> unify; False <=> match + -> Bool -- ^ True <=> doing an injectivity check + -> Bool -- ^ True <=> treat the kinds as well + -> MultiplicityFlag -- ^ see Note [Rewrite rules ignore multiplicities in FunTy] in GHC.Core.Unify + -> RnEnv2 + -> TvSubstEnv -- ^ substitution to extend + -> CvSubstEnv + -> [Type] -> [Type] + -> UnifyResultM (TvSubstEnv, CvSubstEnv) +-- NB: It's tempting to ASSERT here that, if we're not matching kinds, then +-- the kinds of the types should be the same. However, this doesn't work, +-- as the types may be a dependent telescope, where later types have kinds +-- that mention variables occurring earlier in the list of types. Here's an +-- example (from typecheck/should_fail/T12709): +-- template: [rep :: RuntimeRep, a :: TYPE rep] +-- target: [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep] +-- We can see that matching the first pair will make the kinds of the second +-- pair equal. Yet, we still don't need a separate pass to unify the kinds +-- of these types, so it's appropriate to use the Ty variant of unification. +-- See also Note [tcMatchTy vs tcMatchTyKi]. +tc_unify_tys bind_fam bind_tv unif inj_check match_kis match_mults rn_env tv_env cv_env tys1 tys2 + = initUM tv_env cv_env $ + do { when match_kis $ + unify_tys env kis1 kis2 + ; unify_tys env tys1 tys2 } + where + env = UMEnv { um_bind_tv_fun = bind_tv + , um_bind_fam_fun = bind_fam + , um_foralls = emptyVarSet + , um_unif = unif + , um_inj_tf = inj_check + , um_arr_mult = match_mults + , um_rn_env = rn_env } + + kis1 = map typeKind tys1 + kis2 = map typeKind tys2 + + +{- ********************************************************************* +* * + UnifyResult, MaybeApart etc +* * +********************************************************************* -} + +{- Note [Rewrite rules ignore multiplicities in FunTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following (higher-order) rule: + +m :: Bool -> Bool -> Bool +{-# RULES "m" forall f. m (f True) = f #-} + +let x = m ((,) @Bool @Bool True True) + +The rewrite rule expects an `f :: Bool -> Bool`, but `(,) @Bool @Bool True :: +Bool %1 -> Bool` is linear (see Note [Data constructors are linear by default] +in GHC.Core.Multiplicity) Should the rule match? Yes! According to the +principles laid out in Note [Linting linearity] in GHC.Core.Lint, optimisation +shouldn't be constrained by linearity. + +However, when matching the template variable `f` to `(,) True`, we do check that +their types unify (see Note [Matching variable types] in GHC.Core.Rules). So +when unifying types for the sake of rule-matching, the unification algorithm +must be able to ignore multiplicities altogether. + +How is this done? + (1) The `um_arr_mult` field of `UMEnv` recordsw when we are doing rule-matching, + and hence want to ignore multiplicities. + (2) The field is set to True in by `ruleMatchTyKiX`. + (3) It is consulted when matching `FunTy` in `unify_ty`. + +Wrinkle in (3). In `unify_tc_app`, in `unify_ty`, `FunTy` is handled as if it +was a regular type constructor. In this case, and when the types being unified +are *function* arrows, but not constraint arrows, then the first argument is a +multiplicity. + +We select this situation by comparing the type constructor with fUNTyCon. In +this case, and this case only, we can safely drop the first argument (using the +tail function) and unify the rest. + +Note [The substitution in MaybeApart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? +Because consider unifying these: + +(a, a, Int) ~ (b, [b], Bool) + +If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we +apply the subst we have so far and discover that we need [b |-> [b]]. Because +this fails the occurs check, we say that the types are MaybeApart (see above +Note [Infinitary substitutions]). But, we can't stop there! Because if we +continue, we discover that Int is SurelyApart from Bool, and therefore the +types are apart. This has practical consequences for the ability for closed +type family applications to reduce. See test case +indexed-types/should_compile/Overlap14. +-} + +-- This type does double-duty. It is used in the UM (unifier monad) and to +-- return the final result. See Note [Unification result] +type UnifyResult = UnifyResultM Subst + +-- | See Note [Unification result] +data UnifyResultM a = Unifiable a -- the subst that unifies the types + | MaybeApart MaybeApartReason + a -- the subst has as much as we know + -- it must be part of a most general unifier + -- See Note [The substitution in MaybeApart] + | SurelyApart + deriving Functor + +-- | Why are two types 'MaybeApart'? 'MARInfinite' takes precedence: +-- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv +-- As of Feb 2022, we never differentiate between MARTypeFamily and MARTypeVsConstraint; +-- it's really only MARInfinite that's interesting here. +data MaybeApartReason + = MARTypeFamily -- ^ matching e.g. F Int ~? Bool + + | MARInfinite -- ^ matching e.g. a ~? Maybe a + + | MARTypeVsConstraint -- ^ matching Type ~? Constraint or the arrow types + -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim + + | MARCast -- ^ Very obscure. + -- See (KCU2) in Note [Kind coercions in Unify] + + +combineMAR :: MaybeApartReason -> MaybeApartReason -> MaybeApartReason +-- See (UR1) in Note [Unification result] for why MARInfinite wins +combineMAR MARInfinite _ = MARInfinite -- MARInfinite wins +combineMAR MARTypeFamily r = r -- Otherwise it doesn't really matter +combineMAR MARTypeVsConstraint r = r +combineMAR MARCast r = r + +instance Outputable MaybeApartReason where + ppr MARTypeFamily = text "MARTypeFamily" + ppr MARInfinite = text "MARInfinite" + ppr MARTypeVsConstraint = text "MARTypeVsConstraint" + ppr MARCast = text "MARCast" + +instance Semigroup MaybeApartReason where + (<>) = combineMAR + +instance Applicative UnifyResultM where + pure = Unifiable + (<*>) = ap + +instance Monad UnifyResultM where + SurelyApart >>= _ = SurelyApart + MaybeApart r1 x >>= f = case f x of + Unifiable y -> MaybeApart r1 y + MaybeApart r2 y -> MaybeApart (r1 S.<> r2) y + SurelyApart -> SurelyApart + Unifiable x >>= f = f x + +instance Outputable a => Outputable (UnifyResultM a) where + ppr SurelyApart = text "SurelyApart" + ppr (Unifiable x) = text "Unifiable" <+> ppr x + ppr (MaybeApart r x) = text "MaybeApart" <+> ppr r <+> ppr x + +{- +************************************************************************ +* * + Non-idempotent substitution +* * +************************************************************************ + +Note [Non-idempotent substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During unification we use a TvSubstEnv/CvSubstEnv pair that is + (a) non-idempotent + (b) loop-free; ie repeatedly applying it yields a fixed point + +Note [Finding the substitution fixpoint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Finding the fixpoint of a non-idempotent substitution arising from a +unification is much trickier than it looks, because of kinds. Consider + T k (H k (f:k)) ~ T * (g:*) +If we unify, we get the substitution + [ k -> * + , g -> H k (f:k) ] +To make it idempotent we don't want to get just + [ k -> * + , g -> H * (f:k) ] +We also want to substitute inside f's kind, to get + [ k -> * + , g -> H k (f:*) ] +If we don't do this, we may apply the substitution to something, +and get an ill-formed type, i.e. one where typeKind will fail. +This happened, for example, in #9106. + +It gets worse. In #14164 we wanted to take the fixpoint of +this substitution + [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6) + (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6)) + , a_aY6 :-> a_aXQ ] + +We have to apply the substitution for a_aY6 two levels deep inside +the invocation of F! We don't have a function that recursively +applies substitutions inside the kinds of variable occurrences (and +probably rightly so). + +So, we work as follows: + + 1. Start with the current substitution (which we are + trying to fixpoint + [ xs :-> F a (z :: a) (rest :: G a (z :: a)) + , a :-> b ] + + 2. Take all the free vars of the range of the substitution: + {a, z, rest, b} + NB: the free variable finder closes over + the kinds of variable occurrences + + 3. If none are in the domain of the substitution, stop. + We have found a fixpoint. + + 4. Remove the variables that are bound by the substitution, leaving + {z, rest, b} + + 5. Do a topo-sort to put them in dependency order: + [ b :: *, z :: a, rest :: G a z ] + + 6. Apply the substitution left-to-right to the kinds of these + tyvars, extending it each time with a new binding, so we + finish up with + [ xs :-> ..as before.. + , a :-> b + , b :-> b :: * + , z :-> z :: b + , rest :-> rest :: G b (z :: b) ] + Note that rest now has the right kind + + 7. Apply this extended substitution (once) to the range of + the /original/ substitution. (Note that we do the + extended substitution would go on forever if you tried + to find its fixpoint, because it maps z to z.) + + 8. And go back to step 1 + +In Step 6 we use the free vars from Step 2 as the initial +in-scope set, because all of those variables appear in the +range of the substitution, so they must all be in the in-scope +set. But NB that the type substitution engine does not look up +variables in the in-scope set; it is used only to ensure no +shadowing. +-} + +niFixSubst :: InScopeSet -> TvSubstEnv -> Subst +-- Find the idempotent fixed point of the non-idempotent substitution +-- This is surprisingly tricky: +-- see Note [Finding the substitution fixpoint] +-- ToDo: use laziness instead of iteration? +niFixSubst in_scope tenv + | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv) + | otherwise = subst + where + range_fvs :: FV + range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv) + -- It's OK to use nonDetEltsUFM here because the + -- order of range_fvs, range_tvs is immaterial + + range_tvs :: [TyVar] + range_tvs = fvVarList range_fvs + + not_fixpoint = any in_domain range_tvs + in_domain tv = tv `elemVarEnv` tenv + + free_tvs = scopedSort (filterOut in_domain range_tvs) + + -- See Note [Finding the substitution fixpoint], Step 6 + subst = foldl' add_free_tv + (mkTvSubst in_scope tenv) + free_tvs + + add_free_tv :: Subst -> TyVar -> Subst + add_free_tv subst tv + = extendTvSubst subst tv (mkTyVarTy tv') + where + tv' = updateTyVarKind (substTy subst) tv + +{- +************************************************************************ +* * + unify_ty: the main workhorse +* * +************************************************************************ + +Note [Specification of unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The pure unifier, unify_ty, defined in this module, tries to work out +a substitution to make two types say True to eqType. NB: eqType is +itself not purely syntactic; it accounts for CastTys; +see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + +Unlike the "impure unifiers" in the typechecker (the eager unifier in +GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Equality), +the pure unifier does /not/ work up to ~. + +The algorithm implemented here is rather delicate, and we depend on it +to uphold certain properties. This is a summary of these required +properties. + +Notation: + θ,φ substitutions + ξ type-function-free types + τ,σ other types + τ♭ type τ, flattened + + ≡ eqType + +(U1) Soundness. + If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). + θ is a most general unifier for τ₁ and τ₂. + +(U2) Completeness. + If (unify ξ₁ ξ₂) = SurelyApart, + then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). + +These two properties are stated as Property 11 in the "Closed Type Families" +paper (POPL'14). Below, this paper is called [CTF]. + +(U3) Apartness under substitution. + If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, + for any θ. (Property 12 from [CTF]) + +(U4) Apart types do not unify. + If (unify ξ τ♭) = SurelyApart, then there exists no θ + such that θ(ξ) = θ(τ). (Property 13 from [CTF]) + +THEOREM. Completeness w.r.t ~ + If (unify τ₁♭ τ₂♭) = SurelyApart, + then there exists no proof that (τ₁ ~ τ₂). + +PROOF. See appendix of [CTF]. + + +The unification algorithm is used for type family injectivity, as described +in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run +in this mode, it has the following properties. + +(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even + after arbitrary type family reductions. + +(I2) If (unify σ τ) = MaybeApart θ, and if some + φ exists such that φ(σ) ~ φ(τ), then φ extends θ. + + +Furthermore, the RULES matching algorithm requires this property, +but only when using this algorithm for matching: + +(M1) If (match σ τ) succeeds with θ, then all matchable tyvars + in σ are bound in θ. + + Property M1 means that we must extend the substitution with, + say (a ↦ a) when appropriate during matching. + See also Note [Self-substitution when unifying or matching]. + +(M2) Completeness of matching. + If θ(σ) = τ, then (match σ τ) = Unifiable φ, + where θ is an extension of φ. + +Wrinkle (SI1): um_inj_tf: + Sadly, property M2 and I2 conflict. Consider + + type family F1 a b where + F1 Int Bool = Char + F1 Double String = Char + + Consider now two matching problems: + + P1. match (F1 a Bool) (F1 Int Bool) + P2. match (F1 a Bool) (F1 Double String) + + In case P1, we must find (a ↦ Int) to satisfy M2. In case P2, we must /not/ + find (a ↦ Double), in order to satisfy I2. (Note that the correct mapping for + I2 is (a ↦ Int). There is no way to discover this, but we mustn't map a to + anything else!) + + We thus must parameterize the algorithm over whether it's being used + for an injectivity check (refrain from looking at non-injective arguments + to type families) or not (do indeed look at those arguments). This is + implemented by the um_inj_tf field of UMEnv. + + (It's all a question of whether or not to include equation (7) from Fig. 2 + of [ITF].) + + This extra parameter is a bit fiddly, perhaps, but seemingly less so than + having two separate, almost-identical algorithms. + +Note [Self-substitution when unifying or matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What happens when we are unifying or matching two identical type variables? + a ~ a + +* When /unifying/, just succeed, without binding [a :-> a] in the substitution, + else we'd get an infinite substitution. We need to make this check before + we do the occurs check, of course. + +* When /matching/, and `a` is a bindable variable from the template, we /do/ + want to extend the substitution. Remember, a successful match should map all + the template variables (except ones that disappear when expanding synonyms), + + But when `a` is /not/ a bindable variable (perhaps it is a globally-in-scope + skolem) we want to treat it like a constant `Int ~ Int` and succeed. + + Notice: no occurs check! It's fine to match (a ~ Maybe a), because the + template vars of the template come from a different name space to the free + vars of the target. + + Note that this arrangement was provoked by a real failure, where the same + unique ended up in the template as in the target. (It was a rule firing when + compiling Data.List.NonEmpty.) + +* What about matching a /non-bindable/ variable? For example: + template-vars : {a} + matching problem: (forall b. b -> a) ~ (forall c. c -> Int) + We want to emerge with the substitution [a :-> Int] + But on the way we will encounter (b ~ b), when we match the bits before the + arrow under the forall, having renamed `c` to `b`. This match should just + succeed, just like (Int ~ Int), without extending the substitution. + + It's important to do this for /non-bindable/ variables, not just for + forall-bound ones. In an associated type + instance C (Maybe a) where { type F (Maybe a) = Int } + `checkConsistentFamInst` matches (Maybe a) from the header against (Maybe a) + from the type-family instance, with `a` marked as non-bindable. + + +Note [Matching coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + type family F a + + data G a where + MkG :: F a ~ Bool => G a + + type family Foo (x :: G a) :: F a + type instance Foo MkG = False + +We would like that to be accepted. For that to work, we need to introduce +a coercion variable on the left and then use it on the right. Accordingly, +at use sites of Foo, we need to be able to use matching to figure out the +value for the coercion. (See the desugared version: + + axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) + +) We never want this action to happen during *unification* though, when +all bets are off. + +Note [Kind coercions in Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to match/unify while ignoring casts. But, we can't just ignore +them completely, or we'll end up with ill-kinded substitutions. For example, +say we're matching `a` with `ty |> co`. If we just drop the cast, we'll +return [a |-> ty], but `a` and `ty` might have different kinds. We can't +just match/unify their kinds, either, because this might gratuitously +fail. After all, `co` is the witness that the kinds are the same -- they +may look nothing alike. + +So, we pass a kind coercion `kco` to the main `unify_ty`. This coercion witnesses +the equality between the substed kind of the left-hand type and the substed +kind of the right-hand type. Note that we do not unify kinds at the leaves +(as we did previously). + +Hence: (UKINV) Unification Kind Invariant +* In the call + unify_ty ty1 ty2 kco + it must be that + subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)) + where `subst` is the ambient substitution in the UM monad +* In the call + unify_tys tys1 tys2 + (which has no kco), after we unify any prefix of tys1,tys2, the kinds of the + head of the remaining tys1,tys2 are identical after substitution. This + implies, for example, that the kinds of the head of tys1,tys2 are identical + after substitution. + +Preserving (UKINV) takes a bit of work, governed by the `match_kis` flag in +`tc_unify_tys`: + +* When we're working with type applications (either TyConApp or AppTy) we + need to worry about establishing (UKINV), as the kinds of the function + & arguments aren't (necessarily) included in the kind of the result. + When unifying two TyConApps, this is easy, because the two TyCons are + the same. Their kinds are thus the same. As long as we unify left-to-right, + we'll be sure to unify types' kinds before the types themselves. (For example, + think about Proxy :: forall k. k -> *. Unifying the first args matches up + the kinds of the second args.) + +* For AppTy, we must unify the kinds of the functions, but once these are + unified, we can continue unifying arguments without worrying further about + kinds. + +* The interface to this module includes both "...Ty" functions and + "...TyKi" functions. The former assume that (UKINV) is already + established, either because the kinds are the same or because the + list of types being passed in are the well-typed arguments to some + type constructor (see two paragraphs above). The latter take a separate + pre-pass over the kinds to establish (UKINV). Sometimes, it's important + not to take the second pass, as it caused #12442. + +Wrinkles + +(KCU1) We ensure that the `kco` argument never mentions variables in the + domain of either RnEnvL or RnEnvR. Why? + + * `kco` is used only to build the final well-kinded substitution + a :-> ty |> kco + The range of the substitution never mentions forall-bound variables, + so `kco` cannot either. + + * `kco` mixes up types from both left and right arguments of + `unify_ty`, which have different renamings in the RnEnv2. + + The easiest thing is to insist that `kco` does not need renaming with + the RnEnv2; it mentions no forall-bound variables. + + To achieve this we do a `mentionsForAllBoundTyVars` test in the + `CastTy` cases of `unify_ty`. + +(KCU2) Suppose we are unifying + (forall a. x |> (...F a b...) ~ (forall a. y) + We can't bind y :-> x |> (...F a b...), becuase of that free `a`. + + But if we later learn that b=Int, and F a Int = Bool, + that free `a` might disappear, so we could unify with + y :-> x |> (...Bool...) + + Conclusion: if there is a free forall-bound variable in a cast, + return MaybeApart, with a MaybeApartReason of MARCast. + +(KCU3) We thought, at one point, that this was all unnecessary: why should + casts be in types in the first place? But they are sometimes. In + dependent/should_compile/KindEqualities2, we see, for example the + constraint Num (Int |> (blah ; sym blah)). We naturally want to find + a dictionary for that constraint, which requires dealing with + coercions in this manner. + +Note [Matching in the presence of casts (1)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When matching, it is crucial that no variables from the template +end up in the range of the matching substitution (obviously!). +When unifying, that's not a constraint; instead we take the fixpoint +of the substitution at the end. + +So what should we do with this, when matching? + unify_ty (tmpl |> co) tgt kco + +Previously, wrongly, we pushed 'co' in the (horrid) accumulating +'kco' argument like this: + unify_ty (tmpl |> co) tgt kco + = unify_ty tmpl tgt (kco ; co) + +But that is obviously wrong because 'co' (from the template) ends +up in 'kco', which in turn ends up in the range of the substitution. + +This all came up in #13910. Because we match tycon arguments +left-to-right, the ambient substitution will already have a matching +substitution for any kinds; so there is an easy fix: just apply +the substitution-so-far to the coercion from the LHS. + +Note that + +* When matching, the first arg of unify_ty is always the template; + we never swap round. + +* The above argument is distressingly indirect. We seek a + better way. + +* One better way is to ensure that type patterns (the template + in the matching process) have no casts. See #14119. + +Note [Matching in the presence of casts (2)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is another wrinkle (#17395). Suppose (T :: forall k. k -> Type) +and we are matching + tcMatchTy (T k (a::k)) (T j (b::j)) + +Then we'll match k :-> j, as expected. But then in unify_tys +we invoke + unify_tys env (a::k) (b::j) (Refl j) + +Although we have unified k and j, it's very important that we put +(Refl j), /not/ (Refl k) as the fourth argument to unify_tys. +If we put (Refl k) we'd end up with the substitution + a :-> b |> Refl k +which is bogus because one of the template variables, k, +appears in the range of the substitution. Eek. + +Similar care is needed in unify_ty_app. + + +Note [Polykinded tycon applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose T :: forall k. Type -> K +and we are unifying + ty1: T @Type Int :: Type + ty2: T @(Type->Type) Int Int :: Type + +These two TyConApps have the same TyCon at the front but they +(legitimately) have different numbers of arguments. They +are surelyApart, so we can report that without looking any +further (see #15704). + +Note [Unifying type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unifying type applications is quite subtle, as we found +in #23134 and #22647, when type families are involved. + +Suppose + type family F a :: Type -> Type + type family G k :: k = r | r -> k + +and consider these examples: + +* F Int ~ F Char, where F is injective + Since F is injective, we can reduce this to Int ~ Char, + therefore SurelyApart. + +* F Int ~ F Char, where F is not injective + Without injectivity, return MaybeApart. + +* G Type ~ G (Type -> Type) Int + Even though G is injective and the arguments to G are different, + we cannot deduce apartness because the RHS is oversaturated. + For example, G might be defined as + G Type = Maybe Int + G (Type -> Type) = Maybe + So we return MaybeApart. + +* F Int Bool ~ F Int Char -- SurelyApart (since Bool is apart from Char) + F Int Bool ~ Maybe a -- MaybeApart + F Int Bool ~ a b -- MaybeApart + F Int Bool ~ Char -> Bool -- MaybeApart + An oversaturated type family can match an application, + whether it's a TyConApp, AppTy or FunTy. Decompose. + +* F Int ~ a b + We cannot decompose a saturated, or under-saturated + type family application. We return MaybeApart. + +To handle all those conditions, unify_ty goes through +the following checks in sequence, where Fn is a type family +of arity n: + +* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n + A saturated application. + Here we can unify arguments in which Fn is injective. +* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n + A saturated type family can match anything - we return MaybeApart. +* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n + An oversaturated type family can be decomposed. +* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n + If we couldn't decompose in the previous step, we return SurelyApart. + +Afterwards, the rest of the code doesn't have to worry about type families. + +Note [Unifying type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the task of unifying two 'Type's of the form + + TyConApp tc [] ~ TyConApp tc [] + +where `tc` is a type synonym. A naive way to perform this comparison these +would first expand the synonym and then compare the resulting expansions. + +However, this is obviously wasteful and the RHS of `tc` may be large; it is +much better to rather compare the TyCons directly. Consequently, before +expanding type synonyms in type comparisons we first look for a nullary +TyConApp and simply compare the TyCons if we find one. + +Of course, if we find that the TyCons are *not* equal then we still need to +perform the expansion as their RHSs may still be unifiable. E.g + type T = S (a->a) + type S a = [a] +and consider + T Int ~ S (Int -> Int) + +We can't decompose non-nullary synonyms. E.g. + type R a = F a -- Where F is a type family +and consider + R (a->a) ~ R Int +We can't conclude that (a->) ~ Int. (There is a currently-missed opportunity +here; if we knew that R was /injective/, perhaps we could decompose.) + +We perform the nullary-type-synonym optimisation in a number of places: + + * GHC.Core.Unify.unify_ty + * GHC.Tc.Solver.Equality.can_eq_nc' + * GHC.Tc.Utils.Unify.uType + +This optimisation is especially helpful for the ubiquitous GHC.Types.Type, +since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications +whenever possible. See Note [Using synonyms to compress types] in +GHC.Core.Type for details. + +c.f. Note [Comparing type synonyms] in GHC.Core.TyCo.Compare +-} + +-------------- unify_ty: the main workhorse ----------- + +type AmIUnifying = Bool -- True <=> Unifying + -- False <=> Matching + +type InType = Type -- Before applying the RnEnv2 +type OutCoercion = Coercion -- After applying the RnEnv2 + + +unify_ty :: UMEnv + -> InType -> InType -- Types to be unified + -> OutCoercion -- A nominal coercion between their kinds + -- OutCoercion: the RnEnv has already been applied + -- When matching, the coercion is in "target space", + -- not "template space" + -- See Note [Kind coercions in Unify] + -> UM () +-- Precondition: see (Unification Kind Invariant) +-- +-- See Note [Specification of unification] +-- Respects newtypes, PredTypes +-- See Note [Computing equality on types] in GHC.Core.Type +unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco + -- See Note [Unifying type synonyms] + | tc1 == tc2 + = return () + +unify_ty env ty1 ty2 kco + -- Now handle the cases we can "look through": synonyms and casts. + | Just ty1' <- coreView ty1 = unify_ty env ty1' ty2 kco + | Just ty2' <- coreView ty2 = unify_ty env ty1 ty2' kco + +unify_ty env (CastTy ty1 co1) ty2 kco + | mentionsForAllBoundTyVarsL env (tyCoVarsOfCo co1) + -- See (KCU1) in Note [Kind coercions in Unify] + = maybeApart MARCast -- See (KCU2) + + | um_unif env + = unify_ty env ty1 ty2 (co1 `mkTransCo` kco) + + | otherwise -- We are matching, not unifying + = do { subst <- getSubst env + ; let co' = substCo subst co1 + -- We match left-to-right, so the free template vars of the + -- coercion should already have been matched. + -- See Note [Matching in the presence of casts (1)] + -- NB: co1 does not mention forall-bound vars, so no need to rename + ; unify_ty env ty1 ty2 (co' `mkTransCo` kco) } + +unify_ty env ty1 (CastTy ty2 co2) kco + | mentionsForAllBoundTyVarsR env (tyCoVarsOfCo co2) + -- See (KCU1) in Note [Kind coercions in Unify] + = maybeApart MARCast -- See (KCU2) + | otherwise + = unify_ty env ty1 ty2 (kco `mkTransCo` mkSymCo co2) + -- NB: co2 does not mention forall-bound variables + +-- Applications need a bit of care! +-- They can match FunTy and TyConApp, so use splitAppTy_maybe +unify_ty env (AppTy ty1a ty1b) ty2 _kco + | Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty env ty1 (AppTy ty2a ty2b) _kco + | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () + +unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco + -- ToDo: See Note [Unifying coercion-foralls] + = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind) + ; let env' = umRnBndr2 env tv1 tv2 + ; unify_ty env' ty1 ty2 kco } + +-- See Note [Matching coercion variables] +unify_ty env (CoercionTy co1) (CoercionTy co2) kco + = do { c_subst <- getCvSubstEnv + ; case co1 of + CoVarCo cv + | not (um_unif env) + , not (cv `elemVarEnv` c_subst) -- Not forall-bound + , let (_mult_co, co_l, co_r) = decomposeFunCo kco + -- Because the coercion is used in a type, it should be safe to + -- ignore the multiplicity coercion, _mult_co + -- cv :: t1 ~ t2 + -- co2 :: s1 ~ s2 + -- co_l :: t1 ~ s1 + -- co_r :: t2 ~ s2 + rhs_co = co_l `mkTransCo` co2 `mkTransCo` mkSymCo co_r + , BindMe <- um_bind_tv_fun env cv (CoercionTy rhs_co) + -> if mentionsForAllBoundTyVarsR env (tyCoVarsOfCo co2) + then surelyApart + else extendCvEnv cv rhs_co + + _ -> return () } + +unify_ty env (TyVarTy tv1) ty2 kco + = uVarOrFam env (TyVarLHS tv1) ty2 kco + +unify_ty env ty1 (TyVarTy tv2) kco + | um_unif env -- If unifying, can swap args; but not when matching + = uVarOrFam (umSwapRn env) (TyVarLHS tv2) ty1 (mkSymCo kco) + +-- Deal with TyConApps +unify_ty env ty1 ty2 kco + -- Handle non-oversaturated type families first + -- See Note [Unifying type applications] + | Just (tc,tys) <- mb_sat_fam_app1 + = uVarOrFam env (TyFamLHS tc tys) ty2 kco + + | um_unif env + , Just (tc,tys) <- mb_sat_fam_app2 + = uVarOrFam (umSwapRn env) (TyFamLHS tc tys) ty1 (mkSymCo kco) + + -- Handle oversaturated type families. Suppose we have + -- (F a b) ~ (c d) where F has arity 1 + -- We definitely want to decompose that type application! (#22647) + -- + -- If there is no application, an oversaturated type family can only + -- match a type variable or a saturated type family, + -- both of which we handled earlier. So we can say surelyApart. + | Just (tc1, _) <- mb_tc_app1 + , isTypeFamilyTyCon tc1 + = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 + , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 + -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) + | otherwise -> surelyApart -- (C4) + + | Just (tc2, _) <- mb_tc_app2 + , isTypeFamilyTyCon tc2 + = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 + , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 + -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) + | otherwise -> surelyApart -- (C4) + + -- At this point, neither tc1 nor tc2 can be a type family. + | Just (tc1, tys1) <- mb_tc_app1 + , Just (tc2, tys2) <- mb_tc_app2 + , tc1 == tc2 + = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1) + ; unify_tc_app env tc1 tys1 tys2 + } + + -- TYPE and CONSTRAINT are not Apart + -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim + -- NB: at this point we know that the two TyCons do not match + | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1 + , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2 + , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) || + (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey) + = maybeApart MARTypeVsConstraint + -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim + -- Note [Type and Constraint are not apart] + + -- The arrow types are not Apart + -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim + -- wrinkle (W2) + -- NB1: at this point we know that the two TyCons do not match + -- NB2: In the common FunTy/FunTy case you might wonder if we want to go via + -- splitTyConApp_maybe. But yes we do: we need to look at those implied + -- kind argument in order to satisfy (Unification Kind Invariant) + | FunTy {} <- ty1 + , FunTy {} <- ty2 + = maybeApart MARTypeVsConstraint + -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim + -- Note [Type and Constraint are not apart] + + where + mb_tc_app1 = splitTyConApp_maybe ty1 + mb_tc_app2 = splitTyConApp_maybe ty2 + mb_sat_fam_app1 = isSatTyFamApp ty1 + mb_sat_fam_app2 = isSatTyFamApp ty2 + +unify_ty _ _ _ _ = surelyApart + +----------------------------- +unify_tc_app :: UMEnv -> TyCon -> [Type] -> [Type] -> UM () +-- Mainly just unifies the argument types; +-- but with a special case for fUNTyCon +unify_tc_app env tc tys1 tys2 + | tc == fUNTyCon + , IgnoreMultiplicities <- um_arr_mult env + , (_mult1 : no_mult_tys1) <- tys1 + , (_mult2 : no_mult_tys2) <- tys2 + = -- We're comparing function arrow types here (not constraint arrow + -- types!), and they have at least one argument, which is the arrow's + -- multiplicity annotation. The flag `um_arr_mult` instructs us to + -- ignore multiplicities in this very case. This is a little tricky: see + -- point (3) in Note [Rewrite rules ignore multiplicities in FunTy]. + unify_tys env no_mult_tys1 no_mult_tys2 + + | otherwise + = unify_tys env tys1 tys2 + +----------------------------- +unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () +-- Deal with (t1 t1args) ~ (t2 t2args) +-- where length t1args = length t2args +unify_ty_app env ty1 ty1args ty2 ty2args + | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1 + , Just (ty2', ty2a) <- splitAppTyNoView_maybe ty2 + = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) + + | otherwise + = do { let ki1 = typeKind ty1 + ki2 = typeKind ty2 + -- See Note [Kind coercions in Unify] + ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind) + ; unify_ty env ty1 ty2 (mkNomReflCo ki2) + -- Very important: 'ki2' not 'ki1' + -- See Note [Matching in the presence of casts (2)] + ; unify_tys env ty1args ty2args } + +----------------------------- +unify_tys :: UMEnv -> [Type] -> [Type] -> UM () +-- Precondition: see (Unification Kind Invariant) +unify_tys env orig_xs orig_ys + = go orig_xs orig_ys + where + go [] [] = return () + go (x:xs) (y:ys) + -- See Note [Kind coercions in Unify] + = do { unify_ty env x y (mkNomReflCo $ typeKind y) + -- Very important: 'y' not 'x' + -- See Note [Matching in the presence of casts (2)] + ; go xs ys } + go _ _ = surelyApart + -- Possibly different saturations of a polykinded tycon + -- See Note [Polykinded tycon applications] + +--------------------------------- +uVarOrFam :: UMEnv -> CanEqLHS -> InType -> OutCoercion -> UM () +-- Invariants: (a) If ty1 is a TyFamLHS, then ty2 is NOT a TyVarTy +-- (b) both args have had coreView already applied +-- Why saturated? See (ATF4) in Note [Apartness and type families] +uVarOrFam env ty1 ty2 kco + = do { substs <- getSubstEnvs +-- ; pprTrace "uVarOrFam" (vcat +-- [ text "ty1" <+> ppr ty1 +-- , text "ty2" <+> ppr ty2 +-- , text "tv_env" <+> ppr (um_tv_env substs) +-- , text "fam_env" <+> ppr (um_fam_env substs) ]) $ + ; go NotSwapped substs ty1 ty2 kco } + where + foralld_tvs = um_foralls env + under_forall = not (isEmptyVarSet foralld_tvs) + + -- `go` takes two bites at the cherry; if the first one fails + -- it swaps the arguments and tries again; and then it fails. + -- The SwapFlag argument tells `go` whether it is on the first + -- bite (NotSwapped) or the second (IsSwapped). + -- E.g. a ~ F p q + -- Starts with: go a (F p q) + -- if `a` not bindable, swap to: go (F p q) a + + ----------------------------- + -- LHS is a type variable + -- The sequence of tests is very similar to go_tv + go :: SwapFlag -> UMState -> CanEqLHS -> InType -> OutCoercion -> UM () + go swapped substs lhs@(TyVarLHS tv1) ty2 kco + | Just ty1' <- lookupVarEnv (um_tv_env substs) tv1' + = -- We already have a substitution for tv1 + if | um_unif env -> unify_ty env ty1' ty2 kco + | (ty1' `mkCastTy` kco) `tcEqType` ty2 -> return () + | otherwise -> surelyApart + -- Unifying: recurse into unify_ty + -- Matching: we /don't/ want to just recurse here, because the range of + -- the subst is the target type, not the template type. So, just check + -- for normal type equality. + -- NB: it's important to use `tcEqType` instead of `eqType` here, + -- otherwise we might not reject a substitution + -- which unifies `Type` with `Constraint`, e.g. + -- a call to tc_unify_tys with arguments + -- + -- tys1 = [k,k] + -- tys2 = [Type, Constraint] + -- + -- See test cases: T11715b, T20521. + + -- If we are matching or unifying a ~ a, take care + -- See Note [Self-substitution when unifying or matching] + | TyVarTy tv2 <- ty2 + , let tv2' = umRnOccR env tv2 + , tv1' == tv2' + = if | um_unif env -> return () + | tv1_is_bindable -> extendTvEnv tv1' ty2 + | otherwise -> return () + + | tv1_is_bindable + , not (mentionsForAllBoundTyVarsR env ty2_fvs) + -- ty2_fvs: kco does not mention forall-bound vars + , not occurs_check + = -- No occurs check, nor skolem-escape; just bind the tv + -- We don't need to rename `rhs` because it mentions no forall-bound vars + extendTvEnv tv1' rhs -- Bind tv1:=rhs and continue + + -- When unifying, try swapping: + -- e.g. a ~ F p q with `a` not bindable: we might succeed with go_fam + -- e.g. a ~ beta with `a` not bindable: we might be able to bind `beta` + -- e.g. beta ~ F beta Int occurs check; but MaybeApart after swapping + | um_unif env + , NotSwapped <- swapped -- If we have swapped already, don't do so again + , Just lhs2 <- canEqLHS_maybe ty2 + = go IsSwapped substs lhs2 (mkTyVarTy tv1) (mkSymCo kco) + + | occurs_check = maybeApart MARInfinite -- Occurs check + | otherwise = surelyApart + + where + tv1' = umRnOccL env tv1 + ty2_fvs = tyCoVarsOfType ty2 + rhs = ty2 `mkCastTy` mkSymCo kco + tv1_is_bindable | not (tv1' `elemVarSet` foralld_tvs) + -- tv1' is not forall-bound, but tv1 can still differ + -- from tv1; see Note [Cloning the template binders] + -- in GHC.Core.Rules. So give tv1' to um_bind_tv_fun. + , BindMe <- um_bind_tv_fun env tv1' rhs + = True + | otherwise + = False + + occurs_check = um_unif env && uOccursCheck substs foralld_tvs lhs rhs + -- Occurs check, only when unifying + -- see Note [Infinitary substitutions] + -- Make sure you include `kco` in rhs #14846 + + ----------------------------- + -- LHS is a saturated type-family application + -- Invariant: ty2 is not a TyVarTy + go swapped substs lhs@(TyFamLHS tc1 tys1) ty2 kco + -- Check if we have an existing substitution for the LHS; if so, recurse + -- But not under a forall; see (ATF3) in Note [Apartness and type families] + -- Hence the RnEnv2 is empty + | not under_forall + , Just ty1' <- lookupFamEnv (um_fam_env substs) tc1 tys1 + = if | um_unif env -> unify_ty env ty1' ty2 kco + -- Below here we are matching + -- The return () case deals with: + -- Template: (F a)..(F a) + -- Target: (F b)..(F b) + -- This should match! With [a :-> b] + | (ty1' `mkCastTy` kco) `tcEqType` ty2 -> return () + | otherwise -> maybeApart MARTypeFamily + + -- Check for equality F tys1 ~ F tys2 + -- Very important that this can happen under a forall, so that we + -- successfully match (forall a. F a) ~ (forall b. F b) See (ATF9-2) + | Just (tc2, tys2) <- isSatTyFamApp ty2 + , tc1 == tc2 + = go_fam_fam substs tc1 tys1 tys2 kco + + -- If we are under a forall, just give up + -- see (ATF3) and (ATF5) in Note [Apartness and type families] + | under_forall + = maybeApart MARTypeFamily + + -- Now check if we can bind the (F tys) to the RHS + -- Again, not under a forall; see (ATF3) + -- This can happen even when matching: see (ATF7) + | BindMe <- um_bind_fam_fun env tc1 tys1 rhs + = if uOccursCheck substs emptyVarSet lhs rhs + then maybeApart MARInfinite + else do { extendFamEnv tc1 tys1 rhs + -- We don't substitute tys1 before extending + -- See Note [Shortcomings of the apartness test] + ; maybeApart MARTypeFamily } + + -- Swap in case of (F a b) ~ (G c d e) + -- Maybe um_bind_fam_fun is False of (F a b) but true of (G c d e) + -- NB: a type family can appear on the template when matching + -- see (ATF6) in Note [Apartness and type families] + -- (Only worth doing this if we are not under a forall.) + | um_unif env + , NotSwapped <- swapped + , Just lhs2 <- canEqLHS_maybe ty2 + = go IsSwapped substs lhs2 (mkTyConApp tc1 tys1) (mkSymCo kco) + + | otherwise -- See (ATF5) in Note [Apartness and type families] + = surelyApart + + where + rhs = ty2 `mkCastTy` mkSymCo kco + + ----------------------------- + -- go_fam_fam: LHS and RHS are both saturated type-family applications, + -- for the same type-family F + go_fam_fam substs tc tys1 tys2 kco + -- Decompose (F tys1 ~ F tys2): (ATF9) + -- Use injectivity information of F: (ATF10) + -- But first bind the type-fam if poss: (ATF11) + = do { bind_fam_if_poss -- (ATF11) + ; unify_tys env inj_tys1 inj_tys2 -- (ATF10) + ; unless (um_inj_tf env) $ -- (ATF12) + don'tBeSoSure MARTypeFamily $ -- (ATF9-1) + unify_tys env noninj_tys1 noninj_tys2 } + where + inj = case tyConInjectivityInfo tc of + NotInjective -> repeat False + Injective bs -> bs + + (inj_tys1, noninj_tys1) = partitionByList inj tys1 + (inj_tys2, noninj_tys2) = partitionByList inj tys2 + + bind_fam_if_poss + | not (um_unif env) -- Not when matching (ATF11-1) + = return () + | under_forall -- Not under a forall (ATF3) + = return () + | BindMe <- um_bind_fam_fun env tc tys1 rhs1 + = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys1) rhs1) $ + extendFamEnv tc tys1 rhs1 + -- At this point um_unif=True, so we can unify either way + | BindMe <- um_bind_fam_fun env tc tys2 rhs2 + = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys2) rhs2) $ + extendFamEnv tc tys2 rhs2 + | otherwise + = return () + + rhs1 = mkTyConApp tc tys2 `mkCastTy` mkSymCo kco + rhs2 = mkTyConApp tc tys1 `mkCastTy` kco + + +uOccursCheck :: UMState + -> TyVarSet -- Bound by enclosing foralls; see (OCU1) + -> CanEqLHS -> Type -- Can we unify (lhs := ty)? + -> Bool +-- See Note [The occurs check in the Core unifier] and (ATF13) +uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) bvs lhs ty + = go bvs ty + where + go :: TyCoVarSet -- Bound by enclosing foralls; see (OCU1) + -> Type -> Bool + go bvs ty | Just ty' <- coreView ty = go bvs ty' + go bvs (TyVarTy tv) | Just ty' <- lookupVarEnv tv_env tv + = go bvs ty' + | TyVarLHS tv' <- lhs, tv==tv' + = True + | otherwise + = go bvs (tyVarKind tv) + go bvs (AppTy ty1 ty2) = go bvs ty1 || go bvs ty2 + go _ (LitTy {}) = False + go bvs (FunTy _ w arg res) = go bvs w || go bvs arg || go bvs res + go bvs (TyConApp tc tys) = go_tc bvs tc tys + + go bvs (ForAllTy (Bndr tv _) ty) + = go bvs (tyVarKind tv) || + (case lhs of + TyVarLHS tv' | tv==tv' -> False -- Shadowing + | otherwise -> go (bvs `extendVarSet` tv) ty + TyFamLHS {} -> False) -- Lookups don't happen under a forall + + go bvs (CastTy ty _co) = go bvs ty -- ToDo: should we worry about `co`? + go _ (CoercionTy _co) = False -- ToDo: should we worry about `co`? + + go_tc bvs tc tys + | isEmptyVarSet bvs -- Never look up in um_fam_env under a forall (ATF3) + , isTypeFamilyTyCon tc + , Just ty' <- lookupFamEnv fam_env tc (take arity tys) + -- NB: we look up /un-substituted/ types; + -- See Note [Shortcomings of the apartness test] + = go bvs ty' || any (go bvs) (drop arity tys) + + | TyFamLHS tc' tys' <- lhs + , tc == tc' + , tys `lengthAtLeast` arity -- Saturated, or over-saturated + , tcEqTyConAppArgs tys tys' + = True + + | otherwise + = any (go bvs) tys + where + arity = tyConArity tc + +{- Note [The occurs check in the Core unifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The unifier applies both substitutions (um_tv_env and um_fam_env) as it goes, +so we'll get an infinite loop if we have, for example + um_tv_env: a :-> F b -- (1) + um_fam_env F b :-> a -- (2) + +So (uOccursCheck substs lhs ty) returns True iff extending `substs` with `lhs :-> ty` +could lead to a loop. That is, could there by a type `s` such that + applySubsts( (substs + lhs:->ty), s ) is infinite + +It's vital that we do both at once: we might have (1) already and add (2); +or we might have (2) already and add (1). + +A very similar task is done by GHC.Tc.Utils.Unify.checkTyEqRhs. + +(OCU1) We keep track of the forall-bound variables because the um_fam_env is inactive + under a forall; indeed it is /unsound/ to consult it because we may have a binding + (F a :-> Int), and then unify (forall a. ...(F a)...) with something. We don't + want to map that (F a) to Int! + +(OCU2) Performance. Consider unifying + [a, b] ~ [big-ty, (a,a,a)] + We'll unify a:=big-ty. Then we'll attempt b:=(a,a,a), but must do an occurs check. + So we'll walk over big-ty, looking for `b`. And then again, and again, once for + each occurrence of `a`. A similar thing happens for + [a, (b,b,b)] ~ [big-ty, (a,a,a)] + albeit a bit less obviously. + + Potentially we could use a cache to record checks we have already done; + but I have not attempted that yet. Precisely similar remarks would apply + to GHC.Tc.Utils.Unify.checkTyEqRhs + +Note [Unifying coercion-foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we try to unify (forall cv. t1) ~ (forall cv. t2). +See Note [ForAllTy] in GHC.Core.TyCo.Rep. + +The problem with coercion variables is that coercion abstraction is not erased: +the `kco` shouldn't propagate from outside the ForAllTy to inside. Instead, I think +the correct new `kco` for the recursive call is `mkNomReflCo liftedTypeKind` (but I'm +a little worried it might be Constraint sometimes). + +This potential problem has been there a long time, and I'm going to let +sleeping dogs lie for now. +-} + +{- +************************************************************************ +* * + Unification monad +* * +************************************************************************ +-} + +data UMEnv + = UMEnv { um_unif :: AmIUnifying + + , um_inj_tf :: Bool + -- Checking for injectivity? + -- See (SI1) in Note [Specification of unification] + + , um_arr_mult :: MultiplicityFlag + -- Whether to unify multiplicity arguments when unifying arrows. + -- See Note [Rewrite rules ignore multiplicities in FunTy] + + , um_rn_env :: RnEnv2 + -- Renaming InTyVars to OutTyVars; this eliminates shadowing, and + -- lines up matching foralls on the left and right + -- See (CU2) in Note [The Core unifier] + + , um_foralls :: TyVarSet + -- OutTyVars bound by a forall in this unification; + -- Do not bind these in the substitution! + -- See the function tvBindFlag + + , um_bind_tv_fun :: BindTvFun + -- User-supplied BindFlag function, for variables not in um_foralls + -- See (CU1) in Note [The Core unifier] + + , um_bind_fam_fun :: BindFamFun + -- Similar to um_bind_tv_fun, but for type-family applications + -- See (ATF8) in Note [Apartness and type families] + } + +type FamSubstEnv = TyConEnv (ListMap TypeMap Type) + -- Map a TyCon and a list of types to a type + -- Domain of FamSubstEnv is exactly-saturated type-family + -- applications (F t1...tn) + +lookupFamEnv :: FamSubstEnv -> TyCon -> [Type] -> Maybe Type +lookupFamEnv env tc tys + = do { tys_map <- lookupTyConEnv env tc + ; lookupTM tys tys_map } + +data UMState = UMState + { um_tv_env :: TvSubstEnv + , um_cv_env :: CvSubstEnv + , um_fam_env :: FamSubstEnv } + -- um_tv_env, um_cv_env, um_fam_env are all "global" substitutions; + -- that is, neither their domains nor their ranges mention any variables + -- in um_foralls; i.e. variables bound by foralls inside the types being unified + + -- When /matching/ um_fam_env is usually empty; but not quite always. + -- See (ATF7) of Note [Apartness and type families] + +newtype UM a + = UM' { unUM :: UMState -> UnifyResultM (UMState, a) } + -- See Note [The one-shot state monad trick] in GHC.Utils.Monad + +pattern UM :: (UMState -> UnifyResultM (UMState, a)) -> UM a +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern UM m <- UM' m + where + UM m = UM' (oneShot m) +{-# COMPLETE UM #-} + +instance Functor UM where + fmap f (UM m) = UM (\s -> fmap (\(s', v) -> (s', f v)) (m s)) + +instance Applicative UM where + pure a = UM (\s -> pure (s, a)) + (<*>) = ap + +instance Monad UM where + {-# INLINE (>>=) #-} + -- See Note [INLINE pragmas and (>>)] in GHC.Utils.Monad + m >>= k = UM (\state -> + do { (state', v) <- unUM m state + ; unUM (k v) state' }) + +instance MonadFail UM where + fail _ = UM (\_ -> SurelyApart) -- failed pattern match + +initUM :: TvSubstEnv -- subst to extend + -> CvSubstEnv + -> UM () + -> UnifyResultM (TvSubstEnv, CvSubstEnv) +initUM subst_env cv_subst_env um + = case unUM um state of + Unifiable (state, _) -> Unifiable (get state) + MaybeApart r (state, _) -> MaybeApart r (get state) + SurelyApart -> SurelyApart + where + state = UMState { um_tv_env = subst_env + , um_cv_env = cv_subst_env + , um_fam_env = emptyTyConEnv } + get (UMState { um_tv_env = tv_env, um_cv_env = cv_env }) = (tv_env, cv_env) + +getTvSubstEnv :: UM TvSubstEnv +getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) + +getCvSubstEnv :: UM CvSubstEnv +getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) + +getSubstEnvs :: UM UMState +getSubstEnvs = UM $ \state -> Unifiable (state, state) + +getSubst :: UMEnv -> UM Subst +getSubst env = do { tv_env <- getTvSubstEnv + ; cv_env <- getCvSubstEnv + ; let in_scope = rnInScopeSet (um_rn_env env) + ; return (mkTCvSubst in_scope tv_env cv_env) } + +extendTvEnv :: TyVar -> Type -> UM () +extendTvEnv tv ty = UM $ \state -> + Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) + +extendCvEnv :: CoVar -> Coercion -> UM () +extendCvEnv cv co = UM $ \state -> + Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) + +extendFamEnv :: TyCon -> [Type] -> Type -> UM () +extendFamEnv tc tys ty = UM $ \state -> + Unifiable (state { um_fam_env = extend (um_fam_env state) tc }, ()) + where + extend :: FamSubstEnv -> TyCon -> FamSubstEnv + extend = alterTyConEnv alter_tm + + alter_tm :: Maybe (ListMap TypeMap Type) -> Maybe (ListMap TypeMap Type) + alter_tm m_elt = Just (alterTM tys (\_ -> Just ty) (m_elt `orElse` emptyTM)) + +umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv +umRnBndr2 env v1 v2 + = env { um_rn_env = rn_env', um_foralls = um_foralls env `extendVarSet` v' } + where + (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2 + +mentionsForAllBoundTyVarsL, mentionsForAllBoundTyVarsR :: UMEnv -> VarSet -> Bool +-- See (CU2) in Note [The Core unifier] +mentionsForAllBoundTyVarsL = mentions_forall_bound_tvs inRnEnvL +mentionsForAllBoundTyVarsR = mentions_forall_bound_tvs inRnEnvR + +mentions_forall_bound_tvs :: (RnEnv2 -> TyVar -> Bool) -> UMEnv -> VarSet -> Bool +mentions_forall_bound_tvs in_rn_env env varset + | isEmptyVarSet (um_foralls env) = False + | anyVarSet (in_rn_env (um_rn_env env)) varset = True + | otherwise = False + -- NB: That isEmptyVarSet guard is a critical optimization; + -- it means we don't have to calculate the free vars of + -- the type, often saving quite a bit of allocation. + +-- | Converts any SurelyApart to a MaybeApart +don'tBeSoSure :: MaybeApartReason -> UM () -> UM () +don'tBeSoSure r um = UM $ \ state -> + case unUM um state of + SurelyApart -> MaybeApart r (state, ()) + other -> other + +umRnOccL :: UMEnv -> TyVar -> TyVar +umRnOccL env v = rnOccL (um_rn_env env) v + +umRnOccR :: UMEnv -> TyVar -> TyVar +umRnOccR env v = rnOccR (um_rn_env env) v + +umSwapRn :: UMEnv -> UMEnv +umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } + +maybeApart :: MaybeApartReason -> UM () +maybeApart r = UM (\state -> MaybeApart r (state, ())) + +surelyApart :: UM a +surelyApart = UM (\_ -> SurelyApart) + +{- +%************************************************************************ +%* * + Matching a (lifted) type against a coercion +%* * +%************************************************************************ + +This section defines essentially an inverse to liftCoSubst. It is defined +here to avoid a dependency from Coercion on this module. + +-} + +data MatchEnv = ME { me_tmpls :: TyVarSet + , me_env :: RnEnv2 } + +-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if +-- @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@, +-- where @==@ there means that the result of 'liftCoSubst' has the same +-- type as the original co; but may be different under the hood. +-- That is, it matches a type against a coercion of the same +-- "shape", and returns a lifting substitution which could have been +-- used to produce the given coercion from the given type. +-- Note that this function is incomplete -- it might return Nothing +-- when there does indeed exist a possible lifting context. +-- +-- This function is incomplete in that it doesn't respect the equality +-- in `eqType`. That is, it's possible that this will succeed for t1 and +-- fail for t2, even when t1 `eqType` t2. That's because it depends on +-- there being a very similar structure between the type and the coercion. +-- This incompleteness shouldn't be all that surprising, especially because +-- it depends on the structure of the coercion, which is a silly thing to do. +-- +-- The lifting context produced doesn't have to be exacting in the roles +-- of the mappings. This is because any use of the lifting context will +-- also require a desired role. Thus, this algorithm prefers mapping to +-- nominal coercions where it can do so. +liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext +liftCoMatch tmpls ty co + = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co + ; cenv2 <- ty_co_match menv cenv1 ty co + (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) + ; return (LC (mkEmptySubst in_scope) cenv2) } + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) + -- Like tcMatchTy, assume all the interesting variables + -- in ty are in tmpls + + ki = typeKind ty + ki_co = promoteCoercion co + ki_ki_co = mkNomReflCo liftedTypeKind + + Pair co_lkind co_rkind = coercionKind ki_co + +-- | 'ty_co_match' does all the actual work for 'liftCoMatch'. +ty_co_match :: MatchEnv -- ^ ambient helpful info + -> LiftCoEnv -- ^ incoming subst + -> Type -- ^ ty, type to match + -> Coercion -- ^ co :: lty ~r rty, coercion to match against + -> Coercion -- ^ :: kind(lsubst(ty)) ~N kind(lty) + -> Coercion -- ^ :: kind(rsubst(ty)) ~N kind(rty) + -> Maybe LiftCoEnv + -- ^ Just env ==> liftCoSubst Nominal env ty == co, modulo roles. + -- Also: Just env ==> lsubst(ty) == lty and rsubst(ty) == rty, + -- where lsubst = lcSubstLeft(env) and rsubst = lcSubstRight(env) +ty_co_match menv subst ty co lkco rkco + | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco + + -- handle Refl case: + | tyCoVarsOfType ty `isNotInDomainOf` subst + , Just (ty', _) <- isReflCo_maybe co + , ty `eqType` ty' + -- Why `eqType` and not `tcEqType`? Because this function is only used + -- during coercion optimisation, after type-checking has finished. + = Just subst + + where + isNotInDomainOf :: VarSet -> VarEnv a -> Bool + isNotInDomainOf set env + = noneSet (\v -> elemVarEnv v env) set + + noneSet :: (Var -> Bool) -> VarSet -> Bool + noneSet f = allVarSet (not . f) + +ty_co_match menv subst ty co lkco rkco + | CastTy ty' co' <- ty + -- See Note [Matching in the presence of casts (1)] + = let empty_subst = mkEmptySubst (rnInScopeSet (me_env menv)) + substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' + substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' + in + ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco) + (substed_co_r `mkTransCo` rkco) + + | SymCo co' <- co + = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco + + -- Match a type variable against a non-refl coercion +ty_co_match menv subst (TyVarTy tv1) co lkco rkco + | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 + = if eqCoercionX (nukeRnEnvL rn_env) co1' co + then Just subst + else Nothing -- no match since tv1 matches two different coercions + + | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var + = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) + then Nothing -- occurs check failed + else Just $ extendVarEnv subst tv1' $ + castCoercionKind co (mkSymCo lkco) (mkSymCo rkco) + + | otherwise + = Nothing + + where + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 + + -- just look through SubCo's. We don't really care about roles here. +ty_co_match menv subst ty (SubCo co) lkco rkco + = ty_co_match menv subst ty co lkco rkco + +ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco + | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] +ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco + | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1 + -- yes, the one from Type, not TcType; this is for coercion optimization + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] + +ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco + = ty_co_match_tc menv subst tc1 tys tc2 cos + +ty_co_match menv subst (FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 }) + (FunCo { fco_mult = co_w, fco_arg = co1, fco_res = co2 }) _lkco _rkco + = ty_co_match_args menv subst [w, rep1, rep2, ty1, ty2] + [co_w, co1_rep, co2_rep, co1, co2] + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + co1_rep = mkRuntimeRepCo co1 + co2_rep = mkRuntimeRepCo co2 + -- NB: we include the RuntimeRep arguments in the matching; + -- not doing so caused #21205. + +ty_co_match menv subst (ForAllTy (Bndr tv1 vis1t) ty1) + (ForAllCo tv2 vis1c vis2c kind_co2 co2) + lkco rkco + | isTyVar tv1 && isTyVar tv2 + , vis1t == vis1c && vis1c == vis2c -- Is this necessary? + -- Is this visibility check necessary? @rae says: yes, I think the + -- check is necessary, if we're caring about visibility (and we are). + -- But ty_co_match is a dark and not important corner. + = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 + ki_ki_co ki_ki_co + ; let rn_env0 = me_env menv + rn_env1 = rnBndr2 rn_env0 tv1 tv2 + menv' = menv { me_env = rn_env1 } + ; ty_co_match menv' subst1 ty1 co2 lkco rkco } + where + ki_ki_co = mkNomReflCo liftedTypeKind + +-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1) +-- (ForAllCo cv2 kind_co2 co2) +-- lkco rkco +-- | isCoVar cv1 && isCoVar cv2 +-- We seems not to have enough information for this case +-- 1. Given: +-- cv1 :: (s1 :: k1) ~r (s2 :: k2) +-- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) +-- eta1 = mkSelCo (SelTyCon 2 role) (downgradeRole r Nominal kind_co2) +-- :: s1' ~ t1 +-- eta2 = mkSelCo (SelTyCon 3 role) (downgradeRole r Nominal kind_co2) +-- :: s2' ~ t2 +-- Wanted: +-- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 +-- subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4 +-- Question: How do we get kcoi? +-- 2. Given: +-- lkco :: <*> -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep +-- rkco :: <*> +-- Wanted: +-- ty_co_match menv' subst2 ty1 co2 lkco' rkco' +-- Question: How do we get lkco' and rkco'? + +ty_co_match _ subst (CoercionTy {}) _ _ _ + = Just subst -- don't inspect coercions + +ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco + = ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co) + +ty_co_match menv subst ty co1 lkco rkco + | Just (CastTy t co, r) <- isReflCo_maybe co1 + -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us + -- t |> co ~ t ; ; t ~ t |> co + -- But transitive coercions are not helpful. Therefore we deal + -- with it here: we do recursion on the smaller reflexive coercion, + -- while propagating the correct kind coercions. + = let kco' = mkSymCo co + in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco') + (rkco `mkTransCo` kco') + +ty_co_match menv subst ty co lkco rkco + | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco + | otherwise = Nothing + +ty_co_match_tc :: MatchEnv -> LiftCoEnv + -> TyCon -> [Type] + -> TyCon -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_tc menv subst tc1 tys1 tc2 cos2 + = do { guard (tc1 == tc2) + ; ty_co_match_args menv subst tys1 cos2 } + +ty_co_match_app :: MatchEnv -> LiftCoEnv + -> Type -> [Type] -> Coercion -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_app menv subst ty1 ty1args co2 co2args + | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1 + , Just (co2', co2a) <- splitAppCo_maybe co2 + = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) + + | otherwise + = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co + ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 + ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco + ; ty_co_match_args menv subst2 ty1args co2args } + where + ki1 = typeKind ty1 + ki2 = promoteCoercion co2 + ki_ki_co = mkNomReflCo liftedTypeKind + +ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_args menv subst (ty:tys) (arg:args) + = do { let Pair lty rty = coercionKind arg + lkco = mkNomReflCo (typeKind lty) + rkco = mkNomReflCo (typeKind rty) + ; subst' <- ty_co_match menv subst ty arg lkco rkco + ; ty_co_match_args menv subst' tys args } +ty_co_match_args _ subst [] [] = Just subst +ty_co_match_args _ _ _ _ = Nothing + +pushRefl :: Coercion -> Maybe Coercion +pushRefl co = + case (isReflCo_maybe co) of + Just (AppTy ty1 ty2, Nominal) + -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) + Just (FunTy af w ty1 ty2, r) + -> Just (FunCo r af af (mkReflCo r w) (mkReflCo r ty1) (mkReflCo r ty2)) + Just (TyConApp tc tys, r) + -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys)) + Just (ForAllTy (Bndr tv vis) ty, r) + -> Just (ForAllCo { fco_tcv = tv, fco_visL = vis, fco_visR = vis + , fco_kind = mkNomReflCo (varType tv) + , fco_body = mkReflCo r ty }) + _ -> Nothing diff --git a/GHC/Core/UsageEnv.hs b/GHC/Core/UsageEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/UsageEnv.hs @@ -0,0 +1,116 @@ +module GHC.Core.UsageEnv + ( Usage(..) + , UsageEnv + , addUE + , addUsage + , bottomUE + , deleteUE + , lookupUE + , popUE + , scaleUE + , scaleUsage + , supUE + , supUEs + , singleUsageUE + , zeroUE + ) where + +import Data.Foldable +import GHC.Prelude +import GHC.Core.Multiplicity +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- +-- * Usage environments +-- + +-- The typechecker and the linter output usage environments. See Note [Usages] +-- in Multiplicity. Every absent name being considered to map to 'Zero' of +-- 'Bottom' depending on a flag. See Note [Zero as a usage] in Multiplicity, see +-- Note [Bottom as a usage] in Multiplicity. + +data Usage = Zero | Bottom | MUsage Mult + +instance Outputable Usage where + ppr Zero = text "0" + ppr Bottom = text "Bottom" + ppr (MUsage x) = ppr x + +addUsage :: Usage -> Usage -> Usage +addUsage Zero x = x +addUsage x Zero = x +addUsage Bottom x = x +addUsage x Bottom = x +addUsage (MUsage x) (MUsage y) = MUsage $ mkMultAdd x y + +scaleUsage :: Mult -> Usage -> Usage +scaleUsage OneTy Bottom = Bottom +scaleUsage _ Zero = Zero +scaleUsage x Bottom = MUsage x +scaleUsage x (MUsage y) = MUsage $ mkMultMul x y + +-- For now, we use extra multiplicity Bottom for empty case. +data UsageEnv = UsageEnv !(NameEnv Mult) Bool + +-- | Record a single usage of an Id, i.e. {n: 1} +-- Exception: We do not record external names (both GlobalIds and top-level LocalIds) +-- because they're not relevant to linearity checking. +singleUsageUE :: Id -> UsageEnv +singleUsageUE x | isExternalName n = zeroUE + | otherwise = UsageEnv (unitNameEnv n OneTy) False + where n = getName x + +zeroUE, bottomUE :: UsageEnv +zeroUE = UsageEnv emptyNameEnv False + +bottomUE = UsageEnv emptyNameEnv True + +addUE :: UsageEnv -> UsageEnv -> UsageEnv +addUE (UsageEnv e1 b1) (UsageEnv e2 b2) = + UsageEnv (plusNameEnv_C mkMultAdd e1 e2) (b1 || b2) + +scaleUE :: Mult -> UsageEnv -> UsageEnv +scaleUE OneTy ue = ue +scaleUE w (UsageEnv e _) = + UsageEnv (mapNameEnv (mkMultMul w) e) False + +supUE :: UsageEnv -> UsageEnv -> UsageEnv +supUE (UsageEnv e1 False) (UsageEnv e2 False) = + UsageEnv (plusNameEnv_CD mkMultSup e1 ManyTy e2 ManyTy) False +supUE (UsageEnv e1 b1) (UsageEnv e2 b2) = UsageEnv (plusNameEnv_CD2 combineUsage e1 e2) (b1 && b2) + where combineUsage (Just x) (Just y) = mkMultSup x y + combineUsage Nothing (Just x) | b1 = x + | otherwise = ManyTy + combineUsage (Just x) Nothing | b2 = x + | otherwise = ManyTy + combineUsage Nothing Nothing = pprPanic "supUE" (ppr e1 <+> ppr e2) +-- Note: If you are changing this logic, check 'mkMultSup' in Multiplicity as well. + +-- Used with @f = '[]'@ and @f = 'NonEmpty'@ +supUEs :: Foldable f => f UsageEnv -> UsageEnv +supUEs = foldr supUE bottomUE + +-- INLINE to ensure specialization at use site, and to avoid multiple specialization on the same +-- type +{-# INLINE supUEs #-} + +deleteUE :: NamedThing n => UsageEnv -> n -> UsageEnv +deleteUE (UsageEnv e b) x = UsageEnv (delFromNameEnv e (getName x)) b + +-- | |lookupUE x env| returns the multiplicity assigned to |x| in |env|, if |x| is not +-- bound in |env|, then returns |Zero| or |Bottom|. +lookupUE :: NamedThing n => UsageEnv -> n -> Usage +lookupUE (UsageEnv e has_bottom) x = + case lookupNameEnv e (getName x) of + Just w -> MUsage w + Nothing -> if has_bottom then Bottom else Zero + +popUE :: NamedThing n => UsageEnv -> n -> (Usage, UsageEnv) +popUE ue x = (lookupUE ue x, deleteUE ue x) + +instance Outputable UsageEnv where + ppr (UsageEnv ne b) = text "UsageEnv:" <+> ppr ne <+> ppr b diff --git a/GHC/Core/Utils.hs b/GHC/Core/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Utils.hs @@ -0,0 +1,3066 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +-- | Commonly useful utilities for manipulating the Core language +module GHC.Core.Utils ( + -- * Constructing expressions + mkCast, mkCastMCo, mkPiMCo, + mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, + bindNonRec, needsCaseBinding, needsCaseBindingL, + mkAltExpr, mkDefaultCase, mkSingleAltCase, + + -- * Taking expressions apart + findDefault, addDefault, findAlt, isDefaultAlt, + mergeAlts, mergeCaseAlts, trimConArgs, + filterAlts, combineIdenticalAlts, refineDefaultAlt, + scaleAltsBy, + + -- * Properties of expressions + exprType, coreAltType, coreAltsType, + mkLamType, mkLamTypes, + mkFunctionType, + exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe, + trivial_expr_fold, + exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, + exprIsHNF, exprOkForSpeculation, exprOkToDiscard, exprOkForSpecEval, + exprIsWorkFree, exprIsConLike, + isCheapApp, isExpandableApp, isSaturatedConApp, + exprIsTickedString, exprIsTickedString_maybe, + exprIsTopLevelBindable, + exprIsUnaryClassFun, isUnaryClassId, + altsAreExhaustive, etaExpansionTick, + + -- * Equality + cheapEqExpr, cheapEqExpr', diffBinds, + + -- * Manipulating data constructors and types + exprToType, + applyTypeToArgs, + dataConRepInstPat, dataConRepFSInstPat, + isEmptyTy, normSplitTyConApp_maybe, + + -- * Working with ticks + stripTicksTop, stripTicksTopE, stripTicksTopT, + stripTicksE, stripTicksT, + + -- * InScopeSet things which work over CoreBinds + mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs, + + -- * StaticPtr + collectMakeStaticArgs, + + -- * Join points + isJoinBind, + + -- * Tag inference + mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId, + + -- * unsafeEqualityProof + isUnsafeEqualityCase, + + -- * Dumping stuff + dumpIdInfoOfProgram + ) where + +import GHC.Prelude +import GHC.Platform + +import GHC.Core +import GHC.Core.Ppr +import GHC.Core.FVs( bindFreeVars ) +import GHC.Core.DataCon +import GHC.Core.Type as Type +import GHC.Core.Predicate( isEqPred ) +import GHC.Core.Predicate( isUnaryClass ) +import GHC.Core.FamInstEnv +import GHC.Core.TyCo.Compare( eqType, eqTypeX ) +import GHC.Core.Coercion +import GHC.Core.Reduction +import GHC.Core.TyCon +import GHC.Core.Multiplicity + +import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey, unsafeReflDataConKey ) +import GHC.Builtin.PrimOps + +import GHC.Types.Var +import GHC.Types.SrcLoc +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Literal +import GHC.Types.Tickish +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Basic( Arity ) +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Demand +import GHC.Types.RepType (isZeroBitTy) + +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.List.SetOps( minusList ) +import GHC.Data.OrdList + +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import Data.ByteString ( ByteString ) +import Data.Function ( on ) +import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL ) +import qualified Data.List as Partial ( init, last ) +import Data.Ord ( comparing ) +import Control.Monad ( guard ) +import qualified Data.Set as Set + +{- +************************************************************************ +* * +\subsection{Find the type of a Core atom/expression} +* * +************************************************************************ +-} + +exprType :: HasDebugCallStack => CoreExpr -> Type +-- ^ Recover the type of a well-typed Core expression. Fails when +-- applied to the actual 'GHC.Core.Type' expression as it cannot +-- really be said to have a type +exprType (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Coercion co) = coercionType co +exprType (Let bind body) + | NonRec tv rhs <- bind -- See Note [Type bindings] + , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) + | otherwise = exprType body +exprType (Case _ _ ty _) = ty +exprType (Cast _ co) = coercionRKind co +exprType (Tick _ e) = exprType e +exprType (Lam binder expr) = mkLamType binder (exprType expr) +exprType e@(App _ _) + = case collectArgs e of + (fun, args) -> applyTypeToArgs (exprType fun) args +exprType (Type ty) = pprPanic "exprType" (ppr ty) + +coreAltType :: CoreAlt -> Type +-- ^ Returns the type of the alternatives right hand side +coreAltType alt@(Alt _ bs rhs) + = case occCheckExpand bs rhs_ty of + -- Note [Existential variables and silly type synonyms] + Just ty -> ty + Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty) + where + rhs_ty = exprType rhs + +coreAltsType :: [CoreAlt] -> Type +-- ^ Returns the type of the first alternative, which should be the same as for all alternatives +coreAltsType (alt:_) = coreAltType alt +coreAltsType [] = panic "coreAltsType" + +mkLamType :: HasDebugCallStack => Var -> Type -> Type +-- ^ Makes a @(->)@ type or an implicit forall type, depending +-- on whether it is given a type variable or a term variable. +-- This is used, for example, when producing the type of a lambda. +-- +mkLamTypes :: [Var] -> Type -> Type +-- ^ 'mkLamType' for multiple type or value arguments + +mkLamType v body_ty + | isTyVar v + = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty + -- coreTyLamForAllTyFlag: see Note [Required foralls in Core] + -- in GHC.Core.TyCo.Rep + + | isCoVar v + , v `elemVarSet` tyCoVarsOfType body_ty + -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep + = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty + + | otherwise + = mkFunctionType (idMult v) (idType v) body_ty + +mkLamTypes vs ty = foldr mkLamType ty vs + +{- +Note [Type bindings] +~~~~~~~~~~~~~~~~~~~~ +Core does allow type bindings, although such bindings are +not much used, except in the output of the desugarer. +Example: + let a = Int in (\x:a. x) +Given this, exprType must be careful to substitute 'a' in the +result type (#8522). + +Note [Existential variables and silly type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = forall a. T (Funny a) + type Funny a = Bool + f :: T -> Bool + f (T x) = x + +Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. +That means that 'exprType' and 'coreAltsType' may give a result that *appears* +to mention an out-of-scope type variable. See #3409 for a more real-world +example. + +Various possibilities suggest themselves: + + - Ignore the problem, and make Lint not complain about such variables + + - Expand all type synonyms (or at least all those that discard arguments) + This is tricky, because at least for top-level things we want to + retain the type the user originally specified. + + - Expand synonyms on the fly, when the problem arises. That is what + we are doing here. It's not too expensive, I think. + +Note that there might be existentially quantified coercion variables, too. +-} + +applyTypeToArgs :: HasDebugCallStack => Type -> [CoreExpr] -> Type +-- ^ Determines the type resulting from applying an expression with given type +--- to given argument expressions. +applyTypeToArgs op_ty args + = go op_ty args + where + go op_ty [] = op_ty + go op_ty (Type ty : args) = go_ty_args op_ty [ty] args + go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args + go op_ty (_ : args) | Just (_, _, _, res_ty) <- splitFunTy_maybe op_ty + = go res_ty args + go _ args = pprPanic "applyTypeToArgs" (panic_msg args) + + -- go_ty_args: accumulate type arguments so we can + -- instantiate all at once with piResultTys + go_ty_args op_ty rev_tys (Type ty : args) + = go_ty_args op_ty (ty:rev_tys) args + go_ty_args op_ty rev_tys (Coercion co : args) + = go_ty_args op_ty (mkCoercionTy co : rev_tys) args + go_ty_args op_ty rev_tys args + = go (piResultTys op_ty (reverse rev_tys)) args + + panic_msg as = vcat [ text "Type:" <+> ppr op_ty + , text "Args:" <+> ppr args + , text "Args':" <+> ppr as ] + +mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr +mkCastMCo e MRefl = e +mkCastMCo e (MCo co) = Cast e co + -- We are careful to use (MCo co) only when co is not reflexive + -- Hence (Cast e co) rather than (mkCast e co) + +mkPiMCo :: Var -> MCoercionR -> MCoercionR +mkPiMCo _ MRefl = MRefl +mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co) + + +{- ********************************************************************* +* * + Casts +* * +********************************************************************* -} + +-- | Wrap the given expression in the coercion safely, dropping +-- identity coercions and coalescing nested coercions +mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr + +mkCast expr co + = assertPpr (coercionRole co == Representational) + (text "coercion" <+> ppr co <+> text "passed to mkCast" + <+> ppr expr <+> text "has wrong role" <+> ppr (coercionRole co)) $ + warnPprTrace (not (coercionLKind co `eqType` exprType expr)) + "Trying to coerce" (text "(" <> ppr expr + $$ text "::" <+> ppr (exprType expr) <> text ")" + $$ ppr co $$ ppr (coercionType co) + $$ callStackDoc) $ + case expr of + Cast expr co2 -> mkCast expr (mkTransCo co2 co) + Tick t expr -> Tick t (mkCast expr co) + + Coercion e_co | isEqPred (coercionRKind co) + -- The guard here checks that g has a (~#) on both sides, + -- otherwise decomposeCo fails. Can in principle happen + -- with unsafeCoerce + -> Coercion (mkCoCast e_co co) + + _ | isReflCo co -> expr + | otherwise -> Cast expr co + + +{- ********************************************************************* +* * + Attaching ticks +* * +********************************************************************* -} + +-- | Wraps the given expression in the source annotation, dropping the +-- annotation if possible. +mkTick :: CoreTickish -> CoreExpr -> CoreExpr +mkTick t orig_expr = mkTick' id id orig_expr + where + -- Some ticks (cost-centres) can be split in two, with the + -- non-counting part having laxer placement properties. + canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + -- mkTick' handles floating of ticks *into* the expression. + -- In this function, `top` is applied after adding the tick, and `rest` before. + -- This will result in applications that look like (top $ Tick t $ rest expr). + -- If we want to push the tick deeper, we pre-compose `top` with a function + -- adding the tick. + mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through) + -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with) + -> CoreExpr -- current expression + -> CoreExpr + mkTick' top rest expr = case expr of + -- Float ticks into unsafe coerce the same way we would do with a cast. + Case scrut bndr ty alts@[Alt ac abs _rhs] + | Just rhs <- isUnsafeEqualityCase scrut bndr alts + -> top $ mkTick' (\e -> Case scrut bndr ty [Alt ac abs e]) rest rhs + + -- Cost centre ticks should never be reordered relative to each + -- other. Therefore we can stop whenever two collide. + Tick t2 e + | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr + + -- Otherwise we assume that ticks of different placements float + -- through each other. + | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e + + -- For annotations this is where we make sure to not introduce + -- redundant ticks. + | tickishContains t t2 -> mkTick' top rest e + | tickishContains t2 t -> orig_expr + | otherwise -> mkTick' top (rest . Tick t2) e + + -- Ticks don't care about types, so we just float all ticks + -- through them. Note that it's not enough to check for these + -- cases top-level. While mkTick will never produce Core with type + -- expressions below ticks, such constructs can be the result of + -- unfoldings. We therefore make an effort to put everything into + -- the right place no matter what we start with. + Cast e co -> mkTick' (top . flip Cast co) rest e + Coercion co -> Coercion co + + Lam x e + -- Always float through type lambdas. Even for non-type lambdas, + -- floating is allowed for all but the most strict placement rule. + | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime + -> mkTick' (top . Lam x) rest e + + -- If it is both counting and scoped, we split the tick into its + -- two components, often allowing us to keep the counting tick on + -- the outside of the lambda and push the scoped tick inside. + -- The point of this is that the counting tick can probably be + -- floated, and the lambda may then be in a position to be + -- beta-reduced. + | canSplit + -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + + App f arg + -- Always float through type applications. + | not (isRuntimeArg arg) + -> mkTick' (top . flip App arg) rest f + + -- We can also float through constructor applications, placement + -- permitting. Again we can split. + | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) + -> if tickishPlace t == PlaceCostCentre + then top $ rest $ tickHNFArgs t expr + else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + + Var x + | notFunction && tickishPlace t == PlaceCostCentre + -> orig_expr + | notFunction && canSplit + -> top $ Tick (mkNoScope t) $ rest expr + where + -- SCCs can be eliminated on variables provided the variable + -- is not a function. In these cases the SCC makes no difference: + -- the cost of evaluating the variable will be attributed to its + -- definition site. When the variable refers to a function, however, + -- an SCC annotation on the variable affects the cost-centre stack + -- when the function is called, so we must retain those. + notFunction = not (isFunTy (idType x)) + + Lit{} + | tickishPlace t == PlaceCostCentre + -> orig_expr + + -- Catch-all: Annotate where we stand + _any -> top $ Tick t $ rest expr + +mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr +mkTicks ticks expr = foldr mkTick expr ticks + +isSaturatedConApp :: CoreExpr -> Bool +isSaturatedConApp e = go e [] + where go (App f a) as = go f (a:as) + go (Var fun) args + = isConLikeId fun && idArity fun == valArgCount args + go (Cast f _) as = go f as + go _ _ = False + +mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr +mkTickNoHNF t e + | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e + +-- push a tick into the arguments of a HNF (call or constructor app) +tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr +tickHNFArgs t e = push t e + where + push t (App f (Type u)) = App (push t f) (Type u) + push t (App f arg) = App (push t f) (mkTick t arg) + push _t e = e + +-- | Strip ticks satisfying a predicate from top of an expression +stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b) +stripTicksTop p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts other = (reverse ts, other) + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the remaining expression +stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b +stripTicksTopE p = go + where go (Tick t e) | p t = go e + go other = other + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the ticks +stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] +stripTicksTopT p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts _ = ts + +-- | Completely strip ticks satisfying a predicate from an +-- expression. Note this is O(n) in the size of the expression! +stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b +stripTicksE p expr = go expr + where go (App e a) = App (go e) (go a) + go (Lam b e) = Lam b (go e) + go (Let b e) = Let (go_bs b) (go e) + go (Case e b t as) = Case (go e) b t (map go_a as) + go (Cast e c) = Cast (go e) c + go (Tick t e) + | p t = go e + | otherwise = Tick t (go e) + go other = other + go_bs (NonRec b e) = NonRec b (go e) + go_bs (Rec bs) = Rec (map go_b bs) + go_b (b, e) = (b, go e) + go_a (Alt c bs e) = Alt c bs (go e) + +stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] +stripTicksT p expr = fromOL $ go expr + where go (App e a) = go e `appOL` go a + go (Lam _ e) = go e + go (Let b e) = go_bs b `appOL` go e + go (Case e _ _ as) = go e `appOL` concatOL (map go_a as) + go (Cast e _) = go e + go (Tick t e) + | p t = t `consOL` go e + | otherwise = go e + go _ = nilOL + go_bs (NonRec _ e) = go e + go_bs (Rec bs) = concatOL (map go_b bs) + go_b (_, e) = go e + go_a (Alt _ _ e) = go e + +{- +************************************************************************ +* * +\subsection{Other expression construction} +* * +************************************************************************ +-} + +bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr +-- ^ @bindNonRec x r b@ produces either: +-- +-- > let x = r in b +-- +-- or: +-- +-- > case r of x { _DEFAULT_ -> b } +-- +-- depending on whether we have to use a @case@ or @let@ +-- binding for the expression (see 'needsCaseBinding'). +-- It's used by the desugarer to avoid building bindings +-- that give Core Lint a heart attack, although actually +-- the simplifier deals with them perfectly well. See +-- also 'GHC.Core.Make.mkCoreLet' +bindNonRec bndr rhs body + | isTyVar bndr = let_bind + | isCoVar bndr = if isCoArg rhs then let_bind + {- See Note [Binding coercions] -} else case_bind + | isJoinId bndr = let_bind + | needsCaseBinding (idType bndr) rhs = case_bind + | otherwise = let_bind + where + case_bind = mkDefaultCase rhs bndr body + let_bind = Let (NonRec bndr rhs) body + +-- | `needsCaseBinding` tests whether we have to use a @case@ rather than @let@ +-- binding for this expression as per the invariants of 'CoreExpr': see +-- "GHC.Core#let_can_float_invariant" +-- (needsCaseBinding ty rhs) requires that `ty` has a well-defined levity, else +-- `typeLevity ty` will fail; but that should be the case because +-- `needsCaseBinding` is only called once typechecking is complete +needsCaseBinding :: HasDebugCallStack => Type -> CoreExpr -> Bool +needsCaseBinding ty rhs = needsCaseBindingL (typeLevity ty) rhs + +needsCaseBindingL :: Levity -> CoreExpr -> Bool +-- True <=> make a case expression instead of a let +-- These can arise either from the desugarer, +-- or from beta reductions: (\x.e) (x +# y) +needsCaseBindingL Lifted _rhs = False +needsCaseBindingL Unlifted rhs = not (exprOkForSpeculation rhs) + +mkAltExpr :: AltCon -- ^ Case alternative constructor + -> [CoreBndr] -- ^ Things bound by the pattern match + -> [Type] -- ^ The type arguments to the case alternative + -> CoreExpr +-- ^ This guy constructs the value that the scrutinee must have +-- given that you are in one particular branch of a case +mkAltExpr (DataAlt con) args inst_tys + = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) +mkAltExpr (LitAlt lit) [] [] + = Lit lit +mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" +mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" + +mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr +-- Make (case x of y { DEFAULT -> e } +mkDefaultCase scrut case_bndr body + = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body] + +mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr +-- Use this function if possible, when building a case, +-- because it ensures that the type on the Case itself +-- doesn't mention variables bound by the case +-- See Note [Care with the type of a case expression] +mkSingleAltCase scrut case_bndr con bndrs body + = Case scrut case_bndr case_ty [Alt con bndrs body] + where + body_ty = exprType body + + case_ty -- See Note [Care with the type of a case expression] + | Just body_ty' <- occCheckExpand bndrs body_ty + = body_ty' + + | otherwise + = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty) + +{- Note [Care with the type of a case expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a phantom type synonym + type S a = Int +and we want to form the case expression + case x of K (a::*) -> (e :: S a) + +We must not make the type field of the case-expression (S a) because +'a' isn't in scope. Hence the call to occCheckExpand. This caused +issue #17056. + +NB: this situation can only arise with type synonyms, which can +falsely "mention" type variables that aren't "really there", and which +can be eliminated by expanding the synonym. + +Note [Binding coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider binding a CoVar, c = e. Then, we must satisfy +Note [Core type and coercion invariant] in GHC.Core, +which allows only (Coercion co) on the RHS. + +************************************************************************ +* * + Operations over case alternatives +* * +************************************************************************ + +The default alternative must be first, if it exists at all. +This makes it easy to find, though it makes matching marginally harder. +-} + +-- | Extract the default case alternative +findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b)) +findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs) +findDefault alts = (alts, Nothing) + +addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b] +addDefault alts Nothing = alts +addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts + +isDefaultAlt :: Alt b -> Bool +isDefaultAlt (Alt DEFAULT _ _) = True +isDefaultAlt _ = False + +-- | Find the case alternative corresponding to a particular +-- constructor: panics if no such constructor exists +findAlt :: AltCon -> [Alt b] -> Maybe (Alt b) + -- A "Nothing" result *is* legitimate + -- See Note [Unreachable code] +findAlt con alts + = case alts of + (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt) + _ -> go alts Nothing + where + go [] deflt = deflt + go (alt@(Alt con1 _ _) : alts) deflt + = case con `cmpAltCon` con1 of + LT -> deflt -- Missed it already; the alts are in increasing order + EQ -> Just alt + GT -> assert (not (con1 == DEFAULT)) $ go alts deflt + +{- Note [Unreachable code] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible (although unusual) for GHC to find a case expression +that cannot match. For example: + + data Col = Red | Green | Blue + x = Red + f v = case x of + Red -> ... + _ -> ...(case x of { Green -> e1; Blue -> e2 })... + +Suppose that for some silly reason, x isn't substituted in the case +expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff +gets in the way; cf #3118.) Then the full-laziness pass might produce +this + + x = Red + lvl = case x of { Green -> e1; Blue -> e2 }) + f v = case x of + Red -> ... + _ -> ...lvl... + +Now if x gets inlined, we won't be able to find a matching alternative +for 'Red'. That's because 'lvl' is unreachable. So rather than crashing +we generate (error "Inaccessible alternative"). + +Similar things can happen (augmented by GADTs) when the Simplifier +filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase. +-} + +--------------------------------- +mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt]) +-- See Note [Merge Nested Cases] +mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) + | Just (joins, inner_alts) <- go deflt_rhs + = Just (joins, mergeAlts outer_alts inner_alts) + -- NB: mergeAlts gives priority to the left + -- case x of + -- A -> e1 + -- DEFAULT -> case x of + -- A -> e2 + -- B -> e3 + -- When we merge, we must ensure that e1 takes + -- precedence over e2 as the value for A! + where + go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt]) + + -- Whizzo: we can merge! + go (Case (Var inner_scrut_var) inner_bndr _ inner_alts) + | inner_scrut_var == outer_bndr + , not (inner_bndr == outer_bndr) -- Avoid shadowing + , let wrap_let rhs' = Let (NonRec inner_bndr (Var outer_bndr)) rhs' + -- inner_bndr is never dead! It's the scrutinee! + -- The let is OK even for unboxed binders + -- See Note [Merge Nested Cases] wrinkle (MC2) + do_one (Alt con bndrs rhs) + | any (== outer_bndr) bndrs = Nothing + | otherwise = Just (Alt con bndrs (wrap_let rhs)) + = do { alts' <- mapM do_one inner_alts + ; return ([], alts') } + + -- Deal with tagToEnum# See Note [Merge Nested Cases] wrinkle (MC3) + go (App (App (Var f) (Type type_arg)) (Var v)) + | v == outer_bndr + , Just TagToEnumOp <- isPrimOpId_maybe f + , Just tc <- tyConAppTyCon_maybe type_arg + , Just (dc1:dcs) <- tyConDataCons_maybe tc -- At least one data constructor + , dcs `lengthAtMost` 3 -- Arbitrary + = return ( [], mk_alts dc1 dcs) + where + mk_lit dc = mkLitIntUnchecked $ toInteger $ dataConTagZ dc + mk_rhs dc = Var (dataConWorkId dc) + mk_alts dc1 dcs = Alt DEFAULT [] (mk_rhs dc1) + : [Alt (LitAlt (mk_lit dc)) [] (mk_rhs dc) | dc <- dcs] + + -- Float out let/join bindings + -- See Note [Merge Nested Cases] wrinkle (MC4) + go (Let bind body) + | null outer_alts || isJoinBind bind + = do { (joins, alts) <- go body + + -- Check for capture; but only if we could otherwise do a merge + ; let capture = outer_bndr `elem` bindersOf bind + || outer_bndr `elemVarSet` bindFreeVars bind + ; guard (not capture) + + ; return (bind:joins, alts ) } + | otherwise + = Nothing + + -- We don't want ticks to get in the way; just push them inwards. + -- (This happens when you add SourceTicks e.g. GHC.Num.Integer.integerLt#) + go (Tick t body) + = do { (joins, alts) <- go body + ; return (joins, [Alt con bs (Tick t rhs) | Alt con bs rhs <- alts]) } + + go _ = Nothing + +mergeCaseAlts _ _ = Nothing + +--------------------------------- +mergeAlts :: [Alt a] -> [Alt a] -> [Alt a] +-- ^ Merge alternatives preserving order; alternatives in +-- the first argument shadow ones in the second +mergeAlts [] as2 = as2 +mergeAlts as1 [] = as1 +mergeAlts (a1:as1) (a2:as2) + = case a1 `cmpAlt` a2 of + LT -> a1 : mergeAlts as1 (a2:as2) + EQ -> a1 : mergeAlts as1 as2 -- Discard a2 + GT -> a2 : mergeAlts (a1:as1) as2 + + +--------------------------------- +trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] +-- ^ Given: +-- +-- > case (C a b x y) of +-- > C b x y -> ... +-- +-- We want to drop the leading type argument of the scrutinee +-- leaving the arguments to match against the pattern + +trimConArgs DEFAULT args = assert (null args) [] +trimConArgs (LitAlt _) args = assert (null args) [] +trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args + +filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities) + -> [Type] -- ^ And its type arguments + -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee + -> [Alt b] -- ^ Alternatives + -> ([AltCon], [Alt b]) + -- Returns: + -- 1. Constructors that will never be encountered by the + -- *default* case (if any). A superset of imposs_cons + -- 2. The new alternatives, trimmed by + -- a) remove imposs_cons + -- b) remove constructors which can't match because of GADTs + -- + -- NB: the final list of alternatives may be empty: + -- This is a tricky corner case. If the data type has no constructors, + -- which GHC allows, or if the imposs_cons covers all constructors (after taking + -- account of GADTs), then no alternatives can match. + -- + -- If callers need to preserve the invariant that there is always at least one branch + -- in a "case" statement then they will need to manually add a dummy case branch that just + -- calls "error" or similar. +filterAlts _tycon inst_tys imposs_cons alts + = imposs_deflt_cons `seqList` + (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) + -- Very important to force `imposs_deflt_cons` as that forces `alt_cons`, which + -- is essentially as retaining `alts_wo_default` or any `Alt b` for that matter + -- leads to a huge space leak (see #22102 and !8896) + where + (alts_wo_default, maybe_deflt) = findDefault alts + alt_cons = [con | Alt con _ _ <- alts_wo_default] + + trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default + + imposs_cons_set = Set.fromList imposs_cons + imposs_deflt_cons = + imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons + -- "imposs_deflt_cons" are handled + -- EITHER by the context, + -- OR by a non-DEFAULT branch in this case expression. + + impossible_alt :: [Type] -> Alt b -> Bool + impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True + impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con + impossible_alt _ _ = False + +-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. +-- See Note [Refine DEFAULT case alternatives] +refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders + -> Mult -- ^ Multiplicity annotation of the case expression + -> TyCon -- ^ Type constructor of scrutinee's type + -> [Type] -- ^ Type arguments of scrutinee's type + -> [AltCon] -- ^ Constructors that cannot match the DEFAULT (if any) + -> [CoreAlt] + -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' +refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts + | Alt DEFAULT _ rhs : rest_alts <- all_alts + , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. + , not (isNewTyCon tycon) -- Exception 1 in Note [Refine DEFAULT case alternatives] + , not (isTypeDataTyCon tycon) -- Exception 2 in Note [Refine DEFAULT case alternatives] + , Just all_cons <- tyConDataCons_maybe tycon + , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons] + -- We now know it's a data type, so we can use + -- UniqSet rather than Set (more efficient) + impossible con = con `elementOfUniqSet` imposs_data_cons + || dataConCannotMatch tys con + = case filterOut impossible all_cons of + -- Eliminate the default alternative + -- altogether if it can't match: + [] -> (False, rest_alts) + + -- It matches exactly one constructor, so fill it in: + [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs]) + -- We need the mergeAlts to keep the alternatives in the right order + where + (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys + + -- It matches more than one, so do nothing + _ -> (False, all_alts) + + | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon) + , not (isFamilyTyCon tycon || isAbstractTyCon tycon) + -- Check for no data constructors + -- This can legitimately happen for abstract types and type families, + -- so don't report that + = (False, all_alts) + + | otherwise -- The common case + = (False, all_alts) + +{- Note [Merge Nested Cases] +~~~~~~~~~~~~~~~~~~~~~~~~~ + case e of b { ==> case e of b { + p1 -> rhs1 p1 -> rhs1 + ... ... + pm -> rhsm pm -> rhsm + _ -> case b of b' { pn -> let b'=b in rhsn + pn -> rhsn ... + ... po -> let b'=b in rhso + po -> rhso _ -> let b'=b in rhsd + _ -> rhsd + } + +which merges two cases in one case when -- the default alternative of +the outer case scrutinises the same variable as the outer case. This +transformation is called Case Merging. It avoids that the same +variable is scrutinised multiple times. + +Wrinkles + +(MC1) Historical note. I tried making `mergeCaseAlts` "looks though" an inner + single-alternative case-on-variable. For example + case x of { + ...outer-alts... + DEFAULT -> case y of (a,b) -> + case x of { A -> rhs1; B -> rhs2 } + ===> + case x of + ...outer-alts... + a -> case y of (a,b) -> rhs1 + B -> case y of (a,b) -> rhs2 + + This duplicates the `case y` but it removes the case x; so it is a win + in terms of execution time (combining the cases on x) at the cost of + perhaps duplicating the `case y`. A case in point is integerEq, which + is defined thus + integerEq :: Integer -> Integer -> Bool + integerEq !x !y = isTrue# (integerEq# x y) + which becomes + integerEq + = \ (x :: Integer) (y_aAL :: Integer) -> + case x of x1 { __DEFAULT -> + case y of y1 { __DEFAULT -> + case x1 of { + IS x2 -> case y1 of { + __DEFAULT -> GHC.Types.False; + IS y2 -> tagToEnum# @Bool (==# x2 y2) }; + IP x2 -> ... + IN x2 -> ... + We want to merge the outer `case x` with the inner `case x1`. + + But (a) this is all a bit dubious: see #24251, and + (b) it is hard to combine with (MC4) + So I'm not doing this any more. If we want to do it, we'll handle it + separately: #24251. + + End of historical note + +(MC2) The auxiliary bindings b'=b are annoying, because they force another + simplifier pass, but there seems no easy way to avoid them. See + Note [Which transformations are innocuous] in GHC.Core.Opt.Stats. + +(MC3) Consider + case f x of (r::Int#) -> tagToEnum# r :: Bool + `mergeCaseAlts` as a special case to treat this as if it was + case f x of r -> + case r of { 0# -> False; 1# -> True } + which can be merged to + case f x of { 0# -> False; 1# -> True } + + To see why this is important, return to + case f x of (r::Int#) -> tagToEnum# r :: Bool + and supppose `f` inlines to a case expression. Then then we get + let $j r = tagToEnum# r + case .. of { .. jump $j 0#; ...jump $j 1# ... } + Now if the entire expression is consumed by another case-expression, + that outer case will only see (tagToEnum# r) which it can't do much + with. Whereas the result of the above case-merge generates much better + code: no branching on Int# + +(MC4) Consider + case f x of r -> + join $j y = in + case r of { ...alts ... } + This is pretty common, and it a pity for it to defeat the case-merge + transformation; and it makes the optimiser fragile to inlining decisions + for join points. + + So `mergeCaseAlts` floats out any join points. It doesn't float out + non-join-points unless the /outer/ case has just one alternative; doing + so would risk more allocation + +(MC5) See Note [Cascading case merge] + +See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils + + +Note [Cascading case merge] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case merging should cascade in one sweep, because the Simplifier tries it /after/ +simplifying (and hence case-merging) the inner case. For example + + case e of a { + DEFAULT -> case a of b + DEFAULT -> case b of c { + DEFAULT -> e + A -> ea + B -> eb + C -> ec +==> {simplify inner case} + case e of a { + DEFAULT -> case a of b + DEFAULT -> let c = b in e + A -> let c = b in ea + B -> eb + C -> ec +==> {case-merge on outer case} + case e of a { + DEFAULT -> let b = a in let c = b in e + A -> let b = a in let c = b in ea + B -> let b = a in eb + C -> ec + + +However here's a tricky case that we still don't catch, and I don't +see how to catch it in one pass: + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +After occurrence analysis (and its binder-swap) we get this + + case x of c1 { I# a1 -> + let x = c1 in -- Binder-swap addition + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +When we simplify the inner case x, we'll see that +x=c1=I# a1. So we'll bind a2 to a1, and get + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case a1 of ... + +This is correct, but we can't do a case merge in this sweep +because c2 /= a1. Reason: the binding c1=I# a1 went inwards +without getting changed to c1=I# c2. + +I don't think this is worth fixing, even if I knew how. It'll +all come out in the next pass anyway. + + +Note [Refine DEFAULT case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +refineDefaultAlt replaces the DEFAULT alt with a constructor if there +is one possible value it could be. + +The simplest example being + foo :: () -> () + foo x = case x of !_ -> () +which rewrites to + foo :: () -> () + foo x = case x of () -> () + +There are two reasons in general why replacing a DEFAULT alternative +with a specific constructor is desirable. + +1. We can simplify inner expressions. For example + + data Foo = Foo1 () + + test :: Foo -> () + test x = case x of + DEFAULT -> mid (case x of + Foo1 x1 -> x1) + + refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then + x becomes bound to `Foo ip1` so is inlined into the other case + which causes the KnownBranch optimisation to kick in. If we don't + refine DEFAULT to `Foo ip1`, we are left with both case expressions. + +2. combineIdenticalAlts does a better job. For example (Simon Jacobi) + data D = C0 | C1 | C2 + + case e of + DEFAULT -> e0 + C0 -> e1 + C1 -> e1 + + When we apply combineIdenticalAlts to this expression, it can't + combine the alts for C0 and C1, as we already have a default case. + But if we apply refineDefaultAlt first, we get + case e of + C0 -> e1 + C1 -> e1 + C2 -> e0 + and combineIdenticalAlts can turn that into + case e of + DEFAULT -> e1 + C2 -> e0 + + It isn't obvious that refineDefaultAlt does this but if you look + at its one call site in GHC.Core.Opt.Simplify.Utils then the + `imposs_deflt_cons` argument is populated with constructors which + are matched elsewhere. + +There are two exceptions where we avoid refining a DEFAULT case: + +* Exception 1: Newtypes + + We can have a newtype, if we are just doing an eval: + + case x of { DEFAULT -> e } + + And we don't want to fill in a default for them! + +* Exception 2: `type data` declarations + + The data constructors for a `type data` declaration (see + Note [Type data declarations] in GHC.Rename.Module) do not exist at the + value level. Nevertheless, it is possible to strictly evaluate a value + whose type is a `type data` declaration. Test case + type-data/should_compile/T2294b.hs contains an example: + + type data T a where + A :: T Int + + f :: T a -> () + f !x = () + + We want to generate the following Core for f: + + f = \(@a) (x :: T a) -> + case x of + __DEFAULT -> () + + Namely, we do _not_ want to match on `A`, as it doesn't exist at the value + level! See wrinkle (W2b) in Note [Type data declarations] in GHC.Rename.Module + + +Note [Combine identical alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If several alternatives are identical, merge them into a single +DEFAULT alternative. I've occasionally seen this making a big +difference: + + case e of =====> case e of + C _ -> f x D v -> ....v.... + D v -> ....v.... DEFAULT -> f x + DEFAULT -> f x + +The point is that we merge common RHSs, at least for the DEFAULT case. +[One could do something more elaborate but I've never seen it needed.] +To avoid an expensive test, we just merge branches equal to the *first* +alternative; this picks up the common cases + a) all branches equal + b) some branches equal to the DEFAULT (which occurs first) + +The case where Combine Identical Alternatives transformation showed up +was like this (base/Foreign/C/Err/Error.hs): + + x | p `is` 1 -> e1 + | p `is` 2 -> e2 + ...etc... + +where @is@ was something like + + p `is` n = p /= (-1) && p == n + +This gave rise to a horrible sequence of cases + + case p of + (-1) -> $j p + 1 -> e1 + DEFAULT -> $j p + +and similarly in cascade for all the join points! + +Note [Combine identical alternatives: wrinkles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +* It's important that we try to combine alternatives *before* + simplifying them, rather than after. Reason: because + Simplify.simplAlt may zap the occurrence info on the binders in the + alternatives, which in turn defeats combineIdenticalAlts use of + isDeadBinder (see #7360). + + You can see this in the call to combineIdenticalAlts in + GHC.Core.Opt.Simplify.Utils.prepareAlts. Here the alternatives have type InAlt + (the "In" meaning input) rather than OutAlt. + +* combineIdenticalAlts does not work well for nullary constructors + case x of y + [] -> f [] + (_:_) -> f y + Here we won't see that [] and y are the same. Sigh! This problem + is solved in CSE, in GHC.Core.Opt.CSE.combineAlts, which does a better version + of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have + here. + See Note [Combine case alts: awkward corner] in GHC.Core.Opt.CSE). + +Note [Care with impossible-constructors when combining alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#10538) + data T = A | B | C | D + + case x::T of (Imposs-default-cons {A,B}) + DEFAULT -> e1 + A -> e2 + B -> e1 + +When calling combineIdentialAlts, we'll have computed that the +"impossible constructors" for the DEFAULT alt is {A,B}, since if x is +A or B we'll take the other alternatives. But suppose we combine B +into the DEFAULT, to get + + case x::T of (Imposs-default-cons {A}) + DEFAULT -> e1 + A -> e2 + +Then we must be careful to trim the impossible constructors to just {A}, +else we risk compiling 'e1' wrong! + +Not only that, but we take care when there is no DEFAULT beforehand, +because we are introducing one. Consider + + case x of (Imposs-default-cons {A,B,C}) + A -> e1 + B -> e2 + C -> e1 + +Then when combining the A and C alternatives we get + + case x of (Imposs-default-cons {B}) + DEFAULT -> e1 + B -> e2 + +Note that we have a new DEFAULT branch that we didn't have before. So +we need delete from the "impossible-default-constructors" all the +known-con alternatives that we have eliminated. (In #11172 we +missed the first one.) + +-} + +combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT + -> [CoreAlt] + -> (Bool, -- True <=> something happened + [AltCon], -- New constructors that cannot match DEFAULT + [CoreAlt]) -- New alternatives +-- See Note [Combine identical alternatives] +-- True <=> we did some combining, result is a single DEFAULT alternative +combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts) + | all isDeadBinder bndrs1 -- Remember the default + , not (null elim_rest) -- alternative comes first + = (True, imposs_deflt_cons', deflt_alt : filtered_rest) + where + (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts + deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1) + + -- See Note [Care with impossible-constructors when combining alternatives] + imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons + elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest + elim_con1 = case con1 of -- Don't forget con1! + DEFAULT -> [] + _ -> [con1] + + cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 + identical_to_alt1 (Alt _con bndrs rhs) + = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 + tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest + +combineIdenticalAlts imposs_cons alts + = (False, imposs_cons, alts) + +-- Scales the multiplicity of the binders of a list of case alternatives. That +-- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled. +scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt] +scaleAltsBy w alts = map scaleAlt alts + where + scaleAlt :: CoreAlt -> CoreAlt + scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs + + scaleBndr :: CoreBndr -> CoreBndr + scaleBndr b = scaleVarBy w b + + +{- ********************************************************************* +* * + exprIsTrivial +* * +************************************************************************ + +Note [exprIsTrivial] +~~~~~~~~~~~~~~~~~~~~ +@exprIsTrivial@ is true of expressions we are unconditionally happy to + duplicate; simple variables and constants, and type + applications. Note that primop Ids aren't considered + trivial unless + +Note [Variables are trivial] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There used to be a gruesome test for (hasNoBinding v) in the +Var case: + exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 +The idea here is that a constructor worker, like \$wJust, is +really short for (\x -> \$wJust x), because \$wJust has no binding. +So it should be treated like a lambda. Ditto unsaturated primops. +But now constructor workers are not "have-no-binding" Ids. And +completely un-applied primops and foreign-call Ids are sufficiently +rare that I plan to allow them to be duplicated and put up with +saturating them. + +Note [Tick trivial] +~~~~~~~~~~~~~~~~~~~ +Ticks are only trivial if they are pure annotations. If we treat +"tick x" as trivial, it will be inlined inside lambdas and the +entry count will be skewed, for example. Furthermore "scc x" will +turn into just "x" in mkTick. At least if `x` is not a function. + +Note [Empty case is trivial] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The expression (case (x::Int) Bool of {}) is just a type-changing +case used when we are sure that 'x' will not return. See +Note [Empty case alternatives] in GHC.Core. + +If the scrutinee is trivial, then so is the whole expression; and the +CoreToSTG pass in fact drops the case expression leaving only the +scrutinee. + +Having more trivial expressions is good. Moreover, if we don't treat +it as trivial we may land up with let-bindings like + let v = case x of {} in ... +and after CoreToSTG that gives + let v = x in ... +and that confuses the code generator (#11155). So best to kill +it off at source. +-} + +{-# INLINE trivial_expr_fold #-} +trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r +-- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr] +-- This is meant to have the code of both functions in one place and make it +-- easy to derive custom predicates. +-- +-- (trivial_expr_fold k_id k_triv k_not_triv e) +-- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping) +-- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping) +-- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping) +-- * returns k_not_triv otherwise +-- +-- where "trivial wrapping" is +-- * Type application or abstraction +-- * Ticks other than `tickishIsCode` +-- * `case e of {}` an empty case +trivial_expr_fold k_id k_lit k_triv k_not_triv = go + where + -- If you change this function, be sure to change + -- SetLevels.notWorthFloating as well! + -- (Or yet better: Come up with a way to share code with this function.) + go (Var v) = k_id v -- See Note [Variables are trivial] + go (Lit l) | litIsTrivial l = k_lit l + go (Type _) = k_triv + go (Coercion _) = k_triv + go (App f arg) + | not (isRuntimeArg arg) = go f + | exprIsUnaryClassFun f = go arg + | otherwise = k_not_triv + go (Lam b e) | not (isRuntimeVar b) = go e + go (Tick t e) | not (tickishIsCode t) = go e -- See Note [Tick trivial] + go (Cast e _) = go e + go (Case e b _ as) + | null as + = go e -- See Note [Empty case is trivial] + | Just rhs <- isUnsafeEqualityCase e b as + = go rhs -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce + go _ = k_not_triv + +exprIsTrivial :: CoreExpr -> Bool +exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e + +{- +Note [getIdFromTrivialExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When substituting in a breakpoint we need to strip away the type cruft +from a trivial expression and get back to the Id. The invariant is +that the expression we're substituting was originally trivial +according to exprIsTrivial, AND the expression is not a literal. +See Note [substTickish] for how breakpoint substitution preserves +this extra invariant. + +We also need this functionality in CorePrep to extract out Id of a +function which we are saturating. However, in this case we don't know +if the variable actually refers to a literal; thus we use +'getIdFromTrivialExpr_maybe' to handle this case. See test +T12076lit for an example where this matters. +-} + +getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id +-- See Note [getIdFromTrivialExpr] +getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e + where + panic = pprPanic "getIdFromTrivialExpr" (ppr e) + +getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id +getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e + +{- ********************************************************************* +* * + exprIsDupable +* * +************************************************************************ + +Note [exprIsDupable] +~~~~~~~~~~~~~~~~~~~~ +@exprIsDupable@ is true of expressions that can be duplicated at a modest + cost in code size. This will only happen in different case + branches, so there's no issue about duplicating work. + + That is, exprIsDupable returns True of (f x) even if + f is very very expensive to call. + + Its only purpose is to avoid fruitless let-binding + and then inlining of case join points +-} + +exprIsDupable :: Platform -> CoreExpr -> Bool +exprIsDupable platform e + = isJust (go dupAppSize e) + where + go :: Int -> CoreExpr -> Maybe Int + go n (Type {}) = Just n + go n (Coercion {}) = Just n + go n (Var {}) = decrement n + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (App f a) | Just n' <- go n a = go n' f + go n (Lit lit) | litIsDupable platform lit = decrement n + go _ _ = Nothing + + decrement :: Int -> Maybe Int + decrement 0 = Nothing + decrement n = Just (n-1) + +dupAppSize :: Int +dupAppSize = 8 -- Size of term we are prepared to duplicate + -- This is *just* big enough to make test MethSharing + -- inline enough join points. Really it should be + -- smaller, and could be if we fixed #4960. + +{- +************************************************************************ +* * + exprIsCheap, exprIsExpandable +* * +************************************************************************ + +Note [exprIsWorkFree] +~~~~~~~~~~~~~~~~~~~~~ +exprIsWorkFree is used when deciding whether to inline something; we +don't inline it if doing so might duplicate work, by peeling off a +complete copy of the expression. Here we do not want even to +duplicate a primop (#5623): + eg let x = a #+ b in x +# x + we do not want to inline/duplicate x + +Previously we were a bit more liberal, which led to the primop-duplicating +problem. However, being more conservative did lead to a big regression in +one nofib benchmark, wheel-sieve1. The situation looks like this: + + let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool + noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> + case GHC.Prim.<=# x_aRs 2 of _ { + GHC.Types.False -> notDivBy ps_adM qs_adN; + GHC.Types.True -> lvl_r2Eb }} + go = \x. ...(noFactor (I# y))....(go x')... + +The function 'noFactor' is heap-allocated and then called. Turns out +that 'notDivBy' is strict in its THIRD arg, but that is invisible to +the caller of noFactor, which therefore cannot do w/w and +heap-allocates noFactor's argument. At the moment (May 12) we are just +going to put up with this, because the previous more aggressive inlining +(which treated 'noFactor' as work-free) was duplicating primops, which +in turn was making inner loops of array calculations runs slow (#5623) + +Note [Case expressions are work-free] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Are case-expressions work-free? Consider + let v = case x of (p,q) -> p + go = \y -> ...case v of ... +Should we inline 'v' at its use site inside the loop? At the moment +we do. I experimented with saying that case are *not* work-free, but +that increased allocation slightly. It's a fairly small effect, and at +the moment we go for the slightly more aggressive version which treats +(case x of ....) as work-free if the alternatives are. + +Moreover it improves arities of overloaded functions where +there is only dictionary selection (no construction) involved + +Note [exprIsCheap] +~~~~~~~~~~~~~~~~~~ +See also Note [Interaction of exprIsWorkFree and lone variables] in GHC.Core.Unfold + +@exprIsCheap@ looks at a Core expression and returns \tr{True} if +it is obviously in weak head normal form, or is cheap to get to WHNF. +Note that that's not the same as exprIsDupable; an expression might be +big, and hence not dupable, but still cheap. + +By ``cheap'' we mean a computation we're willing to: + push inside a lambda, or + inline at more than one place +That might mean it gets evaluated more than once, instead of being +shared. The main examples of things which aren't WHNF but are +``cheap'' are: + + * case e of + pi -> ei + (where e, and all the ei are cheap) + + * let x = e in b + (where e and b are cheap) + + * op x1 ... xn + (where op is a cheap primitive operator) + + * error "foo" + (because we are happy to substitute it inside a lambda) + +Notice that a variable is considered 'cheap': we can push it inside a lambda, +because sharing will make sure it is only evaluated once. + +Note [exprIsCheap and exprIsHNF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that exprIsHNF does not imply exprIsCheap. Eg + let x = fac 20 in Just x +This responds True to exprIsHNF (you can discard a seq), but +False to exprIsCheap. + +Note [Arguments and let-bindings exprIsCheapX] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What predicate should we apply to the argument of an application, or the +RHS of a let-binding? + +We used to say "exprIsTrivial arg" due to concerns about duplicating +nested constructor applications, but see #4978. So now we just recursively +use exprIsCheapX. + +We definitely want to treat let and app the same. The principle here is +that + let x = blah in f x +should behave equivalently to + f blah + +This in turn means that the 'letrec g' does not prevent eta expansion +in this (which it previously was): + f = \x. let v = case x of + True -> letrec g = \w. blah + in g + False -> \x. x + in \w. v True +-} + +------------------------------------- +type CheapAppFun = Id -> Arity -> Bool + -- Is an application of this function to n *value* args + -- always cheap, assuming the arguments are cheap? + -- True mainly of data constructors, partial applications; + -- but with minor variations: + -- isWorkFreeApp + -- isCheapApp + -- isExpandableApp + +exprIsCheapX :: CheapAppFun -> Bool -> CoreExpr -> Bool +{-# INLINE exprIsCheapX #-} +-- allow specialization of exprIsCheap, exprIsWorkFree and exprIsExpandable +-- instead of having an unknown call to ok_app +-- expandable=True <=> Treat Case and Let as cheap, if their sub-expressions are. +-- This flag is set for exprIsExpandable +exprIsCheapX ok_app expandable e + = ok e + where + ok e = go 0 e + + -- n is the number of value arguments + go n (Var v) = ok_app v n + go _ (Lit {}) = True + go _ (Type {}) = True + go _ (Coercion {}) = True + go n (Cast e _) = go n e + go n (Case scrut _ _ alts) = not expandable && ok scrut && + and [ go n rhs | Alt _ _ rhs <- alts ] + go n (Tick t e) | tickishCounts t = False + | otherwise = go n e + go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e + | otherwise = go n e + go n (App f e) | isRuntimeArg e = go (n+1) f && ok e + | otherwise = go n f + go n (Let (NonRec _ r) e) = not expandable && go n e && ok r + go n (Let (Rec prs) e) = not expandable && go n e && all (ok . snd) prs + + -- Case: see Note [Case expressions are work-free] + -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] + +-------------------- +exprIsWorkFree :: CoreExpr -> Bool +-- See Note [exprIsWorkFree] +exprIsWorkFree e = exprIsCheapX isWorkFreeApp False e + +-------------------- +exprIsCheap :: CoreExpr -> Bool +-- See Note [exprIsCheap] +exprIsCheap e = exprIsCheapX isCheapApp False e + +-------------------- +exprIsExpandable :: CoreExpr -> Bool +-- See Note [exprIsExpandable] +exprIsExpandable e = exprIsCheapX isExpandableApp True e + +isWorkFreeApp :: CheapAppFun +isWorkFreeApp fn n_val_args + | n_val_args == 0 -- No value args + = True + | n_val_args < idArity fn -- Partial application + = True + | otherwise + = case idDetails fn of + DataConWorkId {} -> True + PrimOpId op _ -> primOpIsWorkFree op + _ -> False + +isCheapApp :: CheapAppFun +isCheapApp fn n_val_args + | isWorkFreeApp fn n_val_args = True + | isDeadEndId fn = True -- See Note [isCheapApp: bottoming functions] + | otherwise + = case idDetails fn of + -- DataConWorkId {} -> _ -- Handled by isWorkFreeApp + RecSelId {} -> n_val_args == 1 -- See Note [Record selection] + ClassOpId {} -> n_val_args == 1 + PrimOpId op _ -> primOpIsCheap op + _ -> False + -- In principle we should worry about primops + -- that return a type variable, since the result + -- might be applied to something, but I'm not going + -- to bother to check the number of args + +isExpandableApp :: CheapAppFun +isExpandableApp fn n_val_args + | isWorkFreeApp fn n_val_args = True + | otherwise + = case idDetails fn of + -- DataConWorkId {} -> _ -- Handled by isWorkFreeApp + RecSelId {} -> n_val_args == 1 -- See Note [Record selection] + ClassOpId {} -> n_val_args == 1 + PrimOpId {} -> False + _ | isDeadEndId fn -> False + -- See Note [isExpandableApp: bottoming functions] + | isConLikeId fn -> True + | all_args_are_preds -> True + | otherwise -> False + + where + -- See if all the arguments are PredTys (implicit params or classes) + -- If so we'll regard it as expandable; see Note [Expandable overloadings] + all_args_are_preds = all_pred_args n_val_args (idType fn) + + all_pred_args n_val_args ty + | n_val_args == 0 + = True + + | Just (bndr, ty) <- splitPiTy_maybe ty + = case bndr of + Named {} -> all_pred_args n_val_args ty + Anon _ af -> isInvisibleFunArg af && all_pred_args (n_val_args-1) ty + + | otherwise + = False + +{- Note [isCheapApp: bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I'm not sure why we have a special case for bottoming +functions in isCheapApp. Maybe we don't need it. + +Note [exprIsExpandable] +~~~~~~~~~~~~~~~~~~~~~~~ +An expression is "expandable" if we are willing to duplicate it, if doing +so might make a RULE or case-of-constructor fire. Consider + let x = (a,b) + y = build g + in ....(case x of (p,q) -> rhs)....(foldr k z y).... + +We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), +but we do want + + * the case-expression to simplify + (via exprIsConApp_maybe, exprIsLiteral_maybe) + + * the foldr/build RULE to fire + (by expanding the unfolding during rule matching) + +So we classify the unfolding of a let-binding as "expandable" (via the +uf_expandable field) if we want to do this kind of on-the-fly +expansion. Specifically: + +* True of constructor applications (K a b) + +* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. + (NB: exprIsCheap might not be true of this) + +* False of case-expressions. If we have + let x = case ... in ...(case x of ...)... + we won't simplify. We have to inline x. See #14688. + +* False of let-expressions (same reason); and in any case we + float lets out of an RHS if doing so will reveal an expandable + application (see SimplEnv.doFloatFromRhs). + +* Take care: exprIsExpandable should /not/ be true of primops. I + found this in test T5623a: + let q = /\a. Ptr a (a +# b) + in case q @ Float of Ptr v -> ...q... + + q's inlining should not be expandable, else exprIsConApp_maybe will + say that (q @ Float) expands to (Ptr a (a +# b)), and that will + duplicate the (a +# b) primop, which we should not do lightly. + (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) + +Note [isExpandableApp: bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important that isExpandableApp does not respond True to bottoming +functions. Recall undefined :: HasCallStack => a +Suppose isExpandableApp responded True to (undefined d), and we had: + + x = undefined + +Then Simplify.prepareRhs would ANF the RHS: + + d = + x = undefined d + +This is already bad: we gain nothing from having x bound to (undefined +var), unlike the case for data constructors. Worse, we get the +simplifier loop described in OccurAnal Note [Cascading inlines]. +Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will +certainly_inline; so we end up inlining d right back into x; but in +the end x doesn't inline because it is bottom (preInlineUnconditionally); +so the process repeats.. We could elaborate the certainly_inline logic +some more, but it's better just to treat bottoming bindings as +non-expandable, because ANFing them is a bad idea in the first place. + +Note [Record selection] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +I'm experimenting with making record selection +look cheap, so we will substitute it inside a +lambda. Particularly for dictionary field selection. + +BUT: Take care with (sel d x)! The (sel d) might be cheap, but +there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) + +Note [Expandable overloadings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the user wrote this + {-# RULE forall x. foo (negate x) = h x #-} + f x = ....(foo (negate x)).... +They'd expect the rule to fire. But since negate is overloaded, we might +get this: + f = \d -> let n = negate d in \x -> ...foo (n x)... +So we treat the application of a function (negate in this case) to a +*dictionary* as expandable. In effect, every function is CONLIKE when +it's applied only to dictionaries. +-} + +isUnaryClassId :: Id -> Bool +-- True of (a) the method selector (classop) +-- (b) the dictionary data constructor +-- of a unary class +isUnaryClassId v + | Just cls <- isClassOpId_maybe v = isUnaryClass cls + | Just dc <- isDataConWorkId_maybe v = isUnaryClassDataCon dc + | otherwise = False + +exprIsUnaryClassFun :: CoreExpr -> Bool +-- True of an a type application (f @t1 .. @tn), +-- where `f` is a unary-class-id +-- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon +exprIsUnaryClassFun (App f (Type {})) = exprIsUnaryClassFun f +exprIsUnaryClassFun (Var v) = isUnaryClassId v +exprIsUnaryClassFun _ = False + + +{- ********************************************************************* +* * + exprOkForSpeculation +* * +********************************************************************* -} + +----------------------------- +-- | To a first approximation, 'exprOkForSpeculation' returns True of +-- an expression that is: +-- +-- * Safe to evaluate even if normal order eval might not +-- evaluate the expression at all, and +-- +-- * Safe /not/ to evaluate even if normal order would do so +-- +-- More specifically, this means that: +-- * A: Evaluation of the expression reaches weak-head-normal-form, +-- * B: soon, +-- * C: without causing a write side effect (e.g. writing a mutable variable). +-- +-- In particular, an expression that may +-- * throw a synchronous Haskell exception, or +-- * risk an unchecked runtime exception (e.g. array +-- out of bounds, divide by zero) +-- is /not/ considered OK-for-speculation, as these violate condition A. +-- +-- For 'exprOkToDiscard', condition A is weakened to allow expressions +-- that might risk an unchecked runtime exception but must otherwise +-- reach weak-head-normal-form. +-- (Note that 'exprOkForSpeculation' implies 'exprOkToDiscard') +-- +-- But in fact both functions are a bit more conservative than the above, +-- in at least the following ways: +-- +-- * W1: We do not take advantage of already-evaluated lifted variables. +-- As a result, 'exprIsHNF' DOES NOT imply 'exprOkForSpeculation'; +-- if @y@ is a case-binder of lifted type, then @exprIsHNF y@ is +-- 'True', while @exprOkForSpeculation y@ is 'False'. +-- See Note [exprOkForSpeculation and evaluated variables] for why. +-- * W2: Read-effects on mutable variables are currently also included. +-- See Note [Classifying primop effects] "GHC.Builtin.PrimOps". +-- * W3: Currently, 'exprOkForSpeculation' always returns 'False' for +-- let-expressions. Lets can be stacked deeply, so we just give up. +-- In any case, the argument of 'exprOkForSpeculation' is usually in +-- a strict context, so any lets will have been floated away. +-- +-- +-- As an example of the considerations in this test, consider: +-- +-- > let x = case y# +# 1# of { r# -> I# r# } +-- > in E +-- +-- being translated to: +-- +-- > case y# +# 1# of { r# -> +-- > let x = I# r# +-- > in E +-- > } +-- +-- We can only do this if the @y# +# 1#@ is ok for speculation: it has no +-- side effects, and can't diverge or raise an exception. +-- +-- +-- See also Note [Classifying primop effects] in "GHC.Builtin.PrimOps" +-- and Note [Transformations affected by primop effects]. +-- +-- 'exprOkForSpeculation' is used to define Core's let-can-float +-- invariant. (See Note [Core let-can-float invariant] in +-- "GHC.Core".) It is therefore frequently called on arguments of +-- unlifted type, especially via 'needsCaseBinding'. But it is +-- sometimes called on expressions of lifted type as well. For +-- example, see Note [Speculative evaluation] in "GHC.CoreToStg.Prep". + + +exprOkForSpeculation, exprOkToDiscard :: CoreExpr -> Bool +exprOkForSpeculation = expr_ok fun_always_ok primOpOkForSpeculation +exprOkToDiscard = expr_ok fun_always_ok primOpOkToDiscard + +fun_always_ok :: Id -> Bool +fun_always_ok _ = True + +-- | A special version of 'exprOkForSpeculation' used during +-- Note [Speculative evaluation]. When the predicate arg `fun_ok` returns False +-- for `b`, then `b` is never considered ok-for-spec. +exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool +exprOkForSpecEval fun_ok = expr_ok fun_ok primOpOkForSpeculation + +expr_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool +expr_ok _ _ (Lit _) = True +expr_ok _ _ (Type _) = True +expr_ok _ _ (Coercion _) = True + +expr_ok fun_ok primop_ok (Var v) = app_ok fun_ok primop_ok v [] +expr_ok fun_ok primop_ok (Cast e _) = expr_ok fun_ok primop_ok e +expr_ok fun_ok primop_ok (Lam b e) + | isTyVar b = expr_ok fun_ok primop_ok e + | otherwise = True + +-- Tick annotations that *tick* cannot be speculated, because these +-- are meant to identify whether or not (and how often) the particular +-- source expression was evaluated at runtime. +expr_ok fun_ok primop_ok (Tick tickish e) + | tickishCounts tickish = False + | otherwise = expr_ok fun_ok primop_ok e + +expr_ok _ _ (Let {}) = False +-- See W3 in the Haddock comment for exprOkForSpeculation + +expr_ok fun_ok primop_ok (Case scrut bndr _ alts) + = -- See Note [exprOkForSpeculation: case expressions] + expr_ok fun_ok primop_ok scrut + && isUnliftedType (idType bndr) + -- OK to call isUnliftedType: binders always have a fixed RuntimeRep + && all (\(Alt _ _ rhs) -> expr_ok fun_ok primop_ok rhs) alts + && altsAreExhaustive alts + +expr_ok fun_ok primop_ok other_expr + | (expr, args) <- collectArgs other_expr + = case stripTicksTopE (not . tickishCounts) expr of + Var f -> + app_ok fun_ok primop_ok f args + + -- 'LitRubbish' is the only literal that can occur in the head of an + -- application and will not be matched by the above case (Var /= Lit). + -- See Note [How a rubbish literal can be the head of an application] + -- in GHC.Types.Literal + Lit lit | debugIsOn, not (isLitRubbish lit) + -> pprPanic "Non-rubbish lit in app head" (ppr lit) + | otherwise + -> True + + _ -> False + +----------------------------- +app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreArg] -> Bool +app_ok fun_ok primop_ok fun args + | not (fun_ok fun) + = False -- This code path is only taken for Note [Speculative evaluation] + + | idArity fun > n_val_args + -- Partial application: just check passing the arguments is OK + = args_ok + + | otherwise + = case idDetails fun of + DFunId unary_class -> not unary_class + -- DFuns terminate, unless the dict is implemented + -- by a no-op in which case they may not + -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon + + DataConWorkId dc + | isLazyDataConRep dc + -> args_ok + | otherwise + -> fields_ok (dataConRepStrictness dc) + + ClassOpId _ is_terminating_result + | is_terminating_result -- See Note [exprOkForSpeculation and type classes] + -> assertPpr (n_val_args == 1) (ppr fun $$ ppr args) $ + True + -- assert: terminating result type => can't be applied; + -- c.f the _other case below + + PrimOpId op _ + | primOpIsDiv op + , Lit divisor <- Partial.last args + -- there can be 2 args (most div primops) or 3 args + -- (WordQuotRem2Op), hence the use of last/init + -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args) + -- Special case for dividing operations that fail + -- In general they are NOT ok-for-speculation + -- (which primop_ok will catch), but they ARE OK + -- if the divisor is definitely non-zero. + -- Often there is a literal divisor, and this + -- can get rid of a thunk in an inner loop + + | otherwise -> primop_ok op && args_ok + + _other -- Unlifted and terminating types; + -- Also c.f. the Var case of exprIsHNF + | isTerminatingType fun_ty -- See Note [exprOkForSpeculation and type classes] + || definitelyUnliftedType fun_ty + -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args) + True -- Both terminating types (e.g. Eq a), and unlifted types (e.g. Int#) + -- are non-functions and so will have no value args. The assert is + -- just to check this. + -- (If we added unlifted function types this would change, + -- and we'd need to actually test n_val_args == 0.) + + -- Functions that terminate fast without raising exceptions etc + -- See (U12) of Note [Implementing unsafeCoerce] + | fun `hasKey` unsafeEqualityProofIdKey -> True + + | otherwise -> False + -- NB: even in the nullary case, do /not/ check + -- for evaluated-ness of the fun; + -- see Note [exprOkForSpeculation and evaluated variables] + where + fun_ty = idType fun + n_val_args = valArgCount args + (arg_tys, _) = splitPiTys fun_ty + + -- Even if a function call itself is OK, any unlifted + -- args are still evaluated eagerly and must be checked + args_ok = all2Prefix arg_ok arg_tys args + arg_ok :: PiTyVarBinder -> CoreExpr -> Bool + arg_ok (Named _) _ = True -- A type argument + arg_ok (Anon ty _) arg -- A term argument + | definitelyLiftedType (scaledThing ty) + = True -- lifted args are not evaluated eagerly + | otherwise + = expr_ok fun_ok primop_ok arg + + -- Used for strict DataCon worker arguments + -- See (SFC1) of Note [Strict fields in Core] + fields_ok str_marks = all3Prefix field_ok arg_tys str_marks args + field_ok :: PiTyVarBinder -> StrictnessMark -> CoreExpr -> Bool + field_ok (Named _) _ _ = True + field_ok (Anon ty _) str arg + | NotMarkedStrict <- str -- iff it's a lazy field + , definitelyLiftedType (scaledThing ty) -- and its type is lifted + = True -- then the worker app does not eval + | otherwise + = expr_ok fun_ok primop_ok arg + +----------------------------- +altsAreExhaustive :: [Alt b] -> Bool +-- True <=> the case alternatives are definitely exhaustive +-- False <=> they may or may not be +altsAreExhaustive [] + = True -- The scrutinee never returns; see Note [Empty case alternatives] in GHC.Core +altsAreExhaustive (Alt con1 _ _ : alts) + = case con1 of + DEFAULT -> True + LitAlt {} -> False + DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1) + -- It is possible to have an exhaustive case that does not + -- enumerate all constructors, notably in a GADT match, but + -- we behave conservatively here -- I don't think it's important + -- enough to deserve special treatment + +-- | Should we look past this tick when eta-expanding the given function? +-- +-- See Note [Ticks and mandatory eta expansion] +-- Takes the function we are applying as argument. +etaExpansionTick :: Id -> GenTickish pass -> Bool +etaExpansionTick id t + = hasNoBinding id && + ( tickishFloatable t || isProfTick t ) + +{- Note [exprOkForSpeculation and type classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#22745, #15205) + + \(d :: C a b). case eq_sel (sc_sel d) of + (co :: t1 ~# t2) [Dead] -> blah + +We know that +* eq_sel's argument (sc_sel d) has dictionary type, so it definitely terminates + (again Note [NON-BOTTOM-DICTS invariant] in GHC.Core) +* eq_sel is simply a superclass selector, and hence is fast +* The field that eq_sel picks is of unlifted type, and hence can't be bottom + (remember the dictionary argument itself is non-bottom) + +So we can treat (eq_sel (sc_sel d)) as ok-for-speculation. We must check + +a) That the function is a class-op, with IdDetails of ClassOpId + +b) That the result type of the class-op is terminating or unlifted. E.g. for + class C a => D a where ... + class C a where { op :: a -> a } + Since C is represented by a newtype, (sc_sel (d :: D a)) might + not be terminating. + +Rather than repeatedly test if the result of the class-op is a +terminating/unlifted type, we cache it as a field of ClassOpId. See +GHC.Types.Id.Make.mkDictSelId for where this field is initialised. + +Note [exprOkForSpeculation: case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprOkForSpeculation accepts very special case expressions. +Reason: (a ==# b) is ok-for-speculation, but the litEq rules +in GHC.Core.Opt.ConstantFold convert it (a ==# 3#) to + case a of { DEFAULT -> 0#; 3# -> 1# } +for excellent reasons described in + GHC.Core.Opt.ConstantFold Note [The litEq rule: converting equality to case]. +So, annoyingly, we want that case expression to be +ok-for-speculation too. Bother. + +But we restrict it sharply: + +* We restrict it to unlifted scrutinees. Consider this: + case x of y { + DEFAULT -> ... (let v::Int# = case y of { True -> e1 + ; False -> e2 } + in ...) ... + + Does the RHS of v satisfy the let-can-float invariant? Previously we said + yes, on the grounds that y is evaluated. But the binder-swap done + by GHC.Core.Opt.SetLevels would transform the inner alternative to + DEFAULT -> ... (let v::Int# = case x of { ... } + in ...) .... + which does /not/ satisfy the let-can-float invariant, because x is + not evaluated. See Note [Binder-swap during float-out] + in GHC.Core.Opt.SetLevels. To avoid this awkwardness it seems simpler + to stick to unlifted scrutinees where the issue does not + arise. + +* We restrict it to exhaustive alternatives. A non-exhaustive + case manifestly isn't ok-for-speculation. for example, + this is a valid program (albeit a slightly dodgy one) + let v = case x of { B -> ...; C -> ... } + in case x of + A -> ... + _ -> ...v...v.... + Should v be considered ok-for-speculation? Its scrutinee may be + evaluated, but the alternatives are incomplete so we should not + evaluate it strictly. + + Now, all this is for lifted types, but it'd be the same for any + finite unlifted type. We don't have many of them, but we might + add unlifted algebraic types in due course. + + +----- Historical note: #15696: -------- + Previously GHC.Core.Opt.SetLevels used exprOkForSpeculation to guide + floating of single-alternative cases; it now uses exprIsHNF + Note [Floating single-alternative cases]. + + But in those days, consider + case e of x { DEAFULT -> + ...(case x of y + A -> ... + _ -> ...(case (case x of { B -> p; C -> p }) of + I# r -> blah)... + If GHC.Core.Opt.SetLevels considers the inner nested case as + ok-for-speculation it can do case-floating (in GHC.Core.Opt.SetLevels). + So we'd float to: + case e of x { DEAFULT -> + case (case x of { B -> p; C -> p }) of I# r -> + ...(case x of y + A -> ... + _ -> ...blah...)... + which is utterly bogus (seg fault); see #5453. + +----- Historical note: #3717: -------- + foo :: Int -> Int + foo 0 = 0 + foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) + +In earlier GHCs, we got this: + T.$wfoo = + \ (ww :: GHC.Prim.Int#) -> + case ww of ds { + __DEFAULT -> case (case <# ds 5 of _ { + GHC.Types.False -> lvl1; + GHC.Types.True -> lvl}) + of _ { __DEFAULT -> + T.$wfoo (GHC.Prim.-# ds_XkE 1) }; + 0 -> 0 } + +Before join-points etc we could only get rid of two cases (which are +redundant) by recognising that the (case <# ds 5 of { ... }) is +ok-for-speculation, even though it has /lifted/ type. But now join +points do the job nicely. +------- End of historical note ------------ + + +Note [exprOkForSpeculation and evaluated variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these examples: + * case x of y { DEFAULT -> ....y.... } + Should 'y' (alone) be considered ok-for-speculation? + + * case x of y { DEFAULT -> ....let z = dataToTagLarge# y... } + Should (dataToTagLarge# y) be considered ok-for-spec? Recall that + dataToTagLarge# :: forall a. a -> Int# + must always evaluate its argument. (See also Note [DataToTag overview].) + +You could argue 'yes', because in the case alternative we know that +'y' is evaluated. But the binder-swap transformation, which is +extremely useful for float-out, changes these expressions to + case x of y { DEFAULT -> ....x.... } + case x of y { DEFAULT -> ....let z = dataToTagLarge# x... } + +And now the expression does not obey the let-can-float invariant! Yikes! +Moreover we really might float (dataToTagLarge# x) outside the case, +and then it really, really doesn't obey the let-can-float invariant. + +The solution is simple: exprOkForSpeculation does not try to take +advantage of the evaluated-ness of (lifted) variables. And it returns +False (always) for primops that perform evaluation. We achieve the latter +by marking the relevant primops as "ThrowsException" or +"ReadWriteEffect"; see also Note [Classifying primop effects] in +GHC.Builtin.PrimOps. + +Note that exprIsHNF /can/ and does take advantage of evaluated-ness; +it doesn't have the trickiness of the let-can-float invariant to worry about. + +************************************************************************ +* * + exprIsHNF, exprIsConLike +* * +************************************************************************ +-} + +-- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] +-- ~~~~~~~~~~~~~~~~ +-- | exprIsHNF returns true for expressions that are certainly /already/ +-- evaluated to /head/ normal form. This is used to decide whether it's ok +-- to perform case-to-let for lifted expressions, which changes: +-- +-- > case x of x' { _ -> e } +-- +-- into: +-- +-- > let x' = x in e +-- +-- and in so doing makes the binding lazy. +-- +-- So, it does /not/ treat variables as evaluated, unless they say they are. +-- +-- However, it /does/ treat partial applications and constructor applications +-- as values, even if their arguments are non-trivial, provided the argument +-- type is lifted. For example, both of these are values: +-- +-- > (:) (f x) (map f xs) +-- > map (...redex...) +-- +-- because 'seq' on such things completes immediately. +-- +-- For unlifted argument types, we have to be careful: +-- +-- > C (f x :: Int#) +-- +-- Suppose @f x@ diverges; then @C (f x)@ is not a value. +-- We check for this using needsCaseBinding below +exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP +exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding + +-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as +-- data constructors. Conlike arguments are considered interesting by the +-- inliner. +exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP +exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding + +-- | Returns true for values or value-like expressions. These are lambdas, +-- constructors / CONLIKE functions (as determined by the function argument) +-- or PAPs. +-- +exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool +exprIsHNFlike is_con is_con_unf e + = -- pprTraceWith "hnf" (\r -> ppr r <+> ppr e) $ + is_hnf_like e + where + is_hnf_like (Var v) -- NB: There are no value args at this point + = id_app_is_value v [] -- Catches nullary constructors, + -- so that [] and () are values, for example + -- and (e.g.) primops that don't have unfoldings + || is_con_unf (idUnfolding v) + -- Check the thing's unfolding; it might be bound to a value + -- or to a guaranteed-evaluated variable (isEvaldUnfolding) + -- Contrast with Note [exprOkForSpeculation and evaluated variables] + -- We don't look through loop breakers here, which is a bit conservative + -- but otherwise I worry that if an Id's unfolding is just itself, + -- we could get an infinite loop + + || definitelyUnliftedType (idType v) + -- Unlifted binders are always evaluated (#20140) + + is_hnf_like (Lit l) = not (isLitRubbish l) + -- Regarding a LitRubbish as ConLike leads to unproductive inlining in + -- WWRec, see #20035 + is_hnf_like (Type _) = True -- Types are honorary Values; + -- we don't mind copying them + is_hnf_like (Coercion _) = True -- Same for coercions + is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e + is_hnf_like (Tick tickish e) = not (tickishCounts tickish) + && is_hnf_like e + -- See Note [exprIsHNF Tick] + is_hnf_like (Cast e _) = is_hnf_like e + is_hnf_like (App e a) + | isValArg a = app_is_value e [a] + | otherwise = is_hnf_like e + is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us + is_hnf_like (Case e b _ as) + | Just rhs <- isUnsafeEqualityCase e b as + = is_hnf_like rhs + is_hnf_like _ = False + + -- Collect arguments through Casts and Ticks and call id_app_is_value + app_is_value :: CoreExpr -> [CoreArg] -> Bool + app_is_value (Var f) as = id_app_is_value f as + app_is_value (Tick _ f) as = app_is_value f as + app_is_value (Cast f _) as = app_is_value f as + app_is_value (App f a) as | isValArg a = app_is_value f (a:as) + | otherwise = app_is_value f as + app_is_value _ _ = False + + id_app_is_value id val_args + | Just dc <- isDataConWorkId_maybe id + , isUnaryClassDataCon dc + = all is_hnf_like val_args -- Look through unary class data cons + | otherwise + -- See Note [exprIsHNF for function applications] + -- for the specification and examples + = case compare (idArity id) (length val_args) of + EQ | is_con id -> -- Saturated app of a DataCon/CONLIKE Id + case mb_str_marks id of + Just str_marks -> -- with strict fields; see (SFC1) of Note [Strict fields in Core] + assert (val_args `equalLength` str_marks) $ + fields_hnf str_marks + Nothing -> -- without strict fields: like PAP + args_hnf -- NB: CONLIKEs are lazy! + + GT -> -- PAP: Check unlifted val_args + args_hnf + + _ -> False + + where + -- Saturated, Strict DataCon: Check unlifted val_args and strict fields + fields_hnf str_marks = all3Prefix check_field val_arg_tys str_marks val_args + + -- PAP: Check unlifted val_args + args_hnf = all2Prefix check_arg val_arg_tys val_args + + fun_ty = idType id + val_arg_tys = mapMaybe anonPiTyBinderType_maybe (collectPiTyBinders fun_ty) + -- val_arg_tys = map exprType val_args, but much less costly. + -- The obvious definition regresses T16577 by 30% so we don't do it. + + check_arg a_ty a + | mightBeUnliftedType a_ty = is_hnf_like a + | otherwise = True + -- Check unliftedness; for example f (x /# 12#) where f has arity two, + -- and the first argument is unboxed. This is not a value! + -- But f 34# is a value, so check args for HNFs. + -- NB: We check arity (and CONLIKEness) first because it's cheaper + -- and we reject quickly on saturated apps. + check_field a_ty str a + | mightBeUnliftedType a_ty = is_hnf_like a + | isMarkedStrict str = is_hnf_like a + | otherwise = True + -- isMarkedStrict: Respect Note [Strict fields in Core] + + mb_str_marks id + | Just dc <- isDataConWorkId_maybe id + , not (isLazyDataConRep dc) + = Just (dataConRepStrictness dc) + | otherwise + = Nothing + +{-# INLINE exprIsHNFlike #-} + +{- +Note [exprIsHNF Tick] +~~~~~~~~~~~~~~~~~~~~~ +We can discard source annotations on HNFs as long as they aren't +tick-like: + + scc c (\x . e) => \x . e + scc c (C x1..xn) => C x1..xn + +So we regard these as HNFs. Tick annotations that tick are not +regarded as HNF if the expression they surround is HNF, because the +tick is there to tell us that the expression was evaluated, so we +don't want to discard a seq on it. + +Note [exprIsHNF for function applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider an application with an Id head where the argument is a redex: + + f + +Is this expression a value? + +The answer depends on the type of `f`, its arity and whether or not it is a +strict data constructor. The decision diagram is as follows: + +* If is unlifted, it is *not* a value (regardless of arity!) +* Otherwise, is lifted. + Does its `idArity` (a lower bound on the actual arity) + exceed the number of actual arguments (= 1)? + * If so, it is a PAP and thus a value + * If not, it is a saturated call. + Is it a lazy data constructor? Then it is a value. + Is it a strict data constructor? Then it is *not* a value. (See also Note [Strict fields in Core].) + Otherwise, it is a regular, possibly saturated function call, and hence *not* a value. + +The code in exprIsHNF is tweaked for efficiency, hence it delays the +unliftedness check after the arity check. + +Here are a few examples (enshrined in testcase AppIsHNF) to bring home this +point. Let us say that + + f :: Int# -> Int -> Int -> Int, with idArity 3 + expensive# :: Int -> Int# -- unlifted result + expensive :: Int -> Int -- lifted result + data T where + K1 :: !Int -> Int -> T -- strict field + K2 :: Int# -> Int -> T -- unlifted field + +Now consider + + f (expensive# 1) 2 -- Not HNF + f 1# (expensive 2) -- HNF + + K1 1 (expensive 2) -- HNF + K1 (expensive 1) 2 -- Not HNF + K1 (expensive 1) -- HNF (!) + + K2 1# (expensive 1) -- HNF + K2 (expensive# 1) 2 -- Not HNF + K2 (expensive# 1) -- Not HNF (!) + +Note that the cases marked (!) exemplify that strict fields are different to +unlifted fields when considering partial applications: Unlifted fields are +evaluated eagerly whereas evaluation of strict fields is delayed until the call +is saturated. +-} + +-- | Can we bind this 'CoreExpr' at the top level? +exprIsTopLevelBindable :: CoreExpr -> Type -> Bool +-- See Note [Core top-level string literals] +-- Precondition: exprType expr = ty +-- Top-level literal strings can't even be wrapped in ticks +-- see Note [Core top-level string literals] in "GHC.Core" +exprIsTopLevelBindable expr ty + = not (mightBeUnliftedType ty) + -- Note that 'expr' may not have a fixed runtime representation here, + -- consequently we must use 'mightBeUnliftedType' rather than 'isUnliftedType', + -- as the latter would panic. + || exprIsTickedString expr + +-- | Check if the expression is zero or more Ticks wrapped around a literal +-- string. +exprIsTickedString :: CoreExpr -> Bool +exprIsTickedString = isJust . exprIsTickedString_maybe + +-- | Extract a literal string from an expression that is zero or more Ticks +-- wrapped around a literal string. Returns Nothing if the expression has a +-- different shape. +-- Used to "look through" Ticks in places that need to handle literal strings. +exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString +exprIsTickedString_maybe (Lit (LitString bs)) = Just bs +exprIsTickedString_maybe (Tick t e) + -- we don't tick literals with CostCentre ticks, compare to mkTick + | tickishPlace t == PlaceCostCentre = Nothing + | otherwise = exprIsTickedString_maybe e +exprIsTickedString_maybe _ = Nothing + +{- +************************************************************************ +* * + Instantiating data constructors +* * +************************************************************************ + +These InstPat functions go here to avoid circularity between DataCon and Id +-} + +dataConRepInstPat :: [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) + +dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) +dataConRepFSInstPat = dataConInstPat + +dataConInstPat :: [FastString] -- A long enough list of FSs to use for names + -> [Unique] -- An equally long list of uniques, at least one for each binder + -> Mult -- The multiplicity annotation of the case expression: scales the multiplicity of variables + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyCoVar], [Id]) -- Return instantiated variables +-- dataConInstPat arg_fun fss us mult con inst_tys returns a tuple +-- (ex_tvs, arg_ids), +-- +-- ex_tvs are intended to be used as binders for existential type args +-- +-- arg_ids are intended to be used as binders for value arguments, +-- and their types have been instantiated with inst_tys and ex_tys +-- The arg_ids include both evidence and +-- programmer-specified arguments (both after rep-ing) +-- +-- Example. +-- The following constructor T1 +-- +-- data T a where +-- T1 :: forall b. Int -> b -> T(a,b) +-- ... +-- +-- has representation type +-- forall a. forall a1. forall b. (a ~ (a1,b)) => +-- Int -> b -> T a +-- +-- dataConInstPat fss us T1 (a1',b') will return +-- +-- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) +-- +-- where the double-primed variables are created with the FastStrings and +-- Uniques given as fss and us +dataConInstPat fss uniqs mult con inst_tys + = assert (univ_tvs `equalLength` inst_tys) $ + (ex_bndrs, arg_ids) + where + univ_tvs = dataConUnivTyVars con + ex_tvs = dataConExTyCoVars con + arg_tys = dataConRepArgTys con + arg_strs = dataConRepStrictness con -- 1-1 with arg_tys + n_ex = length ex_tvs + + -- split the Uniques and FastStrings + (ex_uniqs, id_uniqs) = splitAt n_ex uniqs + (ex_fss, id_fss) = splitAt n_ex fss + + -- Make the instantiating substitution for universals + univ_subst = zipTvSubst univ_tvs inst_tys + + -- Make existential type variables, applying and extending the substitution + (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst + (zip3 ex_tvs ex_fss ex_uniqs) + + mk_ex_var :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar) + mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv + new_tv + , new_tv) + where + new_tv | isTyVar tv + = mkTyVar (mkSysTvName uniq fs) kind + | otherwise + = mkCoVar (mkSystemVarName uniq fs) kind + kind = Type.substTyUnchecked subst (varType tv) + + -- Make value vars, instantiating types + arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs + mk_id_var uniq fs (Scaled m ty) str + = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments] + mkUserLocalOrCoVar (mkVarOccFS fs) uniq + (mult `mkMultMul` m) (Type.substTy full_subst ty) noSrcSpan + +{- +Note [Mark evaluated arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pattern matching on a constructor with strict fields, the binder +can have an 'evaldUnfolding'. Moreover, it *should* have one, so that +when loading an interface file unfolding like: + data T = MkT !Int + f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 + in ... } +we don't want Lint to complain. The 'y' is evaluated, so the +case in the RHS of the binding for 'v' is fine. But only if we +*know* that 'y' is evaluated. + +c.f. add_evals in GHC.Core.Opt.Simplify.simplAlt + +************************************************************************ +* * + Equality +* * +************************************************************************ +-} + +-- | A cheap equality test which bales out fast! +-- If it returns @True@ the arguments are definitely equal, +-- otherwise, they may or may not be equal. +cheapEqExpr :: Expr b -> Expr b -> Bool +cheapEqExpr = cheapEqExpr' (const False) + +-- | Cheap expression equality test, can ignore ticks by type. +cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool +{-# INLINE cheapEqExpr' #-} +cheapEqExpr' ignoreTick e1 e2 + = go e1 e2 + where + go (Var v1) (Var v2) = v1 == v2 + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = t1 `eqType` t2 + go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 + go (App f1 a1) (App f2 a2) = f1 `go` f2 && a1 `go` a2 + go (Cast e1 t1) (Cast e2 t2) = e1 `go` e2 && t1 `eqCoercion` t2 + + go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2 + go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2 + go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2 + + go _ _ = False + + + +-- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots +eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool +eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids) + = lid == rid && + map (rnOccL env) lids == map (rnOccR env) rids && + lext == rext +eqTickish _ l r = l == r + +-- | Finds differences between core bindings, see @diffExpr@. +-- +-- The main problem here is that while we expect the binds to have the +-- same order in both lists, this is not guaranteed. To do this +-- properly we'd either have to do some sort of unification or check +-- all possible mappings, which would be seriously expensive. So +-- instead we simply match single bindings as far as we can. This +-- leaves us just with mutually recursive and/or mismatching bindings, +-- which we then speculatively match by ordering them. It's by no means +-- perfect, but gets the job done well enough. +-- +-- Only used in GHC.Core.Lint.lintAnnots +diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] + -> ([SDoc], RnEnv2) +diffBinds top env binds1 = go (length binds1) env binds1 + where go _ env [] [] + = ([], env) + go _fuel env [] binds2 + -- No binds remaining to compare on the left? Bail out early. + = (warn env [] binds2, env) + go _fuel env binds1 [] + -- No binds remaining to compare on the right? Bail out early. + = (warn env binds1 [], env) + go fuel env binds1@(bind1:_) binds2@(_:_) + -- Iterated over all binds without finding a match? Then + -- try speculatively matching binders by order. + | fuel == 0 + = if not $ env `inRnEnvL` fst bind1 + then let env' = uncurry (rnBndrs2 env) $ unzip $ + zip (sort $ map fst binds1) (sort $ map fst binds2) + in go (length binds1) env' binds1 binds2 + -- If we have already tried that, give up + else (warn env binds1 binds2, env) + go fuel env ((bndr1,expr1):binds1) binds2 + | let matchExpr (bndr,expr) = + (isTyVar bndr || not top || null (diffIdInfo env bndr bndr1)) && + null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr) + + , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2 + = go (length binds1) (rnBndr2 env bndr1 bndr2) + binds1 (binds2l ++ binds2r) + | otherwise -- No match, so push back (FIXME O(n^2)) + = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 + + -- We have tried everything, but couldn't find a good match. So + -- now we just return the comparison results when we pair up + -- the binds in a pseudo-random order. + warn env binds1 binds2 = + concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++ + unmatched "unmatched left-hand:" (drop l binds1') ++ + unmatched "unmatched right-hand:" (drop l binds2') + where binds1' = sortBy (comparing fst) binds1 + binds2' = sortBy (comparing fst) binds2 + l = min (length binds1') (length binds2') + unmatched _ [] = [] + unmatched txt bs = [text txt $$ ppr (Rec bs)] + diffBind env (bndr1,expr1) (bndr2,expr2) + | ds@(_:_) <- diffExpr top env expr1 expr2 + = locBind "in binding" bndr1 bndr2 ds + -- Special case for TyVar, which we checked were bound to the same types in + -- diffExpr, but don't have any IdInfo we would panic if called diffIdInfo. + -- These let-bound types are created temporarily by the simplifier but inlined + -- immediately. + | isTyVar bndr1 && isTyVar bndr2 + = [] + | otherwise + = diffIdInfo env bndr1 bndr2 + +-- | Finds differences between core expressions, modulo alpha and +-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be +-- checked for differences as well. +diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] +diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] +diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] +diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] +diffExpr _ env (Coercion co1) (Coercion co2) + | eqCoercionX env co1 co2 = [] +diffExpr top env (Cast e1 co1) (Cast e2 co2) + | eqCoercionX env co1 co2 = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) e2 + | not (tickishIsCode n1) = diffExpr top env e1 e2 +diffExpr top env e1 (Tick n2 e2) + | not (tickishIsCode n2) = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) (Tick n2 e2) + | eqTickish env n1 n2 = diffExpr top env e1 e2 + -- The error message of failed pattern matches will contain + -- generated names, which are allowed to differ. +diffExpr _ _ (App (App (Var absent) _) _) + (App (App (Var absent2) _) _) + | isDeadEndId absent && isDeadEndId absent2 = [] +diffExpr top env (App f1 a1) (App f2 a2) + = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 +diffExpr top env (Lam b1 e1) (Lam b2 e2) + | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + = diffExpr top (rnBndr2 env b1 b2) e1 e2 +diffExpr top env (Let bs1 e1) (Let bs2 e2) + = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) + in ds ++ diffExpr top env' e1 e2 +diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 + -- See Note [Empty case alternatives] in GHC.Data.TrieMap + = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) + where env' = rnBndr2 env b1 b2 + diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2) + | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] + | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 +diffExpr _ _ e1 e2 + = [fsep [ppr e1, text "/=", ppr e2]] + +-- | Find differences in @IdInfo@. We will especially check whether +-- the unfoldings match, if present (see @diffUnfold@). +diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] +diffIdInfo env bndr1 bndr2 + | arityInfo info1 == arityInfo info2 + && cafInfo info1 == cafInfo info2 + && oneShotInfo info1 == oneShotInfo info2 + && inlinePragInfo info1 == inlinePragInfo info2 + && occInfo info1 == occInfo info2 + && demandInfo info1 == demandInfo info2 + && callArityInfo info1 == callArityInfo info2 + = locBind "in unfolding of" bndr1 bndr2 $ + diffUnfold env (realUnfoldingInfo info1) (realUnfoldingInfo info2) + | otherwise + = locBind "in Id info of" bndr1 bndr2 + [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]] + where info1 = idInfo bndr1; info2 = idInfo bndr2 + +-- | Find differences in unfoldings. Note that we will not check for +-- differences of @IdInfo@ in unfoldings, as this is generally +-- redundant, and can lead to an exponential blow-up in complexity. +diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc] +diffUnfold _ NoUnfolding NoUnfolding = [] +diffUnfold _ BootUnfolding BootUnfolding = [] +diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = [] +diffUnfold env (DFunUnfolding bs1 c1 a1) + (DFunUnfolding bs2 c2 a2) + | c1 == c2 && equalLength bs1 bs2 + = concatMap (uncurry (diffExpr False env')) (zip a1 a2) + where env' = rnBndrs2 env bs1 bs2 +diffUnfold env (CoreUnfolding t1 _ _ c1 g1) + (CoreUnfolding t2 _ _ c2 g2) + | c1 == c2 && g1 == g2 + = diffExpr False env t1 t2 +diffUnfold _ uf1 uf2 + = [fsep [ppr uf1, text "/=", ppr uf2]] + +-- | Add location information to diff messages +locBind :: String -> Var -> Var -> [SDoc] -> [SDoc] +locBind loc b1 b2 diffs = map addLoc diffs + where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc)) + bindLoc | b1 == b2 = ppr b1 + | otherwise = ppr b1 <> char '/' <> ppr b2 + + +{- ********************************************************************* +* * +\subsection{Determining non-updatable right-hand-sides} +* * +************************************************************************ + +Top-level constructor applications can usually be allocated +statically, but they can't if the constructor, or any of the +arguments, come from another DLL (because we can't refer to static +labels in other DLLs). + +If this happens we simply make the RHS into an updatable thunk, +and 'execute' it rather than allocating it statically. +-} + +{- +************************************************************************ +* * +\subsection{Type utilities} +* * +************************************************************************ +-} + +-- | True if the type has no non-bottom elements, e.g. when it is an empty +-- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool. +-- See Note [Bottoming expressions] +-- +-- See Note [No alternatives lint check] for another use of this function. +isEmptyTy :: Type -> Bool +isEmptyTy ty + -- Data types where, given the particular type parameters, no data + -- constructor matches, are empty. + -- This includes data types with no constructors, e.g. Data.Void.Void. + | Just (tc, inst_tys) <- splitTyConApp_maybe ty + , Just dcs <- tyConDataCons_maybe tc + , all (dataConCannotMatch inst_tys) dcs + = True + | otherwise + = False + +-- | If @normSplitTyConApp_maybe _ ty = Just (tc, tys, co)@ +-- then @ty |> co = tc tys@. It's 'splitTyConApp_maybe', but looks through +-- coercions via 'topNormaliseType_maybe'. Hence the \"norm\" prefix. +-- +-- Postcondition: tc is not a newtype (guaranteed by topNormaliseType_maybe) +normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion) +normSplitTyConApp_maybe fam_envs ty + | let Reduction co ty1 = topNormaliseType_maybe fam_envs ty + `orElse` (mkReflRedn Representational ty) + , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + , not (isNewTyCon tc) -- How can tc be a newtype, after `topNormaliseType`? + -- Answer: if it is a recursive newtype, `topNormaliseType` + -- may be a no-op. Example: tc226 + = Just (tc, tc_args, co) +normSplitTyConApp_maybe _ _ = Nothing + +{- +***************************************************** +* +* InScopeSet things +* +***************************************************** +-} + + +extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet +extendInScopeSetBind (InScope in_scope) binds + = InScope $ foldBindersOfBindStrict extendVarSet in_scope binds + +extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet +extendInScopeSetBndrs (InScope in_scope) binds + = InScope $ foldBindersOfBindsStrict extendVarSet in_scope binds + +mkInScopeSetBndrs :: [CoreBind] -> InScopeSet +mkInScopeSetBndrs binds = foldBindersOfBindsStrict extendInScopeSet emptyInScopeSet binds + +{- +***************************************************** +* +* StaticPtr +* +***************************************************** +-} + +-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields +-- @Just (makeStatic, t, srcLoc, e)@. +-- +-- Returns @Nothing@ for every other expression. +collectMakeStaticArgs + :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr) +collectMakeStaticArgs e + | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e + , idName b == makeStaticName = Just (fun, t, loc, arg) +collectMakeStaticArgs _ = Nothing + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Does this binding bind a join point (or a recursive group of join points)? +isJoinBind :: CoreBind -> Bool +isJoinBind (NonRec b _) = isJoinId b +isJoinBind (Rec ((b, _) : _)) = isJoinId b +isJoinBind _ = False + +dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc +dumpIdInfoOfProgram dump_locals ppr_id_info binds = vcat (map printId ids) + where + ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds) + getIds (NonRec i _) = [ i ] + getIds (Rec bs) = map fst bs + -- By default only include full info for exported ids, unless we run in the verbose + -- pprDebug mode. + printId id | isExportedId id || dump_locals = ppr id <> colon <+> (ppr_id_info (idInfo id)) + | otherwise = empty + +{- +************************************************************************ +* * +\subsection{Tag inference things} +* * +************************************************************************ +-} + +{- Note [Call-by-value for worker args] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we unbox a constructor with strict fields we want to +preserve the information that some of the arguments came +out of strict fields and therefore should be already properly +tagged, however we can't express this directly in core. + +Instead what we do is generate a worker like this: + + data T = MkT A !B + + foo = case T of MkT a b -> $wfoo a b + + $wfoo a b = case b of b' -> rhs[b/b'] + +This makes the worker strict in b causing us to use a more efficient +calling convention for `b` where the caller needs to ensure `b` is +properly tagged and evaluated before it's passed to $wfoo. See Note [CBV Function Ids]. + +Usually the argument will be known to be properly tagged at the call site so there is +no additional work for the caller and the worker can be more efficient since it can +assume the presence of a tag. + +This is especially true for recursive functions like this: + -- myPred expect it's argument properly tagged + myPred !x = ... + + loop :: MyPair -> Int + loop (MyPair !x !y) = + case x of + A -> 1 + B -> 2 + _ -> loop (MyPair (myPred x) (myPred y)) + +Here we would ordinarily not be strict in y after unboxing. +However if we pass it as a regular argument then this means on +every iteration of loop we will incur an extra seq on y before +we can pass it to `myPred` which isn't great! That is in STG after +tag inference we get: + + Rec { + Find.$wloop [InlPrag=[2], Occ=LoopBreaker] + :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int# + [GblId[StrictWorker([!, ~])], + Arity=2, + Str=<1L>, + Unf=OtherCon []] = + {} \r [x y] + case x of x' [Occ=Once1] { + __DEFAULT -> + case y of y' [Occ=Once1] { + __DEFAULT -> + case Find.$wmyPred y' of pred_y [Occ=Once1] { + __DEFAULT -> + case Find.$wmyPred x' of pred_x [Occ=Once1] { + __DEFAULT -> Find.$wloop pred_x pred_y; + }; + }; + Find.A -> 1#; + Find.B -> 2#; + }; + end Rec } + +Here comes the tricky part: If we make $wloop strict in both x/y and we get: + + Rec { + Find.$wloop [InlPrag=[2], Occ=LoopBreaker] + :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int# + [GblId[StrictWorker([!, !])], + Arity=2, + Str=<1L>, + Unf=OtherCon []] = + {} \r [x y] + case y of y' [Occ=Once1] { __DEFAULT -> + case x of x' [Occ=Once1] { + __DEFAULT -> + case Find.$wmyPred y' of pred_y [Occ=Once1] { + __DEFAULT -> + case Find.$wmyPred x' of pred_x [Occ=Once1] { + __DEFAULT -> Find.$wloop pred_x pred_y; + }; + }; + Find.A -> 1#; + Find.B -> 2#; + }; + end Rec } + +Here both x and y are known to be tagged in the function body since we pass strict worker args using unlifted cbv. +This means the seqs on x and y both become no-ops and compared to the first version the seq on `y` disappears at runtime. + +The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated. +But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated +already at the call site because of the EPT Invariant! See Note [EPT enforcement] for more in this. +This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good. + +We only apply this when we think there is a benefit in doing so however. There are a number of cases in which +it would be useless to insert an extra seq. ShouldStrictifyIdForCbv tries to identify these to avoid churn in the +simplifier. See Note [Which Ids should be strictified] for details on this. +-} +mkStrictFieldSeqs :: [(Id,StrictnessMark)] -> CoreExpr -> (CoreExpr) +mkStrictFieldSeqs args rhs = + foldr addEval rhs args + where + case_ty = exprType rhs + addEval :: (Id,StrictnessMark) -> (CoreExpr) -> (CoreExpr) + addEval (arg_id,arg_cbv) (rhs) + -- Argument representing strict field. + | isMarkedStrict arg_cbv + , shouldStrictifyIdForCbv arg_id + -- Make sure to remove unfoldings here to avoid the simplifier dropping those for OtherCon[] unfoldings. + = Case (Var $! zapIdUnfolding arg_id) arg_id case_ty ([Alt DEFAULT [] rhs]) + -- Normal argument + | otherwise = do + rhs + +{- Note [Which Ids should be strictified] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some arguments we would like to convince GHC to pass them call by value. +One way to achieve this is described in see Note [Call-by-value for worker args]. + +We separate the concerns of "should we pass this argument using cbv" and +"should we do so by making the rhs strict in this argument". +This note deals with the second part. + +There are multiple reasons why we might not want to insert a seq in the rhs to +strictify a functions argument: + +1) The argument doesn't exist at runtime. + +For zero width types (like Types) there is no benefit as we don't operate on them +at runtime at all. This includes things like void#, coercions and state tokens. + +2) The argument is a unlifted type. + +If the argument is a unlifted type the calling convention already is explicitly +cbv. This means inserting a seq on this argument wouldn't do anything as the seq +would be a no-op *and* it wouldn't affect the calling convention. + +3) The argument is absent. + +If the argument is absent in the body there is no advantage to it being passed as +cbv to the function. The function won't ever look at it so we don't safe any work. + +This mostly happens for join point. For example we might have: + + data T = MkT ![Int] [Char] + f t = case t of MkT xs{strict} ys-> snd (xs,ys) + +and abstract the case alternative to: + + f t = join j1 = \xs ys -> snd (xs,ys) + in case t of MkT xs{strict} ys-> j1 xs xy + +While we "use" xs inside `j1` it's not used inside the function `snd` we pass it to. +In short a absent demand means neither our RHS, nor any function we pass the argument +to will inspect it. So there is no work to be saved by forcing `xs` early. + +NB: There is an edge case where if we rebox we *can* end up seqing an absent value. +Note [Absent fillers] has an example of this. However this is so rare it's not worth +caring about here. + +4) The argument is already strict. + +Consider this code: + + data T = MkT ![Int] + f t = case t of MkT xs{strict} -> reverse xs + +The `xs{strict}` indicates that `xs` is used strictly by the `reverse xs`. +If we do a w/w split, and add the extra eval on `xs`, we'll get + + $wf xs = + case xs of xs1 -> + let t = MkT xs1 in + case t of MkT xs2 -> reverse xs2 + +That's not wrong; but the w/w body will simplify to + + $wf xs = case xs of xs1 -> reverse xs1 + +and now we'll drop the `case xs` because `xs1` is used strictly in its scope. +Adding that eval was a waste of time. So don't add it for strictly-demanded Ids. + +5) Functions + +Functions are tricky (see Note [TagInfo of functions] in EnforceEpt). +But the gist of it even if we make a higher order function argument strict +we can't avoid the tag check when it's used later in the body. +So there is no benefit. + +-} +-- | Do we expect there to be any benefit if we make this var strict +-- in order for it to get treated as as cbv argument? +-- See Note [Which Ids should be strictified] +-- See Note [CBV Function Ids] for more background. +shouldStrictifyIdForCbv :: Var -> Bool +shouldStrictifyIdForCbv = wantCbvForId False + +-- Like shouldStrictifyIdForCbv but also wants to use cbv for strict args. +shouldUseCbvForId :: Var -> Bool +shouldUseCbvForId = wantCbvForId True + +-- When we strictify we want to skip strict args otherwise the logic is the same +-- as for shouldUseCbvForId so we common up the logic here. +-- Basically returns true if it would be beneficial for runtime to pass this argument +-- as CBV independent of weither or not it's correct. E.g. it might return true for lazy args +-- we are not allowed to force. +wantCbvForId :: Bool -> Var -> Bool +wantCbvForId cbv_for_strict v + -- Must be a runtime var. + -- See Note [Which Ids should be strictified] point 1) + | isId v + , not $ isZeroBitTy ty + -- Unlifted things don't need special measures to be treated as cbv + -- See Note [Which Ids should be strictified] point 2) + , mightBeLiftedType ty + -- Functions sometimes get a zero tag so we can't eliminate the tag check. + -- See Note [TagInfo of functions] in EnforceEpt. + -- See Note [Which Ids should be strictified] point 5) + , not $ isFunTy ty + -- If the var is strict already a seq is redundant. + -- See Note [Which Ids should be strictified] point 4) + , not (isStrictDmd dmd) || cbv_for_strict + -- If the var is absent a seq is almost always useless. + -- See Note [Which Ids should be strictified] point 3) + , not (isAbsDmd dmd) + = True + | otherwise + = False + where + ty = idType v + dmd = idDemandInfo v + +{- ********************************************************************* +* * + unsafeEqualityProof +* * +********************************************************************* -} + +isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr +-- See (U3) and (U4) in +-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce +isUnsafeEqualityCase scrut bndr alts + | [Alt ac _ rhs] <- alts + , DataAlt dc <- ac + , dc `hasKey` unsafeReflDataConKey + , isDeadBinder bndr + -- We can only discard the case if the case-binder is dead + -- It usually is, but see #18227 + , Var v `App` _ `App` _ `App` _ <- scrut + , v `hasKey` unsafeEqualityProofIdKey + -- Check that the scrutinee really is unsafeEqualityProof + -- and not, say, error + = Just rhs + | otherwise + = Nothing diff --git a/GHC/CoreToIface.hs b/GHC/CoreToIface.hs new file mode 100644 --- /dev/null +++ b/GHC/CoreToIface.hs @@ -0,0 +1,801 @@ +{-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*] + +-- | Functions for converting Core things to interface file things. +module GHC.CoreToIface + ( -- * Binders + toIfaceTvBndr + , toIfaceTvBndrs + , toIfaceIdBndr + , toIfaceBndr + , toIfaceTopBndr + , toIfaceForAllBndr + , toIfaceForAllBndrs + , toIfaceTyVar + -- * Types + , toIfaceType, toIfaceTypeX + , toIfaceKind + , toIfaceTcArgs + , toIfaceTyCon + , toIfaceTyCon_name + , toIfaceTyLit + -- * Tidying types + , tidyToIfaceType + , tidyToIfaceContext + , tidyToIfaceTcArgs + -- * Coercions + , toIfaceCoercion, toIfaceCoercionX + -- * Pattern synonyms + , patSynToIfaceDecl + -- * Expressions + , toIfaceExpr + , toIfaceBang + , toIfaceSrcBang + , toIfaceLetBndr + , toIfaceIdDetails + , toIfaceIdInfo + , toIfUnfolding + , toIfaceTickish + , toIfaceBind + , toIfaceTopBind + , toIfaceAlt + , toIfaceCon + , toIfaceApp + , toIfaceVar + -- * Other stuff + , toIfaceLFInfo + , toIfaceBooleanFormula + ) where + +import GHC.Prelude + +import GHC.StgToCmm.Types + +import GHC.Core +import GHC.Core.TyCon hiding ( pprPromotionQuote ) +import GHC.Core.Coercion.Axiom +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.PatSyn +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCo.Tidy + +import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon ) +import GHC.Builtin.Types ( heqTyCon ) + +import GHC.Iface.Syntax +import GHC.Data.FastString +import GHC.Data.BooleanFormula qualified as BF(BooleanFormula(..)) + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Id.Make ( noinlineIdName, noinlineConstraintIdName ) +import GHC.Types.Literal +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Tickish +import GHC.Types.Demand ( isNopSig ) +import GHC.Types.Cpr ( topCprSig ) +import GHC.Types.SrcLoc (unLoc) + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Hs.Extension (GhcRn) + +import Data.Maybe ( isNothing, catMaybes ) + +{- Note [Avoiding space leaks in toIface*] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Building a interface file depends on the output of the simplifier. +If we build these lazily this would mean keeping the Core AST alive +much longer than necessary causing a space "leak". + +This happens for example when we only write the interface file to disk +after code gen has run, in which case we might carry megabytes of core +AST in the heap which is no longer needed. + +We avoid this in two ways. +* First we use -XStrict in GHC.CoreToIface which avoids many thunks + to begin with. +* Second we define NFData instance for Iface syntax and use them to + force any remaining thunks. + +-XStrict is not sufficient as patterns of the form `f (g x)` would still +result in a thunk being allocated for `g x`. + +NFData is sufficient for the space leak, but using -XStrict reduces allocation +by ~0.1% when compiling with -O. (nofib/spectral/simple, T10370). +It's essentially free performance hence we use -XStrict on top of NFData. + +MR !1633 on gitlab, has more discussion on the topic. +-} + +---------------- +toIfaceTvBndr :: TyVar -> IfaceTvBndr +toIfaceTvBndr = toIfaceTvBndrX emptyVarSet + +toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr +toIfaceTvBndrX fr tyvar = ( mkIfLclName (occNameFS (getOccName tyvar)) + , toIfaceTypeX fr (tyVarKind tyvar) + ) + +toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr] +toIfaceTvBndrs = map toIfaceTvBndr + +toIfaceIdBndr :: Id -> IfaceIdBndr +toIfaceIdBndr = toIfaceIdBndrX emptyVarSet + +toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr +toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar) + , mkIfLclName (occNameFS (getOccName covar)) + , toIfaceTypeX fr (varType covar) + ) + +toIfaceBndr :: Var -> IfaceBndr +toIfaceBndr var + | isId var = IfaceIdBndr (toIfaceIdBndr var) + | otherwise = IfaceTvBndr (toIfaceTvBndr var) + +toIfaceBndrX :: VarSet -> Var -> IfaceBndr +toIfaceBndrX fr var + | isId var = IfaceIdBndr (toIfaceIdBndrX fr var) + | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var) + +toIfaceForAllBndrs :: [VarBndr TyCoVar vis] -> [VarBndr IfaceBndr vis] +toIfaceForAllBndrs = map toIfaceForAllBndr + +toIfaceForAllBndr :: VarBndr TyCoVar flag -> VarBndr IfaceBndr flag +toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet + +toIfaceForAllBndrX :: VarSet -> (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) +toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis + +{- +************************************************************************ +* * + Conversion from Type to IfaceType +* * +************************************************************************ +-} + +toIfaceKind :: Type -> IfaceType +toIfaceKind = toIfaceType + +--------------------- +toIfaceType :: Type -> IfaceType +toIfaceType = toIfaceTypeX emptyVarSet + +toIfaceTypeX :: VarSet -> Type -> IfaceType +-- (toIfaceTypeX free ty) +-- translates the tyvars in 'free' as IfaceFreeTyVars +-- +-- Synonyms are retained in the interface type +toIfaceTypeX fr (TyVarTy tv) -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type + | tv `elemVarSet` fr = IfaceFreeTyVar tv + | otherwise = IfaceTyVar (toIfaceTyVar tv) +toIfaceTypeX fr ty@(AppTy {}) = + -- Flatten as many argument AppTys as possible, then turn them into an + -- IfaceAppArgs list. + -- See Note [Suppressing invisible arguments] in GHC.Iface.Type. + let (head, args) = splitAppTys ty + in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args) +toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n) +toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b) + (toIfaceTypeX (fr `delVarSet` binderVar b) t) +toIfaceTypeX fr (FunTy { ft_arg = t1, ft_mult = w, ft_res = t2, ft_af = af }) + = IfaceFunTy af (toIfaceTypeX fr w) (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) +toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co) +toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co) + +toIfaceTypeX fr (TyConApp tc tys) + -- tuples + | Just sort <- tyConTuple_maybe tc + , n_tys == arity + = IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys) + + | Just dc <- isPromotedDataCon_maybe tc + , isBoxedTupleDataCon dc + , n_tys == 2*arity + = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys)) + + | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ] + , (k1:k2:_) <- tys + = let info = mkIfaceTyConInfo NotPromoted sort + sort | k1 `eqType` k2 = IfaceEqualityTyCon + | otherwise = IfaceNormalTyCon + in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys) + + -- other applications + | otherwise + = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys) + where + arity = tyConArity tc + n_tys = length tys + +toIfaceTyVar :: TyVar -> IfLclName +toIfaceTyVar = mkIfLclName . occNameFS . getOccName + +toIfaceCoVar :: CoVar -> IfLclName +toIfaceCoVar = mkIfLclName . occNameFS . getOccName + +---------------- +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTyCon tc + = IfaceTyCon tc_name info + where + tc_name = tyConName tc + info = mkIfaceTyConInfo promoted sort + promoted | isDataKindsPromotedDataCon tc = IsPromoted + | otherwise = NotPromoted + + tupleSort :: TyCon -> Maybe IfaceTyConSort + tupleSort tc' = + case tyConTuple_maybe tc' of + Just UnboxedTuple -> let arity = tyConArity tc' `div` 2 + in Just $ IfaceTupleTyCon arity UnboxedTuple + Just sort -> let arity = tyConArity tc' + in Just $ IfaceTupleTyCon arity sort + Nothing -> Nothing + + sort + | Just tsort <- tupleSort tc = tsort + + | Just dcon <- isPromotedDataCon_maybe tc + , let tc' = dataConTyCon dcon + , Just tsort <- tupleSort tc' = tsort + + | isUnboxedSumTyCon tc + , Just cons <- tyConDataCons_maybe tc = IfaceSumTyCon (length cons) + + | otherwise = IfaceNormalTyCon + + +toIfaceTyCon_name :: Name -> IfaceTyCon +toIfaceTyCon_name n = IfaceTyCon n info + where info = mkIfaceTyConInfo NotPromoted IfaceNormalTyCon + -- Used for the "rough-match" tycon stuff, + -- where pretty-printing is not an issue + +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x +toIfaceTyLit (StrTyLit x) = IfaceStrTyLit (LexicalFastString x) +toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x + +---------------- +toIfaceCoercion :: Coercion -> IfaceCoercion +toIfaceCoercion = toIfaceCoercionX emptyVarSet + +toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion +-- (toIfaceCoercionX free ty) +-- translates the tyvars in 'free' as IfaceFreeTyVars +toIfaceCoercionX fr co + = go co + where + go_mco MRefl = IfaceMRefl + go_mco (MCo co) = IfaceMCo $ go co + + go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty) + go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco) + go (CoVarCo cv) + -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type + | cv `elemVarSet` fr = IfaceFreeCoVar cv + | otherwise = IfaceCoVarCo (toIfaceCoVar cv) + go (HoleCo h) = IfaceHoleCo (coHoleCoVar h) + + go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) + go (SymCo co) = IfaceSymCo (go co) + go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2) + go (SelCo d co) = IfaceSelCo d (go co) + go (LRCo lr co) = IfaceLRCo lr (go co) + go (InstCo co arg) = IfaceInstCo (go co) (go arg) + go (KindCo c) = IfaceKindCo (go c) + go (SubCo co) = IfaceSubCo (go co) + go (AxiomCo ax cs) = IfaceAxiomCo (toIfaceAxiomRule ax) (map go cs) + go (UnivCo { uco_prov = p, uco_role = r, uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = IfaceUnivCo p r (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) (map go deps) + + go co@(TyConAppCo r tc cos) + = assertPpr (isNothing (tyConAppFunCo_maybe r tc cos)) (ppr co) $ + IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) + + go (FunCo { fco_role = r, fco_mult = w, fco_arg = co1, fco_res = co2 }) + = IfaceFunCo r (go w) (go co1) (go co2) + + go (ForAllCo tv visL visR k co) + = IfaceForAllCo (toIfaceBndr tv) + visL + visR + (toIfaceCoercionX fr' k) + (toIfaceCoercionX fr' co) + where + fr' = fr `delVarSet` tv + +toIfaceAxiomRule :: CoAxiomRule -> IfaceAxiomRule +toIfaceAxiomRule (BuiltInFamRew bif) = IfaceAR_X (mkIfLclName (bifrw_name bif)) +toIfaceAxiomRule (BuiltInFamInj bif) = IfaceAR_X (mkIfLclName (bifinj_name bif)) +toIfaceAxiomRule (BranchedAxiom ax i) = IfaceAR_B (coAxiomName ax) i +toIfaceAxiomRule (UnbranchedAxiom ax) = IfaceAR_U (coAxiomName ax) + +toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs +toIfaceTcArgs = toIfaceTcArgsX emptyVarSet + +toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs +toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args + +toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs +toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args + +toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs +-- See Note [Suppressing invisible arguments] in GHC.Iface.Type +-- We produce a result list of args describing visibility +-- The awkward case is +-- T :: forall k. * -> k +-- And consider +-- T (forall j. blah) * blib +-- Is 'blib' visible? It depends on the visibility flag on j, +-- so we have to substitute for k. Annoying! +toIfaceAppArgsX fr kind ty_args + | null ty_args + = IA_Nil + | otherwise + = go (mkEmptySubst in_scope) kind ty_args + where + in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) + + go _ _ [] = IA_Nil + go env ty ts + | Just ty' <- coreView ty + = go env ty' ts + go env (ForAllTy (Bndr tv vis) res) (t:ts) + = IA_Arg t' vis ts' + where + t' = toIfaceTypeX fr t + ts' = go (extendTCvSubst env tv t) res ts + + go env (FunTy { ft_af = af, ft_res = res }) (t:ts) + = assert (isVisibleFunArg af) + IA_Arg (toIfaceTypeX fr t) Required (go env res ts) + + go env ty ts@(t1:ts1) + | not (isEmptyTCvSubst env) + = go (zapSubst env) (substTy env ty) ts + -- See Note [Care with kind instantiation] in GHC.Core.Type + + | otherwise + = -- There's a kind error in the type we are trying to print + -- e.g. kind = k, ty_args = [Int] + -- This is probably a compiler bug, so we print a trace and + -- carry on as if it were FunTy. Without the test for + -- isEmptyTCvSubst we'd get an infinite loop (#15473) + warnPprTrace True "toIfaceAppArgsX" (ppr kind $$ ppr ty_args) $ + IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1) + +tidyToIfaceType :: TidyEnv -> Type -> IfaceType +tidyToIfaceType env ty = toIfaceType (tidyType env ty) + +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs +tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) + +tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext +tidyToIfaceContext env theta = map (tidyToIfaceType env) theta + +{- +************************************************************************ +* * + Conversion of pattern synonyms +* * +************************************************************************ +-} + +patSynToIfaceDecl :: PatSyn -> IfaceDecl +patSynToIfaceDecl ps + = IfacePatSyn { ifName = getName $ ps + , ifPatMatcher = to_if_pr (patSynMatcher ps) + , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) + , ifPatIsInfix = patSynIsInfix ps + , ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs' + , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs' + , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta + , ifPatReqCtxt = tidyToIfaceContext env2 req_theta + , ifPatArgs = map (tidyToIfaceType env2 . scaledThing) args + , ifPatTy = tidyToIfaceType env2 rhs_ty + , ifFieldLabels = (patSynFieldLabels ps) + } + where + (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps + univ_bndrs = patSynUnivTyVarBinders ps + ex_bndrs = patSynExTyVarBinders ps + (env1, univ_bndrs') = tidyForAllTyBinders emptyTidyEnv univ_bndrs + (env2, ex_bndrs') = tidyForAllTyBinders env1 ex_bndrs + to_if_pr (name, _type, needs_dummy) = (name, needs_dummy) + +{- +************************************************************************ +* * + Conversion of other things +* * +************************************************************************ +-} + +toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang +toIfaceBang _ HsLazy = IfNoBang +toIfaceBang _ (HsUnpack Nothing) = IfUnpack +toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) +toIfaceBang _ (HsStrict _) = IfStrict + +toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang +toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang + +toIfaceLetBndr :: Id -> IfaceLetBndr +toIfaceLetBndr id = IfLetBndr (mkIfLclName (occNameFS (getOccName id))) + (toIfaceType (idType id)) + (toIfaceIdInfo (idInfo id)) + (idJoinPointHood id) + -- Put into the interface file any IdInfo that GHC.Core.Tidy.tidyLetBndr + -- has left on the Id. See Note [IdInfo on nested let-bindings] in GHC.Iface.Syntax + +toIfaceTopBndr :: Id -> IfaceTopBndrInfo +toIfaceTopBndr id + = if isExternalName name + then IfGblTopBndr name + else IfLclTopBndr (mkIfLclName (occNameFS (getOccName id))) (toIfaceType (idType id)) + (toIfaceIdInfo (idInfo id)) (toIfaceIdDetails (idDetails id)) + where + name = getName id + +toIfaceIdDetails :: IdDetails -> IfaceIdDetails +toIfaceIdDetails VanillaId = IfVanillaId +toIfaceIdDetails (WorkerLikeId dmds) = IfWorkerLikeId dmds +toIfaceIdDetails (DFunId {}) = IfDFunId +toIfaceIdDetails (RecSelId { sel_naughty = n + , sel_tycon = tc + , sel_fieldLabel = fl }) = + let (iface, first_con) = case tc of + RecSelData ty_con -> ( Left (toIfaceTyCon ty_con), dataConName $ head $ tyConDataCons ty_con) + RecSelPatSyn pat_syn -> ( Right (patSynToIfaceDecl pat_syn), patSynName pat_syn) + in IfRecSelId iface first_con n fl + + -- The remaining cases are all "implicit Ids" which don't + -- appear in interface files at all +toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) + IfVanillaId -- Unexpected; the other + +toIfaceIdInfo :: IdInfo -> IfaceIdInfo +toIfaceIdInfo id_info + = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo, + inline_hsinfo, unfold_hsinfo] + -- NB: strictness and arity must appear in the list before unfolding + -- See GHC.IfaceToCore.tcUnfolding + where + ------------ Arity -------------- + arity_info = arityInfo id_info + arity_hsinfo | arity_info == 0 = Nothing + | otherwise = Just (HsArity arity_info) + + ------------ Caf Info -------------- + caf_info = cafInfo id_info + caf_hsinfo = case caf_info of + NoCafRefs -> Just HsNoCafRefs + _other -> Nothing + + ------------ Strictness -------------- + -- No point in explicitly exporting TopSig + sig_info = dmdSigInfo id_info + strict_hsinfo | not (isNopSig sig_info) = Just (HsDmdSig sig_info) + | otherwise = Nothing + + ------------ CPR -------------- + cpr_info = cprSigInfo id_info + cpr_hsinfo | cpr_info /= topCprSig = Just (HsCprSig cpr_info) + | otherwise = Nothing + ------------ Unfolding -------------- + unfold_hsinfo = toIfUnfolding loop_breaker (realUnfoldingInfo id_info) + loop_breaker = isStrongLoopBreaker (occInfo id_info) + + ------------ Inline prag -------------- + inline_prag = inlinePragInfo id_info + inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing + | otherwise = Just (HsInline inline_prag) + +-------------------------- +toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem +toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs + , uf_src = src + , uf_cache = cache + , uf_guidance = guidance }) + = Just $ HsUnfold lb $ + IfCoreUnfold src cache (toIfGuidance src guidance) (toIfaceExpr rhs) + -- Yes, even if guidance is UnfNever, expose the unfolding + -- If we didn't want to expose the unfolding, GHC.Iface.Tidy would + -- have stuck in NoUnfolding. For supercompilation we want + -- to see that unfolding! + +toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) + -- No need to serialise the data constructor; + -- we can recover it from the type of the dfun + +toIfUnfolding _ (OtherCon {}) = Nothing + -- The binding site of an Id doesn't have OtherCon, except perhaps + -- where we have called trimUnfolding; and that evald'ness info is + -- not needed by importing modules + +toIfUnfolding _ BootUnfolding = Nothing + -- Can't happen; we only have BootUnfolding for imported binders + +toIfUnfolding _ NoUnfolding = Nothing + +toIfGuidance :: UnfoldingSource -> UnfoldingGuidance -> IfGuidance +toIfGuidance src guidance + | UnfWhen arity unsat_ok boring_ok <- guidance + , isStableSource src = IfWhen arity unsat_ok boring_ok + | otherwise = IfNoGuidance + +toIfaceBooleanFormula :: BF.BooleanFormula GhcRn -> IfaceBooleanFormula +toIfaceBooleanFormula = go + where + go (BF.Var nm ) = IfVar $ mkIfLclName . getOccFS . unLoc $ nm + go (BF.And bfs ) = IfAnd $ map (go . unLoc) bfs + go (BF.Or bfs ) = IfOr $ map (go . unLoc) bfs + go (BF.Parens bf) = IfParens $ (go . unLoc) bf + +{- +************************************************************************ +* * + Conversion of expressions +* * +************************************************************************ +-} + +toIfaceExpr :: CoreExpr -> IfaceExpr +toIfaceExpr (Var v) = toIfaceVar v +toIfaceExpr (Lit (LitRubbish tc r)) = IfaceLitRubbish tc (toIfaceType r) +toIfaceExpr (Lit l) = IfaceLit l +toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) +toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) +toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b) +toIfaceExpr (App f a) = toIfaceApp f [a] +toIfaceExpr (Case s x ty as) + | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) + | otherwise = IfaceCase (toIfaceExpr s) (mkIfLclName (getOccFS x)) (map toIfaceAlt as) +toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) +toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) +toIfaceExpr (Tick t e) = IfaceTick (toIfaceTickish t) (toIfaceExpr e) + +toIfaceOneShot :: Id -> IfaceOneShot +toIfaceOneShot id | isId id + , OneShotLam <- oneShotInfo (idInfo id) + = IfaceOneShot + | otherwise + = IfaceNoOneShot + +--------------------- +toIfaceTickish :: CoreTickish -> IfaceTickish +toIfaceTickish (ProfNote cc tick push) = IfaceSCC cc tick push +toIfaceTickish (HpcTick modl ix) = IfaceHpcTick modl ix +toIfaceTickish (SourceNote src (LexicalFastString names)) = + IfaceSource src names +toIfaceTickish (Breakpoint _ ix fv) = + IfaceBreakpoint ix (toIfaceVar <$> fv) + +--------------------- +toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr +toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) +toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] + +toIfaceTopBind :: Bind Id -> IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo +toIfaceTopBind b = + case b of + NonRec b r -> uncurry IfaceNonRec (do_one (b, r)) + Rec prs -> IfaceRec (map do_one prs) + where + do_one (b, rhs) = + let top_bndr = toIfaceTopBndr b + rhs' = case top_bndr of + -- Use the existing unfolding for a global binder if we store that anyway. + -- See Note [Interface File with Core: Sharing RHSs] + IfGblTopBndr {} -> if already_has_unfolding b then IfUseUnfoldingRhs else IfRhs (toIfaceExpr rhs) + -- Local binders will have had unfoldings trimmed so have + -- to serialise the whole RHS. + IfLclTopBndr {} -> IfRhs (toIfaceExpr rhs) + in (top_bndr, rhs') + + -- The sharing behaviour is currently disabled due to #22807, and relies on + -- finished #20056 to be re-enabled. + disabledDueTo22807 = True + + already_has_unfolding b = not disabledDueTo22807 + && -- The identifier has an unfolding, which we are going to serialise anyway + hasCoreUnfolding (realIdUnfolding b) + -- But not a stable unfolding, we want the optimised unfoldings. + && not (isStableUnfolding (realIdUnfolding b)) + +--------------------- +toIfaceAlt :: CoreAlt -> IfaceAlt +toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map (mkIfLclName . getOccFS) bs) (toIfaceExpr r) + +--------------------- +toIfaceCon :: AltCon -> IfaceConAlt +toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc) +toIfaceCon (LitAlt l) = assertPpr (not (isLitRubbish l)) (ppr l) $ + -- assert: see Note [Rubbish literals] wrinkle (b) + IfaceLitAlt l +toIfaceCon DEFAULT = IfaceDefaultAlt + +--------------------- +toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr +toIfaceApp (App f a) as = toIfaceApp f (a:as) +toIfaceApp (Var v) as + = case isDataConWorkId_maybe v of + -- We convert the *worker* for tuples into IfaceTuples + Just dc | saturated + , Just tup_sort <- tyConTuple_maybe tc + -> IfaceTuple tup_sort tup_args + where + val_args = dropWhile isTypeArg as + saturated = val_args `lengthIs` idArity v + tup_args = map toIfaceExpr val_args + tc = dataConTyCon dc + + _ -> mkIfaceApps (toIfaceVar v) as + +toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as + +mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr +mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as + +--------------------- +toIfaceVar :: Id -> IfaceExpr +toIfaceVar v + | isBootUnfolding (idUnfolding v) + = -- See Note [Inlining and hs-boot files] + IfaceApp (IfaceApp (IfaceExt noinline_id) + (IfaceType (toIfaceType ty))) + (IfaceExt name) -- don't use mkIfaceApps, or infinite loop + + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) + -- Foreign calls have special syntax + + | isExternalName name = IfaceExt name + | otherwise = IfaceLcl (mkIfLclName (occNameFS $ nameOccName name)) + where + name = idName v + ty = idType v + noinline_id | isConstraintKind (typeKind ty) = noinlineConstraintIdName + | otherwise = noinlineIdName + + + +--------------------- +toIfaceLFInfo :: Name -> LambdaFormInfo -> IfaceLFInfo +toIfaceLFInfo nm lfi = case lfi of + LFReEntrant top_lvl arity no_fvs _arg_descr -> + -- Exported LFReEntrant closures are top level, and top-level closures + -- don't have free variables + assertPpr (isTopLevel top_lvl) (ppr nm) $ + assertPpr no_fvs (ppr nm) $ + IfLFReEntrant arity + LFThunk top_lvl no_fvs updatable sfi mb_fun -> + -- Exported LFThunk closures are top level (which don't have free + -- variables) and non-standard (see cgTopRhsClosure) + assertPpr (isTopLevel top_lvl) (ppr nm) $ + assertPpr no_fvs (ppr nm) $ + assertPpr (sfi == NonStandardThunk) (ppr nm) $ + IfLFThunk updatable mb_fun + LFCon dc -> + IfLFCon (dataConName dc) + LFUnknown mb_fun -> + IfLFUnknown mb_fun + LFUnlifted -> + IfLFUnlifted + LFLetNoEscape -> + panic "toIfaceLFInfo: LFLetNoEscape" + + +{- Note [Inlining and hs-boot files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example (#10083, #12789): + + ---------- RSR.hs-boot ------------ + module RSR where + data RSR + eqRSR :: RSR -> RSR -> Bool + + ---------- SR.hs ------------ + module SR where + import {-# SOURCE #-} RSR + data SR = MkSR RSR + eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 + + ---------- RSR.hs ------------ + module RSR where + import SR + data RSR = MkRSR SR -- deriving( Eq ) + eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) + foo x y = not (eqRSR x y) + +When compiling RSR we get this code + + RSR.eqRSR :: RSR -> RSR -> Bool + RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) -> + case ds1 of _ { RSR.MkRSR s1 -> + case ds2 of _ { RSR.MkRSR s2 -> + SR.eqSR s1 s2 }} + + RSR.foo :: RSR -> RSR -> Bool + RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y) + +Now, when optimising foo: + Inline eqRSR (small, non-rec) + Inline eqSR (small, non-rec) +but the result of inlining eqSR from SR is another call to eqRSR, so +everything repeats. Neither eqSR nor eqRSR are (apparently) loop +breakers. + +Solution: in the unfolding of eqSR in SR.hi, replace `eqRSR` in SR +with `noinline eqRSR`, so that eqRSR doesn't get inlined. This means +that when GHC inlines `eqSR`, it will not also inline `eqRSR`, exactly +as would have been the case if `foo` had been defined in SR.hs (and +marked as a loop-breaker). + +But how do we arrange for this to happen? There are two ingredients: + + 1. When we serialize out unfoldings to IfaceExprs (toIfaceVar), + for every variable reference we see if we are referring to an + 'Id' that came from an hs-boot file. If so, we add a `noinline` + to the reference. See Note [noinlineId magic] + in GHC.Types.Id.Make + + 2. But how do we know if a reference came from an hs-boot file + or not? We could record this directly in the 'IdInfo', but + actually we deduce this by looking at the unfolding: 'Id's + that come from boot files are given a special unfolding + (upon typechecking) 'BootUnfolding' which say that there is + no unfolding, and the reason is because the 'Id' came from + a boot file. + +Here is a solution that doesn't work: when compiling RSR, +add a NOINLINE pragma to every function exported by the boot-file +for RSR (if it exists). Doing so makes the bootstrapped GHC itself +slower by 8% overall (on #9872a-d, and T1969: the reason +is that these NOINLINE'd functions now can't be profitably inlined +outside of the hs-boot loop. + +Note [Interface File with Core: Sharing RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +IMPORTANT: This optimisation is currently disabled due to #22807, it can be + re-enabled once #22056 is implemented. + +In order to avoid duplicating definitions for bindings which already have unfoldings +we do some minor headstands to avoid serialising the RHS of a definition if it has +*any* unfolding. + +* Only global things have unfoldings, because local things have had their unfoldings stripped. +* For any global thing which has an unstable unfolding, we just use that. + +In order to implement this sharing: + +* When creating the interface, check the criteria above and don't serialise the RHS + if such a case. + +* When reading an interface, look at the realIdUnfolding, and then the + maybeUnfoldingTemplate. See `tc_iface_binding` for where this happens. + +There are two main reasons why the mi_extra_decls field exists rather than shoe-horning +all the core bindings + +1. mi_extra_decls retains the recursive group structure of the original program which + is very convenient as otherwise we would have to do the analysis again when loading + the program. +2. There are additional local top-level bindings which don't make it into mi_decls. It's + best to keep these separate from mi_decls as mi_decls is used to compute the ABI hash. + +-} diff --git a/GHC/CoreToIface.hs-boot b/GHC/CoreToIface.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/CoreToIface.hs-boot @@ -0,0 +1,18 @@ +module GHC.CoreToIface where + +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion ) +import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceBndr + , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) +import GHC.Types.Var ( VarBndr, TyCoVar ) +import GHC.Types.Var.Env ( TidyEnv ) +import GHC.Core.TyCon ( TyCon ) +import GHC.Types.Var.Set( VarSet ) + +-- For GHC.Core.TyCo.Rep +toIfaceTypeX :: VarSet -> Type -> IfaceType +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceForAllBndrs :: [VarBndr TyCoVar flag] -> [VarBndr IfaceBndr flag] +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs +toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs diff --git a/GHC/CoreToStg.hs b/GHC/CoreToStg.hs new file mode 100644 --- /dev/null +++ b/GHC/CoreToStg.hs @@ -0,0 +1,900 @@ +{-# LANGUAGE DataKinds #-} + +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} + +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- + +-------------------------------------------------------------- +-- Converting Core to STG Syntax +-------------------------------------------------------------- + +-- And, as we have the info in hand, we may convert some lets to +-- let-no-escapes. + +module GHC.CoreToStg ( CoreToStgOpts (..), coreToStg ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Opt.Arity ( manifestArity ) +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.DataCon + +import GHC.Stg.Syntax +import GHC.Stg.Debug +import GHC.Stg.Make +import GHC.Stg.Utils (allowTopLevelConApp) + +import GHC.Types.RepType +import GHC.Types.Id.Make ( coercionTokenId ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.CostCentre +import GHC.Types.Tickish +import GHC.Types.Var.Env +import GHC.Types.Name ( isExternalName ) +import GHC.Types.Basic ( Arity, TypeOrConstraint(..) ) +import GHC.Types.Literal +import GHC.Types.ForeignCall +import GHC.Types.IPE + +import GHC.Unit.Module +import GHC.Platform ( Platform ) +import GHC.Platform.Ways +import GHC.Builtin.PrimOps + +import GHC.Utils.Outputable +import GHC.Utils.Monad +import GHC.Utils.Misc (HasDebugCallStack) +import GHC.Utils.Panic + +import Control.Monad (ap) + +-- Note [Live vs free] +-- ~~~~~~~~~~~~~~~~~~~ +-- +-- The two are not the same. Liveness is an operational property rather +-- than a semantic one. A variable is live at a particular execution +-- point if it can be referred to directly again. In particular, a dead +-- variable's stack slot (if it has one): +-- +-- - should be stubbed to avoid space leaks, and +-- - may be reused for something else. +-- +-- There ought to be a better way to say this. Here are some examples: +-- +-- let v = [q] \[x] -> e +-- in +-- ...v... (but no q's) +-- +-- Just after the `in', v is live, but q is dead. If the whole of that +-- let expression was enclosed in a case expression, thus: +-- +-- case (let v = [q] \[x] -> e in ...v...) of +-- alts[...q...] +-- +-- (ie `alts' mention `q'), then `q' is live even after the `in'; because +-- we'll return later to the `alts' and need it. +-- +-- Let-no-escapes make this a bit more interesting: +-- +-- let-no-escape v = [q] \ [x] -> e +-- in +-- ...v... +-- +-- Here, `q' is still live at the `in', because `v' is represented not by +-- a closure but by the current stack state. In other words, if `v' is +-- live then so is `q'. Furthermore, if `e' mentions an enclosing +-- let-no-escaped variable, then its free variables are also live if `v' is. + +-- Note [What are these SRTs all about?] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Consider the Core program, +-- +-- fibs = go 1 1 +-- where go a b = let c = a + c +-- in c : go b c +-- add x = map (\y -> x*y) fibs +-- +-- In this case we have a CAF, 'fibs', which is quite large after evaluation and +-- has only one possible user, 'add'. Consequently, we want to ensure that when +-- all references to 'add' die we can garbage collect any bit of 'fibs' that we +-- have evaluated. +-- +-- However, how do we know whether there are any references to 'fibs' still +-- around? Afterall, the only reference to it is buried in the code generated +-- for 'add'. The answer is that we record the CAFs referred to by a definition +-- in its info table, namely a part of it known as the Static Reference Table +-- (SRT). +-- +-- Since SRTs are so common, we use a special compact encoding for them in: we +-- produce one table containing a list of CAFs in a module and then include a +-- bitmap in each info table describing which entries of this table the closure +-- references. +-- +-- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki. + +-- Note [What is a non-escaping let] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- NB: Nowadays this is recognized by the occurrence analyser by turning a +-- "non-escaping let" into a join point. The following is then an operational +-- account of join points. +-- +-- Consider: +-- +-- let x = fvs \ args -> e +-- in +-- if ... then x else +-- if ... then x else ... +-- +-- `x' is used twice (so we probably can't unfold it), but when it is +-- entered, the stack is deeper than it was when the definition of `x' +-- happened. Specifically, if instead of allocating a closure for `x', +-- we saved all `x's fvs on the stack, and remembered the stack depth at +-- that moment, then whenever we enter `x' we can simply set the stack +-- pointer(s) to these remembered (compile-time-fixed) values, and jump +-- to the code for `x'. +-- +-- All of this is provided x is: +-- 1. non-updatable; +-- 2. guaranteed to be entered before the stack retreats -- ie x is not +-- buried in a heap-allocated closure, or passed as an argument to +-- something; +-- 3. all the enters have exactly the right number of arguments, +-- no more no less; +-- 4. all the enters are tail calls; that is, they return to the +-- caller enclosing the definition of `x'. +-- +-- Under these circumstances we say that `x' is non-escaping. +-- +-- An example of when (4) does not hold: +-- +-- let x = ... +-- in case x of ...alts... +-- +-- Here, `x' is certainly entered only when the stack is deeper than when +-- `x' is defined, but here it must return to ...alts... So we can't just +-- adjust the stack down to `x''s recalled points, because that would lost +-- alts' context. +-- +-- Things can get a little more complicated. Consider: +-- +-- let y = ... +-- in let x = fvs \ args -> ...y... +-- in ...x... +-- +-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a +-- non-escaping way in ...y..., then `y' is non-escaping. +-- +-- `x' can even be recursive! Eg: +-- +-- letrec x = [y] \ [v] -> if v then x True else ... +-- in +-- ...(x b)... + +-- Note [Cost-centre initialization plan] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`, +-- and the fields were then fixed by a separate pass `stgMassageForProfiling`. +-- We now initialize these correctly. The initialization works like this: +-- +-- - For non-top level bindings always use `currentCCS`. +-- +-- - For top-level bindings, check if the binding is a CAF +-- +-- - CAF: If -fcaf-all is enabled, create a new CAF just for this CAF +-- and use it. Note that these new cost centres need to be +-- collected to be able to generate cost centre initialization +-- code, so `coreToTopStgRhs` now returns `CollectedCCs`. +-- +-- If -fcaf-all is not enabled, use "all CAFs" cost centre. +-- +-- - Non-CAF: Top-level (static) data is not counted in heap profiles; nor +-- do we set CCCS from it; so we just slam in +-- dontCareCostCentre. + +-- Note [Coercion tokens] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- In coreToStgArgs, we drop type arguments completely, but we replace +-- coercions with a special coercionToken# placeholder. Why? Consider: +-- +-- f :: forall a. Int ~# Bool -> a +-- f = /\a. \(co :: Int ~# Bool) -> error "impossible" +-- +-- If we erased the coercion argument completely, we’d end up with just +-- f = error "impossible", but then f `seq` () would be ⊥! +-- +-- This is an artificial example, but back in the day we *did* treat +-- coercion lambdas like type lambdas, and we had bug reports as a +-- result. So now we treat coercion lambdas like value lambdas, but we +-- treat coercions themselves as zero-width arguments — coercionToken# +-- has representation VoidRep — which gets the best of both worlds. +-- +-- (For the gory details, see also the (unpublished) paper, “Practical +-- aspects of evidence-based compilation in System FC.”) + +-- Note [Saturation of data constructors in STG] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We guarantee that `StgConApp` is an exactly-saturated application of a data +-- constructor worker. +-- +-- * If the data constructor is /under/-saturated we just fall through to build +-- a `StgApp`. Remember, data constructor workers have a regular top-level definition +-- (injected by GHC.CoreToStg.Prep.mkDataConWorkers) so we can partially apply +-- that function. +-- +-- * If the data constructor is /over/-saturated, which can happen (see #23865) we again +-- fall through to `StgApp`. That will fail horribly at runtime (by applying data +-- constructor to an argument) but it should be in dead code, and at least the compiler +-- itself won't crash. (We could inject an error-thunk instead.) + + +-- -------------------------------------------------------------- +-- Setting variable info: top-level, binds, RHSs +-- -------------------------------------------------------------- + + +coreToStg :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram + -> ([StgTopBinding], InfoTableProvMap, CollectedCCs) +coreToStg opts@CoreToStgOpts + { coreToStg_ways = ways + , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs + , coreToStg_InfoTableMap = opt_InfoTableMap + , coreToStg_stgDebugOpts = stgDebugOpts + } this_mod ml pgm + = (pgm'', denv, final_ccs) + where + (_, (local_ccs, local_cc_stacks), pgm') + = coreTopBindsToStg opts this_mod emptyVarEnv emptyCollectedCCs pgm + + -- See Note [Mapping Info Tables to Source Positions] + (!pgm'', !denv) + | opt_InfoTableMap + = collectDebugInformation stgDebugOpts ml pgm' + | otherwise = (pgm', emptyInfoTableProvMap) + + prof = hasWay ways WayProf + + final_ccs + | prof && opt_AutoSccsOnIndividualCafs + = (local_ccs,local_cc_stacks) -- don't need "all CAFs" CC + | prof + = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks) + | otherwise + = emptyCollectedCCs + + (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod + +coreTopBindsToStg + :: CoreToStgOpts + -> Module + -> IdEnv HowBound -- environment for the bindings + -> CollectedCCs + -> CoreProgram + -> (IdEnv HowBound, CollectedCCs, [StgTopBinding]) + +coreTopBindsToStg _ _ env ccs [] + = (env, ccs, []) +coreTopBindsToStg opts this_mod env ccs (b:bs) + | NonRec _ rhs <- b, isTyCoArg rhs + = coreTopBindsToStg opts this_mod env1 ccs1 bs + | otherwise + = (env2, ccs2, b':bs') + where + (env1, ccs1, b' ) = coreTopBindToStg opts this_mod env ccs b + (env2, ccs2, bs') = coreTopBindsToStg opts this_mod env1 ccs1 bs + +coreTopBindToStg + :: CoreToStgOpts + -> Module + -> IdEnv HowBound + -> CollectedCCs + -> CoreBind + -> (IdEnv HowBound, CollectedCCs, StgTopBinding) + +coreTopBindToStg _ _ env ccs (NonRec id e) + | Just str <- exprIsTickedString_maybe e + -- top-level string literal + -- See Note [Core top-level string literals] in GHC.Core + = let + env' = extendVarEnv env id how_bound + how_bound = LetBound TopLet 0 + in (env', ccs, StgTopStringLit id str) + +coreTopBindToStg opts@CoreToStgOpts + { coreToStg_platform = platform + } this_mod env ccs (NonRec id rhs) + = let + env' = extendVarEnv env id how_bound + how_bound = LetBound TopLet $! manifestArity rhs + + (ccs', (id', stg_rhs)) = + initCts platform env $ + coreToTopStgRhs opts this_mod ccs (id,rhs) + + bind = StgTopLifted $ StgNonRec id' stg_rhs + in + -- NB: previously the assertion printed 'rhs' and 'bind' + -- as well as 'id', but that led to a black hole + -- where printing the assertion error tripped the + -- assertion again! + (env', ccs', bind) + +coreTopBindToStg opts@CoreToStgOpts + { coreToStg_platform = platform + } this_mod env ccs (Rec pairs) + = assert (not (null pairs)) $ + let + extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) + | (b, rhs) <- pairs ] + env' = extendVarEnvList env extra_env' + + -- generate StgTopBindings and CAF cost centres created for CAFs + (ccs', stg_rhss) + = initCts platform env' $ mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs + bind = StgTopLifted $ StgRec stg_rhss + in + (env', ccs', bind) + +coreToTopStgRhs + :: CoreToStgOpts + -> Module + -> CollectedCCs + -> (Id,CoreExpr) + -> CtsM (CollectedCCs, (Id, StgRhs)) + +coreToTopStgRhs opts this_mod ccs (bndr, rhs) + = do { new_rhs <- coreToMkStgRhs bndr rhs + + ; let (stg_rhs, ccs') = + mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts)) + (coreToStg_AutoSccsOnIndividualCafs opts) + this_mod ccs bndr new_rhs + stg_arity = + stgRhsArity stg_rhs + + ; pure (ccs', (bndr, assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs)) } + where + -- It's vital that the arity on a top-level Id matches + -- the arity of the generated STG binding, else an importing + -- module will use the wrong calling convention + -- (#2844 was an example where this happened) + -- NB1: we can't move the assertion further out without + -- blocking the "knot" tied in coreTopBindsToStg + -- NB2: the arity check is only needed for Ids with External + -- Names, because they are externally visible. The CorePrep + -- pass introduces "sat" things with Local Names and does + -- not bother to set their Arity info, so don't fail for those + arity_ok stg_arity + | isExternalName (idName bndr) = id_arity == stg_arity + | otherwise = True + id_arity = idArity bndr + mk_arity_msg stg_arity + = vcat [ppr bndr, + text "Id arity:" <+> ppr id_arity, + text "STG arity:" <+> ppr stg_arity] + +-- --------------------------------------------------------------------------- +-- Expressions +-- --------------------------------------------------------------------------- + +-- coreToStgExpr panics if the input expression is a value lambda. CorePrep +-- ensures that value lambdas only exist as the RHS of bindings, which we +-- handle with the function coreToMkStgRhs. + +coreToStgExpr + :: HasDebugCallStack => CoreExpr + -> CtsM StgExpr + +-- The second and third components can be derived in a simple bottom up pass, not +-- dependent on any decisions about which variables will be let-no-escaped or +-- not. The first component, that is, the decorated expression, may then depend +-- on these components, but it in turn is not scrutinised as the basis for any +-- decisions. Hence no black holes. + +-- No bignum literal should be left by the time this is called. +-- CorePrep should have converted them all to a real core representation. +coreToStgExpr (Lit (LitNumber LitNumBigNat _)) = panic "coreToStgExpr: LitNumBigNat" +coreToStgExpr (Lit l) = return (StgLit l) +coreToStgExpr (Var v) = coreToStgApp v [] [] (idType v) +coreToStgExpr (Coercion _) + -- See Note [Coercion tokens] + = coreToStgApp coercionTokenId [] [] (idType coercionTokenId) + +coreToStgExpr expr@(App _ _) + = case app_head of + Var f -> coreToStgApp f args ticks res_ty -- Regular application + Lit l | isLitRubbish l -- Discard arguments if head is LitRubbish + -- Recompute representation, because in + -- '(RUBBISH[rep] x) :: (T :: TYPE rep2)' + -- rep might not be equal to rep2 + -> return (StgLit $ LitRubbish TypeLike $ getRuntimeRep res_ty) + + _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr) + where + res_ty = exprType expr + (app_head, args, ticks) = myCollectArgs expr res_ty + +coreToStgExpr expr@(Lam _ _) + = let + (args, body) = myCollectBinders expr + in + case filterStgBinders args of + + [] -> coreToStgExpr body + + _ -> pprPanic "coretoStgExpr" $ + text "Unexpected value lambda:" $$ ppr expr + +coreToStgExpr (Tick tick expr) + = do + let !stg_tick = coreToStgTick (exprType expr) tick + !expr2 <- coreToStgExpr expr + return (StgTick stg_tick expr2) + +coreToStgExpr (Cast expr _) + = coreToStgExpr expr + +-- Cases require a little more real work. +coreToStgExpr (Case scrut bndr _ alts) + | null alts + -- See Note [Empty case alternatives] in GHC.Core If the case + -- alternatives are empty, the scrutinee must diverge or raise an + -- exception, so we can just dive into it. + -- + -- Of course this may seg-fault if the scrutinee *does* return. A + -- belt-and-braces approach would be to move this case into the + -- code generator, and put a return point anyway that calls a + -- runtime system error function. + = coreToStgExpr scrut + + | Just rhs <- isUnsafeEqualityCase scrut bndr alts + -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce + = coreToStgExpr rhs + + | otherwise + = do { scrut2 <- coreToStgExpr scrut + ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts) + ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) } + where + vars_alt :: CoreAlt -> CtsM StgAlt + vars_alt (Alt con binders rhs) + = let -- Remove type variables + binders' = filterStgBinders binders + in + extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do + rhs2 <- coreToStgExpr rhs + return $! GenStgAlt{ alt_con = con + , alt_bndrs = binders' + , alt_rhs = rhs2 + } + +coreToStgExpr (Let bind body) = coreToStgLet bind body +coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) + +mkStgAltType :: Id -> [CoreAlt] -> AltType +mkStgAltType bndr alts + | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty + = MultiValAlt (length prim_reps) -- always use MultiValAlt for unboxed tuples + + | otherwise + = case prim_reps of + [rep] | isGcPtrRep rep -> + case tyConAppTyCon_maybe (unwrapType bndr_ty) of + Just tc + | isAbstractTyCon tc -> look_for_better_tycon + | isAlgTyCon tc -> AlgAlt tc + | otherwise -> assertPpr (_is_poly_alt_tycon tc) (ppr tc) PolyAlt + Nothing -> PolyAlt + [non_gcd] -> PrimAlt non_gcd + not_unary -> MultiValAlt (length not_unary) + where + bndr_ty = idType bndr + prim_reps = typePrimRep bndr_ty + + _is_poly_alt_tycon tc + = isPrimTyCon tc -- "Any" is lifted but primitive + || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict + -- function application where argument has a + -- type-family type + + -- Sometimes, the TyCon is a AbstractTyCon which may not have any + -- constructors inside it. Then we may get a better TyCon by + -- grabbing the one from a constructor alternative + -- if one exists. + look_for_better_tycon + | ((Alt (DataAlt con) _ _) : _) <- data_alts = + AlgAlt (dataConTyCon con) + | otherwise = + assert (null data_alts) + PolyAlt + where + (data_alts, _deflt) = findDefault alts + +-- --------------------------------------------------------------------------- +-- Applications +-- --------------------------------------------------------------------------- + +coreToStgApp :: Id -- Function + -> [CoreArg] -- Arguments + -> [StgTickish] -- From the application nodes + -> Type -- Type of the whole application + -> CtsM StgExpr +coreToStgApp f core_args app_ticks res_ty + = do { how_bound <- lookupVarCts f + ; (stg_args, arg_ticks) <- coreToStgArgs core_args + ; let app = mkStgApp f how_bound core_args stg_args res_ty + all_ticks = app_ticks ++ arg_ticks + + -- Forcing these fixes a leak in the code generator, + -- noticed while profiling for #4367 + ; app `seq` return (foldr add_tick app all_ticks)} + where + add_tick !t !e = StgTick t e + +mkStgApp :: Id -> HowBound -> [CoreArg] -> [StgArg] -> Type -> StgExpr +mkStgApp f how_bound core_args stg_args res_ty + = case idDetails f of + DataConWorkId dc + | exactly_saturated -- See Note [Saturation of data constructors in STG] + -> if isUnboxedSumDataCon dc then + StgConApp dc NoNumber stg_args (sumPrimReps core_args) + else + StgConApp dc NoNumber stg_args [] + + -- Some primitive operator that might be implemented as a library call. + -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps + -- we require that primop applications be saturated. + PrimOpId op _ -> -- assertPpr saturated (ppr f <+> ppr stg_args) $ + StgOpApp (StgPrimOp op) stg_args res_ty + + -- A call to some primitive Cmm function. + FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True) + PrimCallConv _)) + -> assert exactly_saturated $ + StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) stg_args res_ty + + -- A regular foreign call. + FCallId call -> assert exactly_saturated $ + StgOpApp (StgFCallOp call (idType f)) stg_args res_ty + + TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,stg_args) + + _other -> StgApp f stg_args + where + -- Mostly, the arity info of a function is in the fn's IdInfo + -- But new bindings introduced by CoreSat may not have no + -- arity info; it would do us no good anyway. For example: + -- let f = \ab -> e in f + -- No point in having correct arity info for f! + -- Hence the hasArity stuff below. + -- NB: f_arity is only consulted for LetBound things + f_arity = stgArity f how_bound + n_val_args = length stg_args -- StgArgs are all value arguments + exactly_saturated = f_arity == n_val_args + + +-- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's +-- of every alternative. For example, in (#_|#) @LiftedRep @IntRep @Int @Int# 0 +-- the arguments are [Type LiftedRep, Type IntRep, Type Int, Type Int#, 0] +-- and we return the list [[LiftedRep], [IntRep]]. +-- See Note [Representations in StgConApp] in GHC.Stg.Unarise. +sumPrimReps :: [CoreArg] -> [[PrimRep]] +sumPrimReps (Type ty : args) | isRuntimeRepKindedTy ty + = runtimeRepPrimRep (text "sumPrimReps") ty : sumPrimReps args +sumPrimReps _ = [] +-- --------------------------------------------------------------------------- +-- Argument lists +-- This is the guy that turns applications into A-normal form +-- --------------------------------------------------------------------------- + +getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg +-- A (non-erased) trivial CoreArg corresponds to an atomic StgArg. +-- CoreArgs may not immediately look trivial, e.g., `case e of {}` or +-- `case unsafeequalityProof of UnsafeRefl -> e` might intervene. +-- Good thing we can just call `trivial_expr_fold` here. +getStgArgFromTrivialArg e = trivial_expr_fold StgVarArg StgLitArg panic panic e + where + panic = pprPanic "getStgArgFromTrivialArg" (ppr e) + +coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish]) +coreToStgArgs [] + = return ([], []) + +coreToStgArgs (Type _ : args) = do -- Type argument + (args', ts) <- coreToStgArgs args + return (args', ts) + +coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion tokens] + = do { (args', ts) <- coreToStgArgs args + ; return (StgVarArg coercionTokenId : args', ts) } + +coreToStgArgs (arg : args) = do -- Non-type argument + (stg_args, ticks) <- coreToStgArgs args + -- We know that `arg` must be trivial, but it may contain Ticks. + -- Example from test case `decodeMyStack`: + -- $ @... ((src Data.Tuple.snd) @Int @[..]) + -- Note that unfortunately the Tick is not at the top. + -- So we'll traverse the expression twice: + -- * Once with `stripTicksT` (which collects *all* ticks from the expression) + -- * and another time with `getStgArgFromTrivialArg`. + -- Since the argument is trivial, the only place the Tick can occur is + -- somehow wrapping a variable (give or take type args, as above). + platform <- getPlatform + let arg_ty = exprType arg + ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg) + arg' = getStgArgFromTrivialArg arg + arg_rep = typePrimRep arg_ty + stg_arg_rep = stgArgRep arg' + bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) + + massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg) + warnPprTraceM bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) + + return (arg' : stg_args, ticks' ++ ticks) + +coreToStgTick :: Type -- type of the ticked expression + -> CoreTickish + -> StgTickish +coreToStgTick _ty (HpcTick m i) = HpcTick m i +coreToStgTick _ty (SourceNote span nm) = SourceNote span nm +coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope +coreToStgTick !ty (Breakpoint _ bid fvs) = Breakpoint ty bid fvs + +-- --------------------------------------------------------------------------- +-- The magic for lets: +-- --------------------------------------------------------------------------- + +coreToStgLet + :: CoreBind -- bindings + -> CoreExpr -- body + -> CtsM StgExpr -- new let + +coreToStgLet bind body + | NonRec _ rhs <- bind, isTyCoArg rhs + = coreToStgExpr body + + | otherwise + = do { (bind2, env_ext) <- vars_bind bind + + -- Do the body + ; body2 <- extendVarEnvCts env_ext $ + coreToStgExpr body + + -- Compute the new let-expression + ; let new_let | isJoinBind bind + = StgLetNoEscape noExtFieldSilent bind2 body2 + | otherwise + = StgLet noExtFieldSilent bind2 body2 + + ; return new_let } + where + mk_binding binder rhs + = (binder, LetBound NestedLet (manifestArity rhs)) + + vars_bind :: CoreBind + -> CtsM (StgBinding, + [(Id, HowBound)]) -- extension to environment + + vars_bind (NonRec binder rhs) = do + rhs2 <- coreToStgRhs (binder,rhs) + let + env_ext_item = mk_binding binder rhs + + return (StgNonRec binder rhs2, [env_ext_item]) + + vars_bind (Rec pairs) + = let + binders = map fst pairs + env_ext = [ mk_binding b rhs + | (b,rhs) <- pairs ] + in + extendVarEnvCts env_ext $ do + rhss2 <- mapM coreToStgRhs pairs + return (StgRec (binders `zip` rhss2), env_ext) + +coreToStgRhs :: (Id,CoreExpr) + -> CtsM StgRhs + +coreToStgRhs (bndr, rhs) = do + new_rhs <- coreToMkStgRhs bndr rhs + return (mkStgRhs bndr new_rhs) + +-- Convert the RHS of a binding from Core to STG. This is a wrapper around +-- coreToStgExpr that can handle value lambdas. +coreToMkStgRhs :: HasDebugCallStack => Id -> CoreExpr -> CtsM MkStgRhs +coreToMkStgRhs bndr expr = do + let (args, body) = myCollectBinders expr + let args' = filterStgBinders args + extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do + body' <- coreToStgExpr body + let mk_rhs = MkStgRhs + { rhs_args = args' + , rhs_expr = body' + , rhs_type = exprType body + , rhs_is_join = isJoinId bndr + } + pure mk_rhs + +-- --------------------------------------------------------------------------- +-- A monad for the core-to-STG pass +-- --------------------------------------------------------------------------- + +-- There's a lot of stuff to pass around, so we use this CtsM +-- ("core-to-STG monad") monad to help. All the stuff here is only passed +-- *down*. + +newtype CtsM a = CtsM + { unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs + -> IdEnv HowBound + -> a + } + deriving (Functor) + +data HowBound + = ImportBound -- Used only as a response to lookupBinding; never + -- exists in the range of the (IdEnv HowBound) + + | LetBound -- A let(rec) in this module + LetInfo -- Whether top level or nested + Arity -- Its arity (local Ids don't have arity info at this point) + + | LambdaBound -- Used for both lambda and case + deriving (Eq) + +data LetInfo + = TopLet -- top level things + | NestedLet + deriving (Eq) + +-- For a let(rec)-bound variable, x, we record LiveInfo, the set of +-- variables that are live if x is live. This LiveInfo comprises +-- (a) dynamic live variables (ones with a non-top-level binding) +-- (b) static live variables (CAFs or things that refer to CAFs) +-- +-- For "normal" variables (a) is just x alone. If x is a let-no-escaped +-- variable then x is represented by a code pointer and a stack pointer +-- (well, one for each stack). So all of the variables needed in the +-- execution of x are live if x is, and are therefore recorded in the +-- LetBound constructor; x itself *is* included. +-- +-- The set of dynamic live variables is guaranteed ot have no further +-- let-no-escaped variables in it. + +-- The std monad functions: + +initCts :: Platform -> IdEnv HowBound -> CtsM a -> a +initCts platform env m = unCtsM m platform env + + + +{-# INLINE thenCts #-} +{-# INLINE returnCts #-} + +returnCts :: a -> CtsM a +returnCts e = CtsM $ \_ _ -> e + +thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b +thenCts m k = CtsM $ \platform env + -> unCtsM (k (unCtsM m platform env)) platform env + +instance Applicative CtsM where + pure = returnCts + (<*>) = ap + +instance Monad CtsM where + (>>=) = thenCts + +getPlatform :: CtsM Platform +getPlatform = CtsM const + +-- Functions specific to this monad: + +extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a +extendVarEnvCts ids_w_howbound expr + = CtsM $ \platform env + -> unCtsM expr platform (extendVarEnvList env ids_w_howbound) + +lookupVarCts :: Id -> CtsM HowBound +lookupVarCts v = CtsM $ \_ env -> lookupBinding env v + +lookupBinding :: IdEnv HowBound -> Id -> HowBound +lookupBinding env v = case lookupVarEnv env v of + Just xx -> xx + Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound + +-- Misc. + +filterStgBinders :: [Var] -> [Var] +filterStgBinders bndrs = filter isId bndrs + +myCollectBinders :: Expr Var -> ([Var], Expr Var) +myCollectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs (Cast e _) = go bs e + go bs e = (reverse bs, e) + +-- | If the argument expression is (potential chain of) 'App', return the head +-- of the app chain, and collect ticks/args along the chain. +-- INVARIANT: If the app head is trivial, return the atomic Var/Lit that was +-- wrapped in casts, empty case, ticks, etc. +-- So keep in sync with 'exprIsTrivial'. +myCollectArgs :: HasDebugCallStack + => CoreExpr -> Type -> (CoreExpr, [CoreArg], [StgTickish]) +myCollectArgs expr res_ty + = go expr [] [] + where + go h@(Var f) as ts + | isUnaryClassId f, (the_arg:as') <- dropWhile isTypeArg as + = go the_arg as' ts + -- See (UCM1) in Note [Unary class magic] in GHC.Core.TyCon + -- isUnaryClassId includes both the class op and the data-con + + | otherwise + = (h, as, ts) + + go (App f a) as ts = go f (a:as) ts + go (Cast e _) as ts = go e as ts + go (Tick t e) as ts = assertPpr (not (tickishIsCode t) || all isTypeArg as) + (ppr e $$ ppr as $$ ppr ts) $ + -- See Note [Ticks in applications] + -- ticks can appear in type apps + go e as (coreToStgTick res_ty t : ts) + + go (Case e b _ alts) as ts -- Just like in exprIsTrivial! + -- Otherwise we fall over in case we encounter + -- `(case f a of {}) b` in the future. + | null alts + = assertPpr (null as) (ppr e $$ ppr as $$ ppr expr) $ + go e [] ts -- NB: Empty case discards arguments + | Just rhs <- isUnsafeEqualityCase e b alts + = go rhs as ts -- Discards unsafeCoerce in App heads + + go (Lam b e) as ts + | isTyVar b + = go e (drop 1 as) ts -- Note [Collect args] + + go e as ts = (e, as, ts) + +{- Note [Collect args] +~~~~~~~~~~~~~~~~~~~~~~ +This big-lambda case occurred following a rather obscure eta expansion. +It all seems a bit yukky to me. + +Note [Ticks in applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can get an application like + (tick t f) True False +via inlining in the CorePrep pass; see Note [Inlining in CorePrep] +in GHC.CoreToStg.Prep. The tick does not satisfy tickishIsCode; +the inlining-in-CorePrep happens for cpExprIsTrivial which tests +tickishIsCode. + +So we test the same thing here, pushing any non-code ticks to +the top (they don't generate any code, after all). This showed +up in the fallout from fixing #19360. +-} + +stgArity :: Id -> HowBound -> Arity +stgArity _ (LetBound _ arity) = arity +stgArity f ImportBound = idArity f +stgArity _ LambdaBound = 0 + +data CoreToStgOpts = CoreToStgOpts + { coreToStg_platform :: Platform + , coreToStg_ways :: Ways + , coreToStg_AutoSccsOnIndividualCafs :: Bool + , coreToStg_InfoTableMap :: Bool + , coreToStg_ExternalDynamicRefs :: Bool + , coreToStg_stgDebugOpts :: StgDebugOpts + } diff --git a/GHC/CoreToStg/AddImplicitBinds.hs b/GHC/CoreToStg/AddImplicitBinds.hs new file mode 100644 --- /dev/null +++ b/GHC/CoreToStg/AddImplicitBinds.hs @@ -0,0 +1,151 @@ +{- +(c) The University of Glasgow, 1994-2006 + +Add implicit bindings +-} + +module GHC.CoreToStg.AddImplicitBinds ( addImplicitBinds ) where + +import GHC.Prelude + +import GHC.CoreToStg.Prep( CorePrepPgmConfig(..) ) + +import GHC.Unit( ModLocation(..) ) + +import GHC.Core +import GHC.Core.DataCon( DataCon, dataConWorkId, dataConWrapId ) +import GHC.Core.TyCon( TyCon, tyConDataCons, isBoxedDataTyCon, tyConClass_maybe ) +import GHC.Core.Class( classAllSelIds ) + +import GHC.Types.Name +import GHC.Types.Tickish( GenTickish( SourceNote ) ) +import GHC.Types.Id( dataConWrapUnfolding_maybe ) +import GHC.Types.Id.Make( mkDictSelRhs ) +import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) + +import GHC.Utils.Outputable +import GHC.Data.FastString + + +{- ********************************************************************* +* * + Implicit bindings +* * +********************************************************************* -} + +{- Note [Injecting implicit bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`addImplicitBinds` injects the so-called "implicit bindings" generated by +the TyCons of the module. Specifically: + + * Data constructor wrappers + * Data constructor workers: see Note [Data constructor workers] + * Class op selectors: we want curriedn versions of these too + +Note that /record selector/ are injected much earlier, at the beginning +of the pipeline -- see Note [Record selectors] in GHC.Tc.TyCl.Utils. + +At one time I tried injecting the implicit bindings *early*, at the +beginning of SimplCore. But that gave rise to real difficulty, +because GlobalIds are supposed to have *fixed* IdInfo, but the +simplifier and other core-to-core passes mess with IdInfo all the +time. The straw that broke the camels back was when a class selector +got the wrong arity -- ie the simplifier gave it arity 2, whereas +importing modules were expecting it to have arity 1 (#2844). +It's much safer just to inject them right at the end, after tidying. + +Oh: two other reasons for injecting them late: + + - If implicit Ids are already in the bindings when we start tidying, + we'd have to be careful not to treat them as external Ids (in + the sense of chooseExternalIds); else the Ids mentioned in *their* + RHSs will be treated as external and you get an interface file + saying a18 = + but nothing referring to a18 (because the implicit Id is the + one that does, and implicit Ids don't appear in interface files). + + - More seriously, the tidied type-envt will include the implicit + Id replete with a18 in its unfolding; but we won't take account + of a18 when computing a fingerprint for the class; result chaos. + +Note [Data constructor workers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Create any necessary "implicit" bindings for data con workers. We +create the rather strange (non-recursive!) binding + + $wC = \x y -> $wC x y + +i.e. a curried constructor that allocates. This means that we can +treat the worker for a constructor like any other function in the rest +of the compiler. The point here is that CoreToStg will generate a +StgConApp for the RHS, rather than a call to the worker (which would +give a loop). As Lennart says: the ice is thin here, but it works. + +Hmm. Should we create bindings for dictionary constructors? They are +always fully applied, and the bindings are just there to support +partial applications. But it's easier to let them through. +-} + + +addImplicitBinds :: CorePrepPgmConfig -> ModLocation + -> [TyCon] -> CoreProgram -> IO CoreProgram +addImplicitBinds pgm_cfg mod_loc tycons binds + = return (implicit_binds ++ binds) + where + gen_debug_info = cpPgm_generateDebugInfo pgm_cfg + implicit_binds = concatMap (mkImplicitBinds gen_debug_info mod_loc) tycons + + +mkImplicitBinds :: Bool -> ModLocation -> TyCon -> [CoreBind] +-- See Note [Data constructor workers] +-- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy +mkImplicitBinds gen_debug_info mod_loc tycon + = classop_binds ++ datacon_binds + where + datacon_binds + | isBoxedDataTyCon tycon + = concatMap (dataConBinds gen_debug_info mod_loc) (tyConDataCons tycon) + | otherwise + = [] + -- The 'otherwise' includes family TyCons of course, but also (less obviously) + -- * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make + -- * type data: we don't want any code for type-only stuff (#24620) + + classop_binds + | Just cls <- tyConClass_maybe tycon + = [ NonRec op (mkDictSelRhs cls val_index) + | (op, val_index) <- classAllSelIds cls `zip` [0..] ] + | otherwise + = [] + +dataConBinds :: Bool -> ModLocation -> DataCon -> [CoreBind] +dataConBinds gen_debug_info mod_loc data_con + = wrapper_bind ++ worker_bind + where + work_id = dataConWorkId data_con + wrap_id = dataConWrapId data_con + worker_bind = [NonRec work_id (add_tick (Var work_id))] + -- worker_bind: the ice is thin here, but it works: + -- CorePrep will eta-expand it + wrapper_bind = case dataConWrapUnfolding_maybe wrap_id of + Nothing -> [] + Just rhs -> [NonRec wrap_id rhs] + add_tick = tick_it gen_debug_info mod_loc (getName data_con) + +tick_it :: Bool -> ModLocation -> Name -> CoreExpr -> CoreExpr +-- If we want to generate debug info, we put a source note on the +-- worker. This is useful, especially for heap profiling. +tick_it generate_debug_info mod_loc name + | not generate_debug_info = id + | RealSrcSpan span _ <- nameSrcSpan name = tick span + | Just file <- ml_hs_file mod_loc = tick (span1 file) + | otherwise = tick (span1 "???") + where + tick span = Tick $ SourceNote span $ + LexicalFastString $ mkFastString $ + renderWithContext defaultSDocContext $ ppr name + span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 + + + + diff --git a/GHC/CoreToStg/Prep.hs b/GHC/CoreToStg/Prep.hs new file mode 100644 --- /dev/null +++ b/GHC/CoreToStg/Prep.hs @@ -0,0 +1,2858 @@ +{-# LANGUAGE ViewPatterns #-} + +{- +(c) The University of Glasgow, 1994-2006 + + +Core pass to saturate constructors and PrimOps +-} + +module GHC.CoreToStg.Prep + ( CorePrepConfig (..) + , CorePrepPgmConfig (..) + , corePrepPgm + , corePrepExpr + ) +where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Driver.Flags + +import GHC.Unit + +import GHC.Builtin.Names +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim + +import GHC.Core.Utils +import GHC.Core.Opt.Arity +import GHC.Core.Lint ( EndPassConfig(..), endPassIO ) +import GHC.Core +import GHC.Core.Subst +import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Opt.OccurAnal + +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Data.FastString +import GHC.Data.Graph.UnVar + +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Utils.Monad ( mapAccumLM ) +import GHC.Utils.Logger + +import GHC.Types.Demand +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Id.Make ( realWorldPrimId ) +import GHC.Types.Basic +import GHC.Types.Name ( OccName, NamedThing(..), isInternalName ) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Literal +import GHC.Types.Tickish +import GHC.Types.Unique.Supply + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import Data.ByteString.Builder.Prim + +import Control.Monad +import Data.List (intercalate) + +{- +Note [CorePrep Overview] +~~~~~~~~~~~~~~~~~~~~~~~~ + +The goal of this pass is to prepare for code generation. + +1. Saturate constructor and primop applications. + +2. Convert to A-normal form; that is, function arguments + are always variables. + + * Use case for strict arguments: + f E ==> case E of x -> f x + (where f is strict) + + * Use let for non-trivial lazy arguments + f E ==> let x = E in f x + (were f is lazy and x is non-trivial) + +3. Similarly, convert any unboxed lets into cases. + [I'm experimenting with leaving 'ok-for-speculation' + rhss in let-form right up to this point.] + +4. Ensure that *value* lambdas only occur as the RHS of a binding + (The code generator can't deal with anything else.) + Type lambdas are ok, however, because the code gen discards them. + +5. ANF-isation results in additional bindings that can obscure values. + We float these out; see Note [Floating in CorePrep]. + +6. Clone all local Ids. See Note [Cloning in CorePrep] + +7. Give each dynamic CCall occurrence a fresh unique; this is + rather like the cloning step above. + +8. Convert bignum literals into their core representation. + +9. Uphold tick consistency while doing this: We move ticks out of + (non-type) applications where we can, and make sure that we + annotate according to scoping rules when floating. + +10. Collect cost centres (including cost centres in unfoldings) if we're in + profiling mode. We have to do this here because we won't have unfoldings + after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules]. + +11. Eliminate some magic Ids, specifically + runRW# (\s. e) ==> e[readWorldId/s] + lazy e ==> e (see Note [lazyId magic] in GHC.Types.Id.Make) + noinline e ==> e + nospec e ==> e + ToDo: keepAlive# ... + This is done in cpeApp + +This is all done modulo type applications and abstractions, so that +when type erasure is done for conversion to STG, we don't end up with +any trivial or useless bindings. + +Note [CorePrep invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is the syntax of the Core produced by CorePrep: + + Trivial expressions + arg ::= lit | var + | arg ty | /\a. arg + | co | arg |> co + + Applications + app ::= lit | var | app arg | app ty | app co | app |> co + + Expressions + body ::= app + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co + + Right hand sides (only place where value lambdas can occur) + rhs ::= /\a.rhs | \x.rhs | body + +We define a synonym for each of these non-terminals. Functions +with the corresponding name produce a result in that syntax. + +Note [Cloning in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In CorePrep we +* Always clone non-CoVar Ids, so each has a unique Unique +* Sometimes clone CoVars and TyVars + +We always clone non-CoVarIds, for three reasons + +1. Things associated with labels in the final code must be truly unique in + order to avoid labels being shadowed in the final output. + +2. Even binders without info tables like function arguments or alternative + bound binders must be unique at least in their type/unique combination. + We only emit a single declaration for each binder when compiling to C + so if binders are not unique we would either get duplicate declarations + or misstyped variables. The later happend in #22402. + +3. We heavily use unique-keyed maps in the backend which can go wrong when + ids with the same unique are meant to represent the same variable. + +Generally speaking we don't clone TyVars or CoVars. The code gen doesn't need +that (they are erased), and doing so would be tiresome because then we'd need +to substitute in types and coercions. But sometimes need to: see +Note [Cloning CoVars and TyVars] + +Note [Cloning CoVars and TyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally we don't need to clone TyVars and CoVars, but there is one occasion +when we do (see #24463). When we have + case unsafeEqualityProof ... of UnsafeRefl g -> ... +we try to float it, using UnsafeEqualityCase. +Why? See (U3) in Note [Implementing unsafeCoerce] + +Alas, floating it widens the scope of `g`, and that led to catastrophe in +#24463, when two identically-named g's shadowed. + +Solution: clone `g`; see `cpCloneCoVarBndr`. + +BUT once we clone `g` we must apply the cloning substitution to all types +and coercions. But that in turn means that, given a binder like + /\ (a :: kind |> g). blah +we must substitute in a's kind, and hence need to substitute for `a` +itself in `blah`. + +So our plan is: + * Maintain a full Subst in `cpe_subst` + + * Clone a CoVar when we we meet an `isUnsafeEqualityCase`; + otherwise TyVar/CoVar binders are never cloned. + + * So generally the TCvSubst is empty + + * Apply the substitution to type and coercion arguments in Core; but + happily `substTy` has a no-op short-cut for an empty TCvSubst, so this + is usually very cheap. + + * In `cpCloneBndr`, for a tyvar/covar binder, check for an empty substitution; + in that case just do nothing +-} + +type CpeArg = CoreExpr -- Non-terminal 'arg' +type CpeApp = CoreExpr -- Non-terminal 'app' +type CpeBody = CoreExpr -- Non-terminal 'body' +type CpeRhs = CoreExpr -- Non-terminal 'rhs' + +{- +************************************************************************ +* * + Top level stuff +* * +************************************************************************ +-} + +data CorePrepPgmConfig = CorePrepPgmConfig + { cpPgm_endPassConfig :: !EndPassConfig + , cpPgm_generateDebugInfo :: !Bool + } + +corePrepPgm :: Logger + -> CorePrepConfig + -> CorePrepPgmConfig + -> Module -> CoreProgram + -> IO CoreProgram +corePrepPgm logger cp_cfg pgm_cfg + this_mod binds = + withTiming logger + (text "CorePrep"<+>brackets (ppr this_mod)) + (\a -> a `seqList` ()) $ do + let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg + + us <- mkSplitUniqSupply 's' + let + floats = initUs_ us $ + corePrepTopBinds initialCorePrepEnv binds + binds_out = deFloatTop floats + + endPassIO logger (cpPgm_endPassConfig pgm_cfg) + binds_out [] + + return binds_out + +corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr +corePrepExpr logger config expr = do + withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do + us <- mkSplitUniqSupply 's' + let initialCorePrepEnv = mkInitialCorePrepEnv config + let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) + putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) + return new_expr + +corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats +-- Note [Floating out of top level bindings] +corePrepTopBinds initialCorePrepEnv binds + = go initialCorePrepEnv binds + where + go _ [] = return emptyFloats + go env (bind : binds) = do (env', floats, maybe_new_bind) + <- cpeBind TopLevel env bind + massert (isNothing maybe_new_bind) + -- Only join points get returned this way by + -- cpeBind, and no join point may float to top + floatss <- go env' binds + return (floats `zipFloats` floatss) + +{- ********************************************************************* +* * + The main code +* * +********************************************************************* -} + +{- Note [Floating in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ANFisation risks producing a lot of nested lets that obscures values: + let v = (:) (f 14) [] in e + ==> { ANF in CorePrep } + let v = let sat = f 14 in (:) sat [] in e +Here, `v` is not a value anymore, and we'd allocate a thunk closure for `v` that +allocates a thunk for `sat` and then allocates the cons cell. +Hence we carry around a bunch of floated bindings with us so that we again +expose the values: + let v = let sat = f 14 in (:) sat [] in e + ==> { Float sat } + let sat = f 14 in + let v = (:) sat [] in e +(We will not do this transformation if `v` does not become a value afterwards; +see Note [wantFloatLocal].) +If `v` is bound at the top-level, we might even float `sat` to top-level; +see Note [Floating out of top level bindings]. +For nested let bindings, we have to keep in mind Note [Core letrec invariant] +and may exploit strict contexts; see Note [wantFloatLocal]. + +There are 3 main categories of floats, encoded in the `FloatingBind` type: + + * `Float`: A floated binding, as `sat` above. + These come in different flavours as described by their `FloatInfo` and + `BindInfo`, which captures how far the binding can be floated and whether or + not we want to case-bind. See Note [BindInfo and FloatInfo]. + * `UnsafeEqualityCase`: Used for floating around unsafeEqualityProof bindings; + see (U3) of Note [Implementing unsafeCoerce]. + It's exactly a `Float` that is `CaseBound` and `LazyContextFloatable` + (see `mkNonRecFloat`), but one that has a non-DEFAULT Case alternative to + bind the unsafe coercion field of the Refl constructor. + * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep]. + +It is quite essential that CorePrep *does not* rearrange the order in which +evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers +the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does +not attempt to reorder the telescope of Floats or float out out of non-floated +binding sites (such as Case alts) in the first place; for that it would have to +do some kind of data dependency analysis. + +Note [Floating out of top level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: we do need to float out of top-level bindings +Consider x = length [True,False] +We want to get + s1 = False : [] + s2 = True : s1 + x = length s2 + +We return a *list* of bindings, because we may start with + x* = f (g y) +where x is demanded, in which case we want to finish with + a = g y + x* = f a +And then x will actually end up case-bound + +Note [Join points and floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Join points can float out of other join points but not out of value bindings: + + let z = + let w = ... in -- can float + join k = ... in -- can't float + ... jump k ... + join j x1 ... xn = + let y = ... in -- can float (but don't want to) + join h = ... in -- can float (but not much point) + ... jump h ... + in ... + +Here, the jump to h remains valid if h is floated outward, but the jump to k +does not. + +We don't float *out* of join points. It would only be safe to float out of +nullary join points (or ones where the arguments are all either type arguments +or dead binders). Nullary join points aren't ever recursive, so they're always +effectively one-shot functions, which we don't float out of. We *could* float +join points from nullary join points, but there's no clear benefit at this +stage. + +Note [Dead code in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Imagine that we got an input program like this (see #4962): + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g True (Just x) + g () (Just x), g) + where + g :: Show a => a -> Maybe Int -> Int + g _ Nothing = x + g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown + +After specialisation and SpecConstr, we would get something like this: + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) + where + {-# RULES g $dBool = g$Bool + g $dUnit = g$Unit #-} + g = ... + {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} + g$Bool = ... + {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} + g$Unit = ... + g$Bool_True_Just = ... + g$Unit_Unit_Just = ... + +Note that the g$Bool and g$Unit functions are actually dead code: they +are only kept alive by the occurrence analyser because they are +referred to by the rules of g, which is being kept alive by the fact +that it is used (unspecialised) in the returned pair. + +However, at the CorePrep stage there is no way that the rules for g +will ever fire, and it really seems like a shame to produce an output +program that goes to the trouble of allocating a closure for the +unreachable g$Bool and g$Unit functions. + +The way we fix this is to: + * In cloneBndr, drop all unfoldings/rules + + * In deFloatTop, run a simple dead code analyser on each top-level + RHS to drop the dead local bindings. + +The reason we don't just OccAnal the whole output of CorePrep is that +the tidier ensures that all top-level binders are GlobalIds, so they +don't show up in the free variables any longer. So if you run the +occurrence analyser on the output of CoreTidy (or later) you e.g. turn +this program: + + Rec { + f = ... f ... + } + +Into this one: + + f = ... f ... + +(Since f is not considered to be free in its own RHS.) + + +Note [keepAlive# magic] +~~~~~~~~~~~~~~~~~~~~~~~ +When interacting with foreign code, it is often necessary for the user to +extend the lifetime of a heap object beyond the lifetime that would be apparent +from the on-heap references alone. For instance, a program like: + + foreign import safe "hello" hello :: ByteArray# -> IO () + + callForeign :: IO () + callForeign = IO $ \s0 -> + case newByteArray# n# s0 of (# s1, barr #) -> + unIO hello barr s1 + +As-written this program is susceptible to memory-unsafety since there are +no references to `barr` visible to the garbage collector. Consequently, if a +garbage collection happens during the execution of the C function `hello`, it +may be that the array is freed while in use by the foreign function. + +To address this, we introduced a new primop, keepAlive#, which "scopes over" +the computation needing the kept-alive value: + + keepAlive# :: forall (ra :: RuntimeRep) (rb :: RuntimeRep) (a :: TYPE a) (b :: TYPE b). + a -> State# RealWorld -> (State# RealWorld -> b) -> b + +When entered, an application (keepAlive# x s k) will apply `k` to the state +token, evaluating it to WHNF. However, during the course of this evaluation +will *guarantee* that `x` is considered to be alive. + +There are a few things to note here: + + - we are RuntimeRep-polymorphic in the value to be kept-alive. This is + necessary since we will often (but not always) be keeping alive something + unlifted (like a ByteArray#) + + - we are RuntimeRep-polymorphic in the result value since the result may take + many forms (e.g. a boxed value, a raw state token, or a (# State s, result #). + +We implement this operation by desugaring to touch# during CorePrep (see +GHC.CoreToStg.Prep.cpeApp). Specifically, + + keepAlive# x s0 k + +is transformed to: + + case k s0 of r -> + case touch# x realWorld# of s1 -> + r + +Operationally, `keepAlive# x s k` is equivalent to pushing a stack frame with a +pointer to `x` and entering `k s0`. This compilation strategy is safe +because we do no optimization on STG that would drop or re-order the +continuation containing the `touch#`. However, if we were to become more +aggressive in our STG pipeline then we would need to revisit this. + +Beyond this CorePrep transformation, there is very little special about +keepAlive#. However, we did explore (and eventually gave up on) +an optimisation which would allow unboxing of constructed product results, +which we describe below. + + +Lost optimisation: CPR unboxing +-------------------------------- +One unfortunate property of this approach is that the simplifier is unable to +unbox the result of a keepAlive# expression. For instance, consider the program: + + case keepAlive# arr s0 ( + \s1 -> case peekInt arr s1 of + (# s2, r #) -> I# r + ) of + I# x -> ... + +This is a surprisingly common pattern, previously used, e.g., in +GHC.IO.Buffer.readWord8Buf. While exploring ideas, we briefly played around +with optimising this away by pushing strict contexts (like the +`case [] of I# x -> ...` above) into keepAlive#'s continuation. While this can +recover unboxing, it can also unfortunately in general change the asymptotic +memory (namely stack) behavior of the program. For instance, consider + + writeN = + ... + case keepAlive# x s0 (\s1 -> something s1) of + (# s2, x #) -> + writeN ... + +As it is tail-recursive, this program will run in constant space. However, if +we push outer case into the continuation we get: + + writeN = + + case keepAlive# x s0 (\s1 -> + case something s1 of + (# s2, x #) -> + writeN ... + ) of + ... + +Which ends up building a stack which is linear in the recursion depth. For this +reason, we ended up giving up on this optimisation. + + +Historical note: touch# and its inadequacy +------------------------------------------ +Prior to the introduction of `keepAlive#` we instead addressed the need for +lifetime extension with the `touch#` primop: + + touch# :: a -> State# s -> State# s + +This operation would ensure that the `a` value passed as the first argument was +considered "alive" at the time the primop application is entered. + +For instance, the user might modify `callForeign` as: + + callForeign :: IO () + callForeign s0 = IO $ \s0 -> + case newByteArray# n# s0 of (# s1, barr #) -> + case unIO hello barr s1 of (# s2, () #) -> + case touch# barr s2 of s3 -> + (# s3, () #) + +However, in #14346 we discovered that this primop is insufficient in the +presence of simplification. For instance, consider a program like: + + callForeign :: IO () + callForeign s0 = IO $ \s0 -> + case newByteArray# n# s0 of (# s1, barr #) -> + case unIO (forever $ hello barr) s1 of (# s2, () #) -> + case touch# barr s2 of s3 -> + (# s3, () #) + +In this case the Simplifier may realize that (forever $ hello barr) +will never return and consequently that the `touch#` that follows is dead code. +As such, it will be dropped, resulting in memory unsoundness. +This unsoundness lead to the introduction of keepAlive#. + + + +Other related tickets: + + - #15544 + - #17760 + - #14375 + - #15260 + - #18061 +-} + +cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind + -> UniqSM (CorePrepEnv, + Floats, -- Floating value bindings + Maybe CoreBind) -- Just bind' <=> returned new bind; no float + -- Nothing <=> added bind' to floats instead +cpeBind top_lvl env (NonRec bndr rhs) + | not (isJoinId bndr) + = do { (env1, bndr1) <- cpCloneBndr env bndr + ; let dmd = idDemandInfo bndr + lev = typeLevity (idType bndr) + ; (floats, rhs1) <- cpePair top_lvl NonRecursive + dmd lev env bndr1 rhs + -- See Note [Inlining in CorePrep] + ; let triv_rhs = exprIsTrivial rhs1 + env2 | triv_rhs = extendCorePrepEnvExpr env1 bndr rhs1 + | otherwise = env1 + floats1 | triv_rhs, isInternalName (idName bndr) + = floats + | otherwise + = snocFloat floats new_float + + (new_float, _bndr2) = mkNonRecFloat env lev bndr1 rhs1 + + ; return (env2, floats1, Nothing) } + + | otherwise -- A join point; see Note [Join points and floating] + = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point + do { (_, bndr1) <- cpCloneBndr env bndr + ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs + ; return (extendCorePrepEnv env bndr bndr2, + emptyFloats, + Just (NonRec bndr2 rhs1)) } + +cpeBind top_lvl env (Rec pairs) + | not (isJoinId (head bndrs)) + = do { (env, bndrs1) <- cpCloneBndrs env bndrs + ; let env' = enterRecGroupRHSs env bndrs1 + ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd Lifted env') + bndrs1 rhss + + ; let (zipManyFloats -> floats, rhss1) = unzip stuff + -- Glom all floats into the Rec, *except* FloatStrings; see + -- see Note [ANF-ising literal string arguments], Wrinkle (FS1) + is_lit (Float (NonRec _ rhs) CaseBound TopLvlFloatable) = exprIsTickedString rhs + is_lit _ = False + (string_floats, top) = partitionOL is_lit (fs_binds floats) + -- Strings will *always* be in `top_floats` (we made sure of + -- that in `snocOL`), so that's the only field we need to + -- partition. + floats' = floats { fs_binds = top } + all_pairs = foldrOL add_float (bndrs1 `zip` rhss1) (getFloats floats') + -- use env below, so that we reset cpe_rec_ids + ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1), + snocFloat (emptyFloats { fs_binds = string_floats }) + (Float (Rec all_pairs) LetBound TopLvlFloatable), + Nothing) } + + | otherwise -- See Note [Join points and floating] + = do { (env, bndrs1) <- cpCloneBndrs env bndrs + ; let env' = enterRecGroupRHSs env bndrs1 + ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss + + ; let bndrs2 = map fst pairs1 + -- use env below, so that we reset cpe_rec_ids + ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), + emptyFloats, + Just (Rec pairs1)) } + where + (bndrs, rhss) = unzip pairs + + -- Flatten all the floats, and the current + -- group into a single giant Rec + add_float (Float bind bound _) prs2 + | bound /= CaseBound + || all (not . isUnliftedType . idType) (bindersOf bind) + -- The latter check is hit in -O0 (i.e., flavours quick, devel2) + -- for dictionary args which haven't been floated out yet, #24102. + -- They are preferably CaseBound, but since they are lifted we may + -- just as well put them in the Rec, in contrast to lifted bindings. + = case bind of + NonRec x e -> (x,e) : prs2 + Rec prs1 -> prs1 ++ prs2 + add_float f _ = pprPanic "cpeBind" (ppr f) + + +--------------- +cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity + -> CorePrepEnv -> OutId -> CoreExpr + -> UniqSM (Floats, CpeRhs) +-- Used for all bindings +-- The binder is already cloned, hence an OutId +cpePair top_lvl is_rec dmd lev env0 bndr rhs + = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair + do { (floats1, rhs1) <- cpeRhsE env rhs + + -- See if we are allowed to float this stuff out of the RHS + ; let dec = want_float_from_rhs floats1 rhs1 + ; (floats2, rhs2) <- executeFloatDecision env dec floats1 rhs1 + + -- Make the arity match up + ; (floats3, rhs3) + <- if manifestArity rhs1 <= arity + then return (floats2, cpeEtaExpand arity rhs2) + else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ + -- Note [Silly extra arguments] + (do { v <- newVar env (idType bndr) + ; let (float, v') = mkNonRecFloat env Lifted v rhs2 + ; return ( snocFloat floats2 float + , cpeEtaExpand arity (Var v')) }) + + -- Wrap floating ticks + ; let (floats4, rhs4) = wrapTicks floats3 rhs3 + + ; return (floats4, rhs4) } + where + env = pushBinderContext bndr env0 + + arity = idArity bndr -- We must match this arity + + want_float_from_rhs floats rhs + | isTopLevel top_lvl = wantFloatTop floats + | otherwise = wantFloatLocal is_rec dmd lev floats rhs + +{- Note [Silly extra arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we had this + f{arity=1} = \x\y. e +We *must* match the arity on the Id, so we have to generate + f' = \x\y. e + f = \x. f' x + +It's a bizarre case: why is the arity on the Id wrong? Reason +(in the days of __inline_me__): + f{arity=0} = __inline_me__ (let v = expensive in \xy. e) +When InlineMe notes go away this won't happen any more. But +it seems good for CorePrep to be robust. +-} + +--------------- +cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr + -> UniqSM (JoinId, CpeRhs) +-- Used for all join bindings +-- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils +cpeJoinPair env bndr rhs + = assert (isJoinId bndr) $ + do { let join_arity = case idJoinPointHood bndr of + JoinPoint join_arity -> join_arity + _ -> panic "cpeJoinPair" + (bndrs, body) = collectNBinders join_arity rhs + + ; (env', bndrs') <- cpCloneBndrs env bndrs + + ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts + -- with a lambda + + ; let rhs' = mkCoreLams bndrs' body' + bndr' = bndr `setIdUnfolding` evaldUnfolding + `setIdArity` count isId bndrs + -- See Note [Arity and join points] + + ; return (bndr', rhs') } + +{- +Note [Arity and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Up to now, we've allowed a join point to have an arity greater than its join +arity (minus type arguments), since this is what's useful for eta expansion. +However, for code gen purposes, its arity must be exactly the number of value +arguments it will be called with, and it must have exactly that many value +lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS: + + join j x y z = \w -> ... in ... + => + join j x y z = (let f = \w -> ... in f) in ... + +This is also what happens with Note [Silly extra arguments]. Note that it's okay +for us to mess with the arity because a join point is never exported. +-} + +-- --------------------------------------------------------------------------- +-- CpeRhs: produces a result satisfying CpeRhs +-- --------------------------------------------------------------------------- + +cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +-- If +-- e ===> (bs, e') +-- then +-- e = let bs in e' (semantically, that is!) +-- +-- For example +-- f (g x) ===> ([v = g x], f v) + +cpeRhsE env (Type ty) + = return (emptyFloats, Type (cpSubstTy env ty)) +cpeRhsE env (Coercion co) + = return (emptyFloats, Coercion (cpSubstCo env co)) +cpeRhsE env expr@(Lit lit) + | LitNumber LitNumBigNat i <- lit + = cpeBigNatLit env i + | otherwise = return (emptyFloats, expr) +cpeRhsE env expr@(Var {}) = cpeApp env expr +cpeRhsE env expr@(App {}) = cpeApp env expr + +cpeRhsE env (Let bind body) + = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind + ; (body_floats, body') <- cpeRhsE env' body + ; let expr' = case maybe_bind' of Just bind' -> Let bind' body' + Nothing -> body' + ; return (bind_floats `appFloats` body_floats, expr') } + +cpeRhsE env (Tick tickish expr) + -- Pull out ticks if they are allowed to be floated. + | tickishFloatable tickish + = do { (floats, body) <- cpeRhsE env expr + -- See [Floating Ticks in CorePrep] + ; return (FloatTick tickish `consFloat` floats, body) } + | otherwise + = do { body <- cpeBodyNF env expr + ; return (emptyFloats, mkTick tickish' body) } + where + tickish' | Breakpoint ext bid fvs <- tickish + -- See also 'substTickish' + = Breakpoint ext bid (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) + | otherwise + = tickish + +cpeRhsE env (Cast expr co) + = do { (floats, expr') <- cpeRhsE env expr + ; return (floats, Cast expr' (cpSubstCo env co)) } + +cpeRhsE env expr@(Lam {}) + = do { let (bndrs,body) = collectBinders expr + ; (env', bndrs') <- cpCloneBndrs env bndrs + ; body' <- cpeBodyNF env' body + ; return (emptyFloats, mkLams bndrs' body') } + +cpeRhsE env (Case scrut bndr _ alts@[Alt con [covar] _]) + -- See (U3) in Note [Implementing unsafeCoerce] + -- We need make the Case float, otherwise we get + -- let x = case ... of UnsafeRefl co -> + -- let y = expr in + -- K y + -- in f x + -- instead of + -- case ... of UnsafeRefl co -> + -- let y = expr in + -- let x = K y + -- in f x + -- Note that `x` is a value here. This is visible in the GHCi debugger tests + -- (such as `print003`). + | Just rhs <- isUnsafeEqualityCase scrut bndr alts + = do { (floats_scrut, scrut) <- cpeBody env scrut + + ; (env, bndr') <- cpCloneBndr env bndr + ; (env, covar') <- cpCloneCoVarBndr env covar + -- Important: here we clone the CoVar + -- See Note [Cloning CoVars and TyVars] + + -- Up until here this should do exactly the same as the regular code + -- path of `cpeRhsE Case{}`. + ; (floats_rhs, rhs) <- cpeBody env rhs + -- ... but we want to float `floats_rhs` as in (U3) so that rhs' might + -- become a value + ; let case_float = UnsafeEqualityCase scrut bndr' con [covar'] + -- NB: It is OK to "evaluate" the proof eagerly. + -- Usually there's the danger that we float the unsafeCoerce out of + -- a branching Case alt. Not so here, because the regular code path + -- for `cpeRhsE Case{}` will not float out of alts. + floats = snocFloat floats_scrut case_float `appFloats` floats_rhs + ; return (floats, rhs) } + +cpeRhsE env (Case scrut bndr _ [Alt (DataAlt dc) [token_out, res] rhs]) + -- See item (SEQ4) of Note [seq# magic]. We want to match + -- case seq# @a @RealWorld s of (# s', _ #) -> rhs[s'] + -- and simplify to rhs[s]. Triggers in T15226. + | isUnboxedTupleDataCon dc + , (Var f,[_ty1, _ty2, arg, Var token_in]) <- collectArgs scrut + , f `hasKey` seqHashKey + , exprOkToDiscard arg + -- ok-to-discard, because we want to discard the evaluation of `arg`. + -- ok-to-discard includes ok-for-spec, but *also* CanFail primops such as + -- `quotInt# 1# 0#`, but not ThrowsException primops. + -- See Note [Classifying primop effects] + -- and Note [Transformations affected by primop effects] for why this is + -- the correct choice. + , Var token_in' <- lookupCorePrepEnv env token_in + , isDeadBinder res, isDeadBinder bndr + -- Check that bndr and res are dead + -- We can rely on `isDeadBinder res`, despite the fact that the Simplifier + -- often zaps the OccInfo on case-alternative binders (see Note [DataAlt occ info] + -- in GHC.Core.Opt.Simplify.Iteration) because the scrutinee is not a + -- variable, and in that case the zapping doesn't happen; see that Note. + = cpeRhsE (extendCorePrepEnv env token_out token_in') rhs + +cpeRhsE env (Case scrut bndr ty alts) + = do { (floats, scrut') <- cpeBody env scrut + ; (env', bndr2) <- cpCloneBndr env bndr + ; let bndr3 = bndr2 `setIdUnfolding` evaldUnfolding + ; let alts' + | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) + , not (altsAreExhaustive alts) + = addDefault alts (Just err) + | otherwise = alts + where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" + ; alts'' <- mapM (sat_alt env') alts' + + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let float = mkCaseFloat bndr3 scrut' + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr3 (cpSubstTy env ty) alts'') } + where + sat_alt env (Alt con bs rhs) + = do { (env2, bs') <- cpCloneBndrs env bs + ; rhs' <- cpeBodyNF env2 rhs + ; return (Alt con bs' rhs') } + +-- --------------------------------------------------------------------------- +-- CpeBody: produces a result satisfying CpeBody +-- --------------------------------------------------------------------------- + +-- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without +-- producing any floats (any generated floats are immediately +-- let-bound using 'wrapBinds'). Generally you want this, esp. +-- when you've reached a binding form (e.g., a lambda) and +-- floating any further would be incorrect. +cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody +cpeBodyNF env expr + = do { (floats, body) <- cpeBody env expr + ; return (wrapBinds floats body) } + +-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce +-- a list of 'Floats' which are being propagated upwards. In +-- fact, this function is used in only two cases: to +-- implement 'cpeBodyNF' (which is what you usually want), +-- and in the case when a let-binding is in a case scrutinee--here, +-- we can always float out: +-- +-- case (let x = y in z) of ... +-- ==> let x = y in case z of ... +-- +cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +cpeBody env expr + = do { (floats1, rhs) <- cpeRhsE env expr + ; (floats2, body) <- rhsToBody env rhs + ; return (floats1 `appFloats` floats2, body) } + +-------- +rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody) +-- Remove top level lambdas by let-binding + +rhsToBody env (Tick t expr) + | tickishScoped t == NoScope -- only float out of non-scoped annotations + = do { (floats, expr') <- rhsToBody env expr + ; return (floats, mkTick t expr') } + +rhsToBody env (Cast e co) + -- You can get things like + -- case e of { p -> coerce t (\s -> ...) } + = do { (floats, e') <- rhsToBody env e + ; return (floats, Cast e' co) } + +rhsToBody env expr@(Lam {}) -- See Note [No eta reduction needed in rhsToBody] + | all isTyVar bndrs -- Type lambdas are ok + = return (emptyFloats, expr) + | otherwise -- Some value lambdas + = do { let rhs = cpeEtaExpand (exprArity expr) expr + ; fn <- newVar env (exprType rhs) + ; let float = Float (NonRec fn rhs) LetBound TopLvlFloatable + ; return (unitFloat float, Var fn) } + where + (bndrs,_) = collectBinders expr + +rhsToBody _env expr = return (emptyFloats, expr) + + +{- Note [No eta reduction needed in rhsToBody] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Historical note. In the olden days we used to have a Prep-specific +eta-reduction step in rhsToBody: + rhsToBody expr@(Lam {}) + | Just no_lam_result <- tryEtaReducePrep bndrs body + = return (emptyFloats, no_lam_result) + +The goal was to reduce + case x of { p -> \xs. map f xs } + ==> case x of { p -> map f } + +to avoid allocating a lambda. Of course, we'd allocate a PAP +instead, which is hardly better, but that's the way it was. + +Now we simply don't bother with this. It doesn't seem to be a win, +and it's extra work. +-} + +-- --------------------------------------------------------------------------- +-- CpeApp: produces a result satisfying CpeApp +-- --------------------------------------------------------------------------- + +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish + +instance Outputable ArgInfo where + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick + +{- Note [Ticks and mandatory eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Something like + `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool` +caused a compiler panic in #20938. Why did this happen? +The simplifier will eta-reduce the rhs giving us a partial +application of tagToEnum#. The tick is then pushed inside the +type argument. That is we get + `(Tick tagToEnum#) @Bool` +CorePrep would go on to see a undersaturated tagToEnum# application +and eta expand the expression under the tick. Giving us: + (Tick (\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 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 (tagToEnum# @Bool x)`. +-} +cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +-- May return a CpeRhs (instead of CpeApp) because of saturating primops +cpeApp top_env expr + = do { let (terminal, args) = collect_args expr + -- ; pprTraceM "cpeApp" $ (ppr expr) + ; cpe_app top_env terminal args + } + + where + -- We have a nested data structure of the form + -- e `App` a1 `App` a2 ... `App` an, convert it into + -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth) + -- We use 'ArgInfo' because we may also need to + -- record casts and ticks. Depth counts the number + -- of arguments that would consume strictness information + -- (so, no type or coercion arguments.) + collect_args :: CoreExpr -> (CoreExpr, [ArgInfo]) + collect_args e = go e [] + where + go (App fun arg) as + = go fun (AIApp arg : as) + go (Cast fun co) as + = go fun (AICast co : as) + go (Tick tickish fun) as + -- Profiling ticks are slightly less strict so we expand their scope + -- if they cover partial applications of things like primOps. + -- See Note [Ticks and mandatory eta expansion] + -- Here we look inside `fun` before we make the final decision about + -- floating the tick which isn't optimal for perf. But this only makes + -- a difference if we have a non-floatable tick which is somewhat rare. + | Var vh <- head + , Var head' <- lookupCorePrepEnv top_env vh + , etaExpansionTick head' tickish + = (head,as') + where + (head,as') = go fun (AITick tickish : as) + + -- Terminal could still be an app if it's wrapped by a tick. + -- E.g. Tick (f x) can give us (f x) as terminal. + go terminal as = (terminal, as) + + cpe_app :: CorePrepEnv + -> CoreExpr -- The thing we are calling + -> [ArgInfo] + -> UniqSM (Floats, CpeRhs) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) + | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and + -- See Note [lazyId magic] in GHC.Types.Id.Make + || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey + -- Replace (noinline a) with a + -- See Note [noinlineId magic] in GHC.Types.Id.Make + || f `hasKey` nospecIdKey -- Replace (nospec a) with a + -- See Note [nospecId magic] in GHC.Types.Id.Make + + -- Consider the code: + -- + -- lazy (f x) y + -- + -- We need to make sure that we need to recursively collect arguments on + -- "f x", otherwise we'll float "f x" out (it's not a variable) and + -- end up with this awful -ddump-prep: + -- + -- case f x of f_x { + -- __DEFAULT -> f_x y + -- } + -- + -- rather than the far superior "f x y". Test case is par01. + = let (terminal, args') = collect_args arg + in cpe_app env terminal (args' ++ args) + + -- runRW# magic + cpe_app env (Var f) (AIApp _runtimeRep@Type{} : AIApp _type@Type{} : AIApp arg : rest) + | f `hasKey` runRWKey + -- N.B. While it may appear that n == 1 in the case of runRW# + -- applications, keep in mind that we may have applications that return + , has_value_arg (AIApp arg : rest) + -- See Note [runRW magic] + -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this + -- is why we return a CorePrepEnv as well) + = case arg of + Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) + -- TODO: What about casts? + where + has_value_arg [] = False + has_value_arg (AIApp arg:_rest) + | not (isTyCoArg arg) = True + has_value_arg (_:rest) = has_value_arg rest + + -- See Note [seq# magic]. This is the step for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty@Type{}, AIApp thing, AIApp token] + | f `hasKey` seqHashKey + -- seq# thing token + -- ==> case token of s { __DEFAULT -> + -- case thing of res { __DEFAULT -> (# token, res#) } }, + -- allocating CaseBound Floats for token and thing as needed + = do { (floats1, token) <- cpeArg env topDmd token + ; (floats2, thing) <- cpeBody env thing + ; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar env ty + ; let tup = mkCoreUnboxedTuple [token, Var case_bndr] + ; let float = mkCaseFloat case_bndr thing + ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) } + + cpe_app env (Var v) args + = do { v1 <- fiddleCCall v + ; let e2 = lookupCorePrepEnv env v1 + hd = getIdFromTrivialExpr_maybe e2 + -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion] + min_arity = case hd of + Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing + Nothing -> Nothing + -- ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v)) + ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity + ; mb_saturate hd app floats unsat_ticks depth } + where + depth = val_args args + stricts = case idDmdSig v of + DmdSig (DmdType _ demands) + | listLengthCmp demands depth /= GT -> demands + -- length demands <= depth + | otherwise -> [] + -- If depth < length demands, then we have too few args to + -- satisfy strictness info so we have to ignore all the + -- strictness info, e.g. + (error "urk") + -- Here, we can't evaluate the arg strictly, because this + -- partial application might be seq'd + + -- We inlined into something that's not a var and has no args. + -- Bounce it back up to cpeRhsE. + cpe_app env fun [] = cpeRhsE env fun + + -- Here we get: + -- N-variable fun, better let-bind it + -- This case covers literals, apps, lams or let expressions applied to arguments. + -- Basically things we want to ANF before applying to arguments. + cpe_app env fun args + = do { (fun_floats, fun') <- cpeArg env evalDmd fun + -- If evalDmd says that it's sure to be evaluated, + -- we'll end up case-binding it + ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing + ; mb_saturate Nothing app floats unsat_ticks (val_args args) } + + -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG) + val_args :: [ArgInfo] -> Int + val_args args = go args 0 + where + go [] !n = n + go (info:infos) n = + case info of + AICast {} -> go infos n + AITick tickish + | tickishFloatable tickish -> go infos n + -- If we can't guarantee a tick will be floated out of the application + -- we can't guarantee the value args following it will be applied. + | otherwise -> n + AIApp e -> go infos n' + where + !n' + | isTypeArg e = n + | otherwise = n+1 + + -- Saturate if necessary + mb_saturate head app floats unsat_ticks depth = + case head of + Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth unsat_ticks + ; return (floats, sat_app) } + _other -> do { massert (null unsat_ticks) + ; return (floats, app) } + + -- Deconstruct and rebuild the application, floating any non-atomic + -- arguments to the outside. We collect the type of the expression, + -- the head of the application, and the number of actual value arguments, + -- all of which are used to possibly saturate this application if it + -- has a constructor or primop at the head. + rebuild_app + :: CorePrepEnv + -> [ArgInfo] -- The arguments (inner to outer) + -> CpeApp -- The function + -> Floats -- INVARIANT: These floats don't bind anything that is in the CpeApp! + -- Just stuff floated out from the head of the application. + -> [Demand] + -> Maybe Arity + -> UniqSM (CpeApp + ,Floats + ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion] + ) + rebuild_app env args app floats ss req_depth = + rebuild_app' env args app floats ss [] (fromMaybe 0 req_depth) + + rebuild_app' + :: CorePrepEnv + -> [ArgInfo] -- The arguments (inner to outer); substitution not applied + -> CpeApp -- Substitution already applied + -> Floats + -> [Demand] + -> [CoreTickish] + -> Int -- Number of arguments required to satisfy minimal tick scopes. + -> UniqSM (CpeApp, Floats, [CoreTickish]) + rebuild_app' _ [] app floats ss rt_ticks !_req_depth + = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info + return (app, floats, rt_ticks) + + rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of + -- See Note [Ticks and mandatory eta expansion] + _ | not (null rt_ticks), req_depth <= 0 + -> let tick_fun = foldr mkTick fun' rt_ticks + in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth + + AIApp (Type arg_ty) + -> rebuild_app' env as (App fun' (Type arg_ty')) floats ss rt_ticks req_depth + where + arg_ty' = cpSubstTy env arg_ty + + AIApp (Coercion co) + -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth + where + co' = cpSubstCo env co + + AIApp arg -> do + let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make + = case (ss, isLazyExpr arg) of + (_ : ss_rest, True) -> (topDmd, ss_rest) + (ss1 : ss_rest, False) -> (ss1, ss_rest) + ([], _) -> (topDmd, []) + (fs, arg') <- cpeArg env ss1 arg + rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) + + AICast co + -> rebuild_app' env as (Cast fun' co') floats ss rt_ticks req_depth + where + co' = cpSubstCo env co + + -- See Note [Ticks and mandatory eta expansion] + AITick tickish + | tickishPlace tickish == PlaceRuntime + , req_depth > 0 + -> assert (isProfTick tickish) $ + rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth + | otherwise + -- See [Floating Ticks in CorePrep] + -> rebuild_app' env as fun' (snocFloat floats (FloatTick tickish)) ss rt_ticks req_depth + +isLazyExpr :: CoreExpr -> Bool +-- See Note [lazyId magic] in GHC.Types.Id.Make +isLazyExpr (Cast e _) = isLazyExpr e +isLazyExpr (Tick _ e) = isLazyExpr e +isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey +isLazyExpr _ = False + +{- Note [runRW magic] +~~~~~~~~~~~~~~~~~~~~~ +Some definitions, for instance @runST@, must have careful control over float out +of the bindings in their body. Consider this use of @runST@, + + f x = runST ( \ s -> let (a, s') = newArray# 100 [] s + (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' ) + +If we inline @runST@, we'll get: + + f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} + (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' + +And now if we allow the @newArray#@ binding to float out to become a CAF, +we end up with a result that is totally and utterly wrong: + + f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! + in \ x -> + let (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' + +All calls to @f@ will share a {\em single} array! Clearly this is nonsense and +must be prevented. + +This is what @runRW#@ gives us: by being inlined extremely late in the +optimization (right before lowering to STG, in CorePrep), we can ensure that +no further floating will occur. This allows us to safely inline things like +@runST@, which are otherwise needlessly expensive (see #10678 and #5916). + +'runRW' has a variety of quirks: + + * 'runRW' is known-key with a NOINLINE definition in + GHC.Magic. This definition is used in cases where runRW is curried. + + * In addition to its normal Haskell definition in GHC.Magic, we give it + a special late inlining here in CorePrep and GHC.StgToByteCode, avoiding + the incorrect sharing due to float-out noted above. + + * It is levity-polymorphic: + + runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) + => (State# RealWorld -> (# State# RealWorld, o #)) + -> (# State# RealWorld, o #) + + * It has some special simplification logic to allow unboxing of results when + runRW# appears in a strict context. See Note [Simplification of runRW#] + below. + + * Since its body is inlined, we allow runRW#'s argument to contain jumps to + join points. That is, the following is allowed: + + join j x = ... + in runRW# @_ @_ (\s -> ... jump j 42 ...) + + The Core Linter knows about this. See Note [Linting of runRW#] in + GHC.Core.Lint for details. + + The occurrence analyser and SetLevels also know about this, as described in + Note [Simplification of runRW#]. + +Other relevant Notes: + + * Note [Simplification of runRW#] below, describing a transformation of runRW + applications in strict contexts performed by the simplifier. + * Note [Linting of runRW#] in GHC.Core.Lint + * Note [runRW arg] below, describing a non-obvious case where the + late-inlining could go wrong. + +Note [runRW arg] +~~~~~~~~~~~~~~~~~~~ +Consider the Core program (from #11291), + + runRW# (case bot of {}) + +The late inlining logic in cpe_app would transform this into: + + (case bot of {}) realWorld# + +Which would rise to a panic in CoreToStg.myCollectArgs, which expects only +variables in function position. + +However, as runRW#'s strictness signature captures the fact that it will call +its argument this can't happen: the simplifier will transform the bottoming +application into simply (case bot of {}). + +Note that this reasoning does *not* apply to non-bottoming continuations like: + + hello :: Bool -> Int + hello n = + runRW# ( + case n of + True -> \s -> 23 + _ -> \s -> 10) + +Why? The difference is that (case bot of {}) is considered by okCpeArg to be +trivial, consequently cpeArg (which the catch-all case of cpe_app calls on both +the function and the arguments) will forgo binding it to a variable. By +contrast, in the non-bottoming case of `hello` above the function will be +deemed non-trivial and consequently will be case-bound. + +Note [Simplification of runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the program, + + case runRW# (\s -> I# 42#) of + I# n# -> f n# + +There is no reason why we should allocate an I# constructor given that we +immediately destructure it. + +To avoid this the simplifier has a special transformation rule, specific to +runRW#, that pushes a strict context into runRW#'s continuation. See the +`runRW#` guard in `GHC.Core.Opt.Simplify.rebuildCall`. That is, it transforms + + K[ runRW# @r @ty cont ] + ~> + runRW# @r @ty (\s -> K[cont s]) + +This has a few interesting implications. Consider, for instance, this program: + + join j = ... + in case runRW# @r @ty cont of + result -> jump j result + +Performing the transform described above would result in: + + join j x = ... + in runRW# @r @ty (\s -> + case cont of in + result -> jump j result + ) + +If runRW# were a "normal" function this call to join point j would not be +allowed in its continuation argument. However, since runRW# is inlined (as +described in Note [runRW magic] above), such join point occurrences are +completely fine. Both occurrence analysis (see the runRW guard in occAnalApp) +and Core Lint (see the App case of lintCoreExpr) have special treatment for +runRW# applications. See Note [Linting of runRW#] for details on the latter. + +Moreover, it's helpful to ensure that runRW's continuation isn't floated out +For instance, if we have + + runRW# (\s -> do_something) + +where do_something contains only top-level free variables, we may be tempted to +float the argument to the top-level. However, we must resist this urge as since +doing so would then require that runRW# produce an allocation and call, e.g.: + + let lvl = \s -> do_somethign + in + ....(runRW# lvl).... + +whereas without floating the inlining of the definition of runRW would result +in straight-line code. Consequently, GHC.Core.Opt.SetLevels.lvlApp has special +treatment for runRW# applications, ensure the arguments are not floated as +MFEs. + +Now that we float evaluation context into runRW#, we also have to give runRW# a +special higher-order CPR transformer lest we risk #19822. E.g., + + case runRW# (\s -> doThings) of x -> Data.Text.Text x something something' + ~> + runRW# (\s -> case doThings s of x -> Data.Text.Text x something something') + +The former had the CPR property, and so should the latter. + +Other considered designs +------------------------ +One design that was rejected was to *require* that runRW#'s continuation be +headed by a lambda. However, this proved to be quite fragile. For instance, +SetLevels is very eager to float bottoming expressions. For instance given +something of the form, + + runRW# @r @ty (\s -> case expr of x -> undefined) + +SetLevels will see that the body the lambda is bottoming and will consequently +float it to the top-level (assuming expr has no free coercion variables which +prevent this). We therefore end up with + + runRW# @r @ty (\s -> lvl s) + +Which the simplifier will beta reduce, leaving us with + + runRW# @r @ty lvl + +Breaking our desired invariant. Ultimately we decided to simply accept that +the continuation may not be a manifest lambda. + + +-- --------------------------------------------------------------------------- +-- CpeArg: produces a result satisfying CpeArg +-- --------------------------------------------------------------------------- + +Note [ANF-ising literal string arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a Core program like, + + data Foo = Foo Addr# + foo = Foo "turtle"# + +String literals are non-trivial, see 'GHC.Types.Literal.litIsTrivial', hence +they are non-atomic in STG. +With -O1, FloatOut is likely to have floated most of these strings to top-level, +not least to give CSE a chance to deduplicate strings early (before the +linker, that is). +(Notable exceptions seem to be applications of 'unpackAppendCString#'.) +But with -O0, there is no FloatOut, so CorePrep must do the ANFisation to + + s = "turtle"# + foo = Foo s + +(String literals are the only kind of binding allowed at top-level and hence +their `FloatInfo` is `TopLvlFloatable`.) + +This appears to lead to bad code if the arg is under a lambda, because CorePrep +doesn't float out of RHSs, e.g., (T23270) + + foo x = ... patError "turtle"# ... +==> foo x = ... case "turtle"# of s { __DEFAULT -> petError s } ... + +This looks bad because it evals an HNF on every call. +But actually, it doesn't, because "turtle"# is already an HNF. Here is the Cmm: + + [section ""cstring" . cB4_str" { + cB4_str: + I8[] "turtle" + } + ... + _sAG::I64 = cB4_str; + R2 = _sAG::I64; + Sp = Sp + 8; + call Control.Exception.Base.patError_info(R2) args: 8, res: 0, upd: 8; + +Wrinkles: + +(FS1) We detect string literals in `cpeBind Rec{}` and float them out anyway; + otherwise we'd try to bind a string literal in a letrec, violating + Note [Core letrec invariant]. Since we know that literals don't have + free variables, we float further. + Arguably, we could just as well relax the letrec invariant for + string literals, or anthing that is a value (lifted or not). + This is tracked in #24036. +-} + +-- This is where we arrange that a non-trivial argument is let-bound +cpeArg :: CorePrepEnv -> Demand + -> CoreArg -> UniqSM (Floats, CpeArg) +cpeArg env dmd arg + = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda + ; let arg_ty = exprType arg1 + lev = typeLevity arg_ty + dec = wantFloatLocal NonRecursive dmd lev floats1 arg1 + ; (floats2, arg2) <- executeFloatDecision env dec floats1 arg1 + -- Else case: arg1 might have lambdas, and we can't + -- put them inside a wrapBinds + + -- Now ANF-ise any non-trivial argument + -- NB: "non-trivial" includes string literals; + -- see Note [ANF-ising literal string arguments] + ; if exprIsTrivial arg2 + then return (floats2, arg2) + else do { v <- (`setIdDemandInfo` dmd) <$> newVar env arg_ty + -- See Note [Pin demand info on floats] + ; let arity = cpeArgArity env dec floats1 arg2 + arg3 = cpeEtaExpand arity arg2 + -- See Note [Eta expansion of arguments in CorePrep] + ; let (arg_float, v') = mkNonRecFloat env lev v arg3 + ---; pprTraceM "cpeArg" (ppr arg1 $$ ppr dec $$ ppr arg2) + ; return (snocFloat floats2 arg_float, varToCoreExpr v') } + } + +cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CoreArg -> Arity +-- ^ See Note [Eta expansion of arguments in CorePrep] +-- Returning 0 means "no eta-expansion"; see cpeEtaExpand +cpeArgArity env float_decision floats1 arg + | FloatNone <- float_decision + -- If we did not float + , not (isEmptyFloats floats1) + -- ... but there was something to float + , fs_info floats1 `floatsAtLeastAsFarAs` LazyContextFloatable + -- ... and we could have floated it out of a lazy arg + = 0 -- ... then short-cut, because floats1 is likely expensive! + -- See wrinkle (EA2) in Note [Eta expansion of arguments in CorePrep] + + | Just ao <- cp_arityOpts (cpe_config env) -- Just <=> -O1 or -O2 + , not (eta_would_wreck_join arg) + -- See Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep] + = case exprEtaExpandArity ao arg of + Nothing -> 0 + Just at -> arityTypeArity at + + | otherwise + = exprArity arg -- this is cheap enough for -O0 + +eta_would_wreck_join :: CoreExpr -> Bool +-- ^ Identify the cases where we'd generate invalid `CpeApp`s as described in +-- Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep] +eta_would_wreck_join (Let bs e) = isJoinBind bs || eta_would_wreck_join e +eta_would_wreck_join (Lam _ e) = eta_would_wreck_join e +eta_would_wreck_join (Cast e _) = eta_would_wreck_join e +eta_would_wreck_join (Tick _ e) = eta_would_wreck_join e +eta_would_wreck_join (Case _ _ _ alts) = any eta_would_wreck_join (rhssOfAlts alts) +eta_would_wreck_join _ = False + +maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs +maybeSaturate fn expr n_args unsat_ticks + | hasNoBinding fn -- There's no binding + -- See Note [Eta expansion of hasNoBinding things in CorePrep] + = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr + + | mark_arity > 0 -- A call-by-value function. See Note [CBV Function Ids] + , not applied_marks + = assertPpr + ( not (isJoinId fn)) -- See Note [Do not eta-expand join points] + ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$ + text "marks:" <+> ppr (idCbvMarks_maybe fn) $$ + text "join_arity" <+> ppr (idJoinPointHood fn) $$ + text "fn_arity" <+> ppr fn_arity + ) $ + -- pprTrace "maybeSat" + -- ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$ + -- text "marks:" <+> ppr (idCbvMarks_maybe fn) $$ + -- text "join_arity" <+> ppr (isJoinId_maybe fn) $$ + -- text "fn_arity" <+> ppr fn_arity $$ + -- text "excess_arity" <+> ppr excess_arity $$ + -- text "mark_arity" <+> ppr mark_arity + -- ) $ + return sat_expr + + | otherwise + = assert (null unsat_ticks) $ + return expr + where + mark_arity = idCbvMarkArity fn + fn_arity = idArity fn + excess_arity = (max fn_arity mark_arity) - n_args + sat_expr = cpeEtaExpand excess_arity expr + applied_marks = n_args >= (length . dropWhile (not . isMarkedCbv) . + reverse . expectJust $ (idCbvMarks_maybe fn)) + -- For join points we never eta-expand (See Note [Do not eta-expand join points]) + -- so we assert all arguments that need to be passed cbv are visible so that the + -- backend can evalaute them if required.. + +{- Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~ +Eta expand to match the arity claimed by the binder Remember, +CorePrep must not change arity + +Eta expansion might not have happened already, because it is done by +the simplifier only when there at least one lambda already. + +NB1:we could refrain when the RHS is trivial (which can happen + for exported things). This would reduce the amount of code + generated (a little) and make things a little worse for + code compiled without -O. The case in point is data constructor + wrappers. + +NB2: we have to be careful that the result of etaExpand doesn't + invalidate any of the assumptions that CorePrep is attempting + to establish. One possible cause is eta expanding inside of + an SCC note - we're now careful in etaExpand to make sure the + SCC is pushed inside any new lambdas that are generated. + +Note [Eta expansion of hasNoBinding things in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +maybeSaturate deals with eta expanding to saturate things that can't deal +with unsaturated applications (identified by 'hasNoBinding', currently +foreign calls, unboxed tuple/sum constructors, and representation-polymorphic +primitives such as 'coerce' and 'unsafeCoerce#'). + +Historical Note: Note that eta expansion in CorePrep used to be very fragile +due to the "prediction" of CAFfyness that we used to make during tidying. We +previously saturated primop applications here as well but due to this +fragility (see #16846) we now deal with this another way, as described in +Note [Primop wrappers] in GHC.Builtin.PrimOps. + +Note [Eta expansion and the CorePrep invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It turns out to be much much easier to do eta expansion +*after* the main CorePrep stuff. But that places constraints +on the eta expander: given a CpeRhs, it must return a CpeRhs. + +For example here is what we do not want: + f = /\a -> g (h 3) -- h has arity 2 +After ANFing we get + f = /\a -> let s = h 3 in g s +and now we do NOT want eta expansion to give + f = /\a -> \ y -> (let s = h 3 in g s) y + +Instead GHC.Core.Opt.Arity.etaExpand gives + f = /\a -> \y -> let s = h 3 in g s y + +Note [Eta expansion of arguments in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose `g = \x y. blah` and consider the expression `f (g x)`; we ANFise to + + let t = g x + in f t + +We really don't want that `t` to be a thunk! That just wastes runtime, updating +a thunk with a PAP etc. The code generator could in principle allocate a PAP, +but in fact it does not know how to do that -- it's easier just to eta-expand: + + let t = \y. g x y + in f t + +To what arity should we eta-expand the argument? `cpeArg` uses two strategies, +governed by the presence of `-fdo-clever-arg-eta-expansion` (implied by -O): + + 1. Cheap, with -O0: just use `exprArity`. + 2. More clever but expensive, with -O1 -O2: use `exprEtaExpandArity`, + same function the Simplifier uses to eta expand RHSs and lambda bodies. + +The only reason for using (1) rather than (2) is to keep compile times down. +Using (2) in -O0 bumped up compiler allocations by 2-3% in tests T4801 and +T5321*. However, Plan (2) catches cases that (1) misses. +For example (#23083, assuming -fno-pedantic-bottoms): + + let t = case z of __DEFAULT -> g x + in f t + +to + + let t = \y -> case z of __DEFAULT -> g x y + in f t + +Note that there is a missed opportunity in eta expanding `t` earlier, in the +Simplifier: It would allow us to inline `g`, potentially enabling further +simplification. But then we could have inlined `g` into the PAP to begin with, +and that is discussed in #23150; hence we needn't worry about that in CorePrep. + +There is a nasty Wrinkle: + +(EA1) When eta expanding an argument headed by a join point, we might get + "crap", as Note [Eta expansion for join points] in GHC.Core.Opt.Arity puts + it. This crap means the output does not conform to the syntax in + Note [CorePrep invariants], which then makes later passes crash (#25033). + Consider + + f (join j x = rhs in ...(j 1)...(j 2)...) + + where the argument has arity 1. We might be tempted to eta expand, to + + f (\y -> (join j x = rhs in ...(j 1)...(j 2)...) y) + + Why hasn't the App to `y` been pushed into the join point? That's exactly + the crap of Note [Eta expansion for join points], so we have to put up + with it here. + In our case, (join j x = rhs in ...(j 1)...(j 2)...) is not a valid + `CpeApp` (see Note [CorePrep invariants]) and we'd get a crash in the App + case of `coreToStgExpr`. + + Hence, in `eta_would_wreck_join`, we check for the cases where an + intervening join point binding in the tail context of the argument would + make eta-expansion break Note [CorePrep invariants], in which + case we abstain from eta expansion. + + This scenario occurs rarely; hence it's OK to generate sub-optimal code. + The alternative would be to fix Note [Eta expansion for join points], but + that's quite challenging due to unfoldings of (recursive) join points. + + `eta_would_wreck_join` sees if there are any join points, like `j` above + that would be messed up. It must look inside lambdas (#25033); consider + f (\x. join j y = ... in ...(j 1)...(j 3)...) + We can't eta expand that `\x` any more than we could if the join was at + the top. (And when there's a lambda, we don't have a thunk anyway.) + +(EA2) In cpeArgArity, if float_decision=FloatNone the `arg` will look like + let in rhs + where is non-empty and can't be floated out of a lazy context (see + `wantFloatLocal`). So we can't eta-expand it anyway, so we can return 0 + forthwith. Without this short-cut we will call exprEtaExpandArity on the + `arg`, and might be enormous. exprEtaExpandArity be very expensive + on this: it uses arityType, and may look at . + + On the other hand, if float_decision = FloatAll, there will be no + let-bindings around 'arg'; they will have floated out. So + exprEtaExpandArity is cheap. + + This can make a huge difference on deeply nested expressions like + f (f (f (f (f ...)))) + #24471 is a good example, where Prep took 25% of compile time! +-} + +cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs +cpeEtaExpand arity expr + | arity == 0 = expr + | otherwise = etaExpand arity expr + +{- +************************************************************************ +* * + Floats +* * +************************************************************************ + +Note [Pin demand info on floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin demand info on floated lets, so that we can see one-shot thunks. +For example, + f (g x) +where `f` uses its argument at most once, creates a Float for `y = g x` and we +should better pin appropriate demand info on `y`. + +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have the following call, where f is strict: + f (case x of DEFAULT -> blah) +(For the moment, ignore the fact that the Simplifier will have floated that +`case` out because `f` is strict.) +In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind` + + Float (a = case x of y { DEFAULT -> blah }) CaseBound top-lvl + +with the call `f a`. When we wrap that `Float` we will get + + case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a } + +which is a bit silly. Actually the rest of the back end can cope with nested +cases like this, but it is harder to read and we'd prefer the more direct: + + case x of y { DEFAULT -> + case blah of a { DEFAULT -> f a }} + +This is easy to avoid: turn that + + case x of DEFAULT -> blah + +into a FloatingBind of its own. This is easily done in the Case +equation for `cpsRhsE`. Then our example will generate /two/ floats: + + Float (y = x) CaseBound str-ctx + Float (a = blah) CaseBound top-lvl + +and we'll end up with nested cases. + +Of course, the Simplifier never leaves us with an argument like this, but we +/can/ see + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + +and the above footwork in cpsRhsE avoids generating a nested case. + + +Note [Pin evaluatedness on floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When creating a new float `sat=e` in `mkNonRecFloat`, we propagate `sat` with an +`evaldUnfolding` if `e` is a value. + +To see why, consider a call to a CBV function, such as a DataCon worker with +*strict* fields, in an argument context, such as + + data Box a = Box !a + ... f (Box e) ... + +where `f` is *lazy* and `e` is ok-for-spec, e.g. `e = I# (x +# 1#)`. +After ANFisation, we want to get the very nice code + + case x +# 1# of x' -> + let sat = I# x' in + let sat2 = Box sat in + f sat2 + +Note that Case (2) of Note [wantFloatLocal] is in effect. That is, + + * x' is unlifted but ok-for-spec, hence floated out of the lazy arg of f + * Since x' is unlifted, `I# x'` is a value, and so `sat` can be let-bound. + * Since `sat` is a value, `Box sat` is a value as well, and so `sat2` can + be let-bound. + +Hence no thunk needs to be allocated! However, in order to recognise +`Box sat` as a value, it is crucial that the newly created `sat` has an +`evaldUnfolding`; otherwise the strict worker `Box` forces an eval on `sat`. +and we would get the far worse code + + let sat2 = + case x +# 1# of x' -> + case I# x' of sat' -> + Box sat in + f sat2 + +A live example of this is T24730, inspired by $walexGetByte. + +Note [Speculative evaluation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since call-by-value is much cheaper than call-by-need, we case-bind arguments +that are either + + 1. Strictly evaluated anyway, according to the DmdSig of the callee, or + 2. ok-for-spec, according to 'exprOkForSpeculation'. + This includes DFuns `$fEqList a`, for example. + (Could identify more in the future; see reference to !1866 below.) + +While (1) is a no-brainer and always beneficial, (2) is a bit +more subtle, as the careful haddock for 'exprOkForSpeculation' +points out. Still, by case-binding the argument we don't need +to allocate a thunk for it, whose closure must be retained as +long as the callee might evaluate it. And if it is evaluated on +most code paths anyway, we get to turn the unknown eval in the +callee into a known call at the call site. + +Very Nasty Wrinkle + +We must be very careful not to speculate recursive calls! Doing so +might well change termination behavior. + +That comes up in practice for DFuns, which are considered ok-for-spec, +because they always immediately return a constructor. +See Note [NON-BOTTOM-DICTS invariant] in GHC.Core. + +But not so if you speculate the recursive call, as #20836 shows: + + class Foo m => Foo m where + runFoo :: m a -> m a + newtype Trans m a = Trans { runTrans :: m a } + instance Monad m => Foo (Trans m) where + runFoo = id + +(NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The +example in #20836 is more compelling, but boils down to the same thing.) +This program compiles to the following DFun for the `Trans` instance: + + Rec { + $fFooTrans + = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id) + end Rec } + +Note that the DFun immediately terminates and produces a dictionary, just +like DFuns ought to, but it calls itself recursively to produce the `Foo m` +dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so +that we can speculate its calls, and hence use call-by-value, we get: + + $fFooTrans + = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc -> + C:Foo sc (\ @a -> id) + +and that's an infinite loop! +Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the +*body* of the letrec, it's absolutely fine to use call-by-value on +`foo ($fFooTrans d)`. + +Our solution is this: we track in cpe_rec_ids the set of enclosing +recursively-bound Ids, the RHSs of which we are currently transforming and then +in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation', +basically) we'll say that any binder in this set is not ok-for-spec. + +Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we +prep up `rhs1`, we have to include not only `f1`, but all binders of the group +`f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive +DFuns. + +NB: If at some point we decide to have a termination analysis for general +functions (#8655, !1866), we need to take similar precautions for (guarded) +recursive functions: + + repeat x = x : repeat x + +Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x` +is a cheap call that we are willing to speculate, but *not* in repeat's RHS. +Fortunately, pce_rec_ids already has all the information we need in that case. + +The problem is very similar to Note [Eta reduction in recursive RHSs]. +Here as well as there it is *unsound* to change the termination properties +of the very function whose termination properties we are exploiting. + +It is also similar to Note [Do not strictify a DFun's parameter dictionaries], +where marking recursive DFuns (of undecidable *instances*) strict in dictionary +*parameters* leads to quite the same change in termination as above. + +Note [BindInfo and FloatInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The `BindInfo` of a `Float` describes whether it will be case-bound or +let-bound: + + * `LetBound`: A let binding `let x = rhs in ...`, can be Rec or NonRec. + * `CaseBound`: A case binding `case rhs of x -> { __DEFAULT -> .. }`. + (So always NonRec.) + Some case-bound things (string literals, lifted bindings) + can float to top-level (but not all), hence it is similar + to, but not the same as `StrictContextFloatable :: FloatInfo` + described below. + +This info is used in `wrapBinds` to pick the corresponding binding form. + +We want to case-bind iff the binding is (non-recursive, and) either + + * ok-for-spec-eval (and perhaps lifted, see Note [Speculative evaluation]), or + * unlifted, or + * strictly used + +The `FloatInfo` of a `Float` describes how far it can float without +(a) violating Core invariants and (b) changing semantics. + + * Any binding is at least `StrictContextFloatable`, meaning we may float it + out of a strict context such as `f <>` where `f` is strict. + We may never float out of a Case alternative `case e of p -> <>`, though, + even if we made sure that `p` does not capture any variables of the float, + because that risks sequencing guarantees of Note [seq# magic]. + + * A binding is `LazyContextFloatable` if we may float it out of a lazy context + such as `let x = <> in Just x`. + Counterexample: A strict or unlifted binding that isn't ok-for-spec-eval + such as `case divInt# x y of r -> { __DEFAULT -> I# r }`. + Here, we may not foat out the strict `r = divInt# x y`. + + * A binding is `TopLvlFloatable` if it is `LazyContextFloatable` and also can + be bound at the top level. + Counterexample: A strict or unlifted binding (ok-for-spec-eval or not) + such as `case x +# y of r -> { __DEFAULT -> I# r }`. + +This meaning of "at least" is encoded in `floatsAtLeastAsFarAs`. +Note that today, `LetBound` implies `TopLvlFloatable`, so we could make do with +the the following enum (check `mkNonRecFloat` for whether this is up to date): + + LetBoundTopLvlFloatable (lifted or boxed values) + CaseBoundTopLvlFloatable (strings, ok-for-spec-eval and lifted) + CaseBoundLazyContextFloatable (ok-for-spec-eval and unlifted) + CaseBoundStrictContextFloatable (not ok-for-spec-eval and unlifted) + +Although there is redundancy in the current encoding, SG thinks it is cleaner +conceptually. + +See also Note [Floats and FloatDecision] for how we maintain whole groups of +floats and how far they go. + +Note [Controlling Speculative Evaluation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Most of the time, speculative evaluation in the coreprep phase has a positive +effect on performance, however we have found that some forms of speculative +evaluation can lead to large performance regressions. See #25284. + +Therefore we have some flags to control which types of speculative evaluation +are done: + + -fspec-eval + Globally enable/disable speculative evaluation ( -fno-spec-eval also turns + off all other speculative evaluation). On by default for all + optimization levels. Turning on this flag by itself should never cause + a performance regression. Please open a ticket if you find any. + + -fspec-eval-dictfun + Enable speculative evaluation for dictionary functions. Off by default + since it can cause an increase in allocations (#24284). We have no + examples that show a large performance improvement when turning on this + flag. Please open a ticket if you find any. + +Also see the optimization section in the User's Guide for the description of +these flags and when to use them. + +Note [Floats and FloatDecision] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have a special datatype `Floats` for modelling a telescope of `FloatingBind` +and caching its "maximum" `FloatInfo`, according to `floatsAtLeastAsFarAs` +(see Note [BindInfo and FloatInfo] for the ordering). +There are several operations for creating and combining `Floats` that maintain +scoping and the cached `FloatInfo`. + +When deciding whether we want to float out a `Floats` out of a binding context +such as `let x = <> in e` (let), `f <>` (app), or `x = <>; ...` (top-level), +we consult the cached `FloatInfo` of the `Floats`: + + * If we want to float to the top-level (`x = <>; ...`), we check whether + we may float-at-least-as-far-as `TopLvlFloatable`, in which case we + respond with `FloatAll :: FloatDecision`; otherwise we say `FloatNone`. + * If we want to float locally (let or app), then the floating decision is + described in Note [wantFloatLocal]. + +`executeFloatDecision` is then used to act on the particular `FloatDecision`. +-} + +-- See Note [BindInfo and FloatInfo] +data BindInfo + = CaseBound -- ^ A strict binding + | LetBound -- ^ A lazy or value binding + deriving Eq + +-- See Note [BindInfo and FloatInfo] +data FloatInfo + = TopLvlFloatable + -- ^ Anything that can be bound at top-level, such as arbitrary lifted + -- bindings or anything that responds True to `exprIsHNF`, such as literals or + -- saturated DataCon apps where unlifted or strict args are values. + + | LazyContextFloatable + -- ^ Anything that can be floated out of a lazy context. + -- In addition to any 'TopLvlFloatable' things, this includes (unlifted) + -- bindings that are ok-for-spec that we intend to case-bind. + + | StrictContextFloatable + -- ^ Anything that can be floated out of a strict evaluation context. + -- That is possible for all bindings; this is the Top element of 'FloatInfo'. + + deriving Eq + +instance Outputable BindInfo where + ppr CaseBound = text "Case" + ppr LetBound = text "Let" + +instance Outputable FloatInfo where + ppr TopLvlFloatable = text "top-lvl" + ppr LazyContextFloatable = text "lzy-ctx" + ppr StrictContextFloatable = text "str-ctx" + +-- See Note [Floating in CorePrep] +-- and Note [BindInfo and FloatInfo] +data FloatingBind + = Float !CoreBind !BindInfo !FloatInfo -- Never a join-point binding + | UnsafeEqualityCase !CoreExpr !CoreBndr !AltCon ![CoreBndr] + | FloatTick CoreTickish + +-- See Note [Floats and FloatDecision] +data Floats + = Floats + { fs_info :: !FloatInfo + , fs_binds :: !(OrdList FloatingBind) + } + +instance Outputable FloatingBind where + ppr (Float b bi fi) = ppr bi <+> ppr fi <+> ppr b + ppr (FloatTick t) = ppr t + ppr (UnsafeEqualityCase scrut b k bs) = text "case" <+> ppr scrut + <+> text "of"<+> ppr b <> text "@" + <> case bs of + [] -> ppr k + _ -> parens (ppr k <+> ppr bs) + +instance Outputable Floats where + ppr (Floats info binds) = text "Floats" <> brackets (ppr info) <> braces (ppr binds) + +lubFloatInfo :: FloatInfo -> FloatInfo -> FloatInfo +lubFloatInfo StrictContextFloatable _ = StrictContextFloatable +lubFloatInfo _ StrictContextFloatable = StrictContextFloatable +lubFloatInfo LazyContextFloatable _ = LazyContextFloatable +lubFloatInfo _ LazyContextFloatable = LazyContextFloatable +lubFloatInfo TopLvlFloatable TopLvlFloatable = TopLvlFloatable + +floatsAtLeastAsFarAs :: FloatInfo -> FloatInfo -> Bool +-- See Note [Floats and FloatDecision] +floatsAtLeastAsFarAs l r = l `lubFloatInfo` r == r + +emptyFloats :: Floats +emptyFloats = Floats TopLvlFloatable nilOL + +isEmptyFloats :: Floats -> Bool +isEmptyFloats (Floats _ b) = isNilOL b + +getFloats :: Floats -> OrdList FloatingBind +getFloats = fs_binds + +unitFloat :: FloatingBind -> Floats +unitFloat = snocFloat emptyFloats + +floatInfo :: FloatingBind -> FloatInfo +floatInfo (Float _ _ info) = info +floatInfo UnsafeEqualityCase{} = LazyContextFloatable -- See Note [Floating in CorePrep] +floatInfo FloatTick{} = TopLvlFloatable -- We filter these out in cpePair, + -- see Note [Floating Ticks in CorePrep] + +-- | Append a `FloatingBind` `b` to a `Floats` telescope `bs` that may reference any +-- binding of the 'Floats'. +snocFloat :: Floats -> FloatingBind -> Floats +snocFloat floats fb = + Floats { fs_info = lubFloatInfo (fs_info floats) (floatInfo fb) + , fs_binds = fs_binds floats `snocOL` fb } + +-- | Cons a `FloatingBind` `b` to a `Floats` telescope `bs` which scopes over +-- `b`. +consFloat :: FloatingBind -> Floats -> Floats +consFloat fb floats = + Floats { fs_info = lubFloatInfo (fs_info floats) (floatInfo fb) + , fs_binds = fb `consOL` fs_binds floats } + +-- | Append two telescopes, nesting the right inside the left. +appFloats :: Floats -> Floats -> Floats +appFloats outer inner = + Floats { fs_info = lubFloatInfo (fs_info outer) (fs_info inner) + , fs_binds = fs_binds outer `appOL` fs_binds inner } + +-- | Zip up two `Floats`, none of which scope over the other +zipFloats :: Floats -> Floats -> Floats +-- We may certainly just nest one telescope in the other, so appFloats is a +-- valid implementation strategy. +zipFloats = appFloats + +-- | `zipFloats` a bunch of independent telescopes. +zipManyFloats :: [Floats] -> Floats +zipManyFloats = foldr zipFloats emptyFloats + +data FloatInfoArgs + = FIA + { fia_levity :: Levity + , fia_demand :: Demand + , fia_is_hnf :: Bool + , fia_is_triv :: Bool + , fia_is_string :: Bool + , fia_is_dc_worker :: Bool + , fia_ok_for_spec :: Bool + } + +defFloatInfoArgs :: Id -> CoreExpr -> FloatInfoArgs +defFloatInfoArgs bndr rhs + = FIA + { fia_levity = typeLevity (idType bndr) + , fia_demand = idDemandInfo bndr -- mkCaseFloat uses evalDmd + , fia_is_hnf = exprIsHNF rhs + , fia_is_triv = exprIsTrivial rhs + , fia_is_string = exprIsTickedString rhs + , fia_is_dc_worker = isJust (isDataConId_maybe bndr) -- mkCaseFloat uses False + , fia_ok_for_spec = False -- mkNonRecFloat uses exprOkForSpecEval + } + +decideFloatInfo :: FloatInfoArgs -> (BindInfo, FloatInfo) +decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf, + fia_is_triv=is_triv, fia_is_string=is_string, + fia_is_dc_worker=is_dc_worker, fia_ok_for_spec=ok_for_spec} + | Lifted <- lev, is_hnf, not is_triv = (LetBound, TopLvlFloatable) + -- is_lifted: We currently don't allow unlifted values at the + -- top-level or inside letrecs + -- (but SG thinks that in principle, we should) + -- is_triv: Should not turn `case x of x' ->` into `let x' = x` + -- when x is a HNF (cf. fun3 of T24264) + | is_dc_worker = (LetBound, TopLvlFloatable) + -- We need this special case for nullary unlifted DataCon + -- workers/wrappers (top-level bindings) until #17521 is fixed + | is_string = (CaseBound, TopLvlFloatable) + -- String literals are unboxed (so must be case-bound) and float to + -- the top-level + | ok_for_spec = (CaseBound, case lev of Unlifted -> LazyContextFloatable + Lifted -> TopLvlFloatable) + -- See Note [Speculative evaluation] + -- Ok-for-spec-eval things will be case-bound, lifted or not. + -- But when it's lifted we are ok with floating it to top-level + -- (where it is actually bound lazily). + | Unlifted <- lev = (CaseBound, StrictContextFloatable) + | isStrUsedDmd dmd = (CaseBound, StrictContextFloatable) + -- These will never be floated out of a lazy RHS context + | Lifted <- lev = (LetBound, TopLvlFloatable) + -- And these float freely but can't be speculated, hence LetBound + +mkCaseFloat :: Id -> CpeRhs -> FloatingBind +mkCaseFloat bndr scrut + = -- pprTrace "mkCaseFloat" (ppr bndr <+> ppr (bound,info) + -- -- <+> ppr is_lifted <+> ppr is_strict + -- -- <+> ppr ok_for_spec <+> ppr evald + -- $$ ppr scrut) $ + Float (NonRec bndr scrut) bound info + where + !(bound, info) = decideFloatInfo $ (defFloatInfoArgs bndr scrut) + { fia_demand = evalDmd + -- Strict demand, so that we do not let-bind unless it's a value + , fia_is_dc_worker = False + -- DataCon worker *bindings* are never case-bound + , fia_ok_for_spec = False + -- We do not currently float around case bindings. + -- (ok-for-spec case bindings are unlikely anyway.) + } + +mkNonRecFloat :: CorePrepEnv -> Levity -> Id -> CpeRhs -> (FloatingBind, Id) +mkNonRecFloat env lev bndr rhs + = -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info) + -- <+> if is_strict then text "strict" else if is_lifted then text "lazy" else text "unlifted" + -- <+> if ok_for_spec then text "ok-for-spec" else empty + -- <+> if evald then text "evald" else empty + -- $$ ppr rhs) $ + (Float (NonRec bndr' rhs) bound info, bndr') + where + !(bound, info) = decideFloatInfo $ (defFloatInfoArgs bndr rhs) + { fia_levity = lev + , fia_is_hnf = is_hnf + , fia_ok_for_spec = ok_for_spec + } + + is_hnf = exprIsHNF rhs + cfg = cpe_config env + + ok_for_spec = exprOkForSpecEval call_ok_for_spec rhs + -- See Note [Controlling Speculative Evaluation] + call_ok_for_spec x + | is_rec_call x = False + | not (cp_specEval cfg) = False + | not (cp_specEvalDFun cfg) && isDFunId x = False + | otherwise = True + is_rec_call = (`elemUnVarSet` cpe_rec_ids env) + + -- See Note [Pin evaluatedness on floats] + bndr' | is_hnf = bndr `setIdUnfolding` evaldUnfolding + | otherwise = bndr + +-- | Wrap floats around an expression +wrapBinds :: Floats -> CpeBody -> CpeBody +wrapBinds floats body + = -- pprTraceWith "wrapBinds" (\res -> ppr floats $$ ppr body $$ ppr res) $ + foldrOL mk_bind body (getFloats floats) + where + -- See Note [BindInfo and FloatInfo] on whether we pick Case or Let here + mk_bind f@(Float bind CaseBound _) body + | NonRec bndr rhs <- bind + = mkDefaultCase rhs bndr body + | otherwise + = pprPanic "wrapBinds" (ppr f) + mk_bind (Float bind _ _) body + = Let bind body + mk_bind (UnsafeEqualityCase scrut b con bs) body + = mkSingleAltCase scrut b con bs body + mk_bind (FloatTick tickish) body + = mkTick tickish body + +-- | Put floats at top-level +deFloatTop :: Floats -> [CoreBind] +-- Precondition: No Strict or LazyContextFloatable 'FloatInfo', no ticks! +deFloatTop floats + = foldrOL get [] (getFloats floats) + where + get (Float b _ TopLvlFloatable) bs + = get_bind b : bs + get b _ = pprPanic "deFloatTop" (ppr b) + + -- See Note [Dead code in CorePrep] + get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) + get_bind (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes] + +--------------------------------------------------------------------------- + +{- Note [wantFloatLocal] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let x = let y = e1 in e2 + in e +Similarly for `(\x. e) (let y = e1 in e2)`. +Do we want to float `y` out of `x`? +(This is discussed in detail in the paper +"Let-floating: moving bindings to give faster programs".) + +`wantFloatLocal` is concerned with answering this question. +It considers the Demand on `x`, whether or not `e2` is unlifted and the +`FloatInfo` of the `y` binding (e.g., it might itself be unlifted, a value, +strict, or ok-for-spec). + +We float out if ... + 1. ... the binding context is strict anyway, so either `x` is used strictly + or has unlifted type. + Doing so is trivially sound and won`t increase allocations, so we + return `FloatAll`. + This might happen while ANF-ising `f (g (h 13))` where `f`,`g` are strict: + f (g (h 13)) + ==> { ANF } + case (case h 13 of r -> g r) of r2 -> f r2 + ==> { Float } + case h 13 of r -> case g r of r2 -> f r2 + The latter is easier to read and grows less stack. + 2. ... `e2` becomes a value in doing so, in which case we won't need to + allocate a thunk for `x`/the arg that closes over the FVs of `e1`. + In general, this is only sound if `y=e1` is `LazyContextFloatable`. + (See Note [BindInfo and FloatInfo].) + Nothing is won if `x` doesn't become a value + (i.e., `let x = let sat = f 14 in g sat in e`), + so we return `FloatNone` if there is any float that is + `StrictContextFloatable`, and return `FloatAll` otherwise. + +To elaborate on (2), consider the case when the floated binding is +`e1 = divInt# a b`, e.g., not `LazyContextFloatable`: + let x = I# (a `divInt#` b) + in e +this ANFises to + let x = case a `divInt#` b of r { __DEFAULT -> I# r } + in e +If `x` is used lazily, we may not float `r` further out. +A float binding `x +# y` is OK, though, and so every ok-for-spec-eval +binding is `LazyContextFloatable`. + +Wrinkles: + + (W1) When the outer binding is a letrec, i.e., + letrec x = case a +# b of r { __DEFAULT -> f y r } + y = [x] + in e + we don't want to float `LazyContextFloatable` bindings such as `r` either + and require `TopLvlFloatable` instead. + The reason is that we don't track FV of FloatBindings, so we would need + to park them in the letrec, + letrec r = a +# b -- NB: r`s RHS might scope over x and y + x = f y r + y = [x] + in e + and now we have violated Note [Core letrec invariant]. + So we preempt this case in `wantFloatLocal`, responding `FloatNone` unless + all floats are `TopLvlFloatable`. +-} + +data FloatDecision + = FloatNone + | FloatAll + +instance Outputable FloatDecision where + ppr FloatNone = text "none" + ppr FloatAll = text "all" + +executeFloatDecision :: CorePrepEnv -> FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs) +executeFloatDecision env dec floats rhs + = case dec of + FloatAll -> return (floats, rhs) + FloatNone + | isEmptyFloats floats -> return (emptyFloats, rhs) + | otherwise -> do { (floats', body) <- rhsToBody env rhs + ; return (emptyFloats, wrapBinds floats $ + wrapBinds floats' body) } + -- FloatNone case: `rhs` might have lambdas, and we can't + -- put them inside a wrapBinds, which expects a `CpeBody`. + +wantFloatTop :: Floats -> FloatDecision +wantFloatTop fs + | fs_info fs `floatsAtLeastAsFarAs` TopLvlFloatable = FloatAll + | otherwise = FloatNone + +wantFloatLocal :: RecFlag -> Demand -> Levity -> Floats -> CpeRhs -> FloatDecision +-- See Note [wantFloatLocal] +wantFloatLocal is_rec rhs_dmd rhs_lev floats rhs + | isEmptyFloats floats -- Well yeah... + || isStrUsedDmd rhs_dmd -- Case (1) of Note [wantFloatLocal] + || rhs_lev == Unlifted -- dito + || (fs_info floats `floatsAtLeastAsFarAs` max_float_info && exprIsHNF rhs) + -- Case (2) of Note [wantFloatLocal] + = FloatAll + + | otherwise + = FloatNone + where + max_float_info | isRec is_rec = TopLvlFloatable + | otherwise = LazyContextFloatable + -- See Note [wantFloatLocal], Wrinkle (W1) + -- for 'is_rec' + +{- +************************************************************************ +* * + Cloning +* * +************************************************************************ +-} + +-- --------------------------------------------------------------------------- +-- The environment +-- --------------------------------------------------------------------------- + +{- Note [Inlining in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a subtle but important invariant that must be upheld in the output +of CorePrep: there are no "trivial" updatable thunks. Thus, this Core +is impermissible: + + let x :: () + x = y + +(where y is a reference to a GLOBAL variable). Thunks like this are silly: +they can always be profitably replaced by inlining x with y. Consequently, +the code generator/runtime does not bother implementing this properly +(specifically, there is no implementation of stg_ap_0_upd_info, which is the +stack frame that would be used to update this thunk. The "0" means it has +zero free variables.) + +In general, the inliner is good at eliminating these let-bindings. However, +there is one case where these trivial updatable thunks can arise: when +we are optimizing away 'lazy' (see Note [lazyId magic], and also +'cpeRhsE'.) Then, we could have started with: + + let x :: () + x = lazy @() y + +which is a perfectly fine, non-trivial thunk, but then CorePrep will drop +'lazy', giving us 'x = y' which is trivial and impermissible. The solution is +CorePrep to have a miniature inlining pass which deals with cases like this. +We can then drop the let-binding altogether. + +Why does the removal of 'lazy' have to occur in CorePrep? The gory details +are in Note [lazyId magic] in GHC.Types.Id.Make, but the main reason is that +lazy must appear in unfoldings (optimizer output) and it must prevent +call-by-value for catch# (which is implemented by CorePrep.) + +An alternate strategy for solving this problem is to have the inliner treat +'lazy e' as a trivial expression if 'e' is trivial. We decided not to adopt +this solution to keep the definition of 'exprIsTrivial' simple. + +There is ONE caveat however: for top-level bindings we have +to preserve the binding so that we float the (hacky) non-recursive +binding for data constructors; see Note [Data constructor workers]. + +Note [CorePrepEnv: cpe_subst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CorePrepEnv carries a substitution `Subst` in the `cpe_subst1 field, +for these reasons: + +1. To support cloning of local Ids so that they are + all unique (see Note [Cloning in CorePrep]) + +2. To support beta-reduction of runRW, see Note [runRW magic] and + Note [runRW arg]. + +3. To let us inline trivial RHSs of non top-level let-bindings, + see Note [lazyId magic], Note [Inlining in CorePrep] (#12076) + + Note that, if (y::forall a. a->a), we could get + x = lazy @(forall a.a) y @Bool + so after eliminating `lazy`, we need to replace occurrences of `x` with + `y @Bool`, not just `y`. Situations like this can easily arise with + higher-rank types; thus, `cpe_subst` must map to CoreExprs, not Ids, which + oc course it does + +4. The TyCoVar part of the substitution is used only for + Note [Cloning CoVars and TyVars] +-} + +data CorePrepConfig = CorePrepConfig + { cp_catchNonexhaustiveCases :: !Bool + -- ^ Whether to generate a default alternative with ``error`` in these + -- cases. This is helpful when debugging demand analysis or type + -- checker bugs which can sometimes manifest as segmentation faults. + + , cp_platform :: Platform + + , cp_arityOpts :: !(Maybe ArityOpts) + -- ^ Configuration for arity analysis ('exprEtaExpandArity'). + -- See Note [Eta expansion of arguments in CorePrep] + -- When 'Nothing' (e.g., -O0, -O1), use the cheaper 'exprArity' instead + , cp_specEval :: !Bool + -- ^ Whether to perform speculative evaluation + -- See Note [Controlling Speculative Evaluation] + , cp_specEvalDFun :: !Bool + -- ^ Whether to perform speculative evaluation on DFuns + } + +data CorePrepEnv + = CPE { cpe_config :: !CorePrepConfig + -- ^ This flag is intended to aid in debugging strictness + -- analysis bugs. These are particularly nasty to chase down as + -- they may manifest as segmentation faults. When this flag is + -- enabled we instead produce an 'error' expression to catch + -- the case where a function we think should bottom + -- unexpectedly returns. + + , cpe_subst :: Subst -- ^ See Note [CorePrepEnv: cpe_subst] + + , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation] + + , cpe_context :: [OccName] -- ^ See Note [Binder context] + } + +mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv +mkInitialCorePrepEnv cfg = CPE + { cpe_config = cfg + , cpe_subst = emptySubst + , cpe_rec_ids = emptyUnVarSet + , cpe_context = [] + } + +extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv +extendCorePrepEnv cpe@(CPE { cpe_subst = subst }) id id' + = cpe { cpe_subst = subst2 } + where + subst1 = extendSubstInScope subst id' + subst2 = extendIdSubst subst1 id (Var id') + +extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv +extendCorePrepEnvList cpe@(CPE { cpe_subst = subst }) prs + = cpe { cpe_subst = subst2 } + where + subst1 = extendSubstInScopeList subst (map snd prs) + subst2 = extendIdSubstList subst1 [(id, Var id') | (id,id') <- prs] + +extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv +extendCorePrepEnvExpr cpe id expr + = cpe { cpe_subst = extendIdSubst (cpe_subst cpe) id expr } + +lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr +lookupCorePrepEnv cpe id + = case lookupIdSubst_maybe (cpe_subst cpe) id of + Just e -> e + Nothing -> Var id + -- Do not use GHC.Core.Subs.lookupIdSubst because that is a no-op on GblIds; + -- and Tidy has made top-level externally-visible Ids into GblIds + +enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv +enterRecGroupRHSs env grp + = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) } + +cpSubstTy :: CorePrepEnv -> Type -> Type +cpSubstTy (CPE { cpe_subst = subst }) ty = substTy subst ty + -- substTy has a short-cut if the TCvSubst is empty + +cpSubstCo :: CorePrepEnv -> Coercion -> Coercion +cpSubstCo (CPE { cpe_subst = subst }) co = substCo subst co + -- substCo has a short-cut if the TCvSubst is empty + +-- | See Note [Binder context] +pushBinderContext :: Id -> CorePrepEnv -> CorePrepEnv +pushBinderContext ident env + | lengthAtLeast (cpe_context env) 2 + = env + | otherwise + = env { cpe_context = getOccName ident : cpe_context env} + +------------------------------------------------------------------------------ +-- Cloning binders +-- --------------------------------------------------------------------------- + +cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar]) +cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs + +cpCloneCoVarBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar) +-- Clone the CoVar +-- See Note [Cloning CoVars and TyVars] +cpCloneCoVarBndr env@(CPE { cpe_subst = subst }) covar + = assertPpr (isCoVar covar) (ppr covar) $ + do { uniq <- getUniqueM + ; let covar1 = setVarUnique covar uniq + covar2 = updateVarType (substTy subst) covar1 + subst1 = extendTCvSubstWithClone subst covar covar2 + ; return (env { cpe_subst = subst1 }, covar2) } + +cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar) +-- See Note [Cloning in CorePrep] +cpCloneBndr env@(CPE { cpe_subst = subst }) bndr + | isTyCoVar bndr -- See Note [Cloning CoVars and TyVars] + = if isEmptyTCvSubst subst -- The common case + then return (env { cpe_subst = extendSubstInScope subst bndr }, bndr) + else -- No need to clone the Unique; but we must apply the substitution + let bndr1 = updateVarType (substTy subst) bndr + subst1 = extendTCvSubstWithClone subst bndr bndr1 + in return (env { cpe_subst = subst1 }, bndr1) + + | otherwise -- A non-CoVar Id + = do { bndr1 <- clone_it bndr + ; let bndr2 = updateIdTypeAndMult (substTy subst) bndr1 + + -- Drop (now-useless) rules/unfoldings + -- See Note [Drop unfoldings and rules] + -- and Note [Preserve evaluatedness] in GHC.Core.Tidy + -- And force it.. otherwise the old unfolding is just retained. + -- See #22071 + ; let !unfolding' = trimUnfolding (realIdUnfolding bndr) + -- Simplifier will set the Id's unfolding + + bndr3 = bndr2 `setIdUnfolding` unfolding' + `setIdSpecialisation` emptyRuleInfo + + ; return (extendCorePrepEnv env bndr bndr3, bndr3) } + where + clone_it bndr + | isLocalId bndr + = do { uniq <- getUniqueM + ; return (setVarUnique bndr uniq) } + + | otherwise -- Top level things, which we don't want + -- to clone, have become GlobalIds by now + = return bndr + +{- Note [Drop unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to drop the unfolding/rules on every Id: + + - We are now past interface-file generation, and in the + codegen pipeline, so we really don't need full unfoldings/rules + + - The unfolding/rule may be keeping stuff alive that we'd like + to discard. See Note [Dead code in CorePrep] + + - Getting rid of unnecessary unfoldings reduces heap usage + + - We are changing uniques, so if we didn't discard unfoldings/rules + we'd have to substitute in them + +HOWEVER, we want to preserve evaluated-ness; +see Note [Preserve evaluatedness] in GHC.Core.Tidy. +-} + +------------------------------------------------------------------------------ +-- Cloning ccall Ids; each must have a unique name, +-- to give the code generator a handle to hang it on +-- --------------------------------------------------------------------------- + +fiddleCCall :: Id -> UniqSM Id +fiddleCCall id + | isFCallId id = (id `setVarUnique`) <$> getUniqueM + | otherwise = return id + +------------------------------------------------------------------------------ +-- Generating new binders +-- --------------------------------------------------------------------------- + +newVar :: CorePrepEnv -> Type -> UniqSM Id +newVar env ty + -- See Note [Binder context] + = seqType ty `seq` mkSysLocalOrCoVarM (fsLit occ) ManyTy ty + where occ = intercalate "_" (map occNameString $ cpe_context env) ++ "_sat" + +{- Note [Binder context] + ~~~~~~~~~~~~~~~~~~~~~ + To ensure that the compiled program (specifically symbol names) + remains understandable to the user we maintain a context + of binders that we are currently under. This allows us to give + identifiers conjured during CorePrep more contextually-meaningful + names. This is done in `newVar`. + -} + +------------------------------------------------------------------------------ +-- Floating ticks +-- --------------------------------------------------------------------------- +-- +-- Note [Floating Ticks in CorePrep] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- It might seem counter-intuitive to float ticks by default, given +-- that we don't actually want to move them if we can help it. On the +-- other hand, nothing gets very far in CorePrep anyway, and we want +-- to preserve the order of let bindings and tick annotations in +-- relation to each other. For example, if we just wrapped let floats +-- when they pass through ticks, we might end up performing the +-- following transformation: +-- +-- src<...> let foo = bar in baz +-- ==> let foo = src<...> bar in src<...> baz +-- +-- Because the let-binding would float through the tick, and then +-- immediately materialize, achieving nothing but decreasing tick +-- accuracy. The only special case is the following scenario: +-- +-- let foo = src<...> (let a = b in bar) in baz +-- ==> let foo = src<...> bar; a = src<...> b in baz +-- +-- Here we would not want the source tick to end up covering "baz" and +-- therefore refrain from pushing ticks outside. Instead, we copy them +-- into the floating binds (here "a") in cpePair. Note that where "b" +-- or "bar" are (value) lambdas we have to push the annotations +-- further inside in order to uphold our rules. +-- +-- All of this is implemented below in @wrapTicks@. + +-- | Like wrapFloats, but only wraps tick floats +wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr) +wrapTicks floats expr + | (floats1, ticks1) <- fold_fun go floats + = (floats1, foldrOL mkTick expr ticks1) + where fold_fun f floats = + let (binds, ticks) = foldlOL f (nilOL,nilOL) (fs_binds floats) + in (floats { fs_binds = binds }, ticks) + -- Deeply nested constructors will produce long lists of + -- redundant source note floats here. We need to eliminate + -- those early, as relying on mkTick to spot it after the fact + -- can yield O(n^3) complexity [#11095] + go (flt_binds, ticks) (FloatTick t) + = assert (tickishPlace t == PlaceNonLam) + (flt_binds, if any (flip tickishContains t) ticks + then ticks else ticks `snocOL` t) + go (flt_binds, ticks) f@UnsafeEqualityCase{} + -- unsafe equality case will be erased; don't wrap anything! + = (flt_binds `snocOL` f, ticks) + go (flt_binds, ticks) f@Float{} + = (flt_binds `snocOL` foldrOL wrap f ticks, ticks) + + wrap t (Float bind bound info) = Float (wrapBind t bind) bound info + wrap _ f = pprPanic "Unexpected FloatingBind" (ppr f) + wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) + wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) + +------------------------------------------------------------------------------ +-- Numeric literals +-- --------------------------------------------------------------------------- + +-- | Converts Bignum literals into their final CoreExpr +cpeBigNatLit + :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs) +cpeBigNatLit env i = assert (i >= 0) $ do + let + platform = cp_platform (cpe_config env) + + -- Per the documentation in GHC.Internal.Bignum.BigNat, a BigNat# is: + -- "Represented as an array of limbs (Word#) stored in + -- little-endian order (Word# themselves use machine order)." + -- + -- "Invariant (canonical representation): higher Word# is non-zero." + -- So we need to break up the integer into target-word-sized chunks, + -- and encode each of them using the target's byte-order. + encodeBigNat + :: forall a. Num a => FixedPrim a -> BS.ByteString + encodeBigNat encodeWord + = BS.toStrict (BB.toLazyByteString (primUnfoldrFixed encodeWord f i)) + -- (quadratic complexity due to repeated shifts... ok for now) + where + f 0 = Nothing + f x = let low = fromInteger x :: a + high = x `shiftR` bits + in Just (low, high) + bits = platformWordSizeInBits platform + + words :: BS.ByteString + words = case (platformWordSize platform, platformByteOrder platform) of + (PW4, LittleEndian) -> encodeBigNat word32LE + (PW4, BigEndian ) -> encodeBigNat word32BE + (PW8, LittleEndian) -> encodeBigNat word64LE + (PW8, BigEndian ) -> encodeBigNat word64BE + + -- Ideally we would just generate a ByteArray# literal here: + -- pure (emptyFloats, Lit (LitByteArray words)) + -- But sadly we don't have those yet, even in Core. (See also #17747.) + -- So instead we generate: + -- * An `Addr#` literal that contains the contents of the + -- `ByteArray#` we want to create. This gets its own float. + -- * A call to `newByteArray#` with the appropriate size + -- * A call to `copyAddrToByteArray#` to initialize the `ByteArray#` + -- * A call to `unsafeFreezeByteArray#` to make the types match + litAddrId <- mkSysLocalM (fsLit "bigNatGuts") ManyTy addrPrimTy + -- returned from newByteArray#: + deadNewByteArrayTupleId + <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $ + mkTupleTy Unboxed [ realWorldStatePrimTy + , realWorldMutableByteArrayPrimTy + ] + stateTokenFromNewByteArrayId + <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy + mutableByteArrayId + <- mkSysLocalM (fsLit "mba") ManyTy realWorldMutableByteArrayPrimTy + -- returned from copyAddrToByteArray#: + stateTokenFromCopyId + <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy + -- returned from unsafeFreezeByteArray#: + deadFreezeTupleId + <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $ + mkTupleTy Unboxed [realWorldStatePrimTy, byteArrayPrimTy] + stateTokenFromFreezeId + <- (`setIdOccInfo` IAmDead) <$> + mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy + byteArrayId <- mkSysLocalM (fsLit "ba") ManyTy byteArrayPrimTy + + let + litAddrRhs = Lit (LitString words) + -- not "mkLitString"; that does UTF-8 encoding, which we don't want here + (litAddrFloat, litAddrId') = mkNonRecFloat env Unlifted litAddrId litAddrRhs + + contentsLength = mkIntLit platform (toInteger (BS.length words)) + + newByteArrayCall = + Var (primOpId NewByteArrayOp_Char) + `App` Type realWorldTy + `App` contentsLength + `App` Var realWorldPrimId + + copyContentsCall = + Var (primOpId CopyAddrToByteArrayOp) + `App` Type realWorldTy + `App` Var litAddrId' + `App` Var mutableByteArrayId + `App` mkIntLit platform 0 + `App` contentsLength + `App` Var stateTokenFromNewByteArrayId + + unsafeFreezeCall = + Var (primOpId UnsafeFreezeByteArrayOp) + `App` Type realWorldTy + `App` Var mutableByteArrayId + `App` Var stateTokenFromCopyId + + unboxed2tuple_altcon :: AltCon + unboxed2tuple_altcon = DataAlt (tupleDataCon Unboxed 2) + + finalRhs = + Case newByteArrayCall deadNewByteArrayTupleId byteArrayPrimTy + [ Alt unboxed2tuple_altcon + [stateTokenFromNewByteArrayId, mutableByteArrayId] + copyContentsCase + ] + + copyContentsCase = + Case copyContentsCall stateTokenFromCopyId byteArrayPrimTy + [ Alt DEFAULT [] unsafeFreezeCase + ] + + unsafeFreezeCase = + Case unsafeFreezeCall deadFreezeTupleId byteArrayPrimTy + [ Alt unboxed2tuple_altcon + [stateTokenFromFreezeId, byteArrayId] + (Var byteArrayId) + ] + + pure (emptyFloats `snocFloat` litAddrFloat, finalRhs) diff --git a/GHC/Data/Bag.hs b/GHC/Data/Bag.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Bag.hs @@ -0,0 +1,373 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Bag: an unordered collection with duplicates +-} + +{-# LANGUAGE ScopedTypeVariables, DeriveTraversable, TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-data-list-nonempty-unzip #-} + +module GHC.Data.Bag ( + Bag, -- abstract type + + emptyBag, unitBag, unionBags, unionManyBags, + mapBag, pprBag, + elemBag, lengthBag, + filterBag, partitionBag, partitionBagWith, + concatBag, catBagMaybes, foldBag_flip, + isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, + listToBag, nonEmptyToBag, bagToList, headMaybe, mapAccumBagL, + concatMapBag, concatMapBagPair, mapMaybeBag, mapMaybeBagM, unzipBag, + mapBagM, mapBagM_, lookupBag, + flatMapBagM, flatMapBagPairM, + mapAndUnzipBagM, mapAccumBagLM, + anyBagM, filterBagM + ) where + +import GHC.Prelude + +import GHC.Exts ( IsList(..) ) +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Monad +import Control.Monad +import Data.Data +import Data.Maybe( mapMaybe ) +import Data.List ( partition, mapAccumL ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup ( (<>) ) +import Control.Applicative( Alternative( (<|>) ) ) +import Control.DeepSeq + +infixr 3 `consBag` +infixl 3 `snocBag` + +data Bag a + = EmptyBag + | UnitBag a + | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty + | ListBag (NonEmpty a) + deriving (Foldable, Functor, Traversable) + +instance NFData a => NFData (Bag a) where + rnf EmptyBag = () + rnf (UnitBag a) = rnf a + rnf (TwoBags a b) = rnf a `seq` rnf b + rnf (ListBag a) = rnf a + +emptyBag :: Bag a +emptyBag = EmptyBag + +unitBag :: a -> Bag a +unitBag = UnitBag + +lengthBag :: Bag a -> Int +lengthBag EmptyBag = 0 +lengthBag (UnitBag {}) = 1 +lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2 +lengthBag (ListBag xs) = length xs + +elemBag :: Eq a => a -> Bag a -> Bool +elemBag _ EmptyBag = False +elemBag x (UnitBag y) = x == y +elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 +elemBag x (ListBag ys) = any (x ==) ys + +unionManyBags :: [Bag a] -> Bag a +unionManyBags xs = foldr unionBags EmptyBag xs + +-- This one is a bit stricter! The bag will get completely evaluated. + +unionBags :: Bag a -> Bag a -> Bag a +unionBags EmptyBag b = b +unionBags b EmptyBag = b +unionBags b1 b2 = TwoBags b1 b2 + +consBag :: a -> Bag a -> Bag a +snocBag :: Bag a -> a -> Bag a + +consBag elt bag = (unitBag elt) `unionBags` bag +snocBag bag elt = bag `unionBags` (unitBag elt) + +isEmptyBag :: Bag a -> Bool +isEmptyBag EmptyBag = True +isEmptyBag _ = False + +isSingletonBag :: Bag a -> Bool +isSingletonBag EmptyBag = False +isSingletonBag (UnitBag _) = True +isSingletonBag (TwoBags _ _) = False -- Neither is empty +isSingletonBag (ListBag (_:|xs)) = null xs + +filterBag :: (a -> Bool) -> Bag a -> Bag a +filterBag _ EmptyBag = EmptyBag +filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag +filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 + where sat1 = filterBag pred b1 + sat2 = filterBag pred b2 +filterBag pred (ListBag vs) = listToBag (filter pred (toList vs)) + +filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a) +filterBagM _ EmptyBag = return EmptyBag +filterBagM pred b@(UnitBag val) = do + flag <- pred val + if flag then return b + else return EmptyBag +filterBagM pred (TwoBags b1 b2) = do + sat1 <- filterBagM pred b1 + sat2 <- filterBagM pred b2 + return (sat1 `unionBags` sat2) +filterBagM pred (ListBag vs) = do + sat <- filterM pred (toList vs) + return (listToBag sat) +{-# INLINEABLE filterBagM #-} + +lookupBag :: Eq a => a -> Bag (a,b) -> Maybe b +lookupBag _ EmptyBag = Nothing +lookupBag k (UnitBag kv) = lookup_one k kv +lookupBag k (TwoBags b1 b2) = lookupBag k b1 <|> lookupBag k b2 +lookupBag k (ListBag xs) = foldr ((<|>) . lookup_one k) Nothing xs +{-# INLINEABLE lookupBag #-} + +lookup_one :: Eq a => a -> (a,b) -> Maybe b +lookup_one k (k',v) | k==k' = Just v + | otherwise = Nothing + +allBag :: (a -> Bool) -> Bag a -> Bool +allBag _ EmptyBag = True +allBag p (UnitBag v) = p v +allBag p (TwoBags b1 b2) = allBag p b1 && allBag p b2 +allBag p (ListBag xs) = all p xs + +anyBag :: (a -> Bool) -> Bag a -> Bool +anyBag _ EmptyBag = False +anyBag p (UnitBag v) = p v +anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2 +anyBag p (ListBag xs) = any p xs + +anyBagM :: Monad m => (a -> m Bool) -> Bag a -> m Bool +anyBagM _ EmptyBag = return False +anyBagM p (UnitBag v) = p v +anyBagM p (TwoBags b1 b2) = do flag <- anyBagM p b1 + if flag then return True + else anyBagM p b2 +anyBagM p (ListBag xs) = anyM p xs +{-# INLINEABLE anyBagM #-} + +concatBag :: Bag (Bag a) -> Bag a +concatBag = foldr unionBags emptyBag + +catBagMaybes :: Bag (Maybe a) -> Bag a +catBagMaybes bs = foldr add emptyBag bs + where + add Nothing rs = rs + add (Just x) rs = x `consBag` rs + +partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predicate -}, + Bag a {- Don't -}) +partitionBag _ EmptyBag = (EmptyBag, EmptyBag) +partitionBag pred b@(UnitBag val) + = if pred val then (b, EmptyBag) else (EmptyBag, b) +partitionBag pred (TwoBags b1 b2) + = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where (sat1, fail1) = partitionBag pred b1 + (sat2, fail2) = partitionBag pred b2 +partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) + where (sats, fails) = partition pred (toList vs) + + +partitionBagWith :: (a -> Either b c) -> Bag a + -> (Bag b {- Left -}, + Bag c {- Right -}) +partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag) +partitionBagWith pred (UnitBag val) + = case pred val of + Left a -> (UnitBag a, EmptyBag) + Right b -> (EmptyBag, UnitBag b) +partitionBagWith pred (TwoBags b1 b2) + = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where (sat1, fail1) = partitionBagWith pred b1 + (sat2, fail2) = partitionBagWith pred b2 +partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) + where (sats, fails) = partitionWith pred (toList vs) + +foldBag_flip :: (a -> b -> b) -> Bag a -> b -> b +-- Just foldr with flipped arguments, +-- so it can be chained more nicely +foldBag_flip k bag z = foldr k z bag + +mapBag :: (a -> b) -> Bag a -> Bag b +mapBag = fmap + +concatMapBag :: (a -> Bag b) -> Bag a -> Bag b +concatMapBag _ EmptyBag = EmptyBag +concatMapBag f (UnitBag x) = f x +concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2) +concatMapBag f (ListBag xs) = foldr (unionBags . f) emptyBag xs + +concatMapBagPair :: (a -> (Bag b, Bag c)) -> Bag a -> (Bag b, Bag c) +concatMapBagPair _ EmptyBag = (EmptyBag, EmptyBag) +concatMapBagPair f (UnitBag x) = f x +concatMapBagPair f (TwoBags b1 b2) = (unionBags r1 r2, unionBags s1 s2) + where + (r1, s1) = concatMapBagPair f b1 + (r2, s2) = concatMapBagPair f b2 +concatMapBagPair f (ListBag xs) = foldr go (emptyBag, emptyBag) xs + where + go a (s1, s2) = (unionBags r1 s1, unionBags r2 s2) + where + (r1, r2) = f a + +mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b +mapMaybeBag _ EmptyBag = EmptyBag +mapMaybeBag f (UnitBag x) = case f x of + Nothing -> EmptyBag + Just y -> UnitBag y +mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) +mapMaybeBag f (ListBag xs) = listToBag $ mapMaybe f (toList xs) + +mapMaybeBagM :: Monad m => (a -> m (Maybe b)) -> Bag a -> m (Bag b) +mapMaybeBagM _ EmptyBag = return EmptyBag +mapMaybeBagM f (UnitBag x) = do r <- f x + return $ case r of + Nothing -> EmptyBag + Just y -> UnitBag y +mapMaybeBagM f (TwoBags b1 b2) = do r1 <- mapMaybeBagM f b1 + r2 <- mapMaybeBagM f b2 + return $ unionBags r1 r2 +mapMaybeBagM f (ListBag xs) = listToBag <$> mapMaybeM f (toList xs) + +mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) +mapBagM _ EmptyBag = return EmptyBag +mapBagM f (UnitBag x) = do r <- f x + return (UnitBag r) +mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1 + r2 <- mapBagM f b2 + return (TwoBags r1 r2) +mapBagM f (ListBag xs) = do rs <- mapM f xs + return (ListBag rs) +{-# INLINEABLE mapBagM #-} + +mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () +mapBagM_ _ EmptyBag = return () +mapBagM_ f (UnitBag x) = f x >> return () +mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 +mapBagM_ f (ListBag xs) = mapM_ f xs +{-# INLINEABLE mapBagM_ #-} + +flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) +flatMapBagM _ EmptyBag = return EmptyBag +flatMapBagM f (UnitBag x) = f x +flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1 + r2 <- flatMapBagM f b2 + return (r1 `unionBags` r2) +flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs + where + k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) } +{-# INLINEABLE flatMapBagM #-} + +flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) +flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag) +flatMapBagPairM f (UnitBag x) = f x +flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1 + (r2,s2) <- flatMapBagPairM f b2 + return (r1 `unionBags` r2, s1 `unionBags` s2) +flatMapBagPairM f (ListBag xs) = foldrM k (EmptyBag, EmptyBag) xs + where + k x (r2,s2) = do { (r1,s1) <- f x + ; return (r1 `unionBags` r2, s1 `unionBags` s2) } +{-# INLINEABLE flatMapBagPairM #-} + +mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) +mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag) +mapAndUnzipBagM f (UnitBag x) = do (r,s) <- f x + return (UnitBag r, UnitBag s) +mapAndUnzipBagM f (TwoBags b1 b2) = do (r1,s1) <- mapAndUnzipBagM f b1 + (r2,s2) <- mapAndUnzipBagM f b2 + return (TwoBags r1 r2, TwoBags s1 s2) +mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs + let (rs,ss) = NE.unzip ts + return (ListBag rs, ListBag ss) +{-# INLINEABLE mapAndUnzipBagM #-} + +mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> Bag x -- ^ inputs + -> (acc, Bag y) -- ^ final state, outputs +mapAccumBagL _ s EmptyBag = (s, EmptyBag) +mapAccumBagL f s (UnitBag x) = let (s1, x1) = f s x in (s1, UnitBag x1) +mapAccumBagL f s (TwoBags b1 b2) = let (s1, b1') = mapAccumBagL f s b1 + (s2, b2') = mapAccumBagL f s1 b2 + in (s2, TwoBags b1' b2') +mapAccumBagL f s (ListBag xs) = let (s', xs') = mapAccumL f s xs + in (s', ListBag xs') + +mapAccumBagLM :: Monad m + => (acc -> x -> m (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> Bag x -- ^ inputs + -> m (acc, Bag y) -- ^ final state, outputs +mapAccumBagLM _ s EmptyBag = return (s, EmptyBag) +mapAccumBagLM f s (UnitBag x) = do { (s1, x1) <- f s x; return (s1, UnitBag x1) } +mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s b1 + ; (s2, b2') <- mapAccumBagLM f s1 b2 + ; return (s2, TwoBags b1' b2') } +mapAccumBagLM f s (ListBag xs) = do { (s', xs') <- mapAccumLM f s xs + ; return (s', ListBag xs') } +{-# INLINEABLE mapAccumBagLM #-} + +listToBag :: [a] -> Bag a +listToBag [] = EmptyBag +listToBag [x] = UnitBag x +listToBag (x:xs) = ListBag (x:|xs) + +nonEmptyToBag :: NonEmpty a -> Bag a +nonEmptyToBag (x :| []) = UnitBag x +nonEmptyToBag xs = ListBag xs + +bagToList :: Bag a -> [a] +bagToList b = foldr (:) [] b + +unzipBag :: Bag (a, b) -> (Bag a, Bag b) +unzipBag EmptyBag = (EmptyBag, EmptyBag) +unzipBag (UnitBag (a, b)) = (UnitBag a, UnitBag b) +unzipBag (TwoBags xs1 xs2) = (TwoBags as1 as2, TwoBags bs1 bs2) + where + (as1, bs1) = unzipBag xs1 + (as2, bs2) = unzipBag xs2 +unzipBag (ListBag xs) = (ListBag as, ListBag bs) + where + (as, bs) = NE.unzip xs + +headMaybe :: Bag a -> Maybe a +headMaybe EmptyBag = Nothing +headMaybe (UnitBag v) = Just v +headMaybe (TwoBags b1 _) = headMaybe b1 +headMaybe (ListBag (v:|_)) = Just v + +instance (Outputable a) => Outputable (Bag a) where + ppr = pprBag + +pprBag :: Outputable a => Bag a -> SDoc +pprBag bag = braces (pprWithCommas ppr (bagToList bag)) + +instance Data a => Data (Bag a) where + gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly + toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Bag" + dataCast1 x = gcast1 x + +instance IsList (Bag a) where + type Item (Bag a) = a + fromList = listToBag + toList = bagToList + +instance Semigroup (Bag a) where + (<>) = unionBags + +instance Monoid (Bag a) where + mempty = emptyBag diff --git a/GHC/Data/Bitmap.hs b/GHC/Data/Bitmap.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Bitmap.hs @@ -0,0 +1,101 @@ +-- +-- (c) The University of Glasgow 2003-2006 +-- + +-- Functions for constructing bitmaps, which are used in various +-- places in generated code (stack frame liveness masks, function +-- argument liveness masks, SRT bitmaps). + +module GHC.Data.Bitmap ( + Bitmap, mkBitmap, + intsToReverseBitmap, + mAX_SMALL_BITMAP_SIZE, + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Runtime.Heap.Layout + + +{-| +A bitmap represented by a sequence of 'StgWord's on the /target/ +architecture. These are used for bitmaps in info tables and other +generated code which need to be emitted as sequences of StgWords. +-} +type Bitmap = [StgWord] + +-- | Make a bitmap from a sequence of bits +mkBitmap :: Platform -> [Bool] -> Bitmap +mkBitmap _ [] = [] +mkBitmap platform stuff = chunkToBitmap platform chunk : mkBitmap platform rest + where (chunk, rest) = splitAt (platformWordSizeInBits platform) stuff + +chunkToBitmap :: Platform -> [Bool] -> StgWord +chunkToBitmap platform chunk = + foldl' (.|.) (toStgWord platform 0) [ oneAt n | (True,n) <- zip chunk [0..] ] + where + oneAt :: Int -> StgWord + oneAt i = toStgWord platform 1 `shiftL` i + +-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap. +-- eg. @[0,1,3], size 4 ==> 0x4@ (we leave any bits outside the size as zero, +-- just to make the bitmap easier to read). +-- +-- The list of @Int@s /must/ be already sorted and duplicate-free. +intsToReverseBitmap :: Platform + -> Int -- ^ size in bits + -> [Int] -- ^ sorted indices of zeros free of duplicates + -> Bitmap +intsToReverseBitmap platform size = go 0 + where + word_sz = platformWordSizeInBits platform + oneAt :: Int -> StgWord + oneAt i = toStgWord platform 1 `shiftL` i + + -- It is important that we maintain strictness here. + -- See Note [Strictness when building Bitmaps]. + go :: Int -> [Int] -> Bitmap + go !pos slots + | size <= pos = [] + | otherwise = + (foldl' xor (toStgWord platform init) (map (\i->oneAt (i - pos)) these)) : + go (pos + word_sz) rest + where + (these,rest) = span (< (pos + word_sz)) slots + remain = size - pos + init + | remain >= word_sz = -1 + | otherwise = (1 `shiftL` remain) - 1 + +{- + +Note [Strictness when building Bitmaps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +One of the places where @Bitmap@ is used is in building Static Reference +Tables (SRTs) (in @GHC.Cmm.Info.Build.procpointSRT@). In #7450 it was noticed +that some test cases (particularly those whose C-- have large numbers of CAFs) +produced large quantities of allocations from this function. + +The source traced back to 'intsToBitmap', which was lazily subtracting the word +size from the elements of the tail of the @slots@ list and recursively invoking +itself with the result. This resulted in large numbers of subtraction thunks +being built up. Here we take care to avoid passing new thunks to the recursive +call. Instead we pass the unmodified tail along with an explicit position +accumulator, which get subtracted in the fold when we compute the Word. + +-} + +{- | +Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h. +Some kinds of bitmap pack a size\/bitmap into a single word if +possible, or fall back to an external pointer when the bitmap is too +large. This value represents the largest size of bitmap that can be +packed into a single word. +-} +mAX_SMALL_BITMAP_SIZE :: Platform -> Int +mAX_SMALL_BITMAP_SIZE platform = + case platformWordSize platform of + PW4 -> 27 -- On 32-bit: 5 bits for size, 27 bits for bitmap + PW8 -> 58 -- On 64-bit: 6 bits for size, 58 bits for bitmap diff --git a/GHC/Data/Bool.hs b/GHC/Data/Bool.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Bool.hs @@ -0,0 +1,25 @@ +module GHC.Data.Bool + ( OverridingBool(..) + , overrideWith + ) +where + +import GHC.Prelude.Basic + +data OverridingBool + = Auto + | Never + | Always + deriving + ( Show + , Read -- ^ @since 9.4.1 + , Eq -- ^ @since 9.4.1 + , Ord -- ^ @since 9.4.1 + , Enum -- ^ @since 9.4.1 + , Bounded -- ^ @since 9.4.1 + ) + +overrideWith :: Bool -> OverridingBool -> Bool +overrideWith b Auto = b +overrideWith _ Never = False +overrideWith _ Always = True diff --git a/GHC/Data/BooleanFormula.hs b/GHC/Data/BooleanFormula.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/BooleanFormula.hs @@ -0,0 +1,240 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-------------------------------------------------------------------------------- +-- | Boolean formulas without quantifiers and without negation. +-- Such a formula consists of variables, conjunctions (and), and disjunctions (or). +-- +-- This module is used to represent minimal complete definitions for classes. +-- +module GHC.Data.BooleanFormula ( + module Language.Haskell.Syntax.BooleanFormula, + isFalse, isTrue, + bfMap, bfTraverse, + eval, simplify, isUnsatisfied, + implies, impliesAtom, + pprBooleanFormula, pprBooleanFormulaNice, pprBooleanFormulaNormal + ) where + +import Data.List ( intersperse ) +import Data.List.NonEmpty ( NonEmpty (..), init, last ) + +import GHC.Prelude hiding ( init, last ) +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.SrcLoc (unLoc) +import GHC.Utils.Outputable +import GHC.Parser.Annotation ( SrcSpanAnnL ) +import GHC.Hs.Extension (GhcPass (..), OutputableBndrId) +import Language.Haskell.Syntax.Extension (Anno, LIdP, IdP) +import Language.Haskell.Syntax.BooleanFormula + + +---------------------------------------------------------------------- +-- Boolean formula type and smart constructors +---------------------------------------------------------------------- + +type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnL + +-- if we had Functor/Traversable (LbooleanFormula p) we could use that +-- as a constraint and we wouldn't need to specialize to just GhcPass p, +-- but becuase LBooleanFormula is a type synonym such a constraint is +-- impossible. + +-- BooleanFormula can't be an instance of functor because it can't lift +-- arbitrary functions `a -> b`, only functions of type `LIdP a -> LIdP b` +-- ditto for Traversable. +bfMap :: (LIdP (GhcPass p) -> LIdP (GhcPass p')) + -> BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p') +bfMap f = go + where + go (Var a ) = Var $ f a + go (And bfs) = And $ map (fmap go) bfs + go (Or bfs) = Or $ map (fmap go) bfs + go (Parens bf ) = Parens $ fmap go bf + +bfTraverse :: Applicative f + => (LIdP (GhcPass p) -> f (LIdP (GhcPass p'))) + -> BooleanFormula (GhcPass p) + -> f (BooleanFormula (GhcPass p')) +bfTraverse f = go + where + go (Var a ) = Var <$> f a + go (And bfs) = And <$> traverse @[] (traverse go) bfs + go (Or bfs) = Or <$> traverse @[] (traverse go) bfs + go (Parens bf ) = Parens <$> traverse go bf + + + +{- +Note [Simplification of BooleanFormulas] +~~~~~~~~~~~~~~~~~~~~~~ +The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular, + 1. Collapsing nested ands and ors, so + `(mkAnd [x, And [y,z]]` + is represented as + `And [x,y,z]` + Implemented by `fromAnd`/`fromOr` + 2. Collapsing trivial ands and ors, so + `mkAnd [x]` becomes just `x`. + Implemented by mkAnd' / mkOr' + 3. Conjunction with false, disjunction with true is simplified, i.e. + `mkAnd [mkFalse,x]` becomes `mkFalse`. + 4. Common subexpression elimination: + `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`. + +This simplification is not exhaustive, in the sense that it will not produce +the smallest possible equivalent expression. For example, +`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently +is not. A general simplifier would need to use something like BDDs. + +The reason behind the (crude) simplifier is to make for more user friendly +error messages. E.g. for the code + > class Foo a where + > {-# MINIMAL bar, (foo, baq | foo, quux) #-} + > instance Foo Int where + > bar = ... + > baz = ... + > quux = ... +We don't show a ridiculous error message like + Implement () and (either (`foo' and ()) or (`foo' and ())) +-} + +---------------------------------------------------------------------- +-- Evaluation and simplification +---------------------------------------------------------------------- + +isFalse :: BooleanFormula (GhcPass p) -> Bool +isFalse (Or []) = True +isFalse _ = False + +isTrue :: BooleanFormula (GhcPass p) -> Bool +isTrue (And []) = True +isTrue _ = False + +eval :: (LIdP (GhcPass p) -> Bool) -> BooleanFormula (GhcPass p) -> Bool +eval f (Var x) = f x +eval f (And xs) = all (eval f . unLoc) xs +eval f (Or xs) = any (eval f . unLoc) xs +eval f (Parens x) = eval f (unLoc x) + +-- Simplify a boolean formula. +-- The argument function should give the truth of the atoms, or Nothing if undecided. +simplify :: forall p. Eq (LIdP (GhcPass p)) + => (LIdP (GhcPass p) -> Maybe Bool) + -> BooleanFormula (GhcPass p) + -> BooleanFormula (GhcPass p) +simplify f (Var a) = case f a of + Nothing -> Var a + Just b -> mkBool b +simplify f (And xs) = mkAnd (map (fmap (simplify f)) xs) +simplify f (Or xs) = mkOr (map (fmap (simplify f)) xs) +simplify f (Parens x) = simplify f (unLoc x) + +-- Test if a boolean formula is satisfied when the given values are assigned to the atoms +-- if it is, returns Nothing +-- if it is not, return (Just remainder) +isUnsatisfied :: Eq (LIdP (GhcPass p)) + => (LIdP (GhcPass p) -> Bool) + -> BooleanFormula (GhcPass p) + -> Maybe (BooleanFormula (GhcPass p)) +isUnsatisfied f bf + | isTrue bf' = Nothing + | otherwise = Just bf' + where + f' x = if f x then Just True else Nothing + bf' = simplify f' bf + +-- prop_simplify: +-- eval f x == True <==> isTrue (simplify (Just . f) x) +-- eval f x == False <==> isFalse (simplify (Just . f) x) + +-- If the boolean formula holds, does that mean that the given atom is always true? +impliesAtom :: Eq (IdP (GhcPass p)) => BooleanFormula (GhcPass p) -> LIdP (GhcPass p) -> Bool +Var x `impliesAtom` y = (unLoc x) == (unLoc y) +And xs `impliesAtom` y = any (\x -> unLoc x `impliesAtom` y) xs + -- we have all of xs, so one of them implying y is enough +Or xs `impliesAtom` y = all (\x -> unLoc x `impliesAtom` y) xs +Parens x `impliesAtom` y = unLoc x `impliesAtom` y + +implies :: (Uniquable (IdP (GhcPass p))) => BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p) -> Bool +implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) + where + go :: Uniquable (IdP (GhcPass p)) => Clause (GhcPass p) -> Clause (GhcPass p) -> Bool + go l@Clause{ clauseExprs = hyp:hyps } r = + case hyp of + Var x | memberClauseAtoms (unLoc x) r -> True + | otherwise -> go (extendClauseAtoms l (unLoc x)) { clauseExprs = hyps } r + Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r + And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r + Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' + go l r@Clause{ clauseExprs = con:cons } = + case con of + Var x | memberClauseAtoms (unLoc x) l -> True + | otherwise -> go l (extendClauseAtoms r (unLoc x)) { clauseExprs = cons } + Parens con' -> go l r { clauseExprs = unLoc con':cons } + And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' + Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } + go _ _ = False + +-- A small sequent calculus proof engine. +data Clause p = Clause { + clauseAtoms :: UniqSet (IdP p), + clauseExprs :: [BooleanFormula p] + } +extendClauseAtoms :: Uniquable (IdP p) => Clause p -> IdP p -> Clause p +extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x } + +memberClauseAtoms :: Uniquable (IdP p) => IdP p -> Clause p -> Bool +memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c + +---------------------------------------------------------------------- +-- Pretty printing +---------------------------------------------------------------------- + +-- Pretty print a BooleanFormula, +-- using the arguments as pretty printers for Var, And and Or respectively +pprBooleanFormula' :: (Rational -> LIdP (GhcPass p) -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> Rational -> BooleanFormula (GhcPass p) -> SDoc +pprBooleanFormula' pprVar pprAnd pprOr = go + where + go p (Var x) = pprVar p x + go p (And []) = cparen (p > 0) empty + go p (And xs) = pprAnd p (map (go 3 . unLoc) xs) + go _ (Or []) = keyword $ text "FALSE" + go p (Or xs) = pprOr p (map (go 2 . unLoc) xs) + go p (Parens x) = go p (unLoc x) + +-- Pretty print in source syntax, "a | b | c,d,e" +pprBooleanFormula :: (Rational -> LIdP (GhcPass p) -> SDoc) + -> Rational -> BooleanFormula (GhcPass p) -> SDoc +pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr + where + pprAnd p = cparen (p > 3) . fsep . punctuate comma + pprOr p = cparen (p > 2) . fsep . intersperse vbar + +-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? +pprBooleanFormulaNice :: Outputable (LIdP (GhcPass p)) => BooleanFormula (GhcPass p) -> SDoc +pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 + where + pprVar _ = quotes . ppr + pprAnd p = cparen (p > 1) . pprAnd' + pprAnd' [] = empty + pprAnd' [x,y] = x <+> text "and" <+> y + pprAnd' (x:xs) = fsep (punctuate comma (init (x:|xs))) <> text ", and" <+> last (x:|xs) + pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) + +instance OutputableBndrId p => Outputable (BooleanFormula (GhcPass p)) where + ppr = pprBooleanFormulaNormal + +pprBooleanFormulaNormal :: OutputableBndrId p => BooleanFormula (GhcPass p) -> SDoc +pprBooleanFormulaNormal = go + where + go (Var x) = pprPrefixOcc (unLoc x) + go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) + go (Or []) = keyword $ text "FALSE" + go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) + go (Parens x) = parens (go $ unLoc x) diff --git a/GHC/Data/EnumSet.hs b/GHC/Data/EnumSet.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/EnumSet.hs @@ -0,0 +1,69 @@ +-- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' +-- things. +module GHC.Data.EnumSet + ( EnumSet + , member + , insert + , delete + , toList + , fromList + , empty + , difference + ) where + +import GHC.Prelude +import GHC.Utils.Binary +import Control.DeepSeq + +import qualified Data.IntSet as IntSet + +newtype EnumSet a = EnumSet IntSet.IntSet + deriving (Semigroup, Monoid, NFData) + +member :: Enum a => a -> EnumSet a -> Bool +member x (EnumSet s) = IntSet.member (fromEnum x) s + +insert :: Enum a => a -> EnumSet a -> EnumSet a +insert x (EnumSet s) = EnumSet $ IntSet.insert (fromEnum x) s + +delete :: Enum a => a -> EnumSet a -> EnumSet a +delete x (EnumSet s) = EnumSet $ IntSet.delete (fromEnum x) s + +toList :: Enum a => EnumSet a -> [a] +toList (EnumSet s) = map toEnum $ IntSet.toList s + +fromList :: Enum a => [a] -> EnumSet a +fromList = EnumSet . IntSet.fromList . map fromEnum + +empty :: EnumSet a +empty = EnumSet IntSet.empty + +difference :: EnumSet a -> EnumSet a -> EnumSet a +difference (EnumSet a) (EnumSet b) = EnumSet (IntSet.difference a b) + +-- | Represents the 'EnumSet' as a bit set. +-- +-- Assumes that all elements are non-negative. +-- +-- This is only efficient for values that are sufficiently small, +-- for example in the lower hundreds. +instance Binary (EnumSet a) where + put_ bh = put_ bh . enumSetToBitArray + get bh = bitArrayToEnumSet <$> get bh + +-- TODO: Using 'Natural' instead of 'Integer' should be slightly more efficient +-- but we don't currently have a 'Binary' instance for 'Natural'. +type BitArray = Integer + +enumSetToBitArray :: EnumSet a -> BitArray +enumSetToBitArray (EnumSet int_set) = + IntSet.foldl' setBit 0 int_set + +bitArrayToEnumSet :: BitArray -> EnumSet a +bitArrayToEnumSet ba = EnumSet (go (popCount ba) 0 IntSet.empty) + where + go 0 _ !int_set = int_set + go n i !int_set = + if ba `testBit` i + then go (pred n) (succ i) (IntSet.insert i int_set) + else go n (succ i) int_set diff --git a/GHC/Data/FastMutInt.hs b/GHC/Data/FastMutInt.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/FastMutInt.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Unboxed mutable Ints + +module GHC.Data.FastMutInt( + FastMutInt, newFastMutInt, + readFastMutInt, writeFastMutInt, + atomicFetchAddFastMut + ) where + +import GHC.Prelude.Basic + +import GHC.Base + +data FastMutInt = FastMutInt !(MutableByteArray# RealWorld) + +newFastMutInt :: Int -> IO FastMutInt +newFastMutInt n = do + x <- create + writeFastMutInt x n + return x + where + !(I# size) = finiteBitSize (0 :: Int) `unsafeShiftR` 3 + create = IO $ \s -> + case newByteArray# size s of + (# s, arr #) -> (# s, FastMutInt arr #) + +readFastMutInt :: FastMutInt -> IO Int +readFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of + (# s, i #) -> (# s, I# i #) + +writeFastMutInt :: FastMutInt -> Int -> IO () +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> + case writeIntArray# arr 0# i s of + s -> (# s, () #) + +atomicFetchAddFastMut :: FastMutInt -> Int -> IO Int +atomicFetchAddFastMut (FastMutInt arr) (I# i) = IO $ \s -> + case fetchAddIntArray# arr 0# i s of + (# s, n #) -> (# s, I# n #) diff --git a/GHC/Data/FastString.hs b/GHC/Data/FastString.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/FastString.hs @@ -0,0 +1,716 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) +{-# OPTIONS_GHC -fno-unoptimized-core-for-interpreter #-} +#endif +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected +-- +-- Also important, if you load this module into GHCi then the data representation of +-- FastString has to match that of the host compiler due to the shared FastString +-- table. Otherwise you will get segfaults when the table is consulted and the fields +-- from the FastString are in an incorrect order. + +-- | +-- There are two principal string types used internally by GHC: +-- +-- ['FastString'] +-- +-- * A compact, hash-consed, representation of character strings. +-- * Generated by 'fsLit'. +-- * You can get a 'GHC.Types.Unique.Unique' from them. +-- * Equality test is O(1) (it uses the Unique). +-- * Comparison is O(1) or O(n): +-- * O(n) but deterministic with lexical comparison (`lexicalCompareFS`) +-- * O(1) but non-deterministic with Unique comparison (`uniqCompareFS`) +-- * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ftext'. +-- +-- ['PtrString'] +-- +-- * Pointer and size of a Latin-1 encoded string. +-- * Practically no operations. +-- * Outputting them is fast. +-- * Generated by 'mkPtrString#'. +-- * Length of string literals (mkPtrString# "abc"#) is computed statically +-- * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ptext' +-- * Requires manual memory management. +-- Improper use may lead to memory leaks or dangling pointers. +-- * It assumes Latin-1 as the encoding, therefore it cannot represent +-- arbitrary Unicode strings. +-- +-- Use 'PtrString' unless you want the facilities of 'FastString'. +module GHC.Data.FastString + ( + -- * ByteString + bytesFS, + fastStringToByteString, + mkFastStringByteString, + fastZStringToByteString, + unsafeMkByteString, + + -- * ShortByteString + fastStringToShortByteString, + mkFastStringShortByteString, + + -- * ShortText + fastStringToShortText, + + -- * FastZString + FastZString, + hPutFZS, + zString, + zStringTakeN, + lengthFZS, + + -- * FastStrings + FastString(..), -- not abstract, for now. + NonDetFastString (..), + LexicalFastString (..), + + -- ** Construction + fsLit, + mkFastString, + mkFastStringBytes, + mkFastStringByteList, + mkFastString#, + + -- ** Deconstruction + unpackFS, -- :: FastString -> String + unconsFS, -- :: FastString -> Maybe (Char, FastString) + + -- ** Encoding + zEncodeFS, + + -- ** Operations + uniqueOfFS, + lengthFS, + nullFS, + appendFS, + concatFS, + consFS, + nilFS, + lexicalCompareFS, + uniqCompareFS, + + -- ** Outputting + hPutFS, + + -- ** Internal + getFastStringTable, + getFastStringZEncCounter, + + -- * PtrStrings + PtrString (..), + + -- ** Construction + mkPtrString#, + + -- ** Deconstruction + unpackPtrString, + unpackPtrStringTakeN, + + -- ** Operations + lengthPS + ) where + +import GHC.Prelude.Basic as Prelude + +import GHC.Utils.Encoding +import GHC.Utils.IO.Unsafe +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc +import GHC.Data.FastMutInt + +import Control.Concurrent.MVar +import Control.DeepSeq +import Control.Monad +import Data.ByteString (ByteString) +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString.Short as SBS +import GHC.Data.ShortText (ShortText(..)) +import Foreign.C +import System.IO +import Data.Data +import Data.IORef +import Data.Semigroup as Semi + +import Foreign + +import GHC.Conc.Sync (sharedCAF) + +import GHC.Exts +import GHC.IO + +-- | Gives the Modified UTF-8 encoded bytes corresponding to a 'FastString' +bytesFS, fastStringToByteString :: FastString -> ByteString +{-# INLINE[1] bytesFS #-} +bytesFS f = SBS.fromShort $ fs_sbs f + +{-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-} +fastStringToByteString = bytesFS + +fastStringToShortByteString :: FastString -> ShortByteString +fastStringToShortByteString = fs_sbs + +fastStringToShortText :: FastString -> ShortText +fastStringToShortText = ShortText . fs_sbs + +fastZStringToByteString :: FastZString -> ByteString +fastZStringToByteString (FastZString bs) = bs + +-- This will drop information if any character > '\xFF' +unsafeMkByteString :: String -> ByteString +unsafeMkByteString = BSC.pack + +hashFastString :: FastString -> Int +hashFastString fs = hashStr $ fs_sbs fs + +-- ----------------------------------------------------------------------------- + +newtype FastZString = FastZString ByteString + deriving NFData + +hPutFZS :: Handle -> FastZString -> IO () +hPutFZS handle (FastZString bs) = BS.hPut handle bs + +zString :: FastZString -> String +zString (FastZString bs) = + inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen + +-- | @zStringTakeN n = 'take' n . 'zString'@ +-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\), +-- where \(l\) is the length of the 'FastZString'. +zStringTakeN :: Int -> FastZString -> String +zStringTakeN n (FastZString bs) = + inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(cp, len) -> + peekCAStringLen (cp, min n len) + +lengthFZS :: FastZString -> Int +lengthFZS (FastZString bs) = BS.length bs + +mkFastZStringString :: String -> FastZString +mkFastZStringString str = FastZString (BSC.pack str) + +-- ----------------------------------------------------------------------------- + +{-| A 'FastString' is a Modified UTF-8 encoded string together with a unique ID. +All 'FastString's are stored in a global hashtable to support fast O(1) +comparison. + +It is also associated with a lazy reference to the Z-encoding +of this string which is used by the compiler internally. +-} +data FastString = FastString { + uniq :: {-# UNPACK #-} !Int, -- unique id + n_chars :: {-# UNPACK #-} !Int, -- number of chars + fs_sbs :: {-# UNPACK #-} !ShortByteString, + fs_zenc :: FastZString + -- ^ Lazily computed Z-encoding of this string. See Note [Z-Encoding] in + -- GHC.Utils.Encoding. + -- + -- Since 'FastString's are globally memoized this is computed at most + -- once for any given string. + } + +instance Eq FastString where + f1 == f2 = uniq f1 == uniq f2 + +-- We don't provide any "Ord FastString" instance to force you to think about +-- which ordering you want: +-- * lexical: deterministic, O(n). Cf lexicalCompareFS and LexicalFastString. +-- * by unique: non-deterministic, O(1). Cf uniqCompareFS and NonDetFastString. + +instance IsString FastString where + fromString = fsLit + +instance Semi.Semigroup FastString where + (<>) = appendFS + +instance Monoid FastString where + mempty = nilFS + mappend = (Semi.<>) + mconcat = concatFS + +instance Show FastString where + show fs = show (unpackFS fs) + +instance Data FastString where + -- don't traverse? + toConstr _ = abstractConstr "FastString" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "FastString" + +instance NFData FastString where + rnf fs = seq fs () + +-- | Compare FastString lexically +-- +-- If you don't care about the lexical ordering, use `uniqCompareFS` instead. +lexicalCompareFS :: FastString -> FastString -> Ordering +lexicalCompareFS fs1 fs2 = + if uniq fs1 == uniq fs2 then EQ else + utf8CompareShortByteString (fs_sbs fs1) (fs_sbs fs2) + -- perform a lexical comparison taking into account the Modified UTF-8 + -- encoding we use (cf #18562) + +-- | Compare FastString by their Unique (not lexically). +-- +-- Much cheaper than `lexicalCompareFS` but non-deterministic! +uniqCompareFS :: FastString -> FastString -> Ordering +uniqCompareFS fs1 fs2 = compare (uniq fs1) (uniq fs2) + +-- | Non-deterministic FastString +-- +-- This is a simple FastString wrapper with an Ord instance using +-- `uniqCompareFS` (i.e. which compares FastStrings on their Uniques). Hence it +-- is not deterministic from one run to the other. +newtype NonDetFastString + = NonDetFastString FastString + deriving newtype (Eq, Show) + deriving stock Data + +instance Ord NonDetFastString where + compare (NonDetFastString fs1) (NonDetFastString fs2) = uniqCompareFS fs1 fs2 + +-- | Lexical FastString +-- +-- This is a simple FastString wrapper with an Ord instance using +-- `lexicalCompareFS` (i.e. which compares FastStrings on their String +-- representation). Hence it is deterministic from one run to the other. +newtype LexicalFastString + = LexicalFastString { getLexicalFastString :: FastString } + deriving newtype (Eq, Show) + deriving stock Data + +instance Ord LexicalFastString where + compare (LexicalFastString fs1) (LexicalFastString fs2) = lexicalCompareFS fs1 fs2 + +instance NFData LexicalFastString where + rnf (LexicalFastString f) = rnf f + +-- ----------------------------------------------------------------------------- +-- Construction + +{- +Internally, the compiler will maintain a fast string symbol table, providing +sharing and fast comparison. Creation of new @FastString@s then covertly does a +lookup, re-using the @FastString@ if there was a hit. + +The design of the FastString hash table allows for lockless concurrent reads +and updates to multiple buckets with low synchronization overhead. + +See Note [Updating the FastString table] on how it's updated. +-} +data FastStringTable = FastStringTable + {-# UNPACK #-} !FastMutInt + -- ^ The unique ID counter shared with all buckets + -- + -- We unpack the 'FastMutInt' counter as it is always consumed strictly. + {-# NOUNPACK #-} !FastMutInt + -- ^ Number of computed z-encodings for all buckets. + -- + -- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk + -- in 'mkFastStringWith' and needs to be boxed any way. + -- If this is unpacked, then we box this single 'FastMutInt' once for each + -- allocated FastString. + (Array# (IORef FastStringTableSegment)) -- ^ concurrent segments + +data FastStringTableSegment = FastStringTableSegment + {-# UNPACK #-} !(MVar ()) -- the lock for write in each segment + {-# UNPACK #-} !FastMutInt -- the number of elements + (MutableArray# RealWorld [FastString]) -- buckets in this segment + +{- +Following parameters are determined based on: + +* Benchmark based on testsuite/tests/utils/should_run/T14854.hs +* Stats of @echo :browse | ghc --interactive -dfaststring-stats >/dev/null@: + on 2018-10-24, we have 13920 entries. +-} +segmentBits, numSegments, segmentMask, initialNumBuckets :: Int +segmentBits = 8 +numSegments = 256 -- bit segmentBits +segmentMask = 0xff -- bit segmentBits - 1 +initialNumBuckets = 64 + +hashToSegment# :: Int# -> Int# +hashToSegment# hash# = hash# `andI#` segmentMask# + where + !(I# segmentMask#) = segmentMask + +hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int# +hashToIndex# buckets# hash# = + (hash# `uncheckedIShiftRL#` segmentBits#) `remInt#` size# + where + !(I# segmentBits#) = segmentBits + size# = sizeofMutableArray# buckets# + +maybeResizeSegment :: IORef FastStringTableSegment -> IO FastStringTableSegment +maybeResizeSegment segmentRef = do + segment@(FastStringTableSegment lock counter old#) <- readIORef segmentRef + let oldSize# = sizeofMutableArray# old# + newSize# = oldSize# *# 2# + (I# n#) <- readFastMutInt counter + if isTrue# (n# <# newSize#) -- maximum load of 1 + then return segment + else do + resizedSegment@(FastStringTableSegment _ _ new#) <- IO $ \s1# -> + case newArray# newSize# [] s1# of + (# s2#, arr# #) -> (# s2#, FastStringTableSegment lock counter arr# #) + forM_ [0 .. (I# oldSize#) - 1] $ \(I# i#) -> do + fsList <- IO $ readArray# old# i# + forM_ fsList $ \fs -> do + let -- Shall we store in hash value in FastString instead? + !(I# hash#) = hashFastString fs + idx# = hashToIndex# new# hash# + IO $ \s1# -> + case readArray# new# idx# s1# of + (# s2#, bucket #) -> case writeArray# new# idx# (fs: bucket) s2# of + s3# -> (# s3#, () #) + writeIORef segmentRef resizedSegment + return resizedSegment + +{-# NOINLINE stringTable #-} +stringTable :: FastStringTable +stringTable = unsafePerformIO $ do + let !(I# numSegments#) = numSegments + !(I# initialNumBuckets#) = initialNumBuckets + loop a# i# s1# + | isTrue# (i# ==# numSegments#) = s1# + | otherwise = case newMVar () `unIO` s1# of + (# s2#, lock #) -> case newFastMutInt 0 `unIO` s2# of + (# s3#, counter #) -> case newArray# initialNumBuckets# [] s3# of + (# s4#, buckets# #) -> case newIORef + (FastStringTableSegment lock counter buckets#) `unIO` s4# of + (# s5#, segment #) -> case writeArray# a# i# segment s5# of + s6# -> loop a# (i# +# 1#) s6# + uid <- newFastMutInt 603979776 -- ord '$' * 0x01000000 + n_zencs <- newFastMutInt 0 + tab <- IO $ \s1# -> + case newArray# numSegments# (panic "string_table") s1# of + (# s2#, arr# #) -> case loop arr# 0# s2# of + s3# -> case unsafeFreezeArray# arr# s3# of + (# s4#, segments# #) -> + (# s4#, FastStringTable uid n_zencs segments# #) + + -- use the support wired into the RTS to share this CAF among all images of + -- libHSghc + sharedCAF tab getOrSetLibHSghcFastStringTable + +-- from the 9.3 RTS; the previous RTS before might not have this symbol. The +-- right way to do this however would be to define some HAVE_FAST_STRING_TABLE +-- or similar rather than use (odd parity) development versions. +foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" + getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) + +{- + +We include the FastString table in the `sharedCAF` mechanism because we'd like +FastStrings created by a Core plugin to have the same uniques as corresponding +strings created by the host compiler itself. For example, this allows plugins +to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or +even re-invoke the parser. + +In particular, the following little sanity test was failing in a plugin +prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not +be looked up /by the plugin/. + + let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" + putMsgS $ showSDoc dflags $ ppr $ + lookupGRE (mg_rdr_env guts) (LookupRdrName rdrName AllRelevantGREs) + +`mkTcOcc` involves the lookup (or creation) of a FastString. Since the +plugin's FastString.string_table is empty, constructing the RdrName also +allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These +uniques are almost certainly unequal to the ones that the host compiler +originally assigned to those FastStrings. Thus the lookup fails since the +domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's +unique. + +Maintaining synchronization of the two instances of this global is rather +difficult because of the uses of `unsafePerformIO` in this module. Not +synchronizing them risks breaking the rather major invariant that two +FastStrings with the same unique have the same string. Thus we use the +lower-level `sharedCAF` mechanism that relies on Globals.c. + +-} + +mkFastString# :: Addr# -> FastString +{-# INLINE mkFastString# #-} +mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) + where ptr = Ptr a# + +{- Note [Updating the FastString table] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use a concurrent hashtable which contains multiple segments, each hash value +always maps to the same segment. Read is lock-free, write to the a segment +should acquire a lock for that segment to avoid race condition, writes to +different segments are independent. + +The procedure goes like this: + +1. Find out which segment to operate on based on the hash value +2. Read the relevant bucket and perform a look up of the string. +3. If it exists, return it. +4. Otherwise grab a unique ID, create a new FastString and atomically attempt + to update the relevant segment with this FastString: + + * Resize the segment by doubling the number of buckets when the number of + FastStrings in this segment grows beyond the threshold. + * Double check that the string is not in the bucket. Another thread may have + inserted it while we were creating our string. + * Return the existing FastString if it exists. The one we preemptively + created will get GCed. + * Otherwise, insert and return the string we created. +-} + +mkFastStringWith + :: (Int -> FastMutInt-> IO FastString) -> ShortByteString -> IO FastString +mkFastStringWith mk_fs sbs = do + FastStringTableSegment lock _ buckets# <- readIORef segmentRef + let idx# = hashToIndex# buckets# hash# + bucket <- IO $ readArray# buckets# idx# + case bucket_match bucket sbs of + Just found -> return found + Nothing -> do + -- The withMVar below is not dupable. It can lead to deadlock if it is + -- only run partially and putMVar is not called after takeMVar. + noDuplicate + n <- get_uid + new_fs <- mk_fs n n_zencs + withMVar lock $ \_ -> insert new_fs + where + !(FastStringTable uid n_zencs segments#) = stringTable + get_uid = atomicFetchAddFastMut uid 1 + + !(I# hash#) = hashStr sbs + (# segmentRef #) = indexArray# segments# (hashToSegment# hash#) + insert fs = do + FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef + let idx# = hashToIndex# buckets# hash# + bucket <- IO $ readArray# buckets# idx# + case bucket_match bucket sbs of + -- The FastString was added by another thread after previous read and + -- before we acquired the write lock. + Just found -> return found + Nothing -> do + IO $ \s1# -> + case writeArray# buckets# idx# (fs : bucket) s1# of + s2# -> (# s2#, () #) + _ <- atomicFetchAddFastMut counter 1 + return fs + +bucket_match :: [FastString] -> ShortByteString -> Maybe FastString +bucket_match fs sbs = go fs + where go [] = Nothing + go (fs@(FastString {fs_sbs=fs_sbs}) : ls) + | fs_sbs == sbs = Just fs + | otherwise = go ls +-- bucket_match used to inline before changes to instance Eq ShortByteString +-- in bytestring-0.12, which made it slightly larger than inlining threshold. +-- Non-inlining causes a small, but measurable performance regression, so let's force it. +{-# INLINE bucket_match #-} + +mkFastStringBytes :: Ptr Word8 -> Int -> FastString +mkFastStringBytes !ptr !len = + -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is + -- idempotent. + unsafeDupablePerformIO $ do + sbs <- newSBSFromPtr ptr len + mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + +newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString +newSBSFromPtr (Ptr src#) (I# len#) = + IO $ \s -> + case newByteArray# len# s of { (# s, dst# #) -> + case copyAddrToByteArray# src# dst# 0# len# s of { s -> + case unsafeFreezeByteArray# dst# s of { (# s, ba# #) -> + (# s, SBS.SBS ba# #) }}} + +-- | Create a 'FastString' by copying an existing 'ByteString' +mkFastStringByteString :: ByteString -> FastString +mkFastStringByteString bs = + let sbs = SBS.toShort bs in + inlinePerformIO $ + mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + +-- | Create a 'FastString' from an existing 'ShortByteString' without +-- copying. +mkFastStringShortByteString :: ShortByteString -> FastString +mkFastStringShortByteString sbs = + inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + +-- | Creates a UTF-8 encoded 'FastString' from a 'String' +mkFastString :: String -> FastString +{-# NOINLINE[1] mkFastString #-} +mkFastString str = + inlinePerformIO $ do + let !sbs = utf8EncodeShortByteString str + mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + +-- The following rule is used to avoid polluting the non-reclaimable FastString +-- table with transient strings when we only want their encoding. +{-# RULES +"bytesFS/mkFastString" forall x. bytesFS (mkFastString x) = utf8EncodeByteString x #-} + +-- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ +mkFastStringByteList :: [Word8] -> FastString +mkFastStringByteList str = mkFastStringShortByteString (SBS.pack str) + +-- | Creates a (lazy) Z-encoded 'FastString' from a 'ShortByteString' and +-- account the number of forced z-strings into the passed 'FastMutInt'. +mkZFastString :: FastMutInt -> ShortByteString -> FastZString +mkZFastString n_zencs sbs = unsafePerformIO $ do + _ <- atomicFetchAddFastMut n_zencs 1 + return $ mkFastZStringString (zEncodeString (utf8DecodeShortByteString sbs)) + +mkNewFastStringShortByteString :: ShortByteString -> Int + -> FastMutInt -> IO FastString +mkNewFastStringShortByteString sbs uid n_zencs = do + let zstr = mkZFastString n_zencs sbs + chars = utf8CountCharsShortByteString sbs + return (FastString uid chars sbs zstr) + +hashStr :: ShortByteString -> Int + -- produce a hash value between 0 & m (inclusive) +hashStr sbs@(SBS.SBS ba#) = loop 0# 0# + where + !(I# len#) = SBS.length sbs + loop h n = + if isTrue# (n ==# len#) then + I# h + else + let + -- DO NOT move this let binding! indexCharOffAddr# reads from the + -- pointer so we need to evaluate this based on the length check + -- above. Not doing this right caused #17909. + !c = int8ToInt# (indexInt8Array# ba# n) + !h2 = (h *# 16777619#) `xorI#` c + in + loop h2 (n +# 1#) + +-- ----------------------------------------------------------------------------- +-- Operations + +-- | Returns the length of the 'FastString' in characters +lengthFS :: FastString -> Int +lengthFS fs = n_chars fs + +-- | Returns @True@ if the 'FastString' is empty +nullFS :: FastString -> Bool +nullFS fs = SBS.null $ fs_sbs fs + +-- | Lazily unpacks and decodes the FastString +unpackFS :: FastString -> String +unpackFS fs = utf8DecodeShortByteString $ fs_sbs fs + +-- | Returns a Z-encoded version of a 'FastString'. This might be the +-- original, if it was already Z-encoded. The first time this +-- function is applied to a particular 'FastString', the results are +-- memoized. +-- +zEncodeFS :: FastString -> FastZString +zEncodeFS fs = fs_zenc fs + +appendFS :: FastString -> FastString -> FastString +appendFS fs1 fs2 = mkFastStringShortByteString + $ (Semi.<>) (fs_sbs fs1) (fs_sbs fs2) + +concatFS :: [FastString] -> FastString +concatFS = mkFastStringShortByteString . mconcat . map fs_sbs + +consFS :: Char -> FastString -> FastString +consFS c fs = mkFastString (c : unpackFS fs) + +unconsFS :: FastString -> Maybe (Char, FastString) +unconsFS fs = + case unpackFS fs of + [] -> Nothing + (chr : str) -> Just (chr, mkFastString str) + +uniqueOfFS :: FastString -> Int +uniqueOfFS fs = uniq fs + +nilFS :: FastString +nilFS = mkFastString "" + +-- ----------------------------------------------------------------------------- +-- Stats + +getFastStringTable :: IO [[[FastString]]] +getFastStringTable = + forM [0 .. numSegments - 1] $ \(I# i#) -> do + let (# segmentRef #) = indexArray# segments# i# + FastStringTableSegment _ _ buckets# <- readIORef segmentRef + let bucketSize = I# (sizeofMutableArray# buckets#) + forM [0 .. bucketSize - 1] $ \(I# j#) -> + IO $ readArray# buckets# j# + where + !(FastStringTable _ _ segments#) = stringTable + +getFastStringZEncCounter :: IO Int +getFastStringZEncCounter = readFastMutInt n_zencs + where + !(FastStringTable _ n_zencs _) = stringTable + +-- ----------------------------------------------------------------------------- +-- Outputting 'FastString's + +-- |Outputs a 'FastString' with /no decoding at all/, that is, you +-- get the actual bytes in the 'FastString' written to the 'Handle'. +hPutFS :: Handle -> FastString -> IO () +hPutFS handle fs = BS.hPut handle $ bytesFS fs + +-- ToDo: we'll probably want an hPutFSLocal, or something, to output +-- in the current locale's encoding (for error messages and suchlike). + +-- ----------------------------------------------------------------------------- +-- PtrStrings, here for convenience only. + +-- | A 'PtrString' is a pointer to some array of Latin-1 encoded chars. +data PtrString = PtrString !(Ptr Word8) !Int + +-- | Wrap an unboxed address into a 'PtrString'. +mkPtrString# :: Addr# -> PtrString +{-# INLINE mkPtrString# #-} +mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) + +-- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. +-- This does not free the memory associated with 'PtrString'. +unpackPtrString :: PtrString -> String +unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n# + +-- | @unpackPtrStringTakeN n = 'take' n . 'unpackPtrString'@ +-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\), +-- where \(l\) is the length of the 'PtrString'. +unpackPtrStringTakeN :: Int -> PtrString -> String +unpackPtrStringTakeN n (PtrString (Ptr p#) len) = + case min n len of + I# n# -> unpackNBytes# p# n# + +-- | Return the length of a 'PtrString' +lengthPS :: PtrString -> Int +lengthPS (PtrString _ n) = n + +-- ----------------------------------------------------------------------------- +-- under the carpet + + +ptrStrLength :: Ptr Word8 -> Int +{-# INLINE ptrStrLength #-} +ptrStrLength (Ptr a) = I# (cstringLength# a) + +{-# NOINLINE fsLit #-} +fsLit :: String -> FastString +fsLit x = mkFastString x + +{-# RULES "fslit" + forall x . fsLit (unpackCString# x) = mkFastString# x #-} diff --git a/GHC/Data/FastString/Env.hs b/GHC/Data/FastString/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/FastString/Env.hs @@ -0,0 +1,113 @@ +{- +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +-} + +-- | FastStringEnv: FastString environments +module GHC.Data.FastString.Env ( + -- * FastString environments (maps) + FastStringEnv, + + -- ** Manipulating these environments + mkFsEnv, + emptyFsEnv, unitFsEnv, + extendFsEnv_C, extendFsEnv_Acc, extendFsEnv, + extendFsEnvList, extendFsEnvList_C, + filterFsEnv, + plusFsEnv, plusFsEnv_C, alterFsEnv, + lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv, + elemFsEnv, mapFsEnv, strictMapFsEnv, mapMaybeFsEnv, + nonDetFoldFsEnv, + + -- * Deterministic FastString environments (maps) + DFastStringEnv, + + -- ** Manipulating these environments + mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv + ) where + +import GHC.Prelude + +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Data.Maybe +import GHC.Data.FastString + + +-- | A non-deterministic set of FastStrings. +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why it's not +-- deterministic and why it matters. Use DFastStringEnv if the set eventually +-- gets converted into a list or folded over in a way where the order +-- changes the generated code. +type FastStringEnv a = UniqFM FastString a -- Domain is FastString + +emptyFsEnv :: FastStringEnv a +mkFsEnv :: [(FastString,a)] -> FastStringEnv a +alterFsEnv :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a +extendFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a +extendFsEnv_Acc :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b +extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a +plusFsEnv :: FastStringEnv a -> FastStringEnv a -> FastStringEnv a +plusFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastStringEnv a -> FastStringEnv a +extendFsEnvList :: FastStringEnv a -> [(FastString,a)] -> FastStringEnv a +extendFsEnvList_C :: (a->a->a) -> FastStringEnv a -> [(FastString,a)] -> FastStringEnv a +delFromFsEnv :: FastStringEnv a -> FastString -> FastStringEnv a +delListFromFsEnv :: FastStringEnv a -> [FastString] -> FastStringEnv a +elemFsEnv :: FastString -> FastStringEnv a -> Bool +unitFsEnv :: FastString -> a -> FastStringEnv a +lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a +lookupFsEnv_NF :: FastStringEnv a -> FastString -> a +filterFsEnv :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt +mapFsEnv :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 +mapMaybeFsEnv :: (elt1 -> Maybe elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 + +emptyFsEnv = emptyUFM +unitFsEnv x y = unitUFM x y +extendFsEnv x y z = addToUFM x y z +extendFsEnvList x l = addListToUFM x l +lookupFsEnv x y = lookupUFM x y +alterFsEnv = alterUFM +mkFsEnv l = listToUFM l +elemFsEnv x y = elemUFM x y +plusFsEnv x y = plusUFM x y +plusFsEnv_C f x y = plusUFM_C f x y +extendFsEnv_C f x y z = addToUFM_C f x y z +mapFsEnv f x = mapUFM f x +extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b +extendFsEnvList_C x y z = addListToUFM_C x y z +delFromFsEnv x y = delFromUFM x y +delListFromFsEnv x y = delListFromUFM x y +filterFsEnv x y = filterUFM x y +mapMaybeFsEnv f x = mapMaybeUFM f x + +lookupFsEnv_NF env n = expectJust (lookupFsEnv env n) + +strictMapFsEnv :: (a -> b) -> FastStringEnv a -> FastStringEnv b +strictMapFsEnv = strictMapUFM + +-- | Fold over a 'FastStringEnv'. +-- +-- Non-deterministic, unless the folding function is commutative +-- (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@). +nonDetFoldFsEnv :: (a -> b -> b) -> b -> FastStringEnv a -> b +nonDetFoldFsEnv = nonDetFoldUFM + +-- Deterministic FastStringEnv +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need +-- DFastStringEnv. + +type DFastStringEnv a = UniqDFM FastString a -- Domain is FastString + +emptyDFsEnv :: DFastStringEnv a +emptyDFsEnv = emptyUDFM + +dFsEnvElts :: DFastStringEnv a -> [a] +dFsEnvElts = eltsUDFM + +mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a +mkDFsEnv l = listToUDFM l + +lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a +lookupDFsEnv = lookupUDFM diff --git a/GHC/Data/FiniteMap.hs b/GHC/Data/FiniteMap.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/FiniteMap.hs @@ -0,0 +1,31 @@ +-- Some extra functions to extend Data.Map + +module GHC.Data.FiniteMap ( + insertList, + insertListWith, + deleteList, + foldRight, foldRightWithKey + ) where + +import GHC.Prelude + +import Data.Map (Map) +import qualified Data.Map as Map + +insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt +insertList xs m = foldl' (\m (k, v) -> Map.insert k v m) m xs + +insertListWith :: Ord key + => (elt -> elt -> elt) + -> [(key,elt)] + -> Map key elt + -> Map key elt +insertListWith f xs m0 = foldl' (\m (k, v) -> Map.insertWith f k v m) m0 xs + +deleteList :: Ord key => [key] -> Map key elt -> Map key elt +deleteList ks m = foldl' (flip Map.delete) m ks + +foldRight :: (elt -> a -> a) -> a -> Map key elt -> a +foldRight = Map.foldr +foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a +foldRightWithKey = Map.foldrWithKey diff --git a/GHC/Data/FlatBag.hs b/GHC/Data/FlatBag.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/FlatBag.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE UnboxedTuples #-} +module GHC.Data.FlatBag + ( FlatBag(EmptyFlatBag, UnitFlatBag, TupleFlatBag) + , emptyFlatBag + , unitFlatBag + , sizeFlatBag + , elemsFlatBag + , mappendFlatBag + -- * Construction + , fromList + , fromSmallArray + ) where + +import GHC.Prelude + +import Control.DeepSeq + +import GHC.Data.SmallArray + +-- | Store elements in a flattened representation. +-- +-- A 'FlatBag' is a data structure that stores an ordered list of elements +-- in a flat structure, avoiding the overhead of a linked list. +-- Use this data structure, if the code requires the following properties: +-- +-- * Elements are stored in a long-lived object, and benefit from a flattened +-- representation. +-- * The 'FlatBag' will be traversed but not extended or filtered. +-- * The number of elements should be known. +-- * Sharing of the empty case improves memory behaviour. +-- +-- A 'FlagBag' aims to have as little overhead as possible to store its elements. +-- To achieve that, it distinguishes between the empty case, singleton, tuple +-- and general case. +-- Thus, we only pay for the additional three words of an 'Array' if we have at least +-- three elements. +data FlatBag a + = EmptyFlatBag + | UnitFlatBag !a + | TupleFlatBag !a !a + | FlatBag {-# UNPACK #-} !(SmallArray a) + +instance Functor FlatBag where + fmap _ EmptyFlatBag = EmptyFlatBag + fmap f (UnitFlatBag a) = UnitFlatBag $ f a + fmap f (TupleFlatBag a b) = TupleFlatBag (f a) (f b) + fmap f (FlatBag e) = FlatBag $ mapSmallArray f e + +instance Foldable FlatBag where + foldMap _ EmptyFlatBag = mempty + foldMap f (UnitFlatBag a) = f a + foldMap f (TupleFlatBag a b) = f a `mappend` f b + foldMap f (FlatBag arr) = foldMapSmallArray f arr + + length = fromIntegral . sizeFlatBag + +instance Traversable FlatBag where + traverse _ EmptyFlatBag = pure EmptyFlatBag + traverse f (UnitFlatBag a) = UnitFlatBag <$> f a + traverse f (TupleFlatBag a b) = TupleFlatBag <$> f a <*> f b + traverse f fl@(FlatBag arr) = fromList (fromIntegral $ sizeofSmallArray arr) <$> traverse f (elemsFlatBag fl) + +instance NFData a => NFData (FlatBag a) where + rnf EmptyFlatBag = () + rnf (UnitFlatBag a) = rnf a + rnf (TupleFlatBag a b) = rnf a `seq` rnf b + rnf (FlatBag arr) = rnfSmallArray arr + +-- | Create an empty 'FlatBag'. +-- +-- The empty 'FlatBag' is shared over all instances. +emptyFlatBag :: FlatBag a +emptyFlatBag = EmptyFlatBag + +-- | Create a singleton 'FlatBag'. +unitFlatBag :: a -> FlatBag a +unitFlatBag = UnitFlatBag + +-- | Calculate the size of +sizeFlatBag :: FlatBag a -> Word +sizeFlatBag EmptyFlatBag = 0 +sizeFlatBag UnitFlatBag{} = 1 +sizeFlatBag TupleFlatBag{} = 2 +sizeFlatBag (FlatBag arr) = fromIntegral $ sizeofSmallArray arr + +-- | Get all elements that are stored in the 'FlatBag'. +elemsFlatBag :: FlatBag a -> [a] +elemsFlatBag EmptyFlatBag = [] +elemsFlatBag (UnitFlatBag a) = [a] +elemsFlatBag (TupleFlatBag a b) = [a, b] +elemsFlatBag (FlatBag arr) = + [indexSmallArray arr i | i <- [0 .. sizeofSmallArray arr - 1]] + +-- | Combine two 'FlatBag's. +-- +-- The new 'FlatBag' contains all elements from both 'FlatBag's. +-- +-- If one of the 'FlatBag's is empty, the old 'FlatBag' is reused. +mappendFlatBag :: FlatBag a -> FlatBag a -> FlatBag a +mappendFlatBag EmptyFlatBag b = b +mappendFlatBag a EmptyFlatBag = a +mappendFlatBag (UnitFlatBag a) (UnitFlatBag b) = TupleFlatBag a b +mappendFlatBag a b = + fromList (sizeFlatBag a + sizeFlatBag b) + (elemsFlatBag a ++ elemsFlatBag b) + +-- | Store the list in a flattened memory representation, avoiding the memory overhead +-- of a linked list. +-- +-- The size 'n' needs to be smaller or equal to the length of the list. +-- If it is smaller than the length of the list, overflowing elements are +-- discarded. It is undefined behaviour to set 'n' to be bigger than the +-- length of the list. +fromList :: Word -> [a] -> FlatBag a +fromList n elts = + case elts of + [] -> EmptyFlatBag + [a] -> UnitFlatBag a + [a, b] -> TupleFlatBag a b + xs -> + FlatBag (listToArray (fromIntegral n) fst snd (zip [0..] xs)) + +-- | Convert a 'SizedSeq' into its flattened representation. +-- A 'FlatBag a' is more memory efficient than '[a]', if no further modification +-- is necessary. +fromSmallArray :: SmallArray a -> FlatBag a +fromSmallArray s = case sizeofSmallArray s of + 0 -> EmptyFlatBag + 1 -> UnitFlatBag (indexSmallArray s 0) + 2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1) + _ -> FlatBag s + diff --git a/GHC/Data/Graph/Base.hs b/GHC/Data/Graph/Base.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Base.hs @@ -0,0 +1,107 @@ + +-- | Types for the general graph colorer. +module GHC.Data.Graph.Base ( + Triv, + Graph (..), + initGraph, + graphMapModify, + + Node (..), newNode, +) + + +where + +import GHC.Prelude + +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + + +-- | A fn to check if a node is trivially colorable +-- For graphs who's color classes are disjoint then a node is 'trivially colorable' +-- when it has less neighbors and exclusions than available colors for that node. +-- +-- For graph's who's color classes overlap, ie some colors alias other colors, then +-- this can be a bit more tricky. There is a general way to calculate this, but +-- it's likely be too slow for use in the code. The coloring algorithm takes +-- a canned function which can be optimised by the user to be specific to the +-- specific graph being colored. +-- +-- for details, see "A Generalised Algorithm for Graph-Coloring Register Allocation" +-- Smith, Ramsey, Holloway - PLDI 2004. +-- +type Triv k cls color + = cls -- the class of the node we're trying to color. + -> UniqSet k -- the node's neighbors. + -> UniqSet color -- the node's exclusions. + -> Bool + + +-- | The Interference graph. +-- There used to be more fields, but they were turfed out in a previous revision. +-- maybe we'll want more later.. +-- +newtype Graph k cls color + = Graph { + -- | All active nodes in the graph. + graphMap :: UniqFM k (Node k cls color) } + + +-- | An empty graph. +initGraph :: Graph k cls color +initGraph + = Graph + { graphMap = emptyUFM } + + +-- | Modify the finite map holding the nodes in the graph. +graphMapModify + :: (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color)) + -> Graph k cls color -> Graph k cls color + +graphMapModify f graph + = graph { graphMap = f (graphMap graph) } + + + +-- | Graph nodes. +-- Represents a thing that can conflict with another thing. +-- For the register allocater the nodes represent registers. +-- +data Node k cls color + = Node { + -- | A unique identifier for this node. + nodeId :: k + + -- | The class of this node, + -- determines the set of colors that can be used. + , nodeClass :: cls + + -- | The color of this node, if any. + , nodeColor :: Maybe color + + -- | Neighbors which must be colored differently to this node. + , nodeConflicts :: UniqSet k + + -- | Colors that cannot be used by this node. + , nodeExclusions :: UniqSet color + + -- | Colors that this node would prefer to be, in descending order. + , nodePreference :: [color] + + -- | Neighbors that this node would like to be colored the same as. + , nodeCoalesce :: UniqSet k } + + +-- | An empty node. +newNode :: k -> cls -> Node k cls color +newNode k cls + = Node + { nodeId = k + , nodeClass = cls + , nodeColor = Nothing + , nodeConflicts = emptyUniqSet + , nodeExclusions = emptyUniqSet + , nodePreference = [] + , nodeCoalesce = emptyUniqSet } diff --git a/GHC/Data/Graph/Collapse.hs b/GHC/Data/Graph/Collapse.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Collapse.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Data.Graph.Collapse + ( PureSupernode(..) + , Supernode(..) + , collapseInductiveGraph + , VizCollapseMonad(..) + , NullCollapseViz(..) + , runNullCollapse + , MonadUniqDSM(..) + ) +where + +import GHC.Prelude + +import Control.Exception +import Control.Monad +import Data.List (delete, union, insert, intersect) +import Data.Semigroup + +import GHC.Cmm.Dataflow.Label +import GHC.Data.Graph.Inductive.Graph +import GHC.Types.Unique.DSM +import GHC.Utils.Panic hiding (assert) + + +{-| +Module : GHC.Data.Graph.Collapse +Description : Implement the "collapsing" algorithm Hecht and Ullman + +A control-flow graph is reducible if and only if it is collapsible +according to the definition of Hecht and Ullman (1972). This module +implements the collapsing algorithm of Hecht and Ullman, and if it +encounters a graph that is not collapsible, it splits nodes until the +graph is fully collapsed. It then reports what nodes (if any) had to +be split in order to collapse the graph. The information is used +upstream to node-split Cmm graphs. + +The module uses the inductive graph representation cloned from the +Functional Graph Library (Hackage package `fgl`, modules +`GHC.Data.Graph.Inductive.*`.) + +-} + +-- Full reference to paper: Matthew S. Hecht and Jeffrey D. Ullman +-- (1972). Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202. +-- https://doi.org/10.1137/0201014 + + +------------------ Graph-splitting monad ----------------------- + +-- | If you want to visualize the graph-collapsing algorithm, create +-- an instance of monad `VizCollapseMonad`. Each step in the +-- algorithm is announced to the monad as a side effect. If you don't +-- care about visualization, you would use the `NullCollapseViz` +-- monad, in which these operations are no-ops. + +class (MonadUniqDSM m, Graph gr, Supernode s m) => VizCollapseMonad m gr s where + consumeByInGraph :: Node -> Node -> gr s () -> m () + splitGraphAt :: gr s () -> LNode s -> m () + finalGraph :: gr s () -> m () + +-- | The identity monad as a `VizCollapseMonad`. Use this monad when +-- you want efficiency in graph collapse. +newtype NullCollapseViz a = NullCollapseViz { unNCV :: UniqDSM a } + deriving (Functor, Applicative, Monad, MonadGetUnique) + +instance MonadUniqDSM NullCollapseViz where + liftUniqDSM = NullCollapseViz + +instance (Graph gr, Supernode s NullCollapseViz) => + VizCollapseMonad NullCollapseViz gr s where + consumeByInGraph _ _ _ = return () + splitGraphAt _ _ = return () + finalGraph _ = return () + +runNullCollapse :: NullCollapseViz a -> UniqDSM a +runNullCollapse = unNCV + + +------------------ Utility functions on graphs ----------------------- + + +-- | Tell if a `Node` has a single predecessor. +singlePred :: Graph gr => gr a b -> Node -> Bool +singlePred gr n + | ([_], _, _, _) <- context gr n = True + | otherwise = False + +-- | Use this function to extract information about a `Node` that you +-- know is in a `Graph`. It's like `match` from `Graph`, but it must +-- succeed. +forceMatch :: (Graph gr) + => Node -> gr s b -> (Context s b, gr s b) +forceMatch node g = case match node g of (Just c, g') -> (c, g') + _ -> panicDump node g + where panicDump :: Graph gr => Node -> gr s b -> any + panicDump k _g = + panic $ "GHC.Data.Graph.Collapse failed to match node " ++ show k + +-- | Rewrite the label of a given node. +updateNode :: DynGraph gr => (s -> s) -> Node -> gr s b -> gr s b +updateNode relabel node g = (preds, n, relabel this, succs) & g' + where ((preds, n, this, succs), g') = forceMatch node g + + +-- | Test if a graph has but a single node. +singletonGraph :: Graph gr => gr a b -> Bool +singletonGraph g = case labNodes g of [_] -> True + _ -> False + + +---------------- Supernodes ------------------------------------ + +-- | A "supernode" stands for a collection of one or more nodes (basic +-- blocks) that have been coalesced by the Hecht-Ullman algorithm. +-- A collection in a supernode constitutes a /reducible/ subgraph of a +-- control-flow graph. (When an entire control-flow graph is collapsed +-- to a single supernode, the flow graph is reducible.) +-- +-- The idea of node splitting is to collapse a control-flow graph down +-- to a single supernode, then materialize (``inflate'') the reducible +-- equivalent graph from that supernode. The `Supernode` class +-- defines only the methods needed to collapse; rematerialization is +-- the responsibility of the client. +-- +-- During the Hecht-Ullman algorithm, every supernode has a unique +-- entry point, which is given by `superLabel`. But this invariant is +-- not guaranteed by the class methods and is not a law of the class. +-- The `mapLabels` function rewrites all labels that appear in a +-- supernode (both definitions and uses). The `freshen` function +-- replaces every appearance of a /defined/ label with a fresh label. +-- (Appearances include both definitions and uses.) +-- +-- Laws: +-- @ +-- superLabel (n <> n') == superLabel n +-- blocks (n <> n') == blocks n `union` blocks n' +-- mapLabels f (n <> n') = mapLabels f n <> mapLabels f n' +-- mapLabels id == id +-- mapLabels (f . g) == mapLabels f . mapLabels g +-- @ +-- +-- (We expect `freshen` to distribute over `<>`, but because of +-- the fresh names involved, formulating a precise law is a bit +-- challenging.) + +class (Semigroup node) => PureSupernode node where + superLabel :: node -> Label + mapLabels :: (Label -> Label) -> (node -> node) + +class (MonadGetUnique m, PureSupernode node) => Supernode node m where + freshen :: node -> m node + + -- ghost method + -- blocks :: node -> Set Block + +------------------ Functions specific to the algorithm ----------------------- + +-- | Merge two nodes, return new graph plus list of nodes that newly have a single +-- predecessor. This function implements transformation $T_2$ from +-- the Hecht and Ullman paper (merge the node into its unique +-- predecessor). It then also removes self-edges (transformation $T_1$ from +-- the Hecht and Ullman paper). There is no need for a separate +-- implementation of $T_1$. +-- +-- `consumeBy v u g` returns the graph that results when node v is +-- consumed by node u in graph g. Both v and u are replaced with a new node u' +-- with these properties: +-- +-- LABELS(u') = LABELS(u) `union` LABELS(v) +-- SUCC(u') = SUCC(u) `union` SUCC(v) - { u } +-- every node that previously points to u now points to u' +-- +-- It also returns a list of nodes in the result graph that +-- are *newly* single-predecessor nodes. + +consumeBy :: (DynGraph gr, PureSupernode s) + => Node -> Node -> gr s () -> (gr s (), [Node]) +consumeBy toNode fromNode g = + assert (toPreds == [((), fromNode)]) $ + (newGraph, newCandidates) + where ((toPreds, _, to, toSuccs), g') = forceMatch toNode g + ((fromPreds, _, from, fromSuccs), g'') = forceMatch fromNode g' + context = ( fromPreds -- by construction, can't have `toNode` + , fromNode + , from <> to + , delete ((), fromNode) toSuccs `union` fromSuccs + ) + newGraph = context & g'' + newCandidates = filter (singlePred newGraph) changedNodes + changedNodes = fromNode `insert` map snd (toSuccs `intersect` fromSuccs) + +-- | Split a given node. The node is replaced with a collection of replicas, +-- one for each predecessor. After the split, every predecessor +-- points to a unique replica. +split :: forall gr s b m . (DynGraph gr, Supernode s m) + => Node -> gr s b -> m (gr s b) +split node g = assert (isMultiple preds) $ foldM addReplica g' newNodes + where ((preds, _, this, succs), g') = forceMatch node g + newNodes :: [((b, Node), Node)] + newNodes = zip preds [maxNode+1..] + (_, maxNode) = nodeRange g + thisLabel = superLabel this + addReplica :: gr s b -> ((b, Node), Node) -> m (gr s b) + addReplica g ((b, pred), newNode) = do + newSuper <- freshen this + return $ add newSuper + where add newSuper = + updateNode (thisLabel `replacedWith` superLabel newSuper) pred $ + ([(b, pred)], newNode, newSuper, succs) & g + +replacedWith :: PureSupernode s => Label -> Label -> s -> s +replacedWith old new = mapLabels (\l -> if l == old then new else l) + + +-- | Does a list have more than one element? (in constant time). +isMultiple :: [a] -> Bool +isMultiple [] = False +isMultiple [_] = False +isMultiple (_:_:_) = True + +-- | Find a candidate for splitting by finding a node that has multiple predecessors. + +anySplittable :: forall gr a b . Graph gr => gr a b -> LNode a +anySplittable g = case splittable of + n : _ -> n + [] -> panic "anySplittable found no splittable nodes" + where splittable = filter (isMultiple . pre g . fst) $ labNodes g + splittable :: [LNode a] + + +------------------ The collapsing algorithm ----------------------- + +-- | Using the algorithm of Hecht and Ullman (1972), collapse a graph +-- into a single node, splitting nodes as needed. Record +-- visualization events in monad `m`. +collapseInductiveGraph :: (DynGraph gr, Supernode s m, VizCollapseMonad m gr s) + => gr s () -> m (gr s ()) +collapseInductiveGraph g = drain g worklist + where worklist :: [[Node]] -- nodes with exactly one predecessor + worklist = [filter (singlePred g) $ nodes g] + + drain g [] = if singletonGraph g then finalGraph g >> return g + else let (n, super) = anySplittable g + in do splitGraphAt g (n, super) + collapseInductiveGraph =<< split n g + drain g ([]:nss) = drain g nss + drain g ((n:ns):nss) = let (g', ns') = consumeBy n (theUniquePred n) g + in do consumeByInGraph n (theUniquePred n) g + drain g' (ns':ns:nss) + where theUniquePred n + | ([(_, p)], _, _, _) <- context g n = p + | otherwise = + panic "node claimed to have a unique predecessor; it doesn't" diff --git a/GHC/Data/Graph/Color.hs b/GHC/Data/Graph/Color.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Color.hs @@ -0,0 +1,382 @@ +-- | Graph Coloring. +-- This is a generic graph coloring library, abstracted over the type of +-- the node keys, nodes and colors. +-- + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Data.Graph.Color ( + module GHC.Data.Graph.Base, + module GHC.Data.Graph.Ops, + module GHC.Data.Graph.Ppr, + colorGraph +) + +where + +import GHC.Prelude + +import GHC.Data.Graph.Base +import GHC.Data.Graph.Ops +import GHC.Data.Graph.Ppr + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Maybe +import Data.List (mapAccumL) + + +-- | Try to color a graph with this set of colors. +-- Uses Chaitin's algorithm to color the graph. +-- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes +-- are pushed onto a stack and removed from the graph. +-- Once this process is complete the graph can be colored by removing nodes from +-- the stack (ie in reverse order) and assigning them colors different to their neighbors. +-- +colorGraph + :: forall k cls color. + ( Uniquable k, Uniquable cls, Uniquable color + , Eq cls, Ord k + , Outputable k, Outputable cls, Outputable color) + => Bool -- ^ whether to do iterative coalescing + -> Int -- ^ how many times we've tried to color this graph so far. + -> UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to color. + + -> ( Graph k cls color -- the colored graph. + , UniqSet k -- the set of nodes that we couldn't find a color for. + , UniqFM k k ) -- map of regs (r1 -> r2) that were coalesced + -- r1 should be replaced by r2 in the source + +colorGraph iterative spinCount colors triv spill graph0 + = let + -- If we're not doing iterative coalescing then do an aggressive coalescing first time + -- around and then conservative coalescing for subsequent passes. + -- + -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if + -- there is a lot of register pressure and we do it on every round then it can make the + -- graph less colorable and prevent the algorithm from converging in a sensible number + -- of cycles. + -- + (graph_coalesced, kksCoalesce1) + = if iterative + then (graph0, []) + else if spinCount == 0 + then coalesceGraph True triv graph0 + else coalesceGraph False triv graph0 + + -- run the scanner to slurp out all the trivially colorable nodes + -- (and do coalescing if iterative coalescing is enabled) + (ksTriv, ksProblems, kksCoalesce2 :: [(k,k)]) + = colorScan iterative triv spill graph_coalesced + + -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. + -- We need to apply all the coalescences found by the scanner to the original + -- graph before doing assignColors. + -- + -- Because we've got the whole, non-pruned graph here we turn on aggressive coalescing + -- to force all the (conservative) coalescences found during scanning. + -- + (graph_scan_coalesced, _) + = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 + + -- color the trivially colorable nodes + -- during scanning, keys of triv nodes were added to the front of the list as they were found + -- this colors them in the reverse order, as required by the algorithm. + (graph_triv, ksNoTriv) + = assignColors colors graph_scan_coalesced ksTriv + + -- try and color the problem nodes + -- problem nodes are the ones that were left uncolored because they weren't triv. + -- there's a change we can color them here anyway. + (graph_prob, ksNoColor) + = assignColors colors graph_triv ksProblems + + -- if the trivially colorable nodes didn't color then something is probably wrong + -- with the provided triv function. + -- + in if not $ null ksNoTriv + then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty + ( empty + $$ text "ksTriv = " <> ppr ksTriv + $$ text "ksNoTriv = " <> ppr ksNoTriv + $$ text "colors = " <> ppr colors + $$ empty + $$ dotGraph (\_ -> text "white") triv graph_triv) + + else ( graph_prob + , mkUniqSet ksNoColor -- the nodes that didn't color (spills) + , if iterative + then (listToUFM kksCoalesce2) + else (listToUFM kksCoalesce1)) + + +-- | Scan through the conflict graph separating out trivially colorable and +-- potentially uncolorable (problem) nodes. +-- +-- Checking whether a node is trivially colorable or not is a reasonably expensive operation, +-- so after a triv node is found and removed from the graph it's no good to return to the 'start' +-- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. +-- +-- To ward against this, during each pass through the graph we collect up a list of triv nodes +-- that were found, and only remove them once we've finished the pass. The more nodes we can delete +-- at once the more likely it is that nodes we've already checked will become trivially colorable +-- for the next pass. +-- +-- TODO: add work lists to finding triv nodes is easier. +-- If we've just scanned the graph, and removed triv nodes, then the only +-- nodes that we need to rescan are the ones we've removed edges from. + +colorScan + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool -- ^ whether to do iterative coalescing + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to scan + + -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce + +colorScan iterative triv spill graph + = colorScan_spin iterative triv spill graph [] [] [] + +colorScan_spin + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + +colorScan_spin iterative triv spill graph + ksTriv ksSpill kksCoalesce + + -- if the graph is empty then we're done + | isNullUFM $ graphMap graph + = (ksTriv, ksSpill, reverse kksCoalesce) + + -- Simplify: + -- Look for trivially colorable nodes. + -- If we can find some then remove them from the graph and go back for more. + -- + | nsTrivFound@(_:_) + <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + + -- for iterative coalescing we only want non-move related + -- nodes here + && (not iterative || isEmptyUniqSet (nodeCoalesce node))) + $ graph + + , ksTrivFound <- map nodeId nsTrivFound + , graph2 <- foldr (\k g -> let Just g' = delNode k g + in g') + graph ksTrivFound + + = colorScan_spin iterative triv spill graph2 + (ksTrivFound ++ ksTriv) + ksSpill + kksCoalesce + + -- Coalesce: + -- If we're doing iterative coalescing and no triv nodes are available + -- then it's time for a coalescing pass. + | iterative + = case coalesceGraph False triv graph of + + -- we were able to coalesce something + -- go back to Simplify and see if this frees up more nodes to be trivially colorable. + (graph2, kksCoalesceFound@(_:_)) + -> colorScan_spin iterative triv spill graph2 + ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) + + -- Freeze: + -- nothing could be coalesced (or was triv), + -- time to choose a node to freeze and give up on ever coalescing it. + (graph2, []) + -> case freezeOneInGraph graph2 of + + -- we were able to freeze something + -- hopefully this will free up something for Simplify + (graph3, True) + -> colorScan_spin iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- we couldn't find something to freeze either + -- time for a spill + (graph3, False) + -> colorScan_spill iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- spill time + | otherwise + = colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce + + +-- Select: +-- we couldn't find any triv nodes or things to freeze or coalesce, +-- and the graph isn't empty yet.. We'll have to choose a spill +-- candidate and leave it uncolored. +-- +colorScan_spill + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + +colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce + + = let kSpill = spill graph + Just graph' = delNode kSpill graph + in colorScan_spin iterative triv spill graph' + ksTriv (kSpill : ksSpill) kksCoalesce + + +-- | Try to assign a color to all these nodes. + +assignColors + :: forall k cls color. + ( Uniquable k, Uniquable cls, Uniquable color + , Outputable cls) + => UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> [k] -- ^ nodes to assign a color to. + -> ( Graph k cls color -- the colored graph + , [k]) -- the nodes that didn't color. + +assignColors colors graph ks + = assignColors' colors graph [] ks + + where assignColors' :: UniqFM cls (UniqSet color) -- map of (node class -> set of colors available for this class). + -> Graph k cls color -- the graph + -> [k] -- nodes to assign a color to. + -> [k] + -> ( Graph k cls color -- the colored graph + , [k]) + assignColors' _ graph prob [] + = (graph, prob) + + assignColors' colors graph prob (k:ks) + = case assignColor colors k graph of + + -- couldn't color this node + Nothing -> assignColors' colors graph (k : prob) ks + + -- this node colored ok, so do the rest + Just graph' -> assignColors' colors graph' prob ks + + + assignColor colors u graph + | Just c <- selectColor colors graph u + = Just (setColor u c graph) + + | otherwise + = Nothing + + + +-- | Select a color for a certain node +-- taking into account preferences, neighbors and exclusions. +-- returns Nothing if no color can be assigned to this node. +-- +selectColor + :: ( Uniquable k, Uniquable cls, Uniquable color + , Outputable cls) + => UniqFM cls (UniqSet color) -- map of (node class -> set of colors available for this class). + -> Graph k cls color -- the graph + -> k -- key of the node to select a color for. + -> Maybe color + +selectColor colors graph u + = let -- lookup the node + Just node = lookupNode graph u + + -- lookup the available colors for the class of this node. + colors_avail + = case lookupUFM colors (nodeClass node) of + Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) + Just cs -> cs + + -- find colors we can't use because they're already being used + -- by a node that conflicts with this one. + Just nsConflicts + = sequence + $ map (lookupNode graph) + $ nonDetEltsUniqSet + $ nodeConflicts node + -- See Note [Unique Determinism and code generation] + + colors_conflict = mkUniqSet + $ mapMaybe nodeColor nsConflicts + + -- the prefs of our neighbors + colors_neighbor_prefs + = mkUniqSet + $ concatMap nodePreference nsConflicts + + -- colors that are still valid for us + colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) + colors_ok = minusUniqSet colors_ok_ex colors_conflict + + -- the colors that we prefer, and are still ok + colors_ok_pref = intersectUniqSets + (mkUniqSet $ nodePreference node) colors_ok + + -- the colors that we could choose while being nice to our neighbors + colors_ok_nice = minusUniqSet + colors_ok colors_neighbor_prefs + + -- the best of all possible worlds.. + colors_ok_pref_nice + = intersectUniqSets + colors_ok_nice colors_ok_pref + + -- make the decision + chooseColor + + -- everyone is happy, yay! + | not $ isEmptyUniqSet colors_ok_pref_nice + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) + (nodePreference node) + = Just c + + -- we've got one of our preferences + | not $ isEmptyUniqSet colors_ok_pref + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) + (nodePreference node) + = Just c + + -- it wasn't a preference, but it was still ok + | not $ isEmptyUniqSet colors_ok + , c : _ <- nonDetEltsUniqSet colors_ok + -- See Note [Unique Determinism and code generation] + = Just c + + -- no colors were available for us this time. + -- looks like we're going around the loop again.. + | otherwise + = Nothing + + in chooseColor + diff --git a/GHC/Data/Graph/Directed.hs b/GHC/Data/Graph/Directed.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Directed.hs @@ -0,0 +1,487 @@ +-- (c) The University of Glasgow 2006 + + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Data.Graph.Directed ( + Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, + graphFromVerticesAndAdjacency, emptyGraph, + + SCC(..), Node(..), G.flattenSCC, G.flattenSCCs, + stronglyConnCompG, + topologicalSortG, + verticesG, edgesG, hasVertexG, + reachablesG, + transposeG, outgoingG, + emptyG, + + findCycle, + + -- For backwards compatibility with the simpler version of Digraph + stronglyConnCompFromEdgedVerticesOrd, + stronglyConnCompFromEdgedVerticesOrdR, + stronglyConnCompFromEdgedVerticesUniq, + stronglyConnCompFromEdgedVerticesUniqR, + + -- Simple way to classify edges + EdgeType(..), classifyEdges + ) where + +------------------------------------------------------------------------------ +-- A version of the graph algorithms described in: +-- +-- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell'' +-- by David King and John Launchbury +-- +-- Also included is some additional code for printing tree structures ... +-- +-- If you ever find yourself in need of algorithms for classifying edges, +-- or finding connected/biconnected components, consult the history; Sigbjorn +-- Finne contributed some implementations in 1997, although we've since +-- removed them since they were not used anywhere in GHC. +------------------------------------------------------------------------------ + +import GHC.Prelude + +import GHC.Utils.Misc ( sortWith, count ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.Maybe ( expectJust ) + +-- std interfaces +import Data.Maybe +import Data.Array +import Data.List ( sort ) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Data.Graph as G +import Data.Graph ( Vertex, Bounds, SCC(..) ) -- Used in the underlying representation +import GHC.Types.Unique +import GHC.Types.Unique.FM + +-- The graph internals are defined in the .Internal module so they can be +-- imported by GHC.Data.Graph.Directed.Reachability while still allowing this +-- module to export it abstractly. +import GHC.Data.Graph.Directed.Internal + +{- +************************************************************************ +* * +* Graphs and Graph Construction +* * +************************************************************************ + +Note [Nodes, keys, vertices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * A 'node' is a big blob of client-stuff + + * Each 'node' has a unique (client) 'key', but the latter + is in Ord and has fast comparison + + * Digraph then maps each 'key' to a Vertex (Int) which is + arranged densely in 0.n +-} + +{-| Representation for nodes of the Graph. + + * The @payload@ is user data, just carried around in this module + + * The @key@ is the node identifier. + Key has an Ord instance for performance reasons. + + * The @[key]@ are the dependencies of the node; + it's ok to have extra keys in the dependencies that + are not the key of any Node in the graph +-} +data Node key payload = DigraphNode { + node_payload :: payload, -- ^ User data + node_key :: key, -- ^ User defined node id + node_dependencies :: [key] -- ^ Dependencies/successors of the node + } deriving Functor + + +instance (Outputable a, Outputable b) => Outputable (Node a b) where + ppr (DigraphNode a b c) = ppr (a, b, c) + +emptyGraph :: Graph a +emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) + +-- See Note [Deterministic SCC] +graphFromEdgedVertices + :: ReduceFn key payload + -> [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVertices _reduceFn [] = emptyGraph +graphFromEdgedVertices reduceFn edged_vertices = + Graph graph vertex_fn (key_vertex . key_extractor) + where key_extractor = node_key + (bounds, vertex_fn, key_vertex, numbered_nodes) = + reduceFn edged_vertices key_extractor + graph = array bounds [ (v, sort $ mapMaybe key_vertex ks) + | (v, (node_dependencies -> ks)) <- numbered_nodes] + -- We normalize outgoing edges by sorting on node order, so + -- that the result doesn't depend on the order of the edges + +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +graphFromEdgedVerticesOrd + :: Ord key + => [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd + +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +graphFromEdgedVerticesUniq + :: Uniquable key + => [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq + +type ReduceFn key payload = + [Node key payload] -> (Node key payload -> key) -> + (Bounds, Vertex -> Node key payload + , key -> Maybe Vertex, [(Vertex, Node key payload)]) + +{- +Note [reduceNodesIntoVertices implementations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +reduceNodesIntoVertices is parameterized by the container type. +This is to accommodate key types that don't have an Ord instance +and hence preclude the use of Data.Map. An example of such type +would be Unique, there's no way to implement Ord Unique +deterministically. + +For such types, there's a version with a Uniquable constraint. +This leaves us with two versions of every function that depends on +reduceNodesIntoVertices, one with Ord constraint and the other with +Uniquable constraint. +For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq. + +The Uniq version should be a tiny bit more efficient since it uses +Data.IntMap internally. +-} +reduceNodesIntoVertices + :: ([(key, Vertex)] -> m) + -> (key -> m -> Maybe Vertex) + -> ReduceFn key payload +reduceNodesIntoVertices fromList lookup nodes key_extractor = + (bounds, (!) vertex_map, key_vertex, numbered_nodes) + where + max_v = length nodes - 1 + bounds = (0, max_v) :: (Vertex, Vertex) + + -- Keep the order intact to make the result depend on input order + -- instead of key order + numbered_nodes = zip [0..] nodes + vertex_map = array bounds numbered_nodes + + key_map = fromList + [ (key_extractor node, v) | (v, node) <- numbered_nodes ] + key_vertex k = lookup k key_map + +-- See Note [reduceNodesIntoVertices implementations] +reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload +reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup + +-- See Note [reduceNodesIntoVertices implementations] +reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload +reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM) + +{- +************************************************************************ +* * +* SCC +* * +************************************************************************ +-} + +type WorkItem key payload + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a + +-- | Find a reasonably short cycle a->b->c->a, in a graph +-- The graph might not necessarily be strongly connected. +findCycle :: forall payload key. Ord key + => [Node key payload] -- The nodes. The dependencies can + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next +findCycle graph + = goRoots plausible_roots + where + env :: Map.Map key (Node key payload) + env = Map.fromList [ (node_key node, node) | node <- graph ] + + goRoots [] = Nothing + goRoots (root:xs) = + case go Set.empty (new_work root_deps []) [] of + Nothing -> goRoots xs + Just res -> Just res + where + DigraphNode root_payload root_key root_deps = root + -- 'go' implements Dijkstra's algorithm, more or less + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle + -- Invariant: in a call (go visited ps qs), + -- visited = union (map tail (ps ++ qs)) + + go _ [] [] = Nothing -- No cycles + go visited [] qs = go visited qs [] + go visited (((DigraphNode payload key deps), path) : ps) qs + | key == root_key = Just (root_payload : reverse path) + | key `Set.member` visited = go visited ps qs + | key `Map.notMember` env = go visited ps qs + | otherwise = go (Set.insert key visited) + ps (new_qs ++ qs) + where + new_qs = new_work deps (payload : path) + + + -- Find the nodes with fewest dependencies among the SCC modules + -- This is just a heuristic to find some plausible root module + plausible_roots :: [Node key payload] + plausible_roots = map fst (sortWith snd [ (node, count (`Map.member` env) (node_dependencies node)) + | node <- graph ]) + + + new_work :: [key] -> [payload] -> [WorkItem key payload] + new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] + +{- +************************************************************************ +* * +* Strongly Connected Component wrappers for Graph +* * +************************************************************************ + +Note: the components are returned topologically sorted: later components +depend on earlier ones, but not vice versa i.e. later components only have +edges going from them to earlier ones. +-} + +{- +Note [Deterministic SCC] +~~~~~~~~~~~~~~~~~~~~~~~~ +stronglyConnCompFromEdgedVerticesUniq, +stronglyConnCompFromEdgedVerticesUniqR, +stronglyConnCompFromEdgedVerticesOrd and +stronglyConnCompFromEdgedVerticesOrdR +provide a following guarantee: +Given a deterministically ordered list of nodes it returns a deterministically +ordered list of strongly connected components, where the list of vertices +in an SCC is also deterministically ordered. +Note that the order of edges doesn't need to be deterministic for this to work. +We use the order of nodes to normalize the order of edges. +-} + +stronglyConnCompG :: Graph node -> [SCC node] +stronglyConnCompG graph = decodeSccs graph $ scc (gr_int_graph graph) + +decodeSccs :: Graph node -> [SCC Vertex] -> [SCC node] +decodeSccs Graph { gr_vertex_to_node = vertex_fn } + = map (fmap vertex_fn) + +-- The following two versions are provided for backwards compatibility: +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesOrd + :: Ord key + => [Node key payload] + -> [SCC payload] +stronglyConnCompFromEdgedVerticesOrd + = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR + +-- The following two versions are provided for backwards compatibility: +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesUniq + :: Uniquable key + => [Node key payload] + -> [SCC payload] +stronglyConnCompFromEdgedVerticesUniq + = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR + +-- The "R" interface is used when you expect to apply SCC to +-- (some of) the result of SCC, so you don't want to lose the dependency info +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesOrdR + :: Ord key + => [Node key payload] + -> [SCC (Node key payload)] +stronglyConnCompFromEdgedVerticesOrdR = + stronglyConnCompG . graphFromEdgedVerticesOrd + +-- The "R" interface is used when you expect to apply SCC to +-- (some of) the result of SCC, so you don't want to lose the dependency info +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesUniqR + :: Uniquable key + => [Node key payload] + -> [SCC (Node key payload)] +stronglyConnCompFromEdgedVerticesUniqR = + stronglyConnCompG . graphFromEdgedVerticesUniq + +{- +************************************************************************ +* * +* Misc wrappers for Graph +* * +************************************************************************ +-} + +topologicalSortG :: Graph node -> [node] +topologicalSortG graph = map (gr_vertex_to_node graph) result + where result = {-# SCC "Digraph.topSort" #-} G.topSort (gr_int_graph graph) + +outgoingG :: Graph node -> node -> [node] +outgoingG graph from = map (gr_vertex_to_node graph) result + where from_vertex = expectJust (gr_node_to_vertex graph from) + result = gr_int_graph graph ! from_vertex + +-- | Given a list of roots, return all reachable nodes in topological order. +-- Implemented using a depth-first traversal. +reachablesG :: Graph node -> [node] -> [node] +reachablesG graph froms = map (gr_vertex_to_node graph) result + where result = {-# SCC "Digraph.reachable" #-} + reachable (gr_int_graph graph) vs + vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] + +hasVertexG :: Graph node -> node -> Bool +hasVertexG graph node = isJust $ gr_node_to_vertex graph node + +transposeG :: Graph node -> Graph node +transposeG graph = Graph (G.transposeG (gr_int_graph graph)) + (gr_vertex_to_node graph) + (gr_node_to_vertex graph) + +emptyG :: Graph node -> Bool +emptyG g = graphEmpty (gr_int_graph g) + +graphEmpty :: G.Graph -> Bool +graphEmpty g = lo > hi + where (lo, hi) = bounds g + + +{- +************************************************************************ +* * +* Classify Edge Types +* * +************************************************************************ +-} + +-- Remark: While we could generalize this algorithm this comes at a runtime +-- cost and with no advantages. If you find yourself using this with graphs +-- not easily represented using Int nodes please consider rewriting this +-- using the more general Graph type. + +-- | Edge direction based on DFS Classification +data EdgeType + = Forward + | Cross + | Backward -- ^ Loop back towards the root node. + -- Eg backjumps in loops + | SelfLoop -- ^ v -> v + deriving (Eq,Ord) + +instance Outputable EdgeType where + ppr Forward = text "Forward" + ppr Cross = text "Cross" + ppr Backward = text "Backward" + ppr SelfLoop = text "SelfLoop" + +newtype Time = Time Int deriving (Eq,Ord,Num,Outputable) + +--Allow for specialization +{-# INLINEABLE classifyEdges #-} + +-- | Given a start vertex, a way to get successors from a node +-- and a list of (directed) edges classify the types of edges. +classifyEdges :: forall key. Uniquable key => key -> (key -> [key]) + -> [(key,key)] -> [((key, key), EdgeType)] +classifyEdges root getSucc edges = + --let uqe (from,to) = (getUnique from, getUnique to) + --in pprTrace "Edges:" (ppr $ map uqe edges) $ + zip edges $ map classify edges + where + (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root + classify :: (key,key) -> EdgeType + classify (from,to) + | startFrom < startTo + , endFrom > endTo + = Forward + | startFrom > startTo + , endFrom < endTo + = Backward + | startFrom > startTo + , endFrom > endTo + = Cross + | getUnique from == getUnique to + = SelfLoop + | otherwise + = pprPanic "Failed to classify edge of Graph" + (ppr (getUnique from, getUnique to)) + + where + getTime event node + | Just time <- lookupUFM event node + = time + | otherwise + = pprPanic "Failed to classify edge of CFG - not not timed" + (text "edges" <> ppr (getUnique from, getUnique to) + <+> ppr starts <+> ppr ends ) + startFrom = getTime starts from + startTo = getTime starts to + endFrom = getTime ends from + endTo = getTime ends to + + addTimes :: (Time, UniqFM key Time, UniqFM key Time) -> key + -> (Time, UniqFM key Time, UniqFM key Time) + addTimes (time,starts,ends) n + --Dont reenter nodes + | elemUFM n starts + = (time,starts,ends) + | otherwise = + let + starts' = addToUFM starts n time + time' = time + 1 + succs = getSucc n :: [key] + (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs + ends'' = addToUFM ends' n time'' + in + (time'' + 1, starts'', ends'') + +graphFromVerticesAndAdjacency + :: Ord key + => [Node key payload] + -> [(key, key)] -- First component is source vertex key, + -- second is target vertex key (thing depended on) + -- Unlike the other interface I insist they correspond to + -- actual vertices because the alternative hides bugs. I can't + -- do the same thing for the other one for backcompat reasons. + -> Graph (Node key payload) +graphFromVerticesAndAdjacency [] _ = emptyGraph +graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor) + where key_extractor = node_key + (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVerticesOrd vertices key_extractor + key_vertex_pair (a, b) = (expectJust $ key_vertex a, + expectJust $ key_vertex b) + reduced_edges = map key_vertex_pair edges + graph = G.buildG bounds reduced_edges + diff --git a/GHC/Data/Graph/Directed/Internal.hs b/GHC/Data/Graph/Directed/Internal.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Directed/Internal.hs @@ -0,0 +1,79 @@ +module GHC.Data.Graph.Directed.Internal where + +import GHC.Prelude +import GHC.Utils.Outputable + +import Data.Array +import qualified Data.Graph as G +import Data.Graph ( Vertex, SCC(..) ) -- Used in the underlying representation +import Data.Tree + +data Graph node = Graph { + gr_int_graph :: IntGraph, + gr_vertex_to_node :: Vertex -> node, + gr_node_to_vertex :: node -> Maybe Vertex +} + +data Edge node = Edge node node + +------------------------------------------------------------ +-- Nodes and Edges +------------------------------------------------------------ + +verticesG :: Graph node -> [node] +verticesG graph = map (gr_vertex_to_node graph) $ G.vertices (gr_int_graph graph) + +edgesG :: Graph node -> [Edge node] +edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ G.edges (gr_int_graph graph) + where v2n = gr_vertex_to_node graph + +------------------------------------------------------------ +-- Showing Graphs +------------------------------------------------------------ + +instance Outputable node => Outputable (Graph node) where + ppr graph = vcat [ + hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)), + hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph)) + ] + +instance Outputable node => Outputable (Edge node) where + ppr (Edge from to) = ppr from <+> text "->" <+> ppr to + +{- +************************************************************************ +* * +* IntGraphs +* * +************************************************************************ +-} + +type IntGraph = G.Graph + +------------------------------------------------------------ +-- Depth first search numbering +------------------------------------------------------------ + +-- Data.Tree has flatten for Tree, but nothing for Forest +preorderF :: Forest a -> [a] +preorderF ts = concatMap flatten ts + +------------------------------------------------------------ +-- Finding reachable vertices +------------------------------------------------------------ + +-- This generalizes reachable which was found in Data.Graph +reachable :: IntGraph -> [Vertex] -> [Vertex] +reachable g vs = preorderF (G.dfs g vs) + +scc :: IntGraph -> [SCC Vertex] +scc graph = map decode forest + where + forest = {-# SCC "Digraph.scc" #-} G.scc graph + + decode (Node v []) | mentions_itself v = CyclicSCC [v] + | otherwise = AcyclicSCC v + decode other = CyclicSCC (dec other []) + where dec (Node v ts) vs = v : foldr dec vs ts + mentions_itself v = v `elem` (graph ! v) + diff --git a/GHC/Data/Graph/Directed/Reachability.hs b/GHC/Data/Graph/Directed/Reachability.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Directed/Reachability.hs @@ -0,0 +1,178 @@ +-- | An abstract interface for a fast reachability data structure constructed +-- from a 'GHC.Data.Graph.Directed' graph. +module GHC.Data.Graph.Directed.Reachability + ( ReachabilityIndex + + -- * Constructing a reachability index + , graphReachability, cyclicGraphReachability + + -- * Reachability queries + , allReachable, allReachableMany + , isReachable, isReachableMany + + -- * Debugging + , reachabilityIndexMembers + + ) + where + +import GHC.Prelude +import GHC.Data.Maybe + +import qualified Data.Graph as G +import Data.Graph ( Vertex, SCC(..) ) + +import Data.Array ((!)) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS + +import GHC.Data.Graph.Directed.Internal + +-------------------------------------------------------------------------------- +-- * Reachability index +-------------------------------------------------------------------------------- + +-- | The abstract data structure for fast reachability queries +data ReachabilityIndex node = ReachabilityIndex { + index :: IM.IntMap IS.IntSet, + from_vertex :: Vertex -> node, + to_vertex :: node -> Maybe Vertex +} + +-- +reachabilityIndexMembers :: ReachabilityIndex node -> [node] +reachabilityIndexMembers (ReachabilityIndex index from_vert _) = map from_vert (IM.keys index) + +-------------------------------------------------------------------------------- +-- * Construction +-------------------------------------------------------------------------------- + +-- | Construct a 'ReachabilityIndex' from an acyclic 'Graph'. +-- If the graph can have cycles, use 'cyclicGraphReachability' +graphReachability :: Graph node -> ReachabilityIndex node +graphReachability (Graph g from to) = + ReachabilityIndex{index = reachableGraph, from_vertex = from, to_vertex = to} + where + reachableGraph :: IM.IntMap IS.IntSet + reachableGraph = IM.fromList [(v, do_one v) | v <- G.vertices g] + + do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup reachableGraph) (g ! v)) + +-- | Construct a 'ReachabilityIndex' from a 'Graph' which may have cycles. +-- If this reachability index is just going to be used once, it may make sense +-- to use 'reachablesG' instead, which will traverse the reachable nodes without +-- constructing the index -- which may be faster. +cyclicGraphReachability :: Graph node -> ReachabilityIndex node +cyclicGraphReachability (Graph g from to) = + ReachabilityIndex{index = reachableGraphCyclic, from_vertex = from, to_vertex = to} + where + reachableGraphCyclic :: IM.IntMap IS.IntSet + reachableGraphCyclic = foldl' add_one_comp mempty comps + + neighboursOf v = g!v + + comps = scc g + + -- To avoid divergence on cyclic input, we build the result + -- strongly connected component by component, in topological + -- order. For each SCC, we know that: + -- + -- * All vertices in the component can reach all other vertices + -- in the component ("local" reachables) + -- + -- * Other reachable vertices ("remote" reachables) must come + -- from earlier components, either via direct neighbourhood, or + -- transitively from earlier reachability map + -- + -- This allows us to build the extension of the reachability map + -- directly, without any self-reference, thereby avoiding a loop. + add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet + add_one_comp earlier (AcyclicSCC v) = IM.insert v all_remotes earlier + where + earlier_neighbours = neighboursOf v + earlier_further = mapMaybe (flip IM.lookup earlier) earlier_neighbours + all_remotes = IS.unions (IS.fromList earlier_neighbours : earlier_further) + add_one_comp earlier (CyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- vs]) earlier + where + all_locals = IS.fromList vs + local v = IS.delete v all_locals + -- Arguably, for a cyclic SCC we should include each + -- vertex in its own reachable set. However, this could + -- lead to a lot of extra pain in client code to avoid + -- looping when traversing the reachability map. + all_neighbours = IS.fromList (concatMap neighboursOf vs) + earlier_neighbours = all_neighbours IS.\\ all_locals + earlier_further = mapMaybe (flip IM.lookup earlier) (IS.toList earlier_neighbours) + all_remotes = IS.unions (earlier_neighbours : earlier_further) + +-------------------------------------------------------------------------------- +-- * Reachability queries +-------------------------------------------------------------------------------- + +-- | 'allReachable' returns the nodes reachable from the given @root@ node. +-- +-- Properties: +-- * The list of nodes /does not/ include the @root@ node! +-- * The list of nodes is deterministically ordered, but according to an +-- internal order determined by the indices attributed to graph nodes. +-- +-- If you need a topologically sorted list, consider using the functions exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead. +allReachable :: ReachabilityIndex node -> node {-^ The @root@ node -} -> [node] {-^ All nodes reachable from @root@ -} +allReachable (ReachabilityIndex index from to) root = map from result + where root_i = expectJust (to root) + hits = {-# SCC "allReachable" #-} IM.lookup root_i index + result = IS.toList $! expectJust hits + +-- | 'allReachableMany' returns all nodes reachable from the many given @roots@. +-- +-- Properties: +-- * The list of nodes /does not/ include the @roots@ node! +-- * The list of nodes is deterministically ordered, but according to an +-- internal order determined by the indices attributed to graph nodes. +-- * This function has $O(n)$ complexity where $n$ is the number of @roots@. +-- +-- If you need a topologically sorted list, consider using the functions +-- exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead ('reachableG'). +allReachableMany :: ReachabilityIndex node -> [node] {-^ The @roots@ -} -> [node] {-^ All nodes reachable from all @roots@ -} +allReachableMany (ReachabilityIndex index from to) roots = map from (IS.toList hits) + where roots_i = [ v | Just v <- map to roots ] + hits = {-# SCC "allReachableMany" #-} + IS.unions $ map (expectJust . flip IM.lookup index) roots_i + +-- | Fast reachability query. +-- +-- On graph @g@ with nodes @a@ and @b@, @isReachable g a b@ +-- asks whether @b@ can be reached through @g@ starting from @a@. +-- +-- Properties: +-- * No self loops, i.e. @isReachable _ a a == False@ +isReachable :: ReachabilityIndex node {-^ @g@ -} + -> node -- ^ @a@ + -> node -- ^ @b@ + -> Bool -- ^ @b@ is reachable from @a@ +isReachable (ReachabilityIndex index _ to) a b = + IS.member b_i $ + expectJust $ IM.lookup a_i index + where a_i = expectJust $ to a + b_i = expectJust $ to b + +-- | Fast reachability query with many roots. +-- +-- On graph @g@ with many nodes @roots@ and node @b@, @isReachableMany g as b@ +-- asks whether @b@ can be reached through @g@ from any of the @roots@. +-- +-- By partially applying this function to a set of roots, the resulting function can +-- be applied many times and share the initial work. +-- +-- Properties: +-- * No self loops, i.e. @isReachableMany _ [a] a == False@ +isReachableMany :: ReachabilityIndex node -- ^ @g@ + -> [node] -- ^ @roots@ + -> (node -> Bool) -- ^ @b@ is reachable from any of the @roots@ +isReachableMany (ReachabilityIndex index _ to) roots = + let roots_i = [ v | Just v <- map to roots ] + unions = + IS.unions $ + map (expectJust . flip IM.lookup index) roots_i + in \b -> let b_i = expectJust $ to b + in IS.member b_i unions diff --git a/GHC/Data/Graph/Inductive/Graph.hs b/GHC/Data/Graph/Inductive/Graph.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Inductive/Graph.hs @@ -0,0 +1,642 @@ +-- (c) 1999-2005 by Martin Erwig (see copyright at bottom) +-- | Static and Dynamic Inductive Graphs +-- +-- Code is from Hackage `fgl` package version 5.7.0.3 +-- +module GHC.Data.Graph.Inductive.Graph ( + -- * General Type Defintions + -- ** Node and Edge Types + Node,LNode,UNode, + Edge,LEdge,UEdge, + -- ** Types Supporting Inductive Graph View + Adj,Context,MContext,Decomp,GDecomp,UContext,UDecomp, + Path,LPath(..),UPath, + -- * Graph Type Classes + -- | We define two graph classes: + -- + -- Graph: static, decomposable graphs. + -- Static means that a graph itself cannot be changed + -- + -- DynGraph: dynamic, extensible graphs. + -- Dynamic graphs inherit all operations from static graphs + -- but also offer operations to extend and change graphs. + -- + -- Each class contains in addition to its essential operations those + -- derived operations that might be overwritten by a more efficient + -- implementation in an instance definition. + -- + -- Note that labNodes is essentially needed because the default definition + -- for matchAny is based on it: we need some node from the graph to define + -- matchAny in terms of match. Alternatively, we could have made matchAny + -- essential and have labNodes defined in terms of ufold and matchAny. + -- However, in general, labNodes seems to be (at least) as easy to define + -- as matchAny. We have chosen labNodes instead of the function nodes since + -- nodes can be easily derived from labNodes, but not vice versa. + Graph(..), + DynGraph(..), + -- * Operations + order, + size, + -- ** Graph Folds and Maps + ufold,gmap,nmap,emap,nemap, + -- ** Graph Projection + nodes,edges,toEdge,edgeLabel,toLEdge,newNodes,gelem, + -- ** Graph Construction and Destruction + insNode,insEdge,delNode,delEdge,delLEdge,delAllLEdge, + insNodes,insEdges,delNodes,delEdges, + buildGr,mkUGraph, + -- ** Subgraphs + gfiltermap,nfilter,labnfilter,labfilter,subgraph, + -- ** Graph Inspection + context,lab,neighbors,lneighbors, + suc,pre,lsuc,lpre, + out,inn,outdeg,indeg,deg, + hasEdge,hasNeighbor,hasLEdge,hasNeighborAdj, + equal, + -- ** Context Inspection + node',lab',labNode',neighbors',lneighbors', + suc',pre',lpre',lsuc', + out',inn',outdeg',indeg',deg', + -- * Pretty-printing + prettify, + prettyPrint, + -- * Ordering of Graphs + OrdGr(..) +) where + +import GHC.Prelude + +import Control.Arrow (first) +import Data.Function (on) +import qualified Data.IntSet as IntSet +import Data.List (delete, groupBy, sort, sortBy, (\\)) +import Data.List.NonEmpty (nonEmpty) +import Data.Maybe (fromMaybe, isJust) + +import GHC.Utils.Panic + +-- | Unlabeled node +type Node = Int +-- | Labeled node +type LNode a = (Node,a) +-- | Quasi-unlabeled node +type UNode = LNode () + +-- | Unlabeled edge +type Edge = (Node,Node) +-- | Labeled edge +type LEdge b = (Node,Node,b) +-- | Quasi-unlabeled edge +type UEdge = LEdge () + +-- | Unlabeled path +type Path = [Node] +-- | Labeled path +newtype LPath a = LP { unLPath :: [LNode a] } + +instance (Show a) => Show (LPath a) where + show (LP xs) = show xs + +instance (Eq a) => Eq (LPath a) where + (LP []) == (LP []) = True + (LP ((_,x):_)) == (LP ((_,y):_)) = x==y + (LP _) == (LP _) = False + +instance (Ord a) => Ord (LPath a) where + compare (LP []) (LP []) = EQ + compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y + compare _ _ = panic "LPath: cannot compare two empty paths" + +-- | Quasi-unlabeled path +type UPath = [UNode] + +-- | Labeled links to or from a 'Node'. +type Adj b = [(b,Node)] +-- | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'. +-- +-- In other words, this captures all information regarding the +-- specified 'Node' within a graph. +type Context a b = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node +type MContext a b = Maybe (Context a b) +-- | 'Graph' decomposition - the context removed from a 'Graph', and the rest +-- of the 'Graph'. +type Decomp g a b = (MContext a b,g a b) +-- | The same as 'Decomp', only more sure of itself. +type GDecomp g a b = (Context a b,g a b) + +-- | Unlabeled context. +type UContext = ([Node],Node,[Node]) +-- | Unlabeled decomposition. +type UDecomp g = (Maybe UContext,g) + +-- | Minimum implementation: 'empty', 'isEmpty', 'match', 'mkGraph', 'labNodes' +class Graph gr where + {-# MINIMAL empty, isEmpty, match, mkGraph, labNodes #-} + + -- | An empty 'Graph'. + empty :: gr a b + + -- | True if the given 'Graph' is empty. + isEmpty :: gr a b -> Bool + + -- | Decompose a 'Graph' into the 'MContext' found for the given node and the + -- remaining 'Graph'. + match :: Node -> gr a b -> Decomp gr a b + + -- | Create a 'Graph' from the list of 'LNode's and 'LEdge's. + -- + -- For graphs that are also instances of 'DynGraph', @mkGraph ns + -- es@ should be equivalent to @('insEdges' es . 'insNodes' ns) + -- 'empty'@. + mkGraph :: [LNode a] -> [LEdge b] -> gr a b + + -- | A list of all 'LNode's in the 'Graph'. + labNodes :: gr a b -> [LNode a] + + -- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node' + -- and the remaining 'Graph'. + matchAny :: gr a b -> GDecomp gr a b + matchAny g = case labNodes g of + [] -> panic "Match Exception, Empty Graph" + (v,_):_ | (Just c,g') <- match v g -> (c,g') + _ -> panic "This can't happen: failed to match node in graph" + + + -- | The number of 'Node's in a 'Graph'. + noNodes :: gr a b -> Int + noNodes = length . labNodes + + -- | The minimum and maximum 'Node' in a 'Graph'. + nodeRange :: gr a b -> (Node,Node) + nodeRange g = case nonEmpty (nodes g) of + Nothing -> panic "nodeRange of empty graph" + Just vs -> (minimum vs, maximum vs) + + -- | A list of all 'LEdge's in the 'Graph'. + labEdges :: gr a b -> [LEdge b] + labEdges = ufold (\(_,v,_,s)->(map (\(l,w)->(v,w,l)) s ++)) [] + +class (Graph gr) => DynGraph gr where + -- | Merge the 'Context' into the 'DynGraph'. + -- + -- Context adjacencies should only refer to either a Node already + -- in a graph or the node in the Context itself (for loops). + -- + -- Behaviour is undefined if the specified 'Node' already exists + -- in the graph. + (&) :: Context a b -> gr a b -> gr a b + + +-- | The number of nodes in the graph. An alias for 'noNodes'. +order :: (Graph gr) => gr a b -> Int +order = noNodes + +-- | The number of edges in the graph. +-- +-- Note that this counts every edge found, so if you are +-- representing an unordered graph by having each edge mirrored this +-- will be incorrect. +-- +-- If you created an unordered graph by either mirroring every edge +-- (including loops!) or using the @undir@ function in +-- "Data.Graph.Inductive.Basic" then you can safely halve the value +-- returned by this. +size :: (Graph gr) => gr a b -> Int +size = length . labEdges + +-- | Fold a function over the graph by recursively calling 'match'. +ufold :: (Graph gr) => (Context a b -> c -> c) -> c -> gr a b -> c +ufold f u g + | isEmpty g = u + | otherwise = f c (ufold f u g') + where + (c,g') = matchAny g + +-- | Map a function over the graph by recursively calling 'match'. +gmap :: (DynGraph gr) => (Context a b -> Context c d) -> gr a b -> gr c d +gmap f = ufold (\c->(f c&)) empty +{-# NOINLINE [0] gmap #-} + +-- | Map a function over the 'Node' labels in a graph. +nmap :: (DynGraph gr) => (a -> c) -> gr a b -> gr c b +nmap f = gmap (\(p,v,l,s)->(p,v,f l,s)) +{-# NOINLINE [0] nmap #-} + +-- | Map a function over the 'Edge' labels in a graph. +emap :: (DynGraph gr) => (b -> c) -> gr a b -> gr a c +emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s)) + where + map1 g = map (first g) +{-# NOINLINE [0] emap #-} + +-- | Map functions over both the 'Node' and 'Edge' labels in a graph. +nemap :: (DynGraph gr) => (a -> c) -> (b -> d) -> gr a b -> gr c d +nemap fn fe = gmap (\(p,v,l,s) -> (fe' p,v,fn l,fe' s)) + where + fe' = map (first fe) +{-# NOINLINE [0] nemap #-} + +-- | List all 'Node's in the 'Graph'. +nodes :: (Graph gr) => gr a b -> [Node] +nodes = map fst . labNodes + +-- | List all 'Edge's in the 'Graph'. +edges :: (Graph gr) => gr a b -> [Edge] +edges = map toEdge . labEdges + +-- | Drop the label component of an edge. +toEdge :: LEdge b -> Edge +toEdge (v,w,_) = (v,w) + +-- | Add a label to an edge. +toLEdge :: Edge -> b -> LEdge b +toLEdge (v,w) l = (v,w,l) + +-- | The label in an edge. +edgeLabel :: LEdge b -> b +edgeLabel (_,_,l) = l + +-- | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'. +newNodes :: (Graph gr) => Int -> gr a b -> [Node] +newNodes i g + | isEmpty g = [0..i-1] + | otherwise = [n+1..n+i] + where + (_,n) = nodeRange g + +-- | 'True' if the 'Node' is present in the 'Graph'. +gelem :: (Graph gr) => Node -> gr a b -> Bool +gelem v = isJust . fst . match v + +-- | Insert a 'LNode' into the 'Graph'. +insNode :: (DynGraph gr) => LNode a -> gr a b -> gr a b +insNode (v,l) = (([],v,l,[])&) +{-# NOINLINE [0] insNode #-} + +-- | Insert a 'LEdge' into the 'Graph'. +insEdge :: (DynGraph gr) => LEdge b -> gr a b -> gr a b +insEdge (v,w,l) g = (pr,v,la,(l,w):su) & g' + where + (mcxt,g') = match v g + (pr,_,la,su) = fromMaybe + (panic ("insEdge: cannot add edge from non-existent vertex " ++ show v)) + mcxt +{-# NOINLINE [0] insEdge #-} + +-- | Remove a 'Node' from the 'Graph'. +delNode :: (Graph gr) => Node -> gr a b -> gr a b +delNode v = delNodes [v] + +-- | Remove an 'Edge' from the 'Graph'. +-- +-- NOTE: in the case of multiple edges, this will delete /all/ such +-- edges from the graph as there is no way to distinguish between +-- them. If you need to delete only a single such edge, please use +-- 'delLEdge'. +delEdge :: (DynGraph gr) => Edge -> gr a b -> gr a b +delEdge (v,w) g = case match v g of + (Nothing,_) -> g + (Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) & g' + +-- | Remove an 'LEdge' from the 'Graph'. +-- +-- NOTE: in the case of multiple edges with the same label, this +-- will only delete the /first/ such edge. To delete all such +-- edges, please use 'delAllLedge'. +delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b +delLEdge = delLEdgeBy delete + +-- | Remove all edges equal to the one specified. +delAllLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b +delAllLEdge = delLEdgeBy (filter . (/=)) + +delLEdgeBy :: (DynGraph gr) => ((b,Node) -> Adj b -> Adj b) + -> LEdge b -> gr a b -> gr a b +delLEdgeBy f (v,w,b) g = case match v g of + (Nothing,_) -> g + (Just (p,v',l,s),g') -> (p,v',l,f (b,w) s) & g' + +-- | Insert multiple 'LNode's into the 'Graph'. +insNodes :: (DynGraph gr) => [LNode a] -> gr a b -> gr a b +insNodes vs g = foldl' (flip insNode) g vs +{-# INLINABLE insNodes #-} + +-- | Insert multiple 'LEdge's into the 'Graph'. +insEdges :: (DynGraph gr) => [LEdge b] -> gr a b -> gr a b +insEdges es g = foldl' (flip insEdge) g es +{-# INLINABLE insEdges #-} + +-- | Remove multiple 'Node's from the 'Graph'. +delNodes :: (Graph gr) => [Node] -> gr a b -> gr a b +delNodes vs g = foldl' (snd .: flip match) g vs + +-- | Remove multiple 'Edge's from the 'Graph'. +delEdges :: (DynGraph gr) => [Edge] -> gr a b -> gr a b +delEdges es g = foldl' (flip delEdge) g es + +-- | Build a 'Graph' from a list of 'Context's. +-- +-- The list should be in the order such that earlier 'Context's +-- depend upon later ones (i.e. as produced by @'ufold' (:) []@). +buildGr :: (DynGraph gr) => [Context a b] -> gr a b +buildGr = foldr (&) empty + +-- | Build a quasi-unlabeled 'Graph'. +mkUGraph :: (Graph gr) => [Node] -> [Edge] -> gr () () +mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es) + where + labUEdges = map (`toLEdge` ()) + labUNodes = map (flip (,) ()) + +-- | Build a graph out of the contexts for which the predicate is +-- satisfied by recursively calling 'match'. +gfiltermap :: DynGraph gr => (Context a b -> MContext c d) -> gr a b -> gr c d +gfiltermap f = ufold (maybe id (&) . f) empty + +-- | Returns the subgraph only containing the labelled nodes which +-- satisfy the given predicate. +labnfilter :: Graph gr => (LNode a -> Bool) -> gr a b -> gr a b +labnfilter p gr = delNodes (map fst . filter (not . p) $ labNodes gr) gr + +-- | Returns the subgraph only containing the nodes which satisfy the +-- given predicate. +nfilter :: DynGraph gr => (Node -> Bool) -> gr a b -> gr a b +nfilter f = labnfilter (f . fst) + +-- | Returns the subgraph only containing the nodes whose labels +-- satisfy the given predicate. +labfilter :: DynGraph gr => (a -> Bool) -> gr a b -> gr a b +labfilter f = labnfilter (f . snd) + +-- | Returns the subgraph induced by the supplied nodes. +subgraph :: DynGraph gr => [Node] -> gr a b -> gr a b +subgraph vs = let vs' = IntSet.fromList vs + in nfilter (`IntSet.member` vs') + +-- | Find the context for the given 'Node'. Causes an error if the 'Node' is +-- not present in the 'Graph'. +context :: (Graph gr) => gr a b -> Node -> Context a b +context g v = fromMaybe (panic ("Match Exception, Node: "++show v)) + (fst (match v g)) + +-- | Find the label for a 'Node'. +lab :: (Graph gr) => gr a b -> Node -> Maybe a +lab g v = fmap lab' . fst $ match v g + +-- | Find the neighbors for a 'Node'. +neighbors :: (Graph gr) => gr a b -> Node -> [Node] +neighbors = map snd .: lneighbors + +-- | Find the labelled links coming into or going from a 'Context'. +lneighbors :: (Graph gr) => gr a b -> Node -> Adj b +lneighbors = maybe [] lneighbors' .: mcontext + +-- | Find all 'Node's that have a link from the given 'Node'. +suc :: (Graph gr) => gr a b -> Node -> [Node] +suc = map snd .: context4l + +-- | Find all 'Node's that link to to the given 'Node'. +pre :: (Graph gr) => gr a b -> Node -> [Node] +pre = map snd .: context1l + +-- | Find all 'Node's that are linked from the given 'Node' and the label of +-- each link. +lsuc :: (Graph gr) => gr a b -> Node -> [(Node,b)] +lsuc = map flip2 .: context4l + +-- | Find all 'Node's that link to the given 'Node' and the label of each link. +lpre :: (Graph gr) => gr a b -> Node -> [(Node,b)] +lpre = map flip2 .: context1l + +-- | Find all outward-bound 'LEdge's for the given 'Node'. +out :: (Graph gr) => gr a b -> Node -> [LEdge b] +out g v = map (\(l,w)->(v,w,l)) (context4l g v) + +-- | Find all inward-bound 'LEdge's for the given 'Node'. +inn :: (Graph gr) => gr a b -> Node -> [LEdge b] +inn g v = map (\(l,w)->(w,v,l)) (context1l g v) + +-- | The outward-bound degree of the 'Node'. +outdeg :: (Graph gr) => gr a b -> Node -> Int +outdeg = length .: context4l + +-- | The inward-bound degree of the 'Node'. +indeg :: (Graph gr) => gr a b -> Node -> Int +indeg = length .: context1l + +-- | The degree of the 'Node'. +deg :: (Graph gr) => gr a b -> Node -> Int +deg = deg' .: context + +-- | The 'Node' in a 'Context'. +node' :: Context a b -> Node +node' (_,v,_,_) = v + +-- | The label in a 'Context'. +lab' :: Context a b -> a +lab' (_,_,l,_) = l + +-- | The 'LNode' from a 'Context'. +labNode' :: Context a b -> LNode a +labNode' (_,v,l,_) = (v,l) + +-- | All 'Node's linked to or from in a 'Context'. +neighbors' :: Context a b -> [Node] +neighbors' (p,_,_,s) = map snd p++map snd s + +-- | All labelled links coming into or going from a 'Context'. +lneighbors' :: Context a b -> Adj b +lneighbors' (p,_,_,s) = p ++ s + +-- | All 'Node's linked to in a 'Context'. +suc' :: Context a b -> [Node] +suc' = map snd . context4l' + +-- | All 'Node's linked from in a 'Context'. +pre' :: Context a b -> [Node] +pre' = map snd . context1l' + +-- | All 'Node's linked from in a 'Context', and the label of the links. +lsuc' :: Context a b -> [(Node,b)] +lsuc' = map flip2 . context4l' + +-- | All 'Node's linked from in a 'Context', and the label of the links. +lpre' :: Context a b -> [(Node,b)] +lpre' = map flip2 . context1l' + +-- | All outward-directed 'LEdge's in a 'Context'. +out' :: Context a b -> [LEdge b] +out' c@(_,v,_,_) = map (\(l,w)->(v,w,l)) (context4l' c) + +-- | All inward-directed 'LEdge's in a 'Context'. +inn' :: Context a b -> [LEdge b] +inn' c@(_,v,_,_) = map (\(l,w)->(w,v,l)) (context1l' c) + +-- | The outward degree of a 'Context'. +outdeg' :: Context a b -> Int +outdeg' = length . context4l' + +-- | The inward degree of a 'Context'. +indeg' :: Context a b -> Int +indeg' = length . context1l' + +-- | The degree of a 'Context'. +deg' :: Context a b -> Int +deg' (p,_,_,s) = length p+length s + +-- | Checks if there is a directed edge between two nodes. +hasEdge :: Graph gr => gr a b -> Edge -> Bool +hasEdge gr (v,w) = w `elem` suc gr v + +-- | Checks if there is an undirected edge between two nodes. +hasNeighbor :: Graph gr => gr a b -> Node -> Node -> Bool +hasNeighbor gr v w = w `elem` neighbors gr v + +-- | Checks if there is a labelled edge between two nodes. +hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool +hasLEdge gr (v,w,l) = (w,l) `elem` lsuc gr v + +-- | Checks if there is an undirected labelled edge between two nodes. +hasNeighborAdj :: (Graph gr, Eq b) => gr a b -> Node -> (b,Node) -> Bool +hasNeighborAdj gr v a = a `elem` lneighbors gr v + +---------------------------------------------------------------------- +-- GRAPH EQUALITY +---------------------------------------------------------------------- + +slabNodes :: (Graph gr) => gr a b -> [LNode a] +slabNodes = sortBy (compare `on` fst) . labNodes + +glabEdges :: (Graph gr) => gr a b -> [GroupEdges b] +glabEdges = map (GEs . groupLabels) + . groupBy ((==) `on` toEdge) + . sortBy (compare `on` toEdge) + . labEdges + where + groupLabels les = toLEdge (toEdge (head les)) (map edgeLabel les) + +equal :: (Eq a,Eq b,Graph gr) => gr a b -> gr a b -> Bool +equal g g' = slabNodes g == slabNodes g' && glabEdges g == glabEdges g' +-- This assumes that nodes aren't repeated (which shouldn't happen for +-- sane graph instances). If node IDs are repeated, then the usage of +-- slabNodes cannot guarantee stable ordering. + +-- Newtype wrapper just to test for equality of multiple edges. This +-- is needed because without an Ord constraint on `b' it is not +-- possible to guarantee a stable ordering on edge labels. +newtype GroupEdges b = GEs (LEdge [b]) + deriving (Show, Read) + +instance (Eq b) => Eq (GroupEdges b) where + (GEs (v1,w1,bs1)) == (GEs (v2,w2,bs2)) = v1 == v2 + && w1 == w2 + && eqLists bs1 bs2 + +eqLists :: (Eq a) => [a] -> [a] -> Bool +eqLists xs ys = null (xs \\ ys) && null (ys \\ xs) +-- OK to use \\ here as we want each value in xs to cancel a *single* +-- value in ys. + +---------------------------------------------------------------------- +-- UTILITIES +---------------------------------------------------------------------- + +-- auxiliary functions used in the implementation of the +-- derived class members +-- +(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +-- f .: g = \x y->f (g x y) +-- f .: g = (f .) . g +-- (.:) f = ((f .) .) +-- (.:) = (.) (.) (.) +(.:) = (.) . (.) + +flip2 :: (a,b) -> (b,a) +flip2 (x,y) = (y,x) + +-- projecting on context elements +-- +context1l :: (Graph gr) => gr a b -> Node -> Adj b +context1l = maybe [] context1l' .: mcontext + +context4l :: (Graph gr) => gr a b -> Node -> Adj b +context4l = maybe [] context4l' .: mcontext + +mcontext :: (Graph gr) => gr a b -> Node -> MContext a b +mcontext = fst .: flip match + +context1l' :: Context a b -> Adj b +context1l' (p,v,_,s) = p++filter ((==v).snd) s + +context4l' :: Context a b -> Adj b +context4l' (p,v,_,s) = s++filter ((==v).snd) p + +---------------------------------------------------------------------- +-- PRETTY PRINTING +---------------------------------------------------------------------- + +-- | Pretty-print the graph. Note that this loses a lot of +-- information, such as edge inverses, etc. +prettify :: (DynGraph gr, Show a, Show b) => gr a b -> String +prettify g = foldr (showsContext . context g) id (nodes g) "" + where + showsContext (_,n,l,s) sg = shows n . (':':) . shows l + . showString "->" . shows s + . ('\n':) . sg + +-- | Pretty-print the graph to stdout. +prettyPrint :: (DynGraph gr, Show a, Show b) => gr a b -> IO () +prettyPrint = putStr . prettify + +---------------------------------------------------------------------- +-- Ordered Graph +---------------------------------------------------------------------- + +-- | OrdGr comes equipped with an Ord instance, so that graphs can be +-- used as e.g. Map keys. +newtype OrdGr gr a b = OrdGr { unOrdGr :: gr a b } + deriving (Read,Show) + +instance (Graph gr, Ord a, Ord b) => Eq (OrdGr gr a b) where + g1 == g2 = compare g1 g2 == EQ + +instance (Graph gr, Ord a, Ord b) => Ord (OrdGr gr a b) where + compare (OrdGr g1) (OrdGr g2) = + (compare `on` sort . labNodes) g1 g2 + `mappend` (compare `on` sort . labEdges) g1 g2 + + +{----------------------------------------------------------------- + +Copyright (c) 1999-2008, Martin Erwig + 2010, Ivan Lazar Miljenovic + 2022, Norman Ramsey +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +----------------------------------------------------------------} diff --git a/GHC/Data/Graph/Inductive/PatriciaTree.hs b/GHC/Data/Graph/Inductive/PatriciaTree.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Inductive/PatriciaTree.hs @@ -0,0 +1,344 @@ + +-- |An efficient implementation of 'Data.Graph.Inductive.Graph.Graph' +-- using big-endian patricia tree (i.e. "Data.IntMap"). +-- +-- This module provides the following specialised functions to gain +-- more performance, using GHC's RULES pragma: +-- +-- * 'Data.Graph.Inductive.Graph.insNode' +-- +-- * 'Data.Graph.Inductive.Graph.insEdge' +-- +-- * 'Data.Graph.Inductive.Graph.gmap' +-- +-- * 'Data.Graph.Inductive.Graph.nmap' +-- +-- * 'Data.Graph.Inductive.Graph.emap' +-- +-- Code is from Hackage `fgl` package version 5.7.0.3 + + +module GHC.Data.Graph.Inductive.PatriciaTree + ( Gr + , UGr + ) + where + +import GHC.Prelude + +import GHC.Data.Graph.Inductive.Graph + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.List (sort) +import Data.Maybe (fromMaybe) +import Data.Tuple (swap) + +import qualified Data.IntMap.Strict as IMS + +import GHC.Generics (Generic) + +import Data.Bifunctor + +---------------------------------------------------------------------- +-- GRAPH REPRESENTATION +---------------------------------------------------------------------- + +newtype Gr a b = Gr (GraphRep a b) + deriving (Generic) + +type GraphRep a b = IntMap (Context' a b) +type Context' a b = (IntMap [b], a, IntMap [b]) + +type UGr = Gr () () + +---------------------------------------------------------------------- +-- CLASS INSTANCES +---------------------------------------------------------------------- + +instance (Eq a, Ord b) => Eq (Gr a b) where + (Gr g1) == (Gr g2) = fmap sortAdj g1 == fmap sortAdj g2 + where + sortAdj (p,n,s) = (fmap sort p,n,fmap sort s) + +instance (Show a, Show b) => Show (Gr a b) where + showsPrec d g = showParen (d > 10) $ + showString "mkGraph " + . shows (labNodes g) + . showString " " + . shows (labEdges g) + +instance (Read a, Read b) => Read (Gr a b) where + readsPrec p = readParen (p > 10) $ \ r -> do + ("mkGraph", s) <- lex r + (ns,t) <- reads s + (es,u) <- reads t + return (mkGraph ns es, u) + +instance Graph Gr where + empty = Gr IM.empty + + isEmpty (Gr g) = IM.null g + + match = matchGr + + mkGraph vs es = insEdges es + . Gr + . IM.fromList + . map (second (\l -> (IM.empty,l,IM.empty))) + $ vs + + labNodes (Gr g) = [ (node, label) + | (node, (_, label, _)) <- IM.toList g ] + + noNodes (Gr g) = IM.size g + + nodeRange (Gr g) = fromMaybe (error "nodeRange of empty graph") + $ liftA2 (,) (ix (IM.minViewWithKey g)) + (ix (IM.maxViewWithKey g)) + where + ix = fmap (fst . fst) + + labEdges (Gr g) = do (node, (_, _, s)) <- IM.toList g + (next, labels) <- IM.toList s + label <- labels + return (node, next, label) + +instance DynGraph Gr where + (p, v, l, s) & (Gr g) + = let !g1 = IM.insert v (preds, l, succs) g + !(np, preds) = fromAdjCounting p + !(ns, succs) = fromAdjCounting s + !g2 = addSucc g1 v np preds + !g3 = addPred g2 v ns succs + in Gr g3 + + +instance Functor (Gr a) where + fmap = fastEMap + +instance Bifunctor Gr where + bimap = fastNEMap + + first = fastNMap + + second = fastEMap + + +matchGr :: Node -> Gr a b -> Decomp Gr a b +matchGr node (Gr g) + = case IM.lookup node g of + Nothing + -> (Nothing, Gr g) + + Just (p, label, s) + -> let !g1 = IM.delete node g + !p' = IM.delete node p + !s' = IM.delete node s + !g2 = clearPred g1 node s' + !g3 = clearSucc g2 node p' + in (Just (toAdj p', node, label, toAdj s), Gr g3) + +---------------------------------------------------------------------- +-- OVERRIDING FUNCTIONS +---------------------------------------------------------------------- + +{- + +{- RULES + "insNode/Data.Graph.Inductive.PatriciaTree" insNode = fastInsNode + -} +fastInsNode :: LNode a -> Gr a b -> Gr a b +fastInsNode (v, l) (Gr g) = g' `seq` Gr g' + where + g' = IM.insert v (IM.empty, l, IM.empty) g + +-} +{-# RULES + "insEdge/GHC.Data.Graph.Inductive.PatriciaTree" insEdge = fastInsEdge + #-} +fastInsEdge :: LEdge b -> Gr a b -> Gr a b +fastInsEdge (v, w, l) (Gr g) = g2 `seq` Gr g2 + where + g1 = IM.adjust addS' v g + g2 = IM.adjust addP' w g1 + + addS' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss) + addP' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss) + +{- + +{- RULES + "gmap/Data.Graph.Inductive.PatriciaTree" gmap = fastGMap + -} +fastGMap :: forall a b c d. (Context a b -> Context c d) -> Gr a b -> Gr c d +fastGMap f (Gr g) = Gr (IM.mapWithKey f' g) + where + f' :: Node -> Context' a b -> Context' c d + f' = ((fromContext . f) .) . toContext + +{- RULES + "nmap/Data.Graph.Inductive.PatriciaTree" nmap = fastNMap + -} +-} +fastNMap :: forall a b c. (a -> c) -> Gr a b -> Gr c b +fastNMap f (Gr g) = Gr (IM.map f' g) + where + f' :: Context' a b -> Context' c b + f' (ps, a, ss) = (ps, f a, ss) +{- + +{- RULES + "emap/GHC.Data.Graph.Inductive.PatriciaTree" emap = fastEMap + -} +-} +fastEMap :: forall a b c. (b -> c) -> Gr a b -> Gr a c +fastEMap f (Gr g) = Gr (IM.map f' g) + where + f' :: Context' a b -> Context' a c + f' (ps, a, ss) = (IM.map (map f) ps, a, IM.map (map f) ss) + +{- RULES + "nemap/GHC.Data.Graph.Inductive.PatriciaTree" nemap = fastNEMap + -} + +fastNEMap :: forall a b c d. (a -> c) -> (b -> d) -> Gr a b -> Gr c d +fastNEMap fn fe (Gr g) = Gr (IM.map f g) + where + f :: Context' a b -> Context' c d + f (ps, a, ss) = (IM.map (map fe) ps, fn a, IM.map (map fe) ss) + + + +---------------------------------------------------------------------- +-- UTILITIES +---------------------------------------------------------------------- + +toAdj :: IntMap [b] -> Adj b +toAdj = concatMap expand . IM.toList + where + expand (n,ls) = map (flip (,) n) ls + +--fromAdj :: Adj b -> IntMap [b] +--fromAdj = IM.fromListWith addLists . map (second (:[]) . swap) + +data FromListCounting a = FromListCounting !Int !(IntMap a) + deriving (Eq, Show, Read) + +getFromListCounting :: FromListCounting a -> (Int, IntMap a) +getFromListCounting (FromListCounting i m) = (i, m) +{-# INLINE getFromListCounting #-} + +fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a) +fromListWithKeyCounting f = getFromListCounting . foldl' ins (FromListCounting 0 IM.empty) + where + ins (FromListCounting i t) (k,x) = FromListCounting (i + 1) (IM.insertWithKey f k x t) +{-# INLINE fromListWithKeyCounting #-} + +fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a) +fromListWithCounting f = fromListWithKeyCounting (\_ x y -> f x y) +{-# INLINE fromListWithCounting #-} + +fromAdjCounting :: Adj b -> (Int, IntMap [b]) +fromAdjCounting = fromListWithCounting addLists . map (second (:[]) . swap) + +-- We use differenceWith to modify a graph more than bulkThreshold times, +-- and repeated insertWith otherwise. +bulkThreshold :: Int +bulkThreshold = 5 + +--toContext :: Node -> Context' a b -> Context a b +--toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss) + +--fromContext :: Context a b -> Context' a b +--fromContext (ps, _, a, ss) = (fromAdj ps, a, fromAdj ss) + +-- A version of @++@ where order isn't important, so @xs ++ [x]@ +-- becomes @x:xs@. Used when we have to have a function of type @[a] +-- -> [a] -> [a]@ but one of the lists is just going to be a single +-- element (and it isn't possible to tell which). +addLists :: [a] -> [a] -> [a] +addLists [a] as = a : as +addLists as [a] = a : as +addLists xs ys = xs ++ ys + +addSucc :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b +addSucc g0 v numAdd xs + | numAdd < bulkThreshold = foldlWithKey' go g0 xs + where + go :: GraphRep a b -> Node -> [b] -> GraphRep a b + go g p l = IMS.adjust f p g + where f (ps, l', ss) = let !ss' = IM.insertWith addLists v l ss + in (ps, l', ss') +addSucc g v _ xs = IMS.differenceWith go g xs + where + go :: Context' a b -> [b] -> Maybe (Context' a b) + go (ps, l', ss) l = let !ss' = IM.insertWith addLists v l ss + in Just (ps, l', ss') + +foldlWithKey' :: (a -> IM.Key -> b -> a) -> a -> IntMap b -> a +foldlWithKey' = + IM.foldlWithKey' + +addPred :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b +addPred g0 v numAdd xs + | numAdd < bulkThreshold = foldlWithKey' go g0 xs + where + go :: GraphRep a b -> Node -> [b] -> GraphRep a b + go g p l = IMS.adjust f p g + where f (ps, l', ss) = let !ps' = IM.insertWith addLists v l ps + in (ps', l', ss) +addPred g v _ xs = IMS.differenceWith go g xs + where + go :: Context' a b -> [b] -> Maybe (Context' a b) + go (ps, l', ss) l = let !ps' = IM.insertWith addLists v l ps + in Just (ps', l', ss) + +clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b +clearSucc g v = IMS.differenceWith go g + where + go :: Context' a b -> x -> Maybe (Context' a b) + go (ps, l, ss) _ = let !ss' = IM.delete v ss + in Just (ps, l, ss') + +clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b +clearPred g v = IMS.differenceWith go g + where + go :: Context' a b -> x -> Maybe (Context' a b) + go (ps, l, ss) _ = let !ps' = IM.delete v ps + in Just (ps', l, ss) + +{----------------------------------------------------------------- + +Copyright (c) 1999-2008, Martin Erwig + 2010, Ivan Lazar Miljenovic + 2022, Norman Ramsey +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +----------------------------------------------------------------} diff --git a/GHC/Data/Graph/Ops.hs b/GHC/Data/Graph/Ops.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Ops.hs @@ -0,0 +1,699 @@ +-- | Basic operations on graphs. +-- + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Data.Graph.Ops + ( addNode + , delNode + , getNode + , lookupNode + , modNode + + , size + , union + + , addConflict + , delConflict + , addConflicts + + , addCoalesce + , delCoalesce + + , addExclusion + , addExclusions + + , addPreference + , coalesceNodes + , coalesceGraph + , freezeNode + , freezeOneInGraph + , freezeAllInGraph + , scanGraph + , setColor + , validateGraph + , slurpNodeConflictCount + ) +where + +import GHC.Prelude + +import GHC.Data.Graph.Base + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + +import Data.List (mapAccumL, sortBy) +import Data.Maybe + +-- | Lookup a node from the graph. +lookupNode + :: Uniquable k + => Graph k cls color + -> k -> Maybe (Node k cls color) + +lookupNode graph k + = lookupUFM (graphMap graph) k + + +-- | Get a node from the graph, throwing an error if it's not there +getNode + :: Uniquable k + => Graph k cls color + -> k -> Node k cls color + +getNode graph k + = case lookupUFM (graphMap graph) k of + Just node -> node + Nothing -> panic "ColorOps.getNode: not found" + + +-- | Add a node to the graph, linking up its edges +addNode :: Uniquable k + => k -> Node k cls color + -> Graph k cls color -> Graph k cls color + +addNode k node graph + = let + -- add back conflict edges from other nodes to this one + map_conflict = + nonDetStrictFoldUniqSet + -- It's OK to use a non-deterministic fold here because the + -- operation is commutative + (adjustUFM_C (\n -> n { nodeConflicts = + addOneToUniqSet (nodeConflicts n) k})) + (graphMap graph) + (nodeConflicts node) + + -- add back coalesce edges from other nodes to this one + map_coalesce = + nonDetStrictFoldUniqSet + -- It's OK to use a non-deterministic fold here because the + -- operation is commutative + (adjustUFM_C (\n -> n { nodeCoalesce = + addOneToUniqSet (nodeCoalesce n) k})) + map_conflict + (nodeCoalesce node) + + in graph + { graphMap = addToUFM map_coalesce k node} + + +-- | Delete a node and all its edges from the graph. +delNode :: (Uniquable k) + => k -> Graph k cls color -> Maybe (Graph k cls color) + +delNode k graph + | Just node <- lookupNode graph k + = let -- delete conflict edges from other nodes to this one. + graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph + $ nonDetEltsUniqSet (nodeConflicts node) + + -- delete coalesce edge from other nodes to this one. + graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 + $ nonDetEltsUniqSet (nodeCoalesce node) + -- See Note [Unique Determinism and code generation] + + -- delete the node + graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 + + in Just graph3 + + | otherwise + = Nothing + + +-- | Modify a node in the graph. +-- returns Nothing if the node isn't present. +-- +modNode :: Uniquable k + => (Node k cls color -> Node k cls color) + -> k -> Graph k cls color -> Maybe (Graph k cls color) + +modNode f k graph + = case lookupNode graph k of + Just Node{} + -> Just + $ graphMapModify + (\fm -> let Just node = lookupUFM fm k + node' = f node + in addToUFM fm k node') + graph + + Nothing -> Nothing + + +-- | Get the size of the graph, O(n) +size :: Graph k cls color -> Int + +size graph + = sizeUFM $ graphMap graph + + +-- | Union two graphs together. +union :: Graph k cls color -> Graph k cls color -> Graph k cls color + +union graph1 graph2 + = Graph + { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } + + +-- | Add a conflict between nodes to the graph, creating the nodes required. +-- Conflicts are virtual regs which need to be colored differently. +addConflict + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addConflict (u1, c1) (u2, c2) + = let addNeighbor u c u' + = adjustWithDefaultUFM + (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) + (newNode u c) { nodeConflicts = unitUniqSet u' } + u + + in graphMapModify + ( addNeighbor u1 c1 u2 + . addNeighbor u2 c2 u1) + + +-- | Delete a conflict edge. k1 -> k2 +-- returns Nothing if the node isn't in the graph +delConflict + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + +delConflict k1 k2 + = modNode + (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) + k1 + + +-- | Add some conflicts to the graph, creating nodes if required. +-- All the nodes in the set are taken to conflict with each other. +addConflicts + :: Uniquable k + => UniqSet k -> (k -> cls) + -> Graph k cls color -> Graph k cls color + +addConflicts conflicts getClass + + -- just a single node, but no conflicts, create the node anyway. + | (u : []) <- nonDetEltsUniqSet conflicts + = graphMapModify + $ adjustWithDefaultUFM + id + (newNode u (getClass u)) + u + + | otherwise + = graphMapModify + $ \fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm + $ nonDetEltsUniqSet conflicts + -- See Note [Unique Determinism and code generation] + + +addConflictSet1 :: Uniquable k + => k -> (k -> cls) -> UniqSet k + -> UniqFM k (Node k cls color) + -> UniqFM k (Node k cls color) +addConflictSet1 u getClass set + = case delOneFromUniqSet set u of + set' -> adjustWithDefaultUFM + (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) + (newNode u (getClass u)) { nodeConflicts = set' } + u + + +-- | Add an exclusion to the graph, creating nodes if required. +-- These are extra colors that the node cannot use. +addExclusion + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> color + -> Graph k cls color -> Graph k cls color + +addExclusion u getClass color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) + (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } + u + +addExclusions + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> [color] + -> Graph k cls color -> Graph k cls color + +addExclusions u getClass colors graph + = foldr (addExclusion u getClass) graph colors + + +-- | Add a coalescence edge to the graph, creating nodes if required. +-- It is considered advantageous to assign the same color to nodes in a coalescence. +addCoalesce + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addCoalesce (u1, c1) (u2, c2) + = let addCoalesce u c u' + = adjustWithDefaultUFM + (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) + (newNode u c) { nodeCoalesce = unitUniqSet u' } + u + + in graphMapModify + ( addCoalesce u1 c1 u2 + . addCoalesce u2 c2 u1) + + +-- | Delete a coalescence edge (k1 -> k2) from the graph. +delCoalesce + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + +delCoalesce k1 k2 + = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) + k1 + + +-- | Add a color preference to the graph, creating nodes if required. +-- The most recently added preference is the most preferred. +-- The algorithm tries to assign a node it's preferred color if possible. +-- +addPreference + :: Uniquable k + => (k, cls) -> color + -> Graph k cls color -> Graph k cls color + +addPreference (u, c) color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodePreference = color : (nodePreference node) }) + (newNode u c) { nodePreference = [color] } + u + + +-- | Do aggressive coalescing on this graph. +-- returns the new graph and the list of pairs of nodes that got coalesced together. +-- for each pair, the resulting node will have the least key and be second in the pair. +-- +coalesceGraph + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> ( Graph k cls color + , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the + -- coalescing was applied. + +coalesceGraph aggressive triv graph + = coalesceGraph' aggressive triv graph [] + +coalesceGraph' + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> [(k, k)] + -> ( Graph k cls color + , [(k, k)]) +coalesceGraph' aggressive triv graph kkPairsAcc + = let + -- find all the nodes that have coalescence edges + cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + -- build a list of pairs of keys for node's we'll try and coalesce + -- every pair of nodes will appear twice in this list + -- ie [(k1, k2), (k2, k1) ... ] + -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for + -- build a list of what nodes get coalesced together for later on. + -- + cList = [ (nodeId node1, k2) + | node1 <- cNodes + , k2 <- nonDetEltsUniqSet $ nodeCoalesce node1 ] + -- See Note [Unique Determinism and code generation] + + -- do the coalescing, returning the new graph and a list of pairs of keys + -- that got coalesced together. + (graph', mPairs) + = mapAccumL (coalesceNodes aggressive triv) graph cList + + -- keep running until there are no more coalesces can be found + in case catMaybes mPairs of + [] -> (graph', reverse kkPairsAcc) + pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) + + +-- | Coalesce this pair of nodes unconditionally \/ aggressively. +-- The resulting node is the one with the least key. +-- +-- returns: Just the pair of keys if the nodes were coalesced +-- the second element of the pair being the least one +-- +-- Nothing if either of the nodes weren't in the graph + +coalesceNodes + :: (Uniquable k, Ord k, Eq cls) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> (k, k) -- ^ keys of the nodes to be coalesced + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes aggressive triv graph (k1, k2) + | (kMin, kMax) <- if k1 < k2 + then (k1, k2) + else (k2, k1) + + -- the nodes being coalesced must be in the graph + , Just nMin <- lookupNode graph kMin + , Just nMax <- lookupNode graph kMax + + -- can't coalesce conflicting modes + , not $ elementOfUniqSet kMin (nodeConflicts nMax) + , not $ elementOfUniqSet kMax (nodeConflicts nMin) + + -- can't coalesce the same node + , nodeId nMin /= nodeId nMax + + = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + + -- don't do the coalescing after all + | otherwise + = (graph, Nothing) + +coalesceNodes_merge + :: (Uniquable k, Eq cls) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + + -- sanity checks + | nodeClass nMin /= nodeClass nMax + = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce nodes of different classes." + + | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) + = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce colored nodes." + + --- + | otherwise + = let + -- the new node gets all the edges from its two components + node = + Node { nodeId = kMin + , nodeClass = nodeClass nMin + , nodeColor = Nothing + + -- nodes don't conflict with themselves.. + , nodeConflicts + = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + + , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) + , nodePreference = nodePreference nMin ++ nodePreference nMax + + -- nodes don't coalesce with themselves.. + , nodeCoalesce + = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + } + + in coalesceNodes_check aggressive triv graph kMin kMax node + +coalesceNodes_check + :: Uniquable k + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes_check aggressive triv graph kMin kMax node + + -- Unless we're coalescing aggressively, if the result node is not trivially + -- colorable then don't do the coalescing. + | not aggressive + , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = (graph, Nothing) + + | otherwise + = let -- delete the old nodes from the graph and add the new one + Just graph1 = delNode kMax graph + Just graph2 = delNode kMin graph1 + graph3 = addNode kMin node graph2 + + in (graph3, Just (kMax, kMin)) + + +-- | Freeze a node +-- This is for the iterative coalescer. +-- By freezing a node we give up on ever coalescing it. +-- Move all its coalesce edges into the frozen set - and update +-- back edges from other nodes. +-- +freezeNode + :: Uniquable k + => k -- ^ key of the node to freeze + -> Graph k cls color -- ^ the graph + -> Graph k cls color -- ^ graph with that node frozen + +freezeNode k + = graphMapModify + $ \fm -> + let -- freeze all the edges in the node to be frozen + Just node = lookupUFM fm k + node' = node + { nodeCoalesce = emptyUniqSet } + + fm1 = addToUFM fm k node' + + -- update back edges pointing to this node + freezeEdge k node + = if elementOfUniqSet k (nodeCoalesce node) + then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } + else node -- panic "GHC.Data.Graph.Ops.freezeNode: edge to freeze wasn't in the coalesce set" + -- If the edge isn't actually in the coalesce set then just ignore it. + + fm2 = nonDetStrictFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1 + -- It's OK to use a non-deterministic fold here because the + -- operation is commutative + $ nodeCoalesce node + + in fm2 + + +-- | Freeze one node in the graph +-- This if for the iterative coalescer. +-- Look for a move related node of low degree and freeze it. +-- +-- We probably don't need to scan the whole graph looking for the node of absolute +-- lowest degree. Just sample the first few and choose the one with the lowest +-- degree out of those. Also, we don't make any distinction between conflicts of different +-- classes.. this is just a heuristic, after all. +-- +-- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv +-- right here, and add it to a worklist if known triv\/non-move nodes. +-- +freezeOneInGraph + :: (Uniquable k) + => Graph k cls color + -> ( Graph k cls color -- the new graph + , Bool ) -- whether we found a node to freeze + +freezeOneInGraph graph + = let compareNodeDegree n1 n2 + = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) + + candidates + = sortBy compareNodeDegree + $ take 5 -- 5 isn't special, it's just a small number. + $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph + + in case candidates of + + -- there wasn't anything available to freeze + [] -> (graph, False) + + -- we found something to freeze + (n : _) + -> ( freezeNode (nodeId n) graph + , True) + + +-- | Freeze all the nodes in the graph +-- for debugging the iterative allocator. +-- +freezeAllInGraph + :: (Uniquable k) + => Graph k cls color + -> Graph k cls color + +freezeAllInGraph graph + = foldr freezeNode graph + $ map nodeId + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + +-- | Find all the nodes in the graph that meet some criteria +-- +scanGraph + :: (Node k cls color -> Bool) + -> Graph k cls color + -> [Node k cls color] + +scanGraph match graph + = filter match $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + +-- | validate the internal structure of a graph +-- all its edges should point to valid nodes +-- If they don't then throw an error +-- +validateGraph + :: (Uniquable k, Outputable k, Eq color) + => SDoc -- ^ extra debugging info to display on error + -> Bool -- ^ whether this graph is supposed to be colored. + -> Graph k cls color -- ^ graph to validate + -> Graph k cls color -- ^ validated graph + +validateGraph doc isColored graph + + -- Check that all edges point to valid nodes. + | edges <- unionManyUniqSets + ( (map nodeConflicts $ nonDetEltsUFM $ graphMap graph) + ++ (map nodeCoalesce $ nonDetEltsUFM $ graphMap graph)) + + , nodes <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph + , badEdges <- minusUniqSet edges nodes + , not $ isEmptyUniqSet badEdges + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Graph has edges that point to non-existent nodes" + $$ text " bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr) + $$ doc ) + + -- Check that no conflicting nodes have the same color + | badNodes <- filter (not . (checkNode graph)) + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + , not $ null badNodes + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Node has same color as one of it's conflicts" + $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc) + + -- If this is supposed to be a colored graph, + -- check that all nodes have a color. + | isColored + , badNodes <- filter (\n -> isNothing $ nodeColor n) + $ nonDetEltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Supposedly colored graph has uncolored nodes." + $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc ) + + + -- graph looks ok + | otherwise + = graph + + +-- | If this node is colored, check that all the nodes which +-- conflict with it have different colors. +checkNode + :: (Uniquable k, Eq color) + => Graph k cls color + -> Node k cls color + -> Bool -- ^ True if this node is ok + +checkNode graph node + | Just color <- nodeColor node + , Just neighbors <- sequence $ map (lookupNode graph) + $ nonDetEltsUniqSet $ nodeConflicts node + -- See Note [Unique Determinism and code generation] + + , neighbourColors <- mapMaybe nodeColor neighbors + , elem color neighbourColors + = False + + | otherwise + = True + + + +-- | Slurp out a map of how many nodes had a certain number of conflict neighbours + +slurpNodeConflictCount + :: Graph k cls color + -> UniqFM Int (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) + +slurpNodeConflictCount graph + = addListToUFM_C + (\(c1, n1) (_, n2) -> (c1, n1 + n2)) + emptyUFM + $ map (\node + -> let count = sizeUniqSet $ nodeConflicts node + in (count, (count, 1))) + $ nonDetEltsUFM + -- See Note [Unique Determinism and code generation] + $ graphMap graph + + +-- | Set the color of a certain node +setColor + :: Uniquable k + => k -> color + -> Graph k cls color -> Graph k cls color + +setColor u color + = graphMapModify + $ adjustUFM_C + (\n -> n { nodeColor = Just color }) + u + + +{-# INLINE adjustWithDefaultUFM #-} +adjustWithDefaultUFM + :: Uniquable k + => (a -> a) -> a -> k + -> UniqFM k a -> UniqFM k a + +adjustWithDefaultUFM f def k map + = addToUFM_C + (\old _ -> f old) + map + k def + +-- Argument order different from UniqFM's adjustUFM +{-# INLINE adjustUFM_C #-} +adjustUFM_C + :: Uniquable k + => (a -> a) + -> k -> UniqFM k a -> UniqFM k a + +adjustUFM_C f k map + = case lookupUFM map k of + Nothing -> map + Just a -> addToUFM map k (f a) + diff --git a/GHC/Data/Graph/Ppr.hs b/GHC/Data/Graph/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Ppr.hs @@ -0,0 +1,173 @@ + +-- | Pretty printing of graphs. + +module GHC.Data.Graph.Ppr + ( dumpGraph + , dotGraph + ) +where + +import GHC.Prelude + +import GHC.Data.Graph.Base + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + +import Data.List (mapAccumL) +import Data.Maybe + + +-- | Pretty print a graph in a somewhat human readable format. +dumpGraph + :: (Outputable k, Outputable color) + => Graph k cls color -> SDoc + +dumpGraph graph + = text "Graph" + $$ pprUFM (graphMap graph) (vcat . map dumpNode) + +dumpNode + :: (Outputable k, Outputable color) + => Node k cls color -> SDoc + +dumpNode node + = text "Node " <> ppr (nodeId node) + $$ text "conflicts " + <> parens (int (sizeUniqSet $ nodeConflicts node)) + <> text " = " + <> ppr (nodeConflicts node) + + $$ text "exclusions " + <> parens (int (sizeUniqSet $ nodeExclusions node)) + <> text " = " + <> ppr (nodeExclusions node) + + $$ text "coalesce " + <> parens (int (sizeUniqSet $ nodeCoalesce node)) + <> text " = " + <> ppr (nodeCoalesce node) + + $$ space + + + +-- | Pretty print a graph in graphviz .dot format. +-- Conflicts get solid edges. +-- Coalescences get dashed edges. +dotGraph + :: ( Uniquable k + , Outputable k, Outputable cls, Outputable color) + => (color -> SDoc) -- ^ What graphviz color to use for each node color + -- It's usually safe to return X11 style colors here, + -- ie "red", "green" etc or a hex triplet #aaff55 etc + -> Triv k cls color + -> Graph k cls color -> SDoc + +dotGraph colorMap triv graph + = let nodes = nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + in vcat + ( [ text "graph G {" ] + ++ map (dotNode colorMap triv) nodes + ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes) + ++ [ text "}" + , space ]) + + +dotNode :: ( Outputable k, Outputable cls, Outputable color) + => (color -> SDoc) + -> Triv k cls color + -> Node k cls color -> SDoc + +dotNode colorMap triv node + = let name = ppr $ nodeId node + cls = ppr $ nodeClass node + + excludes + = hcat $ punctuate space + $ map (\n -> text "-" <> ppr n) + $ nonDetEltsUniqSet $ nodeExclusions node + -- See Note [Unique Determinism and code generation] + + preferences + = hcat $ punctuate space + $ map (\n -> text "+" <> ppr n) + $ nodePreference node + + expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)] + then empty + else text "\\n" <> (excludes <+> preferences) + + -- if the node has been colored then show that, + -- otherwise indicate whether it looks trivially colorable. + color + | Just c <- nodeColor node + = text "\\n(" <> ppr c <> text ")" + + | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = text "\\n(" <> text "triv" <> text ")" + + | otherwise + = text "\\n(" <> text "spill?" <> text ")" + + label = name <> text " :: " <> cls + <> expref + <> color + + pcolorC = case nodeColor node of + Nothing -> text "style=filled fillcolor=white" + Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c) + + + pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]" + <> space <> doubleQuotes name + <> text ";" + + in pout + + +-- | Nodes in the graph are doubly linked, but we only want one edge for each +-- conflict if the graphviz graph. Traverse over the graph, but make sure +-- to only print the edges for each node once. + +dotNodeEdges + :: ( Uniquable k + , Outputable k) + => UniqSet k + -> Node k cls color + -> (UniqSet k, Maybe SDoc) + +dotNodeEdges visited node + | elementOfUniqSet (nodeId node) visited + = ( visited + , Nothing) + + | otherwise + = let dconflicts + = map (dotEdgeConflict (nodeId node)) + $ nonDetEltsUniqSet + -- See Note [Unique Determinism and code generation] + $ minusUniqSet (nodeConflicts node) visited + + dcoalesces + = map (dotEdgeCoalesce (nodeId node)) + $ nonDetEltsUniqSet + -- See Note [Unique Determinism and code generation] + $ minusUniqSet (nodeCoalesce node) visited + + out = vcat dconflicts + $$ vcat dcoalesces + + in ( addOneToUniqSet visited (nodeId node) + , Just out) + + where dotEdgeConflict u1 u2 + = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) + <> text ";" + + dotEdgeCoalesce u1 u2 + = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) + <> space <> text "[ style = dashed ];" diff --git a/GHC/Data/Graph/UnVar.hs b/GHC/Data/Graph/UnVar.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/UnVar.hs @@ -0,0 +1,188 @@ +{- + +Copyright (c) 2014 Joachim Breitner + +A data structure for undirected graphs of variables +(or in plain terms: Sets of unordered pairs of numbers) + + +This is very specifically tailored for the use in CallArity. In particular it +stores the graph as a union of complete and complete bipartite graph, which +would be very expensive to store as sets of edges or as adjanceny lists. + +It does not normalize the graphs. This means that g `unionUnVarGraph` g is +equal to g, but twice as expensive and large. + +-} +module GHC.Data.Graph.UnVar + ( UnVarSet + , emptyUnVarSet, mkUnVarSet, unionUnVarSet, unionUnVarSets + , extendUnVarSet, extendUnVarSetList, delUnVarSet, delUnVarSetList + , elemUnVarSet, isEmptyUnVarSet + , UnVarGraph + , emptyUnVarGraph + , unionUnVarGraph, unionUnVarGraphs + , completeGraph, completeBipartiteGraph + , neighbors + , hasLoopAt + , delNode + , domUFMUnVarSet + ) where + +import GHC.Prelude + +import GHC.Types.Unique.FM( UniqFM, ufmToSet_Directly ) +import GHC.Types.Var +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Word + +import qualified GHC.Data.Word64Set as S + +-- We need a type for sets of variables (UnVarSet). +-- We do not use VarSet, because for that we need to have the actual variable +-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. +-- Therefore, use a IntSet directly (which is likely also a bit more efficient). + +-- Set of uniques, i.e. for adjacent nodes +newtype UnVarSet = UnVarSet S.Word64Set + deriving Eq + +k :: Var -> Word64 +k v = getKey (getUnique v) + +domUFMUnVarSet :: UniqFM key elt -> UnVarSet +domUFMUnVarSet ae = UnVarSet $ ufmToSet_Directly ae + +emptyUnVarSet :: UnVarSet +emptyUnVarSet = UnVarSet S.empty + +elemUnVarSet :: Var -> UnVarSet -> Bool +elemUnVarSet v (UnVarSet s) = k v `S.member` s + + +isEmptyUnVarSet :: UnVarSet -> Bool +isEmptyUnVarSet (UnVarSet s) = S.null s + +delUnVarSet :: UnVarSet -> Var -> UnVarSet +delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s + +delUnVarSetList :: UnVarSet -> [Var] -> UnVarSet +delUnVarSetList s vs = s `minusUnVarSet` mkUnVarSet vs + +minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet +minusUnVarSet (UnVarSet s) (UnVarSet s') = UnVarSet $ s `S.difference` s' + +sizeUnVarSet :: UnVarSet -> Int +sizeUnVarSet (UnVarSet s) = S.size s + +mkUnVarSet :: [Var] -> UnVarSet +mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs + +extendUnVarSet :: Var -> UnVarSet -> UnVarSet +extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s + +extendUnVarSetList :: [Var] -> UnVarSet -> UnVarSet +extendUnVarSetList vs s = s `unionUnVarSet` mkUnVarSet vs + +unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet +unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) + +unionUnVarSets :: [UnVarSet] -> UnVarSet +unionUnVarSets = foldl' (flip unionUnVarSet) emptyUnVarSet + +instance Outputable UnVarSet where + ppr (UnVarSet s) = braces $ + hcat $ punctuate comma [ ppr (mkUniqueGrimily i) | i <- S.toList s] + +data UnVarGraph = CBPG !UnVarSet !UnVarSet -- ^ complete bipartite graph + | CG !UnVarSet -- ^ complete graph + | Union UnVarGraph UnVarGraph + | Del !UnVarSet UnVarGraph + +emptyUnVarGraph :: UnVarGraph +emptyUnVarGraph = CG emptyUnVarSet + +unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph +{- +Premature optimisation, it seems. +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s1 == s3 && s2 == s4 + = pprTrace "unionUnVarGraph fired" empty $ + completeGraph (s1 `unionUnVarSet` s2) +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s2 == s3 && s1 == s4 + = pprTrace "unionUnVarGraph fired2" empty $ + completeGraph (s1 `unionUnVarSet` s2) +-} +unionUnVarGraph a b + | is_null a = b + | is_null b = a + | otherwise = Union a b + +unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph +unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph + +-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } +completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph +completeBipartiteGraph s1 s2 = prune $ CBPG s1 s2 + +completeGraph :: UnVarSet -> UnVarGraph +completeGraph s = prune $ CG s + +-- (v' ∈ neighbors G v) <=> v--v' ∈ G +neighbors :: UnVarGraph -> Var -> UnVarSet +neighbors = go + where + go (Del d g) v + | v `elemUnVarSet` d = emptyUnVarSet + | otherwise = go g v `minusUnVarSet` d + go (Union g1 g2) v = go g1 v `unionUnVarSet` go g2 v + go (CG s) v = if v `elemUnVarSet` s then s else emptyUnVarSet + go (CBPG s1 s2) v = (if v `elemUnVarSet` s1 then s2 else emptyUnVarSet) `unionUnVarSet` + (if v `elemUnVarSet` s2 then s1 else emptyUnVarSet) + +-- hasLoopAt G v <=> v--v ∈ G +hasLoopAt :: UnVarGraph -> Var -> Bool +hasLoopAt = go + where + go (Del d g) v + | v `elemUnVarSet` d = False + | otherwise = go g v + go (Union g1 g2) v = go g1 v || go g2 v + go (CG s) v = v `elemUnVarSet` s + go (CBPG s1 s2) v = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 + +delNode :: UnVarGraph -> Var -> UnVarGraph +delNode (Del d g) v = Del (extendUnVarSet v d) g +delNode g v + | is_null g = emptyUnVarGraph + | otherwise = Del (mkUnVarSet [v]) g + +-- | Resolves all `Del`, by pushing them in, and simplifies `∅ ∪ … = …` +prune :: UnVarGraph -> UnVarGraph +prune = go emptyUnVarSet + where + go :: UnVarSet -> UnVarGraph -> UnVarGraph + go dels (Del dels' g) = go (dels `unionUnVarSet` dels') g + go dels (Union g1 g2) + | is_null g1' = g2' + | is_null g2' = g1' + | otherwise = Union g1' g2' + where + g1' = go dels g1 + g2' = go dels g2 + go dels (CG s) = CG (s `minusUnVarSet` dels) + go dels (CBPG s1 s2) = CBPG (s1 `minusUnVarSet` dels) (s2 `minusUnVarSet` dels) + +-- | Shallow empty check. +is_null :: UnVarGraph -> Bool +is_null (CBPG s1 s2) = isEmptyUnVarSet s1 || isEmptyUnVarSet s2 +is_null (CG s) = isEmptyUnVarSet s +is_null _ = False + +instance Outputable UnVarGraph where + ppr (Del d g) = text "Del" <+> ppr (sizeUnVarSet d) <+> parens (ppr g) + ppr (Union a b) = text "Union" <+> parens (ppr a) <+> parens (ppr b) + ppr (CG s) = text "CG" <+> ppr (sizeUnVarSet s) + ppr (CBPG a b) = text "CBPG" <+> ppr (sizeUnVarSet a) <+> ppr (sizeUnVarSet b) diff --git a/GHC/Data/IOEnv.hs b/GHC/Data/IOEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/IOEnv.hs @@ -0,0 +1,260 @@ + +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PatternSynonyms #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | The IO Monad with an environment +-- +-- The environment is passed around as a Reader monad but +-- as its in the IO monad, mutable references can be used +-- for updating state. +-- +module GHC.Data.IOEnv ( + IOEnv, -- Instance of Monad + + -- Monad utilities + module GHC.Utils.Monad, + + -- Errors + failM, failWithM, + IOEnvFailure(..), + + -- Getting at the environment + getEnv, setEnv, updEnv, updEnvIO, + + runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, + tryM, tryAllM, tryMostM, fixM, + + -- I/O operations + IORef, newMutVar, readMutVar, writeMutVar, updMutVar, + atomicUpdMutVar, atomicUpdMutVar' + ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import {-# SOURCE #-} GHC.Driver.Hooks +import GHC.IO (catchException) +import GHC.Utils.Exception +import GHC.Unit.Module +import GHC.Utils.Panic + +import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, + atomicModifyIORef, atomicModifyIORef' ) +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO ( fixIO ) +import Control.Monad +import Control.Monad.Trans.Reader +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import GHC.Utils.Monad +import GHC.Utils.Logger +import Control.Applicative (Alternative(..)) +import GHC.Exts( oneShot ) +import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar) +import Control.Concurrent (forkIO, killThread) + +---------------------------------------------------------------------- +-- Defining the monad type +---------------------------------------------------------------------- + + +newtype IOEnv env a = IOEnv' (env -> IO a) + deriving (MonadThrow, MonadCatch, MonadMask, MonadFix) via (ReaderT env IO) + + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +instance Functor (IOEnv env) where + fmap f (IOEnv g) = IOEnv $ \env -> fmap f (g env) + a <$ IOEnv g = IOEnv $ \env -> g env >> pure a + +instance MonadIO (IOEnv env) where + liftIO f = IOEnv (\_ -> f) + +pattern IOEnv :: forall env a. (env -> IO a) -> IOEnv env a +pattern IOEnv m <- IOEnv' m + where + IOEnv m = IOEnv' (oneShot m) + +{-# COMPLETE IOEnv #-} + +unIOEnv :: IOEnv env a -> (env -> IO a) +unIOEnv (IOEnv m) = m + +instance Monad (IOEnv m) where + (>>=) = thenM + (>>) = (*>) + +instance MonadFail (IOEnv m) where + fail _ = failM -- Ignore the string + +instance Applicative (IOEnv m) where + pure = returnM + IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env ) + (*>) = thenM_ + +returnM :: a -> IOEnv env a +returnM a = IOEnv (\ _ -> return a) + +thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b +thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ; + unIOEnv (f r) env }) + +thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b +thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env }) + +failM :: IOEnv env a +failM = IOEnv (\ _ -> throwIO IOEnvFailure) + +failWithM :: String -> IOEnv env a +failWithM s = IOEnv (\ _ -> ioError (userError s)) + +data IOEnvFailure = IOEnvFailure + +instance Show IOEnvFailure where + show IOEnvFailure = "IOEnv failure" + +instance Exception IOEnvFailure + +instance ContainsDynFlags env => HasDynFlags (IOEnv env) where + getDynFlags = do env <- getEnv + return $! extractDynFlags env + +instance ContainsHooks env => HasHooks (IOEnv env) where + getHooks = do env <- getEnv + return $! extractHooks env + +instance ContainsLogger env => HasLogger (IOEnv env) where + getLogger = do env <- getEnv + return $! extractLogger env + + +instance ContainsModule env => HasModule (IOEnv env) where + getModule = do env <- getEnv + return $ extractModule env + +---------------------------------------------------------------------- +-- Fundamental combinators specific to the monad +---------------------------------------------------------------------- + + +--------------------------- +runIOEnv :: env -> IOEnv env a -> IO a +runIOEnv env (IOEnv m) = m env + + +--------------------------- +{-# NOINLINE fixM #-} + -- Aargh! Not inlining fixM alleviates a space leak problem. + -- Normally fixM is used with a lazy tuple match: if the optimiser is + -- shown the definition of fixM, it occasionally transforms the code + -- in such a way that the code generator doesn't spot the selector + -- thunks. Sigh. + +fixM :: (a -> IOEnv env a) -> IOEnv env a +fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) + + +--------------------------- +tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r) +-- Reflect UserError exceptions (only) into IOEnv monad +-- Other exceptions are not caught; they are simply propagated as exns +-- +-- The idea is that errors in the program being compiled will give rise +-- to UserErrors. But, say, pattern-match failures in GHC itself should +-- not be caught here, else they'll be reported as errors in the program +-- begin compiled! +tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env)) + +tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a) +tryIOEnvFailure = try + +tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r) +-- Catch *all* synchronous exceptions +-- This is used when running a Template-Haskell splice, when +-- even a pattern-match failure is a programmer error +tryAllM (IOEnv thing) = IOEnv (\ env -> safeTry (thing env)) + +-- | Like 'try', but doesn't catch asynchronous exceptions +safeTry :: IO a -> IO (Either SomeException a) +safeTry act = do + var <- newEmptyMVar + -- uninterruptible because we want to mask around 'killThread', which is interruptible. + uninterruptibleMask $ \restore -> do + -- Fork, so that 'act' is safe from all asynchronous exceptions other than the ones we send it + t <- forkIO $ try (restore act) >>= putMVar var + restore (readMVar var) + `catchException` \(e :: SomeException) -> do + -- Control reaches this point only if the parent thread was sent an async exception + -- In that case, kill the 'act' thread and re-raise the exception + killThread t + throwIO e + +tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r) +tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) + +--------------------------- +unsafeInterleaveM :: IOEnv env a -> IOEnv env a +unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) + +uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a +uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env)) + +---------------------------------------------------------------------- +-- Alternative/MonadPlus +---------------------------------------------------------------------- + +instance Alternative (IOEnv env) where + empty = IOEnv (const empty) + m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env) + +instance MonadPlus (IOEnv env) + +---------------------------------------------------------------------- +-- Accessing input/output +---------------------------------------------------------------------- + +newMutVar :: a -> IOEnv env (IORef a) +newMutVar val = liftIO (newIORef val) + +writeMutVar :: IORef a -> a -> IOEnv env () +writeMutVar var val = liftIO (writeIORef var val) + +readMutVar :: IORef a -> IOEnv env a +readMutVar var = liftIO (readIORef var) + +updMutVar :: IORef a -> (a -> a) -> IOEnv env () +updMutVar var upd = liftIO (modifyIORef var upd) + +-- | Atomically update the reference. Does not force the evaluation of the +-- new variable contents. For strict update, use 'atomicUpdMutVar''. +atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b +atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd) + +-- | Strict variant of 'atomicUpdMutVar'. +atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b +atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd) + +---------------------------------------------------------------------- +-- Accessing the environment +---------------------------------------------------------------------- + +getEnv :: IOEnv env env +{-# INLINE getEnv #-} +getEnv = IOEnv (\ env -> return env) + +-- | Perform a computation with a different environment +setEnv :: env' -> IOEnv env' a -> IOEnv env a +{-# INLINE setEnv #-} +setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env) + +-- | Perform a computation with an altered environment +updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a +{-# INLINE updEnv #-} +updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) + +-- | Perform a computation with an altered environment +updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a +{-# INLINE updEnvIO #-} +updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env) diff --git a/GHC/Data/List.hs b/GHC/Data/List.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/List.hs @@ -0,0 +1,25 @@ +module GHC.Data.List where + +mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) +mapAndUnzip _ [] = ([], []) +mapAndUnzip f (x:xs) + = let (r1, r2) = f x + (rs1, rs2) = mapAndUnzip f xs + in + (r1:rs1, r2:rs2) + +mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) +mapAndUnzip3 _ [] = ([], [], []) +mapAndUnzip3 f (x:xs) + = let (r1, r2, r3) = f x + (rs1, rs2, rs3) = mapAndUnzip3 f xs + in + (r1:rs1, r2:rs2, r3:rs3) + +mapAndUnzip4 :: (a -> (b, c, d, e)) -> [a] -> ([b], [c], [d], [e]) +mapAndUnzip4 _ [] = ([], [], [], []) +mapAndUnzip4 f (x:xs) + = let (r1, r2, r3, r4) = f x + (rs1, rs2, rs3, rs4) = mapAndUnzip4 f xs + in + (r1:rs1, r2:rs2, r3:rs3, r4:rs4) diff --git a/GHC/Data/List/Infinite.hs b/GHC/Data/List/Infinite.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/List/Infinite.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE RankNTypes #-} + +module GHC.Data.List.Infinite + ( Infinite (..) + , head, tail + , filter + , (++) + , unfoldr + , (!!) + , groupBy + , dropList + , iterate + , concatMap + , allListsOf + , toList + , repeat + , enumFrom + ) where + +import Prelude ((-), Applicative (..), Bool (..), Enum (succ), Foldable, Functor (..), Int, Maybe (..), Monad (..), Traversable (..), (<$>), flip, otherwise) +import Control.Category (Category (..)) +import Control.Monad (guard) +import qualified Data.Foldable as F +import Data.List.NonEmpty (NonEmpty (..)) +import qualified GHC.Base as List (build) + +infixr 5 `Inf` + +data Infinite a = Inf a (Infinite a) + deriving (Foldable, Functor, Traversable) + +head :: Infinite a -> a +head (Inf a _) = a +{-# NOINLINE [1] head #-} + +tail :: Infinite a -> Infinite a +tail (Inf _ as) = as +{-# NOINLINE [1] tail #-} + +{-# RULES +"head/build" forall (g :: forall b . (a -> b -> b) -> b) . head (build g) = g \ x _ -> x + #-} + +instance Applicative Infinite where + pure = repeat + Inf f fs <*> Inf a as = Inf (f a) (fs <*> as) + +instance Monad Infinite where + x >>= f = join (f <$> x) + where + join (Inf a as) = head a `Inf` join (tail <$> as) + +mapMaybe :: (a -> Maybe b) -> Infinite a -> Infinite b +mapMaybe f = go + where + go (Inf a as) = let bs = go as in case f a of + Nothing -> bs + Just b -> Inf b bs +{-# NOINLINE [1] mapMaybe #-} + +{-# RULES +"mapMaybe" [~1] forall f as . mapMaybe f as = build \ c -> foldr (mapMaybeFB c f) as +"mapMaybeList" [1] forall f . foldr (mapMaybeFB Inf f) = mapMaybe f + #-} + +{-# INLINE [0] mapMaybeFB #-} +mapMaybeFB :: (b -> r -> r) -> (a -> Maybe b) -> a -> r -> r +mapMaybeFB cons f a bs = case f a of + Nothing -> bs + Just r -> cons r bs + +filter :: (a -> Bool) -> Infinite a -> Infinite a +filter f = mapMaybe (\ a -> a <$ guard (f a)) +{-# INLINE filter #-} + +infixr 5 ++ +(++) :: Foldable f => f a -> Infinite a -> Infinite a +(++) = flip (F.foldr Inf) + +unfoldr :: (b -> (a, b)) -> b -> Infinite a +unfoldr f b = build \ c -> let go b = case f b of (a, b') -> a `c` go b' in go b +{-# INLINE unfoldr #-} + +(!!) :: Infinite a -> Int -> a +Inf a _ !! 0 = a +Inf _ as !! n = as !! (n-1) + +groupBy :: (a -> a -> Bool) -> Infinite a -> Infinite (NonEmpty a) +groupBy eq = go + where + go (Inf a as) = Inf (a:|bs) (go cs) + where (bs, cs) = span (eq a) as + +span :: (a -> Bool) -> Infinite a -> ([a], Infinite a) +span p = spanJust (\ a -> a <$ guard (p a)) +{-# INLINE span #-} + +spanJust :: (a -> Maybe b) -> Infinite a -> ([b], Infinite a) +spanJust p = go + where + go as@(Inf a as') + | Just b <- p a = let (bs, cs) = go as' in (b:bs, cs) + | otherwise = ([], as) + +iterate :: (a -> a) -> a -> Infinite a +iterate f = go where go a = Inf a (go (f a)) +{-# NOINLINE [1] iterate #-} + +{-# RULES +"iterate" [~1] forall f a . iterate f a = build (\ c -> iterateFB c f a) +"iterateFB" [1] iterateFB Inf = iterate + #-} + +iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b +iterateFB c f a = go a + where go a = a `c` go (f a) +{-# INLINE [0] iterateFB #-} + +concatMap :: Foldable f => (a -> f b) -> Infinite a -> Infinite b +concatMap f = go where go (Inf a as) = f a ++ go as +{-# NOINLINE [1] concatMap #-} + +{-# RULES "concatMap" forall f as . concatMap f as = build \ c -> foldr (\ x b -> F.foldr c b (f x)) as #-} + +{-# SPECIALIZE concatMap :: (a -> [b]) -> Infinite a -> Infinite b #-} + +foldr :: (a -> b -> b) -> Infinite a -> b +foldr f = go where go (Inf a as) = f a (go as) +{-# INLINE [0] foldr #-} + +build :: (forall b . (a -> b -> b) -> b) -> Infinite a +build g = g Inf +{-# INLINE [1] build #-} + +-- Analogous to 'foldr'/'build' fusion for '[]' +{-# RULES +"foldr/build" forall f (g :: forall b . (a -> b -> b) -> b) . foldr f (build g) = g f +"foldr/id" foldr Inf = id + +"foldr/cons/build" forall f a (g :: forall b . (a -> b -> b) -> b) . foldr f (Inf a (build g)) = f a (g f) + #-} + +{-# RULES +"map" [~1] forall f (as :: Infinite a) . fmap f as = build \ c -> foldr (mapFB c f) as +"mapFB" forall c f g . mapFB (mapFB c f) g = mapFB c (f . g) +"mapFB/id" forall c . mapFB c (\ x -> x) = c + #-} + +mapFB :: (b -> c -> c) -> (a -> b) -> a -> c -> c +mapFB c f = \ x ys -> c (f x) ys +{-# INLINE [0] mapFB #-} + +dropList :: [a] -> Infinite b -> Infinite b +dropList [] bs = bs +dropList (_:as) (Inf _ bs) = dropList as bs + +-- | Compute all lists of the given alphabet. +-- For example: @'allListsOf' "ab" = ["a", "b", "aa", "ba", "ab", "bb", "aaa", "baa", "aba", ...]@ +allListsOf :: [a] -> Infinite [a] +allListsOf as = concatMap (\ bs -> [a:bs | a <- as]) ([] `Inf` allListsOf as) + +-- See Note [Fusion for `Infinite` lists]. +toList :: Infinite a -> [a] +toList = \ as -> List.build (\ c _ -> foldr c as) +{-# INLINE toList #-} + +repeat :: a -> Infinite a +repeat a = as where as = Inf a as +{-# INLINE [0] repeat #-} + +repeatFB :: (a -> b -> b) -> a -> b +repeatFB c x = xs where xs = c x xs +{-# INLINE [0] repeatFB #-} + +{-# RULES +"repeat" [~1] forall a . repeat a = build \ c -> repeatFB c a +"repeatFB" [1] repeatFB Inf = repeat + #-} + +enumFrom :: Enum a => a -> Infinite a +enumFrom = iterate succ +{-# INLINE enumFrom #-} + +{- +Note [Fusion for `Infinite` lists] +~~~~~~~~~~~~~~~~~~~~ +We use RULES to support foldr/build fusion for Infinite lists, analogously to the RULES in +GHC.Base to support fusion for regular lists. In particular, we define the following: +• `build :: (forall b . (a -> b -> b) -> b) -> Infinite a` +• `foldr :: (a -> b -> b) -> Infinite a -> b` +• A RULE `foldr f (build g) = g f` +• `Infinite`-producing functions in terms of `build`, and `Infinite`-consuming functions in + terms of `foldr` + +This can work across data types. For example, consider `toList :: Infinite a -> [a]`. +We want 'toList' to be both a good consumer (of 'Infinite' lists) and a good producer (of '[]'). +Ergo, we define it in terms of 'Infinite.foldr' and `List.build`. + +For a bigger example, consider `List.map f (toList (Infinite.map g as))` + +We want to fuse away the intermediate `Infinite` structure between `Infnite.map` and `toList`, +and the list structure between `toList` and `List.map`. And indeed we do: see test +"InfiniteListFusion". +-} diff --git a/GHC/Data/List/NonEmpty.hs b/GHC/Data/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/List/NonEmpty.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.Data.List.NonEmpty (module Data.List.NonEmpty, module GHC.Data.List.NonEmpty, toList) where + +import Prelude (Bool, (.)) +import Control.Applicative +import qualified Control.Monad as List (zipWithM) +import Data.Foldable (Foldable (toList)) +import Data.List.NonEmpty hiding (toList, unzip) +import qualified Data.List as List +import qualified GHC.Data.List as List + +zipWithM :: Applicative f => (a -> b -> f c) -> NonEmpty a -> NonEmpty b -> f (NonEmpty c) +zipWithM f (a:|as) (b:|bs) = liftA2 (:|) (f a b) (List.zipWithM f as bs) +-- Inline to enable fusion of `List.zipWithM` +-- See Note [Fusion for zipN/zipWithN] in List.hs +{-# INLINE zipWithM #-} + +unzip :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b) +unzip ((a,b):|xs) = (a:|as, b:|bs) + where + (as, bs) = List.unzip xs + +unzip3 :: NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c) +unzip3 ((a,b,c):|xs) = (a:|as, b:|bs, c:|cs) + where + (as, bs, cs) = List.unzip3 xs + +mapAndUnzip :: (a -> (b, c)) -> NonEmpty a -> (NonEmpty b, NonEmpty c) +mapAndUnzip f (x:|xs) = (b:|bs, c:|cs) + where + (b, c) = f x + (bs, cs) = List.mapAndUnzip f xs + +mapAndUnzip3 :: (a -> (b, c, d)) -> NonEmpty a -> (NonEmpty b, NonEmpty c, NonEmpty d) +mapAndUnzip3 f (x:|xs) = (b:|bs, c:|cs, d:|ds) + where + (b, c, d) = f x + (bs, cs, ds) = List.mapAndUnzip3 f xs + +isSingleton :: NonEmpty a -> Bool +isSingleton = List.null . tail diff --git a/GHC/Data/List/SetOps.hs b/GHC/Data/List/SetOps.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/List/SetOps.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE CPP #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + + + +-- | Set-like operations on lists +-- +-- Avoid using them as much as possible +module GHC.Data.List.SetOps ( + unionLists, unionListsOrd, minusList, + + -- Association lists + Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, + + -- Duplicate handling + hasNoDups, removeDups, removeDupsOn, nubOrdBy, findDupsEq, + equivClasses, + + -- Indexing + getNth, + + -- Membership + isIn, isn'tIn, + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Ord (comparing) +import qualified Data.Set as S + +getNth :: Outputable a => [a] -> Int -> a +getNth xs n = assertPpr (xs `lengthExceeds` n) (ppr n $$ ppr xs) $ + xs !! n + +{- +************************************************************************ +* * + Treating lists as sets + Assumes the lists contain no duplicates, but are unordered +* * +************************************************************************ +-} + + + +-- | Combines the two lists while keeping their order, placing the first argument +-- first in the result. +-- +-- Uses a set internally to record duplicates. This makes it slightly slower for +-- very small lists but avoids quadratic behaviour for large lists. +unionListsOrd :: (HasDebugCallStack, Outputable a, Ord a) => [a] -> [a] -> [a] +unionListsOrd xs ys + -- Since both arguments don't have internal duplicates we can just take all of xs + -- and every element of ys that's not already in xs. + = let set_ys = S.fromList ys + in (filter (\e -> not $ S.member e set_ys) xs) ++ ys + +-- | Assumes that the arguments contain no duplicates +unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a] +-- We special case some reasonable common patterns. +unionLists xs [] = xs +unionLists [] ys = ys +unionLists [x] ys + | isIn "unionLists" x ys = ys + | otherwise = x:ys +unionLists xs [y] + | isIn "unionLists" y xs = xs + | otherwise = y:xs +unionLists xs ys + = warnPprTrace (lengthExceeds xs 100 || lengthExceeds ys 100) "unionLists" (ppr xs $$ ppr ys) $ + [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys + +-- | Calculate the set difference of two lists. This is +-- /O((m + n) log n)/, where we subtract a list of /n/ elements +-- from a list of /m/ elements. +-- +-- Extremely short cases are handled specially: +-- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1, +-- it takes /O(n)/ time. +minusList :: Ord a => [a] -> [a] -> [a] +-- There's no point building a set to perform just one lookup, so we handle +-- extremely short lists specially. It might actually be better to use +-- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5). +-- The tipping point will be somewhere in the area of where /m/ and /log n/ +-- become comparable, but we probably don't want to work too hard on this. +minusList [] _ = [] +minusList xs@[x] ys + | x `elem` ys = [] + | otherwise = xs +-- Using an empty set or a singleton would also be silly, so let's not. +minusList xs [] = xs +minusList xs [y] = filter (/= y) xs +-- When each list has at least two elements, we build a set from the +-- second argument, allowing us to filter the first argument fairly +-- efficiently. +minusList xs ys = filter (`S.notMember` yss) xs + where + yss = S.fromList ys + +{- +************************************************************************ +* * +\subsection[Utils-assoc]{Association lists} +* * +************************************************************************ + +Inefficient finite maps based on association lists and equality. +-} + +-- | A finite mapping based on equality and association lists. +type Assoc a b = [(a,b)] + +assoc :: (Eq a) => String -> Assoc a b -> a -> b +assocDefault :: (Eq a) => b -> Assoc a b -> a -> b +assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b +-- | Lookup key, fail gracefully using Nothing if not found. +assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b +assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b + +assocDefaultUsing _ deflt [] _ = deflt +assocDefaultUsing eq deflt ((k,v) : rest) key + | k `eq` key = v + | otherwise = assocDefaultUsing eq deflt rest key + +assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key +assocDefault deflt list key = assocDefaultUsing (==) deflt list key +assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key + +assocMaybe alist key + = lookup alist + where + lookup [] = Nothing + lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest + +{- +************************************************************************ +* * +\subsection[Utils-dups]{Duplicate-handling} +* * +************************************************************************ +-} + +hasNoDups :: (Eq a) => [a] -> Bool + +hasNoDups xs = f [] xs + where + f _ [] = True + f seen_so_far (x:xs) = if x `is_elem` seen_so_far + then False + else f (x:seen_so_far) xs + + is_elem = isIn "hasNoDups" + +equivClasses :: (a -> a -> Ordering) -- Comparison + -> [a] + -> [NonEmpty a] + +equivClasses _ [] = [] +equivClasses _ [stuff] = [stuff :| []] +equivClasses cmp items = NE.groupBy eq (L.sortBy cmp items) + where + eq a b = case cmp a b of { EQ -> True; _ -> False } + +-- | Remove the duplicates from a list using the provided +-- comparison function. Might change the order of elements. +-- +-- Returns the list without duplicates, and accumulates +-- all the duplicates in the second component of its result. +removeDups :: (a -> a -> Ordering) -- Comparison function + -> [a] + -> ([a], -- List with no duplicates + [NonEmpty a]) -- List of duplicate groups. One representative + -- from each group appears in the first result + +removeDups _ [] = ([], []) +removeDups _ [x] = ([x],[]) +removeDups cmp xs + = case L.mapAccumR collect_dups [] (equivClasses cmp xs) of { (dups, xs') -> + (xs', dups) } + where + collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a) + collect_dups dups_so_far (x :| []) = (dups_so_far, x) + collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x) + +removeDupsOn :: Ord b => (a -> b) -> [a] -> ([a], [NonEmpty a]) +removeDupsOn f x = removeDups (comparing f) x + +-- | Remove the duplicates from a list using the provided +-- comparison function. +nubOrdBy :: (a -> a -> Ordering) -> [a] -> [a] +nubOrdBy cmp xs = fst (removeDups cmp xs) + +findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a] +findDupsEq _ [] = [] +findDupsEq eq (x:xs) | L.null eq_xs = findDupsEq eq xs + | otherwise = (x :| eq_xs) : findDupsEq eq neq_xs + where (eq_xs, neq_xs) = L.partition (eq x) xs + +-- Debugging/specialising versions of \tr{elem} and \tr{notElem} + +# if !defined(DEBUG) +isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool +isIn _msg x ys = x `elem` ys +isn'tIn _msg x ys = x `notElem` ys + +# else /* DEBUG */ +isIn, isn'tIn :: (HasDebugCallStack, Eq a) => String -> a -> [a] -> Bool +isIn msg x ys + = elem100 0 x ys + where + elem100 :: Eq a => Int -> a -> [a] -> Bool + elem100 _ _ [] = False + elem100 i x (y:ys) + | i > 100 = warnPprTrace True ("Over-long elem in " ++ msg) empty (x `elem` (y:ys)) + | otherwise = x == y || elem100 (i + 1) x ys + +isn'tIn msg x ys + = notElem100 0 x ys + where + notElem100 :: Eq a => Int -> a -> [a] -> Bool + notElem100 _ _ [] = True + notElem100 i x (y:ys) + | i > 100 = warnPprTrace True ("Over-long notElem in " ++ msg) empty (x `notElem` (y:ys)) + | otherwise = x /= y && notElem100 (i + 1) x ys +# endif /* DEBUG */ diff --git a/GHC/Data/Maybe.hs b/GHC/Data/Maybe.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Maybe.hs @@ -0,0 +1,134 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Data.Maybe ( + module Data.Maybe, + + MaybeErr(..), -- Instance of Monad + failME, isSuccess, + + orElse, + firstJust, firstJusts, firstJustsM, + whenIsJust, + expectJust, + rightToMaybe, + + -- * MaybeT + MaybeT(..), liftMaybeT, tryMaybeT + ) where + +import GHC.Prelude +import GHC.IO (catchException) + +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Exception (SomeException(..)) +import Data.Maybe +import Data.Foldable ( foldlM, for_ ) +import GHC.Utils.Misc (HasCallStack) +import GHC.Utils.Panic +import GHC.Utils.Outputable +import Data.List.NonEmpty ( NonEmpty ) +import Control.Applicative( Alternative( (<|>) ) ) + +infixr 4 `orElse` + +{- +************************************************************************ +* * +\subsection[Maybe type]{The @Maybe@ type} +* * +************************************************************************ +-} + +firstJust :: Maybe a -> Maybe a -> Maybe a +firstJust = (<|>) + +-- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or +-- @Nothing@ otherwise. +firstJusts :: Foldable f => f (Maybe a) -> Maybe a +firstJusts = msum +{-# SPECIALISE firstJusts :: [Maybe a] -> Maybe a #-} +{-# SPECIALISE firstJusts :: NonEmpty (Maybe a) -> Maybe a #-} + +-- | Takes computations returnings @Maybes@; tries each one in order. +-- The first one to return a @Just@ wins. Returns @Nothing@ if all computations +-- return @Nothing@. +firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) +firstJustsM = foldlM go Nothing where + go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) + go Nothing action = action + go result@(Just _) _action = return result + +expectJust :: HasCallStack => Maybe a -> a +-- always enable the call stack to get the location even on non-debug builds +{-# INLINE expectJust #-} +expectJust = fromMaybe expectJustError + +expectJustError :: HasCallStack => a +expectJustError = pprPanic "expectJust" empty +{-# NOINLINE expectJustError #-} + +whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenIsJust = for_ + +-- | Flipped version of @fromMaybe@, useful for chaining. +orElse :: Maybe a -> a -> a +orElse = flip fromMaybe + +rightToMaybe :: Either a b -> Maybe b +rightToMaybe (Left _) = Nothing +rightToMaybe (Right x) = Just x + +{- +************************************************************************ +* * +\subsection[MaybeT type]{The @MaybeT@ monad transformer} +* * +************************************************************************ +-} + +-- We had our own MaybeT in the past. Now we reuse transformer's MaybeT + +liftMaybeT :: Monad m => m a -> MaybeT m a +liftMaybeT act = MaybeT $ Just `liftM` act + +-- | Try performing an 'IO' action, failing on error. +tryMaybeT :: IO a -> MaybeT IO a +tryMaybeT action = MaybeT $ catchException (Just `fmap` action) handler + where + handler (SomeException _) = return Nothing + +{- +************************************************************************ +* * +\subsection[MaybeErr type]{The @MaybeErr@ type} +* * +************************************************************************ +-} + +data MaybeErr err val = Succeeded val | Failed err + deriving (Functor) + +instance Applicative (MaybeErr err) where + pure = Succeeded + (<*>) = ap + +instance Monad (MaybeErr err) where + Succeeded v >>= k = k v + Failed e >>= _ = Failed e + +isSuccess :: MaybeErr err val -> Bool +isSuccess (Succeeded {}) = True +isSuccess (Failed {}) = False + +failME :: err -> MaybeErr err val +failME e = Failed e diff --git a/GHC/Data/OrdList.hs b/GHC/Data/OrdList.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/OrdList.hs @@ -0,0 +1,279 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + + +-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | Provide trees (of instructions), so that lists of instructions can be +-- appended in linear time. +module GHC.Data.OrdList ( + OrdList, pattern NilOL, pattern ConsOL, pattern SnocOL, + nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL, + headOL, + mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL, + partitionOL, reverseOL, fromOLReverse, strictlyEqOL, strictlyOrdOL +) where + +import GHC.Prelude +import Data.Foldable + +import GHC.Utils.Misc (strictMap) +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as Semigroup + +infixl 5 `appOL` +infixl 5 `snocOL` +infixr 5 `consOL` + +data OrdList a + = None + | One a + | Many (NonEmpty a) + | Cons a (OrdList a) + | Snoc (OrdList a) a + | Two (OrdList a) -- Invariant: non-empty + (OrdList a) -- Invariant: non-empty + deriving (Functor) + +instance Outputable a => Outputable (OrdList a) where + ppr ol = ppr (fromOL ol) -- Convert to list and print that + +instance Semigroup (OrdList a) where + (<>) = appOL + +instance Monoid (OrdList a) where + mempty = nilOL + mappend = (Semigroup.<>) + mconcat = concatOL + +instance Foldable OrdList where + foldr = foldrOL + foldl' = foldlOL + toList = fromOL + null = isNilOL + length = lengthOL + +instance Traversable OrdList where + traverse f xs = toOL <$> traverse f (fromOL xs) + +nilOL :: OrdList a +isNilOL :: OrdList a -> Bool + +unitOL :: a -> OrdList a +snocOL :: OrdList a -> a -> OrdList a +consOL :: a -> OrdList a -> OrdList a +appOL :: OrdList a -> OrdList a -> OrdList a +concatOL :: [OrdList a] -> OrdList a +headOL :: OrdList a -> a +lastOL :: OrdList a -> a +lengthOL :: OrdList a -> Int + +nilOL = None +unitOL as = One as +snocOL as b = Snoc as b +consOL a bs = Cons a bs +concatOL aas = foldr appOL None aas + +pattern NilOL :: OrdList a +pattern NilOL <- (isNilOL -> True) where + NilOL = None + +-- | An unboxed 'Maybe' type with two unboxed fields in the 'Just' case. +-- Useful for defining 'viewCons' and 'viewSnoc' without overhead. +type VMaybe a b = (# (# a, b #) | (# #) #) +pattern VJust :: a -> b -> VMaybe a b +pattern VJust a b = (# (# a, b #) | #) +pattern VNothing :: VMaybe a b +pattern VNothing = (# | (# #) #) +{-# COMPLETE VJust, VNothing #-} + +pattern ConsOL :: a -> OrdList a -> OrdList a +pattern ConsOL x xs <- (viewCons -> VJust x xs) where + ConsOL x xs = consOL x xs +{-# COMPLETE NilOL, ConsOL #-} + +viewCons :: OrdList a -> VMaybe a (OrdList a) +viewCons None = VNothing +viewCons (One a) = VJust a NilOL +viewCons (Many (a :| [])) = VJust a NilOL +viewCons (Many (a :| b : bs)) = VJust a (Many (b :| bs)) +viewCons (Cons a as) = VJust a as +viewCons (Snoc as a) = case viewCons as of + VJust a' as' -> VJust a' (Snoc as' a) + VNothing -> VJust a NilOL +viewCons (Two as1 as2) = case viewCons as1 of + VJust a' as1' -> VJust a' (Two as1' as2) + VNothing -> viewCons as2 + +pattern SnocOL :: OrdList a -> a -> OrdList a +pattern SnocOL xs x <- (viewSnoc -> VJust xs x) where + SnocOL xs x = snocOL xs x +{-# COMPLETE NilOL, SnocOL #-} + +viewSnoc :: OrdList a -> VMaybe (OrdList a) a +viewSnoc None = VNothing +viewSnoc (One a) = VJust NilOL a +viewSnoc (Many as) = (`VJust` NE.last as) $ case NE.init as of + [] -> NilOL + b : bs -> Many (b :| bs) +viewSnoc (Snoc as a) = VJust as a +viewSnoc (Cons a as) = case viewSnoc as of + VJust as' a' -> VJust (Cons a as') a' + VNothing -> VJust NilOL a +viewSnoc (Two as1 as2) = case viewSnoc as2 of + VJust as2' a' -> VJust (Two as1 as2') a' + VNothing -> viewSnoc as1 + +headOL None = panic "headOL" +headOL (One a) = a +headOL (Many as) = NE.head as +headOL (Cons a _) = a +headOL (Snoc as _) = headOL as +headOL (Two as _) = headOL as + +lastOL None = panic "lastOL" +lastOL (One a) = a +lastOL (Many as) = NE.last as +lastOL (Cons _ as) = lastOL as +lastOL (Snoc _ a) = a +lastOL (Two _ as) = lastOL as + +lengthOL None = 0 +lengthOL (One _) = 1 +lengthOL (Many as) = length as +lengthOL (Cons _ as) = 1 + length as +lengthOL (Snoc as _) = 1 + length as +lengthOL (Two as bs) = length as + length bs + +isNilOL None = True +isNilOL _ = False + +None `appOL` b = b +a `appOL` None = a +One a `appOL` b = Cons a b +a `appOL` One b = Snoc a b +a `appOL` b = Two a b + +fromOL :: OrdList a -> [a] +fromOL a = go a [] + where go None acc = acc + go (One a) acc = a : acc + go (Cons a b) acc = a : go b acc + go (Snoc a b) acc = go a (b:acc) + go (Two a b) acc = go a (go b acc) + go (Many xs) acc = NE.toList xs ++ acc + +fromOLReverse :: OrdList a -> [a] +fromOLReverse a = go a [] + -- acc is already in reverse order + where go :: OrdList a -> [a] -> [a] + go None acc = acc + go (One a) acc = a : acc + go (Cons a b) acc = go b (a : acc) + go (Snoc a b) acc = b : go a acc + go (Two a b) acc = go b (go a acc) + go (Many xs) acc = reverse (NE.toList xs) ++ acc + +mapOL :: (a -> b) -> OrdList a -> OrdList b +mapOL = fmap + +mapOL' :: (a->b) -> OrdList a -> OrdList b +mapOL' _ None = None +mapOL' f (One x) = One $! f x +mapOL' f (Cons x xs) = let !x1 = f x + !xs1 = mapOL' f xs + in Cons x1 xs1 +mapOL' f (Snoc xs x) = let !x1 = f x + !xs1 = mapOL' f xs + in Snoc xs1 x1 +mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1 + !b2' = mapOL' f b2 + in Two b1' b2' +mapOL' f (Many (x :| xs)) = let !x1 = f x + !xs1 = strictMap f xs + in Many (x1 :| xs1) + +foldrOL :: (a->b->b) -> b -> OrdList a -> b +foldrOL _ z None = z +foldrOL k z (One x) = k x z +foldrOL k z (Cons x xs) = k x (foldrOL k z xs) +foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs +foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1 +foldrOL k z (Many xs) = foldr k z xs + +-- | Strict left fold. +foldlOL :: (b->a->b) -> b -> OrdList a -> b +foldlOL _ z None = z +foldlOL k z (One x) = k z x +foldlOL k z (Cons x xs) = let !z' = (k z x) in foldlOL k z' xs +foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x +foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2 +foldlOL k z (Many xs) = foldl' k z xs + +partitionOL :: (a -> Bool) -> OrdList a -> (OrdList a, OrdList a) +partitionOL _ None = (None,None) +partitionOL f (One x) + | f x = (One x, None) + | otherwise = (None, One x) +partitionOL f (Two xs ys) = (Two ls1 ls2, Two rs1 rs2) + where !(!ls1,!rs1) = partitionOL f xs + !(!ls2,!rs2) = partitionOL f ys +partitionOL f (Cons x xs) + | f x = (Cons x ls, rs) + | otherwise = (ls, Cons x rs) + where !(!ls,!rs) = partitionOL f xs +partitionOL f (Snoc xs x) + | f x = (Snoc ls x, rs) + | otherwise = (ls, Snoc rs x) + where !(!ls,!rs) = partitionOL f xs +partitionOL f (Many xs) = (toOL ls, toOL rs) + where !(!ls,!rs) = NE.partition f xs + +toOL :: [a] -> OrdList a +toOL [] = None +toOL [x] = One x +toOL (x : xs) = Many (x :| xs) + +reverseOL :: OrdList a -> OrdList a +reverseOL None = None +reverseOL (One x) = One x +reverseOL (Cons a b) = Snoc (reverseOL b) a +reverseOL (Snoc a b) = Cons b (reverseOL a) +reverseOL (Two a b) = Two (reverseOL b) (reverseOL a) +reverseOL (Many xs) = Many (NE.reverse xs) + +-- | Compare not only the values but also the structure of two lists +strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool +strictlyEqOL None None = True +strictlyEqOL (One x) (One y) = x == y +strictlyEqOL (Cons a as) (Cons b bs) = a == b && as `strictlyEqOL` bs +strictlyEqOL (Snoc as a) (Snoc bs b) = a == b && as `strictlyEqOL` bs +strictlyEqOL (Two a1 a2) (Two b1 b2) = a1 `strictlyEqOL` b1 && a2 `strictlyEqOL` b2 +strictlyEqOL (Many as) (Many bs) = as == bs +strictlyEqOL _ _ = False + +-- | Compare not only the values but also the structure of two lists +strictlyOrdOL :: Ord a => OrdList a -> OrdList a -> Ordering +strictlyOrdOL None None = EQ +strictlyOrdOL None _ = LT +strictlyOrdOL (One x) (One y) = compare x y +strictlyOrdOL (One _) _ = LT +strictlyOrdOL (Cons a as) (Cons b bs) = + compare a b `mappend` strictlyOrdOL as bs +strictlyOrdOL (Cons _ _) _ = LT +strictlyOrdOL (Snoc as a) (Snoc bs b) = + compare a b `mappend` strictlyOrdOL as bs +strictlyOrdOL (Snoc _ _) _ = LT +strictlyOrdOL (Two a1 a2) (Two b1 b2) = + (strictlyOrdOL a1 b1) `mappend` (strictlyOrdOL a2 b2) +strictlyOrdOL (Two _ _) _ = LT +strictlyOrdOL (Many as) (Many bs) = compare as bs +strictlyOrdOL (Many _ ) _ = GT diff --git a/GHC/Data/OsPath.hs b/GHC/Data/OsPath.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/OsPath.hs @@ -0,0 +1,29 @@ +module GHC.Data.OsPath + ( + -- * OsPath initialisation and transformation + OsPath + , OsString + , encodeUtf + , decodeUtf + , unsafeDecodeUtf + , unsafeEncodeUtf + , os + -- * Common utility functions + , () + , (<.>) + ) + where + +import GHC.Prelude + +import GHC.Utils.Misc (HasCallStack) +import GHC.Utils.Panic (panic) + +import System.OsPath +import System.Directory.Internal (os) + +-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. +-- Prefer 'decodeUtf' and gracious error handling. +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath +unsafeDecodeUtf p = + either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p) diff --git a/GHC/Data/Pair.hs b/GHC/Data/Pair.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Pair.hs @@ -0,0 +1,71 @@ +{- +A simple homogeneous pair type with useful Functor, Applicative, and +Traversable instances. +-} + + +{-# LANGUAGE DeriveTraversable #-} + +module GHC.Data.Pair + ( Pair(..) + , unPair + , toPair + , swap + , pLiftFst, pLiftSnd + , unzipPairs + ) +where + +import GHC.Prelude + +import GHC.Utils.Outputable +import qualified Data.Semigroup as Semi + +data Pair a = Pair { pFst :: a, pSnd :: a } + deriving (Foldable, Functor, Traversable) +-- Note that Pair is a *unary* type constructor +-- whereas (,) is binary + +-- The important thing about Pair is that it has a *homogeneous* +-- Functor instance, so you can easily apply the same function +-- to both components + +instance Applicative Pair where + pure x = Pair x x + (Pair f g) <*> (Pair x y) = Pair (f x) (g y) + +instance Semi.Semigroup a => Semi.Semigroup (Pair a) where + Pair a1 b1 <> Pair a2 b2 = Pair (a1 Semi.<> a2) (b1 Semi.<> b2) + +instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where + mempty = Pair mempty mempty + mappend = (Semi.<>) + +instance Outputable a => Outputable (Pair a) where + ppr (Pair a b) = ppr a <+> char '~' <+> ppr b + +unPair :: Pair a -> (a,a) +unPair (Pair x y) = (x,y) + +toPair :: (a,a) -> Pair a +toPair (x,y) = Pair x y + +swap :: Pair a -> Pair a +swap (Pair x y) = Pair y x + +pLiftFst :: (a -> a) -> Pair a -> Pair a +pLiftFst f (Pair a b) = Pair (f a) b + +pLiftSnd :: (a -> a) -> Pair a -> Pair a +pLiftSnd f (Pair a b) = Pair a (f b) + +unzipPairs :: [Pair a] -> ([a], [a]) +unzipPairs [] = ([], []) +unzipPairs (Pair a b : prs) = (a:as, b:bs) + where + !(as,bs) = unzipPairs prs + -- This makes the unzip work eagerly, building no thunks at + -- the cost of doing all the work up-front. + +instance Foldable1 Pair where + foldMap1 f (Pair a b) = f a Semi.<> f b diff --git a/GHC/Data/SmallArray.hs b/GHC/Data/SmallArray.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/SmallArray.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BlockArguments #-} + +-- | Small-array +module GHC.Data.SmallArray + ( SmallMutableArray (..) + , SmallArray (..) + , newSmallArray + , writeSmallArray + , freezeSmallArray + , unsafeFreezeSmallArray + , indexSmallArray + , sizeofSmallArray + , listToArray + , mapSmallArray + , foldMapSmallArray + , rnfSmallArray + + -- * IO Operations + , SmallMutableArrayIO + , newSmallArrayIO + , writeSmallArrayIO + , unsafeFreezeSmallArrayIO + ) +where + +import GHC.Exts +import GHC.Prelude +import GHC.IO +import GHC.ST +import Control.DeepSeq + +data SmallArray a = SmallArray (SmallArray# a) + +data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) + +type SmallMutableArrayIO a = SmallMutableArray RealWorld a + +newSmallArray + :: Int -- ^ size + -> a -- ^ initial contents + -> State# s + -> (# State# s, SmallMutableArray s a #) +{-# INLINE newSmallArray #-} +newSmallArray (I# sz) x s = case newSmallArray# sz x s of + (# s', a #) -> (# s', SmallMutableArray a #) + +newSmallArrayIO :: Int -> a -> IO (SmallMutableArrayIO a) +newSmallArrayIO sz x = IO $ \s -> newSmallArray sz x s + +writeSmallArray + :: SmallMutableArray s a -- ^ array + -> Int -- ^ index + -> a -- ^ new element + -> State# s + -> State# s +{-# INLINE writeSmallArray #-} +writeSmallArray (SmallMutableArray a) (I# i) x = writeSmallArray# a i x + +writeSmallArrayIO :: SmallMutableArrayIO a + -> Int + -> a + -> IO () +writeSmallArrayIO a ix v = IO $ \s -> (# writeSmallArray a ix v s, () #) + + +-- | Copy and freeze a slice of a mutable array. +freezeSmallArray + :: SmallMutableArray s a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> State# s + -> (# State# s, SmallArray a #) +{-# INLINE freezeSmallArray #-} +freezeSmallArray (SmallMutableArray ma) (I# offset) (I# len) s = + case freezeSmallArray# ma offset len s of + (# s', a #) -> (# s', SmallArray a #) + +-- | Freeze a mutable array (no copy!) +unsafeFreezeSmallArray + :: SmallMutableArray s a + -> State# s + -> (# State# s, SmallArray a #) +{-# INLINE unsafeFreezeSmallArray #-} +unsafeFreezeSmallArray (SmallMutableArray ma) s = + case unsafeFreezeSmallArray# ma s of + (# s', a #) -> (# s', SmallArray a #) + +unsafeFreezeSmallArrayIO :: SmallMutableArrayIO a -> IO (SmallArray a) +unsafeFreezeSmallArrayIO arr = IO $ \s -> unsafeFreezeSmallArray arr s + +-- | Get the size of a 'SmallArray' +sizeofSmallArray + :: SmallArray a + -> Int +{-# INLINE sizeofSmallArray #-} +sizeofSmallArray (SmallArray sa#) = + case sizeofSmallArray# sa# of + s -> I# s + +-- | Index a small-array (no bounds checking!) +indexSmallArray + :: SmallArray a -- ^ array + -> Int -- ^ index + -> a +{-# INLINE indexSmallArray #-} +indexSmallArray (SmallArray sa#) (I# i) = + case indexSmallArray# sa# i of + (# v #) -> v + +-- | Map a function over the elements of a 'SmallArray' +-- +mapSmallArray :: (a -> b) -> SmallArray a -> SmallArray b +{-# INLINE mapSmallArray #-} +mapSmallArray f sa = runST $ ST $ \s -> + let + n = sizeofSmallArray sa + go !i saMut# state# + | i < n = + let + a = indexSmallArray sa i + newState# = writeSmallArray saMut# i (f a) state# + in + go (i + 1) saMut# newState# + | otherwise = state# + in + case newSmallArray n (error "SmallArray: internal error, uninitialised elements") s of + (# s', mutArr #) -> + case go 0 mutArr s' of + s'' -> unsafeFreezeSmallArray mutArr s'' + +-- | Fold the values of a 'SmallArray' into a 'Monoid m' of choice +foldMapSmallArray :: Monoid m => (a -> m) -> SmallArray a -> m +{-# INLINE foldMapSmallArray #-} +foldMapSmallArray f sa = go 0 + where + n = sizeofSmallArray sa + go i + | i < n = f (indexSmallArray sa i) `mappend` go (i + 1) + | otherwise = mempty + +-- | Force the elements of the given 'SmallArray' +-- +rnfSmallArray :: NFData a => SmallArray a -> () +{-# INLINE rnfSmallArray #-} +rnfSmallArray sa = go 0 + where + n = sizeofSmallArray sa + go !i + | i < n = rnf (indexSmallArray sa i) `seq` go (i + 1) + | otherwise = () + +-- | Convert a list into an array. +listToArray :: Int -> (e -> Int) -> (e -> a) -> [e] -> SmallArray a +{-# INLINE listToArray #-} +listToArray (I# size) index_of value_of xs = runST $ ST \s -> + let + index_of' e = case index_of e of I# i -> i + write_elems ma es s = case es of + [] -> s + e:es' -> case writeSmallArray# ma (index_of' e) (value_of e) s of + s' -> write_elems ma es' s' + in + case newSmallArray# size undefined s of + (# s', ma #) -> case write_elems ma xs s' of + s'' -> case unsafeFreezeSmallArray# ma s'' of + (# s''', a #) -> (# s''', SmallArray a #) diff --git a/GHC/Data/Stream.hs b/GHC/Data/Stream.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Stream.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2012 +-- +-- ----------------------------------------------------------------------------- + +-- | Monadic streams +module GHC.Data.Stream ( + Stream(..), StreamS(..), runStream, yield, liftIO, liftEff, hoistEff, + collect, consume, fromList, + map, mapM, mapAccumL_ + ) where + +import GHC.Prelude hiding (map,mapM) + +import Control.Monad hiding (mapM) +import Control.Monad.IO.Class + +-- | +-- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence +-- of elements of type @a@ followed by a result of type @b@. +-- +-- More concretely, a value of type @Stream m a b@ can be run using @runStreamInternal@ +-- in the Monad @m@, and it delivers either +-- +-- * the final result: @Done b@, or +-- * @Yield a str@ where @a@ is the next element in the stream, and @str@ +-- is the rest of the stream +-- * @Effect mstr@ where @mstr@ is some action running in @m@ which +-- generates the rest of the stream. +-- +-- Stream is itself a Monad, and provides an operation 'yield' that +-- produces a new element of the stream. This makes it convenient to turn +-- existing monadic computations into streams. +-- +-- The idea is that Stream is useful for making a monadic computation +-- that produces values from time to time. This can be used for +-- knitting together two complex monadic operations, so that the +-- producer does not have to produce all its values before the +-- consumer starts consuming them. We make the producer into a +-- Stream, and the consumer pulls on the stream each time it wants a +-- new value. +-- +-- 'Stream' is implemented in the "yoneda" style for efficiency. By +-- representing a stream in this manner 'fmap' and '>>=' operations are +-- accumulated in the function parameters before being applied once when +-- the stream is destroyed. In the old implementation each usage of 'mapM' +-- and '>>=' would traverse the entire stream in order to apply the +-- substitution at the leaves. +-- +-- The >>= operation for 'Stream' was a hot-spot in the ticky profile for +-- the "ManyConstructors" test which called the 'cg' function many times in +-- @StgToCmm.hs@ +-- +newtype Stream m a b = + Stream { runStreamInternal :: forall r' r . + (a -> m r') -- For fusing calls to `map` and `mapM` + -> (b -> StreamS m r' r) -- For fusing `>>=` + -> StreamS m r' r } + +runStream :: Applicative m => Stream m r' r -> StreamS m r' r +runStream st = runStreamInternal st pure Done + +data StreamS m a b = Yield a (StreamS m a b) + | Done b + | Effect (m (StreamS m a b)) + deriving (Functor) + +instance Monad m => Applicative (StreamS m a) where + pure = Done + (<*>) = ap + +instance Monad m => Monad (StreamS m a) where + a >>= k = case a of + Done r -> k r + Yield a s -> Yield a (s >>= k) + Effect m -> Effect (fmap (>>= k) m) + +instance Functor (Stream f a) where + fmap = liftM + +instance Applicative (Stream m a) where + pure a = Stream $ \_f g -> g a + (<*>) = ap + +instance Monad (Stream m a) where + Stream m >>= k = Stream $ \f h -> m f (\a -> runStreamInternal (k a) f h) + +instance MonadIO m => MonadIO (Stream m b) where + liftIO io = Stream $ \_f g -> Effect (g <$> liftIO io) + +yield :: Monad m => a -> Stream m a () +yield a = Stream $ \f rest -> Effect (flip Yield (rest ()) <$> f a) + +-- | Turn a Stream into an ordinary list, by demanding all the elements. +collect :: Monad m => Stream m a () -> m [a] +collect str = go [] (runStream str) + where + go acc (Done ()) = return (reverse acc) + go acc (Effect m) = m >>= go acc + go acc (Yield a k) = go (a:acc) k + +consume :: (Monad m, Monad n) => Stream m a b -> (forall a . m a -> n a) -> (a -> n ()) -> n b +consume str l f = go (runStream str) + where + go (Done r) = return r + go (Yield a p) = f a >> go p + go (Effect m) = l m >>= go + +-- | Turn a list into a 'Stream', by yielding each element in turn. +fromList :: Monad m => [a] -> Stream m a () +fromList = mapM_ yield + +-- | Apply a function to each element of a 'Stream', lazily +map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x +map f str = Stream $ \g h -> runStreamInternal str (g . f) h + +-- | Apply a monadic operation to each element of a 'Stream', lazily +mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x +mapM f str = Stream $ \g h -> runStreamInternal str (g <=< f) h + +-- | Note this is not very efficient because it traverses the whole stream +-- before rebuilding it, avoid using it if you can. mapAccumL used to +-- implemented but it wasn't used anywhere in the compiler and has similar +-- efficiency problems. +mapAccumL_ :: forall m a b c r . Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r + -> Stream m b (c, r) +mapAccumL_ f c str = Stream $ \f h -> go c f h (runStream str) + + where + go :: c + -> (b -> m r') + -> ((c, r) -> StreamS m r' r1) + -> StreamS m a r + -> StreamS m r' r1 + go c _f1 h1 (Done r) = h1 (c, r) + go c f1 h1 (Yield a p) = Effect (f c a >>= (\(c', b) -> f1 b + >>= \r' -> return $ Yield r' (go c' f1 h1 p))) + go c f1 h1 (Effect m) = Effect (go c f1 h1 <$> m) + +-- | Lift an effect into the Stream +liftEff :: Monad m => m b -> Stream m a b +liftEff eff = Stream $ \_f g -> Effect (g <$> eff) + +-- | Hoist the underlying Stream effect +-- Note this is not very efficience since, just like 'mapAccumL_', it also needs +-- to traverse and rebuild the whole stream. +hoistEff :: forall m n a b. (Applicative m, Monad n) => (forall x. m x -> n x) -> Stream m a b -> Stream n a b +hoistEff h s = Stream $ \f g -> hs f g (runStream s :: StreamS m a b) where + hs :: (a -> n r') + -> (b -> StreamS n r' r) + -> StreamS m a b + -> StreamS n r' r + hs f g x = case x of + Done d -> g d + Yield a r -> Effect (f a >>= \r' -> return $ Yield r' (hs f g r)) + Effect e -> Effect (h (hs f g <$> e)) + diff --git a/GHC/Data/Strict.hs b/GHC/Data/Strict.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Strict.hs @@ -0,0 +1,77 @@ +-- Strict counterparts to common data structures, +-- e.g. tuples, lists, maybes, etc. +-- +-- Import this module qualified as Strict. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} + +module GHC.Data.Strict ( + Maybe(Nothing, Just), + fromMaybe, + GHC.Data.Strict.maybe, + Pair(And), + -- Not used at the moment: + -- + -- Either(Left, Right), + -- List(Nil, Cons), + ) where + +import GHC.Prelude hiding (Maybe(..), Either(..)) + +import Control.Applicative +import Data.Semigroup +import Data.Data +import Control.DeepSeq + +data Maybe a = Nothing | Just !a + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data) + +instance NFData a => NFData (Maybe a) where + rnf Nothing = () + rnf (Just x) = rnf x + +fromMaybe :: a -> Maybe a -> a +fromMaybe d Nothing = d +fromMaybe _ (Just x) = x + +maybe :: b -> (a -> b) -> Maybe a -> b +maybe d _ Nothing = d +maybe _ f (Just x) = f x + +apMaybe :: Maybe (a -> b) -> Maybe a -> Maybe b +apMaybe (Just f) (Just x) = Just (f x) +apMaybe _ _ = Nothing + +altMaybe :: Maybe a -> Maybe a -> Maybe a +altMaybe Nothing r = r +altMaybe l _ = l + +instance Semigroup a => Semigroup (Maybe a) where + Nothing <> b = b + a <> Nothing = a + Just a <> Just b = Just (a <> b) + +instance Semigroup a => Monoid (Maybe a) where + mempty = Nothing + +instance Applicative Maybe where + pure = Just + (<*>) = apMaybe + +instance Alternative Maybe where + empty = Nothing + (<|>) = altMaybe + +data Pair a b = !a `And` !b + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data) + +-- The definitions below are commented out because they are +-- not used anywhere in the compiler, but are useful to showcase +-- the intent behind this module (i.e. how it may evolve). +-- +-- data Either a b = Left !a | Right !b +-- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data) +-- +-- data List a = Nil | !a `Cons` !(List a) +-- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data) diff --git a/GHC/Data/StringBuffer.hs b/GHC/Data/StringBuffer.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/StringBuffer.hs @@ -0,0 +1,427 @@ +{- +(c) The University of Glasgow 2006 +(c) The University of Glasgow, 1997-2006 + + +Buffers for scanning string input stored in external arrays. +-} + +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +module GHC.Data.StringBuffer + ( + StringBuffer(..), + -- non-abstract for vs\/HaskellService + + -- * Creation\/destruction + hGetStringBuffer, + hGetStringBufferBlock, + hPutStringBuffer, + appendStringBuffers, + stringToStringBuffer, + stringBufferFromByteString, + + -- * Inspection + nextChar, + currentChar, + prevChar, + atEnd, + fingerprintStringBuffer, + + -- * Moving and comparison + stepOn, + offsetBytes, + byteDiff, + atLine, + + -- * Conversion + lexemeToString, + lexemeToFastString, + decodePrevNChars, + + -- * Parsing integers + parseUnsignedInteger, + findHashOffset, + + -- * Checking for bi-directional format characters + containsBidirectionalFormatChar, + bidirectionalFormatChars + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Utils.Encoding +import GHC.Utils.IO.Unsafe +import GHC.Utils.Panic.Plain +import GHC.Utils.Exception ( bracket_ ) +import GHC.Fingerprint + +import Data.Maybe +import System.IO +import System.IO.Unsafe ( unsafePerformIO ) +import GHC.IO.Encoding.UTF8 ( mkUTF8 ) +import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) + +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString as BS +import Data.ByteString ( ByteString ) + +import GHC.Exts + +import Foreign +import GHC.ForeignPtr (unsafeWithForeignPtr) + +-- ----------------------------------------------------------------------------- +-- The StringBuffer type + +-- |A StringBuffer is an internal pointer to a sized chunk of bytes. +-- The bytes are intended to be *immutable*. There are pure +-- operations to read the contents of a StringBuffer. +-- +-- A StringBuffer may have a finalizer, depending on how it was +-- obtained. +-- +data StringBuffer + = StringBuffer { + buf :: {-# UNPACK #-} !(ForeignPtr Word8), + len :: {-# UNPACK #-} !Int, -- length + cur :: {-# UNPACK #-} !Int -- current pos + } + -- The buffer is assumed to be UTF-8 encoded, and furthermore + -- we add three @\'\\0\'@ bytes to the end as sentinels so that the + -- decoder doesn't have to check for overflow at every single byte + -- of a multibyte sequence. + +instance Show StringBuffer where + showsPrec _ s = showString "" + +-- ----------------------------------------------------------------------------- +-- Creation / Destruction + +-- | Read a file into a 'StringBuffer'. The resulting buffer is automatically +-- managed by the garbage collector. +hGetStringBuffer :: FilePath -> IO StringBuffer +hGetStringBuffer fname = do + h <- openBinaryFile fname ReadMode + size_i <- hFileSize h + offset_i <- skipBOM h size_i 0 -- offset is 0 initially + let size = fromIntegral $ size_i - offset_i + buf <- mallocForeignPtrArray (size+3) + unsafeWithForeignPtr buf $ \ptr -> do + r <- if size == 0 then return 0 else hGetBuf h ptr size + hClose h + if (r /= size) + then ioError (userError "short read of file") + else newUTF8StringBuffer buf ptr size + +hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer +hGetStringBufferBlock handle wanted + = do size_i <- hFileSize handle + offset_i <- hTell handle >>= skipBOM handle size_i + let size = min wanted (fromIntegral $ size_i-offset_i) + buf <- mallocForeignPtrArray (size+3) + unsafeWithForeignPtr buf $ \ptr -> + do r <- if size == 0 then return 0 else hGetBuf handle ptr size + if r /= size + then ioError (userError $ "short read of file: "++show(r,size,size_i,handle)) + else newUTF8StringBuffer buf ptr size + +hPutStringBuffer :: Handle -> StringBuffer -> IO () +hPutStringBuffer hdl (StringBuffer buf len cur) + = unsafeWithForeignPtr (plusForeignPtr buf cur) $ \ptr -> + hPutBuf hdl ptr len + +-- | Skip the byte-order mark if there is one (see #1744 and #6016), +-- and return the new position of the handle in bytes. +-- +-- This is better than treating #FEFF as whitespace, +-- because that would mess up layout. We don't have a concept +-- of zero-width whitespace in Haskell: all whitespace codepoints +-- have a width of one column. +skipBOM :: Handle -> Integer -> Integer -> IO Integer +skipBOM h size offset = + -- Only skip BOM at the beginning of a file. + if size > 0 && offset == 0 + then do + -- Validate assumption that handle is in binary mode. + assertM (hGetEncoding h >>= return . isNothing) + -- Temporarily select utf8 encoding with error ignoring, + -- to make `hLookAhead` and `hGetChar` return full Unicode characters. + bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do + c <- hLookAhead h + if c == '\xfeff' + then hGetChar h >> hTell h + else return offset + else return offset + where + safeEncoding = mkUTF8 IgnoreCodingFailure + +newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer +newUTF8StringBuffer buf ptr size = do + pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] + -- sentinels for UTF-8 decoding + return $ StringBuffer buf size 0 + +appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer +appendStringBuffers sb1 sb2 + = do newBuf <- mallocForeignPtrArray (size+3) + unsafeWithForeignPtr newBuf $ \ptr -> + unsafeWithForeignPtr (buf sb1) $ \sb1Ptr -> + unsafeWithForeignPtr (buf sb2) $ \sb2Ptr -> + do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len + copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len + pokeArray (ptr `advancePtr` size) [0,0,0] + return (StringBuffer newBuf size 0) + where sb1_len = calcLen sb1 + sb2_len = calcLen sb2 + calcLen sb = len sb - cur sb + size = sb1_len + sb2_len + +-- | Encode a 'String' into a 'StringBuffer' as UTF-8. The resulting buffer +-- is automatically managed by the garbage collector. +stringToStringBuffer :: String -> StringBuffer +stringToStringBuffer str = + unsafePerformIO $ do + let size = utf8EncodedLength str + buf <- mallocForeignPtrArray (size+3) + unsafeWithForeignPtr buf $ \ptr -> do + utf8EncodePtr ptr str + pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] + -- sentinels for UTF-8 decoding + return (StringBuffer buf size 0) + +-- | Convert a UTF-8 encoded 'ByteString' into a 'StringBuffer. This really +-- relies on the internals of both 'ByteString' and 'StringBuffer'. +-- +-- /O(n)/ (but optimized into a @memcpy@ by @bytestring@ under the hood) +stringBufferFromByteString :: ByteString -> StringBuffer +stringBufferFromByteString bs = + let BS.PS fp off len = BS.append bs (BS.pack [0,0,0]) + in StringBuffer { buf = fp, len = len - 3, cur = off } + +-- ----------------------------------------------------------------------------- +-- Grab a character + +-- | Return the first UTF-8 character of a nonempty 'StringBuffer' and as well +-- the remaining portion (analogous to 'Data.List.uncons'). __Warning:__ The +-- behavior is undefined if the 'StringBuffer' is empty. The result shares +-- the same buffer as the original. Similar to 'utf8DecodeChar', if the +-- character cannot be decoded as UTF-8, @\'\\0\'@ is returned. +{-# INLINE nextChar #-} +nextChar :: StringBuffer -> (Char,StringBuffer) +nextChar (StringBuffer buf len (I# cur#)) = + -- Getting our fingers dirty a little here, but this is performance-critical + inlinePerformIO $ + unsafeWithForeignPtr buf $ \(Ptr a#) -> + case utf8DecodeCharAddr# (a# `plusAddr#` cur#) 0# of + (# c#, nBytes# #) -> + let cur' = I# (cur# +# nBytes#) in + return (C# c#, StringBuffer buf len cur') + + +bidirectionalFormatChars :: [(Char,String)] +bidirectionalFormatChars = + [ ('\x202a' , "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)") + , ('\x202b' , "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)") + , ('\x202c' , "U+202C POP DIRECTIONAL FORMATTING (PDF)") + , ('\x202d' , "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)") + , ('\x202e' , "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)") + , ('\x2066' , "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)") + , ('\x2067' , "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)") + , ('\x2068' , "U+2068 FIRST STRONG ISOLATE (FSI)") + , ('\x2069' , "U+2069 POP DIRECTIONAL ISOLATE (PDI)") + ] + +{-| Returns true if the buffer contains Unicode bi-directional formatting +characters. + +https://www.unicode.org/reports/tr9/#Bidirectional_Character_Types + +Bidirectional format characters are one of +'\x202a' : "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)" +'\x202b' : "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)" +'\x202c' : "U+202C POP DIRECTIONAL FORMATTING (PDF)" +'\x202d' : "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)" +'\x202e' : "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)" +'\x2066' : "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)" +'\x2067' : "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)" +'\x2068' : "U+2068 FIRST STRONG ISOLATE (FSI)" +'\x2069' : "U+2069 POP DIRECTIONAL ISOLATE (PDI)" + +This list is encoded in 'bidirectionalFormatChars' + +-} +{-# INLINE containsBidirectionalFormatChar #-} +containsBidirectionalFormatChar :: StringBuffer -> Bool +containsBidirectionalFormatChar (StringBuffer buf (I# len#) (I# cur#)) + = inlinePerformIO $ unsafeWithForeignPtr buf $ \(Ptr a#) -> do + let go :: Int# -> Bool + go i | isTrue# (i >=# len#) = False + | otherwise = case utf8DecodeCharAddr# a# i of + (# '\x202a'# , _ #) -> True + (# '\x202b'# , _ #) -> True + (# '\x202c'# , _ #) -> True + (# '\x202d'# , _ #) -> True + (# '\x202e'# , _ #) -> True + (# '\x2066'# , _ #) -> True + (# '\x2067'# , _ #) -> True + (# '\x2068'# , _ #) -> True + (# '\x2069'# , _ #) -> True + (# _, bytes #) -> go (i +# bytes) + pure $! go cur# + +-- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous +-- to 'Data.List.head'). __Warning:__ The behavior is undefined if the +-- 'StringBuffer' is empty. Similar to 'utf8DecodeChar', if the character +-- cannot be decoded as UTF-8, @\'\\0\'@ is returned. +currentChar :: StringBuffer -> Char +currentChar = fst . nextChar + +prevChar :: StringBuffer -> Char -> Char +prevChar (StringBuffer _ _ 0) deflt = deflt +prevChar (StringBuffer buf _ cur) _ = + inlinePerformIO $ + unsafeWithForeignPtr buf $ \p -> do + p' <- utf8PrevChar (p `plusPtr` cur) + return (fst (utf8DecodeCharPtr p')) + +-- ----------------------------------------------------------------------------- +-- Moving + +-- | Return a 'StringBuffer' with the first UTF-8 character removed (analogous +-- to 'Data.List.tail'). __Warning:__ The behavior is undefined if the +-- 'StringBuffer' is empty. The result shares the same buffer as the +-- original. +stepOn :: StringBuffer -> StringBuffer +stepOn s = snd (nextChar s) + +-- | Return a 'StringBuffer' with the first @n@ bytes removed. __Warning:__ +-- If there aren't enough characters, the returned 'StringBuffer' will be +-- invalid and any use of it may lead to undefined behavior. The result +-- shares the same buffer as the original. +offsetBytes :: Int -- ^ @n@, the number of bytes + -> StringBuffer + -> StringBuffer +offsetBytes i s = s { cur = cur s + i } + +-- | Compute the difference in offset between two 'StringBuffer's that share +-- the same buffer. __Warning:__ The behavior is undefined if the +-- 'StringBuffer's use separate buffers. +byteDiff :: StringBuffer -> StringBuffer -> Int +byteDiff s1 s2 = cur s2 - cur s1 + +-- | Check whether a 'StringBuffer' is empty (analogous to 'Data.List.null'). +atEnd :: StringBuffer -> Bool +atEnd (StringBuffer _ l c) = l == c + +-- | Computes a hash of the contents of a 'StringBuffer'. +fingerprintStringBuffer :: StringBuffer -> Fingerprint +fingerprintStringBuffer (StringBuffer buf len cur) = + unsafePerformIO $ + withForeignPtr buf $ \ptr -> + fingerprintData (ptr `plusPtr` cur) len + +-- | Computes a 'StringBuffer' which points to the first character of the +-- wanted line. Lines begin at 1. +atLine :: Int -> StringBuffer -> Maybe StringBuffer +atLine line sb@(StringBuffer buf len _) = + inlinePerformIO $ + unsafeWithForeignPtr buf $ \p -> do + p' <- skipToLine line len p + if p' == nullPtr + then return Nothing + else + let + delta = p' `minusPtr` p + in return $ Just (sb { cur = delta + , len = len - delta + }) + +skipToLine :: Int -> Int -> Ptr Word8 -> IO (Ptr Word8) +skipToLine !line !len !op0 = go 1 op0 + where + !opend = op0 `plusPtr` len + + go !i_line !op + | op >= opend = pure nullPtr + | i_line == line = pure op + | otherwise = do + w <- peek op :: IO Word8 + case w of + 10 -> go (i_line + 1) (plusPtr op 1) + 13 -> do + -- this is safe because a 'StringBuffer' is + -- guaranteed to have 3 bytes sentinel values. + w' <- peek (plusPtr op 1) :: IO Word8 + case w' of + 10 -> go (i_line + 1) (plusPtr op 2) + _ -> go (i_line + 1) (plusPtr op 1) + _ -> go i_line (plusPtr op 1) + +-- ----------------------------------------------------------------------------- +-- Conversion + +-- | Decode the first @n@ bytes of a 'StringBuffer' as UTF-8 into a 'String'. +-- Similar to 'utf8DecodeChar', if the character cannot be decoded as UTF-8, +-- they will be replaced with @\'\\0\'@. +lexemeToString :: StringBuffer + -> Int -- ^ @n@, the number of bytes + -> String +lexemeToString _ 0 = "" +lexemeToString (StringBuffer buf _ cur) bytes = + utf8DecodeForeignPtr buf cur bytes + +lexemeToFastString :: StringBuffer + -> Int -- ^ @n@, the number of bytes + -> FastString +lexemeToFastString _ 0 = nilFS +lexemeToFastString (StringBuffer buf _ cur) len = + inlinePerformIO $ + unsafeWithForeignPtr buf $ \ptr -> + return $! mkFastStringBytes (ptr `plusPtr` cur) len + +-- | Return the previous @n@ characters (or fewer if we are less than @n@ +-- characters into the buffer. +decodePrevNChars :: Int -> StringBuffer -> String +decodePrevNChars n (StringBuffer buf _ cur) = + inlinePerformIO $ unsafeWithForeignPtr buf $ \p0 -> + go p0 n "" (p0 `plusPtr` (cur - 1)) + where + go :: Ptr Word8 -> Int -> String -> Ptr Word8 -> IO String + go buf0 n acc p | n == 0 || buf0 >= p = return acc + go buf0 n acc p = do + p' <- utf8PrevChar p + let (c,_) = utf8DecodeCharPtr p' + go buf0 (n - 1) (c:acc) p' + +-- ----------------------------------------------------------------------------- +-- Parsing integer strings in various bases +parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer +parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int + = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let + go i x | i == len = x + | otherwise = case fst (utf8DecodeCharPtr (ptr `plusPtr` (cur + i))) of + '_' -> go (i + 1) x -- skip "_" (#14473) + char -> go (i + 1) (x * radix + toInteger (char_to_int char)) + in go 0 0 + +-- | Find the offset of the '#' character in the StringBuffer. +-- +-- Make sure that it contains one before calling this function! +findHashOffset :: StringBuffer -> Int +findHashOffset (StringBuffer buf _ cur) + = inlinePerformIO $ withForeignPtr buf $ \ptr -> do + let + go p = peek p >>= \case + (0x23 :: Word8) -> pure $! ((p `minusPtr` ptr) - cur) + _ -> go (p `plusPtr` 1) + go (ptr `plusPtr` cur) diff --git a/GHC/Data/TrieMap.hs b/GHC/Data/TrieMap.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/TrieMap.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} +module GHC.Data.TrieMap( + -- * Maps over 'Maybe' values + MaybeMap, + -- * Maps over 'List' values + ListMap, + -- * 'TrieMap' class + TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM, + + -- * Things helpful for adding additional Instances. + (>.>), (|>), (|>>), XT, + foldMaybe, filterMaybe, + -- * Map for leaf compression + GenMap, + lkG, xtG, mapG, fdG, + xtList, lkList + + ) where + +import GHC.Prelude + +import GHC.Types.Unique.DFM +import GHC.Types.Unique( Uniquable ) + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import GHC.Utils.Outputable +import Control.Monad( (>=>) ) +import Data.Kind( Type ) + +import qualified Data.Semigroup as S + +{- +This module implements TrieMaps, which are finite mappings +whose key is a structured value like a CoreExpr or Type. + +This file implements tries over general data structures. +Implementation for tries over Core Expressions/Types are +available in GHC.Core.Map.Expr. + +The regular pattern for handling TrieMaps on data structures was first +described (to my knowledge) in Connelly and Morris's 1995 paper "A +generalization of the Trie Data Structure"; there is also an accessible +description of the idea in Okasaki's book "Purely Functional Data +Structures", Section 10.3.2 + +************************************************************************ +* * + The TrieMap class +* * +************************************************************************ +-} + +type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) + -- or an existing elt (Just) + +class Functor m => TrieMap m where + type Key m :: Type + emptyTM :: m a + lookupTM :: forall b. Key m -> m b -> Maybe b + alterTM :: forall b. Key m -> XT b -> m b -> m b + filterTM :: (a -> Bool) -> m a -> m a + mapMaybeTM :: (a -> Maybe b) -> m a -> m b + foldTM :: (a -> b -> b) -> m a -> b -> b + -- The unusual argument order here makes + -- it easy to compose calls to foldTM; + -- see for example fdE below + +insertTM :: TrieMap m => Key m -> a -> m a -> m a +insertTM k v m = alterTM k (\_ -> Just v) m + +deleteTM :: TrieMap m => Key m -> m a -> m a +deleteTM k m = alterTM k (\_ -> Nothing) m + +foldMapTM :: (TrieMap m, Monoid r) => (a -> r) -> m a -> r +foldMapTM f m = foldTM (\ x r -> f x S.<> r) m mempty + +-- This looks inefficient. +isEmptyTM :: TrieMap m => m a -> Bool +isEmptyTM m = foldTM (\ _ _ -> False) m True + +---------------------- +-- Recall that +-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c + +(>.>) :: (a -> b) -> (b -> c) -> a -> c +-- Reverse function composition (do f first, then g) +infixr 1 >.> +(f >.> g) x = g (f x) +infixr 1 |>, |>> + +(|>) :: a -> (a->b) -> b -- Reverse application +x |> f = f x + +---------------------- +(|>>) :: TrieMap m2 + => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) + -> (m2 a -> m2 a) + -> m1 (m2 a) -> m1 (m2 a) +(|>>) f g = f (Just . g . deMaybe) + +deMaybe :: TrieMap m => Maybe (m a) -> m a +deMaybe Nothing = emptyTM +deMaybe (Just m) = m + +{- +Note [Every TrieMap is a Functor] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every TrieMap T admits + fmap :: (a->b) -> T a -> T b +where (fmap f t) applies `f` to every element of the range of `t`. +Ergo, we make `Functor` a superclass of `TrieMap`. + +Moreover it is almost invariably possible to /derive/ Functor for each +particular instance. E.g. in the list instance we have + data ListMap m a + = LM { lm_nil :: Maybe a + , lm_cons :: m (ListMap m a) } + deriving (Functor) + instance TrieMap m => TrieMap (ListMap m) where { .. } + +Alas, we not yet derive `Functor` for reasons of performance; see #22292. +-} + +{- +************************************************************************ +* * + IntMaps +* * +************************************************************************ +-} + +instance TrieMap IntMap.IntMap where + type Key IntMap.IntMap = Int + emptyTM = IntMap.empty + lookupTM k m = IntMap.lookup k m + alterTM = xtInt + foldTM k m z = IntMap.foldr k z m + filterTM f m = IntMap.filter f m + mapMaybeTM f m = IntMap.mapMaybe f m + +xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a +xtInt k f m = IntMap.alter f k m + +instance Ord k => TrieMap (Map.Map k) where + type Key (Map.Map k) = k + emptyTM = Map.empty + lookupTM = Map.lookup + alterTM k f m = Map.alter f k m + foldTM k m z = Map.foldr k z m + filterTM f m = Map.filter f m + mapMaybeTM f m = Map.mapMaybe f m + + +{- +Note [foldTM determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We want foldTM to be deterministic, which is why we have an instance of +TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that +go wrong if foldTM is nondeterministic. Consider: + + f a b = return (a <> b) + +Depending on the order that the typechecker generates constraints you +get either: + + f :: (Monad m, Monoid a) => a -> a -> m a + +or: + + f :: (Monoid a, Monad m) => a -> a -> m a + +The generated code will be different after desugaring as the dictionaries +will be bound in different orders, leading to potential ABI incompatibility. + +One way to solve this would be to notice that the typeclasses could be +sorted alphabetically. + +Unfortunately that doesn't quite work with this example: + + f a b = let x = a <> a; y = b <> b in x + +where you infer: + + f :: (Monoid m, Monoid m1) => m1 -> m -> m1 + +or: + + f :: (Monoid m1, Monoid m) => m1 -> m -> m1 + +Here you could decide to take the order of the type variables in the type +according to depth first traversal and use it to order the constraints. + +The real trouble starts when the user enables incoherent instances and +the compiler has to make an arbitrary choice. Consider: + + class T a b where + go :: a -> b -> String + + instance (Show b) => T Int b where + go a b = show a ++ show b + + instance (Show a) => T a Bool where + go a b = show a ++ show b + + f = go 10 True + +GHC is free to choose either dictionary to implement f, but for the sake of +determinism we'd like it to be consistent when compiling the same sources +with the same flags. + +inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it +gets converted to a bag of (Wanted) Cts using a fold. Then in +solve_simple_wanteds it's merged with other WantedConstraints. We want the +conversion to a bag to be deterministic. For that purpose we use UniqDFM +instead of UniqFM to implement the TrieMap. + +See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details on how it's made +deterministic. +-} + +instance forall key. Uniquable key => TrieMap (UniqDFM key) where + type Key (UniqDFM key) = key + emptyTM = emptyUDFM + lookupTM k m = lookupUDFM m k + alterTM k f m = alterUDFM f m k + foldTM k m z = foldUDFM k z m + filterTM f m = filterUDFM f m + mapMaybeTM f m = mapMaybeUDFM f m + +{- +************************************************************************ +* * + Maybes +* * +************************************************************************ + +If m is a map from k -> val +then (MaybeMap m) is a map from (Maybe k) -> val +-} + +data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } + +-- TODO(22292): derive +instance Functor m => Functor (MaybeMap m) where + fmap f MM { mm_nothing = mn, mm_just = mj } = MM + { mm_nothing = fmap f mn, mm_just = fmap f mj } + +instance TrieMap m => TrieMap (MaybeMap m) where + type Key (MaybeMap m) = Maybe (Key m) + emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } + lookupTM = lkMaybe lookupTM + alterTM = xtMaybe alterTM + foldTM = fdMaybe + filterTM = ftMaybe + mapMaybeTM = mpMaybe + +instance TrieMap m => Foldable (MaybeMap m) where + foldMap = foldMapTM + +lkMaybe :: (forall b. k -> m b -> Maybe b) + -> Maybe k -> MaybeMap m a -> Maybe a +lkMaybe _ Nothing = mm_nothing +lkMaybe lk (Just x) = mm_just >.> lk x + +xtMaybe :: (forall b. k -> XT b -> m b -> m b) + -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a +xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } +xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } + +fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b +fdMaybe k m = foldMaybe k (mm_nothing m) + . foldTM k (mm_just m) + +ftMaybe :: TrieMap m => (a -> Bool) -> MaybeMap m a -> MaybeMap m a +ftMaybe f (MM { mm_nothing = mn, mm_just = mj }) + = MM { mm_nothing = filterMaybe f mn, mm_just = filterTM f mj } + +mpMaybe :: TrieMap m => (a -> Maybe b) -> MaybeMap m a -> MaybeMap m b +mpMaybe f (MM { mm_nothing = mn, mm_just = mj }) + = MM { mm_nothing = mn >>= f, mm_just = mapMaybeTM f mj } + +foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b +foldMaybe _ Nothing b = b +foldMaybe k (Just a) b = k a b + +filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a +filterMaybe _ Nothing = Nothing +filterMaybe f input@(Just x) | f x = input + | otherwise = Nothing + +{- +************************************************************************ +* * + Lists +* * +************************************************************************ +-} + +data ListMap m a + = LM { lm_nil :: Maybe a + , lm_cons :: m (ListMap m a) } + +-- TODO(22292): derive +instance Functor m => Functor (ListMap m) where + fmap f LM { lm_nil = mnil, lm_cons = mcons } = LM + { lm_nil = fmap f mnil, lm_cons = fmap (fmap f) mcons } + +instance TrieMap m => TrieMap (ListMap m) where + type Key (ListMap m) = [Key m] + emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } + lookupTM = lkList lookupTM + alterTM = xtList alterTM + foldTM = fdList + filterTM = ftList + mapMaybeTM = mpList + +instance TrieMap m => Foldable (ListMap m) where + foldMap = foldMapTM + +instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where + ppr m = text "List elts" <+> ppr (foldTM (:) m []) + +lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) + -> [k] -> ListMap m a -> Maybe a +lkList _ [] = lm_nil +lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs + +xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) + -> [k] -> XT a -> ListMap m a -> ListMap m a +xtList _ [] f m = m { lm_nil = f (lm_nil m) } +xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } + +fdList :: forall m a b. TrieMap m + => (a -> b -> b) -> ListMap m a -> b -> b +fdList k m = foldMaybe k (lm_nil m) + . foldTM (fdList k) (lm_cons m) + +ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a +ftList f (LM { lm_nil = mnil, lm_cons = mcons }) + = LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons } + +mpList :: TrieMap m => (a -> Maybe b) -> ListMap m a -> ListMap m b +mpList f (LM { lm_nil = mnil, lm_cons = mcons }) + = LM { lm_nil = mnil >>= f, lm_cons = fmap (mapMaybeTM f) mcons } + +{- +************************************************************************ +* * + GenMap +* * +************************************************************************ + +Note [Compressed TrieMap] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +The GenMap constructor augments TrieMaps with leaf compression. This helps +solve the performance problem detailed in #9960: suppose we have a handful +H of entries in a TrieMap, each with a very large key, size K. If you fold over +such a TrieMap you'd expect time O(H). That would certainly be true of an +association list! But with TrieMap we actually have to navigate down a long +singleton structure to get to the elements, so it takes time O(K*H). This +can really hurt on many type-level computation benchmarks: +see for example T9872d. + +The point of a TrieMap is that you need to navigate to the point where only one +key remains, and then things should be fast. So the point of a SingletonMap +is that, once we are down to a single (key,value) pair, we stop and +just use SingletonMap. + +'EmptyMap' provides an even more basic (but essential) optimization: if there is +nothing in the map, don't bother building out the (possibly infinite) recursive +TrieMap structure! + +Compressed triemaps are heavily used by GHC.Core.Map.Expr. So we have to mark some things +as INLINEABLE to permit specialization. +-} + +data GenMap m a + = EmptyMap + | SingletonMap (Key m) a + | MultiMap (m a) + +instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where + ppr EmptyMap = text "Empty map" + ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v + ppr (MultiMap m) = ppr m + +-- TODO(22292): derive +instance Functor m => Functor (GenMap m) where + fmap = mapG + {-# INLINE fmap #-} + +-- TODO undecidable instance +instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where + type Key (GenMap m) = Key m + emptyTM = EmptyMap + lookupTM = lkG + alterTM = xtG + foldTM = fdG + filterTM = ftG + mapMaybeTM = mpG + +instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where + foldMap = foldMapTM + +--We want to be able to specialize these functions when defining eg +--tries over (GenMap CoreExpr) which requires INLINEABLE + +{-# INLINEABLE lkG #-} +lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a +lkG _ EmptyMap = Nothing +lkG k (SingletonMap k' v') | k == k' = Just v' + | otherwise = Nothing +lkG k (MultiMap m) = lookupTM k m + +{-# INLINEABLE xtG #-} +xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a +xtG k f EmptyMap + = case f Nothing of + Just v -> SingletonMap k v + Nothing -> EmptyMap +xtG k f m@(SingletonMap k' v') + | k' == k + -- The new key matches the (single) key already in the tree. Hence, + -- apply @f@ to @Just v'@ and build a singleton or empty map depending + -- on the 'Just'/'Nothing' response respectively. + = case f (Just v') of + Just v'' -> SingletonMap k' v'' + Nothing -> EmptyMap + | otherwise + -- We've hit a singleton tree for a different key than the one we are + -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then + -- we can just return the old map. If not, we need a map with *two* + -- entries. The easiest way to do that is to insert two items into an empty + -- map of type @m a@. + = case f Nothing of + Nothing -> m + Just v -> emptyTM |> alterTM k' (const (Just v')) + >.> alterTM k (const (Just v)) + >.> MultiMap +xtG k f (MultiMap m) = MultiMap (alterTM k f m) + +{-# INLINEABLE mapG #-} +mapG :: Functor m => (a -> b) -> GenMap m a -> GenMap m b +mapG _ EmptyMap = EmptyMap +mapG f (SingletonMap k v) = SingletonMap k (f v) +mapG f (MultiMap m) = MultiMap (fmap f m) + +{-# INLINEABLE fdG #-} +fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b +fdG _ EmptyMap = \z -> z +fdG k (SingletonMap _ v) = \z -> k v z +fdG k (MultiMap m) = foldTM k m + +{-# INLINEABLE ftG #-} +ftG :: TrieMap m => (a -> Bool) -> GenMap m a -> GenMap m a +ftG _ EmptyMap = EmptyMap +ftG f input@(SingletonMap _ v) + | f v = input + | otherwise = EmptyMap +ftG f (MultiMap m) = MultiMap (filterTM f m) + -- we don't have enough information to reconstruct the key to make + -- a SingletonMap + +{-# INLINEABLE mpG #-} +mpG :: TrieMap m => (a -> Maybe b) -> GenMap m a -> GenMap m b +mpG _ EmptyMap = EmptyMap +mpG f (SingletonMap k v) = case f v of + Just v' -> SingletonMap k v' + Nothing -> EmptyMap +mpG f (MultiMap m) = MultiMap (mapMaybeTM f m) diff --git a/GHC/Data/Unboxed.hs b/GHC/Data/Unboxed.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Unboxed.hs @@ -0,0 +1,56 @@ +-- Unboxed counterparts to data structures + +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnliftedNewtypes #-} + +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + -- If you use -fomit-interface-pragmas for your build, we won't + -- inline the matcher for JustUB, and that turns out to have a + -- catastropic effect on Lint, which uses unboxed Maybes. + -- Simple fix: switch off -fomit-interface-pragmas for this tiny + -- and very stable module. + +module GHC.Data.Unboxed ( + MaybeUB(JustUB, NothingUB), + fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB + ) where + +import GHC.Prelude hiding (Maybe(..), Either(..)) + +-- | Like Maybe, but using unboxed sums. +-- +-- Use with care. Using a unboxed maybe is not always a win +-- in execution *time* even when allocations go down. So make +-- sure to benchmark for execution time as well. If the difference +-- in *runtime* for the compiler is too small to measure it's likely +-- better to use a regular Maybe instead. +-- +-- This is since it causes more function arguments to be passed, and +-- potentially more variables to be captured by closures increasing +-- closure size. +newtype MaybeUB a = MaybeUB (# (# #) | a #) + +pattern JustUB :: a -> MaybeUB a +pattern JustUB x = MaybeUB (# | x #) + +pattern NothingUB :: MaybeUB a +pattern NothingUB = MaybeUB (# (# #) | #) + +{-# COMPLETE NothingUB, JustUB #-} + +fromMaybeUB :: a -> MaybeUB a -> a +fromMaybeUB d NothingUB = d +fromMaybeUB _ (JustUB x) = x + +apMaybeUB :: MaybeUB (a -> b) -> MaybeUB a -> MaybeUB b +apMaybeUB (JustUB f) (JustUB x) = JustUB (f x) +apMaybeUB _ _ = NothingUB + +fmapMaybeUB :: (a -> b) -> MaybeUB a -> MaybeUB b +fmapMaybeUB _f NothingUB = NothingUB +fmapMaybeUB f (JustUB x) = JustUB $ f x + +maybeUB :: b -> (a -> b) -> MaybeUB a -> b +maybeUB _def f (JustUB x) = f x +maybeUB def _f NothingUB = def diff --git a/GHC/Data/UnionFind.hs b/GHC/Data/UnionFind.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/UnionFind.hs @@ -0,0 +1,91 @@ +{- Union-find data structure compiled from Distribution.Utils.UnionFind -} +module GHC.Data.UnionFind where + +import GHC.Prelude +import Data.STRef +import Control.Monad.ST +import Control.Monad + +-- | A variable which can be unified; alternately, this can be thought +-- of as an equivalence class with a distinguished representative. +newtype Point s a = Point (STRef s (Link s a)) + deriving (Eq) + +-- | Mutable write to a 'Point' +writePoint :: Point s a -> Link s a -> ST s () +writePoint (Point v) = writeSTRef v + +-- | Read the current value of 'Point'. +readPoint :: Point s a -> ST s (Link s a) +readPoint (Point v) = readSTRef v + +-- | The internal data structure for a 'Point', which either records +-- the representative element of an equivalence class, or a link to +-- the 'Point' that actually stores the representative type. +data Link s a + -- NB: it is too bad we can't say STRef Int#; the weights remain boxed + = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) + | Link {-# UNPACK #-} !(Point s a) + +-- | Create a fresh equivalence class with one element. +fresh :: a -> ST s (Point s a) +fresh desc = do + weight <- newSTRef 1 + descriptor <- newSTRef desc + Point `fmap` newSTRef (Info weight descriptor) + +-- | Flatten any chains of links, returning a 'Point' +-- which points directly to the canonical representation. +repr :: Point s a -> ST s (Point s a) +repr point = readPoint point >>= \r -> + case r of + Link point' -> do + point'' <- repr point' + when (point'' /= point') $ do + writePoint point =<< readPoint point' + return point'' + Info _ _ -> return point + +-- | Return the canonical element of an equivalence +-- class 'Point'. +find :: Point s a -> ST s a +find point = + -- Optimize length 0 and 1 case at expense of + -- general case + readPoint point >>= \r -> + case r of + Info _ d_ref -> readSTRef d_ref + Link point' -> readPoint point' >>= \r' -> + case r' of + Info _ d_ref -> readSTRef d_ref + Link _ -> repr point >>= find + +-- | Unify two equivalence classes, so that they share +-- a canonical element. Keeps the descriptor of point2. +union :: Point s a -> Point s a -> ST s () +union refpoint1 refpoint2 = do + point1 <- repr refpoint1 + point2 <- repr refpoint2 + when (point1 /= point2) $ do + l1 <- readPoint point1 + l2 <- readPoint point2 + case (l1, l2) of + (Info wref1 dref1, Info wref2 dref2) -> do + weight1 <- readSTRef wref1 + weight2 <- readSTRef wref2 + -- Should be able to optimize the == case separately + if weight1 >= weight2 + then do + writePoint point2 (Link point1) + -- The weight calculation here seems a bit dodgy + writeSTRef wref1 (weight1 + weight2) + writeSTRef dref1 =<< readSTRef dref2 + else do + writePoint point1 (Link point2) + writeSTRef wref2 (weight1 + weight2) + _ -> error "UnionFind.union: repr invariant broken" + +-- | Test if two points are in the same equivalence class. +equivalent :: Point s a -> Point s a -> ST s Bool +equivalent point1 point2 = liftM2 (==) (repr point1) (repr point2) + diff --git a/GHC/Data/Word64Map.hs b/GHC/Data/Word64Map.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Word64Map.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MonoLocalBinds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Word64Map +-- Copyright : (c) Daan Leijen 2002 +-- (c) Andriy Palamarchuk 2008 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- An efficient implementation of maps from integer keys to values +-- (dictionaries). +-- +-- This module re-exports the value lazy "Data.Word64Map.Lazy" API, plus +-- several deprecated value strict functions. Please note that these functions +-- have different strictness properties than those in "Data.Word64Map.Strict": +-- they only evaluate the result of the combining function. For example, the +-- default value to 'insertWith'' is only evaluated if the combining function +-- is called and uses it. +-- +-- These modules are intended to be imported qualified, to avoid name +-- clashes with Prelude functions, e.g. +-- +-- > import Data.Word64Map (Word64Map) +-- > import qualified Data.Word64Map as Word64Map +-- +-- The implementation is based on /big-endian patricia trees/. This data +-- structure performs especially well on binary operations like 'union' +-- and 'intersection'. However, my benchmarks show that it is also +-- (much) faster on insertions and deletions when compared to a generic +-- size-balanced map implementation (see "Data.Map"). +-- +-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", +-- Workshop on ML, September 1998, pages 77-86, +-- +-- +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\", +-- Journal of the ACM, 15(4), October 1968, pages 514-534. +-- +-- Operation comments contain the operation time complexity in +-- the Big-O notation . +-- Many operations have a worst-case complexity of \(O(\min(n,64))\). +-- This means that the operation can become linear in the number of +-- elements with a maximum of \(64\) +----------------------------------------------------------------------------- + +module GHC.Data.Word64Map + ( module GHC.Data.Word64Map.Lazy + ) where + +import GHC.Data.Word64Map.Lazy diff --git a/GHC/Data/Word64Map/Internal.hs b/GHC/Data/Word64Map/Internal.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Word64Map/Internal.hs @@ -0,0 +1,3575 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Word64Map.Internal +-- Copyright : (c) Daan Leijen 2002 +-- (c) Andriy Palamarchuk 2008 +-- (c) wren romano 2016 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. +-- +-- = Description +-- +-- This defines the data structures and core (hidden) manipulations +-- on representations. +-- +-- @since 0.5.9 +----------------------------------------------------------------------------- + +-- [Note: INLINE bit fiddling] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- It is essential that the bit fiddling functions like mask, zero, branchMask +-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC +-- usually gets it right, but it is disastrous if it does not. Therefore we +-- explicitly mark these functions INLINE. + + +-- [Note: Local 'go' functions and capturing] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Care must be taken when using 'go' function which captures an argument. +-- Sometimes (for example when the argument is passed to a data constructor, +-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code +-- must be checked for increased allocation when creating and modifying such +-- functions. + + +-- [Note: Order of constructors] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The order of constructors of Word64Map matters when considering performance. +-- Currently in GHC 7.0, when type has 3 constructors, they are matched from +-- the first to the last -- the best performance is achieved when the +-- constructors are ordered by frequency. +-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil +-- improves the benchmark by circa 10%. +-- + +module GHC.Data.Word64Map.Internal ( + -- * Map type + Word64Map(..), Key -- instance Eq,Show + + -- * Operators + , (!), (!?), (\\) + + -- * Query + , null + , size + , member + , notMember + , lookup + , findWithDefault + , lookupLT + , lookupGT + , lookupLE + , lookupGE + , disjoint + + -- * Construction + , empty + , singleton + + -- ** Insertion + , insert + , insertWith + , insertWithKey + , insertLookupWithKey + + -- ** Delete\/Update + , delete + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + , alter + , alterF + + -- * Combine + + -- ** Union + , union + , unionWith + , unionWithKey + , unions + , unionsWith + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithKey + + -- ** Compose + , compose + + -- ** General combining function + , SimpleWhenMissing + , SimpleWhenMatched + , runWhenMatched + , runWhenMissing + , merge + -- *** @WhenMatched@ tactics + , zipWithMaybeMatched + , zipWithMatched + -- *** @WhenMissing@ tactics + , mapMaybeMissing + , dropMissing + , preserveMissing + , mapMissing + , filterMissing + + -- ** Applicative general combining function + , WhenMissing (..) + , WhenMatched (..) + , mergeA + -- *** @WhenMatched@ tactics + -- | The tactics described for 'merge' work for + -- 'mergeA' as well. Furthermore, the following + -- are available. + , zipWithMaybeAMatched + , zipWithAMatched + -- *** @WhenMissing@ tactics + -- | The tactics described for 'merge' work for + -- 'mergeA' as well. Furthermore, the following + -- are available. + , traverseMaybeMissing + , traverseMissing + , filterAMissing + + -- ** Deprecated general combining function + , mergeWithKey + , mergeWithKey' + + -- * Traversal + -- ** Map + , map + , mapWithKey + , traverseWithKey + , traverseMaybeWithKey + , mapAccum + , mapAccumWithKey + , mapAccumRWithKey + , mapKeys + , mapKeysWith + , mapKeysMonotonic + + -- * Folds + , foldr + , foldl + , foldrWithKey + , foldlWithKey + , foldMapWithKey + + -- ** Strict folds + , foldr' + , foldl' + , foldrWithKey' + , foldlWithKey' + + -- * Conversion + , elems + , keys + , assocs + , keysSet + , fromSet + + -- ** Lists + , toList + , fromList + , fromListWith + , fromListWithKey + + -- ** Ordered lists + , toAscList + , toDescList + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Filter + , filter + , filterWithKey + , restrictKeys + , withoutKeys + , partition + , partitionWithKey + + , takeWhileAntitone + , dropWhileAntitone + , spanAntitone + + , mapMaybe + , mapMaybeWithKey + , mapEither + , mapEitherWithKey + + , split + , splitLookup + , splitRoot + + -- * Submap + , isSubmapOf, isSubmapOfBy + , isProperSubmapOf, isProperSubmapOfBy + + -- * Min\/Max + , lookupMin + , lookupMax + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , updateMin + , updateMax + , updateMinWithKey + , updateMaxWithKey + , minView + , maxView + , minViewWithKey + , maxViewWithKey + + -- * Debugging + , showTree + , showTreeWith + + -- * Internal types + , Mask, Prefix, Nat + + -- * Utility + , natFromInt + , intFromNat + , link + , linkWithMask + , bin + , binCheckLeft + , binCheckRight + , zero + , nomatch + , match + , mask + , maskW + , shorter + , branchMask + , highestBitMask + + -- * Used by "Word64Map.Merge.Lazy" and "Word64Map.Merge.Strict" + , mapWhenMissing + , mapWhenMatched + , lmapWhenMissing + , contramapFirstWhenMatched + , contramapSecondWhenMatched + , mapGentlyWhenMissing + , mapGentlyWhenMatched + ) where + +import GHC.Prelude.Basic hiding + (lookup, filter, foldr, foldl, foldl', null, map) + +import Data.Functor.Identity (Identity (..)) +import Data.Semigroup (Semigroup(stimes,(<>)),stimesIdempotentMonoid) +import Data.Functor.Classes + +import Control.DeepSeq (NFData(rnf)) +import qualified Data.Foldable as Foldable +import Data.Maybe (fromMaybe) + +import GHC.Data.Word64Set.Internal (Key) +import qualified GHC.Data.Word64Set.Internal as Word64Set +import GHC.Utils.Containers.Internal.BitUtil +import GHC.Utils.Containers.Internal.StrictPair + +import Data.Coerce +import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), + DataType, mkDataType, gcast1) +import GHC.Exts (build) +import qualified GHC.Exts as GHCExts +import Text.Read +import qualified Control.Category as Category +import Data.Word + + +-- A "Nat" is a 64 bit machine word (an unsigned Int64) +type Nat = Word64 + +natFromInt :: Key -> Nat +natFromInt = id +{-# INLINE natFromInt #-} + +intFromNat :: Nat -> Key +intFromNat = id +{-# INLINE intFromNat #-} + +{-------------------------------------------------------------------- + Types +--------------------------------------------------------------------} + + +-- | A map of integers to values @a@. + +-- See Note: Order of constructors +data Word64Map a = Bin {-# UNPACK #-} !Prefix + {-# UNPACK #-} !Mask + !(Word64Map a) + !(Word64Map a) +-- Fields: +-- prefix: The most significant bits shared by all keys in this Bin. +-- mask: The switching bit to determine if a key should follow the left +-- or right subtree of a 'Bin'. +-- Invariant: Nil is never found as a child of Bin. +-- Invariant: The Mask is a power of 2. It is the largest bit position at which +-- two keys of the map differ. +-- Invariant: Prefix is the common high-order bits that all elements share to +-- the left of the Mask bit. +-- Invariant: In (Bin prefix mask left right), left consists of the elements that +-- don't have the mask bit set; right is all the elements that do. + | Tip {-# UNPACK #-} !Key a + | Nil + +type Prefix = Word64 +type Mask = Word64 + + +-- Some stuff from "Data.Word64Set.Internal", for 'restrictKeys' and +-- 'withoutKeys' to use. +type Word64SetPrefix = Word64 +type Word64SetBitMap = Word64 + +bitmapOf :: Word64 -> Word64SetBitMap +bitmapOf x = shiftLL 1 (fromIntegral (x .&. Word64Set.suffixBitMask)) +{-# INLINE bitmapOf #-} + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} + +-- | \(O(\min(n,W))\). Find the value at a key. +-- Calls 'error' when the element can not be found. +-- +-- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map +-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a' + +(!) :: Word64Map a -> Key -> a +(!) m k = find k m + +-- | \(O(\min(n,W))\). Find the value at a key. +-- Returns 'Nothing' when the element can not be found. +-- +-- > fromList [(5,'a'), (3,'b')] !? 1 == Nothing +-- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a' +-- +-- @since 0.5.11 + +(!?) :: Word64Map a -> Key -> Maybe a +(!?) m k = lookup k m + +-- | Same as 'difference'. +(\\) :: Word64Map a -> Word64Map b -> Word64Map a +m1 \\ m2 = difference m1 m2 + +infixl 9 !?,\\{-This comment teaches CPP correct behaviour -} + +{-------------------------------------------------------------------- + Types +--------------------------------------------------------------------} + +instance Monoid (Word64Map a) where + mempty = empty + mconcat = unions + mappend = (<>) + +-- | @since 0.5.7 +instance Semigroup (Word64Map a) where + (<>) = union + stimes = stimesIdempotentMonoid + +-- | Folds in order of increasing key. +instance Foldable.Foldable Word64Map where + fold = go + where go Nil = mempty + go (Tip _ v) = v + go (Bin _ m l r) + | m < 0 = go r `mappend` go l + | otherwise = go l `mappend` go r + {-# INLINABLE fold #-} + foldr = foldr + {-# INLINE foldr #-} + foldl = foldl + {-# INLINE foldl #-} + foldMap f t = go t + where go Nil = mempty + go (Tip _ v) = f v + go (Bin _ m l r) + | m < 0 = go r `mappend` go l + | otherwise = go l `mappend` go r + {-# INLINE foldMap #-} + foldl' = foldl' + {-# INLINE foldl' #-} + foldr' = foldr' + {-# INLINE foldr' #-} + length = size + {-# INLINE length #-} + null = null + {-# INLINE null #-} + toList = elems -- NB: Foldable.toList /= Word64Map.toList + {-# INLINE toList #-} + elem = go + where go !_ Nil = False + go x (Tip _ y) = x == y + go x (Bin _ _ l r) = go x l || go x r + {-# INLINABLE elem #-} + maximum = start + where start Nil = error "Data.Foldable.maximum (for Data.Word64Map): empty map" + start (Tip _ y) = y + start (Bin _ m l r) + | m < 0 = go (start r) l + | otherwise = go (start l) r + + go !m Nil = m + go m (Tip _ y) = max m y + go m (Bin _ _ l r) = go (go m l) r + {-# INLINABLE maximum #-} + minimum = start + where start Nil = error "Data.Foldable.minimum (for Data.Word64Map): empty map" + start (Tip _ y) = y + start (Bin _ m l r) + | m < 0 = go (start r) l + | otherwise = go (start l) r + + go !m Nil = m + go m (Tip _ y) = min m y + go m (Bin _ _ l r) = go (go m l) r + {-# INLINABLE minimum #-} + sum = foldl' (+) 0 + {-# INLINABLE sum #-} + product = foldl' (*) 1 + {-# INLINABLE product #-} + +-- | Traverses in order of increasing key. +instance Traversable Word64Map where + traverse f = traverseWithKey (\_ -> f) + {-# INLINE traverse #-} + +instance NFData a => NFData (Word64Map a) where + rnf Nil = () + rnf (Tip _ v) = rnf v + rnf (Bin _ _ l r) = rnf l `seq` rnf r + + +{-------------------------------------------------------------------- + A Data instance +--------------------------------------------------------------------} + +-- This instance preserves data abstraction at the cost of inefficiency. +-- We provide limited reflection services for the sake of data abstraction. + +instance Data a => Data (Word64Map a) where + gfoldl f z im = z fromList `f` (toList im) + toConstr _ = fromListConstr + gunfold k z c = case constrIndex c of + 1 -> k (z fromList) + _ -> error "gunfold" + dataTypeOf _ = intMapDataType + dataCast1 f = gcast1 f + +fromListConstr :: Constr +fromListConstr = mkConstr intMapDataType "fromList" [] Prefix + +intMapDataType :: DataType +intMapDataType = mkDataType "Data.Word64Map.Internal.Word64Map" [fromListConstr] + + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | \(O(1)\). Is the map empty? +-- +-- > Data.Word64Map.null (empty) == True +-- > Data.Word64Map.null (singleton 1 'a') == False + +null :: Word64Map a -> Bool +null Nil = True +null _ = False +{-# INLINE null #-} + +-- | \(O(n)\). Number of elements in the map. +-- +-- > size empty == 0 +-- > size (singleton 1 'a') == 1 +-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3 +size :: Word64Map a -> Int +size = go 0 + where + go !acc (Bin _ _ l r) = go (go acc l) r + go acc (Tip _ _) = 1 + acc + go acc Nil = acc + +-- | \(O(\min(n,W))\). Is the key a member of the map? +-- +-- > member 5 (fromList [(5,'a'), (3,'b')]) == True +-- > member 1 (fromList [(5,'a'), (3,'b')]) == False + +-- See Note: Local 'go' functions and capturing] +member :: Key -> Word64Map a -> Bool +member !k = go + where + go (Bin p m l r) | nomatch k p m = False + | zero k m = go l + | otherwise = go r + go (Tip kx _) = k == kx + go Nil = False + +-- | \(O(\min(n,W))\). Is the key not a member of the map? +-- +-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False +-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True + +notMember :: Key -> Word64Map a -> Bool +notMember k m = not $ member k m + +-- | \(O(\min(n,W))\). Lookup the value at a key in the map. See also 'Data.Map.lookup'. + +-- See Note: Local 'go' functions and capturing +lookup :: Key -> Word64Map a -> Maybe a +lookup !k = go + where + go (Bin _p m l r) | zero k m = go l + | otherwise = go r + go (Tip kx x) | k == kx = Just x + | otherwise = Nothing + go Nil = Nothing + +-- See Note: Local 'go' functions and capturing] +find :: Key -> Word64Map a -> a +find !k = go + where + go (Bin _p m l r) | zero k m = go l + | otherwise = go r + go (Tip kx x) | k == kx = x + | otherwise = not_found + go Nil = not_found + + not_found = error ("Word64Map.!: key " ++ show k ++ " is not an element of the map") + +-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@ +-- returns the value at key @k@ or returns @def@ when the key is not an +-- element of the map. +-- +-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' +-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' + +-- See Note: Local 'go' functions and capturing] +findWithDefault :: a -> Key -> Word64Map a -> a +findWithDefault def !k = go + where + go (Bin p m l r) | nomatch k p m = def + | zero k m = go l + | otherwise = go r + go (Tip kx x) | k == kx = x + | otherwise = def + go Nil = def + +-- | \(O(\min(n,W))\). Find largest key smaller than the given one and return the +-- corresponding (key, value) pair. +-- +-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing +-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') + +-- See Note: Local 'go' functions and capturing. +lookupLT :: Key -> Word64Map a -> Maybe (Key, a) +lookupLT !k t = case t of + Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r + _ -> go Nil t + where + go def (Bin p m l r) + | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r + | zero k m = go def l + | otherwise = go l r + go def (Tip ky y) + | k <= ky = unsafeFindMax def + | otherwise = Just (ky, y) + go def Nil = unsafeFindMax def + +-- | \(O(\min(n,W))\). Find smallest key greater than the given one and return the +-- corresponding (key, value) pair. +-- +-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') +-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing + +-- See Note: Local 'go' functions and capturing. +lookupGT :: Key -> Word64Map a -> Maybe (Key, a) +lookupGT !k t = case t of + Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r + _ -> go Nil t + where + go def (Bin p m l r) + | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def + | zero k m = go r l + | otherwise = go def r + go def (Tip ky y) + | k >= ky = unsafeFindMin def + | otherwise = Just (ky, y) + go def Nil = unsafeFindMin def + +-- | \(O(\min(n,W))\). Find largest key smaller or equal to the given one and return +-- the corresponding (key, value) pair. +-- +-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing +-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') +-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') + +-- See Note: Local 'go' functions and capturing. +lookupLE :: Key -> Word64Map a -> Maybe (Key, a) +lookupLE !k t = case t of + Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r + _ -> go Nil t + where + go def (Bin p m l r) + | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r + | zero k m = go def l + | otherwise = go l r + go def (Tip ky y) + | k < ky = unsafeFindMax def + | otherwise = Just (ky, y) + go def Nil = unsafeFindMax def + +-- | \(O(\min(n,W))\). Find smallest key greater or equal to the given one and return +-- the corresponding (key, value) pair. +-- +-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') +-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') +-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing + +-- See Note: Local 'go' functions and capturing. +lookupGE :: Key -> Word64Map a -> Maybe (Key, a) +lookupGE !k t = case t of + Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r + _ -> go Nil t + where + go def (Bin p m l r) + | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def + | zero k m = go r l + | otherwise = go def r + go def (Tip ky y) + | k > ky = unsafeFindMin def + | otherwise = Just (ky, y) + go def Nil = unsafeFindMin def + + +-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is +-- given, it has m > 0. +unsafeFindMin :: Word64Map a -> Maybe (Key, a) +unsafeFindMin Nil = Nothing +unsafeFindMin (Tip ky y) = Just (ky, y) +unsafeFindMin (Bin _ _ l _) = unsafeFindMin l + +-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is +-- given, it has m > 0. +unsafeFindMax :: Word64Map a -> Maybe (Key, a) +unsafeFindMax Nil = Nothing +unsafeFindMax (Tip ky y) = Just (ky, y) +unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r + +{-------------------------------------------------------------------- + Disjoint +--------------------------------------------------------------------} +-- | \(O(n+m)\). Check whether the key sets of two maps are disjoint +-- (i.e. their 'intersection' is empty). +-- +-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True +-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False +-- > disjoint (fromList []) (fromList []) == True +-- +-- > disjoint a b == null (intersection a b) +-- +-- @since 0.6.2.1 +disjoint :: Word64Map a -> Word64Map b -> Bool +disjoint Nil _ = True +disjoint _ Nil = True +disjoint (Tip kx _) ys = notMember kx ys +disjoint xs (Tip ky _) = notMember ky xs +disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = disjoint1 + | shorter m2 m1 = disjoint2 + | p1 == p2 = disjoint l1 l2 && disjoint r1 r2 + | otherwise = True + where + disjoint1 | nomatch p2 p1 m1 = True + | zero p2 m1 = disjoint l1 t2 + | otherwise = disjoint r1 t2 + disjoint2 | nomatch p1 p2 m2 = True + | zero p1 m2 = disjoint t1 l2 + | otherwise = disjoint t1 r2 + +{-------------------------------------------------------------------- + Compose +--------------------------------------------------------------------} +-- | Relate the keys of one map to the values of +-- the other, by using the values of the former as keys for lookups +-- in the latter. +-- +-- Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument +-- +-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")] +-- +-- @ +-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?') +-- @ +-- +-- __Note:__ Prior to v0.6.4, "Data.Word64Map.Strict" exposed a version of +-- 'compose' that forced the values of the output 'Word64Map'. This version does +-- not force these values. +-- +-- @since 0.6.3.1 +compose :: Word64Map c -> Word64Map Word64 -> Word64Map c +compose bc !ab + | null bc = empty + | otherwise = mapMaybe (bc !?) ab + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | \(O(1)\). The empty map. +-- +-- > empty == fromList [] +-- > size empty == 0 + +empty :: Word64Map a +empty + = Nil +{-# INLINE empty #-} + +-- | \(O(1)\). A map of one element. +-- +-- > singleton 1 'a' == fromList [(1, 'a')] +-- > size (singleton 1 'a') == 1 + +singleton :: Key -> a -> Word64Map a +singleton k x + = Tip k x +{-# INLINE singleton #-} + +{-------------------------------------------------------------------- + Insert +--------------------------------------------------------------------} +-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map. +-- If the key is already present in the map, the associated value is +-- replaced with the supplied value, i.e. 'insert' is equivalent to +-- @'insertWith' 'const'@. +-- +-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] +-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] +-- > insert 5 'x' empty == singleton 5 'x' + +insert :: Key -> a -> Word64Map a -> Word64Map a +insert !k x t@(Bin p m l r) + | nomatch k p m = link k (Tip k x) p t + | zero k m = Bin p m (insert k x l) r + | otherwise = Bin p m l (insert k x r) +insert k x t@(Tip ky _) + | k==ky = Tip k x + | otherwise = link k (Tip k x) ky t +insert k x Nil = Tip k x + +-- right-biased insertion, used by 'union' +-- | \(O(\min(n,W))\). Insert with a combining function. +-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert @f new_value old_value@. +-- +-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] +-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" + +insertWith :: (a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a +insertWith f k x t + = insertWithKey (\_ x' y' -> f x' y') k x t + +-- | \(O(\min(n,W))\). Insert with a combining function. +-- @'insertWithKey' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert @f key new_value old_value@. +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] +-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" + +insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a +insertWithKey f !k x t@(Bin p m l r) + | nomatch k p m = link k (Tip k x) p t + | zero k m = Bin p m (insertWithKey f k x l) r + | otherwise = Bin p m l (insertWithKey f k x r) +insertWithKey f k x t@(Tip ky y) + | k == ky = Tip k (f k x y) + | otherwise = link k (Tip k x) ky t +insertWithKey _ k x Nil = Tip k x + +-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@) +-- is a pair where the first element is equal to (@'lookup' k map@) +-- and the second element equal to (@'insertWithKey' f k x map@). +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) +-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) +-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") +-- +-- This is how to define @insertLookup@ using @insertLookupWithKey@: +-- +-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t +-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) +-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) + +insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> (Maybe a, Word64Map a) +insertLookupWithKey f !k x t@(Bin p m l r) + | nomatch k p m = (Nothing,link k (Tip k x) p t) + | zero k m = let (found,l') = insertLookupWithKey f k x l + in (found,Bin p m l' r) + | otherwise = let (found,r') = insertLookupWithKey f k x r + in (found,Bin p m l r') +insertLookupWithKey f k x t@(Tip ky y) + | k == ky = (Just y,Tip k (f k x y)) + | otherwise = (Nothing,link k (Tip k x) ky t) +insertLookupWithKey _ k x Nil = (Nothing,Tip k x) + + +{-------------------------------------------------------------------- + Deletion +--------------------------------------------------------------------} +-- | \(O(\min(n,W))\). Delete a key and its value from the map. When the key is not +-- a member of the map, the original map is returned. +-- +-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > delete 5 empty == empty + +delete :: Key -> Word64Map a -> Word64Map a +delete !k t@(Bin p m l r) + | nomatch k p m = t + | zero k m = binCheckLeft p m (delete k l) r + | otherwise = binCheckRight p m l (delete k r) +delete k t@(Tip ky _) + | k == ky = Nil + | otherwise = t +delete _k Nil = Nil + +-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +-- +-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] +-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > adjust ("new " ++) 7 empty == empty + +adjust :: (a -> a) -> Key -> Word64Map a -> Word64Map a +adjust f k m + = adjustWithKey (\_ x -> f x) k m + +-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +-- +-- > let f key x = (show key) ++ ":new " ++ x +-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > adjustWithKey f 7 empty == empty + +adjustWithKey :: (Key -> a -> a) -> Key -> Word64Map a -> Word64Map a +adjustWithKey f !k (Bin p m l r) + | zero k m = Bin p m (adjustWithKey f k l) r + | otherwise = Bin p m l (adjustWithKey f k r) +adjustWithKey f k t@(Tip ky y) + | k == ky = Tip ky (f k y) + | otherwise = t +adjustWithKey _ _ Nil = Nil + + +-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] +-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" + +update :: (a -> Maybe a) -> Key -> Word64Map a -> Word64Map a +update f + = updateWithKey (\_ x -> f x) + +-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" + +updateWithKey :: (Key -> a -> Maybe a) -> Key -> Word64Map a -> Word64Map a +updateWithKey f !k (Bin p m l r) + | zero k m = binCheckLeft p m (updateWithKey f k l) r + | otherwise = binCheckRight p m l (updateWithKey f k r) +updateWithKey f k t@(Tip ky y) + | k == ky = case (f k y) of + Just y' -> Tip ky y' + Nothing -> Nil + | otherwise = t +updateWithKey _ _ Nil = Nil + +-- | \(O(\min(n,W))\). Lookup and update. +-- The function returns original value, if it is updated. +-- This is different behavior than 'Data.Map.updateLookupWithKey'. +-- Returns the original key value if the map entry is deleted. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) +-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) +-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") + +updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> Word64Map a -> (Maybe a,Word64Map a) +updateLookupWithKey f !k (Bin p m l r) + | zero k m = let !(found,l') = updateLookupWithKey f k l + in (found,binCheckLeft p m l' r) + | otherwise = let !(found,r') = updateLookupWithKey f k r + in (found,binCheckRight p m l r') +updateLookupWithKey f k t@(Tip ky y) + | k==ky = case (f k y) of + Just y' -> (Just y,Tip ky y') + Nothing -> (Just y,Nil) + | otherwise = (Nothing,t) +updateLookupWithKey _ _ Nil = (Nothing,Nil) + + + +-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. +-- 'alter' can be used to insert, delete, or update a value in an 'Word64Map'. +-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. +alter :: (Maybe a -> Maybe a) -> Key -> Word64Map a -> Word64Map a +alter f !k t@(Bin p m l r) + | nomatch k p m = case f Nothing of + Nothing -> t + Just x -> link k (Tip k x) p t + | zero k m = binCheckLeft p m (alter f k l) r + | otherwise = binCheckRight p m l (alter f k r) +alter f k t@(Tip ky y) + | k==ky = case f (Just y) of + Just x -> Tip ky x + Nothing -> Nil + | otherwise = case f Nothing of + Just x -> link k (Tip k x) ky t + Nothing -> Tip ky y +alter f k Nil = case f Nothing of + Just x -> Tip k x + Nothing -> Nil + +-- | \(O(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at +-- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, +-- or update a value in an 'Word64Map'. In short : @'lookup' k <$> 'alterF' f k m = f +-- ('lookup' k m)@. +-- +-- Example: +-- +-- @ +-- interactiveAlter :: Int -> Word64Map String -> IO (Word64Map String) +-- interactiveAlter k m = alterF f k m where +-- f Nothing = do +-- putStrLn $ show k ++ +-- " was not found in the map. Would you like to add it?" +-- getUserResponse1 :: IO (Maybe String) +-- f (Just old) = do +-- putStrLn $ "The key is currently bound to " ++ show old ++ +-- ". Would you like to change or delete it?" +-- getUserResponse2 :: IO (Maybe String) +-- @ +-- +-- 'alterF' is the most general operation for working with an individual +-- key that may or may not be in a given map. +-- +-- Note: 'alterF' is a flipped version of the @at@ combinator from +-- @Control.Lens.At@. +-- +-- @since 0.5.8 + +alterF :: Functor f + => (Maybe a -> f (Maybe a)) -> Key -> Word64Map a -> f (Word64Map a) +-- This implementation was stolen from 'Control.Lens.At'. +alterF f k m = (<$> f mv) $ \fres -> + case fres of + Nothing -> maybe m (const (delete k m)) mv + Just v' -> insert k v' m + where mv = lookup k m + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +-- | The union of a list of maps. +-- +-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] +-- > == fromList [(3, "b"), (5, "a"), (7, "C")] +-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] +-- > == fromList [(3, "B3"), (5, "A3"), (7, "C")] + +unions :: Foldable f => f (Word64Map a) -> Word64Map a +unions xs + = Foldable.foldl' union empty xs + +-- | The union of a list of maps, with a combining operation. +-- +-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] +-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] + +unionsWith :: Foldable f => (a->a->a) -> f (Word64Map a) -> Word64Map a +unionsWith f ts + = Foldable.foldl' (unionWith f) empty ts + +-- | \(O(n+m)\). The (left-biased) union of two maps. +-- It prefers the first map when duplicate keys are encountered, +-- i.e. (@'union' == 'unionWith' 'const'@). +-- +-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")] + +union :: Word64Map a -> Word64Map a -> Word64Map a +union m1 m2 + = mergeWithKey' Bin const id id m1 m2 + +-- | \(O(n+m)\). The union with a combining function. +-- +-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] + +unionWith :: (a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a +unionWith f m1 m2 + = unionWithKey (\_ x y -> f x y) m1 m2 + +-- | \(O(n+m)\). The union with a combining function. +-- +-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value +-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] + +unionWithKey :: (Key -> a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a +unionWithKey f m1 m2 + = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2 + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} +-- | \(O(n+m)\). Difference between two maps (based on keys). +-- +-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b" + +difference :: Word64Map a -> Word64Map b -> Word64Map a +difference m1 m2 + = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2 + +-- | \(O(n+m)\). Difference with a combining function. +-- +-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing +-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) +-- > == singleton 3 "b:B" + +differenceWith :: (a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a +differenceWith f m1 m2 + = differenceWithKey (\_ x y -> f x y) m1 m2 + +-- | \(O(n+m)\). Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns 'Nothing', the element is discarded (proper set difference). +-- If it returns (@'Just' y@), the element is updated with a new value @y@. +-- +-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing +-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) +-- > == singleton 3 "3:b|B" + +differenceWithKey :: (Key -> a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a +differenceWithKey f m1 m2 + = mergeWithKey f id (const Nil) m1 m2 + + +-- TODO(wrengr): re-verify that asymptotic bound +-- | \(O(n+m)\). Remove all the keys in a given set from a map. +-- +-- @ +-- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``Word64Set.notMember`` s) m +-- @ +-- +-- @since 0.5.8 +withoutKeys :: Word64Map a -> Word64Set.Word64Set -> Word64Map a +withoutKeys t1@(Bin p1 m1 l1 r1) t2@(Word64Set.Bin p2 m2 l2 r2) + | shorter m1 m2 = difference1 + | shorter m2 m1 = difference2 + | p1 == p2 = bin p1 m1 (withoutKeys l1 l2) (withoutKeys r1 r2) + | otherwise = t1 + where + difference1 + | nomatch p2 p1 m1 = t1 + | zero p2 m1 = binCheckLeft p1 m1 (withoutKeys l1 t2) r1 + | otherwise = binCheckRight p1 m1 l1 (withoutKeys r1 t2) + difference2 + | nomatch p1 p2 m2 = t1 + | zero p1 m2 = withoutKeys t1 l2 + | otherwise = withoutKeys t1 r2 +withoutKeys t1@(Bin p1 m1 _ _) (Word64Set.Tip p2 bm2) = + let minbit = bitmapOf p1 + lt_minbit = minbit - 1 + maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1))) + gt_maxbit = (-maxbit) `xor` maxbit + -- TODO(wrengr): should we manually inline/unroll 'updatePrefix' + -- and 'withoutBM' here, in order to avoid redundant case analyses? + in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit) +withoutKeys t1@(Bin _ _ _ _) Word64Set.Nil = t1 +withoutKeys t1@(Tip k1 _) t2 + | k1 `Word64Set.member` t2 = Nil + | otherwise = t1 +withoutKeys Nil _ = Nil + + +updatePrefix + :: Word64SetPrefix -> Word64Map a -> (Word64Map a -> Word64Map a) -> Word64Map a +updatePrefix !kp t@(Bin p m l r) f + | m .&. Word64Set.suffixBitMask /= 0 = + if p .&. Word64Set.prefixBitMask == kp then f t else t + | nomatch kp p m = t + | zero kp m = binCheckLeft p m (updatePrefix kp l f) r + | otherwise = binCheckRight p m l (updatePrefix kp r f) +updatePrefix kp t@(Tip kx _) f + | kx .&. Word64Set.prefixBitMask == kp = f t + | otherwise = t +updatePrefix _ Nil _ = Nil + + +withoutBM :: Word64SetBitMap -> Word64Map a -> Word64Map a +withoutBM 0 t = t +withoutBM bm (Bin p m l r) = + let leftBits = bitmapOf (p .|. m) - 1 + bmL = bm .&. leftBits + bmR = bm `xor` bmL -- = (bm .&. complement leftBits) + in bin p m (withoutBM bmL l) (withoutBM bmR r) +withoutBM bm t@(Tip k _) + -- TODO(wrengr): need we manually inline 'Word64Set.Member' here? + | k `Word64Set.member` Word64Set.Tip (k .&. Word64Set.prefixBitMask) bm = Nil + | otherwise = t +withoutBM _ Nil = Nil + + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} +-- | \(O(n+m)\). The (left-biased) intersection of two maps (based on keys). +-- +-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a" + +intersection :: Word64Map a -> Word64Map b -> Word64Map a +intersection m1 m2 + = mergeWithKey' bin const (const Nil) (const Nil) m1 m2 + + +-- TODO(wrengr): re-verify that asymptotic bound +-- | \(O(n+m)\). The restriction of a map to the keys in a set. +-- +-- @ +-- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``Word64Set.member`` s) m +-- @ +-- +-- @since 0.5.8 +restrictKeys :: Word64Map a -> Word64Set.Word64Set -> Word64Map a +restrictKeys t1@(Bin p1 m1 l1 r1) t2@(Word64Set.Bin p2 m2 l2 r2) + | shorter m1 m2 = intersection1 + | shorter m2 m1 = intersection2 + | p1 == p2 = bin p1 m1 (restrictKeys l1 l2) (restrictKeys r1 r2) + | otherwise = Nil + where + intersection1 + | nomatch p2 p1 m1 = Nil + | zero p2 m1 = restrictKeys l1 t2 + | otherwise = restrictKeys r1 t2 + intersection2 + | nomatch p1 p2 m2 = Nil + | zero p1 m2 = restrictKeys t1 l2 + | otherwise = restrictKeys t1 r2 +restrictKeys t1@(Bin p1 m1 _ _) (Word64Set.Tip p2 bm2) = + let minbit = bitmapOf p1 + ge_minbit = complement (minbit - 1) + maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1))) + le_maxbit = maxbit .|. (maxbit - 1) + -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix' + -- and 'restrictBM' here, in order to avoid redundant case analyses? + in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1) +restrictKeys (Bin _ _ _ _) Word64Set.Nil = Nil +restrictKeys t1@(Tip k1 _) t2 + | k1 `Word64Set.member` t2 = t1 + | otherwise = Nil +restrictKeys Nil _ = Nil + + +-- | \(O(\min(n,W))\). Restrict to the sub-map with all keys matching +-- a key prefix. +lookupPrefix :: Word64SetPrefix -> Word64Map a -> Word64Map a +lookupPrefix !kp t@(Bin p m l r) + | m .&. Word64Set.suffixBitMask /= 0 = + if p .&. Word64Set.prefixBitMask == kp then t else Nil + | nomatch kp p m = Nil + | zero kp m = lookupPrefix kp l + | otherwise = lookupPrefix kp r +lookupPrefix kp t@(Tip kx _) + | (kx .&. Word64Set.prefixBitMask) == kp = t + | otherwise = Nil +lookupPrefix _ Nil = Nil + + +restrictBM :: Word64SetBitMap -> Word64Map a -> Word64Map a +restrictBM 0 _ = Nil +restrictBM bm (Bin p m l r) = + let leftBits = bitmapOf (p .|. m) - 1 + bmL = bm .&. leftBits + bmR = bm `xor` bmL -- = (bm .&. complement leftBits) + in bin p m (restrictBM bmL l) (restrictBM bmR r) +restrictBM bm t@(Tip k _) + -- TODO(wrengr): need we manually inline 'Word64Set.Member' here? + | k `Word64Set.member` Word64Set.Tip (k .&. Word64Set.prefixBitMask) bm = t + | otherwise = Nil +restrictBM _ Nil = Nil + + +-- | \(O(n+m)\). The intersection with a combining function. +-- +-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" + +intersectionWith :: (a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c +intersectionWith f m1 m2 + = intersectionWithKey (\_ x y -> f x y) m1 m2 + +-- | \(O(n+m)\). The intersection with a combining function. +-- +-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar +-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" + +intersectionWithKey :: (Key -> a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c +intersectionWithKey f m1 m2 + = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2 + +{-------------------------------------------------------------------- + MergeWithKey +--------------------------------------------------------------------} + +-- | \(O(n+m)\). A high-performance universal combining function. Using +-- 'mergeWithKey', all combining functions can be defined without any loss of +-- efficiency (with exception of 'union', 'difference' and 'intersection', +-- where sharing of some nodes is lost with 'mergeWithKey'). +-- +-- Please make sure you know what is going on when using 'mergeWithKey', +-- otherwise you can be surprised by unexpected code growth or even +-- corruption of the data structure. +-- +-- When 'mergeWithKey' is given three arguments, it is inlined to the call +-- site. You should therefore use 'mergeWithKey' only to define your custom +-- combining functions. For example, you could define 'unionWithKey', +-- 'differenceWithKey' and 'intersectionWithKey' as +-- +-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 +-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 +-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 +-- +-- When calling @'mergeWithKey' combine only1 only2@, a function combining two +-- 'Word64Map's is created, such that +-- +-- * if a key is present in both maps, it is passed with both corresponding +-- values to the @combine@ function. Depending on the result, the key is either +-- present in the result with specified value, or is left out; +-- +-- * a nonempty subtree present only in the first map is passed to @only1@ and +-- the output is added to the result; +-- +-- * a nonempty subtree present only in the second map is passed to @only2@ and +-- the output is added to the result. +-- +-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. +-- The values can be modified arbitrarily. Most common variants of @only1@ and +-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or +-- @'filterWithKey' f@ could be used for any @f@. + +mergeWithKey :: (Key -> a -> b -> Maybe c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c) + -> Word64Map a -> Word64Map b -> Word64Map c +mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2 + where -- We use the lambda form to avoid non-exhaustive pattern matches warning. + combine = \(Tip k1 x1) (Tip _k2 x2) -> + case f k1 x1 x2 of + Nothing -> Nil + Just x -> Tip k1 x + {-# INLINE combine #-} +{-# INLINE mergeWithKey #-} + +-- Slightly more general version of mergeWithKey. It differs in the following: +-- +-- * the combining function operates on maps instead of keys and values. The +-- reason is to enable sharing in union, difference and intersection. +-- +-- * mergeWithKey' is given an equivalent of bin. The reason is that in union*, +-- Bin constructor can be used, because we know both subtrees are nonempty. + +mergeWithKey' :: (Prefix -> Mask -> Word64Map c -> Word64Map c -> Word64Map c) + -> (Word64Map a -> Word64Map b -> Word64Map c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c) + -> Word64Map a -> Word64Map b -> Word64Map c +mergeWithKey' bin' f g1 g2 = go + where + go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = merge1 + | shorter m2 m1 = merge2 + | p1 == p2 = bin' p1 m1 (go l1 l2) (go r1 r2) + | otherwise = maybe_link p1 (g1 t1) p2 (g2 t2) + where + merge1 | nomatch p2 p1 m1 = maybe_link p1 (g1 t1) p2 (g2 t2) + | zero p2 m1 = bin' p1 m1 (go l1 t2) (g1 r1) + | otherwise = bin' p1 m1 (g1 l1) (go r1 t2) + merge2 | nomatch p1 p2 m2 = maybe_link p1 (g1 t1) p2 (g2 t2) + | zero p1 m2 = bin' p2 m2 (go t1 l2) (g2 r2) + | otherwise = bin' p2 m2 (g2 l2) (go t1 r2) + + go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1' + where + merge0 t2 k2 t1@(Bin p1 m1 l1 r1) + | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2) + | zero k2 m1 = bin' p1 m1 (merge0 t2 k2 l1) (g1 r1) + | otherwise = bin' p1 m1 (g1 l1) (merge0 t2 k2 r1) + merge0 t2 k2 t1@(Tip k1 _) + | k1 == k2 = f t1 t2 + | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2) + merge0 t2 _ Nil = g2 t2 + + go t1@(Bin _ _ _ _) Nil = g1 t1 + + go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2' + where + merge0 t1 k1 t2@(Bin p2 m2 l2 r2) + | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2) + | zero k1 m2 = bin' p2 m2 (merge0 t1 k1 l2) (g2 r2) + | otherwise = bin' p2 m2 (g2 l2) (merge0 t1 k1 r2) + merge0 t1 k1 t2@(Tip k2 _) + | k1 == k2 = f t1 t2 + | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2) + merge0 t1 _ Nil = g1 t1 + + go Nil t2 = g2 t2 + + maybe_link _ Nil _ t2 = t2 + maybe_link _ t1 _ Nil = t1 + maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2 + {-# INLINE maybe_link #-} +{-# INLINE mergeWithKey' #-} + + +{-------------------------------------------------------------------- + mergeA +--------------------------------------------------------------------} + +-- | A tactic for dealing with keys present in one map but not the +-- other in 'merge' or 'mergeA'. +-- +-- A tactic of type @WhenMissing f k x z@ is an abstract representation +-- of a function of type @Key -> x -> f (Maybe z)@. +-- +-- @since 0.5.9 + +data WhenMissing f x y = WhenMissing + { missingSubtree :: Word64Map x -> f (Word64Map y) + , missingKey :: Key -> x -> f (Maybe y)} + +-- | @since 0.5.9 +instance (Applicative f, Monad f) => Functor (WhenMissing f x) where + fmap = mapWhenMissing + {-# INLINE fmap #-} + + +-- | @since 0.5.9 +instance (Applicative f, Monad f) => Category.Category (WhenMissing f) + where + id = preserveMissing + f . g = + traverseMaybeMissing $ \ k x -> do + y <- missingKey g k x + case y of + Nothing -> pure Nothing + Just q -> missingKey f k q + {-# INLINE id #-} + {-# INLINE (.) #-} + + +-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@. +-- +-- @since 0.5.9 +instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where + pure x = mapMissing (\ _ _ -> x) + f <*> g = + traverseMaybeMissing $ \k x -> do + res1 <- missingKey f k x + case res1 of + Nothing -> pure Nothing + Just r -> (pure $!) . fmap r =<< missingKey g k x + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + + +-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@. +-- +-- @since 0.5.9 +instance (Applicative f, Monad f) => Monad (WhenMissing f x) where + m >>= f = + traverseMaybeMissing $ \k x -> do + res1 <- missingKey m k x + case res1 of + Nothing -> pure Nothing + Just r -> missingKey (f r) k x + {-# INLINE (>>=) #-} + + +-- | Map covariantly over a @'WhenMissing' f x@. +-- +-- @since 0.5.9 +mapWhenMissing + :: (Applicative f, Monad f) + => (a -> b) + -> WhenMissing f x a + -> WhenMissing f x b +mapWhenMissing f t = WhenMissing + { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m' + , missingKey = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) } +{-# INLINE mapWhenMissing #-} + + +-- | Map covariantly over a @'WhenMissing' f x@, using only a +-- 'Functor f' constraint. +mapGentlyWhenMissing + :: Functor f + => (a -> b) + -> WhenMissing f x a + -> WhenMissing f x b +mapGentlyWhenMissing f t = WhenMissing + { missingSubtree = \m -> fmap f <$> missingSubtree t m + , missingKey = \k x -> fmap f <$> missingKey t k x } +{-# INLINE mapGentlyWhenMissing #-} + + +-- | Map covariantly over a @'WhenMatched' f k x@, using only a +-- 'Functor f' constraint. +mapGentlyWhenMatched + :: Functor f + => (a -> b) + -> WhenMatched f x y a + -> WhenMatched f x y b +mapGentlyWhenMatched f t = + zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y +{-# INLINE mapGentlyWhenMatched #-} + + +-- | Map contravariantly over a @'WhenMissing' f _ x@. +-- +-- @since 0.5.9 +lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x +lmapWhenMissing f t = WhenMissing + { missingSubtree = \m -> missingSubtree t (fmap f m) + , missingKey = \k x -> missingKey t k (f x) } +{-# INLINE lmapWhenMissing #-} + + +-- | Map contravariantly over a @'WhenMatched' f _ y z@. +-- +-- @since 0.5.9 +contramapFirstWhenMatched + :: (b -> a) + -> WhenMatched f a y z + -> WhenMatched f b y z +contramapFirstWhenMatched f t = + WhenMatched $ \k x y -> runWhenMatched t k (f x) y +{-# INLINE contramapFirstWhenMatched #-} + + +-- | Map contravariantly over a @'WhenMatched' f x _ z@. +-- +-- @since 0.5.9 +contramapSecondWhenMatched + :: (b -> a) + -> WhenMatched f x a z + -> WhenMatched f x b z +contramapSecondWhenMatched f t = + WhenMatched $ \k x y -> runWhenMatched t k x (f y) +{-# INLINE contramapSecondWhenMatched #-} + + +-- | A tactic for dealing with keys present in one map but not the +-- other in 'merge'. +-- +-- A tactic of type @SimpleWhenMissing x z@ is an abstract +-- representation of a function of type @Key -> x -> Maybe z@. +-- +-- @since 0.5.9 +type SimpleWhenMissing = WhenMissing Identity + + +-- | A tactic for dealing with keys present in both maps in 'merge' +-- or 'mergeA'. +-- +-- A tactic of type @WhenMatched f x y z@ is an abstract representation +-- of a function of type @Key -> x -> y -> f (Maybe z)@. +-- +-- @since 0.5.9 +newtype WhenMatched f x y z = WhenMatched + { matchedKey :: Key -> x -> y -> f (Maybe z) } + + +-- | Along with zipWithMaybeAMatched, witnesses the isomorphism +-- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@. +-- +-- @since 0.5.9 +runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z) +runWhenMatched = matchedKey +{-# INLINE runWhenMatched #-} + + +-- | Along with traverseMaybeMissing, witnesses the isomorphism +-- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@. +-- +-- @since 0.5.9 +runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y) +runWhenMissing = missingKey +{-# INLINE runWhenMissing #-} + + +-- | @since 0.5.9 +instance Functor f => Functor (WhenMatched f x y) where + fmap = mapWhenMatched + {-# INLINE fmap #-} + + +-- | @since 0.5.9 +instance (Monad f, Applicative f) => Category.Category (WhenMatched f x) + where + id = zipWithMatched (\_ _ y -> y) + f . g = + zipWithMaybeAMatched $ \k x y -> do + res <- runWhenMatched g k x y + case res of + Nothing -> pure Nothing + Just r -> runWhenMatched f k x r + {-# INLINE id #-} + {-# INLINE (.) #-} + + +-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@ +-- +-- @since 0.5.9 +instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where + pure x = zipWithMatched (\_ _ _ -> x) + fs <*> xs = + zipWithMaybeAMatched $ \k x y -> do + res <- runWhenMatched fs k x y + case res of + Nothing -> pure Nothing + Just r -> (pure $!) . fmap r =<< runWhenMatched xs k x y + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + + +-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@ +-- +-- @since 0.5.9 +instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where + m >>= f = + zipWithMaybeAMatched $ \k x y -> do + res <- runWhenMatched m k x y + case res of + Nothing -> pure Nothing + Just r -> runWhenMatched (f r) k x y + {-# INLINE (>>=) #-} + + +-- | Map covariantly over a @'WhenMatched' f x y@. +-- +-- @since 0.5.9 +mapWhenMatched + :: Functor f + => (a -> b) + -> WhenMatched f x y a + -> WhenMatched f x y b +mapWhenMatched f (WhenMatched g) = + WhenMatched $ \k x y -> fmap (fmap f) (g k x y) +{-# INLINE mapWhenMatched #-} + + +-- | A tactic for dealing with keys present in both maps in 'merge'. +-- +-- A tactic of type @SimpleWhenMatched x y z@ is an abstract +-- representation of a function of type @Key -> x -> y -> Maybe z@. +-- +-- @since 0.5.9 +type SimpleWhenMatched = WhenMatched Identity + + +-- | When a key is found in both maps, apply a function to the key +-- and values and use the result in the merged map. +-- +-- > zipWithMatched +-- > :: (Key -> x -> y -> z) +-- > -> SimpleWhenMatched x y z +-- +-- @since 0.5.9 +zipWithMatched + :: Applicative f + => (Key -> x -> y -> z) + -> WhenMatched f x y z +zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y +{-# INLINE zipWithMatched #-} + + +-- | When a key is found in both maps, apply a function to the key +-- and values to produce an action and use its result in the merged +-- map. +-- +-- @since 0.5.9 +zipWithAMatched + :: Applicative f + => (Key -> x -> y -> f z) + -> WhenMatched f x y z +zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y +{-# INLINE zipWithAMatched #-} + + +-- | When a key is found in both maps, apply a function to the key +-- and values and maybe use the result in the merged map. +-- +-- > zipWithMaybeMatched +-- > :: (Key -> x -> y -> Maybe z) +-- > -> SimpleWhenMatched x y z +-- +-- @since 0.5.9 +zipWithMaybeMatched + :: Applicative f + => (Key -> x -> y -> Maybe z) + -> WhenMatched f x y z +zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y +{-# INLINE zipWithMaybeMatched #-} + + +-- | When a key is found in both maps, apply a function to the key +-- and values, perform the resulting action, and maybe use the +-- result in the merged map. +-- +-- This is the fundamental 'WhenMatched' tactic. +-- +-- @since 0.5.9 +zipWithMaybeAMatched + :: (Key -> x -> y -> f (Maybe z)) + -> WhenMatched f x y z +zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y +{-# INLINE zipWithMaybeAMatched #-} + + +-- | Drop all the entries whose keys are missing from the other +-- map. +-- +-- > dropMissing :: SimpleWhenMissing x y +-- +-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing) +-- +-- but @dropMissing@ is much faster. +-- +-- @since 0.5.9 +dropMissing :: Applicative f => WhenMissing f x y +dropMissing = WhenMissing + { missingSubtree = const (pure Nil) + , missingKey = \_ _ -> pure Nothing } +{-# INLINE dropMissing #-} + + +-- | Preserve, unchanged, the entries whose keys are missing from +-- the other map. +-- +-- > preserveMissing :: SimpleWhenMissing x x +-- +-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x) +-- +-- but @preserveMissing@ is much faster. +-- +-- @since 0.5.9 +preserveMissing :: Applicative f => WhenMissing f x x +preserveMissing = WhenMissing + { missingSubtree = pure + , missingKey = \_ v -> pure (Just v) } +{-# INLINE preserveMissing #-} + + +-- | Map over the entries whose keys are missing from the other map. +-- +-- > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y +-- +-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) +-- +-- but @mapMissing@ is somewhat faster. +-- +-- @since 0.5.9 +mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y +mapMissing f = WhenMissing + { missingSubtree = \m -> pure $! mapWithKey f m + , missingKey = \k x -> pure $ Just (f k x) } +{-# INLINE mapMissing #-} + + +-- | Map over the entries whose keys are missing from the other +-- map, optionally removing some. This is the most powerful +-- 'SimpleWhenMissing' tactic, but others are usually more efficient. +-- +-- > mapMaybeMissing :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y +-- +-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x)) +-- +-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' +-- operations. +-- +-- @since 0.5.9 +mapMaybeMissing + :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y +mapMaybeMissing f = WhenMissing + { missingSubtree = \m -> pure $! mapMaybeWithKey f m + , missingKey = \k x -> pure $! f k x } +{-# INLINE mapMaybeMissing #-} + + +-- | Filter the entries whose keys are missing from the other map. +-- +-- > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x +-- +-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x +-- +-- but this should be a little faster. +-- +-- @since 0.5.9 +filterMissing + :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x +filterMissing f = WhenMissing + { missingSubtree = \m -> pure $! filterWithKey f m + , missingKey = \k x -> pure $! if f k x then Just x else Nothing } +{-# INLINE filterMissing #-} + + +-- | Filter the entries whose keys are missing from the other map +-- using some 'Applicative' action. +-- +-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $ +-- > \k x -> (\b -> guard b *> Just x) <$> f k x +-- +-- but this should be a little faster. +-- +-- @since 0.5.9 +filterAMissing + :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x +filterAMissing f = WhenMissing + { missingSubtree = \m -> filterWithKeyA f m + , missingKey = \k x -> bool Nothing (Just x) <$> f k x } +{-# INLINE filterAMissing #-} + + +-- | \(O(n)\). Filter keys and values using an 'Applicative' predicate. +filterWithKeyA + :: Applicative f => (Key -> a -> f Bool) -> Word64Map a -> f (Word64Map a) +filterWithKeyA _ Nil = pure Nil +filterWithKeyA f t@(Tip k x) = (\b -> if b then t else Nil) <$> f k x +filterWithKeyA f (Bin p m l r) + | m < 0 = liftA2 (flip (bin p m)) (filterWithKeyA f r) (filterWithKeyA f l) + | otherwise = liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r) + +-- | This wasn't in Data.Bool until 4.7.0, so we define it here +bool :: a -> a -> Bool -> a +bool f _ False = f +bool _ t True = t + + +-- | Traverse over the entries whose keys are missing from the other +-- map. +-- +-- @since 0.5.9 +traverseMissing + :: Applicative f => (Key -> x -> f y) -> WhenMissing f x y +traverseMissing f = WhenMissing + { missingSubtree = traverseWithKey f + , missingKey = \k x -> Just <$> f k x } +{-# INLINE traverseMissing #-} + + +-- | Traverse over the entries whose keys are missing from the other +-- map, optionally producing values to put in the result. This is +-- the most powerful 'WhenMissing' tactic, but others are usually +-- more efficient. +-- +-- @since 0.5.9 +traverseMaybeMissing + :: Applicative f => (Key -> x -> f (Maybe y)) -> WhenMissing f x y +traverseMaybeMissing f = WhenMissing + { missingSubtree = traverseMaybeWithKey f + , missingKey = f } +{-# INLINE traverseMaybeMissing #-} + + +-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results. +-- +-- @since 0.6.4 +traverseMaybeWithKey + :: Applicative f => (Key -> a -> f (Maybe b)) -> Word64Map a -> f (Word64Map b) +traverseMaybeWithKey f = go + where + go Nil = pure Nil + go (Tip k x) = maybe Nil (Tip k) <$> f k x + go (Bin p m l r) + | m < 0 = liftA2 (flip (bin p m)) (go r) (go l) + | otherwise = liftA2 (bin p m) (go l) (go r) + + +-- | Merge two maps. +-- +-- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic +-- and two maps. It uses the tactics to merge the maps. Its behavior +-- is best understood via its fundamental tactics, 'mapMaybeMissing' +-- and 'zipWithMaybeMatched'. +-- +-- Consider +-- +-- @ +-- merge (mapMaybeMissing g1) +-- (mapMaybeMissing g2) +-- (zipWithMaybeMatched f) +-- m1 m2 +-- @ +-- +-- Take, for example, +-- +-- @ +-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')] +-- m2 = [(1, "one"), (2, "two"), (4, "three")] +-- @ +-- +-- 'merge' will first \"align\" these maps by key: +-- +-- @ +-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')] +-- m2 = [(1, "one"), (2, "two"), (4, "three")] +-- @ +-- +-- It will then pass the individual entries and pairs of entries +-- to @g1@, @g2@, or @f@ as appropriate: +-- +-- @ +-- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"] +-- @ +-- +-- This produces a 'Maybe' for each key: +-- +-- @ +-- keys = 0 1 2 3 4 +-- results = [Nothing, Just True, Just False, Nothing, Just True] +-- @ +-- +-- Finally, the @Just@ results are collected into a map: +-- +-- @ +-- return value = [(1, True), (2, False), (4, True)] +-- @ +-- +-- The other tactics below are optimizations or simplifications of +-- 'mapMaybeMissing' for special cases. Most importantly, +-- +-- * 'dropMissing' drops all the keys. +-- * 'preserveMissing' leaves all the entries alone. +-- +-- When 'merge' is given three arguments, it is inlined at the call +-- site. To prevent excessive inlining, you should typically use +-- 'merge' to define your custom combining functions. +-- +-- +-- Examples: +-- +-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f) +-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f) +-- prop> differenceWith f = merge diffPreserve diffDrop f +-- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing) +-- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g) +-- +-- @since 0.5.9 +merge + :: SimpleWhenMissing a c -- ^ What to do with keys in @m1@ but not @m2@ + -> SimpleWhenMissing b c -- ^ What to do with keys in @m2@ but not @m1@ + -> SimpleWhenMatched a b c -- ^ What to do with keys in both @m1@ and @m2@ + -> Word64Map a -- ^ Map @m1@ + -> Word64Map b -- ^ Map @m2@ + -> Word64Map c +merge g1 g2 f m1 m2 = + runIdentity $ mergeA g1 g2 f m1 m2 +{-# INLINE merge #-} + + +-- | An applicative version of 'merge'. +-- +-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched' +-- tactic and two maps. It uses the tactics to merge the maps. +-- Its behavior is best understood via its fundamental tactics, +-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'. +-- +-- Consider +-- +-- @ +-- mergeA (traverseMaybeMissing g1) +-- (traverseMaybeMissing g2) +-- (zipWithMaybeAMatched f) +-- m1 m2 +-- @ +-- +-- Take, for example, +-- +-- @ +-- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')] +-- m2 = [(1, "one"), (2, "two"), (4, "three")] +-- @ +-- +-- 'mergeA' will first \"align\" these maps by key: +-- +-- @ +-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')] +-- m2 = [(1, "one"), (2, "two"), (4, "three")] +-- @ +-- +-- It will then pass the individual entries and pairs of entries +-- to @g1@, @g2@, or @f@ as appropriate: +-- +-- @ +-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"] +-- @ +-- +-- Next, it will perform the actions in the @actions@ list in order from +-- left to right. +-- +-- @ +-- keys = 0 1 2 3 4 +-- results = [Nothing, Just True, Just False, Nothing, Just True] +-- @ +-- +-- Finally, the @Just@ results are collected into a map: +-- +-- @ +-- return value = [(1, True), (2, False), (4, True)] +-- @ +-- +-- The other tactics below are optimizations or simplifications of +-- 'traverseMaybeMissing' for special cases. Most importantly, +-- +-- * 'dropMissing' drops all the keys. +-- * 'preserveMissing' leaves all the entries alone. +-- * 'mapMaybeMissing' does not use the 'Applicative' context. +-- +-- When 'mergeA' is given three arguments, it is inlined at the call +-- site. To prevent excessive inlining, you should generally only use +-- 'mergeA' to define custom combining functions. +-- +-- @since 0.5.9 +mergeA + :: (Applicative f) + => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@ + -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@ + -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@ + -> Word64Map a -- ^ Map @m1@ + -> Word64Map b -- ^ Map @m2@ + -> f (Word64Map c) +mergeA + WhenMissing{missingSubtree = g1t, missingKey = g1k} + WhenMissing{missingSubtree = g2t, missingKey = g2k} + WhenMatched{matchedKey = f} + = go + where + go t1 Nil = g1t t1 + go Nil t2 = g2t t2 + + -- This case is already covered below. + -- go (Tip k1 x1) (Tip k2 x2) = mergeTips k1 x1 k2 x2 + + go (Tip k1 x1) t2' = merge2 t2' + where + merge2 t2@(Bin p2 m2 l2 r2) + | nomatch k1 p2 m2 = linkA k1 (subsingletonBy g1k k1 x1) p2 (g2t t2) + | zero k1 m2 = binA p2 m2 (merge2 l2) (g2t r2) + | otherwise = binA p2 m2 (g2t l2) (merge2 r2) + merge2 (Tip k2 x2) = mergeTips k1 x1 k2 x2 + merge2 Nil = subsingletonBy g1k k1 x1 + + go t1' (Tip k2 x2) = merge1 t1' + where + merge1 t1@(Bin p1 m1 l1 r1) + | nomatch k2 p1 m1 = linkA p1 (g1t t1) k2 (subsingletonBy g2k k2 x2) + | zero k2 m1 = binA p1 m1 (merge1 l1) (g1t r1) + | otherwise = binA p1 m1 (g1t l1) (merge1 r1) + merge1 (Tip k1 x1) = mergeTips k1 x1 k2 x2 + merge1 Nil = subsingletonBy g2k k2 x2 + + go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = merge1 + | shorter m2 m1 = merge2 + | p1 == p2 = binA p1 m1 (go l1 l2) (go r1 r2) + | otherwise = linkA p1 (g1t t1) p2 (g2t t2) + where + merge1 | nomatch p2 p1 m1 = linkA p1 (g1t t1) p2 (g2t t2) + | zero p2 m1 = binA p1 m1 (go l1 t2) (g1t r1) + | otherwise = binA p1 m1 (g1t l1) (go r1 t2) + merge2 | nomatch p1 p2 m2 = linkA p1 (g1t t1) p2 (g2t t2) + | zero p1 m2 = binA p2 m2 (go t1 l2) (g2t r2) + | otherwise = binA p2 m2 (g2t l2) (go t1 r2) + + subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x + {-# INLINE subsingletonBy #-} + + mergeTips k1 x1 k2 x2 + | k1 == k2 = maybe Nil (Tip k1) <$> f k1 x1 x2 + | k1 < k2 = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2) + {- + = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2 + -} + | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1) + {-# INLINE mergeTips #-} + + subdoubleton _ _ Nothing Nothing = Nil + subdoubleton _ k2 Nothing (Just y2) = Tip k2 y2 + subdoubleton k1 _ (Just y1) Nothing = Tip k1 y1 + subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2) + {-# INLINE subdoubleton #-} + + -- A variant of 'link_' which makes sure to execute side-effects + -- in the right order. + linkA + :: Applicative f + => Prefix -> f (Word64Map a) + -> Prefix -> f (Word64Map a) + -> f (Word64Map a) + linkA p1 t1 p2 t2 + | zero p1 m = binA p m t1 t2 + | otherwise = binA p m t2 t1 + where + m = branchMask p1 p2 + p = mask p1 m + {-# INLINE linkA #-} + + -- A variant of 'bin' that ensures that effects for negative keys are executed + -- first. + binA + :: Applicative f + => Prefix + -> Mask + -> f (Word64Map a) + -> f (Word64Map a) + -> f (Word64Map a) + binA p m a b + | m < 0 = liftA2 (flip (bin p m)) b a + | otherwise = liftA2 (bin p m) a b + {-# INLINE binA #-} +{-# INLINE mergeA #-} + + +{-------------------------------------------------------------------- + Min\/Max +--------------------------------------------------------------------} + +-- | \(O(\min(n,W))\). Update the value at the minimal key. +-- +-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] +-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" + +updateMinWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a +updateMinWithKey f t = + case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r) + _ -> go f t + where + go f' (Bin p m l r) = binCheckLeft p m (go f' l) r + go f' (Tip k y) = case f' k y of + Just y' -> Tip k y' + Nothing -> Nil + go _ Nil = error "updateMinWithKey Nil" + +-- | \(O(\min(n,W))\). Update the value at the maximal key. +-- +-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] +-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" + +updateMaxWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a +updateMaxWithKey f t = + case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r + _ -> go f t + where + go f' (Bin p m l r) = binCheckRight p m l (go f' r) + go f' (Tip k y) = case f' k y of + Just y' -> Tip k y' + Nothing -> Nil + go _ Nil = error "updateMaxWithKey Nil" + + +data View a = View {-# UNPACK #-} !Key a !(Word64Map a) + +-- | \(O(\min(n,W))\). Retrieves the maximal (key,value) pair of the map, and +-- the map stripped of that element, or 'Nothing' if passed an empty map. +-- +-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b") +-- > maxViewWithKey empty == Nothing + +maxViewWithKey :: Word64Map a -> Maybe ((Key, a), Word64Map a) +maxViewWithKey t = case t of + Nil -> Nothing + _ -> Just $ case maxViewWithKeySure t of + View k v t' -> ((k, v), t') +{-# INLINE maxViewWithKey #-} + +maxViewWithKeySure :: Word64Map a -> View a +maxViewWithKeySure t = + case t of + Nil -> error "maxViewWithKeySure Nil" + Bin p m l r | m < 0 -> + case go l of View k a l' -> View k a (binCheckLeft p m l' r) + _ -> go t + where + go (Bin p m l r) = + case go r of View k a r' -> View k a (binCheckRight p m l r') + go (Tip k y) = View k y Nil + go Nil = error "maxViewWithKey_go Nil" +-- See note on NOINLINE at minViewWithKeySure +{-# NOINLINE maxViewWithKeySure #-} + +-- | \(O(\min(n,W))\). Retrieves the minimal (key,value) pair of the map, and +-- the map stripped of that element, or 'Nothing' if passed an empty map. +-- +-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a") +-- > minViewWithKey empty == Nothing + +minViewWithKey :: Word64Map a -> Maybe ((Key, a), Word64Map a) +minViewWithKey t = + case t of + Nil -> Nothing + _ -> Just $ case minViewWithKeySure t of + View k v t' -> ((k, v), t') +-- We inline this to give GHC the best possible chance of +-- getting rid of the Maybe, pair, and Int constructors, as +-- well as a thunk under the Just. That is, we really want to +-- be certain this inlines! +{-# INLINE minViewWithKey #-} + +minViewWithKeySure :: Word64Map a -> View a +minViewWithKeySure t = + case t of + Nil -> error "minViewWithKeySure Nil" + Bin p m l r | m < 0 -> + case go r of + View k a r' -> View k a (binCheckRight p m l r') + _ -> go t + where + go (Bin p m l r) = + case go l of View k a l' -> View k a (binCheckLeft p m l' r) + go (Tip k y) = View k y Nil + go Nil = error "minViewWithKey_go Nil" +-- There's never anything significant to be gained by inlining +-- this. Sufficiently recent GHC versions will inline the wrapper +-- anyway, which should be good enough. +{-# NOINLINE minViewWithKeySure #-} + +-- | \(O(\min(n,W))\). Update the value at the maximal key. +-- +-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] +-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" + +updateMax :: (a -> Maybe a) -> Word64Map a -> Word64Map a +updateMax f = updateMaxWithKey (const f) + +-- | \(O(\min(n,W))\). Update the value at the minimal key. +-- +-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] +-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" + +updateMin :: (a -> Maybe a) -> Word64Map a -> Word64Map a +updateMin f = updateMinWithKey (const f) + +-- | \(O(\min(n,W))\). Retrieves the maximal key of the map, and the map +-- stripped of that element, or 'Nothing' if passed an empty map. +maxView :: Word64Map a -> Maybe (a, Word64Map a) +maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t) + +-- | \(O(\min(n,W))\). Retrieves the minimal key of the map, and the map +-- stripped of that element, or 'Nothing' if passed an empty map. +minView :: Word64Map a -> Maybe (a, Word64Map a) +minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t) + +-- | \(O(\min(n,W))\). Delete and find the maximal element. +-- This function throws an error if the map is empty. Use 'maxViewWithKey' +-- if the map may be empty. +deleteFindMax :: Word64Map a -> ((Key, a), Word64Map a) +deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey + +-- | \(O(\min(n,W))\). Delete and find the minimal element. +-- This function throws an error if the map is empty. Use 'minViewWithKey' +-- if the map may be empty. +deleteFindMin :: Word64Map a -> ((Key, a), Word64Map a) +deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey + +-- | \(O(\min(n,W))\). The minimal key of the map. Returns 'Nothing' if the map is empty. +lookupMin :: Word64Map a -> Maybe (Key, a) +lookupMin Nil = Nothing +lookupMin (Tip k v) = Just (k,v) +lookupMin (Bin _ m l r) + | m < 0 = go r + | otherwise = go l + where go (Tip k v) = Just (k,v) + go (Bin _ _ l' _) = go l' + go Nil = Nothing + +-- | \(O(\min(n,W))\). The minimal key of the map. Calls 'error' if the map is empty. +-- Use 'minViewWithKey' if the map may be empty. +findMin :: Word64Map a -> (Key, a) +findMin t + | Just r <- lookupMin t = r + | otherwise = error "findMin: empty map has no minimal element" + +-- | \(O(\min(n,W))\). The maximal key of the map. Returns 'Nothing' if the map is empty. +lookupMax :: Word64Map a -> Maybe (Key, a) +lookupMax Nil = Nothing +lookupMax (Tip k v) = Just (k,v) +lookupMax (Bin _ m l r) + | m < 0 = go l + | otherwise = go r + where go (Tip k v) = Just (k,v) + go (Bin _ _ _ r') = go r' + go Nil = Nothing + +-- | \(O(\min(n,W))\). The maximal key of the map. Calls 'error' if the map is empty. +-- Use 'maxViewWithKey' if the map may be empty. +findMax :: Word64Map a -> (Key, a) +findMax t + | Just r <- lookupMax t = r + | otherwise = error "findMax: empty map has no maximal element" + +-- | \(O(\min(n,W))\). Delete the minimal key. Returns an empty map if the map is empty. +-- +-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' – +-- versions prior to 0.5 threw an error if the 'Word64Map' was already empty. +deleteMin :: Word64Map a -> Word64Map a +deleteMin = maybe Nil snd . minView + +-- | \(O(\min(n,W))\). Delete the maximal key. Returns an empty map if the map is empty. +-- +-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' – +-- versions prior to 0.5 threw an error if the 'Word64Map' was already empty. +deleteMax :: Word64Map a -> Word64Map a +deleteMax = maybe Nil snd . maxView + + +{-------------------------------------------------------------------- + Submap +--------------------------------------------------------------------} +-- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal). +-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). +isProperSubmapOf :: Eq a => Word64Map a -> Word64Map a -> Bool +isProperSubmapOf m1 m2 + = isProperSubmapOfBy (==) m1 m2 + +{- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal). + The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when + @keys m1@ and @keys m2@ are not equal, + all keys in @m1@ are in @m2@, and when @f@ returns 'True' when + applied to their respective values. For example, the following + expressions are all 'True': + + > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + + But the following are all 'False': + + > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) + > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) + > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) +-} +isProperSubmapOfBy :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Bool +isProperSubmapOfBy predicate t1 t2 + = case submapCmp predicate t1 t2 of + LT -> True + _ -> False + +submapCmp :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Ordering +submapCmp predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + | shorter m1 m2 = GT + | shorter m2 m1 = submapCmpLt + | p1 == p2 = submapCmpEq + | otherwise = GT -- disjoint + where + submapCmpLt | nomatch p1 p2 m2 = GT + | zero p1 m2 = submapCmp predicate t1 l2 + | otherwise = submapCmp predicate t1 r2 + submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of + (GT,_ ) -> GT + (_ ,GT) -> GT + (EQ,EQ) -> EQ + _ -> LT + +submapCmp _ (Bin _ _ _ _) _ = GT +submapCmp predicate (Tip kx x) (Tip ky y) + | (kx == ky) && predicate x y = EQ + | otherwise = GT -- disjoint +submapCmp predicate (Tip k x) t + = case lookup k t of + Just y | predicate x y -> LT + _ -> GT -- disjoint +submapCmp _ Nil Nil = EQ +submapCmp _ Nil _ = LT + +-- | \(O(n+m)\). Is this a submap? +-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). +isSubmapOf :: Eq a => Word64Map a -> Word64Map a -> Bool +isSubmapOf m1 m2 + = isSubmapOfBy (==) m1 m2 + +{- | \(O(n+m)\). + The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if + all keys in @m1@ are in @m2@, and when @f@ returns 'True' when + applied to their respective values. For example, the following + expressions are all 'True': + + > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) + + But the following are all 'False': + + > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)]) + > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) +-} +isSubmapOfBy :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Bool +isSubmapOfBy predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + | shorter m1 m2 = False + | shorter m2 m1 = match p1 p2 m2 && + if zero p1 m2 + then isSubmapOfBy predicate t1 l2 + else isSubmapOfBy predicate t1 r2 + | otherwise = (p1==p2) && isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2 +isSubmapOfBy _ (Bin _ _ _ _) _ = False +isSubmapOfBy predicate (Tip k x) t = case lookup k t of + Just y -> predicate x y + Nothing -> False +isSubmapOfBy _ Nil _ = True + +{-------------------------------------------------------------------- + Mapping +--------------------------------------------------------------------} +-- | \(O(n)\). Map a function over all values in the map. +-- +-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] + +map :: (a -> b) -> Word64Map a -> Word64Map b +map f = go + where + go (Bin p m l r) = Bin p m (go l) (go r) + go (Tip k x) = Tip k (f x) + go Nil = Nil + +{-# NOINLINE [1] map #-} +{-# RULES +"map/map" forall f g xs . map f (map g xs) = map (f . g) xs +"map/coerce" map coerce = coerce + #-} + +-- | \(O(n)\). Map a function over all values in the map. +-- +-- > let f key x = (show key) ++ ":" ++ x +-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] + +mapWithKey :: (Key -> a -> b) -> Word64Map a -> Word64Map b +mapWithKey f t + = case t of + Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r) + Tip k x -> Tip k (f k x) + Nil -> Nil + +{-# NOINLINE [1] mapWithKey #-} +{-# RULES +"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) = + mapWithKey (\k a -> f k (g k a)) xs +"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) = + mapWithKey (\k a -> f k (g a)) xs +"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) = + mapWithKey (\k a -> f (g k a)) xs + #-} + +-- | \(O(n)\). +-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ +-- That is, behaves exactly like a regular 'traverse' except that the traversing +-- function also has access to the key associated with a value. +-- +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing +traverseWithKey :: Applicative t => (Key -> a -> t b) -> Word64Map a -> t (Word64Map b) +traverseWithKey f = go + where + go Nil = pure Nil + go (Tip k v) = Tip k <$> f k v + go (Bin p m l r) + | m < 0 = liftA2 (flip (Bin p m)) (go r) (go l) + | otherwise = liftA2 (Bin p m) (go l) (go r) +{-# INLINE traverseWithKey #-} + +-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a b = (a ++ b, b ++ "X") +-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) + +mapAccum :: (a -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c) +mapAccum f = mapAccumWithKey (\a' _ x -> f a' x) + +-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") +-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) + +mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c) +mapAccumWithKey f a t + = mapAccumL f a t + +-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating +-- argument through the map in ascending order of keys. +mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c) +mapAccumL f a t + = case t of + Bin p m l r + | m < 0 -> + let (a1,r') = mapAccumL f a r + (a2,l') = mapAccumL f a1 l + in (a2,Bin p m l' r') + | otherwise -> + let (a1,l') = mapAccumL f a l + (a2,r') = mapAccumL f a1 r + in (a2,Bin p m l' r') + Tip k x -> let (a',x') = f a k x in (a',Tip k x') + Nil -> (a,Nil) + +-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating +-- argument through the map in descending order of keys. +mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c) +mapAccumRWithKey f a t + = case t of + Bin p m l r + | m < 0 -> + let (a1,l') = mapAccumRWithKey f a l + (a2,r') = mapAccumRWithKey f a1 r + in (a2,Bin p m l' r') + | otherwise -> + let (a1,r') = mapAccumRWithKey f a r + (a2,l') = mapAccumRWithKey f a1 l + in (a2,Bin p m l' r') + Tip k x -> let (a',x') = f a k x in (a',Tip k x') + Nil -> (a,Nil) + +-- | \(O(n \min(n,W))\). +-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the value at the greatest of the +-- original keys is retained. +-- +-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] +-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c" +-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c" + +mapKeys :: (Key->Key) -> Word64Map a -> Word64Map a +mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) [] + +-- | \(O(n \min(n,W))\). +-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the associated values will be +-- combined using @c@. +-- +-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" +-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" + +mapKeysWith :: (a -> a -> a) -> (Key->Key) -> Word64Map a -> Word64Map a +mapKeysWith c f + = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] + +-- | \(O(n \min(n,W))\). +-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ +-- is strictly monotonic. +-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. +-- /The precondition is not checked./ +-- Semi-formally, we have: +-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapKeysMonotonic f s == mapKeys f s +-- > where ls = keys s +-- +-- This means that @f@ maps distinct original keys to distinct resulting keys. +-- This function has slightly better performance than 'mapKeys'. +-- +-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] + +mapKeysMonotonic :: (Key->Key) -> Word64Map a -> Word64Map a +mapKeysMonotonic f + = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) [] + +{-------------------------------------------------------------------- + Filter +--------------------------------------------------------------------} +-- | \(O(n)\). Filter all values that satisfy some predicate. +-- +-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty +-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty + +filter :: (a -> Bool) -> Word64Map a -> Word64Map a +filter p m + = filterWithKey (\_ x -> p x) m + +-- | \(O(n)\). Filter all keys\/values that satisfy some predicate. +-- +-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" + +filterWithKey :: (Key -> a -> Bool) -> Word64Map a -> Word64Map a +filterWithKey predicate = go + where + go Nil = Nil + go t@(Tip k x) = if predicate k x then t else Nil + go (Bin p m l r) = bin p m (go l) (go r) + +-- | \(O(n)\). Partition the map according to some predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +-- +-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a") +-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty) +-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")]) + +partition :: (a -> Bool) -> Word64Map a -> (Word64Map a,Word64Map a) +partition p m + = partitionWithKey (\_ x -> p x) m + +-- | \(O(n)\). Partition the map according to some predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +-- +-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b") +-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty) +-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")]) + +partitionWithKey :: (Key -> a -> Bool) -> Word64Map a -> (Word64Map a,Word64Map a) +partitionWithKey predicate0 t0 = toPair $ go predicate0 t0 + where + go predicate t = + case t of + Bin p m l r -> + let (l1 :*: l2) = go predicate l + (r1 :*: r2) = go predicate r + in bin p m l1 r1 :*: bin p m l2 r2 + Tip k x + | predicate k x -> (t :*: Nil) + | otherwise -> (Nil :*: t) + Nil -> (Nil :*: Nil) + +-- | \(O(\min(n,W))\). Take while a predicate on the keys holds. +-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@. +-- See note at 'spanAntitone'. +-- +-- @ +-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList' +-- takeWhileAntitone p = 'filterWithKey' (\\k _ -> p k) +-- @ +-- +-- @since 0.6.7 +takeWhileAntitone :: (Key -> Bool) -> Word64Map a -> Word64Map a +takeWhileAntitone predicate t = + case t of + Bin p m l r + | m < 0 -> + if predicate 0 -- handle negative numbers. + then bin p m (go predicate l) r + else go predicate r + _ -> go predicate t + where + go predicate' (Bin p m l r) + | predicate' $! p+m = bin p m l (go predicate' r) + | otherwise = go predicate' l + go predicate' t'@(Tip ky _) + | predicate' ky = t' + | otherwise = Nil + go _ Nil = Nil + +-- | \(O(\min(n,W))\). Drop while a predicate on the keys holds. +-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@. +-- See note at 'spanAntitone'. +-- +-- @ +-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList' +-- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k)) +-- @ +-- +-- @since 0.6.7 +dropWhileAntitone :: (Key -> Bool) -> Word64Map a -> Word64Map a +dropWhileAntitone predicate t = + case t of + Bin p m l r + | m < 0 -> + if predicate 0 -- handle negative numbers. + then go predicate l + else bin p m l (go predicate r) + _ -> go predicate t + where + go predicate' (Bin p m l r) + | predicate' $! p+m = go predicate' r + | otherwise = bin p m (go predicate' l) r + go predicate' t'@(Tip ky _) + | predicate' ky = Nil + | otherwise = t' + go _ Nil = Nil + +-- | \(O(\min(n,W))\). Divide a map at the point where a predicate on the keys stops holding. +-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@. +-- +-- @ +-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs) +-- spanAntitone p xs = 'partitionWithKey' (\\k _ -> p k) xs +-- @ +-- +-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map +-- at some /unspecified/ point. +-- +-- @since 0.6.7 +spanAntitone :: (Key -> Bool) -> Word64Map a -> (Word64Map a, Word64Map a) +spanAntitone predicate t = + case t of + Bin p m l r + | m < 0 -> + if predicate 0 -- handle negative numbers. + then + case go predicate l of + (lt :*: gt) -> + let !lt' = bin p m lt r + in (lt', gt) + else + case go predicate r of + (lt :*: gt) -> + let !gt' = bin p m l gt + in (lt, gt') + _ -> case go predicate t of + (lt :*: gt) -> (lt, gt) + where + go predicate' (Bin p m l r) + | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt + | otherwise = case go predicate' l of (lt :*: gt) -> lt :*: bin p m gt r + go predicate' t'@(Tip ky _) + | predicate' ky = (t' :*: Nil) + | otherwise = (Nil :*: t') + go _ Nil = (Nil :*: Nil) + +-- | \(O(n)\). Map values and collect the 'Just' results. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" + +mapMaybe :: (a -> Maybe b) -> Word64Map a -> Word64Map b +mapMaybe f = mapMaybeWithKey (\_ x -> f x) + +-- | \(O(n)\). Map keys\/values and collect the 'Just' results. +-- +-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing +-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" + +mapMaybeWithKey :: (Key -> a -> Maybe b) -> Word64Map a -> Word64Map b +mapMaybeWithKey f (Bin p m l r) + = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r) +mapMaybeWithKey f (Tip k x) = case f k x of + Just y -> Tip k y + Nothing -> Nil +mapMaybeWithKey _ Nil = Nil + +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. +-- +-- > let f a = if a < "c" then Left a else Right a +-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) +-- > +-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) + +mapEither :: (a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c) +mapEither f m + = mapEitherWithKey (\_ x -> f x) m + +-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results. +-- +-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) +-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) +-- > +-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) + +mapEitherWithKey :: (Key -> a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c) +mapEitherWithKey f0 t0 = toPair $ go f0 t0 + where + go f (Bin p m l r) = + bin p m l1 r1 :*: bin p m l2 r2 + where + (l1 :*: l2) = go f l + (r1 :*: r2) = go f r + go f (Tip k x) = case f k x of + Left y -> (Tip k y :*: Nil) + Right z -> (Nil :*: Tip k z) + go _ Nil = (Nil :*: Nil) + +-- | \(O(\min(n,W))\). The expression (@'split' k map@) is a pair @(map1,map2)@ +-- where all keys in @map1@ are lower than @k@ and all keys in +-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@. +-- +-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")]) +-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a") +-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a") +-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty) +-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty) + +split :: Key -> Word64Map a -> (Word64Map a, Word64Map a) +split k t = + case t of + Bin p m l r + | m < 0 -> + if k >= 0 -- handle negative numbers. + then + case go k l of + (lt :*: gt) -> + let !lt' = bin p m lt r + in (lt', gt) + else + case go k r of + (lt :*: gt) -> + let !gt' = bin p m l gt + in (lt, gt') + _ -> case go k t of + (lt :*: gt) -> (lt, gt) + where + go k' t'@(Bin p m l r) + | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t' + | zero k' m = case go k' l of (lt :*: gt) -> lt :*: bin p m gt r + | otherwise = case go k' r of (lt :*: gt) -> bin p m l lt :*: gt + go k' t'@(Tip ky _) + | k' > ky = (t' :*: Nil) + | k' < ky = (Nil :*: t') + | otherwise = (Nil :*: Nil) + go _ Nil = (Nil :*: Nil) + + +data SplitLookup a = SplitLookup !(Word64Map a) !(Maybe a) !(Word64Map a) + +mapLT :: (Word64Map a -> Word64Map a) -> SplitLookup a -> SplitLookup a +mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt +{-# INLINE mapLT #-} + +mapGT :: (Word64Map a -> Word64Map a) -> SplitLookup a -> SplitLookup a +mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt) +{-# INLINE mapGT #-} + +-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot +-- key was found in the original map. +-- +-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")]) +-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a") +-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a") +-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty) +-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty) + +splitLookup :: Key -> Word64Map a -> (Word64Map a, Maybe a, Word64Map a) +splitLookup k t = + case + case t of + Bin p m l r + | m < 0 -> + if k >= 0 -- handle negative numbers. + then mapLT (flip (bin p m) r) (go k l) + else mapGT (bin p m l) (go k r) + _ -> go k t + of SplitLookup lt fnd gt -> (lt, fnd, gt) + where + go k' t'@(Bin p m l r) + | nomatch k' p m = + if k' > p + then SplitLookup t' Nothing Nil + else SplitLookup Nil Nothing t' + | zero k' m = mapGT (flip (bin p m) r) (go k' l) + | otherwise = mapLT (bin p m l) (go k' r) + go k' t'@(Tip ky y) + | k' > ky = SplitLookup t' Nothing Nil + | k' < ky = SplitLookup Nil Nothing t' + | otherwise = SplitLookup Nil (Just y) Nil + go _ Nil = SplitLookup Nil Nothing Nil + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | \(O(n)\). Fold the values in the map using the given right-associative +-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. +-- +-- For example, +-- +-- > elems map = foldr (:) [] map +-- +-- > let f a len = len + (length a) +-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 +foldr :: (a -> b -> b) -> b -> Word64Map a -> b +foldr f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of + Bin _ m l r + | m < 0 -> go (go z l) r -- put negative numbers before + | otherwise -> go (go z r) l + _ -> go z t + where + go z' Nil = z' + go z' (Tip _ x) = f x z' + go z' (Bin _ _ l r) = go (go z' r) l +{-# INLINE foldr #-} + +-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldr' :: (a -> b -> b) -> b -> Word64Map a -> b +foldr' f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of + Bin _ m l r + | m < 0 -> go (go z l) r -- put negative numbers before + | otherwise -> go (go z r) l + _ -> go z t + where + go !z' Nil = z' + go z' (Tip _ x) = f x z' + go z' (Bin _ _ l r) = go (go z' r) l +{-# INLINE foldr' #-} + +-- | \(O(n)\). Fold the values in the map using the given left-associative +-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. +-- +-- For example, +-- +-- > elems = reverse . foldl (flip (:)) [] +-- +-- > let f len a = len + (length a) +-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 +foldl :: (a -> b -> a) -> a -> Word64Map b -> a +foldl f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of + Bin _ m l r + | m < 0 -> go (go z r) l -- put negative numbers before + | otherwise -> go (go z l) r + _ -> go z t + where + go z' Nil = z' + go z' (Tip _ x) = f z' x + go z' (Bin _ _ l r) = go (go z' l) r +{-# INLINE foldl #-} + +-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldl' :: (a -> b -> a) -> a -> Word64Map b -> a +foldl' f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of + Bin _ m l r + | m < 0 -> go (go z r) l -- put negative numbers before + | otherwise -> go (go z l) r + _ -> go z t + where + go !z' Nil = z' + go z' (Tip _ x) = f z' x + go z' (Bin _ _ l r) = go (go z' l) r +{-# INLINE foldl' #-} + +-- | \(O(n)\). Fold the keys and values in the map using the given right-associative +-- binary operator, such that +-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. +-- +-- For example, +-- +-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map +-- +-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" +-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" +foldrWithKey :: (Key -> a -> b -> b) -> b -> Word64Map a -> b +foldrWithKey f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of + Bin _ m l r + | m < 0 -> go (go z l) r -- put negative numbers before + | otherwise -> go (go z r) l + _ -> go z t + where + go z' Nil = z' + go z' (Tip kx x) = f kx x z' + go z' (Bin _ _ l r) = go (go z' r) l +{-# INLINE foldrWithKey #-} + +-- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldrWithKey' :: (Key -> a -> b -> b) -> b -> Word64Map a -> b +foldrWithKey' f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of + Bin _ m l r + | m < 0 -> go (go z l) r -- put negative numbers before + | otherwise -> go (go z r) l + _ -> go z t + where + go !z' Nil = z' + go z' (Tip kx x) = f kx x z' + go z' (Bin _ _ l r) = go (go z' r) l +{-# INLINE foldrWithKey' #-} + +-- | \(O(n)\). Fold the keys and values in the map using the given left-associative +-- binary operator, such that +-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. +-- +-- For example, +-- +-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) [] +-- +-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" +-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)" +foldlWithKey :: (a -> Key -> b -> a) -> a -> Word64Map b -> a +foldlWithKey f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of + Bin _ m l r + | m < 0 -> go (go z r) l -- put negative numbers before + | otherwise -> go (go z l) r + _ -> go z t + where + go z' Nil = z' + go z' (Tip kx x) = f z' kx x + go z' (Bin _ _ l r) = go (go z' l) r +{-# INLINE foldlWithKey #-} + +-- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldlWithKey' :: (a -> Key -> b -> a) -> a -> Word64Map b -> a +foldlWithKey' f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of + Bin _ m l r + | m < 0 -> go (go z r) l -- put negative numbers before + | otherwise -> go (go z l) r + _ -> go z t + where + go !z' Nil = z' + go z' (Tip kx x) = f z' kx x + go z' (Bin _ _ l r) = go (go z' l) r +{-# INLINE foldlWithKey' #-} + +-- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that +-- +-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@ +-- +-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids. +-- +-- @since 0.5.4 +foldMapWithKey :: Monoid m => (Key -> a -> m) -> Word64Map a -> m +foldMapWithKey f = go + where + go Nil = mempty + go (Tip kx x) = f kx x + go (Bin _ m l r) + | m < 0 = go r `mappend` go l + | otherwise = go l `mappend` go r +{-# INLINE foldMapWithKey #-} + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | \(O(n)\). +-- Return all elements of the map in the ascending order of their keys. +-- Subject to list fusion. +-- +-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"] +-- > elems empty == [] + +elems :: Word64Map a -> [a] +elems = foldr (:) [] + +-- | \(O(n)\). Return all keys of the map in ascending order. Subject to list +-- fusion. +-- +-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5] +-- > keys empty == [] + +keys :: Word64Map a -> [Key] +keys = foldrWithKey (\k _ ks -> k : ks) [] + +-- | \(O(n)\). An alias for 'toAscList'. Returns all key\/value pairs in the +-- map in ascending key order. Subject to list fusion. +-- +-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] +-- > assocs empty == [] + +assocs :: Word64Map a -> [(Key,a)] +assocs = toAscList + +-- | \(O(n \min(n,W))\). The set of all keys of the map. +-- +-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Word64Set.fromList [3,5] +-- > keysSet empty == Data.Word64Set.empty + +keysSet :: Word64Map a -> Word64Set.Word64Set +keysSet Nil = Word64Set.Nil +keysSet (Tip kx _) = Word64Set.singleton kx +keysSet (Bin p m l r) + | m .&. Word64Set.suffixBitMask == 0 = Word64Set.Bin p m (keysSet l) (keysSet r) + | otherwise = Word64Set.Tip (p .&. Word64Set.prefixBitMask) (computeBm (computeBm 0 l) r) + where computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r' + computeBm acc (Tip kx _) = acc .|. Word64Set.bitmapOf kx + computeBm _ Nil = error "Data.Word64Set.keysSet: Nil" + +-- | \(O(n)\). Build a map from a set of keys and a function which for each key +-- computes its value. +-- +-- > fromSet (\k -> replicate k 'a') (Data.Word64Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] +-- > fromSet undefined Data.Word64Set.empty == empty + +fromSet :: (Key -> a) -> Word64Set.Word64Set -> Word64Map a +fromSet _ Word64Set.Nil = Nil +fromSet f (Word64Set.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r) +fromSet f (Word64Set.Tip kx bm) = buildTree f kx bm (Word64Set.suffixBitMask + 1) + where + -- This is slightly complicated, as we to convert the dense + -- representation of Word64Set into tree representation of Word64Map. + -- + -- We are given a nonzero bit mask 'bmask' of 'bits' bits with + -- prefix 'prefix'. We split bmask into halves corresponding + -- to left and right subtree. If they are both nonempty, we + -- create a Bin node, otherwise exactly one of them is nonempty + -- and we construct the Word64Map from that half. + buildTree g !prefix !bmask bits = case bits of + 0 -> Tip prefix (g prefix) + _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of + bits2 + | bmask .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 -> + buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2 + | (bmask `shiftRL` fromIntegral bits2) .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 -> + buildTree g prefix bmask bits2 + | otherwise -> + Bin prefix bits2 + (buildTree g prefix bmask bits2) + (buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2) + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} + +-- | @since 0.5.6.2 +instance GHCExts.IsList (Word64Map a) where + type Item (Word64Map a) = (Key,a) + fromList = fromList + toList = toList + +-- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list +-- fusion. +-- +-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] +-- > toList empty == [] + +toList :: Word64Map a -> [(Key,a)] +toList = toAscList + +-- | \(O(n)\). Convert the map to a list of key\/value pairs where the +-- keys are in ascending order. Subject to list fusion. +-- +-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] + +toAscList :: Word64Map a -> [(Key,a)] +toAscList = foldrWithKey (\k x xs -> (k,x):xs) [] + +-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys +-- are in descending order. Subject to list fusion. +-- +-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")] + +toDescList :: Word64Map a -> [(Key,a)] +toDescList = foldlWithKey (\xs k x -> (k,x):xs) [] + +-- List fusion for the list generating functions. +-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion. +-- They are important to convert unfused methods back, see mapFB in prelude. +foldrFB :: (Key -> a -> b -> b) -> b -> Word64Map a -> b +foldrFB = foldrWithKey +{-# INLINE[0] foldrFB #-} +foldlFB :: (a -> Key -> b -> a) -> a -> Word64Map b -> a +foldlFB = foldlWithKey +{-# INLINE[0] foldlFB #-} + +-- Inline assocs and toList, so that we need to fuse only toAscList. +{-# INLINE assocs #-} +{-# INLINE toList #-} + +-- The fusion is enabled up to phase 2 included. If it does not succeed, +-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to +-- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were +-- used in a list fusion, otherwise it would go away in phase 1), and let compiler +-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to +-- inline it before phase 0, otherwise the fusion rules would not fire at all. +{-# NOINLINE[0] elems #-} +{-# NOINLINE[0] keys #-} +{-# NOINLINE[0] toAscList #-} +{-# NOINLINE[0] toDescList #-} +{-# RULES "Word64Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-} +{-# RULES "Word64Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-} +{-# RULES "Word64Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-} +{-# RULES "Word64Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-} +{-# RULES "Word64Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-} +{-# RULES "Word64Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-} +{-# RULES "Word64Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-} +{-# RULES "Word64Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-} + + +-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs. +-- +-- > fromList [] == empty +-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] +-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] + +fromList :: [(Key,a)] -> Word64Map a +fromList xs + = Foldable.foldl' ins empty xs + where + ins t (k,x) = insert k x t + +-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +-- +-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")] +-- > fromListWith (++) [] == empty + +fromListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a +fromListWith f xs + = fromListWithKey (\_ x y -> f x y) xs + +-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. +-- +-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] +-- > fromListWithKey f [] == empty + +fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a +fromListWithKey f xs + = Foldable.foldl' ins empty xs + where + ins t (k,x) = insertWithKey f k x t + +-- | \(O(n)\). Build a map from a list of key\/value pairs where +-- the keys are in ascending order. +-- +-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] +-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] + +fromAscList :: [(Key,a)] -> Word64Map a +fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) +{-# NOINLINE fromAscList #-} + +-- | \(O(n)\). Build a map from a list of key\/value pairs where +-- the keys are in ascending order, with a combining function on equal keys. +-- /The precondition (input list is ascending) is not checked./ +-- +-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] + +fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a +fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) +{-# NOINLINE fromAscListWith #-} + +-- | \(O(n)\). Build a map from a list of key\/value pairs where +-- the keys are in ascending order, with a combining function on equal keys. +-- /The precondition (input list is ascending) is not checked./ +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] + +fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a +fromAscListWithKey f = fromMonoListWithKey Nondistinct f +{-# NOINLINE fromAscListWithKey #-} + +-- | \(O(n)\). Build a map from a list of key\/value pairs where +-- the keys are in ascending order and all distinct. +-- /The precondition (input list is strictly ascending) is not checked./ +-- +-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] + +fromDistinctAscList :: [(Key,a)] -> Word64Map a +fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) +{-# NOINLINE fromDistinctAscList #-} + +-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys +-- and a combining function. +-- +-- The precise conditions under which this function works are subtle: +-- For any branch mask, keys with the same prefix w.r.t. the branch +-- mask must occur consecutively in the list. + +fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a +fromMonoListWithKey distinct f = go + where + go [] = Nil + go ((kx,vx) : zs1) = addAll' kx vx zs1 + + -- `addAll'` collects all keys equal to `kx` into a single value, + -- and then proceeds with `addAll`. + addAll' !kx vx [] + = Tip kx vx + addAll' !kx vx ((ky,vy) : zs) + | Nondistinct <- distinct, kx == ky + = let v = f kx vy vx in addAll' ky v zs + -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs) + | m <- branchMask kx ky + , Inserted ty zs' <- addMany' m ky vy zs + = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx vx)) zs' + + -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx` + -- `addAll` consumes the rest of the list, adding to the tree `tx` + addAll !_kx !tx [] + = tx + addAll !kx !tx ((ky,vy) : zs) + | m <- branchMask kx ky + , Inserted ty zs' <- addMany' m ky vy zs + = addAll kx (linkWithMask m ky ty {-kx-} tx) zs' + + -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. + addMany' !_m !kx vx [] + = Inserted (Tip kx vx) [] + addMany' !m !kx vx zs0@((ky,vy) : zs) + | Nondistinct <- distinct, kx == ky + = let v = f kx vy vx in addMany' m ky v zs + -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs) + | mask kx m /= mask ky m + = Inserted (Tip kx vx) zs0 + | mxy <- branchMask kx ky + , Inserted ty zs' <- addMany' mxy ky vy zs + = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx vx)) zs' + + -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`. + addMany !_m !_kx tx [] + = Inserted tx [] + addMany !m !kx tx zs0@((ky,vy) : zs) + | mask kx m /= mask ky m + = Inserted tx zs0 + | mxy <- branchMask kx ky + , Inserted ty zs' <- addMany' mxy ky vy zs + = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs' +{-# INLINE fromMonoListWithKey #-} + +data Inserted a = Inserted !(Word64Map a) ![(Key,a)] + +data Distinct = Distinct | Nondistinct + +{-------------------------------------------------------------------- + Eq +--------------------------------------------------------------------} +instance Eq a => Eq (Word64Map a) where + t1 == t2 = equal t1 t2 + t1 /= t2 = nequal t1 t2 + +equal :: Eq a => Word64Map a -> Word64Map a -> Bool +equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) +equal (Tip kx x) (Tip ky y) + = (kx == ky) && (x==y) +equal Nil Nil = True +equal _ _ = False + +nequal :: Eq a => Word64Map a -> Word64Map a -> Bool +nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) +nequal (Tip kx x) (Tip ky y) + = (kx /= ky) || (x/=y) +nequal Nil Nil = False +nequal _ _ = True + +-- | @since 0.5.9 +instance Eq1 Word64Map where + liftEq eq (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 == m2) && (p1 == p2) && (liftEq eq l1 l2) && (liftEq eq r1 r2) + liftEq eq (Tip kx x) (Tip ky y) + = (kx == ky) && (eq x y) + liftEq _eq Nil Nil = True + liftEq _eq _ _ = False + +{-------------------------------------------------------------------- + Ord +--------------------------------------------------------------------} + +instance Ord a => Ord (Word64Map a) where + compare m1 m2 = compare (toList m1) (toList m2) + +-- | @since 0.5.9 +instance Ord1 Word64Map where + liftCompare cmp m n = + liftCompare (liftCompare cmp) (toList m) (toList n) + +{-------------------------------------------------------------------- + Functor +--------------------------------------------------------------------} + +instance Functor Word64Map where + fmap = map + + a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r) + a <$ Tip k _ = Tip k a + _ <$ Nil = Nil + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} + +instance Show a => Show (Word64Map a) where + showsPrec d m = showParen (d > 10) $ + showString "fromList " . shows (toList m) + +-- | @since 0.5.9 +instance Show1 Word64Map where + liftShowsPrec sp sl d m = + showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m) + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +{-------------------------------------------------------------------- + Read +--------------------------------------------------------------------} +instance (Read e) => Read (Word64Map e) where + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- readPrec + return (fromList xs) + + readListPrec = readListPrecDefault + +-- | @since 0.5.9 +instance Read1 Word64Map where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +{-------------------------------------------------------------------- + Helpers +--------------------------------------------------------------------} +{-------------------------------------------------------------------- + Link +--------------------------------------------------------------------} +link :: Prefix -> Word64Map a -> Prefix -> Word64Map a -> Word64Map a +link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2 +{-# INLINE link #-} + +-- `linkWithMask` is useful when the `branchMask` has already been computed +linkWithMask :: Mask -> Prefix -> Word64Map a -> Word64Map a -> Word64Map a +linkWithMask m p1 t1 {-p2-} t2 + | zero p1 m = Bin p m t1 t2 + | otherwise = Bin p m t2 t1 + where + p = mask p1 m +{-# INLINE linkWithMask #-} + +{-------------------------------------------------------------------- + @bin@ assures that we never have empty trees within a tree. +--------------------------------------------------------------------} +bin :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a +bin _ _ l Nil = l +bin _ _ Nil r = r +bin p m l r = Bin p m l r +{-# INLINE bin #-} + +-- binCheckLeft only checks that the left subtree is non-empty +binCheckLeft :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a +binCheckLeft _ _ Nil r = r +binCheckLeft p m l r = Bin p m l r +{-# INLINE binCheckLeft #-} + +-- binCheckRight only checks that the right subtree is non-empty +binCheckRight :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a +binCheckRight _ _ l Nil = l +binCheckRight p m l r = Bin p m l r +{-# INLINE binCheckRight #-} + +{-------------------------------------------------------------------- + Endian independent bit twiddling +--------------------------------------------------------------------} + +-- | Should this key follow the left subtree of a 'Bin' with switching +-- bit @m@? N.B., the answer is only valid when @match i p m@ is true. +zero :: Key -> Mask -> Bool +zero i m + = (natFromInt i) .&. (natFromInt m) == 0 +{-# INLINE zero #-} + +nomatch,match :: Key -> Prefix -> Mask -> Bool + +-- | Does the key @i@ differ from the prefix @p@ before getting to +-- the switching bit @m@? +nomatch i p m + = (mask i m) /= p +{-# INLINE nomatch #-} + +-- | Does the key @i@ match the prefix @p@ (up to but not including +-- bit @m@)? +match i p m + = (mask i m) == p +{-# INLINE match #-} + + +-- | The prefix of key @i@ up to (but not including) the switching +-- bit @m@. +mask :: Key -> Mask -> Prefix +mask i m + = maskW (natFromInt i) (natFromInt m) +{-# INLINE mask #-} + + +{-------------------------------------------------------------------- + Big endian operations +--------------------------------------------------------------------} + +-- | The prefix of key @i@ up to (but not including) the switching +-- bit @m@. +maskW :: Nat -> Nat -> Prefix +maskW i m + = intFromNat (i .&. ((-m) `xor` m)) +{-# INLINE maskW #-} + +-- | Does the left switching bit specify a shorter prefix? +shorter :: Mask -> Mask -> Bool +shorter m1 m2 + = (natFromInt m1) > (natFromInt m2) +{-# INLINE shorter #-} + +-- | The first switching bit where the two prefixes disagree. +branchMask :: Prefix -> Prefix -> Mask +branchMask p1 p2 + = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2)) +{-# INLINE branchMask #-} + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} + +-- | \(O(1)\). Decompose a map into pieces based on the structure +-- of the underlying tree. This function is useful for consuming a +-- map in parallel. +-- +-- No guarantee is made as to the sizes of the pieces; an internal, but +-- deterministic process determines this. However, it is guaranteed that the +-- pieces returned will be in ascending order (all elements in the first submap +-- less than all elements in the second, and so on). +-- +-- Examples: +-- +-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) == +-- > [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]] +-- +-- > splitRoot empty == [] +-- +-- Note that the current implementation does not return more than two submaps, +-- but you should not depend on this behaviour because it can change in the +-- future without notice. +splitRoot :: Word64Map a -> [Word64Map a] +splitRoot orig = + case orig of + Nil -> [] + x@(Tip _ _) -> [x] + Bin _ m l r | m < 0 -> [r, l] + | otherwise -> [l, r] +{-# INLINE splitRoot #-} + + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} + +-- | \(O(n \min(n,W))\). Show the tree that implements the map. The tree is shown +-- in a compressed, hanging format. +showTree :: Show a => Word64Map a -> String +showTree s + = showTreeWith True False s + + +{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows + the tree that implements the map. If @hang@ is + 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If + @wide@ is 'True', an extra wide version is shown. +-} +showTreeWith :: Show a => Bool -> Bool -> Word64Map a -> String +showTreeWith hang wide t + | hang = (showsTreeHang wide [] t) "" + | otherwise = (showsTree wide [] [] t) "" + +showsTree :: Show a => Bool -> [String] -> [String] -> Word64Map a -> ShowS +showsTree wide lbars rbars t = case t of + Bin p m l r -> + showsTree wide (withBar rbars) (withEmpty rbars) r . + showWide wide rbars . + showsBars lbars . showString (showBin p m) . showString "\n" . + showWide wide lbars . + showsTree wide (withEmpty lbars) (withBar lbars) l + Tip k x -> + showsBars lbars . + showString " " . shows k . showString ":=" . shows x . showString "\n" + Nil -> showsBars lbars . showString "|\n" + +showsTreeHang :: Show a => Bool -> [String] -> Word64Map a -> ShowS +showsTreeHang wide bars t = case t of + Bin p m l r -> + showsBars bars . showString (showBin p m) . showString "\n" . + showWide wide bars . + showsTreeHang wide (withBar bars) l . + showWide wide bars . + showsTreeHang wide (withEmpty bars) r + Tip k x -> + showsBars bars . + showString " " . shows k . showString ":=" . shows x . showString "\n" + Nil -> showsBars bars . showString "|\n" + +showBin :: Prefix -> Mask -> String +showBin _ _ + = "*" -- ++ show (p,m) + +showWide :: Bool -> [String] -> String -> String +showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id + +showsBars :: [String] -> ShowS +showsBars bars + = case bars of + [] -> id + _ : tl -> showString (concat (reverse tl)) . showString node + +node :: String +node = "+--" + +withBar, withEmpty :: [String] -> [String] +withBar bars = "| ":bars +withEmpty bars = " ":bars diff --git a/GHC/Data/Word64Map/Lazy.hs b/GHC/Data/Word64Map/Lazy.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Word64Map/Lazy.hs @@ -0,0 +1,227 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Word64Map.Lazy +-- Copyright : (c) Daan Leijen 2002 +-- (c) Andriy Palamarchuk 2008 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- +-- = Finite Word64 Maps (lazy interface) +-- +-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary) +-- from keys of type @Word64@ to values of type @v@. +-- +-- The functions in "Data.Word64Map.Strict" are careful to force values before +-- installing them in an 'Word64Map'. This is usually more efficient in cases where +-- laziness is not essential. The functions in this module do not do so. +-- +-- For a walkthrough of the most commonly used functions see the +-- . +-- +-- This module is intended to be imported qualified, to avoid name clashes with +-- Prelude functions: +-- +-- > import Data.Word64Map.Lazy (Word64Map) +-- > import qualified Data.Word64Map.Lazy as Word64Map +-- +-- Note that the implementation is generally /left-biased/. Functions that take +-- two maps as arguments and combine them, such as `union` and `intersection`, +-- prefer the values in the first argument to those in the second. +-- +-- +-- == Detailed performance information +-- +-- The amortized running time is given for each operation, with \(n\) referring to +-- the number of entries in the map and \(W\) referring to the number of bits in +-- an 'Word64' (64). +-- +-- Benchmarks comparing "Data.Word64Map.Lazy" with other dictionary +-- implementations can be found at https://github.com/haskell-perf/dictionaries. +-- +-- +-- == Implementation +-- +-- The implementation is based on /big-endian patricia trees/. This data +-- structure performs especially well on binary operations like 'union' and +-- 'intersection'. Additionally, benchmarks show that it is also (much) faster +-- on insertions and deletions when compared to a generic size-balanced map +-- implementation (see "Data.Map"). +-- +-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", +-- Workshop on ML, September 1998, pages 77-86, +-- +-- +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\", +-- Journal of the ACM, 15(4), October 1968, pages 514-534. +-- +----------------------------------------------------------------------------- + +module GHC.Data.Word64Map.Lazy ( + -- * Map type + Word64Map, Key -- instance Eq,Show + + -- * Construction + , empty + , singleton + , fromSet + + -- ** From Unordered Lists + , fromList + , fromListWith + , fromListWithKey + + -- ** From Ascending Lists + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Insertion + , insert + , insertWith + , insertWithKey + , insertLookupWithKey + + -- * Deletion\/Update + , delete + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + , alter + , alterF + + -- * Query + -- ** Lookup + , WM.lookup + , (!?) + , (!) + , findWithDefault + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + + -- ** Size + , WM.null + , size + + -- * Combine + + -- ** Union + , union + , unionWith + , unionWithKey + , unions + , unionsWith + + -- ** Difference + , difference + , (\\) + , differenceWith + , differenceWithKey + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithKey + + -- ** Disjoint + , disjoint + + -- ** Compose + , compose + + -- ** Universal combining function + , mergeWithKey + + -- * Traversal + -- ** Map + , WM.map + , mapWithKey + , traverseWithKey + , traverseMaybeWithKey + , mapAccum + , mapAccumWithKey + , mapAccumRWithKey + , mapKeys + , mapKeysWith + , mapKeysMonotonic + + -- * Folds + , WM.foldr + , WM.foldl + , foldrWithKey + , foldlWithKey + , foldMapWithKey + + -- ** Strict folds + , foldr' + , foldl' + , foldrWithKey' + , foldlWithKey' + + -- * Conversion + , elems + , keys + , assocs + , keysSet + + -- ** Lists + , toList + + -- ** Ordered lists + , toAscList + , toDescList + + -- * Filter + , WM.filter + , filterWithKey + , restrictKeys + , withoutKeys + , partition + , partitionWithKey + + , takeWhileAntitone + , dropWhileAntitone + , spanAntitone + + , mapMaybe + , mapMaybeWithKey + , mapEither + , mapEitherWithKey + + , split + , splitLookup + , splitRoot + + -- * Submap + , isSubmapOf, isSubmapOfBy + , isProperSubmapOf, isProperSubmapOfBy + + -- * Min\/Max + , lookupMin + , lookupMax + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , updateMin + , updateMax + , updateMinWithKey + , updateMaxWithKey + , minView + , maxView + , minViewWithKey + , maxViewWithKey + ) where + +import GHC.Data.Word64Map.Internal as WM diff --git a/GHC/Data/Word64Map/Strict.hs b/GHC/Data/Word64Map/Strict.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Word64Map/Strict.hs @@ -0,0 +1,245 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Word64Map.Strict +-- Copyright : (c) Daan Leijen 2002 +-- (c) Andriy Palamarchuk 2008 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- +-- = Finite Word64 Maps (strict interface) +-- +-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary) +-- from key of type @Word64@ to values of type @v@. +-- +-- Each function in this module is careful to force values before installing +-- them in an 'Word64Map'. This is usually more efficient when laziness is not +-- necessary. When laziness /is/ required, use the functions in +-- "Data.Word64Map.Lazy". +-- +-- In particular, the functions in this module obey the following law: +-- +-- - If all values stored in all maps in the arguments are in WHNF, then all +-- values stored in all maps in the results will be in WHNF once those maps +-- are evaluated. +-- +-- For a walkthrough of the most commonly used functions see the +-- . +-- +-- This module is intended to be imported qualified, to avoid name clashes with +-- Prelude functions: +-- +-- > import Data.Word64Map.Strict (Word64Map) +-- > import qualified Data.Word64Map.Strict as Word64Map +-- +-- Note that the implementation is generally /left-biased/. Functions that take +-- two maps as arguments and combine them, such as `union` and `intersection`, +-- prefer the values in the first argument to those in the second. +-- +-- +-- == Detailed performance information +-- +-- The amortized running time is given for each operation, with \(n\) referring to +-- the number of entries in the map and \(W\) referring to the number of bits in +-- an 'Word64' (64). +-- +-- Benchmarks comparing "Data.Word64Map.Strict" with other dictionary +-- implementations can be found at https://github.com/haskell-perf/dictionaries. +-- +-- +-- == Warning +-- +-- The 'Word64Map' type is shared between the lazy and strict modules, meaning that +-- the same 'Word64Map' value can be passed to functions in both modules. This +-- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are +-- the same as for the "Data.Word64Map.Lazy" module, so if they are used the +-- resulting map may contain suspended values (thunks). +-- +-- +-- == Implementation +-- +-- The implementation is based on /big-endian patricia trees/. This data +-- structure performs especially well on binary operations like 'union' and +-- 'intersection'. Additionally, benchmarks show that it is also (much) faster +-- on insertions and deletions when compared to a generic size-balanced map +-- implementation (see "Data.Map"). +-- +-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", +-- Workshop on ML, September 1998, pages 77-86, +-- +-- +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\", +-- Journal of the ACM, 15(4), October 1968, pages 514-534. +-- +----------------------------------------------------------------------------- + +-- See the notes at the beginning of Data.Word64Map.Internal. + +module GHC.Data.Word64Map.Strict ( + -- * Map type + Word64Map, Key -- instance Eq,Show + + -- * Construction + , empty + , singleton + , fromSet + + -- ** From Unordered Lists + , fromList + , fromListWith + , fromListWithKey + + -- ** From Ascending Lists + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Insertion + , insert + , insertWith + , insertWithKey + , insertLookupWithKey + + -- * Deletion\/Update + , delete + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + , alter + , alterF + + -- * Query + -- ** Lookup + , lookup + , (!?) + , (!) + , findWithDefault + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + + -- ** Size + , null + , size + + -- * Combine + + -- ** Union + , union + , unionWith + , unionWithKey + , unions + , unionsWith + + -- ** Difference + , difference + , (\\) + , differenceWith + , differenceWithKey + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithKey + + -- ** Disjoint + , disjoint + + -- ** Compose + , compose + + -- ** Universal combining function + , mergeWithKey + + -- * Traversal + -- ** Map + , map + , mapWithKey + , traverseWithKey + , traverseMaybeWithKey + , mapAccum + , mapAccumWithKey + , mapAccumRWithKey + , mapKeys + , mapKeysWith + , mapKeysMonotonic + + -- * Folds + , foldr + , foldl + , foldrWithKey + , foldlWithKey + , foldMapWithKey + + -- ** Strict folds + , foldr' + , foldl' + , foldrWithKey' + , foldlWithKey' + + -- * Conversion + , elems + , keys + , assocs + , keysSet + + -- ** Lists + , toList + +-- ** Ordered lists + , toAscList + , toDescList + + -- * Filter + , filter + , filterWithKey + , restrictKeys + , withoutKeys + , partition + , partitionWithKey + + , takeWhileAntitone + , dropWhileAntitone + , spanAntitone + + , mapMaybe + , mapMaybeWithKey + , mapEither + , mapEitherWithKey + + , split + , splitLookup + , splitRoot + + -- * Submap + , isSubmapOf, isSubmapOfBy + , isProperSubmapOf, isProperSubmapOfBy + + -- * Min\/Max + , lookupMin + , lookupMax + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , updateMin + , updateMax + , updateMinWithKey + , updateMaxWithKey + , minView + , maxView + , minViewWithKey + , maxViewWithKey + ) where + +import GHC.Data.Word64Map.Strict.Internal diff --git a/GHC/Data/Word64Map/Strict/Internal.hs b/GHC/Data/Word64Map/Strict/Internal.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Word64Map/Strict/Internal.hs @@ -0,0 +1,1195 @@ + +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Word64Map.Strict.Internal +-- Copyright : (c) Daan Leijen 2002 +-- (c) Andriy Palamarchuk 2008 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- +-- = Finite Int Maps (strict interface) +-- +-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary) +-- from key of type @Int@ to values of type @v@. +-- +-- Each function in this module is careful to force values before installing +-- them in an 'Word64Map'. This is usually more efficient when laziness is not +-- necessary. When laziness /is/ required, use the functions in +-- "Data.Word64Map.Lazy". +-- +-- In particular, the functions in this module obey the following law: +-- +-- - If all values stored in all maps in the arguments are in WHNF, then all +-- values stored in all maps in the results will be in WHNF once those maps +-- are evaluated. +-- +-- For a walkthrough of the most commonly used functions see the +-- . +-- +-- This module is intended to be imported qualified, to avoid name clashes with +-- Prelude functions: +-- +-- > import Data.Word64Map.Strict (Word64Map) +-- > import qualified Data.Word64Map.Strict as Word64Map +-- +-- Note that the implementation is generally /left-biased/. Functions that take +-- two maps as arguments and combine them, such as `union` and `intersection`, +-- prefer the values in the first argument to those in the second. +-- +-- +-- == Detailed performance information +-- +-- The amortized running time is given for each operation, with \(n\) referring to +-- the number of entries in the map and \(W\) referring to the number of bits in +-- an 'Int' (32 or 64). +-- +-- Benchmarks comparing "Data.Word64Map.Strict" with other dictionary +-- implementations can be found at https://github.com/haskell-perf/dictionaries. +-- +-- +-- == Warning +-- +-- The 'Word64Map' type is shared between the lazy and strict modules, meaning that +-- the same 'Word64Map' value can be passed to functions in both modules. This +-- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are +-- the same as for the "Data.Word64Map.Lazy" module, so if they are used the +-- resulting map may contain suspended values (thunks). +-- +-- +-- == Implementation +-- +-- The implementation is based on /big-endian patricia trees/. This data +-- structure performs especially well on binary operations like 'union' and +-- 'intersection'. Additionally, benchmarks show that it is also (much) faster +-- on insertions and deletions when compared to a generic size-balanced map +-- implementation (see "Data.Map"). +-- +-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", +-- Workshop on ML, September 1998, pages 77-86, +-- +-- +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\", +-- Journal of the ACM, 15(4), October 1968, pages 514-534. +-- +----------------------------------------------------------------------------- + +-- See the notes at the beginning of Data.Word64Map.Internal. + +module GHC.Data.Word64Map.Strict.Internal ( + -- * Map type + Word64Map, Key -- instance Eq,Show + + -- * Construction + , empty + , singleton + , fromSet + + -- ** From Unordered Lists + , fromList + , fromListWith + , fromListWithKey + + -- ** From Ascending Lists + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Insertion + , insert + , insertWith + , insertWithKey + , insertLookupWithKey + + -- * Deletion\/Update + , delete + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + , alter + , alterF + + -- * Query + -- ** Lookup + , lookup + , (!?) + , (!) + , findWithDefault + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + + -- ** Size + , null + , size + + -- * Combine + + -- ** Union + , union + , unionWith + , unionWithKey + , unions + , unionsWith + + -- ** Difference + , difference + , (\\) + , differenceWith + , differenceWithKey + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithKey + + -- ** Disjoint + , disjoint + + -- ** Compose + , compose + + -- ** Universal combining function + , mergeWithKey + + -- * Traversal + -- ** Map + , map + , mapWithKey + , traverseWithKey + , traverseMaybeWithKey + , mapAccum + , mapAccumWithKey + , mapAccumRWithKey + , mapKeys + , mapKeysWith + , mapKeysMonotonic + + -- * Folds + , foldr + , foldl + , foldrWithKey + , foldlWithKey + , foldMapWithKey + + -- ** Strict folds + , foldr' + , foldl' + , foldrWithKey' + , foldlWithKey' + + -- * Conversion + , elems + , keys + , assocs + , keysSet + + -- ** Lists + , toList + +-- ** Ordered lists + , toAscList + , toDescList + + -- * Filter + , filter + , filterWithKey + , restrictKeys + , withoutKeys + , partition + , partitionWithKey + + , takeWhileAntitone + , dropWhileAntitone + , spanAntitone + + , mapMaybe + , mapMaybeWithKey + , mapEither + , mapEitherWithKey + + , split + , splitLookup + , splitRoot + + -- * Submap + , isSubmapOf, isSubmapOfBy + , isProperSubmapOf, isProperSubmapOfBy + + -- * Min\/Max + , lookupMin + , lookupMax + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , updateMin + , updateMax + , updateMinWithKey + , updateMaxWithKey + , minView + , maxView + , minViewWithKey + , maxViewWithKey + ) where + +import GHC.Prelude.Basic hiding + (lookup, filter, foldr, foldl, foldl', null, map) + +import qualified GHC.Data.Word64Map.Internal as L +import GHC.Data.Word64Map.Internal + ( Word64Map (..) + , Key + , mask + , branchMask + , nomatch + , zero + , natFromInt + , intFromNat + , bin + , binCheckLeft + , binCheckRight + , link + , linkWithMask + + , (\\) + , (!) + , (!?) + , empty + , assocs + , filter + , filterWithKey + , findMin + , findMax + , foldMapWithKey + , foldr + , foldl + , foldr' + , foldl' + , foldlWithKey + , foldrWithKey + , foldlWithKey' + , foldrWithKey' + , keysSet + , mergeWithKey' + , compose + , delete + , deleteMin + , deleteMax + , deleteFindMax + , deleteFindMin + , difference + , elems + , intersection + , disjoint + , isProperSubmapOf + , isProperSubmapOfBy + , isSubmapOf + , isSubmapOfBy + , lookup + , lookupLE + , lookupGE + , lookupLT + , lookupGT + , lookupMin + , lookupMax + , minView + , maxView + , minViewWithKey + , maxViewWithKey + , keys + , mapKeys + , mapKeysMonotonic + , member + , notMember + , null + , partition + , partitionWithKey + , takeWhileAntitone + , dropWhileAntitone + , spanAntitone + , restrictKeys + , size + , split + , splitLookup + , splitRoot + , toAscList + , toDescList + , toList + , union + , unions + , withoutKeys + ) +import qualified GHC.Data.Word64Set.Internal as Word64Set +import GHC.Utils.Containers.Internal.BitUtil +import GHC.Utils.Containers.Internal.StrictPair +import qualified Data.Foldable as Foldable + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} + +-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@ +-- returns the value at key @k@ or returns @def@ when the key is not an +-- element of the map. +-- +-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' +-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' + +-- See Word64Map.Internal.Note: Local 'go' functions and capturing] +findWithDefault :: a -> Key -> Word64Map a -> a +findWithDefault def !k = go + where + go (Bin p m l r) | nomatch k p m = def + | zero k m = go l + | otherwise = go r + go (Tip kx x) | k == kx = x + | otherwise = def + go Nil = def + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | \(O(1)\). A map of one element. +-- +-- > singleton 1 'a' == fromList [(1, 'a')] +-- > size (singleton 1 'a') == 1 + +singleton :: Key -> a -> Word64Map a +singleton k !x + = Tip k x +{-# INLINE singleton #-} + +{-------------------------------------------------------------------- + Insert +--------------------------------------------------------------------} +-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map. +-- If the key is already present in the map, the associated value is +-- replaced with the supplied value, i.e. 'insert' is equivalent to +-- @'insertWith' 'const'@. +-- +-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] +-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] +-- > insert 5 'x' empty == singleton 5 'x' + +insert :: Key -> a -> Word64Map a -> Word64Map a +insert !k !x t = + case t of + Bin p m l r + | nomatch k p m -> link k (Tip k x) p t + | zero k m -> Bin p m (insert k x l) r + | otherwise -> Bin p m l (insert k x r) + Tip ky _ + | k==ky -> Tip k x + | otherwise -> link k (Tip k x) ky t + Nil -> Tip k x + +-- right-biased insertion, used by 'union' +-- | \(O(\min(n,W))\). Insert with a combining function. +-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert @f new_value old_value@. +-- +-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] +-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" + +insertWith :: (a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a +insertWith f k x t + = insertWithKey (\_ x' y' -> f x' y') k x t + +-- | \(O(\min(n,W))\). Insert with a combining function. +-- @'insertWithKey' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert @f key new_value old_value@. +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] +-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" +-- +-- If the key exists in the map, this function is lazy in @value@ but strict +-- in the result of @f@. + +insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a +insertWithKey f !k x t = + case t of + Bin p m l r + | nomatch k p m -> link k (singleton k x) p t + | zero k m -> Bin p m (insertWithKey f k x l) r + | otherwise -> Bin p m l (insertWithKey f k x r) + Tip ky y + | k==ky -> Tip k $! f k x y + | otherwise -> link k (singleton k x) ky t + Nil -> singleton k x + +-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@) +-- is a pair where the first element is equal to (@'lookup' k map@) +-- and the second element equal to (@'insertWithKey' f k x map@). +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) +-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) +-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") +-- +-- This is how to define @insertLookup@ using @insertLookupWithKey@: +-- +-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t +-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) +-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) + +insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> (Maybe a, Word64Map a) +insertLookupWithKey f0 !k0 x0 t0 = toPair $ go f0 k0 x0 t0 + where + go f k x t = + case t of + Bin p m l r + | nomatch k p m -> Nothing :*: link k (singleton k x) p t + | zero k m -> let (found :*: l') = go f k x l in (found :*: Bin p m l' r) + | otherwise -> let (found :*: r') = go f k x r in (found :*: Bin p m l r') + Tip ky y + | k==ky -> (Just y :*: (Tip k $! f k x y)) + | otherwise -> (Nothing :*: link k (singleton k x) ky t) + Nil -> Nothing :*: (singleton k x) + + +{-------------------------------------------------------------------- + Deletion +--------------------------------------------------------------------} +-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +-- +-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] +-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > adjust ("new " ++) 7 empty == empty + +adjust :: (a -> a) -> Key -> Word64Map a -> Word64Map a +adjust f k m + = adjustWithKey (\_ x -> f x) k m + +-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +-- +-- > let f key x = (show key) ++ ":new " ++ x +-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > adjustWithKey f 7 empty == empty + +adjustWithKey :: (Key -> a -> a) -> Key -> Word64Map a -> Word64Map a +adjustWithKey f !k t = + case t of + Bin p m l r + | nomatch k p m -> t + | zero k m -> Bin p m (adjustWithKey f k l) r + | otherwise -> Bin p m l (adjustWithKey f k r) + Tip ky y + | k==ky -> Tip ky $! f k y + | otherwise -> t + Nil -> Nil + +-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] +-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" + +update :: (a -> Maybe a) -> Key -> Word64Map a -> Word64Map a +update f + = updateWithKey (\_ x -> f x) + +-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" + +updateWithKey :: (Key -> a -> Maybe a) -> Key -> Word64Map a -> Word64Map a +updateWithKey f !k t = + case t of + Bin p m l r + | nomatch k p m -> t + | zero k m -> binCheckLeft p m (updateWithKey f k l) r + | otherwise -> binCheckRight p m l (updateWithKey f k r) + Tip ky y + | k==ky -> case f k y of + Just !y' -> Tip ky y' + Nothing -> Nil + | otherwise -> t + Nil -> Nil + +-- | \(O(\min(n,W))\). Lookup and update. +-- The function returns original value, if it is updated. +-- This is different behavior than 'Data.Map.updateLookupWithKey'. +-- Returns the original key value if the map entry is deleted. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) +-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) +-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") + +updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> Word64Map a -> (Maybe a,Word64Map a) +updateLookupWithKey f0 !k0 t0 = toPair $ go f0 k0 t0 + where + go f k t = + case t of + Bin p m l r + | nomatch k p m -> (Nothing :*: t) + | zero k m -> let (found :*: l') = go f k l in (found :*: binCheckLeft p m l' r) + | otherwise -> let (found :*: r') = go f k r in (found :*: binCheckRight p m l r') + Tip ky y + | k==ky -> case f k y of + Just !y' -> (Just y :*: Tip ky y') + Nothing -> (Just y :*: Nil) + | otherwise -> (Nothing :*: t) + Nil -> (Nothing :*: Nil) + + + +-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. +-- 'alter' can be used to insert, delete, or update a value in an 'Word64Map'. +-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. +alter :: (Maybe a -> Maybe a) -> Key -> Word64Map a -> Word64Map a +alter f !k t = + case t of + Bin p m l r + | nomatch k p m -> case f Nothing of + Nothing -> t + Just !x -> link k (Tip k x) p t + | zero k m -> binCheckLeft p m (alter f k l) r + | otherwise -> binCheckRight p m l (alter f k r) + Tip ky y + | k==ky -> case f (Just y) of + Just !x -> Tip ky x + Nothing -> Nil + | otherwise -> case f Nothing of + Just !x -> link k (Tip k x) ky t + Nothing -> t + Nil -> case f Nothing of + Just !x -> Tip k x + Nothing -> Nil + +-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at +-- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, +-- or update a value in an 'Word64Map'. In short : @'lookup' k <$> 'alterF' f k m = f +-- ('lookup' k m)@. +-- +-- Example: +-- +-- @ +-- interactiveAlter :: Int -> Word64Map String -> IO (Word64Map String) +-- interactiveAlter k m = alterF f k m where +-- f Nothing = do +-- putStrLn $ show k ++ +-- " was not found in the map. Would you like to add it?" +-- getUserResponse1 :: IO (Maybe String) +-- f (Just old) = do +-- putStrLn $ "The key is currently bound to " ++ show old ++ +-- ". Would you like to change or delete it?" +-- getUserResponse2 :: IO (Maybe String) +-- @ +-- +-- 'alterF' is the most general operation for working with an individual +-- key that may or may not be in a given map. + +-- Note: 'alterF' is a flipped version of the 'at' combinator from +-- 'Control.Lens.At'. +-- +-- @since 0.5.8 + +alterF :: Functor f + => (Maybe a -> f (Maybe a)) -> Key -> Word64Map a -> f (Word64Map a) +-- This implementation was modified from 'Control.Lens.At'. +alterF f k m = (<$> f mv) $ \fres -> + case fres of + Nothing -> maybe m (const (delete k m)) mv + Just !v' -> insert k v' m + where mv = lookup k m + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +-- | The union of a list of maps, with a combining operation. +-- +-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] +-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] + +unionsWith :: Foldable f => (a->a->a) -> f (Word64Map a) -> Word64Map a +unionsWith f ts + = Foldable.foldl' (unionWith f) empty ts + +-- | \(O(n+m)\). The union with a combining function. +-- +-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] + +unionWith :: (a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a +unionWith f m1 m2 + = unionWithKey (\_ x y -> f x y) m1 m2 + +-- | \(O(n+m)\). The union with a combining function. +-- +-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value +-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] + +unionWithKey :: (Key -> a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a +unionWithKey f m1 m2 + = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) id id m1 m2 + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} + +-- | \(O(n+m)\). Difference with a combining function. +-- +-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing +-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) +-- > == singleton 3 "b:B" + +differenceWith :: (a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a +differenceWith f m1 m2 + = differenceWithKey (\_ x y -> f x y) m1 m2 + +-- | \(O(n+m)\). Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns 'Nothing', the element is discarded (proper set difference). +-- If it returns (@'Just' y@), the element is updated with a new value @y@. +-- +-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing +-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) +-- > == singleton 3 "3:b|B" + +differenceWithKey :: (Key -> a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a +differenceWithKey f m1 m2 + = mergeWithKey f id (const Nil) m1 m2 + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} + +-- | \(O(n+m)\). The intersection with a combining function. +-- +-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" + +intersectionWith :: (a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c +intersectionWith f m1 m2 + = intersectionWithKey (\_ x y -> f x y) m1 m2 + +-- | \(O(n+m)\). The intersection with a combining function. +-- +-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar +-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" + +intersectionWithKey :: (Key -> a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c +intersectionWithKey f m1 m2 + = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) (const Nil) (const Nil) m1 m2 + +{-------------------------------------------------------------------- + MergeWithKey +--------------------------------------------------------------------} + +-- | \(O(n+m)\). A high-performance universal combining function. Using +-- 'mergeWithKey', all combining functions can be defined without any loss of +-- efficiency (with exception of 'union', 'difference' and 'intersection', +-- where sharing of some nodes is lost with 'mergeWithKey'). +-- +-- Please make sure you know what is going on when using 'mergeWithKey', +-- otherwise you can be surprised by unexpected code growth or even +-- corruption of the data structure. +-- +-- When 'mergeWithKey' is given three arguments, it is inlined to the call +-- site. You should therefore use 'mergeWithKey' only to define your custom +-- combining functions. For example, you could define 'unionWithKey', +-- 'differenceWithKey' and 'intersectionWithKey' as +-- +-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 +-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 +-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 +-- +-- When calling @'mergeWithKey' combine only1 only2@, a function combining two +-- 'Word64Map's is created, such that +-- +-- * if a key is present in both maps, it is passed with both corresponding +-- values to the @combine@ function. Depending on the result, the key is either +-- present in the result with specified value, or is left out; +-- +-- * a nonempty subtree present only in the first map is passed to @only1@ and +-- the output is added to the result; +-- +-- * a nonempty subtree present only in the second map is passed to @only2@ and +-- the output is added to the result. +-- +-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. +-- The values can be modified arbitrarily. Most common variants of @only1@ and +-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or +-- @'filterWithKey' f@ could be used for any @f@. + +mergeWithKey :: (Key -> a -> b -> Maybe c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c) + -> Word64Map a -> Word64Map b -> Word64Map c +mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2 + where -- We use the lambda form to avoid non-exhaustive pattern matches warning. + combine = \(Tip k1 x1) (Tip _k2 x2) -> case f k1 x1 x2 of Nothing -> Nil + Just !x -> Tip k1 x + {-# INLINE combine #-} +{-# INLINE mergeWithKey #-} + +{-------------------------------------------------------------------- + Min\/Max +--------------------------------------------------------------------} + +-- | \(O(\log n)\). Update the value at the minimal key. +-- +-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] +-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" + +updateMinWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a +updateMinWithKey f t = + case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r) + _ -> go f t + where + go f' (Bin p m l r) = binCheckLeft p m (go f' l) r + go f' (Tip k y) = case f' k y of + Just !y' -> Tip k y' + Nothing -> Nil + go _ Nil = error "updateMinWithKey Nil" + +-- | \(O(\log n)\). Update the value at the maximal key. +-- +-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] +-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" + +updateMaxWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a +updateMaxWithKey f t = + case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r + _ -> go f t + where + go f' (Bin p m l r) = binCheckRight p m l (go f' r) + go f' (Tip k y) = case f' k y of + Just !y' -> Tip k y' + Nothing -> Nil + go _ Nil = error "updateMaxWithKey Nil" + +-- | \(O(\log n)\). Update the value at the maximal key. +-- +-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] +-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" + +updateMax :: (a -> Maybe a) -> Word64Map a -> Word64Map a +updateMax f = updateMaxWithKey (const f) + +-- | \(O(\log n)\). Update the value at the minimal key. +-- +-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] +-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" + +updateMin :: (a -> Maybe a) -> Word64Map a -> Word64Map a +updateMin f = updateMinWithKey (const f) + + +{-------------------------------------------------------------------- + Mapping +--------------------------------------------------------------------} +-- | \(O(n)\). Map a function over all values in the map. +-- +-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] + +map :: (a -> b) -> Word64Map a -> Word64Map b +map f = go + where + go (Bin p m l r) = Bin p m (go l) (go r) + go (Tip k x) = Tip k $! f x + go Nil = Nil + +{-# NOINLINE [1] map #-} +{-# RULES +"map/map" forall f g xs . map f (map g xs) = map (\x -> f $! g x) xs +"map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs + #-} + +-- | \(O(n)\). Map a function over all values in the map. +-- +-- > let f key x = (show key) ++ ":" ++ x +-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] + +mapWithKey :: (Key -> a -> b) -> Word64Map a -> Word64Map b +mapWithKey f t + = case t of + Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r) + Tip k x -> Tip k $! f k x + Nil -> Nil + +-- Pay close attention to strictness here. We need to force the +-- intermediate result for map f . map g, and we need to refrain +-- from forcing it for map f . L.map g, etc. +-- +-- TODO Consider moving map and mapWithKey to Word64Map.Internal so we can write +-- non-orphan RULES for things like L.map f (map g xs). We'd need a new function +-- for this, and we'd have to pay attention to simplifier phases. Something like +-- +-- lsmap :: (b -> c) -> (a -> b) -> Word64Map a -> Word64Map c +-- lsmap _ _ Nil = Nil +-- lsmap f g (Tip k x) = let !gx = g x in Tip k (f gx) +-- lsmap f g (Bin p m l r) = Bin p m (lsmap f g l) (lsmap f g r) +{-# NOINLINE [1] mapWithKey #-} +{-# RULES +"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) = + mapWithKey (\k a -> f k $! g k a) xs +"mapWithKey/mapWithKeyL" forall f g xs . mapWithKey f (L.mapWithKey g xs) = + mapWithKey (\k a -> f k (g k a)) xs +"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) = + mapWithKey (\k a -> f k $! g a) xs +"mapWithKey/mapL" forall f g xs . mapWithKey f (L.map g xs) = + mapWithKey (\k a -> f k (g a)) xs +"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) = + mapWithKey (\k a -> f $! g k a) xs +"map/mapWithKeyL" forall f g xs . map f (L.mapWithKey g xs) = + mapWithKey (\k a -> f (g k a)) xs + #-} + +-- | \(O(n)\). +-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ +-- That is, behaves exactly like a regular 'traverse' except that the traversing +-- function also has access to the key associated with a value. +-- +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing +traverseWithKey :: Applicative t => (Key -> a -> t b) -> Word64Map a -> t (Word64Map b) +traverseWithKey f = go + where + go Nil = pure Nil + go (Tip k v) = (\ !v' -> Tip k v') <$> f k v + go (Bin p m l r) + | m < 0 = liftA2 (flip (Bin p m)) (go r) (go l) + | otherwise = liftA2 (Bin p m) (go l) (go r) +{-# INLINE traverseWithKey #-} + +-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results. +-- +-- @since 0.6.4 +traverseMaybeWithKey + :: Applicative f => (Key -> a -> f (Maybe b)) -> Word64Map a -> f (Word64Map b) +traverseMaybeWithKey f = go + where + go Nil = pure Nil + go (Tip k x) = maybe Nil (Tip k $!) <$> f k x + go (Bin p m l r) + | m < 0 = liftA2 (flip (bin p m)) (go r) (go l) + | otherwise = liftA2 (bin p m) (go l) (go r) + +-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a b = (a ++ b, b ++ "X") +-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) + +mapAccum :: (a -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c) +mapAccum f = mapAccumWithKey (\a' _ x -> f a' x) + +-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") +-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) + +mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c) +mapAccumWithKey f a t + = mapAccumL f a t + +-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating +-- argument through the map in ascending order of keys. Strict in +-- the accumulating argument and the both elements of the +-- result of the function. +mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c) +mapAccumL f0 a0 t0 = toPair $ go f0 a0 t0 + where + go f a t + = case t of + Bin p m l r + | m < 0 -> + let (a1 :*: r') = go f a r + (a2 :*: l') = go f a1 l + in (a2 :*: Bin p m l' r') + | otherwise -> + let (a1 :*: l') = go f a l + (a2 :*: r') = go f a1 r + in (a2 :*: Bin p m l' r') + Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x') + Nil -> (a :*: Nil) + +-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating +-- argument through the map in descending order of keys. +mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c) +mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0 + where + go f a t + = case t of + Bin p m l r + | m < 0 -> + let (a1 :*: l') = go f a l + (a2 :*: r') = go f a1 r + in (a2 :*: Bin p m l' r') + | otherwise -> + let (a1 :*: r') = go f a r + (a2 :*: l') = go f a1 l + in (a2 :*: Bin p m l' r') + Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x') + Nil -> (a :*: Nil) + +-- | \(O(n \log n)\). +-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the associated values will be +-- combined using @c@. +-- +-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" +-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" + +mapKeysWith :: (a -> a -> a) -> (Key->Key) -> Word64Map a -> Word64Map a +mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] + +{-------------------------------------------------------------------- + Filter +--------------------------------------------------------------------} +-- | \(O(n)\). Map values and collect the 'Just' results. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" + +mapMaybe :: (a -> Maybe b) -> Word64Map a -> Word64Map b +mapMaybe f = mapMaybeWithKey (\_ x -> f x) + +-- | \(O(n)\). Map keys\/values and collect the 'Just' results. +-- +-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing +-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" + +mapMaybeWithKey :: (Key -> a -> Maybe b) -> Word64Map a -> Word64Map b +mapMaybeWithKey f (Bin p m l r) + = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r) +mapMaybeWithKey f (Tip k x) = case f k x of + Just !y -> Tip k y + Nothing -> Nil +mapMaybeWithKey _ Nil = Nil + +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. +-- +-- > let f a = if a < "c" then Left a else Right a +-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) +-- > +-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) + +mapEither :: (a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c) +mapEither f m + = mapEitherWithKey (\_ x -> f x) m + +-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results. +-- +-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) +-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) +-- > +-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) + +mapEitherWithKey :: (Key -> a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c) +mapEitherWithKey f0 t0 = toPair $ go f0 t0 + where + go f (Bin p m l r) + = bin p m l1 r1 :*: bin p m l2 r2 + where + (l1 :*: l2) = go f l + (r1 :*: r2) = go f r + go f (Tip k x) = case f k x of + Left !y -> (Tip k y :*: Nil) + Right !z -> (Nil :*: Tip k z) + go _ Nil = (Nil :*: Nil) + +{-------------------------------------------------------------------- + Conversions +--------------------------------------------------------------------} + +-- | \(O(n)\). Build a map from a set of keys and a function which for each key +-- computes its value. +-- +-- > fromSet (\k -> replicate k 'a') (Data.Word64Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] +-- > fromSet undefined Data.Word64Set.empty == empty + +fromSet :: (Key -> a) -> Word64Set.Word64Set -> Word64Map a +fromSet _ Word64Set.Nil = Nil +fromSet f (Word64Set.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r) +fromSet f (Word64Set.Tip kx bm) = buildTree f kx bm (Word64Set.suffixBitMask + 1) + where -- This is slightly complicated, as we to convert the dense + -- representation of Word64Set into tree representation of Word64Map. + -- + -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'. + -- We split bmask into halves corresponding to left and right subtree. + -- If they are both nonempty, we create a Bin node, otherwise exactly + -- one of them is nonempty and we construct the Word64Map from that half. + buildTree g !prefix !bmask bits = case bits of + 0 -> Tip prefix $! g prefix + _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of + bits2 | bmask .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 -> + buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2 + | (bmask `shiftRL` fromIntegral bits2) .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 -> + buildTree g prefix bmask bits2 + | otherwise -> + Bin prefix bits2 (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2) + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs. +-- +-- > fromList [] == empty +-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] +-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] + +fromList :: [(Key,a)] -> Word64Map a +fromList xs + = Foldable.foldl' ins empty xs + where + ins t (k,x) = insert k x t + +-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +-- +-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] +-- > fromListWith (++) [] == empty + +fromListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a +fromListWith f xs + = fromListWithKey (\_ x y -> f x y) xs + +-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. +-- +-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] +-- > fromListWithKey f [] == empty + +fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a +fromListWithKey f xs + = Foldable.foldl' ins empty xs + where + ins t (k,x) = insertWithKey f k x t + +-- | \(O(n)\). Build a map from a list of key\/value pairs where +-- the keys are in ascending order. +-- +-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] +-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] + +fromAscList :: [(Key,a)] -> Word64Map a +fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) +{-# NOINLINE fromAscList #-} + +-- | \(O(n)\). Build a map from a list of key\/value pairs where +-- the keys are in ascending order, with a combining function on equal keys. +-- /The precondition (input list is ascending) is not checked./ +-- +-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] + +fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a +fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) +{-# NOINLINE fromAscListWith #-} + +-- | \(O(n)\). Build a map from a list of key\/value pairs where +-- the keys are in ascending order, with a combining function on equal keys. +-- /The precondition (input list is ascending) is not checked./ +-- +-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] + +fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a +fromAscListWithKey f = fromMonoListWithKey Nondistinct f +{-# NOINLINE fromAscListWithKey #-} + +-- | \(O(n)\). Build a map from a list of key\/value pairs where +-- the keys are in ascending order and all distinct. +-- /The precondition (input list is strictly ascending) is not checked./ +-- +-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] + +fromDistinctAscList :: [(Key,a)] -> Word64Map a +fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) +{-# NOINLINE fromDistinctAscList #-} + +-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys +-- and a combining function. +-- +-- The precise conditions under which this function works are subtle: +-- For any branch mask, keys with the same prefix w.r.t. the branch +-- mask must occur consecutively in the list. + +fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a +fromMonoListWithKey distinct f = go + where + go [] = Nil + go ((kx,vx) : zs1) = addAll' kx vx zs1 + + -- `addAll'` collects all keys equal to `kx` into a single value, + -- and then proceeds with `addAll`. + addAll' !kx vx [] + = Tip kx $! vx + addAll' !kx vx ((ky,vy) : zs) + | Nondistinct <- distinct, kx == ky + = let !v = f kx vy vx in addAll' ky v zs + -- inlined: | otherwise = addAll kx (Tip kx $! vx) (ky : zs) + | m <- branchMask kx ky + , Inserted ty zs' <- addMany' m ky vy zs + = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx $! vx)) zs' + + -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx` + -- `addAll` consumes the rest of the list, adding to the tree `tx` + addAll !_kx !tx [] + = tx + addAll !kx !tx ((ky,vy) : zs) + | m <- branchMask kx ky + , Inserted ty zs' <- addMany' m ky vy zs + = addAll kx (linkWithMask m ky ty {-kx-} tx) zs' + + -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. + addMany' !_m !kx vx [] + = Inserted (Tip kx $! vx) [] + addMany' !m !kx vx zs0@((ky,vy) : zs) + | Nondistinct <- distinct, kx == ky + = let !v = f kx vy vx in addMany' m ky v zs + -- inlined: | otherwise = addMany m kx (Tip kx $! vx) (ky : zs) + | mask kx m /= mask ky m + = Inserted (Tip kx $! vx) zs0 + | mxy <- branchMask kx ky + , Inserted ty zs' <- addMany' mxy ky vy zs + = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx $! vx)) zs' + + -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`. + addMany !_m !_kx tx [] + = Inserted tx [] + addMany !m !kx tx zs0@((ky,vy) : zs) + | mask kx m /= mask ky m + = Inserted tx zs0 + | mxy <- branchMask kx ky + , Inserted ty zs' <- addMany' mxy ky vy zs + = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs' +{-# INLINE fromMonoListWithKey #-} + +data Inserted a = Inserted !(Word64Map a) ![(Key,a)] + +data Distinct = Distinct | Nondistinct diff --git a/GHC/Data/Word64Set.hs b/GHC/Data/Word64Set.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Word64Set.hs @@ -0,0 +1,160 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Word64Set +-- Copyright : (c) Daan Leijen 2002 +-- (c) Joachim Breitner 2011 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- +-- = Finite Int Sets +-- +-- The @'Word64Set'@ type represents a set of elements of type @Int@. +-- +-- For a walkthrough of the most commonly used functions see their +-- . +-- +-- These modules are intended to be imported qualified, to avoid name +-- clashes with Prelude functions, e.g. +-- +-- > import Data.Word64Set (Word64Set) +-- > import qualified Data.Word64Set as Word64Set +-- +-- +-- == Performance information +-- +-- Many operations have a worst-case complexity of \(O(\min(n,W))\). +-- This means that the operation can become linear in the number of +-- elements with a maximum of \(W\) -- the number of bits in an 'Int' +-- (32 or 64). +-- +-- +-- == Implementation +-- +-- The implementation is based on /big-endian patricia trees/. This data +-- structure performs especially well on binary operations like 'union' +-- and 'intersection'. However, my benchmarks show that it is also +-- (much) faster on insertions and deletions when compared to a generic +-- size-balanced set implementation (see "Data.Set"). +-- +-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", +-- Workshop on ML, September 1998, pages 77-86, +-- +-- +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\", +-- Journal of the ACM, 15(4), October 1968, pages 514-534. +-- +-- Additionally, this implementation places bitmaps in the leaves of the tree. +-- Their size is the natural size of a machine word (32 or 64 bits) and greatly +-- reduces the memory footprint and execution times for dense sets, e.g. sets +-- where it is likely that many values lie close to each other. The asymptotics +-- are not affected by this optimization. +-- +----------------------------------------------------------------------------- + +module GHC.Data.Word64Set ( + -- * Strictness properties + -- $strictness + + -- * Set type + Word64Set -- instance Eq,Show + , Key + + -- * Construction + , empty + , singleton + , fromList + , fromAscList + , fromDistinctAscList + + -- * Insertion + , insert + + -- * Deletion + , delete + + -- * Generalized insertion/deletion + , alterF + + -- * Query + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + , WS.null + , size + , isSubsetOf + , isProperSubsetOf + , disjoint + + -- * Combine + , union + , unions + , difference + , (\\) + , intersection + + -- * Filter + , WS.filter + , partition + + , takeWhileAntitone + , dropWhileAntitone + , spanAntitone + + , split + , splitMember + , splitRoot + + -- * Map + , WS.map + , mapMonotonic + + -- * Folds + , WS.foldr + , WS.foldl + -- ** Strict folds + , foldr' + , foldl' + -- ** Legacy folds + , fold + + -- * Min\/Max + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , maxView + , minView + + -- * Conversion + + -- ** List + , elems + , toList + , toAscList + , toDescList + + -- * Debugging + , showTree + , showTreeWith + + ) where + +import GHC.Data.Word64Set.Internal as WS + +-- $strictness +-- +-- This module satisfies the following strictness property: +-- +-- * Key arguments are evaluated to WHNF +-- +-- Here are some examples that illustrate the property: +-- +-- > delete undefined s == undefined diff --git a/GHC/Data/Word64Set/Internal.hs b/GHC/Data/Word64Set/Internal.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Word64Set/Internal.hs @@ -0,0 +1,1613 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_HADDOCK not-home #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Word64Set.Internal +-- Copyright : (c) Daan Leijen 2002 +-- (c) Joachim Breitner 2011 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. +-- +-- = Description +-- +-- An efficient implementation of integer sets. +-- +-- These modules are intended to be imported qualified, to avoid name +-- clashes with Prelude functions, e.g. +-- +-- > import Data.Word64Set (Word64Set) +-- > import qualified Data.Word64Set as Word64Set +-- +-- The implementation is based on /big-endian patricia trees/. This data +-- structure performs especially well on binary operations like 'union' +-- and 'intersection'. However, my benchmarks show that it is also +-- (much) faster on insertions and deletions when compared to a generic +-- size-balanced set implementation (see "Data.Set"). +-- +-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", +-- Workshop on ML, September 1998, pages 77-86, +-- +-- +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\", +-- Journal of the ACM, 15(4), October 1968, pages 514-534. +-- +-- Additionally, this implementation places bitmaps in the leaves of the tree. +-- Their size is the natural size of a machine word (32 or 64 bits) and greatly +-- reduce memory footprint and execution times for dense sets, e.g. sets where +-- it is likely that many values lie close to each other. The asymptotics are +-- not affected by this optimization. +-- +-- Many operations have a worst-case complexity of \(O(\min(n,W))\). +-- This means that the operation can become linear in the number of +-- elements with a maximum of \(W\) -- the number of bits in an 'Int' +-- (32 or 64). +-- +-- @since 0.5.9 +----------------------------------------------------------------------------- + +-- [Note: INLINE bit fiddling] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- It is essential that the bit fiddling functions like mask, zero, branchMask +-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC +-- usually gets it right, but it is disastrous if it does not. Therefore we +-- explicitly mark these functions INLINE. + + +-- [Note: Local 'go' functions and capturing] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Care must be taken when using 'go' function which captures an argument. +-- Sometimes (for example when the argument is passed to a data constructor, +-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code +-- must be checked for increased allocation when creating and modifying such +-- functions. + + +-- [Note: Order of constructors] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The order of constructors of Word64Set matters when considering performance. +-- Currently in GHC 7.0, when type has 3 constructors, they are matched from +-- the first to the last -- the best performance is achieved when the +-- constructors are ordered by frequency. +-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil +-- improves the benchmark by circa 10%. + +module GHC.Data.Word64Set.Internal ( + -- * Set type + Word64Set(..), Key -- instance Eq,Show + , Prefix, Mask, BitMap + + -- * Operators + , (\\) + + -- * Query + , null + , size + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + , isSubsetOf + , isProperSubsetOf + , disjoint + + -- * Construction + , empty + , singleton + , insert + , delete + , alterF + + -- * Combine + , union + , unions + , difference + , intersection + + -- * Filter + , filter + , partition + + , takeWhileAntitone + , dropWhileAntitone + , spanAntitone + + , split + , splitMember + , splitRoot + + -- * Map + , map + , mapMonotonic + + -- * Folds + , foldr + , foldl + -- ** Strict folds + , foldr' + , foldl' + -- ** Legacy folds + , fold + + -- * Min\/Max + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , maxView + , minView + + -- * Conversion + + -- ** List + , elems + , toList + , fromList + + -- ** Ordered list + , toAscList + , toDescList + , fromAscList + , fromDistinctAscList + + -- * Debugging + , showTree + , showTreeWith + + -- * Internals + , match + , suffixBitMask + , prefixBitMask + , bitmapOf + , zero + ) where + +import Control.Applicative (Const(..)) +import Control.DeepSeq (NFData(rnf)) +import Data.Bits +import qualified Data.List as List +import Data.Maybe (fromMaybe) +import Data.Semigroup (Semigroup(stimes, (<>)), stimesIdempotentMonoid) +import GHC.Prelude.Basic hiding + (filter, foldr, foldl, foldl', null, map) +import Data.Word ( Word64 ) + +import GHC.Utils.Containers.Internal.BitUtil +import GHC.Utils.Containers.Internal.StrictPair + +import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType) +import qualified Data.Data +import Text.Read + +import qualified GHC.Exts + +import Data.Functor.Identity (Identity(..)) + +infixl 9 \\{-This comment teaches CPP correct behaviour -} + +-- A "Nat" is a 64 bit machine word +type Nat = Word64 + +natFromInt :: Word64 -> Nat +natFromInt = id +{-# INLINE natFromInt #-} + +intFromNat :: Nat -> Word64 +intFromNat = id +{-# INLINE intFromNat #-} + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +-- | \(O(n+m)\). See 'difference'. +(\\) :: Word64Set -> Word64Set -> Word64Set +m1 \\ m2 = difference m1 m2 + +{-------------------------------------------------------------------- + Types +--------------------------------------------------------------------} + +-- | A set of integers. + +-- See Note: Order of constructors +data Word64Set = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !Word64Set !Word64Set +-- Invariant: Nil is never found as a child of Bin. +-- Invariant: The Mask is a power of 2. It is the largest bit position at which +-- two elements of the set differ. +-- Invariant: Prefix is the common high-order bits that all elements share to +-- the left of the Mask bit. +-- Invariant: In Bin prefix mask left right, left consists of the elements that +-- don't have the mask bit set; right is all the elements that do. + | Tip {-# UNPACK #-} !Prefix {-# UNPACK #-} !BitMap +-- Invariant: The Prefix is zero for the last 6 bits. The values of the set +-- represented by a tip are the prefix plus the indices of the set +-- bits in the bit map. + | Nil + +-- A number stored in a set is stored as +-- * Prefix (all but last 6 bits) and +-- * BitMap (last 6 bits stored as a bitmask) +-- Last 6 bits are called a Suffix. + +type Prefix = Word64 +type Mask = Word64 +type BitMap = Word64 +type Key = Word64 + +instance Monoid Word64Set where + mempty = empty + mconcat = unions + mappend = (<>) + +-- | @since 0.5.7 +instance Semigroup Word64Set where + (<>) = union + stimes = stimesIdempotentMonoid + + +{-------------------------------------------------------------------- + A Data instance +--------------------------------------------------------------------} + +-- This instance preserves data abstraction at the cost of inefficiency. +-- We provide limited reflection services for the sake of data abstraction. + +instance Data Word64Set where + gfoldl f z is = z fromList `f` (toList is) + toConstr _ = fromListConstr + gunfold k z c = case constrIndex c of + 1 -> k (z fromList) + _ -> error "gunfold" + dataTypeOf _ = intSetDataType + +fromListConstr :: Constr +fromListConstr = mkConstr intSetDataType "fromList" [] Data.Data.Prefix + +intSetDataType :: DataType +intSetDataType = mkDataType "Data.Word64Set.Internal.Word64Set" [fromListConstr] + + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | \(O(1)\). Is the set empty? +null :: Word64Set -> Bool +null Nil = True +null _ = False +{-# INLINE null #-} + +-- | \(O(n)\). Cardinality of the set. +size :: Word64Set -> Int +size = go 0 + where + go !acc (Bin _ _ l r) = go (go acc l) r + go acc (Tip _ bm) = acc + bitcount 0 bm + go acc Nil = acc + +-- | \(O(\min(n,W))\). Is the value a member of the set? + +-- See Note: Local 'go' functions and capturing. +member :: Key -> Word64Set -> Bool +member !x = go + where + go (Bin p m l r) + | nomatch x p m = False + | zero x m = go l + | otherwise = go r + go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0 + go Nil = False + +-- | \(O(\min(n,W))\). Is the element not in the set? +notMember :: Key -> Word64Set -> Bool +notMember k = not . member k + +-- | \(O(\min(n,W))\). Find largest element smaller than the given one. +-- +-- > lookupLT 3 (fromList [3, 5]) == Nothing +-- > lookupLT 5 (fromList [3, 5]) == Just 3 + +-- See Note: Local 'go' functions and capturing. +lookupLT :: Key -> Word64Set -> Maybe Key +lookupLT !x t = case t of + Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r + _ -> go Nil t + where + go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r + | zero x m = go def l + | otherwise = go l r + go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm + | prefixOf x == kx && maskLT /= 0 = Just $ kx + highestBitSet maskLT + | otherwise = unsafeFindMax def + where maskLT = (bitmapOf x - 1) .&. bm + go def Nil = unsafeFindMax def + + +-- | \(O(\min(n,W))\). Find smallest element greater than the given one. +-- +-- > lookupGT 4 (fromList [3, 5]) == Just 5 +-- > lookupGT 5 (fromList [3, 5]) == Nothing + +-- See Note: Local 'go' functions and capturing. +lookupGT :: Key -> Word64Set -> Maybe Key +lookupGT !x t = case t of + Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r + _ -> go Nil t + where + go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def + | zero x m = go r l + | otherwise = go def r + go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm + | prefixOf x == kx && maskGT /= 0 = Just $ kx + lowestBitSet maskGT + | otherwise = unsafeFindMin def + where maskGT = (- ((bitmapOf x) `shiftLL` 1)) .&. bm + go def Nil = unsafeFindMin def + + +-- | \(O(\min(n,W))\). Find largest element smaller or equal to the given one. +-- +-- > lookupLE 2 (fromList [3, 5]) == Nothing +-- > lookupLE 4 (fromList [3, 5]) == Just 3 +-- > lookupLE 5 (fromList [3, 5]) == Just 5 + +-- See Note: Local 'go' functions and capturing. +lookupLE :: Key -> Word64Set -> Maybe Key +lookupLE !x t = case t of + Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r + _ -> go Nil t + where + go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r + | zero x m = go def l + | otherwise = go l r + go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm + | prefixOf x == kx && maskLE /= 0 = Just $ kx + highestBitSet maskLE + | otherwise = unsafeFindMax def + where maskLE = (((bitmapOf x) `shiftLL` 1) - 1) .&. bm + go def Nil = unsafeFindMax def + + +-- | \(O(\min(n,W))\). Find smallest element greater or equal to the given one. +-- +-- > lookupGE 3 (fromList [3, 5]) == Just 3 +-- > lookupGE 4 (fromList [3, 5]) == Just 5 +-- > lookupGE 6 (fromList [3, 5]) == Nothing + +-- See Note: Local 'go' functions and capturing. +lookupGE :: Key -> Word64Set -> Maybe Key +lookupGE !x t = case t of + Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r + _ -> go Nil t + where + go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def + | zero x m = go r l + | otherwise = go def r + go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm + | prefixOf x == kx && maskGE /= 0 = Just $ kx + lowestBitSet maskGE + | otherwise = unsafeFindMin def + where maskGE = (- (bitmapOf x)) .&. bm + go def Nil = unsafeFindMin def + + + +-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is +-- given, it has m > 0. +unsafeFindMin :: Word64Set -> Maybe Key +unsafeFindMin Nil = Nothing +unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm +unsafeFindMin (Bin _ _ l _) = unsafeFindMin l + +-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is +-- given, it has m > 0. +unsafeFindMax :: Word64Set -> Maybe Key +unsafeFindMax Nil = Nothing +unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm +unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | \(O(1)\). The empty set. +empty :: Word64Set +empty + = Nil +{-# INLINE empty #-} + +-- | \(O(1)\). A set of one element. +singleton :: Key -> Word64Set +singleton x + = Tip (prefixOf x) (bitmapOf x) +{-# INLINE singleton #-} + +{-------------------------------------------------------------------- + Insert +--------------------------------------------------------------------} +-- | \(O(\min(n,W))\). Add a value to the set. There is no left- or right bias for +-- Word64Sets. +insert :: Key -> Word64Set -> Word64Set +insert !x = insertBM (prefixOf x) (bitmapOf x) + +-- Helper function for insert and union. +insertBM :: Prefix -> BitMap -> Word64Set -> Word64Set +insertBM !kx !bm t@(Bin p m l r) + | nomatch kx p m = link kx (Tip kx bm) p t + | zero kx m = Bin p m (insertBM kx bm l) r + | otherwise = Bin p m l (insertBM kx bm r) +insertBM kx bm t@(Tip kx' bm') + | kx' == kx = Tip kx' (bm .|. bm') + | otherwise = link kx (Tip kx bm) kx' t +insertBM kx bm Nil = Tip kx bm + +-- | \(O(\min(n,W))\). Delete a value in the set. Returns the +-- original set when the value was not present. +delete :: Key -> Word64Set -> Word64Set +delete !x = deleteBM (prefixOf x) (bitmapOf x) + +-- Deletes all values mentioned in the BitMap from the set. +-- Helper function for delete and difference. +deleteBM :: Prefix -> BitMap -> Word64Set -> Word64Set +deleteBM !kx !bm t@(Bin p m l r) + | nomatch kx p m = t + | zero kx m = bin p m (deleteBM kx bm l) r + | otherwise = bin p m l (deleteBM kx bm r) +deleteBM kx bm t@(Tip kx' bm') + | kx' == kx = tip kx (bm' .&. complement bm) + | otherwise = t +deleteBM _ _ Nil = Nil + +-- | \(O(\min(n,W))\). @('alterF' f x s)@ can delete or insert @x@ in @s@ depending +-- on whether it is already present in @s@. +-- +-- In short: +-- +-- @ +-- 'member' x \<$\> 'alterF' f x s = f ('member' x s) +-- @ +-- +-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At". +-- +-- @since 0.6.3.1 +alterF :: Functor f => (Bool -> f Bool) -> Key -> Word64Set -> f Word64Set +alterF f k s = fmap choose (f member_) + where + member_ = member k s + + (inserted, deleted) + | member_ = (s , delete k s) + | otherwise = (insert k s, s ) + + choose True = inserted + choose False = deleted +{-# INLINABLE [2] alterF #-} + +{-# RULES +"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s + #-} + +{-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> Word64Set -> Identity Word64Set #-} + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +-- | The union of a list of sets. + +{-# INLINABLE unions #-} +unions :: [Word64Set] -> Word64Set +unions = List.foldl' union empty + +-- | \(O(n+m)\). The union of two sets. +union :: Word64Set -> Word64Set -> Word64Set +union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = union1 + | shorter m2 m1 = union2 + | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2) + | otherwise = link p1 t1 p2 t2 + where + union1 | nomatch p2 p1 m1 = link p1 t1 p2 t2 + | zero p2 m1 = Bin p1 m1 (union l1 t2) r1 + | otherwise = Bin p1 m1 l1 (union r1 t2) + + union2 | nomatch p1 p2 m2 = link p1 t1 p2 t2 + | zero p1 m2 = Bin p2 m2 (union t1 l2) r2 + | otherwise = Bin p2 m2 l2 (union t1 r2) + +union t@(Bin _ _ _ _) (Tip kx bm) = insertBM kx bm t +union t@(Bin _ _ _ _) Nil = t +union (Tip kx bm) t = insertBM kx bm t +union Nil t = t + + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} +-- | \(O(n+m)\). Difference between two sets. +difference :: Word64Set -> Word64Set -> Word64Set +difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = difference1 + | shorter m2 m1 = difference2 + | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2) + | otherwise = t1 + where + difference1 | nomatch p2 p1 m1 = t1 + | zero p2 m1 = bin p1 m1 (difference l1 t2) r1 + | otherwise = bin p1 m1 l1 (difference r1 t2) + + difference2 | nomatch p1 p2 m2 = t1 + | zero p1 m2 = difference t1 l2 + | otherwise = difference t1 r2 + +difference t@(Bin _ _ _ _) (Tip kx bm) = deleteBM kx bm t +difference t@(Bin _ _ _ _) Nil = t + +difference t1@(Tip kx bm) t2 = differenceTip t2 + where differenceTip (Bin p2 m2 l2 r2) | nomatch kx p2 m2 = t1 + | zero kx m2 = differenceTip l2 + | otherwise = differenceTip r2 + differenceTip (Tip kx2 bm2) | kx == kx2 = tip kx (bm .&. complement bm2) + | otherwise = t1 + differenceTip Nil = t1 + +difference Nil _ = Nil + + + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} +-- | \(O(n+m)\). The intersection of two sets. +intersection :: Word64Set -> Word64Set -> Word64Set +intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = intersection1 + | shorter m2 m1 = intersection2 + | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2) + | otherwise = Nil + where + intersection1 | nomatch p2 p1 m1 = Nil + | zero p2 m1 = intersection l1 t2 + | otherwise = intersection r1 t2 + + intersection2 | nomatch p1 p2 m2 = Nil + | zero p1 m2 = intersection t1 l2 + | otherwise = intersection t1 r2 + +intersection t1@(Bin _ _ _ _) (Tip kx2 bm2) = intersectBM t1 + where intersectBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = Nil + | zero kx2 m1 = intersectBM l1 + | otherwise = intersectBM r1 + intersectBM (Tip kx1 bm1) | kx1 == kx2 = tip kx1 (bm1 .&. bm2) + | otherwise = Nil + intersectBM Nil = Nil + +intersection (Bin _ _ _ _) Nil = Nil + +intersection (Tip kx1 bm1) t2 = intersectBM t2 + where intersectBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = Nil + | zero kx1 m2 = intersectBM l2 + | otherwise = intersectBM r2 + intersectBM (Tip kx2 bm2) | kx1 == kx2 = tip kx1 (bm1 .&. bm2) + | otherwise = Nil + intersectBM Nil = Nil + +intersection Nil _ = Nil + +{-------------------------------------------------------------------- + Subset +--------------------------------------------------------------------} +-- | \(O(n+m)\). Is this a proper subset? (ie. a subset but not equal). +isProperSubsetOf :: Word64Set -> Word64Set -> Bool +isProperSubsetOf t1 t2 + = case subsetCmp t1 t2 of + LT -> True + _ -> False + +subsetCmp :: Word64Set -> Word64Set -> Ordering +subsetCmp t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + | shorter m1 m2 = GT + | shorter m2 m1 = case subsetCmpLt of + GT -> GT + _ -> LT + | p1 == p2 = subsetCmpEq + | otherwise = GT -- disjoint + where + subsetCmpLt | nomatch p1 p2 m2 = GT + | zero p1 m2 = subsetCmp t1 l2 + | otherwise = subsetCmp t1 r2 + subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of + (GT,_ ) -> GT + (_ ,GT) -> GT + (EQ,EQ) -> EQ + _ -> LT + +subsetCmp (Bin _ _ _ _) _ = GT +subsetCmp (Tip kx1 bm1) (Tip kx2 bm2) + | kx1 /= kx2 = GT -- disjoint + | bm1 == bm2 = EQ + | bm1 .&. complement bm2 == 0 = LT + | otherwise = GT +subsetCmp t1@(Tip kx _) (Bin p m l r) + | nomatch kx p m = GT + | zero kx m = case subsetCmp t1 l of GT -> GT ; _ -> LT + | otherwise = case subsetCmp t1 r of GT -> GT ; _ -> LT +subsetCmp (Tip _ _) Nil = GT -- disjoint +subsetCmp Nil Nil = EQ +subsetCmp Nil _ = LT + +-- | \(O(n+m)\). Is this a subset? +-- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@. + +isSubsetOf :: Word64Set -> Word64Set -> Bool +isSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + | shorter m1 m2 = False + | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2 + else isSubsetOf t1 r2) + | otherwise = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2 +isSubsetOf (Bin _ _ _ _) _ = False +isSubsetOf (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 .&. complement bm2 == 0 +isSubsetOf t1@(Tip kx _) (Bin p m l r) + | nomatch kx p m = False + | zero kx m = isSubsetOf t1 l + | otherwise = isSubsetOf t1 r +isSubsetOf (Tip _ _) Nil = False +isSubsetOf Nil _ = True + + +{-------------------------------------------------------------------- + Disjoint +--------------------------------------------------------------------} +-- | \(O(n+m)\). Check whether two sets are disjoint (i.e. their intersection +-- is empty). +-- +-- > disjoint (fromList [2,4,6]) (fromList [1,3]) == True +-- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False +-- > disjoint (fromList [1,2]) (fromList [1,2,3,4]) == False +-- > disjoint (fromList []) (fromList []) == True +-- +-- @since 0.5.11 +disjoint :: Word64Set -> Word64Set -> Bool +disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = disjoint1 + | shorter m2 m1 = disjoint2 + | p1 == p2 = disjoint l1 l2 && disjoint r1 r2 + | otherwise = True + where + disjoint1 | nomatch p2 p1 m1 = True + | zero p2 m1 = disjoint l1 t2 + | otherwise = disjoint r1 t2 + + disjoint2 | nomatch p1 p2 m2 = True + | zero p1 m2 = disjoint t1 l2 + | otherwise = disjoint t1 r2 + +disjoint t1@(Bin _ _ _ _) (Tip kx2 bm2) = disjointBM t1 + where disjointBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = True + | zero kx2 m1 = disjointBM l1 + | otherwise = disjointBM r1 + disjointBM (Tip kx1 bm1) | kx1 == kx2 = (bm1 .&. bm2) == 0 + | otherwise = True + disjointBM Nil = True + +disjoint (Bin _ _ _ _) Nil = True + +disjoint (Tip kx1 bm1) t2 = disjointBM t2 + where disjointBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = True + | zero kx1 m2 = disjointBM l2 + | otherwise = disjointBM r2 + disjointBM (Tip kx2 bm2) | kx1 == kx2 = (bm1 .&. bm2) == 0 + | otherwise = True + disjointBM Nil = True + +disjoint Nil _ = True + + +{-------------------------------------------------------------------- + Filter +--------------------------------------------------------------------} +-- | \(O(n)\). Filter all elements that satisfy some predicate. +filter :: (Key -> Bool) -> Word64Set -> Word64Set +filter predicate t + = case t of + Bin p m l r + -> bin p m (filter predicate l) (filter predicate r) + Tip kx bm + -> tip kx (foldl'Bits 0 (bitPred kx) 0 bm) + Nil -> Nil + where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi + | otherwise = bm + {-# INLINE bitPred #-} + +-- | \(O(n)\). partition the set according to some predicate. +partition :: (Key -> Bool) -> Word64Set -> (Word64Set,Word64Set) +partition predicate0 t0 = toPair $ go predicate0 t0 + where + go predicate t + = case t of + Bin p m l r + -> let (l1 :*: l2) = go predicate l + (r1 :*: r2) = go predicate r + in bin p m l1 r1 :*: bin p m l2 r2 + Tip kx bm + -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm + in tip kx bm1 :*: tip kx (bm `xor` bm1) + Nil -> (Nil :*: Nil) + where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi + | otherwise = bm + {-# INLINE bitPred #-} + +-- | \(O(\min(n,W))\). Take while a predicate on the elements holds. +-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@. +-- See note at 'spanAntitone'. +-- +-- @ +-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList' +-- takeWhileAntitone p = 'filter' p +-- @ +-- +-- @since 0.6.7 +takeWhileAntitone :: (Key -> Bool) -> Word64Set -> Word64Set +takeWhileAntitone predicate t = + case t of + Bin p m l r + | m < 0 -> + if predicate 0 -- handle negative numbers. + then bin p m (go predicate l) r + else go predicate r + _ -> go predicate t + where + go predicate' (Bin p m l r) + | predicate' $! p+m = bin p m l (go predicate' r) + | otherwise = go predicate' l + go predicate' (Tip kx bm) = tip kx (takeWhileAntitoneBits kx predicate' bm) + go _ Nil = Nil + +-- | \(O(\min(n,W))\). Drop while a predicate on the elements holds. +-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@. +-- See note at 'spanAntitone'. +-- +-- @ +-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList' +-- dropWhileAntitone p = 'filter' (not . p) +-- @ +-- +-- @since 0.6.7 +dropWhileAntitone :: (Key -> Bool) -> Word64Set -> Word64Set +dropWhileAntitone predicate t = + case t of + Bin p m l r + | m < 0 -> + if predicate 0 -- handle negative numbers. + then go predicate l + else bin p m l (go predicate r) + _ -> go predicate t + where + go predicate' (Bin p m l r) + | predicate' $! p+m = go predicate' r + | otherwise = bin p m (go predicate' l) r + go predicate' (Tip kx bm) = tip kx (bm `xor` takeWhileAntitoneBits kx predicate' bm) + go _ Nil = Nil + +-- | \(O(\min(n,W))\). Divide a set at the point where a predicate on the elements stops holding. +-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@. +-- +-- @ +-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs) +-- spanAntitone p xs = 'partition' p xs +-- @ +-- +-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set +-- at some /unspecified/ point. +-- +-- @since 0.6.7 +spanAntitone :: (Key -> Bool) -> Word64Set -> (Word64Set, Word64Set) +spanAntitone predicate t = + case t of + Bin p m l r + | m < 0 -> + if predicate 0 -- handle negative numbers. + then + case go predicate l of + (lt :*: gt) -> + let !lt' = bin p m lt r + in (lt', gt) + else + case go predicate r of + (lt :*: gt) -> + let !gt' = bin p m l gt + in (lt, gt') + _ -> case go predicate t of + (lt :*: gt) -> (lt, gt) + where + go predicate' (Bin p m l r) + | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt + | otherwise = case go predicate' l of (lt :*: gt) -> lt :*: bin p m gt r + go predicate' (Tip kx bm) = let bm' = takeWhileAntitoneBits kx predicate' bm + in (tip kx bm' :*: tip kx (bm `xor` bm')) + go _ Nil = (Nil :*: Nil) + +-- | \(O(\min(n,W))\). The expression (@'split' x set@) is a pair @(set1,set2)@ +-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@ +-- comprises the elements of @set@ greater than @x@. +-- +-- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5]) +split :: Key -> Word64Set -> (Word64Set,Word64Set) +split x t = + case t of + Bin p m l r + | m < 0 -> + if x >= 0 -- handle negative numbers. + then + case go x l of + (lt :*: gt) -> + let !lt' = bin p m lt r + in (lt', gt) + else + case go x r of + (lt :*: gt) -> + let !gt' = bin p m l gt + in (lt, gt') + _ -> case go x t of + (lt :*: gt) -> (lt, gt) + where + go !x' t'@(Bin p m l r) + | nomatch x' p m = if x' < p then (Nil :*: t') else (t' :*: Nil) + | zero x' m = case go x' l of (lt :*: gt) -> lt :*: bin p m gt r + | otherwise = case go x' r of (lt :*: gt) -> bin p m l lt :*: gt + go x' t'@(Tip kx' bm) + | kx' > x' = (Nil :*: t') + -- equivalent to kx' > prefixOf x' + | kx' < prefixOf x' = (t' :*: Nil) + | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap) + where lowerBitmap = bitmapOf x' - 1 + higherBitmap = complement (lowerBitmap + bitmapOf x') + go _ Nil = (Nil :*: Nil) + +-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot +-- element was found in the original set. +splitMember :: Key -> Word64Set -> (Word64Set,Bool,Word64Set) +splitMember x t = + case t of + Bin p m l r + | m < 0 -> + if x >= 0 -- handle negative numbers. + then + case go x l of + (lt, fnd, gt) -> + let !lt' = bin p m lt r + in (lt', fnd, gt) + else + case go x r of + (lt, fnd, gt) -> + let !gt' = bin p m l gt + in (lt, fnd, gt') + _ -> go x t + where + go x' t'@(Bin p m l r) + | nomatch x' p m = if x' < p then (Nil, False, t') else (t', False, Nil) + | zero x' m = + case go x' l of + (lt, fnd, gt) -> + let !gt' = bin p m gt r + in (lt, fnd, gt') + | otherwise = + case go x' r of + (lt, fnd, gt) -> + let !lt' = bin p m l lt + in (lt', fnd, gt) + go x' t'@(Tip kx' bm) + | kx' > x' = (Nil, False, t') + -- equivalent to kx' > prefixOf x' + | kx' < prefixOf x' = (t', False, Nil) + | otherwise = let !lt = tip kx' (bm .&. lowerBitmap) + !found = (bm .&. bitmapOfx') /= 0 + !gt = tip kx' (bm .&. higherBitmap) + in (lt, found, gt) + where bitmapOfx' = bitmapOf x' + lowerBitmap = bitmapOfx' - 1 + higherBitmap = complement (lowerBitmap + bitmapOfx') + go _ Nil = (Nil, False, Nil) + +{---------------------------------------------------------------------- + Min/Max +----------------------------------------------------------------------} + +-- | \(O(\min(n,W))\). Retrieves the maximal key of the set, and the set +-- stripped of that element, or 'Nothing' if passed an empty set. +maxView :: Word64Set -> Maybe (Key, Word64Set) +maxView t = + case t of Nil -> Nothing + Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, bin p m l' r) + _ -> Just (go t) + where + go (Bin p m l r) = case go r of (result, r') -> (result, bin p m l r') + go (Tip kx bm) = case highestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi))) + go Nil = error "maxView Nil" + +-- | \(O(\min(n,W))\). Retrieves the minimal key of the set, and the set +-- stripped of that element, or 'Nothing' if passed an empty set. +minView :: Word64Set -> Maybe (Key, Word64Set) +minView t = + case t of Nil -> Nothing + Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, bin p m l r') + _ -> Just (go t) + where + go (Bin p m l r) = case go l of (result, l') -> (result, bin p m l' r) + go (Tip kx bm) = case lowestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi))) + go Nil = error "minView Nil" + +-- | \(O(\min(n,W))\). Delete and find the minimal element. +-- +-- > deleteFindMin set = (findMin set, deleteMin set) +deleteFindMin :: Word64Set -> (Key, Word64Set) +deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView + +-- | \(O(\min(n,W))\). Delete and find the maximal element. +-- +-- > deleteFindMax set = (findMax set, deleteMax set) +deleteFindMax :: Word64Set -> (Key, Word64Set) +deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView + + +-- | \(O(\min(n,W))\). The minimal element of the set. +findMin :: Word64Set -> Key +findMin Nil = error "findMin: empty set has no minimal element" +findMin (Tip kx bm) = kx + lowestBitSet bm +findMin (Bin _ m l r) + | m < 0 = find r + | otherwise = find l + where find (Tip kx bm) = kx + lowestBitSet bm + find (Bin _ _ l' _) = find l' + find Nil = error "findMin Nil" + +-- | \(O(\min(n,W))\). The maximal element of a set. +findMax :: Word64Set -> Key +findMax Nil = error "findMax: empty set has no maximal element" +findMax (Tip kx bm) = kx + highestBitSet bm +findMax (Bin _ m l r) + | m < 0 = find l + | otherwise = find r + where find (Tip kx bm) = kx + highestBitSet bm + find (Bin _ _ _ r') = find r' + find Nil = error "findMax Nil" + + +-- | \(O(\min(n,W))\). Delete the minimal element. Returns an empty set if the set is empty. +-- +-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' – +-- versions prior to 0.5 threw an error if the 'Word64Set' was already empty. +deleteMin :: Word64Set -> Word64Set +deleteMin = maybe Nil snd . minView + +-- | \(O(\min(n,W))\). Delete the maximal element. Returns an empty set if the set is empty. +-- +-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' – +-- versions prior to 0.5 threw an error if the 'Word64Set' was already empty. +deleteMax :: Word64Set -> Word64Set +deleteMax = maybe Nil snd . maxView + +{---------------------------------------------------------------------- + Map +----------------------------------------------------------------------} + +-- | \(O(n \min(n,W))\). +-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. +-- +-- It's worth noting that the size of the result may be smaller if, +-- for some @(x,y)@, @x \/= y && f x == f y@ + +map :: (Key -> Key) -> Word64Set -> Word64Set +map f = fromList . List.map f . toList + +-- | \(O(n)\). The +-- +-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing. +-- /The precondition is not checked./ +-- Semi-formally, we have: +-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapMonotonic f s == map f s +-- > where ls = toList s +-- +-- @since 0.6.3.1 + +-- Note that for now the test is insufficient to support any fancier implementation. +mapMonotonic :: (Key -> Key) -> Word64Set -> Word64Set +mapMonotonic f = fromDistinctAscList . List.map f . toAscList + + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | \(O(n)\). Fold the elements in the set using the given right-associative +-- binary operator. This function is an equivalent of 'foldr' and is present +-- for compatibility only. +-- +-- /Please note that fold will be deprecated in the future and removed./ +fold :: (Key -> b -> b) -> b -> Word64Set -> b +fold = foldr +{-# INLINE fold #-} + +-- | \(O(n)\). Fold the elements in the set using the given right-associative +-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@. +-- +-- For example, +-- +-- > toAscList set = foldr (:) [] set +foldr :: (Key -> b -> b) -> b -> Word64Set -> b +foldr f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before + | otherwise -> go (go z r) l + _ -> go z t + where + go z' Nil = z' + go z' (Tip kx bm) = foldrBits kx f z' bm + go z' (Bin _ _ l r) = go (go z' r) l +{-# INLINE foldr #-} + +-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldr' :: (Key -> b -> b) -> b -> Word64Set -> b +foldr' f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before + | otherwise -> go (go z r) l + _ -> go z t + where + go !z' Nil = z' + go z' (Tip kx bm) = foldr'Bits kx f z' bm + go z' (Bin _ _ l r) = go (go z' r) l +{-# INLINE foldr' #-} + +-- | \(O(n)\). Fold the elements in the set using the given left-associative +-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@. +-- +-- For example, +-- +-- > toDescList set = foldl (flip (:)) [] set +foldl :: (a -> Key -> a) -> a -> Word64Set -> a +foldl f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before + | otherwise -> go (go z l) r + _ -> go z t + where + go z' Nil = z' + go z' (Tip kx bm) = foldlBits kx f z' bm + go z' (Bin _ _ l r) = go (go z' l) r +{-# INLINE foldl #-} + +-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldl' :: (a -> Key -> a) -> a -> Word64Set -> a +foldl' f z = \t -> -- Use lambda t to be inlinable with two arguments only. + case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before + | otherwise -> go (go z l) r + _ -> go z t + where + go !z' Nil = z' + go z' (Tip kx bm) = foldl'Bits kx f z' bm + go z' (Bin _ _ l r) = go (go z' l) r +{-# INLINE foldl' #-} + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order. +-- Subject to list fusion. +elems :: Word64Set -> [Key] +elems + = toAscList + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} + +-- | @since 0.5.6.2 +instance GHC.Exts.IsList Word64Set where + type Item Word64Set = Key + fromList = fromList + toList = toList + +-- | \(O(n)\). Convert the set to a list of elements. Subject to list fusion. +toList :: Word64Set -> [Key] +toList + = toAscList + +-- | \(O(n)\). Convert the set to an ascending list of elements. Subject to list +-- fusion. +toAscList :: Word64Set -> [Key] +toAscList = foldr (:) [] + +-- | \(O(n)\). Convert the set to a descending list of elements. Subject to list +-- fusion. +toDescList :: Word64Set -> [Key] +toDescList = foldl (flip (:)) [] + +-- List fusion for the list generating functions. +-- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion. +-- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude. +foldrFB :: (Key -> b -> b) -> b -> Word64Set -> b +foldrFB = foldr +{-# INLINE[0] foldrFB #-} +foldlFB :: (a -> Key -> a) -> a -> Word64Set -> a +foldlFB = foldl +{-# INLINE[0] foldlFB #-} + +-- Inline elems and toList, so that we need to fuse only toAscList. +{-# INLINE elems #-} +{-# INLINE toList #-} + +-- The fusion is enabled up to phase 2 included. If it does not succeed, +-- convert in phase 1 the expanded to{Asc,Desc}List calls back to +-- to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were used in +-- a list fusion, otherwise it would go away in phase 1), and let compiler do +-- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it +-- before phase 0, otherwise the fusion rules would not fire at all. +{-# NOINLINE[0] toAscList #-} +{-# NOINLINE[0] toDescList #-} +{-# RULES "Word64Set.toAscList" [~1] forall s . toAscList s = GHC.Exts.build (\c n -> foldrFB c n s) #-} +{-# RULES "Word64Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-} +{-# RULES "Word64Set.toDescList" [~1] forall s . toDescList s = GHC.Exts.build (\c n -> foldlFB (\xs x -> c x xs) n s) #-} +{-# RULES "Word64Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-} + + +-- | \(O(n \min(n,W))\). Create a set from a list of integers. +{-# INLINABLE fromList #-} +fromList :: [Key] -> Word64Set +fromList = List.foldl' ins empty + where + ins t x = insert x t + +-- | \(O(n)\). Build a set from an ascending list of elements. +-- /The precondition (input list is ascending) is not checked./ +fromAscList :: [Key] -> Word64Set +fromAscList = fromMonoList +{-# NOINLINE fromAscList #-} + +-- | \(O(n)\). Build a set from an ascending list of distinct elements. +-- /The precondition (input list is strictly ascending) is not checked./ +fromDistinctAscList :: [Key] -> Word64Set +fromDistinctAscList = fromAscList +{-# INLINE fromDistinctAscList #-} + +-- | \(O(n)\). Build a set from a monotonic list of elements. +-- +-- The precise conditions under which this function works are subtle: +-- For any branch mask, keys with the same prefix w.r.t. the branch +-- mask must occur consecutively in the list. +fromMonoList :: [Key] -> Word64Set +fromMonoList [] = Nil +fromMonoList (kx : zs1) = addAll' (prefixOf kx) (bitmapOf kx) zs1 + where + -- `addAll'` collects all keys with the prefix `px` into a single + -- bitmap, and then proceeds with `addAll`. + addAll' !px !bm [] + = Tip px bm + addAll' !px !bm (ky : zs) + | px == prefixOf ky + = addAll' px (bm .|. bitmapOf ky) zs + -- inlined: | otherwise = addAll px (Tip px bm) (ky : zs) + | py <- prefixOf ky + , m <- branchMask px py + , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs + = addAll px (linkWithMask m py ty {-px-} (Tip px bm)) zs' + + -- for `addAll` and `addMany`, px is /a/ prefix inside the tree `tx` + -- `addAll` consumes the rest of the list, adding to the tree `tx` + addAll !_px !tx [] + = tx + addAll !px !tx (ky : zs) + | py <- prefixOf ky + , m <- branchMask px py + , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs + = addAll px (linkWithMask m py ty {-px-} tx) zs' + + -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. + addMany' !_m !px !bm [] + = Inserted (Tip px bm) [] + addMany' !m !px !bm zs0@(ky : zs) + | px == prefixOf ky + = addMany' m px (bm .|. bitmapOf ky) zs + -- inlined: | otherwise = addMany m px (Tip px bm) (ky : zs) + | mask px m /= mask ky m + = Inserted (Tip (prefixOf px) bm) zs0 + | py <- prefixOf ky + , mxy <- branchMask px py + , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs + = addMany m px (linkWithMask mxy py ty {-px-} (Tip px bm)) zs' + + -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `px`. + addMany !_m !_px tx [] + = Inserted tx [] + addMany !m !px tx zs0@(ky : zs) + | mask px m /= mask ky m + = Inserted tx zs0 + | py <- prefixOf ky + , mxy <- branchMask px py + , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs + = addMany m px (linkWithMask mxy py ty {-px-} tx) zs' +{-# INLINE fromMonoList #-} + +data Inserted = Inserted !Word64Set ![Key] + +{-------------------------------------------------------------------- + Eq +--------------------------------------------------------------------} +instance Eq Word64Set where + t1 == t2 = equal t1 t2 + t1 /= t2 = nequal t1 t2 + +equal :: Word64Set -> Word64Set -> Bool +equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) +equal (Tip kx1 bm1) (Tip kx2 bm2) + = kx1 == kx2 && bm1 == bm2 +equal Nil Nil = True +equal _ _ = False + +nequal :: Word64Set -> Word64Set -> Bool +nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) +nequal (Tip kx1 bm1) (Tip kx2 bm2) + = kx1 /= kx2 || bm1 /= bm2 +nequal Nil Nil = False +nequal _ _ = True + +{-------------------------------------------------------------------- + Ord +--------------------------------------------------------------------} + +instance Ord Word64Set where + compare s1 s2 = compare (toAscList s1) (toAscList s2) + -- tentative implementation. See if more efficient exists. + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance Show Word64Set where + showsPrec p xs = showParen (p > 10) $ + showString "fromList " . shows (toList xs) + +{-------------------------------------------------------------------- + Read +--------------------------------------------------------------------} +instance Read Word64Set where + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- readPrec + return (fromList xs) + + readListPrec = readListPrecDefault + +{-------------------------------------------------------------------- + NFData +--------------------------------------------------------------------} + +-- The Word64Set constructors consist only of strict fields of Ints and +-- Word64Sets, thus the default NFData instance which evaluates to whnf +-- should suffice +instance NFData Word64Set where rnf x = seq x () + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | \(O(n \min(n,W))\). Show the tree that implements the set. The tree is shown +-- in a compressed, hanging format. +showTree :: Word64Set -> String +showTree s + = showTreeWith True False s + + +{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows + the tree that implements the set. If @hang@ is + 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If + @wide@ is 'True', an extra wide version is shown. +-} +showTreeWith :: Bool -> Bool -> Word64Set -> String +showTreeWith hang wide t + | hang = (showsTreeHang wide [] t) "" + | otherwise = (showsTree wide [] [] t) "" + +showsTree :: Bool -> [String] -> [String] -> Word64Set -> ShowS +showsTree wide lbars rbars t + = case t of + Bin p m l r + -> showsTree wide (withBar rbars) (withEmpty rbars) r . + showWide wide rbars . + showsBars lbars . showString (showBin p m) . showString "\n" . + showWide wide lbars . + showsTree wide (withEmpty lbars) (withBar lbars) l + Tip kx bm + -> showsBars lbars . showString " " . shows kx . showString " + " . + showsBitMap bm . showString "\n" + Nil -> showsBars lbars . showString "|\n" + +showsTreeHang :: Bool -> [String] -> Word64Set -> ShowS +showsTreeHang wide bars t + = case t of + Bin p m l r + -> showsBars bars . showString (showBin p m) . showString "\n" . + showWide wide bars . + showsTreeHang wide (withBar bars) l . + showWide wide bars . + showsTreeHang wide (withEmpty bars) r + Tip kx bm + -> showsBars bars . showString " " . shows kx . showString " + " . + showsBitMap bm . showString "\n" + Nil -> showsBars bars . showString "|\n" + +showBin :: Prefix -> Mask -> String +showBin _ _ + = "*" -- ++ show (p,m) + +showWide :: Bool -> [String] -> String -> String +showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id + +showsBars :: [String] -> ShowS +showsBars [] = id +showsBars (_ : tl) = showString (concat (reverse tl)) . showString node + +showsBitMap :: Word64 -> ShowS +showsBitMap = showString . showBitMap + +showBitMap :: Word64 -> String +showBitMap w = show $ foldrBits 0 (:) [] w + +node :: String +node = "+--" + +withBar, withEmpty :: [String] -> [String] +withBar bars = "| ":bars +withEmpty bars = " ":bars + + +{-------------------------------------------------------------------- + Helpers +--------------------------------------------------------------------} +{-------------------------------------------------------------------- + Link +--------------------------------------------------------------------} +link :: Prefix -> Word64Set -> Prefix -> Word64Set -> Word64Set +link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2 +{-# INLINE link #-} + +-- `linkWithMask` is useful when the `branchMask` has already been computed +linkWithMask :: Mask -> Prefix -> Word64Set -> Word64Set -> Word64Set +linkWithMask m p1 t1 {-p2-} t2 + | zero p1 m = Bin p m t1 t2 + | otherwise = Bin p m t2 t1 + where + p = mask p1 m +{-# INLINE linkWithMask #-} + +{-------------------------------------------------------------------- + @bin@ assures that we never have empty trees within a tree. +--------------------------------------------------------------------} +bin :: Prefix -> Mask -> Word64Set -> Word64Set -> Word64Set +bin _ _ l Nil = l +bin _ _ Nil r = r +bin p m l r = Bin p m l r +{-# INLINE bin #-} + +{-------------------------------------------------------------------- + @tip@ assures that we never have empty bitmaps within a tree. +--------------------------------------------------------------------} +tip :: Prefix -> BitMap -> Word64Set +tip _ 0 = Nil +tip kx bm = Tip kx bm +{-# INLINE tip #-} + + +{---------------------------------------------------------------------- + Functions that generate Prefix and BitMap of a Key or a Suffix. +----------------------------------------------------------------------} + +suffixBitMask :: Word64 +suffixBitMask = fromIntegral (finiteBitSize (undefined::Word64)) - 1 +{-# INLINE suffixBitMask #-} + +prefixBitMask :: Word64 +prefixBitMask = complement suffixBitMask +{-# INLINE prefixBitMask #-} + +prefixOf :: Word64 -> Prefix +prefixOf x = x .&. prefixBitMask +{-# INLINE prefixOf #-} + +suffixOf :: Word64 -> Word64 +suffixOf x = x .&. suffixBitMask +{-# INLINE suffixOf #-} + +bitmapOfSuffix :: Word64 -> BitMap +bitmapOfSuffix s = 1 `shiftLL` fromIntegral s +{-# INLINE bitmapOfSuffix #-} + +bitmapOf :: Word64 -> BitMap +bitmapOf x = bitmapOfSuffix (suffixOf x) +{-# INLINE bitmapOf #-} + + +{-------------------------------------------------------------------- + Endian independent bit twiddling +--------------------------------------------------------------------} +-- Returns True iff the bits set in i and the Mask m are disjoint. +zero :: Word64 -> Mask -> Bool +zero i m + = (natFromInt i) .&. (natFromInt m) == 0 +{-# INLINE zero #-} + +nomatch,match :: Word64 -> Prefix -> Mask -> Bool +nomatch i p m + = (mask i m) /= p +{-# INLINE nomatch #-} + +match i p m + = (mask i m) == p +{-# INLINE match #-} + +-- Suppose a is largest such that 2^a divides 2*m. +-- Then mask i m is i with the low a bits zeroed out. +mask :: Word64 -> Mask -> Prefix +mask i m + = maskW (natFromInt i) (natFromInt m) +{-# INLINE mask #-} + +{-------------------------------------------------------------------- + Big endian operations +--------------------------------------------------------------------} +maskW :: Nat -> Nat -> Prefix +maskW i m + = intFromNat (i .&. (complement (m-1) `xor` m)) +{-# INLINE maskW #-} + +shorter :: Mask -> Mask -> Bool +shorter m1 m2 + = (natFromInt m1) > (natFromInt m2) +{-# INLINE shorter #-} + +branchMask :: Prefix -> Prefix -> Mask +branchMask p1 p2 + = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2)) +{-# INLINE branchMask #-} + +{---------------------------------------------------------------------- + To get best performance, we provide fast implementations of + lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC. + If the intel bsf and bsr instructions ever become GHC primops, + this code should be reimplemented using these. + + Performance of this code is crucial for folds, toList, filter, partition. + + The signatures of methods in question are placed after this comment. +----------------------------------------------------------------------} + +lowestBitSet :: Nat -> Word64 +highestBitSet :: Nat -> Word64 +foldlBits :: Word64 -> (a -> Word64 -> a) -> a -> Nat -> a +foldl'Bits :: Word64 -> (a -> Word64 -> a) -> a -> Nat -> a +foldrBits :: Word64 -> (Word64 -> a -> a) -> a -> Nat -> a +foldr'Bits :: Word64 -> (Word64 -> a -> a) -> a -> Nat -> a +takeWhileAntitoneBits :: Word64 -> (Word64 -> Bool) -> Nat -> Nat + +{-# INLINE lowestBitSet #-} +{-# INLINE highestBitSet #-} +{-# INLINE foldlBits #-} +{-# INLINE foldl'Bits #-} +{-# INLINE foldrBits #-} +{-# INLINE foldr'Bits #-} +{-# INLINE takeWhileAntitoneBits #-} + +indexOfTheOnlyBit :: Nat -> Word64 +{-# INLINE indexOfTheOnlyBit #-} +indexOfTheOnlyBit bitmask = fromIntegral $ countTrailingZeros bitmask + +lowestBitSet x = fromIntegral $ countTrailingZeros x + +highestBitSet x = fromIntegral $ 63 - countLeadingZeros x + +lowestBitMask :: Nat -> Nat +lowestBitMask x = x .&. negate x +{-# INLINE lowestBitMask #-} + +-- Reverse the order of bits in the Nat. +revNat :: Nat -> Nat +revNat x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of + x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of + x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of + x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of + x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of + x6 -> ( x6 `shiftRL` 32 ) .|. ( x6 `shiftLL` 32); + +foldlBits prefix f z bitmap = go bitmap z + where go 0 acc = acc + go bm acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi)) + where + !bitmask = lowestBitMask bm + !bi = indexOfTheOnlyBit bitmask + +foldl'Bits prefix f z bitmap = go bitmap z + where go 0 acc = acc + go bm !acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi)) + where !bitmask = lowestBitMask bm + !bi = indexOfTheOnlyBit bitmask + +foldrBits prefix f z bitmap = go (revNat bitmap) z + where go 0 acc = acc + go bm acc = go (bm `xor` bitmask) ((f $! (prefix+63-bi)) acc) + where !bitmask = lowestBitMask bm + !bi = indexOfTheOnlyBit bitmask + + +foldr'Bits prefix f z bitmap = go (revNat bitmap) z + where go 0 acc = acc + go bm !acc = go (bm `xor` bitmask) ((f $! (prefix+63-bi)) acc) + where !bitmask = lowestBitMask bm + !bi = indexOfTheOnlyBit bitmask + +takeWhileAntitoneBits prefix predicate bitmap = + -- Binary search for the first index where the predicate returns false, but skip a predicate + -- call if the high half of the current range is empty. This ensures + -- min (log2 64 + 1 = 7) (popcount bitmap) predicate calls. + let next d h (n',b') = + if n' .&. h /= 0 && (predicate $! prefix + fromIntegral (b'+d)) then (n' `shiftRL` d, b'+d) else (n',b') + {-# INLINE next #-} + (_,b) = next 1 0x2 $ + next 2 0xC $ + next 4 0xF0 $ + next 8 0xFF00 $ + next 16 0xFFFF0000 $ + next 32 0xFFFFFFFF00000000 $ + (bitmap,0) + m = if b /= 0 || (bitmap .&. 0x1 /= 0 && predicate prefix) + then ((2 `shiftLL` b) - 1) + else ((1 `shiftLL` b) - 1) + in bitmap .&. m + + + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} + +-- | \(O(1)\). Decompose a set into pieces based on the structure of the underlying +-- tree. This function is useful for consuming a set in parallel. +-- +-- No guarantee is made as to the sizes of the pieces; an internal, but +-- deterministic process determines this. However, it is guaranteed that the +-- pieces returned will be in ascending order (all elements in the first submap +-- less than all elements in the second, and so on). +-- +-- Examples: +-- +-- > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]] +-- > splitRoot empty == [] +-- +-- Note that the current implementation does not return more than two subsets, +-- but you should not depend on this behaviour because it can change in the +-- future without notice. Also, the current version does not continue +-- splitting all the way to individual singleton sets -- it stops at some +-- point. +splitRoot :: Word64Set -> [Word64Set] +splitRoot Nil = [] +-- NOTE: we don't currently split below Tip, but we could. +splitRoot x@(Tip _ _) = [x] +splitRoot (Bin _ m l r) | m < 0 = [r, l] + | otherwise = [l, r] +{-# INLINE splitRoot #-} diff --git a/GHC/Driver/Backend.hs b/GHC/Driver/Backend.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Backend.hs @@ -0,0 +1,912 @@ +{-# LANGUAGE MultiWayIf, LambdaCase #-} + +{-| +Module : GHC.Driver.Backend +Description : Back ends for code generation + +This module exports the `Backend` type and all the available values +of that type. The type is abstract, and GHC assumes a "closed world": +all the back ends are known and are known here. The compiler driver +chooses a `Backend` value based on how it is asked to generate code. + +A `Backend` value encapsulates the knowledge needed to take Cmm, STG, +or Core and write assembly language to a file. A back end also +provides a function that enables the compiler driver to run an +assembler on the code that is written, if any (the "post-backend +pipeline"). Finally, a back end has myriad /properties/. Properties +mediate interactions between a back end and the rest of the compiler, +especially the driver. Examples include the following: + + * Property `backendValidityOfCImport` says whether the back end can + import foreign C functions. + + * Property `backendForcesOptimization0` says whether the back end can + be used with optimization levels higher than `-O0`. + + * Property `backendCDefs` tells the compiler driver, "if you're using + this back end, then these are the command-line flags you should add + to any invocation of the C compiler." + +These properties are used elsewhere in GHC, primarily in the driver, to +fine-tune operations according to the capabilities of the chosen back +end. You might use a property to make GHC aware of a potential +limitation of certain back ends, or a special feature available only +in certain back ends. If your client code needs to know a fact that +is not exposed in an existing property, you would define and export a +new property. Conditioning client code on the /identity/ or /name/ of +a back end is Not Done. + +For full details, see the documentation of each property. +-} + +module GHC.Driver.Backend + ( -- * The @Backend@ type + Backend -- note: type is abstract + -- * Available back ends + , ncgBackend + , llvmBackend + , jsBackend + , viaCBackend + , interpreterBackend + , noBackend + , allBackends + + -- * Types used to specify properties of back ends + , PrimitiveImplementation(..) + -- ** Properties that stand for functions + -- *** Back-end function for code generation + , DefunctionalizedCodeOutput(..) + -- *** Back-end functions for assembly + , DefunctionalizedPostHscPipeline(..) + -- *** Other back-end functions + , DefunctionalizedCDefs(..) + -- ** Names of back ends (for API clients of version 9.4 or earlier) + , BackendName + + + + -- * Properties of back ends + , backendDescription + , backendWritesFiles + , backendPipelineOutput + , backendCanReuseLoadedCode + , backendGeneratesCode + , backendGeneratesCodeForHsBoot + , backendSupportsInterfaceWriting + , backendRespectsSpecialise + , backendWantsGlobalBindings + , backendHasNativeSwitch + , backendPrimitiveImplementation + , backendSimdValidity + , backendSupportsEmbeddedBlobs + , backendNeedsPlatformNcgSupport + , backendSupportsUnsplitProcPoints + , backendSwappableWithViaC + , backendUnregisterisedAbiOnly + , backendGeneratesHc + , backendSptIsDynamic + , backendSupportsBreakpoints + , backendForcesOptimization0 + , backendNeedsFullWays + , backendSpecialModuleSource + , backendSupportsHpc + , backendSupportsCImport + , backendSupportsCExport + , backendCDefs + , backendCodeOutput + , backendUseJSLinker + , backendPostHscPipeline + , backendNormalSuccessorPhase + , backendName + , backendValidityOfCImport + , backendValidityOfCExport + + -- * Other functions of back ends + , platformDefaultBackend + , platformNcgSupported + ) + +where + + +import GHC.Prelude + +import GHC.Driver.Backend.Internal (BackendName(..)) +import GHC.Driver.Phases + + +import GHC.Utils.Error +import GHC.Utils.Panic + +import GHC.Driver.Pipeline.Monad +import GHC.Platform + + +--------------------------------------------------------------------------------- +-- +-- DESIGN CONSIDERATIONS +-- +-- +-- +-- The `Backend` type is made abstract in order to make it possible to +-- add new back ends without having to inspect or modify much code +-- elsewhere in GHC. Adding a new back end would be /easiest/ if +-- `Backend` were represented as a record type, but in peer review, +-- the clear will of the majority was to use a sum type. As a result, +-- when adding a new back end it is necessary to modify /every/ +-- function in this module that expects `Backend` as its first argument. +-- **By design, these functions have no default/wildcard cases.** This +-- design forces the author of a new back end to consider the semantics +-- in every case, rather than relying on a default that may be wrong. +-- The names and documentation of the functions defined in the `Backend` +-- record are sufficiently descriptive that the author of a new back +-- end will be able to identify correct result values without having to go +-- spelunking throughout the compiler. +-- +-- While the design localizes /most/ back-end logic in this module, +-- the author of a new back end will still have to make changes +-- elsewhere in the compiler: +-- +-- * For reasons described in Note [Backend Defunctionalization], +-- code-generation and post-backend pipeline functions, among other +-- functions, cannot be placed in the `Backend` record itself. +-- Instead, the /names/ of those functions are placed. Each name is +-- a value constructor in one of the algebraic data types defined in +-- this module. The named function is then defined near its point +-- of use. +-- +-- The author of a new back end will have to consider whether an +-- existing function will do or whether a new function needs to be +-- defined. When a new function needs to be defined, the author +-- must take two steps: +-- +-- - Add a value constructor to the relevant data type here +-- in the `Backend` module +-- +-- - Add a case to the location in the compiler (there should be +-- exactly one) where the value constructors of the relevant +-- data type are used +-- +-- * When a new back end is defined, it's quite possible that the +-- compiler driver will have to be changed in some way. Just because +-- the driver supports five back ends doesn't mean it will support a sixth +-- without changes. +-- +-- The collection of functions exported from this module hasn't +-- really been "designed"; it's what emerged from a refactoring of +-- older code. The real design criterion was "make it crystal clear +-- what has to be done to add a new back end." +-- +-- One issue remains unresolved: some of the error messages and +-- warning messages used in the driver assume a "closed world": they +-- think they know all the back ends that exist, and they are not shy +-- about enumerating them. Just one set of error messages has been +-- ported to have an open-world assumption: these are the error +-- messages associated with type checking of foreign imports and +-- exports. To allow other errors to be issued with an open-world +-- assumption, use functions `backendValidityOfCImport` and +-- `backendValidityOfCExport` as models, and have a look at how the +-- 'expected back ends' are used in modules "GHC.Tc.Gen.Foreign" and +-- "GHC.Tc.Errors.Ppr" +-- +--------------------------------------------------------------------------------- + + +platformDefaultBackend :: Platform -> Backend +platformDefaultBackend platform = if + | platformUnregisterised platform -> viaCBackend + | platformNcgSupported platform -> ncgBackend + | platformJSSupported platform -> jsBackend + | otherwise -> llvmBackend + +-- | Is the platform supported by the Native Code Generator? +platformNcgSupported :: Platform -> Bool +platformNcgSupported platform = if + | platformUnregisterised platform -> False -- NCG doesn't support unregisterised ABI + | ncgValidArch -> True + | otherwise -> False + where + ncgValidArch = case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + ArchPPC -> True + ArchPPC_64 {} -> True + ArchAArch64 -> True + ArchWasm32 -> True + ArchRISCV64 -> True + ArchLoongArch64 -> True + _ -> False + +-- | Is the platform supported by the JS backend? +platformJSSupported :: Platform -> Bool +platformJSSupported platform + | platformArch platform == ArchJavaScript = True + | otherwise = False + + +-- | A value of type @Backend@ represents one of GHC's back ends. +-- The set of back ends cannot be extended except by modifying the +-- definition of @Backend@ in this module. +-- +-- The @Backend@ type is abstract; that is, its value constructors are +-- not exported. It's crucial that they not be exported, because a +-- value of type @Backend@ carries only the back end's /name/, not its +-- behavior or properties. If @Backend@ were not abstract, then code +-- elsewhere in the compiler could depend directly on the name, not on +-- the semantics, which would make it challenging to create a new back end. +-- Because @Backend@ /is/ abstract, all the obligations of a new back +-- end are enumerated in this module, in the form of functions that +-- take @Backend@ as an argument. +-- +-- The issue of abstraction is discussed at great length in #20927 and !7442. + + +newtype Backend = Named BackendName + -- Must be a newtype so that it has no `Eq` instance and + -- a different `Show` instance. + +-- | The Show instance is for messages /only/. If code depends on +-- what's in the string, you deserve what happens to you. + +instance Show Backend where + show = backendDescription + + +ncgBackend, llvmBackend, viaCBackend, interpreterBackend, jsBackend, noBackend + :: Backend + +-- | The native code generator. +-- Compiles Cmm code into textual assembler, then relies on +-- an external assembler toolchain to produce machine code. +-- +-- Only supports a few platforms (X86, PowerPC, SPARC). +-- +-- See "GHC.CmmToAsm". +ncgBackend = Named NCG + +-- | The LLVM backend. +-- +-- Compiles Cmm code into LLVM textual IR, then relies on +-- LLVM toolchain to produce machine code. +-- +-- It relies on LLVM support for the calling convention used +-- by the NCG backend to produce code objects ABI compatible +-- with it (see "cc 10" or "ghccc" calling convention in +-- https://llvm.org/docs/LangRef.html#calling-conventions). +-- +-- Supports a few platforms (X86, AArch64, s390x, ARM). +-- +-- See "GHC.CmmToLlvm" +llvmBackend = Named LLVM + +-- | The JavaScript Backend +-- +-- See documentation in GHC.StgToJS +jsBackend = Named JavaScript + +-- | Via-C ("unregisterised") backend. +-- +-- Compiles Cmm code into C code, then relies on a C compiler +-- to produce machine code. +-- +-- It produces code objects that are /not/ ABI compatible +-- with those produced by NCG and LLVM backends. +-- +-- Produced code is expected to be less efficient than the +-- one produced by NCG and LLVM backends because STG +-- registers are not pinned into real registers. On the +-- other hand, it supports more target platforms (those +-- having a valid C toolchain). +-- +-- See "GHC.CmmToC" +viaCBackend = Named ViaC + +-- | The ByteCode interpreter. +-- +-- Produce ByteCode objects (BCO, see "GHC.ByteCode") that +-- can be interpreted. It is used by GHCi. +-- +-- Currently some extensions are not supported +-- (foreign primops). +-- +-- See "GHC.StgToByteCode" +interpreterBackend = Named Interpreter + +-- | A dummy back end that generates no code. +-- +-- Use this back end to disable code generation. It is particularly +-- useful when GHC is used as a library for other purpose than +-- generating code (e.g. to generate documentation with Haddock) or +-- when the user requested it (via `-fno-code`) for some reason. +noBackend = Named NoBackend + +--------------------------------------------------------------------------------- + + + + +-- | This enumeration type specifies how the back end wishes GHC's +-- primitives to be implemented. (Module "GHC.StgToCmm.Prim" provides +-- a generic implementation of every primitive, but some primitives, +-- like `IntQuotRemOp`, can be implemented more efficiently by +-- certain back ends on certain platforms. For example, by using a +-- machine instruction that simultaneously computes quotient and remainder.) +-- +-- For the meaning of each alternative, consult +-- "GHC.StgToCmm.Config". (In a perfect world, type +-- `PrimitiveImplementation` would be defined there, in the module +-- that determines its meaning. But I could not figure out how to do +-- it without mutual recursion across module boundaries.) + +data PrimitiveImplementation + = LlvmPrimitives -- ^ Primitives supported by LLVM + | NcgPrimitives -- ^ Primitives supported by the native code generator + | JSPrimitives -- ^ Primitives supported by JS backend + | GenericPrimitives -- ^ Primitives supported by all back ends + deriving Show + + +-- | Names a function that generates code and writes the results to a +-- file, of this type: +-- +-- > Logger +-- > -> DynFlags +-- > -> Module -- ^ module being compiled +-- > -> ModLocation +-- > -> FilePath -- ^ Where to write output +-- > -> Set UnitId -- ^ dependencies +-- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` +-- > -> IO a +-- +-- The functions so named are defined in "GHC.Driver.CodeOutput". +-- +-- We expect one function per back end—or more precisely, one function +-- for each back end that writes code to a file. (The interpreter +-- does not write to files; its output lives only in memory.) + +data DefunctionalizedCodeOutput + = NcgCodeOutput + | ViaCCodeOutput + | LlvmCodeOutput + | JSCodeOutput + + +-- | Names a function that tells the driver what should happen after +-- assembly code is written. This might include running a C compiler, +-- running LLVM, running an assembler, or various similar activities. +-- The function named normally has this type: +-- +-- > TPipelineClass TPhase m +-- > => PipeEnv +-- > -> HscEnv +-- > -> Maybe ModLocation +-- > -> FilePath +-- > -> m (Maybe FilePath) +-- +-- The functions so named are defined in "GHC.Driver.Pipeline". + +data DefunctionalizedPostHscPipeline + = NcgPostHscPipeline + | ViaCPostHscPipeline + | LlvmPostHscPipeline + | JSPostHscPipeline + | NoPostHscPipeline -- ^ After code generation, nothing else need happen. + +-- | Names a function that tells the driver what command-line options +-- to include when invoking a C compiler. It's meant for @-D@ options that +-- define symbols for the C preprocessor. Because the exact symbols +-- defined might depend on versions of tools located in the file +-- system (/cough/ LLVM /cough/), the function requires an `IO` action. +-- The function named has this type: +-- +-- > Logger -> DynFlags -> IO [String] + +data DefunctionalizedCDefs + = NoCDefs -- ^ No additional command-line options are needed + + | LlvmCDefs -- ^ Return command-line options that tell GHC about the + -- LLVM version. + +--------------------------------------------------------------------------------- + + + +-- | An informal description of the back end, for use in +-- issuing warning messages /only/. If code depends on +-- what's in the string, you deserve what happens to you. +backendDescription :: Backend -> String +backendDescription (Named NCG) = "native code generator" +backendDescription (Named LLVM) = "LLVM" +backendDescription (Named ViaC) = "compiling via C" +backendDescription (Named JavaScript) = "compiling to JavaScript" +backendDescription (Named Interpreter) = "byte-code interpreter" +backendDescription (Named NoBackend) = "no code generated" + +-- | This flag tells the compiler driver whether the back +-- end will write files: interface files and object files. +-- It is typically true for "real" back ends that generate +-- code into the filesystem. (That means, not the interpreter.) +backendWritesFiles :: Backend -> Bool +backendWritesFiles (Named NCG) = True +backendWritesFiles (Named LLVM) = True +backendWritesFiles (Named ViaC) = True +backendWritesFiles (Named JavaScript) = True +backendWritesFiles (Named Interpreter) = False +backendWritesFiles (Named NoBackend) = False + +-- | When the back end does write files, this value tells +-- the compiler in what manner of file the output should go: +-- temporary, persistent, or specific. +backendPipelineOutput :: Backend -> PipelineOutput +backendPipelineOutput (Named NCG) = Persistent +backendPipelineOutput (Named LLVM) = Persistent +backendPipelineOutput (Named ViaC) = Persistent +backendPipelineOutput (Named JavaScript) = Persistent +backendPipelineOutput (Named Interpreter) = NoOutputFile +backendPipelineOutput (Named NoBackend) = NoOutputFile + +-- | This flag tells the driver whether the back end can +-- reuse code (bytecode or object code) that has been +-- loaded dynamically. Likely true only of the interpreter. +backendCanReuseLoadedCode :: Backend -> Bool +backendCanReuseLoadedCode (Named NCG) = False +backendCanReuseLoadedCode (Named LLVM) = False +backendCanReuseLoadedCode (Named ViaC) = False +backendCanReuseLoadedCode (Named JavaScript) = False +backendCanReuseLoadedCode (Named Interpreter) = True +backendCanReuseLoadedCode (Named NoBackend) = False + +-- | It is is true of every back end except @-fno-code@ +-- that it "generates code." Surprisingly, this property +-- influences the driver in a ton of ways. Some examples: +-- +-- * If the back end does not generate code, then the +-- driver needs to turn on code generation for +-- Template Haskell (because that code needs to be +-- generated and run at compile time). +-- +-- * If the back end does not generate code, then the +-- driver does not need to deal with an output file. +-- +-- * If the back end /does/ generated code, then the +-- driver supports `HscRecomp`. If not, recompilation +-- does not need a linkable (and is automatically up +-- to date). +-- +backendGeneratesCode :: Backend -> Bool +backendGeneratesCode (Named NCG) = True +backendGeneratesCode (Named LLVM) = True +backendGeneratesCode (Named ViaC) = True +backendGeneratesCode (Named JavaScript) = True +backendGeneratesCode (Named Interpreter) = True +backendGeneratesCode (Named NoBackend) = False + +backendGeneratesCodeForHsBoot :: Backend -> Bool +backendGeneratesCodeForHsBoot (Named NCG) = True +backendGeneratesCodeForHsBoot (Named LLVM) = True +backendGeneratesCodeForHsBoot (Named ViaC) = True +backendGeneratesCodeForHsBoot (Named JavaScript) = True +backendGeneratesCodeForHsBoot (Named Interpreter) = False +backendGeneratesCodeForHsBoot (Named NoBackend) = False + +-- | When set, this flag turns on interface writing for +-- Backpack. It should probably be the same as +-- `backendGeneratesCode`, but it is kept distinct for +-- reasons described in Note [-fno-code mode]. +backendSupportsInterfaceWriting :: Backend -> Bool +backendSupportsInterfaceWriting (Named NCG) = True +backendSupportsInterfaceWriting (Named LLVM) = True +backendSupportsInterfaceWriting (Named ViaC) = True +backendSupportsInterfaceWriting (Named JavaScript) = True +backendSupportsInterfaceWriting (Named Interpreter) = True +backendSupportsInterfaceWriting (Named NoBackend) = False + +-- | When preparing code for this back end, the type +-- checker should pay attention to SPECIALISE pragmas. If +-- this flag is `False`, then the type checker ignores +-- SPECIALISE pragmas (for imported things?). +backendRespectsSpecialise :: Backend -> Bool +backendRespectsSpecialise (Named NCG) = True +backendRespectsSpecialise (Named LLVM) = True +backendRespectsSpecialise (Named ViaC) = True +backendRespectsSpecialise (Named JavaScript) = True +backendRespectsSpecialise (Named Interpreter) = False +backendRespectsSpecialise (Named NoBackend) = False + +-- | This back end wants the `mi_top_env` field of a +-- `ModIface` to be populated (with the top-level bindings +-- of the original source). Only true for the interpreter. +backendWantsGlobalBindings :: Backend -> Bool +backendWantsGlobalBindings (Named NCG) = False +backendWantsGlobalBindings (Named LLVM) = False +backendWantsGlobalBindings (Named ViaC) = False +backendWantsGlobalBindings (Named JavaScript) = False +backendWantsGlobalBindings (Named NoBackend) = False +backendWantsGlobalBindings (Named Interpreter) = True + +-- | The back end targets a technology that implements +-- `switch` natively. (For example, LLVM or C.) Therefore +-- it is not necessary for GHC to ccompile a Cmm `Switch` +-- form into a decision tree with jump tables at the +-- leaves. +backendHasNativeSwitch :: Backend -> Bool +backendHasNativeSwitch (Named NCG) = False +backendHasNativeSwitch (Named LLVM) = True +backendHasNativeSwitch (Named ViaC) = True +backendHasNativeSwitch (Named JavaScript) = True +backendHasNativeSwitch (Named Interpreter) = False +backendHasNativeSwitch (Named NoBackend) = False + +-- | As noted in the documentation for +-- `PrimitiveImplementation`, certain primitives have +-- multiple implementations, depending on the capabilities +-- of the back end. This field signals to module +-- "GHC.StgToCmm.Prim" what implementations to use with +-- this back end. +backendPrimitiveImplementation :: Backend -> PrimitiveImplementation +backendPrimitiveImplementation (Named NCG) = NcgPrimitives +backendPrimitiveImplementation (Named LLVM) = LlvmPrimitives +backendPrimitiveImplementation (Named JavaScript) = JSPrimitives +backendPrimitiveImplementation (Named ViaC) = GenericPrimitives +backendPrimitiveImplementation (Named Interpreter) = GenericPrimitives +backendPrimitiveImplementation (Named NoBackend) = GenericPrimitives + +-- | When this value is `IsValid`, the back end is +-- compatible with vector instructions. When it is +-- `NotValid`, it carries a message that is shown to +-- users. +backendSimdValidity :: Backend -> Validity' String +backendSimdValidity (Named NCG) = IsValid +backendSimdValidity (Named LLVM) = IsValid +backendSimdValidity (Named ViaC) = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."] +backendSimdValidity (Named JavaScript) = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."] +backendSimdValidity (Named Interpreter) = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."] +backendSimdValidity (Named NoBackend) = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."] + +-- | This flag says whether the back end supports large +-- binary blobs. See Note [Embedding large binary blobs] +-- in "GHC.CmmToAsm.Ppr". +backendSupportsEmbeddedBlobs :: Backend -> Bool +backendSupportsEmbeddedBlobs (Named NCG) = True +backendSupportsEmbeddedBlobs (Named LLVM) = False +backendSupportsEmbeddedBlobs (Named ViaC) = False +backendSupportsEmbeddedBlobs (Named JavaScript) = False +backendSupportsEmbeddedBlobs (Named Interpreter) = False +backendSupportsEmbeddedBlobs (Named NoBackend) = False + +-- | This flag tells the compiler driver that the back end +-- does not support every target platform; it supports +-- only platforms that claim NCG support. (It's set only +-- for the native code generator.) Crufty. If the driver +-- tries to use the native code generator /without/ +-- platform support, the driver fails over to the LLVM +-- back end. +backendNeedsPlatformNcgSupport :: Backend -> Bool +backendNeedsPlatformNcgSupport (Named NCG) = True +backendNeedsPlatformNcgSupport (Named LLVM) = False +backendNeedsPlatformNcgSupport (Named ViaC) = False +backendNeedsPlatformNcgSupport (Named JavaScript) = False +backendNeedsPlatformNcgSupport (Named Interpreter) = False +backendNeedsPlatformNcgSupport (Named NoBackend) = False + +-- | This flag is set if the back end can generate code +-- for proc points. If the flag is not set, then a Cmm +-- pass needs to split proc points (that is, turn each +-- proc point into a standalone procedure). +backendSupportsUnsplitProcPoints :: Backend -> Bool +backendSupportsUnsplitProcPoints (Named NCG) = True +backendSupportsUnsplitProcPoints (Named LLVM) = False +backendSupportsUnsplitProcPoints (Named ViaC) = False +backendSupportsUnsplitProcPoints (Named JavaScript) = False +backendSupportsUnsplitProcPoints (Named Interpreter) = False +backendSupportsUnsplitProcPoints (Named NoBackend) = False + +-- | This flag guides the driver in resolving issues about +-- API support on the target platform. If the flag is set, +-- then these things are true: +-- +-- * When the target platform supports /only/ an unregisterised API, +-- this backend can be replaced with compilation via C. +-- +-- * When the target does /not/ support an unregisterised API, +-- this back end can replace compilation via C. +-- +backendSwappableWithViaC :: Backend -> Bool +backendSwappableWithViaC (Named NCG) = True +backendSwappableWithViaC (Named LLVM) = True +backendSwappableWithViaC (Named ViaC) = False +backendSwappableWithViaC (Named JavaScript) = False +backendSwappableWithViaC (Named Interpreter) = False +backendSwappableWithViaC (Named NoBackend) = False + +-- | This flag is true if the back end works *only* with +-- the unregisterised ABI. +backendUnregisterisedAbiOnly :: Backend -> Bool +backendUnregisterisedAbiOnly (Named NCG) = False +backendUnregisterisedAbiOnly (Named LLVM) = False +backendUnregisterisedAbiOnly (Named ViaC) = True +backendUnregisterisedAbiOnly (Named JavaScript) = False +backendUnregisterisedAbiOnly (Named Interpreter) = False +backendUnregisterisedAbiOnly (Named NoBackend) = False + +-- | This flag is set if the back end generates C code in +-- a @.hc@ file. The flag lets the compiler driver know +-- if the command-line flag @-C@ is meaningful. +backendGeneratesHc :: Backend -> Bool +backendGeneratesHc (Named NCG) = False +backendGeneratesHc (Named LLVM) = False +backendGeneratesHc (Named ViaC) = True +backendGeneratesHc (Named JavaScript) = False +backendGeneratesHc (Named Interpreter) = False +backendGeneratesHc (Named NoBackend) = False + +-- | This flag says whether SPT (static pointer table) +-- entries will be inserted dynamically if needed. If +-- this flag is `False`, then "GHC.Iface.Tidy" should emit C +-- stubs that initialize the SPT entries. +backendSptIsDynamic :: Backend -> Bool +backendSptIsDynamic (Named NCG) = False +backendSptIsDynamic (Named LLVM) = False +backendSptIsDynamic (Named ViaC) = False +backendSptIsDynamic (Named JavaScript) = False +backendSptIsDynamic (Named Interpreter) = True +backendSptIsDynamic (Named NoBackend) = False + +-- | If this flag is unset, then the driver ignores the flag @-fbreak-points@, +-- since backends other than the interpreter tend to panic on breakpoints. +backendSupportsBreakpoints :: Backend -> Bool +backendSupportsBreakpoints = \case + Named NCG -> False + Named LLVM -> False + Named ViaC -> False + Named JavaScript -> False + Named Interpreter -> True + Named NoBackend -> False + +-- | If this flag is set, then the driver forces the +-- optimization level to 0, issuing a warning message if +-- the command line requested a higher optimization level. +backendForcesOptimization0 :: Backend -> Bool +backendForcesOptimization0 (Named NCG) = False +backendForcesOptimization0 (Named LLVM) = False +backendForcesOptimization0 (Named ViaC) = False +backendForcesOptimization0 (Named JavaScript) = False +backendForcesOptimization0 (Named Interpreter) = True +backendForcesOptimization0 (Named NoBackend) = False + +-- | I don't understand exactly how this works. But if +-- this flag is set *and* another condition is met, then +-- @ghc/Main.hs@ will alter the `DynFlags` so that all the +-- `hostFullWays` are asked for. It is set only for the interpreter. +backendNeedsFullWays :: Backend -> Bool +backendNeedsFullWays (Named NCG) = False +backendNeedsFullWays (Named LLVM) = False +backendNeedsFullWays (Named ViaC) = False +backendNeedsFullWays (Named JavaScript) = False +backendNeedsFullWays (Named Interpreter) = True +backendNeedsFullWays (Named NoBackend) = False + +-- | This flag is also special for the interpreter: if a +-- message about a module needs to be shown, do we know +-- anything special about where the module came from? The +-- Boolean argument is a `recomp` flag. +backendSpecialModuleSource :: Backend -> Bool -> Maybe String +backendSpecialModuleSource (Named NCG) = const Nothing +backendSpecialModuleSource (Named LLVM) = const Nothing +backendSpecialModuleSource (Named ViaC) = const Nothing +backendSpecialModuleSource (Named JavaScript) = const Nothing +backendSpecialModuleSource (Named Interpreter) = \b -> if b then Just "interpreted" else Nothing +backendSpecialModuleSource (Named NoBackend) = const (Just "nothing") + +-- | This flag says whether the back end supports Haskell +-- Program Coverage (HPC). If not, the compiler driver +-- will ignore the `-fhpc` option (and will issue a +-- warning message if it is used). +backendSupportsHpc :: Backend -> Bool +backendSupportsHpc (Named NCG) = True +backendSupportsHpc (Named LLVM) = True +backendSupportsHpc (Named ViaC) = True +backendSupportsHpc (Named JavaScript) = False +backendSupportsHpc (Named Interpreter) = False +backendSupportsHpc (Named NoBackend) = True + +-- | This flag says whether the back end supports foreign +-- import of C functions. ("Supports" means "does not +-- barf on," so @-fno-code@ supports foreign C imports.) +backendSupportsCImport :: Backend -> Bool +backendSupportsCImport (Named NCG) = True +backendSupportsCImport (Named LLVM) = True +backendSupportsCImport (Named ViaC) = True +backendSupportsCImport (Named JavaScript) = True +backendSupportsCImport (Named Interpreter) = True +backendSupportsCImport (Named NoBackend) = True + +-- | This flag says whether the back end supports foreign +-- export of Haskell functions to C. +backendSupportsCExport :: Backend -> Bool +backendSupportsCExport (Named NCG) = True +backendSupportsCExport (Named LLVM) = True +backendSupportsCExport (Named ViaC) = True +backendSupportsCExport (Named JavaScript) = True +backendSupportsCExport (Named Interpreter) = False +backendSupportsCExport (Named NoBackend) = True + +-- | When using this back end, it may be necessary or +-- advisable to pass some `-D` options to a C compiler. +-- This (defunctionalized) function produces those +-- options, if any. An IO action may be necessary in +-- order to interrogate external tools about what version +-- they are, for example. +-- +-- The function's type is +-- @ +-- Logger -> DynFlags -> IO [String] +-- @ +-- +-- This field is usually defaulted. +backendCDefs :: Backend -> DefunctionalizedCDefs +backendCDefs (Named NCG) = NoCDefs +backendCDefs (Named LLVM) = LlvmCDefs +backendCDefs (Named ViaC) = NoCDefs +backendCDefs (Named JavaScript) = NoCDefs +backendCDefs (Named Interpreter) = NoCDefs +backendCDefs (Named NoBackend) = NoCDefs + +-- | This (defunctionalized) function generates code and +-- writes it to a file. The type of the function is +-- +-- > Logger +-- > -> DynFlags +-- > -> Module -- ^ module being compiled +-- > -> ModLocation +-- > -> FilePath -- ^ Where to write output +-- > -> Set UnitId -- ^ dependencies +-- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` +-- > -> IO a +backendCodeOutput :: Backend -> DefunctionalizedCodeOutput +backendCodeOutput (Named NCG) = NcgCodeOutput +backendCodeOutput (Named LLVM) = LlvmCodeOutput +backendCodeOutput (Named ViaC) = ViaCCodeOutput +backendCodeOutput (Named JavaScript) = JSCodeOutput +backendCodeOutput (Named Interpreter) = panic "backendCodeOutput: interpreterBackend" +backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" + +backendUseJSLinker :: Backend -> Bool +backendUseJSLinker (Named NCG) = False +backendUseJSLinker (Named LLVM) = False +backendUseJSLinker (Named ViaC) = False +backendUseJSLinker (Named JavaScript) = True +backendUseJSLinker (Named Interpreter) = False +backendUseJSLinker (Named NoBackend) = False + +-- | This (defunctionalized) function tells the compiler +-- driver what else has to be run after code output. +-- The type of the function is +-- +-- > +-- > TPipelineClass TPhase m +-- > => PipeEnv +-- > -> HscEnv +-- > -> Maybe ModLocation +-- > -> FilePath +-- > -> m (Maybe FilePath) +backendPostHscPipeline :: Backend -> DefunctionalizedPostHscPipeline +backendPostHscPipeline (Named NCG) = NcgPostHscPipeline +backendPostHscPipeline (Named LLVM) = LlvmPostHscPipeline +backendPostHscPipeline (Named ViaC) = ViaCPostHscPipeline +backendPostHscPipeline (Named JavaScript) = JSPostHscPipeline +backendPostHscPipeline (Named Interpreter) = NoPostHscPipeline +backendPostHscPipeline (Named NoBackend) = NoPostHscPipeline + +-- | Somewhere in the compiler driver, when compiling +-- Haskell source (as opposed to a boot file or a sig +-- file), it needs to know what to do with the code that +-- the `backendCodeOutput` writes to a file. This `Phase` +-- value gives instructions like "run the C compiler", +-- "run the assembler," or "run the LLVM Optimizer." +backendNormalSuccessorPhase :: Backend -> Phase +backendNormalSuccessorPhase (Named NCG) = As False +backendNormalSuccessorPhase (Named LLVM) = LlvmOpt +backendNormalSuccessorPhase (Named ViaC) = HCc +backendNormalSuccessorPhase (Named JavaScript) = StopLn +backendNormalSuccessorPhase (Named Interpreter) = StopLn +backendNormalSuccessorPhase (Named NoBackend) = StopLn + +-- | Name of the back end, if any. Used to migrate legacy +-- clients of the GHC API. Code within the GHC source +-- tree should not refer to a back end's name. +backendName :: Backend -> BackendName +backendName (Named NCG) = NCG +backendName (Named LLVM) = LLVM +backendName (Named ViaC) = ViaC +backendName (Named JavaScript) = JavaScript +backendName (Named Interpreter) = Interpreter +backendName (Named NoBackend) = NoBackend + + + +-- | A list of all back ends. They are ordered as we wish them to +-- appear when they are enumerated in error messages. + +allBackends :: [Backend] +allBackends = [ ncgBackend + , llvmBackend + , viaCBackend + , jsBackend + , interpreterBackend + , noBackend + ] + +-- | When foreign C import or export is invalid, the carried value +-- enumerates the /valid/ back ends. + +backendValidityOfCImport, backendValidityOfCExport :: Backend -> Validity' [Backend] + +backendValidityOfCImport backend = + if backendSupportsCImport backend then + IsValid + else + NotValid $ filter backendSupportsCImport allBackends + +backendValidityOfCExport backend = + if backendSupportsCExport backend then + IsValid + else + NotValid $ filter backendSupportsCExport allBackends + + + + +{- +Note [Backend Defunctionalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I had hoped to include code-output and post-hsc-pipeline functions +directly in the `Backend` record itself. But this agenda was derailed +by mutual recursion in the types: + + - A `DynFlags` record contains a back end of type `Backend`. + - A `Backend` contains a code-output function. + - A code-output function takes Cmm as input. + - Cmm can include a `CLabel`. + - A `CLabel` can have elements that are defined in + `GHC.Driver.Session`, where `DynFlags` is defined. + +There is also a nasty issue in the values: a typical post-backend +pipeline function both depends on and is depended upon by functions in +"GHC.Driver.Pipeline". + +I'm cut the Gordian not by removing the function types from the +`Backend` record. Instead, a function is represented by its /name/. +This representation is an example of an old trick called +/defunctionalization/, which has been used in both compilers and +interpreters for languages with first-class, nested functions. Here, +a function's name is a value of an algebraic data type. For example, +a code-output function is represented by a value of this type: + + data DefunctionalizedCodeOutput + = NcgCodeOutput + | ViaCCodeOutput + | LlvmCodeOutput + +Such a function may be applied in one of two ways: + + - In this particular example, a `case` expression in module + "GHC.Driver.CodeOutput" discriminates on the value and calls the + designated function. + + - In another example, a function of type `DefunctionalizedCDefs` is + applied by calling function `applyCDefs`, which has this type: + + @ + applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] + @ + + Function `applyCDefs` is defined in module "GHC.SysTools.Cpp". + +I don't love this solution, but defunctionalization is a standard +thing, and it makes the meanings of the enumeration values clear. + +Anyone defining a new back end will need to extend both the +`DefunctionalizedCodeOutput` type and the corresponding apply +function. +-} diff --git a/GHC/Driver/Backend/Internal.hs b/GHC/Driver/Backend/Internal.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Backend/Internal.hs @@ -0,0 +1,33 @@ +{-| +Module : GHC.Driver.Backend.Internal +Description : Interface for migrating legacy clients of the GHC API + +In versions of GHC up through 9.2, a `Backend` was represented only by +its name. This module is meant to aid clients written against the GHC +API, versions 9.2 and older. The module provides an alternative way +to name any back end found in GHC 9.2. /Code within the GHC source +tree should not import this module./ (#20927). + +Only back ends found in version 9.2 have names. + +-} + +module GHC.Driver.Backend.Internal + ( -- * Name of a back end + BackendName(..) + ) + +where + + + +import GHC.Prelude + +data BackendName + = NCG -- ^ Names the native code generator backend. + | LLVM -- ^ Names the LLVM backend. + | ViaC -- ^ Names the Via-C backend. + | JavaScript -- ^ Names the JS backend. + | Interpreter -- ^ Names the ByteCode interpreter. + | NoBackend -- ^ Names the `-fno-code` backend. + deriving (Eq, Show) diff --git a/GHC/Driver/Backpack.hs b/GHC/Driver/Backpack.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Backpack.hs @@ -0,0 +1,945 @@ + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + + +-- | This is the driver for the 'ghc --backpack' mode, which +-- is a reimplementation of the "package manager" bits of +-- Backpack directly in GHC. The basic method of operation +-- is to compile packages and then directly insert them into +-- GHC's in memory database. +-- +-- The compilation products of this mode aren't really suitable +-- for Cabal, because GHC makes up component IDs for the things +-- it builds and doesn't serialize out the database contents. +-- But it's still handy for constructing tests. + +module GHC.Driver.Backpack (doBackpack) where + +import GHC.Prelude + +import GHC.Driver.Backend +-- In a separate module because it hooks into the parser. +import GHC.Driver.Backpack.Syntax +import GHC.Driver.Config.Finder (initFinderOpts) +import GHC.Driver.Config.Parser +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Monad +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Driver.Main +import GHC.Driver.Make +import GHC.Driver.Env +import GHC.Driver.Errors +import GHC.Driver.Errors.Types + +import GHC.Parser +import GHC.Parser.Header +import GHC.Parser.Lexer +import GHC.Parser.Annotation + +import GHC.Rename.Names + +import GHC hiding (Failed, Succeeded) +import GHC.Tc.Utils.Monad +import GHC.Iface.Recomp + +import GHC.Types.SrcLoc +import GHC.Types.SourceError +import GHC.Types.SourceFile +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet +import GHC.Types.Basic (convImportLevel) + +import GHC.Utils.Outputable +import GHC.Utils.Fingerprint +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Error +import GHC.Utils.Logger + +import GHC.Unit +import GHC.Unit.Env +import GHC.Unit.External +import GHC.Unit.Finder +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModSummary + +import GHC.Linker.Types + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.Maybe +import GHC.Data.OsPath (unsafeEncodeUtf, os) +import GHC.Data.StringBuffer +import GHC.Data.FastString +import qualified GHC.Data.EnumSet as EnumSet +import qualified GHC.Data.ShortText as ST + +import Data.List ( partition ) +import System.Exit +import Control.Monad +import System.FilePath +import Data.Version + +-- for the unification +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import GHC.Types.Error (mkUnknownDiagnostic) +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable + +-- | Entry point to compile a Backpack file. +doBackpack :: [FilePath] -> Ghc () +doBackpack [src_filename] = do + -- Apply options from file to dflags + dflags0 <- getDynFlags + let dflags1 = dflags0 + let parser_opts1 = initParserOpts dflags1 + logger0 <- getLogger + (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 (supportedLanguagePragmas dflags1) src_filename + (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma logger0 dflags1 src_opts + modifySession (hscSetFlags dflags) + logger <- getLogger -- Get the logger after having set the session flags, + -- so that logger options are correctly set. + -- Not doing so caused #20396. + -- Cribbed from: preprocessFile / GHC.Driver.Pipeline + liftIO $ checkProcessArgsResult unhandled_flags + let print_config = initPrintConfig dflags + liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcPsMessage <$> p_warns) + liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcDriverMessage <$> warns) + -- TODO: Preprocessing not implemented + + buf <- liftIO $ hGetStringBuffer src_filename + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great + case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of + PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst) + POk _ pkgname_bkp -> do + -- OK, so we have an LHsUnit PackageName, but we want an + -- LHsUnit HsComponentId. So let's rename it. + hsc_env <- getSession + let bkp = renameHsUnits (hsc_units hsc_env) (bkpPackageNameMap pkgname_bkp) pkgname_bkp + initBkpM src_filename bkp $ + forM_ (zip [1..] bkp) $ \(i, lunit) -> do + let comp_name = unLoc (hsunitName (unLoc lunit)) + msgTopPackage (i,length bkp) comp_name + innerBkpM $ do + let (cid, insts) = computeUnitId lunit + if null insts + then if cid == UnitId (fsLit "main") + then compileExe lunit + else compileUnit cid [] + else typecheckUnit cid insts +doBackpack _ = + throwGhcException (CmdLineError "--backpack can only process a single file") + +computeUnitId :: LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)]) +computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) + where + cid = hsComponentId (unLoc (hsunitName unit)) + reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit))) + get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet + get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet + get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname + get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) = + unitFreeModuleHoles (convertHsComponentId hsuid) + +-- | Tiny enum for all types of Backpack operations we may do. +data SessionType + -- | A compilation operation which will result in a + -- runnable executable being produced. + = ExeSession + -- | A type-checking operation which produces only + -- interface files, no object files. + | TcSession + -- | A compilation operation which produces both + -- interface files and object files. + | CompSession + deriving (Eq) + +-- | Create a temporary Session to do some sort of type checking or +-- compilation. +withBkpSession :: UnitId + -> [(ModuleName, Module)] + -> [(Unit, ModRenaming)] + -> SessionType -- what kind of session are we doing + -> BkpM a -- actual action to run + -> BkpM a +withBkpSession cid insts deps session_type do_this = do + dflags <- getDynFlags + let cid_fs = unitFS cid + is_primary = False + uid_str = unpackFS (mkInstantiatedUnitHash cid insts) + cid_str = unpackFS cid_fs + -- There are multiple units in a single Backpack file, so we + -- need to separate out the results in those cases. Right now, + -- we follow this hierarchy: + -- $outputdir/$compid --> typecheck results + -- $outputdir/$compid/$unitid --> compile results + key_base p | Just f <- p dflags = f + | otherwise = "." + sub_comp p | is_primary = p + | otherwise = p cid_str + outdir p | CompSession <- session_type + -- Special case when package is definite + , not (null insts) = sub_comp (key_base p) uid_str + | otherwise = sub_comp (key_base p) + + mk_temp_env hsc_env = + hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env + mk_temp_dflags unit_state dflags = dflags + { backend = case session_type of + TcSession -> noBackend + _ -> backend dflags + , ghcLink = case session_type of + TcSession -> NoLink + _ -> ghcLink dflags + , homeUnitInstantiations_ = insts + -- if we don't have any instantiation, don't + -- fill `homeUnitInstanceOfId` as it makes no + -- sense (we're not instantiating anything) + , homeUnitInstanceOf_ = if null insts then Nothing else Just cid + , homeUnitId_ = case session_type of + TcSession -> newUnitId cid Nothing + -- No hash passed if no instances + _ | null insts -> newUnitId cid Nothing + | otherwise -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts)) + + + -- If we're type-checking an indefinite package, we want to + -- turn on interface writing. However, if the user also + -- explicitly passed in `-fno-code`, we DON'T want to write + -- interfaces unless the user also asked for `-fwrite-interface`. + -- See Note [-fno-code mode] + , generalFlags = case session_type of + -- Make sure to write interfaces when we are type-checking + -- indefinite packages. + TcSession + | backendSupportsInterfaceWriting $ backend dflags + -> EnumSet.insert Opt_WriteInterface (generalFlags dflags) + _ -> generalFlags dflags + + -- Setup all of the output directories according to our hierarchy + , objectDir = Just (outdir objectDir) + , hiDir = Just (outdir hiDir) + , stubDir = Just (outdir stubDir) + -- Unset output-file for non exe builds + , outputFile_ = case session_type of + ExeSession -> outputFile_ dflags + _ -> Nothing + , dynOutputFile_ = case session_type of + ExeSession -> dynOutputFile_ dflags + _ -> Nothing + -- Clear the import path so we don't accidentally grab anything + , importPaths = [] + -- Synthesize the flags + , packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> + let uid = unwireUnit unit_state + $ improveUnit unit_state + $ renameHoleUnit unit_state (listToUFM insts) uid0 + in ExposePackage + (showSDoc dflags + (text "-unit-id" <+> ppr uid <+> ppr rn)) + (UnitIdArg uid) rn) deps + } + withTempSession mk_temp_env $ do + dflags <- getSessionDynFlags + -- pprTrace "flags" (ppr insts <> ppr deps) $ return () + setSessionDynFlags dflags -- calls initUnits + do_this + +withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a +withBkpExeSession deps do_this = + withBkpSession (UnitId (fsLit "main")) [] deps ExeSession do_this + +getSource :: UnitId -> BkpM (LHsUnit HsComponentId) +getSource cid = do + bkp_env <- getBkpEnv + case Map.lookup cid (bkp_table bkp_env) of + Nothing -> pprPanic "missing needed dependency" (ppr cid) + Just lunit -> return lunit + +typecheckUnit :: UnitId -> [(ModuleName, Module)] -> BkpM () +typecheckUnit cid insts = do + lunit <- getSource cid + buildUnit TcSession cid insts lunit + +compileUnit :: UnitId -> [(ModuleName, Module)] -> BkpM () +compileUnit cid insts = do + -- Let everyone know we're building this unit + msgUnitId (mkVirtUnit cid insts) + lunit <- getSource cid + buildUnit CompSession cid insts lunit + +-- | Compute the dependencies with instantiations of a syntactic +-- HsUnit; e.g., wherever you see @dependency p[A=]@ in a +-- unit file, return the 'Unit' corresponding to @p[A=]@. +-- The @include_sigs@ parameter controls whether or not we also +-- include @dependency signature@ declarations in this calculation. +-- +-- Invariant: this NEVER returns UnitId. +hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(Unit, ModRenaming)] +hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit) + where + get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig))) + | include_sigs || not is_sig = [(convertHsComponentId hsuid, go mb_lrn)] + | otherwise = [] + where + go Nothing = ModRenaming True [] + go (Just lrns) = ModRenaming False (map convRn lrns) + where + convRn (L _ (Renaming (L _ from) Nothing)) = (from, from) + convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to) + get_dep _ = [] + +buildUnit :: SessionType -> UnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () +buildUnit session cid insts lunit = do + -- NB: include signature dependencies ONLY when typechecking. + -- If we're compiling, it's not necessary to recursively + -- compile a signature since it isn't going to produce + -- any object files. + let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit) + raw_deps = map fst deps_w_rns + hsc_env <- getSession + -- The compilation dependencies are just the appropriately filled + -- in unit IDs which must be compiled before we can compile. + let hsubst = listToUFM insts + deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps + + -- Build dependencies OR make sure they make sense. BUT NOTE, + -- we can only check the ones that are fully filled; the rest + -- we have to defer until we've typechecked our local signature. + -- TODO: work this into GHC.Driver.Make!! + forM_ (zip [1..] deps0) $ \(i, dep) -> + case session of + TcSession -> return () + _ -> compileInclude (length deps0) (i, dep) + + -- IMPROVE IT + let deps = map (improveUnit (hsc_units hsc_env)) deps0 + + mb_old_eps <- case session of + TcSession -> fmap Just getEpsGhc + _ -> return Nothing + + conf <- withBkpSession cid insts deps_w_rns session $ do + + dflags <- getDynFlags + mod_graph <- hsunitModuleGraph False (unLoc lunit) + + msg <- mkBackpackMsg + ok <- load' noIfaceCache LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph + when (failed ok) (liftIO $ exitWith (ExitFailure 1)) + + let hi_dir = expectJust $ hiDir dflags + export_mod ms = (ms_mod_name ms, ms_mod ms) + -- Export everything! + mods = [ export_mod ms | ms <- mgModSummaries mod_graph + , ms_hsc_src ms == HsSrcFile ] + + -- Compile relevant only + hsc_env <- getSession + let takeLinkables x + | mi_hsc_src (hm_iface x) == HsSrcFile + = [Just $ expectJust $ homeModInfoObject x] + | otherwise + = [Nothing] + linkables <- liftIO $ catMaybes <$> concatHpt takeLinkables (hsc_HPT hsc_env) + let + obj_files = concatMap linkableFiles linkables + state = hsc_units hsc_env + + compat_fs = unitIdFS cid + compat_pn = PackageName compat_fs + unit_id = homeUnitId (hsc_home_unit hsc_env) + + return GenericUnitInfo { + -- Stub data + unitAbiHash = "", + unitPackageId = PackageId compat_fs, + unitPackageName = compat_pn, + unitPackageVersion = makeVersion [], + unitId = unit_id, + unitComponentName = Nothing, + unitInstanceOf = cid, + unitInstantiations = insts, + -- Slight inefficiency here haha + unitExposedModules = map (\(m,n) -> (m,Just n)) mods, + unitHiddenModules = [], -- TODO: doc only + unitDepends = case session of + -- Technically, we should state that we depend + -- on all the indefinite libraries we used to + -- typecheck this. However, this field isn't + -- really used for anything, so we leave it + -- blank for now. + TcSession -> [] + _ -> map (toUnitId . unwireUnit state) + $ deps ++ [ moduleUnit mod + | (_, mod) <- insts + , not (isHoleModule mod) ], + unitAbiDepends = [], + unitLinkerOptions = case session of + TcSession -> [] + _ -> map ST.pack $ obj_files, + unitImportDirs = [ ST.pack $ hi_dir ], + unitIsExposed = False, + unitIsIndefinite = case session of + TcSession -> True + _ -> False, + -- nope + unitLibraries = [], + unitExtDepLibsSys = [], + unitExtDepLibsGhc = [], + unitLibraryDynDirs = [], + unitLibraryDirs = [], + unitExtDepFrameworks = [], + unitExtDepFrameworkDirs = [], + unitCcOptions = [], + unitIncludes = [], + unitIncludeDirs = [], + unitHaddockInterfaces = [], + unitHaddockHTMLs = [], + unitIsTrusted = False + } + + + addUnit conf + case mb_old_eps of + Just old_eps -> updateEpsGhc_ (const old_eps) + _ -> return () + +compileExe :: LHsUnit HsComponentId -> BkpM () +compileExe lunit = do + msgUnitId mainUnit + let deps_w_rns = hsunitDeps False (unLoc lunit) + deps = map fst deps_w_rns + -- no renaming necessary + forM_ (zip [1..] deps) $ \(i, dep) -> + compileInclude (length deps) (i, dep) + withBkpExeSession deps_w_rns $ do + mod_graph <- hsunitModuleGraph True (unLoc lunit) + msg <- mkBackpackMsg + ok <- load' noIfaceCache LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph + when (failed ok) (liftIO $ exitWith (ExitFailure 1)) + +-- | Register a new virtual unit database containing a single unit +addUnit :: GhcMonad m => UnitInfo -> m () +addUnit u = do + hsc_env <- getSession + logger <- getLogger + let dflags0 = hsc_dflags hsc_env + let old_unit_env = hsc_unit_env hsc_env + newdbs <- case ue_unit_dbs old_unit_env of + Nothing -> panic "addUnit: called too early" + Just dbs -> + let newdb = UnitDatabase + { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")" + , unitDatabaseUnits = [u] + } + in return (dbs ++ [newdb]) -- added at the end because ordering matters + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env) + + -- update platform constants + dflags <- liftIO $ updatePlatformConstants dflags0 mconstants + + let unit_env = UnitEnv + { ue_platform = targetPlatform dflags + , ue_namever = ghcNameVersion dflags + , ue_current_unit = homeUnitId home_unit + + , ue_home_unit_graph = + HUG.unitEnv_singleton + (homeUnitId home_unit) + (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) + , ue_eps = ue_eps old_unit_env + , ue_module_graph = ue_module_graph old_unit_env + } + setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } + +compileInclude :: Int -> (Int, Unit) -> BkpM () +compileInclude n (i, uid) = do + hsc_env <- getSession + let pkgs = hsc_units hsc_env + msgInclude (i, n) uid + -- Check if we've compiled it already + case uid of + HoleUnit -> return () + RealUnit _ -> return () + VirtUnit i -> case lookupUnit pkgs uid of + Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i) + Just _ -> return () + +-- ---------------------------------------------------------------------------- +-- Backpack monad + +-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state +-- beyond the 'Session', c.f. 'BkpEnv'. +type BkpM = IOEnv BkpEnv + +-- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv', +-- because we are going to update the 'HscEnv' as we go. +data BkpEnv + = BkpEnv { + -- | The session + bkp_session :: Session, + -- | The filename of the bkp file we're compiling + bkp_filename :: FilePath, + -- | Table of source units which we know how to compile + bkp_table :: Map UnitId (LHsUnit HsComponentId), + -- | When a package we are compiling includes another package + -- which has not been compiled, we bump the level and compile + -- that. + bkp_level :: Int + } + +-- Blah, to get rid of the default instance for IOEnv +-- TODO: just make a proper new monad for BkpM, rather than use IOEnv +instance {-# OVERLAPPING #-} HasDynFlags BkpM where + getDynFlags = fmap hsc_dflags getSession +instance {-# OVERLAPPING #-} HasLogger BkpM where + getLogger = fmap hsc_logger getSession + + +instance GhcMonad BkpM where + getSession = do + Session s <- fmap bkp_session getEnv + readMutVar s + setSession hsc_env = do + Session s <- fmap bkp_session getEnv + writeMutVar s hsc_env + +-- | Get the current 'BkpEnv'. +getBkpEnv :: BkpM BkpEnv +getBkpEnv = getEnv + +-- | Get the nesting level, when recursively compiling modules. +getBkpLevel :: BkpM Int +getBkpLevel = bkp_level `fmap` getBkpEnv + +-- | Run a 'BkpM' computation, with the nesting level bumped one. +innerBkpM :: BkpM a -> BkpM a +innerBkpM do_this = + -- NB: withTempSession mutates, so we don't have to worry + -- about bkp_session being stale. + updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this + +-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot. +updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m () +updateEpsGhc_ f = do + hsc_env <- getSession + liftIO $ atomicModifyIORef' (euc_eps (ue_eps (hsc_unit_env hsc_env))) (\x -> (f x, ())) + +-- | Get the EPS from a 'GhcMonad'. +getEpsGhc :: GhcMonad m => m ExternalPackageState +getEpsGhc = do + hsc_env <- getSession + liftIO $ hscEPS hsc_env + +-- | Run 'BkpM' in 'Ghc'. +initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a +initBkpM file bkp m = + reifyGhc $ \session -> do + let env = BkpEnv { + bkp_session = session, + bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp], + bkp_filename = file, + bkp_level = 0 + } + runIOEnv env m + +-- ---------------------------------------------------------------------------- +-- Messaging + +-- | Print a compilation progress message, but with indentation according +-- to @level@ (for nested compilation). +backpackProgressMsg :: Int -> Logger -> SDoc -> IO () +backpackProgressMsg level logger msg = + compilationProgressMsg logger $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr + <> msg + +-- | Creates a 'Messager' for Backpack compilation; this is basically +-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which +-- handles indentation. +mkBackpackMsg :: BkpM Messager +mkBackpackMsg = do + level <- getBkpLevel + return $ \hsc_env mod_index recomp node -> + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + state = hsc_units hsc_env + showMsg msg reason = + backpackProgressMsg level logger $ pprWithUnitState state $ + showModuleIndex mod_index <> + msg <> showModMsg dflags (recompileRequired recomp) node + <> reason + in case node of + InstantiationNode _ _ -> + case recomp of + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty + | otherwise -> return () + NeedsRecompile reason0 -> showMsg (text "Instantiating ") $ case reason0 of + MustCompile -> empty + RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" + ModuleNode {} -> + case recomp of + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty + | otherwise -> return () + NeedsRecompile reason0 -> showMsg (text "Compiling ") $ case reason0 of + MustCompile -> empty + RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" + LinkNode _ _ -> showMsg (text "Linking ") empty + UnitNode {} -> showMsg (text "Package ") empty + +-- | 'PprStyle' for Backpack messages; here we usually want the module to +-- be qualified (so we can tell how it was instantiated.) But we try not +-- to qualify packages so we can use simple names for them. +backpackStyle :: PprStyle +backpackStyle = + mkUserStyle + (QueryQualify neverQualifyNames + alwaysQualifyModules + neverQualifyPackages + alwaysPrintPromTick) + AllTheWay + +-- | Message when we initially process a Backpack unit. +msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () +msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do + logger <- getLogger + level <- getBkpLevel + liftIO . backpackProgressMsg level logger + $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn + +-- | Message when we instantiate a Backpack unit. +msgUnitId :: Unit -> BkpM () +msgUnitId pk = do + logger <- getLogger + hsc_env <- getSession + level <- getBkpLevel + let state = hsc_units hsc_env + liftIO . backpackProgressMsg level logger + $ pprWithUnitState state + $ text "Instantiating " + <> withPprStyle backpackStyle (ppr pk) + +-- | Message when we include a Backpack unit. +msgInclude :: (Int,Int) -> Unit -> BkpM () +msgInclude (i,n) uid = do + logger <- getLogger + hsc_env <- getSession + level <- getBkpLevel + let state = hsc_units hsc_env + liftIO . backpackProgressMsg level logger + $ pprWithUnitState state + $ showModuleIndex (i, n) <> text "Including " + <> withPprStyle backpackStyle (ppr uid) + +-- ---------------------------------------------------------------------------- +-- Conversion from PackageName to HsComponentId + +type PackageNameMap a = UniqFM PackageName a + +-- For now, something really simple, since we're not actually going +-- to use this for anything +unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId) +unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) + = (pn, HsComponentId pn (UnitId fs)) + +bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId +bkpPackageNameMap units = listToUFM (map unitDefines units) + +renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] +renameHsUnits pkgstate m units = map (fmap renameHsUnit) units + where + + renamePackageName :: PackageName -> HsComponentId + renamePackageName pn = + case lookupUFM m pn of + Nothing -> + case lookupPackageName pkgstate pn of + Nothing -> error "no package name" + Just cid -> HsComponentId pn cid + Just hscid -> hscid + + renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId + renameHsUnit u = + HsUnit { + hsunitName = fmap renamePackageName (hsunitName u), + hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u) + } + + renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId + renameHsUnitDecl (DeclD a b c) = DeclD a b c + renameHsUnitDecl (IncludeD idecl) = + IncludeD IncludeDecl { + idUnitId = fmap renameHsUnitId (idUnitId idecl), + idModRenaming = idModRenaming idecl, + idSignatureInclude = idSignatureInclude idecl + } + + renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId + renameHsUnitId (HsUnitId ln subst) + = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst) + + renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId + renameHsModuleSubst (lk, lm) + = (lk, fmap renameHsModuleId lm) + + renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId + renameHsModuleId (HsModuleVar lm) = HsModuleVar lm + renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm + +convertHsComponentId :: HsUnitId HsComponentId -> Unit +convertHsComponentId (HsUnitId (L _ hscid) subst) + = mkVirtUnit (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst) + +convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module) +convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m) + +convertHsModuleId :: HsModuleId HsComponentId -> Module +convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname +convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsComponentId hsuid) modname + + + +{- +************************************************************************ +* * + Module graph construction +* * +************************************************************************ +-} + +-- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications: +-- +-- 1. Every module is required to be mentioned, so we don't do any funny +-- business with targets or recursively grabbing dependencies. (We +-- could support this in principle). +-- 2. We support inline modules, whose summary we have to synthesize ourself. +-- +-- We don't bother trying to support GHC.Driver.Make for now, it's more trouble +-- than it's worth for inline modules. +hsunitModuleGraph :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph +hsunitModuleGraph do_link unit = do + hsc_env <- getSession + + let decls = hsunitBody unit + pn = hsPackageName (unLoc (hsunitName unit)) + home_unit = hsc_home_unit hsc_env + + sig_keys = flip map (homeUnitInstantiations home_unit) $ \(mod_name, _) -> NodeKey_Module (ModNodeKeyWithUid (GWIB mod_name NotBoot) (homeUnitId home_unit)) + keys = [NodeKey_Module (ModNodeKeyWithUid gwib (homeUnitId home_unit)) | (DeclD hsc_src lmodname _) <- map unLoc decls, let gwib = GWIB (unLoc lmodname) (hscSourceToIsBoot hsc_src) ] + + -- 1. Create a HsSrcFile/HsigFile summary for every + -- explicitly mentioned module/signature. + let get_decl (L _ (DeclD hsc_src lmodname hsmod)) = + Just <$> summariseDecl pn hsc_src lmodname hsmod (keys ++ sig_keys) + get_decl _ = return Nothing + nodes <- mapMaybeM get_decl decls + + -- 2. For each hole which does not already have an hsig file, + -- create an "empty" hsig file to induce compilation for the + -- requirement. + let hsig_set = Set.fromList + [ moduleNodeInfoModuleName ms + | ModuleNode _ ms <- nodes + , moduleNodeInfoHscSource ms == Just HsigFile + ] + req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) -> + if Set.member mod_name hsig_set + then return Nothing + else fmap Just $ summariseRequirement pn mod_name + let inodes = instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env) + -- TODO: Backpack mode does not properly support ExternalPackage nodes yet + -- Module nodes do not get given package dependencies (see hsModuleToModSummary). + let pkg_nodes = ordNub $ map (\(_, iud) -> UnitNode [] (instUnitInstanceOf iud)) inodes + let graph_nodes = nodes ++ req_nodes ++ (map (uncurry InstantiationNode) $ inodes) ++ pkg_nodes + key_nodes = map mkNodeKey graph_nodes + all_nodes = graph_nodes ++ [LinkNode key_nodes (homeUnitId $ hsc_home_unit hsc_env) | do_link] + -- This error message is not very good but .bkp mode is just for testing so + -- better to be direct rather than pretty. + when + (length key_nodes /= length (ordNub key_nodes)) + (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes)) + + -- 3. Return the kaboodle + return $ mkModuleGraph $ all_nodes + + +summariseRequirement :: PackageName -> ModuleName -> BkpM ModuleGraphNode +summariseRequirement pn mod_name = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + let home_unit = hsc_home_unit hsc_env + let fopts = initFinderOpts dflags + + let PackageName pn_fs = pn + let location = mkHomeModLocation2 fopts mod_name + (unsafeEncodeUtf $ unpackFS pn_fs moduleNameSlashes mod_name) (os "hsig") + + env <- getBkpEnv + src_hash <- liftIO $ getFileHash (bkp_filename env) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) + + let fc = hsc_FC hsc_env + mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location HsigFile + + extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name + + let ms = ModSummary { + ms_mod = mod, + ms_hsc_src = HsigFile, + ms_location = location, + ms_hs_hash = src_hash, + ms_obj_date = Nothing, + ms_dyn_obj_date = Nothing, + ms_iface_date = hi_timestamp, + ms_hie_date = hie_timestamp, + ms_srcimps = [], + ms_textual_imps = ((,,) NormalLevel NoPkgQual . noLoc) <$> extra_sig_imports, + ms_parsed_mod = Just (HsParsedModule { + hpm_module = L loc (HsModule { + hsmodExt = XModulePs { + hsmodAnn = noAnn, + hsmodLayout = EpNoLayout, + hsmodDeprecMessage = Nothing, + hsmodHaddockModHeader = Nothing + }, + hsmodName = Just (L (noAnnSrcSpan loc) mod_name), + hsmodExports = Nothing, + hsmodImports = [], + hsmodDecls = [] + }), + hpm_src_files = [] + }), + ms_hspp_file = "", -- none, it came inline + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing + } + let nodes = [mkModuleEdge NormalLevel (NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit))) | mn <- extra_sig_imports ] + return (ModuleNode nodes (ModuleNodeCompile ms)) + +summariseDecl :: PackageName + -> HscSource + -> Located ModuleName + -> Located (HsModule GhcPs) + -> [NodeKey] + -> BkpM ModuleGraphNode +summariseDecl pn hsc_src (L _ modname) hsmod home_keys = hsModuleToModSummary home_keys pn hsc_src modname hsmod + +-- | Up until now, GHC has assumed a single compilation target per source file. +-- Backpack files with inline modules break this model, since a single file +-- may generate multiple output files. How do we decide to name these files? +-- Should there only be one output file? This function our current heuristic, +-- which is we make a "fake" module and use that. +hsModuleToModSummary :: [NodeKey] + -> PackageName + -> HscSource + -> ModuleName + -> Located (HsModule GhcPs) + -> BkpM ModuleGraphNode +hsModuleToModSummary home_keys pn hsc_src modname + hsmod = do + let imps = hsmodImports (unLoc hsmod) + loc = getLoc hsmod + hsc_env <- getSession + -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation + -- Use the PACKAGE NAME to find the location + let PackageName unit_fs = pn + dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags + -- Unfortunately, we have to define a "fake" location in + -- order to appease the various code which uses the file + -- name to figure out where to put, e.g. object files. + -- To add insult to injury, we don't even actually use + -- these filenames to figure out where the hi files go. + -- A travesty! + let location = mkHomeModLocation fopts modname + (unsafeEncodeUtf $ unpackFS unit_fs + moduleNameSlashes modname) + (case hsc_src of + HsigFile -> os "hsig" + HsBootFile -> os "hs-boot" + HsSrcFile -> os "hs") + hsc_src + -- This duplicates a pile of logic in GHC.Driver.Make + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + + -- Also copied from 'getImports' + let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps + + implicit_prelude = xopt LangExt.ImplicitPrelude dflags + implicit_imports = mkPrelImports modname loc + implicit_prelude imps + + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname + convImport (L _ i) = (convImportLevel (ideclLevelSpec i), rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i) + + extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname + + let normal_imports = map convImport (implicit_imports ++ ord_idecls) + (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports + + -- So that Finder can find it, even though it doesn't exist... + this_mod <- liftIO $ do + let home_unit = hsc_home_unit hsc_env + let fc = hsc_FC hsc_env + addHomeModuleToFinder fc home_unit modname location hsc_src + let ms = ModSummary { + ms_mod = this_mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = (case hiDir dflags of + Nothing -> "" + Just d -> d) ".." moduleNameSlashes modname <.> "hi", + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing, + ms_srcimps = (\i -> reLoc (ideclName (unLoc i))) <$> src_idecls, + ms_textual_imps = normal_imports + -- We have to do something special here: + -- due to merging, requirements may end up with + -- extra imports + ++ ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) + ++ ((,,) NormalLevel NoPkgQual . noLoc <$> implicit_sigs), + -- This is our hack to get the parse tree to the right spot + ms_parsed_mod = Just (HsParsedModule { + hpm_module = hsmod, + hpm_src_files = [] -- TODO if we preprocessed it + }), + -- Source hash = fingerprint0, so the recompilation tests do not recompile + -- too much. In future, if necessary then could get the hash by just hashing the + -- relevant part of the .bkp file. + ms_hs_hash = fingerprint0, + ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS + ms_dyn_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS + ms_iface_date = hi_timestamp, + ms_hie_date = hie_timestamp + } + + -- Now, what are the dependencies. + let inst_nodes = map NodeKey_Unit inst_deps + mod_nodes = + -- hs-boot edge + [k | k <- [NodeKey_Module (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot) (moduleUnitId this_mod))], NotBoot == isBootSummary ms, k `elem` home_keys ] ++ + -- Normal edges + [k | (_, _, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys] + + + return (ModuleNode (map mkNormalEdge (mod_nodes ++ inst_nodes)) (ModuleNodeCompile ms)) + +-- | Create a new, externally provided hashed unit id from +-- a hash. +newUnitId :: UnitId -> Maybe FastString -> UnitId +newUnitId uid mhash = case mhash of + Nothing -> uid + Just hash -> UnitId (concatFS [unitIdFS uid, fsLit "+", hash]) diff --git a/GHC/Driver/Backpack/Syntax.hs b/GHC/Driver/Backpack/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Backpack/Syntax.hs @@ -0,0 +1,86 @@ +-- | This is the syntax for bkp files which are parsed in 'ghc --backpack' +-- mode. This syntax is used purely for testing purposes. + +module GHC.Driver.Backpack.Syntax ( + -- * Backpack abstract syntax + HsUnitId(..), + LHsUnitId, + HsModuleSubst, + LHsModuleSubst, + HsModuleId(..), + LHsModuleId, + HsComponentId(..), + LHsUnit, HsUnit(..), + LHsUnitDecl, HsUnitDecl(..), + IncludeDecl(..), + LRenaming, Renaming(..), + ) where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Types.SrcLoc +import GHC.Types.SourceFile + +import GHC.Unit.Types +import GHC.Unit.Info + +import GHC.Utils.Outputable + +{- +************************************************************************ +* * + User syntax +* * +************************************************************************ +-} + +data HsComponentId = HsComponentId { + hsPackageName :: PackageName, + hsComponentId :: UnitId + } + +instance Outputable HsComponentId where + ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn + +data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n] +type LHsUnitId n = Located (HsUnitId n) + +type HsModuleSubst n = (Located ModuleName, LHsModuleId n) +type LHsModuleSubst n = Located (HsModuleSubst n) + +data HsModuleId n = HsModuleVar (Located ModuleName) + | HsModuleId (LHsUnitId n) (Located ModuleName) +type LHsModuleId n = Located (HsModuleId n) + +-- | Top level @unit@ declaration in a Backpack file. +data HsUnit n = HsUnit { + hsunitName :: Located n, + hsunitBody :: [LHsUnitDecl n] + } +type LHsUnit n = Located (HsUnit n) + +-- | A declaration in a package, e.g. a module or signature definition, +-- or an include. +data HsUnitDecl n + = DeclD HscSource (Located ModuleName) (Located (HsModule GhcPs)) + | IncludeD (IncludeDecl n) +type LHsUnitDecl n = Located (HsUnitDecl n) + +-- | An include of another unit +data IncludeDecl n = IncludeDecl { + idUnitId :: LHsUnitId n, + idModRenaming :: Maybe [ LRenaming ], + -- | Is this a @dependency signature@ include? If so, + -- we don't compile this include when we instantiate this + -- unit (as there should not be any modules brought into + -- scope.) + idSignatureInclude :: Bool + } + +-- | Rename a module from one name to another. The identity renaming +-- means that the module should be brought into scope. +data Renaming = Renaming { renameFrom :: Located ModuleName + , renameTo :: Maybe (Located ModuleName) } +type LRenaming = Located Renaming diff --git a/GHC/Driver/CmdLine.hs b/GHC/Driver/CmdLine.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/CmdLine.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RankNTypes #-} + +------------------------------------------------------------------------------- +-- +-- | Command-line parser +-- +-- This is an abstract command-line parser used by DynFlags. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +module GHC.Driver.CmdLine + ( + processArgs, parseResponseFile, OptKind(..), GhcFlagMode(..), + Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag, + errorsToGhcException, + + Err(..), Warn, warnsToMessages, + + EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM + ) where + +import GHC.Prelude + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Data.Bag +import GHC.Types.SrcLoc +import GHC.Types.Error +import GHC.Utils.Error +import GHC.Driver.Errors.Types +import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage +import GHC.Utils.Outputable (text) + +import Data.Function +import Data.List (sortBy, intercalate, stripPrefix) +import Data.Word + +import GHC.ResponseFile +import Control.Exception (IOException, catch) +import Control.Monad (ap) +import Control.Monad.IO.Class + +-------------------------------------------------------- +-- The Flag and OptKind types +-------------------------------------------------------- + +data Flag m = Flag + { flagName :: String, -- Flag, without the leading "-" + flagOptKind :: OptKind m, -- What to do if we see it + flagGhcMode :: GhcFlagMode -- Which modes this flag affects + } + +defFlag :: String -> OptKind m -> Flag m +defFlag name optKind = Flag name optKind AllModes + +defGhcFlag :: String -> OptKind m -> Flag m +defGhcFlag name optKind = Flag name optKind OnlyGhc + +defGhciFlag :: String -> OptKind m -> Flag m +defGhciFlag name optKind = Flag name optKind OnlyGhci + +defHiddenFlag :: String -> OptKind m -> Flag m +defHiddenFlag name optKind = Flag name optKind HiddenFlag + +hoistFlag :: forall m n. (forall a. m a -> n a) -> Flag m -> Flag n +hoistFlag f (Flag a b c) = Flag a (go b) c + where + go (NoArg k) = NoArg (go2 k) + go (HasArg k) = HasArg (\s -> go2 (k s)) + go (SepArg k) = SepArg (\s -> go2 (k s)) + go (Prefix k) = Prefix (\s -> go2 (k s)) + go (OptPrefix k) = OptPrefix (\s -> go2 (k s)) + go (OptIntSuffix k) = OptIntSuffix (\n -> go2 (k n)) + go (IntSuffix k) = IntSuffix (\n -> go2 (k n)) + go (Word64Suffix k) = Word64Suffix (\s -> go2 (k s)) + go (FloatSuffix k) = FloatSuffix (\s -> go2 (k s)) + go (PassFlag k) = PassFlag (\s -> go2 (k s)) + go (AnySuffix k) = AnySuffix (\s -> go2 (k s)) + + go2 :: EwM m a -> EwM n a + go2 (EwM g) = EwM $ \loc es ws -> f (g loc es ws) + +-- | GHC flag modes describing when a flag has an effect. +data GhcFlagMode + = OnlyGhc -- ^ The flag only affects the non-interactive GHC + | OnlyGhci -- ^ The flag only affects the interactive GHC + | AllModes -- ^ The flag affects multiple ghc modes + | HiddenFlag -- ^ This flag should not be seen in cli completion + +data OptKind m -- Suppose the flag is -f + = NoArg (EwM m ()) -- -f all by itself + | HasArg (String -> EwM m ()) -- -farg or -f arg + | SepArg (String -> EwM m ()) -- -f arg + | Prefix (String -> EwM m ()) -- -farg + | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) + | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn + | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn + | Word64Suffix (Word64 -> EwM m ()) -- -f or -f=n; pass n to fn + | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn + | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn + | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn + + +-------------------------------------------------------- +-- The EwM monad +-------------------------------------------------------- + +-- | A command-line error message +newtype Err = Err { errMsg :: Located String } + +-- | A command-line warning message and the reason it arose +-- +-- This used to be own type, but now it's just @'MsgEnvelope' 'DriverMessage'@. +type Warn = Located DriverMessage + +type Errs = Bag Err +type Warns = [Warn] + +-- EwM ("errors and warnings monad") is a monad +-- transformer for m that adds an (err, warn) state +newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg + -> Errs -> Warns + -> m (Errs, Warns, a) } + deriving (Functor) + +instance Monad m => Applicative (EwM m) where + pure v = EwM (\_ e w -> return (e, w, v)) + (<*>) = ap + +instance Monad m => Monad (EwM m) where + (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w + unEwM (k r) l e' w') +instance MonadIO m => MonadIO (EwM m) where + liftIO = liftEwM . liftIO + +runEwM :: EwM m a -> m (Errs, Warns, a) +runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag mempty + +setArg :: Located String -> EwM m () -> EwM m () +setArg l (EwM f) = EwM (\_ es ws -> f l es ws) + +addErr :: Monad m => String -> EwM m () +addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ())) + +addWarn :: Monad m => String -> EwM m () +addWarn msg = addFlagWarn $ DriverUnknownMessage $ mkSimpleUnknownDiagnostic $ + mkPlainDiagnostic WarningWithoutFlag noHints $ text msg + +addFlagWarn :: Monad m => DriverMessage -> EwM m () +addFlagWarn msg = EwM + (\(L loc _) es ws -> return (es, L loc msg : ws, ())) + +getArg :: Monad m => EwM m String +getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) + +getCurLoc :: Monad m => EwM m SrcSpan +getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) + +liftEwM :: Monad m => m a -> EwM m a +liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) + +warnsToMessages :: DiagOpts -> [Warn] -> Messages DriverMessage +warnsToMessages diag_opts = foldr + (\(L loc w) ws -> addMessage (mkPlainMsgEnvelope diag_opts loc w) ws) + emptyMessages + +-------------------------------------------------------- +-- Processing arguments +-------------------------------------------------------- + +processArgs :: Monad m + => [Flag m] -- ^ cmdline parser spec + -> [Located String] -- ^ args + -> (FilePath -> EwM m [Located String]) -- ^ response file handler + -> m ( [Located String], -- spare args + [Err], -- errors + Warns ) -- warnings +processArgs spec args handleRespFile = do + (errs, warns, spare) <- runEwM action + return (spare, bagToList errs, warns) + where + action = process args [] + + -- process :: [Located String] -> [Located String] -> EwM m [Located String] + process [] spare = return (reverse spare) + + process (L _ ('@' : resp_file) : args) spare = do + resp_args <- handleRespFile resp_file + process (resp_args ++ args) spare + + process (locArg@(L _ ('-' : arg)) : args) spare = + case findArg spec arg of + Just (rest, opt_kind) -> + case processOneArg opt_kind rest arg args of + Left err -> + let b = process args spare + in (setArg locArg $ addErr err) >> b + + Right (action,rest) -> + let b = process rest spare + in (setArg locArg $ action) >> b + + Nothing -> process args (locArg : spare) + + process (arg : args) spare = process args (arg : spare) + + +processOneArg :: OptKind m -> String -> String -> [Located String] + -> Either String (EwM m (), [Located String]) +processOneArg opt_kind rest arg args + = let dash_arg = '-' : arg + rest_no_eq = dropEq rest + in case opt_kind of + NoArg a -> assert (null rest) Right (a, args) + + HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + -- See #9776 + SepArg f -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + -- See #12625 + Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> missingArgErr dash_arg + + PassFlag f | notNull rest -> unknownFlagErr dash_arg + | otherwise -> Right (f dash_arg, args) + + OptIntSuffix f | null rest -> Right (f Nothing, args) + | Just n <- parseInt rest_no_eq -> Right (f (Just n), args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + Word64Suffix f | Just n <- parseWord64 rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed natural argument in " ++ dash_arg) + + FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed float argument in " ++ dash_arg) + + OptPrefix f -> Right (f rest_no_eq, args) + AnySuffix f -> Right (f dash_arg, args) + +findArg :: [Flag m] -> String -> Maybe (String, OptKind m) +findArg spec arg = + case sortBy (compare `on` (length . fst)) -- prefer longest matching flag + [ (removeSpaces rest, optKind) + | flag <- spec, + let optKind = flagOptKind flag, + Just rest <- [stripPrefix (flagName flag) arg], + arg_ok optKind rest arg ] + of + [] -> Nothing + (one:_) -> Just one + +arg_ok :: OptKind t -> [Char] -> String -> Bool +arg_ok (NoArg _) rest _ = null rest +arg_ok (HasArg _) _ _ = True +arg_ok (SepArg _) rest _ = null rest +arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t + -- to improve error message (#12625) +arg_ok (OptIntSuffix _) _ _ = True +arg_ok (IntSuffix _) _ _ = True +arg_ok (Word64Suffix _) _ _ = True +arg_ok (FloatSuffix _) _ _ = True +arg_ok (OptPrefix _) _ _ = True +arg_ok (PassFlag _) rest _ = null rest +arg_ok (AnySuffix _) _ _ = True + +-- | Parse an Int +-- +-- Looks for "433" or "=342", with no trailing gubbins +-- * n or =n => Just n +-- * gibberish => Nothing +parseInt :: String -> Maybe Int +parseInt s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +parseWord64 :: String -> Maybe Word64 +parseWord64 s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +parseFloat :: String -> Maybe Float +parseFloat s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +-- | Discards a leading equals sign +dropEq :: String -> String +dropEq ('=' : s) = s +dropEq s = s + +unknownFlagErr :: String -> Either String a +unknownFlagErr f = Left ("unrecognised flag: " ++ f) + +missingArgErr :: String -> Either String a +missingArgErr f = Left ("missing argument for flag: " ++ f) + +-------------------------------------------------------- +-- Utils +-------------------------------------------------------- + +-- | Parse a response file into arguments. +parseResponseFile :: MonadIO m => FilePath -> EwM m [Located String] +parseResponseFile path = do + res <- liftIO $ fmap Right (readFile path) `catch` + \(e :: IOException) -> pure (Left e) + case res of + Left _err -> addErr "Could not open response file" >> return [] + Right resp_file -> return $ map (mkGeneralLocated path) (unescapeArgs resp_file) + +-- See Note [Handling errors when parsing command-line flags] +errorsToGhcException :: [(String, -- Location + String)] -- Error + -> GhcException +errorsToGhcException errs = + UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ] + +{- Note [Handling errors when parsing command-line flags] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Parsing of static and mode flags happens before any session is started, i.e., +before the first call to 'GHC.withGhc'. Therefore, to report errors for +invalid usage of these two types of flags, we can not call any function that +needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags +is not set either). So we always print "on the commandline" as the location, +which is true except for Api users, which is probably ok. + +When reporting errors for invalid usage of dynamic flags we /can/ make use of +DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull. + +Before, we called unsafeGlobalDynFlags when an invalid (combination of) +flag(s) was given on the commandline, resulting in panics (#9963). +-} diff --git a/GHC/Driver/CodeOutput.hs b/GHC/Driver/CodeOutput.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/CodeOutput.hs @@ -0,0 +1,426 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section{Code output phase} +-} + +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Driver.CodeOutput + ( codeOutput + , outputForeignStubs + , profilingInitCode + , ipInitCode + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.ForeignSrcLang +import GHC.Data.FastString + +import GHC.CmmToAsm ( nativeCodeGen ) +import GHC.CmmToLlvm ( llvmCodeGen ) + +import GHC.CmmToC ( cmmToC ) +import GHC.Cmm.Lint ( cmmLint ) +import GHC.Cmm +import GHC.Cmm.CLabel + +import GHC.StgToCmm.CgUtils (CgStream) + +import GHC.Driver.DynFlags +import GHC.Driver.Config.Finder ( initFinderOpts ) +import GHC.Driver.Config.CmmToAsm ( initNCGConfig ) +import GHC.Driver.Config.CmmToLlvm ( initLlvmCgConfig ) +import GHC.Driver.LlvmConfigCache (LlvmConfigCache) +import GHC.Driver.Ppr +import GHC.Driver.Backend + +import GHC.Data.OsPath +import qualified GHC.Data.ShortText as ST +import GHC.Data.Stream ( liftIO ) +import qualified GHC.Data.Stream as Stream + +import GHC.Utils.TmpFs + + +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Logger +import GHC.Utils.Exception ( bracket ) +import GHC.Utils.Ppr (Mode(..)) +import GHC.Utils.Panic.Plain ( pgmError ) + +import GHC.Unit +import GHC.Unit.Finder ( mkStubPaths ) + +import GHC.Types.SrcLoc +import GHC.Types.CostCentre +import GHC.Types.ForeignStubs +import GHC.Types.Unique.DSM + +import System.Directory +import System.FilePath +import System.IO +import Data.Set (Set) +import qualified Data.Set as Set + +{- +************************************************************************ +* * +\subsection{Steering} +* * +************************************************************************ +-} + +codeOutput + :: forall a. + Logger + -> TmpFs + -> LlvmConfigCache + -> DynFlags + -> UnitState + -> Module + -> FilePath + -> ModLocation + -> (a -> ForeignStubs) + -> [(ForeignSrcLang, FilePath)] + -- ^ additional files to be compiled with the C compiler + -> Set UnitId -- ^ Dependencies + -> DUniqSupply -- ^ The deterministic unique supply to run the CgStream. + -- See Note [Deterministic Uniques in the CG] + -> CgStream RawCmmGroup a -- ^ Compiled C-- + -> IO (FilePath, + (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), + [(ForeignSrcLang, FilePath)]{-foreign_fps-}, + a) +codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps dus0 + cmm_stream + = + do { + -- Lint each CmmGroup as it goes past + ; let linted_cmm_stream = + if gopt Opt_DoCmmLinting dflags + then Stream.mapM (liftIO . do_lint) cmm_stream + else cmm_stream + + do_lint cmm = withTimingSilent logger + (text "CmmLint"<+>brackets (ppr this_mod)) + (const ()) $ do + { case cmmLint (targetPlatform dflags) cmm of + Just err -> do { logMsg logger + MCInfo -- See Note [MCInfo for Lint] in "GHC.Core.Lint" + noSrcSpan + $ withPprStyle defaultDumpStyle err + ; ghcExit logger 1 + } + Nothing -> return () + ; return cmm + } + + ; let final_stream :: CgStream RawCmmGroup (ForeignStubs, a) + final_stream = do + { a <- linted_cmm_stream + ; let stubs = genForeignStubs a + ; emitInitializerDecls this_mod stubs + ; return (stubs, a) } + + ; let dus1 = newTagDUniqSupply 'n' dus0 + ; (stubs, a) <- case backendCodeOutput (backend dflags) of + NcgCodeOutput -> outputAsm logger dflags this_mod location filenm dus1 + final_stream + ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps + LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 final_stream + JSCodeOutput -> outputJS logger llvm_config dflags filenm final_stream + ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs + ; return (filenm, stubs_exist, foreign_fps, a) + } + +-- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details. +emitInitializerDecls :: Module -> ForeignStubs -> CgStream RawCmmGroup () +emitInitializerDecls this_mod (ForeignStubs _ cstub) + | initializers <- getInitializers cstub + , not $ null initializers = + let init_array = CmmData sect statics + lbl = mkInitializerArrayLabel this_mod + sect = Section InitArray lbl + statics = CmmStaticsRaw lbl + [ CmmStaticLit $ CmmLabel fn_name + | fn_name <- initializers + ] + in Stream.yield [init_array] +emitInitializerDecls _ _ = return () + +doOutput :: String -> (Handle -> IO a) -> IO a +doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action + +{- +************************************************************************ +* * +\subsection{C} +* * +************************************************************************ +-} + +outputC :: Logger + -> DynFlags + -> FilePath + -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream + -- See Note [Deterministic Uniques in the CG] + -> CgStream RawCmmGroup a + -> Set UnitId + -> IO a +outputC logger dflags filenm dus cmm_stream unit_deps = + withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do + let pkg_names = map unitIdString (Set.toAscList unit_deps) + doOutput filenm $ \ h -> fmap fst $ runUDSMT dus $ do + liftIO $ do + hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") + hPutStr h "#include \"Stg.h\"\n" + let platform = targetPlatform dflags + writeC cmm = do + let doc = cmmToC platform cmm + putDumpFileMaybe logger Opt_D_dump_c_backend + "C backend output" + FormatC + doc + let ctx = initSDocContext dflags PprCode + printSDocLn ctx LeftMode h doc + Stream.consume cmm_stream id (liftIO . writeC) + +{- +************************************************************************ +* * +\subsection{Assembler} +* * +************************************************************************ +-} + +outputAsm :: Logger + -> DynFlags + -> Module + -> ModLocation + -> FilePath + -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream + -- See Note [Deterministic Uniques in the CG] + -> CgStream RawCmmGroup a + -> IO a +outputAsm logger dflags this_mod location filenm dus cmm_stream = do + -- Update tag of uniques in Stream + debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm) + let ncg_config = initNCGConfig dflags this_mod + {-# SCC "OutputAsm" #-} doOutput filenm $ + \h -> {-# SCC "NativeCodeGen" #-} + fmap fst $ + runUDSMT dus $ setTagUDSMT 'n' $ + nativeCodeGen logger (toolSettings dflags) ncg_config location h cmm_stream + +{- +************************************************************************ +* * +\subsection{LLVM} +* * +************************************************************************ +-} + +outputLlvm :: Logger -> LlvmConfigCache -> DynFlags -> FilePath + -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream + -- See Note [Deterministic Uniques in the CG] + -> CgStream RawCmmGroup a -> IO a +outputLlvm logger llvm_config dflags filenm dus cmm_stream = do + lcg_config <- initLlvmCgConfig logger llvm_config dflags + {-# SCC "llvm_output" #-} doOutput filenm $ + \f -> {-# SCC "llvm_CodeGen" #-} + llvmCodeGen logger lcg_config f dus cmm_stream + +{- +************************************************************************ +* * +\subsection{JavaScript} +* * +************************************************************************ +-} +outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> CgStream RawCmmGroup a -> IO a +outputJS _ _ _ _ _ = pgmError $ "codeOutput: Hit JavaScript case. We should never reach here!" + ++ "\nThe JS backend should shortcircuit to StgToJS after Stg." + ++ "\nIf you reached this point then you've somehow made it to Cmm!" + +{- +************************************************************************ +* * +\subsection{Foreign import/export} +* * +************************************************************************ +-} + +{- +Note [Packaging libffi headers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The C code emitted by GHC for libffi adjustors must depend upon the ffi_arg type, +defined in . For this reason, we must ensure that is available +in binary distributions. To do so, we install these headers as part of the +`rts` package. +-} + +outputForeignStubs + :: Logger + -> TmpFs + -> DynFlags + -> UnitState + -> Module + -> ModLocation + -> ForeignStubs + -> IO (Bool, -- Header file created + Maybe FilePath) -- C file created +outputForeignStubs logger tmpfs dflags unit_state mod location stubs + = do + stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" + + case stubs of + NoStubs -> + return (False, Nothing) + + ForeignStubs (CHeader h_code) (CStub c_code _ _) -> do + let + stub_c_output_d = pprCode c_code + stub_c_output_w = showSDoc dflags stub_c_output_d + + -- Header file protos for "foreign export"ed functions. + stub_h_output_d = pprCode h_code + stub_h_output_w = showSDoc dflags stub_h_output_d + + putDumpFileMaybe logger Opt_D_dump_foreign + "Foreign export header file" + FormatC + stub_h_output_d + + -- we need the #includes from the rts package for the stub files + let rts_includes = + let mrts_pkg = lookupUnitId unit_state rtsUnitId + mk_include i = "#include \"" ++ ST.unpack i ++ "\"\n" + in case mrts_pkg of + Just rts_pkg -> concatMap mk_include (unitIncludes rts_pkg) + -- This case only happens when compiling foreign stub for the rts + -- library itself. The only time we do this at the moment is for + -- IPE information for the RTS info tables + Nothing -> "" + + -- wrapper code mentions the ffi_arg type, which comes from ffi.h + ffi_includes + | platformMisc_libFFI $ platformMisc dflags = "#include \"rts/ghc_ffi.h\"\n" + | otherwise = "" + + -- The header path is computed from the module source path, which + -- does not exist when loading interface core bindings for Template + -- Haskell for non-home modules (e.g. when compiling in separate + -- invocations of oneshot mode). + -- Stub headers are only generated for foreign exports. + -- Since those aren't supported for TH with bytecode at the moment, + -- it doesn't make much of a difference. + -- In any case, if a stub dir was specified explicitly by the user, it + -- would be used nonetheless. + stub_h_file_exists <- + case mkStubPaths (initFinderOpts dflags) (moduleName mod) location of + Nothing -> pure False + Just path -> do + let stub_h = unsafeDecodeUtf path + createDirectoryIfMissing True (takeDirectory stub_h) + outputForeignStubs_help stub_h stub_h_output_w + ("#include \n" ++ cplusplus_hdr) cplusplus_ftr + + putDumpFileMaybe logger Opt_D_dump_foreign + "Foreign export stubs" FormatC stub_c_output_d + + stub_c_file_exists + <- outputForeignStubs_help stub_c stub_c_output_w + ("#define IN_STG_CODE 0\n" ++ + "#include \n" ++ + rts_includes ++ + ffi_includes ++ + cplusplus_hdr) + cplusplus_ftr + -- We're adding the default hc_header to the stub file, but this + -- isn't really HC code, so we need to define IN_STG_CODE==0 to + -- avoid the register variables etc. being enabled. + + return (stub_h_file_exists, if stub_c_file_exists + then Just stub_c + else Nothing ) + where + cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n" + cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n" + + +-- It is more than likely that the stubs file will +-- turn out to be empty, in which case no file should be created. +outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool +outputForeignStubs_help _fname "" _header _footer = return False +outputForeignStubs_help fname doc_str header footer + = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") + return True + +-- ----------------------------------------------------------------------------- +-- Initialising cost centres + +-- We must produce declarations for the cost-centres defined in this +-- module; + +-- | Generate code to initialise cost centres +profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub +profilingInitCode platform this_mod (local_CCs, singleton_CCSs) + = {-# SCC profilingInitCode #-} + initializerCStub platform fn_name decls body + where + pdocC = pprCLabel platform + fn_name = mkInitializerStubLabel this_mod (fsLit "prof_init") + decls = vcat + $ map emit_cc_decl local_CCs + ++ map emit_ccs_decl singleton_CCSs + ++ [emit_cc_list local_CCs] + ++ [emit_ccs_list singleton_CCSs] + body = vcat + [ text "registerCcList" <> parens local_cc_list_label <> semi + , text "registerCcsList" <> parens singleton_cc_list_label <> semi + ] + emit_cc_decl cc = + text "extern CostCentre" <+> cc_lbl <> text "[];" + where cc_lbl = pdocC (mkCCLabel cc) + local_cc_list_label = text "local_cc_" <> ppr this_mod + emit_cc_list ccs = + text "static CostCentre *" <> local_cc_list_label <> text "[] =" + <+> braces (vcat $ [ pdocC (mkCCLabel cc) <> comma + | cc <- ccs + ] ++ [text "NULL"]) + <> semi + + emit_ccs_decl ccs = + text "extern CostCentreStack" <+> ccs_lbl <> text "[];" + where ccs_lbl = pdocC (mkCCSLabel ccs) + singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod + emit_ccs_list ccs = + text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] =" + <+> braces (vcat $ [ pdocC (mkCCSLabel cc) <> comma + | cc <- ccs + ] ++ [text "NULL"]) + <> semi + +-- | Generate code to initialise info pointer origin +-- See Note [Mapping Info Tables to Source Positions] +ipInitCode + :: Bool -- is Opt_InfoTableMap enabled or not + -> Platform + -> Module + -> CStub +ipInitCode do_info_table platform this_mod + | not do_info_table = mempty + | otherwise = initializerCStub platform fn_nm ipe_buffer_decl body + where + fn_nm = mkInitializerStubLabel this_mod (fsLit "ip_init") + + body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi + + ipe_buffer_label = pprCLabel platform (mkIPELabel this_mod) + + ipe_buffer_decl = + text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";" diff --git a/GHC/Driver/Config.hs b/GHC/Driver/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config.hs @@ -0,0 +1,57 @@ +-- | Subsystem configuration +module GHC.Driver.Config + ( initOptCoercionOpts + , initSimpleOpts + , initEvalOpts + , EvalStep(..) + ) +where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Core.SimpleOpt +import GHC.Core.Coercion.Opt +import GHCi.Message (EvalOpts(..)) + +-- | Initialise coercion optimiser configuration from DynFlags +initOptCoercionOpts :: DynFlags -> OptCoercionOpts +initOptCoercionOpts dflags = OptCoercionOpts + { optCoercionEnabled = not (hasNoOptCoercion dflags) + } + +-- | Initialise Simple optimiser configuration from DynFlags +initSimpleOpts :: DynFlags -> SimpleOpts +initSimpleOpts dflags = SimpleOpts + { so_uf_opts = unfoldingOpts dflags + , so_co_opts = initOptCoercionOpts dflags + , so_eta_red = gopt Opt_DoEtaReduction dflags + , so_inline = True + } + +-- | Instruct the interpreter evaluation to break... +data EvalStep + -- | ... at every breakpoint tick + = EvalStepSingle + -- | ... after any evaluation to WHNF + -- (See Note [Debugger: Step-out]) + | EvalStepOut + -- | ... only on explicit breakpoints + | EvalStepNone + +-- | Extract GHCi options from DynFlags and step +initEvalOpts :: DynFlags -> EvalStep -> EvalOpts +initEvalOpts dflags step = + EvalOpts + { useSandboxThread = gopt Opt_GhciSandbox dflags + , singleStep = singleStep + , stepOut = stepOut + , breakOnException = gopt Opt_BreakOnException dflags + , breakOnError = gopt Opt_BreakOnError dflags + } + where + (singleStep, stepOut) = case step of + EvalStepSingle -> (True, False) + EvalStepOut -> (False, True) + EvalStepNone -> (False, False) + diff --git a/GHC/Driver/Config/Cmm.hs b/GHC/Driver/Config/Cmm.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Cmm.hs @@ -0,0 +1,28 @@ +module GHC.Driver.Config.Cmm + ( initCmmConfig + ) where + +import GHC.Cmm.Config + +import GHC.Driver.DynFlags +import GHC.Driver.Backend + +import GHC.Platform + +import GHC.Prelude + +initCmmConfig :: DynFlags -> CmmConfig +initCmmConfig dflags = CmmConfig + { cmmProfile = targetProfile dflags + , cmmOptControlFlow = gopt Opt_CmmControlFlow dflags + , cmmDoLinting = gopt Opt_DoCmmLinting dflags + , cmmOptElimCommonBlks = gopt Opt_CmmElimCommonBlocks dflags + , cmmOptSink = gopt Opt_CmmSink dflags + , cmmOptThreadSanitizer = gopt Opt_CmmThreadSanitizer dflags + , cmmGenStackUnwindInstr = debugLevel dflags > 0 + , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags + , cmmDoCmmSwitchPlans = not (backendHasNativeSwitch (backend dflags)) + , cmmSplitProcPoints = not (backendSupportsUnsplitProcPoints (backend dflags)) + || not (platformTablesNextToCode platform) + } + where platform = targetPlatform dflags diff --git a/GHC/Driver/Config/Cmm/Parser.hs b/GHC/Driver/Config/Cmm/Parser.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Cmm/Parser.hs @@ -0,0 +1,25 @@ +module GHC.Driver.Config.Cmm.Parser + ( initCmmParserConfig + ) where + +import GHC.Cmm.Parser.Config + +import GHC.Driver.Config.Parser +import GHC.Driver.Config.StgToCmm +import GHC.Driver.DynFlags + +import GHC.Utils.Panic + +initPDConfig :: DynFlags -> PDConfig +initPDConfig dflags = PDConfig + { pdProfile = targetProfile dflags + , pdSanitizeAlignment = gopt Opt_AlignmentSanitisation dflags + } + +initCmmParserConfig :: DynFlags -> CmmParserConfig +initCmmParserConfig dflags = CmmParserConfig + { cmmpParserOpts = initParserOpts dflags + , cmmpPDConfig = initPDConfig dflags + , cmmpStgToCmmConfig = initStgToCmmConfig dflags (panic "initCmmParserConfig: no module") + } + diff --git a/GHC/Driver/Config/CmmToAsm.hs b/GHC/Driver/Config/CmmToAsm.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/CmmToAsm.hs @@ -0,0 +1,79 @@ +module GHC.Driver.Config.CmmToAsm + ( initNCGConfig + ) +where + +import GHC.Prelude + +import GHC.Driver.DynFlags + +import GHC.Platform +import GHC.Unit.Types (Module) +import GHC.CmmToAsm.Config +import GHC.Utils.Outputable +import GHC.CmmToAsm.BlockLayout + +-- | Initialize the native code generator configuration from the DynFlags +initNCGConfig :: DynFlags -> Module -> NCGConfig +initNCGConfig dflags this_mod = NCGConfig + { ncgPlatform = targetPlatform dflags + , ncgThisModule = this_mod + , ncgAsmContext = initSDocContext dflags PprCode + , ncgProcAlignment = cmmProcAlignment dflags + , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags + , ncgPIC = positionIndependent dflags + , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags + , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags + , ncgSplitSections = gopt Opt_SplitSections dflags + , ncgRegsIterative = gopt Opt_RegsIterative dflags + , ncgRegsGraph = gopt Opt_RegsGraph dflags + , ncgAsmLinting = gopt Opt_DoAsmLinting dflags + , ncgCfgWeights = cfgWeights dflags + , ncgCfgBlockLayout = gopt Opt_CfgBlocklayout dflags + , ncgCfgWeightlessLayout = gopt Opt_WeightlessBlocklayout dflags + + -- When constant-folding is enabled, the cmmSink pass does constant-folding, so + -- we don't need to do it again in the native code generator. + , ncgDoConstantFolding = not (gopt Opt_CoreConstantFolding dflags || gopt Opt_CmmSink dflags) + + , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags + , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags + , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags + , ncgBmiVersion = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags + ArchX86 -> bmiVersion dflags + _ -> Nothing + + -- We assume SSE1 and SSE2 operations are available on both + -- x86 and x86_64. Historically we didn't default to SSE2 and + -- SSE1 on x86, which results in defacto nondeterminism for how + -- rounding behaves in the associated x87 floating point instructions + -- because variations in the spill/fpu stack placement of arguments for + -- operations would change the precision and final result of what + -- would otherwise be the same expressions with respect to single or + -- double precision IEEE floating point computations. + , ncgSseVersion = + let v | sseVersion dflags < Just SSE2 = Just SSE2 + | otherwise = sseVersion dflags + in case platformArch (targetPlatform dflags) of + ArchX86_64 -> v + ArchX86 -> v + _ -> Nothing + , ncgAvxEnabled = isAvxEnabled dflags + , ncgAvx2Enabled = isAvx2Enabled dflags + , ncgAvx512fEnabled = isAvx512fEnabled dflags + + , ncgDwarfEnabled = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64 + , ncgDwarfUnwindings = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 + , ncgDwarfStripBlockInfo = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1. + , ncgDwarfSourceNotes = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3 + , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags + , ncgCmmStaticPred = gopt Opt_CmmStaticPred dflags + , ncgEnableShortcutting = gopt Opt_AsmShortcutting dflags + , ncgEnableInterModuleFarJumps = gopt Opt_InterModuleFarJumps dflags + , ncgComputeUnwinding = debugLevel dflags > 0 + , ncgEnableDeadCodeElimination = not (gopt Opt_InfoTableMap dflags) + -- Disable when -finfo-table-map is on (#20428) + && backendMaintainsCfg (targetPlatform dflags) + -- Enable if the platform maintains the CFG + } diff --git a/GHC/Driver/Config/CmmToLlvm.hs b/GHC/Driver/Config/CmmToLlvm.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/CmmToLlvm.hs @@ -0,0 +1,35 @@ +module GHC.Driver.Config.CmmToLlvm + ( initLlvmCgConfig + ) +where + +import GHC.Prelude +import GHC.Driver.DynFlags +import GHC.Driver.LlvmConfigCache +import GHC.Platform +import GHC.CmmToLlvm.Config +import GHC.SysTools.Tasks + +import GHC.Utils.Outputable +import GHC.Utils.Logger + +-- | Initialize the Llvm code generator configuration from DynFlags +initLlvmCgConfig :: Logger -> LlvmConfigCache -> DynFlags -> IO LlvmCgConfig +initLlvmCgConfig logger config_cache dflags = do + version <- figureLlvmVersion logger dflags + llvm_config <- readLlvmConfigCache config_cache + pure $! LlvmCgConfig { + llvmCgPlatform = targetPlatform dflags + , llvmCgContext = initSDocContext dflags PprCode + , llvmCgFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags + , llvmCgSplitSection = gopt Opt_SplitSections dflags + , llvmCgAvxEnabled = isAvxEnabled dflags + , llvmCgBmiVersion = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags + ArchX86 -> bmiVersion dflags + _ -> Nothing + , llvmCgLlvmVersion = version + , llvmCgDoWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags + , llvmCgLlvmTarget = platformMisc_llvmTarget $! platformMisc dflags + , llvmCgLlvmConfig = llvm_config + } diff --git a/GHC/Driver/Config/Core/Lint.hs b/GHC/Driver/Config/Core/Lint.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Lint.hs @@ -0,0 +1,181 @@ +module GHC.Driver.Config.Core.Lint + ( endPass + , endPassHscEnvIO + , lintCoreBindings + , initEndPassConfig + , initLintPassResultConfig + , initLintConfig + ) where + +import GHC.Prelude + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Driver.Config.Diagnostic + +import GHC.Core +import GHC.Core.Lint +import GHC.Core.Lint.Interactive +import GHC.Core.Opt.Pipeline.Types +import GHC.Core.Opt.Simplify ( SimplifyOpts(..) ) +import GHC.Core.Opt.Simplify.Env ( SimplMode(..) ) +import GHC.Core.Opt.Monad +import GHC.Core.Coercion + +import GHC.Types.Basic ( CompilerPhase(..) ) + +import GHC.Utils.Outputable as Outputable + +{- +These functions are not CoreM monad stuff, but they probably ought to +be, and it makes a convenient place for them. They print out stuff +before and after core passes, and do Core Lint when necessary. +-} + +endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () +endPass pass binds rules + = do { hsc_env <- getHscEnv + ; name_ppr_ctx <- getNamePprCtx + ; liftIO $ endPassHscEnvIO hsc_env + name_ppr_ctx pass binds rules + } + +endPassHscEnvIO :: HscEnv -> NamePprCtx + -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () +endPassHscEnvIO hsc_env name_ppr_ctx pass binds rules + = do { let dflags = hsc_dflags hsc_env + ; endPassIO + (hsc_logger hsc_env) + (initEndPassConfig dflags (interactiveInScope $ hsc_IC hsc_env) name_ppr_ctx pass) + binds rules + } + +-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. +lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs +lintCoreBindings dflags coreToDo vars -- binds + = lintCoreBindings' $ LintConfig + { l_diagOpts = initDiagOpts dflags + , l_platform = targetPlatform dflags + , l_flags = perPassFlags dflags coreToDo + , l_vars = vars + } + +initEndPassConfig :: DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig +initEndPassConfig dflags extra_vars name_ppr_ctx pass = EndPassConfig + { ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags) + , ep_lintPassResult = if gopt Opt_DoCoreLinting dflags + then Just $ initLintPassResultConfig dflags extra_vars pass + else Nothing + , ep_namePprCtx = name_ppr_ctx + , ep_dumpFlag = coreDumpFlag pass + , ep_prettyPass = ppr pass + , ep_passDetails = pprPassDetails pass + } + +coreDumpFlag :: CoreToDo -> Maybe DumpFlag +coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoFloatInwards = Just Opt_D_dump_float_in +coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_dump_float_out +coreDumpFlag CoreLiberateCase = Just Opt_D_dump_liberate_case +coreDumpFlag CoreDoStaticArgs = Just Opt_D_dump_static_argument_transformation +coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity +coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify +coreDumpFlag (CoreDoDemand {}) = Just Opt_D_dump_dmdanal +coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal +coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper +coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec +coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec_constr +coreDumpFlag CoreCSE = Just Opt_D_dump_cse +coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt +coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds +coreDumpFlag CoreTidy = Just Opt_D_dump_simpl +coreDumpFlag CorePrep = Just Opt_D_dump_prep + +coreDumpFlag CoreAddCallerCcs = Nothing +coreDumpFlag CoreAddLateCcs = Nothing +coreDumpFlag CoreDoPrintCore = Nothing +coreDumpFlag (CoreDoRuleCheck {}) = Nothing +coreDumpFlag CoreDoNothing = Nothing +coreDumpFlag (CoreDoPasses {}) = Nothing + +initLintPassResultConfig :: DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig +initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig + { lpr_diagOpts = initDiagOpts dflags + , lpr_platform = targetPlatform dflags + , lpr_makeLintFlags = perPassFlags dflags pass + , lpr_showLintWarnings = showLintWarnings pass + , lpr_passPpr = ppr pass + , lpr_localsInScope = extra_vars + } + +showLintWarnings :: CoreToDo -> Bool +-- Disable Lint warnings on the first simplifier pass, because +-- there may be some INLINE knots still tied, which is tiresomely noisy +showLintWarnings (CoreDoSimplify cfg) = case sm_phase (so_mode cfg) of + InitialPhase -> False + _ -> True +showLintWarnings _ = True + +perPassFlags :: DynFlags -> CoreToDo -> LintFlags +perPassFlags dflags pass + = (defaultLintFlags dflags) + { lf_check_global_ids = check_globals + , lf_check_inline_loop_breakers = check_lbs + , lf_check_static_ptrs = check_static_ptrs + , lf_check_linearity = check_linearity + , lf_check_fixed_rep = check_fixed_rep } + where + -- In the output of the desugarer, before optimisation, + -- we have eta-expanded data constructors with representation-polymorphic + -- bindings; so we switch off the representation-polymorphism checks. + -- The very simple optimiser will beta-reduce them away. + -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete + check_fixed_rep = case pass of + CoreDesugar -> False + _ -> True + + -- See Note [Checking for global Ids] + check_globals = case pass of + CoreTidy -> False + CorePrep -> False + _ -> True + + -- See Note [Checking for INLINE loop breakers] + check_lbs = case pass of + CoreDesugar -> False + CoreDesugarOpt -> False + _ -> True + + -- See Note [Checking StaticPtrs] + check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere + | otherwise = case pass of + CoreDoFloatOutwards _ -> AllowAtTopLevel + CoreTidy -> RejectEverywhere + CorePrep -> AllowAtTopLevel + _ -> AllowAnywhere + + -- See Note [Linting linearity] + check_linearity = gopt Opt_DoLinearCoreLinting dflags || ( + case pass of + CoreDesugar -> True + _ -> False) + +initLintConfig :: DynFlags -> [Var] -> LintConfig +initLintConfig dflags vars =LintConfig + { l_diagOpts = initDiagOpts dflags + , l_platform = targetPlatform dflags + , l_flags = defaultLintFlags dflags + , l_vars = vars + } + +defaultLintFlags :: DynFlags -> LintFlags +defaultLintFlags dflags = LF { lf_check_global_ids = False + , lf_check_inline_loop_breakers = True + , lf_check_static_ptrs = AllowAnywhere + , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags + , lf_report_unsat_syns = True + , lf_check_fixed_rep = True + } diff --git a/GHC/Driver/Config/Core/Lint/Interactive.hs b/GHC/Driver/Config/Core/Lint/Interactive.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Lint/Interactive.hs @@ -0,0 +1,35 @@ +module GHC.Driver.Config.Core.Lint.Interactive + ( lintInteractiveExpr + ) where + +import GHC.Prelude + +import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Driver.Config.Core.Lint + +import GHC.Core +import GHC.Core.Ppr + +import GHC.Core.Lint +import GHC.Core.Lint.Interactive + +--import GHC.Runtime.Context + +import GHC.Data.Bag + +import GHC.Utils.Outputable as Outputable + +lintInteractiveExpr :: SDoc -- ^ The source of the linted expression + -> HscEnv + -> CoreExpr -> IO () +lintInteractiveExpr what hsc_env expr + | not (gopt Opt_DoCoreLinting dflags) + = return () + | Just err <- lintExpr (initLintConfig dflags $ interactiveInScope $ hsc_IC hsc_env) expr + = displayLintResults logger False what (pprCoreExpr expr) (emptyBag, err) + | otherwise + = return () + where + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env diff --git a/GHC/Driver/Config/Core/Opt/Arity.hs b/GHC/Driver/Config/Core/Opt/Arity.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Opt/Arity.hs @@ -0,0 +1,15 @@ +module GHC.Driver.Config.Core.Opt.Arity + ( initArityOpts + ) where + +import GHC.Prelude () + +import GHC.Driver.DynFlags + +import GHC.Core.Opt.Arity + +initArityOpts :: DynFlags -> ArityOpts +initArityOpts dflags = ArityOpts + { ao_ped_bot = gopt Opt_PedanticBottoms dflags + , ao_dicts_cheap = gopt Opt_DictsCheap dflags + } diff --git a/GHC/Driver/Config/Core/Opt/LiberateCase.hs b/GHC/Driver/Config/Core/Opt/LiberateCase.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Opt/LiberateCase.hs @@ -0,0 +1,15 @@ +module GHC.Driver.Config.Core.Opt.LiberateCase + ( initLiberateCaseOpts + ) where + +import GHC.Driver.DynFlags + +import GHC.Core.Opt.LiberateCase ( LibCaseOpts(..) ) + +-- | Initialize configuration for the liberate case Core optimization +-- pass. +initLiberateCaseOpts :: DynFlags -> LibCaseOpts +initLiberateCaseOpts dflags = LibCaseOpts + { lco_threshold = liberateCaseThreshold dflags + , lco_unfolding_opts = unfoldingOpts dflags + } diff --git a/GHC/Driver/Config/Core/Opt/Simplify.hs b/GHC/Driver/Config/Core/Opt/Simplify.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Opt/Simplify.hs @@ -0,0 +1,126 @@ +module GHC.Driver.Config.Core.Opt.Simplify + ( initSimplifyExprOpts + , initSimplifyOpts + , initSimplMode + , initGentleSimplMode + ) where + +import GHC.Prelude + +import GHC.Core.Rules ( RuleBase ) +import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) +import GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) ) +import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..) ) +import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) ) + +import GHC.Driver.Config ( initOptCoercionOpts ) +import GHC.Driver.Config.Core.Lint ( initLintPassResultConfig ) +import GHC.Driver.Config.Core.Rules ( initRuleOpts ) +import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts ) +import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag(..), gopt ) + +import GHC.Runtime.Context ( InteractiveContext(..) ) + +import GHC.Types.Basic ( CompilerPhase(..) ) +import GHC.Types.Var ( Var ) + +initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts +initSimplifyExprOpts dflags ic = SimplifyExprOpts + { se_fam_inst = snd $ ic_instances ic + , se_mode = (initSimplMode dflags InitialPhase "GHCi") + { sm_inline = False + -- Do not do any inlining, in case we expose some + -- unboxed tuple stuff that confuses the bytecode + -- interpreter + } + , se_top_env_cfg = TopEnvConfig + { te_history_size = historySize dflags + , te_tick_factor = simplTickFactor dflags + } + } + +initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts +initSimplifyOpts dflags extra_vars iterations mode hpt_rule_base = let + -- This is a particularly ugly construction, but we will get rid of it in !8341. + opts = SimplifyOpts + { so_dump_core_sizes = not $ gopt Opt_SuppressCoreSizes dflags + , so_iterations = iterations + , so_mode = mode + , so_pass_result_cfg = if gopt Opt_DoCoreLinting dflags + then Just $ initLintPassResultConfig dflags extra_vars + (CoreDoSimplify opts) + else Nothing + , so_hpt_rules = hpt_rule_base + , so_top_env_cfg = TopEnvConfig { te_history_size = historySize dflags + , te_tick_factor = simplTickFactor dflags } + } + in opts + +initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode +initSimplMode dflags phase name = SimplMode + { sm_names = [name] + , sm_phase = phase + , sm_rules = gopt Opt_EnableRewriteRules dflags + , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags + , sm_cast_swizzle = True + , sm_inline = True + , sm_uf_opts = unfoldingOpts dflags + , sm_case_case = True + , sm_pre_inline = gopt Opt_SimplPreInlining dflags + , sm_float_enable = floatEnable dflags + , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags + , sm_arity_opts = initArityOpts dflags + , sm_rule_opts = initRuleOpts dflags + , sm_case_folding = gopt Opt_CaseFolding dflags + , sm_case_merge = gopt Opt_CaseMerge dflags + , sm_co_opt_opts = initOptCoercionOpts dflags + } + +initGentleSimplMode :: DynFlags -> SimplMode +initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle") + { -- Don't do case-of-case transformations. + -- This makes full laziness work better + -- See Note [Case-of-case and full laziness] + sm_case_case = False + } + +floatEnable :: DynFlags -> FloatEnable +floatEnable dflags = + case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of + (True, True) -> FloatEnabled + (True, False)-> FloatNestedOnly + (False, _) -> FloatDisabled + + +{- Note [Case-of-case and full laziness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case-of-case can hide opportunities for let-floating (full laziness). +For example + rec { f = \y. case (expensive x) of (a,b) -> blah } +We might hope to float the (expensive x) out of the \y-loop. +But if we inline `expensive` we might get + \y. case (case x of I# x' -> body) of (a,b) -> blah +Now if we do case-of-case we get + \y. case x if I# x2 -> + case body of (a,b) -> blah + +Sadly, at this point `body` mentions `x2`, so we can't float it out of the +\y-loop. + +Solution: don't do case-of-case in the "gentle" simplification phase that +precedes the first float-out transformation. Implementation: + + * `sm_case_case` field in SimplMode + + * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case + in GHC.Core.Opt.Simplify.Iteration.rebuildCall. + +Wrinkles + +* This applies equally to the case-of-runRW# transformation: + case (runRW# (\s. body)) of (a,b) -> blah + ---> + runRW# (\s. case body of (a,b) -> blah) + Again, don't do this when `sm_case_case` is off. See #25055 for + a motivating example. +-} diff --git a/GHC/Driver/Config/Core/Opt/WorkWrap.hs b/GHC/Driver/Config/Core/Opt/WorkWrap.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Opt/WorkWrap.hs @@ -0,0 +1,21 @@ +module GHC.Driver.Config.Core.Opt.WorkWrap + ( initWorkWrapOpts + ) where + +import GHC.Prelude () + +import GHC.Driver.Config (initSimpleOpts) +import GHC.Driver.DynFlags + +import GHC.Core.FamInstEnv +import GHC.Core.Opt.WorkWrap +import GHC.Unit.Types + +initWorkWrapOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts +initWorkWrapOpts this_mod dflags fam_envs = MkWwOpts + { wo_fam_envs = fam_envs + , wo_simple_opts = initSimpleOpts dflags + , wo_cpr_anal = gopt Opt_CprAnal dflags + , wo_module = this_mod + , wo_unlift_strict = gopt Opt_WorkerWrapperUnlift dflags + } diff --git a/GHC/Driver/Config/Core/Rules.hs b/GHC/Driver/Config/Core/Rules.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Rules.hs @@ -0,0 +1,19 @@ +module GHC.Driver.Config.Core.Rules + ( initRuleOpts + ) where + +import GHC.Prelude + +import GHC.Driver.Flags +import GHC.Driver.DynFlags ( DynFlags, gopt, targetPlatform ) + +import GHC.Core.Rules.Config + +-- | Initialize RuleOpts from DynFlags +initRuleOpts :: DynFlags -> RuleOpts +initRuleOpts dflags = RuleOpts + { roPlatform = targetPlatform dflags + , roNumConstantFolding = gopt Opt_NumConstantFolding dflags + , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags + , roBignumRules = True + } diff --git a/GHC/Driver/Config/CoreToStg.hs b/GHC/Driver/Config/CoreToStg.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/CoreToStg.hs @@ -0,0 +1,16 @@ +module GHC.Driver.Config.CoreToStg where + +import GHC.Driver.Config.Stg.Debug +import GHC.Driver.DynFlags + +import GHC.CoreToStg + +initCoreToStgOpts :: DynFlags -> CoreToStgOpts +initCoreToStgOpts dflags = CoreToStgOpts + { coreToStg_platform = targetPlatform dflags + , coreToStg_ways = ways dflags + , coreToStg_AutoSccsOnIndividualCafs = gopt Opt_AutoSccsOnIndividualCafs dflags + , coreToStg_InfoTableMap = gopt Opt_InfoTableMap dflags + , coreToStg_ExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags + , coreToStg_stgDebugOpts = initStgDebugOpts dflags + } diff --git a/GHC/Driver/Config/CoreToStg/Prep.hs b/GHC/Driver/Config/CoreToStg/Prep.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/CoreToStg/Prep.hs @@ -0,0 +1,35 @@ +module GHC.Driver.Config.CoreToStg.Prep + ( initCorePrepConfig + , initCorePrepPgmConfig + ) where + +import GHC.Prelude + +import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Config.Core.Lint +import GHC.Driver.Config.Core.Opt.Arity +import GHC.Types.Var +import GHC.Utils.Outputable ( alwaysQualify ) + +import GHC.CoreToStg.Prep + +initCorePrepConfig :: HscEnv -> IO CorePrepConfig +initCorePrepConfig hsc_env = do + let dflags = hsc_dflags hsc_env + return $ CorePrepConfig + { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases dflags + , cp_platform = targetPlatform dflags + , cp_arityOpts = if gopt Opt_DoCleverArgEtaExpansion dflags + then Just (initArityOpts dflags) + else Nothing + , cp_specEval = gopt Opt_SpecEval dflags + , cp_specEvalDFun = gopt Opt_SpecEvalDictFun dflags + } + +initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig +initCorePrepPgmConfig dflags extra_vars = CorePrepPgmConfig + { cpPgm_endPassConfig = initEndPassConfig dflags extra_vars alwaysQualify CorePrep + , cpPgm_generateDebugInfo = needSourceNotes dflags + } diff --git a/GHC/Driver/Config/Diagnostic.hs b/GHC/Driver/Config/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Diagnostic.hs @@ -0,0 +1,69 @@ + +-- | Functions for initialising error message printing configuration from the +-- GHC session flags. +module GHC.Driver.Config.Diagnostic + ( initDiagOpts + , initPrintConfig + , initPsMessageOpts + , initDsMessageOpts + , initTcMessageOpts + , initDriverMessageOpts + , initIfaceMessageOpts + ) +where + +import GHC.Driver.Flags +import GHC.Driver.DynFlags +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Utils.Error (DiagOpts (..)) +import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..), checkBuildingCabalPackage) +import GHC.Driver.Errors.Ppr () -- Diagnostic instances +import GHC.Tc.Errors.Types +import GHC.HsToCore.Errors.Types +import GHC.Types.Error +import GHC.Iface.Errors.Types + +-- | Initialise the general configuration for printing diagnostic messages +-- For example, this configuration controls things like whether warnings are +-- treated like errors. +initDiagOpts :: DynFlags -> DiagOpts +initDiagOpts dflags = DiagOpts + { diag_warning_flags = warningFlags dflags + , diag_fatal_warning_flags = fatalWarningFlags dflags + , diag_custom_warning_categories = customWarningCategories dflags + , diag_fatal_custom_warning_categories = fatalCustomWarningCategories dflags + , diag_warn_is_error = gopt Opt_WarnIsError dflags + , diag_reverse_errors = reverseErrors dflags + , diag_max_errors = maxErrors dflags + , diag_ppr_ctx = initSDocContext dflags defaultErrStyle + } + +-- | Initialise the configuration for printing specific diagnostic messages +initPrintConfig :: DynFlags -> DiagnosticOpts GhcMessage +initPrintConfig dflags = + GhcMessageOpts { psMessageOpts = initPsMessageOpts dflags + , tcMessageOpts = initTcMessageOpts dflags + , dsMessageOpts = initDsMessageOpts dflags + , driverMessageOpts= initDriverMessageOpts dflags } + +initPsMessageOpts :: DynFlags -> DiagnosticOpts PsMessage +initPsMessageOpts _ = NoDiagnosticOpts + +initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage +initTcMessageOpts dflags = + TcRnMessageOpts { tcOptsShowContext = gopt Opt_ShowErrorContext dflags + , tcOptsIfaceOpts = initIfaceMessageOpts dflags } + +initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage +initDsMessageOpts _ = NoDiagnosticOpts + +initIfaceMessageOpts :: DynFlags -> DiagnosticOpts IfaceMessage +initIfaceMessageOpts dflags = + IfaceMessageOpts { ifaceShowTriedFiles = verbosity dflags >= 3 + , ifaceBuildingCabalPackage = checkBuildingCabalPackage dflags } + +initDriverMessageOpts :: DynFlags -> DiagnosticOpts DriverMessage +initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags) (initIfaceMessageOpts dflags) + diff --git a/GHC/Driver/Config/Finder.hs b/GHC/Driver/Config/Finder.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Finder.hs @@ -0,0 +1,35 @@ +module GHC.Driver.Config.Finder ( + FinderOpts(..), + initFinderOpts + ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Unit.Finder.Types +import GHC.Data.FastString +import GHC.Data.OsPath +import qualified Data.Map as Map + +-- | Create a new 'FinderOpts' from DynFlags. +initFinderOpts :: DynFlags -> FinderOpts +initFinderOpts flags = FinderOpts + { finder_importPaths = fmap unsafeEncodeUtf $ importPaths flags + , finder_lookupHomeInterfaces = isOneShot (ghcMode flags) + , finder_bypassHiFileCheck = MkDepend == (ghcMode flags) + , finder_ways = ways flags + , finder_enableSuggestions = gopt Opt_HelpfulErrors flags + , finder_workingDirectory = fmap unsafeEncodeUtf $ workingDirectory flags + , finder_thisPackageName = mkFastString <$> thisPackageName flags + , finder_hiddenModules = hiddenModules flags + , finder_reexportedModules = Map.fromList [(known_as, is_as) | ReexportedModule is_as known_as <- reverse (reexportedModules flags)] + , finder_hieDir = fmap unsafeEncodeUtf $ hieDir flags + , finder_hieSuf = unsafeEncodeUtf $ hieSuf flags + , finder_hiDir = fmap unsafeEncodeUtf $ hiDir flags + , finder_hiSuf = unsafeEncodeUtf $ hiSuf_ flags + , finder_dynHiSuf = unsafeEncodeUtf $ dynHiSuf_ flags + , finder_objectDir = fmap unsafeEncodeUtf $ objectDir flags + , finder_objectSuf = unsafeEncodeUtf $ objectSuf_ flags + , finder_dynObjectSuf = unsafeEncodeUtf $ dynObjectSuf_ flags + , finder_stubDir = fmap unsafeEncodeUtf $ stubDir flags + } diff --git a/GHC/Driver/Config/HsToCore.hs b/GHC/Driver/Config/HsToCore.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/HsToCore.hs @@ -0,0 +1,19 @@ +module GHC.Driver.Config.HsToCore + ( initBangOpts + ) +where + +import GHC.Types.Id.Make +import GHC.Driver.DynFlags +import qualified GHC.LanguageExtensions as LangExt + +initBangOpts :: DynFlags -> BangOpts +initBangOpts dflags = BangOpts + { bang_opt_strict_data = xopt LangExt.StrictData dflags + , bang_opt_unbox_disable = gopt Opt_OmitInterfacePragmas dflags + -- Don't unbox if we aren't optimising; rather arbitrarily, + -- we use -fomit-interface-pragmas as the indication + , bang_opt_unbox_strict = gopt Opt_UnboxStrictFields dflags + , bang_opt_unbox_small = gopt Opt_UnboxSmallStrictFields dflags + } + diff --git a/GHC/Driver/Config/HsToCore/Ticks.hs b/GHC/Driver/Config/HsToCore/Ticks.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/HsToCore/Ticks.hs @@ -0,0 +1,34 @@ +module GHC.Driver.Config.HsToCore.Ticks + ( initTicksConfig + , breakpointsAllowed + ) +where + +import GHC.Prelude + +import Data.Maybe (catMaybes) + +import GHC.Driver.Backend +import GHC.Driver.Session +import GHC.HsToCore.Ticks + +initTicksConfig :: DynFlags -> TicksConfig +initTicksConfig dflags = TicksConfig + { ticks_passes = coveragePasses dflags + , ticks_profAuto = profAuto dflags + , ticks_countEntries = gopt Opt_ProfCountEntries dflags + } + +breakpointsAllowed :: DynFlags -> Bool +breakpointsAllowed dflags = + gopt Opt_InsertBreakpoints dflags && + backendSupportsBreakpoints (backend dflags) + +coveragePasses :: DynFlags -> [TickishType] +coveragePasses dflags = catMaybes + [ ifA Breakpoints $ breakpointsAllowed dflags + , ifA HpcTicks $ gopt Opt_Hpc dflags + , ifA ProfNotes $ sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto + , ifA SourceNotes $ needSourceNotes dflags + ] + where ifA x cond = if cond then Just x else Nothing diff --git a/GHC/Driver/Config/HsToCore/Usage.hs b/GHC/Driver/Config/HsToCore/Usage.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/HsToCore/Usage.hs @@ -0,0 +1,14 @@ +module GHC.Driver.Config.HsToCore.Usage + ( initUsageConfig + ) +where + +import GHC.Driver.Env.Types +import GHC.Driver.Session + +import GHC.HsToCore.Usage + +initUsageConfig :: HscEnv -> UsageConfig +initUsageConfig hsc_env = UsageConfig + { uc_safe_implicit_imps_req = safeImplicitImpsReq (hsc_dflags hsc_env) + } diff --git a/GHC/Driver/Config/Linker.hs b/GHC/Driver/Config/Linker.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Linker.hs @@ -0,0 +1,92 @@ +module GHC.Driver.Config.Linker + ( initFrameworkOpts + , initLinkerConfig + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Linker.Config + +import GHC.Driver.DynFlags +import GHC.Driver.Session + +import Data.List (isPrefixOf) + +initFrameworkOpts :: DynFlags -> FrameworkOpts +initFrameworkOpts dflags = FrameworkOpts + { foFrameworkPaths = frameworkPaths dflags + , foCmdlineFrameworks = cmdlineFrameworks dflags + } + +-- | Initialize linker configuration from DynFlags +initLinkerConfig :: DynFlags -> LinkerConfig +initLinkerConfig dflags = + let + -- see Note [Solaris linker] + ld_filter = case platformOS (targetPlatform dflags) of + OSSolaris2 -> sunos_ld_filter + _ -> id + sunos_ld_filter :: [String] -> [String] + sunos_ld_filter x = if (undefined_found x && ld_warning_found x) + then (ld_prefix x) ++ (ld_postfix x) + else x + breakStartsWith x y = break (isPrefixOf x) y + ld_prefix = fst . breakStartsWith "Undefined" + undefined_found = not . null . snd . breakStartsWith "Undefined" + ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" + ld_postfix = tail . snd . ld_warn_break + ld_warning_found = not . null . snd . ld_warn_break + + -- program and arguments + -- + -- `-optl` args come at the end, so that later `-l` options + -- given there manually can fill in symbols needed by + -- Haskell libraries coming in via `args`. + (p,pre_args) = pgm_l dflags + post_args = map Option (getOpts dflags opt_l) + + in LinkerConfig + { linkerProgram = p + , linkerOptionsPre = pre_args + , linkerOptionsPost = post_args + , linkerTempDir = tmpDir dflags + , linkerFilter = ld_filter + } + +{- Note [Solaris linker] + ~~~~~~~~~~~~~~~~~~~~~ + SunOS/Solaris ld emits harmless warning messages about unresolved + symbols in case of compiling into shared library when we do not + link against all the required libs. That is the case of GHC which + does not link against RTS library explicitly in order to be able to + choose the library later based on binary application linking + parameters. The warnings look like: + +Undefined first referenced + symbol in file +stg_ap_n_fast ./T2386_Lib.o +stg_upd_frame_info ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o +newCAF ./T2386_Lib.o +stg_bh_upd_frame_info ./T2386_Lib.o +stg_ap_ppp_fast ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o +stg_ap_p_fast ./T2386_Lib.o +stg_ap_pp_fast ./T2386_Lib.o +ld: warning: symbol referencing errors + + this is actually coming from T2386 testcase. The emitting of those + warnings is also a reason why so many TH testcases fail on Solaris. + + Following filter code is SunOS/Solaris linker specific and should + filter out only linker warnings. Please note that the logic is a + little bit more complex due to the simple reason that we need to preserve + any other linker emitted messages. If there are any. Simply speaking + if we see "Undefined" and later "ld: warning:..." then we omit all + text between (including) the marks. Otherwise we copy the whole output. +-} + diff --git a/GHC/Driver/Config/Logger.hs b/GHC/Driver/Config/Logger.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Logger.hs @@ -0,0 +1,32 @@ +module GHC.Driver.Config.Logger + ( initLogFlags + ) +where + +import GHC.Prelude + +import GHC.Driver.DynFlags + +import GHC.Utils.Logger (LogFlags (..)) +import GHC.Utils.Outputable + +-- | Initialize LogFlags from DynFlags +initLogFlags :: DynFlags -> LogFlags +initLogFlags dflags = LogFlags + { log_default_user_context = initSDocContext dflags defaultUserStyle + , log_default_dump_context = initSDocContext dflags defaultDumpStyle + , log_dump_flags = dumpFlags dflags + , log_show_caret = gopt Opt_DiagnosticsShowCaret dflags + , log_diagnostics_as_json = gopt Opt_DiagnosticsAsJSON dflags + , log_show_warn_groups = gopt Opt_ShowWarnGroups dflags + , log_enable_timestamps = not (gopt Opt_SuppressTimestamps dflags) + , log_dump_to_file = gopt Opt_DumpToFile dflags + , log_dump_dir = dumpDir dflags + , log_dump_prefix = dumpPrefix dflags + , log_dump_prefix_override = dumpPrefixForce dflags + , log_with_ways = gopt Opt_DumpWithWays dflags + , log_enable_debug = not (hasNoDebugOutput dflags) + , log_verbosity = verbosity dflags + , log_ways = Just $ ways dflags + } + diff --git a/GHC/Driver/Config/Parser.hs b/GHC/Driver/Config/Parser.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Parser.hs @@ -0,0 +1,27 @@ +module GHC.Driver.Config.Parser + ( initParserOpts + , supportedLanguagePragmas + ) +where + +import GHC.Prelude +import GHC.Platform + +import GHC.Driver.Session +import GHC.Driver.Config.Diagnostic + +import GHC.Parser.Lexer + +-- | Extracts the flags needed for parsing +initParserOpts :: DynFlags -> ParserOpts +initParserOpts = + mkParserOpts + <$> extensionFlags + <*> initDiagOpts + <*> safeImportsOn + <*> gopt Opt_Haddock + <*> gopt Opt_KeepRawTokenStream + <*> const True -- use LINE/COLUMN to update the internal location + +supportedLanguagePragmas :: DynFlags -> [String] +supportedLanguagePragmas = supportedLanguagesAndExtensions . platformArchOS . targetPlatform diff --git a/GHC/Driver/Config/Stg/Debug.hs b/GHC/Driver/Config/Stg/Debug.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Stg/Debug.hs @@ -0,0 +1,14 @@ +module GHC.Driver.Config.Stg.Debug + ( initStgDebugOpts + ) where + +import GHC.Stg.Debug + +import GHC.Driver.DynFlags + +-- | Initialize STG pretty-printing options from DynFlags +initStgDebugOpts :: DynFlags -> StgDebugOpts +initStgDebugOpts dflags = StgDebugOpts + { stgDebug_infoTableMap = gopt Opt_InfoTableMap dflags + , stgDebug_distinctConstructorTables = gopt Opt_DistinctConstructorTables dflags + } diff --git a/GHC/Driver/Config/Stg/Lift.hs b/GHC/Driver/Config/Stg/Lift.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Stg/Lift.hs @@ -0,0 +1,15 @@ +module GHC.Driver.Config.Stg.Lift + ( initStgLiftConfig + ) where + +import GHC.Stg.Lift.Config + +import GHC.Driver.DynFlags + +initStgLiftConfig :: DynFlags -> StgLiftConfig +initStgLiftConfig dflags = StgLiftConfig + { c_targetProfile = targetProfile dflags + , c_liftLamsRecArgs = liftLamsRecArgs dflags + , c_liftLamsNonRecArgs = liftLamsNonRecArgs dflags + , c_liftLamsKnown = liftLamsKnown dflags + } diff --git a/GHC/Driver/Config/Stg/Pipeline.hs b/GHC/Driver/Config/Stg/Pipeline.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Stg/Pipeline.hs @@ -0,0 +1,53 @@ +module GHC.Driver.Config.Stg.Pipeline + ( initStgPipelineOpts + ) where + +import GHC.Prelude + +import Control.Monad (guard) + +import GHC.Stg.Pipeline +import GHC.Stg.Utils + +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Stg.Lift +import GHC.Driver.Config.Stg.Ppr +import GHC.Driver.DynFlags + +-- | Initialize STG pretty-printing options from DynFlags +initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts +initStgPipelineOpts dflags for_bytecode = + let !platform = targetPlatform dflags + !ext_dyn_refs = gopt Opt_ExternalDynamicRefs dflags + in StgPipelineOpts + { stgPipeline_lint = do + guard $ gopt Opt_DoStgLinting dflags + Just $ initDiagOpts dflags + , stgPipeline_pprOpts = initStgPprOpts dflags + , stgPipeline_phases = getStgToDo for_bytecode dflags + , stgPlatform = platform + , stgPipeline_forBytecode = for_bytecode + , stgPipeline_allowTopLevelConApp = allowTopLevelConApp platform ext_dyn_refs + } + +-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc. +getStgToDo + :: Bool -- ^ Are we preparing for bytecode? + -> DynFlags + -> [StgToDo] +getStgToDo for_bytecode dflags = + filter (/= StgDoNothing) + [ mandatory StgUnarise + -- Important that unarisation comes first + -- See Note [StgCse after unarisation] in GHC.Stg.CSE + , optional Opt_StgCSE StgCSE + , optional Opt_StgLiftLams $ StgLiftLams $ initStgLiftConfig dflags + , runWhen for_bytecode StgBcPrep + , optional Opt_StgStats StgStats + ] where + optional opt = runWhen (gopt opt dflags) + mandatory = id + +runWhen :: Bool -> StgToDo -> StgToDo +runWhen True todo = todo +runWhen _ _ = StgDoNothing diff --git a/GHC/Driver/Config/Stg/Ppr.hs b/GHC/Driver/Config/Stg/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Stg/Ppr.hs @@ -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 + } diff --git a/GHC/Driver/Config/StgToCmm.hs b/GHC/Driver/Config/StgToCmm.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/StgToCmm.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Driver.Config.StgToCmm + ( initStgToCmmConfig + ) where + +import GHC.Prelude.Basic + +import GHC.StgToCmm.Config + +import GHC.Cmm.MachOp ( FMASign(..)) +import GHC.Driver.Backend +import GHC.Driver.Session +import GHC.Platform +import GHC.Platform.Profile +import GHC.Platform.Regs +import GHC.Utils.Error +import GHC.Unit.Module +import GHC.Utils.Outputable + +initStgToCmmConfig :: DynFlags -> Module -> StgToCmmConfig +initStgToCmmConfig dflags mod = StgToCmmConfig + -- settings + { stgToCmmProfile = profile + , stgToCmmThisModule = mod + , stgToCmmTmpDir = tmpDir dflags + , stgToCmmContext = initSDocContext dflags defaultDumpStyle + , stgToCmmEmitDebugInfo = debugLevel dflags > 0 + , stgToCmmBinBlobThresh = b_blob + , stgToCmmMaxInlAllocSize = maxInlineAllocSize dflags + -- ticky options + , stgToCmmDoTicky = gopt Opt_Ticky dflags + , stgToCmmTickyAllocd = gopt Opt_Ticky_Allocd dflags + , stgToCmmTickyLNE = gopt Opt_Ticky_LNE dflags + , stgToCmmTickyDynThunk = gopt Opt_Ticky_Dyn_Thunk dflags + , stgToCmmTickyTag = gopt Opt_Ticky_Tag dflags + -- flags + , stgToCmmLoopification = gopt Opt_Loopification dflags + , stgToCmmAlignCheck = gopt Opt_AlignmentSanitisation dflags + , stgToCmmFastPAPCalls = gopt Opt_FastPAPCalls dflags + , stgToCmmSCCProfiling = sccProfilingEnabled dflags + , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling dflags + , stgToCmmOrigThunkInfo = gopt Opt_OrigThunkInfo dflags + , stgToCmmInfoTableMap = gopt Opt_InfoTableMap dflags + , stgToCmmInfoTableMapWithFallback = gopt Opt_InfoTableMapWithFallback dflags + , stgToCmmInfoTableMapWithStack = gopt Opt_InfoTableMapWithStack dflags + , stgToCmmOmitYields = gopt Opt_OmitYields dflags + , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas dflags + , stgToCmmPIC = gopt Opt_PIC dflags + , stgToCmmPIE = gopt Opt_PIE dflags + , stgToCmmExtDynRefs = gopt Opt_ExternalDynamicRefs dflags + , stgToCmmDoBoundsCheck = gopt Opt_DoBoundsChecking dflags + , stgToCmmDoTagCheck = gopt Opt_DoTagInferenceChecks dflags + , stgToCmmObjectDeterminism = gopt Opt_ObjectDeterminism dflags + + -- backend flags: + + -- LLVM, C, and some 32-bit NCG backends can also handle some 64-bit primops + , stgToCmmAllowArith64 = w64 || not ncg || platformArch platform == ArchWasm32 || platformArch platform == ArchX86 + , stgToCmmAllowQuot64 = w64 || not ncg || platformArch platform == ArchWasm32 + , stgToCmmAllowQuotRemInstr = ncg && (x86ish || ppc) + , stgToCmmAllowQuotRem2 = (ncg && (x86ish || ppc)) || llvm + , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm + , stgToCmmAllowFMAInstr = + if + | not (isFmaEnabled dflags) + || not (ncg || llvm) + -- If we're not using the native code generator or LLVM, + -- fall back to the generic implementation. + || platformArch platform == ArchWasm32 + -- WASM doesn't support native FMA instructions (at the time of writing). + -> const False + + -- FNMSub and FNMAdd have different semantics on PowerPC, + -- so we avoid using them. + | ppc + -> \ case { FMAdd -> True; FMSub -> True; _ -> False } + + | otherwise + -> const True + + , stgToCmmAllowIntMul2Instr = (ncg && (x86ish || aarch64)) || llvm + , stgToCmmAllowWordMul2Instr = (ncg && (x86ish || ppc || aarch64)) || llvm + , stgToCmmAllowIntWord64X2MinMax = (ncg && x86ish && isSse4_2Enabled dflags) || llvm + -- SIMD flags + , stgToCmmVecInstrsErr = vec_err + , stgToCmmAvx = isAvxEnabled dflags + , stgToCmmAvx2 = isAvx2Enabled dflags + , stgToCmmAvx512f = isAvx512fEnabled dflags + , stgToCmmTickyAP = gopt Opt_Ticky_AP dflags + -- See Note [Saving foreign call target to local] + , stgToCmmSaveFCallTargetToLocal = any (callerSaves platform) $ activeStgRegs platform + } where profile = targetProfile dflags + platform = profilePlatform profile + bk_end = backend dflags + w64 = platformWordSize platform == PW8 + b_blob = if not ncg then Nothing else binBlobThreshold dflags + (ncg, llvm) = case backendPrimitiveImplementation bk_end of + GenericPrimitives -> (False, False) + JSPrimitives -> (False, False) + NcgPrimitives -> (True, False) + LlvmPrimitives -> (False, True) + aarch64 = case platformArch platform of + ArchAArch64 -> True + _ -> False + x86ish = case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + _ -> False + ppc = case platformArch platform of + ArchPPC -> True + ArchPPC_64 _ -> True + _ -> False + vec_err = case backendSimdValidity (backend dflags) of + IsValid -> Nothing + NotValid msg -> Just msg diff --git a/GHC/Driver/Config/StgToJS.hs b/GHC/Driver/Config/StgToJS.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/StgToJS.hs @@ -0,0 +1,52 @@ +module GHC.Driver.Config.StgToJS + ( initStgToJSConfig + , initJSLinkConfig + ) +where + +import GHC.StgToJS.Types +import GHC.StgToJS.Linker.Types + +import GHC.Driver.DynFlags +import GHC.Driver.Config.Linker + +import GHC.Platform.Ways +import GHC.Utils.Outputable + +import GHC.Prelude + +-- | Initialize StgToJS settings from DynFlags +initStgToJSConfig :: DynFlags -> StgToJSConfig +initStgToJSConfig dflags = StgToJSConfig + -- flags + { csInlinePush = False + , csInlineBlackhole = False + , csInlineLoadRegs = False + , csInlineEnter = False + , csInlineAlloc = False + , csPrettyRender = gopt Opt_DisableJsMinifier dflags + , csTraceRts = False + , csAssertRts = False + , csBoundsCheck = gopt Opt_DoBoundsChecking dflags + , csDebugAlloc = False + , csTraceForeign = False + , csProf = ways dflags `hasWay` WayProf + , csRuntimeAssert = False + -- settings + , csContext = initSDocContext dflags defaultDumpStyle + , csLinkerConfig = initLinkerConfig dflags + } + +-- | Default linker configuration +initJSLinkConfig :: DynFlags -> JSLinkConfig +initJSLinkConfig dflags = JSLinkConfig + { lcNoJSExecutables = False + , lcNoHsMain = False + , lcNoRts = False + , lcNoStats = False + , lcCombineAll = True + , lcForeignRefs = True + , lcForceEmccRts = False + , lcLinkCsources = not (gopt Opt_DisableJsCsources dflags) + } + diff --git a/GHC/Driver/Config/Tidy.hs b/GHC/Driver/Config/Tidy.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Tidy.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Driver.Config.Tidy + ( initTidyOpts + , initStaticPtrOpts + ) +where + +import GHC.Prelude + +import GHC.Iface.Tidy +import GHC.Iface.Tidy.StaticPtrTable + +import GHC.Driver.DynFlags +import GHC.Driver.Env +import GHC.Driver.Backend + +import GHC.Core.Make (getMkStringIds) +import GHC.Builtin.Names +import GHC.Tc.Utils.Env (lookupGlobal) +import GHC.Types.TyThing +import GHC.Platform.Ways + +import qualified GHC.LanguageExtensions as LangExt + +initTidyOpts :: HscEnv -> IO TidyOpts +initTidyOpts hsc_env = do + let dflags = hsc_dflags hsc_env + static_ptr_opts <- if not (xopt LangExt.StaticPointers dflags) + then pure Nothing + else Just <$> initStaticPtrOpts hsc_env + pure $ TidyOpts + { opt_name_cache = hsc_NC hsc_env + , opt_collect_ccs = ways dflags `hasWay` WayProf + , opt_unfolding_opts = unfoldingOpts dflags + , opt_expose_unfoldings = if | gopt Opt_OmitInterfacePragmas dflags -> ExposeNone + | gopt Opt_ExposeAllUnfoldings dflags -> ExposeAll + | gopt Opt_ExposeOverloadedUnfoldings dflags -> ExposeOverloaded + | otherwise -> ExposeSome + , opt_expose_rules = not (gopt Opt_OmitInterfacePragmas dflags) + , opt_trim_ids = gopt Opt_OmitInterfacePragmas dflags + , opt_static_ptr_opts = static_ptr_opts + , opt_keep_auto_rules = gopt Opt_KeepAutoRules dflags + } + +initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts +initStaticPtrOpts hsc_env = do + let dflags = hsc_dflags hsc_env + + mk_string <- getMkStringIds (fmap tyThingId . lookupGlobal hsc_env ) + static_ptr_info_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrInfoDataConName + static_ptr_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrDataConName + + pure $ StaticPtrOpts + { opt_platform = targetPlatform dflags + + -- If we are compiling for the interpreter we will insert any necessary + -- SPT entries dynamically, otherwise we add a C stub to do so + , opt_gen_cstub = backendWritesFiles (backend dflags) + , opt_mk_string = mk_string + , opt_static_ptr_info_datacon = static_ptr_info_datacon + , opt_static_ptr_datacon = static_ptr_datacon + } diff --git a/GHC/Driver/Downsweep.hs b/GHC/Driver/Downsweep.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Downsweep.hs @@ -0,0 +1,1547 @@ +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} +module GHC.Driver.Downsweep + ( downsweep + , downsweepThunk + , downsweepInstalledModules + , downsweepFromRootNodes + , downsweepInteractiveImports + , DownsweepMode(..) + -- * Summary functions + , summariseModule + , summariseFile + , summariseModuleInterface + , SummariseResult(..) + -- * Helper functions + , instantiationNodes + , checkHomeUnitsClosed + ) where + +import GHC.Prelude + +import GHC.Platform.Ways + +import GHC.Driver.Config.Finder (initFinderOpts) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Phases +import {-# SOURCE #-} GHC.Driver.Pipeline (preprocess) +import GHC.Driver.Session +import GHC.Driver.Backend +import GHC.Driver.Monad +import GHC.Driver.Env +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Messager +import GHC.Driver.MakeSem +import GHC.Driver.MakeAction +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Ppr + +import GHC.Iface.Load + +import GHC.Parser.Header +import GHC.Rename.Names +import GHC.Tc.Utils.Backpack +import GHC.Runtime.Context + +import Language.Haskell.Syntax.ImpExp + +import GHC.Data.Graph.Directed +import GHC.Data.FastString +import GHC.Data.Maybe ( expectJust ) +import qualified GHC.Data.Maybe as M +import GHC.Data.OsPath ( unsafeEncodeUtf ) +import GHC.Data.StringBuffer +import GHC.Data.Graph.Directed.Reachability +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Utils.Exception ( throwIO, SomeAsyncException ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Fingerprint +import GHC.Utils.TmpFs +import GHC.Utils.Constants + +import GHC.Types.Error +import GHC.Types.Target +import GHC.Types.SourceFile +import GHC.Types.SourceError +import GHC.Types.SrcLoc +import GHC.Types.Unique.Map +import GHC.Types.PkgQual +import GHC.Types.Basic + + +import GHC.Unit +import GHC.Unit.Env +import GHC.Unit.Finder +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Graph +import GHC.Unit.Module.Deps +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Module.Stage + +import Data.Either ( rights, partitionEithers, lefts ) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) +import qualified Control.Monad.Catch as MC +import Data.Maybe +import Data.List (partition) +import Data.Time +import Data.List (unfoldr) +import Data.Bifunctor (first, bimap) +import System.Directory +import System.FilePath + +import Control.Monad.Trans.Reader +import qualified Data.Map.Strict as M +import Control.Monad.Trans.Class +import System.IO.Unsafe (unsafeInterleaveIO) + +{- +Note [Downsweep and the ModuleGraph] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The ModuleGraph stores the relationship between all the modules, units, and +instantiations in the current session. + +When we do downsweep, we build up a new ModuleGraph, starting from the root +modules. By following all the dependencies we construct a graph which allows +us to answer questions about the transitive closure of the imports. + +The module graph is accessible in the HscEnv. + +When is this graph constructed? + +1. In `--make` mode, we construct the graph before starting to do any compilation. + +2. In `-c` (oneshot) mode, we construct the graph when we have calculated the + ModSummary for the module we are compiling. The `ModuleGraph` is stored in a + thunk, so it is only constructed when it is needed. This avoids reading + the interface files of the whole transitive closure unless they are needed. + +3. In some situations (such as loading plugins) we may need to construct the + graph without having a ModSummary. In this case we use the `downsweepInstalledModules` + function. + +The result is having a uniform graph available for the whole compilation pipeline. + +-} + +-- This caches the answer to the question, if we are in this unit, what does +-- an import of this module mean. +type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo] + +----------------------------------------------------------------------------- +-- +-- | Downsweep (dependency analysis) for --make mode +-- +-- Chase downwards from the specified root set, returning summaries +-- for all home modules encountered. Only follow source-import +-- links. +-- +-- We pass in the previous collection of summaries, which is used as a +-- cache to avoid recalculating a module summary if the source is +-- unchanged. +-- +-- The returned ModuleGraph has one node for each home-package +-- module, plus one for any hs-boot files. The imports of these nodes +-- are all there, including the imports of non-home-package modules. +-- +-- This function is intendned for use by --make mode and will also insert +-- LinkNodes and InstantiationNodes for any home units. +-- +-- It will also turn on code generation for any modules that need it by calling +-- 'enableCodeGenForTH'. +downsweep :: HscEnv + -> (GhcMessage -> AnyGhcDiagnostic) + -> Maybe Messager + -> [ModSummary] + -- ^ Old summaries + -> [ModuleName] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO ([DriverMessages], ModuleGraph) + -- The non-error elements of the returned list all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true in + -- which case there can be repeats +downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do + n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) + (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary + let closure_errs = checkHomeUnitsClosed unit_env + unit_env = hsc_unit_env hsc_env + + all_errs = closure_errs ++ root_errs + + case all_errs of + [] -> do + (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) [] + + let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) + + let all_nodes = downsweep_nodes ++ unit_nodes + let all_errs = downsweep_errs ++ other_errs + + let logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + -- if we have been passed -fno-code, we enable code generation + -- for dependencies of modules that have -XTemplateHaskell, + -- otherwise those modules will fail to compile. + -- See Note [-fno-code mode] #8025 + th_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes + + return (all_errs, th_configured_nodes) + _ -> return (all_errs, emptyMG) + where + summary = getRootSummary excl_mods old_summary_map + + -- A cache from file paths to the already summarised modules. The same file + -- can be used in multiple units so the map is also keyed by which unit the + -- file was used in. + -- Reuse these if we can because the most expensive part of downsweep is + -- reading the headers. + old_summary_map :: M.Map (UnitId, FilePath) ModSummary + old_summary_map = + M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] + + -- Dependencies arising on a unit (backpack and module linking deps) + unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] + unitModuleNodes summaries uid hue = + maybeToList (linkNodes summaries uid hue) + +-- | Calculate the module graph starting from a single ModSummary. The result is a +-- thunk, which when forced will perform the downsweep. This is useful in oneshot +-- mode where the module graph may never be needed. +-- If downsweep fails, then the resulting errors are just thrown. +downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph +downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do + debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..." + ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] + let dflags = hsc_dflags hsc_env + liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) + (initPrintConfig dflags) + (initDiagOpts dflags) + (GhcDriverMessage <$> unionManyMessages errs) + return (mkModuleGraph mg) + +-- | Construct a module graph starting from the interactive context. +-- Produces, a thunk, which when forced will perform the downsweep. +-- This graph contains the current interactive module, and its dependencies. +-- +-- Invariant: The hsc_mod_graph already contains the relevant home modules which +-- might be imported by the interactive imports. +-- +-- This is a first approximation for this function. There probably should also +-- be edges linking the interactive modules together. (Ie Ghci7 importing Ghci6 +-- and so on) +-- See Note [runTcInteractive module graph] +downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph +downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do + debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...") + let imps = ic_imports (hsc_IC hsc_env) + + let interactive_mn = icInteractiveModule ic + -- No sensible value for ModLocation.. if you hit this panic then you probably + -- need to add proper support for modules without any source files to the driver. + let ml = pprPanic "modLocation" (ppr interactive_mn <+> ppr imps) + let key = moduleToMnk interactive_mn NotBoot + let node_type = ModuleNodeFixed key ml + + -- The existing nodes in the module graph. This will be populated when GHCi runs + -- :load. Any home package modules need to already be in here. + let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ] + + (module_edges, graph) <- loopFromInteractive hsc_env (map mkEdge imps) cached_nodes + let interactive_node = ModuleNode module_edges node_type + + let all_nodes = M.elems graph + return $ mkModuleGraph (interactive_node : all_nodes) + + where + -- + mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName)) + -- A simple edge to a module from the same home unit + mkEdge (IIModule n) = + let + mod_node_key = ModNodeKeyWithUid + { mnkModuleName = GWIB (moduleName n) NotBoot + , mnkUnitId = + -- 'toUnitId' is safe here, as we can't import modules that + -- don't have a 'UnitId'. + toUnitId (moduleUnit n) + } + mod_node_edge = + ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key) + in Left mod_node_edge + -- A complete import statement + mkEdge (IIDecl i) = + let lvl = convImportLevel (ideclLevelSpec i) + wanted_mod = unLoc (ideclName i) + is_boot = ideclSource i + mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i) + unitId = homeUnitId $ hsc_home_unit hsc_env + in Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot) + +loopFromInteractive :: HscEnv + -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] + -> M.Map NodeKey ModuleGraphNode + -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode) +loopFromInteractive _ [] cached_nodes = return ([], cached_nodes) +loopFromInteractive hsc_env (edge:edges) cached_nodes = + case edge of + Left edge -> do + (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes + return (edge : edges, cached_nodes') + Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do + let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env) + let k _ loc mod = + let key = moduleToMnk mod is_boot + in return $ FoundHome (ModuleNodeFixed key loc) + found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg [] + case found of + -- Case 1: Home modules have to already be in the cache. + FoundHome (ModuleNodeFixed mod _) -> do + let edge = ModuleNodeEdge lvl (NodeKey_Module mod) + -- Note: Does not perform any further downsweep as the module must already be in the cache. + (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes + return (edge : edges, cached_nodes') + -- Case 2: External units may not be in the cache, if we haven't already initialised the + -- module graph. We can construct the module graph for those here by calling loopUnit. + External uid -> do + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + cached_nodes' = loopUnit hsc_env' cached_nodes [uid] + edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid) + (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes' + return (edge : edges, cached_nodes') + -- And if it's not found.. just carry on and hope. + _ -> loopFromInteractive hsc_env edges cached_nodes + + +-- | Create a module graph from a list of installed modules. +-- This is used by the loader when we need to load modules but there +-- isn't already an existing module graph. For example, when loading plugins +-- during initialisation. +-- +-- If you call this function, then if the `Module` you request to downsweep can't +-- be found then this function will throw errors. +-- If you need to use this function elsewhere, then it would make sense to make it +-- return [DriverMessages] and [ModuleGraph] so that the caller can handle the errors as it sees fit. +-- At the moment, it is overfitted for what `get_reachable_nodes` needs. +downsweepInstalledModules :: HscEnv -> [Module] -> IO ModuleGraph +downsweepInstalledModules hsc_env mods = do + let + (home_mods, external_mods) = partition (\u -> moduleUnitId u `elem` hsc_all_home_unit_ids hsc_env) mods + installed_mods = map (fst . getModuleInstantiation) home_mods + external_uids = map moduleUnitId external_mods + + process :: InstalledModule -> IO ModuleNodeInfo + process i = do + res <- findExactModule hsc_env i NotBoot + case res of + InstalledFound loc -> return $ ModuleNodeFixed (installedModuleToMnk i) loc + -- It is an internal-ish error if this happens, since we any call to this function should + -- already know that we can find the modules we need to load. + _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i + + nodes <- mapM process installed_mods + (errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed nodes external_uids + + -- Similarly here, we should really not get any errors, but print them out if we do. + let dflags = hsc_dflags hsc_env + liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) + (initPrintConfig dflags) + (initDiagOpts dflags) + (GhcDriverMessage <$> unionManyMessages errs) + + return (mkModuleGraph mg) + + + +-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used +-- by --make mode, and fixed nodes by oneshot mode. +-- +-- See Note [Module Types in the ModuleGraph] for the difference between the two. +data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed + +-- | Perform downsweep, starting from the given root 'ModuleNodeInfo's and root +-- 'UnitId's. +-- This function will start at the given roots, and traverse downwards to find +-- all the dependencies, all the way to the leaf units. +downsweepFromRootNodes :: HscEnv + -> M.Map (UnitId, FilePath) ModSummary + -> [ModuleName] + -> Bool + -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies + -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo + -> [UnitId] -- ^ The starting units + -> IO ([DriverMessages], [ModuleGraphNode]) +downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root_nodes root_uids + = do + let root_map = mkRootMap root_nodes + checkDuplicates root_map + let env = DownsweepEnv hsc_env mode old_summaries excl_mods + (deps', map0) <- runDownsweepM env $ do + (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map) + let all_deps = loopUnit hsc_env module_deps root_uids + let all_instantiations = getHomeUnitInstantiations hsc_env + deps' <- loopInstantiations all_instantiations all_deps + return (deps', map0) + + + let downsweep_errs = lefts $ concat $ M.elems map0 + downsweep_nodes = M.elems deps' + + return (downsweep_errs, downsweep_nodes) + where + getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)] + getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env) + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates + :: DownsweepCache + -> IO () + checkDuplicates root_map + | not allow_dup_roots + , dup_root:_ <- dup_roots = liftIO $ multiRootsErr dup_root + | otherwise = pure () + where + dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2 + dup_roots = filterOut isSingleton $ map rights (M.elems root_map) + + +calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] +calcDeps ms = + -- Add a dependency on the HsBoot file if it exists + -- This gets passed to the loopImports function which just ignores it if it + -- can't be found. + [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ + [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ] + + +type DownsweepM a = ReaderT DownsweepEnv IO a +data DownsweepEnv = DownsweepEnv { + downsweep_hsc_env :: HscEnv + , _downsweep_mode :: DownsweepMode + , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary + , _downsweep_excl_mods :: [ModuleName] +} + +runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a +runDownsweepM env act = runReaderT act env + + +loopInstantiations :: [(UnitId, InstantiatedUnit)] + -> M.Map NodeKey ModuleGraphNode + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopInstantiations [] done = pure done +loopInstantiations ((home_uid, iud) :xs) done = do + hsc_env <- asks downsweep_hsc_env + let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + done' = loopUnit hsc_env' done [instUnitInstanceOf iud] + payload = InstantiationNode home_uid iud + loopInstantiations xs (M.insert (mkNodeKey payload) payload done') + + +-- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit +loopSummaries :: [ModSummary] + -> (M.Map NodeKey ModuleGraphNode, + DownsweepCache) + -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache) +loopSummaries [] done = pure done +loopSummaries (ms:next) (done, summarised) + | Just {} <- M.lookup k done + = loopSummaries next (done, summarised) + -- Didn't work out what the imports mean yet, now do that. + | otherwise = do + (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised + -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. + (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' + loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'') + where + k = NodeKey_Module (msKey ms) + + hs_file_for_boot + | HsBootFile <- ms_hsc_src ms + = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) + | otherwise + = Nothing + +loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache) +loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is + +loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache) +loopModuleNodeInfo mod_node_info (done, summarised) = do + case mod_node_info of + ModuleNodeCompile ms -> do + loopSummaries [ms] (done, summarised) + ModuleNodeFixed mod ml -> do + done' <- loopFixedModule mod ml done + return (done', summarised) + +-- NB: loopFixedModule does not take a downsweep cache, because if you +-- ever reach a Fixed node, everything under that also must be fixed. +loopFixedModule :: ModNodeKeyWithUid -> ModLocation + -> M.Map NodeKey ModuleGraphNode + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFixedModule key loc done = do + let nk = NodeKey_Module key + hsc_env <- asks downsweep_hsc_env + case M.lookup nk done of + Just {} -> return done + Nothing -> do + -- MP: TODO, we should just read the dependency info from the interface rather than either + -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory) + -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation) + read_result <- liftIO $ + -- 1. Check if the interface is already loaded into the EPS by some other + -- part of the compiler. + lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case + Just iface -> return (M.Succeeded iface) + Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) + case read_result of + M.Succeeded iface -> do + -- Computer information about this node + let node_deps = ifaceDeps (mi_deps iface) + edges = map mkFixedEdge node_deps + node = ModuleNode edges (ModuleNodeFixed key loc) + foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps) + -- Ignore any failure, we might try to read a .hi-boot file for + -- example, even if there is not one. + M.Failed {} -> + return done + +loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFixedNodeKey _ done (Left key) = do + loopFixedImports [key] done +loopFixedNodeKey home_uid done (Right uid) = do + -- Set active unit so that looking loopUnit finds the correct + -- -package flags in the unit state. + hsc_env <- asks downsweep_hsc_env + let hsc_env' = hscSetActiveUnitId home_uid hsc_env + return $ loopUnit hsc_env' done [uid] + +mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge +mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key) +mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid) + +ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)] +ifaceDeps deps = + [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid) + | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps) + ] ++ + [ Right (tcImportLevel lvl, uid) + | (lvl, uid) <- Set.toList (dep_direct_pkgs deps) + ] + +-- Like loopImports, but we already know exactly which module we are looking for. +loopFixedImports :: [ModNodeKeyWithUid] + -> M.Map NodeKey ModuleGraphNode + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFixedImports [] done = pure done +loopFixedImports (key:keys) done = do + let nk = NodeKey_Module key + hsc_env <- asks downsweep_hsc_env + case M.lookup nk done of + Just {} -> loopFixedImports keys done + Nothing -> do + read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) + case read_result of + InstalledFound loc -> do + done' <- loopFixedModule key loc done + loopFixedImports keys done' + _otherwise -> + -- If the finder fails, just keep going, there will be another + -- error later. + loopFixedImports keys done + +downsweepSummarise :: HomeUnit + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> Maybe (StringBuffer, UTCTime) + -> DownsweepM SummariseResult +downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do + DownsweepEnv hsc_env mode old_summaries excl_mods <- ask + case mode of + DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods + DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + + +-- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover +-- a new module by doing this. +loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] + -- Work list: process these modules + -> M.Map NodeKey ModuleGraphNode + -> DownsweepCache + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> DownsweepM ([ModuleNodeEdge], + M.Map NodeKey ModuleGraphNode, DownsweepCache) + -- The result is the completed NodeMap +loopImports [] done summarised = return ([], done, summarised) +loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised + | Just summs <- M.lookup cache_key summarised + = case summs of + [Right ms] -> do + let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms)) + (rest, summarised', done') <- loopImports ss done summarised + return (nk: rest, summarised', done') + [Left _err] -> + loopImports ss done summarised + _errs -> do + loopImports ss done summarised + | otherwise + = do + hsc_env <- asks downsweep_hsc_env + let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) + mb_s <- downsweepSummarise home_unit + is_boot wanted_mod mb_pkg + Nothing + case mb_s of + NotThere -> loopImports ss done summarised + External uid -> do + -- Pass an updated hsc_env to loopUnit, as each unit might + -- have a different visible package database. + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + let done' = loopUnit hsc_env' done [uid] + (other_deps, done'', summarised') <- loopImports ss done' summarised + return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised') + FoundInstantiation iud -> do + (other_deps, done', summarised') <- loopImports ss done summarised + return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised') + FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) + FoundHome s -> do + (done', summarised') <- + loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised) + (other_deps, final_done, final_summarised) <- loopImports ss done' summarised' + + -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. + return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised) + where + cache_key = (home_uid, mb_pkg, unLoc <$> gwib) + GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib + wanted_mod = L loc mod + +loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode +loopUnit _ cache [] = cache +loopUnit lcl_hsc_env cache (u:uxs) = do + let nk = (NodeKey_ExternalUnit u) + case Map.lookup nk cache of + Just {} -> loopUnit lcl_hsc_env cache uxs + Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of + Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs + Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u) + +multiRootsErr :: [ModuleNodeInfo] -> IO () +multiRootsErr [] = panic "multiRootsErr" +multiRootsErr summs@(summ1:_) + = throwOneError $ fmap GhcDriverMessage $ + mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files + where + mod = moduleNodeInfoModule summ1 + files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs + +moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages +moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod) + +-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes. +-- These are used to represent the type checking that is done after +-- all the free holes (sigs in current package) relevant to that instantiation +-- are compiled. This is necessary to catch some instantiation errors. +instantiationNodes :: UnitId -> UnitState -> [(UnitId, InstantiatedUnit)] +instantiationNodes uid unit_state = map (uid,) iuids_to_check + where + iuids_to_check :: [InstantiatedUnit] + iuids_to_check = + nubSort $ concatMap (goUnitId . fst) (explicitUnits unit_state) + where + goUnitId uid = + [ recur + | VirtUnit indef <- [uid] + , inst <- instUnitInsts indef + , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst + ] + +-- The linking plan for each module. If we need to do linking for a home unit +-- then this function returns a graph node which depends on all the modules in the home unit. + +-- At the moment nothing can depend on these LinkNodes. +linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode) +linkNodes summaries uid hue = + let dflags = homeUnitEnv_dflags hue + ofile = outputFile_ dflags + + unit_nodes :: [NodeKey] + unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries) + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + no_hs_main = gopt Opt_NoHsMain dflags + + main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes + + do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib + + in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking -> + Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags)) + -- This should be an error, not a warning (#10895). + | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid)) + | otherwise -> Nothing + +getRootSummary :: + [ModuleName] -> + M.Map (UnitId, FilePath) ModSummary -> + HscEnv -> + Target -> + IO (Either DriverMessages ModSummary) +getRootSummary excl_mods old_summary_map hsc_env target + | TargetFile file mb_phase <- targetId + = do + let offset_file = augmentByWorkingDirectory dflags file + exists <- liftIO $ doesFileExist offset_file + if exists || isJust maybe_buf + then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase + maybe_buf + else + return $ Left $ singleMessage $ + mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file) + | TargetModule modl <- targetId + = do + maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot + (L rootLoc modl) (ThisPkg (homeUnitId home_unit)) + maybe_buf excl_mods + pure case maybe_summary of + FoundHome (ModuleNodeCompile s) -> Right s + FoundHomeWithError err -> Left (snd err) + _ -> Left (moduleNotFoundErr uid modl) + where + Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target + home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) + rootLoc = mkGeneralSrcSpan (fsLit "") + dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)) + +-- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline +-- system. +-- Create bundles of 'Target's wrapped in a 'MakeAction' that uses +-- 'withAbstractSem' to wait for a free slot, limiting the number of +-- concurrently computed summaries to the value of the @-j@ option or the slots +-- allocated by the job server, if that is used. +-- +-- The 'MakeAction' returns 'Maybe', which is not handled as an error, because +-- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the +-- result won't be read anyway here. +-- +-- To emulate the current behavior, we funnel exceptions past the concurrency +-- barrier and rethrow the first one afterwards. +rootSummariesParallel :: + WorkerLimit -> + HscEnv -> + (GhcMessage -> AnyGhcDiagnostic) -> + Maybe Messager -> + (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) -> + IO ([DriverMessages], [ModSummary]) +rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do + (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles) + runPipelines n_jobs hsc_env diag_wrapper msg actions + (sequence . catMaybes <$> sequence get_results) >>= \case + Right results -> pure (partitionEithers (concat results)) + Left exc -> throwIO exc + where + bundles = mk_bundles targets + + mk_bundles = unfoldr \case + [] -> Nothing + ts -> Just (splitAt bundle_size ts) + + bundle_size = 20 + + targets = hsc_targets hsc_env + + action_and_result (log_queue_id, ts) = do + res_var <- liftIO newEmptyMVar + pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var) + + action log_queue_id target_bundle = do + env@MakeEnv {compile_sem} <- ask + lift $ lift $ + withAbstractSem compile_sem $ + withLoggerHsc log_queue_id env \ lcl_hsc_env -> + MC.try (mapM (get_summary lcl_hsc_env) target_bundle) >>= \case + Left e | Just (_ :: SomeAsyncException) <- fromException e -> + throwIO e + a -> pure a + +-- | This function checks then important property that if both p and q are home units +-- then any dependency of p, which transitively depends on q is also a home unit. +-- +-- See Note [Multiple Home Units], section 'Closure Property'. +checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] +checkHomeUnitsClosed ue + | Set.null bad_unit_ids = [] + | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] + where + home_id_set = HUG.allUnits $ ue_home_unit_graph ue + bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -} + rootLoc = mkGeneralSrcSpan (fsLit "") + + downwards_closure :: Graph (Node UnitId UnitId) + downwards_closure = graphFromEdgedVerticesUniq graphNodes + + inverse_closure = graphReachability $ transposeG downwards_closure + + upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set] + + all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId) + all_unit_direct_deps + = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue + where + go rest this this_uis = + plusUniqMap_C Set.union + (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps)) + rest + where + external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units) + this_units = homeUnitEnv_units this_uis + this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units] + + graphNodes :: [Node UnitId UnitId] + graphNodes = go Set.empty home_id_set + where + go done todo + = case Set.minView todo of + Nothing -> [] + Just (uid, todo') + | Set.member uid done -> go done todo' + | otherwise -> case lookupUniqMap all_unit_direct_deps uid of + Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps)) + Just depends -> + let todo'' = (depends Set.\\ done) `Set.union` todo' + in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo'' + +-- | Update the every ModSummary that is depended on +-- by a module that needs template haskell. We enable codegen to +-- the specified target, disable optimization and change the .hi +-- and .o file locations to be temporary files. +-- See Note [-fno-code mode] +enableCodeGenForTH + :: Logger + -> TmpFs + -> UnitEnv + -> [ModuleGraphNode] + -> IO ModuleGraph +enableCodeGenForTH logger tmpfs unit_env = + enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env + + +data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord) + +instance Outputable CodeGenEnable where + ppr = text . show + +-- | Helper used to implement 'enableCodeGenForTH'. +-- In particular, this enables +-- unoptimized code generation for all modules that meet some +-- condition (first parameter), or are dependencies of those +-- modules. The second parameter is a condition to check before +-- marking modules for code generation. +enableCodeGenWhen + :: Logger + -> TmpFs + -> TempFileLifetime + -> TempFileLifetime + -> UnitEnv + -> [ModuleGraphNode] + -> IO ModuleGraph +enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do + mgMapM enable_code_gen mg + where + defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env) + + enable_code_gen :: ModuleNodeInfo -> IO ModuleNodeInfo + enable_code_gen (ModuleNodeCompile ms) = ModuleNodeCompile <$> enable_code_gen_ms ms + enable_code_gen m@(ModuleNodeFixed {}) = return m + + -- FIXME: Strong resemblance and some duplication between this and `makeDynFlagsConsistent`. + -- It would be good to consider how to make these checks more uniform and not duplicated. + enable_code_gen_ms :: ModSummary -> IO ModSummary + enable_code_gen_ms ms + | ModSummary + { ms_location = ms_location + , ms_hsc_src = HsSrcFile + , ms_hspp_opts = dflags + } <- ms + , Just enable_spec <- needs_codegen_map ms = + if | nocode_enable ms -> do + let new_temp_file suf dynsuf = do + tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf + let dyn_tn = tn -<.> dynsuf + addFilesToClean tmpfs dynLife [dyn_tn] + return (unsafeEncodeUtf tn, unsafeEncodeUtf dyn_tn) + -- We don't want to create .o or .hi files unless we have been asked + -- to by the user. But we need them, so we patch their locations in + -- the ModSummary with temporary files. + -- + ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <- + -- If ``-fwrite-interface` is specified, then the .o and .hi files + -- are written into `-odir` and `-hidir` respectively. #16670 + if gopt Opt_WriteInterface dflags + then return ((ml_hi_file_ospath ms_location, ml_dyn_hi_file_ospath ms_location) + , (ml_obj_file_ospath ms_location, ml_dyn_obj_file_ospath ms_location)) + else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags)) + <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags)) + let new_dflags = case enable_spec of + EnableByteCode -> dflags { backend = interpreterBackend } + EnableObject -> dflags { backend = defaultBackendOf ms } + EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms} + let ms' = ms + { ms_location = + ms_location { ml_hi_file_ospath = hi_file + , ml_obj_file_ospath = o_file + , ml_dyn_hi_file_ospath = dyn_hi_file + , ml_dyn_obj_file_ospath = dyn_o_file } + , ms_hspp_opts = updOptLevel 0 $ new_dflags + } + -- Recursive call to catch the other cases + enable_code_gen_ms ms' + + -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough) + -- we only get to this case if the default backend is already generating object files, but we need dynamic + -- objects + | bytecode_and_enable enable_spec ms -> do + let ms' = ms + { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode + } + -- Recursive call to catch the other cases + enable_code_gen_ms ms' + | dynamic_too_enable enable_spec ms -> do + let ms' = ms + { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo + } + -- Recursive call to catch the other cases + enable_code_gen_ms ms' + | ext_interp_enable ms -> do + let ms' = ms + { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter + } + -- Recursive call to catch the other cases + enable_code_gen_ms ms' + + | needs_full_ways dflags -> do + let ms' = ms { ms_hspp_opts = set_full_ways dflags } + -- Recursive call to catch the other cases + enable_code_gen_ms ms' + + | otherwise -> return ms + + enable_code_gen_ms ms = return ms + + nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) = + not (backendGeneratesCode (backend dflags)) && + -- Don't enable codegen for TH on indefinite packages; we + -- can't compile anything anyway! See #16219. + isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env) + + bytecode_and_enable enable_spec ms = + -- In the situation where we **would** need to enable dynamic-too + -- IF we had decided we needed objects + dynamic_too_enable EnableObject ms + -- but we prefer to use bytecode rather than objects + && prefer_bytecode + -- and we haven't already turned it on + && not generate_both + where + lcl_dflags = ms_hspp_opts ms + prefer_bytecode = case enable_spec of + EnableByteCodeAndObject -> True + EnableByteCode -> True + EnableObject -> False + + generate_both = gopt Opt_ByteCodeAndObjectCode lcl_dflags + + -- #8180 - when using TemplateHaskell, switch on -dynamic-too so + -- the linker can correctly load the object files. This isn't necessary + -- when using -fexternal-interpreter. + -- FIXME: Duplicated from makeDynFlagsConsistent + dynamic_too_enable enable_spec ms + | sTargetRTSLinkerOnlySupportsSharedLibs $ settings lcl_dflags = + not isDynWay && not dyn_too_enabled + && enable_object + | otherwise = + hostIsDynamic && not hostIsProfiled && internalInterpreter && + not isDynWay && not isProfWay && not dyn_too_enabled + && enable_object + where + lcl_dflags = ms_hspp_opts ms + internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) + dyn_too_enabled = gopt Opt_BuildDynamicToo lcl_dflags + isDynWay = hasWay (ways lcl_dflags) WayDyn + isProfWay = hasWay (ways lcl_dflags) WayProf + enable_object = case enable_spec of + EnableByteCode -> False + EnableByteCodeAndObject -> True + EnableObject -> True + + -- #16331 - when no "internal interpreter" is available but we + -- need to process some TemplateHaskell or QuasiQuotes, we automatically + -- turn on -fexternal-interpreter. + ext_interp_enable ms = not ghciSupported && internalInterpreter + where + lcl_dflags = ms_hspp_opts ms + internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) + + + mg = mkModuleGraph mod_graph + + (td_map, lookup_node) = mkStageDeps mod_graph + + queryReachable ns = isReachableMany td_map (mapMaybe lookup_node ns) + + -- NB: Do not inline these, it is very important to share them across all calls + -- to needs_obj_set and needs_bc_set. + !query_obj = + let !deps = queryReachable need_obj_set + in \k -> deps (expectJust $ lookup_node k) + + !query_bc = + let !deps = queryReachable need_bc_set + in \k -> deps (expectJust $ lookup_node k) + + -- The direct dependencies of modules which require object code + need_obj_set = + + -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only + -- it's dependencies. + [ (mkNodeKey m, RunStage) + | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph + , isTemplateHaskellOrQQNonBoot ms + , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)) + ] + + -- The direct dependencies of modules which require byte code + need_bc_set = + [ (mkNodeKey m, RunStage) + | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph + , isTemplateHaskellOrQQNonBoot ms + , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms) + ] + + needs_obj_set, needs_bc_set :: ModNodeKeyWithUid -> Bool + needs_obj_set k = query_obj (NodeKey_Module k, CompileStage) + + needs_bc_set k = query_bc (NodeKey_Module k, CompileStage) + + -- A map which tells us how to enable code generation for a NodeKey + needs_codegen_map :: ModSummary -> Maybe CodeGenEnable + needs_codegen_map ms = + let nk = msKey ms + + + -- Another option here would be to just produce object code, rather than both object and + -- byte code + in case (needs_obj_set nk, needs_bc_set nk) of + (True, True) -> Just EnableByteCodeAndObject + (True, False) -> Just EnableObject + (False, True) -> Just EnableByteCode + (False, False) -> Nothing + + -- FIXME: Duplicated from makeDynFlagsConsistent + needs_full_ways dflags + = ghcLink dflags == LinkInMemory && + not (gopt Opt_ExternalInterpreter dflags) && + targetWays_ dflags /= hostFullWays + set_full_ways dflags = + let platform = targetPlatform dflags + dflags_a = dflags { targetWays_ = hostFullWays } + dflags_b = foldl gopt_set dflags_a + $ concatMap (wayGeneralFlags platform) + hostFullWays + dflags_c = foldl gopt_unset dflags_b + $ concatMap (wayUnsetGeneralFlags platform) + hostFullWays + in dflags_c + +{- Note [-fno-code mode] +~~~~~~~~~~~~~~~~~~~~~~~~ +GHC offers the flag -fno-code for the purpose of parsing and typechecking a +program without generating object files. This is intended to be used by tooling +and IDEs to provide quick feedback on any parser or type errors as cheaply as +possible. + +When GHC is invoked with -fno-code, no object files or linked output will be +generated. As many errors and warnings as possible will be generated, as if +-fno-code had not been passed. The session DynFlags will have +backend == NoBackend. + +-fwrite-interface +~~~~~~~~~~~~~~~~ +Whether interface files are generated in -fno-code mode is controlled by the +-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is +not also passed. Recompilation avoidance requires interface files, so passing +-fno-code without -fwrite-interface should be avoided. If -fno-code were +re-implemented today, there would be no need for -fwrite-interface as it +would considered always on; this behaviour is as it is for backwards compatibility. + +================================================================ +IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER +================================================================ + +Template Haskell +~~~~~~~~~~~~~~~~ +A module using Template Haskell may invoke an imported function from inside a +splice. This will cause the type-checker to attempt to execute that code, which +would fail if no object files had been generated. See #8025. To rectify this, +during the downsweep we patch the DynFlags in the ModSummary of any home module +that is imported by a module that uses Template Haskell to generate object +code. + +The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled +or not in the module which needs the code generation. If the module requires byte-code then +dependencies will generate byte-code, otherwise they will generate object files. +In the case where some modules require byte-code and some object files, both are +generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these +configurations. + +The object files (and interface files if -fwrite-interface is disabled) produced +for Template Haskell are written to temporary files. + +Note that since Template Haskell can run arbitrary IO actions, -fno-code mode +is no more secure than running without it. + +Explicit Level Imports +~~~~~~~~~~~~~~~~~~~~~~ +When `-XExplicitLevelImports` is enabled, code is only generated for modules +needed for the compile stage. The ReachabilityIndex created by `mkStageDeps` answers +the question, if I compile a module for a specific stage, then which modules at +other stages do I need. The roots of this query are the modules which use `TemplateHaskell` +at the runtime stage, and modules we need code generation for are those which +are needed at the compile time stage. All the logic about how ExplicitLevelImports +and TemplateHaskell affect the needed stages of a module is encoded in mkStageDeps. + +Potential TODOS: +~~~~~ +* Remove -fwrite-interface and have interface files always written in -fno-code + mode +* Both .o and .dyn_o files are generated for template haskell, but we only need + .dyn_o (for dynamically linked compilers) Fix it. (The needed way is 'hostFullWays') +* In make mode, a message like + Compiling A (A.hs, /tmp/ghc_123.o) + is shown if downsweep enabled object code generation for A. Perhaps we should + show "nothing" or "temporary object file" instead. Note that one + can currently use -keep-tmp-files and inspect the generated file with the + current behaviour. +* Offer a -no-codedir command line option, and write what were temporary + object files there. This would speed up recompilation. +* Use existing object files (if they are up to date) instead of always + generating temporary ones. +-} + +-- | Populate the Downsweep cache with the root modules. +mkRootMap + :: [ModuleNodeInfo] + -> DownsweepCache +mkRootMap summaries = Map.fromListWith (flip (++)) + [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ] + +----------------------------------------------------------------------------- +-- Summarising modules + +-- We have two types of summarisation: +-- +-- * Summarise a file. This is used for the root module(s) passed to +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. +-- +-- * Summarise a module. We are given a module name, and must provide +-- a summary. The finder is used to locate the file in which the module +-- resides. + +summariseFile + :: HscEnv + -> HomeUnit + -> M.Map (UnitId, FilePath) ModSummary -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Maybe (StringBuffer,UTCTime) + -> IO (Either DriverMessages ModSummary) + +summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, + | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries + = do + let location = ms_location $ old_summary + + src_hash <- get_src_hash + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getFileHash may fail, but that's the right + -- behaviour. + + -- return the cached summary if the source didn't change + checkSummaryHash + hsc_env (new_summary src_fn) + old_summary location src_hash + + | otherwise + = do src_hash <- get_src_hash + new_summary src_fn src_hash + where + -- change the main active unit so all operations happen relative to the given unit + hsc_env = hscSetActiveHomeUnit home_unit hsc_env' + -- src_fn does not necessarily exist on the filesystem, so we need to + -- check what kind of target we are dealing with + get_src_hash = case maybe_buf of + Just (buf,_) -> return $ fingerprintStringBuffer buf + Nothing -> liftIO $ getFileHash src_fn + + new_summary src_fn src_hash = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf + + let fopts = initFinderOpts (hsc_dflags hsc_env) + (basename, extension) = splitExtension src_fn + + hsc_src + | isHaskellSigSuffix (drop 1 extension) = HsigFile + | isHaskellBootSuffix (drop 1 extension) = HsBootFile + | otherwise = HsSrcFile + + -- Make a ModLocation for this file, adding the @-boot@ suffix to + -- all paths if the original was a boot file. + location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf extension) hsc_src + + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + mod <- liftIO $ do + let home_unit = hsc_home_unit hsc_env + let fc = hsc_FC hsc_env + addHomeModuleToFinder fc home_unit pi_mod_name location hsc_src + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_hash = src_hash + , nms_hsc_src = hsc_src + , nms_location = location + , nms_mod = mod + , nms_preimps = preimps + } + +checkSummaryHash + :: HscEnv + -> (Fingerprint -> IO (Either e ModSummary)) + -> ModSummary -> ModLocation -> Fingerprint + -> IO (Either e ModSummary) +checkSummaryHash + hsc_env new_summary + old_summary + location src_hash + | ms_hs_hash old_summary == src_hash && + not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do + -- update the object-file timestamp + obj_timestamp <- modificationTimeIfExists (ml_obj_file location) + + -- We have to repopulate the Finder's cache for file targets + -- because the file might not even be on the regular search path + -- and it was likely flushed in depanal. This is not technically + -- needed when we're called from sumariseModule but it shouldn't + -- hurt. + let fc = hsc_FC hsc_env + mod = ms_mod old_summary + hsc_src = ms_hsc_src old_summary + addModuleToFinder fc mod location hsc_src + + hi_timestamp <- modificationTimeIfExists (ml_hi_file location) + hie_timestamp <- modificationTimeIfExists (ml_hie_file location) + + return $ Right + ( old_summary + { ms_obj_date = obj_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + } + ) + + | otherwise = + -- source changed: re-summarise. + new_summary src_hash + +data SummariseResult = + FoundInstantiation InstantiatedUnit + | FoundHomeWithError (UnitId, DriverMessages) + | FoundHome ModuleNodeInfo + | External UnitId + | NotThere + +-- | summariseModule finds the location of the source file for the given module. +-- This version always returns a ModuleNodeCompile node, it is useful for +-- --make mode. +summariseModule :: HscEnv + -> HomeUnit + -> M.Map (UnitId, FilePath) ModSummary + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] + -> IO SummariseResult +summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods = + summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + where + k = summariseModuleWithSource home_unit old_summaries is_boot maybe_buf + + +-- | Like summariseModule but for interface files that we don't want to compile. +-- This version always returns a ModuleNodeFixed node. +summariseModuleInterface :: HscEnv + -> HomeUnit + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> [ModuleName] + -> IO SummariseResult +summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods = + summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + where + k _hsc_env loc mod = do + -- The finder will return a path to the .hi-boot even if it doesn't actually + -- exist. So check if it exists first before concluding it's there. + does_exist <- doesFileExist (ml_hi_file loc) + if does_exist + then let key = moduleToMnk mod is_boot + in return $ FoundHome (ModuleNodeFixed key loc) + else return NotThere + + + +-- Summarise a module, and pick up source and timestamp. +summariseModuleDispatch + :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module. + -> HscEnv + -> HomeUnit + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Located ModuleName -- Imported module to be summarised + -> PkgQual + -> [ModuleName] -- Modules to exclude + -> IO SummariseResult + + +summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg excl_mods + | wanted_mod `elem` excl_mods + = return NotThere + | otherwise = find_it + where + -- Temporarily change the currently active home unit so all operations + -- happen relative to it + hsc_env = hscSetActiveHomeUnit home_unit hsc_env' + + find_it :: IO SummariseResult + + find_it = do + found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg + case found of + Found location mod + | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env -> + -- Home package + k hsc_env location mod + | VirtUnit iud <- moduleUnit mod + , not (isHomeModule home_unit mod) + -> return $ FoundInstantiation iud + | otherwise -> return $ External (moduleUnitId mod) + _ -> return NotThere + -- Not found + -- (If it is TRULY not found at all, we'll + -- error when we actually try to compile) + + +-- | The continuation to summarise a home module if we want to find the source file +-- for it and potentially compile it. +summariseModuleWithSource + :: HomeUnit + -> M.Map (UnitId, FilePath) ModSummary + -- ^ Map of old summaries + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Maybe (StringBuffer, UTCTime) + -> HscEnv + -> ModLocation + -> Module + -> IO SummariseResult +summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let src_fn = expectJust (ml_hs_file location) + + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_h <- fileHashIfExists src_fn + case maybe_h of + -- This situation can also happen if we have found the .hs file but the + -- .hs-boot file doesn't exist. + Nothing -> return NotThere + Just h -> do + fresult <- new_summary_cache_check location mod src_fn h + return $ case fresult of + Left err -> FoundHomeWithError (moduleUnitId mod, err) + Right ms -> FoundHome (ModuleNodeCompile ms) + + where + dflags = hsc_dflags hsc_env + new_summary_cache_check loc mod src_fn h + | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = + + -- check the hash on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has changed then need to resummarise. + case maybe_buf of + Just (buf,_) -> + checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf) + Nothing -> + checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h + | otherwise = new_summary loc mod src_fn h + + new_summary :: ModLocation + -> Module + -> FilePath + -> Fingerprint + -> IO (Either DriverMessages ModSummary) + new_summary location mod src_fn src_hash + = runExceptT $ do + preimps@PreprocessedImports {..} + -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP + -- See multiHomeUnits_cpp2 test + <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf + + -- NB: Despite the fact that is_boot is a top-level parameter, we + -- don't actually know coming into this function what the HscSource + -- of the module in question is. This is because we may be processing + -- this module because another module in the graph imported it: in this + -- case, we know if it's a boot or not because of the {-# SOURCE #-} + -- annotation, but we don't know if it's a signature or a regular + -- module until we actually look it up on the filesystem. + let hsc_src + | is_boot == IsBoot = HsBootFile + | isHaskellSigFilename src_fn = HsigFile + | otherwise = HsSrcFile + + when (pi_mod_name /= moduleName mod) $ + throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc + $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod) + + let instantiations = homeUnitInstantiations home_unit + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $ + throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc + $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_hash = src_hash + , nms_hsc_src = hsc_src + , nms_location = location + , nms_mod = mod + , nms_preimps = preimps + } + +-- | Convenience named arguments for 'makeNewModSummary' only used to make +-- code more readable, not exported. +data MakeNewModSummary + = MakeNewModSummary + { nms_src_fn :: FilePath + , nms_src_hash :: Fingerprint + , nms_hsc_src :: HscSource + , nms_location :: ModLocation + , nms_mod :: Module + , nms_preimps :: PreprocessedImports + } + +makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary +makeNewModSummary hsc_env MakeNewModSummary{..} = do + let PreprocessedImports{..} = nms_preimps + obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location) + dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location) + hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location) + hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) + + extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name + (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps + + return $ + ModSummary + { ms_mod = nms_mod + , ms_hsc_src = nms_hsc_src + , ms_location = nms_location + , ms_hspp_file = pi_hspp_fn + , ms_hspp_opts = pi_local_dflags + , ms_hspp_buf = Just pi_hspp_buf + , ms_parsed_mod = Nothing + , ms_srcimps = pi_srcimps + , ms_textual_imps = + ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) ++ + ((,,) NormalLevel NoPkgQual . noLoc <$> implicit_sigs) ++ + pi_theimps + , ms_hs_hash = nms_src_hash + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + , ms_obj_date = obj_timestamp + , ms_dyn_obj_date = dyn_obj_timestamp + } + +data PreprocessedImports + = PreprocessedImports + { pi_local_dflags :: DynFlags + , pi_srcimps :: [Located ModuleName] + , pi_theimps :: [(ImportLevel, PkgQual, Located ModuleName)] + , pi_hspp_fn :: FilePath + , pi_hspp_buf :: StringBuffer + , pi_mod_name_loc :: SrcSpan + , pi_mod_name :: ModuleName + } + +-- Preprocess the source file and get its imports +-- The pi_local_dflags contains the OPTIONS pragmas +getPreprocessedImports + :: HscEnv + -> FilePath + -> Maybe Phase + -> Maybe (StringBuffer, UTCTime) + -- ^ optional source code buffer and modification time + -> ExceptT DriverMessages IO PreprocessedImports +getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do + (pi_local_dflags, pi_hspp_fn) + <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase + pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn + (pi_srcimps', pi_theimps', L pi_mod_name_loc pi_mod_name) + <- ExceptT $ do + let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags + popts = initParserOpts pi_local_dflags + mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn + return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps) + let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + let rn_imps = fmap (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn)) + let pi_srcimps = pi_srcimps' + let pi_theimps = rn_imps pi_theimps' + return PreprocessedImports {..} diff --git a/GHC/Driver/DynFlags.hs b/GHC/Driver/DynFlags.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/DynFlags.hs @@ -0,0 +1,1581 @@ +{-# LANGUAGE LambdaCase #-} +module GHC.Driver.DynFlags ( + -- * Dynamic flags and associated configuration types + DumpFlag(..), + GeneralFlag(..), + WarningFlag(..), DiagnosticReason(..), + Language(..), + FatalMessager, FlushOut(..), + ProfAuto(..), + hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, + dopt, dopt_set, dopt_unset, + gopt, gopt_set, gopt_unset, + wopt, wopt_set, wopt_unset, + wopt_fatal, wopt_set_fatal, wopt_unset_fatal, + wopt_set_all_custom, wopt_unset_all_custom, + wopt_set_all_fatal_custom, wopt_unset_all_fatal_custom, + wopt_set_custom, wopt_unset_custom, + wopt_set_fatal_custom, wopt_unset_fatal_custom, + wopt_any_custom, + xopt, xopt_set, xopt_unset, + xopt_set_unlessExplSpec, + xopt_DuplicateRecordFields, + xopt_FieldSelectors, + lang_set, + DynamicTooState(..), dynamicTooState, setDynamicNow, + OnOff(..), + DynFlags(..), + ParMakeCount(..), + ways, + HasDynFlags(..), ContainsDynFlags(..), + RtsOptsEnabled(..), + GhcMode(..), isOneShot, + GhcLink(..), isNoLink, + PackageFlag(..), PackageArg(..), ModRenaming(..), + packageFlagsChanged, + IgnorePackageFlag(..), TrustFlag(..), + PackageDBFlag(..), PkgDbRef(..), + Option(..), showOpt, + DynLibLoader(..), + positionIndependent, + optimisationFlags, + + targetProfile, + + ReexportedModule(..), + + -- ** Manipulating DynFlags + defaultDynFlags, -- Settings -> DynFlags + initDynFlags, -- DynFlags -> IO DynFlags + defaultFatalMessager, + defaultFlushOut, + optLevelFlags, + languageExtensions, + + TurnOnFlag, + turnOn, + turnOff, + + -- ** System tool settings and locations + programName, projectVersion, + ghcUsagePath, ghciUsagePath, topDir, toolDir, + versionedAppDir, versionedFilePath, + extraGccViaCFlags, globalPackageDatabasePath, + + -- + baseUnitId, + + + -- * Include specifications + IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, + addImplicitQuoteInclude, + + -- * SDoc + initSDocContext, initDefaultSDocContext, + initPromotionTickContext, + + -- * Platform features + isSse3Enabled, + isSsse3Enabled, + isSse4_1Enabled, + isSse4_2Enabled, + isAvxEnabled, + isAvx2Enabled, + isAvx512cdEnabled, + isAvx512erEnabled, + isAvx512fEnabled, + isAvx512pfEnabled, + isFmaEnabled, + isBmiEnabled, + isBmi2Enabled +) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Ways +import GHC.Platform.Profile + +import GHC.CmmToAsm.CFG.Weight +import GHC.Core.Unfold +import GHC.Data.Bool +import GHC.Data.EnumSet (EnumSet) +import GHC.Data.Maybe +import GHC.Builtin.Names ( mAIN_NAME ) +import GHC.Driver.Backend +import GHC.Driver.Flags +import GHC.Driver.IncludeSpecs +import GHC.Driver.Phases ( Phase(..), phaseInputExt ) +import GHC.Driver.Plugins.External +import GHC.Settings +import GHC.Settings.Constants +import GHC.Types.Basic ( IntWithInf, treatZeroAsInf ) +import GHC.Types.Error (DiagnosticReason(..)) +import GHC.Types.ProfAuto +import GHC.Types.SafeHaskell +import GHC.Types.SrcLoc +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Utils.CliOption +import GHC.SysTools.Terminal ( stderrSupportsAnsiColors ) +import GHC.UniqueSubdir (uniqueSubdir) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.TmpFs + +import qualified GHC.Types.FieldLabel as FieldLabel +import qualified GHC.Utils.Ppr.Colour as Col +import qualified GHC.Data.EnumSet as EnumSet + +import GHC.Core.Opt.CallerCC.Types + +import Control.Monad (msum, (<=<)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.Writer (WriterT) +import Data.Word +import System.IO +import System.IO.Error (catchIOError) +import System.Environment (lookupEnv) +import System.FilePath (normalise, ()) +import System.Directory +import GHC.Foreign (withCString, peekCString) + +import qualified Data.Set as Set + +import qualified GHC.LanguageExtensions as LangExt + +-- ----------------------------------------------------------------------------- +-- DynFlags + +-- | Contains not only a collection of 'GeneralFlag's but also a plethora of +-- information relating to the compilation of a single file or GHC session +data DynFlags = DynFlags { + ghcMode :: GhcMode, + ghcLink :: GhcLink, + backend :: !Backend, + -- ^ The backend to use (if any). + -- + -- Whenever you change the backend, also make sure to set 'ghcLink' to + -- something sensible. + -- + -- 'NoBackend' can be used to avoid generating any output, however, note that: + -- + -- * If a program uses Template Haskell the typechecker may need to run code + -- from an imported module. To facilitate this, code generation is enabled + -- for modules imported by modules that use template haskell, using the + -- default backend for the platform. + -- See Note [-fno-code mode]. + + + -- formerly Settings + ghcNameVersion :: {-# UNPACK #-} !GhcNameVersion, + fileSettings :: {-# UNPACK #-} !FileSettings, + unitSettings :: {-# UNPACK #-} !UnitSettings, + + targetPlatform :: Platform, -- Filled in by SysTools + toolSettings :: {-# UNPACK #-} !ToolSettings, + platformMisc :: {-# UNPACK #-} !PlatformMisc, + rawSettings :: [(String, String)], + tmpDir :: TempDir, + + llvmOptLevel :: Int, -- ^ LLVM optimisation level + verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] + debugLevel :: Int, -- ^ How much debug information to produce + simplPhases :: Int, -- ^ Number of simplifier phases + maxSimplIterations :: Int, -- ^ Max simplifier iterations + ruleCheck :: Maybe String, + strictnessBefore :: [Int], -- ^ Additional demand analysis + + parMakeCount :: Maybe ParMakeCount, + -- ^ The number of modules to compile in parallel + -- If unspecified, compile with a single job. + + enableTimeStats :: Bool, -- ^ Enable RTS timing statistics? + ghcHeapSize :: Maybe Int, -- ^ The heap size to set. + + maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt + -- to show in type error messages + maxValidHoleFits :: Maybe Int, -- ^ Maximum number of hole fits to show + -- in typed hole error messages + maxRefHoleFits :: Maybe Int, -- ^ Maximum number of refinement hole + -- fits to show in typed hole error + -- messages + refLevelHoleFits :: Maybe Int, -- ^ Maximum level of refinement for + -- refinement hole fits in typed hole + -- error messages + maxUncoveredPatterns :: Int, -- ^ Maximum number of unmatched patterns to show + -- in non-exhaustiveness warnings + maxPmCheckModels :: Int, -- ^ Soft limit on the number of models + -- the pattern match checker checks + -- a pattern against. A safe guard + -- against exponential blow-up. + simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks + dmdUnboxWidth :: !Int, -- ^ Whether DmdAnal should optimistically put an + -- Unboxed demand on returned products with at most + -- this number of fields + ifCompression :: Int, + specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr + specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function + specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types + -- Not optional; otherwise ForceSpecConstr can diverge. + binBlobThreshold :: Maybe Word, -- ^ Binary literals (e.g. strings) whose size is above + -- this threshold will be dumped in a binary file + -- by the assembler code generator. 0 and Nothing disables + -- this feature. See 'GHC.StgToCmm.Config'. + liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase + floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating + -- See 'GHC.Core.Opt.Monad.FloatOutSwitches' + + liftLamsRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- recursive function. + liftLamsNonRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- non-recursive function. + liftLamsKnown :: Bool, -- ^ Lambda lift even when this turns a known call + -- into an unknown call. + + cmmProcAlignment :: Maybe Int, -- ^ Align Cmm functions at this boundary or use default. + + historySize :: Int, -- ^ Simplification history size + + importPaths :: [FilePath], + mainModuleNameIs :: ModuleName, + mainFunIs :: Maybe String, + reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth + solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver + -- Typically only 1 is needed + givensFuel :: Int, -- ^ Number of layers of superclass expansion for givens + -- Should be < solverIterations + -- See Note [Expanding Recursive Superclasses and ExpansionFuel] + wantedsFuel :: Int, -- ^ Number of layers of superclass expansion for wanteds + -- Should be < givensFuel + -- See Note [Expanding Recursive Superclasses and ExpansionFuel] + qcsFuel :: Int, -- ^ Number of layers of superclass expansion for quantified constraints + -- Should be < givensFuel + -- See Note [Expanding Recursive Superclasses and ExpansionFuel] + homeUnitId_ :: UnitId, -- ^ Target home unit-id + homeUnitInstanceOf_ :: Maybe UnitId, -- ^ Id of the unit to instantiate + homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations + + -- Note [Filepaths and Multiple Home Units] + workingDirectory :: Maybe FilePath, + thisPackageName :: Maybe String, -- ^ What the package is called, use with multiple home units + hiddenModules :: Set.Set ModuleName, + reexportedModules :: [ReexportedModule], + + -- ways + targetWays_ :: Ways, -- ^ Target way flags from the command line + + -- For object splitting + splitInfo :: Maybe (String,Int), + + -- paths etc. + objectDir :: Maybe String, + dylibInstallName :: Maybe String, + hiDir :: Maybe String, + hieDir :: Maybe String, + stubDir :: Maybe String, + dumpDir :: Maybe String, + + objectSuf_ :: String, + hcSuf :: String, + hiSuf_ :: String, + hieSuf :: String, + + dynObjectSuf_ :: String, + dynHiSuf_ :: String, + + outputFile_ :: Maybe String, + dynOutputFile_ :: Maybe String, + outputHi :: Maybe String, + dynOutputHi :: Maybe String, + dynLibLoader :: DynLibLoader, + + dynamicNow :: !Bool, -- ^ Indicate if we are now generating dynamic output + -- because of -dynamic-too. This predicate is + -- used to query the appropriate fields + -- (outputFile/dynOutputFile, ways, etc.) + + -- | This defaults to 'non-module'. It can be set by + -- 'GHC.Driver.Pipeline.setDumpPrefix' or 'ghc.GHCi.UI.runStmt' based on + -- where its output is going. + dumpPrefix :: FilePath, + + -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.setDumpPrefix' + -- or 'ghc.GHCi.UI.runStmt'. + -- Set by @-ddump-file-prefix@ + dumpPrefixForce :: Maybe FilePath, + + ldInputs :: [Option], + + includePaths :: IncludeSpecs, + libraryPaths :: [String], + frameworkPaths :: [String], -- used on darwin only + cmdlineFrameworks :: [String], -- ditto + + rtsOpts :: Maybe String, + rtsOptsEnabled :: RtsOptsEnabled, + rtsOptsSuggestions :: Bool, + + hpcDir :: String, -- ^ Path to store the .mix files + + -- Plugins + pluginModNames :: [ModuleName], + -- ^ the @-fplugin@ flags given on the command line, in *reverse* + -- order that they're specified on the command line. + pluginModNameOpts :: [(ModuleName,String)], + frontendPluginOpts :: [String], + -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* + -- order that they're specified on the command line. + + externalPluginSpecs :: [ExternalPluginSpec], + -- ^ External plugins loaded from shared libraries + + -- For ghc -M + depMakefile :: FilePath, + depIncludePkgDeps :: Bool, + depIncludeCppDeps :: Bool, + depExcludeMods :: [ModuleName], + depSuffixes :: [String], + + -- Package flags + packageDBFlags :: [PackageDBFlag], + -- ^ The @-package-db@ flags given on the command line, In + -- *reverse* order that they're specified on the command line. + -- This is intended to be applied with the list of "initial" + -- package databases derived from @GHC_PACKAGE_PATH@; see + -- 'getUnitDbRefs'. + + ignorePackageFlags :: [IgnorePackageFlag], + -- ^ The @-ignore-package@ flags from the command line. + -- In *reverse* order that they're specified on the command line. + packageFlags :: [PackageFlag], + -- ^ The @-package@ and @-hide-package@ flags from the command-line. + -- In *reverse* order that they're specified on the command line. + pluginPackageFlags :: [PackageFlag], + -- ^ The @-plugin-package-id@ flags from command line. + -- In *reverse* order that they're specified on the command line. + trustFlags :: [TrustFlag], + -- ^ The @-trust@ and @-distrust@ flags. + -- In *reverse* order that they're specified on the command line. + packageEnv :: Maybe FilePath, + -- ^ Filepath to the package environment file (if overriding default) + + + -- hsc dynamic flags + dumpFlags :: EnumSet DumpFlag, + generalFlags :: EnumSet GeneralFlag, + warningFlags :: EnumSet WarningFlag, + fatalWarningFlags :: EnumSet WarningFlag, + customWarningCategories :: WarningCategorySet, -- See Note [Warning categories] + fatalCustomWarningCategories :: WarningCategorySet, -- in GHC.Unit.Module.Warnings + -- Don't change this without updating extensionFlags: + language :: Maybe Language, + -- | Safe Haskell mode + safeHaskell :: SafeHaskellMode, + safeInfer :: Bool, + safeInferred :: Bool, + -- We store the location of where some extension and flags were turned on so + -- we can produce accurate error messages when Safe Haskell fails due to + -- them. + thOnLoc :: SrcSpan, + newDerivOnLoc :: SrcSpan, + deriveViaOnLoc :: SrcSpan, + overlapInstLoc :: SrcSpan, + incoherentOnLoc :: SrcSpan, + pkgTrustOnLoc :: SrcSpan, + warnSafeOnLoc :: SrcSpan, + warnUnsafeOnLoc :: SrcSpan, + trustworthyOnLoc :: SrcSpan, + -- Don't change this without updating extensionFlags: + -- Here we collect the settings of the language extensions + -- from the command line, the ghci config file and + -- from interactive :set / :seti commands. + extensions :: [OnOff LangExt.Extension], + -- extensionFlags should always be equal to + -- flattenExtensionFlags language extensions + -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used + -- by template-haskell + extensionFlags :: EnumSet LangExt.Extension, + + -- | Unfolding control + -- See Note [Discounts and thresholds] in GHC.Core.Unfold + unfoldingOpts :: !UnfoldingOpts, + + maxWorkerArgs :: Int, + maxForcedSpecArgs :: Int, + + ghciHistSize :: Int, + + -- wasm ghci browser mode + ghciBrowserHost :: !String, + ghciBrowserPort :: !Int, + ghciBrowserPuppeteerLaunchOpts :: !(Maybe String), + ghciBrowserPlaywrightBrowserType :: !(Maybe String), + ghciBrowserPlaywrightLaunchOpts :: !(Maybe String), + + flushOut :: FlushOut, + + ghcVersionFile :: Maybe FilePath, + haddockOptions :: Maybe String, + + -- | GHCi scripts specified by -ghci-script, in reverse order + ghciScripts :: [String], + + -- Output style options + pprUserLength :: Int, + pprCols :: Int, + + useUnicode :: Bool, + useColor :: OverridingBool, + canUseColor :: Bool, + useErrorLinks :: OverridingBool, + canUseErrorLinks :: Bool, + colScheme :: Col.Scheme, + + -- | what kind of {-# SCC #-} to add automatically + profAuto :: ProfAuto, + callerCcFilters :: [CallerCcFilter], + + interactivePrint :: Maybe String, + + -- | Machine dependent flags (-m\ stuff) + sseVersion :: Maybe SseVersion, + bmiVersion :: Maybe BmiVersion, + avx :: Bool, + avx2 :: Bool, + avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. + avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. + avx512f :: Bool, -- Enable AVX-512 instructions. + avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. + fma :: Bool, -- ^ Enable FMA instructions. + + -- Constants used to control the amount of optimization done. + + -- | Max size, in bytes, of inline array allocations. + maxInlineAllocSize :: Int, + + -- | Only inline memcpy if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemcpyInsns :: Int, + + -- | Only inline memset if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemsetInsns :: Int, + + -- | Reverse the order of error messages in GHC/GHCi + reverseErrors :: Bool, + + -- | Limit the maximum number of errors to show + maxErrors :: Maybe Int, + + -- | Unique supply configuration for testing build determinism + initialUnique :: Word64, + uniqueIncrement :: Int, + -- 'Int' because it can be used to test uniques in decreasing order. + + -- | Temporary: CFG Edge weights for fast iterations + cfgWeights :: Weights +} + +class HasDynFlags m where + getDynFlags :: m DynFlags + +{- It would be desirable to have the more generalised + + instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where + getDynFlags = lift getDynFlags + +instance definition. However, that definition would overlap with the +`HasDynFlags (GhcT m)` instance. Instead we define instances for a +couple of common Monad transformers explicitly. -} + +instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where + getDynFlags = lift getDynFlags + +class ContainsDynFlags t where + extractDynFlags :: t -> DynFlags + +----------------------------------------------------------------------------- + +-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value +initDynFlags :: DynFlags -> IO DynFlags +initDynFlags dflags = do + let + -- This is not bulletproof: we test that 'localeEncoding' is Unicode-capable, + -- but potentially 'hGetEncoding' 'stdout' might be different. Still good enough. + canUseUnicode <- do let enc = localeEncoding + str = "‘’" + (withCString enc str $ \cstr -> + do str' <- peekCString enc cstr + return (str == str')) + `catchIOError` \_ -> return False + ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE" + let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode + maybeGhcColorsEnv <- lookupEnv "GHC_COLORS" + maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS" + let adjustCols (Just env) = Col.parseScheme env + adjustCols Nothing = id + let (useColor', colScheme') = + (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv) + (useColor dflags, colScheme dflags) + tmp_dir <- normalise <$> getTemporaryDirectory + return dflags{ + useUnicode = useUnicode', + useColor = useColor', + canUseColor = stderrSupportsAnsiColors, + -- if the terminal supports color, we assume it supports links as well + canUseErrorLinks = stderrSupportsAnsiColors, + colScheme = colScheme', + tmpDir = TempDir tmp_dir + } + +-- | The normal 'DynFlags'. Note that they are not suitable for use in this form +-- and must be fully initialized by 'GHC.runGhc' first. +defaultDynFlags :: Settings -> DynFlags +defaultDynFlags mySettings = +-- See Note [Updating flag description in the User's Guide] + DynFlags { + ghcMode = CompManager, + ghcLink = LinkBinary, + backend = platformDefaultBackend (sTargetPlatform mySettings), + verbosity = 0, + debugLevel = 0, + simplPhases = 2, + maxSimplIterations = 4, + ruleCheck = Nothing, + binBlobThreshold = Just 500000, -- 500K is a good default (see #16190) + maxRelevantBinds = Just 6, + maxValidHoleFits = Just 6, + maxRefHoleFits = Just 6, + refLevelHoleFits = Nothing, + maxUncoveredPatterns = 4, + maxPmCheckModels = 30, + simplTickFactor = 100, + dmdUnboxWidth = 3, -- Default: Assume an unboxed demand on function bodies returning a triple + ifCompression = 2, -- Default: Apply safe compressions + specConstrThreshold = Just 2000, + specConstrCount = Just 3, + specConstrRecursive = 3, + liberateCaseThreshold = Just 2000, + floatLamArgs = Just 0, -- Default: float only if no fvs + liftLamsRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsNonRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsKnown = False, -- Default: don't turn known calls into unknown ones + cmmProcAlignment = Nothing, + + historySize = 20, + strictnessBefore = [], + + parMakeCount = Nothing, + + enableTimeStats = False, + ghcHeapSize = Nothing, + + importPaths = ["."], + mainModuleNameIs = mAIN_NAME, + mainFunIs = Nothing, + reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, + solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, + givensFuel = mAX_GIVENS_FUEL, + wantedsFuel = mAX_WANTEDS_FUEL, + qcsFuel = mAX_QC_FUEL, + + homeUnitId_ = mainUnitId, + homeUnitInstanceOf_ = Nothing, + homeUnitInstantiations_ = [], + + workingDirectory = Nothing, + thisPackageName = Nothing, + hiddenModules = Set.empty, + reexportedModules = [], + + objectDir = Nothing, + dylibInstallName = Nothing, + hiDir = Nothing, + hieDir = Nothing, + stubDir = Nothing, + dumpDir = Nothing, + + objectSuf_ = phaseInputExt StopLn, + hcSuf = phaseInputExt HCc, + hiSuf_ = "hi", + hieSuf = "hie", + + dynObjectSuf_ = "dyn_" ++ phaseInputExt StopLn, + dynHiSuf_ = "dyn_hi", + dynamicNow = False, + + pluginModNames = [], + pluginModNameOpts = [], + frontendPluginOpts = [], + + externalPluginSpecs = [], + + outputFile_ = Nothing, + dynOutputFile_ = Nothing, + outputHi = Nothing, + dynOutputHi = Nothing, + dynLibLoader = SystemDependent, + dumpPrefix = "non-module.", + dumpPrefixForce = Nothing, + ldInputs = [], + includePaths = IncludeSpecs [] [] [], + libraryPaths = [], + frameworkPaths = [], + cmdlineFrameworks = [], + rtsOpts = Nothing, + rtsOptsEnabled = RtsOptsSafeOnly, + rtsOptsSuggestions = True, + + hpcDir = ".hpc", + + packageDBFlags = [], + packageFlags = [], + pluginPackageFlags = [], + ignorePackageFlags = [], + trustFlags = [], + packageEnv = Nothing, + targetWays_ = Set.empty, + splitInfo = Nothing, + + ghcNameVersion = sGhcNameVersion mySettings, + unitSettings = sUnitSettings mySettings, + fileSettings = sFileSettings mySettings, + toolSettings = sToolSettings mySettings, + targetPlatform = sTargetPlatform mySettings, + platformMisc = sPlatformMisc mySettings, + rawSettings = sRawSettings mySettings, + + tmpDir = panic "defaultDynFlags: uninitialized tmpDir", + + llvmOptLevel = 0, + + -- ghc -M values + depMakefile = "Makefile", + depIncludePkgDeps = False, + depIncludeCppDeps = False, + depExcludeMods = [], + depSuffixes = [], + -- end of ghc -M values + ghcVersionFile = Nothing, + haddockOptions = Nothing, + dumpFlags = EnumSet.empty, + generalFlags = EnumSet.fromList (defaultFlags mySettings), + warningFlags = EnumSet.fromList standardWarnings, + fatalWarningFlags = EnumSet.empty, + customWarningCategories = completeWarningCategorySet, + fatalCustomWarningCategories = emptyWarningCategorySet, + ghciScripts = [], + language = Nothing, + safeHaskell = Sf_None, + safeInfer = True, + safeInferred = True, + thOnLoc = noSrcSpan, + newDerivOnLoc = noSrcSpan, + deriveViaOnLoc = noSrcSpan, + overlapInstLoc = noSrcSpan, + incoherentOnLoc = noSrcSpan, + pkgTrustOnLoc = noSrcSpan, + warnSafeOnLoc = noSrcSpan, + warnUnsafeOnLoc = noSrcSpan, + trustworthyOnLoc = noSrcSpan, + extensions = [], + extensionFlags = flattenExtensionFlags Nothing [], + + unfoldingOpts = defaultUnfoldingOpts, + maxWorkerArgs = 10, + maxForcedSpecArgs = 333, + -- 333 is fairly arbitrary, see Note [Forcing specialisation]:FS5 + + ghciHistSize = 50, -- keep a log of length 50 by default + + ghciBrowserHost = "127.0.0.1", + ghciBrowserPort = 0, + ghciBrowserPuppeteerLaunchOpts = Nothing, + ghciBrowserPlaywrightBrowserType = Nothing, + ghciBrowserPlaywrightLaunchOpts = Nothing, + + flushOut = defaultFlushOut, + pprUserLength = 5, + pprCols = 100, + useUnicode = False, + useColor = Auto, + canUseColor = False, + useErrorLinks = Auto, + canUseErrorLinks = False, + colScheme = Col.defaultScheme, + profAuto = NoProfAuto, + callerCcFilters = [], + interactivePrint = Nothing, + sseVersion = Nothing, + bmiVersion = Nothing, + avx = False, + avx2 = False, + avx512cd = False, + avx512er = False, + avx512f = False, + avx512pf = False, + -- Use FMA by default on AArch64 + fma = (platformArch . sTargetPlatform $ mySettings) == ArchAArch64, + + maxInlineAllocSize = 128, + maxInlineMemcpyInsns = 32, + maxInlineMemsetInsns = 32, + + initialUnique = 0, + uniqueIncrement = 1, + + reverseErrors = False, + maxErrors = Nothing, + cfgWeights = defaultWeights + } + +type FatalMessager = String -> IO () + +defaultFatalMessager :: FatalMessager +defaultFatalMessager = hPutStrLn stderr + + +newtype FlushOut = FlushOut (IO ()) + +defaultFlushOut :: FlushOut +defaultFlushOut = FlushOut $ hFlush stdout + +-- OnOffs accumulate in reverse order, so we use foldr in order to +-- process them in the right order +flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension +flattenExtensionFlags ml = foldr g defaultExtensionFlags + where g (On f) flags = EnumSet.insert f flags + g (Off f) flags = EnumSet.delete f flags + defaultExtensionFlags = EnumSet.fromList (languageExtensions ml) + +-- ----------------------------------------------------------------------------- +-- -jN + +-- | The type for the -jN argument, specifying that -j on its own represents +-- using the number of machine processors. +data ParMakeCount + -- | Use this many processors (@-j@ flag). + = ParMakeThisMany Int + -- | Use parallelism with as many processors as possible (@-j@ flag without an argument). + | ParMakeNumProcessors + -- | Use the specific semaphore @@ to control parallelism (@-jsem @ flag). + | ParMakeSemaphore FilePath + +-- | The 'GhcMode' tells us whether we're doing multi-module +-- compilation (controlled via the "GHC" API) or one-shot +-- (single-module) compilation. This makes a difference primarily to +-- the "GHC.Unit.Finder": in one-shot mode we look for interface files for +-- imported modules, but in multi-module mode we look for source files +-- in order to check whether they need to be recompiled. +data GhcMode + = CompManager -- ^ @\-\-make@, GHCi, etc. + | OneShot -- ^ @ghc -c Foo.hs@ + | MkDepend -- ^ @ghc -M@, see "GHC.Unit.Finder" for why we need this + deriving Eq + +instance Outputable GhcMode where + ppr CompManager = text "CompManager" + ppr OneShot = text "OneShot" + ppr MkDepend = text "MkDepend" + +isOneShot :: GhcMode -> Bool +isOneShot OneShot = True +isOneShot _other = False + +-- | What to do in the link step, if there is one. +data GhcLink + = NoLink -- ^ Don't link at all + | LinkBinary -- ^ Link object code into a binary + | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both + -- bytecode and object code). + | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) + | LinkStaticLib -- ^ Link objects into a static lib + | LinkMergedObj -- ^ Link objects into a merged "GHCi object" + deriving (Eq, Show) + +isNoLink :: GhcLink -> Bool +isNoLink NoLink = True +isNoLink _ = False + +-- | We accept flags which make packages visible, but how they select +-- the package varies; this data type reflects what selection criterion +-- is used. +data PackageArg = + PackageArg String -- ^ @-package@, by 'PackageName' + | UnitIdArg Unit -- ^ @-package-id@, by 'Unit' + deriving (Eq, Show) + +instance Outputable PackageArg where + ppr (PackageArg pn) = text "package" <+> text pn + ppr (UnitIdArg uid) = text "unit" <+> ppr uid + +-- | Represents the renaming that may be associated with an exposed +-- package, e.g. the @rns@ part of @-package "foo (rns)"@. +-- +-- Here are some example parsings of the package flags (where +-- a string literal is punned to be a 'ModuleName': +-- +-- * @-package foo@ is @ModRenaming True []@ +-- * @-package foo ()@ is @ModRenaming False []@ +-- * @-package foo (A)@ is @ModRenaming False [("A", "A")]@ +-- * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@ +-- * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@ +data ModRenaming = ModRenaming { + modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? + modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope + -- under name @n@. + } deriving (Eq) +instance Outputable ModRenaming where + ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) + +-- | Flags for manipulating the set of non-broken packages. +newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@ + deriving (Eq) + +-- | Flags for manipulating package trust. +data TrustFlag + = TrustPackage String -- ^ @-trust@ + | DistrustPackage String -- ^ @-distrust@ + deriving (Eq) + +-- | Flags for manipulating packages visibility. +data PackageFlag + = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ + | HidePackage String -- ^ @-hide-package@ + deriving (Eq) -- NB: equality instance is used by packageFlagsChanged + +data PackageDBFlag + = PackageDB PkgDbRef + | NoUserPackageDB + | NoGlobalPackageDB + | ClearPackageDBs + deriving (Eq) + +packageFlagsChanged :: DynFlags -> DynFlags -> Bool +packageFlagsChanged idflags1 idflags0 = + packageFlags idflags1 /= packageFlags idflags0 || + ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 || + pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 || + trustFlags idflags1 /= trustFlags idflags0 || + packageDBFlags idflags1 /= packageDBFlags idflags0 || + packageGFlags idflags1 /= packageGFlags idflags0 + where + packageGFlags dflags = map (`gopt` dflags) + [ Opt_HideAllPackages + , Opt_HideAllPluginPackages + , Opt_AutoLinkPackages ] + +instance Outputable PackageFlag where + ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) + ppr (HidePackage str) = text "-hide-package" <+> text str + +data DynLibLoader + = Deployable + | SystemDependent + deriving Eq + +data RtsOptsEnabled + = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly + | RtsOptsAll + deriving (Show) + +-- | Are we building with @-fPIE@ or @-fPIC@ enabled? +positionIndependent :: DynFlags -> Bool +positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags + +-- Note [-dynamic-too business] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- With -dynamic-too flag, we try to build both the non-dynamic and dynamic +-- objects in a single run of the compiler: the pipeline is the same down to +-- Core optimisation, then the backend (from Core to object code) is executed +-- twice. +-- +-- The implementation is currently rather hacky, for example, we don't clearly separate non-dynamic +-- and dynamic loaded interfaces (#9176). +-- +-- To make matters worse, we automatically enable -dynamic-too when some modules +-- need Template-Haskell and GHC is dynamically linked (cf +-- GHC.Driver.Pipeline.compileOne'). +-- +-- We used to try and fall back from a dynamic-too failure but this feature +-- didn't work as expected (#20446) so it was removed to simplify the +-- implementation and not obscure latent bugs. + +data DynamicTooState + = DT_Dont -- ^ Don't try to build dynamic objects too + | DT_OK -- ^ Will still try to generate dynamic objects + | DT_Dyn -- ^ Currently generating dynamic objects (in the backend) + deriving (Eq,Show,Ord) + +dynamicTooState :: DynFlags -> DynamicTooState +dynamicTooState dflags + | not (gopt Opt_BuildDynamicToo dflags) = DT_Dont + | dynamicNow dflags = DT_Dyn + | otherwise = DT_OK + +setDynamicNow :: DynFlags -> DynFlags +setDynamicNow dflags0 = + dflags0 + { dynamicNow = True + } + +data PkgDbRef + = GlobalPkgDb + | UserPkgDb + | PkgDbPath FilePath + deriving Eq + + + +-- An argument to --reexported-module which can optionally specify a module renaming. +data ReexportedModule = ReexportedModule { reexportFrom :: ModuleName + , reexportTo :: ModuleName + } + +instance Outputable ReexportedModule where + ppr (ReexportedModule from to) = + if from == to then ppr from + else ppr from <+> text "as" <+> ppr to + +{- Note [Implicit include paths] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The compile driver adds the path to the folder containing the source file being + compiled to the 'IncludeSpecs', and this change gets recorded in the 'DynFlags' + that are used later to compute the interface file. Because of this, + the flags fingerprint derived from these 'DynFlags' and recorded in the + interface file will end up containing the absolute path to the source folder. + + Build systems with a remote cache like Bazel or Buck (or Shake, see #16956) + store the build artifacts produced by a build BA for reuse in subsequent builds. + + Embedding source paths in interface fingerprints will thwart these attempts and + lead to unnecessary recompilations when the source paths in BA differ from the + source paths in subsequent builds. + -} + +hasPprDebug :: DynFlags -> Bool +hasPprDebug = dopt Opt_D_ppr_debug + +hasNoDebugOutput :: DynFlags -> Bool +hasNoDebugOutput = dopt Opt_D_no_debug_output + +hasNoStateHack :: DynFlags -> Bool +hasNoStateHack = gopt Opt_G_NoStateHack + +hasNoOptCoercion :: DynFlags -> Bool +hasNoOptCoercion = gopt Opt_G_NoOptCoercion + +-- | Test whether a 'DumpFlag' is set +dopt :: DumpFlag -> DynFlags -> Bool +dopt = getDumpFlagFrom verbosity dumpFlags + +-- | Set a 'DumpFlag' +dopt_set :: DynFlags -> DumpFlag -> DynFlags +dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) } + +-- | Unset a 'DumpFlag' +dopt_unset :: DynFlags -> DumpFlag -> DynFlags +dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) } + +-- | Test whether a 'GeneralFlag' is set +-- +-- Note that `dynamicNow` (i.e., dynamic objects built with `-dynamic-too`) +-- always implicitly enables Opt_PIC, Opt_ExternalDynamicRefs, and disables +-- Opt_SplitSections. +-- +gopt :: GeneralFlag -> DynFlags -> Bool +gopt Opt_PIC dflags + | dynamicNow dflags = True +gopt Opt_ExternalDynamicRefs dflags + | dynamicNow dflags = True +gopt Opt_SplitSections dflags + | dynamicNow dflags = False +gopt f dflags = f `EnumSet.member` generalFlags dflags + +-- | Set a 'GeneralFlag' +gopt_set :: DynFlags -> GeneralFlag -> DynFlags +gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) } + +-- | Unset a 'GeneralFlag' +gopt_unset :: DynFlags -> GeneralFlag -> DynFlags +gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) } + +-- | Test whether a 'WarningFlag' is set +wopt :: WarningFlag -> DynFlags -> Bool +wopt f dflags = f `EnumSet.member` warningFlags dflags + +-- | Set a 'WarningFlag' +wopt_set :: DynFlags -> WarningFlag -> DynFlags +wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) } + +-- | Unset a 'WarningFlag' +wopt_unset :: DynFlags -> WarningFlag -> DynFlags +wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) } + +-- | Test whether a 'WarningFlag' is set as fatal +wopt_fatal :: WarningFlag -> DynFlags -> Bool +wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags + +-- | Mark a 'WarningFlag' as fatal (do not set the flag) +wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_set_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) } + +-- | Mark a 'WarningFlag' as not fatal +wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_unset_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } + + +-- | Enable all custom warning categories. +wopt_set_all_custom :: DynFlags -> DynFlags +wopt_set_all_custom dfs + = dfs{ customWarningCategories = completeWarningCategorySet } + +-- | Disable all custom warning categories. +wopt_unset_all_custom :: DynFlags -> DynFlags +wopt_unset_all_custom dfs + = dfs{ customWarningCategories = emptyWarningCategorySet } + +-- | Mark all custom warning categories as fatal (do not set the flags). +wopt_set_all_fatal_custom :: DynFlags -> DynFlags +wopt_set_all_fatal_custom dfs + = dfs { fatalCustomWarningCategories = completeWarningCategorySet } + +-- | Mark all custom warning categories as non-fatal. +wopt_unset_all_fatal_custom :: DynFlags -> DynFlags +wopt_unset_all_fatal_custom dfs + = dfs { fatalCustomWarningCategories = emptyWarningCategorySet } + +-- | Set a custom 'WarningCategory' +wopt_set_custom :: DynFlags -> WarningCategory -> DynFlags +wopt_set_custom dfs f = dfs{ customWarningCategories = insertWarningCategorySet f (customWarningCategories dfs) } + +-- | Unset a custom 'WarningCategory' +wopt_unset_custom :: DynFlags -> WarningCategory -> DynFlags +wopt_unset_custom dfs f = dfs{ customWarningCategories = deleteWarningCategorySet f (customWarningCategories dfs) } + +-- | Mark a custom 'WarningCategory' as fatal (do not set the flag) +wopt_set_fatal_custom :: DynFlags -> WarningCategory -> DynFlags +wopt_set_fatal_custom dfs f + = dfs { fatalCustomWarningCategories = insertWarningCategorySet f (fatalCustomWarningCategories dfs) } + +-- | Mark a custom 'WarningCategory' as not fatal +wopt_unset_fatal_custom :: DynFlags -> WarningCategory -> DynFlags +wopt_unset_fatal_custom dfs f + = dfs { fatalCustomWarningCategories = deleteWarningCategorySet f (fatalCustomWarningCategories dfs) } + +-- | Are there any custom warning categories enabled? +wopt_any_custom :: DynFlags -> Bool +wopt_any_custom dfs = not (nullWarningCategorySet (customWarningCategories dfs)) + + +-- | Test whether a 'LangExt.Extension' is set +xopt :: LangExt.Extension -> DynFlags -> Bool +xopt f dflags = f `EnumSet.member` extensionFlags dflags + +-- | Set a 'LangExt.Extension' +xopt_set :: DynFlags -> LangExt.Extension -> DynFlags +xopt_set dfs f + = let onoffs = On f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Unset a 'LangExt.Extension' +xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags +xopt_unset dfs f + = let onoffs = Off f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Set or unset a 'LangExt.Extension', unless it has been explicitly +-- set or unset before. +xopt_set_unlessExplSpec + :: LangExt.Extension + -> (DynFlags -> LangExt.Extension -> DynFlags) + -> DynFlags -> DynFlags +xopt_set_unlessExplSpec ext setUnset dflags = + let referedExts = stripOnOff <$> extensions dflags + stripOnOff (On x) = x + stripOnOff (Off x) = x + in + if ext `elem` referedExts then dflags else setUnset dflags ext + +xopt_DuplicateRecordFields :: DynFlags -> FieldLabel.DuplicateRecordFields +xopt_DuplicateRecordFields dfs + | xopt LangExt.DuplicateRecordFields dfs = FieldLabel.DuplicateRecordFields + | otherwise = FieldLabel.NoDuplicateRecordFields + +xopt_FieldSelectors :: DynFlags -> FieldLabel.FieldSelectors +xopt_FieldSelectors dfs + | xopt LangExt.FieldSelectors dfs = FieldLabel.FieldSelectors + | otherwise = FieldLabel.NoFieldSelectors + +lang_set :: DynFlags -> Maybe Language -> DynFlags +lang_set dflags lang = + dflags { + language = lang, + extensionFlags = flattenExtensionFlags lang (extensions dflags) + } + +defaultFlags :: Settings -> [GeneralFlag] +defaultFlags settings +-- See Note [Updating flag description in the User's Guide] + = [ Opt_AutoLinkPackages, + Opt_DiagnosticsShowCaret, + Opt_EmbedManifest, + Opt_FamAppCache, + Opt_GenManifest, + Opt_GhciHistory, + Opt_GhciSandbox, + Opt_GhciDoLoadTargets, + Opt_HelpfulErrors, + Opt_KeepHiFiles, + Opt_KeepOFiles, + Opt_OmitYields, + Opt_PrintBindContents, + Opt_ProfCountEntries, + Opt_SharedImplib, + Opt_SimplPreInlining, + Opt_VersionMacros, + Opt_RPath, + Opt_DumpWithWays, + Opt_CompactUnwind, + Opt_ShowErrorContext, + Opt_SuppressStgReps, + Opt_UnoptimizedCoreForInterpreter, + Opt_SpecialiseIncoherents, + Opt_WriteSelfRecompInfo + ] + + ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] + -- The default -O0 options + + -- Default floating flags (see Note [RHS Floating]) + ++ [ Opt_LocalFloatOut, Opt_LocalFloatOutTopLevel ] + + ++ default_PIC platform + + ++ validHoleFitDefaults + + where platform = sTargetPlatform settings + +-- | These are the default settings for the display and sorting of valid hole +-- fits in typed-hole error messages. See Note [Valid hole fits include ...] + -- in the "GHC.Tc.Errors.Hole" module. +validHoleFitDefaults :: [GeneralFlag] +validHoleFitDefaults + = [ Opt_ShowTypeAppOfHoleFits + , Opt_ShowTypeOfHoleFits + , Opt_ShowProvOfHoleFits + , Opt_ShowMatchesOfHoleFits + , Opt_ShowValidHoleFits + , Opt_SortValidHoleFits + , Opt_SortBySizeHoleFits + , Opt_ShowHoleConstraints ] + +-- Note [When is StarIsType enabled] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The StarIsType extension determines whether to treat '*' as a regular type +-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType +-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is +-- enabled. +-- +-- Programs that use TypeOperators might expect to repurpose '*' for +-- multiplication or another binary operation, but making TypeOperators imply +-- NoStarIsType caused too much breakage on Hackage. +-- + +-- +-- Note [Documenting optimisation flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of flags enabled for particular optimisation levels +-- please remember to update the User's Guide. The relevant file is: +-- +-- docs/users_guide/using-optimisation.rst +-- +-- Make sure to note whether a flag is implied by -O0, -O or -O2. + +optLevelFlags :: [([Int], GeneralFlag)] +-- Default settings of flags, before any command-line overrides +optLevelFlags -- see Note [Documenting optimisation flags] + = [ ([0,1,2], Opt_DoLambdaEtaExpansion) + , ([1,2], Opt_DoCleverArgEtaExpansion) -- See Note [Eta expansion of arguments in CorePrep] + , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] + , ([0,1,2], Opt_ProfManualCcs ) + , ([2], Opt_DictsStrict) + + , ([0], Opt_IgnoreInterfacePragmas) + , ([0], Opt_OmitInterfacePragmas) + + , ([1,2], Opt_CoreConstantFolding) + + , ([1,2], Opt_CallArity) + , ([1,2], Opt_Exitification) + , ([1,2], Opt_CaseMerge) + , ([1,2], Opt_CaseFolding) + , ([1,2], Opt_CmmElimCommonBlocks) + , ([2], Opt_AsmShortcutting) + , ([1,2], Opt_CmmSink) + , ([1,2], Opt_CmmStaticPred) + , ([1,2], Opt_CSE) + , ([1,2], Opt_StgCSE) + , ([2], Opt_StgLiftLams) + , ([1,2], Opt_CmmControlFlow) + + , ([1,2], Opt_EnableRewriteRules) + -- Off for -O0. Otherwise we desugar list literals + -- to 'build' but don't run the simplifier passes that + -- would rewrite them back to cons cells! This seems + -- silly, and matters for the GHCi debugger. + + , ([1,2], Opt_FloatIn) + , ([1,2], Opt_FullLaziness) + , ([1,2], Opt_IgnoreAsserts) + , ([1,2], Opt_Loopification) + , ([1,2], Opt_CfgBlocklayout) -- Experimental + + , ([1,2], Opt_Specialise) + , ([1,2], Opt_CrossModuleSpecialise) + , ([1,2], Opt_InlineGenerics) + , ([1,2], Opt_Strictness) + , ([1,2], Opt_UnboxSmallStrictFields) + , ([1,2], Opt_CprAnal) + , ([1,2], Opt_WorkerWrapper) + , ([1,2], Opt_SolveConstantDicts) + , ([1,2], Opt_NumConstantFolding) + + , ([2], Opt_LiberateCase) + , ([2], Opt_SpecConstr) + , ([2], Opt_FastPAPCalls) +-- , ([2], Opt_RegsGraph) +-- RegsGraph suffers performance regression. See #7679 +-- , ([2], Opt_StaticArgumentTransformation) +-- Static Argument Transformation needs investigation. See #9374 + , ([0,1,2], Opt_SpecEval) + , ([], Opt_SpecEvalDictFun) + ] + + +default_PIC :: Platform -> [GeneralFlag] +default_PIC platform = + case (platformOS platform, platformArch platform) of + -- Darwin always requires PIC. Especially on more recent macOS releases + -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses + -- while we could work around this on x86_64 (like WINE does), we won't be + -- able on aarch64, where this is enforced. + (OSDarwin, ArchX86_64) -> [Opt_PIC] + -- For AArch64, we need to always have PIC enabled. The relocation model + -- on AArch64 does not permit arbitrary relocations. Under ASLR, we can't + -- control much how far apart symbols are in memory for our in-memory static + -- linker; and thus need to ensure we get sufficiently capable relocations. + -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux as on top + -- of that. Subsequently we expect all code on aarch64/linux (and macOS) to + -- be built with -fPIC. + (OSDarwin, ArchAArch64) -> [Opt_PIC] + (OSLinux, ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs] + (OSLinux, ArchARM {}) -> [Opt_PIC, Opt_ExternalDynamicRefs] + (OSLinux, ArchRISCV64 {}) -> [Opt_PIC, Opt_ExternalDynamicRefs] + (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in + -- OpenBSD since 5.3 release + -- (1 May 2013) we need to + -- always generate PIC. See + -- #10597 for more + -- information. + (OSLinux, ArchLoongArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs] + _ -> [] + +-- | The language extensions implied by the various language variants. +-- When updating this be sure to update the flag documentation in +-- @docs/users_guide/exts@. +languageExtensions :: Maybe Language -> [LangExt.Extension] + +-- Nothing: the default case +languageExtensions Nothing = languageExtensions (Just defaultLanguage) + +languageExtensions (Just Haskell98) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.CUSKs, + LangExt.MonomorphismRestriction, + LangExt.NPlusKPatterns, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.FieldSelectors, + LangExt.NondecreasingIndentation, + -- strictly speaking non-standard, but we always had this + -- on implicitly before the option was added in 7.1, and + -- turning it off breaks code, so we're keeping it on for + -- backwards compatibility. Cabal uses -XHaskell98 by + -- default unless you specify another language. + LangExt.DeepSubsumption, + -- Non-standard but enabled for backwards compatability (see GHC proposal #511) + LangExt.ListTuplePuns, + LangExt.ImplicitStagePersistence + ] + +languageExtensions (Just Haskell2010) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.CUSKs, + LangExt.MonomorphismRestriction, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.EmptyDataDecls, + LangExt.ForeignFunctionInterface, + LangExt.PatternGuards, + LangExt.DoAndIfThenElse, + LangExt.FieldSelectors, + LangExt.RelaxedPolyRec, + LangExt.DeepSubsumption, + LangExt.ListTuplePuns, + LangExt.ImplicitStagePersistence + ] + +languageExtensions (Just GHC2021) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.MonomorphismRestriction, + LangExt.TraditionalRecordSyntax, + LangExt.EmptyDataDecls, + LangExt.ForeignFunctionInterface, + LangExt.PatternGuards, + LangExt.DoAndIfThenElse, + LangExt.FieldSelectors, + LangExt.RelaxedPolyRec, + LangExt.ListTuplePuns, + -- Now the new extensions (not in Haskell2010) + LangExt.BangPatterns, + LangExt.BinaryLiterals, + LangExt.ConstrainedClassMethods, + LangExt.ConstraintKinds, + LangExt.DeriveDataTypeable, + LangExt.DeriveFoldable, + LangExt.DeriveFunctor, + LangExt.DeriveGeneric, + LangExt.DeriveLift, + LangExt.DeriveTraversable, + LangExt.EmptyCase, + LangExt.EmptyDataDeriving, + LangExt.ExistentialQuantification, + LangExt.ExplicitForAll, + LangExt.FlexibleContexts, + LangExt.FlexibleInstances, + LangExt.GADTSyntax, + LangExt.GeneralizedNewtypeDeriving, + LangExt.HexFloatLiterals, + LangExt.ImportQualifiedPost, + LangExt.InstanceSigs, + LangExt.KindSignatures, + LangExt.MultiParamTypeClasses, + LangExt.NamedFieldPuns, + LangExt.NamedWildCards, + LangExt.NumericUnderscores, + LangExt.PolyKinds, + LangExt.PostfixOperators, + LangExt.RankNTypes, + LangExt.ScopedTypeVariables, + LangExt.StandaloneDeriving, + LangExt.StandaloneKindSignatures, + LangExt.TupleSections, + LangExt.TypeApplications, + LangExt.TypeOperators, + LangExt.TypeSynonymInstances, + LangExt.ImplicitStagePersistence + ] + +languageExtensions (Just GHC2024) + = languageExtensions (Just GHC2021) ++ + [LangExt.DataKinds, + LangExt.DerivingStrategies, + LangExt.DisambiguateRecordFields, + LangExt.ExplicitNamespaces, + LangExt.GADTs, + LangExt.MonoLocalBinds, + LangExt.LambdaCase, + LangExt.RoleAnnotations] + +ways :: DynFlags -> Ways +ways dflags + | dynamicNow dflags = addWay WayDyn (targetWays_ dflags) + | otherwise = targetWays_ dflags + +-- | Get target profile +targetProfile :: DynFlags -> Profile +targetProfile dflags = Profile (targetPlatform dflags) (ways dflags) + +-- +-- System tool settings and locations + +programName :: DynFlags -> String +programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags +projectVersion :: DynFlags -> String +projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags) +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags +topDir :: DynFlags -> FilePath +topDir dflags = fileSettings_topDir $ fileSettings dflags +toolDir :: DynFlags -> Maybe FilePath +toolDir dflags = fileSettings_toolDir $ fileSettings dflags +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags +globalPackageDatabasePath :: DynFlags -> FilePath +globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags + +-- | The directory for this version of ghc in the user's app directory +-- The appdir used to be in ~/.ghc but to respect the XDG specification +-- we want to move it under $XDG_DATA_HOME/ +-- However, old tooling (like cabal) might still write package environments +-- to the old directory, so we prefer that if a subdirectory of ~/.ghc +-- with the correct target and GHC version suffix exists. +-- +-- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that +-- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR +-- +-- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version +versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath +versionedAppDir appname platform = do + -- Make sure we handle the case the HOME isn't set (see #11678) + -- We need to fallback to the old scheme if the subdirectory exists. + msum $ map (checkIfExists <=< fmap ( versionedFilePath platform)) + [ tryMaybeT $ getAppUserDataDirectory appname -- this is ~/.ghc/ + , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/ + ] + where + checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case + True -> pure dir + False -> MaybeT (pure Nothing) + +versionedFilePath :: ArchOS -> FilePath +versionedFilePath platform = uniqueSubdir platform + +-- | Access the unit-id of the version of `base` which we will automatically link +-- against. +baseUnitId :: DynFlags -> UnitId +baseUnitId dflags = unitSettings_baseUnitId (unitSettings dflags) + +-- SDoc +------------------------------------------- +-- | Initialize the pretty-printing options +initSDocContext :: DynFlags -> PprStyle -> SDocContext +initSDocContext dflags style = SDC + { sdocStyle = style + , sdocColScheme = colScheme dflags + , sdocLastColour = Col.colReset + , sdocShouldUseColor = overrideWith (canUseColor dflags) (useColor dflags) + , sdocDefaultDepth = pprUserLength dflags + , sdocLineLength = pprCols dflags + , sdocCanUseUnicode = useUnicode dflags + , sdocPrintErrIndexLinks = overrideWith (canUseErrorLinks dflags) (useErrorLinks dflags) + , sdocHexWordLiterals = gopt Opt_HexWordLiterals dflags + , sdocPprDebug = dopt Opt_D_ppr_debug dflags + , sdocPrintUnicodeSyntax = gopt Opt_PrintUnicodeSyntax dflags + , sdocPrintCaseAsLet = gopt Opt_PprCaseAsLet dflags + , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags + , sdocPrintAxiomIncomps = gopt Opt_PrintAxiomIncomps dflags + , sdocPrintExplicitKinds = gopt Opt_PrintExplicitKinds dflags + , sdocPrintExplicitCoercions = gopt Opt_PrintExplicitCoercions dflags + , sdocPrintExplicitRuntimeReps = gopt Opt_PrintExplicitRuntimeReps dflags + , sdocPrintExplicitForalls = gopt Opt_PrintExplicitForalls dflags + , sdocPrintPotentialInstances = gopt Opt_PrintPotentialInstances dflags + , sdocPrintEqualityRelations = gopt Opt_PrintEqualityRelations dflags + , sdocSuppressTicks = gopt Opt_SuppressTicks dflags + , sdocSuppressTypeSignatures = gopt Opt_SuppressTypeSignatures dflags + , sdocSuppressTypeApplications = gopt Opt_SuppressTypeApplications dflags + , sdocSuppressIdInfo = gopt Opt_SuppressIdInfo dflags + , sdocSuppressCoercions = gopt Opt_SuppressCoercions dflags + , sdocSuppressCoercionTypes = gopt Opt_SuppressCoercionTypes dflags + , sdocSuppressUnfoldings = gopt Opt_SuppressUnfoldings dflags + , sdocSuppressVarKinds = gopt Opt_SuppressVarKinds dflags + , sdocSuppressUniques = gopt Opt_SuppressUniques dflags + , sdocSuppressModulePrefixes = gopt Opt_SuppressModulePrefixes dflags + , sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags + , sdocSuppressStgReps = gopt Opt_SuppressStgReps dflags + , sdocErrorSpans = gopt Opt_ErrorSpans dflags + , sdocStarIsType = xopt LangExt.StarIsType dflags + , sdocLinearTypes = xopt LangExt.LinearTypes dflags + , sdocListTuplePuns = xopt LangExt.ListTuplePuns dflags + , sdocPrintTypeAbbreviations = True + , sdocUnitIdForUser = ftext + } + +-- | Initialize the pretty-printing options using the default user style +initDefaultSDocContext :: DynFlags -> SDocContext +initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle + +initPromotionTickContext :: DynFlags -> PromotionTickContext +initPromotionTickContext dflags = + PromTickCtx { + ptcListTuplePuns = xopt LangExt.ListTuplePuns dflags, + ptcPrintRedundantPromTicks = gopt Opt_PrintRedundantPromotionTicks dflags + } + +-- ----------------------------------------------------------------------------- +-- SSE, AVX, FMA + +isSse3Enabled :: DynFlags -> Bool +isSse3Enabled dflags = sseVersion dflags >= Just SSE3 + +isSsse3Enabled :: DynFlags -> Bool +isSsse3Enabled dflags = sseVersion dflags >= Just SSSE3 + +isSse4_1Enabled :: DynFlags -> Bool +isSse4_1Enabled dflags = sseVersion dflags >= Just SSE4 + +isSse4_2Enabled :: DynFlags -> Bool +isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 + +isAvxEnabled :: DynFlags -> Bool +isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags + +isAvx2Enabled :: DynFlags -> Bool +isAvx2Enabled dflags = avx2 dflags || avx512f dflags + +isAvx512cdEnabled :: DynFlags -> Bool +isAvx512cdEnabled dflags = avx512cd dflags + +isAvx512erEnabled :: DynFlags -> Bool +isAvx512erEnabled dflags = avx512er dflags + +isAvx512fEnabled :: DynFlags -> Bool +isAvx512fEnabled dflags = avx512f dflags + +isAvx512pfEnabled :: DynFlags -> Bool +isAvx512pfEnabled dflags = avx512pf dflags + +isFmaEnabled :: DynFlags -> Bool +isFmaEnabled dflags = fma dflags + +-- ----------------------------------------------------------------------------- +-- BMI2 + +isBmiEnabled :: DynFlags -> Bool +isBmiEnabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI1 + ArchX86 -> bmiVersion dflags >= Just BMI1 + _ -> False + +isBmi2Enabled :: DynFlags -> Bool +isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI2 + ArchX86 -> bmiVersion dflags >= Just BMI2 + _ -> False diff --git a/GHC/Driver/Env.hs b/GHC/Driver/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Env.hs @@ -0,0 +1,453 @@ +{-# LANGUAGE LambdaCase #-} +module GHC.Driver.Env + ( Hsc(..) + , HscEnv (..) + , hsc_mod_graph + , setModuleGraph + , hscUpdateFlags + , hscSetFlags + , hsc_home_unit + , hsc_home_unit_maybe + , hsc_units + , hsc_HPT + , hsc_HUE + , hsc_HUG + , hsc_all_home_unit_ids + , hscUpdateLoggerFlags + , hscUpdateHUG + , hscInsertHPT + , hscSetActiveHomeUnit + , hscSetActiveUnitId + , hscActiveUnitId + , runHsc + , runHsc' + , mkInteractiveHscEnv + , runInteractiveHsc + , hscEPS + , hscInterp + , prepareAnnotations + , discardIC + , lookupType + , lookupIfaceByModule + , lookupIfaceByModuleHsc + , mainModIs + + , hugRulesBelow + , hugInstancesBelow + , hugAnnsBelow + , hugCompleteSigsBelow + + -- * Legacy API + , hscUpdateHPT + ) +where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Driver.Errors ( printOrThrowDiagnostics ) +import GHC.Driver.Errors.Types ( GhcMessage ) +import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig) +import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) ) + +import GHC.Runtime.Context +import GHC.Runtime.Interpreter.Types (Interp) + +import GHC.Unit +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModDetails +import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable +import GHC.Unit.Home.Graph +import GHC.Unit.Module.Graph +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Env as UnitEnv +import GHC.Unit.External + +import GHC.Types.Error ( emptyMessages, Messages ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.TyThing + +import GHC.Data.Maybe + +import GHC.Utils.Exception as Ex +import GHC.Utils.Outputable +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Logger + +import GHC.Core.Rules +import GHC.Types.Annotations +import GHC.Types.CompleteMatch +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Builtin.Names + +import Data.IORef +import qualified Data.Set as Set + +runHsc :: HscEnv -> Hsc a -> IO a +runHsc hsc_env hsc = do + (a, w) <- runHsc' hsc_env hsc + let dflags = hsc_dflags hsc_env + let !diag_opts = initDiagOpts dflags + !print_config = initPrintConfig dflags + printOrThrowDiagnostics (hsc_logger hsc_env) print_config diag_opts w + return a + +runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage) +runHsc' hsc_env (Hsc hsc) = hsc hsc_env emptyMessages + +-- | Switches in the DynFlags and Plugins from the InteractiveContext +mkInteractiveHscEnv :: HscEnv -> HscEnv +mkInteractiveHscEnv hsc_env = + let ic = hsc_IC hsc_env + in hscSetFlags (ic_dflags ic) $ + hsc_env { hsc_plugins = ic_plugins ic } + +-- | A variant of runHsc that switches in the DynFlags and Plugins from the +-- InteractiveContext before running the Hsc computation. +runInteractiveHsc :: HscEnv -> Hsc a -> IO a +runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) + +hsc_home_unit :: HscEnv -> HomeUnit +hsc_home_unit = ue_unsafeHomeUnit . hsc_unit_env + +hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit +hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env + +hsc_units :: HasDebugCallStack => HscEnv -> UnitState +hsc_units = ue_homeUnitState . hsc_unit_env + +hsc_HPT :: HscEnv -> HomePackageTable +hsc_HPT = ue_hpt . hsc_unit_env + +hsc_HUE :: HscEnv -> HomeUnitEnv +hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env + +hsc_HUG :: HscEnv -> HomeUnitGraph +hsc_HUG = ue_home_unit_graph . hsc_unit_env + +hsc_mod_graph :: HscEnv -> ModuleGraph +hsc_mod_graph = ue_module_graph . hsc_unit_env + +hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId +hsc_all_home_unit_ids = HUG.allUnits . hsc_HUG + +hscInsertHPT :: HomeModInfo -> HscEnv -> IO () +hscInsertHPT hmi hsc_env = UnitEnv.insertHpt hmi (hsc_unit_env hsc_env) + +hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv +hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) } + +setModuleGraph :: ModuleGraph -> HscEnv -> HscEnv +setModuleGraph mod_graph hsc_env = hsc_env { hsc_unit_env = (hsc_unit_env hsc_env) { ue_module_graph = mod_graph } } + +{- + +Note [Target code interpreter] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Template Haskell and GHCi use an interpreter to execute code that is built for +the compiler target platform (= code host platform) on the compiler host +platform (= code build platform). + +The internal interpreter can be used when both platforms are the same and when +the built code is compatible with the compiler itself (same way, etc.). This +interpreter is not always available: for instance stage1 compiler doesn't have +it because there might be an ABI mismatch between the code objects (built by +stage1 compiler) and the stage1 compiler itself (built by stage0 compiler). + +In most cases, an external interpreter can be used instead: it runs in a +separate process and it communicates with the compiler via a two-way message +passing channel. The process is lazily spawned to avoid overhead when it is not +used. + +The target code interpreter to use can be selected per session via the +`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in +which case Template Haskell and GHCi will fail to run. The interpreter to use is +configured via command-line flags (in `GHC.setTopSessionDynFlags`). + + +-} + +-- Note [hsc_type_env_var hack] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- hsc_type_env_var is used to initialize tcg_type_env_var, and +-- eventually it is the mutable variable that is queried from +-- if_rec_types to get a TypeEnv. So, clearly, it's something +-- related to knot-tying (see Note [Tying the knot]). +-- hsc_type_env_var is used in two places: initTcRn (where +-- it initializes tcg_type_env_var) and initIfaceCheck +-- (where it initializes if_rec_types). +-- +-- But why do we need a way to feed a mutable variable in? Why +-- can't we just initialize tcg_type_env_var when we start +-- typechecking? The problem is we need to knot-tie the +-- EPS, and we may start adding things to the EPS before type +-- checking starts. +-- +-- Here is a concrete example. Suppose we are running +-- "ghc -c A.hs", and we have this file system state: +-- +-- A.hs-boot A.hi-boot **up to date** +-- B.hs B.hi **up to date** +-- A.hs A.hi **stale** +-- +-- The first thing we do is run checkOldIface on A.hi. +-- checkOldIface will call loadInterface on B.hi so it can +-- get its hands on the fingerprints, to find out if A.hi +-- needs recompilation. But loadInterface also populates +-- the EPS! And so if compilation turns out to be necessary, +-- as it is in this case, the thunks we put into the EPS for +-- B.hi need to have the correct if_rec_types mutable variable +-- to query. +-- +-- If the mutable variable is only allocated WHEN we start +-- typechecking, then that's too late: we can't get the +-- information to the thunks. So we need to pre-commit +-- to a type variable in 'hscIncrementalCompile' BEFORE we +-- check the old interface. +-- +-- This is all a massive hack because arguably checkOldIface +-- should not populate the EPS. But that's a refactor for +-- another day. + +-- | Retrieve the ExternalPackageState cache. +hscEPS :: HscEnv -> IO ExternalPackageState +hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env))) + +-------------------------------------------------------------------------------- +-- * Queries on Transitive Closure +-------------------------------------------------------------------------------- + +-- | Find all rules in modules that are in the transitive closure of the given +-- module. +hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase +hugRulesBelow hsc_env uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> + hugSomeThingsBelowUs (md_rules . hm_details) False hsc_env uid mn + +-- | Get annotations from all modules "below" this one (in the dependency +-- sense) within the home units. If the module is @Nothing@, returns /all/ +-- annotations in the home units. +hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv +hugAnnsBelow hsc_env uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> + hugSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn + +-- | Find all COMPLETE pragmas in modules that are in the transitive closure of the +-- given module. +hugCompleteSigsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO CompleteMatches +hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> + hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn + +-- | Find instances visible from the given set of imports +hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst]) +hugInstancesBelow hsc_env uid mnwib = do + let mn = gwib_mod mnwib + (insts, famInsts) <- + unzip . concat <$> + hugSomeThingsBelowUs (\mod_info -> + let details = hm_details mod_info + -- Don't include instances for the current module + in if moduleName (mi_module (hm_iface mod_info)) == mn + then [] + else [(md_insts details, md_fam_insts details)]) + True -- Include -hi-boot + hsc_env + uid + mnwib + return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) + +-- | Get things from modules in the transitive closure of the given module. +-- +-- Note: Don't expose this function. This is a footgun if exposed! +hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]] +-- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk +-- These things are currently stored in the EPS for home packages. (See #25795 for +-- progress in removing these kind of checks; and making these functions of +-- `UnitEnv` rather than `HscEnv`) +-- See Note [Downsweep and the ModuleGraph] +hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return [] +hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn + = let hug = hsc_HUG hsc_env + mg = hsc_mod_graph hsc_env + in + sequence + [ things + -- "Finding each non-hi-boot module below me" maybe could be cached (well, + -- the inverse) in the module graph to avoid filtering the boots out of + -- the transitive closure out every time this is called + | (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) + <- Set.toList (moduleGraphModulesBelow mg uid mn) + , include_hi_boot || (is_boot == NotBoot) + + -- unsavoury: when compiling the base package with --make, we + -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't + -- be in the HPT, because we never compile it; it's in the EPT + -- instead. ToDo: clean up, and remove this slightly bogus filter: + , mod /= moduleName gHC_PRIM + , not (mod == gwib_mod mn && uid == mod_uid) + + -- Look it up in the HUG + , let things = lookupHug hug mod_uid mod >>= \case + Just info -> return $ extract info + Nothing -> pprTrace "WARNING in hugSomeThingsBelowUs" msg mempty + msg = vcat [text "missing module" <+> ppr mod, + text "When starting from" <+> ppr mn, + text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn), + text "Probable cause: out-of-date interface files"] + -- This really shouldn't happen, but see #962 + ] + +-- | Deal with gathering annotations in from all possible places +-- and combining them into a single 'AnnEnv' +prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv +prepareAnnotations hsc_env mb_guts = do + eps <- hscEPS hsc_env + let -- Extract annotations from the module being compiled if supplied one + mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts + -- Extract dependencies of the module if we are supplied one, + -- otherwise load annotations from all home package table + -- entries regardless of dependency ordering. + get_mod mg = (moduleUnitId (mg_module mg), GWIB (moduleName (mg_module mg)) NotBoot) + home_pkg_anns <- fromMaybe (hugAllAnns (hsc_unit_env hsc_env)) + $ uncurry (hugAnnsBelow hsc_env) + . get_mod <$> mb_guts + let + other_pkg_anns = eps_ann_env eps + !ann_env = maybe id plusAnnEnv mb_this_module_anns $! + plusAnnEnv home_pkg_anns other_pkg_anns + return ann_env + +-- | Find the 'TyThing' for the given 'Name' by using all the resources +-- at our disposal: the compiled modules in the 'HomePackageTable' and the +-- compiled modules in other packages that live in 'PackageTypeEnv'. Note +-- that this does NOT look up the 'TyThing' in the module being compiled: you +-- have to do that yourself, if desired +lookupType :: HscEnv -> Name -> IO (Maybe TyThing) +lookupType hsc_env name = do + eps <- liftIO $ hscEPS hsc_env + let pte = eps_PTE eps + lookupTypeInPTE hsc_env pte name + +lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> IO (Maybe TyThing) +lookupTypeInPTE hsc_env pte name = ty + where + hpt = hsc_HUG hsc_env + mod = assertPpr (isExternalName name) (ppr name) $ + if isHoleName name + then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name)) + else nameModule name + + ty = if isOneShot (ghcMode (hsc_dflags hsc_env)) + -- in one-shot, we don't use the HPT + then return $! lookupNameEnv pte name + else HUG.lookupHugByModule mod hpt >>= \case + Just hm -> pure $! lookupNameEnv (md_types (hm_details hm)) name + Nothing -> pure $! lookupNameEnv pte name + +-- | Find the 'ModIface' for a 'Module', searching in both the loaded home +-- and external package module information +lookupIfaceByModule + :: HomeUnitGraph + -> PackageIfaceTable + -> Module + -> IO (Maybe ModIface) +lookupIfaceByModule hug pit mod + = HUG.lookupHugByModule mod hug >>= pure . \case + Just hm -> Just (hm_iface hm) + Nothing -> lookupModuleEnv pit mod + -- If the module does come from the home package, why do we look in the PIT as well? + -- (a) In OneShot mode, even home-package modules accumulate in the PIT + -- (b) Even in Batch (--make) mode, there is *one* case where a home-package + -- module is in the PIT, namely GHC.Prim when compiling the base package. + -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package + -- of its own, but it doesn't seem worth the bother. + +lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe ModIface) +lookupIfaceByModuleHsc hsc_env mod = do + eps <- hscEPS hsc_env + lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod + +mainModIs :: HomeUnitEnv -> Module +mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) + +-- | Retrieve the target code interpreter +-- +-- Fails if no target code interpreter is available +hscInterp :: HscEnv -> Interp +hscInterp hsc_env = case hsc_interp hsc_env of + Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter") + Just i -> i + +-- | Update the LogFlags of the Log in hsc_logger from the DynFlags in +-- hsc_dflags. You need to call this when DynFlags are modified. +hscUpdateLoggerFlags :: HscEnv -> HscEnv +hscUpdateLoggerFlags h = h + { hsc_logger = setLogFlags (hsc_logger h) (initLogFlags (hsc_dflags h)) } + +-- | Update Flags +hscUpdateFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv +hscUpdateFlags f h = hscSetFlags (f (hsc_dflags h)) h + +-- | Set Flags +hscSetFlags :: HasDebugCallStack => DynFlags -> HscEnv -> HscEnv +hscSetFlags dflags h = + hscUpdateLoggerFlags $ h { hsc_dflags = dflags + , hsc_unit_env = ue_setFlags dflags (hsc_unit_env h) } + +-- See Note [Multiple Home Units] +hscSetActiveHomeUnit :: HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv +hscSetActiveHomeUnit home_unit = hscSetActiveUnitId (homeUnitId home_unit) + +hscSetActiveUnitId :: HasDebugCallStack => UnitId -> HscEnv -> HscEnv +hscSetActiveUnitId uid e = e + { hsc_unit_env = ue_setActiveUnit uid (hsc_unit_env e) + , hsc_dflags = ue_unitFlags uid (hsc_unit_env e) } + +hscActiveUnitId :: HscEnv -> UnitId +hscActiveUnitId e = ue_currentUnit (hsc_unit_env e) + +-- | Discard the contents of the InteractiveContext, but keep the DynFlags and +-- the loaded plugins. It will also keep ic_int_print and ic_monad if their +-- names are from external packages. +discardIC :: HscEnv -> HscEnv +discardIC hsc_env + = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print + , ic_monad = new_ic_monad + , ic_plugins = old_plugins + } } + where + -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic + !new_ic_int_print = keep_external_name ic_int_print + !new_ic_monad = keep_external_name ic_monad + !old_plugins = ic_plugins old_ic + dflags = ic_dflags old_ic + old_ic = hsc_IC hsc_env + empty_ic = emptyInteractiveContext dflags + keep_external_name ic_name + | nameIsFromExternalPackage home_unit old_name = old_name + | otherwise = ic_name empty_ic + where + home_unit = hsc_home_unit hsc_env + old_name = ic_name old_ic + + +-------------------------------------------------------------------------------- +-- * The Legacy API, should be removed after enough deprecation cycles +-------------------------------------------------------------------------------- + +{-# DEPRECATED hscUpdateHPT "Updating the HPT directly is no longer a supported \ + \ operation. Instead, the HPT is an insert-only data structure. If you want to \ + \ overwrite an existing entry, just use 'hscInsertHPT' to insert it again (it \ + \ will override the existing entry if there is one). See 'GHC.Unit.Home.PackageTable' for more details." #-} +hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv +hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHug (HUG.unitEnv_adjust upd (ue_currentUnit $ hsc_unit_env hsc_env)) ue } + where + ue = hsc_unit_env hsc_env + upd hue = hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue) } + diff --git a/GHC/Driver/Env/KnotVars.hs b/GHC/Driver/Env/KnotVars.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Env/KnotVars.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveFunctor #-} +-- | This data structure holds an updateable environment which is used +-- when compiling module loops. +module GHC.Driver.Env.KnotVars( KnotVars(..) + , emptyKnotVars + , knotVarsFromModuleEnv + , knotVarElems + , lookupKnotVars + , knotVarsWithout + ) where + +import GHC.Prelude +import GHC.Unit.Types ( Module ) +import GHC.Unit.Module.Env +import Data.Maybe +import GHC.Utils.Outputable + +-- See Note [Why is KnotVars not a ModuleEnv] +-- See Note [KnotVars invariants] +data KnotVars a = KnotVars { kv_domain :: [Module] -- Domain of the function , Note [KnotVars: Why store the domain?] + -- Invariant: kv_lookup is surjective relative to kv_domain + , kv_lookup :: Module -> Maybe a -- Lookup function + } + | NoKnotVars + deriving Functor + +instance Outputable (KnotVars a) where + ppr NoKnotVars = text "NoKnot" + ppr (KnotVars dom _lookup) = text "Knotty:" <+> ppr dom + +emptyKnotVars :: KnotVars a +emptyKnotVars = NoKnotVars + +knotVarsFromModuleEnv :: ModuleEnv a -> KnotVars a +knotVarsFromModuleEnv me | isEmptyModuleEnv me = NoKnotVars +knotVarsFromModuleEnv me = KnotVars (moduleEnvKeys me) (lookupModuleEnv me) + +knotVarElems :: KnotVars a -> [a] +knotVarElems (KnotVars keys lookup) = mapMaybe lookup keys +knotVarElems NoKnotVars = [] + +lookupKnotVars :: KnotVars a -> Module -> Maybe a +lookupKnotVars (KnotVars _ lookup) x = lookup x +lookupKnotVars NoKnotVars _ = Nothing + +knotVarsWithout :: Module -> KnotVars a -> KnotVars a +knotVarsWithout this_mod (KnotVars loop_mods lkup) = KnotVars + (filter (/= this_mod) loop_mods) + (\that_mod -> if that_mod == this_mod then Nothing else lkup that_mod) +knotVarsWithout _ NoKnotVars = NoKnotVars + +{- +Note [Why is KnotVars not a ModuleEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Initially 'KnotVars' was just a 'ModuleEnv a' but there is one tricky use of +the data structure in 'mkDsEnvs' which required this generalised structure. + +In interactive mode the TypeEnvs from all the previous statements are merged +together into one big TypeEnv. 'dsLookupVar' relies on `tcIfaceVar'. The normal +lookup functions either look in the HPT or EPS but there is no entry for the `Ghci` modules +in either, so the whole merged TypeEnv for all previous Ghci* is stored in the +`if_rec_types` variable and then lookup checks there in the case of any interactive module. + +This is a misuse of the `if_rec_types` variable which might be fixed in future if the +Ghci modules are just placed into the HPT like normal modules with implicit imports +between them. + +Note [KnotVars: Why store the domain?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Normally there's a 'Module' at hand to tell us which 'TypeEnv' we want to interrogate +at a particular time, apart from one case, when constructing the in-scope set +when linting an unfolding. In this case the whole environment is needed to tell us +everything that's in-scope at top-level in the loop because whilst we are linting unfoldings +the top-level identifiers from modules in the cycle might not be globalised properly yet. + +This could be refactored so that the lint functions knew about 'KnotVars' and delayed +this check until deciding whether a variable was local or not. + + +Note [KnotVars invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There is a simple invariant which should hold for the KnotVars constructor: + +* At the end of upsweep, there should be no live KnotVars + +This invariant is difficult to test but easy to check using ghc-debug. The usage of +NoKnotVars is intended to make this invariant easier to check. + +The most common situation where a KnotVars is retained accidentally is if a HscEnv +which contains reference to a KnotVars is used during interface file loading. The +thunks created during this process will retain a reference to the KnotVars. In theory, +all these references should be removed by 'maybeRehydrateAfter' as that rehydrates all +interface files in the loop without using KnotVars. + +At the time of writing (MP: Oct 21) the invariant doesn't actually hold but also +doesn't seem to have too much of a negative consequence on compiler residency. +In theory it could be quite bad as each KnotVars may retain a stale reference to an entire TypeEnv. + +See #20491 +-} + diff --git a/GHC/Driver/Env/Types.hs b/GHC/Driver/Env/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Env/Types.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DerivingVia #-} + +module GHC.Driver.Env.Types + ( Hsc(..) + , HscEnv(..) + ) where + +import GHC.Driver.Errors.Types ( GhcMessage ) +import {-# SOURCE #-} GHC.Driver.Hooks +import GHC.Driver.DynFlags ( ContainsDynFlags(..), HasDynFlags(..), DynFlags ) +import GHC.Driver.LlvmConfigCache (LlvmConfigCache) + +import GHC.Prelude +import GHC.Runtime.Context +import GHC.Runtime.Interpreter.Types ( Interp ) +import GHC.Types.Error ( Messages ) +import GHC.Types.Name.Cache +import GHC.Types.Target +import GHC.Types.TypeEnv +import GHC.Unit.Finder.Types +import GHC.Unit.Env +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import {-# SOURCE #-} GHC.Driver.Plugins + +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Data.IORef +import GHC.Driver.Env.KnotVars + +-- | The Hsc monad: Passing an environment and diagnostic state +newtype Hsc a = Hsc (HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage)) + deriving (Functor, Applicative, Monad, MonadIO) + via ReaderT HscEnv (StateT (Messages GhcMessage) IO) + +instance HasDynFlags Hsc where + getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) + +instance ContainsDynFlags HscEnv where + extractDynFlags h = hsc_dflags h + +instance HasLogger Hsc where + getLogger = Hsc $ \e w -> return (hsc_logger e, w) + + +-- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable. +-- An HscEnv is used to compile a single module from plain Haskell source +-- code (after preprocessing) to either C, assembly or C--. It's also used +-- to store the dynamic linker state to allow for multiple linkers in the +-- same address space. +-- Things like the module graph don't change during a single compilation. +-- +-- Historical note: \"hsc\" used to be the name of the compiler binary, +-- when there was a separate driver and compiler. To compile a single +-- module, the driver would invoke hsc on the source code... so nowadays +-- we think of hsc as the layer of the compiler that deals with compiling +-- a single module. +data HscEnv + = HscEnv { + hsc_dflags :: DynFlags, + -- ^ The dynamic flag settings + + hsc_targets :: [Target], + -- ^ The targets (or roots) of the current session + + hsc_IC :: InteractiveContext, + -- ^ The context for evaluating interactive statements + + hsc_NC :: {-# UNPACK #-} !NameCache, + -- ^ Global Name cache so that each Name gets a single Unique. + -- Also track the origin of the Names. + + hsc_FC :: {-# UNPACK #-} !FinderCache, + -- ^ The cached result of performing finding in the file system + + hsc_type_env_vars :: KnotVars (IORef TypeEnv) + -- ^ Used for one-shot compilation only, to initialise + -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for + -- 'GHC.Tc.Utils.TcGblEnv'. See also Note [hsc_type_env_var hack] + + , hsc_interp :: Maybe Interp + -- ^ target code interpreter (if any) to use for TH and GHCi. + -- See Note [Target code interpreter] + + , hsc_plugins :: !Plugins + -- ^ Plugins + + , hsc_unit_env :: UnitEnv + -- ^ Unit environment (unit state, home unit, etc.). + -- + -- Initialized from the databases cached in 'hsc_unit_dbs' and + -- from the DynFlags. + + , hsc_logger :: !Logger + -- ^ Logger with its flags. + -- + -- Don't forget to update the logger flags if the logging + -- related DynFlags change. Or better, use hscSetFlags setter + -- which does it. + + , hsc_hooks :: !Hooks + -- ^ Hooks + + , hsc_tmpfs :: !TmpFs + -- ^ Temporary files + + , hsc_llvm_config :: !LlvmConfigCache + -- ^ LLVM configuration cache. + } + diff --git a/GHC/Driver/Errors.hs b/GHC/Driver/Errors.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Errors.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module GHC.Driver.Errors ( + printOrThrowDiagnostics + , printMessages + , mkDriverPsHeaderMessage + ) where + +import GHC.Driver.Errors.Types +import GHC.Prelude +import GHC.Types.SourceError +import GHC.Types.Error +import GHC.Utils.Error +import GHC.Utils.Outputable (hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext ) +import GHC.Utils.Logger + +printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO () +printMessages logger msg_opts opts msgs + = sequence_ [ let style = mkErrStyle name_ppr_ctx + ctx = (diag_ppr_ctx opts) { sdocStyle = style } + in (if log_diags_as_json + then logJsonMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) msg + else logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $ + updSDocContext (\_ -> ctx) (messageWithHints dia)) + | msg@MsgEnvelope { errMsgSpan = s, + errMsgDiagnostic = dia, + errMsgSeverity = sev, + errMsgReason = reason, + errMsgContext = name_ppr_ctx } + <- sortMsgBag (Just opts) (getMessages msgs) ] + where + messageWithHints :: a -> SDoc + messageWithHints e = + let main_msg = formatBulleted $ diagnosticMessage msg_opts e + in case diagnosticHints e of + [] -> main_msg + [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h) + hs -> main_msg $$ hang (text "Suggested fixes:") 2 + (formatBulleted $ mkDecorated . map ppr $ hs) + log_diags_as_json = log_diagnostics_as_json (logFlags logger) + +-- | Given a bag of diagnostics, turn them into an exception if +-- any has 'SevError', or print them out otherwise. +printOrThrowDiagnostics :: Logger -> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO () +printOrThrowDiagnostics logger print_config opts msgs + | errorsOrFatalWarningsFound msgs + = throwErrors msgs + | otherwise + = printMessages logger print_config opts msgs + +-- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it +-- for dealing with parse errors when the driver is doing dependency analysis. +-- Defined here to avoid module loops between GHC.Driver.Error.Types and +-- GHC.Driver.Error.Ppr +mkDriverPsHeaderMessage :: MsgEnvelope PsMessage -> MsgEnvelope DriverMessage +mkDriverPsHeaderMessage = fmap DriverPsHeaderMessage diff --git a/GHC/Driver/Errors/Ppr.hs b/GHC/Driver/Errors/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Errors/Ppr.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage} + +module GHC.Driver.Errors.Ppr ( + -- This module only exports Diagnostic instances. + ) where + +import GHC.Prelude + +import GHC.Driver.Errors.Types +import GHC.Driver.Flags +import GHC.Driver.DynFlags +import GHC.HsToCore.Errors.Ppr () -- instance Diagnostic DsMessage +import GHC.Parser.Errors.Ppr () -- instance Diagnostic PsMessage +import GHC.Types.Error +import GHC.Types.Error.Codes +import GHC.Unit.Types +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Unit.Module +import GHC.Unit.Module.Graph +import GHC.Unit.State +import GHC.Types.Hint +import GHC.Types.SrcLoc +import Data.Version + +import Language.Haskell.Syntax.Decls (RuleDecl(..)) +import GHC.Tc.Errors.Types (TcRnMessage) +import GHC.HsToCore.Errors.Types (DsMessage) +import GHC.Iface.Errors.Types +import GHC.Tc.Errors.Ppr () -- instance Diagnostic TcRnMessage +import GHC.Iface.Errors.Ppr () -- instance Diagnostic IfaceMessage +import GHC.CmmToLlvm.Version (llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound) + +-- +-- Suggestions +-- + +-- | Suggests a list of 'InstantiationSuggestion' for the '.hsig' file to the user. +suggestInstantiatedWith :: ModuleName -> GenInstantiations UnitId -> [InstantiationSuggestion] +suggestInstantiatedWith pi_mod_name insts = + [ InstantiationSuggestion k v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : insts) ] + +instance HasDefaultDiagnosticOpts GhcMessageOpts where + defaultOpts = GhcMessageOpts (defaultDiagnosticOpts @PsMessage) + (defaultDiagnosticOpts @TcRnMessage) + (defaultDiagnosticOpts @DsMessage) + (defaultDiagnosticOpts @DriverMessage) + +instance Diagnostic GhcMessage where + type DiagnosticOpts GhcMessage = GhcMessageOpts + diagnosticMessage opts = \case + GhcPsMessage m + -> diagnosticMessage (psMessageOpts opts) m + GhcTcRnMessage m + -> diagnosticMessage (tcMessageOpts opts) m + GhcDsMessage m + -> diagnosticMessage (dsMessageOpts opts) m + GhcDriverMessage m + -> diagnosticMessage (driverMessageOpts opts) m + GhcUnknownMessage (UnknownDiagnostic f _ m) + -> diagnosticMessage (f opts) m + + diagnosticReason = \case + GhcPsMessage m + -> diagnosticReason m + GhcTcRnMessage m + -> diagnosticReason m + GhcDsMessage m + -> diagnosticReason m + GhcDriverMessage m + -> diagnosticReason m + GhcUnknownMessage m + -> diagnosticReason m + + diagnosticHints = \case + GhcPsMessage m + -> diagnosticHints m + GhcTcRnMessage m + -> diagnosticHints m + GhcDsMessage m + -> diagnosticHints m + GhcDriverMessage m + -> diagnosticHints m + GhcUnknownMessage m + -> diagnosticHints m + + diagnosticCode = constructorCode @GHC + +instance HasDefaultDiagnosticOpts DriverMessageOpts where + defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage) + +instance Diagnostic DriverMessage where + type DiagnosticOpts DriverMessage = DriverMessageOpts + diagnosticMessage opts = \case + DriverUnknownMessage (UnknownDiagnostic f _ m) + -> diagnosticMessage (f opts) m + DriverPsHeaderMessage m + -> diagnosticMessage (psDiagnosticOpts opts) m + DriverMissingHomeModules uid missing buildingCabalPackage + -> let msg | buildingCabalPackage == YesBuildingCabalPackage + = hang + (text "These modules are needed for compilation but not listed in your .cabal file's other-modules for" <+> quotes (ppr uid) <+> text ":") + 4 + (sep (map ppr missing)) + | otherwise + = + hang + (text "Modules are not listed in options for" + <+> quotes (ppr uid) <+> text "but needed for compilation:") + 4 + (sep (map ppr missing)) + in mkSimpleDecorated msg + DriverUnknownHiddenModules uid missing + -> let msg = hang + (text "Modules are listed as hidden in options for" <+> quotes (ppr uid) <+> text "but not part of the unit:") + 4 + (sep (map ppr missing)) + in mkSimpleDecorated msg + DriverUnknownReexportedModules uid missing + -> let msg = hang + (text "Modules are listed as reexported in options for" <+> quotes (ppr uid) <+> text "but can't be found in any dependency:") + 4 + (sep (map ppr missing)) + in mkSimpleDecorated msg + DriverUnusedPackages unusedArgs + -> let msg = vcat [ text "The following packages were specified" <+> + text "via -package or -package-id flags," + , text "but were not needed for compilation:" + , nest 2 (vcat (map (withDash . displayOneUnused) unusedArgs)) + ] + in mkSimpleDecorated msg + where + withDash :: SDoc -> SDoc + withDash = (<+>) (text "-") + + displayOneUnused (_uid, pn , v, f) = + ppr pn <> text "-" <> text (showVersion v) + <+> parens (suffix f) + + suffix f = text "exposed by flag" <+> pprUnusedArg f + + pprUnusedArg :: PackageArg -> SDoc + pprUnusedArg (PackageArg str) = text "-package" <+> text str + pprUnusedArg (UnitIdArg uid) = text "-package-id" <+> ppr uid + + DriverUnnecessarySourceImports mod + -> mkSimpleDecorated (text "{-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod)) + DriverDuplicatedModuleDeclaration mod files + -> mkSimpleDecorated $ + text "module" <+> quotes (ppr mod) <+> + text "is defined in multiple files:" <+> + sep (map text files) + DriverModuleNotFound _uid mod + -> mkSimpleDecorated (text "module" <+> quotes (ppr mod) <+> text "cannot be found locally") + DriverFileModuleNameMismatch actual expected + -> mkSimpleDecorated $ + text "File name does not match module name:" + $$ text "Saw :" <+> quotes (ppr actual) + $$ text "Expected:" <+> quotes (ppr expected) + + DriverUnexpectedSignature pi_mod_name _buildingCabalPackage _instantiations + -> mkSimpleDecorated $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name) + DriverFileNotFound hsFilePath + -> mkSimpleDecorated (text "Can't find" <+> text hsFilePath) + DriverStaticPointersNotSupported + -> mkSimpleDecorated (text "StaticPointers is not supported in GHCi interactive expressions.") + DriverBackpackModuleNotFound modname + -> mkSimpleDecorated (text "module" <+> ppr modname <+> text "was not found") + DriverUserDefinedRuleIgnored (HsRule { rd_name = n }) + -> mkSimpleDecorated $ + text "Rule \"" <> ftext (unLoc n) <> text "\" ignored" $+$ + text "Defining user rules is disabled under Safe Haskell" + DriverMixedSafetyImport modName + -> mkSimpleDecorated $ + text "Module" <+> ppr modName <+> text ("is imported both as a safe and unsafe import!") + DriverCannotLoadInterfaceFile m + -> mkSimpleDecorated $ + text "Can't load the interface file for" <+> ppr m + <> text ", to check that it can be safely imported" + DriverInferredSafeModule m + -> mkSimpleDecorated $ + quotes (ppr $ moduleName m) <+> text "has been inferred as safe!" + DriverInferredSafeImport m + -> mkSimpleDecorated $ + sep + [ text "Importing Safe-Inferred module " + <> ppr (moduleName m) + <> text " from explicitly Safe module" + ] + DriverMarkedTrustworthyButInferredSafe m + -> mkSimpleDecorated $ + quotes (ppr $ moduleName m) <+> text "is marked as Trustworthy but has been inferred as safe!" + DriverCannotImportUnsafeModule m + -> mkSimpleDecorated $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The module itself isn't safe." ] + DriverMissingSafeHaskellMode modName + -> mkSimpleDecorated $ + ppr modName <+> text "is missing Safe Haskell mode" + DriverPackageNotTrusted state pkg + -> mkSimpleDecorated $ + pprWithUnitState state + $ text "The package (" + <> ppr pkg + <> text ") is required to be trusted but it isn't!" + DriverCannotImportFromUntrustedPackage state m + -> mkSimpleDecorated $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The package (" + <> (pprWithUnitState state $ ppr (moduleUnit m)) + <> text ") the module resides in isn't trusted." + ] + DriverRedirectedNoMain mod_name + -> mkSimpleDecorated $ (text + ("Output was redirected with -o, " ++ + "but no output will be generated.") $$ + (text "There is no module named" <+> + quotes (ppr mod_name) <> text ".")) + DriverHomePackagesNotClosed needed_unit_ids + -> mkSimpleDecorated $ vcat ([text "Home units are not closed." + , text "It is necessary to also load the following units:" ] + ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids) + DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason + + DriverInconsistentDynFlags msg + -> mkSimpleDecorated $ text msg + DriverSafeHaskellIgnoredExtension ext + -> let arg = text "-X" <> ppr ext + in mkSimpleDecorated $ arg <+> text "is not allowed in Safe Haskell; ignoring" <+> arg + DriverPackageTrustIgnored + -> mkSimpleDecorated $ text "-fpackage-trust ignored; must be specified with a Safe Haskell flag" + + DriverUnrecognisedFlag arg + -> mkSimpleDecorated $ text $ "unrecognised warning flag: -" ++ arg + DriverDeprecatedFlag arg msg + -> mkSimpleDecorated $ text $ arg ++ " is deprecated: " ++ msg + DriverModuleGraphCycle path + -> mkSimpleDecorated $ vcat + [ text "Module graph contains a cycle:" + , nest 2 (show_path path) ] + where + show_path :: [ModuleGraphNode] -> SDoc + show_path [] = panic "show_path" + show_path [m] = ppr_node m <+> text "imports itself" + show_path (m1:m2:ms) = vcat ( nest 14 (ppr_node m1) + : nest 6 (text "imports" <+> ppr_node m2) + : go ms ) + where + go [] = [text "which imports" <+> ppr_node m1] + go (m:ms) = (text "which imports" <+> ppr_node m) : go ms + + ppr_node :: ModuleGraphNode -> SDoc + ppr_node (ModuleNode _deps m) = text "module" <+> ppr_ms m + ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u + ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid) + ppr_node (UnitNode uid _) = pprPanic "UnitNode should not be in a cycle" (ppr uid) + + ppr_ms :: ModuleNodeInfo -> SDoc + ppr_ms ms = quotes (ppr (moduleNodeInfoModule ms)) <+> + (parens (text (node_path ms))) + + node_path :: ModuleNodeInfo -> FilePath + node_path ms = case ml_hs_file (moduleNodeInfoLocation ms) of + Just f -> f + Nothing -> ml_hi_file (moduleNodeInfoLocation ms) + DriverInstantiationNodeInDependencyGeneration node -> + mkSimpleDecorated $ + vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:" + , nest 2 $ ppr node ] + DriverNoConfiguredLLVMToolchain -> + mkSimpleDecorated $ + text "GHC was not configured with a supported LLVM toolchain" $$ + text ("Make sure you have installed LLVM between [" + ++ llvmVersionStr supportedLlvmVersionLowerBound + ++ " and " + ++ llvmVersionStr supportedLlvmVersionUpperBound + ++ ") and reinstall GHC to ensure -fllvm works") + + diagnosticReason = \case + DriverUnknownMessage m + -> diagnosticReason m + DriverPsHeaderMessage {} + -> ErrorWithoutFlag + DriverMissingHomeModules{} + -> WarningWithFlag Opt_WarnMissingHomeModules + DriverUnknownHiddenModules {} + -> ErrorWithoutFlag + DriverUnknownReexportedModules {} + -> ErrorWithoutFlag + DriverUnusedPackages{} + -> WarningWithFlag Opt_WarnUnusedPackages + DriverUnnecessarySourceImports{} + -> WarningWithFlag Opt_WarnUnusedImports + DriverDuplicatedModuleDeclaration{} + -> ErrorWithoutFlag + DriverModuleNotFound{} + -> ErrorWithoutFlag + DriverFileModuleNameMismatch{} + -> ErrorWithoutFlag + DriverUnexpectedSignature{} + -> ErrorWithoutFlag + DriverFileNotFound{} + -> ErrorWithoutFlag + DriverStaticPointersNotSupported + -> WarningWithoutFlag + DriverBackpackModuleNotFound{} + -> ErrorWithoutFlag + DriverUserDefinedRuleIgnored{} + -> WarningWithoutFlag + DriverMixedSafetyImport{} + -> ErrorWithoutFlag + DriverCannotLoadInterfaceFile{} + -> ErrorWithoutFlag + DriverInferredSafeModule{} + -> WarningWithFlag Opt_WarnSafe + DriverMarkedTrustworthyButInferredSafe{} + ->WarningWithFlag Opt_WarnTrustworthySafe + DriverInferredSafeImport{} + -> WarningWithFlag Opt_WarnInferredSafeImports + DriverCannotImportUnsafeModule{} + -> ErrorWithoutFlag + DriverMissingSafeHaskellMode{} + -> WarningWithFlag Opt_WarnMissingSafeHaskellMode + DriverPackageNotTrusted{} + -> ErrorWithoutFlag + DriverCannotImportFromUntrustedPackage{} + -> ErrorWithoutFlag + DriverRedirectedNoMain {} + -> ErrorWithoutFlag + DriverHomePackagesNotClosed {} + -> ErrorWithoutFlag + DriverInterfaceError reason -> diagnosticReason reason + DriverInconsistentDynFlags {} + -> WarningWithFlag Opt_WarnInconsistentFlags + DriverSafeHaskellIgnoredExtension {} + -> WarningWithoutFlag + DriverPackageTrustIgnored {} + -> WarningWithoutFlag + DriverUnrecognisedFlag {} + -> WarningWithFlag Opt_WarnUnrecognisedWarningFlags + DriverDeprecatedFlag {} + -> WarningWithFlag Opt_WarnDeprecatedFlags + DriverModuleGraphCycle {} + -> ErrorWithoutFlag + DriverInstantiationNodeInDependencyGeneration {} + -> ErrorWithoutFlag + DriverNoConfiguredLLVMToolchain + -> WarningWithoutFlag + + diagnosticHints = \case + DriverUnknownMessage m + -> diagnosticHints m + DriverPsHeaderMessage psMsg + -> diagnosticHints psMsg + DriverMissingHomeModules{} + -> noHints + DriverUnknownHiddenModules {} + -> noHints + DriverUnknownReexportedModules {} + -> noHints + DriverUnusedPackages{} + -> noHints + DriverUnnecessarySourceImports{} + -> noHints + DriverDuplicatedModuleDeclaration{} + -> noHints + DriverModuleNotFound{} + -> noHints + DriverFileModuleNameMismatch{} + -> noHints + DriverUnexpectedSignature pi_mod_name buildingCabalPackage instantiations + -> if buildingCabalPackage == YesBuildingCabalPackage + then [SuggestAddSignatureCabalFile pi_mod_name] + else [SuggestSignatureInstantiations pi_mod_name (suggestInstantiatedWith pi_mod_name instantiations)] + DriverFileNotFound{} + -> noHints + DriverStaticPointersNotSupported + -> noHints + DriverBackpackModuleNotFound{} + -> noHints + DriverUserDefinedRuleIgnored{} + -> noHints + DriverMixedSafetyImport{} + -> noHints + DriverCannotLoadInterfaceFile{} + -> noHints + DriverInferredSafeModule{} + -> noHints + DriverInferredSafeImport{} + -> noHints + DriverCannotImportUnsafeModule{} + -> noHints + DriverMissingSafeHaskellMode{} + -> noHints + DriverPackageNotTrusted{} + -> noHints + DriverMarkedTrustworthyButInferredSafe{} + -> noHints + DriverCannotImportFromUntrustedPackage{} + -> noHints + DriverRedirectedNoMain {} + -> noHints + DriverHomePackagesNotClosed {} + -> noHints + DriverInterfaceError reason -> diagnosticHints reason + DriverInconsistentDynFlags {} + -> noHints + DriverSafeHaskellIgnoredExtension {} + -> noHints + DriverPackageTrustIgnored {} + -> noHints + DriverUnrecognisedFlag {} + -> noHints + DriverDeprecatedFlag {} + -> noHints + DriverModuleGraphCycle {} + -> noHints + DriverInstantiationNodeInDependencyGeneration {} + -> noHints + DriverNoConfiguredLLVMToolchain + -> noHints + + diagnosticCode = constructorCode @GHC diff --git a/GHC/Driver/Errors/Types.hs b/GHC/Driver/Errors/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Errors/Types.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +module GHC.Driver.Errors.Types ( + GhcMessage(..) + , AnyGhcDiagnostic + , GhcMessageOpts(..) + , DriverMessage(..) + , DriverMessageOpts(..) + , DriverMessages, PsMessage(PsHeaderMessage) + , WarningMessages + , ErrorMessages + , WarnMsg + -- * Constructors + , ghcUnknownMessage + -- * Utility functions + , hoistTcRnMessage + , hoistDsMessage + , checkBuildingCabalPackage + ) where + +import GHC.Prelude + +import Data.Bifunctor +import Data.Typeable + +import GHC.Driver.DynFlags (DynFlags, PackageArg, gopt, ReexportedModule) +import GHC.Driver.Flags (GeneralFlag (Opt_BuildingCabalPackage)) +import GHC.Types.Error +import GHC.Unit.Module +import GHC.Unit.Module.Graph +import GHC.Unit.State + +import GHC.Parser.Errors.Types ( PsMessage(PsHeaderMessage) ) +import GHC.HsToCore.Errors.Types ( DsMessage ) +import GHC.Hs.Extension (GhcTc) + +import Language.Haskell.Syntax.Decls (RuleDecl) +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Generics ( Generic ) + +import GHC.Tc.Errors.Types +import GHC.Iface.Errors.Types + +-- | A collection of warning messages. +-- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity. +type WarningMessages = Messages GhcMessage + +-- | A collection of error messages. +-- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevError' severity. +type ErrorMessages = Messages GhcMessage + +-- | A single warning message. +-- /INVARIANT/: It must have 'SevWarning' severity. +type WarnMsg = MsgEnvelope GhcMessage + + +{- Note [GhcMessage] +~~~~~~~~~~~~~~~~~~~~ + +We might need to report diagnostics (error and/or warnings) to the users. The +'GhcMessage' type is the root of the diagnostic hierarchy. + +It's useful to have a separate type constructor for the different stages of +the compilation pipeline. This is not just helpful for tools, as it gives a +clear indication on where the error occurred exactly. Furthermore it increases +the modularity amongst the different components of GHC (i.e. to avoid having +"everything depend on everything else") and allows us to write separate +functions that renders the different kind of messages. + +-} + +-- | The umbrella type that encompasses all the different messages that GHC +-- might output during the different compilation stages. See +-- Note [GhcMessage]. +data GhcMessage where + -- | A message from the parsing phase. + GhcPsMessage :: PsMessage -> GhcMessage + -- | A message from typecheck/renaming phase. + GhcTcRnMessage :: TcRnMessage -> GhcMessage + -- | A message from the desugaring (HsToCore) phase. + GhcDsMessage :: DsMessage -> GhcMessage + -- | A message from the driver. + GhcDriverMessage :: DriverMessage -> GhcMessage + + -- | An \"escape\" hatch which can be used when we don't know the source of + -- the message or if the message is not one of the typed ones. The + -- 'Diagnostic' and 'Typeable' constraints ensure that if we /know/, at + -- pattern-matching time, the originating type, we can attempt a cast and + -- access the fully-structured error. This would be the case for a GHC + -- plugin that offers a domain-specific error type but that doesn't want to + -- place the burden on IDEs/application code to \"know\" it. The + -- 'Diagnostic' constraint ensures that worst case scenario we can still + -- render this into something which can be eventually converted into a + -- 'DecoratedSDoc'. + GhcUnknownMessage :: (UnknownDiagnosticFor GhcMessage) -> GhcMessage + + deriving Generic + +type AnyGhcDiagnostic = UnknownDiagnosticFor GhcMessage + +data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage + , tcMessageOpts :: DiagnosticOpts TcRnMessage + , dsMessageOpts :: DiagnosticOpts DsMessage + , driverMessageOpts :: DiagnosticOpts DriverMessage + } + +-- | Creates a new 'GhcMessage' out of any diagnostic. This function is also +-- provided to ease the integration of #18516 by allowing diagnostics to be +-- wrapped into the general (but structured) 'GhcMessage' type, so that the +-- conversion can happen gradually. This function should not be needed within +-- GHC, as it would typically be used by plugin or library authors (see +-- comment for the 'GhcUnknownMessage' type constructor) +ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ DiagnosticHint GhcMessage, Diagnostic a, Typeable a) => a -> GhcMessage +ghcUnknownMessage = GhcUnknownMessage . mkSimpleUnknownDiagnostic + +-- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on +-- the result of 'IO (Messages TcRnMessage, a)'. +hoistTcRnMessage :: Monad m => m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a) +hoistTcRnMessage = fmap (first (fmap GhcTcRnMessage)) + +-- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on +-- the result of 'IO (Messages DsMessage, a)'. +hoistDsMessage :: Monad m => m (Messages DsMessage, a) -> m (Messages GhcMessage, a) +hoistDsMessage = fmap (first (fmap GhcDsMessage)) + +-- | A collection of driver messages +type DriverMessages = Messages DriverMessage + +-- | A message from the driver. +data DriverMessage where + -- | Simply wraps a generic 'Diagnostic' message @a@. + DriverUnknownMessage :: UnknownDiagnosticFor DriverMessage -> DriverMessage + + -- | A parse error in parsing a Haskell file header during dependency + -- analysis + DriverPsHeaderMessage :: !PsMessage -> DriverMessage + + {-| DriverMissingHomeModules is a warning (controlled with -Wmissing-home-modules) that + arises when running GHC in --make mode when some modules needed for compilation + are not included on the command line. For example, if A imports B, `ghc --make + A.hs` will cause this warning, while `ghc --make A.hs B.hs` will not. + + Useful for cabal to ensure GHC won't pick up modules listed neither in + 'exposed-modules' nor in 'other-modules'. + + Test case: warnings/should_compile/MissingMod + + -} + DriverMissingHomeModules :: UnitId -> [ModuleName] -> !BuildingCabalPackage -> DriverMessage + + {-| DriverUnknown is a warning that arises when a user tries to + reexport a module which isn't part of that unit. + -} + DriverUnknownReexportedModules :: UnitId -> [ReexportedModule] -> DriverMessage + + {-| DriverUnknownHiddenModules is a warning that arises when a user tries to + hide a module which isn't part of that unit. + -} + DriverUnknownHiddenModules :: UnitId -> [ModuleName] -> DriverMessage + + {-| DriverUnusedPackages occurs when when package is requested on command line, + but was never needed during compilation. Activated by -Wunused-packages. + + Test cases: warnings/should_compile/UnusedPackages + -} + DriverUnusedPackages :: [(UnitId, PackageName, Version, PackageArg)] -> DriverMessage + + {-| DriverUnnecessarySourceImports (controlled with -Wunused-imports) occurs if there + are {-# SOURCE #-} imports which are not necessary. See 'warnUnnecessarySourceImports' + in 'GHC.Driver.Make'. + + Test cases: warnings/should_compile/T10637 + -} + DriverUnnecessarySourceImports :: !ModuleName -> DriverMessage + + {-| DriverDuplicatedModuleDeclaration occurs if a module 'A' is declared in + multiple files. + + Test cases: None. + -} + DriverDuplicatedModuleDeclaration :: !Module -> [FilePath] -> DriverMessage + + {-| DriverModuleNotFound occurs if a module 'A' can't be found. + + Test cases: None. + -} + DriverModuleNotFound :: !UnitId -> !ModuleName -> DriverMessage + + {-| DriverFileModuleNameMismatch occurs if a module 'A' is defined in a file with a different name. + The first field is the name written in the source code; the second argument is the name extracted + from the filename. + + Test cases: module/mod178, /driver/bug1677 + -} + DriverFileModuleNameMismatch :: !ModuleName -> !ModuleName -> DriverMessage + + {-| DriverUnexpectedSignature occurs when GHC encounters a module 'A' that imports a signature + file which is neither in the 'signatures' section of a '.cabal' file nor in any package in + the home modules. + + Example: + + -- MyStr.hsig is defined, but not added to 'signatures' in the '.cabal' file. + signature MyStr where + data Str + + -- A.hs, which tries to import the signature. + module A where + import MyStr + + + Test cases: driver/T12955 + -} + DriverUnexpectedSignature :: !ModuleName -> !BuildingCabalPackage -> GenInstantiations UnitId -> DriverMessage + + {-| DriverFileNotFound occurs when the input file (e.g. given on the command line) can't be found. + + Test cases: None. + -} + DriverFileNotFound :: !FilePath -> DriverMessage + + {-| DriverStaticPointersNotSupported occurs when the 'StaticPointers' extension is used + in an interactive GHCi context. + + Test cases: ghci/scripts/StaticPtr + -} + DriverStaticPointersNotSupported :: DriverMessage + + {-| DriverBackpackModuleNotFound occurs when Backpack can't find a particular module + during its dependency analysis. + + Test cases: - + -} + DriverBackpackModuleNotFound :: !ModuleName -> DriverMessage + + {-| DriverUserDefinedRuleIgnored is a warning that occurs when user-defined rules + are ignored. This typically happens when Safe Haskell. + + Test cases: + + tests/safeHaskell/safeInfered/UnsafeWarn05 + tests/safeHaskell/safeInfered/UnsafeWarn06 + tests/safeHaskell/safeInfered/UnsafeWarn07 + tests/safeHaskell/safeInfered/UnsafeInfered11 + tests/safeHaskell/safeLanguage/SafeLang03 + -} + DriverUserDefinedRuleIgnored :: !(RuleDecl GhcTc) -> DriverMessage + + {-| DriverMixedSafetyImport is an error that occurs when a module is imported + both as safe and unsafe. + + Test cases: + + tests/safeHaskell/safeInfered/Mixed03 + tests/safeHaskell/safeInfered/Mixed02 + + -} + DriverMixedSafetyImport :: !ModuleName -> DriverMessage + + {-| DriverCannotLoadInterfaceFile is an error that occurs when we cannot load the interface + file for a particular module. This can happen for example in the context of Safe Haskell, + when we have to load a module to check if it can be safely imported. + + Test cases: None. + + -} + DriverCannotLoadInterfaceFile :: !Module -> DriverMessage + + {-| DriverInferredSafeImport is a warning (controlled by the Opt_WarnSafe flag) + that occurs when a module is inferred safe. + + Test cases: None. + + -} + DriverInferredSafeModule :: !Module -> DriverMessage + + {-| DriverMarkedTrustworthyButInferredSafe is a warning (controlled by the Opt_WarnTrustworthySafe flag) + that occurs when a module is marked trustworthy in SafeHaskell but it has been inferred safe. + + Test cases: + tests/safeHaskell/safeInfered/TrustworthySafe02 + tests/safeHaskell/safeInfered/TrustworthySafe03 + + -} + DriverMarkedTrustworthyButInferredSafe :: !Module -> DriverMessage + + {-| DriverInferredSafeImport is a warning (controlled by the Opt_WarnInferredSafeImports flag) + that occurs when a safe-inferred module is imported from a safe module. + + Test cases: None. + + -} + DriverInferredSafeImport :: !Module -> DriverMessage + + {-| DriverCannotImportUnsafeModule is an error that occurs when an usafe module + is being imported from a safe one. + + Test cases: None. + + -} + DriverCannotImportUnsafeModule :: !Module -> DriverMessage + + {-| DriverMissingSafeHaskellMode is a warning (controlled by the Opt_WarnMissingSafeHaskellMode flag) + that occurs when a module is using SafeHaskell features but SafeHaskell mode is not enabled. + + Test cases: None. + + -} + DriverMissingSafeHaskellMode :: !Module -> DriverMessage + + {-| DriverPackageNotTrusted is an error that occurs when a package is required to be trusted + but it isn't. + + Test cases: + tests/safeHaskell/check/Check01 + tests/safeHaskell/check/Check08 + tests/safeHaskell/check/Check06 + tests/safeHaskell/check/pkg01/ImpSafeOnly09 + tests/safeHaskell/check/pkg01/ImpSafe03 + tests/safeHaskell/check/pkg01/ImpSafeOnly07 + tests/safeHaskell/check/pkg01/ImpSafeOnly08 + + -} + DriverPackageNotTrusted :: !UnitState -> !UnitId -> DriverMessage + + {-| DriverCannotImportFromUntrustedPackage is an error that occurs in the context of + Safe Haskell when trying to import a module coming from an untrusted package. + + Test cases: + tests/safeHaskell/check/Check09 + tests/safeHaskell/check/pkg01/ImpSafe01 + tests/safeHaskell/check/pkg01/ImpSafe04 + tests/safeHaskell/check/pkg01/ImpSafeOnly03 + tests/safeHaskell/check/pkg01/ImpSafeOnly05 + tests/safeHaskell/flags/SafeFlags17 + tests/safeHaskell/flags/SafeFlags22 + tests/safeHaskell/flags/SafeFlags23 + tests/safeHaskell/ghci/p11 + tests/safeHaskell/ghci/p12 + tests/safeHaskell/ghci/p17 + tests/safeHaskell/ghci/p3 + tests/safeHaskell/safeInfered/UnsafeInfered01 + tests/safeHaskell/safeInfered/UnsafeInfered02 + tests/safeHaskell/safeInfered/UnsafeInfered02 + tests/safeHaskell/safeInfered/UnsafeInfered03 + tests/safeHaskell/safeInfered/UnsafeInfered05 + tests/safeHaskell/safeInfered/UnsafeInfered06 + tests/safeHaskell/safeInfered/UnsafeInfered09 + tests/safeHaskell/safeInfered/UnsafeInfered10 + tests/safeHaskell/safeInfered/UnsafeInfered11 + tests/safeHaskell/safeInfered/UnsafeWarn01 + tests/safeHaskell/safeInfered/UnsafeWarn03 + tests/safeHaskell/safeInfered/UnsafeWarn04 + tests/safeHaskell/safeInfered/UnsafeWarn05 + tests/safeHaskell/unsafeLibs/BadImport01 + tests/safeHaskell/unsafeLibs/BadImport06 + tests/safeHaskell/unsafeLibs/BadImport07 + tests/safeHaskell/unsafeLibs/BadImport08 + tests/safeHaskell/unsafeLibs/BadImport09 + tests/safeHaskell/unsafeLibs/Dep05 + tests/safeHaskell/unsafeLibs/Dep06 + tests/safeHaskell/unsafeLibs/Dep07 + tests/safeHaskell/unsafeLibs/Dep08 + tests/safeHaskell/unsafeLibs/Dep09 + tests/safeHaskell/unsafeLibs/Dep10 + + -} + DriverCannotImportFromUntrustedPackage :: !UnitState -> !Module -> DriverMessage + + DriverRedirectedNoMain :: !ModuleName -> DriverMessage + + DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage + + DriverInterfaceError :: !IfaceMessage -> DriverMessage + + -- TODO: Add structure messages rather than a String + DriverInconsistentDynFlags :: String -> DriverMessage + + DriverSafeHaskellIgnoredExtension :: !LangExt.Extension -> DriverMessage + + DriverPackageTrustIgnored :: DriverMessage + + DriverUnrecognisedFlag :: String -> DriverMessage + + DriverDeprecatedFlag :: String -> String -> DriverMessage + + {-| DriverModuleGraphCycle is an error that occurs if the module graph + contains cyclic imports. + + Test cases: + tests/backpack/should_fail/bkpfail51 + tests/driver/T20459 + tests/driver/T24196/T24196 + tests/driver/T24275/T24275 + + -} + DriverModuleGraphCycle :: [ModuleGraphNode] -> DriverMessage + + {- | DriverInstantiationNodeInDependencyGeneration is an error that occurs + if the module graph used for dependency generation contains + Backpack 'InstantiationNode's. -} + DriverInstantiationNodeInDependencyGeneration :: InstantiatedUnit -> DriverMessage + + {-| DriverNoConfiguredLLVMToolchain is an error that occurs if there is no + LLVM toolchain configured but -fllvm is passed as an option to the compiler. + + Test cases: None. + + -} + DriverNoConfiguredLLVMToolchain :: DriverMessage + +deriving instance Generic DriverMessage + +data DriverMessageOpts = + DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage + , ifaceDiagnosticOpts :: DiagnosticOpts IfaceMessage } + + +-- | Checks if we are building a cabal package by consulting the 'DynFlags'. +checkBuildingCabalPackage :: DynFlags -> BuildingCabalPackage +checkBuildingCabalPackage dflags = + if gopt Opt_BuildingCabalPackage dflags + then YesBuildingCabalPackage + else NoBuildingCabalPackage diff --git a/GHC/Driver/Flags.hs b/GHC/Driver/Flags.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Flags.hs @@ -0,0 +1,1435 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.Driver.Flags + ( DumpFlag(..) + , getDumpFlagFrom + , enabledIfVerbose + , GeneralFlag(..) + , Language(..) + , defaultLanguage + , optimisationFlags + , codeGenFlags + + -- * Warnings + , WarningGroup(..) + , warningGroupName + , warningGroupFlags + , warningGroupIncludesExtendedWarnings + , WarningFlag(..) + , warnFlagNames + , warningGroups + , warningHierarchies + , smallestWarningGroups + , smallestWarningGroupsForCategory + + , standardWarnings + , minusWOpts + , minusWallOpts + , minusWeverythingOpts + , minusWcompatOpts + , unusedBindsFlags + + , OnOff(..) + , TurnOnFlag + , turnOn + , turnOff + , impliedXFlags + , validHoleFitsImpliedGFlags + , impliedGFlags + , impliedOffGFlags + , glasgowExtsFlags + + , ExtensionDeprecation(..) + , Deprecation(..) + , extensionDeprecation + , deprecation + , extensionNames + , extensionName + ) +where + +import GHC.Prelude +import GHC.Utils.Outputable +import GHC.Utils.Binary +import GHC.Data.EnumSet as EnumSet + +import Control.DeepSeq +import Control.Monad (guard) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (fromMaybe,mapMaybe) + +import qualified GHC.LanguageExtensions as LangExt + +data Language = Haskell98 | Haskell2010 | GHC2021 | GHC2024 + deriving (Eq, Enum, Show, Bounded) + +-- | The default Language is used if one is not specified explicitly, by both +-- GHC and GHCi. +defaultLanguage :: Language +defaultLanguage = GHC2021 + +instance Outputable Language where + ppr = text . show + +instance Binary Language where + put_ bh = put_ bh . fromEnum + get bh = toEnum <$> get bh + +instance NFData Language where + rnf Haskell98 = () + rnf Haskell2010 = () + rnf GHC2021 = () + rnf GHC2024 = () + +data OnOff a = On a + | Off a + deriving (Eq, Show) + +instance Outputable a => Outputable (OnOff a) where + ppr (On x) = text "On" <+> ppr x + ppr (Off x) = text "Off" <+> ppr x + +type TurnOnFlag = Bool -- True <=> we are turning the flag on + -- False <=> we are turning the flag off +turnOn :: TurnOnFlag; turnOn = True +turnOff :: TurnOnFlag; turnOff = False + +data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord) + +data ExtensionDeprecation + = ExtensionNotDeprecated + | ExtensionDeprecatedFor [LangExt.Extension] + | ExtensionFlagDeprecatedCond TurnOnFlag String + | ExtensionFlagDeprecated String + deriving Eq + +-- | Always returns 'Deprecated' even when the flag is +-- only conditionally deprecated. +deprecation :: ExtensionDeprecation -> Deprecation +deprecation ExtensionNotDeprecated = NotDeprecated +deprecation _ = Deprecated + +extensionDeprecation :: LangExt.Extension -> ExtensionDeprecation +extensionDeprecation = \case + LangExt.TypeInType -> ExtensionDeprecatedFor [LangExt.DataKinds, LangExt.PolyKinds] + LangExt.NullaryTypeClasses -> ExtensionDeprecatedFor [LangExt.MultiParamTypeClasses] + LangExt.RelaxedPolyRec -> ExtensionFlagDeprecatedCond turnOff + "You can't turn off RelaxedPolyRec any more" + LangExt.DatatypeContexts -> ExtensionFlagDeprecatedCond turnOn + "It was widely considered a misfeature, and has been removed from the Haskell language." + LangExt.AutoDeriveTypeable -> ExtensionFlagDeprecatedCond turnOn + "Typeable instances are created automatically for all types since GHC 8.2." + LangExt.OverlappingInstances -> ExtensionFlagDeprecated + "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS" + _ -> ExtensionNotDeprecated + + +extensionName :: LangExt.Extension -> String +extensionName = \case + LangExt.Cpp -> "CPP" + LangExt.OverlappingInstances -> "OverlappingInstances" + LangExt.UndecidableInstances -> "UndecidableInstances" + LangExt.IncoherentInstances -> "IncoherentInstances" + LangExt.UndecidableSuperClasses -> "UndecidableSuperClasses" + LangExt.MonomorphismRestriction -> "MonomorphismRestriction" + LangExt.MonoLocalBinds -> "MonoLocalBinds" + LangExt.DeepSubsumption -> "DeepSubsumption" + LangExt.RelaxedPolyRec -> "RelaxedPolyRec" -- Deprecated + LangExt.ExtendedDefaultRules -> "ExtendedDefaultRules" -- Use GHC's extended rules for defaulting + LangExt.NamedDefaults -> "NamedDefaults" + LangExt.ForeignFunctionInterface -> "ForeignFunctionInterface" + LangExt.UnliftedFFITypes -> "UnliftedFFITypes" + LangExt.InterruptibleFFI -> "InterruptibleFFI" + LangExt.CApiFFI -> "CApiFFI" + LangExt.GHCForeignImportPrim -> "GHCForeignImportPrim" + LangExt.JavaScriptFFI -> "JavaScriptFFI" + LangExt.ParallelArrays -> "ParallelArrays" -- Syntactic support for parallel arrays + LangExt.Arrows -> "Arrows" -- Arrow-notation syntax + LangExt.TemplateHaskell -> "TemplateHaskell" + LangExt.TemplateHaskellQuotes -> "TemplateHaskellQuotes" -- subset of TH supported by stage1, no splice + LangExt.QualifiedDo -> "QualifiedDo" + LangExt.QuasiQuotes -> "QuasiQuotes" + LangExt.ImplicitParams -> "ImplicitParams" + LangExt.ImplicitPrelude -> "ImplicitPrelude" + LangExt.ScopedTypeVariables -> "ScopedTypeVariables" + LangExt.AllowAmbiguousTypes -> "AllowAmbiguousTypes" + LangExt.UnboxedTuples -> "UnboxedTuples" + LangExt.UnboxedSums -> "UnboxedSums" + LangExt.UnliftedNewtypes -> "UnliftedNewtypes" + LangExt.UnliftedDatatypes -> "UnliftedDatatypes" + LangExt.BangPatterns -> "BangPatterns" + LangExt.TypeFamilies -> "TypeFamilies" + LangExt.TypeFamilyDependencies -> "TypeFamilyDependencies" + LangExt.TypeInType -> "TypeInType" -- Deprecated + LangExt.OverloadedStrings -> "OverloadedStrings" + LangExt.OverloadedLists -> "OverloadedLists" + LangExt.NumDecimals -> "NumDecimals" + LangExt.OrPatterns -> "OrPatterns" + LangExt.DisambiguateRecordFields -> "DisambiguateRecordFields" + LangExt.RecordWildCards -> "RecordWildCards" + LangExt.NamedFieldPuns -> "NamedFieldPuns" + LangExt.ViewPatterns -> "ViewPatterns" + LangExt.GADTs -> "GADTs" + LangExt.GADTSyntax -> "GADTSyntax" + LangExt.NPlusKPatterns -> "NPlusKPatterns" + LangExt.DoAndIfThenElse -> "DoAndIfThenElse" + LangExt.BlockArguments -> "BlockArguments" + LangExt.RebindableSyntax -> "RebindableSyntax" + LangExt.ConstraintKinds -> "ConstraintKinds" + LangExt.PolyKinds -> "PolyKinds" -- Kind polymorphism + LangExt.DataKinds -> "DataKinds" -- Datatype promotion + LangExt.TypeData -> "TypeData" -- allow @type data@ definitions + LangExt.InstanceSigs -> "InstanceSigs" + LangExt.ApplicativeDo -> "ApplicativeDo" + LangExt.LinearTypes -> "LinearTypes" + LangExt.RequiredTypeArguments -> "RequiredTypeArguments" -- Visible forall (VDQ) in types of terms + LangExt.StandaloneDeriving -> "StandaloneDeriving" + LangExt.DeriveDataTypeable -> "DeriveDataTypeable" + LangExt.AutoDeriveTypeable -> "AutoDeriveTypeable" -- Automatic derivation of Typeable + LangExt.DeriveFunctor -> "DeriveFunctor" + LangExt.DeriveTraversable -> "DeriveTraversable" + LangExt.DeriveFoldable -> "DeriveFoldable" + LangExt.DeriveGeneric -> "DeriveGeneric" -- Allow deriving Generic/1 + LangExt.DefaultSignatures -> "DefaultSignatures" -- Allow extra signatures for defmeths + LangExt.DeriveAnyClass -> "DeriveAnyClass" -- Allow deriving any class + LangExt.DeriveLift -> "DeriveLift" -- Allow deriving Lift + LangExt.DerivingStrategies -> "DerivingStrategies" + LangExt.DerivingVia -> "DerivingVia" -- Derive through equal representation + LangExt.TypeSynonymInstances -> "TypeSynonymInstances" + LangExt.FlexibleContexts -> "FlexibleContexts" + LangExt.FlexibleInstances -> "FlexibleInstances" + LangExt.ConstrainedClassMethods -> "ConstrainedClassMethods" + LangExt.MultiParamTypeClasses -> "MultiParamTypeClasses" + LangExt.NullaryTypeClasses -> "NullaryTypeClasses" + LangExt.FunctionalDependencies -> "FunctionalDependencies" + LangExt.UnicodeSyntax -> "UnicodeSyntax" + LangExt.ExistentialQuantification -> "ExistentialQuantification" + LangExt.MagicHash -> "MagicHash" + LangExt.EmptyDataDecls -> "EmptyDataDecls" + LangExt.KindSignatures -> "KindSignatures" + LangExt.RoleAnnotations -> "RoleAnnotations" + LangExt.ParallelListComp -> "ParallelListComp" + LangExt.TransformListComp -> "TransformListComp" + LangExt.MonadComprehensions -> "MonadComprehensions" + LangExt.GeneralizedNewtypeDeriving -> "GeneralizedNewtypeDeriving" + LangExt.RecursiveDo -> "RecursiveDo" + LangExt.PostfixOperators -> "PostfixOperators" + LangExt.TupleSections -> "TupleSections" + LangExt.PatternGuards -> "PatternGuards" + LangExt.LiberalTypeSynonyms -> "LiberalTypeSynonyms" + LangExt.RankNTypes -> "RankNTypes" + LangExt.ImpredicativeTypes -> "ImpredicativeTypes" + LangExt.TypeOperators -> "TypeOperators" + LangExt.ExplicitNamespaces -> "ExplicitNamespaces" + LangExt.PackageImports -> "PackageImports" + LangExt.ExplicitForAll -> "ExplicitForAll" + LangExt.AlternativeLayoutRule -> "AlternativeLayoutRule" + LangExt.AlternativeLayoutRuleTransitional -> "AlternativeLayoutRuleTransitional" + LangExt.DatatypeContexts -> "DatatypeContexts" + LangExt.NondecreasingIndentation -> "NondecreasingIndentation" + LangExt.RelaxedLayout -> "RelaxedLayout" + LangExt.TraditionalRecordSyntax -> "TraditionalRecordSyntax" + LangExt.LambdaCase -> "LambdaCase" + LangExt.MultiWayIf -> "MultiWayIf" + LangExt.BinaryLiterals -> "BinaryLiterals" + LangExt.NegativeLiterals -> "NegativeLiterals" + LangExt.HexFloatLiterals -> "HexFloatLiterals" + LangExt.DuplicateRecordFields -> "DuplicateRecordFields" + LangExt.OverloadedLabels -> "OverloadedLabels" + LangExt.EmptyCase -> "EmptyCase" + LangExt.PatternSynonyms -> "PatternSynonyms" + LangExt.PartialTypeSignatures -> "PartialTypeSignatures" + LangExt.NamedWildCards -> "NamedWildCards" + LangExt.StaticPointers -> "StaticPointers" + LangExt.TypeApplications -> "TypeApplications" + LangExt.Strict -> "Strict" + LangExt.StrictData -> "StrictData" + LangExt.EmptyDataDeriving -> "EmptyDataDeriving" + LangExt.NumericUnderscores -> "NumericUnderscores" + LangExt.QuantifiedConstraints -> "QuantifiedConstraints" + LangExt.StarIsType -> "StarIsType" + LangExt.ImportQualifiedPost -> "ImportQualifiedPost" + LangExt.CUSKs -> "CUSKs" + LangExt.StandaloneKindSignatures -> "StandaloneKindSignatures" + LangExt.LexicalNegation -> "LexicalNegation" + LangExt.FieldSelectors -> "FieldSelectors" + LangExt.OverloadedRecordDot -> "OverloadedRecordDot" + LangExt.OverloadedRecordUpdate -> "OverloadedRecordUpdate" + LangExt.TypeAbstractions -> "TypeAbstractions" + LangExt.ExtendedLiterals -> "ExtendedLiterals" + LangExt.ListTuplePuns -> "ListTuplePuns" + LangExt.MultilineStrings -> "MultilineStrings" + LangExt.ExplicitLevelImports -> "ExplicitLevelImports" + LangExt.ImplicitStagePersistence -> "ImplicitStagePersistence" + +-- | Is this extension known by any other names? For example +-- -XGeneralizedNewtypeDeriving is accepted +extensionAlternateNames :: LangExt.Extension -> [String] +extensionAlternateNames = \case + LangExt.GeneralizedNewtypeDeriving -> ["GeneralisedNewtypeDeriving"] + LangExt.RankNTypes -> ["Rank2Types", "PolymorphicComponents"] + _ -> [] + +extensionDeprecatedNames :: LangExt.Extension -> [String] +extensionDeprecatedNames = \case + LangExt.RecursiveDo -> ["DoRec"] + LangExt.NamedFieldPuns -> ["RecordPuns"] + LangExt.ScopedTypeVariables -> ["PatternSignatures"] + _ -> [] + +-- | All the names by which an extension is known. +extensionNames :: LangExt.Extension -> [ (ExtensionDeprecation, String) ] +extensionNames ext = mk (extensionDeprecation ext) (extensionName ext : extensionAlternateNames ext) + ++ mk (ExtensionDeprecatedFor [ext]) (extensionDeprecatedNames ext) + where mk depr = map (\name -> (depr, name)) + +impliedXFlags :: [(LangExt.Extension, OnOff LangExt.Extension)] +impliedXFlags +-- See Note [Updating flag description in the User's Guide] + = [ (LangExt.RankNTypes, On LangExt.ExplicitForAll) + , (LangExt.QuantifiedConstraints, On LangExt.ExplicitForAll) + , (LangExt.ScopedTypeVariables, On LangExt.ExplicitForAll) + , (LangExt.LiberalTypeSynonyms, On LangExt.ExplicitForAll) + , (LangExt.ExistentialQuantification, On LangExt.ExplicitForAll) + , (LangExt.FlexibleInstances, On LangExt.TypeSynonymInstances) + , (LangExt.FunctionalDependencies, On LangExt.MultiParamTypeClasses) + , (LangExt.MultiParamTypeClasses, On LangExt.ConstrainedClassMethods) -- c.f. #7854 + , (LangExt.TypeFamilyDependencies, On LangExt.TypeFamilies) + + , (LangExt.RebindableSyntax, Off LangExt.ImplicitPrelude) -- NB: turn off! + + , (LangExt.DerivingVia, On LangExt.DerivingStrategies) + + , (LangExt.GADTs, On LangExt.GADTSyntax) + , (LangExt.GADTs, On LangExt.MonoLocalBinds) + , (LangExt.TypeFamilies, On LangExt.MonoLocalBinds) + + , (LangExt.TypeFamilies, On LangExt.KindSignatures) -- Type families use kind signatures + , (LangExt.PolyKinds, On LangExt.KindSignatures) -- Ditto polymorphic kinds + + -- TypeInType is now just a synonym for a couple of other extensions. + , (LangExt.TypeInType, On LangExt.DataKinds) + , (LangExt.TypeInType, On LangExt.PolyKinds) + , (LangExt.TypeInType, On LangExt.KindSignatures) + + -- Standalone kind signatures are a replacement for CUSKs. + , (LangExt.StandaloneKindSignatures, Off LangExt.CUSKs) + + -- AutoDeriveTypeable is not very useful without DeriveDataTypeable + , (LangExt.AutoDeriveTypeable, On LangExt.DeriveDataTypeable) + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (LangExt.TypeFamilies, On LangExt.ExplicitNamespaces) + , (LangExt.TypeOperators, On LangExt.ExplicitNamespaces) + + , (LangExt.ImpredicativeTypes, On LangExt.RankNTypes) + + -- Record wild-cards implies field disambiguation + -- Otherwise if you write (C {..}) you may well get + -- stuff like " 'a' not in scope ", which is a bit silly + -- if the compiler has just filled in field 'a' of constructor 'C' + , (LangExt.RecordWildCards, On LangExt.DisambiguateRecordFields) + + , (LangExt.ParallelArrays, On LangExt.ParallelListComp) + , (LangExt.MonadComprehensions, On LangExt.ParallelListComp) + , (LangExt.JavaScriptFFI, On LangExt.InterruptibleFFI) + + , (LangExt.DeriveTraversable, On LangExt.DeriveFunctor) + , (LangExt.DeriveTraversable, On LangExt.DeriveFoldable) + + -- Duplicate record fields require field disambiguation + , (LangExt.DuplicateRecordFields, On LangExt.DisambiguateRecordFields) + + , (LangExt.TemplateHaskell, On LangExt.TemplateHaskellQuotes) + , (LangExt.Strict, On LangExt.StrictData) + + -- Historically only UnboxedTuples was required for unboxed sums to work. + -- To avoid breaking code, we make UnboxedTuples imply UnboxedSums. + , (LangExt.UnboxedTuples, On LangExt.UnboxedSums) + + -- The extensions needed to declare an H98 unlifted data type + , (LangExt.UnliftedDatatypes, On LangExt.DataKinds) + , (LangExt.UnliftedDatatypes, On LangExt.StandaloneKindSignatures) + + -- See (NVP3) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind + , (LangExt.LinearTypes, On LangExt.MonoLocalBinds) + + , (LangExt.ExplicitLevelImports, Off LangExt.ImplicitStagePersistence) + ] + + +validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +validHoleFitsImpliedGFlags + = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) + , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ] + +-- | General flags that are switched on/off when other general flags are switched +-- on +impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) + ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) + ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting) + ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) + ,(Opt_WriteIfSimplifiedCore, turnOn, Opt_WriteInterface) + ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteIfSimplifiedCore) + ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithStack) + ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithFallback) + ] ++ validHoleFitsImpliedGFlags + +-- | General flags that are switched on/off when other general flags are switched +-- off +impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] + +-- Please keep @docs/users_guide/what_glasgow_exts_does.rst@ up to date with this list. +glasgowExtsFlags :: [LangExt.Extension] +glasgowExtsFlags = [ + LangExt.ConstrainedClassMethods + , LangExt.DeriveDataTypeable + , LangExt.DeriveFoldable + , LangExt.DeriveFunctor + , LangExt.DeriveGeneric + , LangExt.DeriveTraversable + , LangExt.EmptyDataDecls + , LangExt.ExistentialQuantification + , LangExt.ExplicitNamespaces + , LangExt.FlexibleContexts + , LangExt.FlexibleInstances + , LangExt.ForeignFunctionInterface + , LangExt.FunctionalDependencies + , LangExt.GeneralizedNewtypeDeriving + , LangExt.ImplicitParams + , LangExt.KindSignatures + , LangExt.LiberalTypeSynonyms + , LangExt.MagicHash + , LangExt.MultiParamTypeClasses + , LangExt.ParallelListComp + , LangExt.PatternGuards + , LangExt.PostfixOperators + , LangExt.RankNTypes + , LangExt.RecursiveDo + , LangExt.ScopedTypeVariables + , LangExt.StandaloneDeriving + , LangExt.TypeOperators + , LangExt.TypeSynonymInstances + , LangExt.UnboxedTuples + , LangExt.UnicodeSyntax + , LangExt.UnliftedFFITypes ] + +-- | Debugging flags +data DumpFlag +-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session + + -- debugging flags + = Opt_D_dump_cmm + | Opt_D_dump_cmm_from_stg + | Opt_D_dump_cmm_raw + | Opt_D_dump_cmm_verbose_by_proc + -- All of the cmm subflags (there are a lot!) automatically + -- enabled if you run -ddump-cmm-verbose-by-proc + -- Each flag corresponds to exact stage of Cmm pipeline. + | Opt_D_dump_cmm_verbose + -- ^ same as -ddump-cmm-verbose-by-proc but writes each stage + -- to a separate file (if used with -ddump-to-file) + | Opt_D_dump_cmm_cfg + | Opt_D_dump_cmm_cbe + | Opt_D_dump_cmm_switch + | Opt_D_dump_cmm_proc + | Opt_D_dump_cmm_sp + | Opt_D_dump_cmm_sink + | Opt_D_dump_cmm_caf + | Opt_D_dump_cmm_procmap + | Opt_D_dump_cmm_split + | Opt_D_dump_cmm_info + | Opt_D_dump_cmm_cps + | Opt_D_dump_cmm_thread_sanitizer + -- end cmm subflags + | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. + | Opt_D_dump_asm + | Opt_D_dump_asm_native + | Opt_D_dump_asm_liveness + | Opt_D_dump_asm_regalloc + | Opt_D_dump_asm_regalloc_stages + | Opt_D_dump_asm_conflicts + | Opt_D_dump_asm_stats + | Opt_D_dump_c_backend + | Opt_D_dump_llvm + | Opt_D_dump_js + | Opt_D_dump_core_stats + | Opt_D_dump_deriv + | Opt_D_dump_ds + | Opt_D_dump_ds_preopt + | Opt_D_dump_foreign + | Opt_D_dump_inlinings + | Opt_D_dump_verbose_inlinings + | Opt_D_dump_rule_firings + | Opt_D_dump_rule_rewrites + | Opt_D_dump_simpl_trace + | Opt_D_dump_occur_anal + | Opt_D_dump_parsed + | Opt_D_dump_parsed_ast + | Opt_D_dump_rn + | Opt_D_dump_rn_ast + | Opt_D_dump_simpl + | Opt_D_dump_simpl_iterations + | Opt_D_dump_spec + | Opt_D_dump_spec_constr + | Opt_D_dump_prep + | Opt_D_dump_late_cc + | Opt_D_dump_stg_from_core -- ^ Initial STG (CoreToStg output) + | Opt_D_dump_stg_unarised -- ^ STG after unarise + | Opt_D_dump_stg_cg -- ^ STG (after stg2stg) + | Opt_D_dump_stg_tags -- ^ Result of tag inference analysis. + | Opt_D_dump_stg_final -- ^ Final STG (before cmm gen) + | Opt_D_dump_stg_from_js_sinker -- ^ STG after JS sinker + | Opt_D_dump_call_arity + | Opt_D_dump_exitify + | Opt_D_dump_dmdanal + | Opt_D_dump_dmd_signatures + | Opt_D_dump_cpranal + | Opt_D_dump_cpr_signatures + | Opt_D_dump_tc + | Opt_D_dump_tc_ast + | Opt_D_dump_hie + | Opt_D_dump_types + | Opt_D_dump_rules + | Opt_D_dump_cse + | Opt_D_dump_float_out + | Opt_D_dump_float_in + | Opt_D_dump_liberate_case + | Opt_D_dump_static_argument_transformation + | Opt_D_dump_worker_wrapper + | Opt_D_dump_rn_trace + | Opt_D_dump_rn_stats + | Opt_D_dump_opt_cmm + | Opt_D_dump_simpl_stats + | Opt_D_dump_cs_trace -- ^ Constraint solver in type checker + | Opt_D_dump_tc_trace + | Opt_D_dump_ec_trace -- ^ Pattern match exhaustiveness checker + | Opt_D_dump_if_trace + | Opt_D_dump_splices + | Opt_D_th_dec_file + | Opt_D_dump_BCOs + | Opt_D_dump_ticked + | Opt_D_dump_rtti + | Opt_D_source_stats + | Opt_D_verbose_stg2stg + | Opt_D_dump_hi + | Opt_D_dump_hi_diffs + | Opt_D_dump_mod_cycles + | Opt_D_dump_mod_map + | Opt_D_dump_timings + | Opt_D_dump_view_pattern_commoning + | Opt_D_verbose_core2core + | Opt_D_dump_debug + | Opt_D_dump_json + | Opt_D_ppr_debug + | Opt_D_no_debug_output + | Opt_D_dump_faststrings + | Opt_D_faststring_stats + | Opt_D_ipe_stats + deriving (Eq, Show, Enum) + +-- | Helper function to query whether a given `DumpFlag` is enabled or not. +getDumpFlagFrom + :: (a -> Int) -- ^ Getter for verbosity setting + -> (a -> EnumSet DumpFlag) -- ^ Getter for the set of enabled dump flags + -> DumpFlag -> a -> Bool +getDumpFlagFrom getVerbosity getFlags f x + = (f `EnumSet.member` getFlags x) + || (getVerbosity x >= 4 && enabledIfVerbose f) + +-- | Is the flag implicitly enabled when the verbosity is high enough? +enabledIfVerbose :: DumpFlag -> Bool +enabledIfVerbose Opt_D_dump_tc_trace = False +enabledIfVerbose Opt_D_dump_rn_trace = False +enabledIfVerbose Opt_D_dump_cs_trace = False +enabledIfVerbose Opt_D_dump_if_trace = False +enabledIfVerbose Opt_D_dump_tc = False +enabledIfVerbose Opt_D_dump_rn = False +enabledIfVerbose Opt_D_dump_rn_stats = False +enabledIfVerbose Opt_D_dump_hi_diffs = False +enabledIfVerbose Opt_D_verbose_core2core = False +enabledIfVerbose Opt_D_verbose_stg2stg = False +enabledIfVerbose Opt_D_dump_splices = False +enabledIfVerbose Opt_D_th_dec_file = False +enabledIfVerbose Opt_D_dump_rule_firings = False +enabledIfVerbose Opt_D_dump_rule_rewrites = False +enabledIfVerbose Opt_D_dump_simpl_trace = False +enabledIfVerbose Opt_D_dump_rtti = False +enabledIfVerbose Opt_D_dump_inlinings = False +enabledIfVerbose Opt_D_dump_verbose_inlinings = False +enabledIfVerbose Opt_D_dump_core_stats = False +enabledIfVerbose Opt_D_dump_asm_stats = False +enabledIfVerbose Opt_D_dump_types = False +enabledIfVerbose Opt_D_dump_simpl_iterations = False +enabledIfVerbose Opt_D_dump_ticked = False +enabledIfVerbose Opt_D_dump_view_pattern_commoning = False +enabledIfVerbose Opt_D_dump_mod_cycles = False +enabledIfVerbose Opt_D_dump_mod_map = False +enabledIfVerbose Opt_D_dump_ec_trace = False +enabledIfVerbose _ = True + +-- | Enumerates the simple on-or-off dynamic flags +data GeneralFlag +-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session + + = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. + | Opt_DumpWithWays -- ^ Use foo.ways. instead of foo. + | Opt_D_dump_minimal_imports + | Opt_DoCoreLinting + | Opt_DoLinearCoreLinting + | Opt_DoStgLinting + | Opt_DoCmmLinting + | Opt_DoAsmLinting + | Opt_DoAnnotationLinting + | Opt_DoBoundsChecking + | Opt_AddBcoName + | Opt_NoLlvmMangler -- hidden flag + | Opt_FastLlvm -- hidden flag + | Opt_NoTypeableBinds + + | Opt_DistinctConstructorTables + | Opt_InfoTableMap + | Opt_InfoTableMapWithFallback + | Opt_InfoTableMapWithStack + + | Opt_WarnIsError + -- ^ @-Werror@; makes all warnings fatal. + -- See 'wopt_set_fatal' for making individual warnings fatal as in @-Werror=foo@. + | Opt_ShowWarnGroups + -- ^ Show the group a warning belongs to. + | Opt_HideSourcePaths + -- ^ @-fhide-source-paths@; hide module source/object paths. + + | Opt_PrintExplicitForalls + | Opt_PrintExplicitKinds + | Opt_PrintExplicitCoercions + | Opt_PrintExplicitRuntimeReps + | Opt_PrintEqualityRelations + | Opt_PrintAxiomIncomps + | Opt_PrintUnicodeSyntax + | Opt_PrintExpandedSynonyms + | Opt_PrintPotentialInstances + | Opt_PrintRedundantPromotionTicks + | Opt_PrintTypecheckerElaboration + + -- optimisation opts + | Opt_CallArity + | Opt_Exitification + | Opt_Strictness + | Opt_LateDmdAnal -- #6087 + | Opt_KillAbsence + | Opt_KillOneShot + | Opt_FullLaziness + | Opt_FloatIn + | Opt_LocalFloatOut -- ^ Enable floating out of let-bindings in the + -- simplifier + | Opt_LocalFloatOutTopLevel -- ^ Enable floating out of let-bindings at the + -- top level in the simplifier + -- N.B. See Note [RHS Floating] + | Opt_LateSpecialise + | Opt_Specialise + | Opt_SpecialiseAggressively + | Opt_CrossModuleSpecialise + | Opt_PolymorphicSpecialisation + | Opt_InlineGenerics + | Opt_InlineGenericsAggressively + | Opt_StaticArgumentTransformation + | Opt_CSE + | Opt_StgCSE + | Opt_StgLiftLams + | Opt_LiberateCase + | Opt_SpecConstr + | Opt_SpecConstrKeen + | Opt_SpecialiseIncoherents + | Opt_DoLambdaEtaExpansion + | Opt_DoCleverArgEtaExpansion -- See Note [Eta expansion of arguments in CorePrep] + | Opt_IgnoreAsserts + | Opt_DoEtaReduction + | Opt_CaseMerge + | Opt_CaseFolding -- ^ Constant folding through case-expressions + | Opt_UnboxStrictFields + | Opt_UnboxSmallStrictFields + | Opt_DictsCheap + | Opt_EnableRewriteRules -- ^ Apply rewrite rules during simplification + | Opt_EnableThSpliceWarnings -- ^ Enable warnings for TH splices + | Opt_RegsGraph -- ^ Do graph coloring register allocation + | Opt_RegsIterative -- ^ Do iterative coalescing graph coloring register allocation + | Opt_PedanticBottoms -- ^ Be picky about how we treat bottom + | Opt_LlvmFillUndefWithGarbage -- Testing for undef bugs (hidden flag) + | Opt_IrrefutableTuples + | Opt_CmmSink + | Opt_CmmStaticPred + | Opt_CmmElimCommonBlocks + | Opt_CmmControlFlow + | Opt_AsmShortcutting + | Opt_InterModuleFarJumps + | Opt_OmitYields + | Opt_FunToThunk -- deprecated + | Opt_DictsStrict -- ^ Be strict in argument dictionaries + | Opt_DmdTxDictSel -- ^ deprecated, no effect and behaviour is now default. + -- Allowed switching of a special demand transformer for dictionary selectors + | Opt_Loopification -- See Note [Self-recursive tail calls] + | Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm. + | Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block. + | Opt_CprAnal + | Opt_WorkerWrapper + | Opt_WorkerWrapperUnlift -- ^ Do W/W split for unlifting even if we won't unbox anything. + | Opt_SolveConstantDicts + | Opt_AlignmentSanitisation + | Opt_CatchNonexhaustiveCases + | Opt_NumConstantFolding -- ^ See Note [Constant folding through nested expressions] in GHC.Core.Opt.ConstantFold + | Opt_CoreConstantFolding + | Opt_FastPAPCalls -- #6084 + | Opt_SpecEval + | Opt_SpecEvalDictFun -- See Note [Controlling Speculative Evaluation] + + + -- Inference flags + | Opt_DoTagInferenceChecks + + -- | PreInlining is on by default. The option is there just to see how + -- bad things get if you turn it off! + | Opt_SimplPreInlining + + -- Interface files + | Opt_IgnoreInterfacePragmas + | Opt_OmitInterfacePragmas + | Opt_ExposeAllUnfoldings + | Opt_ExposeOverloadedUnfoldings + | Opt_KeepAutoRules -- ^ Keep auto-generated rules even if they seem to have become useless + | Opt_WriteInterface -- ^ Forces .hi files to be written even with -fno-code + | Opt_WriteSelfRecompInfo + | Opt_WriteSelfRecompFlags -- ^ Include detailed flag information for self-recompilation debugging + | Opt_WriteHie -- ^ Generate .hie files + + -- JavaScript opts + | Opt_DisableJsMinifier -- ^ Render JavaScript pretty-printed instead of minified (compacted) + | Opt_DisableJsCsources -- ^ Don't link C sources (compiled to JS) with Haskell code (compiled to JS) + + -- profiling opts + | Opt_AutoSccsOnIndividualCafs + | Opt_ProfCountEntries + | Opt_ProfLateInlineCcs + | Opt_ProfLateCcs + | Opt_ProfLateOverloadedCcs + | Opt_ProfLateoverloadedCallsCCs + | Opt_ProfManualCcs -- ^ Ignore manual SCC annotations + + -- misc opts + | Opt_Pp + | Opt_ForceRecomp + | Opt_IgnoreOptimChanges + | Opt_IgnoreHpcChanges + | Opt_ExcessPrecision + | Opt_EagerBlackHoling + | Opt_OrigThunkInfo + | Opt_NoHsMain + | Opt_SplitSections + | Opt_StgStats + | Opt_HideAllPackages + | Opt_HideAllPluginPackages + | Opt_PrintBindResult + | Opt_Haddock + | Opt_HaddockOptions + | Opt_BreakOnException + | Opt_BreakOnError + | Opt_PrintEvldWithShow + | Opt_PrintBindContents + | Opt_GenManifest + | Opt_EmbedManifest + | Opt_SharedImplib + | Opt_BuildingCabalPackage + | Opt_IgnoreDotGhci + | Opt_GhciSandbox + | Opt_InsertBreakpoints + | Opt_GhciHistory + | Opt_GhciLeakCheck + | Opt_ValidateHie + | Opt_LocalGhciHistory + | Opt_NoIt + + -- wasm ghci browser mode + | Opt_GhciBrowser + | Opt_GhciBrowserRedirectWasiConsole + + -- | Instruct GHCi to load all targets on startup + | Opt_GhciDoLoadTargets + + | Opt_HelpfulErrors + | Opt_DeferTypeErrors -- Since 7.6 + | Opt_DeferTypedHoles -- Since 7.10 + | Opt_DeferOutOfScopeVariables + | Opt_PIC -- ^ @-fPIC@ + | Opt_PIE -- ^ @-fPIE@ + | Opt_PICExecutable -- ^ @-pie@ + | Opt_ExternalDynamicRefs + | Opt_Ticky + | Opt_Ticky_Allocd + | Opt_Ticky_LNE + | Opt_Ticky_Dyn_Thunk + | Opt_Ticky_Tag + | Opt_Ticky_AP -- ^ Use regular thunks even when we could use std ap thunks in order to get entry counts + | Opt_CmmThreadSanitizer + | Opt_RPath + | Opt_RelativeDynlibPaths + | Opt_CompactUnwind -- ^ @-fcompact-unwind@ + | Opt_Hpc + | Opt_FamAppCache + | Opt_ExternalInterpreter + | Opt_OptimalApplicativeDo + | Opt_VersionMacros + | Opt_WholeArchiveHsLibs + -- copy all libs into a single folder prior to linking binaries + -- this should alleviate the excessive command line limit restrictions + -- on windows, by only requiring a single -L argument instead of + -- one for each dependency. At the time of this writing, gcc + -- forwards all -L flags to the collect2 command without using a + -- response file and as such breaking apart. + | Opt_SingleLibFolder + | Opt_ExposeInternalSymbols + | Opt_KeepCAFs + | Opt_KeepGoing + | Opt_ByteCode + | Opt_ByteCodeAndObjectCode + | Opt_UnoptimizedCoreForInterpreter + | Opt_LinkRts + + -- output style opts + | Opt_ErrorSpans -- ^ Include full span info in error messages, + -- instead of just the start position. + | Opt_DeferDiagnostics + | Opt_DiagnosticsAsJSON -- ^ Dump diagnostics as JSON + | Opt_DiagnosticsShowCaret -- ^ Show snippets of offending code + | Opt_PprCaseAsLet + | Opt_PprShowTicks + | Opt_ShowHoleConstraints + -- Options relating to the display of valid hole fits + -- when generating an error message for a typed hole + -- See Note [Valid hole fits include ...] in GHC.Tc.Errors.Hole + | Opt_ShowValidHoleFits + | Opt_SortValidHoleFits + | Opt_SortBySizeHoleFits + | Opt_SortBySubsumHoleFits + | Opt_AbstractRefHoleFits + | Opt_UnclutterValidHoleFits + | Opt_ShowTypeAppOfHoleFits + | Opt_ShowTypeAppVarsOfHoleFits + | Opt_ShowDocsOfHoleFits + | Opt_ShowTypeOfHoleFits + | Opt_ShowProvOfHoleFits + | Opt_ShowMatchesOfHoleFits + + | Opt_ShowLoadedModules + | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] + + -- | Suppress a coercions inner structure, replacing it with '...' + | Opt_SuppressCoercions + -- | Suppress the type of a coercion as well + | Opt_SuppressCoercionTypes + | Opt_SuppressVarKinds + -- | Suppress module id prefixes on variables. + | Opt_SuppressModulePrefixes + -- | Suppress type applications. + | Opt_SuppressTypeApplications + -- | Suppress info such as arity and unfoldings on identifiers. + | Opt_SuppressIdInfo + -- | Suppress separate type signatures in core, but leave types on + -- lambda bound vars + | Opt_SuppressUnfoldings + -- | Suppress the details of even stable unfoldings + | Opt_SuppressTypeSignatures + -- | Suppress unique ids on variables. + -- Except for uniques, as some simplifier phases introduce new + -- variables that have otherwise identical names. + | Opt_SuppressUniques + | Opt_SuppressStgExts + | Opt_SuppressStgReps + | Opt_SuppressTicks -- ^ Replaces Opt_PprShowTicks + | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps + | Opt_SuppressCoreSizes -- ^ Suppress per binding Core size stats in dumps + + -- Error message suppression + | Opt_ShowErrorContext + + -- Object code determinism + | Opt_ObjectDeterminism + + -- temporary flags + | Opt_AutoLinkPackages + | Opt_ImplicitImportQualified + + -- keeping stuff + | Opt_KeepHscppFiles + | Opt_KeepHiDiffs + | Opt_KeepHcFiles + | Opt_KeepSFiles + | Opt_KeepTmpFiles + | Opt_KeepRawTokenStream + | Opt_KeepLlvmFiles + | Opt_KeepHiFiles + | Opt_KeepOFiles + + | Opt_BuildDynamicToo + | Opt_WriteIfSimplifiedCore + | Opt_UseBytecodeRatherThanObjects + + -- safe haskell flags + | Opt_DistrustAllPackages + | Opt_PackageTrust + | Opt_PluginTrustworthy + + | Opt_G_NoStateHack + | Opt_G_NoOptCoercion + deriving (Eq, Show, Enum) + +-- | The set of flags which affect optimisation for the purposes of +-- recompilation avoidance. Specifically, these include flags which +-- affect code generation but not the semantics of the program. +-- +-- See Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags) +optimisationFlags :: EnumSet GeneralFlag +optimisationFlags = EnumSet.fromList + [ Opt_CallArity + , Opt_Strictness + , Opt_LateDmdAnal + , Opt_KillAbsence + , Opt_KillOneShot + , Opt_FullLaziness + , Opt_FloatIn + , Opt_LateSpecialise + , Opt_Specialise + , Opt_SpecialiseAggressively + , Opt_CrossModuleSpecialise + , Opt_StaticArgumentTransformation + , Opt_CSE + , Opt_StgCSE + , Opt_StgLiftLams + , Opt_LiberateCase + , Opt_SpecConstr + , Opt_SpecConstrKeen + , Opt_DoLambdaEtaExpansion + , Opt_IgnoreAsserts + , Opt_DoEtaReduction + , Opt_CaseMerge + , Opt_CaseFolding + , Opt_UnboxStrictFields + , Opt_UnboxSmallStrictFields + , Opt_DictsCheap + , Opt_EnableRewriteRules + , Opt_RegsGraph + , Opt_RegsIterative + , Opt_IrrefutableTuples + , Opt_CmmSink + , Opt_CmmElimCommonBlocks + , Opt_AsmShortcutting + , Opt_InterModuleFarJumps + , Opt_FunToThunk + , Opt_DmdTxDictSel + , Opt_Loopification + , Opt_CfgBlocklayout + , Opt_WeightlessBlocklayout + , Opt_CprAnal + , Opt_WorkerWrapper + , Opt_WorkerWrapperUnlift + , Opt_SolveConstantDicts + , Opt_SpecEval + , Opt_SpecEvalDictFun + ] + +-- | The set of flags which affect code generation and can change a program's +-- runtime behavior (other than performance). These include flags which affect: +-- +-- * user visible debugging information (e.g. info table provenance) +-- * the ability to catch runtime errors (e.g. -fignore-asserts) +-- * the runtime result of the program (e.g. -fomit-yields) +-- * which code or interface file declarations are emitted +-- +-- We also considered placing flags which affect asympototic space behavior +-- (e.g. -ffull-laziness) however this would mean that changing optimisation +-- levels would trigger recompilation even with -fignore-optim-changes, +-- regressing #13604. +-- +-- Also, arguably Opt_IgnoreAsserts should be here as well; however, we place +-- it instead in 'optimisationFlags' since it is implied by @-O[12]@ and +-- therefore would also break #13604. +-- +-- See #23369. +codeGenFlags :: EnumSet GeneralFlag +codeGenFlags = EnumSet.fromList + [ -- Flags that affect runtime result + Opt_EagerBlackHoling + , Opt_ExcessPrecision + , Opt_DictsStrict + , Opt_PedanticBottoms + , Opt_OmitYields + + -- Flags that affect generated code + , Opt_ExposeAllUnfoldings + , Opt_ExposeOverloadedUnfoldings + , Opt_NoTypeableBinds + , Opt_ObjectDeterminism + , Opt_Haddock + + -- Flags that affect catching of runtime errors + , Opt_CatchNonexhaustiveCases + , Opt_LlvmFillUndefWithGarbage + , Opt_DoTagInferenceChecks + + -- Flags that affect debugging information + , Opt_DistinctConstructorTables + , Opt_InfoTableMap + , Opt_InfoTableMapWithStack + , Opt_InfoTableMapWithFallback + , Opt_OrigThunkInfo + ] + +data WarningFlag = +-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session + Opt_WarnDuplicateExports + | Opt_WarnDuplicateConstraints + | Opt_WarnRedundantConstraints + | Opt_WarnHiShadows + | Opt_WarnImplicitPrelude + | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnOverflowedLiterals + | Opt_WarnEmptyEnumerations + | Opt_WarnMissingFields + | Opt_WarnMissingImportList + | Opt_WarnMissingMethods + | Opt_WarnMissingSignatures + | Opt_WarnMissingLocalSignatures + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnTypeDefaults + | Opt_WarnMonomorphism + | Opt_WarnUnusedTopBinds + | Opt_WarnUnusedLocalBinds + | Opt_WarnUnusedPatternBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnUnusedTypePatterns + | Opt_WarnUnusedForalls + | Opt_WarnUnusedRecordWildcards + | Opt_WarnRedundantBangPatterns + | Opt_WarnRedundantRecordWildcards + | Opt_WarnDeprecatedFlags + | Opt_WarnMissingMonadFailInstances -- since 8.0, has no effect since 8.8 + | Opt_WarnSemigroup -- since 8.0, has no effect since 9.8 + | Opt_WarnDodgyExports + | Opt_WarnDodgyImports + | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities + | Opt_WarnTabs + | Opt_WarnUnrecognisedPragmas + | Opt_WarnMisplacedPragmas + | Opt_WarnDodgyForeignImports + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + | Opt_WarnAlternativeLayoutRuleTransitional + | Opt_WarnUnsafe + | Opt_WarnSafe + | Opt_WarnTrustworthySafe + | Opt_WarnMissedSpecs + | Opt_WarnAllMissedSpecs + | Opt_WarnUnsupportedCallingConventions + | Opt_WarnUnsupportedLlvmVersion + | Opt_WarnMissedExtraSharedLib + | Opt_WarnInlineRuleShadowing + | Opt_WarnTypedHoles + | Opt_WarnPartialTypeSignatures + | Opt_WarnMissingExportedSignatures + | Opt_WarnUntickedPromotedConstructors + | Opt_WarnDerivingTypeable + | Opt_WarnDeferredTypeErrors + | Opt_WarnDeferredOutOfScopeVariables + | Opt_WarnNonCanonicalMonadInstances -- ^ @since 8.0 + | Opt_WarnNonCanonicalMonadFailInstances -- ^ @since 8.0, has no effect since 8.8 + | Opt_WarnNonCanonicalMonoidInstances -- ^ @since 8.0 + | Opt_WarnMissingPatternSynonymSignatures -- ^ @since 8.0 + | Opt_WarnUnrecognisedWarningFlags -- ^ @since 8.0 + | Opt_WarnSimplifiableClassConstraints -- ^ @since 8.2 + | Opt_WarnCPPUndef -- ^ @since 8.2 + | Opt_WarnUnbangedStrictPatterns -- ^ @since 8.2 + | Opt_WarnMissingHomeModules -- ^ @since 8.2 + | Opt_WarnPartialFields -- ^ @since 8.4 + | Opt_WarnMissingExportList + | Opt_WarnInaccessibleCode + | Opt_WarnStarIsType -- ^ @since 8.6 + | Opt_WarnStarBinder -- ^ @since 8.6 + | Opt_WarnImplicitKindVars -- ^ @since 8.6 + | Opt_WarnSpaceAfterBang + | Opt_WarnMissingDerivingStrategies -- ^ @since 8.8 + | Opt_WarnPrepositiveQualifiedModule -- ^ @since 8.10 + | Opt_WarnUnusedPackages -- ^ @since 8.10 + | Opt_WarnInferredSafeImports -- ^ @since 8.10 + | Opt_WarnMissingSafeHaskellMode -- ^ @since 8.10 + | Opt_WarnCompatUnqualifiedImports -- ^ @since 8.10 + | Opt_WarnDerivingDefaults + | Opt_WarnInvalidHaddock -- ^ @since 9.0 + | Opt_WarnOperatorWhitespaceExtConflict -- ^ @since 9.2 + | Opt_WarnOperatorWhitespace -- ^ @since 9.2 + | Opt_WarnAmbiguousFields -- ^ @since 9.2 + | Opt_WarnImplicitLift -- ^ @since 9.2 + | Opt_WarnMissingKindSignatures -- ^ @since 9.2 + | Opt_WarnMissingPolyKindSignatures -- ^ @since 9.8 + | Opt_WarnMissingExportedPatternSynonymSignatures -- ^ @since 9.2 + | Opt_WarnRedundantStrictnessFlags -- ^ @since 9.4 + | Opt_WarnForallIdentifier -- ^ @since 9.4 + | Opt_WarnUnicodeBidirectionalFormatCharacters -- ^ @since 9.0.2 + | Opt_WarnGADTMonoLocalBinds -- ^ @since 9.4 + | Opt_WarnTypeEqualityOutOfScope -- ^ @since 9.4 + | Opt_WarnTypeEqualityRequiresOperators -- ^ @since 9.4 + | Opt_WarnLoopySuperclassSolve -- ^ @since 9.6, has no effect since 9.10 + | Opt_WarnTermVariableCapture -- ^ @since 9.8 + | Opt_WarnMissingRoleAnnotations -- ^ @since 9.8 + | Opt_WarnImplicitRhsQuantification -- ^ @since 9.8 + | Opt_WarnIncompleteExportWarnings -- ^ @since 9.8 + | Opt_WarnIncompleteRecordSelectors -- ^ @since 9.10 + | Opt_WarnBadlyLevelledTypes -- ^ @since 9.10 + | Opt_WarnInconsistentFlags -- ^ @since 9.8 + | Opt_WarnDataKindsTC -- ^ @since 9.10 + | Opt_WarnDefaultedExceptionContext -- ^ @since 9.10 + | Opt_WarnViewPatternSignatures -- ^ @since 9.12 + | Opt_WarnUselessSpecialisations -- ^ @since 9.14 + | Opt_WarnDeprecatedPragmas -- ^ @since 9.14 + | Opt_WarnRuleLhsEqualities + -- ^ @since 9.14, scheduled to be removed in 9.18 + -- + -- See Note [Quantifying over equalities in RULES] in GHC.Tc.Gen.Sig + | Opt_WarnUnusableUnpackPragmas -- Since 9.14 + | Opt_WarnPatternNamespaceSpecifier -- Since 9.14 + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | Return the names of a WarningFlag +-- +-- One flag may have several names because of US/UK spelling. The first one is +-- the "preferred one" that will be displayed in warning messages. +warnFlagNames :: WarningFlag -> NonEmpty String +warnFlagNames wflag = case wflag of + Opt_WarnAlternativeLayoutRuleTransitional -> "alternative-layout-rule-transitional" :| [] + Opt_WarnAmbiguousFields -> "ambiguous-fields" :| [] + Opt_WarnAutoOrphans -> "auto-orphans" :| [] + Opt_WarnTermVariableCapture -> "term-variable-capture" :| [] + Opt_WarnCPPUndef -> "cpp-undef" :| [] + Opt_WarnUnbangedStrictPatterns -> "unbanged-strict-patterns" :| [] + Opt_WarnDeferredTypeErrors -> "deferred-type-errors" :| [] + Opt_WarnDeferredOutOfScopeVariables -> "deferred-out-of-scope-variables" :| [] + Opt_WarnDeprecatedFlags -> "deprecated-flags" :| [] + Opt_WarnDerivingDefaults -> "deriving-defaults" :| [] + Opt_WarnDerivingTypeable -> "deriving-typeable" :| [] + Opt_WarnDodgyExports -> "dodgy-exports" :| [] + Opt_WarnDodgyForeignImports -> "dodgy-foreign-imports" :| [] + Opt_WarnDodgyImports -> "dodgy-imports" :| [] + Opt_WarnEmptyEnumerations -> "empty-enumerations" :| [] + Opt_WarnDuplicateConstraints -> "duplicate-constraints" :| [] + Opt_WarnRedundantConstraints -> "redundant-constraints" :| [] + Opt_WarnDuplicateExports -> "duplicate-exports" :| [] + Opt_WarnHiShadows -> "hi-shadowing" :| [] + Opt_WarnInaccessibleCode -> "inaccessible-code" :| [] + Opt_WarnImplicitPrelude -> "implicit-prelude" :| [] + Opt_WarnImplicitKindVars -> "implicit-kind-vars" :| [] + Opt_WarnIncompletePatterns -> "incomplete-patterns" :| [] + Opt_WarnIncompletePatternsRecUpd -> "incomplete-record-updates" :| [] + Opt_WarnIncompleteUniPatterns -> "incomplete-uni-patterns" :| [] + Opt_WarnInlineRuleShadowing -> "inline-rule-shadowing" :| [] + Opt_WarnIdentities -> "identities" :| [] + Opt_WarnMissingFields -> "missing-fields" :| [] + Opt_WarnMissingImportList -> "missing-import-lists" :| [] + Opt_WarnMissingExportList -> "missing-export-lists" :| [] + Opt_WarnMissingLocalSignatures -> "missing-local-signatures" :| [] + Opt_WarnMissingMethods -> "missing-methods" :| [] + Opt_WarnMissingMonadFailInstances -> "missing-monadfail-instances" :| [] + Opt_WarnSemigroup -> "semigroup" :| [] + Opt_WarnMissingSignatures -> "missing-signatures" :| [] + Opt_WarnMissingKindSignatures -> "missing-kind-signatures" :| [] + Opt_WarnMissingPolyKindSignatures -> "missing-poly-kind-signatures" :| [] + Opt_WarnMissingExportedSignatures -> "missing-exported-signatures" :| [] + Opt_WarnMonomorphism -> "monomorphism-restriction" :| [] + Opt_WarnNameShadowing -> "name-shadowing" :| [] + Opt_WarnNonCanonicalMonadInstances -> "noncanonical-monad-instances" :| [] + Opt_WarnNonCanonicalMonadFailInstances -> "noncanonical-monadfail-instances" :| [] + Opt_WarnNonCanonicalMonoidInstances -> "noncanonical-monoid-instances" :| [] + Opt_WarnOrphans -> "orphans" :| [] + Opt_WarnOverflowedLiterals -> "overflowed-literals" :| [] + Opt_WarnOverlappingPatterns -> "overlapping-patterns" :| [] + Opt_WarnMissedSpecs -> "missed-specialisations" :| ["missed-specializations"] + Opt_WarnAllMissedSpecs -> "all-missed-specialisations" :| ["all-missed-specializations"] + Opt_WarnSafe -> "safe" :| [] + Opt_WarnTrustworthySafe -> "trustworthy-safe" :| [] + Opt_WarnInferredSafeImports -> "inferred-safe-imports" :| [] + Opt_WarnMissingSafeHaskellMode -> "missing-safe-haskell-mode" :| [] + Opt_WarnTabs -> "tabs" :| [] + Opt_WarnTypeDefaults -> "type-defaults" :| [] + Opt_WarnTypedHoles -> "typed-holes" :| [] + Opt_WarnPartialTypeSignatures -> "partial-type-signatures" :| [] + Opt_WarnUnrecognisedPragmas -> "unrecognised-pragmas" :| [] + Opt_WarnMisplacedPragmas -> "misplaced-pragmas" :| [] + Opt_WarnUnsafe -> "unsafe" :| [] + Opt_WarnUnsupportedCallingConventions -> "unsupported-calling-conventions" :| [] + Opt_WarnUnsupportedLlvmVersion -> "unsupported-llvm-version" :| [] + Opt_WarnMissedExtraSharedLib -> "missed-extra-shared-lib" :| [] + Opt_WarnUntickedPromotedConstructors -> "unticked-promoted-constructors" :| [] + Opt_WarnUnusedDoBind -> "unused-do-bind" :| [] + Opt_WarnUnusedForalls -> "unused-foralls" :| [] + Opt_WarnUnusedImports -> "unused-imports" :| [] + Opt_WarnUnusedLocalBinds -> "unused-local-binds" :| [] + Opt_WarnUnusedMatches -> "unused-matches" :| [] + Opt_WarnUnusedPatternBinds -> "unused-pattern-binds" :| [] + Opt_WarnUnusedTopBinds -> "unused-top-binds" :| [] + Opt_WarnUnusedTypePatterns -> "unused-type-patterns" :| [] + Opt_WarnUnusedRecordWildcards -> "unused-record-wildcards" :| [] + Opt_WarnRedundantBangPatterns -> "redundant-bang-patterns" :| [] + Opt_WarnRedundantRecordWildcards -> "redundant-record-wildcards" :| [] + Opt_WarnRedundantStrictnessFlags -> "redundant-strictness-flags" :| [] + Opt_WarnWrongDoBind -> "wrong-do-bind" :| [] + Opt_WarnMissingPatternSynonymSignatures -> "missing-pattern-synonym-signatures" :| [] + Opt_WarnMissingDerivingStrategies -> "missing-deriving-strategies" :| [] + Opt_WarnSimplifiableClassConstraints -> "simplifiable-class-constraints" :| [] + Opt_WarnMissingHomeModules -> "missing-home-modules" :| [] + Opt_WarnUnrecognisedWarningFlags -> "unrecognised-warning-flags" :| [] + Opt_WarnStarBinder -> "star-binder" :| [] + Opt_WarnStarIsType -> "star-is-type" :| [] + Opt_WarnSpaceAfterBang -> "missing-space-after-bang" :| [] + Opt_WarnPartialFields -> "partial-fields" :| [] + Opt_WarnPrepositiveQualifiedModule -> "prepositive-qualified-module" :| [] + Opt_WarnUnusedPackages -> "unused-packages" :| [] + Opt_WarnCompatUnqualifiedImports -> "compat-unqualified-imports" :| [] + Opt_WarnInvalidHaddock -> "invalid-haddock" :| [] + Opt_WarnOperatorWhitespaceExtConflict -> "operator-whitespace-ext-conflict" :| [] + Opt_WarnOperatorWhitespace -> "operator-whitespace" :| [] + Opt_WarnImplicitLift -> "implicit-lift" :| [] + Opt_WarnMissingExportedPatternSynonymSignatures -> "missing-exported-pattern-synonym-signatures" :| [] + Opt_WarnForallIdentifier -> "forall-identifier" :| [] + Opt_WarnUnicodeBidirectionalFormatCharacters -> "unicode-bidirectional-format-characters" :| [] + Opt_WarnGADTMonoLocalBinds -> "gadt-mono-local-binds" :| [] + Opt_WarnTypeEqualityOutOfScope -> "type-equality-out-of-scope" :| [] + Opt_WarnLoopySuperclassSolve -> "loopy-superclass-solve" :| [] + Opt_WarnTypeEqualityRequiresOperators -> "type-equality-requires-operators" :| [] + Opt_WarnMissingRoleAnnotations -> "missing-role-annotations" :| [] + Opt_WarnImplicitRhsQuantification -> "implicit-rhs-quantification" :| [] + Opt_WarnIncompleteExportWarnings -> "incomplete-export-warnings" :| [] + Opt_WarnIncompleteRecordSelectors -> "incomplete-record-selectors" :| [] + Opt_WarnBadlyLevelledTypes -> "badly-levelled-types" :| [] + Opt_WarnInconsistentFlags -> "inconsistent-flags" :| [] + Opt_WarnDataKindsTC -> "data-kinds-tc" :| [] + Opt_WarnDefaultedExceptionContext -> "defaulted-exception-context" :| [] + Opt_WarnViewPatternSignatures -> "view-pattern-signatures" :| [] + Opt_WarnUselessSpecialisations -> "useless-specialisations" :| ["useless-specializations"] + Opt_WarnDeprecatedPragmas -> "deprecated-pragmas" :| [] + Opt_WarnRuleLhsEqualities -> "rule-lhs-equalities" :| [] + Opt_WarnUnusableUnpackPragmas -> "unusable-unpack-pragmas" :| [] + Opt_WarnPatternNamespaceSpecifier -> "pattern-namespace-specifier" :| [] + +-- ----------------------------------------------------------------------------- +-- Standard sets of warning options + +-- Note [Documenting warning flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of warnings enabled by default +-- please remember to update the User's Guide. The relevant file is: +-- +-- docs/users_guide/using-warnings.rst + + +-- | A group of warning flags that can be enabled or disabled collectively, +-- e.g. using @-Wcompat@ to enable all warnings in the 'W_compat' group. +data WarningGroup = W_compat + | W_unused_binds + | W_extended_warnings + | W_default + | W_extra + | W_all + | W_everything + deriving (Bounded, Enum, Eq) + +warningGroupName :: WarningGroup -> String +warningGroupName W_compat = "compat" +warningGroupName W_unused_binds = "unused-binds" +warningGroupName W_extended_warnings = "extended-warnings" +warningGroupName W_default = "default" +warningGroupName W_extra = "extra" +warningGroupName W_all = "all" +warningGroupName W_everything = "everything" + +warningGroupFlags :: WarningGroup -> [WarningFlag] +warningGroupFlags W_compat = minusWcompatOpts +warningGroupFlags W_unused_binds = unusedBindsFlags +warningGroupFlags W_extended_warnings = [] +warningGroupFlags W_default = standardWarnings +warningGroupFlags W_extra = minusWOpts +warningGroupFlags W_all = minusWallOpts +warningGroupFlags W_everything = minusWeverythingOpts + +-- | Does this warning group contain (all) extended warning categories? See +-- Note [Warning categories] in GHC.Unit.Module.Warnings. +-- +-- The 'W_extended_warnings' group contains extended warnings but no +-- 'WarningFlag's, but extended warnings are also treated as part of 'W_default' +-- and every warning group that includes it. +warningGroupIncludesExtendedWarnings :: WarningGroup -> Bool +warningGroupIncludesExtendedWarnings W_compat = False +warningGroupIncludesExtendedWarnings W_unused_binds = False +warningGroupIncludesExtendedWarnings W_extended_warnings = True +warningGroupIncludesExtendedWarnings W_default = True +warningGroupIncludesExtendedWarnings W_extra = True +warningGroupIncludesExtendedWarnings W_all = True +warningGroupIncludesExtendedWarnings W_everything = True + +-- | Warning groups. +-- +-- As all warnings are in the 'W_everything' set, it is ignored when +-- displaying to the user which group a warning is in. +warningGroups :: [WarningGroup] +warningGroups = [minBound..maxBound] + +-- | Warning group hierarchies, where there is an explicit inclusion +-- relation. +-- +-- Each inner list is a hierarchy of warning groups, ordered from +-- smallest to largest, where each group is a superset of the one +-- before it. +-- +-- Separating this from 'warningGroups' allows for multiple +-- hierarchies with no inherent relation to be defined. +-- +-- The special-case 'W_everything' group is not included. +warningHierarchies :: [[WarningGroup]] +warningHierarchies = hierarchies ++ map (:[]) rest + where + hierarchies = [[W_default, W_extra, W_all]] + rest = filter (`notElem` W_everything : concat hierarchies) warningGroups + +-- | Find the smallest group in every hierarchy which a warning +-- belongs to, excluding Weverything. +smallestWarningGroups :: WarningFlag -> [WarningGroup] +smallestWarningGroups flag = mapMaybe go warningHierarchies where + -- Because each hierarchy is arranged from smallest to largest, + -- the first group we find in a hierarchy which contains the flag + -- is the smallest. + go (group:rest) = fromMaybe (go rest) $ do + guard (flag `elem` warningGroupFlags group) + pure (Just group) + go [] = Nothing + +-- | The smallest group in every hierarchy to which a custom warning +-- category belongs is currently always @-Wextended-warnings@. +-- See Note [Warning categories] in "GHC.Unit.Module.Warnings". +smallestWarningGroupsForCategory :: [WarningGroup] +smallestWarningGroupsForCategory = [W_extended_warnings] + +-- | Warnings enabled unless specified otherwise +standardWarnings :: [WarningFlag] +standardWarnings -- see Note [Documenting warning flags] + = [ Opt_WarnOverlappingPatterns, + Opt_WarnDeprecatedFlags, + Opt_WarnDeferredTypeErrors, + Opt_WarnTypedHoles, + Opt_WarnDeferredOutOfScopeVariables, + Opt_WarnPartialTypeSignatures, + Opt_WarnUnrecognisedPragmas, + Opt_WarnMisplacedPragmas, + Opt_WarnDuplicateExports, + Opt_WarnDerivingDefaults, + Opt_WarnOverflowedLiterals, + Opt_WarnEmptyEnumerations, + Opt_WarnAmbiguousFields, + Opt_WarnMissingFields, + Opt_WarnMissingMethods, + Opt_WarnWrongDoBind, + Opt_WarnUnsupportedCallingConventions, + Opt_WarnDodgyForeignImports, + Opt_WarnInlineRuleShadowing, + Opt_WarnAlternativeLayoutRuleTransitional, + Opt_WarnUnsupportedLlvmVersion, + Opt_WarnMissedExtraSharedLib, + Opt_WarnTabs, + Opt_WarnUnrecognisedWarningFlags, + Opt_WarnSimplifiableClassConstraints, + Opt_WarnStarBinder, + Opt_WarnStarIsType, + Opt_WarnInaccessibleCode, + Opt_WarnSpaceAfterBang, + Opt_WarnNonCanonicalMonadInstances, + Opt_WarnNonCanonicalMonoidInstances, + Opt_WarnOperatorWhitespaceExtConflict, + Opt_WarnUnicodeBidirectionalFormatCharacters, + Opt_WarnGADTMonoLocalBinds, + Opt_WarnBadlyLevelledTypes, + Opt_WarnTypeEqualityRequiresOperators, + Opt_WarnInconsistentFlags, + Opt_WarnTypeEqualityOutOfScope, + Opt_WarnImplicitRhsQuantification, -- was in -Wcompat since 9.8, enabled by default since 9.14, to turn into a hard error in 9.16 + Opt_WarnViewPatternSignatures, + Opt_WarnUselessSpecialisations, + Opt_WarnDeprecatedPragmas, + Opt_WarnRuleLhsEqualities, + Opt_WarnUnusableUnpackPragmas + ] + +-- | Things you get with @-W@. +minusWOpts :: [WarningFlag] +minusWOpts + = standardWarnings ++ + [ Opt_WarnUnusedTopBinds, + Opt_WarnUnusedLocalBinds, + Opt_WarnUnusedPatternBinds, + Opt_WarnUnusedMatches, + Opt_WarnUnusedForalls, + Opt_WarnUnusedImports, + Opt_WarnIncompletePatterns, + Opt_WarnDodgyExports, + Opt_WarnDodgyImports, + Opt_WarnUnbangedStrictPatterns + ] + +-- | Things you get with @-Wall@. +minusWallOpts :: [WarningFlag] +minusWallOpts + = minusWOpts ++ + [ Opt_WarnTypeDefaults, + Opt_WarnNameShadowing, + Opt_WarnMissingSignatures, + Opt_WarnHiShadows, + Opt_WarnOrphans, + Opt_WarnUnusedDoBind, + Opt_WarnTrustworthySafe, + Opt_WarnMissingPatternSynonymSignatures, + Opt_WarnUnusedRecordWildcards, + Opt_WarnRedundantRecordWildcards, + Opt_WarnIncompleteUniPatterns, + Opt_WarnIncompletePatternsRecUpd, + Opt_WarnIncompleteExportWarnings, + Opt_WarnIncompleteRecordSelectors, + Opt_WarnDerivingTypeable + ] + +-- | Things you get with @-Weverything@, i.e. *all* known warnings flags. +minusWeverythingOpts :: [WarningFlag] +minusWeverythingOpts = [ toEnum 0 .. ] + +-- | Things you get with @-Wcompat@. +-- +-- This is intended to group together warnings that will be enabled by default +-- at some point in the future, so that library authors eager to make their +-- code future compatible to fix issues before they even generate warnings. +minusWcompatOpts :: [WarningFlag] +minusWcompatOpts + = [ Opt_WarnPatternNamespaceSpecifier + ] + +-- | Things you get with @-Wunused-binds@. +unusedBindsFlags :: [WarningFlag] +unusedBindsFlags = [ Opt_WarnUnusedTopBinds + , Opt_WarnUnusedLocalBinds + , Opt_WarnUnusedPatternBinds + ] diff --git a/GHC/Driver/GenerateCgIPEStub.hs b/GHC/Driver/GenerateCgIPEStub.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/GenerateCgIPEStub.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} + +module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Semigroup ((<>)) +import GHC.Cmm +import GHC.Cmm.CLabel (CLabel, mkAsmTempLabel) +import GHC.Cmm.Dataflow (O) +import GHC.Cmm.Dataflow.Block (blockSplit, blockToList) +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Info.Build (emptySRT) +import GHC.Cmm.Pipeline (cmmPipeline) +import GHC.Data.Stream (liftIO, liftEff) +import qualified GHC.Data.Stream as Stream +import GHC.Driver.Env (hsc_dflags, hsc_logger) +import GHC.Driver.Env.Types (HscEnv) +import GHC.Driver.Flags (GeneralFlag (..), DumpFlag(Opt_D_ipe_stats)) +import GHC.Driver.DynFlags (gopt, targetPlatform) +import GHC.Driver.Config.StgToCmm +import GHC.Driver.Config.Cmm ( initCmmConfig ) +import GHC.Prelude +import GHC.Runtime.Heap.Layout (isStackRep) +import GHC.Settings (platformTablesNextToCode) +import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState) +import GHC.StgToCmm.Prof (initInfoTableProv) +import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos) +import GHC.StgToCmm.Utils +import GHC.StgToCmm.CgUtils (CgStream) +import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation) +import GHC.Types.Name.Set (NonCaffySet) +import GHC.Types.Tickish (GenTickish (SourceNote)) +import GHC.Unit.Types (Module, moduleName) +import GHC.Unit.Module (moduleNameString) +import qualified GHC.Utils.Logger as Logger +import GHC.Utils.Outputable (ppr) +import GHC.Types.Unique.DSM + +{- +Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Stacktraces can be created from return frames as they are pushed to stack for every case scrutinee. +But to make them readable / meaningful, one needs to know the source location of each return frame. + +Every return frame has a distinct info table and thus a distinct code pointer (for tables next to +code) or at least a distinct address itself. Info Table Provenance Entries (IPEs) are searchable by +this pointer and contain a source location. + +The info table / info table code pointer to source location map is described in: +Note [Mapping Info Tables to Source Positions] + +To be able to lookup IPEs for return frames one needs to emit them during compile time. This is done +by `generateCgIPEStub`. + +This leads to the question: How to figure out the source location of a return frame? + +The algorithm for determining source locations for stack info tables is implemented in +`lookupEstimatedTicks` as two passes over every 'CmmGroupSRTs'. The first pass generates estimated +source locations for any labels potentially corresponding to stack info tables in the Cmm code. The +second pass walks over the Cmm decls and creates an entry in the IPE map for every info table, +looking up source locations for stack info tables in the map generated during the first pass. + +The rest of this note will document exactly how the first pass generates the map from labels to +estimated source positions. The algorithms are different depending on whether tables-next-to-code +is on or off. Both algorithms have in common that we are looking for a `CmmNode.CmmTick` +(containing a `SourceNote`) that is near what we estimate to be the label of a return stack frame. + +With tables-next-to-code +~~~~~~~~~~~~~~~~~~~~~~~~ + +Let's consider this example: +``` + Main.returnFrame_entry() { // [R2] + { info_tbls: [(c18g, + label: block_c18g_info + rep: StackRep [] + srt: Just GHC.CString.unpackCString#_closure), + (c18r, + label: Main.returnFrame_info + rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} } + srt: Nothing)] + stack_info: arg_space: 8 + } + {offset + + [...] + + c18u: // global + //tick src + I64[Hp - 16] = sat_s16B_info; + P64[Hp] = _s16r::P64; + _c17j::P64 = Hp - 16; + //tick src + 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`). + +In code the Cmm program is represented as a Hoopl graph. Hoopl distinguishes nodes by defining if they +are open or closed on entry (one can fallthrough to them from the previous instruction) and if they are +open or closed on exit (one can fallthrough from them to the next node). + +Please refer to the paper "Hoopl: A Modular, Reusable Library for Dataflow Analysis and Transformation" +for a detailed explanation. + +Here we use the fact, that calls (represented by `CmmNode.CmmCall`) are always closed on exit +(`CmmNode O C`, `O` means open, `C` closed). In other words, they are always at the end of a block. + +So, given a `CmmGraph`: + - Look at the end of every block: If it is a `CmmNode.CmmCall` returning to some label, lookup + the nearest `CmmNode.CmmTick` by traversing the middle part of the block backwards (from end to + beginning). + - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and map the label we + found to it's payload as an `IpeSourceLocation`. (There are other `Tickish` constructors like + `ProfNote` or `HpcTick`, these are ignored.) + +See `labelsToSourcesWithTNTC` for the implementation of this algorithm. + +Without tables-next-to-code +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When tables-next-to-code is off, there is no return frame / continuation label in calls. The continuation (i.e. return +frame) is set in an explicit Cmm assignment. Thus the tick lookup algorithm has to be slightly different. + +``` + sat_s16G_entry() { // [R1] + { info_tbls: [(c18O, + label: sat_s16G_info + rep: HeapRep { Thunk } + srt: Just _u18Z_srt)] + stack_info: arg_space: 0 + } + {offset + c18O: // global + _s16G::P64 = R1; + if ((Sp + 8) - 40 < SpLim) (likely: False) goto c18P; else goto c18Q; + c18P: // global + R1 = _s16G::P64; + call (stg_gc_enter_1)(R1) args: 8, res: 0, upd: 8; + c18Q: // global + I64[Sp - 16] = stg_upd_frame_info; + P64[Sp - 8] = _s16G::P64; + //tick src + 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` for the return frame `c18M`. +Notice, that this cannot be done with the `Label` `c18M`, but with the `CLabel` `block_c18M_info` +(`label: block_c18M_info` is actually a `CLabel`). + +Given a `CmmGraph`: + - Check every `CmmBlock` from top (first) to bottom (last). + - If a `CmmTick` holding a `SourceNote` is found, remember the source location in the tick. + - If an assignment of the form `... = block_c18M_info;` (a `CmmStore` whose RHS is a + `CmmLit (CmmLabel l)`) is found, map that label to the most recently visited source note's + location. + +See `labelsToSourcesSansTNTC` for the implementation of this algorithm. +-} + +generateCgIPEStub + :: HscEnv + -> Module + -> InfoTableProvMap + -- ^ If the CmmInfoTables map refer Cmm symbols which were deterministically renamed, the info table provenance map must also be accordingly renamed. + -> ( NonCaffySet + , ModuleLFInfos + , Map CmmInfoTable (Maybe IpeSourceLocation) + , IPEStats + ) + -> CgStream CmmGroupSRTs CmmCgInfos +generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesWithTickishes, initStats) = do + let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + logger = hsc_logger hsc_env + fstate = initFCodeState platform + cmm_cfg = initCmmConfig dflags + cgState <- liftIO initC + + -- NB: For determinism, don't use DetUniqFM to rename the IPE Cmm because + -- detRenameCmm isn't idempotent and this Cmm references symbols in the rest + -- of the code! Instead, make sure all labels generated for IPE related code + -- sources uniques from the DUniqSupply gotten from CgStream (see its use in + -- initInfoTableProv/emitIpeBufferListNode). + (mIpeStub, ipeCmmGroup) <- liftEff $ UDSMT $ \dus -> do + + -- Yield Cmm for Info Table Provenance Entries (IPEs) + let denv' = denv {provInfoTables = Map.mapKeys cit_lbl infoTablesWithTickishes} + (((mIpeStub, dus'), ipeCmmGroup), _) = + runC (initStgToCmmConfig dflags this_mod) fstate cgState $ + getCmm (initInfoTableProv initStats (Map.keys infoTablesWithTickishes) denv' dus) + + return ((mIpeStub, ipeCmmGroup), dus') + + (_, ipeCmmGroupSRTs) <- liftEff $ withDUS $ cmmPipeline logger cmm_cfg (emptySRT this_mod) (removeDeterm ipeCmmGroup) + Stream.yield ipeCmmGroupSRTs + + ipeStub <- + case mIpeStub of + Just (stats, stub) -> do + -- Print ipe stats if requested + liftIO $ + Logger.putDumpFileMaybe logger + Opt_D_ipe_stats + ("IPE Stats for module " ++ (moduleNameString $ moduleName this_mod)) + Logger.FormatText + (ppr stats) + return stub + Nothing -> return mempty + + return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub} + +-- | Given: +-- * an initial mapping from info tables to possible source locations, +-- * initial 'IPEStats', +-- * a 'CmmGroupSRTs', +-- +-- map every info table listed in the 'CmmProc's of the group to their possible +-- source locations and update 'IPEStats' for skipped stack info tables (in case +-- both -finfo-table-map and -fno-info-table-map-with-stack were given). See: +-- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] +-- +-- Note: While it would be cleaner if we could keep the recursion and +-- accumulation internal to this function, this cannot be done without +-- separately traversing stream of 'CmmGroupSRTs' in 'GHC.Driver.Main'. The +-- initial implementation of this logic did such a thing, and code generation +-- performance suffered considerably as a result (see #23103). +lookupEstimatedTicks + :: HscEnv + -> Map CmmInfoTable (Maybe IpeSourceLocation) + -> IPEStats + -> CmmGroupSRTs + -> IO (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) +lookupEstimatedTicks hsc_env ipes stats cmm_group_srts = + -- Pass 2: Create an entry in the IPE map for every info table listed in + -- this CmmGroupSRTs. If the info table is a stack info table and + -- -finfo-table-map-with-stack is enabled, look up its estimated source + -- location in the map generate during Pass 1. If the info table is a stack + -- info table and -finfo-table-map-with-stack is not enabled, skip the table + -- and note it as skipped in the IPE stats. If the info table is not a stack + -- info table, insert into the IPE map with no source location information + -- (for now; see `convertInfoProvMap` in GHC.StgToCmm.Utils to see how source + -- locations for these tables get filled in) + pure $ foldl' collectInfoTables (ipes, stats) cmm_group_srts + where + dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + + -- Pass 1: Map every label meeting the conditions described in Note + -- [Stacktraces from Info Table Provenance Entries (IPE based stack + -- unwinding)] to the estimated source location (also as described in the + -- aformentioned note) + -- + -- Note: It's important that this remains a thunk so we do not compute this + -- map if -fno-info-table-with-stack is given + labelsToSources :: Map CLabel IpeSourceLocation + labelsToSources = + if platformTablesNextToCode platform then + foldl' labelsToSourcesWithTNTC Map.empty cmm_group_srts + else + foldl' labelsToSourcesSansTNTC Map.empty cmm_group_srts + + collectInfoTables + :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) + -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph + -> (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) + collectInfoTables (!acc, !stats) (CmmProc h _ _ _) = + mapFoldlWithKey go (acc, stats) (info_tbls h) + where + go :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) + -> Label + -> CmmInfoTable + -> (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) + go (!acc, !stats) lbl' tbl = + let + lbl = + if platformTablesNextToCode platform then + -- TNTC case, the mapped CLabel will be the result of + -- mkAsmTempLabel on the info table label + mkAsmTempLabel lbl' + else + -- Non-TNTC case, the mapped CLabel will be the CLabel of the + -- info table itself + cit_lbl tbl + in + if (isStackRep . cit_rep) tbl then + if gopt Opt_InfoTableMapWithStack dflags then + -- This is a stack info table and we DO want to put it in the + -- info table map + (Map.insert tbl (Map.lookup lbl labelsToSources) acc, stats) + else + -- This is a stack info table but we DO NOT want to put it in + -- the info table map (-fno-info-table-map-with-stack was + -- given), track it as skipped + (acc, stats <> skippedIpeStats) + else + -- This is not a stack info table, so put it in the map with no + -- source location (for now) + (Map.insert tbl Nothing acc, stats) + collectInfoTables (!acc, !stats) _ = (acc, stats) + +-- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] +labelsToSourcesWithTNTC + :: Map CLabel IpeSourceLocation + -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph + -> Map CLabel IpeSourceLocation +labelsToSourcesWithTNTC acc (CmmProc _ _ _ cmm_graph) = + foldl' go acc (toBlockList cmm_graph) + where + go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation + go acc block = + case (,) <$> returnFrameLabel <*> lastTickInBlock of + Just (clabel, src_loc) -> Map.insert clabel src_loc acc + Nothing -> acc + where + (_, middleBlock, endBlock) = blockSplit block + + returnFrameLabel :: Maybe CLabel + returnFrameLabel = + case endBlock of + (CmmCall _ (Just l) _ _ _ _) -> Just $ mkAsmTempLabel l + _ -> Nothing + + lastTickInBlock = foldr maybeTick Nothing (blockToList middleBlock) + + maybeTick :: CmmNode O O -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation + maybeTick _ s@(Just _) = s + maybeTick (CmmTick (SourceNote span name)) Nothing = Just (span, name) + maybeTick _ _ = Nothing +labelsToSourcesWithTNTC acc _ = acc + +-- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] +labelsToSourcesSansTNTC + :: Map CLabel IpeSourceLocation + -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph + -> Map CLabel IpeSourceLocation +labelsToSourcesSansTNTC acc (CmmProc _ _ _ cmm_graph) = + foldl' go acc (toBlockList cmm_graph) + where + go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation + go acc block = fst $ foldl' collectLabels (acc, Nothing) (blockToList middleBlock) + where + (_, middleBlock, _) = blockSplit block + + collectLabels + :: (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation) + -> CmmNode O O + -> (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation) + collectLabels (!acc, lastTick) b = + case (b, lastTick) of + (CmmStore _ (CmmLit (CmmLabel l)) _, Just src_loc) -> + (Map.insert l src_loc acc, Nothing) + (CmmTick (SourceNote span name), _) -> + (acc, Just (span, name)) + _ -> (acc, lastTick) +labelsToSourcesSansTNTC acc _ = acc diff --git a/GHC/Driver/Hooks.hs b/GHC/Driver/Hooks.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Hooks.hs @@ -0,0 +1,160 @@ +-- \section[Hooks]{Low level API hooks} + +-- NB: this module is SOURCE-imported by DynFlags, and should primarily +-- refer to *types*, rather than *code* + +{-# LANGUAGE RankNTypes, TypeFamilies #-} + +module GHC.Driver.Hooks + ( Hooks + , HasHooks (..) + , ContainsHooks (..) + , emptyHooks + -- the hooks: + , DsForeignsHook + , dsForeignsHook + , tcForeignImportsHook + , tcForeignExportsHook + , hscFrontendHook + , hscCompileCoreExprHook + , ghcPrimIfaceHook + , runPhaseHook + , runMetaHook + , linkHook + , runRnSpliceHook + , getValueSafelyHook + , createIservProcessHook + , stgToCmmHook + , cmmToRawCmmHook + ) +where + +import GHC.Prelude + +import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Driver.Pipeline.Phases + +import GHC.Hs.Decls +import GHC.Hs.Binds +import GHC.Hs.Expr +import GHC.Hs.Extension + +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.CostCentre +import GHC.Types.IPE +import GHC.Types.Meta + +import GHC.Unit.Module +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Unit.Home.PackageTable + +import GHC.Core +import GHC.Core.TyCon +import GHC.Core.Type + +import GHC.Tc.Types +import GHC.Stg.Syntax +import GHC.StgToCmm.CgUtils (CgStream) +import GHC.StgToCmm.Types (ModuleLFInfos) +import GHC.StgToCmm.Config +import GHC.Cmm + +import GHCi.RemoteTypes + +import GHC.Data.Bag + +import qualified Data.Kind +import System.Process +import GHC.Linker.Types + +{- +************************************************************************ +* * +\subsection{Hooks} +* * +************************************************************************ +-} + +-- | Hooks can be used by GHC API clients to replace parts of +-- the compiler pipeline. If a hook is not installed, GHC +-- uses the default built-in behaviour + +emptyHooks :: Hooks +emptyHooks = Hooks + { dsForeignsHook = Nothing + , tcForeignImportsHook = Nothing + , tcForeignExportsHook = Nothing + , hscFrontendHook = Nothing + , hscCompileCoreExprHook = Nothing + , ghcPrimIfaceHook = Nothing + , runPhaseHook = Nothing + , runMetaHook = Nothing + , linkHook = Nothing + , runRnSpliceHook = Nothing + , getValueSafelyHook = Nothing + , createIservProcessHook = Nothing + , stgToCmmHook = Nothing + , cmmToRawCmmHook = Nothing + } + +{- Note [The Decoupling Abstract Data Hack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "Abstract Data" idea is due to Richard Eisenberg in +https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1957, where the pattern is +described in more detail. + +Here we use it as a temporary measure to break the dependency from the Parser on +the Desugarer until the parser is free of DynFlags. We introduced a nullary type +family @DsForeignsook@, whose single definition is in GHC.HsToCore.Types, where +we instantiate it to + + [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)) + +In doing so, the Hooks module (which is an hs-boot dependency of DynFlags) can +be decoupled from its use of the DsM definition in GHC.HsToCore.Types. Since +both DsM and the definition of @ForeignsHook@ live in the same module, there is +virtually no difference for plugin authors that want to write a foreign hook. + +An awkward consequences is that the `type instance DsForeignsHook`, in +GHC.HsToCore.Types is an orphan instance. +-} + +-- See Note [The Decoupling Abstract Data Hack] +type family DsForeignsHook :: Data.Kind.Type + +data Hooks = Hooks + { dsForeignsHook :: !(Maybe DsForeignsHook) + -- ^ Actual type: + -- @Maybe ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))@ + , tcForeignImportsHook :: !(Maybe ([LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))) + , tcForeignExportsHook :: !(Maybe ([LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))) + , hscFrontendHook :: !(Maybe (ModSummary -> Hsc FrontendResult)) + , hscCompileCoreExprHook :: !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded))) + , ghcPrimIfaceHook :: !(Maybe ModIface) + , runPhaseHook :: !(Maybe PhaseHook) + , runMetaHook :: !(Maybe (MetaHook TcM)) + , linkHook :: !(Maybe (GhcLink -> DynFlags -> Bool + -> HomePackageTable -> IO SuccessFlag)) + , runRnSpliceHook :: !(Maybe (HsUntypedSplice GhcRn -> RnM (HsUntypedSplice GhcRn))) + , getValueSafelyHook :: !(Maybe (HscEnv -> Name -> Type + -> IO (Either Type (HValue, [Linkable], PkgsLoaded)))) + , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) + , stgToCmmHook :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs + -> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos)) + , cmmToRawCmmHook :: !(forall a . Maybe (DynFlags -> Maybe Module -> CgStream CmmGroupSRTs a + -> IO (CgStream RawCmmGroup a))) + } + +class HasHooks m where + getHooks :: m Hooks + +class ContainsHooks a where + extractHooks :: a -> Hooks diff --git a/GHC/Driver/Hooks.hs-boot b/GHC/Driver/Hooks.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Driver/Hooks.hs-boot @@ -0,0 +1,13 @@ +module GHC.Driver.Hooks where + +import GHC.Prelude () + +data Hooks + +emptyHooks :: Hooks + +class HasHooks m where + getHooks :: m Hooks + +class ContainsHooks a where + extractHooks :: a -> Hooks diff --git a/GHC/Driver/IncludeSpecs.hs b/GHC/Driver/IncludeSpecs.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/IncludeSpecs.hs @@ -0,0 +1,48 @@ +module GHC.Driver.IncludeSpecs + ( IncludeSpecs(..) + , addGlobalInclude + , addQuoteInclude + , addImplicitQuoteInclude + , flattenIncludes + ) where + +import GHC.Prelude + +-- | Used to differentiate the scope an include needs to apply to. +-- We have to split the include paths to avoid accidentally forcing recursive +-- includes since -I overrides the system search paths. See #14312. +data IncludeSpecs + = IncludeSpecs { includePathsQuote :: [String] + , includePathsGlobal :: [String] + -- | See Note [Implicit include paths] + , includePathsQuoteImplicit :: [String] + } + deriving Show + +-- | Append to the list of includes a path that shall be included using `-I` +-- when the C compiler is called. These paths override system search paths. +addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addGlobalInclude spec paths = let f = includePathsGlobal spec + in spec { includePathsGlobal = f ++ paths } + +-- | Append to the list of includes a path that shall be included using +-- `-iquote` when the C compiler is called. These paths only apply when quoted +-- includes are used. e.g. #include "foo.h" +addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addQuoteInclude spec paths = let f = includePathsQuote spec + in spec { includePathsQuote = f ++ paths } + +-- | These includes are not considered while fingerprinting the flags for iface +-- | See Note [Implicit include paths] +addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addImplicitQuoteInclude spec paths = let f = includePathsQuoteImplicit spec + in spec { includePathsQuoteImplicit = f ++ paths } + + +-- | Concatenate and flatten the list of global and quoted includes returning +-- just a flat list of paths. +flattenIncludes :: IncludeSpecs -> [String] +flattenIncludes specs = + includePathsQuote specs ++ + includePathsQuoteImplicit specs ++ + includePathsGlobal specs diff --git a/GHC/Driver/LlvmConfigCache.hs b/GHC/Driver/LlvmConfigCache.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/LlvmConfigCache.hs @@ -0,0 +1,26 @@ +-- | LLVM config cache +module GHC.Driver.LlvmConfigCache + ( LlvmConfigCache + , initLlvmConfigCache + , readLlvmConfigCache + ) +where + +import GHC.Prelude +import GHC.CmmToLlvm.Config + +import System.IO.Unsafe + +-- | Cache LLVM configuration read from files in top_dir +-- +-- See Note [LLVM configuration] in GHC.CmmToLlvm.Config +-- +-- Currently implemented with unsafe lazy IO. But it could be implemented with +-- an IORef as the exposed interface is in IO. +data LlvmConfigCache = LlvmConfigCache LlvmConfig + +initLlvmConfigCache :: FilePath -> IO LlvmConfigCache +initLlvmConfigCache top_dir = pure $ LlvmConfigCache (unsafePerformIO $ initLlvmConfig top_dir) + +readLlvmConfigCache :: LlvmConfigCache -> IO LlvmConfig +readLlvmConfigCache (LlvmConfigCache !config) = pure config diff --git a/GHC/Driver/Main.hs b/GHC/Driver/Main.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Main.hs @@ -0,0 +1,2917 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -fprof-auto-top #-} + +------------------------------------------------------------------------------- +-- +-- | Main API for compiling plain Haskell source code. +-- +-- This module implements compilation of a Haskell source. It is +-- /not/ concerned with preprocessing of source files; this is handled +-- in "GHC.Driver.Pipeline" +-- +-- There are various entry points depending on what mode we're in: +-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and +-- "interactive" mode (GHCi). There are also entry points for +-- individual passes: parsing, typechecking/renaming, desugaring, and +-- simplification. +-- +-- All the functions here take an 'HscEnv' as a parameter, but none of +-- them return a new one: 'HscEnv' is treated as an immutable value +-- from here on in (although it has mutable components, for the +-- caches). +-- +-- We use the Hsc monad to deal with warning messages consistently: +-- specifically, while executing within an Hsc monad, warnings are +-- collected. When a Hsc monad returns to an IO monad, the +-- warnings are printed, or compilation aborts if the @-Werror@ +-- flag is enabled. +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 +-- +------------------------------------------------------------------------------- + +module GHC.Driver.Main + ( + -- * Making an HscEnv + newHscEnv + , newHscEnvWithHUG + , initHscEnv + + -- * Compiling complete source files + , Messager, batchMsg, batchMultiMsg + , HscBackendAction (..), HscRecompStatus (..) + , initModDetails + , initWholeCoreBindings + , loadIfaceByteCode + , loadIfaceByteCodeLazy + , hscMaybeWriteIface + , hscCompileCmmFile + + , hscGenHardCode + , hscInteractive + , mkCgInteractiveGuts + , CgInteractiveGuts + , generateByteCode + , generateFreshByteCode + + -- * Running passes separately + , hscRecompStatus + , hscParse + , hscTypecheckRename + , hscTypecheckRenameWithDiagnostics + , hscTypecheckAndGetWarnings + , hscDesugar + , makeSimpleDetails + , hscSimplify -- ToDo, shouldn't really export this + , hscDesugarAndSimplify + + -- * Safe Haskell + , hscCheckSafe + , hscGetSafe + + -- * Support for interactive evaluation + , hscParseIdentifier + , hscTcRcLookupName + , hscTcRnGetInfo + , hscIsGHCiMonad + , hscGetModuleInterface + , hscRnImportDecls + , hscTcRnLookupRdrName + , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt + , hscParseDeclsWithLocation, hscParsedDecls + , hscParseModuleWithLocation + , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType + , hscParseExpr + , hscParseType + , hscCompileCoreExpr + , hscTidy + + + -- * Low-level exports for hooks + , hscCompileCoreExpr' + -- We want to make sure that we export enough to be able to redefine + -- hsc_typecheck in client code + , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen + , getHscEnv + , hscSimpleIface' + , oneShotMsg + , dumpIfaceStats + , ioMsgMaybe + , showModuleIndex + , hscAddSptEntries + , writeInterfaceOnlyMode + , loadByteCode + , genModDetails + ) where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Driver.Plugins +import GHC.Driver.Session +import GHC.Driver.Backend +import GHC.Driver.Env +import GHC.Driver.Env.KnotVars +import GHC.Driver.Errors +import GHC.Driver.Messager +import GHC.Driver.Errors.Types +import GHC.Driver.CodeOutput +import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig) +import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyExprOpts ) +import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO ) +import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr ) +import GHC.Driver.Config.CoreToStg +import GHC.Driver.Config.CoreToStg.Prep +import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Stg.Ppr (initStgPprOpts) +import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts) +import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) +import GHC.Driver.Config.Cmm (initCmmConfig) +import GHC.Driver.LlvmConfigCache (initLlvmConfigCache) +import GHC.Driver.Config.StgToJS (initStgToJSConfig) +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Tidy +import GHC.Driver.Hooks +import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) + +import GHC.Runtime.Context +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.JS +import GHC.Runtime.Loader ( initializePlugins ) +import GHCi.RemoteTypes +import GHC.ByteCode.Types + +import GHC.Linker.Loader +import GHC.Linker.Types +import GHC.Linker.Deps + +import GHC.Hs +import GHC.Hs.Dump +import GHC.Hs.Stats ( ppSourceStats ) + +import GHC.HsToCore + +import GHC.StgToByteCode ( byteCodeGen ) +import GHC.StgToJS ( stgToJS ) +import GHC.StgToJS.Ids +import GHC.StgToJS.Types +import GHC.JS.Syntax + +import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings ) + +import GHC.Iface.Load ( ifaceStats, writeIface, flagsToIfCompression, getGhcPrimIface ) +import GHC.Iface.Make +import GHC.Iface.Recomp +import GHC.Iface.Tidy +import GHC.Iface.Ext.Ast ( mkHieFile ) +import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) +import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result) +import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) + +import GHC.Core +import GHC.Core.Lint.Interactive ( interactiveInScope ) +import GHC.Core.Tidy ( tidyExpr ) +import GHC.Core.Utils ( exprType ) +import GHC.Core.ConLike +import GHC.Core.Opt.Pipeline +import GHC.Core.Opt.Pipeline.Types ( CoreToDo (..)) +import GHC.Core.TyCon +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Core.Rules +import GHC.Core.Stats +import GHC.Core.LateCC +import GHC.Core.LateCC.Types + + +import GHC.CoreToStg.Prep( CorePrepPgmConfig, corePrepPgm, corePrepExpr ) +import GHC.CoreToStg.AddImplicitBinds( addImplicitBinds ) +import GHC.CoreToStg ( coreToStg ) + +import GHC.Parser.Errors.Types +import GHC.Parser +import GHC.Parser.Lexer as Lexer + +import GHC.Tc.Module +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.Env ( ZonkFlexi (DefaultFlexi) ) + +import GHC.Stg.Syntax +import GHC.Stg.Pipeline ( stg2stg, StgCgInfos ) + +import GHC.Builtin.Names + +import qualified GHC.StgToCmm as StgToCmm ( codeGen ) +import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos, LambdaFormInfo(..)) +import GHC.StgToCmm.CgUtils (CgStream) + +import GHC.Cmm +import GHC.Cmm.Info.Build +import GHC.Cmm.Pipeline +import GHC.Cmm.Info +import GHC.Cmm.Parser +import GHC.Cmm.UniqueRenamer + +import GHC.Unit +import GHC.Unit.Env +import GHC.Unit.Finder +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Graph +import GHC.Unit.Module.Imported +import GHC.Unit.Module.Deps +import GHC.Unit.Module.Status +import GHC.Unit.Home.ModInfo + +import GHC.Types.Id +import GHC.Types.SourceError +import GHC.Types.SafeHaskell +import GHC.Types.ForeignStubs +import GHC.Types.Name.Env ( mkNameEnv ) +import GHC.Types.Var.Env ( mkEmptyTidyEnv ) +import GHC.Types.Var.Set +import GHC.Types.Error +import GHC.Types.Fixity.Env +import GHC.Types.CostCentre +import GHC.Types.IPE +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Types.Name +import GHC.Types.Name.Cache ( newNameCache ) +import GHC.Types.Name.Reader +import GHC.Types.Name.Ppr +import GHC.Types.TyThing +import GHC.Types.Unique.Supply (uniqFromTag) +import GHC.Types.Unique.Set + +import GHC.Utils.Fingerprint ( Fingerprint ) +import GHC.Utils.Panic +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Utils.Touch + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Data.OsPath (unsafeEncodeUtf) +import GHC.Data.StringBuffer +import qualified GHC.Data.Stream as Stream +import GHC.Data.Maybe + +import GHC.SysTools (initSysTools) +import GHC.SysTools.BaseDir (findTopDir) + +import Data.Data hiding (Fixity, TyCon) +import Data.Functor ((<&>)) +import Data.List ( nub, isPrefixOf, partition ) +import qualified Data.List.NonEmpty as NE +import Control.Monad +import Data.IORef +import System.FilePath as FilePath +import System.Directory +import qualified Data.Map as M +import Data.Map (Map) +import qualified Data.Set as S +import Data.Set (Set) +import Control.DeepSeq (force) +import Data.List.NonEmpty (NonEmpty ((:|))) +import GHC.Unit.Module.WholeCoreBindings +import GHC.Types.TypeEnv +import System.IO +import {-# SOURCE #-} GHC.Driver.Pipeline +import Data.Time + +import System.IO.Unsafe ( unsafeInterleaveIO ) +import GHC.Iface.Env ( trace_if ) +import GHC.Platform.Ways +import GHC.Stg.EnforceEpt.TagSig (seqTagSig) +import GHC.StgToCmm.Utils (IPEStats) +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Cmm.Config (CmmConfig) +import Data.Bifunctor +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Home.PackageTable + +{- ********************************************************************** +%* * + Initialisation +%* * +%********************************************************************* -} + +newHscEnv :: FilePath -> DynFlags -> IO HscEnv +newHscEnv top_dir dflags = do + hpt <- emptyHomePackageTable + newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt) + where + home_unit_graph hpt = HUG.unitEnv_singleton + (homeUnitId_ dflags) + (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt Nothing) + +newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv +newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do + nc_var <- newNameCache + fc_var <- initFinderCache + logger <- initLogger + tmpfs <- initTmpFs + let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup cur_unit home_unit_graph + unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags) + llvm_config <- initLlvmConfigCache top_dir + return HscEnv { hsc_dflags = top_dynflags + , hsc_logger = setLogFlags logger (initLogFlags top_dynflags) + , hsc_targets = [] + , hsc_IC = emptyInteractiveContext dflags + , hsc_NC = nc_var + , hsc_FC = fc_var + , hsc_type_env_vars = emptyKnotVars + , hsc_interp = Nothing + , hsc_unit_env = unit_env + , hsc_plugins = emptyPlugins + , hsc_hooks = emptyHooks + , hsc_tmpfs = tmpfs + , hsc_llvm_config = llvm_config + } + +-- | Initialize HscEnv from an optional top_dir path +initHscEnv :: Maybe FilePath -> IO HscEnv +initHscEnv mb_top_dir = do + top_dir <- findTopDir mb_top_dir + mySettings <- initSysTools top_dir + dflags <- initDynFlags (defaultDynFlags mySettings) + hsc_env <- newHscEnv top_dir dflags + setUnsafeGlobalDynFlags dflags + -- c.f. DynFlags.parseDynamicFlagsFull, which + -- creates DynFlags and sets the UnsafeGlobalDynFlags + return hsc_env + +-- ----------------------------------------------------------------------------- + +getDiagnostics :: Hsc (Messages GhcMessage) +getDiagnostics = Hsc $ \_ w -> return (w, w) + +clearDiagnostics :: Hsc () +clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages) + +logDiagnostics :: Messages GhcMessage -> Hsc () +logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w) + +getHscEnv :: Hsc HscEnv +getHscEnv = Hsc $ \e w -> return (e, w) + +handleWarnings :: Hsc () +handleWarnings = do + diag_opts <- initDiagOpts <$> getDynFlags + print_config <- initPrintConfig <$> getDynFlags + logger <- getLogger + w <- getDiagnostics + liftIO $ printOrThrowDiagnostics logger print_config diag_opts w + clearDiagnostics + +-- | log warning in the monad, and if there are errors then +-- throw a SourceError exception. +logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc () +logWarningsReportErrors (warnings,errors) = do + logDiagnostics (GhcPsMessage <$> warnings) + when (not $ isEmptyMessages errors) $ throwErrors (GhcPsMessage <$> errors) + +-- | Log warnings and throw errors, assuming the messages +-- contain at least one error (e.g. coming from PFailed) +handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a +handleWarningsThrowErrors (warnings, errors) = do + diag_opts <- initDiagOpts <$> getDynFlags + logDiagnostics (GhcPsMessage <$> warnings) + logger <- getLogger + let (wWarns, wErrs) = partitionMessages warnings + liftIO $ printMessages logger NoDiagnosticOpts diag_opts wWarns + throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs + +-- | Deal with errors and warnings returned by a compilation step +-- +-- In order to reduce dependencies to other parts of the compiler, functions +-- outside the "main" parts of GHC return warnings and errors as a parameter +-- and signal success via by wrapping the result in a 'Maybe' type. This +-- function logs the returned warnings and propagates errors as exceptions +-- (of type 'SourceError'). +-- +-- This function assumes the following invariants: +-- +-- 1. If the second result indicates success (is of the form 'Just x'), +-- there must be no error messages in the first result. +-- +-- 2. If there are no error messages, but the second result indicates failure +-- there should be warnings in the first result. That is, if the action +-- failed, it must have been due to the warnings (i.e., @-Werror@). +ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a +ioMsgMaybe ioA = do + (msgs, mb_r) <- liftIO ioA + let (warns, errs) = partitionMessages msgs + logDiagnostics warns + case mb_r of + Nothing -> throwErrors errs + Just r -> assert (isEmptyMessages errs ) return r + +-- | like ioMsgMaybe, except that we ignore error messages and return +-- 'Nothing' instead. +ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' ioA = do + (msgs, mb_r) <- liftIO $ ioA + logDiagnostics (mkMessages $ getWarningMessages msgs) + return mb_r + +-- ----------------------------------------------------------------------------- +-- | Lookup things in the compiler's environment + +hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name) +hscTcRnLookupRdrName hsc_env0 rdr_name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + -- tcRnLookupRdrName can return empty list only together with TcRnUnknownMessage. + -- Once errors has been dealt with in hoistTcRnMessage, we can enforce + -- this invariant in types by converting to NonEmpty. + ; ioMsgMaybe $ fmap (fmap (>>= NE.nonEmpty)) $ hoistTcRnMessage $ + tcRnLookupRdrName hsc_env rdr_name } + +hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name + -- ignore errors: the only error we're likely to get is + -- "name not found", and the Maybe in the return type + -- is used to indicate that. + +hscTcRnGetInfo :: HscEnv -> Name + -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) +hscTcRnGetInfo hsc_env0 name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name } + +hscIsGHCiMonad :: HscEnv -> String -> IO Name +hscIsGHCiMonad hsc_env name + = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name + +hscGetModuleInterface :: HscEnv -> Module -> IO ModIface +hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod + +-- ----------------------------------------------------------------------------- +-- | Rename some import declarations +hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv +hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls + +-- ----------------------------------------------------------------------------- +-- | parse a file, returning the abstract syntax + +hscParse :: HscEnv -> ModSummary -> IO HsParsedModule +hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary + +-- internal version, that doesn't fail due to -Werror +hscParse' :: ModSummary -> Hsc HsParsedModule +hscParse' mod_summary + | Just r <- ms_parsed_mod mod_summary = return r + | otherwise = do + dflags <- getDynFlags + logger <- getLogger + {-# SCC "Parser" #-} withTiming logger + (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) + (const ()) $ do + let src_filename = ms_hspp_file mod_summary + maybe_src_buf = ms_hspp_buf mod_summary + + -------------------------- Parser ---------------- + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> liftIO $ hGetStringBuffer src_filename + + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 + + let diag_opts = initDiagOpts dflags + when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do + case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of + Nothing -> pure () + Just chars@((eloc,chr,_) :| _) -> + let span = mkSrcSpanPs $ mkPsSpan eloc (advancePsLoc eloc chr) + in logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope diag_opts span $ + GhcPsMessage $ PsWarnBidirectionalFormatChars chars + + let parseMod | HsigFile == ms_hsc_src mod_summary + = parseSignature + | otherwise = parseModule + + case unP parseMod (initParserState (initParserOpts dflags) buf loc) of + PFailed pst -> + handleWarningsThrowErrors (getPsMessages pst) + POk pst rdr_module -> do + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" + FormatHaskell (ppr rdr_module) + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan + NoBlankEpAnnotations + rdr_module) + liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics" + FormatText (ppSourceStats False rdr_module) + + -- To get the list of extra source files, we take the list + -- that the parser gave us, + -- - eliminate files beginning with '<'. gcc likes to use + -- pseudo-filenames like "" and "" + -- - normalise them (eliminate differences between ./f and f) + -- - filter out the preprocessed source file + -- - filter out anything beginning with tmpdir + -- - remove duplicates + -- - filter out the .hs/.lhs source filename if we have one + -- + let n_hspp = FilePath.normalise src_filename + TempDir tmp_dir = tmpDir dflags + srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`)) + $ filter (not . (== n_hspp)) + $ map FilePath.normalise + $ filter (not . isPrefixOf "<") + $ map unpackFS + $ srcfiles pst + srcs1 = case ml_hs_file (ms_location mod_summary) of + Just f -> filter (/= FilePath.normalise f) srcs0 + Nothing -> srcs0 + + -- sometimes we see source files from earlier + -- preprocessing stages that cannot be found, so just + -- filter them out: + srcs2 <- liftIO $ filterM doesFileExist srcs1 + + let res = HsParsedModule { + hpm_module = rdr_module, + hpm_src_files = srcs2 + } + + -- apply parse transformation of plugins + let applyPluginAction p opts + = parsedResultAction p opts mod_summary + hsc_env <- getHscEnv + (ParsedResult transformed (PsMessages warns errs)) <- + withPlugins (hsc_plugins hsc_env) applyPluginAction + (ParsedResult res (uncurry PsMessages $ getPsMessages pst)) + + logDiagnostics (GhcPsMessage <$> warns) + unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs) + + return transformed + +checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String)) +checkBidirectionFormatChars start_loc sb + | containsBidirectionalFormatChar sb = Just $ go start_loc sb + | otherwise = Nothing + where + go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String) + go loc sb + | atEnd sb = panic "checkBidirectionFormatChars: no char found" + | otherwise = case nextChar sb of + (chr, sb) + | Just desc <- lookup chr bidirectionalFormatChars -> + (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb + | otherwise -> go (advancePsLoc loc chr) sb + + go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)] + go1 loc sb + | atEnd sb = [] + | otherwise = case nextChar sb of + (chr, sb) + | Just desc <- lookup chr bidirectionalFormatChars -> + (loc, chr, desc) : go1 (advancePsLoc loc chr) sb + | otherwise -> go1 (advancePsLoc loc chr) sb + + +-- ----------------------------------------------------------------------------- +-- | If the renamed source has been kept, extract it. Dump it if requested. + + +extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff +extract_renamed_stuff mod_summary tc_result = do + let rn_info = getRenamedStuff tc_result + + dflags <- getDynFlags + logger <- getLogger + liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer" + FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info) + + -- Create HIE files + when (gopt Opt_WriteHie dflags) $ do + -- I assume this fromJust is safe because `-fwrite-hie-file` + -- enables the option which keeps the renamed source. + hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) + let out_file = ml_hie_file $ ms_location mod_summary + liftIO $ writeHieFile out_file hieFile + liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + + -- Validate HIE files + when (gopt Opt_ValidateHie dflags) $ do + hs_env <- getHscEnv + liftIO $ do + -- Validate Scopes + case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of + [] -> putMsg logger $ text "Got valid scopes" + xs -> do + putMsg logger $ text "Got invalid scopes" + mapM_ (putMsg logger) xs + -- Roundtrip testing + file' <- readHieFile (hsc_NC hs_env) out_file + case diffFile hieFile (hie_file_result file') of + [] -> + putMsg logger $ text "Got no roundtrip errors" + xs -> do + putMsg logger $ text "Got roundtrip errors" + let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug) + mapM_ (putMsg logger') xs + return rn_info + + +-- ----------------------------------------------------------------------------- +-- | Rename and typecheck a module, additionally returning the renamed syntax +hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule + -> IO (TcGblEnv, RenamedStuff) +hscTypecheckRename hsc_env mod_summary rdr_module = + fst <$> hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module + +-- | Rename and typecheck a module, additionally returning the renamed syntax +-- and the diagnostics produced. +hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule + -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage) +hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module = runHsc' hsc_env $ + hsc_typecheck True mod_summary (Just rdr_module) + +-- | Do Typechecking without throwing SourceError exception with -Werror +hscTypecheckAndGetWarnings :: HscEnv -> ModSummary -> IO (FrontendResult, WarningMessages) +hscTypecheckAndGetWarnings hsc_env summary = runHsc' hsc_env $ do + case hscFrontendHook (hsc_hooks hsc_env) of + Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False summary Nothing + Just h -> h summary + +-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack +-- b) concerning dumping rename info and hie files. It would be nice to further +-- separate this stuff out, probably in conjunction better separating renaming +-- and type checking (#17781). +hsc_typecheck :: Bool -- ^ Keep renamed source? + -> ModSummary -> Maybe HsParsedModule + -> Hsc (TcGblEnv, RenamedStuff) +hsc_typecheck keep_rn mod_summary mb_rdr_module = do + hsc_env <- getHscEnv + let hsc_src = ms_hsc_src mod_summary + dflags = hsc_dflags hsc_env + home_unit = hsc_home_unit hsc_env + outer_mod = ms_mod mod_summary + mod_name = moduleName outer_mod + outer_mod' = mkHomeModule home_unit mod_name + inner_mod = homeModuleNameInstantiation home_unit mod_name + src_filename = ms_hspp_file mod_summary + real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 + keep_rn' = gopt Opt_WriteHie dflags || keep_rn + massert (isHomeModule home_unit outer_mod) + tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) + then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc + else + do hpm <- case mb_rdr_module of + Just hpm -> return hpm + Nothing -> hscParse' mod_summary + tc_result0 <- tcRnModule' mod_summary keep_rn' hpm + if hsc_src == HsigFile + then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary + ioMsgMaybe $ hoistTcRnMessage $ + tcRnMergeSignatures hsc_env hpm tc_result0 iface + else return tc_result0 + -- TODO are we extracting anything when we merely instantiate a signature? + -- If not, try to move this into the "else" case above. + rn_info <- extract_renamed_stuff mod_summary tc_result + return (tc_result, rn_info) + +-- wrapper around tcRnModule to handle safe haskell extras +tcRnModule' :: ModSummary -> Bool -> HsParsedModule + -> Hsc TcGblEnv +tcRnModule' sum save_rn_syntax mod = do + hsc_env <- getHscEnv + dflags <- getDynFlags + + let diag_opts = initDiagOpts dflags + -- -Wmissing-safe-haskell-mode + when (not (safeHaskellModeEnabled dflags) + && wopt Opt_WarnMissingSafeHaskellMode dflags) $ + logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $ + GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum) + + tcg_res <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ hoistTcRnMessage $ + tcRnModule hsc_env sum + save_rn_syntax mod + + -- See Note [Safe Haskell Overlapping Instances Implementation] + -- although this is used for more than just that failure case. + tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res) + whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res) + let allSafeOK = safeInferred dflags && tcSafeOK + + -- end of the safe haskell line, how to respond to user? + if not (safeHaskellOn dflags) + || (safeInferOn dflags && not allSafeOK) + -- if safe Haskell off or safe infer failed, mark unsafe + then markUnsafeInfer tcg_res whyUnsafe + + -- module (could be) safe, throw warning if needed + else do + tcg_res' <- hscCheckSafeImports tcg_res + safe <- liftIO $ readIORef (tcg_safe_infer tcg_res') + when safe $ + case wopt Opt_WarnSafe dflags of + True + | safeHaskell dflags == Sf_Safe -> return () + | otherwise -> (logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $ + GhcDriverMessage $ DriverInferredSafeModule (tcg_mod tcg_res')) + False | safeHaskell dflags == Sf_Trustworthy && + wopt Opt_WarnTrustworthySafe dflags -> + (logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $ + GhcDriverMessage $ DriverMarkedTrustworthyButInferredSafe (tcg_mod tcg_res')) + False -> return () + return tcg_res' + +-- | Convert a typechecked module to Core +hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts +hscDesugar hsc_env mod_summary tc_result = + runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result + +hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts +hscDesugar' mod_location tc_result = do + hsc_env <- getHscEnv + ioMsgMaybe $ hoistDsMessage $ + {-# SCC "deSugar" #-} + deSugar hsc_env mod_location tc_result + +-- | Make a 'ModDetails' from the results of typechecking. Used when +-- typechecking only, as opposed to full compilation. +makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails +makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result + + +{- ********************************************************************** +%* * + The main compiler pipeline +%* * +%********************************************************************* -} + +{- + -------------------------------- + The compilation proper + -------------------------------- + +It's the task of the compilation proper to compile Haskell, hs-boot and core +files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all +(the module is still parsed and type-checked. This feature is mostly used by +IDE's and the likes). Compilation can happen in either 'one-shot', 'batch', +'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' +mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode +targets byte-code. + +The modes are kept separate because of their different types and meanings: + + * In 'one-shot' mode, we're only compiling a single file and can therefore + discard the new ModIface and ModDetails. This is also the reason it only + targets hard-code; compiling to byte-code or nothing doesn't make sense when + we discard the result. + + * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface + and ModDetails. 'Batch' mode doesn't target byte-code since that require us to + return the newly compiled byte-code. + + * 'Nothing' mode has exactly the same type as 'batch' mode but they're still + kept separate. This is because compiling to nothing is fairly special: We + don't output any interface files, we don't run the simplifier and we don't + generate any code. + + * 'Interactive' mode is similar to 'batch' mode except that we return the + compiled byte-code together with the ModIface and ModDetails. + +Trying to compile a hs-boot file to byte-code will result in a run-time error. +This is the only thing that isn't caught by the type-system. +-} + + + +-- | Do the recompilation avoidance checks for both one-shot and --make modes +-- This function is the *only* place in the compiler where we decide whether to +-- recompile a module or not! +hscRecompStatus :: Maybe Messager + -> HscEnv + -> ModSummary + -> Maybe ModIface + -> HomeModLinkable + -> (Int,Int) + -> IO HscRecompStatus +hscRecompStatus + mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index + = do + let + msg what = case mHscMessage of + Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] (ModuleNodeCompile mod_summary)) + Nothing -> return () + + -- First check to see if the interface file agrees with the + -- source file. + -- + -- Save the interface that comes back from checkOldIface. + -- In one-shot mode we don't have the old iface until this + -- point, when checkOldIface reads it from the disk. + recomp_if_result + <- {-# SCC "checkOldIface" #-} + liftIO $ checkOldIface hsc_env mod_summary mb_old_iface + case recomp_if_result of + OutOfDateItem reason mb_checked_iface -> do + msg $ NeedsRecompile reason + return $ HscRecompNeeded $ fmap mi_iface_hash mb_checked_iface + UpToDateItem checked_iface -> do + let lcl_dflags = ms_hspp_opts mod_summary + if | not (backendGeneratesCode (backend lcl_dflags)) -> do + -- No need for a linkable, we're good to go + msg UpToDate + return $ HscUpToDate checked_iface emptyHomeModInfoLinkable + | not (backendGeneratesCodeForHsBoot (backend lcl_dflags)) + , IsBoot <- isBootSummary mod_summary -> do + msg UpToDate + return $ HscUpToDate checked_iface emptyHomeModInfoLinkable + + -- Always recompile with the JS backend when TH is enabled until + -- #23013 is fixed. + | ArchJavaScript <- platformArch (targetPlatform lcl_dflags) + , xopt LangExt.TemplateHaskell lcl_dflags + -> do + msg $ needsRecompileBecause THWithJS + return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface + + | otherwise -> do + -- Do need linkable + -- 1. Just check whether we have bytecode/object linkables and then + -- we will decide if we need them or not. + bc_linkable <- checkByteCode checked_iface mod_summary (homeMod_bytecode old_linkable) + obj_linkable <- liftIO $ checkObjects lcl_dflags (homeMod_object old_linkable) mod_summary + trace_if (hsc_logger hsc_env) (vcat [text "BCO linkable", nest 2 (ppr bc_linkable), text "Object Linkable", ppr obj_linkable]) + + let just_bc = justBytecode <$> bc_linkable + just_o = justObjects <$> obj_linkable + _maybe_both_os = case (bc_linkable, obj_linkable) of + (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o) + -- If missing object code, just say we need to recompile because of object code. + (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing + -- If just missing byte code, just use the object code + -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll + -- end up using bytecode on recompilation + (_, UpToDateItem {} ) -> just_o + + definitely_both_os = case (bc_linkable, obj_linkable) of + (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o) + -- If missing object code, just say we need to recompile because of object code. + (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing + -- If just missing byte code, just use the object code + -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll + -- end up using bytecode on recompilation + (OutOfDateItem reason _, _ ) -> OutOfDateItem reason Nothing + +-- pprTraceM "recomp" (ppr just_bc <+> ppr just_o) + -- 2. Decide which of the products we will need + let recomp_linkable_result = case () of + _ | backendCanReuseLoadedCode (backend lcl_dflags) -> + case bc_linkable of + -- If bytecode is available for Interactive then don't load object code + UpToDateItem _ -> just_bc + _ -> case obj_linkable of + -- If o is availabe, then just use that + UpToDateItem _ -> just_o + _ -> outOfDateItemBecause MissingBytecode Nothing + -- Need object files for making object files + | backendWritesFiles (backend lcl_dflags) -> + if gopt Opt_ByteCodeAndObjectCode lcl_dflags + -- We say we are going to write both, so recompile unless we have both + then definitely_both_os + -- Only load the object file unless we are saying we need to produce both. + -- Unless we do this then you can end up using byte-code for a module you specify -fobject-code for. + else just_o + | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags) + case recomp_linkable_result of + UpToDateItem linkable -> do + msg $ UpToDate + return $ HscUpToDate checked_iface $ linkable + OutOfDateItem reason _ -> do + msg $ NeedsRecompile reason + return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface + +-- | Check that the .o files produced by compilation are already up-to-date +-- or not. +checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable) +checkObjects dflags mb_old_linkable summary = do + let + dt_enabled = gopt Opt_BuildDynamicToo dflags + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + mb_dyn_obj_date = ms_dyn_obj_date summary + mb_if_date = ms_iface_date summary + obj_fn = ml_obj_file (ms_location summary) + -- dynamic-too *also* produces the dyn_o_file, so have to check + -- that's there, and if it's not, regenerate both .o and + -- .dyn_o + checkDynamicObj k = if dt_enabled + then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of + Just True -> k + _ -> return $ outOfDateItemBecause MissingDynObjectFile Nothing + -- Not in dynamic-too mode + else k + + checkDynamicObj $ + case (,) <$> mb_obj_date <*> mb_if_date of + Just (obj_date, if_date) + | obj_date >= if_date -> + case mb_old_linkable of + Just old_linkable + | linkableIsNativeCodeOnly old_linkable, linkableTime old_linkable == obj_date + -> return $ UpToDateItem old_linkable + _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date + _ -> return $ outOfDateItemBecause MissingObjectFile Nothing + +-- | Check to see if we can reuse the old linkable, by this point we will +-- have just checked that the old interface matches up with the source hash, so +-- no need to check that again here +checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable) +checkByteCode iface mod_sum mb_old_linkable = + case mb_old_linkable of + Just old_linkable + | not (linkableIsNativeCodeOnly old_linkable) + -> return $ (UpToDateItem old_linkable) + _ -> loadByteCode iface mod_sum + +loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable) +loadByteCode iface mod_sum = do + let + this_mod = ms_mod mod_sum + if_date = fromJust $ ms_iface_date mod_sum + case iface_core_bindings iface (ms_location mod_sum) of + Just fi -> do + return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi)))) + _ -> return $ outOfDateItemBecause MissingBytecode Nothing + +-------------------------------------------------------------- +-- Compilers +-------------------------------------------------------------- + +add_iface_to_hpt :: ModIface -> ModDetails -> HscEnv -> IO () +add_iface_to_hpt iface details = + hscInsertHPT (HomeModInfo iface details emptyHomeModInfoLinkable) + +-- Knot tying! See Note [Knot-tying typecheckIface] +-- See Note [ModDetails and --make mode] +initModDetails :: HscEnv -> ModIface -> IO ModDetails +initModDetails hsc_env iface = + fixIO $ \details' -> do + add_iface_to_hpt iface details' hsc_env + -- NB: This result is actually not that useful + -- in one-shot mode, since we're not going to do + -- any further typechecking. It's much more useful + -- in make mode, since this HMI will go into the HPT. + genModDetails hsc_env iface + +-- | Modify flags such that objects are compiled for the interpreter's way. +-- This is necessary when building foreign objects for Template Haskell, since +-- those are object code built outside of the pipeline, which means they aren't +-- subject to the mechanism in 'enableCodeGenWhen' that requests dynamic build +-- outputs for dependencies when the interpreter used for TH is dynamic but the +-- main outputs aren't. +-- Furthermore, the HPT only stores one set of objects with different names for +-- bytecode linking in 'HomeModLinkable', so the usual hack for switching +-- between ways in 'get_link_deps' doesn't work. +compile_for_interpreter :: HscEnv -> (HscEnv -> IO a) -> IO a +compile_for_interpreter hsc_env use = + use (hscUpdateFlags update hsc_env) + where + update dflags = dflags { + targetWays_ = adapt_way interpreterDynamic WayDyn $ + adapt_way interpreterProfiled WayProf $ + targetWays_ dflags + } + + adapt_way want = if want (hscInterp hsc_env) then addWay else removeWay + +-- | Assemble 'WholeCoreBindings' if the interface contains Core bindings. +iface_core_bindings :: ModIface -> ModLocation -> Maybe WholeCoreBindings +iface_core_bindings iface wcb_mod_location = + mi_simplified_core <&> \(IfaceSimplifiedCore bindings foreign') -> + WholeCoreBindings { + wcb_bindings = bindings, + wcb_module = mi_module, + wcb_mod_location, + wcb_foreign = foreign' + } + where + ModIface {mi_module, mi_simplified_core} = iface + +-- | Return an 'IO' that hydrates Core bindings and compiles them to bytecode if +-- the interface contains any, using the supplied type env for typechecking. +-- +-- Unlike 'initWholeCoreBindings', this does not use lazy IO. +-- Instead, the 'IO' is only evaluated (in @get_link_deps@) when it is clear +-- that it will be used immediately (because we're linking TH with +-- @-fprefer-byte-code@ in oneshot mode), and the result is cached in +-- 'LoaderState'. +-- +-- 'initWholeCoreBindings' needs the laziness because it is used to populate +-- 'HomeModInfo', which is done preemptively, in anticipation of downstream +-- modules using the bytecode for TH in make mode, which might never happen. +loadIfaceByteCode :: + HscEnv -> + ModIface -> + ModLocation -> + TypeEnv -> + Maybe (IO Linkable) +loadIfaceByteCode hsc_env iface location type_env = + compile <$> iface_core_bindings iface location + where + compile decls = do + (bcos, fos) <- compileWholeCoreBindings hsc_env type_env decls + linkable $ BCOs bcos :| [DotO fo ForeignObject | fo <- fos] + + linkable parts = do + if_time <- modificationTimeIfExists (ml_hi_file location) + time <- maybe getCurrentTime pure if_time + return $! Linkable time (mi_module iface) parts + +loadIfaceByteCodeLazy :: + HscEnv -> + ModIface -> + ModLocation -> + TypeEnv -> + IO (Maybe Linkable) +loadIfaceByteCodeLazy hsc_env iface location type_env = + case iface_core_bindings iface location of + Nothing -> return Nothing + Just wcb -> do + Just <$> compile wcb + where + compile decls = do + ~(bcos, fos) <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls + linkable $ NE.singleton (LazyBCOs bcos fos) + + linkable parts = do + if_time <- modificationTimeIfExists (ml_hi_file location) + time <- maybe getCurrentTime pure if_time + return $!Linkable time (mi_module iface) parts + +-- | If the 'Linkable' contains Core bindings loaded from an interface, replace +-- them with a lazy IO thunk that compiles them to bytecode and foreign objects, +-- using the supplied environment for type checking. +-- +-- The laziness is necessary because this value is stored purely in a +-- 'HomeModLinkable' in the home package table, rather than some dedicated +-- mutable state that would generate bytecode on demand, so we have to call this +-- function even when we don't know that we'll need the bytecode. +-- +-- In addition, the laziness has to be hidden inside 'LazyBCOs' because +-- 'Linkable' is used too generally, so that looking at the constructor to +-- decide whether to discard it when linking native code would force the thunk +-- otherwise, incurring a significant performance penalty. +-- +-- This is sound because generateByteCode just depends on things already loaded +-- in the interface file. + +-- TODO: We should just use loadIfaceByteCodeLazy instead of the two stage process with +-- loadByteCode and initWholeCoreBindings. The main reason it is like this is because +-- initWholeCoreBindings requires a ModDetails, which we don't have during recompilation +-- checking. We should modify recompilation checking to return a HomeModInfo directly. + +initWholeCoreBindings :: + HscEnv -> + ModIface -> + ModDetails -> + Linkable -> + IO Linkable +initWholeCoreBindings hsc_env iface details (Linkable utc_time this_mod uls) = do + Linkable utc_time this_mod <$> mapM (go hsc_env) uls + where + go hsc_env' = \case + CoreBindings wcb -> do + add_iface_to_hpt iface details hsc_env + ~(bco, fos) <- unsafeInterleaveIO $ + compileWholeCoreBindings hsc_env' type_env wcb + pure (LazyBCOs bco fos) + l -> pure l + + type_env = md_types details + +-- | Hydrate interface Core bindings and compile them to bytecode. +-- +-- This consists of: +-- +-- 1. Running a typechecking step to insert the global names that were removed +-- when the interface was written or were unavailable due to boot import +-- cycles, converting the bindings to 'CoreBind'. +-- +-- 2. Restoring the foreign build inputs from their serialized format, resulting +-- in a set of foreign import stubs and source files added via +-- 'qAddForeignFilePath'. +-- +-- 3. Generating bytecode and foreign objects from the results of the previous +-- steps using the usual pipeline actions. +compileWholeCoreBindings :: + HscEnv -> + TypeEnv -> + WholeCoreBindings -> + IO (CompiledByteCode, [FilePath]) +compileWholeCoreBindings hsc_env type_env wcb = do + core_binds <- typecheck + (stubs, foreign_files) <- decode_foreign + gen_bytecode core_binds stubs foreign_files + where + typecheck = do + types_var <- newIORef type_env + let + tc_env = hsc_env { + hsc_type_env_vars = + knotVarsFromModuleEnv (mkModuleEnv [(wcb_module, types_var)]) + } + initIfaceCheck (text "l") tc_env $ + typecheckWholeCoreBindings types_var wcb + + decode_foreign = + decodeIfaceForeign logger (hsc_tmpfs hsc_env) + (tmpDir (hsc_dflags hsc_env)) wcb_foreign + + gen_bytecode core_binds stubs foreign_files = do + let cgi_guts = CgInteractiveGuts wcb_module core_binds + (typeEnvTyCons type_env) stubs foreign_files + Nothing [] + trace_if logger (text "Generating ByteCode for" <+> ppr wcb_module) + generateByteCode hsc_env cgi_guts wcb_mod_location + + WholeCoreBindings {wcb_module, wcb_mod_location, wcb_foreign} = wcb + + logger = hsc_logger hsc_env + +{- +Note [ModDetails and --make mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An interface file consists of two parts + +* The `ModIface` which ends up getting written to disk. + The `ModIface` is a completely acyclic tree, which can be serialised + and de-serialised completely straightforwardly. The `ModIface` is + also the structure that is finger-printed for recompilation control. + +* The `ModDetails` which provides a more structured view that is suitable + for usage during compilation. The `ModDetails` is heavily cyclic: + An `Id` contains a `Type`, which mentions a `TyCon` that contains kind + that mentions other `TyCons`; the `Id` also includes an unfolding that + in turn mentions more `Id`s; And so on. + +The `ModIface` can be created from the `ModDetails` and the `ModDetails` from +a `ModIface`. + +During tidying, just before interfaces are written to disk, +the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_). +Then when GHC needs to restart typechecking from a certain point it can read the +interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface). +The key part about the loading is that the ModDetails is regenerated lazily +from the ModIface, so that there's only a detailed in-memory representation +for declarations which are actually used from the interface. This mode is +also used when reading interface files from external packages. + +In the old --make mode implementation, the interface was written after compiling a module +but the in-memory ModDetails which was used to compute the ModIface was retained. +The result was that --make mode used much more memory than `-c` mode, because a large amount of +information about a module would be kept in the ModDetails but never used. + +The new idea is that even in `--make` mode, when there is an in-memory `ModDetails` +at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that +we only have to keep the `ModIface` decls in memory and then lazily load +detailed representations if needed. It turns out this makes a really big difference +to memory usage, halving maximum memory used in some cases. + +See !5492 and #13586 +-} + +-- Runs the post-typechecking frontend (desugar and simplify). We want to +-- generate most of the interface as late as possible. This gets us up-to-date +-- and good unfoldings and other info in the interface file. +-- +-- We might create a interface right away, in which case we also return the +-- updated HomeModInfo. But we might also need to run the backend first. In the +-- later case Status will be HscRecomp and we return a function from ModIface -> +-- HomeModInfo. +-- +-- HscRecomp in turn will carry the information required to compute a interface +-- when passed the result of the code generator. So all this can and is done at +-- the call site of the backend code gen if it is run. +hscDesugarAndSimplify :: ModSummary + -> FrontendResult + -> Messages GhcMessage + -> Maybe Fingerprint + -> Hsc HscBackendAction +hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_hash = do + hsc_env <- getHscEnv + dflags <- getDynFlags + logger <- getLogger + let bcknd = backend dflags + hsc_src = ms_hsc_src summary + diag_opts = initDiagOpts dflags + print_config = initPrintConfig dflags + + -- Desugar, if appropriate + -- + -- We usually desugar even when we are not generating code, otherwise we + -- would miss errors thrown by the desugaring (see #10600). The only + -- exception is when it is not a HsSrcFile module. + mb_desugar <- if + | hsc_src /= HsSrcFile -> pure Nothing + -- Desugar an empty ghc-prim:GHC.Prim module by filtering out all its + -- bindings: the reason is that some of them are invalid (such as top-level + -- unlifted ones like void# or proxy#) and cause HsToCore failures. + -- + -- We still need to desugar *something* because the driver and the linkers + -- expect a valid object file (.o) to be generated for this module. + | ms_mod summary == gHC_PRIM -> Just <$> hscDesugar' (ms_location summary) (tc_result { tcg_binds = [] }) + | otherwise -> Just <$> hscDesugar' (ms_location summary) tc_result + + -- Report the warnings from both typechecking and desugar together + w <- getDiagnostics + liftIO $ printOrThrowDiagnostics logger print_config diag_opts (unionMessages tc_warnings w) + clearDiagnostics + + -- Simplify, if appropriate, and (whether we simplified or not) generate an + -- interface file. + case mb_desugar of + -- Just cause we desugared doesn't mean we are generating code, see above. + Just desugared_guts | backendGeneratesCode bcknd -> do + plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) + simplified_guts <- hscSimplify' plugins desugared_guts + + (cg_guts, details) <- + liftIO $ hscTidy hsc_env simplified_guts + + !partial_iface <- liftIO $ + {-# SCC "GHC.Driver.Main.mkPartialIface" #-} + -- This `force` saves 2M residency in test T10370 + -- See Note [Avoiding space leaks in toIface*] for details. + fmap force (mkPartialIface hsc_env (cg_binds cg_guts) details summary (tcg_import_decls tc_result) simplified_guts) + + return HscRecomp { hscs_guts = cg_guts, + hscs_mod_location = ms_location summary, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_hash + } + + Just desugared_guts | gopt Opt_WriteIfSimplifiedCore dflags -> do + -- If -fno-code is enabled (hence we fall through to this case) + -- Running the simplifier once is necessary before doing byte code generation + -- in order to inline data con wrappers but we honour whatever level of simplificication the + -- user requested. See #22008 for some discussion. + plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) + simplified_guts <- hscSimplify' plugins desugared_guts + (cg_guts, _) <- + liftIO $ hscTidy hsc_env simplified_guts + + (iface, _details) <- liftIO $ + hscSimpleIface hsc_env (Just $ cg_binds cg_guts) tc_result summary + + liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) + + -- when compiling gHC_PRIM without generating code (e.g. with + -- Haddock), we still want the virtual interface in the cache + if ms_mod summary == gHC_PRIM + then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env)) + else return $ HscUpdate iface + + + -- We are not generating code or writing an interface with simplified core so we can skip simplification + -- and generate a simple interface. + _ -> do + (iface, _details) <- liftIO $ + hscSimpleIface hsc_env Nothing tc_result summary + + liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) + + -- when compiling gHC_PRIM without generating code (e.g. with + -- Haddock), we still want the virtual interface in the cache + if ms_mod summary == gHC_PRIM + then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env)) + else return $ HscUpdate iface + +{- +Note [Writing interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We write one interface file per module and per compilation, except with +-dynamic-too where we write two interface files (non-dynamic and dynamic). + +We can write two kinds of interfaces (see Note [Interface file stages] in +"GHC.Driver.Types"): + + * simple interface: interface generated after the core pipeline + + * full interface: simple interface completed with information from the + backend + +Depending on the situation, we write one or the other (using +`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the +backend is run twice, so if we write a simple interface we need to write both +the non-dynamic and the dynamic interfaces at the same time (with the same +contents). + +Cases for which we generate simple interfaces: + + * GHC.Driver.Main.hscDesugarAndSimplify: when a compilation does NOT require (re)compilation + of the hard code + + * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target + bytecode (if interface writing is forced). + + * GHC.Driver.Backpack uses simple interfaces for indefinite units + (units with module holes). It writes them indirectly by forcing the + -fwrite-interface flag while setting backend to NoBackend. + +Cases for which we generate full interfaces: + + * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard + code and/or require recompilation. + +By default interface file names are derived from module file names by adding +suffixes. The interface file name can be overloaded with "-ohi", except when +`-dynamic-too` is used. + +-} + +-- | Write interface files +hscMaybeWriteIface + :: Logger + -> DynFlags + -> Bool + -- ^ Is this a simple interface generated after the core pipeline, or one + -- with information from the backend? See: Note [Writing interface files] + -> ModIface + -> Maybe Fingerprint + -- ^ The old interface hash, used to decide if we need to actually write the + -- new interface. + -> ModLocation + -> IO () +hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do + let force_write_interface = gopt Opt_WriteInterface dflags + write_interface = backendWritesFiles (backend dflags) + + write_iface dflags' iface = + let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location + profile = targetProfile dflags' + in + {-# SCC "writeIface" #-} + withTiming logger + (text "WriteIface"<+>brackets (text iface_name)) + (const ()) + (writeIface logger profile (flagsToIfCompression dflags) iface_name iface) + + if (write_interface || force_write_interface) then do + + -- FIXME: with -dynamic-too, "change" is only meaningful for the + -- non-dynamic interface, not for the dynamic one. We should have another + -- flag for the dynamic interface. In the meantime: + -- + -- * when we write a single full interface, we check if we are + -- currently writing the dynamic interface due to -dynamic-too, in + -- which case we ignore "change". + -- + -- * when we write two simple interfaces at once because of + -- dynamic-too, we use "change" both for the non-dynamic and the + -- dynamic interfaces. Hopefully both the dynamic and the non-dynamic + -- interfaces stay in sync... + -- + let change = old_iface /= Just (mi_iface_hash iface) + + let dt = dynamicTooState dflags + + when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $ + hang (text "Writing interface(s):") 2 $ vcat + [ text "Kind:" <+> if is_simple then text "simple" else text "full" + , text "Hash change:" <+> ppr change + , text "DynamicToo state:" <+> text (show dt) + ] + + if is_simple + then when change $ do -- FIXME: see 'change' comment above + write_iface dflags iface + case dt of + DT_Dont -> return () + DT_Dyn -> panic "Unexpected DT_Dyn state when writing simple interface" + DT_OK -> write_iface (setDynamicNow dflags) iface + else case dt of + DT_Dont | change -> write_iface dflags iface + DT_OK | change -> write_iface dflags iface + -- FIXME: see change' comment above + DT_Dyn -> write_iface dflags iface + _ -> return () + + when (gopt Opt_WriteHie dflags) $ do + -- This is slightly hacky. A hie file is considered to be up to date + -- if its modification time on disk is greater than or equal to that + -- of the .hi file (since we should always write a .hi file if we are + -- writing a .hie file). However, with the way this code is + -- structured at the moment, the .hie file is often written before + -- the .hi file; by touching the file here, we ensure that it is + -- correctly considered up-to-date. + -- + -- The file should exist by the time we get here, but we check for + -- existence just in case, so that we don't accidentally create empty + -- .hie files. + let hie_file = ml_hie_file mod_location + whenM (doesFileExist hie_file) $ + GHC.Utils.Touch.touch hie_file + else + -- See Note [Strictness in ModIface] + forceModIface iface + +-------------------------------------------------------------- +-- NoRecomp handlers +-------------------------------------------------------------- + + +-- | genModDetails is used to initialise 'ModDetails' at the end of compilation. +-- This has two main effects: +-- 1. Increases memory usage by unloading a lot of the TypeEnv +-- 2. Globalising certain parts (DFunIds) in the TypeEnv (which used to be achieved using UpdateIdInfos) +-- For the second part to work, it's critical that we use 'initIfaceLoadModule' here rather than +-- 'initIfaceCheck' as 'initIfaceLoadModule' removes the module from the KnotVars, otherwise name lookups +-- succeed by hitting the old TypeEnv, which missing out the critical globalisation step for DFuns. + +-- After the DFunIds are globalised, it's critical to overwrite the old TypeEnv with the new +-- more compact and more correct version. This reduces memory usage whilst compiling the rest of +-- the module loop. +genModDetails :: HscEnv -> ModIface -> IO ModDetails +genModDetails hsc_env old_iface + = do + -- CRITICAL: To use initIfaceLoadModule as that removes the current module from the KnotVars and + -- hence properly globalises DFunIds. + new_details <- {-# SCC "tcRnIface" #-} + initIfaceLoadModule hsc_env (mi_module old_iface) (typecheckIface old_iface) + case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of + Nothing -> return () + Just te_var -> writeIORef te_var (md_types new_details) + dumpIfaceStats hsc_env + return new_details + + +-------------------------------------------------------------- +-- Safe Haskell +-------------------------------------------------------------- + +-- Note [Safe Haskell Trust Check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell checks that an import is trusted according to the following +-- rules for an import of module M that resides in Package P: +-- +-- * If M is recorded as Safe and all its trust dependencies are OK +-- then M is considered safe. +-- * If M is recorded as Trustworthy and P is considered trusted and +-- all M's trust dependencies are OK then M is considered safe. +-- +-- By trust dependencies we mean that the check is transitive. So if +-- a module M that is Safe relies on a module N that is trustworthy, +-- importing module M will first check (according to the second case) +-- that N is trusted before checking M is trusted. +-- +-- This is a minimal description, so please refer to the user guide +-- for more details. The user guide is also considered the authoritative +-- source in this matter, not the comments or code. + + +-- Note [Safe Haskell Inference] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell does Safe inference on modules that don't have any specific +-- safe haskell mode flag. The basic approach to this is: +-- * When deciding if we need to do a Safe language check, treat +-- an unmarked module as having -XSafe mode specified. +-- * For checks, don't throw errors but return them to the caller. +-- * Caller checks if there are errors: +-- * For modules explicitly marked -XSafe, we throw the errors. +-- * For unmarked modules (inference mode), we drop the errors +-- and mark the module as being Unsafe. +-- +-- It used to be that we only did safe inference on modules that had no Safe +-- Haskell flags, but now we perform safe inference on all modules as we want +-- to allow users to set the `-Wsafe`, `-Wunsafe` and +-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a +-- user can ensure their assumptions are correct and see reasons for why a +-- module is safe or unsafe. +-- +-- This is tricky as we must be careful when we should throw an error compared +-- to just warnings. For checking safe imports we manage it as two steps. First +-- we check any imports that are required to be safe, then we check all other +-- imports to see if we can infer them to be safe. + + +-- | Check that the safe imports of the module being compiled are valid. +-- If not we either issue a compilation error if the module is explicitly +-- using Safe Haskell, or mark the module as unsafe if we're in safe +-- inference mode. +hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv +hscCheckSafeImports tcg_env = do + dflags <- getDynFlags + tcg_env' <- checkSafeImports tcg_env + checkRULES dflags tcg_env' + + where + checkRULES dflags tcg_env' = + let diag_opts = initDiagOpts dflags + in case safeLanguageOn dflags of + True -> do + -- XSafe: we nuke user written RULES + logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env') + return tcg_env' { tcg_rules = [] } + False + -- SafeInferred: user defined RULES, so not safe + | safeInferOn dflags && not (null $ tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env') + + -- Trustworthy OR SafeInferred: with no RULES + | otherwise + -> return tcg_env' + + warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules + + warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage + warnRules diag_opts (L loc rule) = + mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUserDefinedRuleIgnored rule + +-- | Validate that safe imported modules are actually safe. For modules in the +-- HomePackage (the package the module we are compiling in resides) this just +-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules +-- that reside in another package we also must check that the external package +-- is trusted. See the Note [Safe Haskell Trust Check] above for more +-- information. +-- +-- The code for this is quite tricky as the whole algorithm is done in a few +-- distinct phases in different parts of the code base. See +-- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a +-- module are collected and unioned. Specifically see the Note [Tracking Trust +-- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in +-- "GHC.Rename.Names". +checkSafeImports :: TcGblEnv -> Hsc TcGblEnv +checkSafeImports tcg_env + = do + dflags <- getDynFlags + imps <- mapM condense imports' + let (safeImps, regImps) = partition (\(_,_,s) -> s) imps + + -- We want to use the warning state specifically for detecting if safe + -- inference has failed, so store and clear any existing warnings. + oldErrs <- getDiagnostics + clearDiagnostics + + -- Check safe imports are correct + safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps + safeErrs <- getDiagnostics + clearDiagnostics + + -- Check non-safe imports are correct if inferring safety + -- See the Note [Safe Haskell Inference] + (infErrs, infPkgs) <- case (safeInferOn dflags) of + False -> return (emptyMessages, S.empty) + True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps + infErrs <- getDiagnostics + clearDiagnostics + return (infErrs, infPkgs) + + -- restore old errors + logDiagnostics oldErrs + + diag_opts <- initDiagOpts <$> getDynFlags + print_config <- initPrintConfig <$> getDynFlags + logger <- getLogger + + -- Will throw if failed safe check + liftIO $ printOrThrowDiagnostics logger print_config diag_opts safeErrs + + -- No fatal warnings or errors: passed safe check + let infPassed = isEmptyMessages infErrs + tcg_env' <- case (not infPassed) of + True -> markUnsafeInfer tcg_env infErrs + False -> return tcg_env + when (packageTrustOn dflags) $ checkPkgTrust pkgReqs + let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed + return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } + + where + impInfo = tcg_imports tcg_env -- ImportAvails + imports = imp_mods impInfo -- ImportedMods + imports1 = M.toList imports -- (Module, [ImportedBy]) + imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal]) + pkgReqs = imp_trust_pkgs impInfo -- [Unit] + + condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) + condense (_, []) = panic "GHC.Driver.Main.condense: Pattern match failure!" + condense (m, x:xs) = do imv <- foldlM cond' x xs + return (m, imv_span imv, imv_is_safe imv) + + -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) + cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal + cond' v1 v2 + | imv_is_safe v1 /= imv_is_safe v2 + = throwOneError $ + mkPlainErrorMsgEnvelope (imv_span v1) $ + GhcDriverMessage $ DriverMixedSafetyImport (imv_name v1) + | otherwise + = return v1 + + -- easier interface to work with + checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId) + checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l + + -- what pkg's to add to our trust requirements + pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> + Bool -> ImportAvails + pkgTrustReqs dflags req inf infPassed | safeInferOn dflags + && not (safeHaskellModeEnabled dflags) && infPassed + = emptyImportAvails { + imp_trust_pkgs = req `S.union` inf + } + pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe + = emptyImportAvails + pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req } + +-- | Check that a module is safe to import. +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an exception may be thrown first. +hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool +hscCheckSafe hsc_env m l = runHsc hsc_env $ do + dflags <- getDynFlags + pkgs <- snd `fmap` hscCheckSafe' m l + when (packageTrustOn dflags) $ checkPkgTrust pkgs + errs <- getDiagnostics + return $ isEmptyMessages errs + +-- | Return if a module is trusted and the pkgs it depends on to be trusted. +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) +hscGetSafe hsc_env m l = runHsc hsc_env $ do + (self, pkgs) <- hscCheckSafe' m l + good <- isEmptyMessages `fmap` getDiagnostics + clearDiagnostics -- don't want them printed... + let pkgs' | Just p <- self = S.insert p pkgs + | otherwise = pkgs + return (good, pkgs') + +-- | Is a module trusted? If not, throw or log errors depending on the type. +-- Return (regardless of trusted or not) if the trust type requires the modules +-- own package be trusted and a list of other packages required to be trusted +-- (these later ones haven't been checked) but the own package trust has been. +hscCheckSafe' :: Module -> SrcSpan + -> Hsc (Maybe UnitId, Set UnitId) +hscCheckSafe' m l = do + hsc_env <- getHscEnv + let home_unit = hsc_home_unit hsc_env + (tw, pkgs) <- isModSafe home_unit m l + case tw of + False -> return (Nothing, pkgs) + True | isHomeModule home_unit m -> return (Nothing, pkgs) + -- TODO: do we also have to check the trust of the instantiation? + -- Not necessary if that is reflected in dependencies + | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) + where + isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId) + isModSafe home_unit m l = do + hsc_env <- getHscEnv + dflags <- getDynFlags + iface <- lookup' m + let diag_opts = initDiagOpts dflags + case iface of + -- can't load iface to check trust! + Nothing -> throwOneError $ + mkPlainErrorMsgEnvelope l $ + GhcDriverMessage $ DriverCannotLoadInterfaceFile m + + -- got iface, check trust + Just iface' -> + let trust = getSafeMode $ mi_trust iface' + trust_own_pkg = mi_trust_pkg iface' + -- check module is trusted + safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy] + -- check package is trusted + safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m + -- pkg trust reqs + pkgRs = dep_trusted_pkgs $ mi_deps iface' + -- warn if Safe module imports Safe-Inferred module. + warns = if wopt Opt_WarnInferredSafeImports dflags + && safeLanguageOn dflags + && trust == Sf_SafeInferred + then inferredImportWarn diag_opts + else emptyMessages + -- General errors we throw but Safe errors we log + errs = case (safeM, safeP) of + (True, True ) -> emptyMessages + (True, False) -> pkgTrustErr + (False, _ ) -> modTrustErr + in do + logDiagnostics warns + logDiagnostics errs + return (trust == Sf_Trustworthy, pkgRs) + + where + state = hsc_units hsc_env + inferredImportWarn diag_opts = singleMessage + $ mkMsgEnvelope diag_opts l (pkgQual state) + $ GhcDriverMessage $ DriverInferredSafeImport m + pkgTrustErr = singleMessage + $ mkErrorMsgEnvelope l (pkgQual state) + $ GhcDriverMessage $ DriverCannotImportFromUntrustedPackage state m + modTrustErr = singleMessage + $ mkErrorMsgEnvelope l (pkgQual state) + $ GhcDriverMessage $ DriverCannotImportUnsafeModule m + + -- Check the package a module resides in is trusted. Safe compiled + -- modules are trusted without requiring that their package is trusted. For + -- trustworthy modules, modules in the home package are trusted but + -- otherwise we check the package trust flag. + packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod = + case safe_mode of + Sf_None -> False -- shouldn't hit these cases + Sf_Ignore -> False -- shouldn't hit these cases + Sf_Unsafe -> False -- prefer for completeness. + _ | not (packageTrustOn dflags) -> True + Sf_Safe | not trust_own_pkg -> True + Sf_SafeInferred | not trust_own_pkg -> True + _ | isHomeModule home_unit mod -> True + _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m) + + lookup' :: Module -> Hsc (Maybe ModIface) + lookup' m = do + hsc_env <- getHscEnv + iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m + -- the 'lookupIfaceByModule' method will always fail when calling from GHCi + -- as the compiler hasn't filled in the various module tables + -- so we need to call 'getModuleInterface' to load from disk + case iface of + Just _ -> return iface + Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) + + +-- | Check the list of packages are trusted. +checkPkgTrust :: Set UnitId -> Hsc () +checkPkgTrust pkgs = do + hsc_env <- getHscEnv + let errors = S.foldr go emptyBag pkgs + state = hsc_units hsc_env + go pkg acc + | unitIsTrusted $ unsafeLookupUnitId state pkg + = acc + | otherwise + = (`consBag` acc) + $ mkErrorMsgEnvelope noSrcSpan (pkgQual state) + $ GhcDriverMessage + $ DriverPackageNotTrusted state pkg + if isEmptyBag errors + then return () + else liftIO $ throwErrors $ mkMessages errors + +-- | Set module to unsafe and (potentially) wipe trust information. +-- +-- Make sure to call this method to set a module to inferred unsafe, it should +-- be a central and single failure method. We only wipe the trust information +-- when we aren't in a specific Safe Haskell mode. +-- +-- While we only use this for recording that a module was inferred unsafe, we +-- may call it on modules using Trustworthy or Unsafe flags so as to allow +-- warning flags for safety to function correctly. See Note [Safe Haskell +-- Inference]. +markUnsafeInfer :: forall e . Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv +markUnsafeInfer tcg_env whyUnsafe = do + dflags <- getDynFlags + + let reason = WarningWithFlag Opt_WarnUnsafe + let diag_opts = initDiagOpts dflags + when (diag_wopt Opt_WarnUnsafe diag_opts) + (logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $ + GhcDriverMessage $ DriverUnknownMessage $ + mkSimpleUnknownDiagnostic $ + mkPlainDiagnostic reason noHints $ + whyUnsafe' dflags) + + liftIO $ writeIORef (tcg_safe_infer tcg_env) False + liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages + -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other + -- times inference may be on but we are in Trustworthy mode -- so we want + -- to record safe-inference failed but not wipe the trust dependencies. + case not (safeHaskellModeEnabled dflags) of + True -> return $ tcg_env { tcg_imports = wiped_trust } + False -> return tcg_env + + where + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } + pprMod = ppr $ moduleName $ tcg_mod tcg_env + whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" + , text "Reason:" + , nest 4 $ (vcat $ badFlags df) $+$ + -- MP: Using defaultDiagnosticOpts here is not right but it's also not right to handle these + -- unsafety error messages in an unstructured manner. + (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @e) (getMessages whyUnsafe)) $+$ + (vcat $ badInsts $ tcg_insts tcg_env) + ] + badFlags df = concatMap (badFlag df) unsafeFlagsForInfer + badFlag df (ext,loc,on,_) + | on df = [mkLocMessage MCOutput (loc df) $ + text "-X" <> ppr ext <+> text "is not allowed in Safe Haskell"] + | otherwise = [] + badInsts insts = concatMap badInst insts + + checkOverlap (NoOverlap _) = False + checkOverlap _ = True + + badInst ins | checkOverlap (overlapMode (is_flag ins)) + = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $ + ppr (overlapMode $ is_flag ins) <+> + text "overlap mode isn't allowed in Safe Haskell"] + | otherwise = [] + +-- | Figure out the final correct safe haskell mode +hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode +hscGetSafeMode tcg_env = do + dflags <- getDynFlags + liftIO $ finalSafeMode dflags tcg_env + +-------------------------------------------------------------- +-- Simplifiers +-------------------------------------------------------------- + +-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin +-- module names added via TH (cf 'addCorePlugin'). +hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts +hscSimplify hsc_env plugins modguts = + runHsc hsc_env $ hscSimplify' plugins modguts + +-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin +-- module names added via TH (cf 'addCorePlugin'). +hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts +hscSimplify' plugins ds_result = do + hsc_env <- getHscEnv + hsc_env_with_plugins <- if null plugins -- fast path + then return hsc_env + else liftIO $ initializePlugins + $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins) + hsc_env + {-# SCC "Core2Core" #-} + liftIO $ core2core hsc_env_with_plugins ds_result + +-------------------------------------------------------------- +-- Interface generators +-------------------------------------------------------------- + +-- | Generate a stripped down interface file, e.g. for boot files or when ghci +-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] +hscSimpleIface :: HscEnv + -> Maybe CoreProgram + -> TcGblEnv + -> ModSummary + -> IO (ModIface, ModDetails) +hscSimpleIface hsc_env mb_core_program tc_result summary + = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary + +hscSimpleIface' :: Maybe CoreProgram + -> TcGblEnv + -> ModSummary + -> Hsc (ModIface, ModDetails) +hscSimpleIface' mb_core_program tc_result summary = do + hsc_env <- getHscEnv + logger <- getLogger + details <- liftIO $ mkBootModDetailsTc logger tc_result + safe_mode <- hscGetSafeMode tc_result + new_iface + <- {-# SCC "MkFinalIface" #-} + liftIO $ + mkIfaceTc hsc_env safe_mode details summary mb_core_program tc_result + -- And the answer is ... + liftIO $ dumpIfaceStats hsc_env + return (new_iface, details) + +-------------------------------------------------------------- +-- BackEnd combinators +-------------------------------------------------------------- + +-- | Compile to hard-code. +hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath + -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos ) + -- ^ @Just f@ <=> _stub.c is f +hscGenHardCode hsc_env cgguts mod_loc output_filename = do + let CgGuts{ cg_module = this_mod, + cg_binds = core_binds, + cg_ccs = local_ccs + } = cgguts + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + + ------------------- + -- ADD IMPLICIT BINDINGS + -- NB: we must feed mkImplicitBinds through corePrep too + -- so that they are suitably cloned and eta-expanded + let cp_pgm_cfg :: CorePrepPgmConfig + cp_pgm_cfg = initCorePrepPgmConfig (hsc_dflags hsc_env) + (interactiveInScope $ hsc_IC hsc_env) + binds_with_implicits <- addImplicitBinds cp_pgm_cfg mod_loc (cg_tycons cgguts) core_binds + + ------------------- + -- INSERT LATE COST CENTRES, based on the provided flags. + -- + -- If -fprof-late-inline is enabled, we will skip adding CCs on any + -- top-level bindings here (via shortcut in `addLateCostCenters`), since + -- it will have already added a superset of the CCs we would add here. + let + late_cc_config :: LateCCConfig + late_cc_config = + LateCCConfig + { lateCCConfig_whichBinds = + if gopt Opt_ProfLateInlineCcs dflags then + LateCCNone + else if gopt Opt_ProfLateCcs dflags then + LateCCBinds + else if gopt Opt_ProfLateOverloadedCcs dflags then + LateCCOverloadedBinds + else + LateCCNone + , lateCCConfig_overloadedCalls = + gopt Opt_ProfLateoverloadedCallsCCs dflags + , lateCCConfig_env = + LateCCEnv + { lateCCEnv_module = this_mod + , lateCCEnv_file = fsLit <$> ml_hs_file mod_loc + , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags + , lateCCEnv_collectCCs = True + } + } + + (late_cc_binds, late_cc_state) <- + addLateCostCenters logger late_cc_config binds_with_implicits + + when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $ + putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr late_cc_binds)) + + ------------------- + -- RUN LATE PLUGINS + -- This is the last use of the CgGuts in a compilation. + -- From now on, we just use the bits we need. + ( CgGuts + { cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_spt_entries = spt_entries, + cg_binds = binds_to_prep, + cg_ccs = late_local_ccs + } + , _ + ) <- + {-# SCC latePlugins #-} + withTiming + logger + (text "LatePlugins"<+>brackets (ppr this_mod)) + (const ()) $ + withPlugins (hsc_plugins hsc_env) + (($ hsc_env) . latePlugin) + ( cgguts + { cg_binds = late_cc_binds + , cg_ccs = S.toList (lateCCState_ccs late_cc_state) ++ local_ccs + } + , lateCCState_ccState late_cc_state + ) + + let + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + llvm_config = hsc_llvm_config hsc_env + profile = targetProfile dflags + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + cp_cfg <- initCorePrepConfig hsc_env + (prepd_binds) <- {-# SCC "CorePrep" #-} + corePrepPgm + (hsc_logger hsc_env) cp_cfg cp_pgm_cfg + this_mod binds_to_prep + + ----------------- Convert to STG ------------------ + (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) + <- {-# SCC "CoreToStg" #-} + withTiming logger + (text "CoreToStg"<+>brackets (ppr this_mod)) + (\(a, b, (c,d), tag_env) -> + a `seqList` + b `seq` + c `seqList` + d `seqList` + (seqEltsUFM (seqTagSig) tag_env)) + (myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) False this_mod mod_loc prepd_binds) + + let (stg_binds,_stg_deps) = unzip stg_binds_with_deps + + let cost_centre_info = + (late_local_ccs ++ caf_ccs, caf_cc_stacks) + platform = targetPlatform dflags + prof_init + | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info + | otherwise = mempty + + ------------------ Code generation ------------------ + -- The back-end is streamed: each top-level function goes + -- from Stg all the way to asm before dealing with the next + -- top-level function, so withTiming isn't very useful here. + -- Hence we have one withTiming for the whole backend, the + -- next withTiming after this will be "Assembler" (hard code only). + withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) + $ case backendCodeOutput (backend dflags) of + JSCodeOutput -> + do + let js_config = initStgToJSConfig dflags + + -- The JavaScript backend does not create CmmCgInfos like the Cmm backend, + -- but it is needed for writing the interface file. Here we compute a very + -- conservative but correct value. + lf_infos (StgTopLifted (StgNonRec b _)) = [(idName b, LFUnknown True)] + lf_infos (StgTopLifted (StgRec bs)) = map (\(b,_) -> (idName b, LFUnknown True)) bs + lf_infos (StgTopStringLit b _) = [(idName b, LFUnlifted)] + + cmm_cg_infos = CmmCgInfos + { cgNonCafs = mempty + , cgLFInfos = mkNameEnv (concatMap lf_infos stg_binds) + , cgIPEStub = mempty + } + stub_c_exists = Nothing + foreign_fps = [] + + putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG + (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds) + + -- do the unfortunately effectual business + stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename + return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, Just cmm_cg_infos) + + _ -> + do + cmms <- {-# SCC "StgToCmm" #-} + doCodeGen hsc_env this_mod denv tycons + cost_centre_info + stg_binds + + ------------------ Code output ----------------------- + rawcmms0 <- {-# SCC "cmmToRawCmm" #-} + case cmmToRawCmmHook hooks of + Nothing -> cmmToRawCmm logger profile cmms + Just h -> h dflags (Just this_mod) cmms + + let dump a = do + unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) + return a + rawcmms1 = Stream.mapM (liftIO . dump) rawcmms0 + + let foreign_stubs st = foreign_stubs0 + `appendStubC` prof_init + `appendStubC` cgIPEStub st + + (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos) + <- {-# SCC "codeOutput" #-} + codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename mod_loc + foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1 + return ( output_filename, stub_c_exists, foreign_fps + , Just stg_cg_infos, Just cmm_cg_infos) + + +-- The part of CgGuts that we need for HscInteractive +data CgInteractiveGuts = CgInteractiveGuts { cgi_module :: Module + , cgi_binds :: CoreProgram + , cgi_tycons :: [TyCon] + , cgi_foreign :: ForeignStubs + , cgi_foreign_files :: [(ForeignSrcLang, FilePath)] + , cgi_modBreaks :: Maybe ModBreaks + , cgi_spt_entries :: [SptEntry] + } + +mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts +mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_foreign_files, cg_modBreaks, cg_spt_entries} + = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_foreign_files cg_modBreaks cg_spt_entries + +hscInteractive :: HscEnv + -> CgInteractiveGuts + -> ModLocation + -> IO (Maybe FilePath, CompiledByteCode) -- ^ .c stub path (if any) and ByteCode +hscInteractive hsc_env cgguts mod_loc = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env + let CgInteractiveGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cgi_module = this_mod, + cgi_binds = core_binds, + cgi_tycons = tycons, + cgi_foreign = foreign_stubs, + cgi_modBreaks = mod_breaks, + cgi_spt_entries = spt_entries } = cgguts + + ------------------- + -- ADD IMPLICIT BINDINGS + let cp_pgm_cfg :: CorePrepPgmConfig + cp_pgm_cfg = initCorePrepPgmConfig (hsc_dflags hsc_env) + (interactiveInScope $ hsc_IC hsc_env) + binds_to_prep <- addImplicitBinds cp_pgm_cfg mod_loc tycons core_binds + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + cp_cfg <- initCorePrepConfig hsc_env + prepd_binds <- {-# SCC "CorePrep" #-} + corePrepPgm (hsc_logger hsc_env) cp_cfg cp_pgm_cfg + this_mod binds_to_prep + + -- The stg cg info only provides a runtime benfit, but is not requires so we just + -- omit it here + (stg_binds_with_deps, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos) + <- {-# SCC "CoreToStg" #-} + myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) True this_mod mod_loc prepd_binds + + let (stg_binds,_stg_deps) = unzip stg_binds_with_deps + + ----------------- Generate byte code ------------------ + comp_bc <- byteCodeGen hsc_env this_mod stg_binds tycons mod_breaks spt_entries + + ------------------ Create f-x-dynamic C-side stuff ----- + (_istub_h_exists, istub_c_exists) + <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod mod_loc foreign_stubs + return (istub_c_exists, comp_bc) + +-- | Compile Core bindings and foreign inputs that were loaded from an +-- interface, to produce bytecode and potential foreign objects for the purpose +-- of linking splices. +generateByteCode :: HscEnv + -> CgInteractiveGuts + -> ModLocation + -> IO (CompiledByteCode, [FilePath]) +generateByteCode hsc_env cgguts mod_location = do + (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location + compile_for_interpreter hsc_env $ \ i_env -> do + stub_o <- traverse (compileForeign i_env LangC) hasStub + foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts) + pure (comp_bc, maybeToList stub_o ++ foreign_files_o) + +generateFreshByteCode :: HscEnv + -> ModuleName + -> CgInteractiveGuts + -> ModLocation + -> IO Linkable +generateFreshByteCode hsc_env mod_name cgguts mod_location = do + bco_time <- getCurrentTime + (bcos, fos) <- generateByteCode hsc_env cgguts mod_location + return $! + Linkable bco_time + (mkHomeModule (hsc_home_unit hsc_env) mod_name) + (BCOs bcos :| [DotO fo ForeignObject | fo <- fos]) +------------------------------ + +hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath) +hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + profile = targetProfile dflags + home_unit = hsc_home_unit hsc_env + platform = targetPlatform dflags + llvm_config = hsc_llvm_config hsc_env + cmm_config = initCmmConfig dflags + do_info_table = gopt Opt_InfoTableMap dflags + -- Make up a module name to give the NCG. We can't pass bottom here + -- lest we reproduce #11784. + mod_name = mkModuleName $ "Cmm$" ++ original_filename + cmm_mod = mkHomeModule home_unit mod_name + cmmpConfig = initCmmParserConfig dflags + (dcmm, ipe_ents) <- ioMsgMaybe + $ do + (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) + $ parseCmmFile cmmpConfig cmm_mod home_unit filename + let msgs = warns `unionMessages` errs + return (GhcPsMessage <$> msgs, cmm) + -- Probably need to rename cmm here + let cmm = removeDeterm dcmm + liftIO $ do + putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) + + -- Compile decls in Cmm files one decl at a time, to avoid re-ordering + -- them in SRT analysis. + -- + -- Re-ordering here causes breakage when booting with C backend because + -- in C we must declare before use, but SRT algorithm is free to + -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A] + ((_,dus1), cmmgroup) <- second concat <$> + mapAccumLM (\(msrt0, dus0) cmm -> do + ((msrt1, cmm'), dus1) <- cmmPipeline logger cmm_config msrt0 [cmm] dus0 + return ((msrt1, dus1), cmm')) (emptySRT cmm_mod, initDUniqSupply 'u' 0) cmm + + unless (null cmmgroup) $ + putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" + FormatCMM (pdoc platform cmmgroup) + + rawCmms0 <- case cmmToRawCmmHook hooks of + Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup) + Just h -> h dflags Nothing (Stream.yield cmmgroup) + + let dump a = do + unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) + return a + rawCmms = Stream.mapM (liftIO . dump) rawCmms0 + + let foreign_stubs _ + | not $ null ipe_ents = + let ip_init = ipInitCode do_info_table platform cmm_mod + in NoStubs `appendStubC` ip_init + | otherwise = NoStubs + (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) + <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty + dus1 rawCmms + return stub_c_exists + where + no_loc = OsPathModLocation + { ml_hs_file_ospath = Just $ unsafeEncodeUtf original_filename, + ml_hi_file_ospath = panic "hscCompileCmmFile: no hi file", + ml_obj_file_ospath = panic "hscCompileCmmFile: no obj file", + ml_dyn_obj_file_ospath = panic "hscCompileCmmFile: no dyn obj file", + ml_dyn_hi_file_ospath = panic "hscCompileCmmFile: no dyn obj file", + ml_hie_file_ospath = panic "hscCompileCmmFile: no hie file"} + +-------------------- Stuff for new code gen --------------------- + +{- +Note [Forcing of stg_binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The two last steps in the STG pipeline are: + +* Sorting the bindings in dependency order. +* Annotating them with free variables. + +We want to make sure we do not keep references to unannotated STG bindings +alive, nor references to bindings which have already been compiled to Cmm. + +We explicitly force the bindings to avoid this. + +This reduces residency towards the end of the CodeGen phase significantly +(5-10%). +-} + +doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon] + -> CollectedCCs + -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs + -> IO (CgStream CmmGroupSRTs CmmCgInfos) + -- Note we produce a 'Stream' of CmmGroups, so that the + -- backend can be run incrementally. Otherwise it generates all + -- the C-- up front, which has a significant space cost. +doCodeGen hsc_env this_mod denv tycons + cost_centre_info stg_binds_w_fvs = do + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + platform = targetPlatform dflags + stg_ppr_opts = (initStgPprOpts dflags) + + putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG + (pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs) + + let stg_to_cmm dflags mod a b c d = case stgToCmmHook hooks of + Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) a b c d + Just h -> (,emptyDetUFM) <$> h (initStgToCmmConfig dflags mod) a b c d + + let cmm_stream :: CgStream CmmGroup (ModuleLFInfos, DetUniqFM) + -- See Note [Forcing of stg_binds] + cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-} + stg_to_cmm dflags this_mod denv tycons cost_centre_info stg_binds_w_fvs + + -- codegen consumes a stream of CmmGroup, and produces a new + -- stream of CmmGroup (not necessarily synchronised: one + -- CmmGroup on input may produce many CmmGroups on output due + -- to proc-point splitting). + + let dump1 a = do + unless (null a) $ + putDumpFileMaybe logger Opt_D_dump_cmm_from_stg + "Cmm produced by codegen" FormatCMM (pdoc platform a) + return a + + ppr_stream1 = Stream.mapM (liftIO . dump1) cmm_stream + + cmm_config = initCmmConfig dflags + + pipeline_stream :: CgStream CmmGroupSRTs CmmCgInfos + pipeline_stream = do + ((mod_srt_info, ipes, ipe_stats), (lf_infos, detRnEnv)) <- + {-# SCC "cmmPipeline" #-} + Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty) ppr_stream1 + + let nonCaffySet = srtMapNonCAFs (moduleSRTMap mod_srt_info) + + -- denv::InfoTableProvMap refers to symbols that no longer exist + -- if -fobject-determinism is on, since it was created before the + -- Cmm was renamed. Update all the symbols by renaming them with + -- the renaming map in that case. + (_drn, rn_denv) + | gopt Opt_ObjectDeterminism dflags = detRenameIPEMap detRnEnv denv + | otherwise = (detRnEnv, denv) + + cmmCgInfos <- generateCgIPEStub hsc_env this_mod rn_denv (nonCaffySet, lf_infos, ipes, ipe_stats) + return cmmCgInfos + + pipeline_action + :: Logger + -> CmmConfig + -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) + -> CmmGroup + -> UniqDSMT IO ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats), CmmGroupSRTs) + pipeline_action logger cmm_config (mod_srt_info, ipes, stats) cmm_group = do + (mod_srt_info', cmm_srts) <- withDUS $ cmmPipeline logger cmm_config mod_srt_info cmm_group + + -- If -finfo-table-map is enabled, we precompute a map from info + -- tables to source locations. See Note [Mapping Info Tables to Source + -- Positions] in GHC.Stg.Debug. + (ipes', stats') <- + if (gopt Opt_InfoTableMap dflags) then + liftIO $ lookupEstimatedTicks hsc_env ipes stats cmm_srts + else + return (ipes, stats) + + return ((mod_srt_info', ipes', stats'), cmm_srts) + + dump2 a = do + unless (null a) $ + putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) + return a + + return $ Stream.mapM (liftIO . dump2) pipeline_stream + +myCoreToStg :: Logger -> DynFlags -> [Var] + -> Bool + -> Module -> ModLocation -> CoreProgram + -> IO ( [(CgStgTopBinding,IdSet)] -- output program and its dependencies + , InfoTableProvMap + , CollectedCCs -- CAF cost centre info (declared and used) + , StgCgInfos ) +myCoreToStg logger dflags ic_inscope for_bytecode this_mod ml prepd_binds = do + let (stg_binds, denv, cost_centre_info) + = {-# SCC "Core2Stg" #-} + coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds + + (stg_binds_with_fvs,stg_cg_info) + <- {-# SCC "Stg2Stg" #-} + stg2stg logger ic_inscope (initStgPipelineOpts dflags for_bytecode) + this_mod stg_binds + + putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG + (pprGenStgTopBindings (initStgPprOpts dflags) (fmap fst stg_binds_with_fvs)) + + return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info) + +{- ********************************************************************** +%* * +\subsection{Compiling a do-statement} +%* * +%********************************************************************* -} + +{- +When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When +you run it you get a list of HValues that should be the same length as the list +of names; add them to the ClosureEnv. + +A naked expression returns a singleton Name [it]. The stmt is lifted into the +IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context +-} + +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv)) +hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "" 1 + +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmtWithLocation :: HscEnv + -> String -- ^ The statement + -> String -- ^ The source + -> Int -- ^ Starting line + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) +hscStmtWithLocation hsc_env0 stmt source linenumber = + runInteractiveHsc hsc_env0 $ do + maybe_stmt <- hscParseStmtWithLocation source linenumber stmt + case maybe_stmt of + Nothing -> return Nothing + + Just parsed_stmt -> do + hsc_env <- getHscEnv + liftIO $ hscParsedStmt hsc_env parsed_stmt + +hscParsedStmt :: HscEnv + -> GhciLStmt GhcPs -- ^ The parsed statement + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) +hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do + -- Rename and typecheck it + (ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt + + -- Desugar it + ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr + liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr) + handleWarnings + + -- Then code-gen, and link it + -- It's important NOT to have package 'interactive' as thisUnitId + -- for linking, else we try to link 'main' and can't find it. + -- Whereas the linker already knows to ignore 'interactive' + let src_span = srcLocSpan interactiveSrcLoc + (hval,_,_) <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + + return $ Just (ids, hval, fix_env) + +hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO (HsModule GhcPs) +hscParseModuleWithLocation hsc_env source line_num str = do + L _ mod <- + runInteractiveHsc hsc_env $ + hscParseThingWithLocation source line_num parseModule str + return mod + +hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs] +hscParseDeclsWithLocation hsc_env source line_num str = do + HsModule { hsmodDecls = decls } <- hscParseModuleWithLocation hsc_env source line_num str + return decls + +hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext) +hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do + hsc_env <- getHscEnv + let interp = hscInterp hsc_env + + {- Rename and typecheck it -} + tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls + + {- Grab the new instances -} + -- We grab the whole environment because of the overlapping that may have + -- been done. See the notes at the definition of InteractiveContext + -- (ic_instances) for more details. + let defaults = tcg_default tc_gblenv + + {- Desugar it -} + -- We use a basically null location for iNTERACTIVE + let iNTERACTIVELoc = OsPathModLocation + { ml_hs_file_ospath = Nothing, + ml_hi_file_ospath = panic "hsDeclsWithLocation:ml_hi_file_ospath", + ml_obj_file_ospath = panic "hsDeclsWithLocation:ml_obj_file_ospath", + ml_dyn_obj_file_ospath = panic "hsDeclsWithLocation:ml_dyn_obj_file_ospath", + ml_dyn_hi_file_ospath = panic "hsDeclsWithLocation:ml_dyn_hi_file_ospath", + ml_hie_file_ospath = panic "hsDeclsWithLocation:ml_hie_file_ospath" } + ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv + + {- Simplify -} + simpl_mg <- liftIO $ do + plugins <- readIORef (tcg_th_coreplugins tc_gblenv) + hscSimplify hsc_env plugins ds_result + + {- Tidy -} + (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg + + let !CgGuts{ cg_module = this_mod, + cg_binds = core_binds + } = tidy_cg + + !ModDetails { md_insts = cls_insts + , md_fam_insts = fam_insts } = mod_details + -- Get the *tidied* cls_insts and fam_insts + + {- Generate byte code & foreign stubs -} + linkable <- liftIO $ generateFreshByteCode hsc_env + (moduleName this_mod) + (mkCgInteractiveGuts tidy_cg) + iNTERACTIVELoc + + let src_span = srcLocSpan interactiveSrcLoc + _ <- liftIO $ loadDecls interp hsc_env src_span linkable + + {- Load static pointer table entries -} + liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) + + let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) + patsyns = mg_patsyns simpl_mg + + ext_ids = [ id | id <- bindersOfBinds core_binds + , isExternalName (idName id) + , not (isDFunId id || isImplicitId id) ] + -- We only need to keep around the external bindings + -- (as decided by GHC.Iface.Tidy), since those are the only ones + -- that might later be looked up by name. But we can exclude + -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context + -- - Implicit Ids, which are implicit in tcs + -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv + + new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns + ictxt = hsc_IC hsc_env + -- See Note [Fixity declarations in GHCi] + fix_env = tcg_fix_env tc_gblenv + new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts + fam_insts defaults fix_env + return (new_tythings, new_ictxt) + +-- | Load the given static-pointer table entries into the interpreter. +-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". +hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () +hscAddSptEntries hsc_env entries = do + let interp = hscInterp hsc_env + let add_spt_entry :: SptEntry -> IO () + add_spt_entry (SptEntry i fpr) = do + -- These are only names from the current module + (val, _, _) <- loadName interp hsc_env (idName i) + addSptEntry interp fpr val + mapM_ add_spt_entry entries + +{- + Note [Fixity declarations in GHCi] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + To support fixity declarations on types defined within GHCi (as requested + in #10018) we record the fixity environment in InteractiveContext. + When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this + fixity environment and uses it to initialize the global typechecker environment. + After the typechecker has finished its business, an updated fixity environment + (reflecting whatever fixity declarations were present in the statements we + passed it) will be returned from hscParsedStmt. This is passed to + updateFixityEnv, which will stuff it back into InteractiveContext, to be + used in evaluating the next statement. + +-} + +hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs) +hscImport hsc_env str = runInteractiveHsc hsc_env $ do + -- Use >>= \case instead of MonadFail desugaring to take into + -- consideration `instance XXModule p = DataConCantHappen`. + -- Tracked in #15681 + hscParseThing parseModule str >>= \case + (L _ (HsModule{hsmodImports=is})) -> + case is of + [L _ i] -> return i + _ -> liftIO $ throwOneError $ + mkPlainErrorMsgEnvelope noSrcSpan $ + GhcPsMessage $ PsUnknownMessage $ + mkSimpleUnknownDiagnostic $ + mkPlainError noHints $ + text "parse error in import declaration" + +-- | Typecheck an expression (but don't run it) +hscTcExpr :: HscEnv + -> TcRnExprMode + -> String -- ^ The expression + -> IO Type +hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + parsed_expr <- hscParseExpr expr + ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr + +-- | Find the kind of a type, after generalisation +hscKcType + :: HscEnv + -> Bool -- ^ Normalise the type + -> String -- ^ The type as a string + -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind +hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ty <- hscParseType str + ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty + +hscParseExpr :: String -> Hsc (LHsExpr GhcPs) +hscParseExpr expr = do + maybe_stmt <- hscParseStmt expr + case maybe_stmt of + Just (L _ (BodyStmt _ expr _ _)) -> return expr + _ -> throwOneError $ + mkPlainErrorMsgEnvelope noSrcSpan $ + GhcPsMessage $ PsUnknownMessage + $ mkSimpleUnknownDiagnostic + $ mkPlainError noHints $ + text "not an expression:" <+> quotes (text expr) + +hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) +hscParseStmt = hscParseThing parseStmt + +hscParseStmtWithLocation :: String -> Int -> String + -> Hsc (Maybe (GhciLStmt GhcPs)) +hscParseStmtWithLocation source linenumber stmt = + hscParseThingWithLocation source linenumber parseStmt stmt + +hscParseType :: String -> Hsc (LHsType GhcPs) +hscParseType = hscParseThing parseType + +hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName) +hscParseIdentifier hsc_env str = + runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str + +hscParseThing :: (Outputable thing, Data thing) + => Lexer.P thing -> String -> Hsc thing +hscParseThing = hscParseThingWithLocation "" 1 + +hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int + -> Lexer.P thing -> String -> Hsc thing +hscParseThingWithLocation source linenumber parser str = do + dflags <- getDynFlags + logger <- getLogger + withTiming logger + (text "Parser [source]") + (const ()) $ {-# SCC "Parser" #-} do + + let buf = stringToStringBuffer str + loc = mkRealSrcLoc (fsLit source) linenumber 1 + + case unP parser (initParserState (initParserOpts dflags) buf loc) of + PFailed pst -> + handleWarningsThrowErrors (getPsMessages pst) + POk pst thing -> do + logWarningsReportErrors (getPsMessages pst) + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" + FormatHaskell (ppr thing) + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing) + return thing + +hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) +hscTidy hsc_env guts = do + let logger = hsc_logger hsc_env + let this_mod = mg_module guts + + opts <- initTidyOpts hsc_env + (cgguts, details) <- withTiming logger + (text "CoreTidy"<+>brackets (ppr this_mod)) + (const ()) + $! {-# SCC "CoreTidy" #-} tidyProgram opts guts + + -- post tidy pretty-printing and linting... + let tidy_rules = md_rules details + let all_tidy_binds = cg_binds cgguts + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts) + ptc = initPromotionTickContext (hsc_dflags hsc_env) + + endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules + + -- If the endPass didn't print the rules, but ddump-rules is + -- on, print now + unless (logHasDumpFlag logger Opt_D_dump_simpl) $ + putDumpFileMaybe logger Opt_D_dump_rules + "Tidy Core rules" + FormatText + (pprRulesForUser tidy_rules) + + -- Print one-line size info + let cs = coreBindsStats all_tidy_binds + putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats" + FormatText + (text "Tidy size (terms,types,coercions)" + <+> ppr (moduleName this_mod) <> colon + <+> int (cs_tm cs) + <+> int (cs_ty cs) + <+> int (cs_co cs)) + + pure (cgguts, details) + + +{- ********************************************************************** +%* * + Desugar, simplify, convert to bytecode, and link an expression +%* * +%********************************************************************* -} + +hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) +hscCompileCoreExpr hsc_env loc expr = + case hscCompileCoreExprHook (hsc_hooks hsc_env) of + Nothing -> hscCompileCoreExpr' hsc_env loc expr + Just h -> h hsc_env loc expr + +hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) +hscCompileCoreExpr' hsc_env srcspan ds_expr = do + {- Simplify it -} + -- Question: should we call SimpleOpt.simpleOptExpr here instead? + -- It is, well, simpler, and does less inlining etc. + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let ic = hsc_IC hsc_env + let unit_env = hsc_unit_env hsc_env + let simplify_expr_opts = initSimplifyExprOpts dflags ic + + simpl_expr <- simplifyExpr logger (ue_eps unit_env) simplify_expr_opts ds_expr + + -- Create a unique temporary binding + -- + -- The id has to be exported for the JS backend. This isn't required for the + -- byte-code interpreter but it does no harm to always do it. + u <- uniqFromTag 'I' + let binding_name = mkSystemVarName u (fsLit ("BCO_toplevel")) + let binding_id = mkExportedVanillaId binding_name (exprType simpl_expr) + + {- Tidy it (temporary, until coreSat does cloning) -} + let tidy_occ_env = initTidyOccEnv [occName binding_id] + let tidy_env = mkEmptyTidyEnv tidy_occ_env + let tidy_expr = tidyExpr tidy_env simpl_expr + + {- Prepare for codegen -} + cp_cfg <- initCorePrepConfig hsc_env + prepd_expr <- corePrepExpr + logger cp_cfg + tidy_expr + + {- Lint if necessary -} + lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr + let this_loc = OsPathModLocation + { ml_hs_file_ospath = Nothing, + ml_hi_file_ospath = panic "hscCompileCoreExpr':ml_hi_file_ospath", + ml_obj_file_ospath = panic "hscCompileCoreExpr':ml_obj_file_ospath", + ml_dyn_obj_file_ospath = panic "hscCompileCoreExpr': ml_obj_file_ospath", + ml_dyn_hi_file_ospath = panic "hscCompileCoreExpr': ml_dyn_hi_file_ospath", + ml_hie_file_ospath = panic "hscCompileCoreExpr':ml_hie_file_ospath" } + + -- Ensure module uniqueness by giving it a name like "GhciNNNN". + -- This uniqueness is needed by the JS linker. Without it we break the 1-1 + -- relationship between modules and object files, i.e. we get different object + -- files for the same module and the JS linker doesn't support this. + -- + -- Note that we can't use icInteractiveModule because the ic_mod_index value + -- isn't bumped between invocations of hscCompileCoreExpr, so uniqueness isn't + -- guaranteed. + -- + -- We reuse the unique we obtained for the binding, but any unique would do. + let this_mod = mkInteractiveModule (show u) + let for_bytecode = True + + (stg_binds_with_deps, _prov_map, _collected_ccs, _stg_cg_infos) <- + myCoreToStg logger + dflags + (interactiveInScope (hsc_IC hsc_env)) + for_bytecode + this_mod + this_loc + [NonRec binding_id prepd_expr] + + let (stg_binds, _stg_deps) = unzip stg_binds_with_deps + + let interp = hscInterp hsc_env + + case interp of + -- always generate JS code for the JS interpreter (no bytecode!) + Interp (ExternalInterp (ExtJS i)) _ _ -> + jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id + + _ -> do + {- Convert to BCOs -} + bcos <- byteCodeGen hsc_env + this_mod + stg_binds + [] + Nothing -- modbreaks + [] -- spt entries + + {- load it -} + bco_time <- getCurrentTime + (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan $ + Linkable bco_time this_mod $ NE.singleton $ BCOs bcos + {- Get the HValue for the root -} + return (expectJust $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) + + + +-- | Generate JS code for the given bindings and return the HValue for the given id +jsCodeGen + :: HscEnv + -> SrcSpan + -> JSInterp + -> Module + -> [(CgStgTopBinding,IdSet)] + -> Id + -> IO (ForeignHValue, [Linkable], PkgsLoaded) +jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do + let logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + dflags = hsc_dflags hsc_env + interp = hscInterp hsc_env + tmp_dir = tmpDir dflags + unit_env = hsc_unit_env hsc_env + js_config = initStgToJSConfig dflags + + -- We need to load all the dependencies first. + -- + -- We get all the imported names from the Stg bindings and load their modules. + -- + -- (logic adapted from GHC.Linker.Loader.loadDecls for the JS linker) + let + (stg_binds, stg_deps) = unzip stg_binds_with_deps + imported_ids = nonDetEltsUniqSet (unionVarSets stg_deps) + imported_names = map idName imported_ids + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- imported_names, + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + + -- Initialise the linker (if it's not been done already) + initLoaderState interp hsc_env + + -- Take lock for the actual work. + (dep_linkables, dep_units) <- modifyLoaderState interp $ \pls -> do + let link_opts = initLinkDepsOpts hsc_env + + -- Find what packages and linkables are required + deps <- getLinkDeps link_opts interp pls srcspan needed_mods + -- We update the LinkerState even if the JS interpreter maintains its linker + -- state independently to load new objects here. + + let objs = mapMaybe linkableFilterNative (ldNeededLinkables deps) + (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs + + -- FIXME: we should make the JS linker load new_objs here, instead of + -- on-demand. + + -- FIXME: we don't report needed units because we would have to find a way + -- to build a meaningful LoadedPkgInfo (see the mess in + -- GHC.Linker.Loader.{loadPackage,loadPackages'}). Detecting what to load + -- and actually loading (using the native interpreter) are intermingled, so + -- we can't directly reuse this code. + let pls' = pls { objs_loaded = objs_loaded' } + pure (pls', (ldAllLinkables deps, emptyUDFM {- ldNeededUnits deps -}) ) + + + let foreign_stubs = NoStubs + spt_entries = mempty + cost_centre_info = mempty + + -- codegen into object file whose path is in out_obj + out_obj <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "o" + stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs cost_centre_info out_obj + + let TxtI id_sym = makeIdentForId binding_id Nothing IdPlain this_mod + -- link code containing binding "id_sym = expr", using id_sym as root + withJSInterp i $ \inst -> do + let roots = mkExportedModFuns this_mod [id_sym] + jsLinkObject logger tmpfs tmp_dir js_config unit_env inst out_obj roots + + -- look up "id_sym" closure and create a StablePtr (HValue) from it + href <- lookupClosure interp (IFaststringSymbol id_sym) >>= \case + Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym) + Just r -> pure r + + binding_fref <- withJSInterp i $ \inst -> + mkForeignRef href (freeReallyRemoteRef inst href) + + return (castForeignRef binding_fref, dep_linkables, dep_units) + + +{- ********************************************************************** +%* * + Statistics on reading interfaces +%* * +%********************************************************************* -} + +dumpIfaceStats :: HscEnv -> IO () +dumpIfaceStats hsc_env = do + eps <- hscEPS hsc_env + let + logger = hsc_logger hsc_env + dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats + dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace + when (dump_if_trace || dump_rn_stats) $ + logDumpMsg logger "Interface statistics" (ifaceStats eps) + + + +writeInterfaceOnlyMode :: DynFlags -> Bool +writeInterfaceOnlyMode dflags = + gopt Opt_WriteInterface dflags && + not (backendGeneratesCode (backend dflags)) diff --git a/GHC/Driver/Main.hs-boot b/GHC/Driver/Main.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Driver/Main.hs-boot @@ -0,0 +1,15 @@ +module GHC.Driver.Main where + +import GHC.Driver.Env.Types (HscEnv) +import GHC.Linker.Types (Linkable) +import GHC.Prelude.Basic +import GHC.Types.TypeEnv (TypeEnv) +import GHC.Unit.Module.Location (ModLocation) +import GHC.Unit.Module.ModIface (ModIface) + +loadIfaceByteCode :: + HscEnv -> + ModIface -> + ModLocation -> + TypeEnv -> + Maybe (IO Linkable) diff --git a/GHC/Driver/Make.hs b/GHC/Driver/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Make.hs @@ -0,0 +1,1935 @@ +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. +-- +-- ----------------------------------------------------------------------------- +module GHC.Driver.Make ( + depanal, depanalE, depanalPartial, + load, loadWithCache, load', AnyGhcDiagnostic, LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache, + + downsweep, + + topSortModuleGraph, + + ms_home_srcimps, ms_home_imps, + + hscSourceToIsBoot, + findExtraSigImports, + implicitRequirementsShallow, + + noModError, cyclicModuleErr, + SummaryNode, + IsBootInterface(..), mkNodeKey, + + ModNodeKey, ModNodeKeyWithUid(..), + ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith, + + -- * Re-exports from Downsweep + checkHomeUnitsClosed, + summariseModule, + summariseModuleInterface, + SummariseResult(..), + summariseFile, + + instantiationNodes, + ) where + +import GHC.Prelude +import GHC.Platform + +import GHC.Tc.Utils.Backpack +import GHC.Tc.Utils.Monad ( initIfaceCheck, concatMapM ) + +import GHC.Runtime.Interpreter +import qualified GHC.Linker.Loader as Linker +import GHC.Linker.Types + + +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Pipeline +import GHC.Driver.Session +import GHC.Driver.DynFlags (ReexportedModule(..)) +import GHC.Driver.Monad +import GHC.Driver.Env +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Main +import GHC.Driver.MakeSem +import GHC.Driver.Downsweep +import GHC.Driver.MakeAction + +import GHC.ByteCode.Types + +import GHC.Iface.Load ( cannotFindModule, readIface ) +import GHC.IfaceToCore ( typecheckIface ) +import GHC.Iface.Recomp ( RecompileRequired(..), CompileReason(..) ) + +import GHC.Data.Bag ( listToBag ) +import GHC.Data.Graph.Directed +import GHC.Data.Maybe ( expectJust ) + +import GHC.Utils.Exception ( throwIO, SomeAsyncException ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.TmpFs + +import GHC.Types.Basic +import GHC.Types.Error +import GHC.Types.Target +import GHC.Types.SourceFile +import GHC.Types.SourceError +import GHC.Types.SrcLoc +import GHC.Types.PkgQual + +import GHC.Unit +import GHC.Unit.Env +import GHC.Unit.Finder +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Graph +import GHC.Unit.Home.ModInfo +import GHC.Unit.Module.ModDetails + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Control.Concurrent.MVar +import Control.Monad +import qualified Control.Monad.Catch as MC +import Data.IORef +import Data.Maybe +import Data.List (sortOn, groupBy, sortBy) +import qualified Data.List as List +import System.FilePath + +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import qualified Data.Map.Strict as M +import GHC.Types.TypeEnv +import Control.Monad.Trans.State.Lazy +import Control.Monad.Trans.Class +import GHC.Driver.Env.KnotVars +import Control.Monad.Trans.Maybe +import GHC.Runtime.Loader +import GHC.Utils.Constants +import GHC.Iface.Errors.Types +import Data.Function +import qualified GHC.Data.Maybe as M + +import GHC.Data.Graph.Directed.Reachability +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Home.PackageTable + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- | Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- In case of errors, just throw them. +-- +depanal :: GhcMonad m => + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + (errs, mod_graph) <- depanalE mkUnknownDiagnostic Nothing excluded_mods allow_dup_roots + if isEmptyMessages errs + then pure mod_graph + else throwErrors (fmap GhcDriverMessage errs) + +-- | Perform dependency analysis like in 'depanal'. +-- In case of errors, the errors and an empty module graph are returned. +depanalE :: GhcMonad m => -- New for #17459 + (GhcMessage -> AnyGhcDiagnostic) + -> Maybe Messager + -> [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (DriverMessages, ModuleGraph) +depanalE diag_wrapper msg excluded_mods allow_dup_roots = do + hsc_env <- getSession + (errs, mod_graph) <- depanalPartial diag_wrapper msg excluded_mods allow_dup_roots + if isEmptyMessages errs + then do + hsc_env <- getSession + let one_unit_messages get_mod_errs k hue = do + errs <- get_mod_errs + unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph + + let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph + unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph + + + return $ errs `unionMessages` unused_home_mod_err + `unionMessages` unused_pkg_err + `unionMessages` unknown_module_err + + all_errs <- liftIO $ HUG.unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env) + logDiagnostics (GhcDriverMessage <$> all_errs) + setSession (setModuleGraph mod_graph hsc_env) + pure (emptyMessages, mod_graph) + else do + -- We don't have a complete module dependency graph, + -- The graph may be disconnected and is unusable. + setSession (setModuleGraph emptyMG hsc_env) + pure (errs, emptyMG) + + +-- | Perform dependency analysis like 'depanal' but return a partial module +-- graph even in the face of problems with some modules. +-- +-- Modules which have parse errors in the module header, failing +-- preprocessors or other issues preventing them from being summarised will +-- simply be absent from the returned module graph. +-- +-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the +-- new module graph. +depanalPartial + :: GhcMonad m + => (GhcMessage -> AnyGhcDiagnostic) + -> Maybe Messager + -> [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (DriverMessages, ModuleGraph) + -- ^ possibly empty 'Bag' of errors and a module graph. +depanalPartial diag_wrapper msg excluded_mods allow_dup_roots = do + hsc_env <- getSession + let + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + logger = hsc_logger hsc_env + + withTiming logger (text "Chasing dependencies") (const ()) $ do + liftIO $ debugTraceMsg logger 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + -- Home package modules may have been moved or deleted, and new + -- source files may have appeared in the home package that shadow + -- external package modules, so we have to discard the existing + -- cached finder data. + liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) + + (errs, mod_graph) <- liftIO $ downsweep + hsc_env diag_wrapper msg (mgModSummaries old_graph) + excluded_mods allow_dup_roots + return (unionManyMessages errs, mod_graph) + + +-- Note [Missing home modules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Sometimes we don't want GHC to process modules that weren't specified as +-- explicit targets. For example, cabal may want to enable this warning +-- when building a library, so that GHC warns the user about modules listed +-- neither in `exposed-modules` nor in `other-modules`. +-- +-- Here "home module" means a module that doesn't come from another package. +-- +-- For example, if GHC is invoked with modules "A" and "B" as targets, +-- but "A" imports some other module "C", then GHC will issue a warning +-- about module "C" not being listed in the command line. +-- +-- The warning in enabled by `-Wmissing-home-modules`. See #13129 +warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages +warnMissingHomeModules dflags targets mod_graph = + if null missing + then emptyMessages + else warn + where + diag_opts = initDiagOpts dflags + + -- We need to be careful to handle the case where (possibly + -- path-qualified) filenames (aka 'TargetFile') rather than module + -- names are being passed on the GHC command-line. + -- + -- For instance, `ghc --make src-exe/Main.hs` and + -- `ghc --make -isrc-exe Main` are supposed to be equivalent. + -- Note also that we can't always infer the associated module name + -- directly from the filename argument. See #13727. + is_known_module mod = + is_module_target mod + || + maybe False is_file_target (ml_hs_file (ms_location mod)) + + is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets + + is_file_target file = Set.member (withoutExt file) file_targets + + file_targets = Set.fromList (mapMaybe file_target targets) + + file_target Target {targetId} = + case targetId of + TargetModule _ -> Nothing + TargetFile file _ -> + Just (withoutExt (augmentByWorkingDirectory dflags file)) + + mod_targets = Set.fromList (mod_target <$> targets) + + mod_target Target {targetUnitId, targetId} = + case targetId of + TargetModule name -> (name, targetUnitId) + TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId) + + withoutExt = fst . splitExtension + + missing = map (moduleName . ms_mod) $ + filter (not . is_known_module) $ + (filter (\ms -> ms_unitid ms == homeUnitId_ dflags) + (mgModSummaries mod_graph)) + + warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan + $ DriverMissingHomeModules (homeUnitId_ dflags) missing (checkBuildingCabalPackage dflags) + +-- Check that any modules we want to reexport or hide are actually in the package. +warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages +warnUnknownModules hsc_env dflags mod_graph = do + reexported_warns <- filterM check_reexport reexported_mods + return $ final_msgs hidden_warns reexported_warns + where + diag_opts = initDiagOpts dflags + + unit_mods = Set.fromList (map ms_mod_name + (filter (\ms -> ms_unitid ms == homeUnitId_ dflags) + (mgModSummaries mod_graph))) + + reexported_mods = reexportedModules dflags + hidden_mods = hiddenModules dflags + + hidden_warns = hidden_mods `Set.difference` unit_mods + + lookupModule mn = findImportedModule hsc_env mn NoPkgQual + + check_reexport mn = do + fr <- lookupModule (reexportFrom mn) + case fr of + Found _ m -> return (moduleUnitId m == homeUnitId_ dflags) + _ -> return True + + + warn diagnostic = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan + $ diagnostic + + final_msgs hidden_warns reexported_warns + = + unionManyMessages $ + [warn (DriverUnknownHiddenModules (homeUnitId_ dflags) (Set.toList hidden_warns)) | not (Set.null hidden_warns)] + ++ [warn (DriverUnknownReexportedModules (homeUnitId_ dflags) reexported_warns) | not (null reexported_warns)] + +-- | Describes which modules of the module graph need to be loaded. +data LoadHowMuch + = LoadAllTargets + -- ^ Load all targets and its dependencies. + | LoadUpTo [HomeUnitModule] + -- ^ Load only the given modules and its dependencies. + -- If empty, we load none of the targets + | LoadDependenciesOf HomeUnitModule + -- ^ Load only the dependencies of the given module, but not the module + -- itself. + +{- +Note [Caching HomeModInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +API clients who call `load` like to cache the HomeModInfo in memory between +calls to this function. In the old days, this cache was a simple MVar which stored +a HomePackageTable. This was insufficient, as the interface files for boot modules +were not recorded in the cache. In the less old days, the cache was returned at the +end of load, and supplied at the start of load, however, this was not sufficient +because it didn't account for the possibility of exceptions such as SIGINT (#20780). + +So now, in the current day, we have this ModIfaceCache abstraction which +can incrementally be updated during the process of upsweep. This allows us +to store interface files for boot modules in an exception-safe way. + +When the final version of an interface file is completed then it is placed into +the cache. The contents of the cache is retrieved, and the cache cleared, by iface_clearCache. + +Note that because we only store the ModIface and Linkable in the ModIfaceCache, +hydration and rehydration is totally irrelevant, and we just store the CachedIface as +soon as it is completed. + +-} + + +-- Abstract interface to a cache of HomeModInfo +-- See Note [Caching HomeModInfo] +data ModIfaceCache = ModIfaceCache { iface_clearCache :: IO [CachedIface] + , iface_addToCache :: CachedIface -> IO () } + +addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO () +addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l) + +data CachedIface = CachedIface { cached_modiface :: !ModIface + , cached_linkable :: !HomeModLinkable } + +instance Outputable CachedIface where + ppr (CachedIface mi ln) = hsep [text "CachedIface", ppr (miKey mi), ppr ln] + +noIfaceCache :: Maybe ModIfaceCache +noIfaceCache = Nothing + +newIfaceCache :: IO ModIfaceCache +newIfaceCache = do + ioref <- newIORef [] + return $ + ModIfaceCache + { iface_clearCache = atomicModifyIORef' ioref (\c -> ([], c)) + , iface_addToCache = \hmi -> atomicModifyIORef' ioref (\c -> (hmi:c, ())) + } + + + + +-- | Try to load the program. See 'LoadHowMuch' for the different modes. +-- +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the backend (see 'DynFlags.backend' field) compiling +-- and loading may result in files being created on disk. +-- +-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether +-- successful or not. +-- +-- If errors are encountered during dependency analysis, the module `depanalE` +-- returns together with the errors an empty ModuleGraph. +-- After processing this empty ModuleGraph, the errors of depanalE are thrown. +-- All other errors are reported using the 'defaultWarnErrLogger'. + +load :: GhcMonad f => LoadHowMuch -> f SuccessFlag +load how_much = loadWithCache noIfaceCache mkUnknownDiagnostic how_much + +mkBatchMsg :: HscEnv -> Messager +mkBatchMsg hsc_env = + if length (hsc_all_home_unit_ids hsc_env) > 1 + -- This also displays what unit each module is from. + then batchMultiMsg + else batchMsg + + +loadWithCache :: GhcMonad m => Maybe ModIfaceCache -- ^ Instructions about how to cache interfaces as we create them. + -> (GhcMessage -> AnyGhcDiagnostic) -- ^ How to wrap error messages before they are displayed to a user. + -- If you are using the GHC API you can use this to override how messages + -- created during 'loadWithCache' are displayed to the user. + -> LoadHowMuch -- ^ How much `loadWithCache` should load + -> m SuccessFlag +loadWithCache cache diag_wrapper how_much = do + msg <- mkBatchMsg <$> getSession + (errs, mod_graph) <- depanalE diag_wrapper (Just msg) [] False -- #17459 + success <- load' cache how_much diag_wrapper (Just msg) mod_graph + if isEmptyMessages errs + then pure success + else throwErrors (fmap GhcDriverMessage errs) + +-- Note [Unused packages] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- Cabal passes `-package-id` flag for each direct dependency. But GHC +-- loads them lazily, so when compilation is done, we have a list of all +-- actually loaded packages. All the packages, specified on command line, +-- but never loaded, are probably unused dependencies. + +warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages +warnUnusedPackages us dflags mod_graph = + let diag_opts = initDiagOpts dflags + + home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph) + + -- Only need non-source imports here because SOURCE imports are always HPT + loadedPackages = concat $ + mapMaybe (\(_st, fs, mn) -> lookupModulePackage us (unLoc mn) fs) + $ concatMap ms_imps home_mod_sum + + used_args = Set.fromList (map unitId loadedPackages) + + resolve (u,mflag) = do + -- The units which we depend on via the command line explicitly + flag <- mflag + -- Which we can find the UnitInfo for (should be all of them) + ui <- lookupUnit us u + -- Which are not explicitly used + guard (Set.notMember (unitId ui) used_args) + return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag) + + unusedArgs = sortOn (\(u,_,_,_) -> u) $ mapMaybe resolve (explicitUnits us) + + warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs) + + in if null unusedArgs + then emptyMessages + else warn + +-- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any +-- path from module to its boot file. +data ModuleGraphNodeWithBootFile + = ModuleGraphNodeWithBootFile + ModuleGraphNode + -- ^ The module itself (not the hs-boot module) + [NodeKey] + -- ^ The modules in between the module and its hs-boot file, + -- not including the hs-boot file itself. + + +instance Outputable ModuleGraphNodeWithBootFile where + ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps + +-- | A 'BuildPlan' is the result of attempting to linearise a single strongly-connected +-- component of the module graph. +data BuildPlan + -- | A simple, single module all alone (which *might* have an hs-boot file, if it isn't part of a cycle) + = SingleModule ModuleGraphNode + -- | A resolved cycle, linearised by hs-boot files + | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile] + -- | An actual cycle, which wasn't resolved by hs-boot files + | UnresolvedCycle [ModuleGraphNode] + +instance Outputable BuildPlan where + ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn) + ppr (ResolvedCycle mgn) = text "ResolvedCycle:" <+> ppr mgn + ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn + + +-- Just used for an assertion +countMods :: BuildPlan -> Int +countMods (SingleModule _) = 1 +countMods (ResolvedCycle ns) = length ns +countMods (UnresolvedCycle ns) = length ns + +-- See Note [Upsweep] for a high-level description. +createBuildPlan :: ModuleGraph -> Maybe [HomeUnitModule] -> [BuildPlan] +createBuildPlan mod_graph maybe_top_mod = + let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles + cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod + acyclic_mod_graph = topSortModuleGraph False mod_graph maybe_top_mod + + -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles. + build_plan :: [BuildPlan] + build_plan + -- Fast path, if there are no boot modules just do a normal toposort + | isEmptyModuleEnv boot_modules = collapseAcyclic acyclic_mod_graph + | otherwise = toBuildPlan cycle_mod_graph [] + + toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan] + toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn) + toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn) + -- Interesting case + toBuildPlan ((CyclicSCC nodes):sccs) mgn = + let acyclic = collapseAcyclic (topSortWithBoot mgn) + -- Now perform another toposort but just with these nodes and relevant hs-boot files. + -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph. + mresolved_cycle = collapseSCC (topSortWithBoot nodes) + in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs [] + + -- Compute the intermediate modules between a file and its hs-boot file. + -- See Step 2a in Note [Upsweep] + boot_path mn uid = + Set.toList $ + -- Don't include the boot module itself + Set.filter ((/= NodeKey_Module (key IsBoot)) . mkNodeKey) $ + -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are + -- the transitive dependencies of the non-boot file which transitively depend + -- on the boot file. + Set.filter (\(mkNodeKey -> nk) -> + nodeKeyUnitId nk == uid -- Cheap test + && mgQuery mod_graph nk (NodeKey_Module (key IsBoot))) $ + Set.fromList $ + expectJust (mgReachable mod_graph (NodeKey_Module (key NotBoot))) + where + key ib = ModNodeKeyWithUid (GWIB mn ib) uid + + + -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists + boot_modules = mkModuleEnv + [ (mn, (m, boot_path (moduleName mn) (moduleUnitId mn))) + | m@(ModuleNode _ ms) <- mgModSummaries' mod_graph + , let mn = moduleNodeInfoModule ms + , isBootModuleNodeInfo ms == IsBoot] + + select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode] + select_boot_modules = mapMaybe (fmap fst . get_boot_module) + + get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]) + get_boot_module (ModuleNode _ ms) + | NotBoot <- isBootModuleNodeInfo ms + = lookupModuleEnv boot_modules (moduleNodeInfoModule ms) + get_boot_module _ = Nothing + + -- Any cycles should be resolved now + collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] + -- Must be at least two nodes, as we were in a cycle + collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2] + collapseSCC (AcyclicSCC node : nodes) = either (Left . (node :)) (Right . (toNodeWithBoot node :)) (collapseSCC nodes) + -- Cyclic + collapseSCC nodes = Left (flattenSCCs nodes) + + toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile + toNodeWithBoot mn = + case get_boot_module mn of + -- The node doesn't have a boot file + Nothing -> Left mn + -- The node does have a boot file + Just path -> Right (ModuleGraphNodeWithBootFile mn (map mkNodeKey (snd path))) + + -- The toposort and accumulation of acyclic modules is solely to pick-up + -- hs-boot files which are **not** part of cycles. + collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan] + collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes + collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes + collapseAcyclic [] = [] + + topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing + in + -- We need to use 'acyclic_mod_graph', since if 'maybe_top_mod' is 'Just', then the resulting module + -- graph is pruned, reducing the number of 'build_plan' elements. + -- We don't use the size of 'cycle_mod_graph', as it removes @.hi-boot@ modules. These are added + -- later in the processing. + assertPpr (sum (map countMods build_plan) == lengthMGWithSCC acyclic_mod_graph) + (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMGWithSCC acyclic_mod_graph))]) + build_plan + where + lengthMGWithSCC :: [SCC a] -> Int + lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0 + +-- | Generalized version of 'load' which also supports a custom +-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally +-- produced by calling 'depanal'. +load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag +load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do + -- In normal usage plugins are initialised already by ghc/Main.hs this is protective + -- for any client who might interact with GHC via load'. + -- See Note [Timing of plugin initialization] + initializeSessionPlugins + modifySession (setModuleGraph mod_graph) + guessOutputFile + hsc_env <- getSession + + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let interp = hscInterp hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = + Set.fromList [ Module (ms_unitid s) (ms_mod_name s) + | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot] + -- TODO: Figure out what the correct form of this assert is. It's violated + -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot + -- files without corresponding hs files. + -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + -- not (ms_mod_name s `elem` all_home_mods)] + -- assert (null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo ms) = checkMods ms + checkHowMuch (LoadDependenciesOf m) = checkMods [m] + checkHowMuch _ = id + + checkMods ms and_then = + case List.partition (`Set.member` all_home_mods) ms of + (_, []) -> and_then + (_, not_found_mods) -> do + let + mkModuleNotFoundError m = + mkPlainErrorMsgEnvelope noSrcSpan + $ GhcDriverMessage + $ DriverModuleNotFound (moduleUnit m) (moduleName m) + throwErrors $ mkMessages $ listToBag [mkModuleNotFoundError not_found | not_found <- not_found_mods] + + checkHowMuch how_much $ do + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. It is just used for warning about unnecessary source imports. + let mg2_with_srcimps :: [SCC ModuleGraphNode] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps) + + let maybe_top_mods = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just [m] + _ -> Nothing + + build_plan = createBuildPlan mod_graph maybe_top_mods + + + cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache + let + -- prune the HPT so everything is not retained when doing an + -- upsweep. + !pruned_cache = pruneCache cache + [ms | (ModuleNodeCompile ms) <- (flattenSCCs (filterToposortToModules mg2_with_srcimps))] + + + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write an empty HPT to allow the old HPT to be GC'd. + + let pruneHomeUnitEnv hme = do + emptyHPT <- liftIO emptyHomePackageTable + pure $! hme{ homeUnitEnv_hpt = emptyHPT } + hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph $ hsc_unit_env hsc_env) + let ue' = (hsc_unit_env hsc_env){ ue_home_unit_graph = hug' } + setSession $ discardIC hsc_env{hsc_unit_env = ue' } + hsc_env <- getSession + + -- Unload everything + liftIO $ unload interp hsc_env + + liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep") + 2 (ppr build_plan)) + + worker_limit <- liftIO $ mkWorkerLimit dflags + + (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do + hsc_env <- getSession + liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan + + -- At this point, all the HPT variables will be populated, but we don't want + -- to leak the contents of a failed session. + liftIO $ restrictDepsHscEnv new_deps hsc_env + case upsweep_ok of + Failed -> loadFinish upsweep_ok + Succeeded -> do + liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.") + loadFinish upsweep_ok + + + +-- | Finish up after a load. +loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +loadFinish all_ok + = do modifySession discardIC + return all_ok + + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> + -- Force mod_graph to avoid leaking env + let !mod_graph = hsc_mod_graph env + new_home_graph = + flip fmap (hsc_HUG env) $ \hue -> + let dflags = homeUnitEnv_dflags hue + platform = targetPlatform dflags + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + ms <- mgLookupModule mod_graph (mainModIs hue) + ml_hs_file (moduleNodeInfoLocation ms) + name = fmap dropExtension mainModuleSrcPath + + -- MP: This exception is quite sensitive to being forced, if you + -- force it here then the error message is different because it gets + -- caught by a different error handler than the test (T9930fail) expects. + -- Putting an exception into DynFlags is probably not a great design but + -- I'll write this comment rather than more eagerly force the exception. + name_exe = do + -- we must add the .exe extension unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248 + !name' <- case platformArchOS platform of + ArchOS _ OSMinGW32 -> fmap (<.> "exe") name + ArchOS ArchWasm32 _ -> fmap (<.> "wasm") name + _ -> name + mainModuleSrcPath' <- mainModuleSrcPath + -- #9930: don't clobber input files (unless they ask for it) + if name' == mainModuleSrcPath' + then throwGhcException . UsageError $ + "default output name would overwrite the input file; " ++ + "must specify -o explicitly" + else Just name' + in + case outputFile_ dflags of + Just _ -> hue + Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } } + in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } } + +-- ----------------------------------------------------------------------------- +-- +-- | Prune the HomePackageTable +-- +-- Before doing an upsweep, we can throw away: +-- +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. +-- Note [GHC Heap Invariants] +pruneCache :: [CachedIface] + -> [ModSummary] + -> [HomeModInfo] +pruneCache hpt summ + = strictMap prune hpt + where prune (CachedIface { cached_modiface = iface + , cached_linkable = linkable + }) = HomeModInfo iface emptyModDetails linkable' + where + modl = miKey iface + linkable' + | Just ms <- M.lookup modl ms_map + , mi_src_hash iface == Just (ms_hs_hash ms) + = linkable + | otherwise + = emptyHomeModInfoLinkable + + -- Using UFM Module is safe for determinism because the map is just used for a transient lookup. The cache should be unique and a key clash is an error. + ms_map = M.fromListWith + (\ms1 ms2 -> assertPpr False (text "prune_cache" $$ (ppr ms1 <+> ppr ms2)) + ms2) + [(msKey ms, ms) | ms <- summ] + +-- --------------------------------------------------------------------------- +-- +-- | Unloading +unload :: Interp -> HscEnv -> IO () +unload interp hsc_env + = case ghcLink (hsc_dflags hsc_env) of + LinkInMemory -> Linker.unload interp hsc_env [] + _other -> return () + + +{- Parallel Upsweep + +The parallel upsweep attempts to concurrently compile the modules in the +compilation graph using multiple Haskell threads. + +The Algorithm + +* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is +a pair of an `IO a` action and a `MVar a`, where to place the result. + The list is sorted topologically, so can be executed in order without fear of + blocking. +* runPipelines takes this list and eventually passes it to runLoop which executes + each action and places the result into the right MVar. +* The amount of parallelism is controlled by a semaphore. This is just used around the + module compilation step, so that only the right number of modules are compiled at + the same time which reduces overall memory usage and allocations. +* Each proper node has a LogQueue, which dictates where to send it's output. +* The LogQueue is placed into the LogQueueQueue when the action starts and a worker + thread processes the LogQueueQueue printing logs for each module in a stable order. +* The result variable for an action producing `a` is of type `Maybe a`, therefore + it is still filled on a failure. If a module fails to compile, the + failure is propagated through the whole module graph and any modules which didn't + depend on the failure can still be compiled. This behaviour also makes the code + quite a bit cleaner. +-} + + +{- + +Note [--make mode] +~~~~~~~~~~~~~~~~~ +There are two main parts to `--make` mode. + +1. `downsweep`: Starts from the top of the module graph and computes dependencies. +2. `upsweep`: Starts from the bottom of the module graph and compiles modules. + +The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which +computers how to build this ModuleGraph. + +Note [Upsweep] +~~~~~~~~~~~~~~ +Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes +the plan in order to compile the project. + +The first step is computing the build plan from a 'ModuleGraph'. + +The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for +how to build all the modules. + +``` +data BuildPlan = SingleModule ModuleGraphNode -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle + | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot] -- A resolved cycle, linearised by hs-boot files + | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files +``` + +The plan is computed in two steps: + +Step 1: Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains + cycles. +Step 2: For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should + result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle. +Step 2a: For each module in the cycle, if the module has a boot file then compute the + modules on the path between it and the hs-boot file. + These are the intermediate modules which: + (1) are (transitive) dependencies of the non-boot module, and + (2) have the boot module as a (transitive) dependency. + In particular, all such intermediate modules must appear in the same unit as + the module under consideration, as module cycles cannot cross unit boundaries. + This information is stored in ModuleGraphNodeWithBoot. + +The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function. + +* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions. +* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented + with a consistent knot-tied version of modules at the end. + - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration + is performed both before and after the module in question is compiled. + See Note [Hydrating Modules] for more information. +* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files + and are reported as an error to the user. + +The main trickiness of `interpretBuildPlan` is deciding which version of a dependency +is visible from each module. For modules which are not in a cycle, there is just +one version of a module, so that is always used. For modules in a cycle, there are two versions of +'HomeModInfo'. + +1. Internal to loop: The version created whilst compiling the loop by upsweep_mod. +2. External to loop: The knot-tied version created by typecheckLoop. + +Whilst compiling a module inside the loop, we need to use the (1). For a module which +is outside of the loop which depends on something from in the loop, the (2) version +is used. + +As the plan is interpreted, which version of a HomeModInfo is visible is updated +by updating a map held in a state monad. So after a loop has finished being compiled, +the visible module is the one created by typecheckLoop and the internal version is not +used again. + +This plan also ensures the most important invariant to do with module loops: + +> If you depend on anything within a module loop, before you can use the dependency, + the whole loop has to finish compiling. + +The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs +of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running +the action. This list is topologically sorted, so can be run in order to compute +the whole graph. + +As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which +can be queried at the end to get the result of all modules at the end, with their proper +visibility. For example, if any module in a loop fails then all modules in that loop will +report as failed because the visible node at the end will be the result of checking +these modules together. + +-} + +-- | Simple wrapper around MVar which allows a functor instance. +data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a)) + +deriving instance Functor ResultVar + +mkResultVar :: MVar (Maybe a) -> ResultVar a +mkResultVar = ResultVar id + +-- | Block until the result is ready. +waitResult :: ResultVar a -> MaybeT IO a +waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var) + +data BuildResult = BuildResult { _resultOrigin :: ResultOrigin + , resultVar :: ResultVar (Maybe HomeModInfo) + } + +-- The origin of this result var, useful for debugging +data ResultOrigin = NoLoop | Loop ResultLoopOrigin deriving (Show) + +data ResultLoopOrigin = Initialise | Rehydrated | Finalised deriving (Show) + +mkBuildResult :: ResultOrigin -> ResultVar (Maybe HomeModInfo) -> BuildResult +mkBuildResult = BuildResult + + +data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey BuildResult + -- The current way to build a specific TNodeKey, without cycles this just points to + -- the appropriate result of compiling a module but with + -- cycles there can be additional indirection and can point to the result of typechecking a loop + , nNODE :: Int + } + +nodeId :: BuildM Int +nodeId = do + n <- gets nNODE + modify (\m -> m { nNODE = n + 1 }) + return n + + +setModulePipeline :: NodeKey -> BuildResult -> BuildM () +setModulePipeline mgn build_result = do + modify (\m -> m { buildDep = M.insert mgn build_result (buildDep m) }) + +type BuildMap = M.Map NodeKey BuildResult + +getBuildMap :: BuildM BuildMap +getBuildMap = gets buildDep + +getDependencies :: [NodeKey] -> BuildMap -> [BuildResult] +getDependencies direct_deps build_map = + strictMap (expectJust . flip M.lookup build_map) direct_deps + +type BuildM a = StateT BuildLoopState IO a + + + + +-- | Given the build plan, creates a graph which indicates where each NodeKey should +-- get its direct dependencies from. This might not be the corresponding build action +-- if the module participates in a loop. This step also labels each node with a number for the output. +-- See Note [Upsweep] for a high-level description. +interpretBuildPlan :: HomeUnitGraph + -> Maybe ModIfaceCache + -> M.Map ModNodeKeyWithUid HomeModInfo + -> [BuildPlan] + -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle + , [MakeAction] -- Actions we need to run in order to build everything + , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end. +interpretBuildPlan hug mhmi_cache old_hpt plan = do + ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1) + let wait = collect_results (buildDep build_map) + return (mcycle, plans, wait) + + where + collect_results build_map = + sequence (map (\br -> collect_result (resultVar br)) (M.elems build_map)) + where + collect_result res_var = runMaybeT (waitResult res_var) + + -- Just used for an assertion + count_mods :: BuildPlan -> Int + count_mods (SingleModule m) = count_m m + count_mods (ResolvedCycle ns) = length ns + count_mods (UnresolvedCycle ns) = length ns + + count_m (UnitNode {}) = 0 + count_m _ = 1 + + n_mods = sum (map count_mods plan) + + buildLoop :: [BuildPlan] + -> BuildM (Maybe [ModuleGraphNode], [MakeAction]) + -- Build the abstract pipeline which we can execute + -- Building finished + buildLoop [] = return (Nothing, []) + buildLoop (plan:plans) = + case plan of + -- If there was no cycle, then typecheckLoop is not necessary + SingleModule m -> do + one_plan <- buildSingleModule Nothing NoLoop m + (cycle, all_plans) <- buildLoop plans + return (cycle, one_plan : all_plans) + + -- For a resolved cycle, depend on everything in the loop, then update + -- the cache to point to this node rather than directly to the module build + -- nodes + ResolvedCycle ms -> do + pipes <- buildModuleLoop ms + (cycle, graph) <- buildLoop plans + return (cycle, pipes ++ graph) + + -- Can't continue past this point as the cycle is unresolved. + UnresolvedCycle ns -> return (Just ns, []) + + buildSingleModule :: Maybe [NodeKey] -- Modules we need to rehydrate before compiling this module + -> ResultOrigin + -> ModuleGraphNode -- The node we are compiling + -> BuildM MakeAction + buildSingleModule rehydrate_nodes origin mod = do + !build_map <- getBuildMap + -- 1. Get the direct dependencies of this module + let direct_deps = mgNodeDependencies False mod + -- It's really important to force build_deps, or the whole buildMap is retained, + -- which would retain all the result variables, preventing us from collecting them + -- after they are no longer used. + !build_deps = getDependencies direct_deps build_map + !build_action <- + case mod of + InstantiationNode uid iu -> do + mod_idx <- nodeId + return $ withCurrentUnit (mgNodeUnitId mod) $ do + !_ <- wait_deps build_deps + executeInstantiationNode mod_idx n_mods hug uid iu + return Nothing + ModuleNode _build_deps ms -> do + let !old_hmi = M.lookup (mnKey ms) old_hpt + rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes + mod_idx <- nodeId + return $ withCurrentUnit (mgNodeUnitId mod) $ do + !_ <- wait_deps build_deps + hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms + -- Write the HMI to an external cache (if one exists) + -- See Note [Caching HomeModInfo] + liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi + -- Make sure the result is written to the HPT var + liftIO $ HUG.addHomeModInfoToHug hmi hug + return (Just hmi) + LinkNode _nks uid -> do + mod_idx <- nodeId + return $ withCurrentUnit (mgNodeUnitId mod) $ do + !_ <- wait_deps build_deps + executeLinkNode hug (mod_idx, n_mods) uid direct_deps + return Nothing + UnitNode {} -> return $ return Nothing + + + res_var <- liftIO newEmptyMVar + let result_var = mkResultVar res_var + setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var) + return $! (MakeAction build_action res_var) + + + buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction] + buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) = do + ma <- buildSingleModule (Just deps) (Loop Initialise) mn + -- Rehydration (1) from Note [Hydrating Modules], "Loops with multiple boot files" + rehydrate_action <- rehydrateAction Rehydrated ((GWIB (mkNodeKey mn) IsBoot) : (map (\d -> GWIB d NotBoot) deps)) + return $ [ma, rehydrate_action] + + + buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction] + buildModuleLoop ms = do + build_modules <- concatMapM (either (fmap (:[]) <$> buildSingleModule Nothing (Loop Initialise)) buildOneLoopyModule) ms + let extract (Left mn) = GWIB (mkNodeKey mn) NotBoot + extract (Right (ModuleGraphNodeWithBootFile mn _)) = GWIB (mkNodeKey mn) IsBoot + let loop_mods = map extract ms + -- Rehydration (2) from Note [Hydrating Modules], "Loops with multiple boot files" + -- Fixes the space leak described in that note. + rehydrate_action <- rehydrateAction Finalised loop_mods + + return $ build_modules ++ [rehydrate_action] + + -- An action which rehydrates the given keys + rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction + rehydrateAction origin deps = do + !build_map <- getBuildMap + res_var <- liftIO newEmptyMVar + let loop_unit :: UnitId + !loop_unit = nodeKeyUnitId (gwib_mod (head deps)) + !build_deps = getDependencies (map gwib_mod deps) build_map + let loop_action = withCurrentUnit loop_unit $ do + !_ <- wait_deps build_deps + hsc_env <- asks hsc_env + let mns :: [ModuleName] + mns = mapMaybe (nodeKeyModName . gwib_mod) deps + + hmis' <- liftIO $ rehydrateAfter hsc_env mns + + checkRehydrationInvariant hmis' deps + + -- Add hydrated interfaces to global variable + liftIO $ mapM_ (\hmi -> HUG.addHomeModInfoToHug hmi hug) hmis' + return hmis' + + let fanout i = Just . (!! i) <$> mkResultVar res_var + -- From outside the module loop, anyone must wait for the loop to finish and then + -- use the result of the rehydrated iface. This makes sure that things not in the + -- module loop will see the updated interfaces for all the identifiers in the loop. + boot_key :: NodeKey -> NodeKey + boot_key (NodeKey_Module m) = NodeKey_Module (m { mnkModuleName = (mnkModuleName m) { gwib_isBoot = IsBoot } } ) + boot_key k = pprPanic "boot_key" (ppr k) + + update_module_pipeline (m, i) = + case gwib_isBoot m of + NotBoot -> setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i)) + IsBoot -> do + setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i)) + -- SPECIAL: Anything outside the loop needs to see A rather than A.hs-boot + setModulePipeline (boot_key (gwib_mod m)) (mkBuildResult (Loop origin) (fanout i)) + + let deps_i = zip deps [0..] + mapM update_module_pipeline deps_i + + return $ MakeAction loop_action res_var + + -- Checks that the interfaces returned from hydration match-up with the names of the + -- modules which were fed into the function. + checkRehydrationInvariant hmis deps = + let hmi_names = map (moduleName . mi_module . hm_iface) hmis + start = mapMaybe (nodeKeyModName . gwib_mod) deps + in massertPpr (hmi_names == start) $ (ppr hmi_names $$ ppr start) + + +withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a +withCurrentUnit uid = do + local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)}) + +upsweep + :: WorkerLimit -- ^ The number of workers we wish to run in parallel + -> HscEnv -- ^ The base HscEnv, which is augmented for each module + -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to + -> (GhcMessage -> AnyGhcDiagnostic) + -> Maybe Messager + -> M.Map ModNodeKeyWithUid HomeModInfo + -> [BuildPlan] + -> IO (SuccessFlag, [HomeModInfo]) +upsweep n_jobs hsc_env hmi_cache diag_wrapper mHscMessage old_hpt build_plan = do + (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan + runPipelines n_jobs hsc_env diag_wrapper mHscMessage pipelines + res <- collect_result + + let completed = [m | Just (Just m) <- res] + + -- Handle any cycle in the original compilation graph and return the result + -- of the upsweep. + case cycle of + Just mss -> do + throwOneError $ cyclicModuleErr mss + Nothing -> do + let success_flag = successIf (all isJust res) + return (success_flag, completed) + +toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo +toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis]) + +upsweep_inst :: HscEnv + -> Maybe Messager + -> Int -- index of module + -> Int -- total number of modules + -> UnitId + -> InstantiatedUnit + -> IO () +upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do + case mHscMessage of + Just hscMessage -> hscMessage hsc_env (mod_index, nmods) (NeedsRecompile MustCompile) (InstantiationNode uid iuid) + Nothing -> return () + runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid + pure () + +-- | Compile a single module. Always produce a Linkable for it if +-- successful. If no compilation happened, return the old Linkable. +upsweep_mod :: HscEnv + -> Maybe Messager + -> Maybe HomeModInfo + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> IO HomeModInfo +upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do + hmi <- compileOne' mHscMessage hsc_env summary + mod_index nmods (hm_iface <$> old_hmi) (maybe emptyHomeModInfoLinkable hm_linkable old_hmi) + + -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module + -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I + -- am unsure if this is sound (wrt running TH splices for example). + -- This function only does anything if the linkable produced is a BCO, which + -- used to only happen with the bytecode backend, but with + -- @-fprefer-byte-code@, @HomeModInfo@ has bytecode even when generating + -- object code, see #25230. + hscInsertHPT hmi hsc_env + addSptEntries (hsc_env) + (homeModInfoByteCode hmi) + + return hmi + +-- | Add the entries from a BCO linkable to the SPT table, see +-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. +addSptEntries :: HscEnv -> Maybe Linkable -> IO () +addSptEntries hsc_env mlinkable = + hscAddSptEntries hsc_env + [ spt + | linkable <- maybeToList mlinkable + , bco <- linkableBCOs linkable + , spt <- bc_spt_entries bco + ] + + +-- Note [When source is considered modified] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A number of functions in GHC.Driver accept a SourceModified argument, which +-- is part of how GHC determines whether recompilation may be avoided (see the +-- definition of the SourceModified data type for details). +-- +-- Determining whether or not a source file is considered modified depends not +-- only on the source file itself, but also on the output files which compiling +-- that module would produce. This is done because GHC supports a number of +-- flags which control which output files should be produced, e.g. -fno-code +-- -fwrite-interface and -fwrite-ide-file; we must check not only whether the +-- source file has been modified since the last compile, but also whether the +-- source file has been modified since the last compile which produced all of +-- the output files which have been requested. +-- +-- Specifically, a source file is considered unmodified if it is up-to-date +-- relative to all of the output files which have been requested. Whether or +-- not an output file is up-to-date depends on what kind of file it is: +-- +-- * iface (.hi) files are considered up-to-date if (and only if) their +-- mi_src_hash field matches the hash of the source file, +-- +-- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date +-- if (and only if) their modification times on the filesystem are greater +-- than or equal to the modification time of the corresponding .hi file. +-- +-- Why do we use '>=' rather than '>' for output files other than the .hi file? +-- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a +-- resolution of 2 seconds), we may often find that the .hi and .o files have +-- the same modification time. Using >= is slightly unsafe, but it matches +-- make's behaviour. +-- +-- This strategy allows us to do the minimum work necessary in order to ensure +-- that all the files the user cares about are up-to-date; e.g. we should not +-- worry about .o files if the user has indicated that they are not interested +-- in them via -fno-code. See also #9243. +-- +-- Note that recompilation avoidance is dependent on .hi files being produced, +-- which does not happen if -fno-write-interface -fno-code is passed. That is, +-- passing -fno-write-interface -fno-code means that you cannot benefit from +-- recompilation avoidance. See also Note [-fno-code mode]. +-- +-- The correctness of this strategy depends on an assumption that whenever we +-- are producing multiple output files, the .hi file is always written first. +-- If this assumption is violated, we risk recompiling unnecessarily by +-- incorrectly regarding non-.hi files as outdated. +-- + +-- --------------------------------------------------------------------------- +-- +-- | Topological sort of the module graph +topSortModuleGraph + :: Bool + -- ^ Drop hi-boot nodes? (see below) + -> ModuleGraph + -> Maybe [HomeUnitModule] + -- ^ Root module name. If @Nothing@, use the full graph. + -> [SCC ModuleGraphNode] +-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. +-- +-- Drop hi-boot nodes (first boolean arg)? +-- +-- - @False@: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic +-- +-- - @True@: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can be cyclic +topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod = + topSortModules drop_hs_boot_nodes + (sortBy (cmpModuleGraphNodes `on` mkNodeKey) $ mgModSummaries' module_graph) + mb_root_mod + + + where + -- In order to get the "right" ordering + -- Module nodes must be in reverse lexigraphic order. + -- All modules nodes must appear before package nodes. + -- + -- MP: This is just the ordering which the tests needed in Jan 2025, it does + -- not arise from nature. + -- + -- Given the current implementation of scc, the result is in + -- The order is sensitive to the internal implementation in Data.Graph, + -- if it changes in future then this ordering will need to be modified. + -- + -- The SCC algorithm firstly transposes the input graph and then + -- performs dfs on the vertices in the order which they are originally given. + -- Therefore, if `ExternalUnit` nodes are first, the order returned will + -- be determined by the order the dependencies are stored in the transposed graph. + moduleGraphNodeRank :: NodeKey -> Int + moduleGraphNodeRank k = + case k of + NodeKey_Unit {} -> 0 + NodeKey_Module {} -> 1 + NodeKey_Link {} -> 2 + NodeKey_ExternalUnit {} -> 3 + + cmpModuleGraphNodes k1 k2 = compare (moduleGraphNodeRank k1) (moduleGraphNodeRank k2) + `mappend` compare k2 k1 + +topSortModules :: Bool -> [ModuleGraphNode] -> Maybe [HomeUnitModule] -> [SCC ModuleGraphNode] +topSortModules drop_hs_boot_nodes summaries mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + (graph, lookup_node) = + moduleGraphNodes drop_hs_boot_nodes summaries + + initial_graph = case mb_root_mod of + Nothing -> graph + Just mods -> + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + let + findNodeForModule (Module uid root_mod) + | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid + , graph `hasVertexG` node + = seq node node + | otherwise + = throwGhcException (ProgramError "module does not exist") + roots = fmap findNodeForModule mods + in graphFromEdgedVerticesUniq (seq roots (roots ++ allReachableMany (graphReachability graph) roots)) + +newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a } + deriving (Functor, Traversable, Foldable) + +emptyModNodeMap :: ModNodeMap a +emptyModNodeMap = ModNodeMap Map.empty + +modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a +modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m) + +modNodeMapElems :: ModNodeMap a -> [a] +modNodeMapElems (ModNodeMap m) = Map.elems m + +modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a +modNodeMapLookup k (ModNodeMap m) = Map.lookup k m + +modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a +modNodeMapSingleton k v = ModNodeMap (M.singleton k v) + +modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a +modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n) + +-- | If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModuleNodeInfo] -> m () +warnUnnecessarySourceImports sccs = do + diag_opts <- initDiagOpts <$> getDynFlags + when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do + let check ms = + let mods_in_this_cycle = map moduleNodeInfoModuleName ms in + [ warn i | (ModuleNodeCompile m) <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: Located ModuleName -> MsgEnvelope GhcMessage + warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts + loc (DriverUnnecessarySourceImports mod) + logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs)) + + +----------------------------------------------------------------------------- +-- Error messages +----------------------------------------------------------------------------- + +-- Defer and group warning, error and fatal messages so they will not get lost +-- in the regular output. +withDeferredDiagnostics :: GhcMonad m => m a -> m a +withDeferredDiagnostics f = do + dflags <- getDynFlags + if not $ gopt Opt_DeferDiagnostics dflags + then f + else do + warnings <- liftIO $ newIORef [] + errors <- liftIO $ newIORef [] + fatals <- liftIO $ newIORef [] + logger <- getLogger + + let deferDiagnostics _dflags !msgClass !srcSpan !msg = do + let action = logMsg logger msgClass srcSpan msg + case msgClass of + MCDiagnostic SevWarning _reason _code + -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) + MCDiagnostic SevError _reason _code + -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) + MCFatal + -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) + _ -> action + + printDeferredDiagnostics = liftIO $ + forM_ [warnings, errors, fatals] $ \ref -> do + -- This IORef can leak when the dflags leaks, so let us always + -- reset the content. The lazy variant is used here as we want to force + -- this error if the IORef is ever accessed again, rather than now. + -- See #20981 for an issue which discusses this general issue. + let landmine = if debugIsOn then panic "withDeferredDiagnostics: use after free" else [] + actions <- atomicModifyIORef ref $ \i -> (landmine, i) + sequence_ $ reverse actions + + MC.bracket + (pushLogHookM (const deferDiagnostics)) + (\_ -> popLogHookM >> printDeferredDiagnostics) + (\_ -> f) + +noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage +-- ToDo: we don't have a proper line number for this error +noModError hsc_env loc wanted_mod err + = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ + DriverInterfaceError $ + (Can'tFindInterface (cannotFindModule hsc_env wanted_mod err) (LookingForModule wanted_mod NotBoot)) + +{- +noHsFileErr :: SrcSpan -> String -> DriverMessages +noHsFileErr loc path + = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path) + -} + + + +cyclicModuleErr :: [ModuleGraphNode] -> MsgEnvelope GhcMessage +-- From a strongly connected component we find +-- a single cycle to report +cyclicModuleErr mss + = assert (not (null mss)) $ + case findCycle graph of + Nothing -> pprPanic "Unexpected non-cycle" (ppr mss) + Just path -> mkPlainErrorMsgEnvelope src_span $ + GhcDriverMessage $ DriverModuleGraphCycle path + where + src_span = maybe noSrcSpan (mkFileSrcSpan . moduleNodeInfoLocation) (mgNodeIsModule (head path)) + where + graph :: [Node NodeKey ModuleGraphNode] + graph = + [ DigraphNode + { node_payload = ms + , node_key = mkNodeKey ms + , node_dependencies = mgNodeDependencies False ms + } + | ms <- mss + ] + +cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m () +cleanCurrentModuleTempFilesMaybe logger tmpfs dflags = + if gopt Opt_KeepTmpFiles dflags + then liftIO $ keepCurrentModuleTempFiles logger tmpfs + else liftIO $ cleanCurrentModuleTempFiles logger tmpfs + + +-- | Thin each HPT variable to only contain keys from the given dependencies. +-- This is used at the end of upsweep to make sure that only completely successfully loaded +-- modules are visible for subsequent operations. +restrictDepsHscEnv :: [HomeModInfo] -> HscEnv -> IO () +restrictDepsHscEnv deps hsc_env = + let deps_with_unit = map (\xs -> (fst (head xs), map snd xs)) $ groupBy ((==) `on` fst) (sortOn fst (map go deps)) + hug = ue_home_unit_graph $ hsc_unit_env hsc_env + go hmi = (hmi_unit, hmi) + where + hmi_mod = mi_module (hm_iface hmi) + hmi_unit = toUnitId (moduleUnit hmi_mod) + in HUG.restrictHug deps_with_unit hug + + +setHUG :: HomeUnitGraph -> HscEnv -> HscEnv +setHUG deps hsc_env = + hscUpdateHUG (const $ deps) hsc_env + +-- | Wrap an action to catch and handle exceptions. +wrapAction :: (GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a) +wrapAction msg_wrapper hsc_env k = do + let lcl_logger = hsc_logger hsc_env + lcl_dynflags = hsc_dflags hsc_env + print_config = initPrintConfig lcl_dynflags + logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (msg_wrapper <$> srcErrorMessages err) + -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle + -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches` + -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to + -- internally using forkIO. + mres <- MC.try $ prettyPrintGhcErrors lcl_logger $ k + case mres of + Right res -> return $ Just res + Left exc -> do + case fromException exc of + Just (err :: SourceError) + -> logg err + Nothing -> case fromException exc of + -- ThreadKilled in particular needs to actually kill the thread. + -- So rethrow that and the other async exceptions + Just (err :: SomeAsyncException) -> throwIO err + _ -> errorMsg lcl_logger (text (show exc)) + return Nothing + + + + +executeInstantiationNode :: Int + -> Int + -> HomeUnitGraph + -> UnitId + -> InstantiatedUnit + -> RunMakeM () +executeInstantiationNode k n deps uid iu = do + env <- ask + -- Output of the logger is mediated by a central worker to + -- avoid output interleaving + msg <- asks env_messager + wrapper <- asks diag_wrapper + lift $ MaybeT $ withLoggerHsc k env $ \hsc_env -> + let lcl_hsc_env = setHUG deps hsc_env + in wrapAction wrapper lcl_hsc_env $ do + res <- upsweep_inst lcl_hsc_env msg k n uid iu + cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) + return res + + +-- | executeCompileNode interprets how --make module should compile a ModuleNode +-- +-- 1. If the ModuleNode is a ModuleNodeCompile, then we first check +-- if the interface file exists and is up to date. If it is, we return those. +-- Otherwise, we compile the module and return the new HomeModInfo. +-- 2. If the ModuleNode is a ModuleNodeFixed, then we just need to load the interface +-- and artifacts from disk. + +executeCompileNode :: Int + -> Int + -> Maybe HomeModInfo + -> HomeUnitGraph + -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling + -> ModuleNodeInfo + -> RunMakeM HomeModInfo +executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do + me@MakeEnv{..} <- ask + -- Rehydrate any dependencies if this module had a boot file or is a signature file. + lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do + hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mni fixed_mrehydrate_mods + case mni of + ModuleNodeCompile mod -> executeCompileNodeWithSource hsc_env' me mod + ModuleNodeFixed key loc -> executeCompileNodeFixed hsc_env' me key loc + ) + + where + fixed_mrehydrate_mods = + case moduleNodeInfoHscSource mni of + -- MP: It is probably a bit of a misimplementation in backpack that + -- compiling a signature requires an knot_var for that unit. + -- If you remove this then a lot of backpack tests fail. + Just HsigFile -> Just [] + _ -> mrehydrate_mods + + executeCompileNodeFixed :: HscEnv -> MakeEnv -> ModNodeKeyWithUid -> ModLocation -> IO (Maybe HomeModInfo) + executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod loc = + wrapAction diag_wrapper hsc_env $ do + forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod loc)) + read_result <- readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc) + case read_result of + M.Failed interface_err -> + let mn = mnkModuleName mod + err = Can'tFindInterface (BadIfaceFile interface_err) (LookingForModule (gwib_mod mn) (gwib_isBoot mn)) + in throwErrors $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (GhcDriverMessage (DriverInterfaceError err)) + M.Succeeded iface -> do + details <- genModDetails hsc_env iface + mb_object <- findObjectLinkableMaybe (mi_module iface) loc + mb_bytecode <- loadIfaceByteCodeLazy hsc_env iface loc (md_types details) + let hm_linkable = HomeModLinkable mb_bytecode mb_object + return (HomeModInfo iface details hm_linkable) + + executeCompileNodeWithSource :: HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo) + executeCompileNodeWithSource hsc_env MakeEnv{diag_wrapper, env_messager} mod = do + let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas + lcl_dynflags = ms_hspp_opts mod + let lcl_hsc_env = + -- Localise the hsc_env to use the cached flags + hscSetFlags lcl_dynflags $ + hsc_env + -- Compile the module, locking with a semaphore to avoid too many modules + -- being compiled at the same time leading to high memory usage. + wrapAction diag_wrapper lcl_hsc_env $ do + res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n + cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags + return res + + +{- Rehydration, see Note [Rehydrating Modules] -} + +rehydrate :: HscEnv -- ^ The HPT in this HscEnv needs rehydrating. + -> [HomeModInfo] -- ^ These are the modules we want to rehydrate. + -> IO [HomeModInfo] +rehydrate hsc_env hmis = do + debugTraceMsg logger 2 $ ( + text "Re-hydrating loop: " <+> (ppr (map (mi_module . hm_iface) hmis))) + -- When the HPT was pure we had to tie a knot to update the ModDetails in the + -- HPT required to update those ModDetails, but since it was made an IORef we + -- just have to make sure the new ModDetails are "reset" so that the new + -- modules are looked up in HPT when it is forced. If we didn't "reset" the + -- ModDetails, modules in a loop would refer the wrong (hs-boot) definitions + -- (as explained in Note [Rehydrating Modules]). + mds <- initIfaceCheck (text "rehydrate") hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_mods = [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds + ] + return new_mods + + where + logger = hsc_logger hsc_env + +-- If needed, then rehydrate the necessary modules with a suitable KnotVars for the +-- module currently being compiled. +maybeRehydrateBefore :: HscEnv -> ModuleNodeInfo -> Maybe [ModuleName] -> IO HscEnv +maybeRehydrateBefore hsc_env _ Nothing = return hsc_env +maybeRehydrateBefore hsc_env mni (Just mns) = do + knot_var <- initialise_knot_var hsc_env + let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var } + hmis <- mapM (fmap expectJust . lookupHpt (hsc_HPT hsc_env')) mns + hmis' <- rehydrate hsc_env' hmis + mapM_ (\hmi -> HUG.addHomeModInfoToHug hmi (hsc_HUG hsc_env')) hmis' + return hsc_env' + + where + initialise_knot_var hsc_env = liftIO $ + let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni) + in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv + +rehydrateAfter :: HscEnv + -> [ModuleName] + -> IO [HomeModInfo] +rehydrateAfter hsc mns = do + let hpt = hsc_HPT hsc + hmis <- mapM (fmap expectJust . lookupHpt hpt) mns + rehydrate (hsc { hsc_type_env_vars = emptyKnotVars }) hmis + +{- +Note [Hydrating Modules] +~~~~~~~~~~~~~~~~~~~~~~~~ +There are at least 4 different representations of an interface file as described +by this diagram. + +------------------------------ +| On-disk M.hi | +------------------------------ + | ^ + | Read file | Write file + V | +------------------------------- +| ByteString | +------------------------------- + | ^ + | Binary.get | Binary.put + V | +-------------------------------- +| ModIface (an acyclic AST) | +-------------------------------- + | ^ + | hydrate | mkIfaceTc + V | +--------------------------------- +| ModDetails (lots of cycles) | +--------------------------------- + +The last step, converting a ModIface into a ModDetails is known as "hydration". + +Hydration happens in three different places + +* When an interface file is initially loaded from disk, it has to be hydrated. +* When a module is finished compiling, we hydrate the ModIface in order to generate + the version of ModDetails which exists in memory (see Note [ModDetails and --make mode]) +* When dealing with boot files and module loops (see Note [Rehydrating Modules]) + +Note [Rehydrating Modules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a module has a boot file then it is critical to rehydrate the modules on +the path between the two (see #20561). + +Suppose we have ("R" for "recursive"): +``` +R.hs-boot: module R where + data T + g :: T -> T + +A.hs: module A( f, T, g ) where + import {-# SOURCE #-} R + data S = MkS T + f :: T -> S = ...g... + +R.hs: module R where + import A + data T = T1 | T2 S + g = ...f... +``` + +== Why we need to rehydrate A's ModIface before compiling R.hs + +After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type +that uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same +AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about +it.) + +When compiling R.hs, we build a TyCon for `T`. But that TyCon mentions `S`, and +it currently has an AbstractTyCon for `T` inside it. But we want to build a +fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`. + +Solution: **rehydration**. *Before compiling `R.hs`*, rehydrate all the +ModIfaces below it that depend on R.hs-boot. To rehydrate a ModIface, call +`typecheckIface` to convert it to a ModDetails. It's just a de-serialisation +step, no type inference, just lookups. + +Now `S` will be bound to a thunk that, when forced, will "see" the final binding +for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot). +But note that this must be done *before* compiling R.hs. + +== Why we need to rehydrate A's ModIface after compiling R.hs + +When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding +mentions the `LocalId` for `g`. But when we finish R, we carefully ensure that +all those `LocalIds` are turned into completed `GlobalIds`, replete with +unfoldings etc. Alas, that will not apply to the occurrences of `g` in `f`'s +unfolding. And if we leave matters like that, they will stay that way, and *all* +subsequent modules that import A will see a crippled unfolding for `f`. + +Solution: rehydrate both R and A's ModIface together, right after completing R.hs. + +~~ Which modules to rehydrate + +We only need rehydrate modules that are +* Below R.hs +* Above R.hs-boot + +There might be many unrelated modules (in the home package) that don't need to be +rehydrated. + +== Loops with multiple boot files + +It is possible for a module graph to have a loop (SCC, when ignoring boot files) +which requires multiple boot files to break. In this case, we must perform +several hydration steps: + 1. The hydration steps described above, which are necessary for correctness. + 2. An extra hydration step at the end of compiling the entire SCC, in order to + remove space leaks, as we explain below. + +Consider the following example: + + ┌─────┐ ┌─────┐ + │ A │ │ B │ + └──┬──┘ └──┬──┘ + │ │ + ┌───▼───────────▼───┐ + │ C │ + └───┬───────────┬───┘ + │ │ + ┌────▼───┐ ┌───▼────┐ + │ A-boot │ │ B-boot │ + └────────┘ └────────┘ + +A, B and C live together in a SCC. Suppose that we compile the modules in the +order: + + A-boot, B-boot, C, A, B. + +When we come to compile A, we will perform the necessary hydration steps, +because A has a boot file. This means that C will be hydrated relative to A, +and the ModDetails for A will reference C/A. Then, when B is compiled, +C will be rehydrated again, and so B will reference C/A,B. At this point, +its interface will be hydrated relative to both A and B. +This causes a space leak: there are now two different copies of C's ModDetails, +kept alive by modules A and B. This is especially problematic if C is large. + +The way to avoid this space leak is to rehydrate an entire SCC together at the +end of compilation, so that all the ModDetails point to interfaces for .hs files. +In this example, when we hydrate A, B and C together, then both A and B will refer to +C/A,B. + +See #21900 for some more discussion. + +== Modules "above" the loop + +This dark corner is the subject of #14092. + +Suppose we add to our example +``` +X.hs module X where + import A + data XT = MkX T + fx = ...g... +``` +If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the argument type of `MkX`. So: + +* Either we should delay compiling X until after R has been compiled. (This is what we do) +* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot. + +Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode. +#20200 has lots of issues, many of them now fixed; +this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758). + +The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful. +Also closely related are + * #14092 + * #14103 + +-} + +executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM () +executeLinkNode hug kn uid deps = do + withCurrentUnit uid $ do + MakeEnv{..} <- ask + let dflags = hsc_dflags hsc_env + let hsc_env' = setHUG hug hsc_env + msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager + + linkresult <- liftIO $ withAbstractSem compile_sem $ do + link (ghcLink dflags) + (hsc_logger hsc_env') + (hsc_tmpfs hsc_env') + (hsc_FC hsc_env') + (hsc_hooks hsc_env') + dflags + (hsc_unit_env hsc_env') + True -- We already decided to link + msg' + (hsc_HPT hsc_env') + case linkresult of + Failed -> fail "Link Failed" + Succeeded -> return () + +-- | Wait for dependencies to finish, and then return their results. +wait_deps :: [BuildResult] -> RunMakeM [HomeModInfo] +wait_deps [] = return [] +wait_deps (x:xs) = do + res <- lift $ waitResult (resultVar x) + hmis <- wait_deps xs + case res of + Nothing -> return hmis + Just hmi -> return (hmi:hmis) + + +{- Note [GHC Heap Invariants] + ~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note is a general place to explain some of the heap invariants which should +hold for a program compiled with --make mode. These invariants are all things +which can be checked easily using ghc-debug. + +1. No HomeModInfo are reachable via the EPS. + Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains + a reference to the entire HscEnv, if we are not careful the HscEnv will + contain the HomePackageTable at the time the interface was loaded and + it will never be released. + Where? dontLeakTheHUG in GHC.Iface.Load + +2. No KnotVars are live at the end of upsweep (#20491) + Why? KnotVars contains an old stale reference to the TypeEnv for modules + which participate in a loop. At the end of a loop all the KnotVars references + should be removed by the call to typecheckLoop. + Where? typecheckLoop in GHC.Driver.Make. + +3. Immediately after a reload, no ModDetails are live. + Why? During the upsweep all old ModDetails are replaced with a new ModDetails + generated from a ModIface. If we don't clear the ModDetails before the + reload takes place then memory usage during the reload is twice as much + as it should be as we retain a copy of the ModDetails for too long. + Where? pruneCache in GHC.Driver.Make + +4. No TcGblEnv or TcLclEnv are live after typechecking is completed. + Why? By the time we get to simplification all the data structures from typechecking + should be eliminated. + Where? No one place in the compiler. These leaks can be introduced by not suitable + forcing functions which take a TcLclEnv as an argument. + +5. At the end of a successful upsweep, the number of live ModDetails equals the + number of non-boot Modules. + Why? Each module has a HomeModInfo which contains a ModDetails from that module. +-} diff --git a/GHC/Driver/MakeAction.hs b/GHC/Driver/MakeAction.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/MakeAction.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE CPP #-} +module GHC.Driver.MakeAction + ( MakeAction(..) + , MakeEnv(..) + , RunMakeM + -- * Running the pipelines + , runAllPipelines + , runParPipelines + , runSeqPipelines + , runPipelines + -- * Worker limit + , WorkerLimit(..) + , mkWorkerLimit + , runWorkerLimit + -- * Utility + , withLoggerHsc + , withParLog + , withLocalTmpFS + , withLocalTmpFSMake + ) where + +import GHC.Prelude +import GHC.Driver.DynFlags + +import GHC.Driver.Monad +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import GHC.Driver.Messager +import GHC.Driver.MakeSem + +import GHC.Utils.Logger +import GHC.Utils.TmpFs + +import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) +import qualified GHC.Conc as CC +import Control.Concurrent.MVar +import Control.Monad +import qualified Control.Monad.Catch as MC + +import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) +import Control.Monad.Trans.Reader +import GHC.Driver.Pipeline.LogQueue +import Control.Concurrent.STM +import Control.Monad.Trans.Maybe + +-- Executing the pipelines + +mkWorkerLimit :: DynFlags -> IO WorkerLimit +mkWorkerLimit dflags = + case parMakeCount dflags of + Nothing -> pure $ num_procs 1 + Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h)) + Just ParMakeNumProcessors -> num_procs <$> getNumProcessors + Just (ParMakeThisMany n) -> pure $ num_procs n + where + num_procs x = NumProcessorsLimit (max 1 x) + +isWorkerLimitSequential :: WorkerLimit -> Bool +isWorkerLimitSequential (NumProcessorsLimit x) = x <= 1 +isWorkerLimitSequential (JSemLimit {}) = False + +-- | This describes what we use to limit the number of jobs, either we limit it +-- ourselves to a specific number or we have an external parallelism semaphore +-- limit it for us. +data WorkerLimit + = NumProcessorsLimit Int + | JSemLimit + SemaphoreName + -- ^ Semaphore name to use + deriving Eq + +-- | Environment used when compiling a module +data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module + , compile_sem :: !AbstractSem + -- Modify the environment for module k, with the supplied logger modification function. + -- For -j1, this wrapper doesn't do anything + -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output + -- into the log queue. + , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a + , env_messager :: !(Maybe Messager) + , diag_wrapper :: GhcMessage -> AnyGhcDiagnostic + } + + +label_self :: String -> IO () +label_self thread_name = do + self_tid <- CC.myThreadId + CC.labelThread self_tid thread_name + + +runPipelines :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO () +-- Don't even initialise plugins if there are no pipelines +runPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines = do + liftIO $ label_self "main --make thread" + case n_job of + NumProcessorsLimit n | n <= 1 -> runSeqPipelines hsc_env diag_wrapper mHscMessager all_pipelines + _n -> runParPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines + +runSeqPipelines :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO () +runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines = + let env = MakeEnv { hsc_env = plugin_hsc_env + , withLogger = \_ k -> k id + , compile_sem = AbstractSem (return ()) (return ()) + , env_messager = mHscMessager + , diag_wrapper = diag_wrapper + } + in runAllPipelines (NumProcessorsLimit 1) env all_pipelines + +runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a +runNjobsAbstractSem n_jobs action = do + compile_sem <- newQSem n_jobs + n_capabilities <- getNumCapabilities + n_cpus <- getNumProcessors + let + asem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem) + set_num_caps n = unless (n_capabilities /= 1) $ setNumCapabilities n + updNumCapabilities = do + -- Setting number of capabilities more than + -- CPU count usually leads to high userspace + -- lock contention. #9221 + set_num_caps $ min n_jobs n_cpus + resetNumCapabilities = set_num_caps n_capabilities + MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem + +runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a +#if defined(wasm32_HOST_ARCH) +runWorkerLimit _ action = do + lock <- newMVar () + action $ AbstractSem (takeMVar lock) (putMVar lock ()) +#else +runWorkerLimit worker_limit action = case worker_limit of + NumProcessorsLimit n_jobs -> + runNjobsAbstractSem n_jobs action + JSemLimit sem -> + runJSemAbstractSem sem action +#endif + +-- | Build and run a pipeline +runParPipelines :: WorkerLimit -- ^ How to limit work parallelism + -> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module + -> (GhcMessage -> AnyGhcDiagnostic) + -> Maybe Messager -- ^ Optional custom messager to use to report progress + -> [MakeAction] -- ^ The build plan for all the module nodes + -> IO () +runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipelines = do + + + -- A variable which we write to when an error has happened and we have to tell the + -- logging thread to gracefully shut down. + stopped_var <- newTVarIO False + -- The queue of LogQueues which actions are able to write to. When an action starts it + -- will add it's LogQueue into this queue. + log_queue_queue_var <- newTVarIO newLogQueueQueue + -- Thread which coordinates the printing of logs + wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var + + + -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue. + thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env) + let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger } + + runWorkerLimit worker_limit $ \abstract_sem -> do + let env = MakeEnv { hsc_env = thread_safe_hsc_env + , withLogger = withParLog log_queue_queue_var + , compile_sem = abstract_sem + , env_messager = mHscMessager + , diag_wrapper = diag_wrapper + } + -- Reset the number of capabilities once the upsweep ends. + runAllPipelines worker_limit env all_pipelines + atomically $ writeTVar stopped_var True + wait_log_thread + +withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a +withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do + withLogger k $ \modifyLogger -> do + let lcl_logger = modifyLogger (hsc_logger hsc_env) + hsc_env' = hsc_env { hsc_logger = lcl_logger } + -- Run continuation with modified logger + cont hsc_env' + +withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b +withParLog lqq_var k cont = do + let init_log = do + -- Make a new log queue + lq <- newLogQueue k + -- Add it into the LogQueueQueue + atomically $ initLogQueue lqq_var lq + return lq + finish_log lq = liftIO (finishLogQueue lq) + MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq))) + +withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a +withLocalTmpFS tmpfs act = do + let initialiser = do + liftIO $ forkTmpFsFrom tmpfs + finaliser tmpfs_local = do + liftIO $ mergeTmpFsInto tmpfs_local tmpfs + -- Add remaining files which weren't cleaned up into local tmp fs for + -- clean-up later. + -- Clear the logQueue if this node had it's own log queue + MC.bracket initialiser finaliser act + +withLocalTmpFSMake :: MakeEnv -> (MakeEnv -> IO a) -> IO a +withLocalTmpFSMake env k = + withLocalTmpFS (hsc_tmpfs (hsc_env env)) $ \lcl_tmpfs + -> k (env { hsc_env = (hsc_env env) { hsc_tmpfs = lcl_tmpfs }}) + + +-- | Run the given actions and then wait for them all to finish. +runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO () +runAllPipelines worker_limit env acts = do + let single_worker = isWorkerLimitSequential worker_limit + spawn_actions :: IO [ThreadId] + spawn_actions = if single_worker + then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts) + else runLoop forkIOWithUnmask env acts + + kill_actions :: [ThreadId] -> IO () + kill_actions tids = mapM_ killThread tids + + MC.bracket spawn_actions kill_actions $ \_ -> do + mapM_ waitMakeAction acts + +-- | Execute each action in order, limiting the amount of parallelism by the given +-- semaphore. +runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a] +runLoop _ _env [] = return [] +runLoop fork_thread env (MakeAction act res_var :acts) = do + + -- withLocalTmpFs has to occur outside of fork to remain deterministic + new_thread <- withLocalTmpFSMake env $ \lcl_env -> + fork_thread $ \unmask -> (do + mres <- (unmask $ run_pipeline lcl_env act) + `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure. + putMVar res_var mres) + threads <- runLoop fork_thread env acts + return (new_thread : threads) + where + run_pipeline :: MakeEnv -> RunMakeM a -> IO (Maybe a) + run_pipeline env p = runMaybeT (runReaderT p env) + +type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a + +data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) + +waitMakeAction :: MakeAction -> IO () +waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar diff --git a/GHC/Driver/MakeFile.hs b/GHC/Driver/MakeFile.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/MakeFile.hs @@ -0,0 +1,480 @@ + + +----------------------------------------------------------------------------- +-- +-- Makefile Dependency Generation +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.MakeFile + ( doMkDependHS + , doMkDependModuleGraph + ) +where + +import GHC.Prelude + +import qualified GHC +import GHC.Driver.Make +import GHC.Driver.Monad +import GHC.Driver.DynFlags +import GHC.Utils.Misc +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import qualified GHC.SysTools as SysTools +import GHC.Data.Graph.Directed ( SCC(..) ) +import GHC.Data.OsPath (unsafeDecodeUtf) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.SourceError +import GHC.Types.SrcLoc +import GHC.Types.PkgQual +import Data.List (partition) +import GHC.Utils.TmpFs + +import GHC.Iface.Load (cannotFindModule) + +import GHC.Unit.Module +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Graph +import GHC.Unit.Finder + +import GHC.Utils.Exception +import GHC.Utils.Error +import GHC.Utils.Logger + +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error ( isEOFError ) +import Control.Monad ( when, forM_ ) +import Data.Maybe ( isJust ) +import Data.IORef +import qualified Data.Set as Set +import GHC.Iface.Errors.Types +import Data.Either + +----------------------------------------------------------------- +-- +-- The main function +-- +----------------------------------------------------------------- + +doMkDependHS :: GhcMonad m => [FilePath] -> m () +doMkDependHS srcs = do + -- Initialisation + dflags0 <- GHC.getSessionDynFlags + + -- We kludge things a bit for dependency generation. Rather than + -- generating dependencies for each way separately, we generate + -- them once and then duplicate them for each way's osuf/hisuf. + -- We therefore do the initial dependency generation with an empty + -- way and .o/.hi extensions, regardless of any flags that might + -- be specified. + let dflags1 = dflags0 + { targetWays_ = Set.empty + , hiSuf_ = "hi" + , objectSuf_ = "o" + } + GHC.setSessionDynFlags dflags1 + + -- If no suffix is provided, use the default -- the empty one + let dflags = if null (depSuffixes dflags1) + then dflags1 { depSuffixes = [""] } + else dflags1 + + -- Do the downsweep to find all the modules + targets <- mapM (\s -> GHC.guessTarget s Nothing Nothing) srcs + GHC.setTargets targets + let excl_mods = depExcludeMods dflags + module_graph <- GHC.depanal excl_mods True {- Allow dup roots -} + doMkDependModuleGraph dflags module_graph + + + +doMkDependModuleGraph :: GhcMonad m => DynFlags -> ModuleGraph -> m () +doMkDependModuleGraph dflags module_graph = do + logger <- getLogger + tmpfs <- hsc_tmpfs <$> getSession + let excl_mods = depExcludeMods dflags + + files <- liftIO $ beginMkDependHS logger tmpfs dflags + let sorted = GHC.topSortModuleGraph False module_graph Nothing + + -- Print out the dependencies if wanted + liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted) + + -- Process them one by one, dumping results into makefile + -- and complaining about cycles + hsc_env <- getSession + root <- liftIO getCurrentDirectory + mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted + + -- If -ddump-mod-cycles, show cycles in the module graph + liftIO $ dumpModCycles logger module_graph + + -- Tidy up + liftIO $ endMkDependHS logger files + + -- Unconditional exiting is a bad idea. If an error occurs we'll get an + --exception; if that is not caught it's fine, but at least we have a + --chance to find out exactly what went wrong. Uncomment the following + --line if you disagree. + + --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) + +----------------------------------------------------------------- +-- +-- beginMkDependHs +-- Create a temporary file, +-- find the Makefile, +-- slurp through it, etc +-- +----------------------------------------------------------------- + +data MkDepFiles + = MkDep { mkd_make_file :: FilePath, -- Name of the makefile + mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile + mkd_tmp_file :: FilePath, -- Name of the temporary file + mkd_tmp_hdl :: Handle } -- Handle of the open temporary file + +beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles +beginMkDependHS logger tmpfs dflags = do + -- open a new temp file in which to stuff the dependency info + -- as we go along. + tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep" + tmp_hdl <- openFile tmp_file WriteMode + + -- open the makefile + let makefile = depMakefile dflags + exists <- doesFileExist makefile + mb_make_hdl <- + if not exists + then return Nothing + else do + makefile_hdl <- openFile makefile ReadMode + + -- slurp through until we get the magic start string, + -- copying the contents into dep_makefile + let slurp = do + l <- hGetLine makefile_hdl + if (l == depStartMarker) + then return () + else do hPutStrLn tmp_hdl l; slurp + + -- slurp through until we get the magic end marker, + -- throwing away the contents + let chuck = do + l <- hGetLine makefile_hdl + if (l == depEndMarker) + then return () + else chuck + + catchIO slurp + (\e -> if isEOFError e then return () else ioError e) + catchIO chuck + (\e -> if isEOFError e then return () else ioError e) + + return (Just makefile_hdl) + + + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depStartMarker + + return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) + + +----------------------------------------------------------------- +-- +-- processDeps +-- +----------------------------------------------------------------- + +processDeps :: DynFlags + -> HscEnv + -> [ModuleName] + -> FilePath + -> Handle -- Write dependencies to here + -> SCC ModuleGraphNode + -> IO () +-- Write suitable dependencies to handle +-- Always: +-- this.o : this.hs +-- +-- If the dependency is on something other than a .hi file: +-- this.o this.p_o ... : dep +-- otherwise +-- this.o ... : dep.hi +-- this.p_o ... : dep.p_hi +-- ... +-- (where .o is $osuf, and the other suffixes come from +-- the cmdline -s options). +-- +-- For {-# SOURCE #-} imports the "hi" will be "hi-boot". + +processDeps _ _ _ _ _ (CyclicSCC nodes) + = -- There shouldn't be any cycles; report them + throwOneError $ cyclicModuleErr nodes + +processDeps _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node)) + = -- There shouldn't be any backpack instantiations; report them as well + throwOneError $ + mkPlainErrorMsgEnvelope noSrcSpan $ + GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node + +processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return () +processDeps _dflags _ _ _ _ (AcyclicSCC (UnitNode {})) = return () +processDeps _ _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {}))) + -- No dependencies needed for fixed modules (already compiled) + = return () +processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) + = do { let extra_suffixes = depSuffixes dflags + include_pkg_deps = depIncludePkgDeps dflags + src_file = msHsFilePath node + obj_file = msObjFilePath node + obj_files = insertSuffixes obj_file extra_suffixes + + do_imp loc is_boot pkg_qual imp_mod + = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod + is_boot include_pkg_deps + ; case mb_hi of { + Nothing -> return () ; + Just hi_file -> do + { let hi_files = insertSuffixes hi_file extra_suffixes + write_dep (obj,hi) = writeDependency root hdl [obj] hi + + -- Add one dependency for each suffix; + -- e.g. A.o : B.hi + -- A.x_o : B.x_hi + ; mapM_ write_dep (obj_files `zip` hi_files) }}} + + + -- Emit std dependency of the object(s) on the source file + -- Something like A.o : A.hs + ; writeDependency root hdl obj_files src_file + + -- add dependency between objects and their corresponding .hi-boot + -- files if the module has a corresponding .hs-boot file (#14482) + ; when (isBootSummary node == IsBoot) $ do + let hi_boot = msHiFilePath node + let obj = unsafeDecodeUtf $ removeBootSuffix (msObjFileOsPath node) + forM_ extra_suffixes $ \suff -> do + let way_obj = insertSuffixes obj [suff] + let way_hi_boot = insertSuffixes hi_boot [suff] + mapM_ (writeDependency root hdl way_obj) way_hi_boot + + -- Emit a dependency for each CPP import + ; when (depIncludeCppDeps dflags) $ do + -- CPP deps are discovered in the module parsing phase by parsing + -- comment lines left by the preprocessor. + -- Note that GHC.parseModule may throw an exception if the module + -- fails to parse, which may not be desirable (see #16616). + { session <- Session <$> newIORef hsc_env + ; parsedMod <- reflectGhc (GHC.parseModule node) session + ; mapM_ (writeDependency root hdl obj_files) + (GHC.pm_extra_src_files parsedMod) + } + + -- Emit a dependency for each import + + ; let do_imps is_boot idecls = sequence_ + [ do_imp loc is_boot mb_pkg mod + | (_lvl, mb_pkg, L loc mod) <- idecls, + mod `notElem` excl_mods ] + + ; do_imps IsBoot (map ((,,) NormalLevel NoPkgQual) (ms_srcimps node)) + ; do_imps NotBoot (ms_imps node) + } + + +findDependency :: HscEnv + -> SrcSpan + -> PkgQual -- package qualifier, if any + -> ModuleName -- Imported module + -> IsBootInterface -- Source import + -> Bool -- Record dependency on package modules + -> IO (Maybe FilePath) -- Interface file +findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do + -- Find the module; this will be fast because + -- we've done it once during downsweep + r <- findImportedModuleWithIsBoot hsc_env imp is_boot pkg + case r of + Found loc _ + -- Home package: just depend on the .hi or hi-boot file + | isJust (ml_hs_file loc) || include_pkg_deps + -> return (Just (ml_hi_file loc)) + + -- Not in this package: we don't need a dependency + | otherwise + -> return Nothing + + fail -> + throwOneError $ + mkPlainErrorMsgEnvelope srcloc $ + GhcDriverMessage $ DriverInterfaceError $ + (Can'tFindInterface (cannotFindModule hsc_env imp fail) (LookingForModule imp is_boot)) + +----------------------------- +writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () +-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency +-- t1 t2 : dep +writeDependency root hdl targets dep + = do let -- We need to avoid making deps on + -- c:/foo/... + -- on cygwin as make gets confused by the : + -- Making relative deps avoids some instances of this. + dep' = makeRelative root dep + forOutput = escapeSpaces . reslash Forwards . normalise + output = unwords (map forOutput targets) ++ " : " ++ forOutput dep' + hPutStrLn hdl output + +----------------------------- +insertSuffixes + :: FilePath -- Original filename; e.g. "foo.o" + -> [String] -- Suffix prefixes e.g. ["x_", "y_"] + -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] + -- Note that the extra bit gets inserted *before* the old suffix + -- We assume the old suffix contains no dots, so we know where to + -- split it +insertSuffixes file_name extras + = [ basename <.> (extra ++ suffix) | extra <- extras ] + where + (basename, suffix) = case splitExtension file_name of + -- Drop the "." from the extension + (b, s) -> (b, drop 1 s) + + +----------------------------------------------------------------- +-- +-- endMkDependHs +-- Complete the makefile, close the tmp file etc +-- +----------------------------------------------------------------- + +endMkDependHS :: Logger -> MkDepFiles -> IO () + +endMkDependHS logger + (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) + = do + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depEndMarker + + case makefile_hdl of + Nothing -> return () + Just hdl -> do + -- slurp the rest of the original makefile and copy it into the output + SysTools.copyHandle hdl tmp_hdl + hClose hdl + + hClose tmp_hdl -- make sure it's flushed + + -- Create a backup of the original makefile + when (isJust makefile_hdl) $ do + showPass logger ("Backing up " ++ makefile) + SysTools.copyFile makefile (makefile++".bak") + + -- Copy the new makefile in place + showPass logger "Installing new makefile" + SysTools.copyFile tmp_file makefile + + +----------------------------------------------------------------- +-- Module cycles +----------------------------------------------------------------- + +dumpModCycles :: Logger -> ModuleGraph -> IO () +dumpModCycles logger module_graph + | not (logHasDumpFlag logger Opt_D_dump_mod_cycles) + = return () + + | null cycles + = putMsg logger (text "No module cycles") + + | otherwise + = putMsg logger (hang (text "Module cycles found:") 2 pp_cycles) + where + topoSort = GHC.topSortModuleGraph True module_graph Nothing + + cycles :: [[ModuleGraphNode]] + cycles = + [ c | CyclicSCC c <- topoSort ] + + pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> text "----------") + $$ pprCycle c $$ blankLine + | (n,c) <- [1..] `zip` cycles ] + +pprCycle :: [ModuleGraphNode] -> SDoc +-- Print a cycle, but show only the imports within the cycle +pprCycle summaries = pp_group (CyclicSCC summaries) + where + cycle_keys :: [NodeKey] -- The modules in this cycle + cycle_keys = map mkNodeKey summaries + + pp_group :: SCC ModuleGraphNode -> SDoc + pp_group (AcyclicSCC (ModuleNode deps m)) = pp_mod deps m + pp_group (AcyclicSCC _) = empty + pp_group (CyclicSCC mss) + = assert (not (null boot_only)) $ + -- The boot-only list must be non-empty, else there would + -- be an infinite chain of non-boot imports, and we've + -- already checked for that in processModDeps + pp_mod loop_deps loop_breaker $$ vcat (map pp_group groups) + where + (boot_only, others) = partitionEithers (map is_boot_only mss) + is_boot_key (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True + is_boot_key _ = False + is_boot_only n@(ModuleNode deps ms) = + let dep_mods = map edgeTargetKey deps + non_boot_deps = filter (not . is_boot_key) dep_mods + in if not (any in_group non_boot_deps) + then Left (deps, ms) + else Right n + is_boot_only n = Right n + in_group m = m `elem` group_mods + group_mods = map mkNodeKey mss + + (loop_deps, loop_breaker) = head boot_only + all_others = tail (map (uncurry ModuleNode) boot_only) ++ others + groups = + GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing + + pp_mod :: [ModuleNodeEdge] -> ModuleNodeInfo -> SDoc + pp_mod deps mn = + text mod_str <> text (take (20 - length mod_str) (repeat ' ')) <> ppr_deps (map edgeTargetKey deps) + where + mod_str = moduleNameString (moduleNodeInfoModuleName mn) + + ppr_deps :: [NodeKey] -> SDoc + ppr_deps [] = empty + ppr_deps deps = + let is_mod_dep (NodeKey_Module {}) = True + is_mod_dep _ = False + + is_boot_dep (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True + is_boot_dep _ = False + + cycle_deps = filter (`elem` cycle_keys) deps + (mod_deps, other_deps) = partition is_mod_dep cycle_deps + (boot_deps, normal_deps) = partition is_boot_dep mod_deps + in vcat [ + if null normal_deps then empty + else text "imports" <+> pprWithCommas ppr normal_deps, + if null boot_deps then empty + else text "{-# SOURCE #-} imports" <+> pprWithCommas ppr boot_deps, + if null other_deps then empty + else text "depends on" <+> pprWithCommas ppr other_deps + ] + +----------------------------------------------------------------- +-- +-- Flags +-- +----------------------------------------------------------------- + +depStartMarker, depEndMarker :: String +depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" +depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" diff --git a/GHC/Driver/MakeSem.hs b/GHC/Driver/MakeSem.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/MakeSem.hs @@ -0,0 +1,545 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | Implementation of a jobserver using system semaphores. +-- +-- +module GHC.Driver.MakeSem + ( -- * JSem: parallelism semaphore backed + -- by a system semaphore (Posix/Windows) + runJSemAbstractSem + + -- * System semaphores + , Semaphore, SemaphoreName(..) + + -- * Abstract semaphores + , AbstractSem(..) + , withAbstractSem + ) + where + +import GHC.Prelude +import GHC.Conc +import GHC.Data.OrdList +import GHC.IO.Exception +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Json + +import System.Semaphore + +import Control.Monad +import qualified Control.Monad.Catch as MC +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Data.Foldable +import Data.Functor +import GHC.Stack +import Debug.Trace + +--------------------------------------- +-- Semaphore jobserver + +-- | A jobserver based off a system 'Semaphore'. +-- +-- Keeps track of the pending jobs and resources +-- available from the semaphore. +data Jobserver + = Jobserver + { jSemaphore :: !Semaphore + -- ^ The semaphore which controls available resources + , jobs :: !(TVar JobResources) + -- ^ The currently pending jobs, and the resources + -- obtained from the semaphore + } + +data JobserverOptions + = JobserverOptions + { releaseDebounce :: !Int + -- ^ Minimum delay, in milliseconds, between acquiring a token + -- and releasing a token. + , setNumCapsDebounce :: !Int + -- ^ Minimum delay, in milliseconds, between two consecutive + -- calls of 'setNumCapabilities'. + } + +defaultJobserverOptions :: JobserverOptions +defaultJobserverOptions = + JobserverOptions + { releaseDebounce = 1000 -- 1 second + , setNumCapsDebounce = 1000 -- 1 second + } + +-- | Resources available for running jobs, i.e. +-- tokens obtained from the parallelism semaphore. +data JobResources + = Jobs + { tokensOwned :: !Int + -- ^ How many tokens have been claimed from the semaphore + , tokensFree :: !Int + -- ^ How many tokens are not currently being used + , jobsWaiting :: !(OrdList (TMVar ())) + -- ^ Pending jobs waiting on a token, the job will be blocked on the TMVar so putting into + -- the TMVar will allow the job to continue. + } + +instance Outputable JobResources where + ppr Jobs{..} + = text "JobResources" <+> + ( braces $ hsep + [ text "owned=" <> ppr tokensOwned + , text "free=" <> ppr tokensFree + , text "num_waiting=" <> ppr (length jobsWaiting) + ] ) + +-- | Add one new token. +addToken :: JobResources -> JobResources +addToken jobs@( Jobs { tokensOwned = owned, tokensFree = free }) + = jobs { tokensOwned = owned + 1, tokensFree = free + 1 } + +-- | Free one token. +addFreeToken :: JobResources -> JobResources +addFreeToken jobs@( Jobs { tokensFree = free }) + = assertPpr (tokensOwned jobs > free) + (text "addFreeToken:" <+> ppr (tokensOwned jobs) <+> ppr free) + $ jobs { tokensFree = free + 1 } + +-- | Use up one token. +removeFreeToken :: JobResources -> JobResources +removeFreeToken jobs@( Jobs { tokensFree = free }) + = assertPpr (free > 0) + (text "removeFreeToken:" <+> ppr free) + $ jobs { tokensFree = free - 1 } + +-- | Return one owned token. +removeOwnedToken :: JobResources -> JobResources +removeOwnedToken jobs@( Jobs { tokensOwned = owned }) + = assertPpr (owned > 1) + (text "removeOwnedToken:" <+> ppr owned) + $ jobs { tokensOwned = owned - 1 } + +-- | Add one new job to the end of the list of pending jobs. +addJob :: TMVar () -> JobResources -> JobResources +addJob job jobs@( Jobs { jobsWaiting = wait }) + = jobs { jobsWaiting = wait `SnocOL` job } + +-- | The state of the semaphore job server. +data JobserverState + = JobserverState + { jobserverAction :: !JobserverAction + -- ^ The current action being performed by the + -- job server. + , canChangeNumCaps :: !(TVar Bool) + -- ^ A TVar that signals whether it has been long + -- enough since we last changed 'numCapabilities'. + , canReleaseToken :: !(TVar Bool) + -- ^ A TVar that signals whether we last acquired + -- a token long enough ago that we can now release + -- a token. + } +data JobserverAction + -- | The jobserver is idle: no thread is currently + -- interacting with the semaphore. + = Idle + -- | A thread is waiting for a token on the semaphore. + | Acquiring + { activeWaitId :: WaitId + , threadFinished :: TMVar (Maybe MC.SomeException) } + +-- | Retrieve the 'TMVar' that signals if the current thread has finished, +-- if any thread is currently active in the jobserver. +activeThread_maybe :: JobserverAction -> Maybe (TMVar (Maybe MC.SomeException)) +activeThread_maybe Idle = Nothing +activeThread_maybe (Acquiring { threadFinished = tmvar }) = Just tmvar + +-- | Whether we should try to acquire a new token from the semaphore: +-- there is a pending job and no free tokens. +guardAcquire :: JobResources -> Bool +guardAcquire ( Jobs { tokensFree, jobsWaiting } ) + = tokensFree == 0 && not (null jobsWaiting) + +-- | Whether we should release a token from the semaphore: +-- there are no pending jobs and we can release a token. +guardRelease :: JobResources -> Bool +guardRelease ( Jobs { tokensFree, tokensOwned, jobsWaiting } ) + = null jobsWaiting && tokensFree > 0 && tokensOwned > 1 + +--------------------------------------- +-- Semaphore jobserver implementation + +-- | Add one pending job to the jobserver. +-- +-- Blocks, waiting on the jobserver to supply a free token. +acquireJob :: TVar JobResources -> IO () +acquireJob jobs_tvar = do + (job_tmvar, _jobs0) <- tracedAtomically "acquire" $ + modifyJobResources jobs_tvar \ jobs -> do + job_tmvar <- newEmptyTMVar + return ((job_tmvar, jobs), addJob job_tmvar jobs) + atomically $ takeTMVar job_tmvar + +-- | Signal to the job server that one job has completed, +-- releasing its corresponding token. +releaseJob :: TVar JobResources -> IO () +releaseJob jobs_tvar = do + tracedAtomically "release" do + modifyJobResources jobs_tvar \ jobs -> do + massertPpr (tokensFree jobs < tokensOwned jobs) + (text "releaseJob: more free jobs than owned jobs!") + return ((), addFreeToken jobs) + + +-- | Release all tokens owned from the semaphore (to clean up +-- the jobserver at the end). +cleanupJobserver :: Jobserver -> IO () +cleanupJobserver (Jobserver { jSemaphore = sem + , jobs = jobs_tvar }) + = do + Jobs { tokensOwned = owned } <- readTVarIO jobs_tvar + let toks_to_release = owned - 1 + -- Subtract off the implicit token: whoever spawned the ghc process + -- in the first place is responsible for that token. + releaseSemaphore sem toks_to_release + +-- | Dispatch the available tokens acquired from the semaphore +-- to the pending jobs in the job server. +dispatchTokens :: JobResources -> STM JobResources +dispatchTokens jobs@( Jobs { tokensFree = toks_free, jobsWaiting = wait } ) + | toks_free > 0 + , next `ConsOL` rest <- wait + -- There's a pending job and a free token: + -- pass on the token to that job, and recur. + = do + putTMVar next () + let jobs' = jobs { tokensFree = toks_free - 1, jobsWaiting = rest } + dispatchTokens jobs' + | otherwise + = return jobs + +-- | Update the available resources used from a semaphore, dispatching +-- any newly acquired resources. +-- +-- Invariant: if the number of available resources decreases, there +-- must be no pending jobs. +-- +-- All modifications should go through this function to ensure the contents +-- of the 'TVar' remains in normal form. +modifyJobResources :: HasCallStack => TVar JobResources + -> (JobResources -> STM (a, JobResources)) + -> STM (a, Maybe JobResources) +modifyJobResources jobs_tvar action = do + old_jobs <- readTVar jobs_tvar + (a, jobs) <- action old_jobs + + -- Check the invariant: if the number of free tokens has decreased, + -- there must be no pending jobs. + massertPpr (null (jobsWaiting jobs) || tokensFree jobs >= tokensFree old_jobs) $ + vcat [ text "modiyJobResources: pending jobs but fewer free tokens" ] + dispatched_jobs <- dispatchTokens jobs + writeTVar jobs_tvar dispatched_jobs + return (a, Just dispatched_jobs) + + +tracedAtomically_ :: String -> STM (Maybe JobResources) -> IO () +tracedAtomically_ s act = tracedAtomically s (((),) <$> act) + +tracedAtomically :: String -> STM (a, Maybe JobResources) -> IO a +tracedAtomically origin act = do + (a, mjr) <- atomically act + forM_ mjr $ \ jr -> do + -- Use the "jsem:" prefix to identify where the write traces are + traceEventIO ("jsem:" ++ renderJobResources origin jr) + return a + +renderJobResources :: String -> JobResources -> String +renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON $ + JSObject [ ("name", JSString origin) + , ("owned", JSInt own) + , ("free", JSInt free) + , ("pending", JSInt (length pending) ) + ] + + +-- | Spawn a new thread that waits on the semaphore in order to acquire +-- an additional token. +acquireThread :: Jobserver -> IO JobserverAction +acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do + threadFinished_tmvar <- newEmptyTMVarIO + let + wait_result_action :: Either MC.SomeException Bool -> IO () + wait_result_action wait_res = + tracedAtomically_ "acquire_thread" do + (r, jb) <- case wait_res of + Left (e :: MC.SomeException) -> do + return $ (Just e, Nothing) + Right success -> do + if success + then do + modifyJobResources jobs_tvar \ jobs -> + return (Nothing, addToken jobs) + else + return (Nothing, Nothing) + putTMVar threadFinished_tmvar r + return jb + wait_id <- forkWaitOnSemaphoreInterruptible sem wait_result_action + labelThread (waitingThreadId wait_id) "acquire_thread" + return $ Acquiring { activeWaitId = wait_id + , threadFinished = threadFinished_tmvar } + +-- | Spawn a thread to release ownership of one resource from the semaphore, +-- provided we have spare resources and no pending jobs. +releaseThread :: Jobserver -> IO JobserverAction +releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do + threadFinished_tmvar <- newEmptyTMVarIO + MC.mask_ do + -- Pre-release the resource so that another thread doesn't take control of it + -- just as we release the lock on the semaphore. + still_ok_to_release + <- tracedAtomically "pre_release" $ + modifyJobResources jobs_tvar \ jobs -> + if guardRelease jobs + -- TODO: should this also debounce? + then return (True , removeOwnedToken $ removeFreeToken jobs) + else return (False, jobs) + if not still_ok_to_release + then return Idle + else do + tid <- forkIO $ do + x <- MC.try $ releaseSemaphore sem 1 + tracedAtomically_ "post-release" $ do + (r, jobs) <- case x of + Left (e :: MC.SomeException) -> do + modifyJobResources jobs_tvar \ jobs -> + return (Just e, addToken jobs) + Right _ -> do + return (Nothing, Nothing) + putTMVar threadFinished_tmvar r + return jobs + labelThread tid "release_thread" + return Idle + +-- | When there are pending jobs but no free tokens, +-- spawn a thread to acquire a new token from the semaphore. +-- +-- See 'acquireThread'. +tryAcquire :: JobserverOptions + -> Jobserver + -> JobserverState + -> STM (IO JobserverState) +tryAcquire opts js@( Jobserver { jobs = jobs_tvar }) + st@( JobserverState { jobserverAction = Idle } ) + = do + jobs <- readTVar jobs_tvar + guard $ guardAcquire jobs + return do + action <- acquireThread js + -- Set a debounce after acquiring a token. + can_release_tvar <- registerDelay $ (releaseDebounce opts * 1000) + return $ st { jobserverAction = action + , canReleaseToken = can_release_tvar } +tryAcquire _ _ _ = retry + +-- | When there are free tokens and no pending jobs, +-- spawn a thread to release a token from the semaphore. +-- +-- See 'releaseThread'. +tryRelease :: Jobserver + -> JobserverState + -> STM (IO JobserverState) +tryRelease sjs@( Jobserver { jobs = jobs_tvar } ) + st@( JobserverState + { jobserverAction = Idle + , canReleaseToken = can_release_tvar } ) + = do + jobs <- readTVar jobs_tvar + guard $ guardRelease jobs + can_release <- readTVar can_release_tvar + guard can_release + return do + action <- releaseThread sjs + return $ st { jobserverAction = action } +tryRelease _ _ = retry + +-- | Wait for an active thread to finish. Once it finishes: +-- +-- - set the 'JobserverAction' to 'Idle', +-- - update the number of capabilities to reflect the number +-- of owned tokens from the semaphore. +tryNoticeIdle :: JobserverOptions + -> TVar JobResources + -> JobserverState + -> STM (IO JobserverState) +tryNoticeIdle opts jobs_tvar jobserver_state + | Just threadFinished_tmvar <- activeThread_maybe $ jobserverAction jobserver_state + = sync_num_caps (canChangeNumCaps jobserver_state) threadFinished_tmvar + | otherwise + = retry -- no active thread: wait until jobserver isn't idle + where + sync_num_caps :: TVar Bool + -> TMVar (Maybe MC.SomeException) + -> STM (IO JobserverState) + sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do + mb_ex <- takeTMVar threadFinished_tmvar + for_ mb_ex MC.throwM + Jobs { tokensOwned } <- readTVar jobs_tvar + can_change_numcaps <- readTVar can_change_numcaps_tvar + guard can_change_numcaps + return do + x <- getNumCapabilities + can_change_numcaps_tvar_2 <- + if x == tokensOwned + then return can_change_numcaps_tvar + else do + setNumCapabilities tokensOwned + registerDelay $ (setNumCapsDebounce opts * 1000) + return $ + jobserver_state + { jobserverAction = Idle + , canChangeNumCaps = can_change_numcaps_tvar_2 } + +-- | Try to stop the current thread which is acquiring/releasing resources +-- if that operation is no longer relevant. +tryStopThread :: TVar JobResources + -> JobserverState + -> STM (IO JobserverState) +tryStopThread jobs_tvar jsj = do + case jobserverAction jsj of + Acquiring { activeWaitId = wait_id } -> do + jobs <- readTVar jobs_tvar + guard $ null (jobsWaiting jobs) + return do + interruptWaitOnSemaphore wait_id + return $ jsj { jobserverAction = Idle } + _ -> retry + +-- | Main jobserver loop: acquire/release resources as +-- needed for the pending jobs and available semaphore tokens. +jobserverLoop :: JobserverOptions -> Jobserver -> IO () +jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar }) + = do + true_tvar <- newTVarIO True + let init_state :: JobserverState + init_state = + JobserverState + { jobserverAction = Idle + , canChangeNumCaps = true_tvar + , canReleaseToken = true_tvar } + loop init_state + where + loop s = do + action <- atomically $ asum $ (\x -> x s) <$> + [ tryRelease sjs + , tryAcquire opts sjs + , tryNoticeIdle opts jobs_tvar + , tryStopThread jobs_tvar + ] + s <- action + loop s + +-- | Create a new jobserver using the given semaphore handle. +makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ()) +makeJobserver sem_name = do + semaphore <- openSemaphore sem_name + let + init_jobs = + Jobs { tokensOwned = 1 + , tokensFree = 1 + , jobsWaiting = NilOL + } + jobs_tvar <- newTVarIO init_jobs + let + opts = defaultJobserverOptions -- TODO: allow this to be configured + sjs = Jobserver { jSemaphore = semaphore + , jobs = jobs_tvar } + loop_finished_mvar <- newEmptyMVar + loop_tid <- forkIOWithUnmask \ unmask -> do + r <- try $ unmask $ jobserverLoop opts sjs + putMVar loop_finished_mvar $ + case r of + Left e + | Just ThreadKilled <- fromException e + -> Nothing + | otherwise + -> Just e + Right () -> Nothing + labelThread loop_tid "job_server" + let + acquireSem = acquireJob jobs_tvar + releaseSem = releaseJob jobs_tvar + cleanupSem = do + -- this is interruptible + cleanupJobserver sjs + killThread loop_tid + mb_ex <- takeMVar loop_finished_mvar + for_ mb_ex MC.throwM + + return (AbstractSem{..}, cleanupSem) + +-- | Implement an abstract semaphore using a semaphore 'Jobserver' +-- which queries the system semaphore of the given name for resources. +runJSemAbstractSem :: SemaphoreName -- ^ the system semaphore to use + -> (AbstractSem -> IO a) -- ^ the operation to run + -- which requires a semaphore + -> IO a +runJSemAbstractSem sem action = MC.mask \ unmask -> do + (abs, cleanup) <- makeJobserver sem + r <- try $ unmask $ action abs + case r of + Left (e1 :: MC.SomeException) -> do + (_ :: Either MC.SomeException ()) <- MC.try cleanup + MC.throwM e1 + Right x -> cleanup $> x + +{- Note [Architecture of the Job Server] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `-jsem` mode, the amount of parallelism that GHC can use is controlled by a +system semaphore. We take resources from the semaphore when we need them, and +give them back if we don't have enough to do. + +A naive implementation would just take and release the semaphore around performing +the action, but this leads to two issues: + +* When taking a token in the semaphore, we must call `setNumCapabilities` in order + to adjust how many capabilities are available for parallel garbage collection. + This causes unnecessary synchronisations. +* We want to implement a debounce, so that whilst there is pending work in the + current process we prefer to keep hold of resources from the semaphore. + This reduces overall memory usage, as there are fewer live GHC processes at once. + +Therefore, the obtention of semaphore resources is separated away from the +request for the resource in the driver. + +A token from the semaphore is requested using `acquireJob`. This creates a pending +job, which is a MVar that can be filled in to signal that the requested token is ready. + +When the job is finished, the token is released by calling `releaseJob`, which just +increases the number of `free` jobs. If there are more pending jobs when the free count +is increased, the token is immediately reused (see `modifyJobResources`). + +The `jobServerLoop` interacts with the system semaphore: when there are pending +jobs, `acquireThread` blocks, waiting for a token from the semaphore. Once a +token is obtained, it increases the owned count. + +When GHC has free tokens (tokens from the semaphore that it is not using), +no pending jobs, and the debounce has expired, then `releaseThread` will +release tokens back to the global semaphore. + +`tryStopThread` attempts to kill threads which are waiting to acquire a resource +when we no longer need it. For example, consider that we attempt to acquire two +tokens, but the first job finishes before we acquire the second token. +This second token is no longer needed, so we should cancel the wait +(as it would not be used to do any work, and not be returned until the debounce). +We only need to kill `acquireJob`, because `releaseJob` never blocks. + +Note [Eventlog Messages for jsem] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be tricky to verify that the work is shared adequately across different +processes. To help debug this, we output the values of `JobResource` to the +eventlog whenever the global state changes. There are some scripts which can be used +to analyse this output and report statistics about core saturation in the +GitHub repo (https://github.com/mpickering/ghc-jsem-analyse). + +-} diff --git a/GHC/Driver/Messager.hs b/GHC/Driver/Messager.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Messager.hs @@ -0,0 +1,66 @@ +module GHC.Driver.Messager (Messager, oneShotMsg, batchMsg, batchMultiMsg, showModuleIndex) where + +import GHC.Prelude +import GHC.Driver.Env +import GHC.Unit.Module.Graph +import GHC.Iface.Recomp +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Unit.State + +type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO () + +-------------------------------------------------------------- +-- Progress displayers. +-------------------------------------------------------------- + +oneShotMsg :: Logger -> RecompileRequired -> IO () +oneShotMsg logger recomp = + case recomp of + UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required" + NeedsRecompile _ -> return () + +batchMsg :: Messager +batchMsg = batchMsgWith (\_ _ _ _ -> empty) +batchMultiMsg :: Messager +batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (mgNodeUnitId node))) + +batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager +batchMsgWith extra hsc_env_start mod_index recomp node = + case recomp of + UpToDate + | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty + | otherwise -> return () + NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of + MustCompile -> empty + (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" + where + herald = case node of + LinkNode {} -> "Linking" + InstantiationNode {} -> "Instantiating" + ModuleNode {} -> "Compiling" + UnitNode {} -> "Loading" + hsc_env = hscSetActiveUnitId (mgNodeUnitId node) hsc_env_start + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + state = hsc_units hsc_env + showMsg msg reason = + compilationProgressMsg logger $ + (showModuleIndex mod_index <> + msg <+> showModMsg dflags (recompileRequired recomp) node) + <> extra hsc_env mod_index recomp node + <> reason + +{- ********************************************************************** +%* * + Progress Messages: Module i of n +%* * +%********************************************************************* -} + +showModuleIndex :: (Int, Int) -> SDoc +showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] " + where + -- compute the length of x > 0 in base 10 + len x = ceiling (logBase 10 (fromIntegral x+1) :: Float) + pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr diff --git a/GHC/Driver/Monad.hs b/GHC/Driver/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Monad.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE DerivingVia, NoPolyKinds #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2010 +-- +-- The Session type and related functionality +-- +-- ----------------------------------------------------------------------------- + +module GHC.Driver.Monad ( + -- * 'Ghc' monad stuff + GhcMonad(..), + Ghc(..), + GhcT(..), liftGhcT, + reflectGhc, reifyGhc, + getSessionDynFlags, + liftIO, + Session(..), withSession, modifySession, modifySessionM, + withTempSession, + + -- * Logger + modifyLogger, + pushLogHookM, + popLogHookM, + pushJsonLogHookM, + popJsonLogHookM, + putLogMsgM, + putMsgM, + withTimingM, + + -- ** Diagnostics + logDiagnostics, printException, + WarnErrLogger, defaultWarnErrLogger + ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Driver.Env +import GHC.Driver.Errors ( printOrThrowDiagnostics, printMessages ) +import GHC.Driver.Errors.Types +import GHC.Driver.Config.Diagnostic + +import GHC.Utils.Monad +import GHC.Utils.Exception +import GHC.Utils.Error +import GHC.Utils.Logger + +import GHC.Types.SrcLoc +import GHC.Types.SourceError + +import Control.Monad +import Control.Monad.Catch as MC +import Control.Monad.Trans.Reader +import Data.IORef + +-- ----------------------------------------------------------------------------- +-- | A monad that has all the features needed by GHC API calls. +-- +-- In short, a GHC monad +-- +-- - allows embedding of IO actions, +-- +-- - can log warnings, +-- +-- - allows handling of (extensible) exceptions, and +-- +-- - maintains a current session. +-- +-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' +-- before any call to the GHC API functions can occur. +-- +class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m ) => GhcMonad m where + getSession :: m HscEnv + setSession :: HscEnv -> m () + +-- | Call the argument with the current session. +withSession :: GhcMonad m => (HscEnv -> m a) -> m a +withSession f = getSession >>= f + +-- | Grabs the DynFlags from the Session +getSessionDynFlags :: GhcMonad m => m DynFlags +getSessionDynFlags = withSession (return . hsc_dflags) + +-- | Set the current session to the result of applying the current session to +-- the argument. +modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () +modifySession f = do h <- getSession + setSession $! f h + +-- | Set the current session to the result of applying the current session to +-- the argument. +modifySessionM :: GhcMonad m => (HscEnv -> m HscEnv) -> m () +modifySessionM f = do h <- getSession + h' <- f h + setSession $! h' + +withSavedSession :: GhcMonad m => m a -> m a +withSavedSession m = do + saved_session <- getSession + m `MC.finally` setSession saved_session + +-- | Call an action with a temporarily modified Session. +withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a +withTempSession f m = + withSavedSession $ modifySession f >> m + +---------------------------------------- +-- Logging +---------------------------------------- + +-- | Modify the logger +modifyLogger :: GhcMonad m => (Logger -> Logger) -> m () +modifyLogger f = modifySession $ \hsc_env -> + hsc_env { hsc_logger = f (hsc_logger hsc_env) } + +-- | Push a log hook on the stack +pushLogHookM :: GhcMonad m => (LogAction -> LogAction) -> m () +pushLogHookM = modifyLogger . pushLogHook + +-- | Pop a log hook from the stack +popLogHookM :: GhcMonad m => m () +popLogHookM = modifyLogger popLogHook + +pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m () +pushJsonLogHookM = modifyLogger . pushJsonLogHook + +popJsonLogHookM :: GhcMonad m => m () +popJsonLogHookM = modifyLogger popJsonLogHook + +-- | Put a log message +putMsgM :: GhcMonad m => SDoc -> m () +putMsgM doc = do + logger <- getLogger + liftIO $ putMsg logger doc + +-- | Put a log message +putLogMsgM :: GhcMonad m => MessageClass -> SrcSpan -> SDoc -> m () +putLogMsgM msg_class loc doc = do + logger <- getLogger + liftIO $ logMsg logger msg_class loc doc + +-- | Time an action +withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b +withTimingM doc force action = do + logger <- getLogger + withTiming logger doc force action + +-- ----------------------------------------------------------------------------- +-- | A monad that allows logging of diagnostics. + +logDiagnostics :: GhcMonad m => Messages GhcMessage -> m () +logDiagnostics warns = do + dflags <- getSessionDynFlags + logger <- getLogger + let !diag_opts = initDiagOpts dflags + !print_config = initPrintConfig dflags + liftIO $ printOrThrowDiagnostics logger print_config diag_opts warns + +-- ----------------------------------------------------------------------------- +-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, +-- e.g., to maintain additional state consider wrapping this monad or using +-- 'GhcT'. +newtype Ghc a = Ghc { unGhc :: Session -> IO a } + deriving stock (Functor) + deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session IO) + +-- | The Session is a handle to the complete state of a compilation +-- session. A compilation session consists of a set of modules +-- constituting the current program or library, the context for +-- interactive evaluation, and various caches. +data Session = Session !(IORef HscEnv) + +instance HasDynFlags Ghc where + getDynFlags = getSessionDynFlags + +instance HasLogger Ghc where + getLogger = hsc_logger <$> getSession + +instance GhcMonad Ghc where + getSession = Ghc $ \(Session r) -> readIORef r + setSession s' = Ghc $ \(Session r) -> writeIORef r s' + +-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. +-- +-- You can use this to call functions returning an action in the 'Ghc' monad +-- inside an 'IO' action. This is needed for some (too restrictive) callback +-- arguments of some library functions: +-- +-- > libFunc :: String -> (Int -> IO a) -> IO a +-- > ghcFunc :: Int -> Ghc a +-- > +-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a +-- > ghcFuncUsingLibFunc str = +-- > reifyGhc $ \s -> +-- > libFunc $ \i -> do +-- > reflectGhc (ghcFunc i) s +-- +reflectGhc :: Ghc a -> Session -> IO a +reflectGhc m = unGhc m + +-- > Dual to 'reflectGhc'. See its documentation. +reifyGhc :: (Session -> IO a) -> Ghc a +reifyGhc act = Ghc $ act + +-- ----------------------------------------------------------------------------- +-- | A monad transformer to add GHC specific features to another monad. +-- +-- Note that the wrapped monad must support IO and handling of exceptions. +newtype GhcT m a = GhcT { unGhcT :: Session -> m a } + deriving stock (Functor) + deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session m) + +liftGhcT :: m a -> GhcT m a +liftGhcT m = GhcT $ \_ -> m + +instance MonadIO m => HasDynFlags (GhcT m) where + getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) + +instance MonadIO m => HasLogger (GhcT m) where + getLogger = GhcT $ \(Session r) -> liftM hsc_logger (liftIO $ readIORef r) + +instance ExceptionMonad m => GhcMonad (GhcT m) where + getSession = GhcT $ \(Session r) -> liftIO $ readIORef r + setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' + + +-- | Print the all diagnostics in a 'SourceError'. Useful inside exception +-- handlers. +printException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m () +printException err = do + dflags <- getDynFlags + logger <- getLogger + let !diag_opts = initDiagOpts dflags + !print_config = initPrintConfig dflags + liftIO $ printMessages logger print_config diag_opts (srcErrorMessages err) + +-- | A function called to log warnings and errors. +type WarnErrLogger = forall m. (HasDynFlags m , MonadIO m, HasLogger m) => Maybe SourceError -> m () + +defaultWarnErrLogger :: WarnErrLogger +defaultWarnErrLogger Nothing = return () +defaultWarnErrLogger (Just e) = printException e diff --git a/GHC/Driver/Phases.hs b/GHC/Driver/Phases.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Phases.hs @@ -0,0 +1,334 @@ +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2002 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.Phases ( + Phase(..), + happensBefore, eqPhase, isStopLn, + startPhase, + phaseInputExt, + + StopPhase(..), + stopPhaseToPhase, + + isHaskellishSuffix, + isHaskellSrcSuffix, + isBackpackishSuffix, + isObjectSuffix, + isCishSuffix, + isDynLibSuffix, + isHaskellUserSrcSuffix, + isHaskellSigSuffix, + isHaskellBootSuffix, + isSourceSuffix, + + isHaskellishTarget, + + isHaskellishFilename, + isHaskellSrcFilename, + isHaskellSigFilename, + isObjectFilename, + isCishFilename, + isDynLibFilename, + isHaskellUserSrcFilename, + isSourceFilename, + + phaseForeignLanguage + ) where + +import GHC.Prelude + +import GHC.Platform + +import GHC.ForeignSrcLang + +import GHC.Types.SourceFile + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import System.FilePath + +----------------------------------------------------------------------------- +-- Phases + +{- + Phase of the | Suffix saying | Flag saying | (suffix of) + compilation system | ``start here''| ``stop after''| output file + + literate pre-processor | .lhs | - | - + C pre-processor (opt.) | - | -E | - + Haskell compiler | .hs | -C, -S | .hc, .s + C compiler (opt.) | .hc or .c | -S | .s + assembler | .s or .S | -c | .o + linker | other | - | a.out + linker (merge objects) | other | - | .o +-} + +-- Phases we can actually stop after +data StopPhase = StopPreprocess -- ^ @-E@ + | StopC -- ^ @-C@ + | StopAs -- ^ @-S@ + | NoStop -- ^ @-c@ + +stopPhaseToPhase :: StopPhase -> Phase +stopPhaseToPhase StopPreprocess = anyHsc +stopPhaseToPhase StopC = HCc +stopPhaseToPhase StopAs = As False +stopPhaseToPhase NoStop = StopLn + +-- | Untyped Phase description +data Phase + = Unlit HscSource + | Cpp HscSource + | HsPp HscSource + | Hsc HscSource + | Ccxx -- Compile C++ + | Cc -- Compile C + | Cobjc -- Compile Objective-C + | Cobjcxx -- Compile Objective-C++ + | HCc -- Haskellised C (as opposed to vanilla C) compilation + | As Bool -- Assembler for regular assembly files (Bool: with-cpp) + | LlvmOpt -- Run LLVM opt tool over llvm assembly + | LlvmLlc -- LLVM bitcode to native assembly + | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM + | CmmCpp -- pre-process Cmm source + | Cmm -- parse & compile Cmm code + | MergeForeign -- merge in the foreign object files + | Js -- pre-process Js source + + -- The final phase is a pseudo-phase that tells the pipeline to stop. + | StopLn -- Stop, but linking will follow, so generate .o file + deriving (Eq, Show) + +instance Outputable Phase where + ppr p = text (show p) + +anyHsc :: Phase +anyHsc = Hsc (panic "anyHsc") + +isStopLn :: Phase -> Bool +isStopLn StopLn = True +isStopLn _ = False + +eqPhase :: Phase -> Phase -> Bool +-- Equality of constructors, ignoring the HscSource field +-- NB: the HscSource field can be 'bot'; see anyHsc above +eqPhase (Unlit _) (Unlit _) = True +eqPhase (Cpp _) (Cpp _) = True +eqPhase (HsPp _) (HsPp _) = True +eqPhase (Hsc _) (Hsc _) = True +eqPhase Cc Cc = True +eqPhase Cobjc Cobjc = True +eqPhase HCc HCc = True +eqPhase (As x) (As y) = x == y +eqPhase LlvmOpt LlvmOpt = True +eqPhase LlvmLlc LlvmLlc = True +eqPhase LlvmMangle LlvmMangle = True +eqPhase CmmCpp CmmCpp = True +eqPhase Cmm Cmm = True +eqPhase MergeForeign MergeForeign = True +eqPhase StopLn StopLn = True +eqPhase Ccxx Ccxx = True +eqPhase Cobjcxx Cobjcxx = True +eqPhase Js Js = True +eqPhase _ _ = False + +-- MP: happensBefore is only used in preprocessPipeline, that usage should +-- be refactored and this usage removed. +happensBefore :: Platform -> Phase -> Phase -> Bool +happensBefore platform p1 p2 = p1 `happensBefore'` p2 + where StopLn `happensBefore'` _ = False + x `happensBefore'` y = after_x `eqPhase` y + || after_x `happensBefore'` y + where after_x = nextPhase platform x + +nextPhase :: Platform -> Phase -> Phase +nextPhase platform p + -- A conservative approximation to the next phase, used in happensBefore + = case p of + Unlit sf -> Cpp sf + Cpp sf -> HsPp sf + HsPp sf -> Hsc sf + Hsc _ -> maybeHCc + LlvmOpt -> LlvmLlc + LlvmLlc -> LlvmMangle + LlvmMangle -> As False + As _ -> MergeForeign + Ccxx -> MergeForeign + Cc -> MergeForeign + Cobjc -> MergeForeign + Cobjcxx -> MergeForeign + CmmCpp -> Cmm + Cmm -> maybeHCc + HCc -> MergeForeign + MergeForeign -> StopLn + Js -> StopLn + StopLn -> panic "nextPhase: nothing after StopLn" + where maybeHCc = if platformUnregisterised platform + then HCc + else As False + +-- the first compilation phase for a given file is determined +-- by its suffix. +startPhase :: String -> Phase +startPhase "lhs" = Unlit HsSrcFile +startPhase "lhs-boot" = Unlit HsBootFile +startPhase "lhsig" = Unlit HsigFile +startPhase "hs" = Cpp HsSrcFile +startPhase "hs-boot" = Cpp HsBootFile +startPhase "hsig" = Cpp HsigFile +startPhase "hscpp" = HsPp HsSrcFile +startPhase "hspp" = Hsc HsSrcFile +startPhase "hc" = HCc +startPhase "c" = Cc +startPhase "cpp" = Ccxx +startPhase "C" = Cc +startPhase "m" = Cobjc +startPhase "M" = Cobjcxx +startPhase "mm" = Cobjcxx +startPhase "cc" = Ccxx +startPhase "cxx" = Ccxx +startPhase "s" = As False +startPhase "S" = As True +startPhase "ll" = LlvmOpt +startPhase "bc" = LlvmLlc +startPhase "lm_s" = LlvmMangle +startPhase "o" = StopLn +startPhase "cmm" = CmmCpp +startPhase "cmmcpp" = Cmm +startPhase "js" = Js +startPhase _ = StopLn -- all unknown file types + +-- This is used to determine the extension for the output from the +-- current phase (if it generates a new file). The extension depends +-- on the next phase in the pipeline. +phaseInputExt :: Phase -> String +phaseInputExt (Unlit HsSrcFile) = "lhs" +phaseInputExt (Unlit HsBootFile) = "lhs-boot" +phaseInputExt (Unlit HsigFile) = "lhsig" +phaseInputExt (Cpp _) = "lpp" -- intermediate only +phaseInputExt (HsPp _) = "hscpp" -- intermediate only +phaseInputExt (Hsc _) = "hspp" -- intermediate only + -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x + -- because runPhase uses the StopBefore phase to pick the + -- output filename. That could be fixed, but watch out. +phaseInputExt HCc = "hc" +phaseInputExt Ccxx = "cpp" +phaseInputExt Cobjc = "m" +phaseInputExt Cobjcxx = "mm" +phaseInputExt Cc = "c" +phaseInputExt (As True) = "S" +phaseInputExt (As False) = "s" +phaseInputExt LlvmOpt = "ll" +phaseInputExt LlvmLlc = "bc" +phaseInputExt LlvmMangle = "lm_s" +phaseInputExt CmmCpp = "cmmcpp" +phaseInputExt Cmm = "cmm" +phaseInputExt MergeForeign = "o" +phaseInputExt Js = "js" +phaseInputExt StopLn = "o" + +haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, + js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes + :: [String] +-- When a file with an extension in the haskellish_src_suffixes group is +-- loaded in --make mode, its imports will be loaded too. +haskellish_src_suffixes = haskellish_user_src_suffixes ++ + [ "hspp", "hscpp" ] +haskellish_suffixes = haskellish_src_suffixes ++ + [ "hc", "cmm", "cmmcpp" ] +cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] +js_suffixes = [ "js" ] + +-- Will not be deleted as temp files: +haskellish_user_src_suffixes = + haskellish_sig_suffixes ++ haskellish_boot_suffixes ++ [ "hs", "lhs" ] +haskellish_boot_suffixes = [ "hs-boot", "lhs-boot" ] +haskellish_sig_suffixes = [ "hsig", "lhsig" ] +backpackish_suffixes = [ "bkp" ] + +objish_suffixes :: Platform -> [String] +-- Use the appropriate suffix for the system on which +-- the GHC-compiled code will run +objish_suffixes platform = case platformOS platform of + OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] + _ -> [ "o" ] + +dynlib_suffixes :: Platform -> [String] +dynlib_suffixes platform = case platformOS platform of + OSMinGW32 -> ["dll", "DLL"] + OSDarwin -> ["dylib", "so"] + _ -> ["so"] + +isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, + isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix + :: String -> Bool +isHaskellishSuffix s = s `elem` haskellish_suffixes +isBackpackishSuffix s = s `elem` backpackish_suffixes +isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes +isHaskellBootSuffix s = s `elem` haskellish_boot_suffixes +isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes +isCishSuffix s = s `elem` cish_suffixes +isJsSuffix s = s `elem` js_suffixes +isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes + +isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool +isObjectSuffix platform s = s `elem` objish_suffixes platform +isDynLibSuffix platform s = s `elem` dynlib_suffixes platform + +isSourceSuffix :: String -> Bool +isSourceSuffix suff = isHaskellishSuffix suff + || isCishSuffix suff + || isJsSuffix suff + || isBackpackishSuffix suff + +-- | When we are given files (modified by -x arguments) we need +-- to determine if they are Haskellish or not to figure out +-- how we should try to compile it. The rules are: +-- +-- 1. If no -x flag was specified, we check to see if +-- the file looks like a module name, has no extension, +-- or has a Haskell source extension. +-- +-- 2. If an -x flag was specified, we just make sure the +-- specified suffix is a Haskell one. +isHaskellishTarget :: (String, Maybe Phase) -> Bool +isHaskellishTarget (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) +isHaskellishTarget (_,Just phase) = + phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm, Js + , StopLn] + +isHaskellishFilename, isHaskellSrcFilename, isCishFilename, + isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename + :: FilePath -> Bool +-- takeExtension return .foo, so we drop 1 to get rid of the . +isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) +isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) +isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) +isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) +isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) +isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) + +isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool +isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) +isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f) + +-- | Foreign language of the phase if the phase deals with a foreign code +phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang +phaseForeignLanguage phase = case phase of + Cc -> Just LangC + Ccxx -> Just LangCxx + Cobjc -> Just LangObjc + Cobjcxx -> Just LangObjcxx + HCc -> Just LangC + As _ -> Just LangAsm + MergeForeign -> Just RawObject + Js -> Just LangJs + _ -> Nothing diff --git a/GHC/Driver/Pipeline.hs b/GHC/Driver/Pipeline.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Pipeline.hs @@ -0,0 +1,983 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.Pipeline ( + -- * Run a series of compilation steps in a pipeline, for a + -- collection of source files. + oneShot, compileFile, + + -- * Interfaces for the compilation manager (interpreted/batch-mode) + preprocess, + compileOne, compileOne', + compileForeign, compileEmptyStub, + + -- * Linking + link, linkingNeeded, checkLinkInfo, + + -- * PipeEnv + PipeEnv(..), mkPipeEnv, phaseOutputFilenameNew, + + -- * Running individual phases + TPhase(..), runPhase, + hscPostBackendPhase, + + -- * Constructing Pipelines + TPipelineClass, MonadUse(..), + + preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline, + hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline, jsPipeline, + llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart, + + -- * Default method of running a pipeline + runPipeline +) where + + +import GHC.Prelude +import GHC.Builtin.Names + +import GHC.Platform + +import GHC.Utils.Monad ( MonadIO(liftIO), mapMaybeM ) + +import GHC.Driver.Main +import GHC.Driver.Env hiding ( Hsc ) +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Pipeline.Monad +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.StgToJS +import GHC.Driver.Phases +import GHC.Driver.Pipeline.Execute +import GHC.Driver.Pipeline.Phases +import GHC.Driver.Session +import GHC.Driver.Backend +import GHC.Driver.Ppr +import GHC.Driver.Hooks + +import GHC.Platform.Ways + +import GHC.SysTools +import GHC.SysTools.Cpp +import GHC.Utils.TmpFs + +import GHC.Linker.ExtraObj +import GHC.Linker.Static +import GHC.Linker.Static.Utils +import GHC.Linker.Types + +import GHC.StgToJS.Linker.Linker + +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Exception as Exception +import GHC.Utils.Logger + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.FastString ( mkFastString ) +import GHC.Data.StringBuffer ( hPutStringBuffer ) +import GHC.Data.Maybe ( expectJust ) + +import GHC.Iface.Make ( mkFullIface ) +import GHC.Iface.Load ( getGhcPrimIface ) +import GHC.Runtime.Loader ( initializePlugins ) + + +import GHC.Types.Basic ( SuccessFlag(..), ForeignSrcLang(..) ) +import GHC.Types.Error ( singleMessage, getMessages, mkSimpleUnknownDiagnostic, defaultDiagnosticOpts ) +import GHC.Types.ForeignStubs (ForeignStubs (NoStubs)) +import GHC.Types.Target +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import GHC.Types.SourceError + +import GHC.Unit +import GHC.Unit.Env +import GHC.Unit.Finder +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable + +import System.Directory +import System.FilePath +import System.IO +import Control.Monad +import qualified Control.Monad.Catch as MC (handle) +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) + +import Data.Time ( getCurrentTime ) +import GHC.Iface.Recomp +import GHC.Types.Unique.DSet + +-- Simpler type synonym for actions in the pipeline monad +type P m = TPipelineClass TPhase m + +-- --------------------------------------------------------------------------- +-- Pre-process + +-- | Just preprocess a file, put the result in a temp. file (used by the +-- compilation manager during the summary phase). +-- +-- We return the augmented DynFlags, because they contain the result +-- of slurping in the OPTIONS pragmas + +preprocess :: HscEnv + -> FilePath -- ^ input filename + -> Maybe InputFileBuffer + -- ^ optional buffer to use instead of reading the input file + -> Maybe Phase -- ^ starting phase + -> IO (Either DriverMessages (DynFlags, FilePath)) +preprocess hsc_env input_fn mb_input_buf mb_phase = + handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $ + MC.handle handler $ + fmap Right $ do + massertPpr (isJust mb_phase || isHaskellSrcFilename input_fn) (text input_fn) + input_fn_final <- mkInputFn + let preprocess_pipeline = preprocessPipeline pipe_env (setDumpPrefix pipe_env hsc_env) input_fn_final + runPipeline (hsc_hooks hsc_env) preprocess_pipeline + + where + srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 + handler (ProgramError msg) = + return $ Left $ singleMessage $ + mkPlainErrorMsgEnvelope srcspan $ + DriverUnknownMessage $ mkSimpleUnknownDiagnostic $ mkPlainError noHints $ text msg + handler ex = throwGhcExceptionIO ex + + to_driver_messages :: Messages GhcMessage -> Messages DriverMessage + to_driver_messages msgs = case traverse to_driver_message msgs of + Nothing -> pprPanic "non-driver message in preprocess" + -- MP: Default config is fine here as it's just in a panic. + (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @GhcMessage) (getMessages msgs)) + Just msgs' -> msgs' + + to_driver_message = \case + GhcDriverMessage msg + -> Just msg + GhcPsMessage (PsHeaderMessage msg) + -> Just (DriverPsHeaderMessage (PsHeaderMessage msg)) + _ -> Nothing + + pipe_env = mkPipeEnv StopPreprocess input_fn mb_phase (Temporary TFL_GhcSession) + mkInputFn = + case mb_input_buf of + Just input_buf -> do + fn <- newTempName (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (tmpDir (hsc_dflags hsc_env)) + TFL_CurrentModule + ("buf_" ++ src_suffix pipe_env) + hdl <- openBinaryFile fn WriteMode + -- Add a LINE pragma so reported source locations will + -- mention the real input file, not this temp file. + hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}" + hPutStringBuffer hdl input_buf + hClose hdl + return fn + Nothing -> return input_fn + +-- --------------------------------------------------------------------------- + +-- | Compile +-- +-- Compile a single module, under the control of the compilation manager. +-- +-- This is the interface between the compilation manager and the +-- compiler proper (hsc), where we deal with tedious details like +-- reading the OPTIONS pragma from the source file, converting the +-- C or assembly that GHC produces into an object file, and compiling +-- FFI stub files. +-- +-- NB. No old interface can also mean that the source has changed. + + +compileOne :: HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> HomeModLinkable -- ^ old linkable, if we have one + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne = compileOne' (Just batchMsg) + +compileOne' :: Maybe Messager + -> HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> HomeModLinkable + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne' mHscMessage + hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable + = do + + debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp) + + unless (gopt Opt_KeepHiFiles lcl_dflags) $ + addFilesToClean tmpfs TFL_CurrentModule $ + [ml_hi_file $ ms_location summary] + unless (gopt Opt_KeepOFiles lcl_dflags) $ + addFilesToClean tmpfs TFL_GhcSession $ + [ml_obj_file $ ms_location summary] + + -- Initialise plugins here for any plugins enabled locally for a module. + plugin_hsc_env <- initializePlugins hsc_env + let pipe_env = mkPipeEnv NoStop input_fn Nothing pipelineOutput + status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary + mb_old_iface mb_old_linkable (mod_index, nmods) + let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status) + (iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline + -- See Note [ModDetails and --make mode] + details <- initModDetails plugin_hsc_env iface + linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable) + return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' }) + + where lcl_dflags = ms_hspp_opts summary + location = ms_location summary + input_fn = expectJust (ml_hs_file location) + input_fnpp = ms_hspp_file summary + + pipelineOutput = backendPipelineOutput bcknd + + logger = hsc_logger hsc_env0 + tmpfs = hsc_tmpfs hsc_env0 + + basename = dropExtension input_fn + + -- We add the directory in which the .hs files resides) to the import + -- path. This is needed when we try to compile the .hc file later, if it + -- imports a _stub.h file that we created here. + current_dir = takeDirectory basename + old_paths = includePaths lcl_dflags + loadAsByteCode + | Just Target { targetAllowObjCode = obj } <- findTarget summary (hsc_targets hsc_env0) + , not obj + = True + | otherwise = False + -- Figure out which backend we're using + (bcknd, dflags3) + -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags + -- suggest to generate object code (which may happen in case -fobject-code + -- was set), force it to generate byte-code. This is NOT transitive and + -- only applies to direct targets. + | loadAsByteCode + = ( interpreterBackend + , gopt_set (lcl_dflags { backend = interpreterBackend }) Opt_ForceRecomp + ) + + | otherwise + = (backend dflags, lcl_dflags) + -- See Note [Filepaths and Multiple Home Units] + dflags = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] } + upd_summary = summary { ms_hspp_opts = dflags } + hsc_env = hscSetFlags dflags hsc_env0 + + +-- --------------------------------------------------------------------------- +-- Link +-- +-- Note [Dynamic linking on macOS] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Since macOS Sierra (10.14), the dynamic system linker enforces +-- a limit on the Load Commands. Specifically the Load Command Size +-- Limit is at 32K (32768). The Load Commands contain the install +-- name, dependencies, runpaths, and a few other commands. We however +-- only have control over the install name, dependencies and runpaths. +-- +-- The install name is the name by which this library will be +-- referenced. This is such that we do not need to bake in the full +-- absolute location of the library, and can move the library around. +-- +-- The dependency commands contain the install names from of referenced +-- libraries. Thus if a libraries install name is @rpath/libHS...dylib, +-- that will end up as the dependency. +-- +-- Finally we have the runpaths, which informs the linker about the +-- directories to search for the referenced dependencies. +-- +-- The system linker can do recursive linking, however using only the +-- direct dependencies conflicts with ghc's ability to inline across +-- packages, and as such would end up with unresolved symbols. +-- +-- Thus we will pass the full dependency closure to the linker, and then +-- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs). +-- +-- We still need to add the relevant runpaths, for the dynamic linker to +-- lookup the referenced libraries though. The linker (ld64) does not +-- have any option to dead strip runpaths; which makes sense as runpaths +-- can be used for dependencies of dependencies as well. +-- +-- The solution we then take in GHC is to not pass any runpaths to the +-- linker at link time, but inject them after the linking. For this to +-- work we'll need to ask the linker to create enough space in the header +-- to add more runpaths after the linking (-headerpad 8000). +-- +-- After the library has been linked by $LD (usually ld64), we will use +-- otool to inspect the libraries left over after dead stripping, compute +-- the relevant runpaths, and inject them into the linked product using +-- the install_name_tool command. +-- +-- This strategy should produce the smallest possible set of load commands +-- while still retaining some form of relocatability via runpaths. +-- +-- The only way I can see to reduce the load command size further would be +-- by shortening the library names, or start putting libraries into the same +-- folders, such that one runpath would be sufficient for multiple/all +-- libraries. +link :: GhcLink -- ^ interactive or batch + -> Logger -- ^ Logger + -> TmpFs + -> FinderCache + -> Hooks + -> DynFlags -- ^ dynamic flags + -> UnitEnv -- ^ unit environment + -> Bool -- ^ attempt linking in batch mode? + -> Maybe (RecompileRequired -> IO ()) + -> HomePackageTable -- ^ what to link + -> IO SuccessFlag + +-- For the moment, in the batch linker, we don't bother to tell doLink +-- which packages to link -- it just tries all that are available. +-- batch_attempt_linking should only be *looked at* in batch mode. It +-- should only be True if the upsweep was successful and someone +-- exports main, i.e., we have good reason to believe that linking +-- will succeed. + +link ghcLink logger tmpfs fc hooks dflags unit_env batch_attempt_linking mHscMessage hpt = + case linkHook hooks of + Nothing -> case ghcLink of + NoLink -> return Succeeded + LinkBinary -> normal_link + LinkStaticLib -> normal_link + LinkDynLib -> normal_link + LinkMergedObj -> normal_link + LinkInMemory + | platformMisc_ghcWithInterpreter $ platformMisc dflags + -- Not Linking...(demand linker will do the job) + -> return Succeeded + | otherwise + -> panicBadLink LinkInMemory + Just h -> h ghcLink dflags batch_attempt_linking hpt + where + normal_link = link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessage hpt + + +panicBadLink :: GhcLink -> a +panicBadLink other = panic ("link: GHC not built to link this way: " ++ + show other) + +link' :: Logger + -> TmpFs + -> FinderCache + -> DynFlags -- ^ dynamic flags + -> UnitEnv -- ^ unit environment + -> Bool -- ^ attempt linking in batch mode? + -> Maybe (RecompileRequired -> IO ()) + -> HomePackageTable -- ^ what to link + -> IO SuccessFlag + +link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt + | batch_attempt_linking + = do + let + staticLink = case ghcLink dflags of + LinkStaticLib -> True + _ -> False + + -- the packages we depend on + -- TODO: This should be a query on the 'ModuleGraph', since we need to + -- know which packages are actually needed at the runtime stage. + pkg_deps <- map snd . Set.toList <$> hptCollectDependencies hpt + + -- the linkables to link + linkables <- hptCollectObjects hpt + + -- the home modules, for tracing + home_modules <- hptCollectModules hpt + + debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map ppr home_modules)) + debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr pkg_deps)) + + -- check for the -no-link flag + if isNoLink (ghcLink dflags) + then do debugTraceMsg logger 3 (text "link(batch): linking omitted (-c flag given).") + return Succeeded + else do + + let obj_files = concatMap linkableObjs linkables + platform = targetPlatform dflags + arch_os = platformArchOS platform + exe_file = exeFileName arch_os staticLink (outputFile_ dflags) + + linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps + + forM_ mHscMessager $ \hscMessage -> hscMessage linking_needed + if not (gopt Opt_ForceRecomp dflags) && (linking_needed == UpToDate) + then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.") + return Succeeded + else do + + + -- Don't showPass in Batch mode; doLink will do that for us. + case ghcLink dflags of + LinkBinary + | backendUseJSLinker (backend dflags) -> linkJSBinary logger tmpfs fc dflags unit_env obj_files pkg_deps + | otherwise -> linkBinary logger tmpfs dflags unit_env obj_files pkg_deps + LinkStaticLib -> linkStaticLib logger dflags unit_env obj_files pkg_deps + LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env obj_files pkg_deps + other -> panicBadLink other + + debugTraceMsg logger 3 (text "link: done") + + -- linkBinary only returns if it succeeds + return Succeeded + + | otherwise + = do debugTraceMsg logger 3 (text "link(batch): upsweep (partially) failed OR" $$ + text " Main.main not exported; not linking.") + return Succeeded + + +linkJSBinary :: Logger -> TmpFs -> FinderCache -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkJSBinary logger tmpfs fc dflags unit_env obj_files pkg_deps = do + -- we use the default configuration for now. In the future we may expose + -- settings to the user via DynFlags. + let lc_cfg = initJSLinkConfig dflags + let cfg = initStgToJSConfig dflags + jsLinkBinary fc lc_cfg cfg logger tmpfs dflags unit_env obj_files pkg_deps + +linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired +linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do + -- if the modification time on the executable is later than the + -- modification times on all of the objects and libraries, then omit + -- linking (unless the -fforce-recomp flag was given). + let platform = ue_platform unit_env + unit_state = ue_homeUnitState unit_env + arch_os = platformArchOS platform + exe_file = exeFileName arch_os staticLink (outputFile_ dflags) + e_exe_time <- tryIO $ getModificationUTCTime exe_file + case e_exe_time of + Left _ -> return $ NeedsRecompile MustCompile + Right t -> do + -- first check object files and extra_ld_inputs + let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] + (errs,extra_times) <- partitionWithM (tryIO . getModificationUTCTime) extra_ld_inputs + let obj_times = map linkableTime linkables ++ extra_times + if not (null errs) || any (t <) obj_times + then return $ needsRecompileBecause ObjectsChanged + else do + + -- next, check libraries. XXX this only checks Haskell libraries, + -- not extra_libraries or -l things from the command line. + -- pkg_deps is just the direct dependencies so take the transitive closure here + -- to decide if we need to relink or not. + let pkg_hslibs acc uid + | uid `elementOfUniqDSet` acc = acc + | Just c <- lookupUnitId unit_state uid = + foldl' @[] pkg_hslibs (addOneToUniqDSet acc uid) (unitDepends c) + | otherwise = acc + + all_pkg_deps = foldl' @[] pkg_hslibs emptyUniqDSet pkg_deps + + let pkg_hslibs = [ (collectLibraryDirs (ways dflags) [c], lib) + | Just c <- map (lookupUnitId unit_state) (uniqDSetToList all_pkg_deps), + lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ] + + pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs + if any isNothing pkg_libfiles then return $ needsRecompileBecause LibraryChanged else do + (lib_errs,lib_times) <- partitionWithM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles) + if not (null lib_errs) || any (t <) lib_times + then return $ needsRecompileBecause LibraryChanged + else do + res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file + if res + then return $ needsRecompileBecause FlagsChanged + else return UpToDate + + +findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath) +findHSLib platform ws dirs lib = do + let batch_lib_file = if ws `hasNotWay` WayDyn + then "lib" ++ lib <.> "a" + else platformSOName platform lib + found <- filterM doesFileExist (map ( batch_lib_file) dirs) + case found of + [] -> return Nothing + (x:_) -> return (Just x) + +-- ----------------------------------------------------------------------------- +-- Compile files in one-shot mode. + +oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO () +oneShot orig_hsc_env stop_phase srcs = do + -- In oneshot mode, initialise plugins specified on command line + -- we also initialise in ghc/Main but this might be used as an entry point by API clients who + -- should initialise their own plugins but may not. + -- See Note [Timing of plugin initialization] + hsc_env <- initializePlugins orig_hsc_env + o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs + case stop_phase of + StopPreprocess -> return () + StopC -> return () + StopAs -> return () + NoStop -> doLink hsc_env o_files + +compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath) +compileFile hsc_env stop_phase (src, mb_phase) = do + let offset_file = augmentByWorkingDirectory dflags src + dflags = hsc_dflags hsc_env + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + notStopPreprocess | StopPreprocess <- stop_phase = False + | _ <- stop_phase = True + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile + -- avoid -E -fno-code undesirable interactions. see #20439 + | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | isJust mb_o_file = SpecificFile + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + pipe_env = mkPipeEnv stop_phase offset_file mb_phase output + pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) offset_file mb_phase + + exists <- doesFileExist offset_file + when (not exists) $ + throwGhcExceptionIO (CmdLineError ("does not exist: " ++ offset_file)) + runPipeline (hsc_hooks hsc_env) pipeline + + +doLink :: HscEnv -> [FilePath] -> IO () +doLink hsc_env o_files = do + let + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + unit_env = hsc_unit_env hsc_env + tmpfs = hsc_tmpfs hsc_env + fc = hsc_FC hsc_env + + case ghcLink dflags of + NoLink -> return () + LinkBinary + | backendUseJSLinker (backend dflags) + -> linkJSBinary logger tmpfs fc dflags unit_env o_files [] + | otherwise -> linkBinary logger tmpfs dflags unit_env o_files [] + LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] + LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files [] + LinkMergedObj + | Just out <- outputFile dflags + , let objs = [ f | FileOption _ f <- ldInputs dflags ] + -> joinObjectFiles hsc_env (o_files ++ objs) out + | otherwise -> panic "Output path must be specified for LinkMergedObj" + other -> panicBadLink other + +----------------------------------------------------------------------------- +-- stub .h and .c files (for foreign export support), and cc files. + +-- The _stub.c file is derived from the haskell source file, possibly taking +-- into account the -stubdir option. +-- +-- The object file created by compiling the _stub.c file is put into a +-- temporary file, which will be later combined with the main .o file +-- (see the MergeForeign phase). +-- +-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files +-- from TH, that are then compiled and linked to the module. This is +-- useful to implement facilities such as inline-c. + +compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath +compileForeign _ RawObject object_file = return object_file +compileForeign hsc_env lang stub_c = do + let pipeline = case lang of + LangC -> viaCPipeline Cc + LangCxx -> viaCPipeline Ccxx + LangObjc -> viaCPipeline Cobjc + LangObjcxx -> viaCPipeline Cobjcxx + LangAsm -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp + LangJs -> \pe hsc_env ml fp -> Just <$> foreignJsPipeline pe hsc_env ml fp + pipe_env = mkPipeEnv NoStop stub_c Nothing (Temporary TFL_GhcSession) + res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c) + case res of + -- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`. + -- and the same should never happen for asPipeline + -- Future refactoring to not check StopC for this case + Nothing -> pprPanic "compileForeign" (text stub_c) + Just fp -> return fp + +compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () +compileEmptyStub dflags hsc_env basename location mod_name = do + -- To maintain the invariant that every Haskell file + -- compiles to object code, we make an empty (but + -- valid) stub object file for signatures. However, + -- we make sure this object file has a unique symbol, + -- so that ranlib on OS X doesn't complain, see + -- https://gitlab.haskell.org/ghc/ghc/issues/12673 + -- and https://github.com/haskell/cabal/issues/2257 + let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env + let home_unit = hsc_home_unit hsc_env + + case backendCodeOutput (backend dflags) of + JSCodeOutput -> do + empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" + let src = ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" + writeFile empty_stub (showSDoc dflags (pprCode src)) + let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename} + pipeline = Just <$> foreignJsPipeline pipe_env hsc_env (Just location) empty_stub + _ <- runPipeline (hsc_hooks hsc_env) pipeline + pure () + + _ -> do + empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" + let src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" + writeFile empty_stub (showSDoc dflags (pprCode src)) + let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename} + pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub + _ <- runPipeline (hsc_hooks hsc_env) pipeline + pure () + + + +{- Environment Initialisation -} + +mkPipeEnv :: StopPhase -- End phase + -> FilePath -- input fn + -> Maybe Phase + -> PipelineOutput -- Output + -> PipeEnv +mkPipeEnv stop_phase input_fn start_phase output = + let (basename, suffix) = splitExtension input_fn + suffix' = drop 1 suffix -- strip off the . + env = PipeEnv{ stop_phase, + src_filename = input_fn, + src_basename = basename, + src_suffix = suffix', + start_phase = fromMaybe (startPhase suffix') start_phase, + output_spec = output } + in env + +setDumpPrefix :: PipeEnv -> HscEnv -> HscEnv +setDumpPrefix pipe_env hsc_env = + hscUpdateFlags (\dflags -> dflags { dumpPrefix = src_basename pipe_env ++ "."}) hsc_env + +{- The Pipelines -} + +phaseIfFlag :: Monad m + => HscEnv + -> (DynFlags -> Bool) + -> a + -> m a + -> m a +phaseIfFlag hsc_env flag def action = + if flag (hsc_dflags hsc_env) + then action + else return def + +-- | Check if the start is *before* the current phase, otherwise skip with a default +phaseIfAfter :: P m => Platform -> Phase -> Phase -> a -> m a -> m a +phaseIfAfter platform start_phase cur_phase def action = + if start_phase `eqPhase` cur_phase + || happensBefore platform start_phase cur_phase + + then action + else return def + +-- | The preprocessor pipeline +preprocessPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath) +preprocessPipeline pipe_env hsc_env input_fn = do + unlit_fn <- + runAfter (Unlit HsSrcFile) input_fn $ do + use (T_Unlit pipe_env hsc_env input_fn) + + + (dflags1, p_warns1, warns1) <- use (T_FileArgs hsc_env unlit_fn) + let hsc_env1 = hscSetFlags dflags1 hsc_env + + (cpp_fn, hsc_env2) + <- runAfterFlag hsc_env1 (Cpp HsSrcFile) (xopt LangExt.Cpp) (unlit_fn, hsc_env1) $ do + cpp_fn <- use (T_Cpp pipe_env hsc_env1 unlit_fn) + (dflags2, _, _) <- use (T_FileArgs hsc_env1 cpp_fn) + let hsc_env2 = hscSetFlags dflags2 hsc_env1 + return (cpp_fn, hsc_env2) + + + pp_fn <- runAfterFlag hsc_env2 (HsPp HsSrcFile) (gopt Opt_Pp) cpp_fn $ + use (T_HsPp pipe_env hsc_env2 input_fn cpp_fn) + + (dflags3, p_warns3, warns3) + <- if pp_fn == unlit_fn + -- Didn't run any preprocessors so don't need to reparse, would be nicer + -- if `T_FileArgs` recognised this. + then return (dflags1, p_warns1, warns1) + else do + -- Reparse with original hsc_env so that we don't get duplicated options + use (T_FileArgs hsc_env pp_fn) + + let print_config = initPrintConfig dflags3 + liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3)) + liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcDriverMessage <$> warns3)) + return (dflags3, pp_fn) + + + -- This won't change through the compilation pipeline + where platform = targetPlatform (hsc_dflags hsc_env) + runAfter :: P p => Phase + -> a -> p a -> p a + runAfter = phaseIfAfter platform (start_phase pipe_env) + runAfterFlag :: P p + => HscEnv + -> Phase + -> (DynFlags -> Bool) + -> a + -> p a + -> p a + runAfterFlag hsc_env phase flag def action = + runAfter phase def + $ phaseIfFlag hsc_env flag def action + +-- | The complete compilation pipeline, from start to finish +fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable) +fullPipeline pipe_env hsc_env pp_fn src_flavour = do + (dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn + let hsc_env' = hscSetFlags dflags hsc_env + (hsc_env_with_plugins, mod_sum, hsc_recomp_status) + <- use (T_HscRecomp pipe_env hsc_env' input_fn src_flavour) + hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) + +-- | Everything after preprocess +hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, HomeModLinkable) +hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do + case hsc_recomp_status of + HscUpToDate iface mb_linkable -> return (iface, mb_linkable) + HscRecompNeeded mb_old_hash -> do + (tc_result, warnings) <- use (T_Hsc hsc_env_with_plugins mod_sum) + hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash ) + hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction + +hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable) +hscBackendPipeline pipe_env hsc_env mod_sum result = + if backendGeneratesCode (backend (hsc_dflags hsc_env)) then + do + res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result + -- Only run dynamic-too if the backend generates object files + -- See Note [Writing interface files] + -- If we are writing a simple interface (not . backendWritesFiles), then + -- hscMaybeWriteIface in the regular pipeline will write both the hi and + -- dyn_hi files. This way we can avoid running the pipeline twice and + -- generating a duplicate linkable. + -- We must not run the backend a second time with `dynamicNow` enable because + -- all the work has already been done in the first pipeline. + when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env) && backendWritesFiles (backend (hsc_dflags hsc_env)) ) $ do + let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow" + () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result + return res + else + case result of + HscUpdate iface -> return (iface, emptyHomeModInfoLinkable) + HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyHomeModInfoLinkable + +hscGenBackendPipeline :: P m + => PipeEnv + -> HscEnv + -> ModSummary + -> HscBackendAction + -> m (ModIface, HomeModLinkable) +hscGenBackendPipeline pipe_env hsc_env mod_sum result = do + let mod_name = moduleName (ms_mod mod_sum) + src_flavour = (ms_hsc_src mod_sum) + let location = ms_location mod_sum + (fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result) + final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file + final_linkable <- + case final_fp of + -- No object file produced, bytecode or NoBackend + Nothing -> return mlinkable + Just o_fp -> do + part_time <- liftIO getCurrentTime + final_object <- use (T_MergeForeign pipe_env hsc_env o_fp fos) + let !linkable = Linkable part_time (ms_mod mod_sum) (NE.singleton (DotO final_object ModuleObject)) + -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend. + return (mlinkable { homeMod_object = Just linkable }) + + -- when building ghc-internal with --make (e.g. with cabal-install), we want + -- the virtual interface for gHC_PRIM in the cache, not the empty one. + let miface_final + | ms_mod mod_sum == gHC_PRIM = getGhcPrimIface (hsc_hooks hsc_env) + | otherwise = miface + return (miface_final, final_linkable) + +asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile) +asPipeline use_cpp pipe_env hsc_env location input_fn = + case stop_phase pipe_env of + StopAs -> return Nothing + _ -> Just <$> use (T_As use_cpp pipe_env hsc_env location input_fn) + +lasPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile) +lasPipeline use_cpp pipe_env hsc_env location input_fn = + case stop_phase pipe_env of + StopAs -> return Nothing + _ -> Just <$> use (T_LlvmAs use_cpp pipe_env hsc_env location input_fn) + +viaCPipeline :: P m => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +viaCPipeline c_phase pipe_env hsc_env location input_fn = do + out_fn <- use (T_Cc c_phase pipe_env hsc_env location input_fn) + case stop_phase pipe_env of + StopC -> return Nothing + _ -> return $ Just out_fn + +llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +llvmPipeline pipe_env hsc_env location fp = do + opt_fn <- use (T_LlvmOpt pipe_env hsc_env fp) + llvmLlcPipeline pipe_env hsc_env location opt_fn + +llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +llvmLlcPipeline pipe_env hsc_env location opt_fn = do + llc_fn <- use (T_LlvmLlc pipe_env hsc_env opt_fn) + llvmManglePipeline pipe_env hsc_env location llc_fn + +llvmManglePipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +llvmManglePipeline pipe_env hsc_env location llc_fn = do + mangled_fn <- + if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env) + then return llc_fn + else use (T_LlvmMangle pipe_env hsc_env llc_fn) + lasPipeline False pipe_env hsc_env location mangled_fn + +cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) +cmmCppPipeline pipe_env hsc_env input_fn = do + output_fn <- use (T_CmmCpp pipe_env hsc_env input_fn) + cmmPipeline pipe_env hsc_env output_fn + +cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) +cmmPipeline pipe_env hsc_env input_fn = do + (fos, output_fn) <- use (T_Cmm pipe_env hsc_env input_fn) + mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn + case mo_fn of + Nothing -> return Nothing + Just mo_fn -> Just <$> use (T_MergeForeign pipe_env hsc_env mo_fn fos) + +jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath +jsPipeline pipe_env hsc_env location input_fn = do + use (T_Js pipe_env hsc_env location input_fn) + +foreignJsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath +foreignJsPipeline pipe_env hsc_env location input_fn = do + use (T_ForeignJs pipe_env hsc_env location input_fn) + +hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +hscPostBackendPipeline _ _ (HsBootOrSig _) _ _ _ = return Nothing +hscPostBackendPipeline pipe_env hsc_env HsSrcFile bcknd ml input_fn = + applyPostHscPipeline (backendPostHscPipeline bcknd) pipe_env hsc_env ml input_fn + +applyPostHscPipeline + :: TPipelineClass TPhase m + => DefunctionalizedPostHscPipeline + -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +applyPostHscPipeline NcgPostHscPipeline = + \pe he ml fp -> asPipeline False pe he ml fp +applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc +applyPostHscPipeline LlvmPostHscPipeline = + \pe he ml fp -> llvmPipeline pe he ml fp +applyPostHscPipeline JSPostHscPipeline = + \pe he ml fp -> Just <$> jsPipeline pe he ml fp +applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing + +-- Pipeline from a given suffix +pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath) +pipelineStart pipe_env hsc_env input_fn mb_phase = + fromPhase (fromMaybe (startPhase $ src_suffix pipe_env) mb_phase) + where + stop_after = stop_phase pipe_env + frontend :: P m => HscSource -> m (Maybe FilePath) + frontend sf = case stop_after of + StopPreprocess -> do + -- The actual output from preprocessing + (_, out_fn) <- preprocessPipeline pipe_env hsc_env input_fn + let logger = hsc_logger hsc_env + -- Sometimes, a compilation phase doesn't actually generate any output + -- (eg. the CPP phase when -fcpp is not turned on). If we end on this + -- stage, but we wanted to keep the output, then we have to explicitly + -- copy the file, remembering to prepend a {-# LINE #-} pragma so that + -- further compilation stages can tell what the original filename was. + -- File name we expected the output to have + final_fn <- liftIO $ phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing + when (final_fn /= out_fn) $ do + let msg = "Copying `" ++ out_fn ++"' to `" ++ final_fn ++ "'" + line_prag = "{-# LINE 1 \"" ++ src_filename pipe_env ++ "\" #-}\n" + liftIO (showPass logger msg) + liftIO (copyWithHeader line_prag out_fn final_fn) + return Nothing + _ -> objFromLinkable <$> fullPipeline pipe_env hsc_env input_fn sf + c :: P m => Phase -> m (Maybe FilePath) + c phase = viaCPipeline phase pipe_env hsc_env Nothing input_fn + as :: P m => Bool -> m (Maybe FilePath) + as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn + + objFromLinkable (_, homeMod_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk + objFromLinkable _ = Nothing + + fromPhase :: P m => Phase -> m (Maybe FilePath) + fromPhase (Unlit p) = frontend p + fromPhase (Cpp p) = frontend p + fromPhase (HsPp p) = frontend p + fromPhase (Hsc p) = frontend p + fromPhase HCc = c HCc + fromPhase Cc = c Cc + fromPhase Ccxx = c Ccxx + fromPhase Cobjc = c Cobjc + fromPhase Cobjcxx = c Cobjcxx + fromPhase (As p) = as p + fromPhase LlvmOpt = llvmPipeline pipe_env hsc_env Nothing input_fn + fromPhase LlvmLlc = llvmLlcPipeline pipe_env hsc_env Nothing input_fn + fromPhase LlvmMangle = llvmManglePipeline pipe_env hsc_env Nothing input_fn + fromPhase StopLn = return (Just input_fn) + fromPhase CmmCpp = cmmCppPipeline pipe_env hsc_env input_fn + fromPhase Cmm = cmmPipeline pipe_env hsc_env input_fn + fromPhase Js = Just <$> foreignJsPipeline pipe_env hsc_env Nothing input_fn + fromPhase MergeForeign = panic "fromPhase: MergeForeign" + +{- +Note [The Pipeline Monad] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The pipeline is represented as a free monad by the `TPipelineClass` type synonym, +which stipulates the general monadic interface for the pipeline and `MonadUse`, instantiated +to `TPhase`, which indicates the actions available in the pipeline. + +The `TPhase` actions correspond to different compiled phases, they are executed by +the 'runPhase' function which interprets each action into IO. + +The idea in the future is that we can now implement different instiations of +`TPipelineClass` to give different behaviours that the default `HookedPhase` implementation: + +* Additional logging of different phases +* Automatic parallelism (in the style of shake) +* Easy consumption by external tools such as ghcide +* Easier to create your own pipeline and extend existing pipelines. + +The structure of the code as a free monad also means that the return type of each +phase is a lot more flexible. + +-} diff --git a/GHC/Driver/Pipeline.hs-boot b/GHC/Driver/Pipeline.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Driver/Pipeline.hs-boot @@ -0,0 +1,24 @@ +module GHC.Driver.Pipeline where + + +import GHC.Driver.Env.Types ( HscEnv ) +import GHC.ForeignSrcLang ( ForeignSrcLang ) +import GHC.Prelude (FilePath, IO, Maybe, Either) +import GHC.Unit.Module.Location (ModLocation) +import GHC.Driver.Session (DynFlags) +import GHC.Driver.Phases (Phase) +import GHC.Driver.Errors.Types (DriverMessages) +import GHC.Types.Target (InputFileBuffer) + +import Language.Haskell.Syntax.Module.Name + +-- These are used in GHC.Driver.Pipeline.Execute, but defined in terms of runPipeline +compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath +compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () + +preprocess :: HscEnv + -> FilePath + -> Maybe InputFileBuffer + -> Maybe Phase + -> IO (Either DriverMessages (DynFlags, FilePath)) + diff --git a/GHC/Driver/Pipeline/Execute.hs b/GHC/Driver/Pipeline/Execute.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Pipeline/Execute.hs @@ -0,0 +1,1307 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +#include + +{- Functions for providing the default interpretation of the 'TPhase' actions +-} +module GHC.Driver.Pipeline.Execute where + +import GHC.Prelude +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Catch +import GHC.Driver.Hooks +import Control.Monad.Trans.Reader +import GHC.Driver.Pipeline.Monad +import GHC.Driver.Pipeline.Phases +import GHC.Driver.Env hiding (Hsc) +import GHC.Unit.Module.Location +import GHC.Unit.Module.ModGuts (cg_foreign, cg_foreign_files) +import GHC.Driver.Phases +import GHC.Unit.Types +import GHC.Types.ForeignStubs (ForeignStubs (NoStubs)) +import GHC.Types.SourceFile +import GHC.Unit.Module.Status +import GHC.Unit.Module.ModIface +import GHC.Driver.Backend +import GHC.Driver.Session +import GHC.Unit.Module.ModSummary +import qualified GHC.LanguageExtensions as LangExt +import GHC.Types.SrcLoc +import GHC.Driver.Main +import GHC.Driver.Downsweep +import GHC.Tc.Types +import GHC.Types.Error +import GHC.Driver.Errors.Types +import GHC.Fingerprint +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Platform +import Data.List (intercalate, isInfixOf) +import GHC.Unit.Env +import GHC.Utils.Error +import Data.Maybe +import GHC.CmmToLlvm.Mangler +import GHC.SysTools +import GHC.SysTools.Cpp +import System.Directory +import System.FilePath +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Unit.Info +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Data.Maybe +import GHC.Iface.Make +import GHC.Driver.Config.Parser +import GHC.Parser.Header +import GHC.Data.StringBuffer +import GHC.Data.OsPath (unsafeEncodeUtf) +import GHC.Types.SourceError +import GHC.Unit.Finder +import Data.IORef +import GHC.Types.Name.Env +import GHC.Platform.Ways +import GHC.Driver.LlvmConfigCache (readLlvmConfigCache) +import GHC.CmmToLlvm.Config (LlvmTarget (..), LlvmConfig (..)) +import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub) +import GHC.Settings +import System.IO +import GHC.Linker.ExtraObj +import GHC.Linker.Dynamic +import GHC.Utils.Panic +import GHC.Utils.Touch +import GHC.Unit.Module.Env +import GHC.Driver.Env.KnotVars +import GHC.Driver.Config.Finder +import GHC.Rename.Names +import GHC.StgToJS.Linker.Linker (embedJsFile) + +import Language.Haskell.Syntax.Module.Name +import GHC.Unit.Home.ModInfo +import GHC.Runtime.Loader (initializePlugins) + +newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO) + +instance MonadUse TPhase HookedUse where + use fa = HookedUse $ \(hooks, (PhaseHook k)) -> + case runPhaseHook hooks of + Nothing -> k fa + Just (PhaseHook h) -> h fa + +-- | The default mechanism to run a pipeline, see Note [The Pipeline Monad] +runPipeline :: Hooks -> HookedUse a -> IO a +runPipeline hooks pipeline = runHookedUse pipeline (hooks, PhaseHook runPhase) + +-- | Default interpretation of each phase, in terms of IO. +runPhase :: TPhase out -> IO out +runPhase (T_Unlit pipe_env hsc_env inp_path) = do + out_path <- phaseOutputFilenameNew (Cpp HsSrcFile) pipe_env hsc_env Nothing + runUnlitPhase hsc_env inp_path out_path +runPhase (T_FileArgs hsc_env inp_path) = getFileArgs hsc_env inp_path +runPhase (T_Cpp pipe_env hsc_env inp_path) = do + out_path <- phaseOutputFilenameNew (HsPp HsSrcFile) pipe_env hsc_env Nothing + runCppPhase hsc_env inp_path out_path +runPhase (T_HsPp pipe_env hsc_env origin_path inp_path) = do + out_path <- phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing + runHsPpPhase hsc_env origin_path inp_path out_path +runPhase (T_HscRecomp pipe_env hsc_env fp hsc_src) = do + runHscPhase pipe_env hsc_env fp hsc_src +runPhase (T_Hsc hsc_env mod_sum) = runHscTcPhase hsc_env mod_sum +runPhase (T_HscPostTc hsc_env ms fer m mfi) = + runHscPostTcPhase hsc_env ms fer m mfi +runPhase (T_HscBackend pipe_env hsc_env mod_name hsc_src location x) = do + runHscBackendPhase pipe_env hsc_env mod_name hsc_src location x +runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do + output_fn <- phaseOutputFilenameNew Cmm pipe_env hsc_env Nothing + doCpp (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (hsc_dflags hsc_env) + (hsc_unit_env hsc_env) + (CppOpts + { sourceCodePreprocessor = SCPCmmCpp + , cppLinePragmas = True + }) + input_fn output_fn + return output_fn +runPhase (T_Js pipe_env hsc_env location js_src) = + runJsPhase pipe_env hsc_env location js_src +runPhase (T_ForeignJs pipe_env hsc_env location js_src) = + runForeignJsPhase pipe_env hsc_env location js_src +runPhase (T_Cmm pipe_env hsc_env input_fn) = do + let dflags = hsc_dflags hsc_env + let next_phase = hscPostBackendPhase HsSrcFile (backend dflags) + output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing + mstub <- hscCompileCmmFile hsc_env (src_filename pipe_env) input_fn output_fn + stub_o <- mapM (compileStub hsc_env) mstub + let foreign_os = maybeToList stub_o + return (foreign_os, output_fn) + +runPhase (T_Cc phase pipe_env hsc_env location input_fn) = runCcPhase phase pipe_env hsc_env location input_fn +runPhase (T_As cpp pipe_env hsc_env location input_fn) = do + runAsPhase cpp pipe_env hsc_env location input_fn +runPhase (T_LlvmOpt pipe_env hsc_env input_fn) = + runLlvmOptPhase pipe_env hsc_env input_fn +runPhase (T_LlvmLlc pipe_env hsc_env input_fn) = + runLlvmLlcPhase pipe_env hsc_env input_fn +runPhase (T_LlvmAs cpp pipe_env hsc_env location input_fn) = do + runLlvmAsPhase cpp pipe_env hsc_env location input_fn +runPhase (T_LlvmMangle pipe_env hsc_env input_fn) = + runLlvmManglePhase pipe_env hsc_env input_fn +runPhase (T_MergeForeign pipe_env hsc_env input_fn fos) = + runMergeForeign pipe_env hsc_env input_fn fos + +runLlvmManglePhase :: PipeEnv -> HscEnv -> FilePath -> IO [Char] +runLlvmManglePhase pipe_env hsc_env input_fn = do + let next_phase = As False + output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing + let dflags = hsc_dflags hsc_env + llvmFixupAsm (targetPlatform dflags) input_fn output_fn + return output_fn + +runMergeForeign :: PipeEnv -> HscEnv -> FilePath -> [FilePath] -> IO FilePath +runMergeForeign _pipe_env hsc_env input_fn foreign_os = do + if null foreign_os + then return input_fn + else do + -- Work around a binutil < 2.31 bug where you can't merge objects if the output file + -- is one of the inputs + new_o <- newTempName (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (tmpDir (hsc_dflags hsc_env)) + TFL_CurrentModule "o" + copyFile input_fn new_o + joinObjectFiles hsc_env (new_o : foreign_os) input_fn + return input_fn + +runLlvmLlcPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath +runLlvmLlcPhase pipe_env hsc_env input_fn = do + -- Note [Clamping of llc optimizations] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- See #13724 + -- + -- we clamp the llc optimization between [1,2]. This is because passing -O0 + -- to llc 3.9 or llc 4.0, the naive register allocator can fail with + -- + -- Error while trying to spill R1 from class GPR: Cannot scavenge register + -- without an emergency spill slot! + -- + -- Observed at least with target 'arm-unknown-linux-gnueabihf'. + -- + -- + -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile + -- rts/HeapStackCheck.cmm + -- + -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s + -- 0 llc 0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40 + -- 1 llc 0x0000000102ae69a6 SignalHandler(int) + 358 + -- 2 libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26 + -- 3 libsystem_c.dylib 0x00007fffc226498b __vfprintf + 17876 + -- 4 llc 0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699 + -- 5 llc 0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381 + -- 6 llc 0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457 + -- 7 llc 0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20 + -- 8 llc 0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134 + -- 9 llc 0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498 + -- 10 llc 0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67 + -- 11 llc 0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920 + -- 12 llc 0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133 + -- 13 llc 0x000000010195bf0b main + 491 + -- 14 libdyld.dylib 0x00007fffc21e5235 start + 1 + -- Stack dump: + -- 0. Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s + -- 1. Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'. + -- 2. Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"' + -- + -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa + -- + llvm_config <- readLlvmConfigCache (hsc_llvm_config hsc_env) + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + llvmOpts = case llvmOptLevel dflags of + 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. + 1 -> "-O1" + _ -> "-O2" + + defaultOptions = map GHC.SysTools.Option . concatMap words . snd + $ unzip (llvmOptions llvm_config dflags) + optFlag = if null (getOpts dflags opt_lc) + then map GHC.SysTools.Option $ words llvmOpts + else [] + + next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling + | gopt Opt_NoLlvmMangler dflags -> return (As False) + | otherwise -> return LlvmMangle + + output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing + + GHC.SysTools.runLlvmLlc logger dflags + ( optFlag + ++ defaultOptions + ++ [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ] + ) + + return output_fn + +runLlvmOptPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath +runLlvmOptPhase pipe_env hsc_env input_fn = do + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + llvm_config <- readLlvmConfigCache (hsc_llvm_config hsc_env) + let -- we always (unless -optlo specified) run Opt since we rely on it to + -- fix up some pretty big deficiencies in the code we generate + optIdx = max 0 $ min 2 $ llvmOptLevel dflags -- ensure we're in [0,2] + llvmOpts = case lookup optIdx $ llvmPasses llvm_config of + Just passes -> passes + Nothing -> panic ("runPhase LlvmOpt: llvm-passes file " + ++ "is missing passes for level " + ++ show optIdx) + defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst + $ unzip (llvmOptions llvm_config dflags) + + -- don't specify anything if user has specified commands. We do this + -- for opt but not llc since opt is very specifically for optimisation + -- passes only, so if the user is passing us extra options we assume + -- they know what they are doing and don't get in the way. + optFlag = if null (getOpts dflags opt_lo) + then map GHC.SysTools.Option $ words llvmOpts + else [] + + output_fn <- phaseOutputFilenameNew LlvmLlc pipe_env hsc_env Nothing + + GHC.SysTools.runLlvmOpt logger dflags + ( optFlag + ++ defaultOptions ++ + [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn] + ) + + return output_fn + + +-- Run either 'clang' or 'gcc' phases +runGenericAsPhase :: (Logger -> DynFlags -> [Option] -> IO ()) -> [Option] -> Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath +runGenericAsPhase run_as extra_opts with_cpp pipe_env hsc_env location input_fn = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let unit_env = hsc_unit_env hsc_env + + let cmdline_include_paths = includePaths dflags + let pic_c_flags = picCCOpts dflags + + output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env location + + -- we create directories for the object file, because it + -- might be a hierarchical module. + createDirectoryIfMissing True (takeDirectory output_fn) + + -- add package include paths + all_includes <- if not with_cpp + then pure [] + else do + pkg_include_dirs <- mayThrowUnitErr (collectIncludeDirs <$> preloadUnitsInfo unit_env) + let global_includes = [ GHC.SysTools.Option ("-I" ++ p) + | p <- includePathsGlobal cmdline_include_paths ++ pkg_include_dirs] + let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p) + | p <- includePathsQuote cmdline_include_paths ++ includePathsQuoteImplicit cmdline_include_paths] + pure (local_includes ++ global_includes) + let runAssembler inputFilename outputFilename + = withAtomicRename outputFilename $ \temp_outputFilename -> + run_as + logger dflags + (all_includes + -- See Note [-fPIC for assembler] + ++ map GHC.SysTools.Option pic_c_flags + -- See Note [Produce big objects on Windows] + ++ [ GHC.SysTools.Option "-Wa,-mbig-obj" + | platformOS (targetPlatform dflags) == OSMinGW32 + , not $ target32Bit (targetPlatform dflags) + ] + + -- See Note [-Wa,--no-type-check on wasm32] + ++ [ GHC.SysTools.Option "-Wa,--no-type-check" + | platformArch (targetPlatform dflags) == ArchWasm32] + + ++ [ GHC.SysTools.Option "-x" + , if with_cpp + then GHC.SysTools.Option "assembler-with-cpp" + else GHC.SysTools.Option "assembler" + , GHC.SysTools.Option "-c" + , GHC.SysTools.FileOption "" inputFilename + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" temp_outputFilename + ] ++ extra_opts) + + debugTraceMsg logger 4 (text "Running the assembler") + runAssembler input_fn output_fn + + return output_fn + +-- Invoke `clang` to assemble a .S file produced by LLvm toolchain +runLlvmAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath +runLlvmAsPhase = + runGenericAsPhase runLlvmAs [ GHC.SysTools.Option "-Wno-unused-command-line-argument" ] + +-- Invoke 'gcc' to assemble a .S file +runAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath +runAsPhase = + runGenericAsPhase runAs [] + + + +-- Note [JS Backend .o file procedure] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The JS backend breaks some of the assumptions on file generation order +-- because it directly produces .o files. This violation breaks some of the +-- assumptions on file timestamps, particularly in the postHsc phase. The +-- postHsc phase for the JS backend is performed in 'runJsPhase'. Consider +-- what the NCG does: +-- +-- With other NCG backends we have the following order: +-- 1. The backend produces a .s file +-- 2. Then we write the interface file, .hi +-- 3. Then we generate a .o file in a postHsc phase (calling the asm phase etc.) +-- +-- For the JS Backend this order is different +-- 1. The JS Backend _directly_ produces .o files +-- 2. Then we write the interface file. Notice that this breaks the ordering +-- of .hi > .o (step 2 and step 3 in the NCG above). +-- +-- This violation results in timestamp checks which pass on the NCG but fail +-- in the JS backend. In particular, checks that compare 'ms_obj_date', and +-- 'ms_iface_date' in 'GHC.Unit.Module.ModSummary'. +-- +-- Thus to fix this ordering we touch the object files we generated earlier +-- to ensure these timestamps abide by the proper ordering. + +-- | Run the JS Backend postHsc phase. +runJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath +runJsPhase _pipe_env _hsc_env _location input_fn = do + -- The object file is already generated. We only touch it to ensure the + -- timestamp is refreshed, see Note [JS Backend .o file procedure]. + touchObjectFile input_fn + return input_fn + +-- | Deal with foreign JS files (embed them into .o files) +runForeignJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath +runForeignJsPhase pipe_env hsc_env _location input_fn = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env + let unit_env = hsc_unit_env hsc_env + + output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env Nothing + embedJsFile logger dflags tmpfs unit_env input_fn output_fn + return output_fn + +runCcPhase :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath +runCcPhase cc_phase pipe_env hsc_env location input_fn = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let unit_env = hsc_unit_env hsc_env + let home_unit = hsc_home_unit_maybe hsc_env + let tmpfs = hsc_tmpfs hsc_env + let platform = ue_platform unit_env + let hcc = cc_phase `eqPhase` HCc + + let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags) + + -- HC files have the dependent packages stamped into them + pkgs <- if hcc then getHCFilePackages input_fn else return [] + + -- add package include paths even if we're just compiling .c + -- files; this is the Value Add(TM) that using ghc instead of + -- gcc gives you :) + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs) + let pkg_include_dirs = collectIncludeDirs ps + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths ++ + includePathsQuoteImplicit cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global + + let gcc_extra_viac_flags = extraGccViaCFlags dflags + let pic_c_flags = picCCOpts dflags + + let verbFlags = getVerbFlags dflags + + -- cc-options are not passed when compiling .hc files. Our + -- hc code doesn't not #include any header files anyway, so these + -- options aren't necessary. + let pkg_extra_cc_opts + | hcc = [] + | otherwise = collectExtraCcOpts ps + + let framework_paths + | platformUsesFrameworks platform + = let pkgFrameworkPaths = collectFrameworksDirs ps + cmdlineFrameworkPaths = frameworkPaths dflags + in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths) + | otherwise + = [] + + let cc_opt | llvmOptLevel dflags >= 2 = [ "-O2" ] + | llvmOptLevel dflags >= 1 = [ "-O" ] + | otherwise = [] + + output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env location + + -- we create directories for the object file, because it + -- might be a hierarchical module. + createDirectoryIfMissing True (takeDirectory output_fn) + + let + more_hcc_opts = + -- on x86 the floating point regs have greater precision + -- than a double, which leads to unpredictable results. + -- By default, we turn this off with -ffloat-store unless + -- the user specified -fexcess-precision. + (if platformArch platform == ArchX86 && + not (gopt Opt_ExcessPrecision dflags) + then [ "-ffloat-store" ] + else []) ++ + + -- gcc's -fstrict-aliasing allows two accesses to memory + -- to be considered non-aliasing if they have different types. + -- This interacts badly with the C code we generate, which is + -- very weakly typed, being derived from C--. + ["-fno-strict-aliasing"] + + ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env + + withAtomicRename output_fn $ \temp_outputFilename -> + GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags ( + [ GHC.SysTools.Option "-c" + , GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" temp_outputFilename + ] + ++ map GHC.SysTools.Option ( + pic_c_flags + + -- See Note [Produce big objects on Windows] + ++ [ "-Wa,-mbig-obj" + | platformOS (targetPlatform dflags) == OSMinGW32 + , not $ target32Bit (targetPlatform dflags) + ] + + -- if -fsplit-sections is enabled, we should also + -- build with these flags. + ++ (if gopt Opt_SplitSections dflags && + platformOS (targetPlatform dflags) /= OSDarwin + then ["-ffunction-sections", "-fdata-sections"] + else []) + + -- Stub files generated for foreign exports references the runIO_closure + -- and runNonIO_closure symbols, which are defined in the base package. + -- These symbols are imported into the stub.c file via RtsAPI.h, and the + -- way we do the import depends on whether we're currently compiling + -- the base package or not. + ++ (case home_unit of + Just hu + | isHomeUnitId hu ghcInternalUnitId + , platformOS platform == OSMinGW32 + -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"] + _ -> []) + + -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. + ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) + then ["-Wimplicit"] + else []) + + ++ (if hcc + then gcc_extra_viac_flags ++ more_hcc_opts + else []) + ++ verbFlags + ++ cc_opt + ++ ghcVersionH + ++ framework_paths + ++ include_paths + ++ pkg_extra_cc_opts + )) + + return output_fn + +-- This is where all object files get written from, for hs-boot and hsig files as well. +runHscBackendPhase :: PipeEnv + -> HscEnv + -> ModuleName + -> HscSource + -> ModLocation + -> HscBackendAction + -> IO ([FilePath], ModIface, HomeModLinkable, FilePath) +runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + o_file = if dynamicNow dflags then ml_dyn_obj_file location else ml_obj_file location -- The real object file + next_phase = hscPostBackendPhase src_flavour (backend dflags) + case result of + HscUpdate iface -> + if | not (backendGeneratesCode (backend dflags)) -> + panic "HscUpdate not relevant for NoBackend" + | not (backendGeneratesCodeForHsBoot (backend dflags)) -> do + -- In Interpreter way, there is just no linkable for hs-boot files + -- and we don't want to write an empty `o-boot` file when we're not + -- supposed to be writing any .o files (#22669) + return ([], iface, emptyHomeModInfoLinkable, o_file) + | otherwise -> do + case src_flavour of + HsigFile -> do + -- We need to create a REAL but empty .o file + -- because we are going to attempt to put it in a library + let input_fn = expectJust (ml_hs_file location) + basename = dropExtension input_fn + compileEmptyStub dflags hsc_env basename location mod_name + + -- In the case of hs-boot files, generate a dummy .o-boot + -- stamp file for the benefit of Make + HsBootFile -> touchObjectFile o_file + HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile" + + -- MP: I wonder if there are any lurking bugs here because we + -- return Linkable == emptyHomeModInfoLinkable, despite the fact that there is a + -- linkable (.o-boot) which we check for in `Iface/Recomp.hs` and + -- then will carry around the linkable if we're doing + -- recompilation. + return ([], iface, emptyHomeModInfoLinkable, o_file) + HscRecomp { hscs_guts = cgguts, + hscs_mod_location = mod_location, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_iface_hash + } + -> if not (backendGeneratesCode (backend dflags)) then + panic "HscRecomp not relevant for NoBackend" + else if backendWritesFiles (backend dflags) then + do + output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location) + (outputFilename, mStub, foreign_files, stg_infos, cg_infos) <- + hscGenHardCode hsc_env cgguts mod_location output_fn + + stub_o <- mapM (compileStub hsc_env) mStub + foreign_os <- + mapM (uncurry (compileForeign hsc_env)) foreign_files + let fos = maybe [] return stub_o ++ foreign_os + (iface_stubs, iface_files) + | gopt Opt_WriteIfSimplifiedCore dflags = (cg_foreign cgguts, cg_foreign_files cgguts) + | otherwise = (NoStubs, []) + + final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos iface_stubs iface_files + + -- See Note [Writing interface files] + hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location + mlinkable <- + if gopt Opt_ByteCodeAndObjectCode dflags + then do + bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location + return $ emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } + + else return emptyHomeModInfoLinkable + + -- This is awkward, no linkable is produced here because we still + -- have some way to do before the object file is produced + -- In future we can split up the driver logic more so that this function + -- is in TPipeline and in this branch we can invoke the rest of the backend phase. + return (fos, final_iface, mlinkable, outputFilename) + + else + -- In interpreted mode the regular codeGen backend is not run so we + -- generate a interface without codeGen info. + do + final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing NoStubs [] + hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location + bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location + return ([], final_iface, emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } , panic "interpreter") + + +runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath +runUnlitPhase hsc_env input_fn output_fn = do + let + -- escape the characters \, ", and ', but don't try to escape + -- Unicode or anything else (so we don't use Util.charToC + -- here). If we get this wrong, then in + -- GHC.HsToCore.Ticks.isGoodTickSrcSpan where we check that the filename in + -- a SrcLoc is the same as the source filename, the two will + -- look bogusly different. See test: + -- testsuite/tests/hpc/function/subdir/tough2.hs + escape ('\\':cs) = '\\':'\\': escape cs + escape ('\"':cs) = '\\':'\"': escape cs + escape ('\'':cs) = '\\':'\'': escape cs + escape (c:cs) = c : escape cs + escape [] = [] + + let flags = [ -- The -h option passes the file name for unlit to + -- put in a #line directive + GHC.SysTools.Option "-h" + -- See Note [Don't normalise input filenames]. + , GHC.SysTools.Option $ escape input_fn + , GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.FileOption "" output_fn + ] + + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + GHC.SysTools.runUnlit logger dflags flags + + return output_fn + +getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, Messages DriverMessage)) +getFileArgs hsc_env input_fn = do + let dflags0 = hsc_dflags hsc_env + logger = hsc_logger hsc_env + parser_opts = initParserOpts dflags0 + (warns0, src_opts) <- getOptionsFromFile parser_opts (supportedLanguagePragmas dflags0) input_fn + (dflags1, unhandled_flags, warns) + <- parseDynamicFilePragma logger dflags0 src_opts + checkProcessArgsResult unhandled_flags + return (dflags1, warns0, warns) + +runCppPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath +runCppPhase hsc_env input_fn output_fn = do + doCpp (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (hsc_dflags hsc_env) + (hsc_unit_env hsc_env) + (CppOpts + { sourceCodePreprocessor = SCPHsCpp + , cppLinePragmas = True + }) + input_fn output_fn + return output_fn + + +runHscPhase :: PipeEnv + -> HscEnv + -> FilePath + -> HscSource + -> IO (HscEnv, ModSummary, HscRecompStatus) +runHscPhase pipe_env hsc_env0 input_fn src_flavour = do + let dflags0 = hsc_dflags hsc_env0 + PipeEnv{ src_basename=basename, + src_suffix=suff } = pipe_env + + -- we add the current directory (i.e. the directory in which + -- the .hs files resides) to the include path, since this is + -- what gcc does, and it's probably what you want. + let current_dir = takeDirectory basename + new_includes = addImplicitQuoteInclude paths [current_dir] + paths = includePaths dflags0 + dflags = dflags0 { includePaths = new_includes } + hsc_env1 = hscSetFlags dflags hsc_env0 + + -- Initialise plugins as the flags passed into runHscPhase might have local plugins just + -- specific to this module. + hsc_env <- initializePlugins hsc_env1 + + -- gather the imports and module name + (hspp_buf,mod_name,imps,src_imps) <- do + buf <- hGetStringBuffer input_fn + let imp_prelude = xopt LangExt.ImplicitPrelude dflags + popts = initParserOpts dflags + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + rn_imps = fmap (\(s, rpk, lmn@(L _ mn)) -> (s, rn_pkg_qual mn rpk, lmn)) + eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) + case eimps of + Left errs -> throwErrors (GhcPsMessage <$> errs) + Right (src_imps,imps, L _ mod_name) -> return + (Just buf, mod_name, rn_imps imps, src_imps) + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile above + location <- mkOneShotModLocation pipe_env dflags src_flavour mod_name + let o_file = ml_obj_file location -- The real object file + hi_file = ml_hi_file location + hie_file = ml_hie_file location + dyn_o_file = ml_dyn_obj_file location + + src_hash <- getFileHash (basename <.> suff) + hi_date <- modificationTimeIfExists hi_file + hie_date <- modificationTimeIfExists hie_file + o_mod <- modificationTimeIfExists o_file + dyn_o_mod <- modificationTimeIfExists dyn_o_file + + -- Tell the finder cache about this module + mod <- do + let home_unit = hsc_home_unit hsc_env + let fc = hsc_FC hsc_env + addHomeModuleToFinder fc home_unit mod_name location src_flavour + + -- Make the ModSummary to hand to hscMain + let + mod_summary = ModSummary { ms_mod = mod, + ms_hsc_src = src_flavour, + ms_hspp_file = input_fn, + ms_hspp_opts = dflags, + ms_hspp_buf = hspp_buf, + ms_location = location, + ms_hs_hash = src_hash, + ms_obj_date = o_mod, + ms_dyn_obj_date = dyn_o_mod, + ms_parsed_mod = Nothing, + ms_iface_date = hi_date, + ms_hie_date = hie_date, + ms_textual_imps = imps, + ms_srcimps = src_imps } + + + -- run the compiler! + let msg :: Messager + msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what + + -- A lazy module graph thunk, don't force it unless you need it! + mg <- downsweepThunk hsc_env mod_summary + + -- Need to set the knot-tying mutable variable for interface + -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. + -- See also Note [hsc_type_env_var hack] + type_env_var <- newIORef emptyNameEnv + let hsc_env' = + setModuleGraph mg + hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } + + + + status <- hscRecompStatus (Just msg) hsc_env' mod_summary + Nothing emptyHomeModInfoLinkable (1, 1) + + return (hsc_env', mod_summary, status) + +-- | Calculate the ModLocation from the provided DynFlags. This function is only used +-- in one-shot mode and therefore takes into account the effect of -o/-ohi flags +-- (which do nothing in --make mode) +mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO ModLocation +mkOneShotModLocation pipe_env dflags src_flavour mod_name = do + let PipeEnv{ src_basename=basename, + src_suffix=suff } = pipe_env + let location1 = mkHomeModLocation fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff) src_flavour + + -- Take -ohi into account if present + -- This can't be done in mkHomeModuleLocation because + -- it only applies to the module being compiles + let ohi = outputHi dflags + location2 | Just fn <- ohi = location1{ ml_hi_file_ospath = unsafeEncodeUtf fn } + | otherwise = location1 + + let dynohi = dynOutputHi dflags + location3 | Just fn <- dynohi = location2{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn } + | otherwise = location2 + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile + -- above + let expl_o_file = outputFile_ dflags + expl_dyn_o_file = dynOutputFile_ dflags + location5 | Just ofile <- expl_o_file + , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file + , isNoLink (ghcLink dflags) + = location3 { ml_obj_file_ospath = unsafeEncodeUtf ofile + , ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile } + | Just dyn_ofile <- expl_dyn_o_file + = location3 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile } + | otherwise = location3 + return location5 + where + fopts = initFinderOpts dflags + +runHscTcPhase :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage) +runHscTcPhase = hscTypecheckAndGetWarnings + +runHscPostTcPhase :: + HscEnv + -> ModSummary + -> FrontendResult + -> Messages GhcMessage + -> Maybe Fingerprint + -> IO HscBackendAction +runHscPostTcPhase hsc_env mod_summary tc_result tc_warnings mb_old_hash = do + runHsc hsc_env $ do + hscDesugarAndSimplify mod_summary tc_result tc_warnings mb_old_hash + + +runHsPpPhase :: HscEnv -> FilePath -> FilePath -> FilePath -> IO FilePath +runHsPpPhase hsc_env orig_fn input_fn output_fn = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + GHC.SysTools.runPp logger dflags + ( [ GHC.SysTools.Option orig_fn + , GHC.SysTools.Option input_fn + , GHC.SysTools.FileOption "" output_fn + ] ) + return output_fn + +phaseOutputFilenameNew :: Phase -- ^ The next phase + -> PipeEnv + -> HscEnv + -> Maybe ModLocation -- ^ A ModLocation, if we are compiling a Haskell source file + -> IO FilePath +phaseOutputFilenameNew next_phase pipe_env hsc_env maybe_loc = do + let PipeEnv{stop_phase, src_basename, output_spec} = pipe_env + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + getOutputFilename logger tmpfs (stopPhaseToPhase stop_phase) output_spec + src_basename dflags next_phase maybe_loc + + +-- | Computes the next output filename for something in the compilation +-- pipeline. This is controlled by several variables: +-- +-- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This +-- is used to tell if we're in the last phase or not, because +-- in that case flags like @-o@ may be important. +-- 2. 'PipelineOutput': is this intended to be a 'Temporary' or +-- 'Persistent' build output? Temporary files just go in +-- a fresh temporary name. +-- 3. 'String': what was the basename of the original input file? +-- 4. 'DynFlags': the obvious thing +-- 5. 'Phase': the phase we want to determine the output filename of. +-- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're +-- compiling; this can be used to override the default output +-- of an object file. (TODO: do we actually need this?) +getOutputFilename + :: Logger + -> TmpFs + -> Phase + -> PipelineOutput + -> String + -> DynFlags + -> Phase -- next phase + -> Maybe ModLocation + -> IO FilePath +getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location + -- 1. If we are generating object files for a .hs file, then return the odir as the ModLocation + -- will have been modified to point to the accurate locations + | StopLn <- next_phase, Just loc <- maybe_location = + return $ if dynamicNow dflags then ml_dyn_obj_file loc + else ml_obj_file loc + -- 2. If output style is persistent then + | is_last_phase, Persistent <- output = persistent_fn + -- 3. Specific file is only set when outputFile is set by -o + -- If we are in dynamic mode but -dyno is not set then write to the same path as + -- -o with a .dyn_* extension. This case is not triggered for object files which + -- are always handled by the ModLocation. + | is_last_phase, SpecificFile <- output = + return $ + if dynamicNow dflags + then case dynOutputFile_ dflags of + Nothing -> let ofile = getOutputFile_ dflags + new_ext = case takeExtension ofile of + "" -> "dyn" + ext -> "dyn_" ++ tail ext + in replaceExtension ofile new_ext + Just fn -> fn + else getOutputFile_ dflags + | keep_this_output = persistent_fn + | Temporary lifetime <- output = newTempName logger tmpfs (tmpDir dflags) lifetime suffix + | otherwise = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule + suffix + where + getOutputFile_ dflags = + case outputFile_ dflags of + Nothing -> pprPanic "SpecificFile: No filename" (ppr (dynamicNow dflags) $$ + text (fromMaybe "-" (dynOutputFile_ dflags))) + Just fn -> fn + + hcsuf = hcSuf dflags + odir = objectDir dflags + osuf = objectSuf dflags + keep_hc = gopt Opt_KeepHcFiles dflags + keep_hscpp = gopt Opt_KeepHscppFiles dflags + keep_s = gopt Opt_KeepSFiles dflags + keep_bc = gopt Opt_KeepLlvmFiles dflags + + myPhaseInputExt HCc = hcsuf + myPhaseInputExt MergeForeign = osuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other + + is_last_phase = next_phase `eqPhase` stop_phase + + -- sometimes, we keep output from intermediate stages + keep_this_output = + case next_phase of + As _ | keep_s -> True + LlvmOpt | keep_bc -> True + HCc | keep_hc -> True + HsPp _ | keep_hscpp -> True -- See #10869 + _other -> False + + suffix = myPhaseInputExt next_phase + + -- persistent object files get put in odir + persistent_fn + | StopLn <- next_phase = return odir_persistent + | otherwise = return persistent + + persistent = basename <.> suffix + + odir_persistent + | Just d <- odir = (d persistent) + | otherwise = persistent + + +-- | LLVM Options. These are flags to be passed to opt and llc, to ensure +-- consistency we list them in pairs, so that they form groups. +llvmOptions :: LlvmConfig + -> DynFlags + -> [(String, String)] -- ^ pairs of (opt, llc) arguments +llvmOptions llvm_config dflags = + [("-relocation-model=" ++ rmodel + ,"-relocation-model=" ++ rmodel) | not (null rmodel)] + + -- Additional llc flags + ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu) + , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ] + ++ [("", "-mattr=" ++ attrs) | not (null attrs) ] + ++ [("", "-target-abi=" ++ abi) | not (null abi) ] + + where target = platformMisc_llvmTarget $ platformMisc dflags + target_os = platformOS (targetPlatform dflags) + LlvmTarget _ mcpu mattr = expectJust $ lookup target (llvmTargets llvm_config) + + -- Relocation models + rmodel | gopt Opt_PIC dflags + || positionIndependent dflags + || target_os == OSMinGW32 -- #22487: use PIC on (64-bit) Windows + = "pic" + | ways dflags `hasWay` WayDyn + = "dynamic-no-pic" + | otherwise + = "static" + + platform = targetPlatform dflags + arch = platformArch platform + + attrs :: String + attrs = intercalate "," $ mattr + ++ ["+sse4.2" | isSse4_2Enabled dflags ] + ++ ["+popcnt" | isSse4_2Enabled dflags ] + -- LLVM gates POPCNT instructions behind the popcnt flag, + -- while the GHC NCG (as well as GCC, Clang) gates it + -- behind SSE4.2 instead. + ++ ["+sse4.1" | isSse4_1Enabled dflags ] + ++ ["+ssse3" | isSsse3Enabled dflags ] + ++ ["+sse3" | isSse3Enabled dflags ] + ++ ["+sse2" | isSse2Enabled platform ] + ++ ["+sse" | isSseEnabled platform ] + ++ ["+avx512f" | isAvx512fEnabled dflags ] + ++ ["+avx2" | isAvx2Enabled dflags ] + ++ ["+avx" | isAvxEnabled dflags ] + ++ ["+avx512cd"| isAvx512cdEnabled dflags ] + ++ ["+avx512er"| isAvx512erEnabled dflags ] + ++ ["+avx512pf"| isAvx512pfEnabled dflags ] + -- For Arch64 +fma is not a option (it's unconditionally available). + ++ ["+fma" | isFmaEnabled dflags && (arch /= ArchAArch64) ] + ++ ["+bmi" | isBmiEnabled dflags ] + ++ ["+bmi2" | isBmi2Enabled dflags ] + + abi :: String + abi = case platformArch (targetPlatform dflags) of + ArchRISCV64 -> "lp64d" + ArchLoongArch64 -> "lp64d" + _ -> "" + +-- | What phase to run after one of the backend code generators has run +hscPostBackendPhase :: HscSource -> Backend -> Phase +hscPostBackendPhase (HsBootOrSig _) _ = StopLn +hscPostBackendPhase HsSrcFile bcknd = backendNormalSuccessorPhase bcknd + + +compileStub :: HscEnv -> FilePath -> IO FilePath +compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c + + +-- --------------------------------------------------------------------------- +-- join object files into a single relocatable object file, using ld -r + +{- +Note [Produce big objects on Windows] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Windows Portable Executable object format has a limit of 32k sections, which +we tend to blow through pretty easily. Thankfully, there is a "big object" +extension, which raises this limit to 2^32. However, it must be explicitly +enabled in the toolchain: + + * the assembler accepts the -mbig-obj flag, which causes it to produce a + bigobj-enabled COFF object. + + * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name + suggests, this tells the linker to produce a bigobj-enabled COFF object, no a + PE executable. + +Previously when we used ld.bfd we had to enable bigobj output in a few places: + + * When merging object files (GHC.Driver.Pipeline.Execute.joinObjectFiles) + + * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...)) + +However, this is no longer necessary with ld.lld, which detects that the +object is large on its own. + +Unfortunately the big object format is not supported on 32-bit targets so +none of this can be used in that case. + + +Note [Object merging] +~~~~~~~~~~~~~~~~~~~~~ +On most platforms one can "merge" a set of relocatable object files into a new, +partially-linked-but-still-relocatable object. In a typical UNIX-style linker, +this is accomplished with the `ld -r` command. We rely on this for two ends: + + * We rely on `ld -r` to squash together split sections, making GHCi loading + more efficient. See Note [Merging object files for GHCi]. + + * We use merging to combine a module's object code (e.g. produced by the NCG) + with its foreign stubs (typically produced by a C compiler). + +The command used for object linking is set using the -pgmlm and -optlm +command-line options. + +However, `ld -r` is broken in some cases: + + * The LLD linker that we use on Windows does not support the `-r` + flag needed to support object merging (see #21068). For this reason + on Windows we do not support GHCi objects. + +In these cases, we bundle a module's own object file with its foreign +stub's object file, instead of merging them. Consequently, we can end +up producing `.o` files which are in fact static archives. This can +only work if `ar -L` is supported, so the archive `.o` files can be +properly added to the final static library. + +Note that this has somewhat non-obvious consequences when producing +initializers and finalizers. See Note [Initializers and finalizers in Cmm] +in GHC.Cmm.InitFini for details. + + +Note [Merging object files for GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHCi can usually loads standard linkable object files using GHC's linker +implementation. However, most users build their projects with -split-sections, +meaning that such object files can have an extremely high number of sections. +As the linker must map each of these sections individually, loading such object +files is very inefficient. + +To avoid this inefficiency, we use the linker's `-r` flag and a linker script +to produce a merged relocatable object file. This file will contain a singe +text section section and can consequently be mapped far more efficiently. As +gcc tends to do unpredictable things to our linker command line, we opt to +invoke ld directly in this case, in contrast to our usual strategy of linking +via gcc. +-} + +-- | See Note [Object merging]. +joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO () +joinObjectFiles hsc_env o_files output_fn + | can_merge_objs = do + let toolSettings' = toolSettings dflags + ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' + ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) ( + [ GHC.SysTools.Option "-o", + GHC.SysTools.FileOption "" output_fn ] + ++ args) + + if ldIsGnuLd + then do + script <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "ldscript" + cwd <- getCurrentDirectory + let o_files_abs = map (\x -> "\"" ++ (cwd x) ++ "\"") o_files + writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" + ld_r [GHC.SysTools.FileOption "" script] + else if toolSettings_ldSupportsFilelist toolSettings' + then do + filelist <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "filelist" + writeFile filelist $ unlines o_files + ld_r [GHC.SysTools.Option "-filelist", + GHC.SysTools.FileOption "" filelist] + else + ld_r (map (GHC.SysTools.FileOption "") o_files) + + | otherwise = do + withAtomicRename output_fn $ \tmp_ar -> + liftIO $ runAr logger dflags Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files + where + dashLSupported = sArSupportsDashL (settings dflags) + dashL = if dashLSupported then "L" else "" + can_merge_objs = isJust (pgm_lm (hsc_dflags hsc_env)) + dflags = hsc_dflags hsc_env + tmpfs = hsc_tmpfs hsc_env + logger = hsc_logger hsc_env + + +----------------------------------------------------------------------------- +-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file + +getHCFilePackages :: FilePath -> IO [UnitId] +getHCFilePackages filename = + withFile filename ReadMode $ \h -> do + l <- hGetLine h + case l of + '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> + return (map stringToUnitId (words rest)) + _other -> + return [] + + +linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do + when (haveRtsOptsFlags dflags) $ + logMsg logger MCInfo noSrcSpan + $ withPprStyle defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + linkDynLib logger tmpfs dflags unit_env o_files dep_units + + + +-- ----------------------------------------------------------------------------- +-- Misc. + + + +touchObjectFile :: FilePath -> IO () +touchObjectFile path = do + createDirectoryIfMissing True $ takeDirectory path + GHC.Utils.Touch.touch path + +-- Note [-fPIC for assembler] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When compiling .c source file GHC's driver pipeline basically +-- does the following two things: +-- 1. ${CC} -S 'PIC_CFLAGS' source.c +-- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S +-- +-- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler? +-- Because on some architectures (at least sparc32) assembler also chooses +-- the relocation type! +-- Consider the following C module: +-- +-- /* pic-sample.c */ +-- int v; +-- void set_v (int n) { v = n; } +-- int get_v (void) { return v; } +-- +-- $ gcc -S -fPIC pic-sample.c +-- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary +-- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary +-- +-- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od +-- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od +-- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od +-- +-- Most of architectures won't show any difference in this test, but on sparc32 +-- the following assembly snippet: +-- +-- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7 +-- +-- generates two kinds or relocations, only 'R_SPARC_PC22' is correct: +-- +-- 3c: 2f 00 00 00 sethi %hi(0), %l7 +-- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8 +-- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8 + +{- Note [Don't normalise input filenames] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Summary + We used to normalise input filenames when starting the unlit phase. This + broke hpc in `--make` mode with imported literate modules (#2991). + +Introduction + 1) --main + When compiling a module with --main, GHC scans its imports to find out which + other modules it needs to compile too. It turns out that there is a small + difference between saying `ghc --make A.hs`, when `A` imports `B`, and + specifying both modules on the command line with `ghc --make A.hs B.hs`. In + the former case, the filename for B is inferred to be './B.hs' instead of + 'B.hs'. + + 2) unlit + When GHC compiles a literate haskell file, the source code first needs to go + through unlit, which turns it into normal Haskell source code. At the start + of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the + option `-h` and the name of the original file. We used to normalise this + filename using System.FilePath.normalise, which among other things removes + an initial './'. unlit then uses that filename in #line directives that it + inserts in the transformed source code. + + 3) SrcSpan + A SrcSpan represents a portion of a source code file. It has fields + linenumber, start column, end column, and also a reference to the file it + originated from. The SrcSpans for a literate haskell file refer to the + filename that was passed to unlit -h. + + 4) -fhpc + At some point during compilation with -fhpc, in the function + `GHC.HsToCore.Ticks.isGoodTickSrcSpan`, we compare the filename that a + `SrcSpan` refers to with the name of the file we are currently compiling. + For some reason I don't yet understand, they can sometimes legitimately be + different, and then hpc ignores that SrcSpan. + +Problem + When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate + module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the + start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2). + Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are + still compiling `./B.lhs`. Hpc thinks these two filenames are different (4), + doesn't include ticks for B, and we have unhappy customers (#2991). + +Solution + Do not normalise `input_fn` when starting the unlit phase. + +Alternative solution + Another option would be to not compare the two filenames on equality, but to + use System.FilePath.equalFilePath. That function first normalises its + arguments. The problem is that by the time we need to do the comparison, the + filenames have been turned into FastStrings, probably for performance + reasons, so System.FilePath.equalFilePath can not be used directly. + +Archeology + The call to `normalise` was added in a commit called "Fix slash + direction on Windows with the new filePath code" (c9b6b5e8). The problem + that commit was addressing has since been solved in a different manner, in a + commit called "Fix the filename passed to unlit" (1eedbc6b). So the + `normalise` is no longer necessary. +-} + +{- +Note [-Wa,--no-type-check on wasm32] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Wasm32 has a type system and corresponding validation rules, so it's +possible to produce syntactically valid object code that doesn't pass +validation. + +We have no problem with that, but we do have a problem with clang. +When clang takes an assembly input for wasm32, it uses its internal +type-checker, which is a huge source of trouble (see llvm ticket +#56935 #58438): it may reject valid assembly, and even worse, it may +silently alter the output object code!!! The worsest of all, is the +person that added the wasm32 asm typechecker logic has moved on from +Google/LLVM, and while other LLVM devs may be knowledgable enough to +fix this mess, they likely got tons of other stuff on their table and +don't care enough. + +We do have an escape hatch, just pass -Wa,--no-type-check to clang to +bypass the entire wasm32 asm typechecking logic. There's little point +in type-checking object code at compile-time anyway, the wasm engines +will do type-checking at run-time. And even if we want to add some +linting flag to do compile-time checks, we should just rely on +battle-tested external tools instead of a completely broken horror +story. +-} diff --git a/GHC/Driver/Pipeline/LogQueue.hs b/GHC/Driver/Pipeline/LogQueue.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Pipeline/LogQueue.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DerivingVia #-} +module GHC.Driver.Pipeline.LogQueue ( LogQueue(..) + , newLogQueue + , finishLogQueue + , writeLogQueue + , parLogAction + + , LogQueueQueue(..) + , initLogQueue + , allLogQueues + , newLogQueueQueue + + , logThread + ) where + +import GHC.Prelude +import Control.Concurrent +import Data.IORef +import GHC.Types.Error +import GHC.Types.SrcLoc +import GHC.Utils.Logger +import qualified Data.IntMap as IM +import Control.Concurrent.STM +import Control.Monad + +-- LogQueue Abstraction + +-- | Each module is given a unique 'LogQueue' to redirect compilation messages +-- to. A 'Nothing' value contains the result of compilation, and denotes the +-- end of the message queue. +data LogQueue = LogQueue { logQueueId :: !Int + , logQueueMessages :: !(IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]) + , logQueueSemaphore :: !(MVar ()) + } + +newLogQueue :: Int -> IO LogQueue +newLogQueue n = do + mqueue <- newIORef [] + sem <- newMVar () + return (LogQueue n mqueue sem) + +finishLogQueue :: LogQueue -> IO () +finishLogQueue lq = do + writeLogQueueInternal lq Nothing + + +writeLogQueue :: LogQueue -> (MessageClass,SrcSpan,SDoc, LogFlags) -> IO () +writeLogQueue lq msg = do + writeLogQueueInternal lq (Just msg) + +-- | Internal helper for writing log messages +writeLogQueueInternal :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc, LogFlags) -> IO () +writeLogQueueInternal (LogQueue _n ref sem) msg = do + atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) + _ <- tryPutMVar sem () + return () + +-- The log_action callback that is used to synchronize messages from a +-- worker thread. +parLogAction :: LogQueue -> LogAction +parLogAction log_queue log_flags !msgClass !srcSpan !msg = + writeLogQueue log_queue (msgClass,srcSpan,msg, log_flags) + +-- Print each message from the log_queue using the global logger +printLogs :: Logger -> LogQueue -> IO () +printLogs !logger (LogQueue _n ref sem) = read_msgs + where read_msgs = do + takeMVar sem + msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs) + print_loop msgs + + print_loop [] = read_msgs + print_loop (x:xs) = case x of + Just (msgClass,srcSpan,msg,flags) -> do + logMsg (setLogFlags logger flags) msgClass srcSpan msg + print_loop xs + -- Exit the loop once we encounter the end marker. + Nothing -> return () + +-- The LogQueueQueue abstraction + +data LogQueueQueue = LogQueueQueue Int (IM.IntMap LogQueue) + +newLogQueueQueue :: LogQueueQueue +newLogQueueQueue = LogQueueQueue 1 IM.empty + +addToQueueQueue :: LogQueue -> LogQueueQueue -> LogQueueQueue +addToQueueQueue lq (LogQueueQueue n im) = LogQueueQueue n (IM.insert (logQueueId lq) lq im) + +initLogQueue :: TVar LogQueueQueue -> LogQueue -> STM () +initLogQueue lqq lq = modifyTVar lqq (addToQueueQueue lq) + +-- | Return all items in the queue in ascending order +allLogQueues :: LogQueueQueue -> [LogQueue] +allLogQueues (LogQueueQueue _n im) = IM.elems im + +dequeueLogQueueQueue :: LogQueueQueue -> Maybe (LogQueue, LogQueueQueue) +dequeueLogQueueQueue (LogQueueQueue n lqq) = case IM.minViewWithKey lqq of + Just ((k, v), lqq') | k == n -> Just (v, LogQueueQueue (n + 1) lqq') + _ -> Nothing + +logThread :: Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit + -> TVar LogQueueQueue -- Queue for logs + -> IO (IO ()) +logThread logger stopped lqq_var = do + finished_var <- newEmptyMVar + _ <- forkIO $ print_logs *> putMVar finished_var () + return (takeMVar finished_var) + where + finish = mapM (printLogs logger) + + print_logs = join $ atomically $ do + lqq <- readTVar lqq_var + case dequeueLogQueueQueue lqq of + Just (lq, lqq') -> do + writeTVar lqq_var lqq' + return (printLogs logger lq *> print_logs) + Nothing -> do + -- No log to print, check if we are finished. + stopped <- readTVar stopped + if not stopped then retry + else return (finish (allLogQueues lqq)) diff --git a/GHC/Driver/Pipeline/Monad.hs b/GHC/Driver/Pipeline/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Pipeline/Monad.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | The 'TPipelineClass' and 'MonadUse' classes and associated types +module GHC.Driver.Pipeline.Monad ( + TPipelineClass, MonadUse(..) + + , PipeEnv(..) + , PipelineOutput(..) + ) where + +import GHC.Prelude +import Control.Monad.IO.Class +import qualified Data.Kind as K +import GHC.Driver.Phases +import GHC.Utils.TmpFs + +-- The interface that the pipeline monad must implement. +type TPipelineClass (f :: K.Type -> K.Type) (m :: K.Type -> K.Type) + = (Functor m, MonadIO m, Applicative m, Monad m, MonadUse f m) + +-- | Lift a `f` action into an `m` action. +class MonadUse f m where + use :: f a -> m a + +-- PipeEnv: invariant information passed down through the pipeline +data PipeEnv = PipeEnv { + stop_phase :: StopPhase, -- ^ Stop just after this phase + src_filename :: String, -- ^ basename of original input source + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + start_phase :: Phase, + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + + +data PipelineOutput + = Temporary TempFileLifetime + -- ^ Output should be to a temporary file: we're going to + -- run more compilation steps on this output later. + | Persistent + -- ^ We want a persistent file, i.e. a file in the current directory + -- derived from the input filename, but with the appropriate extension. + -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. + | SpecificFile + -- ^ The output must go into the specific outputFile in DynFlags. + -- We don't store the filename in the constructor as it changes + -- when doing -dynamic-too. + | NoOutputFile + -- ^ No output should be created, like in Interpreter or NoBackend. + deriving Show diff --git a/GHC/Driver/Pipeline/Phases.hs b/GHC/Driver/Pipeline/Phases.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Pipeline/Phases.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +module GHC.Driver.Pipeline.Phases (TPhase(..), PhaseHook(..)) where + +import GHC.Prelude +import GHC.Driver.Pipeline.Monad +import GHC.Driver.Env.Types +import GHC.Driver.DynFlags +import GHC.Types.SourceFile +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Status +import GHC.Tc.Types ( FrontendResult ) +import GHC.Types.Error +import GHC.Driver.Errors.Types +import GHC.Fingerprint.Type +import GHC.Unit.Module.Location ( ModLocation ) +import GHC.Unit.Module.ModIface +import GHC.Driver.Phases + +import Language.Haskell.Syntax.Module.Name ( ModuleName ) +import GHC.Unit.Home.ModInfo + +-- Typed Pipeline Phases +-- MP: TODO: We need to refine the arguments to each of these phases so recompilation +-- can be smarter. For example, rather than passing a whole HscEnv, just pass the options +-- which each phase depends on, then recompilation checking can decide to only rerun each +-- phase if the inputs have been modified. +data TPhase res where + T_Unlit :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath + T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, Messages DriverMessage) + T_Cpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath + T_HsPp :: PipeEnv -> HscEnv -> FilePath -> FilePath -> TPhase FilePath + T_HscRecomp :: PipeEnv -> HscEnv -> FilePath -> HscSource -> TPhase (HscEnv, ModSummary, HscRecompStatus) + T_Hsc :: HscEnv -> ModSummary -> TPhase (FrontendResult, Messages GhcMessage) + T_HscPostTc :: HscEnv -> ModSummary + -> FrontendResult + -> Messages GhcMessage + -> Maybe Fingerprint + -> TPhase HscBackendAction + T_HscBackend :: PipeEnv -> HscEnv -> ModuleName -> HscSource -> ModLocation -> HscBackendAction -> TPhase ([FilePath], ModIface, HomeModLinkable, FilePath) + T_CmmCpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath + T_Cmm :: PipeEnv -> HscEnv -> FilePath -> TPhase ([FilePath], FilePath) + T_Cc :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath + T_As :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath + T_Js :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath + T_ForeignJs :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath + T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath + T_LlvmLlc :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath + T_LlvmAs :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath + T_LlvmMangle :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath + T_MergeForeign :: PipeEnv -> HscEnv -> FilePath -> [FilePath] -> TPhase FilePath + +-- | A wrapper around the interpretation function for phases. +data PhaseHook = PhaseHook (forall a . TPhase a -> IO a) diff --git a/GHC/Driver/Plugins.hs b/GHC/Driver/Plugins.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Plugins.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} + +#if defined(HAVE_INTERNAL_INTERPRETER) && defined(CAN_LOAD_DLL) +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UnboxedTuples #-} +#endif + + +-- | Definitions for writing /plugins/ for GHC. Plugins can hook into +-- several areas of the compiler. See the 'Plugin' type. These plugins +-- include type-checker plugins, source plugins, and core-to-core plugins. + +module GHC.Driver.Plugins ( + -- * Plugins + Plugins (..) + , emptyPlugins + , Plugin(..) + , defaultPlugin + , CommandLineOption + , PsMessages(..) + , ParsedResult(..) + + -- * External plugins + , loadExternalPlugins + + -- ** Recompilation checking + , purePlugin, impurePlugin, flagRecompile + , PluginRecompile(..) + + -- * Plugin types + -- ** Frontend plugins + , FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction + -- ** Core plugins + -- | Core plugins allow plugins to register as a Core-to-Core pass. + , CorePlugin + -- ** Typechecker plugins + -- | Typechecker plugins allow plugins to provide evidence to the + -- typechecker. + , TcPlugin + -- ** Source plugins + -- | GHC offers a number of points where plugins can access and modify its + -- front-end (\"source\") representation. These include: + -- + -- - access to the parser result with 'parsedResultAction' + -- - access to the renamed AST with 'renamedResultAction' + -- - access to the typechecked AST with 'typeCheckResultAction' + -- - access to the Template Haskell splices with 'spliceRunAction' + -- - access to loaded interface files with 'interfaceLoadAction' + -- + , keepRenamedSource + -- ** Defaulting plugins + -- | Defaulting plugins can add candidate types to the defaulting + -- mechanism. + , DefaultingPlugin + -- ** Hole fit plugins + -- | hole fit plugins allow plugins to change the behavior of valid hole + -- fit suggestions + , HoleFitPluginR + -- ** Late plugins + -- | Late plugins can access and modify the core of a module after + -- optimizations have been applied and after interface creation. + , LatePlugin + + -- * Internal + , PluginWithArgs(..), pluginsWithArgs, pluginRecompile' + , LoadedPlugin(..), lpModuleName + , StaticPlugin(..) + , ExternalPlugin(..) + , mapPlugins, withPlugins, withPlugins_ + ) where + +import GHC.Prelude + +import GHC.Driver.Env +import GHC.Driver.Monad +import GHC.Driver.Phases +import GHC.Driver.Plugins.External + +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary + +import GHC.Parser.Errors.Types (PsWarning, PsError) + +import qualified GHC.Tc.Types +import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) +import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR ) + +import GHC.Core.Opt.Monad ( CoreM ) +import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) +import GHC.Hs +import GHC.Types.Error (Messages) +import GHC.Linker.Types +import GHC.Types.CostCentre.State +import GHC.Types.Unique.DFM + +import GHC.Unit.Module.ModGuts (CgGuts) +import GHC.Utils.Fingerprint +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.List (sort) + +--Qualified import so we can define a Semigroup instance +-- but it doesn't clash with Outputable.<> +import qualified Data.Semigroup + +import Control.Monad + +#if defined(HAVE_INTERNAL_INTERPRETER) && defined(CAN_LOAD_DLL) +import GHCi.ObjLink +import GHC.Exts (addrToAny#, Ptr(..)) +import GHC.Utils.Encoding +#endif + + +-- | Command line options gathered from the -PModule.Name:stuff syntax +-- are given to you as this type +type CommandLineOption = String + +-- | Errors and warnings produced by the parser +data PsMessages = PsMessages { psWarnings :: Messages PsWarning + , psErrors :: Messages PsError + } + +-- | Result of running the parser and the parser plugin +data ParsedResult = ParsedResult + { -- | Parsed module, potentially modified by a plugin + parsedResultModule :: HsParsedModule + , -- | Warnings and errors from parser, potentially modified by a plugin + parsedResultMessages :: PsMessages + } + +-- | 'Plugin' is the compiler plugin data type. Try to avoid +-- constructing one of these directly, and just modify some fields of +-- 'defaultPlugin' instead: this is to try and preserve source-code +-- compatibility when we add fields to this. +-- +-- Nonetheless, this API is preliminary and highly likely to change in +-- the future. +data Plugin = Plugin { + installCoreToDos :: CorePlugin + -- ^ Modify the Core pipeline that will be used for compilation. + -- This is called as the Core pipeline is built for every module + -- being compiled, and plugins get the opportunity to modify the + -- pipeline in a nondeterministic order. + , tcPlugin :: TcPlugin + -- ^ An optional typechecker plugin, which may modify the + -- behaviour of the constraint solver. + , defaultingPlugin :: DefaultingPlugin + -- ^ An optional defaulting plugin, which may specify the + -- additional type-defaulting rules. + , holeFitPlugin :: HoleFitPlugin + -- ^ An optional plugin to handle hole fits, which may re-order + -- or change the list of valid hole fits and refinement hole fits. + + , driverPlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv + -- ^ An optional plugin to update 'HscEnv', right after plugin loading. This + -- can be used to register hooks or tweak any field of 'DynFlags' before + -- doing actual work on a module. + -- + -- @since 8.10.1 + + , latePlugin :: LatePlugin + -- ^ A plugin that runs after interface creation and after late cost centre + -- insertion. Useful for transformations that should not impact interfaces + -- or optimization at all. + -- + -- @since 9.10.1 + + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile + -- ^ Specify how the plugin should affect recompilation. + , parsedResultAction :: [CommandLineOption] -> ModSummary + -> ParsedResult -> Hsc ParsedResult + -- ^ Modify the module when it is parsed. This is called by + -- "GHC.Driver.Main" when the parser has produced no or only non-fatal + -- errors. + -- Compilation will fail if the messages produced by this function contain + -- any errors. + , renamedResultAction :: [CommandLineOption] -> TcGblEnv + -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) + -- ^ Modify each group after it is renamed. This is called after each + -- `HsGroup` has been renamed. + , typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv + -> TcM TcGblEnv + -- ^ Modify the module when it is type checked. This is called at the + -- very end of typechecking. + , spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc + -> TcM (LHsExpr GhcTc) + -- ^ Modify the TH splice or quasiqoute before it is run. + , interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface + -> IfM lcl ModIface + -- ^ Modify an interface that have been loaded. This is called by + -- "GHC.Iface.Load" when an interface is successfully loaded. Not applied to + -- the loading of the plugin interface. Tools that rely on information from + -- modules other than the currently compiled one should implement this + -- function. + } + +-- Note [Source plugins] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The `Plugin` datatype have been extended by fields that allow access to the +-- different inner representations that are generated during the compilation +-- process. These fields are `parsedResultAction`, `renamedResultAction`, +-- `typeCheckResultAction`, `spliceRunAction` and `interfaceLoadAction`. +-- +-- The main purpose of these plugins is to help tool developers. They allow +-- development tools to extract the information about the source code of a big +-- Haskell project during the normal build procedure. In this case the plugin +-- acts as the tools access point to the compiler that can be controlled by +-- compiler flags. This is important because the manipulation of compiler flags +-- is supported by most build environment. +-- +-- For the full discussion, check the full proposal at: +-- https://gitlab.haskell.org/ghc/ghc/wikis/extended-plugins-proposal + +data PluginWithArgs = PluginWithArgs + { paPlugin :: Plugin + -- ^ the actual callable plugin + , paArguments :: [CommandLineOption] + -- ^ command line arguments for the plugin + } + +-- | A plugin with its arguments. The result of loading the plugin. +data LoadedPlugin = LoadedPlugin + { lpPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments + , lpModule :: ModIface + -- ^ the module containing the plugin + } + +-- | External plugin loaded directly from a library without loading module +-- interfaces +data ExternalPlugin = ExternalPlugin + { epPlugin :: PluginWithArgs -- ^ Plugin with its arguments + , epUnit :: String -- ^ UnitId + , epModule :: String -- ^ Module name + } + +-- | A static plugin with its arguments. For registering compiled-in plugins +-- through the GHC API. +data StaticPlugin = StaticPlugin + { spPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments + , spInitialised :: Bool + -- ^ has this plugin been initialised (i.e. driverPlugin has been run) + } + +lpModuleName :: LoadedPlugin -> ModuleName +lpModuleName = moduleName . mi_module . lpModule + +pluginRecompile' :: PluginWithArgs -> IO PluginRecompile +pluginRecompile' (PluginWithArgs plugin args) = pluginRecompile plugin args + +data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint + +instance Outputable PluginRecompile where + ppr ForceRecompile = text "ForceRecompile" + ppr NoForceRecompile = text "NoForceRecompile" + ppr (MaybeRecompile fp) = text "MaybeRecompile" <+> ppr fp + +instance Semigroup PluginRecompile where + ForceRecompile <> _ = ForceRecompile + NoForceRecompile <> r = r + MaybeRecompile fp <> NoForceRecompile = MaybeRecompile fp + MaybeRecompile fp <> MaybeRecompile fp' = MaybeRecompile (fingerprintFingerprints [fp, fp']) + MaybeRecompile _fp <> ForceRecompile = ForceRecompile + +instance Monoid PluginRecompile where + mempty = NoForceRecompile + +type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin +type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin +type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR +type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState) + +purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile +purePlugin _args = return NoForceRecompile + +impurePlugin _args = return ForceRecompile + +flagRecompile = + return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort + +-- | Default plugin: does nothing at all, except for marking that safe +-- inference has failed unless @-fplugin-trustworthy@ is passed. For +-- compatibility reason you should base all your plugin definitions on this +-- default value. +defaultPlugin :: Plugin +defaultPlugin = Plugin { + installCoreToDos = const return + , tcPlugin = const Nothing + , defaultingPlugin = const Nothing + , holeFitPlugin = const Nothing + , driverPlugin = const return + , latePlugin = \_ -> const return + , pluginRecompile = impurePlugin + , renamedResultAction = \_ env grp -> return (env, grp) + , parsedResultAction = \_ _ -> return + , typeCheckResultAction = \_ _ -> return + , spliceRunAction = \_ -> return + , interfaceLoadAction = \_ -> return + } + + +-- | A renamer plugin which mades the renamed source available in +-- a typechecker plugin. +keepRenamedSource :: [CommandLineOption] -> TcGblEnv + -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) +keepRenamedSource _ gbl_env group = + return (gbl_env { tcg_rn_decls = update (tcg_rn_decls gbl_env) + , tcg_rn_exports = update_exports (tcg_rn_exports gbl_env) }, group) + where + update_exports Nothing = Just [] + update_exports m = m + + update Nothing = Just emptyRnGroup + update m = m + + +type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a +type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m () + +data Plugins = Plugins + { staticPlugins :: ![StaticPlugin] + -- ^ Static plugins which do not need dynamic loading. These plugins are + -- intended to be added by GHC API users directly to this list. + -- + -- To add dynamically loaded plugins through the GHC API see + -- 'addPluginModuleName' instead. + + , externalPlugins :: ![ExternalPlugin] + -- ^ External plugins loaded directly from libraries without loading + -- module interfaces. + + , loadedPlugins :: ![LoadedPlugin] + -- ^ Plugins dynamically loaded after processing arguments. What + -- will be loaded here is directed by DynFlags.pluginModNames. + -- Arguments are loaded from DynFlags.pluginModNameOpts. + -- + -- The purpose of this field is to cache the plugins so they + -- don't have to be loaded each time they are needed. See + -- 'GHC.Runtime.Loader.initializePlugins'. + , loadedPluginDeps :: !([Linkable], PkgsLoaded) + -- ^ The object files required by the loaded plugins + -- See Note [Plugin dependencies] + } + +emptyPlugins :: Plugins +emptyPlugins = Plugins + { staticPlugins = [] + , externalPlugins = [] + , loadedPlugins = [] + , loadedPluginDeps = ([], emptyUDFM) + } + +pluginsWithArgs :: Plugins -> [PluginWithArgs] +pluginsWithArgs plugins = + map lpPlugin (loadedPlugins plugins) ++ + map epPlugin (externalPlugins plugins) ++ + map spPlugin (staticPlugins plugins) + +-- | Perform an operation by using all of the plugins in turn. +withPlugins :: Monad m => Plugins -> PluginOperation m a -> a -> m a +withPlugins plugins transformation input = foldM go input (pluginsWithArgs plugins) + where + go arg (PluginWithArgs p opts) = transformation p opts arg + +mapPlugins :: Plugins -> (Plugin -> [CommandLineOption] -> a) -> [a] +mapPlugins plugins f = map (\(PluginWithArgs p opts) -> f p opts) (pluginsWithArgs plugins) + +-- | Perform a constant operation by using all of the plugins in turn. +withPlugins_ :: Monad m => Plugins -> ConstPluginOperation m a -> a -> m () +withPlugins_ plugins transformation input + = mapM_ (\(PluginWithArgs p opts) -> transformation p opts input) + (pluginsWithArgs plugins) + +type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () +data FrontendPlugin = FrontendPlugin { + frontend :: FrontendPluginAction + } +defaultFrontendPlugin :: FrontendPlugin +defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () } + + +-- | Load external plugins +loadExternalPlugins :: [ExternalPluginSpec] -> IO [ExternalPlugin] +loadExternalPlugins [] = return [] +#if !defined(HAVE_INTERNAL_INTERPRETER) +loadExternalPlugins _ = do + panic "loadExternalPlugins: can't load external plugins with GHC built without internal interpreter" +#elif !defined(CAN_LOAD_DLL) +loadExternalPlugins _ = do + panic "loadExternalPlugins: loading shared libraries isn't supported by this compiler" +#else +loadExternalPlugins ps = do + -- initialize the linker + initObjLinker RetainCAFs + -- load plugins + forM ps $ \(ExternalPluginSpec path unit mod_name opts) -> do + loadExternalPluginLib path + -- lookup symbol + let ztmp = zEncodeString mod_name ++ "_plugin_closure" + symbol + | null unit = ztmp + | otherwise = zEncodeString unit ++ "_" ++ ztmp + plugin <- lookupSymbol symbol >>= \case + Nothing -> pprPanic "loadExternalPlugins" + (vcat [ text "Symbol not found" + , text " Library path: " <> text path + , text " Symbol : " <> text symbol + ]) + Just (Ptr addr) -> case addrToAny# addr of + (# a #) -> pure a + + pure $ ExternalPlugin (PluginWithArgs plugin opts) unit mod_name + +loadExternalPluginLib :: FilePath -> IO () +loadExternalPluginLib path = do + -- load library + loadDLL path >>= \case + Left errmsg -> pprPanic "loadExternalPluginLib" + (vcat [ text "Can't load plugin library" + , text " Library path: " <> text path + , text " Error : " <> text errmsg + ]) + Right _ -> do + -- resolve objects + resolveObjs >>= \case + True -> return () + False -> pprPanic "loadExternalPluginLib" (text "Unable to resolve objects for library: " <> text path) + +#endif diff --git a/GHC/Driver/Plugins.hs-boot b/GHC/Driver/Plugins.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Driver/Plugins.hs-boot @@ -0,0 +1,13 @@ +-- The plugins datatype is stored in DynFlags, so it needs to be +-- exposed without importing all of its implementation. +module GHC.Driver.Plugins where + +import GHC.Prelude () + +data Plugin +data Plugins + +emptyPlugins :: Plugins + +data LoadedPlugin +data StaticPlugin diff --git a/GHC/Driver/Plugins/External.hs b/GHC/Driver/Plugins/External.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Plugins/External.hs @@ -0,0 +1,79 @@ +-- | External plugins +-- +-- GHC supports two kinds of "static" plugins: +-- 1. internal: setup with GHC-API +-- 2. external: setup as explained below and loaded from shared libraries +-- +-- The intended use case for external static plugins is with cross compilers: at +-- the time of writing, GHC is mono-target and a GHC cross-compiler (i.e. when +-- host /= target) can't build nor load plugins for the host using the +-- "non-static" plugin approach. Fixing this is tracked in #14335. If you're not +-- using a cross-compiler, you'd better use non-static plugins which are easier +-- to build and and safer to use (see below). +-- +-- External static plugins can be configured via the command-line with +-- the -fplugin-library flag. Syntax is: +-- +-- -fplugin-library=⟨file-path⟩;⟨unit-id⟩;⟨module⟩;⟨args⟩ +-- +-- Example: +-- -fplugin-library=path/to/plugin;package-123;Plugin.Module;["Argument","List"] +-- +-- Building the plugin library: +-- 1. link with the libraries used to build the compiler you target. If you +-- target a cross-compiler (stage2), you can't directly use it to build the +-- plugin library. Use the stage1 compiler instead. +-- +-- 2. if you use cabal to build the library, its unit-id will be set by cabal +-- and will contain a hash (e.g. "my-plugin-unit-1345656546ABCDEF"). To force +-- the unit id, use GHC's `-this-unit-id` command line flag: +-- e.g. -this-unit-id my-plugin-unit +-- You can set this in the .cabal file of your library with the following +-- stanza: `ghc-options: -this-unit-id my-plugin-unit` +-- +-- 3. To make your plugin easier to distribute, you may want to link it +-- statically with all its dependencies. You would need to use `-shared` +-- without `-dynamic` when building your library. +-- +-- However, all the static dependencies have to be built with `-fPIC` and it's +-- not done by default. See +-- https://www.hobson.space/posts/haskell-foreign-library/ for a way to modify +-- the compiler to do it. +-- +-- In any case, don't link your plugin library statically with the RTS (e.g. +-- use `-fno-link-rts`) as there are some global variables in the RTS that must +-- be shared between the plugin and the compiler. +-- +-- With external static plugins we don't check the type of the `plugin` closure +-- we look up. If it's not a valid `Plugin` value, it will probably crash badly. +-- + +module GHC.Driver.Plugins.External + ( ExternalPluginSpec (..) + , parseExternalPluginSpec + ) +where + +import GHC.Prelude +import Text.Read + +-- | External plugin spec +data ExternalPluginSpec = ExternalPluginSpec + { esp_lib :: !FilePath + , esp_unit_id :: !String + , esp_module :: !String + , esp_args :: ![String] + } + +-- | Parser external static plugin specification from command-line flag +parseExternalPluginSpec :: String -> Maybe ExternalPluginSpec +parseExternalPluginSpec optflag = + case break (== ';') optflag of + (libPath, _:rest) -> case break (== ';') rest of + (libName, _:pack) -> case break (== ';') pack of + (modName, _:args) -> case readMaybe args of + Just as -> Just (ExternalPluginSpec libPath libName modName as) + Nothing -> Nothing + _ -> Nothing + _ -> Nothing + _ -> Nothing diff --git a/GHC/Driver/Ppr.hs b/GHC/Driver/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Ppr.hs @@ -0,0 +1,47 @@ +-- | Printing related functions that depend on session state (DynFlags) +module GHC.Driver.Ppr + ( showSDoc + , showSDocUnsafe + , showSDocForUser + , showPpr + , showPprUnsafe + , printForUser + , printForUserColoured + ) +where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Unit.State + +import GHC.Utils.Outputable +import GHC.Utils.Ppr ( Mode(..) ) + +import System.IO ( Handle ) + +-- | Show a SDoc as a String with the default user style +showSDoc :: DynFlags -> SDoc -> String +showSDoc dflags sdoc = renderWithContext (initSDocContext dflags defaultUserStyle) sdoc + +showPpr :: Outputable a => DynFlags -> a -> String +showPpr dflags thing = showSDoc dflags (ppr thing) + +-- | Allows caller to specify the NamePprCtx to use +showSDocForUser :: DynFlags -> UnitState -> NamePprCtx -> SDoc -> String +showSDocForUser dflags unit_state name_ppr_ctx doc = renderWithContext (initSDocContext dflags sty) doc' + where + sty = mkUserStyle name_ppr_ctx AllTheWay + doc' = pprWithUnitState unit_state doc + +printForUser :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO () +printForUser = printForUser' False + +printForUserColoured :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO () +printForUserColoured = printForUser' True + +printForUser' :: Bool -> DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO () +printForUser' colour dflags handle name_ppr_ctx depth doc + = printSDocLn ctx (PageMode False) handle doc + where ctx = initSDocContext dflags (setStyleColoured colour $ mkUserStyle name_ppr_ctx depth) + diff --git a/GHC/Driver/Session.hs b/GHC/Driver/Session.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Session.hs @@ -0,0 +1,3845 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} + +------------------------------------------------------------------------------- +-- +-- | Dynamic flags +-- +-- Most flags are dynamic flags, which means they can change from compilation +-- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each +-- session can be using different dynamic flags. Dynamic flags can also be set +-- at the prompt in GHCi. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +module GHC.Driver.Session ( + -- * Dynamic flags and associated configuration types + DumpFlag(..), + GeneralFlag(..), + WarningFlag(..), DiagnosticReason(..), + Language(..), + FatalMessager, FlushOut(..), + ProfAuto(..), + glasgowExtsFlags, + hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, + dopt, dopt_set, dopt_unset, + gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag', + wopt, wopt_set, wopt_unset, + wopt_fatal, wopt_set_fatal, wopt_unset_fatal, + wopt_set_all_custom, wopt_unset_all_custom, + wopt_set_all_fatal_custom, wopt_unset_all_fatal_custom, + wopt_set_custom, wopt_unset_custom, + wopt_set_fatal_custom, wopt_unset_fatal_custom, + wopt_any_custom, + xopt, xopt_set, xopt_unset, + xopt_set_unlessExplSpec, + xopt_DuplicateRecordFields, + xopt_FieldSelectors, + lang_set, + DynamicTooState(..), dynamicTooState, setDynamicNow, + sccProfilingEnabled, + needSourceNotes, + OnOff(..), + DynFlags(..), + ParMakeCount(..), + outputFile, objectSuf, ways, + FlagSpec(..), + HasDynFlags(..), ContainsDynFlags(..), + RtsOptsEnabled(..), + GhcMode(..), isOneShot, + GhcLink(..), isNoLink, + PackageFlag(..), PackageArg(..), ModRenaming(..), + packageFlagsChanged, + IgnorePackageFlag(..), TrustFlag(..), + PackageDBFlag(..), PkgDbRef(..), + Option(..), showOpt, + DynLibLoader(..), + fFlags, fLangFlags, xFlags, + wWarningFlags, + makeDynFlagsConsistent, + positionIndependent, + optimisationFlags, + codeGenFlags, + setFlagsFromEnvFile, + pprDynFlagsDiff, + flagSpecOf, + + targetProfile, + + -- ** Safe Haskell + safeHaskellOn, safeHaskellModeEnabled, + safeImportsOn, safeLanguageOn, safeInferOn, + packageTrustOn, + safeDirectImpsReq, safeImplicitImpsReq, + unsafeFlags, unsafeFlagsForInfer, + + -- ** base + baseUnitId, + + -- ** System tool settings and locations + Settings(..), + sProgramName, + sProjectVersion, + sGhcUsagePath, + sGhciUsagePath, + sToolDir, + sTopDir, + sGlobalPackageDatabasePath, + sLdSupportsCompactUnwind, + sLdSupportsFilelist, + sLdIsGnuLd, + sGccSupportsNoPie, + sPgm_L, + sPgm_P, + sPgm_F, + sPgm_c, + sPgm_cxx, + sPgm_cpp, + sPgm_a, + sPgm_l, + sPgm_lm, + sPgm_windres, + sPgm_ar, + sPgm_ranlib, + sPgm_lo, + sPgm_lc, + sPgm_las, + sPgm_i, + sOpt_L, + sOpt_P, + sOpt_P_fingerprint, + sOpt_JSP, + sOpt_JSP_fingerprint, + sOpt_CmmP, + sOpt_CmmP_fingerprint, + sOpt_F, + sOpt_c, + sOpt_cxx, + sOpt_a, + sOpt_l, + sOpt_lm, + sOpt_windres, + sOpt_lo, + sOpt_lc, + sOpt_i, + sExtraGccViaCFlags, + sTargetPlatformString, + sGhcWithInterpreter, + sLibFFI, + sTargetRTSLinkerOnlySupportsSharedLibs, + GhcNameVersion(..), + FileSettings(..), + PlatformMisc(..), + settings, + programName, projectVersion, + ghcUsagePath, ghciUsagePath, topDir, + versionedAppDir, versionedFilePath, + extraGccViaCFlags, globalPackageDatabasePath, + pgm_L, pgm_P, pgm_JSP, pgm_CmmP, pgm_F, pgm_c, pgm_cxx, pgm_cpp, pgm_a, pgm_l, + pgm_lm, pgm_windres, pgm_ar, + pgm_ranlib, pgm_lo, pgm_lc, pgm_las, pgm_i, + opt_L, opt_P, opt_JSP, opt_CmmP, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i, + opt_P_signature, opt_JSP_signature, opt_CmmP_signature, + opt_windres, opt_lo, opt_lc, opt_las, + updatePlatformConstants, + + -- ** Manipulating DynFlags + addPluginModuleName, + defaultDynFlags, -- Settings -> DynFlags + initDynFlags, -- DynFlags -> IO DynFlags + defaultFatalMessager, + defaultFlushOut, + setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, + augmentByWorkingDirectory, + + getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] + getVerbFlags, + updOptLevel, + setTmpDir, + setUnitId, + setHomeUnitId, + + TurnOnFlag, + turnOn, + turnOff, + impliedGFlags, + impliedOffGFlags, + impliedXFlags, + + -- ** State + CmdLineP(..), runCmdLineP, + getCmdLineState, putCmdLineState, + processCmdLineP, + + -- ** Parsing DynFlags + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, + parseDynamicFlagsFull, + flagSuggestions, + + -- ** Available DynFlags + allNonDeprecatedFlags, + flagsAll, + flagsDynamic, + flagsPackage, + flagsForCompletion, + + supportedLanguagesAndExtensions, + languageExtensions, + + -- ** DynFlags C compiler options + picCCOpts, picPOpts, + + -- ** DynFlags C linker options + pieCCLDOpts, + + -- * Compiler configuration suitable for display to the user + compilerInfo, + + wordAlignment, + + setUnsafeGlobalDynFlags, + + -- * SSE and AVX + isSse3Enabled, + isSsse3Enabled, + isSse4_1Enabled, + isSse4_2Enabled, + isBmiEnabled, + isBmi2Enabled, + isAvxEnabled, + isAvx2Enabled, + isAvx512cdEnabled, + isAvx512erEnabled, + isAvx512fEnabled, + isAvx512pfEnabled, + isFmaEnabled, + + -- * Linker/compiler information + useXLinkerRPath, + + -- * Include specifications + IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, + addImplicitQuoteInclude, + + -- * SDoc + initSDocContext, initDefaultSDocContext, + initPromotionTickContext, + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Ways +import GHC.Platform.Profile +import GHC.Platform.ArchOS + +import GHC.Unit.Types +import GHC.Unit.Parser +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Driver.DynFlags +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Flags +import GHC.Driver.Backend +import GHC.Driver.Errors.Types +import GHC.Driver.Plugins.External +import GHC.Settings.Config +import GHC.Core.Unfold +import GHC.Driver.CmdLine +import GHC.Utils.Logger +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.GlobalVars +import GHC.Data.Maybe +import GHC.Data.Bool +import GHC.Data.StringBuffer (stringToStringBuffer) +import GHC.Types.Error +import GHC.Types.Name.Reader (RdrName(..)) +import GHC.Types.Name.Occurrence (isVarOcc, occNameString) +import GHC.Utils.Monad +import GHC.Types.SrcLoc +import GHC.Types.SafeHaskell +import GHC.Types.Basic ( treatZeroAsInf ) +import GHC.Data.FastString +import GHC.Utils.TmpFs +import GHC.Utils.Fingerprint +import GHC.Utils.Outputable +import GHC.Utils.Error (emptyDiagOpts, logInfo) +import GHC.Settings +import GHC.CmmToAsm.CFG.Weight +import GHC.Core.Opt.CallerCC +import GHC.Parser (parseIdentifier) +import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..)) + +import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) + +import Data.IORef +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Trans.State as State +import Data.Functor.Identity + +import Data.Ord +import Data.Char +import Data.List (intercalate, sortBy, partition) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Word +import System.FilePath +import Text.ParserCombinators.ReadP hiding (char) +import Text.ParserCombinators.ReadP as R + +import qualified GHC.Data.EnumSet as EnumSet + +import qualified GHC.LanguageExtensions as LangExt + + +-- Note [Updating flag description in the User's Guide] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you modify anything in this file please make sure that your changes are +-- described in the User's Guide. Please update the flag description in the +-- users guide (docs/users_guide) whenever you add or change a flag. +-- Please make sure you add ":since:" information to new flags. + +-- Note [Supporting CLI completion] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The command line interface completion (in for example bash) is an easy way +-- for the developer to learn what flags are available from GHC. +-- GHC helps by separating which flags are available when compiling with GHC, +-- and which flags are available when using GHCi. +-- A flag is assumed to either work in both these modes, or only in one of them. +-- When adding or changing a flag, please consider for which mode the flag will +-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag, +-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec. + +-- Note [Adding a language extension] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- There are a few steps to adding (or removing) a language extension, +-- +-- * Adding the extension to GHC.LanguageExtensions +-- +-- The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +-- is the canonical list of language extensions known by GHC. +-- +-- * Adding a flag to DynFlags.xFlags +-- +-- This is fairly self-explanatory. The name should be concise, memorable, +-- and consistent with any previous implementations of the similar idea in +-- other Haskell compilers. +-- +-- * Adding the flag to the documentation +-- +-- This is the same as any other flag. See +-- Note [Updating flag description in the User's Guide] +-- +-- * Adding the flag to Cabal +-- +-- The Cabal library has its own list of all language extensions supported +-- by all major compilers. This is the list that user code being uploaded +-- to Hackage is checked against to ensure language extension validity. +-- Consequently, it is very important that this list remains up-to-date. +-- +-- To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs) +-- whose job it is to ensure these GHC's extensions are consistent with +-- Cabal. +-- +-- The recommended workflow is, +-- +-- 1. Temporarily add your new language extension to the +-- expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't +-- break while Cabal is updated. +-- +-- 2. After your GHC change is accepted, submit a Cabal pull request adding +-- your new extension to Cabal's list (found in +-- Cabal/Language/Haskell/Extension.hs). +-- +-- 3. After your Cabal change is accepted, let the GHC developers know so +-- they can update the Cabal submodule and remove the extensions from +-- expectedGhcOnlyExtensions. +-- +-- * Adding the flag to the GHC Wiki +-- +-- There is a change log tracking language extension additions and removals +-- on the GHC wiki: https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history +-- +-- See #4437 and #8176. + +-- ----------------------------------------------------------------------------- +-- DynFlags + +{- Note [RHS Floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We provide both 'Opt_LocalFloatOut' and 'Opt_LocalFloatOutTopLevel' to correspond to + 'doFloatFromRhs'; with this we can control floating out with GHC flags. + + This addresses https://gitlab.haskell.org/ghc/ghc/-/issues/13663 and + allows for experimentation. +-} + +----------------------------------------------------------------------------- +-- Accessors from 'DynFlags' + +-- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the +-- vast majority of code. But GHCi questionably uses this to produce a default +-- 'DynFlags' from which to compute a flags diff for printing. +settings :: DynFlags -> Settings +settings dflags = Settings + { sGhcNameVersion = ghcNameVersion dflags + , sFileSettings = fileSettings dflags + , sUnitSettings = unitSettings dflags + , sTargetPlatform = targetPlatform dflags + , sToolSettings = toolSettings dflags + , sPlatformMisc = platformMisc dflags + , sRawSettings = rawSettings dflags + } + +pgm_L :: DynFlags -> String +pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags +pgm_P :: DynFlags -> (String,[Option]) +pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags +pgm_JSP :: DynFlags -> (String,[Option]) +pgm_JSP dflags = toolSettings_pgm_JSP $ toolSettings dflags +pgm_CmmP :: DynFlags -> (String,[Option]) +pgm_CmmP dflags = toolSettings_pgm_CmmP $ toolSettings dflags +pgm_F :: DynFlags -> String +pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags +pgm_c :: DynFlags -> String +pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags +pgm_cxx :: DynFlags -> String +pgm_cxx dflags = toolSettings_pgm_cxx $ toolSettings dflags +pgm_cpp :: DynFlags -> (String,[Option]) +pgm_cpp dflags = toolSettings_pgm_cpp $ toolSettings dflags +pgm_a :: DynFlags -> (String,[Option]) +pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags +pgm_l :: DynFlags -> (String,[Option]) +pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags +pgm_lm :: DynFlags -> Maybe (String,[Option]) +pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags +pgm_windres :: DynFlags -> String +pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags +pgm_ar :: DynFlags -> String +pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags +pgm_ranlib :: DynFlags -> String +pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags +pgm_lo :: DynFlags -> (String,[Option]) +pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags +pgm_lc :: DynFlags -> (String,[Option]) +pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags +pgm_las :: DynFlags -> (String,[Option]) +pgm_las dflags = toolSettings_pgm_las $ toolSettings dflags +pgm_i :: DynFlags -> String +pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags +opt_L :: DynFlags -> [String] +opt_L dflags = toolSettings_opt_L $ toolSettings dflags +opt_P :: DynFlags -> [String] +opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_P (toolSettings dflags) +opt_JSP :: DynFlags -> [String] +opt_JSP dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_JSP (toolSettings dflags) +opt_CmmP :: DynFlags -> [String] +opt_CmmP dflags = toolSettings_opt_CmmP $ toolSettings dflags + +-- This function packages everything that's needed to fingerprint opt_P +-- flags. See Note [Repeated -optP hashing]. +opt_P_signature :: DynFlags -> ([String], Fingerprint) +opt_P_signature dflags = + ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + , toolSettings_opt_P_fingerprint $ toolSettings dflags + ) +-- This function packages everything that's needed to fingerprint opt_P +-- flags. See Note [Repeated -optP hashing]. +opt_JSP_signature :: DynFlags -> ([String], Fingerprint) +opt_JSP_signature dflags = + ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + , toolSettings_opt_JSP_fingerprint $ toolSettings dflags + ) +-- This function packages everything that's needed to fingerprint opt_CmmP +-- flags. See Note [Repeated -optP hashing]. +opt_CmmP_signature :: DynFlags -> Fingerprint +opt_CmmP_signature = toolSettings_opt_CmmP_fingerprint . toolSettings + +opt_F :: DynFlags -> [String] +opt_F dflags= toolSettings_opt_F $ toolSettings dflags +opt_c :: DynFlags -> [String] +opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_c (toolSettings dflags) +opt_cxx :: DynFlags -> [String] +opt_cxx dflags = concatMap (wayOptcxx (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_cxx (toolSettings dflags) +opt_a :: DynFlags -> [String] +opt_a dflags= toolSettings_opt_a $ toolSettings dflags +opt_l :: DynFlags -> [String] +opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_l (toolSettings dflags) +opt_lm :: DynFlags -> [String] +opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags +opt_windres :: DynFlags -> [String] +opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags +opt_lo :: DynFlags -> [String] +opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags +opt_lc :: DynFlags -> [String] +opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags +opt_las :: DynFlags -> [String] +opt_las dflags = toolSettings_opt_las $ toolSettings dflags +opt_i :: DynFlags -> [String] +opt_i dflags= toolSettings_opt_i $ toolSettings dflags + + +setBaseUnitId :: String -> DynP () +setBaseUnitId s = upd $ \d -> d { unitSettings = UnitSettings (stringToUnitId s) } + +----------------------------------------------------------------------------- + +{- +Note [Verbosity levels] +~~~~~~~~~~~~~~~~~~~~~~~ + 0 | print errors & warnings only + 1 | minimal verbosity: print "compiling M ... done." for each module. + 2 | equivalent to -dshow-passes + 3 | equivalent to existing "ghc -v" + 4 | "ghc -v -ddump-most" + 5 | "ghc -v -ddump-all" +-} + +-- | Set the Haskell language standard to use +setLanguage :: Language -> DynP () +setLanguage l = upd (`lang_set` Just l) + +-- | Is the -fpackage-trust mode on +packageTrustOn :: DynFlags -> Bool +packageTrustOn = gopt Opt_PackageTrust + +-- | Is Safe Haskell on in some way (including inference mode) +safeHaskellOn :: DynFlags -> Bool +safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags + +safeHaskellModeEnabled :: DynFlags -> Bool +safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy + , Sf_Safe ] + + +-- | Is the Safe Haskell safe language in use +safeLanguageOn :: DynFlags -> Bool +safeLanguageOn dflags = safeHaskell dflags == Sf_Safe + +-- | Is the Safe Haskell safe inference mode active +safeInferOn :: DynFlags -> Bool +safeInferOn = safeInfer + +-- | Test if Safe Imports are on in some form +safeImportsOn :: DynFlags -> Bool +safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe || + safeHaskell dflags == Sf_Trustworthy || + safeHaskell dflags == Sf_Safe + +-- | Set a 'Safe Haskell' flag +setSafeHaskell :: SafeHaskellMode -> DynP () +setSafeHaskell s = updM f + where f dfs = do + let sf = safeHaskell dfs + safeM <- combineSafeFlags sf s + case s of + Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } + -- leave safe inference on in Trustworthy mode so we can warn + -- if it could have been inferred safe. + Sf_Trustworthy -> do + l <- getCurLoc + return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } + -- leave safe inference on in Unsafe mode as well. + _ -> return $ dfs { safeHaskell = safeM } + +-- | Are all direct imports required to be safe for this Safe Haskell mode? +-- Direct imports are when the code explicitly imports a module +safeDirectImpsReq :: DynFlags -> Bool +safeDirectImpsReq d = safeLanguageOn d + +-- | Are all implicit imports required to be safe for this Safe Haskell mode? +-- Implicit imports are things in the prelude. e.g System.IO when print is used. +safeImplicitImpsReq :: DynFlags -> Bool +safeImplicitImpsReq d = safeLanguageOn d + +-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. +-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't +-- want to export this functionality from the module but do want to export the +-- type constructors. +combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode +combineSafeFlags a b | a == Sf_None = return b + | b == Sf_None = return a + | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore + | a == b = return a + | otherwise = addErr errm >> pure a + where errm = "Incompatible Safe Haskell flags! (" + ++ show a ++ ", " ++ show b ++ ")" + +-- | A list of unsafe flags under Safe Haskell. Tuple elements are: +-- * name of the flag +-- * function to get srcspan that enabled the flag +-- * function to test if the flag is on +-- * function to turn the flag off +unsafeFlags, unsafeFlagsForInfer + :: [(LangExt.Extension, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags = [ (LangExt.GeneralizedNewtypeDeriving, newDerivOnLoc, + xopt LangExt.GeneralizedNewtypeDeriving, + flip xopt_unset LangExt.GeneralizedNewtypeDeriving) + , (LangExt.DerivingVia, deriveViaOnLoc, + xopt LangExt.DerivingVia, + flip xopt_unset LangExt.DerivingVia) + , (LangExt.TemplateHaskell, thOnLoc, + xopt LangExt.TemplateHaskell, + flip xopt_unset LangExt.TemplateHaskell) + ] +unsafeFlagsForInfer = unsafeFlags + + +-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order +getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from + -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors + -> [a] -- ^ Correctly ordered extracted options +getOpts dflags opts = reverse (opts dflags) + -- We add to the options from the front, so we need to reverse the list + +-- | Gets the verbosity flag for the current verbosity level. This is fed to +-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] + +setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir, + setDynObjectSuf, setDynHiSuf, + setDylibInstallName, + setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode, + setPgmP, setPgmJSP, setPgmCmmP, addOptl, addOptc, addOptcxx, addOptP, + addOptJSP, addOptCmmP, + addCmdlineFramework, addHaddockOpts, addGhciScript, + setInteractivePrint + :: String -> DynFlags -> DynFlags +setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, setDumpPrefixForce + :: Maybe String -> DynFlags -> DynFlags + +setObjectDir f d = d { objectDir = Just f} +setHiDir f d = d { hiDir = Just f} +setHieDir f d = d { hieDir = Just f} +setStubDir f d = d { stubDir = Just f + , includePaths = addGlobalInclude (includePaths d) [f] } + -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file + -- \#included from the .hc file when compiling via C (i.e. unregisterised + -- builds). +setDumpDir f d = d { dumpDir = Just f} +setOutputDir f = setObjectDir f + . setHieDir f + . setHiDir f + . setStubDir f + . setDumpDir f +setDylibInstallName f d = d { dylibInstallName = Just f} + +setObjectSuf f d = d { objectSuf_ = f} +setDynObjectSuf f d = d { dynObjectSuf_ = f} +setHiSuf f d = d { hiSuf_ = f} +setHieSuf f d = d { hieSuf = f} +setDynHiSuf f d = d { dynHiSuf_ = f} +setHcSuf f d = d { hcSuf = f} + +setOutputFile f d = d { outputFile_ = f} +setDynOutputFile f d = d { dynOutputFile_ = f} +setOutputHi f d = d { outputHi = f} +setDynOutputHi f d = d { dynOutputHi = f} + +parseUnitInsts :: String -> Instantiations +parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) + where parse = sepBy parseEntry (R.char ',') + parseEntry = do + n <- parseModuleName + _ <- R.char '=' + m <- parseHoleyModule + return (n, m) + +setUnitInstantiations :: String -> DynFlags -> DynFlags +setUnitInstantiations s d = + d { homeUnitInstantiations_ = parseUnitInsts s } + +setUnitInstanceOf :: String -> DynFlags -> DynFlags +setUnitInstanceOf s d = + d { homeUnitInstanceOf_ = Just (UnitId (fsLit s)) } + +addPluginModuleName :: String -> DynFlags -> DynFlags +addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } + +clearPluginModuleNames :: DynFlags -> DynFlags +clearPluginModuleNames d = + d { pluginModNames = [] + , pluginModNameOpts = [] + } + +addPluginModuleNameOption :: String -> DynFlags -> DynFlags +addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } + where (m, rest) = break (== ':') optflag + option = case rest of + [] -> "" -- should probably signal an error + (_:plug_opt) -> plug_opt -- ignore the ':' from break + +addExternalPlugin :: String -> DynFlags -> DynFlags +addExternalPlugin optflag d = case parseExternalPluginSpec optflag of + Just r -> d { externalPluginSpecs = r : externalPluginSpecs d } + Nothing -> cmdLineError $ "Couldn't parse external plugin specification: " ++ optflag + +addFrontendPluginOption :: String -> DynFlags -> DynFlags +addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d } + +parseDynLibLoaderMode f d = + case splitAt 8 f of + ("deploy", "") -> d { dynLibLoader = Deployable } + ("sysdep", "") -> d { dynLibLoader = SystemDependent } + _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f)) + +setDumpPrefixForce f d = d { dumpPrefixForce = f} + +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmP f = alterToolSettings (\s -> s { toolSettings_pgm_P = (pgm, map Option args)}) + where pgm:|args = expectNonEmpty $ words f +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmJSP f = alterToolSettings (\s -> s { toolSettings_pgm_JSP = (pgm, map Option args)}) + where pgm:|args = expectNonEmpty $ words f +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmCmmP f = alterToolSettings (\s -> s { toolSettings_pgm_CmmP = (pgm, map Option args)}) + where pgm:|args = expectNonEmpty $ words f +addOptl f = alterToolSettings (\s -> s { toolSettings_opt_l = f : toolSettings_opt_l s}) +addOptc f = alterToolSettings (\s -> s { toolSettings_opt_c = f : toolSettings_opt_c s}) +addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s}) +addOptP f = alterToolSettings $ \s -> s + { toolSettings_opt_P = f : toolSettings_opt_P s + , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) + } + -- See Note [Repeated -optP hashing] +addOptJSP f = alterToolSettings $ \s -> s + { toolSettings_opt_JSP = f : toolSettings_opt_JSP s + , toolSettings_opt_JSP_fingerprint = fingerprintStrings (f : toolSettings_opt_JSP s) + } + -- See Note [Repeated -optP hashing] +addOptCmmP f = alterToolSettings $ \s -> s + { toolSettings_opt_CmmP = f : toolSettings_opt_CmmP s + , toolSettings_opt_CmmP_fingerprint = fingerprintStrings (f : toolSettings_opt_CmmP s) + } + +setDepMakefile :: FilePath -> DynFlags -> DynFlags +setDepMakefile f d = d { depMakefile = f } + +setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags +setDepIncludeCppDeps b d = d { depIncludeCppDeps = b } + +setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags +setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } + +addDepExcludeMod :: String -> DynFlags -> DynFlags +addDepExcludeMod m d + = d { depExcludeMods = mkModuleName m : depExcludeMods d } + +addDepSuffix :: FilePath -> DynFlags -> DynFlags +addDepSuffix s d = d { depSuffixes = s : depSuffixes d } + +addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d} + +addGhcVersionFile :: FilePath -> DynFlags -> DynFlags +addGhcVersionFile f d = d { ghcVersionFile = Just f } + +addHaddockOpts f d = d { haddockOptions = Just f} + +addGhciScript f d = d { ghciScripts = f : ghciScripts d} + +setInteractivePrint f d = d { interactivePrint = Just f} + +----------------------------------------------------------------------------- +-- Setting the optimisation level + +updOptLevelChanged :: Int -> DynFlags -> (DynFlags, Bool) +-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level and signals if any changes took place +updOptLevelChanged n dfs + = (dfs3, changed1 || changed2 || changed3) + where + final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 + (dfs1, changed1) = foldr unset (dfs , False) remove_gopts + (dfs2, changed2) = foldr set (dfs1, False) extra_gopts + (dfs3, changed3) = setLlvmOptLevel dfs2 + + extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] + remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] + + set f (dfs, changed) + | gopt f dfs = (dfs, changed) + | otherwise = (gopt_set dfs f, True) + + unset f (dfs, changed) + | not (gopt f dfs) = (dfs, changed) + | otherwise = (gopt_unset dfs f, True) + + setLlvmOptLevel dfs + | llvmOptLevel dfs /= final_n = (dfs{ llvmOptLevel = final_n }, True) + | otherwise = (dfs, False) + +updOptLevel :: Int -> DynFlags -> DynFlags +-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level +updOptLevel n = fst . updOptLevelChanged n + +{- ********************************************************************** +%* * + DynFlags parser +%* * +%********************************************************************* -} + +-- ----------------------------------------------------------------------------- +-- Parsing the dynamic flags. + + +-- | Parse dynamic flags from a list of command line arguments. Returns +-- the parsed 'DynFlags', the left-over arguments, and a list of warnings. +-- Throws a 'UsageError' if errors occurred during parsing (such as unknown +-- flags or missing arguments). +parseDynamicFlagsCmdLine :: MonadIO m => Logger -> DynFlags -> [Located String] + -> m (DynFlags, [Located String], Messages DriverMessage) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True + + +-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags +-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). +-- Used to parse flags set in a modules pragma. +parseDynamicFilePragma :: MonadIO m => Logger -> DynFlags -> [Located String] + -> m (DynFlags, [Located String], Messages DriverMessage) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False + +newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a) + deriving (Functor) + +instance Monad (CmdLineP s) where + CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g) + return = pure + +instance Applicative (CmdLineP s) where + pure x = CmdLineP (pure x) + (<*>) = ap + +getCmdLineState :: CmdLineP s s +getCmdLineState = CmdLineP State.get + +putCmdLineState :: s -> CmdLineP s () +putCmdLineState x = CmdLineP (State.put x) + +runCmdLineP :: CmdLineP s a -> s -> (a, s) +runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0 + +-- | A helper to parse a set of flags from a list of command-line arguments, handling +-- response files. +processCmdLineP + :: forall s m. MonadIO m + => [Flag (CmdLineP s)] -- ^ valid flags to match against + -> s -- ^ current state + -> [Located String] -- ^ arguments to parse + -> m (([Located String], [Err], [Warn]), s) + -- ^ (leftovers, errors, warnings) +processCmdLineP activeFlags s0 args = + runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0 + where + getCmdLineP :: CmdLineP s a -> StateT s m a + getCmdLineP (CmdLineP k) = k + +-- | Parses the dynamically set flags for GHC. This is the most general form of +-- the dynamic flag parser that the other methods simply wrap. It allows +-- saying which flags are valid flags and indicating if we are parsing +-- arguments from the command line or from a file pragma. +parseDynamicFlagsFull + :: forall m. MonadIO m + => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against + -> Bool -- ^ are the arguments from the command line? + -> Logger -- ^ logger + -> DynFlags -- ^ current dynamic flags + -> [Located String] -- ^ arguments to parse + -> m (DynFlags, [Located String], Messages DriverMessage) +parseDynamicFlagsFull activeFlags cmdline logger dflags0 args = do + ((leftover, errs, cli_warns), dflags1) <- processCmdLineP activeFlags dflags0 args + + -- See Note [Handling errors when parsing command-line flags] + let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle) + unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $ + map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs + + -- check for disabled flags in safe haskell + let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 + theWays = ways dflags2 + + unless (allowed_combination theWays) $ liftIO $ + throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ + intercalate "/" (map wayDesc (Set.toAscList theWays)))) + + let (dflags3, consistency_warnings, infoverb) = makeDynFlagsConsistent dflags2 + + -- Set timer stats & heap size + when (enableTimeStats dflags3) $ liftIO enableTimingStats + case (ghcHeapSize dflags3) of + Just x -> liftIO (setHeapSize x) + _ -> return () + + liftIO $ setUnsafeGlobalDynFlags dflags3 + + -- create message envelopes using final DynFlags: #23402 + let diag_opts = initDiagOpts dflags3 + warns = warnsToMessages diag_opts $ mconcat [consistency_warnings, sh_warns, cli_warns] + + when (logVerbAtLeast logger 3) $ + mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb + + return (dflags3, leftover, warns) + +-- | Check (and potentially disable) any extensions that aren't allowed +-- in safe mode. +-- +-- The bool is to indicate if we are parsing command line flags (false means +-- file pragma). This allows us to generate better warnings. +safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Warn]) +safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) + where + -- Handle illegal flags under safe language. + (dflagsUnset, warns) = foldl' check_method (dflags, mempty) unsafeFlags + + check_method (df, warns) (ext,loc,test,fix) + | test df = (fix df, safeFailure (loc df) ext : warns) + | otherwise = (df, warns) + + safeFailure loc ext + = L loc $ DriverSafeHaskellIgnoredExtension ext + +safeFlagCheck cmdl dflags = + case safeInferOn dflags of + True -> (dflags' { safeInferred = safeFlags }, warn) + False -> (dflags', warn) + + where + -- dynflags and warn for when -fpackage-trust by itself with no safe + -- haskell flag + (dflags', warn) + | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags + = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) + | otherwise = (dflags, mempty) + + pkgWarnMsg :: [Warn] + pkgWarnMsg = [ L (pkgTrustOnLoc dflags') DriverPackageTrustIgnored ] + + -- Have we inferred Unsafe? See Note [Safe Haskell Inference] in GHC.Driver.Main + -- Force this to avoid retaining reference to old DynFlags value + !safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer + +-- | Produce a list of suggestions for a user provided flag that is invalid. +flagSuggestions + :: [String] -- valid flags to match against + -> String + -> [String] +flagSuggestions flags userInput + -- fixes #11789 + -- If the flag contains '=', + -- this uses both the whole and the left side of '=' for comparing. + | elem '=' userInput = + let (flagsWithEq, flagsWithoutEq) = partition (elem '=') flags + fName = takeWhile (/= '=') userInput + in (fuzzyMatch userInput flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq) + | otherwise = fuzzyMatch userInput flags + +{- ********************************************************************** +%* * + DynFlags specifications +%* * +%********************************************************************* -} + +-- | All dynamic flags option strings without the deprecated ones. +-- These are the user facing strings for enabling and disabling options. +allNonDeprecatedFlags :: [String] +allNonDeprecatedFlags = allFlagsDeps False + +-- | All flags with possibility to filter deprecated ones +allFlagsDeps :: Bool -> [String] +allFlagsDeps keepDeprecated = [ '-':flagName flag + | (deprecated, flag) <- flagsAllDeps + , keepDeprecated || not (isDeprecated deprecated)] + where isDeprecated Deprecated = True + isDeprecated _ = False + +{- + - Below we export user facing symbols for GHC dynamic flags for use with the + - GHC API. + -} + +-- All dynamic flags present in GHC. +flagsAll :: [Flag (CmdLineP DynFlags)] +flagsAll = map snd flagsAllDeps + +-- All dynamic flags present in GHC with deprecation information. +flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] +flagsAllDeps = package_flags_deps ++ dynamic_flags_deps + + +-- All dynamic flags, minus package flags, present in GHC. +flagsDynamic :: [Flag (CmdLineP DynFlags)] +flagsDynamic = map snd dynamic_flags_deps + +-- ALl package flags present in GHC. +flagsPackage :: [Flag (CmdLineP DynFlags)] +flagsPackage = map snd package_flags_deps + +----------------Helpers to make flags and keep deprecation information---------- + +type FlagMaker m = String -> OptKind m -> Flag m +type DynFlagMaker = FlagMaker (CmdLineP DynFlags) + +-- Make a non-deprecated flag +make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_ord_flag fm name kind = (NotDeprecated, fm name kind) + +-- Make a deprecated flag +make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_dep_flag fm name kind message = (Deprecated, + fm name $ add_dep_message kind message) + +add_dep_message :: OptKind (CmdLineP DynFlags) -> String + -> OptKind (CmdLineP DynFlags) +add_dep_message (NoArg f) message = NoArg $ f >> deprecate message +add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message +add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message +add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message +add_dep_message (OptPrefix f) message = + OptPrefix $ \s -> f s >> deprecate message +add_dep_message (OptIntSuffix f) message = + OptIntSuffix $ \oi -> f oi >> deprecate message +add_dep_message (IntSuffix f) message = + IntSuffix $ \i -> f i >> deprecate message +add_dep_message (Word64Suffix f) message = + Word64Suffix $ \i -> f i >> deprecate message +add_dep_message (FloatSuffix f) message = + FloatSuffix $ \fl -> f fl >> deprecate message +add_dep_message (PassFlag f) message = + PassFlag $ \s -> f s >> deprecate message +add_dep_message (AnySuffix f) message = + AnySuffix $ \s -> f s >> deprecate message + +----------------------- The main flags themselves ------------------------------ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +dynamic_flags_deps = [ + make_dep_flag defFlag "n" (NoArg $ return ()) + "The -n flag is deprecated and no longer has any effect" + , make_ord_flag defFlag "cpp" (NoArg (setExtensionFlag LangExt.Cpp)) + , make_ord_flag defFlag "F" (NoArg (setGeneralFlag Opt_Pp)) + , (Deprecated, defFlag "#include" + (HasArg (\_s -> + deprecate ("-#include and INCLUDE pragmas are " ++ + "deprecated: They no longer have any effect")))) + , make_ord_flag defFlag "v" (OptIntSuffix setVerbosity) + + , make_ord_flag defGhcFlag "j" (OptIntSuffix + (\n -> case n of + Just n + | n > 0 -> upd (\d -> d { parMakeCount = Just (ParMakeThisMany n) }) + | otherwise -> addErr "Syntax: -j[n] where n > 0" + Nothing -> upd (\d -> d { parMakeCount = Just ParMakeNumProcessors }))) + -- When the number of parallel builds + -- is omitted, it is the same + -- as specifying that the number of + -- parallel builds is equal to the + -- result of getNumProcessors + , make_ord_flag defGhcFlag "jsem" $ hasArg $ \f d -> d { parMakeCount = Just (ParMakeSemaphore f) } + + , make_ord_flag defFlag "instantiated-with" (sepArg setUnitInstantiations) + , make_ord_flag defFlag "this-component-id" (sepArg setUnitInstanceOf) + + -- RTS options ------------------------------------------------------------- + , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> + d { ghcHeapSize = Just $ fromIntegral (decodeSize s)}))) + + , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d -> + d { enableTimeStats = True }))) + + ------- ways --------------------------------------------------------------- + , make_ord_flag defGhcFlag "prof" (NoArg (addWayDynP WayProf)) + , (Deprecated, defFlag "eventlog" + $ noArgM $ \d -> do + deprecate "the eventlog is now enabled in all runtime system ways" + return d) + , make_ord_flag defGhcFlag "debug" (NoArg (addWayDynP WayDebug)) + , make_ord_flag defGhcFlag "threaded" (NoArg (addWayDynP WayThreaded)) + , make_ord_flag defGhcFlag "single-threaded" (NoArg (removeWayDynP WayThreaded)) + + , make_ord_flag defGhcFlag "ticky" + (NoArg (setGeneralFlag Opt_Ticky >> addWayDynP WayDebug)) + + -- -ticky enables ticky-ticky code generation, and also implies -debug which + -- is required to get the RTS ticky support. + + ----- Linker -------------------------------------------------------- + , make_ord_flag defGhcFlag "static" (NoArg (removeWayDynP WayDyn)) + , make_ord_flag defGhcFlag "dynamic" (NoArg (addWayDynP WayDyn)) + , make_ord_flag defGhcFlag "rdynamic" $ noArg $ +#if defined(linux_HOST_OS) + addOptl "-rdynamic" +#elif defined(mingw32_HOST_OS) + addOptl "-Wl,--export-all-symbols" +#else + -- ignored for compat w/ gcc: + id +#endif + , make_ord_flag defGhcFlag "relative-dynlib-paths" + (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) + , make_ord_flag defGhcFlag "copy-libs-when-linking" + (NoArg (setGeneralFlag Opt_SingleLibFolder)) + , make_ord_flag defGhcFlag "pie" (NoArg (setGeneralFlag Opt_PICExecutable)) + , make_ord_flag defGhcFlag "no-pie" (NoArg (unSetGeneralFlag Opt_PICExecutable)) + + ------- Specific phases -------------------------------------------- + -- need to appear before -pgmL to be parsed as LLVM flags. + , make_ord_flag defFlag "pgmlo" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo = (f,[]) } + , make_ord_flag defFlag "pgmlc" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc = (f,[]) } + , make_ord_flag defFlag "pgmlas" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_las = (f,[]) } + , make_ord_flag defFlag "pgmlm" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm = + if null f then Nothing else Just (f,[]) } + , make_ord_flag defFlag "pgmi" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i = f } + , make_ord_flag defFlag "pgmL" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L = f } + , make_ord_flag defFlag "pgmP" + (hasArg setPgmP) + , make_ord_flag defFlag "pgmJSP" + (hasArg setPgmJSP) + , make_ord_flag defFlag "pgmCmmP" + (hasArg setPgmCmmP) + , make_ord_flag defFlag "pgmF" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F = f } + , make_ord_flag defFlag "pgmc" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_c = f } + , make_ord_flag defFlag "pgmcxx" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_cxx = f } + , (Deprecated, defFlag "pgmc-supports-no-pie" + $ noArgM $ \d -> do + deprecate $ "use -pgml-supports-no-pie instead" + pure $ alterToolSettings (\s -> s { toolSettings_ccSupportsNoPie = True }) d) + , make_ord_flag defFlag "pgms" + (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8")) + , make_ord_flag defFlag "pgma" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a = (f,[]) } + , make_ord_flag defFlag "pgml" + $ hasArg $ \f -> alterToolSettings $ \s -> s + { toolSettings_pgm_l = (f,[]) + , -- Don't pass -no-pie with custom -pgml (see #15319). Note + -- that this could break when -no-pie is actually needed. + -- But the CC_SUPPORTS_NO_PIE check only happens at + -- buildtime, and -pgml is a runtime option. A better + -- solution would be running this check for each custom + -- -pgml. + toolSettings_ccSupportsNoPie = False + } + , make_ord_flag defFlag "pgml-supports-no-pie" + $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True } + , make_ord_flag defFlag "pgmwindres" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f } + , make_ord_flag defFlag "pgmar" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f } + , make_ord_flag defFlag "pgmotool" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_otool = f} + , make_ord_flag defFlag "pgminstall_name_tool" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_install_name_tool = f} + , make_ord_flag defFlag "pgmranlib" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f } + + + -- need to appear before -optl/-opta to be parsed as LLVM flags. + , make_ord_flag defFlag "optlm" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm = f : toolSettings_opt_lm s } + , make_ord_flag defFlag "optlo" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo = f : toolSettings_opt_lo s } + , make_ord_flag defFlag "optlc" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc = f : toolSettings_opt_lc s } + , make_ord_flag defFlag "optlas" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_las = f : toolSettings_opt_las s } + , make_ord_flag defFlag "opti" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i = f : toolSettings_opt_i s } + , make_ord_flag defFlag "optL" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L = f : toolSettings_opt_L s } + , make_ord_flag defFlag "optP" + (hasArg addOptP) + , make_ord_flag defFlag "optJSP" + (hasArg addOptJSP) + , make_ord_flag defFlag "optCmmP" + (hasArg addOptCmmP) + , make_ord_flag defFlag "optF" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F = f : toolSettings_opt_F s } + , make_ord_flag defFlag "optc" + (hasArg addOptc) + , make_ord_flag defFlag "optcxx" + (hasArg addOptcxx) + , make_ord_flag defFlag "opta" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a = f : toolSettings_opt_a s } + , make_ord_flag defFlag "optl" + (hasArg addOptl) + , make_ord_flag defFlag "optwindres" + $ hasArg $ \f -> + alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s } + + -- N.B. We may someday deprecate this in favor of -fsplit-sections, + -- which has the benefit of also having a negating -fno-split-sections. + , make_ord_flag defGhcFlag "split-sections" + (NoArg $ setGeneralFlag Opt_SplitSections) + + -------- ghc -M ----------------------------------------------------- + , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) + , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) + , make_ord_flag defGhcFlag "include-cpp-deps" + (noArg (setDepIncludeCppDeps True)) + , make_ord_flag defGhcFlag "include-pkg-deps" + (noArg (setDepIncludePkgDeps True)) + , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) + + -------- Linking ---------------------------------------------------- + , make_ord_flag defGhcFlag "no-link" + (noArg (\d -> d { ghcLink=NoLink })) + , make_ord_flag defGhcFlag "shared" + (noArg (\d -> d { ghcLink=LinkDynLib })) + , make_ord_flag defGhcFlag "staticlib" + (noArg (\d -> setGeneralFlag' Opt_LinkRts (d { ghcLink=LinkStaticLib }))) + , make_ord_flag defGhcFlag "-merge-objs" + (noArg (\d -> d { ghcLink=LinkMergedObj })) + , make_ord_flag defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) + , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) + + ------- Libraries --------------------------------------------------- + , make_ord_flag defFlag "L" (Prefix addLibraryPath) + , make_ord_flag defFlag "l" (hasArg (addLdInputs . Option . ("-l" ++))) + + ------- Frameworks -------------------------------------------------- + -- -framework-path should really be -F ... + , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath) + , make_ord_flag defFlag "framework" (hasArg addCmdlineFramework) + + ------- Output Redirection ------------------------------------------ + , make_ord_flag defGhcFlag "odir" (hasArg setObjectDir) + , make_ord_flag defGhcFlag "o" (sepArg (setOutputFile . Just)) + , make_ord_flag defGhcFlag "dyno" + (sepArg (setDynOutputFile . Just)) + , make_ord_flag defGhcFlag "ohi" + (hasArg (setOutputHi . Just )) + , make_ord_flag defGhcFlag "dynohi" + (hasArg (setDynOutputHi . Just )) + , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) + , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) + , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf) + , make_ord_flag defGhcFlag "hisuf" (hasArg setHiSuf) + , make_ord_flag defGhcFlag "hiesuf" (hasArg setHieSuf) + , make_ord_flag defGhcFlag "dynhisuf" (hasArg setDynHiSuf) + , make_ord_flag defGhcFlag "hidir" (hasArg setHiDir) + , make_ord_flag defGhcFlag "hiedir" (hasArg setHieDir) + , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) + , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) + , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) + , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) + , make_ord_flag defGhcFlag "ddump-file-prefix" + (hasArg (setDumpPrefixForce . Just . flip (++) ".")) + + , make_ord_flag defGhcFlag "dynamic-too" + (NoArg (setGeneralFlag Opt_BuildDynamicToo)) + + ------- Keeping temporary files ------------------------------------- + -- These can be singular (think ghc -c) or plural (think ghc --make) + , make_ord_flag defGhcFlag "keep-hc-file" + (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , make_ord_flag defGhcFlag "keep-hc-files" + (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-file" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-files" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) + , make_ord_flag defGhcFlag "keep-s-file" + (NoArg (setGeneralFlag Opt_KeepSFiles)) + , make_ord_flag defGhcFlag "keep-s-files" + (NoArg (setGeneralFlag Opt_KeepSFiles)) + , make_ord_flag defGhcFlag "keep-llvm-file" + (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) + , make_ord_flag defGhcFlag "keep-llvm-files" + (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) + -- This only makes sense as plural + , make_ord_flag defGhcFlag "keep-tmp-files" + (NoArg (setGeneralFlag Opt_KeepTmpFiles)) + , make_ord_flag defGhcFlag "keep-hi-file" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-file" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-hi-files" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-files" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-o-file" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-file" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "keep-o-files" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-files" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + + ------- Miscellaneous ---------------------------------------------- + , make_ord_flag defGhcFlag "no-auto-link-packages" + (NoArg (unSetGeneralFlag Opt_AutoLinkPackages)) + , make_ord_flag defGhcFlag "no-hs-main" + (NoArg (setGeneralFlag Opt_NoHsMain)) + , make_ord_flag defGhcFlag "fno-state-hack" + (NoArg (setGeneralFlag Opt_G_NoStateHack)) + , make_ord_flag defGhcFlag "fno-opt-coercion" + (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) + , make_ord_flag defGhcFlag "with-rtsopts" + (HasArg setRtsOpts) + , make_ord_flag defGhcFlag "rtsopts" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=all" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=some" + (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) + , make_ord_flag defGhcFlag "rtsopts=none" + (NoArg (setRtsOptsEnabled RtsOptsNone)) + , make_ord_flag defGhcFlag "rtsopts=ignore" + (NoArg (setRtsOptsEnabled RtsOptsIgnore)) + , make_ord_flag defGhcFlag "rtsopts=ignoreAll" + (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll)) + , make_ord_flag defGhcFlag "no-rtsopts" + (NoArg (setRtsOptsEnabled RtsOptsNone)) + , make_ord_flag defGhcFlag "no-rtsopts-suggestions" + (noArg (\d -> d {rtsOptsSuggestions = False})) + , make_ord_flag defGhcFlag "dhex-word-literals" + (NoArg (setGeneralFlag Opt_HexWordLiterals)) + + , make_ord_flag defGhcFlag "ghcversion-file" (hasArg addGhcVersionFile) + , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) + , make_ord_flag defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) + , make_ord_flag defGhcFlag "no-haddock" (NoArg (unSetGeneralFlag Opt_Haddock)) + , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) + , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) + , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) + , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) + , make_ord_flag defGhcFlag "ticky-allocd" + (NoArg (setGeneralFlag Opt_Ticky_Allocd)) + , make_ord_flag defGhcFlag "ticky-LNE" + (NoArg (setGeneralFlag Opt_Ticky_LNE)) + , make_ord_flag defGhcFlag "ticky-ap-thunk" + (NoArg (setGeneralFlag Opt_Ticky_AP)) + , make_ord_flag defGhcFlag "ticky-dyn-thunk" + (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) + , make_ord_flag defGhcFlag "ticky-tag-checks" + (NoArg (setGeneralFlag Opt_Ticky_Tag)) + ------- recompilation checker -------------------------------------- + , make_dep_flag defGhcFlag "recomp" + (NoArg $ unSetGeneralFlag Opt_ForceRecomp) + "Use -fno-force-recomp instead" + , make_dep_flag defGhcFlag "no-recomp" + (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead" + , make_ord_flag defFlag "fmax-errors" + (intSuffix (\n d -> d { maxErrors = Just (max 1 n) })) + , make_ord_flag defFlag "fno-max-errors" + (noArg (\d -> d { maxErrors = Nothing })) + , make_ord_flag defFlag "freverse-errors" + (noArg (\d -> d {reverseErrors = True} )) + , make_ord_flag defFlag "fno-reverse-errors" + (noArg (\d -> d {reverseErrors = False} )) + + ------ HsCpp opts --------------------------------------------------- + , make_ord_flag defFlag "D" (AnySuffix (upd . addOptP)) + , make_ord_flag defFlag "U" (AnySuffix (upd . addOptP)) + + ------- Include/Import Paths ---------------------------------------- + , make_ord_flag defFlag "I" (Prefix addIncludePath) + , make_ord_flag defFlag "i" (OptPrefix addImportPath) + + ------ Output style options ----------------------------------------- + , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d -> + d { pprUserLength = n })) + , make_ord_flag defFlag "dppr-cols" (intSuffix (\n d -> + d { pprCols = n })) + , make_ord_flag defFlag "fdiagnostics-color=auto" + (NoArg (upd (\d -> d { useColor = Auto }))) + , make_ord_flag defFlag "fdiagnostics-color=always" + (NoArg (upd (\d -> d { useColor = Always }))) + , make_ord_flag defFlag "fdiagnostics-color=never" + (NoArg (upd (\d -> d { useColor = Never }))) + + , make_ord_flag defFlag "fprint-error-index-links=auto" + (NoArg (upd (\d -> d { useErrorLinks = Auto }))) + , make_ord_flag defFlag "fprint-error-index-links=always" + (NoArg (upd (\d -> d { useErrorLinks = Always }))) + , make_ord_flag defFlag "fprint-error-index-links=never" + (NoArg (upd (\d -> d { useErrorLinks = Never }))) + + -- Suppress all that is suppressible in core dumps. + -- Except for uniques, as some simplifier phases introduce new variables that + -- have otherwise identical names. + , make_ord_flag defGhcFlag "dsuppress-all" + (NoArg $ do setGeneralFlag Opt_SuppressCoercions + setGeneralFlag Opt_SuppressCoercionTypes + setGeneralFlag Opt_SuppressVarKinds + setGeneralFlag Opt_SuppressModulePrefixes + setGeneralFlag Opt_SuppressTypeApplications + setGeneralFlag Opt_SuppressIdInfo + setGeneralFlag Opt_SuppressTicks + setGeneralFlag Opt_SuppressStgExts + setGeneralFlag Opt_SuppressStgReps + setGeneralFlag Opt_SuppressTypeSignatures + setGeneralFlag Opt_SuppressCoreSizes + setGeneralFlag Opt_SuppressTimestamps) + + ------ Debugging ---------------------------------------------------- + , make_ord_flag defGhcFlag "dstg-stats" + (NoArg (setGeneralFlag Opt_StgStats)) + + , make_ord_flag defGhcFlag "ddump-cmm" + (setDumpFlag Opt_D_dump_cmm) + , make_ord_flag defGhcFlag "ddump-cmm-from-stg" + (setDumpFlag Opt_D_dump_cmm_from_stg) + , make_ord_flag defGhcFlag "ddump-cmm-raw" + (setDumpFlag Opt_D_dump_cmm_raw) + , make_ord_flag defGhcFlag "ddump-cmm-verbose" + (setDumpFlag Opt_D_dump_cmm_verbose) + , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc" + (setDumpFlag Opt_D_dump_cmm_verbose_by_proc) + , make_ord_flag defGhcFlag "ddump-cmm-cfg" + (setDumpFlag Opt_D_dump_cmm_cfg) + , make_ord_flag defGhcFlag "ddump-cmm-cbe" + (setDumpFlag Opt_D_dump_cmm_cbe) + , make_ord_flag defGhcFlag "ddump-cmm-switch" + (setDumpFlag Opt_D_dump_cmm_switch) + , make_ord_flag defGhcFlag "ddump-cmm-proc" + (setDumpFlag Opt_D_dump_cmm_proc) + , make_ord_flag defGhcFlag "ddump-cmm-sp" + (setDumpFlag Opt_D_dump_cmm_sp) + , make_ord_flag defGhcFlag "ddump-cmm-sink" + (setDumpFlag Opt_D_dump_cmm_sink) + , make_ord_flag defGhcFlag "ddump-cmm-caf" + (setDumpFlag Opt_D_dump_cmm_caf) + , make_ord_flag defGhcFlag "ddump-cmm-procmap" + (setDumpFlag Opt_D_dump_cmm_procmap) + , make_ord_flag defGhcFlag "ddump-cmm-split" + (setDumpFlag Opt_D_dump_cmm_split) + , make_ord_flag defGhcFlag "ddump-cmm-info" + (setDumpFlag Opt_D_dump_cmm_info) + , make_ord_flag defGhcFlag "ddump-cmm-cps" + (setDumpFlag Opt_D_dump_cmm_cps) + , make_ord_flag defGhcFlag "ddump-cmm-opt" + (setDumpFlag Opt_D_dump_opt_cmm) + , make_ord_flag defGhcFlag "ddump-cmm-thread-sanitizer" + (setDumpFlag Opt_D_dump_cmm_thread_sanitizer) + , make_ord_flag defGhcFlag "ddump-cfg-weights" + (setDumpFlag Opt_D_dump_cfg_weights) + , make_ord_flag defGhcFlag "ddump-core-stats" + (setDumpFlag Opt_D_dump_core_stats) + , make_ord_flag defGhcFlag "ddump-asm" + (setDumpFlag Opt_D_dump_asm) + , make_ord_flag defGhcFlag "ddump-js" + (setDumpFlag Opt_D_dump_js) + , make_ord_flag defGhcFlag "ddump-asm-native" + (setDumpFlag Opt_D_dump_asm_native) + , make_ord_flag defGhcFlag "ddump-asm-liveness" + (setDumpFlag Opt_D_dump_asm_liveness) + , make_ord_flag defGhcFlag "ddump-asm-regalloc" + (setDumpFlag Opt_D_dump_asm_regalloc) + , make_ord_flag defGhcFlag "ddump-asm-conflicts" + (setDumpFlag Opt_D_dump_asm_conflicts) + , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages" + (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , make_ord_flag defGhcFlag "ddump-asm-stats" + (setDumpFlag Opt_D_dump_asm_stats) + , make_ord_flag defGhcFlag "ddump-llvm" + (NoArg $ setDumpFlag' Opt_D_dump_llvm) + , make_ord_flag defGhcFlag "ddump-c-backend" + (NoArg $ setDumpFlag' Opt_D_dump_c_backend) + , make_ord_flag defGhcFlag "ddump-deriv" + (setDumpFlag Opt_D_dump_deriv) + , make_ord_flag defGhcFlag "ddump-ds" + (setDumpFlag Opt_D_dump_ds) + , make_ord_flag defGhcFlag "ddump-ds-preopt" + (setDumpFlag Opt_D_dump_ds_preopt) + , make_ord_flag defGhcFlag "ddump-foreign" + (setDumpFlag Opt_D_dump_foreign) + , make_ord_flag defGhcFlag "ddump-inlinings" + (setDumpFlag Opt_D_dump_inlinings) + , make_ord_flag defGhcFlag "ddump-verbose-inlinings" + (setDumpFlag Opt_D_dump_verbose_inlinings) + , make_ord_flag defGhcFlag "ddump-rule-firings" + (setDumpFlag Opt_D_dump_rule_firings) + , make_ord_flag defGhcFlag "ddump-rule-rewrites" + (setDumpFlag Opt_D_dump_rule_rewrites) + , make_ord_flag defGhcFlag "ddump-simpl-trace" + (setDumpFlag Opt_D_dump_simpl_trace) + , make_ord_flag defGhcFlag "ddump-occur-anal" + (setDumpFlag Opt_D_dump_occur_anal) + , make_ord_flag defGhcFlag "ddump-parsed" + (setDumpFlag Opt_D_dump_parsed) + , make_ord_flag defGhcFlag "ddump-parsed-ast" + (setDumpFlag Opt_D_dump_parsed_ast) + , make_ord_flag defGhcFlag "dkeep-comments" + (NoArg (setGeneralFlag Opt_KeepRawTokenStream)) + , make_ord_flag defGhcFlag "ddump-rn" + (setDumpFlag Opt_D_dump_rn) + , make_ord_flag defGhcFlag "ddump-rn-ast" + (setDumpFlag Opt_D_dump_rn_ast) + , make_ord_flag defGhcFlag "ddump-simpl" + (setDumpFlag Opt_D_dump_simpl) + , make_ord_flag defGhcFlag "ddump-simpl-iterations" + (setDumpFlag Opt_D_dump_simpl_iterations) + , make_ord_flag defGhcFlag "ddump-spec" + (setDumpFlag Opt_D_dump_spec) + , make_ord_flag defGhcFlag "ddump-spec-constr" + (setDumpFlag Opt_D_dump_spec_constr) + , make_ord_flag defGhcFlag "ddump-prep" + (setDumpFlag Opt_D_dump_prep) + , make_ord_flag defGhcFlag "ddump-late-cc" + (setDumpFlag Opt_D_dump_late_cc) + , make_ord_flag defGhcFlag "ddump-stg-from-core" + (setDumpFlag Opt_D_dump_stg_from_core) + , make_ord_flag defGhcFlag "ddump-stg-unarised" + (setDumpFlag Opt_D_dump_stg_unarised) + , make_ord_flag defGhcFlag "ddump-stg-final" + (setDumpFlag Opt_D_dump_stg_final) + , make_ord_flag defGhcFlag "ddump-stg-cg" + (setDumpFlag Opt_D_dump_stg_cg) + , make_dep_flag defGhcFlag "ddump-stg" + (setDumpFlag Opt_D_dump_stg_from_core) + "Use `-ddump-stg-from-core` or `-ddump-stg-final` instead" + , make_ord_flag defGhcFlag "ddump-stg-tags" + (setDumpFlag Opt_D_dump_stg_tags) + , make_ord_flag defGhcFlag "ddump-stg-from-js-sinker" + (setDumpFlag Opt_D_dump_stg_from_js_sinker) + , make_ord_flag defGhcFlag "ddump-call-arity" + (setDumpFlag Opt_D_dump_call_arity) + , make_ord_flag defGhcFlag "ddump-exitify" + (setDumpFlag Opt_D_dump_exitify) + , make_dep_flag defGhcFlag "ddump-stranal" + (setDumpFlag Opt_D_dump_dmdanal) + "Use `-ddump-dmdanal` instead" + , make_dep_flag defGhcFlag "ddump-str-signatures" + (setDumpFlag Opt_D_dump_dmd_signatures) + "Use `-ddump-dmd-signatures` instead" + , make_ord_flag defGhcFlag "ddump-dmdanal" + (setDumpFlag Opt_D_dump_dmdanal) + , make_ord_flag defGhcFlag "ddump-dmd-signatures" + (setDumpFlag Opt_D_dump_dmd_signatures) + , make_ord_flag defGhcFlag "ddump-cpranal" + (setDumpFlag Opt_D_dump_cpranal) + , make_ord_flag defGhcFlag "ddump-cpr-signatures" + (setDumpFlag Opt_D_dump_cpr_signatures) + , make_ord_flag defGhcFlag "ddump-tc" + (setDumpFlag Opt_D_dump_tc) + , make_ord_flag defGhcFlag "ddump-tc-ast" + (setDumpFlag Opt_D_dump_tc_ast) + , make_ord_flag defGhcFlag "ddump-hie" + (setDumpFlag Opt_D_dump_hie) + , make_ord_flag defGhcFlag "ddump-types" + (setDumpFlag Opt_D_dump_types) + , make_ord_flag defGhcFlag "ddump-rules" + (setDumpFlag Opt_D_dump_rules) + , make_ord_flag defGhcFlag "ddump-cse" + (setDumpFlag Opt_D_dump_cse) + , make_ord_flag defGhcFlag "ddump-float-out" + (setDumpFlag Opt_D_dump_float_out) + , make_ord_flag defGhcFlag "ddump-full-laziness" + (setDumpFlag Opt_D_dump_float_out) + , make_ord_flag defGhcFlag "ddump-float-in" + (setDumpFlag Opt_D_dump_float_in) + , make_ord_flag defGhcFlag "ddump-liberate-case" + (setDumpFlag Opt_D_dump_liberate_case) + , make_ord_flag defGhcFlag "ddump-static-argument-transformation" + (setDumpFlag Opt_D_dump_static_argument_transformation) + , make_ord_flag defGhcFlag "ddump-worker-wrapper" + (setDumpFlag Opt_D_dump_worker_wrapper) + , make_ord_flag defGhcFlag "ddump-rn-trace" + (setDumpFlag Opt_D_dump_rn_trace) + , make_ord_flag defGhcFlag "ddump-if-trace" + (setDumpFlag Opt_D_dump_if_trace) + , make_ord_flag defGhcFlag "ddump-cs-trace" + (setDumpFlag Opt_D_dump_cs_trace) + , make_ord_flag defGhcFlag "ddump-tc-trace" + (NoArg (do setDumpFlag' Opt_D_dump_tc_trace + setDumpFlag' Opt_D_dump_cs_trace)) + , make_ord_flag defGhcFlag "ddump-ec-trace" + (setDumpFlag Opt_D_dump_ec_trace) + , make_ord_flag defGhcFlag "ddump-splices" + (setDumpFlag Opt_D_dump_splices) + , make_ord_flag defGhcFlag "dth-dec-file" + (setDumpFlag Opt_D_th_dec_file) + + , make_ord_flag defGhcFlag "ddump-rn-stats" + (setDumpFlag Opt_D_dump_rn_stats) + , make_ord_flag defGhcFlag "ddump-opt-cmm" --old alias for cmm-opt + (setDumpFlag Opt_D_dump_opt_cmm) + , make_ord_flag defGhcFlag "ddump-simpl-stats" + (setDumpFlag Opt_D_dump_simpl_stats) + , make_ord_flag defGhcFlag "ddump-bcos" + (setDumpFlag Opt_D_dump_BCOs) + , make_ord_flag defGhcFlag "dsource-stats" + (setDumpFlag Opt_D_source_stats) + , make_ord_flag defGhcFlag "dverbose-core2core" + (NoArg $ setVerbosity (Just 2) >> setDumpFlag' Opt_D_verbose_core2core) + , make_ord_flag defGhcFlag "dverbose-stg2stg" + (setDumpFlag Opt_D_verbose_stg2stg) + , make_ord_flag defGhcFlag "ddump-hi" + (setDumpFlag Opt_D_dump_hi) + , make_ord_flag defGhcFlag "ddump-minimal-imports" + (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) + , make_ord_flag defGhcFlag "ddump-hpc" + (setDumpFlag Opt_D_dump_ticked) -- back compat + , make_ord_flag defGhcFlag "ddump-ticked" + (setDumpFlag Opt_D_dump_ticked) + , make_ord_flag defGhcFlag "ddump-mod-cycles" + (setDumpFlag Opt_D_dump_mod_cycles) + , make_ord_flag defGhcFlag "ddump-mod-map" + (setDumpFlag Opt_D_dump_mod_map) + , make_ord_flag defGhcFlag "ddump-timings" + (setDumpFlag Opt_D_dump_timings) + , make_ord_flag defGhcFlag "ddump-view-pattern-commoning" + (setDumpFlag Opt_D_dump_view_pattern_commoning) + , make_ord_flag defGhcFlag "ddump-to-file" + (NoArg (setGeneralFlag Opt_DumpToFile)) + , make_ord_flag defGhcFlag "ddump-hi-diffs" + (setDumpFlag Opt_D_dump_hi_diffs) + , make_ord_flag defGhcFlag "ddump-rtti" + (setDumpFlag Opt_D_dump_rtti) + , make_ord_flag defGhcFlag "dlint" + (NoArg enableDLint) + , make_ord_flag defGhcFlag "dcore-lint" + (NoArg (setGeneralFlag Opt_DoCoreLinting)) + , make_ord_flag defGhcFlag "dlinear-core-lint" + (NoArg (setGeneralFlag Opt_DoLinearCoreLinting)) + , make_ord_flag defGhcFlag "dstg-lint" + (NoArg (setGeneralFlag Opt_DoStgLinting)) + , make_ord_flag defGhcFlag "dcmm-lint" + (NoArg (setGeneralFlag Opt_DoCmmLinting)) + , make_ord_flag defGhcFlag "dasm-lint" + (NoArg (setGeneralFlag Opt_DoAsmLinting)) + , make_ord_flag defGhcFlag "dannot-lint" + (NoArg (setGeneralFlag Opt_DoAnnotationLinting)) + , make_ord_flag defGhcFlag "dtag-inference-checks" + (NoArg (setGeneralFlag Opt_DoTagInferenceChecks)) + , make_ord_flag defGhcFlag "dshow-passes" + (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) + , make_ord_flag defGhcFlag "dipe-stats" + (setDumpFlag Opt_D_ipe_stats) + , make_ord_flag defGhcFlag "dfaststring-stats" + (setDumpFlag Opt_D_faststring_stats) + , make_ord_flag defGhcFlag "dno-llvm-mangler" + (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag + , make_ord_flag defGhcFlag "dno-typeable-binds" + (NoArg (setGeneralFlag Opt_NoTypeableBinds)) + , make_ord_flag defGhcFlag "ddump-debug" + (setDumpFlag Opt_D_dump_debug) + , make_dep_flag defGhcFlag "ddump-json" + (setDumpFlag Opt_D_dump_json) + "Use `-fdiagnostics-as-json` instead" + , make_ord_flag defGhcFlag "dppr-debug" + (setDumpFlag Opt_D_ppr_debug) + , make_ord_flag defGhcFlag "ddebug-output" + (noArg (flip dopt_unset Opt_D_no_debug_output)) + , make_ord_flag defGhcFlag "dno-debug-output" + (setDumpFlag Opt_D_no_debug_output) + , make_ord_flag defGhcFlag "ddump-faststrings" + (setDumpFlag Opt_D_dump_faststrings) + + ------ Machine dependent (-m) stuff --------------------------- + + , make_ord_flag defGhcFlag "msse" (noArg (\d -> + d { sseVersion = Just SSE1 })) + , make_ord_flag defGhcFlag "msse2" (noArg (\d -> + d { sseVersion = Just SSE2 })) + , make_ord_flag defGhcFlag "msse3" (noArg (\d -> + d { sseVersion = Just SSE3 })) + , make_ord_flag defGhcFlag "mssse3" (noArg (\d -> + d { sseVersion = Just SSSE3 })) + , make_ord_flag defGhcFlag "msse4" (noArg (\d -> + d { sseVersion = Just SSE4 })) + , make_ord_flag defGhcFlag "msse4.2" (noArg (\d -> + d { sseVersion = Just SSE42 })) + , make_ord_flag defGhcFlag "mbmi" (noArg (\d -> + d { bmiVersion = Just BMI1 })) + , make_ord_flag defGhcFlag "mbmi2" (noArg (\d -> + d { bmiVersion = Just BMI2 })) + , make_ord_flag defGhcFlag "mavx" (noArg (\d -> d { avx = True })) + , make_ord_flag defGhcFlag "mavx2" (noArg (\d -> d { avx2 = True })) + , make_ord_flag defGhcFlag "mavx512cd" (noArg (\d -> + d { avx512cd = True })) + , make_ord_flag defGhcFlag "mavx512er" (noArg (\d -> + d { avx512er = True })) + , make_ord_flag defGhcFlag "mavx512f" (noArg (\d -> d { avx512f = True })) + , make_ord_flag defGhcFlag "mavx512pf" (noArg (\d -> + d { avx512pf = True })) + , make_ord_flag defGhcFlag "mfma" (noArg (\d -> d { fma = True })) + + ------ Plugin flags ------------------------------------------------ + , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption) + , make_ord_flag defGhcFlag "fplugin-trustworthy" + (NoArg (setGeneralFlag Opt_PluginTrustworthy)) + , make_ord_flag defGhcFlag "fplugin" (hasArg addPluginModuleName) + , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames) + , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption) + + , make_ord_flag defGhcFlag "fplugin-library" (hasArg addExternalPlugin) + + ------ Optimisation flags ------------------------------------------ + , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) + "Use -O0 instead" + , make_ord_flag defGhcFlag "O" (optIntSuffixM (\mb_n -> + setOptLevel (mb_n `orElse` 1))) + -- If the number is missing, use 1 + + , make_ord_flag defFlag "fbinary-blob-threshold" + (intSuffix (\n d -> d { binBlobThreshold = case fromIntegral n of + 0 -> Nothing + x -> Just x})) + , make_ord_flag defFlag "fmax-relevant-binds" + (intSuffix (\n d -> d { maxRelevantBinds = Just n })) + , make_ord_flag defFlag "fno-max-relevant-binds" + (noArg (\d -> d { maxRelevantBinds = Nothing })) + + , make_ord_flag defFlag "fmax-valid-hole-fits" + (intSuffix (\n d -> d { maxValidHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-valid-hole-fits" + (noArg (\d -> d { maxValidHoleFits = Nothing })) + , make_ord_flag defFlag "fmax-refinement-hole-fits" + (intSuffix (\n d -> d { maxRefHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-refinement-hole-fits" + (noArg (\d -> d { maxRefHoleFits = Nothing })) + , make_ord_flag defFlag "frefinement-level-hole-fits" + (intSuffix (\n d -> d { refLevelHoleFits = Just n })) + , make_ord_flag defFlag "fno-refinement-level-hole-fits" + (noArg (\d -> d { refLevelHoleFits = Nothing })) + + , make_ord_flag defFlag "fwrite-if-compression" + (intSuffix (\n d -> d { ifCompression = n })) + + , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs" + (noArg id) + "vectors registers are now passed in registers by default." + , make_ord_flag defFlag "fmax-uncovered-patterns" + (intSuffix (\n d -> d { maxUncoveredPatterns = n })) + , make_ord_flag defFlag "fmax-pmcheck-models" + (intSuffix (\n d -> d { maxPmCheckModels = n })) + , make_ord_flag defFlag "fsimplifier-phases" + (intSuffix (\n d -> d { simplPhases = n })) + , make_ord_flag defFlag "fmax-simplifier-iterations" + (intSuffix (\n d -> d { maxSimplIterations = n })) + , (Deprecated, defFlag "fmax-pmcheck-iterations" + (intSuffixM (\_ d -> + do { deprecate $ "use -fmax-pmcheck-models instead" + ; return d }))) + , make_ord_flag defFlag "fsimpl-tick-factor" + (intSuffix (\n d -> d { simplTickFactor = n })) + , make_ord_flag defFlag "fdmd-unbox-width" + (intSuffix (\n d -> d { dmdUnboxWidth = n })) + , make_ord_flag defFlag "fspec-constr-threshold" + (intSuffix (\n d -> d { specConstrThreshold = Just n })) + , make_ord_flag defFlag "fno-spec-constr-threshold" + (noArg (\d -> d { specConstrThreshold = Nothing })) + , make_ord_flag defFlag "fspec-constr-count" + (intSuffix (\n d -> d { specConstrCount = Just n })) + , make_ord_flag defFlag "fno-spec-constr-count" + (noArg (\d -> d { specConstrCount = Nothing })) + , make_ord_flag defFlag "fspec-constr-recursive" + (intSuffix (\n d -> d { specConstrRecursive = n })) + , make_ord_flag defFlag "fliberate-case-threshold" + (intSuffix (\n d -> d { liberateCaseThreshold = Just n })) + , make_ord_flag defFlag "fno-liberate-case-threshold" + (noArg (\d -> d { liberateCaseThreshold = Nothing })) + , make_ord_flag defFlag "drule-check" + (sepArg (\s d -> d { ruleCheck = Just s })) + , make_ord_flag defFlag "dinline-check" + (sepArg (\s d -> d { unfoldingOpts = updateReportPrefix (Just s) (unfoldingOpts d)})) + , make_ord_flag defFlag "freduction-depth" + (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n })) + , make_ord_flag defFlag "fconstraint-solver-iterations" + (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n })) + , make_ord_flag defFlag "fgivens-expansion-fuel" + (intSuffix (\n d -> d { givensFuel = n })) + , make_ord_flag defFlag "fwanteds-expansion-fuel" + (intSuffix (\n d -> d { wantedsFuel = n })) + , make_ord_flag defFlag "fqcs-expansion-fuel" + (intSuffix (\n d -> d { qcsFuel = n })) + , (Deprecated, defFlag "fcontext-stack" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , (Deprecated, defFlag "ftype-function-depth" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , make_ord_flag defFlag "fstrictness-before" + (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d })) + , make_ord_flag defFlag "ffloat-lam-args" + (intSuffix (\n d -> d { floatLamArgs = Just n })) + , make_ord_flag defFlag "ffloat-all-lams" + (noArg (\d -> d { floatLamArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args" + (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args-any" + (noArg (\d -> d { liftLamsRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args" + (intSuffix (\n d -> d { liftLamsNonRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any" + (noArg (\d -> d { liftLamsNonRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = True })) + , make_ord_flag defFlag "fno-stg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = False })) + , make_ord_flag defFlag "fproc-alignment" + (intSuffix (\n d -> d { cmmProcAlignment = Just n })) + , make_ord_flag defFlag "fblock-layout-weights" + (HasArg (\s -> + upd (\d -> d { cfgWeights = + parseWeights s (cfgWeights d)}))) + , make_ord_flag defFlag "fhistory-size" + (intSuffix (\n d -> d { historySize = n })) + + , make_ord_flag defFlag "funfolding-creation-threshold" + (intSuffix (\n d -> d { unfoldingOpts = updateCreationThreshold n (unfoldingOpts d)})) + , make_ord_flag defFlag "funfolding-use-threshold" + (intSuffix (\n d -> d { unfoldingOpts = updateUseThreshold n (unfoldingOpts d)})) + , make_ord_flag defFlag "funfolding-fun-discount" + (intSuffix (\n d -> d { unfoldingOpts = updateFunAppDiscount n (unfoldingOpts d)})) + , make_ord_flag defFlag "funfolding-dict-discount" + (intSuffix (\n d -> d { unfoldingOpts = updateDictDiscount n (unfoldingOpts d)})) + + , make_ord_flag defFlag "funfolding-case-threshold" + (intSuffix (\n d -> d { unfoldingOpts = updateCaseThreshold n (unfoldingOpts d)})) + , make_ord_flag defFlag "funfolding-case-scaling" + (intSuffix (\n d -> d { unfoldingOpts = updateCaseScaling n (unfoldingOpts d)})) + + , make_dep_flag defFlag "funfolding-keeness-factor" + (floatSuffix (\_ d -> d)) + "-funfolding-keeness-factor is no longer respected as of GHC 9.0" + + , make_ord_flag defFlag "fmax-worker-args" + (intSuffix (\n d -> d {maxWorkerArgs = n})) + , make_ord_flag defFlag "fmax-forced-spec-args" + (intSuffix (\n d -> d {maxForcedSpecArgs = n})) + , make_ord_flag defGhciFlag "fghci-hist-size" + (intSuffix (\n d -> d {ghciHistSize = n})) + + -- wasm ghci browser mode + , make_ord_flag defGhciFlag "fghci-browser-host" + $ hasArg $ \f d -> d { ghciBrowserHost = f } + , make_ord_flag defGhciFlag "fghci-browser-port" + $ intSuffix $ \n d -> d { ghciBrowserPort = n } + , make_ord_flag defGhciFlag "fghci-browser-puppeteer-launch-opts" + $ hasArg $ \f d -> d { ghciBrowserPuppeteerLaunchOpts = Just f } + , make_ord_flag defGhciFlag "fghci-browser-playwright-browser-type" + $ hasArg $ \f d -> d { ghciBrowserPlaywrightBrowserType = Just f } + , make_ord_flag defGhciFlag "fghci-browser-playwright-launch-opts" + $ hasArg $ \f d -> d { ghciBrowserPlaywrightLaunchOpts = Just f } + + , make_ord_flag defGhcFlag "fmax-inline-alloc-size" + (intSuffix (\n d -> d { maxInlineAllocSize = n })) + , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns" + (intSuffix (\n d -> d { maxInlineMemcpyInsns = n })) + , make_ord_flag defGhcFlag "fmax-inline-memset-insns" + (intSuffix (\n d -> d { maxInlineMemsetInsns = n })) + , make_ord_flag defGhcFlag "dinitial-unique" + (word64Suffix (\n d -> d { initialUnique = n })) + , make_ord_flag defGhcFlag "dunique-increment" + (intSuffix (\n d -> d { uniqueIncrement = n })) + + ------ Profiling ---------------------------------------------------- + + -- OLD profiling flags + , make_dep_flag defGhcFlag "auto-all" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + "Use -fprof-auto instead" + , make_dep_flag defGhcFlag "no-auto-all" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "auto" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + "Use -fprof-auto-exported instead" + , make_dep_flag defGhcFlag "no-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "caf-all" + (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fprof-cafs instead" + , make_dep_flag defGhcFlag "no-caf-all" + (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fno-prof-cafs instead" + + -- NEW profiling flags + , make_ord_flag defGhcFlag "fprof-auto" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + , make_ord_flag defGhcFlag "fprof-auto-top" + (noArg (\d -> d { profAuto = ProfAutoTop } )) + , make_ord_flag defGhcFlag "fprof-auto-exported" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + , make_ord_flag defGhcFlag "fprof-auto-calls" + (noArg (\d -> d { profAuto = ProfAutoCalls } )) + , make_ord_flag defGhcFlag "fno-prof-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + + -- Caller-CC + , make_ord_flag defGhcFlag "fprof-callers" + (HasArg setCallerCcFilters) + ------ Compiler flags ----------------------------------------------- + + , make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend ncgBackend)) + , make_ord_flag defGhcFlag "fvia-c" (NoArg + (deprecate $ "The -fvia-c flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fvia-C" (NoArg + (deprecate $ "The -fvia-C flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjBackend llvmBackend)) + + , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> + d { ghcLink=NoLink }) >> setBackend noBackend)) + , make_ord_flag defFlag "fbyte-code" + (noArgM $ \dflags -> do + setBackend interpreterBackend + pure $ flip gopt_unset Opt_ByteCodeAndObjectCode (gopt_set dflags Opt_ByteCode)) + , make_ord_flag defFlag "fobject-code" $ noArgM $ \dflags -> do + setBackend $ platformDefaultBackend (targetPlatform dflags) + dflags' <- liftEwM getCmdLineState + pure $ gopt_unset dflags' Opt_ByteCodeAndObjectCode + + , make_dep_flag defFlag "fglasgow-exts" + (NoArg enableGlasgowExts) "Use individual extensions instead" + , make_dep_flag defFlag "fno-glasgow-exts" + (NoArg disableGlasgowExts) "Use individual extensions instead" + + ------ Safe Haskell flags ------------------------------------------- + , make_ord_flag defFlag "fpackage-trust" (NoArg setPackageTrust) + , make_ord_flag defFlag "fno-safe-infer" (noArg (\d -> + d { safeInfer = False })) + , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore)) + + ------ position independent flags ---------------------------------- + , make_ord_flag defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIE)) + , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIE)) + + ------ Debugging flags ---------------------------------------------- + , make_ord_flag defGhcFlag "g" (OptIntSuffix setDebugLevel) + ] + ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOff "no-" unSetGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOn "d" setGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOff "dno-" unSetGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOn "f" setGeneralFlag ) fFlagsDeps + ++ map (mkFlag turnOff "fno-" unSetGeneralFlag ) fFlagsDeps + ++ + + ------ Warning flags ------------------------------------------------- + [ make_ord_flag defFlag "W" (NoArg (setWarningGroup W_extra)) + , make_ord_flag defFlag "Werror" + (NoArg (do { setGeneralFlag Opt_WarnIsError + ; setFatalWarningGroup W_everything })) + , make_ord_flag defFlag "Wwarn" + (NoArg (do { unSetGeneralFlag Opt_WarnIsError + ; unSetFatalWarningGroup W_everything })) + -- Opt_WarnIsError is still needed to pass -Werror + -- to CPP; see runCpp in SysTools + , make_dep_flag defFlag "Wnot" (NoArg (unSetWarningGroup W_everything)) + "Use -w or -Wno-everything instead" + , make_ord_flag defFlag "w" (NoArg (unSetWarningGroup W_everything)) + ] + + -- New-style uniform warning sets + -- + -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything + ++ warningControls setWarningGroup unSetWarningGroup setWErrorWarningGroup unSetFatalWarningGroup warningGroupsDeps + ++ warningControls setWarningFlag unSetWarningFlag setWErrorFlag unSetFatalWarningFlag wWarningFlagsDeps + ++ warningControls setCustomWarningFlag unSetCustomWarningFlag setCustomWErrorFlag unSetCustomFatalWarningFlag + [(NotDeprecated, FlagSpec "warnings-deprecations" defaultWarningCategory nop AllModes)] + -- See Note [Warning categories] in GHC.Unit.Module.Warnings. + + ++ [ (NotDeprecated, customOrUnrecognisedWarning "Wno-" unSetCustomWarningFlag) + , (NotDeprecated, customOrUnrecognisedWarning "Werror=" setCustomWErrorFlag) + , (NotDeprecated, customOrUnrecognisedWarning "Wwarn=" unSetCustomFatalWarningFlag) + , (NotDeprecated, customOrUnrecognisedWarning "Wno-error=" unSetCustomFatalWarningFlag) + , (NotDeprecated, customOrUnrecognisedWarning "W" setCustomWarningFlag) + , (Deprecated, customOrUnrecognisedWarning "fwarn-" setCustomWarningFlag) + , (Deprecated, customOrUnrecognisedWarning "fno-warn-" unSetCustomWarningFlag) + ] + + ------ JavaScript flags ----------------------------------------------- + ++ [ make_ord_flag defFlag "ddisable-js-minifier" (NoArg (setGeneralFlag Opt_DisableJsMinifier)) + , make_ord_flag defFlag "ddisable-js-c-sources" (NoArg (setGeneralFlag Opt_DisableJsCsources)) + ] + + ------ Language flags ------------------------------------------------- + ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlagsDeps + ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlagsDeps + ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlagsDeps + ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlagsDeps + ++ map (mkFlag turnOn "X" setLanguage ) languageFlagsDeps + ++ map (mkFlag turnOn "X" setSafeHaskell ) safeHaskellFlagsDeps + +-- | Warnings have both new-style flags to control their state (@-W@, @-Wno-@, +-- @-Werror=@, @-Wwarn=@) and old-style flags (@-fwarn-@, @-fno-warn-@). We +-- define these uniformly for individual warning flags and groups of warnings. +warningControls :: (warn_flag -> DynP ()) -- ^ Set the warning + -> (warn_flag -> DynP ()) -- ^ Unset the warning + -> (warn_flag -> DynP ()) -- ^ Make the warning an error + -> (warn_flag -> DynP ()) -- ^ Clear the error status + -> [(Deprecation, FlagSpec warn_flag)] + -> [(Deprecation, Flag (CmdLineP DynFlags))] +warningControls set unset set_werror unset_fatal xs = + map (mkFlag turnOn "W" set ) xs + ++ map (mkFlag turnOff "Wno-" unset ) xs + ++ map (mkFlag turnOn "Werror=" set_werror ) xs + ++ map (mkFlag turnOn "Wwarn=" unset_fatal ) xs + ++ map (mkFlag turnOn "Wno-error=" unset_fatal ) xs + ++ map (mkFlag turnOn "fwarn-" set . hideFlag) xs + ++ map (mkFlag turnOff "fno-warn-" unset . hideFlag) xs + +-- | This is where we handle unrecognised warning flags. If the flag is valid as +-- an extended warning category, we call the supplied action. Otherwise, issue a +-- warning if -Wunrecognised-warning-flags is set. See #11429 for context. +-- See Note [Warning categories] in GHC.Unit.Module.Warnings. +customOrUnrecognisedWarning :: String -> (WarningCategory -> DynP ()) -> Flag (CmdLineP DynFlags) +customOrUnrecognisedWarning prefix custom = defHiddenFlag prefix (Prefix action) + where + action :: String -> DynP () + action flag + | validWarningCategory cat = custom cat + | otherwise = unrecognised flag + where + cat = mkWarningCategory (mkFastString flag) + + unrecognised flag = do + -- #23402 and #12056 + -- for unrecognised flags we consider current dynflags, not the final one. + -- But if final state says to not report unrecognised flags, they won't anyway. + f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState + when f $ addFlagWarn (DriverUnrecognisedFlag (prefix ++ flag)) + +-- See Note [Supporting CLI completion] +package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +package_flags_deps = [ + ------- Packages ---------------------------------------------------- + make_ord_flag defFlag "package-db" + (HasArg (addPkgDbRef . PkgDbPath)) + , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb) + , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb) + , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb) + , make_ord_flag defFlag "global-package-db" + (NoArg (addPkgDbRef GlobalPkgDb)) + , make_ord_flag defFlag "user-package-db" + (NoArg (addPkgDbRef UserPkgDb)) + -- backwards compat with GHC<=7.4 : + , make_dep_flag defFlag "package-conf" + (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead" + , make_dep_flag defFlag "no-user-package-conf" + (NoArg removeUserPkgDb) "Use -no-user-package-db instead" + , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> + upd (setUnitId name)) + , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) + + , make_ord_flag defGhcFlag "working-dir" (hasArg setWorkingDirectory) + , make_ord_flag defGhcFlag "this-package-name" (hasArg setPackageName) + , make_ord_flag defGhcFlag "hidden-module" (HasArg addHiddenModule) + , make_ord_flag defGhcFlag "reexported-module" (HasArg addReexportedModule) + + , make_ord_flag defFlag "package" (HasArg exposePackage) + , make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId) + , make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage) + , make_ord_flag defFlag "package-id" (HasArg exposePackageId) + , make_ord_flag defFlag "hide-package" (HasArg hidePackage) + , make_ord_flag defFlag "hide-all-packages" + (NoArg (setGeneralFlag Opt_HideAllPackages)) + , make_ord_flag defFlag "hide-all-plugin-packages" + (NoArg (setGeneralFlag Opt_HideAllPluginPackages)) + , make_ord_flag defFlag "package-env" (HasArg setPackageEnv) + , make_ord_flag defFlag "ignore-package" (HasArg ignorePackage) + , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead" + , make_ord_flag defFlag "distrust-all-packages" + (NoArg (setGeneralFlag Opt_DistrustAllPackages)) + , make_ord_flag defFlag "trust" (HasArg trustPackage) + , make_ord_flag defFlag "distrust" (HasArg distrustPackage) + , make_ord_flag defFlag "base-unit-id" (HasArg setBaseUnitId) + ] + where + setPackageEnv env = upd $ \s -> s { packageEnv = Just env } + +-- | Make a list of flags for shell completion. +-- Filter all available flags into two groups, for interactive GHC vs all other. +flagsForCompletion :: Bool -> [String] +flagsForCompletion isInteractive + = [ '-':flagName flag + | flag <- flagsAll + , modeFilter (flagGhcMode flag) + ] + where + modeFilter AllModes = True + modeFilter OnlyGhci = isInteractive + modeFilter OnlyGhc = not isInteractive + modeFilter HiddenFlag = False + +data FlagSpec flag + = FlagSpec + { flagSpecName :: String -- ^ Flag in string form + , flagSpecFlag :: flag -- ^ Flag in internal form + , flagSpecAction :: (TurnOnFlag -> DynP ()) + -- ^ Extra action to run when the flag is found + -- Typically, emit a warning or error + , flagSpecGhcMode :: GhcFlagMode + -- ^ In which ghc mode the flag has effect + } + +-- | Define a new flag. +flagSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagSpec name flag = flagSpec' name flag nop + +-- | Define a new flag with an effect. +flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes) + +-- | Define a warning flag. +warnSpec :: WarningFlag -> [(Deprecation, FlagSpec WarningFlag)] +warnSpec flag = warnSpec' flag nop + +-- | Define a warning flag with an effect. +warnSpec' :: WarningFlag -> (TurnOnFlag -> DynP ()) + -> [(Deprecation, FlagSpec WarningFlag)] +warnSpec' flag act = [ (NotDeprecated, FlagSpec name flag act AllModes) + | name <- NE.toList (warnFlagNames flag) + ] + +-- | Define a new deprecated flag with an effect. +depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String + -> (Deprecation, FlagSpec flag) +depFlagSpecOp name flag act dep = + (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep))) + +-- | Define a new deprecated flag. +depFlagSpec :: String -> flag -> String + -> (Deprecation, FlagSpec flag) +depFlagSpec name flag dep = depFlagSpecOp name flag nop dep + +-- | Define a deprecated warning flag. +depWarnSpec :: WarningFlag -> String + -> [(Deprecation, FlagSpec WarningFlag)] +depWarnSpec flag dep = [ depFlagSpecOp name flag nop dep + | name <- NE.toList (warnFlagNames flag) + ] + +-- | Define a deprecated warning name substituted by another. +subWarnSpec :: String -> WarningFlag -> String + -> [(Deprecation, FlagSpec WarningFlag)] +subWarnSpec oldname flag dep = [ depFlagSpecOp oldname flag nop dep ] + + +-- | Define a new deprecated flag with an effect where the deprecation message +-- depends on the flag value +depFlagSpecOp' :: String + -> flag + -> (TurnOnFlag -> DynP ()) + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpecOp' name flag act dep = + (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f)) + AllModes) + +-- | Define a new deprecated flag where the deprecation message +-- depends on the flag value +depFlagSpec' :: String + -> flag + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep + +-- | Define a new flag for GHCi. +flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagGhciSpec name flag = flagGhciSpec' name flag nop + +-- | Define a new flag for GHCi with an effect. +flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci) + +-- | Define a new flag invisible to CLI completion. +flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagHiddenSpec name flag = flagHiddenSpec' name flag nop + +-- | Define a new flag invisible to CLI completion with an effect. +flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act + HiddenFlag) + +-- | Hide a 'FlagSpec' from being displayed in @--show-options@. +-- +-- This is for example useful for flags that are obsolete, but should not +-- (yet) be deprecated for compatibility reasons. +hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a) +hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag }) + +mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on + -> String -- ^ The flag prefix + -> (flag -> DynP ()) -- ^ What to do when the flag is found + -> (Deprecation, FlagSpec flag) -- ^ Specification of + -- this particular flag + -> (Deprecation, Flag (CmdLineP DynFlags)) +mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode)) + = (dep, + Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) + +deprecate :: String -> DynP () +deprecate s = do + arg <- getArg + addFlagWarn (DriverDeprecatedFlag arg s) + +deprecatedForExtension :: String -> TurnOnFlag -> String +deprecatedForExtension lang turn_on + = "use -X" ++ flag ++ + " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead" + where + flag | turn_on = lang + | otherwise = "No" ++ lang + +deprecatedForExtensions :: [String] -> TurnOnFlag -> String +deprecatedForExtensions [] _ = panic "new extension has not been specified" +deprecatedForExtensions [lang] turn_on = deprecatedForExtension lang turn_on +deprecatedForExtensions langExts turn_on + = "use " ++ xExt flags ++ " instead" + where + flags | turn_on = langExts + | otherwise = ("No" ++) <$> langExts + + xExt fls = intercalate " and " $ (\flag -> "-X" ++ flag) <$> fls + +useInstead :: String -> String -> TurnOnFlag -> String +useInstead prefix flag turn_on + = "Use " ++ prefix ++ no ++ flag ++ " instead" + where + no = if turn_on then "" else "no-" + +nop :: TurnOnFlag -> DynP () +nop _ = return () + +-- | Find the 'FlagSpec' for a 'WarningFlag'. +flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag) +flagSpecOf = flip Map.lookup wWarningFlagMap + +wWarningFlagMap :: Map.Map WarningFlag (FlagSpec WarningFlag) +wWarningFlagMap = Map.fromListWith (\_ x -> x) $ map (flagSpecFlag &&& id) wWarningFlags + +-- | These @-W\@ flags can all be reversed with @-Wno-\@ +wWarningFlags :: [FlagSpec WarningFlag] +wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) + +wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)] +wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] + Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x + Opt_WarnAmbiguousFields -> warnSpec x + Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect" + Opt_WarnCPPUndef -> warnSpec x + Opt_WarnBadlyLevelledTypes -> + warnSpec x ++ + subWarnSpec "badly-staged-types" x "it is renamed to -Wbadly-levelled-types" + Opt_WarnUnbangedStrictPatterns -> warnSpec x + Opt_WarnDeferredTypeErrors -> warnSpec x + Opt_WarnDeferredOutOfScopeVariables -> warnSpec x + Opt_WarnDeprecatedFlags -> warnSpec x + Opt_WarnDerivingDefaults -> warnSpec x + Opt_WarnDerivingTypeable -> warnSpec x + Opt_WarnDodgyExports -> warnSpec x + Opt_WarnDodgyForeignImports -> warnSpec x + Opt_WarnDodgyImports -> warnSpec x + Opt_WarnEmptyEnumerations -> warnSpec x + Opt_WarnDuplicateConstraints + -> subWarnSpec "duplicate-constraints" x "it is subsumed by -Wredundant-constraints" + Opt_WarnRedundantConstraints -> warnSpec x + Opt_WarnDuplicateExports -> warnSpec x + Opt_WarnHiShadows + -> depWarnSpec x "it is not used, and was never implemented" + Opt_WarnInaccessibleCode -> warnSpec x + Opt_WarnImplicitPrelude -> warnSpec x + Opt_WarnImplicitKindVars -> depWarnSpec x "it is now an error" + Opt_WarnIncompletePatterns -> warnSpec x + Opt_WarnIncompletePatternsRecUpd -> warnSpec x + Opt_WarnIncompleteUniPatterns -> warnSpec x + Opt_WarnInconsistentFlags -> warnSpec x + Opt_WarnInlineRuleShadowing -> warnSpec x + Opt_WarnIdentities -> warnSpec x + Opt_WarnLoopySuperclassSolve -> depWarnSpec x "it is now an error" + Opt_WarnMissingFields -> warnSpec x + Opt_WarnMissingImportList -> warnSpec x + Opt_WarnMissingExportList -> warnSpec x + Opt_WarnMissingLocalSignatures + -> subWarnSpec "missing-local-sigs" x + "it is replaced by -Wmissing-local-signatures" + ++ warnSpec x + Opt_WarnMissingMethods -> warnSpec x + Opt_WarnMissingMonadFailInstances + -> depWarnSpec x "fail is no longer a method of Monad" + Opt_WarnSemigroup -> depWarnSpec x "Semigroup is now a superclass of Monoid" + Opt_WarnMissingSignatures -> warnSpec x + Opt_WarnMissingKindSignatures -> warnSpec x + Opt_WarnMissingPolyKindSignatures -> warnSpec x + Opt_WarnMissingExportedSignatures + -> subWarnSpec "missing-exported-sigs" x + "it is replaced by -Wmissing-exported-signatures" + ++ warnSpec x + Opt_WarnMonomorphism -> warnSpec x + Opt_WarnNameShadowing -> warnSpec x + Opt_WarnNonCanonicalMonadInstances -> warnSpec x + Opt_WarnNonCanonicalMonadFailInstances + -> depWarnSpec x "fail is no longer a method of Monad" + Opt_WarnNonCanonicalMonoidInstances -> warnSpec x + Opt_WarnOrphans -> warnSpec x + Opt_WarnOverflowedLiterals -> warnSpec x + Opt_WarnOverlappingPatterns -> warnSpec x + Opt_WarnMissedSpecs -> warnSpec x + Opt_WarnAllMissedSpecs -> warnSpec x + Opt_WarnSafe -> warnSpec' x setWarnSafe + Opt_WarnTrustworthySafe -> warnSpec x + Opt_WarnInferredSafeImports -> warnSpec x + Opt_WarnMissingSafeHaskellMode -> warnSpec x + Opt_WarnTabs -> warnSpec x + Opt_WarnTypeDefaults -> warnSpec x + Opt_WarnTypedHoles -> warnSpec x + Opt_WarnPartialTypeSignatures -> warnSpec x + Opt_WarnUnrecognisedPragmas -> warnSpec x + Opt_WarnMisplacedPragmas -> warnSpec x + Opt_WarnUnsafe -> warnSpec' x setWarnUnsafe + Opt_WarnUnsupportedCallingConventions -> warnSpec x + Opt_WarnUnsupportedLlvmVersion -> warnSpec x + Opt_WarnMissedExtraSharedLib -> warnSpec x + Opt_WarnUntickedPromotedConstructors -> warnSpec x + Opt_WarnUnusedDoBind -> warnSpec x + Opt_WarnUnusedForalls -> warnSpec x + Opt_WarnUnusedImports -> warnSpec x + Opt_WarnUnusedLocalBinds -> warnSpec x + Opt_WarnUnusedMatches -> warnSpec x + Opt_WarnUnusedPatternBinds -> warnSpec x + Opt_WarnUnusedTopBinds -> warnSpec x + Opt_WarnUnusedTypePatterns -> warnSpec x + Opt_WarnUnusedRecordWildcards -> warnSpec x + Opt_WarnRedundantBangPatterns -> warnSpec x + Opt_WarnRedundantRecordWildcards -> warnSpec x + Opt_WarnRedundantStrictnessFlags -> warnSpec x + Opt_WarnWrongDoBind -> warnSpec x + Opt_WarnMissingPatternSynonymSignatures -> warnSpec x + Opt_WarnMissingDerivingStrategies -> warnSpec x + Opt_WarnSimplifiableClassConstraints -> warnSpec x + Opt_WarnMissingHomeModules -> warnSpec x + Opt_WarnUnrecognisedWarningFlags -> warnSpec x + Opt_WarnStarBinder -> warnSpec x + Opt_WarnStarIsType -> warnSpec x + Opt_WarnSpaceAfterBang + -> depWarnSpec x "bang patterns can no longer be written with a space" + Opt_WarnPartialFields -> warnSpec x + Opt_WarnPrepositiveQualifiedModule -> warnSpec x + Opt_WarnUnusedPackages -> warnSpec x + Opt_WarnCompatUnqualifiedImports -> + depWarnSpec x "This warning no longer does anything; see GHC #24904" + Opt_WarnInvalidHaddock -> warnSpec x + Opt_WarnOperatorWhitespaceExtConflict -> warnSpec x + Opt_WarnOperatorWhitespace -> warnSpec x + Opt_WarnImplicitLift -> warnSpec x + Opt_WarnMissingExportedPatternSynonymSignatures -> warnSpec x + Opt_WarnForallIdentifier + -> depWarnSpec x "forall is no longer a valid identifier" + Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x + Opt_WarnGADTMonoLocalBinds -> warnSpec x + Opt_WarnTypeEqualityOutOfScope -> warnSpec x + Opt_WarnTypeEqualityRequiresOperators -> warnSpec x + Opt_WarnTermVariableCapture -> warnSpec x + Opt_WarnMissingRoleAnnotations -> warnSpec x + Opt_WarnImplicitRhsQuantification -> warnSpec x + Opt_WarnIncompleteExportWarnings -> warnSpec x + Opt_WarnIncompleteRecordSelectors -> warnSpec x + Opt_WarnDataKindsTC + -> depWarnSpec x "DataKinds violations are now always an error" + Opt_WarnDefaultedExceptionContext -> warnSpec x + Opt_WarnViewPatternSignatures -> warnSpec x + Opt_WarnUselessSpecialisations -> warnSpec x + Opt_WarnDeprecatedPragmas -> warnSpec x + Opt_WarnRuleLhsEqualities -> warnSpec x + Opt_WarnUnusableUnpackPragmas -> warnSpec x + Opt_WarnPatternNamespaceSpecifier -> warnSpec x + +warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] +warningGroupsDeps = map mk warningGroups + where + mk g = (NotDeprecated, FlagSpec (warningGroupName g) g nop AllModes) + +-- | These @-\@ flags can all be reversed with @-no-\@ +negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +negatableFlagsDeps = [ + flagGhciSpec "ignore-dot-ghci" Opt_IgnoreDotGhci ] + +-- | These @-d\@ flags can all be reversed with @-dno-\@ +dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +dFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, + depFlagSpec' "ppr-ticks" Opt_PprShowTicks + (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), + flagSpec "suppress-ticks" Opt_SuppressTicks, + depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts + (useInstead "-d" "suppress-stg-exts"), + flagSpec "suppress-stg-exts" Opt_SuppressStgExts, + flagSpec "suppress-stg-reps" Opt_SuppressStgReps, + flagSpec "suppress-coercions" Opt_SuppressCoercions, + flagSpec "suppress-coercion-types" Opt_SuppressCoercionTypes, + flagSpec "suppress-idinfo" Opt_SuppressIdInfo, + flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings, + flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, + flagSpec "suppress-timestamps" Opt_SuppressTimestamps, + flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, + flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, + flagSpec "suppress-uniques" Opt_SuppressUniques, + flagSpec "suppress-var-kinds" Opt_SuppressVarKinds, + flagSpec "suppress-core-sizes" Opt_SuppressCoreSizes + ] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fFlags :: [FlagSpec GeneralFlag] +fFlags = map snd fFlagsDeps + +fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +fFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "asm-shortcutting" Opt_AsmShortcutting, + flagGhciSpec "break-on-error" Opt_BreakOnError, + flagGhciSpec "break-on-exception" Opt_BreakOnException, + flagSpec "building-cabal-package" Opt_BuildingCabalPackage, + flagSpec "call-arity" Opt_CallArity, + flagSpec "exitification" Opt_Exitification, + flagSpec "case-merge" Opt_CaseMerge, + flagSpec "case-folding" Opt_CaseFolding, + flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, + flagSpec "cmm-sink" Opt_CmmSink, + flagSpec "cmm-static-pred" Opt_CmmStaticPred, + flagSpec "cse" Opt_CSE, + flagSpec "stg-cse" Opt_StgCSE, + flagSpec "stg-lift-lams" Opt_StgLiftLams, + flagSpec "cpr-anal" Opt_CprAnal, + flagSpec "defer-diagnostics" Opt_DeferDiagnostics, + flagSpec "defer-type-errors" Opt_DeferTypeErrors, + flagSpec "defer-typed-holes" Opt_DeferTypedHoles, + flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables, + flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret, + flagSpec "diagnostics-as-json" Opt_DiagnosticsAsJSON, + -- With-ways needs to be reversible hence why its made via flagSpec unlike + -- other debugging flags. + flagSpec "dump-with-ways" Opt_DumpWithWays, + flagSpec "dicts-cheap" Opt_DictsCheap, + flagSpec "dicts-strict" Opt_DictsStrict, + depFlagSpec "dmd-tx-dict-sel" + Opt_DmdTxDictSel "effect is now unconditionally enabled", + flagSpec "do-eta-reduction" Opt_DoEtaReduction, + flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, + flagSpec "do-clever-arg-eta-expansion" Opt_DoCleverArgEtaExpansion, -- See Note [Eta expansion of arguments in CorePrep] + flagSpec "eager-blackholing" Opt_EagerBlackHoling, + flagSpec "orig-thunk-info" Opt_OrigThunkInfo, + flagSpec "embed-manifest" Opt_EmbedManifest, + flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, + flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, + flagSpec "error-spans" Opt_ErrorSpans, + flagSpec "excess-precision" Opt_ExcessPrecision, + flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, + flagSpec "expose-overloaded-unfoldings" Opt_ExposeOverloadedUnfoldings, + flagSpec "keep-auto-rules" Opt_KeepAutoRules, + flagSpec "expose-internal-symbols" Opt_ExposeInternalSymbols, + flagSpec "external-dynamic-refs" Opt_ExternalDynamicRefs, + flagSpec "external-interpreter" Opt_ExternalInterpreter, + flagSpec "family-application-cache" Opt_FamAppCache, + flagSpec "float-in" Opt_FloatIn, + flagSpec "force-recomp" Opt_ForceRecomp, + flagSpec "ignore-optim-changes" Opt_IgnoreOptimChanges, + flagSpec "ignore-hpc-changes" Opt_IgnoreHpcChanges, + flagSpec "full-laziness" Opt_FullLaziness, + depFlagSpec' "fun-to-thunk" Opt_FunToThunk + (useInstead "-f" "full-laziness"), + flagSpec "local-float-out" Opt_LocalFloatOut, + flagSpec "local-float-out-top-level" Opt_LocalFloatOutTopLevel, + flagSpec "gen-manifest" Opt_GenManifest, + flagSpec "ghci-history" Opt_GhciHistory, + flagSpec "ghci-leak-check" Opt_GhciLeakCheck, + flagSpec "inter-module-far-jumps" Opt_InterModuleFarJumps, + flagSpec "validate-ide-info" Opt_ValidateHie, + flagGhciSpec "local-ghci-history" Opt_LocalGhciHistory, + flagGhciSpec "no-it" Opt_NoIt, + flagSpec "ghci-sandbox" Opt_GhciSandbox, + + -- wasm ghci browser mode + flagGhciSpec "ghci-browser" Opt_GhciBrowser, + flagGhciSpec "ghci-browser-redirect-wasi-console" Opt_GhciBrowserRedirectWasiConsole, + + -- load all targets on GHCi startup + flagGhciSpec "load-initial-targets" Opt_GhciDoLoadTargets, + + flagSpec "helpful-errors" Opt_HelpfulErrors, + flagSpec "hpc" Opt_Hpc, + flagSpec "ignore-asserts" Opt_IgnoreAsserts, + flagSpec "ignore-interface-pragmas" Opt_IgnoreInterfacePragmas, + flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, + flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, + flagSpec "keep-going" Opt_KeepGoing, + flagSpec "late-dmd-anal" Opt_LateDmdAnal, + flagSpec "late-specialise" Opt_LateSpecialise, + flagSpec "liberate-case" Opt_LiberateCase, + flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage, + flagSpec "loopification" Opt_Loopification, + flagSpec "block-layout-cfg" Opt_CfgBlocklayout, + flagSpec "block-layout-weightless" Opt_WeightlessBlocklayout, + flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas, + flagSpec "omit-yields" Opt_OmitYields, + flagSpec "optimal-applicative-do" Opt_OptimalApplicativeDo, + flagSpec "pedantic-bottoms" Opt_PedanticBottoms, + flagSpec "pre-inlining" Opt_SimplPreInlining, + flagGhciSpec "print-bind-contents" Opt_PrintBindContents, + flagGhciSpec "print-bind-result" Opt_PrintBindResult, + flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, + flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, + flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, + flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, + flagSpec "print-explicit-runtime-reps" Opt_PrintExplicitRuntimeReps, + flagSpec "print-equality-relations" Opt_PrintEqualityRelations, + flagSpec "print-axiom-incomps" Opt_PrintAxiomIncomps, + flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, + flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, + flagSpec "print-potential-instances" Opt_PrintPotentialInstances, + flagSpec "print-redundant-promotion-ticks" Opt_PrintRedundantPromotionTicks, + flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, + flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, + flagSpec "prof-count-entries" Opt_ProfCountEntries, + flagSpec "prof-late" Opt_ProfLateCcs, + flagSpec "prof-late-overloaded" Opt_ProfLateOverloadedCcs, + flagSpec "prof-late-overloaded-calls" Opt_ProfLateoverloadedCallsCCs, + flagSpec "prof-manual" Opt_ProfManualCcs, + flagSpec "prof-late-inline" Opt_ProfLateInlineCcs, + flagSpec "regs-graph" Opt_RegsGraph, + flagSpec "regs-iterative" Opt_RegsIterative, + depFlagSpec' "rewrite-rules" Opt_EnableRewriteRules + (useInstead "-f" "enable-rewrite-rules"), + flagSpec "shared-implib" Opt_SharedImplib, + flagSpec "spec-constr" Opt_SpecConstr, + flagSpec "spec-constr-keen" Opt_SpecConstrKeen, + flagSpec "specialise" Opt_Specialise, + flagSpec "specialize" Opt_Specialise, + flagSpec "specialise-aggressively" Opt_SpecialiseAggressively, + flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, + flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, + flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise, + flagSpec "polymorphic-specialisation" Opt_PolymorphicSpecialisation, + flagSpec "specialise-incoherents" Opt_SpecialiseIncoherents, + flagSpec "inline-generics" Opt_InlineGenerics, + flagSpec "inline-generics-aggressively" Opt_InlineGenericsAggressively, + flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, + flagSpec "strictness" Opt_Strictness, + flagSpec "use-rpaths" Opt_RPath, + flagSpec "write-interface" Opt_WriteInterface, + flagSpec "write-if-simplified-core" Opt_WriteIfSimplifiedCore, + flagSpec "write-if-self-recomp" Opt_WriteSelfRecompInfo, + flagSpec "write-if-self-recomp-flags" Opt_WriteSelfRecompFlags, + flagSpec "write-ide-info" Opt_WriteHie, + flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, + flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, + flagSpec "unoptimized-core-for-interpreter" Opt_UnoptimizedCoreForInterpreter, + flagSpec "version-macros" Opt_VersionMacros, + flagSpec "worker-wrapper" Opt_WorkerWrapper, + flagSpec "worker-wrapper-cbv" Opt_WorkerWrapperUnlift, -- See Note [Worker/wrapper for strict arguments] + flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, + flagSpec "catch-nonexhaustive-cases" Opt_CatchNonexhaustiveCases, + flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, + flagSpec "check-prim-bounds" Opt_DoBoundsChecking, + flagSpec "add-bco-name" Opt_AddBcoName, + flagSpec "num-constant-folding" Opt_NumConstantFolding, + flagSpec "core-constant-folding" Opt_CoreConstantFolding, + flagSpec "fast-pap-calls" Opt_FastPAPCalls, + flagSpec "spec-eval" Opt_SpecEval, + flagSpec "spec-eval-dictfun" Opt_SpecEvalDictFun, + flagSpec "cmm-control-flow" Opt_CmmControlFlow, + flagSpec "show-warning-groups" Opt_ShowWarnGroups, + flagSpec "hide-source-paths" Opt_HideSourcePaths, + flagSpec "show-loaded-modules" Opt_ShowLoadedModules, + flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs, + flagSpec "keep-cafs" Opt_KeepCAFs, + flagSpec "link-rts" Opt_LinkRts, + flagSpec "byte-code-and-object-code" Opt_ByteCodeAndObjectCode, + flagSpec "prefer-byte-code" Opt_UseBytecodeRatherThanObjects, + flagSpec "object-determinism" Opt_ObjectDeterminism, + flagSpec' "compact-unwind" Opt_CompactUnwind + (\turn_on -> updM (\dflags -> do + unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on) + (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.") + return dflags)), + flagSpec "show-error-context" Opt_ShowErrorContext, + flagSpec "cmm-thread-sanitizer" Opt_CmmThreadSanitizer, + flagSpec "split-sections" Opt_SplitSections, + flagSpec "break-points" Opt_InsertBreakpoints, + flagSpec "distinct-constructor-tables" Opt_DistinctConstructorTables, + flagSpec "info-table-map" Opt_InfoTableMap, + flagSpec "info-table-map-with-stack" Opt_InfoTableMapWithStack, + flagSpec "info-table-map-with-fallback" Opt_InfoTableMapWithFallback + ] + ++ fHoleFlags + +-- | These @-f\@ flags have to do with the typed-hole error message or +-- the valid hole fits in that message. See Note [Valid hole fits include ...] +-- in the "GHC.Tc.Errors.Hole" module. These flags can all be reversed with +-- @-fno-\@ +fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)] +fHoleFlags = [ + flagSpec "show-hole-constraints" Opt_ShowHoleConstraints, + depFlagSpec' "show-valid-substitutions" Opt_ShowValidHoleFits + (useInstead "-f" "show-valid-hole-fits"), + flagSpec "show-valid-hole-fits" Opt_ShowValidHoleFits, + -- Sorting settings + flagSpec "sort-valid-hole-fits" Opt_SortValidHoleFits, + flagSpec "sort-by-size-hole-fits" Opt_SortBySizeHoleFits, + flagSpec "sort-by-subsumption-hole-fits" Opt_SortBySubsumHoleFits, + flagSpec "abstract-refinement-hole-fits" Opt_AbstractRefHoleFits, + -- Output format settings + flagSpec "show-hole-matches-of-hole-fits" Opt_ShowMatchesOfHoleFits, + flagSpec "show-provenance-of-hole-fits" Opt_ShowProvOfHoleFits, + flagSpec "show-type-of-hole-fits" Opt_ShowTypeOfHoleFits, + flagSpec "show-type-app-of-hole-fits" Opt_ShowTypeAppOfHoleFits, + flagSpec "show-type-app-vars-of-hole-fits" Opt_ShowTypeAppVarsOfHoleFits, + flagSpec "show-docs-of-hole-fits" Opt_ShowDocsOfHoleFits, + flagSpec "unclutter-valid-hole-fits" Opt_UnclutterValidHoleFits + ] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fLangFlags :: [FlagSpec LangExt.Extension] +fLangFlags = map snd fLangFlagsDeps + +fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +fLangFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] + depFlagSpecOp' "th" LangExt.TemplateHaskell + checkTemplateHaskellOk + (deprecatedForExtension "TemplateHaskell"), + depFlagSpec' "fi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "ffi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "arrows" LangExt.Arrows + (deprecatedForExtension "Arrows"), + depFlagSpec' "implicit-prelude" LangExt.ImplicitPrelude + (deprecatedForExtension "ImplicitPrelude"), + depFlagSpec' "bang-patterns" LangExt.BangPatterns + (deprecatedForExtension "BangPatterns"), + depFlagSpec' "monomorphism-restriction" LangExt.MonomorphismRestriction + (deprecatedForExtension "MonomorphismRestriction"), + depFlagSpec' "extended-default-rules" LangExt.ExtendedDefaultRules + (deprecatedForExtension "ExtendedDefaultRules"), + depFlagSpec' "implicit-params" LangExt.ImplicitParams + (deprecatedForExtension "ImplicitParams"), + depFlagSpec' "scoped-type-variables" LangExt.ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + depFlagSpec' "allow-overlapping-instances" LangExt.OverlappingInstances + (deprecatedForExtension "OverlappingInstances"), + depFlagSpec' "allow-undecidable-instances" LangExt.UndecidableInstances + (deprecatedForExtension "UndecidableInstances"), + depFlagSpec' "allow-incoherent-instances" LangExt.IncoherentInstances + (deprecatedForExtension "IncoherentInstances") + ] + +supportedLanguages :: [String] +supportedLanguages = map (flagSpecName . snd) languageFlagsDeps + +supportedLanguageOverlays :: [String] +supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps + +supportedExtensions :: ArchOS -> [String] +supportedExtensions (ArchOS arch os) = concatMap toFlagSpecNamePair xFlags + where + toFlagSpecNamePair flg + -- IMPORTANT! Make sure that `ghc --supported-extensions` omits + -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the + -- box. See also GHC #11102 and #16331 for more details about + -- the rationale + | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell = [noName] + | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes = [noName] + -- "JavaScriptFFI" is only supported on the JavaScript/Wasm backend + | notJSOrWasm, flagSpecFlag flg == LangExt.JavaScriptFFI = [noName] + | otherwise = [name, noName] + where + isAIX = os == OSAIX + notJSOrWasm = not $ arch `elem` [ ArchJavaScript, ArchWasm32 ] + noName = "No" ++ name + name = flagSpecName flg + +supportedLanguagesAndExtensions :: ArchOS -> [String] +supportedLanguagesAndExtensions arch_os = + supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions arch_os + +-- | These -X flags cannot be reversed with -XNo +languageFlagsDeps :: [(Deprecation, FlagSpec Language)] +languageFlagsDeps = [ + flagSpec "Haskell98" Haskell98, + flagSpec "Haskell2010" Haskell2010, + flagSpec "GHC2021" GHC2021, + flagSpec "GHC2024" GHC2024 + ] + +-- | These -X flags cannot be reversed with -XNo +-- They are used to place hard requirements on what GHC Haskell language +-- features can be used. +safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)] +safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] + where mkF flag = flagSpec (show flag) flag + +-- | These -X flags can all be reversed with -XNo +xFlags :: [FlagSpec LangExt.Extension] +xFlags = map snd xFlagsDeps + +makeExtensionFlags :: LangExt.Extension -> [(Deprecation, FlagSpec LangExt.Extension)] +makeExtensionFlags ext = [ makeExtensionFlag name depr ext | (depr, name) <- extensionNames ext ] + +xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +xFlagsDeps = concatMap makeExtensionFlags [minBound .. maxBound] + +makeExtensionFlag :: String -> ExtensionDeprecation -> LangExt.Extension -> (Deprecation, FlagSpec LangExt.Extension) +makeExtensionFlag name depr ext = (deprecation depr, spec) + where effect = extensionEffect ext + spec = FlagSpec name ext (\f -> effect f >> act f) AllModes + act = case depr of + ExtensionNotDeprecated -> nop + ExtensionDeprecatedFor xs + -> deprecate . deprecatedForExtensions (map extensionName xs) + ExtensionFlagDeprecatedCond cond str + -> \f -> when (f == cond) (deprecate str) + ExtensionFlagDeprecated str + -> const (deprecate str) + +extensionEffect :: LangExt.Extension -> (TurnOnFlag -> DynP ()) +extensionEffect = \case + LangExt.TemplateHaskell + -> checkTemplateHaskellOk + LangExt.OverlappingInstances + -> setOverlappingInsts + LangExt.GeneralizedNewtypeDeriving + -> setGenDeriving + LangExt.IncoherentInstances + -> setIncoherentInsts + LangExt.DerivingVia + -> setDeriveVia + _ -> nop + +-- | Things you get with `-dlint`. +enableDLint :: DynP () +enableDLint = do + mapM_ setGeneralFlag dLintFlags + addWayDynP WayDebug + where + dLintFlags :: [GeneralFlag] + dLintFlags = + [ Opt_DoCoreLinting + , Opt_DoStgLinting + , Opt_DoCmmLinting + , Opt_DoAsmLinting + , Opt_CatchNonexhaustiveCases + , Opt_LlvmFillUndefWithGarbage + ] + +enableGlasgowExts :: DynP () +enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls + mapM_ setExtensionFlag glasgowExtsFlags + +disableGlasgowExts :: DynP () +disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls + mapM_ unSetExtensionFlag glasgowExtsFlags + + +setWarnSafe :: Bool -> DynP () +setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) +setWarnSafe False = return () + +setWarnUnsafe :: Bool -> DynP () +setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) +setWarnUnsafe False = return () + +setPackageTrust :: DynP () +setPackageTrust = do + setGeneralFlag Opt_PackageTrust + l <- getCurLoc + upd $ \d -> d { pkgTrustOnLoc = l } + +setGenDeriving :: TurnOnFlag -> DynP () +setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) +setGenDeriving False = return () + +setDeriveVia :: TurnOnFlag -> DynP () +setDeriveVia True = getCurLoc >>= \l -> upd (\d -> d { deriveViaOnLoc = l }) +setDeriveVia False = return () + +setOverlappingInsts :: TurnOnFlag -> DynP () +setOverlappingInsts False = return () +setOverlappingInsts True = do + l <- getCurLoc + upd (\d -> d { overlapInstLoc = l }) + +setIncoherentInsts :: TurnOnFlag -> DynP () +setIncoherentInsts False = return () +setIncoherentInsts True = do + l <- getCurLoc + upd (\d -> d { incoherentOnLoc = l }) + +checkTemplateHaskellOk :: TurnOnFlag -> DynP () +checkTemplateHaskellOk _turn_on + = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) + +{- ********************************************************************** +%* * + DynFlags constructors +%* * +%********************************************************************* -} + +type DynP = EwM (CmdLineP DynFlags) + +upd :: (DynFlags -> DynFlags) -> DynP () +upd f = liftEwM (do dflags <- getCmdLineState + putCmdLineState $! f dflags) + +updM :: (DynFlags -> DynP DynFlags) -> DynP () +updM f = do dflags <- liftEwM getCmdLineState + dflags' <- f dflags + liftEwM $ putCmdLineState $! dflags' + +--------------- Constructor functions for OptKind ----------------- +noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +noArg fn = NoArg (upd fn) + +noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +noArgM fn = NoArg (updM fn) + +hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +hasArg fn = HasArg (upd . fn) + +sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +sepArg fn = SepArg (upd . fn) + +intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffix fn = IntSuffix (\n -> upd (fn n)) + +intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffixM fn = IntSuffix (\n -> updM (fn n)) + +word64Suffix :: (Word64 -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +word64Suffix fn = Word64Suffix (\n -> upd (fn n)) + +floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +floatSuffix fn = FloatSuffix (\n -> upd (fn n)) + +optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) + -> OptKind (CmdLineP DynFlags) +optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) + +setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags) +setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) + +-------------------------- +addWayDynP :: Way -> DynP () +addWayDynP = upd . addWay' + +addWay' :: Way -> DynFlags -> DynFlags +addWay' w dflags0 = + let platform = targetPlatform dflags0 + dflags1 = dflags0 { targetWays_ = addWay w (targetWays_ dflags0) } + dflags2 = foldr setGeneralFlag' dflags1 + (wayGeneralFlags platform w) + dflags3 = foldr unSetGeneralFlag' dflags2 + (wayUnsetGeneralFlags platform w) + in dflags3 + +removeWayDynP :: Way -> DynP () +removeWayDynP w = upd (\dfs -> dfs { targetWays_ = removeWay w (targetWays_ dfs) }) + +-------------------------- +setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () +setGeneralFlag f = upd (setGeneralFlag' f) +unSetGeneralFlag f = upd (unSetGeneralFlag' f) + +setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedGFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setGeneralFlag recursively, in case the implied flags + -- implies further flags + +unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedOffGFlags, f' == f ] + -- In general, when you un-set f, we don't un-set the things it implies. + -- There are however some exceptions, e.g., -fno-strictness implies + -- -fno-worker-wrapper. + -- + -- NB: use unSetGeneralFlag' recursively, in case the implied off flags + -- imply further flags. + +-------------------------- +setWarningGroup :: WarningGroup -> DynP () +setWarningGroup g = do + mapM_ setWarningFlag (warningGroupFlags g) + when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_custom + +unSetWarningGroup :: WarningGroup -> DynP () +unSetWarningGroup g = do + mapM_ unSetWarningFlag (warningGroupFlags g) + when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_custom + +setWErrorWarningGroup :: WarningGroup -> DynP () +setWErrorWarningGroup g = + do { setWarningGroup g + ; setFatalWarningGroup g } + +setFatalWarningGroup :: WarningGroup -> DynP () +setFatalWarningGroup g = do + mapM_ setFatalWarningFlag (warningGroupFlags g) + when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_fatal_custom + +unSetFatalWarningGroup :: WarningGroup -> DynP () +unSetFatalWarningGroup g = do + mapM_ unSetFatalWarningFlag (warningGroupFlags g) + when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_fatal_custom + + +setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () +setWarningFlag f = upd (\dfs -> wopt_set dfs f) +unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) + +setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP () +setFatalWarningFlag f = upd (\dfs -> wopt_set_fatal dfs f) +unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f) + +setWErrorFlag :: WarningFlag -> DynP () +setWErrorFlag flag = + do { setWarningFlag flag + ; setFatalWarningFlag flag } + + +setCustomWarningFlag, unSetCustomWarningFlag :: WarningCategory -> DynP () +setCustomWarningFlag f = upd (\dfs -> wopt_set_custom dfs f) +unSetCustomWarningFlag f = upd (\dfs -> wopt_unset_custom dfs f) + +setCustomFatalWarningFlag, unSetCustomFatalWarningFlag :: WarningCategory -> DynP () +setCustomFatalWarningFlag f = upd (\dfs -> wopt_set_fatal_custom dfs f) +unSetCustomFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal_custom dfs f) + +setCustomWErrorFlag :: WarningCategory -> DynP () +setCustomWErrorFlag flag = + do { setCustomWarningFlag flag + ; setCustomFatalWarningFlag flag } + + +-------------------------- +setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP () +setExtensionFlag f = upd (setExtensionFlag' f) +unSetExtensionFlag f = upd (unSetExtensionFlag' f) + +setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags +setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps + where + deps :: [DynFlags -> DynFlags] + deps = [ setExtension d + | (f', d) <- impliedXFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setExtensionFlag recursively, in case the implied flags + -- implies further flags + + setExtension :: OnOff LangExt.Extension -> DynFlags -> DynFlags + setExtension = \ case + On extension -> setExtensionFlag' extension + Off extension -> unSetExtensionFlag' extension + +unSetExtensionFlag' f dflags = xopt_unset dflags f + -- When you un-set f, however, we don't un-set the things it implies + -- (except for -fno-glasgow-exts, which is treated specially) + +-------------------------- + +alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags +alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } + +-------------------------- +setDumpFlag' :: DumpFlag -> DynP () +setDumpFlag' dump_flag + = do upd (\dfs -> dopt_set dfs dump_flag) + when want_recomp forceRecompile + where -- Certain dumpy-things are really interested in what's going + -- on during recompilation checking, so in those cases we + -- don't want to turn it off. + want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, + Opt_D_dump_hi_diffs, + Opt_D_no_debug_output] + +forceRecompile :: DynP () +-- Whenever we -ddump, force recompilation (by switching off the +-- recompilation checker), else you don't see the dump! However, +-- don't switch it off in --make mode, else *everything* gets +-- recompiled which probably isn't what you want +forceRecompile = do dfs <- liftEwM getCmdLineState + when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp) + where + force_recomp dfs = isOneShot (ghcMode dfs) + + +setVerbosity :: Maybe Int -> DynP () +setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) + +setDebugLevel :: Maybe Int -> DynP () +setDebugLevel mb_n = + upd (\dfs -> exposeSyms $ dfs{ debugLevel = n }) + where + n = mb_n `orElse` 2 + exposeSyms + | n > 2 = setGeneralFlag' Opt_ExposeInternalSymbols + | otherwise = id + +addPkgDbRef :: PkgDbRef -> DynP () +addPkgDbRef p = upd $ \s -> + s { packageDBFlags = PackageDB p : packageDBFlags s } + +removeUserPkgDb :: DynP () +removeUserPkgDb = upd $ \s -> + s { packageDBFlags = NoUserPackageDB : packageDBFlags s } + +removeGlobalPkgDb :: DynP () +removeGlobalPkgDb = upd $ \s -> + s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s } + +clearPkgDb :: DynP () +clearPkgDb = upd $ \s -> + s { packageDBFlags = ClearPackageDBs : packageDBFlags s } + +parsePackageFlag :: String -- the flag + -> ReadP PackageArg -- type of argument + -> String -- string to parse + -> PackageFlag +parsePackageFlag flag arg_parse str + = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) + where doc = flag ++ " " ++ str + parse = do + pkg_arg <- tok arg_parse + let mk_expose = ExposePackage doc pkg_arg + ( do _ <- tok $ string "with" + fmap (mk_expose . ModRenaming True) parseRns + <++ fmap (mk_expose . ModRenaming False) parseRns + <++ return (mk_expose (ModRenaming True []))) + parseRns = do _ <- tok $ R.char '(' + rns <- tok $ sepBy parseItem (tok $ R.char ',') + _ <- tok $ R.char ')' + return rns + parseItem = do + orig <- tok $ parseModuleName + (do _ <- tok $ string "as" + new <- tok $ parseModuleName + return (orig, new) + +++ + return (orig, orig)) + tok m = m >>= \x -> skipSpaces >> return x + +exposePackage, exposePackageId, hidePackage, + exposePluginPackage, exposePluginPackageId, + ignorePackage, + trustPackage, distrustPackage :: String -> DynP () +exposePackage p = upd (exposePackage' p) +exposePackageId p = + upd (\s -> s{ packageFlags = + parsePackageFlag "-package-id" parseUnitArg p : packageFlags s }) +exposePluginPackage p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) +exposePluginPackageId p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package-id" parseUnitArg p : pluginPackageFlags s }) +hidePackage p = + upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) +ignorePackage p = + upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s }) + +trustPackage p = exposePackage p >> -- both trust and distrust also expose a package + upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s }) +distrustPackage p = exposePackage p >> + upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s }) + +exposePackage' :: String -> DynFlags -> DynFlags +exposePackage' p dflags + = dflags { packageFlags = + parsePackageFlag "-package" parsePackageArg p : packageFlags dflags } + +parsePackageArg :: ReadP PackageArg +parsePackageArg = + fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) + +parseUnitArg :: ReadP PackageArg +parseUnitArg = + fmap UnitIdArg parseUnit + +setUnitId :: String -> DynFlags -> DynFlags +setUnitId p d = d { homeUnitId_ = stringToUnitId p } + +setHomeUnitId :: UnitId -> DynFlags -> DynFlags +setHomeUnitId p d = d { homeUnitId_ = p } + +setWorkingDirectory :: String -> DynFlags -> DynFlags +setWorkingDirectory p d = d { workingDirectory = Just p } + +{- +Note [Filepaths and Multiple Home Units] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is common to assume that a package is compiled in the directory where its +cabal file resides. Thus, all paths used in the compiler are assumed to be relative +to this directory. When there are multiple home units the compiler is often +not operating in the standard directory and instead where the cabal.project +file is located. In this case the `-working-dir` option can be passed which specifies +the path from the current directory to the directory the unit assumes to be it's root, +normally the directory which contains the cabal file. + +When the flag is passed, any relative paths used by the compiler are offset +by the working directory. Notably this includes `-i`, `-I⟨dir⟩`, `-hidir`, `-odir` etc and +the location of input files. + +-} + +augmentByWorkingDirectory :: DynFlags -> FilePath -> FilePath +augmentByWorkingDirectory dflags fp | isRelative fp, Just offset <- workingDirectory dflags = offset fp +augmentByWorkingDirectory _ fp = fp + +setPackageName :: String -> DynFlags -> DynFlags +setPackageName p d = d { thisPackageName = Just p } + +addHiddenModule :: String -> DynP () +addHiddenModule p = + upd (\s -> s{ hiddenModules = Set.insert (mkModuleName p) (hiddenModules s) }) + +addReexportedModule :: String -> DynP () +addReexportedModule p = + upd (\s -> s{ reexportedModules = (parseReexportedModule p) : (reexportedModules s) }) + +parseReexportedModule :: String -- string to parse + -> ReexportedModule +parseReexportedModule str + = case filter ((=="").snd) (readP_to_S parseItem str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse reexported module flag: " ++ str) + where + parseItem = do + orig <- tok $ parseModuleName + (do _ <- tok $ string "as" + new <- tok $ parseModuleName + return (ReexportedModule orig new)) + +++ + return (ReexportedModule orig orig) + + tok m = m >>= \x -> skipSpaces >> return x + + +-- If we're linking a binary, then only backends that produce object +-- code are allowed (requests for other target types are ignored). +setBackend :: Backend -> DynP () +setBackend l = upd $ \ dfs -> + if ghcLink dfs /= LinkBinary || backendWritesFiles l + then dfs{ backend = l } + else dfs + +-- Changes the target only if we're compiling object code. This is +-- used by -fasm and -fllvm, which switch from one to the other, but +-- not from bytecode to object-code. The idea is that -fasm/-fllvm +-- can be safely used in an OPTIONS_GHC pragma. +setObjBackend :: Backend -> DynP () +setObjBackend l = updM set + where + set dflags + | backendWritesFiles (backend dflags) + = return $ dflags { backend = l } + | otherwise = return dflags + +setOptLevel :: Int -> DynFlags -> DynP DynFlags +setOptLevel n dflags = return (updOptLevel n dflags) + +setCallerCcFilters :: String -> DynP () +setCallerCcFilters arg = + case parseCallerCcFilter arg of + Right filt -> upd $ \d -> d { callerCcFilters = filt : callerCcFilters d } + Left err -> addErr err + +setMainIs :: String -> DynP () +setMainIs arg = parse parse_main_f arg + where + parse callback str = case unP parseIdentifier (p_state str) of + PFailed _ -> addErr $ "Can't parse -main-is \"" ++ arg ++ "\" as an identifier or module." + POk _ (L _ re) -> callback re + + -- dummy parser state. + p_state str = initParserState + (mkParserOpts mempty emptyDiagOpts False False False True) + (stringToStringBuffer str) + (mkRealSrcLoc (mkFastString []) 1 1) + + parse_main_f (Unqual occ) + | isVarOcc occ = upd $ \d -> d { mainFunIs = main_f occ } + parse_main_f (Qual (ModuleName mod) occ) + | isVarOcc occ = upd $ \d -> d { mainModuleNameIs = mkModuleNameFS mod + , mainFunIs = main_f occ } + -- append dummy "function" to parse A.B as the module A.B + -- and not the Data constructor B from the module A + parse_main_f _ = parse parse_mod (arg ++ ".main") + + main_f = Just . occNameString + + parse_mod (Qual (ModuleName mod) _) = upd $ \d -> d { mainModuleNameIs = mkModuleNameFS mod } + -- we appended ".m" and any parse error was caught. We are Qual or something went very wrong + parse_mod _ = error "unreachable" + +addLdInputs :: Option -> DynFlags -> DynFlags +addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} + +-- ----------------------------------------------------------------------------- +-- Load dynflags from environment files. + +setFlagsFromEnvFile :: FilePath -> String -> DynP () +setFlagsFromEnvFile envfile content = do + setGeneralFlag Opt_HideAllPackages + parseEnvFile envfile content + +parseEnvFile :: FilePath -> String -> DynP () +parseEnvFile envfile = mapM_ parseEntry . lines + where + parseEntry str = case words str of + ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir db)) + -- relative package dbs are interpreted relative to the env file + where envdir = takeDirectory envfile + db = drop 11 str + ["clear-package-db"] -> clearPkgDb + ["hide-package", pkg] -> hidePackage pkg + ["global-package-db"] -> addPkgDbRef GlobalPkgDb + ["user-package-db"] -> addPkgDbRef UserPkgDb + ["package-id", pkgid] -> exposePackageId pkgid + (('-':'-':_):_) -> return () -- comments + -- and the original syntax introduced in 7.10: + [pkgid] -> exposePackageId pkgid + [] -> return () + _ -> throwGhcException $ CmdLineError $ + "Can't parse environment file entry: " + ++ envfile ++ ": " ++ str + + +----------------------------------------------------------------------------- +-- Paths & Libraries + +addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP () + +-- -i on its own deletes the import paths +addImportPath "" = upd (\s -> s{importPaths = []}) +addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) + +addLibraryPath p = + upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) + +addIncludePath p = + upd (\s -> s{includePaths = + addGlobalInclude (includePaths s) (splitPathList p)}) + +addFrameworkPath p = + upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) + +#if !defined(mingw32_HOST_OS) +split_marker :: Char +split_marker = ':' -- not configurable (ToDo) +#endif + +splitPathList :: String -> [String] +splitPathList s = filter notNull (splitUp s) + -- empty paths are ignored: there might be a trailing + -- ':' in the initial list, for example. Empty paths can + -- cause confusion when they are translated into -I options + -- for passing to gcc. + where +#if !defined(mingw32_HOST_OS) + splitUp xs = split split_marker xs +#else + -- Windows: 'hybrid' support for DOS-style paths in directory lists. + -- + -- That is, if "foo:bar:baz" is used, this interpreted as + -- consisting of three entries, 'foo', 'bar', 'baz'. + -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted + -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" + -- + -- Notice that no attempt is made to fully replace the 'standard' + -- split marker ':' with the Windows / DOS one, ';'. The reason being + -- that this will cause too much breakage for users & ':' will + -- work fine even with DOS paths, if you're not insisting on being silly. + -- So, use either. + splitUp [] = [] + splitUp (x:':':div:xs) | div `elem` dir_markers + = ((x:':':div:p): splitUp rs) + where + (p,rs) = findNextPath xs + -- we used to check for existence of the path here, but that + -- required the IO monad to be threaded through the command-line + -- parser which is quite inconvenient. The + splitUp xs = cons p (splitUp rs) + where + (p,rs) = findNextPath xs + + cons "" xs = xs + cons x xs = x:xs + + -- will be called either when we've consumed nought or the + -- ":/" part of a DOS path, so splitting is just a Q of + -- finding the next split marker. + findNextPath xs = + case break (`elem` split_markers) xs of + (p, _:ds) -> (p, ds) + (p, xs) -> (p, xs) + + split_markers :: [Char] + split_markers = [':', ';'] + + dir_markers :: [Char] + dir_markers = ['/', '\\'] +#endif + +-- ----------------------------------------------------------------------------- +-- tmpDir, where we store temporary files. + +setTmpDir :: FilePath -> DynFlags -> DynFlags +setTmpDir dir d = d { tmpDir = TempDir (normalise dir) } + -- we used to fix /cygdrive/c/.. on Windows, but this doesn't + -- seem necessary now --SDM 7/2/2008 + +----------------------------------------------------------------------------- +-- RTS opts + +setRtsOpts :: String -> DynP () +setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} + +setRtsOptsEnabled :: RtsOptsEnabled -> DynP () +setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} + +----------------------------------------------------------------------------- +-- Hpc stuff + +setOptHpcDir :: String -> DynP () +setOptHpcDir arg = upd $ \ d -> d {hpcDir = arg} + +----------------------------------------------------------------------------- +-- Via-C compilation stuff + +-- There are some options that we need to pass to gcc when compiling +-- Haskell code via C, but are only supported by recent versions of +-- gcc. The configure script decides which of these options we need, +-- and puts them in the "settings" file in $topdir. The advantage of +-- having these in a separate file is that the file can be created at +-- install-time depending on the available gcc version, and even +-- re-generated later if gcc is upgraded. +-- +-- The options below are not dependent on the version of gcc, only the +-- platform. + +picCCOpts :: DynFlags -> [String] +picCCOpts dflags = + case platformOS (targetPlatform dflags) of + OSDarwin + -- Apple prefers to do things the other way round. + -- PIC is on by default. + -- -mdynamic-no-pic: + -- Turn off PIC code generation. + -- -fno-common: + -- Don't generate "common" symbols - these are unwanted + -- in dynamic libraries. + + | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] + | otherwise -> ["-mdynamic-no-pic"] + OSMinGW32 -- no -fPIC for Windows + | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] + | otherwise -> [] + _ + -- we need -fPIC for C files when we are compiling with -dynamic, + -- otherwise things like stub.c files don't get compiled + -- correctly. They need to reference data in the Haskell + -- objects, but can't without -fPIC. See + -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code + | gopt Opt_PIC dflags || ways dflags `hasWay` WayDyn -> + ["-fPIC", "-U__PIC__", "-D__PIC__"] ++ + -- Clang defaults to -fvisibility=hidden for wasm targets, + -- but we need these compile-time flags to generate PIC + -- objects that can be properly linked by wasm-ld using + -- --export-dynamic; without these flags we would need + -- -Wl,--export-all at .so link-time which will export + -- internal symbols as well, and that severely pollutes the + -- global symbol namespace. + (if platformArch (targetPlatform dflags) == ArchWasm32 + then [ "-fvisibility=default", "-fvisibility-inlines-hidden" ] + else []) + -- gcc may be configured to have PIC on by default, let's be + -- explicit here, see #15847 + | otherwise -> ["-fno-PIC"] + +pieCCLDOpts :: DynFlags -> [String] +pieCCLDOpts dflags + | gopt Opt_PICExecutable dflags = ["-pie"] + -- See Note [No PIE when linking] + | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"] + | otherwise = [] + + +{- +Note [No PIE when linking] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by +default in their gcc builds. This is incompatible with -r as it implies that we +are producing an executable. Consequently, we must manually pass -no-pie to gcc +when joining object files or linking dynamic libraries. Unless, of course, the +user has explicitly requested a PIE executable with -pie. See #12759. +-} + +picPOpts :: DynFlags -> [String] +picPOpts dflags + | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] + | otherwise = [] + +-- ----------------------------------------------------------------------------- +-- Compiler Info + +compilerInfo :: DynFlags -> [(String, String)] +compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) + (rawSettings dflags) + ++ [("Project version", projectVersion dflags), + ("Project Git commit id", cProjectGitCommitId), + ("Project Version Int", cProjectVersionInt), + ("Project Patch Level", cProjectPatchLevel), + ("Project Patch Level1", cProjectPatchLevel1), + ("Project Patch Level2", cProjectPatchLevel2), + ("Project Unit Id", cProjectUnitId), + ("ghc-internal Unit Id", cGhcInternalUnitId), -- See Note [Special unit-ids] + ("Booter version", cBooterVersion), + ("Stage", cStage), + ("Build platform", cBuildPlatformString), + ("Host platform", cHostPlatformString), + ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), + ("target os string", stringEncodeOS (platformOS (targetPlatform dflags))), + ("target arch string", stringEncodeArch (platformArch (targetPlatform dflags))), + ("target word size in bits", show (platformWordSizeInBits (targetPlatform dflags))), + ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), + ("Object splitting supported", showBool False), + ("Have native code generator", showBool $ platformNcgSupported platform), + ("target has RTS linker", showBool $ platformHasRTSLinker platform), + ("Target default backend", show $ platformDefaultBackend platform), + -- Whether or not we support @-dynamic-too@ + ("Support dynamic-too", showBool $ not isWindows), + -- Whether or not we support the @-j@ flag with @--make@. + ("Support parallel --make", "YES"), + -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in + -- installed package info. + ("Support reexported-modules", "YES"), + -- Whether or not we support extended @-package foo (Foo)@ syntax. + ("Support thinning and renaming package flags", "YES"), + -- Whether or not we support Backpack. + ("Support Backpack", "YES"), + -- If true, we require that the 'id' field in installed package info + -- match what is passed to the @-this-unit-id@ flag for modules + -- built in it + ("Requires unified installed package IDs", "YES"), + -- Whether or not we support the @-this-package-key@ flag. Prefer + -- "Uses unit IDs" over it. We still say yes even if @-this-package-key@ + -- flag has been removed, otherwise it breaks Cabal... + ("Uses package keys", "YES"), + -- Whether or not we support the @-this-unit-id@ flag + ("Uses unit IDs", "YES"), + -- Whether or not GHC was compiled using -dynamic + ("GHC Dynamic", showBool hostIsDynamic), + -- Whether or not GHC was compiled using -prof + ("GHC Profiled", showBool hostIsProfiled), + ("Debug on", showBool debugIsOn), + ("LibDir", topDir dflags), + -- This is always an absolute path, unlike "Relative Global Package DB" which is + -- in the settings file. + ("Global Package DB", globalPackageDatabasePath dflags) + ] + where + showBool True = "YES" + showBool False = "NO" + platform = targetPlatform dflags + isWindows = platformOS platform == OSMinGW32 + useInplaceMinGW = toolSettings_useInplaceMinGW $ toolSettings dflags + expandDirectories :: FilePath -> Maybe FilePath -> String -> String + expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd + +-- Note [Special unit-ids] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- Certain units are special to the compiler: +-- - Wired-in identifiers reference a specific unit-id of `ghc-internal`. +-- - GHC plugins must be linked against a specific unit-id of `ghc`, +-- namely the same one as the compiler. +-- - When using Template Haskell, the result of executing splices refer to +-- the Template Haskell ASTs created using constructors from `ghc-internal`, +-- and must be linked against the same `ghc-internal` unit-id as the compiler. +-- +-- We therefore expose the unit-id of `ghc-internal` ("ghc-internal Unit Id") and +-- ghc ("Project Unit Id") through `ghc --info`. +-- +-- This allows build tools to act accordingly, eg, if a user wishes to build a +-- GHC plugin, `cabal-install` might force them to use the exact `ghc` unit +-- that the compiler was linked against. +-- See: +-- - https://github.com/haskell/cabal/issues/10087 +-- - https://github.com/commercialhaskell/stack/issues/6749 + +{- ----------------------------------------------------------------------------- +Note [DynFlags consistency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of number of DynFlags configurations which either +do not make sense or lead to unimplemented or buggy codepaths in the +compiler. makeDynFlagsConsistent is responsible for verifying the validity +of a set of DynFlags, fixing any issues, and reporting them back to the +caller. + +GHCi and -O +--------------- + +When using optimization, the compiler can introduce several things +(such as unboxed tuples) into the intermediate code, which GHCi later +chokes on since the bytecode interpreter can't handle this (and while +this is arguably a bug these aren't handled, there are no plans to fix +it.) + +While the driver pipeline always checks for this particular erroneous +combination when parsing flags, we also need to check when we update +the flags; this is because API clients may parse flags but update the +DynFlags afterwords, before finally running code inside a session (see +T10052 and #10052). + +Host ways vs Build ways mismatch +-------------------------------- +Many consistency checks aim to fix the situation where the wanted build ways +are not compatible with the ways the compiler is built in. This happens when +using the interpreter, TH, and the runtime linker, where the compiler cannot +load objects compiled for ways not matching its own. + +For instance, a profiled-dynamic object can only be loaded by a +profiled-dynamic compiler (and not any other kind of compiler). + +This incompatibility is traditionally solved in either of two ways: + +(1) Force the "wanted" build ways to match the compiler ways exactly, + guaranteeing they match. + +(2) Force the use of the external interpreter. When interpreting is offloaded + to the external interpreter it no longer matters what are the host compiler ways. + +In the checks and fixes performed by `makeDynFlagsConsistent`, the choice +between the two does not seem uniform. TODO: Make this choice more evident and uniform. +-} + +-- | Resolve any internal inconsistencies in a set of 'DynFlags'. +-- Returns the consistent 'DynFlags' as well as a list of warnings +-- to report to the user, and a list of verbose info msgs. +-- +-- See Note [DynFlags consistency] +makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Warn], [Located SDoc]) +-- Whenever makeDynFlagsConsistent does anything, it starts over, to +-- ensure that a later change doesn't invalidate an earlier check. +-- Be careful not to introduce potential loops! +makeDynFlagsConsistent dflags + -- Disable -dynamic-too on Windows (#8228, #7134, #5987) + | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags + = let dflags' = gopt_unset dflags Opt_BuildDynamicToo + warn = "-dynamic-too is not supported on Windows" + in loop dflags' warn + -- Disable -dynamic-too if we are are compiling with -dynamic already, otherwise + -- you get two dynamic object files (.o and .dyn_o). (#20436) + | ways dflags `hasWay` WayDyn && gopt Opt_BuildDynamicToo dflags + = let dflags' = gopt_unset dflags Opt_BuildDynamicToo + warn = "-dynamic-too is ignored when using -dynamic" + in loop dflags' warn + + | gopt Opt_SplitSections dflags + , platformHasSubsectionsViaSymbols (targetPlatform dflags) + = let dflags' = gopt_unset dflags Opt_SplitSections + warn = "-fsplit-sections is not useful on this platform " ++ + "since it uses subsections-via-symbols. Ignoring." + in loop dflags' warn + + -- Via-C backend only supports unregisterised ABI. Switch to a backend + -- supporting it if possible. + | backendUnregisterisedAbiOnly (backend dflags) && + not (platformUnregisterised (targetPlatform dflags)) + = let b = platformDefaultBackend (targetPlatform dflags) + in if backendSwappableWithViaC b then + let dflags' = dflags { backend = b } + warn = "Target platform doesn't use unregisterised ABI, so using " ++ + backendDescription b ++ " rather than " ++ + backendDescription (backend dflags) + in loop dflags' warn + else + pgmError (backendDescription (backend dflags) ++ + " supports only unregisterised ABI but target platform doesn't use it.") + + | gopt Opt_Hpc dflags && not (backendSupportsHpc (backend dflags)) + = let dflags' = gopt_unset dflags Opt_Hpc + warn = "Hpc can't be used with " ++ backendDescription (backend dflags) ++ + ". Ignoring -fhpc." + in loop dflags' warn + + | backendSwappableWithViaC (backend dflags) && + platformUnregisterised (targetPlatform dflags) + = loop (dflags { backend = viaCBackend }) + "Target platform uses unregisterised ABI, so compiling via C" + + | backendNeedsPlatformNcgSupport (backend dflags) && + not (platformNcgSupported $ targetPlatform dflags) + = let dflags' = dflags { backend = llvmBackend } + warn = "Native code generator doesn't support target platform, so using LLVM" + in loop dflags' warn + + | not (osElfTarget os) && gopt Opt_PIE dflags + = loop (gopt_unset dflags Opt_PIE) + "Position-independent only supported on ELF platforms" + | os == OSDarwin && + arch == ArchX86_64 && + not (gopt Opt_PIC dflags) + = loop (gopt_set dflags Opt_PIC) + "Enabling -fPIC as it is always on for this platform" + + | backendForcesOptimization0 (backend dflags) + , gopt Opt_UnoptimizedCoreForInterpreter dflags + , let (dflags', changed) = updOptLevelChanged 0 dflags + , changed + = loop dflags' $ + "Ignoring optimization flags since they are experimental for the " ++ + backendDescription (backend dflags) ++ + ". Pass -fno-unoptimized-core-for-interpreter to enable this feature." + + | LinkInMemory <- ghcLink dflags + , not (gopt Opt_ExternalInterpreter dflags) + , hostIsProfiled + , backendWritesFiles (backend dflags) + , ways dflags `hasNotWay` WayProf + = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)} + "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" + + | gopt Opt_ByteCode dflags || gopt Opt_ByteCodeAndObjectCode dflags + , not (gopt Opt_ExternalInterpreter dflags) + , hostIsProfiled + , ways dflags `hasNotWay` WayProf + = loop (gopt_set dflags Opt_ExternalInterpreter) + "Enabling external interpreter, because GHC is profiled and bytecode is being used for TH" + + | LinkMergedObj <- ghcLink dflags + , Nothing <- outputFile dflags + = pgmError "--output must be specified when using --merge-objs" + + | platformTablesNextToCode platform + && os == OSMinGW32 + && arch == ArchAArch64 + = case backendCodeOutput (backend dflags) of + LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64" + NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64" + _ -> (dflags, mempty, mempty) + + -- When we do ghci, force using dyn ways if the target RTS linker + -- only supports dynamic code + | LinkInMemory <- ghcLink dflags + , sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags + , not (ways dflags `hasWay` WayDyn && gopt Opt_ExternalInterpreter dflags) + = flip loopNoWarn "Forcing dynamic way because target RTS linker only supports dynamic code" $ + -- See checkOptions, -fexternal-interpreter is + -- required when using --interactive with a non-standard + -- way (-prof, -static, or -dynamic). + setGeneralFlag' Opt_ExternalInterpreter $ + addWay' WayDyn dflags + + | LinkInMemory <- ghcLink dflags + , not (gopt Opt_ExternalInterpreter dflags) + , targetWays_ dflags /= hostFullWays + = flip loopNoWarn "Forcing build ways to match the compiler ways because we're using the internal interpreter" $ + let dflags_a = dflags { targetWays_ = hostFullWays } + dflags_b = foldl gopt_set dflags_a + $ concatMap (wayGeneralFlags platform) + hostFullWays + dflags_c = foldl gopt_unset dflags_b + $ concatMap (wayUnsetGeneralFlags platform) + hostFullWays + in dflags_c + + | otherwise = (dflags, mempty, mempty) + where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") + loop updated_dflags warning + = case makeDynFlagsConsistent updated_dflags of + (dflags', ws, is) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws, is) + loopNoWarn updated_dflags doc + = case makeDynFlagsConsistent updated_dflags of + (dflags', ws, is) -> (dflags', ws, L loc (text doc):is) + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + + +setUnsafeGlobalDynFlags :: DynFlags -> IO () +setUnsafeGlobalDynFlags dflags = do + writeIORef v_unsafeHasPprDebug (hasPprDebug dflags) + writeIORef v_unsafeHasNoDebugOutput (hasNoDebugOutput dflags) + writeIORef v_unsafeHasNoStateHack (hasNoStateHack dflags) + + +-- ----------------------------------------------------------------------------- + +-- | Indicate if cost-centre profiling is enabled +sccProfilingEnabled :: DynFlags -> Bool +sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags) + +-- | Indicate whether we need to generate source notes +needSourceNotes :: DynFlags -> Bool +needSourceNotes dflags = debugLevel dflags > 0 + || gopt Opt_InfoTableMap dflags + + -- Source ticks are used to approximate the location of + -- overloaded call cost centers + || gopt Opt_ProfLateoverloadedCallsCCs dflags + +-- ----------------------------------------------------------------------------- +-- Linker/compiler information + +-- | Should we use `-XLinker -rpath` when linking or not? +-- See Note [-fno-use-rpaths] +useXLinkerRPath :: DynFlags -> OS -> Bool +-- wasm shared libs don't have RPATH at all and wasm-ld doesn't accept +-- any RPATH-related flags +useXLinkerRPath dflags _ | ArchWasm32 <- platformArch $ targetPlatform dflags = False +useXLinkerRPath _ OSDarwin = False -- See Note [Dynamic linking on macOS] +useXLinkerRPath dflags _ = gopt Opt_RPath dflags + +{- +Note [-fno-use-rpaths] +~~~~~~~~~~~~~~~~~~~~~~ + +First read, Note [Dynamic linking on macOS] to understand why on darwin we never +use `-XLinker -rpath`. + +The specification of `Opt_RPath` is as follows: + +The default case `-fuse-rpaths`: +* On darwin, never use `-Xlinker -rpath -Xlinker`, always inject the rpath + afterwards, see `runInjectRPaths`. There is no way to use `-Xlinker` on darwin + as things stand but it wasn't documented in the user guide before this patch how + `-fuse-rpaths` should behave and the fact it was always disabled on darwin. +* Otherwise, use `-Xlinker -rpath -Xlinker` to set the rpath of the executable, + this is the normal way you should set the rpath. + +The case of `-fno-use-rpaths` +* Never inject anything into the rpath. + +When this was first implemented, `Opt_RPath` was disabled on darwin, but +the rpath was still always augmented by `runInjectRPaths`, and there was no way to +stop this. This was problematic because you couldn't build an executable in CI +with a clean rpath. + +-} + +-- ----------------------------------------------------------------------------- +-- RTS hooks + +-- Convert sizes like "3.5M" into integers +decodeSize :: String -> Integer +decodeSize str + | c == "" = truncate n + | c == "K" || c == "k" = truncate (n * 1000) + | c == "M" || c == "m" = truncate (n * 1000 * 1000) + | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) + | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str)) + where (m, c) = span pred str + n = readRational m + pred c = isDigit c || c == '.' + +foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () +foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () + +outputFile :: DynFlags -> Maybe String +outputFile dflags + | dynamicNow dflags = dynOutputFile_ dflags + | otherwise = outputFile_ dflags + +objectSuf :: DynFlags -> String +objectSuf dflags + | dynamicNow dflags = dynObjectSuf_ dflags + | otherwise = objectSuf_ dflags + +-- | Pretty-print the difference between 2 DynFlags. +-- +-- For now only their general flags but it could be extended. +-- Useful mostly for debugging. +pprDynFlagsDiff :: DynFlags -> DynFlags -> SDoc +pprDynFlagsDiff d1 d2 = + let gf_removed = EnumSet.difference (generalFlags d1) (generalFlags d2) + gf_added = EnumSet.difference (generalFlags d2) (generalFlags d1) + ext_removed = EnumSet.difference (extensionFlags d1) (extensionFlags d2) + ext_added = EnumSet.difference (extensionFlags d2) (extensionFlags d1) + in vcat + [ text "Added general flags:" + , text $ show $ EnumSet.toList $ gf_added + , text "Removed general flags:" + , text $ show $ EnumSet.toList $ gf_removed + , text "Added extension flags:" + , text $ show $ EnumSet.toList $ ext_added + , text "Removed extension flags:" + , text $ show $ EnumSet.toList $ ext_removed + ] + +updatePlatformConstants :: DynFlags -> Maybe PlatformConstants -> IO DynFlags +updatePlatformConstants dflags mconstants = do + let platform1 = (targetPlatform dflags) { platform_constants = mconstants } + let dflags1 = dflags { targetPlatform = platform1 } + return dflags1 diff --git a/GHC/Driver/Session/Inspect.hs b/GHC/Driver/Session/Inspect.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Session/Inspect.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE LambdaCase #-} + +-- | GHC API utilities for inspecting the GHC session +module GHC.Driver.Session.Inspect where + +import GHC.Prelude +import GHC.Data.Maybe +import Control.Monad + +import GHC.ByteCode.Types +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv +import GHC.Driver.Env +import GHC.Driver.Main +import GHC.Driver.Monad +import GHC.Driver.Session +import GHC.Rename.Names +import GHC.Runtime.Context +import GHC.Runtime.Interpreter +import GHC.Types.Avail +import GHC.Types.Name +import GHC.Types.Name.Ppr +import GHC.Types.Name.Reader +import GHC.Types.Name.Set +import GHC.Types.PkgQual +import GHC.Types.SafeHaskell +import GHC.Types.SrcLoc +import GHC.Types.TyThing +import GHC.Types.TypeEnv +import GHC.Unit.External +import GHC.Unit.Home.ModInfo +import GHC.Unit.Module +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Utils.Misc +import GHC.Utils.Outputable +import qualified GHC.Unit.Home.Graph as HUG + +-- %************************************************************************ +-- %* * +-- Inspecting the session +-- %* * +-- %************************************************************************ + +-- | Get the module dependency graph. +getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary +getModuleGraph = liftM hsc_mod_graph getSession + +{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-} +-- | Return @True@ \<==> module is loaded. +isLoaded :: GhcMonad m => ModuleName -> m Bool +isLoaded m = withSession $ \hsc_env -> liftIO $ do + hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m + return $! not (null hmis) + +-- | Check whether a 'ModuleName' is found in the 'HomePackageTable' +-- for the given 'UnitId'. +isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool +isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do + hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m + return $! isJust hmi + +-- | Check whether 'Module' is part of the 'HomeUnitGraph'. +-- +-- Similar to 'isLoadedModule', but for 'Module's. +isLoadedHomeModule :: GhcMonad m => Module -> m Bool +isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do + hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env) + return $! isJust hmi + +-- | Return the bindings for the current interactive session. +getBindings :: GhcMonad m => m [TyThing] +getBindings = withSession $ \hsc_env -> + return $ icInScopeTTs $ hsc_IC hsc_env + +-- | Return the instances for the current interactive session. +getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) +getInsts = withSession $ \hsc_env -> + let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env) + in return (instEnvElts inst_env, fam_env) + +getNamePprCtx :: GhcMonad m => m NamePprCtx +getNamePprCtx = withSession $ \hsc_env -> do + return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env) + +-- | Container for information about a 'Module'. +data ModuleInfo = ModuleInfo { + minf_type_env :: TypeEnv, + minf_exports :: [AvailInfo], + minf_instances :: [ClsInst], + minf_iface :: Maybe ModIface, + minf_safe :: SafeHaskellMode, + minf_modBreaks :: Maybe InternalModBreaks + } + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X +getModuleInfo mdl = withSession $ \hsc_env -> do + if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env) + then liftIO $ getHomeModuleInfo hsc_env mdl + else liftIO $ getPackageModuleInfo hsc_env mdl + +getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getPackageModuleInfo hsc_env mdl + = do eps <- hscEPS hsc_env + iface <- hscGetModuleInterface hsc_env mdl + let + avails = mi_exports iface + pte = eps_PTE eps + tys = [ ty | name <- concatMap availNames avails, + Just ty <- [lookupTypeEnv pte name] ] + + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = avails, + minf_instances = error "getModuleInfo: instances for package module unimplemented", + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, + minf_modBreaks = Nothing + })) + +availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv +availsToGlobalRdrEnv hsc_env mod avails + = forceGlobalRdrEnv rdr_env + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + where + rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails) + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} + decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, + is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual, + is_dloc = srcLocSpan interactiveSrcLoc, + is_level = NormalLevel } + +getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getHomeModuleInfo hsc_env mdl = + HUG.lookupHugByModule mdl (hsc_HUG hsc_env) >>= \case + Nothing -> return Nothing + Just hmi -> do + let details = hm_details hmi + iface = hm_iface hmi + return (Just (ModuleInfo { + minf_type_env = md_types details, + minf_exports = md_exports details, + -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo. + minf_instances = instEnvElts $ md_insts details, + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, + minf_modBreaks = getModBreaks hmi + })) + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings minf = typeEnvElts (minf_type_env minf) + +modInfoExports :: ModuleInfo -> [Name] +modInfoExports minf = concatMap availNames $! minf_exports minf + +modInfoExportsWithSelectors :: ModuleInfo -> [Name] +modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf + +-- | Returns the instances defined by the specified module. +-- Warning: currently unimplemented for package modules. +modInfoInstances :: ModuleInfo -> [ClsInst] +modInfoInstances = minf_instances + +modInfoIsExportedName :: ModuleInfo -> Name -> Bool +modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) + +mkNamePprCtxForModule :: + GhcMonad m => + Module -> + ModuleInfo -> + m NamePprCtx +mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) + ptc = initPromotionTickContext (hsc_dflags hsc_env) + return name_ppr_ctx + +modInfoLookupName :: GhcMonad m => + ModuleInfo -> Name + -> m (Maybe TyThing) -- XXX: returns a Maybe X +modInfoLookupName minf name = withSession $ \hsc_env -> do + case lookupTypeEnv (minf_type_env minf) name of + Just tyThing -> return (Just tyThing) + Nothing -> liftIO (lookupType hsc_env name) + +modInfoIface :: ModuleInfo -> Maybe ModIface +modInfoIface = minf_iface + +-- | Retrieve module safe haskell mode +modInfoSafe :: ModuleInfo -> SafeHaskellMode +modInfoSafe = minf_safe + +modInfoModBreaks :: ModuleInfo -> Maybe InternalModBreaks +modInfoModBreaks = minf_modBreaks + diff --git a/GHC/Driver/Session/Units.hs b/GHC/Driver/Session/Units.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Session/Units.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TupleSections #-} +module GHC.Driver.Session.Units (initMake, initMulti) where + +-- The official GHC API +import qualified GHC +import GHC (parseTargetFiles, Ghc, GhcMonad(..)) + +import GHC.Driver.Env +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Phases +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Driver.Pipeline ( oneShot, compileFile ) +import GHC.Driver.Config.Diagnostic + +import GHC.Unit.Env +import GHC.Unit (UnitId) +import GHC.Unit.Home.PackageTable +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.State ( emptyUnitState ) +import qualified GHC.Unit.State as State + +import GHC.Types.SrcLoc +import GHC.Types.SourceError + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Monad ( liftIO, mapMaybeM ) +import GHC.Data.Maybe + +import System.IO +import System.Exit +import System.FilePath +import Control.Monad +import Data.List ( partition, (\\) ) +import qualified Data.Set as Set +import Prelude +import GHC.ResponseFile (expandResponse) +import Data.Bifunctor +import GHC.Data.Graph.Directed +import qualified Data.List.NonEmpty as NE + +-- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list. +removeRTS :: [String] -> [String] +removeRTS ("+RTS" : xs) = + case dropWhile (/= "-RTS") xs of + [] -> [] + (_ : ys) -> removeRTS ys +removeRTS (y:ys) = y : removeRTS ys +removeRTS [] = [] + +initMake :: [(String,Maybe Phase)] -> Ghc [(String, Maybe Phase)] +initMake srcs = do + let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs + + hsc_env <- GHC.getSession + + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then liftIO (oneShot hsc_env NoStop srcs) >> return [] + else do + + o_files <- mapMaybeM (\x -> liftIO $ compileFile hsc_env NoStop x) + non_hs_srcs + dflags <- GHC.getSessionDynFlags + let dflags' = dflags { ldInputs = map (FileOption "") o_files + ++ ldInputs dflags } + _ <- GHC.setSessionDynFlags dflags' + return hs_srcs + +initMulti :: NE.NonEmpty String + -> (DynFlags -> [(String,Maybe Phase)] -> [String] -> [String] -> IO ()) + -- ^ Function to lint initMulti DynFlags and sources. + -- In GHC, this is instanced to @checkOptions@. + -> Ghc ([(String, Maybe UnitId, Maybe Phase)]) +initMulti unitArgsFiles lintDynFlagsAndSrcs = do + hsc_env <- GHC.getSession + let logger = hsc_logger hsc_env + initial_dflags <- GHC.getSessionDynFlags + + dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do + when (verbosity initial_dflags > 2) (liftIO $ print f) + args <- liftIO $ expandResponse [f] + (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine logger initial_dflags (map (mkGeneralLocated f) (removeRTS args)) + handleSourceError (\e -> do + GHC.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns) + + let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args) + dflags4 = offsetDynFlags dflags3 + + let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs + + -- This is dubious as the whole unit environment won't be set-up correctly, but + -- that doesn't matter for what we use it for (linking and oneShot) + let dubious_hsc_env = hscSetFlags dflags4 hsc_env + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then liftIO (oneShot dubious_hsc_env NoStop srcs) >> return (dflags4, []) + else do + + o_files <- mapMaybeM (\x -> liftIO $ compileFile dubious_hsc_env NoStop x) + non_hs_srcs + let dflags5 = dflags4 { ldInputs = map (FileOption "") o_files + ++ ldInputs dflags4 } + + liftIO $ lintDynFlagsAndSrcs dflags5 srcs objs [] + + pure (dflags5, hs_srcs) + + let + unitDflags = NE.map fst dynFlagsAndSrcs + srcs = NE.map (\(dflags, lsrcs) -> map (uncurry (,Just $ homeUnitId_ dflags,)) lsrcs) dynFlagsAndSrcs + (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(file, _uid, phase) -> isHaskellishTarget (file, phase))) (NE.toList srcs)) + + checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags)) + + (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags + let home_units = HUG.allUnits initial_home_graph + + home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv + hue_flags = homeUnitEnv_dflags homeUnitEnv + dflags = homeUnitEnv_dflags homeUnitEnv + (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants + emptyHpt <- liftIO $ emptyHomePackageTable + pure $ HomeUnitEnv + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_hpt = emptyHpt + , homeUnitEnv_home_unit = Just home_unit + } + + checkUnitCycles initial_dflags home_unit_graph + + let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph + unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)) + let final_hsc_env = hsc_env { hsc_unit_env = unitEnv } + + GHC.setSession final_hsc_env + + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then do + liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode." + liftIO $ exitWith (ExitFailure 1) + else do + +{- + o_files <- liftIO $ mapMaybeM + (\(src, uid, mphase) -> + compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase) + ) + (concat non_hs_srcs) + -} + + -- MP: This should probably modify dflags for each unit? + --let dflags' = dflags { ldInputs = map (FileOption "") o_files + -- ++ ldInputs dflags } + return $ concat hs_srcs + +checkUnitCycles :: DynFlags -> HUG.HomeUnitGraph -> Ghc () +checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph) + where + + processSCCs [] = return () + processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs + processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids) + + + cycle_err uids = + hang (text "Units form a dependency cycle:") + 2 + (one_err uids) + + one_err uids = vcat $ + (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start) + ++ [text "-" <+> ppr final] + where + start = init uids + final = last uids + +-- | Check that we don't have multiple units with the same UnitId. +checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc () +checkDuplicateUnits dflags flags = + unless (null duplicate_ids) + (throwGhcException $ CmdLineError $ showSDoc dflags multi_err) + + where + uids = map (second homeUnitId_) flags + deduplicated_uids = ordNubOn snd uids + duplicate_ids = Set.fromList (map snd uids \\ map snd deduplicated_uids) + + duplicate_flags = filter (flip Set.member duplicate_ids . snd) uids + + one_err (fp, home_uid) = text "-" <+> ppr home_uid <+> text "defined in" <+> text fp + + multi_err = + hang (text "Multiple units with the same unit-id:") + 2 + (vcat (map one_err duplicate_flags)) + + +offsetDynFlags :: DynFlags -> DynFlags +offsetDynFlags dflags = + dflags { hiDir = c hiDir + , objectDir = c objectDir + , stubDir = c stubDir + , hieDir = c hieDir + , dumpDir = c dumpDir } + + where + c f = augment_maybe (f dflags) + + augment_maybe Nothing = Nothing + augment_maybe (Just f) = Just (augment f) + augment f | isRelative f, Just offset <- workingDirectory dflags = offset f + | otherwise = f + + +createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId) +createUnitEnvFromFlags unitDflags = do + unitEnvList <- forM unitDflags $ \dflags -> do + emptyHpt <- emptyHomePackageTable + let newInternalUnitEnv = + HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt Nothing + return (homeUnitId_ dflags, newInternalUnitEnv) + let activeUnit = fst $ NE.head unitEnvList + return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) + + diff --git a/GHC/Hs.hs b/GHC/Hs.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs.hs @@ -0,0 +1,148 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{Haskell abstract syntax definition} + +This module glues together the pieces of the Haskell abstract syntax, +which is declared in the various \tr{Hs*} modules. This module, +therefore, is almost nothing but re-exporting. +-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data +{-# LANGUAGE DataKinds #-} + +module GHC.Hs ( + module Language.Haskell.Syntax, + module GHC.Hs.Binds, + module GHC.Hs.Decls, + module GHC.Hs.Expr, + module GHC.Hs.ImpExp, + module GHC.Hs.Lit, + module GHC.Hs.Pat, + module GHC.Hs.Type, + module GHC.Hs.Utils, + module GHC.Hs.Doc, + module GHC.Hs.Extension, + module GHC.Parser.Annotation, + Fixity, + + HsModule(..), AnnsModule(..), + HsParsedModule(..), XModulePs(..) +) where + +-- friends: +import GHC.Prelude + +import GHC.Hs.Decls +import GHC.Hs.Binds +import GHC.Hs.Expr +import GHC.Hs.ImpExp +import GHC.Hs.Lit +import Language.Haskell.Syntax +import GHC.Hs.Extension +import GHC.Parser.Annotation +import GHC.Hs.Pat +import GHC.Hs.Type +import GHC.Hs.Utils +import GHC.Hs.Doc +import GHC.Hs.Instances () -- For Data instances + +-- others: +import GHC.Utils.Outputable +import GHC.Types.Fixity ( Fixity ) +import GHC.Types.SrcLoc +import GHC.Unit.Module.Warnings + +-- libraries: +import Data.Data hiding ( Fixity ) + +-- | Haskell Module extension point: GHC specific +data XModulePs + = XModulePs { + hsmodAnn :: EpAnn AnnsModule, + hsmodLayout :: EpLayout, + -- ^ Layout info for the module. + -- For incomplete modules (e.g. the output of parseHeader), it is EpNoLayout. + hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs), + -- ^ reason\/explanation for warning/deprecation of this module + hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs) + -- ^ Haddock module info and description, unparsed + } + deriving Data + +type instance XCModule GhcPs = XModulePs +type instance XCModule GhcRn = DataConCantHappen +type instance XCModule GhcTc = DataConCantHappen +type instance XXModule p = DataConCantHappen + +deriving instance Data (HsModule GhcPs) + +data AnnsModule + = AnnsModule { + am_sig :: EpToken "signature", + am_mod :: EpToken "module", + am_where :: EpToken "where", + am_decls :: [TrailingAnn], -- ^ Semis before the start of top decls + am_cs :: [LEpaComment], -- ^ Comments before start of top decl, + -- used in exact printing only + am_eof :: Maybe (RealSrcSpan, RealSrcSpan) -- ^ End of file and end of prior token + } deriving (Data, Eq) + +instance NoAnn AnnsModule where + noAnn = AnnsModule NoEpTok NoEpTok NoEpTok [] [] Nothing + +instance Outputable (HsModule GhcPs) where + ppr (HsModule { hsmodExt = XModulePs { hsmodHaddockModHeader = mbDoc } + , hsmodName = Nothing + , hsmodImports = imports + , hsmodDecls = decls }) + = pprMaybeWithDoc mbDoc $ pp_nonnull imports + $$ pp_nonnull decls + + ppr (HsModule { hsmodExt = XModulePs { hsmodDeprecMessage = deprec + , hsmodHaddockModHeader = mbDoc } + , hsmodName = (Just name) + , hsmodExports = exports + , hsmodImports = imports + , hsmodDecls = decls }) + = pprMaybeWithDoc mbDoc $ + vcat + [ case exports of + Nothing -> pp_header (text "where") + Just es -> vcat [ + pp_header lparen, + nest 8 (pprWithCommas ppr (unLoc es)), + nest 4 (text ") where") + ], + pp_nonnull imports, + pp_nonnull decls + ] + where + pp_header rest = case deprec of + Nothing -> pp_modname <+> rest + Just d -> vcat [ pp_modname, ppr d, rest ] + + pp_modname = text "module" <+> ppr name + +pp_nonnull :: Outputable t => [t] -> SDoc +pp_nonnull [] = empty +pp_nonnull xs = vcat (map ppr xs) + +data HsParsedModule = HsParsedModule { + hpm_module :: Located (HsModule GhcPs), + hpm_src_files :: [FilePath] + -- ^ extra source files (e.g. from #includes). The lexer collects + -- these from '# ' pragmas, which the C preprocessor + -- leaves behind. These files and their timestamps are stored in + -- the .hi file, so that we can force recompilation if any of + -- them change (#3589) + } diff --git a/GHC/Hs/Basic.hs b/GHC/Hs/Basic.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Basic.hs @@ -0,0 +1,56 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Fixity +module GHC.Hs.Basic + ( module Language.Haskell.Syntax.Basic + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Utils.Binary + +import Data.Data () + +import Language.Haskell.Syntax.Basic + +instance Outputable LexicalFixity where + ppr Prefix = text "Prefix" + ppr Infix = text "Infix" + +instance Outputable FixityDirection where + ppr InfixL = text "infixl" + ppr InfixR = text "infixr" + ppr InfixN = text "infix" + +instance Outputable Fixity where + ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] + + +instance Binary Fixity where + put_ bh (Fixity aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (Fixity aa ab) + +------------------------ + +instance Binary FixityDirection where + put_ bh InfixL = + putByte bh 0 + put_ bh InfixR = + putByte bh 1 + put_ bh InfixN = + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return InfixL + 1 -> return InfixR + _ -> return InfixN diff --git a/GHC/Hs/Binds.hs b/GHC/Hs/Binds.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Binds.hs @@ -0,0 +1,1061 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} -- used to pass the phase to ppr_mult_ann since MultAnn is a type family +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension + +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[HsBinds]{Abstract syntax: top-level bindings and signatures} + +Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. +-} + +module GHC.Hs.Binds + ( module Language.Haskell.Syntax.Binds + , module GHC.Hs.Binds + , HsRuleBndrsAnn(..) + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Binds +import Language.Haskell.Syntax.Expr( LHsExpr ) + +import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprLExpr, pprFunBind, pprPatBind ) +import {-# SOURCE #-} GHC.Hs.Pat (pprLPat ) + +import GHC.Data.BooleanFormula ( LBooleanFormula, pprBooleanFormulaNormal ) +import GHC.Types.Tickish +import GHC.Hs.Extension +import GHC.Parser.Annotation +import GHC.Hs.Type +import GHC.Tc.Types.Evidence +import GHC.Core.Type +import GHC.Types.Name.Set +import GHC.Types.Basic +import GHC.Types.SourceText +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Var +import GHC.Types.Name + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc ((<||>)) + +import Data.Function +import Data.List (sortBy) +import Data.Data (Data) + +{- +************************************************************************ +* * +\subsection{Bindings: @BindGroup@} +* * +************************************************************************ + +Global bindings (where clauses) +-} + +-- the ...LR datatypes are parameterized by two id types, +-- one for the left and one for the right. + +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = EpAnn (AnnList (EpToken "where")) +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = EpAnn (AnnList (EpToken "where")) +type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen + +-- --------------------------------------------------------------------- +-- Deal with ValBindsOut + +-- TODO: make this the only type for ValBinds +data NHsValBindsLR idL + = NValBinds + [(RecFlag, LHsBinds idL)] + [LSig GhcRn] + +type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag +type instance XXValBindsLR (GhcPass pL) pR + = NHsValBindsLR (GhcPass pL) + +-- --------------------------------------------------------------------- + +type instance XFunBind (GhcPass pL) GhcPs = NoExtField +type instance XFunBind (GhcPass pL) GhcRn = NameSet +-- ^ After the renamer (but before the type-checker), the FunBind +-- extension field contains the locally-bound free variables of this +-- defn. See Note [Bind free vars] + +type instance XFunBind (GhcPass pL) GhcTc = (HsWrapper, [CoreTickish]) +-- ^ After the type-checker, the FunBind extension field contains +-- the ticks to put on the rhs, if any, and a coercion from the +-- type of the MatchGroup to the type of the Id. +-- Example: +-- +-- @ +-- f :: Int -> forall a. a -> a +-- f x y = y +-- @ +-- +-- Then the MatchGroup will have type (Int -> a' -> a') +-- (with a free type variable a'). The coercion will take +-- a CoreExpr of this type and convert it to a CoreExpr of +-- type Int -> forall a'. a' -> a' +-- Notice that the coercion captures the free a'. + +type instance XPatBind GhcPs (GhcPass pR) = NoExtField +type instance XPatBind GhcRn (GhcPass pR) = NameSet -- See Note [Bind free vars] +type instance XPatBind GhcTc (GhcPass pR) = + ( Type -- Type of the GRHSs + , ( [CoreTickish] -- Ticks to put on the rhs, if any + , [[CoreTickish]] ) ) -- and ticks to put on the bound variables. + +type instance XVarBind (GhcPass pL) (GhcPass pR) = XVarBindGhc pL pR +type family XVarBindGhc pL pR where + XVarBindGhc 'Typechecked 'Typechecked = NoExtField + XVarBindGhc _ _ = DataConCantHappen + +type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField + +type instance XXHsBindsLR GhcPs pR = DataConCantHappen +type instance XXHsBindsLR GhcRn pR = DataConCantHappen +type instance XXHsBindsLR GhcTc pR = AbsBinds + +type instance XPSB (GhcPass idL) GhcPs = AnnPSB +type instance XPSB (GhcPass idL) GhcRn = NameSet -- Post renaming, FVs. See Note [Bind free vars] +type instance XPSB (GhcPass idL) GhcTc = NameSet + +type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = DataConCantHappen + +data AnnPSB + = AnnPSB { + ap_pattern :: EpToken "pattern", + ap_openc :: Maybe (EpToken "{"), + ap_closec :: Maybe (EpToken "}"), + ap_larrow :: Maybe (EpUniToken "<-" "←"), + ap_equal :: Maybe (EpToken "=") + } deriving Data + +instance NoAnn AnnPSB where + noAnn = AnnPSB noAnn noAnn noAnn noAnn noAnn + +setTcMultAnn :: Mult -> HsMultAnn GhcRn -> HsMultAnn GhcTc +setTcMultAnn mult (HsLinearAnn _) = HsLinearAnn mult +setTcMultAnn mult (HsExplicitMult _ p) = HsExplicitMult mult p +setTcMultAnn mult (HsUnannotated _) = HsUnannotated mult + +getTcMultAnn :: HsMultAnn GhcTc -> Mult +getTcMultAnn (HsLinearAnn mult) = mult +getTcMultAnn (HsExplicitMult mult _) = mult +getTcMultAnn (HsUnannotated mult) = mult + +-- --------------------------------------------------------------------- + +-- | Typechecked, generalised bindings, used in the output to the type checker. +-- See Note [AbsBinds]. +data AbsBinds = AbsBinds { + abs_tvs :: [TyVar], + abs_ev_vars :: [EvVar], -- ^ Includes equality constraints + + -- | AbsBinds only gets used when idL = idR after renaming, + -- but these need to be idL's for the collect... code in HsUtil + -- to have the right type + abs_exports :: [ABExport], + + -- | Evidence bindings + -- Why a list? See "GHC.Tc.TyCl.Instance" + -- Note [Typechecking plan for instance declarations] + abs_ev_binds :: [TcEvBinds], + + -- | Typechecked user bindings + abs_binds :: LHsBinds GhcTc, + + abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds] + } + + + -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] + -- + -- Creates bindings for (polymorphic, overloaded) poly_f + -- in terms of monomorphic, non-overloaded mono_f + -- + -- Invariants: + -- 1. 'binds' binds mono_f + -- 2. ftvs is a subset of tvs + -- 3. ftvs includes all tyvars free in ds + -- + -- See Note [AbsBinds] + +-- | Abstraction Bindings Export +data ABExport + = ABE { abe_poly :: Id -- ^ Any INLINE pragma is attached to this Id + , abe_mono :: Id + , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] + -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly + , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas + } + +{- +Note [AbsBinds] +~~~~~~~~~~~~~~~ +The AbsBinds constructor is used in the output of the type checker, to +record *typechecked* and *generalised* bindings. Specifically + + AbsBinds { abs_tvs = tvs + , abs_ev_vars = [d1,d2] + , abs_exports = [ABE { abe_poly = fp, abe_mono = fm + , abe_wrap = fwrap } + ABE { slly for g } ] + , abs_ev_binds = DBINDS + , abs_binds = BIND[fm,gm] } + +where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means + + fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ] + [ ; BIND[fm,gm] } ] + [ in fm ] + + gp = ...same again, with gm instead of fm + +The 'fwrap' is an impedance-matcher that typically does nothing; see +Note [ABExport wrapper]. + +This is a pretty bad translation, because it duplicates all the bindings. +So the desugarer tries to do a better job: + + fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of + (fm,gm) -> fm + ..ditto for gp.. + + tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND } + in (fm,gm) + +In general: + + * abs_tvs are the type variables over which the binding group is + generalised + * abs_ev_var are the evidence variables (usually dictionaries) + over which the binding group is generalised + * abs_binds are the monomorphic bindings + * abs_ex_binds are the evidence bindings that wrap the abs_binds + * abs_exports connects the monomorphic Ids bound by abs_binds + with the polymorphic Ids bound by the AbsBinds itself. + +For example, consider a module M, with this top-level binding, where +there is no type signature for M.reverse, + M.reverse [] = [] + M.reverse (x:xs) = M.reverse xs ++ [x] + +In Hindley-Milner, a recursive binding is typechecked with the +*recursive* uses being *monomorphic*. So after typechecking *and* +desugaring we will get something like this + + M.reverse :: forall a. [a] -> [a] + = /\a. letrec + reverse :: [a] -> [a] = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] + in reverse + +Notice that 'M.reverse' is polymorphic as expected, but there is a local +definition for plain 'reverse' which is *monomorphic*. The type variable +'a' scopes over the entire letrec. + +That's after desugaring. What about after type checking but before +desugaring? That's where AbsBinds comes in. It looks like this: + + AbsBinds { abs_tvs = [a] + , abs_ev_vars = [] + , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a], + , abe_mono = reverse :: [a] -> [a]}] + , abs_ev_binds = {} + , abs_binds = { reverse :: [a] -> [a] + = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] } } + +Here, + + * abs_tvs says what type variables are abstracted over the binding + group, just 'a' in this case. + * abs_binds is the *monomorphic* bindings of the group + * abs_exports describes how to get the polymorphic Id 'M.reverse' + from the monomorphic one 'reverse' + +Notice that the *original* function (the polymorphic one you thought +you were defining) appears in the abe_poly field of the +abs_exports. The bindings in abs_binds are for fresh, local, Ids with +a *monomorphic* Id. + +If there is a group of mutually recursive (see Note [Polymorphic +recursion]) functions without type signatures, we get one AbsBinds +with the monomorphic versions of the bindings in abs_binds, and one +element of abe_exports for each variable bound in the mutually +recursive group. This is true even for pattern bindings. Example: + (f,g) = (\x -> x, f) +After type checking we get + AbsBinds { abs_tvs = [a] + , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a + , abe_mono = f :: a -> a } + , ABE { abe_poly = M.g :: forall a. a -> a + , abe_mono = g :: a -> a }] + , abs_binds = { (f,g) = (\x -> x, f) } + +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + Rec { f x = ...(g ef)... + + ; g :: forall a. [a] -> [a] + ; g y = ...(f eg)... } + +These bindings /are/ mutually recursive (f calls g, and g calls f). +But we can use the type signature for g to break the recursion, +like this: + + 1. Add g :: forall a. [a] -> [a] to the type environment + + 2. Typecheck the definition of f, all by itself, + including generalising it to find its most general + type, say f :: forall b. b -> b -> [b] + + 3. Extend the type environment with that type for f + + 4. Typecheck the definition of g, all by itself, + checking that it has the type claimed by its signature + +Steps 2 and 4 each generate a separate AbsBinds, so we end +up with + Rec { AbsBinds { ...for f ... } + ; AbsBinds { ...for g ... } } + +This approach allows both f and to call each other +polymorphically, even though only g has a signature. + +We get an AbsBinds that encompasses multiple source-program +bindings only when + * Each binding in the group has at least one binder that + lacks a user type signature + * The group forms a strongly connected component + + +Note [The abs_sig field of AbsBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The abs_sig field supports a couple of special cases for bindings. +Consider + + x :: Num a => (# a, a #) + x = (# 3, 4 #) + +The general desugaring for AbsBinds would give + + x = /\a. \ ($dNum :: Num a) -> + letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in + xm + +But that has an illegal let-binding for an unboxed tuple. In this +case we'd prefer to generate the (more direct) + + x = /\ a. \ ($dNum :: Num a) -> + (# fromInteger $dNum 3, fromInteger $dNum 4 #) + +A similar thing happens with representation-polymorphic defns +(#11405): + + undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a + undef = error "undef" + +Again, the vanilla desugaring gives a local let-binding for a +representation-polymorphic (undefm :: a), which is illegal. But +again we can desugar without a let: + + undef = /\ a. \ (d:HasCallStack) -> error a d "undef" + +The abs_sig field supports this direct desugaring, with no local +let-binding. When abs_sig = True + + * the abs_binds is single FunBind + + * the abs_exports is a singleton + + * we have a complete type sig for binder + and hence the abs_binds is non-recursive + (it binds the mono_id but refers to the poly_id + +These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to +generate code without a let-binding. + +Note [ABExport wrapper] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (f,g) = (\x.x, \y.y) +This ultimately desugars to something like this: + tup :: forall a b. (a->a, b->b) + tup = /\a b. (\x:a.x, \y:b.y) + f :: forall a. a -> a + f = /\a. case tup a Any of + (fm::a->a,gm:Any->Any) -> fm + ...similarly for g... + +The abe_wrap field deals with impedance-matching between + (/\a b. case tup a b of { (f,g) -> f }) +and the thing we really want, which may have fewer type +variables. The action happens in GHC.Tc.Gen.Bind.mkExport. + +Note [Bind free vars] +~~~~~~~~~~~~~~~~~~~~~ +The extension fields of FunBind, PatBind and PatSynBind at GhcRn records the free +variables of the definition. It is used for the following purposes: + +a) Dependency analysis prior to type checking + (see GHC.Tc.Gen.Bind.tc_group) + +b) Deciding whether we can do generalisation of the binding + (see GHC.Tc.Gen.Bind.decideGeneralisationPlan) + +c) Deciding whether the binding can be used in static forms + (see GHC.Tc.Gen.Expr.checkClosedInStaticForm for the HsStatic case and + GHC.Tc.Gen.Bind.isClosedBndrGroup). + +Specifically, + + * it includes all free vars that are defined in this module + (including top-level things and lexically scoped type variables) + + * it excludes imported vars; this is just to keep the set smaller + + * Before renaming, and after typechecking, the field is unused; + it's just an error thunk +-} + +instance (OutputableBndrId pl, OutputableBndrId pr) + => Outputable (HsLocalBindsLR (GhcPass pl) (GhcPass pr)) where + ppr (HsValBinds _ bs) = ppr bs + ppr (HsIPBinds _ bs) = ppr bs + ppr (EmptyLocalBinds _) = empty + +instance (OutputableBndrId pl, OutputableBndrId pr) + => Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where + ppr (ValBinds _ binds sigs) + = pprDeclList (pprLHsBindsForUser binds sigs) + + ppr (XValBindsLR (NValBinds sccs sigs)) + = getPprDebug $ \case + -- Print with sccs showing + True -> vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) + False -> pprDeclList (pprLHsBindsForUser (concat (map snd sccs)) sigs) + where + ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds + pp_rec Recursive = text "rec" + pp_rec NonRecursive = text "nonrec" + +pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprLHsBinds binds + | isEmptyLHsBinds binds = empty + | otherwise = pprDeclList (map ppr binds) + +pprLHsBindsForUser :: (OutputableBndrId idL, + OutputableBndrId idR, + OutputableBndrId id2) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc] +-- pprLHsBindsForUser is different to pprLHsBinds because +-- a) No braces: 'let' and 'where' include a list of HsBindGroups +-- and we don't want several groups of bindings each +-- with braces around +-- b) Sort by location before printing +-- c) Include signatures +pprLHsBindsForUser binds sigs + = map snd (sort_by_loc decls) + where + + decls :: [(SrcSpan, SDoc)] + decls = [(locA loc, ppr sig) | L loc sig <- sigs] ++ + [(locA loc, ppr bind) | L loc bind <- binds] + + sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls + +pprDeclList :: [SDoc] -> SDoc -- Braces with a space +-- Print a bunch of declarations +-- One could choose { d1; d2; ... }, using 'sep' +-- or d1 +-- d2 +-- .. +-- using vcat +-- At the moment we chose the latter +-- Also we do the 'pprDeeperList' thing. +pprDeclList ds = pprDeeperList vcat ds + +------------ +emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) +emptyLocalBinds = EmptyLocalBinds noExtField + +eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool +eqEmptyLocalBinds (EmptyLocalBinds _) = True +eqEmptyLocalBinds _ = False + +isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs + +emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) +emptyValBindsIn = ValBinds NoAnnSortKey [] [] +emptyValBindsOut = XValBindsLR (NValBinds [] []) + +emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR +emptyLHsBinds = [] + +isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool +isEmptyLHsBinds = null + +------------ +plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) + -> HsValBinds(GhcPass a) +plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) + = ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2) +plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) + (XValBindsLR (NValBinds ds2 sigs2)) + = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) +plusHsValBinds _ _ + = panic "HsBinds.plusHsValBinds" + +instance (OutputableBndrId pl, OutputableBndrId pr) + => Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where + ppr mbind = ppr_monobind mbind + +ppr_monobind :: forall idL idR. + (OutputableBndrId idL, OutputableBndrId idR) + => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc + +ppr_monobind (PatBind { pat_lhs = pat, pat_mult = mult_ann, pat_rhs = grhss }) + = pprHsMultAnn @idL mult_ann + <+> pprPatBind pat grhss +ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) + = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] +ppr_monobind (FunBind { fun_id = fun, + fun_matches = matches, + fun_ext = ext }) + = pprTicks empty ticksDoc + $$ whenPprDebug (pprBndr LetBind (unLoc fun)) + $$ pprFunBind matches + $$ whenPprDebug (pprIfTc @idR $ wrapDoc) + where + ticksDoc :: SDoc + ticksDoc = case ghcPass @idR of + GhcPs -> empty + GhcRn -> empty + GhcTc | (_, ticks) <- ext -> + if null ticks + then empty + else text "-- ticks = " <> ppr ticks + wrapDoc :: SDoc + wrapDoc = case ghcPass @idR of + GhcPs -> empty + GhcRn -> empty + GhcTc | (wrap, _) <- ext -> ppr wrap + + +ppr_monobind (PatSynBind _ psb) = ppr psb +ppr_monobind (XHsBindsLR b) = case ghcPass @idL of + GhcTc -> ppr_absbinds b + where + ppr_absbinds (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars + , abs_exports = exports, abs_binds = val_binds + , abs_ev_binds = ev_binds }) + = sdocOption sdocPrintTypecheckerElaboration $ \case + False -> pprLHsBinds val_binds + True -> -- Show extra information (bug number: #10662) + hang (text "AbsBinds" + <+> sep [ brackets (interpp'SP tyvars) + , brackets (interpp'SP dictvars) ]) + 2 $ braces $ vcat + [ text "Exports:" <+> + brackets (sep (punctuate comma (map ppr exports))) + , text "Exported types:" <+> + vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] + , text "Binds:" <+> pprLHsBinds val_binds + , pprIfTc @idR (text "Evidence:" <+> ppr ev_binds) + ] + +instance Outputable ABExport where + ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) + = vcat [ sep [ ppr gbl, nest 2 (text "<=" <+> ppr lcl) ] + , nest 2 (pprTcSpecPrags prags) + , ppr $ nest 2 (text "wrap:" <+> ppr wrap) ] + +instance (OutputableBndrId l, OutputableBndrId r) + => Outputable (PatSynBind (GhcPass l) (GhcPass r)) where + ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, + psb_dir = dir }) + = ppr_lhs <+> ppr_rhs + where + ppr_lhs = text "pattern" <+> ppr_details + ppr_simple syntax = syntax <+> pprLPat pat + + ppr_details = case details of + InfixCon v1 v2 -> hsep [ppr_v v1, pprInfixOcc psyn, ppr_v v2] + where + ppr_v v = case ghcPass @r of + GhcPs -> ppr v + GhcRn -> ppr v + GhcTc -> ppr v + PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr_v vs) + where + ppr_v v = case ghcPass @r of + GhcPs -> ppr v + GhcRn -> ppr v + GhcTc -> ppr v + RecCon vs -> pprPrefixOcc psyn + <> braces (sep (punctuate comma (map ppr_v vs))) + where + ppr_v v = case ghcPass @r of + GhcPs -> ppr v + GhcRn -> ppr v + GhcTc -> ppr v + + ppr_rhs = case dir of + Unidirectional -> ppr_simple larrow + ImplicitBidirectional -> ppr_simple equals + ExplicitBidirectional mg -> ppr_simple larrow <+> text "where" $$ + (nest 2 $ pprFunBind mg) + +pprTicks :: SDoc -> SDoc -> SDoc +-- Print stuff about ticks only when -dppr-debug is on, to avoid +-- them appearing in error messages (from the desugarer); see # 3263 +-- Also print ticks in dumpStyle, so that -ddump-hpc actually does +-- something useful. +pprTicks pp_no_debug pp_when_debug + = getPprStyle $ \sty -> + getPprDebug $ \debug -> + if debug || dumpStyle sty + then pp_when_debug + else pp_no_debug + +instance Outputable (XRecGhc (IdGhcP p)) => Outputable (RecordPatSynField (GhcPass p)) where + ppr (RecordPatSynField { recordPatSynField = v }) = ppr v + +{- +************************************************************************ +* * + Implicit parameter bindings +* * +************************************************************************ +-} + +type instance XIPBinds GhcPs = NoExtField +type instance XIPBinds GhcRn = NoExtField +type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the + -- implicit parameters + + +type instance XXHsIPBinds (GhcPass p) = DataConCantHappen + +isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool +isEmptyIPBindsPR (IPBinds _ is) = null is + +isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool +isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds + +-- EPA annotations in GhcPs, dictionary Id in GhcTc +type instance XCIPBind GhcPs = EpToken "=" +type instance XCIPBind GhcRn = NoExtField +type instance XCIPBind GhcTc = Id +type instance XXIPBind (GhcPass p) = DataConCantHappen + +instance OutputableBndrId p + => Outputable (HsIPBinds (GhcPass p)) where + ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs) + $$ whenPprDebug (pprIfTc @p $ ppr ds) + +instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where + ppr (IPBind x (L _ ip) rhs) = name <+> equals <+> pprExpr (unLoc rhs) + where name = case ghcPass @p of + GhcPs -> pprBndr LetBind ip + GhcRn -> pprBndr LetBind ip + GhcTc -> pprBndr LetBind x + +{- +************************************************************************ +* * +\subsection{@Sig@: type signatures and value-modifying user pragmas} +* * +************************************************************************ +-} + +type instance XTypeSig (GhcPass p) = AnnSig +type instance XPatSynSig (GhcPass p) = AnnSig +type instance XClassOpSig (GhcPass p) = AnnSig +type instance XFixSig (GhcPass p) = ((EpaLocation, Maybe EpaLocation), SourceText) +type instance XInlineSig (GhcPass p) = (EpaLocation, EpToken "#-}", ActivationAnn) +type instance XSpecSig (GhcPass p) = AnnSpecSig +type instance XSpecInstSig (GhcPass p) = ((EpaLocation, EpToken "instance", EpToken "#-}"), SourceText) +type instance XMinimalSig (GhcPass p) = ((EpaLocation, EpToken "#-}"), SourceText) +type instance XSCCFunSig (GhcPass p) = ((EpaLocation, EpToken "#-}"), SourceText) +type instance XCompleteMatchSig (GhcPass p) = ((EpaLocation, Maybe TokDcolon, EpToken "#-}"), SourceText) + +type instance XSpecSigE GhcPs = AnnSpecSig +type instance XSpecSigE GhcRn = Name +type instance XSpecSigE GhcTc = NoExtField + + -- SourceText: See Note [Pragma source text] in "GHC.Types.SourceText" +type instance XXSig GhcPs = DataConCantHappen +type instance XXSig GhcRn = IdSig +type instance XXSig GhcTc = IdSig + +type instance XFixitySig GhcPs = NamespaceSpecifier +type instance XFixitySig GhcRn = NamespaceSpecifier +type instance XFixitySig GhcTc = NoExtField +type instance XXFixitySig (GhcPass p) = DataConCantHappen + +data AnnSpecSig + = AnnSpecSig { + ass_open :: EpaLocation, + ass_close :: EpToken "#-}", + ass_dcolon :: Maybe TokDcolon, -- Only for old SpecSig, remove when it goes + ass_act :: ActivationAnn + } deriving Data + +instance NoAnn AnnSpecSig where + noAnn = AnnSpecSig noAnn noAnn noAnn noAnn + +data ActivationAnn + = ActivationAnn { + aa_openc :: EpToken "[", + aa_closec :: EpToken "]", + aa_tilde :: Maybe (EpToken "~"), + aa_val :: Maybe EpaLocation + } deriving (Data, Eq) + +instance NoAnn ActivationAnn where + noAnn = ActivationAnn noAnn noAnn noAnn noAnn + + +-- | Optional namespace specifier for fixity signatures, +-- WARNINIG and DEPRECATED pragmas. +-- +-- Examples: +-- +-- {-# WARNING in "x-partial" data Head "don't use this pattern synonym" #-} +-- -- ↑ DataNamespaceSpecifier +-- +-- {-# DEPRECATED type D "This type was deprecated" #-} +-- -- ↑ TypeNamespaceSpecifier +-- +-- infixr 6 data $ +-- -- ↑ DataNamespaceSpecifier +data NamespaceSpecifier + = NoNamespaceSpecifier + | TypeNamespaceSpecifier (EpToken "type") + | DataNamespaceSpecifier (EpToken "data") + deriving (Eq, Data) + +-- | Check if namespace specifiers overlap, i.e. if they are equal or +-- if at least one of them doesn't specify a namespace +overlappingNamespaceSpecifiers :: NamespaceSpecifier -> NamespaceSpecifier -> Bool +overlappingNamespaceSpecifiers NoNamespaceSpecifier _ = True +overlappingNamespaceSpecifiers _ NoNamespaceSpecifier = True +overlappingNamespaceSpecifiers TypeNamespaceSpecifier{} TypeNamespaceSpecifier{} = True +overlappingNamespaceSpecifiers DataNamespaceSpecifier{} DataNamespaceSpecifier{} = True +overlappingNamespaceSpecifiers _ _ = False + +-- | Check if namespace is covered by a namespace specifier: +-- * NoNamespaceSpecifier covers both namespaces +-- * TypeNamespaceSpecifier covers the type namespace only +-- * DataNamespaceSpecifier covers the data namespace only +coveredByNamespaceSpecifier :: NamespaceSpecifier -> NameSpace -> Bool +coveredByNamespaceSpecifier NoNamespaceSpecifier = const True +coveredByNamespaceSpecifier TypeNamespaceSpecifier{} = isTcClsNameSpace <||> isTvNameSpace +coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace +instance Outputable NamespaceSpecifier where + ppr NoNamespaceSpecifier = empty + ppr TypeNamespaceSpecifier{} = text "type" + ppr DataNamespaceSpecifier{} = text "data" + +-- | A type signature in generated code, notably the code +-- generated for record selectors. We simply record the desired Id +-- itself, replete with its name, type and IdDetails. Otherwise it's +-- just like a type signature: there should be an accompanying binding +newtype IdSig = IdSig { unIdSig :: Id } + deriving Data + +data AnnSig + = AnnSig { + asDcolon :: EpUniToken "::" "∷", + asPattern :: Maybe (EpToken "pattern"), + asDefault :: Maybe (EpToken "default") + } deriving Data + +instance NoAnn AnnSig where + noAnn = AnnSig noAnn noAnn noAnn + +-- | Type checker Specialisation Pragmas +-- +-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker +-- to the desugarer +data TcSpecPrags + = IsDefaultMethod -- ^ Super-specialised: a default method should + -- be macro-expanded at every call site + | SpecPrags [LTcSpecPrag] + +-- | Located Type checker Specialisation Pragmas +type LTcSpecPrag = Located TcSpecPrag + +-- | Type checker Specialisation Pragma +-- +-- This data type is used to communicate between the typechecker and +-- the desugarer. +data TcSpecPrag + -- | Old-form specialise pragma + = SpecPrag + Id + -- ^ 'Id' to be specialised + HsWrapper + -- ^ wrapper that specialises the polymorphic function + InlinePragma + -- ^ inlining spec for the specialised function + -- | New-form specialise pragma + | SpecPragE + { spe_fn_nm :: Name + -- ^ 'Name' of the 'Id' being specialised + , spe_fn_id :: Id + -- ^ 'Id' being specialised + -- + -- Note that 'spe_fn_nm' may differ from @'idName' 'spe_fn_id'@ + -- in the case of instance methods, where the 'Name' is the + -- class-op selector but the 'spe_fn_id' is that for the local method + , spe_inl :: InlinePragma + -- ^ (optional) INLINE annotation and activation phase annotation + + , spe_bndrs :: [Var] + -- ^ TyVars, EvVars, and Ids + , spe_call :: LHsExpr GhcTc + -- ^ The type-checked specialise expression + } + +noSpecPrags :: TcSpecPrags +noSpecPrags = SpecPrags [] + +hasSpecPrags :: TcSpecPrags -> Bool +hasSpecPrags (SpecPrags ps) = not (null ps) +hasSpecPrags IsDefaultMethod = False + +isDefaultMethod :: TcSpecPrags -> Bool +isDefaultMethod IsDefaultMethod = True +isDefaultMethod (SpecPrags {}) = False + +instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where + ppr sig = ppr_sig sig + +ppr_sig :: forall p. OutputableBndrId p + => Sig (GhcPass p) -> SDoc +ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (ClassOpSig _ is_deflt vars ty) + | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) + | otherwise = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (FixSig _ fix_sig) = ppr fix_sig + +ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_src = src, inl_inline = spec })) + = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc $ + pprSpec (unLoc var) (interpp'SP ty) inl + where + pragmaSrc = case spec of + NoUserInlinePrag -> "{-# " ++ extractSpecPragName src + _ -> "{-# " ++ extractSpecPragName src ++ "_INLINE" + +ppr_sig (SpecSigE _ bndrs spec_e inl@(InlinePragma { inl_src = src, inl_inline = spec })) + = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc $ + pp_inl <+> hang (ppr bndrs) 2 (pprLExpr spec_e) + where + -- SPECIALISE or SPECIALISE_INLINE + pragmaSrc = case spec of + NoUserInlinePrag -> "{-# " ++ extractSpecPragName src + _ -> "{-# " ++ extractSpecPragName src ++ "_INLINE" + + pp_inl | isDefaultInlinePragma inl = empty + | otherwise = pprInline inl + +ppr_sig (InlineSig _ var inl) + = ppr_pfx <+> pprInline inl <+> pprPrefixOcc (unLoc var) <+> text "#-}" + where + ppr_pfx = case inlinePragmaSource inl of + SourceText src -> ftext src + NoSourceText -> text "{-#" <+> inlinePragmaName (inl_inline inl) + +ppr_sig (SpecInstSig (_, src) ty) + = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty) +ppr_sig (MinimalSig (_, src) bf) + = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) +ppr_sig (PatSynSig _ names sig_ty) + = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) +ppr_sig (SCCFunSig (_, src) fn mlabel) + = pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel ) + where + ppr_fn = case ghcPass @p of + GhcPs -> ppr fn + GhcRn -> ppr fn + GhcTc -> ppr fn +ppr_sig (CompleteMatchSig (_, src) cs mty) + = pragSrcBrackets src "{-# COMPLETE" + ((hsep (punctuate comma (map ppr_n cs))) + <+> opt_sig) + where + opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty + ppr_n n = case ghcPass @p of + GhcPs -> ppr n + GhcRn -> ppr n + GhcTc -> ppr n +ppr_sig (XSig x) = case ghcPass @p of + GhcRn | IdSig id <- x -> pprVarSig [id] (ppr (varType id)) + GhcTc | IdSig id <- x -> pprVarSig [id] (ppr (varType id)) + +hsSigDoc :: forall p. IsPass p => Sig (GhcPass p) -> SDoc +hsSigDoc (TypeSig {}) = text "type signature" +hsSigDoc (PatSynSig {}) = text "pattern synonym signature" +hsSigDoc (ClassOpSig _ is_deflt _ _) + | is_deflt = text "default type signature" + | otherwise = text "class method signature" +hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma" +hsSigDoc (SpecSigE _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma" +hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma" +-- Using the 'inlinePragmaName' function ensures that the pragma name for any +-- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted +-- from the InlineSpec field of the pragma. +hsSigDoc (SpecInstSig (_, src) _) = text (extractSpecPragName src) <+> text "instance pragma" +hsSigDoc (FixSig {}) = text "fixity declaration" +hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" +hsSigDoc (SCCFunSig {}) = text "SCC pragma" +hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" +hsSigDoc (XSig _) = case ghcPass @p of + GhcRn -> text "id signature" + GhcTc -> text "id signature" + +-- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src +-- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE +-- instance pragma of the form: "SourceText {-# SPECIALIZE" +-- +-- Extraction ensures that all variants of the pragma name (with a 'Z' or an +-- 'S') are output exactly as used in the pragma. +extractSpecPragName :: SourceText -> String +extractSpecPragName srcTxt = case (words $ show srcTxt) of + (_:_:pragName:_) -> filter (/= '\"') pragName + _ -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt) + +instance OutputableBndrId p + => Outputable (FixitySig (GhcPass p)) where + ppr (FixitySig ns_spec names fixity) = sep [ppr fixity, ppr_ns_spec, pprops] + where + ppr_ns_spec = + case ghcPass @p of + GhcPs -> ppr ns_spec + GhcRn -> ppr ns_spec + GhcTc -> empty + pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) + +pragBrackets :: SDoc -> SDoc +pragBrackets doc = text "{-#" <+> doc <+> text "#-}" + +-- | Using SourceText in case the pragma was spelled differently or used mixed +-- case +pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc +pragSrcBrackets (SourceText src) _ doc = ftext src <+> doc <+> text "#-}" +pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}" + +pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc +pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] + where + pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) + +pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc +pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty + where + pp_inl | isDefaultInlinePragma inl = empty + | otherwise = pprInline inl + +pprTcSpecPrags :: TcSpecPrags -> SDoc +pprTcSpecPrags IsDefaultMethod = text "" +pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) + +instance Outputable TcSpecPrag where + ppr (SpecPrag var _ inl) + = text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "") inl + ppr (SpecPragE { spe_bndrs = bndrs, spe_call = spec_e, spe_inl = inl }) + = text (extractSpecPragName $ inl_src inl) + <+> hang (ppr bndrs) 2 (pprLExpr spec_e) + +pprMinimalSig :: OutputableBndrId p => LBooleanFormula (GhcPass p) -> SDoc +pprMinimalSig (L _ bf) = pprBooleanFormulaNormal bf + + +{- ********************************************************************* +* * + RuleBndrs +* * +********************************************************************* -} + +data HsRuleBndrsAnn + = HsRuleBndrsAnn + { rb_tyanns :: Maybe (TokForall, EpToken ".") + -- ^ The locations of 'forall' and '.' for forall'd type vars + -- Using AddEpAnn to capture possible unicode variants + , rb_tmanns :: Maybe (TokForall, EpToken ".") + -- ^ The locations of 'forall' and '.' for forall'd term vars + -- Using AddEpAnn to capture possible unicode variants + } deriving (Data, Eq) + +instance NoAnn HsRuleBndrsAnn where + noAnn = HsRuleBndrsAnn Nothing Nothing + + + +type instance XXRuleBndrs (GhcPass _) = DataConCantHappen +type instance XCRuleBndrs GhcPs = HsRuleBndrsAnn +type instance XCRuleBndrs GhcRn = NoExtField +type instance XCRuleBndrs GhcTc = [Var] -- Binders of the rule, not + -- necessarily in dependency order + +type instance XRuleBndrSig (GhcPass _) = AnnTyVarBndr +type instance XCRuleBndr (GhcPass _) = AnnTyVarBndr +type instance XXRuleBndr (GhcPass _) = DataConCantHappen + +instance (OutputableBndrId p) => Outputable (RuleBndrs (GhcPass p)) where + ppr (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) + = pp_forall_ty tyvs <+> pp_forall_tm tyvs + where + pp_forall_ty Nothing = empty + pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot + pp_forall_tm Nothing | null tmvs = empty + pp_forall_tm _ = forAllLit <+> fsep (map ppr tmvs) <> dot + +instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where + ppr (RuleBndr _ name) = ppr name + ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) + +{- +************************************************************************ +* * +\subsection{Anno instances} +* * +************************************************************************ +-} + +type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA +type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA +type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA +type instance Anno (RuleBndr (GhcPass p)) = EpAnnCO + +type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA + +type instance Anno StringLiteral = EpAnnCO diff --git a/GHC/Hs/Decls.hs b/GHC/Hs/Decls.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Decls.hs @@ -0,0 +1,1515 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension + +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable +{-# LANGUAGE InstanceSigs #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +-- | Abstract syntax of global declarations. +-- +-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, +-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. +module GHC.Hs.Decls ( + -- * Toplevel declarations + HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, + HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, + NewOrData, newOrDataToFlavour, anyLConIsGadt, + StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName, + + -- ** Class or type declarations + TyClDecl(..), LTyClDecl, DataDeclRn(..), + AnnDataDefn(..), + AnnClassDecl(..), + AnnSynDecl(..), + AnnFamilyDecl(..), + AnnClsInstDecl(..), + TyClGroup(..), + tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, + tyClGroupKindSigs, + isClassDecl, isDataDecl, isSynDecl, tcdName, + isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, + isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, + tyFamInstDeclName, tyFamInstDeclLName, + countTyClDecls, tyClDeclFlavour, + tyClDeclLName, tyClDeclTyVars, + hsDeclHasCusk, famResultKindSignature, + FamilyDecl(..), LFamilyDecl, + FunDep(..), ppDataDefnHeader, + pp_vanilla_decl_head, + + -- ** Instance declarations + InstDecl(..), LInstDecl, FamilyInfo(..), + TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, + TyFamDefltDecl, LTyFamDefltDecl, + DataFamInstDecl(..), LDataFamInstDecl, + pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS, + FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsFamEqnPats, + LClsInstDecl, ClsInstDecl(..), + + -- ** Standalone deriving declarations + DerivDecl(..), LDerivDecl, AnnDerivDecl, + -- ** Deriving strategies + DerivStrategy(..), LDerivStrategy, + derivStrategyName, foldDerivStrategy, mapDerivStrategy, + XViaStrategyPs(..), + -- ** @RULE@ declarations + LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..), + HsRuleAnn(..), + RuleBndr(..),LRuleBndr, + collectRuleBndrSigTys, + flattenRuleDecls, pprFullRuleName, + -- ** @default@ declarations + DefaultDecl(..), LDefaultDecl, + -- ** Template haskell declaration splice + SpliceDecoration(..), + SpliceDecl(..), LSpliceDecl, + -- ** Foreign function interface declarations + ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), + CImportSpec(..), + -- ** Data-constructor declarations + ConDecl(..), LConDecl, + HsConDeclH98Details, HsConDeclGADTDetails(..), + AnnConDeclH98(..), AnnConDeclGADT(..), + hsConDeclTheta, + getConNames, getRecConArgs_maybe, + -- ** Document comments + DocDecl(..), LDocDecl, docDeclDoc, + -- ** Deprecations + WarnDecl(..), LWarnDecl, + WarnDecls(..), LWarnDecls, + -- ** Annotations + AnnDecl(..), LAnnDecl, + AnnProvenance(..), annProvenanceName_maybe, + -- ** Role annotations + RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName, + -- ** Injective type families + FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn, + resultVariableName, familyDeclLName, familyDeclName, + + -- * Grouping + HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls, + hsGroupTopLevelFixitySigs, + + partitionBindsAndSigs, + ) where + +-- friends: +import GHC.Prelude + +import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Extension + +import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice ) + -- Because Expr imports Decls via HsBracket + +import GHC.Hs.Binds +import GHC.Hs.Type +import GHC.Hs.Doc +import GHC.Types.Basic +import GHC.Core.Coercion + +import GHC.Hs.Extension +import GHC.Parser.Annotation +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Fixity + +-- others: +import GHC.Utils.Misc (count) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.SrcLoc +import GHC.Types.SourceText +import GHC.Core.Type +import GHC.Types.ForeignCall +import GHC.Unit.Module.Warnings + +import GHC.Data.Maybe +import Data.Data (Data) +import Data.List (concatMap) +import Data.Foldable (toList) + +{- +************************************************************************ +* * +\subsection[HsDecl]{Declarations} +* * +************************************************************************ +-} + +type instance XTyClD (GhcPass _) = NoExtField +type instance XInstD (GhcPass _) = NoExtField +type instance XDerivD (GhcPass _) = NoExtField +type instance XValD (GhcPass _) = NoExtField +type instance XSigD (GhcPass _) = NoExtField +type instance XKindSigD (GhcPass _) = NoExtField +type instance XDefD (GhcPass _) = NoExtField +type instance XForD (GhcPass _) = NoExtField +type instance XWarningD (GhcPass _) = NoExtField +type instance XAnnD (GhcPass _) = NoExtField +type instance XRuleD (GhcPass _) = NoExtField +type instance XSpliceD (GhcPass _) = NoExtField +type instance XDocD (GhcPass _) = NoExtField +type instance XRoleAnnotD (GhcPass _) = NoExtField +type instance XXHsDecl (GhcPass _) = DataConCantHappen + +-- | Partition a list of HsDecls into function/pattern bindings, signatures, +-- type family declarations, type family instances, and documentation comments. +-- +-- Panics when given a declaration that cannot be put into any of the output +-- groups. +-- +-- The primary use of this function is to implement +-- 'GHC.Parser.PostProcess.cvBindsAndSigs'. +partitionBindsAndSigs + :: [LHsDecl GhcPs] + -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], + [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) +partitionBindsAndSigs = go + where + go [] = ([], [], [], [], [], []) + go ((L l decl) : ds) = + let (bs, ss, ts, tfis, dfis, docs) = go ds in + case decl of + ValD _ b + -> (L l b : bs, ss, ts, tfis, dfis, docs) + SigD _ s + -> (bs, L l s : ss, ts, tfis, dfis, docs) + TyClD _ (FamDecl _ t) + -> (bs, ss, L l t : ts, tfis, dfis, docs) + InstD _ (TyFamInstD { tfid_inst = tfi }) + -> (bs, ss, ts, L l tfi : tfis, dfis, docs) + InstD _ (DataFamInstD { dfid_inst = dfi }) + -> (bs, ss, ts, tfis, L l dfi : dfis, docs) + DocD _ d + -> (bs, ss, ts, tfis, dfis, L l d : docs) + _ -> pprPanic "partitionBindsAndSigs" (ppr decl) + +-- Okay, I need to reconstruct the document comments, but for now: +instance Outputable (DocDecl name) where + ppr _ = text "" + +type instance XCHsGroup (GhcPass _) = NoExtField +type instance XXHsGroup (GhcPass _) = DataConCantHappen + + +emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p) +emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } +emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } + +emptyGroup = HsGroup { hs_ext = noExtField, + hs_tyclds = [], + hs_derivds = [], + hs_fixds = [], hs_defds = [], hs_annds = [], + hs_fords = [], hs_warnds = [], hs_ruleds = [], + hs_valds = error "emptyGroup hs_valds: Can't happen", + hs_splcds = [], + hs_docs = [] } + +-- | The fixity signatures for each top-level declaration and class method +-- in an 'HsGroup'. +-- See Note [Top-level fixity signatures in an HsGroup] +hsGroupTopLevelFixitySigs :: HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)] +hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) = + fixds ++ cls_fixds + where + cls_fixds = [ L loc sig + | L _ ClassDecl{tcdSigs = sigs} <- tyClGroupTyClDecls tyclds + , L loc (FixSig _ sig) <- sigs + ] + +hsGroupInstDecls :: HsGroup (GhcPass p) -> [LInstDecl (GhcPass p)] +hsGroupInstDecls = (=<<) group_instds . hs_tyclds + +-- Helpers to flatten TyClGroups. +-- See (TCDEP1) in Note [Dependency analysis of type and class decls] in GHC.Rename.Module +tyClGroupTyClDecls :: [TyClGroup (GhcPass p)] -> [LTyClDecl (GhcPass p)] +tyClGroupInstDecls :: [TyClGroup (GhcPass p)] -> [LInstDecl (GhcPass p)] +tyClGroupRoleDecls :: [TyClGroup (GhcPass p)] -> [LRoleAnnotDecl (GhcPass p)] +tyClGroupKindSigs :: [TyClGroup (GhcPass p)] -> [LStandaloneKindSig (GhcPass p)] +tyClGroupTyClDecls = Data.List.concatMap group_tyclds +tyClGroupInstDecls = Data.List.concatMap group_instds +tyClGroupRoleDecls = Data.List.concatMap group_roles +tyClGroupKindSigs = Data.List.concatMap group_kisigs + +appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p) + -> HsGroup (GhcPass p) +appendGroups + HsGroup { + hs_valds = val_groups1, + hs_splcds = spliceds1, + hs_tyclds = tyclds1, + hs_derivds = derivds1, + hs_fixds = fixds1, + hs_defds = defds1, + hs_annds = annds1, + hs_fords = fords1, + hs_warnds = warnds1, + hs_ruleds = rulds1, + hs_docs = docs1 } + HsGroup { + hs_valds = val_groups2, + hs_splcds = spliceds2, + hs_tyclds = tyclds2, + hs_derivds = derivds2, + hs_fixds = fixds2, + hs_defds = defds2, + hs_annds = annds2, + hs_fords = fords2, + hs_warnds = warnds2, + hs_ruleds = rulds2, + hs_docs = docs2 } + = + HsGroup { + hs_ext = noExtField, + hs_valds = val_groups1 `plusHsValBinds` val_groups2, + hs_splcds = spliceds1 ++ spliceds2, + hs_tyclds = tyclds1 ++ tyclds2, + hs_derivds = derivds1 ++ derivds2, + hs_fixds = fixds1 ++ fixds2, + hs_annds = annds1 ++ annds2, + hs_defds = defds1 ++ defds2, + hs_fords = fords1 ++ fords2, + hs_warnds = warnds1 ++ warnds2, + hs_ruleds = rulds1 ++ rulds2, + hs_docs = docs1 ++ docs2 } + +instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass p)) where + ppr (TyClD _ dcl) = ppr dcl + ppr (ValD _ binds) = ppr binds + ppr (DefD _ def) = ppr def + ppr (InstD _ inst) = ppr inst + ppr (DerivD _ deriv) = ppr deriv + ppr (ForD _ fd) = ppr fd + ppr (SigD _ sd) = ppr sd + ppr (KindSigD _ ksd) = ppr ksd + ppr (RuleD _ rd) = ppr rd + ppr (WarningD _ wd) = ppr wd + ppr (AnnD _ ad) = ppr ad + ppr (SpliceD _ dd) = ppr dd + ppr (DocD _ doc) = ppr doc + ppr (RoleAnnotD _ ra) = ppr ra + +instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where + ppr (HsGroup { hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = deprec_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls }) + = vcat_mb empty + [ppr_ds fix_decls, ppr_ds default_decls, + ppr_ds deprec_decls, ppr_ds ann_decls, + ppr_ds rule_decls, + if isEmptyValBinds val_decls + then Nothing + else Just (ppr val_decls), + ppr_ds (tyClGroupRoleDecls tycl_decls), + ppr_ds (tyClGroupKindSigs tycl_decls), + ppr_ds (tyClGroupTyClDecls tycl_decls), + ppr_ds (tyClGroupInstDecls tycl_decls), + ppr_ds deriv_decls, + ppr_ds foreign_decls] + where + ppr_ds :: Outputable a => [a] -> Maybe SDoc + ppr_ds [] = Nothing + ppr_ds ds = Just (vcat (map ppr ds)) + + vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc + -- Concatenate vertically with white-space between non-blanks + vcat_mb _ [] = empty + vcat_mb gap (Nothing : ds) = vcat_mb gap ds + vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds + +type instance XSpliceDecl (GhcPass _) = NoExtField +type instance XXSpliceDecl (GhcPass _) = DataConCantHappen + +instance OutputableBndrId p + => Outputable (SpliceDecl (GhcPass p)) where + ppr (SpliceDecl _ (L _ e) DollarSplice) = pprUntypedSplice True Nothing e + ppr (SpliceDecl _ (L _ e) BareSplice) = pprUntypedSplice False Nothing e + +instance Outputable SpliceDecoration where + ppr x = text $ show x + + + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ +-} + +type instance XFamDecl (GhcPass _) = NoExtField + +type instance XSynDecl GhcPs = AnnSynDecl +type instance XSynDecl GhcRn = NameSet -- FVs +type instance XSynDecl GhcTc = NameSet -- FVs + +type instance XDataDecl GhcPs = NoExtField +type instance XDataDecl GhcRn = DataDeclRn +type instance XDataDecl GhcTc = DataDeclRn + +data DataDeclRn = DataDeclRn + { tcdDataCusk :: Bool -- ^ does this have a CUSK? + -- See Note [CUSKs: complete user-supplied kind signatures] + , tcdFVs :: NameSet } + deriving Data + +type instance XClassDecl GhcPs = + ( AnnClassDecl + , EpLayout -- See Note [Class EpLayout] + , AnnSortKey DeclTag ) -- TODO:AZ:tidy up AnnSortKey + +type instance XClassDecl GhcRn = NameSet -- FVs +type instance XClassDecl GhcTc = NameSet -- FVs + +type instance XXTyClDecl (GhcPass _) = DataConCantHappen + +type instance XCTyFamInstDecl (GhcPass _) = (EpToken "type", EpToken "instance") +type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen + +data AnnDataDefn + = AnnDataDefn { + andd_openp :: [EpToken "("], + andd_closep :: [EpToken ")"], + andd_type :: EpToken "type", + andd_newtype :: EpToken "newtype", + andd_data :: EpToken "data", + andd_instance :: EpToken "instance", + andd_dcolon :: TokDcolon, + andd_where :: EpToken "where", + andd_openc :: EpToken "{", + andd_closec :: EpToken "}", + andd_equal :: EpToken "=" + } deriving Data + +instance NoAnn AnnDataDefn where + noAnn = AnnDataDefn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn + +data AnnClassDecl + = AnnClassDecl { + acd_class :: EpToken "class", + acd_openp :: [EpToken "("], + acd_closep :: [EpToken ")"], + acd_vbar :: EpToken "|", + acd_where :: EpToken "where", + acd_openc :: EpToken "{", + acd_closec :: EpToken "}", + acd_semis :: [EpToken ";"] + } deriving Data + +instance NoAnn AnnClassDecl where + noAnn = AnnClassDecl noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn + +data AnnSynDecl + = AnnSynDecl { + asd_opens :: [EpToken "("], + asd_closes :: [EpToken ")"], + asd_type :: EpToken "type", + asd_equal :: EpToken "=" + } deriving Data + +instance NoAnn AnnSynDecl where + noAnn = AnnSynDecl noAnn noAnn noAnn noAnn + +------------- Pretty printing FamilyDecls ----------- + +pprFlavour :: FamilyInfo pass -> SDoc +pprFlavour DataFamily = text "data" +pprFlavour OpenTypeFamily = text "type" +pprFlavour (ClosedTypeFamily {}) = text "type" + +instance Outputable (FamilyInfo pass) where + ppr info = pprFlavour info <+> text "family" + + +-- Dealing with names + +tyFamInstDeclName :: Anno (IdGhcP p) ~ SrcSpanAnnN + => TyFamInstDecl (GhcPass p) -> IdP (GhcPass p) +tyFamInstDeclName = unLoc . tyFamInstDeclLName + +tyFamInstDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN + => TyFamInstDecl (GhcPass p) -> LocatedN (IdP (GhcPass p)) +tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = ln }}) + = ln + +tyClDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN + => TyClDecl (GhcPass p) -> LocatedN (IdP (GhcPass p)) +tyClDeclLName (FamDecl { tcdFam = fd }) = familyDeclLName fd +tyClDeclLName (SynDecl { tcdLName = ln }) = ln +tyClDeclLName (DataDecl { tcdLName = ln }) = ln +tyClDeclLName (ClassDecl { tcdLName = ln }) = ln + +tyClDeclTyVars :: TyClDecl (GhcPass p) -> LHsQTyVars (GhcPass p) +tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs +tyClDeclTyVars d = tcdTyVars d + +countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int) + -- class, synonym decls, data, newtype, family decls +countTyClDecls decls + = (count isClassDecl decls, + count isSynDecl decls, -- excluding... + count isDataTy decls, -- ...family... + count isNewTy decls, -- ...instances + count isFamilyDecl decls) + where + isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = DataTypeCons _ _ } } = True + isDataTy _ = False + + isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = NewTypeCon _ } } = True + isNewTy _ = False + +-- FIXME: tcdName is commonly used by both GHC and third-party tools, so it +-- needs to be polymorphic in the pass +tcdName :: Anno (IdGhcP p) ~ SrcSpanAnnN + => TyClDecl (GhcPass p) -> IdP (GhcPass p) +tcdName = unLoc . tyClDeclLName + +-- | Does this declaration have a complete, user-supplied kind signature? +-- See Note [CUSKs: complete user-supplied kind signatures] +hsDeclHasCusk :: TyClDecl GhcRn -> Bool +hsDeclHasCusk (FamDecl { tcdFam = + FamilyDecl { fdInfo = fam_info + , fdTyVars = tyvars + , fdResultSig = L _ resultSig } }) = + case fam_info of + ClosedTypeFamily {} -> hsTvbAllKinded tyvars + && isJust (famResultKindSignature resultSig) + _ -> True -- Un-associated open type/data families have CUSKs +hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) + = hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs) +hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk +hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars + +-- Pretty-printing TyClDecl +-- ~~~~~~~~~~~~~~~~~~~~~~~~ + +instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where + + ppr (FamDecl { tcdFam = decl }) = ppr decl + ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + , tcdRhs = rhs }) + = hang (text "type" <+> + pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> equals) + 4 (ppr rhs) + + ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + , tcdDataDefn = defn }) + = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn + + ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdFDs = fds, + tcdSigs = sigs, tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs}) + | null sigs && null methods && null ats && null at_defs -- No "where" part + = top_matter + + | otherwise -- Laid out + = vcat [ top_matter <+> text "where" + , nest 2 $ pprDeclList (map (ppr . unLoc) ats ++ + map (pprTyFamDefltDecl . unLoc) at_defs ++ + pprLHsBindsForUser methods sigs) ] + where + top_matter = text "class" + <+> pp_vanilla_decl_head lclas tyvars fixity context + <+> pprFundeps (map unLoc fds) + +instance OutputableBndrId p + => Outputable (TyClGroup (GhcPass p)) where + ppr (TyClGroup { group_tyclds = tyclds + , group_roles = roles + , group_kisigs = kisigs + , group_instds = instds + } + ) + = hang (text "TyClGroup") 2 $ + ppr kisigs $$ + ppr tyclds $$ + ppr roles $$ + ppr instds + +pp_vanilla_decl_head :: (OutputableBndrId p) + => XRecGhc (IdGhcP p) + -> LHsQTyVars (GhcPass p) + -> LexicalFixity + -> Maybe (LHsContext (GhcPass p)) + -> SDoc +pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context + = hsep [pprLHsContext context, pp_tyvars tyvars] + where + pp_tyvars (varl:varsr) + | fixity == Infix, varr:varsr'@(_:_) <- varsr + -- If varsr has at least 2 elements, parenthesize. + = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) + , (ppr.unLoc) varr, char ')' + , hsep (map (ppr.unLoc) varsr')] + | fixity == Infix + = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) + , hsep (map (ppr.unLoc) varsr)] + | otherwise = hsep [ pprPrefixOcc (unLoc thing) + , hsep (map (ppr.unLoc) (varl:varsr))] + pp_tyvars [] = pprPrefixOcc (unLoc thing) + +tyClDeclFlavour :: TyClDecl (GhcPass p) -> TyConFlavour tc +tyClDeclFlavour (ClassDecl {}) = ClassFlavour +tyClDeclFlavour (SynDecl {}) = TypeSynonymFlavour +tyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) + = case info of + DataFamily -> OpenFamilyFlavour (IAmData DataType) Nothing + OpenTypeFamily -> OpenFamilyFlavour IAmType Nothing + ClosedTypeFamily {} -> ClosedTypeFamilyFlavour +tyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } }) + = case dataDefnConsNewOrData nd of + NewType -> NewtypeFlavour + DataType -> DataTypeFlavour + +instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where + ppr = pprFunDep + +type instance XCFunDep (GhcPass _) = TokRarrow +type instance XXFunDep (GhcPass _) = DataConCantHappen + +pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc +pprFundeps [] = empty +pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) + +pprFunDep :: OutputableBndrId p => FunDep (GhcPass p) -> SDoc +pprFunDep (FunDep _ us vs) = hsep [interppSP us, arrow, interppSP vs] + +{- ********************************************************************* +* * + TyClGroup + Strongly connected components of + type, class, instance, and role declarations +* * +********************************************************************* -} + +type instance XCTyClGroup GhcPs = NoExtField + +type instance XCTyClGroup GhcRn = NameSet -- Lexical dependencies of an SCC + -- What names exactly are in this NameSet? See Note [Prepare TyClGroup FVs] in GHC.Rename.Module + -- How is this NameSet used? See Note [Retrying TyClGroups] in GHC.Tc.TyCl + +type instance XCTyClGroup GhcTc = DataConCantHappen + +type instance XXTyClGroup (GhcPass _) = DataConCantHappen + + +{- ********************************************************************* +* * + Data and type family declarations +* * +********************************************************************* -} + +type instance XNoSig (GhcPass _) = NoExtField +type instance XCKindSig (GhcPass _) = NoExtField + +type instance XTyVarSig (GhcPass _) = NoExtField +type instance XXFamilyResultSig (GhcPass _) = DataConCantHappen + +type instance XCFamilyDecl (GhcPass _) = AnnFamilyDecl +type instance XXFamilyDecl (GhcPass _) = DataConCantHappen + +data AnnFamilyDecl + = AnnFamilyDecl { + afd_openp :: [EpToken "("], + afd_closep :: [EpToken ")"], + afd_type :: EpToken "type", + afd_data :: EpToken "data", + afd_family :: EpToken "family", + afd_dcolon :: TokDcolon, + afd_equal :: EpToken "=", + afd_vbar :: EpToken "|", + afd_where :: EpToken "where", + afd_openc :: EpToken "{", + afd_dotdot :: EpToken "..", + afd_closec :: EpToken "}" + } deriving Data + +instance NoAnn AnnFamilyDecl where + noAnn = AnnFamilyDecl noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn + +------------- Functions over FamilyDecls ----------- + +familyDeclLName :: FamilyDecl (GhcPass p) -> XRecGhc (IdGhcP p) +familyDeclLName (FamilyDecl { fdLName = n }) = n + +familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p) +familyDeclName = unLoc . familyDeclLName + +famResultKindSignature :: FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p)) +famResultKindSignature (NoSig _) = Nothing +famResultKindSignature (KindSig _ ki) = Just ki +famResultKindSignature (TyVarSig _ bndr) = + case hsBndrKind (unLoc bndr) of + HsBndrNoKind _ -> Nothing + HsBndrKind _ ki -> Just ki + +-- | Maybe return name of the result type variable +resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a)) +resultVariableName (TyVarSig _ sig) = hsLTyVarName sig +resultVariableName _ = Nothing + +------------- Pretty printing FamilyDecls ----------- + +type instance XCInjectivityAnn (GhcPass _) = TokRarrow +type instance XXInjectivityAnn (GhcPass _) = DataConCantHappen + +instance OutputableBndrId p + => Outputable (FamilyDecl (GhcPass p)) where + ppr (FamilyDecl { fdInfo = info, fdLName = ltycon + , fdTopLevel = top_level + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = L _ result + , fdInjectivityAnn = mb_inj }) + = vcat [ pprFlavour info <+> pp_top_level <+> + pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> + pp_kind <+> pp_inj <+> pp_where + , nest 2 $ pp_eqns ] + where + pp_top_level = case top_level of + TopLevel -> text "family" + NotTopLevel -> empty + + pp_kind = case result of + NoSig _ -> empty + KindSig _ kind -> dcolon <+> ppr kind + TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr + pp_inj = case mb_inj of + Just (L _ (InjectivityAnn _ lhs rhs)) -> + hsep [ vbar, ppr lhs, arrow, hsep (map ppr rhs) ] + Nothing -> empty + (pp_where, pp_eqns) = case info of + ClosedTypeFamily mb_eqns -> + ( text "where" + , case mb_eqns of + Nothing -> text ".." + Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) + _ -> (empty, empty) + + + +{- ********************************************************************* +* * + Data types and data constructors +* * +********************************************************************* -} + +type instance XCHsDataDefn (GhcPass _) = AnnDataDefn +type instance XXHsDataDefn (GhcPass _) = DataConCantHappen + +type instance XCHsDerivingClause (GhcPass _) = EpToken "deriving" +type instance XXHsDerivingClause (GhcPass _) = DataConCantHappen + +instance OutputableBndrId p + => Outputable (HsDerivingClause (GhcPass p)) where + ppr (HsDerivingClause { deriv_clause_strategy = dcs + , deriv_clause_tys = L _ dct }) + = hsep [ text "deriving" + , pp_strat_before + , ppr dct + , pp_strat_after ] + where + -- @via@ is unique in that in comes /after/ the class being derived, + -- so we must special-case it. + (pp_strat_before, pp_strat_after) = + case dcs of + Just (L _ via@ViaStrategy{}) -> (empty, ppr via) + _ -> (ppDerivStrategy dcs, empty) + +-- | A short description of a @DerivStrategy'@. +derivStrategyName :: DerivStrategy a -> SDoc +derivStrategyName = text . go + where + go StockStrategy {} = "stock" + go AnyclassStrategy {} = "anyclass" + go NewtypeStrategy {} = "newtype" + go ViaStrategy {} = "via" + +type instance XDctSingle (GhcPass _) = NoExtField +type instance XDctMulti (GhcPass _) = NoExtField +type instance XXDerivClauseTys (GhcPass _) = DataConCantHappen + +instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where + ppr (DctSingle _ ty) = ppr ty + ppr (DctMulti _ tys) = parens (interpp'SP tys) + +type instance XStandaloneKindSig GhcPs = (EpToken "type", TokDcolon) +type instance XStandaloneKindSig GhcRn = NoExtField +type instance XStandaloneKindSig GhcTc = NoExtField + +type instance XXStandaloneKindSig (GhcPass p) = DataConCantHappen + +standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) +standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname + +type instance XConDeclGADT GhcPs = AnnConDeclGADT +type instance XConDeclGADT GhcRn = NoExtField +type instance XConDeclGADT GhcTc = NoExtField + +type instance XConDeclH98 GhcPs = AnnConDeclH98 +type instance XConDeclH98 GhcRn = NoExtField +type instance XConDeclH98 GhcTc = NoExtField + +type instance XXConDecl (GhcPass _) = DataConCantHappen + +type instance XPrefixConGADT (GhcPass _) = NoExtField + +type instance XRecConGADT GhcPs = TokRarrow +type instance XRecConGADT GhcRn = NoExtField +type instance XRecConGADT GhcTc = NoExtField + +type instance XXConDeclGADTDetails (GhcPass _) = DataConCantHappen + +data AnnConDeclH98 + = AnnConDeclH98 { + acdh_forall :: TokForall, + acdh_dot :: EpToken ".", + acdh_darrow :: TokDarrow + } deriving Data + +instance NoAnn AnnConDeclH98 where + noAnn = AnnConDeclH98 noAnn noAnn noAnn + +data AnnConDeclGADT + = AnnConDeclGADT { + acdg_openp :: [EpToken "("], + acdg_closep :: [EpToken ")"], + acdg_dcolon :: TokDcolon + } deriving Data + +instance NoAnn AnnConDeclGADT where + noAnn = AnnConDeclGADT noAnn noAnn noAnn + +-- Codomain could be 'NonEmpty', but at the moment all users need a list. +getConNames :: ConDecl GhcRn -> [LocatedN Name] +getConNames ConDeclH98 {con_name = name} = [name] +getConNames ConDeclGADT {con_names = names} = toList names + +-- | Return @'Just' fields@ if a data constructor declaration uses record +-- syntax (i.e., 'RecCon'), where @fields@ are the field selectors. +-- Otherwise, return 'Nothing'. +getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (LocatedL [LHsConDeclRecField GhcRn]) +getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of + PrefixCon{} -> Nothing + RecCon flds -> Just flds + InfixCon{} -> Nothing +getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of + PrefixConGADT{} -> Nothing + RecConGADT _ flds -> Just flds + +hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)] +hsConDeclTheta Nothing = [] +hsConDeclTheta (Just (L _ theta)) = theta + +ppDataDefnHeader + :: (OutputableBndrId p) + => (Maybe (LHsContext (GhcPass p)) -> SDoc) -- Printing the header + -> HsDataDefn (GhcPass p) + -> SDoc +ppDataDefnHeader pp_hdr HsDataDefn + { dd_ctxt = context + , dd_cType = mb_ct + , dd_kindSig = mb_sig + , dd_cons = condecls } + = pp_type <+> ppr (dataDefnConsNewOrData condecls) <+> pp_ct <+> pp_hdr context <+> pp_sig + where + pp_type + | isTypeDataDefnCons condecls = text "type" + | otherwise = empty + pp_ct = case mb_ct of + Nothing -> empty + Just ct -> ppr ct + pp_sig = case mb_sig of + Nothing -> empty + Just kind -> dcolon <+> ppr kind + +pp_data_defn :: (OutputableBndrId p) + => (Maybe (LHsContext (GhcPass p)) -> SDoc) -- Printing the header + -> HsDataDefn (GhcPass p) + -> SDoc +pp_data_defn pp_hdr defn@HsDataDefn + { dd_cons = condecls + , dd_derivs = derivings } + | null condecls + = ppDataDefnHeader pp_hdr defn <+> pp_derivings derivings + + | otherwise + = hang (ppDataDefnHeader pp_hdr defn) 2 (pp_condecls (toList condecls) $$ pp_derivings derivings) + where + pp_derivings ds = vcat (map ppr ds) + +instance OutputableBndrId p + => Outputable (HsDataDefn (GhcPass p)) where + ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d + +instance OutputableBndrId p + => Outputable (StandaloneKindSig (GhcPass p)) where + ppr (StandaloneKindSig _ v ki) + = text "type" <+> pprPrefixOcc (unLoc v) <+> dcolon <+> ppr ki + +pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc +pp_condecls cs + | anyLConIsGadt cs -- In GADT syntax + = hang (text "where") 2 (vcat (map ppr cs)) + | otherwise -- In H98 syntax + = equals <+> sep (punctuate (text " |") (map ppr cs)) + +instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where + ppr = pprConDecl + +pprConDecl :: forall p. OutputableBndrId p => ConDecl (GhcPass p) -> SDoc +pprConDecl (ConDeclH98 { con_name = L _ con + , con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt + , con_args = args + , con_doc = doc }) + = pprMaybeWithDoc doc $ + sep [ pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt + , ppr_details args ] + where + -- In ppr_details: let's not print the multiplicities (they are always 1, by + -- definition) as they do not appear in an actual declaration. + ppr_details (InfixCon t1 t2) = hsep [pprHsConDeclFieldNoMult t1, + pprInfixOcc con, + pprHsConDeclFieldNoMult t2] + ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con + : map pprHsConDeclFieldNoMult tys) + ppr_details (RecCon fields) = pprPrefixOcc con + <+> pprHsConDeclRecFields (unLoc fields) + +pprConDecl (ConDeclGADT { con_names = cons + , con_outer_bndrs = L _ outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = mcxt, con_g_args = args + , con_res_ty = res_ty, con_doc = doc }) + = pprMaybeWithDoc doc $ ppr_con_names (toList cons) <+> dcolon + <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs + <+> hsep (map pprHsForAllTelescope inner_bndrs) + <+> pprLHsContext mcxt, + sep (ppr_args args ++ [ppr res_ty]) ]) + where + ppr_args (PrefixConGADT _ args) = map (pprHsConDeclFieldWith (\arr tyDoc -> tyDoc <+> ppr_arr arr)) args + ppr_args (RecConGADT _ fields) = [pprHsConDeclRecFields (unLoc fields) <+> arrow] + + -- Display linear arrows as unrestricted with -XNoLinearTypes + -- (cf. dataConDisplayType in Note [Displaying linear fields] in GHC.Core.DataCon) + ppr_arr (HsLinearAnn _) = sdocOption sdocLinearTypes $ \show_linear_types -> + if show_linear_types then lollipop else arrow + ppr_arr arr = pprHsArrow arr + +ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc +ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) + +{- +************************************************************************ +* * + Instance declarations +* * +************************************************************************ +-} + +type instance XCFamEqn (GhcPass _) r = ([EpToken "("], [EpToken ")"], EpToken "=") +type instance XXFamEqn (GhcPass _) r = DataConCantHappen + +----------------- Class instances ------------- + +type instance XCClsInstDecl GhcPs = ( Maybe (LWarningTxt GhcPs) + -- The warning of the deprecated instance + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict + , AnnClsInstDecl + , AnnSortKey DeclTag) -- For sorting the additional annotations + -- TODO:AZ:tidy up +type instance XCClsInstDecl GhcRn = Maybe (LWarningTxt GhcRn) + -- The warning of the deprecated instance + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict +type instance XCClsInstDecl GhcTc = NoExtField + +type instance XXClsInstDecl (GhcPass _) = DataConCantHappen + +----------------- Instances of all kinds ------------- + +type instance XClsInstD (GhcPass _) = NoExtField + +type instance XDataFamInstD (GhcPass _) = NoExtField + +type instance XTyFamInstD GhcPs = NoExtField +type instance XTyFamInstD GhcRn = NoExtField +type instance XTyFamInstD GhcTc = NoExtField + +type instance XXInstDecl (GhcPass _) = DataConCantHappen + +data AnnClsInstDecl + = AnnClsInstDecl { + acid_instance :: EpToken "instance", + acid_where :: EpToken "where", + acid_openc :: EpToken "{", + acid_semis :: [EpToken ";"], + acid_closec :: EpToken "}" + } deriving Data + +instance NoAnn AnnClsInstDecl where + noAnn = AnnClsInstDecl noAnn noAnn noAnn noAnn noAnn + +cidDeprecation :: forall p. IsPass p + => ClsInstDecl (GhcPass p) + -> Maybe (WarningTxt (GhcPass p)) +cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) + where + decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p) + -> Maybe (LocatedP (WarningTxt (GhcPass p))) + decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _, _) } ) + = depr + decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr }) + = depr + decl_deprecation _ _ = Nothing + +instance OutputableBndrId p + => Outputable (TyFamInstDecl (GhcPass p)) where + ppr = pprTyFamInstDecl TopLevel + +pprTyFamInstDecl :: (OutputableBndrId p) + => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc +pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) + = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn + +ppr_instance_keyword :: TopLevelFlag -> SDoc +ppr_instance_keyword TopLevel = text "instance" +ppr_instance_keyword NotTopLevel = empty + +pprTyFamDefltDecl :: (OutputableBndrId p) + => TyFamDefltDecl (GhcPass p) -> SDoc +pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel + +ppr_fam_inst_eqn :: (OutputableBndrId p) + => TyFamInstEqn (GhcPass p) -> SDoc +ppr_fam_inst_eqn (FamEqn { feqn_tycon = L _ tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = rhs }) + = pprHsFamInstLHS tycon bndrs pats fixity Nothing <+> equals <+> ppr rhs + +instance OutputableBndrId p + => Outputable (DataFamInstDecl (GhcPass p)) where + ppr = pprDataFamInstDecl TopLevel + +pprDataFamInstDecl :: (OutputableBndrId p) + => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc +pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = + (FamEqn { feqn_tycon = L _ tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = defn })}) + = pp_data_defn pp_hdr defn + where + pp_hdr mctxt = ppr_instance_keyword top_lvl + <+> pprHsFamInstLHS tycon bndrs pats fixity mctxt + -- pp_data_defn pretty-prints the kind sig. See #14817. + +pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc +pprDataFamInstFlavour DataFamInstDecl + { dfid_eqn = FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons }}} + = ppr (dataDefnConsNewOrData cons) + +pprHsFamInstLHS :: (OutputableBndrId p) + => IdP (GhcPass p) + -> HsOuterFamEqnTyVarBndrs (GhcPass p) + -> HsFamEqnPats (GhcPass p) + -> LexicalFixity + -> Maybe (LHsContext (GhcPass p)) + -> SDoc +pprHsFamInstLHS thing bndrs typats fixity mb_ctxt + = hsep [ pprHsOuterFamEqnTyVarBndrs bndrs + , pprLHsContext mb_ctxt + , pprHsArgsApp thing fixity typats ] + +instance OutputableBndrId p + => Outputable (ClsInstDecl (GhcPass p)) where + ppr (cid@ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap + , cid_datafam_insts = adts }) + | null sigs, null ats, null adts, null binds -- No "where" part + = top_matter + + | otherwise -- Laid out + = vcat [ top_matter <+> text "where" + , nest 2 $ pprDeclList $ + map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++ + map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ + pprLHsBindsForUser binds sigs ] + where + top_matter = text "instance" <+> maybe empty ppr (cidDeprecation cid) + <+> ppOverlapPragma mbOverlap + <+> ppr inst_ty + +ppDerivStrategy :: OutputableBndrId p + => Maybe (LDerivStrategy (GhcPass p)) -> SDoc +ppDerivStrategy mb = + case mb of + Nothing -> empty + Just (L _ ds) -> ppr ds + +ppOverlapPragma :: Maybe (LocatedP OverlapMode) -> SDoc +ppOverlapPragma mb = + case mb of + Nothing -> empty + Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}" + Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}" + Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}" + Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}" + Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}" + Just (L _ (NonCanonical s)) -> maybe_stext s "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet + where + maybe_stext NoSourceText alt = text alt + maybe_stext (SourceText src) _ = ftext src <+> text "#-}" + + +instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where + ppr (ClsInstD { cid_inst = decl }) = ppr decl + ppr (TyFamInstD { tfid_inst = decl }) = ppr decl + ppr (DataFamInstD { dfid_inst = decl }) = ppr decl + +-- Extract the declarations of associated data types from an instance + +instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)] +instDeclDataFamInsts inst_decls + = concatMap do_one inst_decls + where + do_one :: LInstDecl (GhcPass p) -> [DataFamInstDecl (GhcPass p)] + do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } })) + = map unLoc fam_insts + do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] + do_one (L _ (TyFamInstD {})) = [] + +-- | Convert a 'NewOrData' to a 'TyConFlavour' +newOrDataToFlavour :: NewOrData -> TyConFlavour tc +newOrDataToFlavour NewType = NewtypeFlavour +newOrDataToFlavour DataType = DataTypeFlavour + +-- At the moment we only call this with @f = '[]'@ and @f = 'DataDefnCons'@. +anyLConIsGadt :: Foldable f => f (GenLocated l (ConDecl pass)) -> Bool +anyLConIsGadt xs = case toList xs of + L _ ConDeclGADT {} : _ -> True + _ -> False +{-# SPECIALIZE anyLConIsGadt :: [GenLocated l (ConDecl pass)] -> Bool #-} +{-# SPECIALIZE anyLConIsGadt :: DataDefnCons (GenLocated l (ConDecl pass)) -> Bool #-} + +{- +************************************************************************ +* * +\subsection[DerivDecl]{A stand-alone instance deriving declaration} +* * +************************************************************************ +-} + +type instance XCDerivDecl GhcPs = ( Maybe (LWarningTxt GhcPs) + -- The warning of the deprecated derivation + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict + , AnnDerivDecl ) +type instance XCDerivDecl GhcRn = ( Maybe (LWarningTxt GhcRn) + -- The warning of the deprecated derivation + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict + , AnnDerivDecl ) +type instance XCDerivDecl GhcTc = AnnDerivDecl +type instance XXDerivDecl (GhcPass _) = DataConCantHappen + +type AnnDerivDecl = (EpToken "deriving", EpToken "instance") + +derivDeprecation :: forall p. IsPass p + => DerivDecl (GhcPass p) + -> Maybe (WarningTxt (GhcPass p)) +derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) + where + decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p) + -> Maybe (LocatedP (WarningTxt (GhcPass p))) + decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) }) + = depr + decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) }) + = depr + decl_deprecation _ _ = Nothing + +instance OutputableBndrId p + => Outputable (DerivDecl (GhcPass p)) where + ppr (deriv@DerivDecl { deriv_type = ty + , deriv_strategy = ds + , deriv_overlap_mode = o }) + = hsep [ text "deriving" + , ppDerivStrategy ds + , text "instance" + , maybe empty ppr (derivDeprecation deriv) + , ppOverlapPragma o + , ppr ty ] + +{- +************************************************************************ +* * + Deriving strategies +* * +************************************************************************ +-} + +type instance XStockStrategy GhcPs = EpToken "stock" +type instance XStockStrategy GhcRn = NoExtField +type instance XStockStrategy GhcTc = NoExtField + +type instance XAnyClassStrategy GhcPs = EpToken "anyclass" +type instance XAnyClassStrategy GhcRn = NoExtField +type instance XAnyClassStrategy GhcTc = NoExtField + +type instance XNewtypeStrategy GhcPs = EpToken "newtype" +type instance XNewtypeStrategy GhcRn = NoExtField +type instance XNewtypeStrategy GhcTc = NoExtField + +type instance XViaStrategy GhcPs = XViaStrategyPs +type instance XViaStrategy GhcRn = LHsSigType GhcRn +type instance XViaStrategy GhcTc = Type + +data XViaStrategyPs = XViaStrategyPs (EpToken "via") (LHsSigType GhcPs) + +instance OutputableBndrId p + => Outputable (DerivStrategy (GhcPass p)) where + ppr (StockStrategy _) = text "stock" + ppr (AnyclassStrategy _) = text "anyclass" + ppr (NewtypeStrategy _) = text "newtype" + ppr (ViaStrategy ty) = text "via" <+> case ghcPass @p of + GhcPs -> ppr ty + GhcRn -> ppr ty + GhcTc -> ppr ty + +instance Outputable XViaStrategyPs where + ppr (XViaStrategyPs _ t) = ppr t + + +-- | Eliminate a 'DerivStrategy'. +foldDerivStrategy :: (p ~ GhcPass pass) + => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r +foldDerivStrategy other _ (StockStrategy _) = other +foldDerivStrategy other _ (AnyclassStrategy _) = other +foldDerivStrategy other _ (NewtypeStrategy _) = other +foldDerivStrategy _ via (ViaStrategy t) = via t + +-- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise, +-- return the 'DerivStrategy' unchanged. +mapDerivStrategy :: (p ~ GhcPass pass) + => (XViaStrategy p -> XViaStrategy p) + -> DerivStrategy p -> DerivStrategy p +mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds + +{- +************************************************************************ +* * +\subsection[DefaultDecl]{A @default@ declaration} +* * +************************************************************************ +-} + +type instance XCDefaultDecl GhcPs = (EpToken "default", EpToken "(", EpToken ")") +type instance XCDefaultDecl GhcRn = NoExtField +type instance XCDefaultDecl GhcTc = NoExtField + +type instance XXDefaultDecl (GhcPass _) = DataConCantHappen + +instance OutputableBndrId p + => Outputable (DefaultDecl (GhcPass p)) where + ppr (DefaultDecl _ cl tys) + = text "default" <+> maybe id ((<+>) . ppr) cl (parens (interpp'SP tys)) + +{- +************************************************************************ +* * +\subsection{Foreign function interface declaration} +* * +************************************************************************ +-} + +type instance XForeignImport GhcPs = (EpToken "foreign", EpToken "import", TokDcolon) +type instance XForeignImport GhcRn = NoExtField +type instance XForeignImport GhcTc = Coercion + +type instance XForeignExport GhcPs = (EpToken "foreign", EpToken "export", TokDcolon) +type instance XForeignExport GhcRn = NoExtField +type instance XForeignExport GhcTc = Coercion + +type instance XXForeignDecl (GhcPass _) = DataConCantHappen + +type instance XCImport (GhcPass _) = LocatedE SourceText -- original source text for the C entity +type instance XXForeignImport (GhcPass _) = DataConCantHappen + +type instance XCExport (GhcPass _) = LocatedE SourceText -- original source text for the C entity +type instance XXForeignExport (GhcPass _) = DataConCantHappen + + +-- pretty printing of foreign declarations + +instance OutputableBndrId p + => Outputable (ForeignDecl (GhcPass p)) where + ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) + = hang (text "foreign import" <+> ppr fimport <+> ppr n) + 2 (dcolon <+> ppr ty) + ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = + hang (text "foreign export" <+> ppr fexport <+> ppr n) + 2 (dcolon <+> ppr ty) + +instance OutputableBndrId p + => Outputable (ForeignImport (GhcPass p)) where + ppr (CImport (L _ srcText) cconv safety mHeader spec) = + ppr cconv <+> ppr safety + <+> pprWithSourceText srcText (pprCEntity spec "") + where + pp_hdr = case mHeader of + Nothing -> empty + Just (Header _ header) -> ftext header + + pprCEntity (CLabel lbl) _ = + doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl + pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src = + if dqNeeded then doubleQuotes ce else empty + where + dqNeeded = (take 6 src == "static") + || isJust mHeader + || not isFun + || st /= NoSourceText + ce = + -- We may need to drop leading spaces first + (if take 6 src == "static" then text "static" else empty) + <+> pp_hdr + <+> (if isFun then empty else text "value") + <+> (pprWithSourceText st empty) + pprCEntity (CFunction DynamicTarget) _ = + doubleQuotes $ text "dynamic" + pprCEntity CWrapper _ = doubleQuotes $ text "wrapper" + +instance OutputableBndrId p + => Outputable (ForeignExport (GhcPass p)) where + ppr (CExport _ (L _ (CExportStatic _ lbl cconv))) = + ppr cconv <+> char '"' <> ppr lbl <> char '"' + +{- +************************************************************************ +* * +\subsection{Rewrite rules} +* * +************************************************************************ +-} + +type instance XCRuleDecls GhcPs = ((EpaLocation, EpToken "#-}"), SourceText) +type instance XCRuleDecls GhcRn = SourceText +type instance XCRuleDecls GhcTc = SourceText + +type instance XXRuleDecls (GhcPass _) = DataConCantHappen + +type instance XHsRule GhcPs = ((ActivationAnn, EpToken "="), SourceText) +type instance XHsRule GhcRn = (HsRuleRn, SourceText) +type instance XHsRule GhcTc = (HsRuleRn, SourceText) + +data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS + deriving Data + +data HsRuleAnn + = HsRuleAnn + { ra_tyanns :: Maybe (TokForall, EpToken ".") + , ra_tmanns :: Maybe (TokForall, EpToken ".") + , ra_equal :: EpToken "=" + , ra_rest :: ActivationAnn + } deriving (Data, Eq) + +instance NoAnn HsRuleAnn where + noAnn = HsRuleAnn Nothing Nothing noAnn noAnn + +type instance XXRuleDecl (GhcPass _) = DataConCantHappen + +flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)] +flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls + +instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where + ppr (HsRules { rds_ext = ext + , rds_rules = rules }) + = pprWithSourceText st (text "{-# RULES") + <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" + where st = case ghcPass @p of + GhcPs | (_, st) <- ext -> st + GhcRn -> ext + GhcTc -> ext + +instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where + ppr (HsRule { rd_ext = ext + , rd_name = name + , rd_act = act + , rd_bndrs = bndrs + , rd_lhs = lhs + , rd_rhs = rhs }) + = sep [pprFullRuleName st name <+> ppr act, + nest 4 (ppr bndrs <+> pprExpr (unLoc lhs)), + nest 6 (equals <+> pprExpr (unLoc rhs)) ] + where + st = case ghcPass @p of + GhcPs | (_, st) <- ext -> st + GhcRn | (_, st) <- ext -> st + GhcTc | (_, st) <- ext -> st + +pprFullRuleName :: SourceText -> GenLocated a (RuleName) -> SDoc +pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n) + + +{- +************************************************************************ +* * +\subsection[DeprecDecl]{Deprecations} +* * +************************************************************************ +-} + +type instance XWarnings GhcPs = ((EpaLocation, EpToken "#-}"), SourceText) +type instance XWarnings GhcRn = SourceText +type instance XWarnings GhcTc = SourceText + +type instance XXWarnDecls (GhcPass _) = DataConCantHappen + +type instance XWarning (GhcPass _) = (NamespaceSpecifier, (EpToken "[", EpToken "]")) +type instance XXWarnDecl (GhcPass _) = DataConCantHappen + + +instance OutputableBndrId p + => Outputable (WarnDecls (GhcPass p)) where + ppr (Warnings ext decls) + = ftext src <+> vcat (punctuate semi (map ppr decls)) <+> text "#-}" + where src = case ghcPass @p of + GhcPs | (_, SourceText src) <- ext -> src + GhcRn | SourceText src <- ext -> src + GhcTc | SourceText src <- ext -> src + _ -> panic "WarnDecls" + +instance OutputableBndrId p + => Outputable (WarnDecl (GhcPass p)) where + ppr (Warning (ns_spec, _) thing txt) + = ppr_category + <+> ppr ns_spec + <+> hsep (punctuate comma (map ppr thing)) + <+> ppr txt + where + ppr_category = case txt of + WarningTxt (Just cat) _ _ -> ppr cat + _ -> empty + +{- +************************************************************************ +* * +\subsection[AnnDecl]{Annotations} +* * +************************************************************************ +-} + +type instance XHsAnnotation (GhcPass _) = (AnnPragma, SourceText) +type instance XXAnnDecl (GhcPass _) = DataConCantHappen + +instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where + ppr (HsAnnotation _ provenance expr) + = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] + +pprAnnProvenance :: OutputableBndrId p => AnnProvenance (GhcPass p) -> SDoc +pprAnnProvenance ModuleAnnProvenance = text "ANN module" +pprAnnProvenance (ValueAnnProvenance (L _ name)) + = text "ANN" <+> ppr name +pprAnnProvenance (TypeAnnProvenance (L _ name)) + = text "ANN type" <+> ppr name + +{- +************************************************************************ +* * +\subsection[RoleAnnot]{Role annotations} +* * +************************************************************************ +-} + +type instance XCRoleAnnotDecl GhcPs = (EpToken "type", EpToken "role") +type instance XCRoleAnnotDecl GhcRn = NoExtField +type instance XCRoleAnnotDecl GhcTc = NoExtField + +type instance XXRoleAnnotDecl (GhcPass _) = DataConCantHappen + +instance OutputableBndr (IdP (GhcPass p)) + => Outputable (RoleAnnotDecl (GhcPass p)) where + ppr (RoleAnnotDecl _ ltycon roles) + = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+> + hsep (map (pp_role . unLoc) roles) + where + pp_role Nothing = underscore + pp_role (Just r) = ppr r + +roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p) +roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name + +{- +************************************************************************ +* * +\subsection{Anno instances} +* * +************************************************************************ +-} + +type instance Anno (HsDecl (GhcPass _)) = SrcSpanAnnA +type instance Anno (SpliceDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (TyClDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA +type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO +type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO +type instance Anno CType = SrcSpanAnnP +type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO +type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC +type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA +type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno Bool = EpAnnCO +type instance Anno [LocatedA (HsConDeclRecField (GhcPass _))] = SrcSpanAnnL +type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA +type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA +type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno OverlapMode = SrcSpanAnnP +type instance Anno (DerivStrategy (GhcPass p)) = EpAnnCO +type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA +type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (SourceText, RuleName) = EpAnnCO +type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA +type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (Maybe Role) = EpAnnCO +type instance Anno CCallConv = EpaLocation +type instance Anno Safety = EpaLocation +type instance Anno CExportSpec = EpaLocation diff --git a/GHC/Hs/Doc.hs b/GHC/Hs/Doc.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Doc.hs @@ -0,0 +1,318 @@ +-- | Types and functions for raw and lexed docstrings. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} + +module GHC.Hs.Doc + ( HsDoc + , WithHsDocIdentifiers(..) + , hsDocIds + , LHsDoc + , pprHsDocDebug + , pprWithDoc + , pprMaybeWithDoc + + , module GHC.Hs.DocString + + , ExtractedTHDocs(..) + + , DocStructureItem(..) + , DocStructure + + , Docs(..) + , emptyDocs + ) where + +import GHC.Prelude + +import GHC.Utils.Binary +import GHC.Types.Name +import GHC.Utils.Outputable as Outputable hiding ((<>)) +import GHC.Types.SrcLoc +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.EnumSet (EnumSet) +import GHC.Types.Avail +import GHC.Types.Name.Set +import GHC.Driver.Flags + +import Control.DeepSeq +import Data.Data +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.List.NonEmpty (NonEmpty(..)) +import GHC.LanguageExtensions.Type +import qualified GHC.Utils.Outputable as O +import GHC.Hs.Extension +import GHC.Types.Unique.Map +import Data.List (sortBy) + +import GHC.Hs.DocString + +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name + +-- | A docstring with the (probable) identifiers found in it. +type HsDoc = WithHsDocIdentifiers HsDocString + +-- | Annotate a value with the probable identifiers found in it +-- These will be used by haddock to generate links. +-- +-- The identifiers are bundled along with their location in the source file. +-- This is useful for tooling to know exactly where they originate. +-- +-- This type is currently used in two places - for regular documentation comments, +-- with 'a' set to 'HsDocString', and for adding identifier information to +-- warnings, where 'a' is 'StringLiteral' +data WithHsDocIdentifiers a pass = WithHsDocIdentifiers + { hsDocString :: !a + , hsDocIdentifiers :: ![Located (IdP pass)] + } + +deriving instance (Data pass, Data (IdP pass), Data a) => Data (WithHsDocIdentifiers a pass) +deriving instance (Eq (IdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass) +instance (NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where + rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf i + +-- | For compatibility with the existing @-ddump-parsed' output, we only show +-- the docstring. +-- +-- Use 'pprHsDoc' to show `HsDoc`'s internals. +instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where + ppr (WithHsDocIdentifiers s _ids) = ppr s + +instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where + put_ bh (WithHsDocIdentifiers s ids) = do + put_ bh s + put_ bh $ BinLocated <$> ids + get bh = + liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh) + +-- | Extract a mapping from the lexed identifiers to the names they may +-- correspond to. +hsDocIds :: WithHsDocIdentifiers a GhcRn -> NameSet +hsDocIds (WithHsDocIdentifiers _ ids) = mkNameSet $ map unLoc ids + +-- | Pretty print a thing with its doc +-- The docstring will include the comment decorators '-- |', '{-|' etc +-- and will come either before or after depending on how it was written +-- i.e it will come after the thing if it is a '-- ^' or '{-^' and before +-- otherwise. +pprWithDoc :: LHsDoc name -> SDoc -> SDoc +pprWithDoc doc = pprWithDocString (hsDocString $ unLoc doc) + +-- | See 'pprWithHsDoc' +pprMaybeWithDoc :: Maybe (LHsDoc name) -> SDoc -> SDoc +pprMaybeWithDoc Nothing = id +pprMaybeWithDoc (Just doc) = pprWithDoc doc + +-- | Print a doc with its identifiers, useful for debugging +pprHsDocDebug :: (Outputable (IdP name)) => HsDoc name -> SDoc +pprHsDocDebug (WithHsDocIdentifiers s ids) = + vcat [ text "text:" $$ nest 2 (pprHsDocString s) + , text "identifiers:" $$ nest 2 (vcat (map pprLocatedAlways ids)) + ] + +type LHsDoc pass = Located (HsDoc pass) + +-- | A simplified version of 'HsImpExp.IE'. +data DocStructureItem + = DsiSectionHeading !Int !(HsDoc GhcRn) + | DsiDocChunk !(HsDoc GhcRn) + | DsiNamedChunkRef !String + | DsiExports !DetOrdAvails + | DsiModExport + !(NonEmpty ModuleName) -- ^ We might re-export avails from multiple + -- modules with a single export declaration. E.g. + -- when we have + -- + -- > module M (module X) where + -- > import R0 as X + -- > import R1 as X + -- + -- Invariant: This list of ModuleNames must be + -- sorted to guarantee interface file determinism. + !DetOrdAvails + -- ^ Invariant: This list of Avails must be sorted + -- to guarantee interface file determinism. + +instance Binary DocStructureItem where + put_ bh = \case + DsiSectionHeading level doc -> do + putByte bh 0 + put_ bh level + put_ bh doc + DsiDocChunk doc -> do + putByte bh 1 + put_ bh doc + DsiNamedChunkRef name -> do + putByte bh 2 + put_ bh name + DsiExports avails -> do + putByte bh 3 + put_ bh avails + DsiModExport mod_names avails -> do + putByte bh 4 + put_ bh mod_names + put_ bh avails + + get bh = do + tag <- getByte bh + case tag of + 0 -> DsiSectionHeading <$> get bh <*> get bh + 1 -> DsiDocChunk <$> get bh + 2 -> DsiNamedChunkRef <$> get bh + 3 -> DsiExports <$> get bh + 4 -> DsiModExport <$> get bh <*> get bh + _ -> fail "instance Binary DocStructureItem: Invalid tag" + +instance Outputable DocStructureItem where + ppr = \case + DsiSectionHeading level doc -> vcat + [ text "section heading, level" <+> ppr level O.<> colon + , nest 2 (pprHsDocDebug doc) + ] + DsiDocChunk doc -> vcat + [ text "documentation chunk:" + , nest 2 (pprHsDocDebug doc) + ] + DsiNamedChunkRef name -> + text "reference to named chunk:" <+> text name + DsiExports avails -> + text "avails:" $$ nest 2 (ppr avails) + DsiModExport mod_names avails -> + text "re-exported module(s):" <+> ppr mod_names $$ nest 2 (ppr avails) + +instance NFData DocStructureItem where + rnf = \case + DsiSectionHeading level doc -> rnf level `seq` rnf doc + DsiDocChunk doc -> rnf doc + DsiNamedChunkRef name -> rnf name + DsiExports avails -> rnf avails + DsiModExport mod_names avails -> rnf mod_names `seq` rnf avails + + +type DocStructure = [DocStructureItem] + +data Docs = Docs + { docs_mod_hdr :: Maybe (HsDoc GhcRn) + -- ^ Module header. + , docs_exports :: UniqMap Name (HsDoc GhcRn) + -- ^ Docs attached to module exports. + , docs_decls :: UniqMap Name [HsDoc GhcRn] + -- ^ Docs for declarations: functions, data types, instances, methods etc. + -- A list because sometimes subsequent haddock comments can be combined into one + , docs_args :: UniqMap Name (IntMap (HsDoc GhcRn)) + -- ^ Docs for arguments. E.g. function arguments, method arguments. + , docs_structure :: DocStructure + , docs_named_chunks :: Map String (HsDoc GhcRn) + -- ^ Map from chunk name to content. + -- + -- This map will be empty unless we have an explicit export list from which + -- we can reference the chunks. + , docs_haddock_opts :: Maybe String + -- ^ Haddock options from @OPTIONS_HADDOCK@ or from @-haddock-opts@. + , docs_language :: Maybe Language + -- ^ The 'Language' used in the module, for example 'Haskell2010'. + , docs_extensions :: EnumSet Extension + -- ^ The full set of language extensions used in the module. + } + +instance NFData Docs where + rnf (Docs mod_hdr exps decls args structure named_chunks haddock_opts language extentions) + = rnf mod_hdr `seq` rnf exps `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks + `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions + `seq` () + +instance Binary Docs where + put_ bh docs = do + put_ bh (docs_mod_hdr docs) + put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_exports docs) + put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_decls docs) + put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_args docs) + put_ bh (docs_structure docs) + put_ bh (Map.toList $ docs_named_chunks docs) + put_ bh (docs_haddock_opts docs) + put_ bh (docs_language docs) + put_ bh (docs_extensions docs) + get bh = do + mod_hdr <- get bh + exports <- listToUniqMap <$> get bh + decls <- listToUniqMap <$> get bh + args <- listToUniqMap <$> get bh + structure <- get bh + named_chunks <- Map.fromList <$> get bh + haddock_opts <- get bh + language <- get bh + exts <- get bh + pure Docs { docs_mod_hdr = mod_hdr + , docs_exports = exports + , docs_decls = decls + , docs_args = args + , docs_structure = structure + , docs_named_chunks = named_chunks + , docs_haddock_opts = haddock_opts + , docs_language = language + , docs_extensions = exts + } + +instance Outputable Docs where + ppr docs = + vcat + [ pprField (pprMaybe pprHsDocDebug) "module header" docs_mod_hdr + , pprField (ppr . fmap pprHsDocDebug) "export docs" docs_exports + , pprField (ppr . fmap (ppr . map pprHsDocDebug)) "declaration docs" docs_decls + , pprField (ppr . fmap (pprIntMap ppr pprHsDocDebug)) "arg docs" docs_args + , pprField (vcat . map ppr) "documentation structure" docs_structure + , pprField (pprMap (doubleQuotes . text) pprHsDocDebug) "named chunks" + docs_named_chunks + , pprField pprMbString "haddock options" docs_haddock_opts + , pprField ppr "language" docs_language + , pprField (vcat . map ppr . EnumSet.toList) "language extensions" + docs_extensions + ] + where + pprField :: (a -> SDoc) -> String -> (Docs -> a) -> SDoc + pprField ppr' heading lbl = + text heading O.<> colon $$ nest 2 (ppr' (lbl docs)) + pprMap pprKey pprVal m = + vcat $ flip map (Map.toList m) $ \(k, v) -> + pprKey k O.<> colon $$ nest 2 (pprVal v) + pprIntMap pprKey pprVal m = + vcat $ flip map (IntMap.toList m) $ \(k, v) -> + pprKey k O.<> colon $$ nest 2 (pprVal v) + pprMbString Nothing = empty + pprMbString (Just s) = text s + pprMaybe ppr' = \case + Nothing -> text "Nothing" + Just x -> text "Just" <+> ppr' x + +emptyDocs :: Docs +emptyDocs = Docs + { docs_mod_hdr = Nothing + , docs_exports = emptyUniqMap + , docs_decls = emptyUniqMap + , docs_args = emptyUniqMap + , docs_structure = [] + , docs_named_chunks = Map.empty + , docs_haddock_opts = Nothing + , docs_language = Nothing + , docs_extensions = EnumSet.empty + } + +-- | Maps of docs that were added via Template Haskell's @putDoc@. +data ExtractedTHDocs = + ExtractedTHDocs + { ethd_mod_header :: Maybe (HsDoc GhcRn) + -- ^ The added module header documentation, if it exists. + , ethd_decl_docs :: UniqMap Name (HsDoc GhcRn) + -- ^ The documentation added to declarations. + , ethd_arg_docs :: UniqMap Name (IntMap (HsDoc GhcRn)) + -- ^ The documentation added to function arguments. + , ethd_inst_docs :: UniqMap Name (HsDoc GhcRn) + -- ^ The documentation added to class and family instances. + } diff --git a/GHC/Hs/Doc.hs-boot b/GHC/Hs/Doc.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Hs/Doc.hs-boot @@ -0,0 +1,19 @@ +{-# LANGUAGE RoleAnnotations #-} +module GHC.Hs.Doc where + +-- See #21592 for progress on removing this boot file. + +import GHC.Types.SrcLoc +import GHC.Hs.DocString +import Data.Kind + +type role WithHsDocIdentifiers representational nominal +type WithHsDocIdentifiers :: Type -> Type -> Type +data WithHsDocIdentifiers a pass + +type HsDoc :: Type -> Type +type HsDoc = WithHsDocIdentifiers HsDocString + +type LHsDoc :: Type -> Type +type LHsDoc pass = Located (HsDoc pass) + diff --git a/GHC/Hs/DocString.hs b/GHC/Hs/DocString.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/DocString.hs @@ -0,0 +1,212 @@ +-- | An exactprintable structure for docstrings +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Hs.DocString + ( LHsDocString + , HsDocString(..) + , HsDocStringDecorator(..) + , HsDocStringChunk(..) + , LHsDocStringChunk + , isEmptyDocString + , unpackHDSC + , mkHsDocStringChunk + , mkHsDocStringChunkUtf8ByteString + , pprHsDocString + , pprHsDocStrings + , mkGeneratedHsDocString + , docStringChunks + , renderHsDocString + , renderHsDocStrings + , exactPrintHsDocString + , pprWithDocString + , printDecorator + ) where + +import GHC.Prelude + +import GHC.Utils.Binary +import GHC.Utils.Encoding +import GHC.Utils.Outputable as Outputable hiding ((<>)) +import GHC.Types.SrcLoc +import Control.DeepSeq + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Data +import Data.List.NonEmpty (NonEmpty(..)) +import Data.List (intercalate) + +type LHsDocString = Located HsDocString + +-- | Haskell Documentation String +-- +-- Rich structure to support exact printing +-- The location around each chunk doesn't include the decorators +data HsDocString + = MultiLineDocString !HsDocStringDecorator !(NonEmpty LHsDocStringChunk) + -- ^ The first chunk is preceded by "-- " and each following chunk is preceded by "--" + -- Example: -- | This is a docstring for 'foo'. It is the line with the decorator '|' and is always included + -- -- This continues that docstring and is the second element in the NonEmpty list + -- foo :: a -> a + | NestedDocString !HsDocStringDecorator LHsDocStringChunk + -- ^ The docstring is preceded by "{-" and followed by "-}" + -- The chunk contains balanced pairs of '{-' and '-}' + | GeneratedDocString HsDocStringChunk + -- ^ A docstring generated either internally or via TH + -- Pretty printed with the '-- |' decorator + -- This is because it may contain unbalanced pairs of '{-' and '-}' and + -- not form a valid 'NestedDocString' + deriving (Eq, Data, Show) + +instance Outputable HsDocString where + ppr = text . renderHsDocString + +instance NFData HsDocString where + rnf (MultiLineDocString a b) = rnf a `seq` rnf b + rnf (NestedDocString a b) = rnf a `seq` rnf b + rnf (GeneratedDocString a) = rnf a + +-- | Annotate a pretty printed thing with its doc +-- The docstring comes after if is 'HsDocStringPrevious' +-- Otherwise it comes before. +-- Note - we convert MultiLineDocString HsDocStringPrevious to HsDocStringNext +-- because we can't control if something else will be pretty printed on the same line +pprWithDocString :: HsDocString -> SDoc -> SDoc +pprWithDocString (MultiLineDocString HsDocStringPrevious ds) sd = pprWithDocString (MultiLineDocString HsDocStringNext ds) sd +pprWithDocString doc@(NestedDocString HsDocStringPrevious _) sd = sd <+> pprHsDocString doc +pprWithDocString doc sd = pprHsDocString doc $+$ sd + + +instance Binary HsDocString where + put_ bh x = case x of + MultiLineDocString dec xs -> do + putByte bh 0 + put_ bh dec + put_ bh $ BinLocated <$> xs + NestedDocString dec x -> do + putByte bh 1 + put_ bh dec + put_ bh $ BinLocated x + GeneratedDocString x -> do + putByte bh 2 + put_ bh x + get bh = do + tag <- getByte bh + case tag of + 0 -> MultiLineDocString <$> get bh <*> (fmap unBinLocated <$> get bh) + 1 -> NestedDocString <$> get bh <*> (unBinLocated <$> get bh) + 2 -> GeneratedDocString <$> get bh + t -> fail $ "HsDocString: invalid tag " ++ show t + +data HsDocStringDecorator + = HsDocStringNext -- ^ '|' is the decorator + | HsDocStringPrevious -- ^ '^' is the decorator + | HsDocStringNamed !String -- ^ '$' is the decorator + | HsDocStringGroup !Int -- ^ The decorator is the given number of '*'s + deriving (Eq, Ord, Show, Data) + +instance Outputable HsDocStringDecorator where + ppr = text . printDecorator + +instance NFData HsDocStringDecorator where + rnf HsDocStringNext = () + rnf HsDocStringPrevious = () + rnf (HsDocStringNamed x) = rnf x + rnf (HsDocStringGroup x) = rnf x + +printDecorator :: HsDocStringDecorator -> String +printDecorator HsDocStringNext = "|" +printDecorator HsDocStringPrevious = "^" +printDecorator (HsDocStringNamed n) = '$':n +printDecorator (HsDocStringGroup n) = replicate n '*' + +instance Binary HsDocStringDecorator where + put_ bh x = case x of + HsDocStringNext -> putByte bh 0 + HsDocStringPrevious -> putByte bh 1 + HsDocStringNamed n -> putByte bh 2 >> put_ bh n + HsDocStringGroup n -> putByte bh 3 >> put_ bh n + get bh = do + tag <- getByte bh + case tag of + 0 -> pure HsDocStringNext + 1 -> pure HsDocStringPrevious + 2 -> HsDocStringNamed <$> get bh + 3 -> HsDocStringGroup <$> get bh + t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t + +type LHsDocStringChunk = Located HsDocStringChunk + +-- | A contiguous chunk of documentation +newtype HsDocStringChunk = HsDocStringChunk ByteString + deriving stock (Eq,Ord,Data, Show) + deriving newtype (NFData) + +instance Binary HsDocStringChunk where + put_ bh (HsDocStringChunk bs) = put_ bh bs + get bh = HsDocStringChunk <$> get bh + +instance Outputable HsDocStringChunk where + ppr = text . unpackHDSC + +mkHsDocStringChunk :: String -> HsDocStringChunk +mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeByteString s) + +-- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. +mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk +mkHsDocStringChunkUtf8ByteString = HsDocStringChunk + +unpackHDSC :: HsDocStringChunk -> String +unpackHDSC (HsDocStringChunk bs) = utf8DecodeByteString bs + +nullHDSC :: HsDocStringChunk -> Bool +nullHDSC (HsDocStringChunk bs) = BS.null bs + +mkGeneratedHsDocString :: String -> HsDocString +mkGeneratedHsDocString = GeneratedDocString . mkHsDocStringChunk + +isEmptyDocString :: HsDocString -> Bool +isEmptyDocString (MultiLineDocString _ xs) = all (nullHDSC . unLoc) xs +isEmptyDocString (NestedDocString _ s) = nullHDSC $ unLoc s +isEmptyDocString (GeneratedDocString x) = nullHDSC x + +docStringChunks :: HsDocString -> [LHsDocStringChunk] +docStringChunks (MultiLineDocString _ (x:|xs)) = x:xs +docStringChunks (NestedDocString _ x) = [x] +docStringChunks (GeneratedDocString x) = [L (UnhelpfulSpan UnhelpfulGenerated) x] + +-- | Pretty print with decorators, exactly as the user wrote it +pprHsDocString :: HsDocString -> SDoc +pprHsDocString = text . exactPrintHsDocString + +pprHsDocStrings :: [HsDocString] -> SDoc +pprHsDocStrings = text . intercalate "\n\n" . map exactPrintHsDocString + +-- | Pretty print with decorators, exactly as the user wrote it +exactPrintHsDocString :: HsDocString -> String +exactPrintHsDocString (MultiLineDocString dec (x :| xs)) + = unlines' $ ("-- " ++ printDecorator dec ++ unpackHDSC (unLoc x)) + : map (\x -> "--" ++ unpackHDSC (unLoc x)) xs +exactPrintHsDocString (NestedDocString dec (L _ s)) + = "{-" ++ printDecorator dec ++ unpackHDSC s ++ "-}" +exactPrintHsDocString (GeneratedDocString x) = case lines (unpackHDSC x) of + [] -> "" + (x:xs) -> unlines' $ ( "-- |" ++ x) + : map (\y -> "--"++y) xs + +-- | Just get the docstring, without any decorators +renderHsDocString :: HsDocString -> String +renderHsDocString (MultiLineDocString _ (x :| xs)) = unlines' $ map (unpackHDSC . unLoc) (x:xs) +renderHsDocString (NestedDocString _ ds) = unpackHDSC $ unLoc ds +renderHsDocString (GeneratedDocString x) = unpackHDSC x + +-- | Don't add a newline to a single string +unlines' :: [String] -> String +unlines' = intercalate "\n" + +-- | Just get the docstring, without any decorators +-- Separates docstrings using "\n\n", which is how haddock likes to render them +renderHsDocStrings :: [HsDocString] -> String +renderHsDocStrings = intercalate "\n\n" . map renderHsDocString diff --git a/GHC/Hs/Dump.hs b/GHC/Hs/Dump.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Dump.hs @@ -0,0 +1,481 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} + +{-# OPTIONS_GHC -fno-specialise #-} + -- Don't do type-class specialisation; it goes mad in this module + -- See #25463 + +-- | Contains a debug function to dump parts of the GHC.Hs AST. It uses a syb +-- traversal which falls back to displaying based on the constructor name, so +-- can be used to dump anything having a @Data.Data@ instance. + +module GHC.Hs.Dump ( + -- * Dumping ASTs + showAstData, + showAstDataFull, + BlankSrcSpan(..), + BlankEpAnnotations(..), + ) where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Core.DataCon + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Types.Name.Set +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Var +import GHC.Types.SourceText +import GHC.Utils.Outputable + +import Data.Data hiding (Fixity) +import qualified Data.ByteString as B +import GHC.TypeLits + +-- | Should source spans be removed from output. +data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan + deriving (Eq,Show) + +-- | Should EpAnnotations be removed from output. +data BlankEpAnnotations = BlankEpAnnotations | NoBlankEpAnnotations + deriving (Eq,Show) + +-- | Show the full AST as the compiler sees it. +showAstDataFull :: Data a => a -> SDoc +showAstDataFull = showAstData NoBlankSrcSpan NoBlankEpAnnotations + +-- | Show a GHC syntax tree. This parameterised because it is also used for +-- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked +-- out, to avoid comparing locations, only structure +showAstData :: Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc +showAstData bs ba a0 = blankLine $$ showAstData' a0 + where + showAstData' :: Data a => a -> SDoc + showAstData' = + generic + `ext1Q` list + `extQ` list_epaLocation + `extQ` list_epTokenOpenP + `extQ` list_epTokenCloseP + `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan + `extQ` annotationModule + `extQ` annotationGrhsAnn + `extQ` annotationAnnList + `extQ` annotationAnnListWhere + `extQ` annotationAnnListCommas + `extQ` annotationAnnListIE + `extQ` annotationEpAnnImportDecl + `extQ` annotationNoEpAnns + `extQ` annotationExprBracket + `extQ` annotationTypedBracket + `extQ` epTokenOC + `extQ` epTokenCC + `extQ` epTokenInstance + `extQ` epTokenForall + `extQ` annParen + `extQ` annClassDecl + `extQ` annSynDecl + `extQ` annDataDefn + `extQ` annFamilyDecl + `extQ` annClsInstDecl + `extQ` lit `extQ` litr `extQ` litt + `extQ` sourceText + `extQ` deltaPos + `extQ` epaLocation + `extQ` maybe_epaLocation + `extQ` bytestring + `extQ` name `extQ` occName `extQ` moduleName `extQ` var + `extQ` dataCon + `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet + `ext2Q` located + `extQ` srcSpanAnnA + `extQ` srcSpanAnnL + `extQ` srcSpanAnnP + `extQ` srcSpanAnnC + `extQ` srcSpanAnnN + + where generic :: Data a => a -> SDoc + generic t = parens $ text (showConstr (toConstr t)) + $$ vcat (gmapQ showAstData' t) + + string :: String -> SDoc + string = text . normalize_newlines . show + + fastString :: FastString -> SDoc + fastString s = braces $ + text "FastString:" + <+> text (normalize_newlines . show $ s) + + bytestring :: B.ByteString -> SDoc + bytestring = text . normalize_newlines . show + + list_epaLocation :: [EpaLocation] -> SDoc + list_epaLocation ls = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "[EpaLocation]" + NoBlankEpAnnotations -> list ls + + list_epTokenOpenP :: [EpToken "("] -> SDoc + list_epTokenOpenP ls = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "[EpToken \"(\"]" + NoBlankEpAnnotations -> list ls + + list_epTokenCloseP :: [EpToken ")"] -> SDoc + list_epTokenCloseP ls = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "[EpToken \"(\"]" + NoBlankEpAnnotations -> list ls + + list [] = brackets empty + list [x] = brackets (showAstData' x) + list (x1 : x2 : xs) = (text "[" <> showAstData' x1) + $$ go x2 xs + where + go y [] = text "," <> showAstData' y <> text "]" + go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys + + -- Eliminate word-size dependence + lit :: HsLit GhcPs -> SDoc + lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + lit l = generic l + + litr :: HsLit GhcRn -> SDoc + litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litr l = generic l + + litt :: HsLit GhcTc -> SDoc + litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litt l = generic l + + numericLit :: String -> Integer -> SourceText -> SDoc + numericLit tag x s = braces $ hsep [ text tag + , generic x + , generic s ] + + sourceText :: SourceText -> SDoc + sourceText NoSourceText = case bs of + BlankSrcSpan -> parens $ text "SourceText" <+> text "blanked" + _ -> parens $ text "NoSourceText" + sourceText (SourceText src) = case bs of + BlankSrcSpan -> parens $ text "SourceText" <+> text "blanked" + _ -> parens $ text "SourceText" <+> ftext src + + epaLocation :: EpaLocation -> SDoc + epaLocation (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s + epaLocation (EpaDelta s d cs) = case ba of + NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> showAstData' cs + BlankEpAnnotations -> parens $ text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> text "blanked" + + maybe_epaLocation :: Maybe EpaLocation -> SDoc + maybe_epaLocation ml = case ba of + NoBlankEpAnnotations -> case ml of + Nothing -> parens $ text "Nothing" + Just l -> parens (text "Just" $$ showAstData' l) + BlankEpAnnotations -> parens $ text "Maybe EpaLocation:" <+> text "blanked" + + deltaPos :: DeltaPos -> SDoc + deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c + deltaPos (DifferentLine l c) = parens $ text "DifferentLine" <+> ppr l <+> ppr c + + name :: Name -> SDoc + name nm = braces $ text "Name:" <+> ppr nm + + occName n = braces $ + text "OccName:" + <+> ftext (occNameFS n) + + moduleName :: ModuleName -> SDoc + moduleName m = braces $ text "ModuleName:" <+> ppr m + + srcSpan :: SrcSpan -> SDoc + srcSpan ss = case bs of + BlankSrcSpan -> text "{ ss }" + NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' ' + BlankSrcSpanFile -> braces $ char ' ' <> (pprUserSpan False ss) <> char ' ' + + realSrcSpan :: RealSrcSpan -> SDoc + realSrcSpan ss = case bs of + BlankSrcSpan -> text "{ ss }" + NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' ' + BlankSrcSpanFile -> braces $ char ' ' <> (pprUserRealSpan False ss) <> char ' ' + + annParen :: AnnParen -> SDoc + annParen ap = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnParen" + NoBlankEpAnnotations -> parens (case ap of + (AnnParens o c) -> text "AnnParens" $$ vcat [showAstData' o, showAstData' c] + (AnnParensHash o c) -> text "AnnParensHash" $$ vcat [showAstData' o, showAstData' c] + (AnnParensSquare o c) -> text "AnnParensSquare" $$ vcat [showAstData' o, showAstData' c] + ) + + annClassDecl :: AnnClassDecl -> SDoc + annClassDecl (AnnClassDecl c ops cps v w oc cc s) = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnClassDecl" + NoBlankEpAnnotations -> + parens $ text "AnnClassDecl" + $$ vcat [showAstData' c, showAstData' ops, showAstData' cps, + showAstData' v, showAstData' w, showAstData' oc, + showAstData' cc, showAstData' s] + + annSynDecl :: AnnSynDecl -> SDoc + annSynDecl (AnnSynDecl ops cps t e) = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnSynDecl" + NoBlankEpAnnotations -> + parens $ text "AnnSynDecl" + $$ vcat [showAstData' ops, showAstData' cps, + showAstData' t, showAstData' e] + + annDataDefn :: AnnDataDefn -> SDoc + annDataDefn (AnnDataDefn a b c d e f g h i j k) = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnDataDefn" + NoBlankEpAnnotations -> + parens $ text "AnnDataDefn" + $$ vcat [showAstData' a, showAstData' b, showAstData' c, + showAstData' d, showAstData' e, showAstData' f, + showAstData' g, showAstData' h, showAstData' i, + showAstData' j, showAstData' k] + + annFamilyDecl :: AnnFamilyDecl -> SDoc + annFamilyDecl (AnnFamilyDecl a b c d e f g h i j k l) = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl" + NoBlankEpAnnotations -> + parens $ text "AnnFamilyDecl" + $$ vcat [showAstData' a, showAstData' b, showAstData' c, + showAstData' d, showAstData' e, showAstData' f, + showAstData' g, showAstData' h, showAstData' i, + showAstData' j, showAstData' k, showAstData' l] + + annClsInstDecl :: AnnClsInstDecl -> SDoc + annClsInstDecl (AnnClsInstDecl a b c d e) = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl" + NoBlankEpAnnotations -> + parens $ text "AnnClsInstDecl" + $$ vcat [showAstData' a, showAstData' b, showAstData' c, + showAstData' d, showAstData' e] + + + annotationExprBracket :: BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|") -> SDoc + annotationExprBracket = annotationBracket + + annotationTypedBracket :: BracketAnn (EpToken "[||") (EpToken "[e||") -> SDoc + annotationTypedBracket = annotationBracket + + annotationBracket ::forall n h .(Data n, Data h, Typeable n, Typeable h) + => BracketAnn n h -> SDoc + annotationBracket a = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "BracketAnn" + NoBlankEpAnnotations -> + parens $ case a of + BracketNoE t -> text "BracketNoE" <+> showAstData' t + BracketHasE t -> text "BracketHasE" <+> showAstData' t + + epTokenOC :: EpToken "{" -> SDoc + epTokenOC = epToken' + + epTokenCC :: EpToken "}" -> SDoc + epTokenCC = epToken' + + epTokenInstance :: EpToken "instance" -> SDoc + epTokenInstance = epToken' + + epTokenForall :: TokForall -> SDoc + epTokenForall = epUniToken' + + epToken' :: KnownSymbol sym => EpToken sym -> SDoc + epToken' (EpTok s) = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "EpToken" + NoBlankEpAnnotations -> + parens $ text "EpTok" <+> epaLocation s + epToken' NoEpTok = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "EpToken" + NoBlankEpAnnotations -> + parens $ text "NoEpTok" + + epUniToken' :: EpUniToken sym1 sym2 -> SDoc + epUniToken' (EpUniTok s f) = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "EpUniToken" + NoBlankEpAnnotations -> + parens $ text "EpUniTok" <+> epaLocation s <+> ppr f + epUniToken' NoEpUniTok = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "EpUniToken" + NoBlankEpAnnotations -> + parens $ text "NoEpUniTok" + + + var :: Var -> SDoc + var v = braces $ text "Var:" <+> ppr v + + dataCon :: DataCon -> SDoc + dataCon c = braces $ text "DataCon:" <+> ppr c + + bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc + bagRdrName bg = braces $ + text "Bag(LocatedA (HsBind GhcPs)):" + $$ (list . bagToList $ bg) + + bagName :: Bag (LocatedA (HsBind GhcRn)) -> SDoc + bagName bg = braces $ + text "Bag(LocatedA (HsBind Name)):" + $$ (list . bagToList $ bg) + + bagVar :: Bag (LocatedA (HsBind GhcTc)) -> SDoc + bagVar bg = braces $ + text "Bag(LocatedA (HsBind Var)):" + $$ (list . bagToList $ bg) + + nameSet ns = braces $ + text "NameSet:" + $$ (list . nameSetElemsStable $ ns) + + located :: (Data a, Data b) => GenLocated a b -> SDoc + located (L ss a) + = parens (text "L" + $$ vcat [showAstData' ss, showAstData' a]) + + + -- ------------------------- + + annotationModule :: EpAnn AnnsModule -> SDoc + annotationModule = annotation' (text "EpAnn AnnsModule") + + annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc + annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") + + annotationAnnList :: EpAnn (AnnList ()) -> SDoc + annotationAnnList = annotation' (text "EpAnn (AnnList ())") + + annotationAnnListWhere :: EpAnn (AnnList (EpToken "where")) -> SDoc + annotationAnnListWhere = annotation' (text "EpAnn (AnnList (EpToken \"where\"))") + + annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc + annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])") + + annotationAnnListIE :: EpAnn (AnnList (EpToken "hiding", [EpToken ","])) -> SDoc + annotationAnnListIE = annotation' (text "EpAnn (AnnList (EpToken \"hiding\", [EpToken \",\"]))") + + annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc + annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl") + + annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc + annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns") + + annotation' :: forall a .(Data a, Typeable a) + => SDoc -> EpAnn a -> SDoc + annotation' tag anns = case ba of + BlankEpAnnotations -> parens (text "blanked:" <+> tag) + NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns)) + $$ vcat (gmapQ showAstData' anns) + + -- ------------------------- + + srcSpanAnnA :: EpAnn AnnListItem -> SDoc + srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") + + srcSpanAnnL :: EpAnn (AnnList ()) -> SDoc + srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") + + srcSpanAnnP :: EpAnn AnnPragma -> SDoc + srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") + + srcSpanAnnC :: EpAnn AnnContext -> SDoc + srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") + + srcSpanAnnN :: EpAnn NameAnn -> SDoc + srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") + + locatedAnn'' :: forall a. (Typeable a, Data a) + => SDoc -> EpAnn a -> SDoc + locatedAnn'' tag ss = parens $ + case cast ss of + Just (ann :: EpAnn a) -> + case ba of + BlankEpAnnotations + -> parens (text "blanked:" <+> tag) + NoBlankEpAnnotations + -> text (showConstr (toConstr ann)) + $$ vcat (gmapQ showAstData' ann) + Nothing -> text "locatedAnn:unmatched" <+> tag + <+> (parens $ text (showConstr (toConstr ss))) + + +normalize_newlines :: String -> String +normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs +normalize_newlines (x:xs) = x:normalize_newlines xs +normalize_newlines [] = [] + +{- +************************************************************************ +* * +* Copied from syb +* * +************************************************************************ +-} + + +-- | The type constructor for queries +newtype Q q x = Q { unQ :: x -> q } + +-- | Extend a generic query by a type-specific case +extQ :: ( Typeable a + , Typeable b + ) + => (a -> q) + -> (b -> q) + -> a + -> q +extQ f g a = maybe (f a) g (cast a) + +-- | Type extension of queries for type constructors +ext1Q :: (Data d, Typeable t) + => (d -> q) + -> (forall e. Data e => t e -> q) + -> d -> q +ext1Q def ext = unQ ((Q def) `ext1` (Q ext)) + + +-- | Type extension of queries for type constructors +ext2Q :: (Data d, Typeable t) + => (d -> q) + -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) + -> d -> q +ext2Q def ext = unQ ((Q def) `ext2` (Q ext)) + +-- | Flexible type extension +ext1 :: (Data a, Typeable t) + => c a + -> (forall d. Data d => c (t d)) + -> c a +ext1 def ext = maybe def id (dataCast1 ext) + + + +-- | Flexible type extension +ext2 :: (Data a, Typeable t) + => c a + -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) + -> c a +ext2 def ext = maybe def id (dataCast2 ext) diff --git a/GHC/Hs/Expr.hs b/GHC/Hs/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Expr.hs @@ -0,0 +1,2722 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension + +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +-- | Abstract Haskell syntax for expressions. +module GHC.Hs.Expr + ( module Language.Haskell.Syntax.Expr + , module GHC.Hs.Expr + ) where + +import Language.Haskell.Syntax.Expr + +-- friends: +import GHC.Prelude + +import GHC.Hs.Basic() -- import instances +import GHC.Hs.Decls() -- import instances +import GHC.Hs.Pat +import GHC.Hs.Lit +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import GHC.Hs.Extension +import GHC.Hs.Type +import GHC.Hs.Binds +import GHC.Parser.Annotation + +-- others: +import GHC.Tc.Types.Evidence +import GHC.Types.Id.Info ( RecSelParent ) +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Name.Set +import GHC.Types.Basic +import GHC.Types.Fixity +import GHC.Types.SourceText +import GHC.Types.SrcLoc +import GHC.Types.Tickish (CoreTickish) +import GHC.Types.Unique.Set (UniqSet) +import GHC.Types.ThLevelIndex +import GHC.Core.ConLike ( conLikeName, ConLike ) +import GHC.Unit.Module (ModuleName) +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.FastString +import GHC.Core.Type +import GHC.Builtin.Types (mkTupleStr) +import GHC.Tc.Utils.TcType (TcType, TcTyVar) +import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv) + +import GHCi.RemoteTypes ( ForeignRef ) +import qualified GHC.Boot.TH.Syntax as TH (Q) + +-- libraries: +import Data.Data hiding (Fixity(..)) +import qualified Data.Data as Data (Fixity(..)) +import qualified Data.Kind +import Data.Maybe (isJust) +import Data.Foldable ( toList ) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Void (Void) +import qualified Data.Set as S +{- ********************************************************************* +* * + Expressions proper +* * +********************************************************************* -} + +-- | Post-Type checking Expression +-- +-- PostTcExpr is an evidence expression attached to the syntax tree by the +-- type checker (c.f. postTcType). +type PostTcExpr = HsExpr GhcTc + +-- | Post-Type checking Table +-- +-- We use a PostTcTable where there are a bunch of pieces of evidence, more +-- than is convenient to keep individually. +type PostTcTable = [(Name, PostTcExpr)] + +------------------------- + +-- Defining SyntaxExpr in two stages allows for better type inference, because +-- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity, +-- noSyntaxExpr would be ambiguous. +type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p + +type family SyntaxExprGhc (p :: Pass) = (r :: Data.Kind.Type) | r -> p where + SyntaxExprGhc 'Parsed = NoExtField + SyntaxExprGhc 'Renamed = SyntaxExprRn + SyntaxExprGhc 'Typechecked = SyntaxExprTc + +-- | The function to use in rebindable syntax. See Note [NoSyntaxExpr]. +data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn) + -- Why is the payload not just a Name? + -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr" + | NoSyntaxExprRn + +-- | An expression with wrappers, used for rebindable syntax +-- +-- This should desugar to +-- +-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0) +-- > (syn_arg_wraps[1] arg1) ... +-- +-- where the actual arguments come from elsewhere in the AST. +data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc + , syn_arg_wraps :: [HsWrapper] + , syn_res_wrap :: HsWrapper } + | NoSyntaxExprTc -- See Note [NoSyntaxExpr] + +-- | This is used for rebindable-syntax pieces that are too polymorphic +-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) +noExpr :: HsExpr (GhcPass p) +noExpr = HsLit noExtField (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr")) + +noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p) + -- Before renaming, and sometimes after + -- See Note [NoSyntaxExpr] +noSyntaxExpr = case ghcPass @p of + GhcPs -> noExtField + GhcRn -> NoSyntaxExprRn + GhcTc -> NoSyntaxExprTc + +-- | Make a 'SyntaxExpr GhcRn' from an expression +-- Used only in getMonadFailOp. +-- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr" +mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn +mkSyntaxExpr = SyntaxExprRn + +instance Outputable SyntaxExprRn where + ppr (SyntaxExprRn expr) = ppr expr + ppr NoSyntaxExprRn = text "" + +instance Outputable SyntaxExprTc where + ppr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + = sdocOption sdocPrintExplicitCoercions $ \print_co -> + getPprDebug $ \debug -> + if debug || print_co + then ppr expr <> braces (pprWithCommas ppr arg_wraps) + <> braces (ppr res_wrap) + else ppr expr + + ppr NoSyntaxExprTc = text "" + +-- | HsWrap appears only in typechecker output +data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper + (hs_syn GhcTc) -- the thing that is wrapped + +deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn) + +-- --------------------------------------------------------------------- + +data HsBracketTc = HsBracketTc + { hsb_quote :: HsQuote GhcRn -- See Note [The life cycle of a TH quotation] + , hsb_ty :: Type + , hsb_wrap :: Maybe QuoteWrapper -- The wrapper to apply type and dictionary argument to the quote. + , hsb_splices :: [PendingTcSplice] -- Output of the type checker is the *original* + -- renamed expression, plus + -- _typechecked_ splices to be + -- pasted back in by the desugarer + } + +type instance XTypedBracket GhcPs = (BracketAnn (EpToken "[||") (EpToken "[e||"), EpToken "||]") +type instance XTypedBracket GhcRn = NoExtField +type instance XTypedBracket GhcTc = HsBracketTc +type instance XUntypedBracket GhcPs = NoExtField +type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices] + -- Output of the renamer is the *original* renamed expression, + -- plus _renamed_ splices to be type checked +type instance XUntypedBracket GhcTc = HsBracketTc + +data BracketAnn noE hasE + = BracketNoE noE + | BracketHasE hasE + deriving Data + +instance (NoAnn n, NoAnn h) => NoAnn (BracketAnn n h) where + noAnn = BracketNoE noAnn + +-- --------------------------------------------------------------------- + +-- API Annotations types + +data EpAnnHsCase = EpAnnHsCase + { hsCaseAnnCase :: EpToken "case" + , hsCaseAnnOf :: EpToken "of" + } deriving Data + +instance NoAnn EpAnnHsCase where + noAnn = EpAnnHsCase noAnn noAnn + +data EpAnnLam = EpAnnLam + { epl_lambda :: EpToken "\\" -- ^ Location of '\' keyword + , epl_case :: Maybe EpaLocation -- ^ Location of 'case' or + -- 'cases' keyword, depending + -- on related 'HsLamVariant'. + } deriving Data + +instance NoAnn EpAnnLam where + noAnn = EpAnnLam noAnn noAnn + +-- Record selectors at parse time are HsVar; they convert to HsRecSel +-- on renaming. +type instance XRecSel GhcPs = DataConCantHappen +type instance XRecSel GhcRn = NoExtField +type instance XRecSel GhcTc = NoExtField + +-- OverLabel not present in GhcTc pass; see GHC.Rename.Expr +-- Note [Handling overloaded and rebindable constructs] +type instance XOverLabel GhcPs = SourceText +type instance XOverLabel GhcRn = SourceText +type instance XOverLabel GhcTc = DataConCantHappen + +-- --------------------------------------------------------------------- + +type instance XVar (GhcPass _) = NoExtField + +type instance XIPVar GhcPs = NoExtField +type instance XIPVar GhcRn = NoExtField +type instance XIPVar GhcTc = DataConCantHappen +type instance XOverLitE (GhcPass _) = NoExtField +type instance XLitE (GhcPass _) = NoExtField +type instance XLam (GhcPass _) = EpAnnLam +type instance XApp (GhcPass _) = NoExtField + +type instance XAppTypeE GhcPs = EpToken "@" +type instance XAppTypeE GhcRn = NoExtField +type instance XAppTypeE GhcTc = Type + +-- OpApp not present in GhcTc pass; see GHC.Rename.Expr +-- Note [Handling overloaded and rebindable constructs] +type instance XOpApp GhcPs = NoExtField +type instance XOpApp GhcRn = Fixity +type instance XOpApp GhcTc = DataConCantHappen + +-- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr +-- Note [Handling overloaded and rebindable constructs] +type instance XSectionL GhcPs = NoExtField +type instance XSectionR GhcPs = NoExtField +type instance XSectionL GhcRn = NoExtField +type instance XSectionR GhcRn = NoExtField +type instance XSectionL GhcTc = DataConCantHappen +type instance XSectionR GhcTc = DataConCantHappen + + +type instance XNegApp GhcPs = EpToken "-" +type instance XNegApp GhcRn = NoExtField +type instance XNegApp GhcTc = NoExtField + +type instance XPar GhcPs = (EpToken "(", EpToken ")") +type instance XPar GhcRn = NoExtField +type instance XPar GhcTc = NoExtField + +type instance XExplicitTuple GhcPs = (EpaLocation, EpaLocation) +type instance XExplicitTuple GhcRn = NoExtField +type instance XExplicitTuple GhcTc = NoExtField + +type instance XExplicitSum GhcPs = AnnExplicitSum +type instance XExplicitSum GhcRn = NoExtField +type instance XExplicitSum GhcTc = [Type] + +type instance XCase GhcPs = EpAnnHsCase +type instance XCase GhcRn = HsMatchContextRn +type instance XCase GhcTc = HsMatchContextRn + +type instance XIf GhcPs = AnnsIf +type instance XIf GhcRn = NoExtField +type instance XIf GhcTc = NoExtField + +type instance XMultiIf GhcPs = (EpToken "if", EpToken "{", EpToken "}") +type instance XMultiIf GhcRn = NoExtField +type instance XMultiIf GhcTc = Type + +type instance XLet GhcPs = (EpToken "let", EpToken "in") +type instance XLet GhcRn = NoExtField +type instance XLet GhcTc = NoExtField + +type instance XDo GhcPs = AnnList EpaLocation +type instance XDo GhcRn = NoExtField +type instance XDo GhcTc = Type + +type instance XExplicitList GhcPs = AnnList () +type instance XExplicitList GhcRn = NoExtField +type instance XExplicitList GhcTc = Type +-- GhcPs: ExplicitList includes all source-level +-- list literals, including overloaded ones +-- GhcRn and GhcTc: ExplicitList used only for list literals +-- that denote Haskell's built-in lists. Overloaded lists +-- have been expanded away in the renamer +-- See Note [Handling overloaded and rebindable constructs] +-- in GHC.Rename.Expr + +type instance XRecordCon GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}")) +type instance XRecordCon GhcRn = NoExtField +type instance XRecordCon GhcTc = PostTcExpr -- Instantiated constructor function + +type instance XRecordUpd GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}")) +type instance XRecordUpd GhcRn = NoExtField +type instance XRecordUpd GhcTc = DataConCantHappen + -- We desugar record updates in the typechecker. + -- See [Handling overloaded and rebindable constructs], + -- and [Record Updates] in GHC.Tc.Gen.Expr. + +-- | Information about the parent of a record update: +-- +-- - the parent type constructor or pattern synonym, +-- - the relevant con-likes, +-- - the field labels. +data family HsRecUpdParent x + +data instance HsRecUpdParent GhcPs +data instance HsRecUpdParent GhcRn + = RnRecUpdParent + { rnRecUpdLabels :: NonEmpty FieldGlobalRdrElt + , rnRecUpdCons :: UniqSet ConLikeName } +data instance HsRecUpdParent GhcTc + = TcRecUpdParent + { tcRecUpdParent :: RecSelParent + , tcRecUpdLabels :: NonEmpty FieldGlobalRdrElt + , tcRecUpdCons :: UniqSet ConLike } + +type instance XLHsRecUpdLabels GhcPs = NoExtField +type instance XLHsRecUpdLabels GhcRn = NonEmpty (HsRecUpdParent GhcRn) + -- Possible parents for the record update. +type instance XLHsRecUpdLabels GhcTc = DataConCantHappen + +type instance XLHsOLRecUpdLabels p = NoExtField + +type instance XGetField GhcPs = NoExtField +type instance XGetField GhcRn = NoExtField +type instance XGetField GhcTc = DataConCantHappen +-- HsGetField is eliminated by the renamer. See [Handling overloaded +-- and rebindable constructs]. + +type instance XProjection GhcPs = AnnProjection +type instance XProjection GhcRn = NoExtField +type instance XProjection GhcTc = DataConCantHappen +-- HsProjection is eliminated by the renamer. See [Handling overloaded +-- and rebindable constructs]. + +type instance XExprWithTySig GhcPs = TokDcolon +type instance XExprWithTySig GhcRn = NoExtField +type instance XExprWithTySig GhcTc = NoExtField + +type instance XArithSeq GhcPs = AnnArithSeq +type instance XArithSeq GhcRn = NoExtField +type instance XArithSeq GhcTc = PostTcExpr + +type instance XProc (GhcPass _) = (EpToken "proc", TokRarrow) + +type instance XStatic GhcPs = EpToken "static" +type instance XStatic GhcRn = NameSet +type instance XStatic GhcTc = (NameSet, Type) + -- Free variables and type of expression, this is stored for convenience as wiring in + -- StaticPtr is a bit tricky (see #20150) + +type instance XEmbTy GhcPs = EpToken "type" +type instance XEmbTy GhcRn = NoExtField +type instance XEmbTy GhcTc = DataConCantHappen + -- A free-standing HsEmbTy is an error. + -- Valid usages are immediately desugared into Type. + + +{- +Note [Holes in expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note explains how GHC uses the `HsHole` constructor. + +`HsHole` is used to represent: + + - anonymous ("_") and named ("_x") holes in expressions, + - unbound variables, + - and parse errors. + +A `HsHole` can be thought of as any thing which is not necessarily a valid or +fully defined program fragment, but for which a type can be derived. + +Note that holes (wildcards) in types, and partial type signatures, are not +handled using the mechanisms described here. Instead, see +Note [The wildcard story for types] for the relevant information. + + +* User-facing behavior + + While GHC uses the same internal mechanism to derive the type for any + `HsHole`, it gives different feedback to the user depending on the type of + hole. For example, an anonymous hole of the form + + foo x = x && _ + + gives the diagnostic + + Foo.hs:5:14: error: [GHC-88464] + • Found hole: _ :: Bool + • In the second argument of ‘(&&)’, namely ‘_’ + In the expression: x && _ + + while an expression containing an unbound variable + + foo x = x && y + + gives + + Foo.hs:5:14: error: [GHC-88464] + Variable not in scope: y :: Bool + + +* HsHole during parsing, renaming, and type checking + + The usage of `HsHole` during the three phases is listed below. + + - Anynomous holes, i.e. the user wrote "_": + + Parser HsHole (HoleVar "_") + Renamer HsHole (HoleVar "_") + Typechecker HsHole (HoleVar "_", ref :: HoleExprRef) + + - Unbound variables and named holes; i.e. the user wrote "x" or "_x", where + `x` or `_x` is not in scope. A variable with a leading underscore has no + special meaning to the parser. + + Parser HsVar "_x" + Renamer HsHole (HoleVar "_x") + Typechecker HsHole (HoleVar "_x", ref :: HoleExprRef) + + - Parse errors currently do not survive beyond the parser because an error is + thrown after parsing. However, in the future GHC is intended to be tolerant + of parse errors until the type checking phase to provide diagnostics similar + to holes. This current singular case looks like this: + + Parser HsHole HoleError + + Note that between anonymous holes, named holes, and unbound variables only the + parsing phase is distinct, while during the renaming and type checking phases + the cases are handled identically. The distinction that the user can observe + is only introduced during final error reporting. There the `RdrName` is + examined to see whether it starts with an underscore or not to determine + whether the `HsHole` came from a hole or an out of scope variable. + + +* Contents of HoleExprRef + + The HoleExprRef type used in the type checking phase is a data structure + containing: + + - The type of the hole. + - A ref-cell that is filled in (by the typechecker) with an + error thunk. With -fdefer-type errors we use this as the + value of the hole. + - A Unique (see Note [Uniques and tags]). + +* Typechecking holes + + When the typechecker encounters a `HsHole`, it returns one with the + HoleExprRef, but also emits a `DelayedError` into the `WantedConstraints`. + This DelayedError later triggers the error reporting, and the filling-in of + the error thunk, in GHC.Tc.Errors. + + The user has the option of deferring errors until runtime with + `-fdefer-type-errors`. In this case, the hole carries evidence in its + `HoleExprRef`. This evidence is an erroring expression that prints an error + and crashes at runtime. + +* Desugaring holes + + During desugaring, the `(HsHole (HoleVar "x", ref))` is desugared by + reading the ref-cell to find the error thunk evidence term, put there by the + constraint solver. + +* Wrinkles: + + - Prior to fixing #17812, we used to invent an Id to hold the erroring + expression, and then bind it during type-checking. But this does not support + representation-polymorphic out-of-scope identifiers. See + typecheck/should_compile/T17812. We thus use the mutable-CoreExpr approach + described above. + + - You might think that the type in the HoleExprRef is the same as the type of + the hole. However, because the hole type (hole_ty) is rewritten with respect + to givens, this might not be the case. That is, the hole_ty is always (~) to + the type of the HoleExprRef, but they might not be `eqType`. We need the + type of the generated evidence to match what is expected in the context of + the hole, and so we must store these types separately. + + - We really don't need the whole HoleExprRef; just the IORef EvTerm would be + enough. But then deriving a Data instance becomes impossible. Much, much + easier just to define HoleExprRef with a Data instance and store the whole + structure. +-} +-- | Expression Hole. See Note [Holes in expressions]. +type instance XHole GhcPs = HoleKind +type instance XHole GhcRn = HoleKind +type instance XHole GhcTc = (HoleKind, HoleExprRef) + +data HoleKind + = HoleVar (LIdP GhcPs) + | HoleError + deriving Data + +-- | The RdrName for an unnamed hole ("_"). +unnamedHoleRdrName :: RdrName +unnamedHoleRdrName = mkUnqual varName (fsLit "_") + + +type instance XForAll GhcPs = NoExtField +type instance XForAll GhcRn = NoExtField +type instance XForAll GhcTc = DataConCantHappen + +type instance XQual GhcPs = NoExtField +type instance XQual GhcRn = NoExtField +type instance XQual GhcTc = DataConCantHappen + +type instance XFunArr GhcPs = NoExtField +type instance XFunArr GhcRn = NoExtField +type instance XFunArr GhcTc = DataConCantHappen + +type instance XPragE (GhcPass _) = NoExtField + +type instance XFunRhs = AnnFunRhs + +type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW +type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA + +multAnnToHsExpr :: HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn -> Maybe (LocatedA (HsExpr GhcRn)) +multAnnToHsExpr = expandHsMultAnnOf mkHsVar + +mkHsVar :: forall p. IsPass p => LIdP (GhcPass p) -> HsExpr (GhcPass p) +mkHsVar n = HsVar noExtField $ + case ghcPass @p of + GhcPs -> n + GhcRn -> fmap (WithUserRdr $ nameRdrName $ unLoc n) n + GhcTc -> n + +mkHsVarWithUserRdr :: forall p. IsPass p => RdrName -> LIdP (GhcPass p) -> HsExpr (GhcPass p) +mkHsVarWithUserRdr rdr n = HsVar noExtField $ + case ghcPass @p of + GhcPs -> n + GhcRn -> fmap (WithUserRdr rdr) n + GhcTc -> n + +data AnnExplicitSum + = AnnExplicitSum { + aesOpen :: EpaLocation, + aesBarsBefore :: [EpToken "|"], + aesBarsAfter :: [EpToken "|"], + aesClose :: EpaLocation + } deriving Data + +instance NoAnn AnnExplicitSum where + noAnn = AnnExplicitSum noAnn noAnn noAnn noAnn + +data AnnFieldLabel + = AnnFieldLabel { + afDot :: Maybe (EpToken ".") + } deriving Data + +instance NoAnn AnnFieldLabel where + noAnn = AnnFieldLabel Nothing + +data AnnProjection + = AnnProjection { + apOpen :: EpToken "(", + apClose :: EpToken ")" + } deriving Data + +instance NoAnn AnnProjection where + noAnn = AnnProjection noAnn noAnn + +data AnnArithSeq + = AnnArithSeq { + aas_open :: EpToken "[", + aas_comma :: Maybe (EpToken ","), + aas_dotdot :: EpToken "..", + aas_close :: EpToken "]" + } deriving Data + +instance NoAnn AnnArithSeq where + noAnn = AnnArithSeq noAnn noAnn noAnn noAnn + +data AnnsIf + = AnnsIf { + aiIf :: EpToken "if", + aiThen :: EpToken "then", + aiElse :: EpToken "else", + aiThenSemi :: Maybe (EpToken ";"), + aiElseSemi :: Maybe (EpToken ";") + } deriving Data + +instance NoAnn AnnsIf where + noAnn = AnnsIf noAnn noAnn noAnn Nothing Nothing + +data AnnFunRhs + = AnnFunRhs { + afr_strict :: EpToken "!", + afr_opens :: [EpToken "("], + afr_closes :: [EpToken ")"] + } deriving Data + +instance NoAnn AnnFunRhs where + noAnn = AnnFunRhs noAnn noAnn noAnn + +-- --------------------------------------------------------------------- + +type instance XSCC (GhcPass _) = (AnnPragma, SourceText) +type instance XXPragE (GhcPass _) = DataConCantHappen + +type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel +type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen + +type instance XPresent (GhcPass _) = NoExtField + +type instance XMissing GhcPs = EpAnn Bool -- True for empty last comma +type instance XMissing GhcRn = NoExtField +type instance XMissing GhcTc = Scaled Type + +type instance XXTupArg (GhcPass _) = DataConCantHappen + +tupArgPresent :: HsTupArg (GhcPass p) -> Bool +tupArgPresent (Present {}) = True +tupArgPresent (Missing {}) = False + +tupArgPresent_maybe :: HsTupArg (GhcPass p) -> Maybe (LHsExpr (GhcPass p)) +tupArgPresent_maybe (Present _ e) = Just e +tupArgPresent_maybe (Missing {}) = Nothing + +tupArgsPresent_maybe :: [HsTupArg (GhcPass p)] -> Maybe [LHsExpr (GhcPass p)] +tupArgsPresent_maybe = traverse tupArgPresent_maybe + + +{- ********************************************************************* +* * + XXExpr: the extension constructor of HsExpr +* * +********************************************************************* -} + +type instance XXExpr GhcPs = DataConCantHappen +type instance XXExpr GhcRn = XXExprGhcRn +type instance XXExpr GhcTc = XXExprGhcTc +-- XXExprGhcRn: see Note [Rebindable syntax and XXExprGhcRn] below + + +{- ********************************************************************* +* * + Generating code for ExpandedThingRn + See Note [Handling overloaded and rebindable constructs] +* * +********************************************************************* -} + +-- | The different source constructs that we use to instantiate the "original" field +-- in an `XXExprGhcRn original expansion` +data HsThingRn = OrigExpr (HsExpr GhcRn) + | OrigStmt (ExprLStmt GhcRn) + | OrigPat (LPat GhcRn) + +isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool +isHsThingRnExpr (OrigExpr{}) = True +isHsThingRnExpr _ = False + +isHsThingRnStmt (OrigStmt{}) = True +isHsThingRnStmt _ = False + +isHsThingRnPat (OrigPat{}) = True +isHsThingRnPat _ = False + +data XXExprGhcRn + = ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing + , xrn_expanded :: HsExpr GhcRn } -- The compiler generated expanded thing + + | PopErrCtxt -- A hint for typechecker to pop + {-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack + -- Does not presist post renaming phase + -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn] + -- in `GHC.Tc.Gen.Do` + | HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector + -- See Note [Non-overloaded record field selectors] and + -- Note [Record selectors in the AST] + + + +-- | Wrap a located expression with a `PopErrCtxt` +mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn +mkPopErrCtxtExpr a = XExpr (PopErrCtxt a) + +-- | Wrap a located expression with a PopSrcExpr with an appropriate location +mkPopErrCtxtExprAt :: SrcSpanAnnA -> LHsExpr GhcRn -> LHsExpr GhcRn +mkPopErrCtxtExprAt loc a = L loc $ mkPopErrCtxtExpr a + +-- | Build an expression using the extension constructor `XExpr`, +-- and the two components of the expansion: original expression and +-- expanded expressions. +mkExpandedExpr + :: HsExpr GhcRn -- ^ source expression + -> HsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr) + +-- | Build an expression using the extension constructor `XExpr`, +-- and the two components of the expansion: original do stmt and +-- expanded expression +mkExpandedStmt + :: ExprLStmt GhcRn -- ^ source statement + -> HsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr) + +mkExpandedPatRn + :: LPat GhcRn -- ^ source pattern + -> HsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr) + +-- | Build an expression using the extension constructor `XExpr`, +-- and the two components of the expansion: original do stmt and +-- expanded expression an associate with a provided location +mkExpandedStmtAt + :: SrcSpanAnnA -- ^ Location for the expansion expression + -> ExprLStmt GhcRn -- ^ source statement + -> HsExpr GhcRn -- ^ expanded expression + -> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn' +mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr + +-- | Wrap the expanded version of the expression with a pop. +mkExpandedStmtPopAt + :: SrcSpanAnnA -- ^ Location for the expansion statement + -> ExprLStmt GhcRn -- ^ source statement + -> HsExpr GhcRn -- ^ expanded expression + -> LHsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr + + +data XXExprGhcTc + = WrapExpr -- Type and evidence application and abstractions + HsWrapper (HsExpr GhcTc) + + | ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn] + -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` + { xtc_orig :: HsThingRn -- The original user written thing + , xtc_expanded :: HsExpr GhcTc } -- The expanded typechecked expression + + | ConLikeTc -- Result of typechecking a data-con + -- See Note [Typechecking data constructors] in + -- GHC.Tc.Gen.Head + -- The two arguments describe how to eta-expand + -- the data constructor when desugaring + ConLike [TcTyVar] [Scaled TcType] + + --------------------------------------- + -- Haskell program coverage (Hpc) Support + + | HsTick + CoreTickish + (LHsExpr GhcTc) -- sub-expression + + | HsBinTick + Int -- module-local tick number for True + Int -- module-local tick number for False + (LHsExpr GhcTc) -- sub-expression + + | HsRecSelTc (FieldOcc GhcTc) -- ^ Variable pointing to record selector + -- See Note [Non-overloaded record field selectors] and + -- Note [Record selectors in the AST] + + +-- | Build a 'XXExprGhcRn' out of an extension constructor, +-- and the two components of the expansion: original and +-- expanded typechecked expressions. +mkExpandedExprTc + :: HsExpr GhcRn -- ^ source expression + -> HsExpr GhcTc -- ^ expanded typechecked expression + -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr) + +-- | Build a 'XXExprGhcRn' out of an extension constructor. +-- The two components of the expansion are: original statement and +-- expanded typechecked expression. +mkExpandedStmtTc + :: ExprLStmt GhcRn -- ^ source do statement + -> HsExpr GhcTc -- ^ expanded typechecked expression + -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt) eExpr) + +{- ********************************************************************* +* * + Pretty-printing expressions +* * +********************************************************************* -} + +instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where + ppr expr = pprExpr expr + +----------------------- +-- pprExpr, pprLExpr, pprBinds call pprDeeper; +-- the underscore versions do not +pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc +pprLExpr (L _ e) = pprExpr e + +pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc +pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e + | otherwise = pprDeeper (ppr_expr e) + +isQuietHsExpr :: HsExpr id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsExpr (HsPar {}) = True +-- applications don't display anything themselves +isQuietHsExpr (HsApp {}) = True +isQuietHsExpr (HsAppType {}) = True +isQuietHsExpr (OpApp {}) = True +isQuietHsExpr _ = False + +pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) + => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprBinds b = pprDeeper (ppr b) + +----------------------- +ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc +ppr_lexpr e = ppr_expr (unLoc e) + +ppr_expr :: forall p. (OutputableBndrId p) + => HsExpr (GhcPass p) -> SDoc +ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v +ppr_expr (HsHole x) = case (ghcPass @p, x) of + (GhcPs, HoleVar (L _ v)) -> pprPrefixOcc v + (GhcRn, HoleVar (L _ v)) -> pprPrefixOcc v + (GhcTc, (HoleVar (L _ v), _)) -> pprPrefixOcc v + (GhcPs, HoleError) -> pprPrefixOcc unnamedHoleRdrName + (GhcRn, HoleError) -> pprPrefixOcc unnamedHoleRdrName + (GhcTc, (HoleError, _)) -> pprPrefixOcc unnamedHoleRdrName +ppr_expr (HsIPVar _ v) = ppr v +ppr_expr (HsOverLabel s l) = case ghcPass @p of + GhcPs -> helper s + GhcRn -> helper s + GhcTc -> dataConCantHappen s + where helper s = + char '#' <> case s of + NoSourceText -> ppr l + SourceText src -> ftext src +ppr_expr (HsLit _ lit) = ppr lit +ppr_expr (HsOverLit _ lit) = ppr lit +ppr_expr (HsPar _ e) = parens (ppr_lexpr e) + +ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] + +ppr_expr e@(HsApp {}) = ppr_apps e [] +ppr_expr e@(HsAppType {}) = ppr_apps e [] + +ppr_expr (OpApp _ e1 op e2) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + + where + pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens + pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear + + pp_prefixly + = hang (ppr op) 2 (sep [pp_e1, pp_e2]) + + pp_infixly pp_op + = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) + +ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e + +ppr_expr (SectionL _ expr op) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + where + pp_expr = pprDebugParendExpr opPrec expr + + pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) + 4 (hsep [pp_expr, text "x_ )"]) + + pp_infixly v = (sep [pp_expr, v]) + +ppr_expr (SectionR _ op expr) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + where + pp_expr = pprDebugParendExpr opPrec expr + + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) + 4 (pp_expr <> rparen) + + pp_infixly v = sep [v, pp_expr] + +ppr_expr (ExplicitTuple _ exprs boxity) + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `MkSolo x`, not `(x)` + | [Present _ expr] <- exprs + , Boxed <- boxity + = hsep [text (mkTupleStr Boxed dataName 1), ppr expr] + | otherwise + = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs)) + where + ppr_tup_args [] = [] + ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es + ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es + + punc (Present {} : _) = comma <> space + punc (Missing {} : _) = comma + punc (XTupArg {} : _) = comma <> space + punc [] = empty + +ppr_expr (ExplicitSum _ alt arity expr) + = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" + where + ppr_bars n = hsep (replicate n (char '|')) + +ppr_expr (HsLam _ lam_variant matches) + = case lam_variant of + LamSingle -> pprMatches matches + _ -> sep [ sep [lamCaseKeyword lam_variant] + , nest 2 (pprMatches matches) ] + +ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts })) + = sep [ sep [text "case", nest 4 (ppr expr), text "of"], + pp_alts ] + where + pp_alts | null alts = text "{}" + | otherwise = nest 2 (pprMatches matches) + +ppr_expr (HsIf _ e1 e2 e3) + = sep [hsep [text "if", nest 2 (ppr e1), text "then"], + nest 4 (ppr e2), + text "else", + nest 4 (ppr e3)] + +ppr_expr (HsMultiIf _ alts) + = hang (text "if") 3 (vcat $ toList $ NE.map ppr_alt alts) + where ppr_alt (L _ (GRHS _ guards expr)) = + hang vbar 2 (hang (interpp'SP guards) 2 (arrow <+> pprDeeper (ppr expr))) + ppr_alt (L _ (XGRHS x)) = ppr x + +-- special case: let ... in let ... +ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _))) + = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), + ppr_lexpr expr] + +ppr_expr (HsLet _ binds expr) + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr expr)] + +ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts + +ppr_expr (ExplicitList _ exprs) + = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) + +ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds }) + = hang pp_con 2 (ppr rbinds) + where + -- con :: ConLikeP (GhcPass p) + -- so we need case analysis to know to print it + pp_con = case ghcPass @p of + GhcPs -> ppr con + GhcRn -> ppr con + GhcTc -> ppr con + +ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds }) + = case flds of + RegularRecUpdFields { recUpdFields= rbinds } -> + hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) + OverloadedRecUpdFields { olRecUpdFields = pbinds } -> + hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds)))) + +ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field }) + = ppr fexp <> dot <> ppr field + +ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr $ toList flds)))) + +ppr_expr (ExprWithTySig _ expr sig) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) + 4 (ppr sig) + +ppr_expr (ArithSeq _ _ info) = brackets (ppr info) + +ppr_expr (HsTypedSplice ext e) = + case ghcPass @p of + GhcPs -> pprTypedSplice Nothing e + GhcRn -> + case ext of + HsTypedSpliceNested n -> pprTypedSplice (Just n) e + HsTypedSpliceTop {} -> pprTypedSplice Nothing e + GhcTc -> pprTypedSplice Nothing e +ppr_expr (HsUntypedSplice ext s) = + case ghcPass @p of + GhcPs -> pprUntypedSplice True Nothing s + GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s + GhcRn | HsUntypedSpliceTop _ e <- ext -> ppr e + GhcTc -> dataConCantHappen ext + +ppr_expr (HsTypedBracket b e) + = case ghcPass @p of + GhcPs -> thTyBrackets (ppr e) + GhcRn -> thTyBrackets (ppr e) + GhcTc | HsBracketTc _ _ty _wrap ps <- b -> + thTyBrackets (ppr e) `ppr_with_pending_tc_splices` ps +ppr_expr (HsUntypedBracket b q) + = case ghcPass @p of + GhcPs -> ppr q + GhcRn -> case b of + [] -> ppr q + ps -> ppr q $$ whenPprDebug (text "pending(rn)" <+> ppr (map ppr_nested_splice ps)) + GhcTc | HsBracketTc rnq _ty _wrap ps <- b -> + ppr rnq `ppr_with_pending_tc_splices` ps + where + ppr_nested_splice (PendingRnSplice splice_name expr) = pprUntypedSplice False (Just splice_name) expr + +ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) + = hsep [text "proc", ppr pat, arrow, ppr cmd] + +ppr_expr (HsStatic _ e) + = hsep [text "static", ppr e] + +ppr_expr (HsEmbTy _ ty) + = hsep [text "type", ppr ty] + +ppr_expr (HsQual _ ctxt ty) + = sep [ppr_context ctxt, ppr_lexpr ty] + where + ppr_context (L _ ctxt) = + case ctxt of + [] -> parens empty <+> darrow + [L _ ty] -> ppr_expr ty <+> darrow + _ -> parens (interpp'SP ctxt) <+> darrow + +ppr_expr (HsForAll _ tele ty) + = sep [pprHsForAll tele Nothing, ppr_lexpr ty] + +ppr_expr (HsFunArr _ arr arg res) + = sep [ppr_lexpr arg, pprHsArrow arr <+> ppr_lexpr res] + +ppr_expr (XExpr x) = case ghcPass @p of + GhcRn -> ppr x + GhcTc -> ppr x + +instance Outputable HsThingRn where + ppr thing + = case thing of + OrigExpr x -> ppr_builder ":" x + OrigStmt x -> ppr_builder ":" x + OrigPat x -> ppr_builder ":" x + + where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x) + +instance Outputable XXExprGhcRn where + ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o) + ppr (PopErrCtxt e) = ifPprDebug (braces (text "" <+> ppr e)) (ppr e) + ppr (HsRecSelRn f) = pprPrefixOcc f + +instance Outputable XXExprGhcTc where + ppr (WrapExpr co_fn e) + = pprHsWrapper co_fn (\_parens -> pprExpr e) + + ppr (ExpandedThingTc o e) + = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o) + -- e is the expanded expression, we print the original + -- expression (HsExpr GhcRn), not the + -- expanded typechecked one (HsExpr GhcTc), + -- unless we are in ppr's debug mode printed both + + ppr (ConLikeTc con _ _) = pprPrefixOcc con + -- Used in error messages generated by + -- the pattern match overlap checker + + ppr (HsTick tickish exp) = + pprTicks (ppr exp) $ + ppr tickish <+> ppr_lexpr exp + + ppr (HsBinTick tickIdTrue tickIdFalse exp) = + pprTicks (ppr exp) $ + hcat [text "bintick<", + ppr tickIdTrue, + text ",", + ppr tickIdFalse, + text ">(", + ppr exp, text ")"] + ppr (HsRecSelTc f) = pprPrefixOcc f + +ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc +ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) +ppr_infix_expr (HsHole x) = Just $ pprInfixOcc $ case (ghcPass @p, x) of + (GhcPs, HoleVar (L _ v)) -> v + (GhcRn, HoleVar (L _ v)) -> v + (GhcTc, (HoleVar (L _ v), _)) -> v + _ -> unnamedHoleRdrName -- TODO: this is the HoleError case; this should print the source text instead of "_". +ppr_infix_expr (XExpr x) = case ghcPass @p of + GhcRn -> ppr_infix_expr_rn x + GhcTc -> ppr_infix_expr_tc x +ppr_infix_expr _ = Nothing + +ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc +ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing +ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a +ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f) + +ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc +ppr_infix_expr_tc (WrapExpr _ e) = ppr_infix_expr e +ppr_infix_expr_tc (ExpandedThingTc thing _) = ppr_infix_hs_expansion thing +ppr_infix_expr_tc (ConLikeTc {}) = Nothing +ppr_infix_expr_tc (HsTick {}) = Nothing +ppr_infix_expr_tc (HsBinTick {}) = Nothing +ppr_infix_expr_tc (HsRecSelTc f) = Just (pprInfixOcc f) + +ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc +ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e +ppr_infix_hs_expansion _ = Nothing + +ppr_apps :: (OutputableBndrId p) + => HsExpr (GhcPass p) + -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] + -> SDoc +ppr_apps (HsApp _ (L _ fun) arg) args + = ppr_apps fun (Left arg : args) +ppr_apps (HsAppType _ (L _ fun) arg) args + = ppr_apps fun (Right arg : args) +ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) + where + pp (Left arg) = ppr arg + -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) + -- = char '@' <> pprHsType arg + pp (Right arg) + = text "@" <> ppr arg + +pprDebugParendExpr :: (OutputableBndrId p) + => PprPrec -> LHsExpr (GhcPass p) -> SDoc +pprDebugParendExpr p expr + = getPprDebug $ \case + True -> pprParendLExpr p expr + False -> pprLExpr expr + +pprParendLExpr :: (OutputableBndrId p) + => PprPrec -> LHsExpr (GhcPass p) -> SDoc +pprParendLExpr p (L _ e) = pprParendExpr p e + +pprParendExpr :: (OutputableBndrId p) + => PprPrec -> HsExpr (GhcPass p) -> SDoc +pprParendExpr p expr + | hsExprNeedsParens p expr = parens (pprExpr expr) + | otherwise = pprExpr expr + -- Using pprLExpr makes sure that we go 'deeper' + -- I think that is usually (always?) right + +-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs +-- parentheses under precedence @p@. +hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool +hsExprNeedsParens prec = go + where + go :: HsExpr (GhcPass p) -> Bool + go (HsVar{}) = False + go (HsIPVar{}) = False + go (HsOverLabel{}) = False + go (HsLit _ l) = hsLitNeedsParens prec l + go (HsOverLit _ ol) = hsOverLitNeedsParens prec ol + go (HsPar{}) = False + go (HsApp{}) = prec >= appPrec + go (HsAppType {}) = prec >= appPrec + go (OpApp{}) = prec >= opPrec + go (NegApp{}) = prec > topPrec + go (SectionL{}) = True + go (SectionR{}) = True + -- Special-case unary boxed tuple applications so that they are + -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612) + -- See Note [One-tuples] in GHC.Builtin.Types + go (ExplicitTuple _ [Present{}] Boxed) + = prec >= appPrec + go (ExplicitTuple{}) = False + go (ExplicitSum{}) = False + go (HsLam{}) = prec > topPrec + go (HsCase{}) = prec > topPrec + go (HsIf{}) = prec > topPrec + go (HsMultiIf{}) = prec > topPrec + go (HsLet{}) = prec > topPrec + go (HsDo _ sc _) + | isDoComprehensionContext sc = False + | otherwise = prec > topPrec + go (ExplicitList{}) = False + go (RecordUpd{}) = False + go (ExprWithTySig{}) = prec >= sigPrec + go (ArithSeq{}) = False + go (HsPragE{}) = prec >= appPrec + go (HsTypedSplice{}) = False + go (HsUntypedSplice{}) = False + go (HsTypedBracket{}) = False + go (HsUntypedBracket{}) = False + go (HsProc{}) = prec > topPrec + go (HsStatic{}) = prec >= appPrec + go (RecordCon{}) = False + go (HsProjection{}) = True + go (HsGetField{}) = False + go (HsEmbTy{}) = prec > topPrec + go (HsHole{}) = False + go (HsForAll{}) = prec >= funPrec + go (HsQual{}) = prec >= funPrec + go (HsFunArr{}) = prec >= funPrec + go (XExpr x) = case ghcPass @p of + GhcTc -> go_x_tc x + GhcRn -> go_x_rn x + + go_x_tc :: XXExprGhcTc -> Bool + go_x_tc (WrapExpr _ e) = hsExprNeedsParens prec e + go_x_tc (ExpandedThingTc thing _) = hsExpandedNeedsParens thing + go_x_tc (ConLikeTc {}) = False + go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e + go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e + go_x_tc (HsRecSelTc{}) = False + + go_x_rn :: XXExprGhcRn -> Bool + go_x_rn (ExpandedThingRn thing _) = hsExpandedNeedsParens thing + go_x_rn (PopErrCtxt (L _ a)) = hsExprNeedsParens prec a + go_x_rn (HsRecSelRn{}) = False + + hsExpandedNeedsParens :: HsThingRn -> Bool + hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e + hsExpandedNeedsParens _ = False + +-- | Parenthesize an expression without token information +gHsPar :: forall p. IsPass p => LHsExpr (GhcPass p) -> HsExpr (GhcPass p) +gHsPar e = HsPar x e + where + x = case ghcPass @p of + GhcPs -> noAnn + GhcRn -> noExtField + GhcTc -> noExtField + +-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, +-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. +parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +parenthesizeHsExpr p le@(L loc e) + | hsExprNeedsParens p e = L loc (gHsPar le) + | otherwise = le + +stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e +stripParensLHsExpr e = e + +stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p) +stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e +stripParensHsExpr e = e + +isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool +-- True of a single token +isAtomicHsExpr (HsVar {}) = True +isAtomicHsExpr (HsLit {}) = True +isAtomicHsExpr (HsOverLit {}) = True +isAtomicHsExpr (HsIPVar {}) = True +isAtomicHsExpr (HsOverLabel {}) = True +isAtomicHsExpr (HsHole{}) = True +isAtomicHsExpr (XExpr x) + | GhcTc <- ghcPass @p = go_x_tc x + | GhcRn <- ghcPass @p = go_x_rn x + where + go_x_tc :: XXExprGhcTc -> Bool + go_x_tc (WrapExpr _ e) = isAtomicHsExpr e + go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing + go_x_tc (ConLikeTc {}) = True + go_x_tc (HsTick {}) = False + go_x_tc (HsBinTick {}) = False + go_x_tc (HsRecSelTc{}) = True + + go_x_rn :: XXExprGhcRn -> Bool + go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing + go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a + go_x_rn (HsRecSelRn{}) = True + + isAtomicExpandedThingRn :: HsThingRn -> Bool + isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e + isAtomicExpandedThingRn _ = False + +isAtomicHsExpr _ = False + +instance Outputable (HsPragE (GhcPass p)) where + ppr (HsPragSCC (_, st) (StringLiteral stl lbl _)) = + pprWithSourceText st (text "{-# SCC") + -- no doublequotes if stl empty, for the case where the SCC was written + -- without quotes. + <+> pprWithSourceText stl (ftext lbl) <+> text "#-}" + + +{- ********************************************************************* +* * + XXExprGhcRn and rebindable syntax +* * +********************************************************************* -} + +{- Note [Rebindable syntax and XXExprGhcRn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We implement rebindable syntax (RS) support by performing a desugaring +in the renamer. We transform GhcPs expressions and patterns affected by +RS into the appropriate desugared form, but **annotated with the original +expression/pattern**. + +Let us consider a piece of code like: + + {-# LANGUAGE RebindableSyntax #-} + ifThenElse :: Char -> () -> () -> () + ifThenElse _ _ _ = () + x = if 'a' then () else True + +The parsed AST for the RHS of x would look something like (slightly simplified): + + L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True)) + +Upon seeing such an AST with RS on, we could transform it into a +mere function call, as per the RS rules, equivalent to the +following function application: + + ifThenElse 'a' () True + +which doesn't typecheck. But GHC would report an error about +not being able to match the third argument's type (Bool) with the +expected type: (), in the expression _as desugared_, i.e in +the aforementioned function application. But the user never +wrote a function application! This would be pretty bad. + +To remedy this, instead of transforming the original HsIf +node into mere applications of 'ifThenElse', we keep the +original 'if' expression around too, using the TTG +XExpr extension point to allow GHC to construct an +'XXExprGhcRn' value that will keep track of the original +expression in its first field, and the desugared one in the +second field. The resulting renamed AST would look like: + + L locif (XExpr + (ExpandedThingRn + (HsIf (L loca 'a') + (L loctrue ()) + (L locfalse True) + ) + (App (L generatedSrcSpan + (App (L generatedSrcSpan + (App (L generatedSrcSpan (Var ifThenElse)) + (L loca 'a') + ) + ) + (L loctrue ()) + ) + ) + (L locfalse True) + ) + ) + ) + +When comes the time to typecheck the program, we end up calling +tcMonoExpr on the AST above. If this expression gives rise to +a type error, then it will appear in a context line and GHC +will pretty-print it using the 'Outputable (XXExprGhcRn a b)' +instance defined below, which *only prints the original +expression*. This is the gist of the idea, but is not quite +enough to recover the error messages that we had with the +SyntaxExpr-based, typechecking/desugaring-to-core time +implementation of rebindable syntax. The key idea is to decorate +some elements of the desugared expression so as to be able to +give them a special treatment when typechecking the desugared +expression, to print a different context line or skip one +altogether. + +Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in +TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we +entered generated code, i.e code fabricated by the compiler when rebinding some +syntax. If someone tries to push some error context line while that field is set +to True, the pushing won't actually happen and the context line is just dropped. +Once we 'setSrcSpan' a real span (for an expression that was in the original +source code), we set 'tcl_in_gen_code' back to False, indicating that we +"emerged from the generated code tunnel", and that the expressions we will be +processing are relevant to report in context lines again. + +You might wonder why TcLclEnv has both + tcl_loc :: RealSrcSpan + tcl_in_gen_code :: Bool +Could we not store a Maybe RealSrcSpan? The problem is that we still +generate constraints when processing generated code, and a CtLoc must +contain a RealSrcSpan -- otherwise, error messages might appear +without source locations. So tcl_loc keeps the RealSrcSpan of the last +location spotted that wasn't generated; it's as good as we're going to +get in generated code. Once we get to sub-trees that are not +generated, then we update the RealSrcSpan appropriately, and set the +tcl_in_gen_code Bool to False. + +--- + +An overview of the constructs that are desugared in this way is laid out in +Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr. + +A general recipe to follow this approach for new constructs could go as follows: + +- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your + construct, in HsExpr or related syntax data types. +- At renaming-time: + - take your original node of interest (HsIf above) + - rename its subexpressions/subpatterns (condition and true/false + branches above) + - construct the suitable "rebound"-and-renamed result (ifThenElse call + above), where the 'SrcSpan' attached to any _fabricated node_ (the + HsVar/HsApp nodes, above) is set to 'generatedSrcSpan' + - take both the original node and that rebound-and-renamed result and wrap + them into an expansion construct: + for expressions, XExpr (ExpandedThingRn ) + for patterns, XPat (HsPatExpanded ) + - At typechecking-time: + - remove any logic that was previously dealing with your rebindable + construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends. + - the XExpr (ExpandedThingRn ... ...) case in tcExpr already makes sure that we + typecheck the desugared expression while reporting the original one in + errors +-} + +{- Note [Overview of record dot syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is the note that explains all the moving parts for record dot +syntax. + +The language extensions @OverloadedRecordDot@ and +@OverloadedRecordUpdate@ (providing "record dot syntax") are +implemented using the techniques of Note [Rebindable syntax and +XXExprGhcRn]. + +When OverloadedRecordDot is enabled: +- Field selection expressions + - e.g. foo.bar.baz + - Have abstract syntax HsGetField + - After renaming are XExpr (ExpandedThingRn (HsGetField ...) (getField @"..."...)) expressions +- Field selector expressions e.g. (.x.y) + - Have abstract syntax HsProjection + - After renaming are XExpr (ExpandedThingRn (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions + +When OverloadedRecordUpdate is enabled: +- Record update expressions + - e.g. a{foo.bar=1, quux="corge", baz} + - Have abstract syntax RecordUpd + - With rupd_flds containting a Right + - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr) + - After renaming are XExpr (ExpandedThingRn (RecordUpd ...) (setField@"..." ...) expressions + - Note that this is true for all record updates even for those that do not involve '.' + +When OverloadedRecordDot is enabled and RebindableSyntax is not +enabled the name 'getField' is resolved to GHC.Records.getField. When +OverloadedRecordDot is enabled and RebindableSyntax is enabled the +name 'getField' is whatever in-scope name that is. + +When OverloadedRecordUpd is enabled and RebindableSyntax is not +enabled it is an error for now (temporary while we wait on native +setField support; see +https://gitlab.haskell.org/ghc/ghc/-/issues/16232). When +OverloadedRecordUpd is enabled and RebindableSyntax is enabled the +names 'getField' and 'setField' are whatever in-scope names they are. +-} + + +{- +************************************************************************ +* * +\subsection{Commands (in arrow abstractions)} +* * +************************************************************************ +-} + +type instance XCmdArrApp GhcPs = (IsUnicodeSyntax, EpaLocation) +type instance XCmdArrApp GhcRn = NoExtField +type instance XCmdArrApp GhcTc = Type + +type instance XCmdArrForm GhcPs = AnnList () +-- | fixity (filled in by the renamer), for forms that were converted from +-- OpApp's by the renamer +type instance XCmdArrForm GhcRn = Maybe Fixity +type instance XCmdArrForm GhcTc = Maybe Fixity + +type instance XCmdApp (GhcPass _) = NoExtField +type instance XCmdLam (GhcPass _) = NoExtField + +type instance XCmdPar GhcPs = (EpToken "(", EpToken ")") +type instance XCmdPar GhcRn = NoExtField +type instance XCmdPar GhcTc = NoExtField + +type instance XCmdCase GhcPs = EpAnnHsCase +type instance XCmdCase GhcRn = NoExtField +type instance XCmdCase GhcTc = NoExtField + +type instance XCmdLamCase (GhcPass _) = EpAnnLam + +type instance XCmdIf GhcPs = AnnsIf +type instance XCmdIf GhcRn = NoExtField +type instance XCmdIf GhcTc = NoExtField + +type instance XCmdLet GhcPs = (EpToken "let", EpToken "in") +type instance XCmdLet GhcRn = NoExtField +type instance XCmdLet GhcTc = NoExtField + +type instance XCmdDo GhcPs = AnnList EpaLocation +type instance XCmdDo GhcRn = NoExtField +type instance XCmdDo GhcTc = Type + +type instance XCmdWrap (GhcPass _) = NoExtField + +type instance XXCmd GhcPs = DataConCantHappen +type instance XXCmd GhcRn = DataConCantHappen +type instance XXCmd GhcTc = HsWrap HsCmd + + -- If cmd :: arg1 --> res + -- wrap :: arg1 "->" arg2 + -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res + +-- | Command Syntax Table (for Arrow syntax) +type CmdSyntaxTable p = [(Name, HsExpr p)] +-- See Note [CmdSyntaxTable] + +{- +Note [CmdSyntaxTable] +~~~~~~~~~~~~~~~~~~~~~ +Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps +track of the methods needed for a Cmd. + +* Before the renamer, this list is an empty list + +* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ + For example, for the 'arr' method + * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) + * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) + where @arr_22@ is whatever 'arr' is in scope + +* After the type checker, it takes the form [(std_name, )] + where is the evidence for the method. This evidence is + instantiated with the class, but is still polymorphic in everything + else. For example, in the case of 'arr', the evidence has type + forall b c. (b->c) -> a b c + where 'a' is the ambient type of the arrow. This polymorphism is + important because the desugarer uses the same evidence at multiple + different types. + +This is Less Cool than what we normally do for rebindable syntax, which is to +make fully-instantiated piece of evidence at every use site. The Cmd way +is Less Cool because + * The renamer has to predict which methods are needed. + See the tedious GHC.Rename.Expr.methodNamesCmd. + + * The desugarer has to know the polymorphic type of the instantiated + method. This is checked by Inst.tcSyntaxName, but is less flexible + than the rest of rebindable syntax, where the type is less + pre-ordained. (And this flexibility is useful; for example we can + typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) +-} + +data CmdTopTc + = CmdTopTc Type -- Nested tuple of inputs on the command's stack + Type -- return type of the command + (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] + +type instance XCmdTop GhcPs = NoExtField +type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] +type instance XCmdTop GhcTc = CmdTopTc + + +type instance XXCmdTop (GhcPass _) = DataConCantHappen + +instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where + ppr cmd = pprCmd cmd + +----------------------- +-- pprCmd and pprLCmd call pprDeeper; +-- the underscore versions do not +pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc +pprLCmd (L _ c) = pprCmd c + +pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc +pprCmd c | isQuietHsCmd c = ppr_cmd c + | otherwise = pprDeeper (ppr_cmd c) + +isQuietHsCmd :: HsCmd id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsCmd (HsCmdPar {}) = True +-- applications don't display anything themselves +isQuietHsCmd (HsCmdApp {}) = True +isQuietHsCmd _ = False + +----------------------- +ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc +ppr_lcmd c = ppr_cmd (unLoc c) + +ppr_cmd :: forall p. (OutputableBndrId p + ) => HsCmd (GhcPass p) -> SDoc +ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) + +ppr_cmd (HsCmdApp _ c e) + = let (fun, args) = collect_args c [e] in + hang (ppr_lcmd fun) 2 (sep (map ppr args)) + where + collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +ppr_cmd (HsCmdLam _ LamSingle matches) + = pprMatches matches +ppr_cmd (HsCmdLam _ lam_variant matches) + = sep [ lamCaseKeyword lam_variant, nest 2 (pprMatches matches) ] + +ppr_cmd (HsCmdCase _ expr matches) + = sep [ sep [text "case", nest 4 (ppr expr), text "of"], + nest 2 (pprMatches matches) ] + +ppr_cmd (HsCmdIf _ _ e ct ce) + = sep [hsep [text "if", nest 2 (ppr e), text "then"], + nest 4 (ppr ct), + text "else", + nest 4 (ppr ce)] + +-- special case: let ... in let ... +ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {}))) + = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), + ppr_lcmd cmd] + +ppr_cmd (HsCmdLet _ binds cmd) + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr cmd)] + +ppr_cmd (HsCmdDo _ (L _ stmts)) = pprArrowExpr stmts + +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) + = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) + = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] + +ppr_cmd (HsCmdArrForm rn_fix (L _ op) ps_fix args) + | HsVar _ (L _ v) <- op + = ppr_cmd_infix v + | GhcTc <- ghcPass @p + , XExpr (ConLikeTc c _ _) <- op + = ppr_cmd_infix (conLikeName c) + | otherwise + = fall_through + where + fall_through = hang (text "(|" <+> ppr_expr op) + 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") + + ppr_cmd_infix :: OutputableBndr v => v -> SDoc + ppr_cmd_infix v + | [arg1, arg2] <- args + , case ghcPass @p of + GhcPs -> ps_fix == Infix + GhcRn -> isJust rn_fix || ps_fix == Infix + GhcTc -> isJust rn_fix || ps_fix == Infix + = hang (pprCmdArg (unLoc arg1)) + 4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)]) + | otherwise + = fall_through + +ppr_cmd (XCmd x) = case ghcPass @p of + GhcTc -> case x of + HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) + +pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc +pprCmdArg (HsCmdTop _ cmd) + = ppr_lcmd cmd + +instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where + ppr = pprCmdArg + +{- +************************************************************************ +* * +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} +* * +************************************************************************ +-} + +type instance XMG GhcPs b = Origin +type instance XMG GhcRn b = Origin -- See Note [Generated code and pattern-match checking] +type instance XMG GhcTc b = MatchGroupTc + +data MatchGroupTc + = MatchGroupTc + { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn + , mg_res_ty :: Type -- Type of the result, tr + , mg_origin :: Origin -- Origin (Generated vs FromSource) + } deriving Data + +type instance XXMatchGroup (GhcPass _) b = DataConCantHappen + +type instance XCMatch (GhcPass _) b = NoExtField +type instance XXMatch (GhcPass _) b = DataConCantHappen + +instance (OutputableBndrId pr, Outputable body) + => Outputable (Match (GhcPass pr) body) where + ppr = pprMatch + +isEmptyMatchGroup :: MatchGroup (GhcPass p) body -> Bool +isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms + +-- | Is there only one RHS in this list of matches? +isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool +isSingletonMatchGroup matches + | [L _ match] <- matches + , Match { m_grhss = GRHSs { grhssGRHSs = _ :| [] } } <- match + = True + | otherwise + = False + +matchGroupArity :: MatchGroup (GhcPass id) body -> Arity +-- This is called before type checking, when mg_arg_tys is not set +matchGroupArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts] +matchGroupArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1) + +hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] +hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats + +isInfixMatch :: Match (GhcPass p) body -> Bool +isInfixMatch match = case m_ctxt match of + FunRhs {mc_fixity = Infix} -> True + _ -> False + +-- We keep the type checker happy by providing EpAnnComments. They +-- can only be used if they follow a `where` keyword with no binds, +-- but in that case the comment is attached to the following parsed +-- item. So this can never be used in practice. +type instance XCGRHSs (GhcPass _) _ = EpAnnComments + +type instance XXGRHSs (GhcPass _) _ = DataConCantHappen + +data GrhsAnn + = GrhsAnn { + ga_vbar :: Maybe (EpToken "|"), + ga_sep :: Either (EpToken "=") TokRarrow -- ^ Match separator location, `=` or `->` + } deriving (Data) + +instance NoAnn GrhsAnn where + noAnn = GrhsAnn Nothing noAnn + +type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn + -- Location of matchSeparator + -- TODO:AZ does this belong on the GRHS, or GRHSs? + +type instance XXGRHS (GhcPass _) b = DataConCantHappen + +pprMatches :: (OutputableBndrId idR, Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc +pprMatches MG { mg_alts = matches } + = vcat (map pprMatch (map unLoc (unLoc matches))) + -- Don't print the type; it's only a place-holder before typechecking + +-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext +pprFunBind :: (OutputableBndrId idR) + => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc +pprFunBind matches = pprMatches matches + +-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext +pprPatBind :: forall bndr p . (OutputableBndrId bndr, + OutputableBndrId p) + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc +pprPatBind pat grhss + = sep [ppr pat, + nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext Void) grhss)] + +pprMatch :: (OutputableBndrId idR, Outputable body) + => Match (GhcPass idR) body -> SDoc +pprMatch (Match { m_pats = L _ pats, m_ctxt = ctxt, m_grhss = grhss }) + = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats) + , nest 2 (pprGRHSs ctxt grhss) ] + where + -- lam_cases_result: we don't simply return (empty, pats) to avoid + -- introducing an additional `nest 2` via the empty herald + lam_cases_result = case pats of + [] -> (empty, []) + (p:ps) -> (pprParendLPat appPrec p, ps) + + (herald, other_pats) + = case ctxt of + FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} + | SrcStrict <- strictness + -> assert (null pats) -- A strict variable binding + (char '!'<>pprPrefixOcc fun, pats) + + | Prefix <- fixity + -> (pprPrefixOcc fun, pats) -- f x y z = e + -- Not pprBndr; the AbsBinds will + -- have printed the signature + | otherwise + -> case pats of + (p1:p2:rest) + | null rest -> (pp_infix, []) -- x &&& y = e + | otherwise -> (parens pp_infix, rest) -- (x &&& y) z = e + where + pp_infix = pprParendLPat opPrec p1 + <+> pprInfixOcc fun + <+> pprParendLPat opPrec p2 + _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) + + LamAlt LamSingle -> (char '\\', pats) + ArrowMatchCtxt (ArrowLamAlt LamSingle) -> (char '\\', pats) + LamAlt LamCases -> lam_cases_result + ArrowMatchCtxt (ArrowLamAlt LamCases) -> lam_cases_result + + ArrowMatchCtxt ProcExpr -> (text "proc", pats) + + _ -> case pats of + [] -> (empty, []) + [pat] -> (ppr pat, []) -- No parens around the single pat in a case + _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) + +pprGRHSs :: (OutputableBndrId idR, Outputable body) + => HsMatchContext fn -> GRHSs (GhcPass idR) body -> SDoc +pprGRHSs ctxt (GRHSs _ grhss binds) + = vcat (toList $ NE.map (pprGRHS ctxt . unLoc) grhss) + -- Print the "where" even if the contents of the binds is empty. Only + -- EmptyLocalBinds means no "where" keyword + $$ ppUnless (eqEmptyLocalBinds binds) + (text "where" $$ nest 4 (pprBinds binds)) + +pprGRHS :: (OutputableBndrId idR, Outputable body) + => HsMatchContext fn -> GRHS (GhcPass idR) body -> SDoc +pprGRHS ctxt (GRHS _ [] body) + = pp_rhs ctxt body + +pprGRHS ctxt (GRHS _ guards body) + = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] + +pp_rhs :: Outputable body => HsMatchContext fn -> body -> SDoc +pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) + +matchSeparator :: HsMatchContext fn -> SDoc +matchSeparator FunRhs{} = text "=" +matchSeparator CaseAlt = arrow +matchSeparator LamAlt{} = arrow +matchSeparator IfAlt = arrow +matchSeparator ArrowMatchCtxt{} = arrow +matchSeparator PatBindRhs = text "=" +matchSeparator PatBindGuards = text "=" +matchSeparator StmtCtxt{} = text "<-" +matchSeparator RecUpd = text "=" -- This can be printed by the pattern +matchSeparator PatSyn = text "<-" -- match checker trace +matchSeparator LazyPatCtx = panic "unused" +matchSeparator ThPatSplice = panic "unused" +matchSeparator ThPatQuote = panic "unused" + +instance Outputable GrhsAnn where + ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s + +{- +************************************************************************ +* * +\subsection{Do stmts and list comprehensions} +* * +************************************************************************ +-} + +-- Extra fields available post typechecking for RecStmt. +data RecStmtTc = + RecStmtTc + { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T + , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) + , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 + -- with recS_later_ids and recS_rec_ids, + -- and are the expressions that should be + -- returned by the recursion. + -- They may not quite be the Ids themselves, + -- because the Id may be *polymorphic*, but + -- the returned thing has to be *monomorphic*, + -- so they may be type applications + + , recS_ret_ty :: Type -- The type of + -- do { stmts; return (a,b,c) } + -- With rebindable syntax the type might not + -- be quite as simple as (m (tya, tyb, tyc)). + } + + +type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField + +type instance XBindStmt (GhcPass _) GhcPs b = EpUniToken "<-" "←" +type instance XBindStmt (GhcPass _) GhcRn b = XBindStmtRn +type instance XBindStmt (GhcPass _) GhcTc b = XBindStmtTc + +data XBindStmtRn = XBindStmtRn + { xbsrn_bindOp :: SyntaxExpr GhcRn + , xbsrn_failOp :: FailOperator GhcRn + } + +data XBindStmtTc = XBindStmtTc + { xbstc_bindOp :: SyntaxExpr GhcTc + , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S + , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S + , xbstc_failOp :: FailOperator GhcTc + } + +type instance XApplicativeStmt (GhcPass _) GhcPs = NoExtField +type instance XApplicativeStmt (GhcPass _) GhcRn = NoExtField +type instance XApplicativeStmt (GhcPass _) GhcTc = Type + +type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField +type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField +type instance XBodyStmt (GhcPass _) GhcTc b = Type + +type instance XLetStmt (GhcPass _) (GhcPass _) b = EpToken "let" + +type instance XParStmt (GhcPass _) GhcPs b = NoExtField +type instance XParStmt (GhcPass _) GhcRn b = NoExtField +type instance XParStmt (GhcPass _) GhcTc b = Type + +type instance XTransStmt (GhcPass _) GhcPs b = AnnTransStmt +type instance XTransStmt (GhcPass _) GhcRn b = NoExtField +type instance XTransStmt (GhcPass _) GhcTc b = Type + +type instance XRecStmt (GhcPass _) GhcPs b = AnnList (EpToken "rec") +type instance XRecStmt (GhcPass _) GhcRn b = NoExtField +type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc + +type instance XXStmtLR (GhcPass _) GhcPs b = DataConCantHappen +type instance XXStmtLR (GhcPass x) GhcRn b = ApplicativeStmt (GhcPass x) GhcRn +type instance XXStmtLR (GhcPass x) GhcTc b = ApplicativeStmt (GhcPass x) GhcTc + +data AnnTransStmt + = AnnTransStmt { + ats_then :: EpToken "then", + ats_group :: Maybe (EpToken "group"), + ats_by :: Maybe (EpToken "by"), + ats_using :: Maybe (EpToken "using") + } deriving Data + +instance NoAnn AnnTransStmt where + noAnn = AnnTransStmt noAnn noAnn noAnn noAnn + + +-- | 'ApplicativeStmt' represents an applicative expression built with +-- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the +-- appropriate applicative expression by the desugarer, but it is intended +-- to be invisible in error messages. +-- +-- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr" +-- +data ApplicativeStmt idL idR + = ApplicativeStmt + (XApplicativeStmt idL idR) -- Post typecheck, Type of the body + [ ( SyntaxExpr idR + , ApplicativeArg idL) ] + -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] + (Maybe (SyntaxExpr idR)) -- 'join', if necessary + +-- | Applicative Argument +data ApplicativeArg idL + = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) + { xarg_app_arg_one :: XApplicativeArgOne idL + -- ^ The fail operator, after renaming + -- + -- The fail operator is needed if this is a BindStmt + -- where the pattern can fail. E.g.: + -- (Just a) <- stmt + -- The fail operator will be invoked if the pattern + -- match fails. + -- It is also used for guards in MonadComprehensions. + -- The fail operator is Nothing + -- if the pattern match can't fail + , app_arg_pattern :: LPat idL -- WildPat if it was a BodyStmt (see below) + , arg_expr :: LHsExpr idL + , is_body_stmt :: Bool + -- ^ True <=> was a BodyStmt, + -- False <=> was a BindStmt. + -- See Note [Applicative BodyStmt] + } + | ApplicativeArgMany -- do { stmts; return vars } + { xarg_app_arg_many :: XApplicativeArgMany idL + , app_stmts :: [ExprLStmt idL] -- stmts + , final_expr :: HsExpr idL -- return (v1,..,vn), or just (v1,..,vn) + , bv_pattern :: LPat idL -- (v1,...,vn) + , stmt_context :: HsDoFlavour + -- ^ context of the do expression, used in pprArg + } + | XApplicativeArg !(XXApplicativeArg idL) + +type family XApplicativeStmt x x' + +-- ApplicativeArg type families +type family XApplicativeArgOne x +type family XApplicativeArgMany x +type family XXApplicativeArg x + +type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = DataConCantHappen + +type instance XApplicativeArgOne GhcPs = NoExtField +type instance XApplicativeArgOne GhcRn = FailOperator GhcRn +type instance XApplicativeArgOne GhcTc = FailOperator GhcTc + +type instance XApplicativeArgMany (GhcPass _) = NoExtField +type instance XXApplicativeArg (GhcPass _) = DataConCantHappen + +instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))), + Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR))) + => Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where + ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts + +instance (OutputableBndrId pl, OutputableBndrId pr, + Anno (StmtLR (GhcPass pl) (GhcPass pr) body) ~ SrcSpanAnnA, + Outputable body) + => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where + ppr stmt = pprStmt stmt + +pprStmt :: forall idL idR body . (OutputableBndrId idL, + OutputableBndrId idR, + Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA, + Outputable body) + => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc +pprStmt (LastStmt _ expr m_dollar_stripped _) + = whenPprDebug (text "[last]") <+> + (case m_dollar_stripped of + Just True -> text "return $" + Just False -> text "return" + Nothing -> empty) <+> + ppr expr +pprStmt (BindStmt _ pat expr) = pprBindStmt pat expr +pprStmt (LetStmt _ binds) = hsep [text "let", pprBinds binds] +pprStmt (BodyStmt _ expr _ _) = ppr expr +pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr $ toList stmtss)) + +pprStmt (TransStmt { trS_stmts = stmts, trS_by = by + , trS_using = using, trS_form = form }) + = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) + +pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids + , recS_later_ids = later_ids }) + = text "rec" <+> + vcat [ ppr_do_stmts (unLoc segment) + , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids + , text "later_ids=" <> ppr later_ids])] + +pprStmt (XStmtLR x) = case ghcPass :: GhcPass idR of + GhcRn -> pprApplicativeStmt x + GhcTc -> pprApplicativeStmt x + + where + pprApplicativeStmt :: (OutputableBndrId idL, OutputableBndrId idR) => ApplicativeStmt (GhcPass idL) (GhcPass idR) -> SDoc + pprApplicativeStmt (ApplicativeStmt _ args mb_join) = + getPprStyle $ \style -> + if userStyle style + then pp_for_user + else pp_debug + where + -- make all the Applicative stuff invisible in error messages by + -- flattening the whole ApplicativeStmt nest back to a sequence + -- of statements. + pp_for_user = vcat $ concatMap flattenArg args + + -- ppr directly rather than transforming here, because we need to + -- inject a "return" which is hard when we're polymorphic in the id + -- type. + flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc] + flattenStmt (L _ (XStmtLR x)) = case ghcPass :: GhcPass idL of + GhcRn | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args + GhcTc | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args + flattenStmt stmt = [ppr stmt] + + flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc] + flattenArg (_, ApplicativeArgOne _ pat expr isBody) + | isBody = [ppr expr] -- See Note [Applicative BodyStmt] + | otherwise = [pprBindStmt pat expr] + flattenArg (_, ApplicativeArgMany _ stmts _ _ _) = + concatMap flattenStmt stmts + + pp_debug = + let + ap_expr = sep (punctuate (text " |") (map pp_arg args)) + in + whenPprDebug (if isJust mb_join then text "[join]" else empty) <+> + (if lengthAtLeast args 2 then parens else id) ap_expr + + pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc + pp_arg (_, applicativeArg) = ppr applicativeArg + +pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc +pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr] + +instance (OutputableBndrId idL) + => Outputable (ApplicativeArg (GhcPass idL)) where + ppr = pprArg + +pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc +pprArg (ApplicativeArgOne _ pat expr isBody) + | isBody = ppr expr -- See Note [Applicative BodyStmt] + | otherwise = pprBindStmt pat expr +pprArg (ApplicativeArgMany _ stmts return pat ctxt) = + ppr pat <+> + text "<-" <+> + pprDo ctxt (stmts ++ + [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)]) + +pprTransformStmt :: (OutputableBndrId p) + => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) + -> Maybe (LHsExpr (GhcPass p)) -> SDoc +pprTransformStmt bndrs using by + = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) + , nest 2 (ppr using) + , nest 2 (pprBy by)] + +pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc +pprTransStmt by using ThenForm + = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] +pprTransStmt by using GroupForm + = sep [ text "then group", nest 2 (pprBy by), nest 2 (text "using" <+> ppr using)] + +pprBy :: Outputable body => Maybe body -> SDoc +pprBy Nothing = empty +pprBy (Just e) = text "by" <+> ppr e + +pprDo :: (OutputableBndrId p, Outputable body, + Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA + ) + => HsDoFlavour -> [LStmt (GhcPass p) body] -> SDoc +pprDo (DoExpr m) stmts = + ppr_module_name_prefix m <> text "do" <+> ppr_do_stmts stmts +pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts +pprDo (MDoExpr m) stmts = + ppr_module_name_prefix m <> text "mdo" <+> ppr_do_stmts stmts +pprDo ListComp stmts = brackets $ pprComp stmts +pprDo MonadComp stmts = brackets $ pprComp stmts + +pprArrowExpr :: (OutputableBndrId p, Outputable body, + Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA + ) + => [LStmt (GhcPass p) body] -> SDoc +pprArrowExpr stmts = text "do" <+> ppr_do_stmts stmts + +ppr_module_name_prefix :: Maybe ModuleName -> SDoc +ppr_module_name_prefix = \case + Nothing -> empty + Just module_name -> ppr module_name <> char '.' + +ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, + Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA, + Outputable body) + => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc +-- Print a bunch of do stmts +ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) + +pprComp :: (OutputableBndrId p, Outputable body, + Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA) + => [LStmt (GhcPass p) body] -> SDoc +pprComp quals -- Prints: body | qual1, ..., qualn + | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals + = if null initStmts + -- If there are no statements in a list comprehension besides the last + -- one, we simply treat it like a normal list. This does arise + -- occasionally in code that GHC generates, e.g., in implementations of + -- 'range' for derived 'Ix' instances for product datatypes with exactly + -- one constructor (e.g., see #12583). + then ppr body + else hang (ppr body <+> vbar) 2 (pprQuals initStmts) + | otherwise + = pprPanic "pprComp" (pprQuals quals) + +pprQuals :: (OutputableBndrId p, Outputable body, + Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA) + => [LStmt (GhcPass p) body] -> SDoc +-- Show list comprehension qualifiers separated by commas +pprQuals quals = interpp'SP quals + +{- +************************************************************************ +* * + Template Haskell quotation brackets +* * +************************************************************************ +-} + +-- | Finalizers produced by a splice with +-- 'Language.Haskell.TH.Syntax.addModFinalizer' +-- +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how +-- this is used. +-- +newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] + +-- A Data instance which ignores the argument of 'ThModFinalizers'. +instance Data ThModFinalizers where + gunfold _ z _ = z $ ThModFinalizers [] + toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] + +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. +-- This is the result of splicing a splice. It is produced by +-- the renamer and consumed by the typechecker. It lives only between the two. +data HsUntypedSpliceResult thing -- 'thing' can be HsExpr or HsType + = HsUntypedSpliceTop + { utsplice_result_finalizers :: ThModFinalizers -- ^ TH finalizers produced by the splice. + , utsplice_result :: thing -- ^ The result of splicing; See Note [Lifecycle of a splice] + } + | HsUntypedSpliceNested SplicePointName -- A unique name to identify this splice point + +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +-- for an explanation of the Template Haskell extension points. +data HsTypedSpliceResult + = HsTypedSpliceTop + | HsTypedSpliceNested SplicePointName + +type instance XTypedSplice GhcPs = NoExtField +type instance XTypedSplice GhcRn = HsTypedSpliceResult +type instance XTypedSplice GhcTc = DelayedSplice + +type instance XUntypedSplice GhcPs = NoExtField +type instance XUntypedSplice GhcRn = HsUntypedSpliceResult (HsExpr GhcRn) +type instance XUntypedSplice GhcTc = DataConCantHappen + +-- HsUntypedSplice +type instance XUntypedSpliceExpr GhcPs = EpToken "$" +type instance XUntypedSpliceExpr GhcRn = HsUserSpliceExt +type instance XUntypedSpliceExpr GhcTc = DataConCantHappen + +type instance XTypedSpliceExpr GhcPs = EpToken "$$" +type instance XTypedSpliceExpr GhcRn = NoExtField +type instance XTypedSpliceExpr GhcTc = NoExtField + +type instance XQuasiQuote GhcPs = NoExtField +type instance XQuasiQuote GhcRn = HsQuasiQuoteExt +type instance XQuasiQuote GhcTc = DataConCantHappen + + +type instance XXUntypedSplice GhcPs = DataConCantHappen +type instance XXUntypedSplice GhcRn = HsImplicitLiftSplice +type instance XXUntypedSplice GhcTc = DataConCantHappen + +type instance XXTypedSplice GhcPs = DataConCantHappen +type instance XXTypedSplice GhcRn = HsImplicitLiftSplice +type instance XXTypedSplice GhcTc = DataConCantHappen + +-- See Note [Running typed splices in the zonker] +-- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice` +data DelayedSplice = + DelayedSplice + TcLclEnv -- The local environment to run the splice in + (LHsExpr GhcRn) -- The original renamed expression + TcType -- The result type of running the splice, unzonked + (LHsExpr GhcTc) -- The typechecked expression to run and splice in the result + +-- A Data instance which ignores the argument of 'DelayedSplice'. +instance Data DelayedSplice where + gunfold _ _ _ = panic "DelayedSplice" + toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a] + +-- See Note [Pending Splices] +type SplicePointName = Name + +data UntypedSpliceFlavour + = UntypedExpSplice + | UntypedPatSplice + | UntypedTypeSplice + | UntypedDeclSplice + deriving Data + + +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +-- A 'PendingRnSplice' is lifted from an untyped quotation and then typechecked. +data PendingRnSplice = PendingRnSplice SplicePointName (HsUntypedSplice GhcRn) + +instance Outputable PendingRnSplice where + ppr (PendingRnSplice sp expr) = + angleBrackets (ppr sp <> comma <+> pprUntypedSplice False Nothing expr) + +-- | Pending Type-checker Splice +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +data PendingTcSplice + = PendingTcSplice SplicePointName (LHsExpr GhcTc) + +-- | Information about an implicit lift, discovered by the renamer +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +data HsImplicitLiftSplice = + HsImplicitLiftSplice + { implicit_lift_bind_lvl :: S.Set ThLevelIndex + , implicit_lift_used_lvl :: ThLevelIndex + , implicit_lift_gre :: Maybe GlobalRdrElt + , implicit_lift_lid :: LIdOccP GhcRn + } + +-- | Information about a user-written splice, discovered by the renamer +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +data HsUserSpliceExt = + HsUserSpliceExt + { user_splice_flavour :: UntypedSpliceFlavour + } + +-- | Information about a quasi-quoter, discovered by the renamer +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +data HsQuasiQuoteExt = + HsQuasiQuoteExt + { quasi_quote_flavour :: UntypedSpliceFlavour + } + + +pprTypedSplice :: forall p . (OutputableBndrId p) => Maybe SplicePointName -> HsTypedSplice (GhcPass p) -> SDoc +pprTypedSplice n (HsTypedSpliceExpr _ e) = ppr_splice (text "$$") n e +pprTypedSplice n (XTypedSplice p) = + case ghcPass @p of + GhcRn -> case p of + HsImplicitLiftSplice _ _ _ lid -> ppr lid <+> whenPprDebug (maybe empty (brackets . ppr) n) + +pprUntypedSplice :: forall p. (OutputableBndrId p) + => Bool -- Whether to precede the splice with "$" + -> Maybe SplicePointName -- Used for pretty printing when exists + -> HsUntypedSplice (GhcPass p) + -> SDoc +pprUntypedSplice True n (HsUntypedSpliceExpr _ e) = ppr_splice (text "$") n e +pprUntypedSplice False n (HsUntypedSpliceExpr _ e) = ppr_splice empty n e +pprUntypedSplice _ _ (HsQuasiQuote _ q s) = ppr_quasi (unLoc q) (unLoc s) +pprUntypedSplice _ _ (XUntypedSplice x) = + case ghcPass @p of + GhcRn -> case x of + HsImplicitLiftSplice _ _ _ lid -> ppr lid + +ppr_quasi :: OutputableBndr p => p -> FastString -> SDoc +ppr_quasi quoter quote = char '[' <> ppr quoter <> vbar <> + ppr quote <> text "|]" + +ppr_splice :: (OutputableBndrId p) + => SDoc + -> Maybe SplicePointName + -> LHsExpr (GhcPass p) + -> SDoc +ppr_splice herald mn e + = herald + <> (case mn of + Nothing -> empty + Just splice_name -> whenPprDebug (brackets (ppr splice_name))) + <> ppr e + + +type instance XExpBr GhcPs = (BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|"), EpUniToken "|]" "⟧") +type instance XPatBr GhcPs = (EpToken "[p|", EpUniToken "|]" "⟧") +type instance XDecBrL GhcPs = (EpToken "[d|", EpUniToken "|]" "⟧", (EpToken "{", EpToken "}")) +type instance XDecBrG GhcPs = NoExtField +type instance XTypBr GhcPs = (EpToken "[t|", EpUniToken "|]" "⟧") +type instance XVarBr GhcPs = EpaLocation +type instance XXQuote GhcPs = DataConCantHappen + +type instance XExpBr GhcRn = NoExtField +type instance XPatBr GhcRn = NoExtField +type instance XDecBrL GhcRn = NoExtField +type instance XDecBrG GhcRn = NoExtField +type instance XTypBr GhcRn = NoExtField +type instance XVarBr GhcRn = NoExtField +type instance XXQuote GhcRn = DataConCantHappen + +-- See Note [The life cycle of a TH quotation] +type instance XExpBr GhcTc = DataConCantHappen +type instance XPatBr GhcTc = DataConCantHappen +type instance XDecBrL GhcTc = DataConCantHappen +type instance XDecBrG GhcTc = DataConCantHappen +type instance XTypBr GhcTc = DataConCantHappen +type instance XVarBr GhcTc = DataConCantHappen +type instance XXQuote GhcTc = NoExtField + +instance OutputableBndrId p + => Outputable (HsQuote (GhcPass p)) where + ppr = pprHsQuote + where + pprHsQuote :: forall p. (OutputableBndrId p) + => HsQuote (GhcPass p) -> SDoc + pprHsQuote (ExpBr _ e) = thBrackets empty (ppr e) + pprHsQuote (PatBr _ p) = thBrackets (char 'p') (ppr p) + pprHsQuote (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) + pprHsQuote (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) + pprHsQuote (TypBr _ t) = thBrackets (char 't') (ppr t) + pprHsQuote (VarBr _ True n) + = char '\'' <> pprPrefixOcc (unLoc n) + pprHsQuote (VarBr _ False n) + = text "''" <> pprPrefixOcc (unLoc n) + pprHsQuote (XQuote b) = case ghcPass @p of + GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b) + -- See Note [The life cycle of a TH quotation] + +thBrackets :: SDoc -> SDoc -> SDoc +thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> + pp_body <+> text "|]" + +thTyBrackets :: SDoc -> SDoc +thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]" + +instance Outputable PendingTcSplice where + ppr (PendingTcSplice n e) = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e)) + +ppr_with_pending_tc_splices :: SDoc -> [PendingTcSplice] -> SDoc +ppr_with_pending_tc_splices x [] = x +ppr_with_pending_tc_splices x ps = x $$ whenPprDebug (text "pending(tc)" <+> ppr ps) + +{- +************************************************************************ +* * +\subsection{Enumerations and list comprehensions} +* * +************************************************************************ +-} + +instance OutputableBndrId p + => Outputable (ArithSeqInfo (GhcPass p)) where + ppr (From e1) = hcat [ppr e1, pp_dotdot] + ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] + ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] + ppr (FromThenTo e1 e2 e3) + = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] + +pp_dotdot :: SDoc +pp_dotdot = text " .. " + +{- +************************************************************************ +* * +\subsection{HsMatchCtxt} +* * +************************************************************************ +-} + +type HsMatchContextPs = HsMatchContext (LIdP GhcPs) +type HsMatchContextRn = HsMatchContext (LIdP GhcRn) + +type HsStmtContextRn = HsStmtContext (LIdP GhcRn) + +instance Outputable fn => Outputable (HsMatchContext fn) where + ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) + ppr CaseAlt = text "CaseAlt" + ppr (LamAlt lam_variant) = text "LamAlt" <+> ppr lam_variant + ppr IfAlt = text "IfAlt" + ppr (ArrowMatchCtxt c) = text "ArrowMatchCtxt" <+> ppr c + ppr PatBindRhs = text "PatBindRhs" + ppr PatBindGuards = text "PatBindGuards" + ppr RecUpd = text "RecUpd" + ppr (StmtCtxt _) = text "StmtCtxt _" + ppr ThPatSplice = text "ThPatSplice" + ppr ThPatQuote = text "ThPatQuote" + ppr PatSyn = text "PatSyn" + ppr LazyPatCtx = text "LazyPatCtx" + +instance Outputable HsLamVariant where + ppr = text . \case + LamSingle -> "LamSingle" + LamCase -> "LamCase" + LamCases -> "LamCases" + +lamCaseKeyword :: HsLamVariant -> SDoc +lamCaseKeyword LamSingle = text "lambda" +lamCaseKeyword LamCase = text "\\case" +lamCaseKeyword LamCases = text "\\cases" + +pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc +pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4)) + = ppr (src,(n1,n2),(n3,n4)) + +instance Outputable HsArrowMatchContext where + ppr ProcExpr = text "ProcExpr" + ppr ArrowCaseAlt = text "ArrowCaseAlt" + ppr (ArrowLamAlt lam_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lam_variant + +pprHsArrType :: HsArrAppType -> SDoc +pprHsArrType HsHigherOrderApp = text "higher order arrow application" +pprHsArrType HsFirstOrderApp = text "first order arrow application" + +----------------- + +instance Outputable fn => Outputable (HsStmtContext fn) where + ppr = pprStmtContext + +-- Used to generate the string for a *runtime* error message +matchContextErrString :: Outputable fn => HsMatchContext fn -> SDoc +matchContextErrString (FunRhs{mc_fun=fun}) = text "function" <+> ppr fun +matchContextErrString CaseAlt = text "case" +matchContextErrString (LamAlt lam_variant) = lamCaseKeyword lam_variant +matchContextErrString IfAlt = text "multi-way if" +matchContextErrString PatBindRhs = text "pattern binding" +matchContextErrString PatBindGuards = text "pattern binding guards" +matchContextErrString RecUpd = text "record update" +matchContextErrString (ArrowMatchCtxt c) = matchArrowContextErrString c +matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime +matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime +matchContextErrString PatSyn = text "pattern synonym" +matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" +matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block" +matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour +matchContextErrString LazyPatCtx = text "irrefutable pattern" + +matchArrowContextErrString :: HsArrowMatchContext -> SDoc +matchArrowContextErrString ProcExpr = text "proc" +matchArrowContextErrString ArrowCaseAlt = text "case" +matchArrowContextErrString (ArrowLamAlt LamSingle) = text "kappa" +matchArrowContextErrString (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant + +matchDoContextErrString :: HsDoFlavour -> SDoc +matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command" +matchDoContextErrString (DoExpr m) = prependQualified m (text "'do' block") +matchDoContextErrString (MDoExpr m) = prependQualified m (text "'mdo' block") +matchDoContextErrString ListComp = text "list comprehension" +matchDoContextErrString MonadComp = text "monad comprehension" + +pprMatchInCtxt :: (OutputableBndrId idR, Outputable body) + => Match (GhcPass idR) body -> SDoc +pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) + <> colon) + 4 (pprMatch match) + +pprStmtInCtxt :: (OutputableBndrId idL, + OutputableBndrId idR, + Outputable fn, + Outputable body, + Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) + => HsStmtContext fn + -> StmtLR (GhcPass idL) (GhcPass idR) body + -> SDoc +pprStmtInCtxt ctxt (LastStmt _ e _ _) + | isComprehensionContext ctxt -- For [ e | .. ], do not mutter about "stmts" + = hang (text "In the expression:") 2 (ppr e) + +pprStmtInCtxt ctxt stmt + = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) + 2 (ppr_stmt stmt) + where + -- For Group and Transform Stmts, don't print the nested stmts! + ppr_stmt (TransStmt { trS_by = by, trS_using = using + , trS_form = form }) = pprTransStmt by using form + ppr_stmt stmt = pprStmt stmt + + +pprMatchContext :: Outputable p => HsMatchContext p -> SDoc +pprMatchContext ctxt + | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt + | otherwise = text "a" <+> pprMatchContextNoun ctxt + where + want_an (FunRhs {}) = True -- Use "an" in front + want_an (ArrowMatchCtxt ProcExpr) = True + want_an (ArrowMatchCtxt (ArrowLamAlt LamSingle)) = True + want_an LazyPatCtx = True + want_an _ = False + +pprMatchContextNoun :: Outputable fn => HsMatchContext fn -> SDoc +pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for" <+> quotes (ppr fun) +pprMatchContextNoun CaseAlt = text "case alternative" +pprMatchContextNoun (LamAlt LamSingle) = text "lambda abstraction" +pprMatchContextNoun (LamAlt lam_variant) = lamCaseKeyword lam_variant + <+> text "alternative" +pprMatchContextNoun IfAlt = text "multi-way if alternative" +pprMatchContextNoun RecUpd = text "record update" +pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" +pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" +pprMatchContextNoun PatBindRhs = text "pattern binding" +pprMatchContextNoun PatBindGuards = text "pattern binding guards" +pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c +pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" + $$ pprAStmtContext ctxt +pprMatchContextNoun PatSyn = text "pattern synonym declaration" +pprMatchContextNoun LazyPatCtx = text "irrefutable pattern" + +pprMatchContextNouns :: Outputable fn => HsMatchContext fn -> SDoc +pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for" <+> quotes (ppr fun) +pprMatchContextNouns PatBindGuards = text "pattern binding guards" +pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c +pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in" + $$ pprAStmtContext ctxt +pprMatchContextNouns ctxt = pprMatchContextNoun ctxt <> char 's' + +pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc +pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern" +pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation" +pprArrowMatchContextNoun (ArrowLamAlt LamSingle) = text "arrow kappa abstraction" +pprArrowMatchContextNoun (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant + <+> text "alternative within arrow notation" + +pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc +pprArrowMatchContextNouns ArrowCaseAlt = text "case alternatives within arrow notation" +pprArrowMatchContextNouns (ArrowLamAlt LamSingle) = text "arrow kappa abstractions" +pprArrowMatchContextNouns (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant + <+> text "alternatives within arrow notation" +pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's' + +----------------- +pprAStmtContext, pprStmtContext :: Outputable fn => HsStmtContext fn -> SDoc +pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour +pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt + +----------------- +pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour +pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt +pprStmtContext ArrowExpr = text "'do' block in an arrow command" + +-- Drop the inner contexts when reporting errors, else we get +-- Unexpected transform statement +-- in a transformed branch of +-- transformed branch of +-- transformed branch of monad comprehension +pprStmtContext (ParStmtCtxt c) = + ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) + (pprStmtContext c) +pprStmtContext (TransStmtCtxt c) = + ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) + (pprStmtContext c) + +pprStmtCat :: forall p body . IsPass p => Stmt (GhcPass p) body -> SDoc +pprStmtCat (TransStmt {}) = text "transform" +pprStmtCat (LastStmt {}) = text "return expression" +pprStmtCat (BodyStmt {}) = text "body" +pprStmtCat (BindStmt {}) = text "binding" +pprStmtCat (LetStmt {}) = text "let" +pprStmtCat (RecStmt {}) = text "rec" +pprStmtCat (ParStmt {}) = text "parallel" +pprStmtCat (XStmtLR _) = text "applicative" + +pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc +pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour + where + pp_an = text "an" + pp_a = text "a" + article = case flavour of + MDoExpr Nothing -> pp_an + GhciStmtCtxt -> pp_an + _ -> pp_a +pprHsDoFlavour (DoExpr m) = prependQualified m (text "'do' block") +pprHsDoFlavour (MDoExpr m) = prependQualified m (text "'mdo' block") +pprHsDoFlavour ListComp = text "list comprehension" +pprHsDoFlavour MonadComp = text "monad comprehension" +pprHsDoFlavour GhciStmtCtxt = text "interactive GHCi command" + +prependQualified :: Maybe ModuleName -> SDoc -> SDoc +prependQualified Nothing t = t +prependQualified (Just _) t = text "qualified" <+> t + +{- +************************************************************************ +* * +FieldLabelStrings +* * +************************************************************************ +-} + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where + ppr (FieldLabelStrings flds) = + hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds)) + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where + pprInfixOcc = pprFieldLabelStrings + pprPrefixOcc = pprFieldLabelStrings + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where + pprInfixOcc = pprInfixOcc . unLoc + pprPrefixOcc = pprInfixOcc . unLoc + +pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc +pprFieldLabelStrings (FieldLabelStrings flds) = + hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds)) + +pprPrefixFastString :: FastString -> SDoc +pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs) + +instance UnXRec p => Outputable (DotFieldOcc p) where + ppr (DotFieldOcc _ s) = (pprPrefixFastString . field_label . unXRec @p) s + ppr XDotFieldOcc{} = text "XDotFieldOcc" + +{- +************************************************************************ +* * +\subsection{Anno instances} +* * +************************************************************************ +-} + +type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA +type instance Anno [LocatedA (HsExpr (GhcPass p))] = SrcSpanAnnC +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW + +type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA + +type instance Anno (HsCmdTop (GhcPass p)) = EpAnnCO +type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnLW +type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))] = SrcSpanAnnLW +type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA +type instance Anno (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpanAnnA +type instance Anno [LocatedA (Pat (GhcPass p))] = EpaLocation +type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = EpAnnCO +type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = EpAnnCO +type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA + +type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA + +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW + +type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO +type instance Anno FieldLabelString = SrcSpanAnnN + +type instance Anno FastString = EpAnnCO + -- Used in HsQuasiQuote and perhaps elsewhere + +type instance Anno (DotFieldOcc (GhcPass p)) = EpAnnCO + +instance (HasAnnotation (Anno a)) + => WrapXRec (GhcPass p) a where + wrapXRec = noLocA diff --git a/GHC/Hs/Expr.hs-boot b/GHC/Hs/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Hs/Expr.hs-boot @@ -0,0 +1,54 @@ +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension + +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable + +module GHC.Hs.Expr where + +import GHC.Utils.Outputable ( SDoc, Outputable ) +import Language.Haskell.Syntax.Pat ( LPat ) +import {-# SOURCE #-} GHC.Hs.Pat () -- for Outputable +import Language.Haskell.Syntax.Expr + ( HsExpr, LHsExpr + , HsCmd + , MatchGroup + , GRHSs + , HsUntypedSplice + , HsTypedSplice + ) +import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) +import GHC.Types.Name ( Name ) +import Data.Bool ( Bool ) +import Data.Maybe ( Maybe ) + +type SplicePointName = Name + +instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) +instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) + +pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc + +pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc + +pprTypedSplice :: (OutputableBndrId p) => Maybe SplicePointName -> HsTypedSplice (GhcPass p) -> SDoc +pprUntypedSplice :: (OutputableBndrId p) => Bool -> Maybe SplicePointName -> HsUntypedSplice (GhcPass p) -> SDoc + +pprPatBind :: forall bndr p . (OutputableBndrId bndr, + OutputableBndrId p) + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc + +pprFunBind :: (OutputableBndrId idR) + => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc + +data ThModFinalizers +type role HsUntypedSpliceResult representational +data HsUntypedSpliceResult thing + = HsUntypedSpliceTop + { utsplice_result_finalizers :: ThModFinalizers + , utsplice_result :: thing + } + | HsUntypedSpliceNested SplicePointName diff --git a/GHC/Hs/Extension.hs b/GHC/Hs/Extension.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Extension.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} -- for pprIfTc, etc. +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc] +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension + +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable + +module GHC.Hs.Extension where + +-- This module captures the type families to precisely identify the extension +-- points for GHC.Hs syntax + +import GHC.Prelude + +import Data.Data hiding ( Fixity ) +import Language.Haskell.Syntax.Extension +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Var +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Types.SrcLoc (GenLocated(..), unLoc) +import GHC.Utils.Panic +import GHC.Parser.Annotation + +{- +Note [IsPass] +~~~~~~~~~~~~~ +One challenge with the Trees That Grow approach +is that we sometimes have different information in different passes. +For example, we have + + type instance XViaStrategy GhcPs = LHsSigType GhcPs + type instance XViaStrategy GhcRn = LHsSigType GhcRn + type instance XViaStrategy GhcTc = Type + +This means that printing a DerivStrategy (which contains an XViaStrategy) +might need to print a LHsSigType, or it might need to print a type. Yet we +want one Outputable instance for a DerivStrategy, instead of one per pass. We +could have a large constraint, including e.g. (Outputable (XViaStrategy p), +Outputable (XViaStrategy GhcTc)), and pass that around in every context where +we might output a DerivStrategy. But a simpler alternative is to pass a +witness to whichever pass we're in. When we pattern-match on that (GADT) +witness, we learn the pass identity and can then print away. To wit, we get +the definition of GhcPass and the functions isPass. These allow us to do away +with big constraints, passing around all manner of dictionaries we might or +might not use. It does mean that we have to manually use isPass when printing, +but these places are few. + +See Note [NoGhcTc] about the superclass constraint to IsPass. + +Note [NoGhcTc] +~~~~~~~~~~~~~~ +An expression is parsed into HsExpr GhcPs, renamed into HsExpr GhcRn, and +then type-checked into HsExpr GhcTc. Not so for types! These get parsed +into HsType GhcPs, renamed into HsType GhcRn, and then type-checked into +Type. We never build an HsType GhcTc. Why do this? Because we need to be +able to compare type-checked types for equality, and we don't want to do +this with HsType. + +This causes wrinkles within the AST, where we normally think that the whole +AST travels through the GhcPs --> GhcRn --> GhcTc pipeline as one. So we +have the NoGhcTc type family, which just replaces GhcTc with GhcRn, so that +user-written types can be preserved (as HsType GhcRn) even in e.g. HsExpr GhcTc. + +For example, this is used in ExprWithTySig: + | ExprWithTySig + (XExprWithTySig p) + + (LHsExpr p) + (LHsSigWcType (NoGhcTc p)) + +If we have (e :: ty), we still want to be able to print that (with the :: ty) +after type-checking. So we retain the LHsSigWcType GhcRn, even in an +HsExpr GhcTc. That's what NoGhcTc does. + +When we're printing the type annotation, we need to know +(Outputable (LHsSigWcType GhcRn)), even though we've assumed only that +(OutputableBndrId GhcTc). We thus must be able to prove OutputableBndrId (NoGhcTc p) +from OutputableBndrId p. The extra constraints in OutputableBndrId and +the superclass constraints of IsPass allow this. Note that the superclass +constraint of IsPass is *recursive*: it asserts that IsPass (NoGhcTcPass p) holds. +For this to make sense, we need -XUndecidableSuperClasses and the other constraint, +saying that NoGhcTcPass is idempotent. + +-} + +-- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation +type instance XRec (GhcPass p) a = XRecGhc a + +-- (XRecGhc tree) wraps `tree` in a GHC-specific, +-- but pass-independent, source location +type XRecGhc a = GenLocated (Anno a) a + +type instance Anno RdrName = SrcSpanAnnN +type instance Anno Name = SrcSpanAnnN +type instance Anno Id = SrcSpanAnnN + +type instance Anno (WithUserRdr a) = Anno a + +type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ EpAnn a, + Anno (IdOccGhcP p) ~ EpAnn a, + NoAnn a, + IsPass p) + +instance UnXRec (GhcPass p) where + unXRec = unLoc +instance MapXRec (GhcPass p) where + mapXRec = fmap + +-- instance WrapXRec (GhcPass p) a where +-- wrapXRec = noLocA + +{- +Note [DataConCantHappen and strict fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, any unused TTG extension constructor will generally look like the +following: + + type instance XXHsDecl (GhcPass _) = DataConCantHappen + data HsDecl p + = ... + | XHsDecl !(XXHsDecl p) + +The field of type `XXHsDecl p` is strict for a good reason: it allows the +pattern-match coverage checker to conclude that any matches against XHsDecl +are unreachable whenever `p ~ GhcPass _`. To see why this is the case, consider +the following function which consumes an HsDecl: + + ex :: HsDecl GhcPs -> HsDecl GhcRn + ... + ex (XHsDecl nec) = dataConCantHappen nec + +Because `p` equals GhcPs (i.e., GhcPass 'Parsed), XHsDecl's field has the type +DataConCantHappen. But since (1) the field is strict and (2) DataConCantHappen +is an empty data type, there is no possible way to reach the right-hand side +of the XHsDecl case. As a result, the coverage checker concludes that +the XHsDecl case is inaccessible, so it can be removed. +(See Note [Strict argument type constraints] in GHC.HsToCore.Pmc.Solver for +more on how this works.) + +Bottom line: if you add a TTG extension constructor that uses DataConCantHappen, make +sure that any uses of it as a field are strict. +-} + +-- | Used as a data type index for the hsSyn AST; also serves +-- as a singleton type for Pass +data GhcPass (c :: Pass) where + GhcPs :: GhcPass 'Parsed + GhcRn :: GhcPass 'Renamed + GhcTc :: GhcPass 'Typechecked + +-- This really should never be entered, but the data-deriving machinery +-- needs the instance to exist. +instance Typeable p => Data (GhcPass p) where + gunfold _ _ _ = panic "instance Data GhcPass" + toConstr _ = panic "instance Data GhcPass" + dataTypeOf _ = panic "instance Data GhcPass" + +data Pass = Parsed | Renamed | Typechecked + deriving (Data) + +-- Type synonyms as a shorthand for tagging +type GhcPs = GhcPass 'Parsed -- Output of parser +type GhcRn = GhcPass 'Renamed -- Output of renamer +type GhcTc = GhcPass 'Typechecked -- Output of typechecker + +-- | Allows us to check what phase we're in at GHC's runtime. +-- For example, this class allows us to write +-- +-- @ +-- f :: forall p. IsPass p => HsExpr (GhcPass p) -> blah +-- f e = case ghcPass @p of +-- GhcPs -> ... in this RHS we have HsExpr GhcPs... +-- GhcRn -> ... in this RHS we have HsExpr GhcRn... +-- GhcTc -> ... in this RHS we have HsExpr GhcTc... +-- @ +-- +-- which is very useful, for example, when pretty-printing. +-- See Note [IsPass]. +class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p + , IsPass (NoGhcTcPass p) + ) => IsPass p where + ghcPass :: GhcPass p + +instance IsPass 'Parsed where + ghcPass = GhcPs +instance IsPass 'Renamed where + ghcPass = GhcRn +instance IsPass 'Typechecked where + ghcPass = GhcTc + +type instance IdP (GhcPass p) = IdGhcP p + +-- | Maps the "normal" id type for a given GHC pass +type family IdGhcP pass where + IdGhcP 'Parsed = RdrName + IdGhcP 'Renamed = Name + IdGhcP 'Typechecked = Id + +type LIdGhcP p = XRecGhc (IdGhcP p) + +type instance IdOccP (GhcPass p) = IdOccGhcP p + +type family IdOccGhcP pass where + IdOccGhcP 'Parsed = RdrName + IdOccGhcP 'Renamed = WithUserRdr Name + IdOccGhcP 'Typechecked = Id +type LIdOccGhcP p = XRecGhc (IdOccGhcP p) + +-- | Marks that a field uses the GhcRn variant even when the pass +-- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because +-- HsType GhcTc should never occur. +-- See Note [NoGhcTc] + +-- Breaking it up this way, GHC can figure out that the result is a GhcPass +type instance NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass) + +type family NoGhcTcPass (p :: Pass) :: Pass where + NoGhcTcPass 'Typechecked = 'Renamed + NoGhcTcPass other = other + +-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both +-- the @id@ and the 'NoGhcTc' of it. See Note [NoGhcTc]. +type OutputableBndrId pass = + ( OutputableBndr (IdGhcP pass) + , OutputableBndr (IdOccGhcP pass) + , OutputableBndr (IdGhcP (NoGhcTcPass pass)) + , OutputableBndr (IdOccGhcP (NoGhcTcPass pass)) + , Outputable (LIdGhcP pass) + , Outputable (LIdOccGhcP pass) + , Outputable (LIdGhcP (NoGhcTcPass pass)) + , Outputable (LIdOccGhcP (NoGhcTcPass pass)) + , IsPass pass + ) + +-- useful helper functions: +pprIfPs :: forall p. IsPass p => (p ~ 'Parsed => SDoc) -> SDoc +pprIfPs pp = case ghcPass @p of GhcPs -> pp + _ -> empty + +pprIfRn :: forall p. IsPass p => (p ~ 'Renamed => SDoc) -> SDoc +pprIfRn pp = case ghcPass @p of GhcRn -> pp + _ -> empty + +pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc +pprIfTc pp = case ghcPass @p of GhcTc -> pp + _ -> empty + +--- Outputable + +instance Outputable NoExtField where + ppr _ = text "NoExtField" + +instance Outputable DataConCantHappen where + ppr = dataConCantHappen diff --git a/GHC/Hs/ImpExp.hs b/GHC/Hs/ImpExp.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/ImpExp.hs @@ -0,0 +1,380 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable and IEWrappedName +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension +{-# LANGUAGE MultiWayIf #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces +-} + +module GHC.Hs.ImpExp + ( module Language.Haskell.Syntax.ImpExp + , module GHC.Hs.ImpExp + ) where + +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.ImpExp + +import GHC.Prelude + +import GHC.Types.SourceText ( SourceText(..) ) +import GHC.Types.SrcLoc +import GHC.Types.Name +import GHC.Types.PkgQual + +import GHC.Parser.Annotation +import GHC.Hs.Extension + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Unit.Module.Warnings + +import Data.Data +import Data.Maybe +import GHC.Hs.Doc (LHsDoc) + + +{- +************************************************************************ +* * + Import and export declaration lists +* * +************************************************************************ + +One per import declaration in a module. +-} + +type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA + + + +-- | Convenience function to answer the question if an import decl. is +-- qualified. +isImportDeclQualified :: ImportDeclQualifiedStyle -> Bool +isImportDeclQualified NotQualified = False +isImportDeclQualified _ = True + + + +type instance ImportDeclPkgQual GhcPs = RawPkgQual +type instance ImportDeclPkgQual GhcRn = PkgQual +type instance ImportDeclPkgQual GhcTc = PkgQual + +type instance XCImportDecl GhcPs = XImportDeclPass +type instance XCImportDecl GhcRn = XImportDeclPass +type instance XCImportDecl GhcTc = DataConCantHappen + +data XImportDeclPass = XImportDeclPass + { ideclAnn :: EpAnn EpAnnImportDecl + , ideclSourceText :: SourceText -- Note [Pragma source text] in "GHC.Types.SourceText" + , ideclImplicit :: Bool + -- ^ GHC generates an `ImportDecl` to represent the invisible `import Prelude` + -- that appears in any file that omits `import Prelude`, setting + -- this field to indicate that the import doesn't appear in the + -- original source. True => implicit import (of Prelude) + } + deriving (Data) + +type instance XXImportDecl (GhcPass _) = DataConCantHappen + +type instance Anno ModuleName = SrcSpanAnnA +type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnLI + +deriving instance Data (IEWrappedName GhcPs) +deriving instance Data (IEWrappedName GhcRn) +deriving instance Data (IEWrappedName GhcTc) + +deriving instance Eq (IEWrappedName GhcPs) +deriving instance Eq (IEWrappedName GhcRn) +deriving instance Eq (IEWrappedName GhcTc) + +-- --------------------------------------------------------------------- + +-- API Annotations types + +data EpAnnImportDecl = EpAnnImportDecl + { importDeclAnnImport :: EpToken "import" -- ^ The location of the @import@ keyword + , importDeclAnnPragma :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively + , importDeclAnnSafe :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword + , importDeclAnnLevel :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword + , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword + , importDeclAnnPackage :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@) + , importDeclAnnAs :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword + } deriving (Data) + + +instance NoAnn EpAnnImportDecl where + noAnn = EpAnnImportDecl noAnn Nothing Nothing noAnn Nothing Nothing Nothing + +data EpAnnLevel = EpAnnLevelSplice (EpToken "splice") + | EpAnnLevelQuote (EpToken "quote") + deriving Data + +instance HasLoc EpAnnLevel where + getHasLoc (EpAnnLevelSplice tok) = getEpTokenSrcSpan tok + getHasLoc (EpAnnLevelQuote tok) = getEpTokenSrcSpan tok + +-- --------------------------------------------------------------------- + +simpleImportDecl :: ModuleName -> ImportDecl GhcPs +simpleImportDecl mn = ImportDecl { + ideclExt = XImportDeclPass noAnn NoSourceText False, + ideclName = noLocA mn, + ideclPkgQual = NoRawPkgQual, + ideclSource = NotBoot, + ideclSafe = False, + ideclLevelSpec = NotLevelled, + ideclQualified = NotQualified, + ideclAs = Nothing, + ideclImportList = Nothing + } + +instance (OutputableBndrId p + , Outputable (Anno (IE (GhcPass p))) + , Outputable (ImportDeclPkgQual (GhcPass p))) + => Outputable (ImportDecl (GhcPass p)) where + ppr (ImportDecl { ideclExt = impExt, ideclName = mod' + , ideclPkgQual = pkg + , ideclSource = from, ideclSafe = safe + , ideclQualified = qual + , ideclAs = as, ideclImportList = spec }) + = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, pp_safe safe, + pp_qual qual False, ppr pkg, ppr mod', pp_qual qual True, pp_as as]) + 4 (pp_spec spec) + where + pp_implicit ext = + let implicit = case ghcPass @p of + GhcPs | XImportDeclPass { ideclImplicit = implicit } <- ext -> implicit + GhcRn | XImportDeclPass { ideclImplicit = implicit } <- ext -> implicit + GhcTc -> dataConCantHappen ext + in if implicit then text "(implicit)" + else empty + + pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position. + pp_qual QualifiedPost True = text "qualified" -- Postpositive qualifier/postpositive position. + pp_qual QualifiedPre True = empty -- Prepositive qualifier/postpositive position. + pp_qual QualifiedPost False = empty -- Postpositive qualifier/prepositive position. + pp_qual NotQualified _ = empty + + pp_safe False = empty + pp_safe True = text "safe" + + pp_as Nothing = empty + pp_as (Just a) = text "as" <+> ppr a + + ppr_imp ext IsBoot = + let mSrcText = case ghcPass @p of + GhcPs | XImportDeclPass { ideclSourceText = mst } <- ext -> mst + GhcRn | XImportDeclPass { ideclSourceText = mst } <- ext -> mst + GhcTc -> dataConCantHappen ext + in case mSrcText of + NoSourceText -> text "{-# SOURCE #-}" + SourceText src -> ftext src <+> text "#-}" + ppr_imp _ NotBoot = empty + + pp_spec Nothing = empty + pp_spec (Just (Exactly, (L _ ies))) = ppr_ies ies + pp_spec (Just (EverythingBut, (L _ ies))) = text "hiding" <+> ppr_ies ies + + ppr_ies [] = text "()" + ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' + +{- +************************************************************************ +* * +\subsection{Imported and exported entities} +* * +************************************************************************ +-} + +type instance XIEName (GhcPass _) = NoExtField +type instance XIEDefault (GhcPass _) = EpToken "default" +type instance XIEPattern (GhcPass _) = EpToken "pattern" +type instance XIEType (GhcPass _) = EpToken "type" +type instance XIEData (GhcPass _) = EpToken "data" +type instance XXIEWrappedName (GhcPass _) = DataConCantHappen + +type instance Anno (IEWrappedName (GhcPass _)) = SrcSpanAnnA + +type instance Anno (IE (GhcPass p)) = SrcSpanAnnA + +-- The additional field of type 'Maybe (WarningTxt pass)' holds information +-- about export deprecation annotations and is thus set to Nothing when `IE` +-- is used in an import list (since export deprecation can only be used in exports) +type instance XIEVar GhcPs = Maybe (LWarningTxt GhcPs) +type instance XIEVar GhcRn = Maybe (LWarningTxt GhcRn) +type instance XIEVar GhcTc = NoExtField + +-- The additional field of type 'Maybe (WarningTxt pass)' holds information +-- about export deprecation annotations and is thus set to Nothing when `IE` +-- is used in an import list (since export deprecation can only be used in exports) +type instance XIEThingAbs GhcPs = Maybe (LWarningTxt GhcPs) +type instance XIEThingAbs GhcRn = Maybe (LWarningTxt GhcRn) +type instance XIEThingAbs GhcTc = () + +-- The additional field of type 'Maybe (WarningTxt pass)' holds information +-- about export deprecation annotations and is thus set to Nothing when `IE` +-- is used in an import list (since export deprecation can only be used in exports) +type instance XIEThingAll GhcPs = (Maybe (LWarningTxt GhcPs), (EpToken "(", EpToken "..", EpToken ")")) +type instance XIEThingAll GhcRn = (Maybe (LWarningTxt GhcRn), (EpToken "(", EpToken "..", EpToken ")")) +type instance XIEThingAll GhcTc = (EpToken "(", EpToken "..", EpToken ")") + +-- The additional field of type 'Maybe (WarningTxt pass)' holds information +-- about export deprecation annotations and is thus set to Nothing when `IE` +-- is used in an import list (since export deprecation can only be used in exports) +type instance XIEThingWith GhcPs = (Maybe (LWarningTxt GhcPs), IEThingWithAnns) +type instance XIEThingWith GhcRn = (Maybe (LWarningTxt GhcRn), IEThingWithAnns) +type instance XIEThingWith GhcTc = IEThingWithAnns + +type IEThingWithAnns = (EpToken "(", EpToken "..", EpToken ",", EpToken ")") + +-- The additional field of type 'Maybe (WarningTxt pass)' holds information +-- about export deprecation annotations and is thus set to Nothing when `IE` +-- is used in an import list (since export deprecation can only be used in exports) +type instance XIEModuleContents GhcPs = (Maybe (LWarningTxt GhcPs), EpToken "module") +type instance XIEModuleContents GhcRn = Maybe (LWarningTxt GhcRn) +type instance XIEModuleContents GhcTc = NoExtField + +type instance XIEGroup (GhcPass _) = NoExtField +type instance XIEDoc (GhcPass _) = NoExtField +type instance XIEDocNamed (GhcPass _) = NoExtField +type instance XXIE (GhcPass _) = DataConCantHappen + +type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA + +ieLIEWrappedName :: IE (GhcPass p) -> LIEWrappedName (GhcPass p) +ieLIEWrappedName (IEVar _ n _) = n +ieLIEWrappedName (IEThingAbs _ n _) = n +ieLIEWrappedName (IEThingWith _ n _ _ _) = n +ieLIEWrappedName (IEThingAll _ n _) = n +ieLIEWrappedName _ = panic "ieLIEWrappedName failed pattern match!" + +ieName :: IE (GhcPass p) -> IdP (GhcPass p) +ieName = lieWrappedName . ieLIEWrappedName + +ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)] +ieNames (IEVar _ (L _ n) _) = [ieWrappedName n] +ieNames (IEThingAbs _ (L _ n) _) = [ieWrappedName n] +ieNames (IEThingAll _ (L _ n) _) = [ieWrappedName n] +ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n : map (ieWrappedName . unLoc) ns +ieNames (IEModuleContents {}) = [] +ieNames (IEGroup {}) = [] +ieNames (IEDoc {}) = [] +ieNames (IEDocNamed {}) = [] + +ieDeprecation :: forall p. IsPass p => IE (GhcPass p) -> Maybe (WarningTxt (GhcPass p)) +ieDeprecation = fmap unLoc . ie_deprecation (ghcPass @p) + where + ie_deprecation :: GhcPass p -> IE (GhcPass p) -> Maybe (LWarningTxt (GhcPass p)) + ie_deprecation GhcPs (IEVar xie _ _) = xie + ie_deprecation GhcPs (IEThingAbs xie _ _) = xie + ie_deprecation GhcPs (IEThingAll (xie, _) _ _) = xie + ie_deprecation GhcPs (IEThingWith (xie, _) _ _ _ _) = xie + ie_deprecation GhcPs (IEModuleContents (xie, _) _) = xie + ie_deprecation GhcRn (IEVar xie _ _) = xie + ie_deprecation GhcRn (IEThingAbs xie _ _) = xie + ie_deprecation GhcRn (IEThingAll (xie, _) _ _) = xie + ie_deprecation GhcRn (IEThingWith (xie, _) _ _ _ _) = xie + ie_deprecation GhcRn (IEModuleContents xie _) = xie + ie_deprecation _ _ = Nothing + +ieWrappedLName :: IEWrappedName (GhcPass p) -> LIdP (GhcPass p) +ieWrappedLName (IEDefault _ (L l n)) = L l n +ieWrappedLName (IEName _ (L l n)) = L l n +ieWrappedLName (IEPattern _ (L l n)) = L l n +ieWrappedLName (IEType _ (L l n)) = L l n +ieWrappedLName (IEData _ (L l n)) = L l n + +ieWrappedName :: IEWrappedName (GhcPass p) -> IdP (GhcPass p) +ieWrappedName = unLoc . ieWrappedLName + + +lieWrappedName :: LIEWrappedName (GhcPass p) -> IdP (GhcPass p) +lieWrappedName (L _ n) = ieWrappedName n + +ieLWrappedName :: LIEWrappedName (GhcPass p) -> LIdP (GhcPass p) +ieLWrappedName (L _ n) = ieWrappedLName n + +replaceWrappedName :: IEWrappedName GhcPs -> IdP GhcRn -> IEWrappedName GhcRn +replaceWrappedName (IEDefault r (L l _)) n = IEDefault r (L l n) +replaceWrappedName (IEName x (L l _)) n = IEName x (L l n) +replaceWrappedName (IEPattern r (L l _)) n = IEPattern r (L l n) +replaceWrappedName (IEType r (L l _)) n = IEType r (L l n) +replaceWrappedName (IEData r (L l _)) n = IEData r (L l n) + +replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn +replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') + +exportDocstring :: LHsDoc pass -> SDoc +exportDocstring doc = braces (text "docstring: " <> ppr doc) + +instance OutputableBndrId p => Outputable (IE (GhcPass p)) where + ppr ie@(IEVar _ var doc) = + sep $ catMaybes [ ppr <$> ieDeprecation ie + , Just $ ppr (unLoc var) + , exportDocstring <$> doc + ] + ppr ie@(IEThingAbs _ thing doc) = + sep $ catMaybes [ ppr <$> ieDeprecation ie + , Just $ ppr (unLoc thing) + , exportDocstring <$> doc + ] + ppr ie@(IEThingAll _ thing doc) = + sep $ catMaybes [ ppr <$> ieDeprecation ie + , Just $ hcat [ppr (unLoc thing) + , text "(..)"] + , exportDocstring <$> doc + ] + ppr ie@(IEThingWith _ thing wc withs doc) = + sep $ catMaybes [ ppr <$> ieDeprecation ie + , Just $ ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths)) + , exportDocstring <$> doc + ] + where + ppWiths = + case wc of + NoIEWildcard -> + map (ppr . unLoc) withs + IEWildcard pos -> + let (bs, as) = splitAt pos (map (ppr . unLoc) withs) + in bs ++ [text ".."] ++ as + ppr ie@(IEModuleContents _ mod') + = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ text "module" <+> ppr mod'] + ppr (IEGroup _ n _) = text ("") + ppr (IEDoc _ doc) = ppr doc + ppr (IEDocNamed _ string) = text ("") + +instance (HasOccName (IdP (GhcPass p)), OutputableBndrId p) => HasOccName (IEWrappedName (GhcPass p)) where + occName w = occName (ieWrappedName w) + +instance OutputableBndrId p => OutputableBndr (IEWrappedName (GhcPass p)) where + pprBndr bs w = pprBndr bs (ieWrappedName w) + pprPrefixOcc w = pprPrefixOcc (ieWrappedName w) + pprInfixOcc w = pprInfixOcc (ieWrappedName w) + +instance OutputableBndrId p => Outputable (IEWrappedName (GhcPass p)) where + ppr (IEDefault _ (L _ n)) = text "default" <+> pprPrefixOcc n + ppr (IEName _ (L _ n)) = pprPrefixOcc n + ppr (IEPattern _ (L _ n)) = text "pattern" <+> pprPrefixOcc n + ppr (IEType _ (L _ n)) = text "type" <+> pprPrefixOcc n + ppr (IEData _ (L _ n)) = text "data" <+> pprPrefixOcc n + +pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc +pprImpExp name = type_pref <+> pprPrefixOcc name + where + occ = occName name + type_pref | isTcOcc occ && isSymOcc occ = text "type" + | otherwise = empty diff --git a/GHC/Hs/Instances.hs b/GHC/Hs/Instances.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Instances.hs @@ -0,0 +1,610 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- This module contains exclusively Data instances, which are going to be slow +-- no matter what we do. Furthermore, they are incredibly slow to compile with +-- optimisation (see #9557). Consequently we compile this with -O0. +-- See #18254. +{-# OPTIONS_GHC -O0 #-} + +module GHC.Hs.Instances where + +-- This module defines the Data instances for the hsSyn AST. + +-- It happens here to avoid massive constraint types on the AST with concomitant +-- slow GHC bootstrap times. + +-- UndecidableInstances ? + +import Data.Data hiding ( Fixity ) + +import GHC.Prelude +import GHC.Hs.Extension +import GHC.Hs.Binds +import GHC.Hs.Decls +import GHC.Hs.Expr +import GHC.Hs.Lit +import GHC.Hs.Type +import GHC.Hs.Pat +import GHC.Hs.ImpExp +import GHC.Parser.Annotation +import GHC.Types.Name.Reader (WithUserRdr(..)) +import GHC.Data.BooleanFormula (BooleanFormula(..)) +import Language.Haskell.Syntax.Extension (Anno) + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs----------------------------------------- + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Binds ---------------------------------- + +-- deriving instance (DataIdLR pL pR) => Data (HsLocalBindsLR pL pR) +deriving instance Data (HsLocalBindsLR GhcPs GhcPs) +deriving instance Data (HsLocalBindsLR GhcPs GhcRn) +deriving instance Data (HsLocalBindsLR GhcRn GhcRn) +deriving instance Data (HsLocalBindsLR GhcTc GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (HsValBindsLR pL pR) +deriving instance Data (HsValBindsLR GhcPs GhcPs) +deriving instance Data (HsValBindsLR GhcPs GhcRn) +deriving instance Data (HsValBindsLR GhcRn GhcRn) +deriving instance Data (HsValBindsLR GhcTc GhcTc) + +-- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL) +deriving instance Data (NHsValBindsLR GhcPs) +deriving instance Data (NHsValBindsLR GhcRn) +deriving instance Data (NHsValBindsLR GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR) +deriving instance Data (HsBindLR GhcPs GhcPs) +deriving instance Data (HsBindLR GhcPs GhcRn) +deriving instance Data (HsBindLR GhcRn GhcRn) +deriving instance Data (HsBindLR GhcTc GhcTc) + +deriving instance Data AbsBinds + +deriving instance Data ABExport + +-- deriving instance DataId p => Data (RecordPatSynField p) +deriving instance Data (RecordPatSynField GhcPs) +deriving instance Data (RecordPatSynField GhcRn) +deriving instance Data (RecordPatSynField GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) +deriving instance Data (PatSynBind GhcPs GhcPs) +deriving instance Data (PatSynBind GhcPs GhcRn) +deriving instance Data (PatSynBind GhcRn GhcRn) +deriving instance Data (PatSynBind GhcTc GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsIPBinds p) +deriving instance Data (HsIPBinds GhcPs) +deriving instance Data (HsIPBinds GhcRn) +deriving instance Data (HsIPBinds GhcTc) + +-- deriving instance (DataIdLR p p) => Data (IPBind p) +deriving instance Data (IPBind GhcPs) +deriving instance Data (IPBind GhcRn) +deriving instance Data (IPBind GhcTc) + +-- deriving instance (DataIdLR p p) => Data (Sig p) +deriving instance Data (Sig GhcPs) +deriving instance Data (Sig GhcRn) +deriving instance Data (Sig GhcTc) + +-- deriving instance (DataId p) => Data (FixitySig p) +deriving instance Data (FixitySig GhcPs) +deriving instance Data (FixitySig GhcRn) +deriving instance Data (FixitySig GhcTc) + +-- deriving instance (DataId p) => Data (StandaloneKindSig p) +deriving instance Data (StandaloneKindSig GhcPs) +deriving instance Data (StandaloneKindSig GhcRn) +deriving instance Data (StandaloneKindSig GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsPatSynDir p) +deriving instance Data (HsPatSynDir GhcPs) +deriving instance Data (HsPatSynDir GhcRn) +deriving instance Data (HsPatSynDir GhcTc) + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Decls ---------------------------------- + +-- deriving instance (DataIdLR p p) => Data (HsDecl p) +deriving instance Data (HsDecl GhcPs) +deriving instance Data (HsDecl GhcRn) +deriving instance Data (HsDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsGroup p) +deriving instance Data (HsGroup GhcPs) +deriving instance Data (HsGroup GhcRn) +deriving instance Data (HsGroup GhcTc) + +-- deriving instance (DataIdLR p p) => Data (SpliceDecl p) +deriving instance Data (SpliceDecl GhcPs) +deriving instance Data (SpliceDecl GhcRn) +deriving instance Data (SpliceDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (TyClDecl p) +deriving instance Data (TyClDecl GhcPs) +deriving instance Data (TyClDecl GhcRn) +deriving instance Data (TyClDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FunDep p) +deriving instance Data (FunDep GhcPs) +deriving instance Data (FunDep GhcRn) +deriving instance Data (FunDep GhcTc) + +-- deriving instance (DataIdLR p p) => Data (TyClGroup p) +deriving instance Data (TyClGroup GhcPs) +deriving instance Data (TyClGroup GhcRn) +deriving instance Data (TyClGroup GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyResultSig p) +deriving instance Data (FamilyResultSig GhcPs) +deriving instance Data (FamilyResultSig GhcRn) +deriving instance Data (FamilyResultSig GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyDecl p) +deriving instance Data (FamilyDecl GhcPs) +deriving instance Data (FamilyDecl GhcRn) +deriving instance Data (FamilyDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (InjectivityAnn p) +deriving instance Data (InjectivityAnn GhcPs) +deriving instance Data (InjectivityAnn GhcRn) +deriving instance Data (InjectivityAnn GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyInfo p) +deriving instance Data (FamilyInfo GhcPs) +deriving instance Data (FamilyInfo GhcRn) +deriving instance Data (FamilyInfo GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsDataDefn p) +deriving instance Data (HsDataDefn GhcPs) +deriving instance Data (HsDataDefn GhcRn) +deriving instance Data (HsDataDefn GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsDerivingClause p) +deriving instance Data (HsDerivingClause GhcPs) +deriving instance Data (HsDerivingClause GhcRn) +deriving instance Data (HsDerivingClause GhcTc) + +-- deriving instance DataIdLR p p => Data (DerivClauseTys p) +deriving instance Data (DerivClauseTys GhcPs) +deriving instance Data (DerivClauseTys GhcRn) +deriving instance Data (DerivClauseTys GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ConDecl p) +deriving instance Data (ConDecl GhcPs) +deriving instance Data (ConDecl GhcRn) +deriving instance Data (ConDecl GhcTc) + +-- deriving instance DataIdLR p p => Data (HsConDeclGADTDetails p) +deriving instance Data (HsConDeclGADTDetails GhcPs) +deriving instance Data (HsConDeclGADTDetails GhcRn) +deriving instance Data (HsConDeclGADTDetails GhcTc) + +-- deriving instance DataIdLR p p => Data (TyFamInstDecl p) +deriving instance Data (TyFamInstDecl GhcPs) +deriving instance Data (TyFamInstDecl GhcRn) +deriving instance Data (TyFamInstDecl GhcTc) + +-- deriving instance DataIdLR p p => Data (DataFamInstDecl p) +deriving instance Data (DataFamInstDecl GhcPs) +deriving instance Data (DataFamInstDecl GhcRn) +deriving instance Data (DataFamInstDecl GhcTc) + +-- deriving instance (DataIdLR p p,Data rhs)=>Data (FamEqn p rhs) +deriving instance Data rhs => Data (FamEqn GhcPs rhs) +deriving instance Data rhs => Data (FamEqn GhcRn rhs) +deriving instance Data rhs => Data (FamEqn GhcTc rhs) + +-- deriving instance (DataIdLR p p) => Data (ClsInstDecl p) +deriving instance Data (ClsInstDecl GhcPs) +deriving instance Data (ClsInstDecl GhcRn) +deriving instance Data (ClsInstDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (InstDecl p) +deriving instance Data (InstDecl GhcPs) +deriving instance Data (InstDecl GhcRn) +deriving instance Data (InstDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (DerivDecl p) +deriving instance Data (DerivDecl GhcPs) +deriving instance Data (DerivDecl GhcRn) +deriving instance Data (DerivDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (DerivStrategy p) +deriving instance Data (DerivStrategy GhcPs) +deriving instance Data (DerivStrategy GhcRn) +deriving instance Data (DerivStrategy GhcTc) + +-- deriving instance (DataIdLR p p) => Data (DefaultDecl p) +deriving instance Data (DefaultDecl GhcPs) +deriving instance Data (DefaultDecl GhcRn) +deriving instance Data (DefaultDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ForeignDecl p) +deriving instance Data (ForeignDecl GhcPs) +deriving instance Data (ForeignDecl GhcRn) +deriving instance Data (ForeignDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ForeignImport p) +deriving instance Data (ForeignImport GhcPs) +deriving instance Data (ForeignImport GhcRn) +deriving instance Data (ForeignImport GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ForeignExport p) +deriving instance Data (ForeignExport GhcPs) +deriving instance Data (ForeignExport GhcRn) +deriving instance Data (ForeignExport GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleDecls p) +deriving instance Data (RuleDecls GhcPs) +deriving instance Data (RuleDecls GhcRn) +deriving instance Data (RuleDecls GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleDecl p) +deriving instance Data (RuleDecl GhcPs) +deriving instance Data (RuleDecl GhcRn) +deriving instance Data (RuleDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleBndr p) +deriving instance Data (RuleBndr GhcPs) +deriving instance Data (RuleBndr GhcRn) +deriving instance Data (RuleBndr GhcTc) + +deriving instance Data (RuleBndrs GhcPs) +deriving instance Data (RuleBndrs GhcRn) +deriving instance Data (RuleBndrs GhcTc) + +deriving instance Data TcSpecPrags +deriving instance Data TcSpecPrag + +-- deriving instance (DataId p) => Data (WarnDecls p) +deriving instance Data (WarnDecls GhcPs) +deriving instance Data (WarnDecls GhcRn) +deriving instance Data (WarnDecls GhcTc) + +-- deriving instance (DataId p) => Data (WarnDecl p) +deriving instance Data (WarnDecl GhcPs) +deriving instance Data (WarnDecl GhcRn) +deriving instance Data (WarnDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (AnnDecl p) +deriving instance Data (AnnProvenance GhcPs) +deriving instance Data (AnnProvenance GhcRn) +deriving instance Data (AnnProvenance GhcTc) + +deriving instance Data (AnnDecl GhcPs) +deriving instance Data (AnnDecl GhcRn) +deriving instance Data (AnnDecl GhcTc) + +-- deriving instance (DataId p) => Data (RoleAnnotDecl p) +deriving instance Data (RoleAnnotDecl GhcPs) +deriving instance Data (RoleAnnotDecl GhcRn) +deriving instance Data (RoleAnnotDecl GhcTc) + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Expr ----------------------------------- + +deriving instance Data (FieldLabelStrings GhcPs) +deriving instance Data (FieldLabelStrings GhcRn) +deriving instance Data (FieldLabelStrings GhcTc) + +deriving instance Data (HsRecUpdParent GhcPs) +deriving instance Data (HsRecUpdParent GhcRn) +deriving instance Data (HsRecUpdParent GhcTc) + +deriving instance Data (LHsRecUpdFields GhcPs) +deriving instance Data (LHsRecUpdFields GhcRn) +deriving instance Data (LHsRecUpdFields GhcTc) + +deriving instance Data (DotFieldOcc GhcPs) +deriving instance Data (DotFieldOcc GhcRn) +deriving instance Data (DotFieldOcc GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsPragE p) +deriving instance Data (HsPragE GhcPs) +deriving instance Data (HsPragE GhcRn) +deriving instance Data (HsPragE GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsExpr p) +deriving instance Data (HsExpr GhcPs) +deriving instance Data (HsExpr GhcRn) +deriving instance Data (HsExpr GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsTupArg p) +deriving instance Data (HsTupArg GhcPs) +deriving instance Data (HsTupArg GhcRn) +deriving instance Data (HsTupArg GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsCmd p) +deriving instance Data (HsCmd GhcPs) +deriving instance Data (HsCmd GhcRn) +deriving instance Data (HsCmd GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsCmdTop p) +deriving instance Data (HsCmdTop GhcPs) +deriving instance Data (HsCmdTop GhcRn) +deriving instance Data (HsCmdTop GhcTc) + +-- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body) +deriving instance Data (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) +deriving instance Data (MatchGroup GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (MatchGroup GhcTc (LocatedA (HsExpr GhcTc))) +deriving instance Data (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) +deriving instance Data (MatchGroup GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (MatchGroup GhcTc (LocatedA (HsCmd GhcTc))) + +-- deriving instance (DataIdLR p p,Data body) => Data (Match p body) +deriving instance Data (Match GhcPs (LocatedA (HsExpr GhcPs))) +deriving instance Data (Match GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (Match GhcTc (LocatedA (HsExpr GhcTc))) +deriving instance Data (Match GhcPs (LocatedA (HsCmd GhcPs))) +deriving instance Data (Match GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (Match GhcTc (LocatedA (HsCmd GhcTc))) + +-- deriving instance (DataIdLR p p,Data body) => Data (GRHSs p body) +deriving instance Data (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) +deriving instance Data (GRHSs GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (GRHSs GhcTc (LocatedA (HsExpr GhcTc))) +deriving instance Data (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) +deriving instance Data (GRHSs GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (GRHSs GhcTc (LocatedA (HsCmd GhcTc))) + +-- deriving instance (DataIdLR p p,Data body) => Data (GRHS p body) +deriving instance Data (GRHS GhcPs (LocatedA (HsExpr GhcPs))) +deriving instance Data (GRHS GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (GRHS GhcTc (LocatedA (HsExpr GhcTc))) +deriving instance Data (GRHS GhcPs (LocatedA (HsCmd GhcPs))) +deriving instance Data (GRHS GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (GRHS GhcTc (LocatedA (HsCmd GhcTc))) + +-- deriving instance (DataIdLR p p,Data body) => Data (StmtLR p p body) +deriving instance Data (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))) +deriving instance Data (StmtLR GhcPs GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (StmtLR GhcRn GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))) +deriving instance Data (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs))) +deriving instance Data (StmtLR GhcPs GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (StmtLR GhcRn GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc))) + +deriving instance Data RecStmtTc + +-- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p) +deriving instance Data (ParStmtBlock GhcPs GhcPs) +deriving instance Data (ParStmtBlock GhcPs GhcRn) +deriving instance Data (ParStmtBlock GhcRn GhcRn) +deriving instance Data (ParStmtBlock GhcTc GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ApplicativeStmt p p) +deriving instance Data (ApplicativeStmt GhcPs GhcPs) +deriving instance Data (ApplicativeStmt GhcPs GhcRn) +deriving instance Data (ApplicativeStmt GhcPs GhcTc) +deriving instance Data (ApplicativeStmt GhcRn GhcPs) +deriving instance Data (ApplicativeStmt GhcRn GhcRn) +deriving instance Data (ApplicativeStmt GhcRn GhcTc) +deriving instance Data (ApplicativeStmt GhcTc GhcPs) +deriving instance Data (ApplicativeStmt GhcTc GhcRn) +deriving instance Data (ApplicativeStmt GhcTc GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ApplicativeArg p) +deriving instance Data (ApplicativeArg GhcPs) +deriving instance Data (ApplicativeArg GhcRn) +deriving instance Data (ApplicativeArg GhcTc) + +deriving instance Data HsArrowMatchContext + +deriving instance Data fn => Data (HsStmtContext fn) +deriving instance Data fn => Data (HsMatchContext fn) + +-- deriving instance (DataIdLR p p) => Data (HsUntypedSplice p) +deriving instance Data (HsUntypedSplice GhcPs) +deriving instance Data (HsUntypedSplice GhcRn) +deriving instance Data (HsUntypedSplice GhcTc) + +deriving instance Data (HsTypedSplice GhcPs) +deriving instance Data (HsTypedSplice GhcRn) +deriving instance Data (HsTypedSplice GhcTc) + +deriving instance Data HsImplicitLiftSplice +deriving instance Data HsUserSpliceExt +deriving instance Data HsQuasiQuoteExt + +deriving instance Data a => Data (HsUntypedSpliceResult a) +deriving instance Data HsTypedSpliceResult + +-- deriving instance (DataIdLR p p) => Data (HsQuote p) +deriving instance Data (HsQuote GhcPs) +deriving instance Data (HsQuote GhcRn) +deriving instance Data (HsQuote GhcTc) + +deriving instance Data HsBracketTc + +-- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p) +deriving instance Data (ArithSeqInfo GhcPs) +deriving instance Data (ArithSeqInfo GhcRn) +deriving instance Data (ArithSeqInfo GhcTc) + +deriving instance Data CmdTopTc +deriving instance Data PendingRnSplice +deriving instance Data PendingTcSplice +deriving instance Data SyntaxExprRn +deriving instance Data SyntaxExprTc + +deriving instance Data XBindStmtRn +deriving instance Data XBindStmtTc + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Lit ------------------------------------ + +-- deriving instance (DataId p) => Data (HsLit p) +deriving instance Data (HsLit GhcPs) +deriving instance Data (HsLit GhcRn) + +deriving instance Data HsLitTc +deriving instance Data (HsLit GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsOverLit p) +deriving instance Data (HsOverLit GhcPs) +deriving instance Data (HsOverLit GhcRn) +deriving instance Data (HsOverLit GhcTc) + +deriving instance Data OverLitRn +deriving instance Data OverLitTc + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Pat ------------------------------------ + +-- deriving instance (DataIdLR p p) => Data (Pat p) +deriving instance Data (Pat GhcPs) +deriving instance Data (Pat GhcRn) +deriving instance Data (Pat GhcTc) + +deriving instance Data ConPatTc + +deriving instance (Data a, Data b) => Data (HsFieldBind a b) + +deriving instance (Data body) => Data (HsRecFields GhcPs body) +deriving instance (Data body) => Data (HsRecFields GhcRn body) +deriving instance (Data body) => Data (HsRecFields GhcTc body) + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Type ---------------------------------- + +-- deriving instance Data (HsBndrVis p) +deriving instance Data (HsBndrVis GhcPs) +deriving instance Data (HsBndrVis GhcRn) +deriving instance Data (HsBndrVis GhcTc) + +-- deriving instance (DataIdLR p p) => Data (LHsQTyVars p) +deriving instance Data (LHsQTyVars GhcPs) +deriving instance Data (LHsQTyVars GhcRn) +deriving instance Data (LHsQTyVars GhcTc) + +-- deriving instance (Data flag, DataIdLR p p) => Data (HsOuterTyVarBndrs p) +deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcPs) +deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcRn) +deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsSigType p) +deriving instance Data (HsSigType GhcPs) +deriving instance Data (HsSigType GhcRn) +deriving instance Data (HsSigType GhcTc) + +-- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing) + +-- deriving instance (DataIdLR p p) => Data (HsPatSigType p) +deriving instance Data (HsPatSigType GhcPs) +deriving instance Data (HsPatSigType GhcRn) +deriving instance Data (HsPatSigType GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsTyPat p) +deriving instance Data (HsTyPat GhcPs) +deriving instance Data (HsTyPat GhcRn) +deriving instance Data (HsTyPat GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsForAllTelescope p) +deriving instance Data (HsForAllTelescope GhcPs) +deriving instance Data (HsForAllTelescope GhcRn) +deriving instance Data (HsForAllTelescope GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) +deriving instance (Data flag) => Data (HsTyVarBndr flag GhcPs) +deriving instance (Data flag) => Data (HsTyVarBndr flag GhcRn) +deriving instance (Data flag) => Data (HsTyVarBndr flag GhcTc) + +-- deriving instance Data (HsBndrVar p) +deriving instance Data (HsBndrVar GhcPs) +deriving instance Data (HsBndrVar GhcRn) +deriving instance Data (HsBndrVar GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsBndrKind p) +deriving instance Data (HsBndrKind GhcPs) +deriving instance Data (HsBndrKind GhcRn) +deriving instance Data (HsBndrKind GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsType p) +deriving instance Data (HsType GhcPs) +deriving instance Data (HsType GhcRn) +deriving instance Data (HsType GhcTc) + +deriving instance Data HsTypeGhcPsExt + +-- deriving instance (DataIdLR p p) => Data (HsTyLit p) +deriving instance Data (HsTyLit GhcPs) +deriving instance Data (HsTyLit GhcRn) +deriving instance Data (HsTyLit GhcTc) + +-- deriving instance (Data mult, DataIdLR p p) => Data (HsMultAnnOf mult p) +deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcPs)) GhcPs) +deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcRn)) GhcRn) +deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcRn)) GhcTc) +deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcPs)) GhcPs) +deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn) +deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcTc)) GhcTc) + +-- deriving instance (Data a, Data b) => Data (HsArg p a b) +deriving instance (Data a, Data b) => Data (HsArg GhcPs a b) +deriving instance (Data a, Data b) => Data (HsArg GhcRn a b) +deriving instance (Data a, Data b) => Data (HsArg GhcTc a b) + +-- deriving instance (DataIdLR p p) => Data (HsConDeclRecField p) +deriving instance Data (HsConDeclRecField GhcPs) +deriving instance Data (HsConDeclRecField GhcRn) +deriving instance Data (HsConDeclRecField GhcTc) + +-- deriving instance (DataIdLR p p, Typeable on) => Data (HsConDeclField on p) +deriving instance Data (HsConDeclField GhcPs) +deriving instance Data (HsConDeclField GhcRn) +deriving instance Data (HsConDeclField GhcTc) + +-- deriving instance (DataId p) => Data (FieldOcc p) +deriving instance Data (FieldOcc GhcPs) +deriving instance Data (FieldOcc GhcRn) +deriving instance Data (FieldOcc GhcTc) + +-- deriving instance (DataId name) => Data (ImportDecl name) +deriving instance Data (ImportDecl GhcPs) +deriving instance Data (ImportDecl GhcRn) +deriving instance Data (ImportDecl GhcTc) + +-- deriving instance (DataId name) => Data (IE name) +deriving instance Data (IE GhcPs) +deriving instance Data (IE GhcRn) +deriving instance Data (IE GhcTc) + +-- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name) +deriving instance Eq (IE GhcPs) +deriving instance Eq (IE GhcRn) +deriving instance Eq (IE GhcTc) + +-- --------------------------------------------------------------------- + +deriving instance Data HsThingRn +deriving instance Data XXExprGhcRn +deriving instance Data a => Data (WithUserRdr a) + +-- --------------------------------------------------------------------- + +deriving instance Data XXExprGhcTc +deriving instance Data XXPatGhcTc + +-- --------------------------------------------------------------------- + +deriving instance Data XViaStrategyPs + +-- --------------------------------------------------------------------- + +deriving instance (Typeable p, Data (Anno (IdGhcP p)), Data (IdGhcP p)) => Data (BooleanFormula (GhcPass p)) +--------------------------------------------------------------------- diff --git a/GHC/Hs/Lit.hs b/GHC/Hs/Lit.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Lit.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, OutputableBndrId + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Source-language literals +module GHC.Hs.Lit + ( module Language.Haskell.Syntax.Lit + , module GHC.Hs.Lit + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Hs.Expr( pprExpr ) + +import GHC.Data.FastString (unpackFS) +import GHC.Types.Basic (PprPrec(..), topPrec ) +import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) +import GHC.Types.SourceText +import GHC.Core.Type +import GHC.Utils.Misc (split) +import GHC.Utils.Outputable +import GHC.Utils.Panic (panic) +import GHC.Hs.Extension +import Language.Haskell.Syntax.Expr ( HsExpr ) +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Lit + +{- +************************************************************************ +* * +\subsection[HsLit]{Literals} +* * +************************************************************************ +-} + +type instance XHsChar (GhcPass _) = SourceText +type instance XHsCharPrim (GhcPass _) = SourceText +type instance XHsString (GhcPass _) = SourceText +type instance XHsMultilineString (GhcPass _) = SourceText +type instance XHsStringPrim (GhcPass _) = SourceText +type instance XHsInt (GhcPass _) = NoExtField +type instance XHsIntPrim (GhcPass _) = SourceText +type instance XHsWordPrim (GhcPass _) = SourceText +type instance XHsInt8Prim (GhcPass _) = SourceText +type instance XHsInt16Prim (GhcPass _) = SourceText +type instance XHsInt32Prim (GhcPass _) = SourceText +type instance XHsInt64Prim (GhcPass _) = SourceText +type instance XHsWord8Prim (GhcPass _) = SourceText +type instance XHsWord16Prim (GhcPass _) = SourceText +type instance XHsWord32Prim (GhcPass _) = SourceText +type instance XHsWord64Prim (GhcPass _) = SourceText +type instance XHsFloatPrim (GhcPass _) = NoExtField +type instance XHsDoublePrim (GhcPass _) = NoExtField + +type instance XXLit GhcPs = DataConCantHappen +type instance XXLit GhcRn = DataConCantHappen +type instance XXLit GhcTc = HsLitTc + +data HsLitTc + = HsInteger SourceText Integer Type + -- ^ Genuinely an integer; arises only + -- from TRANSLATION (overloaded + -- literals are done with HsOverLit) + | HsRat FractionalLit Type + -- ^ Genuinely a rational; arises only from + -- TRANSLATION (overloaded literals are + -- done with HsOverLit) +instance Eq HsLitTc where + (HsInteger _ x _) == (HsInteger _ y _) = x==y + (HsRat x _) == (HsRat y _) = x==y + _ == _ = False + +data OverLitRn + = OverLitRn { + ol_rebindable :: Bool, -- Note [ol_rebindable] + ol_from_fun :: LIdP GhcRn -- Note [Overloaded literal witnesses] + } + +data OverLitTc + = OverLitTc { + ol_rebindable :: Bool, -- Note [ol_rebindable] + ol_witness :: HsExpr GhcTc, -- Note [Overloaded literal witnesses] + ol_type :: Type } + +{- +Note [Overloaded literal witnesses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +During renaming, the coercion function needed for a given HsOverLit is +resolved according to the current scope and RebindableSyntax (see Note +[ol_rebindable]). The result of this resolution *before* type checking +is the coercion function such as 'fromInteger' or 'fromRational', +stored in the ol_from_fun field of OverLitRn. + +*After* type checking, the ol_witness field of the OverLitTc contains +the witness of the literal as HsExpr, such as (fromInteger 3) or +lit_78. This witness should replace the literal. Reason: it allows +commoning up of the fromInteger calls, which wouldn't be possible if +the desugarer made the application. + +The ol_type in OverLitTc records the type the overloaded literal is +found to have. +-} + +type instance XOverLit GhcPs = NoExtField +type instance XOverLit GhcRn = OverLitRn +type instance XOverLit GhcTc = OverLitTc + +pprXOverLit :: GhcPass p -> XOverLit (GhcPass p) -> SDoc +pprXOverLit GhcPs noExt = ppr noExt +pprXOverLit GhcRn OverLitRn{ ol_from_fun = from_fun } = ppr from_fun +pprXOverLit GhcTc OverLitTc{ ol_witness = witness } = pprExpr witness + +type instance XXOverLit (GhcPass _) = DataConCantHappen + +overLitType :: HsOverLit GhcTc -> Type +overLitType (OverLit OverLitTc{ ol_type = ty } _) = ty + +-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal +-- @ol@ needs to be parenthesized under precedence @p@. +hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool +hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv + where + go :: OverLitVal -> Bool + go (HsIntegral x) = p > topPrec && il_neg x + go (HsFractional x) = p > topPrec && fl_neg x + go (HsIsString {}) = False +hsOverLitNeedsParens _ (XOverLit { }) = False + +-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs +-- to be parenthesized under precedence @p@. +-- +-- See Note [Printing of literals in Core] in GHC.Types.Literal +-- for the reasoning. +hsLitNeedsParens :: forall x. IsPass x => PprPrec -> HsLit (GhcPass x) -> Bool +hsLitNeedsParens p = go + where + go (HsChar {}) = False + go (HsCharPrim {}) = False + go (HsString {}) = False + go (HsMultilineString {}) = False + go (HsStringPrim {}) = False + go (HsInt _ x) = p > topPrec && il_neg x + go (HsFloatPrim {}) = False + go (HsDoublePrim {}) = False + go (HsIntPrim {}) = False + go (HsInt8Prim {}) = False + go (HsInt16Prim {}) = False + go (HsInt32Prim {}) = False + go (HsInt64Prim {}) = False + go (HsWordPrim {}) = False + go (HsWord8Prim {}) = False + go (HsWord16Prim {}) = False + go (HsWord64Prim {}) = False + go (HsWord32Prim {}) = False + go (XLit x) = case ghcPass @x of + GhcTc -> case x of + (HsInteger _ x _) -> p > topPrec && x < 0 + (HsRat x _) -> p > topPrec && fl_neg x + + +-- | Convert a literal from one index type to another. +-- The constraint XXLit (GhcPass p)~DataConCantHappen means that once the +-- XLit constructor is inhabited, we can no longer go back to the case where +-- its not. In practice it just means you can't just convertLit to go from +-- (HsLit GhcTc) -> (HsLit GhcPs/GhcRn), while all other conversions are fine. +convertLit :: XXLit (GhcPass p)~DataConCantHappen => HsLit (GhcPass p) -> HsLit (GhcPass p') +convertLit (HsChar a x) = HsChar a x +convertLit (HsCharPrim a x) = HsCharPrim a x +convertLit (HsString a x) = HsString a x +convertLit (HsMultilineString a x) = HsMultilineString a x +convertLit (HsStringPrim a x) = HsStringPrim a x +convertLit (HsInt a x) = HsInt a x +convertLit (HsIntPrim a x) = HsIntPrim a x +convertLit (HsWordPrim a x) = HsWordPrim a x +convertLit (HsInt8Prim a x) = HsInt8Prim a x +convertLit (HsInt16Prim a x) = HsInt16Prim a x +convertLit (HsInt32Prim a x) = HsInt32Prim a x +convertLit (HsInt64Prim a x) = HsInt64Prim a x +convertLit (HsWord8Prim a x) = HsWord8Prim a x +convertLit (HsWord16Prim a x) = HsWord16Prim a x +convertLit (HsWord32Prim a x) = HsWord32Prim a x +convertLit (HsWord64Prim a x) = HsWord64Prim a x +convertLit (HsFloatPrim a x) = HsFloatPrim a x +convertLit (HsDoublePrim a x) = HsDoublePrim a x + +{- +Note [ol_rebindable] +~~~~~~~~~~~~~~~~~~~~ +The ol_rebindable field is True if this literal is actually +using rebindable syntax. Specifically: + + False iff ol_from_fun / ol_witness is the standard one + True iff ol_from_fun / ol_witness is non-standard + +Equivalently it's True if + a) RebindableSyntax is on + b) the witness for fromInteger/fromRational/fromString + that happens to be in scope isn't the standard one +-} + +-- Instance specific to GhcPs, need the SourceText +instance IsPass p => Outputable (HsLit (GhcPass p)) where + ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) + ppr (HsCharPrim st c) = pprWithSourceText st (pprPrimChar c) + ppr (HsString st s) = pprWithSourceText st (pprHsString s) + ppr (HsMultilineString st s) = + case st of + NoSourceText -> pprHsString s + SourceText src -> vcat $ map text $ split '\n' (unpackFS src) + ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) + ppr (HsInt _ i) + = pprWithSourceText (il_text i) (integer (il_value i)) + ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix + ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix + ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) + ppr (HsInt8Prim st i) = pprWithSourceText st (pprPrimInt8 i) + ppr (HsInt16Prim st i) = pprWithSourceText st (pprPrimInt16 i) + ppr (HsInt32Prim st i) = pprWithSourceText st (pprPrimInt32 i) + ppr (HsInt64Prim st i) = pprWithSourceText st (pprPrimInt64 i) + ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) + ppr (HsWord8Prim st w) = pprWithSourceText st (pprPrimWord8 w) + ppr (HsWord16Prim st w) = pprWithSourceText st (pprPrimWord16 w) + ppr (HsWord32Prim st w) = pprWithSourceText st (pprPrimWord32 w) + ppr (HsWord64Prim st w) = pprWithSourceText st (pprPrimWord64 w) + ppr (XLit x) = case ghcPass @p of + GhcTc -> case x of + (HsInteger st i _) -> pprWithSourceText st (integer i) + (HsRat f _) -> ppr f + +-- in debug mode, print the expression that it's resolved to, too +instance OutputableBndrId p + => Outputable (HsOverLit (GhcPass p)) where + ppr (OverLit {ol_val=val, ol_ext=ext}) + = ppr val <+> (whenPprDebug (parens (pprXOverLit (ghcPass @p) ext))) + +instance Outputable OverLitVal where + ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) + ppr (HsFractional f) = ppr f + ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) + +-- | pmPprHsLit pretty prints literals and is used when pretty printing pattern +-- match warnings. All are printed the same (i.e., without hashes if they are +-- primitive and not wrapped in constructors if they are boxed). This happens +-- mainly for too reasons: +-- * We do not want to expose their internal representation +-- * The warnings become too messy +pmPprHsLit :: forall p. IsPass p => HsLit (GhcPass p) -> SDoc +pmPprHsLit (HsChar _ c) = pprHsChar c +pmPprHsLit (HsCharPrim _ c) = pprHsChar c +pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s) +pmPprHsLit (HsMultilineString st s) = pprWithSourceText st (pprHsString s) +pmPprHsLit (HsStringPrim _ s) = pprHsBytes s +pmPprHsLit (HsInt _ i) = integer (il_value i) +pmPprHsLit (HsIntPrim _ i) = integer i +pmPprHsLit (HsWordPrim _ w) = integer w +pmPprHsLit (HsInt8Prim _ i) = integer i +pmPprHsLit (HsInt16Prim _ i) = integer i +pmPprHsLit (HsInt32Prim _ i) = integer i +pmPprHsLit (HsInt64Prim _ i) = integer i +pmPprHsLit (HsWord8Prim _ w) = integer w +pmPprHsLit (HsWord16Prim _ w) = integer w +pmPprHsLit (HsWord32Prim _ w) = integer w +pmPprHsLit (HsWord64Prim _ w) = integer w +pmPprHsLit (HsFloatPrim _ f) = ppr f +pmPprHsLit (HsDoublePrim _ d) = ppr d +pmPprHsLit (XLit x) = case ghcPass @p of + GhcTc -> case x of + (HsInteger _ i _) -> integer i + (HsRat f _) -> ppr f + +negateOverLitVal :: OverLitVal -> OverLitVal +negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) +negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) +negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" + +instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where + compare (OverLit _ val1) (OverLit _ val2) = val1 `compare` val2 + compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2 + compare _ _ = panic "Ord HsOverLit" + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) +instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where + (OverLit _ val1) == (OverLit _ val2) = val1 == val2 + (XOverLit val1) == (XOverLit val2) = val1 == val2 + _ == _ = panic "Eq HsOverLit" diff --git a/GHC/Hs/Pat.hs b/GHC/Hs/Pat.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Pat.hs @@ -0,0 +1,1176 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension + +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PatSyntax]{Abstract Haskell syntax---patterns} +-} + +module GHC.Hs.Pat ( + Pat(..), LPat, + isInvisArgPat, isInvisArgLPat, + isVisArgPat, isVisArgLPat, + EpAnnSumPat(..), + ConPatTc (..), + ConLikeP, + HsPatExpansion(..), + XXPatGhcTc(..), + + HsConPatDetails, hsConPatArgs, + HsRecFields(..), HsFieldBind(..), LHsFieldBind, + HsRecField, LHsRecField, + HsRecUpdField, LHsRecUpdField, + RecFieldsDotDot(..), + hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, + + mkPrefixConPat, mkCharLitPat, mkNilPat, + + isSimplePat, isPatSyn, + looksLazyPatBind, + isBangedLPat, + gParPat, patNeedsParens, parenthesizePat, + isIrrefutableHsPat, + + isBoringHsPat, + + collectEvVarsPat, collectEvVarsPats, + + pprParendLPat, pprConArgs, + pprLPat + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Pat +import Language.Haskell.Syntax.Expr ( HsExpr ) + +import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprUntypedSplice, HsUntypedSpliceResult(..)) + +-- friends: +import GHC.Hs.Binds +import GHC.Hs.Lit +import Language.Haskell.Syntax.Extension +import GHC.Parser.Annotation +import GHC.Hs.Extension +import GHC.Hs.Type +import GHC.Tc.Types.Evidence +import GHC.Types.Basic +import GHC.Types.SourceText +-- others: +import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) +import GHC.Builtin.Types +import GHC.Types.Var +import GHC.Types.Name.Reader +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Utils.Outputable +import GHC.Core.Type +import GHC.Types.SrcLoc +import GHC.Data.Bag -- collect ev vars from pats +import GHC.Types.Name + +import Data.Data +import qualified Data.List( map ) + +import qualified Data.List.NonEmpty as NE + +type instance XWildPat GhcPs = NoExtField +type instance XWildPat GhcRn = NoExtField +type instance XWildPat GhcTc = Type + +type instance XVarPat (GhcPass _) = NoExtField + +type instance XLazyPat GhcPs = EpToken "~" +type instance XLazyPat GhcRn = NoExtField +type instance XLazyPat GhcTc = NoExtField + +type instance XAsPat GhcPs = EpToken "@" +type instance XAsPat GhcRn = NoExtField +type instance XAsPat GhcTc = NoExtField + +type instance XParPat GhcPs = (EpToken "(", EpToken ")") +type instance XParPat GhcRn = NoExtField +type instance XParPat GhcTc = NoExtField + +type instance XBangPat GhcPs = EpToken "!" +type instance XBangPat GhcRn = NoExtField +type instance XBangPat GhcTc = NoExtField + +type instance XListPat GhcPs = AnnList () + -- After parsing, ListPat can refer to a built-in Haskell list pattern + -- or an overloaded list pattern. +type instance XListPat GhcRn = NoExtField + -- Built-in list patterns only. + -- After renaming, overloaded list patterns are expanded to view patterns. + -- See Note [Desugaring overloaded list patterns] +type instance XListPat GhcTc = Type + -- List element type, for use in hsPatType. + +type instance XTuplePat GhcPs = (EpaLocation, EpaLocation) +type instance XTuplePat GhcRn = NoExtField +type instance XTuplePat GhcTc = [Type] + +type instance XOrPat GhcPs = NoExtField +type instance XOrPat GhcRn = NoExtField +type instance XOrPat GhcTc = Type + +type instance XSumPat GhcPs = EpAnnSumPat +type instance XSumPat GhcRn = NoExtField +type instance XSumPat GhcTc = [Type] + +type instance XConPat GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}")) +type instance XConPat GhcRn = NoExtField +type instance XConPat GhcTc = ConPatTc + +type instance XViewPat GhcPs = TokRarrow +type instance XViewPat GhcRn = Maybe (HsExpr GhcRn) + -- The @HsExpr GhcRn@ gives an inverse to the view function. + -- This is used for overloaded lists in particular. + -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn. + +type instance XViewPat GhcTc = Type + -- Overall type of the pattern + -- (= the argument type of the view function), for hsPatType. + +type instance XSplicePat GhcPs = NoExtField +type instance XSplicePat GhcRn = HsUntypedSpliceResult (Pat GhcRn) -- See Note [Lifecycle of a splice] in GHC.Hs.Expr +type instance XSplicePat GhcTc = DataConCantHappen + +type instance XLitPat (GhcPass _) = NoExtField + +type instance XNPat GhcPs = EpToken "-" +type instance XNPat GhcRn = EpToken "-" +type instance XNPat GhcTc = Type + +type instance XNPlusKPat GhcPs = EpToken "+" +type instance XNPlusKPat GhcRn = NoExtField +type instance XNPlusKPat GhcTc = Type + +type instance XSigPat GhcPs = TokDcolon +type instance XSigPat GhcRn = NoExtField +type instance XSigPat GhcTc = Type + +type instance XEmbTyPat GhcPs = EpToken "type" +type instance XEmbTyPat GhcRn = NoExtField +type instance XEmbTyPat GhcTc = Type + +type instance XXPat GhcPs = DataConCantHappen +type instance XXPat GhcRn = HsPatExpansion (Pat GhcRn) (Pat GhcRn) + -- Original pattern and its desugaring/expansion. + -- See Note [Rebindable syntax and XXExprGhcRn]. +type instance XXPat GhcTc = XXPatGhcTc + -- After typechecking, we add extra constructors: CoPat and XXExprGhcRn. + -- XXExprGhcRn allows us to handle RebindableSyntax in pattern position: + -- see "XXExpr GhcTc" for the counterpart in expressions. + +type instance ConLikeP GhcPs = RdrName -- IdOccP GhcPs +type instance ConLikeP GhcRn = WithUserRdr Name -- IdOccP GhcRn +type instance ConLikeP GhcTc = ConLike + +type instance XHsRecFields GhcPs = NoExtField +type instance XHsRecFields GhcRn = NoExtField +type instance XHsRecFields GhcTc = NoExtField + +type instance XHsFieldBind _ = Maybe (EpToken "=") + +-- The specificity of an invisible pattern from the parser is always +-- SpecifiedSpec. The specificity field supports code generated when deriving +-- newtype or via; see Note [Inferred invisible patterns]. +type instance XInvisPat GhcPs = (EpToken "@", Specificity) +type instance XInvisPat GhcRn = Specificity +type instance XInvisPat GhcTc = Type + + +{- Note [Invisible binders in functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC Proposal #448 (section 1.5 Type arguments in lambda patterns) introduces +binders for invisible type arguments (@a-binders) in function equations and +lambdas, e.g. + + 1. {-# LANGUAGE TypeAbstractions #-} + id1 :: a -> a + id1 @t x = x :: t -- @t-binder on the LHS of a function equation + + 2. {-# LANGUAGE TypeAbstractions #-} + ex :: (Int8, Int16) + ex = higherRank (\ @a x -> maxBound @a - x ) + -- @a-binder in a lambda pattern in an argument + -- to a higher-order function + higherRank :: (forall a. (Num a, Bounded a) => a -> a) -> (Int8, Int16) + higherRank f = (f 42, f 42) + +In the AST, invisible patterns are represented as InvisPat constructor inside of Pat: + data Pat p + = ... + | InvisPat (LHsType p) + ... + +Just like `BangPat`, the `Pat` data type allows `InvisPat` to appear in +nested positions. But this is often not allowed; e.g. + + f @a x = rhs -- YES + f (@a,x) = rhs -- NO + + g = do { @a <- e1; e2 } -- NO + h x = case x of { @a -> rhs } -- NO + +Rather than excluding these things syntactically, we reject them in the renamer +(see `rn_pats_general`). This actually gives a better error message than we +would get if they were rejected in the parser. + +Each pattern is either visible (not prefixed with @) or invisible (prefixed with @): + f :: forall a. forall b -> forall c. Int -> ... + f @a b @c x = ... + +In this example, the arg-patterns are + 1. InvisPat @a -- in the type sig: forall a. + 2. VarPat b -- in the type sig: forall b -> + 3. InvisPat @c -- in the type sig: forall c. + 4. VarPat x -- in the type sig: Int -> + +Invisible patterns are always type patterns, i.e. they are matched with +forall-bound type variables in the signature. Consequently, those variables (and +their binders) are erased during compilation, having no effect on program +execution at runtime. + +Visible patterns, on the other hand, may be matched with ordinary function +arguments (Int ->) as well as required type arguments (forall b ->). This means +that a visible pattern may either be erased or retained, and we only find out in +the type checker, namely in tcMatchPats, where we match up all arg-patterns with +quantifiers from the type signature. + +In other words, invisible patterns are always /erased/, while visible patterns +are sometimes /erased/ and sometimes /retained/. + +The desugarer has no use for erased patterns, as the type checker generates +HsWrappers to bind the corresponding type variables. Erased patterns are simply +discarded inside tcMatchPats, where we know if visible pattern retained or erased. +-} + +-- --------------------------------------------------------------------- + +-- API Annotations types + +data EpAnnSumPat = EpAnnSumPat + { sumPatParens :: (EpaLocation, EpaLocation) + , sumPatVbarsBefore :: [EpToken "|"] + , sumPatVbarsAfter :: [EpToken "|"] + } deriving Data + +instance NoAnn EpAnnSumPat where + noAnn = EpAnnSumPat (noAnn, noAnn) [] [] + +-- --------------------------------------------------------------------- + +-- | Extension constructor for Pat, added after typechecking. +data XXPatGhcTc + = -- | Coercion Pattern (translation only) + -- + -- During desugaring a (CoPat co pat) turns into a cast with 'co' on the + -- scrutinee, followed by a match on 'pat'. + CoPat + { -- | Coercion Pattern + -- If co :: t1 ~ t2, p :: t2, + -- then (CoPat co p) :: t1 + co_cpt_wrap :: HsWrapper + + , -- | Why not LPat? Ans: existing locn will do + co_pat_inner :: Pat GhcTc + + , -- | Type of whole pattern, t1 + co_pat_ty :: Type + } + -- | Pattern expansion: original pattern, and desugared pattern, + -- for RebindableSyntax and other overloaded syntax such as OverloadedLists. + -- See Note [Rebindable syntax and XXExprGhcRn]. + | ExpansionPat (Pat GhcRn) (Pat GhcTc) + + +-- See Note [Rebindable syntax and XXExprGhcRn]. +data HsPatExpansion a b + = HsPatExpanded a b + deriving Data + +-- | This is the extension field for ConPat, added after typechecking +-- It adds quite a few extra fields, to support elaboration of pattern matching. +data ConPatTc + = ConPatTc + { -- | The universal arg types 1-1 with the universal + -- tyvars of the constructor/pattern synonym + -- Use (conLikeResTy pat_con cpt_arg_tys) to get + -- the type of the pattern + cpt_arg_tys :: [Type] + + , -- | Existentially bound type variables + -- in correctly-scoped order e.g. [k:* x:k] + cpt_tvs :: [TyVar] + + , -- | Ditto *coercion variables* and *dictionaries* + -- One reason for putting coercion variable here I think + -- is to ensure their kinds are zonked + cpt_dicts :: [EvVar] + + , -- | Bindings involving those dictionaries + cpt_binds :: TcEvBinds + + , -- | Extra wrapper to pass to the matcher + -- Only relevant for pattern-synonyms; + -- ignored for data cons + cpt_wrap :: HsWrapper + } + + +hsRecFields :: HsRecFields (GhcPass p) arg -> [IdGhcP p] +hsRecFields rbinds = Data.List.map (hsRecFieldSel . unLoc) (rec_flds rbinds) + +hsRecFieldsArgs :: HsRecFields (GhcPass p) arg -> [arg] +hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unLoc) (rec_flds rbinds) + +hsRecFieldSel :: HsRecField (GhcPass p) arg -> IdGhcP p +hsRecFieldSel = unLoc . foLabel . unLoc . hfbLHS + +hsRecFieldId :: HsRecField GhcTc arg -> Id +hsRecFieldId = hsRecFieldSel + +{- +************************************************************************ +* * +* Printing patterns +* * +************************************************************************ +-} + +instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ LocatedE RecFieldsDotDot) + => Outputable (HsRecFields p arg) where + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) + = braces (fsep (punctuate comma (map ppr flds))) + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> RecFieldsDotDot n) }) + = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) + where + dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) + +instance (Outputable p, OutputableBndr p, Outputable arg) + => Outputable (HsFieldBind p arg) where + ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg, + hfbPun = pun }) + = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg) + +instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where + ppr = pprPat + +-- See Note [Rebindable syntax and XXExprGhcRn]. +instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where + ppr (HsPatExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a) + +pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc +pprLPat (L _ e) = pprPat e + +-- | Print with type info if -dppr-debug is on +pprPatBndr :: OutputableBndr name => name -> SDoc +pprPatBndr var + = getPprDebug $ \case + True -> parens (pprBndr LambdaBind var) -- Could pass the site to pprPat + -- but is it worth it? + False -> pprPrefixOcc var + +pprParendLPat :: (OutputableBndrId p) + => PprPrec -> LPat (GhcPass p) -> SDoc +pprParendLPat p = pprParendPat p . unLoc + +pprParendPat :: forall p. OutputableBndrId p + => PprPrec + -> Pat (GhcPass p) + -> SDoc +pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_elab -> + if need_parens print_tc_elab pat + then parens (pprPat pat) + else pprPat pat + where + need_parens print_tc_elab pat + | GhcTc <- ghcPass @p + , XPat (CoPat {}) <- pat + = print_tc_elab + + | otherwise + = patNeedsParens p pat + -- For a CoPat we need parens if we are going to show it, which + -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper) + -- But otherwise the CoPat is discarded, so it + -- is the pattern inside that matters. Sigh. + +pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc +pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) +pprPat (WildPat _) = char '_' +pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat +pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat +pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@', + pprParendLPat appPrec pat] +pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat] +pprPat (ParPat _ pat) = parens (ppr pat) +pprPat (LitPat _ s) = ppr s +pprPat (NPat _ l Nothing _) = ppr l +pprPat (NPat _ l (Just _) _) = char '-' <> ppr l +pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr_n, char '+', ppr k] + where ppr_n = case ghcPass @p of + GhcPs -> ppr n + GhcRn -> ppr n + GhcTc -> ppr n +pprPat (SplicePat ext splice) = + case ghcPass @p of + GhcPs -> pprUntypedSplice True Nothing splice + GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) splice + GhcRn | HsUntypedSpliceTop _ p <- ext -> ppr p + GhcTc -> dataConCantHappen ext +pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (ListPat _ pats) = brackets (interpp'SP pats) +pprPat (OrPat _ pats) = pprWithSemis ppr (NE.toList pats) +pprPat (TuplePat _ pats bx) + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `MkSolo x`, not `(x)` + | [pat] <- pats + , Boxed <- bx + = hcat [text (mkTupleStr Boxed dataName 1), pprParendLPat appPrec pat] + | otherwise + = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) +pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) +pprPat (ConPat { pat_con = con + , pat_args = details + , pat_con_ext = ext + } + ) + = case ghcPass @p of + GhcPs -> pprUserCon (unLoc con) details + GhcRn -> pprUserCon (unLoc con) details + GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case + False -> pprUserCon (unLoc con) details + True -> + -- Tiresome; in 'GHC.Tc.Gen.Bind.tcRhs' we print out a typechecked Pat in an + -- error message, and we want to make sure it prints nicely + ppr con + <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) + , ppr binds ]) + <+> pprConArgs details + where ConPatTc { cpt_tvs = tvs + , cpt_dicts = dicts + , cpt_binds = binds + } = ext +pprPat (EmbTyPat _ tp) = text "type" <+> ppr tp +pprPat (InvisPat x tp) = char '@' <> delimit (ppr tp) + where + delimit + | inferred = braces + | needs_parens = parens + | otherwise = id + inferred = case ghcPass @p of + GhcPs -> snd x == InferredSpec + GhcRn -> x == InferredSpec + GhcTc -> False + needs_parens = hsTypeNeedsParens appPrec $ unLoc $ hstp_body tp + +pprPat (XPat ext) = case ghcPass @p of + GhcRn -> case ext of + HsPatExpanded orig _ -> pprPat orig + GhcTc -> case ext of + CoPat co pat _ -> + pprHsWrapper co $ \parens -> + if parens + then pprParendPat appPrec pat + else pprPat pat + ExpansionPat orig _ -> pprPat orig + +pprUserCon :: (OutputableBndr con, OutputableBndrId p, + Outputable (Anno (IdGhcP p))) + => con -> HsConPatDetails (GhcPass p) -> SDoc +pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 +pprUserCon c details = pprPrefixOcc c <+> pprConArgs details + +pprConArgs :: (OutputableBndrId p, + Outputable (Anno (IdGhcP p))) + => HsConPatDetails (GhcPass p) -> SDoc +pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats) +pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 + , pprParendLPat appPrec p2 ] +pprConArgs (RecCon rpats) = ppr rpats + +{- +************************************************************************ +* * +* Building patterns +* * +************************************************************************ +-} + +mkPrefixConPat :: DataCon -> + [LPat GhcTc] -> [Type] -> LPat GhcTc +-- Make a vanilla Prefix constructor pattern +mkPrefixConPat dc pats tys + = noLocA $ ConPat { pat_con = noLocA (RealDataCon dc) + , pat_args = PrefixCon pats + , pat_con_ext = ConPatTc + { cpt_tvs = [] + , cpt_dicts = [] + , cpt_binds = emptyTcEvBinds + , cpt_arg_tys = tys + , cpt_wrap = idHsWrapper + } + } + +mkNilPat :: Type -> LPat GhcTc +mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] + +mkCharLitPat :: SourceText -> Char -> LPat GhcTc +mkCharLitPat src c = mkPrefixConPat charDataCon + [noLocA $ LitPat noExtField (HsCharPrim src c)] [] + +{- +************************************************************************ +* * +* Predicates for checking things about pattern-lists in EquationInfo * +* * +************************************************************************ + +\subsection[Pat-list-predicates]{Look for interesting things in patterns} + +Unlike in the Wadler chapter, where patterns are either ``variables'' +or ``constructors,'' here we distinguish between: +\begin{description} +\item[unfailable:] +Patterns that cannot fail to match: variables, wildcards, and lazy +patterns. + +These are the irrefutable patterns; the two other categories +are refutable patterns. + +\item[constructor:] +A non-literal constructor pattern (see next category). + +\item[literal patterns:] +At least the numeric ones may be overloaded. +\end{description} + +A pattern is in {\em exactly one} of the above three categories; `as' +patterns are treated specially, of course. + +The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. +-} + +isBangedLPat :: LPat (GhcPass p) -> Bool +isBangedLPat = isBangedPat . unLoc + +isBangedPat :: Pat (GhcPass p) -> Bool +isBangedPat (ParPat _ p) = isBangedLPat p +isBangedPat (BangPat {}) = True +isBangedPat _ = False + +looksLazyPatBind :: HsBind GhcTc -> Bool +-- Returns True of anything *except* +-- a StrictHsBind (as above) or +-- a VarPat +-- In particular, returns True of a pattern binding with a compound pattern, like (I# x) +-- Looks through AbsBinds +looksLazyPatBind (PatBind { pat_lhs = p }) + = looksLazyLPat p +looksLazyPatBind (XHsBindsLR (AbsBinds { abs_binds = binds })) + = any (looksLazyPatBind . unLoc) binds +looksLazyPatBind _ + = False + +looksLazyLPat :: LPat (GhcPass p) -> Bool +looksLazyLPat = looksLazyPat . unLoc + +looksLazyPat :: Pat (GhcPass p) -> Bool +looksLazyPat (ParPat _ p) = looksLazyLPat p +looksLazyPat (AsPat _ _ p) = looksLazyLPat p +looksLazyPat (BangPat {}) = False +looksLazyPat (VarPat {}) = False +looksLazyPat (WildPat {}) = False +looksLazyPat _ = True + +{- +Note [-XStrict and irrefutability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -XStrict is enabled the rules for irrefutability are slightly modified. +Specifically, the pattern in a program like + + do ~(Just hi) <- expr + +cannot be considered irrefutable. The ~ here merely disables the bang that +-XStrict would usually apply, rendering the program equivalent to the following +without -XStrict + + do Just hi <- expr + +To achieve make this pattern irrefutable with -XStrict the user would rather +need to write + + do ~(~(Just hi)) <- expr + +Failing to account for this resulted in #19027. To fix this isIrrefutableHsPat +takes care to check for two the irrefutability of the inner pattern when it +encounters a LazyPat and -XStrict is enabled. + +See also Note [decideBangHood] in GHC.HsToCore.Utils. +-} + +-- | @isIrrefutableHsPat p@ is true if matching against @p@ cannot fail +-- in the sense of falling through to the next pattern. +-- (NB: this is not quite the same as the (silly) defn +-- in 3.17.2 of the Haskell 98 report.) +-- +-- If isIrrefutableHsPat returns 'True', the pattern is definitely irrefutable. +-- +-- However, isIrrefutableHsPat returns 'False' if it's in doubt. It's a +-- best effort guess with the information we have available: +-- +-- - we sometimes call 'isIrrefutableHsPat' from the renamer, in which case +-- we don't have type information to hand. This means we can't properly +-- handle GADTs, nor the result TyCon of COMPLETE pragmas. +-- - even when calling 'isIrrefutableHsPat' in the typechecker, we don't keep +-- track of any long distance information like the pattern-match checker does. +isIrrefutableHsPat + :: forall p + . IsPass p + => Bool -- ^ Are we in a @-XStrict@ context? + -- See Note [-XStrict and irrefutability] + -> (ConLikeP (GhcPass p) -> Bool) -- ^ How to check whether the 'ConLike' in a + -- 'ConPat' pattern is irrefutable + -> LPat (GhcPass p) -- ^ The (located) pattern to check + -> Bool -- Is it irrefutable? +isIrrefutableHsPat is_strict irref_conLike pat = go (unLoc pat) + where + goL (L _ p) = go p + + go :: Pat (GhcPass p) -> Bool + go (WildPat {}) = True + go (VarPat {}) = True + go (LazyPat _ p') + | is_strict + = isIrrefutableHsPat False irref_conLike p' + | otherwise = True + go (BangPat _ pat) = goL pat + go (ParPat _ pat) = goL pat + go (AsPat _ _ pat) = goL pat + go (ViewPat _ _ pat) = goL pat + go (SigPat _ pat _) = goL pat + go (TuplePat _ pats _) = all goL pats + go (OrPat _ pats) = any goL pats -- This is simplistic; see Note [Irrefutable or-patterns] + go (SumPat {}) = False -- See Note [Unboxed sum patterns aren't irrefutable] + go (ListPat {}) = False + + -- See Note [Irrefutability of ConPat] + go (ConPat { pat_con = L _ con, pat_args = details }) + = irref_conLike con + && all goL (hsConPatArgs details) + go (LitPat {}) = False + go (NPat {}) = False + go (NPlusKPat {}) = False + + -- We conservatively assume that no TH splices are irrefutable + -- since we cannot know until the splice is evaluated. + go (SplicePat {}) = False + + -- The behavior of this case is unimportant, as GHC will throw an error shortly + -- after reaching this case for other reasons (see TcRnIllegalTypePattern). + go (EmbTyPat {}) = True + go (InvisPat {}) = True + + go (XPat ext) = case ghcPass @p of + GhcRn -> case ext of + HsPatExpanded _ pat -> go pat + GhcTc -> case ext of + CoPat _ pat _ -> go pat + ExpansionPat _ pat -> go pat + +-- | Is the pattern any of combination of: +-- +-- - (pat) +-- - pat :: Type +-- - ~pat +-- - !pat +-- - x (variable) +isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x)) +isSimplePat p = case unLoc p of + ParPat _ x -> isSimplePat x + SigPat _ x _ -> isSimplePat x + LazyPat _ x -> isSimplePat x + BangPat _ x -> isSimplePat x + VarPat _ x -> Just (unLoc x) + _ -> Nothing + +-- | Is this pattern boring from the perspective of pattern-match checking, +-- i.e. introduces no new pieces of long-distance information +-- which could influence pattern-match checking? +-- +-- See Note [Boring patterns]. +isBoringHsPat :: forall p. OutputableBndrId p => LPat (GhcPass p) -> Bool +-- NB: it's always safe to return 'False' in this function; that just means +-- performing potentially-redundant pattern-match checking. +isBoringHsPat = goL + where + goL :: forall p. OutputableBndrId p => LPat (GhcPass p) -> Bool + goL = go . unLoc + + go :: forall p. OutputableBndrId p => Pat (GhcPass p) -> Bool + go = \case + WildPat {} -> True + VarPat {} -> True + LazyPat {} -> True + BangPat _ pat -> goL pat + ParPat _ pat -> goL pat + AsPat {} -> False -- the pattern x@y links x and y together, + -- which is a nontrivial piece of information + ViewPat _ _ pat -> goL pat + SigPat _ pat _ -> goL pat + TuplePat _ pats _ -> all goL pats + SumPat _ pat _ _ -> goL pat + ListPat _ pats -> all goL pats + ConPat { pat_con = con, pat_args = details } + -> case ghcPass @p of + GhcPs -> False -- conservative + GhcRn -> False -- conservative + GhcTc + | isVanillaConLike (unLoc con) + -> all goL (hsConPatArgs details) + | otherwise + -- A pattern match on a GADT constructor can introduce + -- type-level information (for example, T18572). + -> False + OrPat _ pats -> all goL pats + LitPat {} -> True + NPat {} -> True + NPlusKPat {} -> True + SplicePat {} -> False + EmbTyPat {} -> True + InvisPat {} -> True + XPat ext -> + case ghcPass @p of + GhcRn -> case ext of + HsPatExpanded _ pat -> go pat + GhcTc -> case ext of + CoPat _ pat _ -> go pat + ExpansionPat _ pat -> go pat + +isPatSyn :: LPat GhcTc -> Bool +isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True +isPatSyn _ = False + +{- Note [Irrefutability of ConPat] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A constructor pattern `ConPat { pat_con, pat_args }` is irrefutable under two +conditions: + + Irref-ConLike: the constructor, pat_con, is itself irrefutable. + Irref-args : all of the argument patterns, pat_args, are irrefutable. + +The (Irref-ConLike) condition can be stated as follows: + + Irref-DataCon: a DataCon is irrefutable iff it is the only constructor of its + parent type constructor. + Irref-PatSyn: a PatSyn is irrefutable iff there is a COMPLETE pragma + containing this PatSyn as its sole member. + +To understand this, let's consider some simple examples: + + data A = MkA Int Bool + data BC = B Int | C + + pattern P :: Maybe Int -> BC + pattern P mb_i <- ( ( \ case { B i -> Just i; C -> Nothing } ) -> mb_i ) + {-# COMPLETE P #-} + +In this case: + + - the pattern 'A p1 p2' (for patterns 'p1 :: Int', 'p2 :: Bool') is irrefutable + precisely when both 'p1' and 'p2' are irrefutable (this is the same as + irrefutability of tuple patterns); + - neither of the patterns 'B p' (for any pattern 'p :: Int') or 'C' are irrefutable, + because the parent type constructor 'BC' contains more than one data constructor, + - the pattern 'P q', for a pattern 'q :: Maybe Int', is irrefutable precisely + when 'q' is irrefutable, due to the COMPLETE pragma on 'P'. + +Wrinkle [Irrefutability and COMPLETE pragma result TyCons] + + There is one subtlety in the Irref-PatSyn condition: COMPLETE pragmas may + optionally specify a result TyCon, as explained in Note [Implementation of COMPLETE pragmas] + in GHC.HsToCore.Pmc.Solver. + + So, for a COMPLETE pragma with a result TyCon, we would need to compute + 'completeMatchAppliesAtType' to ensure that the COMPLETE pragma is indeed + applicable. Doing so is not so straightforward in 'isIrrefutableHsPat', for + a couple of reasons: + + 1. 'isIrrefutableHsPat' is called from within the renamer, which means + we don't have the appropriate 'Type' to hand, + 2. Even when 'isIrrefutableHsPat' is called from within the typechecker, + computing 'completeMatchAppliesAtType' for a 'ConPat' which might be + nested deep inside the top-level call, such as + + ( ( _ , P (x :: Int) ) :: ( Int, Int ) + + would require keeping track of types as we recur in 'isIrrefutableHsPat', + which would be much more involved and require duplicating code from + the pattern match checker (it performs this check using the notion + of "match variables", which we don't have in the typechecker). + +Note [Irrefutable or-patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When is an or-pattern ( p_1 ; ... ; p_n ) irrefutable? It certainly suffices +that individual pattern p_i is irrefutable, but it isn't necessary. + +For example, with the datatype definition + + data ABC = A | B | C + +the or-pattern ( B ; C ; A ) is irrefutable. Similarly, one can take into +account COMPLETE pragmas, e.g. (P ; R ; Q) is irrefutable in the presence of +{-# COMPLETE P, Q, R #-}. This would extend Note [Irrefutability of ConPat] to +the case of disjunctions of constructor patterns. + +For now, the function 'isIrrefutableHsPat' does not take into account these +additional complications, and considers an or-pattern irrefutable precisely when +any of the summands are irrefutable. This pessimistic behaviour is OK: the contract +of 'isIrrefutableHsPat' is that it can only return 'True' for definitely irrefutable +patterns, but may conservatively return 'False' in other cases. + +The justification for this design choice is as follows: + + 1. Producing the correct answer in all cases would be rather difficult, + for example for a complex pattern such as ( P ; !( R ; S ; ( Q :: Ty ) ) ). + 2. Irrefutable or-patterns aren't particularly common or useful, given that + (currently) or-patterns aren't allowed to bind variables. + +Note [Unboxed sum patterns aren't irrefutable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as +patterns. A simple example that demonstrates this is from #14228: + + pattern Just' x = (# x | #) + pattern Nothing' = (# | () #) + + foo x = case x of + Nothing' -> putStrLn "nothing" + Just' -> putStrLn "just" + +In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable, +as does not match an unboxed sum value of the same arity—namely, (# | y #) +(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the +minimum unboxed sum arity is 2. + +Failing to mark unboxed sum patterns as non-irrefutable would cause the Just' +case in foo to be unreachable, as GHC would mistakenly believe that Nothing' +is the only thing that could possibly be matched! + +Note [Boring patterns] +~~~~~~~~~~~~~~~~~~~~~~ +A pattern is called boring when no new information is gained upon successfully +matching on the pattern. + +Some examples of boring patterns: + + - x, for a variable x. We learn nothing about x upon matching this pattern. + - Just y. This pattern can fail, but if it matches, we don't learn anything + about y. + +Some examples of non-boring patterns: + + - x@(Just y). A match on this pattern introduces the fact that x is headed + by the constructor Just, which means that a subsequent pattern match such as + + case x of { Just z -> ... } + + should not be marked as incomplete. + - a@b. Matching on this pattern introduces a relation between 'a' and 'b', + which means that we shouldn't emit any warnings in code of the form + + case a of + True -> case b of { True -> .. } -- no warning here! + False -> ... + - GADT patterns. For example, with the GADT + + data G i where { MkGInt :: G Int } + + a match on the pattern 'MkGInt' introduces type-level information: + + foo :: G i -> i + foo MkGInt = 3 + + Here we learn that i ~ Int after matching on 'MkGInt', so this pattern + is not boring. + +When a pattern is boring, and we are only interested in additional long-distance +information (not whether the pattern itself is fallible), we can skip pattern-match +checking entirely. Doing this saves about 10% allocations in test T11195. + +This happens when we are checking pattern-matches in do-notation, for example: + + do { x@(Just y) <- z + ; ... + ; return $ case x of { Just w -> ... } } + +Here we *do not* want to emit a pattern-match warning on the first line for the +incomplete pattern-match, as incompleteness inside do-notation is handled +using MonadFail. However, we still want to propagate the fact that x is headed +by the 'Just' constructor, to avoid a pattern-match warning on the last line. + +Note [Implementation of OrPatterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes the implementation of the extension -XOrPatterns. + +* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0522-or-patterns.rst +* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/522 and others + +Parser +------ +We parse an or-pattern `pat_1; ...; pat_k` into `OrPat [pat_1, ..., pat_k]`, +where `OrPat` is a constructor of `Pat` in Language.Haskell.Syntax.Pat. +We occasionally refer to any of the `pat_k` as "pattern alternatives" below. +The changes to the parser are as outlined in Section 8.1 of the proposal. +The main productions are + + orpats -> exp | exp ';' orpats + aexp2 -> '(' orpats ')' + pat -> orpats + +Renamer and typechecker +----------------------- +The typing rule for or-patterns in terms of pattern types is + + Γ0, Σ0 ⊢ pat_i : τ ⤳ Γ0,Σi,Ψi + -------------------------------------------- + Γ0, Σ0 ⊢ ( pat_1; ...; pat_n ) : τ ⤳ Γ0,Σ0,∅ + +(See the proposal for what a pattern type `Γ, Σ ⊢ pat : τ ⤳ Γ,Σ,Ψ` is.) +The main points + + * None of the patterns may bind any variables, hence the same Γ0 in both input + and output. + * Any Given constraints bound by the pattern are discarded: the rule discards + the Σi returned by each pattern. + * Similarly any existentials Ψi bound by the pattern are discarded. + +In GHC.Rename.Pat.rnPatAndThen, we reject visible term and type binders (i.e. +concerning Γ0). + +Regarding the Givens Σi and existenials Ψi (i.e. invisible type binders) +introduced by the pattern alternatives `pat_i`, we discard them in +GHC.Tc.Gen.Pats.tc_pat in a manner similar to LazyPats; +see Note [Hopping the LIE in lazy patterns]. + +Why is it useful to allow Σi and Ψi only to discard them immediately after? +Consider + + data T a where MkT :: forall a x. Num a => x -> T a + foo :: T a -> a + foo (MkT{}; MkT{}) = 3 + +We do want to allow matching on MkT{} in or-patterns, despite them invisibly +binding an existential type variable `x` and a new Given constraint `Num a`. +Clearly, `x` must be dead in the RHS of foo, because there is no field binder +that brings it to life, so no harm done. +But we must be careful not to solve the `Num a` Wanted constraint in the RHS of +foo with the Given constraint from the pattern alternatives, hence we are +Hopping the LIE. + +Desugarer +--------- +The desugaring of or-patterns is complicated by the fact that we have to avoid +exponential code blowup. Consider + f (LT; GT) (EQ; GT) = rhs1 + f _ _ = rhs2 +The naïve desugaring of or-patterns would explode every or-pattern, thus + f LT EQ = rhs1 + f LT GT = rhs1 + f GT EQ = rhs1 + f GT GT = rhs1 + f _ _ = rhs2 +which leads to an exponential number of copies of `rhs1`. +Our current strategy, implemented in GHC.HsToCore.Match.tidy1, is to +desugar to LambdaCase and ViewPatterns, + f ((\case LT -> True; GT -> True; _ -> False) -> True) + ((\case EQ -> True; GT -> True; _ -> False) -> True) + = rhs1 + f _ _ = rhs2 +The existing code for ViewPatterns makes sure that we do not duplicate `rhs1` +and the Simplifier will take care to turn this into efficient code. + +Pattern-match checker +--------------------- +The changes to the pattern-match checker are described in detail in Section 4.9 +of the 2024 revision of the "Lower Your Guards" paper. +What follows is a brief summary of that change. + +The pattern-match checker desugars patterns as well, into syntactic variants of +*guard trees* such as `PmMatch`, describing a single Match `f ps | grhss`. +It used to be that each such guard trees nicely captured the effects of pattern +matching `ps` in a conjunctive list of `PmGrd`s, each of which refines +the set of Nablas that reach the RHS of the clause. +`PmGrd` is the heart of the Lower Your Guards approach: it is compositional, +simple, and *non-recursive*, unlike or-patterns! +Conjunction is implemented with the `...Pmc.Check.leftToRight` combinator. +But to desugar or-patterns, we need to compose with `Pmc.Check.topToBottom` +to model first match semantics! +This was previously impossible in the pattern fragment, and indeed is +incompatible with the simple "list of `PmGrd`s" desugaring of patterns. + +So our solution is to generalise "sequence of `PmGrd`" into a series-parallel +graph `GrdDag`, a special kind of DAG, where "series" corresponds to +left-to-right sequence and "parallel" corresponds to top-to-bottom or-pattern +alternatives. Example + + f (LT; GT) True (EQ; GT) = rhs + +desugars to + + /- LT <- x -\ /- EQ <- z -\ + . . True <- y . .-> rhs + \- GT <- x ./ \- GT <- z -/ + +Branching is GdAlt and models first-match semantics of or-patterns, and +sequencing is GdSeq. + +We must take care of exponential explosion of Covered sets for long matches like + g (LT; GT) (LT; GT) ... True = 1 +Fortunately, we can build on our existing throttling mechanism; +see Note [Countering exponential blowup] in GHC.HsToCore.Pmc.Check. +-} + + +-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs +-- parentheses under precedence @p@. +patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool +patNeedsParens p = go @p + where + -- Remark: go needs to be polymorphic, as we call it recursively + -- at a different GhcPass (see the case for GhcTc XPat below). + go :: forall q. IsPass q => Pat (GhcPass q) -> Bool + go (NPlusKPat {}) = p > opPrec + go (OrPat {}) = p > topPrec + go (SplicePat {}) = False + go (ConPat { pat_args = ds }) + = conPatNeedsParens p ds + go (SigPat {}) = p >= sigPrec + go (ViewPat {}) = True + go (EmbTyPat {}) = True + go (InvisPat{}) = False + go (XPat ext) = case ghcPass @q of + GhcRn -> case ext of + HsPatExpanded orig _ -> go orig + GhcTc -> case ext of + CoPat _ inner _ -> go inner + ExpansionPat orig _ -> go orig + -- ^^^^^^^ + -- NB: recursive call of go at a different GhcPass. + go (WildPat {}) = False + go (VarPat {}) = False + go (LazyPat {}) = False + go (BangPat {}) = False + go (ParPat {}) = False + go (AsPat {}) = False + -- Special-case unary boxed tuple applications so that they are + -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612) + -- See Note [One-tuples] in GHC.Builtin.Types + go (TuplePat _ [_] Boxed) + = p >= appPrec + go (TuplePat{}) = False + go (SumPat {}) = False + go (ListPat {}) = False + go (LitPat _ l) = hsLitNeedsParens p l + go (NPat _ lol _ _) = hsOverLitNeedsParens p (unLoc lol) + +-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ +-- needs parentheses under precedence @p@. +conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool +conPatNeedsParens p = go + where + go (PrefixCon args) = p >= appPrec && not (null args) + go (InfixCon {}) = p >= opPrec -- type args should be empty in this case + go (RecCon {}) = False + + +-- | Parenthesize a pattern without token information +gParPat :: forall p. IsPass p => LPat (GhcPass p) -> Pat (GhcPass p) +gParPat pat = ParPat x pat + where + x = case ghcPass @p of + GhcPs -> noAnn + GhcRn -> noExtField + GhcTc -> noExtField + +-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and +-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. +parenthesizePat :: IsPass p + => PprPrec + -> LPat (GhcPass p) + -> LPat (GhcPass p) +parenthesizePat p lpat@(L loc pat) + | patNeedsParens p pat = L loc (gParPat lpat) + | otherwise = lpat + + +{- +% Collect all EvVars from all constructor patterns +-} + +-- May need to add more cases +collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar +collectEvVarsPats = unionManyBags . map collectEvVarsPat + +collectEvVarsLPat :: LPat GhcTc -> Bag EvVar +collectEvVarsLPat = collectEvVarsPat . unLoc + +collectEvVarsPat :: Pat GhcTc -> Bag EvVar +collectEvVarsPat pat = + case pat of + LazyPat _ p -> collectEvVarsLPat p + AsPat _ _ p -> collectEvVarsLPat p + ParPat _ p -> collectEvVarsLPat p + BangPat _ p -> collectEvVarsLPat p + ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps + TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps + OrPat _ ps -> unionManyBags $ map collectEvVarsLPat (NE.toList ps) + SumPat _ p _ _ -> collectEvVarsLPat p + ConPat + { pat_args = args + , pat_con_ext = ConPatTc + { cpt_dicts = dicts + } + } + -> unionBags (listToBag dicts) + $ unionManyBags + $ map collectEvVarsLPat + $ hsConPatArgs args + SigPat _ p _ -> collectEvVarsLPat p + XPat ext -> case ext of + CoPat _ p _ -> collectEvVarsPat p + ExpansionPat _ p -> collectEvVarsPat p + _other_pat -> emptyBag + +{- +************************************************************************ +* * +\subsection{Anno instances} +* * +************************************************************************ +-} + +type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA +type instance Anno (HsOverLit (GhcPass p)) = EpAnnCO +type instance Anno ConLike = SrcSpanAnnN +type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA +type instance Anno RecFieldsDotDot = EpaLocation diff --git a/GHC/Hs/Pat.hs-boot b/GHC/Hs/Pat.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Hs/Pat.hs-boot @@ -0,0 +1,17 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension + +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable + +module GHC.Hs.Pat where + +import GHC.Utils.Outputable +import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) + +import Language.Haskell.Syntax.Pat + +instance (OutputableBndrId p) => Outputable (Pat (GhcPass p)) + +pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc diff --git a/GHC/Hs/Specificity.hs b/GHC/Hs/Specificity.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Specificity.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module GHC.Hs.Specificity where + +import Prelude +import Control.DeepSeq (NFData(..)) + +import GHC.Utils.Outputable +import GHC.Utils.Binary + +import Language.Haskell.Syntax.Specificity + +{- ********************************************************************* +* * +* ForAllTyFlag +* * +********************************************************************* -} + +instance Outputable ForAllTyFlag where + ppr Required = text "[req]" + ppr Specified = text "[spec]" + ppr Inferred = text "[infrd]" + +instance Binary Specificity where + put_ bh SpecifiedSpec = putByte bh 0 + put_ bh InferredSpec = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return SpecifiedSpec + _ -> return InferredSpec + +instance Binary ForAllTyFlag where + put_ bh Required = putByte bh 0 + put_ bh Specified = putByte bh 1 + put_ bh Inferred = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> return Required + 1 -> return Specified + _ -> return Inferred + +instance NFData Specificity where + rnf SpecifiedSpec = () + rnf InferredSpec = () +instance NFData ForAllTyFlag where + rnf (Invisible spec) = rnf spec + rnf Required = () + diff --git a/GHC/Hs/Stats.hs b/GHC/Hs/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Stats.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Statistics for per-module compilations +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- + +module GHC.Hs.Stats ( ppSourceStats ) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Types.SrcLoc + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import Data.Char + +-- | Source Statistics +ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc +ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = imports, hsmodDecls = ldecls })) + = (if short then hcat else vcat) + (map pp_val + [("ExportAll ", export_all), -- 1 if no export list + ("ExportDecls ", export_ds), + ("ExportModules ", export_ms), + ("Imports ", imp_no), + (" ImpSafe ", imp_safe), + (" ImpQual ", imp_qual), + (" ImpAs ", imp_as), + (" ImpAll ", imp_all), + (" ImpPartial ", imp_partial), + (" ImpHiding ", imp_hiding), + ("FixityDecls ", fixity_sigs), + ("DefaultDecls ", default_ds), + ("TypeDecls ", type_ds), + ("DataDecls ", data_ds), + ("NewTypeDecls ", newt_ds), + ("TypeFamilyDecls ", type_fam_ds), + ("DataConstrs ", data_constrs), + ("DataDerivings ", data_derivs), + ("ClassDecls ", class_ds), + ("ClassMethods ", class_method_ds), + ("DefaultMethods ", default_method_ds), + ("InstDecls ", inst_ds), + ("InstMethods ", inst_method_ds), + ("InstType ", inst_type_ds), + ("InstData ", inst_data_ds), + ("TypeSigs ", bind_tys), + ("ClassOpSigs ", generic_sigs), + ("ValBinds ", val_bind_ds), + ("FunBinds ", fn_bind_ds), + ("PatSynBinds ", patsyn_ds), + ("InlineMeths ", method_inlines), + ("InlineBinds ", bind_inlines), + ("SpecialisedMeths ", method_specs), + ("SpecialisedBinds ", bind_specs) + ]) + where + decls = map unLoc ldecls + + pp_val (_, 0) = empty + pp_val (str, n) + | not short = hcat [text str, int n] + | otherwise = hcat [text (trim str), equals, int n, semi] + + trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) + + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) + = count_sigs [d | SigD _ d <- decls] + -- NB: this omits fixity decls on local bindings and + -- in class decls. ToDo + + tycl_decls = [d | TyClD _ d <- decls] + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = + countTyClDecls tycl_decls + + inst_decls = [d | InstD _ d <- decls] + inst_ds = length inst_decls + default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls + val_decls = [d | ValD _ d <- decls] + + real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } + n_exports = length real_exports + export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True + ; _ -> False}) + real_exports + export_ds = n_exports - export_ms + export_all = case exports of { Nothing -> 1; _ -> 0 } + + (val_bind_ds, fn_bind_ds, patsyn_ds) + = sum3 (map count_bind val_decls) + + (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) + = sum7 (map import_info imports) + (data_constrs, data_derivs) + = sum2 (map data_info tycl_decls) + (class_method_ds, default_method_ds) + = sum2 (map class_info tycl_decls) + (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) + = sum5 (map inst_info inst_decls) + + count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) + count_bind (PatBind {}) = (0,1,0) + count_bind (FunBind {}) = (0,1,0) + count_bind (PatSynBind {}) = (0,0,1) + count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) + + count_sigs sigs = sum5 (map sig_info sigs) + + sig_info (FixSig {}) = (1,0,0,0,0) + sig_info (TypeSig {}) = (0,1,0,0,0) + sig_info (SpecSig {}) = (0,0,1,0,0) + sig_info (SpecSigE {}) = (0,0,1,0,0) + sig_info (InlineSig {}) = (0,0,0,1,0) + sig_info (ClassOpSig {}) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) + + import_info :: LImportDecl GhcPs -> (Int, Int, Int, Int, Int, Int, Int) + import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclImportList = spec })) + = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) + + safe_info False = 0 + safe_info True = 1 + qual_info NotQualified = 0 + qual_info _ = 1 + as_info Nothing = 0 + as_info (Just _) = 1 + spec_info Nothing = (0,0,0,0,1,0,0) + spec_info (Just (Exactly, _)) = (0,0,0,0,0,1,0) + spec_info (Just (EverythingBut, _)) = (0,0,0,0,0,0,1) + + data_info (DataDecl { tcdDataDefn = dd :: HsDataDefn GhcPs }) + | HsDataDefn { dd_cons = cs, dd_derivs = derivs} <- dd + = ( length cs + , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) + 0 derivs ) + data_info _ = (0,0) + + class_info decl@(ClassDecl {}) + = (classops, addpr (sum3 (map count_bind methods))) + where + methods = map unLoc $ tcdMeths decl + (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl)) + class_info _ = (0,0) + + inst_info :: InstDecl GhcPs -> (Int, Int, Int, Int, Int) + inst_info (TyFamInstD {}) = (0,0,0,1,0) + inst_info (DataFamInstD {}) = (0,0,0,0,1) + inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths + , cid_sigs = inst_sigs + , cid_tyfam_insts = ats + , cid_datafam_insts = adts } }) + = case count_sigs (map unLoc inst_sigs) of + (_,_,ss,is,_) -> + (addpr (sum3 (map count_bind methods)), + ss, is, length ats, length adts) + where + methods = map unLoc inst_meths + + -- TODO: use Sum monoid + addpr :: (Int,Int,Int) -> Int + sum2 :: [(Int, Int)] -> (Int, Int) + sum3 :: [(Int, Int, Int)] -> (Int, Int, Int) + sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int) + sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int) + add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int) + -> (Int, Int, Int, Int, Int, Int, Int) + + addpr (x,y,z) = x+y+z + sum2 = foldr add2 (0,0) + where + add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) + sum3 = foldr add3 (0,0,0) + where + add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) + sum5 = foldr add5 (0,0,0,0,0) + where + add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) + sum7 = foldr add7 (0,0,0,0,0,0,0) + + add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) diff --git a/GHC/Hs/Syn/Type.hs b/GHC/Hs/Syn/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Syn/Type.hs @@ -0,0 +1,213 @@ +-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion. +-- +-- Note that this does /not/ currently support the use case of annotating +-- every subexpression in an 'HsExpr' with its 'Type'. For more information on +-- this task, see #12706, #15320, #16804, and #17331. +module GHC.Hs.Syn.Type ( + -- * Extracting types from HsExpr + lhsExprType, hsExprType, hsWrapperType, + -- * Extracting types from HsSyn + hsLitType, hsPatType, hsLPatType, + ) where + +import GHC.Prelude + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Core.Coercion +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Hs +import GHC.Tc.Types.Evidence +import GHC.Types.Id +import GHC.Types.Var( VarBndr(..) ) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +{- +************************************************************************ +* * + Extracting the type from HsSyn +* * +************************************************************************ + +-} + +hsLPatType :: LPat GhcTc -> Type +hsLPatType (L _ p) = hsPatType p + +hsPatType :: Pat GhcTc -> Type +hsPatType (ParPat _ pat) = hsLPatType pat +hsPatType (WildPat ty) = ty +hsPatType (VarPat _ lvar) = idType (unLoc lvar) +hsPatType (BangPat _ pat) = hsLPatType pat +hsPatType (LazyPat _ pat) = hsLPatType pat +hsPatType (LitPat _ lit) = hsLitType lit +hsPatType (AsPat _ var _) = idType (unLoc var) +hsPatType (ViewPat ty _ _) = ty +hsPatType (ListPat ty _) = mkListTy ty +hsPatType (OrPat ty _) = ty +hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make +hsPatType (SumPat tys _ _ _ ) = mkSumTy tys +hsPatType (ConPat { pat_con = lcon + , pat_con_ext = ConPatTc + { cpt_arg_tys = tys + } + }) + = conLikeResTy (unLoc lcon) tys +hsPatType (SigPat ty _ _) = ty +hsPatType (NPat ty _ _ _) = ty +hsPatType (NPlusKPat ty _ _ _ _ _) = ty +hsPatType (EmbTyPat ty _) = typeKind ty +hsPatType (InvisPat ty _) = typeKind ty +hsPatType (XPat ext) = + case ext of + CoPat _ _ ty -> ty + ExpansionPat _ pat -> hsPatType pat +hsPatType (SplicePat v _) = dataConCantHappen v + +hsLitType :: forall p. IsPass p => HsLit (GhcPass p) -> Type +hsLitType (HsChar _ _) = charTy +hsLitType (HsCharPrim _ _) = charPrimTy +hsLitType (HsString _ _) = stringTy +hsLitType (HsMultilineString _ _) = stringTy +hsLitType (HsStringPrim _ _) = addrPrimTy +hsLitType (HsInt _ _) = intTy +hsLitType (HsIntPrim _ _) = intPrimTy +hsLitType (HsWordPrim _ _) = wordPrimTy +hsLitType (HsInt8Prim _ _) = int8PrimTy +hsLitType (HsInt16Prim _ _) = int16PrimTy +hsLitType (HsInt32Prim _ _) = int32PrimTy +hsLitType (HsInt64Prim _ _) = int64PrimTy +hsLitType (HsWord8Prim _ _) = word8PrimTy +hsLitType (HsWord16Prim _ _) = word16PrimTy +hsLitType (HsWord32Prim _ _) = word32PrimTy +hsLitType (HsWord64Prim _ _) = word64PrimTy +hsLitType (HsFloatPrim _ _) = floatPrimTy +hsLitType (HsDoublePrim _ _) = doublePrimTy +hsLitType (XLit x) = case ghcPass @p of + GhcTc -> case x of + (HsInteger _ _ ty) -> ty + (HsRat _ ty) -> ty + + +-- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion. +lhsExprType :: LHsExpr GhcTc -> Type +lhsExprType (L _ e) = hsExprType e + +-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion. +hsExprType :: HsExpr GhcTc -> Type +hsExprType (HsVar _ (L _ id)) = idType id +hsExprType (HsOverLabel v _) = dataConCantHappen v +hsExprType (HsIPVar v _) = dataConCantHappen v +hsExprType (HsOverLit _ lit) = overLitType lit +hsExprType (HsLit _ lit) = hsLitType lit +hsExprType (HsLam _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group +hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f +hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x +hsExprType (OpApp v _ _ _) = dataConCantHappen v +hsExprType (NegApp _ _ se) = syntaxExprType se +hsExprType (HsPar _ e) = lhsExprType e +hsExprType (SectionL v _ _) = dataConCantHappen v +hsExprType (SectionR v _ _) = dataConCantHappen v +hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args +hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys +hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group +hsExprType (HsIf _ _ t _) = lhsExprType t +hsExprType (HsMultiIf ty _) = ty +hsExprType (HsLet _ _ body) = lhsExprType body +hsExprType (HsDo ty _ _) = ty +hsExprType (ExplicitList ty _) = mkListTy ty +hsExprType (RecordCon con_expr _ _) = hsExprType con_expr +hsExprType (RecordUpd v _ _) = dataConCantHappen v +hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v +hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v +hsExprType (ExprWithTySig _ e _) = lhsExprType e +hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of + Just op -> piResultTy (syntaxExprType op) asi_ty + Nothing -> asi_ty + where + asi_ty = arithSeqInfoType asi +hsExprType (HsTypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty +hsExprType (HsUntypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty +hsExprType e@(HsTypedSplice{}) = pprPanic "hsExprType: Unexpected HsTypedSplice" + (ppr e) + -- Typed splices should have been eliminated during zonking, but we + -- can't use `dataConCantHappen` since they are still present before + -- than in the typechecked AST. +hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext +hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top +hsExprType (HsStatic (_, ty) _s) = ty +hsExprType (HsPragE _ _ e) = lhsExprType e +hsExprType (HsEmbTy x _) = dataConCantHappen x +hsExprType (HsHole (_, (HER _ ty _))) = ty +hsExprType (HsQual x _ _) = dataConCantHappen x +hsExprType (HsForAll x _ _) = dataConCantHappen x +hsExprType (HsFunArr x _ _ _) = dataConCantHappen x +hsExprType (XExpr (WrapExpr wrap e)) = hsWrapperType wrap $ hsExprType e +hsExprType (XExpr (ExpandedThingTc _ e)) = hsExprType e +hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con +hsExprType (XExpr (HsTick _ e)) = lhsExprType e +hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e +hsExprType (XExpr (HsRecSelTc (FieldOcc _ id))) = idType (unLoc id) + +arithSeqInfoType :: ArithSeqInfo GhcTc -> Type +arithSeqInfoType asi = mkListTy $ case asi of + From x -> lhsExprType x + FromThen x _ -> lhsExprType x + FromTo x _ -> lhsExprType x + FromThenTo x _ _ -> lhsExprType x + +conLikeType :: ConLike -> Type +conLikeType (RealDataCon con) = dataConNonlinearType con +conLikeType (PatSynCon patsyn) = case patSynBuilder patsyn of + Just (_, ty, _) -> ty + Nothing -> pprPanic "conLikeType: Unidirectional pattern synonym in expression position" + (ppr patsyn) + +hsTupArgType :: HsTupArg GhcTc -> Type +hsTupArgType (Present _ e) = lhsExprType e +hsTupArgType (Missing (Scaled _ ty)) = ty + + +-- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas)) +type PRType = (Type, [Type]) + +prTypeType :: PRType -> Type +prTypeType (ty, tys) + | null tys = ty + | otherwise = piResultTys ty (reverse tys) + +liftPRType :: (Type -> Type) -> PRType -> PRType +liftPRType f pty = (f (prTypeType pty), []) + +hsWrapperType :: HsWrapper -> Type -> Type +hsWrapperType wrap ty = prTypeType $ go wrap (ty,[]) + where + go WpHole = id + go (w1 `WpCompose` w2) = go w1 . go w2 + go (WpFun _ w2 (Scaled m exp_arg)) = liftPRType $ \t -> + let act_res = funResultTy t + exp_res = hsWrapperType w2 act_res + in mkFunctionType m exp_arg exp_res + go (WpCast co) = liftPRType $ \_ -> coercionRKind co + go (WpEvLam v) = liftPRType $ mkInvisFunTy (idType v) + go (WpEvApp _) = liftPRType $ funResultTy + go (WpTyLam tv) = liftPRType $ mkForAllTy (Bndr tv Inferred) + go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas) + go (WpLet _) = id + +lhsCmdTopType :: LHsCmdTop GhcTc -> Type +lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty + +matchGroupTcType :: MatchGroupTc -> Type +matchGroupTcType (MatchGroupTc args res _) = mkScaledFunTys args res + +syntaxExprType :: SyntaxExpr GhcTc -> Type +syntaxExprType (SyntaxExprTc e _ _) = hsExprType e +syntaxExprType NoSyntaxExprTc = panic "syntaxExprType: Unexpected NoSyntaxExprTc" diff --git a/GHC/Hs/Type.hs b/GHC/Hs/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Type.hs @@ -0,0 +1,1653 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension + +{-# OPTIONS_GHC -Wno-orphans #-} -- NamedThing, Outputable, OutputableBndrId + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +GHC.Hs.Type: Abstract syntax: user-defined types +-} + +module GHC.Hs.Type ( + Mult, + HsMultAnn, HsMultAnnOf(..), + multAnnToHsType, expandHsMultAnnOf, + EpLinear(..), EpArrowOrColon(..), + pprHsArrow, pprHsMultAnn, + + HsType(..), HsCoreTy, LHsType, HsKind, LHsKind, + HsTypeGhcPsExt(..), + HsForAllTelescope(..), EpAnnForallVis, EpAnnForallInvis, + HsTyVarBndr(..), LHsTyVarBndr, AnnTyVarBndr(..), + HsBndrKind(..), + HsBndrVar(..), + HsBndrVis(..), isHsBndrInvisible, + LHsQTyVars(..), + HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, + HsWildCardBndrs(..), + HsPatSigType(..), HsPSRn(..), + HsTyPat(..), HsTyPatRn(..), + HsTyPatRnBuilder(..), tpBuilderExplicitTV, tpBuilderPatSig, buildHsTyPatRn, builderFromHsTyPatRn, + HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType, + HsTupleSort(..), + HsContext, LHsContext, fromMaybeContext, + HsTyLit(..), + HsIPName(..), hsIPNameFS, + HsArg(..), numVisibleArgs, pprHsArgsApp, + LHsTypeArg, lhsTypeArgSrcSpan, + OutputableBndrFlag, + + HsSrcBang(..), HsImplBang(..), + SrcStrictness(..), SrcUnpackedness(..), + + HsConDeclRecField(..), LHsConDeclRecField, pprHsConDeclRecFields, + + HsConDetails(..), + HsConDeclField(..), pprHsConDeclFieldWith, pprHsConDeclFieldNoMult, + hsPlainTypeField, mkConDeclField, + FieldOcc(..), LFieldOcc, mkFieldOcc, + fieldOccRdrName, fieldOccLRdrName, + + OpName(..), + + mkAnonWildCardTy, pprAnonWildCard, + + hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit, + mkHsOuterImplicit, mkHsOuterExplicit, + mkHsImplicitSigType, mkHsExplicitSigType, + mkHsWildCardBndrs, mkHsPatSigType, mkHsTyPat, + mkEmptyWildCardBndrs, + mkHsForAllVisTele, mkHsForAllInvisTele, + mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, + isHsKindedTyVar, hsBndrVar, hsBndrKind, hsTvbAllKinded, + hsScopedTvs, hsScopedKvs, hsWcScopedTvs, dropWildCards, + hsTyVarLName, hsTyVarName, + hsAllLTyVarNames, hsLTyVarLocNames, + hsLTyVarName, hsLTyVarNames, + hsForAllTelescopeBndrs, + hsForAllTelescopeNames, + hsLTyVarLocName, hsExplicitLTyVarNames, + splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, + splitLHsPatSynTy, + splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy, + splitLHsSigmaTyInvis, splitLHsGadtTy, + splitHsFunType, hsTyGetAppHead_maybe, + mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, + ignoreParens, hsSigWcType, hsPatSigType, + hsTyKindSig, + setHsTyVarBndrFlag, hsTyVarBndrFlag, updateHsTyVarBndrFlag, + + -- Printing + pprHsType, pprHsForAll, pprHsForAllTelescope, + pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs, + pprLHsContext, + hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Type + +import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) ) + +import Language.Haskell.Syntax.Extension +import GHC.Core.DataCon ( SrcStrictness(..), SrcUnpackedness(..) + , HsSrcBang(..), HsImplBang(..) + ) +import GHC.Hs.Extension +import GHC.Parser.Annotation + +import GHC.Types.Fixity ( LexicalFixity(..) ) +import GHC.Types.SourceText +import GHC.Types.Name +import GHC.Types.Name.Reader ( RdrName, WithUserRdr(..), noUserRdr ) +import GHC.Types.Var ( VarBndr, visArgTypeLike ) +import GHC.Core.TyCo.Rep ( Type(..) ) +import GHC.Builtin.Names ( negateName ) +import GHC.Builtin.Types( oneDataConName, mkTupleStr ) +import GHC.Core.Ppr ( pprOccWithTick) +import GHC.Core.Type +import GHC.Core.Multiplicity( pprArrowWithMultiplicity ) +import GHC.Hs.Doc +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Misc (count) + +import Data.Maybe +import Data.Data (Data) + +import qualified Data.Semigroup as S +import GHC.Data.Bag + +{- +************************************************************************ +* * +\subsection{Data types} +* * +************************************************************************ +-} + +fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p) +fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt + +type instance XHsForAllVis (GhcPass _) = EpAnn (TokForall, TokRarrow) + -- Location of 'forall' and '->' +type instance XHsForAllInvis (GhcPass _) = EpAnn (TokForall, EpToken ".") + -- Location of 'forall' and '.' + +type instance XXHsForAllTelescope (GhcPass _) = DataConCantHappen + +type EpAnnForallVis = EpAnn (TokForall, TokRarrow) +type EpAnnForallInvis = EpAnn (TokForall, EpToken ".") + +type HsQTvsRn = [Name] -- Implicit variables + -- For example, in data T (a :: k1 -> k2) = ... + -- the 'a' is explicit while 'k1', 'k2' are implicit + +type instance XHsQTvs GhcPs = NoExtField +type instance XHsQTvs GhcRn = HsQTvsRn +type instance XHsQTvs GhcTc = HsQTvsRn + +type instance XXLHsQTyVars (GhcPass _) = DataConCantHappen + +mkHsForAllVisTele ::EpAnnForallVis -> + [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p) +mkHsForAllVisTele an vis_bndrs = + HsForAllVis { hsf_xvis = an, hsf_vis_bndrs = vis_bndrs } + +mkHsForAllInvisTele :: EpAnnForallInvis + -> [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p) +mkHsForAllInvisTele an invis_bndrs = + HsForAllInvis { hsf_xinvis = an, hsf_invis_bndrs = invis_bndrs } + +mkHsQTvs :: [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs] -> LHsQTyVars GhcPs +mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs } + +emptyLHsQTvs :: LHsQTyVars GhcRn +emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] } + +------------------------------------------------ +-- HsOuterTyVarBndrs + +type instance XHsOuterImplicit GhcPs = NoExtField +type instance XHsOuterImplicit GhcRn = [Name] +type instance XHsOuterImplicit GhcTc = [TyVar] + +type instance XHsOuterExplicit GhcPs _ = EpAnnForallInvis +type instance XHsOuterExplicit GhcRn _ = NoExtField +type instance XHsOuterExplicit GhcTc flag = [VarBndr TyVar flag] + +type instance XXHsOuterTyVarBndrs (GhcPass _) = DataConCantHappen + +type instance XHsWC GhcPs b = NoExtField +type instance XHsWC GhcRn b = [Name] +type instance XHsWC GhcTc b = [Name] + +type instance XXHsWildCardBndrs (GhcPass _) _ = DataConCantHappen + +type instance XHsPS GhcPs = EpAnnCO +type instance XHsPS GhcRn = HsPSRn +type instance XHsPS GhcTc = HsPSRn + +type instance XHsTP GhcPs = NoExtField +type instance XHsTP GhcRn = HsTyPatRn +type instance XHsTP GhcTc = DataConCantHappen + +-- | The extension field for 'HsPatSigType', which is only used in the +-- renamer onwards. See @Note [Pattern signature binders and scoping]@. +data HsPSRn = HsPSRn + { hsps_nwcs :: [Name] -- ^ Wildcard names + , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names + } + deriving Data + +-- HsTyPatRn is the extension field for `HsTyPat`, after renaming +-- E.g. pattern K @(Maybe (_x, a, b::Proxy k) +-- In the type pattern @(Maybe ...): +-- '_x' is a named wildcard +-- 'a' is explicitly bound +-- 'k' is implicitly bound +-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat +data HsTyPatRn = HsTPRn + { hstp_nwcs :: [Name] -- ^ Wildcard names + , hstp_imp_tvs :: [Name] -- ^ Implicitly bound variable names + , hstp_exp_tvs :: [Name] -- ^ Explicitly bound variable names + } + deriving Data + +-- | A variant of HsTyPatRn that uses Bags for efficient concatenation. +-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat +data HsTyPatRnBuilder = + HsTPRnB { + hstpb_nwcs :: Bag Name, + hstpb_imp_tvs :: Bag Name, + hstpb_exp_tvs :: Bag Name + } + +tpBuilderExplicitTV :: Name -> HsTyPatRnBuilder +tpBuilderExplicitTV name = mempty {hstpb_exp_tvs = unitBag name} + +tpBuilderPatSig :: HsPSRn -> HsTyPatRnBuilder +tpBuilderPatSig HsPSRn {hsps_nwcs, hsps_imp_tvs} = + mempty { + hstpb_nwcs = listToBag hsps_nwcs, + hstpb_imp_tvs = listToBag hsps_imp_tvs + } + +instance Semigroup HsTyPatRnBuilder where + HsTPRnB nwcs1 imp_tvs1 exptvs1 <> HsTPRnB nwcs2 imp_tvs2 exptvs2 = + HsTPRnB + (nwcs1 `unionBags` nwcs2) + (imp_tvs1 `unionBags` imp_tvs2) + (exptvs1 `unionBags` exptvs2) + +instance Monoid HsTyPatRnBuilder where + mempty = HsTPRnB emptyBag emptyBag emptyBag + +buildHsTyPatRn :: HsTyPatRnBuilder -> HsTyPatRn +buildHsTyPatRn HsTPRnB {hstpb_nwcs, hstpb_imp_tvs, hstpb_exp_tvs} = + HsTPRn { + hstp_nwcs = bagToList hstpb_nwcs, + hstp_imp_tvs = bagToList hstpb_imp_tvs, + hstp_exp_tvs = bagToList hstpb_exp_tvs + } + +builderFromHsTyPatRn :: HsTyPatRn -> HsTyPatRnBuilder +builderFromHsTyPatRn HsTPRn{hstp_nwcs, hstp_imp_tvs, hstp_exp_tvs} = + HsTPRnB { + hstpb_nwcs = listToBag hstp_nwcs, + hstpb_imp_tvs = listToBag hstp_imp_tvs, + hstpb_exp_tvs = listToBag hstp_exp_tvs + } + +type instance XXHsPatSigType (GhcPass _) = DataConCantHappen +type instance XXHsTyPat (GhcPass _) = DataConCantHappen + +type instance XHsSig (GhcPass _) = NoExtField +type instance XXHsSigType (GhcPass _) = DataConCantHappen + + +hsPatSigType :: HsPatSigType (GhcPass p) -> LHsType (GhcPass p) +hsPatSigType (HsPS { hsps_body = ty }) = ty + +hsSigWcType :: LHsSigWcType (GhcPass p) -> LHsType (GhcPass p) +hsSigWcType = sig_body . unLoc . hswc_body + +dropWildCards :: LHsSigWcType (GhcPass p) -> LHsSigType (GhcPass p) +-- Drop the wildcard part of a LHsSigWcType +dropWildCards sig_ty = hswc_body sig_ty + +hsOuterTyVarNames :: HsOuterTyVarBndrs flag GhcRn -> [Name] +hsOuterTyVarNames (HsOuterImplicit{hso_ximplicit = imp_tvs}) = imp_tvs +hsOuterTyVarNames (HsOuterExplicit{hso_bndrs = bndrs}) = hsLTyVarNames bndrs + +hsOuterExplicitBndrs :: HsOuterTyVarBndrs flag (GhcPass p) + -> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))] +hsOuterExplicitBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = bndrs +hsOuterExplicitBndrs (HsOuterImplicit{}) = [] + +mkHsOuterImplicit :: HsOuterTyVarBndrs flag GhcPs +mkHsOuterImplicit = HsOuterImplicit{hso_ximplicit = noExtField} + +mkHsOuterExplicit :: EpAnnForallInvis -> [LHsTyVarBndr flag GhcPs] + -> HsOuterTyVarBndrs flag GhcPs +mkHsOuterExplicit an bndrs = HsOuterExplicit { hso_xexplicit = an + , hso_bndrs = bndrs } + +mkHsImplicitSigType :: LHsType GhcPs -> HsSigType GhcPs +mkHsImplicitSigType body = + HsSig { sig_ext = noExtField + , sig_bndrs = mkHsOuterImplicit, sig_body = body } + +mkHsExplicitSigType :: EpAnnForallInvis + -> [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs + -> HsSigType GhcPs +mkHsExplicitSigType an bndrs body = + HsSig { sig_ext = noExtField + , sig_bndrs = mkHsOuterExplicit an bndrs, sig_body = body } + +mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing +mkHsWildCardBndrs x = HsWC { hswc_body = x + , hswc_ext = noExtField } + +mkHsPatSigType :: EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs +mkHsPatSigType ann x = HsPS { hsps_ext = ann + , hsps_body = x } + +mkHsTyPat :: LHsType GhcPs -> HsTyPat GhcPs +mkHsTyPat x = HsTP { hstp_ext = noExtField + , hstp_body = x } + +mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing +mkEmptyWildCardBndrs x = HsWC { hswc_body = x + , hswc_ext = [] } + +-------------------------------------------------- + +type instance XTyVarBndr (GhcPass _) = AnnTyVarBndr +type instance XXTyVarBndr (GhcPass _) = DataConCantHappen + +type instance XBndrKind (GhcPass p) = NoExtField +type instance XBndrNoKind (GhcPass p) = NoExtField +type instance XXBndrKind (GhcPass p) = DataConCantHappen + +type instance XBndrVar (GhcPass p) = NoExtField + +type instance XBndrWildCard GhcPs = EpToken "_" +type instance XBndrWildCard GhcRn = NoExtField +type instance XBndrWildCard GhcTc = NoExtField + +type instance XXBndrVar (GhcPass p) = DataConCantHappen + +data AnnTyVarBndr + = AnnTyVarBndr { + atv_opens :: [EpaLocation], -- all "(" or all "{" + atv_closes :: [EpaLocation], -- all ")" or all "}" + atv_tv :: EpToken "'", + atv_dcolon :: TokDcolon + } deriving Data + +instance NoAnn AnnTyVarBndr where + noAnn = AnnTyVarBndr noAnn noAnn noAnn noAnn + +-- | Return the attached flag +hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag +hsTyVarBndrFlag = tvb_flag +-- By specialising to (GhcPass p) we know that XXTyVarBndr is DataConCantHappen +-- so the equation is exhaustive: extension construction can't happen + +-- | Set the attached flag +setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass) + -> HsTyVarBndr flag (GhcPass pass) +setHsTyVarBndrFlag fl tvb = tvb { tvb_flag = fl } + +-- | Update the attached flag +updateHsTyVarBndrFlag + :: (flag -> flag') + -> HsTyVarBndr flag (GhcPass pass) + -> HsTyVarBndr flag' (GhcPass pass) +updateHsTyVarBndrFlag f tvb = tvb { tvb_flag = f (tvb_flag tvb) } + +-- | Get the variable of the type variable binder +hsBndrVar :: HsTyVarBndr flag (GhcPass pass) -> HsBndrVar (GhcPass pass) +hsBndrVar = tvb_var + +-- | Get the kind of the type variable binder +hsBndrKind :: HsTyVarBndr flag (GhcPass pass) -> HsBndrKind (GhcPass pass) +hsBndrKind = tvb_kind + +-- | Do all type variables in this 'LHsQTyVars' come with kind annotations? +hsTvbAllKinded :: LHsQTyVars (GhcPass p) -> Bool +hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit + +type instance XBndrRequired (GhcPass _) = NoExtField + +type instance XBndrInvisible GhcPs = EpToken "@" +type instance XBndrInvisible GhcRn = NoExtField +type instance XBndrInvisible GhcTc = NoExtField + +type instance XXBndrVis (GhcPass _) = DataConCantHappen + +{- Note [Wildcard binders in disallowed contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In contexts where a type variable binder is expected (HsTyVarBndr), we usually +allow both named binders and wildcards, e.g. + + type Const1 a b = a -- ok + type Const2 a _ = a -- ok, too + +This applies to LHSs of data, newtype, type, class, type family and data family +declarations. However, we choose to reject wildcards in forall telescopes and +type family result variables (the latter being part of TypeFamilyDependencies): + + type family Fd a = _ -- disallowed (WildcardBndrInTyFamResultVar) + fn :: forall _. Int -- disallowed (WildcardBndrInForallTelescope) + +This restriction is placed solely because such binders have not been proposed +and there is no known use case for them. If we see user demand for wildcard +binders in these contexts, adding support for them would be as easy as dropping +the checks that reject them. The rest of the compiler can handle all wildcard +binders regardless of context by generating a fresh name (see `tcHsBndrVarName` +in GHC.Tc.Gen.HsType and `repHsBndrVar` in GHC.HsToCore.Quote). + +That is, in type declarations we have: + + type F _ = ... -- equivalent to ... + type F _a = ... -- where _a is fresh + +and the same principle could be applied to foralls: + + fn :: forall _. Int -- equivalent to ... + fn :: forall _a. Int -- where _a is fresh + +except the `forall _.` example is rejected by checkForAllTelescopeWildcardBndrs. +-} + +type instance XForAllTy (GhcPass _) = NoExtField +type instance XQualTy (GhcPass _) = NoExtField +type instance XTyVar (GhcPass _) = EpToken "'" +type instance XAppTy (GhcPass _) = NoExtField +type instance XFunTy (GhcPass _) = NoExtField +type instance XListTy (GhcPass _) = AnnParen +type instance XTupleTy (GhcPass _) = AnnParen +type instance XSumTy (GhcPass _) = AnnParen +type instance XOpTy (GhcPass _) = NoExtField +type instance XParTy (GhcPass _) = (EpToken "(", EpToken ")") +type instance XIParamTy (GhcPass _) = TokDcolon +type instance XStarTy (GhcPass _) = NoExtField +type instance XKindSig (GhcPass _) = TokDcolon + +type instance XAppKindTy GhcPs = EpToken "@" +type instance XAppKindTy GhcRn = NoExtField +type instance XAppKindTy GhcTc = NoExtField + +type instance XSpliceTy GhcPs = NoExtField +type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn) +type instance XSpliceTy GhcTc = Kind + +type instance XDocTy (GhcPass _) = NoExtField +type instance XConDeclField (GhcPass _) = ((EpaLocation, EpToken "#-}", EpaLocation), SourceText) +type instance XXConDeclRecField (GhcPass _) = DataConCantHappen + +type instance XExplicitListTy GhcPs = (EpToken "'", EpToken "[", EpToken "]") +type instance XExplicitListTy GhcRn = NoExtField +type instance XExplicitListTy GhcTc = Kind + +type instance XExplicitTupleTy GhcPs = (EpToken "'", EpToken "(", EpToken ")") +type instance XExplicitTupleTy GhcRn = NoExtField +type instance XExplicitTupleTy GhcTc = [Kind] + +type instance XTyLit (GhcPass _) = NoExtField + +type instance XWildCardTy GhcPs = EpToken "_" +type instance XWildCardTy GhcRn = NoExtField +type instance XWildCardTy GhcTc = NoExtField + +type instance XXType GhcPs = HsTypeGhcPsExt +type instance XXType GhcRn = HsCoreTy +type instance XXType GhcTc = DataConCantHappen + +type instance XNumTy (GhcPass _) = SourceText +type instance XStrTy (GhcPass _) = SourceText +type instance XCharTy (GhcPass _) = SourceText +type instance XXTyLit (GhcPass _) = DataConCantHappen + +type HsCoreTy = Type + +-- Extension of HsType during parsing. +-- see Note [Trees That Grow] in Language.Haskell.Syntax.Extension +data HsTypeGhcPsExt + = HsCoreTy HsCoreTy + -- An escape hatch for tunnelling a Core 'Type' through 'HsType'. + -- For more details on how this works, see: + -- + -- @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType" + -- + -- @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType" + + | HsBangTy (EpaLocation, EpToken "#-}", EpaLocation) + HsSrcBang + (LHsType GhcPs) + -- See Note [Parsing data type declarations] + + | HsRecTy (AnnList ()) + [LHsConDeclRecField GhcPs] + -- See Note [Parsing data type declarations] + +{- Note [Parsing data type declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When parsing it is not always clear if we're parsing a constructor field type +or not. So during parsing we extend the type syntax to support bang annotations +and record braces. We do this through the extension constructor of (HsType GhcPs), +namely `HsTypeGhcPsExt`, adding data constructors for `HsBangTy` and `HsRecTy`. +Once parsing is done (i.e. (HsType GhcRn) and (HsType GhcTc)) these constructors +are not needed; instead the data is stored in `HsConDeclField`. It is an error +if it turns out the extensions were used outside of a constructor field type. +-} + +data EpArrowOrColon + = EpArrow !TokRarrow + | EpColon !TokDcolon + | EpPatBind + deriving Data + +data EpLinear + = EpPct1 !(EpToken "%1") !EpArrowOrColon + | EpLolly !(EpToken "⊸") + deriving Data + +instance NoAnn EpLinear where + noAnn = EpPct1 noAnn (EpArrow noAnn) + +type instance XUnannotated _ GhcPs = EpArrowOrColon +type instance XUnannotated _ GhcRn = NoExtField +type instance XUnannotated _ GhcTc = Mult + +type instance XLinearAnn _ GhcPs = EpLinear +type instance XLinearAnn _ GhcRn = NoExtField +type instance XLinearAnn _ GhcTc = Mult + +type instance XExplicitMult _ GhcPs = (EpToken "%", EpArrowOrColon) +type instance XExplicitMult _ GhcRn = NoExtField +type instance XExplicitMult _ GhcTc = Mult + +type instance XXMultAnnOf _ (GhcPass _) = DataConCantHappen + +multAnnToHsType :: HsMultAnn GhcRn -> Maybe (LHsType GhcRn) +multAnnToHsType = expandHsMultAnnOf (HsTyVar noAnn NotPromoted . fmap noUserRdr) + +-- | Convert an multiplicity annotation into its corresponding multiplicity. +-- If no annotation was written, `Nothing` is returned. +-- In this polymorphic function, `t` can be `HsType` or `HsExpr` +expandHsMultAnnOf :: (LocatedN Name -> t GhcRn) + -> HsMultAnnOf (LocatedA (t GhcRn)) GhcRn + -> Maybe (LocatedA (t GhcRn)) +expandHsMultAnnOf _mk_var HsUnannotated{} = Nothing +expandHsMultAnnOf mk_var (HsLinearAnn _) = Just (noLocA (mk_var (noLocA oneDataConName))) +expandHsMultAnnOf _mk_var (HsExplicitMult _ p) = Just p + +instance + (Outputable mult, OutputableBndrId pass) => + Outputable (HsMultAnnOf mult (GhcPass pass)) where + ppr arr = parens (pprHsArrow arr) + +-- See #18846 +pprHsArrow :: (Outputable mult, OutputableBndrId pass) => HsMultAnnOf mult (GhcPass pass) -> SDoc +pprHsArrow (HsUnannotated _) = pprArrowWithMultiplicity visArgTypeLike (Left False) +pprHsArrow (HsLinearAnn _) = pprArrowWithMultiplicity visArgTypeLike (Left True) +pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p)) + +-- Used to print, for instance, let bindings: +-- let %1 x = … +-- and record field declarations: +-- { x %1 :: … } +pprHsMultAnn :: forall id. OutputableBndrId id => HsMultAnn (GhcPass id) -> SDoc +pprHsMultAnn (HsUnannotated _) = empty +pprHsMultAnn (HsLinearAnn _) = text "%1" +pprHsMultAnn (HsExplicitMult _ p) = text "%" <> ppr p + +type instance XConDeclRecField (GhcPass _) = NoExtField +type instance XXConDeclRecField (GhcPass _) = DataConCantHappen + +instance OutputableBndrId p + => Outputable (HsConDeclRecField (GhcPass p)) where + ppr (HsConDeclRecField _ fld_n cfs) = pprMaybeWithDoc (cdf_doc cfs) (ppr_names fld_n <+> pprHsConDeclFieldWith ppr_mult cfs { cdf_doc = Nothing }) + where + ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc + ppr_names [n] = pprPrefixOcc n + ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns)) + + ppr_mult :: HsMultAnn (GhcPass p) -> SDoc -> SDoc + ppr_mult mult tyDoc = pprHsMultAnn mult <+> dcolon <+> tyDoc + +--------------------- +hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] +-- Get the lexically-scoped type variables of an LHsSigWcType: +-- - the explicitly-given forall'd type variables; +-- see Note [Lexically scoped type variables] +-- - the named wildcards; see Note [Scoping of named wildcards] +-- because they scope in the same way +hsWcScopedTvs sig_wc_ty + | HsWC { hswc_ext = nwcs, hswc_body = sig_ty } <- sig_wc_ty + , L _ (HsSig{sig_bndrs = outer_bndrs}) <- sig_ty + = nwcs ++ hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs) + -- See Note [hsScopedTvs and visible foralls] + +hsScopedTvs :: LHsSigType GhcRn -> [Name] +-- Same as hsWcScopedTvs, but for a LHsSigType +hsScopedTvs (L _ (HsSig{sig_bndrs = outer_bndrs})) + = hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs) + -- See Note [hsScopedTvs and visible foralls] + +hsScopedKvs :: LHsKind GhcRn -> [Name] +-- Same as hsScopedTvs, but for a LHsKind +hsScopedKvs (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }}) + = hsLTyVarNames bndrs + -- See Note [hsScopedTvs and visible foralls] +hsScopedKvs _ = [] + +--------------------- +hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> Maybe (LIdP (GhcPass p)) +hsTyVarLName tvb = + case hsBndrVar tvb of + HsBndrVar _ n -> Just n + HsBndrWildCard _ -> Nothing + +hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p)) +hsTyVarName = fmap unLoc . hsTyVarLName + +hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p)) +hsLTyVarName = hsTyVarName . unLoc + +hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)] +hsLTyVarNames = mapMaybe hsLTyVarName + +hsForAllTelescopeBndrs :: HsForAllTelescope (GhcPass p) -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)] +hsForAllTelescopeBndrs (HsForAllVis _ bndrs) = map (fmap (setHsTyVarBndrFlag Required)) bndrs +hsForAllTelescopeBndrs (HsForAllInvis _ bndrs) = map (fmap (updateHsTyVarBndrFlag Invisible)) bndrs + +hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)] +hsForAllTelescopeNames (HsForAllVis _ bndrs) = hsLTyVarNames bndrs +hsForAllTelescopeNames (HsForAllInvis _ bndrs) = hsLTyVarNames bndrs + +hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] +-- Explicit variables only +hsExplicitLTyVarNames qtvs = hsLTyVarNames (hsQTvExplicit qtvs) + +hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] +-- All variables +hsAllLTyVarNames (HsQTvs { hsq_ext = kvs + , hsq_explicit = tvs }) + = kvs ++ hsLTyVarNames tvs + +hsLTyVarLocName :: Anno (IdGhcP p) ~ SrcSpanAnnN + => LHsTyVarBndr flag (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p))) +hsLTyVarLocName (L _ a) = hsTyVarLName a + +hsLTyVarLocNames :: Anno (IdGhcP p) ~ SrcSpanAnnN + => LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))] +hsLTyVarLocNames qtvs = mapMaybe hsLTyVarLocName (hsQTvExplicit qtvs) + +-- | Get the kind signature of a type, ignoring parentheses: +-- +-- hsTyKindSig `Maybe ` = Nothing +-- hsTyKindSig `Maybe :: Type -> Type ` = Just `Type -> Type` +-- hsTyKindSig `Maybe :: ((Type -> Type))` = Just `Type -> Type` +-- +-- This is used to extract the result kind of type synonyms with a CUSK: +-- +-- type S = (F :: res_kind) +-- ^^^^^^^^ +-- +hsTyKindSig :: LHsType (GhcPass p) -> Maybe (LHsKind (GhcPass p)) +hsTyKindSig lty = + case unLoc lty of + HsParTy _ lty' -> hsTyKindSig lty' + HsKindSig _ _ k -> Just k + _ -> Nothing + +--------------------- +ignoreParens :: LHsType (GhcPass p) -> LHsType (GhcPass p) +ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty +ignoreParens ty = ty + +{- +************************************************************************ +* * + Building types +* * +************************************************************************ +-} + +mkAnonWildCardTy :: EpToken "_" -> HsType GhcPs +mkAnonWildCardTy tok = HsWildCardTy tok + +mkHsOpTy :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN) + => PromotionFlag + -> LHsType (GhcPass p) -> LocatedN (IdOccP (GhcPass p)) + -> LHsType (GhcPass p) -> HsType (GhcPass p) +mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField prom ty1 op ty2 + +mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +mkHsAppTy t1 t2 = addCLocA t1 t2 (HsAppTy noExtField t1 t2) + +mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] + -> LHsType (GhcPass p) +mkHsAppTys = foldl' mkHsAppTy + +mkHsAppKindTy :: XAppKindTy (GhcPass p) + -> LHsType (GhcPass p) -> LHsType (GhcPass p) + -> LHsType (GhcPass p) +mkHsAppKindTy at ty k = addCLocA ty k (HsAppKindTy at ty k) + +{- +************************************************************************ +* * + Decomposing HsTypes +* * +************************************************************************ +-} + +--------------------------------- +-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) +-- Breaks up any parens in the result type: +-- splitHsFunType (a -> (b -> c)) = ([a,b], c) +-- It returns API Annotations for any parens removed +splitHsFunType :: + LHsType GhcPs + -> ( ([EpToken "("], [EpToken ")"]) , EpAnnComments -- The locations of any parens and + -- comments discarded + , [HsConDeclField GhcPs], LHsType GhcPs) +splitHsFunType ty = go ty + where + go (L l (HsParTy (op,cp) ty)) + = let + ((ops, cps), cs, args, res) = splitHsFunType ty + cs' = cs S.<> epAnnComments l + in ((ops++[op], cps ++ [cp]), cs', args, res) + + go (L ll (HsFunTy _ mult x y)) + | (anns, csy, args, res) <- splitHsFunType y + = (anns, csy S.<> epAnnComments ll, mkConDeclField mult x:args, res) + + go other = (noAnn, emptyComments, [], other) + +-- | Retrieve the name of the \"head\" of a nested type application. +-- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more +-- thorough. The purpose of this function is to examine instance heads, so it +-- doesn't handle *all* cases (like lists, tuples, @(~)@, etc.). +hsTyGetAppHead_maybe :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN) + => LHsType (GhcPass p) + -> Maybe (LocatedN (IdOccP (GhcPass p))) +hsTyGetAppHead_maybe = go + where + go (L _ (HsTyVar _ _ ln)) = Just ln + go (L _ (HsAppTy _ l _)) = go l + go (L _ (HsAppKindTy _ t _)) = go t + go (L _ (HsOpTy _ _ _ ln _)) = Just ln + go (L _ (HsParTy _ t)) = go t + go (L _ (HsKindSig _ t _)) = go t + go _ = Nothing + +------------------------------------------------------------ + +type instance XValArg (GhcPass _) = NoExtField + +type instance XTypeArg GhcPs = EpToken "@" +type instance XTypeArg GhcRn = NoExtField +type instance XTypeArg GhcTc = NoExtField + +type instance XArgPar (GhcPass _) = SrcSpan + +type instance XXArg (GhcPass _) = DataConCantHappen + +-- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'. +lhsTypeArgSrcSpan :: LHsTypeArg GhcPs -> SrcSpan +lhsTypeArgSrcSpan arg = case arg of + HsValArg _ tm -> getLocA tm + HsTypeArg at ty -> getEpTokenSrcSpan at `combineSrcSpans` getLocA ty + HsArgPar sp -> sp + +-------------------------------- + +numVisibleArgs :: [HsArg p tm ty] -> Arity +numVisibleArgs = count is_vis + where is_vis (HsValArg _ _) = True + is_vis _ = False + +-------------------------------- + +-- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@ +-- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix +-- or infix. Examples: +-- +-- @ +-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int] = T \@Bool Int +-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int] = (T \@Bool) Int +-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double] = Char ++ Double +-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering +-- @ +pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) + => id -> LexicalFixity -> [HsArg (GhcPass p) tm ty] -> SDoc +pprHsArgsApp thing fixity (argl:argr:args) + | Infix <- fixity + = let pp_op_app = hsep [ ppr_single_hs_arg argl + , pprInfixOcc thing + , ppr_single_hs_arg argr ] in + case args of + [] -> pp_op_app + _ -> ppr_hs_args_prefix_app (parens pp_op_app) args + +pprHsArgsApp thing _fixity args + = ppr_hs_args_prefix_app (pprPrefixOcc thing) args + +-- | Pretty-print a prefix identifier to a list of 'HsArg's. +ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty) + => SDoc -> [HsArg (GhcPass p) tm ty] -> SDoc +ppr_hs_args_prefix_app acc [] = acc +ppr_hs_args_prefix_app acc (arg:args) = + case arg of + HsValArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args + HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args + HsArgPar{} -> ppr_hs_args_prefix_app (parens acc) args + +-- | Pretty-print an 'HsArg' in isolation. +ppr_single_hs_arg :: (Outputable tm, Outputable ty) + => HsArg (GhcPass p) tm ty -> SDoc +ppr_single_hs_arg (HsValArg _ tm) = ppr tm +ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty +-- GHC shouldn't be constructing ASTs such that this case is ever reached. +-- Still, it's possible some wily user might construct their own AST that +-- allows this to be reachable, so don't fail here. +ppr_single_hs_arg (HsArgPar{}) = empty + +-- | This instance is meant for debug-printing purposes. If you wish to +-- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead. +instance (Outputable tm, Outputable ty) => Outputable (HsArg (GhcPass p) tm ty) where + ppr (HsValArg _ tm) = text "HsValArg" <+> ppr tm + ppr (HsTypeArg _ ty) = text "HsTypeArg" <+> ppr ty + ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp + +-------------------------------- + +-- | Decompose a pattern synonym type signature into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsPatSynTy :: + LHsSigType (GhcPass p) + -> ( [LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))] -- universals + , Maybe (LHsContext (GhcPass p)) -- required constraints + , [LHsTyVarBndr Specificity (GhcPass p)] -- existentials + , Maybe (LHsContext (GhcPass p)) -- provided constraints + , LHsType (GhcPass p)) -- body type +splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) + where + -- split_sig_ty :: + -- LHsSigType (GhcPass p) + -- -> ([LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))], LHsType (GhcPass p)) + split_sig_ty (L _ HsSig{sig_bndrs = outer_bndrs, sig_body = body}) = + case outer_bndrs of + -- NB: Use ignoreParens here in order to be consistent with the use of + -- splitLHsForAllTyInvis below, which also looks through parentheses. + HsOuterImplicit{} -> ([], ignoreParens body) + HsOuterExplicit{hso_bndrs = exp_bndrs} -> (exp_bndrs, body) + + (univs, ty1) = split_sig_ty ty + (reqs, ty2) = splitLHsQualTy ty1 + (exis, ty3) = splitLHsForAllTyInvis ty2 + (provs, ty4) = splitLHsQualTy ty3 + +-- | Decompose a sigma type (of the form @forall . context => body@) +-- into its constituent parts. +-- Only splits type variable binders that were +-- quantified invisibly (e.g., @forall a.@, with a dot). +-- +-- This function is used to split apart certain types, such as instance +-- declaration types, which disallow visible @forall@s. For instance, if GHC +-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that +-- declaration would mistakenly be accepted! +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsSigmaTyInvis :: LHsType (GhcPass p) + -> ([LHsTyVarBndr Specificity (GhcPass p)] + , Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p)) +splitLHsSigmaTyInvis ty + | (tvs, ty1) <- splitLHsForAllTyInvis ty + , (ctxt, ty2) <- splitLHsQualTy ty1 + = (tvs, ctxt, ty2) + +-- | Decompose a GADT type into its constituent parts. +-- Returns @(outer_bndrs, mb_ctxt, body)@, where: +-- +-- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost +-- type variable binders. Otherwise, they are 'HsOuterImplicit'. +-- +-- * @mb_ctxt@ is @Just@ the context, if it is provided. +-- Otherwise, it is @Nothing@. +-- +-- * @body@ is the body of the type after the optional @forall@s and context. +-- +-- This function is careful not to look through parentheses. +-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@ +-- "GHC.Hs.Decls" for why this is important. +splitLHsGadtTy :: + LHsSigType GhcPs + -> (HsOuterSigTyVarBndrs GhcPs, [HsForAllTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs) +splitLHsGadtTy (L _ sig_ty) + | (outer_bndrs, sigma_ty) <- split_outer_bndrs sig_ty + , (inner_bndrs, phi_ty) <- split_inner_bndrs sigma_ty + , (mb_ctxt, rho_ty) <- splitLHsQualTy_KP phi_ty + = case rho_ty of + L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _) | not (null inner_bndrs) + -- Bad! Record GADTs are not allowed to have inner_bndrs, + -- undo the split to get a proper error message later + -> (outer_bndrs, [], Nothing, sigma_ty) + _ -> (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty) + where + split_outer_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) + split_outer_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) = + (outer_bndrs, body_ty) + + split_inner_bndrs :: LHsType GhcPs -> ([HsForAllTelescope GhcPs], LHsType GhcPs) + split_inner_bndrs (L _ HsForAllTy { hst_tele = tele + , hst_body = body }) + = let ~(teles, t) = split_inner_bndrs body + in (tele:teles, t) + split_inner_bndrs t = ([], t) + +-- | Decompose a type of the form @forall . body@ into its constituent +-- parts. Only splits type variable binders that +-- were quantified invisibly (e.g., @forall a.@, with a dot). +-- +-- This function is used to split apart certain types, such as instance +-- declaration types, which disallow visible @forall@s. For instance, if GHC +-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that +-- declaration would mistakenly be accepted! +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +-- Unlike 'splitLHsSigmaTyInvis', this function does not look through +-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). +splitLHsForAllTyInvis :: + LHsType (GhcPass pass) -> ( [LHsTyVarBndr Specificity (GhcPass pass)] + , LHsType (GhcPass pass)) +splitLHsForAllTyInvis ty + | ((mb_tvbs), body) <- splitLHsForAllTyInvis_KP (ignoreParens ty) + = (fromMaybe [] mb_tvbs, body) + +-- | Decompose a type of the form @forall . body@ into its constituent +-- parts. Only splits type variable binders that +-- were quantified invisibly (e.g., @forall a.@, with a dot). +-- +-- This function is used to split apart certain types, such as instance +-- declaration types, which disallow visible @forall@s. For instance, if GHC +-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that +-- declaration would mistakenly be accepted! +-- +-- Unlike 'splitLHsForAllTyInvis', this function does not look through +-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). +splitLHsForAllTyInvis_KP :: + LHsType (GhcPass pass) -> (Maybe ([LHsTyVarBndr Specificity (GhcPass pass)]) + , LHsType (GhcPass pass)) +splitLHsForAllTyInvis_KP lty@(L _ ty) = + case ty of + HsForAllTy { hst_tele = HsForAllInvis {hsf_invis_bndrs = tvs } + , hst_body = body } + -> (Just tvs, body) + _ -> (Nothing, lty) + +-- | Decompose a type of the form @context => body@ into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(context => <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsQualTy :: LHsType (GhcPass pass) + -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass)) +splitLHsQualTy ty + | (mb_ctxt, body) <- splitLHsQualTy_KP (ignoreParens ty) + = (mb_ctxt, body) + +-- | Decompose a type of the form @context => body@ into its constituent parts. +-- +-- Unlike 'splitLHsQualTy', this function does not look through +-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). +splitLHsQualTy_KP :: LHsType (GhcPass pass) -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass)) +splitLHsQualTy_KP (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) + = (Just ctxt, body) +splitLHsQualTy_KP body = (Nothing, body) + +-- | Decompose a type class instance type (of the form +-- @forall . context => instance_head@) into its constituent parts. +-- Note that the @[Name]@s returned correspond to either: +-- +-- * The implicitly bound type variables (if the type lacks an outermost +-- @forall@), or +-- +-- * The explicitly bound type variables (if the type has an outermost +-- @forall@). +-- +-- This function is careful not to look through parentheses. +-- See @Note [No nested foralls or contexts in instance types]@ +-- for why this is important. +splitLHsInstDeclTy :: LHsSigType GhcRn + -> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn) +splitLHsInstDeclTy (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = inst_ty})) = + (hsOuterTyVarNames outer_bndrs, mb_cxt, body_ty) + where + (mb_cxt, body_ty) = splitLHsQualTy_KP inst_ty + +-- | Decompose a type class instance type (of the form +-- @forall . context => instance_head@) into the @instance_head@. +getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) +getLHsInstDeclHead (L _ (HsSig{sig_body = qual_ty})) + | (_mb_cxt, body_ty) <- splitLHsQualTy_KP qual_ty + = body_ty + +-- | Decompose a type class instance type (of the form +-- @forall . context => instance_head@) into the @instance_head@ and +-- retrieve the underlying class type constructor (if it exists). +getLHsInstDeclClass_maybe :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN) + => LHsSigType (GhcPass p) + -> Maybe (LocatedN (IdOccP (GhcPass p))) +-- Works on (LHsSigType GhcPs) +getLHsInstDeclClass_maybe inst_ty + = do { let head_ty = getLHsInstDeclHead inst_ty + ; hsTyGetAppHead_maybe head_ty + } + +{- +Note [No nested foralls or contexts in instance types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type at the top of an instance declaration is one of the few places in GHC +where nested `forall`s or contexts are not permitted, even with RankNTypes +enabled. For example, the following will be rejected: + + instance forall a. forall b. Show (Either a b) where ... + instance Eq a => Eq b => Show (Either a b) where ... + instance (forall a. Show (Maybe a)) where ... + instance (Eq a => Show (Maybe a)) where ... + +This restriction is partly motivated by an unusual quirk of instance +declarations. Namely, if ScopedTypeVariables is enabled, then the type +variables from the top of an instance will scope over the bodies of the +instance methods, /even if the type variables are implicitly quantified/. +For example, GHC will accept the following: + + instance Monoid a => Monoid (Identity a) where + mempty = Identity (mempty @a) + +Moreover, the type in the top of an instance declaration must obey the +forall-or-nothing rule (see Note [forall-or-nothing rule]). +If instance types allowed nested `forall`s, this could +result in some strange interactions. For example, consider the following: + + class C a where + m :: Proxy a + instance (forall a. C (Either a b)) where + m = Proxy @(Either a b) + +Somewhat surprisingly, old versions of GHC would accept the instance above. +Even though the `forall` only quantifies `a`, the outermost parentheses mean +that the `forall` is nested, and per the forall-or-nothing rule, this means +that implicit quantification would occur. Therefore, the `a` is explicitly +bound and the `b` is implicitly bound. Moreover, ScopedTypeVariables would +bring /both/ sorts of type variables into scope over the body of `m`. +How utterly confusing! + +To avoid this sort of confusion, we simply disallow nested `forall`s in +instance types, which makes things like the instance above become illegal. +For the sake of consistency, we also disallow nested contexts, even though they +don't have the same strange interaction with ScopedTypeVariables. + +Just as we forbid nested `forall`s and contexts in normal instance +declarations, we also forbid them in SPECIALISE instance pragmas (#18455). +Unlike normal instance declarations, ScopedTypeVariables don't have any impact +on SPECIALISE instance pragmas, but we use the same validity checks for +SPECIALISE instance pragmas anyway to be consistent. + +----- +-- Wrinkle: Derived instances +----- + +`deriving` clauses and standalone `deriving` declarations also permit bringing +type variables into scope, either through explicit or implicit quantification. +Unlike in the tops of instance declarations, however, one does not need to +enable ScopedTypeVariables for this to take effect. + +Just as GHC forbids nested `forall`s in the top of instance declarations, it +also forbids them in types involved with `deriving`: + +1. In the `via` types in DerivingVia. For example, this is rejected: + + deriving via (forall x. V x) instance C (S x) + + Just like the types in instance declarations, `via` types can also bring + both implicitly and explicitly bound type variables into scope. As a result, + we adopt the same no-nested-`forall`s rule in `via` types to avoid confusing + behavior like in the example below: + + deriving via (forall x. T x y) instance W x y (Foo a b) + -- Both x and y are brought into scope??? +2. In the classes in `deriving` clauses. For example, this is rejected: + + data T = MkT deriving (C1, (forall x. C2 x y)) + + This is because the generated instance would look like: + + instance forall x y. C2 x y T where ... + + So really, the same concerns as instance declarations apply here as well. +-} + +{- +************************************************************************ +* * + FieldOcc +* * +************************************************************************ + +Note [Ambiguous FieldOcc in record updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a "record field update" (`some_record{ field = expr }`), the field +occurrence may be ambiguous if there are multiple record types with that same +field label in scope. Instead of failing, we may attempt to do type-directed +disambiguation: if we typecheck the record field update, we can disambiguate +the `field` based on the record and field type. + +In practice, this means an identifier of a field occurrence +(`FieldOcc`) may have to go straight from `RdrName` to `Id`, since field +ambiguity makes it impossible to construct a `Name` for the field. + +Since type-directed disambiguation is a GHC property rather than a property of +the GHC-Haskell AST, we still parameterise a `FieldOcc` occurrence by `IdP p`, +but in the case of the ambiguity we do the unthinkable and insert a mkUnboundName +in the name. Very bad, yes, but since type-directed disambiguation is on the way +out (see proposal https://github.com/ghc-proposals/ghc-proposals/pull/366), +we consider this acceptable for now. + +see also Wrinkle [Disambiguating fields] and note [Type-directed record disambiguation] + +NB: FieldOcc preserves the RdrName throughout its lifecycle for +exact printing purposes. +-} + +type instance XCFieldOcc GhcPs = NoExtField -- RdrName is stored in the proper IdP field +type instance XCFieldOcc GhcRn = RdrName +type instance XCFieldOcc GhcTc = RdrName + +type instance XXFieldOcc (GhcPass p) = DataConCantHappen + +-------------------------------------------------------------------------------- + +mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs +mkFieldOcc rdr = FieldOcc noExtField rdr + +fieldOccRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> RdrName +fieldOccRdrName fo = case ghcPass @p of + GhcPs -> unLoc $ foLabel fo + GhcRn -> foExt fo + GhcTc -> foExt fo + +-- ToDo SPJ: remove +--fieldOccExt :: FieldOcc (GhcPass p) -> XCFieldOcc (GhcPass p) +--fieldOccExt (FieldOcc { foExt = ext }) = ext + +fieldOccLRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> LocatedN RdrName +fieldOccLRdrName fo = case ghcPass @p of + GhcPs -> foLabel fo + GhcRn -> case fo of + FieldOcc rdr sel -> + let (L l _) = sel + in L l rdr + GhcTc -> + let (L l _) = foLabel fo + in L l (foExt fo) + + +{- +************************************************************************ +* * + OpName +* * +************************************************************************ +-} + +-- | Name of an operator in an operator application or section +data OpName = NormalOp (WithUserRdr Name) -- ^ A normal identifier + | NegateOp -- ^ Prefix negation + | UnboundOp RdrName -- ^ An unbound identifier + | RecFldOp (FieldOcc GhcRn) -- ^ A record field occurrence + +instance Outputable OpName where + ppr (NormalOp n) = ppr n + ppr NegateOp = ppr negateName + ppr (UnboundOp uv) = ppr uv + ppr (RecFldOp fld) = ppr fld + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} + +instance OutputableBndrId p => Outputable (HsBndrVar (GhcPass p)) where + ppr (HsBndrVar _ name) = ppr name + ppr (HsBndrWildCard _) = char '_' + +class OutputableBndrFlag flag p where + pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc + +instance OutputableBndrFlag () p where + pprTyVarBndr (HsTvb _ _ bvar bkind) = decorate (ppr_hs_tvb bvar bkind) + where decorate :: SDoc -> SDoc + decorate d = parens_if_kind bkind d + +instance OutputableBndrFlag Specificity p where + pprTyVarBndr (HsTvb _ spec bvar bkind) = decorate (ppr_hs_tvb bvar bkind) + where decorate :: SDoc -> SDoc + decorate d = case spec of + InferredSpec -> braces d + SpecifiedSpec -> parens_if_kind bkind d + +instance OutputableBndrFlag (HsBndrVis (GhcPass p')) p where + pprTyVarBndr (HsTvb _ bvis bvar bkind) = decorate (ppr_hs_tvb bvar bkind) + where decorate :: SDoc -> SDoc + decorate d = case bvis of + HsBndrRequired _ -> parens_if_kind bkind d + HsBndrInvisible _ -> char '@' <> parens_if_kind bkind d + +instance OutputableBndrFlag ForAllTyFlag p where + pprTyVarBndr (HsTvb _ spec bvar bkind) = + text "forall" <+> decorate (ppr_hs_tvb bvar bkind) + where decorate :: SDoc -> SDoc + decorate d = case spec of + Inferred -> braces d <> dot + Specified -> parens_if_kind bkind d <> dot + Required -> parens_if_kind bkind d <+> text "->" + +ppr_hs_tvb :: OutputableBndrId p => HsBndrVar (GhcPass p) -> HsBndrKind (GhcPass p) -> SDoc +ppr_hs_tvb bvar (HsBndrNoKind _) = ppr bvar +ppr_hs_tvb bvar (HsBndrKind _ k) = hsep [ppr bvar, dcolon, ppr k] + +parens_if_kind :: HsBndrKind (GhcPass p) -> SDoc -> SDoc +parens_if_kind (HsBndrNoKind _) d = d +parens_if_kind (HsBndrKind _ _) d = parens d + +instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where + ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) = + pprHsOuterSigTyVarBndrs outer_bndrs <+> ppr body + +instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where + ppr ty = pprHsType ty + +instance OutputableBndrId p + => Outputable (LHsQTyVars (GhcPass p)) where + ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs + +instance (OutputableBndrFlag flag p, + OutputableBndrFlag flag (NoGhcTcPass p), + OutputableBndrId p) + => Outputable (HsOuterTyVarBndrs flag (GhcPass p)) where + ppr (HsOuterImplicit{hso_ximplicit = imp_tvs}) = + text "HsOuterImplicit:" <+> case ghcPass @p of + GhcPs -> ppr imp_tvs + GhcRn -> ppr imp_tvs + GhcTc -> ppr imp_tvs + ppr (HsOuterExplicit{hso_bndrs = exp_tvs}) = + text "HsOuterExplicit:" <+> ppr exp_tvs + +instance OutputableBndrId p + => Outputable (HsForAllTelescope (GhcPass p)) where + ppr (HsForAllVis { hsf_vis_bndrs = bndrs }) = + text "HsForAllVis:" <+> ppr bndrs + ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) = + text "HsForAllInvis:" <+> ppr bndrs + +instance (OutputableBndrId p, OutputableBndrFlag flag p) + => Outputable (HsTyVarBndr flag (GhcPass p)) where + ppr = pprTyVarBndr + +instance Outputable thing + => Outputable (HsWildCardBndrs (GhcPass p) thing) where + ppr (HsWC { hswc_body = ty }) = ppr ty + +instance (OutputableBndrId p) + => Outputable (HsPatSigType (GhcPass p)) where + ppr (HsPS { hsps_body = ty }) = ppr ty + + +instance (OutputableBndrId p) + => Outputable (HsTyPat (GhcPass p)) where + ppr (HsTP { hstp_body = ty }) = ppr ty + + +instance (OutputableBndrId p) + => Outputable (HsTyLit (GhcPass p)) where + ppr = ppr_tylit + +instance Outputable HsIPName where + ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters + +instance OutputableBndr HsIPName where + pprBndr _ n = ppr n -- Simple for now + pprInfixOcc n = ppr n + pprPrefixOcc n = ppr n + +instance (Outputable arg, Outputable rec) + => Outputable (HsConDetails arg rec) where + ppr (PrefixCon args) = text "PrefixCon:" <+> ppr args + ppr (RecCon rec) = text "RecCon:" <+> ppr rec + ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] + +pprHsConDeclFieldWith :: (OutputableBndrId p) + => (HsMultAnn (GhcPass p) -> SDoc -> SDoc) + -> HsConDeclField (GhcPass p) -> SDoc +pprHsConDeclFieldWith ppr_mult (CDF _ prag mark mult ty doc) = + pprMaybeWithDoc doc (ppr_mult mult (ppr prag <+> ppr mark <> ppr ty)) + +pprHsConDeclFieldNoMult :: (OutputableBndrId p) => HsConDeclField (GhcPass p) -> SDoc +pprHsConDeclFieldNoMult = pprHsConDeclFieldWith (\_ d -> d) + +hsPlainTypeField :: LHsType GhcPs -> HsConDeclField GhcPs +hsPlainTypeField = mkConDeclField (HsUnannotated (EpColon noAnn)) + +mkConDeclField :: HsMultAnn GhcPs -> LHsType GhcPs -> HsConDeclField GhcPs +mkConDeclField mult (L _ (HsDocTy _ ty lds)) = (mkConDeclField mult ty) { cdf_doc = Just lds } +mkConDeclField mult (L _ (XHsType (HsBangTy ann (HsSrcBang srcTxt unp str) t))) = CDF (ann, srcTxt) unp str mult t Nothing +mkConDeclField mult t = CDF noAnn NoSrcUnpack NoSrcStrict mult t Nothing + +instance Outputable (XRecGhc (IdGhcP p)) => + Outputable (FieldOcc (GhcPass p)) where + ppr = ppr . foLabel + +instance (OutputableBndrId pass) => OutputableBndr (FieldOcc (GhcPass pass)) where + pprInfixOcc = pprInfixOcc . unXRec @(GhcPass pass) . foLabel + pprPrefixOcc = pprPrefixOcc . unXRec @(GhcPass pass) . foLabel + +instance (OutputableBndrId pass) => OutputableBndr (GenLocated SrcSpan (FieldOcc (GhcPass pass))) where + pprInfixOcc = pprInfixOcc . unLoc + pprPrefixOcc = pprPrefixOcc . unLoc + +ppr_tylit :: (HsTyLit (GhcPass p)) -> SDoc +ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) +ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) +ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c)) + +pprAnonWildCard :: SDoc +pprAnonWildCard = char '_' + +-- | Prints the explicit @forall@ in a type family equation if one is written. +-- If there is no explicit @forall@, nothing is printed. +pprHsOuterFamEqnTyVarBndrs :: OutputableBndrId p + => HsOuterFamEqnTyVarBndrs (GhcPass p) -> SDoc +pprHsOuterFamEqnTyVarBndrs (HsOuterImplicit{}) = empty +pprHsOuterFamEqnTyVarBndrs (HsOuterExplicit{hso_bndrs = qtvs}) = + forAllLit <+> interppSP qtvs <> dot + +-- | Prints the outermost @forall@ in a type signature if one is written. +-- If there is no outermost @forall@, nothing is printed. +pprHsOuterSigTyVarBndrs :: OutputableBndrId p + => HsOuterSigTyVarBndrs (GhcPass p) -> SDoc +pprHsOuterSigTyVarBndrs (HsOuterImplicit{}) = empty +pprHsOuterSigTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = + pprHsForAllTelescope (mkHsForAllInvisTele noAnn bndrs) + +-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ +-- only when @-dppr-debug@ is enabled. +pprHsForAll :: forall p. OutputableBndrId p + => HsForAllTelescope (GhcPass p) + -> Maybe (LHsContext (GhcPass p)) -> SDoc +pprHsForAll tele cxt + = pprHsForAllTelescope tele <+> pprLHsContext cxt + +pprHsForAllTelescope :: forall p. OutputableBndrId p + => HsForAllTelescope (GhcPass p) + -> SDoc +pprHsForAllTelescope tele = + case tele of + HsForAllVis { hsf_vis_bndrs = qtvs } -> pp_forall (space <> arrow) qtvs + HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs + where + pp_forall :: forall flag p. (OutputableBndrId p, OutputableBndrFlag flag p) + => SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc + pp_forall separator qtvs + | null qtvs = whenPprDebug (forAllLit <> separator) + -- Note: to fix the PprRecordDotSyntax1 ppr roundtrip test, the <> + -- below needs to be <+>. But it means 94 other test results need to + -- be updated to match. + | otherwise = forAllLit <+> interppSP qtvs <> separator + +pprLHsContext :: (OutputableBndrId p) + => Maybe (LHsContext (GhcPass p)) -> SDoc +pprLHsContext Nothing = empty +pprLHsContext (Just lctxt) = pprLHsContextAlways lctxt + +-- For use in a HsQualTy, which always gets printed if it exists. +pprLHsContextAlways :: (OutputableBndrId p) + => LHsContext (GhcPass p) -> SDoc +pprLHsContextAlways (L _ ctxt) + = case ctxt of + [] -> parens empty <+> darrow + [L _ ty] -> ppr_mono_ty ty <+> darrow + _ -> parens (interpp'SP ctxt) <+> darrow + +pprHsConDeclRecFields :: forall p. OutputableBndrId p + => [LHsConDeclRecField (GhcPass p)] -> SDoc +pprHsConDeclRecFields fields = braces (sep (punctuate comma (map ppr fields))) + +-- Printing works more-or-less as for Types + +pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc +pprHsType ty = ppr_mono_ty ty + +ppr_mono_lty :: OutputableBndrId p + => LHsType (GhcPass p) -> SDoc +ppr_mono_lty ty = ppr_mono_ty (unLoc ty) + +ppr_mono_ty :: forall p. (OutputableBndrId p) => HsType (GhcPass p) -> SDoc +ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty }) + = sep [pprHsForAll tele Nothing, ppr_mono_lty ty] + +ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) + = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty] + +ppr_mono_ty (HsTyVar _ prom (L _ name)) = pprOccWithTick Prefix prom name +ppr_mono_ty (HsFunTy _ mult ty1 ty2) = ppr_fun_ty mult ty1 ty2 +ppr_mono_ty (HsTupleTy _ con tys) + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `Solo x`, not `(x)` + | [ty] <- tys + , BoxedTuple <- std_con + = sep [text (mkTupleStr Boxed tcName 1), ppr_mono_lty ty] + | otherwise + = tupleParens std_con (pprWithCommas ppr tys) + where std_con = case con of + HsUnboxedTuple -> UnboxedTuple + _ -> BoxedTuple +ppr_mono_ty (HsSumTy _ tys) + = tupleParens UnboxedTuple (pprWithBars ppr tys) +ppr_mono_ty (HsKindSig _ ty kind) + = ppr_mono_lty ty <+> dcolon <+> ppr kind +ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty) +ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) +ppr_mono_ty (HsSpliceTy ext s) = + case ghcPass @p of + GhcPs -> pprUntypedSplice True Nothing s + GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s + GhcRn | HsUntypedSpliceTop _ t <- ext -> ppr t + GhcTc -> pprUntypedSplice True Nothing s +ppr_mono_ty (HsExplicitListTy _ prom tys) + | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys) + | otherwise = brackets (interpp'SP tys) +ppr_mono_ty (HsExplicitTupleTy _ prom tys) + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `'MkSolo x`, not `'(x)` + | [ty] <- tys + = quote_tuple prom $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty] + | otherwise + = quote_tuple prom $ parens (maybeAddSpace tys $ interpp'SP tys) +ppr_mono_ty (HsTyLit _ t) = ppr t +ppr_mono_ty (HsWildCardTy {}) = char '_' + +ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*') + +ppr_mono_ty (HsAppTy _ fun_ty arg_ty) + = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] +ppr_mono_ty (HsAppKindTy _ ty k) + = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k +ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2) + = sep [ ppr_mono_lty ty1 + , sep [pprOccWithTick Infix prom op, ppr_mono_lty ty2 ] ] +ppr_mono_ty (HsParTy _ ty) + = parens (ppr_mono_lty ty) + -- Put the parens in where the user did + -- But we still use the precedence stuff to add parens because + -- toHsType doesn't put in any HsParTys, so we may still need them + +ppr_mono_ty (HsDocTy _ ty doc) + = pprWithDoc doc $ ppr_mono_lty ty + +ppr_mono_ty (XHsType t) = case ghcPass @p of + GhcPs -> case t of + HsCoreTy ty -> ppr ty + HsBangTy _ b ty -> ppr b <> ppr_mono_lty ty + HsRecTy _ flds -> pprHsConDeclRecFields flds + GhcRn -> ppr t + +-------------------------- +ppr_fun_ty :: (OutputableBndrId p) + => HsMultAnn (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc +ppr_fun_ty mult ty1 ty2 + = let p1 = ppr_mono_lty ty1 + p2 = ppr_mono_lty ty2 + arr = pprHsArrow mult + in + sep [p1, arr <+> p2] + +quote_tuple :: PromotionFlag -> SDoc -> SDoc +quote_tuple IsPromoted doc = quote doc +quote_tuple NotPromoted doc = doc + +-------------------------- +-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses +-- under precedence @p@. +hsTypeNeedsParens :: forall p. IsPass p => PprPrec -> HsType (GhcPass p) -> Bool +hsTypeNeedsParens p = go_hs_ty + where + go_hs_ty (HsForAllTy{}) = p >= funPrec + go_hs_ty (HsQualTy{}) = p >= funPrec + go_hs_ty (HsTyVar{}) = False + go_hs_ty (HsFunTy{}) = p >= funPrec + -- Special-case unary boxed tuple applications so that they are + -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612) + -- See Note [One-tuples] in GHC.Builtin.Types + go_hs_ty (HsTupleTy _ con [_]) + = case con of + HsBoxedOrConstraintTuple -> p >= appPrec + HsUnboxedTuple -> False + go_hs_ty (HsTupleTy{}) = False + go_hs_ty (HsSumTy{}) = False + go_hs_ty (HsKindSig{}) = p >= sigPrec + go_hs_ty (HsListTy{}) = False + go_hs_ty (HsIParamTy{}) = p > topPrec + go_hs_ty (HsSpliceTy{}) = False + go_hs_ty (HsExplicitListTy{}) = False + -- Special-case unary boxed tuple applications so that they are + -- parenthesized as `Proxy ('MkSolo x)`, not `Proxy 'MkSolo x` (#18612) + -- See Note [One-tuples] in GHC.Builtin.Types + go_hs_ty (HsExplicitTupleTy _ _ [_]) + = p >= appPrec + go_hs_ty (HsExplicitTupleTy{}) = False + go_hs_ty (HsTyLit{}) = False + go_hs_ty (HsWildCardTy{}) = False + go_hs_ty (HsStarTy{}) = p >= starPrec + go_hs_ty (HsAppTy{}) = p >= appPrec + go_hs_ty (HsAppKindTy{}) = p >= appPrec + go_hs_ty (HsOpTy{}) = p >= opPrec + go_hs_ty (HsParTy{}) = False + go_hs_ty (HsDocTy _ (L _ t) _) = go_hs_ty t + go_hs_ty (XHsType t) = case ghcPass @p of + GhcPs -> case t of + HsCoreTy ty -> go_core_ty ty + HsBangTy{} -> p > topPrec + HsRecTy{} -> False + GhcRn -> go_core_ty t + + go_core_ty (TyVarTy{}) = False + go_core_ty (AppTy{}) = p >= appPrec + go_core_ty (TyConApp _ args) + | null args = False + | otherwise = p >= appPrec + go_core_ty (ForAllTy{}) = p >= funPrec + go_core_ty (FunTy{}) = p >= funPrec + go_core_ty (LitTy{}) = False + go_core_ty (CastTy t _) = go_core_ty t + go_core_ty (CoercionTy{}) = False + +maybeAddSpace :: [LHsType (GhcPass p)] -> SDoc -> SDoc +-- See Note [Printing promoted type constructors] +-- in GHC.Iface.Type. This code implements the same +-- logic for printing HsType +maybeAddSpace tys doc + | (ty : _) <- tys + , lhsTypeHasLeadingPromotionQuote ty = space <> doc + | otherwise = doc + +lhsTypeHasLeadingPromotionQuote :: LHsType (GhcPass p) -> Bool +lhsTypeHasLeadingPromotionQuote ty + = goL ty + where + goL (L _ ty) = go ty + + go (HsForAllTy{}) = False + go (HsQualTy{ hst_ctxt = ctxt, hst_body = body}) + | (L _ (c:_)) <- ctxt = goL c + | otherwise = goL body + go (HsTyVar _ p _) = isPromoted p + go (HsFunTy _ _ arg _) = goL arg + go (HsListTy{}) = False + go (HsTupleTy{}) = False + go (HsSumTy{}) = False + go (HsOpTy _ _ t1 _ _) = goL t1 + go (HsKindSig _ t _) = goL t + go (HsIParamTy{}) = False + go (HsSpliceTy{}) = False + go (HsExplicitListTy _ p _) = isPromoted p + go (HsExplicitTupleTy{}) = True + go (HsTyLit{}) = False + go (HsWildCardTy{}) = False + go (HsStarTy{}) = False + go (HsAppTy _ t _) = goL t + go (HsAppKindTy _ t _) = goL t + go (HsParTy{}) = False + go (HsDocTy _ t _) = goL t + go (XHsType{}) = False + +-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is +-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply +-- returns @ty@. +parenthesizeHsType :: IsPass p => PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) +parenthesizeHsType p lty@(L loc ty) + | hsTypeNeedsParens p ty = L loc (HsParTy noAnn lty) + | otherwise = lty + +-- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint +-- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@ +-- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply +-- returns @ctxt@ unchanged. +parenthesizeHsContext :: IsPass p => PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p) +parenthesizeHsContext p lctxt@(L loc ctxt) = + case ctxt of + [c] -> L loc [parenthesizeHsType p c] + _ -> lctxt -- Other contexts are already "parenthesized" by virtue of + -- being tuples. +{- +************************************************************************ +* * +\subsection{Anno instances} +* * +************************************************************************ +-} + +type instance Anno [LocatedA (HsType (GhcPass p))] = SrcSpanAnnC +type instance Anno (HsType (GhcPass p)) = SrcSpanAnnA +type instance Anno (HsSigType (GhcPass p)) = SrcSpanAnnA +type instance Anno (HsKind (GhcPass p)) = SrcSpanAnnA + +type instance Anno (HsTyVarBndr _flag (GhcPass _)) = SrcSpanAnnA + -- Explicit pass Anno instances needed because of the NoGhcTc field +type instance Anno (HsTyVarBndr _flag GhcPs) = SrcSpanAnnA +type instance Anno (HsTyVarBndr _flag GhcRn) = SrcSpanAnnA +type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA + +type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA +type instance Anno HsIPName = EpAnnCO +type instance Anno (HsConDeclRecField (GhcPass p)) = SrcSpanAnnA + +type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA diff --git a/GHC/Hs/Utils.hs b/GHC/Hs/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Utils.hs @@ -0,0 +1,1882 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TupleSections #-} + +{-| +Module : GHC.Hs.Utils +Description : Generic helpers for the HsSyn type. +Copyright : (c) The University of Glasgow, 1992-2023 + +Here we collect a variety of helper functions that construct or +analyse HsSyn. All these functions deal with generic HsSyn; functions +which deal with the instantiated versions are located elsewhere: + + Parameterised by Module + ---------------- ------------- + GhcPs/RdrName GHC.Parser.PostProcess + GhcRn/Name GHC.Rename.* + GhcTc/Id GHC.Tc.Zonk.Type + +The @mk*@ functions attempt to construct a not-completely-useless SrcSpan +from their components, compared with the @nl*@ functions which +just attach noSrcSpan to everything. + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE RecordWildCards #-} + +module GHC.Hs.Utils( + -- * Terms + mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith, mkHsSyntaxApps, + mkHsAppType, mkHsAppTypes, mkHsCaseAlt, + mkSimpleMatch, unguardedGRHSs, unguardedRHS, + mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, + mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, + mkHsDictLet, mkHsLams, + mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, + mkHsWrapPat, mkLHsWrapPat, mkHsWrapPatCo, + mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, + mkHsCmdIf, mkConLikeTc, + + nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon, + nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, + nlHsIntLit, nlHsVarApps, + nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, + mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, + mkLocatedList, nlAscribe, + + forgetUserRdr, noUserRdr, + + -- * Bindings + mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind, + mkPatSynBind, + isInfixFunBind, + spanHsLocaLBinds, + + -- * Literals + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringFS, mkHsStringPrimLit, + mkHsCharPrimLit, + + -- * Patterns + mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, + nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, + nlWildPatName, nlTuplePat, mkParPat, nlParPat, + mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, + + -- * Types + mkHsAppTy, mkHsAppKindTy, + hsTypeToHsSigType, hsTypeToHsSigWcType, mkClassOpSigs, mkHsSigEnv, + nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp, + + -- * Stmts + mkTransformStmt, mkTransformByStmt, mkBodyStmt, + mkPsBindStmt, mkRnBindStmt, mkTcBindStmt, + mkLastStmt, + emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, + emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, + unitRecStmtTc, + mkLetStmt, + + -- * Collecting binders + isUnliftedHsBind, isUnliftedHsBinds, isBangedHsBind, + + collectLocalBinders, collectHsValBinders, collectHsBindListBinders, + collectHsIdBinders, + collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, + + collectPatBinders, collectPatsBinders, + collectLStmtsBinders, collectStmtsBinders, + collectLStmtBinders, collectStmtBinders, + CollectPass(..), CollectFlag(..), + + TyDeclBinders(..), LConsWithFields(..), + hsLTyClDeclBinders, hsTyClForeignBinders, + hsPatSynSelectors, getPatSynBinds, + hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, + + -- * Collecting implicit binders + ImplicitFieldBinders(..), + lStmtsImplicits, hsValBindsImplicits, lPatImplicits, + lHsRecFieldsImplicits + ) where + +import GHC.Prelude hiding (head, init, last, tail) + +import GHC.Hs.Decls +import GHC.Hs.Binds +import GHC.Hs.Expr +import GHC.Hs.Pat +import GHC.Hs.Type +import GHC.Hs.Lit +import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Extension +import GHC.Hs.Extension +import GHC.Parser.Annotation + +import GHC.Tc.Types.Evidence + +import GHC.Core.Coercion( isReflCo ) +import GHC.Core.Multiplicity ( pattern ManyTy ) +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.Make ( mkChunkified ) +import GHC.Core.Type ( Type, isUnliftedType ) + +import GHC.Builtin.Types ( unitTy, manyDataConTy ) + +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Set hiding ( unitFV ) +import GHC.Types.Name.Env +import GHC.Types.Name.Reader +import GHC.Types.Var +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Fixity +import GHC.Types.SourceText + +import GHC.Data.FastString + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Arrow ( first ) +import Data.Foldable ( toList ) +import Data.List ( partition ) +import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) +import qualified Data.List.NonEmpty as NE + +import Data.IntMap ( IntMap ) +import qualified Data.IntMap.Strict as IntMap +import Data.Map ( Map ) +import qualified Data.Map.Strict as Map + +{- +************************************************************************ +* * + Some useful helpers for constructing syntax +* * +************************************************************************ + +These functions attempt to construct a not-completely-useless 'SrcSpan' +from their components, compared with the @nl*@ functions below which +just attach 'noSrcSpan' to everything. +-} + +-- | @e => (e)@ +mkHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +mkHsPar e = L (getLoc e) (gHsPar e) + +mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpanAnnA, + Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ EpAnn NoEpAnns) + => HsMatchContext (LIdP (NoGhcTc (GhcPass p))) + -> LocatedE [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) + -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) +mkSimpleMatch ctxt (L l pats) rhs + = L loc $ + Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = L l pats + , m_grhss = unguardedGRHSs (locA loc) rhs noAnn } + where + loc = case pats of + [] -> getLoc rhs + (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs) + +unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ EpAnn NoEpAnns + => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn + -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) +unguardedGRHSs loc rhs an + = GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds + +unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ EpAnn NoEpAnns + => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p)) + -> NonEmpty (LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))) +unguardedRHS an loc rhs = NE.singleton $ L (noAnnSrcSpan loc) (GRHS an [] rhs) + +type AnnoBody p body + = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ Origin + , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnLW + , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA + ) + +mkMatchGroup :: AnnoBody p body + => Origin + -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] + -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) +mkMatchGroup origin matches = MG { mg_ext = origin + , mg_alts = matches } + +mkLamCaseMatchGroup :: AnnoBody p body + => Origin + -> HsLamVariant + -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] + -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) +mkLamCaseMatchGroup origin lam_variant (L l matches) + = mkMatchGroup origin (L l $ map fixCtxt matches) + where fixCtxt (L a match) = L a match{m_ctxt = LamAlt lam_variant} + +mkLocatedList :: (Semigroup a, NoAnn an) + => [GenLocated (EpAnn a) e2] -> LocatedAn an [GenLocated (EpAnn a) e2] +mkLocatedList ms = case nonEmpty ms of + Nothing -> noLocA [] + Just ms1 -> L (noAnnSrcSpan $ locA $ combineLocsA (NE.head ms1) (NE.last ms1)) ms + +mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkHsApp e1 e2 = addCLocA e1 e2 (HsApp noExtField e1 e2) + +mkHsAppWith + :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)) + -> LHsExpr (GhcPass id) + -> LHsExpr (GhcPass id) + -> LHsExpr (GhcPass id) +mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2) + +mkHsApps + :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +mkHsApps = mkHsAppsWith addCLocA + +mkHsAppsWith + :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)) + -> LHsExpr (GhcPass id) + -> [LHsExpr (GhcPass id)] + -> LHsExpr (GhcPass id) +mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated) + +mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn +mkHsAppType e t = addCLocA t_body e (HsAppType noExtField e paren_wct) + where + t_body = hswc_body t + paren_wct = t { hswc_body = t_body } + +mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn +mkHsAppTypes = foldl' mkHsAppType + +mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) + => LocatedE [LPat (GhcPass p)] + -> LHsExpr (GhcPass p) + -> LHsExpr (GhcPass p) +mkHsLam (L l pats) body = mkHsPar (L (getLoc body) (HsLam noAnn LamSingle matches)) + where + matches = mkMatchGroup (Generated OtherExpansion SkipPmc) + (noLocA [mkSimpleMatch (LamAlt LamSingle) (L l pats') body]) + pats' = map (parenthesizePat appPrec) pats + +mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc +mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars + <.> mkWpEvLams dicts) expr + +mkHsSyntaxApps :: SrcSpanAnnA -> SyntaxExprTc -> [LHsExpr GhcTc] + -> LHsExpr GhcTc +mkHsSyntaxApps ann (SyntaxExprTc { syn_expr = fun + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) args + = mkLHsWrap res_wrap (foldl' mkHsApp (L ann fun) (zipWithEqual mkLHsWrap arg_wraps args)) +mkHsSyntaxApps _ NoSyntaxExprTc args = pprPanic "mkHsSyntaxApps" (ppr args) + -- this function should never be called in scenarios where there is no + -- syntax expr + +-- |A simple case alternative with a single pattern, no binds, no guards; +-- pre-typechecking +mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ EpAnn NoEpAnns, + Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpanAnnA) + => LPat (GhcPass p) -> (LocatedA (body (GhcPass p))) + -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) +mkHsCaseAlt (L l pat) expr + = mkSimpleMatch CaseAlt (L (l2l l) [L l pat]) expr + +nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc +nlHsTyApp fun_id tys + = noLocA (mkHsWrap (mkWpTyApps tys) (mkHsVar (noLocA fun_id))) + +nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc +nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs + +--------- Adding parens --------- +-- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them +-- So @f x@ becomes @(f x)@, but @3@ stays as @3@. +mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsPar = parenthesizeHsExpr appPrec + +mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) +mkParPat = parenthesizePat appPrec + +nlParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) +nlParPat p = noLocA (gParPat p) + +------------------------------- +-- These are the bits of syntax that contain rebindable names +-- See GHC.Rename.Env.lookupSyntax + +mkHsIntegral :: IntegralLit -> HsOverLit GhcPs +mkHsFractional :: FractionalLit -> HsOverLit GhcPs +mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs +mkHsDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsDoAnns :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs +mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> HsExpr GhcPs +mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> AnnList EpaLocation + -> HsExpr GhcPs + +mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpToken "-" + -> Pat GhcPs +mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpToken "+" + -> Pat GhcPs + +-- NB: The following functions all use noSyntaxExpr: the generated expressions +-- will not work with rebindable syntax if used after the renamer +mkLastStmt :: IsPass idR => LocatedA (bodyR (GhcPass idR)) + -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR))) +mkBodyStmt :: LocatedA (bodyR GhcPs) + -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs)) +mkPsBindStmt :: EpUniToken "<-" "←" -> LPat GhcPs -> LocatedA (bodyR GhcPs) + -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs)) +mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn) + -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn)) +mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc) + -> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc)) + +emptyRecStmt :: (Anno [GenLocated + (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) + (StmtLR (GhcPass idL) GhcPs bodyR)] + ~ SrcSpanAnnLW) + => StmtLR (GhcPass idL) GhcPs bodyR +emptyRecStmtName :: (Anno [GenLocated + (Anno (StmtLR GhcRn GhcRn bodyR)) + (StmtLR GhcRn GhcRn bodyR)] + ~ SrcSpanAnnLW) + => StmtLR GhcRn GhcRn bodyR +emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) + +mkRecStmt :: forall (idL :: Pass) bodyR. + (Anno [GenLocated + (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) + (StmtLR (GhcPass idL) GhcPs bodyR)] + ~ SrcSpanAnnLW) + => AnnList (EpToken "rec") + -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR] + -> StmtLR (GhcPass idL) GhcPs bodyR +mkRecStmt anns stmts = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR) + { recS_stmts = stmts } + + +mkHsIntegral i = OverLit noExtField (HsIntegral i) +mkHsFractional f = OverLit noExtField (HsFractional f) +mkHsIsString src s = OverLit noExtField (HsIsString src s) + +mkHsDo ctxt stmts = HsDo noAnn ctxt stmts +mkHsDoAnns ctxt stmts anns = HsDo anns ctxt stmts +mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn +mkHsCompAnns ctxt stmts expr@(L l e) anns = mkHsDoAnns ctxt (L loc (stmts ++ [last_stmt])) anns + where + -- Move the annotations to the top of the last_stmt + last = mkLastStmt (L (noAnnSrcSpan $ getLocA expr) e) + last_stmt = L l last + -- last_stmt actually comes first in a list comprehension, consider all spans + loc = noAnnSrcSpan $ getHasLocList (last_stmt:stmts) + +-- restricted to GhcPs because other phases might need a SyntaxExpr +mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> AnnsIf + -> HsExpr GhcPs +mkHsIf c a b anns = HsIf anns c a b + +-- restricted to GhcPs because other phases might need a SyntaxExpr +mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> AnnsIf + -> HsCmd GhcPs +mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b + +mkNPat lit neg anns = NPat anns lit neg noSyntaxExpr +mkNPlusKPat id lit anns + = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr + +mkTransformStmt :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkTransformByStmt :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkGroupUsingStmt :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkGroupByUsingStmt :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) + +emptyTransStmt :: AnnTransStmt -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +emptyTransStmt anns = TransStmt { trS_ext = anns + , trS_form = panic "emptyTransStmt: form" + , trS_stmts = [], trS_bndrs = [] + , trS_by = Nothing, trS_using = noLocA noExpr + , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr + , trS_fmap = noExpr } +mkTransformStmt a ss u = (emptyTransStmt a) { trS_form = ThenForm, trS_stmts = ss, trS_using = u } +mkTransformByStmt a ss u b = (emptyTransStmt a) { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } +mkGroupUsingStmt a ss u = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u } +mkGroupByUsingStmt a ss b u = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } + +mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr +mkBodyStmt body + = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr +mkPsBindStmt ann pat body = BindStmt ann pat body +mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body +mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr, + xbstc_boundResultType = unitTy, + -- unitTy is a dummy value + -- can't panic here: it's forced during zonking + xbstc_boundResultMult = ManyTy, + xbstc_failOp = Nothing }) pat body + +emptyRecStmt' :: forall idL idR body . + (WrapXRec (GhcPass idR) [LStmtLR (GhcPass idL) (GhcPass idR) body], IsPass idR) + => XRecStmt (GhcPass idL) (GhcPass idR) body + -> StmtLR (GhcPass idL) (GhcPass idR) body +emptyRecStmt' tyVal = + RecStmt + { recS_stmts = wrapXRec @(GhcPass idR) [] + , recS_later_ids = [] + , recS_rec_ids = [] + , recS_ret_fn = noSyntaxExpr + , recS_mfix_fn = noSyntaxExpr + , recS_bind_fn = noSyntaxExpr + , recS_ext = tyVal } + +unitRecStmtTc :: RecStmtTc +unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy + , recS_later_rets = [] + , recS_rec_rets = [] + , recS_ret_ty = unitTy } + +emptyRecStmt = emptyRecStmt' noAnn +emptyRecStmtName = emptyRecStmt' noExtField +emptyRecStmtId = emptyRecStmt' unitRecStmtTc + -- a panic might trigger during zonking + +mkLetStmt :: EpToken "let" -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) +mkLetStmt anns binds = LetStmt anns binds + +------------------------------- +-- | A useful function for building @OpApps@. The operator is always a +-- variable, and we don't know the fixity yet. +mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs +mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLocA (mkHsVar (noLocA op))) e2 + +mkHsString :: String -> HsLit (GhcPass p) +mkHsString s = HsString NoSourceText (mkFastString s) + +mkHsStringFS :: FastString -> HsLit (GhcPass p) +mkHsStringFS s = HsString NoSourceText s + +mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) +mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) + +mkHsCharPrimLit :: Char -> HsLit (GhcPass p) +mkHsCharPrimLit c = HsChar NoSourceText c + +mkConLikeTc :: ConLike -> HsExpr GhcTc +mkConLikeTc con = XExpr (ConLikeTc con [] []) + +{- +************************************************************************ +* * + Constructing syntax with no location info +* * +************************************************************************ +-} + +nlHsVar :: IsSrcSpanAnn p a + => IdP (GhcPass p) -> LHsExpr (GhcPass p) +nlHsVar n = noLocA (mkHsVar (noLocA n)) + +-- | NB: Only for 'LHsExpr' 'Id'. +nlHsDataCon :: DataCon -> LHsExpr GhcTc +nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con)) + +nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) +nlHsLit n = noLocA (HsLit noExtField n) + +nlHsIntLit :: Integer -> LHsExpr (GhcPass p) +nlHsIntLit n = noLocA (HsLit noExtField (HsInt noExtField (mkIntegralLit n))) + +nlVarPat :: IsSrcSpanAnn p a + => IdP (GhcPass p) -> LPat (GhcPass p) +nlVarPat n = noLocA (VarPat noExtField (noLocA n)) + +nlLitPat :: HsLit GhcPs -> LPat GhcPs +nlLitPat l = noLocA (LitPat noExtField l) + +nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsApp f x = noLocA (HsApp noExtField f (mkLHsPar x)) + +nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc] + -> LHsExpr GhcTc +nlHsSyntaxApps = mkHsSyntaxApps noSrcSpanA + +nlHsApps :: IsSrcSpanAnn p a + => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) +nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs + +nlHsVarApps :: IsSrcSpanAnn p a + => IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p) +nlHsVarApps f xs = noLocA (foldl' mk (mkHsVar (noLocA f)) + (map (mkHsVar . noLocA) xs)) + where + mk f a = HsApp noExtField (noLocA f) (noLocA a) + +nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs +nlConVarPat con vars = nlConPat con (map nlVarPat vars) + +nlConVarPatName :: Name -> [Name] -> LPat GhcRn +nlConVarPatName con vars = nlConPatName con (map nlVarPat vars) + +nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs +nlInfixConPat con l r = noLocA $ ConPat + { pat_con = noLocA con + , pat_args = InfixCon (parenthesizePat opPrec l) + (parenthesizePat opPrec r) + , pat_con_ext = noAnn + } + +nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs +nlConPat con pats = noLocA $ ConPat + { pat_con_ext = noAnn + , pat_con = noLocA con + , pat_args = PrefixCon (map (parenthesizePat appPrec) pats) + } + +nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn +nlConPatName con pats = noLocA $ ConPat + { pat_con_ext = noExtField + , pat_con = noLocA (noUserRdr con) + , pat_args = PrefixCon (map (parenthesizePat appPrec) pats) + } + +nlNullaryConPat :: RdrName -> LPat GhcPs +nlNullaryConPat con = noLocA $ ConPat + { pat_con_ext = noAnn + , pat_con = noLocA con + , pat_args = PrefixCon [] + } + +nlWildConPat :: DataCon -> LPat GhcPs +nlWildConPat con = noLocA $ ConPat + { pat_con_ext = noAnn + , pat_con = noLocA $ getRdrName con + , pat_args = PrefixCon $ + replicate (dataConSourceArity con) + nlWildPat + } + +-- | Wildcard pattern - after parsing +nlWildPat :: LPat GhcPs +nlWildPat = noLocA (WildPat noExtField ) + +-- | Wildcard pattern - after renaming +nlWildPatName :: LPat GhcRn +nlWildPatName = noLocA (WildPat noExtField ) + +nlHsDo :: HsDoFlavour -> [LStmt GhcPs (LHsExpr GhcPs)] + -> LHsExpr GhcPs +nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts)) + +nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2) + +nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs +nlHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsExpr GhcPs +nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs + +nlHsLam match = noLocA $ HsLam noAnn LamSingle + $ mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [match]) + +nlHsPar e = noLocA (gHsPar e) + +-- nlHsIf should generate if-expressions which are NOT subject to +-- RebindableSyntax, so the first field of HsIf is False. (#12080) +nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +nlHsIf cond true false = noLocA (HsIf noAnn cond true false) + +nlHsCase expr matches + = noLocA (HsCase noAnn expr (mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA matches))) +nlList exprs = noLocA (ExplicitList noAnn exprs) + +nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsTyVar :: forall p a. IsSrcSpanAnn p a + => PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p) +nlHsFunTy :: forall p. IsPass p + => LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) + +nlHsAppTy f t = noLocA (HsAppTy noExtField f t) +nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA $ noUserRdrP @p x)) +nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnannotated x) a b) + where + x = case ghcPass @p of + GhcPs -> EpArrow noAnn + GhcRn -> noExtField + GhcTc -> manyDataConTy +nlHsParTy t = noLocA (HsParTy noAnn t) + +nlHsTyConApp :: forall p a. IsSrcSpanAnn p a + => PromotionFlag + -> LexicalFixity -> IdOccP (GhcPass p) + -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p) +nlHsTyConApp prom fixity tycon tys + | Infix <- fixity + , HsValArg _ ty1 : HsValArg _ ty2 : rest <- tys + = foldl' mk_app (noLocA $ HsOpTy noExtField prom ty1 (noLocA tycon) ty2) rest + | otherwise + = foldl' mk_app (nlHsTyVar prom $ forgetUserRdr @p tycon) tys + where + mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p) + mk_app fun@(L _ (HsOpTy {})) arg = mk_app (nlHsParTy fun) arg + -- parenthesize things like `(A + B) C` + mk_app fun (HsValArg _ ty) = nlHsAppTy fun ty + mk_app fun (HsTypeArg _ ki) = nlHsAppKindTy fun ki + mk_app fun (HsArgPar _) = nlHsParTy fun + +-- | Turn an 'IdP' into an 'IdOccP', with no user-written 'RdrName' information. +noUserRdrP :: forall p. IsPass p => IdP (GhcPass p) -> IdOccP (GhcPass p) +noUserRdrP = + case ghcPass @p of + GhcPs -> id + GhcRn -> noUserRdr + GhcTc -> id + +-- | Turn an 'IdOccP' into an 'IdP', discarding the user-written 'RdrName'. +forgetUserRdr :: forall p. IsPass p => IdOccP (GhcPass p) -> IdP (GhcPass p) +forgetUserRdr = + case ghcPass @p of + GhcPs -> id + GhcRn -> \ (WithUserRdr _rdr n) -> n + GhcTc -> id + +nlHsAppKindTy :: forall p. IsPass p => + LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) +nlHsAppKindTy f k = noLocA (HsAppKindTy x f k) + where + x = case ghcPass @p of + GhcPs -> noAnn + GhcRn -> noExtField + GhcTc -> noExtField + +{- +Tuples. All these functions are *pre-typechecker* because they lack +types on the tuple. +-} + +mkLHsTupleExpr :: [LHsExpr (GhcPass p)] -> XExplicitTuple (GhcPass p) + -> LHsExpr (GhcPass p) +-- Makes a pre-typechecker boxed tuple, deals with 1 case +mkLHsTupleExpr [e] _ = e +mkLHsTupleExpr es ext + = noLocA $ ExplicitTuple ext (map (Present noExtField) es) Boxed + +mkLHsVarTuple :: IsSrcSpanAnn p a + => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p) + -> LHsExpr (GhcPass p) +mkLHsVarTuple ids ext = mkLHsTupleExpr (map nlHsVar ids) ext + +nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs +nlTuplePat pats box = noLocA (TuplePat noAnn pats box) + +missingTupArg :: EpAnn Bool -> HsTupArg GhcPs +missingTupArg ann = Missing ann + +mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn +mkLHsPatTup [] = noLocA $ TuplePat noExtField [] Boxed +mkLHsPatTup [lpat] = lpat +mkLHsPatTup lpats@(lpat:_) = L (getLoc lpat) $ TuplePat noExtField lpats Boxed + +-- | The Big equivalents for the source tuple expressions +mkBigLHsVarTup :: IsSrcSpanAnn p a + => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p) + -> LHsExpr (GhcPass p) +mkBigLHsVarTup ids anns = mkBigLHsTup (map nlHsVar ids) anns + +mkBigLHsTup :: [LHsExpr (GhcPass id)] -> XExplicitTuple (GhcPass id) + -> LHsExpr (GhcPass id) +mkBigLHsTup es anns = mkChunkified (\e -> mkLHsTupleExpr e anns) es + +-- | The Big equivalents for the source tuple patterns +mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn +mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) + +mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn +mkBigLHsPatTup = mkChunkified mkLHsPatTup + +{- +************************************************************************ +* * + LHsSigType and LHsSigWcType +* * +********************************************************************* -} + +-- | Convert an 'LHsType' to an 'LHsSigType'. +hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs +hsTypeToHsSigType lty@(L loc ty) = case ty of + HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an + , hsf_invis_bndrs = bndrs } + , hst_body = body } + -> L loc $ mkHsExplicitSigType an bndrs body + _ -> L (l2l loc) $ mkHsImplicitSigType lty -- The annotations are in lty, erase them from loc + +-- | Convert an 'LHsType' to an 'LHsSigWcType'. +hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs +hsTypeToHsSigWcType = mkHsWildCardBndrs . hsTypeToHsSigType + +mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([LocatedN Name], a)) + -> [LSig GhcRn] + -> NameEnv a +mkHsSigEnv get_info sigs + = mkNameEnv (mk_pairs ordinary_sigs) + `extendNameEnvList` (mk_pairs gen_dm_sigs) + -- The subtlety is this: in a class decl with a + -- default-method signature as well as a method signature + -- we want the latter to win (#12533) + -- class C x where + -- op :: forall a . x a -> x a + -- default op :: forall b . x b -> x b + -- op x = ...(e :: b -> b)... + -- The scoped type variables of the 'default op', namely 'b', + -- scope over the code for op. The 'forall a' does not! + -- This applies both in the renamer and typechecker, both + -- of which use this function + where + (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs + is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True + is_gen_dm_sig _ = False + + mk_pairs :: [LSig GhcRn] -> [(Name, a)] + mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs + , L _ n <- ns ] + +mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] +-- ^ Convert 'TypeSig' to 'ClassOpSig'. +-- The former is what is parsed, but the latter is +-- what we need in class/instance declarations +mkClassOpSigs sigs + = map fiddle sigs + where + fiddle (L loc (TypeSig anns nms ty)) + = L loc (ClassOpSig anns False nms (dropWildCards ty)) + fiddle sig = sig + + +-- | Type ascription: (e :: ty) +nlAscribe :: RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs +nlAscribe ty e = noLocA $ ExprWithTySig noAnn e + $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType + $ nlHsTyVar NotPromoted ty + +{- ********************************************************************* +* * + --------- HsWrappers: type args, dict args, casts --------- +* * +********************************************************************* -} + +mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc +mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) + +mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc +mkHsWrap co_fn e | isIdHsWrapper co_fn = e +mkHsWrap co_fn e = XExpr (WrapExpr co_fn e) + +mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b + -> HsExpr GhcTc -> HsExpr GhcTc +mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e + +mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b + -> HsExpr GhcTc -> HsExpr GhcTc +mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e + +mkLHsWrapCo :: TcCoercionN -> LHsExpr GhcTc -> LHsExpr GhcTc +mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) + +mkHsCmdWrap :: HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc +mkHsCmdWrap w cmd | isIdHsWrapper w = cmd + | otherwise = XCmd (HsWrap w cmd) + +mkLHsCmdWrap :: HsWrapper -> LHsCmd GhcTc -> LHsCmd GhcTc +mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) + +mkHsWrapPat :: HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc +mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p + | otherwise = XPat $ CoPat co_fn p ty + +mkLHsWrapPat :: HsWrapper -> LPat GhcTc -> Type -> LPat GhcTc +mkLHsWrapPat co_fn (L loc p) ty = L loc (mkHsWrapPat co_fn p ty) + +mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc +mkHsWrapPatCo co pat ty | isReflCo co = pat + | otherwise = XPat $ CoPat (mkWpCastN co) pat ty + +mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc +mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr + +{- +l +************************************************************************ +* * + Bindings; with a location at the top +* * +************************************************************************ +-} + +mkFunBind :: Origin -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> HsBind GhcPs +-- ^ Not infix, with place holders for coercion and free vars +mkFunBind origin fn ms + = FunBind { fun_id = fn + , fun_matches = mkMatchGroup origin (noLocA ms) + , fun_ext = noExtField + } + +mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)] + -> HsBind GhcRn +-- ^ In Name-land, with empty bind_fvs +mkTopFunBind origin fn ms = FunBind { fun_id = fn + , fun_matches = mkMatchGroup origin (noLocA ms) + , fun_ext = emptyNameSet -- NB: closed + -- binding + } + +mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs +mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var (noLocA []) rhs + +mkVarBind :: IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc +mkVarBind var rhs = L (getLoc rhs) $ + VarBind { var_ext = noExtField, + var_id = var, var_rhs = rhs } + +mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs + -> LPat GhcPs -> HsPatSynDir GhcPs -> AnnPSB -> HsBind GhcPs +mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb + where + psb = PSB{ psb_ext = anns + , psb_id = name + , psb_args = details + , psb_def = lpat + , psb_dir = dir } + +-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is +-- considered infix. +isInfixFunBind :: HsBindLR (GhcPass p1) (GhcPass p2) -> Bool +isInfixFunBind (FunBind { fun_matches = MG _ matches }) + = any (isInfixMatch . unLoc) (unLoc matches) +isInfixFunBind _ = False + +-- |Return the 'SrcSpan' encompassing the contents of any enclosed binds +spanHsLocaLBinds :: HsLocalBinds (GhcPass p) -> SrcSpan +spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan +spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) + = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans) + where + bsSpans :: [SrcSpan] + bsSpans = map getLocA bs + sigsSpans :: [SrcSpan] + sigsSpans = map getLocA sigs +spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs))) + = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans) + where + bsSpans :: [SrcSpan] + bsSpans = map getLocA $ concatMap snd bs + sigsSpans :: [SrcSpan] + sigsSpans = map getLocA sigs +spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) + = foldr combineSrcSpans noSrcSpan (map getLocA bs) + +------------ +-- | Convenience function using 'mkFunBind'. +-- This is for generated bindings only, do not use for user-written code. +mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> LocatedE [LPat GhcPs] + -> LHsExpr GhcPs -> LHsBind GhcPs +mkSimpleGeneratedFunBind loc fun pats expr + = L (noAnnSrcSpan loc) $ mkFunBind (Generated OtherExpansion SkipPmc) (L (noAnnSrcSpan loc) fun) + [mkMatch ctxt pats expr emptyLocalBinds] + where + ctxt :: HsMatchContextPs + ctxt = mkPrefixFunRhs (L (noAnnSrcSpan loc) fun) noAnn + +-- | Make a prefix, non-strict function 'HsMatchContext' +mkPrefixFunRhs :: fn -> AnnFunRhs -> HsMatchContext fn +mkPrefixFunRhs n an = FunRhs { mc_fun = n + , mc_fixity = Prefix + , mc_strictness = NoSrcStrict + , mc_an = an } + +------------ +mkMatch :: forall p. IsPass p + => HsMatchContext (LIdP (NoGhcTc (GhcPass p))) + -> LocatedE [LPat (GhcPass p)] + -> LHsExpr (GhcPass p) + -> HsLocalBinds (GhcPass p) + -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) +mkMatch ctxt pats expr binds + = noLocA (Match { m_ext = noExtField + , m_ctxt = ctxt + , m_pats = pats + , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds }) + +{- +************************************************************************ +* * + Collecting binders +* * +************************************************************************ + +Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg. + +... +where + (x, y) = ... + f i j = ... + [a, b] = ... + +it should return [x, y, f, a, b] (remember, order important). + +Note [Collect binders only after renaming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions should only be used on HsSyn *after* the renamer, +to return a [Name] or [Id]. Before renaming the record punning +and wild-card mechanism makes it hard to know what is bound. +So these functions should not be applied to (HsSyn RdrName) + +Note [isUnliftedHsBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function isUnliftedHsBind tells if the binding binds a variable of +unlifted type. e.g. + + - I# x = blah + - Just (I# x) = blah + +isUnliftedHsBind is used in two ways: + +* To complain if we make a top-level binding for a variable of unlifted + type. E.g. any of the above bindings are illegal at top level + +* To generate a case expression for a non-recursive local let. E.g. + let Just (I# x) = blah in body + ==> + case blah of Just (I# x) -> body + See GHC.HsToCore.Expr.dsUnliftedBind. + +Wrinkles: + +(W1) For AbsBinds we must check if the local letrec generated by desugaring + AbsBinds would be unlifted; so we just recurse into the abs_binds. E.g. + f :: Num a => (# a, a #) + g :: Num a => a -> a + f = ...g... + g = ...g... + + The top-level bindings for f,g are not unlifted (because of the Num a =>), + but the local, recursive, monomorphic bindings are: + t = /\a \(d:Num a). + letrec fm :: (# a, a #) = ...g... + gm :: a -> a = ...f... + in (fm, gm) + + Here the binding for 'fm' is illegal. So we recurse into the abs_binds + +(W2) BUT we have a special case when abs_sig is true; + see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds + +(W3) isUnliftedHsBind returns False even if the binding itself is + unlifted, provided it binds only lifted variables. E.g. + - (# a,b #) = (# reverse xs, xs #) + + - x = sqrt# y# :: Float# + + - type Unl :: UnliftedType + data Unl = MkUnl Int + MkUnl z = blah + + In each case the RHS of the "=" has unlifted type, but isUnliftedHsBind + returns False. Reason: see GHC Proposal #35 + https://github.com/ghc-proposals/ghc-proposals/blob/master/ + proposals/0035-unbanged-strict-patterns.rst + +(W4) In particular, (W3) applies to a pattern that binds no variables at all. + So { _ = sqrt# y :: Float# } returns False from isUnliftedHsBind, but + { x = sqrt# y :: Float# } returns True. + This is arguably a bit confusing (see #22719) +-} + +----------------- Bindings -------------------------- + +-- | Should we treat this as an unlifted bind? This will be true for any +-- bind that binds an unlifted variable, but we must be careful around +-- AbsBinds. See Note [isUnliftedHsBind]. For usage +-- information, see Note [Strict binds checks] is GHC.HsToCore.Binds. +isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds +isUnliftedHsBind (XHsBindsLR (AbsBinds { abs_exports = exports + , abs_sig = has_sig + , abs_binds = binds })) + | has_sig = any (is_unlifted_id . abe_poly) exports + | otherwise = isUnliftedHsBinds binds + -- See wrinkle (W1) and (W2) in Note [isUnliftedHsBind] + -- If has_sig is True we will never generate a binding for abe_mono, + -- so we don't need to worry about it being unlifted. The abe_poly + -- binding might not be: e.g. forall a. Num a => (# a, a #) + -- If has_sig is False, just recurse + +isUnliftedHsBind (FunBind { fun_id = L _ fun }) + = is_unlifted_id fun + +isUnliftedHsBind (VarBind { var_id = var }) + = is_unlifted_id var + +isUnliftedHsBind (PatBind { pat_lhs = pat }) + = any is_unlifted_id (collectPatBinders CollNoDictBinders pat) + -- If we changed our view on (W3) you could add + -- || isUnliftedType pat_ty + -- to this check + +isUnliftedHsBind (PatSynBind {}) = panic "isUnliftedBind: PatSynBind" + +isUnliftedHsBinds :: LHsBinds GhcTc -> Bool +isUnliftedHsBinds = any (isUnliftedHsBind . unLoc) + +is_unlifted_id :: Id -> Bool +is_unlifted_id id = isUnliftedType (idType id) + -- Bindings always have a fixed RuntimeRep, so it's OK + -- to call isUnliftedType here + +-- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)? +isBangedHsBind :: HsBind GhcTc -> Bool +isBangedHsBind (XHsBindsLR (AbsBinds { abs_binds = binds })) + = any (isBangedHsBind . unLoc) binds +isBangedHsBind (FunBind {fun_matches = matches}) + | [L _ match] <- unLoc $ mg_alts matches + , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match + = True +isBangedHsBind (PatBind {pat_lhs = pat}) + = isBangedLPat pat +isBangedHsBind _ + = False + +collectLocalBinders :: CollectPass (GhcPass idL) + => CollectFlag (GhcPass idL) + -> HsLocalBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] +collectLocalBinders flag = \case + HsValBinds _ binds -> collectHsIdBinders flag binds + -- No pattern synonyms here + HsIPBinds {} -> [] + EmptyLocalBinds _ -> [] + +collectHsIdBinders :: CollectPass (GhcPass idL) + => CollectFlag (GhcPass idL) + -> HsValBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] +-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively +collectHsIdBinders flag = collect_hs_val_binders True flag + +collectHsValBinders :: CollectPass (GhcPass idL) + => CollectFlag (GhcPass idL) + -> HsValBindsLR (GhcPass idL) idR + -> [IdP (GhcPass idL)] +collectHsValBinders flag = collect_hs_val_binders False flag + +collectHsBindBinders :: CollectPass p + => CollectFlag p + -> HsBindLR p idR + -> [IdP p] +-- ^ Collect both 'Id's and pattern-synonym binders +collectHsBindBinders flag b = collect_bind False flag b [] + +collectHsBindsBinders :: CollectPass p + => CollectFlag p + -> LHsBindsLR p idR + -> [IdP p] +collectHsBindsBinders flag binds = collect_binds False flag binds [] + +collectHsBindListBinders :: forall p idR. CollectPass p + => CollectFlag p + -> [LHsBindLR p idR] + -> [IdP p] +-- ^ Same as 'collectHsBindsBinders', but works over a list of bindings +collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) [] + +collect_hs_val_binders :: CollectPass (GhcPass idL) + => Bool + -> CollectFlag (GhcPass idL) + -> HsValBindsLR (GhcPass idL) idR + -> [IdP (GhcPass idL)] +collect_hs_val_binders ps flag = \case + ValBinds _ binds _ -> collect_binds ps flag binds [] + XValBindsLR (NValBinds binds _) -> collect_out_binds ps flag binds + +collect_out_binds :: forall p. CollectPass p + => Bool + -> CollectFlag p + -> [(RecFlag, LHsBinds p)] + -> [IdP p] +collect_out_binds ps flag = foldr (collect_binds ps flag . snd) [] + +collect_binds :: forall p idR. CollectPass p + => Bool + -> CollectFlag p + -> LHsBindsLR p idR + -> [IdP p] + -> [IdP p] +-- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag +collect_binds ps flag binds acc = foldr (collect_bind ps flag . unXRec @p) acc binds + +collect_bind :: forall p idR. CollectPass p + => Bool + -> CollectFlag p + -> HsBindLR p idR + -> [IdP p] + -> [IdP p] +collect_bind _ _ (FunBind { fun_id = f }) acc = unXRec @p f : acc +collect_bind _ flag (PatBind { pat_lhs = p }) acc = collect_lpat flag p acc +collect_bind _ _ (VarBind { var_id = f }) acc = f : acc +collect_bind omitPatSyn _ (PatSynBind _ (PSB { psb_id = ps })) acc + | omitPatSyn = acc + | otherwise = unXRec @p ps : acc +collect_bind _ _ (PatSynBind _ (XPatSynBind _)) acc = acc +collect_bind _ _ (XHsBindsLR b) acc = collectXXHsBindsLR @p @idR b acc + + +collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL] +-- ^ Used exclusively for the bindings of an instance decl which are all +-- 'FunBinds' +collectMethodBinders binds = foldr (get . unXRec @idL) [] binds + where + get (FunBind { fun_id = f }) fs = f : fs + get _ fs = fs + -- Someone else complains about non-FunBinds + +----------------- Statements -------------------------- +-- +collectLStmtsBinders + :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> [LStmtLR (GhcPass idL) (GhcPass idR) body] + -> [IdP (GhcPass idL)] +collectLStmtsBinders flag = concatMap (collectLStmtBinders flag) + +collectStmtsBinders + :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> [StmtLR (GhcPass idL) (GhcPass idR) body] + -> [IdP (GhcPass idL)] +collectStmtsBinders flag = concatMap (collectStmtBinders flag) + +collectLStmtBinders + :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> LStmtLR (GhcPass idL) (GhcPass idR) body + -> [IdP (GhcPass idL)] +collectLStmtBinders flag = collectStmtBinders flag . unLoc + +collectStmtBinders + :: forall idL idR body . (IsPass idL, IsPass idR, CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> StmtLR (GhcPass idL) (GhcPass idR) body + -> [IdP (GhcPass idL)] + -- Id Binders for a Stmt... [but what about pattern-sig type vars]? +collectStmtBinders flag = \case + BindStmt _ pat _ -> collectPatBinders flag pat + LetStmt _ binds -> collectLocalBinders flag binds + BodyStmt {} -> [] + LastStmt {} -> [] + ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss] + TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts + RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss + XStmtLR x -> case ghcPass :: GhcPass idR of + GhcRn -> collectApplicativeStmtBndrs x + GhcTc -> collectApplicativeStmtBndrs x + where + collectApplicativeStmtBndrs :: ApplicativeStmt (GhcPass idL) a -> [IdP (GhcPass idL)] + collectApplicativeStmtBndrs (ApplicativeStmt _ args _) = concatMap (collectArgBinders . snd) args + + collectArgBinders = \case + ApplicativeArgOne { app_arg_pattern = pat } -> collectPatBinders flag pat + ApplicativeArgMany { bv_pattern = pat } -> collectPatBinders flag pat + +----------------- Patterns -------------------------- + +collectPatBinders + :: CollectPass p + => CollectFlag p + -> LPat p + -> [IdP p] +collectPatBinders flag pat = collect_lpat flag pat [] + +collectPatsBinders + :: CollectPass p + => CollectFlag p + -> [LPat p] + -> [IdP p] +collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats + +------------- + +-- | Indicate if evidence binders and type variable binders have +-- to be collected. +-- +-- This type enumerates the modes of collecting bound variables +-- | evidence | type | term | ghc | +-- | binders | variables | variables | pass | +-- -------------------------------------------- +-- CollNoDictBinders | no | no | yes | any | +-- CollWithDictBinders | yes | no | yes | GhcTc | +-- CollVarTyVarBinders | no | yes | yes | GhcRn | +-- +-- See Note [Dictionary binders in ConPatOut] +data CollectFlag p where + -- | Don't collect evidence binders + CollNoDictBinders :: CollectFlag p + -- | Collect evidence binders + CollWithDictBinders :: CollectFlag GhcTc + -- | Collect variable and type variable binders, but no evidence binders + CollVarTyVarBinders :: CollectFlag GhcRn + + +collect_lpat :: forall p. CollectPass p + => CollectFlag p + -> LPat p + -> [IdP p] + -> [IdP p] +collect_lpat flag pat bndrs = collect_pat flag (unXRec @p pat) bndrs + +collect_pat :: forall p. CollectPass p + => CollectFlag p + -> Pat p + -> [IdP p] + -> [IdP p] +collect_pat flag pat bndrs = case pat of + VarPat _ var -> unXRec @p var : bndrs + WildPat _ -> bndrs + LazyPat _ pat -> collect_lpat flag pat bndrs + BangPat _ pat -> collect_lpat flag pat bndrs + AsPat _ a pat -> unXRec @p a : collect_lpat flag pat bndrs + ViewPat _ _ pat -> collect_lpat flag pat bndrs + ParPat _ pat -> collect_lpat flag pat bndrs + ListPat _ pats -> foldr (collect_lpat flag) bndrs pats + TuplePat _ pats _ -> foldr (collect_lpat flag) bndrs pats + OrPat _ _ -> [] + -- See Note [Implementation of OrPatterns], Renamer: + -- evidence binders in an OrPat currently aren't visible outside their + -- binding pattern, so we return []. + SumPat _ pat _ _ -> collect_lpat flag pat bndrs + LitPat _ _ -> bndrs + NPat {} -> bndrs + NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs + SigPat _ pat sig -> case flag of + CollNoDictBinders -> collect_lpat flag pat bndrs + CollWithDictBinders -> collect_lpat flag pat bndrs + CollVarTyVarBinders -> collect_lpat flag pat bndrs ++ collectPatSigBndrs sig + XPat ext -> collectXXPat @p flag ext bndrs + SplicePat ext _ -> collectXSplicePat @p flag ext bndrs + EmbTyPat _ tp -> collect_ty_pat_bndrs flag tp bndrs + InvisPat _ tp -> collect_ty_pat_bndrs flag tp bndrs + + -- See Note [Dictionary binders in ConPatOut] + ConPat {pat_args=ps} -> case flag of + CollNoDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) + CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) + ++ collectEvBinders (cpt_binds (pat_con_ext pat)) + CollVarTyVarBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) + +collectEvBinders :: TcEvBinds -> [Id] +collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs +collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" + +collect_ty_pat_bndrs :: CollectFlag p -> HsTyPat (NoGhcTc p) -> [IdP p] -> [IdP p] +collect_ty_pat_bndrs CollNoDictBinders _ bndrs = bndrs +collect_ty_pat_bndrs CollWithDictBinders _ bndrs = bndrs +collect_ty_pat_bndrs CollVarTyVarBinders tp bndrs = collectTyPatBndrs tp ++ bndrs + +collectTyPatBndrs :: HsTyPat GhcRn -> [Name] +collectTyPatBndrs (HsTP (HsTPRn nwcs imp_tvs exp_tvs) _) = nwcs ++ imp_tvs ++ exp_tvs + +collectPatSigBndrs :: HsPatSigType GhcRn -> [Name] +collectPatSigBndrs (HsPS (HsPSRn nwcs imp_tvs) _) = nwcs ++ imp_tvs + +add_ev_bndr :: EvBind -> [Id] -> [Id] +add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs + | otherwise = bs + -- A worry: what about coercion variable binders?? + + +-- | This class specifies how to collect variable identifiers from extension patterns in the given pass. +-- Consumers of the GHC API that define their own passes should feel free to implement instances in order +-- to make use of functions which depend on it. +-- +-- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that +-- it can reuse the code in GHC for collecting binders. +class UnXRec p => CollectPass p where + collectXXPat :: CollectFlag p -> XXPat p -> [IdP p] -> [IdP p] + collectXXHsBindsLR :: forall pR. XXHsBindsLR p pR -> [IdP p] -> [IdP p] + collectXSplicePat :: CollectFlag p -> XSplicePat p -> [IdP p] -> [IdP p] + +instance IsPass p => CollectPass (GhcPass p) where + collectXXPat flag ext = + case ghcPass @p of + GhcPs -> dataConCantHappen ext + GhcRn + | HsPatExpanded _ pat <- ext + -> collect_pat flag pat + GhcTc -> case ext of + CoPat _ pat _ -> collect_pat flag pat + ExpansionPat _ pat -> collect_pat flag pat + collectXXHsBindsLR ext = + case ghcPass @p of + GhcPs -> dataConCantHappen ext + GhcRn -> dataConCantHappen ext + GhcTc -> case ext of + AbsBinds { abs_exports = dbinds } -> (map abe_poly dbinds ++) + -- I don't think we want the binders from the abe_binds + -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Zonk.Type + + collectXSplicePat flag ext = + case ghcPass @p of + GhcPs -> id + GhcRn | (HsUntypedSpliceTop _ pat) <- ext -> collect_pat flag pat + GhcRn | (HsUntypedSpliceNested _) <- ext -> id + GhcTc -> dataConCantHappen ext + + +{- +Note [Dictionary binders in ConPatOut] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Should we collect dictionary binders in ConPatOut? It depends! Use CollectFlag +to choose. + +1. Pre-typechecker there are no ConPatOuts. Use CollNoDictBinders flag. + +2. In the desugarer, most of the time we don't want to collect evidence binders, + so we also use CollNoDictBinders flag. + + Example of why it matters: + + In a lazy pattern, for example f ~(C x y) = ..., we want to generate bindings + for x,y but not for dictionaries bound by C. + (The type checker ensures they would not be used.) + + Here's the problem. Consider + + data T a where + C :: Num a => a -> Int -> T a + + f ~(C (n+1) m) = (n,m) + + Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), + and *also* uses that dictionary to match the (n+1) pattern. Yet, the + variables bound by the lazy pattern are n,m, *not* the dictionary d. + So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the + variables bound. + + So in this case, we do *not* gather (a) dictionary and (b) dictionary + bindings as binders of a ConPatOut pattern. + + +3. On the other hand, desugaring of arrows needs evidence bindings and uses + CollWithDictBinders flag. + + Consider + + h :: (ArrowChoice a, Arrow a) => Int -> a (Int,Int) Int + h x = proc (y,z) -> case compare x y of + GT -> returnA -< z+x + + The type checker turns the case into + + case compare x y of + GT { $dNum_123 = $dNum_Int } -> returnA -< (+) $dNum_123 z x + + That is, it attaches the $dNum_123 binding to a ConPatOut in scope. + + During desugaring, evidence binders must be collected because their sets are + intersected with free variable sets of subsequent commands to create + (minimal) command environments. Failing to do it properly leads to bugs + (e.g., #18950). + + Note: attaching evidence binders to existing ConPatOut may be suboptimal for + arrows. In the example above we would prefer to generate: + + case compare x y of + GT -> returnA -< let $dNum_123 = $dNum_Int in (+) $dNum_123 z x + + So that the evidence isn't passed into the command environment. This issue + doesn't arise with desugaring of non-arrow code because the simplifier can + freely float and inline let-expressions created for evidence binders. But + with arrow desugaring, the simplifier would have to see through the command + environment tuple which is more complicated. + +-} + +hsGroupBinders :: HsGroup GhcRn -> [Name] +hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, + hs_fords = foreign_decls }) + = collectHsValBinders CollNoDictBinders val_decls + ++ hsTyClForeignBinders tycl_decls foreign_decls + +hsTyClForeignBinders :: [TyClGroup GhcRn] + -> [LForeignDecl GhcRn] + -> [Name] +-- We need to look at instance declarations too, +-- because their associated types may bind data constructors +hsTyClForeignBinders tycl_decls foreign_decls + = map unLoc (hsForeignDeclsBinders foreign_decls) + ++ getSelectorNames + (foldMap (foldMap (tyDeclBinders . hsLTyClDeclBinders) . group_tyclds) tycl_decls + `mappend` + (foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)) + where + getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name] + getSelectorNames (ns, fs) = map unLoc ns ++ map (unLoc . foLabel . unLoc) fs + +------------------- + +data TyDeclBinders p + = TyDeclBinders + { tyDeclMainBinder :: !(LocatedA (IdP (GhcPass p)), TyConFlavour ()) + , tyDeclATs :: ![(LocatedA (IdP (GhcPass p)), TyConFlavour ())] + , tyDeclOpSigs :: ![LocatedA (IdP (GhcPass p))] + , tyDeclConsWithFields :: !(LConsWithFields p) } + +tyDeclBinders :: TyDeclBinders p -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) +tyDeclBinders (TyDeclBinders main ats sigs consWithFields) + = (fst main : (fmap fst ats ++ sigs ++ cons), flds) + where + (cons, flds) = lconsWithFieldsBinders consWithFields + +hsLTyClDeclBinders :: (IsPass p, OutputableBndrId p) + => LocatedA (TyClDecl (GhcPass p)) + -> TyDeclBinders p +-- ^ Returns all the /binding/ names of the decl. The first one is +-- guaranteed to be the name of the decl. The first component +-- represents all binding names except record fields; the second +-- represents field occurrences. For record fields mentioned in +-- multiple constructors, the SrcLoc will be from the first occurrence. +-- +-- Each returned (Located name) has a SrcSpan for the /whole/ declaration. +-- See Note [SrcSpan for binders] + +hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl + { fdLName = (L _ name) + , fdInfo = fd_info } })) + = TyDeclBinders + { tyDeclMainBinder = (L loc name, familyInfoTyConFlavour Nothing fd_info) + , tyDeclATs = [], tyDeclOpSigs = [] + , tyDeclConsWithFields = emptyLConsWithFields } +hsLTyClDeclBinders (L loc (SynDecl + { tcdLName = (L _ name) })) + = TyDeclBinders + { tyDeclMainBinder = (L loc name, TypeSynonymFlavour) + , tyDeclATs = [], tyDeclOpSigs = [] + , tyDeclConsWithFields = emptyLConsWithFields } +hsLTyClDeclBinders (L loc (ClassDecl + { tcdLName = (L _ cls_name) + , tcdSigs = sigs + , tcdATs = ats })) + = TyDeclBinders + { tyDeclMainBinder = (L loc cls_name, ClassFlavour) + , tyDeclATs = [ (L fam_loc fam_name, familyInfoTyConFlavour (Just ()) fd_info) + | (L fam_loc (FamilyDecl { fdLName = L _ fam_name + , fdInfo = fd_info })) <- ats ] + , tyDeclOpSigs = [ L mem_loc mem_name + | (L mem_loc (ClassOpSig _ False ns _)) <- sigs + , (L _ mem_name) <- ns ] + , tyDeclConsWithFields = emptyLConsWithFields } +hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name) + , tcdDataDefn = defn })) + = TyDeclBinders + { tyDeclMainBinder = (L loc name, flav ) + , tyDeclATs = [] + , tyDeclOpSigs = [] + , tyDeclConsWithFields = hsDataDefnBinders defn } + where + flav = newOrDataToFlavour $ dataDefnConsNewOrData $ dd_cons defn + +------------------- +hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a) + => [LForeignDecl (GhcPass p)] -> [LIdP (GhcPass p)] +-- ^ See Note [SrcSpan for binders] +hsForeignDeclsBinders foreign_decls + = [ L (noAnnSrcSpan (locA decl_loc)) n + | L decl_loc (ForeignImport { fd_name = L _ n }) + <- foreign_decls] + + +------------------- +hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)] +-- ^ Collects record pattern-synonym selectors only; the pattern synonym +-- names are collected by 'collectHsValBinders'. +hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" +hsPatSynSelectors (XValBindsLR (NValBinds binds _)) + = foldr addPatSynSelector [] . concat $ map snd binds + +addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p] +addPatSynSelector bind sels + | PatSynBind _ (PSB { psb_args = RecCon as }) <- unXRec @p bind + = map recordPatSynField as ++ sels + | otherwise = sels + +getPatSynBinds :: forall id. UnXRec id + => [(RecFlag, LHsBinds id)] -> [PatSynBind id id] +getPatSynBinds binds + = [ psb | (_, lbinds) <- binds + , (unXRec @id -> (PatSynBind _ psb)) <- lbinds ] + +------------------- +hsLInstDeclBinders :: (IsPass p, OutputableBndrId p) + => LInstDecl (GhcPass p) + -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)]) +hsLInstDeclBinders (L _ (ClsInstD + { cid_inst = ClsInstDecl + { cid_datafam_insts = dfis }})) + = foldMap (lconsWithFieldsBinders . hsDataFamInstBinders . unLoc) dfis +hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) + = lconsWithFieldsBinders $ hsDataFamInstBinders fi +hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty + +------------------- +-- | the 'SrcLoc' returned are for the whole declarations, not just the names +hsDataFamInstBinders :: (IsPass p, OutputableBndrId p) + => DataFamInstDecl (GhcPass p) + -> LConsWithFields p +hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }}) + = hsDataDefnBinders defn + -- There can't be repeated symbols because only data instances have binders + +------------------- +-- | the 'SrcLoc' returned are for the whole declarations, not just the names +hsDataDefnBinders :: (IsPass p, OutputableBndrId p) + => HsDataDefn (GhcPass p) + -> LConsWithFields p +hsDataDefnBinders (HsDataDefn { dd_cons = cons }) + = hsConDeclsBinders (toList cons) + -- See Note [Binders in family instances] + +------------------- + +{- Note [Collecting record fields in data declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a data declaration that includes record constructors, we are, in +the end, going to to create a mapping from constructor to its field labels, +to store in 'GREInfo' (see 'IAmConLike'). This allows us to know, in the renamer, +which constructor has what fields. + +In order to achieve this, we return the constructor and field information from +hsConDeclsBinders in the following format: + + - [(ConRdrName, [Located Int])], a list of the constructors, each associated + with its record fields, in the form of a list of Int indices into... + - IntMap FieldOcc, an IntMap of record fields. + +(In actual fact, we use [(ConRdrName, Maybe [Located Int])], with Nothing indicating +that the constructor has unlabelled fields: see Note [Local constructor info in the renamer] +in GHC.Types.GREInfo.) + +This allows us to do the following (see GHC.Rename.Names.getLocalNonValBinders.new_tc): + + - create 'Name's for each of the record fields, to get IntMap FieldLabel, + - create 'Name's for each of the constructors, to get [(ConName, [Int])], + - look up the FieldLabels of each constructor, to get [(ConName, [FieldLabel])]. + +NB: This can be a bit tricky to get right in the presence of data types with +duplicate constructors or fields. Storing locations allows us to report an error +for duplicate field declarations, see test cases T9156 T9156_DF. +Other relevant test cases: rnfail015. + +-} + +-- | A mapping from constructors to all of their fields. +-- +-- See Note [Collecting record fields in data declarations]. +data LConsWithFields p = + LConsWithFields + { consWithFieldIndices :: [(LocatedA (IdP (GhcPass p)), Maybe [Located Int])] + , consFields :: IntMap (LFieldOcc (GhcPass p)) + } + +lconsWithFieldsBinders :: LConsWithFields p + -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)]) +lconsWithFieldsBinders (LConsWithFields cons fields) + = (map fst cons, IntMap.elems fields) + +emptyLConsWithFields :: LConsWithFields p +emptyLConsWithFields = LConsWithFields [] IntMap.empty + +hsConDeclsBinders :: forall p. (IsPass p, OutputableBndrId p) + => [LConDecl (GhcPass p)] + -> LConsWithFields p + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful +hsConDeclsBinders cons = go emptyFieldIndices cons + where + go :: FieldIndices p -> [LConDecl (GhcPass p)] -> LConsWithFields p + go seen [] = LConsWithFields [] (fields seen) + go seen (r:rs) + -- Don't re-mangle the location of field names, because we don't + -- have a record of the full location of the field declaration anyway + = let loc = getLoc r + in case unLoc r of + ConDeclGADT { con_names = names, con_g_args = args } + -> LConsWithFields (cons ++ ns) fs + where + cons = map ( , con_flds ) $ toList (L loc . unLoc <$> names) + (con_flds, seen') = get_flds_gadt seen args + LConsWithFields ns fs = go seen' rs + + ConDeclH98 { con_name = name, con_args = args } + -> LConsWithFields ([(L loc (unLoc name), con_flds)] ++ ns) fs + where + (con_flds, seen') = get_flds_h98 seen args + LConsWithFields ns fs = go seen' rs + + get_flds_h98 :: FieldIndices p -> HsConDeclH98Details (GhcPass p) + -> (Maybe [Located Int], FieldIndices p) + get_flds_h98 seen (RecCon flds) = first Just $ get_flds seen flds + get_flds_h98 seen (PrefixCon []) = (Just [], seen) + get_flds_h98 seen _ = (Nothing, seen) + + get_flds_gadt :: FieldIndices p -> HsConDeclGADTDetails (GhcPass p) + -> (Maybe [Located Int], FieldIndices p) + get_flds_gadt seen (RecConGADT _ flds) = first Just $ get_flds seen flds + get_flds_gadt seen (PrefixConGADT _ []) = (Just [], seen) + get_flds_gadt seen _ = (Nothing, seen) + + get_flds :: FieldIndices p -> LocatedL [LHsConDeclRecField (GhcPass p)] + -> ([Located Int], FieldIndices p) + get_flds seen flds = + foldr add_fld ([], seen) fld_names + where + add_fld fld (is, ixs) = + let (i, ixs') = insertField fld ixs + in (i:is, ixs') + fld_names = concatMap (cdrf_names . unLoc) (unLoc flds) + +-- | A bijection between record fields of a datatype and integers, +-- used to implement Note [Collecting record fields in data declarations]. +data FieldIndices p = + FieldIndices + { fields :: IntMap (LFieldOcc (GhcPass p)) + -- ^ Look up a field from its index. + , fieldIndices :: Map RdrName Int + -- ^ Look up the index of a field label in the previous 'IntMap'. + , newInt :: !Int + -- ^ An integer @i@ such that no integer @i' >= i@ appears in the 'IntMap'. + } + +emptyFieldIndices :: FieldIndices p +emptyFieldIndices = + FieldIndices { fields = IntMap.empty + , fieldIndices = Map.empty + , newInt = 0 } + +insertField :: IsPass p => LFieldOcc (GhcPass p) -> FieldIndices p -> (Located Int, FieldIndices p) +insertField new_fld fi@(FieldIndices flds idxs new_idx) + | Just i <- Map.lookup rdr idxs + = (L loc i, fi) + | otherwise + = (L loc new_idx, + FieldIndices (IntMap.insert new_idx new_fld flds) + (Map.insert rdr new_idx idxs) + (new_idx + 1)) + where + loc = getLocA new_fld + rdr = fieldOccRdrName . unLoc $ new_fld + +{- + +Note [SrcSpan for binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When extracting the (Located RdrName) for a binder, at least for the +main name (the TyCon of a type declaration etc), we want to give it +the @SrcSpan@ of the whole /declaration/, not just the name itself +(which is how it appears in the syntax tree). This SrcSpan (for the +entire declaration) is used as the SrcSpan for the Name that is +finally produced, and hence for error messages. (See #8607.) + +Note [Binders in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type or data family instance declaration, the type +constructor is an *occurrence* not a binding site + type instance T Int = Int -> Int -- No binders + data instance S Bool = S1 | S2 -- Binders are S1,S2 + + +************************************************************************ +* * + Collecting binders the user did not write +* * +************************************************************************ + +The job of the following family of functions is to run through binding sites and find +the set of all Names that were defined "implicitly", without being explicitly written +by the user. + +Note [Collecting implicit binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We collect all the RHS Names that are implicitly introduced by record wildcards, +so that we can: + + - avoid warning the user when they don't use those names (#4404), + - report deprecation warnings for deprecated fields that are used (#23382). + +The functions that collect implicit binders return a collection of 'ImplicitFieldBinders', +which associates each implicitly-introduced record field with the bound variables in the +RHS of the record field pattern, e.g. in + + data R = MkR { fld :: Int } + foo (MkR { .. }) = fld + +the renamer will elaborate this to + + foo (MkR { fld = fld_var }) = fld_var + +and the implicit binders function will return + + [ ImplicitFieldBinders { implFlBndr_field = fld + , implFlBndr_binders = [fld_var] } ] + +This information is then used: + + - in the calls to GHC.Rename.Utils.checkUnusedRecordWildcard, to emit + a warning when a record wildcard binds no new variables (redundant record wildcard) + or none of the bound variables are used (unused record wildcard). + - in GHC.Rename.Utils.deprecateUsedRecordWildcard, to emit a warning + when the field is deprecated and any of the binders are used. + +NOTE: the implFlBndr_binders field should always be a singleton + (since the RHS of an implicit binding should always be a VarPat, + created in rnHsRecPatsAndThen.mkVarPat) + +-} + +-- | All binders corresponding to a single implicit record field pattern. +-- +-- See Note [Collecting implicit binders]. +data ImplicitFieldBinders + = ImplicitFieldBinders { implFlBndr_field :: Name + -- ^ The 'Name' of the record field + , implFlBndr_binders :: [Name] + -- ^ The binders of the RHS of the record field pattern + -- (in practice, always a singleton: see Note [Collecting implicit binders]) + } + +lStmtsImplicits :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))] + -> [(SrcSpan, [ImplicitFieldBinders])] +lStmtsImplicits = hs_lstmts + where + hs_lstmts :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))] + -> [(SrcSpan, [ImplicitFieldBinders])] + hs_lstmts = concatMap (hs_stmt . unLoc) + + hs_stmt :: forall idR body . IsPass idR => StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR))) + -> [(SrcSpan, [ImplicitFieldBinders])] + hs_stmt (BindStmt _ pat _) = lPatImplicits pat + hs_stmt (XStmtLR x) = case ghcPass :: GhcPass idR of + GhcRn -> hs_applicative_stmt x + GhcTc -> hs_applicative_stmt x + hs_stmt (LetStmt _ binds) = hs_local_binds binds + hs_stmt (BodyStmt {}) = [] + hs_stmt (LastStmt {}) = [] + hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- toList xs , s <- ss] + hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts + hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss + + hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds + hs_local_binds (HsIPBinds {}) = [] + hs_local_binds (EmptyLocalBinds _) = [] + + hs_applicative_stmt (ApplicativeStmt _ args _) = concatMap do_arg args + where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat + do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts + +hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) + -> [(SrcSpan, [ImplicitFieldBinders])] +hsValBindsImplicits (XValBindsLR (NValBinds binds _)) + = concatMap (lhsBindsImplicits . snd) binds +hsValBindsImplicits (ValBinds _ binds _) + = lhsBindsImplicits binds + +lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [ImplicitFieldBinders])] +lhsBindsImplicits = concatMap (lhs_bind . unLoc) + where + lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat + lhs_bind _ = [] + +-- | Collect all record wild card binders in the given pattern. +-- +-- These are all the variables bound in all (possibly nested) record wildcard patterns +-- appearing inside the pattern. +-- +-- See Note [Collecting implicit binders]. +lPatImplicits :: LPat GhcRn -> [(SrcSpan, [ImplicitFieldBinders])] +lPatImplicits = hs_lpat + where + hs_lpat lpat = hs_pat (unLoc lpat) + + hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) [] + + hs_pat (LazyPat _ pat) = hs_lpat pat + hs_pat (BangPat _ pat) = hs_lpat pat + hs_pat (AsPat _ _ pat) = hs_lpat pat + hs_pat (ViewPat _ _ pat) = hs_lpat pat + hs_pat (ParPat _ pat) = hs_lpat pat + hs_pat (ListPat _ pats) = hs_lpats pats + hs_pat (TuplePat _ pats _) = hs_lpats pats + hs_pat (SigPat _ pat _) = hs_lpat pat + + hs_pat (ConPat {pat_args=ps}) = details ps + + hs_pat _ = [] + + details :: HsConPatDetails GhcRn -> [(SrcSpan, [ImplicitFieldBinders])] + details (PrefixCon ps) = hs_lpats ps + details (RecCon (HsRecFields { rec_dotdot = Nothing, rec_flds })) + = hs_lpats $ map (hfbRHS . unLoc) rec_flds + details (RecCon (HsRecFields { rec_dotdot = Just (L err_loc rec_dotdot), rec_flds })) + = [(l2l err_loc, implicit_field_binders)] + ++ hs_lpats explicit_pats + + where (explicit_pats, implicit_field_binders) + = rec_field_expl_impl rec_flds rec_dotdot + + details (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2 + +lHsRecFieldsImplicits :: [LHsRecField GhcRn (LPat GhcRn)] + -> RecFieldsDotDot + -> [ImplicitFieldBinders] +lHsRecFieldsImplicits rec_flds rec_dotdot + = snd $ rec_field_expl_impl rec_flds rec_dotdot + +rec_field_expl_impl :: [LHsRecField GhcRn (LPat GhcRn)] + -> RecFieldsDotDot + -> ([LPat GhcRn], [ImplicitFieldBinders]) +rec_field_expl_impl rec_flds (RecFieldsDotDot { .. }) + = ( map (hfbRHS . unLoc) explicit_binds + , map implicit_field_binders implicit_binds ) + where (explicit_binds, implicit_binds) = splitAt unRecFieldsDotDot rec_flds + implicit_field_binders (L _ (HsFieldBind { hfbLHS = L _ fld, hfbRHS = rhs })) + = ImplicitFieldBinders + { implFlBndr_field = unLoc $ foLabel (fld :: FieldOcc GhcRn) + , implFlBndr_binders = collectPatBinders CollNoDictBinders rhs } diff --git a/GHC/HsToCore.hs b/GHC/HsToCore.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore.hs @@ -0,0 +1,787 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The Desugarer: turning HsSyn into Core. +-} + +module GHC.HsToCore ( + -- * Desugaring operations + deSugar, deSugarExpr + ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Driver.Config +import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO ) +import GHC.Driver.Config.HsToCore.Ticks +import GHC.Driver.Env +import GHC.Driver.Backend +import GHC.Driver.Plugins + +import GHC.Hs + +import GHC.HsToCore.Monad +import GHC.HsToCore.Errors.Types +import GHC.HsToCore.Expr +import GHC.HsToCore.Binds +import GHC.HsToCore.Foreign.Decl +import GHC.HsToCore.Ticks +import GHC.HsToCore.Breakpoints +import GHC.HsToCore.Coverage +import GHC.HsToCore.Docs + +import GHC.Tc.Types +import GHC.Tc.Types.Origin ( Position(..), mkArgPos ) +import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances ) +import GHC.Tc.Module ( runTcInteractive ) + +import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCon ( tyConDataCons ) +import GHC.Core +import GHC.Core.FVs ( exprsSomeFreeVarsList, exprFreeVars ) +import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) +import GHC.Core.Utils +import GHC.Core.Unfold.Make +import GHC.Core.Coercion +import GHC.Core.Predicate( scopedSort, mkNomEqPred ) +import GHC.Core.DataCon ( dataConWrapId ) +import GHC.Core.Make +import GHC.Core.Rules +import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) +import GHC.Core.Ppr + +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types + +import GHC.Data.Maybe ( expectJust ) +import GHC.Data.OrdList +import GHC.Data.SizedSeq ( sizeSS ) + +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Logger + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Id.Make ( mkRepPolyIdConcreteTyVars ) +import GHC.Types.ForeignStubs +import GHC.Types.Avail +import GHC.Types.Basic +import GHC.Types.Var.Set +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import GHC.Types.TypeEnv +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Name.Ppr +import GHC.Types.HpcInfo + +import GHC.Unit +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps + +import Data.List (partition) +import Data.IORef +import GHC.Iface.Make (mkRecompUsageInfo) +import GHC.Runtime.Interpreter (interpreterProfiled) + +{- +************************************************************************ +* * +* The main function: deSugar +* * +************************************************************************ +-} + +-- | Main entry point to the desugarer. +deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts) +-- Can modify PCS by faulting in more declarations + +deSugar hsc_env + mod_loc + tcg_env@(TcGblEnv { tcg_mod = id_mod, + tcg_semantic_mod = mod, + tcg_src = hsc_src, + tcg_type_env = type_env, + tcg_imports = imports, + tcg_exports = exports, + tcg_keep = keep_var, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_inst_env = inst_env, + tcg_fam_inst_env = fam_inst_env, + tcg_warns = warns, + tcg_anns = anns, + tcg_binds = binds, + tcg_imp_specs = imp_specs, + tcg_ev_binds = ev_binds, + tcg_th_foreign_files = th_foreign_files_var, + tcg_fords = fords, + tcg_rules = rules, + tcg_patsyns = patsyns, + tcg_tcs = tcs, + tcg_default_exports = defaults, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_complete_matches = complete_matches, + tcg_self_boot = self_boot + }) + + = do { let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + ptc = initPromotionTickContext (hsc_dflags hsc_env) + name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + ; withTiming logger + (text "Desugar"<+>brackets (ppr mod)) + (const ()) $ + do { -- Desugar the program + ; let export_set = availsToNameSet exports + bcknd = backend dflags + -- See Note [Named default declarations] in GHC.Tc.Gen.Default + + ; (binds_cvr, m_tickInfo) + <- if not (isHsBootOrSig hsc_src) + then addTicksToBinds + (hsc_logger hsc_env) + (initTicksConfig (hsc_dflags hsc_env)) + mod mod_loc + export_set (typeEnvTyCons type_env) binds + else return (binds, Nothing) + ; let modBreaks + | Just (_, specs) <- m_tickInfo + , breakpointsAllowed dflags + = Just $ mkModBreaks (interpreterProfiled $ hscInterp hsc_env) mod specs + | otherwise + = Nothing + + ; ds_hpc_info <- case m_tickInfo of + Just (orig_file2, ticks) + | gopt Opt_Hpc $ hsc_dflags hsc_env + -> do + hashNo <- if gopt Opt_Hpc $ hsc_dflags hsc_env + then writeMixEntries (hpcDir dflags) mod ticks orig_file2 + else return 0 -- dummy hash when none are written + pure $ HpcInfo (fromIntegral $ sizeSS ticks) hashNo + _ -> pure $ emptyHpcInfo + + ; (msgs, mb_res) <- initDs hsc_env tcg_env $ + do { dsEvBinds ev_binds $ \ ds_ev_binds -> do + { core_prs <- dsTopLHsBinds binds_cvr + ; core_prs <- patchMagicDefns core_prs + ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs + ; (ds_fords, foreign_prs) <- dsForeigns fords + ; ds_rules <- mapMaybeM dsRule rules + ; let hpc_init + | gopt Opt_Hpc dflags = hpcInitCode (targetPlatform $ hsc_dflags hsc_env) mod ds_hpc_info + | otherwise = mempty + ; return ( ds_ev_binds + , foreign_prs `appOL` core_prs `appOL` spec_prs + , spec_rules ++ ds_rules + , ds_fords `appendStubC` hpc_init) } } + + ; case mb_res of { + Nothing -> return (msgs, Nothing) ; + Just (ds_ev_binds, all_prs, all_rules, ds_fords) -> + + do { -- Add export flags to bindings + keep_alive <- readIORef keep_var + ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules + final_prs = addExportFlagsAndRules bcknd export_set keep_alive + rules_for_locals (fromOL all_prs) + + final_pgm = combineEvBinds ds_ev_binds final_prs + -- Notice that we put the whole lot in a big Rec, even the foreign binds + -- When compiling PrelFloat, which defines data Float = F# Float# + -- we want F# to be in scope in the foreign marshalling code! + -- You might think it doesn't matter, but the simplifier brings all top-level + -- things into the in-scope set before simplifying; so we get no unfolding for F#! + + ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugar final_pgm rules_for_imps + ; let simpl_opts = initSimpleOpts dflags + ; let (ds_binds, ds_rules_for_imps, occ_anald_binds) + = simpleOptPgm simpl_opts mod final_pgm rules_for_imps + -- The simpleOptPgm gets rid of type + -- bindings plus any stupid dead code + ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" + FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps ) + + ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugarOpt ds_binds ds_rules_for_imps + + ; let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env)) + home_unit = hsc_home_unit hsc_env + ; let deps = mkDependencies home_unit + (tcg_mod tcg_env) + (tcg_imports tcg_env) + (map mi_module pluginModules) + + ; safe_mode <- finalSafeMode dflags tcg_env + + ; usages <- mkRecompUsageInfo hsc_env tcg_env + + -- id_mod /= mod when we are processing an hsig, but hsigs + -- never desugared and compiled (there's no code!) + -- Consequently, this should hold for any ModGuts that make + -- past desugaring. See Note [Identity versus semantic module]. + ; massert (id_mod == mod) + + ; foreign_files <- readIORef th_foreign_files_var + + ; docs <- extractDocs dflags tcg_env + + ; let mod_guts = ModGuts { + mg_module = mod, + mg_hsc_src = hsc_src, + mg_loc = mkFileSrcSpan mod_loc, + mg_exports = exports, + mg_usages = usages, + mg_deps = deps, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_anns = anns, + mg_tcs = tcs, + mg_defaults = defaults, + mg_insts = fixSafeInstances safe_mode insts, + mg_fam_insts = fam_insts, + mg_inst_env = inst_env, + mg_fam_inst_env = fam_inst_env, + mg_boot_exports = bootExports self_boot, + mg_patsyns = patsyns, + mg_rules = ds_rules_for_imps, + mg_binds = ds_binds, + mg_foreign = ds_fords, + mg_foreign_files = foreign_files, + mg_hpc_info = ds_hpc_info, + mg_modBreaks = modBreaks, + mg_safe_haskell = safe_mode, + mg_trust_pkg = imp_trust_own_pkg imports, + mg_complete_matches = complete_matches, + mg_docs = docs + } + ; return (msgs, Just mod_guts) + }}}} + +combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind] +-- Top-level bindings can include coercion bindings, but not via superclasses +-- See Note [Top-level evidence] +combineEvBinds [] val_prs + = [Rec val_prs] +combineEvBinds (NonRec b r : bs) val_prs + | isId b = combineEvBinds bs ((b,r):val_prs) + | otherwise = NonRec b r : combineEvBinds bs val_prs +combineEvBinds (Rec prs : bs) val_prs + = combineEvBinds bs (prs ++ val_prs) + +{- +Note [Top-level evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Top-level evidence bindings may be mutually recursive with the top-level value +bindings, so we must put those in a Rec. But we can't put them *all* in a Rec +because the occurrence analyser doesn't take account of type/coercion variables +when computing dependencies. + +So we pull out the type/coercion variables (which are in dependency order), +and Rec the rest. +-} + +deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr) +deSugarExpr hsc_env tc_expr = do + let logger = hsc_logger hsc_env + + showPass logger "Desugar" + + -- Do desugaring + (tc_msgs, mb_result) <- runTcInteractive hsc_env $ + initDsTc $ + dsLExpr tc_expr + + massert (isEmptyMessages tc_msgs) -- the type-checker isn't doing anything here + + -- mb_result is Nothing only when a failure happens in the type-checker, + -- but mb_core_expr is Nothing when a failure happens in the desugarer + let (ds_msgs, mb_core_expr) = expectJust mb_result + + case mb_core_expr of + Nothing -> return () + Just expr -> putDumpFileMaybe logger Opt_D_dump_ds "Desugared" + FormatCore (pprCoreExpr expr) + + -- callers (i.e. ioMsgMaybe) expect that no expression is returned if + -- there are errors + let final_res | errorsFound ds_msgs = Nothing + | otherwise = mb_core_expr + + return (ds_msgs, final_res) + +{- +************************************************************************ +* * +* Add rules and export flags to binders +* * +************************************************************************ +-} + +addExportFlagsAndRules + :: Backend -> NameSet -> NameSet -> [CoreRule] + -> [(Id, t)] -> [(Id, t)] +addExportFlagsAndRules bcknd exports keep_alive rules + = mapFst (addRulesToId rule_base . add_export_flag) + -- addRulesToId: see Note [Attach rules to local ids] + -- NB: the binder might have some existing rules, + -- arising from specialisation pragmas + + where + + ---------- Rules -------- + rule_base = extendRuleBaseList emptyRuleBase rules + + ---------- Export flag -------- + -- See Note [Adding export flags] + add_export_flag bndr + | dont_discard bndr = setIdExported bndr + | otherwise = bndr + + dont_discard :: Id -> Bool + dont_discard bndr = is_exported name + || name `elemNameSet` keep_alive + where + name = idName bndr + + -- In interactive mode, we don't want to discard any top-level + -- entities at all (eg. do not inline them away during + -- simplification), and retain them all in the TypeEnv so they are + -- available from the command line. + -- + -- isExternalName separates the user-defined top-level names from those + -- introduced by the type checker. + is_exported :: Name -> Bool + is_exported | backendWantsGlobalBindings bcknd = isExternalName + | otherwise = (`elemNameSet` exports) + +{- +Note [Adding export flags] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Set the no-discard flag if either + a) the Id is exported + b) it's mentioned in the RHS of an orphan rule + c) it's in the keep-alive set + +It means that the binding won't be discarded EVEN if the binding +ends up being trivial (v = w) -- the simplifier would usually just +substitute w for v throughout, but we don't apply the substitution to +the rules (maybe we should?), so this substitution would make the rule +bogus. + +You might wonder why exported Ids aren't already marked as such; +it's just because the type checker is rather busy already and +I didn't want to pass in yet another mapping. + +Note [Attach rules to local ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Find the rules for locally-defined Ids; then we can attach them +to the binders in the top-level bindings + +Reason + - It makes the rules easier to look up + - It means that rewrite rules and specialisations for + locally defined Ids are handled uniformly + - It keeps alive things that are referred to only from a rule + (the occurrence analyser knows about rules attached to Ids) + - It makes sure that, when we apply a rule, the free vars + of the RHS are more likely to be in scope + - The imported rules are carried in the in-scope set + which is extended on each iteration by the new wave of + local binders; any rules which aren't on the binding will + thereby get dropped + + +************************************************************************ +* * +* Desugaring rewrite rules +* * +************************************************************************ +-} + +dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) +dsRule (L loc (HsRule { rd_name = name + , rd_act = rule_act + , rd_bndrs = RuleBndrs { rb_ext = bndrs } + , rd_lhs = lhs + , rd_rhs = rhs })) + = putSrcSpanDs (locA loc) $ + do { let bndrs' = scopedSort bndrs + -- The scopedSort is because the binders may not + -- be in dependency order; see wrinkle (FTV1) in + -- Note [Free tyvars on rule LHS] in GHC.Tc.Zonk.Type + + ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ + unsetWOptM Opt_WarnIdentities $ + zapUnspecables $ + dsLExpr lhs -- Note [Desugaring RULE left hand sides] + + ; rhs' <- dsLExpr rhs + ; this_mod <- getModule + + ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs' + + -- Substitute the dict bindings eagerly, + -- and take the body apart into a (f args) form + ; dflags <- getDynFlags + ; case decomposeRuleLhs dflags bndrs'' lhs'' (exprFreeVars rhs'') of { + Left msg -> do { diagnosticDs msg; return Nothing } ; + Right (final_bndrs, fn_id, args) -> do + + { let is_local = isLocalId fn_id + -- NB: isLocalId is False of implicit Ids. This is good because + -- we don't want to attach rules to the bindings of implicit Ids, + -- because they don't show up in the bindings until just before code gen + fn_name = idName fn_id + simpl_opts = initSimpleOpts dflags + final_rhs = simpleOptExpr simpl_opts rhs'' -- De-crap it + rule_name = unLoc name + rule = mkRule this_mod False is_local rule_name rule_act + fn_name final_bndrs args final_rhs + ; dsWarnOrphanRule rule + ; dsWarnRuleShadowing fn_id rule + + ; return (Just rule) + } } } + +dsWarnRuleShadowing :: Id -> CoreRule -> DsM () +-- See Note [Rules and inlining/other rules] +dsWarnRuleShadowing fn_id + (Rule { ru_name = rule_name, ru_act = rule_act, ru_bndrs = bndrs, ru_args = args}) + = do { check False fn_id -- We often have multiple rules for the same Id in a + -- module. Maybe we should check that they don't overlap + -- but currently we don't + ; mapM_ (check True) arg_ids } + where + bndrs_set = mkVarSet bndrs + arg_ids = filterOut (`elemVarSet` bndrs_set) $ + exprsSomeFreeVarsList isId args + + check check_rules_too lhs_id + | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) + -- If imported with no unfolding, no worries + , idInlineActivation lhs_id `competesWith` rule_act + = diagnosticDs (DsRuleMightInlineFirst rule_name lhs_id rule_act) + | check_rules_too + , bad_rule : _ <- get_bad_rules lhs_id + = diagnosticDs (DsAnotherRuleMightFireFirst rule_name (ruleName bad_rule) lhs_id) + | otherwise + = return () + + get_bad_rules lhs_id + = [ rule | rule <- idCoreRules lhs_id + , ruleActivation rule `competesWith` rule_act ] + +dsWarnRuleShadowing _ _ = return () -- Not expecting built-in rules here + +-- See Note [Desugaring coerce as cast] +unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr) +unfold_coerce bndrs lhs rhs = do + (bndrs', wrap) <- go bndrs + return (bndrs', wrap lhs, wrap rhs) + where + go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr) + go [] = return ([], id) + go (v:vs) + | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v) + , tc `hasKey` coercibleTyConKey = do + u <- newUnique + + let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2] + v' = mkLocalCoVar + (mkDerivedInternalName mkRepEqOcc u (getName v)) ty' + box = Var (dataConWrapId coercibleDataCon) `mkTyApps` + [k, t1, t2] `App` + Coercion (mkCoVarCo v') + + (bndrs, wrap) <- go vs + return (v':bndrs, mkCoreLet (NonRec v box) . wrap) + | otherwise = do + (bndrs,wrap) <- go vs + return (v:bndrs, wrap) + +{- Note [Desugaring RULE left hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the LHS of a RULE we do *not* want to desugar + [x] to build (\cn. x `c` n) +We want to leave explicit lists simply as chains +of cons's. We can achieve that slightly indirectly by +switching off EnableRewriteRules. See GHC.HsToCore.Expr.dsExplicitList. + +That keeps the desugaring of list comprehensions simple too. + +Nor do we want to warn of conversion identities on the LHS; +the rule is precisely to optimise them: + {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} + +Finally, the `zapUnspecables` is to implement (NC1) of +Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr + +Note [Desugaring coerce as cast] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want the user to express a rule saying roughly “mapping a coercion over a +list can be replaced by a coercion”. But the cast operator of Core (▷) cannot +be written in Haskell. So we use `coerce` for that (#2110). The user writes + map coerce = coerce +as a RULE, and this optimizes any kind of mapped' casts away, including `map +MkNewtype`. + +For that we replace any forall'ed `c :: Coercible a b` value in a RULE by +corresponding `co :: a ~#R b` and wrap the LHS and the RHS in +`let c = MkCoercible co in ...`. This is later simplified to the desired form +by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS). +See also Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt. + +Note [Rules and inlining/other rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you have + f x = ... + g x = ... + {-# RULES "rule-for-f" forall x. f (g x) = ... #-} +then there's a good chance that in a potential rule redex + ...f (g e)... +then 'f' or 'g' will inline before the rule can fire. Solution: add an +INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'. + +Note that this applies to all the free variables on the LHS, both the +main function and things in its arguments. + +We also check if there are Ids on the LHS that have competing RULES. +In the above example, suppose we had + {-# RULES "rule-for-g" forally. g [y] = ... #-} +Then "rule-for-f" and "rule-for-g" would compete. Better to add phase +control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes +active; or perhaps after "rule-for-g" has become inactive. This is checked +by 'competesWith' + +Class methods have a built-in RULE to select the method from the dictionary, +so you can't change the phase on this. That makes id very dubious to +match on class methods in RULE lhs's. See #10595. I'm not happy +about this. For example in Control.Arrow we have + +{-# RULES "compose/arr" forall f g . + (arr f) . (arr g) = arr (f . g) #-} + +and similar, which will elicit exactly these warnings, and risk never +firing. But it's not clear what to do instead. We could make the +class method rules inactive in phase 2, but that would delay when +subsequent transformations could fire. +-} + +{- +************************************************************************ +* * +* Magic definitions +* * +************************************************************************ + +Note [Patching magic definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We sometimes need to have access to defined Ids in pure contexts. Usually, we +simply "wire in" these entities, as we do for types in GHC.Builtin.Types and for Ids +in GHC.Types.Id.Make. See Note [Wired-in Ids] in GHC.Types.Id.Make. + +However, it is sometimes *much* easier to define entities in Haskell, +even if we need pure access; note that wiring-in an Id requires all +entities used in its definition *also* to be wired in, transitively +and recursively. This can be a huge pain. The little trick +documented here allows us to have the best of both worlds. + +Motivating example: unsafeCoerce#. See [Wiring in unsafeCoerce#] for the +details. + +The trick is to + +* Define the known-key Id in a library module, with a stub definition, + unsafeCoerce# :: ..a suitable type signature.. + unsafeCoerce# = error "urk" + +* Magically over-write its RHS here in the desugarer, in + patchMagicDefns. This update can be done with full access to the + DsM monad, and hence, dsLookupGlobal. We thus do not have to wire in + all the entities used internally, a potentially big win. + + This step should not change the Name or type of the Id. + +Because an Id stores its unfolding directly (as opposed to in the second +component of a (Id, CoreExpr) pair), the patchMagicDefns function returns +a new Id to use. + +Here are the moving parts: + +- patchMagicDefns checks whether we're in a module with magic definitions; + if so, patch the magic definitions. If not, skip. + +- patchMagicDefn just looks up in an environment to find a magic defn and + patches it in. + +- magicDefns holds the magic definitions. + +- magicDefnsEnv allows for quick access to magicDefns. + +- magicDefnModules, built also from magicDefns, contains the modules that + need careful attention. + +Note [Wiring in unsafeCoerce#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want (Haskell) + + unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b + unsafeCoerce# x = case unsafeEqualityProof @r1 @r2 of + UnsafeRefl -> case unsafeEqualityProof @a @b of + UnsafeRefl -> x + +or (Core) + + unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b + unsafeCoerce# = \ @r1 @r2 @a @b (x :: a). + case unsafeEqualityProof @RuntimeRep @r1 @r2 of + UnsafeRefl (co1 :: r1 ~# r2) -> + case unsafeEqualityProof @(TYPE r2) @(a |> TYPE co1) @b of + UnsafeRefl (co2 :: (a |> TYPE co1) ~# b) -> + (x |> (GRefl :: a ~# (a |> TYPE co1)) ; co2) + +It looks like we can write this in Haskell directly, but we can't: +the representation polymorphism checks defeat us. Note that `x` is a +representation-polymorphic variable. So we must wire it in with a +compulsory unfolding, like other representation-polymorphic primops. + +The challenge is that UnsafeEquality is a GADT, and wiring in a GADT +is *hard*: it has a worker separate from its wrapper, with all manner +of complications. (Simon and Richard tried to do this. We nearly wept.) + +The solution is documented in Note [Patching magic definitions]. We now +simply look up the UnsafeEquality GADT in the environment, leaving us +only to wire in unsafeCoerce# directly. + +Wrinkle: see Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy +-} + + +-- Postcondition: the returned Ids are in one-to-one correspondence as the +-- input Ids; each returned Id has the same type as the passed-in Id. +-- See Note [Patching magic definitions] +patchMagicDefns :: OrdList (Id,CoreExpr) + -> DsM (OrdList (Id,CoreExpr)) +patchMagicDefns pairs + -- optimization: check whether we're in a magic module before looking + -- at all the ids + = do { this_mod <- getModule + ; if this_mod `elemModuleSet` magicDefnModules + then traverse patchMagicDefn pairs + else return pairs } + +patchMagicDefn :: (Id, CoreExpr) -> DsM (Id, CoreExpr) +patchMagicDefn orig_pair@(orig_id, orig_rhs) + | Just mk_magic_pair <- lookupNameEnv magicDefnsEnv (getName orig_id) + = do { magic_pair@(magic_id, _) <- mk_magic_pair orig_id orig_rhs + + -- Patching should not change the Name or the type of the Id + ; massert (getUnique magic_id == getUnique orig_id) + ; massert (varType magic_id `eqType` varType orig_id) + + ; return magic_pair } + | otherwise + = return orig_pair + +magicDefns :: [(Name, Id -> CoreExpr -- old Id and RHS + -> DsM (Id, CoreExpr) -- new Id and RHS + )] +magicDefns = [ (unsafeCoercePrimName, mkUnsafeCoercePrimPair) ] + +magicDefnsEnv :: NameEnv (Id -> CoreExpr -> DsM (Id, CoreExpr)) +magicDefnsEnv = mkNameEnv magicDefns + +magicDefnModules :: ModuleSet +magicDefnModules = mkModuleSet $ map (nameModule . getName . fst) magicDefns + +mkUnsafeCoercePrimPair :: Id -> CoreExpr -> DsM (Id, CoreExpr) +-- See Note [Wiring in unsafeCoerce#] for the defn we are creating here +mkUnsafeCoercePrimPair _old_id old_expr + = do { unsafe_equality_proof_id <- dsLookupGlobalId unsafeEqualityProofName + ; unsafe_equality_tc <- dsLookupTyCon unsafeEqualityTyConName + + ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc + + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar + , x ] $ + mkSingleAltCase scrut1 + (mkWildValBinder ManyTy scrut1_ty) + (DataAlt unsafe_refl_data_con) + [rr_cv] $ + mkSingleAltCase scrut2 + (mkWildValBinder ManyTy scrut2_ty) + (DataAlt unsafe_refl_data_con) + [ab_cv] $ + Var x `mkCast` x_co + + [x, rr_cv, ab_cv] = mkTemplateLocals + [ openAlphaTy -- x :: a + , rr_cv_ty -- rr_cv :: r1 ~# r2 + , ab_cv_ty -- ab_cv :: (alpha |> alpha_co ~# beta) + ] + + -- Returns (scrutinee, scrutinee type, type of covar in AltCon) + unsafe_equality k a b + = ( mkTyApps (Var unsafe_equality_proof_id) [k,b,a] + , mkTyConApp unsafe_equality_tc [k,b,a] + , mkNomEqPred a b + ) + -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to + -- carefully swap the arguments above + + (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy + runtimeRep1Ty + runtimeRep2Ty + (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (mkTYPEapp runtimeRep2Ty) + (openAlphaTy `mkCastTy` alpha_co) + openBetaTy + + -- alpha_co :: TYPE r1 ~# TYPE r2 + -- alpha_co = TYPE rr_cv + alpha_co = mkTyConAppCo Nominal tYPETyCon [mkCoVarCo rr_cv] + + -- x_co :: alpha ~R# beta + x_co = mkGReflMCo Representational openAlphaTy alpha_co `mkTransCo` + mkSubCo (mkCoVarCo ab_cv) + + + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setArityInfo` arity + + ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar ] $ + mkVisFunTyMany openAlphaTy openBetaTy + + arity = 1 + + concs = mkRepPolyIdConcreteTyVars + [((mkTyVarTy openAlphaTyVar, mkArgPos 1 Top), runtimeRep1TyVar)] + unsafeCoercePrimName + + id = mkExportedLocalId (RepPolyId concs) unsafeCoercePrimName ty `setIdInfo` info + ; return (id, old_expr) } diff --git a/GHC/HsToCore/Arrows.hs b/GHC/HsToCore/Arrows.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Arrows.hs @@ -0,0 +1,1259 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring arrow commands +-} + +module GHC.HsToCore.Arrows ( dsProcExpr ) where + +import GHC.Prelude + +import GHC.HsToCore.Match +import GHC.HsToCore.Utils +import GHC.HsToCore.Monad + +import GHC.Hs +import GHC.Hs.Syn.Type + +-- NB: The desugarer, which straddles the source and Core worlds, sometimes +-- needs to see source types (newtypes etc), and sometimes not +-- So WATCH OUT; check each use of split*Ty functions. +-- Sigh. This is a pain. + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLocalBinds, + dsSyntaxExpr ) + +import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity +import GHC.Tc.Types.Evidence +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Make +import GHC.HsToCore.Binds (dsHsWrapper) + + +import GHC.Types.Id +import GHC.Core.ConLike +import GHC.Builtin.Types +import GHC.Types.Basic +import GHC.Builtin.Names +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.Var.Set +import GHC.Types.SrcLoc +import GHC.Data.List.SetOps( assocMaybe ) +import Data.Foldable (toList) +import Data.List (mapAccumL) +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) +import GHC.Utils.Misc +import GHC.Types.Unique.DSet + +data DsCmdEnv = DsCmdEnv { + arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr + } + +mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv) +-- See Note [CmdSyntaxTable] in GHC.Hs.Expr +mkCmdEnv tc_meths + = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths + + -- NB: Some of these lookups might fail, but that's OK if the + -- symbol is never used. That's why we use Maybe first and then + -- panic. An eager panic caused trouble in typecheck/should_compile/tc192 + ; let the_arr_id = assocMaybe prs arrAName + the_compose_id = assocMaybe prs composeAName + the_first_id = assocMaybe prs firstAName + the_app_id = assocMaybe prs appAName + the_choice_id = assocMaybe prs choiceAName + the_loop_id = assocMaybe prs loopAName + + ; return (meth_binds, DsCmdEnv { + arr_id = Var (unmaybe the_arr_id arrAName), + compose_id = Var (unmaybe the_compose_id composeAName), + first_id = Var (unmaybe the_first_id firstAName), + app_id = Var (unmaybe the_app_id appAName), + choice_id = Var (unmaybe the_choice_id choiceAName), + loop_id = Var (unmaybe the_loop_id loopAName) + }) } + where + mk_bind (std_name, expr) + = do { rhs <- dsExpr expr + ; id <- newSysLocalMDs (exprType rhs) + -- no check needed; these are functions + ; return (NonRec id rhs, (std_name, id)) } + + unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name) + unmaybe (Just id) _ = id + +-- arr :: forall b c. (b -> c) -> a b c +do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr +do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f] + +-- (>>>) :: forall b c d. a b c -> a c d -> a b d +do_compose :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_compose ids b_ty c_ty d_ty f g + = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g] + +-- first :: forall b c d. a b c -> a (b,d) (c,d) +do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr +do_first ids b_ty c_ty d_ty f + = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f] + +-- app :: forall b c. a (a b c, b) c +do_app :: DsCmdEnv -> Type -> Type -> CoreExpr +do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty] + +-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d +-- note the swapping of d and c +do_choice :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_choice ids b_ty c_ty d_ty f g + = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g] + +-- loop :: forall b d c. a (b,d) (c,d) -> a b c +-- note the swapping of d and c +do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr +do_loop ids b_ty c_ty d_ty f + = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f] + +-- premap :: forall b c d. (b -> c) -> a c d -> a b d +-- premap f g = arr f >>> g +do_premap :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_premap ids b_ty c_ty d_ty f g + = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g + +-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a +mkFstExpr :: Type -> Type -> DsM CoreExpr +mkFstExpr a_ty b_ty = do + a_var <- newSysLocalMDs a_ty + b_var <- newSysLocalMDs b_ty + pair_var <- newSysLocalMDs (mkCorePairTy a_ty b_ty) + return (Lam pair_var + (coreCasePair pair_var a_var b_var (Var a_var))) + +-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b +mkSndExpr :: Type -> Type -> DsM CoreExpr +mkSndExpr a_ty b_ty = do + a_var <- newSysLocalMDs a_ty + b_var <- newSysLocalMDs b_ty + pair_var <- newSysLocalMDs (mkCorePairTy a_ty b_ty) + return (Lam pair_var + (coreCasePair pair_var a_var b_var (Var b_var))) + +{- +Build case analysis of a tuple. This cannot be done in the DsM monad, +because the list of variables is typically not yet defined. +-} + +-- coreCaseTuple [u1..] v [x1..xn] body +-- = case v of v { (x1, .., xn) -> body } +-- But the matching may be nested if the tuple is very big + +coreCaseTuple :: Id -> [Id] -> CoreExpr -> DsM CoreExpr +coreCaseTuple scrut_var vars body + = mkBigTupleCase vars body (Var scrut_var) + +coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr +coreCasePair scrut_var var1 var2 body + = Case (Var scrut_var) scrut_var (exprType body) + [Alt (DataAlt (tupleDataCon Boxed 2)) [var1, var2] body] + +mkCorePairTy :: Type -> Type -> Type +mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] + +mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr +mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] + +mkCoreUnitExpr :: CoreExpr +mkCoreUnitExpr = mkCoreTup [] + +{- Note [Environment and stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The input is divided into + +* A local environment, which is a flat tuple (unless it's too big) + The elements of the local environment can be + - of kind Type (for ordinary variables), or + - of kind Constraint (for dictionaries bound by patterns) + +* A stack, which is a right-nested pair. + The elements on the stack are always of kind Type. + +So in general, the input has the form + + ((x1,...,xn), (s1,...(sk,())...)) + +where xi are the environment values, and si the ones on the stack, +with s1 being the "top", the first one to be matched with a lambda. +-} + +envStackType :: [Id] -> Type -> Type +envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty + +-- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t) +splitTypeAt :: Int -> Type -> ([Type], Type) +splitTypeAt n ty + | n == 0 = ([], ty) + | otherwise = case tcTyConAppArgs ty of + [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r) + _ -> pprPanic "splitTypeAt" (ppr ty) + +---------------------------------------------- +-- buildEnvStack +-- +-- ((x1,...,xn),stk) + +buildEnvStack :: [Id] -> Id -> CoreExpr +buildEnvStack env_ids stack_id + = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id) + +---------------------------------------------- +-- matchEnvStack +-- +-- \ ((x1,...,xn),stk) -> body +-- => +-- \ pair -> +-- case pair of (tup,stk) -> +-- case tup of (x1,...,xn) -> +-- body + +matchEnvStack :: [Id] -- x1..xn + -> Id -- stk + -> CoreExpr -- e + -> DsM CoreExpr +matchEnvStack env_ids stack_id body = do + tup_var <- newSysLocalMDs (mkBigCoreVarTupTy env_ids) + match_env <- coreCaseTuple tup_var env_ids body + pair_id <- newSysLocalMDs (mkCorePairTy (idType tup_var) (idType stack_id)) + return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) + +---------------------------------------------- +-- matchEnv +-- +-- \ (x1,...,xn) -> body +-- => +-- \ tup -> +-- case tup of (x1,...,xn) -> +-- body + +matchEnv :: [Id] -- x1..xn + -> CoreExpr -- e + -> DsM CoreExpr +matchEnv env_ids body = do + tup_id <- newSysLocalMDs (mkBigCoreVarTupTy env_ids) + tup_case <- coreCaseTuple tup_id env_ids body + return (Lam tup_id tup_case) + +---------------------------------------------- +-- matchVarStack +-- +-- case (x1, ...(xn, s)...) -> e +-- => +-- case z0 of (x1,z1) -> +-- case zn-1 of (xn,s) -> +-- e +matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr) +matchVarStack [] stack_id body = return (stack_id, body) +matchVarStack (param_id:param_ids) stack_id body = do + (tail_id, tail_code) <- matchVarStack param_ids stack_id body + pair_id <- newSysLocalMDs (mkCorePairTy (idType param_id) (idType tail_id)) + return (pair_id, coreCasePair pair_id param_id tail_id tail_code) + +mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc +mkHsEnvStackExpr env_ids stack_id + = mkLHsTupleExpr [mkLHsVarTuple env_ids noExtField, nlHsVar stack_id] + noExtField + +-- Translation of arrow abstraction + +-- D; xs |-a c : () --> t' ---> c' +-- -------------------------- +-- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c' +-- +-- where (xs) is the tuple of variables bound by p + +dsProcExpr + :: LPat GhcTc + -> LHsCmdTop GhcTc + -> DsM CoreExpr +dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do + (meth_binds, meth_ids) <- mkCmdEnv ids + let locals = mkVarSet (collectPatBinders CollWithDictBinders pat) + (core_cmd, _free_vars, env_ids) + <- dsfixCmd meth_ids locals unitTy cmd_ty cmd + let env_ty = mkBigCoreVarTupTy env_ids + let env_stk_ty = mkCorePairTy env_ty unitTy + let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr + fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty + var <- selectSimpleMatchVarL ManyTy pat + match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) ManyTy pat env_stk_expr fail_expr + let pat_ty = hsLPatType pat + let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty + (Lam var match_code) + core_cmd + return (mkLets meth_binds proc_code) + +{- +Translation of a command judgement of the form + + D; xs |-a c : stk --> t + +to an expression e such that + + D |- e :: a (xs, stk) t +-} + +dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id] + -> DsM (CoreExpr, DIdSet) +dsLCmd ids local_vars stk_ty res_ty cmd env_ids + = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids + +dsCmd :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> HsCmd GhcTc -- command to desugar + -> [Id] -- list of vars in the input to this command + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +-- D |- fun :: a t1 t2 +-- D, xs |- arg :: t1 +-- ----------------------------- +-- D; xs |-a fun -< arg : stk --> t2 +-- +-- ---> premap (\ ((xs), _stk) -> arg) fun + +dsCmd ids local_vars stack_ty res_ty + (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _) + env_ids = do + let + (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty + (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty + core_arrow <- dsLExpr arrow + core_arg <- dsLExpr arg + stack_id <- newSysLocalMDs stack_ty + core_make_arg <- matchEnvStack env_ids stack_id core_arg + return (do_premap ids + (envStackType env_ids stack_ty) + arg_ty + res_ty + core_make_arg + core_arrow, + exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars) + +-- D, xs |- fun :: a t1 t2 +-- D, xs |- arg :: t1 +-- ------------------------------ +-- D; xs |-a fun -<< arg : stk --> t2 +-- +-- ---> premap (\ ((xs), _stk) -> (fun, arg)) app + +dsCmd ids local_vars stack_ty res_ty + (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _) + env_ids = do + let + (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty + (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty + + core_arrow <- dsLExpr arrow + core_arg <- dsLExpr arg + stack_id <- newSysLocalMDs stack_ty + core_make_pair <- matchEnvStack env_ids stack_id + (mkCorePairExpr core_arrow core_arg) + + return (do_premap ids + (envStackType env_ids stack_ty) + (mkCorePairTy arrow_ty arg_ty) + res_ty + core_make_pair + (do_app ids arg_ty res_ty), + (exprsFreeIdsDSet [core_arrow, core_arg]) + `uniqDSetIntersectUniqSet` local_vars) + +-- D; ys |-a cmd : (t,stk) --> t' +-- D, xs |- exp :: t +-- ------------------------ +-- D; xs |-a cmd exp : stk --> t' +-- +-- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd + +dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do + core_arg <- dsLExpr arg + let + arg_ty = exprType core_arg + stack_ty' = mkCorePairTy arg_ty stack_ty + (core_cmd, free_vars, env_ids') + <- dsfixCmd ids local_vars stack_ty' res_ty cmd + stack_id <- newSysLocalMDs stack_ty + arg_id <- newSysLocalMDs arg_ty + -- push the argument expression onto the stack + let + stack' = mkCorePairExpr (Var arg_id) (Var stack_id) + core_body = bindNonRec arg_id core_arg + (mkCorePairExpr (mkBigCoreVarTup env_ids') stack') + + -- match the environment and stack against the input + core_map <- matchEnvStack env_ids stack_id core_body + return (do_premap ids + (envStackType env_ids stack_ty) + (envStackType env_ids' stack_ty') + res_ty + core_map + core_cmd, + free_vars `unionDVarSet` + (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)) + +dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids + = dsLCmd ids local_vars stack_ty res_ty cmd env_ids + +-- D, xs |- e :: Bool +-- D; xs1 |-a c1 : stk --> t +-- D; xs2 |-a c2 : stk --> t +-- ---------------------------------------- +-- D; xs |-a if e then c1 else c2 : stk --> t +-- +-- ---> premap (\ ((xs),stk) -> +-- if e then Left ((xs1),stk) else Right ((xs2),stk)) +-- (c1 ||| c2) + +dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd) + env_ids = do + core_cond <- dsLExpr cond + (core_then, fvs_then, then_ids) + <- dsfixCmd ids local_vars stack_ty res_ty then_cmd + (core_else, fvs_else, else_ids) + <- dsfixCmd ids local_vars stack_ty res_ty else_cmd + stack_id <- newSysLocalMDs stack_ty + either_con <- dsLookupTyCon eitherTyConName + left_con <- dsLookupDataCon leftDataConName + right_con <- dsLookupDataCon rightDataConName + + let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1,Type ty2, e] + mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e] + + in_ty = envStackType env_ids stack_ty + then_ty = envStackType then_ids stack_ty + else_ty = envStackType else_ids stack_ty + sum_ty = mkTyConApp either_con [then_ty, else_ty] + fvs_cond = exprFreeIdsDSet core_cond + `uniqDSetIntersectUniqSet` local_vars + + core_left = mk_left_expr then_ty else_ty + (buildEnvStack then_ids stack_id) + core_right = mk_right_expr then_ty else_ty + (buildEnvStack else_ids stack_id) + + core_if <- case mb_fun of + NoSyntaxExprTc -> matchEnvStack env_ids stack_id $ + mkIfThenElse core_cond core_left core_right + _ -> do { fun_apps <- dsSyntaxExpr mb_fun + [core_cond, core_left, core_right] + ; matchEnvStack env_ids stack_id fun_apps } + + return (do_premap ids in_ty sum_ty res_ty + core_if + (do_choice ids then_ty else_ty res_ty core_then core_else), + fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else) + +{- +Note [Desugaring HsCmdCase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case commands are treated in much the same way as if commands +(see above) except that there are more alternatives. For example + + case e of { p1 -> c1; p2 -> c2; p3 -> c3 } + +is translated to + + premap (\ ((xs)*ts) -> case e of + p1 -> (Left (Left (xs1)*ts)) + p2 -> Left ((Right (xs2)*ts)) + p3 -> Right ((xs3)*ts)) + ((c1 ||| c2) ||| c3) + +The idea is to extract the commands from the case, build a balanced tree +of choices, and replace the commands with expressions that build tagged +tuples, obtaining a case expression that can be desugared normally. +To build all this, we use triples describing segments of the list of +case bodies, containing the following fields: + * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put + into the case replacing the commands + * a sum type that is the common type of these expressions, and also the + input type of the arrow + * a CoreExpr for an arrow built by combining the translated command + bodies with |||. +-} + +dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do + stack_id <- newSysLocalMDs stack_ty + (match', core_choices) + <- dsCases ids local_vars stack_id stack_ty res_ty match + let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match' + in_ty = envStackType env_ids stack_ty + + core_body <- dsExpr (HsCase (ArrowMatchCtxt ArrowCaseAlt) exp match') + + core_matches <- matchEnvStack env_ids stack_id core_body + return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, + exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars) + +{- +\cases and \case are desugared analogously to a case command (see above). +For example + + \cases {p1 q1 -> c1; p2 q2 -> c2; p3 q3 -> c3 } + +is translated to + + premap (\ ((xs), (e1, (e2,stk))) -> cases e1 e2 of + p1 q1 -> (Left (Left (xs1), stk)) + p2 q2 -> Left ((Right (xs2), stk)) + p3 q3 -> Right ((xs3), stk)) + ((c1 ||| c2) ||| c3) + +(cases...of is hypothetical notation that works like case...of but with +multiple scrutinees) + +-} +dsCmd ids local_vars stack_ty res_ty + (HsCmdLam _ LamSingle (MG { mg_alts + = (L _ [L _ (Match { m_pats = L _ pats + , m_grhss = GRHSs _ (L _ (GRHS _ [] body) :| _) _ })]) })) + env_ids + = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids + +dsCmd ids local_vars stack_ty res_ty + (HsCmdLam _ lam_variant match@MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } ) + env_ids = do + arg_ids <- newSysLocalsDs arg_tys + + let match_ctxt = ArrowLamAlt lam_variant + pat_vars = mkVarSet arg_ids + local_vars' = pat_vars `unionVarSet` local_vars + (pat_tys, stack_ty') = splitTypeAt (length arg_tys) stack_ty + + -- construct and desugar a case expression with multiple scrutinees + (core_body, free_vars, env_ids') <- trimInput \env_ids -> do + stack_id <- newSysLocalMDs stack_ty' + (match', core_choices) + <- dsCases ids local_vars' stack_id stack_ty' res_ty match + + let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match' + in_ty = envStackType env_ids stack_ty' + discrims = map nlHsVar arg_ids + (discrim_vars, matching_code) + <- matchWrapper (ArrowMatchCtxt match_ctxt) (Just discrims) match' + core_body <- flip (bind_vars discrim_vars) matching_code <$> + traverse dsLExpr discrims + + core_matches <- matchEnvStack env_ids stack_id core_body + return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, + exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars') + + param_ids <- newSysLocalsMDs pat_tys + stack_id' <- newSysLocalMDs stack_ty' + + -- the expression is built from the inside out, so the actions + -- are presented in reverse order + + let -- build a new environment, plus what's left of the stack + core_expr = buildEnvStack env_ids' stack_id' + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty' + + -- bind the scrutinees to the parameters + let match_code = bind_vars arg_ids (map Var param_ids) core_expr + + -- match the parameters against the top of the old stack + (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code + -- match the old environment and stack against the input + select_code <- matchEnvStack env_ids stack_id param_code + return (do_premap ids in_ty in_ty' res_ty select_code core_body, + free_vars `uniqDSetMinusUniqSet` pat_vars) + where + bind_vars vars exprs expr = foldr (uncurry bindNonRec) expr $ zip vars exprs + +-- D; ys |-a cmd : stk --> t +-- ---------------------------------- +-- D; xs |-a let binds in cmd : stk --> t +-- +-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c + +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@binds body) env_ids = do + let + defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds) + local_vars' = defined_vars `unionVarSet` local_vars + + (core_body, _free_vars, env_ids') + <- dsfixCmd ids local_vars' stack_ty res_ty body + stack_id <- newSysLocalMDs stack_ty + -- build a new environment, plus the stack, using the let bindings + core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) + -- match the old environment and stack against the input + core_map <- matchEnvStack env_ids stack_id core_binds + return (do_premap ids + (envStackType env_ids stack_ty) + (envStackType env_ids' stack_ty) + res_ty + core_map + core_body, + exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars) + +-- D; xs |-a ss : t +-- ---------------------------------- +-- D; xs |-a do { ss } : () --> t +-- +-- ---> premap (\ (env,stk) -> env) c + +dsCmd ids local_vars stack_ty res_ty (HsCmdDo _ (L _ stmts)) env_ids = do + (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids + let env_ty = mkBigCoreVarTupTy env_ids + core_fst <- mkFstExpr env_ty stack_ty + return (do_premap ids + (mkCorePairTy env_ty stack_ty) + env_ty + res_ty + core_fst + core_stmts, + env_ids') + +-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t +-- D; xs |-a ci :: stki --> ti +-- ----------------------------------- +-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn + +dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ args) env_ids = do + let env_ty = mkBigCoreVarTupTy env_ids + core_op <- dsLExpr op + (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args + return (mkApps (App core_op (Type env_ty)) core_args, + unionDVarSets fv_sets) + +dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do + (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids + dsHsWrapper wrap $ \core_wrap -> + return (core_wrap core_cmd, env_ids') + +-- D; ys |-a c : stk --> t (ys <= xs) +-- --------------------- +-- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c + +dsTrimCmdArg + :: IdSet -- set of local vars available to this command + -> [Id] -- list of vars in the input to this command + -> LHsCmdTop GhcTc -- command argument to desugar + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free +dsTrimCmdArg local_vars env_ids + (L _ (HsCmdTop + (CmdTopTc stack_ty cmd_ty ids) cmd )) = do + (meth_binds, meth_ids) <- mkCmdEnv ids + (core_cmd, free_vars, env_ids') + <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd + stack_id <- newSysLocalMDs stack_ty + trim_code + <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) + let + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty + arg_code = if env_ids' == env_ids then core_cmd else + do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd + return (mkLets meth_binds arg_code, free_vars) + +-- Given D; xs |-a c : stk --> t, builds c with xs fed back. +-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) + +dsfixCmd + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> LHsCmd GhcTc -- command to desugar + -> DsM (CoreExpr, -- desugared expression + DIdSet, -- subset of local vars that occur free + [Id]) -- the same local vars as a list, fed back +dsfixCmd ids local_vars stk_ty cmd_ty cmd + = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) + +-- Feed back the list of local variables actually used a command, +-- for use as the input tuple of the generated arrow. + +trimInput + :: ([Id] -> DsM (CoreExpr, DIdSet)) + -> DsM (CoreExpr, -- desugared expression + DIdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list, fed back to + -- the inner function to form the tuple of + -- inputs to the arrow. +trimInput build_arrow + = fixDs (\ ~(_,_,env_ids) -> do + (core_cmd, free_vars) <- build_arrow env_ids + return (core_cmd, free_vars, dVarSetElems free_vars)) + +-- Desugaring for both HsCmdLam +-- +-- D; ys |-a cmd : stk t' +-- ----------------------------------------------- +-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t' +-- +-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd +dsCmdLam :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> [LPat GhcTc] -- argument patterns to desugar + -> LHsCmd GhcTc -- body to desugar + -> [Id] -- list of vars in the input to this command + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free +dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do + let pat_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats) + let local_vars' = pat_vars `unionVarSet` local_vars + (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty + (core_body, free_vars, env_ids') + <- dsfixCmd ids local_vars' stack_ty' res_ty body + param_ids <- newSysLocalsMDs pat_tys + stack_id' <- newSysLocalMDs stack_ty' + + -- the expression is built from the inside out, so the actions + -- are presented in reverse order + + let -- build a new environment, plus what's left of the stack + core_expr = buildEnvStack env_ids' stack_id' + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty' + lam_cxt = ArrowMatchCtxt (ArrowLamAlt LamSingle) + + fail_expr <- mkFailExpr lam_cxt in_ty' + -- match the patterns against the parameters + match_code <- matchSimplys (map Var param_ids) lam_cxt pats core_expr + fail_expr + -- match the parameters against the top of the old stack + (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code + -- match the old environment and stack against the input + select_code <- matchEnvStack env_ids stack_id param_code + return (do_premap ids in_ty in_ty' res_ty select_code core_body, + free_vars `uniqDSetMinusUniqSet` pat_vars) + +-- Used for case and \case(s) +-- See Note [Desugaring HsCmdCase] +dsCases :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Id -- stack id + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> MatchGroup GhcTc (LHsCmd GhcTc) -- match group to desugar + -> DsM (MatchGroup GhcTc (LHsExpr GhcTc), -- match group with choice tree + CoreExpr) -- desugared choices +dsCases ids local_vars stack_id stack_ty res_ty + (MG { mg_alts = L l matches + , mg_ext = MatchGroupTc arg_tys _ origin + }) = do + + -- Extract and desugar the leaf commands in the case, building tuple + -- expressions that will (after tagging) replace these leaves + + let leaves = concatMap leavesMatch matches + make_branch (leaf, bound_vars) = do + (core_leaf, _fvs, leaf_ids) + <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty + res_ty leaf + return ([mkHsEnvStackExpr leaf_ids stack_id], + envStackType leaf_ids stack_ty, + core_leaf) + + branches <- mapM make_branch leaves + either_con <- dsLookupTyCon eitherTyConName + left_con <- dsLookupDataCon leftDataConName + right_con <- dsLookupDataCon rightDataConName + void_ty <- mkTyConTy <$> dsLookupTyCon voidTyConName + let + left_id = mkConLikeTc (RealDataCon left_con) + right_id = mkConLikeTc (RealDataCon right_con) + left_expr ty1 ty2 e = noLocA $ HsApp noExtField + (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e + right_expr ty1 ty2 e = noLocA $ HsApp noExtField + (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e + + -- Prefix each tuple with a distinct series of Left's and Right's, + -- in a balanced way, keeping track of the types. + + merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr) + -> ([LHsExpr GhcTc], Type, CoreExpr) + -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ + merge_branches (builds1, in_ty1, core_exp1) + (builds2, in_ty2, core_exp2) + = (map (left_expr in_ty1 in_ty2) builds1 ++ + map (right_expr in_ty1 in_ty2) builds2, + mkTyConApp either_con [in_ty1, in_ty2], + do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2) + (leaves', sum_ty, core_choices) <- case nonEmpty branches of + Just bs -> return $ foldb merge_branches bs + -- when the case command has no alternatives, the sum type from + -- Note [Desugaring HsCmdCase] becomes the empty sum type, + -- i.e. Void. The choices then effectively become `arr absurd`, + -- implemented as `arr \case {}`. + Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$> + dsExpr (HsLam noAnn LamCase + (MG { mg_alts = noLocA [] + , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated OtherExpansion SkipPmc) + })) + + -- Replace the commands in the case with these tagged tuples, + -- yielding a HsExpr Id we can feed to dsExpr. + + let (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches + + -- Note that we replace the MatchGroup result type by sum_ty, + -- which is the type of matches' + return (MG { mg_alts = L l matches' + , mg_ext = MatchGroupTc arg_tys sum_ty origin + }, + core_choices) + +{- +Translation of command judgements of the form + + D |-a do { ss } : t +-} + +dsCmdDo :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> Type -- return type of the statement + -> [CmdLStmt GhcTc] -- statements to desugar + -> [Id] -- list of vars in the input to this statement + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +dsCmdDo _ _ _ [] _ = panic "dsCmdDo" + +-- D; xs |-a c : () --> t +-- -------------------------- +-- D; xs |-a do { c } : t +-- +-- ---> premap (\ (xs) -> ((xs), ())) c + +dsCmdDo ids local_vars res_ty [L _ (LastStmt _ body _ _)] env_ids = do + (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids + let env_ty = mkBigCoreVarTupTy env_ids + env_var <- newSysLocalMDs env_ty + let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) + return (do_premap ids + env_ty + (mkCorePairTy env_ty unitTy) + res_ty + core_map + core_body, + env_ids') + +dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do + let bound_vars = mkVarSet (collectLStmtBinders CollWithDictBinders stmt) + let local_vars' = bound_vars `unionVarSet` local_vars + (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids + return (do_compose ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy env_ids') + res_ty + core_stmt + core_stmts, + fv_stmt) + +{- +A statement maps one local environment to another, and is represented +as an arrow from one tuple type to another. A statement sequence is +translated to a composition of such arrows. +-} + +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id] + -> DsM (CoreExpr, DIdSet) +dsCmdLStmt ids local_vars out_ids cmd env_ids + = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids + +dsCmdStmt + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- list of vars in the output of this statement + -> CmdStmt GhcTc -- statement to desugar + -> [Id] -- list of vars in the input to this statement + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +-- D; xs1 |-a c : () --> t +-- D; xs' |-a do { ss } : t' +-- ------------------------------ +-- D; xs |-a do { c; ss } : t' +-- +-- ---> premap (\ ((xs)) -> (((xs1),()),(xs'))) +-- (first c >>> arr snd) >>> ss + +dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do + (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd + core_mux <- matchEnv env_ids + (mkCorePairExpr + (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) + (mkBigCoreVarTup out_ids)) + let + in_ty = mkBigCoreVarTupTy env_ids + in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy + out_ty = mkBigCoreVarTupTy out_ids + before_c_ty = mkCorePairTy in_ty1 out_ty + after_c_ty = mkCorePairTy c_ty out_ty + snd_fn <- mkSndExpr c_ty out_ty + return (do_premap ids in_ty before_c_ty out_ty core_mux $ + do_compose ids before_c_ty after_c_ty out_ty + (do_first ids in_ty1 c_ty out_ty core_cmd) $ + do_arr ids after_c_ty out_ty snd_fn, + extendDVarSetList fv_cmd out_ids) + +-- D; xs1 |-a c : () --> t +-- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p) +-- ----------------------------------- +-- D; xs |-a do { p <- c; ss } : t' +-- +-- ---> premap (\ (xs) -> (((xs1),()),(xs2))) +-- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss +-- +-- It would be simpler and more consistent to do this using second, +-- but that's likely to be defined in terms of first. + +dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do + let pat_ty = hsLPatType pat + (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd + let pat_vars = mkVarSet (collectPatBinders CollWithDictBinders pat) + let + env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids + env_ty2 = mkBigCoreVarTupTy env_ids2 + + -- multiplexing function + -- \ (xs) -> (((xs1),()),(xs2)) + + core_mux <- matchEnv env_ids + (mkCorePairExpr + (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) + (mkBigCoreVarTup env_ids2)) + + -- projection function + -- \ (p, (xs2)) -> (zs) + + env_id <- newSysLocalMDs env_ty2 + let + after_c_ty = mkCorePairTy pat_ty env_ty2 + out_ty = mkBigCoreVarTupTy out_ids + body_expr <- coreCaseTuple env_id env_ids2 (mkBigCoreVarTup out_ids) + + fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty + pat_id <- selectSimpleMatchVarL ManyTy pat + match_code + <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) ManyTy pat body_expr fail_expr + pair_id <- newSysLocalMDs after_c_ty + let + proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) + + -- put it all together + let + in_ty = mkBigCoreVarTupTy env_ids + in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy + in_ty2 = mkBigCoreVarTupTy env_ids2 + before_c_ty = mkCorePairTy in_ty1 in_ty2 + return (do_premap ids in_ty before_c_ty out_ty core_mux $ + do_compose ids before_c_ty after_c_ty out_ty + (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $ + do_arr ids after_c_ty out_ty proj_expr, + fv_cmd `unionDVarSet` (mkDVarSet out_ids + `uniqDSetMinusUniqSet` pat_vars)) + +-- D; xs' |-a do { ss } : t +-- -------------------------------------- +-- D; xs |-a do { let binds; ss } : t +-- +-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss + +dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do + -- build a new environment using the let bindings + core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) + -- match the old environment against the input + core_map <- matchEnv env_ids core_binds + return (do_arr ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy out_ids) + core_map, + exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars) + +-- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ... +-- D; xs' |-a do { ss' } : t +-- ------------------------------------ +-- D; xs |-a do { rec ss; ss' } : t +-- +-- xs1 = xs' /\ defs(ss) +-- xs2 = xs' - defs(ss) +-- ys1 = ys - defs(ss) +-- ys2 = ys /\ defs(ss) +-- +-- ---> arr (\(xs) -> ((ys1),(xs2))) >>> +-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> +-- arr (\((xs1),(xs2)) -> (xs')) >>> ss' + +dsCmdStmt ids local_vars out_ids + (RecStmt { recS_stmts = L _ stmts + , recS_later_ids = later_ids, recS_rec_ids = rec_ids + , recS_ext = RecStmtTc { recS_later_rets = later_rets + , recS_rec_rets = rec_rets } }) + env_ids = do + let + later_ids_set = mkVarSet later_ids + env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids + env2_id_set = mkDVarSet env2_ids + env2_ty = mkBigCoreVarTupTy env2_ids + + -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) + + env2_id <- newSysLocalMDs env2_ty + let + later_ty = mkBigCoreVarTupTy later_ids + post_pair_ty = mkCorePairTy later_ty env2_ty + post_loop_body <- coreCaseTuple env2_id env2_ids (mkBigCoreVarTup out_ids) + + post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body + + --- loop (...) + + (core_loop, env1_id_set, env1_ids) + <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets + + -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids)) + + let + env1_ty = mkBigCoreVarTupTy env1_ids + pre_pair_ty = mkCorePairTy env1_ty env2_ty + pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids) + (mkBigCoreVarTup env2_ids) + + pre_loop_fn <- matchEnv env_ids pre_loop_body + + -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn + + let + env_ty = mkBigCoreVarTupTy env_ids + out_ty = mkBigCoreVarTupTy out_ids + core_body = do_premap ids env_ty pre_pair_ty out_ty + pre_loop_fn + (do_compose ids pre_pair_ty post_pair_ty out_ty + (do_first ids env1_ty later_ty env2_ty + core_loop) + (do_arr ids post_pair_ty out_ty + post_loop_fn)) + + return (core_body, env1_id_set `unionDVarSet` env2_id_set) + +dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) + +-- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) +-- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>> + +dsRecCmd + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [CmdLStmt GhcTc] -- list of statements inside the RecCmd + -> [Id] -- list of vars defined here and used later + -> [HsExpr GhcTc] -- expressions corresponding to later_ids + -> [Id] -- list of vars fed back through the loop + -> [HsExpr GhcTc] -- expressions corresponding to rec_ids + -> DsM (CoreExpr, -- desugared statement + DIdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list + +dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do + let + later_id_set = mkVarSet later_ids + rec_id_set = mkVarSet rec_ids + local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars + + -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets)) + + core_later_rets <- mapM dsExpr later_rets + core_rec_rets <- mapM dsExpr rec_rets + let + -- possibly polymorphic version of vars of later_ids and rec_ids + out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets) + out_ty = mkBigCoreVarTupTy out_ids + + later_tuple = mkBigCoreTup core_later_rets + later_ty = mkBigCoreVarTupTy later_ids + + rec_tuple = mkBigCoreTup core_rec_rets + rec_ty = mkBigCoreVarTupTy rec_ids + + out_pair = mkCorePairExpr later_tuple rec_tuple + out_pair_ty = mkCorePairTy later_ty rec_ty + + mk_pair_fn <- matchEnv out_ids out_pair + + -- ss + + (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts + + -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) + + rec_id <- newSysLocalMDs rec_ty + let + env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set + env1_ids = dVarSetElems env1_id_set + env1_ty = mkBigCoreVarTupTy env1_ids + in_pair_ty = mkCorePairTy env1_ty rec_ty + core_body = mkBigCoreTup (map selectVar env_ids) + where + selectVar v + | v `elemVarSet` rec_id_set + = mkBigTupleSelector rec_ids v rec_id (Var rec_id) + | otherwise = Var v + + squash_pair_fn <- matchEnvStack env1_ids rec_id core_body + + -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn)) + + let + env_ty = mkBigCoreVarTupTy env_ids + core_loop = do_loop ids env1_ty later_ty rec_ty + (do_premap ids in_pair_ty env_ty out_pair_ty + squash_pair_fn + (do_compose ids env_ty out_ty out_pair_ty + core_stmts + (do_arr ids out_ty out_pair_ty mk_pair_fn))) + + return (core_loop, env1_id_set, env1_ids) + +{- +A sequence of statements (as in a rec) is desugared to an arrow between +two environments (no stack) +-} + +dsfixCmdStmts + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- output vars of these statements + -> [CmdLStmt GhcTc] -- statements to desugar + -> DsM (CoreExpr, -- desugared expression + DIdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list + +dsfixCmdStmts ids local_vars out_ids stmts + = trimInput (dsCmdStmts ids local_vars out_ids stmts) + -- TODO: Add representation polymorphism check for the resulting expression. + -- But I (Richard E.) don't know enough about arrows to do so. + +dsCmdStmts + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- output vars of these statements + -> [CmdLStmt GhcTc] -- statements to desugar + -> [Id] -- list of vars in the input to these statements + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +dsCmdStmts ids local_vars out_ids [stmt] env_ids + = dsCmdLStmt ids local_vars out_ids stmt env_ids + +dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do + let bound_vars = mkVarSet (collectLStmtBinders CollWithDictBinders stmt) + let local_vars' = bound_vars `unionVarSet` local_vars + (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids + return (do_compose ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy env_ids') + (mkBigCoreVarTupTy out_ids) + core_stmt + core_stmts, + fv_stmt) + +dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" + +-- Match a list of expressions against a list of patterns, left-to-right. + +matchSimplys :: [CoreExpr] -- Scrutinees + -> HsMatchContextRn -- Match kind + -> [LPat GhcTc] -- Patterns they should match + -> CoreExpr -- Return this if they all match + -> CoreExpr -- Return this if they don't + -> DsM CoreExpr +matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr +matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do + match_code <- matchSimplys exps ctxt pats result_expr fail_expr + matchSimply exp ctxt ManyTy pat match_code fail_expr +matchSimplys _ _ _ _ _ = panic "matchSimplys" + +-- List of leaf expressions, with set of variables bound in each + +leavesMatch :: LMatch GhcTc (LocatedA (body GhcTc)) + -> [(LocatedA (body GhcTc), IdSet)] +leavesMatch (L _ (Match { m_pats = L _ pats + , m_grhss = GRHSs _ grhss binds })) + = let + defined_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats) + `unionVarSet` + mkVarSet (collectLocalBinders CollWithDictBinders binds) + in + [(body, + mkVarSet (collectLStmtsBinders CollWithDictBinders stmts) + `unionVarSet` defined_vars) + | L _ (GRHS _ stmts body) <- toList grhss] + +-- Replace the leaf commands in a match + +replaceLeavesMatch + :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc))) + , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc)))) + => Type -- new result type + -> [LocatedA (body' GhcTc)] -- replacement leaf expressions of that type + -> LMatch GhcTc (LocatedA (body GhcTc)) -- the matches of a case command + -> ([LocatedA (body' GhcTc)], -- remaining leaf expressions + LMatch GhcTc (LocatedA (body' GhcTc))) -- updated match +replaceLeavesMatch _res_ty leaves + (L loc + match@(Match { m_grhss = GRHSs x grhss binds })) + = let + (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss + in + (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) + +replaceLeavesGRHS + :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc))) + , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc)))) + => [LocatedA (body' GhcTc)] -- replacement leaf expressions of that type + -> LGRHS GhcTc (LocatedA (body GhcTc)) -- rhss of a case command + -> ([LocatedA (body' GhcTc)], -- remaining leaf expressions + LGRHS GhcTc (LocatedA (body' GhcTc))) -- updated GRHS +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _)) + = (leaves, L loc (GRHS x stmts leaf)) +replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" + +-- Balanced fold of a non-empty list. + +foldb :: (a -> a -> a) -> NonEmpty a -> a +foldb _ (x:|[]) = x +foldb f xs = foldb f (fold_pairs xs) + where + fold_pairs (x1:|x2:xs) = f x1 x2 :| keep_empty fold_pairs xs + fold_pairs xs = xs + + keep_empty :: (NonEmpty a -> NonEmpty a) -> [a] -> [a] + keep_empty f = maybe [] (toList . f) . nonEmpty diff --git a/GHC/HsToCore/Binds.hs b/GHC/HsToCore/Binds.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Binds.hs @@ -0,0 +1,1854 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching bindings (HsBinds and MonoBinds) + +Handles @HsBinds@; those at the top level require different handling, +in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at +lower levels it is preserved with @let@/@letrec@s). +-} + +module GHC.HsToCore.Binds + ( dsTopLHsBinds, dsLHsBinds + , dsImpSpecs, decomposeRuleLhs + , dsHsWrapper, dsHsWrappers + , dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds + , dsWarnOrphanRule + ) +where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Driver.Config +import qualified GHC.LanguageExtensions as LangExt +import GHC.Unit.Module + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) +import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper ) + +import GHC.HsToCore.Pmc.Utils( tracePm ) + +import GHC.HsToCore.Monad +import GHC.HsToCore.Errors.Types +import GHC.HsToCore.GuardedRHSs +import GHC.HsToCore.Utils +import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) + +import GHC.Hs -- lots of things +import GHC.Core -- lots of things +import GHC.Core.SimpleOpt +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.InstEnv ( CanonicalEvidence(..) ) +import GHC.Core.Make +import GHC.Core.Utils +import GHC.Core.Opt.Arity ( etaExpand ) +import GHC.Core.Unfold.Make +import GHC.Core.FVs +import GHC.Core.Predicate +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Rules +import GHC.Core.Ppr( pprCoreBinders ) +import GHC.Core.TyCo.Compare( eqType ) + +import GHC.Builtin.Names +import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy ) + +import GHC.Tc.Types.Evidence + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Var( EvVar, mkLocalVar ) +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Unique.Set( nonDetEltsUniqSet ) + +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Data.Graph.Directed +import GHC.Data.Bag + +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Monad + + +{-********************************************************************** +* * + Desugaring a MonoBinds +* * +**********************************************************************-} + +-- | Desugar top level binds, strict binds are treated like normal +-- binds since there is no good time to force before first usage. +dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr)) +dsTopLHsBinds binds + -- see Note [Strict binds checks] + | not (null unlifted_binds) || not (null bang_binds) + = do { mapM_ (top_level_err UnliftedTypeBinds) unlifted_binds + ; mapM_ (top_level_err StrictBinds) bang_binds + ; return nilOL } + + | otherwise + = do { (force_vars, prs) <- dsLHsBinds binds + ; when debugIsOn $ + do { xstrict <- xoptM LangExt.Strict + ; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) } + -- with -XStrict, even top-level vars are listed as force vars. + + ; return (toOL prs) } + + where + unlifted_binds = filter (isUnliftedHsBind . unLoc) binds + bang_binds = filter (isBangedHsBind . unLoc) binds + + top_level_err bindsType (L loc bind) + = putSrcSpanDs (locA loc) $ + diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind) +{- +Note [Return non-recursive bindings in dependency order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For recursive bindings, the desugarer has no choice: it returns a single big +Rec{...} group. + +But for /non-recursive/ bindings, the desugarer guarantees to desugar them to +a sequence of non-recurive Core bindings, in dependency order. + +Why is this important? Partly it saves a bit of work in the first run of the +occurrence analyser. But more importantly, for linear types, non-recursive lets +can be linear whereas recursive-let can't. Since we check the output of the +desugarer for linearity (see also Note [Linting linearity]), desugaring +non-recursive lets to recursive lets would break linearity checks. An +alternative is to refine the typing rule for recursive lets so that we don't +have to care (see in particular #23218 and #18694), but the outcome of this line +of work is still unclear. In the meantime, being a little precise in the +desugarer is cheap. (paragraph written on 2023-06-09) + +In dsLHSBinds (and dependencies), a single binding can be desugared to multiple +bindings. For instance because the source binding has the {-# SPECIALIZE #-} +pragma. In: + +f _ = … + where + {-# SPECIALIZE g :: F Int -> F Int #-} + g :: C a => F a -> F a + g _ = … + +The g binding desugars to + +let { + $sg = … } in + + g + [RULES: "SPEC g" g @Int $dC = $sg] + g = … + +In order to avoid generating a letrec that will immediately be reordered, we +make sure to return the binding in dependency order [$sg, g]. + +-} + +-- | Desugar all other kind of bindings, Ids of strict binds are returned to +-- later be forced in the binding group body, see Note [Desugar Strict binds] +-- +-- Invariant: the desugared bindings are returned in dependency order, +-- see Note [Return non-recursive bindings in dependency order] +dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBinds binds + = do { ds_bs <- mapM dsLHsBind binds + ; return (foldr (\(a, a') (b, b') -> (a ++ b, a' ++ b')) + ([], []) ds_bs) } + +------------------------ +dsLHsBind :: LHsBind GhcTc + -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBind (L loc bind) = do dflags <- getDynFlags + putSrcSpanDs (locA loc) $ dsHsBind dflags bind + +-- | Desugar a single binding (or group of recursive binds). +-- +-- Invariant: the desugared bindings are returned in dependency order, +-- see Note [Return non-recursive bindings in dependency order] +dsHsBind :: DynFlags + -> HsBind GhcTc + -> DsM ([Id], [(Id,CoreExpr)]) + -- ^ The Ids of strict binds, to be forced in the body of the + -- binding group see Note [Desugar Strict binds] and all + -- bindings and their desugared right hand sides. + +dsHsBind dflags (VarBind { var_id = var + , var_rhs = expr }) + = do { core_expr <- dsLExpr expr + -- Dictionary bindings are always VarBinds, + -- so we only need do this here + ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr + force_var = if xopt LangExt.Strict dflags + then [id] + else [] + ; return (force_var, [core_bind]) } + +dsHsBind dflags b@(FunBind { fun_id = L loc fun + , fun_matches = matches + , fun_ext = (co_fn, tick) + }) + = dsHsWrapper co_fn $ \core_wrap -> + do { (args, body) <- matchWrapper (mkPrefixFunRhs (L loc (idName fun)) noAnn) Nothing matches + + ; let body' = mkOptTickBox tick body + rhs = core_wrap (mkLams args body') + core_binds@(id,_) = makeCorePair dflags fun False 0 rhs + force_var + -- Bindings are strict when -XStrict is enabled + | xopt LangExt.Strict dflags + , matchGroupArity matches == 0 -- no need to force lambdas + = [id] + | isBangedHsBind b + = [id] + | otherwise + = [] + ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) + -- , ppr (mg_alts matches) + -- , ppr args, ppr core_binds, ppr body']) $ + return (force_var, [core_binds]) } + +dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_ext = (ty, (rhs_tick, var_ticks)) + }) + = do { rhss_nablas <- pmcGRHSs PatBindGuards grhss + ; body_expr <- dsGuarded grhss ty rhss_nablas + ; let body' = mkOptTickBox rhs_tick body_expr + pat' = decideBangHood dflags pat + ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat PatBindRhs body' + -- We silently ignore inline pragmas; no makeCorePair + -- Not so cool, but really doesn't matter + ; let force_var' = if isBangedLPat pat' + then [force_var] + else [] + ; return (force_var', sel_binds) } + +dsHsBind + dflags + (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = binds, abs_sig = has_sig })) + = addTyCs FromSource (listToBag dicts) $ + -- addTyCs: push type constraints deeper + -- for inner pattern match check + -- See Check, Note [Long-distance information] + dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do + do { ds_binds <- dsLHsBinds binds + -- dsAbsBinds does the hard work + ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds + (isSingleton binds) has_sig } + +dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" + +----------------------- +dsAbsBinds :: DynFlags + -> [TyVar] -> [EvVar] -> [ABExport] + -> [CoreBind] -- Desugared evidence bindings + -> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings + -> Bool -- Single source binding + -> Bool -- Single binding with signature + -> DsM ([Id], [(Id,CoreExpr)]) + +dsAbsBinds dflags tyvars dicts exports + ds_ev_binds (force_vars, bind_prs) is_singleton has_sig + + -- A very important common case: one exported variable + -- Non-recursive bindings come through this way + -- So do self-recursive bindings + -- gbl_id = wrap (/\tvs \dicts. let ev_binds + -- letrec bind_prs + -- in lcl_id) + | [export] <- exports + , ABE { abe_poly = global_id, abe_mono = local_id + , abe_wrap = wrap, abe_prags = prags } <- export + , Just force_vars' <- case force_vars of + [] -> Just [] + [v] | v == local_id -> Just [global_id] + _ -> Nothing + -- If there is a variable to force, it's just the + -- single variable we are binding here + = do { dsHsWrapper wrap $ \core_wrap -> do -- Usually the identity + { let rhs = core_wrap $ + mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_ev_binds $ + body + + body | has_sig + , [(_, lrhs)] <- bind_prs + = lrhs + | otherwise + = mkLetRec bind_prs (Var local_id) + + ; (spec_binds, rules) <- dsSpecs rhs prags + + ; let global_id' = addIdSpecialisations global_id rules + main_bind = makeCorePair dflags global_id' + (isDefaultMethod prags) + (dictArity dicts) rhs + + ; return (force_vars', fromOL spec_binds ++ [main_bind]) } } + + -- Another common case: no tyvars, no dicts + -- In this case we can have a much simpler desugaring + -- lcl_id{inl-prag} = rhs -- Auxiliary binds + -- gbl_id = lcl_id |> co -- Main binds + -- + -- See Note [The no-tyvar no-dict case] + | null tyvars, null dicts + = do { let wrap_first_bind f ((main, main_rhs):other_binds) = + ((main, f main_rhs):other_binds) + wrap_first_bind _ [] = panic "dsAbsBinds received an empty binding list" + + mk_main :: ABExport -> DsM (Id, CoreExpr) + mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id + , abe_wrap = wrap }) + -- No SpecPrags (no dicts) + -- Can't be a default method (default methods are singletons) + = do { dsHsWrapper wrap $ \core_wrap -> do + { return ( gbl_id `setInlinePragma` defaultInlinePragma + , core_wrap (Var lcl_id)) } } + ; main_prs <- mapM mk_main exports + ; let bind_prs' = map mk_aux_bind bind_prs + -- When there's a single source binding, we wrap the evidence binding in a + -- separate let-rec (DSB1) inside the first desugared binding (DSB2). + -- See Note [The no-tyvar no-dict case]. + final_prs | is_singleton = wrap_first_bind (mkCoreLets ds_ev_binds) bind_prs' + | otherwise = flattenBinds ds_ev_binds ++ bind_prs' + ; return (force_vars, final_prs ++ main_prs ) } + + -- The general case + -- See Note [Desugaring AbsBinds] + | otherwise + = do { let aux_binds = Rec (map mk_aux_bind bind_prs) + -- Monomorphic recursion possible, hence Rec + + new_force_vars = get_new_force_vars force_vars + locals = map abe_mono exports + all_locals = locals ++ new_force_vars + tup_expr = mkBigCoreVarTup all_locals + tup_ty = exprType tup_expr + ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_ev_binds $ + mkLet aux_binds $ + tup_expr + + ; poly_tup_id <- newSysLocalMDs (exprType poly_tup_rhs) + + -- Find corresponding global or make up a new one: sometimes + -- we need to make new export to desugar strict binds, see + -- Note [Desugar Strict binds] + ; (exported_force_vars, extra_exports) <- get_exports force_vars + + ; let mk_bind (ABE { abe_wrap = wrap + , abe_poly = global + , abe_mono = local, abe_prags = spec_prags }) + -- See Note [ABExport wrapper] in "GHC.Hs.Binds" + = do { tup_id <- newSysLocalMDs tup_ty + ; dsHsWrapper wrap $ \core_wrap -> do + { let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ + mkBigTupleSelector all_locals local tup_id $ + mkVarApps (Var poly_tup_id) (tyvars ++ dicts) + rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs + ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags + ; let global' = (global `setInlinePragma` defaultInlinePragma) + `addIdSpecialisations` rules + -- Kill the INLINE pragma because it applies to + -- the user written (local) function. The global + -- Id is just the selector. Hmm. + ; return (fromOL spec_binds ++ [(global', rhs)]) } } + + ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) + + ; return ( exported_force_vars + , (poly_tup_id, poly_tup_rhs) : + concat export_binds_s) } + where + mk_aux_bind :: (Id,CoreExpr) -> (Id,CoreExpr) + mk_aux_bind (lcl_id, rhs) = let lcl_w_inline = lookupVarEnv inline_env lcl_id + `orElse` lcl_id + in + makeCorePair dflags lcl_w_inline False 0 rhs + + inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with + -- the inline pragma from the source + -- The type checker put the inline pragma + -- on the *global* Id, so we need to transfer it + inline_env + = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) + | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports + , let prag = idInlinePragma gbl_id ] + + global_env :: IdEnv Id -- Maps local Id to its global exported Id + global_env = + mkVarEnv [ (local, global) + | ABE { abe_mono = local, abe_poly = global } <- exports + ] + + -- find variables that are not exported + get_new_force_vars lcls = + foldr (\lcl acc -> case lookupVarEnv global_env lcl of + Just _ -> acc + Nothing -> lcl:acc) + [] lcls + + -- find exports or make up new exports for force variables + get_exports :: [Id] -> DsM ([Id], [ABExport]) + get_exports lcls = + foldM (\(glbls, exports) lcl -> + case lookupVarEnv global_env lcl of + Just glbl -> return (glbl:glbls, exports) + Nothing -> do export <- mk_export lcl + let glbl = abe_poly export + return (glbl:glbls, export:exports)) + ([],[]) lcls + + mk_export local = + do global <- newSysLocalMDs + (exprType (mkLams tyvars (mkLams dicts (Var local)))) + return (ABE { abe_poly = global + , abe_mono = local + , abe_wrap = WpHole + , abe_prags = SpecPrags [] }) + +-- | This is where we apply INLINE and INLINABLE pragmas. All we need to +-- do is to attach the unfolding information to the Id. +-- +-- Other decisions about whether to inline are made in +-- `calcUnfoldingGuidance` but the decision about whether to then expose +-- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal` +-- using this information. +------------------------ +makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr + -> (Id, CoreExpr) +makeCorePair dflags gbl_id is_default_method dict_arity rhs + | is_default_method -- Default methods are *always* inlined + -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance + = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs) + + | otherwise + = case inlinePragmaSpec inline_prag of + NoUserInlinePrag -> (gbl_id, rhs) + NoInline {} -> (gbl_id, rhs) + Opaque {} -> (gbl_id, rhs) + Inlinable {} -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) + Inline {} -> inline_pair + where + simpl_opts = initSimpleOpts dflags + inline_prag = idInlinePragma gbl_id + inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs + inline_pair + | Just arity <- inlinePragmaSat inline_prag + -- Add an Unfolding for an INLINE (but not for NOINLINE) + -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] + , let real_arity = dict_arity + arity + -- NB: The arity passed to mkInlineUnfoldingWithArity + -- must take account of the dictionaries + = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc real_arity rhs + , etaExpand real_arity rhs) + + | otherwise + = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ + (gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs) + +dictArity :: [Var] -> Arity +-- Don't count coercion variables in arity +dictArity dicts = count isId dicts + +{- +Note [Desugaring AbsBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the general AbsBinds case we desugar the binding to this: + + tup a (d:Num a) = let fm = ...gm... + gm = ...fm... + in (fm,gm) + f a d = case tup a d of { (fm,gm) -> fm } + g a d = case tup a d of { (fm,gm) -> fm } + +Note [Rules and inlining] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Common special case: no type or dictionary abstraction +This is a bit less trivial than you might suppose +The naive way would be to desugar to something like + f_lcl = ...f_lcl... -- The "binds" from AbsBinds + M.f = f_lcl -- Generated from "exports" +But we don't want that, because if M.f isn't exported, +it'll be inlined unconditionally at every call site (its rhs is +trivial). That would be ok unless it has RULES, which would +thereby be completely lost. Bad, bad, bad. + +Instead we want to generate + M.f = ...f_lcl... + f_lcl = M.f +Now all is cool. The RULES are attached to M.f (by SimplCore), +and f_lcl is rapidly inlined away. + +This does not happen in the same way to polymorphic binds, +because they desugar to + M.f = /\a. let f_lcl = ...f_lcl... in f_lcl +Although I'm a bit worried about whether full laziness might +float the f_lcl binding out and then inline M.f at its call site + +Note [Specialising in no-dict case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even if there are no tyvars or dicts, we may have specialisation pragmas. +Class methods can generate + AbsBinds [] [] [( ... spec-prag] + { AbsBinds [tvs] [dicts] ...blah } +So the overloading is in the nested AbsBinds. A good example is in GHC.Float: + + class (Real a, Fractional a) => RealFrac a where + round :: (Integral b) => a -> b + + instance RealFrac Float where + {-# SPECIALIZE round :: Float -> Int #-} + +The top-level AbsBinds for $cround has no tyvars or dicts (because the +instance does not). But the method is locally overloaded! + +Note [The no-tyvar no-dict case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are desugaring + AbsBinds { tyvars = [] + , dicts = [] + , exports = [ ABE f fm, ABE g gm ] + , binds = B + , ev_binds = EB } +That is: no type variables or dictionary abstractions. Here, `f` and `fm` are +the polymorphic and monomorphic versions of `f`; in this special case they will +both have the same type. + +Specialising Note [Desugaring AbsBinds] for this case gives the desugaring + + tup = letrec EB' in letrec B' in (fm,gm) + f = case tup of { (fm,gm) -> fm } + g = case tup of { (fm,gm) -> fm } + +where B' is the result of desugaring B. This desugaring is a little silly: we +don't need the intermediate tuple (contrast with the general case where fm and f +have different types). So instead, in this case, we desugar to + + EB'; B'; f=fm; g=gm + +This is done in the `null tyvars, null dicts` case of `dsAbsBinds`. + +But there is a wrinkle (DSB1). If the original binding group was +/non-recursive/, we want to return a bunch of non-recursive bindings in +dependency order: see Note [Return non-recursive bindings in dependency order]. + +But there is no guarantee that EB', the desugared evidence bindings, will be +non-recursive. Happily, in the non-recursive case, B will have just a single +binding (f = rhs), so we can wrap EB' around its RHS, thus: + + fm = letrec EB' in rhs; f = fm + +There is a sub-wrinkle (DSB2). If B is a /pattern/ bindings, it will desugar to +a "main" binding followed by a bunch of selectors. The main binding always +comes first, so we can pick it out and wrap EB' around its RHS. For example + + AbsBinds { tyvars = [] + , dicts = [] + , exports = [ ABE p pm, ABE q qm ] + , binds = PatBind (pm, Just qm) rhs + , ev_binds = EB } + +can desguar to + + pt = let EB' in + case rhs of + (pm,Just qm) -> (pm,qm) + pm = case pt of (pm,qm) -> pm + qm = case pt of (pm,qm) -> qm + + p = pm + q = qm + +The first three bindings come from desugaring the PatBind, and subsequently +wrapping the RHS of the main binding in EB'. + +Why got to this trouble? It's a common case, and it removes the +quadratic-sized tuple desugaring. Less clutter, hopefully faster +compilation, especially in a case where there are a *lot* of +bindings. + +Note [Eta-expanding INLINE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo :: Eq a => a -> a + {-# INLINE foo #-} + foo x = ... + +If (foo d) ever gets floated out as a common sub-expression (which can +happen as a result of method sharing), there's a danger that we never +get to do the inlining, which is a Terribly Bad thing given that the +user said "inline"! + +To avoid this we preemptively eta-expand the definition, so that foo +has the arity with which it is declared in the source code. In this +example it has arity 2 (one for the Eq and one for x). Doing this +should mean that (foo d) is a PAP and we don't share it. + +Note [Nested arities] +~~~~~~~~~~~~~~~~~~~~~ +For reasons that are not entirely clear, method bindings come out looking like +this: + + AbsBinds [] [] [$cfromT <= [] fromT] + $cfromT [InlPrag=INLINE] :: T Bool -> Bool + { AbsBinds [] [] [fromT <= [] fromT_1] + fromT :: T Bool -> Bool + { fromT_1 ((TBool b)) = not b } } } + +Note the nested AbsBind. The arity for the unfolding on $cfromT should be +gotten from the binding for fromT_1. + +It might be better to have just one level of AbsBinds, but that requires more +thought! + + +Note [Desugar Strict binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma + +Desugaring strict variable bindings looks as follows (core below ==>) + + let !x = rhs + in body +==> + let x = rhs + in x `seq` body -- seq the variable + +and if it is a pattern binding the desugaring looks like + + let !pat = rhs + in body +==> + let x = rhs -- bind the rhs to a new variable + pat = x + in x `seq` body -- seq the new variable + +if there is no variable in the pattern desugaring looks like + + let False = rhs + in body +==> + let x = case rhs of {False -> (); _ -> error "Match failed"} + in x `seq` body + +In order to force the Ids in the binding group they are passed around +in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind. + +Consider a recursive group like this + + letrec + f : g = rhs[f,g] + in + +Without `Strict`, we get a translation like this: + + let t = /\a. letrec tm = rhs[fm,gm] + fm = case t of fm:_ -> fm + gm = case t of _:gm -> gm + in + (fm,gm) + + in let f = /\a. case t a of (fm,_) -> fm + in let g = /\a. case t a of (_,gm) -> gm + in + +Here `tm` is the monomorphic binding for `rhs`. + +With `Strict`, we want to force `tm`, but NOT `fm` or `gm`. +Alas, `tm` isn't in scope in the `in ` part. + +The simplest thing is to return it in the polymorphic +tuple `t`, thus: + + let t = /\a. letrec tm = rhs[fm,gm] + fm = case t of fm:_ -> fm + gm = case t of _:gm -> gm + in + (tm, fm, gm) + + in let f = /\a. case t a of (_,fm,_) -> fm + in let g = /\a. case t a of (_,_,gm) -> gm + in let tm = /\a. case t a of (tm,_,_) -> tm + in tm `seq` + + +See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more +detailed explanation of the desugaring of strict bindings. + +Wrinkle 1: forcing linear variables + +Consider + + let %1 !x = rhs in +==> + let x = rhs in x `seq` + +In the desugared version x is used in both arguments of seq. This isn't +recognised a linear. So we can't strictly speaking use seq. Instead, the code is +really desugared as + + let x = rhs in case x of x { _ -> } + +The shadowing with the case-binder is crucial. The linear linter (see +Note [Linting linearity] in GHC.Core.Lint) understands this as linear. This is +what the seqVar function does. + +To be more precise, suppose x has multiplicity p, the fully annotated seqVar (in +Core, p is really stored inside x) is + + case x of %p x { _ -> } + +In linear Core, case u of %p y { _ -> v } consumes u with multiplicity p, and +makes y available with multiplicity p in v. Which is exactly what we want. + +Wrinkle 2: linear patterns + +Consider the following linear binding (linear lets are always non-recursive): + + let + %1 f : g = rhs + in + +The general case would desugar it to + + let t = let tm = rhs + fm = case tm of fm:_ -> fm + gm = case tm of _:gm -> gm + in + (tm, fm, gm) + + in let f = case t a of (_,fm,_) -> fm + in let g = case t a of (_,_,gm) -> gm + in let tm = case t a of (tm,_,_) -> tm + in tm `seq` + +But all the case expression drop variables, which is prohibited by +linearity. But because this is a non-recursive let (in particular we're +desugaring a single binding), we can (and do) desugar the binding as a simple +case-expression instead: + + case rhs of { + (f:g) -> + } + +This is handled by the special case: a non-recursive PatBind in +GHC.HsToCore.Expr.ds_val_bind. + +Note [Strict binds checks] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several checks around properly formed strict bindings. They +all link to this Note. These checks must be here in the desugarer because +we cannot know whether or not a type is unlifted until after zonking, due +to representation polymorphism. These checks all used to be handled in the +typechecker in checkStrictBinds (before Jan '17). + +We define an "unlifted bind" to be any bind that binds an unlifted id. Note that + + x :: Char + (# True, x #) = blah + +is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind. + +Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind. +Define a "strict bind" to be either an unlifted bind or a banged bind. + +The restrictions are: + 1. Strict binds may not be top-level. Checked in dsTopLHsBinds. + + 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged + unlifted bind, but an unbanged bind looks lazy, and we don't want users to be + surprised by the strictness of an unlifted bind.) Checked in first clause + of GHC.HsToCore.Expr.ds_val_bind. + + 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type + variables or constraints.) Checked in first clause + of GHC.HsToCore.Expr.ds_val_bind. + + 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind. + +Note [Desugaring new-form SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +"New-form" SPECIALISE pragmas generate a SpecPragE record in the typechecker, +which is desugared in this module by `dsSpec`. For the context see +Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig + +Suppose we have + f :: forall a b c d. (Ord a, Ord b, Eq c, Ix d) => ... + f = rhs + {-# SPECIALISE f @p @[p] @[Int] @(q,r) #-} + +The type-checker generates `the_call` which looks like + + spe_bndrs = (dx1 :: Ord p) (dx2::Ix q) (dx3::Ix r) + the_call = let d6 = dx1 + d2 = $fOrdList d6 + d3 = $fEqList $fEqInt + d7 = dx1 -- Solver may introduce + d1 = d7 -- these indirections + d4 = $fIxPair dx2 dx3 + in f @p @p @[Int] @(q,r) + (d1::Ord p) (d2::Ord [p]) (d3::Eq [Int]) (d4::Ix (q,r) + +We /could/ generate + RULE f d1 d2 d3 d4 e1..en = $sf d1 d2 d3 d4 + $sf d1 d2 d3 d4 = d1 d2 d3 d4 + +But that would do no specialisation at all! What we want is this: + RULE f d1 _d2 _d3 d4 e1..en = $sf d1 d4 + $sf d1 d4 = let d7 = d1 -- Renaming + dx1 = d1 -- Renaming + d6 = d1 -- Renaming + d2 = $fOrdList d6 + d3 = $fEqList $fEqInt + in rhs d1 d2 d3 d4 + +Notice that: + * We pass some, but not all, of the matched dictionaries to $sf + + * We get specialisations for d2 and d3, but not for d1, nor d4. + + * We had to introduce some renaming bindings at the top + to line things up + +The transformation goes in these steps + +(S1) decomposeCall: decompose `the_call` into + - `binds`: the enclosing let-bindings + - `rule_lhs_args`: the arguments of the call itself + + If the expression in the SPECIALISE pragma had a type signature, such as + SPECIALISE g :: Eq b => Int -> b -> b + then the desugared expression may have type abstractions and applications + "in the way", like this: + (/\b. (\d:Eq b). let d1 = $dfOrdInt in f @Int @b d1 d) @b (d2:Eq b) + The lambdas come from the type signature, which is then re-instantiated, + hence the applications of those lambdas. + + To handle these, `decomposeCall` uses the simple optimiser to simplify + this to + let { d = d2; d1 = $dfOrdInt } in f @Int @b d1 d + + Wrinkle (S1a): do no inlining in this "simple optimiser" phase: + use `simpleOptExprNoInline`. E.g. we don't want to turn it into + f @Int @b $dfOrdInt d2 + because the latter is harder to match. Similarly if we have + let { d1=d; d2=d } in f d1 d2 + we don't want to inline d1/d2 to get this + f d d + + TL;DR: as a result the dictionary arguments of the actual call, + `rule_lhs_args` are all distinct dictionary variables, not + expressions. + +(S2) Compute `rule_bndrs`: the free vars of `rule_lhs_args`, which + will be the forall'd template variables of the RULE. In the example, + rule_bndrs = d1,d2,d3,d4 + These variables will get values from a successful RULE match. + +(S3) `getRenamings`: starting from the rule_bndrs, make bindings for + all other variables that are equal to them. In the example, we + make renaming-bindings for d7, dx1, d6. Our goal is to bind + as many variables as possible, by deducing them from `rule_bndrs`. + If we have the binding + d1 = d7 (where `d1` is a rule_bndr) + we want to generate the renaming + d7 = d1 + which instead deduces d7 from d1 + + NB1: we don't actually have to remove the original bindings; + it's harmless to leave them + NB2: We also reverse bindings like d1 = d2 |> co, to get + d2 = d1 |> sym co + It's easy and slightly improves our ability to get bindings + for local variables from `rule_bndrs`. I'm not sure if it + matters in practice, but it's easy to do. + NB3: `getRenamings` works innermost first, so that we get transitivity. + E.g in our example we have + d7 = dx1 + d1 = d7 where d1 is rule_bndr + `getRenamings` generate the renamings + dx1 = d1 + d7 = d2 + +(S4) `pickSpecBinds`: pick the bindings we want to keep in the + specialised function. We start from `known_vars`, the variables we + know, namely the `rule_bndrs` and the binders from (S3), which are + all equal to one of the `rule_bndrs`. + + Then we keep a binding if the free vars of its RHS are all known. + In our example, `d2` and `d3` are both picked, but `d4` is not. + The non-picked ones won't end up being specialised. + +(S5) Finally, work out which of the `rule_bndrs` we must pass on to + specialised function. We just filter out ones bound by a renaming + or a picked binding. +-} + +------------------------ +dsSpecs :: CoreExpr -- Its rhs + -> TcSpecPrags + -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids + , [CoreRule] ) -- Rules for the Global Ids +-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig +dsSpecs _ IsDefaultMethod = return (nilOL, []) +dsSpecs poly_rhs (SpecPrags sps) + = do { pairs <- mapMaybeM (dsLSpec poly_rhs) sps + ; let (spec_binds_s, rules) = unzip pairs + ; return (concatOL spec_binds_s, rules) } + +dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) +dsImpSpecs imp_specs + = do { spec_prs <- mapMaybeM spec_one imp_specs + ; let (spec_binds, spec_rules) = unzip spec_prs + ; return (concatOL spec_binds, spec_rules) } + where + spec_one (L loc prag) = putSrcSpanDs loc $ + dsSpec (get_rhs prag) prag + + get_rhs (SpecPrag poly_id _ _) = get_rhs1 poly_id + get_rhs (SpecPragE { spe_fn_id = poly_id }) = get_rhs1 poly_id + + get_rhs1 poly_id + | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id) + = unfolding -- Imported Id; this is its unfolding + -- Use realIdUnfolding so we get the unfolding + -- even when it is a loop breaker. + -- We want to specialise recursive functions! + | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) + -- The type checker has checked that it *has* an unfolding + +dsLSpec :: CoreExpr -> Located TcSpecPrag + -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) +dsLSpec poly_rhs (L loc prag) + = putSrcSpanDs loc $ dsSpec poly_rhs prag + +dsSpec :: CoreExpr -- RHS to be specialised + -> TcSpecPrag + -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) +dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl) + -- SpecPrag case: See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig + | (spec_bndrs, spec_app) <- collectHsWrapBinders spec_co + -- spec_co looks like + -- \spec_bndrs. [] spec_args + -- perhaps with the body of the lambda wrapped in some WpLets + -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2 + = dsHsWrapper spec_app $ \core_app -> + dsSpec_help (idName poly_id) poly_id poly_rhs + spec_inl spec_bndrs (core_app (Var poly_id)) + +dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm + , spe_fn_id = poly_id + , spe_inl = spec_inl + , spe_bndrs = bndrs + , spe_call = the_call }) + -- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig + = do { ds_call <- unsetGOptM Opt_EnableRewriteRules $ -- Note [Desugaring RULE left hand sides] + unsetWOptM Opt_WarnIdentities $ + zapUnspecables $ + dsLExpr the_call + ; dsSpec_help poly_nm poly_id poly_rhs spec_inl bndrs ds_call } + +dsSpec_help :: Name -> Id -> CoreExpr -- Function to specialise + -> InlinePragma -> [Var] -> CoreExpr + -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) +dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call + = do { -- Decompose the call + -- Step (S1) of Note [Desugaring new-form SPECIALISE pragmas] + mb_call_info <- decomposeCall poly_id ds_call + ; case mb_call_info of { + Nothing -> return Nothing ; + Just (binds, rule_lhs_args) -> + + do { dflags <- getDynFlags + ; this_mod <- getModule + ; uniq <- newUnique + ; let locals = mkVarSet orig_bndrs `extendVarSetList` bindersOfBinds binds + is_local :: Var -> Bool + is_local v = v `elemVarSet` locals + + -- Find `rule_bndrs`: (S2) of Note [Desugaring new-form SPECIALISE pragmas] + rule_bndrs = scopedSort (exprsSomeFreeVarsList is_local rule_lhs_args) + + -- getRenamings: (S3) of Note [Desugaring new-form SPECIALISE pragmas] + rn_binds = getRenamings orig_bndrs binds rule_bndrs + + -- pickSpecBinds: (S4) of Note [Desugaring new-form SPECIALISE pragmas] + known_vars = mkVarSet rule_bndrs `extendVarSetList` bindersOfBinds rn_binds + picked_binds = pickSpecBinds is_local known_vars binds + + -- Find `spec_bndrs`: (S5) of Note [Desugaring new-form SPECIALISE pragmas] + -- Make spec_bndrs, the variables to pass to the specialised + -- function, by filtering out the rule_bndrs that aren't needed + spec_binds_bndr_set = mkVarSet (bindersOfBinds picked_binds) + `minusVarSet` exprsFreeVars (rhssOfBinds rn_binds) + spec_bndrs = filterOut (`elemVarSet` spec_binds_bndr_set) rule_bndrs + + mk_spec_body fn_body = mkLets (rn_binds ++ picked_binds) $ + mkApps fn_body rule_lhs_args + -- NB: not mkCoreApps! That uses exprType on fun + -- which fails in specUnfolding, sigh + + poly_name = idName poly_id + spec_occ = mkSpecOcc (getOccName poly_name) + spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name) + id_inl = idInlinePragma poly_id + + simpl_opts = initSimpleOpts dflags + fn_unf = realIdUnfolding poly_id + spec_unf = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_lhs_args fn_unf + spec_info = vanillaIdInfo + `setInlinePragInfo` specFunInlinePrag poly_id id_inl spec_inl + `setUnfoldingInfo` spec_unf + spec_id = mkLocalVar (idDetails poly_id) spec_name ManyTy spec_ty spec_info + -- Specialised binding is toplevel, hence Many. + + -- The RULE looks like + -- RULE "USPEC" forall rule_bndrs. f rule_lhs_args = $sf spec_bndrs + -- The specialised function looks like + -- $sf spec_bndrs = mk_spec_body + -- We also use mk_spec_body to specialise the methods in f's stable unfolding + -- NB: spec_bindrs is a subset of rule_bndrs + rule = mkSpecRule dflags this_mod False rule_act (text "USPEC") + poly_id rule_bndrs rule_lhs_args + (mkVarApps (Var spec_id) spec_bndrs) + + rule_ty = exprType (mkApps (Var poly_id) rule_lhs_args) + spec_ty = mkLamTypes spec_bndrs rule_ty + spec_rhs = mkLams spec_bndrs (mk_spec_body poly_rhs) + + result = (unitOL (spec_id, spec_rhs), rule) + -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because + -- makeCorePair overwrites the unfolding, which we have + -- just created using specUnfolding + ; tracePm "dsSpec(new route)" $ + vcat [ text "poly_id" <+> ppr poly_id + , text "unfolding" <+> ppr (realIdUnfolding poly_id) + , text "orig_bndrs" <+> pprCoreBinders orig_bndrs + , text "locals" <+> ppr locals + , text "fvs" <+> ppr (exprsSomeFreeVarsList is_local rule_lhs_args) + , text "ds_call" <+> ppr ds_call + , text "binds" <+> ppr binds + , text "rule_lhs_args" <+> ppr rule_lhs_args + , text "rule_bndrs" <+> ppr rule_bndrs + , text "spec_bndrs" <+> ppr spec_bndrs + , text "rn_binds" <+> ppr rn_binds + , text "picked_binds" <+> ppr picked_binds ] + + ; dsWarnOrphanRule rule + + ; case checkUselessSpecPrag poly_id rule_lhs_args spec_bndrs + no_act_spec spec_inl rule_act of + Nothing -> return (Just result) + + Just reason -> do { diagnosticDs $ DsUselessSpecialisePragma poly_nm is_dfun reason + ; if uselessSpecialisePragmaKeepAnyway reason + then return (Just result) + else return Nothing } } } } + + where + -- See Note [Activation pragmas for SPECIALISE] + -- no_act_spec is True if the user didn't write an explicit + -- phase specification in the SPECIALISE pragma + id_inl = idInlinePragma poly_id + inl_prag_act = inlinePragmaActivation id_inl + spec_prag_act = inlinePragmaActivation spec_inl + no_act_spec = case inlinePragmaSpec spec_inl of + NoInline _ -> isNeverActive spec_prag_act + Opaque _ -> isNeverActive spec_prag_act + _ -> isAlwaysActive spec_prag_act + rule_act | no_act_spec = inl_prag_act -- Inherit + | otherwise = spec_prag_act -- Specified by user + + is_dfun = case idDetails poly_id of + DFunId {} -> True + _ -> False + +decomposeCall :: Id -> CoreExpr + -> DsM (Maybe ([CoreBind], [CoreExpr] )) +-- Decompose the call into (let in f ) +-- See (S1) in Note [Desugaring new-form SPECIALISE pragmas] +decomposeCall poly_id ds_call + = do { dflags <- getDynFlags + ; let simpl_opts = initSimpleOpts dflags + core_call = simpleOptExprNoInline simpl_opts ds_call + -- simpleOptExprNoInline: see Wrinkle (S1a)! + + ; case go [] core_call of { + Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call) + ; return Nothing } ; + Just result -> return (Just result) } } + where + go :: [CoreBind] -> CoreExpr -> Maybe ([CoreBind],[CoreExpr]) + go acc (Let bind body) = go (bind:acc) body + go acc (Cast e _) = go acc e -- Discard outer casts + -- ToDo: document this + go acc e + | (Var fun, args) <- collectArgs e + = assertPpr (fun == poly_id) (ppr fun $$ ppr poly_id) $ + Just (reverse acc, args) + | otherwise + = Nothing + + -- Is this SPECIALISE pragma useless? +checkUselessSpecPrag :: Id -> [CoreExpr] + -> [Var] -> Bool -> InlinePragma -> Activation + -> Maybe UselessSpecialisePragmaReason +checkUselessSpecPrag poly_id rule_lhs_args + spec_bndrs no_act_spec spec_inl rule_act + | isJust (isClassOpId_maybe poly_id) + -- There is no point in trying to specialise a class op + -- Moreover, classops don't (currently) have an inl_sat arity set + -- (it would be Just 0) and that in turn makes makeCorePair bleat + = Just UselessSpecialiseForClassMethodSelector + + | no_act_spec, isNeverActive rule_act + -- Function is NOINLINE, and the specialisation inherits that + -- See Note [Activation pragmas for SPECIALISE] + = Just UselessSpecialiseForNoInlineFunction + + | all is_nop_arg rule_lhs_args, not (isInlinePragma spec_inl) + -- The specialisation does nothing. + -- But don't complain if it is SPECIALISE INLINE (#4444) + = Just UselessSpecialiseNoSpecialisation + + | otherwise + = Nothing + + where + is_nop_arg (Type {}) = True + is_nop_arg (Coercion {}) = True + is_nop_arg (Cast e _) = is_nop_arg e + is_nop_arg (Tick _ e) = is_nop_arg e + is_nop_arg (Var x) = x `elem` spec_bndrs + is_nop_arg _ = False + + +getRenamings :: [Var] -> [CoreBind] -- orig_bndrs and bindings + -> [Var] -- rule_bndrs + -> [CoreBind] -- Binds some of the orig_bndrs to a rule_bndr +getRenamings orig_bndrs binds rule_bndrs + = [ NonRec b e | b <- orig_bndrs + , not (b `elem` rule_bndrs) + , Just e <- [lookupVarEnv final_renamings b] ] + where + init_renamings, final_renamings :: IdEnv CoreExpr + -- In this function, IdEnv maps a local variable to (v |> co), + -- where `v` is a rule_bndr + + init_renamings = mkVarEnv [ (v, Var v) | v <- rule_bndrs, isId v ] + final_renamings = go binds + + go :: [CoreBind] -> IdEnv CoreExpr + go [] = init_renamings + go (bind : binds) + | NonRec b rhs <- bind + , Just (v, mco) <- getCastedVar rhs + , Just e <- lookupVarEnv renamings b + = extendVarEnv renamings v (mkCastMCo e (mkSymMCo mco)) + | otherwise + = renamings + where + renamings = go binds + +pickSpecBinds :: (Var -> Bool) -> VarSet -> [CoreBind] -> [CoreBind] +pickSpecBinds _ _ [] = [] +pickSpecBinds is_local known_bndrs (bind:binds) + | all keep_me (rhssOfBind bind) + , let known_bndrs' = known_bndrs `extendVarSetList` bindersOf bind + = bind : pickSpecBinds is_local known_bndrs' binds + | otherwise + = pickSpecBinds is_local known_bndrs binds + where + keep_me rhs = isEmptyVarSet (exprSomeFreeVars bad_var rhs) + bad_var v = is_local v && not (v `elemVarSet` known_bndrs) + +getCastedVar :: CoreExpr -> Maybe (Var, MCoercionR) +getCastedVar (Var v) = Just (v, MRefl) +getCastedVar (Cast (Var v) co) = Just (v, MCo co) +getCastedVar _ = Nothing + +specFunInlinePrag :: Id -> InlinePragma + -> InlinePragma -> InlinePragma +-- See Note [Activation pragmas for SPECIALISE] +specFunInlinePrag poly_id id_inl spec_inl + | not (isDefaultInlinePragma spec_inl) = spec_inl + | isGlobalId poly_id -- See Note [Specialising imported functions] + -- in OccurAnal + , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma + | otherwise = id_inl + -- Get the INLINE pragma from SPECIALISE declaration, or, + -- failing that, from the original Id + +dsWarnOrphanRule :: CoreRule -> DsM () +dsWarnOrphanRule rule + = when (ruleIsOrphan rule) $ + diagnosticDs (DsOrphanRule rule) + +{- Note [SPECIALISE on INLINE functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to warn that using SPECIALISE for a function marked INLINE +would be a no-op; but it isn't! Especially with worker/wrapper split +we might have + {-# INLINE f #-} + f :: Ord a => Int -> a -> ... + f d x y = case x of I# x' -> $wf d x' y + +We might want to specialise 'f' so that we in turn specialise '$wf'. +We can't even /name/ '$wf' in the source code, so we can't specialise +it even if we wanted to. #10721 is a case in point. + +Note [Activation pragmas for SPECIALISE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From a user SPECIALISE pragma for f, we generate + a) A top-level binding spec_fn = rhs + b) A RULE f dOrd = spec_fn + +We need two pragma-like things: + +* spec_fn's inline pragma: inherited from f's inline pragma (ignoring + activation on SPEC), unless overridden by SPEC INLINE + +* Activation of RULE: from SPECIALISE pragma (if activation given) + otherwise from f's inline pragma + +This is not obvious (see #5237)! + +Examples Rule activation Inline prag on spec'd fn +--------------------------------------------------------------------- +SPEC [n] f :: ty [n] Always, or NOINLINE [n] + copy f's prag + +NOINLINE f +SPEC [n] f :: ty [n] NOINLINE + copy f's prag + +NOINLINE [k] f +SPEC [n] f :: ty [n] NOINLINE [k] + copy f's prag + +INLINE [k] f +SPEC [n] f :: ty [n] INLINE [k] + copy f's prag + +SPEC INLINE [n] f :: ty [n] INLINE [n] + (ignore INLINE prag on f, + same activation for rule and spec'd fn) + +NOINLINE [k] f +SPEC f :: ty [n] INLINE [k] + + +************************************************************************ +* * +\subsection{Adding inline pragmas} +* * +************************************************************************ +-} + +decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr + -> VarSet -- Free vars of the RHS + -> Either DsMessage ([Var], Id, [CoreExpr]) +-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, +-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs +-- may add some extra dictionary binders (see Note [Free dictionaries on rule LHS]) +-- +-- Returns an error message if the LHS isn't of the expected shape +-- Note [Decomposing the left-hand side of a RULE] +decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs + | Var funId <- fun2 + , Just con <- isDataConId_maybe funId + = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons] + + | otherwise = case decompose fun2 args2 of + Nothing -> -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "rhs_fvs:" <+> ppr rhs_fvs + -- , text "lhs1:" <+> ppr lhs1 + -- , text "lhs2:" <+> ppr lhs2 + -- , text "fun2:" <+> ppr fun2 + -- , text "args2:" <+> ppr args2 + -- ]) $ + Left (DsRuleLhsTooComplicated orig_lhs lhs2) + + Just (fn_id, args) + | not (null unbound) -> + -- Check for things unbound on LHS + -- See Note [Unused spec binders] + -- pprTrace "decomposeRuleLhs 1" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "lhs_fvs:" <+> ppr lhs_fvs + -- , text "rhs_fvs:" <+> ppr rhs_fvs + -- , text "unbound:" <+> ppr unbound + -- ]) $ + Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2) + | otherwise -> + -- pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "lhs1:" <+> ppr lhs1 + -- , text "trimmed_bndrs:" <+> ppr trimmed_bndrs + -- , text "extra_dicts:" <+> ppr extra_dicts + -- , text "fn_id:" <+> ppr fn_id + -- , text "args:" <+> ppr args + -- , text "args fvs:" <+> ppr (exprsFreeVarsList args) + -- ]) $ + Right (trimmed_bndrs ++ extra_dicts, fn_id, args) + + where -- See Note [Variables unbound on the LHS] + lhs_fvs = exprsFreeVars args + all_fvs = lhs_fvs `unionVarSet` rhs_fvs + trimmed_bndrs = filter (`elemVarSet` all_fvs) orig_bndrs + unbound = filterOut (`elemVarSet` lhs_fvs) trimmed_bndrs + -- Needed on RHS but not bound on LHS + + -- extra_dicts: see Note [Free dictionaries on rule LHS] +-- ToDo: extra_dicts is needed. E.g. the SPECIALISE rules for `ap` in GHC.Base + extra_dicts + = [ mkLocalIdOrCoVar (localiseName (idName d)) ManyTy (idType d) + | d <- exprsSomeFreeVarsList is_extra args ] + + is_extra v + = isSimplePredTy (idType v) + -- isSimplePredTy: includes coercions and dictionaries + -- But NOT dictionary functions; and in particular not + -- superclass-selector fuctions + + && not (v `elemVarSet` orig_bndr_set) + && not (v == fn_id) + -- fn_id: do not quantify over the function itself, which may + -- itself be a dictionary (in pathological cases, #10251) + + where + simpl_opts = initSimpleOpts dflags + orig_bndr_set = mkVarSet orig_bndrs + + lhs1 = drop_dicts orig_lhs + lhs2 = simpleOptExpr simpl_opts lhs1 -- See Note [Simplify rule LHS] + (fun2,args2) = collectArgs lhs2 + + decompose (Var fn_id) args + | not (fn_id `elemVarSet` orig_bndr_set) + = Just (fn_id, args) + + decompose _ _ = Nothing + + drop_dicts :: CoreExpr -> CoreExpr + drop_dicts e + = wrap_lets needed bnds body + where + needed = orig_bndr_set `minusVarSet` exprFreeVars body + (bnds, body) = split_lets (occurAnalyseExpr e) + -- The occurAnalyseExpr drops dead bindings which is + -- crucial to ensure that every binding is used later; + -- which in turn makes wrap_lets work right + + split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) + split_lets (Let (NonRec d r) body) + | isPredTy (idType d) + -- isPredTy: catches dictionaries, yes, but also catches + -- dictionary /functions/ arising from solving a + -- quantified contraint (see #24370) + = ((d,r):bs, body') + where (bs, body') = split_lets body + + -- handle "unlifted lets" too, needed for "map/coerce" + split_lets (Case r d _ [Alt DEFAULT _ body]) + | isCoVar d + = ((d,r):bs, body') + where (bs, body') = split_lets body + + split_lets e = ([], e) + + wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr + wrap_lets _ [] body = body + wrap_lets needed ((d, r) : bs) body + | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body) + | otherwise = wrap_lets needed bs body + where + rhs_fvs = exprFreeVars r + needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d + +{- +Note [Variables unbound on the LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously want to complain about + RULE forall x. f True = not x +because the forall'd variable `x` is not bound on the LHS. + +It can be a bit delicate when dictionaries are involved. +Consider #22471 + {-# RULES "foo" forall (f :: forall a. [a] -> Int). + foo (\xs. 1 + f xs) = 2 + foo f #-} + +We get two dicts on the LHS, one from `1` and one from `+`. +For reasons described in Note [The SimplifyRule Plan] in +GHC.Tc.Gen.Sig, we quantify separately over those dictionaries: + forall f (d1::Num Int) (d2 :: Num Int). + foo (\xs. (+) d1 (fromInteger d2 1) xs) = ... + +Now the desugarer shortcircuits (fromInteger d2 1) to (I# 1); so d2 is +not mentioned at all (on LHS or RHS)! We don't want to complain about +and unbound d2. Hence the trimmed_bndrs. + +Note [Decomposing the left-hand side of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several things going on here. +* drop_dicts: see Note [Drop dictionary bindings on rule LHS] +* simpleOptExpr: see Note [Simplify rule LHS] +* extra_dict_bndrs: see Note [Free dictionaries on rule LHS] + +Note [Free dictionaries on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, +which is presumably in scope at the function definition site, we can quantify +over it too. *Any* dict with that type will do. + +So for example when you have + f :: Eq a => a -> a + f = + ... SPECIALISE f :: Int -> Int ... + +Then we get the SpecPrag + SpecPrag (f Int dInt) + +And from that we want the rule + + RULE forall dInt. f Int dInt = f_spec + f_spec = let f = in f Int dInt + +But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External +Name, and you can't bind them in a lambda or forall without getting things +confused. Likewise it might have a stable unfolding or something, which would be +utterly bogus. So we really make a fresh Id, with the same unique and type +as the old one, but with an Internal name and no IdInfo. + +Note [Drop dictionary bindings on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +drop_dicts drops dictionary bindings on the LHS where possible. + E.g. let d:Eq [Int] = $fEqList $fEqInt in f d + --> f d + Reasoning here is that there is only one d:Eq [Int], and so we can + quantify over it. That makes 'd' free in the LHS, but that is later + picked up by extra_dict_bndrs (see Note [Unused spec binders]). + + NB 1: We can only drop the binding if the RHS of the binding doesn't + mention one of the orig_bndrs, which we assume occur on RHS of + the rule. Example + f :: (Eq a) => b -> a -> a + {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-} + Here we want to end up with + RULE forall d:Eq a. f ($dfEqList d) = f_spec d + Of course, the ($dfEqlist d) in the pattern makes it less likely + to match, but there is no other way to get d:Eq a + + NB 2: We do drop_dicts *before* simplOptExpr, so that we expect all + the evidence bindings to be wrapped around the outside of the + LHS. (After simplOptExpr they'll usually have been inlined.) + dsHsWrapper does dependency analysis, so that civilised ones + will be simple NonRec bindings. We don't handle recursive + dictionaries! + + NB3: In the common case of a non-overloaded, but perhaps-polymorphic + specialisation, we don't need to bind *any* dictionaries for use + in the RHS. For example (#8331) + {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-} + useAbstractMonad :: MonadAbstractIOST m => m Int + Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code + but the RHS uses no dictionaries, so we want to end up with + RULE forall s (d :: MonadAbstractIOST (ReaderT s)). + useAbstractMonad (ReaderT s) d = $suseAbstractMonad s + + #8848 is a good example of where there are some interesting + dictionary bindings to discard. + +The drop_dicts algorithm is based on these observations: + + * Given (let d = rhs in e) where d is a DictId, + matching 'e' will bind e's free variables. + + * So we want to keep the binding if one of the needed variables (for + which we need a binding) is in fv(rhs) but not already in fv(e). + + * The "needed variables" are simply the orig_bndrs. Consider + f :: (Eq a, Show b) => a -> b -> String + ... SPECIALISE f :: (Show b) => Int -> b -> String ... + Then orig_bndrs includes the *quantified* dictionaries of the type + namely (dsb::Show b), but not the one for Eq Int + +So we work inside out, applying the above criterion at each step. + + +Note [Simplify rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~ +simplOptExpr occurrence-analyses and simplifies the LHS: + + (a) Inline any remaining dictionary bindings (which hopefully + occur just once) + + (b) Substitute trivial lets, so that they don't get in the way. + Note that we substitute the function too; we might + have this as a LHS: let f71 = M.f Int in f71 + + (c) Do eta reduction. To see why, consider the fold/build rule, + which without simplification looked like: + fold k z (build (/\a. g a)) ==> ... + This doesn't match unless you do eta reduction on the build argument. + Similarly for a LHS like + augment g (build h) + we do not want to get + augment (\a. g a) (build h) + otherwise we don't match when given an argument like + augment (\a. h a a) (build h) + +Note [Unused spec binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: a -> a + ... SPECIALISE f :: Eq a => a -> a ... +It's true that this *is* a more specialised type, but the rule +we get is something like this: + f_spec d = f + RULE: f = f_spec d +Note that the rule is bogus, because it mentions a 'd' that is +not bound on the LHS! But it's a silly specialisation anyway, because +the constraint is unused. We could bind 'd' to (error "unused") +but it seems better to reject the program because it's almost certainly +a mistake. That's what the isDeadBinder call detects. + +Note [No RULES on datacons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Previously, `RULES` like + + "JustNothing" forall x . Just x = Nothing + +were allowed. Simon Peyton Jones says this seems to have been a +mistake, that such rules have never been supported intentionally, +and that he doesn't know if they can break in horrible ways. +Furthermore, Ben Gamari and Reid Barton are considering trying to +detect the presence of "static data" that the simplifier doesn't +need to traverse at all. Such rules do not play well with that. +So for now, we ban them altogether as requested by #13290. See also #7398. + + +************************************************************************ +* * + Desugaring evidence +* * +************************************************************************ + +Note [Desugaring WpFun] +~~~~~~~~~~~~~~~~~~~~~~~ +See comments on WpFun in GHC.Tc.Types.Evidence for what WpFun means. +Roughly: + + (WpFun w_arg w_res)[ e ] = \x. w_res[ e w_arg[x] ] + +This eta-expansion risk duplicating work, if `e` is not in HNF. +At one stage I thought we could avoid that by desugaring to + let f = e in \x. w_res[ f w_arg[x] ] +But that /fundamentally/ doesn't work, because `w_res` may bind +evidence that is used in `e`. + +This question arose when thinking about deep subsumption; see +https://github.com/ghc-proposals/ghc-proposals/pull/287#issuecomment-1125419649). +-} + +dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a +dsHsWrappers (wp:wps) k = dsHsWrapper wp $ \wrap -> dsHsWrappers wps $ \wraps -> k (wrap:wraps) +dsHsWrappers [] k = k [] + +dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a +dsHsWrapper hs_wrap thing_inside + = ds_hs_wrapper hs_wrap $ \ core_wrap -> + addTyCs FromSource (hsWrapDictBinders hs_wrap) $ + -- addTyCs: Add type evidence to the refinement type + -- predicate of the coverage checker + -- See Note [Long-distance information] in "GHC.HsToCore.Pmc" + -- FromSource might not be accurate (we don't have any + -- origin annotations for things in this module), but at + -- worst we do superfluous calls to the pattern match + -- oracle. + thing_inside core_wrap + +ds_hs_wrapper :: HsWrapper + -> ((CoreExpr -> CoreExpr) -> DsM a) + -> DsM a +ds_hs_wrapper wrap = go wrap + where + go WpHole k = k $ \e -> e + go (WpTyApp ty) k = k $ \e -> App e (Type ty) + go (WpEvLam ev) k = k $ Lam ev + go (WpTyLam tv) k = k $ Lam tv + go (WpCast co) k = assert (coercionRole co == Representational) $ + k $ \e -> mkCastDs e co + go (WpEvApp tm) k = do { core_tm <- dsEvTerm tm + ; k $ \e -> e `App` core_tm } + go (WpLet ev_binds) k = dsTcEvBinds ev_binds $ \bs -> + k (mkCoreLets bs) + go (WpCompose c1 c2) k = go c1 $ \w1 -> + go c2 $ \w2 -> + k (w1 . w2) + go (WpFun c1 c2 st) k = -- See Note [Desugaring WpFun] + do { x <- newSysLocalDs st + ; go c1 $ \w1 -> + go c2 $ \w2 -> + let app f a = mkCoreApp (text "dsHsWrapper") f a + arg = w1 (Var x) + in k (\e -> (Lam x (w2 (app e arg)))) } + +-------------------------------------- +dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a +dsTcEvBinds_s [] k = k [] +dsTcEvBinds_s (b:rest) k = assert (null rest) $ -- Zonker ensures null + dsTcEvBinds b k + +dsTcEvBinds :: TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a +dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this +dsTcEvBinds (EvBinds bs) = dsEvBinds bs + +-- * Desugars the ev_binds, sorts them into dependency order, and +-- passes the resulting [CoreBind] to thing_inside +-- * Extends the DsM (dsl_unspecable field) with specialisability information +-- for each binder in ev_binds, before invoking thing_inside +dsEvBinds :: Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a +dsEvBinds ev_binds thing_inside + = do { ds_binds <- mapBagM dsEvBind ev_binds + ; let comps = sort_ev_binds ds_binds + ; go comps thing_inside } + where + go ::[SCC (Node EvVar (CanonicalEvidence, CoreExpr))] -> ([CoreBind] -> DsM a) -> DsM a + go (comp:comps) thing_inside + = do { unspecables <- getUnspecables + ; let (core_bind, new_unspecables) = ds_component unspecables comp + ; addUnspecables new_unspecables $ go comps $ \ core_binds -> + thing_inside (core_bind:core_binds) } + go [] thing_inside = thing_inside [] + + ds_component mb_unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables) + where + ((v, rhs), (this_canonical, deps)) = unpack_node node + new_unspecables = case mb_unspecables of + Nothing -> [] + Just unspecs | transitively_unspecable -> [v] + | otherwise -> [] + where + transitively_unspecable = is_unspecable this_canonical + || any (`elemVarSet` unspecs) deps + + ds_component mb_unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables) + where + (pairs, direct_canonicity) = unzip $ map unpack_node nodes + + new_unspecables = case mb_unspecables of + Nothing -> [] + Just unspecs | transitively_unspecable -> map fst pairs + | otherwise -> [] + where + transitively_unspecable + = or [ is_unspecable this_canonical + || any (`elemVarSet` unspecs) deps + | (this_canonical, deps) <- direct_canonicity ] + -- Bindings from a given SCC are transitively specialisable if + -- all are specialisable and all their remote dependencies are + -- also specialisable; see Note [Desugaring non-canonical evidence] + + unpack_node DigraphNode { node_key = v, node_payload = (canonical, rhs), node_dependencies = deps } + = ((v, rhs), (canonical, deps)) + + is_unspecable :: CanonicalEvidence -> Bool + is_unspecable EvNonCanonical = True + is_unspecable EvCanonical = False + +sort_ev_binds :: Bag (Id, CanonicalEvidence, CoreExpr) -> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))] +-- We do SCC analysis of the evidence bindings, /after/ desugaring +-- them. This is convenient: it means we can use the GHC.Core +-- free-variable functions rather than having to do accurate free vars +-- for EvTerm. +sort_ev_binds ds_binds = stronglyConnCompFromEdgedVerticesUniqR edges + where + edges :: [ Node EvVar (CanonicalEvidence, CoreExpr) ] + edges = foldr ((:) . mk_node) [] ds_binds + + mk_node :: (Id, CanonicalEvidence, CoreExpr) -> Node EvVar (CanonicalEvidence, CoreExpr) + mk_node (var, canonical, rhs) + = DigraphNode { node_payload = (canonical, rhs) + , node_key = var + , node_dependencies = nonDetEltsUniqSet $ + exprFreeVars rhs `unionVarSet` + coVarsOfType (varType var) } + -- It's OK to use nonDetEltsUniqSet here as graphFromEdgedVerticesUniq + -- is still deterministic even if the edges are in nondeterministic order + -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. + +dsEvBind :: EvBind -> DsM (Id, CanonicalEvidence, CoreExpr) +dsEvBind (EvBind { eb_lhs = v, eb_rhs = r, eb_info = info }) = do + e <- dsEvTerm r + let canonical = case info of + EvBindGiven{} -> EvCanonical + EvBindWanted{ ebi_canonical = canonical } -> canonical + return (v, canonical, e) + + +{-********************************************************************** +* * + Desugaring EvTerms +* * +**********************************************************************-} + +dsEvTerm :: EvTerm -> DsM CoreExpr +dsEvTerm (EvExpr e) = return e +dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev +dsEvTerm (EvFun { et_tvs = tvs, et_given = given + , et_binds = ev_binds, et_body = wanted_id }) + = do { dsTcEvBinds ev_binds $ \ds_ev_binds -> + return $ (mkLams (tvs ++ given) $ + mkCoreLets ds_ev_binds $ + Var wanted_id) } + + +{-********************************************************************** +* * + Desugaring Typeable dictionaries +* * +**********************************************************************-} + +dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr +-- Return a CoreExpr :: Typeable ty +-- This code is tightly coupled to the representation +-- of TypeRep, in base library Data.Typeable.Internal +dsEvTypeable ty ev + = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable + ; let kind = typeKind ty + typeable_data_con = tyConSingleDataCon tyCl -- "Data constructor" + -- for Typeable + + ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a + + -- Package up the method as `Typeable` dictionary + ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] } + +type TypeRepExpr = CoreExpr + +-- | Returns a @CoreExpr :: TypeRep ty@ +ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr +ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) + = do { mkTrCon <- dsLookupGlobalId mkTrConName + -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a + ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName + ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName + -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep + + ; tc_rep <- tyConRep tc -- :: TyCon + ; let ks = tyConAppArgs ty + -- Construct a SomeTypeRep + toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr + toSomeTypeRep t ev = do + rep <- getRep ev t + return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep] + ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev -- :: TypeRep t + ; let -- :: [SomeTypeRep] + kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps + + -- Note that we use the kind of the type, not the TyCon from which it + -- is constructed since the latter may be kind polymorphic whereas the + -- former we know is not (we checked in the solver). + ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) + , Type ty + , tc_rep + , kind_args ] + -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr + ; return expr + } + +ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) + | Just (t1,t2) <- splitAppTy_maybe ty + = do { e1 <- getRep ev1 t1 + ; e2 <- getRep ev2 t2 + ; mkTrAppChecked <- dsLookupGlobalId mkTrAppCheckedName + -- mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1). + -- TypeRep a -> TypeRep b -> TypeRep (a b) + ; let (_, k1, k2) = splitFunTy (typeKind t1) -- drop the multiplicity, + -- since it's a kind + ; let expr = mkApps (mkTyApps (Var mkTrAppChecked) [ k1, k2, t1, t2 ]) + [ e1, e2 ] + -- ; pprRuntimeTrace "Trace mkTrAppChecked" (ppr expr) expr + ; return expr + } + +ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2) + | Just (_af,m,t1,t2) <- splitFunTy_maybe ty + = do { e1 <- getRep ev1 t1 + ; e2 <- getRep ev2 t2 + ; em <- getRep evm m + ; mkTrFun <- dsLookupGlobalId mkTrFunName + -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2). + -- TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a % m -> b) + ; let r1 = getRuntimeRep t1 + r2 = getRuntimeRep t2 + ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2]) + [ em, e1, e2 ] + } + +ds_ev_typeable ty (EvTypeableTyLit ev) + = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Instance.Class + do { fun <- dsLookupGlobalId tr_fun + ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol + ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) } + where + ty_kind = typeKind ty + + -- tr_fun is the Name of + -- typeNatTypeRep :: KnownNat a => TypeRep a + -- of typeSymbolTypeRep :: KnownSymbol a => TypeRep a + tr_fun | ty_kind `eqType` naturalTy = typeNatTypeRepName + | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName + | ty_kind `eqType` charTy = typeCharTypeRepName + | otherwise = panic "dsEvTypeable: unknown type lit kind" + +ds_ev_typeable ty ev + = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev) + +getRep :: EvTerm -- ^ EvTerm for @Typeable ty@ + -> Type -- ^ The type @ty@ + -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@ + -- namely @typeRep# dict@ +-- Remember that +-- typeRep# :: forall k (a::k). Typeable k a -> TypeRep a +getRep ev ty + = do { typeable_expr <- dsEvTerm ev + ; typeRepId <- dsLookupGlobalId typeRepIdName + ; let ty_args = [typeKind ty, ty] + ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) } + +tyConRep :: TyCon -> DsM CoreExpr +-- Returns CoreExpr :: TyCon +tyConRep tc + | Just tc_rep_nm <- tyConRepName_maybe tc + = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm + ; return (Var tc_rep_id) } + | otherwise + = pprPanic "tyConRep" (ppr tc) diff --git a/GHC/HsToCore/Binds.hs-boot b/GHC/HsToCore/Binds.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Binds.hs-boot @@ -0,0 +1,6 @@ +module GHC.HsToCore.Binds where +import GHC.HsToCore.Monad ( DsM ) +import GHC.Core ( CoreExpr ) +import GHC.Tc.Types.Evidence (HsWrapper) + +dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a diff --git a/GHC/HsToCore/Breakpoints.hs b/GHC/HsToCore/Breakpoints.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Breakpoints.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Information attached to Breakpoints generated from Ticks +-- +-- The breakpoint information stored in 'ModBreaks' is generated during +-- desugaring from the ticks annotating the source expressions. +-- +-- This information can be queried per-breakpoint using the 'BreakpointId' +-- datatype, which indexes tick-level breakpoint information. +-- +-- 'ModBreaks' and 'BreakpointId's are not to be confused with +-- 'InternalModBreaks' and 'InternalBreakId's. The latter are constructed +-- during bytecode generation and can be found in 'GHC.ByteCode.Breakpoints'. +-- +-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers] +module GHC.HsToCore.Breakpoints + ( -- * ModBreaks + mkModBreaks, ModBreaks(..) + + -- ** Re-exports BreakpointId + , BreakpointId(..), BreakTickIndex + ) where + +import GHC.Prelude +import Data.Array + +import GHC.HsToCore.Ticks (Tick (..)) +import GHC.Data.SizedSeq +import GHC.Types.SrcLoc (SrcSpan) +import GHC.Types.Name (OccName) +import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..)) +import GHC.Unit.Module (Module) +import GHC.Utils.Outputable +import Data.List (intersperse) + +-------------------------------------------------------------------------------- +-- ModBreaks +-------------------------------------------------------------------------------- + +-- | All the information about the source-relevant breakpoints for a module +-- +-- This information is constructed once during desugaring (with `mkModBreaks`) +-- from breakpoint ticks and fixed/unchanged from there on forward. It could be +-- exported as an abstract datatype because it should never be updated after +-- construction, only queried. +-- +-- The arrays can be indexed using the int in the corresponding 'BreakpointId' +-- (i.e. the 'BreakpointId' whose 'Module' matches the 'Module' corresponding +-- to these 'ModBreaks') with the accessors 'modBreaks_locs', 'modBreaks_vars', +-- and 'modBreaks_decls'. +data ModBreaks + = ModBreaks + { modBreaks_locs :: !(Array BreakTickIndex SrcSpan) + -- ^ An array giving the source span of each breakpoint. + , modBreaks_vars :: !(Array BreakTickIndex [OccName]) + -- ^ An array giving the names of the free variables at each breakpoint. + , modBreaks_decls :: !(Array BreakTickIndex [String]) + -- ^ An array giving the names of the declarations enclosing each breakpoint. + -- See Note [Field modBreaks_decls] + , modBreaks_ccs :: !(Array BreakTickIndex (String, String)) + -- ^ Array pointing to cost centre info for each breakpoint; + -- actual 'CostCentre' allocation is done at link-time. + , modBreaks_module :: !Module + -- ^ The module to which this ModBreaks is associated. + -- We also cache this here for internal sanity checks. + } + +-- | Initialize memory for breakpoint data that is shared between the bytecode +-- generator and the interpreter. +-- +-- Since GHCi and the RTS need to interact with breakpoint data and the bytecode +-- generator needs to encode this information for each expression, the data is +-- allocated remotely in GHCi's address space and passed to the codegen as +-- foreign pointers. +mkModBreaks :: Bool {-^ Whether the interpreter is profiled and thus if we should include store a CCS array -} + -> Module -> SizedSeq Tick -> ModBreaks +mkModBreaks interpreterProfiled modl extendedMixEntries + = let count = fromIntegral $ sizeSS extendedMixEntries + entries = ssElts extendedMixEntries + locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ] + varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ] + declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ] + ccs + | interpreterProfiled = + listArray + (0, count - 1) + [ ( concat $ intersperse "." $ tick_path t, + renderWithContext defaultSDocContext $ ppr $ tick_loc t + ) + | t <- entries + ] + | otherwise = listArray (0, -1) [] + in ModBreaks + { modBreaks_locs = locsTicks + , modBreaks_vars = varsTicks + , modBreaks_decls = declsTicks + , modBreaks_ccs = ccs + , modBreaks_module = modl + } + +{- +Note [Field modBreaks_decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A value of eg ["foo", "bar", "baz"] in a `modBreaks_decls` field means: +The breakpoint is in the function called "baz" that is declared in a `let` +or `where` clause of a declaration called "bar", which itself is declared +in a `let` or `where` clause of the top-level function called "foo". +-} diff --git a/GHC/HsToCore/Coverage.hs b/GHC/HsToCore/Coverage.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Coverage.hs @@ -0,0 +1,139 @@ +{- +(c) Galois, 2006 +(c) University of Glasgow, 2007 +-} + +module GHC.HsToCore.Coverage + ( writeMixEntries + , hpcInitCode + ) where + +import GHC.Prelude as Prelude + +import GHC.Unit + +import GHC.HsToCore.Ticks + +import GHC.Platform + +import GHC.Data.FastString +import GHC.Data.SizedSeq + +import GHC.Cmm.CLabel + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Types.ForeignStubs +import GHC.Types.HpcInfo +import GHC.Types.SrcLoc + +import Control.Monad +import Data.Time +import System.Directory + +import Trace.Hpc.Mix +import Trace.Hpc.Util + +import qualified Data.ByteString as BS + +writeMixEntries + :: FilePath -> Module -> SizedSeq Tick -> FilePath -> IO Int +writeMixEntries hpc_dir mod extendedMixEntries filename + = do + let count = fromIntegral $ sizeSS extendedMixEntries + entries = ssElts extendedMixEntries + + mod_name = moduleNameString (moduleName mod) + + hpc_mod_dir + | moduleUnit mod == mainUnit = hpc_dir + | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod) + + tabStop = 8 -- counts as a normal char in GHC's + -- location ranges. + + createDirectoryIfMissing True hpc_mod_dir + modTime <- getModificationUTCTime filename + let entries' = [ (hpcPos, tick_label t) + | t <- entries, hpcPos <- [mkHpcPos $ tick_loc t] ] + when (entries' `lengthIsNot` count) $ + panic "the number of .mix entries are inconsistent" + let hashNo = mixHash filename modTime tabStop entries' + mixCreate hpc_mod_dir mod_name + $ Mix filename modTime (toHash hashNo) tabStop entries' + return hashNo + +mkHpcPos :: SrcSpan -> HpcPos +mkHpcPos pos@(RealSrcSpan s _) + | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, + srcSpanStartCol s, + srcSpanEndLine s, + srcSpanEndCol s - 1) + -- the end column of a SrcSpan is one + -- greater than the last column of the + -- span (see SrcLoc), whereas HPC + -- expects to the column range to be + -- inclusive, hence we subtract one above. +mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" + +-- For the hash value, we hash everything: the file name, +-- the timestamp of the original source file, the tab stop, +-- and the mix entries. We cheat, and hash the show'd string. +-- This hash only has to be hashed at Mix creation time, +-- and is for sanity checking only. +mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int +mixHash file tm tabstop entries = fromIntegral $ hashString + (show $ Mix file tm 0 tabstop entries) + +{- +************************************************************************ +* * +* initialisation +* * +************************************************************************ +-} + +{- | Create HPC initialization C code for a module + +Each module compiled with -fhpc declares an initialisation function of +the form `hpc_init_()`, which is emitted into the _stub.c file +and annotated with __attribute__((constructor)) so that it gets +executed at startup time. + +The function's purpose is to call hs_hpc_module to register this +module with the RTS, and it looks something like this: + +> static void hpc_init_Main(void) __attribute__((constructor)); +> static void hpc_init_Main(void) +> { +> extern StgWord64 _hpc_tickboxes_Main_hpc[]; +> hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc); +> } +-} +hpcInitCode :: Platform -> Module -> HpcInfo -> CStub +hpcInitCode _ _ (NoHpcInfo {}) = mempty +hpcInitCode platform this_mod (HpcInfo tickCount hashNo) + = initializerCStub platform fn_name decls body + where + fn_name = mkInitializerStubLabel this_mod (fsLit "hpc") + decls = text "StgWord64 " <> tickboxes <> brackets (int tickCount) <> semi + body = text "hs_hpc_module" <> + parens (hcat (punctuate comma [ + doubleQuotes full_name_str, + int tickCount, -- really StgWord32 + int hashNo, -- really StgWord32 + tickboxes + ])) <> semi + + tickboxes = pprCLabel platform (mkHpcTicksLabel $ this_mod) + + module_name = hcat (map (text.charToC) $ BS.unpack $ + bytesFS (moduleNameFS (moduleName this_mod))) + package_name = hcat (map (text.charToC) $ BS.unpack $ + bytesFS (unitFS (moduleUnit this_mod))) + full_name_str + | moduleUnit this_mod == mainUnit + = module_name + | otherwise + = package_name <> char '/' <> module_name diff --git a/GHC/HsToCore/Docs.hs b/GHC/HsToCore/Docs.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Docs.hs @@ -0,0 +1,652 @@ +-- | Extract docs from the renamer output so they can be serialized. +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} + +module GHC.HsToCore.Docs where + +import GHC.Prelude +import GHC.Hs.Binds +import GHC.Hs.Doc +import GHC.Hs.Decls +import Language.Haskell.Syntax.Extension +import GHC.Hs.Extension +import GHC.Hs.Type +import GHC.Hs.Utils +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.SrcLoc +import GHC.Tc.Types +import GHC.Parser.Annotation + +import Control.Applicative +import Control.Monad.IO.Class +import Data.Bifunctor (first) +import Data.Foldable (toList) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.Map.Strict (Map) +import qualified Data.Map as M +import qualified Data.Set as Set +import Data.Maybe +import qualified Data.Semigroup as S +import GHC.IORef (readIORef) +import GHC.Unit.Types +import GHC.Hs +import GHC.Types.Avail +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty ((:|))) +import GHC.Unit.Module.Imported +import GHC.Driver.DynFlags +import GHC.Types.TypeEnv +import GHC.Types.Id +import GHC.Types.Unique.Map +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- | Extract docs from renamer output. +-- This is monadic since we need to be able to read documentation added from +-- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'. +extractDocs :: MonadIO m + => DynFlags -> TcGblEnv + -> m (Maybe Docs) + -- ^ + -- 1. Module header + -- 2. Docs on top level declarations + -- 3. Docs on arguments +extractDocs dflags + TcGblEnv { tcg_semantic_mod = semantic_mdl + , tcg_mod = mdl + , tcg_rn_decls = Just rn_decls + , tcg_rn_exports = mb_rn_exports + , tcg_exports = all_exports + , tcg_imports = import_avails + , tcg_insts = insts + , tcg_fam_insts = fam_insts + , tcg_hdr_info = mb_hdr_info + , tcg_th_docs = th_docs_var + , tcg_type_env = ty_env + } = do + th_docs <- liftIO $ readIORef th_docs_var + let doc_hdr = unLoc <$> fst mb_hdr_info + 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 + , docs_exports = exports_docs + -- Left biased union (see #21220) + , docs_decls = plusUniqMap_C (\a _ -> a) + ((:[]) <$> th_decl_docs `plusUniqMap` th_inst_docs) + -- These will not clash so safe to use plusUniqMap + doc_map + , docs_args = th_arg_docs `unionArgMaps` arg_map + , docs_structure = doc_structure + , docs_named_chunks = named_chunks + , docs_haddock_opts = haddockOptions dflags + , docs_language = language_ + , docs_extensions = exts + } + pure (Just mod_docs) + where + exts = extensionFlags dflags + language_ = language dflags + + -- We need to lookup the Names for default methods, so we + -- can put them in the correct map + -- See Note [default method Name] in GHC.Iface.Recomp + def_meths_env = mkOccEnv [(occ, nm) + | id <- typeEnvIds ty_env + , let nm = idName id + occ = nameOccName nm + , isDefaultMethodOcc occ + ] + + exports_docs = maybe emptyUniqMap mkExportsDocs mb_rn_exports + (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 + +mkExportsDocs :: [(LIE GhcRn, Avails)] -> UniqMap Name (HsDoc GhcRn) +mkExportsDocs = foldMap f + where + f :: (LIE GhcRn, Avails) -> UniqMap Name (HsDoc GhcRn) + f (L _ ie, avails) + | Just (L _ doc) <- ieExportDoc ie = + listToUniqMap [ (availName nm, doc) | nm <- avails ] + f _ = emptyUniqMap + + ieExportDoc :: IE GhcRn -> Maybe (ExportDoc GhcRn) + ieExportDoc (IEVar _ _ doc) = doc + ieExportDoc (IEThingAbs _ _ doc) = doc + ieExportDoc (IEThingAll _ _ doc) = doc + ieExportDoc (IEThingWith _ _ _ _ doc) = doc + ieExportDoc (IEModuleContents _ _) = Nothing + ieExportDoc (IEGroup _ _ _) = Nothing + ieExportDoc (IEDoc _ _) = Nothing + ieExportDoc (IEDocNamed _ _) = 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? +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 + (IEThingWith{}, avails) -> + DsiExports $ + {- For explicit export lists, use the explicit order. It is deterministic by construction -} + DefinitelyDeterministicAvails (nubAvails avails) + (_, avails) -> DsiExports (sortAvails (nubAvails avails)) + + moduleExport :: ModuleName -- Alias + -> Avails + -> DocStructureItem + moduleExport alias avails = + DsiModExport (nubSortNE orig_names) (sortAvails (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 (S.<>) $ + (this_mdl_name, this_mdl_name :| []) + : (flip concatMap (M.toList imported) $ \(mdl, imvs) -> + [(imv_name imv, moduleName mdl :| []) | imv <- imvs]) + where + this_mdl_name = moduleName mdl + + imported = M.map 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 (sortAvails [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 (sortAvails [])) + + -- This causes the associated data family to be incorrectly documented + -- separately from its class: + -- Nothing -> noLoc (DsiExports [avail]) + + -- This panics on the associated data family: + -- Nothing -> panicDoc "mkDocStructureFromDecls: No loc found for" + -- (ppr avail) + + docs = mapMaybe structuralDoc (hs_docs decls) + + structuralDoc :: LDocDecl GhcRn + -> Maybe (Located DocStructureItem) + structuralDoc = \case + L loc (DocCommentNamed _name doc) -> + -- TODO: Is this correct? + -- NB: There is no export list where we could reference the named chunk. + Just (L (locA loc) (DsiDocChunk (unLoc doc))) + + L loc (DocGroup level doc) -> + Just (L (locA loc) (DsiSectionHeading level (unLoc doc))) + + _ -> Nothing + + name_locs = M.fromList (concatMap ldeclNames (ungroup decls)) + ldeclNames (L loc d) = zip (getMainDeclBinder env d) (repeat (locA loc)) + +-- | Extract named documentation chunks from the renamed declarations. +-- +-- If there is no explicit export list, we simply return an empty map +-- since there would be no way to link to a named chunk. +getNamedChunks :: Bool -- ^ Do we have an explicit export list? + -> HsGroup (GhcPass pass) + -> Map String (HsDoc (GhcPass pass)) +getNamedChunks True decls = + M.fromList $ flip mapMaybe (unLoc <$> hs_docs decls) $ \case + DocCommentNamed name doc -> Just (name, unLoc doc) + _ -> Nothing +getNamedChunks False _ = M.empty + +-- | Create decl and arg doc-maps by looping through the declarations. +-- For each declaration, find its names, its subordinates, and its doc strings. +mkMaps :: OccEnv Name + -> [Name] + -> [(LHsDecl GhcRn, [HsDoc GhcRn])] + -> (UniqMap Name [HsDoc GhcRn], UniqMap Name (IntMap (HsDoc GhcRn))) +mkMaps env instances decls = + ( listsToMapWith (++) (map (nubByName fst) decls') + , listsToMapWith (S.<>) (filterMapping (not . IM.null) args) + ) + where + (decls', args) = unzip (map mappings decls) + + listsToMapWith f = listToUniqMap_C f . concat + + filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] + filterMapping p = map (filter (p . snd)) + + mappings :: (LHsDecl GhcRn, [HsDoc GhcRn]) + -> ( [(Name, [HsDoc GhcRn])] + , [(Name, IntMap (HsDoc GhcRn))] + ) + mappings (L (EpAnn (EpaSpan (RealSrcSpan l _)) _ _) decl, doc) = + (dm, am) + where + args = declTypeDocs decl + + subs :: [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))] + subs = subordinates env instanceMap decl + + (subNs, subDocs, subArgs) = + unzip3 subs + + ns = names l decl + dm = [(n, d) | (n, d) <- zip ns (repeat doc) ++ zip subNs subDocs, not $ all (isEmptyDocString . hsDocString) d] + am = [(n, args) | n <- ns] ++ zip subNs subArgs + mappings (L (EpAnn _ _ _) _, _) = ([], []) + + instanceMap :: Map RealSrcSpan Name + instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] + + names :: RealSrcSpan -> HsDecl GhcRn -> [Name] + names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap + names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1]. + names _ decl = getMainDeclBinder env decl + +{- +Note [1] +~~~~~~~~ +We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried +inside them. That should work for normal user-written instances (from +looking at GHC sources). We can assume that commented instances are +user-written. This lets us relate Names (from ClsInsts) to comments +(associated with InstDecls and DerivDecls). +-} + +getMainDeclBinder + :: OccEnv Name -- ^ Default method environment for this module. See Note [default method Name] in GHC.Iface.Recomp + -> HsDecl GhcRn -> [Name] +getMainDeclBinder _ (TyClD _ d) = [tcdName d] +getMainDeclBinder _ (ValD _ d) = + case collectHsBindBinders CollNoDictBinders d of + [] -> [] + (name:_) -> [name] +getMainDeclBinder env (SigD _ d) = sigNameNoLoc env d +getMainDeclBinder _ (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinder _ (ForD _ (ForeignExport _ _ _ _)) = [] +getMainDeclBinder _ _ = [] + + +-- | The "OccEnv Name" is the default method environment for this module +-- Ultimately, the a special "defaultMethodOcc" name is used for +-- the signatures on bindings for default methods. Unfortunately, this +-- name isn't generated until typechecking, so it is not in the renamed AST. +-- We have to look it up from the 'OccEnv' parameter constructed from the typechecked +-- AST. +-- See also Note [default method Name] in GHC.Iface.Recomp +sigNameNoLoc :: forall a . (UnXRec a, HasOccName (IdP a)) => OccEnv (IdP a) -> Sig a -> [IdP a] +sigNameNoLoc _ (TypeSig _ ns _) = map (unXRec @a) ns +sigNameNoLoc _ (ClassOpSig _ False ns _) = map (unXRec @a) ns +sigNameNoLoc env (ClassOpSig _ True ns _) = mapMaybe (lookupOccEnv env . mkDefaultMethodOcc . occName) $ map (unXRec @a) ns +sigNameNoLoc _ (PatSynSig _ ns _) = map (unXRec @a) ns +sigNameNoLoc _ (SpecSig _ n _ _) = [unXRec @a n] +sigNameNoLoc _ (InlineSig _ n _) = [unXRec @a n] +sigNameNoLoc _ (FixSig _ (FixitySig _ ns _)) = map (unXRec @a) ns +sigNameNoLoc _ _ = [] + +-- Extract the source location where an instance is defined. This is used +-- to correlate InstDecls with their Instance/CoAxiom Names, via the +-- instanceMap. +getInstLoc :: Anno (IdGhcP p) ~ SrcSpanAnnN => InstDecl (GhcPass p) -> SrcSpan +getInstLoc = \case + ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLocA ty + -- The Names of data and type family instances have their SrcSpan's attached + -- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have + -- its SrcSpan attached here: + -- type family Foo a + -- type instance Foo Int = Bool + -- ^^^ + DataFamInstD _ (DataFamInstDecl + { dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l + -- Since CoAxioms' Names refer to the whole line for type family instances + -- in particular, we need to dig a bit deeper to pull out the entire + -- equation. This does not happen for data family instances, for some reason. + TyFamInstD _ (TyFamInstDecl + { tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l + +-- | Get all subordinate declarations inside a declaration, and their docs. +-- A subordinate declaration is something like the associate type or data +-- family of a type class. +subordinates :: OccEnv Name -- ^ The default method environment + -> Map RealSrcSpan Name + -> HsDecl GhcRn + -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))] +subordinates env instMap decl = case decl of + InstD _ (ClsInstD _ d) -> let + data_fams = do + DataFamInstDecl { dfid_eqn = + FamEqn { feqn_tycon = L l _ + , feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d + [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn + ty_fams = do + TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts d + [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] + in data_fams ++ ty_fams + + InstD _ (DataFamInstD _ (DataFamInstDecl d)) + -> dataSubs (feqn_rhs d) + TyClD _ d | ClassDecl{} <- d -> classSubs d + | DataDecl{} <- d -> dataSubs (tcdDataDefn d) + _ -> [] + where + classSubs dd = [ (name, doc, declTypeDocs d) + | (L _ d, doc) <- classDecls dd + , name <- getMainDeclBinder env d, not (isValD d) + ] + dataSubs :: HsDataDefn GhcRn + -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))] + dataSubs dd = constrs ++ fields ++ derivs + where + cons = unLoc <$> dd_cons dd + constrs = [ ( unLoc cname + , maybeToList $ fmap unLoc $ con_doc c + , conArgDocs c) + | c <- toList cons, cname <- getConNames c ] + fields = [ (unLoc $ foLabel n, maybeToList $ fmap unLoc doc, IM.empty) + | Just flds <- toList $ fmap getRecConArgs_maybe cons + , (L _ (HsConDeclRecField _ ns (CDF { cdf_doc = doc }))) <- (unLoc flds) + , (L _ n) <- ns ] + derivs = [ (instName, [unLoc doc], IM.empty) + | (l, doc) <- concatMap (extract_deriv_clause_tys . + deriv_clause_tys . unLoc) $ + -- unLoc $ dd_derivs dd + dd_derivs dd + , Just instName <- [lookupSrcSpan l instMap] ] + + extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDoc GhcRn)] + extract_deriv_clause_tys (L _ dct) = + case dct of + DctSingle _ ty -> maybeToList $ extract_deriv_ty ty + DctMulti _ tys -> mapMaybe extract_deriv_ty tys + + extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDoc GhcRn) + extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) = + case ty of + -- deriving (C a {- ^ Doc comment -}) + HsDocTy _ _ doc -> Just (locA l, doc) + _ -> Nothing + +-- | Extract constructor argument docs from inside constructor decls. +conArgDocs :: ConDecl GhcRn -> IntMap (HsDoc GhcRn) +conArgDocs (ConDeclH98{con_args = args}) = + h98ConArgDocs args +conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) = + gadtConArgDocs args (unLoc res_ty) + +h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn) +h98ConArgDocs con_args = case con_args of + PrefixCon args -> con_arg_docs 0 $ map cdf_doc args + InfixCon arg1 arg2 -> con_arg_docs 0 [ cdf_doc arg1, cdf_doc arg2 ] + RecCon _ -> IM.empty + +gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn) +gadtConArgDocs con_args res_ty = case con_args of + PrefixConGADT _ args -> con_arg_docs 0 $ map cdf_doc args ++ [res_doc] + RecConGADT _ _ -> con_arg_docs 1 [res_doc] + where + res_doc = case res_ty of + HsDocTy _ _ lds -> Just lds + _ -> Nothing + +con_arg_docs :: Int -> [Maybe (LHsDoc GhcRn)] -> IntMap (HsDoc GhcRn) +con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..] + where + f n (Just lds) = Just (n, unLoc lds) + f _ _ = Nothing + +isValD :: HsDecl a -> Bool +isValD (ValD _ _) = True +isValD _ = False + +-- | All the sub declarations of a class (that we handle), ordered by +-- source location, with documentation attached if it exists. +classDecls :: TyClDecl GhcRn -- Always a ClassDecl + -> [(LHsDecl GhcRn, [HsDoc GhcRn])] +classDecls decl + | ClassDecl { .. } <- decl + , let decls = docs ++ defs ++ sigs ++ ats + docs = mkDecls (DocD noExtField) tcdDocs + defs = mkDecls (ValD noExtField) tcdMeths + sigs = mkDecls (SigD noExtField) tcdSigs + ats = mkDecls (TyClD noExtField . FamDecl noExtField) tcdATs + + = filterDecls . collectDocs . sortLocatedA $ decls + + | otherwise + = pprPanic "classDecls" (ppr decl) + +-- | Extract function argument docs from inside top-level decls. +declTypeDocs :: HsDecl GhcRn -> IntMap (HsDoc GhcRn) +declTypeDocs = \case + SigD _ (TypeSig _ _ ty) -> sigTypeDocs (unLoc (dropWildCards ty)) + SigD _ (ClassOpSig _ _ _ ty) -> sigTypeDocs (unLoc ty) + SigD _ (PatSynSig _ _ ty) -> sigTypeDocs (unLoc ty) + ForD _ (ForeignImport _ _ ty _) -> sigTypeDocs (unLoc ty) + TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty) + _ -> IM.empty + +nubByName :: (a -> Name) -> [a] -> [a] +nubByName f ns = go emptyNameSet ns + where + go _ [] = [] + go s (x:xs) + | y `elemNameSet` s = go s xs + | otherwise = let !s' = extendNameSet s y + in x : go s' xs + where + y = f x + +-- | Extract function argument docs from inside types. +typeDocs :: HsType GhcRn -> IntMap (HsDoc GhcRn) +typeDocs = go 0 + where + go n = \case + HsForAllTy { hst_body = ty } -> go n (unLoc ty) + HsQualTy { hst_body = ty } -> go n (unLoc ty) + HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> IM.insert n (unLoc x) $ go (n+1) (unLoc ty) + HsFunTy _ _ _ ty -> go (n+1) (unLoc ty) + HsDocTy _ _ doc -> IM.singleton n (unLoc doc) + _ -> IM.empty + +-- | Extract function argument docs from inside types. +sigTypeDocs :: HsSigType GhcRn -> IntMap (HsDoc GhcRn) +sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body) + +-- | The top-level declarations of a module that we care about, +-- ordered by source location, with documentation attached if it exists. +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] +topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup + +-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. +ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] +ungroup (HsGroup {..}) = + mkDecls (TyClD noExtField) (tyClGroupTyClDecls hs_tyclds) ++ + mkDecls (DerivD noExtField) hs_derivds ++ + mkDecls (DefD noExtField) hs_defds ++ + mkDecls (ForD noExtField) hs_fords ++ + mkDecls (DocD noExtField) hs_docs ++ + mkDecls (InstD noExtField) (tyClGroupInstDecls hs_tyclds) ++ + mkDecls (SigD noExtField) (typesigs hs_valds) ++ + mkDecls (ValD noExtField) (valbinds hs_valds) + where + typesigs :: HsValBinds GhcRn -> [LSig GhcRn] + typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig + typesigs ValBinds{} = error "expected XValBindsLR" + + valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn] + valbinds (XValBindsLR (NValBinds binds _)) = + concat . snd . unzip $ binds + valbinds ValBinds{} = error "expected XValBindsLR" + +-- | Collect docs and attach them to the right declarations. +-- +-- A declaration may have multiple doc strings attached to it. +collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDoc p])] +-- ^ This is an example. +collectDocs = go [] Nothing + where + go docs mprev decls = case (decls, mprev) of + ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing) -> go (unLoc s:docs) Nothing ds + ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [unLoc s] Nothing ds + ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev) -> go (unLoc s:docs) mprev ds + (d : ds, Nothing) -> go docs (Just d) ds + (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds + ([] , Nothing) -> [] + ([] , Just prev) -> finished prev docs [] + + finished decl docs rest = (decl, reverse docs) : rest + +-- | Filter out declarations that we don't handle in Haddock +filterDecls :: forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)] +filterDecls = filter (isHandled . unXRec @p . fst) + where + isHandled (ForD _ (ForeignImport {})) = True + isHandled (TyClD {}) = True + isHandled (InstD {}) = True + isHandled (DerivD {}) = True + isHandled (SigD _ d) = isUserSig d + isHandled (ValD {}) = True + -- we keep doc declarations to be able to get at named docs + isHandled (DocD {}) = True + isHandled _ = False + + +-- | Go through all class declarations and filter their sub-declarations +filterClasses :: forall p doc. (IsPass p) => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)] +filterClasses = map (first (fmap filterClass)) + where + filterClass (TyClD x c@(ClassDecl {})) = + TyClD x $ c { tcdSigs = + filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) } + filterClass d = d + +-- | Was this signature given by the user? +isUserSig :: Sig name -> Bool +isUserSig TypeSig {} = True +isUserSig ClassOpSig {} = True +isUserSig PatSynSig {} = True +isUserSig _ = False + +-- | Take a field of declarations from a data structure and create HsDecls +-- using the given constructor +mkDecls :: (decl -> hsDecl) + -> [GenLocated l decl] + -> [GenLocated l hsDecl] +mkDecls con = map (fmap con) + +-- | Extracts out individual maps of documentation added via Template Haskell's +-- @putDoc@. +extractTHDocs :: THDocs + -> ExtractedTHDocs +extractTHDocs docs = + -- Split up docs into separate maps for each 'DocLoc' type + ExtractedTHDocs + { ethd_mod_header = docHeader + , ethd_decl_docs = searchDocs decl + , ethd_arg_docs = searchDocs args + , ethd_inst_docs = searchDocs insts + } + where + docHeader :: Maybe (HsDoc GhcRn) + docHeader + | ((_, s):_) <- filter isModDoc (M.toList docs) = Just s + | otherwise = Nothing + + isModDoc (ModuleDoc, _) = True + isModDoc _ = False + + -- Folds over the docs, applying 'f' as the accumulating function. + -- We use different accumulating functions to sift out the specific types of + -- documentation + searchDocs :: (UniqMap Name a -> (DocLoc, HsDoc GhcRn) -> UniqMap Name a) -> UniqMap Name a + searchDocs f = foldl' f emptyUniqMap $ M.toList docs + + -- Pick out the declaration docs + decl acc ((DeclDoc name), s) = addToUniqMap acc name s + decl acc _ = acc + + -- Pick out the instance docs + insts acc ((InstDoc name), s) = addToUniqMap acc name s + insts acc _ = acc + + -- Pick out the argument docs + args :: UniqMap Name (IntMap (HsDoc GhcRn)) + -> (DocLoc, HsDoc GhcRn) + -> UniqMap Name (IntMap (HsDoc GhcRn)) + args acc ((ArgDoc name i), s) = + -- Insert the doc for the arg into the argument map for the function. This + -- means we have to search to see if an map already exists for the + -- function, and insert the new argument if it exists, or create a new map + addToUniqMap_C (\_ m -> IM.insert i s m) acc name (IM.singleton i s) + args acc _ = acc + +-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two +-- maps with values for the same key merge the inner map as well. +-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@. + +unionArgMaps :: forall b . UniqMap Name (IntMap b) + -> UniqMap Name (IntMap b) + -> UniqMap Name (IntMap b) +unionArgMaps a b = nonDetFoldUniqMap go b a + where + go :: (Name, IntMap b) + -> UniqMap Name (IntMap b) -> UniqMap Name (IntMap b) + go (n, newArgMap) acc + | Just oldArgMap <- lookupUniqMap acc n = + addToUniqMap acc n (newArgMap `IM.union` oldArgMap) + | otherwise = addToUniqMap acc n newArgMap diff --git a/GHC/HsToCore/Errors/Ppr.hs b/GHC/HsToCore/Errors/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Errors/Ppr.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage + +module GHC.HsToCore.Errors.Ppr where + +import GHC.Core.Predicate (isEvId) +import GHC.Core.Type +import GHC.Driver.Flags +import GHC.Hs +import GHC.HsToCore.Errors.Types +import GHC.Prelude +import GHC.Types.Basic (pprRuleName) +import GHC.Types.Error +import GHC.Types.Error.Codes +import GHC.Types.Id (idType) +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Utils.Outputable +import qualified GHC.LanguageExtensions as LangExt +import GHC.HsToCore.Pmc.Ppr + + +instance Diagnostic DsMessage where + type DiagnosticOpts DsMessage = NoDiagnosticOpts + diagnosticMessage opts = \case + DsUnknownMessage (UnknownDiagnostic f _ m) + -> diagnosticMessage (f opts) m + DsEmptyEnumeration + -> mkSimpleDecorated $ text "Enumeration is empty" + DsIdentitiesFound conv_fn type_of_conv + -> mkSimpleDecorated $ + vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv + , nest 2 $ text "can probably be omitted" + ] + DsOverflowedLiterals i tc bounds _possiblyUsingNegativeLiterals + -> let msg = case bounds of + Nothing + -> vcat [ text "Literal" <+> integer i + <+> text "is negative but" <+> ppr tc + <+> text "only supports positive numbers" + ] + Just (MinBound minB, MaxBound maxB) + -> vcat [ text "Literal" <+> integer i + <+> text "is out of the" <+> ppr tc <+> text "range" + <+> integer minB <> text ".." <> integer maxB + ] + in mkSimpleDecorated msg + DsRedundantBangPatterns ctx q + -> mkSimpleDecorated $ pprEqn ctx q "has redundant bang" + DsOverlappingPatterns ctx q + -> mkSimpleDecorated $ pprEqn ctx q "is redundant" + DsInaccessibleRhs ctx q + -> mkSimpleDecorated $ pprEqn ctx q "has inaccessible right hand side" + DsMaxPmCheckModelsReached limit + -> mkSimpleDecorated $ vcat + [ hang + (text "Pattern match checker ran into -fmax-pmcheck-models=" + <> int limit + <> text " limit, so") + 2 + ( bullet <+> text "Redundant clauses might not be reported at all" + $$ bullet <+> text "Redundant clauses might be reported as inaccessible" + $$ bullet <+> text "Patterns reported as unmatched might actually be matched") + ] + DsNonExhaustivePatterns kind _flag maxPatterns vars nablas + -> mkSimpleDecorated $ + pprContext False kind (text "are non-exhaustive") $ \_ -> + case vars of -- See #11245 + [] -> text "Guards do not cover entire pattern space" + _ -> let us = map (\nabla -> pprUncovered nabla vars) nablas + pp_tys = pprQuotedList $ map idType vars + in hang + (text "Patterns of type" <+> pp_tys <+> text "not matched:") + 4 + (vcat (take maxPatterns us) $$ dots maxPatterns us) + DsTopLevelBindsNotAllowed bindsType bind + -> let desc = case bindsType of + UnliftedTypeBinds -> "bindings for unlifted types" + StrictBinds -> "strict bindings" + in mkSimpleDecorated $ + hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind) + DsUselessSpecialisePragma poly_nm is_dfun rea -> + mkSimpleDecorated $ + vcat [ what <+> pragma <+> text "pragma" <> why + , additional ] + where + quoted_nm = quotes (ppr poly_nm) + what + | uselessSpecialisePragmaKeepAnyway rea + = text "Dubious" + | otherwise + = text "Ignoring useless" + pragma = if is_dfun + then text "SPECIALISE instance" + else text "SPECIALISE" + why = case rea of + UselessSpecialiseForClassMethodSelector -> + text " for class selector:" <+> quoted_nm + UselessSpecialiseForNoInlineFunction -> + text " for NOINLINE function:" <+> quoted_nm + UselessSpecialiseNoSpecialisation -> + -- Omit the Name for a DFunId, as it will be internal and not + -- very illuminating to users who don't know what a DFunId is. + (if is_dfun then empty else text " for" <+> quoted_nm) <> dot + + additional + | uselessSpecialisePragmaKeepAnyway rea + = -- No specialisation happening, but the pragma may still be useful. + -- For example (#25389): + -- + -- data G a where { G1 :: G Int, G2 :: G Bool } + -- f :: G a -> a + -- f G1 = ; f G2 = + -- {-# SPECIALISE f :: G Int -> Int #-} + -- -- In $sf, we get rid of dead code in + vcat + [ text "The pragma does not specialise away any class dictionaries," + , text "and neither is there any value specialisation." + ] + | otherwise + = empty + DsOrphanRule rule + -> mkSimpleDecorated $ text "Orphan rule:" <+> ppr rule + DsRuleLhsTooComplicated orig_lhs lhs2 + -> mkSimpleDecorated $ + hang (text "RULE left-hand side too complicated to desugar") + 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 + , text "Orig lhs:" <+> ppr orig_lhs]) + DsRuleIgnoredDueToConstructor con + -> mkSimpleDecorated $ vcat + [ text "A constructor," <+> ppr con <> + text ", appears as outermost match in RULE lhs." + , text "This rule will be ignored." ] + DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2 + -> mkSimpleDecorated $ vcat (map pp_dead unbound) + where + pp_dead bndr = + hang (sep [ text "Forall'd" <+> pp_bndr bndr + , text "is not bound in RULE lhs"]) + 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs + , text "Orig lhs:" <+> ppr orig_lhs + , text "Optimised lhs:" <+> ppr lhs2 ]) + + pp_bndr b + | isTyVar b = text "type variable" <+> quotes (ppr b) + | isEvId b = text "constraint" <+> quotes (ppr (varType b)) + | otherwise = text "variable" <+> quotes (ppr b) + DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs + -> mkSimpleDecorated $ + hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ + text "Unlifted variables:") + 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) unlifted_bndrs)) + DsNotYetHandledByTH reason + -> case reason of + ThAmbiguousRecordUpdates fld + -> mkMsg "Ambiguous record updates" (ppr fld) + ThAbstractClosedTypeFamily decl + -> mkMsg "abstract closed type family" (ppr decl) + ThForeignLabel cls + -> mkMsg "Foreign label" (doubleQuotes (ppr cls)) + ThForeignExport decl + -> mkMsg "Foreign export" (ppr decl) + ThMinimalPragmas + -> mkMsg "MINIMAL pragmas" empty + ThSCCPragmas + -> mkMsg "SCC pragmas" empty + ThNoUserInline + -> mkMsg "NOUSERINLINE" empty + ThExoticFormOfType ty + -> mkMsg "Exotic form of type" (ppr ty) + ThAmbiguousRecordSelectors e + -> mkMsg "Ambiguous record selectors" (ppr e) + ThMonadComprehensionSyntax e + -> mkMsg "monad comprehension and [: :]" (ppr e) + ThCostCentres e + -> mkMsg "Cost centres" (ppr e) + ThExpressionForm e + -> mkMsg "Expression form" (ppr e) + ThExoticStatement other + -> mkMsg "Exotic statement" (ppr other) + ThExoticLiteral lit + -> mkMsg "Exotic literal" (ppr lit) + ThExoticPattern pat + -> mkMsg "Exotic pattern" (ppr pat) + ThGuardedLambdas m + -> mkMsg "Guarded lambdas" (pprMatch m) + ThNegativeOverloadedPatterns pat + -> mkMsg "Negative overloaded patterns" (ppr pat) + ThHaddockDocumentation + -> mkMsg "Haddock documentation" empty + ThWarningAndDeprecationPragmas decl + -> mkMsg "WARNING and DEPRECATION pragmas" $ + text "Pragma for declaration of" <+> ppr decl + ThSplicesWithinDeclBrackets + -> mkMsg "Splices within declaration brackets" empty + ThNonLinearDataCon + -> mkMsg "Non-linear fields in data constructors" empty + ThDataConVisibleForall + -> mkMsg "Visible forall in data constructors" empty + where + mkMsg what doc = + mkSimpleDecorated $ + hang (text what <+> text "not (yet) handled by Template Haskell") 2 doc + DsAggregatedViewExpressions views + -> mkSimpleDecorated (vcat msgs) + where + msgs = map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) views + DsUnbangedStrictPatterns bind + -> mkSimpleDecorated $ + hang (text "Pattern bindings containing unlifted types should use" $$ + text "an outermost bang pattern:") + 2 (ppr bind) + DsCannotMixPolyAndUnliftedBindings bind + -> mkSimpleDecorated $ + hang (text "You can't mix polymorphic and unlifted bindings:") + 2 (ppr bind) + DsWrongDoBind _rhs elt_ty + -> mkSimpleDecorated $ badMonadBind elt_ty + DsUnusedDoBind _rhs elt_ty + -> mkSimpleDecorated $ badMonadBind elt_ty + DsRecBindsNotAllowedForUnliftedTys binds + -> mkSimpleDecorated $ + hang (text "Recursive bindings for unlifted types aren't allowed:") + 2 (vcat (map ppr binds)) + DsRuleMightInlineFirst rule_name lhs_id _ + -> mkSimpleDecorated $ + vcat [ hang (text "Rule" <+> pprRuleName rule_name + <+> text "may never fire") + 2 (text "because" <+> quotes (ppr lhs_id) + <+> text "might inline first") + ] + DsAnotherRuleMightFireFirst rule_name bad_rule lhs_id + -> mkSimpleDecorated $ + vcat [ hang (text "Rule" <+> pprRuleName rule_name + <+> text "may never fire") + 2 (text "because rule" <+> pprRuleName bad_rule + <+> text "for"<+> quotes (ppr lhs_id) + <+> text "might fire first") + ] + DsIncompleteRecordSelector name cons maxCons -> mkSimpleDecorated $ + hang (text "Selecting the record field" <+> quotes (ppr name) + <+> text "may fail for the following constructors:") + 2 + (hsep $ punctuate comma $ + map ppr (take maxCons cons) ++ [ text "..." | lengthExceeds cons maxCons ]) + + diagnosticReason = \case + DsUnknownMessage m -> diagnosticReason m + DsEmptyEnumeration -> WarningWithFlag Opt_WarnEmptyEnumerations + DsIdentitiesFound{} -> WarningWithFlag Opt_WarnIdentities + DsOverflowedLiterals{} -> WarningWithFlag Opt_WarnOverflowedLiterals + DsRedundantBangPatterns{} -> WarningWithFlag Opt_WarnRedundantBangPatterns + DsOverlappingPatterns{} -> WarningWithFlag Opt_WarnOverlappingPatterns + DsInaccessibleRhs{} -> WarningWithFlag Opt_WarnOverlappingPatterns + DsMaxPmCheckModelsReached{} -> WarningWithoutFlag + DsNonExhaustivePatterns _ (ExhaustivityCheckType mb_flag) _ _ _ + -> maybe WarningWithoutFlag WarningWithFlag mb_flag + DsTopLevelBindsNotAllowed{} -> ErrorWithoutFlag + DsUselessSpecialisePragma{} -> WarningWithFlag Opt_WarnUselessSpecialisations + DsOrphanRule{} -> WarningWithFlag Opt_WarnOrphans + DsRuleLhsTooComplicated{} -> WarningWithoutFlag + DsRuleIgnoredDueToConstructor{} -> WarningWithoutFlag + DsRuleBindersNotBound{} -> WarningWithoutFlag + DsLazyPatCantBindVarsOfUnliftedType{} -> ErrorWithoutFlag + DsNotYetHandledByTH{} -> ErrorWithoutFlag + DsAggregatedViewExpressions{} -> WarningWithoutFlag + DsUnbangedStrictPatterns{} -> WarningWithFlag Opt_WarnUnbangedStrictPatterns + DsCannotMixPolyAndUnliftedBindings{} -> ErrorWithoutFlag + DsWrongDoBind{} -> WarningWithFlag Opt_WarnWrongDoBind + DsUnusedDoBind{} -> WarningWithFlag Opt_WarnUnusedDoBind + DsRecBindsNotAllowedForUnliftedTys{} -> ErrorWithoutFlag + DsRuleMightInlineFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing + DsAnotherRuleMightFireFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing + DsIncompleteRecordSelector{} -> WarningWithFlag Opt_WarnIncompleteRecordSelectors + + diagnosticHints = \case + DsUnknownMessage m -> diagnosticHints m + DsEmptyEnumeration -> noHints + DsIdentitiesFound{} -> noHints + DsOverflowedLiterals i _tc bounds usingNegLiterals + -> case (bounds, usingNegLiterals) of + (Just (MinBound minB, MaxBound _), NotUsingNegLiterals) + | minB == -i -- Note [Suggest NegativeLiterals] + , i > 0 + -> [ suggestExtensionWithInfo (text "If you are trying to write a large negative literal") + LangExt.NegativeLiterals ] + _ -> noHints + DsRedundantBangPatterns{} -> noHints + DsOverlappingPatterns{} -> noHints + DsInaccessibleRhs{} -> noHints + DsMaxPmCheckModelsReached{} -> [SuggestIncreaseMaxPmCheckModels] + DsNonExhaustivePatterns{} -> noHints + DsTopLevelBindsNotAllowed{} -> noHints + DsUselessSpecialisePragma{} -> noHints + DsOrphanRule{} -> noHints + DsRuleLhsTooComplicated{} -> noHints + DsRuleIgnoredDueToConstructor{} -> noHints + DsRuleBindersNotBound{} -> noHints + DsLazyPatCantBindVarsOfUnliftedType{} -> noHints + DsNotYetHandledByTH{} -> noHints + DsAggregatedViewExpressions{} -> noHints + DsUnbangedStrictPatterns{} -> noHints + DsCannotMixPolyAndUnliftedBindings{} -> [SuggestAddTypeSignatures UnnamedBinding] + DsWrongDoBind rhs _ -> [SuggestBindToWildcard rhs] + DsUnusedDoBind rhs _ -> [SuggestBindToWildcard rhs] + DsRecBindsNotAllowedForUnliftedTys{} -> noHints + DsRuleMightInlineFirst _ lhs_id rule_act -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act] + DsAnotherRuleMightFireFirst _ bad_rule _ -> [SuggestAddPhaseToCompetingRule bad_rule] + DsIncompleteRecordSelector{} -> noHints + + diagnosticCode = constructorCode @GHC + +{- +Note [Suggest NegativeLiterals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you write + x :: Int8 + x = -128 +it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals. +We get an erroneous suggestion for + x = 128 +but perhaps that does not matter too much. +-} + +-- +-- Helper functions +-- + +badMonadBind :: Type -> SDoc +badMonadBind elt_ty + = hang (text "A do-notation statement discarded a result of type") + 2 (quotes (ppr elt_ty)) + +-- Print a single clause (for redundant/with-inaccessible-rhs) +pprEqn :: HsMatchContextRn -> SDoc -> String -> SDoc +pprEqn ctx q txt = pprContext True ctx (text txt) $ \f -> + f (q <+> matchSeparator ctx <+> text "...") + +pprContext :: Bool -> HsMatchContextRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc +pprContext singular kind msg rest_of_msg_fun + = vcat [text txt <+> msg, + sep [ text "In" <+> ppr_match <> char ':' + , nest 4 (rest_of_msg_fun pref)]] + where + txt | singular = "Pattern match" + | otherwise = "Pattern match(es)" + + (ppr_match, pref) + = case kind of + FunRhs { mc_fun = L _ fun } + -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + _ -> (pprMatchContext kind, \ pp -> pp) + +dots :: Int -> [a] -> SDoc +dots maxPatterns qs + | qs `lengthExceeds` maxPatterns = text "..." + | otherwise = empty diff --git a/GHC/HsToCore/Errors/Types.hs b/GHC/HsToCore/Errors/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Errors/Types.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.HsToCore.Errors.Types where + +import GHC.Prelude + +import GHC.Core (CoreRule, CoreExpr, RuleName) +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.Type +import GHC.Driver.DynFlags (DynFlags, xopt) +import GHC.Driver.Flags (WarningFlag) +import GHC.Hs +import GHC.HsToCore.Pmc.Solver.Types +import GHC.Types.Basic (Activation) +import GHC.Types.Error +import GHC.Types.ForeignCall +import GHC.Types.Id +import GHC.Types.Name (Name) +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Generics (Generic) + +newtype MinBound = MinBound Integer +newtype MaxBound = MaxBound Integer +type MaxUncoveredPatterns = Int +type MaxPmCheckModels = Int + +-- | Diagnostics messages emitted during desugaring. +data DsMessage + -- | Simply wraps a generic 'Diagnostic' message. + = DsUnknownMessage (UnknownDiagnosticFor DsMessage) + + {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is + emitted if an enumeration is empty. + + Example(s): + + main :: IO () + main = do + let enum = [5 .. 3] + print enum + + Here 'enum' would yield an empty list, because 5 is greater than 3. + + Test case(s): + warnings/should_compile/T10930 + warnings/should_compile/T18402 + warnings/should_compile/T10930b + numeric/should_compile/T10929 + numeric/should_compile/T7881 + deSugar/should_run/T18172 + + -} + | DsEmptyEnumeration + + {-| DsIdentitiesFound is a warning (controlled by the -Widentities flag) that is + emitted on uses of Prelude numeric conversions that are probably the identity + (and hence could be omitted). + + Example(s): + + main :: IO () + main = do + let x = 10 + print $ conv 10 + + where + conv :: Int -> Int + conv x = fromIntegral x + + Here calling 'conv' is essentially the identity function, and therefore can be omitted. + + Test case(s): + deSugar/should_compile/T4488 + -} + | DsIdentitiesFound !Id -- The conversion function + !Type -- The type of conversion + + | DsOverflowedLiterals !Integer + !Name + !(Maybe (MinBound, MaxBound)) + !NegLiteralExtEnabled + + -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately + -- 'SrcInfo' gives us an 'SDoc' to begin with. + | DsRedundantBangPatterns !HsMatchContextRn !SDoc + + -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately + -- 'SrcInfo' gives us an 'SDoc' to begin with. + | DsOverlappingPatterns !HsMatchContextRn !SDoc + + -- FIXME(adn) Use a proper type instead of 'SDoc' + | DsInaccessibleRhs !HsMatchContextRn !SDoc + + | DsMaxPmCheckModelsReached !MaxPmCheckModels + + | DsNonExhaustivePatterns !HsMatchContextRn + !ExhaustivityCheckType + !MaxUncoveredPatterns + [Id] + [Nabla] + + | DsTopLevelBindsNotAllowed !BindsType !(HsBindLR GhcTc GhcTc) + + {-| DsUselessSpecialisePragma is a warning (controlled by the -Wuseless-specialisations flag) + that is emitted for SPECIALISE pragmas that (most likely) don't do anything. + + Examples: + + foo :: forall a. a -> a + {-# SPECIALISE foo :: Int -> Int #-} + -} + | DsUselessSpecialisePragma + !Name + !Bool -- ^ is this a @SPECIALISE instance@ pragma? + !UselessSpecialisePragmaReason + + | DsOrphanRule !CoreRule + + | DsRuleLhsTooComplicated !CoreExpr !CoreExpr + + | DsRuleIgnoredDueToConstructor !DataCon + + | DsRuleBindersNotBound ![Var] + -- ^ The list of unbound binders + ![Var] + -- ^ The original binders + !CoreExpr + -- ^ The original LHS + !CoreExpr + -- ^ The optimised LHS + + | DsLazyPatCantBindVarsOfUnliftedType [Var] + + | DsNotYetHandledByTH !ThRejectionReason + + | DsAggregatedViewExpressions [[LHsExpr GhcTc]] + + | DsUnbangedStrictPatterns !(HsBindLR GhcTc GhcTc) + + | DsCannotMixPolyAndUnliftedBindings !(HsBindLR GhcTc GhcTc) + + | DsWrongDoBind !(LHsExpr GhcTc) !Type + + | DsUnusedDoBind !(LHsExpr GhcTc) !Type + + | DsRecBindsNotAllowedForUnliftedTys ![LHsBindLR GhcTc GhcTc] + + | DsRuleMightInlineFirst !RuleName !Var !Activation + + | DsAnotherRuleMightFireFirst !RuleName + !RuleName -- the \"bad\" rule + !Var + + {-| DsIncompleteRecordSelector is a warning triggered when we are not certain whether + a record selector application will be successful. Currently, this means that + the warning is triggered when there is a record selector of a data type that + does not have that field in all its constructors. + + Example(s): + data T = T1 | T2 {x :: Bool} + f :: T -> Bool + f a = x a + + Test cases: + DsIncompleteRecSel1 + DsIncompleteRecSel2 + DsIncompleteRecSel3 + -} + | DsIncompleteRecordSelector !Name -- ^ The selector + ![ConLike] -- ^ The partial constructors + !Int -- ^ The max number of constructors reported + + deriving Generic + +-- The positional number of the argument for an expression (first, second, third, etc) +newtype DsArgNum = DsArgNum Int + +-- | Why TemplateHaskell rejected the splice. Used in the 'DsNotYetHandledByTH' +-- constructor of a 'DsMessage'. +data ThRejectionReason + = ThAmbiguousRecordUpdates !(HsRecUpdField GhcRn GhcRn) + | ThAbstractClosedTypeFamily !(LFamilyDecl GhcRn) + | ThForeignLabel !CLabelString + | ThForeignExport !(LForeignDecl GhcRn) + | ThMinimalPragmas + | ThSCCPragmas + | ThNoUserInline + | ThExoticFormOfType !(HsType GhcRn) + | ThAmbiguousRecordSelectors !(HsExpr GhcRn) + | ThMonadComprehensionSyntax !(HsExpr GhcRn) + | ThCostCentres !(HsExpr GhcRn) + | ThExpressionForm !(HsExpr GhcRn) + | ThExoticStatement [Stmt GhcRn (LHsExpr GhcRn)] + | ThExoticLiteral !(HsLit GhcRn) + | ThExoticPattern !(Pat GhcRn) + | ThGuardedLambdas !(Match GhcRn (LHsExpr GhcRn)) + | ThNegativeOverloadedPatterns !(Pat GhcRn) + | ThHaddockDocumentation + | ThWarningAndDeprecationPragmas [LIdP GhcRn] + | ThSplicesWithinDeclBrackets + | ThNonLinearDataCon + | ThDataConVisibleForall + +-- | Why is a @SPECIALISE@ pragmas useless? +data UselessSpecialisePragmaReason + -- | Useless @SPECIALISE@ pragma for a class method + = UselessSpecialiseForClassMethodSelector + -- | Useless @SPECIALISE@ pragma for a function with NOINLINE + | UselessSpecialiseForNoInlineFunction + -- | Useless @SPECIALISE@ pragma which generates a specialised function + -- which is identical to the original function at runtime. + | UselessSpecialiseNoSpecialisation + deriving Generic + +uselessSpecialisePragmaKeepAnyway :: UselessSpecialisePragmaReason -> Bool +uselessSpecialisePragmaKeepAnyway = \case + UselessSpecialiseForClassMethodSelector -> False + UselessSpecialiseForNoInlineFunction -> False + UselessSpecialiseNoSpecialisation -> True + -- See #25389/T25389 for why we might want to keep this specialisation + -- around even if it seemingly does nothing. + +data NegLiteralExtEnabled + = YesUsingNegLiterals + | NotUsingNegLiterals + +negLiteralExtEnabled :: DynFlags -> NegLiteralExtEnabled +negLiteralExtEnabled dflags = + if (xopt LangExt.NegativeLiterals dflags) then YesUsingNegLiterals else NotUsingNegLiterals + +newtype ExhaustivityCheckType = ExhaustivityCheckType (Maybe WarningFlag) + +data BindsType + = UnliftedTypeBinds + | StrictBinds diff --git a/GHC/HsToCore/Expr.hs b/GHC/HsToCore/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Expr.hs @@ -0,0 +1,1268 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE LambdaCase #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring expressions. +-} + +module GHC.HsToCore.Expr + ( dsExpr, dsLExpr, dsLocalBinds + , dsValBinds, dsLit, dsSyntaxExpr + ) +where + +import GHC.Prelude + +import GHC.HsToCore.Match +import GHC.HsToCore.Match.Literal +import GHC.HsToCore.Binds +import GHC.HsToCore.GuardedRHSs +import GHC.HsToCore.ListComp +import GHC.HsToCore.Utils +import GHC.HsToCore.Arrows +import GHC.HsToCore.Monad +import GHC.HsToCore.Pmc +import GHC.HsToCore.Pmc.Utils +import GHC.HsToCore.Errors.Types +import GHC.HsToCore.Quote +import GHC.HsToCore.Ticks (stripTicksTopHsExpr) +import GHC.Hs + + +-- NB: The desugarer, which straddles the source and Core worlds, sometimes +-- needs to see source types +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Monad +import GHC.Tc.Instance.Class (lookupHasFieldLabel) + +import GHC.Core +import GHC.Core.FVs( exprsFreeVarsList ) +import GHC.Core.FamInstEnv( topNormaliseType ) +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Core.PatSyn + +import GHC.Driver.Session + +import GHC.Types.SourceText +import GHC.Types.Name hiding (varName) +import GHC.Types.CostCentre +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Id.Make +import GHC.Types.Var( isInvisibleAnonPiTyBinder ) +import GHC.Types.Var.Set( isEmptyVarSet, elemVarSet ) +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Tickish + +import GHC.Unit.Module +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Builtin.Types +import GHC.Builtin.Names + +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import Control.Monad + +{- +************************************************************************ +* * + dsLocalBinds, dsValBinds +* * +************************************************************************ +-} + +dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsLocalBinds (EmptyLocalBinds _) body = return body +dsLocalBinds b@(HsValBinds _ binds) body = putSrcSpanDs (spanHsLocaLBinds b) $ + dsValBinds binds body +dsLocalBinds (HsIPBinds _ binds) body = dsIPBinds binds body + +------------------------- +-- caller sets location +dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsValBinds (XValBindsLR (NValBinds binds _)) body + = do { dflags <- getDynFlags + ; foldrM (ds_val_bind dflags) body binds } +dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" + +------------------------- +dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsIPBinds (IPBinds ev_binds ip_binds) body + = do { dsTcEvBinds ev_binds $ \ ds_binds -> do + { let inner = mkCoreLets ds_binds body + -- The dict bindings may not be in + -- dependency order; hence Rec + ; foldrM ds_ip_bind inner ip_binds } } + where + ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr + -- Given (IPBind n s e), we have + -- n :: IP s ty, e :: ty + -- Use evWrapIP to convert `e` (the user-written RHS) to an IP dictionary + ds_ip_bind (L _ (IPBind n _ e)) body + = do e' <- dsLExpr e + return (Let (NonRec n (evWrapIPE (idType n) e')) body) + +------------------------- +-- caller sets location +ds_val_bind :: DynFlags -> (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr +-- Special case for bindings which bind unlifted variables +-- We need to do a case right away, rather than building +-- a tuple and doing selections. +-- Silently ignore INLINE and SPECIALISE pragmas... +ds_val_bind _ (NonRecursive, hsbinds) body + | [L loc bind] <- hsbinds + -- Non-recursive, non-overloaded bindings only come in ones + -- ToDo: in some bizarre case it's conceivable that there + -- could be dict binds in the 'binds'. (See the notes + -- below. Then pattern-match would fail. Urk.) + , isUnliftedHsBind bind + = putSrcSpanDs (locA loc) $ + -- see Note [Strict binds checks] in GHC.HsToCore.Binds + if is_polymorphic bind + then errDsCoreExpr (DsCannotMixPolyAndUnliftedBindings bind) + -- data Ptr a = Ptr Addr# + -- f x = let p@(Ptr y) = ... in ... + -- Here the binding for 'p' is polymorphic, but does + -- not mix with an unlifted binding for 'y'. You should + -- use a bang pattern. #6078. + + else do { when (looksLazyPatBind bind) $ + diagnosticDs (DsUnbangedStrictPatterns bind) + -- Complain about a binding that looks lazy + -- e.g. let I# y = x in ... + -- Remember, in checkStrictBinds we are going to do strict + -- matching, so (for software engineering reasons) we insist + -- that the strictness is manifest on each binding + -- However, lone (unboxed) variables are ok + + + ; dsUnliftedBind bind body } + where + is_polymorphic (XHsBindsLR (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })) + = not (null tvs && null evs) + is_polymorphic _ = False + + +ds_val_bind _ (is_rec, binds) _body + | any (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in GHC.HsToCore.Binds + = assert (isRec is_rec ) + errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys binds + +-- Special case: a non-recursive PatBind. No dancing about with lets and seqs, +-- we make a case immediately. Very important for linear types: let !pat can be +-- linear, but selectors as used in the general case aren't. So the general case +-- would transform a linear definition into a non-linear one. See Wrinkle 2 +-- Note [Desugar Strict binds] in GHC.HsToCore.Binds. +ds_val_bind dflags (NonRecursive, hsbinds) body + | [L _loc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_ann + , pat_ext = (ty, (rhs_tick, _var_ticks))})] <- hsbinds + -- Non-recursive, non-overloaded bindings only come in ones + , pat' <- decideBangHood dflags pat + , isBangedLPat pat' + = do { rhss_nablas <- pmcGRHSs PatBindGuards grhss + ; rhs_expr <- dsGuarded grhss ty rhss_nablas + ; let rhs' = mkOptTickBox rhs_tick rhs_expr + ; let body_ty = exprType body + ; let mult = getTcMultAnn mult_ann + ; error_expr <- mkErrorAppDs pAT_ERROR_ID body_ty (ppr pat') + ; matchSimply rhs' PatBindRhs mult pat' body error_expr } + -- This is the one place where matchSimply is given a non-ManyTy + -- multiplicity argument. + -- + -- In this form, there isn't a natural place for the var_ticks. In + -- mkSelectorBinds, the ticks are around the selector function but there + -- aren't any selection functions as we make a single pattern-match. Is this a + -- problem? + +-- Ordinary case for bindings; none should be unlifted +ds_val_bind _ (is_rec, binds) body + = do { massert (isRec is_rec || isSingleton binds) + -- we should never produce a non-recursive list of multiple binds + + ; (force_vars,prs) <- dsLHsBinds binds + ; let body' = foldr seqVar body force_vars + ; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $ + -- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType + case prs of + [] -> return body + _ -> return (mkLets (mk_binds is_rec prs) body') } + -- We can make a non-recursive let because we make sure to return + -- the bindings in dependency order in dsLHsBinds, + -- see Note [Return non-recursive bindings in dependency order] in + -- GHC.HsToCore.Binds + +-- | Helper function. You can use the result of 'mk_binds' with 'mkLets' for +-- instance. +-- +-- * @'mk_binds' 'Recursive' binds@ makes a single mutually-recursive +-- bindings with all the rhs/lhs pairs in @binds@ +-- * @'mk_binds' 'NonRecursive' binds@ makes one non-recursive binding +-- for each rhs/lhs pairs in @binds@ +mk_binds :: RecFlag -> [(b, (Expr b))] -> [Bind b] +mk_binds Recursive binds = [Rec binds] +mk_binds NonRecursive binds = map (uncurry NonRec) binds + +------------------ +dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr +dsUnliftedBind (XHsBindsLR (AbsBinds { abs_tvs = [], abs_ev_vars = [] + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = lbinds })) body + = do { let body1 = foldr bind_export body exports + bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b + ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body) + body1 lbinds + ; dsTcEvBinds_s ev_binds $ \ ds_binds -> do + { return (mkCoreLets ds_binds body2) } } + +dsUnliftedBind (FunBind { fun_id = L l fun + , fun_matches = matches + , fun_ext = (co_fn, tick) + }) body + -- Can't be a bang pattern (that looks like a PatBind) + -- so must be simply unboxed + = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun) noAnn) Nothing matches + ; massert (null args) -- Functions aren't unlifted + ; dsHsWrapper co_fn $ \core_wrap -> -- Can be non-identity (#21516) + do { let rhs' = core_wrap (mkOptTickBox tick rhs) + ; return (bindNonRec fun rhs' body) } } + +dsUnliftedBind (PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_ext = (ty, _) }) body + = -- let C x# y# = rhs in body + -- ==> case rhs of C x# y# -> body + do { match_nablas <- pmcGRHSs PatBindGuards grhss + ; rhs <- dsGuarded grhss ty match_nablas + ; let eqn = EqnMatch { eqn_pat = pat, eqn_rest = EqnDone (cantFailMatchResult body) } + ; var <- selectMatchVar ManyTy (unLoc pat) + -- `var` will end up in a let binder, so the multiplicity + -- doesn't matter. + ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) + ; return (bindNonRec var rhs result) } + +dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) + +{- +************************************************************************ +* * +* Variables, constructors, literals * +* * +************************************************************************ +-} + +-- | Desugar a located typechecked expression. +dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr +dsLExpr (L loc e) = putSrcSpanDsA loc $ dsExpr e + +-- | Desugar a typechecked expression. +dsExpr :: HsExpr GhcTc -> DsM CoreExpr + +dsExpr e@(HsVar {}) = dsApp e +dsExpr e@(HsApp {}) = dsApp e +dsExpr e@(HsAppType {}) = dsApp e + +dsExpr (HsHole (_, (HER ref _ _))) = dsEvTerm =<< readMutVar ref + -- See Note [Holes in expressions] in GHC.Tc.Types.Constraint. + +dsExpr (HsPar _ e) = dsLExpr e +dsExpr (ExprWithTySig _ e _) = dsLExpr e + +dsExpr (HsLit _ lit) + = do { warnAboutOverflowedLit lit + ; dsLit lit } + +dsExpr (HsOverLit _ lit) + = do { warnAboutOverflowedOverLit lit + ; dsOverLit lit } + +dsExpr e@(XExpr ext_expr_tc) + = case ext_expr_tc of + HsRecSelTc {} -> dsApp e + WrapExpr {} -> dsApp e + ConLikeTc {} -> dsApp e + + ExpandedThingTc o e + | OrigStmt (L loc _) <- o + -> putSrcSpanDsA loc $ dsExpr e + | otherwise -> dsExpr e + -- Hpc Support + HsTick tickish e -> do + e' <- dsLExpr e + return (Tick tickish e') + + -- There is a problem here. The then and else branches + -- have no free variables, so they are open to lifting. + -- We need someway of stopping this. + -- This will make no difference to binary coverage + -- (did you go here: YES or NO), but will effect accurate + -- tick counting. + + HsBinTick ixT ixF e -> do + e2 <- dsLExpr e + do { assert (exprType e2 `eqType` boolTy) + mkBinaryTickBox ixT ixF e2 + } + + + +-- Strip ticks due to #21701, need to be invariant about warnings we produce whether +-- this is enabled or not. +dsExpr (NegApp _ (L loc + (stripTicksTopHsExpr -> (ts, (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))))) + neg_expr) + = do { expr' <- putSrcSpanDsA loc $ do + { warnAboutOverflowedOverLit + -- See Note [Checking "negative literals"] + (lit { ol_val = HsIntegral (negateIntegralLit i) }) + ; dsOverLit lit } + ; dsSyntaxExpr neg_expr [mkTicks ts expr'] } + +dsExpr (NegApp _ expr neg_expr) + = do { expr' <- dsLExpr expr + ; dsSyntaxExpr neg_expr [expr'] } + +dsExpr (HsLam _ variant a_Match) + = uncurry mkCoreLams <$> matchWrapper (LamAlt variant) Nothing a_Match + + +{- +Note [Checking "negative literals"] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +As observed in #13257 it's desirable to warn about overflowing negative literals +in some situations where the user thinks they are writing a negative literal (ie -1) +but without `-XNegativeLiterals` enabled. + +This catches cases such as (-1 :: Word8) which overflow, because (negate 1 == 255) but +which we desugar to `negate (fromIntegral 1)`. + +Notice it's crucial we still desugar to the correct (negate (fromIntegral ...)) despite +performing the negation in order to check whether the application of negate will overflow. +For a user written Integer instance we can't predict the interaction of negate and fromIntegral. + +Also note that this works for detecting the right result for `-128 :: Int8`.. which is +in-range for Int8 but the correct result is achieved via two overflows. + +negate (fromIntegral 128 :: Int8) += negate (-128 :: Int8) += -128 :: Int8 + +Note [Desugaring vars] +~~~~~~~~~~~~~~~~~~~~~~ +In one situation we can get a *coercion* variable in a HsVar, namely +the support method for an equality superclass: + class (a~b) => C a b where ... + instance (blah) => C (T a) (T b) where .. +Then we get + $dfCT :: forall ab. blah => C (T a) (T b) + $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) + + $c$p1C :: forall ab. blah => (T a ~ T b) + $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g + +That 'g' in the 'in' part is an evidence variable, and when +converting to core it must become a CO. +-} + +dsExpr (ExplicitTuple _ tup_args boxity) + = do { let go (lam_vars, args) (Missing st) + -- For every missing expression, we need + -- another lambda in the desugaring. + = do { lam_var <- newSysLocalDs st + ; return (lam_var : lam_vars, Var lam_var : args) } + go (lam_vars, args) (Present _ expr) + -- Expressions that are present don't generate + -- lambdas, just arguments. + = do { core_expr <- dsLExpr expr + ; return (lam_vars, core_expr : args) } + + ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args) + -- The reverse is because foldM goes left-to-right + ; return $ mkCoreLams lam_vars (mkCoreTupBoxity boxity args) } + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + +dsExpr (ExplicitSum types alt arity expr) + = mkCoreUnboxedSum arity alt types <$> dsLExpr expr + +dsExpr (HsPragE _ (HsPragSCC _ cc) expr) + = do { dflags <- getDynFlags + ; if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags + then do + mod_name <- getModule + count <- goptM Opt_ProfCountEntries + let nm = sl_fs cc + flavour <- mkExprCCFlavour <$> getCCIndexDsM nm + Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True) + <$> dsLExpr expr + else dsLExpr expr } + +dsExpr (HsCase ctxt discrim matches) + = do { core_discrim <- dsLExpr discrim + ; ([discrim_var], matching_code) <- matchWrapper ctxt (Just [discrim]) matches + ; return (bindNonRec discrim_var core_discrim matching_code) } + +-- Pepe: The binds are in scope in the body but NOT in the binding group +-- This is to avoid silliness in breakpoints +dsExpr (HsLet _ binds body) = do + body' <- dsLExpr body + dsLocalBinds binds body' + +-- We need the `ListComp' form to use `deListComp' (rather than the "do" form) +-- because the interpretation of `stmts' depends on what sort of thing it is. +-- +dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty +dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts +dsExpr (HsDo res_ty ctx@DoExpr{} (L _ stmts)) = dsDo ctx stmts res_ty +dsExpr (HsDo res_ty ctx@GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts res_ty +dsExpr (HsDo res_ty ctx@MDoExpr{} (L _ stmts)) = dsDo ctx stmts res_ty + +dsExpr (HsIf _ guard_expr then_expr else_expr) + = do { pred <- dsLExpr guard_expr + ; b1 <- dsLExpr then_expr + ; b2 <- dsLExpr else_expr + ; return $ mkIfThenElse pred b1 b2 } + +dsExpr (HsMultiIf res_ty alts) + = do { let grhss = GRHSs emptyComments alts emptyLocalBinds + ; rhss_nablas <- pmcGRHSs IfAlt grhss + ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas + ; error_expr <- mkErrorExpr + ; extractMatchResult match_result error_expr } + where + mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty + (text "multi-way if") + +dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs + +dsExpr (ArithSeq expr witness seq) + = case witness of + Nothing -> dsArithSeq expr seq + Just fl -> do { newArithSeq <- dsArithSeq expr seq + ; dsSyntaxExpr fl [newArithSeq] } + +{- Note [Desugaring static pointers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable +for an overview. + g = ... static f ... +==> + g = ... makeStatic loc f ... +-} + +dsExpr (HsStatic (_, whole_ty) expr@(L loc _)) + = do { expr_ds <- dsLExpr expr + ; let (_, [ty]) = splitTyConApp whole_ty + ; makeStaticId <- dsLookupGlobalId makeStaticName + + ; dflags <- getDynFlags + ; let platform = targetPlatform dflags + (line, col) = case locA loc of + RealSrcSpan r _ -> ( srcLocLine $ realSrcSpanStart r + , srcLocCol $ realSrcSpanStart r ) + _ -> (0, 0) + srcLoc = mkCoreTup [ mkIntExprInt platform line + , mkIntExprInt platform col + ] + + ; putSrcSpanDsA loc $ return $ + mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] } + +{- Note [Desugaring record construction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For record construction we do this (assuming T has three arguments) +\begin{verbatim} + T { op2 = e } +==> + let err = /\a -> recConError a + T (recConError t1 "M.hs/230/op1") + e + (recConError t1 "M.hs/230/op3") +\end{verbatim} +@recConError@ then converts its argument string into a proper message +before printing it as +\begin{verbatim} + M.hs, line 230: missing field op1 was evaluated +\end{verbatim} + +We also handle @C{}@ as valid construction syntax for an unlabelled +constructor @C@, setting all of @C@'s fields to bottom. +-} + +dsExpr (RecordCon { rcon_con = L _ con_like + , rcon_flds = rbinds + , rcon_ext = con_expr }) +-- See Note [Desugaring record construction] + = do { con_expr' <- dsExpr con_expr + ; let + (arg_tys, _) = tcSplitFunTys (exprType con_expr') + -- A newtype in the corner should be opaque; + -- hence TcType.tcSplitFunTys + + mk_arg (arg_ty, fl) + = case findField (rec_flds rbinds) (flSelector fl) of + (rhs:rhss) -> assert (null rhss) + dsLExpr rhs + [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) + unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty + + labels = conLikeFieldLabels con_like + + ; con_args <- if null labels + then mapM unlabelled_bottom (map scaledThing arg_tys) + else mapM mk_arg (zipEqual (map scaledThing arg_tys) labels) + + ; return (mkCoreApps con_expr' con_args) } + + +-- Here is where we desugar the Template Haskell brackets and escapes + +-- Template Haskell stuff +-- See Note [The life cycle of a TH quotation] + +dsExpr (HsTypedBracket bracket_tc _) = dsBracket bracket_tc +dsExpr (HsUntypedBracket bracket_tc _) = dsBracket bracket_tc +dsExpr (HsTypedSplice _ s) = pprPanic "dsExpr:typed splice" (pprTypedSplice Nothing s) +dsExpr (HsUntypedSplice ext _) = dataConCantHappen ext + +-- Arrow notation extension +dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd + +-- HsSyn constructs that just shouldn't be here, because +-- the renamer or typechecker removed them. See GHC.Rename.Expr. +-- Note [Handling overloaded and rebindable constructs] +dsExpr (HsIPVar x _) = dataConCantHappen x +dsExpr (HsGetField x _ _) = dataConCantHappen x +dsExpr (HsProjection x _) = dataConCantHappen x +dsExpr (RecordUpd x _ _) = dataConCantHappen x +dsExpr (HsEmbTy x _) = dataConCantHappen x +dsExpr (HsQual x _ _) = dataConCantHappen x +dsExpr (HsForAll x _ _) = dataConCantHappen x +dsExpr (HsFunArr x _ _ _) = dataConCantHappen x +dsExpr (HsOverLabel x _) = dataConCantHappen x +dsExpr (OpApp x _ _ _) = dataConCantHappen x +dsExpr (SectionL x _ _) = dataConCantHappen x +dsExpr (SectionR x _ _) = dataConCantHappen x + + +{- ********************************************************************* +* * +* Desugaring applications +* * +********************************************************************* -} + +{- Note [Desugaring applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come across an application (f e1 .. en) we collect up +all the desugared arguments, and then dispatch on the function f. +(Including the nullary case where n=0.) + +There are several special cases to handle + +* HsRecSel: a record selector gets warnings if it might fail. +* HsVar: special magic for `noinline` +* HsVar: special magic for `seq` + +Note [Desugaring seq] +~~~~~~~~~~~~~~~~~~~~~ +There are a few subtleties in the desugaring of `seq`, all +implemented in the `seqId` case of `ds_app_var`: + + 1. (as described in #1031) + + Consider, + f x y = x `seq` (y `seq` (# x,y #)) + + Because the argument to the outer 'seq' has an unlifted type, we'll use + call-by-value, and compile it as if we had + + f x y = case (y `seq` (# x,y #)) of v -> x `seq` v + + But that is bad, because we now evaluate y before x! + + Seq is very, very special! So we recognise it right here, and desugar to + case x of _ -> case y of _ -> (# x,y #) + + 2. (as described in #2273) + + Consider + let chp = case b of { True -> fst x; False -> 0 } + in chp `seq` ...chp... + Here the seq is designed to plug the space leak of retaining (snd x) + for too long. + + If we rely on the ordinary inlining of seq, we'll get + let chp = case b of { True -> fst x; False -> 0 } + case chp of _ { I# -> ...chp... } + + But since chp is cheap, and the case is an alluring context, we'll + inline chp into the case scrutinee. Now there is only one use of chp, + so we'll inline a second copy. Alas, we've now ruined the purpose of + the seq, by re-introducing the space leak: + case (case b of {True -> fst x; False -> 0}) of + I# _ -> ...case b of {True -> fst x; False -> 0}... + + We can try to avoid doing this by ensuring that the binder-swap in the + case happens, so we get this at an early stage: + case chp of chp2 { I# -> ...chp2... } + But this is fragile. The real culprit is the source program. Perhaps we + should have said explicitly + let !chp2 = chp in ...chp2... + + But that's painful. So the code here does a little hack to make seq + more robust: a saturated application of 'seq' is turned *directly* into + the case expression, thus: + x `seq` e2 ==> case x of x -> e2 -- Note shadowing! + e1 `seq` e2 ==> case x of _ -> e2 + + So we desugar our example to: + let chp = case b of { True -> fst x; False -> 0 } + case chp of chp { I# -> ...chp... } + And now all is well. + + The reason it's a hack is because if you define mySeq=seq, the hack + won't work on mySeq. + + 3. (as described in #2409) + + The isInternalName ensures that we don't turn + True `seq` e + into + case True of True { ... } + which stupidly tries to bind the datacon 'True'. +-} + +dsApp :: HsExpr GhcTc -> DsM CoreExpr +dsApp e = ds_app e [] [] + +---------------------- +ds_lapp :: LHsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr +-- The [LHsExpr] args correspond to the [CoreExpr] args, +-- but there may be more of the latter because they include +-- type and dictionary arguments +ds_lapp (L loc e) hs_args core_args + = putSrcSpanDsA loc $ + ds_app e hs_args core_args + +ds_app :: HsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr +-- The work-horse +ds_app (HsPar _ e) hs_args core_args = ds_lapp e hs_args core_args + +ds_app (HsApp _ fun arg) hs_args core_args + = do { core_arg <- dsLExpr arg + ; ds_lapp fun (arg : hs_args) (core_arg : core_args) } + +ds_app (HsAppType arg_ty fun _) hs_args core_args + = ds_lapp fun hs_args (Type arg_ty : core_args) + +ds_app (XExpr (WrapExpr hs_wrap fun)) hs_args core_args + = do { (fun_wrap, all_args) <- splitHsWrapperArgs hs_wrap core_args + ; if isIdHsWrapper fun_wrap + then ds_app fun hs_args all_args + else do { core_fun <- dsHsWrapper fun_wrap $ \core_wrap -> + do { core_fun <- dsExpr fun + ; return (core_wrap core_fun) } + ; return (mkCoreApps core_fun all_args) } } + +ds_app (XExpr (ConLikeTc con tvs tys)) _hs_args core_args +-- Desugar desugars 'ConLikeTc': it eta-expands +-- data constructors to make linear types work. +-- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head + = do { ds_con <- dsHsConLike con + ; ids <- newSysLocalsDs tys + -- NB: these 'Id's may be representation-polymorphic; + -- see Wrinkle [Representation-polymorphic lambda] in + -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head. + ; let core_fun = mkLams tvs $ mkLams ids $ + ds_con `mkTyApps` mkTyVarTys tvs + `mkVarApps` ids + ; return (mkApps core_fun core_args) } + +ds_app (XExpr (HsRecSelTc (FieldOcc { foLabel = L _ sel_id }))) _hs_args core_args + = ds_app_rec_sel sel_id sel_id core_args + +ds_app (HsVar _ lfun) hs_args core_args + = ds_app_var lfun hs_args core_args + +ds_app e _hs_args core_args + = do { core_e <- dsExpr e + ; return (mkCoreApps core_e core_args) } + +--------------- +ds_app_var :: LocatedN Id -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr +-- Desugar an application with HsVar at the head +ds_app_var (L loc fun_id) hs_args core_args + + ----------------------- + -- Deal with getField applications. General form: + -- getField + -- @GHC.Types.Symbol {k} + -- @"sel" x_ty + -- @T r_ty + -- @Int a_ty + -- ($dHasField :: HasField "sel" T Int) dict + -- :: T -> Int + -- where + -- $dHasField = sel |> (co :: T -> Int ~R# HasField "sel" T Int) + -- Alas, we cannot simply look at the unfolding of $dHasField below because it + -- has not been set yet, so we have to reconstruct the selector Id from the types. + | fun_id `hasKey` getFieldClassOpKey + = do { -- Look up the field named x/"sel" in the type r/T + fam_inst_envs <- dsGetFamInstEnvs + ; rdr_env <- dsGetGlobalRdrEnv + ; let core_arg_tys :: [Type] = [ty | Type ty <- core_args] + ; case lookupHasFieldLabel fam_inst_envs rdr_env core_arg_tys of + Just (sel_name,_,_,_) + -> do { sel_id <- dsLookupGlobalId sel_name + ; tracePm "getfield2" (ppr sel_id) + ; ds_app_rec_sel sel_id fun_id core_args } + _ -> ds_app_finish fun_id core_args } + + ----------------------- + -- Warn about identities for (fromInteger :: Integer -> Integer) etc + -- They all have a type like: forall . => arg_ty -> res_ty + | idName fun_id `elem` numericConversionNames + , let (conv_ty, _) = apply_invis_args fun_id core_args + , Just (arg_ty, res_ty) <- splitVisibleFunTy_maybe conv_ty + = do { dflags <- getDynFlags + ; when (wopt Opt_WarnIdentities dflags + && arg_ty `eqType` res_ty) $ + -- So we are converting ty -> ty + diagnosticDs (DsIdentitiesFound fun_id conv_ty) + + ; ds_app_finish fun_id core_args } + + ----------------------- + -- Warn about unused return value in + -- do { ...; e; ... } when e returns (say) an Int + | fun_id `hasKey` thenMClassOpKey -- It is the built-in Prelude.(>>) + -- (>>) :: forall m. Monad m => forall a b. m a -> (b->m b) -> m b + , Type m_ty : _dict : Type arg_ty : _ <- core_args + , hs_arg : _ <- hs_args + = do { tracePm ">>" (ppr loc $$ ppr arg_ty $$ ppr (isGeneratedSrcSpan (locA loc))) + ; when (isGeneratedSrcSpan (locA loc)) $ -- It is a compiler-generated (>>) + warnDiscardedDoBindings hs_arg m_ty arg_ty + ; ds_app_finish fun_id core_args } + + ----------------------- + -- Deal with `noinline` + -- See Note [noinlineId magic] in GHC.Types.Id.Make + | fun_id `hasKey` noinlineIdKey + , Type _ : arg1 : rest_args <- core_args + , (inner_fun, inner_args) <- collectArgs arg1 + = return (Var fun_id `App` Type (exprType inner_fun) `App` inner_fun + `mkCoreApps` inner_args `mkCoreApps` rest_args) + + ----------------------- + -- Deal with `seq` + -- See Note [Desugaring seq], points (1) and (2) + | fun_id `hasKey` seqIdKey + , Type _r : Type ty1 : Type ty2 : arg1 : arg2 : rest_args <- core_args + , let case_bndr = case arg1 of + Var v1 | isInternalName (idName v1) + -> v1 -- Note [Desugaring seq], points (2) and (3) + _ -> mkWildValBinder ManyTy ty1 + = return (Case arg1 case_bndr ty2 [Alt DEFAULT [] arg2] + `mkCoreApps` rest_args) + + ----------------------- + -- Phew! No more special cases. Just build an applications + | otherwise + = ds_app_finish fun_id core_args + +--------------- +ds_app_finish :: Id -> [CoreExpr] -> DsM CoreExpr +-- We are about to construct an application that may include evidence applications +-- `f dict`. If the dictionary is non-specialisable, instead construct +-- nospec f dict +-- See Note [nospecId magic] in GHC.Types.Id.Make for what `nospec` does. +-- See Note [Desugaring non-canonical evidence] +ds_app_finish fun_id core_args + = do { mb_unspecables <- getUnspecables + ; let fun_ty = idType fun_id + free_dicts = exprsFreeVarsList + [ e | (e,pi_bndr) <- core_args `zip` fst (splitPiTys fun_ty) + , isInvisibleAnonPiTyBinder pi_bndr ] + + fun | Just unspecables <- mb_unspecables + , not (isEmptyVarSet unspecables) -- Fast path + , any (`elemVarSet` unspecables) free_dicts + = Var nospecId `App` Type fun_ty `App` Var fun_id + | otherwise + = Var fun_id + + ; return (mkCoreApps fun core_args) } + +--------------- +ds_app_rec_sel :: Id -- The record selector Id itself + -> Id -- The function at the the head + -> [CoreExpr] -- Its arguments + -> DsM CoreExpr +-- Desugar an application with HsRecSelId at the head +ds_app_rec_sel sel_id fun_id core_args + | RecSelId{ sel_cons = rec_sel_info } <- idDetails sel_id + , RSI { rsi_undef = cons_wo_field } <- rec_sel_info + = do { -- Record selectors are warned about if they are not present in all of the + -- parent data type's constructors, or always in case of pattern synonym record + -- selectors (regulated by a flag). However, this only produces a warning if + -- it's not a part of a record selector application. For example: + -- data T = T1 | T2 {s :: Bool} + -- g y = map s y -- Warn here + -- f x = s x -- No warning here + ; let (fun_ty, val_args) = apply_invis_args fun_id core_args + + ; tracePm "ds_app_rec_sel" (ppr fun_ty $$ ppr val_args) + ; case val_args of + + -- There is a value argument + -- See (IRS2) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc + (arg:_) -> pmcRecSel sel_id arg + + -- No value argument, but the selector is + -- applied to all its type arguments + -- See (IRS3) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc + [] | Just (val_arg_ty, _) <- splitVisibleFunTy_maybe fun_ty + -> do { dummy <- newSysLocalDs (Scaled ManyTy val_arg_ty) + ; pmcRecSel sel_id (Var dummy) } + + -- Not even applied to all its type args + -- See (IRS4) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc + _ -> unless (null cons_wo_field) $ + do { dflags <- getDynFlags + ; let maxCons = maxUncoveredPatterns dflags + ; diagnosticDs $ DsIncompleteRecordSelector (idName sel_id) cons_wo_field maxCons } + + ; ds_app_finish fun_id core_args } + + | otherwise + = pprPanic "ds_app_rec_sel" (ppr sel_id $$ ppr (idDetails sel_id)) + where + +apply_invis_args :: Id -> [CoreExpr] -> (Type, [CoreExpr]) +-- Apply function to the initial /type/ args; +-- return the type of the instantiated function, +-- and the remaining args +-- e.g. apply_type_args (++) [Type Int, Var xs] +-- = ([Int] -> [Int] -> [Int], [Var xs]) +apply_invis_args fun_id args + = (applyTypeToArgs fun_ty invis_args, rest_args) + where + fun_ty = idType fun_id + (invis_args, rest_args) = splitAt (invisibleBndrCount fun_ty) args + +------------------------------ +splitHsWrapperArgs :: HsWrapper -> [CoreArg] -> DsM (HsWrapper, [CoreArg]) +-- Splits the wrapper into the trailing arguments, and leftover bit +splitHsWrapperArgs wrap args = go wrap args + where + go (WpTyApp ty) args = return (WpHole, Type ty : args) + go (WpEvApp tm) args = do { core_tm <- dsEvTerm tm + ; return (WpHole, core_tm : args)} + go (WpCompose w1 w2) args + = do { (w1', args') <- go w1 args + ; if isIdHsWrapper w1' + then go w2 args' + else return (w1' <.> w2, args') } + go wrap args = return (wrap, args) + +------------------------------ +dsHsConLike :: ConLike -> DsM CoreExpr +dsHsConLike (RealDataCon dc) + = return (varToCoreExpr (dataConWrapId dc)) +dsHsConLike (PatSynCon ps) + | Just (builder_name, _, add_void) <- patSynBuilder ps + = do { builder_id <- dsLookupGlobalId builder_name + ; return (if add_void + then mkCoreApp (text "dsConLike" <+> ppr ps) + (Var builder_id) unboxedUnitExpr + else Var builder_id) } + | otherwise + = pprPanic "dsConLike" (ppr ps) + +------------------------------ +dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr +dsSyntaxExpr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + arg_exprs + = do { fun <- dsExpr expr + ; dsHsWrappers arg_wraps $ \core_arg_wraps -> + dsHsWrapper res_wrap $ \core_res_wrap -> + do { let wrapped_args = zipWithEqual ($) core_arg_wraps arg_exprs + ; return $ core_res_wrap (mkCoreApps fun wrapped_args) } } +dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" + +findField :: [LHsRecField GhcTc arg] -> Name -> [arg] +findField rbinds sel + = [hfbRHS fld | L _ fld <- rbinds + , sel == idName (hsRecFieldId fld) ] + +{- +%-------------------------------------------------------------------- + +Note [Desugaring non-canonical evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When constructing an application + f @ty1 ty2 .. dict1 dict2 .. arg1 arg2 .. +if the evidence `dict_i` is canonical, we simply build that application. +But if any of the `dict_i` are /non-canonical/, we wrap the application +in `nospec`, thus + nospec @fty f @ty1 @ty2 .. dict1 dict2 .. arg1 arg2 .. +where nospec :: forall a. a -> a ensures that the typeclass specialiser +doesn't attempt to common up this evidence term with other evidence terms +of the same type (see Note [nospecId magic] in GHC.Types.Id.Make). + +See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv for +what a "non-canonical" dictionary is, and whe shouldn't specialise on it. + +How do we decide if the arguments are non-canonical dictionaries? + +* In `ds_app_finish` we look for dictionary arguments (invisible value args) + +* In the DsM monad we track the "unspecables" (i.e. non-canonical dictionaries) + in the `dsl_unspecable` field of `DsLclEnv` + +* We extend that unspecable set via `addUnspecables`, in `dsEvBinds`. + A dictionary is non-canonical if its own resolution was incoherent (see + Note [Incoherent instances]), or if its definition refers to other non-canonical + evidence. `dsEvBinds` is the convenient place to compute this, since it already + needs to do inter-evidence dependency analysis to generate well-scoped + bindings. + +Wrinkle: + +(NC1) We don't do this in the LHS of a RULE. In particular, if we have + f :: (Num a, HasCallStack) => a -> a + {-# SPECIALISE f :: Int -> Int #-} + then making a rule like + RULE forall d1:Num Int, d2:HasCallStack. + f @Int d1 d2 = $sf + is pretty dodgy, because $sf won't get the call stack passed in d2. + But that's what you asked for in the SPECIALISE pragma, so we'll obey. + + We definitely can't desugar that LHS into this! + nospec (f @Int d1) d2 + + This is done by zapping the unspecables in `dsRule` to Nothing. That `Nothing` + says not to collect unspecables at all. + + +Note [Desugaring explicit lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Explicit lists are desugared in a cleverer way to prevent some +fruitless allocations. Essentially, whenever we see a list literal +[x_1, ..., x_n] we generate the corresponding expression in terms of +build: + +Explicit lists (literals) are desugared to allow build/foldr fusion when +beneficial. This is a bit of a trade-off, + + * build/foldr fusion can generate far larger code than the corresponding + cons-chain (e.g. see #11707) + + * even when it doesn't produce more code, build can still fail to fuse, + requiring that the simplifier do more work to bring the expression + back into cons-chain form; this costs compile time + + * when it works, fusion can be a significant win. Allocations are reduced + by up to 25% in some nofib programs. Specifically, + + Program Size Allocs Runtime CompTime + rewrite +0.0% -26.3% 0.02 -1.8% + ansi -0.3% -13.8% 0.00 +0.0% + lift +0.0% -8.7% 0.00 -2.3% + +At the moment we use a simple heuristic to determine whether build will be +fruitful: for small lists we assume the benefits of fusion will be worthwhile; +for long lists we assume that the benefits will be outweighed by the cost of +code duplication. This magic length threshold is @maxBuildLength@. Also, fusion +won't work at all if rewrite rules are disabled, so we don't use the build-based +desugaring in this case. + +We used to have a more complex heuristic which would try to break the list into +"static" and "dynamic" parts and only build-desugar the dynamic part. +Unfortunately, determining "static-ness" reliably is a bit tricky and the +heuristic at times produced surprising behavior (see #11710) so it was dropped. +-} + +{- | The longest list length which we will desugar using @build@. + +This is essentially a magic number and its setting is unfortunate rather +arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists], +is to avoid deforesting large static data into large(r) code. Ideally we'd +want a smaller threshold with larger consumers and vice-versa, but we have no +way of knowing what will be consuming our list in the desugaring impossible to +set generally correctly. + +The effect of reducing this number will be that 'build' fusion is applied +less often. From a runtime performance perspective, applying 'build' more +liberally on "moderately" sized lists should rarely hurt and will often it can +only expose further optimization opportunities; if no fusion is possible it will +eventually get rule-rewritten back to a list). We do, however, pay in compile +time. +-} +maxBuildLength :: Int +maxBuildLength = 32 + +dsExplicitList :: Type -> [LHsExpr GhcTc] + -> DsM CoreExpr +-- See Note [Desugaring explicit lists] +dsExplicitList elt_ty xs + = do { dflags <- getDynFlags + ; xs' <- mapM dsLExpr xs + ; if xs' `lengthExceeds` maxBuildLength + -- Don't generate builds if the list is very long. + || null xs' + -- Don't generate builds when the [] constructor will do + || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off + -- Don't generate a build if there are no rules to eliminate it! + -- See Note [Desugaring RULE left hand sides] in GHC.HsToCore + then return $ mkListExpr elt_ty xs' + else mkBuildExpr elt_ty (mk_build_list xs') } + where + mk_build_list xs' (cons, _) (nil, _) + = return (foldr (App . App (Var cons)) (Var nil) xs') + +dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr +dsArithSeq expr (From from) + = App <$> dsExpr expr <*> dsLExpr from +dsArithSeq expr (FromTo from to) + = do fam_envs <- dsGetFamInstEnvs + dflags <- getDynFlags + warnAboutEmptyEnumerations fam_envs dflags from Nothing to + expr' <- dsExpr expr + from' <- dsLExpr from + to' <- dsLExpr to + return $ mkApps expr' [from', to'] +dsArithSeq expr (FromThen from thn) + = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] +dsArithSeq expr (FromThenTo from thn to) + = do fam_envs <- dsGetFamInstEnvs + dflags <- getDynFlags + warnAboutEmptyEnumerations fam_envs dflags from (Just thn) to + expr' <- dsExpr expr + from' <- dsLExpr from + thn' <- dsLExpr thn + to' <- dsLExpr to + return $ mkApps expr' [from', thn', to'] + +{- +Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're +handled in GHC.HsToCore.ListComp). Basically does the translation given in the +Haskell 98 report: +-} + +dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr +-- This code path seems inactive for regular Do, +-- which is expanded in GHC.Tc.Gen.Do. +-- It is used only for ApplicativeDo (even the BindStmt case), which is *very* +-- annoying because it is a lot of duplicated code that is seldomly tested. +-- But we are on course to expane Applicative in GHC.Tc.Gen.Do, at which +-- point all this will go away +dsDo ctx stmts res_ty + = goL stmts + where + goL [] = panic "dsDo" + goL ((L loc stmt):lstmts) = putSrcSpanDsA loc (go loc stmt lstmts) + + go _ (LastStmt _ body _ _) stmts + = assert (null stmts ) dsLExpr body + -- The 'return' op isn't used for 'do' expressions + + go _ (BodyStmt _ rhs then_expr _) stmts + = do { rhs2 <- dsLExpr rhs + ; case tcSplitAppTy_maybe (exprType rhs2) of + Just (m_ty, elt_ty) -> warnDiscardedDoBindings rhs m_ty elt_ty + Nothing -> return () -- Odd, but not warning + ; rest <- goL stmts + ; dsSyntaxExpr then_expr [rhs2, rest] } + + go _ (LetStmt _ binds) stmts + = do { rest <- goL stmts + ; dsLocalBinds binds rest } + + go _ (BindStmt xbs pat rhs) stmts + -- SG: As far as I can tell, this code path is only triggered when ApplicativeDo fails, e.g. + -- do blah <- action1; action2 (blah * 2) + -- It is reached when compiling GHC.Parser.PostProcess.Haddock.addHaddockToModule + = do { var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat + ; rhs' <- dsLExpr rhs + ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat + (xbstc_boundResultType xbs) (MR_Infallible $ goL stmts) + -- NB: "goL stmts" needs to happen inside matchSinglePatVar, and not + -- before it, so that long-distance information is properly threaded. + -- See Note [Long-distance information in do notation]. + ; match_code <- dsHandleMonadicFailure ctx pat res_ty match (xbstc_failOp xbs) + ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] } + + go loc (RecStmt { recS_stmts = L _ rec_stmts, recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_ret_fn = return_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op + , recS_ext = RecStmtTc + { recS_bind_ty = bind_ty + , recS_rec_rets = rec_rets + , recS_ret_ty = body_ty} }) stmts + = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } + where + new_bind_stmt = L loc $ BindStmt + XBindStmtTc + { xbstc_bindOp = bind_op + , xbstc_boundResultType = bind_ty + , xbstc_boundResultMult = ManyTy + , xbstc_failOp = Nothing -- Tuple cannot fail + } + (mkBigLHsPatTupId later_pats) + mfix_app + + tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids + tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case + rec_tup_pats = map nlVarPat tup_ids + later_pats = rec_tup_pats + rets = map noLocA rec_rets + mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] + match_group = MatchGroupTc [unrestricted tup_ty] body_ty (Generated OtherExpansion SkipPmc) + mfix_arg = noLocA $ HsLam noAnn LamSingle + (MG { mg_alts = noLocA [mkSimpleMatch + (LamAlt LamSingle) + (noLocA [mfix_pat]) body] + , mg_ext = match_group + }) + mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats + body = noLocA $ HsDo body_ty + ctx (noLocA (rec_stmts ++ [ret_stmt])) + ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] + ret_stmt = noLocA $ mkLastStmt ret_app + -- This LastStmt will be desugared with dsDo, + -- which ignores the return_op in the LastStmt, + -- so we must apply the return_op explicitly + + go _ (XStmtLR (ApplicativeStmt body_ty args mb_join)) stmts + = do { + let + (pats, rhss) = unzip (map (do_arg . snd) args) + + do_arg (ApplicativeArgOne fail_op pat expr _) = + ((pat, fail_op), dsLExpr expr) + do_arg (ApplicativeArgMany _ stmts ret pat _) = + ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)]) res_ty) + + ; rhss' <- sequence rhss + + ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts) + + ; let match_args (pat, fail_op) (vs,body) + = putSrcSpanDs (getLocA pat) $ + do { var <- selectSimpleMatchVarL ManyTy pat + ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat + body_ty (cantFailMatchResult body) + ; match_code <- dsHandleMonadicFailure ctx pat body_ty match fail_op + ; return (var:vs, match_code) + } + + ; (vars, body) <- foldrM match_args ([],body') pats + ; let fun' = mkLams vars body + ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] + ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') + ; case mb_join of + Nothing -> return expr + Just join_op -> dsSyntaxExpr join_op [expr] } + + go _ (ParStmt {}) _ = panic "dsDo ParStmt" + go _ (TransStmt {}) _ = panic "dsDo TransStmt" + +{- Note [Long-distance information in do notation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider T21360: + + data Foo = A Int | B + + swooble :: Foo -> Maybe Foo + swooble foo = do + bar@A{} <- Just foo + return $ case bar of { A _ -> A 9 } + +The pattern-match checker **should not** complain that the case statement +is incomplete, because we know that 'bar' is headed by the constructor 'A', +due to the pattern match in the line above. However, we need to ensure that we +propagate this long-distance information; failing to do so lead to #21360. + +To do this, we use "matchSinglePatVar" to handle the first pattern match + + bar@A{} <- Just foo + +"matchSinglePatVar" then threads through the long-distance information to the +desugaring of the remaining statements by using updPmNablasMatchResult. +This avoids any spurious pattern-match warnings when handling the case +statement on the last line. + +Other places that requires from the same treatment: + + - monad comprehensions, e.g. + + blorble :: Foo -> Maybe Foo + blorble foo = [ case bar of { A _ -> A 9 } | bar@A{} <- Just foo ] + + See GHC.HsToCore.ListComp.dsMcBindStmt. Also tested in T21360. + + - guards, e.g. + + giddy :: Maybe Char -> Char + giddy x + | y@(Just _) <- x + , let z = case y of { Just w -> w } + = z + + We don't want any inexhaustive pattern match warnings for the case statement, + because we already know 'y' is of the form "Just ...". + See test case T21360b. + + +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ +-} + +-- Warn about certain types of values discarded in monadic bindings (#3263) +warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> Type -> DsM () +warnDiscardedDoBindings rhs m_ty elt_ty + = do { warn_unused <- woptM Opt_WarnUnusedDoBind + ; warn_wrong <- woptM Opt_WarnWrongDoBind + ; when (warn_unused || warn_wrong) $ + do { fam_inst_envs <- dsGetFamInstEnvs + ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty + supressible_ty = + isUnitTy norm_elt_ty || isAnyTy norm_elt_ty || isZonkAnyTy norm_elt_ty + -- Warn about discarding things in 'monadic' binding, + -- however few types are excluded: + -- * Unit type `()` + -- * `ZonkAny` or `Any` type see (Any8) of Note [Any types] + ; if warn_unused && not supressible_ty + then diagnosticDs (DsUnusedDoBind rhs elt_ty) + else + + -- Warn about discarding m a things in 'monadic' binding of the same type, + -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + -- Example: do { return 3; blah } + -- We get (>>) @m d @(m Int) (return 3) blah + when warn_wrong $ + case tcSplitAppTy_maybe norm_elt_ty of + Just (elt_m_ty, _) + | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty + -> diagnosticDs (DsWrongDoBind rhs elt_ty) + _ -> return () } } diff --git a/GHC/HsToCore/Expr.hs-boot b/GHC/HsToCore/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Expr.hs-boot @@ -0,0 +1,10 @@ +module GHC.HsToCore.Expr where +import GHC.Hs ( HsExpr, LHsExpr, HsLocalBinds, SyntaxExpr ) +import GHC.HsToCore.Monad ( DsM ) +import GHC.Core ( CoreExpr ) +import GHC.Hs.Extension ( GhcTc) + +dsExpr :: HsExpr GhcTc -> DsM CoreExpr +dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr +dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr +dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr diff --git a/GHC/HsToCore/Foreign/C.hs b/GHC/HsToCore/Foreign/C.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/C.hs @@ -0,0 +1,598 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handling of C foreign imports/exports +module GHC.HsToCore.Foreign.C + ( dsCImport + , dsCFExport + , dsCFExportDynamic + ) +where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Tc.Utils.Monad -- temp +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType + +import GHC.Core +import GHC.Core.Unfold.Make +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Multiplicity + +import GHC.HsToCore.Foreign.Call +import GHC.HsToCore.Foreign.Prim +import GHC.HsToCore.Foreign.Utils +import GHC.HsToCore.Monad +import GHC.HsToCore.Types (ds_next_wrapper_num) + +import GHC.Hs + +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Types.ForeignStubs +import GHC.Types.SourceText +import GHC.Types.Name +import GHC.Types.RepType +import GHC.Types.ForeignCall +import GHC.Types.Basic + +import GHC.Unit.Module + +import GHC.Driver.DynFlags +import GHC.Driver.Config + +import GHC.Cmm.Expr +import GHC.Cmm.Utils + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names + +import GHC.Data.FastString + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Encoding + +import Data.Maybe +import Data.List (nub) + +dsCFExport:: Id -- Either the exported Id, + -- or the foreign-export-dynamic constructor + -> Coercion -- Coercion between the Haskell type callable + -- from C, and its representation type + -> CLabelString -- The name to export to C land + -> CCallConv + -> Bool -- True => foreign export dynamic + -- so invoke IO action that's hanging off + -- the first argument's stable pointer + -> DsM ( CHeader -- contents of Module_stub.h + , CStub -- contents of Module_stub.c + , String -- string describing type to pass to createAdj. + ) + +dsCFExport fn_id co ext_name cconv isDyn = do + let + ty = coercionRKind co + (bndrs, orig_res_ty) = tcSplitPiTys ty + fe_arg_tys' = mapMaybe anonPiTyBinderType_maybe bndrs + -- We must use tcSplits here, because we want to see + -- the (IO t) in the corner of the type! + fe_arg_tys | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' + + -- Look at the result type of the exported function, orig_res_ty + -- If it's IO t, return (t, True) + -- If it's plain t, return (t, False) + (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of + -- The function already returns IO t + Just (_ioTyCon, res_ty) -> (res_ty, True) + -- The function returns t + Nothing -> (orig_res_ty, False) + + dflags <- getDynFlags + return $ + mkFExportCBits dflags ext_name + (if isDyn then Nothing else Just fn_id) + fe_arg_tys res_ty is_IO_res_ty cconv + +dsCImport :: Id + -> Coercion + -> CImportSpec + -> CCallConv + -> Safety + -> Maybe Header + -> DsM ([Binding], CHeader, CStub) +dsCImport id co (CLabel cid) _ _ _ = do + let ty = coercionLKind co + fod = case tyConAppTyCon_maybe (dropForAlls ty) of + Just tycon + | tyConUnique tycon == funPtrTyConKey -> + IsFunction + _ -> IsData + (resTy, foRhs) <- resultWrapper ty + assert (fromJust resTy `eqType` addrPrimTy) $ -- typechecker ensures this + let + rhs = foRhs (Lit (LitLabel cid fod)) + rhs' = Cast rhs co + in + return ([(id, rhs')], mempty, mempty) + +dsCImport id co (CFunction target) cconv@PrimCallConv safety _ + = dsPrimCall id co (CCall (CCallSpec target cconv safety)) +dsCImport id co (CFunction target) cconv safety mHeader + = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader +dsCImport id co CWrapper cconv _ _ + = dsCFExportDynamic id co cconv + + +{- +@foreign import "wrapper"@ (previously "foreign export dynamic") lets +you dress up Haskell IO actions of some fixed type behind an +externally callable interface (i.e., as a C function pointer). Useful +for callbacks and stuff. + +\begin{verbatim} +type Fun = Bool -> Int -> IO Int +foreign import "wrapper" f :: Fun -> IO (FunPtr Fun) + +-- Haskell-visible constructor, which is generated from the above: +-- SUP: No check for NULL from createAdjustor anymore??? + +f :: Fun -> IO (FunPtr Fun) +f cback = + bindIO (newStablePtr cback) + (\StablePtr sp# -> IO (\s1# -> + case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of + (# s2#, a# #) -> (# s2#, A# a# #))) + +foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) + +-- and the helper in C: (approximately; see `mkFExportCBits` below) + +f_helper(StablePtr s, HsBool b, HsInt i) +{ + Capability *cap; + cap = rts_lock(); + rts_inCall(&cap, + rts_apply(rts_apply(deRefStablePtr(s), + rts_mkBool(b)), rts_mkInt(i))); + rts_unlock(cap); +} +\end{verbatim} +-} +dsCFExportDynamic :: Id + -> Coercion + -> CCallConv + -> DsM ([Binding], CHeader, CStub) +dsCFExportDynamic id co0 cconv = do + mod <- getModule + let fe_nm = mkFastString $ zEncodeString + (moduleStableString mod ++ "$" ++ toCName id) + -- Construct the label based on the passed id, don't use names + -- depending on Unique. See #13807 and Note [Unique Determinism]. + cback <- newSysLocalDs scaled_arg_ty + newStablePtrId <- dsLookupGlobalId newStablePtrName + stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName + let + stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] + export_ty = mkVisFunTyMany stable_ptr_ty arg_ty + bindIOId <- dsLookupGlobalId bindIOName + stbl_value <- newSysLocalMDs stable_ptr_ty + (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True + let + {- + The arguments to the external function which will + create a little bit of (template) code on the fly + for allowing the (stable pointed) Haskell closure + to be entered using an external calling convention + (ccall). + -} + adj_args = [ Var stbl_value + , Lit (LitLabel fe_nm IsFunction) + , Lit (mkLitString typestring) + ] + -- name of external entry point providing these services. + -- (probably in the RTS.) + adjustor = fsLit "createAdjustor" + + ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) + -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback + + let io_app = mkLams tvs $ + Lam cback $ + mkApps (Var bindIOId) + [ Type stable_ptr_ty + , Type res_ty + , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] + , Lam stbl_value ccall_adj + ] + + fed = (id `setInlineActivation` NeverActive, Cast io_app co0) + -- Never inline the f.e.d. function, because the litlit + -- might not be in scope in other modules. + + return ([fed], h_code, c_code) + + where + ty = coercionLKind co0 + (tvs,sans_foralls) = tcSplitForAllInvisTyVars ty + ([scaled_arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls + arg_ty = scaledThing scaled_arg_ty + Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty + -- Must have an IO type; hence Just + + +-- | Foreign calls +dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header + -> DsM ([(Id, Expr TyVar)], CHeader, CStub) +dsFCall fn_id co fcall mDeclHeader = do + let + (ty,ty1) = (coercionLKind co, coercionRKind co) + (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty + (arg_tys, io_res_ty) = tcSplitFunTys rho + + let constQual -- provide 'const' qualifier (#22043) + | (_, res_ty1) <- tcSplitFunTys ty1 + , newty <- maybe res_ty1 snd (tcSplitIOType_maybe res_ty1) + , Just (ptr, _) <- splitTyConApp_maybe newty + , tyConName ptr == constPtrConName + = text "const" + | otherwise = empty + + args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism + (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) + + let + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + + (ccall_result_ty, res_wrapper) <- boxResult io_res_ty + + ccall_uniq <- newUnique + work_uniq <- newUnique + + (fcall', cDoc) <- + case fcall of + CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) + CApiConv safety) -> + do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv + wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName) + let fcall' = CCall (CCallSpec + (StaticTarget NoSourceText + wrapperName mUnitId + True) + CApiConv safety) + c = includes + $$ fun_proto <+> braces (cRet <> semi) + includes = vcat [ text "#include \"" <> ftext h + <> text "\"" + | Header _ h <- nub headers ] + fun_proto = constQual <+> cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes + cRet + | isVoidRes = cCall + | otherwise = text "return" <+> cCall + cCall + | isFun = ppr cName <> parens argVals + | null arg_tys = ppr cName + | otherwise = panic "dsFCall: Unexpected arguments to FFI value import" + raw_res_ty = case tcSplitIOType_maybe io_res_ty of + Just (_ioTyCon, res_ty) -> res_ty + Nothing -> io_res_ty + isVoidRes = raw_res_ty `eqType` unitTy + (mHeader, cResType) + | isVoidRes = (Nothing, text "void") + | otherwise = toCType raw_res_ty + pprCconv = ccallConvAttribute CApiConv + mHeadersArgTypeList + = [ (header, cType <+> char 'a' <> int n) + | (t, n) <- zip arg_tys [1..] + , let (header, cType) = toCType (scaledThing t) ] + (mHeaders, argTypeList) = unzip mHeadersArgTypeList + argTypes = if null argTypeList + then text "void" + else hsep $ punctuate comma argTypeList + mHeaders' = mDeclHeader : mHeader : mHeaders + headers = catMaybes mHeaders' + argVals = hsep $ punctuate comma + [ char 'a' <> int n + | (_, n) <- zip arg_tys [1..] ] + return (fcall', c) + _ -> + return (fcall, empty) + dflags <- getDynFlags + let + -- Build the worker + worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) + tvs = map binderVar tv_bndrs + the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty + work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) + work_id = mkSysLocal (fsLit "$wccall") work_uniq ManyTy worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers + wrap_rhs = mkLams (tvs ++ args) wrapper_body + wrap_rhs' = Cast wrap_rhs co + simpl_opts = initSimpleOpts dflags + fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts + StableSystemSrc (length args) + wrap_rhs' + + return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] []) + + +toCName :: Id -> String +toCName i = showSDocOneLine defaultSDocContext (pprCode (ppr (idName i))) + +toCType :: Type -> (Maybe Header, SDoc) +toCType = f False + where f voidOK t + -- First, if we have (Ptr t) of (FunPtr t), then we need to + -- convert t to a C type and put a * after it. If we don't + -- know a type for t, then "void" is fine, though. + | Just (ptr, [t']) <- splitTyConApp_maybe t + , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] + = case f True t' of + (mh, cType') -> + (mh, cType' <> char '*') + -- Otherwise, if we have a type constructor application, then + -- see if there is a C type associated with that constructor. + -- Note that we aren't looking through type synonyms or + -- anything, as it may be the synonym that is annotated. + | Just tycon <- tyConAppTyConPicky_maybe t + , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon + = (mHeader, ftext cType) + -- If we don't know a C type for this type, then try looking + -- through one layer of type synonym etc. + | Just t' <- coreView t + = f voidOK t' + -- Handle 'UnliftedFFITypes' argument + | Just tyCon <- tyConAppTyConPicky_maybe t + , isPrimTyCon tyCon + , Just cType <- ppPrimTyConStgType tyCon + = (Nothing, text cType) + + -- Otherwise we don't know the C type. If we are allowing + -- void then return that; otherwise something has gone wrong. + | voidOK = (Nothing, text "void") + | otherwise + = pprPanic "toCType" (ppr t) + +{- +* + +\subsection{Generating @foreign export@ stubs} + +* + +For each @foreign export@ function, a C stub function is generated. +The C stub constructs the application of the exported Haskell function +using the hugs/ghc rts invocation API. +-} + +mkFExportCBits :: DynFlags + -> FastString + -> Maybe Id -- Just==static, Nothing==dynamic + -> [Type] + -> Type + -> Bool -- True <=> returns an IO type + -> CCallConv + -> (CHeader, + CStub, + String -- the argument reps + ) +mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc + = + ( header_bits + , CStub body [] [] + , type_string + ) + where + platform = targetPlatform dflags + + -- list the arguments to the C function + arg_info :: [(SDoc, -- arg name + SDoc, -- C type + Type, -- Haskell type + CmmType)] -- the CmmType + arg_info = [ let stg_type = showStgType ty in + (arg_cname n stg_type, + stg_type, + ty, + typeCmmType platform (getPrimTyOf ty)) + | (ty,n) <- zip arg_htys [1::Int ..] ] + + arg_cname n stg_ty + | libffi = char '*' <> parens (stg_ty <> char '*') <> + text "args" <> brackets (int (n-1)) + | otherwise = char 'a' <> int n + + -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled + libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target + + type_string + -- libffi needs to know the result type too: + | libffi = primTyDescChar platform res_hty : arg_type_string + | otherwise = arg_type_string + + arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info] + -- just the real args + + -- add some auxiliary args; the stable ptr in the wrapper case, and + -- a slot for the dummy return address in the wrapper + ccall case + aug_arg_info + | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info + | otherwise = arg_info + + stable_ptr_arg = + (text "the_stableptr", text "StgStablePtr", undefined, + typeCmmType platform (mkStablePtrPrimTy alphaTy)) + + -- stuff to do with the return type of the C function + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes + + cResType | res_hty_is_unit = text "void" + | otherwise = showStgType res_hty + + -- when the return type is integral and word-sized or smaller, it + -- must be assigned as type ffi_arg (#3516). To see what type + -- libffi is expecting here, take a look in its own testsuite, e.g. + -- libffi/testsuite/libffi.call/cls_align_ulonglong.c + ffi_cResType + | is_ffi_arg_type = text "ffi_arg" + | otherwise = cResType + where + res_ty_key = getUnique (getName (typeTyCon res_hty)) + is_ffi_arg_type = res_ty_key `notElem` + [floatTyConKey, doubleTyConKey, + int64TyConKey, word64TyConKey] + + -- Now we can cook up the prototype for the exported function. + pprCconv = ccallConvAttribute cc + + header_bits = CHeader (text "extern" <+> fun_proto <> semi) + + fun_args + | null aug_arg_info = text "void" + | otherwise = hsep $ punctuate comma + $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info + + fun_proto + | libffi + = text "void" <+> ftext c_nm <> + parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr") + | otherwise + = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args + + -- the target which will form the root of what we ask rts_inCall to run + the_cfun + = case maybe_target of + Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" + Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure" + + cap = text "cap" <> comma + + -- the expression we give to rts_inCall + expr_to_run + = foldl' appArg the_cfun arg_info -- NOT aug_arg_info + where + appArg acc (arg_cname, _, arg_hty, _) + = text "rts_apply" + <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname)) + + -- various other bits for inside the fn + declareResult = text "HaskellObj ret;" + declareCResult | res_hty_is_unit = empty + | otherwise = cResType <+> text "cret;" + + assignCResult | res_hty_is_unit = empty + | otherwise = + text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi + + -- an extern decl for the fn being called + extern_decl + = case maybe_target of + Nothing -> empty + Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi + + + -- finally, the whole darn thing + body = + space $$ + extern_decl $$ + fun_proto $$ + vcat + [ lbrace + , text "Capability *cap;" + , declareResult + , declareCResult + , text "cap = rts_lock();" + -- create the application + perform it. + , text "rts_inCall" <> parens ( + char '&' <> cap <> + text "rts_apply" <> parens ( + cap + <> (if is_IO_res_ty + then text "ghc_hs_iface->runIO_closure" + else text "ghc_hs_iface->runNonIO_closure") + <> comma + <> expr_to_run + ) <+> comma + <> text "&ret" + ) <> semi + , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) + <> comma <> text "cap") <> semi + , assignCResult + , text "rts_unlock(cap);" + , ppUnless res_hty_is_unit $ + if libffi + then char '*' <> parens (ffi_cResType <> char '*') <> + text "resp = " <> parens ffi_cResType <> text "cret;" + else text "return cret;" + , rbrace + ] + +mkHObj :: Type -> SDoc +mkHObj t = text "rts_mk" <> showFFIType t + +unpackHObj :: Type -> SDoc +unpackHObj t = text "rts_get" <> showFFIType t + +showStgType :: Type -> SDoc +showStgType t = text "Hs" <> showFFIType t + +showFFIType :: Type -> SDoc +showFFIType t = ftext (occNameFS (getOccName (typeTyCon t))) + +typeTyCon :: Type -> TyCon +typeTyCon ty + | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) + = tc + | otherwise + = pprPanic "GHC.HsToCore.Foreign.C.typeTyCon" (ppr ty) + + +insertRetAddr :: Platform -> CCallConv + -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] +insertRetAddr platform CCallConv args + = case platformArch platform of + ArchX86_64 + | platformOS platform == OSMinGW32 -> + -- On other Windows x86_64 we insert the return address + -- after the 4th argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 4 args = ret_addr_arg platform : args + go n (arg:args) = arg : go (n+1) args + go _ [] = [] + in go 0 args + | otherwise -> + -- On other x86_64 platforms we insert the return address + -- after the 6th integer argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 6 args = ret_addr_arg platform : args + go n (arg@(_,_,_,rep):args) + -- Int type fitting into int register + | (isBitsType rep && typeWidth rep <= W64 || isGcPtrType rep) + = arg : go (n+1) args + | otherwise + = arg : go n args + go _ [] = [] + in go 0 args + _ -> + ret_addr_arg platform : args +insertRetAddr _ _ args = args + +ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType) +ret_addr_arg platform = (text "original_return_addr", text "void*", undefined, + typeCmmType platform addrPrimTy) diff --git a/GHC/HsToCore/Foreign/Call.hs b/GHC/HsToCore/Foreign/Call.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/Call.hs @@ -0,0 +1,358 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +Desugaring foreign calls +-} + + + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Foreign.Call + ( dsCCall + , mkFCall + , unboxArg + , boxResult + , resultWrapper + ) +where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.Coercion +import GHC.Core.TyCon +import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped ) + +import GHC.HsToCore.Monad +import GHC.HsToCore.Utils + +import GHC.Types.SourceText +import GHC.Types.Id.Make +import GHC.Types.ForeignCall +import GHC.Types.Basic +import GHC.Types.Literal +import GHC.Types.RepType (typePrimRep1) + +import GHC.Tc.Utils.TcType + +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Builtin.Names + +import GHC.Driver.DynFlags + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Maybe + +{- +Desugaring of @ccall@s consists of adding some state manipulation, +unboxing any boxed primitive arguments and boxing the result if +desired. + +The state stuff just consists of adding in +@PrimIO (\ s -> case s of { State# s# -> ... })@ in an appropriate place. + +The unboxing is straightforward, as all information needed to unbox is +available from the type. For each boxed-primitive argument, we +transform: +\begin{verbatim} + _ccall_ foo [ r, t1, ... tm ] e1 ... em + | + | + V + case e1 of { T1# x1# -> + ... + case em of { Tm# xm# -> xm# + ccall# foo [ r, t1#, ... tm# ] x1# ... xm# + } ... } +\end{verbatim} + +The reboxing of a @_ccall_@ result is a bit tricker: the types don't +contain information about the state-pairing functions so we have to +keep a list of \tr{(type, s-p-function)} pairs. We transform as +follows: +\begin{verbatim} + ccall# foo [ r, t1#, ... tm# ] e1# ... em# + | + | + V + \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of + (StateAnd# result# state#) -> (R# result#, realWorld#) +\end{verbatim} +-} + +dsCCall :: CLabelString -- C routine to invoke + -> [CoreExpr] -- Arguments (desugared) + -- Precondition: none have representation-polymorphic types + -> Safety -- Safety of the call + -> Type -- Type of the result: IO t + -> DsM CoreExpr -- Result, of type ??? + +dsCCall lbl args may_gc result_ty + = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args + (ccall_result_ty, res_wrapper) <- boxResult result_ty + uniq <- newUnique + let + target = StaticTarget NoSourceText lbl Nothing True + the_fcall = CCall (CCallSpec target CCallConv may_gc) + the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty + return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) + +mkFCall :: Unique -> ForeignCall + -> [CoreExpr] -- Args + -> Type -- Result type + -> CoreExpr +-- Construct the ccall. The only tricky bit is that the ccall Id should have +-- no free vars, so if any of the arg tys do we must give it a polymorphic type. +-- [I forget *why* it should have no free vars!] +-- For example: +-- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char] +-- +-- Here we build a ccall thus +-- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) +-- a b s x c +mkFCall uniq the_fcall val_args res_ty + = assert (all isTyVar tyvars) $ -- this must be true because the type is top-level + mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args + where + arg_tys = map exprType val_args + body_ty = (mkVisFunTysMany arg_tys res_ty) + tyvars = tyCoVarsOfTypeWellScoped body_ty + ty = mkInfForAllTys tyvars body_ty + the_fcall_id = mkFCallId uniq the_fcall ty + +unboxArg :: CoreExpr -- The supplied argument, not representation-polymorphic + -> DsM (CoreExpr, -- To pass as the actual argument + CoreExpr -> CoreExpr -- Wrapper to unbox the arg + ) +-- Example: if the arg is e::Int, unboxArg will return +-- (x#::Int#, \W. case x of I# x# -> W) +-- where W is a CoreExpr that probably mentions x# + +-- always returns a non-representation-polymorphic expression + +unboxArg arg + -- Primitive types: nothing to unbox + | isPrimitiveType arg_ty || + -- Same for (# #) + (isUnboxedTupleType arg_ty && typePrimRep1 arg_ty == VoidRep) + = return (arg, \body -> body) + + -- Possibly-recursive newtypes + | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty + = unboxArg (mkCastDs arg co) + + -- Booleans + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` boolTyConKey + = do dflags <- getDynFlags + let platform = targetPlatform dflags + prim_arg <- newSysLocalMDs intPrimTy + return (Var prim_arg, + \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0)) + prim_arg + (exprType body) + [Alt DEFAULT [] body]) + + -- Data types with a single constructor, which has a single, primitive-typed arg + -- This deals with Int, Float etc; also Ptr, ForeignPtr + | is_product_type && data_con_arity == 1 + = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $ + -- Typechecker ensures this + do case_bndr <- newSysLocalMDs arg_ty + prim_arg <- newSysLocalMDs data_con_arg_ty1 + return (Var prim_arg, + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body] + ) + + -- Byte-arrays, both mutable and otherwise; hack warning + -- We're looking for values of type ByteArray, MutableByteArray + -- data ByteArray ix = ByteArray ix ix ByteArray# + -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) + | is_product_type && + data_con_arity == 3, + Just arg3_tycon <- maybe_arg3_tycon, + (arg3_tycon == byteArrayPrimTyCon || + arg3_tycon == mutableByteArrayPrimTyCon) + = do case_bndr <- newSysLocalMDs arg_ty + vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys) + return (Var arr_cts_var, + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body] + ) + + | otherwise + = do l <- getSrcSpanDs + pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) + where + arg_ty = exprType arg + maybe_product_type = splitDataProductType_maybe arg_ty + is_product_type = isJust maybe_product_type + Just (_, _, data_con, scaled_data_con_arg_tys) = maybe_product_type + data_con_arg_tys = map scaledThing scaled_data_con_arg_tys + data_con_arity = dataConSourceArity data_con + (data_con_arg_ty1 : _) = data_con_arg_tys + + (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys + maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3 + +boxResult :: Type + -> DsM (Type, CoreExpr -> CoreExpr) + +-- Takes the result of the user-level ccall: +-- either (IO t), +-- or maybe just t for a side-effect-free call +-- Returns a wrapper for the primitive ccall itself, along with the +-- type of the result of the primitive ccall. This result type +-- will be of the form +-- State# RealWorld -> (# State# RealWorld, t' #) +-- where t' is the unwrapped form of t. If t is simply (), then +-- the result type will be +-- State# RealWorld -> (# State# RealWorld #) + +boxResult result_ty + | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty + -- isIOType_maybe handles the case where the type is a + -- simple wrapping of IO. E.g. + -- newtype Wrap a = W (IO a) + -- No coercion necessary because its a non-recursive newtype + -- (If we wanted to handle a *recursive* newtype too, we'd need + -- another case, and a coercion.) + -- The result is IO t, so wrap the result in an IO constructor + = do { res <- resultWrapper io_res_ty + ; let return_result state anss = mkCoreUnboxedTuple [state, anss] + + ; (ccall_res_ty, the_alt) <- mk_alt return_result res + + ; state_id <- newSysLocalMDs realWorldStatePrimTy + ; let io_data_con = head (tyConDataCons io_tycon) + toIOCon = dataConWrapId io_data_con + + wrap the_call = + mkApps (Var toIOCon) + [ Type io_res_ty, + Lam state_id $ + mkWildCase (App the_call (Var state_id)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + ] + + ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) } + +boxResult result_ty + = do -- It isn't IO, so do unsafePerformIO + -- It's not conveniently available, so we inline it + res <- resultWrapper result_ty + (ccall_res_ty, the_alt) <- mk_alt return_result res + let + wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) + where + return_result _ ans = ans + + +mk_alt :: (Expr Var -> Expr Var -> Expr Var) + -> (Maybe Type, Expr Var -> Expr Var) + -> DsM (Type, CoreAlt) +mk_alt return_result (Nothing, wrap_result) + = do -- The ccall returns () + state_id <- newSysLocalMDs realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + (wrap_result (panic "boxResult")) + + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] + the_alt = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs + + return (ccall_res_ty, the_alt) + +mk_alt return_result (Just prim_res_ty, wrap_result) + = -- The ccall returns a non-() value + assertPpr (isPrimitiveType prim_res_ty) (ppr prim_res_ty) $ + -- True because resultWrapper ensures it is so + do { result_id <- newSysLocalMDs prim_res_ty + ; state_id <- newSysLocalMDs realWorldStatePrimTy + ; let the_rhs = return_result (Var state_id) + (wrap_result (Var result_id)) + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] + the_alt = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs + ; return (ccall_res_ty, the_alt) } + + +resultWrapper :: Type + -> DsM (Maybe Type, -- Type of the expected result, if any + CoreExpr -> CoreExpr) -- Wrapper for the result +-- resultWrapper deals with the result *value* +-- E.g. foreign import foo :: Int -> IO T +-- Then resultWrapper deals with marshalling the 'T' part +-- So if resultWrapper ty = (Just ty_rep, marshal) +-- then marshal (e :: ty_rep) :: ty +-- That is, 'marshal' wrape the result returned by the foreign call, +-- of type ty_rep, into the value Haskell expected, of type 'ty' +-- +-- Invariant: ty_rep is always a primitive type +-- i.e. (isPrimitiveType ty_rep) is True + +resultWrapper result_ty + -- Base case 1: primitive types + | isPrimitiveType result_ty + = return (Just result_ty, \e -> e) + + -- Base case 2: the unit type () + | Just (tc,_) <- maybe_tc_app + , tc `hasKey` unitTyConKey + = return (Nothing, \_ -> unitExpr) + + -- Base case 3: the boolean type + | Just (tc,_) <- maybe_tc_app + , tc `hasKey` boolTyConKey + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; let marshal_bool e + = mkWildCase e (unrestricted intPrimTy) boolTy + [ Alt DEFAULT [] (Var trueDataConId ) + , Alt (LitAlt (mkLitInt platform 0)) [] (Var falseDataConId)] + ; return (Just intPrimTy, marshal_bool) } + + -- Newtypes + | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty + = do { (maybe_ty, wrapper) <- resultWrapper rep_ty + ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) } + + -- The type might contain foralls (eg. for dummy type arguments, + -- referring to 'Ptr a' is legal). + | Just (tyvar, rest) <- splitForAllTyCoVar_maybe result_ty + = do { (maybe_ty, wrapper) <- resultWrapper rest + ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) } + + -- Data types with a single constructor, which has a single arg + -- This includes types like Ptr and ForeignPtr + | Just (tycon, tycon_arg_tys) <- maybe_tc_app + , not (isNewTyCon tycon) -- Newtypes should have been dealt with above, but + -- a recursive one might fall through here, I think + , Just data_con <- tyConSingleDataCon_maybe tycon -- One constructor + , null (dataConExTyCoVars data_con) -- no existentials + , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument + = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty + ; let marshal_con e = Var (dataConWrapId data_con) + `mkTyApps` tycon_arg_tys + `App` wrapper e + ; return (maybe_ty, marshal_con) } + + | otherwise + = pprPanic "resultWrapper" (ppr result_ty) + where + maybe_tc_app = splitTyConApp_maybe result_ty diff --git a/GHC/HsToCore/Foreign/Decl.hs b/GHC/HsToCore/Foreign/Decl.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/Decl.hs @@ -0,0 +1,220 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 +-} + +-- | Desugaring foreign declarations +module GHC.HsToCore.Foreign.Decl + ( dsForeigns + ) +where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Tc.Utils.Monad -- temp + +import GHC.HsToCore.Foreign.C +import GHC.HsToCore.Foreign.JavaScript +import GHC.HsToCore.Foreign.Wasm +import GHC.HsToCore.Foreign.Utils +import GHC.HsToCore.Monad + +import GHC.Hs +import GHC.Types.Id +import GHC.Types.ForeignStubs +import GHC.Unit.Module +import GHC.Core.Coercion + +import GHC.Cmm.CLabel +import GHC.Types.ForeignCall +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Driver.DynFlags +import GHC.Platform +import GHC.Data.OrdList +import GHC.Driver.Hooks + +import Data.List (unzip4) + +{- +Desugaring of @foreign@ declarations is naturally split up into +parts, an @import@ and an @export@ part. A @foreign import@ +declaration +\begin{verbatim} + foreign import cc nm f :: prim_args -> IO prim_res +\end{verbatim} +is the same as +\begin{verbatim} + f :: prim_args -> IO prim_res + f a1 ... an = _ccall_ nm cc a1 ... an +\end{verbatim} +so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these. +-} + +dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) +dsForeigns fos = do + hooks <- getHooks + case dsForeignsHook hooks of + Nothing -> dsForeigns' fos + Just h -> h fos + +dsForeigns' :: [LForeignDecl GhcTc] + -> DsM (ForeignStubs, OrdList Binding) +dsForeigns' [] + = return (NoStubs, nilOL) +dsForeigns' fos = do + mod <- getModule + platform <- targetPlatform <$> getDynFlags + fives <- mapM do_ldecl fos + let + (hs, cs, idss, bindss) = unzip4 fives + fe_ids = concat idss + fe_init_code = foreignExportsInitialiser platform mod fe_ids + -- + return (ForeignStubs + (mconcat hs) + (mconcat cs `mappend` fe_init_code), + foldr (appOL . toOL) nilOL bindss) + where + do_ldecl (L loc decl) = putSrcSpanDs (locA loc) (do_decl decl) + + do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding]) + do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do + traceIf (text "fi start" <+> ppr id) + let id' = unLoc id + (bs, h, c, ids) <- dsFImport id' co spec + traceIf (text "fi end" <+> ppr id) + return (h, c, ids, bs) + + do_decl (ForeignExport { fd_name = L _ id + , fd_e_ext = co + , fd_fe = CExport _ + (L _ (CExportStatic _ ext_nm cconv)) }) = do + (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv False + return (h, c, ids, bs) + +{- +************************************************************************ +* * +\subsection{Foreign import} +* * +************************************************************************ + +Desugaring foreign imports is just the matter of creating a binding +that on its RHS unboxes its arguments, performs the external call +(using the @CCallOp@ primop), before boxing the result up and returning it. + +However, we create a worker/wrapper pair, thus: + + foreign import f :: Int -> IO Int +==> + f x = IO ( \s -> case x of { I# x# -> + case fw s x# of { (# s1, y# #) -> + (# s1, I# y# #)}}) + + fw s x# = ccall f s x# + +The strictness/CPR analyser won't do this automatically because it doesn't look +inside returned tuples; but inlining this wrapper is a Really Good Idea +because it exposes the boxing to the call site. +-} + +dsFImport :: Id + -> Coercion + -> ForeignImport (GhcPass p) + -> DsM ([Binding], CHeader, CStub, [Id]) +dsFImport id co (CImport _ cconv safety mHeader spec) = do + platform <- getPlatform + let cconv' = unLoc cconv + safety' = unLoc safety + case (platformArch platform, cconv') of + (ArchJavaScript, _) -> do + (bs, h, c) <- dsJsImport id co spec cconv' safety' mHeader + pure (bs, h, c, []) + (ArchWasm32, JavaScriptCallConv) -> + dsWasmJSImport id co spec safety' + _ -> do + (bs, h, c) <- dsCImport id co spec cconv' safety' mHeader + pure (bs, h, c, []) + +{- +************************************************************************ +* * +\subsection{Foreign export} +* * +************************************************************************ + +The function that does most of the work for `@foreign export@' declarations. +(see below for the boilerplate code a `@foreign export@' declaration expands + into.) + +For each `@foreign export foo@' in a module M we generate: +\begin{itemize} +\item a C function `@foo@', which calls +\item a Haskell stub `@M.\$ffoo@', which calls +\end{itemize} +the user-written Haskell function `@M.foo@'. +-} + +dsFExport :: Id -- Either the exported Id, + -- or the foreign-export-dynamic constructor + -> Coercion -- Coercion between the Haskell type callable + -- from C, and its representation type + -> CLabelString -- The name to export to C land + -> CCallConv + -> Bool -- True => foreign export dynamic + -- so invoke IO action that's hanging off + -- the first argument's stable pointer + -> DsM ( CHeader -- contents of Module_stub.h + , CStub -- contents of Module_stub.c + , String -- string describing type to pass to createAdj. + , [Id] -- function closures to be registered as GC roots + , [Binding] -- additional bindings used by desugared foreign export + ) +dsFExport fn_id co ext_name cconv is_dyn = do + platform <- getPlatform + case (platformArch platform, cconv) of + (ArchJavaScript, _) -> do + (h, c, ts) <- dsJsFExport fn_id co ext_name cconv is_dyn + pure (h, c, ts, [fn_id], []) + (ArchWasm32, JavaScriptCallConv) -> + dsWasmJSExport fn_id co ext_name + _ -> do + (h, c, ts) <- dsCFExport fn_id co ext_name cconv is_dyn + pure (h, c, ts, [fn_id], []) + + +foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub +foreignExportsInitialiser _ _ [] = mempty +foreignExportsInitialiser platform mod hs_fns = + -- Initialise foreign exports by registering a stable pointer from an + -- __attribute__((constructor)) function. + -- The alternative is to do this from stginit functions generated in + -- codeGen/CodeGen.hs; however, stginit functions have a negative impact + -- on binary sizes and link times because the static linker will think that + -- all modules that are imported directly or indirectly are actually used by + -- the program. + -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) + -- + -- See Note [Tracking foreign exports] in rts/ForeignExports.c + initializerCStub platform fn_nm list_decl fn_body + where + fn_nm = mkInitializerStubLabel mod (fsLit "fexports") + mod_str = pprModuleName (moduleName mod) + fn_body = text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi + list_symbol = text "stg_exports_" <> mod_str + list_decl = text "static struct ForeignExportsList" <+> list_symbol <+> equals + <+> braces ( + text ".exports = " <+> export_list <> comma <+> + text ".n_entries = " <+> ppr (length hs_fns)) + <> semi + + export_list = braces $ pprWithCommas closure_ptr hs_fns + + closure_ptr :: Id -> SDoc + closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure" diff --git a/GHC/HsToCore/Foreign/JavaScript.hs b/GHC/HsToCore/Foreign/JavaScript.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/JavaScript.hs @@ -0,0 +1,652 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handling of JavaScript foreign imports/exports +module GHC.HsToCore.Foreign.JavaScript + ( dsJsImport + , dsJsFExport + , dsJsFExportDynamic + ) +where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Hs + +import GHC.HsToCore.Monad +import GHC.HsToCore.Foreign.Call +import GHC.HsToCore.Foreign.Prim +import GHC.HsToCore.Foreign.Utils +import GHC.HsToCore.Utils + +import GHC.Core +import GHC.Core.Make +import GHC.Core.Utils +import GHC.Core.DataCon +import GHC.Core.Unfold.Make +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Multiplicity + +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Literal +import GHC.Types.ForeignStubs +import GHC.Types.SourceText +import GHC.Types.Name +import GHC.Types.RepType +import GHC.Types.ForeignCall +import GHC.Types.Basic +import GHC.Types.Unique + +import GHC.Unit.Module + +import GHC.Tc.Utils.TcType + +import GHC.Cmm.Expr +import GHC.Cmm.Utils + +import GHC.JS.Ppr + +import GHC.Driver.DynFlags +import GHC.Driver.Config + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names + +import GHC.Data.FastString +import GHC.Data.Maybe + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Encoding + +dsJsFExport + :: Id -- Either the exported Id, + -- or the foreign-export-dynamic constructor + -> Coercion -- Coercion between the Haskell type callable + -- from C, and its representation type + -> CLabelString -- The name to export to C land + -> CCallConv + -> Bool -- True => foreign export dynamic + -- so invoke IO action that's hanging off + -- the first argument's stable pointer + -> DsM ( CHeader -- contents of Module_stub.h + , CStub -- contents of Module_stub.c + , String -- string describing type to pass to createAdj. + ) + +dsJsFExport fn_id co ext_name cconv isDyn = do + let + ty = coercionRKind co + (_tvs,sans_foralls) = tcSplitForAllTyVars ty + (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls + -- We must use tcSplits here, because we want to see + -- the (IO t) in the corner of the type! + fe_arg_tys | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' + + -- Look at the result type of the exported function, orig_res_ty + -- If it's IO t, return (t, True) + -- If it's plain t, return (t, False) + (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of + -- The function already returns IO t + Just (_ioTyCon, res_ty) -> (res_ty, True) + -- The function returns t + Nothing -> (orig_res_ty, False) + platform <- targetPlatform <$> getDynFlags + return $ + mkFExportJSBits platform ext_name + (if isDyn then Nothing else Just fn_id) + (map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv + +mkFExportJSBits + :: Platform + -> FastString + -> Maybe Id -- Just==static, Nothing==dynamic + -> [Type] + -> Type + -> Bool -- True <=> returns an IO type + -> CCallConv + -> (CHeader, + CStub, + String -- the argument reps + ) +mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv + = (header_bits, js_bits, type_string) + where + -- list the arguments to the JS function + arg_info :: [(SDoc, -- arg name + SDoc, -- C type + Type, -- Haskell type + CmmType)] -- the CmmType + arg_info = [ let stg_type = showStgType ty in + (arg_cname n stg_type, + stg_type, + ty, + typeCmmType platform (getPrimTyOf ty)) + | (ty,n) <- zip arg_htys [1::Int ..] ] + + arg_cname n _stg_ty = text ('a':show n) + + type_string = primTyDescChar platform res_hty : arg_type_string + + arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info] + + -- stuff to do with the return type of the JS function + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes + + unboxResType | res_hty_is_unit = text "h$rts_getUnit" + | otherwise = unpackHObj res_hty + + header_bits = maybe mempty idTag maybe_target + idTag i = let (tag, u) = unpkUnique (getUnique i) + in CHeader (char tag <> word64 u) + + normal_args = map (\(nm,_ty,_,_) -> nm) arg_info + all_args + | isNothing maybe_target = text "stableptr_offset" : normal_args + | otherwise = normal_args + + fun_args + | null arg_info = empty -- text "void" + | otherwise = hsep $ punctuate comma all_args + + fun_proto + = text "function" <+> + (if isNothing maybe_target + then text "h$" <> ftext c_nm + else ftext c_nm) <> + parens fun_args + + fun_export + = case maybe_target of + Just hs_fn | Just m <- nameModule_maybe (getName hs_fn) -> + text "h$foreignExport" <> + parens ( + ftext c_nm <> comma <> + strlit (unitIdFS (moduleUnitId m)) <> comma <> + strlit (moduleNameFS (moduleName m)) <> comma <> + strlit c_nm <> comma <> + strlit (mkFastString type_string) + ) <> semi + _ -> empty + + strlit xs = pprStringLit xs + + -- the target which will form the root of what we ask rts_evalIO to run + the_cfun + = case maybe_target of + Nothing -> text "h$deRefStablePtr(stableptr_offset)" + Just hs_fn -> idClosureText hs_fn + + -- the expression we give to rts_eval + expr_to_run :: SDoc + expr_to_run + = foldl appArg the_cfun arg_info + where + appArg acc (arg_cname, _, arg_hty, _) + = text "h$rts_apply" + <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname) + + -- finally, the whole darn thing + js_bits = CStub { getCStub = js_sdoc + , getInitializers = mempty + , getFinalizers = mempty + } + where js_sdoc = space + $$ fun_proto + $$ vcat + [ lbrace + , text "return" + <+> text "h$rts_eval_sync" + <> parens ((if is_IO_res_ty + then expr_to_run + else text "h$rts_toIO" <> parens expr_to_run) + <> comma <+> unboxResType) + <> semi + , rbrace + ] + $$ fun_export + +idClosureText :: Id -> SDoc +idClosureText i + | isExportedId i + , name <- getName i + , Just m <- nameModule_maybe name + = let str = renderWithContext defaultSDocContext (pprFullName m (localiseName name)) + in text "h$" <> text (zEncodeString str) + | otherwise + = panic "idClosureText: unknown module" + +-- | Desugaring of JavaScript foreign imports +dsJsImport + :: Id + -> Coercion + -> CImportSpec + -> CCallConv + -> Safety + -> Maybe Header + -> DsM ([Binding], CHeader, CStub) +dsJsImport id co (CLabel cid) _ _ _ = do + let ty = coercionLKind co + fod = case tyConAppTyCon_maybe (dropForAlls ty) of + Just tycon + | tyConUnique tycon == funPtrTyConKey -> + IsFunction + _ -> IsData + (_resTy, foRhs) <- jsResultWrapper ty +-- ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this + let rhs = foRhs (Lit (LitLabel cid fod)) + rhs' = Cast rhs co + + return ([(id, rhs')], mempty, mempty) + +dsJsImport id co (CFunction target) cconv@PrimCallConv safety _ + = dsPrimCall id co (CCall (CCallSpec target cconv safety)) +dsJsImport id co (CFunction target) cconv safety mHeader + = dsJsCall id co (CCall (CCallSpec target cconv safety)) mHeader +dsJsImport id co CWrapper cconv _ _ + = dsJsFExportDynamic id co cconv + +-- fixme work in progress +-- FIXME (Sylvain 2022-03): possibility of code sharing with dsFExportDynamic? +-- Lot of duplication +dsJsFExportDynamic :: Id + -> Coercion + -> CCallConv + -> DsM ([Binding], CHeader, CStub) +dsJsFExportDynamic id co0 cconv = do + let + ty = coercionLKind co0 + (tvs,sans_foralls) = tcSplitForAllTyVars ty + ([scaled_arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls + arg_ty = scaledThing scaled_arg_ty + (io_tc, res_ty) = expectJust + -- Must have an IO type; hence Just + $ tcSplitIOType_maybe fn_res_ty + mod <- getModule + let fe_nm = mkFastString $ zEncodeString + ("h$" ++ moduleStableString mod ++ "$" ++ toJsName id) + -- Construct the label based on the passed id, don't use names + -- depending on Unique. See #13807 and Note [Unique Determinism]. + cback <- newSysLocalDs scaled_arg_ty + newStablePtrId <- dsLookupGlobalId newStablePtrName + stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName + let + stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] + export_ty = mkVisFunTyMany stable_ptr_ty arg_ty + bindIOId <- dsLookupGlobalId bindIOName + stbl_value <- newSysLocalMDs stable_ptr_ty + (h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True + let + {- + The arguments to the external function which will + create a little bit of (template) code on the fly + for allowing the (stable pointed) Haskell closure + to be entered using an external calling convention + (ccall). + -} + adj_args = [ Var stbl_value + , Lit (LitLabel fe_nm IsFunction) + , Lit (mkLitString typestring) + ] + -- name of external entry point providing these services. + -- (probably in the RTS.) + adjustor = fsLit "createAdjustor" + + ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) + -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback + + let io_app = mkLams tvs $ + Lam cback $ + mkApps (Var bindIOId) + [ Type stable_ptr_ty + , Type res_ty + , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] + , Lam stbl_value ccall_adj + ] + + fed = (id `setInlineActivation` NeverActive, Cast io_app co0) + -- Never inline the f.e.d. function, because the litlit + -- might not be in scope in other modules. + + return ([fed], h_code, c_code) + +toJsName :: Id -> String +toJsName i = renderWithContext defaultSDocContext (pprCode (ppr (idName i))) + +dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe Header + -> DsM ([(Id, Expr TyVar)], CHeader, CStub) +dsJsCall fn_id co (CCall (CCallSpec target cconv safety)) _mDeclHeader = do + let + ty = coercionLKind co + (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty + (arg_tys, io_res_ty) = tcSplitFunTys rho + + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism + (val_args, arg_wrappers) <- mapAndUnzipM unboxJsArg (map Var args) + + let + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + + (ccall_result_ty, res_wrapper) <- boxJsResult io_res_ty + + ccall_uniq <- newUnique + work_uniq <- newUnique + + simpl_opts <- initSimpleOpts <$> getDynFlags + + let + -- Build the worker + fcall = CCall (CCallSpec target cconv safety) + worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) + tvs = map binderVar tv_bndrs + the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty + work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) + work_id = mkSysLocal (fsLit "$wccall") work_uniq ManyTy worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers + wrap_rhs = mkLams (tvs ++ args) wrapper_body + wrap_rhs' = Cast wrap_rhs co + fn_id_w_inl = fn_id + `setIdUnfolding` + mkInlineUnfoldingWithArity simpl_opts VanillaSrc + (length args) wrap_rhs' + + return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, mempty) + + +mkHObj :: Type -> SDoc +mkHObj t = text "h$rts_mk" <> showFFIType t + +unpackHObj :: Type -> SDoc +unpackHObj t = text "h$rts_get" <> showFFIType t + +showStgType :: Type -> SDoc +showStgType t = text "Hs" <> showFFIType t + +showFFIType :: Type -> SDoc +showFFIType t = ftext (occNameFS (getOccName (typeTyCon t))) + +typeTyCon :: Type -> TyCon +typeTyCon ty + -- UnaryRep rep_ty <- repType ty + | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) -- rep_ty + = tc + | otherwise + = pprPanic "typeTyCon" (ppr ty) + + +{- + We unbox arguments for JS calls a bit different from native code: + - Bool is marshalled to true/false, not 0/1 + - All int types are narrowed, since JS floats have a greater range than Int32 + -} + +unboxJsArg :: CoreExpr -- The supplied argument + -> DsM (CoreExpr, -- To pass as the actual argument + CoreExpr -> CoreExpr -- Wrapper to unbox the arg + ) +unboxJsArg arg + -- Primtive types: nothing to unbox + | isPrimitiveType arg_ty + = return (arg, \body -> body) + + -- Recursive newtypes + | Just (co, _rep_ty) <- topNormaliseNewType_maybe arg_ty + = unboxJsArg (mkCast arg co) + + -- Booleans, do not convert to 0/1, only force them + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` boolTyConKey + = return (arg, + \ body -> mkWildCase arg (unrestricted boolTy) (exprType body) [Alt DEFAULT [] body]) + + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` anyTyConKey + = return (arg, + \ body -> mkWildCase arg (unrestricted arg_ty) (exprType body) [Alt DEFAULT [] body]) + -- Data types with a single constructor, which has a single, primitive-typed arg + -- This deals with Int, Float etc; also Ptr, ForeignPtr + | is_product_type && data_con_arity == 1 + = do case_bndr <- newSysLocalMDs arg_ty + prim_arg <- newSysLocalMDs (scaledThing data_con_arg_ty1) + return (Var prim_arg, + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body] + ) + + -- Byte-arrays, both mutable and otherwise; hack warning + -- We're looking for values of type ByteArray, MutableByteArray + -- data ByteArray ix = ByteArray ix ix ByteArray# + -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) + | is_product_type && + data_con_arity == 3, + Just arg3_tycon <- maybe_arg3_tycon, + (arg3_tycon == byteArrayPrimTyCon || + arg3_tycon == mutableByteArrayPrimTyCon) + = do case_bndr <- newSysLocalMDs arg_ty + vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys + return (Var arr_cts_var, + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body] + ) + + | otherwise + = do l <- getSrcSpanDs + pprPanic "unboxJsArg: " (ppr l <+> ppr arg_ty) + where + arg_ty = exprType arg + maybe_product_type = splitDataProductType_maybe arg_ty + is_product_type = isJust maybe_product_type + Just (_, _, data_con, data_con_arg_tys) = maybe_product_type + data_con_arity = dataConSourceArity data_con + (data_con_arg_ty1 : _) = data_con_arg_tys + + (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys + maybe_arg3_tycon = tyConAppTyCon_maybe (scaledThing data_con_arg_ty3) + + +-- Takes the result of the user-level ccall: +-- either (IO t), +-- or maybe just t for an side-effect-free call +-- Returns a wrapper for the primitive ccall itself, along with the +-- type of the result of the primitive ccall. This result type +-- will be of the form +-- State# RealWorld -> (# State# RealWorld, t' #) +-- where t' is the unwrapped form of t. If t is simply (), then +-- the result type will be +-- State# RealWorld -> (# State# RealWorld #) +boxJsResult :: Type -> DsM (Type, CoreExpr -> CoreExpr) +boxJsResult result_ty + | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty + -- isIOType_maybe handles the case where the type is a + -- simple wrapping of IO. E.g. + -- newtype Wrap a = W (IO a) + -- No coercion necessary because its a non-recursive newtype + -- (If we wanted to handle a *recursive* newtype too, we'd need + -- another case, and a coercion.) + -- The result is IO t, so wrap the result in an IO constructor + = do { res <- jsResultWrapper io_res_ty + ; let return_result state ans + = mkCoreUnboxedTuple [state, ans] + + ; (ccall_res_ty, the_alt) <- mk_alt return_result res + + ; state_id <- newSysLocalMDs realWorldStatePrimTy + ; let io_data_con = head (tyConDataCons io_tycon) + toIOCon = dataConWrapId io_data_con + + wrap the_call = + mkApps (Var toIOCon) + [ Type io_res_ty, + Lam state_id $ + mkWildCase (App the_call (Var state_id)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + ] + + ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) } + +boxJsResult result_ty + = do -- It isn't IO, so do unsafePerformIO + -- It's not conveniently available, so we inline it + res <- jsResultWrapper result_ty + (ccall_res_ty, the_alt) <- mk_alt return_result res + let + wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) + where + return_result _ ans = ans + +mk_alt :: (Expr Var -> Expr Var -> Expr Var) + -> (Maybe Type, Expr Var -> Expr Var) + -> DsM (Type, CoreAlt) +mk_alt return_result (Nothing, wrap_result) + = do -- The ccall returns () + state_id <- newSysLocalMDs realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + (wrap_result $ panic "jsBoxResult") + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] + the_alt = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs + return (ccall_res_ty, the_alt) + +mk_alt return_result (Just prim_res_ty, wrap_result) + -- The ccall returns a non-() value + | isUnboxedTupleType prim_res_ty = do + let + ls = dropRuntimeRepArgs (tyConAppArgs prim_res_ty) + arity = 1 + length ls + args_ids <- newSysLocalsMDs ls + state_id <- newSysLocalMDs realWorldStatePrimTy + let + result_tup = mkCoreUnboxedTuple (map Var args_ids) + the_rhs = return_result (Var state_id) + (wrap_result result_tup) + ccall_res_ty = mkTupleTy Unboxed (realWorldStatePrimTy : ls) + the_alt = Alt (DataAlt (tupleDataCon Unboxed arity)) + (state_id : args_ids) + the_rhs + return (ccall_res_ty, the_alt) + + | otherwise = do + result_id <- newSysLocalMDs prim_res_ty + state_id <- newSysLocalMDs realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + (wrap_result (Var result_id)) + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] + the_alt = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs + return (ccall_res_ty, the_alt) + +jsResultWrapper + :: Type + -> DsM ( Maybe Type -- Type of the expected result, if any + , CoreExpr -> CoreExpr -- Wrapper for the result + ) +-- resultWrapper deals with the result *value* +-- E.g. foreign import foo :: Int -> IO T +-- Then resultWrapper deals with marshalling the 'T' part +jsResultWrapper result_ty + -- Base case 1a: unboxed tuples + | Just (tc, args) <- splitTyConApp_maybe result_ty + , isUnboxedTupleTyCon tc {- && False -} = do + let args' = dropRuntimeRepArgs args + (tys, wrappers) <- unzip <$> mapM jsResultWrapper args' + matched <- mapM (mapM newSysLocalMDs) tys + let tys' = catMaybes tys + -- arity = length args' + -- resCon = tupleDataCon Unboxed (length args) + err = panic "jsResultWrapper: used Id with result type Nothing" + resWrap :: CoreExpr + resWrap = mkCoreUnboxedTuple (zipWith (\w -> w . Var . fromMaybe err) wrappers matched) + return $ + if null tys' + then (Nothing, \_ -> resWrap) + else let innerArity = length tys' + innerTy = mkTupleTy Unboxed tys' + innerCon = tupleDataCon Unboxed innerArity + inner :: CoreExpr -> CoreExpr + inner e = mkWildCase e (unrestricted innerTy) result_ty + [Alt (DataAlt innerCon) + (catMaybes matched) + resWrap + ] + in (Just innerTy, inner) + + -- Base case 1b: primitive types + | isPrimitiveType result_ty + = return (Just result_ty, \e -> e) + -- Base case 1c: boxed tuples + | Just (tc, args) <- maybe_tc_app + , isBoxedTupleTyCon tc = do + let innerTy = mkTupleTy Unboxed args + (inner_res, w) <- jsResultWrapper innerTy + matched <- newSysLocalsMDs args + let inner e = mkWildCase (w e) (unrestricted innerTy) result_ty + [ Alt (DataAlt (tupleDataCon Unboxed (length args))) + matched + (mkCoreTup (map Var matched)) + -- mkCoreConApps (tupleDataCon Boxed (length args)) (map Type args ++ map Var matched) + ] + return (inner_res, inner) + + -- Base case 2: the unit type () + | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey + = return (Nothing, \_ -> Var unitDataConId) + + -- Base case 3: the boolean type + | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do +-- result_id <- newSysLocalDs boolTy + ccall_uniq <- newUnique + let forceBool e = mkJsCall ccall_uniq (fsLit "((x) => { return !(!x); })") [e] boolTy + return + (Just intPrimTy, \e -> forceBool e) + + -- Base case 4: the any type + | Just (tc,_) <- maybe_tc_app, tc `hasKey` anyTyConKey + = return (Just result_ty, \e -> e) + + -- Newtypes + | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty + = do (maybe_ty, wrapper) <- jsResultWrapper rep_ty + return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) + + -- The type might contain foralls (eg. for dummy type arguments, + -- referring to 'Ptr a' is legal). + | Just (tyvar, rest) <- splitForAllTyCoVar_maybe result_ty + = do (maybe_ty, wrapper) <- jsResultWrapper rest + return (maybe_ty, \e -> Lam tyvar (wrapper e)) + + -- Data types with a single constructor, which has a single arg + -- This includes types like Ptr and ForeignPtr + | Just (_tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty, + dataConSourceArity data_con == 1 + = do let (unwrapped_res_ty : _) = data_con_arg_tys + (maybe_ty, wrapper) <- jsResultWrapper (scaledThing unwrapped_res_ty) + return + (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) + (map Type tycon_arg_tys ++ [wrapper e])) + + | otherwise + = pprPanic "jsResultWrapper" (ppr result_ty) + where + maybe_tc_app = splitTyConApp_maybe result_ty + +-- low-level primitive JavaScript call: +mkJsCall :: Unique -> FastString -> [CoreExpr] -> Type -> CoreExpr +mkJsCall u tgt args t = mkFCall u ccall args t + where + ccall = CCall $ CCallSpec + (StaticTarget NoSourceText tgt (Just ghcInternalUnit) True) + JavaScriptCallConv + PlayRisky diff --git a/GHC/HsToCore/Foreign/Prim.hs b/GHC/HsToCore/Foreign/Prim.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/Prim.hs @@ -0,0 +1,45 @@ +-- | Foreign primitive calls +-- +-- This is for `@foreign import prim@' declarations. +-- +-- Currently, at the core level we pretend that these primitive calls are +-- foreign calls. It may make more sense in future to have them as a distinct +-- kind of Id, or perhaps to bundle them with PrimOps since semantically and for +-- calling convention they are really prim ops. +module GHC.HsToCore.Foreign.Prim + ( dsPrimCall + ) +where + +import GHC.Prelude + +import GHC.Tc.Utils.Monad -- temp +import GHC.Tc.Utils.TcType + +import GHC.Core +import GHC.Core.Type +import GHC.Core.Coercion + +import GHC.HsToCore.Monad +import GHC.HsToCore.Foreign.Call + +import GHC.Types.Id +import GHC.Types.ForeignStubs +import GHC.Types.ForeignCall + +dsPrimCall :: Id -> Coercion -> ForeignCall + -> DsM ([(Id, Expr TyVar)], CHeader, CStub) +dsPrimCall fn_id co fcall = do + let + ty = coercionLKind co + (tvs, fun_ty) = tcSplitForAllInvisTyVars ty + (arg_tys, io_res_ty) = tcSplitFunTys fun_ty + + args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism + + ccall_uniq <- newUnique + let + call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty + rhs = mkLams tvs (mkLams args call_app) + rhs' = Cast rhs co + return ([(fn_id, rhs')], mempty, mempty) diff --git a/GHC/HsToCore/Foreign/Utils.hs b/GHC/HsToCore/Foreign/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/Utils.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE MultiWayIf #-} + +module GHC.HsToCore.Foreign.Utils + ( Binding + , getPrimTyOf + , primTyDescChar + , ppPrimTyConStgType + ) +where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Tc.Utils.TcType + +import GHC.Core (CoreExpr) +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep + +import GHC.Types.Id +import GHC.Types.RepType + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +type Binding = (Id, CoreExpr) -- No rec/nonrec structure; + -- the occurrence analyser will sort it all out + +-- This function returns the primitive type associated with the boxed +-- type argument to a foreign export (eg. Int ==> Int#). +getPrimTyOf :: Type -> UnaryType +getPrimTyOf ty + | isBoolTy rep_ty = intPrimTy + -- Except for Bool, the types we are interested in have a single constructor + -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). + | otherwise = + case splitDataProductType_maybe rep_ty of + Just (_, _, data_con, [Scaled _ prim_ty]) -> + assert (dataConSourceArity data_con == 1) $ + assertPpr (isUnliftedType prim_ty) (ppr prim_ty) + -- NB: it's OK to call isUnliftedType here, as we don't allow + -- representation-polymorphic types in foreign import/export declarations + prim_ty + _other -> pprPanic "getPrimTyOf" (ppr ty) + where + rep_ty = unwrapType ty + +-- represent a primitive type as a Char, for building a string that +-- described the foreign function type. The types are size-dependent, +-- e.g. 'W' is a signed 32-bit integer. +primTyDescChar :: Platform -> Type -> Char +primTyDescChar !platform ty + | ty `eqType` unitTy = 'v' + | otherwise + = case typePrimRepU (getPrimTyOf ty) of + IntRep -> signed_word + WordRep -> unsigned_word + Int8Rep -> 'B' + Word8Rep -> 'b' + Int16Rep -> 'S' + Word16Rep -> 's' + Int32Rep -> 'W' + Word32Rep -> 'w' + Int64Rep -> 'L' + Word64Rep -> 'l' + AddrRep -> 'p' + FloatRep -> 'f' + DoubleRep -> 'd' + _ -> pprPanic "primTyDescChar" (ppr ty) + where + (signed_word, unsigned_word) = case platformWordSize platform of + PW4 -> ('W','w') + PW8 -> ('L','l') + +-- | Printed C Type to be used with CAPI calling convention +ppPrimTyConStgType :: TyCon -> Maybe String +ppPrimTyConStgType tc = + if | tc == charPrimTyCon -> Just "StgChar" + | tc == intPrimTyCon -> Just "StgInt" + | tc == int8PrimTyCon -> Just "StgInt8" + | tc == int16PrimTyCon -> Just "StgInt16" + | tc == int32PrimTyCon -> Just "StgInt32" + | tc == int64PrimTyCon -> Just "StgInt64" + | tc == wordPrimTyCon -> Just "StgWord" + | tc == word8PrimTyCon -> Just "StgWord8" + | tc == word16PrimTyCon -> Just "StgWord16" + | tc == word32PrimTyCon -> Just "StgWord32" + | tc == word64PrimTyCon -> Just "StgWord64" + | tc == floatPrimTyCon -> Just "StgFloat" + | tc == doublePrimTyCon -> Just "StgDouble" + | tc == addrPrimTyCon -> Just "StgAddr" + | tc == stablePtrPrimTyCon -> Just "StgStablePtr" + | tc == arrayPrimTyCon -> Just "const StgAddr" + | tc == mutableArrayPrimTyCon -> Just "StgAddr" + | tc == byteArrayPrimTyCon -> Just "const StgAddr" + | tc == mutableByteArrayPrimTyCon -> Just "StgAddr" + | tc == smallArrayPrimTyCon -> Just "const StgAddr" + | tc == smallMutableArrayPrimTyCon -> Just "StgAddr" + | otherwise -> Nothing diff --git a/GHC/HsToCore/Foreign/Wasm.hs b/GHC/HsToCore/Foreign/Wasm.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/Wasm.hs @@ -0,0 +1,759 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Foreign.Wasm + ( dsWasmJSImport, + dsWasmJSExport, + ) +where + +import Data.List + ( intercalate, + stripPrefix, + ) +import Data.List qualified +import Data.Maybe +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Core +import GHC.Core.Coercion +import GHC.Core.DataCon +import GHC.Core.Make +import GHC.Core.Multiplicity +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Utils +import GHC.Data.FastString +import GHC.Hs +import GHC.HsToCore.Foreign.Call +import GHC.HsToCore.Foreign.Utils +import GHC.HsToCore.Monad +import GHC.HsToCore.Types +import GHC.Iface.Env +import GHC.Prelude +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Types.ForeignCall +import GHC.Types.ForeignStubs +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.SourceText +import GHC.Types.SrcLoc +import GHC.Types.Var +import GHC.Unit +import GHC.Utils.Outputable +import GHC.Utils.Panic +import Language.Haskell.Syntax.Basic + +data Synchronicity = Sync | Async + deriving (Eq) + +dsWasmJSImport :: + Id -> + Coercion -> + CImportSpec -> + Safety -> + DsM ([Binding], CHeader, CStub, [Id]) +dsWasmJSImport id co (CFunction (StaticTarget _ js_src mUnitId _)) safety + | js_src == "wrapper" = dsWasmJSDynamicExport Async id co mUnitId + | js_src == "wrapper sync" = dsWasmJSDynamicExport Sync id co mUnitId + | otherwise = do + (bs, h, c) <- dsWasmJSStaticImport id co (unpackFS js_src) mUnitId sync + pure (bs, h, c, []) + where + sync = case safety of + PlayRisky -> Sync + _ -> Async +dsWasmJSImport _ _ _ _ = panic "dsWasmJSImport: unreachable" + +{- + +Note [Desugaring JSFFI dynamic export] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A JSFFI dynamic export wraps a Haskell function as a JavaScript +callback: + +foreign import javascript "wrapper" + mk_wrapper :: HsFuncType -> IO JSVal + +We desugar it to three bindings under the hood: + +1. The worker function + +mk_wrapper_worker :: StablePtr HsFuncType -> HsFuncType +mk_wrapper_worker sp = unsafeDupablePerformIO (deRefStablePtr sp) + +The worker function is marked as a JSFFI static export. It turns a +dynamic export to a static one by prepending a StablePtr to the +argument list. + +We don't actually generate a Core binding for the worker function +though; the JSFFI static export C stub generation logic would just +generate a function that doesn't need to refer to the worker Id's +closure. This is not just for convenience, it's actually required for +correctness, see #25473. + +2. The adjustor function + +foreign import javascript unsafe "(...args) => __exports.mk_wrapper_worker($1, ...args)" + mk_wrapper_adjustor :: StablePtr HsFuncType -> IO JSVal + +Now that mk_wrapper_worker is exported in __exports, we need to make a +JavaScript callback that invokes mk_wrapper_worker with the right +StablePtr as well as the rest of the arguments. + +3. The wrapper function + +mk_wrapper :: HsFuncType -> IO JSVal +mk_wrapper = mkJSCallback mk_wrapper_adjustor + +This is the user-facing mk_wrapper binding. It allocates a stable +pointer for the Haskell function closure, then calls the adjustor +function to fetch the JSVal that represents the JavaScript callback. +The JSVal as returned by the adjustor is not returned directly; it has +a StablePtr# field which is NULL by default, but for JSFFI dynamic +exports, it's set to the Haskell function's stable pointer. This way, +when we call freeJSVal, the Haskell function can be freed as well. + +By default, JSFFI exports are async JavaScript functions. One can use +"wrapper sync" instead of "wrapper" to indicate the Haskell function +is meant to be exported as a sync JavaScript function. All the +comments above still hold, with only only difference: +mk_wrapper_worker is exported as a sync function. See +Note [Desugaring JSFFI static export] for further details. + +-} + +dsWasmJSDynamicExport :: + Synchronicity -> + Id -> + Coercion -> + Maybe Unit -> + DsM ([Binding], CHeader, CStub, [Id]) +dsWasmJSDynamicExport sync fn_id co mUnitId = do + sp_tycon <- dsLookupTyCon stablePtrTyConName + let ty = coercionLKind co + (tv_bndrs, fun_ty) = tcSplitForAllTyVarBinders ty + ([Scaled ManyTy arg_ty], io_jsval_ty) = tcSplitFunTys fun_ty + sp_ty = mkTyConApp sp_tycon [arg_ty] + sp_id <- newSysLocalMDs sp_ty + work_export_name <- unpackFS <$> uniqueCFunName + deRefStablePtr_id <- + lookupGhcInternalVarId + "GHC.Internal.Stable" + "deRefStablePtr" + unsafeDupablePerformIO_id <- + lookupGhcInternalVarId + "GHC.Internal.IO.Unsafe" + "unsafeDupablePerformIO" + let work_rhs = + mkCoreLams ([tv | Bndr tv _ <- tv_bndrs] ++ [sp_id]) + $ mkApps + (Var unsafeDupablePerformIO_id) + [Type arg_ty, mkApps (Var deRefStablePtr_id) [Type arg_ty, Var sp_id]] + work_ty = exprType work_rhs + (work_h, work_c, _, work_ids, work_bs) <- + dsWasmJSExport' + sync + Nothing + (mkRepReflCo work_ty) + work_export_name + adjustor_uniq <- newUnique + let adjustor_id = + mkExportedVanillaId + ( mkExternalName + adjustor_uniq + (nameModule $ getName fn_id) + ( mkVarOcc + $ "jsffi_" + ++ occNameString (getOccName fn_id) + ++ "_adjustor" + ) + generatedSrcSpan + ) + adjustor_ty + adjustor_ty = mkForAllTys tv_bndrs $ mkVisFunTysMany [sp_ty] io_jsval_ty + adjustor_js_src = + "(...args) => __exports." ++ work_export_name ++ "($1, ...args)" + (adjustor_bs, adjustor_h, adjustor_c) <- + dsWasmJSStaticImport + adjustor_id + (mkRepReflCo adjustor_ty) + adjustor_js_src + mUnitId + Sync + mkJSCallback_id <- + lookupGhcInternalVarId + "GHC.Internal.Wasm.Prim.Exports" + "mkJSCallback" + let wrap_rhs = + mkCoreLams [tv | Bndr tv _ <- tv_bndrs] + $ mkApps + (Var mkJSCallback_id) + [ Type arg_ty, + mkApps + (Var adjustor_id) + [Type $ mkTyVarTy tv | Bndr tv _ <- tv_bndrs] + ] + pure + ( [(fn_id, Cast wrap_rhs co)] ++ work_bs ++ adjustor_bs, + work_h `mappend` adjustor_h, + work_c `mappend` adjustor_c, + work_ids + ) + +{- + +Note [Desugaring JSFFI import] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The simplest case is JSFFI sync import, those marked as unsafe. It is +implemented on top of C FFI safe import. + +Unlike C FFI which generates a worker/wrapper pair that unboxes the +arguments and boxes the result in Haskell, we only desugar to a single +Haskell binding that case-binds the arguments to ensure they're +evaluated, then passes the boxed arguments directly to C and receive +the boxed result from C as well. + +This is slightly less efficient than how C FFI does it, and unboxed +FFI types aren't supported, but it's the simplest way to implement it, +especially since leaving all the boxing/unboxing business to C unifies +the implementation of JSFFI imports and exports +(rts_mkJSVal/rts_getJSVal). + +Now, each sync import calls a generated C function with a unique +symbol. The C function uses rts_get* to unbox the arguments, call into +JavaScript, then boxes the result with rts_mk* and returns it to +Haskell. But wait, how on earth is C able to call into JavaScript +here!? The secret is using a wasm import: + +__attribute__((import_module("ghc_wasm_jsffi"), import_name("my_js_func"))) +HsJSVal worker_func(HsInt a1, HsJSVal a2); + +Wasm imports live in the same namespace as other wasm functions, so +our C wrapper function can call into this imported worker function, +which will literally be the user written JavaScript function with +binders $1, $2, etc. + +So far so good, but how does the source code snippet go from Haskell +source files to the JavaScript module which provides the +ghc_wasm_jsffi imports to be used by the wasm module at runtime? The +secret is embedding the source code snippets in a wasm custom section +named ghc_wasm_jsffi: + +.section .custom_section.ghc_wasm_jsffi,"",@ +.asciz my_js_func +.asciz ($1, $2) +.asciz js_code_containing($1, $2) + +At link time, for all object files touched by wasm-ld, all +ghc_wasm_jsffi sections are concatenated into a single ghc_wasm_jsffi +section in the output wasm module. And then, a simple "post-linker" +program can parse the payload of that section and emit a JavaScript +module. Note that above is assembly source file, but we're only +generating a C stub, so we need to smuggle the assembly code into C +via __asm__. + +The C FFI import that calls the generated C function is always marked +as safe. There is some extra overhead, but this allows re-entrance by +Haskell -> JavaScript -> Haskell function calls with each call being a +synchronous one. It's possible to steal the "interruptible" keyword to +indicate async imports, "safe" for sync imports and "unsafe" for sync +imports sans the safe C FFI overhead, but it's simply not worth the +extra complexity. + +JSFFI async import is implemented on top of JSFFI sync import. We +still desugar it to a single Haskell binding that calls C, with some +subtle differences: + +- The C result type is always a boxed JSVal that represents the + JavaScript Promise, instead of the actual Haskell result type. +- In the custom section payload, we emit "async ($1, $2)" instead of + "($1, $2)". As you can see, it is the arrow function binder, and the + post-linker will respect the async binder and allow await in the + function body. + +Now we have the Promise JSVal, we apply stg_blockPromise to it to get +a thunk with the desired return type. When the thunk is forced, it +will block the forcing thread and wait for the Promise to resolve or +reject. See Note [stg_blockPromise] for detailed explanation of how it +works. + +-} + +dsWasmJSStaticImport :: + Id -> + Coercion -> + String -> + Maybe Unit -> + Synchronicity -> + DsM ([Binding], CHeader, CStub) +dsWasmJSStaticImport fn_id co js_src' mUnitId sync = do + cfun_name <- uniqueCFunName + let ty = coercionLKind co + (tvs, fun_ty) = tcSplitForAllInvisTyVars ty + (arg_tys, orig_res_ty) = tcSplitFunTys fun_ty + (res_ty, is_io) = case tcSplitIOType_maybe orig_res_ty of + Just (_, res_ty) -> (res_ty, True) + Nothing -> (orig_res_ty, False) + js_src + -- Just desugar it to a JSFFI import with source text "$1($2, + -- ...)", with the same type signature and safety annotation. + | js_src' == "dynamic" = + "$1(" + ++ intercalate "," ["$" ++ show i | i <- [2 .. length arg_tys]] + ++ ")" + | otherwise = + js_src' + case sync of + Sync -> do + rhs <- importBindingRHS mUnitId cfun_name tvs arg_tys orig_res_ty id + pure + ( [(fn_id, Cast rhs co)], + CHeader commonCDecls, + importCStub Sync cfun_name (map scaledThing arg_tys) res_ty js_src + ) + Async -> do + err_msg <- mkStringExpr $ js_src + io_tycon <- dsLookupTyCon ioTyConName + jsval_ty <- + mkTyConTy + <$> lookupGhcInternalTyCon "GHC.Internal.Wasm.Prim.Types" "JSVal" + bindIO_id <- dsLookupGlobalId bindIOName + returnIO_id <- dsLookupGlobalId returnIOName + promise_id <- newSysLocalMDs jsval_ty + blockPromise_id <- + lookupGhcInternalVarId + "GHC.Internal.Wasm.Prim.Imports" + "stg_blockPromise" + msgPromise_id <- + lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" + $ "stg_messagePromise" + ++ ffiType res_ty + unsafeDupablePerformIO_id <- + lookupGhcInternalVarId + "GHC.Internal.IO.Unsafe" + "unsafeDupablePerformIO" + rhs <- + importBindingRHS + mUnitId + cfun_name + tvs + arg_tys + (mkTyConApp io_tycon [jsval_ty]) + $ ( if is_io + then id + else \m_res -> + mkApps (Var unsafeDupablePerformIO_id) [Type res_ty, m_res] + ) + -- (m_promise :: IO JSVal) >>= (\promise -> return (stg_blockPromise promise msgPromise)) + -- stg_blockPromise returns the thunk + . ( \m_promise -> + mkApps + (Var bindIO_id) + [ Type jsval_ty, + Type res_ty, + m_promise, + Lam promise_id + $ mkApps + (Var returnIO_id) + [ Type res_ty, + mkApps + (Var blockPromise_id) + [Type res_ty, err_msg, Var promise_id, Var msgPromise_id] + ] + ] + ) + pure + ( [(fn_id, Cast rhs co)], + CHeader commonCDecls, + importCStub Async cfun_name (map scaledThing arg_tys) jsval_ty js_src + ) + +uniqueCFunName :: DsM FastString +uniqueCFunName = do + cfun_num <- ds_next_wrapper_num <$> getGblEnv + mkWrapperName cfun_num "ghc_wasm_jsffi" "" + +importBindingRHS :: + Maybe Unit -> + FastString -> + [TyVar] -> + [Scaled Type] -> + Type -> + (CoreExpr -> CoreExpr) -> + DsM CoreExpr +importBindingRHS mUnitId cfun_name tvs arg_tys orig_res_ty res_trans = do + ccall_uniq <- newUnique + args_unevaled <- newSysLocalsDs arg_tys + args_evaled <- newSysLocalsDs arg_tys + -- ccall_action_ty: type of the_call, State# RealWorld -> (# State# RealWorld, a #) + -- res_wrapper: turn the_call to (IO a) or a + (ccall_action_ty, res_wrapper) <- case tcSplitIOType_maybe orig_res_ty of + Just (io_tycon, res_ty) -> do + s0_id <- newSysLocalMDs realWorldStatePrimTy + s1_id <- newSysLocalMDs realWorldStatePrimTy + let io_data_con = tyConSingleDataCon io_tycon + toIOCon = dataConWorkId io_data_con + (ccall_res_ty, wrap) + | res_ty `eqType` unitTy = + ( mkTupleTy Unboxed [realWorldStatePrimTy], + \the_call -> + mkApps + (Var toIOCon) + [ Type res_ty, + Lam s0_id + $ mkWildCase + (App the_call (Var s0_id)) + (unrestricted ccall_res_ty) + (mkTupleTy Unboxed [realWorldStatePrimTy, unitTy]) + [ Alt + (DataAlt (tupleDataCon Unboxed 1)) + [s1_id] + (mkCoreUnboxedTuple [Var s1_id, unitExpr]) + ] + ] + ) + | otherwise = + ( mkTupleTy Unboxed [realWorldStatePrimTy, res_ty], + \the_call -> mkApps (Var toIOCon) [Type res_ty, the_call] + ) + pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) + Nothing -> do + unsafeDupablePerformIO_id <- + lookupGhcInternalVarId + "GHC.Internal.IO.Unsafe" + "unsafeDupablePerformIO" + io_data_con <- dsLookupDataCon ioDataConName + let ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, orig_res_ty] + toIOCon = dataConWorkId io_data_con + wrap the_call = + mkApps + (Var unsafeDupablePerformIO_id) + [ Type orig_res_ty, + mkApps (Var toIOCon) [Type orig_res_ty, the_call] + ] + pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) + let cfun_fcall = + CCall + ( CCallSpec + (StaticTarget NoSourceText cfun_name mUnitId True) + CCallConv + -- Same even for foreign import javascript unsafe, for + -- the sake of re-entrancy. + PlaySafe + ) + call_app = + mkFCall ccall_uniq cfun_fcall (map Var args_evaled) ccall_action_ty + rhs = + mkCoreLams (tvs ++ args_unevaled) + $ foldr + (\(arg_u, arg_e) acc -> mkDefaultCase (Var arg_u) arg_e acc) + -- res_trans transforms the result. When desugaring + -- JSFFI sync imports, the result is just (IO a) or a, + -- and res_trans is id; for async cases, the result is + -- always (IO JSVal), and res_trans will wrap it in a + -- thunk that has the original return type. This way, we + -- can reuse most of the RHS generation logic for both + -- sync/async imports. + (res_trans $ res_wrapper call_app) + (zip args_unevaled args_evaled) + pure rhs + +importCStub :: Synchronicity -> FastString -> [Type] -> Type -> String -> CStub +importCStub sync cfun_name arg_tys res_ty js_src = CStub c_doc [] [] + where + import_name = fromJust $ stripPrefix "ghczuwasmzujsffi" (unpackFS cfun_name) + import_asm = + text "__asm__" + <> parens + ( vcat + [ text (show l) + | l <- + [ ".section .custom_section.ghc_wasm_jsffi,\"\",@\n", + ".asciz \"" ++ import_name ++ "\"\n", + ".asciz \"" + ++ ( case sync of + Sync -> "(" + Async -> "async (" + ) + ++ intercalate "," ["$" ++ show i | i <- [1 .. length arg_tys]] + ++ ")\"\n", + ".asciz " ++ show js_src ++ "\n" + ] + ] + ) + <> semi + import_attr = + text "__attribute__" + <> parens + ( parens + ( hsep + ( punctuate + comma + [ text k <> parens (doubleQuotes (text v)) + | (k, v) <- + [("import_module", "ghc_wasm_jsffi"), ("import_name", import_name)] + ] + ) + ) + ) + import_proto = + import_res_ty <+> text import_name <> parens import_args <> semi + import_res_ty + | res_ty `eqType` unitTy = text "void" + | otherwise = text ("Hs" ++ ffiType res_ty) + import_arg_list = + [ text ("Hs" ++ ffiType arg_ty) <+> char 'a' <> int i + | (i, arg_ty) <- zip [1 ..] arg_tys + ] + import_args = case import_arg_list of + [] -> text "void" + _ -> hsep $ punctuate comma import_arg_list + cfun_proto = cfun_res_ty <+> ppr cfun_name <> parens cfun_args + cfun_ret + | res_ty `eqType` unitTy = cfun_call_import <> semi + | otherwise = text "return" <+> cfun_call_import <> semi + cfun_make_arg arg_ty arg_val = + text ("rts_get" ++ ffiType arg_ty) <> parens arg_val + cfun_make_ret ret_val + | res_ty `eqType` unitTy = ret_val + | otherwise = + text ("rts_mk" ++ ffiType res_ty) + -- We can cheat a little bit here since there's only + -- MainCapability in the single-threaded RTS anyway, so no + -- need to call rts_unsafeGetMyCapability(). + <> parens (hsep (punctuate comma [text "&MainCapability", ret_val])) + cfun_call_import = + cfun_make_ret + $ text import_name + <> parens + ( hsep + ( punctuate + comma + [ cfun_make_arg arg_ty (char 'a' <> int n) + | (arg_ty, n) <- zip arg_tys [1 ..] + ] + ) + ) + cfun_res_ty + | res_ty `eqType` unitTy = text "void" + | otherwise = text "HaskellObj" + cfun_arg_list = + [text "HaskellObj" <+> char 'a' <> int n | n <- [1 .. length arg_tys]] + cfun_args = case cfun_arg_list of + [] -> text "void" + _ -> hsep $ punctuate comma cfun_arg_list + c_doc = + commonCDecls + $+$ import_asm + $+$ import_attr + $+$ import_proto + $+$ cfun_proto + $+$ braces cfun_ret + +{- + +Note [Desugaring JSFFI static export] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A JSFFI static export wraps a top-level Haskell binding as a wasm +module export that can be called in JavaScript as an async/sync +function: + +foreign export javascript "plus" + (+) :: Int -> Int -> Int + +Just like generating C stub for a JSFFI import, we need to generate C +stub for a JSFFI export as well: + +__attribute__((export_name("plus"))) +HsJSVal plus(HsInt a1, HsInt a2) { ... } + +The generated C stub function would be exported as __exports.plus and +can be called in JavaScript. By default, it's exported as an async +function, so the C stub would always return an HsJSVal which +represents the result Promise; in case of a sync export (using "plus +sync" instead of "plus"), it returns the original result type. + +The C stub function body applies the function closure to arguments, +wrap it with a runIO/runNonIO top handler function, then schedules +Haskell computation to happen, then fetches the result. In case of an +async export, the top handler creates a JavaScript Promise that stands +for Haskell evaluation result, and the Promise will eventually be +resolved with the result or rejected with an exception. That Promise +is what we return in the C stub function. See +Note [Async JSFFI scheduler] for detailed explanation. + +At link time, you need to pass -optl-Wl,--export=plus,--export=... to +specify your entrypoint function symbols as roots of wasm-ld link-time +garbage collection. As for the auto-generated exports when desugaring +the JSFFI dynamic exports, they will be transitively included as well +due to the export_name attribute. + +-} + +dsWasmJSExport :: + Id -> + Coercion -> + CLabelString -> + DsM (CHeader, CStub, String, [Id], [Binding]) +dsWasmJSExport fn_id co str = dsWasmJSExport' sync (Just fn_id) co ext_name + where + (sync, ext_name) = case words $ unpackFS str of + [ext_name] -> (Async, ext_name) + [ext_name, "sync"] -> (Sync, ext_name) + _ -> panic "dsWasmJSExport: unrecognized label string" + +dsWasmJSExport' :: + Synchronicity -> + Maybe Id -> + Coercion -> + String -> + DsM (CHeader, CStub, String, [Id], [Binding]) +dsWasmJSExport' sync m_fn_id co ext_name = do + let ty = coercionRKind co + (_, fun_ty) = tcSplitForAllInvisTyVars ty + (arg_tys, orig_res_ty) = tcSplitFunTys fun_ty + (res_ty, is_io) = case tcSplitIOType_maybe orig_res_ty of + Just (_, res_ty) -> (res_ty, True) + Nothing -> (orig_res_ty, False) + res_ty_str = ffiType res_ty + top_handler_mod = case sync of + Sync -> "GHC.Internal.TopHandler" + Async -> "GHC.Internal.Wasm.Prim.Exports" + top_handler_name + | is_io = "runIO" + | otherwise = "runNonIO" + -- In case of sync export, we use the normal C FFI tophandler + -- functions. They would call flushStdHandles in case of uncaught + -- exception but not in normal cases, but we want flushStdHandles to + -- be called so that there are less run-time surprises for users, + -- and that's what our tophandler functions already do. + -- + -- So for each sync export, we first wrap the computation with a C + -- FFI tophandler, and then sequence it with flushStdHandles using + -- (<*) :: IO a -> IO b -> IO a. But it's trickier to call (<*) + -- using RTS API given type class dictionary is involved, so we'll + -- just use finally. + finally_id <- + lookupGhcInternalVarId + "GHC.Internal.Control.Exception.Base" + "finally" + flushStdHandles_id <- + lookupGhcInternalVarId + "GHC.Internal.TopHandler" + "flushStdHandles" + promiseRes_id <- + lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" + $ "js_promiseResolve" + ++ res_ty_str + top_handler_id <- lookupGhcInternalVarId top_handler_mod top_handler_name + let ppr_closure c = ppr c <> text "_closure" + mk_extern_closure_decl c = + text "extern StgClosure" <+> ppr_closure c <> semi + gc_root_closures = maybeToList m_fn_id ++ case sync of + -- In case of C FFI top handlers, they are already declared in + -- RtsAPI.h and registered as GC roots in initBuiltinGcRoots. + -- flushStdHandles is already registered but somehow the C + -- stub can't access its declaration, won't hurt to declare it + -- again here. + Sync -> [finally_id, flushStdHandles_id] + Async -> [top_handler_id, promiseRes_id] + extern_closure_decls = vcat $ map mk_extern_closure_decl $ top_handler_id : gc_root_closures + cstub_attr = + text "__attribute__" + <> parens + (parens $ text "export_name" <> parens (doubleQuotes $ text ext_name)) + cstub_arg_list = + [ text ("Hs" ++ ffiType (scaledThing arg_ty)) <+> char 'a' <> int i + | (i, arg_ty) <- zip [1 ..] arg_tys + ] + cstub_args = case cstub_arg_list of + [] -> text "void" + _ -> hsep $ punctuate comma cstub_arg_list + cstub_proto + | Sync <- sync, + res_ty `eqType` unitTy = + text "void" <+> text ext_name <> parens cstub_args + | Sync <- sync = + text ("Hs" ++ res_ty_str) <+> text ext_name <> parens cstub_args + | Async <- sync = + text "HsJSVal" <+> text ext_name <> parens cstub_args + c_closure c = char '&' <> ppr_closure c + c_call fn args = text fn <> parens (hsep $ punctuate comma args) + c_rts_apply = + Data.List.foldl1' $ \fn arg -> c_call "rts_apply" [text "cap", fn, arg] + apply_top_handler expr = case sync of + Sync -> + c_rts_apply + [ c_closure finally_id, + c_rts_apply [c_closure top_handler_id, expr], + c_closure flushStdHandles_id + ] + Async -> + c_rts_apply [c_closure top_handler_id, c_closure promiseRes_id, expr] + cstub_ret + | Sync <- sync, res_ty `eqType` unitTy = empty + | Sync <- sync = text $ "return rts_get" ++ res_ty_str ++ "(ret);" + | Async <- sync = text "return rts_getJSVal(ret);" + (cstub_target, real_args) + | Just fn_id <- m_fn_id = (c_closure fn_id, zip [1 ..] arg_tys) + | otherwise = (text "(HaskellObj)deRefStablePtr(a1)", zip [2 ..] $ tail arg_tys) + cstub_body = + vcat + [ lbrace, + text "Capability *cap = rts_lock();", + text "HaskellObj ret;", + c_call + "rts_inCall" + [ text "&cap", + apply_top_handler + $ c_rts_apply + $ cstub_target + : [ c_call + ("rts_mk" ++ ffiType (scaledThing arg_ty)) + [text "cap", char 'a' <> int i] + | (i, arg_ty) <- real_args + ], + text "&ret" + ] + <> semi, + c_call "rts_checkSchedStatus" [doubleQuotes (text ext_name), text "cap"] + <> semi, + text "rts_unlock(cap);", + cstub_ret, + rbrace + ] + cstub = + commonCDecls + $+$ extern_closure_decls + $+$ cstub_attr + $+$ cstub_proto + $+$ cstub_body + pure (CHeader commonCDecls, CStub cstub [] [], "", gc_root_closures, []) + +lookupGhcInternalVarId :: FastString -> String -> DsM Id +lookupGhcInternalVarId m v = do + n <- lookupOrig (mkGhcInternalModule m) (mkVarOcc v) + dsLookupGlobalId n + +lookupGhcInternalTyCon :: FastString -> String -> DsM TyCon +lookupGhcInternalTyCon m t = do + n <- lookupOrig (mkGhcInternalModule m) (mkTcOcc t) + dsLookupTyCon n + +ffiType :: Type -> String +ffiType = occNameString . getOccName . fst . splitTyConApp + +commonCDecls :: SDoc +commonCDecls = + vcat + [ text "typedef __externref_t HsJSVal;", + text "HsJSVal rts_getJSVal(HaskellObj);", + text "HaskellObj rts_mkJSVal(Capability*, HsJSVal);" + ] diff --git a/GHC/HsToCore/GuardedRHSs.hs b/GHC/HsToCore/GuardedRHSs.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/GuardedRHSs.hs @@ -0,0 +1,162 @@ + + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Matching guarded right-hand-sides (GRHSs) +-} + +module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsLocalBinds ) +import {-# SOURCE #-} GHC.HsToCore.Match ( matchSinglePatVar ) + +import GHC.Hs +import GHC.Core.Make +import GHC.Core +import GHC.Core.Utils (bindNonRec) + +import GHC.HsToCore.Monad +import GHC.HsToCore.Utils +import GHC.HsToCore.Pmc.Types ( Nablas ) +import GHC.Core.Type ( Type ) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Core.Multiplicity +import Data.List.NonEmpty ( NonEmpty ) +import qualified GHC.Data.List.NonEmpty as NE + +{- +@dsGuarded@ is used for GRHSs. +It desugars: +\begin{verbatim} + | g1 -> e1 + ... + | gn -> en + where binds +\end{verbatim} +producing an expression with a runtime error in the corner case if +necessary. The type argument gives the type of the @ei@. +-} + +dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Nablas -> DsM CoreExpr +dsGuarded grhss rhs_ty rhss_nablas = do + match_result <- dsGRHSs PatBindRhs grhss rhs_ty rhss_nablas + error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty + (text "pattern binding") + extractMatchResult match_result error_expr + +-- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@. + +dsGRHSs :: HsMatchContextRn + -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs + -> Type -- ^ Type of RHS + -> NonEmpty Nablas -- ^ Refined pattern match checking + -- models, one for the pattern part and + -- one for each GRHS. + -> DsM (MatchResult CoreExpr) +dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas + = do { match_results <- assert (length grhss == length rhss_nablas) $ + NE.zipWithM (dsGRHS hs_ctx rhs_ty) rhss_nablas grhss + ; nablas <- getPmNablas + -- We need to remember the Nablas from the particular match context we + -- are in, which might be different to when dsLocalBinds is actually + -- called. + ; let ds_binds = updPmNablas nablas . dsLocalBinds binds + match_result1 = foldr1 combineMatchResults match_results + match_result2 = adjustMatchResultDs ds_binds match_result1 + -- NB: nested dsLet inside matchResult + ; return match_result2 } + +dsGRHS :: HsMatchContextRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc) + -> DsM (MatchResult CoreExpr) +dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs)) + = updPmNablas rhs_nablas $ + matchGuards (map unLoc guards) hs_ctx rhs rhs_ty + +{- +************************************************************************ +* * +* matchGuard : make a MatchResult CoreExpr CoreExpr from a guarded RHS * +* * +************************************************************************ +-} + +matchGuards :: [GuardStmt GhcTc] -- Guard + -> HsMatchContextRn -- Context + -> LHsExpr GhcTc -- RHS + -> Type -- Type of RHS of guard + -> DsM (MatchResult CoreExpr) + +-- See comments with HsExpr.Stmt re what a BodyStmt means +-- Here we must be in a guard context (not do-expression, nor list-comp) + +matchGuards [] _ rhs _ + = do { core_rhs <- dsLExpr rhs + ; return (cantFailMatchResult core_rhs) } + + -- BodyStmts must be guards + -- Turn an "otherwise" guard is a no-op. This ensures that + -- you don't get a "non-exhaustive eqns" message when the guards + -- finish in "otherwise". + -- NB: The success of this clause depends on the typechecker not + -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors + -- If it does, you'll get bogus overlap warnings +matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty + | Just addTicks <- isTrueLHsExpr e = do + match_result <- matchGuards stmts ctx rhs rhs_ty + return (adjustMatchResultDs addTicks match_result) +matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do + match_result <- matchGuards stmts ctx rhs rhs_ty + pred_expr <- dsLExpr expr + return (mkGuardedMatchResult pred_expr match_result) + +matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do + ldi_nablas <- getPmNablas + match_result <- matchGuards stmts ctx rhs rhs_ty + -- Propagate long-distance information when desugaring let bindings, e.g. + -- + -- f r@(K1 {}) + -- | let g = fld r + -- = g + -- + -- Failing to do so resulted in #25749. + return (adjustMatchResultDs (updPmNablas ldi_nablas . dsLocalBinds binds) match_result) + -- NB the dsLet occurs inside the match_result + -- Reason: dsLet takes the body expression as its argument + -- so we can't desugar the bindings without the + -- body expression in hand + +matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do + let upat = unLoc pat + match_var <- selectMatchVar ManyTy upat + -- We only allow unrestricted patterns in guards, hence the `Many` + -- above. It isn't clear what linear patterns would mean, maybe we will + -- figure it out in the future. + + match_result <- matchGuards stmts ctx rhs rhs_ty + core_rhs <- dsLExpr bind_rhs + match_result' <- + matchSinglePatVar match_var (Just core_rhs) (StmtCtxt $ PatGuard ctx) + pat rhs_ty match_result + return $ bindNonRec match_var core_rhs <$> match_result' + +matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt" +matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt" +matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt" +matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" +matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ = + panic "matchGuards ApplicativeLastStmt" + +{- +Should {\em fail} if @e@ returns @D@ +\begin{verbatim} +f x | p <- e', let C y# = e, f y# = r1 + | otherwise = r2 +\end{verbatim} +-} diff --git a/GHC/HsToCore/ListComp.hs b/GHC/HsToCore/ListComp.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/ListComp.hs @@ -0,0 +1,665 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring list comprehensions, monad comprehensions and array comprehensions +-} + +module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr ) + +import GHC.Hs +import GHC.Hs.Syn.Type +import GHC.Core +import GHC.Core.Make + +import GHC.HsToCore.Monad -- the monadery used in the desugarer +import GHC.HsToCore.Utils + +import GHC.Driver.DynFlags +import GHC.Core.Utils +import GHC.Types.Id +import GHC.Core.Type +import GHC.Builtin.Types +import GHC.HsToCore.Match +import GHC.Builtin.Names +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Tc.Utils.TcType +import GHC.Data.List.SetOps( getNth ) + +import Data.Foldable ( toList ) + +{- +List comprehensions may be desugared in one of two ways: ``ordinary'' +(as you would expect if you read SLPJ's book) and ``with foldr/build +turned on'' (if you read Gill {\em et al.}'s paper on the subject). + +There will be at least one ``qualifier'' in the input. +-} + +dsListComp :: [ExprLStmt GhcTc] + -> Type -- Type of entire list + -> DsM CoreExpr +dsListComp lquals res_ty = do + dflags <- getDynFlags + let quals = map unLoc lquals + elt_ty = case tcTyConAppArgs res_ty of + [elt_ty] -> elt_ty + _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals) + + if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags + -- Either rules are switched off, or we are ignoring what there are; + -- Either way foldr/build won't happen, so use the more efficient + -- Wadler-style desugaring + || isParallelComp quals + -- Foldr-style desugaring can't handle parallel list comprehensions + then deListComp quals (mkNilExpr elt_ty) + else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals) + -- Foldr/build should be enabled, so desugar + -- into foldrs and builds + + where + -- We must test for ParStmt anywhere, not just at the head, because an extension + -- to list comprehensions would be to add brackets to specify the associativity + -- of qualifier lists. This is really easy to do by adding extra ParStmts into the + -- mix of possibly a single element in length, so we do this to leave the possibility open + isParallelComp = any isParallelStmt + + isParallelStmt (ParStmt {}) = True + isParallelStmt _ = False + + +-- This function lets you desugar a inner list comprehension and a list of the binders +-- of that comprehension that we need in the outer comprehension into such an expression +-- and the type of the elements that it outputs (tuples of binders) +dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type) +dsInnerListComp (ParStmtBlock _ stmts bndrs _) + = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs + list_ty = mkListTy bndrs_tuple_type + + -- really use original bndrs below! + ; expr <- dsListComp (stmts ++ [noLocA $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty + + ; return (expr, bndrs_tuple_type) } + +-- This function factors out commonality between the desugaring strategies for GroupStmt. +-- Given such a statement it gives you back an expression representing how to compute the transformed +-- list and the tuple that you need to bind from that list in order to proceed with your desugaring +dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc) +dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_using = using }) = do + let (from_bndrs, to_bndrs) = unzip binderMap + + let from_bndrs_tys = map idType from_bndrs + to_bndrs_tys = map idType to_bndrs + + to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys + + -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders + (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts + from_bndrs noSyntaxExpr) + + -- Work out what arguments should be supplied to that expression: i.e. is an extraction + -- function required? If so, create that desugared function and add to arguments + usingExpr' <- dsLExpr using + usingArgs' <- case by of + Nothing -> return [expr'] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam' <- matchTuple from_bndrs by_e' + ; return [lam', expr'] } + + -- Create an unzip function for the appropriate arity and element types and find "map" + unzip_stuff' <- mkUnzipBind form from_bndrs_tys + map_id <- dsLookupGlobalId mapName + + -- Generate the expressions to build the grouped list + let -- First we apply the grouping function to the inner list + inner_list_expr' = mkApps usingExpr' usingArgs' + -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists + -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and + -- the "b" to be a tuple of "to" lists! + -- Then finally we bind the unzip function around that expression + bound_unzipped_inner_list_expr' + = case unzip_stuff' of + Nothing -> inner_list_expr' + Just (unzip_fn', unzip_rhs') -> + Let (Rec [(unzip_fn', unzip_rhs')]) $ + mkApps (Var map_id) $ + [ Type (mkListTy from_tup_ty) + , Type to_bndrs_tup_ty + , Var unzip_fn' + , inner_list_expr' ] + + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold lists rather than single values + let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '! + return (bound_unzipped_inner_list_expr', pat) + +dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt" + +{- +************************************************************************ +* * +* Ordinary desugaring of list comprehensions * +* * +************************************************************************ + +Just as in Phil's chapter~7 in SLPJ, using the rules for +optimally-compiled list comprehensions. This is what Kevin followed +as well, and I quite happily do the same. The TQ translation scheme +transforms a list of qualifiers (either boolean expressions or +generators) into a single expression which implements the list +comprehension. Because we are generating 2nd-order polymorphic +lambda-calculus, calls to NIL and CONS must be applied to a type +argument, as well as their usual value arguments. +\begin{verbatim} +TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >> + +(Rule C) +TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <> TE <> + +(Rule B) +TQ << [ e | b , qs ] ++ L >> = + if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >> + +(Rule A') +TQ << [ e | p <- L1, qs ] ++ L2 >> = + letrec + h = \ u1 -> + case u1 of + [] -> TE << L2 >> + (u2 : u3) -> + (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2) + [] (h u3) + in + h ( TE << L1 >> ) + +"h", "u1", "u2", and "u3" are new variables. +\end{verbatim} + +@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@ +is the TE translation scheme. Note that we carry around the @L@ list +already desugared. @dsListComp@ does the top TE rule mentioned above. + +To the above, we add an additional rule to deal with parallel list +comprehensions. The translation goes roughly as follows: + [ e | p1 <- e11, let v1 = e12, p2 <- e13 + | q1 <- e21, let v2 = e22, q2 <- e23] + => + [ e | ((x1, .., xn), (y1, ..., ym)) <- + zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13] + [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]] +where (x1, .., xn) are the variables bound in p1, v1, p2 + (y1, .., ym) are the variables bound in q1, v2, q2 + +In the translation below, the ParStmt branch translates each parallel branch +into a sub-comprehension, and desugars each independently. The resulting lists +are fed to a zip function, we create a binding for all the variables bound in all +the comprehensions, and then we hand things off the desugarer for bindings. +The zip function is generated here a) because it's small, and b) because then we +don't have to deal with arbitrary limits on the number of zip functions in the +prelude, nor which library the zip function came from. +The introduced tuples are Boxed, but only because I couldn't get it to work +with the Unboxed variety. +-} + +deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr + +deListComp [] _ = panic "deListComp" + +deListComp (LastStmt _ body _ _ : quals) list + = -- Figure 7.4, SLPJ, p 135, rule C above + assert (null quals) $ + do { core_body <- dsLExpr body + ; return (mkConsExpr (exprType core_body) core_body list) } + + -- Non-last: must be a guard +deListComp (BodyStmt _ guard _ _ : quals) list = do -- rule B above + core_guard <- dsLExpr guard + core_rest <- deListComp quals list + return (mkIfThenElse core_guard core_rest list) + +-- [e | let B, qs] = let B in [e | qs] +deListComp (LetStmt _ binds : quals) list = do + core_rest <- deListComp quals list + dsLocalBinds binds core_rest + +deListComp (stmt@(TransStmt {}) : quals) list = do + (inner_list_expr, pat) <- dsTransStmt stmt + deBindComp pat inner_list_expr quals list + +deListComp (BindStmt _ pat list1 : quals) core_list2 = do -- rule A' above + core_list1 <- dsLExpr list1 + deBindComp pat core_list1 quals core_list2 + +deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list + = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs + ; let (exps, qual_tys) = unzip exps_and_qual_tys + + ; (zip_fn, zip_rhs) <- mkZipBind (toList qual_tys) + + -- Deal with [e | pat <- zip l1 .. ln] in example above + ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) (toList exps))) + quals list } + where + bndrs_s = [bs | ParStmtBlock _ _ bs _ <- toList stmtss_w_bndrs] + + -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above + pat = mkBigLHsPatTupId pats + pats = map mkBigLHsVarPatTupId bndrs_s + +deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" + +deListComp (XStmtLR ApplicativeStmt {} : _) _ = + panic "deListComp ApplicativeStmt" + +deBindComp :: LPat GhcTc + -> CoreExpr + -> [ExprStmt GhcTc] + -> CoreExpr + -> DsM (Expr Id) +deBindComp pat core_list1 quals core_list2 = do + let u3_ty@u1_ty = exprType core_list1 -- two names, same thing + + -- u1_ty is a [alpha] type, and u2_ty = alpha + let u2_ty = hsLPatType pat + + let res_ty = exprType core_list2 + h_ty = u1_ty `mkVisFunTyMany` res_ty + + -- no representation polymorphism here, as list comprehensions + -- don't work with RebindableSyntax. NB: These are *not* monad comps. + [h, u1, u2, u3] <- newSysLocalsDs $ map unrestricted [h_ty, u1_ty, u2_ty, u3_ty] + + -- the "fail" value ... + let + core_fail = App (Var h) (Var u3) + letrec_body = App (Var h) core_list1 + + rest_expr <- deListComp quals core_fail + core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) ManyTy pat rest_expr core_fail + + let + rhs = Lam u1 $ + Case (Var u1) u1 res_ty + [Alt (DataAlt nilDataCon) [] core_list2 + ,Alt (DataAlt consDataCon) [u2, u3] core_match] + -- Increasing order of tag + + return (Let (Rec [(h, rhs)]) letrec_body) + +{- +************************************************************************ +* * +* Foldr/Build desugaring of list comprehensions * +* * +************************************************************************ + +@dfListComp@ are the rules used with foldr/build turned on: + +\begin{verbatim} +TE[ e | ] c n = c e n +TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n +TE[ e | p <- l , q ] c n = let + f = \ x b -> case x of + p -> TE[ e | q ] c b + _ -> b + in + foldr f n l +\end{verbatim} +-} + +dfListComp :: Id -> Id -- 'c' and 'n' + -> [ExprStmt GhcTc] -- the rest of the qual's + -> DsM CoreExpr + +dfListComp _ _ [] = panic "dfListComp" + +dfListComp c_id n_id (LastStmt _ body _ _ : quals) + = assert (null quals) $ + do { core_body <- dsLExpr body + ; return (mkApps (Var c_id) [core_body, Var n_id]) } + + -- Non-last: must be a guard +dfListComp c_id n_id (BodyStmt _ guard _ _ : quals) = do + core_guard <- dsLExpr guard + core_rest <- dfListComp c_id n_id quals + return (mkIfThenElse core_guard core_rest (Var n_id)) + +dfListComp c_id n_id (LetStmt _ binds : quals) = do + -- new in 1.3, local bindings + core_rest <- dfListComp c_id n_id quals + dsLocalBinds binds core_rest + +dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do + (inner_list_expr, pat) <- dsTransStmt stmt + -- Anyway, we bind the newly grouped list via the generic binding function + dfBindComp c_id n_id (pat, inner_list_expr) quals + +dfListComp c_id n_id (BindStmt _ pat list1 : quals) = do + -- evaluate the two lists + core_list1 <- dsLExpr list1 + + -- Do the rest of the work in the generic binding builder + dfBindComp c_id n_id (pat, core_list1) quals + +dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" +dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" +dfListComp _ _ (XStmtLR ApplicativeStmt {} : _) = + panic "dfListComp ApplicativeStmt" + +dfBindComp :: Id -> Id -- 'c' and 'n' + -> (LPat GhcTc, CoreExpr) + -> [ExprStmt GhcTc] -- the rest of the qual's + -> DsM CoreExpr +dfBindComp c_id n_id (pat, core_list1) quals = do + -- find the required type + let x_ty = hsLPatType pat + let b_ty = idType n_id + + -- create some new local id's + b <- newSysLocalMDs b_ty + x <- newSysLocalMDs x_ty + + -- build rest of the comprehension + core_rest <- dfListComp c_id b quals + + -- build the pattern match + core_expr <- matchSimply (Var x) (StmtCtxt (HsDoStmt ListComp)) ManyTy + pat core_rest (Var b) + + -- now build the outermost foldr, and return + mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1 + +{- +************************************************************************ +* * +\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring} +* * +************************************************************************ +-} + +mkZipBind :: [Type] -> DsM (Id, CoreExpr) +-- mkZipBind [t1, t2] +-- = (zip, \as1:[t1] as2:[t2] +-- -> case as1 of +-- [] -> [] +-- (a1:as'1) -> case as2 of +-- [] -> [] +-- (a2:as'2) -> (a1, a2) : zip as'1 as'2)] + +mkZipBind elt_tys = do + ass <- newSysLocalsMDs elt_list_tys + as' <- newSysLocalsMDs elt_tys + as's <- newSysLocalsMDs elt_list_tys + + zip_fn <- newSysLocalMDs zip_fn_ty + + let inner_rhs = mkConsExpr elt_tuple_ty + (mkBigCoreVarTup as') + (mkVarApps (Var zip_fn) as's) + zip_body = foldr mk_case inner_rhs (zip3 ass as' as's) + + return (zip_fn, mkLams ass zip_body) + where + elt_list_tys = map mkListTy elt_tys + elt_tuple_ty = mkBigCoreTupTy elt_tys + elt_tuple_list_ty = mkListTy elt_tuple_ty + + zip_fn_ty = mkVisFunTysMany elt_list_tys elt_tuple_list_ty + + mk_case (as, a', as') rest + = Case (Var as) as elt_tuple_list_ty + [ Alt (DataAlt nilDataCon) [] (mkNilExpr elt_tuple_ty) + , Alt (DataAlt consDataCon) [a', as'] rest] + -- Increasing order of tag + + +mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr)) +-- mkUnzipBind [t1, t2] +-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2]) +-- -> case ax of +-- (x1, x2) -> case axs of +-- (xs1, xs2) -> (x1 : xs1, x2 : xs2)) +-- ([], []) +-- ys) +-- +-- We use foldr here in all cases, even if rules are turned off, because we may as well! +mkUnzipBind ThenForm _ + = return Nothing -- No unzipping for ThenForm +mkUnzipBind _ elt_tys + = do { ax <- newSysLocalMDs elt_tuple_ty + ; axs <- newSysLocalMDs elt_list_tuple_ty + ; ys <- newSysLocalMDs elt_tuple_list_ty + ; xs <- newSysLocalsMDs elt_tys + ; xss <- newSysLocalsMDs elt_list_tys + + ; unzip_fn <- newSysLocalMDs unzip_fn_ty + + ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) + concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) + tupled_concat_expression = mkBigCoreTup concat_expressions + + ; folder_body_inner_case <- mkBigTupleCase xss tupled_concat_expression (Var axs) + ; folder_body_outer_case <- mkBigTupleCase xs folder_body_inner_case (Var ax) + ; let folder_body = mkLams [ax, axs] folder_body_outer_case + + ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) + ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } + where + elt_tuple_ty = mkBigCoreTupTy elt_tys + elt_tuple_list_ty = mkListTy elt_tuple_ty + elt_list_tys = map mkListTy elt_tys + elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys + + unzip_fn_ty = elt_tuple_list_ty `mkVisFunTyMany` elt_list_tuple_ty + + mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail + +-- Translation for monad comprehensions + +-- Entry point for monad comprehension desugaring +dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr +dsMonadComp stmts = dsMcStmts stmts + +dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr +dsMcStmts [] = panic "dsMcStmts" +dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDsA loc (dsMcStmt stmt lstmts) + +--------------- +dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr + +dsMcStmt (LastStmt _ body _ ret_op) stmts + = assert (null stmts) $ + do { body' <- dsLExpr body + ; dsSyntaxExpr ret_op [body'] } + +-- [ .. | let binds, stmts ] +dsMcStmt (LetStmt _ binds) stmts + = do { rest <- dsMcStmts stmts + ; dsLocalBinds binds rest } + +-- [ .. | a <- m, stmts ] +dsMcStmt (BindStmt xbs pat rhs) stmts + = do { rhs' <- dsLExpr rhs + ; dsMcBindStmt pat rhs' (xbstc_bindOp xbs) (xbstc_failOp xbs) (xbstc_boundResultType xbs) stmts } + +-- Apply `guard` to the `exp` expression +-- +-- [ .. | exp, stmts ] +-- +dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts + = do { exp' <- dsLExpr exp + ; rest <- dsMcStmts stmts + ; guard_exp' <- dsSyntaxExpr guard_exp [exp'] + ; dsSyntaxExpr then_exp [guard_exp', rest] } + +-- Group statements desugar like this: +-- +-- [| (q, then group by e using f); rest |] +-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> +-- case unzip n_tup of qv' -> [| rest |] +-- +-- where variables (v1:t1, ..., vk:tk) are bound by q +-- qv = (v1, ..., vk) +-- qt = (t1, ..., tk) +-- (>>=) :: m2 a -> (a -> m3 b) -> m3 b +-- f :: forall a. (a -> t) -> m1 a -> m2 (n a) +-- n_tup :: n qt +-- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n) + +dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs + , trS_by = by, trS_using = using + , trS_ret = return_op, trS_bind = bind_op + , trS_ext = n_tup_ty' -- n (a,b,c) + , trS_fmap = fmap_op, trS_form = form }) stmts_rest + = do { let (from_bndrs, to_bndrs) = unzip bndrs + + ; let from_bndr_tys = map idType from_bndrs -- Types ty + + + -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders + ; expr' <- dsInnerMonadComp stmts from_bndrs return_op + + -- Work out what arguments should be supplied to that expression: i.e. is an extraction + -- function required? If so, create that desugared function and add to arguments + ; usingExpr' <- dsLExpr using + ; usingArgs' <- case by of + Nothing -> return [expr'] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam' <- matchTuple from_bndrs by_e' + ; return [lam', expr'] } + + -- Generate the expressions to build the grouped list + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold monads rather than single values + ; body <- dsMcStmts stmts_rest + ; n_tup_var' <- newSysLocalMDs n_tup_ty' + ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys + ; let rhs' = mkApps usingExpr' usingArgs' + ; body' <- mkBigTupleCase to_bndrs body tup_n_expr' + + ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } + +-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel +-- statements, for example: +-- +-- [ body | qs1 | qs2 | qs3 ] +-- -> [ body | (bndrs1, (bndrs2, bndrs3)) +-- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ] +-- +-- where `mzip` has type +-- mzip :: forall a b. m a -> m b -> m (a,b) +-- NB: we need a polymorphic mzip because we call it several times + +dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest + = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) + ; mzip_op' <- dsExpr mzip_op + + ; let parStmtBlockIds :: ParStmtBlock GhcTc GhcTc -> [Id] + parStmtBlockIds = \ case + ParStmtBlock _ _ bs _ -> bs + -- The pattern variables + pats = fmap (mkBigLHsVarPatTupId . parStmtBlockIds) blocks + -- Pattern with tuples of variables + -- [v1,v2,v3] => (v1, (v2, v3)) + pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats + (rhs, _) = foldr1 (\(e1,t1) (e2,t2) -> + (mkApps mzip_op' [Type t1, Type t2, e1, e2], + mkBoxedTupleTy [t1,t2])) + exps_w_tys + + ; dsMcBindStmt pat rhs bind_op Nothing bind_ty stmts_rest } + where + ds_inner :: ParStmtBlock GhcTc GhcTc -> DsM (CoreExpr, Type) + ds_inner (ParStmtBlock _ stmts bndrs return_op) + = do { exp <- dsInnerMonadComp stmts bndrs return_op + ; return (exp, mkBigCoreVarTupTy bndrs) } + +dsMcStmt stmt@(XStmtLR ApplicativeStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) +dsMcStmt stmt@(RecStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) + +matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr +-- (matchTuple [a,b,c] body) +-- returns the Core term +-- \x. case x of (a,b,c) -> body +matchTuple ids body + = do { tup_id <- newSysLocalMDs (mkBigCoreVarTupTy ids) + ; tup_case <- mkBigTupleCase ids body (Var tup_id) + ; return (Lam tup_id tup_case) } + +-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a +-- desugared `CoreExpr` +dsMcBindStmt :: LPat GhcTc + -> CoreExpr -- ^ the desugared rhs of the bind statement + -> SyntaxExpr GhcTc + -> Maybe (SyntaxExpr GhcTc) + -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T + -> [ExprLStmt GhcTc] + -> DsM CoreExpr +dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts + = do { var <- selectSimpleMatchVarL ManyTy pat + ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat + res1_ty (MR_Infallible $ dsMcStmts stmts) + -- NB: dsMcStmts needs to happen inside matchSinglePatVar, and not + -- before it, so that long-distance information is properly threaded. + -- See Note [Long-distance information in do notation] in GHC.HsToCore.Expr. + ; match_code <- dsHandleMonadicFailure MonadComp pat res1_ty match fail_op + ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } + +-- Desugar nested monad comprehensions, for example in `then..` constructs +-- dsInnerMonadComp quals [a,b,c] ret_op +-- returns the desugaring of +-- [ (a,b,c) | quals ] + +dsInnerMonadComp :: [ExprLStmt GhcTc] + -> [Id] -- Return a tuple of these variables + -> SyntaxExpr GhcTc -- The monomorphic "return" operator + -> DsM CoreExpr +dsInnerMonadComp stmts bndrs ret_op + = dsMcStmts (stmts ++ + [noLocA (LastStmt noExtField (mkBigLHsVarTupId bndrs) Nothing ret_op)]) + + +-- The `unzip` function for `GroupStmt` in a monad comprehensions +-- +-- unzip :: m (a,b,..) -> (m a,m b,..) +-- unzip m_tuple = ( liftM selN1 m_tuple +-- , liftM selN2 m_tuple +-- , .. ) +-- +-- mkMcUnzipM fmap ys [t1, t2] +-- = ( fmap (selN1 :: (t1, t2) -> t1) ys +-- , fmap (selN2 :: (t1, t2) -> t2) ys ) + +mkMcUnzipM :: TransForm + -> HsExpr GhcTc -- fmap + -> Id -- Of type n (a,b,c) + -> [Type] -- [a,b,c] (not representation-polymorphic) + -> DsM CoreExpr -- Of type (n a, n b, n c) +mkMcUnzipM ThenForm _ ys _ + = return (Var ys) -- No unzipping to do + +mkMcUnzipM _ fmap_op ys elt_tys + = do { fmap_op' <- dsExpr fmap_op + ; xs <- newSysLocalsMDs elt_tys + ; let tup_ty = mkBigCoreTupTy elt_tys + ; tup_xs <- newSysLocalMDs tup_ty + + ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b + [ Type tup_ty, Type (getNth elt_tys i) + , mk_sel i, Var ys] + + mk_sel n = Lam tup_xs $ + mkBigTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) + + ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } diff --git a/GHC/HsToCore/Match.hs b/GHC/HsToCore/Match.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Match.hs @@ -0,0 +1,1321 @@ + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The @match@ function +-} + +module GHC.HsToCore.Match + ( match, matchEquations, matchWrapper, matchSimply + , matchSinglePat, matchSinglePatVar + ) +where + +import GHC.Prelude +import GHC.Platform + +import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr) + +import GHC.Types.Basic + +import GHC.Types.SourceText + ( FractionalLit, + IntegralLit(il_value), + negateFractionalLit, + integralFractionalLit ) +import GHC.Driver.DynFlags +import GHC.Hs +import GHC.Hs.Syn.Type +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Monad +import GHC.HsToCore.Pmc +import GHC.HsToCore.Pmc.Utils +import GHC.HsToCore.Pmc.Types ( Nablas ) +import GHC.HsToCore.Monad +import GHC.HsToCore.Binds +import GHC.HsToCore.GuardedRHSs +import GHC.HsToCore.Utils +import GHC.HsToCore.Errors.Types +import GHC.HsToCore.Match.Constructor +import GHC.HsToCore.Match.Literal + +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType, eqTypes ) +import GHC.Core.Coercion ( eqCoercion ) +import GHC.Core.TyCon ( isNewTyCon ) +import GHC.Core.Multiplicity +import GHC.Builtin.Types + +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Types.SrcLoc + +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.FastString +import GHC.Types.Unique +import GHC.Types.Unique.DFM + +import Control.Monad ( zipWithM, unless ) +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map + +{- +************************************************************************ +* * + The main matching function +* * +************************************************************************ + +The function @match@ is basically the same as in the Wadler chapter +from "The Implementation of Functional Programming Languages", +except it is monadised, to carry around the name supply, info about +annotations, etc. + +Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns: +\begin{enumerate} +\item +A list of $n$ variable names, those variables presumably bound to the +$n$ expressions being matched against the $n$ patterns. Using the +list of $n$ expressions as the first argument showed no benefit and +some inelegance. + +\item +The second argument, a list giving the ``equation info'' for each of +the $m$ equations: +\begin{itemize} +\item +the $n$ patterns for that equation, and +\item +a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on +the front'' of the matching code, as in: +\begin{verbatim} +let +in +\end{verbatim} +\item +and finally: (ToDo: fill in) + +The right way to think about the ``after-match function'' is that it +is an embryonic @CoreExpr@ with a ``hole'' at the end for the +final ``else expression''. +\end{itemize} + +There is a data type, @EquationInfo@, defined in module @GHC.HsToCore.Monad@. + +An experiment with re-ordering this information about equations (in +particular, having the patterns available in column-major order) +showed no benefit. + +\item +A default expression---what to evaluate if the overall pattern-match +fails. This expression will (almost?) always be +a measly expression @Var@, unless we know it will only be used once +(as we do in @glue_success_exprs@). + +Leaving out this third argument to @match@ (and slamming in lots of +@Var "fail"@s) is a positively {\em bad} idea, because it makes it +impossible to share the default expressions. (Also, it stands no +chance of working in our post-upheaval world of @Locals@.) +\end{enumerate} + +Note: @match@ is often called via @matchWrapper@ (end of this module), +a function that does much of the house-keeping that goes with a call +to @match@. + +It is also worth mentioning the {\em typical} way a block of equations +is desugared with @match@. At each stage, it is the first column of +patterns that is examined. The steps carried out are roughly: +\begin{enumerate} +\item +Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add +bindings to the second component of the equation-info): +\item +Now {\em unmix} the equations into {\em blocks} [w\/ local function +@match_groups@], in which the equations in a block all have the same + match group. +(see ``the mixture rule'' in SLPJ). +\item +Call the right match variant on each block of equations; it will do the +appropriate thing for each kind of column-1 pattern. +\end{enumerate} + +We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) +than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). +And gluing the ``success expressions'' together isn't quite so pretty. + +This @match@ uses @tidyEqnInfo@ +to get `as'- and `twiddle'-patterns out of the way (tidying), before +applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em +un}mixes the equations], producing a list of equation-info +blocks, each block having as its first column patterns compatible with each other. + +Note [Match Ids] +~~~~~~~~~~~~~~~~ +Most of the matching functions take an Id or [Id] as argument. This Id +is the scrutinee(s) of the match. The desugared expression may +sometimes use that Id in a local binding or as a case binder. So it +should not have an External name; Lint rejects non-top-level binders +with External names (#13043). + +See also Note [Localise pattern binders] in GHC.HsToCore.Utils +-} + +type MatchId = Id -- See Note [Match Ids] + +match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with + -- ^ See Note [Match Ids] + -- + -- ^ Note that the Match Ids carry not only a name, but + -- ^ also the multiplicity at which each column has been + -- ^ type checked. + -> Type -- ^ Type of the case expression + -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below) + -> DsM (MatchResult CoreExpr) -- ^ Desugared result! + +match [] ty eqns = maybe (assertPprPanic (ppr ty)) combineEqnRhss $ nonEmpty eqns + +match (v:vs) ty eqns -- Eqns can be empty, but each equation is nonempty + = assertPpr (all (isInternalName . idName) vars) (ppr vars) $ + do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + -- Tidy the first pattern, generating + -- auxiliary bindings if necessary + ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns + -- Group the equations and match each group in turn + ; let grouped = groupEquations platform tidy_eqns + + -- print the view patterns that are commoned up to help debug + ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped) + + ; match_results <- match_groups grouped + ; return $ foldr (.) id aux_binds <$> + foldr1 combineMatchResults match_results + } + where + vars = v :| vs + + dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo + dropGroup = fmap snd + + match_groups :: [NonEmpty (PatGroup,EquationInfoNE)] -> DsM (NonEmpty (MatchResult CoreExpr)) + match_groups [] = matchEmpty v ty + match_groups (g:gs) = mapM match_group $ g :| gs + + match_group :: NonEmpty (PatGroup,EquationInfoNE) -> DsM (MatchResult CoreExpr) + match_group eqns@((group,_) :| _) + = case group of + PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) + PgSyn {} -> matchPatSyn vars ty (dropGroup eqns) + PgLit {} -> matchLiterals vars ty (ne $ subGroupOrd [(l,e) | (PgLit l, e) <- eqns']) + PgAny -> matchVariables vars ty (dropGroup eqns) + PgN {} -> matchNPats vars ty (dropGroup eqns) + PgOverS {}-> matchNPats vars ty (dropGroup eqns) + PgNpK {} -> matchNPlusKPats vars ty (dropGroup eqns) + PgBang -> matchBangs vars ty (dropGroup eqns) + PgCo {} -> matchCoercion vars ty (dropGroup eqns) + PgView {} -> matchView vars ty (dropGroup eqns) + where eqns' = NE.toList eqns + ne l = case NE.nonEmpty l of + Just nel -> nel + Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty" + + -- FIXME: we should also warn about view patterns that should be + -- commoned up but are not + + -- print some stuff to see what's getting grouped + -- use -dppr-debug to see the resolution of overloaded literals + debug eqns = + let gs = map (\group -> foldr (\ (p,_) -> \acc -> + case p of PgView e _ -> e:acc + _ -> acc) [] group) eqns + maybeWarn [] = return () + maybeWarn l = diagnosticDs (DsAggregatedViewExpressions l) + in + maybeWarn $ filter (not . null) gs + +matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr)) +-- See Note [Empty case alternatives] +matchEmpty var res_ty + = return [MR_Fallible mk_seq] + where + mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty + [Alt DEFAULT [] fail] + +matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) +-- Real true variables, just like in matchVar, SLPJ p 94 +-- No binding to do: they'll all be wildcards by now (done in tidy) +matchVariables (_ :| vars) ty eqns = match vars ty $ NE.toList $ shiftEqns eqns + +matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) +matchBangs (var :| vars) ty eqns + = do { match_result <- match (var:vars) ty $ NE.toList $ + decomposeFirstPat getBangPat <$> eqns + ; return (mkEvalMatchResult var ty match_result) } + +matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) +-- Apply the coercion to the match variable and then match that +matchCoercion (var :| vars) ty eqns@(eqn1 :| _) + = do { let XPat (CoPat co pat _) = firstPat eqn1 + ; let pat_ty' = hsPatType pat + ; var' <- newUniqueId var (idMult var) pat_ty' + ; match_result <- match (var':vars) ty $ NE.toList $ + decomposeFirstPat getCoPat <$> eqns + ; dsHsWrapper co $ \core_wrap -> do + { let bind = NonRec var' (core_wrap (Var var)) + ; return (mkCoLetMatchResult bind match_result) } } + +matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) +-- Apply the view function to the match variable and then match that +matchView (var :| vars) ty eqns@(eqn1 :| _) + = do { -- we could pass in the expr from the PgView, + -- but this needs to extract the pat anyway + -- to figure out the type of the fresh variable + let TcViewPat viewExpr pat = firstPat eqn1 + -- do the rest of the compilation + ; let pat_ty' = hsPatType pat + ; var' <- newUniqueId var (idMult var) pat_ty' + ; match_result <- match (var':vars) ty $ NE.toList $ + decomposeFirstPat getViewPat <$> eqns + -- compile the view expressions + ; viewExpr' <- dsExpr viewExpr + ; return (mkViewMatchResult var' + (mkCoreApp (text "matchView") viewExpr' (Var var)) + match_result) } + +-- decompose the first pattern and leave the rest alone +decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfoNE -> EquationInfoNE +decomposeFirstPat extract eqn@(EqnMatch { eqn_pat = pat }) = eqn{eqn_pat = fmap extract pat} +decomposeFirstPat _ (EqnDone {}) = panic "decomposeFirstPat" + +getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc +getCoPat (XPat (CoPat _ pat _)) = pat +getCoPat _ = panic "getCoPat" +getBangPat (BangPat _ pat ) = unLoc pat +getBangPat _ = panic "getBangPat" +getViewPat (TcViewPat _ pat) = pat +getViewPat _ = panic "getViewPat" + +-- | Use this pattern synonym to match on a 'ViewPat'. +-- +-- N.B.: View patterns can occur inside HsExpansions. +pattern TcViewPat :: HsExpr GhcTc -> Pat GhcTc -> Pat GhcTc +pattern TcViewPat viewExpr pat <- (getTcViewPat -> (viewExpr, pat)) + +getTcViewPat :: Pat GhcTc -> (HsExpr GhcTc, Pat GhcTc) +getTcViewPat (ViewPat _ viewLExpr pat) = (unLoc viewLExpr, unLoc pat) +getTcViewPat (XPat (ExpansionPat _ p)) = getTcViewPat p +getTcViewPat p = pprPanic "getTcViewPat" (ppr p) + +{- +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The list of EquationInfo can be empty, arising from + case x of {} or \case {} +In that situation we desugar to + case x of { _ -> error "pattern match failure" } +The *desugarer* isn't certain whether there really should be no +alternatives, so it adds a default case, as it always does. A later +pass may remove it if it's inaccessible. (See also Note [Empty case +alternatives] in GHC.Core.) + +We do *not* desugar simply to + error "empty case" +or some such, because 'x' might be bound to (error "hello"), in which +case we want to see that "hello" exception, not (error "empty case"). +See also the "lifted case" discussion in Note [Case elimination] in GHC.Core.Opt.Simplify. + + +************************************************************************ +* * + Tidying patterns +* * +************************************************************************ + +Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ +which will be scrutinised. + +This makes desugaring the pattern match simpler by transforming some of +the patterns to simpler forms. (Tuples to Constructor Patterns) + +Among other things in the resulting Pattern: +* Variables and irrefutable(lazy) patterns are replaced by Wildcards +* As patterns are replaced by the patterns they wrap. + +The bindings created by the above patterns are put into the returned wrapper +instead. + +This means a definition of the form: + f x = rhs +when called with v get's desugared to the equivalent of: + let x = v + in + f _ = rhs + +The same principle holds for as patterns (@) and +irrefutable/lazy patterns (~). +In the case of irrefutable patterns the irrefutable pattern is pushed into +the binding. + +Pattern Constructors which only represent syntactic sugar are converted into +their desugared representation. +This usually means converting them to Constructor patterns but for some +depends on enabled extensions. (Eg OverloadedLists) + +GHC also tries to convert overloaded Literals into regular ones. + +The result of this tidying is that the column of patterns will include +only these which can be assigned a PatternGroup (see patGroup). + +-} + +tidyEqnInfo :: Id -> EquationInfo + -> DsM (DsWrapper, EquationInfo) + -- DsM'd because of internal call to dsLHsBinds + -- and mkSelectorBinds. + -- "tidy1" does the interesting stuff, looking at + -- one pattern and fiddling the list of bindings. + -- + -- POST CONDITION: head pattern in the EqnInfo is + -- one of these for which patGroup is defined. + +tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn) + +tidyEqnInfo v eqn@(EqnMatch { eqn_pat = (L loc pat) }) = do + (wrap, pat') <- tidy1 v (not . isGoodSrcSpan . locA $ loc) pat + return (wrap, eqn{eqn_pat = L loc pat' }) + +tidy1 :: Id -- The Id being scrutinised + -> Bool -- `True` if the pattern was generated, `False` if it was user-written + -> Pat GhcTc -- The pattern against which it is to be matched + -> DsM (DsWrapper, -- Extra bindings to do before the match + Pat GhcTc) -- Equivalent pattern + +------------------------------------------------------- +-- (pat', mr') = tidy1 v pat mr +-- tidies the *outer level only* of pat, giving pat' +-- It eliminates many pattern forms (as-patterns, variable patterns, +-- list patterns, etc) and returns any created bindings in the wrapper. + +tidy1 v g (ParPat _ pat) = tidy1 v g (unLoc pat) +tidy1 v g (SigPat _ pat _) = tidy1 v g (unLoc pat) +tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty) +tidy1 v g (BangPat _ (L l p)) = tidy_bang_pat v g l p + + -- case v of { x -> mr[] } + -- = case v of { _ -> let x=v in mr[] } +tidy1 v _ (VarPat _ (L _ var)) + = return (wrapBind var v, WildPat (idType var)) + + -- case v of { x@p -> mr[] } + -- = case v of { p -> let x=v in mr[] } +tidy1 v g (AsPat _ (L _ var) pat) + = do { (wrap, pat') <- tidy1 v g (unLoc pat) + ; return (wrapBind var v . wrap, pat') } + +{- now, here we handle lazy patterns: + tidy1 v ~p bs = (v, v1 = case v of p -> v1 : + v2 = case v of p -> v2 : ... : bs ) + + where the v_i's are the binders in the pattern. + + ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing? + + The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr +-} + +tidy1 v _ (LazyPat _ pat) + -- This is a convenient place to check for unlifted types under a lazy pattern. + -- Doing this check during type-checking is unsatisfactory because we may + -- not fully know the zonked types yet. We sure do here. + = putSrcSpanDs (getLocA pat) $ + 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) $ + diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs) + + ; (_,sel_prs) <- mkSelectorBinds [] pat LazyPatCtx (Var v) + ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] + ; return (mkCoreLets sel_binds, WildPat (idType v)) } + +tidy1 _ _ (ListPat ty pats) + = return (idDsWrapper, unLoc list_ConPat) + where + list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) + (mkNilPat ty) + pats + +tidy1 _ _ (TuplePat tys pats boxity) + = return (idDsWrapper, unLoc tuple_ConPat) + where + arity = length pats + tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys' + tys' = case boxity of + Unboxed -> map getRuntimeRep tys ++ tys + Boxed -> tys + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + +tidy1 _ _ (SumPat tys pat alt arity) + = return (idDsWrapper, unLoc sum_ConPat) + where + sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys) + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + +-- LitPats: we *might* be able to replace these w/ a simpler form +tidy1 _ g (LitPat _ lit) + = do { unless g $ + warnAboutOverflowedLit lit + ; return (idDsWrapper, tidyLitPat lit) } + +-- NPats: we *might* be able to replace these w/ a simpler form +tidy1 _ g (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq) + = do { unless g $ + let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v } + | otherwise = lit + in warnAboutOverflowedOverLit lit' + ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) } + +-- NPlusKPat: we may want to warn about the literals +tidy1 _ g n@(NPlusKPat _ _ (L _ lit1) lit2 _ _) + = do { unless g $ do + warnAboutOverflowedOverLit lit1 + warnAboutOverflowedOverLit lit2 + ; return (idDsWrapper, n) } + +tidy1 _ _ (OrPat ty lpats) + -- See Note [Implementation of OrPatterns]. We desugar + -- (1; 2; 3) + -- to + -- ((\case 1 -> True; 2 -> True; 3 -> True; _ -> False) -> True) + = return (idDsWrapper, ViewPat ty (noLocA (HsLam noAnn LamCase mg)) (mkPrefixConPat trueDataCon [] [])) + where + mg :: MatchGroup GhcTc (LHsExpr GhcTc) + mg = MG mgtc (noLocA (map match_true (NE.toList lpats) ++ [match_false (noLocA $ WildPat ty)])) + mgtc = MatchGroupTc + { mg_arg_tys = [tymult ty] + , mg_res_ty = boolTy + , mg_origin = Generated OtherExpansion SkipPmc + -- The or-pattern has already been PM-checked; + -- checking the desugaring only leads to confusing warnings + } + match_true :: LPat GhcTc -> LMatch GhcTc (LHsExpr GhcTc) + match_true lpat = mk_match lpat (hs_var trueDataConId) + match_false :: LPat GhcTc -> LMatch GhcTc (LHsExpr GhcTc) + match_false lpat = mk_match lpat (hs_var falseDataConId) + mk_match :: LPat GhcTc -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc) + mk_match lpat body = noLocA $ Match noExtField CaseAlt (noLocA [lpat]) (single_grhs body) + + hs_var :: Var -> LHsExpr GhcTc + hs_var v = noLocA $ mkHsVar (noLocA v) + single_grhs :: LHsExpr GhcTc -> GRHSs GhcTc (LHsExpr GhcTc) + single_grhs e = GRHSs emptyComments [noLocA $ GRHS noAnn [] e] (EmptyLocalBinds noExtField) + +-- Everything else goes through unchanged... +tidy1 _ _ non_interesting_pat + = return (idDsWrapper, non_interesting_pat) + +-------------------- +tidy_bang_pat :: Id -> Bool -> SrcSpanAnnA -> Pat GhcTc + -> DsM (DsWrapper, Pat GhcTc) + +-- Discard par/sig under a bang +tidy_bang_pat v g _ (ParPat _ (L l p)) = tidy_bang_pat v g l p +tidy_bang_pat v g _ (SigPat _ (L l p) _) = tidy_bang_pat v g l p + +-- Push the bang-pattern inwards, in the hope that +-- it may disappear next time +tidy_bang_pat v g l (AsPat x v' p) + = tidy1 v g (AsPat x v' (L l (BangPat noExtField p))) +tidy_bang_pat v g l (XPat (CoPat w p t)) + = tidy1 v g (XPat $ CoPat w (BangPat noExtField (L l p)) t) +tidy_bang_pat v g l (OrPat x (p:|ps)) -- push bang into first pat alt + = tidy1 v g (OrPat x (L l (BangPat noExtField p) :| ps)) + +-- Discard bang around strict pattern +tidy_bang_pat v g _ p@(LitPat {}) = tidy1 v g p +tidy_bang_pat v g _ p@(ListPat {}) = tidy1 v g p +tidy_bang_pat v g _ p@(TuplePat {}) = tidy1 v g p +tidy_bang_pat v g _ p@(SumPat {}) = tidy1 v g p + +-- Data/newtype constructors +tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc) + , pat_args = args + , pat_con_ext = ConPatTc + { cpt_arg_tys = arg_tys + } + }) + -- Newtypes: push bang inwards (#9844) + = + if isNewTyCon (dataConTyCon dc) + then tidy1 v g (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args }) + else tidy1 v g p -- Data types: discard the bang + where + (ty:_) = dataConInstArgTys dc arg_tys + +------------------- +-- Default case, leave the bang there: +-- VarPat, +-- LazyPat, +-- WildPat, +-- ViewPat, +-- pattern synonyms (ConPatOut with PatSynCon) +-- NPat, +-- NPlusKPat +-- +-- For LazyPat, remember that it's semantically like a VarPat +-- i.e. !(~p) is not like ~p, or p! (#8952) +-- +-- NB: SigPatIn, ConPatIn should not happen + +tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p)) + +------------------- +push_bang_into_newtype_arg :: SrcSpanAnnA + -> Type -- The type of the argument we are pushing + -- onto + -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc +-- See Note [Bang patterns and newtypes] +-- We are transforming !(N p) into (N !p) +push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) + = assert (null args) $ + PrefixCon [L l (BangPat noExtField arg)] +push_bang_into_newtype_arg l _ty (RecCon rf) + | HsRecFields { rec_flds = L lf fld : flds } <- rf + , HsFieldBind { hfbRHS = arg } <- fld + = assert (null flds) $ + RecCon (rf { rec_flds = [L lf (fld { hfbRHS + = L l (BangPat noExtField arg) })] }) +push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) + | HsRecFields { rec_flds = [] } <- rf + = PrefixCon [L l (BangPat noExtField (noLocA (WildPat ty)))] +push_bang_into_newtype_arg _ _ cd + = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) + +{- +Note [Bang patterns and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the pattern !(Just pat) we can discard the bang, because +the pattern is strict anyway. But for !(N pat), where + newtype NT = N Int +we definitely can't discard the bang. #9844. + +So what we do is to push the bang inwards, in the hope that it will +get discarded there. So we transform + !(N pat) into (N !pat) + +But what if there is nothing to push the bang onto? In at least one instance +a user has written !(N {}) which we translate into (N !_). See #13215 + + +\noindent +{\bf Previous @matchTwiddled@ stuff:} + +Now we get to the only interesting part; note: there are choices for +translation [from Simon's notes]; translation~1: +\begin{verbatim} +deTwiddle [s,t] e +\end{verbatim} +returns +\begin{verbatim} +[ w = e, + s = case w of [s,t] -> s + t = case w of [s,t] -> t +] +\end{verbatim} + +Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple +evaluation of \tr{e}. An alternative translation (No.~2): +\begin{verbatim} +[ w = case e of [s,t] -> (s,t) + s = case w of (s,t) -> s + t = case w of (s,t) -> t +] +\end{verbatim} + +************************************************************************ +* * +\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing} +* * +************************************************************************ + +We might be able to optimise unmixing when confronted by +only-one-constructor-possible, of which tuples are the most notable +examples. Consider: +\begin{verbatim} +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +f j ... = ... +\end{verbatim} +This definition would normally be unmixed into four equation blocks, +one per equation. But it could be unmixed into just one equation +block, because if the one equation matches (on the first column), +the others certainly will. + +You have to be careful, though; the example +\begin{verbatim} +f j ... = ... +------------------- +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +\end{verbatim} +{\em must} be broken into two blocks at the line shown; otherwise, you +are forcing unnecessary evaluation. In any case, the top-left pattern +always gives the cue. You could then unmix blocks into groups of... +\begin{description} +\item[all variables:] +As it is now. +\item[constructors or variables (mixed):] +Need to make sure the right names get bound for the variable patterns. +\item[literals or variables (mixed):] +Presumably just a variant on the constructor case (as it is now). +\end{description} + +************************************************************************ +* * +* matchWrapper: a convenient way to call @match@ * +* * +************************************************************************ +\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@} + +Calls to @match@ often involve similar (non-trivial) work; that work +is collected here, in @matchWrapper@. This function takes as +arguments: +\begin{itemize} +\item +Typechecked @Matches@ (of a function definition, or a case or lambda +expression)---the main input; +\item +An error message to be inserted into any (runtime) pattern-matching +failure messages. +\end{itemize} + +As results, @matchWrapper@ produces: +\begin{itemize} +\item +A list of variables (@Locals@) that the caller must ``promise'' to +bind to appropriate values; and +\item +a @CoreExpr@, the desugared output (main result). +\end{itemize} + +The main actions of @matchWrapper@ include: +\begin{enumerate} +\item +Flatten the @[TypecheckedMatch]@ into a suitable list of +@EquationInfo@s. +\item +Create as many new variables as there are patterns in a pattern-list +(in any one of the @EquationInfo@s). +\item +Create a suitable ``if it fails'' expression---a call to @error@ using +the error-string input; the {\em type} of this fail value can be found +by examining one of the RHS expressions in one of the @EquationInfo@s. +\item +Call @match@ with all of this information! +\end{enumerate} +-} + +-- Note [matchWrapper scrutinees] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- There are three possible cases for matchWrapper's scrutinees argument: +-- +-- 1. Nothing Used for FunBind, HsLam, HsLamcase, where there is no explicit scrutinee +-- The MatchGroup may have matchGroupArity of 0 or more. Examples: +-- f p1 q1 = ... -- matchGroupArity 2 +-- f p2 q2 = ... +-- +-- \cases | g1 -> ... -- matchGroupArity 0 +-- | g2 -> ... +-- +-- 2. Just [e] Used for HsCase, RecordUpd; exactly one scrutinee +-- The MatchGroup has matchGroupArity of exactly 1. Example: +-- case e of p1 -> e1 -- matchGroupArity 1 +-- p2 -> e2 +-- +-- 3. Just es Used for HsCmdLamCase; zero or more scrutinees +-- The MatchGroup has matchGroupArity of (length es). Example: +-- \cases p1 q1 -> returnA -< ... -- matchGroupArity 2 +-- p2 q2 -> ... + +matchWrapper + :: HsMatchContextRn -- ^ For shadowing warning messages + -> Maybe [LHsExpr GhcTc] -- ^ Scrutinee(s) + -- see Note [matchWrapper scrutinees] + -> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared + -> DsM ([Id], CoreExpr) -- ^ Results (usually passed to 'match') + +{- + There is one small problem with the Lambda Patterns, when somebody + writes something similar to: +\begin{verbatim} + (\ (x:xs) -> ...) +\end{verbatim} + he/she don't want a warning about incomplete patterns, that is done with + the flag @opt_WarnSimplePatterns@. + This problem also appears in the: +\begin{itemize} +\item @do@ patterns, but if the @do@ can fail + it creates another equation if the match can fail + (see @GHC.HsToCore.Expr.doDo@ function) +\item @let@ patterns, are treated by @matchSimply@ + List Comprehension Patterns, are treated by @matchSimply@ also +\end{itemize} + +We can't call @matchSimply@ with Lambda patterns, +due to the fact that lambda patterns can have more than +one pattern, and match simply only accepts one pattern. + +JJQC 30-Nov-1997 +-} + +matchWrapper ctxt scrs (MG { mg_alts = L _ matches + , mg_ext = MatchGroupTc arg_tys rhs_ty origin + }) + = do { dflags <- getDynFlags + ; locn <- getSrcSpanDs + ; new_vars <- case matches of + [] -> newSysLocalsDs arg_tys + (m:_) -> + selectMatchVars (zipWithEqual + (\a b -> (scaledMult a, unLoc b)) + arg_tys + (hsLMatchPats m)) + + -- Pattern match check warnings for /this match-group/. + -- @rhss_nablas@ is a flat list of covered Nablas for each RHS. + -- Each Match will split off one Nablas for its RHSs from this. + ; tracePm "matchWrapper" + (vcat [ ppr ctxt + , text "scrs" <+> ppr scrs + , text "matches group" <+> ppr matches + , text "matchPmChecked" <+> ppr (isMatchContextPmChecked dflags origin ctxt)]) + ; matches_nablas <- + if isMatchContextPmChecked dflags origin ctxt + -- See Note [Expanding HsDo with XXExprGhcRn] Part 1. Wrinkle 1 for + -- pmc for pattern synonyms + + -- See Note [Long-distance information] in GHC.HsToCore.Pmc + then addHsScrutTmCs (concat scrs) new_vars $ + pmcMatches origin (DsMatchContext ctxt locn) new_vars matches + + -- When we're not doing PM checks on the match group, + -- we still need to propagate long-distance information. + -- See Note [Long-distance information in matchWrapper] + else do { ldi_nablas <- getLdiNablas + ; pure $ initNablasMatches ldi_nablas matches } + + ; eqns_info <- zipWithM mk_eqn_info matches matches_nablas + + ; result_expr <- discard_warnings_if_skip_pmc origin $ + matchEquations ctxt new_vars eqns_info rhs_ty + + ; return (new_vars, result_expr) } + where + -- Called once per equation in the match, or alternative in the case + mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo + mk_eqn_info (L _ (Match { m_pats = L _ pats, m_grhss = grhss })) (pat_nablas, rhss_nablas) + = do { dflags <- getDynFlags + ; let upats = map (decideBangHood dflags) pats + -- pat_nablas is the covered set *after* matching the pattern, but + -- before any of the GRHSs. We extend the environment with pat_nablas + -- (via updPmNablas) so that the where-clause of 'grhss' can profit + -- from that knowledge (#18533) + ; match_result <- updPmNablas pat_nablas $ + dsGRHSs ctxt grhss rhs_ty rhss_nablas + ; return $ mkEqnInfo upats match_result } + + discard_warnings_if_skip_pmc orig = + if requiresPMC orig + then id + else discardWarningsDs + + initNablasMatches :: Nablas -> [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)] + initNablasMatches ldi_nablas ms + = map (\(L _ m) -> (ldi_nablas, initNablasGRHSs ldi_nablas (m_grhss m))) ms + + initNablasGRHSs :: Nablas -> GRHSs GhcTc b -> NonEmpty Nablas + initNablasGRHSs ldi_nablas m = ldi_nablas <$ grhssGRHSs m + +{- Note [Long-distance information in matchWrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The pattern match checking in matchWrapper is done conditionally, depending +on isMatchContextPmChecked. This means that we don't perform pattern match +checking on e.g. generated pattern matches. + +However, when we skip pattern match checking, we still need to keep track +of long-distance information in case we need it in a nested context. + +This came up in #23445. For example: + + data GADT a where + IsUnit :: GADT () + + data Foo b where + FooUnit :: Foo () + FooInt :: Foo Int + + data SomeRec = SomeRec { fld :: () } + + bug :: GADT a -> Foo a -> SomeRec -> SomeRec + bug IsUnit foo r = + let gen_fld :: () + gen_fld = case foo of { FooUnit -> () } + in case r of { SomeRec _ -> SomeRec gen_fld } + +Here the body of 'bug' was generated by 'desugarRecordUpd' from the user-written +record update + + cd { fld = case foo of { FooUnit -> () } } + +As a result, we have a generated FunBind gen_fld whose RHS + + case foo of { FooUnit -> () } + +is user-written. This all happens after the GADT pattern match on IsUnit, +which brings into scope the Given equality [G] a ~ (). We need to make sure +that this long distance information is visible when pattern match checking the +user-written case statement. + +To propagate this long-distance information in 'matchWrapper', when we skip +pattern match checks, we make sure to manually pass the long-distance +information to 'mk_eqn_info', which is responsible for recurring further into +the expression (in this case, it will end up recursively calling 'matchWrapper' +on the user-written case statement). +-} + +matchEquations :: HsMatchContextRn + -> [MatchId] -> [EquationInfo] -> Type + -> DsM CoreExpr +matchEquations ctxt vars eqns_info rhs_ty + = do { match_result <- match vars rhs_ty eqns_info + + ; fail_expr <- mkFailExpr ctxt rhs_ty + + ; extractMatchResult match_result fail_expr } + +-- | @matchSimply@ is a wrapper for 'match' which deals with the +-- situation where we want to match a single expression against a single +-- pattern. It returns an expression. +matchSimply :: CoreExpr -- ^ Scrutinee + -> HsMatchContextRn -- ^ Match kind + -> Mult -- ^ Scaling factor of the case expression + -> LPat GhcTc -- ^ Pattern it should match + -> CoreExpr -- ^ Return this if it matches + -> CoreExpr -- ^ Return this if it doesn't + -> DsM CoreExpr +-- Some reasons 'matchSimply' is not defined using 'matchWrapper' (#18572): +-- * Some call sites like in 'deBindComp' specify a @fail_expr@ that isn't a +-- straight @patError@ +-- * It receives an already desugared 'CoreExpr' for the scrutinee, not an +-- 'HsExpr' like 'matchWrapper' expects +-- * Filling in all the phony fields for the 'MatchGroup' for a single pattern +-- match is awkward +-- * And we still export 'matchSinglePatVar', so not much is gained if we +-- don't also implement it in terms of 'matchWrapper' +matchSimply scrut hs_ctx mult pat result_expr fail_expr = do + let + match_result = cantFailMatchResult result_expr + rhs_ty = exprType fail_expr + -- Use exprType of fail_expr, because won't refine in the case of failure! + match_result' <- matchSinglePat scrut hs_ctx pat mult rhs_ty match_result + extractMatchResult match_result' fail_expr + +matchSinglePat :: CoreExpr -> HsMatchContextRn -> LPat GhcTc -> Mult + -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) +-- matchSinglePat ensures that the scrutinee is a variable +-- and then calls matchSinglePatVar +-- +-- matchSinglePat does not warn about incomplete patterns +-- Used for things like [ e | pat <- stuff ], where +-- incomplete patterns are just fine + +matchSinglePat (Var var) ctx pat _ ty match_result + | not (isExternalName (idName var)) + = matchSinglePatVar var Nothing ctx pat ty match_result + +matchSinglePat scrut hs_ctx pat mult ty match_result + = do { var <- selectSimpleMatchVarL mult pat + ; match_result' <- matchSinglePatVar var (Just scrut) hs_ctx pat ty match_result + ; return $ bindNonRec var scrut <$> match_result' + } + +matchSinglePatVar :: Id -- See Note [Match Ids] + -> Maybe CoreExpr -- ^ The scrutinee the match id is bound to + -> HsMatchContextRn -> LPat GhcTc + -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) +matchSinglePatVar var mb_scrut ctx pat ty match_result + = assertPpr (isInternalName (idName var)) (ppr var) $ + do { dflags <- getDynFlags + ; locn <- getSrcSpanDs + -- Pattern match check warnings. + -- See Note [Long-distance information in matchWrapper] and + -- Note [Long-distance information in do notation] in GHC.HsToCore.Expr. + ; ldi_nablas <- + if isMatchContextPmChecked_SinglePat dflags FromSource ctx pat + then addCoreScrutTmCs (maybeToList mb_scrut) [var] $ + pmcPatBind (DsMatchContext ctx locn) var (unLoc pat) + else getLdiNablas + + ; let eqn_info = EqnMatch { eqn_pat = decideBangHood dflags pat + , eqn_rest = + EqnDone $ updPmNablasMatchResult ldi_nablas match_result } + -- See Note [Long-distance information in do notation] + -- in GHC.HsToCore.Expr. + + ; match [var] ty [eqn_info] } + +updPmNablasMatchResult :: Nablas -> MatchResult r -> MatchResult r +updPmNablasMatchResult nablas = \case + MR_Infallible body_fn -> MR_Infallible $ + updPmNablas nablas body_fn + MR_Fallible body_fn -> MR_Fallible $ \fail -> + updPmNablas nablas $ body_fn fail + +{- +************************************************************************ +* * + Pattern classification +* * +************************************************************************ +-} + +data PatGroup + = PgAny -- Immediate match: variables, wildcards, + -- lazy patterns + | PgCon DataCon -- Constructor patterns (incl list, tuple) + | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups] + | PgLit Literal -- Literal patterns + | PgN FractionalLit -- Overloaded numeric literals; + -- see Note [Don't use Literal for PgN] + | PgOverS FastString -- Overloaded string literals + | PgNpK Integer -- n+k patterns + | PgBang -- Bang patterns + | PgCo Type -- Coercion patterns; the type is the type + -- of the pattern *inside* + | PgView (LHsExpr GhcTc) -- view pattern (e -> p): + -- the LHsExpr is the expression e + Type -- the Type is the type of p (equivalently, the result type of e) + +instance Show PatGroup where + show PgAny = "PgAny" + show (PgCon _) = "PgCon" + show (PgLit _) = "PgLit" + show (PgView _ _) = "PgView" + show _ = "PgOther" + +{- Note [Don't use Literal for PgN] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously we had, as PatGroup constructors + + | ... + | PgN Literal -- Overloaded literals + | PgNpK Literal -- n+k patterns + | ... + +But Literal is really supposed to represent an *unboxed* literal, like Int#. +We were sticking the literal from, say, an overloaded numeric literal pattern +into a LitInt constructor. This didn't really make sense; and we now have +the invariant that value in a LitInt must be in the range of the target +machine's Int# type, and an overloaded literal could meaningfully be larger. + +Solution: For pattern grouping purposes, just store the literal directly in +the PgN constructor as a FractionalLit if numeric, and add a PgOverStr constructor +for overloaded strings. +-} + +groupEquations :: Platform -> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)] +-- If the result is of form [g1, g2, g3], +-- (a) all the (pg,eq) pairs in g1 have the same pg +-- (b) none of the gi are empty +-- The ordering of equations is unchanged +groupEquations platform eqns + = NE.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns] + -- comprehension on NonEmpty + where + same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool + (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 + +-- TODO Make subGroup1 using a NonEmptyMap +subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems + -> m -- Map.empty + -> (a -> m -> Maybe (NonEmpty EquationInfo)) -- Map.lookup + -> (a -> NonEmpty EquationInfo -> m -> m) -- Map.insert + -> [(a, EquationInfo)] -> [NonEmpty EquationInfo] +-- Input is a particular group. The result sub-groups the +-- equations by with particular constructor, literal etc they match. +-- Each sub-list in the result has the same PatGroup +-- See Note [Take care with pattern order] +-- Parameterized by map operations to allow different implementations +-- and constraints, eg. types without Ord instance. +subGroup elems empty lookup insert group + = fmap NE.reverse $ elems $ foldl' accumulate empty group + where + accumulate pg_map (pg, eqn) + = case lookup pg pg_map of + Just eqns -> insert pg (NE.cons eqn eqns) pg_map + Nothing -> insert pg [eqn] pg_map + -- pg_map :: Map a [EquationInfo] + -- Equations seen so far in reverse order of appearance + +subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo] +subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert + +subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo] +subGroupUniq = + subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v) + +{- Note [Pattern synonym groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see + f (P a) = e1 + f (P b) = e2 + ... +where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the +same group? We can if P is a constructor, but /not/ if P is a pattern synonym. +Consider (#11224) + -- readMaybe :: Read a => String -> Maybe a + pattern PRead :: Read a => () => a -> String + pattern PRead a <- (readMaybe -> Just a) + + f (PRead (x::Int)) = e1 + f (PRead (y::Bool)) = e2 +This is all fine: we match the string by trying to read an Int; if that +fails we try to read a Bool. But clearly we can't combine the two into a single +match. + +Conclusion: we can combine when we invoke PRead /at the same type/. Hence +in PgSyn we record the instantiating types, and use them in sameGroup. + +Note [Take care with pattern order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the subGroup function we must be very careful about pattern re-ordering, +Consider the patterns [ (True, Nothing), (False, x), (True, y) ] +Then in bringing together the patterns for True, we must not +swap the Nothing and y! +-} + +sameGroup :: PatGroup -> PatGroup -> Bool +-- Same group means that a single case expression +-- or test will suffice to match both, *and* the order +-- of testing within the group is insignificant. +sameGroup PgAny PgAny = True +sameGroup PgBang PgBang = True +sameGroup (PgCon _) (PgCon _) = True -- One case expression +sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2 + -- eqTypes: See Note [Pattern synonym groups] +sameGroup (PgLit _) (PgLit _) = True -- One case expression +sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant + -- Order is significant, match PgN after PgLit + -- If the exponents are small check for value equality rather than syntactic equality + -- This is implemented in the Eq instance for FractionalLit, we do this to avoid + -- computing the value of excessively large rationals. +sameGroup (PgOverS s1) (PgOverS s2) = s1==s2 +sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] +sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 + -- CoPats are in the same group only if the type of the + -- enclosed pattern is the same. The patterns outside the CoPat + -- always have the same type, so this boils down to saying that + -- the two coercions are identical. +sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) + -- ViewPats are in the same group iff the expressions + -- are "equal"---conservatively, we use syntactic equality +sameGroup _ _ = False + +-- An approximation of syntactic equality used for determining when view +-- exprs are in the same group. +-- This function can always safely return false; +-- but doing so will result in the application of the view function being repeated. +-- +-- Currently: compare applications of literals and variables +-- and anything else that we can do without involving other +-- HsSyn types in the recursion +-- +-- NB we can't assume that the two view expressions have the same type. Consider +-- f (e1 -> True) = ... +-- f (e2 -> "hi") = ... +viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool +viewLExprEq (e1,_) (e2,_) = lexp e1 e2 + where + lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool + lexp e e' = exp (unLoc e) (unLoc e') + + --------- + exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool + -- real comparison is on HsExpr's + -- strip parens + exp (HsPar _ (L _ e)) e' = exp e e' + exp e (HsPar _ (L _ e')) = exp e e' + -- because the expressions do not necessarily have the same type, + -- we have to compare the wrappers + exp (XExpr (WrapExpr h e)) (XExpr (WrapExpr h' e')) = + wrap h h' && exp e e' + exp (XExpr (ExpandedThingTc o x)) (XExpr (ExpandedThingTc o' x')) + | isHsThingRnExpr o + , isHsThingRnExpr o' + = exp x x' + exp (HsVar _ i) (HsVar _ i') = i == i' + exp (XExpr (ConLikeTc c _ _)) (XExpr (ConLikeTc c' _ _)) = c == c' + -- the instance for IPName derives using the id, so this works if the + -- above does + exp (HsIPVar _ i) (HsIPVar _ i') = i == i' + exp (HsOverLit _ l) (HsOverLit _ l') = + -- Overloaded lits are equal if they have the same type + -- and the data is the same. + -- this is coarser than comparing the SyntaxExpr's in l and l', + -- which resolve the overloading (e.g., fromInteger 1), + -- because these expressions get written as a bunch of different variables + -- (presumably to improve sharing) + eqType (overLitType l) (overLitType l') && l == l' + exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2' + -- the fixities have been straightened out by now, so it's safe + -- to ignore them? + exp (OpApp _ l g ri) (OpApp _ l' o' ri') = + lexp l l' && lexp g o' && lexp ri ri' + exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n' + exp (SectionL _ e1 e2) (SectionL _ e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (SectionR _ e1 e2) (SectionR _ e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = + eq_list tup_arg es1 es2 + exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e' + exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = + lexp e e' && lexp e1 e1' && lexp e2 e2' + + -- Enhancement: could implement equality for more expressions + -- if it seems useful + -- But no need for HsLit, ExplicitList, ExplicitTuple, + -- because they cannot be functions + exp _ _ = False + + --------- + syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool + syn_exp (SyntaxExprTc { syn_expr = expr1 + , syn_arg_wraps = arg_wraps1 + , syn_res_wrap = res_wrap1 }) + (SyntaxExprTc { syn_expr = expr2 + , syn_arg_wraps = arg_wraps2 + , syn_res_wrap = res_wrap2 }) + = exp expr1 expr2 && + and (zipWithEqual wrap arg_wraps1 arg_wraps2) && + wrap res_wrap1 res_wrap2 + syn_exp NoSyntaxExprTc NoSyntaxExprTc = True + syn_exp _ _ = False + + --------- + tup_arg (Present _ e1) (Present _ e2) = lexp e1 e2 + tup_arg (Missing (Scaled _ t1)) (Missing (Scaled _ t2)) = eqType t1 t2 + tup_arg _ _ = False + + --------- + wrap :: HsWrapper -> HsWrapper -> Bool + -- Conservative, in that it demands that wrappers be + -- syntactically identical and doesn't look under binders + -- + -- Coarser notions of equality are possible + -- (e.g., reassociating compositions, + -- equating different ways of writing a coercion) + wrap WpHole WpHole = True + wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' + wrap (WpFun w1 w2 _) (WpFun w1' w2' _) = wrap w1 w1' && wrap w2 w2' + wrap (WpCast co) (WpCast co') = co `eqCoercion` co' + wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2 + wrap (WpTyApp t) (WpTyApp t') = eqType t t' + -- Enhancement: could implement equality for more wrappers + -- if it seems useful (lams and lets) + wrap _ _ = False + + --------- + ev_term :: EvTerm -> EvTerm -> Bool + ev_term (EvExpr (Var a)) (EvExpr (Var b)) + = idType a `eqType` idType b + -- The /type/ of the evidence matters, not its precise proof term. + -- Caveat: conceivably a sufficiently exotic use of incoherent instances + -- could make a difference, but remember this is only used within the + -- pattern matches for a single function, so it's hard to see how that + -- could really happen. And we don't want accidentally different proofs + -- to prevent spotting equalities, and hence degrade pattern-match + -- overlap checking. + ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) + = a `eqCoercion` b + ev_term _ _ = False + + --------- + eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool + eq_list _ [] [] = True + eq_list _ [] (_:_) = False + eq_list _ (_:_) [] = False + eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys + +patGroup :: Platform -> Pat GhcTc -> PatGroup +patGroup _ (ConPat { pat_con = L _ con + , pat_con_ext = ConPatTc { cpt_arg_tys = tys } + }) + | RealDataCon dcon <- con = PgCon dcon + | PatSynCon psyn <- con = PgSyn psyn tys +patGroup _ (WildPat {}) = PgAny +patGroup _ (BangPat {}) = PgBang +patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) = + case (oval, isJust mb_neg) of + (HsIntegral i, is_neg) -> PgN (integralFractionalLit is_neg (if is_neg + then negate (il_value i) + else il_value i)) + (HsFractional f, is_neg) + | is_neg -> PgN $! negateFractionalLit f + | otherwise -> PgN f + (HsIsString _ s, _) -> assert (isNothing mb_neg) $ + PgOverS s +patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) = + case oval of + HsIntegral i -> PgNpK (il_value i) + _ -> pprPanic "patGroup NPlusKPat" (ppr oval) +patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) +patGroup platform (LitPat _ lit) = PgLit (hsLitKey platform lit) +patGroup _ EmbTyPat{} = PgAny +patGroup platform (XPat ext) = case ext of + CoPat _ p _ -> PgCo (hsPatType p) -- Type of innelexp pattern + ExpansionPat _ p -> patGroup platform p +patGroup _ pat = pprPanic "patGroup" (ppr pat) + +{- +Note [Grouping overloaded literal patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +WATCH OUT! Consider + + f (n+1) = ... + f (n+2) = ... + f (n+1) = ... + +We can't group the first and third together, because the second may match +the same thing as the first. Same goes for *overloaded* literal patterns + f 1 True = ... + f 2 False = ... + f 1 False = ... +If the first arg matches '1' but the second does not match 'True', we +cannot jump to the third equation! Because the same argument might +match '2'! +Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group. +-} diff --git a/GHC/HsToCore/Match.hs-boot b/GHC/HsToCore/Match.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Match.hs-boot @@ -0,0 +1,39 @@ +module GHC.HsToCore.Match where + +import GHC.Prelude +import GHC.Types.Var ( Id ) +import GHC.Tc.Utils.TcType ( Type ) +import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) +import GHC.Core ( CoreExpr ) +import GHC.Hs ( LPat, MatchGroup, LHsExpr, Mult ) +import GHC.Hs.Expr ( HsMatchContextRn ) +import GHC.Hs.Extension ( GhcTc ) + +match :: [Id] + -> Type + -> [EquationInfo] + -> DsM (MatchResult CoreExpr) + +matchWrapper + :: HsMatchContextRn + -> Maybe [LHsExpr GhcTc] + -> MatchGroup GhcTc (LHsExpr GhcTc) + -> DsM ([Id], CoreExpr) + +matchSimply + :: CoreExpr + -> HsMatchContextRn + -> Mult + -> LPat GhcTc + -> CoreExpr + -> CoreExpr + -> DsM CoreExpr + +matchSinglePatVar + :: Id + -> Maybe CoreExpr + -> HsMatchContextRn + -> LPat GhcTc + -> Type + -> MatchResult CoreExpr + -> DsM (MatchResult CoreExpr) diff --git a/GHC/HsToCore/Match/Constructor.hs b/GHC/HsToCore/Match/Constructor.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Match/Constructor.hs @@ -0,0 +1,296 @@ + +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-data-list-nonempty-unzip #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching constructors +-} + +module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.HsToCore.Match ( match ) + +import GHC.Hs +import GHC.HsToCore.Binds +import GHC.Core.ConLike +import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity +import GHC.HsToCore.Monad +import GHC.HsToCore.Utils +import GHC.Core ( CoreExpr ) +import GHC.Core.Make ( mkCoreLets ) +import GHC.Utils.Misc +import GHC.Types.Id +import GHC.Types.Name.Env +import GHC.Types.FieldLabel ( flSelector ) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import Control.Monad(liftM) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE + +{- +We are confronted with the first column of patterns in a set of +equations, all beginning with constructors from one ``family'' (e.g., +@[]@ and @:@ make up the @List@ ``family''). We want to generate the +alternatives for a @Case@ expression. There are several choices: +\begin{enumerate} +\item +Generate an alternative for every constructor in the family, whether +they are used in this set of equations or not; this is what the Wadler +chapter does. +\begin{description} +\item[Advantages:] +(a)~Simple. (b)~It may also be that large sparsely-used constructor +families are mainly handled by the code for literals. +\item[Disadvantages:] +(a)~Not practical for large sparsely-used constructor families, e.g., +the ASCII character set. (b)~Have to look up a list of what +constructors make up the whole family. +\end{description} + +\item +Generate an alternative for each constructor used, then add a default +alternative in case some constructors in the family weren't used. +\begin{description} +\item[Advantages:] +(a)~Alternatives aren't generated for unused constructors. (b)~The +STG is quite happy with defaults. (c)~No lookup in an environment needed. +\item[Disadvantages:] +(a)~A spurious default alternative may be generated. +\end{description} + +\item +``Do it right:'' generate an alternative for each constructor used, +and add a default alternative if all constructors in the family +weren't used. +\begin{description} +\item[Advantages:] +(a)~You will get cases with only one alternative (and no default), +which should be amenable to optimisation. Tuples are a common example. +\item[Disadvantages:] +(b)~Have to look up constructor families in TDE (as above). +\end{description} +\end{enumerate} + +We are implementing the ``do-it-right'' option for now. The arguments +to @matchConFamily@ are the same as to @match@; the extra @Int@ +returned is the number of constructors in the family. + +The function @matchConFamily@ is concerned with this +have-we-used-all-the-constructors? question; the local function +@match_cons_used@ does all the real work. +-} + +matchConFamily :: NonEmpty Id + -> Type + -> NonEmpty (NonEmpty EquationInfoNE) + -> DsM (MatchResult CoreExpr) +-- Each group of eqns is for a single constructor +matchConFamily (var :| vars) ty groups + = do let mult = idMult var + -- Each variable in the argument list correspond to one column in the + -- pattern matching equations. Its multiplicity is the context + -- multiplicity of the pattern. We extract that multiplicity, so that + -- 'matchOneconLike' knows the context multiplicity, in case it needs + -- to come up with new variables. + alts <- mapM (fmap toRealAlt . matchOneConLike vars ty mult) groups + return (mkCoAlgCaseMatchResult var ty alts) + where + toRealAlt alt = case alt_pat alt of + RealDataCon dcon -> alt{ alt_pat = dcon } + _ -> panic "matchConFamily: not RealDataCon" + +matchPatSyn :: NonEmpty Id + -> Type + -> NonEmpty EquationInfoNE + -> DsM (MatchResult CoreExpr) +matchPatSyn (var :| vars) ty eqns + = do let mult = idMult var + alt <- fmap toSynAlt $ matchOneConLike vars ty mult eqns + return (mkCoSynCaseMatchResult var ty alt) + where + toSynAlt alt = case alt_pat alt of + PatSynCon psyn -> alt{ alt_pat = psyn } + _ -> panic "matchPatSyn: not PatSynCon" + +type ConArgPats = HsConPatDetails GhcTc + +matchOneConLike :: [Id] + -> Type + -> Mult + -> NonEmpty EquationInfoNE + -> DsM (CaseAlt ConLike) +matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single constructor + = do { let inst_tys = assert (all tcIsTcTyVar ex_tvs) $ + -- ex_tvs can only be tyvars as data types in source + -- Haskell cannot mention covar yet (Aug 2018). + assert (tvs1 `equalLength` ex_tvs) $ + arg_tys ++ mkTyVarTys tvs1 + + val_arg_tys = conLikeInstOrigArgTys con1 inst_tys + -- dataConInstOrigArgTys takes the univ and existential tyvars + -- and returns the types of the *value* args, which is what we want + + match_group :: [Id] + -> NonEmpty (ConArgPats, EquationInfoNE) + -> DsM (MatchResult CoreExpr) + -- All members of the group have compatible ConArgPats + match_group arg_vars arg_eqn_prs + = do { (wraps, eqns') <- liftM NE.unzip (mapM shift arg_eqn_prs) + ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs + ; match_result <- match (group_arg_vars ++ vars) ty (NE.toList eqns') + ; return $ foldr1 (.) wraps <$> match_result + } + + shift (_, EqnMatch { + eqn_pat = L _ (ConPat + { pat_args = args + , pat_con_ext = ConPatTc + { cpt_tvs = tvs + , cpt_dicts = ds + , cpt_binds = bind }}) + , eqn_rest = rest }) + = do dsTcEvBinds bind $ \ds_bind -> + return ( wrapBinds (tvs `zip` tvs1) + . wrapBinds (ds `zip` dicts1) + . mkCoreLets ds_bind + , prependPats (conArgPats val_arg_tys args) rest + ) + shift (_, eqn) = pprPanic "matchOneCon/shift" (ppr eqn) + ; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys + -- The 'val_arg_tys' are taken from the data type definition, they + -- do not take into account the context multiplicity, therefore we + -- need to scale them back to get the correct context multiplicity + -- to desugar the sub-pattern in each field. We need to know these + -- multiplicity because of the invariant that, in Core, binders in a + -- constructor pattern must be scaled by the multiplicity of the + -- case. See Note [Case expression invariants]. + ; arg_vars <- selectConMatchVars scaled_arg_tys args1 + -- Use the first equation as a source of + -- suggestions for the new variables + + -- Divide into sub-groups; see Note [Record patterns] + ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfoNE)) + groups = NE.groupBy1 compatible_pats + $ fmap (\eqn -> (con_pat_args (firstPat eqn), eqn)) (eqn1 :| eqns) + + ; match_results <- mapM (match_group arg_vars) groups + + ; return $ MkCaseAlt{ alt_pat = con1, + alt_bndrs = tvs1 ++ dicts1 ++ arg_vars, + alt_wrapper = wrapper1, + alt_result = foldr1 combineMatchResults match_results } } + where + con_pat_args :: Pat GhcTc -> HsConPatDetails GhcTc + con_pat_args (ConPat { pat_args = args }) = args + con_pat_args p = pprPanic "matchOneConLike" (ppr p) -- All patterns are ConPats + + ConPat { pat_con = L _ con1 + , pat_args = args1 + , pat_con_ext = ConPatTc + { cpt_arg_tys = arg_tys + , cpt_wrap = wrapper1 + , cpt_tvs = tvs1 + , cpt_dicts = dicts1 + } + } = firstPat eqn1 + fields1 = map flSelector (conLikeFieldLabels con1) + + ex_tvs = conLikeExTyCoVars con1 + + -- Choose the right arg_vars in the right order for this group + -- Note [Record patterns] + select_arg_vars :: [Id] -> NonEmpty (ConArgPats, EquationInfo) -> [Id] + select_arg_vars arg_vars ((arg_pats, _) :| _) + | RecCon flds <- arg_pats + , let rpats = rec_flds flds + , not (null rpats) -- Treated specially; cf conArgPats + = assertPpr (fields1 `equalLength` arg_vars) + (ppr con1 $$ ppr fields1 $$ ppr arg_vars) $ + map lookup_fld rpats + | otherwise + = arg_vars + where + fld_var_env = mkNameEnv $ zipEqual fields1 arg_vars + lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env + (idName (hsRecFieldId rpat)) + +----------------- +compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool +-- Two constructors have compatible argument patterns if the number +-- and order of sub-matches is the same in both cases +compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2 +compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1) +compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2) +compatible_pats _ _ = True -- Prefix or infix con + +same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) + -> Bool +same_fields flds1 flds2 + = all2 (\(L _ f1) (L _ f2) + -> hsRecFieldId f1 == hsRecFieldId f2) + (rec_flds flds1) (rec_flds flds2) + + +----------------- +selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id] +selectConMatchVars arg_tys con + = case con of + RecCon {} -> newSysLocalsDs arg_tys + PrefixCon ps -> selectMatchVars (zipMults arg_tys ps) + InfixCon p1 p2 -> selectMatchVars (zipMults arg_tys [p1, p2]) + where + zipMults = zipWithEqual (\a b -> (scaledMult a, unLoc b)) + +conArgPats :: [Scaled Type]-- Instantiated argument types + -- Used only to fill in the types of WildPats, which + -- are probably never looked at anyway + -> ConArgPats + -> [LPat GhcTc] +conArgPats _arg_tys (PrefixCon ps) = ps +conArgPats _arg_tys (InfixCon p1 p2) = [p1, p2] +conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) + | null rpats = map (noLocA . WildPat . 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 (hfbRHS . unLoc) rpats + +{- +Note [Record patterns] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = T { x,y,z :: Bool } + + f (T { y=True, x=False }) = ... + +We must match the patterns IN THE ORDER GIVEN, thus for the first +one we match y=True before x=False. See #246; or imagine +matching against (T { y=False, x=undefined }): should fail without +touching the undefined. + +Now consider: + + f (T { y=True, x=False }) = ... + f (T { x=True, y= False}) = ... + +In the first we must test y first; in the second we must test x +first. So we must divide even the equations for a single constructor +T into sub-groups, based on whether they match the same field in the +same order. That's what the (groupBy compatible_pats) grouping. + +All non-record patterns are "compatible" in this sense, because the +positional patterns (T a b) and (a `T` b) all match the arguments +in order. Also T {} is special because it's equivalent to (T _ _). +Hence the (null rpats) checks here and there. + +-} diff --git a/GHC/HsToCore/Match/Literal.hs b/GHC/HsToCore/Match/Literal.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Match/Literal.hs @@ -0,0 +1,725 @@ + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching literal patterns +-} + +module GHC.HsToCore.Match.Literal + ( dsLit, dsOverLit, hsLitKey + , tidyLitPat, tidyNPat + , matchLiterals, matchNPlusKPats, matchNPats + , numericConversionNames + , warnAboutOverflowedOverLit, warnAboutOverflowedLit + , warnAboutEmptyEnumerations + ) +where + +import GHC.Prelude +import GHC.Platform + +import {-# SOURCE #-} GHC.HsToCore.Match ( match ) +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsSyntaxExpr ) + +import GHC.HsToCore.Errors.Types +import GHC.HsToCore.Monad +import GHC.HsToCore.Utils + +import GHC.Hs + +import GHC.Tc.Utils.TcMType ( shortCutLit ) +import GHC.Tc.Utils.TcType + +import GHC.Core +import GHC.Core.Make +import GHC.Core.TyCon +import GHC.Core.Reduction ( Reduction(..) ) +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType ) + +import GHC.Types.Name +import GHC.Types.Literal +import GHC.Types.SrcLoc + +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim + +import GHC.Types.Id +import GHC.Types.SourceText + +import GHC.Driver.DynFlags + +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Unique (sameUnique) + +import GHC.Data.FastString +import qualified GHC.Data.List.NonEmpty as NEL + +import Control.Monad +import Data.Int +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Word +import GHC.Real ( Ratio(..), numerator, denominator ) + +{- +************************************************************************ +* * + Desugaring literals + [used to be in GHC.HsToCore.Expr, but GHC.HsToCore.Quote needs it, + and it's nice to avoid a loop] +* * +************************************************************************ + +We give int/float literals type @Integer@ and @Rational@, respectively. +The typechecker will (presumably) have put \tr{from{Integer,Rational}s} +around them. + +ToDo: put in range checks for when converting ``@i@'' +(or should that be in the typechecker?) + +For numeric literals, we try to detect there use at a standard type +(@Int@, @Float@, etc.) are directly put in the right constructor. +[NB: down with the @App@ conversion.] + +See also below where we look for @DictApps@ for \tr{plusInt}, etc. +-} + +dsLit :: forall p. IsPass p => HsLit (GhcPass p) -> DsM CoreExpr +dsLit l = do + dflags <- getDynFlags + let platform = targetPlatform dflags + case l of + HsStringPrim _ s -> return (Lit (LitString s)) + HsCharPrim _ c -> return (Lit (LitChar c)) + HsIntPrim _ i -> return (Lit (mkLitIntWrap platform i)) + HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w)) + HsInt8Prim _ i -> return (Lit (mkLitInt8Wrap i)) + HsInt16Prim _ i -> return (Lit (mkLitInt16Wrap i)) + HsInt32Prim _ i -> return (Lit (mkLitInt32Wrap i)) + HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap i)) + HsWord8Prim _ w -> return (Lit (mkLitWord8Wrap w)) + HsWord16Prim _ w -> return (Lit (mkLitWord16Wrap w)) + HsWord32Prim _ w -> return (Lit (mkLitWord32Wrap w)) + HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap w)) + + -- This can be slow for very large literals. See Note [FractionalLit representation] + -- and #15646 + HsFloatPrim _ fl -> return (Lit (LitFloat (rationalFromFractionalLit fl))) + HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl))) + HsChar _ c -> return (mkCharExpr c) + HsString _ str -> mkStringExprFS str + HsMultilineString _ str -> mkStringExprFS str + HsInt _ i -> return (mkIntExpr platform (il_value i)) + XLit x -> case ghcPass @p of + GhcTc -> case x of + HsInteger _ i _ -> return (mkIntegerExpr platform i) + HsRat fl ty -> dsFractionalLitToRational fl ty + +{- +Note [FractionalLit representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a fun wrinkle to this, we used to simply compute the value +for these literals and store it as `Rational`. While this might seem +reasonable it meant typechecking literals of extremely large numbers +wasn't possible. This happened for example in #15646. + +There a user would write in GHCi e.g. `:t 1e1234111111111111111111111` +which would trip up the compiler. The reason being we would parse it as +. Try to compute n, which would run out of memory +for truly large numbers, or take far too long for merely large ones. + +To fix this we instead now store the significand and exponent of the +literal instead. Depending on the size of the exponent we then defer +the computation of the Rational value, potentially up to runtime of the +program! There are still cases left were we might compute large rationals +but it's a lot rarer then. + +The current state of affairs for large literals is: +* Typechecking: Will produce a FractionalLit +* Desugaring a large overloaded literal to Float/Double *is* done + at compile time. So can still fail. But this only matters for values too large + to be represented as float anyway. +* Converting overloaded literals to a value of *Rational* is done at *runtime*. + If such a value is then demanded at runtime the program might hang or run out of + memory. But that is perhaps expected and acceptable. +* TH might also evaluate the literal even when overloaded. + But there a user should be able to work around #15646 by + generating a call to `mkRationalBase10/2` for large literals instead. + + +Note [FractionalLit representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For fractional literals, like 1.3 or 0.79e22, we do /not/ represent +them within the compiler as a Rational. Doing so would force the +compiler to compute a huge Rational for 2.3e300000000000, at compile +time (#15646)! + +So instead we represent fractional literals as a FractionalLit, +in which we record the significand and exponent separately. Then +we can compute the huge Rational at /runtime/, by emitting code +for + mkRationalBase10 2.3 300000000000 + +where mkRationalBase10 is defined in the library GHC.Real + +The moving parts are here: + +* Parsing, renaming, typechecking: use FractionalLit, in which the + significand and exponent are represented separately. + +* Desugaring. Remember that a fractional literal like 54.4e20 has type + Fractional a => a + + - For fractional literals whose type turns out to be Float/Double, + we desugar to a Float/Double literal at /compile time/. + This conversion can still fail. But this only matters for values + too large to be represented as float anyway. See dsLit in + GHC.HsToCore.Match.Literal + + - For fractional literals whose type turns out to be Rational, we + desugar the literal to a call of `mkRationalBase10` (etc for hex + literals), so that we only compute the Rational at /run time/. If + this value is then demanded at runtime the program might hang or + run out of memory. But that is perhaps expected and acceptable. + See dsFractionalLitToRational in GHC.HsToCore.Match.Literal + + - For fractional literals whose type isn't one of the above, we just + call the typeclass method `fromRational`. But to do that we need + the rational to give to it, and we compute that at runtime, as + above. + +* Template Haskell definitions are also problematic. While the TH code + works as expected once it's spliced into a program it will compute the + value of the large literal. + But there a user should be able to work around #15646 + by having their TH code generating a call to `mkRationalBase[10/2]` for + large literals instead. + +-} + +-- | See Note [FractionalLit representation] +dsFractionalLitToRational :: FractionalLit -> Type -> DsM CoreExpr +dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = base } ty + -- We compute "small" rationals here and now + | abs exp <= 100 + = do + platform <- targetPlatform <$> getDynFlags + let !val = rationalFromFractionalLit fl + !num = mkIntegerExpr platform (numerator val) + !denom = mkIntegerExpr platform (denominator val) + (ratio_data_con, integer_ty) + = case tcSplitTyConApp ty of + (tycon, [i_ty]) -> assert (isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) + (head (tyConDataCons tycon), i_ty) + x -> pprPanic "dsLit" (ppr x) + return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) + -- Large rationals will be computed at runtime. + | otherwise + = do + let mkRationalName = case base of + Base2 -> mkRationalBase2Name + Base10 -> mkRationalBase10Name + mkRational <- dsLookupGlobalId mkRationalName + litR <- dsRational signi + platform <- targetPlatform <$> getDynFlags + let litE = mkIntegerExpr platform exp + return (mkCoreApps (Var mkRational) [litR, litE]) + +dsRational :: Rational -> DsM CoreExpr +dsRational (n :% d) = do + platform <- targetPlatform <$> getDynFlags + dcn <- dsLookupDataCon ratioDataConName + let cn = mkIntegerExpr platform n + let dn = mkIntegerExpr platform d + return $ mkCoreConApps dcn [Type integerTy, cn, dn] + + +dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr +-- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains +-- (an expression for) the literal value itself. +dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable witness ty }) = do + dflags <- getDynFlags + let platform = targetPlatform dflags + case shortCutLit platform val ty of + Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut] + _ -> dsExpr witness + +{- +Note [Literal short cut] +~~~~~~~~~~~~~~~~~~~~~~~~ +The type checker tries to do this short-cutting as early as possible, but +because of unification etc, more information is available to the desugarer. +And where it's possible to generate the correct literal right away, it's +much better to do so. + + +************************************************************************ +* * + Warnings about overflowed literals +* * +************************************************************************ + +Warn about functions like toInteger, fromIntegral, that convert +between one type and another when the to- and from- types are the +same. Then it's probably (albeit not definitely) the identity +-} + +numericConversionNames :: [Name] +numericConversionNames + = [ toIntegerName, toRationalName + , fromIntegralName, realToFracName ] + -- We can't easily add fromIntegerName, fromRationalName, + -- because they are generated by literals + +-- | Emit warnings on overloaded integral literals which overflow the bounds +-- implied by their type. +warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM () +warnAboutOverflowedOverLit hsOverLit = do + dflags <- getDynFlags + fam_envs <- dsGetFamInstEnvs + warnAboutOverflowedLiterals dflags $ + getIntegralLit hsOverLit >>= getNormalisedTyconName fam_envs + +-- | Emit warnings on integral literals which overflow the bounds implied by +-- their type. +warnAboutOverflowedLit :: HsLit GhcTc -> DsM () +warnAboutOverflowedLit hsLit = do + dflags <- getDynFlags + warnAboutOverflowedLiterals dflags $ + getSimpleIntegralLit hsLit >>= getTyconName + +-- | Emit warnings on integral literals which overflow the bounds implied by +-- their type. +warnAboutOverflowedLiterals + :: DynFlags + -> Maybe (Integer, Name) -- ^ the literal value and name of its tycon + -> DsM () +warnAboutOverflowedLiterals dflags lit + | wopt Opt_WarnOverflowedLiterals dflags + , Just (i, tc) <- lit + = if + -- These only show up via the 'HsOverLit' route + | sameUnique tc intTyConName -> check i tc minInt maxInt + | sameUnique tc wordTyConName -> check i tc minWord maxWord + | sameUnique tc int8TyConName -> check i tc (min' @Int8) (max' @Int8) + | sameUnique tc int16TyConName -> check i tc (min' @Int16) (max' @Int16) + | sameUnique tc int32TyConName -> check i tc (min' @Int32) (max' @Int32) + | sameUnique tc int64TyConName -> check i tc (min' @Int64) (max' @Int64) + | sameUnique tc word8TyConName -> check i tc (min' @Word8) (max' @Word8) + | sameUnique tc word16TyConName -> check i tc (min' @Word16) (max' @Word16) + | sameUnique tc word32TyConName -> check i tc (min' @Word32) (max' @Word32) + | sameUnique tc word64TyConName -> check i tc (min' @Word64) (max' @Word64) + | sameUnique tc naturalTyConName -> checkPositive i tc + + -- These only show up via the 'HsLit' route + | sameUnique tc intPrimTyConName -> check i tc minInt maxInt + | sameUnique tc wordPrimTyConName -> check i tc minWord maxWord + | sameUnique tc int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8) + | sameUnique tc int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16) + | sameUnique tc int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32) + | sameUnique tc int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64) + | sameUnique tc word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8) + | sameUnique tc word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16) + | sameUnique tc word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32) + | sameUnique tc word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64) + + | otherwise -> return () + + | otherwise = return () + where + -- use target Int/Word sizes! See #17336 + platform = targetPlatform dflags + (minInt,maxInt) = (platformMinInt platform, platformMaxInt platform) + (minWord,maxWord) = (0, platformMaxWord platform) + + min' :: forall a. (Integral a, Bounded a) => Integer + min' = fromIntegral (minBound :: a) + + max' :: forall a. (Integral a, Bounded a) => Integer + max' = fromIntegral (maxBound :: a) + + checkPositive :: Integer -> Name -> DsM () + checkPositive i tc + = when (i < 0) $ + diagnosticDs (DsOverflowedLiterals i tc Nothing (negLiteralExtEnabled dflags)) + + check i tc minB maxB + = when (i < minB || i > maxB) $ + diagnosticDs (DsOverflowedLiterals i tc bounds (negLiteralExtEnabled dflags)) + where + bounds = Just (MinBound minB, MaxBound maxB) + +warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc + -> Maybe (LHsExpr GhcTc) + -> LHsExpr GhcTc -> DsM () +-- ^ Warns about @[2,3 .. 1]@ or @['b' .. 'a']@ which return the empty list. +-- For numeric literals, only works for integral types, not floating point. +warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr + | not $ wopt Opt_WarnEmptyEnumerations dflags + = return () + -- Numeric Literals + | Just from_ty@(from',_) <- getLHsIntegralLit fromExpr + , Just (_, tc) <- getNormalisedTyconName fam_envs from_ty + , Just mThn' <- traverse getLHsIntegralLit mThnExpr + , Just (to',_) <- getLHsIntegralLit toExpr + = do + let + check :: forall a. (Integral a, Num a) => DsM () + check = when (null enumeration) raiseWarning + where + enumeration = case mThn of + Nothing -> [from .. to] + Just thn -> [from, thn .. to] + wrap :: forall a. (Integral a, Num a) => Integer -> Integer + wrap i = toInteger (fromIntegral i :: a) + from = wrap @a from' + to = wrap @a to' + mThn = fmap (wrap @a . fst) mThn' + + platform <- targetPlatform <$> getDynFlags + -- Be careful to use target Int/Word sizes! cf #17336 + if | sameUnique tc intTyConName -> case platformWordSize platform of + PW4 -> check @Int32 + PW8 -> check @Int64 + | sameUnique tc wordTyConName -> case platformWordSize platform of + PW4 -> check @Word32 + PW8 -> check @Word64 + | sameUnique tc int8TyConName -> check @Int8 + | sameUnique tc int16TyConName -> check @Int16 + | sameUnique tc int32TyConName -> check @Int32 + | sameUnique tc int64TyConName -> check @Int64 + | sameUnique tc word8TyConName -> check @Word8 + | sameUnique tc word16TyConName -> check @Word16 + | sameUnique tc word32TyConName -> check @Word32 + | sameUnique tc word64TyConName -> check @Word64 + | sameUnique tc integerTyConName -> check @Integer + | sameUnique tc naturalTyConName -> check @Integer + -- We use 'Integer' because otherwise a negative 'Natural' literal + -- could cause a compile time crash (instead of a runtime one). + -- See the T10930b test case for an example of where this matters. + | otherwise -> return () + + -- Char literals (#18402) + | Just fromChar <- getLHsCharLit fromExpr + , Just mThnChar <- traverse getLHsCharLit mThnExpr + , Just toChar <- getLHsCharLit toExpr + , let enumeration = case mThnChar of + Nothing -> [fromChar .. toChar] + Just thnChar -> [fromChar, thnChar .. toChar] + = when (null enumeration) raiseWarning + + | otherwise = return () + where + raiseWarning = + diagnosticDs DsEmptyEnumeration + +getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) +-- ^ See if the expression is an 'Integral' literal. +getLHsIntegralLit (L _ e) = go e + where + go (HsPar _ e) = getLHsIntegralLit e + go (HsOverLit _ over_lit) = getIntegralLit over_lit + go (HsLit _ lit) = getSimpleIntegralLit lit + + -- Remember to look through automatically-added tick-boxes! (#8384) + go (XExpr (HsTick _ e)) = getLHsIntegralLit e + go (XExpr (HsBinTick _ _ e)) = getLHsIntegralLit e + + -- The literal might be wrapped in a case with -XOverloadedLists + go (XExpr (WrapExpr _ e)) = go e + go _ = Nothing + +-- | If 'Integral', extract the value and type of the overloaded literal. +-- See Note [Literals and the OverloadedLists extension] +getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type) +getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc { ol_type = ty } }) + = Just (il_value i, ty) +getIntegralLit _ = Nothing + +-- | If 'Integral', extract the value and type of the non-overloaded literal. +getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type) +getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy) +getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy) +getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy) +getSimpleIntegralLit (HsInt8Prim _ i) = Just (i, int8PrimTy) +getSimpleIntegralLit (HsInt16Prim _ i) = Just (i, int16PrimTy) +getSimpleIntegralLit (HsInt32Prim _ i) = Just (i, int32PrimTy) +getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy) +getSimpleIntegralLit (HsWord8Prim _ i) = Just (i, word8PrimTy) +getSimpleIntegralLit (HsWord16Prim _ i) = Just (i, word16PrimTy) +getSimpleIntegralLit (HsWord32Prim _ i) = Just (i, word32PrimTy) +getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy) +getSimpleIntegralLit (XLit (HsInteger _ i ty)) = Just (i, ty) + +getSimpleIntegralLit HsChar{} = Nothing +getSimpleIntegralLit HsCharPrim{} = Nothing +getSimpleIntegralLit HsString{} = Nothing +getSimpleIntegralLit HsMultilineString{} = Nothing +getSimpleIntegralLit HsStringPrim{} = Nothing +getSimpleIntegralLit (XLit (HsRat{})) = Nothing +getSimpleIntegralLit HsFloatPrim{} = Nothing +getSimpleIntegralLit HsDoublePrim{} = Nothing + +-- | Extract the Char if the expression is a Char literal. +getLHsCharLit :: LHsExpr GhcTc -> Maybe Char +getLHsCharLit (L _ (HsPar _ e)) = getLHsCharLit e +getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c +getLHsCharLit (L _ (XExpr (HsTick _ e))) = getLHsCharLit e +getLHsCharLit (L _ (XExpr (HsBinTick _ _ e))) = getLHsCharLit e +getLHsCharLit _ = Nothing + +-- | Convert a pair (Integer, Type) to (Integer, Name) after eventually +-- normalising the type +getNormalisedTyconName :: FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name) +getNormalisedTyconName fam_envs (i,ty) + | Just tc <- tyConAppTyCon_maybe (normaliseNominal fam_envs ty) + = Just (i, tyConName tc) + | otherwise = Nothing + where + normaliseNominal :: FamInstEnvs -> Type -> Type + normaliseNominal fam_envs ty + = reductionReducedType + $ normaliseType fam_envs Nominal ty + +-- | Convert a pair (Integer, Type) to (Integer, Name) without normalising +-- the type +getTyconName :: (Integer, Type) -> Maybe (Integer, Name) +getTyconName (i,ty) + | Just tc <- tyConAppTyCon_maybe ty = Just (i, tyConName tc) + | otherwise = Nothing + +{- +Note [Literals and the OverloadedLists extension] +~~~~ +Consider the Literal `[256] :: [Data.Word.Word8]` + +When the `OverloadedLists` extension is not active, then the `ol_ext` field +in the `OverLitTc` record that is passed to the function `getIntegralLit` +contains the type `Word8`. This is a simple type, and we can use its +type constructor immediately for the `warnAboutOverflowedLiterals` function. + +When the `OverloadedLists` extension is active, then the `ol_ext` field +contains the type family `Item [Word8]`. The function `nomaliseType` is used +to convert it to the needed type `Word8`. +-} + +{- +************************************************************************ +* * + Tidying lit pats +* * +************************************************************************ +-} + +tidyLitPat :: HsLit GhcTc -> Pat GhcTc +-- Result has only the following HsLits: +-- HsIntPrim, HsWordPrim, HsCharPrim, HsString +-- * HsInteger, HsRat, HsInt, as well as HsStringPrim, +-- HsFloatPrim and HsDoublePrim can't show up in LitPats +-- * We get rid of HsChar right here +tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c) +tidyLitPat (HsString src s) + | lengthFS s <= 1 -- Short string literals only + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon + [mkCharLitPat src c, pat] [charTy]) + (mkNilPat charTy) (unpackFS s) + -- The stringTy is the type of the whole pattern, not + -- the type to instantiate (:) or [] with! +tidyLitPat lit = LitPat noExtField lit + +---------------- +tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc + -> Type + -> Pat GhcTc +tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty + -- False: Take short cuts only if the literal is not using rebindable syntax + -- + -- Once that is settled, look for cases where the type of the + -- entire overloaded literal matches the type of the underlying literal, + -- and in that case take the short cut + -- NB: Watch out for weird cases like #3382 + -- f :: Int -> Int + -- f "blah" = 4 + -- which might be ok if we have 'instance IsString Int' + -- + | not type_change, isIntTy ty, Just int_lit <- mb_int_lit + = mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit) + | not type_change, isWordTy ty, Just int_lit <- mb_int_lit + = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit) + | not type_change, isStringTy ty, Just str_lit <- mb_str_lit + = tidyLitPat (HsString NoSourceText str_lit) + -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 + -- If we do convert to the constructor form, we'll generate a case + -- expression on a Float# or Double# and that's not allowed in Core; see + -- #9238 and Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold + where + -- Sometimes (like in test case + -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include + -- type-changing wrappers (for example, from Id Int to Int, for the identity + -- type family Id). In these cases, we can't do the short-cut. + type_change = not (outer_ty `eqType` ty) + + mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc + mk_con_pat con lit + = unLoc (mkPrefixConPat con [noLocA $ LitPat noExtField lit] []) + + mb_int_lit :: Maybe Integer + mb_int_lit = case (mb_neg, val) of + (Nothing, HsIntegral i) -> Just (il_value i) + (Just _, HsIntegral i) -> Just (-(il_value i)) + _ -> Nothing + + mb_str_lit :: Maybe FastString + mb_str_lit = case (mb_neg, val) of + (Nothing, HsIsString _ s) -> Just s + _ -> Nothing + +tidyNPat over_lit mb_neg eq outer_ty + = NPat outer_ty (noLocA over_lit) mb_neg eq + +{- +************************************************************************ +* * + Pattern matching on LitPat +* * +************************************************************************ +-} + +matchLiterals :: NonEmpty Id + -> Type -- ^ Type of the whole case expression + -> NonEmpty (NonEmpty EquationInfoNE) -- ^ All PgLits + -> DsM (MatchResult CoreExpr) + +matchLiterals (var :| vars) ty sub_groups + = do { -- Deal with each group + ; alts <- mapM match_group sub_groups + + -- Combine results. For everything except String + -- we can use a case expression; for String we need + -- a chain of if-then-else + ; if isStringTy (idType var) then + do { eq_str <- dsLookupGlobalId eqStringName + ; mrs <- mapM (wrap_str_guard eq_str) alts + ; return (foldr1 combineMatchResults mrs) } + else + return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts) + } + where + match_group :: NonEmpty EquationInfoNE -> DsM (Literal, MatchResult CoreExpr) + match_group eqns + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; let EqnMatch { eqn_pat = L _ (LitPat _ hs_lit) } = NEL.head eqns + ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns) + ; return (hsLitKey platform hs_lit, match_result) } + + wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr) + -- Equality check for string literals + wrap_str_guard eq_str (LitString s, mr) + = do { -- We now have to convert back to FastString. Perhaps there + -- should be separate LitBytes and LitString constructors? + let s' = mkFastStringByteString s + ; lit <- mkStringExprFS s' + ; let pred = mkApps (Var eq_str) [Var var, lit] + ; return (mkGuardedMatchResult pred mr) } + wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) + + +--------------------------- +hsLitKey :: Platform -> HsLit GhcTc -> Literal +-- Get the Core literal corresponding to a HsLit. +-- It only works for primitive types and strings; +-- others have been removed by tidy +-- For HsString, it produces a LitString, which really represents an _unboxed_ +-- string literal; and we deal with it in matchLiterals above. Otherwise, it +-- produces a primitive Literal of type matching the original HsLit. +-- In the case of the fixed-width numeric types, we need to wrap here +-- because Literal has an invariant that the literal is in range, while +-- HsLit does not. +hsLitKey platform (HsIntPrim _ i) = mkLitIntWrap platform i +hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w +hsLitKey _ (HsInt8Prim _ i) = mkLitInt8Wrap i +hsLitKey _ (HsInt16Prim _ i) = mkLitInt16Wrap i +hsLitKey _ (HsInt32Prim _ i) = mkLitInt32Wrap i +hsLitKey _ (HsInt64Prim _ i) = mkLitInt64Wrap i +hsLitKey _ (HsWord8Prim _ w) = mkLitWord8Wrap w +hsLitKey _ (HsWord16Prim _ w) = mkLitWord16Wrap w +hsLitKey _ (HsWord32Prim _ w) = mkLitWord32Wrap w +hsLitKey _ (HsWord64Prim _ w) = mkLitWord64Wrap w +hsLitKey _ (HsCharPrim _ c) = mkLitChar c +-- This following two can be slow. See Note [FractionalLit representation] +hsLitKey _ (HsFloatPrim _ fl) = mkLitFloat (rationalFromFractionalLit fl) +hsLitKey _ (HsDoublePrim _ fl) = mkLitDouble (rationalFromFractionalLit fl) + +hsLitKey _ (HsString _ s) = LitString (bytesFS s) +hsLitKey _ l = pprPanic "hsLitKey" (ppr l) + +{- +************************************************************************ +* * + Pattern matching on NPat +* * +************************************************************************ +-} + +matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) +matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal + = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 + ; lit_expr <- dsOverLit lit + ; neg_lit <- case mb_neg of + Nothing -> return lit_expr + Just neg -> dsSyntaxExpr neg [lit_expr] + ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit] + ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) + ; return (mkGuardedMatchResult pred_expr match_result) } + +{- +************************************************************************ +* * + Pattern matching on n+k patterns +* * +************************************************************************ + +For an n+k pattern, we use the various magic expressions we've been given. +We generate: +\begin{verbatim} + if ge var lit then + let n = sub var lit + in + else + +\end{verbatim} +-} + +matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) +-- All NPlusKPats, for the *same* literal k +matchNPlusKPats (var :| vars) ty (eqn1 :| eqns) + = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus + = firstPat eqn1 + ; lit1_expr <- dsOverLit lit1 + ; lit2_expr <- dsOverLit lit2 + ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] + ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr] + ; let (wraps, eqns') = NEL.mapAndUnzip (shift n1) (eqn1:|eqns) + ; match_result <- match vars ty (NEL.toList eqns') + ; return (mkGuardedMatchResult pred_expr $ + mkCoLetMatchResult (NonRec n1 minusk_expr) $ + fmap (foldr1 (.) wraps) $ + match_result) } + where + shift n1 (EqnMatch { eqn_pat = L _ (NPlusKPat _ (L _ n) _ _ _ _), eqn_rest = rest }) + = (wrapBind n n1, rest) + -- The wrapBind is a no-op for the first equation + shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/GHC/HsToCore/Monad.hs b/GHC/HsToCore/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Monad.hs @@ -0,0 +1,625 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Monadery used in desugaring +-} + +module GHC.HsToCore.Monad ( + DsM, mapM, mapAndUnzipM, + initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs, + foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM, + Applicative(..),(<$>), + + duplicateLocalDs, newSysLocalDs, newSysLocalsDs, + newSysLocalMDs, newSysLocalsMDs, newFailLocalMDs, + newUniqueId, newPredVarDs, + getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA, + mkNamePprCtxDs, + newUnique, + UniqSupply, newUniqueSupply, + getGhcModeDs, dsGetFamInstEnvs, dsGetGlobalRdrEnv, + dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, + dsLookupDataCon, dsLookupConLike, + getCCIndexDsM, + + DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, + + -- Getting and setting pattern match oracle states + getPmNablas, updPmNablas, + + -- Tracking evidence variable coherence + addUnspecables, getUnspecables, zapUnspecables, + + -- Get COMPLETE sets of a TyCon + dsGetCompleteMatches, + + -- Warnings and errors + DsWarning, diagnosticDs, errDsCoreExpr, + failWithDs, failDs, discardWarningsDs, + + -- Data types + DsMatchContext(..), + EquationInfo(..), EquationInfoNE, prependPats, mkEqnInfo, eqnMatchResult, + MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, + + -- Trace injection + pprRuntimeTrace + ) where + +import GHC.Prelude + +import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Driver.Ppr +import GHC.Driver.Config.Diagnostic + +import GHC.Hs + +import GHC.HsToCore.Types +import GHC.HsToCore.Errors.Types +import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas) + +import GHC.Core.FamInstEnv +import GHC.Core +import GHC.Core.Make ( unitExpr ) +import GHC.Core.Utils ( exprType ) +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Multiplicity + +import GHC.IfaceToCore + +import GHC.Tc.Utils.Monad + +import GHC.Builtin.Names + +import GHC.Data.FastString + +import GHC.Unit.Env +import GHC.Unit.External +import GHC.Unit.Module +import GHC.Unit.Module.ModGuts + +import GHC.Types.Name.Reader +import GHC.Types.SourceFile +import GHC.Types.Id +import GHC.Types.Var (EvVar) +import GHC.Types.Var.Set( VarSet, emptyVarSet, extendVarSetList ) +import GHC.Types.SrcLoc +import GHC.Types.TypeEnv +import GHC.Types.Unique.Supply +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Ppr +import GHC.Types.Literal ( mkLitString ) +import GHC.Types.CostCentre.State +import GHC.Types.TyThing +import GHC.Types.Error +import GHC.Types.CompleteMatch +import GHC.Types.Unique.DSet + +import GHC.Tc.Utils.Env (lookupGlobal) + +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified GHC.Data.Strict as Strict + +import Data.IORef +import GHC.Driver.Env.KnotVars +import GHC.IO.Unsafe (unsafeInterleaveIO) + +{- +************************************************************************ +* * + Data types for the desugarer +* * +************************************************************************ +-} + +data DsMatchContext + = DsMatchContext HsMatchContextRn SrcSpan + deriving () + +instance Outputable DsMatchContext where + ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match + +data EquationInfo + = EqnMatch { eqn_pat :: LPat GhcTc + -- ^ The first pattern of the equation + -- + -- NB: The location info is used to determine whether the + -- pattern is generated or not. + -- This helps us avoid warnings on patterns that GHC elaborated. + -- + -- NB: We have /already/ applied 'decideBangHood' to this + -- pattern. See Note [decideBangHood] in "GHC.HsToCore.Utils" + + , eqn_rest :: EquationInfo } + -- ^ The rest of the equation after its first pattern + + | EqnDone + -- The empty tail of an equation having no more patterns + (MatchResult CoreExpr) + -- ^ What to do after match + +type EquationInfoNE = EquationInfo +-- An EquationInfo which has at least one pattern +-- i.e. it's an EqnMatch, not EqnDone + +prependPats :: [LPat GhcTc] -> EquationInfo -> EquationInfo +prependPats [] eqn = eqn +prependPats (pat:pats) eqn = EqnMatch { eqn_pat = pat, eqn_rest = prependPats pats eqn } + +mkEqnInfo :: [LPat GhcTc] -> MatchResult CoreExpr -> EquationInfo +mkEqnInfo pats = prependPats pats . EqnDone + +eqnMatchResult :: EquationInfo -> MatchResult CoreExpr +eqnMatchResult (EqnDone rhs) = rhs +eqnMatchResult (EqnMatch { eqn_rest = eq }) = eqnMatchResult eq + +instance Outputable EquationInfo where + ppr = ppr . allEqnPats where + allEqnPats (EqnDone {}) = [] + allEqnPats (EqnMatch { eqn_pat = pat, eqn_rest = eq }) = unLoc pat : allEqnPats eq + +type DsWrapper = CoreExpr -> CoreExpr +idDsWrapper :: DsWrapper +idDsWrapper e = e + +-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult CoreExpr +-- \fail. wrap (case vs of { pats -> rhs fail }) +-- where vs are not bound by wrap + +-- | This is a value of type a with potentially a CoreExpr-shaped hole in it. +-- This is used to deal with cases where we are potentially handling pattern +-- match failure, and want to later specify how failure is handled. +data MatchResult a + -- | We represent the case where there is no hole without a function from + -- 'CoreExpr', like this, because sometimes we have nothing to put in the + -- hole and so want to be sure there is in fact no hole. + = MR_Infallible (DsM a) + | MR_Fallible (CoreExpr -> DsM a) + deriving (Functor) + +-- | Product is an "or" on fallibility---the combined match result is infallible +-- only if the left and right argument match results both were. +-- +-- This is useful for combining a bunch of alternatives together and then +-- getting the overall fallibility of the entire group. See 'mkDataConCase' for +-- an example. +instance Applicative MatchResult where + pure v = MR_Infallible (pure v) + MR_Infallible f <*> MR_Infallible x = MR_Infallible (f <*> x) + f <*> x = MR_Fallible $ \fail -> runMatchResult fail f <*> runMatchResult fail x + +-- Given a fail expression to use, and a MatchResult CoreExpr, compute the filled CoreExpr whether +-- the MatchResult CoreExpr was failable or not. +runMatchResult :: CoreExpr -> MatchResult a -> DsM a +runMatchResult fail = \case + MR_Infallible body -> body + MR_Fallible body_fn -> body_fn fail + +{- +************************************************************************ +* * + Monad functions +* * +************************************************************************ +-} + +-- Compatibility functions +fixDs :: (a -> DsM a) -> DsM a +fixDs = fixM + +type DsWarning = (SrcSpan, SDoc) + -- Not quite the same as a WarnMsg, we have an SDoc here + -- and we'll do the name_ppr_ctx stuff later on to turn it + -- into a Doc. + +-- | Run a 'DsM' action inside the 'TcM' monad. +initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a) +initDsTc thing_inside + = do { tcg_env <- getGblEnv + ; msg_var <- liftIO $ newIORef emptyMessages + ; hsc_env <- getTopEnv + ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env + ; e_result <- tryM $ -- need to tryM so that we don't discard + -- DsMessages + setEnvs envs thing_inside + ; msgs <- liftIO $ readIORef msg_var + ; return (msgs, case e_result of Left _ -> Nothing + Right x -> Just x) + } + +-- | Run a 'DsM' action inside the 'IO' monad. +initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a) +initDs hsc_env tcg_env thing_inside + = do { msg_var <- newIORef emptyMessages + ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env + ; runDs hsc_env envs thing_inside + } + +-- | Build a set of desugarer environments derived from a 'TcGblEnv'. +mkDsEnvsFromTcGbl :: MonadIO m + => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv + -> m (DsGblEnv, DsLclEnv) +mkDsEnvsFromTcGbl hsc_env msg_var tcg_env + = do { cc_st_var <- liftIO $ newIORef newCostCentreState + ; eps <- liftIO $ hscEPS hsc_env + ; let unit_env = hsc_unit_env hsc_env + this_mod = tcg_mod tcg_env + type_env = tcg_type_env tcg_env + rdr_env = tcg_rdr_env tcg_env + fam_inst_env = tcg_fam_inst_env tcg_env + ptc = initPromotionTickContext (hsc_dflags hsc_env) + -- re-use existing next_wrapper_num to ensure uniqueness + next_wrapper_num_var = tcg_next_wrapper_num tcg_env + tcg_comp_env = tcg_complete_match_env tcg_env + + ; ds_complete_matches <- + liftIO $ unsafeInterleaveIO $ + -- Note [Lazily loading COMPLETE pragmas] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- This call to 'unsafeInterleaveIO' ensures we only do this work + -- when we need to look at the COMPLETE pragmas, avoiding doing work + -- when we don't need them. + -- + -- Relevant test case: MultiLayerModulesTH_Make, which regresses + -- in allocations by ~5% if we don't do this. + traverse (lookupCompleteMatch type_env hsc_env) =<< + localAndImportedCompleteMatches tcg_comp_env eps + ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc + msg_var cc_st_var next_wrapper_num_var ds_complete_matches + } + +-- | We have in hand the `CompleteMatches` for the module, but when +-- doing pattern-match overlap checking we want the `ConLike` for each +-- data constructor, not just its `Name`. This function makes the +-- transition. +lookupCompleteMatch :: TypeEnv -> HscEnv -> CompleteMatch -> IO DsCompleteMatch +lookupCompleteMatch type_env hsc_env (CompleteMatch { cmConLikes = nms, cmResultTyCon = mb_tc }) + = do { cons <- mapMUniqDSet lookup_conLike nms + ; return $ CompleteMatch { cmConLikes = cons, cmResultTyCon = mb_tc } } + where + lookup_conLike :: Name -> IO ConLike + lookup_conLike nm + | Just ty <- wiredInNameTyThing_maybe nm + = go ty + | Just ty <- lookupTypeEnv type_env nm + = go ty + | otherwise + = go =<< lookupGlobal hsc_env nm + where + go :: TyThing -> IO ConLike + go (AConLike cl) = return cl + go ty = pprPanic "lookup_conLike not a ConLike" (ppr nm <+> ppr ty) + +runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a) +runDs hsc_env (ds_gbl, ds_lcl) thing_inside + = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl + (tryM thing_inside) + ; msgs <- readIORef (ds_msgs ds_gbl) + ; let final_res + | errorsFound msgs = Nothing + | Right r <- res = Just r + | otherwise = panic "initDs" + ; return (msgs, final_res) + } + +-- | Run a 'DsM' action in the context of an existing 'ModGuts' +initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a) +initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds + , mg_tcs = tycons, mg_fam_insts = fam_insts + , mg_patsyns = patsyns, mg_rdr_env = rdr_env + , mg_fam_inst_env = fam_inst_env + , mg_complete_matches = local_complete_matches + }) thing_inside + = do { cc_st_var <- newIORef newCostCentreState + ; next_wrapper_num <- newIORef emptyModuleEnv + ; msg_var <- newIORef emptyMessages + ; eps <- liftIO $ hscEPS hsc_env + ; let unit_env = hsc_unit_env hsc_env + type_env = typeEnvFromEntities ids tycons patsyns fam_insts + ptc = initPromotionTickContext (hsc_dflags hsc_env) + bindsToIds (NonRec v _) = [v] + bindsToIds (Rec binds) = map fst binds + ids = concatMap bindsToIds binds + ; ds_complete_matches <- traverse (lookupCompleteMatch type_env hsc_env) =<< + localAndImportedCompleteMatches local_complete_matches eps + ; let + envs = mkDsEnvs unit_env this_mod rdr_env type_env + fam_inst_env ptc msg_var cc_st_var + next_wrapper_num ds_complete_matches + ; runDs hsc_env envs thing_inside + } + +initTcDsForSolver :: TcM a -> DsM a +-- Spin up a TcM context so that we can run the constraint solver +-- Returns any error messages generated by the constraint solver +-- and (Just res) if no error happened; Nothing if an error happened +-- +-- Simon says: I'm not very happy about this. We spin up a complete TcM monad +-- only to immediately refine it to a TcS monad. +-- Better perhaps to make TcS into its own monad, rather than building on TcS +-- But that may in turn interact with plugins + +initTcDsForSolver thing_inside + = do { (gbl, lcl) <- getEnvs + ; hsc_env <- getTopEnv + + -- The DsGblEnv is used to inform the typechecker's solver of a few + -- key pieces of information: + -- + -- - ds_fam_inst_env tells it how to reduce type families, + -- - ds_gbl_rdr_env tells it which newtypes it can unwrap. + ; let DsGblEnv { ds_mod = mod + , ds_fam_inst_env = fam_inst_env + , ds_gbl_rdr_env = rdr_env + } = gbl + DsLclEnv { dsl_loc = loc } = lcl + + ; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $ + updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env + , tcg_rdr_env = rdr_env }) $ + thing_inside + ; case mb_ret of + Just ret -> pure ret + Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) } + +mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv + -> PromotionTickContext + -> IORef (Messages DsMessage) -> IORef CostCentreState + -> IORef (ModuleEnv Int) -> DsCompleteMatches + -> (DsGblEnv, DsLclEnv) +mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var + next_wrapper_num complete_matches + = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs" + -- Failing tests here are `ghci` and `T11985` if you get this wrong. + -- this is very very "at a distance" because the reason for this check is that the type_env in interactive + -- mode is the smushed together of all the interactive modules. + -- See Note [Why is KnotVars not a ModuleEnv] + , if_rec_types = KnotVars [mod] (\that_mod -> if that_mod == mod || isInteractiveModule mod + then Just (return type_env) + else Nothing) } + if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) + NotBoot + real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) + gbl_env = DsGblEnv { ds_mod = mod + , ds_fam_inst_env = fam_inst_env + , ds_gbl_rdr_env = rdr_env + , ds_if_env = (if_genv, if_lenv) + , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env + , ds_msgs = msg_var + , ds_complete_matches = complete_matches + , ds_cc_st = cc_st_var + , ds_next_wrapper_num = next_wrapper_num + } + lcl_env = DsLclEnv { dsl_meta = emptyNameEnv + , dsl_loc = real_span + , dsl_nablas = initNablas + , dsl_unspecables = Just emptyVarSet + } + in (gbl_env, lcl_env) + + +{- +************************************************************************ +* * + Operations in the monad +* * +************************************************************************ + +And all this mysterious stuff is so we can occasionally reach out and +grab one or more names. @newLocalDs@ isn't exported---exported +functions are defined with it. The difference in name-strings makes +it easier to read debugging output. + +-} + +-- Make a new Id with the same print name, but different type, and new unique +newUniqueId :: Id -> Mult -> Type -> DsM Id +newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id))) + +duplicateLocalDs :: Id -> DsM Id +duplicateLocalDs old_local + = do { uniq <- newUnique + ; return (setIdUnique old_local uniq) } + +newPredVarDs :: PredType -> DsM Var +newPredVarDs + = mkSysLocalOrCoVarM (fsLit "ds") ManyTy -- like newSysLocalDs, but we allow covars + +newSysLocalMDs, newFailLocalMDs :: Type -> DsM Id +-- Implicitly have ManyTy multiplicity, hence the "M" +newSysLocalMDs = mkSysLocalM (fsLit "ds") ManyTy +newFailLocalMDs = mkSysLocalM (fsLit "fail") ManyTy + +newSysLocalsMDs :: [Type] -> DsM [Id] +newSysLocalsMDs = mapM newSysLocalMDs + +newSysLocalDs :: Scaled Type -> DsM Id +newSysLocalDs (Scaled w t) = mkSysLocalM (fsLit "ds") w t + +newSysLocalsDs :: [Scaled Type] -> DsM [Id] +newSysLocalsDs = mapM newSysLocalDs + +{- +We can also reach out and either set/grab location information from +the @SrcSpan@ being carried around. +-} + +getGhcModeDs :: DsM GhcMode +getGhcModeDs = getDynFlags >>= return . ghcMode + +-- | Get the current pattern match oracle state. See 'dsl_nablas'. +getPmNablas :: DsM Nablas +getPmNablas = do { env <- getLclEnv; return (dsl_nablas env) } + +-- | Set the pattern match oracle state within the scope of the given action. +-- See 'dsl_nablas'. +updPmNablas :: Nablas -> DsM a -> DsM a +updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas }) + +addUnspecables :: [EvVar] -> DsM a -> DsM a +addUnspecables new_unspecables + = updLclEnv (\env -> case dsl_unspecables env of + Nothing -> env + Just us -> env { dsl_unspecables + = Just (us `extendVarSetList` new_unspecables) }) + +zapUnspecables :: DsM a -> DsM a +zapUnspecables = updLclEnv (\env -> env{ dsl_unspecables = Nothing }) + +getUnspecables :: DsM (Maybe VarSet) +getUnspecables = dsl_unspecables <$> getLclEnv + +getSrcSpanDs :: DsM SrcSpan +getSrcSpanDs = do { env <- getLclEnv + ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) } + +putSrcSpanDs :: SrcSpan -> DsM a -> DsM a +putSrcSpanDs (UnhelpfulSpan {}) thing_inside + = thing_inside +putSrcSpanDs (RealSrcSpan real_span _) thing_inside + = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside + +putSrcSpanDsA :: EpAnn ann -> DsM a -> DsM a +putSrcSpanDsA loc = putSrcSpanDs (locA loc) + +-- | Emit a diagnostic for the current source location. In case the diagnostic is a warning, +-- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags. +-- See Note [Discarding Messages] in 'GHC.Types.Error'. +diagnosticDs :: DsMessage -> DsM () +diagnosticDs dsMessage + = do { env <- getGblEnv + ; loc <- getSrcSpanDs + ; !diag_opts <- initDiagOpts <$> getDynFlags + ; let msg = mkMsgEnvelope diag_opts loc (ds_name_ppr_ctx env) dsMessage + ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } + +-- | Issue an error, but return the expression for (), so that we can continue +-- reporting errors. +errDsCoreExpr :: DsMessage -> DsM CoreExpr +errDsCoreExpr msg + = do { diagnosticDs msg + ; return unitExpr } + +failWithDs :: DsMessage -> DsM a +failWithDs msg + = do { diagnosticDs msg + ; failM } + +failDs :: DsM a +failDs = failM + +mkNamePprCtxDs :: DsM NamePprCtx +mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv + +instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where + lookupThing = dsLookupGlobal + +dsLookupGlobal :: Name -> DsM TyThing +-- Very like GHC.Tc.Utils.Env.tcLookupGlobal +dsLookupGlobal name + = do { env <- getGblEnv + ; setEnvs (ds_if_env env) + (tcIfaceGlobal name) } + +dsLookupGlobalId :: Name -> DsM Id +dsLookupGlobalId name + = tyThingId <$> dsLookupGlobal name + +dsLookupTyCon :: Name -> DsM TyCon +dsLookupTyCon name + = tyThingTyCon <$> dsLookupGlobal name + +dsLookupDataCon :: Name -> DsM DataCon +dsLookupDataCon name + = tyThingDataCon <$> dsLookupGlobal name + +dsLookupConLike :: Name -> DsM ConLike +dsLookupConLike name + = tyThingConLike <$> dsLookupGlobal name + + +dsGetFamInstEnvs :: DsM FamInstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +dsGetFamInstEnvs + = do { eps <- getEps; env <- getGblEnv + ; return (eps_fam_inst_env eps, ds_fam_inst_env env) } + +dsGetMetaEnv :: DsM (NameEnv DsMetaVal) +dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) } + +dsGetGlobalRdrEnv :: DsM GlobalRdrEnv +dsGetGlobalRdrEnv = ds_gbl_rdr_env <$> getGblEnv + +-- | The @COMPLETE@ pragmas that are in scope. +dsGetCompleteMatches :: DsM DsCompleteMatches +dsGetCompleteMatches = ds_complete_matches <$> getGblEnv + +dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) +dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) } + +dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a +dsExtendMetaEnv menv thing_inside + = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside + +discardWarningsDs :: DsM a -> DsM a +-- Ignore warnings inside the thing inside; +-- used to ignore inaccessible cases etc. inside generated code +discardWarningsDs thing_inside + = do { env <- getGblEnv + ; old_msgs <- readTcRef (ds_msgs env) + + ; result <- thing_inside + + -- Revert messages to old_msgs + ; writeTcRef (ds_msgs env) old_msgs + + ; return result } + +-- | Inject a trace message into the compiled program. Whereas +-- pprTrace prints out information *while compiling*, pprRuntimeTrace +-- captures that information and causes it to be printed *at runtime* +-- using Debug.Trace.trace. +-- +-- pprRuntimeTrace hdr doc expr +-- +-- will produce an expression that looks like +-- +-- trace (hdr + doc) expr +-- +-- When using this to debug a module that Debug.Trace depends on, +-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that +-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace, +-- but that doesn't seem worth the effort and maintenance cost. +pprRuntimeTrace :: String -- ^ header + -> SDoc -- ^ information to output + -> CoreExpr -- ^ expression + -> DsM CoreExpr +pprRuntimeTrace str doc expr = do + traceId <- dsLookupGlobalId traceName + unpackCStringId <- dsLookupGlobalId unpackCStringName + dflags <- getDynFlags + let message :: CoreExpr + message = App (Var unpackCStringId) $ + Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc) + return $ mkApps (Var traceId) [Type (exprType expr), message, expr] + +-- | See 'getCCIndexM'. +getCCIndexDsM :: FastString -> DsM CostCentreIndex +getCCIndexDsM = getCCIndexM ds_cc_st diff --git a/GHC/HsToCore/Pmc.hs b/GHC/HsToCore/Pmc.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Pmc.hs @@ -0,0 +1,708 @@ + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | This module coverage checks pattern matches. It finds +-- +-- * Uncovered patterns, certifying non-exhaustivity +-- * Redundant equations +-- * Equations with an inaccessible right-hand-side +-- +-- The algorithm is based on the paper +-- [Lower Your Guards: A Compositional Pattern-Match Coverage Checker"](https://dl.acm.org/doi/abs/10.1145/3408989) +-- +-- There is an overview Figure 2 in there that's probably helpful. +-- Here is an overview of how it's implemented, which follows the structure of +-- the entry points such as 'pmcMatches': +-- +-- 1. Desugar source syntax (like 'LMatch') to guard tree variants (like +-- 'GrdMatch'), with one of the desugaring functions (like 'desugarMatch'). +-- See "GHC.HsToCore.Pmc.Desugar". +-- Follows Section 3.1 in the paper. +-- 2. Coverage check guard trees (with a function like 'checkMatch') to get a +-- 'CheckResult'. See "GHC.HsToCore.Pmc.Check". +-- The normalised refinement types 'Nabla' are tested for inhabitants by +-- "GHC.HsToCore.Pmc.Solver". +-- 3. Collect redundancy information into a 'CIRB' with a function such +-- as 'cirbsMatch'. Follows the R function from Figure 6 of the paper. +-- 4. Format and report uncovered patterns and redundant equations ('CIRB') +-- with 'formatReportWarnings'. Basically job of the G function, plus proper +-- pretty printing of the warnings (Section 5.4 of the paper). +-- 5. Return 'Nablas' reaching syntactic sub-components for +-- Note [Long-distance information]. Collected by functions such as +-- 'ldiMatch'. See Section 4.1 of the paper. +module GHC.HsToCore.Pmc ( + -- Checking and printing + pmcPatBind, pmcMatches, pmcGRHSs, pmcRecSel, + isMatchContextPmChecked, isMatchContextPmChecked_SinglePat, + + -- See Note [Long-distance information] + addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas, + getNFirstUncovered + ) where + +import GHC.Prelude + +import GHC.HsToCore.Errors.Types +import GHC.HsToCore.Pmc.Types +import GHC.HsToCore.Pmc.Utils +import GHC.HsToCore.Pmc.Desugar +import GHC.HsToCore.Pmc.Check +import GHC.HsToCore.Pmc.Solver +import GHC.Types.Basic (Origin(..), isDoExpansionGenerated) +import GHC.Core +import GHC.Driver.DynFlags +import GHC.Hs +import GHC.Types.Id +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.Var (EvVar, Var (..)) +import GHC.Types.Id.Info +import GHC.Tc.Utils.TcType (evVarPred) +import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr) +import GHC.HsToCore.Monad +import GHC.Data.Bag +import GHC.Data.OrdList + +import Control.Monad (when, unless, forM_) +import qualified Data.Semigroup as Semi +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.Coerce +import GHC.Tc.Utils.Monad + +-- +-- * Exported entry points to the checker +-- + +-- | A non-empty delta that is initialised from the ambient refinement type +-- capturing long-distance information, or the trivially habitable 'Nablas' if +-- the former is uninhabited. +-- See Note [Recovering from unsatisfiable pattern-matching constraints]. +getLdiNablas :: DsM Nablas +getLdiNablas = do + nablas <- getPmNablas + isInhabited nablas >>= \case + True -> pure nablas + False -> pure initNablas + +-- | We need to call the Hs desugarer to get the Core of a let-binding or where +-- clause. We don't want to run the coverage checker when doing so! Efficiency +-- is one concern, but also a lack of properly set up long-distance information +-- might trigger warnings that we normally wouldn't emit. +noCheckDs :: DsM a -> DsM a +noCheckDs = updTopFlags (\dflags -> foldl' wopt_unset dflags allPmCheckWarnings) + +-- | Check a pattern binding (let, where) for exhaustiveness. +pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM Nablas +pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p + = mb_discard_warnings $ do + !missing <- getLdiNablas + pat_bind <- noCheckDs $ desugarPatBind loc var p + tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing]) + result <- unCA (checkPatBind pat_bind) missing + let ldi = ldiGRHS $ ( \ pb -> case pb of PmPatBind grhs -> grhs) $ cr_ret result + tracePm "pmcPatBind }: " $ + vcat [ text "cr_uncov:" <+> ppr (cr_uncov result) + , text "ldi:" <+> ppr ldi ] + formatReportWarnings ReportPatBind ctxt [var] result + return ldi + where + -- See Note [pmcPatBind doesn't warn on pattern guards] + mb_discard_warnings + = if want_pmc match_ctxt + then id + else discardWarningsDs + want_pmc PatBindRhs = True + want_pmc LazyPatCtx = True + want_pmc (StmtCtxt stmt_ctxt) = + case stmt_ctxt of + PatGuard {} -> False + _ -> True + want_pmc _ = False + +-- | Exhaustive for guard matches, is used for guards in pattern bindings and +-- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs. +pmcGRHSs + :: HsMatchContextRn -- ^ Match context, for warning messages + -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check + -> DsM (NonEmpty Nablas) -- ^ Covered 'Nablas' for each RHS, for long + -- distance info +pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do + let combined_loc = foldl1 combineSrcSpans (NE.map getLocA grhss) + ctxt = DsMatchContext hs_ctxt combined_loc + !missing <- getLdiNablas + matches <- noCheckDs $ desugarGRHSs combined_loc empty guards + tracePm "pmcGRHSs" (hang (vcat [ppr ctxt + , text "Guards:"]) + 2 + (pprGRHSs hs_ctxt guards $$ ppr missing)) + result <- unCA (checkGRHSs matches) missing + tracePm "}: " (ppr (cr_uncov result)) + formatReportWarnings ReportGRHSs ctxt [] result + return (ldiGRHSs (cr_ret result)) + +-- | Check a list of syntactic 'Match'es (part of case, functions, etc.), each +-- with a 'Pat' and one or more 'GRHSs': +-- +-- @ +-- f x y | x == y = 1 -- match on x and y with two guarded RHSs +-- | otherwise = 2 +-- f _ _ = 3 -- clause with a single, un-guarded RHS +-- @ +-- +-- Returns one non-empty 'Nablas' for 1.) each pattern of a 'Match' and 2.) +-- each of a 'Match'es 'GRHS' for Note [Long-distance information]. +-- +-- Special case: When there are /no matches/, then the function assumes it +-- checks an @-XEmptyCase@ with only a single match variable. +-- See Note [Checking EmptyCase]. +pmcMatches + :: Origin + -> DsMatchContext -- ^ Match context, for warnings messages + -> [Id] -- ^ Match variables, i.e. x and y above + -> [LMatch GhcTc (LHsExpr GhcTc)] -- ^ List of matches + -> DsM [(Nablas, NonEmpty Nablas)] -- ^ One covered 'Nablas' per Match and + -- GRHS, for long distance info. +pmcMatches origin ctxt vars matches = {-# SCC "pmcMatches" #-} do + -- We have to force @missing@ before printing out the trace message, + -- otherwise we get interleaved output from the solver. This function + -- should be strict in @missing@ anyway! + !missing <- getLdiNablas + tracePm "pmcMatches {" $ + hang (vcat [ppr origin, ppr ctxt, ppr vars, text "Matches:"]) + 2 + ((ppr matches) $$ (text "missing:" <+> ppr missing)) + case NE.nonEmpty matches of + Nothing -> do + -- This must be an -XEmptyCase. See Note [Checking EmptyCase] + let var = only vars + empty_case <- noCheckDs $ desugarEmptyCase var + result <- unCA (checkEmptyCase empty_case) missing + tracePm "}: " (ppr (cr_uncov result)) + formatReportWarnings ReportEmptyCase ctxt vars result + return [] + Just matches -> do + matches <- {-# SCC "desugarMatches" #-} + noCheckDs $ desugarMatches vars matches + tracePm "desugared matches" (ppr matches) + result <- {-# SCC "checkMatchGroup" #-} + unCA (checkMatchGroup matches) missing + tracePm "}: " (ppr (cr_uncov result)) + unless (isDoExpansionGenerated origin) -- Do expansion generated code shouldn't emit overlapping warnings + ({-# SCC "formatReportWarnings" #-} + formatReportWarnings ReportMatchGroup ctxt vars result) + return (NE.toList (ldiMatchGroup (cr_ret result))) + +{- +Note [Detecting incomplete record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes the implementation of +GHC proposal 516 "Add warning for incomplete record selectors". + +A **partial field** is a field that does not belong to every constructor of the +corresponding datatype. +A **partial selector occurrence** is a use of a record selector for a partial +field, either as a selector function in an expression, or as the solution to a +HasField constraint. + +Partial selector occurrences desugar to case expressions which may crash at +runtime: + + data T a where + T1 :: T Int + T2 {sel :: Int} :: T Bool + + urgh :: T a -> Int + urgh x = sel x + ===> + urgh x = case x of + T1 -> error "no record field sel" + T2 f -> f + +As such, it makes sense to warn about such potential crashes. +We do so whenever -Wincomplete-record-selectors is present, and we utilise +the pattern-match coverage checker for precise results, because there are many +uses of selectors for partial fields which are in fact dynamically safe. + +Pmc can detect two very common safe uses for which we will not warn: + + (LDI) Ambient pattern-matches unleash Note [Long-distance information] that + render a naively flagged partial selector occurrence safe, as in + ldi :: T a -> Int + ldi T1 = 0 + ldi arg = sel arg + We should not warn here, because `arg` cannot be `T1`. + + (RES) Constraining the result type of a GADT such as T might render + naively flagged partial selector occurrences safe, as in + resTy :: T Bool -> Int + resTy = sel + Here, `T1 :: T Int` is ruled out because it has the wrong result type. + +Additionally, we want to support incomplete -XOverloadedRecordDot access as +well, in either the (LDI) use case or the (RES) use case: + + data Dot = No | Yes { sel2 :: Int } + dot d = d.sel2 -- should warn + ldiDot No = 0 + ldiDot d = d.sel2 -- should not warn + resTyDot :: T Bool -> Int + resTyDot x = x.sel -- should not warn + +From a user's point of view, function `ldiDot` looks very like example `ldi` and +`resTyDot` looks very like `resTy`. But from an /implementation/ point of view +they are very different: both `ldiDot` and `resTyDot` simply emit `HasField` +constraints, and it is those constraints that the implementation must use to +determine incompleteness. + +Furthermore, HasField constraints allow to delay the completeness check from +the field access site to a caller, as in test cases TcIncompleteRecSel and T24891: + + accessDot :: HasField "sel2" t Int => t -> Int + accessDot x = x.sel2 -- getField @Symbol @"sel2" @t @Int x + solveDot :: Dot -> Int + solveDot = accessDot + +We should warn in `solveDot`, but not in `accessDot`. + +Here is how we achieve all this in the implementation: + +(IRS1) When renaming a record selector in `mkOneRecordSelector`, + we precompute the constructors the selector succeeds on. + That would be `T2` for `sel` because `sel (T2 42)` succeeds, + and `Yes` for `sel2` because `sel2 (Yes 13)` succeeds. + We store this information in the `sel_cons` field of `RecSelId`. + (Remember, the same field may occur in several constructors of the data + type; hence the selector may succeed on more than one constructor.) + +We generate warnings for incomplete record selectors in two places: +* Mainly: in GHC.HsToCore.Expr.ds_app (see (IRS2-5) below) +* Plus: in GHC.Tc.Instance.Class.matchHassField (see (IRS6-7) below) + +(IRS2) In function `ldi`, we have a record selector application `sel arg`. + This situation is detected `GHC.HsToCore.Expr.ds_app_rec_sel`, when the + record selector is applied to at least one argument. We call out to the + pattern-match checker to determine whether use of the selector is safe, + by calling GHC.HsToCore.Pmc.pmcRecSel, passing the `RecSelId` `sel` as + well as `arg`. + + The pattern-match checker reduces the partial-selector-occurrence problem to + a complete-match problem by adding a negative constructor constraint such as + `arg /~ T2` for every constructor in the precomputed `rsi_def . sel_cons` of + `sel`. (Recall that these were exactly the constructors which define a field + `sel`.) `pmcRecSel` then tests + case arg of {} + for completeness. Any incomplete match, such as in the original `urgh`, must + reference a constructor that does not have field `sel`, such as `T1`. + + In case of `urgh`, `T1` is indeed the case that we report as inexhaustive. + + However, in function `ldi`, we have *both* the result type of + `arg::T a` (boring, but see (IRS3)) as well as Note [Long-distance information] + about `arg` from the ambient match, and the latter lists the constraint + `arg /~ T1`. Consequently, since `arg` is neither `T1` nor `T2` in the + reduced problem, the match is exhaustive and the use of the record selector + safe. + +(IRS3) In function `resTy`, the record selector is unsaturated, but the result type + ensures a safe use of the selector. + + This situation is also detected in `GHC.HsToCore.Expr.ds_app_rec_sel`. + THe selector is elaborated with its type arguments; we simply match on + desugared Core `sel @Bool :: T Bool -> Int` to learn the result type `T Bool`. + We again call `pmcRecSel`, but this time with a fresh dummy Id `ds::T Bool`. + +(IRS4) In case of an unsaturated record selector that is *not* applied to any type + argument after elaboration (e.g. in `urgh2 = sel2 :: Dot -> Int`), we simply + produce a warning about all `sel_cons`; no need to call `pmcRecSel`. + This happens in `ds_app_rec_sel` + +Finally, there are two more items addressing -XOverloadedRecordDot: + +(IRS5) With -XOverloadedDot, all occurrences of (r.x), such as in `ldiDot` and + `accessDot` above, are warned about as follows. `r.x` is parsed as + `HsGetField` in `HsExpr`; which is then expanded (in `rnExpr`) to a call to + `getField`. For example, consider: + ldiDot No = 0 + ldiDot x = x.sel2 -- should not warn + The `d.sel2` in the RHS generates + getField @GHC.Types.Symbol @"sel2" @Dot @Int + ($dHasField :: HasField "sel2" Dot Int) x + where + $dHasField = sel2 |> (co :: Dot -> Int ~R# HasField "sel2" Dot Int) + We spot this `getField` application in `GHC.HsToCore.Expr.ds_app_var`, + and treat it exactly like (IRS2) and (IRS3). + + Note carefully that doing this in the desugarer allows us to account for the + long-distance info about `x`; even though `sel2` is partial, we don't want + to warn about `x.sel2` in this example. + +(IRS6) Finally we have + solveDot :: Dot -> Int + solveDot = accessDot + No field-accesses or selectors in sight! From the RHS we get the constraint + [W] HasField @"sel2" @Dot @Int` + The only time we can generate a warning is when we solve this constraint, + in `GHC.Tc.Instance.Class.matchHasField`, generating a call to the (partial) + selector. We have no hope of exploiting long-distance info here. + +(IRS7) BUT, look back at `ldiDot`. Doesn't `matchHasField` /also/ generate a + warning for the `HasField` constraint arising from `x.sel2`? We don't + want that, because the desugarer will catch it: see (IRS5). So we suppress + the (IRS6) warning in the typechecker for a `HasField` constraint that + arises from a record-dot HsGetField occurrence. Happily, this is easy to do + by looking at its `CtOrigin`. Tested in T24891. +-} + +pmcRecSel :: Id -- ^ Id of the selector + -> CoreExpr -- ^ Core expression of the argument to the selector + -> DsM () +-- See (IRS2,3) in Note [Detecting incomplete record selectors] +pmcRecSel sel_id arg + | RecSelId{ sel_cons = rec_sel_info } <- idDetails sel_id + , RSI { rsi_def = cons_w_field, rsi_undef = cons_wo_field } <- rec_sel_info + , not (null cons_wo_field) + = do { !missing <- getLdiNablas + + ; tracePm "pmcRecSel {" (ppr sel_id) + ; CheckResult{ cr_ret = PmRecSel{ pr_arg_var = arg_id }, cr_uncov = uncov_nablas } + <- unCA (checkRecSel (PmRecSel () arg cons_w_field)) missing + ; tracePm "}: " $ ppr uncov_nablas + + ; inhabited <- isInhabited uncov_nablas + ; when inhabited $ warn_incomplete arg_id uncov_nablas } + + | otherwise + = return () + + where + sel_name = varName sel_id + warn_incomplete arg_id uncov_nablas = do + dflags <- getDynFlags + let maxPatterns = maxUncoveredPatterns dflags + unc_examples <- getNFirstUncovered MinimalCover [arg_id] (maxPatterns + 1) uncov_nablas + let cons = [con | unc_example <- unc_examples + , Just (PACA (PmAltConLike con) _ _) <- [lookupSolution unc_example arg_id]] + tracePm "unc-ex" (ppr cons $$ ppr unc_examples) + diagnosticDs $ DsIncompleteRecordSelector sel_name cons maxPatterns + + +{- Note [pmcPatBind doesn't warn on pattern guards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +@pmcPatBind@'s main purpose is to check vanilla pattern bindings, like +@x :: Int; Just x = e@, which is in a @PatBindRhs@ context. +But its caller is also called for individual pattern guards in a @StmtCtxt@. +For example, both pattern guards in @f x y | True <- x, False <- y = ...@ will +go through this function. It makes no sense to report pattern match warnings +for these pattern guards: + + * Pattern guards may well fail. Fall-through is not an unrecoverable panic, + but rather behavior the programmer expects, so inexhaustivity should not be + reported. + + * Redundancy is already reported for the whole GRHS via one of the other + exported coverage checking functions. Also, reporting individual redundant + guards is... redundant. See #17646. + +However, we should not skip pattern-match checking altogether, as it may reveal +important long-distance information. One example is described in +Note [Long-distance information in do notation] in GHC.HsToCore.Expr. + +Instead, we simply discard warnings when in pattern-guards, by using the function +discardWarningsDs. +-} + +-- +-- * Collecting long-distance information +-- + +ldiMatchGroup :: PmMatchGroup Post -> NonEmpty (Nablas, NonEmpty Nablas) +ldiMatchGroup (PmMatchGroup matches) = ldiMatch <$> matches + +ldiMatch :: PmMatch Post -> (Nablas, NonEmpty Nablas) +ldiMatch (PmMatch { pm_pats = red, pm_grhss = grhss }) = + (rs_cov red, ldiGRHSs grhss) + +ldiGRHSs :: PmGRHSs Post -> NonEmpty Nablas +ldiGRHSs (PmGRHSs { pgs_grhss = grhss }) = ldiGRHS <$> grhss + +ldiGRHS :: PmGRHS Post -> Nablas +ldiGRHS (PmGRHS { pg_grds = red }) = rs_cov red + +-- +-- * Collecting redundancy information +-- + +-- | The result of redundancy checking: +-- * RHSs classified as /C/overed, /I/naccessible and /R/edundant +-- * And redundant /B/ang patterns. See Note [Dead bang patterns]. +data CIRB + = CIRB + { cirb_cov :: !(OrdList SrcInfo) -- ^ Covered clauses + , cirb_inacc :: !(OrdList SrcInfo) -- ^ Inaccessible clauses + , cirb_red :: !(OrdList SrcInfo) -- ^ Redundant clauses + , cirb_bangs :: !(OrdList SrcInfo) -- ^ Redundant bang patterns + } + +instance Semigroup CIRB where + CIRB a b c d <> CIRB e f g h = CIRB (a <> e) (b <> f) (c <> g) (d <> h) + where (<>) = (Semi.<>) + +instance Monoid CIRB where + mempty = CIRB mempty mempty mempty mempty + +-- See Note [Determining inaccessible clauses] +ensureOneNotRedundant :: CIRB -> CIRB +ensureOneNotRedundant ci = case ci of + CIRB { cirb_cov = NilOL, cirb_inacc = NilOL, cirb_red = ConsOL r rs } + -> ci { cirb_inacc = unitOL r, cirb_red = rs } + _ -> ci + +-- | Only adds the redundant bangs to the @CIRB@ if there is at least one +-- non-redundant 'SrcInfo'. There is no point in remembering a redundant bang +-- if the whole match is redundant! +addRedundantBangs :: OrdList SrcInfo -> CIRB -> CIRB +addRedundantBangs _red_bangs cirb@CIRB { cirb_cov = NilOL, cirb_inacc = NilOL } = + cirb +addRedundantBangs red_bangs cirb = + cirb { cirb_bangs = cirb_bangs cirb Semi.<> red_bangs } + +-- | Checks the 'Nablas' in a 'RedSets' for inhabitants and returns +-- 1. Whether the Covered set was inhabited +-- 2. Whether the Diverging set was inhabited +-- 3. All source bangs whose 'Nablas' were empty, which means they are +-- redundant. +testRedSets :: RedSets -> DsM (Bool, Bool, OrdList SrcInfo) +testRedSets RedSets { rs_cov = cov, rs_div = div, rs_bangs = bangs } = do + is_covered <- isInhabited cov + may_diverge <- isInhabited div + red_bangs <- flip mapMaybeM (fromOL bangs) $ \(nablas, bang) -> + isInhabited nablas >>= \case + True -> pure Nothing + False -> pure (Just bang) + pure (is_covered, may_diverge, toOL red_bangs) + +cirbsMatchGroup :: PmMatchGroup Post -> DsM CIRB +cirbsMatchGroup (PmMatchGroup matches) = + Semi.sconcat <$> traverse cirbsMatch matches + +cirbsMatch :: PmMatch Post -> DsM CIRB +cirbsMatch PmMatch { pm_pats = red, pm_grhss = grhss } = do + (_is_covered, may_diverge, red_bangs) <- testRedSets red + -- Don't look at is_covered: If it is True, all children are redundant anyway, + -- unless there is a 'considerAccessible', which may break that rule + -- intentionally. See Note [considerAccessible] in "GHC.HsToCore.Pmc.Check". + cirb <- cirbsGRHSs grhss + pure $ addRedundantBangs red_bangs + -- See Note [Determining inaccessible clauses] + $ applyWhen may_diverge ensureOneNotRedundant + $ cirb + +cirbsGRHSs :: PmGRHSs Post -> DsM CIRB +cirbsGRHSs (PmGRHSs { pgs_grhss = grhss }) = Semi.sconcat <$> traverse cirbsGRHS grhss + +cirbsGRHS :: PmGRHS Post -> DsM CIRB +cirbsGRHS PmGRHS { pg_grds = red, pg_rhs = info } = do + (is_covered, may_diverge, red_bangs) <- testRedSets red + let cirb | is_covered = mempty { cirb_cov = unitOL info } + | may_diverge = mempty { cirb_inacc = unitOL info } + | otherwise = mempty { cirb_red = unitOL info } + pure (addRedundantBangs red_bangs cirb) + +cirbsEmptyCase :: PmEmptyCase -> DsM CIRB +cirbsEmptyCase _ = pure mempty + +cirbsPatBind :: PmPatBind Post -> DsM CIRB +cirbsPatBind = coerce cirbsGRHS + +{- Note [Determining inaccessible clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f _ True = () + f () True = () + f _ _ = () +Is f's second clause redundant? The perhaps surprising answer is, no, it isn't! +@f (error "boom") False@ will force the error with clause 2, but will return +() if it was deleted, so clearly not redundant. Yet for now combination of +arguments we can ever reach clause 2's RHS, so we say it has inaccessible RHS +(as opposed to being completely redundant). + +We detect an inaccessible RHS simply by pretending it's redundant, until we see +-} + +-- +-- * Formatting and reporting warnings +-- + +-- | A datatype to accommodate the different call sites of +-- 'formatReportWarnings'. Used for extracting 'CIRB's from a concrete 'ann' +-- through 'collectInMode'. Since this is only possible for a couple of +-- well-known 'ann's, this is a GADT. +data FormatReportWarningsMode ann where + ReportPatBind :: FormatReportWarningsMode (PmPatBind Post) + ReportGRHSs :: FormatReportWarningsMode (PmGRHSs Post) + ReportMatchGroup:: FormatReportWarningsMode (PmMatchGroup Post) + ReportEmptyCase:: FormatReportWarningsMode PmEmptyCase + +deriving instance Eq (FormatReportWarningsMode ann) + +-- | A function collecting 'CIRB's for each of the different +-- 'FormatReportWarningsMode's. +collectInMode :: FormatReportWarningsMode ann -> ann -> DsM CIRB +collectInMode ReportPatBind = cirbsPatBind +collectInMode ReportGRHSs = cirbsGRHSs +collectInMode ReportMatchGroup = cirbsMatchGroup +collectInMode ReportEmptyCase = cirbsEmptyCase + +-- | Given a 'FormatReportWarningsMode', this function will emit warnings +-- for a 'CheckResult'. +formatReportWarnings :: FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult ann -> DsM () +formatReportWarnings report_mode ctx vars cr@CheckResult { cr_ret = ann } = do + cov_info <- collectInMode report_mode ann + dflags <- getDynFlags + reportWarnings dflags report_mode ctx vars cr{cr_ret=cov_info} + +-- | Issue all the warnings +-- (redundancy, inaccessibility, exhaustiveness, redundant bangs). +reportWarnings :: DynFlags -> FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM () +reportWarnings dflags report_mode (DsMatchContext kind loc) vars + CheckResult { cr_ret = CIRB { cirb_inacc = inaccessible_rhss + , cirb_red = redundant_rhss + , cirb_bangs = redundant_bangs } + , cr_uncov = uncovered + , cr_approx = precision } + = when (flag_i || flag_u || flag_b) $ do + unc_examples <- getNFirstUncovered gen_mode vars (maxPatterns + 1) uncovered + let exists_r = flag_i && notNull redundant_rhss + exists_i = flag_i && notNull inaccessible_rhss + exists_u = flag_u && notNull unc_examples + exists_b = flag_b && notNull redundant_bangs + approx = precision == Approximate + + when (approx && (exists_u || exists_i)) $ + putSrcSpanDs loc (diagnosticDs (DsMaxPmCheckModelsReached (maxPmCheckModels dflags))) + + when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) -> + putSrcSpanDs l (diagnosticDs (DsRedundantBangPatterns kind q)) + + when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) -> + putSrcSpanDs l (diagnosticDs (DsOverlappingPatterns kind q)) + when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) -> + putSrcSpanDs l (diagnosticDs (DsInaccessibleRhs kind q)) + + when exists_u $ + putSrcSpanDs loc (diagnosticDs (DsNonExhaustivePatterns kind check_type maxPatterns vars unc_examples)) + where + flag_i = overlapping dflags kind + flag_u = exhaustive dflags kind + flag_b = redundantBang dflags + check_type = ExhaustivityCheckType (exhaustiveWarningFlag kind) + gen_mode = case report_mode of -- See Note [Case split inhabiting patterns] + ReportEmptyCase -> CaseSplitTopLevel + _ -> MinimalCover + + maxPatterns = maxUncoveredPatterns dflags + +getNFirstUncovered :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nablas -> DsM [Nabla] +getNFirstUncovered mode vars n (MkNablas nablas) = go n (bagToList nablas) + where + go 0 _ = pure [] + go _ [] = pure [] + go n (nabla:nablas) = do + front <- generateInhabitingPatterns mode vars n nabla + back <- go (n - length front) nablas + pure (front ++ back) + +-- +-- * Adding external long-distance information +-- + +-- | Locally update 'dsl_nablas' with the given action, but defer evaluation +-- with 'unsafeInterleaveM' in order not to do unnecessary work. +locallyExtendPmNablas :: DsM a -> (Nablas -> DsM Nablas) -> DsM a +locallyExtendPmNablas k ext = do + nablas <- getLdiNablas + nablas' <- unsafeInterleaveM $ ext nablas + updPmNablas nablas' k + +-- | Add in-scope type constraints if the coverage checker might run and then +-- run the given action. +addTyCs :: Origin -> Bag EvVar -> DsM a -> DsM a +addTyCs origin ev_vars thing_inside + | isEmptyBag ev_vars + = thing_inside -- Very common fast path + | otherwise + = do { dflags <- getDynFlags + ; if needToRunPmCheck dflags origin + then locallyExtendPmNablas thing_inside $ \nablas -> + addPhiCtsNablas nablas (PhiTyCt . evVarPred <$> ev_vars) + else thing_inside } + +-- | Add equalities for the 'CoreExpr' scrutinees to the local 'DsM' environment, +-- e.g. when checking a case expression: +-- case e of x { matches } +-- When checking matches we record that (x ~ e) where x is the initial +-- uncovered. All matches will have to satisfy this equality. +-- This is also used for the Arrows \cases command, where these equalities have +-- to be added for multiple scrutinees rather than just one. +addCoreScrutTmCs :: [CoreExpr] -> [Id] -> DsM a -> DsM a +addCoreScrutTmCs [] _ k = k +addCoreScrutTmCs (scr:scrs) (x:xs) k + = locallyExtendPmNablas (addCoreScrutTmCs scrs xs k) $ \nablas -> + addPhiCtsNablas nablas (unitBag (PhiCoreCt x scr)) +addCoreScrutTmCs _ _ _ = panic "addCoreScrutTmCs: numbers of scrutinees and match ids differ" + +-- | 'addCoreScrutTmCs', but desugars the 'LHsExpr's first. +addHsScrutTmCs :: [LHsExpr GhcTc] -> [Id] -> DsM a -> DsM a +addHsScrutTmCs scrs vars k = do + scr_es <- traverse dsLExpr scrs + addCoreScrutTmCs scr_es vars k + +{- Note [Long-distance information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data Color = R | G | B + f :: Color -> Int + f R = … + f c = … (case c of + G -> True + B -> False) … + +Humans can make the "long-distance connection" between the outer pattern match +and the nested case pattern match to see that the inner pattern match is +exhaustive: @c@ can't be @R@ anymore because it was matched in the first clause +of @f@. + +To achieve similar reasoning in the coverage checker, we keep track of the set +of values that can reach a particular program point (often loosely referred to +as "Covered set") in 'GHC.HsToCore.Monad.dsl_nablas'. +We fill that set with Covered Nablas returned by the exported checking +functions, which the call sites put into place with +'GHC.HsToCore.Monad.updPmNablas'. +Call sites also extend this set with facts from type-constraint dictionaries, +case scrutinees, etc. with the exported functions 'addTyCs', 'addCoreScrutTmCs' +and 'addHsScrutTmCs'. + +Note [Recovering from unsatisfiable pattern-matching constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following code (see #12957 and #15450): + + f :: Int ~ Bool => () + f = case True of { False -> () } + +We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC +used not to do this; in fact, it would warn that the match was /redundant/! +This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the +coverage checker deems any matches with unsatisfiable constraint sets to be +unreachable. + +We make sure to always start from an inhabited 'Nablas' by calling +'getLdiNablas', which falls back to the trivially inhabited 'Nablas' if the +long-distance info returned by 'GHC.HsToCore.Monad.getPmNablas' is empty. +-} diff --git a/GHC/HsToCore/Pmc/Check.hs b/GHC/HsToCore/Pmc/Check.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Pmc/Check.hs @@ -0,0 +1,410 @@ + +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} + +-- | Coverage checking step of the +-- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989). +-- +-- Coverage check guard trees (like @'PmMatch' 'Pre'@) to get a +-- 'CheckResult', containing +-- +-- 1. The set of uncovered values, 'cr_uncov' +-- 2. And an annotated tree variant (like @'PmMatch' 'Post'@) that captures +-- redundancy and inaccessibility information as 'RedSets' annotations +-- +-- Basically the UA function from Section 5.1, which is an optimised +-- interleaving of U and A from Section 3.2 (Figure 5). +-- The Normalised Refinement Types 'Nablas' are maintained in +-- "GHC.HsToCore.Pmc.Solver". +module GHC.HsToCore.Pmc.Check ( + CheckAction(..), + checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase, checkRecSel + ) where + +import GHC.Prelude + +import GHC.Builtin.Names ( hasKey, considerAccessibleIdKey, trueDataConKey ) +import GHC.HsToCore.Monad ( DsM ) +import GHC.HsToCore.Pmc.Types +import GHC.HsToCore.Pmc.Utils +import GHC.HsToCore.Pmc.Solver +import GHC.Driver.DynFlags +import GHC.Utils.Outputable +import GHC.Tc.Utils.TcType (evVarPred) +import GHC.Data.OrdList +import GHC.Data.Bag + +import qualified Data.Semigroup as Semi +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.Coerce +import GHC.Types.Var +import GHC.Core +import GHC.Core.Utils + +-- | Coverage checking action. Can be composed 'leftToRight' or 'topToBottom'. +newtype CheckAction a = CA { unCA :: Nablas -> DsM (CheckResult a) } + deriving Functor + +-- | A 'CheckAction' representing a successful pattern-match. +matchSucceeded :: CheckAction RedSets +matchSucceeded = CA $ \inc -> -- succeed + pure CheckResult { cr_ret = emptyRedSets { rs_cov = inc } + , cr_uncov = mempty + , cr_approx = Precise } + +-- | Composes 'CheckAction's top-to-bottom: +-- If a value falls through the resulting action, then it must fall through the +-- first action and then through the second action. +-- If a value matches the resulting action, then it either matches the +-- first action or matches the second action. +-- Basically the semantics of the LYG branching construct. +topToBottom :: ((Nablas -> (Precision, Nablas)) -> top -> bot -> (Precision, ret)) + -> CheckAction top + -> CheckAction bot + -> CheckAction ret +topToBottom f (CA top) (CA bot) = CA $ \inc -> do + t <- top inc + b <- bot (cr_uncov t) + limit <- maxPmCheckModels <$> getDynFlags + -- See Note [Countering exponential blowup] + let throttler cov = throttle limit inc cov + let (prec', ret) = f throttler (cr_ret t) (cr_ret b) + pure CheckResult { cr_ret = ret + , cr_uncov = cr_uncov b + , cr_approx = prec' Semi.<> cr_approx t Semi.<> cr_approx b } + + +-- | Composes 'CheckAction's left-to-right: +-- If a value falls through the resulting action, then it either falls through the +-- first action or through the second action. +-- If a value matches the resulting action, then it must match the first action +-- and then match the second action. +-- Basically the semantics of the LYG guard construct. +leftToRight :: (RedSets -> right -> ret) + -> CheckAction RedSets + -> CheckAction right + -> CheckAction ret +leftToRight f (CA left) (CA right) = CA $ \inc -> do + l <- left inc + r <- right (rs_cov (cr_ret l)) + limit <- maxPmCheckModels <$> getDynFlags + let uncov = cr_uncov l Semi.<> cr_uncov r + -- See Note [Countering exponential blowup] + let (prec', uncov') = throttle limit inc uncov + pure CheckResult { cr_ret = f (cr_ret l) (cr_ret r) + , cr_uncov = uncov' + , cr_approx = prec' Semi.<> cr_approx l Semi.<> cr_approx r } + +-- | @throttle limit old new@ returns @old@ if the number of 'Nabla's in @new@ +-- is exceeding the given @limit@ and the @old@ number of 'Nabla's. +-- See Note [Countering exponential blowup]. +throttle :: Int -> Nablas -> Nablas -> (Precision, Nablas) +throttle limit old@(MkNablas old_ds) new@(MkNablas new_ds) + --- | pprTrace "PmCheck:throttle" (ppr (length old_ds) <+> ppr (length new_ds) <+> ppr limit) False = undefined + | length new_ds > max limit (length old_ds) = (Approximate, old) + | otherwise = (Precise, new) + +checkAlternatives :: (grdtree -> CheckAction anntree) -> NonEmpty grdtree -> CheckAction (NonEmpty anntree) +-- The implementation is pretty similar to +-- @traverse1 :: Apply f => (a -> f b) -> NonEmpty a -> f (NonEmpty b)@ +checkAlternatives act (t :| []) = (:| []) <$> act t +checkAlternatives act (t1 :| (t2:ts)) = + topToBottom (no_throttling (NE.<|)) (act t1) (checkAlternatives act (t2:|ts)) + where + no_throttling f _throttler t b = (Precise, f t b) + +emptyRedSets :: RedSets +-- Semigroup instance would be misleading! +emptyRedSets = RedSets mempty mempty mempty + +checkGrd :: PmGrd -> CheckAction RedSets +checkGrd grd = CA $ \inc -> case grd of + -- let x = e: Refine with x ~ e + PmLet x e -> do + matched <- addPhiCtNablas inc (PhiCoreCt x e) + tracePm "check:Let" (ppr x <+> char '=' <+> ppr e) + pure CheckResult { cr_ret = emptyRedSets { rs_cov = matched } + , cr_uncov = mempty + , cr_approx = Precise } + -- Bang x _: Diverge on x ~ ⊥, refine with x ≁ ⊥ + PmBang x mb_info -> do + div <- addPhiCtNablas inc (PhiBotCt x) + matched <- addPhiCtNablas inc (PhiNotBotCt x) + -- See Note [Dead bang patterns] + -- mb_info = Just info <==> PmBang originates from bang pattern in source + let bangs | Just info <- mb_info = unitOL (div, info) + | otherwise = NilOL + tracePm "check:Bang" (ppr x <+> ppr div) + pure CheckResult { cr_ret = RedSets { rs_cov = matched, rs_div = div, rs_bangs = bangs } + , cr_uncov = mempty + , cr_approx = Precise } + -- See point (3) of Note [considerAccessible] + PmCon x (PmAltConLike con) _ _ _ + | x `hasKey` considerAccessibleIdKey + , con `hasKey` trueDataConKey + -> pure CheckResult { cr_ret = emptyRedSets { rs_cov = initNablas } + , cr_uncov = mempty + , cr_approx = Precise } + -- Con: Fall through on x ≁ K and refine with x ~ K ys and type info + PmCon x con tvs dicts args -> do + !div <- if isPmAltConMatchStrict con + then addPhiCtNablas inc (PhiBotCt x) + else pure mempty + !matched <- addPhiCtNablas inc (PhiConCt x con tvs (map evVarPred dicts) args) + !uncov <- addPhiCtNablas inc (PhiNotConCt x con) + tracePm "check:Con" $ vcat + [ ppr grd + , ppr inc + , hang (text "div") 2 (ppr div) + , hang (text "matched") 2 (ppr matched) + , hang (text "uncov") 2 (ppr uncov) + ] + pure CheckResult { cr_ret = emptyRedSets { rs_cov = matched, rs_div = div } + , cr_uncov = uncov + , cr_approx = Precise } + + + +checkGrdDag :: GrdDag -> CheckAction RedSets +checkGrdDag (GdOne g) = checkGrd g +checkGrdDag GdEnd = matchSucceeded +checkGrdDag (GdSeq dl dr) = leftToRight merge (checkGrdDag dl) (checkGrdDag dr) + where + -- Note that + -- * the incoming set of dr is the covered set of dl + -- * the covered set of dr is a subset of the incoming set of dr + -- * this is so that the covered set of dr is the covered set of the + -- entire sequence + -- Hence we merge by returning @rs_cov ri_r@ as the covered set. + merge ri_l ri_r = + RedSets { rs_cov = rs_cov ri_r + , rs_div = rs_div ri_l Semi.<> rs_div ri_r + , rs_bangs = rs_bangs ri_l Semi.<> rs_bangs ri_r } +checkGrdDag (GdAlt dt db) = topToBottom merge (checkGrdDag dt) (checkGrdDag db) + where + -- The intuition here: ri_b is disjoint with ri_t, because db only gets + -- fed the "leftover" uncovered set of dt. But for the GrdDag that follows + -- to the right of the GdAlt (say), we have to reunite the RedSets. Hence + -- component-wise merge. + -- After the GdAlt, we unite the covered sets. If they become too large, we + -- throttle, continuing with the incoming set. + merge throttler ri_t ri_b = + let (prec, cov) = throttler (rs_cov ri_t Semi.<> rs_cov ri_b) in + (prec, RedSets { rs_cov = cov + , rs_div = rs_div ri_t Semi.<> rs_div ri_b + , rs_bangs = rs_bangs ri_t Semi.<> rs_bangs ri_b }) + +checkMatchGroup :: PmMatchGroup Pre -> CheckAction (PmMatchGroup Post) +checkMatchGroup (PmMatchGroup matches) = + PmMatchGroup <$> checkAlternatives checkMatch matches + +checkMatch :: PmMatch Pre -> CheckAction (PmMatch Post) +checkMatch (PmMatch { pm_pats = grds, pm_grhss = grhss }) = + leftToRight PmMatch (checkGrdDag grds) (checkGRHSs grhss) + +checkGRHSs :: PmGRHSs Pre -> CheckAction (PmGRHSs Post) +checkGRHSs (PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss }) = + leftToRight PmGRHSs (checkGrdDag lcls) (checkAlternatives checkGRHS grhss) + +checkGRHS :: PmGRHS Pre -> CheckAction (PmGRHS Post) +checkGRHS (PmGRHS { pg_grds = grds, pg_rhs = rhs_info }) = + flip PmGRHS rhs_info <$> checkGrdDag grds + +checkEmptyCase :: PmEmptyCase -> CheckAction PmEmptyCase +-- See Note [Checking EmptyCase] +checkEmptyCase pe@(PmEmptyCase { pe_var = var }) = CA $ \inc -> do + unc <- addPhiCtNablas inc (PhiNotBotCt var) + pure CheckResult { cr_ret = pe, cr_uncov = unc, cr_approx = mempty } + +checkPatBind :: (PmPatBind Pre) -> CheckAction (PmPatBind Post) +checkPatBind = coerce checkGRHS + +checkRecSel :: PmRecSel () -> CheckAction (PmRecSel Id) +-- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc +checkRecSel pr@(PmRecSel { pr_arg = arg, pr_cons = cons }) = CA $ \inc -> do + arg_id <- case arg of + Var arg_id -> return arg_id + _ -> mkPmId $ exprType arg + + let con_cts = map (PhiNotConCt arg_id . PmAltConLike) cons + arg_ct = PhiCoreCt arg_id arg + phi_cts = listToBag (arg_ct : con_cts) + unc <- addPhiCtsNablas inc phi_cts + pure CheckResult { cr_ret = pr{ pr_arg_var = arg_id }, cr_uncov = unc, cr_approx = mempty } + + +{- Note [Checking EmptyCase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-XEmptyCase is useful for matching on empty data types like 'Void'. For example, +the following is a complete match: + + f :: Void -> () + f x = case x of {} + +Really, -XEmptyCase is the only way to write a program that at the same time is +safe (@f _ = error "boom"@ is not because of ⊥), doesn't trigger a warning +(@f !_ = error "inaccessible" has inaccessible RHS) and doesn't turn an +exception into divergence (@f x = f x@). + +Semantically, unlike every other case expression, -XEmptyCase is strict in its +match var x, which rules out ⊥ as an inhabitant. So we add x ≁ ⊥ to the +initial Nabla and check if there are any values left to match on. + +Note [Dead bang patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + f :: Bool -> Int + f True = 1 + f !x = 2 + +Whenever we fall through to the second equation, we will already have evaluated +the argument. Thus, the bang pattern serves no purpose and should be warned +about. We call this kind of bang patterns "dead". Dead bangs are the ones +that under no circumstances can force a thunk that wasn't already forced. +Dead bangs are a form of redundant bangs; see below. + +We can detect dead bang patterns by checking whether @x ~ ⊥@ is satisfiable +where the PmBang appears in 'checkGrd'. If not, then clearly the bang is +dead. So for a source bang, we add the refined Nabla and the source info to +the 'RedSet's 'rs_bangs'. When collecting stuff to warn, we test that Nabla for +inhabitants. If it's empty, we'll warn that it's redundant. + +Note that we don't want to warn for a dead bang that appears on a redundant +clause. That is because in that case, we recommend to delete the clause wholly, +including its leading pattern match. + +Dead bang patterns are redundant. But there are bang patterns which are +redundant that aren't dead, for example + + f !() = 0 + +the bang still forces the match variable, before we attempt to match on (). But +it is redundant with the forcing done by the () match. We currently don't +detect redundant bangs that aren't dead. + +Note [Countering exponential blowup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Precise pattern match exhaustiveness checking is necessarily exponential in +the size of some input programs. We implement a counter-measure in the form of +the -fmax-pmcheck-models flag, limiting the number of Nablas we check against +each pattern by a constant. + +How do we do that? Consider + + f True True = () + f True True = () + +And imagine we set our limit to 1 for the sake of the example. The first clause +will be checked against the initial Nabla, {}. Doing so will produce an +Uncovered set of size 2, containing the models {x≁True} and {x~True,y≁True}. +Also we find the first clause to cover the model {x~True,y~True}. + +But the Uncovered set we get out of the match is too large! We somehow have to +ensure not to make things worse than they are already, so we continue checking +with a singleton Uncovered set of the initial Nabla {}. Why is this +sound (wrt. the notion in GADTs Meet Their Match)? Well, it basically amounts +to forgetting that we matched against the first clause. The values represented +by {} are a superset of those represented by its two refinements {x≁True} and +{x~True,y≁True}. + +This forgetfulness becomes very apparent in the example above: By continuing +with {} we don't detect the second clause as redundant, as it again covers the +same non-empty subset of {}. So we don't flag everything as redundant anymore, +but still will never flag something as redundant that isn't. + +For exhaustivity, the converse applies: We will report @f@ as non-exhaustive +and report @f _ _@ as missing, which is a superset of the actual missing +matches. But soundness means we will never fail to report a missing match. + +This mechanism is implemented in 'throttle'. + +Guards are an extreme example in this regard, with #11195 being a particularly +dreadful example: Since their RHS are often pretty much unique, we split on a +variable (the one representing the RHS) that doesn't occur anywhere else in the +program, so we don't actually get useful information out of that split! +We counter this by throttling *Uncovered* sets in `leftToRight`. + +Another challenge is posed by or-patterns (see also Note [Implementation of OrPatterns]): +Large matches such as `f (LT; GT) (LT; GT) .... True = 1` will desugar into +a long sequence of `GdAlt LT GT`. The careless desugaring of `GdAlt` via +`topToBottom` would cause ever enlarging *Covered* sets. +So we throttle when merging Covered sets from LT and GT, by using the original +incoming covered set. The effect is very like replacing (LT; GT) with a wildcard +pattern _. + +Note [considerAccessible] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (T18610) + + f :: Bool -> Int + f x = case (x, x) of + (True, True) -> 1 + (False, False) -> 2 + (True, False) -> 3 -- Warning: Redundant + +The third case is detected as redundant. But it may be the intent of the +programmer to keep the dead code, in order for it not to bitrot or to support +debugging scenarios. But there is no way to communicate that to the +pattern-match checker! The only way is to deactivate pattern-match checking +whole-sale, which is quite annoying. Hence, we define in "GHC.Exts": + + considerAccessible = True + +'considerAccessible' is treated specially by the pattern-match checker in that a +guard with it as the scrutinee expression will keep its parent clause alive: + + g :: Bool -> Int + g x = case (x, x) of + (True, True) -> 1 + (False, False) -> 2 + (True, False) | GHC.Exts.considerAccessible -> 3 -- No warning + +The key bits of the implementation are: + + 1. Its definition is recognised as known-key (see "GHC.Builtin.Names"). + 2. After "GHC.HsToCore.Pmc.Desugar", the guard will end up as a 'PmCon', where + the match var is the known-key 'considerAccessible' and the constructor + against which it matches is 'True'. + 3. We recognise the 'PmCon' in 'GHC.HsToCore.Check.checkGrd' and inflate the + incoming set of values for all guards downstream to the unconstrained + 'initNablas' set, e.g. /all/ values. + (The set of values that falls through that particular guard is empty, as + matching 'considerAccessible' against 'True' can't fail.) + +Note that 'considerAccessible' breaks the invariant that incoming sets of values +reaching syntactic children are subsets of that of the syntactic ancestor: +A whole match, like that of the third clause of the example, might have no +incoming value, but its single RHS has incoming values because of (3). + +That means the 'is_covered' flag computed in 'GHC.HsToCore.Pmc.cirbsMatch' +is irrelevant and should not be used to flag all children as redundant (which is +what we used to do). + +We achieve great benefits with a very simple implementation. +There are caveats, though: + + (A) Putting potentially failing guards /after/ the + 'considerAccessible' guard might lead to weird check results, e.g., + + h :: Bool -> Int + h x = case (x, x) of + (True, True) -> 1 + (False, False) -> 2 + (True, False) | GHC.Exts.considerAccessible, False <- x -> 3 + -- Warning: Not matched: (_, _) + + That *is* fixable, although we would pay with a much more complicated + implementation. + (B) If the programmer puts a 'considerAccessible' marker on an accessible + clause, the checker doesn't warn about it. E.g., + + f :: Bool -> Int + f True | considerAccessible = 0 + f False = 1 + + will not emit any warning whatsoever. We could implement code that warns + here, but it wouldn't be as simple as it is now. +-} diff --git a/GHC/HsToCore/Pmc/Desugar.hs b/GHC/HsToCore/Pmc/Desugar.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Pmc/Desugar.hs @@ -0,0 +1,563 @@ + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DisambiguateRecordFields #-} + +-- | Desugaring step of the +-- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989). +-- +-- Desugars Haskell source syntax into guard tree variants Pm*. +-- In terms of the paper, this module is concerned with Sections 3.1, Figure 4, +-- in particular. +module GHC.HsToCore.Pmc.Desugar ( + desugarPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase + ) where + +import GHC.Prelude + +import GHC.HsToCore.Pmc.Types +import GHC.HsToCore.Pmc.Utils +import GHC.Core (Expr(Var,App)) +import GHC.Data.FastString (unpackFS, lengthFS) +import GHC.Driver.DynFlags +import GHC.Hs +import GHC.Tc.Utils.TcMType (shortCutLit) +import GHC.Types.Id +import GHC.Core.ConLike +import GHC.Types.Name +import GHC.Builtin.Types +import GHC.Builtin.Names (rationalTyConName, toListName) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Core.DataCon +import GHC.Types.Var (EvVar) +import GHC.Core.Coercion +import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper) +import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr) +import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper) +import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar, decideBangHood) +import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) +import GHC.HsToCore.Monad +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.Type +import GHC.Data.Maybe +import GHC.Types.SourceText (FractionalLit(..)) +import Control.Monad (zipWithM, replicateM) +import Data.List (elemIndex) +import Data.List.NonEmpty ( NonEmpty(..) ) + +-- import GHC.Driver.Ppr + +-- | Smart constructor that eliminates trivial lets +mkPmLetVar :: Id -> Id -> GrdDag +mkPmLetVar x y = sequencePmGrds [ PmLet x (Var y) | x /= y ] + +-- | ADT constructor pattern => no existentials, no local constraints +vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd +vanillaConGrd scrut con arg_ids = + PmCon { pm_id = scrut, pm_con_con = PmAltConLike (RealDataCon con) + , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = arg_ids } + +-- | Creates a 'GrdDag' refining a match var of list type to a list, +-- where list fields are matched against the incoming tagged 'GrdDag's. +-- For example: +-- @mkListGrds "a" "[(x, True <- x),(y, !y)]"@ +-- to +-- @"[(x:b) <- a, True <- x, (y:c) <- b, !y, [] <- c]"@ +-- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match +-- variable. +mkListGrds :: Id -> [(Id, GrdDag)] -> DsM GrdDag +-- See Note [Order of guards matters] for why we need to intertwine guards +-- on list elements. +mkListGrds a [] = pure (GdOne (vanillaConGrd a nilDataCon [])) +mkListGrds a ((x, head_grds):xs) = do + b <- mkPmId (idType a) + tail_grds <- mkListGrds b xs + pure $ vanillaConGrd a consDataCon [x, b] `consGrdDag` head_grds `gdSeq` tail_grds + +-- | Create a 'GrdDag' refining a match variable to a 'PmLit'. +mkPmLitGrds :: Id -> PmLit -> DsM GrdDag +mkPmLitGrds x (PmLit _ (PmLitString s)) = do + -- We desugar String literals to list literals for better overlap reasoning. + -- It's a little unfortunate we do this here rather than in + -- 'GHC.HsToCore.Pmc.Solver.trySolve' and + -- 'GHC.HsToCore.Pmc.Solver.addRefutableAltCon', but it's so much simpler + -- here. See Note [Representation of Strings in TmState] in + -- GHC.HsToCore.Pmc.Solver + vars <- replicateM (lengthFS s) (mkPmId charTy) + let mk_char_lit y c = mkPmLitGrds y (PmLit charTy (PmLitChar c)) + char_grdss <- zipWithM mk_char_lit vars (unpackFS s) + mkListGrds x (zip vars char_grdss) +mkPmLitGrds x lit = do + let grd = PmCon { pm_id = x + , pm_con_con = PmAltLit lit + , pm_con_tvs = [] + , pm_con_dicts = [] + , pm_con_args = [] } + pure (GdOne grd) + +-- | @desugarPat _ x pat@ transforms @pat@ into a 'GrdDag', where +-- the variable representing the match is @x@. +desugarPat :: Id -> Pat GhcTc -> DsM GrdDag +desugarPat x pat = case pat of + WildPat _ty -> pure GdEnd + VarPat _ y -> pure (mkPmLetVar (unLoc y) x) + ParPat _ p -> desugarLPat x p + LazyPat _ _ -> pure GdEnd -- like a wildcard + BangPat _ p@(L l p') -> + -- Add the bang in front of the list, because it will happen before any + -- nested stuff. + consGrdDag (PmBang x pm_loc) <$> desugarLPat x p + where pm_loc = Just (SrcInfo (L (locA l) (ppr p'))) + + -- (x@pat) ==> Desugar pat with x as match var and handle impedance + -- mismatch with incoming match var + AsPat _ (L _ y) p -> (mkPmLetVar y x `gdSeq`) <$> desugarLPat y p + SigPat _ p _ty -> desugarLPat x p + EmbTyPat _ _ -> pure GdEnd + InvisPat _ _ -> pure GdEnd + + XPat ext -> case ext of + + ExpansionPat orig expansion -> do + case orig of + -- We add special logic for overloaded list patterns. When: + -- - a ViewPat is the expansion of a ListPat, + -- - 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 lrhs pat <- expansion + , Just tc <- tyConAppTyCon_maybe arg_ty + , tc == listTyCon + -- `pat` looks like `coerce toList -> [p1,...,pn]`. + -- Now take care of -XRebindableSyntax: + , let is_to_list (HsVar _ (L _ to_list)) = idName to_list == toListName + is_to_list (XExpr (WrapExpr _ e)) = is_to_list e + is_to_list _ = False + , is_to_list (unLoc lrhs) + -> 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 + dsHsWrapper wrapper $ \wrap_rhs_y -> + pure (PmLet y (wrap_rhs_y (Var x)) `consGrdDag` grds) -- (n + k) ===> let b = x >= k, True <- b, let n = x-k + NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do + b <- mkPmId boolTy + let grd_b = vanillaConGrd b trueDataCon [] + [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2] + rhs_b <- dsSyntaxExpr ge [Var x, ke1] + rhs_n <- dsSyntaxExpr minus [Var x, ke2] + pure $ sequencePmGrds [PmLet b rhs_b, grd_b, PmLet n rhs_n] + + -- (fun -> pat) ===> let y = fun x, pat <- y where y is a match var of pat + ViewPat _arg_ty lexpr pat -> do + (y, grds) <- desugarLPatV pat + fun <- dsLExpr lexpr + pure $ consGrdDag (PmLet y (App fun (Var x))) grds -- list + ListPat _ ps -> + desugarListPat x ps + + ConPat { pat_con = L _ con + , pat_args = ps + , pat_con_ext = ConPatTc + { cpt_arg_tys = arg_tys + , cpt_tvs = ex_tvs + , cpt_dicts = dicts + } + } -> + desugarConPatOut x con arg_tys ex_tvs dicts ps + + NPat ty (L _ olit) mb_neg _ -> do + -- See Note [Literal short cut] in "GHC.HsToCore.Match.Literal" + -- We inline the Literal short cut for @ty@ here, because @ty@ is more + -- precise than the field of OverLitTc, which is all that dsOverLit (which + -- normally does the literal short cut) can look at. Also @ty@ matches the + -- type of the scrutinee, so info on both pattern and scrutinee (for which + -- short cutting in dsOverLit works properly) is overloaded iff either is. + dflags <- getDynFlags + let platform = targetPlatform dflags + pm_lit <- case olit of + OverLit{ ol_val = val, ol_ext = OverLitTc { ol_rebindable = rebindable } } + | not rebindable + , Just expr <- shortCutLit platform val ty + -> coreExprAsPmLit <$> dsExpr expr + | not rebindable + , (HsFractional f) <- val + , negates <- if fl_neg f then 1 else 0 + -> do + rat_tc <- dsLookupTyCon rationalTyConName + let rat_ty = mkTyConTy rat_tc + return $ Just $ PmLit rat_ty (PmLitOverRat negates f) + | otherwise + -> do + dsLit <- dsOverLit olit + let !pmLit = coreExprAsPmLit dsLit :: Maybe PmLit + -- pprTraceM "desugarPat" + -- ( + -- text "val" <+> ppr val $$ + -- text "witness" <+> ppr (ol_witness olit) $$ + -- text "dsLit" <+> ppr dsLit $$ + -- text "asPmLit" <+> ppr pmLit + -- ) + return pmLit + + let lit = case pm_lit of + Just l -> l + Nothing -> pprPanic "failed to detect OverLit" (ppr olit) + let lit' = case mb_neg of + Just _ -> expectJust (negatePmLit lit) + Nothing -> lit + mkPmLitGrds x lit' + + LitPat _ lit -> do + core_expr <- dsLit lit + let lit = expectJust (coreExprAsPmLit core_expr) + mkPmLitGrds x lit + + TuplePat _tys pats boxity -> do + (vars, grdss) <- mapAndUnzipM desugarLPatV pats + let tuple_con = tupleDataCon boxity (length vars) + pure $ vanillaConGrd x tuple_con vars `consGrdDag` sequenceGrdDags grdss + + OrPat _tys pats -> alternativesGrdDags <$> traverse (desugarLPat x) pats + + SumPat _ty p alt arity -> do + (y, grds) <- desugarLPatV p + let sum_con = sumDataCon alt arity + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + pure $ vanillaConGrd x sum_con [y] `consGrdDag` grds + + SplicePat {} -> panic "Check.desugarPat: SplicePat" + + +-- | 'desugarPat', but also select and return a new match var. +desugarPatV :: Pat GhcTc -> DsM (Id, GrdDag) +desugarPatV pat = do + x <- selectMatchVar ManyTy pat + grds <- desugarPat x pat + pure (x, grds) + +desugarLPat :: Id -> LPat GhcTc -> DsM GrdDag +desugarLPat x = desugarPat x . unLoc + +-- | 'desugarLPat', but also select and return a new match var. +desugarLPatV :: LPat GhcTc -> DsM (Id, GrdDag) +desugarLPatV = desugarPatV . unLoc + +-- | @desugarListPat _ x [p1, ..., pn]@ is basically +-- @desugarConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever +-- constructing the 'ConPatOut's. +desugarListPat :: Id -> [LPat GhcTc] -> DsM GrdDag +desugarListPat x pats = do + vars_and_grdss <- traverse desugarLPatV pats + mkListGrds x vars_and_grdss + +-- | Desugar a constructor pattern +desugarConPatOut :: Id -> ConLike -> [Type] -> [TyVar] + -> [EvVar] -> HsConPatDetails GhcTc -> DsM GrdDag +desugarConPatOut x con univ_tys ex_tvs dicts = \case + PrefixCon ps -> go_field_pats (zip [0..] ps) + InfixCon p1 p2 -> go_field_pats (zip [0..] [p1,p2]) + RecCon (HsRecFields NoExtField fs _) -> go_field_pats (rec_field_ps fs) + where + -- The actual argument types (instantiated) + arg_tys = map scaledThing $ conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs) + + -- Extract record field patterns tagged by field index from a list of + -- LHsRecField + rec_field_ps fs = map (tagged_pat . unLoc) fs + where + tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hfbRHS f) + -- Unfortunately the label info is empty when the DataCon wasn't defined + -- with record field labels, hence we desugar to field index. + orig_lbls = map flSelector $ conLikeFieldLabels con + lbl_to_index lbl = expectJust $ elemIndex lbl orig_lbls + + go_field_pats tagged_pats = do + -- The fields that appear might not be in the correct order. So + -- 1. Do the PmCon match + -- 2. Then pattern match on the fields in the order given by the first + -- field of @tagged_pats@. + -- See Note [Field match order for RecCon] + + -- Desugar the mentioned field patterns. We're doing this first to get + -- the Ids for pm_con_args and bring them in order afterwards. + let trans_pat (n, pat) = do + (var, pvec) <- desugarLPatV pat + pure ((n, var), pvec) + (tagged_vars, arg_grdss) <- mapAndUnzipM trans_pat tagged_pats + + let get_pat_id n ty = case lookup n tagged_vars of + Just var -> pure var + Nothing -> mkPmId ty + + -- 1. the constructor pattern match itself + arg_ids <- zipWithM get_pat_id [0..] arg_tys + let con_grd = PmCon x (PmAltConLike con) ex_tvs dicts arg_ids + + -- 2. guards from field selector patterns + let arg_grds = sequenceGrdDags arg_grdss + + -- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids) + pure (con_grd `consGrdDag` arg_grds) + +desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre) +-- See 'GrdPatBind' for how this simply repurposes GrdGRHS. +desugarPatBind loc var pat = + PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarPat var pat + +desugarEmptyCase :: Id -> DsM PmEmptyCase +desugarEmptyCase var = pure PmEmptyCase { pe_var = var } + +-- | Desugar the non-empty 'Match'es of a 'MatchGroup'. +desugarMatches :: [Id] -> NonEmpty (LMatch GhcTc (LHsExpr GhcTc)) + -> DsM (PmMatchGroup Pre) +desugarMatches vars matches = + PmMatchGroup <$> traverse (desugarMatch vars) matches + +-- Desugar a single match +desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre) +desugarMatch vars (L match_loc (Match { m_pats = L _ pats, m_grhss = grhss })) = do + dflags <- getDynFlags + -- decideBangHood: See Note [Desugaring -XStrict matches in Pmc] + let banged_pats = map (decideBangHood dflags) pats + pats' <- sequenceGrdDags <$> zipWithM desugarLPat vars banged_pats + grhss' <- desugarGRHSs (locA match_loc) (sep (map ppr pats)) grhss + -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss']) + return PmMatch { pm_pats = pats', pm_grhss = grhss' } + +desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre) +desugarGRHSs match_loc pp_pats grhss = do + lcls <- desugarLocalBinds (grhssLocalBinds grhss) + grhss' <- traverse (desugarLGRHS match_loc pp_pats) (grhssGRHSs grhss) + return PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss' } + +-- | Desugar a guarded right-hand side to a single 'GrdTree' +desugarLGRHS :: SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (PmGRHS Pre) +desugarLGRHS match_loc pp_pats (L _loc (GRHS _ gs _)) = do + -- _loc points to the match separator (ie =, ->) that comes after the guards. + -- Hence we have to pass in the match_loc, which we use in case that the RHS + -- is unguarded. + -- pp_pats is the space-separated pattern of the current Match this + -- GRHS belongs to, so the @A B x@ part in @A B x | 0 <- x@. + let rhs_info = case gs of + [] -> L match_loc pp_pats + (L grd_loc _):_ -> L (locA grd_loc) (pp_pats <+> vbar <+> interpp'SP gs) + grdss <- traverse (desugarGuard . unLoc) gs + pure PmGRHS { pg_grds = sequenceGrdDags grdss, pg_rhs = SrcInfo rhs_info } + +-- | Desugar a guard statement to a 'GrdDag' +desugarGuard :: GuardStmt GhcTc -> DsM GrdDag +desugarGuard guard = case guard of + BodyStmt _ e _ _ -> desugarBoolGuard e + LetStmt _ binds -> desugarLocalBinds binds + BindStmt _ p e -> desugarBind p e + LastStmt {} -> panic "desugarGuard LastStmt" + ParStmt {} -> panic "desugarGuard ParStmt" + TransStmt {} -> panic "desugarGuard TransStmt" + RecStmt {} -> panic "desugarGuard RecStmt" + XStmtLR ApplicativeStmt{} -> panic "desugarGuard ApplicativeLastStmt" + +sequenceGrdDagMapM :: Applicative f => (a -> f GrdDag) -> [a] -> f GrdDag +sequenceGrdDagMapM f as = sequenceGrdDags <$> traverse f as + +-- | Desugar local bindings to a bunch of 'PmLet' guards. +-- Deals only with simple @let@ or @where@ bindings without any polymorphism, +-- recursion, pattern bindings etc. +-- See Note [Long-distance information for HsLocalBinds]. +desugarLocalBinds :: HsLocalBinds GhcTc -> DsM GrdDag +desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) = + sequenceGrdDagMapM (sequenceGrdDagMapM go) (map snd binds) + where + go :: LHsBind GhcTc -> DsM GrdDag + go (L _ FunBind{fun_id = L _ x, fun_matches = mg}) + -- See Note [Long-distance information for HsLocalBinds] for why this + -- pattern match is so very specific. + | L _ [L _ Match{m_pats = L _ [], m_grhss = grhss}] <- mg_alts mg + , GRHSs{grhssGRHSs = L _ (GRHS _ _grds rhs) :| []} <- grhss = do + core_rhs <- dsLExpr rhs + return (GdOne (PmLet x core_rhs)) + go (L _ (XHsBindsLR (AbsBinds + { abs_tvs = [], abs_ev_vars = [] + , abs_exports=exports, abs_binds = binds }))) = do + -- Typechecked HsLocalBinds are wrapped in AbsBinds, which carry + -- renamings. See Note [Long-distance information for HsLocalBinds] + -- for the details. + let go_export :: ABExport -> Maybe PmGrd + go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap} + | isIdHsWrapper wrap + = assertPpr (idType x `eqType` idType y) + (ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y)) $ + Just $ PmLet x (Var y) + | otherwise + = Nothing + let exps = mapMaybe go_export exports + bs <- sequenceGrdDagMapM go binds + return (sequencePmGrds exps `gdSeq` bs) + go _ = return GdEnd +desugarLocalBinds _binds = return GdEnd + +-- | Desugar a pattern guard +-- @pat <- e ==> let x = e; @ +desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM GrdDag +desugarBind p e = dsLExpr e >>= \case + Var y + | Nothing <- isDataConId_maybe y + -- RHS is a variable, so that will allow us to omit the let + -> desugarLPat y p + rhs -> do + (x, grds) <- desugarLPatV p + pure (PmLet x rhs `consGrdDag` grds) + +-- | Desugar a boolean guard +-- @e ==> let x = e; True <- x@ +desugarBoolGuard :: LHsExpr GhcTc -> DsM GrdDag +desugarBoolGuard e + | isJust (isTrueLHsExpr e) = return GdEnd + -- The formal thing to do would be to generate (True <- True) + -- but it is trivial to solve so instead we give back an empty + -- GrdDag for efficiency + | otherwise = dsLExpr e >>= \case + Var y + | Nothing <- isDataConId_maybe y + -- Omit the let by matching on y + -> pure (GdOne (vanillaConGrd y trueDataCon [])) + rhs -> do + x <- mkPmId boolTy + pure $ sequencePmGrds [PmLet x rhs, vanillaConGrd x trueDataCon []] + +{- Note [Field match order for RecCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The order for RecCon field patterns actually determines evaluation order of +the pattern match. For example: + + data T = T { a :: Char, b :: Int } + f :: T -> () + f T{ b = 42, a = 'a' } = () + +Then @f (T (error "a") (error "b"))@ errors out with "b" because it is mentioned +first in the pattern match. + +This means we can't just desugar the pattern match to +@[T a b <- x, 'a' <- a, 42 <- b]@. Instead we have to force them in the +right order: @[T a b <- x, 42 <- b, 'a' <- a]@. + +Note [Order of guards matters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Similar to Note [Field match order for RecCon], the order in which the guards +for a pattern match appear matter. Consider a situation similar to T5117: + + f (0:_) = () + f (0:[]) = () + +The latter clause is clearly redundant. Yet if we desugar the second clause as + + [x:xs' <- xs, [] <- xs', 0 <- x] + +We will say that the second clause only has an inaccessible RHS. That's because +we force the tail of the list before comparing its head! So the correct +translation would have been + + [x:xs' <- xs, 0 <- x, [] <- xs'] + +And we have to take in the guards on list cells into @mkListGrds@. + +Note [Desugar CoPats] +~~~~~~~~~~~~~~~~~~~~~~~ +The pattern match checker did not know how to handle coerced patterns +`CoPat` efficiently, which gave rise to #11276. The original approach +desugared `CoPat`s: + + pat |> co ===> x (pat <- (x |> co)) + +Why did we do this seemingly unnecessary expansion in the first place? +The reason is that the type of @pat |> co@ (which is the type of the value +abstraction we match against) might be different than that of @pat@. Data +instances such as @Sing (a :: Bool)@ are a good example of this: If we would +just drop the coercion, we'd get a type error when matching @pat@ against its +value abstraction, with the result being that pmIsSatisfiable decides that every +possible data constructor fitting @pat@ is rejected as uninhabited, leading to +a lot of false warnings. + +But we can check whether the coercion is a hole or if it is just refl, in +which case we can drop it. + +Note [Long-distance information for HsLocalBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#18626) + + f :: Int -> () + f x | y = () + where + y = True + + x :: () + x | let y = True, y = () + +Both definitions are exhaustive, but to make the necessary long-distance +connection from @y@'s binding to its use site in a guard, we have to collect +'PmLet' guards for the 'HsLocalBinds' which contain @y@'s definitions. + +In principle, we are only interested in desugaring local binds that are +'FunBind's, that + + * Have no pattern matches. If @y@ above had any patterns, it would be a + function and we can't reason about them anyway. + * Have singleton match group with a single GRHS. + Otherwise, what expression to pick in the generated guard @let y = @? + +It turns out that desugaring type-checked local binds in this way is a bit +more complex than expected: Apparently, all bindings are wrapped in 'AbsBinds' +Nfter type-checking. See Note [AbsBinds] in "GHC.Hs.Binds". + +We make sure that there is no polymorphism in the way by checking that there +are no 'abs_tvs' or 'abs_ev_vars' (we don't reason about +@y :: forall a. Eq a => ...@) and that the exports carry no 'HsWrapper's. In +this case, the exports are a simple renaming substitution that we can capture +with 'PmLet'. Ultimately we'll hit those renamed 'FunBind's, though, which is +the whole point. + +The place to store the 'PmLet' guards for @where@ clauses (which are per +'GRHSs') is as a field of 'PmGRHSs'. For plain @let@ guards as in the guards of +@x@, we can simply add them to the 'pg_grds' field of 'PmGRHS'. + +Note [Desugaring -XStrict matches in Pmc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#21761) + + {-# LANGUAGE Strict #-} + idV :: Void -> Void + idV v = v + +Without -XStrict, we would not warn here. But with -XStrict, there is an +implicit bang on `v` and we should give an inaccessible warning for the RHS. +The way we account for that is by calling `decideBangHood` on patterns +in a `Match`, which inserts the implicit bang. + +Making the call here actually seems redundant with the call to `decideBangHood` +in `GHC.HsToCore.Match.matchWrapper`, which does it *after* it calls the +pattern-match checker on the Match's patterns. It would be great if we could expect +`matchWrapper` to pass the bang-adorned `Match` to the pattern-match checker, +but sadly then we get worse warning messages which would print `idV` as if the +user *had* written a bang: + + Pattern match has inaccessible right hand side +- In an equation for ‘idV’: idV v = ... ++ In an equation for ‘idV’: idV !v = ... + +So we live with the duplication. +-} diff --git a/GHC/HsToCore/Pmc/Ppr.hs b/GHC/HsToCore/Pmc/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Pmc/Ppr.hs @@ -0,0 +1,206 @@ + + + +-- | Provides facilities for pretty-printing 'Nabla's in a way appropriate for +-- user facing pattern match warnings. +module GHC.HsToCore.Pmc.Ppr ( + pprUncovered + ) where + +import GHC.Prelude + +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf +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.Data.Maybe +import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) + +import GHC.HsToCore.Pmc.Types + +-- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its +-- components and refutable shapes associated to any mentioned variables. +-- +-- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]])@: +-- +-- @ +-- (Just p) q +-- where p is not one of {3, 4} +-- q is not one of {0, 5} +-- @ +-- +-- When the set of refutable shapes contains more than 3 elements, the +-- additional elements are indicated by "...". +pprUncovered :: Nabla -> [Id] -> SDoc +pprUncovered nabla vas + | isNullUDFM refuts = fsep vec -- there are no refutations + | otherwise = hang (fsep vec) 4 $ + text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts)) + where + init_prec + -- No outer parentheses when it's a unary pattern by assuming lowest + -- precedence + | [_] <- vas = topPrec + | otherwise = appPrec + ppr_action = mapM (pprPmVar init_prec) vas + (vec, renamings) = runPmPpr nabla ppr_action + refuts = prettifyRefuts nabla renamings + +-- | Output refutable shapes of a variable in the form of @var is not one of {2, +-- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is +-- indicated by an ellipsis. +pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc +pprRefutableShapes (var, alts) + = var <+> text "is not one of" <+> format_alts alts + where + format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt + shorten (a:b:c:_:_) = a:b:c:[text "..."] + shorten xs = xs + ppr_alt (PmAltConLike cl) = ppr cl + ppr_alt (PmAltLit lit) = ppr lit + +{- 1. Literals +~~~~~~~~~~~~~~ +Starting with a function definition like: + + f :: Int -> Bool + f 5 = True + f 6 = True + +The uncovered set looks like: + { var |> var /= 5, var /= 6 } + +Yet, we would like to print this nicely as follows: + x , where x not one of {5,6} + +Since these variables will be shown to the programmer, we give them better names +(t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'. + +2. Residual Constraints +~~~~~~~~~~~~~~~~~~~~~~~ +Unhandled constraints that refer to HsExpr are typically ignored by the solver +(it does not even substitute in HsExpr so they are even printed as wildcards). +Additionally, the oracle returns a substitution if it succeeds so we apply this +substitution to the vectors before printing them out (see function `pprOne' in +"GHC.HsToCore.Pmc") to be more precise. +-} + +-- | Extract and assigns pretty names to constraint variables with refutable +-- shapes. +prettifyRefuts :: Nabla -> DIdEnv (Id, SDoc) -> DIdEnv (SDoc, [PmAltCon]) +prettifyRefuts nabla = listToUDFM_Directly . map attach_refuts . udfmToList + where + attach_refuts (u, (x, sdoc)) = (u, (sdoc, lookupRefuts nabla x)) + + +type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) a + +-- Try nice names p,q,r,s,t before using the (ugly) t_i +nameList :: Infinite SDoc +nameList = map text ["p","q","r","s","t"] Inf.++ flip Inf.unfoldr (0 :: Int) (\ u -> (text ('t':show u), u+1)) + +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 Inf 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 diff --git a/GHC/HsToCore/Pmc/Solver.hs b/GHC/HsToCore/Pmc/Solver.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Pmc/Solver.hs @@ -0,0 +1,2136 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +{- +Authors: George Karachalias + Sebastian Graf + Ryan Scott +-} + +-- | Model refinements type as per the +-- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989). +-- The main export of the module are the functions 'addPhiCtsNablas' for adding +-- facts to the oracle, 'isInhabited' to check if a refinement type is inhabited +-- and 'generateInhabitingPatterns' to turn a 'Nabla' into a concrete pattern +-- for an equation. +-- +-- In terms of the LYG paper, this module is concerned with Sections 3.4, 3.6 +-- and 3.7. E.g., it represents refinement types directly as a bunch of +-- normalised refinement types 'Nabla'. + +module GHC.HsToCore.Pmc.Solver ( + + Nabla, Nablas(..), initNablas, + + PhiCt(..), PhiCts, + addPhiCtNablas, + addPhiCtsNablas, + + isInhabited, + generateInhabitingPatterns, GenerateInhabitingPatternsMode(..) + + ) where + +import GHC.Prelude + +import GHC.HsToCore.Pmc.Types +import GHC.HsToCore.Pmc.Utils (tracePm, traceWhenFailPm, mkPmId) +import GHC.HsToCore.Types (DsGblEnv(..)) + +import GHC.Driver.DynFlags +import GHC.Driver.Config +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Monad (allM) +import GHC.Utils.Panic +import GHC.Data.Bag + +import GHC.Types.CompleteMatch +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet +import GHC.Types.Unique.SDFM +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Reader (lookupGRE_Name, GlobalRdrEnv) +import GHC.Types.Var (EvVar) +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Supply + +import GHC.Tc.Utils.Monad (getGblEnv) + +import GHC.Core +import GHC.Core.FVs (exprFreeVars) +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.Map.Expr +import GHC.Core.Predicate (typeDeterminesValue, mkNomEqPred) +import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) +import GHC.Core.Utils (exprType) +import GHC.Core.Make (mkListExpr, mkCharExpr, mkImpossibleExpr) + +import GHC.Data.FastString +import GHC.Types.SrcLoc +import GHC.Data.Maybe +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.TyCon +import GHC.Core.TyCon.RecWalk +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst (elemSubst) +import GHC.Core.Type +import GHC.Tc.Solver (tcNormalise, tcCheckGivens, tcCheckWanteds) +import GHC.Core.Unify (tcMatchTy) +import GHC.Core.Coercion +import GHC.Core.Reduction +import GHC.HsToCore.Monad hiding (foldlM) +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv + +import Control.Applicative ((<|>)) +import Control.Monad (foldM, forM, guard, mzero, when, filterM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict +import Data.Coerce +import Data.Foldable (foldlM, toList) +import Data.Monoid (Any(..)) +import Data.List (sortBy, find) +import qualified Data.List.NonEmpty as NE +import Data.Ord (comparing) + + +-- +-- * Main exports +-- + +-- | Add a bunch of 'PhiCt's to all the 'Nabla's. +-- Lifts 'addPhiCts' over many 'Nablas'. +addPhiCtsNablas :: Nablas -> PhiCts -> DsM Nablas +addPhiCtsNablas nablas cts = liftNablasM (\d -> addPhiCts d cts) nablas + +-- | 'addPmCtsNablas' for a single 'PmCt'. +addPhiCtNablas :: Nablas -> PhiCt -> DsM Nablas +addPhiCtNablas nablas ct = addPhiCtsNablas nablas (unitBag ct) + +liftNablasM :: Monad m => (Nabla -> m (Maybe Nabla)) -> Nablas -> m Nablas +liftNablasM f (MkNablas ds) = MkNablas . catBagMaybes <$> (traverse f ds) + +-- | Test if any of the 'Nabla's is inhabited. Currently this is pure, because +-- we preserve the invariant that there are no uninhabited 'Nabla's. But that +-- could change in the future, for example by implementing this function in +-- terms of @notNull <$> generateInhabitingPatterns 1 ds@. +isInhabited :: Nablas -> DsM Bool +isInhabited (MkNablas ds) = pure (not (null ds)) + +----------------------------------------------- +-- * Caching residual COMPLETE sets + +-- See Note [Implementation of COMPLETE pragmas] + +-- | Update the COMPLETE sets of 'ResidualCompleteMatches', or 'Nothing' +-- if there was no change as per the update function. +updRcm :: (DsCompleteMatch -> (Bool, DsCompleteMatch)) + -> ResidualCompleteMatches -> (Maybe ResidualCompleteMatches) +updRcm f (RCM vanilla pragmas) + | not any_change = Nothing + | otherwise = Just (RCM vanilla' pragmas') + where + f' :: DsCompleteMatch -> (Any, DsCompleteMatch) + f' = coerce f + (chgd, vanilla') = traverse f' vanilla + (chgds, pragmas') = traverse (traverse f') pragmas + any_change = getAny $ chgd `mappend` chgds + +-- | A pseudo-'CompleteMatch' for the vanilla complete set of the given data +-- 'TyCon'. +-- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@ +vanillaCompleteMatchTC :: TyCon -> Maybe DsCompleteMatch +vanillaCompleteMatchTC tc = + let mb_dcs | -- 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. + tc == tYPETyCon = Just [] + | -- Similarly, treat `type data` declarations as empty data types on + -- the term level, as `type data` data constructors only exist at + -- the type level (#22964). See wrinkle (W2a) in + -- Note [Type data declarations] in GHC.Rename.Module. + isTypeDataTyCon tc = Just [] + | otherwise = tyConDataCons_maybe tc + in vanillaCompleteMatch . mkUniqDSet . map RealDataCon <$> mb_dcs + +-- | Initialise from 'dsGetCompleteMatches' (containing all COMPLETE pragmas) +-- if the given 'ResidualCompleteMatches' were empty. +addCompleteMatches :: ResidualCompleteMatches -> DsM ResidualCompleteMatches +addCompleteMatches (RCM v Nothing) = RCM v . Just <$> dsGetCompleteMatches +addCompleteMatches rcm = pure rcm + +-- | Adds the declared 'CompleteMatches' from COMPLETE pragmas, as well as the +-- vanilla data defn if it is a 'DataCon'. +addConLikeMatches :: ConLike -> ResidualCompleteMatches -> DsM ResidualCompleteMatches +addConLikeMatches (RealDataCon dc) rcm = addTyConMatches (dataConTyCon dc) rcm +addConLikeMatches (PatSynCon _) rcm = addCompleteMatches rcm + +-- | Adds +-- * the 'CompleteMatches' from COMPLETE pragmas +-- * and the /vanilla/ 'CompleteMatch' from the data 'TyCon' +-- to the 'ResidualCompleteMatches', if not already present. +addTyConMatches :: TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches +addTyConMatches tc rcm = add_tc_match <$> addCompleteMatches rcm + where + -- Add the vanilla COMPLETE set from the data defn, if any. But only if + -- it's not already present. + add_tc_match rcm + = rcm{rcm_vanilla = rcm_vanilla rcm <|> vanillaCompleteMatchTC tc} + +markMatched :: PmAltCon -> ResidualCompleteMatches -> DsM (Maybe ResidualCompleteMatches) +-- Nothing means the PmAltCon didn't occur in any COMPLETE set. +-- See Note [Shortcutting the inhabitation test] for how this is useful for +-- performance on T17836. +markMatched (PmAltLit _) _ = pure Nothing -- lits are never part of a COMPLETE set +markMatched (PmAltConLike cl) rcm = do + rcm' <- addConLikeMatches cl rcm + let go cm = case lookupUniqDSet (cmConLikes cm) cl of + Nothing -> (False, cm) + Just _ -> (True, cm { cmConLikes = delOneFromUniqDSet (cmConLikes cm) cl }) + pure $ updRcm go rcm' + +{- Note [Implementation of COMPLETE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A COMPLETE set represents a set of conlikes (i.e., constructors or +pattern synonyms) such that if they are all pattern-matched against in a +function, it gives rise to a total function. An example is: + + newtype Boolean = Boolean Int + pattern F, T :: Boolean + pattern F = Boolean 0 + pattern T = Boolean 1 + {-# COMPLETE F, T #-} + + -- This is a total function + booleanToInt :: Boolean -> Int + booleanToInt F = 0 + booleanToInt T = 1 + +COMPLETE sets are represented internally in GHC as a set of 'ConLike's. For +example, the pragma {-# COMPLETE F, T #-} would be represented as: + + CompleteMatch {F, T} Nothing + +What is the Maybe for? Answer: COMPLETE pragmas may optionally specify a +result *type constructor* (cf. T14422): + + class C f where + foo :: f a -> () + pattern P :: C f => f a + pattern P <- (foo -> ()) + + instance C State where + foo _ = () + {-# COMPLETE P :: State #-} + + f :: State a -> () + f P = () + g :: C f => f a -> () + g P = () + +The @:: State@ here means that the types at which the COMPLETE pragma *applies* +is restricted to scrutinee types that are applications of the 'State' TyCon. So +it applies to the match in @f@ but not in @g@ above, resulting in a warning for +the latter but not for the former. The pragma is represented as + + CompleteMatch {P} (Just State) + +GHC collects all COMPLETE pragmas from the current module and from imports +into a field in the DsM environment, which can be accessed with +dsGetCompleteMatches from "GHC.HsToCore.Monad". +Currently, COMPLETE pragmas can't be orphans (e.g. at least one ConLike must +also be defined in the module of the pragma) and do not impact recompilation +checking (#18675). + +The pattern-match checker will then initialise each variable's 'VarInfo' with +*all* imported COMPLETE sets (in 'GHC.HsToCore.Pmc.Solver.addCompleteMatches'), +well-typed or not, into a 'ResidualCompleteMatches'. The trick is that a +COMPLETE set that is ill-typed for that match variable could never be written by +the user! And we make sure not to report any ill-typed COMPLETE sets when +formatting 'Nabla's for warnings in 'generateInhabitingPatterns'. + +A 'ResidualCompleteMatches' is a list of all COMPLETE sets, minus the ConLikes +we know a particular variable can't be (through negative constructor constraints +@x /~ K@ or a failed attempt at instantiating that ConLike during inhabitation +testing). If *any* of the COMPLETE sets become empty, we know that the match +was exhaustive. + +We assume that a COMPLETE set does not apply if for one of its +ConLikes we fail to 'matchConLikeResTy' or the +type of the match variable isn't an application of the optional +result type constructor from the pragma. Why don't we simply +prune inapplicable COMPLETE sets from 'ResidualCompleteMatches'? +The answer is that additional type constraints might make more +COMPLETE sets applicable! Example: + + h :: a -> a :~: Boolean -> () + h x Refl | T <- x = () + | F <- x = () + +If we eagerly prune {F,T} from the residual matches of @x@, then we don't see +that the match in the guards of @h@ is exhaustive, where the COMPLETE set +applies due to refined type information. +-} + +----------------------- +-- * Type normalisation + +-- | The return value of 'pmTopNormaliseType' +data TopNormaliseTypeResult + = NormalisedByConstraints Type + -- ^ 'tcNormalise' was able to simplify the type with some local constraint + -- from the type oracle, but 'topNormaliseTypeX' couldn't identify a type + -- redex. + | HadRedexes Type [(Type, DataCon, Type)] Type + -- ^ 'tcNormalise' may or may not been able to simplify the type, but + -- 'topNormaliseTypeX' made progress either way and got rid of at least one + -- outermost type or data family redex or newtype. + -- The first field is the last type that was reduced solely through type + -- family applications (possibly just the 'tcNormalise'd type). This is the + -- one that is equal (in source Haskell) to the initial type. + -- The third field is the type that we get when also looking through data + -- family applications and newtypes. This would be the representation type in + -- Core (modulo casts). + -- The second field is the list of Newtype 'DataCon's that we looked through + -- in the chain of reduction steps between the Source type and the Core type. + -- We also keep the type of the DataCon application and its field, so that we + -- don't have to reconstruct it in 'inhabitationCandidates' and + -- 'generateInhabitingPatterns'. + -- For an example, see Note [Type normalisation]. + +-- | Return the fields of 'HadRedexes'. Returns appropriate defaults in the +-- other cases. +tntrGuts :: TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type) +tntrGuts (NormalisedByConstraints ty) = (ty, [], ty) +tntrGuts (HadRedexes src_ty ds core_ty) = (src_ty, ds, core_ty) + +instance Outputable TopNormaliseTypeResult where + ppr (NormalisedByConstraints ty) = text "NormalisedByConstraints" <+> ppr ty + ppr (HadRedexes src_ty ds core_ty) = text "HadRedexes" <+> braces fields + where + fields = fsep (punctuate comma [ text "src_ty =" <+> ppr src_ty + , text "newtype_dcs =" <+> ppr ds + , text "core_ty =" <+> ppr core_ty ]) + +pmTopNormaliseType :: TyState -> Type -> DsM TopNormaliseTypeResult +-- ^ Get rid of *outermost* (or toplevel) +-- * type function redex +-- * data family redex +-- * newtypes +-- +-- Behaves like `topNormaliseType_maybe`, but instead of returning a +-- coercion, it returns useful information for issuing pattern matching +-- warnings. See Note [Type normalisation] for details. +-- It also initially 'tcNormalise's the type with the bag of local constraints. +-- +-- See 'TopNormaliseTypeResult' for the meaning of the return value. +-- +-- NB: Normalisation can potentially change kinds, if the head of the type +-- is a type family with a variable result kind. I (Richard E) can't think +-- of a way to cause trouble here, though. +pmTopNormaliseType (TySt _ inert) typ = {-# SCC "pmTopNormaliseType" #-} do + env <- dsGetFamInstEnvs + tracePm "normalise" (ppr typ) + -- Before proceeding, we chuck typ into the constraint solver, in case + -- solving for given equalities may reduce typ some. See + -- "Wrinkle: local equalities" in Note [Type normalisation]. + typ' <- initTcDsForSolver $ tcNormalise inert typ + -- Now we look with topNormaliseTypeX through type and data family + -- applications and newtypes, which tcNormalise does not do. + -- See also 'TopNormaliseTypeResult'. + pure $ case topNormaliseTypeX (stepper env) comb typ' of + Nothing -> NormalisedByConstraints typ' + Just ((ty_f,tm_f), ty) -> HadRedexes src_ty newtype_dcs core_ty + where + src_ty = eq_src_ty ty (typ' : ty_f [ty]) + newtype_dcs = tm_f [] + core_ty = ty + where + -- Find the first type in the sequence of rewrites that is a data type, + -- newtype, or a data family application (not the representation tycon!). + -- This is the one that is equal (in source Haskell) to the initial type. + -- If none is found in the list, then all of them are type family + -- applications, so we simply return the last one, which is the *simplest*. + eq_src_ty :: Type -> [Type] -> Type + eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys) + + is_closed_or_data_family :: Type -> Bool + is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyApp ty + + -- For efficiency, represent both lists as difference lists. + -- comb performs the concatenation, for both lists. + comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2) + + stepper env = newTypeStepper `composeSteppers` tyFamStepper env + + -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into + -- a loop. If it would fall into a loop, it produces 'NS_Abort'. + newTypeStepper :: NormaliseStepper ([Type] -> [Type],[(Type, DataCon, Type)] -> [(Type, DataCon, Type)]) + newTypeStepper rec_nts tc tys + | Just (ty', _co) <- instNewTyCon_maybe tc tys + , let orig_ty = TyConApp tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> let tyf = (orig_ty:) + tmf = ((orig_ty, tyConSingleDataCon tc, ty'):) + in NS_Step rec_nts' ty' (tyf, tmf) + Nothing -> NS_Abort + | otherwise + = NS_Done + + tyFamStepper :: FamInstEnvs -> NormaliseStepper ([Type] -> [Type], a -> a) + tyFamStepper env rec_nts tc tys -- Try to step a type/data family + = case topReduceTyFamApp_maybe env tc tys of + Just (HetReduction (Reduction _ rhs) _) + -> NS_Step rec_nts rhs ((rhs:), id) + _ -> NS_Done + +-- | Returns 'True' if the argument 'Type' is a fully saturated application of +-- a closed type constructor. +-- +-- Closed type constructors are those with a fixed right hand side, as +-- opposed to e.g. associated types. These are of particular interest for +-- pattern-match coverage checking, because GHC can exhaustively consider all +-- possible forms that values of a closed type can take on. +-- +-- Note that this function is intended to be used to check types of value-level +-- patterns, so as a consequence, the 'Type' supplied as an argument to this +-- function should be of kind @Type@. +pmIsClosedType :: Type -> Bool +pmIsClosedType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) + | is_algebraic_like tc && not (isFamilyTyCon tc) + -> assertPpr (ty_args `lengthIs` tyConArity tc) (ppr ty) True + _other -> False + where + -- This returns True for TyCons which /act like/ algebraic types. + -- (See "Type#type_classification" for what an algebraic type is.) + -- + -- This is qualified with \"like\" because of a particular special + -- case: TYPE (the underlying kind behind Type, among others). TYPE + -- is conceptually a datatype (and thus algebraic), but in practice it is + -- a primitive builtin type, so we must check for it specially. + -- + -- NB: it makes sense to think of TYPE as a closed type in a value-level, + -- pattern-matching context. However, at the kind level, TYPE is certainly + -- not closed! Since this function is specifically tailored towards pattern + -- matching, however, it's OK to label TYPE as closed. + is_algebraic_like :: TyCon -> Bool + is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon + +-- | Normalise the given source type to WHNF. If it isn't already in WHNF +-- ('isSourceTypeInWHNF') , it will normalise the type and then try to step +-- through type family applications, but not data family applications or +-- newtypes. +-- +-- This is a pretty common case of calling 'pmTopNormaliseType' and it should be +-- efficient. +normaliseSourceTypeWHNF :: TyState -> Type -> DsM Type +normaliseSourceTypeWHNF _ ty | isSourceTypeInWHNF ty = pure ty +normaliseSourceTypeWHNF ty_st ty = + pmTopNormaliseType ty_st ty >>= \case + NormalisedByConstraints ty -> pure ty + HadRedexes ty _ _ -> pure ty + +-- | Is the source type in WHNF wrt. 'pmTopNormaliseType'? +-- +-- Returns False if the given type is not a TyCon application, or if the TyCon +-- app head is a type family TyCon. (But not for data family TyCons!) +isSourceTypeInWHNF :: Type -> Bool +isSourceTypeInWHNF ty + | Just (tc, _) <- splitTyConApp_maybe ty = not (isTypeFamilyTyCon tc) + | otherwise = False + +{- Note [Type normalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constructs like -XEmptyCase or a previous unsuccessful pattern match on a data +constructor place a non-void constraint on the matched thing. This means that it +boils down to checking whether the type of the scrutinee is inhabited. Function +pmTopNormaliseType gets rid of the outermost type function/data family redex and +newtypes, in search of an algebraic type constructor, which is easier to check +for inhabitation. + +It returns 3 results instead of one, because there are 2 subtle points: +1. Newtypes are isomorphic to the underlying type in core but not in the source + language, +2. The representational data family tycon is used internally but should not be + shown to the user + +Hence, if pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty), +then + (a) src_ty is the rewritten type which we can show to the user. That is, the + type we get if we rewrite type families but not data families or + newtypes. + (b) dcs is the list of newtype constructors "skipped", every time we normalise + a newtype to its core representation, we keep track of the source data + constructor. For convenience, we also track the type we unwrap and the + type of its field. Example: @Down 42@ => @[(Down @Int, Down, Int)] + (c) core_ty is the rewritten type. That is, + pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty) + implies + topNormaliseType_maybe env ty = Just (co, core_ty) + for some coercion co. + +To see how all cases come into play, consider the following example: + + data family T a :: * + data instance T Int = T1 | T2 Bool + -- Which gives rise to FC: + -- data T a + -- data R:TInt = T1 | T2 Bool + -- axiom ax_ti : T Int ~R R:TInt + + newtype G1 = MkG1 (T Int) + newtype G2 = MkG2 G1 + + type instance F Int = F Char + type instance F Char = G2 + +In this case pmTopNormaliseType env ty_cs (F Int) results in + + Just (G2, [(G2,MkG2,G1),(G1,MkG1,T Int)], R:TInt) + +Which means that in source Haskell: + - G2 is equivalent to F Int (in contrast, G1 isn't). + - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int). + +----- +-- Wrinkle: Local equalities +----- + +Given the following type family: + + type family F a + type instance F Int = Void + +Should the following program (from #14813) be considered exhaustive? + + f :: (i ~ Int) => F i -> a + f x = case x of {} + +You might think "of course, since `x` is obviously of type Void". But the +idType of `x` is technically F i, not Void, so if we pass F i to +inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive. +In order to avoid this pitfall, we need to normalise the type passed to +pmTopNormaliseType, using the constraint solver to solve for any local +equalities (such as i ~ Int) that may be in scope. + +Note [Coverage checking Newtype matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Newtypes have quite peculiar match semantics compared to ordinary DataCons. In a +pattern-match, they behave like a irrefutable (lazy) match, but for inhabitation +testing purposes (e.g. at construction sites), they behave rather like a DataCon +with a *strict* field, because they don't contribute their own bottom and are +inhabited iff the wrapped type is inhabited. + +This distinction becomes apparent in #17248: + + newtype T2 a = T2 a + g _ True = () + g (T2 _) True = () + g !_ True = () + +If we treat Newtypes like we treat regular DataCons, we would mark the third +clause as redundant, which clearly is unsound. The solution: +1. 'isPmAltConMatchStrict' returns False for newtypes, indicating that a + newtype match is lazy. +2. When we find @x ~ T2 y@, transfer all constraints on @x@ (which involve @⊥@) + to @y@, similar to what 'equate' does, and don't add a @x ≁ ⊥@ constraint. + This way, the third clause will still be marked as inaccessible RHS instead + of redundant. This is ensured by calling 'lookupVarInfoNT'. +3. Immediately reject when we find @x ≁ T2@. +Handling of Newtypes is also described in the Appendix of the Lower Your Guards paper, +where you can find the solution in a perhaps more digestible format. +-} + +------------------------- +-- * Adding φ constraints +-- +-- Figure 7 in the LYG paper. + +-- | A high-level pattern-match constraint. Corresponds to φ from Figure 3 of +-- the LYG paper. +data PhiCt + = PhiTyCt !PredType + -- ^ A type constraint "T ~ U". + | PhiCoreCt !Id !CoreExpr + -- ^ @PhiCoreCt x e@ encodes "x ~ e", equating @x@ with the 'CoreExpr' @e@. + | PhiConCt !Id !PmAltCon ![TyVar] ![PredType] ![Id] + -- ^ @PhiConCt x K tvs dicts ys@ encodes @K \@tvs dicts ys <- x@, matching @x@ + -- against the 'PmAltCon' application @K \@tvs dicts ys@, binding @tvs@, + -- @dicts@ and possibly unlifted fields @ys@ in the process. + -- See Note [Strict fields and variables of unlifted type]. + | PhiNotConCt !Id !PmAltCon + -- ^ @PhiNotConCt x K@ encodes "x ≁ K", asserting that @x@ can't be headed + -- by @K@. + | PhiBotCt !Id + -- ^ @PhiBotCt x@ encodes "x ~ ⊥", equating @x@ to ⊥. + -- by @K@. + | PhiNotBotCt !Id + -- ^ @PhiNotBotCt x y@ encodes "x ≁ ⊥", asserting that @x@ can't be ⊥. + +instance Outputable PhiCt where + ppr (PhiTyCt ty_ct) = ppr ty_ct + ppr (PhiCoreCt x e) = ppr x <+> char '~' <+> ppr e + ppr (PhiConCt x con tvs dicts args) = + hsep (ppr con : pp_tvs ++ pp_dicts ++ pp_args) <+> text "<-" <+> ppr x + where + pp_tvs = map ((<> char '@') . ppr) tvs + pp_dicts = map ppr dicts + pp_args = map ppr args + ppr (PhiNotConCt x con) = ppr x <+> text "≁" <+> ppr con + ppr (PhiBotCt x) = ppr x <+> text "~ ⊥" + ppr (PhiNotBotCt x) = ppr x <+> text "≁ ⊥" + +type PhiCts = Bag PhiCt + +-- | The fuel for the inhabitation test. +-- See Note [Fuel for the inhabitation test]. +initFuel :: Int +initFuel = 4 -- 4 because it's the smallest number that passes f' in T17977b + +-- | Adds new constraints to 'Nabla' and returns 'Nothing' if that leads to a +-- contradiction. +-- +-- In terms of the paper, this function models the \(⊕_φ\) function in +-- Figure 7 on batches of φ constraints. +addPhiCts :: Nabla -> PhiCts -> DsM (Maybe Nabla) +-- See Note [TmState invariants]. +addPhiCts nabla cts = runMaybeT $ do + let (ty_cts, tm_cts) = partitionPhiCts cts + nabla' <- addTyCts nabla (listToBag ty_cts) + nabla'' <- foldlM addPhiTmCt nabla' (listToBag tm_cts) + inhabitationTest initFuel (nabla_ty_st nabla) nabla'' + +partitionPhiCts :: PhiCts -> ([PredType], [PhiCt]) +partitionPhiCts = partitionWith to_either . toList + where + to_either (PhiTyCt pred_ty) = Left pred_ty + to_either ct = Right ct + +----------------------------- +-- ** Adding type constraints + +-- | Adds new type-level constraints by calling out to the type-checker via +-- 'tyOracle'. +addTyCts :: Nabla -> Bag PredType -> MaybeT DsM Nabla +addTyCts nabla@MkNabla{ nabla_ty_st = ty_st } new_ty_cs = do + ty_st' <- MaybeT (tyOracle ty_st new_ty_cs) + pure nabla{ nabla_ty_st = ty_st' } + +-- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we +-- find a contradiction (e.g. @Int ~ Bool@). +-- +-- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver. +tyOracle :: TyState -> Bag PredType -> DsM (Maybe TyState) +tyOracle ty_st@(TySt n inert) cts + | isEmptyBag cts + = pure (Just ty_st) + | otherwise + = {-# SCC "tyOracle" #-} + do { evs <- traverse nameTyCt cts + ; tracePm "tyOracle" (ppr n $$ ppr cts $$ ppr inert) + ; mb_new_inert <- initTcDsForSolver $ tcCheckGivens inert evs + -- return the new inert set and increment the sequence number n + ; return (TySt (n+1) <$> mb_new_inert) } + +-- | Allocates a fresh 'EvVar' name for 'PredTy's. +nameTyCt :: PredType -> DsM EvVar +nameTyCt pred_ty = do + unique <- getUniqueM + let occname = mkVarOccFS (fsLit ("pm_"++show unique)) + return (mkUserLocalOrCoVar occname unique ManyTy pred_ty noSrcSpan) + +----------------------------- +-- ** Adding term constraints + +-- | Adds a single higher-level φ constraint by dispatching to the various +-- oracle functions. +-- +-- In terms of the paper, this function amounts to the constructor constraint +-- case of \(⊕_φ\) in Figure 7, which "desugars" higher-level φ constraints +-- into lower-level δ constraints. We don't have a data type for δ constraints +-- and call the corresponding oracle function directly instead. +-- +-- Precondition: The φ is /not/ a type constraint! These should be handled by +-- 'addTyCts' before, through 'addPhiCts'. +addPhiTmCt :: Nabla -> PhiCt -> MaybeT DsM Nabla +addPhiTmCt _ (PhiTyCt ct) = pprPanic "addPhiCt:TyCt" (ppr ct) -- See the precondition +addPhiTmCt nabla (PhiCoreCt x e) = addCoreCt nabla x e +addPhiTmCt nabla (PhiConCt x con tvs dicts args) = do + -- Case (1) of Note [Strict fields and variables of unlifted type] + -- PhiConCt correspond to the higher-level φ constraints from the paper with + -- bindings semantics. It disperses into lower-level δ constraints that the + -- 'add*Ct' functions correspond to. + nabla' <- addTyCts nabla (listToBag dicts) + nabla'' <- addConCt nabla' x con tvs args + foldlM addNotBotCt nabla'' (filterUnliftedFields con args) +addPhiTmCt nabla (PhiNotConCt x con) = addNotConCt nabla x con +addPhiTmCt nabla (PhiBotCt x) = addBotCt nabla x +addPhiTmCt nabla (PhiNotBotCt x) = addNotBotCt nabla x + +filterUnliftedFields :: PmAltCon -> [Id] -> [Id] +filterUnliftedFields con args = + [ arg | (arg, bang) <- zipEqual args (pmAltConImplBangs con) + , isBanged bang || definitelyUnliftedType (idType arg) ] + +-- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@ +-- surely diverges. Quite similar to 'addConCt', only that it only cares about +-- ⊥. +addBotCt :: Nabla -> Id -> MaybeT DsM Nabla +addBotCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_facts=env } } x = do + let (y, vi@VI { vi_bot = bot }) = lookupVarInfoNT (nabla_tm_st nabla) x + case bot of + IsNotBot -> mzero -- There was x ≁ ⊥. Contradiction! + IsBot -> pure nabla -- There already is x ~ ⊥. Nothing left to do + MaybeBot -- We add x ~ ⊥ + | definitelyUnliftedType (idType x) + -- Case (3) in Note [Strict fields and variables of unlifted type] + -> mzero -- unlifted vars can never be ⊥ + | otherwise + -> do + let vi' = vi{ vi_bot = IsBot } + pure nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } } + +-- | Adds the constraint @x ~/ ⊥@ to 'Nabla'. Quite similar to 'addNotConCt', +-- but only cares for the ⊥ "constructor". +addNotBotCt :: Nabla -> Id -> MaybeT DsM Nabla +addNotBotCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts=env} } x = do + let (y, vi@VI { vi_bot = bot }) = lookupVarInfoNT (nabla_tm_st nabla) x + case bot of + IsBot -> mzero -- There was x ~ ⊥. Contradiction! + IsNotBot -> pure nabla -- There already is x ≁ ⊥. Nothing left to do + MaybeBot -> do -- We add x ≁ ⊥ and test if x is still inhabited + -- Mark dirty for a delayed inhabitation test + let vi' = vi{ vi_bot = IsNotBot} + pure $ markDirty y + $ nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env y vi' } } + +-- | Record a @x ~/ K@ constraint, e.g. that a particular 'Id' @x@ can't +-- take the shape of a 'PmAltCon' @K@ in the 'Nabla' and return @Nothing@ if +-- that leads to a contradiction. +-- See Note [TmState invariants]. +addNotConCt :: Nabla -> Id -> PmAltCon -> MaybeT DsM Nabla +addNotConCt _ _ (PmAltConLike (RealDataCon dc)) + | isNewDataCon dc = mzero -- (3) in Note [Coverage checking Newtype matches] +addNotConCt nabla x nalt = do + (mb_mark_dirty, nabla') <- trvVarInfo go nabla x + pure $ case mb_mark_dirty of + Just x -> markDirty x nabla' + Nothing -> nabla' + where + -- Update `x`'s 'VarInfo' entry. Fail ('MaybeT') if contradiction, + -- otherwise return updated entry and `Just x'` if `x` should be marked dirty, + -- where `x'` is the representative of `x`. + go :: VarInfo -> MaybeT DsM (Maybe Id, VarInfo) + go vi@(VI x' pos neg _ rcm) = do + -- 1. Bail out quickly when nalt contradicts a solution + let contradicts nalt sol = eqPmAltCon (paca_con sol) nalt == Equal + guard (not (any (contradicts nalt) pos)) + -- 2. Only record the new fact when it's not already implied by one of the + -- solutions + let implies nalt sol = eqPmAltCon (paca_con sol) nalt == Disjoint + let neg' + | any (implies nalt) pos = neg + -- See Note [Completeness checking with required Thetas] + | hasRequiredTheta nalt = neg + | otherwise = extendPmAltConSet neg nalt + massert (isPmAltConMatchStrict nalt) + let vi' = vi{ vi_neg = neg', vi_bot = IsNotBot } + -- 3. Make sure there's at least one other possible constructor + mb_rcm' <- lift (markMatched nalt rcm) + pure $ case mb_rcm' of + -- If nalt could be removed from a COMPLETE set, we'll get back Just and + -- have to mark x dirty, by returning Just x'. + Just rcm' -> (Just x', vi'{ vi_rcm = rcm' }) + -- Otherwise, nalt didn't occur in any residual COMPLETE set and we + -- don't have to mark it dirty. So we return Nothing, which in the case + -- above would have compromised precision. + -- See Note [Shortcutting the inhabitation test], grep for T17836. + Nothing -> (Nothing, vi') + +hasRequiredTheta :: PmAltCon -> Bool +hasRequiredTheta (PmAltConLike cl) = notNull req_theta + where + (_,_,_,_,req_theta,_,_) = conLikeFullSig cl +hasRequiredTheta _ = False + +-- | Add a @x ~ K tvs args ts@ constraint. +-- @addConCt x K tvs args ts@ extends the substitution with a solution +-- @x :-> (K, tvs, args)@ if compatible with the negative and positive info we +-- have on @x@, reject (@Nothing@) otherwise. +-- +-- See Note [TmState invariants]. +addConCt :: Nabla -> Id -> PmAltCon -> [TyVar] -> [Id] -> MaybeT DsM Nabla +addConCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_facts=env } } x alt tvs args = do + let vi@(VI _ pos neg bot _) = lookupVarInfo ts x + -- First try to refute with a negative fact + guard (not (elemPmAltConSet alt neg)) + -- Then see if any of the other solutions (remember: each of them is an + -- additional refinement of the possible values x could take) indicate a + -- contradiction + guard (all ((/= Disjoint) . eqPmAltCon alt . paca_con) pos) + -- Now we should be good! Add (alt, tvs, args) as a possible solution, or + -- refine an existing one + case find ((== Equal) . eqPmAltCon alt . paca_con) pos of + Just (PACA _con other_tvs other_args) -> do + -- We must unify existentially bound ty vars and arguments! + let ty_cts = equateTys (map mkTyVarTy tvs) (map mkTyVarTy other_tvs) + nabla' <- MaybeT $ addPhiCts nabla (listToBag ty_cts) + let add_var_ct nabla (a, b) = addVarCt nabla a b + foldlM add_var_ct nabla' $ zipEqual args other_args + Nothing -> do + let pos' = PACA alt tvs args : pos + let nabla_with bot' = + nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env x (vi{vi_pos = pos', vi_bot = bot'})} } + -- Do (2) in Note [Coverage checking Newtype matches] + case (alt, args) of + (PmAltConLike (RealDataCon dc), [y]) | isNewDataCon dc -> + case bot of + MaybeBot -> pure (nabla_with MaybeBot) + IsBot -> addBotCt (nabla_with MaybeBot) y + IsNotBot -> addNotBotCt (nabla_with MaybeBot) y + _ -> assert (isPmAltConMatchStrict alt ) + pure (nabla_with IsNotBot) -- strict match ==> not ⊥ + +equateTys :: [Type] -> [Type] -> [PhiCt] +equateTys ts us = + [ PhiTyCt (mkNomEqPred t u) + | (t, u) <- zipEqual ts us + -- The following line filters out trivial Refl constraints, so that we don't + -- need to initialise the type oracle that often + , not (eqType t u) + ] + +-- | Adds a @x ~ y@ constraint by merging the two 'VarInfo's and record the +-- gained knowledge in 'Nabla'. +-- +-- Returns @Nothing@ when there's a contradiction while merging. Returns @Just +-- nabla@ when the constraint was compatible with prior facts, in which case +-- @nabla@ has integrated the knowledge from the equality constraint. +-- +-- See Note [TmState invariants]. +addVarCt :: Nabla -> Id -> Id -> MaybeT DsM Nabla +addVarCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_facts = env } } x y = + case equateUSDFM env x y of + (Nothing, env') -> pure (nabla{ nabla_tm_st = ts{ ts_facts = env' } }) + -- Add the constraints we had for x to y + (Just vi_x, env') -> do + let nabla_equated = nabla{ nabla_tm_st = ts{ts_facts = env'} } + -- and then gradually merge every positive fact we have on x into y + let add_pos nabla (PACA cl tvs args) = addConCt nabla y cl tvs args + nabla_pos <- foldlM add_pos nabla_equated (vi_pos vi_x) + -- Do the same for negative info + let add_neg nabla nalt = addNotConCt nabla y nalt + foldlM add_neg nabla_pos (pmAltConSetElems (vi_neg vi_x)) + +-- | Inspects a 'PmCoreCt' @let x = e@ by recording constraints for @x@ based +-- on the shape of the 'CoreExpr' @e@. Examples: +-- +-- * For @let x = Just (42, 'z')@ we want to record the +-- constraints @x ~ Just a, a ~ (b, c), b ~ 42, c ~ 'z'@. +-- See 'data_con_app'. +-- * For @let x = unpackCString# "tmp"@ we want to record the literal +-- constraint @x ~ "tmp"@. +-- * For @let x = I# 42@ we want the literal constraint @x ~ 42@. Similar +-- for other literals. See 'coreExprAsPmLit'. +-- * Finally, if we have @let x = e@ and we already have seen @let y = e@, we +-- want to record @x ~ y@. +addCoreCt :: Nabla -> Id -> CoreExpr -> MaybeT DsM Nabla +addCoreCt nabla x e = do + simpl_opts <- initSimpleOpts <$> getDynFlags + let e' = simpleOptExpr simpl_opts e + -- lift $ tracePm "addCoreCt" (ppr x <+> dcolon <+> ppr (idType x) $$ ppr e $$ ppr e') + execStateT (core_expr x e') nabla + where + -- Takes apart a 'CoreExpr' and tries to extract as much information about + -- literals and constructor applications as possible. + core_expr :: Id -> CoreExpr -> StateT Nabla (MaybeT DsM) () + -- TODO: Handle newtypes properly, by wrapping the expression in a DataCon + -- This is the right thing for casts involving data family instances and + -- their representation TyCon, though (which are not visible in source + -- syntax). See Note [COMPLETE sets on data families] + -- core_expr x e | pprTrace "core_expr" (ppr x $$ ppr e) False = undefined + core_expr x (Cast e _co) = core_expr x e + core_expr x (Tick _t e) = core_expr x e + core_expr x e + | Just (pmLitAsStringLit -> Just s) <- coreExprAsPmLit e + , expr_ty `eqType` stringTy + -- See Note [Representation of Strings in TmState] + = case unpackFS s of + -- We need this special case to break a loop with coreExprAsPmLit + -- Otherwise we alternate endlessly between [] and "" + [] -> data_con_app x emptyInScopeSet nilDataCon [] + s' -> core_expr x (mkListExpr charTy (map mkCharExpr s')) + | Just lit <- coreExprAsPmLit e + = pm_lit x lit + | Just (in_scope, _empty_floats@[], dc, _arg_tys, args) + <- exprIsConApp_maybe in_scope_env e + = data_con_app x in_scope dc args + -- See Note [Detecting pattern synonym applications in expressions] + | Var y <- e, Nothing <- isDataConId_maybe x + -- We don't consider DataCons flexible variables + = modifyT (\nabla -> addVarCt nabla x y) + | otherwise + -- Any other expression. Try to find other uses of a semantically + -- equivalent expression and represent them by the same variable! + = equate_with_similar_expr x e + where + expr_ty = exprType e + expr_in_scope = mkInScopeSet (exprFreeVars e) + in_scope_env = ISE expr_in_scope noUnfoldingFun + -- It's inconvenient to get hold of a global in-scope set + -- here, but it'll only be needed if exprIsConApp_maybe ends + -- up substituting inside a forall or lambda (i.e. seldom) + -- so using exprFreeVars seems fine. See MR !1647. + + -- The @e@ in @let x = e@ had no familiar form. But we can still see if + -- see if we already encountered a constraint @let y = e'@ with @e'@ + -- semantically equivalent to @e@, in which case we may add the constraint + -- @x ~ y@. + equate_with_similar_expr :: Id -> CoreExpr -> StateT Nabla (MaybeT DsM) () + equate_with_similar_expr x e = do + rep <- StateT $ \nabla -> lift (representCoreExpr nabla e) + -- Note that @rep == x@ if we encountered @e@ for the first time. + modifyT (\nabla -> addVarCt nabla x rep) + + bind_expr :: CoreExpr -> StateT Nabla (MaybeT DsM) Id + bind_expr e = do + x <- lift (lift (mkPmId (exprType e))) + core_expr x e + pure x + + -- Look at @let x = K taus theta es@ and generate the following + -- constraints (assuming universals were dropped from @taus@ before): + -- 1. @x ≁ ⊥@ if 'K' is not a Newtype constructor. + -- 2. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@ + -- 3. @y_1 ~ e_1, ..., y_m ~ e_m@ for fresh @y_i@ + -- 4. @x ~ K as ys@ + -- This is quite similar to PmCheck.pmConCts. + data_con_app :: Id -> InScopeSet -> DataCon -> [CoreExpr] -> StateT Nabla (MaybeT DsM) () + data_con_app x in_scope dc args = do + let dc_ex_tvs = dataConExTyCoVars dc + arty = dataConSourceArity dc + (ex_ty_args, val_args) = splitAtList dc_ex_tvs args + ex_tys = map exprToType ex_ty_args + vis_args = reverse $ take arty $ reverse val_args + uniq_supply <- lift $ lift $ getUniqueSupplyM + let (_, ex_tvs) = cloneTyVarBndrs (mkEmptySubst in_scope) dc_ex_tvs uniq_supply + ty_cts = equateTys (map mkTyVarTy ex_tvs) ex_tys + -- 1. @x ≁ ⊥@ if 'K' is not a Newtype constructor (#18341) + when (not (isNewDataCon dc)) $ + modifyT $ \nabla -> addNotBotCt nabla x + -- 2. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@. See also #17703 + modifyT $ \nabla -> MaybeT $ addPhiCts nabla (listToBag ty_cts) + -- 3. @y_1 ~ e_1, ..., y_m ~ e_m@ for fresh @y_i@ + arg_ids <- traverse bind_expr vis_args + -- 4. @x ~ K as ys@ + pm_alt_con_app x (PmAltConLike (RealDataCon dc)) ex_tvs arg_ids + + -- Adds a literal constraint, i.e. @x ~ 42@. + -- Also we assume that literal expressions won't diverge, so this + -- will add a @x ~/ ⊥@ constraint. + pm_lit :: Id -> PmLit -> StateT Nabla (MaybeT DsM) () + pm_lit x lit = do + modifyT $ \nabla -> addNotBotCt nabla x + pm_alt_con_app x (PmAltLit lit) [] [] + + -- Adds the given constructor application as a solution for @x@. + pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Nabla (MaybeT DsM) () + pm_alt_con_app x con tvs args = modifyT $ \nabla -> addConCt nabla x con tvs args + +-- | Like 'modify', but with an effectful modifier action +modifyT :: Monad m => (s -> m s) -> StateT s m () +modifyT f = StateT $ fmap ((,) ()) . f + +-- | Finds a representant of the semantic equality class of the given @e@. +-- Which is the @x@ of a @let x = e'@ constraint (with @e@ semantically +-- equivalent to @e'@) we encountered earlier, or a fresh identifier if +-- there weren't any such constraints. +representCoreExpr :: Nabla -> CoreExpr -> DsM (Id, Nabla) +representCoreExpr nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_reps = reps } } e + | Just rep <- lookupCoreMap reps key = pure (rep, nabla) + | otherwise = do + rep <- mkPmId (exprType e) + let reps' = extendCoreMap reps key rep + let nabla' = nabla{ nabla_tm_st = ts{ ts_reps = reps' } } + pure (rep, nabla') + where + key = makeDictsCoherent e + -- Use a key in which dictionaries for the same type become equal. + -- See Note [Unique dictionaries in the TmOracle CoreMap] + +-- | Change out 'Id's which are uniquely determined by their type to a +-- common value, so that different names for dictionaries of the same type +-- are considered equal when building a 'CoreMap'. +-- +-- See Note [Unique dictionaries in the TmOracle CoreMap] +makeDictsCoherent :: CoreExpr -> CoreExpr +makeDictsCoherent var@(Var v) + | let ty = idType v + , typeDeterminesValue ty + = mkImpossibleExpr ty "Solver.makeDictsCoherent" + | otherwise + = var +makeDictsCoherent lit@(Lit {}) + = lit +makeDictsCoherent (App f a) + = App (makeDictsCoherent f) (makeDictsCoherent a) +makeDictsCoherent (Lam f body) + = Lam f (makeDictsCoherent body) +makeDictsCoherent (Let bndr body) + = Let + (go_bndr bndr) + (makeDictsCoherent body) + where + go_bndr (NonRec bndr expr) = NonRec bndr (makeDictsCoherent expr) + go_bndr (Rec bndrs) = Rec (map ( \(b, expr) -> (b, makeDictsCoherent expr) ) bndrs) +makeDictsCoherent (Case scrut bndr ty alts) + = Case scrut bndr ty + [ Alt con bndr expr' + | Alt con bndr expr <- alts + , let expr' = makeDictsCoherent expr ] +makeDictsCoherent (Cast expr co) + = Cast (makeDictsCoherent expr) co +makeDictsCoherent (Tick tick expr) + = Tick tick (makeDictsCoherent expr) +makeDictsCoherent ty@(Type {}) + = ty +makeDictsCoherent co@(Coercion {}) + = co + +{- Note [Unique dictionaries in the TmOracle CoreMap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Any two dictionaries for a coherent typeclass should be considered equal +in the TmOracle CoreMap, as this allows us to report better pattern-match +warnings. + +Consider for example T21662: + + view_fn :: forall (n :: Nat). KnownNat n => Int -> Bool + + foo :: Int -> Int + foo (view_fn @12 -> True ) = 0 + foo (view_fn @12 -> False) = 1 + +In this example, the pattern match is exhaustive because we have covered +the range of the view pattern function. However, we may fail to recognise +the fact that the two cases use the same view function if the KnownNat +dictionaries aren't syntactically equal: + + eqn 1: [let ds_d1p0 = view_fn @12 $dKnownNat_a1ny ds_d1oR, True <- ds_d1p0] + eqn 2: [let ds_d1p6 = view_fn @12 $dKnownNat_a1nC ds_d1oR, False <- ds_d1p6] + +Note that the uniques of the KnownNat 12 dictionary differ. If we fail to utilise +the coherence of the KnownNat constraint, then we have to pessimistically assume +that we have two function calls with different arguments: + + foo (fn arg1 -> True ) = ... + foo (fn arg2 -> False) = ... + +In this case we can't determine whether the pattern matches are complete, so we +emit a pattern match warning. + +Solution: replace all 'Id's whose type uniquely determines its value with +a common value, e.g. in the above example we would replace both +$dKnownNat_a1ny and $dKnownNat_a1nC with error @(KnownNat 12). + +Why did we choose this solution? Here are some alternatives that were considered: + + 1. Perform CSE first. This would common up the dictionaries before we compare + using the CoreMap. + However, this is architecturally difficult as it would require threading + a CSEnv through to desugarPat. + 2. Directly modify CoreMap so that any two dictionaries of the same type are + considered equal. + The problem is that this affects all users of CoreMap. For example, CSE + would now assume that any two dictionaries of the same type are equal, + but this isn't necessarily true in the presence of magicDict, which + violates coherence by design. It seems more prudent to limit the changes + to the pattern-match checker only, to avoid undesirable consequences. + +In the end, replacing dictionaries with an error value in the pattern-match +checker was the most self-contained, although we might want to revisit once +we implement a more robust approach to computing equality in the pattern-match +checker (see #19272). +-} + +{- Note [The Pos/Neg invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant applying to each VarInfo: Whenever we have @C @tvs args@ in 'vi_pos', +any entry in 'vi_neg' must be incomparable to C (return Nothing) according to +'eqPmAltCons'. Those entries that are comparable either lead to a refutation +or are redundant. Examples: +* @x ~ Just y@, @x ≁ [Just]@. 'eqPmAltCon' returns @Equal@, so refute. +* @x ~ Nothing@, @x ≁ [Just]@. 'eqPmAltCon' returns @Disjoint@, so negative + info is redundant and should be discarded. +* @x ~ I# y@, @x ≁ [4,2]@. 'eqPmAltCon' returns @PossiblyOverlap@, so orthogonal. + We keep this info in order to be able to refute a redundant match on i.e. 4 + later on. + +This carries over to pattern synonyms and overloaded literals. Say, we have + pattern Just42 = Just 42 + case Just42 of x + Nothing -> () + Just _ -> () +Even though we had a solution for the value abstraction called x here in form +of a PatSynCon Just42, this solution is incomparable to both Nothing and +Just. Hence we retain the info in vi_neg, which eventually allows us to detect +the complete pattern match. + +The Pos/Neg invariant extends to vi_rcm, which essentially stores positive +information. We make sure that vi_neg and vi_rcm never overlap. This isn't +strictly necessary since vi_rcm is just a cache, so doesn't need to be +accurate: Every suggestion of a possible ConLike from vi_rcm might be +refutable by the type oracle anyway. But it helps to maintain sanity while +debugging traces. + +Note [Why record both positive and negative info?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that knowing positive info (like x ~ Just y) would render +negative info irrelevant, but not so because of pattern synonyms. E.g we might +know that x cannot match (Foo 4), where pattern Foo p = Just p + +Also overloaded literals themselves behave like pattern synonyms. E.g if +postively we know that (x ~ I# y), we might also negatively want to record that +x does not match 45 f 45 = e2 f (I# 22#) = e3 f 45 = e4 -- +Overlapped + +Note [TmState invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The term oracle state is never obviously (i.e., without consulting the type +oracle or doing inhabitation testing) contradictory. This implies a few +invariants: +* Whenever vi_pos overlaps with vi_neg according to 'eqPmAltCon', we refute. + This is implied by the Note [The Pos/Neg invariant]. +* Whenever vi_neg subsumes a COMPLETE set, we refute. We consult vi_rcm to + detect this, but we could just compare whole COMPLETE sets to vi_neg every + time, if it weren't for performance. + +Maintaining these invariants in 'addVarCt' (the core of the term oracle) and +'addNotConCt' is subtle. +* Merging VarInfos. Example: Add the fact @x ~ y@ (see 'equate'). + - (COMPLETE) If we had @x ≁ True@ and @y ≁ False@, then we get + @x ≁ [True,False]@. This is vacuous by matter of comparing to the built-in + COMPLETE set, so should refute. + - (Pos/Neg) If we had @x ≁ True@ and @y ~ True@, we have to refute. +* Adding positive information. Example: Add the fact @x ~ K ys@ (see 'addConCt') + - (Neg) If we had @x ≁ K@, refute. + - (Pos) If we had @x ~ K2@, and that contradicts the new solution according to + 'eqPmAltCon' (ex. K2 is [] and K is (:)), then refute. + - (Refine) If we had @x ≁ K zs@, unify each y with each z in turn. +* Adding negative information. Example: Add the fact @x ≁ Nothing@ (see 'addNotConCt') + - (Refut) If we have @x ~ K ys@, refute. + - (COMPLETE) If K=Nothing and we had @x ≁ Just@, then we get + @x ≁ [Just,Nothing]@. This is vacuous by matter of comparing to the built-in + COMPLETE set, so should refute. + +Note that merging VarInfo in equate can be done by calling out to 'addConCt' and +'addNotConCt' for each of the facts individually. + +Note [Representation of Strings in TmState] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of treating regular String literals as a PmLits, we treat it as a list +of characters in the oracle for better overlap reasoning. The following example +shows why: + + f :: String -> () + f ('f':_) = () + f "foo" = () + f _ = () + +The second case is redundant, and we like to warn about it. Therefore either +the oracle will have to do some smart conversion between the list and literal +representation or treat is as the list it really is at runtime. + +The "smart conversion" has the advantage of leveraging the more compact literal +representation wherever possible, but is really nasty to get right with negative +equalities: Just think of how to encode @x /= "foo"@. +The "list" option is far simpler, but incurs some overhead in representation and +warning messages (which can be alleviated by someone with enough dedication). + +Note [Detecting pattern synonym applications in expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment we fail to detect pattern synonyms in scrutinees and RHS of +guards. This could be alleviated with considerable effort and complexity, but +the returns are meager. Consider: + + pattern P + pattern Q + case P 15 of + Q _ -> ... + P 15 -> + +Compared to the situation where P and Q are DataCons, the lack of generativity +means we could never flag Q as redundant. (also see Note [Undecidable Equality +for PmAltCons] in PmTypes.) On the other hand, if we fail to recognise the +pattern synonym, we flag the pattern match as inexhaustive. That wouldn't happen +if we had knowledge about the scrutinee, in which case the oracle basically +knows "If it's a P, then its field is 15". + +This is a pretty narrow use case and I don't think we should to try to fix it +until a user complains energetically. + +Note [Completeness checking with required Thetas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the situation in #11224 + + import Text.Read (readMaybe) + pattern PRead :: Read a => () => a -> String + pattern PRead x <- (readMaybe -> Just x) + f :: String -> Int + f (PRead x) = x + f (PRead xs) = length xs + f _ = 0 + +Is the first match exhaustive on the PRead synonym? Should the second line thus +deemed redundant? The answer is, of course, No! The required theta is like a +hidden parameter which must be supplied at the pattern match site, so PRead +is much more like a view pattern (where behavior depends on the particular value +passed in). +The simple solution here is to forget in 'addNotConCt' that we matched +on synonyms with a required Theta like @PRead@, so that subsequent matches on +the same constructor are never flagged as redundant. The consequence is that +we no longer detect the actually redundant match in + + g :: String -> Int + g (PRead x) = x + g (PRead y) = y -- redundant! + g _ = 0 + +But that's a small price to pay, compared to the proper solution here involving +storing required arguments along with the PmAltConLike in 'vi_neg'. + +Note [Strict fields and variables of unlifted type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Binders of unlifted type (and strict fields) are unlifted by construction; +they are conceived with an implicit (but delayed checked) @≁⊥@ constraint to +begin with. Hence, desugaring in "GHC.HsToCore.Pmc" is entirely unconcerned +by strict fields, since the forcing happens *before* pattern matching. And +the φ constructor constraints emitted by 'GHC.HsToCore.Pmc.checkGrd' have +complex binding semantics (binding type constraints and unlifted fields), so +unliftedness semantics are entirely confined to the oracle. + +These are the moving parts: + + 1. For each strict (or more generally, unlifted) field @s@ of a 'PhiConCt' + we have to add a @s ≁ ⊥@ constraint in the corresponding case of + 'addPhiTmCt'. Strict fields are devoid of ⊥ by construction, there's + nothing that a bang pattern would act on. Example from #18341: + + data T = MkT !Int + f :: T -> () + f (MkT _) | False = () -- inaccessible + f (MkT !_) | False = () -- redundant, not only inaccessible! + f _ = () + + The second clause desugars to @MkT n <- x, !n@. When coverage checked, + the 'PmCon' @MkT n <- x@ refines the set of values that reach the bang + pattern with the φ constraints @MkT n <- x@ (Nothing surprising so far). + Upon that constraint, it disperses into two lower-level δ constraints + @x ~ MkT n, n ≁ ⊥@ per Equation (3) in Figure 7 of the paper. + + Checking the 'PmBang' @!n@ will then try to add the + constraint @n ~ ⊥@ to this set to get the diverging set, which is found + to be empty. Hence the whole clause is detected as redundant, as + expected. + + 2. Similarly, when performing the 'inhabitationTest', when instantiating a + constructor we call 'instCon', which generates a higher-level φ + constructor constraint. + + 3. The preceding points handle unlifted constructor fields, but there also + are regular binders of unlifted type. We simply fail in 'addBotCt' for + any binder of unlifted type. + It would be enough to check for unliftedness once, when the binder comes + into scope, but we haven't really a way to track that. + + 4. Why not start an 'emptyVarInfo' of unlifted type with @vi_bot = IsNotBot@? + Because then we'd need to trigger an inhabitation test, because the var + might actually be void to begin with. But we can't trigger the test from + 'emptyVarInfo'. + Historically, that is what we did and not doing the test led to #20631, + where 'addNotBotCt' trivially succeeded, because the 'VarInfo' already + said 'IsNotBot', implying that a prior inhabitation test succeeded. +-} + +------------------------- +-- * Inhabitation testing +-- +-- Figure 8 in the LYG paper. + +tyStateRefined :: TyState -> TyState -> Bool +-- Makes use of the fact that the two TyStates we compare will never have the +-- same sequence number. It is invalid to call this function when a is not a +-- refinement of b or vice versa! +tyStateRefined a b = ty_st_n a /= ty_st_n b + +markDirty :: Id -> Nabla -> Nabla +markDirty x nabla@MkNabla{nabla_tm_st = ts@TmSt{ts_dirty = dirty} } = + nabla{ nabla_tm_st = ts{ ts_dirty = extendDVarSet dirty x } } + +traverseDirty :: Monad m => (VarInfo -> m VarInfo) -> TmState -> m TmState +traverseDirty f ts@TmSt{ts_facts = env, ts_dirty = dirty} = + go (uniqDSetToList dirty) env + where + go [] env = pure ts{ts_facts=env} + go (x:xs) !env = do + vi' <- f (lookupVarInfo ts x) + go xs (addToUSDFM env x vi') + +traverseAll :: Monad m => (VarInfo -> m VarInfo) -> TmState -> m TmState +traverseAll f ts@TmSt{ts_facts = env} = do + env' <- traverseUSDFM f env + pure ts{ts_facts = env'} + +-- | Makes sure the given 'Nabla' is still inhabited, by trying to instantiate +-- all dirty variables (or all variables when the 'TyState' changed) to concrete +-- inhabitants. It returns a 'Nabla' with the *same* inhabitants, but with some +-- amount of work cached (like failed instantiation attempts) from the test. +-- +-- The \(∇ ⊢ x inh\) judgment form in Figure 8 of the LYG paper. +inhabitationTest :: Int -> TyState -> Nabla -> MaybeT DsM Nabla +inhabitationTest 0 _ nabla = pure nabla +inhabitationTest fuel old_ty_st nabla@MkNabla{ nabla_tm_st = ts } = {-# SCC "inhabitationTest" #-} do + -- lift $ tracePm "inhabitation test" $ vcat + -- [ ppr fuel + -- , ppr old_ty_st + -- , ppr nabla + -- , text "tyStateRefined:" <+> ppr (tyStateRefined old_ty_st (nabla_ty_st nabla)) + -- ] + -- When type state didn't change, we only need to traverse dirty VarInfos + ts' <- if tyStateRefined old_ty_st (nabla_ty_st nabla) + then traverseAll test_one ts + else traverseDirty test_one ts + pure nabla{ nabla_tm_st = ts'{ts_dirty=emptyDVarSet}} + where + nabla_not_dirty = nabla{ nabla_tm_st = ts{ts_dirty=emptyDVarSet} } + test_one :: VarInfo -> MaybeT DsM VarInfo + test_one vi = + lift (varNeedsTesting old_ty_st nabla vi) >>= \case + True -> do + -- lift $ tracePm "test_one" (ppr vi) + -- No solution yet and needs testing + -- We have to test with a Nabla where all dirty bits are cleared + instantiate (fuel-1) nabla_not_dirty vi + _ -> pure vi + +-- | Checks whether the given 'VarInfo' needs to be tested for inhabitants. +-- Returns `False` when we can skip the inhabitation test, presuming it would +-- say "yes" anyway. See Note [Shortcutting the inhabitation test]. +varNeedsTesting :: TyState -> Nabla -> VarInfo -> DsM Bool +varNeedsTesting _ MkNabla{nabla_tm_st=tm_st} vi + | elemDVarSet (vi_id vi) (ts_dirty tm_st) = pure True +varNeedsTesting _ _ vi + | notNull (vi_pos vi) = pure False +varNeedsTesting old_ty_st MkNabla{nabla_ty_st=new_ty_st} _ + -- Same type state => still inhabited + | not (tyStateRefined old_ty_st new_ty_st) = pure False +varNeedsTesting old_ty_st MkNabla{nabla_ty_st=new_ty_st} vi = do + -- These normalisations are relatively expensive, but still better than having + -- to perform a full inhabitation test + (_, _, old_norm_ty) <- tntrGuts <$> pmTopNormaliseType old_ty_st (idType $ vi_id vi) + (_, _, new_norm_ty) <- tntrGuts <$> pmTopNormaliseType new_ty_st (idType $ vi_id vi) + if old_norm_ty `eqType` new_norm_ty + then pure False + else pure True + +-- | Returns (Just vi) if at least one member of each ConLike in the COMPLETE +-- set satisfies the oracle +-- +-- Internally uses and updates the CompleteMatchs in vi_rcm. +-- +-- NB: Does /not/ filter each CompleteMatch with the oracle; members may +-- remain that do not satisfy it. This lazy approach just +-- avoids doing unnecessary work. +instantiate :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo +instantiate fuel nabla vi = {-# SCC "instantiate" #-} + (instBot fuel nabla vi <|> instCompleteSets fuel nabla vi) + +-- | The \(⊢_{Bot}\) rule from the paper +instBot :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo +instBot _fuel nabla vi = {-# SCC "instBot" #-} do + _nabla' <- addBotCt nabla (vi_id vi) + pure vi + +addNormalisedTypeMatches :: Nabla -> Id -> DsM (ResidualCompleteMatches, Nabla) +addNormalisedTypeMatches nabla@MkNabla{ nabla_ty_st = ty_st } x + = trvVarInfo add_matches nabla x + where + add_matches vi@VI{ vi_rcm = rcm } + -- important common case, shaving down allocations of PmSeriesG by -5% + | isRcmInitialised rcm = pure (rcm, vi) + add_matches vi@VI{ vi_rcm = rcm } = do + norm_res_ty <- normaliseSourceTypeWHNF ty_st (idType x) + env <- dsGetFamInstEnvs + rcm' <- case splitReprTyConApp_maybe env norm_res_ty of + Just (rep_tc, _args, _co) -> addTyConMatches rep_tc rcm + Nothing -> addCompleteMatches rcm + pure (rcm', vi{ vi_rcm = rcm' }) + +-- | Does a 'splitTyConApp_maybe' and then tries to look through a data family +-- application to find the representation TyCon, to which the data constructors +-- are attached. Returns the representation TyCon, the TyCon application args +-- and a representational coercion that will be Refl for non-data family apps. +splitReprTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion) +splitReprTyConApp_maybe env ty = + uncurry (tcLookupDataFamInst env) <$> splitTyConApp_maybe ty + +-- | This is the |-Inst rule from the paper (section 4.5). Tries to +-- find an inhabitant in every complete set by instantiating with one their +-- constructors. If there is any complete set where we can't find an +-- inhabitant, the whole thing is uninhabited. It returns the updated 'VarInfo' +-- where all the attempted ConLike instantiations have been purged from the +-- 'ResidualCompleteMatches', which functions as a cache. +instCompleteSets :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo +instCompleteSets fuel nabla vi = {-# SCC "instCompleteSets" #-} do + let x = vi_id vi + (rcm, nabla) <- lift (addNormalisedTypeMatches nabla x) + nabla <- foldM (\nabla cls -> instCompleteSet fuel nabla x cls) nabla (getRcm rcm) + pure (lookupVarInfo (nabla_tm_st nabla) x) + +anyConLikeSolution :: (ConLike -> Bool) -> [PmAltConApp] -> Bool +anyConLikeSolution p = any (go . paca_con) + where + go (PmAltConLike cl) = p cl + go _ = False + +-- | @instCompleteSet fuel nabla x cls@ iterates over @cls@ until it finds +-- the first inhabited ConLike (as per 'instCon'). Any failed instantiation +-- attempts of a ConLike are recorded as negative information in the returned +-- 'Nabla', so that later calls to this function can skip repeatedly fruitless +-- instantiation of that same constructor. +-- +-- Note that the returned Nabla is just a different representation of the +-- original Nabla, not a proper refinement! No positive information will be +-- added, only negative information from failed instantiation attempts, +-- entirely as an optimisation. +instCompleteSet :: Int -> Nabla -> Id -> DsCompleteMatch -> MaybeT DsM Nabla +instCompleteSet fuel nabla x cs + | anyConLikeSolution (`elementOfUniqDSet` (cmConLikes cs)) (vi_pos vi) + -- No need to instantiate a constructor of this COMPLETE set if we already + -- have a solution! + = pure nabla + | not (completeMatchAppliesAtType (varType x) cs) + = pure nabla + | otherwise + = {-# SCC "instCompleteSet" #-} go nabla (sorted_candidates cs) + where + vi = lookupVarInfo (nabla_tm_st nabla) x + + sorted_candidates :: DsCompleteMatch -> [ConLike] + sorted_candidates cm + -- If there aren't many candidates, we can try to sort them by number of + -- strict fields, type constraints, etc., so that we are fast in the + -- common case + -- (either many simple constructors *or* few "complicated" ones). + | sizeUniqDSet cs <= 5 = sortBy compareConLikeTestability (uniqDSetToList cs) + | otherwise = uniqDSetToList cs + where cs = cmConLikes cm + + go :: Nabla -> [ConLike] -> MaybeT DsM Nabla + go _ [] = mzero + go nabla (RealDataCon dc:_) + -- See Note [DataCons that are definitely inhabitable] + -- Recall that dc can't be in vi_neg, because then it would be + -- deleted from the residual COMPLETE set. + | isDataConTriviallyInhabited dc + = pure nabla + go nabla (con:cons) = do + let x = vi_id vi + let recur_not_con = do + nabla' <- addNotConCt nabla x (PmAltConLike con) + go nabla' cons + (nabla <$ instCon fuel nabla x con) -- return the original nabla, not the + -- refined one! + <|> recur_not_con -- Assume that x can't be con. Encode that fact + -- with addNotConCt and recur. + +-- | Is this 'DataCon' trivially inhabited, that is, without needing to perform +-- any inhabitation testing because of strict/unlifted fields or type +-- equalities? See Note [DataCons that are definitely inhabitable] +isDataConTriviallyInhabited :: DataCon -> Bool +isDataConTriviallyInhabited dc + | isTyConTriviallyInhabited (dataConTyCon dc) = True +isDataConTriviallyInhabited dc = + null (dataConTheta dc) && -- (1) + null (dataConImplBangs dc) && -- (2) + null (dataConMightBeUnliftedFieldTys dc) -- (3) + +dataConMightBeUnliftedFieldTys :: DataCon -> [Type] +dataConMightBeUnliftedFieldTys = + filter mightBeUnliftedType . map scaledThing . dataConOrigArgTys + +isTyConTriviallyInhabited :: TyCon -> Bool +isTyConTriviallyInhabited tc = memberUniqueSet (getUnique tc) triviallyInhabitedTyConKeys + +-- | All these types are trivially inhabited +triviallyInhabitedTyConKeys :: UniqueSet +triviallyInhabitedTyConKeys = fromListUniqueSet [ + charTyConKey, doubleTyConKey, floatTyConKey, + intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey, + intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey, + wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey, + wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, + trTyConTyConKey + ] + +compareConLikeTestability :: ConLike -> ConLike -> Ordering +-- We should instantiate DataCons first, because they are likely to occur in +-- multiple COMPLETE sets at once and we might find that multiple COMPLETE sets +-- are inhabited by instantiating only a single DataCon. +compareConLikeTestability PatSynCon{} _ = GT +compareConLikeTestability _ PatSynCon{} = GT +compareConLikeTestability (RealDataCon a) (RealDataCon b) = mconcat + -- Thetas are most expensive to check, as they might incur a whole new round + -- of inhabitation testing + [ comparing (fast_length . dataConTheta) + -- Unlifted or strict fields only incur an inhabitation test for that + -- particular field. Still something to avoid. + , comparing unlifted_or_strict_fields + ] a b + where + fast_length :: [a] -> Int + fast_length xs = atLength length 6 xs 5 -- @min 6 (length xs)@, but O(1) + + -- An upper bound on the number of strict or unlifted fields. Approximate in + -- the unlikely bogus case of an unlifted field that has a bang. + unlifted_or_strict_fields :: DataCon -> Int + unlifted_or_strict_fields dc = fast_length (dataConImplBangs dc) + + fast_length (dataConMightBeUnliftedFieldTys dc) + +-- | @instCon fuel nabla (x::match_ty) K@ tries to instantiate @x@ to @K@ by +-- adding the proper constructor constraint. +-- +-- See Note [Instantiating a ConLike]. +instCon :: Int -> Nabla -> Id -> ConLike -> MaybeT DsM Nabla +instCon fuel nabla@MkNabla{nabla_ty_st = ty_st} x con = {-# SCC "instCon" #-} MaybeT $ do + let hdr what = "instCon " ++ show fuel ++ " " ++ what + env <- dsGetFamInstEnvs + let match_ty = idType x + tracePm (hdr "{") $ + ppr con <+> text "... <-" <+> ppr x <+> dcolon <+> ppr match_ty + norm_match_ty <- normaliseSourceTypeWHNF ty_st match_ty + mb_sigma_univ <- matchConLikeResTy env ty_st norm_match_ty con + case mb_sigma_univ of + Just sigma_univ -> do + let (_univ_tvs, ex_tvs, eq_spec, thetas, _req_theta, field_tys, _con_res_ty) + = conLikeFullSig con + -- Following Note [Instantiating a ConLike]: + -- (1) _req_theta has been tested in 'matchConLikeResTy' + -- (2) Instantiate fresh existentials + (sigma_ex, _) <- cloneTyVarBndrs sigma_univ ex_tvs <$> getUniqueSupplyM + -- (3) Substitute provided constraints bound by the constructor. + -- These are added to the type oracle as new facts (in a moment) + let gammas = substTheta sigma_ex (eqSpecPreds eq_spec ++ thetas) + -- (4) Instantiate fresh term variables as arguments to the constructor + let field_tys' = substTys sigma_ex $ map scaledThing field_tys + arg_ids <- mapM mkPmId field_tys' + tracePm (hdr "(cts)") $ vcat + [ ppr x <+> dcolon <+> ppr match_ty + , text "In WHNF:" <+> ppr (isSourceTypeInWHNF match_ty) <+> ppr norm_match_ty + , ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty + , ppr (map (\tv -> ppr tv <+> char '↦' <+> ppr (substTyVar sigma_univ tv)) _univ_tvs) + , ppr gammas + , ppr (map (\x -> ppr x <+> dcolon <+> ppr (idType x)) arg_ids) + ] + -- (5) Finally add the new constructor constraint + runMaybeT $ do + -- Case (2) of Note [Strict fields and variables of unlifted type] + let alt = PmAltConLike con + let branching_factor = length $ filterUnliftedFields alt arg_ids + let ct = PhiConCt x alt ex_tvs gammas arg_ids + nabla1 <- traceWhenFailPm (hdr "(ct unsatisfiable) }") (ppr ct) $ + addPhiTmCt nabla ct + -- See Note [Fuel for the inhabitation test] + let new_fuel + | branching_factor <= 1 = fuel + | otherwise = min fuel 2 + lift $ tracePm (hdr "(ct satisfiable)") $ vcat + [ ppr ct + , ppr x <+> dcolon <+> ppr match_ty + , text "In WHNF:" <+> ppr (isSourceTypeInWHNF match_ty) <+> ppr norm_match_ty + , ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty + , ppr (map (\tv -> ppr tv <+> char '↦' <+> ppr (substTyVar sigma_univ tv)) _univ_tvs) + , ppr gammas + , ppr (map (\x -> ppr x <+> dcolon <+> ppr (idType x)) arg_ids) + , ppr branching_factor + , ppr new_fuel + ] + nabla2 <- traceWhenFailPm (hdr "(inh test failed) }") (ppr nabla1) $ + inhabitationTest new_fuel (nabla_ty_st nabla) nabla1 + lift $ tracePm (hdr "(inh test succeeded) }") (ppr nabla2) + pure nabla2 + Nothing -> do + tracePm (hdr "(match_ty not instance of res_ty) }") empty + pure (Just nabla) -- Matching against match_ty failed. Inhabited! + -- See Note [Instantiating a ConLike]. + +-- | @matchConLikeResTy _ _ ty K@ tries to match @ty@ against the result +-- type of @K@, @res_ty@. It returns a substitution @s@ for @K@'s universal +-- tyvars such that @s(res_ty)@ equals @ty@ if successful. +-- +-- Make sure that @ty@ is normalised before. +-- +-- See Note [Matching against a ConLike result type]. +matchConLikeResTy :: FamInstEnvs -> TyState -> Type -> ConLike -> DsM (Maybe Subst) +matchConLikeResTy env _ ty (RealDataCon dc) = pure $ do + (rep_tc, tc_args, _co) <- splitReprTyConApp_maybe env ty + if rep_tc == dataConTyCon dc + then Just (zipTCvSubst (dataConUnivTyVars dc) tc_args) + else Nothing +matchConLikeResTy _ (TySt _ inert) ty (PatSynCon ps) = {-# SCC "matchConLikeResTy" #-} runMaybeT $ do + let (univ_tvs,req_theta,_,_,_,con_res_ty) = patSynSig ps + subst <- MaybeT $ pure $ tcMatchTy con_res_ty ty + guard $ all (`elemSubst` subst) univ_tvs -- See the Note about T11336b + if null req_theta + then pure subst + else do + let req_theta' = substTys subst req_theta + satisfiable <- lift $ initTcDsForSolver $ tcCheckWanteds inert req_theta' + if satisfiable + then pure subst + else mzero + +{- Note [Soundness and Completeness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Soundness and completeness of the pattern-match checker depend entirely on the +soundness and completeness of the inhabitation test. + +Achieving both soundness and completeness at the same time is undecidable. +See also T17977 and Note [Fuel for the inhabitation test]. +Losing soundness would make the algorithm pointless; hence we give up on +completeness, but try to get as close as possible (how close is called +the 'precision' of the algorithm). + +Soundness means that you + 1. Can remove clauses flagged as redundant without changing program semantics + (no false positives). + 2. Can be sure that your program is free of incomplete pattern matches + when the checker doesn't flag any inexhaustive definitions + (no false negatives). + +A complete algorithm would mean that + 1. When a clause can be deleted without changing program semantics, it will + be flagged as redundant (no false negatives). + 2. A program that is free of incomplete pattern matches will never have a + definition be flagged as inexhaustive (no false positives). + +Via the LYG algorithm, we reduce both these properties to a property on +the inhabitation test of refinement types: + *Soundness*: If the inhabitation test says "no" for a given refinement type + Nabla, then it provably has no inhabitant. + *Completeness*: If the inhabitation test says "yes" for a given refinement type + Nabla, then it provably has an inhabitant. +Our test is sound, but incomplete, so there are instances where we say +"yes" but in fact the Nabla is empty. Which entails false positive exhaustivity +and false negative redundancy warnings, as above. + +In summary, we have the following correspondence: + +Property | Exhaustiveness warnings | Redundancy warnings | Inhabitation test | +-------------|-------------------------|---------------------|-------------------| +Soundness | No false negatives | No false positives | Only says "no" | + | | | if there is no | + | | | inhabitant | +Completeness | No false positives | No false negatives | Only says "yes" | + | | | if there is an | + | | | inhabitant | + +Note [Shortcutting the inhabitation test] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally, we have to re-test a refinement type for inhabitants whenever we +add a new constraint. Often, we can say "no" early, upon trying to add a +contradicting constraint, see Note [The Pos/Neg invariant]. Still, COMPLETE +sets and type evidence are best handled in a delayed fashion, because of +the recursive nature of the test and our fuel-based approach. +But even then there are some cases in which we can skip the full test, +because we are sure that the refinement type is still inhabited. These +conditions are monitored by 'varNeedsTesting'. It returns + +- `True` whenever a full inhabitation test is needed +- `False` whenever the test can be skipped, amounting to an inhabitation test + that says "yes". + +According to Note [Soundness and Completeness], this test will never compromise +soundness: The `True` case just forwards to the actual inhabitation test and the +`False` case amounts to an inhabitation test that is trivially sound, because it +never says "no". + +Of course, if the returns says `False`, Completeness (and thus Precision) of the +algorithm is affected, but we get to skip costly inhabitation tests. We try to +trade as little Precision as possible against as much Performance as possible. +Here are the tests, in order: + + 1. If a variable is dirty (because of a newly added negative term constraint), + we have to test. + 2. If a variable has positive information, we don't have to test: The + positive information acts as constructive proof for inhabitation. + 3. If the type state didn't change, there is no need to test. + 4. If the variable's normalised type didn't change, there is no need to test. + 5. Otherwise, we have to test. + +Why (1) before (2)? +------------------- +Consider the reverse for (T18960): + pattern P x = x + {-# COMPLETE P :: () #-} + foo = case () of x@(P _) -> () +This should be exhaustive. But if we say "We know `x` has solution `()`, so it's +inhabited", then we'll get a warning saying that `()` wasn't matched. +But the match on `P` added the new negative information to the uncovered set, +in the process of which we marked `x` as dirty. By giving the dirty flag a +higher priority than positive info, we get to test again and see that `x` is +uninhabited and the match is exhaustive. + +But suppose that `P` wasn't mentioned in any COMPLETE set. Then we simply +don't mark `x` as dirty and will emit a warning again (which we would anyway), +without running a superfluous inhabitation test. That speeds up T17836 +considerably. + +Why (2) before (3) and (4)? +--------------------------- +Simply because (2) is more efficient to test than (3) (not by a lot), which +is more efficient to test than (4), which is still more efficient than running +the full inhabitation test (5). + +Note [Fuel for the inhabitation test] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Whether or not a type is inhabited is undecidable in general, see also +Note [Soundness and Completeness]. As a result, we can run into infinite +loops in `inhabitationTest`. Therefore, we adopt a fuel-based approach to +prevent that. + +Consider the following example: + + data Abyss = MkAbyss !Abyss + stareIntoTheAbyss :: Abyss -> a + stareIntoTheAbyss x = case x of {} + +In principle, stareIntoTheAbyss is exhaustive, since there is no way to +construct a terminating value using MkAbyss. But this can't be proven by mere +instantiation and requires an inductive argument, which `inhabitationTest` +currently isn't equipped to do. + +In order to prevent endless instantiation attempts in @inhabitationTest@, we +use the fuel as an upper bound on such attempts. + +The same problem occurs with recursive newtypes, like in the following code: + + newtype Chasm = MkChasm Chasm + gazeIntoTheChasm :: Chasm -> a + gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive + +So this limitation is somewhat understandable. + +Note that even with this recursion detection, there is still a possibility that +`inhabitationTest` can run in exponential time in the amount of fuel. Consider +the following data type: + + data T = MkT !T !T !T + +If we try to instantiate each of its fields, that will require us to once again +check if `MkT` is inhabitable in each of those three fields, which in turn will +require us to check if `MkT` is inhabitable again... As you can see, the +branching factor adds up quickly, and if the initial fuel is, say, +100, then the inhabitation test will effectively take forever. + +To mitigate this, we check the branching factor every time we are about to do +inhabitation testing in 'instCon'. If the branching factor exceeds 1 +(i.e., if there is potential for exponential runtime), then we limit the +maximum recursion depth to 1 to mitigate the problem. If the branching factor +is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay +to stick with a larger maximum recursion depth. + +In #17977 we saw that the defaultRecTcMaxBound (100 at the time of writing) was +too large and had detrimental effect on performance of the coverage checker. +Given that we only commit to a best effort anyway, we decided to substantially +decrement the fuel to 4, at the cost of precision in some edge cases +like + + data Nat = Z | S Nat + data Down :: Nat -> Type where + Down :: !(Down n) -> Down (S n) + f :: Down (S (S (S (S (S Z))))) -> () + f x = case x of {} + +Since the coverage won't bother to instantiate Down 4 levels deep to see that it +is in fact uninhabited, it will emit a inexhaustivity warning for the case. + +Note [DataCons that are definitely inhabitable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Another microoptimization applies to data types like this one: + + data S a = S ![a] !T + +Even though there is a strict field of type [a], it's quite silly to call +'instCon' on it, since it's "obvious" that it is inhabitable. To make this +intuition formal, we say that a DataCon C is definitely inhabitable (DI) if: + + 1. C has no equality constraints (since they might be unsatisfiable) + 2. C has no strict arguments (since they might be uninhabitable) + 3. C has no unlifted argument types (since they might be uninhabitable) + +It's relatively cheap to check if a DataCon is DI, so before we call 'instCon' +on a constructor of a COMPLETE set, we filter out all of the DI ones. + +This fast path shaves down -7% allocations for PmSeriesG, for example. + +Note [Matching against a ConLike result type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a ConLike + +> C :: forall us. R => ... -> res_ty + +is a pattern `C ...` compatible with the type `ty`? Clearly that is the case if +`res_ty` /subsumes/ `ty` and the required constraints `R` (strictly a feature of +pattern synonyms) are satisfiable. In that case, 'matchConLikeResTy' returns a +substitution σ over `us` such that `σ(res_ty) == ty`. + +It's surprisingly tricky to implement correctly, and works quite different for +DataCons and PatSynCons: + + * For data cons, we look at `ty` and see if it's a TyCon app `T t1 ... tn`. + If that is the case, we make sure that `C` is a DataCon of `T` and return + a substitution mapping `C`'s universal tyvars `us` to `t1`...`tn`. + + Wrinkle: Since `T` might be a data family TyCon, we have to look up its + representation TyCon before we compare to `C`'s TyCon. + So we use 'splitReprTyConApp_maybe' instead of 'splitTyConApp_maybe'. + + * For pattern synonyms, we directly match `ty` against `res_ty` to get the + substitution σ. See Note [Pattern synonym result type] in "GHC.Core.PatSyn". + + Fortunately, we don't have to treat data family TyCons specially: + Pattern synonyms /never/ apply to a data family representation TyCon. + We do have to consider the required constraints `σ(R)`, though, as we have + seen in #19475. That is done by solving them as Wanted constraints given the + inert set of the current type state (which is part of a Nabla's TySt). Since + spinning up a constraint solver session is costly, we only do so in the rare + cases that a pattern synonym actually carries any required constraints. + + We can get into the strange situation that not all universal type variables + `us` occur in `res_ty`. Example from T11336b: + + instance C Proxy where ... -- impl uninteresting + pattern P :: forall f a. C f => f a -> Proxy a -- impl uninteresting + + fun :: Proxy a -> () + fun (P Proxy) = () + fun (P Proxy) = () -- ideally detected as redundant + + `f` is a universal type variable and `C f` the required constraint of + pattern synonym `P`. But `f` doesn't occur in the result type `Proxy a` of + `P`, so σ will not even have `f` in its in-scope set. It's a bit unclear + what to do here; we might want to freshen `f` to `f'` and see if we can + solve `C f'` as a Wanted constraint, which we most likely can't. + Hence, we simply skip the freshening and declare the match as failed when + there is a variable like `f`. For the definition of `fun`, that + means we will not remember that we matched on `P` and thus will + not detect its second clause as redundant. + + See Note [Pattern synonym result type] in "GHC.Core.PatSyn" for similar + oddities. + +Note [Instantiating a ConLike] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`instCon` implements the \(Inst\) function from Figure 8 of the LYG paper. + +Given the following type of ConLike `K` + +> K :: forall us. R => forall es. P => t1 -> ... -> tn -> res_ty + +and a variable `x::match_ty`, it tries to find an instantiation +`K ex_tvs gammas arg_ids :: match_ty` (for fresh `arg_ids`) and ultimately adds +a constructor constraint `K ex_tvs gammas arg_ids <- x` to the given Nabla. + +As a first step, it tries (via 'matchConLikeResTy') to match `match_ty` against +`res_ty` and checks that that the required constraints @R@ are satisfiable. +See Note [Matching against a ConLike result type]. + +If matching /fails/, it trivially (and conservatively) reports "inhabited" by +returning the unrefined input Nabla. After all, the match might have failed due +to incomplete type information in Nabla. +(Later type refinement from unpacking GADT constructors might monomorphise +`match_ty` so much that `res_ty` ultimately subsumes it.) + +If matching /succeeds/, we get a substitution σ for the (universal) +tyvars `us`. After applying σ, we get + +> K @σ(us) :: σ(R) => forall σ(es). σ(P) => σ(t1) -> ... -> σ(tn) -> match_ty + +The existentials `es` might still occur in argument types `σ(tn)`, though. +Now 'instCon' performs the following steps: + + 1. It drops the required constraints `σ(R)`, as they have already been + discharged by 'matchConLikeResTy'. + 2. It instantiates fresh binders `es'` for the other type variables `es` + bound by `K` and adds the mapping to σ to get σ', so that we have + + > K @σ(us) @es' :: σ'(P) => σ'(t1) -> ... -> σ'(tn) -> match_ty + + 3. It adds new type constraints from the substituted + provided constraints @σ'(P)@. + 4. It substitutes and conjures new binders @arg_ids@ for the argument types + @σ'(t1) ... σ'(tn)@. + 5. It adds a term constraint @K es' σ'(P) arg_ids <- x@, which handles + the details regarding type constraints and unlifted fields. + +And finally the extended 'Nabla' is returned if all the constraints were +compatible. +-} + +-------------------------------------- +-- * Generating inhabitants of a Nabla +-- +-- This is important for warnings. Roughly corresponds to G in Figure 6 of the +-- LYG paper, with a few tweaks for better warning messages. + +-- | See Note [Case split inhabiting patterns] +data GenerateInhabitingPatternsMode + = CaseSplitTopLevel + | MinimalCover + deriving (Eq, Show) + +instance Outputable GenerateInhabitingPatternsMode where + ppr = text . show + +-- | @generateInhabitingPatterns vs n nabla@ returns a list of at most @n@ (but +-- perhaps empty) refinements of @nabla@ that represent inhabited patterns. +-- Negative information is only retained if literals are involved or for +-- recursive GADTs. +generateInhabitingPatterns :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nabla -> DsM [Nabla] +-- See Note [Why inhabitationTest doesn't call generateInhabitingPatterns] +generateInhabitingPatterns _ _ 0 _ = pure [] +generateInhabitingPatterns _ [] _ nabla = pure [nabla] +generateInhabitingPatterns mode (x:xs) n nabla = do + tracePm "generateInhabitingPatterns" (ppr mode <+> ppr n <+> ppr (x:xs) $$ ppr nabla) + let VI _ pos neg _ _ = lookupVarInfo (nabla_tm_st nabla) x + case pos of + _:_ -> do + -- Example for multiple solutions (must involve a PatSyn): + -- f x@(Just _) True | SomePatSyn _ <- x = ... + -- within the RHS, we know that + -- * @x ~ Just y@ for some @y@ + -- * @x ~ SomePatSyn z@ for some @z@ + -- and both conditions have to hold /at the same time/. Hence we must + -- find evidence for @y@ and @z@ that is valid at the same time. These + -- constitute arg_vas below. + let arg_vas = concatMap paca_ids pos + generateInhabitingPatterns mode (arg_vas ++ xs) n nabla + [] + -- When there are literals involved, just print negative info + -- instead of listing missed constructors + | notNull [ l | PmAltLit l <- pmAltConSetElems neg ] + -> generateInhabitingPatterns mode xs n nabla + -- When some constructors are impossible or when we don't care for a + -- minimal cover (Note [Case split inhabiting patterns]), do a case split. + | not (isEmptyPmAltConSet neg) || mode == CaseSplitTopLevel + -> try_instantiate x xs n nabla + -- Else don't do a case split on this var, just print a wildcard. + -- But try splitting for the remaining vars, of course + | otherwise + -> generateInhabitingPatterns mode xs n nabla + where + -- Tries to instantiate a variable by possibly following the chain of + -- newtypes and then instantiating to all ConLikes of the wrapped type's + -- minimal residual COMPLETE set. + try_instantiate :: Id -> [Id] -> Int -> Nabla -> DsM [Nabla] + -- Convention: x binds the outer constructor in the chain, y the inner one. + try_instantiate x xs n nabla = do + (_src_ty, dcs, rep_ty) <- tntrGuts <$> pmTopNormaliseType (nabla_ty_st nabla) (idType x) + mb_stuff <- runMaybeT $ instantiate_newtype_chain x nabla dcs + case mb_stuff of + Nothing -> pure [] + Just (y, newty_nabla) -> do + let vi = lookupVarInfo (nabla_tm_st newty_nabla) y + env <- dsGetFamInstEnvs + rcm <- case splitReprTyConApp_maybe env rep_ty of + Just (tc, _, _) -> addTyConMatches tc (vi_rcm vi) + Nothing -> addCompleteMatches (vi_rcm vi) + + -- Test all COMPLETE sets for inhabitants (n inhs at max). Take care of ⊥. + clss <- pickApplicableCompleteSets (nabla_ty_st nabla) rep_ty rcm + case NE.nonEmpty (uniqDSetToList . cmConLikes <$> clss) of + Nothing -> + -- No COMPLETE sets ==> inhabited + generateInhabitingPatterns mode xs n newty_nabla + Just clss -> do + -- Try each COMPLETE set. + nablass' <- forM clss (instantiate_cons y rep_ty xs n newty_nabla) + if any null nablass' && vi_bot vi /= IsNotBot + then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard! + else do + -- Pick the residual COMPLETE set with the smallest cost (see 'completeSetCost'). + -- See Note [Prefer in-scope COMPLETE matches]. + DsGblEnv { ds_gbl_rdr_env = rdr_env } <- getGblEnv + let bestSet = map snd $ minimumBy (comparing $ completeSetCost rdr_env) nablass' + pure bestSet + + -- Instantiates a chain of newtypes, beginning at @x@. + -- Turns @x nabla [T,U,V]@ to @(y, nabla')@, where @nabla'@ we has the fact + -- @x ~ T (U (V y))@. + instantiate_newtype_chain :: Id -> Nabla -> [(Type, DataCon, Type)] -> MaybeT DsM (Id, Nabla) + instantiate_newtype_chain x nabla [] = pure (x, nabla) + instantiate_newtype_chain x nabla ((_ty, dc, arg_ty):dcs) = do + y <- lift $ mkPmId arg_ty + -- Newtypes don't have existentials (yet?!), so passing an empty + -- list as ex_tvs. + nabla' <- addConCt nabla x (PmAltConLike (RealDataCon dc)) [] [y] + instantiate_newtype_chain y nabla' dcs + + instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [(Maybe ConLike, Nabla)] + instantiate_cons _ _ _ _ _ [] = pure [] + instantiate_cons _ _ _ 0 _ _ = pure [] + instantiate_cons _ ty xs n nabla _ + -- We don't want to expose users to GHC-specific constructors for Int etc. + | fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True + = map (Nothing,) <$> generateInhabitingPatterns mode xs n nabla + instantiate_cons x ty xs n nabla (cl:cls) = do + -- The following line is where we call out to the inhabitationTest! + mb_nabla <- runMaybeT $ instCon 4 nabla x cl + tracePm "instantiate_cons" (vcat [ ppr x <+> dcolon <+> ppr (idType x) + , ppr ty + , ppr cl + , ppr nabla + , ppr mb_nabla + , ppr n ]) + con_nablas <- case mb_nabla of + Nothing -> pure [] + -- NB: We don't prepend arg_vars as we don't have any evidence on + -- them and we only want to split once on a data type. They are + -- inhabited, otherwise the inhabitation test would have refuted. + Just nabla' -> generateInhabitingPatterns mode xs n nabla' + other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls + pure (map (Just cl,) con_nablas ++ other_cons_nablas) + +-- | If multiple residual COMPLETE sets apply, pick one as follows: +-- +-- - prefer COMPLETE sets in which all constructors are in scope, +-- as per Note [Prefer in-scope COMPLETE matches], +-- - if there are ties, pick the one with the fewest (residual) ConLikes, +-- - if there are ties, pick the one with the fewest "trivially inhabited" types, +-- - if there are ties, pick the one with the fewest PatSyns, +-- - if there are still ties, pick the one that comes first in the list of +-- COMPLETE pragmas, which means the one that was brought into scope first. +completeSetCost :: GlobalRdrEnv -> [(Maybe ConLike, a)] -> (Bool, Int, Int, Int) +completeSetCost _ [] = (False, 0, 0, 0) +completeSetCost rdr_env ((mb_con, _) : cons) = + let con_out_of_scope + | Just con <- mb_con + = isNothing $ lookupGRE_Name rdr_env (conLikeName con) + | otherwise + = False + (any_out_of_scope, nb_cons, nb_triv, nb_ps) = completeSetCost rdr_env cons + in ( any_out_of_scope || con_out_of_scope + , nb_cons + 1 + , nb_triv + case mb_con of { Nothing -> 1; _ -> 0 } + , nb_ps + case mb_con of { Just (PatSynCon {}) -> 1; _ -> 0 } + ) + +{- Note [Prefer in-scope COMPLETE matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We prefer using COMPLETE pragmas in which all ConLikes are in scope, as this +improves error messages. See for example T25115: + + - T25115a defines pattern Foo :: a with {-# COMPLETE Foo #-} + - T25115 imports T25115a, but not Foo. + (This means it imports the COMPLETE pragma, which behaves like an instance.) + + Then, for the following incomplete pattern match in T25115: + + baz :: Ordering -> Int + baz = \case + EQ -> 5 + + we would prefer reporting that 'LT' and 'GT' are not matched, rather than + saying that 'T25115a.Foo' is not matched. + + However, if ALL ConLikes are out of scope, then we should still report + something, so we don't want to outright filter out all COMPLETE sets + with an out-of-scope ConLike. +-} + +pickApplicableCompleteSets :: TyState -> Type -> ResidualCompleteMatches -> DsM DsCompleteMatches +-- See Note [Implementation of COMPLETE pragmas] on what "applicable" means +pickApplicableCompleteSets ty_st ty rcm = do + let cl_res_ty_ok :: ConLike -> DsM Bool + cl_res_ty_ok cl = do + env <- dsGetFamInstEnvs + isJust <$> matchConLikeResTy env ty_st ty cl + let cm_applicable :: DsCompleteMatch -> DsM Bool + cm_applicable cm = do + cls_ok <- allM cl_res_ty_ok (uniqDSetToList (cmConLikes cm)) + let match_ty_ok = completeMatchAppliesAtType ty cm + pure (cls_ok && match_ty_ok) + applicable_cms <- filterM cm_applicable (getRcm rcm) + tracePm "pickApplicableCompleteSets:" $ + vcat + [ ppr ty + , ppr rcm + , ppr applicable_cms + ] + return applicable_cms + +{- Note [Why inhabitationTest doesn't call generateInhabitingPatterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why can't we define `inhabitationTest` (IT) in terms of +`generateInhabitingPatterns` (GIP) as + + inhabitationTest nabla = do + nablas <- lift $ generateInhabitingPatterns all_variables 1 nabla + guard (notNull nablas) + +There are a few technical reasons, like the lack of a fuel-tracking approach +to stay decidable, that could be overcome. But the nail in the coffin is +performance: In order to provide good warning messages, GIP commits to *one* +COMPLETE set, and goes through some hoops to find the minimal one. This implies +it has to look at *all* constructors in the residual COMPLETE matches and see if +they match, if only to filter out ill-typed COMPLETE sets +(see Note [Implementation of COMPLETE pragmas]). That is untractable for an +efficient IT on huge enumerations. + +But we still need GIP to produce the Nablas as proxies for +uncovered patterns that we display warnings for. It's fine to pay this price +once at the end, but IT is called far more often than that. + +Note [Case split inhabiting patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have an -XEmptyCase, +```hs +f :: Maybe a -> () +f x = case x of {} +``` +we want to show the different missing patterns {'Just _', 'Nothing'} to the user +instead of an uninformative wildcard pattern '_'. + +But when we have a match as part of a function definition, such as +```hs +g :: (Bool, [a]) -> () +g (_, []) = () +``` +we established in #20642 that we *do not* want to report P1={'(False, (_:_))', +'(True, (_:_))'} when we could just give the singleton set P2={'(_, (_:_))'}! +The latter set M is a "minimal cover" of the space of missing patterns S, in +that + +1. The union of M is *exactly* S +2. The size of M is minimal under all such candidates. + +In terms of 'g', P2 satisfies both (1) and (2). While P1 satisfies (1), it does +not satisfy (2). The set {'_'} satisfies (2), but it does not satisfy (1) as +it also covers the pattern '(_,[])' which is not part of the space of missing +patterns of 'g', so it would be a bad (too conservative) suggestion. + +Note that for -XEmptyCase, we don't want to emit a minimal cover. We arrange +that by passing 'CaseSplitTopLevel' to 'generateInhabitingPatterns'. We detect +the -XEmptyCase case in 'reportWarnings' by looking for 'ReportEmptyCase'. +-} diff --git a/GHC/HsToCore/Pmc/Solver/Types.hs b/GHC/HsToCore/Pmc/Solver/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Pmc/Solver/Types.hs @@ -0,0 +1,804 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Domain types used in "GHC.HsToCore.Pmc.Solver". +-- The ultimate goal is to define 'Nabla', which models normalised refinement +-- types from the paper +-- [Lower Your Guards: A Compositional Pattern-Match Coverage Checker"](https://dl.acm.org/doi/abs/10.1145/3408989). +module GHC.HsToCore.Pmc.Solver.Types ( + + -- * Normalised refinement types + BotInfo(..), PmAltConApp(..), VarInfo(..), TmState(..), TyState(..), + Nabla(..), Nablas(..), initNablas, + lookupRefuts, lookupSolution, + + -- ** Looking up 'VarInfo' + lookupVarInfo, lookupVarInfoNT, trvVarInfo, + + -- ** Caching residual COMPLETE sets + CompleteMatch, ResidualCompleteMatches(..), getRcm, isRcmInitialised, + + -- ** Representations for Literals and AltCons + PmLit(..), PmLitValue(..), PmAltCon(..), pmLitType, pmAltConType, + isPmAltConMatchStrict, pmAltConImplBangs, + + -- *** PmAltConSet + PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet, + extendPmAltConSet, pmAltConSetElems, + + -- *** Equality on 'PmAltCon's + PmEquality(..), eqPmAltCon, + + -- *** Operations on 'PmLit' + literalToPmLit, negatePmLit, overloadPmLit, + pmLitAsStringLit, coreExprAsPmLit + + ) where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Unique.DSet +import GHC.Types.Unique.SDFM +import GHC.Types.Name +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Utils.Outputable +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc (lastMaybe) +import GHC.Data.List.SetOps (unionLists) +import GHC.Data.Maybe +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Types.Literal +import GHC.Core +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.Map.Expr +import GHC.Core.Utils (exprType) +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Tc.Solver.InertSet (InertSet, emptyInertSet) +import GHC.Tc.Utils.TcType (isStringTy, topTcLevel) +import GHC.Types.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 (emptyInertSet topTcLevel) + +-- | 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 DsCompleteMatch) + -- ^ 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 DsCompleteMatches) + -- ^ 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 -> DsCompleteMatches +getRcm (RCM vanilla pragmas) = maybeToList vanilla ++ fromMaybe [] pragmas + +isRcmInitialised :: ResidualCompleteMatches -> Bool +isRcmInitialised (RCM vanilla pragmas) = isJust vanilla && isJust pragmas + +instance Outputable ResidualCompleteMatches where + -- formats as "[{Nothing,Just},{P,Q}]" + ppr rcm = ppr (getRcm rcm) + +----------------------- +-- * Looking up VarInfo + +emptyRCM :: ResidualCompleteMatches +emptyRCM = RCM Nothing Nothing + +emptyVarInfo :: Id -> VarInfo +emptyVarInfo x + = VI + { vi_id = x + , vi_pos = [] + , vi_neg = emptyPmAltConSet + -- Why not set IsNotBot for unlifted type here? + -- Because we'd have to trigger an inhabitation test, which we can't. + -- See case (4) in Note [Strict fields and variables of unlifted type] + -- in GHC.HsToCore.Pmc.Solver + , vi_bot = MaybeBot + , vi_rcm = emptyRCM + } + +lookupVarInfo :: TmState -> Id -> VarInfo +-- (lookupVarInfo tms x) tells what we know about 'x' +lookupVarInfo (TmSt env _ _) x = fromMaybe (emptyVarInfo x) (lookupUSDFM env x) + +-- | Like @lookupVarInfo ts x@, but @lookupVarInfo ts x = (y, vi)@ also looks +-- through newtype constructors. We have @x ~ N1 (... (Nk y))@ such that the +-- returned @y@ doesn't have a positive newtype constructor constraint +-- associated with it (yet). The 'VarInfo' returned is that of @y@'s +-- representative. +-- +-- Careful, this means that @idType x@ might be different to @idType y@, even +-- modulo type normalisation! +-- +-- See also Note [Coverage checking Newtype matches] in GHC.HsToCore.Pmc.Solver. +lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo) +lookupVarInfoNT ts x = case lookupVarInfo ts x of + VI{ vi_pos = as_newtype -> Just y } -> lookupVarInfoNT ts y + res -> (x, res) + where + as_newtype = listToMaybe . mapMaybe go + go PACA{paca_con = PmAltConLike (RealDataCon dc), paca_ids = [y]} + | isNewDataCon dc = Just y + go _ = Nothing + +trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla) +{-# INLINE trvVarInfo #-} +-- This function is called a lot and we want to specilise it, not only +-- for the type class, but also for its 'f' function argument. +-- Before the INLINE pragma it sometimes inlined and sometimes didn't, +-- depending delicately on GHC's optimisations. Better to use a pragma. +trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x + = set_vi <$> f (lookupVarInfo ts x) + where + set_vi (a, vi') = + (a, nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env (vi_id vi') vi' } }) + +------------------------------------------------ +-- * Exported utility functions querying 'Nabla' + +lookupRefuts :: Nabla -> Id -> [PmAltCon] +-- Unfortunately we need the extra bit of polymorphism and the unfortunate +-- duplication of lookupVarInfo here. +lookupRefuts MkNabla{ nabla_tm_st = ts } x = + pmAltConSetElems $ vi_neg $ lookupVarInfo ts x + +isDataConSolution :: PmAltConApp -> Bool +isDataConSolution PACA{paca_con = PmAltConLike (RealDataCon _)} = True +isDataConSolution _ = False + +-- @lookupSolution nabla x@ picks a single solution ('vi_pos') of @x@ from +-- possibly many, preferring 'RealDataCon' solutions whenever possible. +lookupSolution :: Nabla -> Id -> Maybe PmAltConApp +lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of + [] -> Nothing + pos@(x:_) + | Just sol <- find isDataConSolution pos -> Just sol + | otherwise -> Just x + +-------------------------------------------------------------------------------- +-- The rest is just providing an IR for (overloaded!) literals and AltCons that +-- sits between Hs and Core. We need a reliable way to detect and determine +-- equality between them, which is impossible with Hs (too expressive) and with +-- Core (no notion of overloaded literals, and even plain 'Int' literals are +-- actually constructor apps). Also String literals are troublesome. + +-- | Literals (simple and overloaded ones) for pattern match checking. +-- +-- See Note [Undecidable Equality for PmAltCons] +data PmLit = PmLit + { pm_lit_ty :: Type + , pm_lit_val :: PmLitValue } + +data PmLitValue + = PmLitInt Integer + | PmLitRat Rational + | PmLitChar Char + -- We won't actually see PmLitString in the oracle since we desugar strings to + -- lists + | PmLitString FastString + | PmLitOverInt Int {- How often Negated? -} Integer + | PmLitOverRat Int {- How often Negated? -} FractionalLit + | PmLitOverString FastString + +-- | Undecidable semantic equality result. +-- See Note [Undecidable Equality for PmAltCons] +data PmEquality + = Equal + | Disjoint + | PossiblyOverlap + deriving (Eq, Show) + +-- | When 'PmEquality' can be decided. @True <=> Equal@, @False <=> Disjoint@. +decEquality :: Bool -> PmEquality +decEquality True = Equal +decEquality False = Disjoint + +-- | Undecidable equality for values represented by 'PmLit's. +-- See Note [Undecidable Equality for PmAltCons] +-- +-- * @Just True@ ==> Surely equal +-- * @Just False@ ==> Surely different (non-overlapping, even!) +-- * @Nothing@ ==> Equality relation undecidable +eqPmLit :: PmLit -> PmLit -> PmEquality +eqPmLit (PmLit t1 v1) (PmLit t2 v2) + -- no haddock | pprTrace "eqPmLit" (ppr t1 <+> ppr v1 $$ ppr t2 <+> ppr v2) False = undefined + | not (t1 `eqType` t2) = Disjoint + | otherwise = go v1 v2 + where + go (PmLitInt i1) (PmLitInt i2) = decEquality (i1 == i2) + go (PmLitRat r1) (PmLitRat r2) = decEquality (r1 == r2) + go (PmLitChar c1) (PmLitChar c2) = decEquality (c1 == c2) + go (PmLitString s1) (PmLitString s2) = decEquality (s1 == s2) + go (PmLitOverInt n1 i1) (PmLitOverInt n2 i2) + | n1 == n2 && i1 == i2 = Equal + go (PmLitOverRat n1 r1) (PmLitOverRat n2 r2) + | n1 == n2 && r1 == r2 = Equal + go (PmLitOverString s1) (PmLitOverString s2) + | s1 == s2 = Equal + go _ _ = PossiblyOverlap + +-- | Syntactic equality. +instance Eq PmLit where + a == b = eqPmLit a b == Equal + +-- | Type of a 'PmLit' +pmLitType :: PmLit -> Type +pmLitType (PmLit ty _) = ty + +-- | Undecidable equality for values represented by 'ConLike's. +-- See Note [Undecidable Equality for PmAltCons]. +-- 'PatSynCon's aren't enforced to be generative, so two syntactically different +-- 'PatSynCon's might match the exact same values. Without looking into and +-- reasoning about the pattern synonym's definition, we can't decide if their +-- sets of matched values is different. +-- +-- * @Just True@ ==> Surely equal +-- * @Just False@ ==> Surely different (non-overlapping, even!) +-- * @Nothing@ ==> Equality relation undecidable +eqConLike :: ConLike -> ConLike -> PmEquality +eqConLike (RealDataCon dc1) (RealDataCon dc2) = decEquality (dc1 == dc2) +eqConLike (PatSynCon psc1) (PatSynCon psc2) + | psc1 == psc2 + = Equal +eqConLike _ _ = PossiblyOverlap + +-- | Represents the head of a match against a 'ConLike' or literal. +-- Really similar to 'GHC.Core.AltCon'. +data PmAltCon = PmAltConLike ConLike + | PmAltLit PmLit + +data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit] + +emptyPmAltConSet :: PmAltConSet +emptyPmAltConSet = PACS emptyUniqDSet [] + +isEmptyPmAltConSet :: PmAltConSet -> Bool +isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits + +-- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to +-- the given 'PmAltCon' according to 'eqPmAltCon'. +elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool +elemPmAltConSet (PmAltConLike cl) (PACS cls _ ) = elementOfUniqDSet cl cls +elemPmAltConSet (PmAltLit lit) (PACS _ lits) = elem lit lits + +extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet +extendPmAltConSet (PACS cls lits) (PmAltConLike cl) + = PACS (addOneToUniqDSet cls cl) lits +extendPmAltConSet (PACS cls lits) (PmAltLit lit) + = PACS cls (unionLists lits [lit]) + +pmAltConSetElems :: PmAltConSet -> [PmAltCon] +pmAltConSetElems (PACS cls lits) + = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits + +instance Outputable PmAltConSet where + ppr = ppr . pmAltConSetElems + +-- | We can't in general decide whether two 'PmAltCon's match the same set of +-- values. In addition to the reasons in 'eqPmLit' and 'eqConLike', a +-- 'PmAltConLike' might or might not represent the same value as a 'PmAltLit'. +-- See Note [Undecidable Equality for PmAltCons]. +-- +-- * @Just True@ ==> Surely equal +-- * @Just False@ ==> Surely different (non-overlapping, even!) +-- * @Nothing@ ==> Equality relation undecidable +-- +-- Examples (omitting some constructor wrapping): +-- +-- * @eqPmAltCon (LitInt 42) (LitInt 1) == Just False@: Lit equality is +-- decidable +-- * @eqPmAltCon (DataCon A) (DataCon B) == Just False@: DataCon equality is +-- decidable +-- * @eqPmAltCon (LitOverInt 42) (LitOverInt 1) == Nothing@: OverLit equality +-- is undecidable +-- * @eqPmAltCon (PatSyn PA) (PatSyn PB) == Nothing@: PatSyn equality is +-- undecidable +-- * @eqPmAltCon (DataCon I#) (LitInt 1) == Nothing@: DataCon to Lit +-- comparisons are undecidable without reasoning about the wrapped @Int#@ +-- * @eqPmAltCon (LitOverInt 1) (LitOverInt 1) == Just True@: We assume +-- reflexivity for overloaded literals +-- * @eqPmAltCon (PatSyn PA) (PatSyn PA) == Just True@: We assume reflexivity +-- for Pattern Synonyms +eqPmAltCon :: PmAltCon -> PmAltCon -> PmEquality +eqPmAltCon (PmAltConLike cl1) (PmAltConLike cl2) = eqConLike cl1 cl2 +eqPmAltCon (PmAltLit l1) (PmAltLit l2) = eqPmLit l1 l2 +eqPmAltCon _ _ = PossiblyOverlap + +-- | Syntactic equality. +instance Eq PmAltCon where + a == b = eqPmAltCon a b == Equal + +-- | Type of a 'PmAltCon' +pmAltConType :: PmAltCon -> [Type] -> Type +pmAltConType (PmAltLit lit) _arg_tys = assert (null _arg_tys ) $ pmLitType lit +pmAltConType (PmAltConLike con) arg_tys = conLikeResTy con arg_tys + +-- | Is a match on this constructor forcing the match variable? +-- True of data constructors, literals and pattern synonyms (#17357), but not of +-- newtypes. +-- See Note [Coverage checking Newtype matches] in GHC.HsToCore.Pmc.Solver. +isPmAltConMatchStrict :: PmAltCon -> Bool +isPmAltConMatchStrict PmAltLit{} = True +isPmAltConMatchStrict (PmAltConLike PatSynCon{}) = True -- #17357 +isPmAltConMatchStrict (PmAltConLike (RealDataCon dc)) = not (isNewDataCon dc) + +pmAltConImplBangs :: PmAltCon -> [HsImplBang] +pmAltConImplBangs PmAltLit{} = [] +pmAltConImplBangs (PmAltConLike con) = conLikeImplBangs con + +{- Note [Undecidable Equality for PmAltCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Equality on overloaded literals is undecidable in the general case. Consider +the following example: + + instance Num Bool where + ... + fromInteger 0 = False -- C-like representation of booleans + fromInteger _ = True + + f :: Bool -> () + f 1 = () -- Clause A + f 2 = () -- Clause B + +Clause B is redundant but to detect this, we must decide the constraint: +@fromInteger 2 ~ fromInteger 1@ which means that we +have to look through function @fromInteger@, whose implementation could +be anything. This poses difficulties for: + +1. The expressive power of the check. + We cannot expect a reasonable implementation of pattern matching to detect + that @fromInteger 2 ~ fromInteger 1@ is True, unless we unfold function + fromInteger. This puts termination at risk and is undecidable in the + general case. + +2. Error messages/Warnings. + What should our message for @f@ above be? A reasonable approach would be + to issue: + + Pattern matches are (potentially) redundant: + f 2 = ... under the assumption that 1 == 2 + + but seems to complex and confusing for the user. + +We choose to equate only obviously equal overloaded literals, in all other cases +we signal undecidability by returning Nothing from 'eqPmAltCons'. We do +better for non-overloaded literals, because we know their fromInteger/fromString +implementation is actually injective, allowing us to simplify the constraint +@fromInteger 1 ~ fromInteger 2@ to @1 ~ 2@, which is trivially unsatisfiable. + +The impact of this treatment of overloaded literals is the following: + + * Redundancy checking is rather conservative, since it cannot see that clause + B above is redundant. + + * We have instant equality check for overloaded literals (we do not rely on + the term oracle which is rather expensive, both in terms of performance and + memory). This significantly improves the performance of functions `covered` + `uncovered` and `divergent` in "GHC.HsToCore.Pmc" and effectively addresses + #11161. + + * The warnings issued are simpler. + +Similar reasoning applies to pattern synonyms: In contrast to data constructors, +which are generative, constraints like F a ~ G b for two different pattern +synonyms F and G aren't immediately unsatisfiable. We assume F a ~ F a, though. +-} + +literalToPmLit :: Type -> Literal -> Maybe PmLit +literalToPmLit ty l = PmLit ty <$> go l + where + go (LitChar c) = Just (PmLitChar c) + go (LitFloat r) = Just (PmLitRat r) + go (LitDouble r) = Just (PmLitRat r) + go (LitString s) = Just (PmLitString (mkFastStringByteString s)) + go (LitNumber _ i) = Just (PmLitInt i) + go _ = Nothing + +negatePmLit :: PmLit -> Maybe PmLit +negatePmLit (PmLit ty v) = PmLit ty <$> go v + where + go (PmLitInt i) = Just (PmLitInt (-i)) + go (PmLitRat r) = Just (PmLitRat (-r)) + go (PmLitOverInt n i) = Just (PmLitOverInt (n+1) i) + go (PmLitOverRat n r) = Just (PmLitOverRat (n+1) r) + go _ = Nothing + +overloadPmLit :: Type -> PmLit -> Maybe PmLit +overloadPmLit ty (PmLit _ v) = PmLit ty <$> go v + where + go (PmLitInt i) = Just (PmLitOverInt 0 i) + go (PmLitRat r) = Just $! PmLitOverRat 0 $! fractionalLitFromRational r + go (PmLitString s) + | ty `eqType` stringTy = Just v + | otherwise = Just (PmLitOverString s) + go ovRat@PmLitOverRat{} = Just ovRat + go _ = Nothing + +pmLitAsStringLit :: PmLit -> Maybe FastString +pmLitAsStringLit (PmLit _ (PmLitString s)) = Just s +pmLitAsStringLit _ = Nothing + +coreExprAsPmLit :: CoreExpr -> Maybe PmLit +-- coreExprAsPmLit e | pprTrace "coreExprAsPmLit" (ppr e) False = undefined +coreExprAsPmLit (Tick _t e) = coreExprAsPmLit e +coreExprAsPmLit (Lit l) = literalToPmLit (literalType l) l +coreExprAsPmLit e = case collectArgs e of + (Var x, [Lit l]) + | Just dc <- isDataConWorkId_maybe x + , dc `elem` [intDataCon, wordDataCon, charDataCon, floatDataCon, doubleDataCon] + -> literalToPmLit (exprType e) l + (Var x, [Lit (LitNumber _ l)]) + | Just (ty,l) <- bignum_lit_maybe x l + -> Just (PmLit ty (PmLitInt l)) + (Var x, [_ty, n_arg, d_arg]) + | Just dc <- isDataConWorkId_maybe x + , dataConName dc == ratioDataConName + , Just (PmLit _ (PmLitInt n)) <- coreExprAsPmLit n_arg + , Just (PmLit _ (PmLitInt d)) <- coreExprAsPmLit d_arg + -- HACK: just assume we have a literal double. This case only occurs for + -- overloaded lits anyway, so we immediately override type information + -> literalToPmLit (exprType e) (mkLitDouble (n % d)) + + (Var x, args) + -- See Note [Detecting overloaded literals with -XRebindableSyntax] + | is_rebound_name x fromIntegerName + , Just arg <- lastMaybe args + , Just (_ty,l) <- bignum_conapp_maybe arg + -> Just (PmLit integerTy (PmLitInt l)) >>= overloadPmLit (exprType e) + (Var x, args) + -- See Note [Detecting overloaded literals with -XRebindableSyntax] + -- fromRational + | 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* + | Just exp_base <- is_larg_exp_ratio x + , [r, exp] <- dropWhile (not . is_ratio) args + , (Var x, [_ty, n_arg, d_arg]) <- collectArgs r + , Just dc <- isDataConWorkId_maybe x + , dataConName dc == ratioDataConName + , Just (PmLit _ (PmLitInt n)) <- coreExprAsPmLit n_arg + , Just (PmLit _ (PmLitInt d)) <- coreExprAsPmLit d_arg + , Just (_exp_ty,exp') <- bignum_conapp_maybe exp + -> do + let rational = (abs n) :% d + let neg = if n < 0 then 1 else 0 + let frac = mkFractionalLit NoSourceText False rational exp' exp_base + Just $ PmLit (exprType e) (PmLitOverRat neg frac) + + (Var x, args) + | is_rebound_name x fromStringName + -- See Note [Detecting overloaded literals with -XRebindableSyntax] + , s:_ <- filter (isStringTy . exprType) $ filter isValArg args + -- NB: Calls coreExprAsPmLit and then overloadPmLit, so that we return PmLitOverStrings + -> coreExprAsPmLit s >>= overloadPmLit (exprType e) + -- These last two cases handle proper String literals + (Var x, [Type ty]) + | Just dc <- isDataConWorkId_maybe x + , dc == nilDataCon + , ty `eqType` charTy + -> literalToPmLit stringTy (mkLitString "") + (Var x, [Lit l]) + | idName x `elem` [unpackCStringName, unpackCStringUtf8Name] + -> literalToPmLit stringTy l + + _ -> Nothing + where + bignum_conapp_maybe (App (Var x) (Lit (LitNumber _ l))) + = bignum_lit_maybe x l + bignum_conapp_maybe _ = Nothing + + bignum_lit_maybe x l + | Just dc <- isDataConWorkId_maybe x + = if | dc == integerISDataCon -> Just (integerTy,l) + | dc == integerIPDataCon -> Just (integerTy,l) + | dc == integerINDataCon -> Just (integerTy,negate l) + | dc == naturalNSDataCon -> Just (naturalTy,l) + | dc == naturalNBDataCon -> Just (naturalTy,l) + | otherwise -> Nothing + bignum_lit_maybe _ _ = Nothing + + is_ratio (Type _) = False + is_ratio r + | Just (tc, _) <- splitTyConApp_maybe (exprType r) + = tyConName tc == ratioTyConName + | otherwise + = False + is_larg_exp_ratio x + | is_rebound_name x mkRationalBase10Name + = Just Base10 + | is_rebound_name x mkRationalBase2Name + = Just Base2 + | otherwise + = Nothing + + + -- See Note [Detecting overloaded literals with -XRebindableSyntax] + is_rebound_name :: Id -> Name -> Bool + is_rebound_name x n = getOccFS (idName x) == getOccFS n + +{- Note [Detecting overloaded literals with -XRebindableSyntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally, we'd find e.g. overloaded string literals by comparing the +application head of an expression to `fromStringName`. But that doesn't work +with -XRebindableSyntax: The `Name` of a user-provided `fromString` function is +different to `fromStringName`, which lives in a certain module, etc. + +There really is no other way than to compare `OccName`s and guess which +argument is the actual literal string (we assume it's the first argument of +type `String`). + +The same applies to other overloaded literals, such as overloaded rationals +(`fromRational`)and overloaded integer literals (`fromInteger`). + +Note [Dealing with rationals with large exponents] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rationals with large exponents are *not* desugared to +a simple rational. As that would require us to compute +their value which can be expensive. Rather they desugar +to an expression. For example 1e1000 will desugar to an +expression of the form: `mkRationalWithExponentBase10 (1 :% 1) 1000` + +Only overloaded literals desugar to this form however, so we +we can just return a overloaded rational literal. + +The most complex case is if we have RebindableSyntax enabled. +By example if we have a pattern like this: `f 3.3 = True` + +It will desugar to: + fromRational + [TYPE: Rational, mkRationalBase10 (:% @Integer 10 1) (-1)] + +The fromRational is properly detected as an overloaded Rational by +coreExprAsPmLit and it's general code for detecting overloaded rationals. +See Note [Detecting overloaded literals with -XRebindableSyntax]. + +This case then recurses into coreExprAsPmLit passing only the expression +`mkRationalBase10 (:% @Integer 10 1) (-1)`. Which is caught by rationals +with large exponents case. This will return a `PmLitOverRat` literal. + +Which is then passed to overloadPmLit which simply returns it as-is since +it's already overloaded. + +-} + +instance Outputable PmLitValue where + ppr (PmLitInt i) = ppr i + ppr (PmLitRat r) = 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 diff --git a/GHC/HsToCore/Pmc/Types.hs b/GHC/HsToCore/Pmc/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Pmc/Types.hs @@ -0,0 +1,293 @@ + +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +{- +Author: George Karachalias + Sebastian Graf +-} + +-- | 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(..), GrdDag(..), + consGrdDag, gdSeq, sequencePmGrds, sequenceGrdDags, + alternativesGrdDags, + + -- ** Guard tree language + PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), + PmPatBind(..), PmEmptyCase(..), PmRecSel(..), + + -- * Coverage Checking types + RedSets (..), Precision (..), CheckResult (..), + + -- * Pre and post coverage checking synonyms + Pre, Post, + + -- * Normalised refinement types + module GHC.HsToCore.Pmc.Solver.Types + + ) where + +import GHC.Prelude + +import GHC.HsToCore.Pmc.Solver.Types + +import GHC.Data.OrdList +import GHC.Types.Id +import GHC.Types.Var (EvVar) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Core.ConLike +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 series-parallel graph of 'PmGrd's, so very nearly a guard tree, if +-- it weren't for or-patterns/'GdAlt'! +-- The implicit "source" corresponds to "before the match" and the implicit +-- "sink" corresponds to "after a successful match". +-- +-- * 'GdEnd' is a 'GrdDag' that always matches. +-- * 'GdOne' is a 'GrdDag' that matches iff its 'PmGrd' matches. +-- * @'GdSeq' g1 g2@ corresponds to matching guards @g1@ and then @g2@ +-- if matching @g1@ succeeded. +-- Example: The Haskell guard @| x > 1, x < 10 = ...@ will test @x > 1@ +-- before @x < 10@, failing if either test fails. +-- * @'GdAlt' g1 g2@ is far less common than 'GdSeq' and corresponds to +-- matching an or-pattern @(LT; EQ)@, succeeding if the +-- match variable matches /either/ 'LT' or 'EQ'. +-- See Note [Implementation of OrPatterns] for a larger example. +-- +data GrdDag + = GdEnd + | GdOne !PmGrd + | GdSeq !GrdDag !GrdDag + | GdAlt !GrdDag !GrdDag + +-- | Sequentially compose a list of 'PmGrd's into a 'GrdDag'. +sequencePmGrds :: [PmGrd] -> GrdDag +sequencePmGrds = sequenceGrdDags . map GdOne + +-- | Sequentially compose a list of 'GrdDag's. +sequenceGrdDags :: [GrdDag] -> GrdDag +sequenceGrdDags xs = foldr gdSeq GdEnd xs + +-- | Sequentially compose a 'PmGrd' in front of a 'GrdDag'. +consGrdDag :: PmGrd -> GrdDag -> GrdDag +consGrdDag g d = gdSeq (GdOne g) d + +-- | Sequentially compose two 'GrdDag's. A smart constructor for `GdSeq` that +-- eliminates `GdEnd`s. +gdSeq :: GrdDag -> GrdDag -> GrdDag +gdSeq g1 GdEnd = g1 +gdSeq GdEnd g2 = g2 +gdSeq g1 g2 = g1 `GdSeq` g2 + +-- | Parallel composition of a list of 'GrdDag's. +-- Needs a non-empty list as 'GdAlt' does not have a neutral element. +alternativesGrdDags :: NonEmpty GrdDag -> GrdDag +alternativesGrdDags xs = foldr1 GdAlt xs + +-- | 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) + +-- A guard tree denoting a record selector application +data PmRecSel v = PmRecSel { pr_arg_var :: v, pr_arg :: CoreExpr, pr_cons :: [ConLike] } +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 GrdDag where + ppr GdEnd = empty + ppr (GdOne g) = ppr g + ppr (GdSeq d1 d2) = ppr d1 <> comma <+> ppr d2 + ppr d0@GdAlt{} = parens $ fsep (ppr d : map ((semi <+>) . ppr) ds) + where + d NE.:| ds = collect d0 + collect (GdAlt d1 d2) = collect d1 Semi.<> collect d2 + collect d = NE.singleton d + +-- | Format a LYG sequence (e.g. 'Match'es of a 'MatchGroup' or 'GRHSs') as +-- @{ ; ...; }@ +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 " 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 = GrdDag + +-- | Used as tree payload post-checking. The redundancy info we elaborated. +type Post = RedSets diff --git a/GHC/HsToCore/Pmc/Utils.hs b/GHC/HsToCore/Pmc/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Pmc/Utils.hs @@ -0,0 +1,173 @@ + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Utility module for the pattern-match coverage checker. +module GHC.HsToCore.Pmc.Utils ( + + tracePm, traceWhenFailPm, mkPmId, + allPmCheckWarnings, overlapping, exhaustive, redundantBang, + exhaustiveWarningFlag, + isMatchContextPmChecked, isMatchContextPmChecked_SinglePat, + needToRunPmCheck + + ) where + +import GHC.Prelude + +import GHC.Types.Basic (Origin(..), requiresPMC) +import GHC.Driver.DynFlags +import GHC.Hs +import GHC.Core.Type +import GHC.Data.FastString +import GHC.Data.IOEnv +import GHC.Data.Maybe +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Unique.Supply +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Logger +import GHC.HsToCore.Monad + +import Control.Monad + +tracePm :: String -> SDoc -> DsM () +tracePm herald doc = do + logger <- getLogger + name_ppr_ctx <- mkNamePprCtxDs + liftIO $ putDumpFileMaybe' logger name_ppr_ctx + Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc)) +{-# INLINE tracePm #-} -- see Note [INLINE conditional tracing utilities] + +traceWhenFailPm :: String -> SDoc -> MaybeT DsM a -> MaybeT DsM a +traceWhenFailPm herald doc act = MaybeT $ do + mb_a <- runMaybeT act + when (isNothing mb_a) $ tracePm herald doc + pure mb_a +{-# INLINE traceWhenFailPm #-} -- see Note [INLINE conditional tracing utilities] + +-- | Generate a fresh `Id` of a given type +mkPmId :: Type -> DsM Id +mkPmId ty = getUniqueM >>= \unique -> + let occname = mkVarOccFS $ fsLit "pm" + in return (mkUserLocalOrCoVar occname unique ManyTy ty noSrcSpan) +{-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough + +-- | All warning flags that need to run the pattern match checker. +allPmCheckWarnings :: [WarningFlag] +allPmCheckWarnings = + [ Opt_WarnIncompletePatterns + , Opt_WarnIncompleteUniPatterns + , Opt_WarnIncompletePatternsRecUpd + , Opt_WarnOverlappingPatterns + , Opt_WarnIncompleteRecordSelectors + ] + +-- | Check whether the redundancy checker should run (redundancy only) +overlapping :: DynFlags -> HsMatchContext fn -> Bool +-- See Note [Inaccessible warnings for record updates] +overlapping _ RecUpd = False +overlapping dflags _ = wopt Opt_WarnOverlappingPatterns dflags + +-- | Check whether the exhaustiveness checker should run (exhaustiveness only) +exhaustive :: DynFlags -> HsMatchContext fn -> Bool +exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag + +-- | Check whether unnecessary bangs should be warned about +redundantBang :: DynFlags -> Bool +redundantBang dflags = wopt Opt_WarnRedundantBangPatterns dflags + +-- | Denotes whether an exhaustiveness check is supported, and if so, +-- via which 'WarningFlag' it's controlled. +-- Returns 'Nothing' if check is not supported. +exhaustiveWarningFlag :: HsMatchContext fn -> Maybe WarningFlag +exhaustiveWarningFlag FunRhs{} = Just Opt_WarnIncompletePatterns +exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns +exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns +exhaustiveWarningFlag (LamAlt LamSingle) = Just Opt_WarnIncompleteUniPatterns +exhaustiveWarningFlag (LamAlt _case) = Just Opt_WarnIncompletePatterns +exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns +exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns +exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c +exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd +exhaustiveWarningFlag LazyPatCtx = Just Opt_WarnIncompleteUniPatterns +exhaustiveWarningFlag ThPatSplice = Nothing +exhaustiveWarningFlag PatSyn = Nothing +exhaustiveWarningFlag ThPatQuote = Nothing +-- Don't warn about incomplete patterns in list comprehensions, pattern guards +-- etc. They are often *supposed* to be incomplete +exhaustiveWarningFlag StmtCtxt{} = Nothing + +arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag +arrowMatchContextExhaustiveWarningFlag = \ case + ProcExpr -> Just Opt_WarnIncompleteUniPatterns + ArrowCaseAlt -> Just Opt_WarnIncompletePatterns + ArrowLamAlt LamSingle -> Just Opt_WarnIncompleteUniPatterns + ArrowLamAlt _ -> Just Opt_WarnIncompletePatterns + +-- | Check whether any part of pattern match checking is enabled for this +-- 'HsMatchContext' (does not matter whether it is the redundancy check or the +-- exhaustiveness check). +isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext fn -> Bool +isMatchContextPmChecked dflags origin ctxt + = requiresPMC origin + && (overlapping dflags ctxt || exhaustive dflags ctxt) + +-- | Check whether exhaustivity checks are enabled for this 'HsMatchContext', +-- when dealing with a single pattern (using the 'matchSinglePatVar' function). +isMatchContextPmChecked_SinglePat :: DynFlags -> Origin -> HsMatchContext fn -> LPat GhcTc -> Bool +isMatchContextPmChecked_SinglePat dflags origin ctxt pat + | not (needToRunPmCheck dflags origin) + = False + | StmtCtxt {} <- ctxt + -- For @StmtCtxt@, we are interested in propagating pattern-match information + -- but not in the actual outcome of pattern-match checking, so we skip + -- if the pattern is "boring" (gives rise to no long-distance information). + -- (This is done purely for runtime performance.) + = not (isBoringHsPat pat) -- See Note [Boring patterns] in GHC.Hs.Pat. + | otherwise + = overlapping dflags ctxt || exhaustive dflags ctxt + +-- | Return True when any of the pattern match warnings ('allPmCheckWarnings') +-- are enabled, in which case we need to run the pattern match checker. +needToRunPmCheck :: DynFlags -> Origin -> Bool +needToRunPmCheck dflags origin + = requiresPMC origin + && any (`wopt` dflags) allPmCheckWarnings + +{- Note [Inaccessible warnings for record updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12957): + + data T a where + T1 :: { x :: Int } -> T Bool + T2 :: { x :: Int } -> T a + T3 :: T a + + f :: T Char -> T a + f r = r { x = 3 } + +In GHC.Tc.Gen.Expr.desugarRecordUpd, we will conservatively generate a case +for T1 even though it's impossible: + + f r = case r of + T1 x -> T1 3 -- Inaccessible branch + T2 x -> T2 3 + _ -> error "Missing" + +We don't want to warn about the inaccessible branch because the programmer +didn't put it there! So we filter out the warning here. +The test case T12957a checks this. + +The same can happen for long distance term constraints instead of type +constraints (#17783): + + data T = A { x :: Int } | B + f r@A{} = r { x = 3 } + f _ = B + +Here, the long distance info from the FunRhs match (@r ~ A x@) will make the +clause matching on @B@ of the desugaring to @case@ redundant. It's generated +code that we don't want to warn about. +-} diff --git a/GHC/HsToCore/Quote.hs b/GHC/HsToCore/Quote.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Quote.hs @@ -0,0 +1,3306 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- +-- The purpose of this module is to transform an HsExpr into a CoreExpr which +-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the +-- input HsExpr. We do this in the DsM monad, which supplies access to +-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype. +-- +-- It also defines a bunch of knownKeyNames, in the same way as is done +-- in prelude/GHC.Builtin.Names. It's much more convenient to do it here, because +-- otherwise we have to recompile GHC.Builtin.Names whenever we add a Name, which is +-- a Royal Pain (triggers other recompilation). +----------------------------------------------------------------------------- + +module GHC.HsToCore.Quote( dsBracket ) where + +import GHC.Prelude +import GHC.Platform + +import GHC.Driver.DynFlags + +import GHC.HsToCore.Errors.Types +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) +import GHC.HsToCore.Match.Literal +import GHC.HsToCore.Monad +import GHC.HsToCore.Binds + +import qualified GHC.Boot.TH.Syntax as TH + +import GHC.Hs + +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.TyCl ( IsPrefixConGADT(..), unannotatedMultIsLinear ) + +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core +import GHC.Core.Type( pattern ManyTy, mkFunTy ) +import GHC.Core.Make +import GHC.Core.Utils + +import GHC.Builtin.Names +import GHC.Builtin.Names.TH +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim + +import GHC.Unit.Module + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Monad + +import GHC.Data.FastString +import GHC.Data.Maybe +import qualified GHC.Data.List.NonEmpty as NE + +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.SourceText +import GHC.Types.Fixity +import GHC.Types.TyThing +import GHC.Types.Name hiding( varName, tcName ) +import GHC.Types.Name.Env + +import GHC.TypeLits +import Data.Kind (Constraint) + +import qualified GHC.LanguageExtensions as LangExt + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Data.ByteString ( unpack ) +import Control.Monad +import Data.List (sort, sortBy) +import Data.List.NonEmpty ( NonEmpty(..), toList ) +import Data.Function +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class +import GHC.Types.Name.Reader (RdrName(..), WithUserRdr (..)) + +data MetaWrappers = MetaWrappers { + -- Applies its argument to a type argument `m` and dictionary `Quote m` + quoteWrapper :: CoreExpr -> CoreExpr + -- Apply its argument to a type argument `m` and a dictionary `Monad m` + , monadWrapper :: CoreExpr -> CoreExpr + -- Apply the container typed variable `m` to the argument type `T` to get `m T`. + , metaTy :: Type -> Type + -- Information about the wrappers which be printed to be inspected + , _debugWrappers :: (HsWrapper, HsWrapper, Type) + } + +-- | Construct the functions which will apply the relevant part of the +-- QuoteWrapper to identifiers during desugaring. +mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers +mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do + let quote_var = Var quote_var_raw + -- Get the superclass selector to select the Monad dictionary, going + -- to be used to construct the monadWrapper. + quote_tc <- dsLookupTyCon quoteClassName + monad_tc <- dsLookupTyCon monadClassName + let cls = expectJust $ tyConClass_maybe quote_tc + monad_cls = expectJust $ tyConClass_maybe monad_tc + -- Quote m -> Monad m + monad_sel = classSCSelId cls 0 + + -- Only used for the defensive assertion that the selector has + -- the expected type + tyvars = dataConUserTyVarBinders (classDataCon cls) + expected_ty = mkForAllTys tyvars $ + mkFunTy invisArgConstraintLike ManyTy + (mkClassPred cls (mkTyVarTys (binderVars tyvars))) + (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) + + massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty) + + let m_ty = Type m_var + -- Construct the contents of MetaWrappers + quoteWrapper = applyQuoteWrapper q + monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.> + mkWpTyApps [m_var] + tyWrapper t = mkAppTy m_var t + debug = (quoteWrapper, monadWrapper, m_var) + dsHsWrapper quoteWrapper $ \q_f -> do { + dsHsWrapper monadWrapper $ \m_f -> do { + return (MetaWrappers q_f m_f tyWrapper debug) } } + +-- Turn A into m A +wrapName :: Name -> MetaM Type +wrapName n = do + t <- lookupType n + wrap_fn <- asks metaTy + return (wrap_fn t) + +-- The local state is always the same, calculated from the passed in +-- wrapper +type MetaM a = ReaderT MetaWrappers DsM a + +getPlatform :: MetaM Platform +getPlatform = targetPlatform <$> getDynFlags + +----------------------------------------------------------------------------- +dsBracket :: HsBracketTc -> DsM CoreExpr +-- See Note [Desugaring Brackets] +-- Returns a CoreExpr of type (M TH.Exp) +-- The quoted thing is parameterised over Name, even though it has +-- been type checked. We don't want all those type decorations! + +dsBracket (HsBracketTc { hsb_wrap = mb_wrap, hsb_splices = splices, hsb_quote = quote }) + = case quote of + VarBr _ _ n -> do { MkC e1 <- lookupOccDsM (unLoc n) ; return e1 } + ExpBr _ e -> runOverloaded $ do { MkC e1 <- repLE e ; return e1 } + PatBr _ p -> runOverloaded $ do { MkC p1 <- repTopP p ; return p1 } + TypBr _ t -> runOverloaded $ do { MkC t1 <- repLTy t ; return t1 } + DecBrG _ gp -> runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 } + DecBrL {} -> panic "dsUntypedBracket: unexpected DecBrL" + where + wrap = expectJust mb_wrap -- Not used in VarBr case + -- In the overloaded case we have to get given a wrapper, it is just + -- the VarBr case that there is no wrapper, because they + -- have a simple type. + + runOverloaded act = do { mw <- mkMetaWrappers wrap + ; runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw } + + new_bit = mkNameEnv [(n, DsSplice (unLoc e)) + | PendingTcSplice n e <- splices] + +{- +Note [Desugaring Brackets] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie +an expression bracket was of type Q Exp. This made the desugaring process simple +as there were no complicated type variables to keep consistent throughout the +whole AST. Due to the overloaded quotations proposal a quotation bracket is now +of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been +generalised to work with any monad implementing a minimal interface. + +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst + +Users can rejoice at the flexibility but now there is some additional complexity in +how brackets are desugared as all these polymorphic combinators need their arguments +instantiated. + +> IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD +> USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR. + +What the arguments should be instantiated to is supplied by the `QuoteWrapper` +datatype which is produced by `GHC.Tc.Gen.Splice`. It is a pair of an evidence variable +for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring +need to be applied to these two type variables. + +There are three important functions which do the application. + +1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument. +2. `rep2M` takes a function name of type `Monad m => T` as an argument +3. `rep2_nw` takes a function name without any constraints as an argument. + +These functions then use the information in QuoteWrapper to apply the correct +arguments to the functions as the representation is constructed. + +The `MetaM` monad carries around an environment of three functions which are +used in order to wrap the polymorphic combinators and instantiate the arguments +to the correct things. + +1. quoteWrapper wraps functions of type `forall m . Quote m => T` +2. monadWrapper wraps functions of type `forall m . Monad m => T` +3. metaTy wraps a type in the polymorphic `m` variable of the whole representation. + +Historical note about the implementation: At the first attempt, I attempted to +lie that the type of any quotation was `Quote m => m Exp` and then specialise it +by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was +simpler to implement but didn't work because of nested splices. For example, +you might have a nested splice of a more specific type which fixes the type of +the overall quote and so all the combinators used must also be instantiated to +that specific type. Therefore you really have to use the contents of the quote +wrapper to directly apply the right type to the combinators rather than +first generate a polymorphic definition and then just apply the wrapper at the end. + +-} + +{- -------------- Examples -------------------- + + [| \x -> x |] +====> + gensym (unpackString "x"#) `bindQ` \ x1::String -> + lam (pvar x1) (var x1) + + + [| \x -> $(f [| x |]) |] +====> + gensym (unpackString "x"#) `bindQ` \ x1::String -> + lam (pvar x1) (f (var x1)) +-} + + +------------------------------------------------------- +-- Declarations +------------------------------------------------------- + +-- Proxy for the phantom type of `Core`. All the generated fragments have +-- type something like `Quote m => m Exp` so to keep things simple we represent fragments +-- of that type as `M Exp`. +data M a + +repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat)) +repTopP pat = do { ss <- mkGenSyms (collectPatBinders CollNoDictBinders pat) + ; pat' <- addBinds ss (repLP pat) + ; wrapGenSyms ss pat' } + +repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec])) +repTopDs group@(HsGroup { hs_valds = valds + , hs_splcds = splcds + , hs_tyclds = tyclds + , hs_derivds = derivds + , hs_fixds = fixds + , hs_defds = defds + , hs_fords = fords + , hs_warnds = warnds + , hs_annds = annds + , hs_ruleds = ruleds + , hs_docs = docs }) + = do { let { bndrs = hsScopedTvBinders valds + ++ hsGroupBinders group + ++ map (unLoc . foLabel) (hsPatSynSelectors valds) + ; instds = tyclds >>= group_instds } ; + ss <- mkGenSyms bndrs ; + + -- Bind all the names mainly to avoid repeated use of explicit strings. + -- Thus we get + -- do { t :: String <- genSym "T" ; + -- return (Data t [] ...more t's... } + -- The other important reason is that the output must mention + -- only "T", not "Foo:T" where Foo is the current module + + decls <- addBinds ss ( + do { val_ds <- rep_val_binds valds + ; _ <- mapM no_splice splcds + ; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds) + ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) + ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds) + ; inst_ds <- mapM repInstD instds + ; deriv_ds <- mapM repStandaloneDerivD derivds + ; fix_ds <- mapM repLFixD fixds + ; def_ds <- mapM repDefD defds + ; for_ds <- mapM repForD fords + ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc) + warnds) + ; ann_ds <- mapM repAnnD annds + ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc) + ruleds) + ; _ <- mapM no_doc docs + + -- more needed + ; return (de_loc $ sort_by_loc $ + val_ds ++ catMaybes tycl_ds ++ role_ds + ++ kisig_ds + ++ (concat fix_ds) + ++ def_ds + ++ inst_ds ++ rule_ds ++ for_ds + ++ ann_ds ++ deriv_ds) }) ; + + core_list <- repListM decTyConName return decls ; + + dec_ty <- lookupType decTyConName ; + q_decs <- repSequenceM dec_ty core_list ; + + wrapGenSyms ss q_decs + } + where + no_splice (L loc _) + = notHandledL (locA loc) ThSplicesWithinDeclBrackets + no_warn :: LWarnDecl GhcRn -> MetaM a + no_warn (L loc (Warning _ thing _)) + = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing) + no_doc (L loc _) + = notHandledL (locA loc) ThHaddockDocumentation + +hsScopedTvBinders :: HsValBinds GhcRn -> [Name] +-- See Note [Scoped type variables in quotes] +hsScopedTvBinders binds + = concatMap get_scoped_tvs sigs + where + sigs = case binds of + ValBinds _ _ sigs -> sigs + XValBindsLR (NValBinds _ sigs) -> sigs + +get_scoped_tvs :: LSig GhcRn -> [Name] +get_scoped_tvs (L _ signature) + | TypeSig _ _ sig <- signature + = get_scoped_tvs_from_sig (hswc_body sig) + | ClassOpSig _ _ _ sig <- signature + = get_scoped_tvs_from_sig sig + | PatSynSig _ _ sig <- signature + = get_scoped_tvs_from_sig sig + | otherwise + = [] + +get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name] + -- Collect both implicit and explicit quantified variables, since + -- the types in instance heads, as well as `via` types in DerivingVia, can + -- bring implicitly quantified type variables into scope, e.g., + -- + -- instance Foo [a] where + -- m = n @a + -- + -- See also Note [Scoped type variables in quotes] +get_scoped_tvs_from_sig (L _ (HsSig{sig_bndrs = outer_bndrs})) = + hsOuterTyVarNames outer_bndrs + +{- Notes + +Note [Scoped type variables in quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Quoting declarations with scoped type variables requires some care. Consider: + + $([d| f :: forall a. a -> a + f x = x::a + |]) + +Here, the `forall a` brings `a` into scope over the binding group. This has +ramifications when desugaring the quote, as we must ensure that that the +desugared code binds `a` with `Language.Haskell.TH.newName` and refers to the +bound `a` type variable in the type signature and in the body of `f`. As a +result, the call to `newName` must occur before any part of the declaration for +`f` is processed. To achieve this, we: + + (a) Gensym a binding for `a` at the same time as we do one for `f`, + collecting the relevant binders with the hsScopedTvBinders family of + functions. + + (b) Use `addBinds` to bring these gensymmed bindings into scope over any + part of the code where the type variables scope. In the `f` example, + above, that means the type signature and the body of `f`. + + (c) When processing the `forall`, /don't/ gensym the type variables. We have + already brought the type variables into scope in part (b), after all, so + gensymming them again would lead to shadowing. We use the rep_ty_sig + family of functions for processing types without gensymming the type + variables again. + + (d) Finally, we use wrapGenSyms to generate the Core for these scoped type + variables: + + newName "a" >>= \a -> + ... -- process the type signature and body of `f` + +The relevant places are signposted with references to this Note. + +Note [Binders and occurrences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we desugar [d| data T = MkT |] +we want to get + Data "T" [] [Con "MkT" []] [] +and *not* + Data "Foo:T" [] [Con "Foo:MkT" []] [] +That is, the new data decl should fit into whatever new module it is +asked to fit in. We do *not* clone, though; no need for this: + Data "T79" .... + +But if we see this: + data T = MkT + foo = reifyDecl T + +then we must desugar to + foo = Data "Foo:T" [] [Con "Foo:MkT" []] [] + +So in repTopDs we bring the binders into scope with mkGenSyms and addBinds. +And we use lookupOcc, rather than lookupBinder +in repTyClD and repC. + +Note [Don't quantify implicit type variables in quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you're not careful, it's surprisingly easy to take this quoted declaration: + + [d| id :: a -> a + id x = x + |] + +and have Template Haskell turn it into this: + + id :: forall a. a -> a + id x = x + +Notice that we explicitly quantified the variable `a`! The latter declaration +isn't what the user wrote in the first place. + +Usually, the culprit behind these bugs is taking implicitly quantified type +variables (often from the hsib_vars field of HsImplicitBinders) and putting +them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. +-} + +-- represent associated family instances +-- +repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec))) + +repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ + repFamilyDecl (L loc fam) + +repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) + = do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences] + ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs -> + repSynDecl tc1 bndrs rhs + ; return (Just (locA loc, dec)) } + +repTyClD (L loc (DataDecl { tcdLName = tc + , tcdTyVars = tvs + , tcdDataDefn = defn })) + = do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences] + ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs -> + repDataDefn tc1 (Left bndrs) defn + ; return (Just (locA loc, dec)) } + +repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, + tcdTyVars = tvs, tcdFDs = fds, + tcdSigs = sigs, tcdMeths = meth_binds, + tcdATs = ats, tcdATDefs = atds })) + = do { cls1 <- lookupLOcc cls -- See Note [Binders and occurrences] + ; dec <- addQTyVarBinds FreshNamesOnly tvs $ \bndrs -> + do { cxt1 <- repLContext cxt + -- See Note [Scoped type variables in quotes] + ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds + ; fds1 <- repLFunDeps fds + ; ats1 <- repFamilyDecls ats + ; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds + ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds) + ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1 + ; wrapGenSyms ss decls2 } + ; return $ Just (locA loc, dec) + } + +------------------------- +repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repRoleD (L loc (RoleAnnotDecl _ tycon roles)) + = do { tycon1 <- lookupLOcc tycon + ; roles1 <- mapM repRole roles + ; roles2 <- coreList roleTyConName roles1 + ; dec <- repRoleAnnotD tycon1 roles2 + ; return (locA loc, dec) } + +------------------------- +repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repKiSigD (L loc kisig) = + case kisig of + StandaloneKindSig _ v ki -> do + MkC th_v <- lookupLOcc v + MkC th_ki <- repHsSigType ki + dec <- rep2 kiSigDName [th_v, th_ki] + pure (locA loc, dec) + +------------------------- +repDataDefn :: Core TH.Name + -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))]) + -- the repTyClD case + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) + -- the repDataFamInstD case + -> HsDataDefn GhcRn + -> MetaM (Core (M TH.Dec)) +repDataDefn tc opts + (HsDataDefn { dd_ctxt = cxt, dd_kindSig = ksig + , dd_cons = cons, dd_derivs = mb_derivs }) + = do { cxt1 <- repLContext cxt + ; derivs1 <- repDerivs mb_derivs + ; case cons of + NewTypeCon con -> do { con' <- repC con + ; ksig' <- repMaybeLTy ksig + ; repNewtype cxt1 tc opts ksig' con' + derivs1 } + DataTypeCons type_data cons -> do { ksig' <- repMaybeLTy ksig + ; consL <- mapM repC cons + ; cons1 <- coreListM conTyConName consL + ; repData type_data cxt1 tc opts ksig' cons1 + derivs1 } + } + +repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))] + -> LHsType GhcRn + -> MetaM (Core (M TH.Dec)) +repSynDecl tc bndrs ty + = do { ty1 <- repLTy ty + ; repTySyn tc bndrs ty1 } + +repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info + , fdLName = tc + , fdTyVars = tvs + , fdResultSig = L _ resultSig + , fdInjectivityAnn = injectivity })) + = do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences] + ; let res_tv = resultVariableName resultSig + ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs -> + addSimpleTyVarBinds ReuseBoundNames (maybeToList res_tv) $ + case info of + ClosedTypeFamily Nothing -> + notHandled (ThAbstractClosedTypeFamily decl) + ClosedTypeFamily (Just eqns) -> + do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns + ; eqns2 <- coreListM tySynEqnTyConName eqns1 + ; result <- repFamilyResultSig resultSig + ; inj <- repInjectivityAnn injectivity + ; repClosedFamilyD tc1 bndrs result inj eqns2 } + OpenTypeFamily -> + do { result <- repFamilyResultSig resultSig + ; inj <- repInjectivityAnn injectivity + ; repOpenFamilyD tc1 bndrs result inj } + DataFamily -> + do { kind <- repFamilyResultSigToMaybeKind resultSig + ; repDataFamilyD tc1 bndrs kind } + ; return (locA loc, dec) + } + +-- | Represent result signature of a type family +repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig)) +repFamilyResultSig (NoSig _) = repNoSig +repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki + ; repKindSig ki' } +repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr + ; repTyVarSig bndr' } + +-- | Represent result signature using a Maybe Kind. Used with data families, +-- where the result signature can be either missing or a kind but never a named +-- result variable. +repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn + -> MetaM (Core (Maybe (M TH.Kind))) +repFamilyResultSigToMaybeKind (NoSig _) = + coreNothingM kindTyConName +repFamilyResultSigToMaybeKind (KindSig _ ki) = + coreJustM kindTyConName =<< repLTy ki +repFamilyResultSigToMaybeKind TyVarSig{} = + panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig" + +-- | Represent injectivity annotation of a type family +repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) + -> MetaM (Core (Maybe TH.InjectivityAnn)) +repInjectivityAnn Nothing = + coreNothing injAnnTyConName +repInjectivityAnn (Just (L _ (InjectivityAnn _ lhs rhs))) = + do { lhs' <- lookupBinder (unLoc lhs) + ; rhs1 <- mapM (lookupBinder . unLoc) rhs + ; rhs2 <- coreList nameTyConName rhs1 + ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2] + ; coreJust injAnnTyConName injAnn } + +repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)] +repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) + +repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec)) +repAssocTyFamDefaultD = repTyFamInstD + +------------------------- +-- represent fundeps +-- +repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep]) +repLFunDeps fds = repList funDepTyConName repLFunDep fds + +repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep) +repLFunDep (L _ (FunDep _ xs ys)) + = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs + ys' <- repList nameTyConName (lookupBinder . unLoc) ys + repFunDep xs' ys' + +-- Represent instance declarations +-- +repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) + = do { dec <- repTyFamInstD fi_decl + ; return (locA loc, dec) } +repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) + = do { dec <- repDataFamInstD fi_decl + ; return (locA loc, dec) } +repInstD (L loc (ClsInstD { cid_inst = cls_decl })) + = do { dec <- repClsInstD cls_decl + ; return (locA loc, dec) } + +repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec)) +repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_datafam_insts = adts + , cid_overlap_mode = overlap + }) + = addSimpleTyVarBinds FreshNamesOnly tvs $ + -- We must bring the type variables into scope, so their + -- occurrences don't fail, even though the binders don't + -- appear in the resulting data structure + -- + -- But we do NOT bring the binders of 'binds' into scope + -- because they are properly regarded as occurrences + -- For example, the method names should be bound to + -- the selector Ids, not to fresh names (#5410) + -- + do { cxt1 <- repLContext cxt + ; inst_ty1 <- repLTy inst_ty + -- See Note [Scoped type variables in quotes] + ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs binds + ; ats1 <- mapM (repTyFamInstD . unLoc) ats + ; adts1 <- mapM (repDataFamInstD . unLoc) adts + ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds) + ; rOver <- repOverlap (fmap unLoc overlap) + ; decls2 <- repInst rOver cxt1 inst_ty1 decls1 + ; wrapGenSyms ss decls2 } + where + (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty + +repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat + , deriv_type = ty })) + = do { dec <- repDerivStrategy strat $ \strat' -> + addSimpleTyVarBinds FreshNamesOnly tvs $ + do { cxt' <- repLContext cxt + ; inst_ty' <- repLTy inst_ty + ; repDeriv strat' cxt' inst_ty' } + ; return (locA loc, dec) } + where + (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) + +repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) +repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) + = do { eqn1 <- repTyFamEqn eqn + ; repTySynInst eqn1 } + +repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn)) +repTyFamEqn (FamEqn { feqn_tycon = tc_name + , feqn_bndrs = outer_bndrs + , feqn_pats = tys + , feqn_fixity = fixity + , feqn_rhs = rhs }) + = do { tc <- lookupLOcc tc_name -- See Note [Binders and occurrences] + ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs -> + do { tys1 <- case fixity of + Prefix -> repTyArgs (repNamedTyCon tc) tys + Infix -> do { (HsValArg _ t1: HsValArg _ t2: args) <- checkTys tys + ; t1' <- repLTy t1 + ; t2' <- repLTy t2 + ; repTyArgs (repTInfix t1' tc t2') args } + ; rhs1 <- repLTy rhs + ; repTySynEqn mb_exp_bndrs tys1 rhs1 } } + where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] + checkTys tys@(HsValArg _ _:HsValArg _ _:_) = return tys + checkTys _ = panic "repTyFamEqn:checkTys" + +repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type)) +repTyArgs f [] = f +repTyArgs f (HsValArg _ ty : as) = do { f' <- f + ; ty' <- repLTy ty + ; repTyArgs (repTapp f' ty') as } +repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f + ; ki' <- repLTy ki + ; repTyArgs (repTappKind f' ki') as } +repTyArgs f (HsArgPar _ : as) = repTyArgs f as + +repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) +repDataFamInstD (DataFamInstDecl { dfid_eqn = + FamEqn { feqn_tycon = tc_name + , feqn_bndrs = outer_bndrs + , feqn_pats = tys + , feqn_fixity = fixity + , feqn_rhs = defn }}) + = do { tc <- lookupLOcc tc_name -- See Note [Binders and occurrences] + ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs -> + do { tys1 <- case fixity of + Prefix -> repTyArgs (repNamedTyCon tc) tys + Infix -> do { (HsValArg _ t1: HsValArg _ t2: args) <- checkTys tys + ; t1' <- repLTy t1 + ; t2' <- repLTy t2 + ; repTyArgs (repTInfix t1' tc t2') args } + ; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } } + + where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] + checkTys tys@(HsValArg _ _: HsValArg _ _: _) = return tys + checkTys _ = panic "repDataFamInstD:checkTys" + +repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ + , fd_fi = CImport _ (L _ cc) + (L _ s) mch cis })) + = do MkC name' <- lookupLOcc name + MkC typ' <- repHsSigType typ + MkC cc' <- repCCallConv cc + MkC s' <- repSafety s + cis' <- conv_cimportspec cis + MkC str <- coreStringLit (mkFastString (static ++ chStr ++ cis')) + dec <- rep2 forImpDName [cc', s', str, name', typ'] + return (locA loc, dec) + where + conv_cimportspec (CLabel cls) + = notHandled (ThForeignLabel cls) + conv_cimportspec (CFunction DynamicTarget) = return "dynamic" + conv_cimportspec (CFunction (StaticTarget _ fs _ True)) + = return (unpackFS fs) + conv_cimportspec (CFunction (StaticTarget _ _ _ False)) + = panic "conv_cimportspec: values not supported yet" + conv_cimportspec CWrapper = return "wrapper" + -- these calling conventions do not support headers and the static keyword + raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv + static = case cis of + CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static " + _ -> "" + chStr = case mch of + Just (Header _ h) | not raw_cconv -> unpackFS h ++ " " + _ -> "" +repForD decl@(L _ ForeignExport{}) = notHandled (ThForeignExport decl) + +repCCallConv :: CCallConv -> MetaM (Core TH.Callconv) +repCCallConv CCallConv = rep2_nw cCallName [] +repCCallConv StdCallConv = rep2_nw stdCallName [] +repCCallConv CApiConv = rep2_nw cApiCallName [] +repCCallConv PrimCallConv = rep2_nw primCallName [] +repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName [] + +repSafety :: Safety -> MetaM (Core TH.Safety) +repSafety PlayRisky = rep2_nw unsafeName [] +repSafety PlayInterruptible = rep2_nw interruptibleName [] +repSafety PlaySafe = rep2_nw safeName [] + +repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +repLFixD (L loc fix_sig) = rep_fix_d (locA loc) fix_sig + +rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_fix_d loc (FixitySig ns_spec names (Fixity prec dir)) + = do { MkC prec' <- coreIntLit prec + ; let rep_fn = case dir of + InfixL -> infixLWithSpecDName + InfixR -> infixRWithSpecDName + InfixN -> infixNWithSpecDName + ; let do_one name + = do { MkC name' <- lookupLOcc name + ; MkC ns_spec' <- repNamespaceSpecifier ns_spec + ; dec <- rep2 rep_fn [prec', ns_spec', name'] + ; return (loc,dec) } + ; mapM do_one names } + +repDefD :: LDefaultDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repDefD (L loc (DefaultDecl _ _ tys)) = do { tys1 <- repLTys tys + ; MkC tys2 <- coreListM typeTyConName tys1 + ; dec <- rep2 defaultDName [tys2] + ; return (locA loc, dec)} + +repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repRuleD (L loc (HsRule { rd_name = n + , rd_act = act + , rd_bndrs = bndrs + , rd_lhs = lhs + , rd_rhs = rhs })) + = fmap (locA loc, ) <$> + repRuleBinders bndrs $ \ ty_bndrs' tm_bndrs' -> + do { n' <- coreStringLit $ unLoc n + ; act' <- repPhases act + ; lhs' <- repLE lhs + ; rhs' <- repLE rhs + ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' } + +repRuleBinders :: RuleBndrs GhcRn + -> (Core (Maybe [M (TH.TyVarBndr ())]) -> Core [M TH.RuleBndr] -> MetaM (Core (M a))) + -> MetaM (Core (M a)) +repRuleBinders (RuleBndrs { rb_tyvs = m_ty_bndrs, rb_tmvs = tm_bndrs }) thing_inside + = do { let ty_bndrs = fromMaybe [] m_ty_bndrs + ; addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs -> + do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs + ; ss <- mkGenSyms tm_bndr_names + ; x <- addBinds ss $ + do { elt_ty <- wrapName tyVarBndrUnitTyConName + ; ty_bndrs' <- return $ case m_ty_bndrs of + Nothing -> coreNothing' (mkListTy elt_ty) + Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs + ; tm_bndrs' <- repListM ruleBndrTyConName + repRuleBndr + tm_bndrs + ; thing_inside ty_bndrs' tm_bndrs' + } + ; wrapGenSyms ss x } + } + +ruleBndrNames :: LRuleBndr GhcRn -> [Name] +ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] +ruleBndrNames (L _ (RuleBndrSig _ n sig)) + | HsPS { hsps_ext = HsPSRn { hsps_imp_tvs = vars }} <- sig + = unLoc n : vars + +repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr)) +repRuleBndr (L _ (RuleBndr _ n)) + = do { MkC n' <- lookupNBinder n + ; rep2 ruleVarName [n'] } +repRuleBndr (L _ (RuleBndrSig _ n sig)) + = do { MkC n' <- lookupNBinder n + ; MkC ty' <- repLTy (hsPatSigType sig) + ; rep2 typedRuleVarName [n', ty'] } + +repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) + = do { target <- repAnnProv ann_prov + ; exp' <- repE exp + ; dec <- repPragAnn target exp' + ; return (locA loc, dec) } + +repAnnProv :: AnnProvenance GhcRn -> MetaM (Core TH.AnnTarget) +repAnnProv (ValueAnnProvenance n) + = do { -- An ANN references an identifier bound elsewhere in the module, so + -- we must look it up using lookupLOcc (#19377). + -- Similarly for TypeAnnProvenance (`ANN type`) below. + MkC n' <- lookupLOcc n + ; rep2_nw valueAnnotationName [ n' ] } +repAnnProv (TypeAnnProvenance n) + = do { MkC n' <- lookupLOcc n + ; rep2_nw typeAnnotationName [ n' ] } +repAnnProv ModuleAnnProvenance + = rep2_nw moduleAnnotationName [] + +------------------------------------------------------- +-- Constructors +------------------------------------------------------- + +repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con)) +repC (L _ (ConDeclH98 { con_name = con + , con_forall = False + , con_mb_cxt = Nothing + , con_args = args })) + = repH98DataCon con args + +repC (L _ (ConDeclH98 { con_name = con + , con_forall = is_existential + , con_ex_tvs = con_tvs + , con_mb_cxt = mcxt + , con_args = args })) + = addHsTyVarBinds FreshNamesOnly con_tvs $ \ ex_bndrs -> + do { c' <- repH98DataCon con args + ; ctxt' <- repMbContext mcxt + ; if not is_existential && isNothing mcxt + then return c' + else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) + } + +repC (L l (ConDeclGADT { con_names = cons + , con_outer_bndrs = L _ outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = mcxt + , con_g_args = args + , con_res_ty = res_ty })) + | no_explicit_forall, no_context + -- No explicit variables, no context ==> No need for a ForallC + -- See Note [Don't quantify implicit type variables in quotes] + = addSimpleTyVarBinds FreshNamesOnly (hsOuterTyVarNames outer_bndrs) $ + repGadtDataCons cons args res_ty + + | Just invis_inner_bndrs <- m_invis_inner_bndrs + = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' -> + -- the context is attached to the innermost ForallC + let loop last_bndrs' [] = do + ctxt' <- repMbContext mcxt + c' <- repGadtDataCons cons args res_ty + rep2 forallCName ([unC last_bndrs', unC ctxt', unC c']) + loop last_bndrs' (bndrs : bndrs_s) = + addHsTyVarBinds FreshNamesOnly bndrs $ \bndrs' -> do + body_c' <- loop bndrs' bndrs_s + ctxt' <- repContext [] + rep2 forallCName [unC last_bndrs', unC ctxt', unC body_c'] + in loop outer_bndrs' invis_inner_bndrs + + | Nothing <- m_invis_inner_bndrs + = notHandledL (locA l) ThDataConVisibleForall + + where + no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_bndrs + no_context = isNothing mcxt + + m_invis_inner_bndrs :: Maybe [[LHsTyVarBndr Specificity GhcRn]] + m_invis_inner_bndrs = traverse get_invis_bndrs inner_bndrs + + get_invis_bndrs :: HsForAllTelescope GhcRn -> Maybe [LHsTyVarBndr Specificity GhcRn] + get_invis_bndrs HsForAllVis{} = Nothing + get_invis_bndrs HsForAllInvis { hsf_invis_bndrs = tvbs } = Just tvbs + +repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) +repMbContext Nothing = repContext [] +repMbContext (Just (L _ cxt)) = repContext cxt + +repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness)) +repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] +repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName [] +repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName [] + +repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness)) +repSrcStrictness SrcLazy = rep2 sourceLazyName [] +repSrcStrictness SrcStrict = rep2 sourceStrictName [] +repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] + +repConDeclField :: HsConDeclField GhcRn -> MetaM (Core (M TH.BangType)) +repConDeclField (CDF { cdf_unpack, cdf_bang, cdf_type }) = do + MkC u <- repSrcUnpackedness cdf_unpack + MkC s <- repSrcStrictness cdf_bang + MkC b <- rep2 bangName [u, s] + MkC t <- repLTy cdf_type + rep2 bangTypeName [b, t] + +------------------------------------------------------- +-- Deriving clauses +------------------------------------------------------- + +repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause]) +repDerivs clauses + = repListM derivClauseTyConName repDerivClause clauses + +repDerivClause :: LHsDerivingClause GhcRn + -> MetaM (Core (M TH.DerivClause)) +repDerivClause (L _ (HsDerivingClause + { deriv_clause_strategy = dcs + , deriv_clause_tys = dct })) + = repDerivStrategy dcs $ \(MkC dcs') -> + do MkC dct' <- rep_deriv_clause_tys dct + rep2 derivClauseName [dcs',dct'] + where + rep_deriv_clause_tys :: LDerivClauseTys GhcRn -> MetaM (Core [M TH.Type]) + rep_deriv_clause_tys (L _ dct) = case dct of + DctSingle _ ty -> rep_deriv_tys [ty] + DctMulti _ tys -> rep_deriv_tys tys + + rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M TH.Type]) + rep_deriv_tys = repListM typeTyConName repHsSigType + +rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn + -> MetaM ([GenSymBind], [Core (M TH.Dec)]) +-- Represent signatures and methods in class/instance declarations. +-- See Note [Scoped type variables in quotes] +-- +-- Why not use 'repBinds': we have already created symbols for methods in +-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate +-- these fun_id via 'collectHsValBinders decs', which would lead to the +-- instance declarations failing in TH. +rep_meth_sigs_binds sigs binds + = do { let tvs = concatMap get_scoped_tvs sigs + ; ss <- mkGenSyms tvs + ; sigs1 <- addBinds ss $ rep_sigs sigs + ; binds1 <- addBinds ss $ rep_binds binds + ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) } + +------------------------------------------------------- +-- Signatures in a class decl, or a group of bindings +------------------------------------------------------- + +rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M TH.Dec))] + -- We silently ignore ones we don't recognise +rep_sigs = concatMapM rep_sig + +rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_sig (L loc (TypeSig _ nms ty)) + = mapM (rep_wc_ty_sig sigDName (locA loc) ty) nms +rep_sig (L loc (PatSynSig _ nms ty)) + = mapM (rep_patsyn_ty_sig (locA loc) ty) nms +rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) + | is_deflt = mapM (rep_ty_sig defaultSigDName (locA loc) ty) nms + | otherwise = mapM (rep_ty_sig sigDName (locA loc) ty) nms +rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d (locA loc) fix_sig +rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc) +rep_sig (L loc (SpecSig _ nm tys ispec)) + = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys +rep_sig (L loc (SpecSigE _nm bndrs expr ispec)) + = fmap (\ d -> [(locA loc, d)]) $ + rep_specialiseE bndrs expr ispec +rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc) +rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas +rep_sig (L loc (SCCFunSig _ nm str)) = rep_sccFun nm str (locA loc) +rep_sig (L loc (CompleteMatchSig _ cls mty)) + = rep_complete_sig cls mty (locA loc) +rep_sig d@(L _ (XSig {})) = pprPanic "rep_sig IdSig" (ppr d) + +-- Desugar the explicit type variable binders in an 'LHsSigType', making +-- sure not to gensym them. +-- See Note [Scoped type variables in quotes] +-- and Note [Don't quantify implicit type variables in quotes] +rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn] + -> MetaM (Core [M (TH.TyVarBndr TH.Specificity)]) +rep_ty_sig_tvs explicit_tvs + = repListM tyVarBndrSpecTyConName repTyVarBndr + explicit_tvs + +-- Desugar the outer type variable binders in an 'LHsSigType', making +-- sure not to gensym them. +-- See Note [Scoped type variables in quotes] +-- and Note [Don't quantify implicit type variables in quotes] +rep_ty_sig_outer_tvs :: HsOuterSigTyVarBndrs GhcRn + -> MetaM (Core [M (TH.TyVarBndr TH.Specificity)]) +rep_ty_sig_outer_tvs (HsOuterImplicit{}) = + coreListM tyVarBndrSpecTyConName [] +rep_ty_sig_outer_tvs (HsOuterExplicit{hso_bndrs = explicit_tvs}) = + rep_ty_sig_tvs explicit_tvs + +-- Desugar a top-level type signature. Unlike 'repHsSigType', this +-- deliberately avoids gensymming the type variables. +-- See Note [Scoped type variables in quotes] +-- and Note [Don't quantify implicit type variables in quotes] +rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> LocatedN Name + -> MetaM (SrcSpan, Core (M TH.Dec)) +rep_ty_sig mk_sig loc sig_ty nm + = do { nm1 <- lookupLOcc nm + ; ty1 <- rep_ty_sig' sig_ty + ; sig <- repProto mk_sig nm1 ty1 + ; return (loc, sig) } + +-- Desugar an 'LHsSigType', making sure not to gensym the type variables at +-- the front of the type signature. +-- See Note [Scoped type variables in quotes] +-- and Note [Don't quantify implicit type variables in quotes] +rep_ty_sig' :: LHsSigType GhcRn + -> MetaM (Core (M TH.Type)) +rep_ty_sig' (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) + | (ctxt, tau) <- splitLHsQualTy body + = do { th_explicit_tvs <- rep_ty_sig_outer_tvs outer_bndrs + ; th_ctxt <- repLContext ctxt + ; th_tau <- repLTy tau + ; if nullOuterExplicit outer_bndrs && null (fromMaybeContext ctxt) + then return th_tau + else repTForall th_explicit_tvs th_ctxt th_tau } + +rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> LocatedN Name + -> MetaM (SrcSpan, Core (M TH.Dec)) +-- represents a pattern synonym type signature; +-- see Note [Pattern synonym type signatures and Template Haskell] in "GHC.ThToHs" +-- +-- Don't create the implicit and explicit variables when desugaring signatures, +-- see Note [Scoped type variables in quotes] +-- and Note [Don't quantify implicit type variables in quotes] +rep_patsyn_ty_sig loc sig_ty nm + | (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy sig_ty + = do { nm1 <- lookupLOcc nm + ; th_univs <- rep_ty_sig_tvs univs + ; th_exis <- rep_ty_sig_tvs exis + + ; th_reqs <- repLContext reqs + ; th_provs <- repLContext provs + ; th_ty <- repLTy ty + ; ty1 <- repTForall th_univs th_reqs =<< + repTForall th_exis th_provs th_ty + ; sig <- repProto patSynSigDName nm1 ty1 + ; return (loc, sig) } + +rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> LocatedN Name + -> MetaM (SrcSpan, Core (M TH.Dec)) +rep_wc_ty_sig mk_sig loc sig_ty nm + = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm + +rep_inline :: LocatedN Name + -> InlinePragma -- Never defaultInlinePragma + -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_inline nm ispec loc + | Opaque {} <- inl_inline ispec + = do { nm1 <- lookupLOcc nm + ; opq <- repPragOpaque nm1 + ; return [(loc, opq)] + } + +rep_inline nm ispec loc + = do { nm1 <- lookupLOcc nm + ; inline <- repInline $ inl_inline ispec + ; rm <- repRuleMatch $ inl_rule ispec + ; phases <- repPhases $ inl_act ispec + ; pragma <- repPragInl nm1 inline rm phases + ; return [(loc, pragma)] + } + +rep_inline_phases :: InlinePragma -> MetaM (Maybe (Core TH.Inline), Core TH.Phases) +rep_inline_phases (InlinePragma { inl_act = act, inl_inline = inl }) + = do { phases <- repPhases act + ; inl <- if noUserInlineSpec inl + -- SPECIALISE + then return Nothing + -- SPECIALISE INLINE + else Just <$> repInline inl + ; return (inl, phases) } + +rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma + -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_specialise nm ty ispec loc + -- Old form SPECIALISE pragmas + = do { nm1 <- lookupLOcc nm + ; ty1 <- repHsSigType ty + ; (inl, phases) <- rep_inline_phases ispec + ; pragma <- repPragSpec nm1 ty1 inl phases + ; return [(loc, pragma)] + } + +rep_specialiseE :: RuleBndrs GhcRn -> LHsExpr GhcRn -> InlinePragma + -> MetaM (Core (M TH.Dec)) +rep_specialiseE bndrs e ispec + -- New form SPECIALISE pragmas + = repRuleBinders bndrs $ \ ty_bndrs tm_bndrs -> + do { (inl, phases) <- rep_inline_phases ispec + ; exp <- repLE e + ; repPragSpecE ty_bndrs tm_bndrs exp inl phases + } + +rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_specialiseInst ty loc + = do { ty1 <- repHsSigType ty + ; pragma <- repPragSpecInst ty1 + ; return [(loc, pragma)] } + +rep_sccFun :: LocatedN Name + -> Maybe (XRec GhcRn StringLiteral) + -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_sccFun nm Nothing loc = do + nm1 <- lookupLOcc nm + scc <- repPragSCCFun nm1 + return [(loc, scc)] + +rep_sccFun nm (Just (L _ str)) loc = do + nm1 <- lookupLOcc nm + str1 <- coreStringLit (sl_fs str) + scc <- repPragSCCFunNamed nm1 str1 + return [(loc, scc)] + +repInline :: InlineSpec -> MetaM (Core TH.Inline) +repInline (NoInline _ ) = dataCon noInlineDataConName +-- There is a mismatch between the TH and GHC representation because +-- OPAQUE pragmas can't have phase activation annotations (which is +-- enforced by the TH API), therefore they are desugared to OpaqueP rather than +-- InlineP, see special case in rep_inline. +repInline (Opaque _ ) = panic "repInline: Opaque" +repInline (Inline _ ) = dataCon inlineDataConName +repInline (Inlinable _ ) = dataCon inlinableDataConName +repInline NoUserInlinePrag = notHandled ThNoUserInline + +repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch) +repRuleMatch ConLike = dataCon conLikeDataConName +repRuleMatch FunLike = dataCon funLikeDataConName + +repPhases :: Activation -> MetaM (Core TH.Phases) +repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i + ; dataCon' beforePhaseDataConName [arg] } +repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i + ; dataCon' fromPhaseDataConName [arg] } +repPhases _ = dataCon allPhasesDataConName + +rep_complete_sig :: [LocatedN Name] + -> Maybe (LocatedN Name) + -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_complete_sig cls mty loc + = do { mty' <- repMaybe nameTyConName lookupLOcc mty + ; cls' <- repList nameTyConName lookupLOcc cls + ; sig <- repPragComplete cls' mty' + ; return [(loc, sig)] } + +------------------------------------------------------- +-- Types +------------------------------------------------------- + +class RepTV flag flag' | flag -> flag' where + tyVarBndrName :: Name + repPlainTV :: Core TH.Name -> flag -> MetaM (Core (M (TH.TyVarBndr flag'))) + repKindedTV :: Core TH.Name -> flag -> Core (M TH.Kind) + -> MetaM (Core (M (TH.TyVarBndr flag'))) + +instance RepTV () () where + tyVarBndrName = tyVarBndrUnitTyConName + repPlainTV (MkC nm) () = rep2 plainTVName [nm] + repKindedTV (MkC nm) () (MkC ki) = rep2 kindedTVName [nm, ki] + +instance RepTV Specificity TH.Specificity where + tyVarBndrName = tyVarBndrSpecTyConName + repPlainTV (MkC nm) spec = do { (MkC spec') <- rep_flag spec + ; rep2 plainInvisTVName [nm, spec'] } + repKindedTV (MkC nm) spec (MkC ki) = do { (MkC spec') <- rep_flag spec + ; rep2 kindedInvisTVName [nm, spec', ki] } + +rep_flag :: Specificity -> MetaM (Core TH.Specificity) +rep_flag SpecifiedSpec = rep2_nw specifiedSpecName [] +rep_flag InferredSpec = rep2_nw inferredSpecName [] + +instance RepTV (HsBndrVis GhcRn) TH.BndrVis where + tyVarBndrName = tyVarBndrVisTyConName + repPlainTV (MkC nm) vis = do { (MkC vis') <- rep_bndr_vis vis + ; rep2 plainBndrTVName [nm, vis'] } + repKindedTV (MkC nm) vis (MkC ki) = do { (MkC vis') <- rep_bndr_vis vis + ; rep2 kindedBndrTVName [nm, vis', ki] } + +rep_bndr_vis :: HsBndrVis GhcRn -> MetaM (Core TH.BndrVis) +rep_bndr_vis (HsBndrRequired _) = rep2_nw bndrReqName [] +rep_bndr_vis (HsBndrInvisible _) = rep2_nw bndrInvisName [] + +addHsOuterFamEqnTyVarBinds :: + HsOuterFamEqnTyVarBndrs GhcRn + -> (Core (Maybe [M (TH.TyVarBndr ())]) -> MetaM (Core (M a))) + -> MetaM (Core (M a)) +addHsOuterFamEqnTyVarBinds outer_bndrs thing_inside = do + elt_ty <- wrapName tyVarBndrUnitTyConName + case outer_bndrs of + HsOuterImplicit{hso_ximplicit = imp_tvs} -> + addSimpleTyVarBinds ReuseBoundNames imp_tvs $ + thing_inside $ coreNothingList elt_ty + HsOuterExplicit{hso_bndrs = exp_bndrs} -> + addHsTyVarBinds FreshNamesOnly exp_bndrs $ \th_exp_bndrs -> + thing_inside $ coreJustList elt_ty th_exp_bndrs + +addHsOuterSigTyVarBinds :: + HsOuterSigTyVarBndrs GhcRn + -> (Core [M (TH.TyVarBndr TH.Specificity)] -> MetaM (Core (M a))) + -> MetaM (Core (M a)) +addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of + HsOuterImplicit{hso_ximplicit = imp_tvs} -> + do th_nil <- coreListM tyVarBndrSpecTyConName [] + addSimpleTyVarBinds FreshNamesOnly imp_tvs $ thing_inside th_nil + HsOuterExplicit{hso_bndrs = exp_bndrs} -> + addHsTyVarBinds FreshNamesOnly exp_bndrs thing_inside + +-- | If a type explicitly quantifies its outermost type variables, return +-- 'True' if the list of explicitly bound type variables is empty. If a type +-- implicitly quantifies its outermost type variables, always return 'True'. +-- +-- This is used in various places to determine if a Template Haskell 'Type' +-- should be headed by a 'ForallT' or not. +nullOuterExplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool +nullOuterExplicit (HsOuterExplicit{hso_bndrs = exp_bndrs}) = null exp_bndrs +nullOuterExplicit (HsOuterImplicit{}) = True + -- Vacuously true, as there is no outermost explicit quantification + +-- Do we want to generate fresh names for type variables +-- or reuse the ones that are already in scope? +data FreshOrReuse + = FreshNamesOnly + -- Generate fresh names for all type variables, regardless of existing + -- variables in the MetaEnv. + -- + -- This is the default strategy. + + | ReuseBoundNames + -- Generate fresh names for type variables not in the MetaEnv. + -- Where a name is already bound in the MetaEnv, use that existing binding; + -- do not create a new one with a fresh name. + -- + -- This is the strategy used for data/newtype declarations and type family + -- instances, so that the nested type variables work right: + -- + -- class C a where + -- type W a b + -- instance C (T a) where + -- type W (T a) b = blah + -- + -- The 'a' in the type instance is the one bound by the instance decl + -- + -- Test cases: TH_reifyExplicitForAllFams T9081 T9199 T10811 + +mkGenSyms' :: FreshOrReuse -> [Name] -> MetaM [GenSymBind] +mkGenSyms' FreshNamesOnly names = mkGenSyms names +mkGenSyms' ReuseBoundNames names = + -- Make fresh names for the ones that are not already in scope + -- This makes things work for associated types + do { env <- lift dsGetMetaEnv + ; mkGenSyms (filterOut (`elemNameEnv` env) names) } + +addSimpleTyVarBinds :: FreshOrReuse + -> [Name] -- the binders to be added + -> MetaM (Core (M a)) -- action in the ext env + -> MetaM (Core (M a)) +addSimpleTyVarBinds fresh_or_reuse names thing_inside + = do { fresh_names <- mkGenSyms' fresh_or_reuse names + ; term <- addBinds fresh_names thing_inside + ; wrapGenSyms fresh_names term } + +addHsTyVarBinds :: forall flag flag' a. RepTV flag flag' + => FreshOrReuse + -> [LHsTyVarBndr flag GhcRn] -- the binders to be added + -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env + -> MetaM (Core (M a)) +addHsTyVarBinds fresh_or_reuse exp_tvs thing_inside + = do { fresh_exp_names <- mkGenSyms' fresh_or_reuse (hsLTyVarNames exp_tvs) + ; term <- addBinds fresh_exp_names $ + do { kbs <- repListM (tyVarBndrName @flag @flag') repTyVarBndr + exp_tvs + ; thing_inside kbs } + ; wrapGenSyms fresh_exp_names term } + +addQTyVarBinds :: FreshOrReuse + -> LHsQTyVars GhcRn -- the binders to be added + -> (Core [(M (TH.TyVarBndr TH.BndrVis))] -> MetaM (Core (M a))) -- action in the ext env + -> MetaM (Core (M a)) +addQTyVarBinds fresh_or_reuse qtvs thing_inside = + let HsQTvs { hsq_ext = imp_tvs + , hsq_explicit = exp_tvs } + = qtvs + in addTyVarBinds fresh_or_reuse exp_tvs imp_tvs thing_inside + +addTyVarBinds :: RepTV flag flag' + => FreshOrReuse + -> [LHsTyVarBndr flag GhcRn] -- the binders to be added + -> [Name] + -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env + -> MetaM (Core (M a)) +-- gensym a list of type variables and enter them into the meta environment; +-- the computations passed as the second argument is executed in that extended +-- meta environment and gets the *new* names on Core-level as an argument +addTyVarBinds fresh_or_reuse exp_tvs imp_tvs thing_inside + = addSimpleTyVarBinds fresh_or_reuse imp_tvs $ + addHsTyVarBinds fresh_or_reuse exp_tvs $ + thing_inside + +-- | Represent a type variable binder +repTyVarBndr :: RepTV flag flag' + => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag'))) +repTyVarBndr (L _ (HsTvb _ fl bvar bkind)) = do + nm' <- repHsBndrVar bvar + case bkind of + HsBndrNoKind _ -> + repPlainTV nm' fl + HsBndrKind _ ki -> do + ki' <- repLTy ki + repKindedTV nm' fl ki' + +repHsBndrVar :: HsBndrVar GhcRn -> MetaM (Core TH.Name) +repHsBndrVar (HsBndrVar _ (L _ nm)) = + lookupBinder nm +repHsBndrVar (HsBndrWildCard _) = do + u <- lift newUnique + lift $ globalVarLocal u (mkTyVarOcc "_") + +-- represent a type context +-- +repLContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) +repLContext Nothing = repContext [] +repLContext (Just ctxt) = repContext (unLoc ctxt) + +repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt)) +repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt + repCtxt preds + +repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type)) +repHsSigType (L _ (HsSig { sig_bndrs = outer_bndrs, sig_body = body })) + | (ctxt, tau) <- splitLHsQualTy body + = addHsOuterSigTyVarBinds outer_bndrs $ \ th_outer_bndrs -> + do { th_ctxt <- repLContext ctxt + ; th_tau <- repLTy tau + ; if nullOuterExplicit outer_bndrs && null (fromMaybeContext ctxt) + then pure th_tau + else repTForall th_outer_bndrs th_ctxt th_tau } + +-- yield the representation of a list of types +repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)] +repLTys tys = mapM repLTy tys + +-- represent a type +repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type)) +repLTy ty = repTy (unLoc ty) + +-- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or +-- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax. +-- In other words, the argument to this function is always an +-- @HsForAllTy HsForAllInvis{}@ or @HsQualTy@. +-- Types headed by visible foralls (which are desugared to ForallVisT) are +-- handled separately in repTy. +repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type)) +repForallT ty + | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLocA ty) + = addHsTyVarBinds FreshNamesOnly tvs $ \bndrs -> + do { ctxt1 <- repLContext ctxt + ; tau1 <- repLTy tau + ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...} + } + +repTy :: HsType GhcRn -> MetaM (Core (M TH.Type)) +repTy ty@(HsForAllTy { hst_tele = tele, hst_body = body }) = + case tele of + HsForAllInvis{} -> repForallT ty + HsForAllVis { hsf_vis_bndrs = tvs } -> + addHsTyVarBinds FreshNamesOnly tvs $ \bndrs -> + do body1 <- repLTy body + repTForallVis bndrs body1 +repTy ty@(HsQualTy {}) = repForallT ty + +repTy (HsTyVar _ _ (L _ (WithUserRdr _ n))) + | n `hasKey` liftedTypeKindTyConKey = repTStar + | n `hasKey` constraintKindTyConKey = repTConstraint + | n `hasKey` unrestrictedFunTyConKey = repArrowTyCon + | n `hasKey` fUNTyConKey = repMulArrowTyCon + | n `hasKey` eqTyConKey = repTequality + | isVarNameSpace ns = do tv1 <- lookupOcc n + repTvar tv1 + | isDataConNameSpace ns = do dc1 <- lookupOcc n + repPromotedDataCon dc1 + | isTcClsNameSpace ns = do tc1 <- lookupOcc n + repNamedTyCon tc1 + | otherwise = panic "repTy: HsTyVar: unknown namespace" + where + occ = nameOccName n + ns = occNameSpace occ + +repTy (HsAppTy _ f a) = do + f1 <- repLTy f + a1 <- repLTy a + repTapp f1 a1 +repTy (HsAppKindTy _ ty ki) = do + ty1 <- repLTy ty + ki1 <- repLTy ki + repTappKind ty1 ki1 +repTy (HsFunTy _ w f a) = do + f1 <- repLTy f + a1 <- repLTy a + case multAnnToHsType w of + Nothing -> do + tcon <- repArrowTyCon + repTapps tcon [f1, a1] + Just m -> do + w1 <- repLTy m + tcon <- repMulArrowTyCon + repTapps tcon [w1, f1, a1] +repTy (HsListTy _ t) = do + t1 <- repLTy t + tcon <- repListTyCon + repTapp tcon t1 +repTy (HsTupleTy _ HsUnboxedTuple tys) = do + tys1 <- repLTys tys + tcon <- repUnboxedTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys + tcon <- repTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsSumTy _ tys) = do tys1 <- repLTys tys + tcon <- repUnboxedSumTyCon (length tys) + repTapps tcon tys1 +repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (getName n) `nlHsAppTy` ty1) + `nlHsAppTy` ty2) +repTy (HsParTy _ t) = repLTy t +repTy (HsStarTy _ _) = repTStar +repTy (HsKindSig _ t k) = do + t1 <- repLTy t + k1 <- repLTy k + repTSig t1 k1 +repTy (HsSpliceTy (HsUntypedSpliceNested n) _) = rep_splice n +repTy t@(HsSpliceTy (HsUntypedSpliceTop _ _) _) = pprPanic "repTy: top level splice" (ppr t) +repTy (HsExplicitListTy _ _ tys) = do + tys1 <- repLTys tys + repTPromotedList tys1 +repTy (HsExplicitTupleTy _ _ tys) = do + tys1 <- repLTys tys + tcon <- repPromotedTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsTyLit _ lit) = do + lit' <- repTyLit lit + repTLit lit' +repTy (HsWildCardTy _) = repTWildCard +repTy (HsIParamTy _ n t) = do + n' <- rep_implicit_param_name (unLoc n) + t' <- repLTy t + repTImplicitParam n' t' + +repTy ty = notHandled (ThExoticFormOfType ty) + +repTyLit :: HsTyLit (GhcPass p) -> MetaM (Core (M TH.TyLit)) +repTyLit (HsNumTy _ i) = do + platform <- getPlatform + rep2 numTyLitName [mkIntegerExpr platform i] +repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s + ; rep2 strTyLitName [s'] + } +repTyLit (HsCharTy _ c) = do { c' <- return (mkCharExpr c) + ; rep2 charTyLitName [c'] + } + +-- | Represent a type wrapped in a Maybe +repMaybeLTy :: Maybe (LHsKind GhcRn) + -> MetaM (Core (Maybe (M TH.Type))) +repMaybeLTy m = do + k_ty <- wrapName kindTyConName + repMaybeT k_ty repLTy m + +repRole :: LocatedAn NoEpAnns (Maybe Role) -> MetaM (Core TH.Role) +repRole (L _ (Just Nominal)) = rep2_nw nominalRName [] +repRole (L _ (Just Representational)) = rep2_nw representationalRName [] +repRole (L _ (Just Phantom)) = rep2_nw phantomRName [] +repRole (L _ Nothing) = rep2_nw inferRName [] + +----------------------------------------------------------------------------- +-- Splices +----------------------------------------------------------------------------- + +-- See Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice +-- We return a CoreExpr of any old type; the context should know + +rep_splice :: Name -> MetaM (Core a) +rep_splice splice_name + = do { mb_val <- lift $ dsLookupMetaEnv splice_name + ; case mb_val of + Just (DsSplice e) -> do { e' <- lift $ dsExpr e + ; return (MkC e') } + _ -> pprPanic "HsSplice" (ppr splice_name) } + -- Should not happen; statically checked + +----------------------------------------------------------------------------- +-- Expressions +----------------------------------------------------------------------------- + +repLEs :: [LHsExpr GhcRn] -> MetaM (Core [(M TH.Exp)]) +repLEs es = repListM expTyConName repLE es + +-- FIXME: some of these panics should be converted into proper error messages +-- unless we can make sure that constructs, which are plainly not +-- supported in TH already lead to error messages at an earlier stage +repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp)) +repLE (L loc e) = mapReaderT (putSrcSpanDs (locA loc)) (repE e) + +repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp)) +repE (HsVar _ (L _ (WithUserRdr _ x))) = + do { mb_val <- lift $ dsLookupMetaEnv x + ; case mb_val of + Nothing -> do { str <- lift $ globalVar x + ; repVarOrCon x str } + Just (DsBound y) -> repVarOrCon x (coreVar y) + Just (DsSplice e) -> do { e' <- lift $ dsExpr e + ; return (MkC e') } } +repE (HsHole (HoleVar (L _ uv))) = do + name <- repRdrName uv + repUnboundVar name +repE (HsHole HoleError) = panic "repE: HoleError" +repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar +repE (HsOverLabel _ s) = repOverLabel s + + + -- Remember, we're desugaring renamer output here, so + -- HsOverlit can definitely occur +repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } +repE (HsLit _ l) = do { a <- repLiteral l; repLit a } +repE (HsLam _ LamSingle (MG { mg_alts = L _ [m] })) = repLambda m +repE e@(HsLam _ LamSingle (MG { mg_alts = L _ _ })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e) +repE (HsLam _ LamCase (MG { mg_alts = L _ ms })) + = do { ms' <- mapM repMatchTup ms + ; core_ms <- coreListM matchTyConName ms' + ; repLamCase core_ms } +repE (HsLam _ LamCases (MG { mg_alts = (L _ ms) })) + = do { ms' <- mapM repClauseTup ms + ; core_ms <- coreListM matchTyConName ms' + ; repLamCases core_ms } +repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} +repE (HsAppType _ e t) = do { a <- repLE e + ; s <- repLTy (hswc_body t) + ; repAppType a s } + +repE (OpApp _ e1 op e2) = + do { arg1 <- repLE e1; + arg2 <- repLE e2; + the_op <- repLE op ; + repInfixApp arg1 the_op arg2 } +repE (NegApp _ x _) = do + a <- repLE x + negateVar <- lookupOcc negateName >>= repVar + negateVar `repApp` a +repE (HsPar _ x) = repLE x +repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } +repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } +repE (HsCase _ e (MG { mg_alts = (L _ ms) })) + = do { arg <- repLE e + ; ms2 <- mapM repMatchTup ms + ; core_ms2 <- coreListM matchTyConName ms2 + ; repCaseE arg core_ms2 } +repE (HsIf _ x y z) = do + a <- repLE x + b <- repLE y + c <- repLE z + repCond a b c +repE (HsMultiIf _ alts) + = do { (binds, alts') <- NE.unzip <$> mapM repLGRHS alts + ; expr' <- repMultiIf (nonEmptyCoreList' alts') + ; wrapGenSyms (concat binds) expr' } +repE (HsLet _ bs e) = do { (ss,ds) <- repBinds bs + ; e2 <- addBinds ss (repLE e) + ; z <- repLetE ds e2 + ; wrapGenSyms ss z } + +-- FIXME: I haven't got the types here right yet +repE e@(HsDo _ ctxt (L _ sts)) + | Just maybeModuleName <- case ctxt of + { DoExpr m -> Just m; GhciStmtCtxt -> Just Nothing; _ -> Nothing } + = do { (ss,zs) <- repLSts sts; + e' <- repDoE maybeModuleName (nonEmptyCoreList zs); + wrapGenSyms ss e' } + + | ListComp <- ctxt + = do { (ss,zs) <- repLSts sts; + e' <- repComp (nonEmptyCoreList zs); + wrapGenSyms ss e' } + + | MDoExpr maybeModuleName <- ctxt + = do { (ss,zs) <- repLSts sts; + e' <- repMDoE maybeModuleName (nonEmptyCoreList zs); + wrapGenSyms ss e' } + + | otherwise + = notHandled (ThMonadComprehensionSyntax e) + +repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } +repE (ExplicitTuple _ es boxity) = + let tupArgToCoreExp :: HsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp))) + tupArgToCoreExp a + | (Present _ e) <- a = do { e' <- repLE e + ; coreJustM expTyConName e' } + | otherwise = coreNothingM expTyConName + + in do { args <- mapM tupArgToCoreExp es + ; expTy <- wrapName expTyConName + ; let maybeExpQTy = mkTyConApp maybeTyCon [expTy] + listArg = coreList' maybeExpQTy args + ; if isBoxed boxity + then repTup listArg + else repUnboxedTup listArg } + +repE (ExplicitSum _ alt arity e) + = do { e1 <- repLE e + ; repUnboxedSum e1 alt arity } + +repE (RecordCon { rcon_con = c, rcon_flds = flds }) + = do { x <- lookupWithUserRdrLOcc c; + fs <- repFields flds; + repRecCon x fs } +repE (RecordUpd { rupd_expr = e, rupd_flds = RegularRecUpdFields { recUpdFields = flds } }) + = do { x <- repLE e; + fs <- repUpdFields flds; + repRecUpd x fs } +repE e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {} }) + = do + -- Not possible due to elimination in the renamer. See Note + -- [Handling overloaded and rebindable constructs] + pprPanic "repE: unexpected overloaded record update" $ ppr e + +repE (ExprWithTySig _ e wc_ty) + = addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig sig_ty) $ + do { e1 <- repLE e + ; t1 <- rep_ty_sig' sig_ty + ; repSigExp e1 t1 } + where + sig_ty = dropWildCards wc_ty + +repE (ArithSeq _ _ aseq) = + case aseq of + From e -> do { ds1 <- repLE e; repFrom ds1 } + FromThen e1 e2 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + repFromThen ds1 ds2 + FromTo e1 e2 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + repFromTo ds1 ds2 + FromThenTo e1 e2 e3 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + ds3 <- repLE e3 + repFromThenTo ds1 ds2 ds3 + +repE (HsTypedSplice (HsTypedSpliceNested n) _) = rep_splice n +repE (HsUntypedSplice (HsUntypedSpliceNested n) _) = rep_splice n +repE e@(HsUntypedSplice (HsUntypedSpliceTop _ _) _) = pprPanic "repE: top level splice" (ppr e) +repE e@(HsTypedSplice HsTypedSpliceTop _) = pprPanic "repE: top level splice" (ppr e) +repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC +repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do + e1 <- repLE e + repGetField e1 f +repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel) xs) +repE (HsEmbTy _ t) = do + t1 <- repLTy (hswc_body t) + rep2 typeEName [unC t1] +repE (HsQual _ (L _ ctx) body) = do + ctx' <- repLEs ctx + body' <- repLE body + rep2 constrainedEName [unC ctx', unC body'] +repE (HsForAll _ tele body) = + case tele of + HsForAllVis _ tvs -> mk_forall forallVisEName tvs + HsForAllInvis _ tvs -> mk_forall forallEName tvs + where + mk_forall :: RepTV flag flag' => Name -> [LHsTyVarBndr flag GhcRn] -> MetaM (Core (M TH.Exp)) + mk_forall forall_name tvs = + addHsTyVarBinds FreshNamesOnly tvs $ \bndrs -> do + body' <- repLE body + rep2 forall_name [unC bndrs, unC body'] +repE (HsFunArr _ mult arg res) = do + fun <- repFunArrMult mult + arg' <- repLE arg + res' <- repLE res + repApps fun [arg', res'] +repE e@(XExpr (ExpandedThingRn o x)) + | OrigExpr e <- o + = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax + ; if rebindable_on -- See Note [Quotation and rebindable syntax] + then repE x + else repE e } + | otherwise + = notHandled (ThExpressionForm e) + +repE (XExpr (PopErrCtxt (L _ e))) = repE e +repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (mkHsVar (noLocA x)) + +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) + +repFunArrMult :: HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn -> MetaM (Core (M TH.Exp)) +repFunArrMult mult = case multAnnToHsExpr mult of + Nothing -> repConName unrestrictedFunTyConName + Just e -> do { fun <- repConName fUNTyConName + ; mult' <- repLE e + ; repApp fun mult' } + +repConName :: Name -> MetaM (Core (M TH.Exp)) +repConName n = do + core_name <- lift $ globalVar n + repCon core_name + +{- Note [Quotation and rebindable syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = [| (* 3) |] + +Because of Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr, +the renamer will expand (* 3) to (rightSection (*) 3), regardless of RebindableSyntax. +Then, concerning the TH quotation, + +* If RebindableSyntax is off, we want the TH quote to generate the section (* 3), + as the user originally wrote. + +* If RebindableSyntax is on, we perhaps want the TH quote to generate + (rightSection (*) 3), using whatever 'rightSection' is in scope, because + (a) RebindableSyntax might not be on in the splicing context + (b) Even if it is, 'rightSection' might not be in scope + (c) At least in the case of Typed Template Haskell we should never get + a type error from the splice. + +We consult the module-wide RebindableSyntax flag here. We could instead record +the choice in ExpandedThingRn, but it seems simpler to consult the flag (again). +-} + +----------------------------------------------------------------------------- +-- Building representations of auxiliary structures like Match, Clause, Stmt, + +repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match)) +repMatchTup (L _ (Match { m_pats = L _ [p] + , m_grhss = GRHSs _ guards wheres })) = + do { ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p) + ; addBinds ss1 $ do { + ; p1 <- repLP p + ; (ss2,ds) <- repBinds wheres + ; addBinds ss2 $ do { + ; gs <- repGuards guards + ; match <- repMatch p1 gs ds + ; wrapGenSyms (ss1++ss2) match }}} +repMatchTup _ = panic "repMatchTup: case alt with more than one arg or with invisible pattern" + +repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause)) +repClauseTup (L _ (Match { m_pats = L _ ps + , m_grhss = GRHSs _ guards wheres })) = + do { ss1 <- mkGenSyms (collectPatsBinders CollNoDictBinders ps) + ; addBinds ss1 $ do { + ps1 <- repLPs ps + ; (ss2,ds) <- repBinds wheres + ; addBinds ss2 $ do { + gs <- repGuards guards + ; clause <- repClause ps1 gs ds + ; wrapGenSyms (ss1++ss2) clause }}} + +repGuards :: NonEmpty (LGRHS GhcRn (LHsExpr GhcRn)) -> MetaM (Core (M TH.Body)) +repGuards (L _ (GRHS _ [] e) :| []) + = do {a <- repLE e; repNormal a } +repGuards other + = do { zs <- mapM repLGRHS other + ; let (xs, ys) = NE.unzip zs + ; gd <- repGuarded (nonEmptyCoreList' ys) + ; wrapGenSyms (concat xs) gd } + +repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) + -> MetaM ([GenSymBind], (Core (M (TH.Guard, TH.Exp)))) +repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2)) + = do { guarded <- repLNormalGE e1 e2 + ; return ([], guarded) } +repLGRHS (L _ (GRHS _ ss rhs)) + = do { (gs, ss') <- repLSts ss + ; rhs' <- addBinds gs $ repLE rhs + ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' + ; return (gs, guarded) } + +repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp]) +repFields (HsRecFields { rec_flds = flds }) + = repListM fieldExpTyConName rep_fld flds + where + rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) + -> MetaM (Core (M TH.FieldExp)) + rep_fld (L _ fld) = do { fn <- lookupOcc (hsRecFieldSel fld) + ; e <- repLE (hfbRHS fld) + ; repFieldExp fn e } + +repUpdFields :: [LHsRecUpdField GhcRn GhcRn] -> MetaM (Core [M TH.FieldExp]) +repUpdFields = repListM fieldExpTyConName rep_fld + where + rep_fld :: LHsRecUpdField GhcRn GhcRn -> MetaM (Core (M TH.FieldExp)) + rep_fld (L l fld) = + let (FieldOcc _ (L _ sel_name)) = unLoc (hfbLHS fld) + -- If we have an unbountName in the sel_name, that means we failed to + -- disambiguate during the Rename stage of Ghc. Now if we continued + -- onwards to type checking that might be fine, as explained in + -- Note [Ambiguous FieldOcc in record updates], but if instead we + -- are within the context of Template Haskell, we just fail immediately. + in if isUnboundName sel_name + then notHandled (ThAmbiguousRecordUpdates fld) + else do { fn <- lookupLOcc (L l sel_name) + ; e <- repLE (hfbRHS fld) + ; repFieldExp fn e + } + + + +----------------------------------------------------------------------------- +-- Representing Stmt's is tricky, especially if bound variables +-- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] +-- First gensym new names for every variable in any of the patterns. +-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) +-- if variables didn't shadow, the static gensym wouldn't be necessary +-- and we could reuse the original names (x and x). +-- +-- do { x'1 <- gensym "x" +-- ; x'2 <- gensym "x" +-- ; doE Nothing +-- [ BindSt (pvar x'1) [| f 1 |] +-- , BindSt (pvar x'2) [| f x |] +-- , NoBindSt [| g x |] +-- ] +-- } + +-- The strategy is to translate a whole list of do-bindings by building a +-- bigger environment, and a bigger set of meta bindings +-- (like: x'1 <- gensym "x" ) and then combining these with the translations +-- of the expressions within the Do + +----------------------------------------------------------------------------- +-- The helper function repSts computes the translation of each sub expression +-- and a bunch of prefix bindings denoting the dynamic renaming. + +repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) +repLSts stmts = repSts (map unLoc stmts) + +repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) +repSts (BindStmt _ p e : ss) = + do { e2 <- repLE e + ; ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p) + ; addBinds ss1 $ do { + ; p1 <- repLP p; + ; (ss2,zs) <- repSts ss + ; z <- repBindSt p1 e2 + ; return (ss1++ss2, z : zs) }} +repSts (LetStmt _ bs : ss) = + do { (ss1,ds) <- repBinds bs + ; z <- repLetSt ds + ; (ss2,zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } +repSts (BodyStmt _ e _ _ : ss) = + do { e2 <- repLE e + ; z <- repNoBindSt e2 + ; (ss2,zs) <- repSts ss + ; return (ss2, z : zs) } +repSts (ParStmt _ stmt_blocks _ _ : ss) = + do { (ss_s, stmt_blocks1) <- unzip <$> traverse rep_stmt_block stmt_blocks + ; let stmt_blocks2 = nonEmptyCoreList' stmt_blocks1 + ss1 = concat ss_s + ; z <- repParSt stmt_blocks2 + ; (ss2, zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } + where + rep_stmt_block :: ParStmtBlock GhcRn GhcRn + -> MetaM ([GenSymBind], Core [(M TH.Stmt)]) + rep_stmt_block (ParStmtBlock _ stmts _ _) = + do { (ss1, zs) <- repSts (map unLoc stmts) + ; zs1 <- coreListM stmtTyConName zs + ; return (ss1, zs1) } +repSts [LastStmt _ e _ _] + = do { e2 <- repLE e + ; z <- repNoBindSt e2 + ; return ([], [z]) } +repSts (stmt@RecStmt{} : ss) + = do { let binders = collectLStmtsBinders CollNoDictBinders (unLoc $ recS_stmts stmt) + ; ss1 <- mkGenSyms binders + -- Bring all of binders in the recursive group into scope for the + -- whole group. + ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (unLoc $ recS_stmts stmt)) + ; massert (sort ss1 == sort ss1_other) + ; z <- repRecSt (nonEmptyCoreList rss) + ; (ss2,zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } +repSts [] = return ([],[]) +repSts other = notHandled (ThExoticStatement other) + + +----------------------------------------------------------- +-- Bindings +----------------------------------------------------------- + +repBinds :: HsLocalBinds GhcRn -> MetaM ([GenSymBind], Core [(M TH.Dec)]) +repBinds (EmptyLocalBinds _) + = do { core_list <- coreListM decTyConName [] + ; return ([], core_list) } + +repBinds (HsIPBinds _ (IPBinds _ decs)) + = do { ips <- mapM rep_implicit_param_bind decs + ; core_list <- coreListM decTyConName + (de_loc (sort_by_loc ips)) + ; return ([], core_list) + } + +repBinds (HsValBinds _ decs) + = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders CollNoDictBinders decs } + -- No need to worry about detailed scopes within + -- the binding group, because we are talking Names + -- here, so we can safely treat it as a mutually + -- recursive group + -- For hsScopedTvBinders see Note [Scoped type variables in quotes] + ; ss <- mkGenSyms bndrs + ; prs <- addBinds ss (rep_val_binds decs) + ; core_list <- coreListM decTyConName + (de_loc (sort_by_loc prs)) + ; return (ss, core_list) } + +rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +rep_implicit_param_bind (L loc (IPBind _ (L _ n) (L _ rhs))) + = do { name <- rep_implicit_param_name n + ; rhs' <- repE rhs + ; ipb <- repImplicitParamBind name rhs' + ; return (locA loc, ipb) } + +rep_implicit_param_name :: HsIPName -> MetaM (Core String) +rep_implicit_param_name (HsIPName name) = coreStringLit name + +rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +-- Assumes: all the binders of the binding are already in the meta-env +rep_val_binds (XValBindsLR (NValBinds binds sigs)) + = do { core1 <- rep_binds (concatMap snd binds) + ; core2 <- rep_sigs sigs + ; return (core1 ++ core2) } +rep_val_binds (ValBinds _ _ _) + = panic "rep_val_binds: ValBinds" + +rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_binds = mapM rep_bind + +rep_bind :: LHsBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +-- Assumes: all the binders of the binding are already in the meta-env + +-- Note GHC treats declarations of a variable (not a pattern) +-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match +-- with an empty list of patterns +rep_bind (L loc (FunBind + { fun_id = fn, + fun_matches = MG { mg_alts + = (L _ [L _ (Match + { m_pats = L _ [] + , m_grhss = GRHSs _ guards wheres + -- For a variable declaration I'm pretty + -- sure we always have a FunRhs + , m_ctxt = FunRhs { mc_strictness = strictessAnn } + } )]) } })) + = do { (ss,wherecore) <- repBinds wheres + ; guardcore <- addBinds ss (repGuards guards) + ; fn' <- lookupNBinder fn + ; p <- repPvar fn' >>= case strictessAnn of + SrcLazy -> repPtilde + SrcStrict -> repPbang + NoSrcStrict -> pure + ; ans <- repVal p guardcore wherecore + ; ans' <- wrapGenSyms ss ans + ; return (locA loc, ans') } + +rep_bind (L loc (FunBind { fun_id = fn + , fun_matches = MG { mg_alts = L _ ms } })) + = do { ms1 <- mapM repClauseTup ms + ; fn' <- lookupNBinder fn + ; ans <- repFun fn' (nonEmptyCoreList ms1) + ; return (locA loc, ans) } + +rep_bind (L loc (PatBind { pat_lhs = pat + , pat_rhs = GRHSs _ guards wheres })) + = do { patcore <- repLP pat + ; (ss,wherecore) <- repBinds wheres + ; guardcore <- addBinds ss (repGuards guards) + ; ans <- repVal patcore guardcore wherecore + ; ans' <- wrapGenSyms ss ans + ; return (locA loc, ans') } + +rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn + , psb_args = args + , psb_def = pat + , psb_dir = dir }))) + = do { syn' <- lookupNBinder syn + ; dir' <- repPatSynDir dir + ; ss <- mkGenArgSyms args + ; patSynD' <- addBinds ss ( + do { args' <- repPatSynArgs args + ; pat' <- repLP pat + ; repPatSynD syn' args' dir' pat' }) + ; patSynD'' <- wrapGenArgSyms args ss patSynD' + ; return (locA loc, patSynD'') } + where + mkGenArgSyms :: HsPatSynDetails GhcRn -> MetaM [GenSymBind] + -- for Record Pattern Synonyms we want to conflate the selector + -- and the pattern-only names in order to provide a nicer TH + -- API. Whereas inside GHC, record pattern synonym selectors and + -- their pattern-only bound right hand sides have different names, + -- we want to treat them the same in TH. This is the reason why we + -- need an adjusted mkGenArgSyms in the `RecCon` case below. + mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args) + mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] + mkGenArgSyms (RecCon fields) + = do { let pats = map (unLoc . recordPatSynPatVar) fields + sels = map (unLoc . foLabel . recordPatSynField) fields + ; ss <- mkGenSyms sels + ; return $ replaceNames (zip sels pats) ss } + + replaceNames selsPats genSyms + = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats + , sel == sel' ] + + wrapGenArgSyms :: HsPatSynDetails GhcRn + -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec)) + wrapGenArgSyms (RecCon _) _ dec = return dec + wrapGenArgSyms _ ss dec = wrapGenSyms ss dec + +rep_bind (L _ (VarBind { var_ext = x })) = dataConCantHappen x + +repPatSynD :: Core TH.Name + -> Core (M TH.PatSynArgs) + -> Core (M TH.PatSynDir) + -> Core (M TH.Pat) + -> MetaM (Core (M TH.Dec)) +repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat) + = rep2 patSynDName [syn, args, dir, pat] + +repPatSynArgs :: HsPatSynDetails GhcRn -> MetaM (Core (M TH.PatSynArgs)) +repPatSynArgs (PrefixCon args) + = do { args' <- repList nameTyConName lookupLOcc args + ; repPrefixPatSynArgs args' } +repPatSynArgs (InfixCon arg1 arg2) + = do { arg1' <- lookupLOcc arg1 + ; arg2' <- lookupLOcc arg2 + ; repInfixPatSynArgs arg1' arg2' } +repPatSynArgs (RecCon fields) + = do { sels' <- repList nameTyConName (lookupOcc . unLoc . foLabel) sels + ; repRecordPatSynArgs sels' } + where sels = map recordPatSynField fields + +repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs)) +repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms] + +repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> MetaM (Core (M TH.PatSynArgs)) +repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2] + +repRecordPatSynArgs :: Core [TH.Name] + -> MetaM (Core (M TH.PatSynArgs)) +repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] + +repPatSynDir :: HsPatSynDir GhcRn -> MetaM (Core (M TH.PatSynDir)) +repPatSynDir Unidirectional = rep2 unidirPatSynName [] +repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] +repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) })) + = do { clauses' <- mapM repClauseTup clauses + ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } + +repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir)) +repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] + + +----------------------------------------------------------------------------- +-- Since everything in a Bind is mutually recursive we need rename all +-- all the variables simultaneously. For example: +-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to +-- do { f'1 <- gensym "f" +-- ; g'2 <- gensym "g" +-- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]}, +-- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]} +-- ]} +-- This requires collecting the bindings (f'1 <- gensym "f"), and the +-- environment ( f |-> f'1 ) from each binding, and then unioning them +-- together. As we do this we collect GenSymBinds's which represent the renamed +-- variables bound by the Bindings. In order not to lose track of these +-- representations we build a shadow datatype MB with the same structure as +-- MonoBinds, but which has slots for the representations + + +----------------------------------------------------------------------------- +-- GHC allows a more general form of lambda abstraction than specified +-- by Haskell 98. In particular it allows guarded lambda's like : +-- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in +-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like +-- (\ p1 .. pn -> exp) by causing an error. + +repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp)) +repLambda (L _ (Match { m_pats = L _ ps + , m_grhss = GRHSs _ (L _ (GRHS _ [] e) :| []) + (EmptyLocalBinds _) } )) + = do { let bndrs = collectPatsBinders CollNoDictBinders ps ; + ; ss <- mkGenSyms bndrs + ; lam <- addBinds ss ( + do { xs <- repLPs ps; body <- repLE e; repLam xs body }) + ; wrapGenSyms ss lam } + +repLambda (L _ m) = notHandled (ThGuardedLambdas m) + + +----------------------------------------------------------------------------- +-- Patterns +-- repP deals with patterns. It assumes that we have already +-- walked over the pattern(s) once to collect the binders, and +-- have extended the environment. So every pattern-bound +-- variable should already appear in the environment. + +-- Process a list of patterns +repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)]) +repLPs ps = repListM patTyConName repLP ps + +repLPs1 :: NonEmpty (LPat GhcRn) -> MetaM (Core (NonEmpty (M TH.Pat))) +repLPs1 ps = repNonEmptyM patTyConName repLP ps + +repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat)) +repLP p = repP (unLoc p) + +repP :: Pat GhcRn -> MetaM (Core (M TH.Pat)) +repP (WildPat _) = repPwild +repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 } +repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' } +repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } +repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } +repP (AsPat _ x p) = do { x' <- lookupNBinder x; p1 <- repLP p + ; repPaspat x' p1 } +repP (ParPat _ p) = repLP p +repP (ListPat _ ps) = do { qs <- repLPs ps; repPlist qs } +repP (TuplePat _ ps boxed) + | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } + | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } +repP (SumPat _ p alt arity) = do { p1 <- repLP p + ; repPunboxedSum p1 alt arity } +repP (ConPat NoExtField dc details) + = do { con_str <- lookupWithUserRdrLOcc dc + ; case details of + PrefixCon ps -> do { ts' <- repListM typeTyConName (repTy . unLoc . hstp_body) (takeHsConPatTyArgs ps) + ; ps' <- repLPs (dropHsConPatTyArgs ps) + ; repPcon con_str ts' ps' } + RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec) + ; repPrec con_str fps } + InfixCon p1 p2 -> do { p1' <- repLP p1; + p2' <- repLP p2; + repPinfix p1' con_str p2' } + } + where + rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat))) + rep_fld (L _ fld) = do { MkC v <- lookupOcc (hsRecFieldSel fld) + ; MkC p <- repLP (hfbRHS fld) + ; rep2 fieldPatName [v,p] } +repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l + ; repPlit a } +repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } +repP p@(NPat _ (L _ l) (Just _) _) + | OverLitRn rebindable _ <- ol_ext l + , rebindable = notHandled (ThNegativeOverloadedPatterns p) + | HsIntegral i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsIntegral (negateIntegralLit i)} + ; repPlit a } + | HsFractional i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsFractional (negateFractionalLit i)} + ; repPlit a } + | otherwise = notHandled (ThExoticPattern p) +repP (SigPat _ p t) = do { p' <- repLP p + ; t' <- repLTy (hsPatSigType t) + ; repPsig p' t' } +repP (EmbTyPat _ t) = do { t' <- repLTy (hstp_body t) + ; repPtype t' } +repP (InvisPat _ t) = do { t' <- repLTy (hstp_body t) + ; repPinvis t' } +repP (OrPat _ ps) = do { ps' <- repLPs1 ps; repPor ps' } +repP (SplicePat (HsUntypedSpliceNested n) _) = rep_splice n +repP p@(SplicePat (HsUntypedSpliceTop _ _) _) = pprPanic "repP: top level splice" (ppr p) +repP other = notHandled (ThExoticPattern other) + +---------------------------------------------------------- +-- Declaration ordering helpers + +sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)] +sort_by_loc = sortBy (SrcLoc.leftmost_smallest `on` fst) + +de_loc :: [(a, b)] -> [b] +de_loc = map snd + +---------------------------------------------------------- +-- The meta-environment + +-- A name/identifier association for fresh names of locally bound entities +type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id + -- I.e. (x, x_id) means + -- let x_id = gensym "x" in ... + +-- Generate a fresh name for a locally bound entity + +mkGenSyms :: [Name] -> MetaM [GenSymBind] +-- We can use the existing name. For example: +-- [| \x_77 -> x_77 + x_77 |] +-- desugars to +-- do { x_77 <- genSym "x"; .... } +-- We use the same x_77 in the desugared program, but with the type Bndr +-- instead of Int +-- +-- We do make it an Internal name, though (hence localiseName) +-- +-- Nevertheless, it's monadic because we have to generate nameTy +mkGenSyms ns = do { var_ty <- lookupType nameTyConName + ; return [ (nm, mkLocalId (localiseName nm) ManyTy var_ty) + | nm <- ns] } + + +addBinds :: [GenSymBind] -> MetaM a -> MetaM a +-- Add a list of fresh names for locally bound entities to the +-- meta environment (which is part of the state carried around +-- by the desugarer monad) +addBinds bs m = mapReaderT (dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs])) m + +-- Look up a locally bound name +-- +lookupNBinder :: LocatedN Name -> MetaM (Core TH.Name) +lookupNBinder n = lookupBinder (unLoc n) + +lookupBinder :: Name -> MetaM (Core TH.Name) +lookupBinder = lookupOcc + -- Binders are brought into scope before the pattern or what-not is + -- desugared. Moreover, in instance declaration the binder of a method + -- will be the selector Id and hence a global; so we need the + -- globalVar case of lookupOcc + +-- Look up a name that is either locally bound or a global name +-- +-- * If it is a global name, generate the "original name" representation (ie, +-- the : form) for the associated entity +-- +lookupLOcc :: GenLocated l Name -> MetaM (Core TH.Name) +-- Lookup an occurrence; it can't be a splice. +-- Use the in-scope bindings if they exist +lookupLOcc n = lookupOcc (unLoc n) + +lookupWithUserRdrLOcc :: GenLocated l (WithUserRdr Name) -> MetaM (Core TH.Name) +lookupWithUserRdrLOcc (L _loc (WithUserRdr _rdr n)) = lookupOcc n + +lookupOcc :: Name -> MetaM (Core TH.Name) +lookupOcc = lift . lookupOccDsM + +lookupOccDsM :: Name -> DsM (Core TH.Name) +lookupOccDsM n + = do { mb_val <- dsLookupMetaEnv n ; + case mb_val of + Nothing -> globalVar n + Just (DsBound x) -> return (coreVar x) + Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n) + } + + +-- Not bound by the meta-env +-- Could be top-level; or could be local +-- f x = $(g [| x |]) +-- Here the x will be local +globalVar :: Name -> DsM (Core TH.Name) +globalVar n = + case nameModule_maybe n of + Just m -> globalVarExternal m (getOccName n) + Nothing -> globalVarLocal (getUnique n) (getOccName n) + +globalVarLocal :: Unique -> OccName -> DsM (Core TH.Name) +globalVarLocal unique name + = do { MkC occ <- occNameLit name + ; platform <- targetPlatform <$> getDynFlags + ; let uni = mkIntegerExpr platform (toInteger $ getKey unique) + ; rep2_nwDsM mkNameLName [occ,uni] } + +globalVarExternal :: Module -> OccName -> DsM (Core TH.Name) +globalVarExternal mod name_occ + = do { MkC mod <- coreStringLit name_mod + ; MkC pkg <- coreStringLit name_pkg + ; MkC occ <- occNameLit name_occ + ; if | isDataOcc name_occ + -> rep2_nwDsM mkNameG_dName [pkg,mod,occ] + | isVarOcc name_occ + -> rep2_nwDsM mkNameG_vName [pkg,mod,occ] + | isTcOcc name_occ + -> rep2_nwDsM mkNameG_tcName [pkg,mod,occ] + | Just con_fs <- fieldOcc_maybe name_occ + -> do { MkC con <- coreStringLit con_fs + ; rep2_nwDsM mkNameG_fldName [pkg,mod,con,occ] } + | otherwise + -> pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name_occ) + } + where + name_mod = moduleNameFS (moduleName mod) + name_pkg = unitFS (moduleUnit mod) + +lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp)) + -> MetaM Type -- The type +lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ; + return (mkTyConApp tc []) } + +wrapGenSyms :: [GenSymBind] + -> Core (M a) -> MetaM (Core (M a)) +-- wrapGenSyms [(nm1,id1), (nm2,id2)] y +-- --> bindQ (gensym nm1) (\ id1 -> +-- bindQ (gensym nm2 (\ id2 -> +-- y)) + +wrapGenSyms binds body@(MkC b) + = do { var_ty <- lookupType nameTyConName + ; go var_ty binds } + where + (_, elt_ty) = tcSplitAppTy (exprType b) + -- b :: m a, so we can get the type 'a' by looking at the + -- argument type. Need to use `tcSplitAppTy` here as since + -- the overloaded quotations patch the type of the expression can + -- be something more complicated than just `Q a`. + -- See #17839 for when this went wrong with the type `WriterT () m a` + + go _ [] = return body + go var_ty ((name,id) : binds) + = do { MkC body' <- go var_ty binds + ; lit_str <- occNameLit (occName name) + ; gensym_app <- repGensym lit_str + ; repBindM var_ty elt_ty + gensym_app (MkC (Lam id body')) } + +occNameLit :: MonadThings m => OccName -> m (Core String) +occNameLit name = coreStringLit (occNameFS name) + + +-- %********************************************************************* +-- %* * +-- Constructing code +-- %* * +-- %********************************************************************* + +----------------------------------------------------------------------------- +-- PHANTOM TYPES for consistency. In order to make sure we do this correct +-- we invent a new datatype which uses phantom types. + +newtype Core a = MkC CoreExpr +unC :: Core a -> CoreExpr +unC (MkC x) = x + +type family NotM a where + NotM (M _) = TypeError ('Text ("rep2_nw must not produce something of overloaded type")) + NotM _other = (() :: Constraint) + +rep2M :: Name -> [CoreExpr] -> MetaM (Core (M a)) +rep2 :: Name -> [CoreExpr] -> MetaM (Core (M a)) +rep2_nw :: NotM a => Name -> [CoreExpr] -> MetaM (Core a) +rep2_nwDsM :: NotM a => Name -> [CoreExpr] -> DsM (Core a) +rep2 = rep2X lift (asks quoteWrapper) +rep2M = rep2X lift (asks monadWrapper) +rep2_nw n xs = lift (rep2_nwDsM n xs) +rep2_nwDsM = rep2X id (return id) + +rep2X :: Monad m => (forall z . DsM z -> m z) + -> m (CoreExpr -> CoreExpr) + -> Name + -> [ CoreExpr ] + -> m (Core a) +rep2X lift_dsm get_wrap n xs = do + { rep_id <- lift_dsm $ dsLookupGlobalId n + ; wrap <- get_wrap + ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) } + + +dataCon' :: Name -> [CoreExpr] -> MetaM (Core a) +dataCon' n args = do { id <- lift $ dsLookupDataCon n + ; return $ MkC $ mkCoreConApps id args } + +dataCon :: Name -> MetaM (Core a) +dataCon n = dataCon' n [] + + +-- %********************************************************************* +-- %* * +-- The 'smart constructors' +-- %* * +-- %********************************************************************* + +--------------- Patterns ----------------- +repPlit :: Core TH.Lit -> MetaM (Core (M TH.Pat)) +repPlit (MkC l) = rep2 litPName [l] + +repPvar :: Core TH.Name -> MetaM (Core (M TH.Pat)) +repPvar (MkC s) = rep2 varPName [s] + +repPtup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPtup (MkC ps) = rep2 tupPName [ps] + +repPunboxedTup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] + +repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat)) +-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here +repPunboxedSum (MkC p) alt arity + = do { platform <- getPlatform + ; rep2 unboxedSumPName [ p + , mkIntExprInt platform alt + , mkIntExprInt platform arity ] } + +repPcon :: Core TH.Name -> Core [(M TH.Type)] -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPcon (MkC s) (MkC ts) (MkC ps) = rep2 conPName [s, ts, ps] + +repPrec :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps] + +repPinfix :: Core (M TH.Pat) -> Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2] + +repPtilde :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPtilde (MkC p) = rep2 tildePName [p] + +repPbang :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPbang (MkC p) = rep2 bangPName [p] + +repPaspat :: Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] + +repPwild :: MetaM (Core (M TH.Pat)) +repPwild = rep2 wildPName [] + +repPlist :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPlist (MkC ps) = rep2 listPName [ps] + +repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPview (MkC e) (MkC p) = rep2 viewPName [e,p] + +repPor :: Core (NonEmpty (M TH.Pat)) -> MetaM (Core (M TH.Pat)) +repPor (MkC ps) = rep2 orPName [ps] + +repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat)) +repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] + +repPtype :: Core (M TH.Type) -> MetaM (Core (M TH.Pat)) +repPtype (MkC t) = rep2 typePName [t] + +repPinvis :: Core (M TH.Type) -> MetaM (Core (M TH.Pat)) +repPinvis (MkC t) = rep2 invisPName [t] + +--------------- Expressions ----------------- +repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp)) +repVarOrCon vc str + | isVarNameSpace ns = repVar str -- Both type and term variables (#18740) + | otherwise = repCon str + where + ns = nameNameSpace vc + +repVar :: Core TH.Name -> MetaM (Core (M TH.Exp)) +repVar (MkC s) = rep2 varEName [s] + +repCon :: Core TH.Name -> MetaM (Core (M TH.Exp)) +repCon (MkC s) = rep2 conEName [s] + +repLit :: Core TH.Lit -> MetaM (Core (M TH.Exp)) +repLit (MkC c) = rep2 litEName [c] + +repApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repApp (MkC x) (MkC y) = rep2 appEName [x,y] + +repApps :: Core (M TH.Exp) -> [Core (M TH.Exp)] -> MetaM (Core (M TH.Exp)) +repApps = foldlM repApp + +repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp)) +repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y] + +repLam :: Core [(M TH.Pat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] + +repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) +repLamCase (MkC ms) = rep2 lamCaseEName [ms] + +repLamCases :: Core [(M TH.Clause)] -> MetaM (Core (M TH.Exp)) +repLamCases (MkC ms) = rep2 lamCasesEName [ms] + +repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp)) +repTup (MkC es) = rep2 tupEName [es] + +repUnboxedTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp)) +repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] + +repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp)) +-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here +repUnboxedSum (MkC e) alt arity + = do { platform <- getPlatform + ; rep2 unboxedSumEName [ e + , mkIntExprInt platform alt + , mkIntExprInt platform arity ] } + +repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] + +repMultiIf :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Exp)) +repMultiIf (MkC alts) = rep2 multiIfEName [alts] + +repLetE :: Core [(M TH.Dec)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] + +repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) +repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] + +repDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) +repDoE = repDoBlock doEName + +repMDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) +repMDoE = repDoBlock mdoEName + +repDoBlock :: Name -> Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) +repDoBlock doName maybeModName (MkC ss) = do + MkC coreModName <- coreModNameM + rep2 doName [coreModName, ss] + where + coreModNameM :: MetaM (Core (Maybe TH.ModName)) + coreModNameM = case maybeModName of + Just m -> do + MkC s <- coreStringLit (moduleNameFS m) + mName <- rep2_nw mkModNameName [s] + coreJust modNameTyConName mName + _ -> coreNothing modNameTyConName + +repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) +repComp (MkC ss) = rep2 compEName [ss] + +repListExp :: Core [(M TH.Exp)] -> MetaM (Core (M TH.Exp)) +repListExp (MkC es) = rep2 listEName [es] + +repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp)) +repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t] + +repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp)) +repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs] + +repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp)) +repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs] + +repFieldExp :: Core TH.Name -> Core (M TH.Exp) -> MetaM (Core (M TH.FieldExp)) +repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x] + +repInfixApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] + +repSectionL :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y] + +repSectionR :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] + +repImplicitParamVar :: Core String -> MetaM (Core (M TH.Exp)) +repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x] + +------------ Right hand sides (guarded expressions) ---- +repGuarded :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Body)) +repGuarded (MkC pairs) = rep2 guardedBName [pairs] + +repNormal :: Core (M TH.Exp) -> MetaM (Core (M TH.Body)) +repNormal (MkC e) = rep2 normalBName [e] + +------------ Guards ---- +repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn + -> MetaM (Core (M (TH.Guard, TH.Exp))) +repLNormalGE g e = do g' <- repLE g + e' <- repLE e + repNormalGE g' e' + +repNormalGE :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp))) +repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e] + +repPatGE :: Core [(M TH.Stmt)] -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp))) +repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e] + +------------- Stmts ------------------- +repBindSt :: Core (M TH.Pat) -> Core (M TH.Exp) -> MetaM (Core (M TH.Stmt)) +repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e] + +repLetSt :: Core [(M TH.Dec)] -> MetaM (Core (M TH.Stmt)) +repLetSt (MkC ds) = rep2 letSName [ds] + +repNoBindSt :: Core (M TH.Exp) -> MetaM (Core (M TH.Stmt)) +repNoBindSt (MkC e) = rep2 noBindSName [e] + +repParSt :: Core [[(M TH.Stmt)]] -> MetaM (Core (M TH.Stmt)) +repParSt (MkC sss) = rep2 parSName [sss] + +repRecSt :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Stmt)) +repRecSt (MkC ss) = rep2 recSName [ss] + +-------------- Range (Arithmetic sequences) ----------- +repFrom :: Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFrom (MkC x) = rep2 fromEName [x] + +repFromThen :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y] + +repFromTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y] + +repFromThenTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z] + +------------ Match and Clause Tuples ----------- +repMatch :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Match)) +repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds] + +repClause :: Core [(M TH.Pat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause)) +repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] + +-------------- Dec ----------------------------- +repVal :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) +repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] + +repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec)) +repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] + +repData :: Bool -- ^ @True@ for a @type data@ declaration. + -- See Note [Type data declarations] in GHC.Rename.Module + -> Core (M TH.Cxt) -> Core TH.Name + -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))]) + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) + -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause] + -> MetaM (Core (M TH.Dec)) +repData type_data (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) + | type_data = rep2 typeDataDName [nm, tvs, ksig, cons] + | otherwise = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] +repData _ (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) + (MkC derivs) + = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] + +repNewtype :: Core (M TH.Cxt) -> Core TH.Name + -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))]) + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) + -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause] + -> MetaM (Core (M TH.Dec)) +repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con) + (MkC derivs) + = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs] +repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con) + (MkC derivs) + = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs] + +repTySyn :: Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))] + -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) +repTySyn (MkC nm) (MkC tvs) (MkC rhs) + = rep2 tySynDName [nm, tvs, rhs] + +repInst :: Core (Maybe TH.Overlap) -> + Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) +repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName + [o, cxt, ty, ds] + +repDerivStrategy :: Maybe (LDerivStrategy GhcRn) + -> (Core (Maybe (M TH.DerivStrategy)) -> MetaM (Core (M a))) + -> MetaM (Core (M a)) +repDerivStrategy mds thing_inside = + case mds of + Nothing -> thing_inside =<< nothing + Just ds -> + case unLoc ds of + StockStrategy _ -> thing_inside =<< just =<< repStockStrategy + AnyclassStrategy _ -> thing_inside =<< just =<< repAnyclassStrategy + NewtypeStrategy _ -> thing_inside =<< just =<< repNewtypeStrategy + ViaStrategy ty -> addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig ty) $ + do ty' <- rep_ty_sig' ty + via_strat <- repViaStrategy ty' + m_via_strat <- just via_strat + thing_inside m_via_strat + where + nothing = coreNothingM derivStrategyTyConName + just = coreJustM derivStrategyTyConName + +repStockStrategy :: MetaM (Core (M TH.DerivStrategy)) +repStockStrategy = rep2 stockStrategyName [] + +repAnyclassStrategy :: MetaM (Core (M TH.DerivStrategy)) +repAnyclassStrategy = rep2 anyclassStrategyName [] + +repNewtypeStrategy :: MetaM (Core (M TH.DerivStrategy)) +repNewtypeStrategy = rep2 newtypeStrategyName [] + +repViaStrategy :: Core (M TH.Type) -> MetaM (Core (M TH.DerivStrategy)) +repViaStrategy (MkC t) = rep2 viaStrategyName [t] + +repOverlap :: Maybe OverlapMode -> MetaM (Core (Maybe TH.Overlap)) +repOverlap mb = + case mb of + Nothing -> nothing + Just o -> + case o of + NoOverlap _ -> nothing + Overlappable _ -> just =<< dataCon overlappableDataConName + Overlapping _ -> just =<< dataCon overlappingDataConName + Overlaps _ -> just =<< dataCon overlapsDataConName + Incoherent _ -> just =<< dataCon incoherentDataConName + NonCanonical _ -> just =<< dataCon incoherentDataConName + where + nothing = coreNothing overlapTyConName + just = coreJust overlapTyConName + + +repNamespaceSpecifier :: NamespaceSpecifier -> MetaM (Core (TH.NamespaceSpecifier)) +repNamespaceSpecifier ns_spec = case ns_spec of + NoNamespaceSpecifier{} -> dataCon noNamespaceSpecifierDataConName + TypeNamespaceSpecifier{} -> dataCon typeNamespaceSpecifierDataConName + DataNamespaceSpecifier{} -> dataCon dataNamespaceSpecifierDataConName + +repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))] + -> Core [TH.FunDep] -> Core [(M TH.Dec)] + -> MetaM (Core (M TH.Dec)) +repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) + = rep2 classDName [cxt, cls, tvs, fds, ds] + +repDeriv :: Core (Maybe (M TH.DerivStrategy)) + -> Core (M TH.Cxt) -> Core (M TH.Type) + -> MetaM (Core (M TH.Dec)) +repDeriv (MkC ds) (MkC cxt) (MkC ty) + = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty] + +repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch + -> Core TH.Phases -> MetaM (Core (M TH.Dec)) +repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases) + = rep2 pragInlDName [nm, inline, rm, phases] + +repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec)) +repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm] + +repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Maybe (Core (TH.Inline)) + -> Core TH.Phases + -> MetaM (Core (M TH.Dec)) +repPragSpec (MkC nm) (MkC ty) mb_inl (MkC phases) + = case mb_inl of + Nothing -> + rep2 pragSpecDName [nm, ty, phases] + Just (MkC inl) -> + rep2 pragSpecInlDName [nm, ty, inl, phases] + +repPragSpecE :: Core (Maybe [M (TH.TyVarBndr ())]) -> Core [(M TH.RuleBndr)] + -> Core (M TH.Exp) + -> Maybe (Core TH.Inline) -> Core TH.Phases + -> MetaM (Core (M TH.Dec)) +repPragSpecE (MkC ty_bndrs) (MkC tm_bndrs) (MkC expr) mb_inl (MkC phases) + = case mb_inl of + Nothing -> + rep2 pragSpecEDName [ty_bndrs, tm_bndrs, expr, phases] + Just (MkC inl) -> + rep2 pragSpecInlEDName [ty_bndrs, tm_bndrs, expr, inl, phases] + +repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec)) +repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty] + +repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec)) +repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty] + +repPragRule :: Core String -> Core (Maybe [(M (TH.TyVarBndr ()))]) + -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp) + -> Core TH.Phases -> MetaM (Core (M TH.Dec)) +repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases) + = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases] + +repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec)) +repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] + +repPragSCCFun :: Core TH.Name -> MetaM (Core (M TH.Dec)) +repPragSCCFun (MkC nm) = rep2 pragSCCFunDName [nm] + +repPragSCCFunNamed :: Core TH.Name -> Core String -> MetaM (Core (M TH.Dec)) +repPragSCCFunNamed (MkC nm) (MkC str) = rep2 pragSCCFunNamedDName [nm, str] + +repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec)) +repTySynInst (MkC eqn) + = rep2 tySynInstDName [eqn] + +repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))] + -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec)) +repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) + = rep2 dataFamilyDName [nm, tvs, kind] + +repOpenFamilyD :: Core TH.Name + -> Core [(M (TH.TyVarBndr TH.BndrVis))] + -> Core (M TH.FamilyResultSig) + -> Core (Maybe TH.InjectivityAnn) + -> MetaM (Core (M TH.Dec)) +repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) + = rep2 openTypeFamilyDName [nm, tvs, result, inj] + +repClosedFamilyD :: Core TH.Name + -> Core [(M (TH.TyVarBndr TH.BndrVis))] + -> Core (M TH.FamilyResultSig) + -> Core (Maybe TH.InjectivityAnn) + -> Core [(M TH.TySynEqn)] + -> MetaM (Core (M TH.Dec)) +repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) + = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] + +repTySynEqn :: Core (Maybe [(M (TH.TyVarBndr ()))]) -> + Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn)) +repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs) + = rep2 tySynEqnName [mb_bndrs, lhs, rhs] + +repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> MetaM (Core (M TH.Dec)) +repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles] + +repFunDep :: Core [TH.Name] -> Core [TH.Name] -> MetaM (Core TH.FunDep) +repFunDep (MkC xs) (MkC ys) = rep2_nw funDepName [xs, ys] + +repProto :: Name -> Core TH.Name -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) +repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] + +repImplicitParamBind :: Core String -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec)) +repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e] + +repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt)) +repCtxt (MkC tys) = rep2 cxtName [tys] + +repH98DataCon :: LocatedN Name + -> HsConDeclH98Details GhcRn + -> MetaM (Core (M TH.Con)) +repH98DataCon con details + = do con' <- lookupLOcc con -- See Note [Binders and occurrences] + case details of + PrefixCon ps -> do + arg_tys <- repPrefixConArgs IsNotPrefixConGADT ps + rep2 normalCName [unC con', unC arg_tys] + InfixCon st1 st2 -> do + verifyLinearFields IsNotPrefixConGADT [st1, st2] + arg1 <- repConDeclField st1 + arg2 <- repConDeclField st2 + rep2 infixCName [unC arg1, unC con', unC arg2] + RecCon ips -> do + arg_vtys <- repRecConArgs ips + rep2 recCName [unC con', unC arg_vtys] + +repGadtDataCons :: NonEmpty (LocatedN Name) + -> HsConDeclGADTDetails GhcRn + -> LHsType GhcRn + -> MetaM (Core (M TH.Con)) +repGadtDataCons cons details res_ty + = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] + case details of + PrefixConGADT _ ps -> do + arg_tys <- repPrefixConArgs IsPrefixConGADT ps + res_ty' <- repLTy res_ty + rep2 gadtCName [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty'] + RecConGADT _ ips -> do + arg_vtys <- repRecConArgs ips + res_ty' <- repLTy res_ty + rep2 recGadtCName [unC (nonEmptyCoreList' cons'), unC arg_vtys, + unC res_ty'] + +-- TH currently only supports linear constructors. +-- We also accept the (->) arrow when -XLinearTypes is off, because this +-- denotes a linear field. +verifyLinearFields :: IsPrefixConGADT -> [HsConDeclField GhcRn] -> MetaM () +verifyLinearFields isPrefixConGADT ps = do + linear <- lift $ unannotatedMultIsLinear isPrefixConGADT + let allGood = all (hsMultIsLinear linear . cdf_multiplicity) ps + unless allGood $ notHandled ThNonLinearDataCon + where + hsMultIsLinear linear HsUnannotated{} = linear + hsMultIsLinear _ HsLinearAnn{} = True + hsMultIsLinear _ (HsExplicitMult _ (L _ (HsTyVar _ _ (L _ n)))) = getName n == oneDataConName + hsMultIsLinear _ _ = False + +-- Desugar the arguments in a data constructor declared with prefix syntax. +repPrefixConArgs :: IsPrefixConGADT -> [HsConDeclField GhcRn] -> MetaM (Core [M TH.BangType]) +repPrefixConArgs isPrefixConGADT ps = do + verifyLinearFields isPrefixConGADT ps + repListM bangTypeTyConName repConDeclField ps + +-- Desugar the arguments in a data constructor declared with record syntax. +repRecConArgs :: LocatedL [LHsConDeclRecField GhcRn] + -> MetaM (Core [M TH.VarBangType]) +repRecConArgs lips = do + let ips = map unLoc (unLoc lips) + verifyLinearFields IsNotPrefixConGADT (map cdrf_spec ips) + args <- concatMapM rep_ip ips + coreListM varBangTypeTyConName args + where + rep_ip ip = mapM (rep_one_ip (cdrf_spec ip)) (cdrf_names ip) + + rep_one_ip :: HsConDeclField GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType)) + rep_one_ip t n = do { MkC v <- lookupOcc (unLoc . foLabel $ unLoc n) + ; MkC ty <- repConDeclField t + ; rep2 varBangTypeName [v,ty] } + +------------ Types ------------------- + +repTForall :: Core [(M (TH.TyVarBndr TH.Specificity))] -> Core (M TH.Cxt) -> Core (M TH.Type) + -> MetaM (Core (M TH.Type)) +repTForall (MkC tvars) (MkC ctxt) (MkC ty) + = rep2 forallTName [tvars, ctxt, ty] + +repTForallVis :: Core [(M (TH.TyVarBndr ()))] -> Core (M TH.Type) + -> MetaM (Core (M TH.Type)) +repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty] + +repTvar :: Core TH.Name -> MetaM (Core (M TH.Type)) +repTvar (MkC s) = rep2 varTName [s] + +repTapp :: Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) +repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2] + +repTappKind :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type)) +repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki] + +repTapps :: Core (M TH.Type) -> [Core (M TH.Type)] -> MetaM (Core (M TH.Type)) +repTapps f [] = return f +repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } + +repTSig :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type)) +repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] + +repTequality :: MetaM (Core (M TH.Type)) +repTequality = rep2 equalityTName [] + +repTPromotedList :: [Core (M TH.Type)] -> MetaM (Core (M TH.Type)) +repTPromotedList [] = repPromotedNilTyCon +repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon + ; f <- repTapp tcon t + ; t' <- repTPromotedList ts + ; repTapp f t' + } + +repTLit :: Core (M TH.TyLit) -> MetaM (Core (M TH.Type)) +repTLit (MkC lit) = rep2 litTName [lit] + +repTWildCard :: MetaM (Core (M TH.Type)) +repTWildCard = rep2 wildCardTName [] + +repTImplicitParam :: Core String -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) +repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e] + +repTStar :: MetaM (Core (M TH.Type)) +repTStar = rep2 starKName [] + +repTConstraint :: MetaM (Core (M TH.Type)) +repTConstraint = rep2 constraintKName [] + +--------- Type constructors -------------- + +repNamedTyCon :: Core TH.Name -> MetaM (Core (M TH.Type)) +repNamedTyCon (MkC s) = rep2 conTName [s] + +repTInfix :: Core (M TH.Type) -> Core TH.Name -> Core (M TH.Type) + -> MetaM (Core (M TH.Type)) +repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2] + +repTupleTyCon :: Int -> MetaM (Core (M TH.Type)) +-- Note: not Core Int; it's easier to be direct here +repTupleTyCon i = do platform <- getPlatform + rep2 tupleTName [mkIntExprInt platform i] + +repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type)) +-- Note: not Core Int; it's easier to be direct here +repUnboxedTupleTyCon i = do platform <- getPlatform + rep2 unboxedTupleTName [mkIntExprInt platform i] + +repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type)) +-- Note: not Core TH.SumArity; it's easier to be direct here +repUnboxedSumTyCon arity = do platform <- getPlatform + rep2 unboxedSumTName [mkIntExprInt platform arity] + +repArrowTyCon :: MetaM (Core (M TH.Type)) +repArrowTyCon = rep2 arrowTName [] + +repMulArrowTyCon :: MetaM (Core (M TH.Type)) +repMulArrowTyCon = rep2 mulArrowTName [] + +repListTyCon :: MetaM (Core (M TH.Type)) +repListTyCon = rep2 listTName [] + +repPromotedDataCon :: Core TH.Name -> MetaM (Core (M TH.Type)) +repPromotedDataCon (MkC s) = rep2 promotedTName [s] + +repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type)) +repPromotedTupleTyCon i = do platform <- getPlatform + rep2 promotedTupleTName [mkIntExprInt platform i] + +repPromotedNilTyCon :: MetaM (Core (M TH.Type)) +repPromotedNilTyCon = rep2 promotedNilTName [] + +repPromotedConsTyCon :: MetaM (Core (M TH.Type)) +repPromotedConsTyCon = rep2 promotedConsTName [] + +---------------------------------------------------------- +-- Type family result signature + +repNoSig :: MetaM (Core (M TH.FamilyResultSig)) +repNoSig = rep2 noSigName [] + +repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig)) +repKindSig (MkC ki) = rep2 kindSigName [ki] + +repTyVarSig :: Core (M (TH.TyVarBndr ())) -> MetaM (Core (M TH.FamilyResultSig)) +repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] + +---------------------------------------------------------- +-- Literals + +repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit) +repLiteral (HsStringPrim _ bs) + = do word8_ty <- lookupType word8TyConName + let w8s = unpack bs + w8s_expr = map (\w8 -> mkCoreConApps word8DataCon + [mkWord8Lit (toInteger w8)]) w8s + rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr] +repLiteral lit + = do lit' <- case lit of + HsIntPrim _ i -> lift . dsLit <$> mk_integer i + HsWordPrim _ w -> lift . dsLit <$> mk_integer w + HsInt _ i -> lift . dsLit <$> mk_integer (il_value i) + HsFloatPrim _ r -> lift . dsLit <$> mk_rational r + HsDoublePrim _ r -> lift . dsLit <$> mk_rational r + HsCharPrim _ c -> lift . dsLit <$> mk_char c + _ -> return . lift . dsLit $ lit + lit_expr <- lit' + case mb_lit_name of + Just lit_name -> rep2_nw lit_name [lit_expr] + Nothing -> notHandled (ThExoticLiteral lit) + where + mb_lit_name = case lit of + HsInt _ _ -> Just integerLName + HsIntPrim _ _ -> Just intPrimLName + HsWordPrim _ _ -> Just wordPrimLName + HsFloatPrim _ _ -> Just floatPrimLName + HsDoublePrim _ _ -> Just doublePrimLName + HsChar _ _ -> Just charLName + HsCharPrim _ _ -> Just charPrimLName + HsString _ _ -> Just stringLName + HsMultilineString _ _ -> Just stringLName + _ -> Nothing + +mk_integer :: Integer -> MetaM (HsLit GhcTc) +mk_integer i = return $ XLit $ HsInteger NoSourceText i integerTy + +mk_rational :: FractionalLit -> MetaM (HsLit GhcTc) +mk_rational r = do rat_ty <- lookupType rationalTyConName + return $ XLit $ HsRat r rat_ty + +mk_string :: FastString -> MetaM (HsLit GhcRn) +mk_string s = return $ HsString NoSourceText s + +mk_char :: Char -> MetaM (HsLit GhcRn) +mk_char c = return $ HsChar NoSourceText c + +repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit) +repOverloadedLiteral (OverLit { ol_val = val}) + = repOverLiteralVal val + -- The type Rational will be in the environment, because + -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, + -- and rationalL is sucked in when any TH stuff is used + +repOverLiteralVal :: OverLitVal -> MetaM (Core TH.Lit) +repOverLiteralVal lit = do + lit' <- case lit of + (HsIntegral i) -> lift . dsLit <$> mk_integer (il_value i) + (HsFractional f) -> lift . dsLit <$> mk_rational f + (HsIsString _ s) -> lift . dsLit <$> mk_string s + lit_expr <- lit' + + let lit_name = case lit of + (HsIntegral _ ) -> integerLName + (HsFractional _) -> rationalLName + (HsIsString _ _) -> stringLName + + rep2_nw lit_name [lit_expr] + +repRdrName :: RdrName -> MetaM (Core TH.Name) +repRdrName rdr_name = do + case rdr_name of + Unqual occ -> + repNameS =<< occNameLit occ + Qual mn occ -> do + let name_mod = moduleNameFS mn + mod <- coreStringLit name_mod + occ <- occNameLit occ + repNameQ mod occ + Orig m n -> lift $ globalVarExternal m n + Exact n -> lift $ globalVar n + +repNameS :: Core String -> MetaM (Core TH.Name) +repNameS (MkC name) = rep2_nw mkNameSName [name] + +repNameQ :: Core String -> Core String -> MetaM (Core TH.Name) +repNameQ (MkC mn) (MkC name) = rep2_nw mkNameQName [mn, name] + +--------------- Miscellaneous ------------------- + +repGensym :: Core String -> MetaM (Core (M TH.Name)) +repGensym (MkC lit_str) = rep2 newNameName [lit_str] + +repBindM :: Type -> Type -- a and b + -> Core (M a) -> Core (a -> M b) -> MetaM (Core (M b)) +repBindM ty_a ty_b (MkC x) (MkC y) + = rep2M bindMName [Type ty_a, Type ty_b, x, y] + +repSequenceM :: Type -> Core [M a] -> MetaM (Core (M [a])) +repSequenceM ty_a (MkC list) + = rep2M sequenceQName [Type ty_a, list] + +repUnboundVar :: Core TH.Name -> MetaM (Core (M TH.Exp)) +repUnboundVar (MkC name) = rep2 unboundVarEName [name] + +repOverLabel :: FastString -> MetaM (Core (M TH.Exp)) +repOverLabel fs = do + MkC s <- coreStringLit fs + rep2 labelEName [s] + +repGetField :: Core (M TH.Exp) -> FastString -> MetaM (Core (M TH.Exp)) +repGetField (MkC exp) fs = do + MkC s <- coreStringLit fs + rep2 getFieldEName [exp,s] + +repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp)) +repProjection fs = do + ne_tycon <- lift $ dsLookupTyCon nonEmptyTyConName + MkC xs <- coreListNonEmpty ne_tycon stringTy <$> + mapM coreStringLit fs + rep2 projectionEName [xs] + +------------ Lists ------------------- +-- turn a list of patterns into a single pattern matching a list + +repList :: Name -> (a -> MetaM (Core b)) + -> [a] -> MetaM (Core [b]) +repList tc_name f args + = do { args1 <- mapM f args + ; coreList tc_name args1 } + +-- Create a list of m a values +repListM :: Name -> (a -> MetaM (Core b)) + -> [a] -> MetaM (Core [b]) +repListM tc_name f args + = do { ty <- wrapName tc_name + ; args1 <- mapM f args + ; return $ coreList' ty args1 } + +repNonEmptyM + :: Name + -> (a -> MetaM (Core b)) + -> NonEmpty a -> MetaM (Core (NonEmpty b)) +repNonEmptyM tc_name f args + = do { ty <- wrapName tc_name + ; args' <- traverse f args + ; ne_tycon <- lift $ dsLookupTyCon nonEmptyTyConName -- the DataCon is not known-key + ; return $ coreListNonEmpty ne_tycon ty args' } + +coreListM :: Name -> [Core a] -> MetaM (Core [a]) +coreListM tc as = repListM tc return as + +coreList :: Name -- Of the TyCon of the element type + -> [Core a] -> MetaM (Core [a]) +coreList tc_name es + = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } + +coreList' :: Type -- The element type + -> [Core a] -> Core [a] +coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) + +coreListNonEmpty :: TyCon -- TyCon for NonEmpty + -> Type -- Element type + -> NonEmpty (Core a) + -> Core (NonEmpty a) +coreListNonEmpty ne_tc ty (MkC x :| xs) + = MkC $ mkCoreConApps (tyConSingleDataCon ne_tc) + [Type ty, x, mkListExpr ty (map unC xs)] + +nonEmptyCoreList :: [Core a] -> Core [a] + -- The list must be non-empty so we can get the element type + -- Otherwise use coreList +nonEmptyCoreList [] = panic "coreList: empty argument" +nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) + +nonEmptyCoreList' :: NonEmpty (Core a) -> Core [a] +nonEmptyCoreList' xs@(MkC x:|_) = MkC (mkListExpr (exprType x) (toList $ fmap unC xs)) + +coreStringLit :: MonadThings m => FastString -> m (Core String) +coreStringLit s = do { z <- mkStringExprFS s; return (MkC z) } + +------------------- Maybe ------------------ + +repMaybe :: Name -> (a -> MetaM (Core b)) + -> Maybe a -> MetaM (Core (Maybe b)) +repMaybe tc_name f m = do + t <- lookupType tc_name + repMaybeT t f m + +repMaybeT :: Type -> (a -> MetaM (Core b)) + -> Maybe a -> MetaM (Core (Maybe b)) +repMaybeT ty _ Nothing = return $ coreNothing' ty +repMaybeT ty f (Just es) = coreJust' ty <$> f es + +-- | Construct Core expression for Nothing of a given type name +coreNothing :: Name -- ^ Name of the TyCon of the element type + -> MetaM (Core (Maybe a)) +coreNothing tc_name = + do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) } + +coreNothingM :: Name -> MetaM (Core (Maybe a)) +coreNothingM tc_name = + do { elt_ty <- wrapName tc_name; return (coreNothing' elt_ty) } + +-- | Construct Core expression for Nothing of a given type +coreNothing' :: Type -- ^ The element type + -> Core (Maybe a) +coreNothing' elt_ty = MkC (mkNothingExpr elt_ty) + +-- | Store given Core expression in a Just of a given type name +coreJust :: Name -- ^ Name of the TyCon of the element type + -> Core a -> MetaM (Core (Maybe a)) +coreJust tc_name es + = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) } + +coreJustM :: Name -> Core a -> MetaM (Core (Maybe a)) +coreJustM tc_name es = do { elt_ty <- wrapName tc_name; return (coreJust' elt_ty es) } + +-- | Store given Core expression in a Just of a given type +coreJust' :: Type -- ^ The element type + -> Core a -> Core (Maybe a) +coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es)) + +------------------- Maybe Lists ------------------ + +coreJustList :: Type -> Core [a] -> Core (Maybe [a]) +coreJustList elt_ty = coreJust' (mkListTy elt_ty) + +coreNothingList :: Type -> Core (Maybe [a]) +coreNothingList elt_ty = coreNothing' (mkListTy elt_ty) + +------------ Literals & Variables ------------------- + +coreIntLit :: Int -> MetaM (Core Int) +coreIntLit i = do platform <- getPlatform + return (MkC (mkIntExprInt platform i)) + +coreVar :: Id -> Core TH.Name -- The Id has type Name +coreVar id = MkC (Var id) + +----------------- Failure ----------------------- +notHandledL :: SrcSpan -> ThRejectionReason -> MetaM a +notHandledL loc reason + | isGoodSrcSpan loc + = mapReaderT (putSrcSpanDs loc) $ notHandled reason + | otherwise + = notHandled reason + +notHandled :: ThRejectionReason -> MetaM a +notHandled reason = lift $ failWithDs (DsNotYetHandledByTH reason) diff --git a/GHC/HsToCore/Ticks.hs b/GHC/HsToCore/Ticks.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Ticks.hs @@ -0,0 +1,1451 @@ +{-# LANGUAGE NondecreasingIndentation #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +{- +(c) Galois, 2006 +(c) University of Glasgow, 2007 +(c) Florian Ragwitz, 2025 +-} + +module GHC.HsToCore.Ticks + ( TicksConfig (..) + , Tick (..) + , TickishType (..) + , addTicksToBinds + , isGoodSrcSpan' + , stripTicksTopHsExpr + ) where + +import GHC.Prelude as Prelude + +import GHC.Hs +import GHC.Unit + +import GHC.Core.Type +import GHC.Core.TyCon + +import GHC.Data.Maybe +import GHC.Data.FastString +import GHC.Data.SizedSeq + +import GHC.Driver.Flags (DumpFlag(..)) + +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Logger +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name.Set hiding (FreeVars) +import GHC.Types.Name +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State +import GHC.Types.Tickish +import GHC.Types.ProfAuto + +import Control.Monad +import Data.List (isSuffixOf, intersperse) +import Data.Foldable (toList) + +import Trace.Hpc.Mix + +import Data.Bifunctor (second) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Set (Set) +import qualified Data.Set as Set + +{- +************************************************************************ +* * +* The main function: addTicksToBinds +* * +************************************************************************ +-} + +-- | Configuration for compilation pass to add tick for instrumentation +-- to binding sites. +data TicksConfig = TicksConfig + { ticks_passes :: ![TickishType] + -- ^ What purposes do we need ticks for + + , ticks_profAuto :: !ProfAuto + -- ^ What kind of {-# SCC #-} to add automatically + + , ticks_countEntries :: !Bool + -- ^ Whether to count the entries to functions + -- + -- Requires extra synchronization which can vastly degrade + -- performance. + } + +data Tick = Tick + { tick_loc :: SrcSpan -- ^ Tick source span + , tick_path :: [String] -- ^ Path to the declaration + , tick_ids :: [OccName] -- ^ Identifiers being bound + , tick_label :: BoxLabel -- ^ Label for the tick counter + } + +addTicksToBinds + :: Logger + -> TicksConfig + -> Module + -> ModLocation -- ^ location of the current module + -> NameSet -- ^ Exported Ids. When we call addTicksToBinds, + -- isExportedId doesn't work yet (the desugarer + -- hasn't set it), so we have to work from this set. + -> [TyCon] -- ^ Type constructors in this module + -> LHsBinds GhcTc + -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick)) + +addTicksToBinds logger cfg + mod mod_loc exports tyCons binds + | let passes = ticks_passes cfg + , not (null passes) + , Just orig_file <- ml_hs_file mod_loc = do + + let orig_file2 = guessSourceFile binds orig_file + + tickPass tickish (binds,st) = + let env = TTE + { fileName = mkFastString orig_file2 + , declPath = [] + , tte_countEntries = ticks_countEntries cfg + , exports = exports + , inlines = emptyVarSet + , inScope = emptyVarSet + , blackList = Set.fromList $ + mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of + RealSrcSpan l _ -> Just l + UnhelpfulSpan _ -> Nothing) + tyCons + , density = mkDensity tickish $ ticks_profAuto cfg + , this_mod = mod + , tickishType = tickish + , recSelBinds = emptyVarEnv + } + (binds',_,st') = unTM (addTickLHsBinds binds) env st + in (binds', st') + + (binds1,st) = foldr tickPass (binds, initTTState) passes + + extendedMixEntries = ticks st + + putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell + (pprLHsBinds binds1) + + return (binds1, Just (orig_file2, extendedMixEntries)) + + | otherwise = return (binds, Nothing) + +guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath +guessSourceFile binds orig_file = + -- Try look for a file generated from a .hsc file to a + -- .hs file, by peeking ahead. + let top_pos = catMaybes $ foldr (\ (L pos _) rest -> + srcSpanFileName_maybe (locA pos) : rest) [] binds + in + case top_pos of + (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name + -> unpackFS file_name + _ -> orig_file + + +-- ----------------------------------------------------------------------------- +-- TickDensity + +-- | Where to insert ticks +data TickDensity + = TickForCoverage -- ^ for Hpc + | TickForBreakPoints -- ^ for GHCi + | TickAllFunctions -- ^ for -prof-auto-all + | TickTopFunctions -- ^ for -prof-auto-top + | TickExportedFunctions -- ^ for -prof-auto-exported + | TickCallSites -- ^ for stack tracing + deriving Eq + +mkDensity :: TickishType -> ProfAuto -> TickDensity +mkDensity tickish pa = case tickish of + HpcTicks -> TickForCoverage + SourceNotes -> TickForCoverage + Breakpoints -> TickForBreakPoints + ProfNotes -> + case pa of + ProfAutoAll -> TickAllFunctions + ProfAutoTop -> TickTopFunctions + ProfAutoExports -> TickExportedFunctions + ProfAutoCalls -> TickCallSites + _other -> panic "mkDensity" + +-- | Decide whether to add a tick to a binding or not. +shouldTickBind :: TickDensity + -> Bool -- ^ top level? + -> Bool -- ^ exported? + -> Bool -- ^ simple pat bind? + -> Bool -- ^ INLINE pragma? + -> Bool + +shouldTickBind density top_lev exported _simple_pat inline + = case density of + TickForBreakPoints -> False + -- we never add breakpoints to simple pattern bindings + -- (there's always a tick on the rhs anyway). + TickAllFunctions -> not inline + TickTopFunctions -> top_lev && not inline + TickExportedFunctions -> exported && not inline + TickForCoverage -> True + TickCallSites -> False + +shouldTickPatBind :: TickDensity -> Bool -> Bool +shouldTickPatBind density top_lev + = case density of + TickForBreakPoints -> False + TickAllFunctions -> True + TickTopFunctions -> top_lev + TickExportedFunctions -> False + TickForCoverage -> False + TickCallSites -> False + +-- Strip ticks HsExpr + +-- | Strip CoreTicks from an HsExpr +stripTicksTopHsExpr :: HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc) +stripTicksTopHsExpr (XExpr (HsTick t e)) = let (ts, body) = stripTicksTopHsExpr (unLoc e) + in (t:ts, body) +stripTicksTopHsExpr e = ([], e) + +-- ----------------------------------------------------------------------------- +-- Adding ticks to bindings + +addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) +addTickLHsBinds = mapM addTickLHsBind + +addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) +addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds + , abs_exports = abs_exports + }))) = + withEnv (add_rec_sels . add_inlines . add_exports) $ do + binds' <- addTickLHsBinds binds + return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' } + where + -- in AbsBinds, the Id on each binding is not the actual top-level + -- Id that we are defining, they are related by the abs_exports + -- field of AbsBinds. So if we're doing TickExportedFunctions we need + -- to add the local Ids to the set of exported Names so that we know to + -- tick the right bindings. + add_exports env = + env{ exports = exports env `extendNameSetList` + [ idName mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , idName pid `elemNameSet` (exports env) ] } + + -- See Note [inline sccs] + add_inlines env = + env{ inlines = inlines env `extendVarSetList` + [ mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , isInlinePragma (idInlinePragma pid) ] } + + add_rec_sels env = + env{ recSelBinds = recSelBinds env `extendVarEnvList` + [ (abe_mono, abe_poly) + | ABE{ abe_poly, abe_mono } <- abs_exports + , RecSelId{} <- [idDetails abe_poly] ] } + +addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do + let name = getOccString id + decl_path <- getPathEntry + density <- getDensity + + inline_ids <- liftM inlines getEnv + -- See Note [inline sccs] + let inline = isInlinePragma (idInlinePragma id) + || id `elemVarSet` inline_ids + + -- See Note [inline sccs] + tickish <- tickishType `liftM` getEnv + case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do + + -- See Note [Record-selector ticks] + selTick <- recSelTick id + case selTick of { Just tick -> tick_rec_sel tick; _ -> do + + (fvs, mg) <- + getFreeVars $ + addPathEntry name $ + addTickMatchGroup False matches + + blackListed <- isBlackListed (locA pos) + exported_names <- liftM exports getEnv + + -- We don't want to generate code for blacklisted positions + -- We don't want redundant ticks on simple pattern bindings + -- We don't want to tick non-exported bindings in TickExportedFunctions + let simple = matchGroupArity matches == 0 + -- A binding is a "simple pattern binding" if it is a + -- funbind with zero patterns + toplev = null decl_path + exported = idName id `elemNameSet` exported_names + + tick <- if not blackListed && + shouldTickBind density toplev exported simple inline + then + bindTick density name (locA pos) fvs + else + return Nothing + + let mbCons = maybe Prelude.id (:) + return $ L pos $ funBind { fun_matches = mg + , fun_ext = second (tick `mbCons`) (fun_ext funBind) } + } } + where + -- See Note [Record-selector ticks] + tick_rec_sel tick = + pure $ L pos $ funBind { fun_ext = second (tick :) (fun_ext funBind) } + + +-- Note [Record-selector ticks] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Users expect (see #17834) that accessing a record field by its name using +-- NamedFieldPuns or RecordWildCards will mark it as covered. This is very +-- reasonable, because otherwise the use of those two language features will +-- produce unnecessary noise in coverage reports, distracting from real +-- coverage problems. +-- +-- Because of that, GHC chooses to treat record selectors specially for +-- coverage purposes to improve the developer experience. +-- +-- This is done by keeping track of which 'Id's are effectively bound to +-- record fields (using NamedFieldPuns or RecordWildCards) in 'TickTransEnv's +-- 'recSelBinds', and making 'HsVar's corresponding to those fields tick the +-- appropriate box when executed. +-- +-- To enable that, we also treat 'FunBind's for record selector functions +-- specially. We only create a TopLevelBox for the record selector function, +-- skipping the ExpBox that'd normally be created. This simplifies the re-use +-- of ticks for the same record selector, and is done by not recursing into +-- the fun_matches match group for record selector functions. +-- +-- This scheme could be extended further in the future, making coverage for +-- constructor fields (named or even positional) mean that the field was +-- accessed at run-time. For the time being, we only cover NamedFieldPuns and +-- RecordWildCards binds to cover most practical use-cases while keeping it +-- simple. + +-- TODO: Revisit this +addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs + , pat_rhs = rhs + , pat_ext = (grhs_ty, initial_ticks)}))) = do + + let simplePatId = isSimplePat lhs + + -- TODO: better name for rhs's for non-simple patterns? + let name = maybe "(...)" getOccString simplePatId + + (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False False rhs + let pat' = pat { pat_rhs = rhs'} + + -- Should create ticks here? + density <- getDensity + decl_path <- getPathEntry + let top_lev = null decl_path + if not (shouldTickPatBind density top_lev) + then return (L pos pat') + else do + + -- Allocate the ticks + rhs_tick <- bindTick density name (locA pos) fvs + + let mbCons = maybe id (:) + (initial_rhs_ticks, initial_patvar_tickss) = initial_ticks + rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks + + patvar_tickss <- case simplePatId of + Just{} -> return initial_patvar_tickss + Nothing -> do + let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs) + patvar_ticks <- mapM (\v -> bindTick density v (locA pos) fvs) patvars + return + (zipWith mbCons patvar_ticks + (initial_patvar_tickss ++ repeat [])) + + return $ L pos $ pat' { pat_ext = (grhs_ty, (rhs_ticks, patvar_tickss)) } + +-- Only internal stuff, not from source, uses VarBind, so we ignore it. +addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind +addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind + +bindTick + :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish) +bindTick density name pos fvs = do + decl_path <- getPathEntry + let + toplev = null decl_path + count_entries = toplev || density == TickAllFunctions + top_only = density /= TickAllFunctions + box_label = if toplev then TopLevelBox [name] + else LocalBox (decl_path ++ [name]) + -- + allocATickBox box_label count_entries top_only pos fvs + + +-- Note [inline sccs] +-- ~~~~~~~~~~~~~~~~~~ +-- The reason not to add ticks to INLINE functions is that this is +-- sometimes handy for avoiding adding a tick to a particular function +-- (see #6131) +-- +-- So for now we do not add any ticks to INLINE functions at all. +-- +-- We used to use isAnyInlinePragma to figure out whether to avoid adding +-- ticks for this purpose. However, #12962 indicates that this contradicts +-- the documentation on profiling (which only mentions INLINE pragmas). +-- So now we're more careful about what we avoid adding ticks to. + +-- ----------------------------------------------------------------------------- +-- Decorate an LHsExpr with ticks + +-- selectively add ticks to interesting expressions +addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExpr e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | isGoodBreakExpr e0 -> tick_it + TickForCoverage | XExpr (ExpandedThingTc OrigStmt{} _) <- e0 -- expansion ticks are handled separately + -> dont_tick_it + | otherwise -> tick_it + TickCallSites | isCallSite e0 -> tick_it + _other -> dont_tick_it + where + tick_it = allocTickBox (ExpBox False) False False (locA pos) + $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- Add a tick to an expression which is the RHS of an equation or a binding. +-- We always consider these to be breakpoints, unless the expression is a 'let' +-- (because the body will definitely have a tick somewhere). ToDo: perhaps +-- we should treat 'case' and 'if' the same way? +addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprRHS e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it + TickForCoverage -> tick_it + TickCallSites | isCallSite e0 -> tick_it + _other -> dont_tick_it + where + tick_it = allocTickBox (ExpBox False) False False (locA pos) + $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- The inner expression of an evaluation context: +-- let binds in [], ( [] ) +-- we never tick these if we're doing HPC, but otherwise +-- we treat it like an ordinary expression. +addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprEvalInner e = do + d <- getDensity + case d of + TickForCoverage -> addTickLHsExprNever e + _otherwise -> addTickLHsExpr e + +-- | A let body is treated differently from addTickLHsExprEvalInner +-- above with TickForBreakPoints, because for breakpoints we always +-- want to tick the body, even if it is not a redex. See test +-- break012. This gives the user the opportunity to inspect the +-- values of the let-bound variables. +addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprLetBody e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it + _other -> addTickLHsExprEvalInner e + where + tick_it = allocTickBox (ExpBox False) False False (locA pos) + -- don't allow duplicates of this forced bp + $ withBlackListed (locA pos) + $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- version of addTick that does not actually add a tick, +-- because the scope of this tick is completely subsumed by +-- another. +addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprNever (L pos e0) = do + e1 <- addTickHsExpr e0 + return $ L pos e1 + +-- General heuristic: expressions which are calls (do not denote +-- values) are good break points. +isGoodBreakExpr :: HsExpr GhcTc -> Bool +isGoodBreakExpr (XExpr (ExpandedThingTc (OrigStmt{}) _)) = False +isGoodBreakExpr e = isCallSite e + +isCallSite :: HsExpr GhcTc -> Bool +isCallSite HsApp{} = True +isCallSite HsAppType{} = True +isCallSite HsCase{} = True +isCallSite (XExpr (ExpandedThingTc _ e)) + = isCallSite e + +-- NB: OpApp, SectionL, SectionR are all expanded out +isCallSite _ = False + +addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprOptAlt oneOfMany e@(L pos e0) + = ifDensity TickForCoverage + (allocTickBox (ExpBox oneOfMany) False False (locA pos) + $ addTickHsExpr e0) + (addTickLHsExpr e) + +addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addBinTickLHsExpr boxLabel e@(L pos e0) + = ifDensity TickForCoverage + (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0) + (addTickLHsExpr e) + + +-- ----------------------------------------------------------------------------- +-- Decorate the body of an HsExpr with ticks. +-- (Whether to put a tick around the whole expression was already decided, +-- in the addTickLHsExpr family of functions.) + +addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) +-- See Note [Record-selector ticks] +addTickHsExpr e@(HsVar _ (L _ id)) = + freeVar id >> recSelTick id >>= pure . maybe e wrap + where wrap tick = XExpr . HsTick tick . noLocA $ e +addTickHsExpr e@(HsIPVar {}) = return e +addTickHsExpr e@(HsOverLit {}) = return e +addTickHsExpr e@(HsOverLabel{}) = return e +addTickHsExpr e@(HsLit {}) = return e +addTickHsExpr e@(HsEmbTy {}) = return e +addTickHsExpr e@(HsHole {}) = return e +addTickHsExpr e@(HsQual {}) = return e +addTickHsExpr e@(HsForAll {}) = return e +addTickHsExpr e@(HsFunArr {}) = return e +addTickHsExpr (HsLam x v mg) = liftM (HsLam x v) + (addTickMatchGroup True mg) +addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1) + (addTickLHsExpr e2) +addTickHsExpr (HsAppType x e ty) = do + e' <- addTickLHsExprNever e + return (HsAppType x e' ty) +addTickHsExpr (OpApp fix e1 e2 e3) = + liftM4 OpApp + (return fix) + (addTickLHsExpr e1) + (addTickLHsExprNever e2) + (addTickLHsExpr e3) +addTickHsExpr (NegApp x e neg) = + liftM2 (NegApp x) + (addTickLHsExpr e) + (addTickSyntaxExpr hpcSrcSpan neg) +addTickHsExpr (HsPar x e) = do + e' <- addTickLHsExprEvalInner e + return (HsPar x e') +addTickHsExpr (SectionL x e1 e2) = + liftM2 (SectionL x) + (addTickLHsExpr e1) + (addTickLHsExprNever e2) +addTickHsExpr (SectionR x e1 e2) = + liftM2 (SectionR x) + (addTickLHsExprNever e1) + (addTickLHsExpr e2) +addTickHsExpr (ExplicitTuple x es boxity) = + liftM2 (ExplicitTuple x) + (mapM addTickTupArg es) + (return boxity) +addTickHsExpr (ExplicitSum ty tag arity e) = do + e' <- addTickLHsExpr e + return (ExplicitSum ty tag arity e') +addTickHsExpr (HsCase x e mgs) = + liftM2 (HsCase x) + (addTickLHsExpr e) -- not an EvalInner; e might not necessarily + -- be evaluated. + (addTickMatchGroup False mgs) + +addTickHsExpr (HsIf x e1 e2 e3) = + liftM3 (HsIf x) + (addBinTickLHsExpr (BinBox CondBinBox) e1) + (addTickLHsExprOptAlt True e2) + (addTickLHsExprOptAlt True e3) +addTickHsExpr (HsMultiIf ty alts) + = do { let isOneOfMany = case alts of { (_ :| []) -> False; _ -> True; } + ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts + ; return $ HsMultiIf ty alts' } +addTickHsExpr (HsLet x binds e) = + bindLocals binds $ do + binds' <- addTickHsLocalBinds binds -- to think about: !patterns. + e' <- addTickLHsExprLetBody e + return (HsLet x binds' e') +addTickHsExpr (ExplicitList ty es) + = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es) + +addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e + +addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) + = do { rec_binds' <- addTickHsRecordBinds rec_binds + ; return (expr { rcon_flds = rec_binds' }) } + +addTickHsExpr expr@(RecordUpd { rupd_expr = e + , rupd_flds = upd@(RegularRecUpdFields { recUpdFields = flds }) }) + = do { e' <- addTickLHsExpr e + ; flds' <- mapM addTickHsRecField flds + ; return (expr { rupd_expr = e', rupd_flds = upd { recUpdFields = flds' } }) } +addTickHsExpr expr@(RecordUpd { rupd_expr = e + , rupd_flds = upd@(OverloadedRecUpdFields { olRecUpdFields = flds } ) }) + = do { e' <- addTickLHsExpr e + ; flds' <- mapM addTickHsRecField flds + ; return (expr { rupd_expr = e', rupd_flds = upd { olRecUpdFields = flds' } }) } + +addTickHsExpr (ExprWithTySig x e ty) = + liftM3 ExprWithTySig + (return x) + (addTickLHsExprNever e) -- No need to tick the inner expression + -- for expressions with signatures + (return ty) +addTickHsExpr (ArithSeq ty wit arith_seq) = + liftM3 ArithSeq + (return ty) + (addTickWit wit) + (addTickArithSeqInfo arith_seq) + where addTickWit Nothing = return Nothing + addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl + return (Just fl') + +addTickHsExpr (HsPragE x p e) = + liftM (HsPragE x p) (addTickLHsExpr e) +addTickHsExpr e@(HsTypedBracket {}) = return e +addTickHsExpr e@(HsUntypedBracket{}) = return e +addTickHsExpr e@(HsTypedSplice{}) = return e +addTickHsExpr e@(HsUntypedSplice{}) = return e +addTickHsExpr e@(HsGetField {}) = return e +addTickHsExpr e@(HsProjection {}) = return e +addTickHsExpr (HsProc x pat cmdtop) = + bindLocals pat $ + liftM2 (HsProc x) + (addTickLPat pat) + (traverse (addTickHsCmdTop) cmdtop) +addTickHsExpr (XExpr (WrapExpr w e)) = + liftM (XExpr . WrapExpr w) $ + (addTickHsExpr e) -- Explicitly no tick on inside +addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e + +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) + +addTickHsExpr e@(XExpr (HsRecSelTc (FieldOcc _ id))) = do freeVar (unLoc id); return e + +addTickHsExpr (HsDo srcloc cxt (L l stmts)) + = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) + ; return (HsDo srcloc cxt (L l stmts')) } + where + forQual = case cxt of + ListComp -> Just $ BinBox QualBinBox + _ -> Nothing + +addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc) +addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of + -- We always want statements to get a tick, so we can step over each one. + -- To avoid duplicates we blacklist SrcSpans we already inserted here. + OrigStmt (L pos _) -> do_tick_black pos + _ -> skip + where + skip = addTickHsExpr e + do_tick_black pos = do + d <- getDensity + case d of + TickForCoverage -> tick_it_black pos + TickForBreakPoints -> tick_it_black pos + _ -> skip + tick_it_black pos = + unLoc <$> allocTickBox (ExpBox False) False False (locA pos) + (withBlackListed (locA pos) $ + addTickHsExpr e) + +addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) +addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e + ; return (Present x e') } +addTickTupArg (Missing ty) = return (Missing ty) + + +addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) + -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) +addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches, mg_ext = ctxt }) = do + let isOneOfMany = matchesOneOfMany matches + isDoExp = isDoExpansionGenerated $ mg_origin ctxt + matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam isDoExp)) matches + return $ mg { mg_alts = L l matches' } + +addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} -> Match GhcTc (LHsExpr GhcTc) + -> TM (Match GhcTc (LHsExpr GhcTc)) +addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = L _ pats + , m_grhss = gRHSs }) = + bindLocals pats $ do + gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs + return $ match { m_grhss = gRHSs' } + +addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) + -> TM (GRHSs GhcTc (LHsExpr GhcTc)) +addTickGRHSs isOneOfMany isLambda isDoExp (GRHSs x guarded local_binds) = + bindLocals local_binds $ do + local_binds' <- addTickHsLocalBinds local_binds + guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp)) guarded + return $ GRHSs x guarded' local_binds' + +addTickGRHS :: Bool -> Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) + -> TM (GRHS GhcTc (LHsExpr GhcTc)) +addTickGRHS isOneOfMany isLambda isDoExp (GRHS x stmts expr) = do + (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts + (addTickGRHSBody isOneOfMany isLambda isDoExp expr) + return $ GRHS x stmts' expr' + +addTickGRHSBody :: Bool -> Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickGRHSBody isOneOfMany isLambda isDoExp expr@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints + | isDoExp -- ticks for do-expansions are handled by `addTickHsExpanded` + -> addTickLHsExprNever expr + | otherwise + -> addTickLHsExprRHS expr + TickForCoverage + | isDoExp -- ticks for do-expansions are handled by `addTickHsExpanded` + -> addTickLHsExprNever expr + | otherwise + -> addTickLHsExprOptAlt isOneOfMany expr + TickAllFunctions | isLambda -> + addPathEntry "\\" $ + allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $ + addTickHsExpr e0 + _otherwise -> + addTickLHsExprRHS expr + +addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] + -> TM [ExprLStmt GhcTc] +addTickLStmts isGuard stmts = do + (stmts, _) <- addTickLStmts' isGuard stmts (return ()) + return stmts + +addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a + -> TM ([ExprLStmt GhcTc], a) +addTickLStmts' isGuard lstmts res + = bindLocals lstmts $ + do { lstmts' <- mapM (traverse (addTickStmt isGuard)) lstmts + ; a <- res + ; return (lstmts', a) } + +addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) + -> TM (Stmt GhcTc (LHsExpr GhcTc)) +addTickStmt _isGuard (LastStmt x e noret ret) = + liftM3 (LastStmt x) + (addTickLHsExpr e) + (pure noret) + (addTickSyntaxExpr hpcSrcSpan ret) +addTickStmt _isGuard (BindStmt xbs pat e) = + bindLocals pat $ + liftM4 (\b f -> BindStmt $ XBindStmtTc + { xbstc_bindOp = b + , xbstc_boundResultType = xbstc_boundResultType xbs + , xbstc_boundResultMult = xbstc_boundResultMult xbs + , xbstc_failOp = f + }) + (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs)) + (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs)) + (addTickLPat pat) + (addTickLHsExprRHS e) +addTickStmt isGuard (BodyStmt x e bind' guard') = + liftM3 (BodyStmt x) + (addTick isGuard e) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') +addTickStmt _isGuard (LetStmt x binds) = + liftM (LetStmt x) + (addTickHsLocalBinds binds) +addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = + liftM3 (ParStmt x) + (mapM (addTickStmtAndBinders isGuard) pairs) + (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr)) + (addTickSyntaxExpr hpcSrcSpan bindExpr) + +addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts + , trS_by = by, trS_using = using + , trS_ret = returnExpr, trS_bind = bindExpr + , trS_fmap = liftMExpr }) = do + t_s <- addTickLStmts isGuard stmts + t_y <- traverse addTickLHsExprRHS by + t_u <- addTickLHsExprRHS using + t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr + t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr + t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr)) + return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u + , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } + +addTickStmt isGuard stmt@(RecStmt {}) + = do { stmts' <- addTickLStmts isGuard (unLoc $ recS_stmts stmt) + ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) + ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) + ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) + ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret' + , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } + +addTickStmt isGuard (XStmtLR (ApplicativeStmt body_ty args mb_join)) = do + args' <- mapM (addTickApplicativeArg isGuard) args + return (XStmtLR (ApplicativeStmt body_ty args' mb_join)) + +addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e + | otherwise = addTickLHsExprRHS e + +addTickApplicativeArg + :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc) +addTickApplicativeArg isGuard (op, arg) = + liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) + where + addTickArg (ApplicativeArgOne m_fail pat expr isBody) = + bindLocals pat $ + ApplicativeArgOne + <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail + <*> addTickLPat pat + <*> addTickLHsExpr expr + <*> pure isBody + addTickArg (ApplicativeArgMany x stmts ret pat ctxt) = + bindLocals pat $ + ApplicativeArgMany x + <$> addTickLStmts isGuard stmts + <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret)) + <*> addTickLPat pat + <*> pure ctxt + +addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc + -> TM (ParStmtBlock GhcTc GhcTc) +addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = + liftM3 (ParStmtBlock x) + (addTickLStmts isGuard stmts) + (return ids) + (addTickSyntaxExpr hpcSrcSpan returnExpr) + +addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) +addTickHsLocalBinds (HsValBinds x binds) = + liftM (HsValBinds x) + (addTickHsValBinds binds) +addTickHsLocalBinds (HsIPBinds x binds) = + liftM (HsIPBinds x) + (addTickHsIPBinds binds) +addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) + +addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) + -> TM (HsValBindsLR GhcTc (GhcPass b)) +addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do + b <- liftM2 NValBinds + (mapM (\ (rec,binds') -> + liftM2 (,) + (return rec) + (addTickLHsBinds binds')) + binds) + (return sigs) + return $ XValBindsLR b +addTickHsValBinds _ = panic "addTickHsValBinds" + +addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) +addTickHsIPBinds (IPBinds dictbinds ipbinds) = + liftM2 IPBinds + (return dictbinds) + (mapM (traverse (addTickIPBind)) ipbinds) + +addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) +addTickIPBind (IPBind x nm e) = + liftM (IPBind x nm) + (addTickLHsExpr e) + +-- There is no location here, so we might need to use a context location?? +addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) +addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do + x' <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan pos) x)) + return $ syn { syn_expr = x' } +addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc + +-- we do not walk into patterns. +addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) +addTickLPat pat = return pat + +addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) +addTickHsCmdTop (HsCmdTop x cmd) = + liftM2 HsCmdTop + (return x) + (addTickLHsCmd cmd) + +addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) +addTickLHsCmd (L pos c0) = do + c1 <- addTickHsCmd c0 + return $ L pos c1 + +addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) +addTickHsCmd (HsCmdLam x lam_variant mgs) = + liftM (HsCmdLam x lam_variant) (addTickCmdMatchGroup mgs) +addTickHsCmd (HsCmdApp x c e) = + liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) +{- +addTickHsCmd (OpApp e1 c2 fix c3) = + liftM4 OpApp + (addTickLHsExpr e1) + (addTickLHsCmd c2) + (return fix) + (addTickLHsCmd c3) +-} +addTickHsCmd (HsCmdPar x e) = do + e' <- addTickLHsCmd e + return (HsCmdPar x e') +addTickHsCmd (HsCmdCase x e mgs) = + liftM2 (HsCmdCase x) + (addTickLHsExpr e) + (addTickCmdMatchGroup mgs) +addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = + liftM3 (HsCmdIf x cnd) + (addBinTickLHsExpr (BinBox CondBinBox) e1) + (addTickLHsCmd c2) + (addTickLHsCmd c3) +addTickHsCmd (HsCmdLet x binds c) = + bindLocals binds $ do + binds' <- addTickHsLocalBinds binds -- to think about: !patterns. + c' <- addTickLHsCmd c + return (HsCmdLet x binds' c') +addTickHsCmd (HsCmdDo srcloc (L l stmts)) + = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) + ; return (HsCmdDo srcloc (L l stmts')) } + +addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = + liftM5 HsCmdArrApp + (return arr_ty) + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (return ty1) + (return lr) +addTickHsCmd (HsCmdArrForm x e f cmdtop) = + liftM3 (HsCmdArrForm x) + (addTickLHsExpr e) + (return f) + (mapM (traverse (addTickHsCmdTop)) cmdtop) + +addTickHsCmd (XCmd (HsWrap w cmd)) = + liftM XCmd $ + liftM (HsWrap w) (addTickHsCmd cmd) + +-- Others should never happen in a command context. +--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) + +addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) + -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) +addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do + matches' <- mapM (traverse addTickCmdMatch) matches + return $ mg { mg_alts = L l matches' } + +addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) +addTickCmdMatch match@(Match { m_pats = L _ pats, m_grhss = gRHSs }) = + bindLocals pats $ do + gRHSs' <- addTickCmdGRHSs gRHSs + return $ match { m_grhss = gRHSs' } + +addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) +addTickCmdGRHSs (GRHSs x guarded local_binds) = + bindLocals local_binds $ do + local_binds' <- addTickHsLocalBinds local_binds + guarded' <- mapM (traverse addTickCmdGRHS) guarded + return $ GRHSs x guarded' local_binds' + +addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) +-- The *guards* are *not* Cmds, although the body is +-- C.f. addTickGRHS for the BinBox stuff +addTickCmdGRHS (GRHS x stmts cmd) + = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) + stmts (addTickLHsCmd cmd) + ; return $ GRHS x stmts' expr' } + +addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] + -> TM [LStmt GhcTc (LHsCmd GhcTc)] +addTickLCmdStmts stmts = do + (stmts, _) <- addTickLCmdStmts' stmts (return ()) + return stmts + +addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a + -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) +addTickLCmdStmts' lstmts res + = bindLocals lstmts $ do + lstmts' <- mapM (traverse addTickCmdStmt) lstmts + a <- res + return (lstmts', a) + +addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) +addTickCmdStmt (BindStmt x pat c) = + bindLocals pat $ + liftM2 (BindStmt x) + (addTickLPat pat) + (addTickLHsCmd c) +addTickCmdStmt (LastStmt x c noret ret) = + liftM3 (LastStmt x) + (addTickLHsCmd c) + (pure noret) + (addTickSyntaxExpr hpcSrcSpan ret) +addTickCmdStmt (BodyStmt x c bind' guard') = + liftM3 (BodyStmt x) + (addTickLHsCmd c) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') +addTickCmdStmt (LetStmt x binds) = + liftM (LetStmt x) + (addTickHsLocalBinds binds) +addTickCmdStmt stmt@(RecStmt {}) + = do { stmts' <- addTickLCmdStmts (unLoc $ recS_stmts stmt) + ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) + ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) + ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) + ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret' + , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } +addTickCmdStmt (XStmtLR (ApplicativeStmt{})) = + panic "ToDo: addTickCmdStmt ApplicativeLastStmt" + +-- Others should never happen in a command context. +addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) + +addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc) +addTickHsRecordBinds (HsRecFields x fields dd) + = do { fields' <- mapM addTickHsRecField fields + ; return (HsRecFields x fields' dd) } + +addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc) + -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc)) +addTickHsRecField (L l (HsFieldBind x id expr pun)) + = do { expr' <- addTickLHsExpr expr + ; return (L l (HsFieldBind x id expr' pun)) } + +addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) +addTickArithSeqInfo (From e1) = + liftM From + (addTickLHsExpr e1) +addTickArithSeqInfo (FromThen e1 e2) = + liftM2 FromThen + (addTickLHsExpr e1) + (addTickLHsExpr e2) +addTickArithSeqInfo (FromTo e1 e2) = + liftM2 FromTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) +addTickArithSeqInfo (FromThenTo e1 e2 e3) = + liftM3 FromThenTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (addTickLHsExpr e3) + +data TickTransState = TT { ticks :: !(SizedSeq Tick) + , ccIndices :: !CostCentreState + , recSelTicks :: !(IdEnv CoreTickish) + } + +initTTState :: TickTransState +initTTState = TT { ticks = emptySS + , ccIndices = newCostCentreState + , recSelTicks = emptyVarEnv + } + +addMixEntry :: Tick -> TM Int +addMixEntry ent = do + c <- fromIntegral . sizeSS . ticks <$> getState + setState $ \st -> + st { ticks = addToSS (ticks st) ent + } + return c + +addRecSelTick :: Id -> CoreTickish -> TM () +addRecSelTick sel tick = + setState $ \s -> s{ recSelTicks = extendVarEnv (recSelTicks s) sel tick } + +data TickTransEnv = TTE { fileName :: FastString + , density :: TickDensity + , tte_countEntries :: !Bool + -- ^ Whether the number of times functions are + -- entered should be counted. + , exports :: NameSet + , inlines :: VarSet + , declPath :: [String] + , inScope :: VarSet + , blackList :: Set RealSrcSpan + , this_mod :: Module + , tickishType :: TickishType + , recSelBinds :: IdEnv Id + } + +-- deriving Show + +-- | Reasons why we need ticks, +data TickishType + -- | For profiling + = ProfNotes + -- | For Haskell Program Coverage + | HpcTicks + -- | For ByteCode interpreter break points + | Breakpoints + -- | For source notes + | SourceNotes + deriving (Eq) + +-- | Tickishs that only make sense when their source code location +-- refers to the current file. This might not always be true due to +-- LINE pragmas in the code - which would confuse at least HPC. +tickSameFileOnly :: TickishType -> Bool +tickSameFileOnly HpcTicks = True +tickSameFileOnly _other = False + +type FreeVars = OccEnv Id +noFVs :: FreeVars +noFVs = emptyOccEnv + +-- Note [freevars] +-- ~~~~~~~~~~~~~~~ +-- For breakpoints we want to collect the free variables of an +-- expression for pinning on the HsTick. We don't want to collect +-- *all* free variables though: in particular there's no point pinning +-- on free variables that are will otherwise be in scope at the GHCi +-- prompt, which means all top-level bindings. Unfortunately detecting +-- top-level bindings isn't easy (collectHsBindsBinders on the top-level +-- bindings doesn't do it), so we keep track of a set of "in-scope" +-- variables in addition to the free variables, and the former is used +-- to filter additions to the latter. This gives us complete control +-- over what free variables we track. + +newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) } + deriving (Functor) + -- a combination of a state monad (TickTransState) and a writer + -- monad (FreeVars). + +instance Applicative TM where + pure a = TM $ \ _env st -> (a,noFVs,st) + (<*>) = ap + +instance Monad TM where + (TM m) >>= k = TM $ \ env st -> + case m env st of + (r1,fv1,st1) -> + case unTM (k r1) env st1 of + (r2,fv2,st2) -> + (r2, fv1 `plusOccEnv` fv2, st2) + + +-- | Get the next HPC cost centre index for a given centre name +getCCIndexM :: FastString -> TM CostCentreIndex +getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $ + ccIndices st + in (idx, noFVs, st { ccIndices = is' }) + +getState :: TM TickTransState +getState = TM $ \ _ st -> (st, noFVs, st) + +setState :: (TickTransState -> TickTransState) -> TM () +setState f = TM $ \ _ st -> ((), noFVs, f st) + +getEnv :: TM TickTransEnv +getEnv = TM $ \ env st -> (env, noFVs, st) + +withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a +withEnv f (TM m) = TM $ \ env st -> + case m (f env) st of + (a, fvs, st') -> (a, fvs, st') + +getDensity :: TM TickDensity +getDensity = TM $ \env st -> (density env, noFVs, st) + +ifDensity :: TickDensity -> TM a -> TM a -> TM a +ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el + +getFreeVars :: TM a -> TM (FreeVars, a) +getFreeVars (TM m) + = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st') + +freeVar :: Id -> TM () +freeVar id = TM $ \ env st -> + if id `elemVarSet` inScope env + then ((), unitOccEnv (nameOccName (idName id)) id, st) + else ((), noFVs, st) + +addPathEntry :: String -> TM a -> TM a +addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] }) + +getPathEntry :: TM [String] +getPathEntry = declPath `liftM` getEnv + +getFileName :: TM FastString +getFileName = fileName `liftM` getEnv + +isGoodSrcSpan' :: SrcSpan -> Bool +isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos +isGoodSrcSpan' (UnhelpfulSpan _) = False + +isGoodTickSrcSpan :: SrcSpan -> TM Bool +isGoodTickSrcSpan pos = do + file_name <- getFileName + tickish <- tickishType `liftM` getEnv + let need_same_file = tickSameFileOnly tickish + same_file = Just file_name == srcSpanFileName_maybe pos + isBL <- isBlackListed pos + return (isGoodSrcSpan' pos && not isBL && (not need_same_file || same_file)) + +ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a +ifGoodTickSrcSpan pos then_code else_code = do + good <- isGoodTickSrcSpan pos + if good then then_code else else_code + +bindLocals :: (CollectBinders bndr, CollectFldBinders bndr) => bndr -> TM a -> TM a +bindLocals from (TM m) = TM $ \env st -> + case m (with_bnds env) st of + (r, fv, st') -> (r, fv `delListFromOccEnv` (map (nameOccName . idName) new_bnds), st') + where with_bnds e = e{ inScope = inScope e `extendVarSetList` new_bnds + , recSelBinds = recSelBinds e `plusVarEnv` collectFldBinds from } + new_bnds = collectBinds from + +withBlackListed :: SrcSpan -> TM a -> TM a +withBlackListed (RealSrcSpan ss _) = withEnv (\ env -> env { blackList = Set.insert ss (blackList env) }) +withBlackListed (UnhelpfulSpan _) = id + +isBlackListed :: SrcSpan -> TM Bool +isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st) +isBlackListed (UnhelpfulSpan _) = return False + +-- the tick application inherits the source position of its +-- expression argument to support nested box allocations +allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) +allocTickBox boxLabel countEntries topOnly pos m + = ifGoodTickSrcSpan pos good_case skip_case + where + this_loc = L (noAnnSrcSpan pos) + skip_case = do + e <- m + return (this_loc e) + good_case = do + (fvs, e) <- getFreeVars m + env <- getEnv + tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) + return (this_loc (XExpr $ HsTick tickish $ this_loc e)) + +recSelTick :: Id -> TM (Maybe CoreTickish) +recSelTick id = ifDensity TickForCoverage maybe_tick (pure Nothing) + where + maybe_tick = getEnv >>= + maybe (pure Nothing) tick . (`lookupVarEnv` id) . recSelBinds + tick sel = getState >>= + maybe (alloc sel) (pure . Just) . (`lookupVarEnv` sel) . recSelTicks + alloc sel = allocATickBox (box sel) False False (getSrcSpan sel) noFVs + >>= traverse (\t -> t <$ addRecSelTick sel t) + box sel = TopLevelBox [getOccString sel] + +-- the tick application inherits the source position of its +-- expression argument to support nested box allocations +allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars + -> TM (Maybe CoreTickish) +allocATickBox boxLabel countEntries topOnly pos fvs = + ifGoodTickSrcSpan pos (do + let + mydecl_path = case boxLabel of + TopLevelBox x -> x + LocalBox xs -> xs + _ -> panic "allocATickBox" + tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path + return (Just tickish) + ) (return Nothing) + + +mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] + -> TM CoreTickish +mkTickish boxLabel countEntries topOnly pos fvs decl_path = do + + let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs + -- unlifted types cause two problems here: + -- * we can't bind them at the GHCi prompt + -- (bindLocalsAtBreakpoint already filters them out), + -- * the simplifier might try to substitute a literal for + -- the Id, and we can't handle that. + + me = Tick + { tick_loc = pos + , tick_path = decl_path + , tick_ids = map (nameOccName.idName) ids + , tick_label = boxLabel + } + + cc_name | topOnly = mkFastString $ head decl_path + | otherwise = mkFastString $ concat (intersperse "." decl_path) + + env <- getEnv + case tickishType env of + HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me + + ProfNotes -> do + flavour <- mkHpcCCFlavour <$> getCCIndexM cc_name + let cc = mkUserCC cc_name (this_mod env) pos flavour + count = countEntries && tte_countEntries env + return $ ProfNote cc count True{-scopes-} + + Breakpoints -> do + i <- addMixEntry me + pure (Breakpoint noExtField (BreakpointId (this_mod env) i) ids) + + SourceNotes | RealSrcSpan pos' _ <- pos -> + return $ SourceNote pos' $ LexicalFastString cc_name + + _otherwise -> panic "mkTickish: bad source span!" + + +allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) +allocBinTickBox boxLabel pos m = do + env <- getEnv + case tickishType env of + HpcTicks -> do e <- liftM (L (noAnnSrcSpan pos)) m + ifGoodTickSrcSpan pos + (mkBinTickBoxHpc boxLabel pos e) + (return e) + _other -> allocTickBox (ExpBox False) False False pos m + +mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc + -> TM (LHsExpr GhcTc) +mkBinTickBoxHpc boxLabel pos e = do + env <- getEnv + binTick <- HsBinTick + <$> addMixEntry (Tick { tick_loc = pos + , tick_path = declPath env + , tick_ids = [] + , tick_label = boxLabel True + }) + <*> addMixEntry (Tick { tick_loc = pos + , tick_path = declPath env + , tick_ids = [] + , tick_label = boxLabel False + }) + <*> pure e + tick <- HpcTick (this_mod env) + <$> addMixEntry (Tick { tick_loc = pos + , tick_path = declPath env + , tick_ids = [] + , tick_label = ExpBox False + }) + let pos' = noAnnSrcSpan pos + return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick)) + +hpcSrcSpan :: SrcSpan +hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") + +matchesOneOfMany :: [LMatch GhcTc body] -> Bool +matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 + where + matchCount :: LMatch GhcTc body -> Int + matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) + = length grhss + +-- | Convenience class used by 'bindLocals' to collect new bindings from +-- various parts of he AST. Just delegates to +-- 'collect{Pat,Pats,Local,LStmts}Binders' from 'GHC.Hs.Utils' as appropriate. +class CollectBinders a where + collectBinds :: a -> [Id] + +-- | Variant of 'CollectBinders' which collects information on which locals +-- are bound to record fields (currently only via 'RecordWildCards' or +-- 'NamedFieldPuns') to enable better coverage support for record selectors. +-- +-- See Note [Record-selector ticks]. +class CollectFldBinders a where + collectFldBinds :: a -> IdEnv Id + +instance CollectBinders (LocatedA (Pat GhcTc)) where + collectBinds = collectPatBinders CollNoDictBinders +instance CollectBinders [LocatedA (Pat GhcTc)] where + collectBinds = collectPatsBinders CollNoDictBinders +instance CollectBinders (HsLocalBinds GhcTc) where + collectBinds = collectLocalBinders CollNoDictBinders +instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsExpr GhcTc)))] where + collectBinds = collectLStmtsBinders CollNoDictBinders +instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsCmd GhcTc)))] where + collectBinds = collectLStmtsBinders CollNoDictBinders + +instance (CollectFldBinders a) => CollectFldBinders [a] where + collectFldBinds = foldr (flip plusVarEnv . collectFldBinds) emptyVarEnv +instance (CollectFldBinders e) => CollectFldBinders (GenLocated l e) where + collectFldBinds = collectFldBinds . unLoc +instance CollectFldBinders (Pat GhcTc) where + collectFldBinds ConPat{ pat_args = RecCon HsRecFields{ rec_flds, rec_dotdot } } = + collectFldBinds rec_flds `plusVarEnv` plusVarEnvList (zipWith fld_bnds [0..] rec_flds) + where n_explicit | Just (L _ (RecFieldsDotDot n)) <- rec_dotdot = n + | otherwise = length rec_flds + fld_bnds n (L _ HsFieldBind{ hfbLHS = L _ FieldOcc{ foLabel = L _ sel } + , hfbRHS = L _ (VarPat _ (L _ var)) + , hfbPun }) + | hfbPun || n >= n_explicit = unitVarEnv var sel + fld_bnds _ _ = emptyVarEnv + collectFldBinds ConPat{ pat_args = PrefixCon pats } = collectFldBinds pats + collectFldBinds ConPat{ pat_args = InfixCon p1 p2 } = collectFldBinds [p1, p2] + collectFldBinds (LazyPat _ pat) = collectFldBinds pat + collectFldBinds (BangPat _ pat) = collectFldBinds pat + collectFldBinds (AsPat _ _ pat) = collectFldBinds pat + collectFldBinds (ViewPat _ _ pat) = collectFldBinds pat + collectFldBinds (ParPat _ pat) = collectFldBinds pat + collectFldBinds (ListPat _ pats) = collectFldBinds pats + collectFldBinds (TuplePat _ pats _) = collectFldBinds pats + collectFldBinds (SumPat _ pats _ _) = collectFldBinds pats + collectFldBinds (SigPat _ pat _) = collectFldBinds pat + collectFldBinds (XPat exp) = collectFldBinds exp + collectFldBinds VarPat{} = emptyVarEnv + collectFldBinds WildPat{} = emptyVarEnv + collectFldBinds OrPat{} = emptyVarEnv + collectFldBinds LitPat{} = emptyVarEnv + collectFldBinds NPat{} = emptyVarEnv + collectFldBinds NPlusKPat{} = emptyVarEnv + collectFldBinds SplicePat{} = emptyVarEnv + collectFldBinds EmbTyPat{} = emptyVarEnv + collectFldBinds InvisPat{} = emptyVarEnv +instance (CollectFldBinders r) => CollectFldBinders (HsFieldBind l r) where + collectFldBinds = collectFldBinds . hfbRHS +instance CollectFldBinders XXPatGhcTc where + collectFldBinds (CoPat _ pat _) = collectFldBinds pat + collectFldBinds (ExpansionPat _ pat) = collectFldBinds pat +instance CollectFldBinders (HsLocalBinds GhcTc) where + collectFldBinds (HsValBinds _ bnds) = collectFldBinds bnds + collectFldBinds HsIPBinds{} = emptyVarEnv + collectFldBinds EmptyLocalBinds{} = emptyVarEnv +instance CollectFldBinders (HsValBinds GhcTc) where + collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds + collectFldBinds (XValBindsLR (NValBinds bnds _)) = collectFldBinds (map snd bnds) +instance CollectFldBinders (HsBind GhcTc) where + collectFldBinds PatBind{ pat_lhs } = collectFldBinds pat_lhs + collectFldBinds (XHsBindsLR AbsBinds{ abs_exports, abs_binds }) = + mkVarEnv [ (abe_poly, sel) + | ABE{ abe_poly, abe_mono } <- abs_exports + , Just sel <- [lookupVarEnv monos abe_mono] ] + where monos = collectFldBinds abs_binds + collectFldBinds VarBind{} = emptyVarEnv + collectFldBinds FunBind{} = emptyVarEnv + collectFldBinds PatSynBind{} = emptyVarEnv +instance CollectFldBinders (Stmt GhcTc e) where + collectFldBinds (BindStmt _ pat _) = collectFldBinds pat + collectFldBinds (LetStmt _ bnds) = collectFldBinds bnds + collectFldBinds (ParStmt _ xs _ _) = collectFldBinds [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss] + collectFldBinds TransStmt{ trS_stmts } = collectFldBinds trS_stmts + collectFldBinds RecStmt{ recS_stmts } = collectFldBinds recS_stmts + collectFldBinds (XStmtLR (ApplicativeStmt _ args _)) = collectFldBinds (map snd args) + collectFldBinds LastStmt{} = emptyVarEnv + collectFldBinds BodyStmt{} = emptyVarEnv +instance CollectFldBinders (ApplicativeArg GhcTc) where + collectFldBinds ApplicativeArgOne{ app_arg_pattern } = collectFldBinds app_arg_pattern + collectFldBinds ApplicativeArgMany{ bv_pattern } = collectFldBinds bv_pattern diff --git a/GHC/HsToCore/Types.hs b/GHC/HsToCore/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Types.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TypeFamilies, UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + -- Don't warn that `type instance DsForeignsHooks = ...` + -- is an orphan; see Note [The Decoupling Abstract Data Hack] + -- in GHC.Driver.Hooks + +-- | Various types used during desugaring. +module GHC.HsToCore.Types ( + DsM, DsLclEnv(..), DsGblEnv(..), + DsMetaEnv, DsMetaVal(..), CompleteMatches + ) where + +import GHC.Prelude (Int) + +import Data.IORef + +import GHC.Types.CostCentre.State +import GHC.Types.Error +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Name.Reader (GlobalRdrEnv) + +import GHC.Hs (LForeignDecl, HsExpr, GhcTc) + +import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv) + +import GHC.HsToCore.Pmc.Types (Nablas) +import GHC.HsToCore.Errors.Types + +import GHC.Core (CoreExpr) +import GHC.Core.FamInstEnv +import GHC.Utils.Outputable as Outputable +import GHC.Unit.Module +import GHC.Driver.Hooks (DsForeignsHook) +import GHC.Data.OrdList (OrdList) + +import GHC.Types.ForeignStubs (ForeignStubs) +import GHC.Types.CompleteMatch + +import Data.Maybe( Maybe ) + +{- +************************************************************************ +* * + Desugarer monad +* * +************************************************************************ + +Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around +a @UniqueSupply@ and some annotations, which +presumably include source-file location information: +-} + +-- | Global read-only context and state of the desugarer. +-- The statefulness is implemented through 'IORef's. +data DsGblEnv + = DsGblEnv + { ds_mod :: Module -- For SCC profiling + , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env + , ds_gbl_rdr_env :: GlobalRdrEnv -- needed only for the following reasons: + -- - to know what newtype constructors are in scope + -- - to check whether all members of a COMPLETE pragma are in scope + , ds_name_ppr_ctx :: NamePprCtx + , ds_msgs :: IORef (Messages DsMessage) -- Diagnostic messages + , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, + -- possibly-imported things + , ds_complete_matches :: DsCompleteMatches + -- Additional complete pattern matches + , ds_cc_st :: IORef CostCentreState + -- Tracking indices for cost centre annotations + , ds_next_wrapper_num :: IORef (ModuleEnv Int) + -- ^ See Note [Generating fresh names for FFI wrappers] + } + +instance ContainsModule DsGblEnv where + extractModule = ds_mod + +-- | Local state of the desugarer, extended as we lexically descend +data DsLclEnv + = DsLclEnv + { dsl_meta :: DsMetaEnv -- ^ Template Haskell bindings + , dsl_loc :: RealSrcSpan -- ^ To put in pattern-matching error msgs + , dsl_nablas :: Nablas + -- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc". + -- The set of reaching values Nablas is augmented as we walk inwards, refined + -- through each pattern match in turn + + , dsl_unspecables :: Maybe VarSet + -- ^ See Note [Desugaring non-canonical evidence] + -- This field collects all un-specialisable evidence variables in scope. + -- Nothing <=> don't collect this info (used for the LHS of Rules) + } + +-- Inside [| |] brackets, the desugarer looks +-- up variables in the DsMetaEnv +type DsMetaEnv = NameEnv DsMetaVal + +data DsMetaVal + = DsBound Id -- Bound by a pattern inside the [| |]. + -- Will be dynamically alpha renamed. + -- The Id has type THSyntax.Var + + | DsSplice (HsExpr GhcTc) -- These bindings are introduced by + -- the PendingSplices on a Hs*Bracket + +-- | Desugaring monad. See also 'TcM'. +type DsM = TcRnIf DsGblEnv DsLclEnv + +-- See Note [The Decoupling Abstract Data Hack] +type instance DsForeignsHook = [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)) diff --git a/GHC/HsToCore/Usage.hs b/GHC/HsToCore/Usage.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Usage.hs @@ -0,0 +1,383 @@ +module GHC.HsToCore.Usage ( + -- * Dependency/fingerprinting code (used by GHC.Iface.Make) + mkUsageInfo, mkUsedNames, + + UsageConfig(..), + ) where + +import GHC.Prelude + +import GHC.Driver.Env + +import GHC.Tc.Types + +import GHC.Iface.Load + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Fingerprint +import GHC.Utils.Panic +import GHC.Utils.Monad + +import GHC.Types.Avail +import GHC.Types.Name +import GHC.Types.Name.Reader (ImpDeclSpec(..)) +import GHC.Types.Name.Set ( NameSet, allUses, emptyNameSet, unionNameSet ) +import GHC.Types.Unique.Set + +import GHC.Unit +import GHC.Unit.Env +import GHC.Unit.External +import GHC.Unit.Module.Imported +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps + +import GHC.Data.Maybe +import GHC.Data.FastString + +import Data.IORef +import Data.List (sortBy) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.List.NonEmpty as NE + +import GHC.Linker.Types +import GHC.Unit.Finder +import GHC.Types.Unique.DFM +import GHC.Driver.Plugins +import qualified GHC.Unit.Home.Graph as HUG + +{- Note [Module self-dependency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC.Rename.Names.calculateAvails asserts the invariant that a module must not occur in +its own dep_orphs or dep_finsts. However, if we aren't careful this can occur +in the presence of hs-boot files: Consider that we have two modules, A and B, +both with hs-boot files, + + A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A + A.hs-boot declares an orphan instance A.hs defines the orphan instance + +In this case, B's dep_orphs will contain A due to its SOURCE import of A. +Consequently, A will contain itself in its imp_orphs due to its import of B. +This fact would end up being recorded in A's interface file. This would then +break the invariant asserted by calculateAvails that a module does not itself in +its dep_orphs. This was the cause of #14128. + +-} + +mkUsedNames :: TcGblEnv -> NameSet +mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus + +data UsageConfig = UsageConfig + { uc_safe_implicit_imps_req :: !Bool -- ^ Are all implicit imports required to be safe for this Safe Haskell mode? + } + +mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv + -> Module -> ImportedMods -> [ImportUserSpec] -> NameSet + -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded + -> IfG [Usage] +mkUsageInfo uc plugins fc unit_env + this_mod dir_imp_mods imp_decls used_names + dependent_files merged needed_links needed_pkgs + = do + eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env)) + hashes <- liftIO $ mapM getFileHash dependent_files + let hu = ue_unsafeHomeUnit unit_env + hug = ue_home_unit_graph unit_env + -- Dependencies on object files due to TH and plugins + object_usages <- liftIO $ mkObjectUsage (eps_PIT eps) plugins fc hug needed_links needed_pkgs + let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env) + mod_usages <- mk_mod_usage_info uc hu all_home_ids this_mod + dir_imp_mods imp_decls used_names + let usages = mod_usages ++ [ UsageFile { usg_file_path = mkFastString f + , usg_file_hash = hash + , usg_file_label = Nothing } + | (f, hash) <- zip dependent_files hashes ] + ++ [ UsageMergedRequirement + { usg_mod = mod, + usg_mod_hash = hash + } + | (mod, hash) <- merged ] + ++ object_usages + usages `seqList` return usages + -- seq the list of Usages returned: occasionally these + -- don't get evaluated for a while and we can end up hanging on to + -- the entire collection of Ifaces. + +{- Note [Plugin dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Modules for which plugins were used in the compilation process, should be +recompiled whenever one of those plugins changes. But how do we know if a +plugin changed from the previous time a module was compiled? + +We could try storing the fingerprints of the interface files of plugins in +the interface file of the module. And see if there are changes between +compilation runs. However, this is pretty much a non-option because interface +fingerprints of plugin modules are fairly stable, unless you compile plugins +with optimisations turned on, and give basically all binders an INLINE pragma. + +So instead: + + * For plugins that were built locally: we store the filepath and hash of the + object files of the module with the `plugin` binder, and the object files of + modules that are dependencies of the plugin module and belong to the same + `UnitId` as the plugin + * For plugins in an external package: we store the filepath and hash of + the dynamic library containing the plugin module. + +During recompilation we then compare the hashes of those files again to see +if anything has changed. + +One issue with this approach is that object files are currently (GHC 8.6.1) +not created fully deterministically, which could sometimes induce accidental +recompilation of a module for which plugins were used in the compile process. + +One way to improve this is to either: + + * Have deterministic object file creation + * Create and store implementation hashes, which would be based on the Core + of the module and the implementation hashes of its dependencies, and then + compare implementation hashes for recompilation. Creation of implementation + hashes is however potentially expensive. + + A serious issue with the interface hash idea is that if you include an + interface hash, that hash also needs to depend on the hash of its + dependencies. Therefore, if any of the transitive dependencies of a modules + gets updated then you need to recompile the module in case the interface + hash has changed irrespective if the module uses TH or not. + + This is important to maintain the invariant that the information in the + interface file is always up-to-date. + + + See #20790 (comment 3) +-} + +{- +Note [Object File Dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In addition to the Note [Plugin dependencies] above, for TH we also need to record +the hashes of object files that the TH code is required to load. These are +calculated by the loader in `getLinkDeps` and are accumulated in each individual +`TcGblEnv`, in `tcg_th_needed_deps`. We read this just before compute the UsageInfo +to inject the appropriate dependencies. +-} + +-- | Find object files corresponding to the transitive closure of given home +-- modules and direct object files for pkg dependencies +mkObjectUsage :: PackageIfaceTable -> Plugins -> FinderCache -> HomeUnitGraph-> [Linkable] -> PkgsLoaded -> IO [Usage] +mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do + let ls = ordNubOn linkableModule (th_links_needed ++ plugins_links_needed) + ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well + (plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps plugins + concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds) + where + linkableToUsage (Linkable _ m uls) = mapM (partToUsage m) (NE.toList uls) + + msg m = moduleNameString (moduleName m) ++ "[TH] changed" + + fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg + + partToUsage m part = + case linkablePartPath part 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. + miface <- lookupIfaceByModule hug pit m + case miface of + Nothing -> pprPanic "mkObjectUsage" (ppr m) + Just iface -> + return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash 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 :: UsageConfig + -> HomeUnit + -> Set.Set UnitId + -> Module + -> ImportedMods + -> [ImportUserSpec] + -> NameSet + -> IfG [Usage] +mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls used_names + = mapMaybeM mkUsageM usage_mods + where + safe_implicit_imps_req = uc_safe_implicit_imps_req uc + + used_mods = moduleEnvKeys ent_map + dir_imp_mods = Map.keys direct_imports + all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods + usage_mods = sortBy stableModuleCmp all_mods + -- canonical order is imported, to avoid interface-file + -- wobblage. + + -- ent_map groups together all the things imported and used + -- from a particular module + ent_map :: ModuleEnv [OccName] + ent_map = nonDetStrictFoldUniqSet add_mv emptyModuleEnv used_names + -- nonDetStrictFoldUniqSet is OK here. If you follow the logic, we sort by + -- OccName in ent_hashs + where + add_mv name mv_map + | isWiredInName name = mv_map -- ignore wired-in names + | otherwise + = case nameModule_maybe name of + Nothing -> assertPpr (isSystemName name) (ppr name) mv_map + -- See Note [Internal used_names] + + Just mod -> + -- See Note [Identity versus semantic module] + let mod' = if isHoleModule mod + then mkHomeModule home_unit (moduleName mod) + else mod + -- This lambda function is really just a + -- specialised (++); originally came about to + -- avoid quadratic behaviour (#2680) + in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ] + where occ = nameOccName name + + mkUsageM :: Module -> IfG (Maybe Usage) + mkUsageM mod | mod == this_mod -- We don't care about usages of things in *this* module + || moduleUnit mod == interactiveUnit -- ... or in GHCi + = return Nothing + mkUsageM mod = do + iface <- loadSysInterface (text "mk_mod_usage") mod + -- Make sure the interface is loaded even if we don't directly use + -- any symbols from it, to ensure determinism. See #22217. + return $ mkUsage mod iface + + + -- We want to create a Usage for a home module if + -- a) we used something from it; has something in used_names + -- b) we imported it, even if we used nothing from it + -- (need to recompile if its export list changes: export_fprint) + mkUsage :: Module -> ModIface -> Maybe Usage + mkUsage mod iface + | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids + = Just $ UsagePackageModule{ usg_mod = mod, + usg_mod_hash = mod_hash, + usg_safe = imp_safe } + -- for package modules, we record the module hash only + + | (null used_occs + && isNothing imported_exports + && not is_direct_import + && not finsts_mod) + = Nothing -- Record no usage info + -- for directly-imported modules, we always want to record a usage + -- on the orphan hash. This is what triggers a recompilation if + -- an orphan is added or removed somewhere below us in the future. + + | otherwise + = Just UsageHomeModule { + usg_mod_name = moduleName mod, + usg_unit_id = toUnitId (moduleUnit mod), + usg_mod_hash = mod_hash, + usg_exports = imported_exports, + usg_entities = Map.toList ent_hashs, + usg_safe = imp_safe } + where + finsts_mod = mi_finsts iface + hash_env = mi_hash_fn iface + mod_hash = mi_mod_hash iface + imported_exports + = if not depend_on_exports + then Nothing + else + Just $ + HomeModImport + { hmiu_orphanLikeHash + = mi_orphan_like_hash iface + , hmiu_importedAvails + = moduleImportedAvails mod (mi_export_avails_hash iface) imp_decls + } + + by_is_safe (ImportedByUser imv) = imv_is_safe imv + by_is_safe _ = False + (is_direct_import, imp_safe) + = case Map.lookup mod direct_imports of + -- ezyang: I'm not sure if any is the correct + -- metric here. If safety was guaranteed to be uniform + -- across all imports, why did the old code only look + -- at the first import? + Just bys -> (True, any by_is_safe bys) + Nothing -> (False, safe_implicit_imps_req) + -- Nothing case is for references to entities which were + -- not directly imported (NB: the "implicit" Prelude import + -- counts as directly imported! An entity is not directly + -- imported if, e.g., we got a reference to it from a + -- reexport of another module.) + + used_occs = lookupModuleEnv ent_map mod `orElse` [] + + -- Making a Map here ensures that (a) we remove duplicates + -- when we have usages on several subordinates of a single parent, + -- and (b) that the usages emerge in a canonical order, which + -- is why we use Map rather than OccEnv: Map works + -- using Ord on the OccNames, which is a lexicographic ordering. + ent_hashs :: Map OccName Fingerprint + ent_hashs = Map.fromList (map lookup_occ used_occs) + + lookup_occ occ = + case hash_env occ of + Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names) + Just r -> r + + depend_on_exports = is_direct_import + {- True + Even if we used 'import M ()', we have to register a + usage on the export list because we are sensitive to + changes in orphan instances/rules. + False + In GHC 6.8.x we always returned true, and in + fact it recorded a dependency on *all* the + modules underneath in the dependency tree. This + happens to make orphans work right, but is too + expensive: it'll read too many interface files. + The 'isNothing maybe_iface' check above saved us + from generating many of these usages (at least in + one-shot mode), but that's even more bogus! + -} + +-- | Compute the avails that we are importing from a home module. +-- +-- See 'HomeModImportedAvails'. +moduleImportedAvails :: Module -> Fingerprint -> [ImportUserSpec] -> HomeModImportedAvails +moduleImportedAvails mod vis_exp_hash = go [] emptyNameSet + where + go :: Avails -> NameSet -> [ImportUserSpec] -> HomeModImportedAvails + go avails_acc parents_acc [] = + HMIA_Explicit + { hmia_imported_avails = sortAvails avails_acc + , hmia_parents_with_implicits = parents_acc + } + go avails_acc parents_acc (ImpUserSpec (ImpDeclSpec { is_mod = mod' }) decl : imp_decls) + | mod' == mod + = case decl of + ImpUserExplicit avails parents_of_implicits + -> go (avails ++ avails_acc) (parents_acc `unionNameSet` parents_of_implicits) + imp_decls + _ -> HMIA_Implicit vis_exp_hash + | otherwise + = go avails_acc parents_acc imp_decls + +{- Note [Internal used_names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the used_names are External Names, but we can have System +Names too. Two examples: + +* Names arising from Language.Haskell.TH.newName. + See Note [Binders in Template Haskell] in GHC.ThToHs (and #5362). +* The names of auxiliary bindings in derived instances. + See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. + +Such Names are always for locally-defined things, for which we don't gather +usage info, so we can just ignore them in ent_map. Moreover, they are always +System Names, hence the assert, just as a double check. +-} diff --git a/GHC/HsToCore/Utils.hs b/GHC/HsToCore/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Utils.hs @@ -0,0 +1,1012 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utilities for desugaring + +This module exports some utility functions of no great interest. +-} + +-- | Utility functions for constructing Core syntax, principally for desugaring +module GHC.HsToCore.Utils ( + EquationInfo(..), + firstPat, shiftEqns, combineEqnRhss, + + MatchResult (..), CaseAlt(..), + cantFailMatchResult, alwaysFailMatchResult, + extractMatchResult, combineMatchResults, + adjustMatchResultDs, + shareFailureHandler, + dsHandleMonadicFailure, + mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, + matchCanFail, mkEvalMatchResult, + mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, + wrapBind, wrapBinds, + + mkErrorAppDs, mkCastDs, mkFailExpr, + + seqVar, + + -- LHs tuples + mkLHsPatTup, mkVanillaTuplePat, + mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId, + + mkSelectorBinds, + + selectSimpleMatchVarL, selectMatchVars, selectMatchVar, + mkOptTickBox, mkBinaryTickBox, decideBangHood, + isTrueLHsExpr, + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Basic (Boxity(..)) + +import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply ) +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsSyntaxExpr ) + +import GHC.Hs +import GHC.Hs.Syn.Type +import GHC.Core +import GHC.HsToCore.Monad + +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Types.Id.Make +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCo.Rep( Scaled(..) ) +import GHC.Builtin.Types +import GHC.Core.ConLike +import GHC.Types.Unique.Set +import GHC.Types.Unique.Supply +import GHC.Unit.Module +import GHC.Builtin.Names +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.SrcLoc +import GHC.Types.Tickish +import GHC.Utils.Misc +import GHC.Driver.DynFlags +import GHC.Driver.Ppr +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Rename.Env ( irrefutableConLikeTc ) +import GHC.Tc.Types.Evidence + +import Control.Monad ( zipWithM ) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (maybeToList) +import qualified Data.List.NonEmpty as NEL + +{- +************************************************************************ +* * +\subsection{ Selecting match variables} +* * +************************************************************************ + +We're about to match against some patterns. We want to make some +@Ids@ to use as match variables. If a pattern has an @Id@ readily at +hand, which should indeed be bound to the pattern as a whole, then use it; +otherwise, make one up. The multiplicity argument is chosen as the multiplicity +of the variable if it is made up. +-} + +selectSimpleMatchVarL :: Mult -> LPat GhcTc -> DsM Id +-- Postcondition: the returned Id has an Internal Name +selectSimpleMatchVarL w pat = selectMatchVar w (unLoc pat) + +-- (selectMatchVars ps tys) chooses variables of type tys +-- to use for matching ps against. If the pattern is a variable, +-- we try to use that, to save inventing lots of fresh variables. +-- +-- OLD, but interesting note: +-- But even if it is a variable, its type might not match. Consider +-- data T a where +-- T1 :: Int -> T Int +-- T2 :: a -> T a +-- +-- f :: T a -> a -> Int +-- f (T1 i) (x::Int) = x +-- f (T2 i) (y::a) = 0 +-- Then we must not choose (x::Int) as the matching variable! +-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat + +selectMatchVars :: [(Mult, Pat GhcTc)] -> DsM [Id] +-- Postcondition: the returned Ids have Internal Names +selectMatchVars ps = mapM (uncurry selectMatchVar) ps + +selectMatchVar :: Mult -> Pat GhcTc -> DsM Id +-- Postcondition: the returned Id has an Internal Name +selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar w (ParPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) + -- Note [Localise pattern binders] + -- + -- Remark: when the pattern is a variable (or + -- an @-pattern), then w is the same as the + -- multiplicity stored within the variable + -- itself. It's easier to pull it from the + -- variable, so we ignore the multiplicity. +selectMatchVar _w (AsPat _ var _) = assert (isManyTy _w ) (return (localiseId (unLoc var))) +selectMatchVar w other_pat = newSysLocalDs (Scaled w (hsPatType other_pat)) + +{- Note [Localise pattern binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider module M where + [Just a] = e +After renaming it looks like + module M where + [Just M.a] = e + +We don't generalise, since it's a pattern binding, monomorphic, etc, +so after desugaring we may get something like + M.a = case e of (v:_) -> + case v of Just M.a -> M.a +Notice the "M.a" in the pattern; after all, it was in the original +pattern. However, after optimisation those pattern binders can become +let-binders, and then end up floated to top level. They have a +different *unique* by then (the simplifier is good about maintaining +proper scoping), but it's BAD to have two top-level bindings with the +External Name M.a, because that turns into two linker symbols for M.a. +It's quite rare for this to actually *happen* -- the only case I know +of is tc003 compiled with the 'hpc' way -- but that only makes it +all the more annoying. + +To avoid this, we craftily call 'localiseId' in the desugarer, which +simply turns the External Name for the Id into an Internal one, but +doesn't change the unique. So the desugarer produces this: + M.a{r8} = case e of (v:_) -> + case v of Just a{r8} -> M.a{r8} +The unique is still 'r8', but the binding site in the pattern +is now an Internal Name. Now the simplifier's usual mechanisms +will propagate that Name to all the occurrence sites, as well as +un-shadowing it, so we'll get + M.a{r8} = case e of (v:_) -> + case v of Just a{s77} -> a{s77} +In fact, even GHC.Core.Subst.simplOptExpr will do this, and simpleOptExpr +runs on the output of the desugarer, so all is well by the end of +the desugaring pass. + +See also Note [Match Ids] in GHC.HsToCore.Match + +************************************************************************ +* * +* type synonym EquationInfo and access functions for its pieces * +* * +************************************************************************ +\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} + +The ``equation info'' used by @match@ is relatively complicated and +worthy of a type synonym and a few handy functions. +-} + +firstPat :: EquationInfoNE -> Pat GhcTc +firstPat (EqnMatch { eqn_pat = pat }) = unLoc pat +firstPat (EqnDone {}) = error "firstPat: no patterns" + +shiftEqns :: Functor f => f EquationInfoNE -> f EquationInfo +-- Drop the first pattern in each equation +shiftEqns = fmap shift + where + shift (EqnMatch { eqn_rest = rest }) = rest + shift eqn@(EqnDone {}) = pprPanic "shiftEqns" (ppr eqn) + +combineEqnRhss :: NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +combineEqnRhss = pure . foldr1 combineMatchResults . fmap eqnMatchResult + +-- Functions on MatchResult CoreExprs + +matchCanFail :: MatchResult a -> Bool +matchCanFail (MR_Fallible {}) = True +matchCanFail (MR_Infallible {}) = False + +alwaysFailMatchResult :: MatchResult CoreExpr +alwaysFailMatchResult = MR_Fallible $ \fail -> return fail + +cantFailMatchResult :: CoreExpr -> MatchResult CoreExpr +cantFailMatchResult expr = MR_Infallible $ return expr + +extractMatchResult :: MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr +extractMatchResult match_result failure_expr = + runMatchResult + failure_expr + (shareFailureHandler match_result) + +combineMatchResults :: MatchResult CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr +combineMatchResults match_result1@(MR_Infallible _) _ + = match_result1 +combineMatchResults match_result1 match_result2 = + -- if the first pattern needs a failure handler (i.e. if it is fallible), + -- make it let-bind it bind it with `shareFailureHandler`. + case shareFailureHandler match_result1 of + MR_Infallible _ -> match_result1 + MR_Fallible body_fn1 -> MR_Fallible $ \fail_expr -> + -- Before actually failing, try the next match arm. + body_fn1 =<< runMatchResult fail_expr match_result2 + +adjustMatchResultDs :: (a -> DsM b) -> MatchResult a -> MatchResult b +adjustMatchResultDs encl_fn = \case + MR_Infallible body_fn -> MR_Infallible $ + encl_fn =<< body_fn + MR_Fallible body_fn -> MR_Fallible $ \fail -> + encl_fn =<< body_fn fail + +wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr +wrapBinds [] e = e +wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) + +wrapBind :: Var -> Var -> CoreExpr -> CoreExpr +wrapBind new old body -- NB: this function must deal with term + | new==old = body -- variables, type variables or coercion variables + | otherwise = Let (NonRec new (varToCoreExpr old)) body + +-- Used to force variables when desugaring strict binders. It's crucial that the +-- variable is shadowed by the case binder. See Wrinkle 1 in +-- Note [Desugar Strict binds] in GHC.HsToCore.Binds. +seqVar :: Var -> CoreExpr -> CoreExpr +seqVar var body = mkDefaultCase (Var var) var body + +mkCoLetMatchResult :: CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr +mkCoLetMatchResult bind = fmap (mkCoreLet bind) + +-- (mkViewMatchResult var' viewExpr mr) makes the expression +-- let var' = viewExpr in mr +mkViewMatchResult :: Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr +mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr + +mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr +mkEvalMatchResult var ty = fmap $ \e -> + Case (Var var) var ty [Alt DEFAULT [] e] + +mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr +mkGuardedMatchResult pred_expr mr = MR_Fallible $ \fail -> do + body <- runMatchResult fail mr + return (mkIfThenElse pred_expr body fail) + +mkCoPrimCaseMatchResult :: Id -- Scrutinee + -> Type -- Type of the case + -> [(Literal, MatchResult CoreExpr)] -- Alternatives + -> MatchResult CoreExpr -- Literals are all unlifted +mkCoPrimCaseMatchResult var ty match_alts + = MR_Fallible mk_case + where + mk_case fail = do + alts <- mapM (mk_alt fail) sorted_alts + return (Case (Var var) var ty (Alt DEFAULT [] fail : alts)) + + sorted_alts = sortWith fst match_alts -- Right order for a Case + mk_alt fail (lit, mr) + = assert (not (litIsLifted lit)) $ + do body <- runMatchResult fail mr + return (Alt (LitAlt lit) [] body) + +data CaseAlt a = MkCaseAlt{ alt_pat :: a, + alt_bndrs :: [Var], + alt_wrapper :: HsWrapper, + alt_result :: MatchResult CoreExpr } + +mkCoAlgCaseMatchResult + :: Id -- ^ Scrutinee + -> Type -- ^ Type of exp + -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts) + -> MatchResult CoreExpr +mkCoAlgCaseMatchResult var ty match_alts + | isNewtype -- Newtype case; use a let + = assert (null match_alts_tail && null (tail arg_ids1)) $ + mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 + + | otherwise + = mkDataConCase var ty match_alts + where + isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1)) + + -- [Interesting: because of GADTs, we can't rely on the type of + -- the scrutinised Id to be sufficiently refined to have a TyCon in it] + + alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail + = match_alts + -- Stuff for newtype + arg_id1 = assert (notNull arg_ids1) $ head arg_ids1 + var_ty = idType var + (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes + -- (not that splitTyConApp does, these days) + newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) + +mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult CoreExpr +mkCoSynCaseMatchResult var ty alt = MR_Fallible $ mkPatSynCase var ty alt + +mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr +mkPatSynCase var ty alt fail = do + matcher_id <- dsLookupGlobalId matcher_name + matcher <- dsLExpr $ mkLHsWrap wrapper $ + nlHsTyApp matcher_id [getRuntimeRep ty, ty] + cont <- mkCoreLams bndrs <$> runMatchResult fail match_result + return $ mkCoreApps matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] + where + MkCaseAlt{ alt_pat = psyn, + alt_bndrs = bndrs, + alt_wrapper = wrapper, + alt_result = match_result} = alt + (matcher_name, _, needs_void_lam) = patSynMatcher psyn + + -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn + -- on these extra Void# arguments + ensure_unstrict cont | needs_void_lam = Lam voidArgId cont + | otherwise = cont + +mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr +mkDataConCase var ty alts@(alt1 :| _) + = liftA2 mk_case mk_default mk_alts + -- The liftA2 combines the failability of all the alternatives and the default + where + con1 = alt_pat alt1 + tycon = dataConTyCon con1 + data_cons = tyConDataCons tycon + + sorted_alts :: [ CaseAlt DataCon ] + sorted_alts = sortWith (dataConTag . alt_pat) $ NEL.toList alts + + var_ty = idType var + (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes + -- (not that splitTyConApp does, these days) + + mk_case :: Maybe CoreAlt -> [CoreAlt] -> CoreExpr + mk_case def alts = mkWildCase (Var var) (idScaledType var) ty $ + maybeToList def ++ alts + + mk_alts :: MatchResult [CoreAlt] + mk_alts = traverse mk_alt sorted_alts + + mk_alt :: CaseAlt DataCon -> MatchResult CoreAlt + mk_alt MkCaseAlt { alt_pat = con + , alt_bndrs = args + , alt_result = match_result } = + flip adjustMatchResultDs match_result $ \body -> do + case dataConBoxer con of + Nothing -> return (Alt (DataAlt con) args body) + Just (DCB boxer) -> do + us <- newUniqueSupply + let (rep_ids, binds) = initUs_ us (boxer ty_args args) + let rep_ids' = map (scaleVarBy (idMult var)) rep_ids + -- Upholds the invariant that the binders of a case expression + -- must be scaled by the case multiplicity. See Note [Case + -- expression invariants] in CoreSyn. + return (Alt (DataAlt con) rep_ids' (mkLets binds body)) + + mk_default :: MatchResult (Maybe CoreAlt) + mk_default + | exhaustive_case = MR_Infallible $ return Nothing + | otherwise = MR_Fallible $ \fail -> return $ Just (Alt DEFAULT [] fail) + + mentioned_constructors = mkUniqSet $ map alt_pat sorted_alts + un_mentioned_constructors + = mkUniqSet data_cons `minusUniqSet` mentioned_constructors + exhaustive_case = isEmptyUniqSet un_mentioned_constructors + +{- +************************************************************************ +* * +\subsection{Desugarer's versions of some Core functions} +* * +************************************************************************ +-} + +mkErrorAppDs :: Id -- The error function + -> Type -- Type to which it should be applied + -> SDoc -- The error message string to pass + -> DsM CoreExpr + +mkErrorAppDs err_id ty msg = do + src_loc <- getSrcSpanDs + dflags <- getDynFlags + let full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) + fail_expr = mkRuntimeErrorApp err_id unitTy full_msg + return $ mkWildCase fail_expr (unrestricted unitTy) ty [] + -- See Note [Incompleteness and linearity] + +{- +Note [Incompleteness and linearity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The default branch of an incomplete pattern match is compiled to a call +to 'error'. +Because of linearity, we wrap it with an empty case. Example: + +f :: a %1 -> Bool -> a +f x True = False + +Adding 'f x False = error "Non-exhaustive pattern..."' would violate +the linearity of x. +Instead, we use 'f x False = case error "Non-exhaustive pattern..." :: () of {}'. +This case expression accounts for linear variables by assigning bottom usage +(See Note [Bottom as a usage] in GHC.Core.Multiplicity). +This is done in mkErrorAppDs, called from mkFailExpr. +We use '()' instead of the original return type ('a' in this case) +because there might be representation polymorphism, e.g. in + +g :: forall (a :: TYPE r). (() -> a) %1 -> Bool -> a +g x True = x () + +adding 'g x False = case error "Non-exhaustive pattern" :: a of {}' +would create an illegal representation-polymorphic case binder. +This is important for pattern synonym matchers, which often look like this 'g'. + +Similarly, a hole +h :: a %1 -> a +h x = _ +is desugared to 'case error "Hole" :: () of {}'. Test: LinearHole. + +Instead of () we could use Data.Void.Void, but that would require +moving Void to GHC.Types: partial pattern matching is used in modules +that are compiled before Data.Void. +We can use () even though it has a constructor, because +Note [Case expression invariants] point 4 in GHC.Core is satisfied +when the scrutinee is bottoming. + +You might wonder if this change slows down compilation, but the +performance testsuite did not show up any regressions. + +For uniformity, calls to 'error' in both cases are wrapped even if -XLinearTypes +is disabled. +-} + +mkFailExpr :: HsMatchContextRn -> Type -> DsM CoreExpr +mkFailExpr ctxt ty + = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) + +mkCastDs :: CoreExpr -> Coercion -> CoreExpr +-- We define a desugarer-specific version of GHC.Core.Utils.mkCast, +-- because in the immediate output of the desugarer, we can have +-- apparently-mis-matched coercions: E.g. +-- let a = b +-- in (x :: a) |> (co :: b ~ Int) +-- Lint know about type-bindings for let and does not complain +-- So here we do not make the assertion checks that we make in +-- GHC.Core.Utils.mkCast; and we do less peephole optimisation too +mkCastDs e co | isReflCo co = e + | otherwise = Cast e co + +{- +************************************************************************ +* * + Tuples and selector bindings +* * +************************************************************************ + +This is used in various places to do with lazy patterns. +For each binder $b$ in the pattern, we create a binding: +\begin{verbatim} + b = case v of pat' -> b' +\end{verbatim} +where @pat'@ is @pat@ with each binder @b@ cloned into @b'@. + +ToDo: making these bindings should really depend on whether there's +much work to be done per binding. If the pattern is complex, it +should be de-mangled once, into a tuple (and then selected from). +Otherwise the demangling can be in-line in the bindings (as here). + +Boring! Boring! One error message per binder. The above ToDo is +even more helpful. Something very similar happens for pattern-bound +expressions. + +Note [mkSelectorBinds] +~~~~~~~~~~~~~~~~~~~~~~ +mkSelectorBinds is used to desugar a pattern binding {p = e}, +in a binding group: + let { ...; p = e; ... } in body +where p binds x,y (this list of binders can be empty). + +mkSelectorBinds is also used to desugar irrefutable patterns, which is the +pattern syntax equivalent of a lazy pattern binding: + f (~(a:as)) = rhs ==> f x = let (a:as) = x in rhs + +There are three cases. + +------ Special case (A) ------- + For a pattern that is just a variable, + let !x = e in body + ==> + let x = e in x `seq` body + So we return the binding, with 'x' as the variable to seq. + +------ Special case (B) ------- + For a pattern that is essentially just a tuple: + * A product type, so cannot fail + * Boxed, so that it can be matched lazily + * Only one level, so that + - generating multiple matches is fine + - seq'ing it evaluates the same as matching it + Then instead we generate + { v = e + ; x = case v of p -> x + ; y = case v of p -> y } + with 'v' as the variable to force + +------ General case (C) ------- + In the general case we generate these bindings: + let { ...; p = e; ... } in body + ==> + let { t = case e of p -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> y } + in t `seq` body + + Note that we return 't' as the variable to force if the pattern + is strict (i.e. with -XStrict or an outermost-bang-pattern) + + Note that (C) /includes/ the situation where + + * The pattern binds exactly one variable + let !(Just (Just x)) = e in body + ==> + let { t = case e of Just (Just v) -> Solo v + ; v = case t of Solo v -> v } + in t `seq` body + The 'Solo' is a one-tuple; see Note [One-tuples] in GHC.Builtin.Types + Note that forcing 't' makes the pattern match happen, + but does not force 'v'. That's why we call `mkBigCoreVarTupSolo` + in `mkSelectorBinds` + + * The pattern binds no variables + let !(True,False) = e in body + ==> + let t = case e of (True,False) -> () + in t `seq` body + + +------ Examples ---------- + * !(_, (_, a)) = e + ==> + t = case e of (_, (_, a)) -> Solo a + a = case t of Solo a -> a + + Note that + - Forcing 't' will force the pattern to match fully; + e.g. will diverge if (snd e) is bottom + - But 'a' itself is not forced; it is wrapped in a one-tuple + (see Note [One-tuples] in GHC.Builtin.Types) + + * !(Just x) = e + ==> + t = case e of Just x -> Solo x + x = case t of Solo x -> x + + Again, forcing 't' will fail if 'e' yields Nothing. + +Note that even though this is rather general, the special cases +work out well: + +* One binder, not -XStrict: + + let Just (Just v) = e in body + ==> + let t = case e of Just (Just v) -> Solo v + v = case t of Solo v -> v + in body + ==> + let v = case (case e of Just (Just v) -> Solo v) of + Solo v -> v + in body + ==> + let v = case e of Just (Just v) -> v + in body + +* Non-recursive, -XStrict + let p = e in body + ==> + let { t = case e of p -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> x } + in t `seq` body + ==> {inline seq, float x,y bindings inwards} + let t = case e of p -> (x,y) in + case t of t' -> + let { x = case t' of (x,y) -> x + ; y = case t' of (x,y) -> x } in + body + ==> {inline t, do case of case} + case e of p -> + let t = (x,y) in + let { x = case t' of (x,y) -> x + ; y = case t' of (x,y) -> x } in + body + ==> {case-cancellation, drop dead code} + case e of p -> body + +* Special case (B) is there to avoid fruitlessly taking the tuple + apart and rebuilding it. For example, consider + { K x y = e } + where K is a product constructor. Then general case (A) does: + { t = case e of K x y -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> y } + In the lazy case we can't optimise out this fruitless taking apart + and rebuilding. Instead (B) builds + { v = e + ; x = case v of K x y -> x + ; y = case v of K x y -> y } + which is better. +-} +-- Remark: pattern selectors only occur in unrestricted patterns so we are free +-- to select Many as the multiplicity of every let-expression introduced. +mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly + -> LPat GhcTc -- ^ The pattern + -> HsMatchContextRn -- ^ Where the pattern occurs + -> CoreExpr -- ^ Expression to which the pattern is bound + -> DsM (Id,[(Id,CoreExpr)]) + -- ^ Id the rhs is bound to, for desugaring strict + -- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds") + -- and all the desugared binds + +mkSelectorBinds ticks pat ctx val_expr + | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) + = return (v, [(v, val_expr)]) + + | is_flat_prod_lpat pat' -- Special case (B) + = do { let pat_ty = hsLPatType pat' + ; val_var <- newSysLocalMDs pat_ty + + ; let mk_bind tick bndr_var + -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } + -- Remember, 'pat' binds 'bv' + = do { rhs_expr <- matchSimply (Var val_var) ctx ManyTy pat' + (Var bndr_var) + (Var bndr_var) -- Neat hack + -- Neat hack: since 'pat' can't fail, the + -- "fail-expr" passed to matchSimply is not + -- used. But it /is/ used for its type, and for + -- that bndr_var is just the ticket. + ; return (bndr_var, mkOptTickBox tick rhs_expr) } + + ; binds <- zipWithM mk_bind ticks' binders + ; return ( val_var, (val_var, val_expr) : binds) } + + | otherwise -- General case (C) + = do { tuple_var <- newSysLocalMDs tuple_ty + ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') + ; tuple_expr <- matchSimply val_expr ctx ManyTy pat + local_tuple error_expr + ; let mk_tup_bind tick binder + = (binder, mkOptTickBox tick $ + mkBigTupleSelectorSolo local_binders binder + tuple_var (Var tuple_var)) + tup_binds = zipWith mk_tup_bind ticks' binders + ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) } + where + pat' = strip_bangs pat + -- Strip the bangs before looking for case (A) or (B) + -- The incoming pattern may well have a bang on it + + binders = collectPatBinders CollNoDictBinders pat' + ticks' = ticks ++ repeat [] + + local_binders = map localiseId binders -- See Note [Localise pattern binders] + local_tuple = mkBigCoreVarTupSolo binders + tuple_ty = exprType local_tuple + +strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) +-- Remove outermost bangs and parens +strip_bangs (L _ (ParPat _ p)) = strip_bangs p +strip_bangs (L _ (BangPat _ p)) = strip_bangs p +strip_bangs lp = lp + +is_flat_prod_lpat :: LPat GhcTc -> Bool +-- Pattern is equivalent to a flat, boxed, lifted tuple +is_flat_prod_lpat = is_flat_prod_pat . unLoc + +is_flat_prod_pat :: Pat GhcTc -> Bool +is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p +is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps +is_flat_prod_pat (ConPat { pat_con = L _ pcon + , pat_args = ps}) + | RealDataCon con <- pcon + , let tc = dataConTyCon con + , Just _ <- tyConSingleDataCon_maybe tc + , isLiftedAlgTyCon tc + = all is_triv_lpat (hsConPatArgs ps) +is_flat_prod_pat _ = False + +is_triv_lpat :: LPat (GhcPass p) -> Bool +is_triv_lpat = is_triv_pat . unLoc + +is_triv_pat :: Pat (GhcPass p) -> Bool +is_triv_pat (VarPat {}) = True +is_triv_pat (WildPat{}) = True +is_triv_pat (ParPat _ p) = is_triv_lpat p +is_triv_pat _ = False + + +{- ********************************************************************* +* * + Creating big tuples and their types for full Haskell expressions. + They work over *Ids*, and create tuples replete with their types, + which is whey they are not in GHC.Hs.Utils. +* * +********************************************************************* -} + +mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc +mkLHsPatTup [] = noLocA $ mkVanillaTuplePat [] Boxed +mkLHsPatTup [lpat] = lpat +mkLHsPatTup lpats@(L l _:_) = L l $ + mkVanillaTuplePat lpats Boxed + +mkVanillaTuplePat :: [LPat GhcTc] -> Boxity -> Pat GhcTc +-- A vanilla tuple pattern simply gets its type from its sub-patterns +mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box + +-- The Big equivalents for the source tuple expressions +mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc +mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids) + +mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc +mkBigLHsTupId = mkChunkified (\e -> mkLHsTupleExpr e noExtField) + +-- The Big equivalents for the source tuple patterns +mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc +mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs) + +mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc +mkBigLHsPatTupId = mkChunkified mkLHsPatTup + +{- +************************************************************************ +* * + Code for pattern-matching and other failures +* * +************************************************************************ + +Generally, we handle pattern matching failure like this: let-bind a +fail-variable, and use that variable if the thing fails: +\begin{verbatim} + let fail.33 = error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 + p3 -> fail.33 + p4 -> ... +\end{verbatim} +Then +\begin{itemize} +\item +If the case can't fail, then there'll be no mention of @fail.33@, and the +simplifier will later discard it. + +\item +If it can fail in only one way, then the simplifier will inline it. + +\item +Only if it is used more than once will the let-binding remain. +\end{itemize} + +There's a problem when the result of the case expression is of +unboxed type. Then the type of @fail.33@ is unboxed too, and +there is every chance that someone will change the let into a case: +\begin{verbatim} + case error "Help" of + fail.33 -> case .... +\end{verbatim} + +which is of course utterly wrong. Rather than drop the condition that +only boxed types can be let-bound, we just turn the fail into a function +for the primitive case: +\begin{verbatim} + let fail.33 :: Void -> Int# + fail.33 = \_ -> error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 void + p3 -> fail.33 void + p4 -> ... +\end{verbatim} + +Now @fail.33@ is a function, so it can be let-bound. + +We would *like* to use join points here; in fact, these "fail variables" are +paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as +CPS functions - i.e. they take "join points" as parameters. It's not impossible +to imagine extending our type system to allow passing join points around (very +carefully), but we certainly don't support it now. + +99.99% of the time, the fail variables wind up as join points in short order +anyway, and the Void# doesn't do much harm. +-} + +mkFailurePair :: CoreExpr -- Result type of the whole case expression + -> DsM (CoreBind, -- Binds the newly-created fail variable + -- to \ _ -> expression + CoreExpr) -- Fail variable applied to (# #) +-- See Note [Failure thunks and CPR] +mkFailurePair expr + = do { fail_fun_var <- newFailLocalMDs (unboxedUnitTy `mkVisFunTyMany` ty) + ; fail_fun_arg <- newSysLocalMDs unboxedUnitTy + ; let real_arg = setOneShotLambda fail_fun_arg + ; return (NonRec fail_fun_var (Lam real_arg expr), + App (Var fail_fun_var) unboxedUnitExpr) } + where + ty = exprType expr + +-- Uses '@mkFailurePair@' to bind the failure case. Infallible matches have +-- neither a failure arg or failure "hole", so nothing is let-bound, and no +-- extraneous Core is produced. +shareFailureHandler :: MatchResult CoreExpr -> MatchResult CoreExpr +shareFailureHandler = \case + mr@(MR_Infallible _) -> mr + MR_Fallible match_fn -> MR_Fallible $ \fail_expr -> do + (fail_bind, shared_failure_handler) <- mkFailurePair fail_expr + body <- match_fn shared_failure_handler + -- Never unboxed, per the above, so always OK for `let` not `case`. + return $ Let fail_bind body + +{- +Note [Failure thunks and CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This note predates join points as formal entities (hence the quotation marks). +We can't use actual join points here (see above); if we did, this would also +solve the CPR problem, since join points don't get CPR'd. See Note [Don't w/w +join points for CPR] in GHC.Core.Opt.WorkWrap.) + +When we make a failure point we ensure that it +does not look like a thunk. Example: + + let fail = \rw -> error "urk" + in case x of + [] -> fail realWorld# + (y:ys) -> case ys of + [] -> fail realWorld# + (z:zs) -> (y,z) + +Reason: we know that a failure point is always a "join point" and is +entered at most once. Adding a dummy 'realWorld' token argument makes +it clear that sharing is not an issue. And that in turn makes it more +CPR-friendly. This matters a lot: if you don't get it right, you lose +the tail call property. For example, see #3403. +-} + +dsHandleMonadicFailure :: HsDoFlavour -> LPat GhcTc -> Type -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr + -- In an ApplicativeDo expression, pattern-match failure just calls the + -- monadic 'fail' rather than throwing an exception. +dsHandleMonadicFailure ctx pat res_ty match m_fail_op = + case shareFailureHandler match of + MR_Infallible body -> body + MR_Fallible body -> do + dflags <- getDynFlags + let strict = xopt LangExt.Strict dflags + comps <- dsGetCompleteMatches + fail_expr <- case m_fail_op of + -- Note that (non-monadic) list comprehension, pattern guards, etc could + -- have fallible bindings without an explicit failure op, but this is + -- handled elsewhere. See Note [Failing pattern matches in Stmts] the + -- breakdown of regular and special binds. + -- It *is* possible to land here for infallible Or patterns in + -- ApplicativeDo, because their desugaring to ViewPatterns leads + -- to a MR_Fallible match. But irrefutability is easily asserted: + Nothing -> do + massertPpr (isIrrefutableHsPat strict (irrefutableConLikeTc comps) pat) $ + text "Pattern match:" <+> ppr pat <+> + text "is failable, and fail_expr was left unset" + -- In this case we likely desugar the pattern-match in something like + -- do (~True; False) <- m; stmts + -- just presume a fail_expr like in the desugaring of lambdas; + -- that's the non-ApplicativeDo code path + mkErrorAppDs pAT_ERROR_ID res_ty (matchDoContextErrString ctx) + Just fail_op -> do + fail_msg <- mkStringExpr (mk_fail_msg dflags ctx pat) + dsSyntaxExpr fail_op [fail_msg] + body fail_expr + +mk_fail_msg :: DynFlags -> HsDoFlavour -> LocatedA e -> String +mk_fail_msg dflags ctx pat + = showPpr dflags $ text "Pattern match failure in" <+> pprHsDoFlavour ctx + <+> text "at" <+> ppr (getLocA pat) + +{- ********************************************************************* +* * + Ticks +* * +********************************************************************* -} + +mkOptTickBox :: [CoreTickish] -> CoreExpr -> CoreExpr +mkOptTickBox = flip (foldr Tick) + +mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr +mkBinaryTickBox ixT ixF e = do + this_mod <- getModule + let trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) + falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) + return $ mkIfThenElse e trueBox falseBox + + + +-- ******************************************************************* + +{- Note [decideBangHood] +~~~~~~~~~~~~~~~~~~~~~~~~ +With -XStrict we may make /outermost/ patterns more strict. +E.g. + let (Just x) = e in ... + ==> + let !(Just x) = e in ... +and + f x = e + ==> + f !x = e + +This adjustment is done by decideBangHood, + + * Just before constructing an EqnInfo, in GHC.HsToCore.Match + (matchWrapper and matchSinglePat) + + * When desugaring a pattern-binding in GHC.HsToCore.Binds.dsHsBind + +Note that it is /not/ done recursively. See the -XStrict +spec in the user manual. + +Specifically: + ~pat => pat -- when -XStrict (even if pat = ~pat') + !pat => !pat -- always + pat => !pat -- when -XStrict + pat => pat -- otherwise +-} + + +-- | Use -XStrict to add a ! or remove a ~ +-- See Note [decideBangHood] +decideBangHood :: DynFlags + -> LPat GhcTc -- ^ Original pattern + -> LPat GhcTc -- Pattern with bang if necessary +decideBangHood dflags lpat + | not (xopt LangExt.Strict dflags) + = lpat + | otherwise -- -XStrict + = go lpat + where + go lp@(L l p) + = case p of + ParPat x p -> L l (ParPat x (go p)) + LazyPat _ lp' -> lp' + BangPat _ _ -> lp + _ -> L l (BangPat noExtField lp) + +isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) + +-- Returns Just {..} if we're sure that the expression is True +-- I.e. * 'True' datacon +-- * 'otherwise' Id +-- * Trivial wrappings of these +-- The arguments to Just are any HsTicks that we have found, +-- because we still want to tick then, even it they are always evaluated. +isTrueLHsExpr (L _ (HsVar _ (L _ v))) + | v `hasKey` otherwiseIdKey + || v `hasKey` getUnique trueDataConId + = Just return + -- trueDataConId doesn't have the same unique as trueDataCon +isTrueLHsExpr (L _ (XExpr (ConLikeTc con _ _))) + | con `hasKey` getUnique trueDataCon = Just return +isTrueLHsExpr (L _ (XExpr (HsTick tickish e))) + | Just ticks <- isTrueLHsExpr e + = Just (\x -> do wrapped <- ticks x + return (Tick tickish wrapped)) + -- This encodes that the result is constant True for Hpc tick purposes; + -- which is specifically what isTrueLHsExpr is trying to find out. +isTrueLHsExpr (L _ (XExpr (HsBinTick ixT _ e))) + | Just ticks <- isTrueLHsExpr e + = Just (\x -> do e <- ticks x + this_mod <- getModule + return (Tick (HpcTick this_mod ixT) e)) + +isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e +isTrueLHsExpr _ = Nothing diff --git a/GHC/Iface/Binary.hs b/GHC/Iface/Binary.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Binary.hs @@ -0,0 +1,749 @@ +{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- + +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- | Binary interface file support. +module GHC.Iface.Binary ( + -- * Public API for interface file serialisation + writeBinIface, + readBinIface, + readBinIfaceHeader, + CompressionIFace(..), + getSymtabName, + CheckHiWay(..), + TraceBinIFace(..), + getIfaceWithExtFields, + putIfaceWithExtFields, + getWithUserData, + putWithUserData, + + -- * Internal serialisation functions + getSymbolTable, + putName, + putSymbolTable, + BinSymbolTable(..), + initWriteIfaceType, initReadIfaceTypeTable, + putAllTables, + ) where + +import GHC.Prelude + +import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName ) +import GHC.Unit +import GHC.Unit.Module.ModIface +import GHC.Types.Name +import GHC.Platform.Profile +import GHC.Types.Unique.FM +import GHC.Utils.Panic +import GHC.Utils.Binary as Binary +import GHC.Data.FastMutInt +import GHC.Types.Unique +import GHC.Utils.Outputable +import GHC.Types.Name.Cache +import GHC.Types.SrcLoc +import GHC.Platform +import GHC.Settings.Constants +import GHC.Iface.Type (IfaceType(..), getIfaceType, putIfaceType, ifaceTypeSharedByte) + +import Control.Monad +import Data.Array +import Data.Array.IO +import Data.Array.Unsafe +import Data.Char +import Data.IORef +import Data.Map.Strict (Map) +import Data.Word +import System.IO.Unsafe +import Data.Typeable (Typeable) +import qualified GHC.Data.Strict as Strict +import Data.Function ((&)) + + +-- --------------------------------------------------------------------------- +-- Reading and writing binary interface files +-- + +data CheckHiWay = CheckHiWay | IgnoreHiWay + deriving Eq + +data TraceBinIFace + = TraceBinIFace (SDoc -> IO ()) + | QuietBinIFace + +-- | The compression/deduplication level of 'ModIface' files. +-- +-- A 'ModIface' contains many duplicated symbols and names. To keep interface +-- files small, we deduplicate them during serialisation. +-- It is impossible to write an interface file with *no* compression/deduplication. +-- +-- We support different levels of compression/deduplication, with different +-- trade-offs for run-time performance and memory usage. +-- If you don't have any specific requirements, then 'SafeExtraCompression' is a good default. +data CompressionIFace + = NormalCompression + -- ^ Perform the normal compression operations, + -- such as deduplicating 'Name's and 'FastString's + | SafeExtraCompression + -- ^ Perform some extra compression steps that have minimal impact + -- on the run-time of 'ghc'. + -- + -- This reduces the size of '.hi' files significantly in some cases + -- and reduces overall memory usage in certain scenarios. + | MaximumCompression + -- ^ Try to compress as much as possible. + -- + -- Yields the smallest '.hi' files but at the cost of additional run-time. + deriving (Show, Eq, Ord, Bounded, Enum) + +instance Outputable CompressionIFace where + ppr = text . show + +-- | 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 ReadBinHandle +readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do + let platform = profilePlatform profile + + wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () + wantedGot what wanted got ppr' = + case traceBinIFace of + QuietBinIFace -> return () + TraceBinIFace printer -> printer $ + text what <> text ": " <> + vcat [text "Wanted " <> ppr' wanted <> text ",", + text "got " <> ppr' got] + + errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO () + errorOnMismatch what wanted got = + -- This will be caught by readIface which will emit an error + -- msg containing the iface module name. + when (wanted /= got) $ throwGhcExceptionIO $ ProgramError + (what ++ " (wanted " ++ show wanted + ++ ", got " ++ show got ++ ")") + bh <- Binary.readBinMem hi_path + + -- Read the magic number to check that this really is a GHC .hi file + -- (This magic number does not change when we change + -- GHC interface file format) + magic <- get bh + wantedGot "Magic" (binaryInterfaceMagic platform) magic (ppr . unFixedLength) + errorOnMismatch "magic number mismatch: old/corrupt interface file?" + (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic) + + -- Check the interface file version and profile tag. + check_ver <- get bh + let our_ver = show hiVersion + wantedGot "Version" our_ver check_ver text + errorOnMismatch "mismatched interface file versions" our_ver check_ver + + check_tag <- get bh + let tag = profileBuildTag profile + wantedGot "Way" tag check_tag text + when (checkHiWay == CheckHiWay) $ + errorOnMismatch "mismatched interface file profile tag" tag check_tag + + pure bh + +-- | Read an interface file. +-- +-- See Note [Deduplication during iface binary serialisation] for details. +readBinIface + :: Profile + -> NameCache + -> CheckHiWay + -> TraceBinIFace + -> FilePath + -> IO ModIface +readBinIface profile name_cache checkHiWay traceBinIface hi_path = do + bh <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path + + mod_iface <- getIfaceWithExtFields name_cache bh + + return $ mod_iface + + +getIfaceWithExtFields :: NameCache -> ReadBinHandle -> IO ModIface +getIfaceWithExtFields name_cache bh = do + -- Start offset for the byte array that contains the serialised 'ModIface'. + start <- tellBinReader bh + extFields_p_rel <- getRelBin bh + + mod_iface <- getWithUserData name_cache bh + + seekBinReaderRel bh extFields_p_rel + extFields <- get bh + -- Store the 'ModIface' byte array, so that we can avoid serialisation if + -- the 'ModIface' isn't modified. + -- See Note [Sharing of ModIface] + modIfaceBinData <- freezeBinHandle bh start + pure $ mod_iface + & set_mi_ext_fields extFields + & set_mi_hi_bytes (FullIfaceBinHandle $ Strict.Just modIfaceBinData) + +-- | This performs a get action after reading the dictionary and symbol +-- table. It is necessary to run this before trying to deserialise any +-- Names or FastStrings. +getWithUserData :: Binary a => NameCache -> ReadBinHandle -> IO a +getWithUserData name_cache bh = do + bh <- getTables name_cache bh + get bh + +-- | Setup a BinHandle to read something written using putWithTables +-- +-- Reading names has the side effect of adding them into the given NameCache. +getTables :: NameCache -> ReadBinHandle -> IO ReadBinHandle +getTables name_cache bh = do + bhRef <- newIORef (error "used too soon") + -- It is important this is passed to 'getTable' + -- See Note [Lazy ReaderUserData during IfaceType serialisation] + ud <- unsafeInterleaveIO (readIORef bhRef) + + fsReaderTable <- initFastStringReaderTable + nameReaderTable <- initNameReaderTable name_cache + ifaceTypeReaderTable <- initReadIfaceTypeTable ud + + let -- For any 'ReaderTable', we decode the table that is found at the location + -- the forward reference points to. + -- After decoding the table, we create a 'BinaryReader' and immediately + -- add it to the 'ReaderUserData' of 'ReadBinHandle'. + decodeReaderTable :: Typeable a => ReaderTable a -> ReadBinHandle -> IO ReadBinHandle + decodeReaderTable tbl bh0 = do + table <- Binary.forwardGetRel bh (getTable tbl bh0) + let binaryReader = mkReaderFromTable tbl table + pure $ addReaderToUserData binaryReader bh0 + + -- Decode all the tables and populate the 'ReaderUserData'. + bhFinal <- foldM (\bh0 act -> act bh0) bh + -- The order of these deserialisation matters! + -- + -- See Note [Order of deduplication tables during iface binary serialisation] for details. + [ decodeReaderTable fsReaderTable + , decodeReaderTable nameReaderTable + , decodeReaderTable ifaceTypeReaderTable + ] + + writeIORef bhRef (getReaderUserData bhFinal) + pure bhFinal + +-- | Write an interface file. +-- +-- See Note [Deduplication during iface binary serialisation] for details. +writeBinIface :: Profile -> TraceBinIFace -> CompressionIFace -> FilePath -> ModIface -> IO () +writeBinIface profile traceBinIface compressionLevel hi_path mod_iface = do + case traceBinIface of + QuietBinIFace -> pure () + TraceBinIFace printer -> do + printer (text "writeBinIface compression level:" <+> ppr compressionLevel) + + bh <- openBinMem initBinMemSize + let platform = profilePlatform profile + put_ bh (binaryInterfaceMagic platform) + + -- The version, profile tag, and source hash go next + put_ bh (show hiVersion) + let tag = profileBuildTag profile + put_ bh tag + + putIfaceWithExtFields traceBinIface compressionLevel bh mod_iface + + -- And send the result to the file + writeBinMem bh hi_path + +-- | Puts the 'ModIface' to the 'WriteBinHandle'. +-- +-- This avoids serialisation of the 'ModIface' if the fields 'mi_hi_bytes' contains a +-- 'Just' value. This field is populated by reading the 'ModIface' using +-- 'getIfaceWithExtFields' and not modifying it in any way afterwards. +putIfaceWithExtFields :: TraceBinIFace -> CompressionIFace -> WriteBinHandle -> ModIface -> IO () +putIfaceWithExtFields traceBinIface compressionLevel bh mod_iface = + case mi_hi_bytes mod_iface of + FullIfaceBinHandle Strict.Nothing -> do + forwardPutRel_ bh (\_ -> put_ bh (mi_ext_fields mod_iface)) $ do + putWithUserData traceBinIface compressionLevel bh mod_iface + FullIfaceBinHandle (Strict.Just binData) -> putFullBinData bh binData + +-- | Put a piece of data with an initialised `UserData` field. This +-- is necessary if you want to serialise Names or FastStrings. +-- It also writes a symbol table and the dictionary. +-- This segment should be read using `getWithUserData`. +putWithUserData :: Binary a => TraceBinIFace -> CompressionIFace -> WriteBinHandle -> a -> IO () +putWithUserData traceBinIface compressionLevel bh payload = do + (name_count, fs_count, ifacetype_count, _b) <- putWithTables compressionLevel bh (\bh' -> put bh' payload) + + case traceBinIface of + QuietBinIFace -> return () + TraceBinIFace printer -> do + printer (text "writeBinIface:" <+> int name_count + <+> text "Names") + printer (text "writeBinIface:" <+> int fs_count + <+> text "dict entries") + printer (text "writeBinIface:" <+> int ifacetype_count + <+> text "iface type entries") + +-- | Write name/symbol/ifacetype tables +-- +-- 1. setup the given BinHandle with Name/FastString/IfaceType table handling +-- 2. write the following +-- - FastString table pointer +-- - Name table pointer +-- - IfaceType table pointer +-- - payload +-- - IfaceType table +-- - Name table +-- - FastString table +-- +-- It returns (number of names, number of FastStrings, number of IfaceTypes, payload write result) +-- +-- See Note [Order of deduplication tables during iface binary serialisation] +putWithTables :: CompressionIFace -> WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, Int, b) +putWithTables compressionLevel bh' put_payload = do + -- Initialise deduplicating tables. + (fast_wt, fsWriter) <- initFastStringWriterTable + (name_wt, nameWriter) <- initNameWriterTable + (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType compressionLevel + + -- Initialise the 'WriterUserData'. + -- + -- Similar to how 'getTables' calls 'addReaderToUserData', here we + -- call 'addWriterToUserData' instead of 'setWriterUserData', to + -- avoid overwriting existing writers of other types in bh'. + let bh = + addWriterToUserData fsWriter + $ addWriterToUserData nameWriter + -- We sometimes serialise binding and non-binding names differently, but + -- not during 'ModIface' serialisation. Here, we serialise both to the same + -- deduplication table. + -- + -- See Note [Binary UserData] + $ addWriterToUserData + (mkWriter $ \bh name -> putEntry nameWriter bh $ getBindingName name) + $ addWriterToUserData ifaceTypeWriter bh' + + ([fs_count, name_count, ifacetype_count] , r) <- + -- The order of these entries matters! + -- + -- See Note [Order of deduplication tables during iface binary serialisation] for details. + putAllTables bh [fast_wt, name_wt, ifaceType_wt] $ do + put_payload bh + + return (name_count, fs_count, ifacetype_count, r) + +-- | Write all deduplication tables to disk after serialising the +-- main payload. +-- +-- Writes forward pointers to the deduplication tables before writing the payload +-- to allow deserialisation *before* the payload is read again. +putAllTables :: WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b) +putAllTables _ [] act = do + a <- act + pure ([], a) +putAllTables bh (x : xs) act = do + (r, (res, a)) <- forwardPutRel bh (const $ putTable x bh) $ do + putAllTables bh xs act + pure (r : res, a) + +-- | Initial ram buffer to allocate for writing interface files +initBinMemSize :: Int +initBinMemSize = 1024 * 1024 + +binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32 +binaryInterfaceMagic platform + | target32Bit platform = FixedLengthEncoding 0x1face + | otherwise = FixedLengthEncoding 0x1face64 + + +{- +Note [Deduplication during iface binary serialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we serialise a 'ModIface', many symbols are redundant. +For example, there can be many duplicated 'FastString's and 'Name's. +To save space, we deduplicate duplicated symbols, such as 'FastString' and 'Name', +by maintaining a table of already seen symbols. + +Besides saving a lot of disk space, this additionally enables us to automatically share +these symbols when we read the 'ModIface' from disk, without additional mechanisms such as 'FastStringTable'. + +The general idea is, when serialising a value of type 'Name', we first have to create a deduplication +table (see 'putWithTables.initNameWriterTable' for example). Then, we create a 'BinaryWriter' function +which we add to the 'WriterUserData'. When this 'BinaryWriter' is used to serialise a value of type 'Name', +it looks up whether we have seen this value before. If so, we write an index to disk. +If we haven't seen the value before, we add it to the deduplication table and produce a new index. + +Both the 'ReaderUserData' and 'WriterUserData' can contain many 'BinaryReader's and 'BinaryWriter's +respectively, which can each individually be tweaked to use a deduplication table, or to serialise +the value without deduplication. + +After the payload (e.g., the 'ModIface') has been serialised to disk, we serialise the deduplication tables +to disk. This happens in 'putAllTables', where we serialise all tables that we use during 'ModIface' +serialisation. See 'initNameWriterTable' and 'putSymbolTable' for an implementation example. +This uses the 'real' serialisation function, e.g., 'serialiseName'. +However, these tables need to be deserialised before we can read the 'ModIface' from disk. +Thus, we write before the 'ModIface' a forward pointer to the deduplication table, so we can +read this table before deserialising the 'ModIface'. + +To add a deduplication table for a type, let us assume 'IfaceTyCon', you need to do the following: + +* The 'Binary' instance 'IfaceTyCon' needs to dynamically look up the serialiser function instead of + serialising the value of 'IfaceTyCon'. It needs to look up the serialiser in the 'ReaderUserData' and + 'WriterUserData' respectively. + This allows us to change the serialisation of 'IfaceTyCon' at run-time. + We can still serialise 'IfaceTyCon' to disk directly, or use a deduplication table to reduce the size of + the .hi file. + + For example: + + @ + instance Binary IfaceTyCon where + put_ bh ty = case findUserDataWriter (Proxy @IfaceTyCon) bh of + tbl -> putEntry tbl bh ty + get bh = case findUserDataReader (Proxy @IfaceTyCon) bh of + tbl -> getEntry tbl bh + @ + + We include the signatures of 'findUserDataWriter' and 'findUserDataReader' to make this code example + easier to understand: + + @ + findUserDataReader :: Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a + findUserDataWriter :: Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a + @ + + where 'BinaryReader' and 'BinaryWriter' correspond to the 'Binary' class methods + 'get' and 'put_' respectively, thus: + + @ + newtype BinaryReader s = BinaryReader { getEntry :: ReadBinHandle -> IO s } + + newtype BinaryWriter s = BinaryWriter { putEntry :: WriteBinHandle -> s -> IO () } + @ + + 'findUserData*' looks up the serialisation function for 'IfaceTyCon', which we then subsequently + use to serialise said 'IfaceTyCon'. If no such serialiser can be found, 'findUserData*' + crashes at run-time. + +* Whenever a value of 'IfaceTyCon' needs to be serialised, there are two serialisation functions involved: + + * The literal serialiser that puts/gets the value to/from disk: + Writes or reads a value of type 'IfaceTyCon' from the 'Write/ReadBinHandle'. + This serialiser is primarily used to write the values stored in the deduplication table. + It is also used to read the values from disk. + + * The deduplicating serialiser: + Replaces the serialised value of 'IfaceTyCon' with an offset that is stored in the + deduplication table. + This serialiser is used while serialising the payload. + + We need to add the deduplicating serialiser to the 'ReaderUserData' and 'WriterUserData' + respectively, so that 'findUserData*' can find them. + + For example, adding a serialiser for writing 'IfaceTyCon's: + + @ + let bh0 :: WriteBinHandle = ... + putIfaceTyCon = ... -- Serialises 'IfaceTyCon' to disk + bh = addWriterToUserData (mkSomeBinaryWriter putIfaceTyCon) bh0 + @ + + Naturally, you have to do something similar for reading values of 'IfaceTyCon'. + + The provided code example implements the previous behaviour: + serialise all values of type 'IfaceTyCon' directly. No deduplication is happening. + + Now, instead of literally putting the value, we can introduce a deduplication table! + Instead of specifying 'putIfaceTyCon', which writes a value of 'IfaceTyCon' directly to disk, + we provide a function that looks up values in a table and provides an index of each value + we have already seen. + If the particular 'IfaceTyCon' we want to serialise isn't already in the de-dup table, + we allocate a new index and extend the table. + + See the definition of 'initNameWriterTable' and 'initNameReaderTable' for example deduplication tables. + +* Storing the deduplication table. + + After the deduplicating the elements in the payload (e.g., 'ModIface'), we now have a deduplication + table full with all the values. + We serialise this table to disk using the real serialiser (e.g., 'putIfaceTyCon'). + + When serialisation is complete, we write out the de-dup table in 'putAllTables', + serialising each 'IfaceTyCon' in the table. Of course, doing so might in turn serialise + another de-dup'd thing (e.g. a FastString), thereby extending its respective de-dup table. + +Note [Order of deduplication tables during iface binary serialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Serialisation of 'ModIface' uses tables to deduplicate symbols that occur often. +See Note [Deduplication during iface binary serialisation]. + +After 'ModIface' has been written to disk, we write the deduplication tables. +Writing a table may add additional entries to *other* deduplication tables, thus +we need to make sure that the symbol table we serialise only depends on +deduplication tables that haven't been written to disk yet. + +For example, assume we maintain deduplication tables for 'FastString' and 'Name'. +The symbol 'Name' depends on 'FastString', so serialising a 'Name' may add a 'FastString' +to the 'FastString' deduplication table. +Thus, 'Name' table needs to be serialised to disk before the 'FastString' table. + +When we read the 'ModIface' from disk, we consequentially need to read the 'FastString' +deduplication table from disk, before we can deserialise the 'Name' deduplication table. +Therefore, before we serialise the tables, we write forward pointers that allow us to jump ahead +to the table we need to deserialise first. +What deduplication tables exist and the order of serialisation is currently statically specified +in 'putWithTables'. 'putWithTables' also takes care of the serialisation of used deduplication tables. +The deserialisation of the deduplication tables happens 'getTables', using 'Binary' utility +functions such as 'forwardGetRel'. + +Here, a visualisation of the table structure we currently have (ignoring 'ExtensibleFields'): + +┌──────────────┐ +│ Headers │ +├──────────────┤ +│ Ptr FS ├────────┐ +├──────────────┤ │ +│ Ptr Name ├─────┐ │ +├──────────────┤ │ │ +│ │ │ │ +│ ModIface │ │ │ +│ Payload │ │ │ +│ │ │ │ +├──────────────┤ │ │ +│ │ │ │ +│ Name Table │◄────┘ │ +│ │ │ +├──────────────┤ │ +│ │ │ +│ FS Table │◄───────┘ +│ │ +└──────────────┘ + +-} + +{- +Note [Lazy ReaderUserData during IfaceType serialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Serialising recursive data types, such as 'IfaceType', requires some trickery +to inject the deduplication table at the right moment. + +When we serialise a value of 'IfaceType', we might encounter new 'IfaceType' values. +For example, 'IfaceAppTy' has an 'IfaceType' field, which we want to deduplicate as well. +Thus, when we serialise an 'IfaceType', we might add new 'IfaceType's to the 'GenericSymbolTable' +(i.e., the deduplication table). These 'IfaceType's are then subsequently also serialised to disk, +and uncover new 'IfaceType' values, etc... +In other words, when we serialise an 'IfaceType' we write it out using a post-order traversal. +See 'putGenericSymbolTable' for the implementation. + +Now, when we deserialise the deduplication table, reading the first element of the deduplication table +will fail, as deserialisation requires that we read the child elements first. Remember, we wrote them to disk +using a post-order traversal. +To make this work, we therefore use 'lazyGet'' to lazily read the parent 'IfaceType', but delay the actual +deserialisation. We just assume that once you need to force a value, the deduplication table for 'IfaceType' +will be available. + +That's where 'bhRef' comes into play: + +@ + bhRef <- newIORef (error "used too soon") + ud <- unsafeInterleaveIO (readIORef bhRef) + ... + ifaceTypeReaderTable <- initReadIfaceTypeTable ud + ... + writeIORef bhRef (getReaderUserData bhFinal) +@ + +'ud' is the 'ReaderUserData' that will eventually contain the deduplication table for 'IfaceType'. +As deserialisation of the 'IfaceType' needs the deduplication table, we provide a +promise that it will exist in the future (represented by @unsafeInterleaveIO (readIORef bhRef)@). +We pass 'ud' to 'initReadIfaceTypeTable', so the deserialisation will use the promised deduplication table. + +Once we have "read" the deduplication table, it will be available in 'bhFinal', and we fulfill the promise +that the deduplication table for 'IfaceType' exists when forced. +-} + +-- ----------------------------------------------------------------------------- +-- The symbol table +-- + +initReadIfaceTypeTable :: ReaderUserData -> IO (ReaderTable IfaceType) +initReadIfaceTypeTable ud = do + pure $ + ReaderTable + { getTable = getGenericSymbolTable (\bh -> lazyGet' getIfaceType (setReaderUserData bh ud)) + , mkReaderFromTable = \tbl -> mkReader (getGenericSymtab tbl) + } + +initWriteIfaceType :: CompressionIFace -> IO (WriterTable, BinaryWriter IfaceType) +initWriteIfaceType compressionLevel = do + sym_tab <- initGenericSymbolTable @(Map IfaceType) + pure + ( WriterTable + { putTable = putGenericSymbolTable sym_tab (lazyPut' putIfaceType) + } + , mkWriter $ ifaceWriter sym_tab + ) + where + ifaceWriter sym_tab = case compressionLevel of + NormalCompression -> literalIfaceTypeSerialiser + SafeExtraCompression -> ifaceTyConAppSerialiser sym_tab + MaximumCompression -> fullIfaceTypeSerialiser sym_tab + + ifaceTyConAppSerialiser sym_tab bh ty = case ty of + IfaceTyConApp {} -> do + put_ bh ifaceTypeSharedByte + putGenericSymTab sym_tab bh ty + _ -> putIfaceType bh ty + + fullIfaceTypeSerialiser sym_tab bh ty = do + put_ bh ifaceTypeSharedByte + putGenericSymTab sym_tab bh ty + + literalIfaceTypeSerialiser = putIfaceType + + +initNameReaderTable :: NameCache -> IO (ReaderTable Name) +initNameReaderTable cache = do + return $ + ReaderTable + { getTable = \bh -> getSymbolTable bh cache + , mkReaderFromTable = \tbl -> mkReader (getSymtabName tbl) + } + +data BinSymbolTable = BinSymbolTable { + bin_symtab_next :: !FastMutInt, -- The next index to use + bin_symtab_map :: !(IORef (UniqFM Name (Int,Name))) + -- indexed by Name + } + +initNameWriterTable :: IO (WriterTable, BinaryWriter Name) +initNameWriterTable = do + symtab_next <- newFastMutInt 0 + symtab_map <- newIORef emptyUFM + let bin_symtab = + BinSymbolTable + { bin_symtab_next = symtab_next + , bin_symtab_map = symtab_map + } + + let put_symtab bh = do + name_count <- readFastMutInt symtab_next + symtab_map <- readIORef symtab_map + putSymbolTable bh name_count symtab_map + pure name_count + + return + ( WriterTable + { putTable = put_symtab + } + , mkWriter $ putName bin_symtab + ) + + +putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,Name) -> IO () +putSymbolTable bh name_count symtab = do + put_ bh name_count + let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab)) + -- It's OK to use nonDetEltsUFM here because the elements have + -- indices that array uses to create order + mapM_ (\n -> serialiseName bh n symtab) names + + +getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name) +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 :: WriteBinHandle -> Name -> UniqFM key (Int,Name) -> IO () +serialiseName bh name _ = do + let mod = assertPpr (isExternalName name) (ppr name) (nameModule name) + put_ bh (moduleUnit mod, moduleName mod, nameOccName name) + + +-- Note [Symbol table representation of names] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- An occurrence of a name in an interface file is serialized as a single 32-bit +-- word. The format of this word is: +-- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx +-- A normal name. x is an index into the symbol table +-- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy +-- A known-key name. x is the Unique's Char, y is the int part. We assume that +-- all known-key uniques fit in this space. This is asserted by +-- GHC.Builtin.Utils.knownKeyNamesOkay. +-- +-- During serialization we check for known-key things using isKnownKeyName. +-- During deserialization we use lookupKnownKeyName to get from the unique back +-- to its corresponding Name. + + +-- See Note [Symbol table representation of names] +putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO () +putName BinSymbolTable{ + bin_symtab_map = symtab_map_ref, + bin_symtab_next = symtab_next } + bh name + | isKnownKeyName name + , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits + = -- assert (u < 2^(22 :: Int)) + put_ bh (0x80000000 + .|. (fromIntegral (ord c) `shiftL` 22) + .|. (fromIntegral u :: Word32)) + + | otherwise + = do symtab_map <- readIORef symtab_map_ref + case lookupUFM symtab_map name of + Just (off,_) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt symtab_next + -- massert (off < 2^(30 :: Int)) + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! addToUFM symtab_map name (off,name) + put_ bh (fromIntegral off :: Word32) + +-- See Note [Symbol table representation of names] +getSymtabName :: SymbolTable Name + -> ReadBinHandle -> IO Name +getSymtabName symtab bh = do + i :: Word32 <- get bh + case i .&. 0xC0000000 of + 0x00000000 -> return $! symtab ! fromIntegral i + + 0x80000000 -> + let + tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) + ix = fromIntegral i .&. 0x003FFFFF + u = mkUnique tag ix + in + return $! case lookupKnownKeyName u of + Nothing -> pprPanic "getSymtabName:unknown known-key unique" + (ppr i $$ ppr u $$ char tag $$ ppr ix) + Just n -> n + + _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) diff --git a/GHC/Iface/Decl.hs b/GHC/Iface/Decl.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Decl.hs @@ -0,0 +1,336 @@ + +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE LambdaCase #-} + +{- +(c) The University of Glasgow 2006-2008 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +-- | Module for constructing interface declaration values +-- from the corresponding 'TyThing's. + +module GHC.Iface.Decl + ( coAxiomToIfaceDecl + , tyThingToIfaceDecl -- Converting things to their Iface equivalents + ) +where + +import GHC.Prelude + +import GHC.Tc.Utils.TcType + +import GHC.Iface.Syntax + +import GHC.CoreToIface + +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.TyCo.Tidy + +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Types.TyThing + +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc + +import GHC.Data.Maybe +import Data.List ( findIndex, mapAccumL ) + +{- +************************************************************************ +* * + Converting things to their Iface equivalents +* * +************************************************************************ +-} + +tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl +tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id +tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) +tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax +tyThingToIfaceDecl show_linear_types (AConLike cl) = case cl of + RealDataCon dc -> dataConToIfaceDecl show_linear_types dc -- for ppr purposes only + PatSynCon ps -> patSynToIfaceDecl ps + +-------------------------- +idToIfaceDecl :: Id -> IfaceDecl +-- The Id is already tidied, so that locally-bound names +-- (lambdas, for-alls) already have non-clashing OccNames +-- We can't tidy it here, locally, because it may have +-- free variables in its type or IdInfo +idToIfaceDecl id + = IfaceId { ifName = getName id, + ifType = toIfaceType (idType id), + ifIdDetails = toIfaceIdDetails (idDetails id), + ifIdInfo = toIfaceIdInfo (idInfo id) } + +-------------------------- +dataConToIfaceDecl :: Bool -> DataCon -> IfaceDecl +dataConToIfaceDecl show_linear_types dataCon + = IfaceId { ifName = getName dataCon, + ifType = toIfaceType (dataConDisplayType show_linear_types dataCon), + ifIdDetails = IfVanillaId, + ifIdInfo = [] } + +-------------------------- +coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl +-- We *do* tidy Axioms, because they are not (and cannot +-- conveniently be) built in tidy form +coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches + , co_ax_role = role }) + = IfaceAxiom { ifName = getName ax + , ifTyCon = toIfaceTyCon tycon + , ifRole = role + , ifAxBranches = map (coAxBranchToIfaceBranch tycon + (map coAxBranchLHS branch_list)) + branch_list } + where + branch_list = fromBranches branches + +-- 2nd parameter is the list of branch LHSs, in case of a closed type family, +-- for conversion from incompatible branches to incompatible indices. +-- For an open type family the list should be empty. +-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom +coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch tc lhs_s + (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_eta_tvs = eta_tvs + , cab_lhs = lhs, cab_roles = roles + , cab_rhs = rhs, cab_incomps = incomps }) + + = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs + , ifaxbCoVars = map toIfaceIdBndr cvs + , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs + , ifaxbLHS = toIfaceTcArgs tc lhs + , ifaxbRoles = roles + , ifaxbRHS = toIfaceType rhs + , ifaxbIncomps = iface_incomps } + where + iface_incomps = map (expectJust + . flip findIndex lhs_s + . eqTypes + . coAxBranchLHS) incomps + +----------------- +tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) +-- We *do* tidy TyCons, because they are not (and cannot +-- conveniently be) built in tidy form +-- The returned TidyEnv is the one after tidying the tyConTyVars +tyConToIfaceDecl env tycon + | Just clas <- tyConClass_maybe tycon + = classToIfaceDecl env clas + + | Just syn_rhs <- synTyConRhs_maybe tycon + = ( tc_env1 + , IfaceSynonym { ifName = getName tycon, + ifRoles = tyConRoles tycon, + ifSynRhs = if_syn_type syn_rhs, + ifBinders = if_binders, + ifResKind = if_res_kind + }) + + | Just fam_flav <- famTyConFlav_maybe tycon + = ( tc_env1 + , IfaceFamily { ifName = getName tycon, + ifResVar = mkIfLclName <$> if_res_var, + ifFamFlav = to_if_fam_flav fam_flav, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifFamInj = tyConInjectivityInfo tycon + }) + + | isAlgTyCon tycon + = ( tc_env1 + , IfaceData { ifName = getName tycon, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifCType = tyConCType_maybe tycon, + ifRoles = tyConRoles tycon, + ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), + ifCons = ifaceConDecls (algTyConRhs tycon), + ifGadtSyntax = isGadtSyntaxTyCon tycon, + ifParent = parent }) + + | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon + -- We only convert these TyCons to IfaceTyCons when we are + -- just about to pretty-print them, not because we are going + -- to put them into interface files + = ( env + , IfaceData { ifName = getName tycon, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifCType = Nothing, + ifRoles = tyConRoles tycon, + ifCtxt = [], + ifCons = IfDataTyCon False [], + ifGadtSyntax = False, + ifParent = IfNoParent }) + where + -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon` + -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause + -- an error. + (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) + tc_tyvars = binderVars tc_binders + if_binders = toIfaceForAllBndrs tc_binders + -- No tidying of the binders; they are already tidy + if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) + if_syn_type ty = tidyToIfaceType tc_env1 ty + if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon + + parent = case tyConFamInstSig_maybe tycon of + Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) + (toIfaceTyCon tc) + (tidyToIfaceTcArgs tc_env1 tc ty) + Nothing -> IfNoParent + + to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon + to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon + to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon + to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon + to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing + to_if_fam_flav (ClosedSynFamilyTyCon (Just ax)) + = IfaceClosedSynFamilyTyCon (Just (axn, ibr)) + where defs = fromBranches $ coAxiomBranches ax + lhss = map coAxBranchLHS defs + ibr = map (coAxBranchToIfaceBranch tycon lhss) defs + axn = coAxiomName ax + + ifaceConDecls (DataTyCon { data_cons = cons, is_type_data = type_data }) + = IfDataTyCon type_data (map ifaceConDecl cons) + ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) + ifaceConDecls (UnaryClassTyCon { data_con = con}) = IfDataTyCon False [ifaceConDecl con] + ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon False [ifaceConDecl con] + ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon False (map ifaceConDecl cons) + ifaceConDecls AbstractTyCon = IfAbstractTyCon + -- The AbstractTyCon case happens when a TyCon has been trimmed during tidying. + -- + -- NB: TupleTyCon/SumTyCon/UnaryClassTyCon are never serialised into interface files + -- But tyThingToIfaceDecl is also used in GHC.Tc.Module + -- for GHCi, when browsing a module, in which case the + -- AbstractTyCon, TupleTyCon, SumTyCon are perfectly sensible. + -- (Not sure about UnaryClassTyCon, but easier to treat it uniformly.) + + ifaceConDecl data_con + = IfCon { ifConName = dataConName data_con, + ifConInfix = dataConIsInfix data_con, + ifConWrapper = isJust (dataConWrapId_maybe data_con), + ifConExTCvs = map toIfaceBndr ex_tvs', + ifConUserTvBinders = toIfaceForAllBndrs user_bndrs', + ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, + ifConCtxt = tidyToIfaceContext con_env2 theta, + ifConArgTys = + map (\(Scaled w t) -> (tidyToIfaceType con_env2 w + , (tidyToIfaceType con_env2 t))) arg_tys, + ifConFields = dataConFieldLabels data_con, + ifConStricts = map (toIfaceBang con_env2) + (dataConImplBangs data_con), + ifConSrcStricts = map toIfaceSrcBang + (dataConSrcBangs data_con)} + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) + = dataConFullSig data_con + user_bndrs = dataConUserTyVarBinders data_con + + -- Tidy the univ_tvs of the data constructor to be identical + -- to the tyConTyVars of the type constructor. This means + -- (a) we don't need to redundantly put them into the interface file + -- (b) when pretty-printing an Iface data declaration in H98-style syntax, + -- we know that the type variables will line up + -- The latter (b) is important because we pretty-print type constructors + -- by converting to Iface syntax and pretty-printing that + con_env1 = (fst tc_env1, mkVarEnv (zipEqual univ_tvs tc_tyvars)) + -- A bit grimy, perhaps, but it's simple! + + (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs + user_bndrs' = map (tidyUserForAllTyBinder con_env2) user_bndrs + to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty) + + -- By this point, we have tidied every universal and existential + -- tyvar. Because of the dcUserForAllTyBinders invariant + -- (see Note [DataCon user type variable binders]), *every* + -- user-written tyvar must be contained in the substitution that + -- tidying produced. Therefore, tidying the user-written tyvars is a + -- simple matter of looking up each variable in the substitution, + -- which tidyTyCoVarOcc accomplishes. + tidyUserForAllTyBinder :: TidyEnv -> TyVarBinder -> TyVarBinder + tidyUserForAllTyBinder env (Bndr tv vis) = + Bndr (tidyTyCoVarOcc env tv) vis + +classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) +classToIfaceDecl env clas + = ( env1 + , IfaceClass { ifName = getName tycon, + ifRoles = tyConRoles (classTyCon clas), + ifBinders = toIfaceForAllBndrs tc_binders, + ifBody = body, + ifFDs = map toIfaceFD clas_fds }) + where + (_, clas_fds, sc_theta, _, clas_ats, op_stuff) + = classExtraBigSig clas + tycon = classTyCon clas + + body | isAbstractTyCon tycon = IfAbstractClass + | otherwise + = IfConcreteClass { + ifClassCtxt = tidyToIfaceContext env1 sc_theta, + ifATs = map toIfaceAT clas_ats, + ifSigs = map toIfaceClassOp op_stuff, + ifMinDef = toIfaceBooleanFormula (classMinimalDef clas), + ifUnary = isUnaryClassTyCon tycon + } + + (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) + + toIfaceAT :: ClassATItem -> IfaceAT + toIfaceAT (ATI tc def) + = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def) + where + (env2, if_decl) = tyConToIfaceDecl env1 tc + + toIfaceClassOp (sel_id, def_meth) + = assert (sel_tyvars == binderVars tc_binders) $ + IfaceClassOp (getName sel_id) + (tidyToIfaceType env1 op_ty) + (fmap toDmSpec def_meth) + where + -- Be careful when splitting the type, because of things + -- like class Foo a where + -- op :: (?x :: String) => a -> a + -- and class Baz a where + -- op :: (Ord a) => a -> a + (sel_tyvars, rho_ty) = splitForAllTyCoVars (idType sel_id) + op_ty = funResultTy rho_ty + + toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType + toDmSpec (_, VanillaDM) = VanillaDM + toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty) + + toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1 + ,map (tidyTyVar env1) tvs2) + +-------------------------- + +tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder) +-- If the type variable "binder" is in scope, don't re-bind it +-- In a class decl, for example, the ATD binders mention +-- (amd must mention) the class tyvars +tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis) + = case lookupVarEnv subst tv of + Just tv' -> (env, Bndr tv' vis) + Nothing -> tidyForAllTyBinder env tvb + +tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) +tidyTyConBinders = mapAccumL tidyTyConBinder + +tidyTyVar :: TidyEnv -> TyVar -> IfLclName +tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) diff --git a/GHC/Iface/Env.hs b/GHC/Iface/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Env.hs @@ -0,0 +1,283 @@ +-- (c) The University of Glasgow 2002-2006 + +{-# LANGUAGE RankNTypes #-} + +module GHC.Iface.Env ( + newGlobalBinder, newInteractiveBinder, + externaliseName, + lookupIfaceTop, + lookupOrig, lookupNameCache, lookupOrigNameCache, + newIfaceName, newIfaceNames, + extendIfaceIdEnv, extendIfaceTyVarEnv, + tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar, + lookupIfaceTyVar, extendIfaceEnvs, + setNameModule, + + ifaceExportNames, + + trace_if, trace_hi_diffs, trace_hi_diffs_io, + + -- Name-cache stuff + allocateGlobalBinder, + ) where + +import GHC.Prelude + +import GHC.Driver.Env +import GHC.Driver.DynFlags + +import GHC.Tc.Utils.Monad +import GHC.Core.Type +import GHC.Iface.Type +import GHC.Runtime.Context + +import GHC.Unit.Module +import GHC.Unit.Module.ModIface + +import GHC.Data.FastString.Env + +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Avail +import GHC.Types.Name.Cache +import GHC.Types.Unique.Supply +import GHC.Types.SrcLoc + +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Utils.Logger + +import Data.List ( partition ) +import Control.Monad + +{- +********************************************************* +* * + Allocating new Names in the Name Cache +* * +********************************************************* + +See Also: Note [The Name Cache] in GHC.Types.Name.Cache +-} + +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name +-- Used for source code and interface files, to make the +-- Name for a thing, given its Module and OccName +-- See Note [The Name Cache] in GHC.Types.Name.Cache +-- +-- The cache may already have a binding for this thing, +-- because we may have seen an occurrence before, but now is the +-- moment when we know its Module and SrcLoc in their full glory + +newGlobalBinder mod occ loc + = do { hsc_env <- getTopEnv + ; name <- liftIO $ allocateGlobalBinder (hsc_NC hsc_env) mod occ loc + ; traceIf (text "newGlobalBinder" <+> + (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name])) + ; return name } + +newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name +-- Works in the IO monad, and gets the Module +-- from the interactive context +newInteractiveBinder hsc_env occ loc = do + let mod = icInteractiveModule (hsc_IC hsc_env) + allocateGlobalBinder (hsc_NC hsc_env) mod occ loc + +allocateGlobalBinder + :: NameCache + -> Module -> OccName -> SrcSpan + -> IO Name +-- See Note [The Name Cache] in GHC.Types.Name.Cache +allocateGlobalBinder nc mod occ loc + = updateNameCache nc mod occ $ \cache0 -> do + case lookupOrigNameCache cache0 mod occ of + -- A hit in the cache! We are at the binding site of the name. + -- This is the moment when we know the SrcLoc + -- of the Name, so we set this field in the Name we return. + -- + -- Then (bogus) multiple bindings of the same Name + -- get different SrcLocs can be reported as such. + -- + -- Possible other reason: it might be in the cache because we + -- encountered an occurrence before the binding site for an + -- implicitly-imported Name. Perhaps the current SrcLoc is + -- better... but not really: it'll still just say 'imported' + -- + -- IMPORTANT: Don't mess with wired-in names. + -- Their wired-in-ness is in their NameSort + -- and their Module is correct. + + Just name | isWiredInName name + -> pure (cache0, name) + | otherwise + -> pure (new_cache, name') + where + uniq = nameUnique name + name' = mkExternalName uniq mod occ loc + -- name' is like name, but with the right SrcSpan + new_cache = extendOrigNameCache cache0 mod occ name' + + -- Miss in the cache! + -- Build a completely new Name, and put it in the cache + _ -> do + uniq <- takeUniqFromNameCache nc + let name = mkExternalName uniq mod occ loc + let new_cache = extendOrigNameCache cache0 mod occ name + pure (new_cache, name) + +ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] +ifaceExportNames exports = return exports + +{- +************************************************************************ +* * + Name cache access +* * +************************************************************************ +-} + +-- | Look up the 'Name' for a given 'Module' and 'OccName'. +-- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad +-- and 'Module' is simply that of the 'ModIface' you are typechecking. +lookupOrig :: Module -> OccName -> TcRnIf a b Name +lookupOrig mod occ = do + hsc_env <- getTopEnv + traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) + liftIO $ lookupNameCache (hsc_NC hsc_env) mod occ + +lookupNameCache :: NameCache -> Module -> OccName -> IO Name +-- Lookup up the (Module,OccName) in the NameCache +-- If you find it, return it; if not, allocate a fresh original name and extend +-- the NameCache. +-- Reason: this may the first occurrence of (say) Foo.bar we have encountered. +-- If we need to explore its value we will load Foo.hi; but meanwhile all we +-- need is a Name for it. +lookupNameCache nc mod occ = updateNameCache nc mod occ $ \cache0 -> + case lookupOrigNameCache cache0 mod occ of + Just name -> pure (cache0, name) + Nothing -> do + uniq <- takeUniqFromNameCache nc + let name = mkExternalName uniq mod occ noSrcSpan + let new_cache = extendOrigNameCache cache0 mod occ name + pure (new_cache, name) + +externaliseName :: Module -> Name -> TcRnIf m n Name +-- Take an Internal Name and make it an External one, +-- with the same unique +externaliseName mod name + = do { let occ = nameOccName name + loc = nameSrcSpan name + uniq = nameUnique name + ; occ `seq` return () -- c.f. seq in newGlobalBinder + ; hsc_env <- getTopEnv + ; liftIO $ updateNameCache (hsc_NC hsc_env) mod occ $ \cache -> do + let name' = mkExternalName uniq mod occ loc + cache' = extendOrigNameCache cache mod occ name' + pure (cache', name') } + +-- | Set the 'Module' of a 'Name'. +setNameModule :: Maybe Module -> Name -> TcRnIf m n Name +setNameModule Nothing n = return n +setNameModule (Just m) n = + newGlobalBinder m (nameOccName n) (nameSrcSpan n) + +{- +************************************************************************ +* * + Type variables and local Ids +* * +************************************************************************ +-} + +tcIfaceLclId :: IfLclName -> IfL Id +tcIfaceLclId occ + = do { lcl <- getLclEnv + ; case lookupFsEnv (if_id_env lcl) (ifLclNameFS occ) of + Just ty_var -> return ty_var + Nothing -> failIfM $ + vcat + [ text "Iface id out of scope: " <+> ppr occ + , text "env:" <+> ppr (if_id_env lcl) ] + } + +extendIfaceIdEnv :: [Id] -> IfL a -> IfL a +extendIfaceIdEnv ids + = updLclEnv $ \env -> + let { id_env' = extendFsEnvList (if_id_env env) pairs + ; pairs = [(occNameFS (getOccName id), id) | id <- ids] } + in env { if_id_env = id_env' } + + +tcIfaceTyVar :: IfLclName -> IfL TyVar +tcIfaceTyVar occ + = do { lcl <- getLclEnv + ; case lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ) of + Just ty_var -> return ty_var + Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ) + } + +lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar) +lookupIfaceTyVar (occ, _) + = do { lcl <- getLclEnv + ; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) } + +lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar) +lookupIfaceVar (IfaceIdBndr (_, occ, _)) + = do { lcl <- getLclEnv + ; return (lookupFsEnv (if_id_env lcl) (ifLclNameFS occ)) } +lookupIfaceVar (IfaceTvBndr (occ, _)) + = do { lcl <- getLclEnv + ; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) } + +extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a +extendIfaceTyVarEnv tyvars + = updLclEnv $ \env -> + let { tv_env' = extendFsEnvList (if_tv_env env) pairs + ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] } + in env { if_tv_env = tv_env' } + +extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a +extendIfaceEnvs tcvs thing_inside + = extendIfaceTyVarEnv tvs $ + extendIfaceIdEnv cvs $ + thing_inside + where + (tvs, cvs) = partition isTyVar tcvs + +{- +************************************************************************ +* * + Getting from RdrNames to Names +* * +************************************************************************ +-} + +-- | Look up a top-level name from the current Iface module +lookupIfaceTop :: OccName -> IfL Name +lookupIfaceTop occ + = do { env <- getLclEnv; lookupOrig (if_mod env) occ } + +newIfaceName :: OccName -> IfL Name +newIfaceName occ + = do { uniq <- newUnique + ; return $! mkInternalName uniq occ noSrcSpan } + +newIfaceNames :: [OccName] -> IfL [Name] +newIfaceNames occs + = do { uniqs <- getUniquesM + ; return [ mkInternalName uniq occ noSrcSpan + | (occ,uniq) <- occs `zip` uniqs] } + +trace_if :: Logger -> SDoc -> IO () +{-# INLINE trace_if #-} -- see Note [INLINE conditional tracing utilities] +trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc + +trace_hi_diffs_io :: Logger -> IO SDoc -> IO () +{-# INLINE trace_hi_diffs_io #-} -- see Note [INLINE conditional tracing utilities] +trace_hi_diffs_io logger doc = + when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ + doc >>= putMsg logger + +trace_hi_diffs :: Logger -> SDoc -> IO () +{-# INLINE trace_hi_diffs #-} -- see Note [INLINE conditional tracing utilities] +trace_hi_diffs logger doc = trace_hi_diffs_io logger (pure doc) diff --git a/GHC/Iface/Env.hs-boot b/GHC/Iface/Env.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Iface/Env.hs-boot @@ -0,0 +1,9 @@ +module GHC.Iface.Env where + +import GHC.Unit.Module +import GHC.Types.Name.Occurrence +import GHC.Tc.Utils.Monad +import GHC.Types.Name +import GHC.Types.SrcLoc + +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name diff --git a/GHC/Iface/Errors.hs b/GHC/Iface/Errors.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Errors.hs @@ -0,0 +1,149 @@ + +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Iface.Errors + ( badIfaceFile + , cannotFindInterface + , cantFindInstalledErr + , cannotFindModule + ) where + +import GHC.Platform.Profile +import GHC.Platform.Ways +import GHC.Utils.Panic.Plain +import GHC.Driver.DynFlags +import GHC.Driver.Env +import GHC.Data.Maybe +import GHC.Data.OsPath +import GHC.Prelude +import GHC.Unit +import GHC.Unit.Env +import GHC.Unit.Finder.Types +import GHC.Utils.Outputable as Outputable +import GHC.Iface.Errors.Types + +-- ----------------------------------------------------------------------------- +-- Error messages + +badIfaceFile :: String -> SDoc -> SDoc +badIfaceFile file err + = vcat [text "Bad interface file:" <+> text file, + nest 4 err] + +cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile + -> ModuleName -> InstalledFindResult -> MissingInterfaceError +cannotFindInterface us mhu p mn ifr = + CantFindErr us FindingInterface $ + cantFindInstalledErr us mhu p mn ifr + +cantFindInstalledErr + :: UnitState + -> Maybe HomeUnit + -> Profile + -> ModuleName + -> InstalledFindResult + -> CantFindInstalled +cantFindInstalledErr unit_state mhome_unit profile mod_name find_result + = CantFindInstalled mod_name more_info + where + build_tag = waysBuildTag (profileWays profile) + + more_info + = case find_result of + InstalledNoPackage pkg + -> NoUnitIdMatching pkg (searchPackageId unit_state (PackageId (unitIdFS pkg))) + + InstalledNotFound files mb_pkg + | Just pkg <- mb_pkg + , notHomeUnitId mhome_unit pkg + -> not_found_in_package pkg $ fmap unsafeDecodeUtf files + + | null files + -> NotAModule + + | otherwise + -> CouldntFindInFiles $ fmap unsafeDecodeUtf files + + _ -> panic "cantFindInstalledErr" + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + MissingPackageWayFiles build pkg files + | otherwise + = MissingPackageFiles pkg files + + + +cannotFindModule :: HscEnv -> ModuleName -> FindResult -> MissingInterfaceError +cannotFindModule hsc_env = cannotFindModule' + (hsc_unit_env hsc_env) + (targetProfile (hsc_dflags hsc_env)) + + +cannotFindModule' :: UnitEnv -> Profile -> ModuleName -> FindResult + -> MissingInterfaceError +cannotFindModule' unit_env profile mod res = + CantFindErr (ue_homeUnitState unit_env) FindingModule $ + cantFindErr unit_env + profile + mod + res + +cantFindErr + :: UnitEnv + -> Profile + -> ModuleName + -> FindResult + -> CantFindInstalled +cantFindErr _ _ mod_name (FoundMultiple mods) + = CantFindInstalled mod_name (MultiplePackages mods) + +cantFindErr unit_env profile mod_name find_result + = CantFindInstalled mod_name more_info + where + mhome_unit = ue_homeUnit unit_env + more_info + = case find_result of + NoPackage pkg + -> NoUnitIdMatching (toUnitId pkg) [] + 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 (toUnitId 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 (toUnitId pkg) files + + | not (null suggest) + -> ModuleSuggestion suggest files + + | null files && null mod_hiddens && + null pkg_hiddens && null unusables + -> NotAModule + + | otherwise + -> GenericMissing + (map ((\uid -> (uid, lookupUnit (ue_homeUnitState unit_env) uid))) pkg_hiddens) + mod_hiddens unusables 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 + MissingPackageWayFiles build pkg files + + | otherwise + = MissingPackageFiles pkg files diff --git a/GHC/Iface/Errors/Ppr.hs b/GHC/Iface/Errors/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Errors/Ppr.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic IfaceMessage +{-# LANGUAGE InstanceSigs #-} + +module GHC.Iface.Errors.Ppr + ( IfaceMessageOpts(..) + , interfaceErrorHints + , interfaceErrorReason + , interfaceErrorDiagnostic + , missingInterfaceErrorHints + , missingInterfaceErrorReason + , missingInterfaceErrorDiagnostic + , readInterfaceErrorDiagnostic + + , lookingForHerald + , cantFindErrorX + , mayShowLocations + , pkgHiddenHint + ) + where + +import GHC.Prelude + +import GHC.Types.Error +import GHC.Types.Hint.Ppr () -- Outputable GhcHint +import GHC.Types.Error.Codes +import GHC.Types.Name +import GHC.Types.TyThing + +import GHC.Unit.State +import GHC.Unit.Module + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Iface.Errors.Types + +defaultIfaceMessageOpts :: IfaceMessageOpts +defaultIfaceMessageOpts = IfaceMessageOpts { ifaceShowTriedFiles = False + , ifaceBuildingCabalPackage = NoBuildingCabalPackage } + +instance HasDefaultDiagnosticOpts IfaceMessageOpts where + defaultOpts = defaultIfaceMessageOpts + +instance Diagnostic IfaceMessage where + type DiagnosticOpts IfaceMessage = IfaceMessageOpts + diagnosticMessage opts reason = mkSimpleDecorated $ + interfaceErrorDiagnostic opts reason + + diagnosticReason = interfaceErrorReason + + diagnosticHints = interfaceErrorHints + + diagnosticCode = constructorCode @GHC + +interfaceErrorHints :: IfaceMessage -> [GhcHint] +interfaceErrorHints = \ case + Can'tFindInterface err _looking_for -> + missingInterfaceErrorHints err + Can'tFindNameInInterface {} -> + noHints + CircularImport {} -> + noHints + +missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint] +missingInterfaceErrorHints = \case + BadSourceImport {} -> + noHints + HomeModError {} -> + noHints + DynamicHashMismatchError {} -> + noHints + CantFindErr {} -> + noHints + BadIfaceFile {} -> + noHints + FailedToLoadDynamicInterface {} -> + noHints + +interfaceErrorReason :: IfaceMessage -> DiagnosticReason +interfaceErrorReason (Can'tFindInterface err _) + = missingInterfaceErrorReason err +interfaceErrorReason (Can'tFindNameInInterface {}) + = ErrorWithoutFlag +interfaceErrorReason (CircularImport {}) + = ErrorWithoutFlag + +missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason +missingInterfaceErrorReason = \ case + BadSourceImport {} -> + ErrorWithoutFlag + HomeModError {} -> + ErrorWithoutFlag + DynamicHashMismatchError {} -> + ErrorWithoutFlag + CantFindErr {} -> + ErrorWithoutFlag + BadIfaceFile {} -> + ErrorWithoutFlag + FailedToLoadDynamicInterface {} -> + ErrorWithoutFlag + + +prettyCantFindWhat :: FindOrLoad -> FindingModuleOrInterface -> AmbiguousOrMissing -> SDoc +prettyCantFindWhat Find FindingModule AoM_Missing = text "Could not find module" +prettyCantFindWhat Load FindingModule AoM_Missing = text "Could not load module" +prettyCantFindWhat _ FindingInterface AoM_Missing = text "Failed to load interface for" +prettyCantFindWhat _ FindingModule AoM_Ambiguous = text "Ambiguous module name" +prettyCantFindWhat _ FindingInterface AoM_Ambiguous = text "Ambiguous interface for" + +isAmbiguousInstalledReason :: CantFindInstalledReason -> AmbiguousOrMissing +isAmbiguousInstalledReason (MultiplePackages {}) = AoM_Ambiguous +isAmbiguousInstalledReason _ = AoM_Missing + +isLoadOrFindReason :: CantFindInstalledReason -> FindOrLoad +isLoadOrFindReason NotAModule {} = Find +isLoadOrFindReason (GenericMissing a b c _) | null a && null b && null c = Find +isLoadOrFindReason (ModuleSuggestion {}) = Find +isLoadOrFindReason _ = Load + +data FindOrLoad = Find | Load + +data AmbiguousOrMissing = AoM_Ambiguous | AoM_Missing + +cantFindError :: IfaceMessageOpts + -> FindingModuleOrInterface + -> CantFindInstalled + -> SDoc +cantFindError opts = + cantFindErrorX + (pkgHiddenHint (const empty) (ifaceBuildingCabalPackage opts)) + (mayShowLocations "-v" (ifaceShowTriedFiles opts)) + + +pkgHiddenHint :: (UnitInfo -> SDoc) -> BuildingCabalPackage + -> UnitInfo -> SDoc +pkgHiddenHint _hint YesBuildingCabalPackage pkg + = text "Perhaps you need to add" <+> + quotes (ppr (unitPackageName pkg)) <+> + text "to the build-depends in your .cabal file." +pkgHiddenHint hint _not_cabal pkg + = hint pkg + +mayShowLocations :: String -> Bool -> [FilePath] -> SDoc +mayShowLocations option verbose files + | null files = empty + | not verbose = + text "Use" <+> text option <+> + text "to see a list of the files searched for." + | otherwise = + hang (text "Locations searched:") 2 $ vcat (map text files) + +-- | General version of cantFindError which has some holes which allow GHC/GHCi to display slightly different +-- error messages. +cantFindErrorX :: (UnitInfo -> SDoc) -> ([FilePath] -> SDoc) -> FindingModuleOrInterface -> CantFindInstalled -> SDoc +cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInstalled mod_name cfir) = + let ambig = isAmbiguousInstalledReason cfir + find_or_load = isLoadOrFindReason cfir + ppr_what = prettyCantFindWhat find_or_load mod_or_interface ambig + in + (ppr_what <+> quotes (ppr mod_name) <> dot) $$ + case cfir of + NoUnitIdMatching pkg cands -> + + let looks_like_srcpkgid :: SDoc + looks_like_srcpkgid = + -- Unsafely coerce a unit id (i.e. an installed package component + -- identifier) into a PackageId and see if it means anything. + case cands of + (pkg:pkgs) -> + 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 empty + else text "and" <+> int (length pkgs) <+> text "other candidate" <> plural pkgs)) + -- Todo: also check if it looks like a package name! + [] -> empty + + in hsep [ text "no unit id matching" <+> quotes (ppr pkg) + , text "was found"] $$ looks_like_srcpkgid + MissingPackageFiles pkg files -> + text "There are files missing in the " <> quotes (ppr pkg) <+> + text "package," $$ + text "try running 'ghc-pkg check'." $$ + may_show_locations files + MissingPackageWayFiles build pkg files -> + text "Perhaps you haven't installed the " <> text build <+> + text "libraries for package " <> quotes (ppr pkg) <> char '?' $$ + may_show_locations files + ModuleSuggestion ms fps -> + + let pp_suggestions :: [ModuleSuggestion] -> SDoc + pp_suggestions sugs + | null sugs = 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 = empty + provenance (ModUnusable _) = 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 = empty + pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o + where provenance ModHidden = empty + provenance (ModUnusable _) = 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 = empty + + in pp_suggestions ms $$ may_show_locations fps + NotAModule -> text "It is not a module in the current program, or in any known package." + CouldntFindInFiles fps -> vcat (map text fps) + MultiplePackages mods + | Just pkgs <- unambiguousPackages + -> sep [text "it was found in multiple packages:", + hsep (map ppr pkgs)] + | otherwise + -> vcat (map pprMod mods) + where + unambiguousPackages = foldl' unambiguousPackage (Just []) mods + unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + = Just (moduleUnit m : xs) + unambiguousPackage _ _ = Nothing + GenericMissing pkg_hiddens mod_hiddens unusables files -> + vcat (map pkg_hidden pkg_hiddens) $$ + vcat (map mod_hidden mod_hiddens) $$ + vcat (map unusable unusables) $$ + may_show_locations files + where + 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 [] + ) + pkg_hidden :: (Unit, Maybe UnitInfo) -> SDoc + pkg_hidden (uid, uif) = + 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 $$ maybe empty pkg_hidden_hint uif + + + mod_hidden pkg = + text "it is a hidden module in the package" <+> quotes (ppr pkg) + + unusable (UnusableUnit unit reason reexport) + = text "It is " <> (if reexport then text "reexported from the package" + else text "a member of the package") + <+> quotes (ppr unit) + $$ pprReason (text "which is") reason + + +interfaceErrorDiagnostic :: IfaceMessageOpts -> IfaceMessage -> SDoc +interfaceErrorDiagnostic opts = \ case + Can'tFindNameInInterface name relevant_tyThings -> + missingDeclInInterface name relevant_tyThings + Can'tFindInterface err looking_for -> + hangNotEmpty (lookingForHerald looking_for) 2 (missingInterfaceErrorDiagnostic opts err) + CircularImport mod -> + text "Circular imports: module" <+> quotes (ppr mod) + <+> text "depends on itself" + +lookingForHerald :: InterfaceLookingFor -> SDoc +lookingForHerald looking_for = + case looking_for of + LookingForName {} -> empty + LookingForModule {} -> empty + LookingForHiBoot mod -> + text "Could not find hi-boot interface for" <+> quotes (ppr mod) <> colon + LookingForSig sig -> + text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon + +readInterfaceErrorDiagnostic :: ReadInterfaceError -> SDoc +readInterfaceErrorDiagnostic = \ case + ExceptionOccurred fp ex -> + hang (text "Exception when reading interface file " <+> text fp) + 2 (text (showException ex)) + HiModuleNameMismatchWarn _ m1 m2 -> + hiModuleNameMismatchWarn m1 m2 + +missingInterfaceErrorDiagnostic :: IfaceMessageOpts -> MissingInterfaceError -> SDoc +missingInterfaceErrorDiagnostic opts reason = + case reason of + BadSourceImport m -> badSourceImport m + HomeModError im ml -> homeModError im ml + DynamicHashMismatchError m ml -> dynamicHashMismatchError m ml + CantFindErr us module_or_interface cfi -> pprWithUnitState us $ cantFindError opts module_or_interface cfi + BadIfaceFile rie -> readInterfaceErrorDiagnostic rie + FailedToLoadDynamicInterface wanted_mod err -> + hang (text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) + 2 (readInterfaceErrorDiagnostic 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 = + -- Display fully qualified unit names. Otherwise we may not have enough + -- qualification and the printed names could look exactly the same. + pprRawUnitIds $ + withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ + -- we want the Modules below to be qualified with package names, + -- so reset the NamePprCtx setting. + hsep [ text "Something is amiss; requested module " + , ppr requested_mod + , text "differs from name found in the interface file" + , ppr read_mod + ] + +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) ] + +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 -> empty) + <+> text "which is not loaded" + + +missingDeclInInterface :: Name -> [TyThing] -> SDoc +missingDeclInInterface name things = + whenPprDebug (found_things $$ empty) $$ + hang (text "Can't find interface-file declaration for" <+> + pprNameSpace (nameNameSpace name) <+> ppr name) + 2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file", + text "Use -ddump-if-trace to get an idea of which file caused the error"]) + where + found_things = + hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon) + 2 (vcat (map ppr things)) + +badSourceImport :: Module -> SDoc +badSourceImport mod + = hang (text "You cannot {-# SOURCE #-} import a module from another package") + 2 (text "but" <+> quotes (ppr mod) <+> text "is from package" + <+> quotes (ppr (moduleUnit mod))) diff --git a/GHC/Iface/Errors/Types.hs b/GHC/Iface/Errors/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Errors/Types.hs @@ -0,0 +1,98 @@ + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +module GHC.Iface.Errors.Types ( + + MissingInterfaceError(..) + , InterfaceLookingFor(..) + , IfaceMessage(..) + , ReadInterfaceError(..) + , CantFindInstalled(..) + , CantFindInstalledReason(..) + , FindingModuleOrInterface(..) + + , BuildingCabalPackage(..) + + , IfaceMessageOpts(..) + + ) where + +import GHC.Prelude + +import GHC.Types.Name (Name) +import GHC.Types.TyThing (TyThing) +import GHC.Unit.Types (Module, InstalledModule, UnitId, Unit) +import GHC.Unit.State (UnitState, ModuleSuggestion, ModuleOrigin, UnusableUnit, UnitInfo) +import GHC.Exception.Type (SomeException) +import GHC.Unit.Types ( IsBootInterface ) +import Language.Haskell.Syntax.Module.Name ( ModuleName ) + + + +import GHC.Generics ( Generic ) +import GHC.Unit.Module.Location + +data IfaceMessageOpts = IfaceMessageOpts { ifaceShowTriedFiles :: !Bool -- ^ Whether to show files we tried to look for or not when printing loader errors + , ifaceBuildingCabalPackage :: !BuildingCabalPackage + } + +data InterfaceLookingFor + = LookingForName !Name + | LookingForHiBoot !Module + | LookingForModule !ModuleName !IsBootInterface + | LookingForSig !InstalledModule + +data IfaceMessage + = Can'tFindInterface + MissingInterfaceError + InterfaceLookingFor + | Can'tFindNameInInterface + Name + [TyThing] -- possibly relevant TyThings + | CircularImport !Module + deriving Generic + +data MissingInterfaceError + = BadSourceImport !Module + | HomeModError !InstalledModule !ModLocation + | DynamicHashMismatchError !Module !ModLocation + + | CantFindErr !UnitState FindingModuleOrInterface CantFindInstalled + + | BadIfaceFile ReadInterfaceError + | FailedToLoadDynamicInterface Module ReadInterfaceError + deriving Generic + +data ReadInterfaceError + = ExceptionOccurred FilePath SomeException + | HiModuleNameMismatchWarn FilePath Module Module + deriving Generic + +data CantFindInstalledReason + = NoUnitIdMatching UnitId [UnitInfo] + | MissingPackageFiles UnitId [FilePath] + | MissingPackageWayFiles String UnitId [FilePath] + | ModuleSuggestion [ModuleSuggestion] [FilePath] + | NotAModule + | CouldntFindInFiles [FilePath] + | GenericMissing + [(Unit, Maybe UnitInfo)] [Unit] + [UnusableUnit] [FilePath] + | MultiplePackages [(Module, ModuleOrigin)] + deriving Generic + +data CantFindInstalled = + CantFindInstalled ModuleName CantFindInstalledReason + deriving Generic +data FindingModuleOrInterface = FindingModule + | FindingInterface + +-- | Pass to a 'DriverMessage' the information whether or not the +-- '-fbuilding-cabal-package' flag is set. +data BuildingCabalPackage + = YesBuildingCabalPackage + | NoBuildingCabalPackage + deriving Eq diff --git a/GHC/Iface/Ext/Ast.hs b/GHC/Iface/Ext/Ast.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Ext/Ast.hs @@ -0,0 +1,2326 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE RankNTypes #-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- For the HasLoc instances + +{- +Main functions for .hie file generation +-} + +module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where + +import GHC.Utils.Outputable(ppr) + +import GHC.Prelude hiding ( head, init, last, tail ) + +import GHC.Types.Avail ( Avails ) +import GHC.Data.Bag ( Bag, bagToList ) +import GHC.Types.Basic +import GHC.Data.BooleanFormula +import GHC.Core.Class ( className, classSCSelIds ) +import GHC.Core.ConLike ( conLikeName ) +import GHC.Core.DataCon ( dataConNonlinearType ) +import GHC.Types.FieldLabel +import GHC.Hs +import GHC.Hs.Syn.Type +import GHC.Utils.Monad ( concatMapM, MonadIO(liftIO) ) +import GHC.Utils.FV ( fvVarList, filterFV ) +import GHC.Types.Id ( isDataConId_maybe ) +import GHC.Types.Name ( Name, nameSrcSpan, nameUnique, wiredInNameTyThing_maybe, getName ) +import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) +import GHC.Types.Name.Reader ( RecFieldInfo(..), WithUserRdr(..) ) +import GHC.Types.SrcLoc +import GHC.Core.Type ( Type, ForAllTyFlag(..) ) +import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) +import GHC.Core.InstEnv +import GHC.Core.Predicate ( isEvId ) +import GHC.Tc.Types +import GHC.Tc.Types.Evidence +import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique ) +import GHC.Types.Var.Env +import GHC.Builtin.Uniques +import GHC.Iface.Make ( mkIfaceExports ) +import GHC.Utils.Panic +import GHC.Data.Maybe +import GHC.Data.FastString +import qualified GHC.Data.Strict as Strict +import GHC.Data.Pair + +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils + +import GHC.Unit.Module ( ml_hs_file ) +import GHC.Unit.Module.ModSummary + +import qualified Data.Array as A +import qualified Data.ByteString as BS +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Data ( Data, Typeable ) +import Data.Foldable ( toList ) +import Data.Functor.Identity ( Identity(..) ) +import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) +import qualified Data.List.NonEmpty as NE +import Data.Void ( Void, absurd ) +import Control.Monad ( forM_ ) +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class ( lift ) +import Control.Applicative ( (<|>) ) +import GHC.Types.TypeEnv ( TypeEnv ) +import Control.Arrow ( second ) +import Data.Traversable ( mapAccumR ) + +{- Note [Updating HieAst for changes in the GHC AST] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When updating the code in this file for changes in the GHC AST, you +need to pay attention to the following things: + +1) Symbols (Names/Vars/Modules) in the following categories: + + a) Symbols that appear in the source file that directly correspond to + something the user typed + b) Symbols that don't appear in the source, but should be in some sense + "visible" to a user, particularly via IDE tooling or the like. This + includes things like the names introduced by RecordWildcards (We record + all the names introduced by a (..) in HIE files), and will include implicit + parameters and evidence variables after one of my pending MRs lands. + +2) Subtrees that may contain such symbols, or correspond to a SrcSpan in + the file. This includes all `Located` things + +For 1), you need to call `toHie` for one of the following instances + +instance ToHie (Context (Located Name)) where ... +instance ToHie (Context (Located Var)) where ... +instance ToHie (IEContext (Located ModuleName)) where ... + +`Context` is a data type that looks like: + +data Context a = C ContextInfo a -- Used for names and bindings + +`ContextInfo` is defined in `GHC.Iface.Ext.Types`, and looks like + +data ContextInfo + = Use -- ^ regular variable + | MatchBind + | IEThing IEType -- ^ import/export + | TyDecl + -- | Value binding + | ValBind + BindType -- ^ whether or not the binding is in an instance + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of entire binding + ... + +It is used to annotate symbols in the .hie files with some extra information on +the context in which they occur and should be fairly self explanatory. You need +to select one that looks appropriate for the symbol usage. In very rare cases, +you might need to extend this sum type if none of the cases seem appropriate. + +So, given a `Located Name` that is just being "used", and not defined at a +particular location, you would do the following: + + toHie $ C Use located_name + +If you select one that corresponds to a binding site, you will need to +provide a `Scope` and a `Span` for your binding. Both of these are basically +`SrcSpans`. + +The `SrcSpan` in the `Scope` is supposed to span over the part of the source +where the symbol can be legally allowed to occur. For more details on how to +calculate this, see Note [Capturing Scopes and other non local information] +in GHC.Iface.Ext.Ast. + +The binding `Span` is supposed to be the span of the entire binding for +the name. + +For a function definition `foo`: + +foo x = x + y + where y = x^2 + +The binding `Span` is the span of the entire function definition from `foo x` +to `x^2`. For a class definition, this is the span of the entire class, and +so on. If this isn't well defined for your bit of syntax (like a variable +bound by a lambda), then you can just supply a `Nothing` + +There is a test that checks that all symbols in the resulting HIE file +occur inside their stated `Scope`. This can be turned on by passing the +-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the +.hie file. + +You may also want to provide a test in testsuite/test/hiefile that includes +a file containing your new construction, and tests that the calculated scope +is valid (by using -fvalidate-ide-info) + +For subtrees in the AST that may contain symbols, the procedure is fairly +straightforward. If you are extending the GHC AST, you will need to provide a +`ToHie` instance for any new types you may have introduced in the AST. + +Here is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)): + + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + ... + HsApp _ a b -> + [ toHie a + , toHie b + ] + +If your subtree is `Located` or has a `SrcSpan` available, the output list +should contain a HieAst `Node` corresponding to the subtree. You can use +either `makeNode` or `getTypeNode` for this purpose, depending on whether it +makes sense to assign a `Type` to the subtree. After this, you just need +to concatenate the result of calling `toHie` on all subexpressions and +appropriately annotated symbols contained in the subtree. + +The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed +to work for both the renamed and typechecked source. `getTypeNode` is from +the `HasType` class defined in this file, and it has different instances +for `GhcTc` and `GhcRn` that allow it to access the type of the expression +when given a typechecked AST: + +class Data a => HasType a where + getTypeNode :: a -> HieM [HieAST Type] +instance HasType (LHsExpr GhcTc) where + getTypeNode e@(L spn e') = ... -- Actually get the type for this expression +instance HasType (LHsExpr GhcRn) where + getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type + +If your subtree doesn't have a span available, you can omit the `makeNode` +call and just recurse directly in to the subexpressions. + +-} + +-- These synonyms match those defined in compiler/GHC.hs +type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] + , Maybe [(LIE GhcRn, Avails)] + , Maybe (LHsDoc GhcRn) + , Maybe (XRec GhcRn ModuleName) ) +type TypecheckedSource = LHsBinds GhcTc + + +{- Note [Name Remapping] + ~~~~~~~~~~~~~~~~~~~~~ +The Typechecker introduces new names for mono names in AbsBinds. +We don't care about the distinction between mono and poly bindings, +so we replace all occurrences of the mono name with the poly name. +-} +type VarMap a = DVarEnv (Var,a) +data HieState = HieState + { name_remapping :: NameEnv Id + , unlocated_ev_binds :: VarMap (S.Set ContextInfo) + -- These contain evidence bindings that we don't have a location for + -- These are placed at the top level Node in the HieAST after everything + -- else has been generated + -- This includes things like top level evidence bindings. + , type_env :: TypeEnv + -- tcg_type_env from TcGblEnv contains the type environment for the module + , entity_infos :: NameEntityInfo + -- ^ Information about entities in the module + } + +addUnlocatedEvBind :: Var -> ContextInfo -> HieM () +addUnlocatedEvBind var ci = do + let go (a,b) (_,c) = (a,S.union b c) + lift $ modify' $ \s -> + s { unlocated_ev_binds = + extendDVarEnv_C go (unlocated_ev_binds s) + var (var,S.singleton ci) + } + +getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type]) +getUnlocatedEvBinds file = do + binds <- lift $ gets unlocated_ev_binds + org <- ask + let elts = dVarEnvElts binds + + mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci) + + go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of + RealSrcSpan spn _ + | srcSpanFile spn == file -> + let node = Node (mkSourcedNodeInfo org ni) spn [] + ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] + in (xs,node:ys) + _ -> (mkNodeInfo e : xs,ys) + + (nis,asts) = foldr go ([],[]) elts + + pure $ (M.fromList nis, asts) + +lookupAndInsertEntityName :: Name -> HieM () +lookupAndInsertEntityName name = do + m <- lift $ gets type_env + let tyThing = lookupNameEnv m name <|> wiredInNameTyThing_maybe name + insertEntityInfo name $ maybe (nameEntityInfo name) tyThingEntityInfo tyThing + +-- | Insert entity information for an identifier +insertEntityInfo :: Name -> S.Set EntityInfo -> HieM () +insertEntityInfo ident info = do + lift $ modify' $ \s -> + s { entity_infos = M.insertWith S.union ident info (entity_infos s) } + +initState :: HieState +initState = HieState emptyNameEnv emptyDVarEnv mempty mempty + +class ModifyState a where -- See Note [Name Remapping] + addSubstitution :: a -> a -> HieState -> HieState + +instance ModifyState Name where + addSubstitution _ _ hs = hs + +instance ModifyState Id where + addSubstitution mono poly hs = + hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} + +modifyState :: [ABExport] -> HieState -> HieState +modifyState = foldr go id + where + go ABE{abe_poly=poly,abe_mono=mono} f + = addSubstitution mono poly . f + +type HieM = ReaderT NodeOrigin (State HieState) + +-- | Construct an 'HieFile' from the outputs of the typechecker. +mkHieFile :: MonadIO m + => ModSummary + -> TcGblEnv + -> RenamedSource -> m HieFile +mkHieFile ms ts rs = do + let src_file = expectJust (ml_hs_file $ ms_location ms) + src <- liftIO $ BS.readFile src_file + pure $ mkHieFileWithSource src_file src ms ts rs + +-- | Construct an 'HieFile' from the outputs of the typechecker but don't +-- read the source file again from disk. +mkHieFileWithSource :: FilePath + -> BS.ByteString + -> ModSummary + -> TcGblEnv + -> RenamedSource -> HieFile +mkHieFileWithSource src_file src ms ts rs = + let tc_binds = tcg_binds ts + top_ev_binds = tcg_ev_binds ts + insts = tcg_insts ts + tte = tcg_type_env ts + tcs = tcg_tcs ts + (asts',arr,entityInfos) = getCompressedAsts tc_binds rs top_ev_binds insts tcs tte in + HieFile + { hie_hs_file = src_file + , hie_module = ms_mod ms + , hie_types = arr + , hie_asts = asts' + -- mkIfaceExports sorts the AvailInfos for stability + , hie_exports = mkIfaceExports (tcg_exports ts) + , hie_hs_src = src + , hie_entity_infos = entityInfos + } + +getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] -> TypeEnv + -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat, NameEntityInfo) +getCompressedAsts ts rs top_ev_binds insts tcs tte = + let (asts, infos) = enrichHie ts rs top_ev_binds insts tcs tte + add c (a, b) = (a,b,c) + in add infos $ compressTypes asts + +enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] -> TypeEnv + -> (HieASTs Type, NameEntityInfo) +enrichHie ts (hsGrp, imports, exports, docs, modName) ev_bs insts tcs tte = + second entity_infos $ runIdentity $ flip runStateT initState{type_env=tte} $ flip runReaderT SourceInfo $ do + modName <- toHie (IEC Export <$> modName) + tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts + rasts <- processGrp hsGrp + imps <- toHie $ filter (not . ideclImplicit . ideclExt . unLoc) imports + exps <- toHie $ fmap (map $ IEC Export . fst) exports + docs <- toHie docs + -- Add Instance bindings + forM_ insts $ \i -> + addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing) + -- Add class parent bindings + forM_ tcs $ \tc -> + case tyConClass_maybe tc of + Nothing -> pure () + Just c -> forM_ (classSCSelIds c) $ \v -> + addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing) + let spanFile file children = case nonEmpty children of + Nothing -> realSrcLocSpan (mkRealSrcLoc file 1 1) + Just children -> mkRealSrcSpan + (realSrcSpanStart $ nodeSpan (NE.head children)) + (realSrcSpanEnd $ nodeSpan (NE.last children)) + + flat_asts = concat + [ modName + , tasts + , rasts + , imps + , exps + , docs + ] + + modulify (HiePath file) xs' = do + + top_ev_asts :: [HieAST Type] <- do + let + l :: SrcSpanAnnA + l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Strict.Nothing) + toHie $ EvBindContext ModuleScope Nothing + $ L l (EvBinds ev_bs) + + (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file + + let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts + span = spanFile file xs + + moduleInfo = SourcedNodeInfo + $ M.singleton SourceInfo + $ (simpleNodeInfo "Module" "Module") + {nodeIdentifiers = uloc_evs} + + moduleNode = Node moduleInfo span [] + + case mergeSortAsts $ moduleNode : xs of + [x] -> return x + xs -> panicDoc "enrichHie: mergeSortAsts retur:ed more than one result" (ppr $ map nodeSpan xs) + + asts' <- sequence + $ M.mapWithKey modulify + $ M.fromListWith (++) + $ map (\x -> (HiePath (srcSpanFile (nodeSpan x)),[x])) flat_asts + + let asts = HieASTs $ resolveTyVarScopes asts' + return asts + +processGrp :: HsGroup GhcRn -> HieM [HieAST Type] +processGrp grp = concatM + [ toHie $ fmap (RS ModuleScope ) hs_valds grp + , toHie $ hs_splcds grp + , toHie $ hs_tyclds grp + , toHie $ hs_derivds grp + , toHie $ hs_fixds grp + , toHie $ hs_defds grp + , toHie $ hs_fords grp + , toHie $ hs_warnds grp + , toHie $ hs_annds grp + , toHie $ hs_ruleds grp + , toHie $ hs_docs grp + ] + +getRealSpanA :: EpAnn ann -> Maybe Span +getRealSpanA la = getRealSpan (locA la) + +getRealSpan :: SrcSpan -> Maybe Span +getRealSpan (RealSrcSpan sp _) = Just sp +getRealSpan _ = Nothing + +grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns) + => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan +grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (NE.map getLocA xs) + +bindingsOnly :: [Context Name] -> HieM [HieAST a] +bindingsOnly [] = pure [] +bindingsOnly (C c n : xs) = do + org <- ask + rest <- bindingsOnly xs + lookupAndInsertEntityName n + pure $ case nameSrcSpan n of + RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest + where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) + info = mempty{identInfo = S.singleton c} + _ -> rest + +concatM :: Monad m => [m [a]] -> m [a] +concatM xs = concat <$> sequence xs + +{- Note [Capturing Scopes and other non local information] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +toHie is a local transformation, but scopes of bindings cannot be known locally, +hence we have to push the relevant info down into the binding nodes. +We use the following types (*Context and *Scoped) to wrap things and +carry the required info +(Maybe Span) always carries the span of the entire binding, including rhs +-} +data Context a = C ContextInfo a -- Used for names and bindings + +data RContext a = RC RecFieldContext a +data RFContext a = RFC RecFieldContext (Maybe Span) a +-- ^ context for record fields + +data IEContext a = IEC IEType a +-- ^ context for imports/exports + +data BindContext a = BC BindType Scope a +-- ^ context for imports/exports + +data PatSynFieldContext a = PSC (Maybe Span) a +-- ^ context for pattern synonym fields. + +data SigContext a = SC SigInfo a +-- ^ context for type signatures + +data SigInfo = SI SigType (Maybe Span) + +data SigType = BindSig | ClassSig | InstSig + +data EvBindContext a = EvBindContext Scope (Maybe Span) a + +data RScoped a = RS Scope a +-- ^ Scope spans over everything to the right of a, (mostly) not +-- including a itself +-- (Includes a in a few special cases like recursive do bindings) or +-- let/where bindings + +-- | Pattern scope +data PScoped a = PS (Maybe Span) + Scope -- ^ use site of the pattern + Scope -- ^ pattern to the right of a, not including a + a + deriving (Data) -- Pattern Scope + +{- Note [TyVar Scopes] + ~~~~~~~~~~~~~~~~~~~ +Due to -XScopedTypeVariables, type variables can be in scope quite far from +their original binding. We resolve the scope of these type variables +in a separate pass +-} +data TScoped a = TS TyVarScope a -- TyVarScope + +data TVScoped a = TVS TyVarScope Scope a -- TyVarScope +-- ^ First scope remains constant +-- Second scope is used to build up the scope of a tyvar over +-- things to its right, ala RScoped + +-- | Each element scopes over the elements to the right +listScopes :: Traversable f => Scope -> f (LocatedA a) -> f (RScoped (LocatedA a)) +listScopes = fmap snd . mapAccumR (\ (scope :: Scope) pat -> let scope' = combineScopes scope $ mkScope $ getLocA pat in (scope', RS scope pat)) + +-- | 'listScopes' specialised to 'PScoped' things +patScopes + :: Traversable f + => Maybe Span + -> Scope + -> Scope + -> f (LPat (GhcPass p)) + -> f (PScoped (LPat (GhcPass p))) +patScopes rsp useScope patScope = + fmap (\(RS sc a) -> PS rsp useScope sc a) . listScopes patScope + +-- | 'listScopes' specialised to 'TVScoped' things +tvScopes + :: TyVarScope + -> Scope + -> [LHsTyVarBndr flag (GhcPass a)] + -> [TVScoped (LHsTyVarBndr flag (GhcPass a))] +tvScopes tvScope rhsScope xs = + map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs + +{- Note [Scoping Rules for SigPat] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Explicitly quantified variables in pattern type signatures are not +brought into scope in the rhs, but implicitly quantified variables +are (HsWC and HsIB). +This is unlike other signatures, where explicitly quantified variables +are brought into the RHS Scope +For example +foo :: forall a. ...; +foo = ... -- a is in scope here + +bar (x :: forall a. a -> a) = ... -- a is not in scope here +-- ^ a is in scope here (pattern body) + +bax (x :: a) = ... -- a is in scope here + +This case in handled in the instance for HsPatSigType +-} + +instance HasLoc thing => HasLoc (PScoped thing) where + getHasLoc (PS _ _ _ a) = getHasLoc a + +instance HasLoc a => HasLoc (DataDefnCons a) where + getHasLoc = getHasLocList . toList + +instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where + getHasLoc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of + HsOuterImplicit{} -> + foldl1' combineSrcSpans (getHasLoc a :| getHasLocList b : getHasLoc c : []) + HsOuterExplicit{hso_bndrs = tvs} -> + foldl1' combineSrcSpans (getHasLoc a :| getHasLocList tvs : getHasLocList b : getHasLoc c : []) + +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg (GhcPass p) tm ty) where + getHasLoc (HsValArg _ tm) = getHasLoc tm + getHasLoc (HsTypeArg _ ty) = getHasLoc ty + getHasLoc (HsArgPar sp) = sp + +instance HasLoc (HsDataDefn GhcRn) where + getHasLoc def@(HsDataDefn{}) = getHasLoc $ dd_cons def + -- Only used for data family instances, so we only need rhs + -- Most probably the rest will be unhelpful anyway + +-- | The main worker class +-- See Note [Updating HieAst for changes in the GHC AST] for more information +-- on how to add/modify instances for this. +class ToHie a where + toHie :: a -> HieM [HieAST Type] + +-- | Used to collect type info +class HasType a where + getTypeNode :: a -> HieM [HieAST Type] + +instance ToHie Void where + toHie v = absurd v + +instance (ToHie a) => ToHie [a] where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (NonEmpty a) where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (DataDefnCons a) where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (Bag a) where + toHie = toHie . bagToList + +instance (ToHie a) => ToHie (Maybe a) where + toHie = maybe (pure []) toHie + +instance ToHie (IEContext (LocatedA ModuleName)) where + toHie (IEC c (L (EpAnn (EpaSpan (RealSrcSpan span _)) _ _) mname)) = do + org <- ask + pure [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []] + where details = mempty{identInfo = S.singleton (IEThing c)} + idents = M.singleton (Left mname) details + toHie _ = pure [] + +instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where + toHie (C c (L l a)) = toHie (C c (L (locA l) a)) + +instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where + toHie (C c (L l a)) = toHie (C c (L (locA l) a)) + +instance ToHie (Context (Located Var)) where + toHie c = case c of + C context (L (RealSrcSpan span _) name') + | varUnique name' == mkBuiltinUnique 1 -> pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise -> do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m (varName name') of + Just var -> var + Nothing-> name' + ty = case isDataConId_maybe name' of + Nothing -> varType name' + Just dc -> dataConNonlinearType dc + -- insert the entity info for the name into the entity_infos map + insertEntityInfo (varName name) $ idEntityInfo name + insertEntityInfo (varName name') $ idEntityInfo name' + pure + [Node + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right $ varName name) + (IdentifierDetails (Just ty) + (S.singleton context))) + span + []] + C (EvidenceVarBind i _ sp) (L _ name) -> do + addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) + pure [] + _ -> pure [] + +instance ToHie (Context (Located Name)) where + toHie c = case c of + C context (L (RealSrcSpan span _) name') + | nameUnique name' == mkBuiltinUnique 1 -> pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise -> do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m name' of + Just var -> varName var + Nothing -> name' + -- insert the entity info for the name into the entity_infos map + lookupAndInsertEntityName name + lookupAndInsertEntityName name' + pure + [Node + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right name) + (IdentifierDetails Nothing + (S.singleton context))) + span + []] + _ -> pure [] + +instance ToHie (Context (Located (WithUserRdr Name))) where + toHie (C c (L l (WithUserRdr _ n))) = toHie $ C c (L l n) + +hieEvIdsOfTerm :: EvTerm -> [EvId] +-- Returns only EvIds satisfying relevantEvId +hieEvIdsOfTerm tm = fvVarList (filterFV isEvId (evTermFVs tm)) + +instance ToHie (EvBindContext (LocatedA TcEvBinds)) where + toHie (EvBindContext sc sp (L span (EvBinds bs))) + = concatMapM go $ bagToList bs + where + go evbind = do + let evDeps = hieEvIdsOfTerm $ eb_rhs evbind + depNames = EvBindDeps $ map varName evDeps + concatM $ + [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) + (L span $ eb_lhs evbind)) + , toHie $ map (C EvidenceVarUse . L span) $ evDeps + ] + toHie _ = pure [] + +instance ToHie (LocatedA HsWrapper) where + toHie (L osp wrap) + = case wrap of + (WpLet bs) -> toHie $ EvBindContext (mkScope osp) (getRealSpanA osp) (L osp bs) + (WpCompose a b) -> concatM $ + [toHie (L osp a), toHie (L osp b)] + (WpFun a b _) -> concatM $ + [toHie (L osp a), toHie (L osp b)] + (WpEvLam a) -> + toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpanA osp)) + $ L osp a + (WpEvApp a) -> + concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a + _ -> pure [] + +instance HiePass p => HasType (LocatedA (HsBind (GhcPass p))) where + getTypeNode (L spn bind) = + case hiePass @p of + HieRn -> makeNode bind (locA spn) + HieTc -> case bind of + FunBind{fun_id = name} -> makeTypeNode bind (locA spn) (varType $ unLoc name) + _ -> makeNode bind (locA spn) + +instance HiePass p => HasType (LocatedA (Pat (GhcPass p))) where + getTypeNode (L spn pat) = + case hiePass @p of + HieRn -> makeNodeA pat spn + HieTc -> makeTypeNodeA pat spn (hsPatType pat) + +-- | This instance tries to construct 'HieAST' nodes which include the type of +-- the expression. It is not yet possible to do this efficiently for all +-- expression forms, so we skip filling in the type for those inputs. +-- +-- See Note [Computing the type of every node in the tree] +instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where + getTypeNode (L spn e) = + case hiePass @p of + HieRn -> fallback + HieTc -> case computeType e of + Just ty -> makeTypeNodeA e spn ty + Nothing -> fallback + where + fallback :: HieM [HieAST Type] + fallback = makeNodeA e spn + + -- Skip computing the type of some expressions for performance reasons. + -- + -- See impact on Haddock output (esp. missing type annotations or links) + -- before skipping more kinds of expressions. See impact on Haddock + -- performance before computing the types of more expressions. + -- + -- See Note [Computing the type of every node in the tree] + computeType :: HsExpr GhcTc -> Maybe Type + computeType e = case e of + HsApp{} -> Nothing + HsAppType{} -> Nothing + NegApp{} -> Nothing + HsPar _ e -> computeLType e + ExplicitTuple{} -> Nothing + HsIf _ _ t f -> computeLType t <|> computeLType f + HsLet _ _ body -> computeLType body + RecordCon con_expr _ _ -> computeType con_expr + ExprWithTySig _ e _ -> computeLType e + HsPragE _ _ e -> computeLType e + XExpr (ExpandedThingTc thing e) + | OrigExpr (HsGetField{}) <- thing -- for record-dot-syntax + -> Just (hsExprType e) + | otherwise -> computeType e + XExpr (HsTick _ e) -> computeLType e + XExpr (HsBinTick _ _ e) -> computeLType e + e -> Just (hsExprType e) + + computeLType :: LHsExpr GhcTc -> Maybe Type + computeLType (L _ e) = computeType e + +{- Note [Computing the type of every node in the tree] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC.Iface.Ext.Ast we decorate every node in the AST with its +type, computed by `hsExprType` applied to that node. So it's +important that `hsExprType` takes roughly constant time per node. +There are three cases to consider: + +1. For many nodes (e.g. HsVar, HsDo, HsCase) it is easy to get their + type -- e.g. it is stored in the node, or in sub-node thereof. + +2. For some nodes (e.g. HsPar, HsTick, HsIf) the type of the node is + the type of a child, so we can recurse, fast. We don't expect the + nesting to be very deep, so while this is theoretically non-linear, + we don't expect it to be a problem in practice. + +3. A very few nodes (e.g. HsApp) are more troublesome because we need to + take the type of a child, and then do some non-trivial processing. + To be conservative on computation, we decline to decorate these + nodes, using `fallback` instead. + +The function `computeType e` returns `Just t` if we can find the type +of `e` cheaply, and `Nothing` otherwise. The base `Nothing` cases +are the troublesome ones in (3) above. Hopefully we can ultimately +get rid of them all. + +See #16233 + +-} + +data HiePassEv p where + HieRn :: HiePassEv 'Renamed + HieTc :: HiePassEv 'Typechecked + +class ( HiePass (NoGhcTcPass p) + , NoGhcTcPass p ~ 'Renamed + , ModifyState (IdGhcP p) + , Data (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) + , Data (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) + , Data (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) + , Data (Stmt (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) + , Data (Stmt (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) + , Data (HsExpr (GhcPass p)) + , Data (HsCmd (GhcPass p)) + , Data (HsCmdTop (GhcPass p)) + , Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) + , Data (HsUntypedSplice (GhcPass p)) + , Data (HsTypedSplice (GhcPass p)) + , Data (HsLocalBinds (GhcPass p)) + , Data (FieldOcc (GhcPass p)) + , Data (HsTupArg (GhcPass p)) + , Data (IPBind (GhcPass p)) + , ToHie (Context (Located (IdGhcP p))) + , ToHie (Context (Located (IdOccGhcP p))) + , Anno (IdGhcP p) ~ SrcSpanAnnN + , Anno (IdOccGhcP p) ~ SrcSpanAnnN + , Typeable p + , IsPass p + ) + => HiePass p where + hiePass :: HiePassEv p + +instance HiePass 'Renamed where + hiePass = HieRn +instance HiePass 'Typechecked where + hiePass = HieTc + +instance ToHie (Context (Located NoExtField)) where + toHie _ = pure [] + +type AnnoBody p body + = ( Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpanAnnA + , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] + ~ SrcSpanAnnLW + , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ EpAnn NoEpAnns + , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA + + , Data (body (GhcPass p)) + , Data (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + , Data (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + , Data (Stmt (GhcPass p) (LocatedA (body (GhcPass p)))) + ) + +instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where + toHie (BC context scope b@(L span bind)) = + concatM $ getTypeNode b : case bind of + FunBind{fun_id = name, fun_matches = matches, fun_ext = ext} -> + [ toHie $ C (ValBind context scope $ getRealSpanA span) name + , toHie matches + , case hiePass @p of + HieTc | (wrap, _) <- ext -> toHie $ L span wrap + _ -> pure [] + ] + PatBind{pat_lhs = lhs, pat_rhs = rhs} -> + [ toHie $ PS (getRealSpan (locA span)) scope NoScope lhs + , toHie rhs + ] + VarBind{var_rhs = expr} -> + [ toHie expr + ] + XHsBindsLR ext -> case hiePass @p of + 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 (mkScope span) (getRealSpanA span) + . L span) ev_binds + , toHie $ + map (C (EvidenceVarBind EvSigBind + (mkScope span) + (getRealSpanA span)) + . L span) ev_vars + ] + PatSynBind _ psb -> + [ toHie $ L (locA span) psb -- PatSynBinds only occur at the top level + ] + +instance ( HiePass p + , AnnoBody p body + , ToHie (LocatedA (body (GhcPass p))) + ) => ToHie (MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))) where + toHie mg = case mg of + MG{ mg_alts = (L span alts) } -> + local (setOrigin origin) $ concatM + [ locOnly (locA span) + , toHie alts + ] + where origin = case hiePass @p of + HieRn -> mg_ext mg + HieTc -> mg_origin $ mg_ext mg + +setOrigin :: Origin -> NodeOrigin -> NodeOrigin +setOrigin FromSource _ = SourceInfo +setOrigin (Generated {}) _ = GeneratedInfo + +instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where + toHie (L sp psb) = concatM $ case psb of + PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> + [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var + , toHie $ toBind dets + , toHie $ PS Nothing lhsScope patScope pat + , toHie dir + ] + where + lhsScope = combineScopes varScope detScope + varScope = mkScope var + patScope = mkScope $ getLoc pat + detScope = case dets of + (PrefixCon args) -> foldr combineScopes NoScope $ map mkScope args + (InfixCon a b) -> combineScopes (mkScope a) (mkScope b) + (RecCon r) -> foldr go NoScope r + go (RecordPatSynField (a :: FieldOcc (GhcPass p)) b) c = combineScopes c + $ combineScopes (mkScope (foLabel a)) (mkScope b) + detSpan = case detScope of + LocalScope a -> Just a + _ -> Nothing + toBind (PrefixCon args) = PrefixCon $ map (C Use) args + toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) + toBind (RecCon r) = RecCon $ map (PSC detSpan) r + +instance ToHie a => ToHie (WithUserRdr a) where + toHie (WithUserRdr _ a) = toHie a + +instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where + toHie dir = case dir of + ExplicitBidirectional mg -> toHie mg + _ -> pure [] + +instance ( HiePass p + , Data (body (GhcPass p)) + , AnnoBody p body + , ToHie (LocatedA (body (GhcPass p))) + ) => ToHie (LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))) where + toHie (L span m ) = concatM $ makeNodeA m span : case m of + Match{m_ctxt=mctx, m_pats = L _ pats, m_grhss = grhss } -> + [ toHieHsMatchContext @p mctx + , let rhsScope = mkScope $ grhss_span grhss + in toHie $ patScopes Nothing rhsScope NoScope pats + , toHie grhss + ] + +toHieHsMatchContext :: forall p. HiePass p => HsMatchContext (LIdP (NoGhcTc (GhcPass p))) + -> HieM [HieAST Type] +toHieHsMatchContext ctxt + = case ctxt of + FunRhs{mc_fun=name} -> toHie $ C MatchBind (get_name name) + StmtCtxt a -> toHieHsStmtContext @p a + _ -> pure [] + where + -- See a paragraph about Haddock in #20415. + get_name :: LIdP (NoGhcTc (GhcPass p)) -> LocatedN Name + get_name name = case hiePass @p of + HieRn -> name + HieTc -> name + +toHieHsStmtContext :: forall p. HiePass p => HsStmtContext (LIdP (NoGhcTc (GhcPass p))) + -> HieM [HieAST Type] +toHieHsStmtContext ctxt + = case ctxt of + PatGuard a -> toHieHsMatchContext @p a + ParStmtCtxt a -> toHieHsStmtContext @p a + TransStmtCtxt a -> toHieHsStmtContext @p a + _ -> pure [] + +instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where + toHie (PS rsp scope pscope lpat@(L ospan opat)) = + concatM $ getTypeNode lpat : case opat of + OrPat _ pats -> + map (toHie . PS rsp scope pscope) (NE.toList pats) + WildPat _ -> + [] + VarPat _ lname -> + [ toHie $ C (PatternBind scope pscope rsp) lname + ] + LazyPat _ p -> + [ toHie $ PS rsp scope pscope p + ] + AsPat _ lname pat -> + [ toHie $ C (PatternBind scope + (combineScopes (mkScope pat) pscope) + rsp) + lname + , toHie $ PS rsp scope pscope pat + ] + ParPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + BangPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + ListPat _ pats -> + [ toHie $ patScopes rsp scope pscope pats + ] + TuplePat _ pats _ -> + [ toHie $ patScopes rsp scope pscope pats + ] + SumPat _ pat _ _ -> + [ toHie $ PS rsp scope pscope pat + ] + ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext} -> + case hiePass @p of + HieTc -> + [ toHie $ C Use $ fmap conLikeName con + , toHie $ contextify dets + , let ev_binds = cpt_binds ext + ev_vars = cpt_dicts ext + wrap = cpt_wrap ext + evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope + in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds + , toHie $ L ospan wrap + , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp) + . L ospan) ev_vars + ] + ] + HieRn -> + [ toHie $ C Use (fmap getName con) + , toHie $ contextify dets + ] + ViewPat _ expr pat -> + [ toHie expr + , toHie $ PS rsp scope pscope pat + ] + SplicePat _ sp -> + [ toHie $ L ospan sp + ] + LitPat _ _ -> + [] + NPat _ (L loc lit) _ eq -> + [ toHie $ L (l2l loc :: SrcSpanAnnA) lit + , toHieSyntax (L ospan eq) + ] + NPlusKPat _ n (L loc lit) _ ord _ -> + [ toHie $ C (PatternBind scope pscope rsp) n + , toHie $ L (l2l loc :: SrcSpanAnnA) lit + , toHieSyntax (L ospan ord) + ] + SigPat _ pat sig -> + [ toHie $ PS rsp scope pscope pat + , case hiePass @p of + HieTc -> + let cscope = mkScope pat in + toHie $ TS (ResolvedScopes [cscope, scope, pscope]) + sig + HieRn -> pure [] + ] + EmbTyPat _ tp -> + [ toHie $ TS (ResolvedScopes [scope, pscope]) tp + ] + InvisPat _ tp -> + [ toHie $ TS (ResolvedScopes [scope, pscope]) tp + ] + XPat e -> + case hiePass @p of + HieRn -> case e of + HsPatExpanded _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ] + HieTc -> case e of + CoPat wrap pat _ -> + [ toHie $ L ospan wrap + , toHie $ PS rsp scope pscope $ (L ospan pat) + ] + ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ] + where + contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a) + -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) + contextify (PrefixCon args) = + PrefixCon (patScopes rsp scope pscope args) + contextify (InfixCon a b) = InfixCon a' b' + where Pair a' b' = patScopes rsp scope pscope (Pair a b) + contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r + contextify_rec (HsRecFields x fds a) = HsRecFields x (map go scoped_fds) a + where + go :: RScoped (LocatedA (HsFieldBind id a1)) + -> LocatedA (HsFieldBind id (PScoped a1)) -- AZ + go (RS fscope (L spn (HsFieldBind x lbl pat pun))) = + L spn $ HsFieldBind x lbl (PS rsp scope fscope pat) pun + scoped_fds = listScopes pscope fds + +toHieSyntax :: forall p. HiePass p => LocatedA (SyntaxExpr (GhcPass p)) -> HieM [HieAST Type] +toHieSyntax s = local (const GeneratedInfo) $ case hiePass @p of + HieRn -> toHie s + HieTc -> toHie s + +instance ToHie (LocatedA SyntaxExprRn) where + toHie (L mspan (SyntaxExprRn expr)) = toHie (L mspan expr) + toHie (L _ NoSyntaxExprRn) = pure [] + +instance ToHie (LocatedA SyntaxExprTc) where + toHie (L mspan (SyntaxExprTc expr w1 w2)) = concatM + [ toHie (L mspan expr) + , concatMapM (toHie . L mspan) w1 + , toHie (L mspan w2) + ] + toHie (L _ NoSyntaxExprTc) = pure [] + +instance ToHie (TScoped (HsPatSigType GhcRn)) where + toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs) + , toHie body + ] + -- See Note [Scoping Rules for SigPat] + +instance ToHie (TScoped (HsTyPat GhcRn)) where + toHie (TS sc (HsTP (HsTPRn wcs imp_tvs exp_tvs) body@(L span _))) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs ++ imp_tvs ++ exp_tvs) + , toHie body + ] + +instance ( ToHie (LocatedA (body (GhcPass p))) + , HiePass p + , AnnoBody p body + ) => ToHie (GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))) where + toHie grhs = concatM $ case grhs of + GRHSs _ grhss binds -> + [ toHie grhss + , toHie $ RS (mkScope $ grhss_span grhs) binds + ] + +instance ( ToHie (LocatedA (body (GhcPass p))) + , HiePass p + , AnnoBody p body + ) => ToHie (LocatedAn NoEpAnns (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where + toHie (L span g) = concatM $ makeNodeA g span : case g of + GRHS _ guards body -> + [ toHie $ listScopes (mkScope body) guards + , toHie body + ] + +{- +Note [Source locations for implicit function calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While calls to e.g. 'fromString' with -XOverloadedStrings do not actually +appear in the source code, giving their HsWrapper the location of the +overloaded bit of syntax that triggered them is useful for assigning +their type class evidence uses to the right location in the HIE AST. +Without this, we only get type class instance information under the +expected top-level node if the type had to be inferred. (#23540) + +We currently handle the following constructors with this in mind, +all largely in the renamer as their locations are normally inherited by +the typechecker: + + * HsOverLit, where we assign the SrcSpan of the overloaded literal + to ol_from_fun. + * HsDo, where we give the SrcSpan of the entire do block to each + ApplicativeStmt. + * Expanded (via ExpandedThingRn) ExplicitList{}, where we give the SrcSpan of the original + list expression to the 'fromListN' call. + +In order for the implicit function calls to not be confused for actual +occurrences of functions in the source code, most of this extra information +is put under 'GeneratedInfo'. +-} + +whenPostTc :: forall p t m. (HiePass p, Applicative t, Monoid m) => ((p ~ 'Typechecked) => t m) -> t m +whenPostTc a = case hiePass @p of + HieTc -> a + HieRn -> pure mempty + +-- | Helper function for a common pattern where we are only interested in +-- implicit evidence information: runs only post-typecheck and marks the +-- current 'NodeOrigin' as generated. +whenPostTcGen :: forall p. HiePass p => ((p ~ 'Typechecked) => HieM [HieAST Type]) -> HieM [HieAST Type] +whenPostTcGen a = local (const GeneratedInfo) $ whenPostTc @p a + +instance HiePass p => ToHie (LocatedA (HsOverLit (GhcPass p))) where + toHie (L span (OverLit x _)) = whenPostTcGen @p $ concatM $ case x of + OverLitTc _ witness _ -> + [ toHie (L span witness) + ] + -- See Note [Source locations for implicit function calls] + +instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsOverLabel {} -> [] + HsIPVar _ _ -> [] + HsOverLit _ o -> + [ toHie (L mspan o) + ] + HsLit _ _ -> [] + HsLam _ _ mg -> + [ toHie mg + ] + HsApp _ a b -> + [ toHie a + , toHie b + ] + HsAppType _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes []) sig + ] + OpApp _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + NegApp _ a _ -> + [ toHie a + ] + HsPar _ a -> + [ toHie a + ] + SectionL _ a b -> + [ toHie a + , toHie b + ] + SectionR _ a b -> + [ toHie a + , toHie b + ] + ExplicitTuple _ args _ -> + [ toHie args + ] + ExplicitSum _ _ _ expr -> + [ toHie expr + ] + HsCase _ expr matches -> + [ toHie expr + , toHie matches + ] + HsIf _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsMultiIf _ grhss -> + [ toHie grhss + ] + HsLet _ binds expr -> + [ toHie $ RS (mkScope expr) binds + , toHie expr + ] + HsDo _ _ (L ispan stmts) -> + [ locOnly (locA ispan) + , toHie $ listScopes NoScope stmts + ] + ExplicitList _ exprs -> + [ toHie exprs + ] + RecordCon { rcon_con = con, rcon_flds = binds} -> + [ toHie $ C Use $ con_name + , toHie $ RC RecFieldAssign $ binds + ] + where + con_name :: LocatedN Name + con_name = case hiePass @p of -- Like ConPat + HieRn -> fmap getName con + HieTc -> fmap conLikeName con + RecordUpd { rupd_expr = expr + , rupd_flds = RegularRecUpdFields { recUpdFields = upds } }-> + [ toHie expr + , case hiePass @p of + HieRn -> toHie $ map (RC RecFieldAssign) upds + HieTc -> toHie $ map (RC RecFieldAssign) upds + ] + RecordUpd { rupd_expr = expr + , rupd_flds = OverloadedRecUpdFields {} }-> + [ toHie expr + ] + ExprWithTySig _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes [mkScope expr]) sig + ] + ArithSeq enum _ info -> + [ toHie info + , whenPostTcGen @p $ toHie (L mspan enum) + ] + HsPragE _ _ expr -> + [ toHie expr + ] + HsProc _ pat cmdtop -> + [ toHie $ PS Nothing (mkScope cmdtop) NoScope pat + , toHie cmdtop + ] + HsStatic _ expr -> + [ toHie expr + ] + HsEmbTy _ ty -> + [ toHie $ TS (ResolvedScopes []) ty + ] + HsQual _ ctx body -> + [ toHie ctx + , toHie body + ] + HsForAll x tele body -> case hiePass @p of + HieRn -> + [ toHieForAllTele tele (getLocA body) + ] + HieTc -> dataConCantHappen x + HsFunArr x mult arg res -> case hiePass @p of + HieRn -> + [ toHie (multAnnToHsExpr mult) + , toHie arg + , toHie res + ] + HieTc -> dataConCantHappen x + HsTypedBracket xbracket b -> case hiePass @p of + HieRn -> + [ toHie b + ] + HieTc | HsBracketTc _ _ _ p <- xbracket -> + [ toHie b + , toHie p + ] + HsUntypedBracket xbracket b -> case hiePass @p of + HieRn -> + [ toHie b + , toHie xbracket + ] + HieTc | HsBracketTc q _ _ p <- xbracket -> + [ toHie q + , toHie p + ] + HsTypedSplice _ x -> + [ toHie $ L mspan x + ] + HsUntypedSplice _ x -> + [ toHie $ L mspan x + ] + HsGetField {} -> [] + HsProjection {} -> [] + HsHole _ -> [] -- there is a hole here, but that causes trouble + XExpr x -> case hiePass @p of + HieTc -> case x of + WrapExpr w a + -> [ toHie $ L mspan a + , toHie (L mspan w) ] + ExpandedThingTc _ e + -> [ toHie (L mspan e) ] + ConLikeTc con _ _ + -> [ toHie $ C Use $ L mspan $ conLikeName con ] + HsTick _ expr + -> [ toHie expr + ] + HsBinTick _ _ expr + -> [ toHie expr + ] + HsRecSelTc fld + -> [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) + ] + HieRn -> case x of + HsRecSelRn fld + -> [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) + ] + _ -> [] + +-- NOTE: no longer have the location +instance HiePass p => ToHie (HsTupArg (GhcPass p)) where + toHie arg = concatM $ case arg of + Present _ expr -> + [ toHie expr + ] + Missing _ -> [] + +instance ( ToHie (LocatedA (body (GhcPass p))) + , AnnoBody p body + , HiePass p + ) => ToHie (RScoped (LocatedA (Stmt (GhcPass p) (LocatedA (body (GhcPass p)))))) where + toHie (RS scope (L span stmt)) = concatM $ node : case stmt of + LastStmt _ body _ _ -> + [ toHie body + ] + BindStmt monad pat body -> + [ toHie $ PS (getRealSpan $ getLocA body) scope NoScope pat + , toHie body + , whenPostTcGen @p $ + toHieSyntax $ L span (xbstc_bindOp monad) + ] + BodyStmt _ body monad alternative -> + [ toHie body + , whenPostTc @p $ + concatMapM (toHieSyntax . L span) [monad, alternative] + ] + LetStmt _ binds -> + [ toHie $ RS scope binds + ] + ParStmt _ parstmts _ _ -> + [ concatMapM (\(ParStmtBlock _ stmts _ _) -> + toHie $ listScopes NoScope stmts) + parstmts + ] + TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> + [ toHie $ listScopes scope stmts + , toHie using + , toHie by + ] + RecStmt {recS_stmts = L _ stmts} -> + [ toHie $ map (RS $ combineScopes scope (mkScope (locA span))) stmts + ] + XStmtLR x -> case hiePass @p of + HieRn -> extApplicativeStmt x + HieTc -> extApplicativeStmt x + where + node = case hiePass @p of + HieTc -> makeNodeA stmt span + HieRn -> makeNodeA stmt span + extApplicativeStmt :: ApplicativeStmt (GhcPass p) (GhcPass p) -> [ReaderT NodeOrigin (State HieState) [HieAST Type]] + extApplicativeStmt (ApplicativeStmt _ stmts _) = + [ concatMapM (toHie . RS scope . snd) stmts + , let applicative_or_functor = map fst stmts + in whenPostTcGen @p $ + concatMapM (toHieSyntax . L span) applicative_or_functor + ] + +instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where + toHie (RS scope binds) = concatM $ makeNode binds (spanHsLocaLBinds binds) : case binds of + EmptyLocalBinds _ -> [] + HsIPBinds _ ipbinds -> case ipbinds of + IPBinds evbinds xs -> let sc = combineScopes scope $ scopeHsLocaLBinds binds + sp :: SrcSpanAnnA + sp = noAnnSrcSpan $ spanHsLocaLBinds binds in + [ + case hiePass @p of + HieTc -> toHie $ EvBindContext sc (getRealSpan $ locA sp) $ L sp evbinds + HieRn -> pure [] + , toHie $ map (RS sc) xs + ] + HsValBinds _ valBinds -> + [ + toHie $ RS (combineScopes scope (scopeHsLocaLBinds binds)) + valBinds + ] + +scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope +scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) + = foldr combineScopes NoScope (bsScope ++ sigsScope) + where + bsScope :: [Scope] + bsScope = map (mkScope . getLoc) bs + sigsScope :: [Scope] + sigsScope = map (mkScope . getLocA) sigs +scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs))) + = foldr combineScopes NoScope (bsScope ++ sigsScope) + where + bsScope :: [Scope] + bsScope = map (mkScope . getLoc) $ concatMap snd bs + sigsScope :: [Scope] + sigsScope = map (mkScope . getLocA) sigs + +scopeHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) + = foldr combineScopes NoScope (map (mkScope . getLoc) bs) +scopeHsLocaLBinds (EmptyLocalBinds _) = NoScope + +instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where + toHie (RS scope (L sp bind@(IPBind v _ expr))) = concatM $ makeNodeA bind sp : case hiePass @p of + HieRn -> [toHie expr] + HieTc -> [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp)) + $ L sp v + , toHie expr + ] + +instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where + toHie (RS sc v) = concatM $ case v of + ValBinds _ binds sigs -> + [ toHie $ fmap (BC RegularBind sc) binds + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + XValBindsLR x -> [ toHie $ RS sc x ] + +instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + +instance ( ToHie arg , HasLoc arg , Data arg + , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where + toHie (RC c (HsRecFields _ fields _)) = toHie $ map (RC c) fields + +instance ( ToHie (RFContext label) + , ToHie arg, HasLoc arg, Data arg + , Data label + ) => ToHie (RContext (LocatedA (HsFieldBind label arg))) where + toHie (RC c (L span recfld)) = concatM $ makeNode recfld (locA span) : case recfld of + HsFieldBind _ label expr _ -> + [ toHie $ RFC c (getRealSpan $ getHasLoc expr) label + , toHie expr + ] + +instance HiePass p => ToHie (RFContext (LocatedA (FieldOcc (GhcPass p)))) where + toHie (RFC c rhs (L nspan f)) = concatM $ + case hiePass @p of + HieRn -> + case f of + FieldOcc _ fld -> + [toHie $ C (RecField c rhs) (L (locA nspan) $ unLoc fld)] + HieTc -> + case f of + FieldOcc _ fld -> + [toHie $ C (RecField c rhs) (L (locA nspan) $ unLoc fld)] + + +instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where + toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM + [ toHie $ PS Nothing sc NoScope pat + , toHie expr + ] + toHie (RS sc (ApplicativeArgMany _ stmts _ pat _)) = concatM + [ toHie $ listScopes NoScope stmts + , toHie $ PS Nothing sc NoScope pat + ] + +instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where + toHie (PrefixCon args) = toHie args + toHie (RecCon rec) = toHie rec + toHie (InfixCon a b) = concatM [ toHie a, toHie b] + +instance ToHie (HsConDeclGADTDetails GhcRn) where + toHie (PrefixConGADT _ args) = toHie args + toHie (RecConGADT _ rec) = toHie rec + +instance HiePass p => ToHie (LocatedAn NoEpAnns (HsCmdTop (GhcPass p))) where + toHie (L span top) = concatM $ makeNodeA top span : case top of + HsCmdTop _ cmd -> + [ toHie cmd + ] + +instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where + toHie (L span cmd) = concatM $ makeNodeA cmd span : case cmd of + HsCmdArrApp _ a b _ _ -> + [ toHie a + , toHie b + ] + HsCmdArrForm _ a _ cmdtops -> + [ toHie a + , toHie cmdtops + ] + HsCmdApp _ a b -> + [ toHie a + , toHie b + ] + HsCmdPar _ a -> + [ toHie a + ] + HsCmdCase _ expr alts -> + [ toHie expr + , toHie alts + ] + HsCmdLam _ _ alts -> + [ toHie alts + ] + HsCmdIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsCmdLet _ binds cmd' -> + [ toHie $ RS (mkScope cmd') binds + , toHie cmd' + ] + HsCmdDo _ (L ispan stmts) -> + [ locOnly (locA ispan) + , toHie $ listScopes NoScope stmts + ] + XCmd _ -> [] + +instance ToHie (TyClGroup GhcRn) where + toHie TyClGroup{ group_tyclds = classes + , group_roles = roles + , group_kisigs = sigs + , group_instds = instances } = + concatM + [ toHie classes + , toHie sigs + , toHie roles + , toHie instances + ] + +instance ToHie (LocatedA (TyClDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of + FamDecl {tcdFam = fdecl} -> + [ toHie ((L span fdecl) :: LFamilyDecl GhcRn) + ] + SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> + [ toHie $ C (Decl SynDec $ getRealSpanA span) name + , toHie $ TS (ResolvedScopes [mkScope $ getLocA typ]) vars + , toHie typ + ] + DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> + [ toHie $ C (Decl DataDec $ getRealSpanA span) name + , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars + , toHie defn + ] + where + quant_scope = mkScope $ fromMaybe (noLocA []) $ dd_ctxt defn + rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc + sig_sc = maybe NoScope mkScope $ dd_kindSig defn + con_sc = foldr combineScopes NoScope $ mkScope <$> dd_cons defn + deriv_sc = foldr combineScopes NoScope $ mkScope <$> dd_derivs defn + ClassDecl { tcdCtxt = context + , tcdLName = name + , tcdTyVars = vars + , tcdFDs = deps + , tcdSigs = sigs + , tcdMeths = meths + , tcdATs = typs + , tcdATDefs = deftyps + } -> + [ toHie $ C (Decl ClassDec $ getRealSpanA span) name + , toHie context + , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars + , toHie deps + , toHie $ map (SC $ SI ClassSig $ getRealSpanA span) sigs + , toHie $ fmap (BC InstanceBind ModuleScope) meths + , toHie typs + , concatMapM (locOnly . getLocA) deftyps + , toHie deftyps + ] + where + context_scope = mkScope $ fromMaybe (noLocA []) context + rhs_scope = foldl1' combineScopes $ NE.map mkScope + ( getHasLocList deps :| getHasLocList sigs : getHasLocList meths : getHasLocList typs : getHasLocList deftyps : []) + +instance ToHie (LocatedA (FamilyDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of + FamilyDecl _ info _ name vars _ sig inj -> + [ toHie $ C (Decl FamDec $ getRealSpanA span) name + , toHie $ TS (ResolvedScopes [rhsSpan]) vars + , toHie info + , toHie $ RS injSpan sig + , toHie inj + ] + where + rhsSpan = sigSpan `combineScopes` injSpan + sigSpan = mkScope $ getLocA sig + injSpan = maybe NoScope (mkScope . getLocA) inj + +instance ToHie (FamilyInfo GhcRn) where + toHie (ClosedTypeFamily (Just eqns)) = concatM $ + [ concatMapM (locOnly . getLocA) eqns + , toHie $ map go eqns + ] + where + go (L l ib) = TS (ResolvedScopes [mkScope l]) ib + toHie _ = pure [] + +instance ToHie (RScoped (LocatedAn NoEpAnns (FamilyResultSig GhcRn))) where + toHie (RS sc (L span sig)) = concatM $ makeNodeA sig span : case sig of + NoSig _ -> + [] + KindSig _ k -> + [ toHie k + ] + TyVarSig _ bndr -> + [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr + ] + +instance ToHie (LocatedA (FunDep GhcRn)) where + toHie (L span fd@(FunDep _ lhs rhs)) = concatM $ + [ makeNode fd (locA span) + , toHie $ map (C Use) lhs + , toHie $ map (C Use) rhs + ] + + +instance ToHie (TScoped (FamEqn GhcRn (HsDataDefn GhcRn))) where + toHie (TS _ f) = toHie f + +instance ToHie (TScoped (FamEqn GhcRn (LocatedA (HsType GhcRn)))) where + toHie (TS _ f) = toHie f + +instance (ToHie rhs, HasLoc rhs) + => ToHie (FamEqn GhcRn rhs) where + toHie fe@(FamEqn _ var outer_bndrs pats _ rhs) = concatM $ + [ toHie $ C (Decl InstDec $ getRealSpan $ getHasLoc fe) var + , toHie $ TVS (ResolvedScopes []) scope outer_bndrs + , toHie pats + , toHie rhs + ] + where scope = combineScopes patsScope rhsScope + patsScope = mkScope (getHasLocList pats) + rhsScope = mkScope (getHasLoc rhs) + +instance ToHie (LocatedAn NoEpAnns (InjectivityAnn GhcRn)) where + toHie (L span ann) = concatM $ makeNodeA ann span : case ann of + InjectivityAnn _ lhs rhs -> + [ toHie $ C Use lhs + , toHie $ map (C Use) rhs + ] + +instance ToHie (HsDataDefn GhcRn) where + toHie (HsDataDefn _ ctx _ mkind cons derivs) = concatM + [ toHie ctx + , toHie mkind + , toHie cons + , toHie derivs + ] + +instance ToHie (Located [LocatedAn NoEpAnns (HsDerivingClause GhcRn)]) where + toHie (L span clauses) = concatM + [ locOnly span + , toHie clauses + ] + +instance ToHie (LocatedAn NoEpAnns (HsDerivingClause GhcRn)) where + toHie (L span cl) = concatM $ makeNodeA cl span : case cl of + HsDerivingClause _ strat dct -> + [ toHie (RS (mkScope dct) <$> strat) + , toHie dct + ] + +instance ToHie (LocatedC (DerivClauseTys GhcRn)) where + toHie (L span dct) = concatM $ makeNodeA dct span : case dct of + DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ] + DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ] + +instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where + toHie (RS sc (L span strat)) = concatM $ makeNodeA strat span : case strat of + StockStrategy _ -> [] + AnyclassStrategy _ -> [] + NewtypeStrategy _ -> [] + ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ] + +instance ToHie (LocatedP OverlapMode) where + toHie (L span _) = locOnly (locA span) + +instance ToHie (LocatedA (ConDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of + ConDeclGADT { con_names = names + , con_outer_bndrs = L outer_bndrs_loc outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = ctx + , con_g_args = args + , con_res_ty = typ + , con_doc = doc} -> + [ toHie $ C (Decl ConDec $ getRealSpanA span) <$> names + , bindingsOnly $ -- implicit forall + map (C $ TyVarBind (mkScope outer_bndrs_loc) (ResolvedScopes [sigmaScope])) + imp_vars + , toHie $ tvScopes (ResolvedScopes [phiScope]) NoScope exp_bndrs + , toHie ctx + , toHie args + , toHie typ + , toHie doc + ] + where + rhsScope = combineScopes argsScope tyScope + ctxScope = maybe NoScope mkScope ctx + argsScope = case args of + PrefixConGADT _ xs -> scaled_args_scope xs + RecConGADT _ x -> mkScope x + tyScope = mkScope typ + phiScope = combineScopes ctxScope rhsScope + sigmaScope = foldr combineScopes phiScope (map (mkScope . getLoc) exp_bndrs) + imp_vars = case outer_bndrs of + HsOuterImplicit{hso_ximplicit = imp_vars} -> imp_vars + HsOuterExplicit{} -> [] + exp_bndrs = + [ L l (updateHsTyVarBndrFlag Invisible b) | L l b <- hsOuterExplicitBndrs outer_bndrs ] + ++ concatMap hsForAllTelescopeBndrs inner_bndrs + ConDeclH98 { con_name = name, con_ex_tvs = qvars + , con_mb_cxt = ctx, con_args = dets + , con_doc = doc} -> + [ toHie $ C (Decl ConDec $ getRealSpan (locA span)) name + , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars + , toHie ctx + , toHie dets + , toHie doc + ] + where + rhsScope = combineScopes ctxScope argsScope + ctxScope = maybe NoScope mkScope ctx + argsScope = case dets of + PrefixCon xs -> scaled_args_scope xs + InfixCon a b -> scaled_args_scope [a, b] + RecCon x -> mkScope x + where scaled_args_scope :: [HsConDeclField GhcRn] -> Scope + scaled_args_scope = foldr combineScopes NoScope . map (mkScope . cdf_type) + +instance ToHie (LocatedL [LocatedA (HsConDeclRecField GhcRn)]) where + toHie (L span decls) = concatM $ + [ locOnly (locA span) + , toHie decls + ] + +instance ToHie (HsConDeclField GhcRn) where + toHie (CDF { cdf_multiplicity, cdf_type, cdf_doc }) = concatM + [ toHie (multAnnToHsType cdf_multiplicity) + , toHie cdf_type + , toHie cdf_doc + ] + +instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsSigType GhcRn)))) where + toHie (TS sc (HsWC names a)) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + , toHie $ TS sc a + ] + where span = getHasLoc a + +instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsType GhcRn)))) where + toHie (TS sc (HsWC names a)) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + , toHie a + ] + where span = getHasLoc a + +instance ToHie (LocatedA (StandaloneKindSig GhcRn)) where + toHie (L sp sig) = concatM [makeNodeA sig sp, toHie sig] + +instance ToHie (StandaloneKindSig GhcRn) where + toHie sig = concatM $ case sig of + StandaloneKindSig _ name typ -> + [ toHie $ C TyDecl name + , toHie $ TS (ResolvedScopes []) typ + ] + +instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where + toHie (SC (SI styp msp) (L sp sig)) = + case hiePass @p of + HieTc -> pure [] + HieRn -> concatM $ makeNodeA sig sp : case sig of + TypeSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + PatSynSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + ClassOpSig _ _ names typ -> + [ case styp of + ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpanA sp) names + _ -> toHie $ map (C $ TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ + ] + FixSig _ fsig -> + [ toHie $ L sp fsig + ] + InlineSig _ name _ -> + [ toHie $ (C Use) name + ] + SpecSig _ name typs _ -> + [ toHie $ (C Use) name + , toHie $ map (TS (ResolvedScopes [])) typs + ] + SpecSigE _ bndrs spec_e _ -> + [ toHieRuleBndrs (locA sp) (mkScope spec_e) bndrs + , toHie spec_e + ] + SpecInstSig _ typ -> + [ toHie $ TS (ResolvedScopes []) typ + ] + MinimalSig _ form -> + [ toHie form + ] + SCCFunSig _ name mtxt -> + [ toHie $ (C Use) name + , maybe (pure []) (locOnly . getLocA) mtxt + ] + CompleteMatchSig _ names typ -> + [ toHie $ map (C Use) names + , toHie $ fmap (C Use) typ + ] + XSig _ -> [] + +instance ToHie (TScoped (LocatedA (HsSigType GhcRn))) where + toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNodeA t span : + [ toHie (TVS tsc (mkScope span) bndrs) + , toHie body + ] + +-- Check this +instance Data flag => ToHie (TVScoped (HsOuterTyVarBndrs flag GhcRn)) where + toHie (TVS tsc sc bndrs) = case bndrs of + HsOuterImplicit xs -> bindingsOnly $ map (C $ TyVarBind sc tsc) xs + HsOuterExplicit _ xs -> toHie $ tvScopes tsc sc xs + +toHieForAllTele :: HsForAllTelescope GhcRn -> SrcSpan -> HieM [HieAST Type] +toHieForAllTele (HsForAllVis { hsf_vis_bndrs = bndrs }) loc = + toHie $ tvScopes (ResolvedScopes []) (mkScope loc) bndrs +toHieForAllTele (HsForAllInvis { hsf_invis_bndrs = bndrs }) loc = + toHie $ tvScopes (ResolvedScopes []) (mkScope loc) bndrs + +instance ToHie (LocatedA (HsType GhcRn)) where + toHie (L span t) = concatM $ makeNode t (locA span) : case t of + HsForAllTy _ tele body -> + [ toHieForAllTele tele (getLocA body) + , toHie body + ] + HsQualTy _ ctx body -> + [ toHie ctx + , toHie body + ] + HsTyVar _ _ var -> + [ toHie $ C Use var + ] + HsAppTy _ a b -> + [ toHie a + , toHie b + ] + HsAppKindTy _ ty ki -> + [ toHie ty + , toHie ki + ] + HsFunTy _ w a b -> + [ toHie (multAnnToHsType w) + , toHie a + , toHie b + ] + HsListTy _ a -> + [ toHie a + ] + HsTupleTy _ _ tys -> + [ toHie tys + ] + HsSumTy _ tys -> + [ toHie tys + ] + HsOpTy _ _prom a op b -> + [ toHie a + , toHie $ C Use op + , toHie b + ] + HsParTy _ a -> + [ toHie a + ] + HsIParamTy _ ip ty -> + [ toHie ip + , toHie ty + ] + HsKindSig _ a b -> + [ toHie a + , toHie b + ] + HsSpliceTy _ a -> + [ toHie $ L span a + ] + HsDocTy _ a doc -> + [ toHie a + , toHie doc + ] + HsExplicitListTy _ _ tys -> + [ toHie tys + ] + HsExplicitTupleTy _ _ tys -> + [ toHie tys + ] + HsTyLit _ _ -> [] + HsWildCardTy _ -> [] + HsStarTy _ _ -> [] + XHsType _ -> [] + +instance (ToHie tm, ToHie ty) => ToHie (HsArg (GhcPass p) tm ty) where + toHie (HsValArg _ tm) = toHie tm + toHie (HsTypeArg _ ty) = toHie ty + toHie (HsArgPar sp) = locOnly sp + +instance Data flag => ToHie (TVScoped (LocatedA (HsTyVarBndr flag GhcRn))) where + toHie (TVS tsc sc (L span bndr)) = + concatM $ makeNodeA bndr span : (name' ++ kind') + where + name' = case hsBndrVar bndr of + HsBndrWildCard _ -> [] + HsBndrVar _ tv -> [toHie $ C (TyVarBind sc tsc) tv] + kind' = case hsBndrKind bndr of + HsBndrNoKind _ -> [] + HsBndrKind _ k -> [toHie k] + +instance ToHie (TScoped (LHsQTyVars GhcRn)) where + toHie (TS sc (HsQTvs implicits vars)) = concatM $ + [ bindingsOnly bindings + , toHie $ tvScopes sc NoScope vars + ] + where + varLoc = getHasLocList vars + bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits + +instance ToHie (LocatedC [LocatedA (HsType GhcRn)]) where + toHie (L span tys) = concatM $ + [ locOnly (locA span) + , toHie tys + ] + +instance HiePass p => ToHie (LocatedC [LocatedA (HsExpr (GhcPass p))]) where + toHie (L span exprs) = concatM $ + [ locOnly (locA span) + , toHie exprs + ] + +instance ToHie (LocatedA (HsConDeclRecField GhcRn)) where + toHie (L span field) = concatM $ makeNode field (locA span) : case field of + HsConDeclRecField _ fields typ -> + [ toHie $ map (RFC RecFieldDecl (getRealSpan $ getHasLoc $ cdf_type typ)) fields + , toHie typ + ] + +instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where + toHie (From expr) = toHie expr + toHie (FromThen a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromTo a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromThenTo a b c) = concatM $ + [ toHie a + , toHie b + , toHie c + ] + +instance ToHie (LocatedA (SpliceDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of + SpliceDecl _ splice _ -> + [ toHie splice + ] + +instance ToHie (HsQuote GhcRn) where + toHie (ExpBr _ e) = toHie e + toHie (PatBr _ b) = toHie (PS Nothing NoScope NoScope b) + toHie (DecBrL {} ) = pure [] + toHie (DecBrG _ decls) = processGrp decls + toHie (TypBr _ ty) = toHie ty + toHie (VarBr {} ) = pure [] + +instance forall pass . HiePass pass => ToHie (HsUntypedSplice (GhcPass pass)) where + toHie (HsUntypedSpliceExpr _ext e) = toHie e + toHie (HsQuasiQuote _ext quoter _ispanFs) = toHie (C Use quoter) + toHie (XUntypedSplice ext) = + case ghcPass @pass of + GhcRn -> case ext of + HsImplicitLiftSplice _ _ _ lid -> toHie (C Use lid) + +instance ToHie PendingTcSplice where + toHie (PendingTcSplice _ e) = toHie e + +instance ToHie PendingRnSplice where + toHie (PendingRnSplice _ e) = toHie e + +instance (HiePass p, Data (IdGhcP p)) + => ToHie (GenLocated SrcSpanAnnL (BooleanFormula (GhcPass p))) where + toHie (L span form) = concatM $ makeNode form (locA span) : case form of + Var a -> + [ toHie $ C Use a + ] + And forms -> + [ toHie forms + ] + Or forms -> + [ toHie forms + ] + Parens f -> + [ toHie f + ] + +instance ToHie (LocatedAn NoEpAnns HsIPName) where + toHie (L span e) = makeNodeA e span + +instance (HiePass p) => ToHie (LocatedA (HsUntypedSplice (GhcPass p))) where + toHie (L span sp) = concatM $ makeNodeA sp span : case sp of + HsUntypedSpliceExpr _ expr -> + [ toHie expr + ] + HsQuasiQuote _ _ ispanFs -> + [ locOnly (getLocA ispanFs) + ] + XUntypedSplice x -> + case ghcPass @p of + GhcRn -> case x of + HsImplicitLiftSplice _ _ _ lid -> + [ toHie $ C Use lid + ] + +instance HiePass p => ToHie (LocatedA (HsTypedSplice (GhcPass p))) where + toHie (L span sp) = concatM $ makeNodeA sp span : case sp of + HsTypedSpliceExpr _ expr -> + [ toHie expr + ] + XTypedSplice x -> + case ghcPass @p of + GhcRn -> case x of + HsImplicitLiftSplice _ _ _ lid -> + [ toHie $ C Use lid + ] + + + + +instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where + toHie (L span annot) = concatM $ makeNodeA annot span : case annot of + RoleAnnotDecl _ var roles -> + [ toHie $ C Use var + , concatMapM (locOnly . getLocA) roles + ] + +instance ToHie (LocatedA (InstDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of + ClsInstD _ d -> + [ toHie $ L span d + ] + DataFamInstD _ d -> + [ toHie $ L span d + ] + TyFamInstD _ d -> + [ toHie $ L span d + ] + +instance ToHie (LocatedA (ClsInstDecl GhcRn)) where + toHie (L span decl) = concatM + [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl + , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl + , toHie $ map (SC $ SI InstSig $ getRealSpanA span) $ cid_sigs decl + , concatMapM (locOnly . getLocA) $ cid_tyfam_insts decl + , toHie $ cid_tyfam_insts decl + , concatMapM (locOnly . getLocA) $ cid_datafam_insts decl + , toHie $ cid_datafam_insts decl + , toHie $ cid_overlap_mode decl + ] + +instance ToHie (LocatedA (DataFamInstDecl GhcRn)) where + toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (LocatedA (TyFamInstDecl GhcRn)) where + toHie (L sp (TyFamInstDecl _ d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + + +instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where + toHie (C c (FieldOcc _ l)) = toHie (C c l) + +instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) where + toHie (PSC sp (RecordPatSynField a b)) = concatM $ + [ toHie $ C (RecField RecFieldDecl sp) a + , toHie $ C Use b + ] + +instance ToHie (LocatedA (DerivDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of + DerivDecl _ typ strat overlap -> + [ toHie $ TS (ResolvedScopes []) typ + , toHie $ (RS (mkScope span) <$> strat) + , toHie overlap + ] + +instance ToHie (LocatedA (FixitySig GhcRn)) where + toHie (L span sig) = concatM $ makeNodeA sig span : case sig of + FixitySig _ vars _ -> + [ toHie $ map (C Use) vars + ] + +instance ToHie (LocatedA (DefaultDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of + DefaultDecl _ cl typs -> + [ maybe (pure []) (toHie . C Use) cl + , toHie typs + ] + +instance ToHie (LocatedA (ForeignDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of + ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> + [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpanA span) name + , toHie $ TS (ResolvedScopes []) sig + , toHie fi + ] + ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> + [ toHie $ C Use name + , toHie $ TS (ResolvedScopes []) sig + , toHie fe + ] + +instance ToHie (ForeignImport GhcRn) where + toHie (CImport (L c _) (L a _) (L b _) _ _) = concatM $ + [ locOnlyE a + , locOnlyE b + , locOnlyE c + ] + +instance ToHie (ForeignExport GhcRn) where + toHie (CExport (L b _) (L a _)) = concatM $ + [ locOnlyE a + , locOnlyE b + ] + +instance ToHie (LocatedA (WarnDecls GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of + Warnings _ warnings -> + [ toHie warnings + ] + +instance ToHie (LocatedA (WarnDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of + Warning _ vars _ -> + [ toHie $ map (C Use) vars + ] + +instance ToHie (LocatedA (AnnDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of + HsAnnotation _ prov expr -> + [ toHie prov + , toHie expr + ] + +instance ToHie (AnnProvenance GhcRn) where + toHie (ValueAnnProvenance a) = toHie $ C Use a + toHie (TypeAnnProvenance a) = toHie $ C Use a + toHie ModuleAnnProvenance = pure [] + +instance ToHie (LocatedA (RuleDecls GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of + HsRules _ rules -> + [ toHie rules + ] + +instance ToHie (LocatedA (RuleDecl GhcRn)) where + toHie (L span r@(HsRule { rd_name = rname, rd_bndrs = bndrs + , rd_lhs = exprA, rd_rhs = exprB })) + = concatM + [ makeNodeA r span + , locOnly $ getLocA rname + , toHieRuleBndrs (locA span) scope bndrs + , toHie exprA + , toHie exprB + ] + where + scope = mkScope exprA `combineScopes` mkScope exprB + +toHieRuleBndrs :: SrcSpan -> Scope -> RuleBndrs GhcRn -> HieM [HieAST Type] +toHieRuleBndrs span body_sc (RuleBndrs { rb_tyvs = tybndrs, rb_tmvs = bndrs }) + = concatM [ toHie $ fmap (tvScopes (ResolvedScopes []) full_sc) tybndrs + , toHie $ map (RS $ mkScope (locA span)) bndrs ] + where + full_sc = bndrs_sc `combineScopes` body_sc + bndrs_sc = maybe NoScope mkScope (listToMaybe bndrs) + +instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where + toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of + RuleBndr _ var -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + ] + RuleBndrSig _ var typ -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + , toHie $ TS (ResolvedScopes [sc]) typ + ] + +instance ToHie (LocatedA (ImportDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of + ImportDecl { ideclName = name, ideclAs = as, ideclImportList = hidden } -> + [ toHie $ IEC Import name + , toHie $ fmap (IEC ImportAs) as + , maybe (pure []) goIE hidden + ] + where + goIE (hiding, (L sp liens)) = concatM $ + [ locOnly (locA sp) + , toHie $ map (IEC c) liens + ] + where + -- ROMES:TODO: I notice some overlap here with Iface types, eventually + -- we could join these + c = case hiding of + Exactly -> Import + EverythingBut -> ImportHiding + + +instance ToHie (IEContext (LocatedA (IE GhcRn))) where + toHie (IEC c (L span ie)) = concatM $ makeNode ie (locA span) : case ie of + IEVar _ n _ -> + [ toHie $ IEC c n + ] + IEThingAbs _ n _ -> + [ toHie $ IEC c n + ] + IEThingAll _ n _ -> + [ toHie $ IEC c n + ] + IEThingWith _ n _ ns _ -> + [ toHie $ IEC c n + , toHie $ map (IEC c) ns + ] + IEModuleContents _ n -> + [ toHie $ IEC c n + ] + IEGroup _ _ d -> [toHie d] + IEDoc _ d -> [toHie d] + IEDocNamed _ _ -> [] + +instance ToHie (IEContext (LocatedA (IEWrappedName GhcRn))) where + toHie (IEC c (L span iewn)) = concatM $ makeNodeA iewn span : case iewn of + IEDefault _ (L l p) -> + [ toHie $ C (IEThing c) (L l p) + ] + IEName _ (L l n) -> + [ toHie $ C (IEThing c) (L l n) + ] + IEPattern _ (L l p) -> + [ toHie $ C (IEThing c) (L l p) + ] + IEType _ (L l n) -> + [ toHie $ C (IEThing c) (L l n) + ] + IEData _ (L l n) -> + [ toHie $ C (IEThing c) (L l n) + ] + +instance ToHie (IEContext (Located RecFieldInfo)) where + toHie (IEC c (L span info)) = concatM + [ makeNode info span + , toHie $ C (IEThing c) $ L span (flSelector $ recFieldLabel info) + ] + +instance ToHie (LocatedA (DocDecl GhcRn)) where + toHie (L span d) = concatM $ makeNodeA d span : case d of + DocCommentNext d -> [ toHie d ] + DocCommentPrev d -> [ toHie d ] + DocCommentNamed _ d -> [ toHie d ] + DocGroup _ d -> [ toHie d ] + +instance ToHie (LHsDoc GhcRn) where + toHie (L span d@(WithHsDocIdentifiers _ ids)) = + concatM $ makeNode d span : [toHie $ map (C Use) ids] diff --git a/GHC/Iface/Ext/Binary.hs b/GHC/Iface/Ext/Binary.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Ext/Binary.hs @@ -0,0 +1,336 @@ +{- +Binary serialization for .hie files. +-} + +module GHC.Iface.Ext.Binary + ( readHieFile + , readHieFileWithVersion + , HieHeader + , writeHieFile + , HieName(..) + , toHieName + , HieFileResult(..) + , hieMagic + , hieNameOcc + ) +where + +import GHC.Prelude + +import GHC.Builtin.Utils +import GHC.Settings.Utils ( maybeRead ) +import GHC.Settings.Config ( cProjectVersion ) +import GHC.Utils.Binary +import GHC.Data.FastMutInt +import GHC.Data.FastString ( FastString ) +import GHC.Iface.Ext.Types +import GHC.Iface.Binary ( putAllTables ) +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.FM +import qualified GHC.Utils.Binary as Binary +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import qualified Data.Array as A +import qualified Data.Array.IO as A +import qualified Data.Array.Unsafe as A +import Data.IORef +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Word ( Word8, Word32 ) +import Control.Monad ( replicateM, when, forM_, foldM ) +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath ( takeDirectory ) + +data HieSymbolTable = HieSymbolTable + { hie_symtab_next :: !FastMutInt + , hie_symtab_map :: !(IORef (UniqFM Name (Int, HieName))) + } + +initBinMemSize :: Int +initBinMemSize = 1024*1024 + +-- | The header for HIE files - Capital ASCII letters \"HIE\". +hieMagic :: [Word8] +hieMagic = [72,73,69] + +hieMagicLen :: Int +hieMagicLen = length hieMagic + +ghcVersion :: ByteString +ghcVersion = BSC.pack cProjectVersion + +putBinLine :: WriteBinHandle -> ByteString -> IO () +putBinLine bh xs = do + mapM_ (putByte bh) $ BS.unpack xs + putByte bh 10 -- newline char + +-- | Write a `HieFile` to the given `FilePath`, with a proper header and +-- symbol tables for `Name`s and `FastString`s. +writeHieFile :: FilePath -> HieFile -> IO () +writeHieFile hie_file_path hiefile = do + bh0 <- openBinMem initBinMemSize + + -- Write the header: hieHeader followed by the + -- hieVersion and the GHC version used to generate this file + mapM_ (putByte bh0) hieMagic + putBinLine bh0 $ BSC.pack $ show hieVersion + putBinLine bh0 $ ghcVersion + + (fs_tbl, fs_w) <- initFastStringWriterTable + (name_tbl, name_w) <- initWriteNameTable + + let bh = setWriterUserData bh0 $ mkWriterUserData + [ mkSomeBinaryWriter @Name name_w + , mkSomeBinaryWriter @BindingName (simpleBindingNameWriter name_w) + , mkSomeBinaryWriter @FastString fs_w + ] + + -- Discard number of written elements + -- Order matters! See Note [Order of deduplication tables during iface binary serialisation] + _ <- putAllTables bh [fs_tbl, name_tbl] $ do + put_ bh hiefile + + -- and send the result to the file + createDirectoryIfMissing True (takeDirectory hie_file_path) + writeBinMem bh hie_file_path + return () + +initWriteNameTable :: IO (WriterTable, BinaryWriter Name) +initWriteNameTable = do + symtab_next <- newFastMutInt 0 + symtab_map <- newIORef emptyUFM + let bin_symtab = + HieSymbolTable + { hie_symtab_next = symtab_next + , hie_symtab_map = symtab_map + } + + let put_symtab bh = do + name_count <- readFastMutInt symtab_next + symtab_map <- readIORef symtab_map + putSymbolTable bh name_count symtab_map + pure name_count + + return + ( WriterTable + { putTable = put_symtab + } + , mkWriter $ putName bin_symtab + ) + +initReadNameTable :: NameCache -> IO (ReaderTable Name) +initReadNameTable cache = do + return $ + ReaderTable + { getTable = \bh -> getSymbolTable bh cache + , mkReaderFromTable = \tbl -> mkReader (getSymTabName tbl) + } + +data HieFileResult + = HieFileResult + { hie_file_result_version :: Integer + , hie_file_result_ghc_version :: ByteString + , hie_file_result :: HieFile + } + +type HieHeader = (Integer, ByteString) + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. Allows you to specify +-- which versions of hieFile to attempt to read. +-- `Left` case returns the failing header versions. +readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader HieFileResult) +readHieFileWithVersion readVersion name_cache file = do + bh0 <- readBinMem file + + (hieVersion, ghcVersion) <- readHieFileHeader file bh0 + + if readVersion (hieVersion, ghcVersion) + then do + hieFile <- readHieFileContents bh0 name_cache + return $ Right (HieFileResult hieVersion ghcVersion hieFile) + else return $ Left (hieVersion, ghcVersion) + + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. +readHieFile :: NameCache -> FilePath -> IO HieFileResult +readHieFile name_cache file = do + + bh0 <- readBinMem file + + (readHieVersion, ghcVersion) <- readHieFileHeader file bh0 + + -- Check if the versions match + when (readHieVersion /= hieVersion) $ + panic $ unwords ["readHieFile: hie file versions don't match for file:" + , file + , "Expected" + , show hieVersion + , "but got", show readHieVersion + ] + hieFile <- readHieFileContents bh0 name_cache + return $ HieFileResult hieVersion ghcVersion hieFile + +readBinLine :: ReadBinHandle -> IO ByteString +readBinLine bh = BS.pack . reverse <$> loop [] + where + loop acc = do + char <- get bh :: IO Word8 + if char == 10 -- ASCII newline '\n' + then return acc + else loop (char : acc) + +readHieFileHeader :: FilePath -> ReadBinHandle -> IO HieHeader +readHieFileHeader file bh0 = do + -- Read the header + magic <- replicateM hieMagicLen (get bh0) + version <- BSC.unpack <$> readBinLine bh0 + case maybeRead version of + Nothing -> + panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:" + , show version + ] + Just readHieVersion -> do + ghcVersion <- readBinLine bh0 + + -- Check if the header is valid + when (magic /= hieMagic) $ + panic $ unwords ["readHieFileHeader: headers don't match for file:" + , file + , "Expected" + , show hieMagic + , "but got", show magic + ] + return (readHieVersion, ghcVersion) + +readHieFileContents :: ReadBinHandle -> NameCache -> IO HieFile +readHieFileContents bh0 name_cache = do + fsReaderTable <- initFastStringReaderTable + nameReaderTable <- initReadNameTable name_cache + + -- read the symbol table so we are capable of reading the actual data + bh1 <- + foldM (\bh tblReader -> tblReader bh) bh0 + -- The order of these deserialisation matters! + -- + -- See Note [Order of deduplication tables during iface binary serialisation] for details. + [ get_dictionary fsReaderTable + , get_dictionary nameReaderTable + ] + + -- load the actual data + get bh1 + where + get_dictionary tbl bin_handle = do + fsTable <- Binary.forwardGetRel bin_handle (getTable tbl bin_handle) + let + fsReader = mkReaderFromTable tbl fsTable + bhFs = addReaderToUserData fsReader bin_handle + pure bhFs + + +putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,HieName) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab)) + mapM_ (putHieName bh) names + +getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name) +getSymbolTable bh name_cache = do + sz <- get bh + mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name) + forM_ [0..(sz-1)] $ \i -> do + od_name <- getHieName bh + name <- fromHieName name_cache od_name + A.writeArray mut_arr i name + A.unsafeFreeze mut_arr + +getSymTabName :: SymbolTable Name -> ReadBinHandle -> IO Name +getSymTabName st bh = do + i :: Word32 <- get bh + return $ st A.! (fromIntegral i) + +putName :: HieSymbolTable -> WriteBinHandle -> Name -> IO () +putName (HieSymbolTable next ref) bh name = do + symmap <- readIORef ref + case lookupUFM symmap name of + Just (off, ExternalName mod occ (UnhelpfulSpan _)) + | isGoodSrcSpan (nameSrcSpan name) -> do + let hieName = ExternalName mod occ (nameSrcSpan name) + writeIORef ref $! addToUFM symmap name (off, hieName) + put_ bh (fromIntegral off :: Word32) + Just (off, LocalName _occ span) + | notLocal (toHieName name) || nameSrcSpan name /= span -> do + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + Just (off, _) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt next + writeFastMutInt next (off+1) + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + + where + notLocal :: HieName -> Bool + notLocal LocalName{} = False + notLocal _ = True + + +-- ** Converting to and from `HieName`'s + +fromHieName :: NameCache -> HieName -> IO Name +fromHieName nc hie_name = do + + case hie_name of + ExternalName mod occ span -> updateNameCache nc mod occ $ \cache -> do + case lookupOrigNameCache cache mod occ of + Just name -> pure (cache, name) + Nothing -> do + uniq <- takeUniqFromNameCache nc + let name = mkExternalName uniq mod occ span + new_cache = extendOrigNameCache cache mod occ name + pure (new_cache, name) + + LocalName occ span -> do + uniq <- takeUniqFromNameCache nc + -- don't update the NameCache for local names + pure $ mkInternalName uniq occ span + + KnownKeyName u -> case lookupKnownKeyName u of + Nothing -> pprPanic "fromHieName:unknown known-key unique" + (ppr u) + Just n -> pure n + +-- ** Reading and writing `HieName`'s + +putHieName :: WriteBinHandle -> HieName -> IO () +putHieName bh (ExternalName mod occ span) = do + putByte bh 0 + put_ bh (mod, occ, BinSrcSpan span) +putHieName bh (LocalName occName span) = do + putByte bh 1 + put_ bh (occName, BinSrcSpan span) +putHieName bh (KnownKeyName uniq) = do + putByte bh 2 + put_ bh $ unpkUnique uniq + +getHieName :: ReadBinHandle -> IO HieName +getHieName bh = do + t <- getByte bh + case t of + 0 -> do + (modu, occ, span) <- get bh + return $ ExternalName modu occ $ unBinSrcSpan span + 1 -> do + (occ, span) <- get bh + return $ LocalName occ $ unBinSrcSpan span + 2 -> do + (c,i) <- get bh + return $ KnownKeyName $ mkUnique c i + _ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag" diff --git a/GHC/Iface/Ext/Debug.hs b/GHC/Iface/Ext/Debug.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Ext/Debug.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{- +Functions to validate and check .hie file ASTs generated by GHC. +-} + +module GHC.Iface.Ext.Debug where + +import GHC.Prelude + +import GHC.Types.SrcLoc +import GHC.Unit.Module +import GHC.Utils.Outputable + +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils +import GHC.Types.Name + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Function ( on ) +import Data.List ( sortOn ) + +type Diff a = a -> a -> [SDoc] + +diffFile :: Diff HieFile +diffFile = diffAsts eqDiff `on` (getAsts . hie_asts) + +diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map HiePath (HieAST a)) +diffAsts f = diffList (diffAst f) `on` M.elems + +diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a) +diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) = + infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2 + where + spanDiff + | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]] + | otherwise = [] + infoDiff' i1 i2 + = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) i1 i2 + ++ (diffList diffType `on` nodeType) i1 i2 + ++ (diffIdents `on` nodeIdentifiers) i1 i2 + sinfoDiff = diffList (\(k1,a) (k2,b) -> eqDiff k1 k2 ++ infoDiff' a b) `on` (M.toList . getSourcedNodeInfo) + infoDiff = case sinfoDiff info1 info2 of + [] -> [] + xs -> xs ++ [vcat ["In Node:",ppr (sourcedNodeIdents info1,span1) + , "and", ppr (sourcedNodeIdents info2,span2) + , "While comparing" + , ppr (normalizeIdents $ sourcedNodeIdents info1), "and" + , ppr (normalizeIdents $ sourcedNodeIdents info2) + ] + ] + + diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b + diffIdent (a,b) (c,d) = diffName a c + ++ eqDiff b d + diffName (Right a) (Right b) = case (a,b) of + (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o') + (LocalName o _, ExternalName _ o' _) -> eqDiff o o' + _ -> eqDiff a b + diffName a b = eqDiff a b + +type DiffIdent = Either ModuleName HieName + +normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)] +normalizeIdents = sortOn go . map (first toHieName) . M.toList + where + first f (a,b) = (fmap f a, b) + go (a,b) = (hieNameOcc <$> a,identInfo b,identType b) + +diffList :: Diff a -> Diff [a] +diffList f xs ys + | length xs == length ys = concat $ zipWith f xs ys + | otherwise = ["length of lists doesn't match"] + +eqDiff :: (Outputable a, Eq a) => Diff a +eqDiff a b + | a == b = [] + | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]] + +validAst :: HieAST a -> Either SDoc () +validAst (Node _ span children) = do + checkContainment children + checkSorted children + mapM_ validAst children + where + checkSorted [] = return () + checkSorted [_] = return () + checkSorted (x:y:xs) + | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs) + | otherwise = Left $ hsep + [ ppr $ nodeSpan x + , "is not to the left of" + , ppr $ nodeSpan y + ] + checkContainment [] = return () + checkContainment (x:xs) + | span `containsSpan` (nodeSpan x) = checkContainment xs + | otherwise = Left $ hsep + [ ppr $ span + , "does not contain" + , ppr $ nodeSpan x + ] + +-- | Look for any identifiers which occur outside of their supposed scopes. +-- Returns a list of error messages. +validateScopes :: Module -> M.Map HiePath (HieAST a) -> [SDoc] +validateScopes mod asts = validScopes ++ validEvs + where + refMap = generateReferencesMap asts + -- We use a refmap for most of the computation + + evs = M.keys + $ M.filter (any isEvidenceContext . concatMap (S.toList . identInfo . snd)) refMap + + validEvs = do + i@(Right ev) <- evs + case M.lookup i refMap of + Nothing -> ["Impossible, ev"<+> ppr ev <+> "not found in refmap" ] + Just refs + | nameIsLocalOrFrom mod ev + , not (any isEvidenceBind . concatMap (S.toList . identInfo . snd) $ refs) + -> ["Evidence var" <+> ppr ev <+> "not bound in refmap"] + | otherwise -> [] + + -- Check if all the names occur in their calculated scopes + validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap + valid (Left _) _ = [] + valid (Right n) refs = concatMap inScope refs + where + mapRef = foldMap getScopeFromContext . identInfo . snd + scopes = case foldMap mapRef refs of + Just xs -> xs + Nothing -> [] + inScope (sp, dets) + | (definedInAsts asts n || (any isEvidenceContext (identInfo dets))) + && any isOccurrence (identInfo dets) + -- We validate scopes for names which are defined locally, and occur + -- in this span, or are evidence variables + = case scopes of + [] | nameIsLocalOrFrom mod n + , ( not (isDerivedOccName $ nameOccName n) + || any isEvidenceContext (identInfo dets)) + -- If we don't get any scopes for a local name or + -- an evidence variable, then its an error. + -- We can ignore other kinds of derived names as + -- long as we take evidence vars into account + -> return $ hsep $ + [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp + , "Doesn't have a calculated scope: ", ppr scopes] + | otherwise -> [] + _ -> if any (`scopeContainsSpan` sp) scopes + then [] + else return $ hsep $ + [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp + , "doesn't occur in calculated scope", ppr scopes] + | otherwise = [] diff --git a/GHC/Iface/Ext/Fields.hs b/GHC/Iface/Ext/Fields.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Ext/Fields.hs @@ -0,0 +1,94 @@ +module GHC.Iface.Ext.Fields + ( ExtensibleFields (..) + , FieldName + , emptyExtensibleFields + -- * Reading + , readField + , readFieldWith + -- * Writing + , writeField + , writeFieldWith + -- * Deletion + , deleteField + ) +where + +import GHC.Prelude +import GHC.Utils.Binary + +import Control.Monad +import Data.Map ( Map ) +import qualified Data.Map as Map +import Control.DeepSeq + +type FieldName = String + +newtype ExtensibleFields = ExtensibleFields { getExtensibleFields :: (Map FieldName BinData) } + +instance Binary ExtensibleFields where + put_ bh (ExtensibleFields fs) = do + put_ bh (Map.size fs :: Int) + + -- Put the names of each field, and reserve a space + -- for a payload pointer after each name: + header_entries <- forM (Map.toList fs) $ \(name, dat) -> do + put_ bh name + field_p_p <- tellBinWriter bh + put_ bh field_p_p + return (field_p_p, dat) + + -- Now put the payloads and use the reserved space + -- to point to the start of each payload: + forM_ header_entries $ \(field_p_p, dat) -> do + field_p <- tellBinWriter bh + putAtRel bh field_p_p field_p + seekBinWriter bh field_p + put_ bh dat + + get bh = do + n <- get bh :: IO Int + + -- Get the names and field pointers: + header_entries <- replicateM n $ + (,) <$> get bh <*> getRelBin bh + + -- Seek to and get each field's payload: + fields <- forM header_entries $ \(name, field_p) -> do + seekBinReaderRel bh field_p + dat <- get bh + return (name, dat) + + return . ExtensibleFields . Map.fromList $ fields + +instance NFData ExtensibleFields where + rnf (ExtensibleFields fs) = rnf fs + +emptyExtensibleFields :: ExtensibleFields +emptyExtensibleFields = ExtensibleFields Map.empty + +-------------------------------------------------------------------------------- +-- | Reading + +readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a) +readField name = readFieldWith name get + +readFieldWith :: FieldName -> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a) +readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$> + Map.lookup name (getExtensibleFields fields) + +-------------------------------------------------------------------------------- +-- | Writing + +writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields +writeField name x = writeFieldWith name (`put_` x) + +writeFieldWith :: FieldName -> (WriteBinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields +writeFieldWith name write fields = do + bh <- openBinMem (1024 * 1024) + write bh + -- + bd <- handleData bh + return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields) + +deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields +deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs diff --git a/GHC/Iface/Ext/Types.hs b/GHC/Iface/Ext/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Ext/Types.hs @@ -0,0 +1,885 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- +Types for the .hie file format are defined here. + +For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files +-} + +module GHC.Iface.Ext.Types where + +import GHC.Prelude + +import GHC.Settings.Config +import GHC.Utils.Binary +import GHC.Data.FastString +import GHC.Builtin.Utils +import GHC.Iface.Type +import GHC.Unit.Module ( ModuleName, Module ) +import GHC.Types.Name +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Types.SrcLoc +import GHC.Types.Avail +import GHC.Types.Unique +import qualified GHC.Utils.Outputable as O ( (<>) ) +import GHC.Utils.Panic +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Core.TyCo.Rep ( Type(..) ) +import GHC.Core.Type ( coreFullView, isFunTy, Var (..) ) +import GHC.Core.TyCon ( isTypeSynonymTyCon, isClassTyCon, isFamilyTyCon ) +import GHC.Types.Id ( Id, isRecordSelector, isClassOpId ) +import GHC.Types.TyThing ( TyThing (..) ) +import GHC.Types.Var ( isTyVar, isFUNArg ) + +import qualified Data.Array as A +import qualified Data.Map as M +import qualified Data.Set as S +import Data.ByteString ( ByteString ) +import Data.Data ( Data ) +import Data.Semigroup ( Semigroup(..) ) +import Data.Word ( Word8 ) +import Control.Applicative ( (<|>) ) +import Data.Coerce ( coerce ) +import Data.Function ( on ) +import qualified Data.Semigroup as S + +type Span = RealSrcSpan + +-- | Current version of @.hie@ files +hieVersion :: Integer +hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer + +{- | +GHC builds up a wealth of information about Haskell source as it compiles it. +@.hie@ files are a way of persisting some of this information to disk so that +external tools that need to work with haskell source don't need to parse, +typecheck, and rename all over again. These files contain: + + * a simplified AST + + * nodes are annotated with source positions and types + * identifiers are annotated with scope information + + * the raw bytes of the initial Haskell source + +Besides saving compilation cycles, @.hie@ files also offer a more stable +interface than the GHC API. +-} +data HieFile = HieFile + { hie_hs_file :: FilePath + -- ^ Initial Haskell source file path + + , hie_module :: Module + -- ^ The module this HIE file is for + + , hie_types :: A.Array TypeIndex HieTypeFlat + -- ^ Types referenced in the 'hie_asts'. + -- + -- See Note [Efficient serialization of redundant type info] + + , hie_asts :: HieASTs TypeIndex + -- ^ Type-annotated abstract syntax trees + + , hie_exports :: [AvailInfo] + -- ^ The names that this module exports + + , hie_hs_src :: ByteString + -- ^ Raw bytes of the initial Haskell source + + , hie_entity_infos :: NameEntityInfo + -- ^ Entity information for each `Name` in the `hie_asts` + } + +type NameEntityInfo = M.Map Name (S.Set EntityInfo) + +instance Binary NameEntityInfo where + put_ bh m = put_ bh $ M.toList m + get bh = fmap M.fromList (get bh) + +instance Binary HieFile where + put_ bh hf = do + put_ bh $ hie_hs_file hf + put_ bh $ hie_module hf + put_ bh $ hie_types hf + put_ bh $ hie_asts hf + put_ bh $ hie_exports hf + put_ bh $ hie_hs_src hf + put_ bh $ hie_entity_infos hf + + get bh = HieFile + <$> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + + +{- +Note [Efficient serialization of redundant type info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The type information in .hie files is highly repetitive and redundant. For +example, consider the expression + + const True 'a' + +There is a lot of shared structure between the types of subterms: + + * const True 'a' :: Bool + * const True :: Char -> Bool + * const :: Bool -> Char -> Bool + +Since all 3 of these types need to be stored in the .hie file, it is worth +making an effort to deduplicate this shared structure. The trick is to define +a new data type that is a flattened version of 'Type': + + data HieType a = HAppTy a a -- data Type = AppTy Type Type + | HFunTy a a -- | FunTy Type Type + | ... + + type TypeIndex = Int + +Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)', +where the 'TypeIndex's in the 'HieType' are references to other elements of the +array. Types recovered from GHC are deduplicated and stored in this compressed +form with sharing of subtrees. +-} + +type TypeIndex = Int + +-- | A flattened version of 'Type'. +-- +-- See Note [Efficient serialization of redundant type info] +data HieType a + = HTyVarTy Name + | HAppTy a (HieArgs a) + | HTyConApp IfaceTyCon (HieArgs a) + | HForAllTy ((Name, a),ForAllTyFlag) a + | HFunTy a a a + | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy') + | HLitTy IfaceTyLit + | HCastTy a + | HCoercionTy + deriving (Functor, Foldable, Traversable, Eq) + +type HieTypeFlat = HieType TypeIndex + +-- | Roughly isomorphic to the original core 'Type'. +newtype HieTypeFix = Roll (HieType (HieTypeFix)) + deriving Eq + +instance Binary (HieType TypeIndex) where + put_ bh (HTyVarTy n) = do + putByte bh 0 + put_ bh n + put_ bh (HAppTy a b) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh (HTyConApp n xs) = do + putByte bh 2 + put_ bh n + put_ bh xs + put_ bh (HForAllTy bndr a) = do + putByte bh 3 + put_ bh bndr + put_ bh a + put_ bh (HFunTy w a b) = do + putByte bh 4 + put_ bh w + put_ bh a + put_ bh b + put_ bh (HQualTy a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (HLitTy l) = do + putByte bh 6 + put_ bh l + put_ bh (HCastTy a) = do + putByte bh 7 + put_ bh a + put_ bh (HCoercionTy) = putByte bh 8 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> HTyVarTy <$> get bh + 1 -> HAppTy <$> get bh <*> get bh + 2 -> HTyConApp <$> get bh <*> get bh + 3 -> HForAllTy <$> get bh <*> get bh + 4 -> HFunTy <$> get bh <*> get bh <*> get bh + 5 -> HQualTy <$> get bh <*> get bh + 6 -> HLitTy <$> get bh + 7 -> HCastTy <$> get bh + 8 -> return HCoercionTy + _ -> panic "Binary (HieArgs Int): invalid tag" + + +-- | A list of type arguments along with their respective visibilities (ie. is +-- this an argument that would return 'True' for 'isVisibleForAllTyFlag'?). +newtype HieArgs a = HieArgs [(Bool,a)] + deriving (Functor, Foldable, Traversable, Eq) + +instance Binary (HieArgs TypeIndex) where + put_ bh (HieArgs xs) = put_ bh xs + get bh = HieArgs <$> get bh + + +-- A HiePath is just a lexical FastString. We use a lexical FastString to avoid +-- non-determinism when printing or storing HieASTs which are sorted by their +-- HiePath. +type HiePath = LexicalFastString + +{-# COMPLETE HiePath #-} +pattern HiePath :: FastString -> HiePath +pattern HiePath fs = LexicalFastString fs + +-- | Mapping from filepaths to the corresponding AST +newtype HieASTs a = HieASTs { getAsts :: M.Map HiePath (HieAST a) } + deriving (Functor, Foldable, Traversable) + +instance Binary (HieASTs TypeIndex) where + put_ bh asts = put_ bh $ M.toAscList $ getAsts asts + get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh) + +instance Outputable a => Outputable (HieASTs a) where + ppr (HieASTs asts) = M.foldrWithKey go "" asts + where + go k a rest = vcat $ + [ "File: " O.<> ppr k + , ppr a + , rest + ] + +data HieAST a = + Node + { sourcedNodeInfo :: SourcedNodeInfo a + , nodeSpan :: Span + , nodeChildren :: [HieAST a] + } deriving (Functor, Foldable, Traversable) + +instance Binary (HieAST TypeIndex) where + put_ bh ast = do + put_ bh $ sourcedNodeInfo ast + put_ bh $ BinSpan $ nodeSpan ast + put_ bh $ nodeChildren ast + + get bh = Node + <$> get bh + <*> (unBinSpan <$> get bh) + <*> get bh + +instance Outputable a => Outputable (HieAST a) where + ppr (Node ni sp ch) = hang header 2 rest + where + header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni + rest = vcat (map ppr ch) + + +-- | NodeInfos grouped by source +newtype SourcedNodeInfo a = SourcedNodeInfo { getSourcedNodeInfo :: (M.Map NodeOrigin (NodeInfo a)) } + deriving (Functor, Foldable, Traversable) + +instance Binary (SourcedNodeInfo TypeIndex) where + put_ bh asts = put_ bh $ M.toAscList $ getSourcedNodeInfo asts + get bh = SourcedNodeInfo <$> fmap M.fromDistinctAscList (get bh) + +instance Outputable a => Outputable (SourcedNodeInfo a) where + ppr (SourcedNodeInfo asts) = M.foldrWithKey go "" asts + where + go k a rest = vcat $ + [ "Source: " O.<> ppr k + , ppr a + , rest + ] + +-- | Source of node info +data NodeOrigin + = SourceInfo + | GeneratedInfo + deriving (Eq, Enum, Ord) + +instance Outputable NodeOrigin where + ppr SourceInfo = text "From source" + ppr GeneratedInfo = text "generated by ghc" + +instance Binary NodeOrigin where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + +-- | A node annotation +data NodeAnnotation = NodeAnnotation + { nodeAnnotConstr :: !FastString -- ^ name of the AST node constructor + , nodeAnnotType :: !FastString -- ^ name of the AST node Type + } + deriving (Eq) + +instance Ord NodeAnnotation where + compare (NodeAnnotation c0 t0) (NodeAnnotation c1 t1) + = mconcat [lexicalCompareFS c0 c1, lexicalCompareFS t0 t1] + +instance Outputable NodeAnnotation where + ppr (NodeAnnotation c t) = ppr (c,t) + +instance Binary NodeAnnotation where + put_ bh (NodeAnnotation c t) = do + put_ bh c + put_ bh t + get bh = NodeAnnotation + <$> get bh + <*> get bh + +-- | The information stored in one AST node. +-- +-- The type parameter exists to provide flexibility in representation of types +-- (see Note [Efficient serialization of redundant type info]). +data NodeInfo a = NodeInfo + { nodeAnnotations :: S.Set NodeAnnotation + -- ^ Annotations + + , nodeType :: [a] + -- ^ The Haskell types of this node, if any. + + , nodeIdentifiers :: NodeIdentifiers a + -- ^ All the identifiers and their details + } deriving (Functor, Foldable, Traversable) + +instance Binary (NodeInfo TypeIndex) where + put_ bh ni = do + put_ bh $ S.toAscList $ nodeAnnotations ni + put_ bh $ nodeType ni + put_ bh $ M.toList $ nodeIdentifiers ni + get bh = NodeInfo + <$> fmap (S.fromDistinctAscList) (get bh) + <*> get bh + <*> fmap (M.fromList) (get bh) + +instance Outputable a => Outputable (NodeInfo a) where + ppr (NodeInfo anns typs idents) = braces $ fsep $ punctuate ", " + [ parens (text "annotations:" <+> ppr anns) + , parens (text "types:" <+> ppr typs) + , parens (text "identifier info:" <+> pprNodeIdents idents) + ] + +pprNodeIdents :: Outputable a => NodeIdentifiers a -> SDoc +pprNodeIdents ni = braces $ fsep $ punctuate ", " $ map go $ M.toList ni + where + go (i,id) = parens $ hsep $ punctuate ", " [pprIdentifier i, ppr id] + +pprIdentifier :: Identifier -> SDoc +pprIdentifier (Left mod) = text "module" <+> ppr mod +pprIdentifier (Right name) = text "name" <+> ppr name + +type Identifier = Either ModuleName Name + +type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a) + +-- | Information associated with every identifier +-- +-- We need to include types with identifiers because sometimes multiple +-- identifiers occur in the same span(Overloaded Record Fields and so on) +data IdentifierDetails a = IdentifierDetails + { identType :: Maybe a + , identInfo :: S.Set ContextInfo + } deriving (Eq, Functor, Foldable, Traversable) + +instance Outputable a => Outputable (IdentifierDetails a) where + ppr x = text "Details: " <+> ppr (identType x) <+> ppr (identInfo x) + +instance Semigroup (IdentifierDetails a) where + d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2) + (S.union (identInfo d1) (identInfo d2)) + +instance Monoid (IdentifierDetails a) where + mempty = IdentifierDetails Nothing S.empty + +instance Binary (IdentifierDetails TypeIndex) where + put_ bh dets = do + put_ bh $ identType dets + put_ bh $ S.toList $ identInfo dets + get bh = IdentifierDetails + <$> get bh + <*> fmap S.fromDistinctAscList (get bh) + + +-- | Different contexts under which identifiers exist +data ContextInfo + = Use -- ^ regular variable + | MatchBind + | IEThing IEType -- ^ import/export + | TyDecl + + -- | Value binding + | ValBind + BindType -- ^ whether or not the binding is in an instance + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of entire binding + + -- | Pattern binding + -- + -- This case is tricky because the bound identifier can be used in two + -- distinct scopes. Consider the following example (with @-XViewPatterns@) + -- + -- @ + -- do (b, a, (a -> True)) <- bar + -- foo a + -- @ + -- + -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and + -- in the rest of the @do@-block in @foo a@. + | PatternBind + Scope -- ^ scope /in the pattern/ (the variable bound can be used + -- further in the pattern) + Scope -- ^ rest of the scope outside the pattern + (Maybe Span) -- ^ span of entire binding + + | ClassTyDecl (Maybe Span) + + -- | Declaration + | Decl + DeclType -- ^ type of declaration + (Maybe Span) -- ^ span of entire binding + + -- | Type variable + | TyVarBind Scope TyVarScope + + -- | Record field + | RecField RecFieldContext (Maybe Span) + -- | Constraint/Dictionary evidence variable binding + | EvidenceVarBind + EvVarSource -- ^ how did this bind come into being + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of the binding site + + -- | Usage of evidence variable + | EvidenceVarUse + deriving (Eq, Ord) + +instance Outputable ContextInfo where + ppr (Use) = text "usage" + ppr (MatchBind) = text "LHS of a match group" + ppr (IEThing x) = ppr x + ppr (TyDecl) = text "bound in a type signature declaration" + ppr (ValBind t sc sp) = + ppr t <+> text "value bound with scope:" <+> ppr sc <+> pprBindSpan sp + ppr (PatternBind sc1 sc2 sp) = + text "bound in a pattern with scope:" + <+> ppr sc1 <+> "," <+> ppr sc2 + <+> pprBindSpan sp + ppr (ClassTyDecl sp) = + text "bound in a class type declaration" <+> pprBindSpan sp + ppr (Decl d sp) = + text "declaration of" <+> ppr d <+> pprBindSpan sp + ppr (TyVarBind sc1 sc2) = + text "type variable binding with scope:" + <+> ppr sc1 <+> "," <+> ppr sc2 + ppr (RecField ctx sp) = + text "record field" <+> ppr ctx <+> pprBindSpan sp + ppr (EvidenceVarBind ctx sc sp) = + text "evidence variable" <+> ppr ctx + $$ "with scope:" <+> ppr sc + $$ pprBindSpan sp + ppr (EvidenceVarUse) = + text "usage of evidence variable" + +pprBindSpan :: Maybe Span -> SDoc +pprBindSpan Nothing = text "" +pprBindSpan (Just sp) = text "bound at:" <+> ppr sp + +instance Binary ContextInfo where + put_ bh Use = putByte bh 0 + put_ bh (IEThing t) = do + putByte bh 1 + put_ bh t + put_ bh TyDecl = putByte bh 2 + put_ bh (ValBind bt sc msp) = do + putByte bh 3 + put_ bh bt + put_ bh sc + put_ bh $ BinSpan <$> msp + put_ bh (PatternBind a b c) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh $ BinSpan <$> c + put_ bh (ClassTyDecl sp) = do + putByte bh 5 + put_ bh $ BinSpan <$> sp + put_ bh (Decl a b) = do + putByte bh 6 + put_ bh a + put_ bh $ BinSpan <$> b + put_ bh (TyVarBind a b) = do + putByte bh 7 + put_ bh a + put_ bh b + put_ bh (RecField a b) = do + putByte bh 8 + put_ bh a + put_ bh $ BinSpan <$> b + put_ bh MatchBind = putByte bh 9 + put_ bh (EvidenceVarBind a b c) = do + putByte bh 10 + put_ bh a + put_ bh b + put_ bh $ BinSpan <$> c + put_ bh EvidenceVarUse = putByte bh 11 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> return Use + 1 -> IEThing <$> get bh + 2 -> return TyDecl + 3 -> ValBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh) + 4 -> PatternBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh) + 5 -> ClassTyDecl <$> (fmap unBinSpan <$> get bh) + 6 -> Decl <$> get bh <*> (fmap unBinSpan <$> get bh) + 7 -> TyVarBind <$> get bh <*> get bh + 8 -> RecField <$> get bh <*> (fmap unBinSpan <$> get bh) + 9 -> return MatchBind + 10 -> EvidenceVarBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh) + 11 -> return EvidenceVarUse + _ -> panic "Binary ContextInfo: invalid tag" + +data EvVarSource + = EvPatternBind -- ^ bound by a pattern match + | EvSigBind -- ^ bound by a type signature + | EvWrapperBind -- ^ bound by a hswrapper + | EvImplicitBind -- ^ bound by an implicit variable + | EvInstBind { isSuperInst :: Bool, cls :: Name } -- ^ Bound by some instance of given class + | EvLetBind EvBindDeps -- ^ A direct let binding + deriving (Eq,Ord) + +instance Binary EvVarSource where + put_ bh EvPatternBind = putByte bh 0 + put_ bh EvSigBind = putByte bh 1 + put_ bh EvWrapperBind = putByte bh 2 + put_ bh EvImplicitBind = putByte bh 3 + put_ bh (EvInstBind b cls) = do + putByte bh 4 + put_ bh b + put_ bh cls + put_ bh (EvLetBind deps) = do + putByte bh 5 + put_ bh deps + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> pure EvPatternBind + 1 -> pure EvSigBind + 2 -> pure EvWrapperBind + 3 -> pure EvImplicitBind + 4 -> EvInstBind <$> get bh <*> get bh + 5 -> EvLetBind <$> get bh + _ -> panic "Binary EvVarSource: invalid tag" + +instance Outputable EvVarSource where + ppr EvPatternBind = text "bound by a pattern" + ppr EvSigBind = text "bound by a type signature" + ppr EvWrapperBind = text "bound by a HsWrapper" + ppr EvImplicitBind = text "bound by an implicit variable binding" + ppr (EvInstBind False cls) = text "bound by an instance of class" <+> ppr cls + ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls + ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps + +-- | Eq/Ord instances compare on the converted HieName, +-- as non-exported names may have different uniques after +-- a roundtrip +newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] } + deriving Outputable + +instance Eq EvBindDeps where + (==) = coerce ((==) `on` map toHieName) + +instance Ord EvBindDeps where + compare = coerce (compare `on` map toHieName) + +instance Binary EvBindDeps where + put_ bh (EvBindDeps xs) = put_ bh xs + get bh = EvBindDeps <$> get bh + + +-- | Types of imports and exports +data IEType + = Import + | ImportAs + | ImportHiding + | Export + deriving (Eq, Enum, Ord) + +instance Outputable IEType where + ppr Import = text "import" + ppr ImportAs = text "import as" + ppr ImportHiding = text "import hiding" + ppr Export = text "export" + +instance Binary IEType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data RecFieldContext + = RecFieldDecl + | RecFieldAssign + | RecFieldMatch + | RecFieldOcc + deriving (Eq, Enum, Ord) + +instance Outputable RecFieldContext where + ppr RecFieldDecl = text "declaration" + ppr RecFieldAssign = text "assignment" + ppr RecFieldMatch = text "pattern match" + ppr RecFieldOcc = text "occurrence" + +instance Binary RecFieldContext where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data BindType + = RegularBind + | InstanceBind + deriving (Eq, Ord, Enum) + +instance Outputable BindType where + ppr RegularBind = "regular" + ppr InstanceBind = "instance" + +instance Binary BindType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + +data DeclType + = FamDec -- ^ type or data family + | SynDec -- ^ type synonym + | DataDec -- ^ data declaration + | ConDec -- ^ constructor declaration + | PatSynDec -- ^ pattern synonym + | ClassDec -- ^ class declaration + | InstDec -- ^ instance declaration + deriving (Eq, Ord, Enum) + +instance Outputable DeclType where + ppr FamDec = text "type or data family" + ppr SynDec = text "type synonym" + ppr DataDec = text "data" + ppr ConDec = text "constructor" + ppr PatSynDec = text "pattern synonym" + ppr ClassDec = text "class" + ppr InstDec = text "instance" + +instance Binary DeclType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + +data Scope + = NoScope + | LocalScope Span + | ModuleScope + deriving (Eq, Ord, Data) + +instance Outputable Scope where + ppr NoScope = text "NoScope" + ppr (LocalScope sp) = text "LocalScope" <+> ppr sp + ppr ModuleScope = text "ModuleScope" + +instance Binary Scope where + put_ bh NoScope = putByte bh 0 + put_ bh (LocalScope span) = do + putByte bh 1 + put_ bh $ BinSpan span + put_ bh ModuleScope = putByte bh 2 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> return NoScope + 1 -> LocalScope . unBinSpan <$> get bh + 2 -> return ModuleScope + _ -> panic "Binary Scope: invalid tag" + + +-- | Scope of a type variable. +-- +-- This warrants a data type apart from 'Scope' because of complexities +-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For +-- example, consider: +-- +-- @ +-- foo, bar, baz :: forall a. a -> a +-- @ +-- +-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we +-- need a list of scopes to keep track of this. Furthermore, this list cannot be +-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@. +-- +-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@ +-- which later gets resolved into a 'ResolvedScopes'. +data TyVarScope + = ResolvedScopes [Scope] + + -- | Unresolved scopes should never show up in the final @.hie@ file + | UnresolvedScope + [Name] -- ^ names of the definitions over which the scope spans + (Maybe Span) -- ^ the location of the instance/class declaration for + -- the case where the type variable is declared in a + -- method type signature + deriving (Eq, Ord) + +instance Outputable TyVarScope where + ppr (ResolvedScopes xs) = + text "type variable scopes:" <+> hsep (punctuate ", " $ map ppr xs) + ppr (UnresolvedScope ns sp) = + text "unresolved type variable scope for name" O.<> plural ns + <+> pprBindSpan sp + +instance Binary TyVarScope where + put_ bh (ResolvedScopes xs) = do + putByte bh 0 + put_ bh xs + put_ bh (UnresolvedScope ns span) = do + putByte bh 1 + put_ bh ns + put_ bh (BinSpan <$> span) + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> ResolvedScopes <$> get bh + 1 -> UnresolvedScope <$> get bh <*> (fmap unBinSpan <$> get bh) + _ -> panic "Binary TyVarScope: invalid tag" + +-- | `Name`'s get converted into `HieName`'s before being written into @.hie@ +-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between +-- these two types. +data HieName + = ExternalName !Module !OccName !SrcSpan + | LocalName !OccName !SrcSpan + | KnownKeyName !Unique + deriving (Eq) + +instance Ord HieName where + compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) S.<> leftmost_smallest c f + -- TODO (int-index): Perhaps use RealSrcSpan in HieName? + compare (LocalName a b) (LocalName c d) = compare a c S.<> leftmost_smallest b d + -- TODO (int-index): Perhaps use RealSrcSpan in HieName? + compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b + -- Not actually non deterministic as it is a KnownKey + compare ExternalName{} _ = LT + compare LocalName{} ExternalName{} = GT + compare LocalName{} _ = LT + compare KnownKeyName{} _ = GT + +instance Outputable HieName where + ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp + ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp + ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u + +hieNameOcc :: HieName -> OccName +hieNameOcc (ExternalName _ occ _) = occ +hieNameOcc (LocalName occ _) = occ +hieNameOcc (KnownKeyName u) = + case lookupKnownKeyName u of + Just n -> nameOccName n + Nothing -> pprPanic "hieNameOcc:unknown known-key unique" + (ppr u) + +toHieName :: Name -> HieName +toHieName name + | isKnownKeyName name = KnownKeyName (nameUnique name) + | isExternalName name = ExternalName (nameModule name) + (nameOccName name) + (removeBufSpan $ nameSrcSpan name) + | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name) + + +{- Note [Capture Entity Information] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to capture the entity information for the identifier in HieAst, so that +language tools and protocols can take advantage making use of it. + +Capture `EntityInfo` for a `Name` or `Id` in `renamedSource` or `typecheckedSource` +if it is a name, we ask the env for the `TyThing` then compute the `EntityInfo` from tyThing +if it is an Id, we compute the `EntityInfo` directly from Id + +see issue #24544 for more details +-} + + +-- | Entity information +-- `EntityInfo` is a simplified version of `TyThing` and richer version than `Namespace` in `OccName`. +-- It state the kind of the entity, such as `Variable`, `TypeVariable`, `DataConstructor`, etc.. +data EntityInfo + = EntityVariable + | EntityFunction + | EntityDataConstructor + | EntityTypeVariable + | EntityClassMethod + | EntityPatternSynonym + | EntityTypeConstructor + | EntityTypeClass + | EntityTypeSynonym + | EntityTypeFamily + | EntityRecordField + deriving (Eq, Ord, Enum, Show) + + +instance Outputable EntityInfo where + ppr EntityVariable = text "variable" + ppr EntityFunction = text "function" + ppr EntityDataConstructor = text "data constructor" + ppr EntityTypeVariable = text "type variable" + ppr EntityClassMethod = text "class method" + ppr EntityPatternSynonym = text "pattern synonym" + ppr EntityTypeConstructor = text "type constructor" + ppr EntityTypeClass = text "type class" + ppr EntityTypeSynonym = text "type synonym" + ppr EntityTypeFamily = text "type family" + ppr EntityRecordField = text "record field" + + +instance Binary EntityInfo where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! toEnum (fromIntegral x) + + +-- | Get the `EntityInfo` for an `Id` +idEntityInfo :: Id -> S.Set EntityInfo +idEntityInfo vid = S.fromList $ [EntityTypeVariable | isTyVar vid] <> [EntityFunction | isFunType $ varType vid] + <> [EntityRecordField | isRecordSelector vid] <> [EntityClassMethod | isClassOpId vid] <> [EntityVariable] + where + isFunType a = case coreFullView a of + ForAllTy _ t -> isFunType t + FunTy { ft_af = flg, ft_res = rhs } -> isFUNArg flg || isFunType rhs + _x -> isFunTy a + +-- | Get the `EntityInfo` for a `TyThing` +tyThingEntityInfo :: TyThing -> S.Set EntityInfo +tyThingEntityInfo ty = case ty of + AnId vid -> idEntityInfo vid + AConLike con -> case con of + RealDataCon _ -> S.singleton EntityDataConstructor + PatSynCon _ -> S.singleton EntityPatternSynonym + ATyCon tyCon -> S.fromList $ [EntityTypeSynonym | isTypeSynonymTyCon tyCon] <> [EntityTypeFamily | isFamilyTyCon tyCon] + <> [EntityTypeClass | isClassTyCon tyCon] <> [EntityTypeConstructor] + ACoAxiom _ -> S.empty + +nameEntityInfo :: Name -> S.Set EntityInfo +nameEntityInfo name + | isTyVarName name = S.fromList [EntityVariable, EntityTypeVariable] + | isDataConName name = S.singleton EntityDataConstructor + | isTcClsNameSpace (occNameSpace $ occName name) = S.singleton EntityTypeConstructor + | isFieldName name = S.fromList [EntityVariable, EntityRecordField] + | isVarName name = S.fromList [EntityVariable] + | otherwise = S.empty diff --git a/GHC/Iface/Ext/Utils.hs b/GHC/Iface/Ext/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Ext/Utils.hs @@ -0,0 +1,603 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} +module GHC.Iface.Ext.Utils where + +import GHC.Prelude + +import GHC.Core.Map.Type +import GHC.Driver.DynFlags ( DynFlags ) +import GHC.Driver.Ppr +import GHC.Data.FastString ( FastString, mkFastString ) +import GHC.Iface.Type +import GHC.Types.Name hiding (varName) +import GHC.Types.Name.Set +import GHC.Utils.Outputable hiding ( (<>) ) +import qualified GHC.Utils.Outputable as O +import GHC.Types.SrcLoc +import GHC.CoreToIface +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( nonDetCmpType ) +import GHC.Core.Type +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Parser.Annotation +import qualified GHC.Data.Strict as Strict + +import GHC.Iface.Ext.Types + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Array as A +import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) ) +import Data.Maybe ( maybeToList, mapMaybe) +import Data.Monoid +import Data.List (find) +import Data.Traversable ( for ) +import Data.Coerce +import GHC.Utils.Monad.State.Strict hiding (get) +import GHC.Utils.Panic.Plain( assert ) +import Control.Monad.Trans.Reader +import qualified Data.Tree as Tree + +type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] + +generateReferencesMap + :: Foldable f + => f (HieAST a) + -> RefMap a +generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty + where + go ast = M.unionsWith (++) (this : map go (nodeChildren ast)) + where + this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast + +renderHieType :: DynFlags -> HieTypeFix -> String +renderHieType dflags ht = showSDoc dflags (ppr $ hieTypeToIface ht) + +resolveVisibility :: Type -> [Type] -> [(Bool,Type)] +resolveVisibility kind ty_args + = go (mkEmptySubst in_scope) kind ty_args + where + in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) + + go _ _ [] = [] + go env ty ts + | Just ty' <- coreView ty + = go env ty' ts + go env (ForAllTy (Bndr tv vis) res) (t:ts) + | isVisibleForAllTyFlag vis = (True , t) : ts' + | otherwise = (False, t) : ts' + where + ts' = go (extendTvSubst env tv t) res ts + + go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps + = (True,t) : (go env res ts) + + go env (TyVarTy tv) ts + | Just ki <- lookupTyVar env tv = go env ki ts + go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded + +foldType :: (HieType a -> a) -> HieTypeFix -> a +foldType f (Roll t) = f $ fmap (foldType f) t + +selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int) +selectPoint hf (sl,sc) = getFirst $ + flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(HiePath fs,ast) -> First $ + case selectSmallestContaining (sp fs) ast of + Nothing -> Nothing + Just ast' -> Just ast' + where + sloc fs = mkRealSrcLoc fs sl sc + sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + +findEvidenceUse :: NodeIdentifiers a -> [Name] +findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)] + where + xs = M.toList ni + +data EvidenceInfo a + = EvidenceInfo + { evidenceVar :: Name + , evidenceSpan :: RealSrcSpan + , evidenceType :: a + , evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span) + } deriving (Eq, Functor) + +instance Ord a => Ord (EvidenceInfo a) where + compare (EvidenceInfo name span typ dets) (EvidenceInfo name' span' typ' dets') = + case stableNameCmp name name' of + EQ -> compare (span, typ, dets) (span', typ', dets') + r -> r + +instance (Outputable a) => Outputable (EvidenceInfo a) where + ppr (EvidenceInfo name span typ dets) = + hang (ppr name <+> text "at" <+> ppr span O.<> text ", of type:" <+> ppr typ) 4 $ + pdets $$ (pprDefinedAt name) + where + pdets = case dets of + Nothing -> text "is a usage of an external evidence variable" + Just (src,scp,spn) -> text "is an" <+> ppr (EvidenceVarBind src scp spn) + +getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a) +getEvidenceTreesAtPoint hf refmap point = + [t | Just ast <- pure $ selectPoint hf point + , n <- findEvidenceUse (sourcedNodeIdents $ sourcedNodeInfo ast) + , Just t <- pure $ getEvidenceTree refmap n + ] + +getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a)) +getEvidenceTree refmap var = go emptyNameSet var + where + go seen var + | var `elemNameSet` seen = Nothing + | otherwise = do + xs <- M.lookup (Right var) refmap + case find (any isEvidenceBind . identInfo . snd) xs of + Just (sp,dets) -> do + typ <- identType dets + (evdet,children) <- getFirst $ foldMap First $ do + det <- S.toList $ identInfo dets + case det of + EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn -> + pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs) + EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[]) + _ -> pure Nothing + pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children + -- It is externally bound + Nothing -> getFirst $ foldMap First $ do + (sp,dets) <- xs + if (any isEvidenceUse $ identInfo dets) + then do + case identType dets of + Nothing -> pure Nothing + Just typ -> pure $ Just $ Tree.Node (EvidenceInfo var sp typ Nothing) [] + else pure Nothing + +hieTypeToIface :: HieTypeFix -> IfaceType +hieTypeToIface = foldType go + where + go (HTyVarTy n) = IfaceTyVar $ (mkIfLclName (occNameFS $ getOccName n)) + go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b) + go (HLitTy l) = IfaceLitTy l + go (HForAllTy ((n,k),af) t) = let b = (mkIfLclName (occNameFS $ getOccName n), k) + in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t + go (HFunTy w a b) = IfaceFunTy visArgTypeLike w a b + go (HQualTy pred b) = IfaceFunTy invisArgTypeLike many_ty pred b + go (HCastTy a) = a + go HCoercionTy = IfaceTyVar (mkIfLclName "") + go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) + + -- This isn't fully faithful - we can't produce the 'Inferred' case + hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs + hieToIfaceArgs (HieArgs xs) = go' xs + where + go' [] = IA_Nil + go' ((True ,x):xs) = IA_Arg x Required $ go' xs + go' ((False,x):xs) = IA_Arg x Specified $ go' xs + +data HieTypeState + = HTS + { tyMap :: !(TypeMap TypeIndex) + , htyTable :: !(IM.IntMap HieTypeFlat) + , freshIndex :: !TypeIndex + } + +initialHTS :: HieTypeState +initialHTS = HTS emptyTypeMap IM.empty 0 + +freshTypeIndex :: State HieTypeState TypeIndex +freshTypeIndex = do + index <- gets freshIndex + modify $ \hts -> hts { freshIndex = index+1 } + return index + +compressTypes + :: HieASTs Type + -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +compressTypes asts = (a, arr) + where + (a, (HTS _ m i)) = flip runState initialHTS $ + for asts $ \typ -> + getTypeIndex typ + arr = A.array (0,i-1) (IM.toList m) + +recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix +recoverFullType i m = go i + where + go i = Roll $ fmap go (m A.! i) + +getTypeIndex :: Type -> State HieTypeState TypeIndex +getTypeIndex t + | otherwise = do + tm <- gets tyMap + case lookupTypeMap tm t of + Just i -> return i + Nothing -> do + ht <- go t + extendHTS t ht + where + extendHTS t ht = do + i <- freshTypeIndex + modify $ \(HTS tm tt fi) -> + HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi + return i + + go (TyVarTy v) = return $ HTyVarTy $ varName v + go ty@(AppTy _ _) = do + let (head,args) = splitAppTys ty + visArgs = HieArgs $ resolveVisibility (typeKind head) args + ai <- getTypeIndex head + argsi <- mapM getTypeIndex visArgs + return $ HAppTy ai argsi + go (TyConApp f xs) = do + let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs + is <- mapM getTypeIndex visArgs + return $ HTyConApp (toIfaceTyCon f) is + go (ForAllTy (Bndr v a) t) = do + k <- getTypeIndex (varType v) + i <- getTypeIndex t + return $ HForAllTy ((varName v,k),a) i + go (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b }) = do + ai <- getTypeIndex a + bi <- getTypeIndex b + wi <- getTypeIndex w + return $ if isInvisibleFunArg af + then assert (isManyTy w) $ HQualTy ai bi + else HFunTy wi ai bi + go (LitTy a) = return $ HLitTy $ toIfaceTyLit a + go (CastTy t _) = do + i <- getTypeIndex t + return $ HCastTy i + go (CoercionTy _) = return HCoercionTy + +resolveTyVarScopes :: M.Map HiePath (HieAST a) -> M.Map HiePath (HieAST a) +resolveTyVarScopes asts = M.map go asts + where + go ast = resolveTyVarScopeLocal ast asts + +resolveTyVarScopeLocal :: HieAST a -> M.Map HiePath (HieAST a) -> HieAST a +resolveTyVarScopeLocal ast asts = go ast + where + resolveNameScope dets = dets{identInfo = + S.map resolveScope (identInfo dets)} + resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) = + TyVarBind sc $ ResolvedScopes + [ LocalScope binding + | name <- names + , Just binding <- [getNameBinding name asts] + ] + resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) = + TyVarBind sc $ ResolvedScopes + [ LocalScope binding + | name <- names + , Just binding <- [getNameBindingInClass name sp asts] + ] + resolveScope scope = scope + go (Node info span children) = Node info' span $ map go children + where + info' = SourcedNodeInfo (updateNodeInfo <$> getSourcedNodeInfo info) + updateNodeInfo i = i { nodeIdentifiers = idents } + where + idents = M.map resolveNameScope $ nodeIdentifiers i + +getNameBinding :: Name -> M.Map HiePath (HieAST a) -> Maybe Span +getNameBinding n asts = do + (_,msp) <- getNameScopeAndBinding n asts + msp + +getNameScope :: Name -> M.Map HiePath (HieAST a) -> Maybe [Scope] +getNameScope n asts = do + (scopes,_) <- getNameScopeAndBinding n asts + return scopes + +getNameBindingInClass + :: Name + -> Span + -> M.Map HiePath (HieAST a) + -> Maybe Span +getNameBindingInClass n sp asts = do + ast <- M.lookup (HiePath (srcSpanFile sp)) asts + clsNode <- selectLargestContainedBy sp ast + getFirst $ foldMap First $ do + child <- flattenAst clsNode + dets <- maybeToList + $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return (getFirst binding) + +getNameScopeAndBinding + :: Name + -> M.Map HiePath (HieAST a) + -> Maybe ([Scope], Maybe Span) +getNameScopeAndBinding n asts = case nameSrcSpan n of + RealSrcSpan sp _ -> do -- @Maybe + ast <- M.lookup (HiePath (srcSpanFile sp)) asts + defNode <- selectLargestContainedBy sp ast + getFirst $ foldMap First $ do -- @[] + node <- flattenAst defNode + dets <- maybeToList + $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node + scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return $ Just (scopes, getFirst binding) + _ -> Nothing + +getScopeFromContext :: ContextInfo -> Maybe [Scope] +getScopeFromContext (ValBind _ sc _) = Just [sc] +getScopeFromContext (PatternBind a b _) = Just [a, b] +getScopeFromContext (ClassTyDecl _) = Just [ModuleScope] +getScopeFromContext (Decl _ _) = Just [ModuleScope] +getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs +getScopeFromContext (TyVarBind a _) = Just [a] +getScopeFromContext (EvidenceVarBind _ a _) = Just [a] +getScopeFromContext _ = Nothing + +getBindSiteFromContext :: ContextInfo -> Maybe Span +getBindSiteFromContext (ValBind _ _ sp) = sp +getBindSiteFromContext (PatternBind _ _ sp) = sp +getBindSiteFromContext _ = Nothing + +flattenAst :: HieAST a -> [HieAST a] +flattenAst n = + n : concatMap flattenAst (nodeChildren n) + +smallestContainingSatisfying + :: Span + -> (HieAST a -> Bool) + -> HieAST a + -> Maybe (HieAST a) +smallestContainingSatisfying sp cond node + | nodeSpan node `containsSpan` sp = getFirst $ mconcat + [ foldMap (First . smallestContainingSatisfying sp cond) $ + nodeChildren node + , First $ if cond node then Just node else Nothing + ] + | sp `containsSpan` nodeSpan node = Nothing + | otherwise = Nothing + +selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a) +selectLargestContainedBy sp node + | sp `containsSpan` nodeSpan node = Just node + | nodeSpan node `containsSpan` sp = + getFirst $ foldMap (First . selectLargestContainedBy sp) $ + nodeChildren node + | otherwise = Nothing + +selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a) +selectSmallestContaining sp node + | nodeSpan node `containsSpan` sp = getFirst $ mconcat + [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node + , First (Just node) + ] + | sp `containsSpan` nodeSpan node = Nothing + | otherwise = Nothing + +definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool +definedInAsts asts n = case nameSrcSpan n of + RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts + _ -> False + +getEvidenceBindDeps :: ContextInfo -> [Name] +getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) = + getEvBindDeps xs +getEvidenceBindDeps _ = [] + +isEvidenceBind :: ContextInfo -> Bool +isEvidenceBind EvidenceVarBind{} = True +isEvidenceBind _ = False + +isEvidenceContext :: ContextInfo -> Bool +isEvidenceContext EvidenceVarUse = True +isEvidenceContext EvidenceVarBind{} = True +isEvidenceContext _ = False + +isEvidenceUse :: ContextInfo -> Bool +isEvidenceUse EvidenceVarUse = True +isEvidenceUse _ = False + +isOccurrence :: ContextInfo -> Bool +isOccurrence Use = True +isOccurrence EvidenceVarUse = True +isOccurrence _ = False + +scopeContainsSpan :: Scope -> Span -> Bool +scopeContainsSpan NoScope _ = False +scopeContainsSpan ModuleScope _ = True +scopeContainsSpan (LocalScope a) b = a `containsSpan` b + +-- | One must contain the other. Leaf nodes cannot contain anything +combineAst :: HieAST Type -> HieAST Type -> HieAST Type +combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys) + | aSpn == bSpn = Node (aInf `combineSourcedNodeInfo` bInf) aSpn (mergeAsts xs ys) + | aSpn `containsSpan` bSpn = combineAst b a +combineAst a (Node xs span children) = Node xs span (insertAst a children) + +-- | Insert an AST in a sorted list of disjoint Asts +insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type] +insertAst x = mergeAsts [x] + +nodeInfo :: HieAST Type -> NodeInfo Type +nodeInfo = foldl' combineNodeInfo emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo + +emptyNodeInfo :: NodeInfo a +emptyNodeInfo = NodeInfo S.empty [] M.empty + +sourcedNodeIdents :: SourcedNodeInfo a -> NodeIdentifiers a +sourcedNodeIdents = M.unionsWith (<>) . fmap nodeIdentifiers . getSourcedNodeInfo + +combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type +combineSourcedNodeInfo = coerce $ M.unionWith combineNodeInfo + +-- | Merge two nodes together. +-- +-- Precondition and postcondition: elements in 'nodeType' are ordered. +combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type +(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) = + NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd) + where + mergeSorted :: [Type] -> [Type] -> [Type] + mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of + LT -> a : mergeSorted as lb + EQ -> a : mergeSorted as bs + GT -> b : mergeSorted la bs + mergeSorted as [] = as + mergeSorted [] bs = bs + + +{- | Merge two sorted, disjoint lists of ASTs, combining when necessary. + +In the absence of position-altering pragmas (ex: @# line "file.hs" 3@), +different nodes in an AST tree should either have disjoint spans (in +which case you can say for sure which one comes first) or one span +should be completely contained in the other (in which case the contained +span corresponds to some child node). + +However, since Haskell does have position-altering pragmas it /is/ +possible for spans to be overlapping. Here is an example of a source file +in which @foozball@ and @quuuuuux@ have overlapping spans: + +@ +module Baz where + +# line 3 "Baz.hs" +foozball :: Int +foozball = 0 + +# line 3 "Baz.hs" +bar, quuuuuux :: Int +bar = 1 +quuuuuux = 2 +@ + +In these cases, we just do our best to produce sensible `HieAST`'s. The blame +should be laid at the feet of whoever wrote the line pragmas in the first place +(usually the C preprocessor...). +-} +mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type] +mergeAsts xs [] = xs +mergeAsts [] ys = ys +mergeAsts xs@(a:as) ys@(b:bs) + | span_a `containsSpan` span_b = mergeAsts (combineAst a b : as) bs + | span_b `containsSpan` span_a = mergeAsts as (combineAst a b : bs) + | span_a `rightOf` span_b = b : mergeAsts xs bs + | span_a `leftOf` span_b = a : mergeAsts as ys + + -- These cases are to work around ASTs that are not fully disjoint + | span_a `startsRightOf` span_b = b : mergeAsts as ys + | otherwise = a : mergeAsts as ys + where + span_a = nodeSpan a + span_b = nodeSpan b + +rightOf :: Span -> Span -> Bool +rightOf s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + >= (srcSpanEndLine s2, srcSpanEndCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + +leftOf :: Span -> Span -> Bool +leftOf s1 s2 + = (srcSpanEndLine s1, srcSpanEndCol s1) + <= (srcSpanStartLine s2, srcSpanStartCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + +startsRightOf :: Span -> Span -> Bool +startsRightOf s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + >= (srcSpanStartLine s2, srcSpanStartCol s2) + +-- | combines and sorts ASTs using a merge sort +mergeSortAsts :: [HieAST Type] -> [HieAST Type] +mergeSortAsts = go . map pure + where + go [] = [] + go [xs] = xs + go xss = go (mergePairs xss) + mergePairs [] = [] + mergePairs [xs] = [xs] + mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss + +simpleNodeInfo :: FastString -> FastString -> NodeInfo a +simpleNodeInfo cons typ = NodeInfo (S.singleton (NodeAnnotation cons typ)) [] M.empty + +locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a] +locOnly (RealSrcSpan span _) = do + org <- ask + let e = mkSourcedNodeInfo org $ emptyNodeInfo + pure [Node e span []] +locOnly _ = pure [] + +locOnlyE :: Monad m => EpaLocation -> ReaderT NodeOrigin m [HieAST a] +locOnlyE (EpaSpan s) = locOnly s +locOnlyE _ = pure [] + +mkScope :: (HasLoc a) => a -> Scope +mkScope a = case getHasLoc a of + (RealSrcSpan sp _) -> LocalScope sp + _ -> NoScope + +combineScopes :: Scope -> Scope -> Scope +combineScopes ModuleScope _ = ModuleScope +combineScopes _ ModuleScope = ModuleScope +combineScopes NoScope x = x +combineScopes x NoScope = x +combineScopes (LocalScope a) (LocalScope b) = + mkScope $ combineSrcSpans (RealSrcSpan a Strict.Nothing) (RealSrcSpan b Strict.Nothing) + +mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a +mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni + +{-# INLINEABLE makeNodeA #-} +makeNodeA + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> EpAnn ann -- ^ return an empty list if this is unhelpful + -> ReaderT NodeOrigin m [HieAST b] +makeNodeA x spn = makeNode x (locA spn) + +{-# INLINEABLE makeNode #-} +makeNode + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpan -- ^ return an empty list if this is unhelpful + -> ReaderT NodeOrigin m [HieAST b] +makeNode x spn = do + org <- ask + pure $ case spn of + RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] + _ -> [] + where + cons = mkFastString . show . toConstr $ x + typ = mkFastString . show . typeRepTyCon . typeOf $ x + +{-# INLINEABLE makeTypeNodeA #-} +makeTypeNodeA + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpanAnnA -- ^ return an empty list if this is unhelpful + -> Type -- ^ type to associate with the node + -> ReaderT NodeOrigin m [HieAST Type] +makeTypeNodeA x spn etyp = makeTypeNode x (locA spn) etyp + +{-# INLINEABLE makeTypeNode #-} +makeTypeNode + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpan -- ^ return an empty list if this is unhelpful + -> Type -- ^ type to associate with the node + -> ReaderT NodeOrigin m [HieAST Type] +makeTypeNode x spn etyp = do + org <- ask + pure $ case spn of + RealSrcSpan span _ -> + [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] + _ -> [] + where + cons = mkFastString . show . toConstr $ x + typ = mkFastString . show . typeRepTyCon . typeOf $ x diff --git a/GHC/Iface/Flags.hs b/GHC/Iface/Flags.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Flags.hs @@ -0,0 +1,194 @@ +-- | Datatype definitions for the flag representation stored in interface files +module GHC.Iface.Flags ( + IfaceDynFlags(..) + , IfaceGeneralFlag(..) + , IfaceProfAuto(..) + , IfaceExtension(..) + , IfaceLanguage(..) + , IfaceCppOptions(..) + , pprIfaceDynFlags + , missingExtraFlagInfo + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import Control.DeepSeq +import GHC.Utils.Fingerprint +import GHC.Utils.Binary + +import GHC.Driver.DynFlags +import GHC.Types.SafeHaskell +import GHC.Core.Opt.CallerCC.Types + +import qualified GHC.LanguageExtensions as LangExt + +-- The part of DynFlags which recompilation information needs +data IfaceDynFlags = IfaceDynFlags + { ifaceMainIs :: Maybe (Maybe String) + , ifaceSafeMode :: IfaceTrustInfo + , ifaceLang :: Maybe IfaceLanguage + , ifaceExts :: [IfaceExtension] + , ifaceCppOptions :: IfaceCppOptions + , ifaceJsOptions :: IfaceCppOptions + , ifaceCmmOptions :: IfaceCppOptions + , ifacePaths :: [String] + , ifaceProf :: Maybe IfaceProfAuto + , ifaceTicky :: [IfaceGeneralFlag] + , ifaceCodeGen :: [IfaceGeneralFlag] + , ifaceFatIface :: Bool + , ifaceDebugLevel :: Int + , ifaceCallerCCFilters :: [CallerCcFilter] + } + +pprIfaceDynFlags :: IfaceDynFlags -> SDoc +pprIfaceDynFlags (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) = + vcat [ text "main-is:" <+> (ppr $ fmap (fmap (text @SDoc)) a1) + , text "safe-mode:" <+> ppr a2 + , text "lang:" <+> ppr a3 + , text "exts:" <+> ppr a4 + , text "cpp-options:" + , nest 2 $ ppr a5 + , text "js-options:" + , nest 2 $ ppr a6 + , text "cmm-options:" + , nest 2 $ ppr a7 + , text "paths:" <+> hcat (map text a8) + , text "prof:" <+> ppr a9 + , text "ticky:" + , nest 2 $ vcat (map ppr a10) + , text "codegen:" + , nest 2 $ vcat (map ppr a11) + , text "fat-iface:" <+> ppr a12 + , text "debug-level:" <+> ppr a13 + , text "caller-cc-filters:" <+> ppr a14 + ] + +missingExtraFlagInfo :: SDoc +missingExtraFlagInfo = text "flags: no detailed info, recompile with -fwrite-if-self-recomp-flags" + where + -- If you modify the name of this flag, you have to modify this string. + _placeholder = Opt_WriteSelfRecompFlags + +instance Binary IfaceDynFlags where + put_ bh (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + put_ bh a11 + put_ bh a12 + put_ bh a13 + put_ bh a14 + get bh = IfaceDynFlags <$> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + +instance NFData IfaceDynFlags where + rnf (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) = + rnf a1 + `seq` rnf a2 + `seq` rnf a3 + `seq` rnf a4 + `seq` rnf a5 + `seq` rnf a6 + `seq` rnf a7 + `seq` rnf a8 + `seq` rnf a9 + `seq` rnf a10 + `seq` rnf a11 + `seq` rnf a12 + `seq` rnf a13 + `seq` rnf a14 + +newtype IfaceGeneralFlag = IfaceGeneralFlag GeneralFlag + +instance NFData IfaceGeneralFlag where + rnf (IfaceGeneralFlag !_) = () + +instance Binary IfaceGeneralFlag where + put_ bh (IfaceGeneralFlag f) = put_ bh (fromEnum f) + get bh = IfaceGeneralFlag . toEnum <$> get bh + +instance Outputable IfaceGeneralFlag where + ppr (IfaceGeneralFlag f) = text (show f) + +newtype IfaceProfAuto = IfaceProfAuto ProfAuto + +instance NFData IfaceProfAuto where + rnf (IfaceProfAuto !_) = () + +instance Binary IfaceProfAuto where + put_ bh (IfaceProfAuto f) = put_ bh (fromEnum f) + get bh = IfaceProfAuto . toEnum <$> get bh + +instance Outputable IfaceProfAuto where + ppr (IfaceProfAuto f) = text (show f) + + +newtype IfaceExtension = IfaceExtension LangExt.Extension + +instance NFData IfaceExtension where + rnf (IfaceExtension !_) = () + +instance Binary IfaceExtension where + put_ bh (IfaceExtension f) = put_ bh (fromEnum f) + get bh = IfaceExtension . toEnum <$> get bh + +instance Outputable IfaceExtension where + ppr (IfaceExtension f) = text (show f) + +newtype IfaceLanguage = IfaceLanguage Language + +instance NFData IfaceLanguage where + rnf (IfaceLanguage !_) = () + +instance Binary IfaceLanguage where + put_ bh (IfaceLanguage f) = put_ bh (fromEnum f) + get bh = IfaceLanguage . toEnum <$> get bh + +instance Outputable IfaceLanguage where + ppr (IfaceLanguage f) = text (show f) + +data IfaceCppOptions = IfaceCppOptions { ifaceCppIncludes :: [FilePath] + , ifaceCppOpts :: [String] + , ifaceCppSig :: ([String], Fingerprint) + } + +instance NFData IfaceCppOptions where + rnf (IfaceCppOptions is os s) = rnf is `seq` rnf os `seq` rnf s + +instance Binary IfaceCppOptions where + put_ bh (IfaceCppOptions is os s) = do + put_ bh is + put_ bh os + put_ bh s + get bh = IfaceCppOptions <$> get bh <*> get bh <*> get bh + +instance Outputable IfaceCppOptions where + ppr (IfaceCppOptions is os (wos, fp)) = + vcat [text "includes:" + , nest 2 $ hcat (map text is) + , text "opts:" + , nest 2 $ hcat (map text os) + , text "signature:" + , nest 2 $ parens (ppr fp) <+> ppr (map (text @SDoc) wos) + + ] diff --git a/GHC/Iface/Load.hs b/GHC/Iface/Load.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Load.hs @@ -0,0 +1,1251 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Loading interface files +module GHC.Iface.Load ( + -- Importing one thing + tcLookupImported_maybe, importDecl, + checkWiredInTyCon, ifCheckWiredInThing, + + -- RnM/TcM functions + loadModuleInterface, loadModuleInterfaces, + loadSrcInterface, loadSrcInterface_maybe, + loadInterfaceForName, loadInterfaceForModule, + + -- IfM functions + loadInterface, + loadSysInterface, loadUserInterface, loadPluginInterface, + findAndReadIface, readIface, writeIface, + flagsToIfCompression, + moduleFreeHolesPrecise, + needWiredInHomeIface, loadWiredInHomeIface, + + WhereFrom(..), + + pprModIfaceSimple, + ifaceStats, pprModIface, showIface, + + getGhcPrimIface, + + module Iface_Errors -- avoids boot files in Ppr modules + ) where + +import GHC.Prelude + +import GHC.Platform.Profile + +import {-# SOURCE #-} GHC.IfaceToCore + ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst + , tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceDefaults) + +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import GHC.Driver.DynFlags +import GHC.Driver.Hooks +import GHC.Driver.Plugins + +import GHC.Iface.Warnings +import GHC.Iface.Syntax +import GHC.Iface.Ext.Fields +import GHC.Iface.Binary +import GHC.Iface.Rename +import GHC.Iface.Env +import GHC.Iface.Errors as Iface_Errors + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad + +import GHC.Utils.Binary ( BinData(..) ) +import GHC.Utils.Error +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Logger + +import GHC.Settings.Constants + +import GHC.Builtin.Names +import GHC.Builtin.Utils + +import GHC.Core.Rules +import GHC.Core.TyCon +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv + +import GHC.Types.Annotations +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Types.Name.Env +import GHC.Types.Avail +import GHC.Types.Fixity +import GHC.Types.Fixity.Env +import GHC.Types.SourceError +import GHC.Types.SourceFile +import GHC.Types.SafeHaskell +import GHC.Types.TypeEnv +import GHC.Types.Unique.DSet +import GHC.Types.SrcLoc +import GHC.Types.TyThing +import GHC.Types.PkgQual + +import GHC.Unit.External +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Unit.Home.PackageTable +import GHC.Unit.Finder +import GHC.Unit.Env + +import GHC.Data.Maybe + +import Control.Monad +import Data.Map ( toList ) +import System.FilePath +import System.Directory +import GHC.Driver.Env.KnotVars +import {-# source #-} GHC.Driver.Main (loadIfaceByteCode) +import GHC.Iface.Errors.Types +import Data.Function ((&)) +import GHC.Unit.Module.Graph +import qualified GHC.Unit.Home.Graph as HUG + +{- +************************************************************************ +* * +* tcImportDecl is the key function for "faulting in" * +* imported things +* * +************************************************************************ + +The main idea is this. We are chugging along type-checking source code, and +find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find +it in the EPS type envt. So it + 1 loads GHC.Base.hi + 2 gets the decl for GHC.Base.map + 3 typechecks it via tcIfaceDecl + 4 and adds it to the type env in the EPS + +Note that DURING STEP 4, we may find that map's type mentions a type +constructor that also + +Notice that for imported things we read the current version from the EPS +mutable variable. This is important in situations like + ...$(e1)...$(e2)... +where the code that e1 expands to might import some defns that +also turn out to be needed by the code that e2 expands to. +-} + +tcLookupImported_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing) +-- Returns (Failed err) if we can't find the interface file for the thing +tcLookupImported_maybe name + = do { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupType hsc_env name) + ; case mb_thing of + Just thing -> return (Succeeded thing) + Nothing -> tcImportDecl_maybe name } + +tcImportDecl_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing) +-- Entry point for *source-code* uses of importDecl +tcImportDecl_maybe name + | Just thing <- wiredInNameTyThing_maybe name + = do { when (needWiredInHomeIface thing) + (initIfaceTcRn (loadWiredInHomeIface name)) + -- See Note [Loading instances for wired-in things] + ; return (Succeeded thing) } + | otherwise + = initIfaceTcRn (importDecl name) + +importDecl :: Name -> IfM lcl (MaybeErr IfaceMessage TyThing) +-- Get the TyThing for this Name from an interface file +-- It's not a wired-in thing -- the caller caught that +importDecl name + = assert (not (isWiredInName name)) $ + do { logger <- getLogger + ; liftIO $ trace_if logger nd_doc + + -- Load the interface, which should populate the PTE + ; mb_iface <- assertPpr (isExternalName name) (ppr name) $ + loadInterface nd_doc (nameModule name) ImportBySystem + ; case mb_iface of + { Failed err_msg -> return $ Failed $ + Can'tFindInterface err_msg (LookingForName name) + ; Succeeded _ -> do + + -- Now look it up again; this time we should find it + { eps <- getEps + ; case lookupTypeEnv (eps_PTE eps) name of + Just thing -> return $ Succeeded thing + Nothing -> return $ Failed $ + Can'tFindNameInInterface name + (filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps) + }}} + where + nd_doc = text "Need decl for" <+> ppr name + is_interesting thing = nameModule name == nameModule (getName thing) + + +{- +************************************************************************ +* * + Checks for wired-in things +* * +************************************************************************ + +Note [Loading instances for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to make sure that we have at least *read* the interface files +for any module with an instance decl or RULE that we might want. + +* If the instance decl is an orphan, we have a whole separate mechanism + (loadOrphanModules) + +* If the instance decl is not an orphan, then the act of looking at the + TyCon or Class will force in the defining module for the + TyCon/Class, and hence the instance decl + +* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface; + but we must make sure we read its interface in case it has instances or + rules. That is what GHC.Iface.Load.loadWiredInHomeIface does. It's called + from GHC.IfaceToCore.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing} + +* HOWEVER, only do this for TyCons. There are no wired-in Classes. There + are some wired-in Ids, but we don't want to load their interfaces. For + example, Control.Exception.Base.recSelError is wired in, but that module + is compiled late in the base library, and we don't want to force it to + load before it's been compiled! + +All of this is done by the type checker. The renamer plays no role. +(It used to, but no longer.) +-} + +checkWiredInTyCon :: TyCon -> TcM () +-- Ensure that the home module of the TyCon (and hence its instances) +-- are loaded. See Note [Loading instances for wired-in things] +-- It might not be a wired-in tycon (see the calls in GHC.Tc.Utils.Unify), +-- in which case this is a no-op. +checkWiredInTyCon tc + | not (isWiredInName tc_name) + = return () + | otherwise + = do { mod <- getModule + ; logger <- getLogger + ; liftIO $ trace_if logger (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod) + ; assert (isExternalName tc_name ) + when (mod /= nameModule tc_name) + (initIfaceTcRn (loadWiredInHomeIface tc_name)) + -- Don't look for (non-existent) Float.hi when + -- compiling Float.hs, which mentions Float of course + -- A bit yukky to call initIfaceTcRn here + } + where + tc_name = tyConName tc + +ifCheckWiredInThing :: TyThing -> IfL () +-- Even though we are in an interface file, we want to make +-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) +-- Ditto want to ensure that RULES are loaded too +-- See Note [Loading instances for wired-in things] +ifCheckWiredInThing thing + = do { mod <- getIfModule + -- Check whether we are typechecking the interface for this + -- very module. E.g when compiling the base library in --make mode + -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in + -- the HPT, so without the test we'll demand-load it into the PIT! + -- C.f. the same test in checkWiredInTyCon above + ; let name = getName thing + ; assertPpr (isExternalName name) (ppr name) $ + when (needWiredInHomeIface thing && mod /= nameModule name) + (loadWiredInHomeIface name) } + +needWiredInHomeIface :: TyThing -> Bool +-- Only for TyCons; see Note [Loading instances for wired-in things] +needWiredInHomeIface (ATyCon {}) = True +needWiredInHomeIface _ = False + + +{- +************************************************************************ +* * + loadSrcInterface, loadOrphanModules, loadInterfaceForName + + These three are called from TcM-land +* * +************************************************************************ +-} + +-- | Load the interface corresponding to an @import@ directive in +-- source code. On a failure, fail in the monad with an error message. +loadSrcInterface :: SDoc + -> ModuleName + -> IsBootInterface -- {-# SOURCE #-} ? + -> PkgQual -- "package", if any + -> RnM ModIface + +loadSrcInterface doc mod want_boot maybe_pkg + = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg + ; case res of + Failed err -> + failWithTc $ + TcRnInterfaceError $ + Can'tFindInterface err $ + LookingForModule mod want_boot + Succeeded iface -> + return iface + } + +-- | Like 'loadSrcInterface', but returns a 'MaybeErr'. +loadSrcInterface_maybe :: SDoc + -> ModuleName + -> IsBootInterface -- {-# SOURCE #-} ? + -> PkgQual -- "package", if any + -> RnM (MaybeErr MissingInterfaceError ModIface) + +loadSrcInterface_maybe doc mod want_boot maybe_pkg + -- We must first find which Module this import refers to. This involves + -- calling the Finder, which as a side effect will search the filesystem + -- and create a ModLocation. If successful, loadIface will read the + -- interface; it will call the Finder again, but the ModLocation will be + -- cached from the first search. + = do hsc_env <- getTopEnv + res <- liftIO $ findImportedModule hsc_env mod maybe_pkg + case res of + Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) + -- TODO: Make sure this error message is good + err -> return (Failed (cannotFindModule hsc_env mod err)) + +-- | Load interface directly for a fully qualified 'Module'. (This is a fairly +-- rare operation, but in particular it is used to load orphan modules +-- in order to pull their instances into the global package table and to +-- handle some operations in GHCi). +loadModuleInterface :: SDoc -> Module -> TcM ModIface +loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod) + +-- | Load interfaces for a collection of modules. +loadModuleInterfaces :: SDoc -> [Module] -> TcM () +loadModuleInterfaces doc mods + | null mods = return () + | otherwise = initIfaceTcRn (mapM_ load mods) + where + load mod = loadSysInterface (doc <+> parens (ppr mod)) mod + +-- | Loads the interface for a given Name. +-- Should only be called for an imported name; +-- otherwise loadSysInterface may not find the interface +loadInterfaceForName :: SDoc -> Name -> TcRn ModIface +loadInterfaceForName doc name + = do { when debugIsOn $ -- Check pre-condition + do { this_mod <- getModule + ; massertPpr (not (nameIsLocalOrFrom this_mod name)) (ppr name <+> parens doc) } + ; assertPpr (isExternalName name) (ppr name) $ + initIfaceTcRn $ loadSysInterface doc (nameModule name) } + +-- | Loads the interface for a given Module. +loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface +loadInterfaceForModule doc m + = do + -- Should not be called with this module + when debugIsOn $ do + this_mod <- getModule + massertPpr (this_mod /= m) (ppr m <+> parens doc) + initIfaceTcRn $ loadSysInterface doc m + +{- +********************************************************* +* * + loadInterface + + The main function to load an interface + for an imported module, and put it in + the External Package State +* * +********************************************************* +-} + +-- | An 'IfM' function to load the home interface for a wired-in thing, +-- so that we're sure that we see its instance declarations and rules +-- See Note [Loading instances for wired-in things] +loadWiredInHomeIface :: Name -> IfM lcl () +loadWiredInHomeIface name + = assert (isWiredInName name) $ + do _ <- loadSysInterface doc (nameModule name); return () + where + doc = text "Need home interface for wired-in thing" <+> ppr name + +------------------ +-- | Loads a system interface and throws an exception if it fails +loadSysInterface :: SDoc -> Module -> IfM lcl ModIface +loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem + +------------------ +-- | Loads a user interface and throws an exception if it fails. The first parameter indicates +-- whether we should import the boot variant of the module +loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl ModIface +loadUserInterface is_boot doc mod_name + = loadInterfaceWithException doc mod_name (ImportByUser is_boot) + +loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface +loadPluginInterface doc mod_name + = loadInterfaceWithException doc mod_name ImportByPlugin + +------------------ +-- | A wrapper for 'loadInterface' that throws an exception if it fails +loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface +loadInterfaceWithException doc mod_name where_from + = do + dflags <- getDynFlags + let ctx = initSDocContext dflags defaultUserStyle + withIfaceErr ctx (loadInterface doc mod_name where_from) + +------------------ +loadInterface :: SDoc -> Module -> WhereFrom + -> IfM lcl (MaybeErr MissingInterfaceError ModIface) + +-- loadInterface looks in both the HPT and PIT for the required interface +-- If not found, it loads it, and puts it in the PIT (always). + +-- If it can't find a suitable interface file, we +-- a) modify the PackageIfaceTable to have an empty entry +-- (to avoid repeated complaints) +-- b) return (Left message) +-- +-- It's not necessarily an error for there not to be an interface +-- file -- perhaps the module has changed, and that interface +-- is no longer used + +loadInterface doc_str mod from + | isHoleModule mod + -- Hole modules get special treatment + = do hsc_env <- getTopEnv + let home_unit = hsc_home_unit hsc_env + -- Redo search for our local hole module + loadInterface doc_str (mkHomeModule home_unit (moduleName mod)) from + | otherwise + = do + logger <- getLogger + withTimingSilent logger (text "loading interface") (pure ()) $ do + { -- Read the state + (eps,hug) <- getEpsAndHug + ; gbl_env <- getGblEnv + + ; liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> ppr from) + + -- Check whether we have the interface already + ; hsc_env <- getTopEnv + ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env) + ; liftIO (lookupIfaceByModule hug (eps_PIT eps) mod) >>= \case { + Just iface + -> return (Succeeded iface) ; -- Already loaded + _ -> do { + + -- READ THE MODULE IN + ; read_result <- case wantHiBootFile mhome_unit eps mod from of + Failed err -> return (Failed err) + Succeeded hi_boot_file -> do + hsc_env <- getTopEnv + liftIO $ computeInterface hsc_env doc_str hi_boot_file mod + ; case read_result of { + Failed err -> do + { let fake_iface = emptyFullModIface mod + + ; updateEps_ $ \eps -> + eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } + -- Not found, so add an empty iface to + -- the EPS map so that we don't look again + + ; return (Failed err) } ; + + -- Found and parsed! + -- We used to have a sanity check here that looked for: + -- * System importing .. + -- * a home package module .. + -- * that we know nothing about (mb_dep == Nothing)! + -- + -- But this is no longer valid because thNameToGhcName allows users to + -- cause the system to load arbitrary interfaces (by supplying an appropriate + -- Template Haskell original-name). + Succeeded (iface, loc) -> + let + loc_doc = text (ml_hi_file loc) + in + initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ + + dontLeakTheHUG $ do + + -- Load the new ModIface into the External Package State + -- Even home-package interfaces loaded by loadInterface + -- (which only happens in OneShot mode; in Batch/Interactive + -- mode, home-package modules are loaded one by one into the HPT) + -- are put in the EPS. + -- + -- The main thing is to add the ModIface to the PIT, but + -- we also take the + -- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, + -- out of the ModIface and put them into the big EPS pools + + -- NB: *first* we do tcIfaceDecls, so that the provenance of all the locally-defined + --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). + -- If we do loadExport first the wrong info gets into the cache (unless we + -- explicitly tag each export which seems a bit of a bore) + + -- Crucial assertion that checks if you are trying to load a HPT module into the EPS. + -- If you start loading HPT modules into the EPS then you get strange errors about + -- overlapping instances. + ; massertPpr + ((isOneShot (ghcMode (hsc_dflags hsc_env))) + || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env + || mod == gHC_PRIM) + (text "Attempting to load home package interface into the EPS" $$ ppr (HUG.allUnits hug) $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod)) + ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas + ; new_eps_decls <- tcIfaceDecls ignore_prags (mi_decls iface) + ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) + ; new_eps_defaults <- tcIfaceDefaults mod (mi_defaults iface) + ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface) + ; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) + ; purged_hsc_env <- getTopEnv + + ; let final_iface = iface + & set_mi_decls (panic "No mi_decls in PIT") + & set_mi_insts (panic "No mi_insts in PIT") + & set_mi_defaults (panic "No mi_defaults in PIT") + & set_mi_fam_insts (panic "No mi_fam_insts in PIT") + & set_mi_rules (panic "No mi_rules in PIT") + & set_mi_anns (panic "No mi_anns in PIT") + & set_mi_simplified_core (panic "No mi_simplified_core in PIT") + + 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] + + -- Create an IO action that loads and compiles bytecode from Core + -- bindings. + -- + -- See Note [Interface Files with Core Definitions] + add_bytecode old + | Just action <- loadIfaceByteCode purged_hsc_env iface loc (mkNameEnv new_eps_decls) + = extendModuleEnv old mod action + -- Don't add an entry if the iface doesn't have 'extra_decls' + -- so 'get_link_deps' knows that it should load object code. + | otherwise + = old + + ; warnPprTrace bad_boot "loadInterface" (ppr mod) $ + updateEps_ $ \ eps -> + if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface + then eps + else if bad_boot + -- See Note [Loading your own hi-boot file] + then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls } + else + eps { + eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, + eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, + eps_iface_bytecode = add_bytecode (eps_iface_bytecode eps), + eps_rule_base = extendRuleBaseList (eps_rule_base eps) + new_eps_rules, + eps_complete_matches + = eps_complete_matches eps ++ new_eps_complete_matches, + eps_inst_env = extendInstEnvList (eps_inst_env eps) + new_eps_insts, + eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) + new_eps_fam_insts, + eps_ann_env = extendAnnEnvList (eps_ann_env eps) + new_eps_anns, + eps_mod_fam_inst_env + = let + fam_inst_env = + extendFamInstEnvList emptyFamInstEnv + new_eps_fam_insts + in + extendModuleEnv (eps_mod_fam_inst_env eps) + mod + fam_inst_env, + eps_stats = addEpsInStats (eps_stats eps) + (length new_eps_decls) + (length new_eps_insts) + (length new_eps_rules), + eps_defaults = extendModuleEnv (eps_defaults eps) mod new_eps_defaults + } + + ; -- invoke plugins with *full* interface, not final_iface, to ensure + -- that plugins have access to declarations, etc. + res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface + ; return (Succeeded res) + }}}} + +{- Note [Loading your own hi-boot file] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, when compiling module M, we should not +load M.hi-boot into the EPS. After all, we are very shortly +going to have full information about M. Moreover, see +Note [Do not update EPS with your own hi-boot] in GHC.Iface.Recomp. + +But there is a HORRIBLE HACK here. + +* At the end of tcRnImports, we call checkFamInstConsistency to + check consistency of imported type-family instances + See Note [The type family instance consistency story] in GHC.Tc.Instance.Family + +* Alas, those instances may refer to data types defined in M, + if there is a M.hs-boot. + +* And that means we end up loading M.hi-boot, because those + data types are not yet in the type environment. + +But in this weird case, /all/ we need is the types. We don't need +instances, rules etc. And if we put the instances in the EPS +we get "duplicate instance" warnings when we compile the "real" +instance in M itself. Hence the strange business of just updateing +the eps_PTE. + +This really happens in practice. The module "GHC.Hs.Expr" gets +"duplicate instance" errors if this hack is not present. + +This is a mess. + + +Note [Home Unit Graph space leak] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Ticket: #15111 + +In IfL, we defer some work until it is demanded using forkM, such +as building TyThings from IfaceDecls. These thunks are stored in +the ExternalPackageState, and they might never be poked. If we're +not careful, these thunks will capture the state of the loaded +program when we read an interface file, and retain all that data +for ever. + +Therefore, when loading a package interface file , we use a "clean" +version of the HscEnv with all the data about the currently loaded +program stripped out. Most of the fields can be panics because +we'll never read them, but hsc_HUG needs to be empty because this +interface will cause other interfaces to be loaded recursively, and +when looking up those interfaces we use the HUG in loadInterface. +We know that none of the interfaces below here can refer to +home-package modules however, so it's safe for the HUG to be empty. +-} + +-- Note [GHC Heap Invariants] +-- Note [Home Unit Graph space leak] +dontLeakTheHUG :: IfL a -> IfL a +dontLeakTheHUG thing_inside = do + env <- getTopEnv + let + inOneShot = + isOneShot (ghcMode (hsc_dflags env)) + cleanGblEnv gbl_env + | inOneShot = gbl_env + | otherwise = gbl_env { if_rec_types = emptyKnotVars } + cleanTopEnv hsc_env = + + let + !maybe_type_vars | inOneShot = Just (hsc_type_env_vars env) + | otherwise = Nothing + -- wrinkle: when we're typechecking in --backpack mode, the + -- instantiation of a signature might reside in the HPT, so + -- this case breaks the assumption that EPS interfaces only + -- refer to other EPS interfaces. + -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it + -- contains any hole modules. + -- Quite a few tests in testsuite/tests/backpack break without this + -- tweak. + old_unit_env = hsc_unit_env hsc_env + keepFor20509 + -- oneshot mode does not support backpack + -- and we want to avoid prodding the hsc_mod_graph thunk + | isOneShot (ghcMode (hsc_dflags hsc_env)) = False + | mgHasHoles (ue_module_graph old_unit_env) = True + | otherwise = False + pruneHomeUnitEnv hme = do + -- NB: These are empty HPTs because Iface/Load first consults the HPT + emptyHPT <- liftIO emptyHomePackageTable + return $! hme{ homeUnitEnv_hpt = emptyHPT } + unit_env_io + | keepFor20509 + = return old_unit_env + | otherwise + = do + hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph old_unit_env) + let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" + , mg_graph = panic "cleanTopEnv: mg_graph" + , mg_has_holes = keepFor20509 } + return old_unit_env + { ue_home_unit_graph = hug' + , ue_module_graph = new_mod_graph + } + in do + !unit_env <- unit_env_io + -- mg_has_holes will be checked again, but nothing else about the module graph + pure $ + hsc_env + { hsc_targets = panic "cleanTopEnv: hsc_targets" + , 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 + } + + updTopEnvIO cleanTopEnv $ updGblEnv cleanGblEnv $ do + !_ <- getTopEnv -- force the updTopEnv + !_ <- getGblEnv + thing_inside + + +-- | Returns @True@ if a 'ModIface' comes from an external package. +-- In this case, we should NOT load it into the EPS; the entities +-- should instead come from the local merged signature interface. +is_external_sig :: Maybe HomeUnit -> ModIface -> Bool +is_external_sig mhome_unit iface = + -- It's a signature iface... + mi_semantic_module iface /= mi_module iface && + -- and it's not from the local package + notHomeModuleMaybe mhome_unit (mi_module iface) + +-- | This is an improved version of 'findAndReadIface' which can also +-- handle the case when a user requests @p[A=]:M@ but we only +-- have an interface for @p[A=]:M@ (the indefinite interface. +-- If we are not trying to build code, we load the interface we have, +-- *instantiating it* according to how the holes are specified. +-- (Of course, if we're actually building code, this is a hard error.) +-- +-- In the presence of holes, 'computeInterface' has an important invariant: +-- to load module M, its set of transitively reachable requirements must +-- have an up-to-date local hi file for that requirement. Note that if +-- we are loading the interface of a requirement, this does not +-- apply to the requirement itself; e.g., @p[A=]:A@ does not require +-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless +-- we are actually typechecking p.) +computeInterface + :: HscEnv + -> SDoc + -> IsBootInterface + -> Module + -> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation)) +computeInterface hsc_env doc_str hi_boot_file mod0 = do + massert (not (isHoleModule mod0)) + let mhome_unit = hsc_home_unit_maybe hsc_env + let find_iface m = findAndReadIface hsc_env doc_str + m mod0 hi_boot_file + case getModuleInstantiation mod0 of + (imod, Just indef) + | Just home_unit <- mhome_unit + , isHomeUnitIndefinite home_unit -> + find_iface imod >>= \case + Succeeded (iface0, path) -> + rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case + Right x -> return (Succeeded (x, path)) + Left errs -> throwErrors (GhcTcRnMessage <$> errs) + Failed err -> return (Failed err) + (mod, _) -> find_iface mod + +-- | Compute the signatures which must be compiled in order to +-- load the interface for a 'Module'. The output of this function +-- is always a subset of 'moduleFreeHoles'; it is more precise +-- because in signature @p[A=\,B=\]:B@, although the free holes +-- are A and B, B might not depend on A at all! +-- +-- If this is invoked on a signature, this does NOT include the +-- signature itself; e.g. precise free module holes of +-- @p[A=\,B=\]:B@ never includes B. +moduleFreeHolesPrecise + :: SDoc -> Module + -> TcRnIf gbl lcl (MaybeErr MissingInterfaceError (UniqDSet ModuleName)) +moduleFreeHolesPrecise doc_str mod + | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) + | otherwise = + case getModuleInstantiation mod of + (imod, Just indef) -> do + logger <- getLogger + let insts = instUnitInsts (moduleUnit indef) + liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> + text "to compute precise free module holes") + (eps, hpt) <- getEpsAndHug + result <- tryEpsAndHpt eps hpt + case result `firstJust` tryDepsCache eps imod insts of + Just r -> return (Succeeded r) + Nothing -> readAndCache imod insts + (_, Nothing) -> return (Succeeded emptyUniqDSet) + where + tryEpsAndHpt eps hpt = + fmap mi_free_holes <$> liftIO (lookupIfaceByModule hpt (eps_PIT eps) mod) + tryDepsCache eps imod insts = + case lookupInstalledModuleEnv (eps_free_holes eps) imod of + Just ifhs -> Just (renameFreeHoles ifhs insts) + _otherwise -> Nothing + readAndCache imod insts = do + hsc_env <- getTopEnv + mb_iface <- liftIO $ findAndReadIface hsc_env + (text "moduleFreeHolesPrecise" <+> doc_str) + imod mod NotBoot + case mb_iface of + Succeeded (iface, _) -> do + let ifhs = mi_free_holes iface + -- Cache it + updateEps_ (\eps -> + eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs }) + return (Succeeded (renameFreeHoles ifhs insts)) + Failed err -> return (Failed err) + +wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom + -> MaybeErr MissingInterfaceError IsBootInterface +-- Figure out whether we want Foo.hi or Foo.hi-boot +wantHiBootFile mhome_unit eps mod from + = case from of + ImportByUser usr_boot + | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod + -> Failed (BadSourceImport mod) + | otherwise -> Succeeded usr_boot + + ImportByPlugin + -> Succeeded NotBoot + + ImportBySystem + | notHomeModuleMaybe mhome_unit mod + -> Succeeded NotBoot + -- If the module to be imported is not from this package + -- don't look it up in eps_is_boot, because that is keyed + -- on the ModuleName of *home-package* modules only. + -- We never import boot modules from other packages! + + | otherwise + -> case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of + Just (GWIB { gwib_isBoot = is_boot }) -> + Succeeded is_boot + Nothing -> + Succeeded NotBoot + -- The boot-ness of the requested interface, + -- based on the dependencies in directly-imported modules + + +----------------------------------------------------- +-- Loading type/class/value decls +-- We pass the full Module name here, replete with +-- its package info, so that we can build a Name for +-- each binder with the right package info in it +-- All subsequent lookups, including crucially lookups during typechecking +-- the declaration itself, will find the fully-glorious Name +-- +-- We handle ATs specially. They are not main declarations, but also not +-- implicit things (in particular, adding them to `implicitTyThings' would mess +-- things up in the renaming/type checking of source programs). +----------------------------------------------------- + +addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv +addDeclsToPTE pte things = extendNameEnvList pte things + +{- +********************************************************* +* * +\subsection{Reading an interface file} +* * +********************************************************* + +Note [Home module load error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the sought-for interface is in the current package (as determined +by -package-name flag) then it jolly well should already be in the HPT +because we process home-package modules in dependency order. (Except +in one-shot mode; see notes with hsc_HPT decl in GHC.Driver.Env). + +It is possible (though hard) to get this error through user behaviour. + * Suppose package P (modules P1, P2) depends on package Q (modules Q1, + Q2, with Q2 importing Q1) + * We compile both packages. + * Now we edit package Q so that it somehow depends on P + * Now recompile Q with --make (without recompiling P). + * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2 + is a home-package module which is not yet in the HPT! Disaster. + +This actually happened with P=base, Q=ghc-prim, via the AMP warnings. +See #8320. +-} + +findAndReadIface + :: HscEnv + -> SDoc -- ^ Reason for loading the iface (used for tracing) + -> InstalledModule -- ^ The unique identifier of the on-disk module we're looking for + -> Module -- ^ The *actual* module we're looking for. We use + -- this to check the consistency of the requirements of the + -- module we read out. + -> IsBootInterface -- ^ Looking for .hi-boot or .hi file + -> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation)) +findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do + + let profile = targetProfile dflags + unit_state = hsc_units 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 + + + trace_if logger (sep [hsep [text "Reading", + if hi_boot_file == IsBoot + then text "[boot]" + else Outputable.empty, + text "interface for", + ppr mod <> semi], + nest 4 (text "reason:" <+> doc_str)]) + + -- Look for the file + mb_found <- liftIO (findExactModule hsc_env mod hi_boot_file) + case mb_found of + InstalledFound loc -> do + -- See Note [Home module load error] + if HUG.memberHugUnitId (moduleUnit mod) (hsc_HUG hsc_env) + && not (isOneShot (ghcMode dflags)) + then return (Failed (HomeModError mod loc)) + else do + r <- read_file hooks logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) + case r of + Failed err + -> return (Failed $ BadIfaceFile err) + Succeeded (iface,_fp) + -> do + r2 <- load_dynamic_too_maybe hooks logger name_cache unit_state + (setDynamicNow dflags) wanted_mod + iface loc + case r2 of + Failed sdoc -> return (Failed sdoc) + Succeeded {} -> return $ Succeeded (iface, loc) + err -> do + trace_if logger (text "...not found") + return $ Failed $ cannotFindInterface + unit_state + mhome_unit + profile + (moduleName mod) + err + +-- | Check if we need to try the dynamic interface for -dynamic-too +load_dynamic_too_maybe :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags + -> Module -> ModIface -> ModLocation + -> IO (MaybeErr MissingInterfaceError ()) +load_dynamic_too_maybe hooks 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 hooks logger name_cache unit_state dflags wanted_mod iface loc + | otherwise = return (Succeeded ()) + +load_dynamic_too :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags + -> Module -> ModIface -> ModLocation + -> IO (MaybeErr MissingInterfaceError ()) +load_dynamic_too hooks logger name_cache unit_state dflags wanted_mod iface loc = do + read_file hooks logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case + Succeeded (dynIface, _) + | mi_mod_hash iface == mi_mod_hash dynIface + -> return (Succeeded ()) + | otherwise -> + do return $ (Failed $ DynamicHashMismatchError wanted_mod loc) + Failed err -> + do return $ (Failed $ FailedToLoadDynamicInterface wanted_mod err) + + --((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err)) + + + + +read_file :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags + -> Module -> FilePath + -> IO (MaybeErr ReadInterfaceError (ModIface, FilePath)) +read_file hooks logger name_cache unit_state dflags wanted_mod file_path = do + + -- 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 hooks logger dflags name_cache wanted_mod' file_path + case read_result of + Failed err -> return (Failed err) + Succeeded iface -> return (Succeeded (iface, file_path)) + -- Don't forget to fill in the package name... + + +-- | Write interface file +writeIface :: Logger -> Profile -> CompressionIFace -> FilePath -> ModIface -> IO () +writeIface logger profile compression_level hi_file_path new_iface + = do createDirectoryIfMissing True (takeDirectory hi_file_path) + let printer = TraceBinIFace (debugTraceMsg logger 3) + writeBinIface profile printer compression_level hi_file_path new_iface + +flagsToIfCompression :: DynFlags -> CompressionIFace +flagsToIfCompression dflags + | n <= 1 = NormalCompression + | n == 2 = SafeExtraCompression + -- n >= 3 + | otherwise = MaximumCompression + where n = ifCompression dflags + +-- | @readIface@ tries just the one file. +-- +-- Failed err <=> file not found, or unreadable, or illegible +-- Succeeded iface <=> successfully found and parsed +readIface + :: Hooks + -> Logger + -> DynFlags + -> NameCache + -> Module + -> FilePath + -> IO (MaybeErr ReadInterfaceError ModIface) +readIface hooks logger dflags name_cache wanted_mod file_path = do + trace_if logger (text "readIFace" <+> text file_path) + 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 final_iface) + | otherwise -> return (Failed err) + where + final_iface + -- Check for GHC.Prim, and return its static interface + -- See Note [GHC.Prim] in primops.txt.pp. + | wanted_mod == gHC_PRIM = getGhcPrimIface hooks + | otherwise = iface + actual_mod = mi_module iface + err = HiModuleNameMismatchWarn file_path wanted_mod actual_mod + + Left exn -> return (Failed (ExceptionOccurred file_path exn)) + +{- +********************************************************* +* * + Wired-in interface for GHC.Prim +* * +********************************************************* +-} + +-- See Note [GHC.Prim] in primops.txt.pp. +ghcPrimIface :: ModIface +ghcPrimIface + = empty_iface + & set_mi_exports ghcPrimExports + & set_mi_decls [] + & set_mi_fixities ghcPrimFixities + & set_mi_fix_fn (mkIfaceFixCache ghcPrimFixities) + & set_mi_decl_warn_fn (mkIfaceDeclWarnCache ghcPrimWarns) + & set_mi_export_warn_fn (mkIfaceExportWarnCache ghcPrimWarns) + & set_mi_fix_fn (mkIfaceFixCache ghcPrimFixities) + & set_mi_docs (Just ghcPrimDeclDocs) -- See Note [GHC.Prim Docs] in GHC.Builtin.Utils + & set_mi_warns (toIfaceWarnings ghcPrimWarns) -- See Note [GHC.Prim Deprecations] in GHC.Builtin.Utils + + where + empty_iface = emptyFullModIface gHC_PRIM + +{- +********************************************************* +* * +\subsection{Statistics} +* * +********************************************************* +-} + +ifaceStats :: ExternalPackageState -> SDoc +ifaceStats eps + = hcat [text "Renamer stats: ", msg] + where + stats = eps_stats eps + msg = vcat + [int (n_ifaces_in stats) <+> text "interfaces read", + hsep [ int (n_decls_out stats), text "type/class/variable imported, out of", + int (n_decls_in stats), text "read"], + hsep [ int (n_insts_out stats), text "instance decls imported, out of", + int (n_insts_in stats), text "read"], + hsep [ int (n_rules_out stats), text "rule decls imported, out of", + int (n_rules_in stats), text "read"] + ] + +{- +************************************************************************ +* * + Printing interfaces +* * +************************************************************************ + +Note [Name qualification with --show-iface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In order to disambiguate between identifiers from different modules, we qualify +all names that don't originate in the current module. In order to keep visual +noise as low as possible, we keep local names unqualified. + +For some background on this choice see #15269. +-} + +-- | Read binary interface, and print it out +showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO () +showIface logger dflags unit_state name_cache filename = do + let profile = targetProfile dflags + printer = logMsg logger MCOutput noSrcSpan . withPprStyle defaultDumpStyle + + -- skip the hi way check; we don't want to worry about profiled vs. + -- non-profiled interfaces, for example. + iface <- readBinIface profile name_cache IgnoreHiWay (TraceBinIFace printer) filename + + let -- See Note [Name qualification with --show-iface] + qualifyImportedNames mod _user_qual _ + | mod == mi_module iface = NameUnqual + | otherwise = NameNotInScope1 + name_ppr_ctx = QueryQualify qualifyImportedNames + neverQualifyModules + neverQualifyPackages + alwaysPrintPromTick + logMsg logger MCDump noSrcSpan + $ withPprStyle (mkDumpStyle name_ppr_ctx) + $ pprModIface unit_state iface + +-- | Show a ModIface but don't display details; suitable for ModIfaces stored in +-- the EPT. +pprModIfaceSimple :: UnitState -> ModIface -> SDoc +pprModIfaceSimple unit_state iface = + ppr (mi_module iface) + $$ pprDeps unit_state (mi_deps iface) + $$ nest 2 (vcat (map pprExport (mi_exports iface))) + +-- | Show a ModIface +-- +-- The UnitState is used to pretty-print units +pprModIface :: UnitState -> ModIface -> SDoc +pprModIface unit_state iface + = vcat $ [ text "interface" + <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface) + <+> (withSelfRecomp iface empty $ \_ -> text "[self-recomp]") + <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty) + <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty) + <+> integer hiVersion + , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface)) + , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface)) + , nest 2 (text "export avails hash:" <+> ppr (mi_export_avails_hash iface)) + , nest 2 (text "orphan-like hash:" <+> ppr (mi_orphan_like_hash iface)) + , withSelfRecomp iface empty ppr + , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface)) + , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) + , nest 2 (text "where") + , text "exports:" + , nest 2 (vcat (map pprExport (mi_exports iface))) + , text "defaults:" + , nest 2 (vcat (map ppr (mi_defaults iface))) + , pprDeps unit_state (mi_deps iface) + , vcat (map pprIfaceAnnotation (mi_anns iface)) + , pprFixities (mi_fixities iface) + , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface] + , case mi_simplified_core iface of + Nothing -> empty + Just (IfaceSimplifiedCore eds fs) -> + vcat [ text "extra decls:" + $$ nest 2 (vcat ([ppr bs | bs <- eds])) + , text "foreign stubs:" + $$ nest 2 (ppr fs) + ] + , vcat (map ppr (mi_insts iface)) + , vcat (map ppr (mi_fam_insts iface)) + , vcat (map ppr (mi_rules iface)) + , ppr (mi_warns iface) + , pprTrustInfo (mi_trust iface) + , pprTrustPkg (mi_trust_pkg iface) + , vcat (map ppr (mi_complete_matches iface)) + , text "docs:" $$ nest 2 (ppr (mi_docs iface)) + , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface)) + ] + where + + pp_hsc_src HsBootFile = text "[boot]" + pp_hsc_src HsigFile = text "[hsig]" + pp_hsc_src HsSrcFile = Outputable.empty + + +{- +When printing export lists, we print like this: + Avail f f + AvailTC C [C, x, y] C(x,y) + AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C +-} + +pprExport :: IfaceExport -> SDoc +pprExport (Avail n) = ppr n +pprExport (AvailTC _ []) = Outputable.empty +pprExport avail@(AvailTC n _) = + ppr n <> mark <> pp_export (availSubordinateNames avail) + where + mark | availExportsDecl avail = Outputable.empty + | otherwise = vbar + + pp_export [] = Outputable.empty + pp_export names = braces (hsep (map ppr names)) + + +pprFixities :: [(OccName, Fixity)] -> SDoc +pprFixities [] = Outputable.empty +pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes + where + pprFix (occ,fix) = ppr fix <+> ppr occ + +pprTrustInfo :: IfaceTrustInfo -> SDoc +pprTrustInfo trust = text "trusted:" <+> ppr trust + +pprTrustPkg :: Bool -> SDoc +pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg + +pprIfaceAnnotation :: IfaceAnnotation -> SDoc +pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) + = ppr target <+> text "annotated by" <+> ppr serialized + +pprExtensibleFields :: ExtensibleFields -> SDoc +pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs + where + pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes" + + +-- | Reason for loading an interface file +-- +-- Used to figure out whether we want to consider loading hi-boot files or not. +data WhereFrom + = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) + | ImportBySystem -- Non user import. + | ImportByPlugin -- Importing a plugin. + +instance Outputable WhereFrom where + ppr (ImportByUser IsBoot) = text "{- SOURCE -}" + ppr (ImportByUser NotBoot) = empty + ppr ImportBySystem = text "{- SYSTEM -}" + ppr ImportByPlugin = text "{- PLUGIN -}" + + +-- | Get gHC_PRIM interface file +-- +-- This is a helper function that takes into account the hook allowing ghc-prim +-- interface to be extended via the ghc-api. Afaik it was introduced for GHCJS +-- so that it can add its own primitive types. +getGhcPrimIface :: Hooks -> ModIface +getGhcPrimIface hooks = + case ghcPrimIfaceHook hooks of + Nothing -> ghcPrimIface + Just h -> h diff --git a/GHC/Iface/Load.hs-boot b/GHC/Iface/Load.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Iface/Load.hs-boot @@ -0,0 +1,8 @@ +module GHC.Iface.Load where + +import GHC.Unit.Module (Module) +import GHC.Tc.Utils.Monad (IfM) +import GHC.Unit.Module.ModIface (ModIface) +import GHC.Utils.Outputable (SDoc) + +loadSysInterface :: SDoc -> Module -> IfM lcl ModIface diff --git a/GHC/Iface/Make.hs b/GHC/Iface/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Make.hs @@ -0,0 +1,568 @@ + +{-# LANGUAGE NondecreasingIndentation #-} + +{- +(c) The University of Glasgow 2006-2008 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +-- | Module for constructing @ModIface@ values (interface files), +-- writing them to disk and comparing two versions to see if +-- recompilation is required. +module GHC.Iface.Make + ( mkPartialIface + , mkFullIface + , mkIfaceTc + , mkRecompUsageInfo + , mkIfaceExports + ) +where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Stg.EnforceEpt.TagSig (StgCgInfos) +import GHC.StgToCmm.Types (CmmCgInfos (..)) + +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad + +import GHC.Iface.Warnings +import GHC.Iface.Decl +import GHC.Iface.Syntax +import GHC.Iface.Recomp +import GHC.Iface.Load +import GHC.Iface.Ext.Fields + +import GHC.CoreToIface + +import qualified GHC.LanguageExtensions as LangExt +import GHC.Core +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Core.Ppr +import GHC.Core.RoughMap ( RoughMatchTc(..) ) + +import GHC.Driver.Config.HsToCore.Usage +import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Driver.Plugins + +import GHC.Types.Id +import GHC.Types.Fixity.Env +import GHC.Types.ForeignStubs (ForeignStubs (NoStubs)) +import GHC.Types.SafeHaskell +import GHC.Types.Annotations +import GHC.Types.Name +import GHC.Types.Avail +import GHC.Types.Name.Reader +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.DefaultEnv ( ClassDefaults (..), DefaultEnv, defaultList ) +import GHC.Types.Unique.DSet +import GHC.Types.TypeEnv +import GHC.Types.SourceFile +import GHC.Types.TyThing +import GHC.Types.CompleteMatch +import GHC.Types.Name.Cache + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Logger +import GHC.Utils.Binary +import GHC.Iface.Binary + +import GHC.Data.FastString +import GHC.Data.Maybe + +import GHC.HsToCore.Docs +import GHC.HsToCore.Usage + +import GHC.Unit +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Deps +import GHC.Unit.Module.WholeCoreBindings (encodeIfaceForeign, emptyIfaceForeign) + +import Data.Function +import Data.List ( sortBy ) +import Data.Ord +import Data.IORef +import Data.Traversable + +{- +************************************************************************ +* * +\subsection{Completing an interface} +* * +************************************************************************ +-} + +mkPartialIface :: HscEnv + -> CoreProgram + -> ModDetails + -> ModSummary + -> [ImportUserSpec] + -> ModGuts + -> IO PartialModIface +mkPartialIface hsc_env core_prog mod_details mod_summary import_decls + ModGuts{ mg_module = this_mod + , mg_hsc_src = hsc_src + , mg_usages = usages + , mg_deps = deps + , mg_rdr_env = rdr_env + , mg_fix_env = fix_env + , mg_warns = warns + , mg_safe_haskell = safe_mode + , mg_trust_pkg = self_trust + , mg_docs = docs + } + = do + self_recomp <- traverse (mkSelfRecomp hsc_env this_mod (ms_hs_hash mod_summary)) usages + return $ mkIface_ hsc_env this_mod core_prog hsc_src deps rdr_env import_decls fix_env warns self_trust + safe_mode self_recomp docs mod_details + +-- | Fully instantiate an interface. Adds fingerprints and potentially code +-- generator produced information. +-- +-- CmmCgInfos is not available when not generating code (-fno-code), or when not +-- generating interface pragmas (-fomit-interface-pragmas). See also +-- Note [Conveying CAF-info and LFInfo between modules] in GHC.StgToCmm.Types. +mkFullIface :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> ForeignStubs -> [(ForeignSrcLang, FilePath)] -> IO ModIface +mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos stubs foreign_files = do + let decls + | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env) + = mi_decls partial_iface + | otherwise + = updateDecl (mi_decls partial_iface) mb_stg_infos mb_cmm_infos + + -- See Note [Foreign stubs and TH bytecode linking] + mi_simplified_core <- for (mi_simplified_core partial_iface) $ \simpl_core -> do + fs <- encodeIfaceForeign (hsc_logger hsc_env) (hsc_dflags hsc_env) stubs foreign_files + return $ (simpl_core { mi_sc_foreign = fs }) + + full_iface <- + {-# SCC "addFingerprints" #-} + addFingerprints hsc_env $ set_mi_simplified_core mi_simplified_core $ set_mi_decls decls partial_iface + + -- Debug printing + let unit_state = hsc_units hsc_env + putDumpFileMaybe (hsc_logger hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText + (pprModIface unit_state full_iface) + final_iface <- shareIface (hsc_NC hsc_env) (flagsToIfCompression $ hsc_dflags hsc_env) full_iface + return final_iface + +-- | Compress an 'ModIface' and share as many values as possible, depending on the 'CompressionIFace' level. +-- See Note [Sharing of ModIface]. +-- +-- We compress the 'ModIface' by serialising the 'ModIface' to an in-memory byte array, and then deserialising it. +-- The deserialisation will deduplicate certain values depending on the 'CompressionIFace' level. +-- See Note [Deduplication during iface binary serialisation] for how we do that. +-- +-- Additionally, we cache the serialised byte array, so if the 'ModIface' is not modified +-- after calling 'shareIface', 'writeBinIface' will reuse that buffer without serialising the 'ModIface' again. +-- Modifying the 'ModIface' forces us to re-serialise it again. +shareIface :: NameCache -> CompressionIFace -> ModIface -> IO ModIface +shareIface _ NormalCompression mi = do + -- In 'NormalCompression', the sharing isn't reducing the memory usage, as 'Name's and 'FastString's are + -- already shared, and at this compression level, we don't compress/share anything else. + -- Thus, for a brief moment we simply double the memory residency for no reason. + -- Therefore, we only try to share expensive values if the compression mode is higher than + -- 'NormalCompression' + pure mi +shareIface nc compressionLevel mi = do + bh <- openBinMem initBinMemSize + start <- tellBinWriter bh + putIfaceWithExtFields QuietBinIFace compressionLevel bh mi + rbh <- shrinkBinBuffer bh + seekBinReader rbh start + res <- getIfaceWithExtFields nc rbh + forceModIface res + return res + +-- | Initial ram buffer to allocate for writing interface files. +initBinMemSize :: Int +initBinMemSize = 1024 * 1024 -- 1 MB + +updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Maybe CmmCgInfos -> [IfaceDecl] +updateDecl decls Nothing Nothing = decls +updateDecl decls m_stg_infos m_cmm_infos + = map update_decl decls + where + (non_cafs,lf_infos) = maybe (mempty, mempty) + (\cmm_info -> (ncs_nameSet (cgNonCafs cmm_info), cgLFInfos cmm_info)) + m_cmm_infos + tag_sigs = fromMaybe mempty m_stg_infos + + update_decl (IfaceId nm ty details infos) + | let not_caffy = elemNameSet nm non_cafs + , let mb_lf_info = lookupNameEnv lf_infos nm + , let sig = lookupNameEnv tag_sigs nm + , warnPprTrace (isNothing mb_lf_info) "updateDecl" (text "Name without LFInfo:" <+> ppr nm) True + -- Only allocate a new IfaceId if we're going to update the infos + , isJust mb_lf_info || not_caffy || isJust sig + = IfaceId nm ty details $ + (if not_caffy then (HsNoCafRefs :) else id) $ + (if isJust sig then (HsTagSig (fromJust sig):) else id) $ + (case mb_lf_info of + Nothing -> infos -- LFInfos not available when building .cmm files + Just lf_info -> HsLFInfo (toIfaceLFInfo nm lf_info) : infos) + + update_decl decl + = decl + + + + +-- | Make an interface from the results of typechecking only. Useful +-- for non-optimising compilation, or where we aren't generating any +-- object code at all ('NoBackend'). +mkIfaceTc :: HscEnv + -> SafeHaskellMode -- The safe haskell mode + -> ModDetails -- gotten from mkBootModDetails, probably + -> ModSummary + -> Maybe CoreProgram + -> TcGblEnv -- Usages, deprecations, etc + -> IO ModIface +mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program + tc_result@TcGblEnv{ tcg_mod = this_mod, + tcg_src = hsc_src, + tcg_imports = imports, + tcg_import_decls = import_decls, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_warns = warns + } + = do + let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env)) + let home_unit = hsc_home_unit hsc_env + let deps = mkDependencies home_unit + (tcg_mod tc_result) + (tcg_imports tc_result) + (map mi_module pluginModules) + + usage <- mkRecompUsageInfo hsc_env tc_result + docs <- extractDocs (ms_hspp_opts mod_summary) tc_result + self_recomp <- traverse (mkSelfRecomp hsc_env this_mod (ms_hs_hash mod_summary)) usage + + let partial_iface = mkIface_ hsc_env + this_mod (fromMaybe [] mb_program) hsc_src + deps rdr_env import_decls + fix_env warns + (imp_trust_own_pkg imports) safe_mode self_recomp + docs + mod_details + + mkFullIface hsc_env partial_iface Nothing Nothing NoStubs [] + +mkRecompUsageInfo :: HscEnv -> TcGblEnv -> IO (Maybe [Usage]) +mkRecompUsageInfo hsc_env tc_result = do + let dflags = hsc_dflags hsc_env + if not (gopt Opt_WriteSelfRecompInfo dflags) + then return Nothing + else do + let used_names = mkUsedNames tc_result + dep_files <- (readIORef (tcg_dependent_files tc_result)) + (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result) + let uc = initUsageConfig hsc_env + plugins = hsc_plugins hsc_env + fc = hsc_FC hsc_env + unit_env = hsc_unit_env hsc_env + + -- Do NOT use semantic module here; this_mod in mkUsageInfo + -- is used solely to decide if we should record a dependency + -- or not. When we instantiate a signature, the semantic + -- module is something we want to record dependencies for, + -- but if you pass that in here, we'll decide it's the local + -- module and does not need to be recorded as a dependency. + -- See Note [Identity versus semantic module] + usages <- initIfaceLoad hsc_env $ + mkUsageInfo uc plugins fc unit_env + (tcg_mod tc_result) + (imp_mods (tcg_imports tc_result)) + (tcg_import_decls tc_result) + used_names + dep_files + (tcg_merged tc_result) + needed_links + needed_pkgs + return (Just usages) + +mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource + -> Dependencies -> GlobalRdrEnv -> [ImportUserSpec] + -> NameEnv FixItem -> Warnings GhcRn + -> Bool + -> SafeHaskellMode + -> Maybe IfaceSelfRecomp + -> Maybe Docs + -> ModDetails + -> PartialModIface +mkIface_ hsc_env + this_mod core_prog hsc_src deps rdr_env import_decls fix_env src_warns + pkg_trust_req safe_mode self_recomp + docs + ModDetails{ md_defaults = defaults, + md_insts = insts, + md_fam_insts = fam_insts, + md_rules = rules, + md_anns = anns, + md_types = type_env, + md_exports = exports, + md_complete_matches = complete_matches } +-- NB: notice that mkIface does not look at the bindings +-- only at the TypeEnv. The previous Tidy phase has +-- put exactly the info into the TypeEnv that we want +-- to expose in the interface + + = do + let home_unit = hsc_home_unit hsc_env + semantic_mod = homeModuleNameInstantiation home_unit (moduleName this_mod) + entities = typeEnvElts type_env + show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env) + + simplified_core = if gopt Opt_WriteIfSimplifiedCore dflags then Just (IfaceSimplifiedCore [ toIfaceTopBind b | b <- core_prog ] emptyIfaceForeign) + else Nothing + decls = [ tyThingToIfaceDecl show_linear_types entity + | entity <- entities, + let name = getName entity, + not (isImplicitTyThing entity), + -- No implicit Ids and class tycons in the interface file + not (isWiredInName name), + -- Nor wired-in things; the compiler knows about them anyhow + nameIsLocalOrFrom semantic_mod name ] + -- Sigh: see Note [Root-main Id] in GHC.Tc.Module + -- NB: ABSOLUTELY need to check against semantic_mod, + -- because all of the names in an hsig p[H=]:H + -- are going to be for , not the former id! + -- See Note [Identity versus semantic module] + + fixities = sortBy (comparing fst) + [(occ,fix) | FixItem occ fix <- nonDetNameEnvElts fix_env] + -- The order of fixities returned from nonDetNameEnvElts is not + -- deterministic, so we sort by OccName to canonicalize it. + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details. + warns = toIfaceWarnings src_warns + iface_rules = map coreRuleToIfaceRule rules + iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode (instEnvElts insts) + iface_fam_insts = map famInstToIfaceFamInst fam_insts + trust_info = setSafeMode safe_mode + annotations = map mkIfaceAnnotation anns + icomplete_matches = map mkIfaceCompleteMatch complete_matches + !rdrs = mkIfaceTopEnv rdr_env + + emptyPartialModIface this_mod + -- Need to record this because it depends on the -instantiated-with flag + -- which could change + & set_mi_sig_of (if semantic_mod == this_mod + then Nothing + else Just semantic_mod) + & set_mi_hsc_src hsc_src + & set_mi_self_recomp self_recomp + & set_mi_deps deps + & set_mi_exports (mkIfaceExports exports) + + & set_mi_defaults (defaultsToIfaceDefaults defaults) + + -- Sort these lexicographically, so that + -- the result is stable across compilations + & set_mi_insts (sortBy cmp_inst iface_insts) + & set_mi_fam_insts (sortBy cmp_fam_inst iface_fam_insts) + & set_mi_rules (sortBy cmp_rule iface_rules) + + & set_mi_fixities fixities + & set_mi_warns warns + & set_mi_anns annotations + & set_mi_top_env rdrs + & set_mi_decls decls + & set_mi_simplified_core simplified_core + & set_mi_trust trust_info + & set_mi_trust_pkg pkg_trust_req + & set_mi_complete_matches (icomplete_matches) + & set_mi_docs docs + & set_mi_abi_hashes () + & set_mi_ext_fields emptyExtensibleFields + & set_mi_hi_bytes PartialIfaceBinHandle + + where + cmp_rule = lexicalCompareFS `on` ifRuleName + -- Compare these lexicographically by OccName, *not* by unique, + -- because the latter is not stable across compilations: + cmp_inst = comparing (nameOccName . ifDFun) + cmp_fam_inst = comparing (nameOccName . ifFamInstTcName) + + dflags = hsc_dflags hsc_env + + -- We only fill in mi_top_env if the module was compiled to byte + -- code. Otherwise, the compiler may not have retained all the + -- top-level bindings and they won't be in the TypeEnv (see + -- Desugar.addExportFlagsAndRules). The mi_top_env field is used + -- by GHCi to decide whether the module has its full top-level + -- scope available. (#5534) + mkIfaceTopEnv :: GlobalRdrEnv -> IfaceTopEnv + mkIfaceTopEnv rdr_env + = let !exports = sortAvails $ gresToAvailInfo $ globalRdrEnvElts $ globalRdrEnvLocal rdr_env + !imports = mkIfaceImports import_decls + in IfaceTopEnv exports imports + + ifFamInstTcName = ifFamInstFam + +-------------------------- +defaultsToIfaceDefaults :: DefaultEnv -> [IfaceDefault] +defaultsToIfaceDefaults = map toIface . defaultList + where + toIface ClassDefaults { cd_class = cls + , cd_types = tys + , cd_warn = warn } + = IfaceDefault { ifDefaultCls = className cls + , ifDefaultTys = map toIfaceType tys + , ifDefaultWarn = fmap toIfaceWarningTxt warn } + +-------------------------- +instanceToIfaceInst :: ClsInst -> IfaceClsInst +instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag + , is_cls_nm = cls_name, is_cls = cls + , is_tcs = rough_tcs + , is_orphan = orph + , is_warn = warn }) + = assert (cls_name == className cls) $ + IfaceClsInst { ifDFun = idName dfun_id + , ifOFlag = oflag + , ifInstCls = cls_name + , ifInstTys = ifaceRoughMatchTcs $ tail rough_tcs + -- N.B. Drop the class name from the rough match template + -- It is put back by GHC.Core.InstEnv.mkImportedClsInst + , ifInstOrph = orph + , ifInstWarn = fmap toIfaceWarningTxt warn } + +-------------------------- +famInstToIfaceFamInst :: FamInst -> IfaceFamInst +famInstToIfaceFamInst (FamInst { fi_axiom = axiom + , fi_fam = fam + , fi_tcs = rough_tcs + , fi_orphan = orphan }) + = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom + , ifFamInstFam = fam + , ifFamInstTys = ifaceRoughMatchTcs rough_tcs + , ifFamInstOrph = orphan } + +ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon] +ifaceRoughMatchTcs tcs = map do_rough tcs + where + do_rough RM_WildCard = Nothing + do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n) + +-------------------------- +coreRuleToIfaceRule :: CoreRule -> IfaceRule +-- A plugin that installs a BuiltinRule in a CoreDoPluginPass should +-- ensure that there's another CoreDoPluginPass that removes the rule. +-- Otherwise a module using the plugin and compiled with -fno-omit-interface-pragmas +-- would cause panic when the rule is attempted to be written to the interface file. +coreRuleToIfaceRule rule@(BuiltinRule {}) + = pprPanic "toHsRule:" (pprRule rule) + +coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, + ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs, + ru_orphan = orph, ru_auto = auto }) + = IfaceRule { ifRuleName = name, ifActivation = act, + ifRuleBndrs = map toIfaceBndr bndrs, + ifRuleHead = fn, + ifRuleArgs = map do_arg args, + ifRuleRhs = toIfaceExpr rhs, + ifRuleAuto = auto, + ifRuleOrph = orph } + where + -- For type args we must remove synonyms from the outermost + -- level. Reason: so that when we read it back in we'll + -- construct the same ru_rough field as we have right now; + -- see tcIfaceRule + do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) + do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) + do_arg arg = toIfaceExpr arg + + +{- +************************************************************************ +* * + COMPLETE Pragmas +* * +************************************************************************ +-} + +mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch +mkIfaceCompleteMatch (CompleteMatch cls mtc) = + -- NB: Sorting here means that COMPLETE {P, Q} and COMPLETE {Q, P} are + -- considered identical, in particular for recompilation checking. + IfaceCompleteMatch (sortBy stableNameCmp $ uniqDSetToList cls) mtc + + +{- +************************************************************************ +* * + Keeping track of what we've slurped, and fingerprints +* * +************************************************************************ +-} + + +mkIfaceAnnotation :: Annotation -> IfaceAnnotation +mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload }) + = IfaceAnnotation { + ifAnnotatedTarget = fmap nameOccName target, + ifAnnotatedValue = payload + } + +mkIfaceImports :: [ImportUserSpec] -> [IfaceImport] +mkIfaceImports = map go + where + go (ImpUserSpec decl ImpUserAll) + = IfaceImport decl ImpIfaceAll + go (ImpUserSpec decl (ImpUserExplicit env parents_of_implicits)) + = IfaceImport decl (ImpIfaceExplicit (sortAvails env) (nameSetElemsStable parents_of_implicits)) + go (ImpUserSpec decl (ImpUserEverythingBut ns)) + = IfaceImport decl (ImpIfaceEverythingBut (nameSetElemsStable ns)) + +mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical +mkIfaceExports as = case sortAvails as of DefinitelyDeterministicAvails sas -> sas + +{- +Note [Original module] +~~~~~~~~~~~~~~~~~~~~~ +Consider this: + module X where { data family T } + module Y( T(..) ) where { import X; data instance T Int = MkT Int } +The exported Avail from Y will look like + X.T{X.T, Y.MkT} +That is, in Y, + - only MkT is brought into scope by the data instance; + - but the parent (used for grouping and naming in T(..) exports) is X.T + - and in this case we export X.T too + +In the result of mkIfaceExports, the names are grouped by defining module, +so we may need to split up a single Avail into multiple ones. +-} + +{- +Note [Sharing of ModIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A 'ModIface' contains many duplicated values such as 'Name', 'FastString' and 'IfaceType'. +'Name's and 'FastString's are already deduplicated by default using the 'NameCache' and +'FastStringTable' respectively. +However, 'IfaceType' can be quite expensive in terms of memory usage. +To improve the sharing of 'IfaceType', we introduced deduplication tables during +serialisation of 'ModIface', see Note [Deduplication during iface binary serialisation]. + +We can improve the sharing of 'ModIface' at run-time as well, by serialising the 'ModIface' to +an in-memory buffer, and then deserialising it again. +This implicitly shares duplicated values. + +To avoid re-serialising the 'ModIface' when writing it to disk, we save the serialised 'ModIface' buffer +in 'mi_hi_bytes_' field of said 'ModIface'. This buffer is written to disk directly in 'putIfaceWithExtFields'. +If we have to modify the 'ModIface' after 'shareIface' is called, the buffer needs to be discarded. +-} diff --git a/GHC/Iface/Recomp.hs b/GHC/Iface/Recomp.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Recomp.hs @@ -0,0 +1,2004 @@ +{-# 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 + , mkSelfRecomp + ) +where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Driver.Backend +import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Driver.Ppr +import GHC.Driver.Plugins + + +import GHC.Iface.Syntax +import GHC.Iface.Recomp.Binary +import GHC.Iface.Recomp.Types +import GHC.Iface.Load +import GHC.Iface.Recomp.Flags +import GHC.Iface.Env + +import GHC.Core +import GHC.Tc.Utils.Monad +import GHC.Hs + +import GHC.Data.Graph.Directed +import GHC.Data.Maybe + +import GHC.Utils.Error +import GHC.Utils.Panic +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Misc as Utils +import GHC.Utils.Binary +import GHC.Utils.Fingerprint +import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Constants (debugIsOn) + +import GHC.Types.Annotations +import GHC.Types.Avail +import GHC.Types.Basic ( ImportLevel(..) ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.SrcLoc +import GHC.Types.Unique.Set +import GHC.Types.Fixity.Env +import GHC.Types.Unique.Map +import GHC.Unit.External +import GHC.Unit.Finder +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.Deps + +import Control.Monad +import Control.Monad.Trans.State +import Data.List (sortBy, sort, sortOn) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Word (Word64) +import Data.Either + +--Qualified import so we can define a Semigroup instance +-- but it doesn't clash with Outputable.<> +import qualified Data.Semigroup +import GHC.List (uncons) +import Data.Ord +import Data.Containers.ListUtils +import GHC.Iface.Errors.Ppr +import Data.Functor +import Data.Bifunctor (first) +import GHC.Types.PkgQual + +{- + ----------------------------------------------- + Recompilation checking + ----------------------------------------------- + +A complete description of how recompilation checking works can be +found in the wiki commentary: + + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance + +Please read the above page for a top-down description of how this all +works. Notes below cover specific issues related to the implementation. + +Basic idea: + + * In the mi_usages information in an interface, we record the + fingerprint of each free variable of the module + + * In mkIface, we compute the fingerprint of each exported thing A.f. + For each external thing that A.f refers to, we include the fingerprint + of the external reference when computing the fingerprint of A.f. So + if anything that A.f depends on changes, then A.f's fingerprint will + change. + Also record any dependent files added with + * addDependentFile + * #include + * -optP-include + + * In checkOldIface we compare the mi_usages for the module with + the actual fingerprint for all each thing recorded in mi_usages +-} + +data RecompileRequired + -- | everything is up to date, recompilation is not required + = UpToDate + -- | Need to compile the module + | NeedsRecompile !CompileReason + deriving (Eq) + +needsRecompileBecause :: RecompReason -> RecompileRequired +needsRecompileBecause = NeedsRecompile . RecompBecause + +data MaybeValidated a + -- | The item contained is validated to be up to date + = UpToDateItem a + -- | The item is are absent altogether or out of date, for the reason given. + | OutOfDateItem + !CompileReason + -- ^ the reason we need to recompile. + (Maybe a) + -- ^ The old item, if it exists + deriving (Functor) + +instance Outputable a => Outputable (MaybeValidated a) where + ppr (UpToDateItem a) = text "UpToDate" <+> ppr a + ppr (OutOfDateItem r _) = text "OutOfDate: " <+> ppr r + +outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a +outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item + +data CompileReason + -- | The .hs file has been touched, or the .o/.hi file does not exist + = MustCompile + -- | The .o/.hi files are up to date, but something else has changed + -- to force recompilation; the String says what (one-line summary) + | RecompBecause !RecompReason + deriving (Eq) + +instance Outputable RecompileRequired where + ppr UpToDate = text "UpToDate" + ppr (NeedsRecompile reason) = ppr reason + +instance Outputable CompileReason where + ppr MustCompile = text "MustCompile" + ppr (RecompBecause r) = text "RecompBecause" <+> ppr r + +instance Semigroup RecompileRequired where + UpToDate <> r = r + mc <> _ = mc + +instance Monoid RecompileRequired where + mempty = UpToDate + +data RecompReason + = UnitDepRemoved (ImportLevel, UnitId) + | ModulePackageChanged FastString + | SourceFileChanged + | NoSelfRecompInfo + | ThisUnitIdChanged + | ImpurePlugin + | PluginsChanged + | PluginFingerprintChanged + | ModuleInstChanged + | HieMissing + | HieOutdated + | SigsMergeChanged + | ModuleChanged ModuleName + | ModuleRemoved (ImportLevel, UnitId, ModuleName) + | ModuleAdded (ImportLevel, UnitId, ModuleName) + | ModuleChangedRaw ModuleName + | ModuleChangedIface ModuleName + | FileChanged FilePath + | CustomReason String + | FlagsChanged + | LinkFlagsChanged + | OptimFlagsChanged + | HpcFlagsChanged + | MissingBytecode + | MissingObjectFile + | MissingDynObjectFile + | MissingDynHiFile + | MismatchedDynHiFile + | ObjectsChanged + | LibraryChanged + | THWithJS + deriving (Eq) + + +instance Outputable RecompReason where + ppr = \case + UnitDepRemoved (_lvl, uid) -> ppr uid <+> text "removed" + ModulePackageChanged s -> ftext s <+> text "package changed" + SourceFileChanged -> text "Source file changed" + NoSelfRecompInfo -> text "Old interface lacks recompilation info" + 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 (_st, _uid, m) -> ppr m <+> text "removed" + ModuleAdded (_st, _uid, m) -> ppr m <+> text "added" + FileChanged fp -> text fp <+> text "changed" + CustomReason s -> text s + FlagsChanged -> text "Flags changed" + LinkFlagsChanged -> 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" + THWithJS -> text "JS backend always recompiles modules using Template Haskell for now (#23013)" + +recompileRequired :: RecompileRequired -> Bool +recompileRequired UpToDate = False +recompileRequired _ = True + +recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired +recompThen ma mb = ma >>= \case + UpToDate -> mb + rr@(NeedsRecompile _) -> pure rr + +checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired +checkList = \case + [] -> return UpToDate + (check : checks) -> check `recompThen` checkList checks + +---------------------- + +-- | Top level function to check if the version of an old interface file +-- is equivalent to the current source file the user asked us to compile. +-- If the same, we can avoid recompilation. +-- +-- We return on the outside whether the interface file is up to date, providing +-- evidence that is with a `ModIface`. In the case that it isn't, we may also +-- return a found or provided `ModIface`. Why we don't always return the old +-- one, if it exists, is unclear to me, except that I tried it and some tests +-- failed (see #18205). +checkOldIface + :: HscEnv + -> ModSummary + -> Maybe ModIface -- Old interface from compilation manager, if any + -> IO (MaybeValidated ModIface) + +checkOldIface hsc_env mod_summary maybe_iface + = do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + showPass logger $ + "Checking old interface for " ++ + (showPpr dflags $ ms_mod mod_summary) ++ + " (use -ddump-hi-diffs for more details)" + initIfaceCheck (text "checkOldIface") hsc_env $ + check_old_iface hsc_env mod_summary maybe_iface + +check_old_iface + :: HscEnv + -> ModSummary + -> Maybe ModIface + -> IfG (MaybeValidated ModIface) + +check_old_iface hsc_env mod_summary maybe_iface + = let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + getIface = + case maybe_iface of + Just {} -> do + trace_if logger (text "We already have the old interface for" <+> + ppr (ms_mod mod_summary)) + return maybe_iface + Nothing -> loadIface dflags (msHiFilePath mod_summary) + + loadIface read_dflags iface_path = do + let ncu = hsc_NC hsc_env + read_result <- readIface (hsc_hooks hsc_env) logger read_dflags ncu (ms_mod mod_summary) iface_path + case read_result of + Failed err -> do + let msg = readInterfaceErrorDiagnostic err + trace_if logger + $ vcat [ text "FYI: cannot read old interface file:" + , nest 4 msg ] + trace_hi_diffs logger $ + vcat [ text "Old interface file was invalid:" + , nest 4 msg ] + return Nothing + Succeeded iface -> do + trace_if logger (text "Read the interface file" <+> text iface_path) + return $ Just iface + check_dyn_hi :: ModIface + -> IfG (MaybeValidated ModIface) + -> IfG (MaybeValidated ModIface) + check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do + res <- recomp_check + case res of + UpToDateItem _ -> do + maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary) + case maybe_dyn_iface of + Nothing -> return $ outOfDateItemBecause MissingDynHiFile Nothing + Just dyn_iface | mi_iface_hash dyn_iface + /= mi_iface_hash normal_iface + -> return $ outOfDateItemBecause MismatchedDynHiFile Nothing + Just {} -> return res + _ -> return res + check_dyn_hi _ recomp_check = recomp_check + + + src_changed + | gopt Opt_ForceRecomp dflags = True + | otherwise = False + in do + when src_changed $ + liftIO $ trace_hi_diffs logger (nest 4 $ text "Recompilation check turned off") + + case src_changed of + -- If the source has changed and we're in interactive mode, + -- avoid reading an interface; just return the one we might + -- have been supplied with. + True | not (backendWritesFiles $ backend dflags) -> + return $ OutOfDateItem MustCompile maybe_iface + + -- Try and read the old interface for the current module + -- from the .hi file left from the last time we compiled it + True -> do + maybe_iface' <- liftIO $ getIface + return $ OutOfDateItem MustCompile maybe_iface' + + False -> do + maybe_iface' <- liftIO $ getIface + case maybe_iface' of + -- We can't retrieve the iface + Nothing -> return $ OutOfDateItem MustCompile Nothing + + -- We have got the old iface; check its versions + -- even in the SourceUnmodifiedAndStable case we + -- should check versions because some packages + -- might have changed or gone away. + Just iface -> + case mi_self_recomp_info iface of + Nothing -> return $ outOfDateItemBecause NoSelfRecompInfo Nothing + Just sr_info -> check_dyn_hi iface $ checkVersions hsc_env mod_summary iface sr_info + +-- | Check if a module is still the same 'version'. +-- +-- This function is called in the recompilation checker after we have +-- determined that the module M being checked hasn't had any changes +-- to its source file since we last compiled M. So at this point in general +-- two things may have changed that mean we should recompile M: +-- * The interface export by a dependency of M has changed. +-- * The compiler flags specified this time for M have changed +-- in a manner that is significant for recompilation. +-- We return not just if we should recompile the object file but also +-- if we should rebuild the interface file. +checkVersions :: HscEnv + -> ModSummary + -> ModIface -- Old interface + -> IfaceSelfRecomp + -> IfG (MaybeValidated ModIface) +checkVersions hsc_env mod_summary iface self_recomp + = 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_sr_src_hash self_recomp /= ms_hs_hash mod_summary + then return $ outOfDateItemBecause SourceFileChanged Nothing else do { + ; if not (isHomeModule home_unit (mi_module iface)) + then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do { + ; recomp <- liftIO $ checkFlagHash hsc_env (mi_module iface) self_recomp + `recompThen` checkOptimHash hsc_env self_recomp + `recompThen` checkHpcHash hsc_env self_recomp + `recompThen` checkMergedSignatures hsc_env mod_summary self_recomp + `recompThen` checkHsig logger home_unit mod_summary iface + `recompThen` pure (checkHie dflags mod_summary) + ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do { + ; recomp <- checkDependencies hsc_env mod_summary iface + ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do { + ; recomp <- checkPlugins (hsc_plugins hsc_env) self_recomp + ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do { + + -- Source code unchanged and no errors yet... carry on + -- + -- First put the dependent-module info, read from the old + -- interface, into the envt, so that when we look for + -- interfaces we look for the right one (.hi or .hi-boot) + -- + -- It's just temporary because either the usage check will succeed + -- (in which case we are done with this module) or it'll fail (in which + -- case we'll compile the module from scratch anyhow). + + when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do { + ; updateEps_ $ \eps -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) } + } + ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) u + | u <- mi_sr_usages self_recomp] + ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do { + ; return $ UpToDateItem iface + }}}}}}} + where + logger = hsc_logger hsc_env + dflags = hsc_dflags hsc_env + home_unit = hsc_home_unit hsc_env + + + +-- | Check if any plugins are requesting recompilation +checkPlugins :: Plugins -> IfaceSelfRecomp -> IfG RecompileRequired +checkPlugins plugins self_recomp = liftIO $ do + recomp <- recompPlugins plugins + let new_fingerprint = fingerprintPluginRecompile recomp + let old_fingerprint = mi_sr_plugin_hash self_recomp + return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp + +recompPlugins :: Plugins -> IO PluginRecompile +recompPlugins plugins = mconcat <$> mapM pluginRecompile' (pluginsWithArgs plugins) + +fingerprintPlugins :: Plugins -> IO Fingerprint +fingerprintPlugins plugins = fingerprintPluginRecompile <$> recompPlugins plugins + +fingerprintPluginRecompile :: PluginRecompile -> Fingerprint +fingerprintPluginRecompile recomp = case recomp of + NoForceRecompile -> fingerprintString "NoForceRecompile" + ForceRecompile -> fingerprintString "ForceRecompile" + -- is the chance of collision worth worrying about? + -- An alternative is to fingerprintFingerprints [fingerprintString + -- "maybeRecompile", fp] + MaybeRecompile fp -> fp + + +pluginRecompileToRecompileRequired + :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired +pluginRecompileToRecompileRequired old_fp new_fp pr + | old_fp == new_fp = + case pr of + NoForceRecompile -> UpToDate + + -- we already checked the fingerprint above so a mismatch is not possible + -- here, remember that: `fingerprint (MaybeRecomp x) == x`. + MaybeRecompile _ -> UpToDate + + -- when we have an impure plugin in the stack we have to unconditionally + -- recompile since it might integrate all sorts of crazy IO results into + -- its compilation output. + ForceRecompile -> needsRecompileBecause ImpurePlugin + + | old_fp `elem` magic_fingerprints || + new_fp `elem` magic_fingerprints + -- The fingerprints do not match either the old or new one is a magic + -- fingerprint. This happens when non-pure plugins are added for the first + -- time or when we go from one recompilation strategy to another: (force -> + -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.) + -- + -- For example when we go from ForceRecomp to NoForceRecomp + -- recompilation is triggered since the old impure plugins could have + -- changed the build output which is now back to normal. + = needsRecompileBecause PluginsChanged + + | otherwise = + case pr of + -- even though a plugin is forcing recompilation the fingerprint changed + -- which would cause recompilation anyways so we report the fingerprint + -- change instead. + ForceRecompile -> needsRecompileBecause PluginFingerprintChanged + + _ -> needsRecompileBecause PluginFingerprintChanged + + where + magic_fingerprints = + [ fingerprintString "NoForceRecompile" + , fingerprintString "ForceRecompile" + ] + + +-- | Check if an hsig file needs recompilation because its +-- implementing module has changed. +checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired +checkHsig logger home_unit mod_summary iface = do + let outer_mod = ms_mod mod_summary + inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod) + massert (isHomeModule home_unit outer_mod) + case inner_mod == mi_semantic_module iface of + True -> up_to_date logger (text "implementing module unchanged") + False -> return $ needsRecompileBecause ModuleInstChanged + +-- | Check if @.hie@ file is out of date or missing. +checkHie :: DynFlags -> ModSummary -> RecompileRequired +checkHie dflags mod_summary = + let hie_date_opt = ms_hie_date mod_summary + hi_date = ms_iface_date mod_summary + in if not (gopt Opt_WriteHie dflags) + then UpToDate + else case (hie_date_opt, hi_date) of + (Nothing, _) -> needsRecompileBecause HieMissing + (Just hie_date, Just hi_date) + | hie_date < hi_date + -> needsRecompileBecause HieOutdated + _ -> UpToDate + +-- | Check the flags haven't changed +checkFlagHash :: HscEnv -> Module -> IfaceSelfRecomp -> IO RecompileRequired +checkFlagHash hsc_env iface_mod self_recomp = do + let logger = hsc_logger hsc_env + let FingerprintWithValue old_fp old_flags = mi_sr_flag_hash self_recomp + let (new_fp, new_flags) = fingerprintDynFlags hsc_env iface_mod putNameLiterally + if old_fp == new_fp + then up_to_date logger (text "Module flags unchanged") + else do + -- Do not perform this computation unless -ddump-hi-diffs is on + let diffs = case old_flags of + Nothing -> pure [missingExtraFlagInfo] + Just old_flags -> checkIfaceFlags old_flags new_flags + out_of_date logger FlagsChanged (fmap vcat diffs) + + +checkIfaceFlags :: IfaceDynFlags -> IfaceDynFlags -> IO [SDoc] +checkIfaceFlags (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) + (IfaceDynFlags b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14) = + flip execStateT [] $ do + check_one "main is" (ppr . fmap (fmap (text @SDoc))) a1 b1 + check_one_simple "safemode" a2 b2 + check_one_simple "lang" a3 b3 + check_one_simple "exts" a4 b4 + check_one_simple "cpp option" a5 b5 + check_one_simple "js option" a6 b6 + check_one_simple "cmm option" a7 b7 + check_one "paths" (ppr . map (text @SDoc)) a8 b8 + check_one_simple "prof" a9 b9 + check_one_simple "ticky" a10 b10 + check_one_simple "codegen" a11 b11 + check_one_simple "fat iface" a12 b12 + check_one_simple "debug level" a13 b13 + check_one_simple "caller cc filter" a14 b14 + where + diffSimple p a b = vcat [text "before:" <+> p a + , text "after:" <+> p b ] + + check_one_simple s a b = check_one s ppr a b + + check_one s p a b = do + let a' = computeFingerprint putNameLiterally a + let b' = computeFingerprint putNameLiterally b + if a' == b' then pure () else modify (([ text s <+> text "flags changed"] ++ [diffSimple p a b]) ++) + +-- | Check the optimisation flags haven't changed +checkOptimHash :: HscEnv -> IfaceSelfRecomp -> IO RecompileRequired +checkOptimHash hsc_env iface = do + let logger = hsc_logger hsc_env + let old_hash = mi_sr_opt_hash iface + let !new_hash = fingerprintOptFlags (hsc_dflags hsc_env) + putNameLiterally + if | old_hash == new_hash + -> up_to_date logger (text "Optimisation flags unchanged") + | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env) + -> up_to_date logger (text "Optimisation flags changed; ignoring") + | otherwise + -> out_of_date_hash logger OptimFlagsChanged + (text " Optimisation flags have changed") + old_hash new_hash + +-- | Check the HPC flags haven't changed +checkHpcHash :: HscEnv -> IfaceSelfRecomp -> IO RecompileRequired +checkHpcHash hsc_env self_recomp = do + let logger = hsc_logger hsc_env + let old_hash = mi_sr_hpc_hash self_recomp + let !new_hash = fingerprintHpcFlags (hsc_dflags hsc_env) + putNameLiterally + if | old_hash == new_hash + -> up_to_date logger (text "HPC flags unchanged") + | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env) + -> up_to_date logger (text "HPC flags changed; ignoring") + | otherwise + -> out_of_date_hash logger HpcFlagsChanged + (text " HPC flags have changed") + old_hash new_hash + +-- Check that the set of signatures we are merging in match. +-- If the -unit-id flags change, this can change too. +checkMergedSignatures :: HscEnv -> ModSummary -> IfaceSelfRecomp -> IO RecompileRequired +checkMergedSignatures hsc_env mod_summary self_recomp = do + let logger = hsc_logger hsc_env + let unit_state = hsc_units hsc_env + let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_sr_usages self_recomp ] + new_merged = case lookupUniqMap (requirementContext unit_state) + (ms_mod_name mod_summary) of + Nothing -> [] + Just r -> sort $ map (instModuleToModule unit_state) r + if old_merged == new_merged + then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged) + else return $ needsRecompileBecause SigsMergeChanged + +-- If the direct imports of this module are resolved to targets that +-- are not among the dependencies of the previous interface file, +-- then we definitely need to recompile. This catches cases like +-- - an exposed package has been upgraded +-- - we are compiling with different package flags +-- - a home module that was shadowing a package module has been removed +-- - a new home module has been added that shadows a package module +-- See bug #1372. +-- +-- Returns (RecompBecause ) if recompilation is required. +checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired +checkDependencies hsc_env summary iface + = do + res_normal <- classify_import (findImportedModule hsc_env) + ([(st, p, m) | (st, p, m) <- (ms_textual_imps summary)] + ++ + [(NormalLevel, NoPkgQual, m) | m <- ms_srcimps summary ]) + res_plugin <- classify_import (\mod _ -> findPluginModule hsc_env mod) + [(st, p, m) | (st, p, m) <- (ms_plugin_imps summary) ] + case sequence (res_normal ++ res_plugin) 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 + in check_packages allPkgDeps prev_dep_pkgs + where + + classify_import :: (ModuleName -> t -> IO FindResult) + -> [(ImportLevel, t, GenLocated l ModuleName)] + -> IfG + [Either + CompileReason (Either (ImportLevel, UnitId, ModuleName) (FastString, (ImportLevel, UnitId)))] + classify_import find_import imports = + liftIO $ traverse (\(st, mb_pkg, L _ mod) -> + let reason = ModuleChanged mod + in classify st reason <$> find_import mod mb_pkg) + imports + logger = hsc_logger hsc_env + all_home_units = hsc_all_home_unit_ids hsc_env + prev_dep_mods = map (\(IfaceImportLevel s,u, a) -> (s, u, gwib_mod a)) $ Set.toAscList $ dep_direct_mods (mi_deps iface) + prev_dep_pkgs = Set.toAscList (Set.union (Set.map (first tcImportLevel) (dep_direct_pkgs (mi_deps iface))) + (Set.map ((SpliceLevel),) (dep_plugin_pkgs (mi_deps iface)))) + + classify st _ (Found _ mod) + | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((st, toUnitId $ moduleUnit mod, moduleName mod))) + | otherwise = Right (Right (moduleNameFS (moduleName mod), (st, toUnitId $ moduleUnit mod))) + classify _ reason _ = Left (RecompBecause reason) + + check_mods :: [(ImportLevel, UnitId, ModuleName)] -> [(ImportLevel, UnitId, ModuleName)] -> IO RecompileRequired + check_mods [] [] = return UpToDate + check_mods [] (old:_) = do + -- This case can happen when a module is change from HPT to package import + trace_hi_diffs logger $ + text "module no longer" <+> quotes (ppr old) <+> + text "in dependencies" + + return $ needsRecompileBecause $ ModuleRemoved old + check_mods (new:news) olds + | Just (old, olds') <- uncons olds + , new == old = check_mods (dropWhile (== new) news) olds' + | otherwise = do + trace_hi_diffs logger $ + text "imported module " <> quotes (ppr new) <> + text " not among previous dependencies" + return $ needsRecompileBecause $ ModuleAdded new + + check_packages :: [(FastString, (ImportLevel, UnitId))] -> [(ImportLevel, UnitId)] -> IO RecompileRequired + check_packages [] [] = return UpToDate + check_packages [] (old:_) = do + trace_hi_diffs logger $ + text "package " <> quotes (ppr old) <> + text "no longer in dependencies" + return $ needsRecompileBecause $ UnitDepRemoved old + check_packages ((new_name, (new_unit)):news) olds + | Just (old, olds') <- uncons olds + , new_unit == old = check_packages (dropWhile ((== new_unit) . snd) news) olds' + | otherwise = do + trace_hi_diffs logger $ + text "imported package" <+> ftext new_name <+> ppr new_unit <+> + text "not among previous dependencies" + return $ needsRecompileBecause $ ModulePackageChanged new_name + + +needInterface :: Module -> (ModIface -> IO RecompileRequired) + -> IfG RecompileRequired +needInterface mod continue + = do + mb_recomp <- tryGetModIface + "need version info for" + mod + case mb_recomp of + Nothing -> return $ NeedsRecompile MustCompile + Just iface -> liftIO $ continue iface + +tryGetModIface :: String -> Module -> IfG (Maybe ModIface) +tryGetModIface doc_msg mod + = do -- Load the imported interface if possible + logger <- getLogger + let doc_str = sep [text doc_msg, ppr mod] + liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod <+> ppr (moduleUnit mod)) + + mb_iface <- loadInterface doc_str mod ImportBySystem + -- Load the interface, but don't complain on failure; + -- Instead, get an Either back which we can test + + case mb_iface of + Failed _ -> do + liftIO $ trace_hi_diffs logger (sep [text "Couldn't load interface for module", ppr mod]) + return Nothing + -- Couldn't find or parse a module mentioned in the + -- old interface file. Don't complain: it might + -- just be that the current module doesn't need that + -- import and it's been deleted + Succeeded iface -> pure $ Just iface + +-- | Given the usage information extracted from the old +-- M.hi file for the module being compiled, figure out +-- whether M needs to be recompiled. +checkModUsage :: FinderCache -> Usage -> IfG RecompileRequired +checkModUsage _ UsagePackageModule{ + usg_mod = mod, + usg_mod_hash = old_mod_hash } = do + logger <- getLogger + needInterface mod $ \iface -> do + let reason = ModuleChanged (moduleName mod) + checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface) + -- We only track the ABI hash of package modules, rather than + -- individual entity usages, so if the ABI hash changes we must + -- recompile. This is safe but may entail more recompilation when + -- a dependent package has changed. + +checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do + logger <- getLogger + needInterface mod $ \iface -> do + let reason = ModuleChangedRaw (moduleName mod) + checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface) +checkModUsage _ UsageHomeModuleInterface{ usg_mod_name = mod_name + , usg_unit_id = uid + , usg_iface_hash = old_mod_hash } = do + let mod = mkModule (RealUnit (Definite uid)) mod_name + logger <- getLogger + needInterface mod $ \iface -> do + let reason = ModuleChangedIface mod_name + checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash iface) + +checkModUsage _ UsageHomeModule{ + usg_mod_name = mod_name, + usg_unit_id = uid, + usg_mod_hash = old_mod_hash, + usg_exports = maybe_imported_exports, + usg_entities = old_decl_hash } + = do + let mod = mkModule (RealUnit (Definite uid)) mod_name + logger <- getLogger + needInterface mod $ \iface -> do + let + new_mod_hash = mi_mod_hash iface + new_decl_hash = mi_hash_fn iface + reason = ModuleChanged (moduleName mod) + + liftIO $ do + -- CHECK MODULE + recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash + if not (recompileRequired recompile) + then return UpToDate + else checkList + [ -- CHECK EXPORT LIST; see Note [When to recompile when export lists change?] + checkHomeModImport logger reason maybe_imported_exports iface + , -- CHECK USED ITEMS ONE BY ONE + checkList [ checkEntityUsage logger reason new_decl_hash u + | u <- old_decl_hash] + , up_to_date logger (text " Great! The bits I use are up to date") + ] + +checkModUsage fc UsageFile{ usg_file_path = file, + usg_file_hash = old_hash, + usg_file_label = mlabel } = + liftIO $ + handleIO handler $ do + new_hash <- lookupFileCache fc $ unpackFS file + if (old_hash /= new_hash) + then return recomp + else return UpToDate + where + reason = FileChanged $ unpackFS 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 + +-- | We are importing a module whose exports have changed. +-- Does this require recompilation? +-- +-- See Note [When to recompile when export lists change?] +checkHomeModImport :: Logger -> RecompReason -> Maybe HomeModImport -> ModIface -> IO RecompileRequired +checkHomeModImport _ _ Nothing _ = return UpToDate +checkHomeModImport logger reason + (Just (HomeModImport old_orphan_like_hash old_avails)) + iface + -- (1) Orphans (of the module we are importing or of its dependencies) + -- have changed: recompilation is required. + -- + -- See Note [Orphan-like hash]. + | old_orphan_like_hash /= new_orphan_like_hash + = out_of_date_hash logger reason (text " Orphan-likes changed") + old_orphan_like_hash new_orphan_like_hash + | otherwise + -- (2) Is there a change in the set of entities we are importing? + = case old_avails of + -- (a) Whole module import: recompile if the export hash + -- of the module we are importing has changed. + HMIA_Implicit old_avails_hash + | old_avails_hash /= new_avails_hash + -> out_of_date_hash logger reason (text " Export list changed") + old_orphan_like_hash new_orphan_like_hash + | otherwise + -> return UpToDate + -- (b) Explicit imports: recompile if there is a change in the + -- set of imported items. + HMIA_Explicit + { hmia_imported_avails = DetOrdAvails imps + , hmia_parents_with_implicits = parents_of_implicits + } -> + case checkNewExportedAvails new_exports parents_of_implicits imps of + [] -> return UpToDate + changes@(_:_) -> + do trace_hi_diffs logger $ + hang (text "Export list changed") + 2 (ppr changes) + return $ needsRecompileBecause reason + where + new_orphan_like_hash = mi_orphan_like_hash iface + new_avails_hash = mi_export_avails_hash iface + new_exports = mi_exports iface + +-- | The exported avails of a module have changed. Should this cause recompilation +-- of a module that imports it? +-- +-- This is only about export/import lists; checking for changes in the definitions +-- of used identifiers is done later (see 'checkEntityUsage'). +-- +-- See Note [When to recompile when export lists change?]. +checkNewExportedAvails :: [AvailInfo] -> NameSet -> [AvailInfo] -> [AvailInfo] +checkNewExportedAvails new_avails parents_of_implicits imported_avails + = concatMap go imported_avails + where + go a@(Avail n) = + case lookupNameEnv env n of + Nothing -> [a] + Just {} -> [] + go a@(AvailTC n ns) = + case lookupNameEnv env n of + Nothing -> [a] + Just a' -> + case a' of + Avail {} -> [a] + AvailTC _ ns' + | n `elemNameSet` parents_of_implicits + -> + -- We are dealing with an export item of the form @T(..)@. + -- If the set of subordinate names has changed at all, we must + -- recompile. + if mkNameSet ns == mkNameSet ns' + then [] + else [a] + | otherwise + -> + -- We are dealing with an import item of the form @T(K,x,y)@. + -- Just check that all the names we are explicitly importing + -- continue to be exported. It's OK if T has more children + -- than it used to. + if all (`elem` ns') ns + then [] + else [a] + + env = availsToNameEnv new_avails + +{- Note [When to recompile when export lists change?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose module N imports module M, and the exports of M change. Does this +require recompiling N? + +Suppose for example that we have: + + module M (foo) where + foo = 3 + + module N where + import M + bar = foo + 1 + baz = 2 * bar + +If we add an identifier to the export list of M, we must recompile N because +this might introduce name clashes, e.g. changing M to: + + module M (foo, bar) where + foo = 3 + bar = 7 + +will cause N to no longer compile because of a name clash involving 'bar'. + +However, if N had an explicit import list: + + module N where + import M(foo) + bar = foo + 1 + baz = 2 * bar + +then it *does not matter* that 'M' starts exporting 'bar'; 'N' is unaffected. + +This justifies the following approach for deciding whether a change in exports +should lead to recompilation. + + (1) If the orphan instances exported by M change, or if the orphans of + dependencies of M change, we must recompile N. + See Note [Orphan-like hash] + + (2) Otherwise, look at all the import declarations that import M. + + (a) If there is a whole module import, or an "import hiding" import, + then we must recompile N when the avails exported from M change + (such a change is detected by using the 'mi_export_avails_hash'). + + (b) Otherwise, all imports are explicit imports, but not every identifier + is necessarily explicitly imported, as we might have an import of + the form @import M(T(..))@. + + We proceed by comparing what we are importing from M against the + new exports of M. We recompile unless the following two conditions + are both satisfied: + + C1. Every explicitly imported identifier continues to be exported. + C2. For every parent P in an import item of the form @P(..)@, + the set of subordinates exported by P has not changed. + +Note that this import check is done purely on the basis of the Names involved, +unlike the subsequent recompilation check done in 'checkEntityUsage' which +checks that the definitions of used identifiers have not changed. + +Note [Orphan-like hash] +~~~~~~~~~~~~~~~~~~~~~~~ +The orphan-like hash extends the orphan hash to include other entities that +also cause recompilation downstream upon changing. + +The hash includes: + + (1) orphan class and family instances + (2) exported named defaults (these are very similar to orphan instances) + (3) non-orphan type family instances, including those of dependencies + (4) the Safe Haskell safety of the module + +Why do we need to do this? For (3), suppose we have: + + module A where + type instance F Int = Bool + + module B where + import A + + module C where + import B + +The family instance consistency check for C depends on the dep_finsts of +B. If we rename module A to A2, when the dep_finsts of B changes, we need +to make sure that C gets rebuilt. Effectively, the dep_finsts are part of +the exports of B, because C always considers them when checking +consistency. + +A full discussion is in #12723. + +We do NOT need to hash dep_orphs, because this is implied by +dep_orphan_hashes, and we do not need to hash ordinary (non-orphan) class +instances, because there is no eager consistency check as there is with type +families. For this reason, we don't currently store a hash of non-orphan class +instances. +-} + +------------------------ +checkModuleFingerprint + :: Logger + -> RecompReason + -> Fingerprint + -> Fingerprint + -> IO RecompileRequired +checkModuleFingerprint logger reason old_mod_hash new_mod_hash + | new_mod_hash == old_mod_hash + = up_to_date logger (text "Module fingerprint unchanged") + + | otherwise + = out_of_date_hash logger reason (text " Module fingerprint has changed") + old_mod_hash new_mod_hash + +checkIfaceFingerprint + :: Logger + -> RecompReason + -> Fingerprint + -> Fingerprint + -> IO RecompileRequired +checkIfaceFingerprint logger reason old_mod_hash new_mod_hash + | new_mod_hash == old_mod_hash + = up_to_date logger (text "Iface fingerprint unchanged") + + | otherwise + = out_of_date_hash logger reason (text " Iface fingerprint has changed") + old_mod_hash new_mod_hash + +------------------------ +checkEntityUsage :: Logger + -> RecompReason + -> (OccName -> Maybe (OccName, Fingerprint)) + -> (OccName, Fingerprint) + -> IO RecompileRequired +checkEntityUsage logger reason new_hash (name,old_hash) = do + case new_hash name of + -- We used it before, but it ain't there now + Nothing -> out_of_date logger reason (pure $ sep [text "No longer exported:", ppr name]) + -- It's there, but is it up to date? + Just (_, new_hash) + | new_hash == old_hash + -> do trace_hi_diffs logger (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) + return UpToDate + | otherwise + -> out_of_date_hash logger reason (text " Out of date:" <+> ppr name) old_hash new_hash + +up_to_date :: Logger -> SDoc -> IO RecompileRequired +up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate + +out_of_date :: Logger -> RecompReason -> IO SDoc -> IO RecompileRequired +out_of_date logger reason msg = trace_hi_diffs_io 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 (pure $ hsep [msg, ppr old_hash, text "->", ppr new_hash]) + +-- --------------------------------------------------------------------------- +-- Compute fingerprints for the interface + +{- Note [Fingerprinting IfaceDecls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The general idea here is that we first examine the 'IfaceDecl's and determine +the recursive groups of them. We then walk these groups in dependency order, +serializing each contained 'IfaceDecl' to a "Binary" buffer which we then +hash using MD5 to produce a fingerprint for the group. + +However, the serialization that we use is a bit funny: we override the @putName@ +operation with our own which serializes the hash of a 'Name' instead of the +'Name' itself. This ensures that the fingerprint of a decl changes if anything +in its transitive closure changes. This trick is why we must be careful about +traversing in dependency order: we need to ensure that we have hashes for +everything referenced by the decl which we are fingerprinting. + +Moreover, we need to be careful to distinguish between serialization of binding +Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls +field of a IfaceClsInst): only in the non-binding case should we include the +fingerprint; in the binding case we shouldn't since it is merely the name of the +thing that we are currently fingerprinting. + + +Note [Fingerprinting recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The fingerprinting of a single recursive group is a rather subtle affair, as +seen in #18733. + +How not to fingerprint +---------------------- + +Prior to fixing #18733 we used the following (flawed) scheme to fingerprint a +group in hash environment `hash_env0`: + + 1. extend hash_env0, giving each declaration in the group the fingerprint 0 + 2. use this environment to hash the declarations' ABIs, resulting in + group_fingerprint + 3. produce the final hash environment by extending hash_env0, mapping each + declaration of the group to group_fingerprint + +However, this is wrong. Consider, for instance, a program like: + + data A = ARecu B | ABase String deriving (Show) + data B = BRecu A | BBase Int deriving (Show) + + info :: B + info = BBase 1 + +A consequence of (3) is that A and B will have the same fingerprint. This means +that if the user changes `info` to: + + info :: A + info = ABase "hello" + +The program's ABI fingerprint will not change despite `info`'s type, and +therefore ABI, being clearly different. + +However, the incorrectness doesn't end there: (1) means that all recursive +occurrences of names within the group will be given the same fingerprint. This +means that the group's fingerprint won't change if we change an occurrence of A +to B. + +Surprisingly, this bug (#18733) lurked for many years before being uncovered. + +How we now fingerprint +---------------------- + +As seen above, the fingerprinting function must ensure that a groups +fingerprint captures the structure of within-group occurrences. The scheme that +we use is: + + 0. To ensure determinism, sort the declarations into a stable order by + declaration name + + 1. Extend hash_env0, giving each declaration in the group a sequential + fingerprint (e.g. 0, 1, 2, ...). + + 2. Use this environment to hash the declarations' ABIs, resulting in + group_fingerprint. + + Since we included the sequence number in step (1) programs identical up to + transposition of recursive occurrences are distinguishable, avoiding the + second issue mentioned above. + + 3. Produce the final environment by extending hash_env, mapping each + declaration of the group to the hash of (group_fingerprint, i), where + i is the position of the declaration in the stable ordering. + + Including i in the hash ensures that the first issue noted above is + avoided. + +-} + +-- | Compute the information needed for self-recompilation checking. This +-- information can be computed before the backend phase. +mkSelfRecomp :: HscEnv -> Module -> Fingerprint -> [Usage] -> IO IfaceSelfRecomp +mkSelfRecomp hsc_env this_mod src_hash usages = do + let dflags = hsc_dflags hsc_env + + let dyn_flags_info = fingerprintDynFlags hsc_env this_mod putNameLiterally + + let opt_hash = fingerprintOptFlags dflags putNameLiterally + + let hpc_hash = fingerprintHpcFlags dflags putNameLiterally + + plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env) + + let include_detailed_flags (flag_hash, flags) = + if gopt Opt_WriteSelfRecompFlags dflags + then FingerprintWithValue flag_hash (Just flags) + else FingerprintWithValue flag_hash Nothing + + return (IfaceSelfRecomp + { mi_sr_flag_hash = include_detailed_flags dyn_flags_info + , mi_sr_hpc_hash = hpc_hash + , mi_sr_opt_hash = opt_hash + , mi_sr_plugin_hash = plugin_hash + , mi_sr_src_hash = src_hash + , mi_sr_usages = usages }) + +-- | Add fingerprints for top-level declarations to a 'ModIface'. +-- +-- See Note [Fingerprinting IfaceDecls] +addFingerprints + :: HscEnv + -> PartialModIface + -> IO ModIface +addFingerprints hsc_env iface0 = do + (abiHashes, caches, decls_w_hashes) <- addAbiHashes hsc_env (mi_mod_info iface0) (mi_public iface0) (mi_deps iface0) + + -- put the declarations in a canonical order, sorted by OccName + let sorted_decls :: [(Fingerprint, IfaceDecl)] + sorted_decls = Map.elems $ Map.fromList $ + [(getOccName d, e) | e@(_, d) <- decls_w_hashes] + + -- This key is safe because mi_extra_decls contains tidied things. + getOcc (IfGblTopBndr b) = getOccName b + getOcc (IfLclTopBndr fs _ _ details) = + case details of + IfRecSelId { ifRecSelFirstCon = first_con } + -> mkRecFieldOccFS (getOccFS first_con) (ifLclNameFS fs) + _ -> mkVarOccFS (ifLclNameFS fs) + + binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) () + binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs) + + sorted_extra_decls :: Maybe IfaceSimplifiedCore + sorted_extra_decls = mi_simplified_core iface0 <&> \simpl_core -> + IfaceSimplifiedCore (sortOn binding_key (mi_sc_extra_decls simpl_core)) (mi_sc_foreign simpl_core) + + -- The interface hash depends on: + -- - the ABI hash, plus + -- - the things which can affect whether a module is recompiled + -- - the module level annotations, + -- - deps (home and external packages, dependent files) + let !iface_hash = computeFingerprint putNameLiterally + (mi_abi_mod_hash abiHashes, + mi_self_recomp_info iface0, + mi_deps iface0) + + let final_iface = completePartialModIface iface0 iface_hash + sorted_decls sorted_extra_decls abiHashes caches + -- + return final_iface + + + +-- The ABI hash should depend on everything in IfacePublic +-- This is however computed in a very convoluted way, so be careful your +-- addition ends up in the right place. In essence all this function does is +-- compute a hash of the arguments. +-- +-- Why the convoluted way? Hashing individual declarations allows us to do fine-grained +-- recompilation checking for home package modules, which record precisely what they use +-- from each module. +addAbiHashes :: HscEnv -> IfaceModInfo -> PartialIfacePublic -> Dependencies -> IO (IfaceAbiHashes, IfaceCache, [(Fingerprint, IfaceDecl)]) +addAbiHashes hsc_env info + iface_public + deps = do + eps <- hscEPS hsc_env + let + -- If you have arrived here by accident then congratulations, + -- you have discovered the ABI hash. Your reward is to update the ABI hash to + -- account for your change to the interface file. Omitting your field using a + -- wildcard may lead to some unfortunate consequences. + IfacePublic + exports fixities warns anns decls + defaults insts fam_insts rules + trust _trust_pkg -- TODO: trust_pkg ignored + complete + _cache + () + = iface_public + -- And these fields of deps should be in IfacePublic, but in good time. + Dependencies _ _ _ sig_mods trusted_pkgs boot_mods orph_mods fis_mods = deps + decl_warn_fn = mkIfaceDeclWarnCache (fromIfaceWarnings warns) + export_warn_fn = mkIfaceExportWarnCache (fromIfaceWarnings $ warns) + fix_fn = mkIfaceFixCache fixities + + this_mod = mi_mod_info_module info + semantic_mod = mi_mod_info_semantic_module info + (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph insts + (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph rules + (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph fam_insts + complete_matches = mkIfaceCompleteMap complete + ann_fn = mkIfaceAnnCache anns + + -- The ABI of a declaration represents everything that is made + -- visible about the declaration that a client can depend on. + -- see IfaceDeclABI below. + declABI :: IfaceDecl -> IfaceDeclABI + -- TODO: I'm not sure if this should be semantic_mod or this_mod. + -- See also Note [Identity versus semantic module] + declABI decl = (this_mod, decl, extras) + where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts + non_orph_fis top_lvl_name_env complete_matches decl + + -- This is used for looking up the Name of a default method + -- from its OccName. See Note [default method Name] + top_lvl_name_env = + mkOccEnv [ (nameOccName nm, nm) + | IfaceId { ifName = nm } <- decls ] + + -- Dependency edges between declarations in the current module. + -- This is computed by finding the free external names of each + -- declaration, including IfaceDeclExtras (things that a + -- declaration implicitly depends on). + edges :: [ Node OccName IfaceDeclABI ] + edges = [ DigraphNode abi (getOccName decl) out + | decl <- decls + , let abi = declABI decl + , let out = localOccs $ freeNamesDeclABI abi + ] + + name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n) + localOccs = + map (getParent . getOccName) + -- NB: names always use semantic module, so + -- filtering must be on the semantic module! + -- See Note [Identity versus semantic module] + . filter ((== semantic_mod) . name_module) + . nonDetEltsUniqSet + -- It's OK to use nonDetEltsUFM as localOccs is only + -- used to construct the edges and + -- stronglyConnCompFromEdgedVertices is deterministic + -- even with non-deterministic order of edges as + -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. + where getParent :: OccName -> OccName + getParent occ = lookupOccEnv parent_map occ `orElse` occ + + -- maps OccNames to their parents in the current module. + -- e.g. a reference to a constructor must be turned into a reference + -- to the TyCon for the purposes of calculating dependencies. + parent_map :: OccEnv OccName + parent_map = foldl' extend emptyOccEnv decls + where extend env d = + extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] + where n = getOccName d + + -- Strongly-connected groups of declarations, in dependency order + groups :: [SCC IfaceDeclABI] + groups = stronglyConnCompFromEdgedVerticesOrd edges + + global_hash_fn = mkHashFun hsc_env eps + + -- How to output Names when generating the data to fingerprint. + -- Here we want to output the fingerprint for each top-level + -- Name, whether it comes from the current module or another + -- module. In this way, the fingerprint for a declaration will + -- change if the fingerprint for anything it refers to (transitively) + -- changes. + mk_put_name :: OccEnv (OccName,Fingerprint) + -> WriteBinHandle -> Name -> IO () + mk_put_name local_env bh name + | isWiredInName name = putNameLiterally bh name + -- wired-in names don't have fingerprints + | otherwise + = assertPpr (isExternalName name) (ppr name) $ + let hash | nameModule name /= semantic_mod = global_hash_fn name + -- Get it from the REAL interface!! + -- This will trigger when we compile an hsig file + -- and we know a backing impl for it. + -- See Note [Identity versus semantic module] + | semantic_mod /= this_mod + , not (isHoleModule semantic_mod) = global_hash_fn name + | otherwise = return (snd (lookupOccEnv local_env (getOccName name) + `orElse` pprPanic "urk! lookup local fingerprint" + (ppr name $$ ppr local_env))) + -- This panic indicates that we got the dependency + -- analysis wrong, because we needed a fingerprint for + -- an entity that wasn't in the environment. To debug + -- it, turn the panic into a trace, uncomment the + -- pprTraces below, run the compile again, and inspect + -- the output and the generated .hi file with + -- --show-iface. + in hash >>= put_ bh + + -- take a strongly-connected group of declarations and compute + -- its fingerprint. + + fingerprint_group :: (OccEnv (OccName,Fingerprint), + [(Fingerprint,IfaceDecl)]) + -> SCC IfaceDeclABI + -> IO (OccEnv (OccName,Fingerprint), + [(Fingerprint,IfaceDecl)]) + + fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi) + = do let hash_fn = mk_put_name local_env + decl = abiDecl abi + --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do + let !hash = computeFingerprint hash_fn abi + env' <- extend_hash_env local_env (hash,decl) + return (env', (hash,decl) : decls_w_hashes) + + fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis) + = do let stable_abis = sortBy cmp_abiNames abis + stable_decls = map abiDecl stable_abis + local_env1 <- foldM extend_hash_env local_env + (zip (map mkRecFingerprint [0..]) stable_decls) + -- See Note [Fingerprinting recursive groups] + let hash_fn = mk_put_name local_env1 + -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do + -- put the cycle in a canonical order + let !hash = computeFingerprint hash_fn stable_abis + let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls + -- See Note [Fingerprinting recursive groups] + local_env2 <- foldM extend_hash_env local_env pairs + return (local_env2, pairs ++ decls_w_hashes) + + -- Make a fingerprint from the ordinal position of a binding in its group. + mkRecFingerprint :: Word64 -> Fingerprint + mkRecFingerprint i = Fingerprint 0 i + + bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint + bumpFingerprint fp n = fingerprintFingerprints [ fp, mkRecFingerprint n ] + + -- we have fingerprinted the whole declaration, but we now need + -- to assign fingerprints to all the OccNames that it binds, to + -- use when referencing those OccNames in later declarations. + -- + extend_hash_env :: OccEnv (OccName,Fingerprint) + -> (Fingerprint,IfaceDecl) + -> IO (OccEnv (OccName,Fingerprint)) + extend_hash_env env0 (hash,d) = + return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 + (ifaceDeclFingerprints hash d)) + + -- + (local_env, decls_w_hashes) <- + foldM fingerprint_group (emptyOccEnv, []) groups + + -- The export hash of a module depends on the orphan hashes of the + -- orphan modules below us in the dependency tree. This is the way + -- that changes in orphans get propagated all the way up the + -- dependency tree. + -- + -- NB: do not filter out non-home-package modules! + -- See Note [Take into account non-home package orphan modules]. + let orph_mods_no_self + = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot] + $ orph_mods + dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods_no_self + + let !orphan_hash = computeFingerprint (mk_put_name local_env) + (map ifDFun orph_insts, orph_rules, orph_fis) + + -- Hash of the transitive things in dependencies + let !dep_hash = computeFingerprint putNameLiterally + ( sig_mods, boot_mods + , trusted_pkgs -- Trusted packages are like orphans + , fis_mods -- See Note [Orphan-like hash] + ) + + -- The export list hash doesn't depend on the fingerprints of + -- the Names it mentions, only the Names themselves, hence putNameLiterally. + -- + -- As per Note [When to recompile when export lists change?], there are two + -- separate considerations: + -- + -- (1) If there is a change in exported orphan instances, we must recompile. + -- + -- In fact, we must include slightly more items here than only the orphan + -- instances defined in the current module; see Note [Orphan-like hash]. + -- + -- (2) If there is a change in the exported avails, this may or may not + -- require recompilation downstream, depending on what is imported. + -- In the case that the downstream module has a whole module import, + -- then we recompile when any exports change, by looking at export_hash. + let + -- (1) Orphan-like information, see Note [Orphan-like hash]. + !orphan_like_hash = + computeFingerprint putNameLiterally + ( orphan_hash, dep_hash, dep_orphan_hashes + , defaults -- Changes in exported named defaults cause recompilation + , trust -- Change of Safe Haskell mode causes recompilation + ) + -- (2) Exported avails + !exported_avails_hash = computeFingerprint putNameLiterally exports + + -- the ABI hash depends on: + -- - decls + -- - export list + -- - orphans + -- - deprecations + -- - flag abi hash + let !mod_hash = computeFingerprint putNameLiterally + (sort (map fst decls_w_hashes), + exported_avails_hash, + orphan_like_hash, -- includes orphan_hash + ann_fn AnnModule, + warns) + + -- Surely the ABI depends on "module" annotations? + -- Also named defaults + + + + let + final_iface_exts = IfaceAbiHashes + { mi_abi_mod_hash = mod_hash + , mi_abi_orphan = not ( all ifRuleAuto orph_rules + -- See Note [Orphans and auto-generated rules] + && null orph_insts + && null orph_fis) + , mi_abi_finsts = not (null fam_insts) + , mi_abi_export_avails_hash = exported_avails_hash + , mi_abi_orphan_like_hash = orphan_like_hash + , mi_abi_orphan_hash = orphan_hash + } + + caches = IfaceCache + { mi_cache_decl_warn_fn = decl_warn_fn + , mi_cache_export_warn_fn = export_warn_fn + , mi_cache_fix_fn = fix_fn + , mi_cache_hash_fn = lookupOccEnv local_env + } + return (final_iface_exts, caches, decls_w_hashes) + where + +{- Note [Take into account non-home package orphan modules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to take into account all orphan modules, not just those that are from +the home package. + +Historically, we filtered out orphan modules which were not from the home +package, justifying it by saying that "we'd pick up the ABI hashes of the +external module instead". This is wrong. + +Suppose that we have: + + module External where + instance Show (a -> b) + + module Home1 where + import External + + module Home2 where + import Home1 + +The export hash of Home1 needs to reflect the orphan instances of +External. It's true that Home1 will get rebuilt if the orphans +of External, but we also need to make sure Home2 gets rebuilt +as well. See #12733 for more details. + +Note [Do not update EPS with your own hi-boot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When your hs-boot file includes an orphan instance declaration, you may find +that the dep_orphs of a module you import contains reference to yourself. +DO NOT actually load this module or add it to the orphan hashes: you're going +to provide the orphan instances yourself, no need to consult hs-boot; if you do +load the interface into EPS, you will see a duplicate orphan instance. + +See also #10182. +-} + +-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules +-- (in particular, the orphan modules which are transitively imported by the +-- current module). +-- +-- Q: Why do we need the hash at all, doesn't the list of transitively +-- imported orphan modules suffice? +-- +-- A: If one of our transitive imports adds a new orphan instance, our +-- export hash must change so that modules which import us rebuild. If we just +-- hashed the [Module], the hash would not change even when a new instance was +-- added to a module that already had an orphan instance. +-- +-- Q: Why don't we just hash the orphan hashes of our direct dependencies? +-- Why the full transitive closure? +-- +-- A: Suppose we have these modules: +-- +-- module A where +-- instance Show (a -> b) where +-- module B where +-- import A -- ** +-- module C where +-- import A +-- import B +-- +-- Whether or not we add or remove the import to A in B affects the +-- orphan hash of B. But it shouldn't really affect the orphan hash +-- of C. If we hashed only direct dependencies, there would be no +-- way to tell that the net effect was a wash, and we'd be forced +-- to recompile C and everything else. +getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] +getOrphanHashes hsc_env mods = do + let + dflags = hsc_dflags hsc_env + ctx = initSDocContext dflags defaultUserStyle + get_orph_hash mod = do + iface <- initIfaceLoad hsc_env . withIfaceErr ctx + $ loadInterface (text "getOrphanHashes") mod ImportBySystem + return (mi_orphan_hash iface) + + mapM get_orph_hash mods + + +{- +************************************************************************ +* * + The ABI of an IfaceDecl +* * +************************************************************************ + +Note [The ABI of an IfaceDecl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ABI of a declaration consists of: + + (a) the full name of the identifier (inc. module and package, + because these are used to construct the symbol name by which + the identifier is known externally). + + (b) the declaration itself, as exposed to clients. That is, the + definition of an Id is included in the fingerprint only if + it is made available as an unfolding in the interface. + + (c) the fixity of the identifier (if it exists) + (d) for Ids: rules + (e) for classes: instances, fixity & rules for methods + (f) for datatypes: instances, fixity & rules for constrs + +Items (c)-(f) are not stored in the IfaceDecl, but instead appear +elsewhere in the interface file. But they are *fingerprinted* with +the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras, +and fingerprinting that as part of the declaration. +-} + +type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras) + +data IfaceDeclExtras + = IfaceIdExtras IfaceIdExtras + + | IfaceDataExtras + (Maybe Fixity) -- Fixity of the tycon itself (if it exists) + [IfaceInstABI] -- Local class and family instances of this tycon + -- See Note [Orphans] in GHC.Core.InstEnv + [AnnPayload] -- Annotations of the type itself + [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations + + | IfaceClassExtras + (Maybe Fixity) -- Fixity of the class itself (if it exists) + [IfaceInstABI] -- Local instances of this class *or* + -- of its associated data types + -- See Note [Orphans] in GHC.Core.InstEnv + [AnnPayload] -- Annotations of the type itself + [IfaceIdExtras] -- For each class method: fixity, RULES and annotations + [IfExtName] -- Default methods. If a module + -- mentions a class, then it can + -- instantiate the class and thereby + -- use the default methods, so we must + -- include these in the fingerprint of + -- a class. + + | IfaceSynonymExtras (Maybe Fixity) [AnnPayload] + + | IfaceFamilyExtras (Maybe Fixity) [IfaceInstABI] [AnnPayload] + + | IfacePatSynExtras (Maybe Fixity) [IfaceCompleteMatchABI] -- ^ COMPLETE pragmas that this PatSyn appears in + + | IfaceOtherDeclExtras + +data IfaceIdExtras + = IdExtras + (Maybe Fixity) -- Fixity of the Id (if it exists) + [IfaceRule] -- Rules for the Id + [AnnPayload] -- Annotations for the Id + [IfaceCompleteMatchABI] -- See Note [Fingerprinting complete matches] for why this is in IdExtras + +-- When hashing a class or family instance, we hash only the +-- DFunId or CoAxiom, because that depends on all the +-- information about the instance. +-- +type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance + +-- See Note [Fingerprinting complete matches] +type IfaceCompleteMatchABI = (Fingerprint, Maybe IfExtName) + +abiDecl :: IfaceDeclABI -> IfaceDecl +abiDecl (_, decl, _) = decl + +cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering +cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare` + getOccName (abiDecl abi2) + +freeNamesDeclABI :: IfaceDeclABI -> NameSet +freeNamesDeclABI (_mod, decl, extras) = + freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras + +freeNamesDeclExtras :: IfaceDeclExtras -> NameSet +freeNamesDeclExtras (IfaceIdExtras id_extras) + = freeNamesIdExtras id_extras +freeNamesDeclExtras (IfaceDataExtras _ insts _ subs) + = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs) +freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms) + = unionNameSets $ + mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs +freeNamesDeclExtras (IfaceSynonymExtras _ _) + = emptyNameSet +freeNamesDeclExtras (IfaceFamilyExtras _ insts _) + = mkNameSet insts +freeNamesDeclExtras (IfacePatSynExtras _ complete) + = unionNameSets (map freeNamesIfaceCompleteABI complete) +freeNamesDeclExtras IfaceOtherDeclExtras + = emptyNameSet + +freeNamesIdExtras :: IfaceIdExtras -> NameSet +freeNamesIdExtras (IdExtras _ rules _ complete) = + unionNameSets (map freeNamesIfRule rules ++ map freeNamesIfaceCompleteABI complete) + +-- | Extract free names from a COMPLETE pragma ABI +freeNamesIfaceCompleteABI :: IfaceCompleteMatchABI -> NameSet +freeNamesIfaceCompleteABI (_, mb_ty) = case mb_ty of + Nothing -> emptyNameSet + Just ty -> unitNameSet ty + + +instance Outputable IfaceDeclExtras where + ppr IfaceOtherDeclExtras = Outputable.empty + ppr (IfaceIdExtras extras) = ppr_id_extras extras + ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns] + ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns] + ppr (IfaceDataExtras fix insts anns stuff) + = vcat [ppr fix, ppr_insts insts, ppr anns, + ppr_id_extras_s stuff] + ppr (IfaceClassExtras fix insts anns stuff defms) = + vcat [ppr fix, ppr_insts insts, ppr anns, + ppr_id_extras_s stuff, ppr defms] + ppr (IfacePatSynExtras fix complete) = vcat [ppr fix, ppr complete] + +ppr_insts :: [IfaceInstABI] -> SDoc +ppr_insts _ = text "" + +ppr_id_extras_s :: [IfaceIdExtras] -> SDoc +ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff) + +ppr_id_extras :: IfaceIdExtras -> SDoc +ppr_id_extras (IdExtras fix rules anns complete) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns) $$ vcat (map ppr complete) + +-- This instance is used only to compute fingerprints +instance Binary IfaceDeclExtras where + get _bh = panic "no get for IfaceDeclExtras" + put_ bh (IfaceIdExtras extras) = do + putByte bh 1; put_ bh extras + put_ bh (IfaceDataExtras fix insts anns cons) = do + putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons + put_ bh (IfaceClassExtras fix insts anns methods defms) = do + putByte bh 3 + put_ bh fix + put_ bh insts + put_ bh anns + put_ bh methods + put_ bh defms + put_ bh (IfaceSynonymExtras fix anns) = do + putByte bh 4; put_ bh fix; put_ bh anns + put_ bh (IfaceFamilyExtras fix finsts anns) = do + putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns + put_ bh (IfacePatSynExtras fix complete) = do + putByte bh 6; put_ bh fix; put_ bh complete + put_ bh IfaceOtherDeclExtras = putByte bh 7 + +instance Binary IfaceIdExtras where + get _bh = panic "no get for IfaceIdExtras" + put_ bh (IdExtras fix rules anns complete) = do { put_ bh fix; put_ bh rules; put_ bh anns; put_ bh complete } + +declExtras :: (OccName -> Maybe Fixity) + -> (AnnCacheKey -> [AnnPayload]) + -> OccEnv [IfaceRule] + -> OccEnv [IfaceClsInst] + -> OccEnv [IfaceFamInst] + -> OccEnv IfExtName -- lookup default method names + -> OccEnv [IfaceCompleteMatchABI] -- lookup complete matches + -> IfaceDecl + -> IfaceDeclExtras + +declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env complete_env decl + = case decl of + IfaceId{} -> IfaceIdExtras (id_extras n) + IfaceData{ifCons=cons} -> + IfaceDataExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++ + map ifDFun (lookupOccEnvL inst_env n)) + (ann_fn (AnnOccName n)) + (map (id_extras . occName . ifConName) (visibleIfConDecls cons)) + IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} -> + IfaceClassExtras (fix_fn n) insts (ann_fn (AnnOccName n)) meths defms + where + insts = (map ifDFun $ (concatMap at_extras ats) + ++ lookupOccEnvL inst_env n) + -- Include instances of the associated types + -- as well as instances of the class (#5147) + meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs] + -- Names of all the default methods (see Note [default method Name]) + defms = [ dmName + | IfaceClassOp bndr _ (Just _) <- sigs + , let dmOcc = mkDefaultMethodOcc (nameOccName bndr) + , Just dmName <- [lookupOccEnv dm_env dmOcc] ] + IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n) + (ann_fn (AnnOccName n)) + IfaceFamily{} -> IfaceFamilyExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n)) + (ann_fn (AnnOccName n)) + IfacePatSyn{} -> IfacePatSynExtras (fix_fn n) (lookup_complete_match n) + _other -> IfaceOtherDeclExtras + where + n = getOccName decl + id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn (AnnOccName occ)) (lookup_complete_match occ) + at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl) + + lookup_complete_match occ = lookupOccEnvL complete_env occ + +{- Note [default method Name] (see also #15970) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Names for the default methods aren't available in Iface syntax. + +* We originally start with a DefMethInfo from the class, contain a + Name for the default method + +* We turn that into Iface syntax as a DefMethSpec which lacks a Name + entirely. Why? Because the Name can be derived from the method name + (in GHC.IfaceToCore), so doesn't need to be serialised into the interface + file. + +But now we have to get the Name back, because the class declaration's +fingerprint needs to depend on it (this was the bug in #15970). This +is done in a slightly convoluted way: + +* Then, in addFingerprints we build a map that maps OccNames to Names + +* We pass that map to declExtras which laboriously looks up in the map + (using the derived occurrence name) to recover the Name we have just + thrown away. +-} + +lookupOccEnvL :: OccEnv [v] -> OccName -> [v] +lookupOccEnvL env k = lookupOccEnv env k `orElse` [] + +{- +-- for testing: use the md5sum command to generate fingerprints and +-- compare the results against our built-in version. + fp' <- oldMD5 dflags bh + if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp') + else return fp + +oldMD5 dflags bh = do + tmp <- newTempName dflags CurrentModule "bin" + writeBinMem bh tmp + tmp2 <- newTempName dflags CurrentModule "md5" + let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2 + r <- system cmd + case r of + ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r) + ExitSuccess -> do + hash_str <- readFile tmp2 + return $! readHexFingerprint hash_str +-} + +---------------------- +-- mkOrphMap partitions instance decls or rules into +-- (a) an OccEnv for ones that are not orphans, +-- mapping the local OccName to a list of its decls +-- (b) a list of orphan decls +mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl + -> [decl] -- Sorted into canonical order + -> (OccEnv [decl], -- Non-orphan decls associated with their key; + -- each sublist in canonical order + [decl]) -- Orphan decls; in canonical order +mkOrphMap get_key decls + = foldl' go (emptyOccEnv, []) decls + where + go (non_orphs, orphs) d + | NotOrphan occ <- get_key d + = (extendOccEnv_Acc (:) Utils.singleton non_orphs occ d, orphs) + | otherwise = (non_orphs, d:orphs) + +-- ----------------------------------------------------------------------------- +-- Look up parents and versions of Names + +-- This is like a global version of the mi_hash_fn field in each ModIface. +-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get +-- the parent and version info. + +mkHashFun + :: HscEnv -- needed to look up versions + -> ExternalPackageState -- ditto + -> (Name -> IO Fingerprint) +mkHashFun hsc_env eps name + | isHoleModule orig_mod + = lookup (mkHomeModule home_unit (moduleName orig_mod)) + | otherwise + = lookup orig_mod + where + home_unit = hsc_home_unit hsc_env + dflags = hsc_dflags hsc_env + hpt = hsc_HUG hsc_env + pit = eps_PIT eps + ctx = initSDocContext dflags defaultUserStyle + occ = nameOccName name + orig_mod = nameModule name + lookup mod = do + massertPpr (isExternalName name) (ppr name) + iface <- lookupIfaceByModule hpt pit mod >>= \case + Just iface -> return iface + Nothing -> + -- This can occur when we're writing out ifaces for + -- requirements; we didn't do any /real/ typechecking + -- so there's no guarantee everything is loaded. + -- Kind of a heinous hack. + initIfaceLoad hsc_env . withIfaceErr ctx + $ withoutDynamicNow + -- If you try and load interfaces when dynamic-too + -- enabled then it attempts to load the dyn_hi and hi + -- interface files. Backpack doesn't really care about + -- dynamic object files as it isn't doing any code + -- generation so -dynamic-too is turned off. + -- Some tests fail without doing this (such as T16219), + -- but they fail because dyn_hi files are not found for + -- one of the dependencies (because they are deliberately turned off) + -- Why is this check turned off here? That is unclear but + -- just one of the many horrible hacks in the backpack + -- implementation. + $ loadInterface (text "lookupVers2") mod ImportBySystem + return $ snd (mi_hash_fn iface occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr occ)) + +{- Note [Fingerprinting complete matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The presence or absence of COMPLETE pragmas influences the programs we generate, +and not just error messages, because pattern fallibility information feeds into +the desugaring of do notation (e.g. whether to use 'fail' from 'MonadFail'). + +As far as recompilation checking is concerned, there are two questions we need +to answer: + + Usage: When is a COMPLETE pragma used? + Fingerprinting: What is the Fingerprint of a COMPLETE pragma, i.e. when + do we consider a COMPLETE pragma to have changed? + +Usage + + There isn't a straightforward way to compute which COMPLETE pragmas are + "used" during pattern-match checking. So we have to come up with a conservative + approximation. + + The most conservative option is to consider a COMPLETE pragma to always be + used, much like we treat orphan class instances today. This means that any + change at all would require recompilation. + + A slightly finer grained option, which is what is currently implemented, is to + consider a COMPLETE pragma to be used only when the importing module actually + mentions at least one of the constructors in the COMPLETE pragma. + + Tested in: RecompCompletePragma + +Fingerprinting + + Most conservatively, the fingerprint of a COMPLETE pragma would be the hash of + all the constructors it mentions (together with the hash of the result TyCon, + if any). + + However, for the purposes of the pattern-match checker, we only really care + about the Names of the constructors in a COMPLETE pragma; it doesn't matter + what the definitions of the constructors are. The above criterion would + pessimistically lead to recompilation in the following scenario: + + module M where + pattern MyJust :: a -> Maybe a + pattern MyJust a = Just a + pattern MyNothing :: Maybe a + pattern MyNothing = Nothing + {-# COMPLETE MyJust, MyNothing #-} + + module N where + import M + f :: Maybe Int -> Int + f (MyJust x) = x; f _ = 0 + + In this example, if we change the definition of the 'MyNothing' pattern, then + we will recompile 'M', because 'N' uses the 'MyJust' constructor, 'MyJust' + appears in the imported {-# COMPLETE MyJust, MyNothing #-} pragma, and + 'MyNothing' has changed. + + However, this is needless: the RHS of the pattern synonym declaration for + 'MyNothing' is completely irrelevant to 'N'. So, to avoid this extraneous + recompilation, we implement the following finer-grained criterion: the + Fingerprint of a COMPLETE pragma is the hash of the 'Name's of the mentioned + constructors (hashed together with the Fingerprint of the result TyCon, if any). + + Tested in: RecompCompleteIndependence. +-} + +-- | Make a map from OccNames of pattern synonyms or data constructors to a list +-- of COMPLETE pragmas relevant for that OccName. +-- See Note [Fingerprinting complete matches] +mkIfaceCompleteMap :: [IfaceCompleteMatch] -> OccEnv [IfaceCompleteMatchABI] +mkIfaceCompleteMap complete = + mkOccEnv_C (++) $ + concatMap (\m@(IfaceCompleteMatch syns _) -> + let complete_abi = mkIfaceCompleteMatchABI m + in [(getOccName syn, [complete_abi]) | syn <- syns] + ) complete + where + mkIfaceCompleteMatchABI (IfaceCompleteMatch syns ty) = + (computeFingerprint putNameLiterally syns, ty) + +data AnnCacheKey = AnnModule | AnnOccName OccName + +-- | Creates cached lookup for the 'mi_anns' field of ModIface +mkIfaceAnnCache :: [IfaceAnnotation] -> AnnCacheKey -> [AnnPayload] +mkIfaceAnnCache anns + = \n -> case n of + AnnModule -> module_anns + AnnOccName occn -> lookupOccEnv env occn `orElse` [] + where + (module_anns, occ_anns) = partitionEithers $ map classify anns + classify (IfaceAnnotation target value) = + case target of + NamedTarget occn -> Right (occn, [value]) + ModuleTarget _ -> Left value + + -- flipping (++), so the first argument is always short + env = mkOccEnv_C (flip (++)) occ_anns diff --git a/GHC/Iface/Recomp/Binary.hs b/GHC/Iface/Recomp/Binary.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Recomp/Binary.hs @@ -0,0 +1,51 @@ + + +-- | Computing fingerprints of values serializable with GHC's \"Binary\" module. +module GHC.Iface.Recomp.Binary + ( -- * Computing fingerprints + fingerprintBinMem + , computeFingerprint + , putNameLiterally + ) where + +import GHC.Prelude + +import GHC.Utils.Fingerprint +import GHC.Utils.Binary +import GHC.Types.Name +import GHC.Utils.Panic.Plain +import GHC.Iface.Type (putIfaceType) +import System.IO.Unsafe (unsafePerformIO) + +fingerprintBinMem :: WriteBinHandle -> IO Fingerprint +fingerprintBinMem bh = withBinBuffer bh f + where + f bs = + -- we need to take care that we force the result here + -- lest a reference to the ByteString may leak out of + -- withBinBuffer. + let fp = fingerprintByteString bs + in fp `seq` return fp + +computeFingerprint :: (Binary a) + => (WriteBinHandle -> Name -> IO ()) + -> a + -> Fingerprint +computeFingerprint put_nonbinding_name a = unsafePerformIO $ do + bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block + put_ bh a + fingerprintBinMem bh + where + set_user_data bh = setWriterUserData bh $ mkWriterUserData + [ mkSomeBinaryWriter $ mkWriter putIfaceType + , mkSomeBinaryWriter $ mkWriter put_nonbinding_name + , mkSomeBinaryWriter $ simpleBindingNameWriter $ mkWriter putNameLiterally + , mkSomeBinaryWriter $ mkWriter putFS + ] + +-- | Used when we want to fingerprint a structure without depending on the +-- fingerprints of external Names that it refers to. +putNameLiterally :: WriteBinHandle -> Name -> IO () +putNameLiterally bh name = assert (isExternalName name) $ do + put_ bh $! nameModule name + put_ bh $! nameOccName name diff --git a/GHC/Iface/Recomp/Flags.hs b/GHC/Iface/Recomp/Flags.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Recomp/Flags.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | This module manages storing the various GHC option flags in a modules +-- interface file as part of the recompilation checking infrastructure. +module GHC.Iface.Recomp.Flags ( + fingerprintDynFlags + , fingerprintOptFlags + , fingerprintHpcFlags + ) where + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Driver.Env + +import GHC.Utils.Binary +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.SafeHaskell +import GHC.Utils.Fingerprint +import GHC.Iface.Recomp.Binary +import GHC.Iface.Flags + +import GHC.Data.EnumSet as EnumSet +import System.FilePath (normalise) +import Data.Maybe + +-- The subset of DynFlags which is used by the recompilation checker. + +-- | Produce a fingerprint of a @DynFlags@ value. We only base +-- the finger print on important fields in @DynFlags@ so that +-- the recompilation checker can use this fingerprint. +-- +-- NB: The 'Module' parameter is the 'Module' recorded by the *interface* +-- file, not the actual 'Module' according to our 'DynFlags'. +fingerprintDynFlags :: HscEnv -> Module + -> (WriteBinHandle -> Name -> IO ()) + -> (Fingerprint, IfaceDynFlags) + +fingerprintDynFlags hsc_env this_mod nameio = + let dflags@DynFlags{..} = hsc_dflags hsc_env + mainis = if mainModIs (hsc_HUE hsc_env) == this_mod then Just mainFunIs else Nothing + -- see #5878 + -- pkgopts = (homeUnit home_unit, sort $ packageFlags dflags) + safeHs = setSafeMode safeHaskell + -- oflags = sort $ filter filterOFlags $ flags dflags + + -- all the extension flags and the language + lang = fmap IfaceLanguage language + exts = map IfaceExtension $ EnumSet.toList extensionFlags + + -- avoid fingerprinting the absolute path to the directory of the source file + -- see Note [Implicit include paths] + includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] } + + -- -I, -D and -U flags affect Haskell C/CPP Preprocessor + cpp = IfaceCppOptions + { ifaceCppIncludes = map normalise $ flattenIncludes includePathsMinusImplicit + -- normalise: eliminate spurious differences due to "./foo" vs "foo" + , ifaceCppOpts = picPOpts dflags + , ifaceCppSig = opt_P_signature dflags + } + -- See Note [Repeated -optP hashing] + + + -- -I, -D and -U flags affect JavaScript C/CPP Preprocessor + js = IfaceCppOptions + { ifaceCppIncludes = map normalise $ flattenIncludes includePathsMinusImplicit + -- normalise: eliminate spurious differences due to "./foo" vs "foo" + , ifaceCppOpts = picPOpts dflags + , ifaceCppSig = opt_JSP_signature dflags + } + -- See Note [Repeated -optP hashing] + + -- -I, -D and -U flags affect C-- CPP Preprocessor + cmm = IfaceCppOptions { + ifaceCppIncludes = map normalise $ flattenIncludes includePathsMinusImplicit + -- normalise: eliminate spurious differences due to "./foo" vs "foo" + , ifaceCppOpts = picPOpts dflags + , ifaceCppSig = ([], opt_CmmP_signature dflags) + } + + -- Note [path flags and recompilation] + paths = [ hcSuf ] + + -- -fprof-auto etc. + prof = if sccProfilingEnabled dflags then Just (IfaceProfAuto profAuto) else Nothing + + -- Ticky + ticky = + mapMaybe (\f -> (if f `gopt` dflags then Just (IfaceGeneralFlag f) else Nothing)) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag] + + -- Other flags which affect code generation + codegen = mapMaybe (\f -> (if f `gopt` dflags then Just (IfaceGeneralFlag f) else Nothing)) (EnumSet.toList codeGenFlags) + + -- Did we include core for all bindings? + fat_iface = gopt Opt_WriteIfSimplifiedCore dflags + + f = IfaceDynFlags mainis safeHs lang exts cpp js cmm paths prof ticky codegen fat_iface debugLevel callerCcFilters + + in (computeFingerprint nameio f, f) + +-- Fingerprint the optimisation info. We keep this separate from the rest of +-- the flags because GHCi users (especially) may wish to ignore changes in +-- optimisation level or optimisation flags so as to use as many pre-existing +-- object files as they can. +-- See Note [Ignoring some flag changes] +fingerprintOptFlags :: DynFlags + -> (WriteBinHandle -> Name -> IO ()) + -> Fingerprint +fingerprintOptFlags DynFlags{..} nameio = + let + -- See https://gitlab.haskell.org/ghc/ghc/issues/10923 + -- We used to fingerprint the optimisation level, but as Joachim + -- Breitner pointed out in comment 9 on that ticket, it's better + -- to ignore that and just look at the individual optimisation flags. + opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags) + (EnumSet.toList generalFlags) + + in computeFingerprint nameio opt_flags + +-- Fingerprint the HPC info. We keep this separate from the rest of +-- the flags because GHCi users (especially) may wish to use an object +-- file compiled for HPC when not actually using HPC. +-- See Note [Ignoring some flag changes] +fingerprintHpcFlags :: DynFlags + -> (WriteBinHandle -> Name -> IO ()) + -> Fingerprint +fingerprintHpcFlags dflags@DynFlags{..} nameio = + let + -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798 + -- hpcDir is output-only, so we should recompile if it changes + hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing + + in computeFingerprint nameio hpc + + +{- Note [path flags and recompilation] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several flags that we deliberately omit from the +recompilation check; here we explain why. + +-osuf, -odir, -hisuf, -hidir + If GHC decides that it does not need to recompile, then + it must have found an up-to-date .hi file and .o file. + There is no point recording these flags - the user must + have passed the correct ones. Indeed, the user may + have compiled the source file in one-shot mode using + -o to specify the .o file, and then loaded it in GHCi + using -odir. + +-stubdir + We omit this one because it is automatically set by -outputdir, and + we don't want changes in -outputdir to automatically trigger + recompilation. This could be wrong, but only in very rare cases. + +-i (importPaths) + For the same reason as -osuf etc. above: if GHC decides not to + recompile, then it must have already checked all the .hi files on + which the current module depends, so it must have found them + successfully. It is occasionally useful to be able to cd to a + different directory and use -i flags to enable GHC to find the .hi + files; we don't want this to force recompilation. + +The only path-related flag left is -hcsuf. +-} + +{- Note [Ignoring some flag changes] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally, --make tries to reuse only compilation products that are +the same as those that would have been produced compiling from +scratch. Sometimes, however, users would like to be more aggressive +about recompilation avoidance. This is particularly likely when +developing using GHCi (see #13604). Currently, we allow users to +ignore optimisation changes using -fignore-optim-changes, and to +ignore HPC option changes using -fignore-hpc-changes. If there's a +demand for it, we could also allow changes to -fprof-auto-* flags +(although we can't allow -prof flags to differ). The key thing about +these options is that we can still successfully link a library or +executable when some of its components differ in these ways. + +The way we accomplish this is to leave the optimization and HPC +options out of the flag hash, hashing them separately. +-} + +{- Note [Repeated -optP hashing] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We invoke fingerprintDynFlags for each compiled module to include +the hash of relevant DynFlags in the resulting interface file. +-optP (preprocessor) flags are part of that hash. +-optP flags can come from multiple places: + + 1. -optP flags directly passed on command line. + 2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof. + 3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file. + +When compiling many modules at once with many -optP command line arguments +the work of hashing -optP flags would be repeated. This can get expensive +and as noted on #14697 it can take 7% of time and 14% of allocations on +a real codebase. + +The obvious solution is to cache the hash of -optP flags per GHC invocation. +However, one has to be careful there, as the flags that were added in 3. way +have to be accounted for. + +The current strategy is as follows: + + 1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p + is modified. This serves dual purpose. It ensures correctness for when + we add per file -optP flags and lets us save work for when we don't. + 2. When computing the fingerprint in fingerprintDynFlags use the cached + value *and* fingerprint the additional implied (see 2. above) -optP flags. + This is relatively cheap and saves the headache of fingerprinting all + the -optP flags and tracking all the places that could invalidate the + cache. +-} diff --git a/GHC/Iface/Recomp/Types.hs b/GHC/Iface/Recomp/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Recomp/Types.hs @@ -0,0 +1,156 @@ +module GHC.Iface.Recomp.Types ( + IfaceSelfRecomp(..), + IfaceDynFlags(..), + pprIfaceDynFlags, + missingExtraFlagInfo, +) where + +import GHC.Prelude +import GHC.Fingerprint +import GHC.Utils.Outputable +import GHC.Iface.Flags +import GHC.Types.SafeHaskell +import GHC.Unit.Module.Deps +import GHC.Unit.Module + +import GHC.Utils.Binary + +import Control.DeepSeq + +{- +Note [Self recompilation information in interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The flag -fwrite-if-self-recomp controls whether +interface files contain the information necessary to answer the +question: + + Is the interface file up-to-date, relative to: + * the source file it corresponds to, + * the flags passed to the GHC invocation to compile it, + * its dependencies (e.g. imported items, watched files added by addDependentFile, ...) + +If there is no self-recompilation information stored, then we always re-generate +the interface file from scratch. + +Why? Most packages are only built once either by a distribution or cabal +and then placed into an immutable store, after which we will never ask +this question. Therefore we can derive two benefits from omitting this +information. + +* Primary motivation: It vastly reduces the surface area for creating + non-deterministic interface files. See issue #10424 which motivated a + proper fix to that issue. Distributions have long contained versions + of GHC which just have broken self-recompilation checking (in order to + get deterministic interface files). + +* Secondary motivation: This reduces the size of interface files + slightly.. the `mi_usages` field can be quite big but probably this + isn't such a great benefit. + +* Third motivation: Conceptually clarity about which parts of an + interface file are used in order to **communicate** with subsequent + packages about the **interface** for a module. And which parts are + used to self-communicate during recompilation checking. + +The main tracking issue is #22188 but fixes issues such as #10424 in a +proper way. + +-} + +-- | The information for a module which is only used when deciding whether to recompile +-- itself. +-- +-- See Note [Self recompilation information in interface files] +data IfaceSelfRecomp = + IfaceSelfRecomp { mi_sr_src_hash :: !Fingerprint + -- ^ Hash of the .hs source, used for recompilation checking. + , mi_sr_usages :: [Usage] + -- ^ Usages; kept sorted so that it's easy to decide + -- whether to write a new iface file (changing usages + -- doesn't affect the hash of this module) + -- NOT STRICT! we read this field lazily from the interface file + -- It is *only* consulted by the recompilation checker + + , mi_sr_flag_hash :: !(FingerprintWithValue IfaceDynFlags) + -- ^ Hash of the important flags used when compiling the module, excluding + -- optimisation flags + , mi_sr_opt_hash :: !Fingerprint + -- ^ Hash of optimisation flags + , mi_sr_hpc_hash :: !Fingerprint + -- ^ Hash of hpc flags + , mi_sr_plugin_hash :: !Fingerprint + -- ^ Hash of plugins + } + + +instance Binary IfaceSelfRecomp where + put_ bh (IfaceSelfRecomp{mi_sr_src_hash, mi_sr_usages, mi_sr_flag_hash, mi_sr_opt_hash, mi_sr_hpc_hash, mi_sr_plugin_hash}) = do + put_ bh mi_sr_src_hash + lazyPut bh mi_sr_usages + put_ bh mi_sr_flag_hash + put_ bh mi_sr_opt_hash + put_ bh mi_sr_hpc_hash + put_ bh mi_sr_plugin_hash + + get bh = do + src_hash <- get bh + usages <- lazyGet bh + flag_hash <- get bh + opt_hash <- get bh + hpc_hash <- get bh + plugin_hash <- get bh + return $ IfaceSelfRecomp { mi_sr_src_hash = src_hash, mi_sr_usages = usages, mi_sr_flag_hash = flag_hash, mi_sr_opt_hash = opt_hash, mi_sr_hpc_hash = hpc_hash, mi_sr_plugin_hash = plugin_hash } + +instance Outputable IfaceSelfRecomp where + ppr (IfaceSelfRecomp{mi_sr_src_hash, mi_sr_usages, mi_sr_flag_hash, mi_sr_opt_hash, mi_sr_hpc_hash, mi_sr_plugin_hash}) + = vcat [text "Self-Recomp" + , nest 2 (vcat [ text "src hash:" <+> ppr mi_sr_src_hash + , text "flags:" <+> pprFingerprintWithValue missingExtraFlagInfo (fmap pprIfaceDynFlags mi_sr_flag_hash) + , text "opt hash:" <+> ppr mi_sr_opt_hash + , text "hpc hash:" <+> ppr mi_sr_hpc_hash + , text "plugin hash:" <+> ppr mi_sr_plugin_hash + , text "usages:" <+> ppr (map pprUsage mi_sr_usages) + ])] + +instance NFData IfaceSelfRecomp where + rnf (IfaceSelfRecomp src_hash usages flag_hash opt_hash hpc_hash plugin_hash) + = rnf src_hash `seq` rnf usages `seq` rnf flag_hash `seq` rnf opt_hash `seq` rnf hpc_hash `seq` rnf plugin_hash `seq` () + +pprFingerprintWithValue :: SDoc -> FingerprintWithValue SDoc -> SDoc +pprFingerprintWithValue missingInfo (FingerprintWithValue fp mflags) + = vcat $ + [ text "fingerprint:" <+> (ppr fp) + ] + ++ case mflags of + Nothing -> [missingInfo] + Just doc -> [doc] + +pprUsage :: Usage -> SDoc +pprUsage UsagePackageModule{ usg_mod = mod, usg_mod_hash = hash, usg_safe = safe } + = pprUsageImport mod hash safe +pprUsage UsageHomeModule{ usg_unit_id = unit_id, usg_mod_name = mod_name + , usg_mod_hash = hash, usg_safe = safe + , usg_exports = exports, usg_entities = entities } + = pprUsageImport (mkModule unit_id mod_name) hash safe $$ + nest 2 ( + maybe empty (\v -> text "exports: " <> ppr v) exports $$ + vcat [ ppr n <+> ppr v | (n,v) <- entities ] + ) +pprUsage usage@UsageFile{} + = hsep [text "addDependentFile", + doubleQuotes (ftext (usg_file_path usage)), + ppr (usg_file_hash usage)] +pprUsage usage@UsageMergedRequirement{} + = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] +pprUsage usage@UsageHomeModuleInterface{} + = hsep [text "implementation", ppr (usg_mod_name usage) + , ppr (usg_unit_id usage) + , ppr (usg_iface_hash usage)] + +pprUsageImport :: Outputable mod => mod -> Fingerprint -> IsSafeImport -> SDoc +pprUsageImport mod hash safe + = hsep [ text "import", pp_safe, ppr mod + , ppr hash ] + where + pp_safe | safe = text "safe" + | otherwise = text " -/ " diff --git a/GHC/Iface/Rename.hs b/GHC/Iface/Rename.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Rename.hs @@ -0,0 +1,739 @@ +-- | This module implements interface renaming, which is +-- used to rewrite interface files on the fly when we +-- are doing indefinite typechecking and need instantiations +-- of modules which do not necessarily exist yet. + +module GHC.Iface.Rename ( + rnModIface, + rnModExports, + tcRnModIface, + tcRnModExports, + ) where + +import GHC.Prelude + +import GHC.Driver.Env + +import GHC.Tc.Utils.Monad + +import GHC.Iface.Syntax +import GHC.Iface.Env +import {-# SOURCE #-} GHC.Iface.Load -- a bit vexing + +import GHC.Unit +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps + +import GHC.Tc.Errors.Types +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM +import GHC.Types.Avail +import GHC.Types.Error +import GHC.Types.FieldLabel +import GHC.Types.Var +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Shape + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Error +import GHC.Utils.Fingerprint +import GHC.Utils.Panic + +import qualified Data.Traversable as T + +import Data.IORef +import Data.Function ((&)) + +tcRnMsgMaybe :: IO (Either (Messages TcRnMessage) a) -> TcM a +tcRnMsgMaybe do_this = do + r <- liftIO $ do_this + case r of + Left msgs -> do + addMessages msgs + failM + Right x -> return x + +tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface +tcRnModIface x y z = do + hsc_env <- getTopEnv + tcRnMsgMaybe $ rnModIface hsc_env x y z + +tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo] +tcRnModExports x y = do + hsc_env <- getTopEnv + tcRnMsgMaybe $ rnModExports hsc_env x y + +failWithRn :: TcRnMessage -> ShIfM a +failWithRn tcRnMessage = do + errs_var <- fmap sh_if_errs getGblEnv + errs <- readTcRef errs_var + -- TODO: maybe associate this with a source location? + let msg = mkPlainErrorMsgEnvelope noSrcSpan tcRnMessage + writeTcRef errs_var (msg `addMessage` errs) + failM + +-- | What we have is a generalized ModIface, which corresponds to +-- a module that looks like p[A=\]:B. We need a *specific* ModIface, e.g. +-- p[A=q():A]:B (or maybe even p[A=\]:B) which we load +-- up (either to merge it, or to just use during typechecking). +-- +-- Suppose we have: +-- +-- p[A=\]:M ==> p[A=q():A]:M +-- +-- Substitute all occurrences of \ with q():A (renameHoleModule). +-- Then, for any Name of form {A.T}, replace the Name with +-- the Name according to the exports of the implementing module. +-- This works even for p[A=\]:M, since we just read in the +-- exports of B.hi, which is assumed to be ready now. +-- +-- This function takes an optional 'NameShape', which can be used +-- to further refine the identities in this interface: suppose +-- we read a declaration for {H.T} but we actually know that this +-- should be Foo.T; then we'll also rename this (this is used +-- when loading an interface to merge it into a requirement.) +rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape + -> ModIface -> IO (Either (Messages TcRnMessage) ModIface) +rnModIface hsc_env insts nsubst iface = + initRnIface hsc_env iface insts nsubst $ do + mod <- rnModule (mi_module iface) + sig_of <- case mi_sig_of iface of + Nothing -> return Nothing + Just x -> fmap Just (rnModule x) + exports <- mapM rnAvailInfo (mi_exports iface) + decls <- mapM rnIfaceDecl' (mi_decls iface) + insts <- mapM rnIfaceClsInst (mi_insts iface) + fams <- mapM rnIfaceFamInst (mi_fam_insts iface) + deps <- rnDependencies (mi_deps iface) + defaults <- mapM rnIfaceDefault (mi_defaults iface) + -- TODO: + -- mi_rules + return $ iface + & set_mi_module mod + & set_mi_sig_of sig_of + & set_mi_insts insts + & set_mi_fam_insts fams + & set_mi_exports exports + & set_mi_decls decls + & set_mi_deps deps + & set_mi_defaults defaults + +-- | Rename just the exports of a 'ModIface'. Useful when we're doing +-- shaping prior to signature merging. +rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either (Messages TcRnMessage) [AvailInfo]) +rnModExports hsc_env insts iface + = initRnIface hsc_env iface insts Nothing + $ mapM rnAvailInfo (mi_exports iface) + +rnDependencies :: Rename Dependencies +rnDependencies deps0 = do + deps1 <- dep_orphs_update deps0 (rnDepModules dep_orphs) + dep_finsts_update deps1 (rnDepModules dep_finsts) + +rnDepModules :: (Dependencies -> [Module]) -> [Module] -> ShIfM [Module] +rnDepModules sel mods = do + hsc_env <- getTopEnv + hmap <- getHoleSubst + -- NB: It's not necessary to test if we're doing signature renaming, + -- because ModIface will never contain module reference for itself + -- in these dependencies. + fmap (nubSort . concat) . T.forM mods $ \mod -> do + -- For holes, its necessary to "see through" the instantiation + -- of the hole to get accurate family instance dependencies. + -- For example, if B imports , and is instantiated with + -- F, we must grab and include all of the dep_finsts from + -- F to have an accurate transitive dep_finsts list. + -- + -- However, we MUST NOT do this for regular modules. + -- First, for efficiency reasons, doing this + -- bloats the dep_finsts list, because we *already* had + -- those modules in the list (it wasn't a hole module, after + -- all). But there's a second, more important correctness + -- consideration: we perform module renaming when running + -- --abi-hash. In this case, GHC's contract to the user is that + -- it will NOT go and read out interfaces of any dependencies + -- (https://github.com/haskell/cabal/issues/3633); the point of + -- --abi-hash is just to get a hash of the on-disk interfaces + -- for this *specific* package. If we go off and tug on the + -- interface for /everything/ in dep_finsts, we're gonna have a + -- bad time. (It's safe to do this for hole modules, though, + -- because the hmap for --abi-hash is always trivial, so the + -- interface we request is local. Though, maybe we ought + -- not to do it in this case either...) + -- + -- This mistake was bug #15594. + let mod' = renameHoleModule (hsc_units hsc_env) hmap mod + if isHoleModule mod + then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env + $ loadSysInterface (text "rnDepModule") mod' + return (mod' : sel (mi_deps iface)) + else return [mod'] + +{- +************************************************************************ +* * + ModIface substitution +* * +************************************************************************ +-} + +-- | Run a computation in the 'ShIfM' monad. +initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape + -> ShIfM a -> IO (Either (Messages TcRnMessage) a) +initRnIface hsc_env iface insts nsubst do_this = do + errs_var <- newIORef emptyMessages + let hsubst = listToUFM insts + rn_mod = renameHoleModule (hsc_units hsc_env) hsubst + env = ShIfEnv { + sh_if_module = rn_mod (mi_module iface), + sh_if_semantic_module = rn_mod (mi_semantic_module iface), + sh_if_hole_subst = listToUFM insts, + sh_if_shape = nsubst, + sh_if_errs = errs_var + } + -- Modeled off of 'initTc' + res <- initTcRnIf 'c' hsc_env env () $ tryM do_this + msgs <- readIORef errs_var + case res of + Left _ -> return (Left msgs) + Right r | not (isEmptyMessages msgs) -> return (Left msgs) + | otherwise -> return (Right r) + +-- | Environment for 'ShIfM' monads. +data ShIfEnv = ShIfEnv { + -- What we are renaming the ModIface to. It assumed that + -- the original mi_module of the ModIface is + -- @generalizeModule (mi_module iface)@. + sh_if_module :: Module, + -- The semantic module that we are renaming to + sh_if_semantic_module :: Module, + -- Cached hole substitution, e.g. + -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnit . sh_if_module@ + sh_if_hole_subst :: ShHoleSubst, + -- An optional name substitution to be applied when renaming + -- the names in the interface. If this is 'Nothing', then + -- we just load the target interface and look at the export + -- list to determine the renaming. + sh_if_shape :: Maybe NameShape, + -- Mutable reference to keep track of diagnostics (similar to 'tcl_errs') + sh_if_errs :: IORef (Messages TcRnMessage) + } + +getHoleSubst :: ShIfM ShHoleSubst +getHoleSubst = fmap sh_if_hole_subst getGblEnv + +type ShIfM = TcRnIf ShIfEnv () +type Rename a = a -> ShIfM a + + +rnModule :: Rename Module +rnModule mod = do + hmap <- getHoleSubst + unit_state <- hsc_units <$> getTopEnv + return (renameHoleModule unit_state hmap mod) + +rnAvailInfo :: Rename AvailInfo +rnAvailInfo (Avail c) = Avail <$> rnIfaceGlobal c +rnAvailInfo (AvailTC n ns) = do + -- Why don't we rnIfaceGlobal the availName itself? It may not + -- actually be exported by the module it putatively is from, in + -- which case we won't be able to tell what the name actually + -- is. But for the availNames they MUST be exported, so they + -- will rename fine. + ns' <- mapM rnIfaceGlobal ns + case ns' of + [] -> panic "rnAvailInfoEmpty AvailInfo" + (rep:rest) -> assertPpr (all ((== childModule rep) . childModule) rest) + (ppr rep $$ hcat (map ppr rest)) $ do + n' <- setNameModule (Just (childModule rep)) n + return (AvailTC n' ns') + where + childModule = nameModule + +rnFieldLabel :: Rename FieldLabel +rnFieldLabel fl = do + sel' <- rnIfaceGlobal (flSelector fl) + return (fl { flSelector = sel' }) + + +-- | The key function. This gets called on every Name embedded +-- inside a ModIface. Our job is to take a Name from some +-- generalized unit ID p[A=\, B=\], and change +-- it to the correct name for a (partially) instantiated unit +-- ID, e.g. p[A=q[]:A, B=\]. +-- +-- There are two important things to do: +-- +-- If a hole is substituted with a real module implementation, +-- we need to look at that actual implementation to determine what +-- the true identity of this name should be. We'll do this by +-- loading that module's interface and looking at the mi_exports. +-- +-- However, there is one special exception: when we are loading +-- the interface of a requirement. In this case, we may not have +-- the "implementing" interface, because we are reading this +-- interface precisely to "merge it in". +-- +-- External case: +-- p[A=\]:A (and thisUnitId is something else) +-- We are loading this in order to determine B.hi! So +-- don't load B.hi to find the exports. +-- +-- Local case: +-- p[A=\]:A (and thisUnitId is p[A=\]) +-- This should not happen, because the rename is not necessary +-- in this case, but if it does we shouldn't load A.hi! +-- +-- Compare me with 'tcIfaceGlobal'! + +-- In effect, this function needs compute the name substitution on the +-- fly. What it has is the name that we would like to substitute. +-- If the name is not a hole name {M.x} (e.g. isHoleModule) then +-- no renaming can take place (although the inner hole structure must +-- be updated to account for the hole module renaming.) +rnIfaceGlobal :: Name -> ShIfM Name +rnIfaceGlobal n = do + hsc_env <- getTopEnv + let unit_state = hsc_units hsc_env + home_unit = hsc_home_unit hsc_env + iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv + mb_nsubst <- fmap sh_if_shape getGblEnv + hmap <- getHoleSubst + let m = nameModule n + m' = renameHoleModule unit_state hmap m + case () of + -- Did we encounter {A.T} while renaming p[A=]:A? If so, + -- do NOT assume B.hi is available. + -- In this case, rename {A.T} to {B.T} but don't look up exports. + _ | m' == iface_semantic_mod + , isHoleModule m' + -- NB: this could be Nothing for computeExports, we have + -- nothing to say. + -> do n' <- setNameModule (Just m') n + case mb_nsubst of + Nothing -> return n' + Just nsubst -> + case maybeSubstNameShape nsubst n' of + -- TODO: would love to have context + -- TODO: This will give an unpleasant message if n' + -- is a constructor; then we'll suggest adding T + -- but it won't work. + Nothing -> + failWithRn $ TcRnIdNotExportedFromLocalSig n' + Just n'' -> return n'' + -- Fastpath: we are renaming p[H=]:A.T, in which case the + -- export list is irrelevant. + | not (isHoleModule m) + -> setNameModule (Just m') n + -- The substitution was from to p[]:A. + -- But this does not mean {A.T} goes to p[]:A.T: + -- p[]:A may reexport T from somewhere else. Do the name + -- substitution. Furthermore, we need + -- to make sure we pick the accurate name NOW, + -- or we might accidentally reject a merge. + | otherwise + -> do -- Make sure we look up the local interface if substitution + -- went from to . + let m'' = if isHoleModule m' + -- Pull out the local guy!! + then mkHomeModule home_unit (moduleName m') + else m' + iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env + $ loadSysInterface (text "rnIfaceGlobal") m'' + let nsubst = mkNameShape (moduleName m) (mi_exports iface) + case maybeSubstNameShape nsubst n of + -- NB: report m' because it's more user-friendly + Nothing -> failWithRn $ TcRnIdNotExportedFromModuleSig n m' + Just n' -> return n' + +-- | Rename an implicit name, e.g., a DFun or coercion axiom. +-- Here is where we ensure that DFuns have the correct module as described in +-- Note [rnIfaceNeverExported]. +rnIfaceNeverExported :: Name -> ShIfM Name +rnIfaceNeverExported name = do + hmap <- getHoleSubst + unit_state <- hsc_units <$> getTopEnv + iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv + let m = renameHoleModule unit_state hmap $ nameModule name + -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined. + massertPpr (iface_semantic_mod == m) (ppr iface_semantic_mod <+> ppr m) + setNameModule (Just m) name + +-- Note [rnIfaceNeverExported] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- For the high-level overview, see +-- Note [Handling never-exported TyThings under Backpack] +-- +-- When we see a reference to an entity that was defined in a signature, +-- 'rnIfaceGlobal' relies on the identifier in question being part of the +-- exports of the implementing 'ModIface', so that we can use the exports to +-- decide how to rename the identifier. Unfortunately, references to 'DFun's +-- and 'CoAxiom's will run into trouble under this strategy, because they are +-- never exported. +-- +-- Let us consider first what should happen in the absence of promotion. In +-- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside +-- the signature *that is defining it* (as there are no Core terms in +-- typechecked-only interface files, there's no way for a reference to occur +-- besides from the defining 'ClsInst' or closed type family). Thus, +-- it doesn't really matter what names we give the DFun/CoAxiom, as long +-- as it's consistent between the declaration site and the use site. +-- +-- We have to make sure that these bogus names don't get propagated, +-- but it is fine: see Note [Signature merging DFuns] for the fixups +-- to the names we do before writing out the merged interface. +-- (It's even easier for instantiation, since the DFuns all get +-- dropped entirely; the instances are reexported implicitly.) +-- +-- Unfortunately, this strategy is not enough in the presence of promotion +-- (see bug #13149), where modules which import the signature may make +-- reference to their coercions. It's not altogether clear how to +-- fix this case, but it is definitely a bug! + +-- PILES AND PILES OF BOILERPLATE + +-- | Rename an 'IfaceClsInst', with special handling for an associated +-- dictionary function. +rnIfaceClsInst :: Rename IfaceClsInst +rnIfaceClsInst cls_inst = do + n <- rnIfaceGlobal (ifInstCls cls_inst) + tys <- mapM rnRoughMatchTyCon (ifInstTys cls_inst) + + dfun <- rnIfaceNeverExported (ifDFun cls_inst) + return cls_inst { ifInstCls = n + , ifInstTys = tys + , ifDFun = dfun + } + +rnIfaceDefault :: Rename IfaceDefault +rnIfaceDefault cls_inst = do + n <- rnIfaceGlobal (ifDefaultCls cls_inst) + tys <- mapM rnIfaceType (ifDefaultTys cls_inst) + return cls_inst { ifDefaultCls = n + , ifDefaultTys = tys + } + +rnRoughMatchTyCon :: Rename (Maybe IfaceTyCon) +rnRoughMatchTyCon Nothing = return Nothing +rnRoughMatchTyCon (Just tc) = Just <$> rnIfaceTyCon tc + +rnIfaceFamInst :: Rename IfaceFamInst +rnIfaceFamInst d = do + fam <- rnIfaceGlobal (ifFamInstFam d) + tys <- mapM rnRoughMatchTyCon (ifFamInstTys d) + axiom <- rnIfaceGlobal (ifFamInstAxiom d) + return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom } + +rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl) +rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl + +rnIfaceDecl :: Rename IfaceDecl +rnIfaceDecl d@IfaceId{} = do + name <- case ifIdDetails d of + IfDFunId -> rnIfaceNeverExported (ifName d) + _ | isDefaultMethodOcc (occName (ifName d)) + -> rnIfaceNeverExported (ifName d) + -- Typeable bindings. See Note [Grand plan for Typeable]. + _ | isTypeableBindOcc (occName (ifName d)) + -> rnIfaceNeverExported (ifName d) + | otherwise -> rnIfaceGlobal (ifName d) + ty <- rnIfaceType (ifType d) + details <- rnIfaceIdDetails (ifIdDetails d) + info <- rnIfaceIdInfo (ifIdInfo d) + return d { ifName = name + , ifType = ty + , ifIdDetails = details + , ifIdInfo = info + } +rnIfaceDecl d@IfaceData{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + ctxt <- mapM rnIfaceType (ifCtxt d) + cons <- rnIfaceConDecls (ifCons d) + res_kind <- rnIfaceType (ifResKind d) + parent <- rnIfaceTyConParent (ifParent d) + return d { ifName = name + , ifBinders = binders + , ifCtxt = ctxt + , ifCons = cons + , ifResKind = res_kind + , ifParent = parent + } +rnIfaceDecl d@IfaceSynonym{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + syn_kind <- rnIfaceType (ifResKind d) + syn_rhs <- rnIfaceType (ifSynRhs d) + return d { ifName = name + , ifBinders = binders + , ifResKind = syn_kind + , ifSynRhs = syn_rhs + } +rnIfaceDecl d@IfaceFamily{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + fam_kind <- rnIfaceType (ifResKind d) + fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d) + return d { ifName = name + , ifBinders = binders + , ifResKind = fam_kind + , ifFamFlav = fam_flav + } +rnIfaceDecl d@IfaceClass{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + body <- rnIfaceClassBody (ifBody d) + return d { ifName = name + , ifBinders = binders + , ifBody = body + } +rnIfaceDecl d@IfaceAxiom{} = do + name <- rnIfaceNeverExported (ifName d) + tycon <- rnIfaceTyCon (ifTyCon d) + ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d) + return d { ifName = name + , ifTyCon = tycon + , ifAxBranches = ax_branches + } +rnIfaceDecl d@IfacePatSyn{} = do + name <- rnIfaceGlobal (ifName d) + let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b + pat_matcher <- rnPat (ifPatMatcher d) + pat_builder <- T.traverse rnPat (ifPatBuilder d) + pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d) + pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d) + pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d) + pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d) + pat_args <- mapM rnIfaceType (ifPatArgs d) + pat_ty <- rnIfaceType (ifPatTy d) + return d { ifName = name + , ifPatMatcher = pat_matcher + , ifPatBuilder = pat_builder + , ifPatUnivBndrs = pat_univ_bndrs + , ifPatExBndrs = pat_ex_bndrs + , ifPatProvCtxt = pat_prov_ctxt + , ifPatReqCtxt = pat_req_ctxt + , ifPatArgs = pat_args + , ifPatTy = pat_ty + } + +rnIfaceClassBody :: Rename IfaceClassBody +rnIfaceClassBody IfAbstractClass = return IfAbstractClass +rnIfaceClassBody d@IfConcreteClass{} = do + ctxt <- mapM rnIfaceType (ifClassCtxt d) + ats <- mapM rnIfaceAT (ifATs d) + sigs <- mapM rnIfaceClassOp (ifSigs d) + return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs } + +rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav +rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs))) + = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n + <*> mapM rnIfaceAxBranch axs) +rnIfaceFamTyConFlav flav = pure flav + +rnIfaceAT :: Rename IfaceAT +rnIfaceAT (IfaceAT decl mb_ty) + = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty + +rnIfaceTyConParent :: Rename IfaceTyConParent +rnIfaceTyConParent (IfDataInstance n tc args) + = IfDataInstance <$> rnIfaceGlobal n + <*> rnIfaceTyCon tc + <*> rnIfaceAppArgs args +rnIfaceTyConParent IfNoParent = pure IfNoParent + +rnIfaceConDecls :: Rename IfaceConDecls +rnIfaceConDecls (IfDataTyCon type_data ds) + = IfDataTyCon type_data <$> mapM rnIfaceConDecl ds +rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d +rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon + +rnIfaceConDecl :: Rename IfaceConDecl +rnIfaceConDecl d = do + con_name <- rnIfaceGlobal (ifConName d) + con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d) + con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d) + let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t + con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d) + con_ctxt <- mapM rnIfaceType (ifConCtxt d) + con_arg_tys <- mapM rnIfaceScaledType (ifConArgTys d) + con_fields <- mapM rnFieldLabel (ifConFields d) + let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co + rnIfaceBang bang = pure bang + con_stricts <- mapM rnIfaceBang (ifConStricts d) + return d { ifConName = con_name + , ifConExTCvs = con_ex_tvs + , ifConUserTvBinders = con_user_tvbs + , ifConEqSpec = con_eq_spec + , ifConCtxt = con_ctxt + , ifConArgTys = con_arg_tys + , ifConFields = con_fields + , ifConStricts = con_stricts + } + +rnIfaceClassOp :: Rename IfaceClassOp +rnIfaceClassOp (IfaceClassOp n ty dm) = + IfaceClassOp <$> rnIfaceGlobal n + <*> rnIfaceType ty + <*> rnMaybeDefMethSpec dm + +rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType)) +rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty +rnMaybeDefMethSpec mb = return mb + +rnIfaceAxBranch :: Rename IfaceAxBranch +rnIfaceAxBranch d = do + ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d) + lhs <- rnIfaceAppArgs (ifaxbLHS d) + rhs <- rnIfaceType (ifaxbRHS d) + return d { ifaxbTyVars = ty_vars + , ifaxbLHS = lhs + , ifaxbRHS = rhs } + +rnIfaceIdInfo :: Rename IfaceIdInfo +rnIfaceIdInfo = mapM rnIfaceInfoItem + +rnIfaceInfoItem :: Rename IfaceInfoItem +rnIfaceInfoItem (HsUnfold lb if_unf) + = HsUnfold lb <$> rnIfaceUnfolding if_unf +rnIfaceInfoItem i + = pure i + +rnIfaceUnfolding :: Rename IfaceUnfolding +rnIfaceUnfolding (IfCoreUnfold src cache guide if_expr) + = IfCoreUnfold src cache guide <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfDFunUnfold bs ops) + = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops + +rnIfaceExpr :: Rename IfaceExpr +rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name) +rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl +rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty +rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co +rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args +rnIfaceExpr (IfaceLam lam_bndr expr) + = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr +rnIfaceExpr (IfaceApp fun arg) + = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg +rnIfaceExpr (IfaceCase scrut case_bndr alts) + = IfaceCase <$> rnIfaceExpr scrut + <*> pure case_bndr + <*> mapM rnIfaceAlt alts +rnIfaceExpr (IfaceECase scrut ty) + = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty +rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs) + <*> rnIfaceExpr body +rnIfaceExpr (IfaceLet (IfaceRec pairs) body) + = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) -> + (,) <$> rnIfaceLetBndr bndr + <*> rnIfaceExpr rhs) pairs) + <*> rnIfaceExpr body +rnIfaceExpr (IfaceCast expr co) + = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co +rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit) +rnIfaceExpr (IfaceLitRubbish tc rep) = IfaceLitRubbish tc <$> rnIfaceType rep +rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty +rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr + +rnIfaceBndrs :: Rename [IfaceBndr] +rnIfaceBndrs = mapM rnIfaceBndr + +rnIfaceBndr :: Rename IfaceBndr +rnIfaceBndr (IfaceIdBndr (w, fs, ty)) = IfaceIdBndr <$> ((,,) w fs <$> rnIfaceType ty) +rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr + +rnIfaceTvBndr :: Rename IfaceTvBndr +rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind + +rnIfaceTyConBinder :: Rename IfaceTyConBinder +rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis + +rnIfaceAlt :: Rename IfaceAlt +rnIfaceAlt (IfaceAlt conalt names rhs) + = IfaceAlt <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs + +rnIfaceConAlt :: Rename IfaceConAlt +rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ +rnIfaceConAlt alt = pure alt + +rnIfaceLetBndr :: Rename IfaceLetBndr +rnIfaceLetBndr (IfLetBndr fs ty info jpi) + = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi + +rnIfaceLamBndr :: Rename IfaceLamBndr +rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot + +rnIfaceMCo :: Rename IfaceMCoercion +rnIfaceMCo IfaceMRefl = pure IfaceMRefl +rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co + +rnIfaceCo :: Rename IfaceCoercion +rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty +rnIfaceCo (IfaceGReflCo role ty mco) = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco +rnIfaceCo (IfaceFunCo role w co1 co2) = IfaceFunCo role <$> rnIfaceCo w <*> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceTyConAppCo role tc cos) = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos +rnIfaceCo (IfaceAppCo co1 co2) = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c) +rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl +rnIfaceCo (IfaceHoleCo lcl) = IfaceHoleCo <$> pure lcl +rnIfaceCo (IfaceSymCo c) = IfaceSymCo <$> rnIfaceCo c +rnIfaceCo (IfaceTransCo c1 c2) = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 +rnIfaceCo (IfaceInstCo c1 c2) = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 +rnIfaceCo (IfaceSelCo d c) = IfaceSelCo d <$> rnIfaceCo c +rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c +rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c +rnIfaceCo (IfaceAxiomCo ax cos) = IfaceAxiomCo ax <$> mapM rnIfaceCo cos +rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c +rnIfaceCo (IfaceForAllCo bndr visL visR co1 co2) + = (\bndr' co1' co2' -> IfaceForAllCo bndr' visL visR co1' co2') + <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceUnivCo s r t1 t2 deps) + = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2 <*> mapM rnIfaceCo deps + +rnIfaceTyCon :: Rename IfaceTyCon +rnIfaceTyCon (IfaceTyCon n info) + = IfaceTyCon <$> rnIfaceGlobal n <*> pure info + +rnIfaceExprs :: Rename [IfaceExpr] +rnIfaceExprs = mapM rnIfaceExpr + +rnIfaceIdDetails :: Rename IfaceIdDetails +rnIfaceIdDetails (IfRecSelId (Left tc) con naughty fl) + = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> rnIfaceGlobal con <*> pure naughty <*> rnFieldLabel fl +rnIfaceIdDetails (IfRecSelId (Right decl) con naughty fl) + = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> rnIfaceGlobal con <*> pure naughty <*> rnFieldLabel fl +rnIfaceIdDetails details + = pure details + +rnIfaceType :: Rename IfaceType +rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n) +rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n) +rnIfaceType (IfaceAppTy t1 t2) + = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2 +rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l) +rnIfaceType (IfaceFunTy af w t1 t2) + = IfaceFunTy af <$> rnIfaceType w <*> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceType (IfaceTupleTy s i tks) + = IfaceTupleTy s i <$> rnIfaceAppArgs tks +rnIfaceType (IfaceTyConApp tc tks) + = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks +rnIfaceType (IfaceForAllTy tv t) + = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t +rnIfaceType (IfaceCoercionTy co) + = IfaceCoercionTy <$> rnIfaceCo co +rnIfaceType (IfaceCastTy ty co) + = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co + +rnIfaceScaledType :: Rename (IfaceMult, IfaceType) +rnIfaceScaledType (m, t) = (,) <$> rnIfaceType m <*> rnIfaceType t + +rnIfaceForAllBndr :: Rename (VarBndr IfaceBndr flag) +rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis + +rnIfaceAppArgs :: Rename IfaceAppArgs +rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a + <*> rnIfaceAppArgs ts +rnIfaceAppArgs IA_Nil = pure IA_Nil diff --git a/GHC/Iface/Syntax.hs b/GHC/Iface/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Syntax.hs @@ -0,0 +1,3256 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveTraversable #-} + +module GHC.Iface.Syntax ( + module GHC.Iface.Type, + + IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), + IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, + IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding, + IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..), + IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceWarnings(..), IfaceWarningTxt(..), IfaceStringLiteral(..), + IfaceDefault(..), IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), + IfaceClassBody(..), IfaceBooleanFormula(..), + IfaceBang(..), + IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), + IfaceAxBranch(..), + IfaceTyConParent(..), + IfaceCompleteMatch(..), + IfaceLFInfo(..), IfaceTopBndrInfo(..), + IfaceImport(..), + ifImpModule, + ImpIfaceList(..), IfaceExport, + + -- * Binding names + IfaceTopBndr, + putIfaceTopBndr, getIfaceTopBndr, + + -- Misc + ifaceDeclImplicitBndrs, visibleIfConDecls, + ifaceDeclFingerprints, + fromIfaceWarnings, + fromIfaceWarningTxt, + -- Free Names + freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, + freeNamesIfConDecls, + + -- Pretty printing + pprIfaceExpr, + pprIfaceDecl, + AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader + ) where + +import GHC.Prelude + +import GHC.Builtin.Names(mkUnboundName) +import GHC.Data.FastString +import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue) + +import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey, + constraintKindTyConKey ) +import GHC.Types.Unique ( hasKey ) +import GHC.Iface.Type +import GHC.Iface.Recomp.Binary +import GHC.Core( IsOrphan, isOrphan, UnfoldingCache(..) ) +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core.Class +import GHC.Types.FieldLabel +import GHC.Core.Coercion.Axiom ( BranchIndex ) +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.CostCentre +import GHC.Types.Literal +import GHC.Types.Avail +import GHC.Types.ForeignCall +import GHC.Types.Annotations( AnnPayload, AnnTarget ) +import GHC.Types.Basic +import GHC.Types.Tickish +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Types.SrcLoc +import GHC.Types.SourceText +import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike ) +import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) +import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) +import GHC.Builtin.Types ( constraintKindTyConName ) +import GHC.Stg.EnforceEpt.TagSig +import GHC.Parser.Annotation (noLocA) +import GHC.Hs.Extension ( GhcRn ) +import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) + +import GHC.Utils.Lexeme (isLexSym) +import GHC.Utils.Fingerprint +import GHC.Utils.Binary +import GHC.Utils.Binary.Typeable () -- instance Binary AnnPayload +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, + zipWithEqual ) + +import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..)) + +import Control.Monad +import Control.DeepSeq +import Data.Proxy +import qualified Data.Set as Set + +infixl 3 &&& + +{- +************************************************************************ +* * + Declarations +* * +************************************************************************ +-} + +type IfaceExport = AvailInfo + +data IfaceImport = IfaceImport ImpDeclSpec ImpIfaceList + +data ImpIfaceList + = ImpIfaceAll -- ^ no user import list + | ImpIfaceExplicit + { iil_avails :: !DetOrdAvails + , iil_non_explicit_parents :: ![Name] + } + | ImpIfaceEverythingBut ![Name] + +-- | Extract the imported module from an IfaceImport +ifImpModule :: IfaceImport -> Module +ifImpModule (IfaceImport declSpec _) = is_mod declSpec + +instance Binary IfaceImport where + put_ bh (IfaceImport declSpec ifaceList) = do + put_ bh declSpec + put_ bh ifaceList + get bh = do + declSpec <- get bh + ifaceList <- get bh + return (IfaceImport declSpec ifaceList) + +instance Binary ImpIfaceList where + put_ bh ImpIfaceAll = putByte bh 0 + put_ bh (ImpIfaceExplicit env implicit_parents) = do + putByte bh 1 + put_ bh env + put_ bh implicit_parents + put_ bh (ImpIfaceEverythingBut ns) = do + putByte bh 2 + put_ @[Name] bh ns + get bh = do + tag <- getByte bh + case tag of + 0 -> return ImpIfaceAll + 1 -> do + env <- get bh + implicit_parents <- get bh + return $ ImpIfaceExplicit env implicit_parents + 2 -> do + ns <- get @[Name] bh + return $ ImpIfaceEverythingBut ns + _ -> fail $ "instance Binary ImpIfaceList: Invalid tag " ++ show tag + +-- | A binding top-level 'Name' in an interface file (e.g. the name of an +-- 'IfaceDecl'). +type IfaceTopBndr = Name + -- It's convenient to have a Name in the Iface syntax, although in each + -- case the namespace is implied by the context. However, having a + -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints + -- very convenient. Moreover, having the key of the binder means that + -- we can encode known-key things cleverly in the symbol table. See Note + -- [Symbol table representation of Names] + -- + -- We don't serialise the namespace onto the disk though; rather we + -- drop it when serialising and add it back in when deserialising. + +getIfaceTopBndr :: ReadBinHandle -> IO IfaceTopBndr +getIfaceTopBndr bh = get bh + +putIfaceTopBndr :: WriteBinHandle -> IfaceTopBndr -> IO () +putIfaceTopBndr bh name = + case findUserDataWriter (Proxy @BindingName) bh of + tbl -> + --pprTrace "putIfaceTopBndr" (ppr name) $ + putEntry tbl bh (BindingName name) + +data IfaceDecl + = IfaceId { ifName :: IfaceTopBndr, + ifType :: IfaceType, + ifIdDetails :: IfaceIdDetails, + ifIdInfo :: IfaceIdInfo + } + + | IfaceData { ifName :: IfaceTopBndr, -- Type constructor + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceType, -- Result kind of type constructor + ifCType :: Maybe CType, -- C type for CAPI FFI + ifRoles :: [Role], -- Roles + ifCtxt :: IfaceContext, -- The "stupid theta" + ifCons :: IfaceConDecls, -- Includes new/data/data family info + ifGadtSyntax :: Bool, -- True <=> declared using + -- GADT syntax + ifParent :: IfaceTyConParent -- The axiom, for a newtype, + -- or data/newtype family instance + } + + | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor + ifRoles :: [Role], -- Roles + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceKind, -- Kind of the *result* + ifSynRhs :: IfaceType } + + | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor + ifResVar :: Maybe IfLclName, -- Result variable name, used + -- only for pretty-printing + -- with --show-iface + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceKind, -- Kind of the *tycon* + ifFamFlav :: IfaceFamTyConFlav, + ifFamInj :: Injectivity } -- injectivity information + + | IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon + ifRoles :: [Role], -- Roles + ifBinders :: [IfaceTyConBinder], + ifFDs :: [FunDep IfLclName], -- Functional dependencies + ifBody :: IfaceClassBody -- Methods, superclasses, ATs + } + + | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name + ifTyCon :: IfaceTyCon, -- LHS TyCon + ifRole :: Role, -- Role of axiom + ifAxBranches :: [IfaceAxBranch] -- Branches + } + + | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym + ifPatIsInfix :: Bool, + ifPatMatcher :: (IfExtName, Bool), + ifPatBuilder :: Maybe (IfExtName, Bool), + -- Everything below is redundant, + -- but needed to implement pprIfaceDecl + ifPatUnivBndrs :: [IfaceForAllSpecBndr], + ifPatExBndrs :: [IfaceForAllSpecBndr], + ifPatProvCtxt :: IfaceContext, + ifPatReqCtxt :: IfaceContext, + ifPatArgs :: [IfaceType], + ifPatTy :: IfaceType, + ifFieldLabels :: [FieldLabel] } + +-- See also 'ClassBody' +data IfaceClassBody + -- Abstract classes don't specify their body; they only occur in @hs-boot@ and + -- @hsig@ files. + = IfAbstractClass + | IfConcreteClass { + ifClassCtxt :: IfaceContext, -- Super classes + ifATs :: [IfaceAT], -- Associated type families + ifSigs :: [IfaceClassOp], -- Method signatures + ifMinDef :: IfaceBooleanFormula, -- Minimal complete definition + ifUnary :: Bool -- This is a unary class + -- NB: in principle ifUnary is redundant; it can be deduced from + -- the number and types of class ops. In practice, in interface + -- files those types are knot tied, and it's very easy to get a + -- black hole. Easiest thing: let the definition module decide if + -- it is a unary class, and communicate that through IfaceClassBody + -- See (UCM12) in Note [Unary class magic] in GHC.Core.TyCon + } + +-- See also 'BooleanFormula' +data IfaceBooleanFormula + = IfVar IfLclName + | IfAnd [IfaceBooleanFormula] + | IfOr [IfaceBooleanFormula] + | IfParens IfaceBooleanFormula + deriving Eq + + +data IfaceTyConParent + = IfNoParent + | IfDataInstance + IfExtName -- Axiom name + IfaceTyCon -- Family TyCon (pretty-printing only, not used in GHC.IfaceToCore) + -- see Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr + IfaceAppArgs -- Arguments of the family TyCon + +data IfaceFamTyConFlav + = IfaceDataFamilyTyCon -- Data family + | IfaceOpenSynFamilyTyCon + | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch])) + -- ^ Name of associated axiom and branches for pretty printing purposes, + -- or 'Nothing' for an empty closed family without an axiom + -- See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr" + | IfaceAbstractClosedSynFamilyTyCon + | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only + +data IfaceClassOp + = IfaceClassOp IfaceTopBndr + IfaceType -- Class op type + (Maybe (DefMethSpec IfaceType)) -- Default method + -- The types of both the class op itself, + -- and the default method, are *not* quantified + -- over the class variables + +data IfaceAT = IfaceAT -- See GHC.Core.Class.ClassATItem + IfaceDecl -- The associated type declaration + (Maybe IfaceType) -- Default associated type instance, if any + + +-- This is just like CoAxBranch +data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] + , ifaxbEtaTyVars :: [IfaceTvBndr] + , ifaxbCoVars :: [IfaceIdBndr] + , ifaxbLHS :: IfaceAppArgs + , ifaxbRoles :: [Role] + , ifaxbRHS :: IfaceType + , ifaxbIncomps :: [BranchIndex] } + -- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom + +data IfaceConDecls + = IfAbstractTyCon -- c.f TyCon.AbstractTyCon + | IfDataTyCon !Bool [IfaceConDecl] -- Data type decls + -- The Bool is True for "type data" declarations. + -- see Note [Type data declarations] in GHC.Rename.Module + | IfNewTyCon IfaceConDecl -- Newtype decls + +-- For IfDataTyCon and IfNewTyCon we store: +-- * the data constructor(s); +-- The field labels are stored individually in the IfaceConDecl +-- (there is some redundancy here, because a field label may occur +-- in multiple IfaceConDecls and represent the same field label) + +data IfaceConDecl + = IfCon { + ifConName :: IfaceTopBndr, -- Constructor name + ifConWrapper :: Bool, -- True <=> has a wrapper + ifConInfix :: Bool, -- True <=> declared infix + + -- The universal type variables are precisely those + -- of the type constructor of this data constructor + -- This is *easy* to guarantee when creating the IfCon + -- but it's not so easy for the original TyCon/DataCon + -- So this guarantee holds for IfaceConDecl, but *not* for DataCon + + ifConExTCvs :: [IfaceBndr], -- Existential ty/covars + ifConUserTvBinders :: [IfaceForAllBndr], + -- The tyvars, in the order the user wrote them + -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the + -- set of tyvars (*not* covars) of ifConExTCvs, unioned + -- with the set of ifBinders (from the parent IfaceDecl) + -- whose tyvars do not appear in ifConEqSpec + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon + ifConEqSpec :: IfaceEqSpec, -- Equality constraints + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [(IfaceMult, IfaceType)],-- Arg types + ifConFields :: [FieldLabel], -- ...ditto... (field labels) + ifConStricts :: [IfaceBang], + -- Empty (meaning all lazy), + -- or 1-1 corresp with arg tys + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make + ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts + +type IfaceEqSpec = [(IfLclName,IfaceType)] + +-- | This corresponds to an HsImplBang; that is, the final +-- implementation decision about the data constructor arg +data IfaceBang + = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion + +-- | This corresponds to HsSrcBang +data IfaceSrcBang + = IfSrcBang SrcUnpackedness SrcStrictness + +-- See Note [Named default declarations] in GHC.Tc.Gen.Default +-- | Exported named defaults +data IfaceDefault + = IfaceDefault { ifDefaultCls :: IfExtName, -- Defaulted class + ifDefaultTys :: [IfaceType], -- List of defaults + ifDefaultWarn :: Maybe IfaceWarningTxt } + +data IfaceClsInst + = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst + ifDFun :: IfExtName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: IsOrphan, -- See Note [Orphans] in GHC.Core.InstEnv + ifInstWarn :: Maybe IfaceWarningTxt } + -- Warning emitted when the instance is used + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict + -- There's always a separate IfaceDecl for the DFun, which gives + -- its IdInfo with its full type and version number. + -- The instance declarations taken together have a version number, + -- and we don't want that to wobble gratuitously + -- If this instance decl is *used*, we'll record a usage on the dfun; + -- and if the head does not change it won't be used if it wasn't before + +-- The ifFamInstTys field of IfaceFamInst contains a list of the rough +-- match types +data IfaceFamInst + = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name + , ifFamInstTys :: [Maybe IfaceTyCon] -- See above + , ifFamInstAxiom :: IfExtName -- The axiom + , ifFamInstOrph :: IsOrphan -- Just like IfaceClsInst + } + +data IfaceRule + = IfaceRule { + ifRuleName :: RuleName, + ifActivation :: Activation, + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleAuto :: Bool, + ifRuleOrph :: IsOrphan -- Just like IfaceClsInst + } + +data IfaceWarnings + = IfWarnAll IfaceWarningTxt + | IfWarnSome [(OccName, IfaceWarningTxt)] + [(IfExtName, IfaceWarningTxt)] + +data IfaceWarningTxt + = IfWarningTxt (Maybe WarningCategory) SourceText [(IfaceStringLiteral, [IfExtName])] + | IfDeprecatedTxt SourceText [(IfaceStringLiteral, [IfExtName])] + +data IfaceStringLiteral + = IfStringLiteral SourceText FastString + +data IfaceAnnotation + = IfaceAnnotation { + ifAnnotatedTarget :: IfaceAnnTarget, + ifAnnotatedValue :: AnnPayload + } + +type IfaceAnnTarget = AnnTarget OccName + +data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] (Maybe IfExtName) + +instance Outputable IfaceCompleteMatch where + ppr (IfaceCompleteMatch cls mtc) = text "COMPLETE" <> colon <+> ppr cls <+> case mtc of + Nothing -> empty + Just tc -> dcolon <+> ppr tc + +-- Here's a tricky case: +-- * Compile with -O module A, and B which imports A.f +-- * Change function f in A, and recompile without -O +-- * When we read in old A.hi we read in its IdInfo (as a thunk) +-- (In earlier GHCs we used to drop IdInfo immediately on reading, +-- but we do not do that now. Instead it's discarded when the +-- ModIface is read into the various decl pools.) +-- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *) +-- and so gives a new version. + +type IfaceIdInfo = [IfaceInfoItem] + +data IfaceInfoItem + = HsArity Arity + | HsDmdSig DmdSig + | HsCprSig CprSig + | HsInline InlinePragma + | HsUnfold Bool -- True <=> isStrongLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] + | HsNoCafRefs + | HsLFInfo IfaceLFInfo + | HsTagSig TagSig + +-- NB: Specialisations and rules come in separately and are +-- only later attached to the Id. Partial reason: some are orphans. + +data IfaceUnfolding + = IfCoreUnfold UnfoldingSource + IfUnfoldingCache -- See Note [Tying the 'CoreUnfolding' knot] + IfGuidance + IfaceExpr + | IfDFunUnfold [IfaceBndr] [IfaceExpr] + +type IfUnfoldingCache = UnfoldingCache + +data IfGuidance + = IfNoGuidance -- Compute it from the IfaceExpr + | IfWhen Arity Bool Bool -- Just like UnfWhen in Core.UnfoldingGuidance + +-- We only serialise the IdDetails of top-level Ids, and even then +-- we only need a very limited selection. Notably, none of the +-- implicit ones are needed here, because they are not put in +-- interface files + +data IfaceIdDetails + = IfVanillaId + | IfWorkerLikeId [CbvMark] + | IfRecSelId + { ifRecSelIdParent :: Either IfaceTyCon IfaceDecl + , ifRecSelFirstCon :: IfaceTopBndr + , ifRecSelIdIsNaughty :: Bool + , ifRecSelIdFieldLabel :: FieldLabel } + | IfDFunId + +-- | Iface type for LambdaFormInfo. Fields not relevant for imported Ids are +-- omitted in this type. +data IfaceLFInfo + = IfLFReEntrant !RepArity + | IfLFThunk + !Bool -- True <=> updatable + !Bool -- True <=> might be a function type + | IfLFCon !Name + | IfLFUnknown !Bool + | IfLFUnlifted + +instance Outputable IfaceLFInfo where + ppr (IfLFReEntrant arity) = + text "LFReEntrant" <+> ppr arity + + ppr (IfLFThunk updatable mb_fun) = + text "LFThunk" <+> parens + (text "updatable=" <> ppr updatable <+> + text "might_be_function=" <+> ppr mb_fun) + + ppr (IfLFCon con) = + text "LFCon" <> brackets (ppr con) + + ppr IfLFUnlifted = + text "LFUnlifted" + + ppr (IfLFUnknown fun_flag) = + text "LFUnknown" <+> ppr fun_flag + +instance Binary IfaceLFInfo where + put_ bh (IfLFReEntrant arity) = do + putByte bh 0 + put_ bh arity + put_ bh (IfLFThunk updatable mb_fun) = do + putByte bh 1 + put_ bh updatable + put_ bh mb_fun + put_ bh (IfLFCon con_name) = do + putByte bh 2 + put_ bh con_name + put_ bh (IfLFUnknown fun_flag) = do + putByte bh 3 + put_ bh fun_flag + put_ bh IfLFUnlifted = + putByte bh 4 + get bh = do + tag <- getByte bh + case tag of + 0 -> IfLFReEntrant <$> get bh + 1 -> IfLFThunk <$> get bh <*> get bh + 2 -> IfLFCon <$> get bh + 3 -> IfLFUnknown <$> get bh + 4 -> pure IfLFUnlifted + _ -> panic "Invalid byte" + +instance NFData IfaceLFInfo where + rnf = \case + IfLFReEntrant arity -> rnf arity + IfLFThunk updatable mb_fun -> rnf updatable `seq` rnf mb_fun + IfLFCon con -> rnf con + IfLFUnknown fun_flag -> rnf fun_flag + IfLFUnlifted -> () + +{- +Note [Versioning of instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See [https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#instances] + + +************************************************************************ +* * + Functions over declarations +* * +************************************************************************ +-} + +visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] +visibleIfConDecls (IfAbstractTyCon {}) = [] +visibleIfConDecls (IfDataTyCon _ cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] + +ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] +-- *Excludes* the 'main' name, but *includes* the implicitly-bound names +-- Deeply revolting, because it has to predict what gets bound, +-- especially the question of whether there's a wrapper for a datacon +-- See Note [Implicit TyThings] in GHC.Driver.Env + +-- N.B. the set of names returned here *must* match the set of TyThings +-- returned by GHC.Types.TyThing.implicitTyThings, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in GHC.IfaceToCore.tc_iface_decl_fingerprint +-- (see Note [Tricky iface loop] in GHC.Types.TyThing.) +-- The order of the list does not matter. + +ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) + = case cons of + IfAbstractTyCon {} -> [] + IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd + IfDataTyCon type_data cds + | type_data -> + -- Constructors in "type data" declarations have no implicits. + -- see Note [Type data declarations] in GHC.Rename.Module + [occName con_name | IfCon { ifConName = con_name } <- cds] + | otherwise -> concatMap ifaceConDeclImplicitBndrs cds + +ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass }) + = [] + +ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name + , ifBody = IfConcreteClass { + ifClassCtxt = sc_ctxt, + ifSigs = sigs, + ifATs = ats + }}) + = -- data constructor (DataCon namespace) + -- data worker (Id namespace) + -- no wrapper (class dictionaries never have a wrapper) + [dc_occ, dcww_occ] ++ + -- associated types + [occName (ifName at) | IfaceAT at _ <- ats ] ++ + -- superclass selectors + [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++ + -- operation selectors + [occName op | IfaceClassOp op _ _ <- sigs] + where + cls_tc_occ = occName cls_tc_name + n_ctxt = length sc_ctxt + dcww_occ = mkDataConWorkerOcc dc_occ + dc_occ = mkClassDataConOcc cls_tc_occ + +ifaceDeclImplicitBndrs _ = [] + +ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName] +ifaceConDeclImplicitBndrs (IfCon { + ifConWrapper = has_wrapper, ifConName = con_name }) + = [occName con_name, work_occ] ++ wrap_occs + where + con_occ = occName con_name + work_occ = mkDataConWorkerOcc con_occ -- Id namespace + wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace + | otherwise = [] + +-- ----------------------------------------------------------------------------- +-- The fingerprints of an IfaceDecl + + -- We better give each name bound by the declaration a + -- different fingerprint! So we calculate the fingerprint of + -- each binder by combining the fingerprint of the whole + -- declaration with the name of the binder. (#5614, #7215) +ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] +ifaceDeclFingerprints hash decl + = (getOccName decl, hash) : + [ (occ, computeFingerprint' (hash,occ)) + | occ <- ifaceDeclImplicitBndrs decl ] + where + computeFingerprint' = computeFingerprint (panic "ifaceDeclFingerprints") + +fromIfaceWarnings :: IfaceWarnings -> Warnings GhcRn +fromIfaceWarnings = \case + IfWarnAll txt -> WarnAll (fromIfaceWarningTxt txt) + IfWarnSome vs ds -> WarnSome [(occ, fromIfaceWarningTxt txt) | (occ, txt) <- vs] + [(occ, fromIfaceWarningTxt txt) | (occ, txt) <- ds] + +fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn +fromIfaceWarningTxt = \case + IfWarningTxt mb_cat src strs -> WarningTxt (noLocA . fromWarningCategory <$> mb_cat) src (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) + +fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn +fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names) + +fromIfaceStringLiteral :: IfaceStringLiteral -> StringLiteral +fromIfaceStringLiteral (IfStringLiteral st fs) = StringLiteral st fs Nothing + + +{- +************************************************************************ +* * + Expressions +* * +************************************************************************ +-} + +data IfaceExpr + = IfaceLcl IfLclName + | IfaceExt IfExtName + | IfaceType IfaceType + | IfaceCo IfaceCoercion + | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceLamBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName [IfaceAlt] + | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] + | IfaceLet (IfaceBinding IfaceLetBndr) IfaceExpr + | IfaceCast IfaceExpr IfaceCoercion + | IfaceLit Literal + | IfaceLitRubbish TypeOrConstraint IfaceType + -- See GHC.Types.Literal Note [Rubbish literals] item (6) + | IfaceFCall ForeignCall IfaceType + | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E + + +data IfaceTickish + = IfaceHpcTick Module Int -- from HpcTick x + | IfaceSCC CostCentre Bool Bool -- from ProfNote + | IfaceSource RealSrcSpan FastString -- from SourceNote + | IfaceBreakpoint BreakpointId [IfaceExpr] -- from Breakpoint + +data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr + -- Note: IfLclName, not IfaceBndr (and same with the case binder) + -- We reconstruct the kind/type of the thing from the context + -- thus saving bulk in interface files + +data IfaceConAlt = IfaceDefaultAlt + | IfaceDataAlt IfExtName + | IfaceLitAlt Literal + +type IfaceBinding b = IfaceBindingX IfaceExpr b + +data IfaceBindingX r b + = IfaceNonRec b r + | IfaceRec [(b, r)] + deriving (Functor, Foldable, Traversable, Ord, Eq) + +-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too +-- It's used for *non-top-level* let/rec binders +-- See Note [IdInfo on nested let-bindings] +data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo JoinPointHood + +data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails + | IfGblTopBndr IfaceTopBndr + +-- See Note [Interface File with Core: Sharing RHSs] +data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr + +{- +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Iface syntax an IfaceCase does not record the types of the alternatives, +unlike Core syntax Case. But we need this type if the alternatives are empty. +Hence IfaceECase. See Note [Empty case alternatives] in GHC.Core. + +Note [Expose recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For supercompilation we want to put *all* unfoldings in the interface +file, even for functions that are recursive (or big). So we need to +know when an unfolding belongs to a loop-breaker so that we can refrain +from inlining it (except during supercompilation). + +Note [IdInfo on nested let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Occasionally we want to preserve IdInfo on nested let bindings. The one +that came up was a NOINLINE pragma on a let-binding inside an INLINE +function. The user (Duncan Coutts) really wanted the NOINLINE control +to cross the separate compilation boundary. + +In general we retain all info that is left by GHC.Core.Tidy.tidyLetBndr, since +that is what is seen by importing module with --make + +Note [Displaying axiom incompatibilities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -fprint-axiom-incomps we display which closed type family equations +are incompatible with which. This information is sometimes necessary +because GHC doesn't try equations in order: any equation can be used when +all preceding equations that are incompatible with it do not apply. + +For example, the last "a && a = a" equation in Data.Type.Bool.&& is +actually compatible with all previous equations, and can reduce at any +time. + +This is displayed as: +Prelude> :i Data.Type.Equality.== +type family (==) (a :: k) (b :: k) :: Bool + where + {- #0 -} (==) (f a) (g b) = (f == g) && (a == b) + {- #1 -} (==) a a = 'True + -- incompatible with: #0 + {- #2 -} (==) _1 _2 = 'False + -- incompatible with: #1, #0 +The comment after an equation refers to all previous equations (0-indexed) +that are incompatible with it. + +************************************************************************ +* * + Printing IfaceDecl +* * +************************************************************************ +-} + +pprAxBranch :: SDoc -> BranchIndex -> IfaceAxBranch -> SDoc +-- The TyCon might be local (just an OccName), or this might +-- be a branch for an imported TyCon, so it would be an ExtName +-- So it's easier to take an SDoc here +-- +-- This function is used +-- to print interface files, +-- in debug messages +-- in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon +-- For user error messages we use Coercion.pprCoAxiom and friends +pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs + , ifaxbCoVars = _cvs + , ifaxbLHS = pat_tys + , ifaxbRHS = rhs + , ifaxbIncomps = incomps }) + = assertPpr (null _cvs) (pp_tc $$ ppr _cvs) $ + hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) + $+$ + nest 4 maybe_incomps + where + -- See Note [Printing foralls in type family instances] in GHC.Iface.Type + ppr_binders = maybe_index <+> + pprUserIfaceForAll (map (mkIfaceForAllTvBndr Specified) tvs) + pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys) + + -- See Note [Displaying axiom incompatibilities] + maybe_index + = ppWhenOption sdocPrintAxiomIncomps $ + text "{-" <+> (text "#" <> ppr idx) <+> text "-}" + maybe_incomps + = ppWhenOption sdocPrintAxiomIncomps $ + ppWhen (notNull incomps) $ + text "--" <+> text "incompatible with:" + <+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps + +instance Outputable IfaceWarnings where + ppr = \case + IfWarnAll txt -> text "Warn all" <+> ppr txt + IfWarnSome vs ds -> + hang (text "Warnings:") 2 $ + text "Deprecated names:" <+> vcat [ppr name <+> ppr txt | (name, txt) <- vs] $$ + text "Deprecated exports:" <+> vcat [ppr name <+> ppr txt | (name, txt) <- ds] + +instance Outputable IfaceWarningTxt where + ppr = \case + IfWarningTxt _ _ ws -> pp_ws ws + IfDeprecatedTxt _ ds -> pp_ws ds + where + pp_ws [msg] = pp_with_name msg + pp_ws msgs = brackets $ vcat . punctuate comma . map pp_with_name $ msgs + + pp_with_name = ppr . fst + +instance Outputable IfaceStringLiteral where + ppr (IfStringLiteral st fs) = pprWithSourceText st (ftext fs) + +instance Outputable IfaceAnnotation where + ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value + +instance NamedThing IfaceClassOp where + getName (IfaceClassOp n _ _) = n + +instance HasOccName IfaceClassOp where + occName = getOccName + +instance NamedThing IfaceConDecl where + getName = ifConName + +instance HasOccName IfaceConDecl where + occName = getOccName + +instance NamedThing IfaceDecl where + getName = ifName + +instance HasOccName IfaceDecl where + occName = getOccName + +instance Outputable IfaceDecl where + ppr = pprIfaceDecl showToIface + +instance (Outputable r, Outputable b) => Outputable (IfaceBindingX r b) where + ppr b = case b of + (IfaceNonRec b r) -> ppr_bind (b, r) + (IfaceRec pairs) -> sep [text "rec {", nest 2 (sep (map ppr_bind pairs)),text "}"] + where + ppr_bind (b, r) = ppr b <+> equals <+> ppr r + +instance Outputable IfaceTopBndrInfo where + ppr (IfLclTopBndr lcl_name _ _ _) = ppr lcl_name + ppr (IfGblTopBndr gbl) = ppr gbl + +instance Outputable IfaceMaybeRhs where + ppr IfUseUnfoldingRhs = text "" + ppr (IfRhs ie) = ppr ie + +{- +Note [Minimal complete definition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The minimal complete definition should only be included if a complete +class definition is shown. Since the minimal complete definition is +anonymous we can't reuse the same mechanism that is used for the +filtering of method signatures. Instead we just check if anything at all is +filtered and hide it in that case. +-} + +{- +Note [Printing IfaceDecl binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binders in an IfaceDecl are just OccNames, so we don't know what module they +come from. But when we pretty-print a TyThing by converting to an IfaceDecl +(see GHC.Types.TyThing.Ppr), the TyThing may come from some other module so we really need +the module qualifier. We solve this by passing in a pretty-printer for the +binders. + +When printing an interface file (--show-iface), we want to print +everything unqualified, so we can just print the OccName directly. +-} + +-- | Show a declaration but not its RHS. +showToHeader :: ShowSub +showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing + , ss_forall = ShowForAllWhen } + +-- | Show declaration and its RHS, including GHc-internal information (e.g. +-- for @--show-iface@). +showToIface :: ShowSub +showToIface = ShowSub { ss_how_much = ShowIface + , ss_forall = ShowForAllWhen } + +ppShowIface :: ShowSub -> SDoc -> SDoc +ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowIface _ _ = Outputable.empty + +-- show if all sub-components or the complete interface is shown +ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- See Note [Minimal complete definition] +ppShowAllSubs (ShowSub { ss_how_much = ShowSome Nothing _ }) doc + = doc +ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowAllSubs _ _ = Outputable.empty + +ppShowRhs :: ShowSub -> SDoc -> SDoc +ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty +ppShowRhs _ doc = doc + +showSub :: HasOccName n => ShowSub -> n -> Bool +showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False +showSub (ShowSub { ss_how_much = ShowSome (Just f) _ }) thing + = f (occName thing) +showSub (ShowSub { ss_how_much = _ }) _ = True + +ppr_trim :: [Maybe SDoc] -> [SDoc] +-- Collapse a group of Nothings to a single "..." +ppr_trim xs + = snd (foldr go (False, []) xs) + where + go (Just doc) (_, so_far) = (False, doc : so_far) + go Nothing (True, so_far) = (True, so_far) + go Nothing (False, so_far) = (True, text "..." : so_far) + +isIfaceDataInstance :: IfaceTyConParent -> Bool +isIfaceDataInstance IfNoParent = False +isIfaceDataInstance _ = True + +pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc +pprClassRoles ss clas binders roles = + pprRoles (== Nominal) + (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) + binders + roles + +pprClassStandaloneKindSig :: ShowSub -> IfaceTopBndr -> IfaceKind -> SDoc +pprClassStandaloneKindSig ss clas = + pprStandaloneKindSig (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) + +constraintIfaceKind :: IfaceKind +constraintIfaceKind = + IfaceTyConApp (IfaceTyCon constraintKindTyConName (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil + +{- Note [Print invisible binders in interface declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Starting from GHC 9.8 it is possible to write invisible @-binders +in type-level declarations. That feature introduced several challenges +in interface declaration pretty printing (e.g. using the :info command +inside GHCi) to overcome. + +Consider this example with a redundant type variable `a`: + + type Id :: forall a b. b -> b + type Id x = x + +GHC will create system binders for kinds there to meet typechecking +and compilation needs and that will turn that declaration into a less +straightforward form with multiple @-binders: + + type Id :: forall {k} (a :: k) b. b -> b + type Id @{k} @a @b x = x :: b + +This information isn't required for understanding in most cases, +so GHC will hide it unless -fprint-explicit-kinds flag is supplied by the user. +And here is what we get: + + type Id :: forall {k} (a :: k) b. b -> b + type Id x = x + +However, there are several cases involving user-written @-binders +when it is cruicial to show them to provide understanding of what's going on. +First of all it can plainly appear on the right-hand side: + + type T :: forall (a :: Type). Type + type T @x = Tuple2 x x + +Not only that, an invisible binder can be unused by itself, but have an +impact on invisible binder positioning, e.g.: + + type T :: forall (a :: Type) (b :: Type). Type + type T @x @y = Tuple2 y y + +Here `x` is unused, but it is required to display, as `y` corresponds +to `b` in the standalone kind signature. + +The last problem is related to non-generative type declarations (type +synonyms and type families) only. It is not possible to partially +apply them, hence it's important to understand what parts of a declaration's +kind are related to the declaration itself. Here is a simple example: + + type T1 :: forall k. k -> Maybe k + type T1 = Just + + type T2 :: forall k. k -> Maybe k + type T2 @k = Just + +Both these type synonyms have the same kind signature, but they aren't +the same! `T1` can be used in strictly more cases, for example, as +an argument for a higher-order type: + + type F :: (forall k. k -> Maybe k) -> Type + + type R1 = F T1 -- Yes! + type R2 = F T2 -- No, that will not compile :( + +User-written invisible binders and "system" binders introduced by GHC +are indistinguishable at this stage, hence we try to only print +semantically significant binders by default. + +An invisible binder is considered significant when it meets at least +one of the following two criteria: + - It visibly occurs in the declaration's body (See more about that below) + - It is followed by a significant binder, + so it affects positioning +For non-generative type declarations (type synonyms and type families), +there is one additional criterion: + - It is not followed by a visible binder, so it + affects the arity of a type declaration + +The overall solution consists of three functions: +- `iface_decl_non_generative` decides whether the current declaration is + generative or not + +- `iface_decl_mentioned_vars` gives a Set of variables that + visibly occur in the declaration's body + +- `suppressIfaceInvisibles` uses information provided + by the first two functions to actually filter out insignificant + @-binders + +Here is what we consider "visibly occurs" in general and for +each declaration type: + +- Variables that visibly occur in IfaceType are collected by the + `visibleTypeVarOccurencies` function. + +- Variables that visibly occur in IfaceAT are collected by `iface_at_mentioned_vars` + function. It accounts visible binders for associated data and type + families and for type families only, it counts invisible binders. + Associated types can't have definitions, so it's safe to drop all other + binders. + +- None of the type variables in IfaceData declared using GADT syntax doesn't are considered + as visibe occurrences. This is because each constructor has its own variables, e.g.: + + type D :: forall (a :: Type). Type + data D @a where + MkD :: D @b + -- This is shorthand for: + -- MkD :: forall b. D @b + +- For IfaceData declared using Haskell98 syntax, a variable is considered visible + if it visibly occurs in at least one argument's type in at least one constructor. + +- For IfaceSynonym, a variable is considered visible if it visibly occurs + in the RHS type. + +- For IfaceFamily, a variable is considered visible if i occurs inside + an injectivity annotation, e.g. + + type family F @a = r | r -> a + +- For IfaceClass, a variable is considered visible if it occurs at least + once inside a functional dependency annotation or in at least one method's + type signature, or if it visibly occurs in at least one associated type's + declaration (Visible occurrences in associated types are described above.) + +- IfacePatSyn, IfaceId and IfaceAxiom are irrelevant to this problem. +-} + +iface_decl_generative :: IfaceDecl -> Bool +iface_decl_generative IfaceSynonym{} = False +iface_decl_generative IfaceFamily{ifFamFlav = rhs} + | IfaceDataFamilyTyCon <- rhs = True + | otherwise = False +iface_decl_generative IfaceData{} = True +iface_decl_generative IfaceId{} = True +iface_decl_generative IfaceClass{} = True +iface_decl_generative IfaceAxiom{} = True +iface_decl_generative IfacePatSyn{} = True + +iface_at_mentioned_vars :: IfaceAT -> Set.Set IfLclName +iface_at_mentioned_vars (IfaceAT decl _) + = Set.fromList . map ifTyConBinderName . suppress_vars $ binders + where + -- ifBinders is not total, so we assume here that associated types + -- cannot be IfaceId, IfaceAxiom or IfacePatSyn + binders = case decl of + IfaceFamily {ifBinders} -> ifBinders + IfaceData{ifBinders} -> ifBinders + IfaceSynonym{ifBinders} -> ifBinders + IfaceClass{ifBinders} -> ifBinders + IfaceId{} -> panic "IfaceId shoudn't be an associated type!" + IfaceAxiom{} -> panic "IfaceAxiom shoudn't be an associated type!" + IfacePatSyn {} -> panic "IfacePatSyn shoudn't be an associated type!" + + suppress_arity = not (iface_decl_generative decl) + + suppress_vars binders = + suppressIfaceInvisibles + -- We need to count trailing invisible binders for type families + (MkPrintArityInvisibles suppress_arity) + -- But this setting will simply count all invisible binderss + (PrintExplicitKinds False) + -- ...and associated types can't have a RHS + mempty + binders binders + +-- See Note [Print invisible binders in interface declarations] +-- in particular, the parts about collecting visible occurrences +iface_decl_mentioned_vars :: IfaceDecl -> Set.Set IfLclName +iface_decl_mentioned_vars (IfaceData { ifCons = condecls, ifGadtSyntax = gadt }) + | gadt = mempty + -- Get visible occurrences in each constructor in each alternative + | otherwise = Set.unions (map mentioned_con_vars cons) + where + mentioned_con_vars = Set.unions . map (visibleTypeVarOccurencies . snd) . ifConArgTys + cons = visibleIfConDecls condecls + +iface_decl_mentioned_vars (IfaceClass { ifFDs = fds, ifBody = IfAbstractClass }) + = Set.unions (map fundep_names fds) + where + fundep_names fd = Set.fromList (fst fd) `Set.union` Set.fromList (snd fd) + +iface_decl_mentioned_vars + (IfaceClass { ifFDs = fds + , ifBody = IfConcreteClass { + ifATs = ats, + ifSigs = sigs + }}) + = Set.unions + [ Set.unions (map fundep_names fds) + , Set.unions (map iface_at_mentioned_vars ats) + , Set.unions (map (visibleTypeVarOccurencies . class_op_type) sigs) + ] + where + class_op_type (IfaceClassOp _bndr ty _default) = ty + + fundep_names fd = Set.fromList (fst fd) `Set.union` Set.fromList (snd fd) + +iface_decl_mentioned_vars (IfaceSynonym {ifSynRhs = poly_ty}) + = visibleTypeVarOccurencies poly_ty + +-- Consider a binder to be a visible occurrence if it occurs inside an injectivity annotation. +iface_decl_mentioned_vars (IfaceFamily { ifBinders = binders, ifResVar = res_var, ifFamInj = inj }) + | Just{} <- res_var + , Injective injectivity <- inj + = Set.fromList . map (ifTyConBinderName . snd) . filter fst $ zip injectivity binders + | otherwise = mempty + +iface_decl_mentioned_vars IfacePatSyn{} = mempty +iface_decl_mentioned_vars IfaceId{} = mempty +iface_decl_mentioned_vars IfaceAxiom{} = mempty + +pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc +-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi +-- See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr +pprIfaceDecl ss decl@(IfaceData { ifName = tycon, ifCType = ctype, + ifCtxt = context, ifResKind = kind, + ifRoles = roles, ifCons = condecls, + ifParent = parent, + ifGadtSyntax = gadt, + ifBinders = binders }) + + | gadt = vcat [ pp_roles + , pp_ki_sig + , pp_nd <+> pp_lhs <+> pp_kind <+> pp_where + , nest 2 (vcat pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + | otherwise = vcat [ pp_roles + , pp_ki_sig + , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + where + is_data_instance = isIfaceDataInstance parent + -- See Note [Printing foralls in type family instances] in GHC.Iface.Type + pp_data_inst_forall :: SDoc + pp_data_inst_forall = pprUserIfaceForAll forall_bndrs + + forall_bndrs :: [IfaceForAllBndr] + forall_bndrs = [Bndr (binderVar tc_bndr) Specified | tc_bndr <- binders] + + cons = visibleIfConDecls condecls + pp_where = ppWhen (gadt && not (null cons)) $ text "where" + pp_cons = ppr_trim (map show_con cons) :: [SDoc] + pp_kind = ppUnless (ki_sig_printable || isIfaceLiftedTypeKind kind) + (dcolon <+> ppr kind) + + decl_head = pprIfaceDeclHead decl suppress_bndr_sig context ss tycon binders + + pp_lhs = case parent of + IfNoParent -> decl_head + IfDataInstance{} + -> text "instance" <+> pp_data_inst_forall + <+> pprIfaceTyConParent parent + + pp_roles + | is_data_instance = empty + | otherwise = pprRoles (== Representational) name_doc binders roles + -- Don't display roles for data family instances (yet) + -- See discussion on #8672. + + ki_sig_printable = + -- If we print a standalone kind signature for a data instance, we leak + -- the internal constructor name: + -- + -- type T15827.R:Dka :: forall k. k -> * + -- data instance forall k (a :: k). D a = MkD (Proxy a) + -- + -- This T15827.R:Dka is a compiler-generated type constructor for the + -- data instance. + not is_data_instance + + pp_ki_sig = ppWhen ki_sig_printable $ + pprStandaloneKindSig name_doc (mkIfaceTyConKind binders kind) + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig ki_sig_printable + + name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) + + add_bars [] = Outputable.empty + add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs) + + ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc) + + show_con dc + | ok_con dc = Just $ pprIfaceConDecl ss gadt tycon binders parent dc + | otherwise = Nothing + + pp_nd = case condecls of + IfAbstractTyCon{} -> text "data" + IfDataTyCon True _ -> text "type data" + IfDataTyCon{} -> text "data" + IfNewTyCon{} -> text "newtype" + + pp_extra = vcat [pprCType ctype] + +pprIfaceDecl ss decl@(IfaceClass { ifName = clas + , ifRoles = roles + , ifFDs = fds + , ifBinders = binders + , ifBody = IfAbstractClass }) + = vcat [ pprClassRoles ss clas binders roles + , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) + , text "class" <+> decl_head <+> pprFundeps fds ] + where + decl_head = pprIfaceDeclHead decl suppress_bndr_sig [] ss clas binders + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl ss decl@(IfaceClass { ifName = clas + , ifRoles = roles + , ifFDs = fds + , ifBinders = binders + , ifBody = IfConcreteClass { + ifATs = ats, + ifSigs = sigs, + ifClassCtxt = context, + ifMinDef = minDef + }}) + = vcat [ pprClassRoles ss clas binders roles + , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) + , text "class" <+> decl_head <+> pprFundeps fds <+> pp_where + , nest 2 (vcat [ vcat asocs, vcat dsigs + , ppShowAllSubs ss (pprMinDef $ fromIfaceBooleanFormula minDef)])] + where + pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") + + decl_head = pprIfaceDeclHead decl suppress_bndr_sig context ss clas binders + + asocs = ppr_trim $ map maybeShowAssoc ats + dsigs = ppr_trim $ map maybeShowSig sigs + + maybeShowAssoc :: IfaceAT -> Maybe SDoc + maybeShowAssoc asc@(IfaceAT d _) + | showSub ss d = Just $ pprIfaceAT ss asc + | otherwise = Nothing + + maybeShowSig :: IfaceClassOp -> Maybe SDoc + maybeShowSig sg + | showSub ss sg = Just $ pprIfaceClassOp ss sg + | otherwise = Nothing + + pprMinDef :: BooleanFormula GhcRn -> SDoc + pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions + text "{-# MINIMAL" <+> + pprBooleanFormula + (\_ def -> let fs = getOccFS def in cparen (isLexSym fs) (ppr fs)) 0 minDef <+> + text "#-}" + + fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula GhcRn + -- `mkUnboundName` here is fine because the Name generated is only used for pretty printing and nothing else. + fromIfaceBooleanFormula (IfVar nm ) = Var $ noLocA . mkUnboundName . mkVarOccFS . ifLclNameFS $ nm + fromIfaceBooleanFormula (IfAnd bfs ) = And $ map (noLocA . fromIfaceBooleanFormula) bfs + fromIfaceBooleanFormula (IfOr bfs ) = Or $ map (noLocA . fromIfaceBooleanFormula) bfs + fromIfaceBooleanFormula (IfParens bf) = Parens $ (noLocA . fromIfaceBooleanFormula) bf + + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl ss decl@(IfaceSynonym { ifName = tc + , ifBinders = binders + , ifSynRhs = poly_ty + , ifResKind = res_kind}) + = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) + , hang (text "type" <+> decl_head <+> equals) + 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr_tau ]) + ] + where + (tvs, theta, tau) = splitIfaceSigmaTy poly_ty + name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tc) + + decl_head = pprIfaceDeclHead decl suppress_bndr_sig [] ss tc binders + + -- See Note [Printing type abbreviations] in GHC.Iface.Type + ppr_tau | tc `hasKey` liftedTypeKindTyConKey || + tc `hasKey` unrestrictedFunTyConKey || + tc `hasKey` constraintKindTyConKey + = updSDocContext (\ctx -> ctx { sdocPrintTypeAbbreviations = False }) $ ppr tau + | otherwise = ppr tau + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl ss decl@(IfaceFamily { ifName = tycon + , ifFamFlav = rhs, ifBinders = binders + , ifResKind = res_kind + , ifResVar = res_var, ifFamInj = inj }) + | IfaceDataFamilyTyCon <- rhs + = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) + , text "data family" <+> decl_head + ] + + | otherwise + = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) + , hang (text "type family" <+> decl_head <+> pp_inj res_var inj + <+> ppShowRhs ss (pp_where rhs)) + 2 (ppShowRhs ss (pp_rhs rhs)) + $$ + nest 2 (ppShowRhs ss (pp_branches rhs)) + ] + where + name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) + + decl_head = pprIfaceDeclHead decl suppress_bndr_sig [] ss tycon binders + + pp_where (IfaceClosedSynFamilyTyCon {}) = text "where" + pp_where _ = empty + + pp_inj Nothing _ = empty + pp_inj (Just res) inj + | Injective injectivity <- inj = hsep [ equals, ppr res + , pp_inj_cond res injectivity] + | otherwise = hsep [ equals, ppr res ] + + pp_inj_cond res inj = case filterByList inj binders of + [] -> empty + tvs -> hsep [vbar, ppr res, arrow, interppSP (map ifTyConBinderName tvs)] + + pp_rhs IfaceDataFamilyTyCon + = ppShowIface ss (text "data") + pp_rhs IfaceOpenSynFamilyTyCon + = ppShowIface ss (text "open") + pp_rhs IfaceAbstractClosedSynFamilyTyCon + = ppShowIface ss (text "closed, abstract") + pp_rhs (IfaceClosedSynFamilyTyCon {}) + = empty -- see pp_branches + pp_rhs IfaceBuiltInSynFamTyCon + = ppShowIface ss (text "built-in") + + pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) + = vcat (unzipWith (pprAxBranch + (pprPrefixIfDeclBndr + (ss_how_much ss) + (occName tycon)) + ) $ zip [0..] brs) + $$ ppShowIface ss (text "axiom" <+> ppr ax) + pp_branches _ = Outputable.empty + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl _ (IfacePatSyn { ifName = name, + ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs, + ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, + ifPatArgs = arg_tys, ifFieldLabels = pat_fldlbls, + ifPatTy = pat_ty} ) + = sdocWithContext mk_msg + where + pat_keywrd = text "pattern" + mk_msg sdocCtx + = vcat [ ppr_pat_ty + -- only print this for record pattern synonyms + , if null pat_fldlbls then Outputable.empty + else pat_keywrd <+> pprPrefixOcc name <+> pat_body] + where + ppr_pat_ty = + hang (pat_keywrd <+> pprPrefixOcc name) + 2 (dcolon <+> sep [univ_msg + , pprIfaceContextArr req_ctxt + , ppWhen insert_empty_ctxt $ parens empty <+> darrow + , ex_msg + , pprIfaceContextArr prov_ctxt + , pprIfaceType $ foldr (IfaceFunTy visArgTypeLike many_ty) + pat_ty arg_tys ]) + pat_body = braces $ sep $ punctuate comma $ map ppr pat_fldlbls + univ_msg = pprUserIfaceForAll $ tyVarSpecToBinders univ_bndrs + ex_msg = pprUserIfaceForAll $ tyVarSpecToBinders ex_bndrs + + insert_empty_ctxt = null req_ctxt + && not (null prov_ctxt && isEmpty sdocCtx ex_msg) + +pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, + ifIdDetails = details, ifIdInfo = info }) + = vcat [ hang (pprPrefixIfDeclBndr (ss_how_much ss) (occName var) <+> dcolon) + 2 (pprIfaceSigmaType (ss_forall ss) ty) + , ppShowIface ss (ppr details) + , ppShowIface ss (ppr info) ] + +pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon + , ifAxBranches = branches }) + = hang (text "axiom" <+> ppr name <+> dcolon) + 2 (vcat $ unzipWith (pprAxBranch (ppr tycon)) $ zip [0..] branches) + +pprCType :: Maybe CType -> SDoc +pprCType Nothing = Outputable.empty +pprCType (Just cType) = text "C type:" <+> ppr cType + +-- if, for each role, suppress_if role is True, then suppress the role +-- output +pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder] + -> [Role] -> SDoc +pprRoles suppress_if tyCon bndrs roles + = sdocOption sdocPrintExplicitKinds $ \print_kinds -> + let froles = + suppressIfaceInvisibles + (MkPrintArityInvisibles False) + (PrintExplicitKinds print_kinds) + mempty + bndrs roles + in ppUnless (all suppress_if froles || null froles) $ + text "type role" <+> tyCon <+> hsep (map ppr froles) + +pprStandaloneKindSig :: SDoc -> IfaceType -> SDoc +pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> dcolon <+> ppr ty + +pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc +pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name + = pprInfixVar (isSymOcc name) (ppr_bndr name) +pprInfixIfDeclBndr _ name + = pprInfixVar (isSymOcc name) (ppr name) + +pprPrefixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc +pprPrefixIfDeclBndr (ShowHeader (AltPpr (Just ppr_bndr))) name + = parenSymOcc name (ppr_bndr name) +pprPrefixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name + = parenSymOcc name (ppr_bndr name) +pprPrefixIfDeclBndr _ name + = parenSymOcc name (ppr name) + +instance Outputable IfaceClassOp where + ppr = pprIfaceClassOp showToIface + +pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc +pprIfaceClassOp ss (IfaceClassOp n ty dm) + = pp_sig n ty $$ generic_dm + where + generic_dm | Just (GenericDM dm_ty) <- dm + = text "default" <+> pp_sig n dm_ty + | otherwise + = empty + pp_sig n ty + = pprPrefixIfDeclBndr (ss_how_much ss) (occName n) + <+> dcolon + <+> pprIfaceSigmaType ShowForAllWhen ty + +instance Outputable IfaceAT where + ppr = pprIfaceAT showToIface + +pprIfaceAT :: ShowSub -> IfaceAT -> SDoc +pprIfaceAT ss (IfaceAT d mb_def) + = vcat [ pprIfaceDecl ss d + , case mb_def of + Nothing -> Outputable.empty + Just rhs -> nest 2 $ + text "Default:" <+> ppr rhs ] + +instance Outputable IfaceTyConParent where + ppr p = pprIfaceTyConParent p + +pprIfaceTyConParent :: IfaceTyConParent -> SDoc +pprIfaceTyConParent IfNoParent + = Outputable.empty +pprIfaceTyConParent (IfDataInstance _ tc tys) + = pprIfaceTypeApp topPrec tc tys + +pprIfaceDeclHead :: IfaceDecl + -> SuppressBndrSig + -> IfaceContext -> ShowSub -> Name + -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression + -> SDoc +pprIfaceDeclHead decl suppress_sig context ss tc_occ bndrs + = sdocOption sdocPrintExplicitKinds $ \print_kinds -> + sep [ pprIfaceContextArr context + , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ) + <+> pprIfaceTyConBinders suppress_sig + (suppressIfaceInvisibles + (MkPrintArityInvisibles print_arity) + (PrintExplicitKinds print_kinds) + mentioned_vars + bndrs bndrs) ] + where + -- See Note [Print invisible binders in interface declarations] + mentioned_vars = iface_decl_mentioned_vars decl + print_arity = not (iface_decl_generative decl) + +pprIfaceConDecl :: ShowSub -> Bool + -> IfaceTopBndr + -> [IfaceTyConBinder] + -> IfaceTyConParent + -> IfaceConDecl -> SDoc +pprIfaceConDecl ss gadt_style tycon tc_binders parent + (IfCon { ifConName = name, ifConInfix = is_infix, + ifConUserTvBinders = user_tvbs, + ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, + ifConStricts = stricts, ifConFields = fields }) + | gadt_style = pp_prefix_con <+> dcolon <+> ppr_gadt_ty + | otherwise = ppr_ex_quant pp_h98_con + where + pp_h98_con + | not (null fields) = pp_prefix_con <+> pp_field_args + | is_infix + , [ty1, ty2] <- pp_args + = sep [ ty1 + , pprInfixIfDeclBndr how_much (occName name) + , ty2] + | otherwise = pp_prefix_con <+> sep pp_args + + how_much = ss_how_much ss + tys_w_strs :: [(IfaceBang, IfaceType)] + tys_w_strs = zip stricts (map snd arg_tys) + pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name) + + -- If we're pretty-printing a H98-style declaration with existential + -- quantification, then user_tvbs will always consist of the universal + -- tyvar binders followed by the existential tyvar binders. So to recover + -- the visibilities of the existential tyvar binders, we can simply drop + -- the universal tyvar binders from user_tvbs. + ex_tvbs = dropList tc_binders user_tvbs + ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt + pp_gadt_res_ty = mk_user_con_res_ty eq_spec + ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau + + -- A bit gruesome this, but we can't form the full con_tau, and ppr it, + -- because we don't have a Name for the tycon, only an OccName + pp_tau | null fields + = case pp_args ++ [pp_gadt_res_ty] of + (t:ts) -> fsep (t : zipWithEqual (\(w,_) d -> ppr_arr w <+> d) + arg_tys ts) + [] -> panic "pp_con_taus" + | otherwise + = sep [pp_field_args, arrow <+> pp_gadt_res_ty] + + -- Constructors are linear by default, but we don't want to show + -- linear arrows when -XLinearTypes is disabled + ppr_arr w = sdocOption sdocLinearTypes $ \linearTypes -> + if linearTypes + then pprTypeArrow visArgTypeLike w + else arrow + + ppr_bang IfNoBang = whenPprDebug $ char '_' + ppr_bang IfStrict = char '!' + ppr_bang IfUnpack = text "{-# UNPACK #-} !" + ppr_bang (IfUnpackCo co) = text "{-# UNPACK #-} !" <> + whenPprDebug (pprParendIfaceCoercion co) + + pprFieldArgTy, pprArgTy :: (IfaceBang, IfaceType) -> SDoc + -- If using record syntax, the only reason one would need to parenthesize + -- a compound field type is if it's preceded by a bang pattern. + pprFieldArgTy (bang, ty) = ppr_arg_ty (bang_prec bang) bang ty + -- If not using record syntax, a compound field type might need to be + -- parenthesized if one of the following holds: + -- + -- 1. We're using Haskell98 syntax. + -- 2. The field type is preceded with a bang pattern. + pprArgTy (bang, ty) = ppr_arg_ty (max gadt_prec (bang_prec bang)) bang ty + + ppr_arg_ty :: PprPrec -> IfaceBang -> IfaceType -> SDoc + ppr_arg_ty prec bang ty = ppr_bang bang <> pprPrecIfaceType prec ty + + -- If we're displaying the fields GADT-style, e.g., + -- + -- data Foo a where + -- MkFoo :: (Int -> Int) -> Maybe a -> Foo + -- + -- Then we use `funPrec`, since that will ensure `Int -> Int` gets the + -- parentheses that it requires, but simple compound types like `Maybe a` + -- (which don't require parentheses in a function argument position) won't + -- get them, assuming that there are no bang patterns (see bang_prec). + -- + -- If we're displaying the fields Haskell98-style, e.g., + -- + -- data Foo a = MkFoo (Int -> Int) (Maybe a) + -- + -- Then not only must we parenthesize `Int -> Int`, we must also + -- parenthesize compound fields like (Maybe a). Therefore, we pick + -- `appPrec`, which has higher precedence than `funPrec`. + gadt_prec :: PprPrec + gadt_prec + | gadt_style = funPrec + | otherwise = appPrec + + -- The presence of bang patterns or UNPACK annotations requires + -- surrounding the type with parentheses, if needed (#13699) + bang_prec :: IfaceBang -> PprPrec + bang_prec IfNoBang = topPrec + bang_prec IfStrict = appPrec + bang_prec IfUnpack = appPrec + bang_prec IfUnpackCo{} = appPrec + + pp_args :: [SDoc] -- No records, e.g., ` Maybe a -> Int -> ...` or + -- `!(Maybe a) -> !Int -> ...` + pp_args = map pprArgTy tys_w_strs + + pp_field_args :: SDoc -- Records, e.g., { x :: Maybe a, y :: Int } or + -- { x :: !(Maybe a), y :: !Int } + pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $ + zipWith maybe_show_label fields tys_w_strs + + maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc + maybe_show_label lbl bty + | showSub ss sel = Just (pprPrefixIfDeclBndr how_much occ + <+> dcolon <+> pprFieldArgTy bty) + | otherwise = Nothing + where + sel = flSelector lbl + occ = nameOccName sel + + mk_user_con_res_ty :: IfaceEqSpec -> SDoc + -- See Note [Result type of a data family GADT] + mk_user_con_res_ty eq_spec + | IfDataInstance _ tc tys <- parent + = pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys)) + | otherwise + = ppr_tc_app gadt_subst + where + gadt_subst = mkIfaceTySubst eq_spec + + -- When pretty-printing a GADT return type, we: + -- + -- 1. Take the data tycon binders, extract their variable names and + -- visibilities, and construct suitable arguments from them. (This is + -- the role of mk_tc_app_args.) + -- 2. Apply the GADT substitution constructed from the eq_spec. + -- (See Note [Result type of a data family GADT].) + -- 3. Pretty-print the data type constructor applied to its arguments. + -- This process will omit any invisible arguments, such as coercion + -- variables, if necessary. (See Note + -- [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.) + ppr_tc_app gadt_subst = + pprPrefixIfDeclBndr how_much (occName tycon) + <+> pprParendIfaceAppArgs + (substIfaceAppArgs gadt_subst (mk_tc_app_args tc_binders)) + + mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs + mk_tc_app_args [] = IA_Nil + mk_tc_app_args (Bndr bndr vis:tc_bndrs) = + IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisForAllTyFlag vis) + (mk_tc_app_args tc_bndrs) + +instance Outputable IfaceRule where + ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, + ifRuleOrph = orph }) + = sep [ hsep [ pprRuleName name + , if isOrphan orph then text "[orphan]" else Outputable.empty + , ppr act + , pp_foralls ] + , nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), + text "=" <+> ppr rhs]) ] + where + pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot + +instance Outputable IfaceDefault where + ppr (IfaceDefault { ifDefaultCls = cls, ifDefaultTys = tcs }) + = text "default" <+> ppr cls <+> parens (pprWithCommas ppr tcs) + +instance Outputable IfaceClsInst where + ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag + , ifInstCls = cls, ifInstTys = mb_tcs + , ifInstOrph = orph }) + = hang (text "instance" <+> ppr flag + <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) + <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) + 2 (equals <+> ppr dfun_id) + +instance Outputable IfaceFamInst where + ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph }) + = hang (text "family instance" + <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) + <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) + 2 (equals <+> ppr tycon_ax) + +ppr_rough :: Maybe IfaceTyCon -> SDoc +ppr_rough Nothing = dot +ppr_rough (Just tc) = ppr tc + +{- +Note [Result type of a data family GADT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T (p,q) where + T1 :: T (Int, Maybe c) + T2 :: T (Bool, q) + +The IfaceDecl actually looks like + + data TPr p q where + T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q + T2 :: forall p q. (p~Bool) => TPr p q + +To reconstruct the result types for T1 and T2 that we +want to pretty print, we substitute the eq-spec +[p->Int, q->Maybe c] in the arg pattern (p,q) to give + T (Int, Maybe c) +Remember that in IfaceSyn, the TyCon and DataCon share the same +universal type variables. + +----------------------------- Printing IfaceExpr ------------------------------------ +-} + +instance Outputable IfaceExpr where + ppr e = pprIfaceExpr noParens e + +noParens :: SDoc -> SDoc +noParens pp = pp + +pprParendIfaceExpr :: IfaceExpr -> SDoc +pprParendIfaceExpr = pprIfaceExpr parens + +-- | Pretty Print an IfaceExpr +-- +-- The first argument should be a function that adds parens in context that need +-- an atomic value (e.g. function args) +pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc + +pprIfaceExpr _ (IfaceLcl v) = ppr v +pprIfaceExpr _ (IfaceExt v) = ppr v +pprIfaceExpr _ (IfaceLit l) = ppr l +pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) +pprIfaceExpr _ (IfaceType ty) = char '@' <> pprParendIfaceType ty +pprIfaceExpr _ (IfaceCo co) = text "@~" <> pprParendIfaceCoercion co +pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) + +pprIfaceExpr _ (IfaceLitRubbish tc r) + = text "RUBBISH" + <> (case tc of { TypeLike -> empty; ConstraintLike -> text "[c]" }) + <> parens (ppr r) + +pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) + +pprIfaceExpr add_par i@(IfaceLam _ _) + = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, + pprIfaceExpr noParens body]) + where + (bndrs,body) = collect [] i + collect bs (IfaceLam b e) = collect (b:bs) e + collect bs e = (reverse bs, e) + +pprIfaceExpr add_par (IfaceECase scrut ty) + = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut + , text "ret_ty" <+> pprParendIfaceType ty + , text "of {}" ]) + +pprIfaceExpr add_par (IfaceCase scrut bndr [IfaceAlt con bs rhs]) + = add_par (sep [text "case" + <+> pprIfaceExpr noParens scrut <+> text "of" + <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, + pprIfaceExpr noParens rhs <+> char '}']) + +pprIfaceExpr add_par (IfaceCase scrut bndr alts) + = add_par (sep [text "case" + <+> pprIfaceExpr noParens scrut <+> text "of" + <+> ppr bndr <+> char '{', + nest 2 (sep (map pprIfaceAlt alts)) <+> char '}']) + +pprIfaceExpr _ (IfaceCast expr co) + = sep [pprParendIfaceExpr expr, + nest 2 (text "`cast`"), + pprParendIfaceCoercion co] + +pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) + = add_par (sep [text "let {", + nest 2 (ppr_bind (b, rhs)), + text "} in", + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) + = add_par (sep [text "letrec {", + nest 2 (sep (map ppr_bind pairs)), + text "} in", + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceTick tickish e) + = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e) + +pprIfaceAlt :: IfaceAlt -> SDoc +pprIfaceAlt (IfaceAlt con bs rhs) + = sep [ppr_con_bs con bs, arrow <+> pprIfaceExpr noParens rhs] + +ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc +ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) + +ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc +ppr_bind (IfLetBndr b ty info ji, rhs) + = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info), + equals <+> pprIfaceExpr noParens rhs] + +------------------ +pprIfaceTickish :: IfaceTickish -> SDoc +pprIfaceTickish (IfaceHpcTick m ix) + = braces (text "tick" <+> ppr m <+> ppr ix) +pprIfaceTickish (IfaceSCC cc tick scope) + = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) +pprIfaceTickish (IfaceSource src _names) + = braces (pprUserRealSpan True src) +pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs) + = braces (text "break" <+> ppr m <+> ppr ix <+> ppr fvs) + +------------------ +pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc +pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $ + nest 2 (pprParendIfaceExpr arg) : args +pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) + +------------------ +instance Outputable IfaceConAlt where + ppr IfaceDefaultAlt = text "DEFAULT" + ppr (IfaceLitAlt l) = ppr l + ppr (IfaceDataAlt d) = ppr d + +------------------ +instance Outputable IfaceIdDetails where + ppr IfVanillaId = Outputable.empty + ppr (IfWorkerLikeId dmd) = text "StrWork" <> parens (ppr dmd) + ppr (IfRecSelId tc _c b _fl) = text "RecSel" <+> ppr tc + <+> if b + then text "" + else Outputable.empty + ppr IfDFunId = text "DFunId" + +instance Outputable IfaceInfoItem where + ppr (HsUnfold lb unf) = text "Unfolding" + <> ppWhen lb (text "(loop-breaker)") + <> colon <+> ppr unf + ppr (HsInline prag) = text "Inline:" <+> ppr prag + ppr (HsArity arity) = text "Arity:" <+> int arity + ppr (HsDmdSig str) = text "Strictness:" <+> ppr str + ppr (HsCprSig cpr) = text "CPR:" <+> ppr cpr + ppr HsNoCafRefs = text "HasNoCafRefs" + ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info + ppr (HsTagSig tag_sig) = text "TagSig:" <+> ppr tag_sig + +instance Outputable IfaceUnfolding where + ppr (IfCoreUnfold src _ guide e) + = sep [ text "Core:" <+> ppr src <+> ppr guide, ppr e ] + ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot) + 2 (sep (map pprParendIfaceExpr es)) + +instance Outputable IfGuidance where + ppr IfNoGuidance = empty + ppr (IfWhen a u b) = angleBrackets (ppr a <> comma <> ppr u <> ppr b) + +{- +************************************************************************ +* * + Finding the Names in Iface syntax +* * +************************************************************************ + +This is used for dependency analysis in GHC.Iface.Make, so that we +fingerprint a declaration before the things that depend on it. It +is specific to interface-file fingerprinting in the sense that we +don't collect *all* Names: for example, the DFun of an instance is +recorded textually rather than by its fingerprint when +fingerprinting the instance, so DFuns are not dependencies. +-} + +freeNamesIfDecl :: IfaceDecl -> NameSet +freeNamesIfDecl (IfaceId { ifType = t, ifIdDetails = d, ifIdInfo = i}) + = freeNamesIfType t &&& + freeNamesIfIdInfo i &&& + freeNamesIfIdDetails d + +freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k + , ifParent = p, ifCtxt = ctxt, ifCons = cons }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfType res_k &&& + freeNamesIfaceTyConParent p &&& + freeNamesIfContext ctxt &&& + freeNamesIfConDecls cons + +freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k + , ifSynRhs = rhs }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfKind res_k &&& + freeNamesIfType rhs + +freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k + , ifFamFlav = flav }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfKind res_k &&& + freeNamesIfFamFlav flav + +freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfClassBody cls_body + +freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches }) + = freeNamesIfTc tc &&& + fnList freeNamesIfAxBranch branches + +freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _) + , ifPatBuilder = mb_builder + , ifPatUnivBndrs = univ_bndrs + , ifPatExBndrs = ex_bndrs + , ifPatProvCtxt = prov_ctxt + , ifPatReqCtxt = req_ctxt + , ifPatArgs = args + , ifPatTy = pat_ty + , ifFieldLabels = lbls }) + = unitNameSet matcher &&& + maybe emptyNameSet (unitNameSet . fst) mb_builder &&& + freeNamesIfVarBndrs univ_bndrs &&& + freeNamesIfVarBndrs ex_bndrs &&& + freeNamesIfContext prov_ctxt &&& + freeNamesIfContext req_ctxt &&& + fnList freeNamesIfType args &&& + freeNamesIfType pat_ty &&& + mkNameSet (map flSelector lbls) + +freeNamesIfClassBody :: IfaceClassBody -> NameSet +freeNamesIfClassBody IfAbstractClass + = emptyNameSet +freeNamesIfClassBody (IfConcreteClass{ ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }) + = freeNamesIfContext ctxt &&& + fnList freeNamesIfAT ats &&& + fnList freeNamesIfClsSig sigs + +freeNamesIfAxBranch :: IfaceAxBranch -> NameSet +freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars + , ifaxbCoVars = covars + , ifaxbLHS = lhs + , ifaxbRHS = rhs }) + = fnList freeNamesIfTvBndr tyvars &&& + fnList freeNamesIfIdBndr covars &&& + freeNamesIfAppArgs lhs &&& + freeNamesIfType rhs + +freeNamesIfIdDetails :: IfaceIdDetails -> NameSet +freeNamesIfIdDetails (IfRecSelId tc first_con _ fl) = + either freeNamesIfTc freeNamesIfDecl tc &&& + unitFV first_con &&& + unitFV (flSelector fl) +freeNamesIfIdDetails IfVanillaId = emptyNameSet +freeNamesIfIdDetails (IfWorkerLikeId {}) = emptyNameSet +freeNamesIfIdDetails IfDFunId = emptyNameSet + +-- All other changes are handled via the version info on the tycon +freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet +freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet +freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br))) + = unitNameSet ax &&& fnList freeNamesIfAxBranch br +freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet +freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet + +freeNamesIfContext :: IfaceContext -> NameSet +freeNamesIfContext = fnList freeNamesIfType + +freeNamesIfAT :: IfaceAT -> NameSet +freeNamesIfAT (IfaceAT decl mb_def) + = freeNamesIfDecl decl &&& + case mb_def of + Nothing -> emptyNameSet + Just rhs -> freeNamesIfType rhs + +freeNamesIfClsSig :: IfaceClassOp -> NameSet +freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm + +freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet +freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty +freeNamesDM _ = emptyNameSet + +freeNamesIfConDecls :: IfaceConDecls -> NameSet +freeNamesIfConDecls (IfDataTyCon _ cs) = fnList freeNamesIfConDecl cs +freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c +freeNamesIfConDecls _ = emptyNameSet + +freeNamesIfConDecl :: IfaceConDecl -> NameSet +freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt + , ifConArgTys = arg_tys + , ifConFields = flds + , ifConEqSpec = eq_spec + , ifConStricts = bangs }) + = fnList freeNamesIfBndr ex_tvs &&& + freeNamesIfContext ctxt &&& + fnList freeNamesIfType (map fst arg_tys) &&& -- these are multiplicities, represented as types + fnList freeNamesIfType (map snd arg_tys) &&& + mkNameSet (map flSelector flds) &&& + fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints + fnList freeNamesIfBang bangs + +freeNamesIfBang :: IfaceBang -> NameSet +freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co +freeNamesIfBang _ = emptyNameSet + +freeNamesIfKind :: IfaceType -> NameSet +freeNamesIfKind = freeNamesIfType + +freeNamesIfAppArgs :: IfaceAppArgs -> NameSet +freeNamesIfAppArgs (IA_Arg t _ ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts +freeNamesIfAppArgs IA_Nil = emptyNameSet + +freeNamesIfType :: IfaceType -> NameSet +freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet +freeNamesIfType (IfaceTyVar _) = emptyNameSet +freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t +freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts +freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts +freeNamesIfType (IfaceLitTy _) = emptyNameSet +freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t +freeNamesIfType (IfaceFunTy _ w s t) = freeNamesIfType s &&& freeNamesIfType t &&& freeNamesIfType w +freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c +freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c + +freeNamesIfMCoercion :: IfaceMCoercion -> NameSet +freeNamesIfMCoercion IfaceMRefl = emptyNameSet +freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co + +freeNamesIfCoercion :: IfaceCoercion -> NameSet +freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t +freeNamesIfCoercion (IfaceGReflCo _ t mco) + = freeNamesIfType t &&& freeNamesIfMCoercion mco +freeNamesIfCoercion (IfaceFunCo _ c_mult c1 c2) + = freeNamesIfCoercion c_mult &&& freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) + = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceAppCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceForAllCo _tcv _visL _visR kind_co co) + = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co +freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet +freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet +freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet +freeNamesIfCoercion (IfaceUnivCo _ _ t1 t2 cos) + = freeNamesIfType t1 &&& freeNamesIfType t2 &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceSymCo c) + = freeNamesIfCoercion c +freeNamesIfCoercion (IfaceTransCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceSelCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceLRCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceInstCo co co2) + = freeNamesIfCoercion co &&& freeNamesIfCoercion co2 +freeNamesIfCoercion (IfaceKindCo c) + = freeNamesIfCoercion c +freeNamesIfCoercion (IfaceSubCo co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceAxiomCo ax cos) + = fnAxRule ax &&& fnList freeNamesIfCoercion cos + +fnAxRule :: IfaceAxiomRule -> NameSet +fnAxRule (IfaceAR_X _) = emptyNameSet -- the axiom is just a string, so we don't count it as a name. +fnAxRule (IfaceAR_U n) = unitNameSet n +fnAxRule (IfaceAR_B n _) = unitNameSet n + +freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet +freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr + +freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet +freeNamesIfVarBndrs = fnList freeNamesIfVarBndr + +freeNamesIfBndr :: IfaceBndr -> NameSet +freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b +freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b + +freeNamesIfBndrs :: [IfaceBndr] -> NameSet +freeNamesIfBndrs = fnList freeNamesIfBndr + +freeNamesIfLetBndr :: IfaceLetBndr -> NameSet +-- Remember IfaceLetBndr is used only for *nested* bindings +-- The IdInfo can contain an unfolding (in the case of +-- local INLINE pragmas), so look there too +freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty + &&& freeNamesIfIdInfo info + +freeNamesIfTvBndr :: IfaceTvBndr -> NameSet +freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k + -- kinds can have Names inside, because of promotion + +freeNamesIfIdBndr :: IfaceIdBndr -> NameSet +freeNamesIfIdBndr (_, _fs,k) = freeNamesIfKind k + +freeNamesIfIdInfo :: IfaceIdInfo -> NameSet +freeNamesIfIdInfo = fnList freeNamesItem + +freeNamesItem :: IfaceInfoItem -> NameSet +freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u +freeNamesItem (HsLFInfo (IfLFCon n)) = unitNameSet n +freeNamesItem _ = emptyNameSet + +freeNamesIfUnfold :: IfaceUnfolding -> NameSet +freeNamesIfUnfold (IfCoreUnfold _ _ _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es + +freeNamesIfExpr :: IfaceExpr -> NameSet +freeNamesIfExpr (IfaceExt v) = unitNameSet v +freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co +freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as +freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body +freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a +freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co +freeNamesIfExpr (IfaceTick t e) = freeNamesIfTickish t &&& freeNamesIfExpr e +freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty +freeNamesIfExpr (IfaceCase s _ alts) + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts + where + fn_alt (IfaceAlt _con _bs r) = freeNamesIfExpr r + + -- Depend on the data constructors. Just one will do! + -- Note [Tracking data constructors] + fn_cons [] = emptyNameSet + fn_cons (IfaceAlt IfaceDefaultAlt _ _ : xs) = fn_cons xs + fn_cons (IfaceAlt (IfaceDataAlt con) _ _ : _ ) = unitNameSet con + fn_cons (_ : _ ) = emptyNameSet + +freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body + +freeNamesIfExpr (IfaceLet (IfaceRec as) x) + = fnList fn_pair as &&& freeNamesIfExpr x + where + fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs + +freeNamesIfExpr _ = emptyNameSet + +freeNamesIfTc :: IfaceTyCon -> NameSet +freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) +-- ToDo: shouldn't we include IfaceIntTc & co.? + +freeNamesIfRule :: IfaceRule -> NameSet +freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f + , ifRuleArgs = es, ifRuleRhs = rhs }) + = unitNameSet f &&& + fnList freeNamesIfBndr bs &&& + fnList freeNamesIfExpr es &&& + freeNamesIfExpr rhs + +freeNamesIfFamInst :: IfaceFamInst -> NameSet +freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName + , ifFamInstAxiom = axName }) + = unitNameSet famName &&& + unitNameSet axName + +freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet +freeNamesIfaceTyConParent IfNoParent = emptyNameSet +freeNamesIfaceTyConParent (IfDataInstance ax tc tys) + = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys + +freeNamesIfTickish :: IfaceTickish -> NameSet +freeNamesIfTickish (IfaceBreakpoint _ fvs) = + fnList freeNamesIfExpr fvs +freeNamesIfTickish _ = emptyNameSet + +-- helpers +(&&&) :: NameSet -> NameSet -> NameSet +(&&&) = unionNameSet + +fnList :: (a -> NameSet) -> [a] -> NameSet +fnList f = foldr (&&&) emptyNameSet . map f + +{- +Note [Tracking data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a case expression + case e of { C a -> ...; ... } +You might think that we don't need to include the datacon C +in the free names, because its type will probably show up in +the free names of 'e'. But in rare circumstances this may +not happen. Here's the one that bit me: + + module DynFlags where + import {-# SOURCE #-} Packages( PackageState ) + data DynFlags = DF ... PackageState ... + + module Packages where + import GHC.Driver.DynFlags + data PackageState = PS ... + lookupModule (df :: DynFlags) + = case df of + DF ...p... -> case p of + PS ... -> ... + +Now, lookupModule depends on DynFlags, but the transitive dependency +on the *locally-defined* type PackageState is not visible. We need +to take account of the use of the data constructor PS in the pattern match. + + +************************************************************************ +* * + Binary instances +* * +************************************************************************ + +Note that there is a bit of subtlety here when we encode names. While +IfaceTopBndrs is really just a synonym for Name, we need to take care to +encode them with {get,put}IfaceTopBndr. The difference becomes important when +we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for +details. + +-} + +instance Binary IfaceDecl where + put_ bh (IfaceId name ty details idinfo) = do + putByte bh 0 + putIfaceTopBndr bh name + lazyPut bh (ty, details, idinfo) + -- See Note [Lazy deserialization of IfaceId] + + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + putByte bh 2 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + + put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do + putByte bh 3 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + + put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do + putByte bh 4 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + + -- NB: Written in a funny way to avoid an interface change + put_ bh (IfaceClass { + ifName = a2, + ifRoles = a3, + ifBinders = a4, + ifFDs = a5, + ifBody = IfConcreteClass { + ifClassCtxt = a1, + ifATs = a6, + ifSigs = a7, + ifMinDef = a8, + ifUnary = a9 + }}) = do + putByte bh 5 + put_ bh a1 + putIfaceTopBndr bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + + put_ bh (IfaceAxiom a1 a2 a3 a4) = do + putByte bh 6 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + + put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do + putByte bh 7 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + put_ bh a11 + + put_ bh (IfaceClass { + ifName = a1, + ifRoles = a2, + ifBinders = a3, + ifFDs = a4, + ifBody = IfAbstractClass }) = do + putByte bh 8 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + + get bh = do + h <- getByte bh + case h of + 0 -> do name <- get bh + ~(ty, details, idinfo) <- lazyGet bh + -- See Note [Lazy deserialization of IfaceId] + return (IfaceId name ty details idinfo) + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) + 3 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceSynonym a1 a2 a3 a4 a5) + 4 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + return (IfaceFamily a1 a2 a3 a4 a5 a6) + 5 -> do a1 <- get bh + a2 <- getIfaceTopBndr bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + return (IfaceClass { + ifName = a2, + ifRoles = a3, + ifBinders = a4, + ifFDs = a5, + ifBody = IfConcreteClass { + ifClassCtxt = a1, + ifATs = a6, + ifSigs = a7, + ifMinDef = a8, + ifUnary = a9 + }}) + 6 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + return (IfaceAxiom a1 a2 a3 a4) + 7 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + a11 <- get bh + return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) + 8 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + return (IfaceClass { + ifName = a1, + ifRoles = a2, + ifBinders = a3, + ifFDs = a4, + ifBody = IfAbstractClass }) + _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) + +instance Binary IfaceBooleanFormula where + put_ bh = \case + IfVar a1 -> putByte bh 0 >> put_ bh a1 + IfAnd a1 -> putByte bh 1 >> put_ bh a1 + IfOr a1 -> putByte bh 2 >> put_ bh a1 + IfParens a1 -> putByte bh 3 >> put_ bh a1 + + get bh = do + getByte bh >>= \case + 0 -> IfVar <$> get bh + 1 -> IfAnd <$> get bh + 2 -> IfOr <$> get bh + _ -> IfParens <$> get bh + +{- Note [Lazy deserialization of IfaceId] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The use of lazyPut and lazyGet in the IfaceId Binary instance is +purely for performance reasons, to avoid deserializing details about +identifiers that will never be used. It's not involved in tying the +knot in the type checker. It saved ~1% of the total build time of GHC. + +When we read an interface file, we extend the PTE, a mapping of Names +to TyThings, with the declarations we have read. The extension of the +PTE is strict in the Names, but not in the TyThings themselves. +GHC.IfaceToCore.tcIfaceDecls calculates the list of (Name, TyThing) bindings +to add to the PTE. For an IfaceId, there's just one binding to add; and +the ty, details, and idinfo fields of an IfaceId are used only in the +TyThing. So by reading those fields lazily we may be able to save the +work of ever having to deserialize them (into IfaceType, etc.). + +For IfaceData and IfaceClass, tcIfaceDecls creates extra implicit bindings +(the constructors and field selectors of the data declaration, or the +methods of the class), whose Names depend on more than just the Name +of the type constructor or class itself. So deserializing them lazily +would be more involved. Similar comments apply to the other +constructors of IfaceDecl with the additional point that they probably +represent a small proportion of all declarations. +-} + +instance Binary IfaceFamTyConFlav where + put_ bh IfaceDataFamilyTyCon = putByte bh 0 + put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1 + put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb + put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3 + put_ _ IfaceBuiltInSynFamTyCon + = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty + + get bh = do { h <- getByte bh + ; case h of + 0 -> return IfaceDataFamilyTyCon + 1 -> return IfaceOpenSynFamilyTyCon + 2 -> do { mb <- get bh + ; return (IfaceClosedSynFamilyTyCon mb) } + 3 -> return IfaceAbstractClosedSynFamilyTyCon + _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag" + (ppr (fromIntegral h :: Int)) } + +instance Binary IfaceClassOp where + put_ bh (IfaceClassOp n ty def) = do + putIfaceTopBndr bh n + put_ bh ty + put_ bh def + get bh = do + n <- getIfaceTopBndr bh + ty <- get bh + def <- get bh + return (IfaceClassOp n ty def) + +instance Binary IfaceAT where + put_ bh (IfaceAT dec defs) = do + put_ bh dec + put_ bh defs + get bh = do + dec <- get bh + defs <- get bh + return (IfaceAT dec defs) + +instance Binary IfaceAxBranch where + put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) + +instance Binary IfaceConDecls where + put_ bh IfAbstractTyCon = putByte bh 0 + put_ bh (IfDataTyCon False cs) = putByte bh 1 >> put_ bh cs + put_ bh (IfDataTyCon True cs) = putByte bh 2 >> put_ bh cs + put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c + get bh = do + h <- getByte bh + case h of + 0 -> return IfAbstractTyCon + 1 -> liftM (IfDataTyCon False) (get bh) + 2 -> liftM (IfDataTyCon True) (get bh) + 3 -> liftM IfNewTyCon (get bh) + _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" + +instance Binary IfaceConDecl where + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh (length a9) + mapM_ (put_ bh) a9 + put_ bh a10 + put_ bh a11 + get bh = do + a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + n_fields <- get bh + a9 <- replicateM n_fields (get bh) + a10 <- get bh + a11 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) + +instance Binary IfaceBang where + put_ bh IfNoBang = putByte bh 0 + put_ bh IfStrict = putByte bh 1 + put_ bh IfUnpack = putByte bh 2 + put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co + + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoBang + 1 -> return IfStrict + 2 -> return IfUnpack + _ -> IfUnpackCo <$> get bh + +instance Binary IfaceSrcBang where + put_ bh (IfSrcBang a1 a2) = + do put_ bh a1 + put_ bh a2 + + get bh = + do a1 <- get bh + a2 <- get bh + return (IfSrcBang a1 a2) + +instance Binary IfaceDefault where + put_ bh (IfaceDefault cls tys warn) = do + put_ bh cls + put_ bh tys + put_ bh warn + get bh = do + cls <- get bh + tys <- get bh + warn <- get bh + return (IfaceDefault cls tys warn) + +instance Binary IfaceClsInst where + put_ bh (IfaceClsInst cls tys dfun flag orph warn) = do + put_ bh cls + put_ bh tys + put_ bh dfun + put_ bh flag + put_ bh orph + put_ bh warn + get bh = do + cls <- get bh + tys <- get bh + dfun <- get bh + flag <- get bh + orph <- get bh + warn <- get bh + return (IfaceClsInst cls tys dfun flag orph warn) + +instance Binary IfaceFamInst where + put_ bh (IfaceFamInst fam tys name orph) = do + put_ bh fam + put_ bh tys + put_ bh name + put_ bh orph + get bh = do + fam <- get bh + tys <- get bh + name <- get bh + orph <- get bh + return (IfaceFamInst fam tys name orph) + +instance Binary IfaceRule where + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) + +instance Binary IfaceWarnings where + put_ bh = \case + IfWarnAll txt -> putByte bh 0 *> put_ bh txt + IfWarnSome vs ds -> putByte bh 1 *> put_ bh vs *> put_ bh ds + get bh = getByte bh >>= \case + 0 -> pure IfWarnAll <*> get bh + 1 -> pure IfWarnSome <*> get bh <*> get bh + _ -> fail "invalid tag(IfaceWarnings)" + +instance Binary IfaceWarningTxt where + put_ bh = \case + IfWarningTxt a1 a2 a3 -> putByte bh 0 *> put_ bh a1 *> put_ bh a2 *> put_ bh a3 + IfDeprecatedTxt a1 a2 -> putByte bh 1 *> put_ bh a1 *> put_ bh a2 + get bh = getByte bh >>= \case + 0 -> pure IfWarningTxt <*> get bh <*> get bh <*> get bh + _ -> pure IfDeprecatedTxt <*> get bh <*> get bh + +instance Binary IfaceStringLiteral where + put_ bh (IfStringLiteral a1 a2) = put_ bh a1 *> put_ bh a2 + get bh = IfStringLiteral <$> get bh <*> get bh + +instance Binary IfaceAnnotation where + put_ bh (IfaceAnnotation a1 a2) = do + put_ bh a1 + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + return (IfaceAnnotation a1 a2) + +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b c d) = do { putByte bh 1 + ; put_ bh a + ; put_ bh b + ; put_ bh c + ; put_ bh d } + put_ bh (IfWorkerLikeId dmds) = putByte bh 2 >> put_ bh dmds + put_ bh IfDFunId = putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do { a <- get bh + ; b <- get bh + ; c <- get bh + ; d <- get bh + ; return (IfRecSelId a b c d) } + 2 -> do { dmds <- get bh + ; return (IfWorkerLikeId dmds) } + _ -> return IfDFunId + +instance Binary IfaceInfoItem where + put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa + put_ bh (HsDmdSig ab) = putByte bh 1 >> put_ bh ab + put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad + put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad + put_ bh HsNoCafRefs = putByte bh 4 + put_ bh (HsCprSig cpr) = putByte bh 6 >> put_ bh cpr + put_ bh (HsLFInfo lf_info) = putByte bh 7 >> put_ bh lf_info + put_ bh (HsTagSig sig) = putByte bh 8 >> put_ bh sig + + get bh = do + h <- getByte bh + case h of + 0 -> liftM HsArity $ get bh + 1 -> liftM HsDmdSig $ get bh + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) + 3 -> liftM HsInline $ get bh + 4 -> return HsNoCafRefs + 6 -> HsCprSig <$> get bh + 7 -> HsLFInfo <$> get bh + _ -> HsTagSig <$> get bh + +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold s c g e) = do + putByte bh 0 + put_ bh s + putUnfoldingCache bh c + put_ bh g + put_ bh e + put_ bh (IfDFunUnfold as bs) = do + putByte bh 1 + put_ bh as + put_ bh bs + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + c <- getUnfoldingCache bh + g <- get bh + e <- get bh + return (IfCoreUnfold s c g e) + _ -> do as <- get bh + bs <- get bh + return (IfDFunUnfold as bs) + +instance Binary IfGuidance where + put_ bh IfNoGuidance = putByte bh 0 + put_ bh (IfWhen a b c ) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoGuidance + _ -> do a <- get bh + b <- get bh + c <- get bh + return (IfWhen a b c) + +putUnfoldingCache :: WriteBinHandle -> IfUnfoldingCache -> IO () +putUnfoldingCache bh (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike + , uf_is_work_free = wf, uf_expandable = exp }) = do + let b = zeroBits .<<|. hnf .<<|. conlike .<<|. wf .<<|. exp + putByte bh b + +getUnfoldingCache :: ReadBinHandle -> IO IfUnfoldingCache +getUnfoldingCache bh = do + b <- getByte bh + let hnf = testBit b 3 + conlike = testBit b 2 + wf = testBit b 1 + exp = testBit b 0 + return (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike + , uf_is_work_free = wf, uf_expandable = exp }) + +seqUnfoldingCache :: IfUnfoldingCache -> () +seqUnfoldingCache (UnfoldingCache hnf conlike wf exp) = + rnf hnf `seq` rnf conlike `seq` rnf wf `seq` rnf exp `seq` () + +infixl 9 .<<|. +(.<<|.) :: (Num a, Bits a) => a -> Bool -> a +x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1) +{-# INLINE (.<<|.) #-} + +instance Binary IfaceAlt where + put_ bh (IfaceAlt a b c) = do + put_ bh a + put_ bh b + put_ bh c + get bh = do + a <- get bh + b <- get bh + c <- get bh + return (IfaceAlt a b c) + +instance Binary IfaceExpr where + put_ bh (IfaceLcl aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceType ab) = do + putByte bh 1 + put_ bh ab + put_ bh (IfaceCo ab) = do + putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 + put_ bh ac + put_ bh ad + put_ bh (IfaceLam (ae, os) af) = do + putByte bh 4 + put_ bh ae + put_ bh os + put_ bh af + put_ bh (IfaceApp ag ah) = do + putByte bh 5 + put_ bh ag + put_ bh ah + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 + put_ bh ai + put_ bh aj + put_ bh ak + put_ bh (IfaceLet al am) = do + putByte bh 7 + put_ bh al + put_ bh am + put_ bh (IfaceTick an ao) = do + putByte bh 8 + put_ bh an + put_ bh ao + put_ bh (IfaceLit ap) = do + putByte bh 9 + put_ bh ap + put_ bh (IfaceFCall as at) = do + putByte bh 10 + put_ bh as + put_ bh at + put_ bh (IfaceExt aa) = do + putByte bh 11 + put_ bh aa + put_ bh (IfaceCast ie ico) = do + putByte bh 12 + put_ bh ie + put_ bh ico + put_ bh (IfaceECase a b) = do + putByte bh 13 + put_ bh a + put_ bh b + put_ bh (IfaceLitRubbish torc r) = do + putByte bh 14 + put_ bh r + put_ bh torc + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceLcl aa) + 1 -> do ab <- get bh + return (IfaceType ab) + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh + ad <- get bh + return (IfaceTuple ac ad) + 4 -> do ae <- get bh + os <- get bh + af <- get bh + return (IfaceLam (ae, os) af) + 5 -> do ag <- get bh + ah <- get bh + return (IfaceApp ag ah) + 6 -> do ai <- get bh + aj <- get bh + ak <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh + am <- get bh + return (IfaceLet al am) + 8 -> do an <- get bh + ao <- get bh + return (IfaceTick an ao) + 9 -> do ap <- get bh + return (IfaceLit ap) + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh + return (IfaceExt aa) + 12 -> do ie <- get bh + ico <- get bh + return (IfaceCast ie ico) + 13 -> do a <- get bh + b <- get bh + return (IfaceECase a b) + 14 -> do r <- get bh + torc <- get bh + return (IfaceLitRubbish torc r) + _ -> panic ("get IfaceExpr " ++ show h) + +instance Binary IfaceTickish where + put_ bh (IfaceHpcTick m ix) = do + putByte bh 0 + put_ bh m + put_ bh ix + put_ bh (IfaceSCC cc tick push) = do + putByte bh 1 + put_ bh cc + put_ bh tick + put_ bh push + put_ bh (IfaceSource src name) = do + putByte bh 2 + put_ bh (srcSpanFile src) + put_ bh (srcSpanStartLine src) + put_ bh (srcSpanStartCol src) + put_ bh (srcSpanEndLine src) + put_ bh (srcSpanEndCol src) + put_ bh name + put_ bh (IfaceBreakpoint (BreakpointId m ix) fvs) = do + putByte bh 3 + put_ bh m + put_ bh ix + put_ bh fvs + + get bh = do + h <- getByte bh + case h of + 0 -> do m <- get bh + ix <- get bh + return (IfaceHpcTick m ix) + 1 -> do cc <- get bh + tick <- get bh + push <- get bh + return (IfaceSCC cc tick push) + 2 -> do file <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + let start = mkRealSrcLoc file sl sc + end = mkRealSrcLoc file el ec + name <- get bh + return (IfaceSource (mkRealSrcSpan start end) name) + 3 -> do m <- get bh + ix <- get bh + fvs <- get bh + return (IfaceBreakpoint (BreakpointId m ix) fvs) + _ -> panic ("get IfaceTickish " ++ show h) + +instance Binary IfaceConAlt where + put_ bh IfaceDefaultAlt = putByte bh 0 + put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa + put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceDefaultAlt + 1 -> liftM IfaceDataAlt $ get bh + _ -> liftM IfaceLitAlt $ get bh + +instance (Binary r, Binary b) => Binary (IfaceBindingX b r) where + put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab + put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } + _ -> do { ac <- get bh; return (IfaceRec ac) } + +instance Binary IfaceLetBndr where + put_ bh (IfLetBndr a b c d) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfLetBndr a b c d) + +instance Binary IfaceTopBndrInfo where + put_ bh (IfLclTopBndr lcl ty info dets) = do + putByte bh 0 + put_ bh lcl + put_ bh ty + put_ bh info + put_ bh dets + put_ bh (IfGblTopBndr gbl) = do + putByte bh 1 + put_ bh gbl + get bh = do + tag <- getByte bh + case tag of + 0 -> IfLclTopBndr <$> get bh <*> get bh <*> get bh <*> get bh + 1 -> IfGblTopBndr <$> get bh + _ -> pprPanic "IfaceTopBndrInfo" (intWithCommas tag) + +instance Binary IfaceMaybeRhs where + put_ bh IfUseUnfoldingRhs = putByte bh 0 + put_ bh (IfRhs e) = do + putByte bh 1 + put_ bh e + + get bh = do + b <- getByte bh + case b of + 0 -> return IfUseUnfoldingRhs + 1 -> IfRhs <$> get bh + _ -> pprPanic "IfaceMaybeRhs" (intWithCommas b) + +instance Binary IfaceTyConParent where + put_ bh IfNoParent = putByte bh 0 + put_ bh (IfDataInstance ax pr ty) = do + putByte bh 1 + put_ bh ax + put_ bh pr + put_ bh ty + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoParent + _ -> do + ax <- get bh + pr <- get bh + ty <- get bh + return $ IfDataInstance ax pr ty + +instance Binary IfaceCompleteMatch where + put_ bh (IfaceCompleteMatch cs mtc) = put_ bh cs >> put_ bh mtc + get bh = IfaceCompleteMatch <$> get bh <*> get bh + + +{- +************************************************************************ +* * + NFData instances + See Note [Avoiding space leaks in toIface*] in GHC.CoreToIface +* * +************************************************************************ +-} + +instance NFData IfaceImport where + rnf (IfaceImport a b) = rnf a `seq` rnf b + +instance NFData ImpIfaceList where + rnf ImpIfaceAll = () + rnf (ImpIfaceEverythingBut ns) = rnf ns + rnf (ImpIfaceExplicit gre explicit) = rnf gre `seq` rnf explicit + +instance NFData IfaceDecl where + rnf = \case + IfaceId f1 f2 f3 f4 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 + + IfaceData f1 f2 f3 f4 f5 f6 f7 f8 f9 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` + rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` rnf f9 + + IfaceSynonym f1 f2 f3 f4 f5 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 + + IfaceFamily f1 f2 f3 f4 f5 f6 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` () + + IfaceClass f1 f2 f3 f4 f5 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 + + IfaceAxiom nm tycon role ax -> + rnf nm `seq` + rnf tycon `seq` + rnf role `seq` + rnf ax + + IfacePatSyn f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` + rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` rnf f11 `seq` () + +instance NFData IfaceAxBranch where + rnf (IfaceAxBranch f1 f2 f3 f4 f5 f6 f7) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 + +instance NFData IfaceClassBody where + rnf = \case + IfAbstractClass -> () + IfConcreteClass f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` () + +instance NFData IfaceBooleanFormula where + rnf = \case + IfVar f1 -> rnf f1 + IfAnd f1 -> rnf f1 + IfOr f1 -> rnf f1 + IfParens f1 -> rnf f1 + +instance NFData IfaceAT where + rnf (IfaceAT f1 f2) = rnf f1 `seq` rnf f2 + +instance NFData IfaceClassOp where + rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` () + +instance NFData IfaceTyConParent where + rnf = \case + IfNoParent -> () + IfDataInstance f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + +instance NFData IfaceConDecls where + rnf = \case + IfAbstractTyCon -> () + IfDataTyCon _ f1 -> rnf f1 + IfNewTyCon f1 -> rnf f1 + +instance NFData IfaceConDecl where + rnf (IfCon f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` + rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` rnf f11 + +instance NFData IfaceSrcBang where + rnf (IfSrcBang f1 f2) = rnf f1 `seq` rnf f2 `seq` () + +instance NFData IfaceBang where + rnf IfNoBang = () + rnf IfStrict = () + rnf IfUnpack = () + rnf (IfUnpackCo co) = rnf co + +instance NFData IfaceIdDetails where + rnf = \case + IfVanillaId -> () + IfWorkerLikeId dmds -> rnf dmds `seq` () + IfRecSelId (Left tycon) b c d -> rnf tycon `seq` rnf b `seq` rnf c `seq` rnf d + IfRecSelId (Right decl) b c d -> rnf decl `seq` rnf b `seq` rnf c `seq` rnf d + IfDFunId -> () + +instance NFData IfaceInfoItem where + rnf = \case + HsArity a -> rnf a + HsDmdSig str -> seqDmdSig str + HsInline p -> rnf p `seq` () + HsUnfold b unf -> rnf b `seq` rnf unf + HsNoCafRefs -> () + HsCprSig cpr -> seqCprSig cpr `seq` () + HsLFInfo lf_info -> rnf lf_info `seq` () + HsTagSig sig -> seqTagSig sig `seq` () + +instance NFData IfGuidance where + rnf = \case + IfNoGuidance -> () + IfWhen a b c -> rnf a `seq` rnf b `seq` rnf c `seq` () + +instance NFData IfaceUnfolding where + rnf = \case + IfCoreUnfold src cache guidance expr -> rnf src `seq` seqUnfoldingCache cache `seq` rnf guidance `seq` rnf expr + IfDFunUnfold bndrs exprs -> rnf bndrs `seq` rnf exprs + +instance NFData IfaceExpr where + rnf = \case + IfaceLcl nm -> rnf nm + IfaceExt nm -> rnf nm + IfaceType ty -> rnf ty + IfaceCo co -> rnf co + IfaceTuple sort exprs -> rnf sort `seq` rnf exprs + IfaceLam bndr expr -> rnf bndr `seq` rnf expr + IfaceApp e1 e2 -> rnf e1 `seq` rnf e2 + IfaceCase e nm alts -> rnf e `seq` rnf nm `seq` rnf alts + IfaceECase e ty -> rnf e `seq` rnf ty + IfaceLet bind e -> rnf bind `seq` rnf e + IfaceCast e co -> rnf e `seq` rnf co + IfaceLit l -> rnf l `seq` () + IfaceLitRubbish tc r -> rnf tc `seq` rnf r `seq` () + IfaceFCall fc ty -> rnf fc `seq` rnf ty + IfaceTick tick e -> rnf tick `seq` rnf e + +instance NFData IfaceAlt where + rnf (IfaceAlt con bndrs rhs) = rnf con `seq` rnf bndrs `seq` rnf rhs + +instance (NFData b, NFData a) => NFData (IfaceBindingX a b) where + rnf = \case + IfaceNonRec bndr e -> rnf bndr `seq` rnf e + IfaceRec binds -> rnf binds + +instance NFData IfaceTopBndrInfo where + rnf (IfGblTopBndr n) = rnf n `seq` () + rnf (IfLclTopBndr fs ty info dets) = rnf fs `seq` rnf ty `seq` rnf info `seq` rnf dets `seq` () + +instance NFData IfaceMaybeRhs where + rnf IfUseUnfoldingRhs = () + rnf (IfRhs ce) = rnf ce `seq` () + +instance NFData IfaceLetBndr where + rnf (IfLetBndr nm ty id_info join_info) = + rnf nm `seq` rnf ty `seq` rnf id_info `seq` rnf join_info + +instance NFData IfaceFamTyConFlav where + rnf = \case + IfaceDataFamilyTyCon -> () + IfaceOpenSynFamilyTyCon -> () + IfaceClosedSynFamilyTyCon f1 -> rnf f1 + IfaceAbstractClosedSynFamilyTyCon -> () + IfaceBuiltInSynFamTyCon -> () + +instance NFData IfaceTickish where + rnf = \case + IfaceHpcTick m i -> rnf m `seq` rnf i + IfaceSCC cc b1 b2 -> rnf cc `seq` rnf b1 `seq` rnf b2 + IfaceSource src str -> rnf src `seq` rnf str + IfaceBreakpoint i fvs -> rnf i `seq` rnf fvs + +instance NFData IfaceConAlt where + rnf = \case + IfaceDefaultAlt -> () + IfaceDataAlt nm -> rnf nm + IfaceLitAlt lit -> rnf lit `seq` () + +instance NFData IfaceCompleteMatch where + rnf (IfaceCompleteMatch f1 mtc) = rnf f1 `seq` rnf mtc + +instance NFData IfaceRule where + rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` () + +instance NFData IfaceDefault where + rnf (IfaceDefault f1 f2 f3) = + rnf f1 `seq` rnf f2 `seq` rnf f3 + +instance NFData IfaceFamInst where + rnf (IfaceFamInst f1 f2 f3 f4) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` () + +instance NFData IfaceClsInst where + rnf (IfaceClsInst f1 f2 f3 f4 f5 f6) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 + +instance NFData IfaceWarnings where + rnf = \case + IfWarnAll txt -> rnf txt + IfWarnSome vs ds -> rnf vs `seq` rnf ds + +instance NFData IfaceWarningTxt where + rnf = \case + IfWarningTxt f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfDeprecatedTxt f1 f2 -> rnf f1 `seq` rnf f2 + +instance NFData IfaceStringLiteral where + rnf (IfStringLiteral f1 f2) = rnf f1 `seq` rnf f2 + +instance NFData IfaceAnnotation where + rnf (IfaceAnnotation f1 f2) = rnf f1 `seq` rnf f2 `seq` () diff --git a/GHC/Iface/Tidy.hs b/GHC/Iface/Tidy.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Tidy.hs @@ -0,0 +1,1489 @@ + +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE NamedFieldPuns #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-| Tidying up Core + +This module's purpose is to prepare the Core program for two distinct purposes: +* To be serialised into the module's interface file +* To feed to the code generator + +The most important tasks are: +* Determine which `Name`s should ultimately be `Internal` and `External` + (which may differ to whether they were originally `Internal` or `External`). + See `Note [About the NameSorts]` in GHC.Types.Name. + For example, in: + module M where + f x = x + y + where y = factorial 4 + could be optimized during the Core pass to: + module M where + y = factorial 4 + f x = x + y + in which case `y` would be changed from `Internal` to `External`. + +* Rename local identifiers to avoid name clashes, so that unfoldings etc can + be serialialised using the OccName, without Uniques. + + For example (`x_5` means `x` with a `Unique` of `5`): + f x_12 x_23 = x_12 + would be changed to: + f x_12 x1_23 = x_12 +-} +module GHC.Iface.Tidy + ( TidyOpts (..) + , UnfoldingExposure (..) + , tidyProgram + , mkBootModDetailsTc + ) +where + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Tc.Utils.Env + +import GHC.Core +import GHC.Core.Unfold +import GHC.Core.FVs +import GHC.Core.Tidy +import GHC.Core.Seq ( seqBinds ) +import GHC.Core.Opt.Arity ( exprArity, typeArity, exprBotStrictness_maybe ) +import GHC.Core.InstEnv +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.TyCo.Tidy +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) + +import GHC.Iface.Tidy.StaticPtrTable +import GHC.Iface.Env + +import GHC.Utils.Outputable +import GHC.Utils.Misc( filterOut ) +import GHC.Utils.Panic +import GHC.Utils.Logger as Logger +import qualified GHC.Utils.Error as Err + +import GHC.Types.ForeignStubs +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand ( isDeadEndAppSig, isNopSig, nopSig, isDeadEndSig ) +import GHC.Types.Basic +import GHC.Types.TyThing( implicitTyConThings ) +import GHC.Types.Name hiding (varName) +import GHC.Types.Name.Set +import GHC.Types.Name.Cache +import GHC.Types.Avail +import GHC.Types.Tickish +import GHC.Types.TypeEnv +import GHC.Tc.Utils.TcType (tcSplitNestedSigmaTys) + +import GHC.Unit.Module +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.Deps + +import GHC.Data.Maybe + +import Control.Monad +import Data.Function +import Data.List ( sortBy, mapAccumL ) +import qualified Data.Set as S +import GHC.Types.CostCentre + +{- +Constructing the TypeEnv, Instances, Rules from which the +ModIface is constructed, and which goes on to subsequent modules in +--make mode. + +Most of the interface file is obtained simply by serialising the +TypeEnv. One important consequence is that if the *interface file* +has pragma info if and only if the final TypeEnv does. This is not so +important for *this* module, but it's essential for ghc --make: +subsequent compilations must not see (e.g.) the arity if the interface +file does not contain arity If they do, they'll exploit the arity; +then the arity might change, but the iface file doesn't change => +recompilation does not happen => disaster. + +For data types, the final TypeEnv will have a TyThing for the TyCon, +plus one for each DataCon; the interface file will contain just one +data type declaration, but it is de-serialised back into a collection +of TyThings. + +************************************************************************ +* * + Plan A: simpleTidyPgm +* * +************************************************************************ + + +Plan A: mkBootModDetails: omit pragmas, make interfaces small +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Ignore the bindings + +* Drop all WiredIn things from the TypeEnv + (we never want them in interface files) + +* Retain all TyCons and Classes in the TypeEnv, to avoid + having to find which ones are mentioned in the + types of exported Ids + +* Trim off the constructors of non-exported TyCons, both + from the TyCon and from the TypeEnv + +* Drop non-exported Ids from the TypeEnv + +* Tidy the types of the DFunIds of Instances, + make them into GlobalIds, (they already have External Names) + and add them to the TypeEnv + +* Tidy the types of the (exported) Ids in the TypeEnv, + make them into GlobalIds (they already have External Names) + +* Drop rules altogether + +* Tidy the bindings, to ensure that the Arity + information is correct for each top-level binder; the + code generator needs it. And to ensure that local names have + distinct OccNames in case of object-file splitting + +* If this an hsig file, drop the instances altogether too (they'll + get pulled in by the implicit module import. +-} + +-- This is Plan A: make a small type env when typechecking only, +-- or when compiling a hs-boot file, or simply when not using -O +-- +-- We don't look at the bindings at all -- there aren't any +-- for hs-boot files + +mkBootModDetailsTc :: Logger -> TcGblEnv -> IO ModDetails +mkBootModDetailsTc logger + TcGblEnv{ tcg_exports = exports, + tcg_type_env = type_env, -- just for the Ids + tcg_tcs = tcs, + tcg_patsyns = pat_syns, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_complete_matches = complete_matches, + tcg_mod = this_mod, + tcg_default_exports = default_exports + } + = -- This timing isn't terribly useful since the result isn't forced, but + -- the message is useful to locating oneself in the compilation process. + Err.withTiming logger + (text "CoreTidy"<+>brackets (ppr this_mod)) + (const ()) $ + return (ModDetails { md_types = type_env' + , md_defaults = default_exports + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_anns = [] + , md_exports = exports + , md_complete_matches = complete_matches + }) + where + -- Find the LocalIds in the type env that are exported + -- Make them into GlobalIds, and tidy their types + -- + -- It's very important to remove the non-exported ones + -- because we don't tidy the OccNames, and if we don't remove + -- the non-exported ones we'll get many things with the + -- same name in the interface file, giving chaos. + -- + -- Do make sure that we keep Ids that are already Global. + -- When typechecking an .hs-boot file, the Ids come through as + -- GlobalIds. + final_ids = [ globaliseAndTidyBootId id + | id <- typeEnvIds type_env + , keep_it id ] + + final_tcs = filterOut isWiredIn tcs + -- See Note [Drop wired-in things] + type_env' = typeEnvFromEntities final_ids final_tcs pat_syns fam_insts + insts' = mkFinalClsInsts type_env' $ mkInstEnv insts + + -- Default methods have their export flag set (isExportedId), + -- but everything else doesn't (yet), because this is + -- pre-desugaring, so we must test against the exports too. + keep_it id | isWiredInName id_name = False + -- See Note [Drop wired-in things] + | isExportedId id = True + | id_name `elemNameSet` exp_names = True + | otherwise = False + where + id_name = idName id + + exp_names = availsToNameSet exports + +lookupFinalId :: TypeEnv -> Id -> Id +lookupFinalId type_env id + = case lookupTypeEnv type_env (idName id) of + Just (AnId id') -> id' + _ -> pprPanic "lookup_final_id" (ppr id) + +mkFinalClsInsts :: TypeEnv -> InstEnv -> InstEnv +mkFinalClsInsts env = updateClsInstDFuns (lookupFinalId env) + +globaliseAndTidyBootId :: Id -> Id +-- For a LocalId with an External Name, +-- makes it into a GlobalId +-- * unchanged Name (might be Internal or External) +-- * unchanged details +-- * VanillaIdInfo (makes a conservative assumption about arity) +-- * BootUnfolding (see Note [Inlining and hs-boot files] in GHC.CoreToIface) +globaliseAndTidyBootId id + = updateIdTypeAndMult tidyTopType (globaliseId id) + `setIdUnfolding` BootUnfolding + +{- +************************************************************************ +* * + Plan B: tidy bindings, make TypeEnv full of IdInfo +* * +************************************************************************ + +Plan B: include pragmas, make interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Step 1: Figure out which Ids are externally visible + See Note [Choosing external Ids] + +* Step 2: Gather the externally visible rules, separately from + the top-level bindings. + See Note [Finding external rules] + +* Step 3: Tidy the bindings, externalising appropriate Ids + See Note [Tidy the top-level bindings] + +* Drop all Ids from the TypeEnv, and add all the External Ids from + the bindings. (This adds their IdInfo to the TypeEnv; and adds + floated-out Ids that weren't even in the TypeEnv before.) + +Note [Choosing external Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also the section "Interface stability" in the +recompilation-avoidance commentary: + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance + +First we figure out which Ids are "external" Ids. An +"external" Id is one that is visible from outside the compilation +unit. These are + a) the user exported ones + b) the ones bound to static forms + c) ones mentioned in the unfoldings, workers, or + rules of externally-visible ones + +While figuring out which Ids are external, we pick a "tidy" OccName +for each one. That is, we make its OccName distinct from the other +external OccNames in this module, so that in interface files and +object code we can refer to it unambiguously by its OccName. The +OccName for each binder is prefixed by the name of the exported Id +that references it; e.g. if "f" references "x" in its unfolding, then +"x" is renamed to "f_x". This helps distinguish the different "x"s +from each other, and means that if "f" is later removed, things that +depend on the other "x"s will not need to be recompiled. Of course, +if there are multiple "f_x"s, then we have to disambiguate somehow; we +use "f_x0", "f_x1" etc. + +As far as possible we should assign names in a deterministic fashion. +Each time this module is compiled with the same options, we should end +up with the same set of external names with the same types. That is, +the ABI hash in the interface should not change. This turns out to be +quite tricky, since the order of the bindings going into the tidy +phase is already non-deterministic, as it is based on the ordering of +Uniques, which are assigned unpredictably. + +To name things in a stable way, we do a depth-first-search of the +bindings, starting from the exports sorted by name. This way, as long +as the bindings themselves are deterministic (they sometimes aren't!), +the order in which they are presented to the tidying phase does not +affect the names we assign. + +Note [Tidy the top-level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Next we traverse the bindings top to bottom. For each *top-level* +binder + + 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, + reflecting the fact that from now on we regard it as a global, + not local, Id + + 2. Give it a system-wide Unique. + [Even non-exported things need system-wide Uniques because the + byte-code generator builds a single Name->BCO symbol table.] + + We use the given NameCache as the source of such system-wide uniques. + + For external Ids, use the original-name cache in the NameCache + to ensure that the unique assigned is the same as the Id had + in any previous compilation run. + + 3. Rename top-level Ids according to the names we chose in step 1. + If it's an external Id, make it have a External Name, otherwise + make it have an Internal Name. This is used by the code generator + to decide whether to make the label externally visible + + 4. Give it its UTTERLY FINAL IdInfo; in ptic, + * its unfolding, if it should have one + + * its arity, computed from the number of visible lambdas + + +Finally, substitute these new top-level binders consistently +throughout, including in unfoldings. We also tidy binders in +RHSs, so that they print nicely in interfaces. + +Note [Always expose compulsory unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must make absolutely sure that unsafeCoerce# is inlined. You might +think that giving it a compulsory unfolding is enough. However, +unsafeCoerce# is put in an interface file just like any other definition. +So, unless we take special precuations +- If we compiled Unsafe.Coerce with -O0, we might not put the unfolding + into the interface file. +- If we compile a module M, that imports Unsafe.Coerce, with -O0 we might + not read the unfolding out of the interface file. + +So we need to take care, to ensure that Compulsory unfoldings are written +and read. That makes sense: they are compulsory, after all. There are +three places this is actioned: + +* GHC.Iface.Tidy.addExternal. Export end: expose compulsory + unfoldings, even with -O0. + +* GHC.IfaceToCore.tcIdInfo. Import end: when reading in from + interface file, even with -O0 (fignore-interface-pragmas.) we must + load a compulsory unfolding +-} + +data UnfoldingExposure + = ExposeNone -- ^ Don't expose unfoldings + | ExposeSome -- ^ Expose mandatory unfoldings and those meeting inlining thresholds. + | ExposeOverloaded -- ^ Expose unfoldings useful for inlinings and those which + -- which might be specialised. See Note [Exposing overloaded functions] + | ExposeAll -- ^ Expose all unfoldings + deriving (Show,Eq,Ord) + +data TidyOpts = TidyOpts + { opt_name_cache :: !NameCache + , opt_collect_ccs :: !Bool -- ^ Always true if we compile with -prof + , opt_unfolding_opts :: !UnfoldingOpts + , opt_expose_unfoldings :: !UnfoldingExposure + -- ^ Which unfoldings to expose + , opt_trim_ids :: !Bool + -- ^ trim off the arity, one-shot-ness, strictness etc which were + -- retained for the benefit of the code generator + , opt_expose_rules :: !Bool + -- ^ Are rules exposed or not? + , opt_static_ptr_opts :: !(Maybe StaticPtrOpts) + -- ^ Options for generated static pointers, if enabled (/= Nothing). + , opt_keep_auto_rules :: !Bool + } + +tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails) +tidyProgram opts (ModGuts { mg_module = mod + , mg_exports = exports + , mg_tcs = tcs + , mg_defaults = cls_defaults + , 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_modBreaks = modBreaks + , mg_boot_exports = boot_exports + }) = do + + (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod tcs binds imp_rules + let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env + + (tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds + + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. + (spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of + Nothing -> pure ([], Nothing, tidy_binds) + Just sopts -> sptCreateStaticBinds sopts mod tidy_binds + + -- pprTraceM "trimmed_rules" (ppr trimmed_rules) + + let all_foreign_stubs = case mcstub of + Nothing -> foreign_stubs + Just cstub -> foreign_stubs `appendStubC` cstub + + -- The completed type environment is gotten from + -- a) the types and classes defined here (plus implicit things) + -- b) adding Ids with correct IdInfo, including unfoldings, + -- gotten from the bindings + -- From (b) we keep only those Ids with External names; + -- the CoreTidy pass makes sure these are all and only + -- the externally-accessible ones + -- This truncates the type environment to include only the + -- exported Ids and things needed from them, which saves space + -- + -- See Note [Don't attempt to trim data types] + final_ids = [ trimId (opt_trim_ids opts) id + | id <- bindersOfBinds tidy_binds + , isExternalName (idName id) + , not (isWiredIn id) + ] -- See Note [Drop wired-in things] + + final_tcs = filterOut isWiredIn tcs + -- See Note [Drop wired-in things] + tidy_type_env = typeEnvFromEntities final_ids final_tcs patsyns fam_insts + tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts + tidy_rules = tidyRules tidy_env trimmed_rules + + -- See Note [Injecting implicit bindings] + all_tidy_binds = tidy_binds' + + -- Get the TyCons to generate code for. Careful! We must use + -- the untidied TyCons here, because we need + -- (a) implicit TyCons arising from types and classes defined + -- in this module + -- (b) wired-in TyCons, which are normally removed from the + -- TypeEnv we put in the ModDetails + -- (c) Constructors even if they are not exported (the + -- tidied TypeEnv has trimmed these away) + alg_tycons = filter isAlgTyCon tcs + + local_ccs + | opt_collect_ccs opts + = collectCostCentres mod all_tidy_binds tidy_rules + | otherwise + = S.empty + + return (CgGuts { cg_module = mod + , cg_tycons = alg_tycons + , cg_binds = all_tidy_binds + , cg_ccs = S.toList local_ccs + , cg_foreign = all_foreign_stubs + , cg_foreign_files = foreign_files + -- TODO: Check whether we need to account for levels here. + -- It seems that this field just gets used to write a comment + -- in C codegen, so it's value doesn't affect an important result. + , cg_dep_pkgs = S.map snd (dep_direct_pkgs deps) + , cg_modBreaks = modBreaks + , cg_spt_entries = spt_entries + } + , ModDetails { md_types = tidy_type_env + , md_rules = tidy_rules + , md_defaults = cls_defaults + , md_insts = tidy_cls_insts + , md_fam_insts = fam_insts + , md_exports = exports + , md_anns = anns -- are already tidy + , md_complete_matches = complete_matches + } + ) + + +------------------------------------------------------------------------------ +-- Collecting cost centres +-- --------------------------------------------------------------------------- + +-- | Collect cost centres defined in the current module, including those in +-- unfoldings. +collectCostCentres :: Module -> CoreProgram -> [CoreRule] -> S.Set CostCentre +collectCostCentres mod_name binds rules + = {-# SCC collectCostCentres #-} foldl' go_bind (go_rules S.empty) binds + where + go cs e = case e of + Var{} -> cs + Lit{} -> cs + App e1 e2 -> go (go cs e1) e2 + Lam _ e -> go cs e + Let b e -> go (go_bind cs b) e + Case scrt _ _ alts -> go_alts (go cs scrt) alts + Cast e _ -> go cs e + Tick (ProfNote cc _ _) e -> + go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e + Tick _ e -> go cs e + Type{} -> cs + Coercion{} -> cs + + go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e) + + go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre + go_bind cs (NonRec b e) = + go (do_binder cs b) e + go_bind cs (Rec bs) = + foldl' (\cs' (b, e) -> go (do_binder cs' b) e) cs bs + + do_binder cs b = maybe cs (go cs) (get_unf b) + + -- Unfoldings may have cost centres that in the original definion are + -- optimized away, see #5889. + get_unf = maybeUnfoldingTemplate . realIdUnfolding + + -- Have to look at the RHS of rules as well, as these may contain ticks which + -- don't appear anywhere else. See #19894 + go_rules cs = foldl' go cs (mapMaybe get_rhs rules) + + get_rhs Rule { ru_rhs } = Just ru_rhs + get_rhs BuiltinRule {} = Nothing + +-------------------------- +trimId :: Bool -> Id -> Id +-- With -O0 we now trim off the arity, one-shot-ness, strictness +-- etc which tidyTopIdInfo retains for the benefit of the code generator +-- but which we don't want in the interface file or ModIface for +-- downstream compilations +trimId do_trim id + | do_trim, not (isImplicitId id) + = id `setIdInfo` vanillaIdInfo + `setIdUnfolding` idUnfolding id + -- We respect the final unfolding chosen by tidyTopIdInfo. + -- We have already trimmed it if we don't want it for -O0; + -- see also Note [Always expose compulsory unfoldings] + + | otherwise -- No trimming + = id + +{- Note [Drop wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never put wired-in TyCons or Ids in an interface file. +They are wired-in, so the compiler knows about them already. + +Note [Don't attempt to trim data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some time GHC tried to avoid exporting the data constructors +of a data type if it wasn't strictly necessary to do so; see #835. +But "strictly necessary" accumulated a longer and longer list +of exceptions, and finally I gave up the battle: + + commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11 + Author: Simon Peyton Jones + Date: Thu Dec 6 16:03:16 2012 +0000 + + Stop attempting to "trim" data types in interface files + + Without -O, we previously tried to make interface files smaller + by not including the data constructors of data types. But + there are a lot of exceptions, notably when Template Haskell is + involved or, more recently, DataKinds. + + However #7445 shows that even without TemplateHaskell, using + the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ + is enough to require us to expose the data constructors. + + So I've given up on this "optimisation" -- it's probably not + important anyway. Now I'm simply not attempting to trim off + the data constructors. The gain in simplicity is worth the + modest cost in interface file growth, which is limited to the + bits reqd to describe those data constructors. + +-} + +{- +************************************************************************ +* * +\subsection{Step 1: finding externals} +* * +************************************************************************ + +See Note [Choosing external Ids]. +-} + +type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) + -- Maps each top-level Id to its new Name (the Id is tidied in step 2) + -- The Unique is unchanged. If the new Name is external, it will be + -- visible in the interface file. + -- + -- Bool => expose unfolding or not. + +chooseExternalIds :: TidyOpts + -> Module + -> [TyCon] + -> [CoreBind] + -> [CoreRule] + -> IO (UnfoldEnv, TidyOccEnv) + -- Step 1 from the notes above + +chooseExternalIds opts mod tcs binds imp_id_rules + = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env + ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders + ; tidy_internal internal_ids unfold_env1 occ_env1 } + where + name_cache = opt_name_cache opts + + -- init_ext_ids is the initial list of Ids that should be + -- externalised. It serves as the starting point for finding a + -- deterministic, tidy, renaming for all external Ids in this + -- module. + -- + -- It is sorted, so that it has a deterministic order (i.e. it's the + -- same list every time this module is compiled), in contrast to the + -- bindings, which are ordered non-deterministically. + init_work_list = zip init_ext_ids init_ext_ids + init_ext_ids = sortBy (compare `on` getOccName) $ filter is_external binders + + -- An Id should be external if either (a) it is exported, + -- (b) local rules are exposed and it appears in the RHS of a local rule for + -- an imported Id, or See Note [Which rules to expose] + is_external id + | isExportedId id = True + | opt_expose_rules opts = id `elemVarSet` rule_rhs_vars + | otherwise = False + + rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules + + binders = map fst $ flattenBinds binds + binder_set = mkVarSet binders + + avoids = [ getOccName name | bndr <- binders, + let name = idName bndr, + isExternalName name ] + ++ [ getOccName thing | tc <- tcs + , thing <- implicitTyConThings tc ] + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + + -- We also make sure to avoid any exported binders. Consider + -- f{-u1-} = 1 -- Local decl + -- ... + -- f{-u2-} = 2 -- Exported decl + -- + -- The second exported decl must 'get' the name 'f', so we + -- have to put 'f' in the avoids list before we get to the first + -- decl. tidyTopId then does a no-op on exported binders. + init_occ_env = initTidyOccEnv avoids + + + search :: [(Id,Id)] -- The work-list: (external id, referring id) + -- Make a tidy, external Name for the external id, + -- add it to the UnfoldEnv, and do the same for the + -- transitive closure of Ids it refers to + -- The referring id is used to generate a tidy + --- name for the external id + -> UnfoldEnv -- id -> (new Name, show_unfold) + -> TidyOccEnv -- occ env for choosing new Names + -> IO (UnfoldEnv, TidyOccEnv) + + search [] unfold_env occ_env = return (unfold_env, occ_env) + + search ((idocc,referrer) : rest) unfold_env occ_env + | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env + | otherwise = do + (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc + let + (new_ids, show_unfold) = addExternal opts refined_id + + -- 'idocc' is an *occurrence*, but we need to see the + -- unfolding in the *definition*; so look up in binder_set + refined_id = case lookupVarSet binder_set idocc of + Just id -> id + Nothing -> warnPprTrace True "chooseExternalIds" (ppr idocc) idocc + + unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold) + referrer' | isExportedId refined_id = refined_id + | otherwise = referrer + -- + search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env' + + tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv + -> IO (UnfoldEnv, TidyOccEnv) + tidy_internal [] unfold_env occ_env = return (unfold_env,occ_env) + tidy_internal (id:ids) unfold_env occ_env = do + (occ_env', name') <- tidyTopName mod name_cache Nothing occ_env id + let unfold_env' = extendVarEnv unfold_env id (name',False) + tidy_internal ids unfold_env' occ_env' + +addExternal :: TidyOpts -> Id -> ([Id], Bool) +addExternal opts id + | ExposeNone <- opt_expose_unfoldings opts + , not (isCompulsoryUnfolding unfolding) + = ([], False) -- See Note [Always expose compulsory unfoldings] + -- in GHC.HsToCore + + | otherwise + = (new_needed_ids, show_unfold) + + where + new_needed_ids = bndrFvsInOrder show_unfold id + idinfo = idInfo id + unfolding = realUnfoldingInfo idinfo + show_unfold = show_unfolding unfolding + never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) + loop_breaker = isStrongLoopBreaker (occInfo idinfo) + -- bottoming_fn: 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. + 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 }) + = stable || profitable || explicitly_requested + where + -- Always expose things whose + -- source is an inline rule + stable = isStableSource src + -- Good for perf as it might inline + profitable + | never_active = False + | loop_breaker = False + | otherwise = + case guidance of + UnfWhen {} -> True + UnfIfGoodArgs {} -> not bottoming_fn + UnfNever -> False + -- Requested by the user through a flag. + explicitly_requested = + case opt_expose_unfoldings opts of + -- 'ExposeAll' says to expose all + -- unfoldings willy-nilly + ExposeAll -> True + -- Overloaded functions like @foo :: Bar a => ...@ + -- See Note [Exposing overloaded functions] + ExposeOverloaded -> + not bottoming_fn && isOverloaded id + ExposeSome -> False + ExposeNone -> False + + show_unfolding (DFunUnfolding {}) = True + show_unfolding _ = False + +isOverloaded :: Id -> Bool +isOverloaded fn = + let fun_type = idType fn + -- TODO: The specialiser currently doesn't handle newtypes of the + -- form `newtype T x = T (C x => x)` well. So we don't bother + -- looking through newtypes for constraints. + -- (Newtypes are opaque to tcSplitNestedSigmaTys) + -- If the specialiser ever starts looking through newtypes properly + -- we might want to use a version of tcSplitNestedSigmaTys that looks + -- through newtypes. + (_ty_vars, constraints, _ty) = tcSplitNestedSigmaTys fun_type + -- NB: This will consider functions with only equality constraints overloaded. + -- While these sorts of constraints aren't currently useful for specialization + -- it's simpler to just include them. + in not . null $ constraints + +{- Note [Exposing overloaded functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also #13090 and #22942. + +The basic idea is that exposing only overloaded function is reasonably cheap +but allows the specializer to fire more often as unfoldings for overloaded +functions will generally be available. So we make the unfoldings of overloaded +functions available when `-fexpose-overloaded-unfoldings is enabled. + +We use `tcSplitNestedSigmaTys` to see the constraints deep within in types like: + f :: Int -> forall a. Eq a => blah + +We could simply use isClassPred to check if any of the constraints responds to +a class dictionary, but that would miss (perhaps obscure) opportunities +like the one in the program below: + + type family C a where + C Int = Eq Int + C Bool = Ord Bool + + + bar :: C a => a -> a -> Bool + bar = undefined + {-# SPECIALIZE bar :: Int -> Int -> Bool #-} + +GHC will specialize `bar` properly. However `C a =>` isn't recognized as class +predicate since it's a type family in the definition. To ensure it's exposed +anyway we allow for some false positives and simply expose all functions which +have a constraint. This means we might expose more unhelpful unfoldings. But +it seems like the better choice. + +Currently this option is off by default and has to be enabled manually. But +we might change this in the future. +-} + +{- +************************************************************************ +* * + Deterministic free variables +* * +************************************************************************ + +We want a deterministic free-variable list. exprFreeVars gives us +a VarSet, which is in a non-deterministic order when converted to a +list. Hence, here we define a free-variable finder that returns +the free variables in the order that they are encountered. + +See Note [Choosing external Ids] +-} + +bndrFvsInOrder :: Bool -> Id -> [Id] +bndrFvsInOrder show_unfold id + = run (dffvLetBndr show_unfold id) + +run :: DFFV () -> [Id] +run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of + ((_,ids),_) -> ids + +newtype DFFV a + = DFFV (VarSet -- Envt: non-top-level things that are in scope + -- we don't want to record these as free vars + -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far + -> ((VarSet,[Var]),a)) -- Output state + deriving (Functor) + +instance Applicative DFFV where + pure a = DFFV $ \_ st -> (st, a) + (<*>) = ap + +instance Monad DFFV where + (DFFV m) >>= k = DFFV $ \env st -> + case m env st of + (st',a) -> case k a of + DFFV f -> f env st' + +extendScope :: Var -> DFFV a -> DFFV a +extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st) + +extendScopeList :: [Var] -> DFFV a -> DFFV a +extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) + +insert :: Var -> DFFV () +insert v = DFFV $ \ env (set, ids) -> + let keep_me = isLocalId v && + not (v `elemVarSet` env) && + not (v `elemVarSet` set) + in if keep_me + then ((extendVarSet set v, v:ids), ()) + else ((set, ids), ()) + + +dffvExpr :: CoreExpr -> DFFV () +dffvExpr (Var v) = insert v +dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 +dffvExpr (Lam v e) = extendScope v (dffvExpr e) +dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e +dffvExpr (Tick _other e) = dffvExpr e +dffvExpr (Cast e _) = dffvExpr e +dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) +dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ + (mapM_ dffvBind prs >> dffvExpr e) +dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) +dffvExpr _other = return () + +dffvAlt :: CoreAlt -> DFFV () +dffvAlt (Alt _ xs r) = extendScopeList xs (dffvExpr r) + +dffvBind :: (Id, CoreExpr) -> DFFV () +dffvBind(x,r) + | not (isId x) = dffvExpr r + | otherwise = dffvLetBndr False x >> dffvExpr r + -- Pass False because we are doing the RHS right here + -- If you say True you'll get *exponential* behaviour! + +dffvLetBndr :: Bool -> Id -> DFFV () +-- Gather the free vars of the RULES and unfolding of a binder +-- We always get the free vars of a *stable* unfolding, but +-- for a *vanilla* one (VanillaSrc), the flag controls what happens: +-- True <=> get fvs of even a *vanilla* unfolding +-- False <=> ignore a VanillaSrc +-- For nested bindings (call from dffvBind) we always say "False" because +-- we are taking the fvs of the RHS anyway +-- For top-level bindings (call from addExternal, via bndrFvsInOrder) +-- we say "True" if we are exposing that unfolding +dffvLetBndr vanilla_unfold id + = do { go_unf (realUnfoldingInfo idinfo) + ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) } + where + idinfo = idInfo id + + go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + | isStableSource src = dffvExpr rhs + | vanilla_unfold = dffvExpr rhs + | otherwise = return () + + go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = extendScopeList bndrs $ mapM_ dffvExpr args + go_unf _ = return () + + go_rule (BuiltinRule {}) = return () + go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) + = extendScopeList bndrs (dffvExpr rhs) + +{- +************************************************************************ +* * + findExternalRules +* * +************************************************************************ + +Note [Finding external rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The complete rules are gotten by combining + a) local rules for imported Ids + b) rules embedded in the top-level Ids + +There are two complications: + * Note [Which rules to expose] + * Note [Trimming auto-rules] + +Note [Which rules to expose] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function 'expose_rule' filters out rules that mention, on the LHS, +Ids that aren't externally visible; these rules can't fire in a client +module. + +The externally-visible binders are computed (by chooseExternalIds) +assuming that all orphan rules are externalised (see init_ext_ids in +function 'search'). So in fact it's a bit conservative and we may +export more than we need. (It's a sort of mutual recursion.) + +Note [Trimming auto-rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Second, with auto-specialisation we may specialise local or imported +dfuns or INLINE functions, and then later inline them. That may leave +behind something like + RULE "foo" forall d. f @ Int d = f_spec +where f is either local or imported, and there is no remaining +reference to f_spec except from the RULE. + +Now that RULE *might* be useful to an importing module, but that is +purely speculative, and meanwhile the code is taking up space and +codegen time. I found that binary sizes jumped by 6-10% when I +started to specialise INLINE functions (again, Note [Inline +specialisations] in GHC.Core.Opt.Specialise). + +So it seems better to drop the binding for f_spec, and the rule +itself, if the auto-generated rule is the *only* reason that it is +being kept alive. + +(The RULE still might have been useful in the past; that is, it was +the right thing to have generated it in the first place. See Note +[Inline specialisations] in GHC.Core.Opt.Specialise. But now it has +served its purpose, and can be discarded.) + +So findExternalRules does this: + * Remove all bindings that are kept alive *only* by isAutoRule rules + (this is done in trim_binds) + * Remove all auto rules that mention bindings that have been removed + (this is done by filtering by keep_rule) + +NB: if a binding is kept alive for some *other* reason (e.g. f_spec is +called in the final code), we keep the rule too. + +This stuff is the only reason for the ru_auto field in a Rule. + +We discard auto-rules by default, but keep them if -fkeep-auto-rules is on. + +* Discard by default: in #18532 we looked at keeping auto-rules and it turned out to just make + compiler performance worse while increasing code sizes at the same time. The + impact varied. Compiling Cabal got ~3% slower, allocated ~3% more and wrote 15% + more code to disk. Nofib only saw 0.7% more compiler allocations and executable + file size growth. But given there was no difference in runtime for these + benchmarks it turned out to be flat out worse. See the ticket for more details. + +* Keep with -fkeep-auto-rules: in #21917 we found cases where we get a lot code + duplication when we discard specialisations. Agda is a case in point. Having + a flag gives us control over the rule-trimming decision. +-} + +findExternalRules :: TidyOpts + -> [CoreBind] + -> [CoreRule] -- Local rules for imported fns + -> UnfoldEnv -- Ids that are exported, so we need their rules + -> ([CoreBind], [CoreRule]) +-- See Note [Finding external rules] +findExternalRules opts binds imp_id_rules unfold_env + = (trimmed_binds, filter keep_rule all_rules) + where + imp_rules | opt_expose_rules opts = filter expose_rule imp_id_rules + | otherwise = [] + imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules + + user_rule_rhs_fvs rule | isAutoRule rule && not (opt_keep_auto_rules opts) + = emptyVarSet + | otherwise = ruleRhsFreeVars rule + + (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds + + keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs + -- Remove rules that make no sense, because they mention a + -- local binder (on LHS or RHS) that we have now discarded. + -- (NB: ruleFreeVars only includes LocalIds) + -- + -- LHS: we have already filtered out rules that mention internal Ids + -- on LHS but that isn't enough because we might have by now + -- discarded a binding with an external Id. (How? + -- chooseExternalIds is a bit conservative.) + -- + -- RHS: the auto rules that might mention a binder that has + -- been discarded; see Note [Trimming auto-rules] + + expose_rule rule = all is_external_id (ruleLhsFreeIdsList rule) + -- Don't expose a rule whose LHS mentions a locally-defined + -- Id that is completely internal (i.e. not visible to an + -- importing module). NB: ruleLhsFreeIds only returns LocalIds. + -- See Note [Which rules to expose] + + is_external_id id = case lookupVarEnv unfold_env id of + Just (name, _) -> isExternalName name && not (isImplicitId id) + Nothing -> False + + trim_binds :: [CoreBind] + -> ( [CoreBind] -- Trimmed bindings + , VarSet -- Binders of those bindings + , VarSet -- Free vars of those bindings + rhs of user rules + -- (we don't bother to delete the binders) + , [CoreRule]) -- All rules, imported + from the bindings + -- This function removes unnecessary bindings, and gathers up rules from + -- the bindings we keep. See Note [Trimming auto-rules] + trim_binds [] -- Base case, start with imp_user_rule_fvs + = ([], emptyVarSet, imp_user_rule_fvs, imp_rules) + + trim_binds (bind:binds) + | any needed bndrs -- Keep this binding + = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules ) + | otherwise -- Discard binding altogether + = stuff + where + stuff@(binds', bndr_set, needed_fvs, rules) + = trim_binds binds + needed bndr = isExportedId bndr || bndr `elemVarSet` needed_fvs + + bndrs = bindersOf bind + rhss = rhssOfBind bind + bndr_set' = bndr_set `extendVarSetList` bndrs + + needed_fvs' = needed_fvs `unionVarSet` + mapUnionVarSet idUnfoldingVars bndrs `unionVarSet` + -- Ignore type variables in the type of bndrs + mapUnionVarSet exprFreeVars rhss `unionVarSet` + mapUnionVarSet user_rule_rhs_fvs local_rules + -- In needed_fvs', we don't bother to delete binders from the fv set + + local_rules = [ rule + | opt_expose_rules opts + , id <- bndrs + , is_external_id id -- Only collect rules for external Ids + , rule <- idCoreRules id + , expose_rule rule ] -- and ones that can fire in a client + +{- +************************************************************************ +* * + tidyTopName +* * +************************************************************************ + +This is where we set names to local/global based on whether they really are +externally visible (see comment at the top of this module). If the name +was previously local, we have to give it a unique occurrence name if +we intend to externalise it. +-} + +tidyTopName :: Module -> NameCache -> Maybe Id -> TidyOccEnv + -> Id -> IO (TidyOccEnv, Name) +tidyTopName mod name_cache maybe_ref occ_env id + | global && internal = return (occ_env, localiseName name) + + | global && external = return (occ_env, name) + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too + + -- Now we get to the real reason that all this is in the IO Monad: + -- we have to update the name cache in a nice atomic fashion + + | local && internal = do uniq <- takeUniqFromNameCache name_cache + -- See #19619 + let new_local_name = occ' `seq` mkInternalName uniq occ' loc + return (occ_env', new_local_name) + -- Even local, internal names must get a unique occurrence. + -- This is necessary because the byte-code generator the byte-code + -- generator builds a system-wide Name->BCO symbol table. + + | local && external = do new_external_name <- allocateGlobalBinder name_cache mod occ' loc + return (occ_env', new_external_name) + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- All this is done by allocateGlobalBinder. + -- This is needed when *re*-compiling a module in GHCi; we must + -- use the same name for externally-visible things as we did before. + + | otherwise = panic "tidyTopName" + where + !name = idName id + external = isJust maybe_ref + global = isExternalName name + local = not global + internal = not external + !loc = nameSrcSpan name + + old_occ = nameOccName name + new_occ | Just ref <- maybe_ref + , ref /= id + = mkOccName (occNameSpace old_occ) $ + let + ref_str = occNameString (getOccName ref) + occ_str = occNameString old_occ + in + case occ_str of + '$':'w':_ -> occ_str + -- workers: the worker for a function already + -- includes the occname for its parent, so there's + -- no need to prepend the referrer. + _other | isSystemName name -> ref_str + | otherwise -> ref_str ++ '_' : occ_str + -- If this name was system-generated, then don't bother + -- to retain its OccName, just use the referrer. These + -- system-generated names will become "f1", "f2", etc. for + -- a referrer "f". + | otherwise = old_occ + + (occ_env', occ') = tidyOccName occ_env new_occ + + +{- +************************************************************************ +* * +\subsection{Step 2: top-level tidying} +* * +************************************************************************ +-} + +-- TopTidyEnv: when tidying we need to know +-- * name_cache: The NameCache, containing a unique supply and any pre-ordained Names. +-- These may have arisen because the +-- renamer read in an interface file mentioning M.$wf, say, +-- and assigned it unique r77. If, on this compilation, we've +-- invented an Id whose name is $wf (but with a different unique) +-- we want to rename it to have unique r77, so that we can do easy +-- comparisons with stuff from the interface file +-- +-- * occ_env: The TidyOccEnv, which tells us which local occurrences +-- are 'used' +-- +-- * subst_env: A Var->Var mapping that substitutes the new Var for the old + +tidyTopBinds :: UnfoldEnv + -> NameSet + -> TidyOccEnv + -> CoreProgram + -> IO (TidyEnv, CoreProgram) + +tidyTopBinds unfold_env boot_exports init_occ_env binds + = do let result = tidy init_env binds + seqBinds (snd result) `seq` return result + -- This seqBinds avoids a spike in space usage (see #13564) + where + init_env = (init_occ_env, emptyVarEnv) + + tidy = mapAccumL (tidyTopBind unfold_env boot_exports) + +------------------------ +tidyTopBind :: UnfoldEnv + -> NameSet + -> TidyEnv + -> CoreBind + -> (TidyEnv, CoreBind) + +tidyTopBind unfold_env boot_exports + (occ_env,subst1) (NonRec bndr rhs) + = (tidy_env2, NonRec bndr' rhs') + where + (bndr', rhs') = tidyTopPair unfold_env boot_exports tidy_env2 (bndr, rhs) + subst2 = extendVarEnv subst1 bndr bndr' + tidy_env2 = (occ_env, subst2) + +tidyTopBind unfold_env boot_exports (occ_env, subst1) (Rec prs) + = (tidy_env2, Rec prs') + where + prs' = map (tidyTopPair unfold_env boot_exports tidy_env2) prs + subst2 = extendVarEnvList subst1 (map fst prs `zip` map fst prs') + tidy_env2 = (occ_env, subst2) + -- This is where we "tie the knot": tidy_env2 is fed into tidyTopPair + +----------------------------------------------------------- +tidyTopPair :: UnfoldEnv + -> NameSet + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) + -- This function is the heart of Step 2 + -- The rec_tidy_env is the one to use for the IdInfo + -- It's necessary because when we are dealing with a recursive + -- group, a variable late in the group might be mentioned + -- in the IdInfo of one early in the group + +tidyTopPair unfold_env boot_exports rhs_tidy_env (bndr, rhs) + = -- pprTrace "tidyTop" (ppr name' <+> ppr details <+> ppr rhs) $ + (bndr1, rhs1) + + where + (name',show_unfold) = case lookupVarEnv unfold_env bndr of + Just stuff -> stuff + Nothing -> pprPanic "tidyTopPair" (ppr bndr) + !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs + bndr1 = mkGlobalId details name' ty' idinfo' + details = idDetails cbv_bndr -- Preserve the IdDetails + ty' = tidyTopType (idType cbv_bndr) + rhs1 = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo rhs_tidy_env name' ty' + rhs rhs1 (idInfo cbv_bndr) show_unfold + +-- tidyTopIdInfo creates the final IdInfo for top-level +-- binders. The delicate piece: +-- +-- * Arity. After CoreTidy, this arity must not change any more. +-- Indeed, CorePrep must eta expand where necessary to make +-- the manifest arity equal to the claimed arity. +-- +tidyTopIdInfo :: TidyEnv -> Name -> Type + -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> IdInfo +tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold + | not is_external -- For internal Ids (not externally visible) + = vanillaIdInfo -- we only need enough info for code generation + -- Arity and strictness info are enough; + -- c.f. GHC.Core.Tidy.tidyLetBndr + `setArityInfo` arity + `setDmdSigInfo` final_sig + `setCprSigInfo` final_cpr + `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] + -- in GHC.Core.Tidy + + | otherwise -- Externally-visible Ids get the whole lot + = vanillaIdInfo + `setArityInfo` arity + `setDmdSigInfo` final_sig + `setCprSigInfo` final_cpr + `setOccInfo` robust_occ_info + `setInlinePragInfo` inlinePragInfo idinfo + `setUnfoldingInfo` unfold_info + -- NB: we throw away the Rules + -- They have already been extracted by findExternalRules + where + is_external = isExternalName name + + --------- OccInfo ------------ + robust_occ_info = zapFragileOcc (occInfo idinfo) + -- It's important to keep loop-breaker information + -- when we are doing -fexpose-all-unfoldings + + --------- Strictness ------------ + mb_bot_str = exprBotStrictness_maybe orig_rhs + + sig = dmdSigInfo idinfo + final_sig | not (isNopSig sig) + = warnPprTrace (bottom_hidden sig) "tidyTopIdInfo" (ppr name <+> ppr sig) sig + + -- No demand signature, so try a + -- cheap-and-cheerful bottom analyser + | Just (_, bot_str_sig, _) <- mb_bot_str + = bot_str_sig + + -- No strictness info + | otherwise = nopSig + + cpr = cprSigInfo idinfo + final_cpr | Just (_, _, bot_cpr_sig) <- mb_bot_str + = bot_cpr_sig + | otherwise + = cpr + + bottom_hidden id_sig + = case mb_bot_str of + Nothing -> False + Just (arity, _, _) -> not (isDeadEndAppSig id_sig arity) + + --------- Unfolding ------------ + -- Force unfold_info (hence bangs), otherwise the old unfolding + -- is retained during code generation. See #22071 + + unf_info = realUnfoldingInfo idinfo + !minimal_unfold_info = trimUnfolding unf_info + + !unfold_info | isCompulsoryUnfolding unf_info || show_unfold + = tidyTopUnfolding rhs_tidy_env tidy_rhs unf_info + | otherwise + = minimal_unfold_info + -- NB: use `orig_rhs` not `tidy_rhs` in this call to mkFinalUnfolding + -- else you get a black hole (#22122). Reason: mkFinalUnfolding + -- looks at IdInfo, and that is knot-tied in tidyTopBind (the Rec case) + + --------- Arity ------------ + -- Usually the Id will have an accurate arity on it, because + -- the simplifier has just run, but not always. + -- One case I found was when the last thing the simplifier + -- did was to let-bind a non-atomic argument and then float + -- it to the top level. So it seems more robust just to + -- fix it here. + arity = exprArity orig_rhs `min` typeArity rhs_ty + -- orig_rhs: using tidy_rhs would make a black hole, since + -- exprArity uses the arities of Ids inside the rhs + -- + -- typeArity: see Note [Arity invariants for bindings] + -- in GHC.Core.Opt.Arity + +------------ Unfolding -------------- +tidyTopUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding +tidyTopUnfolding _ _ NoUnfolding = NoUnfolding +tidyTopUnfolding _ _ BootUnfolding = BootUnfolding +tidyTopUnfolding _ _ (OtherCon {}) = evaldUnfolding + +tidyTopUnfolding tidy_env _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args } + where + (tidy_env', bndrs') = tidyBndrs tidy_env bndrs + +tidyTopUnfolding tidy_env tidy_rhs + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + = -- See Note [tidyTopUnfolding: avoiding black holes] + unf { uf_tmpl = tidy_unf_rhs } + where + tidy_unf_rhs | isStableSource src + = tidyExpr tidy_env unf_rhs -- Preserves OccInfo in unf_rhs + | otherwise + = occurAnalyseExpr tidy_rhs -- Do occ-anal + +{- Note [tidyTopUnfolding: avoiding black holes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are exposing all unfoldings we don't want to tidy the unfolding +twice -- we just want to use the tidied RHS. That tidied RHS itself +contains fully-tidied Ids -- it is knot-tied. So the uf_tmpl for the +unfolding contains stuff we can't look at. Now consider (#22112) + foo = foo +If we freshly compute the uf_is_value field for foo's unfolding, +we'll call `exprIsValue`, which will look at foo's unfolding! +Whether or not the RHS is a value depends on whether foo is a value... +black hole. + +In the Simplifier we deal with this by not giving `foo` an unfolding +in its own RHS. And we could do that here. But it's qite nice +to common everything up to a single Id for foo, used everywhere. + +And it's not too hard: simply leave the unfolding undisturbed, except +tidy the uf_tmpl field. Hence tidyTopUnfolding does + unf { uf_tmpl = tidy_unf_rhs } + +Don't mess with uf_is_value, or guidance; in particular don't recompute +them from tidy_unf_rhs. + +And (unlike tidyNestedUnfolding) don't deep-seq the new unfolding, +because that'll cause a black hole (I /think/ because occurAnalyseExpr +looks in IdInfo). + + +************************************************************************ +* * + Old, dead, type-trimming code +* * +************************************************************************ + +We used to try to "trim off" the constructors of data types that are +not exported, to reduce the size of interface files, at least without +-O. But that is not always possible: see the old Note [When we can't +trim types] below for exceptions. + +Then (#7445) I realised that the TH problem arises for any data type +that we have deriving( Data ), because we can invoke + Language.Haskell.TH.Quote.dataToExpQ +to get a TH Exp representation of a value built from that data type. +You don't even need {-# LANGUAGE TemplateHaskell #-}. + +At this point I give up. The pain of trimming constructors just +doesn't seem worth the gain. So I've dumped all the code, and am just +leaving it here at the end of the module in case something like this +is ever resurrected. + + +Note [When we can't trim types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of type trimming is to export algebraic data types +abstractly (without their data constructors) when compiling without +-O, unless of course they are explicitly exported by the user. + +We always export synonyms, because they can be mentioned in the type +of an exported Id. We could do a full dependency analysis starting +from the explicit exports, but that's quite painful, and not done for +now. + +But there are some times we can't do that, indicated by the 'no_trim_types' flag. + +First, Template Haskell. Consider (#2386) this + module M(T, makeOne) where + data T = Yay String + makeOne = [| Yay "Yep" |] +Notice that T is exported abstractly, but makeOne effectively exports it too! +A module that splices in $(makeOne) will then look for a declaration of Yay, +so it'd better be there. Hence, brutally but simply, we switch off type +constructor trimming if TH is enabled in this module. + +Second, data kinds. Consider (#5912) + {-# LANGUAGE DataKinds #-} + module M() where + data UnaryTypeC a = UnaryDataC a + type Bug = 'UnaryDataC +We always export synonyms, so Bug is exposed, and that means that +UnaryTypeC must be too, even though it's not explicitly exported. In +effect, DataKinds means that we'd need to do a full dependency analysis +to see what data constructors are mentioned. But we don't do that yet. + +In these two cases we just switch off type trimming altogether. + +mustExposeTyCon :: Bool -- Type-trimming flag + -> NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as +-- possible into the interface file. But we must expose the details of +-- any data types whose constructors or fields are exported +mustExposeTyCon no_trim_types exports tc + | no_trim_types -- See Note [When we can't trim types] + = True + + | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to + -- figure out whether it was mentioned in the type + -- of any other exported thing) + = True + + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors + = True -- won't lead to the need for further exposure + + | isFamilyTyCon tc -- Open type family + = True + + -- Below here we just have data/newtype decls or family instances + + | null data_cons -- Ditto if there are no data constructors + = True -- (NB: empty data types do not count as enumerations + -- see Note [Enumeration types] in GHC.Core.TyCon + + | any exported_con data_cons -- Expose rep if any datacon or field is exported + = True + + | isNewTyCon tc && isFFITy (snd (newTyConRhs tc)) + = True -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + + | otherwise + = False + where + data_cons = tyConDataCons tc + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) +-} diff --git a/GHC/Iface/Tidy/StaticPtrTable.hs b/GHC/Iface/Tidy/StaticPtrTable.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Tidy/StaticPtrTable.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE ViewPatterns #-} + +-- | Code generation for the Static Pointer Table +-- +-- (c) 2014 I/O Tweag +-- +-- Each module that uses 'static' keyword declares an initialization function of +-- the form hs_spt_init_\() which is emitted into the _stub.c file and +-- annotated with __attribute__((constructor)) so that it gets executed at +-- startup time. +-- +-- The function's purpose is to call hs_spt_insert to insert the static +-- pointers of this module in the hashtable of the RTS, and it looks something +-- like this: +-- +-- > static void hs_hpc_init_Main(void) __attribute__((constructor)); +-- > static void hs_hpc_init_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > extern StgPtr Main_r2wb_closure; +-- > hs_spt_insert(k0, &Main_r2wb_closure); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > extern StgPtr Main_r2wc_closure; +-- > hs_spt_insert(k1, &Main_r2wc_closure); +-- > +-- > } +-- +-- where the constants are fingerprints produced from the static forms. +-- +-- The linker must find the definitions matching the @extern StgPtr @ +-- declarations. For this to work, the identifiers of static pointers need to be +-- exported. This is done in 'GHC.Core.Opt.SetLevels.newLvlVar'. +-- +-- There is also a finalization function for the time when the module is +-- unloaded. +-- +-- > static void hs_hpc_fini_Main(void) __attribute__((destructor)); +-- > static void hs_hpc_fini_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > hs_spt_remove(k0); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > hs_spt_remove(k1); +-- > +-- > } +-- + +module GHC.Iface.Tidy.StaticPtrTable + ( sptCreateStaticBinds + , sptModuleInitCode + , StaticPtrOpts (..) + ) +where + +{- Note [Grand plan for static forms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Static forms go through the compilation phases as follows. +Here is a running example: + + f x = let k = map toUpper + in ...(static k)... + +* The renamer looks for out-of-scope names in the body of the static + form, as always. If all names are in scope, the free variables of the + body are stored in AST at the location of the static form. + +* The typechecker verifies that all free variables occurring in the + static form are floatable to top level (see Note [Meaning of + IdBindingInfo] in GHC.Tc.Types). In our example, 'k' is floatable. + Even though it is bound in a nested let, we are fine. + + See the call to `checkClosedInStaticForm` in the HsStatic case of `tcExpr`. + +* The desugarer replaces the static form with an application of the + function 'makeStatic' (defined in module GHC.StaticPtr.Internal of + base). So we get + + f x = let k = map toUpper + in ...fromStaticPtr (makeStatic location k)... + +* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic' + to the top level. Thus the FloatOut pass is always executed, even when + optimizations are disabled. So we get + + k = map toUpper + static_ptr = makeStatic location k + f x = ...fromStaticPtr static_ptr... + + The FloatOut pass is careful to produce an /exported/ Id for a floated + 'makeStatic' call, so the binding is not removed or inlined by the + simplifier. + E.g. the code for `f` above might look like + + static_ptr = makeStatic location k + f x = ...(case static_ptr of ...)... + + which might be simplified to + + f x = ...(case makeStatic location k of ...)... + + BUT the top-level binding for static_ptr must remain, so that it can be + collected to populate the Static Pointer Table. + + Making the binding exported also has a necessary effect during the + CoreTidy pass. + +* The CoreTidy pass replaces all bindings of the form + + b = /\ ... -> makeStatic location value + + with + + b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value + + where a distinct key is generated for each binding. + +* If we are compiling to object code we insert a C stub (generated by + sptModuleInitCode) into the final object which runs when the module is loaded, + inserting the static forms defined by the module into the RTS's static pointer + table. + +* If we are compiling for the byte-code interpreter, we instead explicitly add + the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter + process' SPT table using the addSptEntry interpreter message. This happens + in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep'). +-} + +import GHC.Prelude +import GHC.Platform + +import GHC.Core +import GHC.Core.Utils (collectMakeStaticArgs) +import GHC.Core.DataCon +import GHC.Core.Make (mkStringExprFSWith,MkStringIds(..)) +import GHC.Core.Type + +import GHC.Cmm.CLabel + +import GHC.Unit.Module +import GHC.Utils.Outputable as Outputable + +import GHC.Linker.Types + +import GHC.Types.Id +import GHC.Types.ForeignStubs +import GHC.Data.Maybe +import GHC.Data.FastString + +import Control.Monad.Trans.State.Strict +import Data.List (intercalate) +import GHC.Fingerprint + +data StaticPtrOpts = StaticPtrOpts + { opt_platform :: !Platform -- ^ Target platform + , opt_gen_cstub :: !Bool -- ^ Generate CStub or not + , opt_mk_string :: !MkStringIds -- ^ Ids for `unpackCString[Utf8]#` + , opt_static_ptr_info_datacon :: !DataCon -- ^ `StaticPtrInfo` datacon + , opt_static_ptr_datacon :: !DataCon -- ^ `StaticPtr` datacon + } + +-- | Replaces all bindings of the form +-- +-- > b = /\ ... -> makeStatic location value +-- +-- with +-- +-- > b = /\ ... -> +-- > StaticPtr key (StaticPtrInfo "pkg key" "module" location) value +-- +-- where a distinct key is generated for each binding. +-- +-- It also yields the C stub that inserts these bindings into the static +-- pointer table. +sptCreateStaticBinds :: StaticPtrOpts -> Module -> CoreProgram -> IO ([SptEntry], Maybe CStub, CoreProgram) +sptCreateStaticBinds opts this_mod binds = do + (fps, binds') <- evalStateT (go [] [] binds) 0 + let cstub + | opt_gen_cstub opts = Just (sptModuleInitCode (opt_platform opts) this_mod fps) + | otherwise = Nothing + return (fps, cstub, binds') + where + go fps bs xs = case xs of + [] -> return (reverse fps, reverse bs) + bnd : xs' -> do + (fps', bnd') <- replaceStaticBind bnd + go (reverse fps' ++ fps) (bnd' : bs) xs' + + -- Generates keys and replaces 'makeStatic' with 'StaticPtr'. + -- + -- The 'Int' state is used to produce a different key for each binding. + replaceStaticBind :: CoreBind + -> StateT Int IO ([SptEntry], CoreBind) + replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e + return (maybeToList mfp, NonRec b' e') + replaceStaticBind (Rec rbs) = do + (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs + return (catMaybes mfps, Rec rbs') + + replaceStatic :: Id -> CoreExpr + -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr)) + replaceStatic b e@(collectTyBinders -> (tvs, e0)) = + case collectMakeStaticArgs e0 of + Nothing -> return (Nothing, (b, e)) + Just (_, t, info, arg) -> do + (fp, e') <- mkStaticBind t info arg + return (Just (SptEntry b fp), (b, foldr Lam e' tvs)) + + mkStaticBind :: Type -> CoreExpr -> CoreExpr + -> StateT Int IO (Fingerprint, CoreExpr) + mkStaticBind t srcLoc e = do + i <- get + put (i + 1) + let staticPtrInfoDataCon = opt_static_ptr_info_datacon opts + let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i + let mk_string_fs = mkStringExprFSWith (opt_mk_string opts) + let info = mkConApp staticPtrInfoDataCon + [ mk_string_fs $ unitFS $ moduleUnit this_mod + , mk_string_fs $ moduleNameFS $ moduleName this_mod + , srcLoc + ] + + let staticPtrDataCon = opt_static_ptr_datacon opts + return (fp, mkConApp staticPtrDataCon + [ Type t + , mkWord64LitWord64 w0 + , mkWord64LitWord64 w1 + , info + , e ]) + + mkStaticPtrFingerprint :: Int -> Fingerprint + mkStaticPtrFingerprint n = fingerprintString $ intercalate ":" + [ unitString $ moduleUnit this_mod + , moduleNameString $ moduleName this_mod + , show n + ] + +-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries +-- of @module@ into the static pointer table. +-- +-- @fps@ is a list associating each binding corresponding to a static entry with +-- its fingerprint. +sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub +sptModuleInitCode platform this_mod entries + -- no CStub if there is no entry + | [] <- entries = mempty + -- no CStub for the JS backend: it deals with it directly during JS code + -- generation + | ArchJavaScript <- platformArch platform = mempty + | otherwise = + initializerCStub platform init_fn_nm empty init_fn_body `mappend` + finalizerCStub platform fini_fn_nm empty fini_fn_body + where + init_fn_nm = mkInitializerStubLabel this_mod (fsLit "spt") + init_fn_body = vcat + [ text "static StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "extern StgPtr " + <> (pprCLabel platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi + $$ text "hs_spt_insert" <> parens + (hcat $ punctuate comma + [ char 'k' <> int i + , char '&' <> pprCLabel platform (mkClosureLabel (idName n) (idCafInfo n)) + ] + ) + <> semi + | (i, SptEntry n fp) <- zip [0..] entries + ] + + fini_fn_nm = mkFinalizerStubLabel this_mod (fsLit "spt") + fini_fn_body = vcat + [ text "StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi + | (i, (SptEntry _ fp)) <- zip [0..] entries + ] + + pprFingerprint :: Fingerprint -> SDoc + pprFingerprint (Fingerprint w1 w2) = + braces $ hcat $ punctuate comma + [ integer (fromIntegral w1) <> text "ULL" + , integer (fromIntegral w2) <> text "ULL" + ] diff --git a/GHC/Iface/Type.hs b/GHC/Iface/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Type.hs @@ -0,0 +1,2667 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +This module defines interface types and binders +-} + + +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +module GHC.Iface.Type ( + IfExtName, + IfLclName(..), mkIfLclName, ifLclNameFS, + + IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), + IfaceAxiomRule(..),IfaceMCoercion(..), + IfaceMult, + IfaceTyCon(..), + IfaceTyConInfo(..), mkIfaceTyConInfo, + IfaceTyConSort(..), + IfaceTyLit(..), IfaceAppArgs(..), + IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, + IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, + IfaceForAllSpecBndr, + IfaceForAllBndr, ForAllTyFlag(..), FunTyFlag(..), ShowForAllFlag(..), + ShowSub(..), ShowHowMuch(..), AltPpr(..), + mkIfaceForAllTvBndr, + mkIfaceTyConKind, + ifaceForAllSpecToBndrs, ifaceForAllSpecToBndr, + + ifForAllBndrVar, ifForAllBndrName, ifaceBndrName, + ifTyConBinderVar, ifTyConBinderName, + + -- Binary utilities + putIfaceType, getIfaceType, ifaceTypeSharedByte, + -- Equality testing + isIfaceLiftedTypeKind, + + -- Conversion from IfaceAppArgs to IfaceTypes/ForAllTyFlags + appArgsIfaceTypes, appArgsIfaceTypesForAllTyFlags, + + -- Printing + SuppressBndrSig(..), + UseBndrParens(..), + PrintExplicitKinds(..), + PrintArityInvisibles(..), + pprIfaceType, pprParendIfaceType, pprPrecIfaceType, + pprIfaceContext, pprIfaceContextArr, + pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, + pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs, + pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll, + pprIfaceSigmaType, pprIfaceTyLit, + pprIfaceCoercion, pprParendIfaceCoercion, + splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, + pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, + isIfaceRhoType, + + suppressIfaceInvisibles, + visibleTypeVarOccurencies, + stripIfaceInvisVars, + stripInvisArgs, + + mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst, + + many_ty, pprTypeArrow + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Builtin.Types + ( coercibleTyCon, heqTyCon + , constraintKindTyConName + , tupleTyConName + , tupleDataConName + , manyDataConTyCon + , liftedRepTyCon, liftedDataConTyCon + , sumTyCon ) +import GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy, funTyFlagTyCon ) +import GHC.Core.TyCo.Rep( CoSel, UnivCoProvenance(..) ) +import GHC.Core.TyCo.Compare( eqForAllVis ) +import GHC.Core.TyCon hiding ( pprPromotionQuote ) +import GHC.Core.Coercion.Axiom +import GHC.Types.Var +import GHC.Builtin.Names +import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyConName ) +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Utils.Binary +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Utils.Panic +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar ) + +import Data.Maybe (isJust) +import Data.Proxy +import qualified Data.Semigroup as Semi +import Data.Word (Word8) +import Control.Arrow (first) +import Control.DeepSeq +import Control.Monad ((<$!>)) +import Data.List (dropWhileEnd) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set + +{- +************************************************************************ +* * + Local (nested) binders +* * +************************************************************************ +-} + +-- | A local name in iface syntax +newtype IfLclName = IfLclName + { getIfLclName :: LexicalFastString + } deriving (Eq, Ord, Show) + +ifLclNameFS :: IfLclName -> FastString +ifLclNameFS = getLexicalFastString . getIfLclName + +mkIfLclName :: FastString -> IfLclName +mkIfLclName = IfLclName . LexicalFastString + +type IfExtName = Name -- An External or WiredIn Name can appear in Iface syntax + -- (However Internal or System Names never should) + +data IfaceBndr -- Local (non-top-level) binders + = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr + | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr + deriving (Eq, Ord) + + +type IfaceIdBndr = (IfaceType, IfLclName, IfaceType) +type IfaceTvBndr = (IfLclName, IfaceKind) + +ifaceTvBndrName :: IfaceTvBndr -> IfLclName +ifaceTvBndrName (n,_) = n + +ifaceIdBndrName :: IfaceIdBndr -> IfLclName +ifaceIdBndrName (_,n,_) = n + +ifaceBndrName :: IfaceBndr -> IfLclName +ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr +ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr + +ifaceBndrType :: IfaceBndr -> IfaceType +ifaceBndrType (IfaceIdBndr (_, _, t)) = t +ifaceBndrType (IfaceTvBndr (_, t)) = t + +type IfaceLamBndr = (IfaceBndr, IfaceOneShot) + +data IfaceOneShot -- See Note [Preserve OneShotInfo] in "GHC.Core.Tidy" + = IfaceNoOneShot -- and Note [oneShot magic] in "GHC.Types.Id.Make" + | IfaceOneShot + +instance Outputable IfaceOneShot where + ppr IfaceNoOneShot = text "NoOneShotInfo" + ppr IfaceOneShot = text "OneShot" + +{- +%************************************************************************ +%* * + IfaceType +%* * +%************************************************************************ +-} + +------------------------------- +type IfaceKind = IfaceType + +-- | A kind of universal type, used for types and kinds. +-- +-- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType' +-- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr" +data IfaceType + = IfaceFreeTyVar TyVar -- See Note [Free TyVars and CoVars in IfaceType] + | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon + | IfaceLitTy IfaceTyLit + | IfaceAppTy IfaceType IfaceAppArgs + -- See Note [Suppressing invisible arguments] for + -- an explanation of why the second field isn't + -- IfaceType, analogous to AppTy. + | IfaceFunTy FunTyFlag IfaceMult IfaceType IfaceType + | IfaceForAllTy IfaceForAllBndr IfaceType + | IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated + -- Includes newtypes, synonyms, tuples + | IfaceCastTy IfaceType IfaceCoercion + | IfaceCoercionTy IfaceCoercion + + | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp) + TupleSort -- What sort of tuple? + PromotionFlag -- A bit like IfaceTyCon + IfaceAppArgs -- arity = length args + -- For promoted data cons, the kind args are omitted + -- Why have this? Only for efficiency: IfaceTupleTy can omit the + -- type arguments, as they can be recreated when deserializing. + -- In an experiment, removing IfaceTupleTy resulted in a 0.75% regression + -- in interface file size (in GHC's boot libraries). + -- See !3987. + deriving (Eq, Ord) + -- See Note [Ord instance of IfaceType] + +{- +Note [Ord instance of IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need an 'Ord' instance to have a 'Map' keyed by 'IfaceType'. This 'Map' is +required for implementing the deduplication table during interface file +serialisation. +See Note [Deduplication during iface binary serialisation] for the implementation details. + +We experimented with a 'TrieMap' based implementation, but it seems to be +slower than using a straight-forward 'Map IfaceType'. +The experiments loaded the full agda library into a ghci session with the +following scenarios: + +* normal: a plain ghci session. +* cold: a ghci session that uses '-fwrite-if-simplified-core -fforce-recomp', + forcing a cold-cache. +* warm: a subsequent ghci session that uses a warm cache for + '-fwrite-if-simplified-core', e.g. nothing needs to be recompiled. + +The implementation was up to 5% slower in some execution runs. However, on +'lib:Cabal', the performance difference between 'Map IfaceType' and +'TrieMap IfaceType' was negligible. + +We share our implementation of the 'TrieMap' in the ticket #24816, so that +further performance analysis and improvements don't need to start from scratch. +-} + +type IfaceMult = IfaceType + +type IfacePredType = IfaceType +type IfaceContext = [IfacePredType] + +data IfaceTyLit + = IfaceNumTyLit Integer + | IfaceStrTyLit LexicalFastString + | IfaceCharTyLit Char + deriving (Eq, Ord) + +type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +type IfaceForAllBndr = VarBndr IfaceBndr ForAllTyFlag +type IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity + +-- | Make an 'IfaceForAllBndr' from an 'IfaceTvBndr'. +mkIfaceForAllTvBndr :: ForAllTyFlag -> IfaceTvBndr -> IfaceForAllBndr +mkIfaceForAllTvBndr vis var = Bndr (IfaceTvBndr var) vis + +-- | Build the 'tyConKind' from the binders and the result kind. +-- Keep in sync with 'mkTyConKind' in "GHC.Core.TyCon". +mkIfaceTyConKind :: [IfaceTyConBinder] -> IfaceKind -> IfaceKind +mkIfaceTyConKind bndrs res_kind = foldr mk res_kind bndrs + where + mk :: IfaceTyConBinder -> IfaceKind -> IfaceKind + mk (Bndr tv AnonTCB) k = IfaceFunTy FTF_T_T many_ty (ifaceBndrType tv) k + mk (Bndr tv (NamedTCB vis)) k = IfaceForAllTy (Bndr tv vis) k + +ifaceForAllSpecToBndrs :: [IfaceForAllSpecBndr] -> [IfaceForAllBndr] +ifaceForAllSpecToBndrs = map ifaceForAllSpecToBndr + +ifaceForAllSpecToBndr :: IfaceForAllSpecBndr -> IfaceForAllBndr +ifaceForAllSpecToBndr (Bndr tv spec) = Bndr tv (Invisible spec) + +-- | Stores the arguments in a type application as a list. +-- See @Note [Suppressing invisible arguments]@. +data IfaceAppArgs + = IA_Nil + | IA_Arg IfaceType -- The type argument + + ForAllTyFlag -- The argument's visibility. We store this here so + -- that we can: + -- + -- 1. Avoid pretty-printing invisible (i.e., specified + -- or inferred) arguments when + -- -fprint-explicit-kinds isn't enabled, or + -- 2. When -fprint-explicit-kinds *is*, enabled, print + -- specified arguments in @(...) and inferred + -- arguments in @{...}. + + IfaceAppArgs -- The rest of the arguments + deriving (Eq, Ord) + +instance Semi.Semigroup IfaceAppArgs where + IA_Nil <> xs = xs + IA_Arg ty argf rest <> xs = IA_Arg ty argf (rest Semi.<> xs) + +instance Monoid IfaceAppArgs where + mempty = IA_Nil + mappend = (Semi.<>) + +-- Encodes type constructors, kind constructors, +-- coercion constructors, the lot. +-- We have to tag them in order to pretty print them +-- properly. +data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName + , ifaceTyConInfo :: !IfaceTyConInfo + -- ^ We add a bang to this field as heap analysis + -- showed that this constructor retains a thunk to + -- a value that is usually shared. + -- + -- See !12200 for how this bang saved ~10% residency + -- when loading 'mi_extra_decls' on the agda + -- code base. + -- + -- See Note [Sharing IfaceTyConInfo] for why + -- sharing is so important for 'IfaceTyConInfo'. + } + deriving (Eq, Ord) + +-- | The various types of TyCons which have special, built-in syntax. +data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon + + | IfaceTupleTyCon !Arity !TupleSort + -- ^ a tuple, e.g. @(a, b, c)@ or @(#a, b, c#)@. + -- The arity is the tuple width, not the tycon arity + -- (which is twice the width in the case of unboxed + -- tuples). + + | IfaceSumTyCon !Arity + -- ^ an unboxed sum, e.g. @(# a | b | c #)@ + + | IfaceEqualityTyCon + -- ^ A heterogeneous equality TyCon + -- (i.e. eqPrimTyCon, eqReprPrimTyCon, heqTyCon) + -- that is actually being applied to two types + -- of the same kind. This affects pretty-printing + -- only: see Note [Equality predicates in IfaceType] + deriving (Eq, Ord) + +instance Outputable IfaceTyConSort where + ppr IfaceNormalTyCon = text "normal" + ppr (IfaceTupleTyCon n sort) = ppr sort <> colon <> ppr n + ppr (IfaceSumTyCon n) = text "sum:" <> ppr n + ppr IfaceEqualityTyCon = text "equality" + +{- Note [Free TyVars and CoVars in IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to +an IfaceType and pretty printing that. This eliminates a lot of +pretty-print duplication, and it matches what we do with pretty- +printing TyThings. See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr. + +It works fine for closed types, but when printing debug traces (e.g. +when using -ddump-tc-trace) we print a lot of /open/ types. These +types are full of TcTyVars, and it's absolutely crucial to print them +in their full glory, with their unique, TcTyVarDetails etc. + +So we simply embed a TyVar in IfaceType with the IfaceFreeTyVar constructor. +Note that: + +* We never expect to serialise an IfaceFreeTyVar into an interface file, nor + to deserialise one. IfaceFreeTyVar is used only in the "convert to IfaceType + and then pretty-print" pipeline. + +We do the same for covars, naturally. + +Note [Equality predicates in IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has several varieties of type equality (see Note [The equality types story] +in GHC.Builtin.Types.Prim for details). In an effort to avoid confusing users, we suppress +the differences during pretty printing unless certain flags are enabled. +Here is how each equality predicate* is printed in homogeneous and +heterogeneous contexts, depending on which combination of the +-fprint-explicit-kinds and -fprint-equality-relations flags is used: + +-------------------------------------------------------------------------------------------- +| Predicate | Neither flag | -fprint-explicit-kinds | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~# b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | Coercible a b | Coercible @Type a b | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +|-------------------------------|----------------------------|-----------------------------| +| Predicate | -fprint-equality-relations | Both flags | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~~ b | (a :: Type) ~~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~# b | (a :: Type) ~# (b :: Type) | +| a ~# b, heterogeneously | a ~# c | (a :: Type) ~# (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | a ~R# b | (a :: Type) ~R# (b :: Type) | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +-------------------------------------------------------------------------------------------- + +(* There is no heterogeneous, representational, lifted equality counterpart +to (~~). There could be, but there seems to be no use for it.) + +This table adheres to the following rules: + +A. With -fprint-equality-relations, print the true equality relation. +B. Without -fprint-equality-relations: + i. If the equality is representational and homogeneous, use Coercible. + ii. Otherwise, if the equality is representational, use ~R#. + iii. If the equality is nominal and homogeneous, use ~. + iv. Otherwise, if the equality is nominal, use ~~. +C. With -fprint-explicit-kinds, print kinds on both sides of an infix operator, + as above; or print the kind with Coercible. +D. Without -fprint-explicit-kinds, don't print kinds. + +A hetero-kinded equality is used homogeneously when it is applied to two +identical kinds. Unfortunately, determining this from an IfaceType isn't +possible since we can't see through type synonyms. Consequently, we need to +record whether this particular application is homogeneous in IfaceTyConSort +for the purposes of pretty-printing. + +See Note [The equality types story] in GHC.Builtin.Types.Prim. +-} + +data IfaceTyConInfo -- Used only to guide pretty-printing + = IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag + -- A PromotionFlag value of IsPromoted indicates + -- that the type constructor came from a data + -- constructor promoted by -XDataKinds, and thus + -- should be printed as 'D to distinguish it from + -- an existing type constructor D. + , ifaceTyConSort :: IfaceTyConSort } + deriving (Eq, Ord) + +-- | This smart constructor allows sharing of the two most common +-- cases. See Note [Sharing IfaceTyConInfo] +mkIfaceTyConInfo :: PromotionFlag -> IfaceTyConSort -> IfaceTyConInfo +mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = promotedNormalTyConInfo +mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo +mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort + +{-# NOINLINE promotedNormalTyConInfo #-} +-- | See Note [Sharing IfaceTyConInfo] +promotedNormalTyConInfo :: IfaceTyConInfo +promotedNormalTyConInfo = IfaceTyConInfo IsPromoted IfaceNormalTyCon + +{-# NOINLINE notPromotedNormalTyConInfo #-} +-- | See Note [Sharing IfaceTyConInfo] +notPromotedNormalTyConInfo :: IfaceTyConInfo +notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon + +{- +Note [Sharing IfaceTyConInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'IfaceTyConInfo' occurs an awful lot in 'ModIface', see #19194 for an example. +But almost all of them are + + IfaceTyConInfo IsPromoted IfaceNormalTyCon + IfaceTyConInfo NotPromoted IfaceNormalTyCon. + +The smart constructor `mkIfaceTyConInfo` arranges to share these instances, +thus: + + promotedNormalTyConInfo = IfaceTyConInfo IsPromoted IfaceNormalTyCon + notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon + + mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = promotedNormalTyConInfo + mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo + mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort + +But ALAS, the (nested) CPR transform can lose this sharing, completely +negating the effect of `mkIfaceTyConInfo`: see #24530 and #19326. + +Sticking-plaster solution: add a NOINLINE pragma to those top-level constants. +When we fix the CPR bug we can remove the NOINLINE pragmas. + +This one change leads to an 15% reduction in residency for GHC when embedding +'mi_extra_decls': see !12222. +-} + +data IfaceMCoercion + = IfaceMRefl + | IfaceMCo IfaceCoercion deriving (Eq, Ord) + +data IfaceCoercion + = IfaceReflCo IfaceType + | IfaceGReflCo Role IfaceType (IfaceMCoercion) + | IfaceFunCo Role IfaceCoercion IfaceCoercion IfaceCoercion + | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] + | IfaceAppCo IfaceCoercion IfaceCoercion + | IfaceForAllCo IfaceBndr !ForAllTyFlag !ForAllTyFlag IfaceCoercion IfaceCoercion + | IfaceCoVarCo IfLclName + | IfaceAxiomCo IfaceAxiomRule [IfaceCoercion] + -- ^ There are only a fixed number of CoAxiomRules, so it suffices + -- to use an IfaceLclName to distinguish them. + -- See Note [Adding built-in type families] in GHC.Builtin.Types.Literals + | IfaceUnivCo UnivCoProvenance Role IfaceType IfaceType [IfaceCoercion] + | IfaceSymCo IfaceCoercion + | IfaceTransCo IfaceCoercion IfaceCoercion + | IfaceSelCo CoSel IfaceCoercion + | IfaceLRCo LeftOrRight IfaceCoercion + | IfaceInstCo IfaceCoercion IfaceCoercion + | IfaceKindCo IfaceCoercion + | IfaceSubCo IfaceCoercion + | IfaceFreeCoVar CoVar -- ^ See Note [Free TyVars and CoVars in IfaceType] + | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] + deriving (Eq, Ord) + -- Why Ord? See Note [Ord instance of IfaceType] + +data IfaceAxiomRule + = IfaceAR_X IfLclName -- Built-in + | IfaceAR_B IfExtName BranchIndex -- Branched + | IfaceAR_U IfExtName -- Unbranched + deriving (Eq, Ord) + +{- Note [Holes in IfaceCoercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking fails the typechecker will produce a HoleCo to stand +in place of the unproven assertion. While we generally don't want to +let these unproven assertions leak into interface files, we still need +to be able to pretty-print them as we use IfaceType's pretty-printer +to render Types. For this reason IfaceCoercion has a IfaceHoleCo +constructor; however, we fails when asked to serialize to a +IfaceHoleCo to ensure that they don't end up in an interface file. + + +%************************************************************************ +%* * + Functions over IfaceTypes +* * +************************************************************************ +-} + +ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool +ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key + +-- | Returns true for Type or (TYPE LiftedRep) +isIfaceLiftedTypeKind :: IfaceKind -> Bool +isIfaceLiftedTypeKind (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + , IA_Nil <- args + = True -- Type + + | tc `ifaceTyConHasKey` tYPETyConKey + , IA_Arg arg1 Required IA_Nil <- args + , isIfaceLiftedRep arg1 + = True -- TYPE Lifted + +isIfaceLiftedTypeKind _ = False + +-- | Returns true for Constraint or (CONSTRAINT LiftedRep) +isIfaceConstraintKind :: IfaceKind -> Bool +isIfaceConstraintKind (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` constraintKindTyConKey + , IA_Nil <- args + = True -- Type + + | tc `ifaceTyConHasKey` cONSTRAINTTyConKey + , IA_Arg arg1 Required IA_Nil <- args + , isIfaceLiftedRep arg1 + = True -- TYPE Lifted + +isIfaceConstraintKind _ = False + +isIfaceLiftedRep :: IfaceKind -> Bool +-- Returns true for LiftedRep, or BoxedRep Lifted +isIfaceLiftedRep (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` liftedRepTyConKey + , IA_Nil <- args + = True -- LiftedRep + + | tc `ifaceTyConHasKey` boxedRepDataConKey + , IA_Arg arg1 Required IA_Nil <- args + , isIfaceLifted arg1 + = True -- TYPE Lifted + +isIfaceLiftedRep _ = False + +isIfaceLifted :: IfaceKind -> Bool +-- Returns true for Lifted +isIfaceLifted (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` liftedDataConKey + , IA_Nil <- args + = True +isIfaceLifted _ = False + +splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) +-- Mainly for printing purposes +-- +-- Here we split nested IfaceSigmaTy properly. +-- +-- @ +-- forall t. T t => forall m a b. M m => (a -> m b) -> t a -> m (t b) +-- @ +-- +-- If you called @splitIfaceSigmaTy@ on this type: +-- +-- @ +-- ([t, m, a, b], [T t, M m], (a -> m b) -> t a -> m (t b)) +-- @ +splitIfaceSigmaTy ty + = case (bndrs, theta) of + ([], []) -> (bndrs, theta, tau) + _ -> let (bndrs', theta', tau') = splitIfaceSigmaTy tau + in (bndrs ++ bndrs', theta ++ theta', tau') + where + (bndrs, rho) = split_foralls ty + (theta, tau) = split_rho rho + + split_foralls (IfaceForAllTy bndr ty) + | isInvisibleForAllTyFlag (binderFlag bndr) + = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } + split_foralls rho = ([], rho) + + split_rho (IfaceFunTy af _ ty1 ty2) + | isInvisibleFunArg af + = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } + split_rho tau = ([], tau) + +splitIfaceReqForallTy :: IfaceType -> ([IfaceForAllBndr], IfaceType) +splitIfaceReqForallTy (IfaceForAllTy bndr ty) + | isVisibleForAllTyFlag (binderFlag bndr) + = case splitIfaceReqForallTy ty of { (bndrs, rho) -> (bndr:bndrs, rho) } +splitIfaceReqForallTy rho = ([], rho) + +newtype PrintArityInvisibles = MkPrintArityInvisibles Bool + +-- See Note [Print invisible binders in interface declarations] +-- for the definition of what binders are considered insignificant +suppressIfaceInvisibles :: PrintArityInvisibles + -> PrintExplicitKinds + -> Set.Set IfLclName + -> [IfaceTyConBinder] + -> [a] + -> [a] +suppressIfaceInvisibles _ (PrintExplicitKinds True) _ _tys xs = xs + +suppressIfaceInvisibles -- This case is semantically the same as the third case, but it should be way f + (MkPrintArityInvisibles False) (PrintExplicitKinds False) mentioned_vars tys xs + | Set.null mentioned_vars = suppress tys xs + where + suppress _ [] = [] + suppress [] a = a + suppress (k:ks) (x:xs) + | isInvisibleTyConBinder k = suppress ks xs + | otherwise = x : suppress ks xs + +suppressIfaceInvisibles + (MkPrintArityInvisibles arity_invisibles) + (PrintExplicitKinds False) mentioned_vars tys xs + = map snd (suppress (zip tys xs)) + where + -- Consider this example: + -- type T :: forall k1 k2. Type + -- type T @a @b = b + -- `@a` is not mentioned on the RHS. However, we can't just + -- drop it because implicit argument positioning matters. + -- + -- Hence just drop the end + only_mentioned_binders = dropWhileEnd (not . is_binder_mentioned) + + is_binder_mentioned (bndr, _) = ifTyConBinderName bndr `Set.member` mentioned_vars + + suppress_invisibles group = + applyWhen invis_group only_mentioned_binders bndrs + where + bndrs = NonEmpty.toList group + invis_group = is_invisible_bndr (NonEmpty.head group) + + suppress_invisible_groups [] = [] + suppress_invisible_groups [group] = + if arity_invisibles + then NonEmpty.toList group -- the last group affects arity + else suppress_invisibles group + suppress_invisible_groups (group : groups) + = suppress_invisibles group ++ suppress_invisible_groups groups + + suppress + = suppress_invisible_groups -- Filter out insignificant invisible binders + . NonEmpty.groupWith is_invisible_bndr -- Find chunks of @-binders + . filterOut is_inferred_bndr -- We don't want to display @{binders} + + is_inferred_bndr = isInferredTyConBinder . fst + is_invisible_bndr = isInvisibleTyConBinder . fst + +stripIfaceInvisVars :: PrintExplicitKinds -> [IfaceTyConBinder] -> [IfaceTyConBinder] +stripIfaceInvisVars (PrintExplicitKinds True) tyvars = tyvars +stripIfaceInvisVars (PrintExplicitKinds False) tyvars + = filterOut isInvisibleTyConBinder tyvars + +-- | Extract an 'IfaceBndr' from an 'IfaceForAllBndr'. +ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr +ifForAllBndrVar = binderVar + +-- | Extract the variable name from an 'IfaceForAllBndr'. +ifForAllBndrName :: IfaceForAllBndr -> IfLclName +ifForAllBndrName fab = ifaceBndrName (ifForAllBndrVar fab) + +-- | Extract an 'IfaceBndr' from an 'IfaceTyConBinder'. +ifTyConBinderVar :: IfaceTyConBinder -> IfaceBndr +ifTyConBinderVar = binderVar + +-- | Extract the variable name from an 'IfaceTyConBinder'. +ifTyConBinderName :: IfaceTyConBinder -> IfLclName +ifTyConBinderName tcb = ifaceBndrName (ifTyConBinderVar tcb) + +ifTypeIsVarFree :: IfaceType -> Bool +-- Returns True if the type definitely has no variables at all +-- Just used to control pretty printing +ifTypeIsVarFree ty = go ty + where + go (IfaceTyVar {}) = False + go (IfaceFreeTyVar {}) = False + go (IfaceAppTy fun args) = go fun && go_args args + go (IfaceFunTy _ w arg res) = go w && go arg && go res + go (IfaceForAllTy {}) = False + go (IfaceTyConApp _ args) = go_args args + go (IfaceTupleTy _ _ args) = go_args args + go (IfaceLitTy _) = True + go (IfaceCastTy {}) = False -- Safe + go (IfaceCoercionTy {}) = False -- Safe + + go_args IA_Nil = True + go_args (IA_Arg arg _ args) = go arg && go_args args + +visibleTypeVarOccurencies :: IfaceType -> Set.Set IfLclName +-- Returns True if the type contains this name. Doesn't count +-- invisible application +-- Just used to control pretty printing +visibleTypeVarOccurencies = go + where + (<>) = Set.union + + go (IfaceTyVar var) = Set.singleton var + go (IfaceFreeTyVar {}) = mempty + go (IfaceAppTy fun args) = go fun <> go_args args + go (IfaceFunTy _ w arg res) = go w <> go arg <> go res + go (IfaceForAllTy bndr ty) = go (ifaceBndrType $ binderVar bndr) <> go ty + go (IfaceTyConApp _ args) = go_args args + go (IfaceTupleTy _ _ args) = go_args args + go (IfaceLitTy _) = mempty + go (IfaceCastTy {}) = mempty -- Safe + go (IfaceCoercionTy {}) = mempty -- Safe + + go_args IA_Nil = mempty + go_args (IA_Arg arg Required args) = go arg <> go_args args + go_args (IA_Arg _arg _ args) = go_args args + +{- Note [Substitution on IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Substitutions on IfaceType are done only during pretty-printing to +construct the result type of a GADT, and does not deal with binders +(eg IfaceForAll), so it doesn't need fancy capture stuff. -} + +type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType] + +mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst +-- See Note [Substitution on IfaceType] +mkIfaceTySubst eq_spec = mkFsEnv (map (first ifLclNameFS) eq_spec) + +inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool +-- See Note [Substitution on IfaceType] +inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst (ifLclNameFS fs)) + +substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType +-- See Note [Substitution on IfaceType] +substIfaceType env ty + = go ty + where + go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv + go (IfaceTyVar tv) = substIfaceTyVar env tv + go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts) + go (IfaceFunTy af w t1 t2) = IfaceFunTy af (go w) (go t1) (go t2) + go ty@(IfaceLitTy {}) = ty + go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys) + go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys) + go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) + go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co) + go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co) + + go_mco IfaceMRefl = IfaceMRefl + go_mco (IfaceMCo co) = IfaceMCo $ go_co co + + go_co (IfaceReflCo ty) = IfaceReflCo (go ty) + go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco) + go_co (IfaceFunCo r w c1 c2) = IfaceFunCo r (go_co w) (go_co c1) (go_co c2) + go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) + go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) + go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) + go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv + go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv + go_co (IfaceHoleCo cv) = IfaceHoleCo cv + go_co (IfaceUnivCo p r t1 t2 ds) = IfaceUnivCo p r (go t1) (go t2) (go_cos ds) + go_co (IfaceSymCo co) = IfaceSymCo (go_co co) + go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) + go_co (IfaceSelCo n co) = IfaceSelCo n (go_co co) + go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co) + go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) + go_co (IfaceKindCo co) = IfaceKindCo (go_co co) + go_co (IfaceSubCo co) = IfaceSubCo (go_co co) + go_co (IfaceAxiomCo n cos) = IfaceAxiomCo n (go_cos cos) + + go_cos = map go_co + +substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs +substIfaceAppArgs env args + = go args + where + go IA_Nil = IA_Nil + go (IA_Arg ty arg tys) = IA_Arg (substIfaceType env ty) arg (go tys) + +substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType +substIfaceTyVar env tv + | Just ty <- lookupFsEnv env (ifLclNameFS tv) = ty + | otherwise = IfaceTyVar tv + + +{- +************************************************************************ +* * + Functions over IfaceAppArgs +* * +************************************************************************ +-} + +stripInvisArgs :: PrintExplicitKinds -> IfaceAppArgs -> IfaceAppArgs +stripInvisArgs (PrintExplicitKinds True) tys = tys +stripInvisArgs (PrintExplicitKinds False) tys = suppress_invis tys + where + suppress_invis c + = case c of + IA_Nil -> IA_Nil + IA_Arg t argf ts + | isVisibleForAllTyFlag argf + -> IA_Arg t argf $ suppress_invis ts + -- Keep recursing through the remainder of the arguments, as it's + -- possible that there are remaining invisible ones. + -- See the "In type declarations" section of Note [VarBndrs, + -- ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. + | otherwise + -> suppress_invis ts + +appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType] +appArgsIfaceTypes IA_Nil = [] +appArgsIfaceTypes (IA_Arg t _ ts) = t : appArgsIfaceTypes ts + +appArgsIfaceTypesForAllTyFlags :: IfaceAppArgs -> [(IfaceType, ForAllTyFlag)] +appArgsIfaceTypesForAllTyFlags IA_Nil = [] +appArgsIfaceTypesForAllTyFlags (IA_Arg t a ts) + = (t, a) : appArgsIfaceTypesForAllTyFlags ts + +ifaceVisAppArgsLength :: IfaceAppArgs -> Int +ifaceVisAppArgsLength = go 0 + where + go !n IA_Nil = n + go n (IA_Arg _ argf rest) + | isVisibleForAllTyFlag argf = go (n+1) rest + | otherwise = go n rest + +ifaceAppArgsLength :: IfaceAppArgs -> Int +ifaceAppArgsLength = go 0 + where + go !n IA_Nil = n + go !n (IA_Arg _ _ ts) = go (n + 1) ts + +{- +Note [Suppressing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use the IfaceAppArgs data type to specify which of the arguments to a type +should be displayed when pretty-printing, under the control of +-fprint-explicit-kinds. +See also Type.filterOutInvisibleTypes. +For example, given + + T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism + 'Just :: forall k. k -> 'Maybe k -- Promoted + +we want + + T * Tree Int prints as T Tree Int + 'Just * prints as Just * + +For type constructors (IfaceTyConApp), IfaceAppArgs is a quite natural fit, +since the corresponding Core constructor: + + data Type + = ... + | TyConApp TyCon [Type] + +Already puts all of its arguments into a list. So when converting a Type to an +IfaceType (see toIfaceAppArgsX in GHC.Core.ToIface), we simply use the kind of +the TyCon (which is cached) to guide the process of converting the argument +Types into an IfaceAppArgs list. + +We also want this behavior for IfaceAppTy, since given: + + data Proxy (a :: k) + f :: forall (t :: forall a. a -> Type). Proxy Type (t Bool True) + +We want to print the return type as `Proxy (t True)` without the use of +-fprint-explicit-kinds (#15330). Accomplishing this is trickier than in the +tycon case, because the corresponding Core constructor for IfaceAppTy: + + data Type + = ... + | AppTy Type Type + +Only stores one argument at a time. Therefore, when converting an AppTy to an +IfaceAppTy (in toIfaceTypeX in GHC.CoreToIface), we: + +1. Flatten the chain of AppTys down as much as possible +2. Use typeKind to determine the function Type's kind +3. Use this kind to guide the process of converting the argument Types into an + IfaceAppArgs list. + +By flattening the arguments like this, we obtain two benefits: + +(a) We can reuse the same machinery to pretty-print IfaceTyConApp arguments as + we do IfaceTyApp arguments, which means that we only need to implement the + logic to filter out invisible arguments once. +(b) Unlike for tycons, finding the kind of a type in general (through typeKind) + is not a constant-time operation, so by flattening the arguments first, we + decrease the number of times we have to call typeKind. + +Note [Pretty-printing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Suppressing invisible arguments] is all about how to avoid printing +invisible arguments when the -fprint-explicit-kinds flag is disables. Well, +what about when it's enabled? Then we can and should print invisible kind +arguments, and this Note explains how we do it. + +As two running examples, consider the following code: + + {-# LANGUAGE PolyKinds #-} + data T1 a + data T2 (a :: k) + +When displaying these types (with -fprint-explicit-kinds on), we could just +do the following: + + T1 k a + T2 k a + +That certainly gets the job done. But it lacks a crucial piece of information: +is the `k` argument inferred or specified? To communicate this, we use visible +kind application syntax to distinguish the two cases: + + T1 @{k} a + T2 @k a + +Here, @{k} indicates that `k` is an inferred argument, and @k indicates that +`k` is a specified argument. (See +Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for +a lengthier explanation on what "inferred" and "specified" mean.) + +************************************************************************ +* * + Pretty-printing +* * +************************************************************************ +-} + +if_print_coercions :: SDoc -- ^ if printing coercions + -> SDoc -- ^ otherwise + -> SDoc +if_print_coercions yes no + = sdocOption sdocPrintExplicitCoercions $ \print_co -> + getPprStyle $ \style -> + getPprDebug $ \debug -> + if print_co || dumpStyle style || debug + then yes + else no + +pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc +pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2 + = maybeParen ctxt_prec opPrec $ + sep [pp_ty1, pp_tc <+> pp_ty2] + +pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc +pprIfacePrefixApp ctxt_prec pp_fun pp_tys + | null pp_tys = pp_fun + | otherwise = maybeParen ctxt_prec appPrec $ + hang pp_fun 2 (sep pp_tys) + +isIfaceRhoType :: IfaceType -> Bool +isIfaceRhoType (IfaceForAllTy _ _) = False +isIfaceRhoType (IfaceFunTy af _ _ _) = isVisibleFunArg af +isIfaceRhoType _ = True + +-- ----------------------------- Printing binders ------------------------------------ + +instance Outputable IfaceBndr where + ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr + ppr (IfaceTvBndr bndr) = char '@' <> pprIfaceTvBndr bndr (SuppressBndrSig False) + (UseBndrParens False) + +pprIfaceBndrs :: [IfaceBndr] -> SDoc +pprIfaceBndrs bs = sep (map ppr bs) + +pprIfaceLamBndr :: IfaceLamBndr -> SDoc +pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b +pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" + +pprIfaceIdBndr :: IfaceIdBndr -> SDoc +pprIfaceIdBndr (w, name, ty) = parens (ppr name <> brackets (ppr_ty_nested w) <+> dcolon <+> ppr_ty_nested ty) + +{- Note [Suppressing binder signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When printing the binders in a 'forall', we want to keep the kind annotations: + + forall (a :: k). blah + ^^^^ + good + +On the other hand, when we print the binders of a data declaration in :info, +the kind information would be redundant due to the standalone kind signature: + + type F :: Symbol -> Type + type F (s :: Symbol) = blah + ^^^^^^^^^ + redundant + +Here we'd like to omit the kind annotation: + + type F :: Symbol -> Type + type F s = blah + +Note [Printing type abbreviations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally, we pretty-print + `TYPE 'LiftedRep` as `Type` (or `*`) + `CONSTRAINT 'LiftedRep` as `Constraint` + `FUN 'Many` as `(->)` +This way, error messages don't refer to representation polymorphism +or linearity if it is not necessary. Normally we'd would represent +these types using their synonyms (see GHC.Core.Type +Note [Using synonyms to compress types]), but in the :kind! GHCi +command we specifically expand synonyms (see GHC.Tc.Module.tcRnExpr). +So here in the pretty-printing we effectively collapse back Type +and Constraint to their synonym forms. A bit confusing! + +However, when printing the definition of Type, Constraint or (->) with :info, +this would give confusing output: `type (->) = (->)` (#18594). +Solution: detect when we are in :info and disable displaying the synonym +with the SDoc option sdocPrintTypeAbbreviations. +If you are creating a similar synonym, make sure it is listed in pprIfaceDecl, +see reference to this Note. + +If there will be a need, in the future we could expose it as a flag +-fprint-type-abbreviations or even three separate flags controlling +TYPE 'LiftedRep, CONSTRAINT 'LiftedRep and FUN 'Many. +-} + +-- | Do we want to suppress kind annotations on binders? +-- See Note [Suppressing binder signatures] +newtype SuppressBndrSig = SuppressBndrSig Bool + +newtype UseBndrParens = UseBndrParens Bool +newtype PrintExplicitKinds = PrintExplicitKinds Bool + +pprIfaceTvBndr :: IfaceTvBndr -> SuppressBndrSig -> UseBndrParens -> SDoc +pprIfaceTvBndr (tv, ki) (SuppressBndrSig suppress_sig) (UseBndrParens use_parens) + | suppress_sig = ppr tv + | isIfaceLiftedTypeKind ki = ppr tv + | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr_ty_nested ki) + where + maybe_parens | use_parens = parens + | otherwise = id + +pprIfaceTyConBinders :: SuppressBndrSig -> [IfaceTyConBinder] -> SDoc +pprIfaceTyConBinders suppress_sig = sep . map go + where + go :: IfaceTyConBinder -> SDoc + go (Bndr (IfaceIdBndr bndr) _) = pprIfaceIdBndr bndr + go (Bndr (IfaceTvBndr bndr) vis) = + -- See Note [Pretty-printing invisible arguments] + case vis of + AnonTCB -> ppr_bndr (UseBndrParens True) + NamedTCB Required -> ppr_bndr (UseBndrParens True) + NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) + NamedTCB Inferred -> char '@' <> braces (ppr_bndr (UseBndrParens False)) + where + ppr_bndr = pprIfaceTvBndr bndr suppress_sig + +instance Binary IfaceBndr where + put_ bh (IfaceIdBndr aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceTvBndr ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceIdBndr aa) + _ -> do ab <- get bh + return (IfaceTvBndr ab) + +instance Binary IfaceOneShot where + put_ bh IfaceNoOneShot = + putByte bh 0 + put_ bh IfaceOneShot = + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceNoOneShot + _ -> return IfaceOneShot + +-- ----------------------------- Printing IfaceType ------------------------------------ + +--------------------------------- +instance Outputable IfaceType where + ppr ty = pprIfaceType ty + +-- The purpose of 'ppr_ty_nested' is to distinguish calls that should not +-- trigger 'hideNonStandardTypes', see Note [Defaulting RuntimeRep variables] +-- wrinkle (W2). +pprIfaceType, pprParendIfaceType, ppr_ty_nested :: IfaceType -> SDoc +pprIfaceType = pprPrecIfaceType topPrec +pprParendIfaceType = pprPrecIfaceType appPrec +ppr_ty_nested = ppr_ty topPrec + +pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc +-- We still need `hideNonStandardTypes`, since the `pprPrecIfaceType` may be +-- called from other places, besides `:type` and `:info`. +pprPrecIfaceType prec ty = + hideNonStandardTypes (ppr_ty prec) ty + +pprTypeArrow :: FunTyFlag -> IfaceMult -> SDoc +pprTypeArrow af mult + = pprArrow (mb_conc, pprPrecIfaceType) af mult + where + mb_conc (IfaceTyConApp tc _) = Just tc + mb_conc _ = Nothing + +pprArrow :: (a -> Maybe IfaceTyCon, PprPrec -> a -> SDoc) + -> FunTyFlag -> a -> SDoc +-- Prints a thin arrow (->) with its multiplicity +-- Used for both FunTy and FunCo, hence higher order arguments +pprArrow (mb_conc, ppr_mult) af mult + | isFUNArg af + = case mb_conc mult of + Just tc | tc `ifaceTyConHasKey` manyDataConKey -> arrow + | tc `ifaceTyConHasKey` oneDataConKey -> lollipop + _ -> text "%" <> ppr_mult appPrec mult <+> arrow + | otherwise + = ppr (funTyFlagTyCon af) + +ppr_ty :: PprPrec -> IfaceType -> SDoc +ppr_ty ctxt_prec ty + | not (isIfaceRhoType ty) = ppr_sigma ShowForAllMust ctxt_prec ty +ppr_ty _ (IfaceForAllTy {}) = panic "ppr_ty" -- Covered by not.isIfaceRhoType +ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar! +ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free TyVars and CoVars in IfaceType] +ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys +ppr_ty ctxt_prec (IfaceTupleTy i p tys) = ppr_tuple ctxt_prec i p tys -- always fully saturated +ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n + + -- Function types +ppr_ty ctxt_prec ty@(IfaceFunTy af w ty1 ty2) -- Should be a visible argument + = assertPpr (isVisibleFunArg af) (ppr ty) $ -- Ensured by isIfaceRhoType above + -- We want to print a chain of arrows in a column + -- type1 + -- -> type2 + -- -> type3 + maybeParen ctxt_prec funPrec $ + sep [ppr_ty funPrec ty1, sep (ppr_fun_tail w ty2)] + where + ppr_fun_tail wthis (IfaceFunTy af wnext ty1 ty2) + | isVisibleFunArg af + = (pprTypeArrow af wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2 + ppr_fun_tail wthis other_ty + = [pprTypeArrow af wthis <+> ppr_ty_nested other_ty] + +ppr_ty ctxt_prec (IfaceAppTy t ts) + = if_print_coercions + ppr_app_ty + ppr_app_ty_no_casts + where + ppr_app_ty = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + let tys_wo_kinds = appArgsIfaceTypesForAllTyFlags $ stripInvisArgs + (PrintExplicitKinds print_kinds) ts + in pprIfacePrefixApp ctxt_prec + (ppr_ty funPrec t) + (map (ppr_app_arg appPrec) tys_wo_kinds) + + + -- Strip any casts from the head of the application + ppr_app_ty_no_casts = + case t of + IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts) + _ -> ppr_app_ty + + mk_app_tys :: IfaceType -> IfaceAppArgs -> IfaceType + mk_app_tys (IfaceTyConApp tc tys1) tys2 = + IfaceTyConApp tc (tys1 `mappend` tys2) + mk_app_tys t1 tys2 = IfaceAppTy t1 tys2 + +ppr_ty ctxt_prec (IfaceCastTy ty co) + = if_print_coercions + (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co)) + (ppr_ty ctxt_prec ty) + +ppr_ty ctxt_prec (IfaceCoercionTy co) + = if_print_coercions + (ppr_co ctxt_prec co) + (text "<>") + +{- Note [Defaulting RuntimeRep variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +RuntimeRep variables are considered by many (most?) users to be little +more than syntactic noise. When the notion was introduced there was a +significant and understandable push-back from those with pedagogy in +mind, which argued that RuntimeRep variables would throw a wrench into +nearly any teach approach since they appear in even the lowly ($) +function's type, + + ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b + +which is significantly less readable than its non RuntimeRep-polymorphic type of + + ($) :: (a -> b) -> a -> b + +Moreover, unboxed types don't appear all that often in run-of-the-mill +Haskell programs, so it makes little sense to make all users pay this +syntactic overhead. + +For this reason it was decided that we would hide RuntimeRep variables +for now (see #11549). We do this right in the pretty-printer, by pre-processing +the type we are about to print, to default any type variables of kind RuntimeRep +that are bound by toplevel invisible quantification to LiftedRep. +Likewise, we default Multiplicity variables to Many and Levity variables to +Lifted. + +This is done in a pass right before pretty-printing +(defaultIfaceTyVarsOfKind, controlled by +-fprint-explicit-runtime-reps and -XLinearTypes) + +This applies to /quantified/ variables like 'w' above. What about +variables that are /free/ in the type being printed, which certainly +happens in error messages. Suppose (#16074, #19361) we are reporting a +mismatch between skolems + (a :: RuntimeRep) ~ (b :: RuntimeRep) + or + (m :: Multiplicity) ~ Many +We certainly don't want to say "Can't match LiftedRep with LiftedRep" or +"Can't match Many with Many"! + +But if we are printing the type + (forall (a :: TYPE r). blah) +we do want to turn that (free) r into LiftedRep, so it prints as + (forall a. blah) + +We use isMetaTyVar to distinguish between those two situations: +metavariables are converted, skolem variables are not. + +There's one exception though: TyVarTv metavariables should not be defaulted, +as they appear during kind-checking of "newtype T :: TYPE r where..." +(test T18357a). Therefore, we additionally test for isTyConableTyVar. + +Wrinkles: + +(W1) The loop 'go' in 'defaultIfaceTyVarsOfKind' passes a Bool flag, 'rank1', + around that indicates whether we haven't yet descended into the arguments + of a function type. + This is used to decide whether newly bound variables are eligible for + defaulting – we do not want contravariant foralls to be defaulted because + that would result in an incorrect, rather than specialized, type. + For example: + ∀ p (r1 :: RuntimeRep) . (∀ (r2 :: RuntimeRep) . p r2) -> p r1 + We want to default 'r1', but not 'r2'. + When examining the first forall, 'rank1' is True. + The toplevel function type is matched as IfaceFunTy, where we recurse into + 'go' by passing False for 'rank1'. + The forall in the first argument then skips adding a substitution for 'r2'. + +(W2) 'defaultIfaceTyVarsOfKind' ought to be called only once when printing a + type. + A few components of the printing machinery used to invoke 'ppr' on types + nested in secondary structures like IfaceBndr, which would repeat the + defaulting process, but treating the type as if it were top-level, causing + unwanted defaulting. + In order to prevent future developers from using 'ppr' again or being + confused that @ppr_ty topPrec@ is used, we introduced a marker function, + 'ppr_ty_nested'. +-} + +-- | Default 'RuntimeRep' variables to 'LiftedRep', +-- 'Levity' variables to 'Lifted', and 'Multiplicity' +-- variables to 'Many'. For example: +-- +-- @ +-- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). +-- (a -> b) -> a -> b +-- Just :: forall (k :: Multiplicity) a. a % k -> Maybe a +-- @ +-- +-- turns in to, +-- +-- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ +-- @ Just :: forall a . a -> Maybe a @ +-- +-- We do this to prevent RuntimeRep, Levity and Multiplicity variables from +-- incurring a significant syntactic overhead in otherwise simple +-- type signatures (e.g. ($)). See Note [Defaulting RuntimeRep variables] +-- and #11549 for further discussion. +defaultIfaceTyVarsOfKind :: Bool -- ^ default 'RuntimeRep'/'Levity' variables? + -> Bool -- ^ default 'Multiplicity' variables? + -> IfaceType -> IfaceType +defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty + where + go :: FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Levity/Multiplicity variables + -> Bool -- Are we in a toplevel forall, where defaulting is allowed? + -> IfaceType + -> IfaceType + go subs True (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) + | isInvisibleForAllTyFlag argf -- Don't default *visible* quantification + -- or we get the mess in #13963 + , Just substituted_ty <- check_substitution var_kind + = let subs' = extendFsEnv subs (ifLclNameFS var) substituted_ty + -- Record that we should replace it with LiftedRep/Lifted/Many, + -- and recurse, discarding the forall + in go subs' True ty + + go subs rank1 (IfaceForAllTy bndr ty) + = IfaceForAllTy (go_ifacebndr subs bndr) (go subs rank1 ty) + + go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs (ifLclNameFS tv) of + Just s -> s + Nothing -> ty + + go _ _ ty@(IfaceFreeTyVar tv) + -- See Note [Defaulting RuntimeRep variables], about free vars + | def_rep + , GHC.Core.Type.isRuntimeRepTy (tyVarKind tv) + , isMetaTyVar tv + , isTyConableTyVar tv + = liftedRep_ty + | def_rep + , GHC.Core.Type.isLevityTy (tyVarKind tv) + , isMetaTyVar tv + , isTyConableTyVar tv + = lifted_ty + | def_mult + , GHC.Core.Type.isMultiplicityTy (tyVarKind tv) + , isMetaTyVar tv + , isTyConableTyVar tv + = many_ty + | otherwise + = ty + + go subs _ (IfaceTyConApp tc tc_args) + = IfaceTyConApp tc (go_args subs tc_args) + + go subs _ (IfaceTupleTy sort is_prom tc_args) + = IfaceTupleTy sort is_prom (go_args subs tc_args) + + go subs rank1 (IfaceFunTy af w arg res) + = IfaceFunTy af (go subs False w) (go subs False arg) (go subs rank1 res) + + go subs _ (IfaceAppTy t ts) + = IfaceAppTy (go subs False t) (go_args subs ts) + + go subs rank1 (IfaceCastTy x co) + = IfaceCastTy (go subs rank1 x) co + + go _ _ ty@(IfaceLitTy {}) = ty + go _ _ ty@(IfaceCoercionTy {}) = ty + + go_ifacebndr :: FastStringEnv IfaceType -> IfaceForAllBndr -> IfaceForAllBndr + go_ifacebndr subs (Bndr (IfaceIdBndr (w, n, t)) argf) + = Bndr (IfaceIdBndr (w, n, go subs False t)) argf + go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf) + = Bndr (IfaceTvBndr (n, go subs False t)) argf + + go_args :: FastStringEnv IfaceType -> IfaceAppArgs -> IfaceAppArgs + go_args _ IA_Nil = IA_Nil + go_args subs (IA_Arg ty argf args) + = IA_Arg (go subs False ty) argf (go_args subs args) + + check_substitution :: IfaceType -> Maybe IfaceType + check_substitution (IfaceTyConApp tc _) + | def_rep + , tc `ifaceTyConHasKey` runtimeRepTyConKey + = Just liftedRep_ty + | def_rep + , tc `ifaceTyConHasKey` levityTyConKey + = Just lifted_ty + | def_mult + , tc `ifaceTyConHasKey` multiplicityTyConKey + = Just many_ty + check_substitution _ = Nothing + +-- | The type ('BoxedRep 'Lifted), also known as LiftedRep. +liftedRep_ty :: IfaceType +liftedRep_ty = + IfaceTyConApp liftedRep IA_Nil + where + liftedRep :: IfaceTyCon + liftedRep = IfaceTyCon tc_name (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon) + where tc_name = getName liftedRepTyCon + +-- | The type 'Lifted :: Levity'. +lifted_ty :: IfaceType +lifted_ty = + IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon)) + IA_Nil + where dc_name = getName liftedDataConTyCon + +-- | The type 'Many :: Multiplicity'. +many_ty :: IfaceType +many_ty = IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon)) + IA_Nil + where dc_name = getName manyDataConTyCon + +hideNonStandardTypes :: (IfaceType -> SDoc) -> IfaceType -> SDoc +hideNonStandardTypes f ty + = sdocOption sdocPrintExplicitRuntimeReps $ \printExplicitRuntimeReps -> + sdocOption sdocLinearTypes $ \linearTypes -> + getPprStyle $ \sty -> + let def_rep = not printExplicitRuntimeReps + def_mult = not linearTypes + in if userStyle sty + then f (defaultIfaceTyVarsOfKind def_rep def_mult ty) + else f ty + +instance Outputable IfaceAppArgs where + ppr tca = pprIfaceAppArgs tca + +pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgs -> SDoc +pprIfaceAppArgs = ppr_app_args topPrec +pprParendIfaceAppArgs = ppr_app_args appPrec + +ppr_app_args :: PprPrec -> IfaceAppArgs -> SDoc +ppr_app_args ctx_prec = go + where + go :: IfaceAppArgs -> SDoc + go IA_Nil = empty + go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts + +-- See Note [Pretty-printing invisible arguments] +ppr_app_arg :: PprPrec -> (IfaceType, ForAllTyFlag) -> SDoc +ppr_app_arg ctx_prec (t, argf) = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + case argf of + Required -> ppr_ty ctx_prec t + Specified | print_kinds + -> char '@' <> ppr_ty appPrec t + Inferred | print_kinds + -> char '@' <> braces (ppr_ty_nested t) + _ -> empty + +------------------- +pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +pprIfaceForAllPart tvs ctxt sdoc + = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc + +-- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@. +pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +pprIfaceForAllPartMust tvs ctxt sdoc + = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc + +pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] + -> SDoc -> SDoc +pprIfaceForAllCoPart tvs sdoc + = sep [ pprIfaceForAllCo tvs, sdoc ] + +ppr_iface_forall_part :: ShowForAllFlag + -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +ppr_iface_forall_part show_forall tvs ctxt sdoc + = sep [ case show_forall of + ShowForAllMust -> pprIfaceForAll tvs + ShowForAllWhen -> pprUserIfaceForAll tvs + , pprIfaceContextArr ctxt + , sdoc] + +-- | Render the "forall ... ." or "forall ... ->" bit of a type. +pprIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprIfaceForAll [] = empty +pprIfaceForAll bndrs@(Bndr _ vis : _) + = sep [ add_separator (forAllLit <+> fsep docs) + , pprIfaceForAll bndrs' ] + where + (bndrs', docs) = ppr_itv_bndrs bndrs vis + + add_separator stuff = case vis of + Required -> stuff <+> arrow + _inv -> stuff <> dot + + +-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. +-- Returns both the list of not-yet-rendered binders and the doc. +-- No anonymous binders here! +ppr_itv_bndrs :: [IfaceForAllBndr] + -> ForAllTyFlag -- ^ visibility of the first binder in the list + -> ([IfaceForAllBndr], [SDoc]) +ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 + | vis `eqForAllVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in + (bndrs', pprIfaceForAllBndr bndr : doc) + | otherwise = (all_bndrs, []) +ppr_itv_bndrs [] _ = ([], []) + +pprIfaceForAllCo :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc +pprIfaceForAllCo [] = empty +pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot + +pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc +pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs + +pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc +pprIfaceForAllBndr bndr = + case bndr of + Bndr (IfaceTvBndr tv) Inferred -> + braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False) + Bndr (IfaceTvBndr tv) _ -> + pprIfaceTvBndr tv suppress_sig (UseBndrParens True) + Bndr (IfaceIdBndr idv) _ -> pprIfaceIdBndr idv + where + -- See Note [Suppressing binder signatures] + suppress_sig = SuppressBndrSig False + +pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag) -> SDoc +pprIfaceForAllCoBndr (tv, kind_co, visL, visR) + = parens (ppr tv <> pp_vis <+> dcolon <+> pprIfaceCoercion kind_co) + where + pp_vis | visL == coreTyLamForAllTyFlag + , visR == coreTyLamForAllTyFlag + = empty + | otherwise + = ppr visL <> char '~' <> ppr visR -- "[spec]~[reqd]" + +-- | Show forall flag +-- +-- Unconditionally show the forall quantifier with ('ShowForAllMust') +-- or when ('ShowForAllWhen') the names used are free in the binder +-- or when compiling with -fprint-explicit-foralls. +data ShowForAllFlag = ShowForAllMust | ShowForAllWhen + +data ShowSub + = ShowSub + { ss_how_much :: ShowHowMuch + , ss_forall :: ShowForAllFlag } + +-- See Note [Printing IfaceDecl binders] +-- The alternative pretty printer referred to in the note. +newtype AltPpr = AltPpr (Maybe (OccName -> SDoc)) + +data ShowHowMuch + = ShowHeader AltPpr -- ^ Header information only, not rhs + | ShowSome (Maybe (OccName -> Bool)) AltPpr + -- ^ Show the declaration and its RHS. The @Maybe@ predicate + -- allows filtering of the sub-components which should be printing; + -- any sub-components filtered out will be elided with @...@. + | ShowIface + -- ^ Everything including GHC-internal information (used in --show-iface) + +instance Outputable ShowHowMuch where + ppr (ShowHeader _) = text "ShowHeader" + ppr ShowIface = text "ShowIface" + ppr (ShowSome _ _) = text "ShowSome" + +pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc +pprIfaceSigmaType show_forall ty + = hideNonStandardTypes (ppr_sigma show_forall topPrec) ty + +ppr_sigma :: ShowForAllFlag -> PprPrec -> IfaceType -> SDoc +ppr_sigma show_forall ctxt_prec iface_ty + = maybeParen ctxt_prec funPrec $ + let (invis_tvs, theta, tau) = splitIfaceSigmaTy iface_ty + (req_tvs, tau') = splitIfaceReqForallTy tau + -- splitIfaceSigmaTy is recursive, so it will gather the binders after + -- the theta, i.e. forall a. theta => forall b. tau + -- will give you ([a,b], theta, tau). + -- + -- This isn't right when it comes to visible forall (see + -- testsuite/tests/polykinds/T18522-ppr), + -- so we split off required binders separately, + -- using splitIfaceReqForallTy. + -- + -- An alternative solution would be to make splitIfaceSigmaTy + -- non-recursive (see #18458). + -- Then it could handle both invisible and required binders, and + -- splitIfaceReqForallTy wouldn't be necessary here. + in ppr_iface_forall_part show_forall invis_tvs theta $ + sep [pprIfaceForAll req_tvs, ppr_ty_nested tau'] + +pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprUserIfaceForAll tvs + = sdocOption sdocPrintExplicitForalls $ \print_foralls -> + -- See Note [When to print foralls] in this module. + ppWhen (any tv_has_kind_var tvs + || any tv_is_required tvs + || print_foralls) $ + pprIfaceForAll tvs + where + tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _) + = not (ifTypeIsVarFree kind) + tv_has_kind_var _ = False + + tv_is_required = isVisibleForAllTyFlag . binderFlag + +{- +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We opt to explicitly pretty-print `forall`s if any of the following +criteria are met: + +1. -fprint-explicit-foralls is on. + +2. A bound type variable has a polymorphic kind. E.g., + + forall k (a::k). Proxy a -> Proxy a + + Since a's kind mentions a variable k, we print the foralls. + +3. A bound type variable is a visible argument (#14238). + Suppose we are printing the kind of: + + T :: forall k -> k -> Type + + The "forall k ->" notation means that this kind argument is required. + That is, it must be supplied at uses of T. E.g., + + f :: T (Type->Type) Monad -> Int + + So we print an explicit "T :: forall k -> k -> Type", + because omitting it and printing "T :: k -> Type" would be + utterly misleading. + + See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] + in GHC.Core.TyCo.Rep. + +N.B. Until now (Aug 2018) we didn't check anything for coercion variables. + +Note [Printing foralls in type family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use the same criteria as in Note [When to print foralls] to determine +whether a type family instance should be pretty-printed with an explicit +`forall`. Example: + + type family Foo (a :: k) :: k where + Foo Maybe = [] + Foo (a :: Type) = Int + Foo a = a + +Without -fprint-explicit-foralls enabled, this will be pretty-printed as: + +type family Foo (a :: k) :: k where + Foo Maybe = [] + Foo a = Int + forall k (a :: k). Foo a = a + +Note that only the third equation has an explicit forall, since it has a type +variable with a non-Type kind. (If -fprint-explicit-foralls were enabled, then +the second equation would be preceded with `forall a.`.) + +There is one tricky point in the implementation: what visibility +do we give the type variables in a type family instance? Type family instances +only store type *variables*, not type variable *binders*, and only the latter +has visibility information. We opt to default the visibility of each of these +type variables to Specified because users can't ever instantiate these +variables manually, so the choice of visibility is only relevant to +pretty-printing. (This is why the `k` in `forall k (a :: k). ...` above is +printed the way it is, even though it wasn't written explicitly in the +original source code.) + +We adopt the same strategy for data family instances. Example: + + data family DF (a :: k) + data instance DF '[a, b] = DFList + +That data family instance is pretty-printed as: + + data instance forall j (a :: j) (b :: j). DF '[a, b] = DFList + +This is despite that the representation tycon for this data instance (call it +$DF:List) actually has different visibilities for its binders. +However, the visibilities of these binders are utterly irrelevant to the +programmer, who cares only about the specificity of variables in `DF`'s type, +not $DF:List's type. Therefore, we opt to pretty-print all variables in data +family instances as Specified. + +Note [Printing promoted type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GHCi session (#14343) + > _ :: Proxy '[ 'True ] + error: + Found hole: _ :: Proxy '['True] + +This would be bad, because the '[' looks like a character literal. + +A similar issue arises if the element is a character literal (#22488) + ghci> type T = '[ 'x' ] + ghci> :kind! T + T :: [Char] + = '['x'] + +Solution: in type-level lists and tuples, add a leading space +if the first element is printed with a single quote. +-} + + +------------------- + +-- See equivalent function in "GHC.Core.TyCo.Rep" +pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc +-- Given a type-level list (t1 ': t2), see if we can print +-- it in list notation [t1, ...]. +-- Precondition: Opt_PrintExplicitKinds is off +pprIfaceTyList ctxt_prec ty1 ty2 + = case gather ty2 of + (arg_tys, Nothing) + -> + sdocWithContext $ \ctx -> + let + items = ty1:arg_tys + eos = isListEmptyOrSingleton items + ticked = promTick (sdocStyle ctx) (PromotedItemListSyntax eos) + (preBracket, postBracket) = + if ticked + then (char '\'', spaceIfSingleQuote) + else (empty, id) + in + preBracket <> brackets (postBracket (fsep + (punctuate comma (map (ppr_ty topPrec) items)))) + (arg_tys, Just tl) + -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) + 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) + where + gather :: IfaceType -> ([IfaceType], Maybe IfaceType) + -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] + -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl + gather (IfaceTyConApp tc tys) + | tc `ifaceTyConHasKey` consDataConKey + , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys + , isInvisibleForAllTyFlag argf + , (args, tl) <- gather ty2 + = (ty1:args, tl) + | tc `ifaceTyConHasKey` nilDataConKey + = ([], Nothing) + gather ty = ([], Just ty) + +pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc +pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args + +pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc +pprTyTcApp ctxt_prec tc tys = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + sdocOption sdocPrintTypeAbbreviations $ \print_type_abbreviations -> + getPprDebug $ \debug -> + + if | ifaceTyConName tc `hasKey` ipClassKey + , IA_Arg (IfaceLitTy (IfaceStrTyLit n)) + Required (IA_Arg ty Required IA_Nil) <- tys + -> maybeParen ctxt_prec funPrec + $ char '?' <> ftext (getLexicalFastString n) <> dcolon <> ppr_ty topPrec ty + + | IfaceTupleTyCon arity sort <- ifaceTyConSort info + , not debug + , arity == ifaceVisAppArgsLength tys + -> ppr_tuple ctxt_prec sort (ifaceTyConIsPromoted info) tys + -- NB: ppr_tuple requires a saturated tuple. + + | IfaceSumTyCon arity <- ifaceTyConSort info + , not debug + , arity == ifaceVisAppArgsLength tys + -> ppr_sum ctxt_prec (ifaceTyConIsPromoted info) tys + -- NB: ppr_sum requires a saturated unboxed sum. + + | tc `ifaceTyConHasKey` consDataConKey + , False <- print_kinds + , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys + , isInvisibleForAllTyFlag argf + -> pprIfaceTyList ctxt_prec ty1 ty2 + + | isIfaceLiftedTypeKind (IfaceTyConApp tc tys) + , print_type_abbreviations -- See Note [Printing type abbreviations] + -> ppr_kind_type ctxt_prec + + | isIfaceConstraintKind (IfaceTyConApp tc tys) + , print_type_abbreviations -- See Note [Printing type abbreviations] + -> pprPrefixOcc constraintKindTyConName + + | tc `ifaceTyConHasKey` fUNTyConKey + , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys + , rep `ifaceTyConHasKey` manyDataConKey + , print_type_abbreviations -- See Note [Printing type abbreviations] + -> pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_app_arg appPrec) $ + appArgsIfaceTypesForAllTyFlags $ + stripInvisArgs (PrintExplicitKinds print_kinds) args) + -- Use appArgsIfaceTypesForAllTyFlags to print invisible arguments + -- correctly (#19310) + + | tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey + , not debug + -- Suppress detail unless you _really_ want to see + -> text "(TypeError ...)" + + | Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys) + -> doc + + | otherwise + -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc $ + appArgsIfaceTypesForAllTyFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys + where + info = ifaceTyConInfo tc + +ppr_kind_type :: PprPrec -> SDoc +ppr_kind_type ctxt_prec = sdocOption sdocStarIsType $ \case + False -> pprPrefixOcc liftedTypeKindTyConName + True -> maybeParen ctxt_prec starPrec $ + unicodeSyntax (char '★') (char '*') + +-- | Pretty-print a type-level equality. +-- Returns (Just doc) if the argument is a /saturated/ application +-- of eqTyCon (~) +-- eqPrimTyCon (~#) +-- eqReprPrimTyCon (~R#) +-- heqTyCon (~~) +-- +-- See Note [Equality predicates in IfaceType] +-- and Note [The equality types story] in GHC.Builtin.Types.Prim +ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc +ppr_equality ctxt_prec tc args + | hetero_eq_tc + , [k1, k2, t1, t2] <- args + = Just $ print_equality (k1, k2, t1, t2) + + | hom_eq_tc + , [k, t1, t2] <- args + = Just $ print_equality (k, k, t1, t2) + + | otherwise + = Nothing + where + homogeneous = tc_name `hasKey` eqTyConKey -- (~) + || hetero_tc_used_homogeneously + where + hetero_tc_used_homogeneously + = case ifaceTyConSort $ ifaceTyConInfo tc of + IfaceEqualityTyCon -> True + _other -> False + -- True <=> a heterogeneous equality whose arguments + -- are (in this case) of the same kind + + tc_name = ifaceTyConName tc + pp = ppr_ty + hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~) + hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#) + || tc_name `hasKey` eqReprPrimTyConKey -- (~R#) + || tc_name `hasKey` heqTyConKey -- (~~) + nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~) + || tc_name `hasKey` eqPrimTyConKey -- (~#) + print_equality args = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + sdocOption sdocPrintEqualityRelations $ \print_eqs -> + getPprStyle $ \style -> + getPprDebug $ \debug -> + print_equality' args print_kinds + (print_eqs || dumpStyle style || debug) + + print_equality' (ki1, ki2, ty1, ty2) print_kinds print_eqs + | -- If -fprint-equality-relations is on, just print the original TyCon + print_eqs + = ppr_infix_eq (ppr tc) + + | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2) + -- or unlifted equality (ty1 ~# ty2) + nominal_eq_tc, homogeneous + = ppr_infix_eq (text "~") + + | -- Heterogeneous use of unlifted equality (ty1 ~# ty2) + not homogeneous + = ppr_infix_eq (ppr heqTyCon) + + | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2) + tc_name `hasKey` eqReprPrimTyConKey, homogeneous + = let ki | print_kinds = [pp appPrec ki1] + | otherwise = [] + in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon) + (ki ++ [pp appPrec ty1, pp appPrec ty2]) + + -- The other cases work as you'd expect + | otherwise + = ppr_infix_eq (ppr tc) + where + ppr_infix_eq :: SDoc -> SDoc + ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op + (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2) + where + pp_ty_ki ty ki + | print_kinds + = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki) + | otherwise + = pp opPrec ty + + +pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc +pprIfaceCoTcApp ctxt_prec tc tys = + ppr_iface_tc_app (\prec (co, _) -> ppr_co prec co) ctxt_prec tc + (map (, Required) tys) + -- We are trying to re-use ppr_iface_tc_app here, which requires its + -- arguments to be accompanied by visibilities. But visibility is + -- irrelevant when printing coercions, so just default everything to + -- Required. + +-- | Pretty-prints an application of a type constructor to some arguments +-- (whose visibilities are known). This is polymorphic (over @a@) since we use +-- this function to pretty-print two different things: +-- +-- 1. Types (from `pprTyTcApp'`) +-- +-- 2. Coercions (from 'pprIfaceCoTcApp') +ppr_iface_tc_app :: (PprPrec -> (a, ForAllTyFlag) -> SDoc) + -> PprPrec -> IfaceTyCon -> [(a, ForAllTyFlag)] -> SDoc + +ppr_iface_tc_app pp ctxt_prec tc tys = + sdocOption sdocListTuplePuns $ \listTuplePuns -> + if | listTuplePuns, tc `ifaceTyConHasKey` listTyConKey, [ty] <- tys + -> brackets (pp topPrec ty) + + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + -> ppr_kind_type ctxt_prec + + | isSymOcc (nameOccName (ifaceTyConName tc)) + + , [ ty1@(_, Required), ty2@(_, Required) ] <- tys + -- Infix, two visible arguments (we know nothing of precedence though). + -- Don't apply this special case if one of the arguments is invisible, + -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). + -> pprIfaceInfixApp ctxt_prec (pprIfaceTyCon tc) (pp opPrec ty1) (pp opPrec ty2) + + | otherwise + -> pprIfacePrefixApp ctxt_prec (pprParendIfaceTyCon tc) (map (pp appPrec) tys) + +data TupleOrSum = IsSum | IsTuple TupleSort + deriving (Eq) + +-- | Pretty-print a boxed tuple datacon in regular tuple syntax. +-- Used when -XListTuplePuns is disabled. +ppr_tuple_no_pun :: PprPrec -> [IfaceType] -> SDoc +ppr_tuple_no_pun ctxt_prec = \case + [t] -> maybeParen ctxt_prec appPrec (text "MkSolo" <+> pprPrecIfaceType appPrec t) + tys -> tupleParens BoxedTuple (pprWithCommas pprIfaceType tys) + +-- | Pretty-print an unboxed tuple or sum type in its parenthesized, punned, form. +-- Used when -XListTuplePuns is enabled. +-- +-- The tycon should be saturated: +-- as many visible arguments as the arity of the sum or tuple. +-- +-- NB: this always strips off the invisible 'RuntimeRep' arguments, +-- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`. +ppr_tuple_sum_pun :: PprPrec -> TupleOrSum -> PromotionFlag -> IfaceType -> Arity -> [IfaceType] -> SDoc +ppr_tuple_sum_pun ctxt_prec sort promoted tc arity tys + | IsSum <- sort + = sumParens (pprWithBars (ppr_ty topPrec) tys) + + | IsTuple ConstraintTuple <- sort + , NotPromoted <- promoted + , arity == 0 + = maybeParen ctxt_prec sigPrec $ + text "() :: Constraint" + + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `Solo x`, not `(x)` + | IsTuple BoxedTuple <- sort + , arity == 1 + = pprPrecIfaceType ctxt_prec tc + + | IsTuple tupleSort <- sort + = pprPromotionQuoteI promoted <> + tupleParens tupleSort (quote_space (pprWithCommas pprIfaceType tys)) + where + quote_space = case promoted of + IsPromoted -> spaceIfSingleQuote + NotPromoted -> id + +-- | Pretty-print an unboxed tuple or sum type either in the punned or unpunned form, +-- depending on whether -XListTuplePuns is enabled. +ppr_tuple_sum :: PprPrec -> TupleOrSum -> PromotionFlag -> IfaceAppArgs -> SDoc +ppr_tuple_sum ctxt_prec sort is_promoted args = + sdocOption sdocListTuplePuns $ \case + True -> ppr_tuple_sum_pun ctxt_prec sort is_promoted prefix_tc arity non_rep_tys + False + | IsPromoted <- is_promoted + , IsTuple BoxedTuple <- sort + -> ppr_tuple_no_pun ctxt_prec non_rep_tys + | otherwise + -> pprPrecIfaceType ctxt_prec prefix_tc + where + -- This tycon is used to print in prefix notation for the punned Solo + -- case and the unabbreviated case. + prefix_tc = IfaceTyConApp (IfaceTyCon (mk_name arity) info) args + + info = mkIfaceTyConInfo NotPromoted IfaceNormalTyCon + + mk_name = case (sort, is_promoted) of + (IsTuple BoxedTuple, IsPromoted) -> tupleDataConName Boxed + (IsTuple s, _) -> tupleTyConName s + (IsSum, _) -> tyConName . sumTyCon + + -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + non_rep_tys = if strip_reps then drop arity all_tys else all_tys + + arity = if strip_reps then count `div` 2 else count + + count = length all_tys + + all_tys = appArgsIfaceTypes args + + strip_reps = case is_promoted of + IsPromoted -> True + NotPromoted -> strip_reps_sort + + strip_reps_sort = case sort of + IsTuple BoxedTuple -> False + IsTuple UnboxedTuple -> True + IsTuple ConstraintTuple -> False + IsSum -> True + +-- | Pretty-print an unboxed sum type. +-- The sum should be saturated: as many visible arguments as the arity of +-- the sum. +ppr_sum :: PprPrec -> PromotionFlag -> IfaceAppArgs -> SDoc +ppr_sum ctxt_prec = ppr_tuple_sum ctxt_prec IsSum + +-- | Pretty-print a tuple type (boxed tuple, constraint tuple, unboxed tuple). +-- The tuple should be saturated: as many visible arguments as the arity of +-- the tuple. +ppr_tuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc +ppr_tuple ctxt_prec sort = ppr_tuple_sum ctxt_prec (IsTuple sort) + +pprIfaceTyLit :: IfaceTyLit -> SDoc +pprIfaceTyLit (IfaceNumTyLit n) = integer n +pprIfaceTyLit (IfaceStrTyLit n) = text (show n) +pprIfaceTyLit (IfaceCharTyLit c) = text (show c) + +pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc +pprIfaceCoercion = ppr_co topPrec +pprParendIfaceCoercion = ppr_co appPrec + +ppr_co :: PprPrec -> IfaceCoercion -> SDoc +ppr_co _ (IfaceReflCo ty) = angleBrackets (ppr ty) <> ppr_role Nominal +ppr_co _ (IfaceGReflCo r ty IfaceMRefl) + = angleBrackets (ppr ty) <> ppr_role r +ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co)) + = ppr_special_co ctxt_prec + (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co] + +ppr_co ctxt_prec (IfaceFunCo r co_mult co1 co2) + = maybeParen ctxt_prec funPrec $ + sep (ppr_co funPrec co1 : ppr_fun_tail co_mult co2) + where + ppr_fun_tail co_mult1 (IfaceFunCo r co_mult2 co1 co2) + = (ppr_arrow co_mult1 <> ppr_role r <+> ppr_co funPrec co1) + : ppr_fun_tail co_mult2 co2 + ppr_fun_tail co_mult1 other_co + = [ppr_arrow co_mult1 <> ppr_role r <+> pprIfaceCoercion other_co] + + ppr_arrow = pprArrow (mb_conc, ppr_co) visArgTypeLike + mb_conc (IfaceTyConAppCo _ tc _) = Just tc + mb_conc _ = Nothing + +ppr_co _ (IfaceTyConAppCo r tc cos) + = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r +ppr_co ctxt_prec (IfaceAppCo co1 co2) + = maybeParen ctxt_prec appPrec $ + ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 +ppr_co ctxt_prec co@(IfaceForAllCo {}) + = maybeParen ctxt_prec funPrec $ + -- FIXME: collect and pretty-print visibility info? + pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co) + where + (tvs, inner_co) = split_co co + + split_co (IfaceForAllCo (IfaceTvBndr (name, _)) visL visR kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'') + split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) visL visR kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'') + split_co co' = ([], co') + +-- Why these three? See Note [Free TyVars and CoVars in IfaceType] +ppr_co _ (IfaceFreeCoVar covar) = ppr covar +ppr_co _ (IfaceCoVarCo covar) = ppr covar +ppr_co _ (IfaceHoleCo covar) = braces (ppr covar) + +ppr_co _ (IfaceUnivCo prov role ty1 ty2 ds) + = text "Univ" <> (parens $ + sep [ ppr role <+> ppr prov <> ppr ds + , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ]) + +ppr_co ctxt_prec (IfaceInstCo co ty) + = maybeParen ctxt_prec appPrec $ + text "Inst" <+> sep [ pprParendIfaceCoercion co + , pprParendIfaceCoercion ty ] + +ppr_co ctxt_prec (IfaceAxiomCo ax cos) + | null cos = pprIfAxRule ax -- Don't add parens + | otherwise = ppr_special_co ctxt_prec (pprIfAxRule ax) cos +ppr_co ctxt_prec (IfaceSymCo co) + = ppr_special_co ctxt_prec (text "Sym") [co] +ppr_co ctxt_prec (IfaceTransCo co1 co2) + -- chain nested TransCo + = let ppr_trans (IfaceTransCo c1 c2) = semi <+> ppr_co topPrec c1 : ppr_trans c2 + ppr_trans c = [semi <+> ppr_co opPrec c] + in maybeParen ctxt_prec opPrec $ + vcat (ppr_co topPrec co1 : ppr_trans co2) +ppr_co ctxt_prec (IfaceSelCo d co) + = ppr_special_co ctxt_prec (text "SelCo:" <> ppr d) [co] +ppr_co ctxt_prec (IfaceLRCo lr co) + = ppr_special_co ctxt_prec (ppr lr) [co] +ppr_co ctxt_prec (IfaceSubCo co) + = ppr_special_co ctxt_prec (text "Sub") [co] +ppr_co ctxt_prec (IfaceKindCo co) + = ppr_special_co ctxt_prec (text "Kind") [co] + +ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc +ppr_special_co ctxt_prec doc cos + = maybeParen ctxt_prec appPrec + (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) + +pprIfAxRule :: IfaceAxiomRule -> SDoc +pprIfAxRule (IfaceAR_X n) = ppr n +pprIfAxRule (IfaceAR_U n) = ppr n +pprIfAxRule (IfaceAR_B n i) = ppr n <> brackets (int i) + +ppr_role :: Role -> SDoc +ppr_role r = underscore <> pp_role + where pp_role = case r of + Nominal -> char 'N' + Representational -> char 'R' + Phantom -> char 'P' + +------------------- +instance Outputable IfLclName where + ppr = ppr . ifLclNameFS + +instance Outputable IfaceTyCon where + ppr = pprIfaceTyCon + +-- | Print an `IfaceTyCon` with a promotion tick if needed, without parens, +-- suitable for use in infix contexts +pprIfaceTyCon :: IfaceTyCon -> SDoc +pprIfaceTyCon tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) + +-- | Print an `IfaceTyCon` with a promotion tick if needed, possibly with parens, +-- suitable for use in prefix contexts +pprParendIfaceTyCon :: IfaceTyCon -> SDoc +pprParendIfaceTyCon tc = pprPromotionQuote tc <> pprPrefixVar (isSymOcc (nameOccName tc_name)) (ppr tc_name) + where tc_name = ifaceTyConName tc + +instance Outputable IfaceTyConInfo where + ppr (IfaceTyConInfo { ifaceTyConIsPromoted = prom + , ifaceTyConSort = sort }) + = angleBrackets $ ppr prom <> comma <+> ppr sort + +pprPromotionQuote :: IfaceTyCon -> SDoc +pprPromotionQuote tc = + getPprStyle $ \sty -> + let + name = getOccName (ifaceTyConName tc) + ticked = + case ifaceTyConIsPromoted (ifaceTyConInfo tc) of + NotPromoted -> False + IsPromoted -> promTick sty (PromotedItemDataCon name) + in + if ticked + then char '\'' + else empty + +pprPromotionQuoteI :: PromotionFlag -> SDoc +pprPromotionQuoteI NotPromoted = empty +pprPromotionQuoteI IsPromoted = char '\'' + +instance Outputable IfaceCoercion where + ppr = pprIfaceCoercion + +instance Binary IfaceTyCon where + put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i + + get bh = do + n <- get bh + i <- get bh + return (IfaceTyCon n i) + +instance Binary IfaceTyConSort where + put_ bh IfaceNormalTyCon = putByte bh 0 + put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort + put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity + put_ bh IfaceEqualityTyCon = putByte bh 3 + + get bh = do + n <- getByte bh + case n of + 0 -> return IfaceNormalTyCon + 1 -> IfaceTupleTyCon <$> get bh <*> get bh + 2 -> IfaceSumTyCon <$> get bh + _ -> return IfaceEqualityTyCon + +instance Binary IfaceTyConInfo where + put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s + + get bh = mkIfaceTyConInfo <$!> get bh <*> get bh + -- We want to make sure, when reading from disk, as the most common case + -- is supposed to be shared. Any thunk adds an additional indirection + -- making sharing less useful. + -- + -- See !12200 for how this bang and the one in 'IfaceTyCon' reduces the + -- residency by ~10% when loading 'mi_extra_decls' from disk. + +instance Outputable IfaceTyLit where + ppr = pprIfaceTyLit + +instance Binary IfaceTyLit where + put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n + put_ bh (IfaceCharTyLit n) = putByte bh 3 >> put_ bh n + + get bh = + do tag <- getByte bh + case tag of + 1 -> do { n <- get bh + ; return (IfaceNumTyLit n) } + 2 -> do { n <- get bh + ; return (IfaceStrTyLit n) } + 3 -> do { n <- get bh + ; return (IfaceCharTyLit n) } + _ -> panic ("get IfaceTyLit " ++ show tag) + +instance Binary IfaceAppArgs where + put_ bh tk = do + -- Int is variable length encoded so only + -- one byte for small lists. + put_ bh (ifaceAppArgsLength tk) + go tk + where + go IA_Nil = pure () + go (IA_Arg a b t) = do + put_ bh a + put_ bh b + go t + + get bh = do + n <- get bh :: IO Int + go n + where + go 0 = return IA_Nil + go c = do + a <- get bh + b <- get bh + IA_Arg a b <$> go (c - 1) + +------------------- + +-- Some notes about printing contexts +-- +-- In the event that we are printing a singleton context (e.g. @Eq a@) we can +-- omit parentheses. However, we must take care to set the precedence correctly +-- to opPrec, since something like @a :~: b@ must be parenthesized (see +-- #9658). +-- +-- When printing a larger context we use 'fsep' instead of 'sep' so that +-- the context doesn't get displayed as a giant column. Rather than, +-- instance (Eq a, +-- Eq b, +-- Eq c, +-- Eq d, +-- Eq e, +-- Eq f, +-- Eq g, +-- Eq h, +-- Eq i, +-- Eq j, +-- Eq k, +-- Eq l) => +-- Eq (a, b, c, d, e, f, g, h, i, j, k, l) +-- +-- we want +-- +-- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, +-- Eq j, Eq k, Eq l) => +-- Eq (a, b, c, d, e, f, g, h, i, j, k, l) + + + +-- | Prints "(C a, D b) =>", including the arrow. +-- Used when we want to print a context in a type, so we +-- use 'funPrec' to decide whether to parenthesise a singleton +-- predicate; e.g. Num a => a -> a +pprIfaceContextArr :: [IfacePredType] -> SDoc +pprIfaceContextArr [] = empty +pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow +pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow + +-- | Prints a context or @()@ if empty +-- You give it the context precedence +pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc +pprIfaceContext _ [] = text "()" +pprIfaceContext prec [pred] = ppr_ty prec pred +pprIfaceContext _ preds = ppr_parend_preds preds + +ppr_parend_preds :: [IfacePredType] -> SDoc +ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds))) + +instance Binary IfaceType where + put_ bh ty = + case findUserDataWriter Proxy bh of + tbl -> putEntry tbl bh ty + + get bh = getIfaceTypeShared bh + +-- | This is the byte tag we expect to read when the next +-- value is not an 'IfaceType' value, but an offset into a +-- lookup table. +-- See Note [Deduplication during iface binary serialisation]. +-- +-- Must not overlap with any byte tag in 'getIfaceType'. +ifaceTypeSharedByte :: Word8 +ifaceTypeSharedByte = 99 + +-- | Like 'getIfaceType' but checks for a specific byte tag +-- that indicates that we won't be able to read a 'IfaceType' value +-- but rather an offset into a lookup table. Consequentially, +-- we look up the value for the 'IfaceType' in the look up table. +-- +-- See Note [Deduplication during iface binary serialisation] +-- for details. +getIfaceTypeShared :: ReadBinHandle -> IO IfaceType +getIfaceTypeShared bh = do + start <- tellBinReader bh + tag <- getByte bh + if ifaceTypeSharedByte == tag + then case findUserDataReader Proxy bh of + tbl -> getEntry tbl bh + else seekBinReader bh start >> getIfaceType bh + +-- | Serialises an 'IfaceType' to the given 'WriteBinHandle'. +-- +-- Serialising inner 'IfaceType''s uses the 'Binary.put' of 'IfaceType' which may be using +-- a deduplication table. See Note [Deduplication during iface binary serialisation]. +putIfaceType :: WriteBinHandle -> IfaceType -> IO () +putIfaceType _ (IfaceFreeTyVar tv) + = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv) + -- See Note [Free TyVars and CoVars in IfaceType] + +putIfaceType bh (IfaceForAllTy aa ab) = do + putByte bh 0 + put_ bh aa + put_ bh ab +putIfaceType bh (IfaceTyVar ad) = do + putByte bh 1 + put_ bh ad +putIfaceType bh (IfaceAppTy ae af) = do + putByte bh 2 + put_ bh ae + put_ bh af +putIfaceType bh (IfaceFunTy af aw ag ah) = do + putByte bh 3 + put_ bh af + put_ bh aw + put_ bh ag + put_ bh ah +putIfaceType bh (IfaceTyConApp tc tys) + = do { putByte bh 5; put_ bh tc; put_ bh tys } +putIfaceType bh (IfaceCastTy a b) + = do { putByte bh 6; put_ bh a; put_ bh b } +putIfaceType bh (IfaceCoercionTy a) + = do { putByte bh 7; put_ bh a } +putIfaceType bh (IfaceTupleTy s i tys) + = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } +putIfaceType bh (IfaceLitTy n) + = do { putByte bh 9; put_ bh n } + +-- | Deserialises an 'IfaceType' from the given 'ReadBinHandle'. +-- +-- Reading inner 'IfaceType''s uses the 'Binary.get' of 'IfaceType' which may be using +-- a deduplication table. See Note [Deduplication during iface binary serialisation]. +getIfaceType :: HasCallStack => ReadBinHandle -> IO IfaceType +getIfaceType bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + return (IfaceForAllTy aa ab) + 1 -> do ad <- get bh + return (IfaceTyVar ad) + 2 -> do ae <- get bh + af <- get bh + return (IfaceAppTy ae af) + 3 -> do af <- get bh + aw <- get bh + ag <- get bh + ah <- get bh + return (IfaceFunTy af aw ag ah) + 5 -> do { tc <- get bh; tys <- get bh + ; return (IfaceTyConApp tc tys) } + 6 -> do { a <- get bh; b <- get bh + ; return (IfaceCastTy a b) } + 7 -> do { a <- get bh + ; return (IfaceCoercionTy a) } + + 8 -> do { s <- get bh; i <- get bh; tys <- get bh + ; return (IfaceTupleTy s i tys) } + _ -> do n <- get bh + return (IfaceLitTy n) + +instance Binary IfLclName where + put_ bh = put_ bh . ifLclNameFS + + get bh = do + fs <- get bh + pure $ IfLclName $ LexicalFastString fs + +instance Binary IfaceMCoercion where + put_ bh IfaceMRefl = + putByte bh 1 + put_ bh (IfaceMCo co) = do + putByte bh 2 + put_ bh co + + get bh = do + tag <- getByte bh + case tag of + 1 -> return IfaceMRefl + 2 -> do a <- get bh + return $ IfaceMCo a + _ -> panic ("get IfaceMCoercion " ++ show tag) + +instance Binary IfaceCoercion where + put_ bh (IfaceReflCo a) = do + putByte bh 1 + put_ bh a + put_ bh (IfaceGReflCo a b c) = do + putByte bh 2 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceFunCo a w b c) = do + putByte bh 3 + put_ bh a + put_ bh w + put_ bh b + put_ bh c + put_ bh (IfaceTyConAppCo a b c) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceAppCo a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (IfaceForAllCo a visL visR b c) = do + putByte bh 6 + put_ bh a + put_ bh visL + put_ bh visR + put_ bh b + put_ bh c + put_ bh (IfaceCoVarCo a) = do + putByte bh 7 + put_ bh a + put_ bh (IfaceUnivCo a b c d deps) = do + putByte bh 9 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh deps + put_ bh (IfaceSymCo a) = do + putByte bh 10 + put_ bh a + put_ bh (IfaceTransCo a b) = do + putByte bh 11 + put_ bh a + put_ bh b + put_ bh (IfaceSelCo a b) = do + putByte bh 12 + put_ bh a + put_ bh b + put_ bh (IfaceLRCo a b) = do + putByte bh 13 + put_ bh a + put_ bh b + put_ bh (IfaceInstCo a b) = do + putByte bh 14 + put_ bh a + put_ bh b + put_ bh (IfaceKindCo a) = do + putByte bh 15 + put_ bh a + put_ bh (IfaceSubCo a) = do + putByte bh 16 + put_ bh a + put_ bh (IfaceAxiomCo a b) = do + putByte bh 17 + put_ bh a + put_ bh b + put_ _ (IfaceFreeCoVar cv) + = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) + -- See Note [Free TyVars and CoVars in IfaceType] + put_ _ (IfaceHoleCo cv) + = pprPanic "Can't serialise IfaceHoleCo" (ppr cv) + -- See Note [Holes in IfaceCoercion] + + get bh = do + tag <- getByte bh + case tag of + 1 -> do a <- get bh + return $ IfaceReflCo a + 2 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceGReflCo a b c + 3 -> do a <- get bh + w <- get bh + b <- get bh + c <- get bh + return $ IfaceFunCo a w b c + 4 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceTyConAppCo a b c + 5 -> do a <- get bh + b <- get bh + return $ IfaceAppCo a b + 6 -> do a <- get bh + visL <- get bh + visR <- get bh + b <- get bh + c <- get bh + return $ IfaceForAllCo a visL visR b c + 7 -> do a <- get bh + return $ IfaceCoVarCo a + 9 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + deps <- get bh + return $ IfaceUnivCo a b c d deps + 10-> do a <- get bh + return $ IfaceSymCo a + 11-> do a <- get bh + b <- get bh + return $ IfaceTransCo a b + 12-> do a <- get bh + b <- get bh + return $ IfaceSelCo a b + 13-> do a <- get bh + b <- get bh + return $ IfaceLRCo a b + 14-> do a <- get bh + b <- get bh + return $ IfaceInstCo a b + 15-> do a <- get bh + return $ IfaceKindCo a + 16-> do a <- get bh + return $ IfaceSubCo a + 17-> do a <- get bh + b <- get bh + return $ IfaceAxiomCo a b + _ -> panic ("get IfaceCoercion " ++ show tag) + +instance Binary IfaceAxiomRule where + put_ bh (IfaceAR_X n) = putByte bh 0 >> put_ bh n + put_ bh (IfaceAR_U n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceAR_B n i) = putByte bh 2 >> put_ bh n >> put_ bh i + + get bh = do h <- getByte bh + case h of + 0 -> do { n <- get bh; return (IfaceAR_X n) } + 1 -> do { n <- get bh; return (IfaceAR_U n) } + _ -> do { n <- get bh; i <- get bh; return (IfaceAR_B n i) } + +instance Binary (DefMethSpec IfaceType) where + put_ bh VanillaDM = putByte bh 0 + put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t + get bh = do + h <- getByte bh + case h of + 0 -> return VanillaDM + _ -> do { t <- get bh; return (GenericDM t) } + +instance NFData (DefMethSpec IfaceType) where + rnf = \case + VanillaDM -> () + GenericDM t -> rnf t + +instance NFData IfaceType where + rnf = \case + IfaceFreeTyVar f1 -> f1 `seq` () + IfaceTyVar f1 -> rnf f1 + IfaceLitTy f1 -> rnf f1 + IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2 + IfaceFunTy f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 + IfaceForAllTy f1 f2 -> rnf f1 `seq` rnf f2 + IfaceTyConApp f1 f2 -> rnf f1 `seq` rnf f2 + IfaceCastTy f1 f2 -> rnf f1 `seq` rnf f2 + IfaceCoercionTy f1 -> rnf f1 + IfaceTupleTy f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + +instance NFData IfaceTyLit where + rnf = \case + IfaceNumTyLit f1 -> rnf f1 + IfaceStrTyLit f1 -> rnf f1 + IfaceCharTyLit f1 -> rnf f1 + +instance NFData IfaceCoercion where + rnf = \case + IfaceReflCo f1 -> rnf f1 + IfaceGReflCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfaceFunCo f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 + IfaceTyConAppCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceForAllCo f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 + IfaceCoVarCo f1 -> rnf f1 + IfaceAxiomCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceUnivCo f1 f2 f3 f4 deps -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf deps + IfaceSymCo f1 -> rnf f1 + IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceSelCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceLRCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceKindCo f1 -> rnf f1 + IfaceSubCo f1 -> rnf f1 + -- These are not deeply forced because they are not used in ModIface, + -- these constructors are for pretty-printing. + -- See Note [Free TyVars and CoVars in IfaceType] + -- See Note [Holes in IfaceCoercion] + IfaceFreeCoVar f1 -> f1 `seq` () + IfaceHoleCo f1 -> f1 `seq` () + +instance NFData IfaceAxiomRule where + rnf = \case + IfaceAR_X n -> rnf n + IfaceAR_U n -> rnf n + IfaceAR_B n i -> rnf n `seq` rnf i + +instance NFData IfaceMCoercion where + rnf IfaceMRefl = () + rnf (IfaceMCo c) = rnf c + +instance NFData IfaceOneShot where + rnf IfaceOneShot = () + rnf IfaceNoOneShot = () + +instance NFData IfaceTyConSort where + rnf = \case + IfaceNormalTyCon -> () + IfaceTupleTyCon arity sort -> rnf arity `seq` rnf sort `seq` () + IfaceSumTyCon arity -> rnf arity + IfaceEqualityTyCon -> () + +instance NFData IfLclName where + rnf (IfLclName lfs) = rnf lfs + +instance NFData IfaceTyConInfo where + rnf (IfaceTyConInfo f s) = rnf f `seq` rnf s + +instance NFData IfaceTyCon where + rnf (IfaceTyCon nm info) = rnf nm `seq` rnf info + +instance NFData IfaceBndr where + rnf = \case + IfaceIdBndr id_bndr -> rnf id_bndr + IfaceTvBndr tv_bndr -> rnf tv_bndr + +instance NFData IfaceAppArgs where + rnf = \case + IA_Nil -> () + IA_Arg f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 diff --git a/GHC/Iface/Type.hs-boot b/GHC/Iface/Type.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Iface/Type.hs-boot @@ -0,0 +1,19 @@ +module GHC.Iface.Type + ( IfaceType, IfaceTyCon, IfaceBndr + , IfaceCoercion, IfaceTyLit, IfaceAppArgs + , ShowSub + ) +where + +-- Empty import to influence the compilation ordering. +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + +data IfaceAppArgs + +data IfaceType +data IfaceTyCon +data IfaceTyLit +data IfaceCoercion +data IfaceBndr +data ShowSub diff --git a/GHC/Iface/Warnings.hs b/GHC/Iface/Warnings.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Warnings.hs @@ -0,0 +1,34 @@ +module GHC.Iface.Warnings + ( toIfaceWarnings + , toIfaceWarningTxt + ) +where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Iface.Syntax + +import GHC.Types.SourceText +import GHC.Types.SrcLoc ( unLoc ) + +import GHC.Unit.Module.Warnings + +toIfaceWarnings :: Warnings GhcRn -> IfaceWarnings +toIfaceWarnings (WarnAll txt) = IfWarnAll (toIfaceWarningTxt txt) +toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds' + where + vs' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- vs] + ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds] + +toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt +toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc . iwc_wc . unLoc <$> mb_cat) src (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) + +toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName]) +toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names) + +toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral +toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs + diff --git a/GHC/IfaceToCore.hs b/GHC/IfaceToCore.hs new file mode 100644 --- /dev/null +++ b/GHC/IfaceToCore.hs @@ -0,0 +1,2297 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Type checking of type signatures in interface files +-} + + +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# LANGUAGE RecursiveDo #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} + +module GHC.IfaceToCore ( + tcLookupImported_maybe, + importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, + typecheckWholeCoreBindings, + tcIfaceDefaults, + typecheckIfacesForMerging, + typecheckIfaceForInstantiate, + tcIfaceDecl, tcIfaceDecls, + tcIfaceInst, tcIfaceFamInst, tcIfaceRules, + tcIfaceAnnotations, tcIfaceCompleteMatches, + tcIfaceExpr, -- Desired by HERMIT (#7683) + tcIfaceGlobal, + tcIfaceOneShot, tcTopIfaceBindings, + tcIfaceImport, + hydrateCgBreakInfo + ) where + + +import GHC.Prelude + +import GHC.ByteCode.Types + +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Config.Core.Lint ( initLintConfig ) + +import GHC.Builtin.Types.Literals(typeNatCoAxiomRules) +import GHC.Builtin.Types + +import GHC.Iface.Syntax +import GHC.Iface.Load +import GHC.Iface.Env + +import GHC.StgToCmm.Types +import GHC.Runtime.Heap.Layout + +import GHC.Tc.Errors.Types +import GHC.Tc.TyCl.Build +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Env + +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import GHC.Core.FVs +import GHC.Core.TyCo.Rep -- needs to build types & coercions in a knot +import GHC.Core.TyCo.Subst ( substTyCoVars ) +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Core +import GHC.Core.RoughMap( RoughMatchTc(..) ) +import GHC.Core.Utils +import GHC.Core.Unfold( calcUnfoldingGuidance ) +import GHC.Core.Unfold.Make +import GHC.Core.Lint +import GHC.Core.Make +import GHC.Core.Class +import GHC.Core.Predicate( isUnaryClass ) +import GHC.Core.TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.Ppr + +import GHC.Unit.External +import GHC.Unit.Module +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Unit.Home.ModInfo +import qualified GHC.Unit.Home.Graph as HUG + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Logger + +import GHC.Data.Bag +import GHC.Data.Maybe +import GHC.Data.FastString +import GHC.Data.List.SetOps + +import GHC.Types.Annotations +import GHC.Types.SourceFile +import GHC.Types.SourceText +import GHC.Types.Basic hiding ( SuccessFlag(..) ) +import GHC.Types.CompleteMatch +import GHC.Types.SrcLoc +import GHC.Types.Avail +import GHC.Types.TypeEnv +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet ( mkUniqDSet ) +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) +import GHC.Types.Unique.Supply +import GHC.Types.Demand( isDeadEndSig ) +import GHC.Types.Literal +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.DefaultEnv ( ClassDefaults(..), DefaultEnv, mkDefaultEnv, DefaultProvenance(..) ) +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Id.Info +import GHC.Types.Tickish +import GHC.Types.TyThing +import GHC.Types.Error + +import GHC.Parser.Annotation (noLocA) + +import GHC.Hs.Extension ( GhcRn ) + +import GHC.Fingerprint + +import Control.Monad +import GHC.Driver.Env.KnotVars +import GHC.Unit.Module.WholeCoreBindings +import Data.IORef +import Data.Foldable +import Data.List(nub) +import GHC.Builtin.Names (ioTyConName, rOOT_MAIN) +import GHC.Iface.Errors.Types + +import Language.Haskell.Syntax.BooleanFormula (BooleanFormula) +import Language.Haskell.Syntax.BooleanFormula qualified as BF(BooleanFormula(..)) +import Language.Haskell.Syntax.Extension (NoExtField (NoExtField)) + +{- +This module takes + + IfaceDecl -> TyThing + IfaceType -> Type + etc + +An IfaceDecl is populated with RdrNames, and these are not renamed to +Names before typechecking, because there should be no scope errors etc. + + -- For (b) consider: f = \$(...h....) + -- where h is imported, and calls f via an hi-boot file. + -- This is bad! But it is not seen as a staging error, because h + -- is indeed imported. We don't want the type-checker to black-hole + -- when simplifying and compiling the splice! + -- + -- Simple solution: discard any unfolding that mentions a variable + -- bound in this module (and hence not yet processed). + -- The discarding happens when forkM finds a type error. + + +************************************************************************ +* * + Type-checking a complete interface +* * +************************************************************************ + +Suppose we discover we don't need to recompile. Then we must type +check the old interface file. This is a bit different to the +incremental type checking we do as we suck in interface files. Instead +we do things similarly as when we are typechecking source decls: we +bring into scope the type envt for the interface all at once, using a +knot. Remember, the decls aren't necessarily in dependency order -- +and even if they were, the type decls might be mutually recursive. + +Note [Knot-tying typecheckIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are typechecking an interface A.hi, and we come across +a Name for another entity defined in A.hi. How do we get the +'TyCon', in this case? There are three cases: + + 1) tcHiBootIface in GHC.IfaceToCore: We're typechecking an + hi-boot file in preparation of checking if the hs file we're + building is compatible. In this case, we want all of the + internal TyCons to MATCH the ones that we just constructed + during typechecking: the knot is thus tied through if_rec_types. + + 2) rehydrate in GHC.Driver.Make: We are rehydrating a + mutually recursive cluster of hi files, in order to ensure + that all of the references refer to each other correctly. + In this case, the knot is tied through the HPT passed in, + which contains all of the interfaces we are in the process + of typechecking. + + 3) genModDetails in GHC.Driver.Main: We are typechecking an + old interface to generate the ModDetails. In this case, + we do the same thing as (2) and pass in an HPT with + the HomeModInfo being generated to tie knots. + +The upshot is that the CLIENT of this function is responsible +for making sure that the knot is tied correctly. If you don't, +then you'll get a message saying that we couldn't load the +declaration you wanted. + +BTW, in one-shot mode we never call typecheckIface; instead, +loadInterface handles type-checking interface. In that case, +knots are tied through the EPS. No problem! +-} + +-- Clients of this function be careful, see Note [Knot-tying typecheckIface] +typecheckIface :: ModIface -- Get the decls from here + -> IfG ModDetails +typecheckIface iface + | let iface_mod = mi_semantic_module iface + = initIfaceLcl iface_mod (text "typecheckIface") (mi_boot iface) $ do + { -- Get the right set of decls and rules. If we are compiling without -O + -- we discard pragmas before typechecking, so that we don't "see" + -- information that we shouldn't. From a versioning point of view + -- It's not actually *wrong* to do so, but in fact GHCi is unable + -- to handle unboxed tuples, so it must not see unfoldings. + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + + -- Typecheck the decls. This is done lazily, so that the knot-tying + -- within this single module works out right. It's the callers + -- job to make sure the knot is tied. + ; names_w_things <- tcIfaceDecls ignore_prags (mi_decls iface) + ; let type_env = mkNameEnv names_w_things + + -- Now do those rules, instances and annotations + ; defaults <- tcIfaceDefaults iface_mod (mi_defaults iface) + ; insts <- mapM tcIfaceInst (mi_insts iface) + ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; anns <- tcIfaceAnnotations (mi_anns iface) + + -- Exports + ; exports <- ifaceExportNames (mi_exports iface) + + -- Complete Sigs + ; complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) + + -- Finished + ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface), + -- Careful! If we tug on the TyThing thunks too early + -- we'll infinite loop with hs-boot. See #10083 for + -- an example where this would cause non-termination. + text "Type envt:" <+> ppr (map fst names_w_things)]) + ; return $ ModDetails { md_types = type_env + , md_defaults = defaults + , md_insts = mkInstEnv insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_exports = exports + , md_complete_matches = complete_matches + } + } + +typecheckWholeCoreBindings :: IORef TypeEnv -> WholeCoreBindings -> IfG [CoreBind] +typecheckWholeCoreBindings type_var WholeCoreBindings {wcb_bindings, wcb_module} = + initIfaceLcl wcb_module (text "typecheckWholeCoreBindings") NotBoot $ do + tcTopIfaceBindings type_var wcb_bindings + + +{- +************************************************************************ +* * + Typechecking for merging +* * +************************************************************************ +-} + +-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type) +isAbstractIfaceDecl :: IfaceDecl -> Bool +isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon {} } = True +isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True +isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True +isAbstractIfaceDecl _ = False + +ifMaybeRoles :: IfaceDecl -> Maybe [Role] +ifMaybeRoles IfaceData { ifRoles = rs } = Just rs +ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs +ifMaybeRoles IfaceClass { ifRoles = rs } = Just rs +ifMaybeRoles _ = Nothing + +-- | Merge two 'IfaceDecl's together, preferring a non-abstract one. If +-- both are non-abstract we pick one arbitrarily (and check for consistency +-- later.) +mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl +mergeIfaceDecl d1 d2 + | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1 + | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2 + | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1 + , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2 + = let ops = nonDetNameEnvElts $ + plusNameEnv_C mergeIfaceClassOp + (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ]) + (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ]) + + in d1 { ifBody = (ifBody d1) { + ifSigs = ops, + ifMinDef = mkOr [ bf1, bf2] + } + } `withRolesFrom` d2 + -- It doesn't matter; we'll check for consistency later when + -- we merge, see 'mergeSignatures' + | otherwise = d1 `withRolesFrom` d2 + where + -- The reason we need to duplicate mkOr here, instead of + -- using BooleanFormula's mkOr and just doing the loop like: + -- `toIfaceBooleanFormula . mkOr . fromIfaceBooleanFormula` + -- is quite subtle. Say we have the following minimal pragma: + -- {-# MINIMAL f | g #-}. If we use fromIfaceBooleanFormula + -- first, we will end up doing + -- `nub [Var (mkUnboundName f), Var (mkUnboundName g)]`, + -- which might seem fine, but Name equallity is decided by + -- their Unique, which will be identical since mkUnboundName + -- just stuffs the mkUnboundKey unqiue into both. + -- So the result will be {-# MINIMAL f #-}, oopsie. + -- Duplication it is. + mkOr :: [IfaceBooleanFormula] -> IfaceBooleanFormula + mkOr = maybe (IfAnd []) (mkOr' . nub . concat) . mapM fromOr + where + -- See Note [Simplification of BooleanFormulas] + fromOr bf = case bf of + (IfOr xs) -> Just xs + (IfAnd []) -> Nothing + _ -> Just [bf] + mkOr' [x] = x + mkOr' xs = IfOr xs + +-- Note [Role merging] +-- ~~~~~~~~~~~~~~~~~~~ +-- First, why might it be necessary to do a non-trivial role +-- merge? It may rescue a merge that might otherwise fail: +-- +-- signature A where +-- type role T nominal representational +-- data T a b +-- +-- signature A where +-- type role T representational nominal +-- data T a b +-- +-- A module that defines T as representational in both arguments +-- would successfully fill both signatures, so it would be better +-- if we merged the roles of these types in some nontrivial +-- way. +-- +-- However, we have to be very careful about how we go about +-- doing this, because role subtyping is *conditional* on +-- the supertype being NOT representationally injective, e.g., +-- if we have instead: +-- +-- signature A where +-- type role T nominal representational +-- data T a b = T a b +-- +-- signature A where +-- type role T representational nominal +-- data T a b = T a b +-- +-- Should we merge the definitions of T so that the roles are R/R (or N/N)? +-- Absolutely not: neither resulting type is a subtype of the original +-- types (see Note [Role subtyping]), because data is not representationally +-- injective. +-- +-- Thus, merging only occurs when BOTH TyCons in question are +-- representationally injective. If they're not, no merge. + +withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl +d1 `withRolesFrom` d2 + | Just roles1 <- ifMaybeRoles d1 + , Just roles2 <- ifMaybeRoles d2 + , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2) + = d1 { ifRoles = mergeRoles roles1 roles2 } + | otherwise = d1 + where + mergeRoles roles1 roles2 = zipWithEqual max roles1 roles2 + +isRepInjectiveIfaceDecl :: IfaceDecl -> Bool +isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon{} } = True +isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True +isRepInjectiveIfaceDecl _ = False + +mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp +mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1 +mergeIfaceClassOp _ op2 = op2 + +-- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'. +mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl +mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl + +-- | This is a very interesting function. Like typecheckIface, we want +-- to type check an interface file into a ModDetails. However, the use-case +-- for these ModDetails is different: we want to compare all of the +-- ModDetails to ensure they define compatible declarations, and then +-- merge them together. So in particular, we have to take a different +-- strategy for knot-tying: we first speculatively merge the declarations +-- to get the "base" truth for what we believe the types will be +-- (this is "type computation.") Then we read everything in relative +-- to this truth and check for compatibility. +-- +-- During the merge process, we may need to nondeterministically +-- pick a particular declaration to use, if multiple signatures define +-- the declaration ('mergeIfaceDecl'). If, for all choices, there +-- are no type synonym cycles in the resulting merged graph, then +-- we can show that our choice cannot matter. Consider the +-- set of entities which the declarations depend on: by assumption +-- of acyclicity, we can assume that these have already been shown to be equal +-- to each other (otherwise merging will fail). Then it must +-- be the case that all candidate declarations here are type-equal +-- (the choice doesn't matter) or there is an inequality (in which +-- case merging will fail.) +-- +-- Unfortunately, the choice can matter if there is a cycle. Consider the +-- following merge: +-- +-- signature H where { type A = C; type B = A; data C } +-- signature H where { type A = (); data B; type C = B } +-- +-- If we pick @type A = C@ as our representative, there will be +-- a cycle and merging will fail. But if we pick @type A = ()@ as +-- our representative, no cycle occurs, and we instead conclude +-- that all of the types are unit. So it seems that we either +-- (a) need a stronger acyclicity check which considers *all* +-- possible choices from a merge, or (b) we must find a selection +-- of declarations which is acyclic, and show that this is always +-- the "best" choice we could have made (ezyang conjectures this +-- is the case but does not have a proof). For now this is +-- not implemented. +-- +-- It's worth noting that at the moment, a data constructor and a +-- type synonym are never compatible. Consider: +-- +-- signature H where { type Int=C; type B = Int; data C = Int} +-- signature H where { export Prelude.Int; data B; type C = B; } +-- +-- This will be rejected, because the reexported Int in the second +-- signature (a proper data type) is never considered equal to a +-- type synonym. Perhaps this should be relaxed, where a type synonym +-- in a signature is considered implemented by a data type declaration +-- which matches the reference of the type synonym. +typecheckIfacesForMerging :: Module -> [ModIface] -> (KnotVars (IORef TypeEnv)) -> IfM lcl (TypeEnv, [ModDetails]) +typecheckIfacesForMerging mod ifaces tc_env_vars = + -- cannot be boot (False) + initIfaceLcl mod (text "typecheckIfacesForMerging") NotBoot $ do + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + -- Build the initial environment + -- NB: Don't include dfuns here, because we don't want to + -- serialize them out. See Note [rnIfaceNeverExported] in GHC.Iface.Rename + -- NB: But coercions are OK, because they will have the right OccName. + let mk_decl_env decls + = mkOccEnv [ (getOccName decl, decl) + | decl <- decls + , case decl of + IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns + _ -> True ] + decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces + :: [OccEnv IfaceDecl] + decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs + :: OccEnv IfaceDecl + -- TODO: change tcIfaceDecls to accept w/o Fingerprint + names_w_things <- tcIfaceDecls ignore_prags (map (\x -> (fingerprint0, x)) + (nonDetOccEnvElts decl_env)) + let global_type_env = mkNameEnv names_w_things + case lookupKnotVars tc_env_vars mod of + Just tc_env_var -> writeMutVar tc_env_var global_type_env + Nothing -> return () + + -- OK, now typecheck each ModIface using this environment + details <- forM ifaces $ \iface -> do + -- See Note [Resolving never-exported Names] in GHC.IfaceToCore + type_env <- fixM $ \type_env -> + setImplicitEnvM type_env $ do + decls <- tcIfaceDecls ignore_prags (mi_decls iface) + return (mkNameEnv decls) + -- But note that we use this type_env to typecheck references to DFun + -- in 'IfaceInst' + setImplicitEnvM type_env $ do + defaults <- tcIfaceDefaults (mi_semantic_module iface) (mi_defaults iface) + insts <- mapM tcIfaceInst (mi_insts iface) + fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + rules <- tcIfaceRules ignore_prags (mi_rules iface) + anns <- tcIfaceAnnotations (mi_anns iface) + exports <- ifaceExportNames (mi_exports iface) + complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) + return $ ModDetails { md_types = type_env + , md_defaults = defaults + , md_insts = mkInstEnv insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_exports = exports + , md_complete_matches = complete_matches + } + return (global_type_env, details) + +-- | Typecheck a signature 'ModIface' under the assumption that we have +-- instantiated it under some implementation (recorded in 'mi_semantic_module') +-- and want to check if the implementation fills the signature. +-- +-- This needs to operate slightly differently than 'typecheckIface' +-- because (1) we have a 'NameShape', from the exports of the +-- implementing module, which we will use to give our top-level +-- declarations the correct 'Name's even when the implementor +-- provided them with a reexport, and (2) we have to deal with +-- DFun silliness (see Note [rnIfaceNeverExported]) +typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails +typecheckIfaceForInstantiate nsubst iface + | let iface_mod = mi_semantic_module iface + = initIfaceLclWithSubst iface_mod + (text "typecheckIfaceForInstantiate") + (mi_boot iface) nsubst $ do + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + -- See Note [Resolving never-exported Names] in GHC.IfaceToCore + type_env <- fixM $ \type_env -> + setImplicitEnvM type_env $ do + decls <- tcIfaceDecls ignore_prags (mi_decls iface) + return (mkNameEnv decls) + -- See Note [rnIfaceNeverExported] + setImplicitEnvM type_env $ do + defaults <- tcIfaceDefaults iface_mod (mi_defaults iface) + insts <- mapM tcIfaceInst (mi_insts iface) + fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + rules <- tcIfaceRules ignore_prags (mi_rules iface) + anns <- tcIfaceAnnotations (mi_anns iface) + exports <- ifaceExportNames (mi_exports iface) + complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) + return $ ModDetails { md_types = type_env + , md_defaults = defaults + , md_insts = mkInstEnv insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_exports = exports + , md_complete_matches = complete_matches + } + +-- Note [Resolving never-exported Names] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- For the high-level overview, see +-- Note [Handling never-exported TyThings under Backpack] +-- +-- As described in 'typecheckIfacesForMerging', the splendid innovation +-- of signature merging is to rewrite all Names in each of the signatures +-- we are merging together to a pre-merged structure; this is the key +-- ingredient that lets us solve some problems when merging type +-- synonyms. +-- +-- However, when a 'Name' refers to a NON-exported entity, as is the +-- case with the DFun of a ClsInst, or a CoAxiom of a type family, +-- this strategy causes problems: if we pick one and rewrite all +-- references to a shared 'Name', we will accidentally fail to check +-- if the DFun or CoAxioms are compatible, as they will never be +-- checked--only exported entities are checked for compatibility, +-- and a non-exported TyThing is checked WHEN we are checking the +-- ClsInst or type family for compatibility in checkBootDeclM. +-- By virtue of the fact that everything's been pointed to the merged +-- declaration, you'll never notice there's a difference even if there +-- is one. +-- +-- Fortunately, there are only a few places in the interface declarations +-- where this can occur, so we replace those calls with 'tcIfaceImplicit', +-- which will consult a local TypeEnv that records any never-exported +-- TyThings which we should wire up with. +-- +-- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a +-- type family can refer to a coercion axiom, all of which are done in one go +-- when we typecheck 'mi_decls'. An alternate strategy would be to typecheck +-- coercions first before type families, but that seemed more fragile. +-- + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ +-} + +tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo +-- Load the hi-boot iface for the module being compiled, +-- if it indeed exists in the transitive closure of imports +-- Return the ModDetails; Nothing if no hi-boot iface +tcHiBootIface hsc_src mod + | HsBootFile <- hsc_src -- Already compiling a hs-boot file + = return NoSelfBoot + | otherwise + = do { traceIf (text "loadHiBootInterface" <+> ppr mod) + + ; mode <- getGhcMode + ; if not (isOneShot mode) + -- In --make and interactive mode, if this module has an hs-boot file + -- we'll have compiled it already, and it'll be in the HPT + -- + -- We check whether the interface is a *boot* interface. + -- It can happen (when using GHC from Visual Studio) that we + -- compile a module in TypecheckOnly mode, with a stable, + -- fully-populated HPT. In that case the boot interface isn't there + -- (it's been replaced by the mother module) so we can't check it. + -- And that's fine, because if M's ModInfo is in the HPT, then + -- it's been compiled once, and we don't need to check the boot iface + then do { (_, hug) <- getEpsAndHug + ; liftIO $ + HUG.lookupHugByModule mod hug >>= pure . \case + Just info | mi_boot (hm_iface info) == IsBoot + -> SelfBoot { sb_mds = hm_details info } + _ -> NoSelfBoot } + else do + + -- OK, so we're in one-shot mode. + -- Re #9245, we always check if there is an hi-boot interface + -- to check consistency against, rather than just when we notice + -- that an hi-boot is necessary due to a circular import. + { hsc_env <- getTopEnv + ; read_result <- liftIO $ findAndReadIface hsc_env need + (fst (getModuleInstantiation mod)) mod + IsBoot -- Hi-boot file + + ; case read_result of { + Succeeded (iface, _path) -> + do { tc_iface <- initIfaceTcRn $ typecheckIface iface + ; return $ SelfBoot { sb_mds = tc_iface } } ; + Failed err -> + + -- There was no hi-boot file. But if there is circularity in + -- the module graph, there really should have been one. + -- Since we've read all the direct imports by now, + -- eps_is_boot will record if any of our imports mention the + -- current module, which either means a module loop (not + -- a SOURCE import) or that our hi-boot file has mysteriously + -- disappeared. + do { eps <- getEps + ; case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of + -- The typical case + Nothing -> return NoSelfBoot + -- error cases + Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of + IsBoot -> + let diag = Can'tFindInterface err + (LookingForHiBoot mod) + in failWithTc (TcRnInterfaceError diag) + -- The hi-boot file has mysteriously disappeared. + NotBoot -> failWithTc (TcRnInterfaceError (CircularImport mod)) + -- Someone below us imported us! + -- This is a loop with no hi-boot in the way + }}}} + where + need = text "Need the hi-boot interface for" <+> ppr mod + <+> text "to compare against the Real Thing" + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ + +When typechecking a data type decl, we *lazily* (via forkM) typecheck +the constructor argument types. This is in the hope that we may never +poke on those argument types, and hence may never need to load the +interface files for types mentioned in the arg types. + +E.g. + data Foo.S = MkS Baz.T +Maybe we can get away without even loading the interface for Baz! + +This is not just a performance thing. Suppose we have + data Foo.S = MkS Baz.T + data Baz.T = MkT Foo.S +(in different interface files, of course). +Now, first we load and typecheck Foo.S, and add it to the type envt. +If we do explore MkS's argument, we'll load and typecheck Baz.T. +If we explore MkT's argument we'll find Foo.S already in the envt. + +If we typechecked constructor args eagerly, when loading Foo.S we'd try to +typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S... +which isn't done yet. + +All very cunning. However, there is a rather subtle gotcha which bit +me when developing this stuff. When we typecheck the decl for S, we +extend the type envt with S, MkS, and all its implicit Ids. Suppose +(a bug, but it happened) that the list of implicit Ids depended in +turn on the constructor arg types. Then the following sequence of +events takes place: + * we build a thunk for the constructor arg tys + * we build a thunk for the extended type environment (depends on ) + * we write the extended type envt into the global EPS mutvar + +Now we look something up in the type envt + * that pulls on + * which reads the global type envt out of the global EPS mutvar + * but that depends in turn on + +It's subtle, because, it'd work fine if we typechecked the constructor args +eagerly -- they don't need the extended type envt. They just get the extended +type envt by accident, because they look at it later. + +What this means is that the implicitTyThings MUST NOT DEPEND on any of +the forkM stuff. +-} + +tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings + -> IfaceDecl + -> IfL TyThing +tcIfaceDecl = tc_iface_decl Nothing + +tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations + -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings + -> IfaceDecl + -> IfL TyThing +tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type, + ifIdDetails = details, ifIdInfo = info}) + = do { ty <- tcIfaceType iface_type + ; details <- tcIdDetails name ty details + ; info <- tcIdInfo ignore_prags TopLevel name ty info + ; return (AnId (mkGlobalId details name ty info)) } + +tc_iface_decl _ _ (IfaceData {ifName = tc_name, + ifCType = cType, + ifBinders = binders, + ifResKind = res_kind, + ifRoles = roles, + ifCtxt = ctxt, ifGadtSyntax = gadt_syn, + ifCons = rdr_cons, + ifParent = mb_parent }) + = bindIfaceTyConBinders_AT binders $ \ binders' -> do + { res_kind' <- tcIfaceType res_kind + + ; tycon <- fixM $ \ tycon -> do + { stupid_theta <- tcIfaceCtxt ctxt + ; parent' <- tc_parent tc_name mb_parent + ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons + ; return (mkAlgTyCon tc_name binders' res_kind' + roles cType stupid_theta + cons parent' gadt_syn) } + ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) + ; return (ATyCon tycon) } + where + tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav + tc_parent tc_name IfNoParent + = do { tc_rep_name <- newTyConRepName tc_name + ; return (VanillaAlgTyCon tc_rep_name) } + tc_parent _ (IfDataInstance ax_name _ arg_tys) + = do { ax <- tcIfaceUnbranchedAxiom ax_name + ; let fam_tc = coAxiomTyCon ax + ; lhs_tys <- tcIfaceAppArgs arg_tys + ; return (DataFamInstTyCon ax fam_tc lhs_tys) } + +tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name, + ifRoles = roles, + ifSynRhs = rhs_ty, + ifBinders = binders, + ifResKind = res_kind }) + = bindIfaceTyConBinders_AT binders $ \ binders' -> do + { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] + ; rhs <- forkM (mk_doc tc_name) $ + tcIfaceType rhs_ty + ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs + ; return (ATyCon tycon) } + where + mk_doc n = text "Type synonym" <+> ppr n + +tc_iface_decl parent _ (IfaceFamily {ifName = tc_name, + ifFamFlav = fam_flav, + ifBinders = binders, + ifResKind = res_kind, + ifResVar = res, ifFamInj = inj }) + = bindIfaceTyConBinders_AT binders $ \ binders' -> do + { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] + ; rhs <- forkM (mk_doc tc_name) $ + tc_fam_flav tc_name fam_flav + ; res_name <- traverse (newIfaceName . mkTyVarOccFS . ifLclNameFS) res + ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj + ; return (ATyCon tycon) } + where + mk_doc n = text "Type synonym" <+> ppr n + + tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav + tc_fam_flav tc_name IfaceDataFamilyTyCon + = do { tc_rep_name <- newTyConRepName tc_name + ; return (DataFamilyTyCon tc_rep_name) } + tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon + tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches) + = do { ax <- traverse (tcIfaceBranchedAxiom . fst) mb_ax_name_branches + ; return (ClosedSynFamilyTyCon ax) } + tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon + = return AbstractClosedSynFamilyTyCon + tc_fam_flav _ IfaceBuiltInSynFamTyCon + = pprPanic "tc_iface_decl" + (text "IfaceBuiltInSynFamTyCon in interface file") + +tc_iface_decl _parent _ignore_prags + (IfaceClass {ifName = tc_name, + ifRoles = roles, + ifBinders = binders, + ifFDs = rdr_fds, + ifBody = IfAbstractClass}) + = bindIfaceTyConBinders binders $ \ binders' -> do + { fds <- mapM tc_fd rdr_fds + ; cls <- buildAbstractClass tc_name binders' roles fds + ; return (ATyCon (classTyCon cls)) } + +tc_iface_decl _parent ignore_prags + (IfaceClass {ifName = tc_name, + ifRoles = roles, + ifBinders = binders, + ifFDs = rdr_fds, + ifBody = IfConcreteClass { + ifClassCtxt = rdr_ctxt, + ifATs = rdr_ats, ifSigs = rdr_sigs, + ifMinDef = if_mindef, ifUnary = unary + }}) + = bindIfaceTyConBinders binders $ \ binders' -> do + { traceIf (text "tc-iface-class1" <+> ppr tc_name) + ; ctxt <- mapM tc_sc rdr_ctxt + ; traceIf (text "tc-iface-class2" <+> ppr tc_name) + ; sigs <- mapM tc_sig rdr_sigs + ; fds <- mapM tc_fd rdr_fds + ; traceIf (text "tc-iface-class3" <+> ppr tc_name) + ; mindef <- tc_boolean_formula if_mindef + ; cls <- fixM $ \ cls -> do + { ats <- mapM (tc_at cls) rdr_ats + ; traceIf (text "tc-iface-class4" <+> ppr tc_name) + ; buildClass tc_name binders' roles fds ctxt ats sigs mindef unary } + ; return (ATyCon (classTyCon cls)) } + where + tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) + -- The *length* of the superclasses is used by buildClass, and hence must + -- not be inside the thunk. But the *content* maybe recursive and hence + -- must be lazy (via forkM). Example: + -- class C (T a) => D a where + -- data T a + -- Here the associated type T is knot-tied with the class, and + -- so we must not pull on T too eagerly. See #5970 + + tc_sig :: IfaceClassOp -> IfL TcMethInfo + tc_sig (IfaceClassOp op_name rdr_ty dm) + = do { let doc = mk_op_doc op_name rdr_ty + ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty + -- Must be done lazily for just the same reason as the + -- type of a data con; to avoid sucking in types that + -- it mentions unless it's necessary to do so + ; dm' <- tc_dm doc dm + ; return (op_name, op_ty, dm') } + + tc_dm :: SDoc + -> Maybe (DefMethSpec IfaceType) + -> IfL (Maybe (DefMethSpec (SrcSpan, Type))) + tc_dm _ Nothing = return Nothing + tc_dm _ (Just VanillaDM) = return (Just VanillaDM) + tc_dm doc (Just (GenericDM ty)) + = do { -- Must be done lazily to avoid sucking in types + ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty + ; return (Just (GenericDM (noSrcSpan, ty'))) } + + tc_at cls (IfaceAT tc_decl if_def) + = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl + mb_def <- case if_def of + Nothing -> return Nothing + Just def -> forkM (mk_at_doc tc) $ + extendIfaceTyVarEnv (tyConTyVars tc) $ + do { tc_def <- tcIfaceType def + ; return (Just (tc_def, NoVI)) } + -- Must be done lazily in case the RHS of the defaults mention + -- the type constructor being defined here + -- e.g. type AT a; type AT b = AT [b] #8002 + return (ATI tc mb_def) + + tc_boolean_formula :: IfaceBooleanFormula -> IfL (BooleanFormula GhcRn) + tc_boolean_formula (IfAnd ibfs ) = BF.And . map noLocA <$> traverse tc_boolean_formula ibfs + tc_boolean_formula (IfOr ibfs ) = BF.Or . map noLocA <$> traverse tc_boolean_formula ibfs + tc_boolean_formula (IfParens ibf) = BF.Parens . noLocA <$> tc_boolean_formula ibf + tc_boolean_formula (IfVar nm ) = BF.Var . noLocA <$> (lookupIfaceTop . mkVarOccFS . ifLclNameFS $ nm) + + mk_sc_doc pred = text "Superclass" <+> ppr pred + mk_at_doc tc = text "Associated type" <+> ppr tc + mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty] + +tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc + , ifAxBranches = branches, ifRole = role }) + = do { tc_tycon <- tcIfaceTyCon tc + -- Must be done lazily, because axioms are forced when checking + -- for family instance consistency, and the RHS may mention + -- a hs-boot declared type constructor that is going to be + -- defined by this module. + -- e.g. type instance F Int = ToBeDefined + -- See #13803 + ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name) + $ tc_ax_branches branches + ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name + , co_ax_name = tc_name + , co_ax_tc = tc_tycon + , co_ax_role = role + , co_ax_branches = manyBranches tc_branches + , co_ax_implicit = False } + ; return (ACoAxiom axiom) } + +tc_iface_decl _ _ (IfacePatSyn{ ifName = name + , ifPatMatcher = if_matcher + , ifPatBuilder = if_builder + , ifPatIsInfix = is_infix + , ifPatUnivBndrs = univ_bndrs + , ifPatExBndrs = ex_bndrs + , ifPatProvCtxt = prov_ctxt + , ifPatReqCtxt = req_ctxt + , ifPatArgs = args + , ifPatTy = pat_ty + , ifFieldLabels = field_labels }) + = do { traceIf (text "tc_iface_decl" <+> ppr name) + ; matcher <- tc_pr if_matcher + ; builder <- traverse tc_pr if_builder + ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do + { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do + { patsyn <- forkM (mk_doc name) $ + do { prov_theta <- tcIfaceCtxt prov_ctxt + ; req_theta <- tcIfaceCtxt req_ctxt + ; pat_ty <- tcIfaceType pat_ty + ; arg_tys <- mapM tcIfaceType args + ; return $ buildPatSyn name is_infix matcher builder + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + arg_tys pat_ty field_labels } + ; return $ AConLike . PatSynCon $ patsyn }}} + where + mk_doc n = text "Pattern synonym" <+> ppr n + tc_pr :: (IfExtName, Bool) -> IfL (Name, Type, Bool) + tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) + ; return (nm, idType id, b) } + +tcTopIfaceBindings :: IORef TypeEnv -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] + -> IfL [CoreBind] +tcTopIfaceBindings ty_var ver_decls + = do + int <- mapM tcTopBinders ver_decls + let all_ids :: [Id] = concatMap toList int + liftIO $ modifyIORef ty_var (flip extendTypeEnvList (map AnId all_ids)) + + extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int + +tcTopBinders :: IfaceBindingX a IfaceTopBndrInfo -> IfL (IfaceBindingX a Id) +tcTopBinders = traverse mk_top_id + +tc_iface_bindings :: IfaceBindingX IfaceMaybeRhs Id -> IfL CoreBind +tc_iface_bindings (IfaceNonRec b rhs) = do + rhs' <- tc_iface_binding b rhs + return $ NonRec b rhs' +tc_iface_bindings (IfaceRec bs) = do + rs <- mapM (\(b, rhs) -> (b,) <$> tc_iface_binding b rhs) bs + return (Rec rs) + +-- | See Note [Interface File with Core: Sharing RHSs] +tc_iface_binding :: Id -> IfaceMaybeRhs -> IfL CoreExpr +tc_iface_binding i IfUseUnfoldingRhs = + case maybeUnfoldingTemplate $ realIdUnfolding i of + Just e -> return e + Nothing -> pprPanic "tc_iface_binding" (vcat [text "Binding" <+> quotes (ppr i) <+> text "had an unfolding when the interface file was created" + , text "which has now gone missing, something has badly gone wrong." + , text "Unfolding:" <+> ppr (realIdUnfolding i)]) + +tc_iface_binding _ (IfRhs rhs) = tcIfaceExpr rhs + +mk_top_id :: IfaceTopBndrInfo -> IfL Id +mk_top_id (IfGblTopBndr gbl_name) + -- See Note [Root-main Id] + -- This special binding is actually defined in the current module + -- (hence don't go looking for it externally) but the module name is rOOT_MAIN + -- rather than the current module so we need this special case. + -- See some similar logic in `GHC.Rename.Env`. + | Just rOOT_MAIN == nameModule_maybe gbl_name + = do + ATyCon ioTyCon <- tcIfaceGlobal ioTyConName + return $ mkExportedVanillaId gbl_name (mkTyConApp ioTyCon [unitTy]) + | otherwise = tcIfaceExtId gbl_name +mk_top_id (IfLclTopBndr raw_name iface_type info details) = do + ty <- tcIfaceType iface_type + rec { details' <- tcIdDetails name ty details + ; let occ = case details' of + RecSelId { sel_tycon = parent } + -> let con_fs = getOccFS $ recSelFirstConName parent + in mkRecFieldOccFS con_fs (ifLclNameFS raw_name) + _ -> mkVarOccFS (ifLclNameFS raw_name) + ; name <- newIfaceName occ } + info' <- tcIdInfo False TopLevel name ty info + let new_id = mkGlobalId details' name ty info' + return new_id + +tcIfaceDecls :: Bool + -> [(Fingerprint, IfaceDecl)] + -> IfL [(Name,TyThing)] +tcIfaceDecls ignore_prags ver_decls + = concatMapM (tc_iface_decl_fingerprint ignore_prags) ver_decls + +tc_iface_decl_fingerprint :: Bool -- Don't load pragmas into the decl pool + -> (Fingerprint, IfaceDecl) + -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the + -- TyThings are forkM'd thunks +tc_iface_decl_fingerprint ignore_prags (_version, decl) + = do { -- Populate the name cache with final versions of all + -- the names associated with the decl + let !main_name = ifName decl + -- Force this field access, as `main_name` thunk will otherwise + -- be retained in the thunk created by `forkM`. + + -- Typecheck the thing, lazily + -- NB. Firstly, the laziness is there in case we never need the + -- declaration (in one-shot mode), and secondly it is there so that + -- we don't look up the occurrence of a name before calling mk_new_bndr + -- on the binder. This is important because we must get the right name + -- which includes its nameParent. + + ; thing <- forkM doc $ do { bumpDeclStats main_name + ; tcIfaceDecl ignore_prags decl } + + -- Populate the type environment with the implicitTyThings too. + -- + -- Note [Tricky iface loop] + -- ~~~~~~~~~~~~~~~~~~~~~~~~ + -- Summary: The delicate point here is that 'mini-env' must be + -- buildable from 'thing' without demanding any of the things + -- 'forkM'd by tcIfaceDecl. + -- + -- In more detail: Consider the example + -- data T a = MkT { x :: T a } + -- The implicitTyThings of T are: [ , ] + -- (plus their workers, wrappers, coercions etc etc) + -- + -- We want to return an environment + -- [ "MkT" -> , "x" -> , ... ] + -- (where the "MkT" is the *Name* associated with MkT, etc.) + -- + -- We do this by mapping the implicit_names to the associated + -- TyThings. By the invariant on ifaceDeclImplicitBndrs and + -- implicitTyThings, we can use getOccName on the implicit + -- TyThings to make this association: each Name's OccName should + -- be the OccName of exactly one implicitTyThing. So the key is + -- to define a "mini-env" + -- + -- [ 'MkT' -> , 'x' -> , ... ] + -- where the 'MkT' here is the *OccName* associated with MkT. + -- + -- However, there is a subtlety: due to how type checking needs + -- to be staged, we can't poke on the forkM'd thunks inside the + -- implicitTyThings while building this mini-env. + -- If we poke these thunks too early, two problems could happen: + -- (1) When processing mutually recursive modules across + -- hs-boot boundaries, poking too early will do the + -- type-checking before the recursive knot has been tied, + -- so things will be type-checked in the wrong + -- environment, and necessary variables won't be in + -- scope. + -- + -- (2) Looking up one OccName in the mini_env will cause + -- others to be looked up, which might cause that + -- original one to be looked up again, and hence loop. + -- + -- The code below works because of the following invariant: + -- getOccName on a TyThing does not force the suspended type + -- checks in order to extract the name. For example, we don't + -- poke on the "T a" type of on the way to + -- extracting 's OccName. Of course, there is no + -- reason in principle why getting the OccName should force the + -- thunks, but this means we need to be careful in + -- implicitTyThings and its helper functions. + -- + -- All a bit too finely-balanced for my liking. + + -- This mini-env and lookup function mediates between the + --'Name's n and the map from 'OccName's to the implicit TyThings + ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] + lookup n = case lookupOccEnv mini_env (getOccName n) of + Just thing -> thing + Nothing -> + pprPanic "tc_iface_decl_fingerprint" (ppr main_name <+> ppr n $$ ppr (decl)) + + ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl) + +-- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names) + ; return $ (main_name, thing) : + -- uses the invariant that implicit_names and + -- implicitTyThings are bijective + [(n, lookup n) | n <- implicit_names] + } + where + doc = text "Declaration for" <+> ppr (ifName decl) + +bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used +bumpDeclStats name + = do { traceIf (text "Loading decl for" <+> ppr name) + ; updateEps_ (\eps -> let stats = eps_stats eps + in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } }) + } + +tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar) +tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 + ; tvs2' <- mapM tcIfaceTyVar tvs2 + ; return (tvs1', tvs2') } + +tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch] +tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches + +tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] +tc_ax_branch prev_branches + (IfaceAxBranch { ifaxbTyVars = tv_bndrs + , ifaxbEtaTyVars = eta_tv_bndrs + , ifaxbCoVars = cv_bndrs + , ifaxbLHS = lhs, ifaxbRHS = rhs + , ifaxbRoles = roles, ifaxbIncomps = incomps }) + = bindIfaceTyConBinders_AT + (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs -> + -- The _AT variant is needed here; see Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom + bindIfaceIds cv_bndrs $ \ cvs -> do + { tc_lhs <- tcIfaceAppArgs lhs + ; tc_rhs <- tcIfaceType rhs + ; eta_tvs <- bindIfaceTyVars eta_tv_bndrs return + ; this_mod <- getIfModule + ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS` + moduleNameFS (moduleName this_mod)) + br = CoAxBranch { cab_loc = loc + , cab_tvs = binderVars tvs + , cab_eta_tvs = eta_tvs + , cab_cvs = cvs + , cab_lhs = tc_lhs + , cab_roles = roles + , cab_rhs = tc_rhs + , cab_incomps = map (prev_branches `getNth`) incomps } + ; return (prev_branches ++ [br]) } + +tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs +tcIfaceDataCons tycon_name tycon tc_tybinders if_cons + = case if_cons of + IfAbstractTyCon + -> return AbstractTyCon + IfDataTyCon type_data cons + -> do { data_cons <- mapM tc_con_decl cons + ; return $ + mkLevPolyDataTyConRhs + (isFixedRuntimeRepKind $ tyConResKind tycon) + type_data + data_cons } + IfNewTyCon con + -> do { data_con <- tc_con_decl con + ; mkNewTyConRhs tycon_name tycon data_con } + where + univ_tvs :: [TyVar] + univ_tvs = binderVars tc_tybinders + + tag_map :: NameEnv ConTag + tag_map = mkTyConTagMap tycon + + tc_con_decl (IfCon { ifConInfix = is_infix, + ifConExTCvs = ex_bndrs, + ifConUserTvBinders = user_bndrs, + ifConName = dc_name, + ifConCtxt = ctxt, ifConEqSpec = spec, + ifConArgTys = args, ifConFields = lbl_names, + ifConStricts = if_stricts, + ifConSrcStricts = if_src_stricts}) + = -- Universally-quantified tyvars are shared with + -- parent TyCon, and are already in scope + bindIfaceBndrs ex_bndrs $ \ ex_tvs -> do + { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name) + + -- By this point, we have bound every universal and existential + -- tyvar. Because of the dcUserTyVarBinders invariant + -- (see Note [DataCon user type variable binders]), *every* tyvar in + -- ifConUserTvBinders has a matching counterpart somewhere in the + -- bound universals/existentials. As a result, calling tcIfaceTyVar + -- below is always guaranteed to succeed. + ; user_tv_bndrs <- mapM (\(Bndr bd vis) -> + case bd of + IfaceIdBndr (_, name, _) -> + Bndr <$> tcIfaceLclId name <*> pure vis + IfaceTvBndr (name, _) -> + Bndr <$> tcIfaceTyVar name <*> pure vis) + user_bndrs + + -- Read the context and argument types, but lazily for two reasons + -- (a) to avoid looking tugging on a recursive use of + -- the type itself, which is knot-tied + -- (b) to avoid faulting in the component types unless + -- they are really needed + ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $ + do { eq_spec <- tcIfaceEqSpec spec + ; theta <- tcIfaceCtxt ctxt + -- This fixes #13710. The enclosing lazy thunk gets + -- forced when typechecking record wildcard pattern + -- matching (it's not completely clear why this + -- tuple is needed), which causes trouble if one of + -- the argument types was recursively defined. + -- See also Note [Tying the knot] + ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys") + $ mapM (\(w, ty) -> mkScaled <$> tcIfaceType w <*> tcIfaceType ty) args + ; stricts <- mapM tc_strict if_stricts + -- The IfBang field can mention + -- the type itself; hence inside forkM + ; return (eq_spec, theta, arg_tys, stricts) } + + -- Remember, tycon is the representation tycon + ; let orig_res_ty = mkFamilyTyConApp tycon + (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec)) + (binderVars tc_tybinders)) + + ; prom_rep_name <- newTyConRepName dc_name + + ; let bang_opts = FixedBangOpts stricts + -- Pass the HsImplBangs (i.e. final decisions) to buildDataCon; + -- it'll use these to guide the construction of a worker. + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make + + ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name)) + bang_opts + dc_name is_infix prom_rep_name + (map src_strict if_src_stricts) + lbl_names + univ_tvs ex_tvs user_tv_bndrs + eq_spec theta + arg_tys orig_res_ty tycon tag_map + ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name) + ; return con } + mk_doc con_name = text "Constructor" <+> ppr con_name + + tc_strict :: IfaceBang -> IfL HsImplBang + tc_strict IfNoBang = return (HsLazy) + tc_strict IfStrict = return (HsStrict True) + tc_strict IfUnpack = return (HsUnpack Nothing) + tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co + ; return (HsUnpack (Just co)) } + + src_strict :: IfaceSrcBang -> HsSrcBang + src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang + +tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec] +tcIfaceEqSpec spec + = mapM do_item spec + where + do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ + ; ty <- tcIfaceType if_ty + ; return (mkEqSpec tv ty) } + +{- +Note [Synonym kind loop] +~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we eagerly grab the *kind* from the interface file, but +build a forkM thunk for the *rhs* (and family stuff). To see why, +consider this (#2412) + +M.hs: module M where { import X; data T = MkT S } +X.hs: module X where { import {-# SOURCE #-} M; type S = T } +M.hs-boot: module M where { data T } + +When kind-checking M.hs we need S's kind. But we do not want to +find S's kind from (typeKind S-rhs), because we don't want to look at +S-rhs yet! Since S is imported from X.hi, S gets just one chance to +be defined, and we must not do that until we've finished with M.T. + +Solution: record S's kind in the interface file; now we can safely +look at it. + +************************************************************************ +* * + Instances +* * +************************************************************************ +-} + +tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc +tcRoughTyCon (Just tc) = RM_KnownTc (ifaceTyConName tc) +tcRoughTyCon Nothing = RM_WildCard + +{- Note [Tricky rehydrating IfaceDefaults loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a potential circular dependency when rehydrating IfaceDefaults into +a DefaultEnv (a map from class names to defaults): + +1. To construct a DefaultEnv, we need the Class objects corresponding to + the class names in the IfaceDefault + +2. If a class is defined in the current module, rehydrating it requires + looking into the ModDetails we're currently building + +3. But that ModDetails needs the DefaultEnv we're trying to create! + +This creates a circular dependency: + - DefaultEnv needs Class objects + - Class objects (for current module) need ModDetails + - ModDetails needs DefaultEnv + +Our solution is to break this loop by using just the class name from +IfaceDefault, rather than trying to fully resolve the Class. Since +DefaultEnv is keyed by Name anyway, we don't need the full Class object +for the map construction - we only need it for the map values. + +In tcIfaceDefault we create ClassDefaults records containing the actual +Class objects, but we do this *after* creating the DefaultEnv keyed by Name. + +This approach allows us to tie the knot properly without causing a loop. +-} + +-- | 'tcIfaceDefaults' rehydrates a list of default declarations +-- lazily, and returns a DefaultEnv. +tcIfaceDefaults :: Module -> [IfaceDefault] -> IfL DefaultEnv +tcIfaceDefaults this_mod defaults = do + defaults <- mapM do_one defaults + return $ mkDefaultEnv defaults + where + do_one idf = do + -- Invariant: (className class_default) == name + -- see Note [Tricky rehydrating IfaceDefaults loop] + let name = ifDefaultCls idf + + -- Now look up the Class and the default types. + -- We must use forkM here, as these may be knot-tied (see #25858). + -- See Note [Rehydrating Modules] in GHC.Driver.Make + -- as well as Note [Knot-tying typecheckIface] in GHC.IfaceToCore. + class_default <- forkM (text "tcIfaceDefault" <+> ppr name) $ tcIfaceDefault this_mod idf + return (name, class_default) + +tcIfaceDefault :: Module -> IfaceDefault -> IfL ClassDefaults +tcIfaceDefault this_mod IfaceDefault { ifDefaultCls = cls_name + , ifDefaultTys = tys + , ifDefaultWarn = iface_warn } + = do { cls <- fmap tyThingConClass (tcIfaceImplicit cls_name) + ; tys' <- traverse tcIfaceType tys + ; let warn = fmap fromIfaceWarningTxt iface_warn + ; return ClassDefaults { cd_class = cls + , cd_types = tys' + , cd_provenance = DP_Imported this_mod + , cd_warn = warn } } + where + tyThingConClass :: TyThing -> Class + tyThingConClass th = case tyConClass_maybe $ tyThingTyCon th of + Just cls -> cls + Nothing -> pprPanic "tcIfaceDefault, expected class" (ppr th) + +tcIfaceInst :: IfaceClsInst -> IfL ClsInst +tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag + , ifInstCls = cls, ifInstTys = mb_tcs + , ifInstOrph = orph, ifInstWarn = iface_warn }) + = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $ + fmap tyThingId (tcIfaceImplicit dfun_name) + ; let mb_tcs' = map tcRoughTyCon mb_tcs + warn = fmap fromIfaceWarningTxt iface_warn + ; return (mkImportedClsInst cls mb_tcs' dfun_name dfun oflag orph warn) } + +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = axiom_name + , ifFamInstOrph = orphan } ) + = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $ + tcIfaceUnbranchedAxiom axiom_name + -- will panic if branched, but that's OK + ; let mb_tcs' = map tcRoughTyCon mb_tcs + ; return (mkImportedFamInst fam mb_tcs' axiom' orphan) } + +{- +************************************************************************ +* * + Rules +* * +************************************************************************ + +We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars +are in the type environment. However, remember that typechecking a Rule may +(as a side effect) augment the type envt, and so we may need to iterate the process. +-} + +tcIfaceRules :: Bool -- True <=> ignore rules + -> [IfaceRule] + -> IfL [CoreRule] +tcIfaceRules ignore_prags if_rules + | ignore_prags = return [] + | otherwise = mapM tcIfaceRule if_rules + +tcIfaceRule :: IfaceRule -> IfL CoreRule +tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, + ifRuleAuto = auto, ifRuleOrph = orph }) + = do { ~(bndrs', args', rhs') <- + -- Typecheck the payload lazily, in the hope it'll never be looked at + forkM (text "Rule" <+> pprRuleName name) $ + bindIfaceBndrs bndrs $ \ bndrs' -> + do { args' <- mapM tcIfaceExpr args + ; rhs' <- tcIfaceExpr rhs + ; whenGOptM Opt_DoCoreLinting $ do + { dflags <- getDynFlags + ; (_, lcl_env) <- getEnvs + ; let in_scope :: [Var] + in_scope = ((nonDetEltsUFM $ if_tv_env lcl_env) ++ + (nonDetEltsUFM $ if_id_env lcl_env) ++ + bndrs' ++ + exprsFreeIdsList args') + ; case lintExpr (initLintConfig dflags in_scope) rhs' of + Nothing -> return () + Just errs -> do + logger <- getLogger + liftIO $ displayLintResults logger False doc + (pprCoreExpr rhs') + (emptyBag, errs) } + ; return (bndrs', args', rhs') } + ; let mb_tcs = map ifTopFreeName args + ; this_mod <- getIfModule + ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs', ru_args = args', + ru_rhs = occurAnalyseExpr rhs', + ru_rough = mb_tcs, + ru_origin = this_mod, + ru_orphan = orph, + ru_auto = auto, + ru_local = False }) } -- An imported RULE is never for a local Id + -- or, even if it is (module loop, perhaps) + -- we'll just leave it in the non-local set + where + -- This function *must* mirror exactly what Rules.roughTopNames does + -- We could have stored the ru_rough field in the iface file + -- but that would be redundant, I think. + -- The only wrinkle is that we must not be deceived by + -- type synonyms at the top of a type arg. Since + -- we can't tell at this point, we are careful not + -- to write them out in coreRuleToIfaceRule + ifTopFreeName :: IfaceExpr -> Maybe Name + ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) + ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts))) + ifTopFreeName (IfaceApp f _) = ifTopFreeName f + ifTopFreeName (IfaceExt n) = Just n + ifTopFreeName _ = Nothing + + doc = text "Unfolding of" <+> ppr name + +{- +************************************************************************ +* * + Annotations +* * +************************************************************************ +-} + +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] +tcIfaceAnnotations = mapM tcIfaceAnnotation + +tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation +tcIfaceAnnotation (IfaceAnnotation target serialized) = do + target' <- tcIfaceAnnTarget target + return $ Annotation { + ann_target = target', + ann_value = serialized + } + +tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name) +tcIfaceAnnTarget (NamedTarget occ) = + NamedTarget <$> lookupIfaceTop occ +tcIfaceAnnTarget (ModuleTarget mod) = + return $ ModuleTarget mod + +{- +************************************************************************ +* * + Complete Match Pragmas +* * +************************************************************************ +-} + +tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch] +tcIfaceCompleteMatches = mapM tcIfaceCompleteMatch + +tcIfaceCompleteMatch :: IfaceCompleteMatch -> IfL CompleteMatch +tcIfaceCompleteMatch (IfaceCompleteMatch ms mtc) = + return $ CompleteMatch (mkUniqDSet ms) mtc + +{- Note [Positioning of forkM] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to be lazy when type checking the interface, since these functions are +called when the interface itself is being loaded, which means it is not in the +PIT yet. In particular, the `tcIfaceTCon` must be inside the forkM, otherwise +we'll try to look it up the TyCon, find it's not there, and so initiate the +process (again) of loading the (very same) interface file. Result: infinite +loop. See #19744. +-} + +{- +************************************************************************ +* * + Types +* * +************************************************************************ +-} + +tcIfaceType :: IfaceType -> IfL Type +tcIfaceType = go + where + go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n + go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n) + go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l + go (IfaceFunTy flag w t1 t2) = FunTy flag <$> tcIfaceType w <*> go t1 <*> go t2 + go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks + go (IfaceAppTy t ts) + = do { t' <- go t + ; ts' <- traverse go (appArgsIfaceTypes ts) + ; pure (foldl' AppTy t' ts') } + go (IfaceTyConApp tc tks) + = do { tc' <- tcIfaceTyCon tc + ; tks' <- mapM go (appArgsIfaceTypes tks) + ; return (mkTyConApp tc' tks') } + go (IfaceForAllTy bndr t) + = bindIfaceForAllBndr bndr $ \ tv' vis -> + ForAllTy (Bndr tv' vis) <$> go t + go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co + go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co + +tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type +tcIfaceTupleTy sort is_promoted args + = do { args' <- tcIfaceAppArgs args + ; let arity = length args' + ; base_tc <- tcTupleTyCon True sort arity + ; case is_promoted of + NotPromoted + -> return (mkTyConApp base_tc args') + + IsPromoted + -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc) + kind_args = map typeKind args' + ; return (mkTyConApp tc (kind_args ++ args')) } } + +-- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon +tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr) + -> TupleSort + -> Arity -- the number of args. *not* the tuple arity. + -> IfL TyCon +tcTupleTyCon in_type sort arity + = case sort of + ConstraintTuple -> return (cTupleTyCon arity) + BoxedTuple -> return (tupleTyCon Boxed arity) + UnboxedTuple -> return (tupleTyCon Unboxed arity') + where arity' | in_type = arity `div` 2 + | otherwise = arity + -- in expressions, we only have term args + +tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type] +tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes + +----------------------------------------- +tcIfaceCtxt :: IfaceContext -> IfL ThetaType +tcIfaceCtxt sts = mapM tcIfaceType sts + +----------------------------------------- +tcIfaceTyLit :: IfaceTyLit -> IfL TyLit +tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) +tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit (getLexicalFastString n)) +tcIfaceTyLit (IfaceCharTyLit n) = return (CharTyLit n) + +{- +%************************************************************************ +%* * + Coercions +* * +************************************************************************ +-} + +tcIfaceCo :: IfaceCoercion -> IfL Coercion +tcIfaceCo = go + where + go_mco IfaceMRefl = pure MRefl + go_mco (IfaceMCo co) = MCo <$> (go co) + + go (IfaceReflCo t) = Refl <$> tcIfaceType t + go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco + go (IfaceFunCo r w c1 c2) = mkFunCoNoFTF r <$> go w <*> go c1 <*> go c2 + go (IfaceTyConAppCo r tc cs) = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs + go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 + go (IfaceForAllCo tv visL visR k c) = do { k' <- go k + ; bindIfaceBndr tv $ \ tv' -> + ForAllCo tv' visL visR k' <$> go c } + go (IfaceCoVarCo n) = CoVarCo <$> go_var n + go (IfaceUnivCo p r t1 t2 ds) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2 + ; ds' <- mapM go ds + ; return (UnivCo { uco_prov = p, uco_role = r + , uco_lty = t1', uco_rty = t2' + , uco_deps = ds' }) } + go (IfaceSymCo c) = SymCo <$> go c + go (IfaceTransCo c1 c2) = TransCo <$> go c1 + <*> go c2 + go (IfaceInstCo c1 t2) = InstCo <$> go c1 + <*> go t2 + go (IfaceSelCo d c) = do { c' <- go c + ; return $ mkSelCo d c' } + go (IfaceLRCo lr c) = LRCo lr <$> go c + go (IfaceKindCo c) = KindCo <$> go c + go (IfaceSubCo c) = SubCo <$> go c + go (IfaceAxiomCo ax cos) = AxiomCo <$> tcIfaceAxiomRule ax + <*> mapM go cos + go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c) + go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c) + + go_var :: IfLclName -> IfL CoVar + go_var = tcIfaceLclId + +{- +************************************************************************ +* * + Core +* * +************************************************************************ +-} + +tcIfaceExpr :: IfaceExpr -> IfL CoreExpr +tcIfaceExpr (IfaceType ty) + = Type <$> tcIfaceType ty + +tcIfaceExpr (IfaceCo co) + = Coercion <$> tcIfaceCo co + +tcIfaceExpr (IfaceCast expr co) + = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co + +tcIfaceExpr (IfaceLcl name) + = Var <$> tcIfaceLclId name + +tcIfaceExpr (IfaceExt gbl) + = Var <$> tcIfaceExtId gbl + +tcIfaceExpr (IfaceLitRubbish tc rep) + = do rep' <- tcIfaceType rep + return (Lit (LitRubbish tc rep')) + +tcIfaceExpr (IfaceLit lit) + = do lit' <- tcIfaceLit lit + return (Lit lit') + +tcIfaceExpr (IfaceFCall cc ty) = do + ty' <- tcIfaceType ty + u <- newUnique + return (Var (mkFCallId u cc ty')) + +tcIfaceExpr (IfaceTuple sort args) + = do { args' <- mapM tcIfaceExpr args + ; tc <- tcTupleTyCon False sort arity + ; let con_tys = map exprType args' + some_con_args = map Type con_tys ++ args' + con_args = case sort of + UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args + _ -> some_con_args + -- Put the missing type arguments back in + con_id = dataConWorkId (tyConSingleDataCon tc) + ; return (mkApps (Var con_id) con_args) } + where + arity = length args + +tcIfaceExpr (IfaceLam (bndr, os) body) + = bindIfaceBndr bndr $ \bndr' -> + Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body + where + tcIfaceOneShot IfaceOneShot b = setOneShotLambda b + tcIfaceOneShot _ b = b + +tcIfaceExpr (IfaceApp fun arg) + = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg + +tcIfaceExpr (IfaceECase scrut ty) + = do { scrut' <- tcIfaceExpr scrut + ; ty' <- tcIfaceType ty + ; return (castBottomExpr scrut' ty') } + +tcIfaceExpr (IfaceCase scrut case_bndr alts) = do + scrut' <- tcIfaceExpr scrut + case_bndr_name <- newIfaceName (mkVarOccFS (ifLclNameFS case_bndr)) + let + scrut_ty = exprType scrut' + case_mult = ManyTy + case_bndr' = mkLocalIdOrCoVar case_bndr_name case_mult scrut_ty + -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors + -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. + tc_app = splitTyConApp scrut_ty + -- NB: Won't always succeed (polymorphic case) + -- but won't be demanded in those cases + -- NB: not tcSplitTyConApp; we are looking at Core here + -- look through non-rec newtypes to find the tycon that + -- corresponds to the datacon in this case alternative + + extendIfaceIdEnv [case_bndr'] $ do + alts' <- mapM (tcIfaceAlt scrut' case_mult tc_app) alts + return (Case scrut' case_bndr' (coreAltsType alts') alts') + +tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body) + = do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs)) + ; ty' <- tcIfaceType ty + ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} + NotTopLevel name ty' info + ; let id = mkLocalIdWithInfo name ManyTy ty' id_info + `asJoinId_maybe` ji + ; rhs' <- tcIfaceExpr rhs + ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) + ; return (Let (NonRec id rhs') body') } + +tcIfaceExpr (IfaceLet (IfaceRec pairs) body) + = do { ids <- mapM tc_rec_bndr (map fst pairs) + ; extendIfaceIdEnv ids $ do + { pairs' <- zipWithM tc_pair pairs ids + ; body' <- tcIfaceExpr body + ; return (Let (Rec pairs') body') } } + where + tc_rec_bndr (IfLetBndr fs ty _ ji) + = do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs)) + ; ty' <- tcIfaceType ty + ; return (mkLocalId name ManyTy ty' `asJoinId_maybe` ji) } + tc_pair (IfLetBndr _ _ info _, rhs) id + = do { rhs' <- tcIfaceExpr rhs + ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} + NotTopLevel (idName id) (idType id) info + ; return (setIdInfo id id_info, rhs') } + +tcIfaceExpr (IfaceTick tickish expr) = do + expr' <- tcIfaceExpr expr + -- If debug flag is not set: Ignore source notes + need_notes <- needSourceNotes <$> getDynFlags + case tickish of + IfaceSource{} | not (need_notes) + -> return expr' + _otherwise -> do + tickish' <- tcIfaceTickish tickish + return (Tick tickish' expr') + +------------------------- +tcIfaceTickish :: IfaceTickish -> IfL CoreTickish +tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) +tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) +tcIfaceTickish (IfaceSource src name) = return (SourceNote src (LexicalFastString name)) +tcIfaceTickish (IfaceBreakpoint bid fvs) = do + fvs' <- mapM tcIfaceExpr fvs + return (Breakpoint NoExtField bid [f | Var f <- fvs']) + +------------------------- +tcIfaceLit :: Literal -> IfL Literal +tcIfaceLit lit = return lit + +------------------------- +tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type]) + -> IfaceAlt + -> IfL CoreAlt +tcIfaceAlt _ _ _ (IfaceAlt IfaceDefaultAlt names rhs) + = assert (null names) $ do + rhs' <- tcIfaceExpr rhs + return (Alt DEFAULT [] rhs') + +tcIfaceAlt _ _ _ (IfaceAlt (IfaceLitAlt lit) names rhs) + = assert (null names) $ do + lit' <- tcIfaceLit lit + rhs' <- tcIfaceExpr rhs + return (Alt (LitAlt lit') [] rhs') + +-- A case alternative is made quite a bit more complicated +-- by the fact that we omit type annotations because we can +-- work them out. True enough, but its not that easy! +tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceAlt (IfaceDataAlt data_occ) arg_strs rhs) + = do { con <- tcIfaceDataCon data_occ + ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) + (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) + ; tcIfaceDataAlt mult con inst_tys arg_strs rhs } + +tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [IfLclName] -> IfaceExpr + -> IfL CoreAlt +tcIfaceDataAlt mult con inst_tys arg_strs rhs + = do { uniqs <- getUniquesM + ; let (ex_tvs, arg_ids) + = dataConRepFSInstPat (map ifLclNameFS arg_strs) uniqs mult con inst_tys + + ; rhs' <- extendIfaceEnvs ex_tvs $ + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs + ; return (Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs') } + +{- +************************************************************************ +* * + IdInfo +* * +************************************************************************ +-} + +tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ _ IfVanillaId = return VanillaId +tcIdDetails _ _ (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds +tcIdDetails _ ty IfDFunId = return (DFunId (isUnaryClass cls)) + where + (_, _, cls, _) = tcSplitDFunTy ty + +tcIdDetails nm _ (IfRecSelId tc _first_con naughty fl) + = do { tc' <- either (fmap RecSelData . tcIfaceTyCon) + (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False) + tc + ; let all_cons = recSelParentCons tc' + cons_partitioned = conLikesRecSelInfo all_cons [flLabel fl] + ; return (RecSelId + { sel_tycon = tc' + , sel_naughty = naughty + , sel_fieldLabel = fl { flSelector = nm } + , sel_cons = cons_partitioned } + -- Reconstructed here since we don't want Uniques in the Iface file + ) } + where + tyThingPatSyn (AConLike (PatSynCon ps)) = ps + tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn" + +tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo +tcIdInfo ignore_prags toplvl name ty info = do + lcl_env <- getLclEnv + -- Set the CgInfo to something sensible but uninformative before + -- we start; default assumption is that it has CAFs + let init_info = if if_boot lcl_env == IsBoot + then vanillaIdInfo `setUnfoldingInfo` BootUnfolding + else vanillaIdInfo + + foldlM tcPrag init_info (needed_prags info) + where + needed_prags :: [IfaceInfoItem] -> [IfaceInfoItem] + needed_prags items + | not ignore_prags = items + | otherwise = filter need_prag items + + need_prag :: IfaceInfoItem -> Bool + -- Always read in compulsory unfoldings + -- See Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy + need_prag (HsUnfold _ (IfCoreUnfold src _ _ _)) = isCompulsorySource src + need_prag _ = False + + tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo + tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) + tcPrag info (HsArity arity) = return (info `setArityInfo` arity) + tcPrag info (HsDmdSig str) = return (info `setDmdSigInfo` str) + tcPrag info (HsCprSig cpr) = return (info `setCprSigInfo` cpr) + tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) + tcPrag info (HsLFInfo lf_info) = do + lf_info <- tcLFInfo lf_info + return (info `setLFInfo` lf_info) + + tcPrag info (HsTagSig sig) = do + return (info `setTagSig` sig) + + -- The next two are lazy, so they don't transitively suck stuff in + tcPrag info (HsUnfold lb if_unf) + = do { unf <- tcUnfolding toplvl name ty info if_unf + ; let info1 | lb = info `setOccInfo` strongLoopBreaker + | otherwise = info + ; return (info1 `setUnfoldingInfo` unf) } + +tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo +tcLFInfo lfi = case lfi of + IfLFReEntrant rep_arity -> + -- LFReEntrant closures in interface files are guaranteed to + -- + -- - Be top-level, as only top-level closures are exported. + -- - Have no free variables, as only non-top-level closures have free + -- variables + -- - Don't have ArgDescrs, as ArgDescr is used when generating code for + -- the closure + -- + -- These invariants are checked when generating LFInfos in toIfaceLFInfo. + return (LFReEntrant TopLevel rep_arity True ArgUnknown) + + IfLFThunk updatable mb_fun -> + -- LFThunk closure in interface files are guaranteed to + -- + -- - Be top-level + -- - No have free variables + -- + -- These invariants are checked when generating LFInfos in toIfaceLFInfo. + return (LFThunk TopLevel True updatable NonStandardThunk mb_fun) + + IfLFUnlifted -> + return LFUnlifted + + IfLFCon con_name -> + LFCon <$!> tcIfaceDataCon con_name + + IfLFUnknown fun_flag -> + return (LFUnknown fun_flag) + +tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding +-- See Note [Lazily checking Unfoldings] +tcUnfolding toplvl name _ info (IfCoreUnfold src cache if_guidance if_expr) + = do { uf_opts <- unfoldingOpts <$> getDynFlags + ; expr <- tcUnfoldingRhs (isCompulsorySource src) toplvl name if_expr + ; let guidance = case if_guidance of + IfWhen arity unsat_ok boring_ok -> UnfWhen arity unsat_ok boring_ok + IfNoGuidance -> calcUnfoldingGuidance uf_opts is_top_bottoming False expr + -- See Note [Tying the 'CoreUnfolding' knot] + ; return $ mkCoreUnfolding src True expr (Just cache) guidance } + where + -- Strictness should occur before unfolding! + is_top_bottoming = isTopLevel toplvl && isDeadEndSig (dmdSigInfo info) + +tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops) + = bindIfaceBndrs bs $ \ bs' -> + do { ops1 <- forkM doc $ mapM tcIfaceExpr ops + ; return $ mkDFunUnfolding bs' (classDataCon cls) ops1 } + where + doc = text "Class ops for dfun" <+> ppr name + (_, _, cls, _) = tcSplitDFunTy dfun_ty + +{- Note [Tying the 'CoreUnfolding' knot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The unfolding of recursive definitions can contain references to the +Id being defined. Consider the following example: + + foo :: () + foo = foo + +The unfolding template of 'foo' is, of course, 'foo'; so the interface +file for this module contains: + + foo :: (); Unfolding = foo + +When rehydrating the interface file we are going to make an Id for +'foo' (in GHC.IfaceToCore), with an 'Unfolding'. We used to make this +'Unfolding' by calling 'mkFinalUnfolding', but that needs to populate, +among other fields, the 'uf_is_value' field, by computing +'exprIsValue' of the template (in this case, 'foo'). + +'exprIsValue e' looks at the unfoldings of variables in 'e' to see if +they are evaluated; so it consults the `uf_is_value` field of +variables in `e`. Now we can see the problem: to set the `uf_is_value` +field of `foo`'s unfolding, we look at its unfolding (in this case +just `foo` itself!). Loop. This is the root cause of ticket #22272. + +The simple solution we chose is to serialise the various auxiliary +fields of `CoreUnfolding` so that we don't need to recreate them when +rehydrating. Specifically, the following fields are moved to the +'UnfoldingCache', which is persisted in the interface file: + +* 'uf_is_conlike' +* 'uf_is_value' +* 'uf_is_work_free' +* 'uf_expandable' + +These four bits make the interface files only one byte larger per +unfolding; on the other hand, this does save calls to 'exprIsValue', +'exprIsExpandable' etc for every imported Id. + +We could choose to do this only for loop breakers. But that's a bit +more complicated and it seems good all round. +-} + +{- Note [Lazily checking Unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For unfoldings, we try to do the job lazily, so that we never typecheck +an unfolding that isn't going to be looked at. + +The main idea is that if M.hi has a declaration + f :: Int -> Int + f = \x. ...A.g... -- The unfolding for f + +then we don't even want to /read/ A.hi unless f's unfolding is actually used; say, +if f is inlined. But we need to be careful. Even if we don't inline f, we might ask +hasNoBinding of it (Core Lint does this in GHC.Core.Lint.checkCanEtaExpand), +and hasNoBinding looks to see if f has a compulsory unfolding. +So the root Unfolding constructor must be visible: we want to be able to read the 'uf_src' +field which says whether it is a compulsory unfolding, without forcing the unfolding RHS +which is stored in 'uf_tmpl'. This matters for efficiency, but not only: if g's unfolding +mentions f, we must not look at the unfolding RHS for f, as this is precisely what we are +in the middle of checking (so looking at it would cause a loop). + +Conclusion: `tcUnfolding` must return an `Unfolding` whose `uf_src` field is readable without +forcing the `uf_tmpl` field. In particular, all the functions used at the end of +`tcUnfolding` (such as `mkFinalUnfolding`, `mkCoreUnfolding`) must be +lazy in `expr`. + +Ticket #21139 +-} + +tcUnfoldingRhs :: Bool -- ^ Is this unfolding compulsory? + -- See Note [Checking for representation polymorphism] in GHC.Core.Lint + -> TopLevelFlag -> Name -> IfaceExpr -> IfL CoreExpr +tcUnfoldingRhs is_compulsory toplvl name expr + = forkM doc $ do + core_expr' <- tcIfaceExpr expr + + -- Check for type consistency in the unfolding + -- See Note [Linting Unfoldings from Interfaces] in GHC.Core.Lint + when (isTopLevel toplvl) $ + whenGOptM Opt_DoCoreLinting $ do + in_scope <- nonDetEltsUniqSet <$> get_in_scope + dflags <- getDynFlags + logger <- getLogger + case lintUnfolding is_compulsory (initLintConfig dflags in_scope) noSrcLoc core_expr' of + Nothing -> return () + Just errs -> liftIO $ + displayLintResults logger False doc + (pprCoreExpr core_expr') (emptyBag, errs) + return core_expr' + where + doc = ppWhen is_compulsory (text "Compulsory") <+> + text "Unfolding of" <+> ppr name + + get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting + get_in_scope + = do { (gbl_env, lcl_env) <- getEnvs + ; let type_envs = knotVarElems (if_rec_types gbl_env) + ; top_level_vars <- concat <$> mapM (fmap typeEnvIds . setLclEnv ()) type_envs + ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet` + bindingsVars (if_id_env lcl_env) `unionVarSet` + mkVarSet top_level_vars) } + + bindingsVars :: FastStringEnv Var -> VarSet + bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm + -- It's OK to use nonDetEltsUFM here because we immediately forget + -- the ordering by creating a set + +tcIfaceOneShot :: IfaceOneShot -> OneShotInfo +tcIfaceOneShot IfaceNoOneShot = NoOneShotInfo +tcIfaceOneShot IfaceOneShot = OneShotLam + +{- +************************************************************************ +* * + Getting from Names to TyThings +* * +************************************************************************ +-} + +tcIfaceGlobal :: Name -> IfL TyThing +tcIfaceGlobal name + | Just thing <- wiredInNameTyThing_maybe name + -- Wired-in things include TyCons, DataCons, and Ids + -- Even though we are in an interface file, we want to make + -- sure the instances and RULES of this thing (particularly TyCon) are loaded + -- Imagine: f :: Double -> Double + = do { ifCheckWiredInThing thing; return thing } + + | otherwise + = do { env <- getGblEnv + ; cur_mod <- if_mod <$> getLclEnv + ; case lookupKnotVars (if_rec_types env) (fromMaybe cur_mod (nameModule_maybe name)) of -- Note [Tying the knot] + Just get_type_env + -> do -- It's defined in a module in the hs-boot loop + { type_env <- setLclEnv () get_type_env -- yuk + ; case lookupNameEnv type_env name of + Just thing -> return thing + -- See Note [Knot-tying fallback on boot] + Nothing -> via_external + } + + _ -> via_external } + where + via_external = do + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupType hsc_env name) + ; case mb_thing of { + Just thing -> return thing ; + Nothing -> do + + { mb_thing <- importDecl name -- It's imported; go get it + ; case mb_thing of + Failed err -> failIfM (ppr name <+> pprDiagnostic err) + Succeeded thing -> return thing + }}} + +-- Note [Tying the knot] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- The if_rec_types field is used when we are compiling M.hs, which indirectly +-- imports Foo.hi, which mentions M.T Then we look up M.T in M's type +-- environment, which is splatted into if_rec_types after we've built M's type +-- envt. +-- +-- This is a dark and complicated part of GHC type checking, with a lot +-- of moving parts. Interested readers should also look at: +-- +-- * Note [Knot-tying typecheckIface] +-- * Note [DFun knot-tying] +-- * Note [hsc_type_env_var hack] +-- * Note [Knot-tying fallback on boot] +-- * Note [Hydrating Modules] +-- +-- There is also a wiki page on the subject, see: +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot + +-- Note [Knot-tying fallback on boot] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Suppose that you are typechecking A.hs, which transitively imports, +-- via B.hs, A.hs-boot. When we poke on B.hs and discover that it +-- has a reference to a type T from A, what TyThing should we wire +-- it up with? Clearly, if we have already typechecked T and +-- added it into the type environment, we should go ahead and use that +-- type. But what if we haven't typechecked it yet? +-- +-- For the longest time, GHC adopted the policy that this was +-- *an error condition*; that you MUST NEVER poke on B.hs's reference +-- to a T defined in A.hs until A.hs has gotten around to kind-checking +-- T and adding it to the env. However, actually ensuring this is the +-- case has proven to be a bug farm, because it's really difficult to +-- actually ensure this never happens. The problem was especially poignant +-- with type family consistency checks, which eagerly happen before any +-- typechecking takes place. +-- +-- Today, we take a different strategy: if we ever try to access +-- an entity from A which doesn't exist, we just fall back on the +-- definition of A from the hs-boot file. This is complicated in +-- its own way: it means that you may end up with a mix of A.hs and +-- A.hs-boot TyThings during the course of typechecking. We don't +-- think (and have not observed) any cases where this would cause +-- problems, but the hypothetical situation one might worry about +-- is something along these lines in Core: +-- +-- case x of +-- A -> e1 +-- B -> e2 +-- +-- If, when typechecking this, we find x :: T, and the T we are hooked +-- up with is the abstract one from the hs-boot file, rather than the +-- one defined in this module with constructors A and B. But it's hard +-- to see how this could happen, especially because the reference to +-- the constructor (A and B) means that GHC will always typecheck +-- this expression *after* typechecking T. + +tcIfaceTyCon :: IfaceTyCon -> IfL TyCon +tcIfaceTyCon (IfaceTyCon name _info) + = do { thing <- tcIfaceGlobal name + ; case thing of + ATyCon tc -> return tc + AConLike (RealDataCon dc) -> return (promoteDataCon dc) + _ -> pprPanic "tcIfaceTyCon" (ppr thing) } + +tcIfaceAxiomRule :: IfaceAxiomRule -> IfL CoAxiomRule +-- Unlike CoAxioms, which arise from user 'type instance' declarations, +-- there are a fixed set of CoAxiomRules: +-- - axioms for type-level literals (Nat and Symbol), +-- enumerated in typeNatCoAxiomRules +tcIfaceAxiomRule (IfaceAR_X n) + | Just axr <- lookupUFM typeNatCoAxiomRules (ifLclNameFS n) + = return axr + | otherwise + = pprPanic "tcIfaceAxiomRule" (ppr n) +tcIfaceAxiomRule (IfaceAR_U name) = do { ax <- tcIfaceUnbranchedAxiom name; return (UnbranchedAxiom ax) } +tcIfaceAxiomRule (IfaceAR_B name i) = do { ax <- tcIfaceBranchedAxiom name; return (BranchedAxiom ax i) } + +tcIfaceUnbranchedAxiom :: IfExtName -> IfL (CoAxiom Unbranched) +tcIfaceUnbranchedAxiom name + = do { thing <- tcIfaceImplicit name + ; return (toUnbranchedAxiom (tyThingCoAxiom thing)) } + +tcIfaceBranchedAxiom :: IfExtName -> IfL (CoAxiom Branched) +tcIfaceBranchedAxiom name + = do { thing <- tcIfaceImplicit name + ; return (tyThingCoAxiom thing) } + +tcIfaceDataCon :: Name -> IfL DataCon +tcIfaceDataCon name = do { thing <- tcIfaceGlobal name + ; case thing of + AConLike (RealDataCon dc) -> return dc + _ -> pprPanic "tcIfaceDataCon" (ppr name$$ ppr thing) } + +tcIfaceExtId :: Name -> IfL Id +tcIfaceExtId name = do { thing <- tcIfaceGlobal name + ; case thing of + AnId id -> return id + _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } + +-- See Note [Resolving never-exported Names] in GHC.IfaceToCore +tcIfaceImplicit :: Name -> IfL TyThing +tcIfaceImplicit n = do + lcl_env <- getLclEnv + case if_implicits_env lcl_env of + Nothing -> tcIfaceGlobal n + Just tenv -> + case lookupTypeEnv tenv n of + Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv) + Just tything -> return tything + +{- +************************************************************************ +* * + Bindings +* * +************************************************************************ +-} + +bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a +bindIfaceId (w, fs, ty) thing_inside + = do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs)) + ; ty' <- tcIfaceType ty + ; w' <- tcIfaceType w + ; let id = mkLocalIdOrCoVar name w' ty' + -- We should not have "OrCoVar" here, this is a bug (#17545) + ; extendIfaceIdEnv [id] (thing_inside id) } + +bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a +bindIfaceIds [] thing_inside = thing_inside [] +bindIfaceIds (b:bs) thing_inside + = bindIfaceId b $ \b' -> + bindIfaceIds bs $ \bs' -> + thing_inside (b':bs') + +bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a +bindIfaceBndr (IfaceIdBndr bndr) thing_inside + = bindIfaceId bndr thing_inside +bindIfaceBndr (IfaceTvBndr bndr) thing_inside + = bindIfaceTyVar bndr thing_inside + +bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a +bindIfaceBndrs [] thing_inside = thing_inside [] +bindIfaceBndrs (b:bs) thing_inside + = bindIfaceBndr b $ \ b' -> + bindIfaceBndrs bs $ \ bs' -> + thing_inside (b':bs') + +----------------------- +bindIfaceForAllBndrs :: [VarBndr IfaceBndr vis] -> ([VarBndr TyCoVar vis] -> IfL a) -> IfL a +bindIfaceForAllBndrs [] thing_inside = thing_inside [] +bindIfaceForAllBndrs (bndr:bndrs) thing_inside + = bindIfaceForAllBndr bndr $ \tv vis -> + bindIfaceForAllBndrs bndrs $ \bndrs' -> + thing_inside (Bndr tv vis : bndrs') + +bindIfaceForAllBndr :: (VarBndr IfaceBndr vis) -> (TyCoVar -> vis -> IfL a) -> IfL a +bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside + = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis +bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside + = bindIfaceId tv $ \tv' -> thing_inside tv' vis + +bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a +bindIfaceTyVar (occ,kind) thing_inside + = do { name <- newIfaceName (mkTyVarOccFS (ifLclNameFS occ)) + ; tyvar <- mk_iface_tyvar name kind + ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } + +bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +bindIfaceTyVars [] thing_inside = thing_inside [] +bindIfaceTyVars (bndr:bndrs) thing_inside + = bindIfaceTyVar bndr $ \tv -> + bindIfaceTyVars bndrs $ \tvs -> + thing_inside (tv : tvs) + +mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar +mk_iface_tyvar name ifKind + = do { kind <- tcIfaceType ifKind + ; return (Var.mkTyVar name kind) } + +bindIfaceTyConBinders :: [IfaceTyConBinder] + -> ([TyConBinder] -> IfL a) -> IfL a +bindIfaceTyConBinders [] thing_inside = thing_inside [] +bindIfaceTyConBinders (b:bs) thing_inside + = bindIfaceTyConBinderX bindIfaceBndr b $ \ b' -> + bindIfaceTyConBinders bs $ \ bs' -> + thing_inside (b':bs') + +bindIfaceTyConBinders_AT :: [IfaceTyConBinder] + -> ([TyConBinder] -> IfL a) -> IfL a +-- Used for type variable in nested associated data/type declarations +-- where some of the type variables are already in scope +-- class C a where { data T a b } +-- Here 'a' is in scope when we look at the 'data T' +bindIfaceTyConBinders_AT [] thing_inside + = thing_inside [] +bindIfaceTyConBinders_AT (b : bs) thing_inside + = bindIfaceTyConBinderX bind_tv b $ \b' -> + bindIfaceTyConBinders_AT bs $ \bs' -> + thing_inside (b':bs') + where + bind_tv tv thing + = do { mb_tv <- lookupIfaceVar tv + ; case mb_tv of + Just b' -> thing b' + Nothing -> bindIfaceBndr tv thing } + +bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a) + -> IfaceTyConBinder + -> (TyConBinder -> IfL a) -> IfL a +bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside + = bind_tv tv $ \tv' -> + thing_inside (Bndr tv' vis) + +-- CgBreakInfo + +hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (Id, Word)], Type) +hydrateCgBreakInfo CgBreakInfo{..} = do + bindIfaceTyVars cgb_tyvars $ \_ -> do + result_ty <- tcIfaceType cgb_resty + mbVars <- mapM (traverse (\(if_gbl, offset) -> (,offset) <$> bindIfaceId if_gbl return)) cgb_vars + return (mbVars, result_ty) + +-- | This function is only used to construct the environment for GHCi, +-- so we make up fake locations +tcIfaceImport :: IfaceImport -> ImportUserSpec +tcIfaceImport (IfaceImport spec ImpIfaceAll) + = ImpUserSpec spec ImpUserAll +tcIfaceImport (IfaceImport spec (ImpIfaceEverythingBut ns)) + = ImpUserSpec spec (ImpUserEverythingBut (mkNameSet ns)) +tcIfaceImport (IfaceImport spec (ImpIfaceExplicit gre implicit_parents)) + = ImpUserSpec spec (ImpUserExplicit (getDetOrdAvails gre) $ mkNameSet implicit_parents) diff --git a/GHC/IfaceToCore.hs-boot b/GHC/IfaceToCore.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/IfaceToCore.hs-boot @@ -0,0 +1,26 @@ +module GHC.IfaceToCore where + +import GHC.Prelude +import GHC.Iface.Syntax ( IfaceDecl, IfaceDefault, IfaceClsInst, IfaceFamInst, IfaceRule + , IfaceAnnotation, IfaceCompleteMatch ) +import GHC.Types.TyThing ( TyThing ) +import GHC.Tc.Types ( IfL ) +import GHC.Core.InstEnv ( ClsInst ) +import GHC.Core.FamInstEnv ( FamInst ) +import GHC.Core ( CoreRule ) +import GHC.Types.CompleteMatch +import GHC.Types.Annotations ( Annotation ) +import GHC.Types.DefaultEnv ( DefaultEnv ) +import GHC.Types.Name +import GHC.Unit.Types ( Module ) +import GHC.Fingerprint.Type + + +tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing +tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] +tcIfaceDefaults :: Module -> [IfaceDefault] -> IfL DefaultEnv +tcIfaceInst :: IfaceClsInst -> IfL ClsInst +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] +tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL CompleteMatches +tcIfaceDecls :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name,TyThing)] diff --git a/GHC/JS/Ident.hs b/GHC/JS/Ident.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Ident.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Ident +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Ident defines identifiers for the JS backend. We keep this module +-- separate to prevent coupling between GHC and the backend and between +-- unrelated modules is the JS backend. +-- +-- * Consumers +-- +-- The entire JavaScript Backend consumes this module including modules in +-- GHC.JS.\* and modules in GHC.StgToJS.\* +-- +-- * Additional Notes +-- +-- This module should be kept as small as possible. Anything added to it +-- will be coupled to the JS backend EDSL and the JS Backend including the +-- linker and rts. You have been warned. +-- +----------------------------------------------------------------------------- + +module GHC.JS.Ident + ( Ident(..) + , name + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Types.Unique +import GHC.Utils.Outputable + +-------------------------------------------------------------------------------- +-- Identifiers +-------------------------------------------------------------------------------- + +-- | A newtype wrapper around 'FastString' for JS identifiers. +newtype Ident = TxtI { identFS :: FastString } + deriving stock (Show, Eq) + deriving newtype (Uniquable, Outputable) + +-- | To give a thing a name is to have power over it. This smart constructor +-- serves two purposes: first, it isolates the JS backend from the rest of GHC. +-- The backend should not explicitly use types provided by GHC but instead +-- should wrap them such as we do here. Second it creates a symbol in the JS +-- backend, but it does not yet give that symbols meaning. Giving the symbol +-- meaning only occurs once it is used with a combinator from @GHC.JS.Make@. +name :: FastString -> Ident +name = TxtI diff --git a/GHC/JS/JStg/Monad.hs b/GHC/JS/JStg/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/JStg/Monad.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.JStg.Monad +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.JStg.Monad defines the computational environment for the eDSL that +-- we use to write the JS Backend's RTS. Its purpose is to ensure unique +-- identifiers are generated throughout the backend and that we can use the +-- host language to ensure references are not mixed. +-- +-- * Strategy +-- +-- The monad is a straightforward state monad which holds an environment +-- holds a pointer to a prefix to tag identifiers with and an infinite +-- stream of identifiers. +-- +-- * Usage +-- +-- One should almost never need to directly use the functions in this +-- module. Instead one should opt to use the combinators in 'GHC.JS.Make', +-- the sole exception to this is the @withTag@ function which is used to +-- change the prefix of identifiers for a given computation. For example, +-- the rts uses this function to tag all identifiers generated by the RTS +-- code as RTS_N, where N is some unique. +----------------------------------------------------------------------------- +module GHC.JS.JStg.Monad + ( runJSM + , JSM + , withTag + , newIdent + , initJSM + ) where + +import Prelude + +import GHC.JS.Ident + +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import Control.Monad.Trans.State.Strict +import GHC.Data.FastString + +-------------------------------------------------------------------------------- +-- JSM Monad +-------------------------------------------------------------------------------- + +-- | Environment for the JSM Monad. We maintain the prefix of each ident in the +-- environment to allow consumers to tag idents with a new prefix. See @withTag@ +data JEnv = JEnv { prefix :: !FastString -- ^ prefix for generated names, e.g., + -- prefix = "RTS" will generate names + -- such as 'h$RTS_jUt' + , ids :: UniqSupply -- ^ The supply of uniques for names + -- generated by the JSM monad. + } + +type JSM a = State JEnv a + +runJSM :: JEnv -> JSM a -> a +runJSM env m = evalState m env + +-- | create a new environment using the input tag. +initJSMState :: FastString -> UniqSupply -> JEnv +initJSMState tag supply = JEnv { prefix = tag + , ids = supply + } +initJSM :: IO JEnv +initJSM = do supply <- mkSplitUniqSupply 'j' + return (initJSMState "js" supply) + +update_stream :: UniqSupply -> JSM () +update_stream new = modify' $ \env -> env {ids = new} + +-- | generate a fresh Ident +newIdent :: JSM Ident +newIdent = do env <- get + let tag = prefix env + supply = ids env + (id,rest) = takeUniqFromSupply supply + update_stream rest + return $ mk_ident tag id + +mk_ident :: FastString -> Unique -> Ident +mk_ident t i = name (mconcat [t, "_", mkFastString (show i)]) + +-- | Set the tag for @Ident@s for all remaining computations. +tag_names :: FastString -> JSM () +tag_names tag = modify' (\env -> env {prefix = tag}) + +-- | tag the name generater with a prefix for the monadic action. +withTag + :: FastString -- ^ new name to tag with + -> JSM a -- ^ action to run with new tags + -> JSM a -- ^ result +withTag tag go = do + old <- gets prefix + tag_names tag + result <- go + tag_names old + return result diff --git a/GHC/JS/JStg/Syntax.hs b/GHC/JS/JStg/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/JStg/Syntax.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.JStg.Syntax +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.JStg.Syntax defines the eDSL that the JS backend's runtime system +-- is written in. Nothing fancy, its just a straightforward deeply embedded +-- DSL. +-- +-- In general, one should not use these constructors explicitly in the JS +-- backend. Instead, prefer using the combinators in GHC.JS.Make, if those +-- are suitable then prefer using the patterns exported from this module + +----------------------------------------------------------------------------- +module GHC.JS.JStg.Syntax + ( -- * Deeply embedded JS datatypes + JStgStat(..) + , JStgExpr(..) + , JVal(..) + , Op(..) + , AOp(..) + , UOp(..) + , JsLabel + -- * pattern synonyms over JS operators + , pattern New + , pattern Not + , pattern Negate + , pattern Add + , pattern Sub + , pattern Mul + , pattern Div + , pattern Mod + , pattern BOr + , pattern BAnd + , pattern BXor + , pattern BNot + , pattern LOr + , pattern LAnd + , pattern Int + , pattern String + , pattern Var + , pattern PreInc + , pattern PostInc + , pattern PreDec + , pattern PostDec + -- * Utility + , SaneDouble(..) + , pattern Func + , global + , local + ) where + +import GHC.Prelude +import GHC.Utils.Outputable + +import GHC.JS.Ident + +import Control.DeepSeq + +import Data.Data +import qualified Data.Semigroup as Semigroup + +import GHC.Generics + +import GHC.Data.FastString +import GHC.Types.Unique.Map +import GHC.Types.SaneDouble + +-------------------------------------------------------------------------------- +-- Statements +-------------------------------------------------------------------------------- +-- | JavaScript statements, see the [ECMA262 +-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) +-- for details +data JStgStat + = DeclStat !Ident !(Maybe JStgExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JStgExpr -- ^ Return + | IfStat JStgExpr JStgStat JStgStat -- ^ If + | WhileStat Bool JStgExpr JStgStat -- ^ While, bool is "do" when True + | ForStat JStgStat JStgExpr JStgStat JStgStat -- ^ For + | ForInStat Bool Ident JStgExpr JStgStat -- ^ For-in, bool is "each' when True + | SwitchStat JStgExpr [(JStgExpr, JStgStat)] JStgStat -- ^ Switch + | TryStat JStgStat Ident JStgStat JStgStat -- ^ Try + | BlockStat [JStgStat] -- ^ Blocks + | ApplStat JStgExpr [JStgExpr] -- ^ Application + | UOpStat UOp JStgExpr -- ^ Unary operators + | AssignStat JStgExpr AOp JStgExpr -- ^ Binding form: @foo = bar@ + | LabelStat JsLabel JStgStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JsLabel) -- ^ Break + | ContinueStat (Maybe JsLabel) -- ^ Continue + | FuncStat !Ident [Ident] JStgStat -- ^ an explicit function definition + deriving (Eq, Generic) + +-- | A Label used for 'JStgStat', specifically 'BreakStat', 'ContinueStat' and of +-- course 'LabelStat' +type JsLabel = LexicalFastString + +instance Semigroup JStgStat where + (<>) = appendJStgStat + +instance Monoid JStgStat where + mempty = BlockStat [] + +-- | Append a statement to another statement. 'appendJStgStat' only returns a +-- 'JStgStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty +-- 'BlockStat'. That is: +-- > (BlockStat [] , y ) = y +-- > (x , BlockStat []) = x +appendJStgStat :: JStgStat -> JStgStat -> JStgStat +appendJStgStat mx my = case (mx,my) of + (BlockStat [] , y ) -> y + (x , BlockStat []) -> x + (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys + (BlockStat xs , ys ) -> BlockStat $ xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $ xs : ys + (xs , ys ) -> BlockStat [xs,ys] + + +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- +-- | JavaScript Expressions +data JStgExpr + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JStgExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + | IdxExpr JStgExpr JStgExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' + | InfixExpr Op JStgExpr JStgExpr -- ^ Infix Expressions, see 'JStgExpr' pattern synonyms + | UOpExpr UOp JStgExpr -- ^ Unary Expressions + | IfExpr JStgExpr JStgExpr JStgExpr -- ^ If-expression + | ApplExpr JStgExpr [JStgExpr] -- ^ Application + deriving (Eq, Generic) + +instance Outputable JStgExpr where + ppr x = case x of + ValExpr _ -> text ("ValExpr" :: String) + SelExpr x' _ -> text ("SelExpr" :: String) <+> ppr x' + IdxExpr x' y' -> text ("IdxExpr" :: String) <+> ppr (x', y') + InfixExpr _ x' y' -> text ("InfixExpr" :: String) <+> ppr (x', y') + UOpExpr _ x' -> text ("UOpExpr" :: String) <+> ppr x' + IfExpr p t e -> text ("IfExpr" :: String) <+> ppr (p, t, e) + ApplExpr x' xs -> text ("ApplExpr" :: String) <+> ppr (x', xs) + +-- * Useful pattern synonyms to ease programming with the deeply embedded JS +-- AST. Each pattern wraps @UOp@ and @Op@ into a @JStgExpr@s to save typing and +-- for convienience. In addition we include a string wrapper for JS string +-- and Integer literals. + +-- | pattern synonym for a unary operator new +pattern New :: JStgExpr -> JStgExpr +pattern New x = UOpExpr NewOp x + +-- | pattern synonym for prefix increment @++x@ +pattern PreInc :: JStgExpr -> JStgExpr +pattern PreInc x = UOpExpr PreIncOp x + +-- | pattern synonym for postfix increment @x++@ +pattern PostInc :: JStgExpr -> JStgExpr +pattern PostInc x = UOpExpr PostIncOp x + +-- | pattern synonym for prefix decrement @--x@ +pattern PreDec :: JStgExpr -> JStgExpr +pattern PreDec x = UOpExpr PreDecOp x + +-- | pattern synonym for postfix decrement @--x@ +pattern PostDec :: JStgExpr -> JStgExpr +pattern PostDec x = UOpExpr PostDecOp x + +-- | pattern synonym for logical not @!@ +pattern Not :: JStgExpr -> JStgExpr +pattern Not x = UOpExpr NotOp x + +-- | pattern synonym for unary negation @-@ +pattern Negate :: JStgExpr -> JStgExpr +pattern Negate x = UOpExpr NegOp x + +-- | pattern synonym for addition @+@ +pattern Add :: JStgExpr -> JStgExpr -> JStgExpr +pattern Add x y = InfixExpr AddOp x y + +-- | pattern synonym for subtraction @-@ +pattern Sub :: JStgExpr -> JStgExpr -> JStgExpr +pattern Sub x y = InfixExpr SubOp x y + +-- | pattern synonym for multiplication @*@ +pattern Mul :: JStgExpr -> JStgExpr -> JStgExpr +pattern Mul x y = InfixExpr MulOp x y + +-- | pattern synonym for division @*@ +pattern Div :: JStgExpr -> JStgExpr -> JStgExpr +pattern Div x y = InfixExpr DivOp x y + +-- | pattern synonym for remainder @%@ +pattern Mod :: JStgExpr -> JStgExpr -> JStgExpr +pattern Mod x y = InfixExpr ModOp x y + +-- | pattern synonym for Bitwise Or @|@ +pattern BOr :: JStgExpr -> JStgExpr -> JStgExpr +pattern BOr x y = InfixExpr BOrOp x y + +-- | pattern synonym for Bitwise And @&@ +pattern BAnd :: JStgExpr -> JStgExpr -> JStgExpr +pattern BAnd x y = InfixExpr BAndOp x y + +-- | pattern synonym for Bitwise XOr @^@ +pattern BXor :: JStgExpr -> JStgExpr -> JStgExpr +pattern BXor x y = InfixExpr BXorOp x y + +-- | pattern synonym for Bitwise Not @~@ +pattern BNot :: JStgExpr -> JStgExpr +pattern BNot x = UOpExpr BNotOp x + +-- | pattern synonym for logical Or @||@ +pattern LOr :: JStgExpr -> JStgExpr -> JStgExpr +pattern LOr x y = InfixExpr LOrOp x y + +-- | pattern synonym for logical And @&&@ +pattern LAnd :: JStgExpr -> JStgExpr -> JStgExpr +pattern LAnd x y = InfixExpr LAndOp x y + +-- | pattern synonym to create integer values +pattern Int :: Integer -> JStgExpr +pattern Int x = ValExpr (JInt x) + +-- | pattern synonym to create string values +pattern String :: FastString -> JStgExpr +pattern String x = ValExpr (JStr x) + +-- | pattern synonym to create a local variable reference +pattern Var :: Ident -> JStgExpr +pattern Var x = ValExpr (JVar x) + +-- | pattern synonym to create an anonymous function +pattern Func :: [Ident] -> JStgStat -> JStgExpr +pattern Func args body = ValExpr (JFunc args body) + +-------------------------------------------------------------------------------- +-- Values +-------------------------------------------------------------------------------- +-- | JavaScript values +data JVal + = JVar Ident -- ^ A variable reference + | JList [JStgExpr] -- ^ A JavaScript list, or what JS + -- calls an Array + | JDouble SaneDouble -- ^ A Double + | JInt Integer -- ^ A BigInt + | JStr FastString -- ^ A String + | JRegEx FastString -- ^ A Regex + | JBool Bool -- ^ A Boolean + | JHash (UniqMap FastString JStgExpr) -- ^ A JS HashMap: @{"foo": 0}@ + | JFunc [Ident] JStgStat -- ^ A function + deriving (Eq, Generic) + +-------------------------------------------------------------------------------- +-- Operators +-------------------------------------------------------------------------------- +-- | JS Binary Operators. We do not deeply embed the comma operator and the +-- assignment operators +data Op + = EqOp -- ^ Equality: `==` + | StrictEqOp -- ^ Strict Equality: `===` + | NeqOp -- ^ InEquality: `!=` + | StrictNeqOp -- ^ Strict InEquality `!==` + | GtOp -- ^ Greater Than: `>` + | GeOp -- ^ Greater Than or Equal: `>=` + | LtOp -- ^ Less Than: < + | LeOp -- ^ Less Than or Equal: <= + | AddOp -- ^ Addition: + + | SubOp -- ^ Subtraction: - + | MulOp -- ^ Multiplication \* + | DivOp -- ^ Division: \/ + | ModOp -- ^ Remainder: % + | LeftShiftOp -- ^ Left Shift: \<\< + | RightShiftOp -- ^ Right Shift: \>\> + | ZRightShiftOp -- ^ Unsigned RightShift: \>\>\> + | BAndOp -- ^ Bitwise And: & + | BOrOp -- ^ Bitwise Or: | + | BXorOp -- ^ Bitwise XOr: ^ + | LAndOp -- ^ Logical And: && + | LOrOp -- ^ Logical Or: || + | InstanceofOp -- ^ @instanceof@ + | InOp -- ^ @in@ + deriving (Show, Eq, Ord, Enum, Data, Generic) + +instance NFData Op + +-- | JS Unary Operators +data UOp + = NotOp -- ^ Logical Not: @!@ + | BNotOp -- ^ Bitwise Not: @~@ + | NegOp -- ^ Negation: @-@ + | PlusOp -- ^ Unary Plus: @+x@ + | NewOp -- ^ new x + | TypeofOp -- ^ typeof x + | DeleteOp -- ^ delete x + | YieldOp -- ^ yield x + | VoidOp -- ^ void x + | PreIncOp -- ^ Prefix Increment: @++x@ + | PostIncOp -- ^ Postfix Increment: @x++@ + | PreDecOp -- ^ Prefix Decrement: @--x@ + | PostDecOp -- ^ Postfix Decrement: @x--@ + deriving (Show, Eq, Ord, Enum, Data, Generic) + +instance NFData UOp + +-- | JS Unary Operators +data AOp + = AssignOp -- ^ Vanilla Assignment: = + | AddAssignOp -- ^ Addition Assignment: += + | SubAssignOp -- ^ Subtraction Assignment: -= + deriving (Show, Eq, Ord, Enum, Data, Generic) + +instance NFData AOp + +-- | construct a JS reference, intended to refer to a global name +global :: FastString -> JStgExpr +global = Var . name + +-- | construct a JS reference, intended to refer to a local name +local :: FastString -> JStgExpr +local = Var . name diff --git a/GHC/JS/Make.hs b/GHC/JS/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Make.hs @@ -0,0 +1,836 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JStgExpr + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Make +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Make defines helper functions to ease the creation of JavaScript +-- ASTs as defined in 'GHC.JS.Syntax'. Its purpose is twofold: make the EDSL +-- more ergonomic to program in, and make errors in the EDSL /look/ obvious +-- because the EDSL is untyped. It is primarily concerned with injecting +-- terms into the domain of the EDSL to construct JS programs in Haskell. +-- +-- * Strategy +-- +-- The strategy for this module comes straight from gentzen; where we have +-- two types of helper functions. Functions which inject terms into the +-- EDSL, and combinator functions which operate on terms in the EDSL to +-- construct new terms in the EDSL. Crucially, missing from this module are +-- corresponding /elimination/ or /destructing/ functions which would +-- project information from the EDSL back to Haskell. See +-- 'GHC.StgToJS.Utils' for such functions. +-- +-- * /Introduction/ functions +-- +-- We define various primitive helpers which /introduce/ terms in the +-- EDSL, for example 'jVar', 'jLam', and 'var' and 'jString'. +-- Similarly this module exports four typeclasses 'ToExpr', 'ToStat', +-- 'JVarMagic', 'JSArgument'. 'ToExpr' injects values as a JS +-- expression into the EDSL. 'ToStat' injects values as JS statements +-- into the EDSL. @JVarMagic@ provides a polymorphic way to introduce +-- a new name into the EDSL and @JSArgument@ provides a polymorphic +-- way to bind variable names for use in JS functions with different +-- arities. +-- +-- * /Combinator/ functions +-- +-- The rest of the module defines combinators which create terms in +-- the EDSL from terms in the EDSL. Notable examples are '|=' and +-- '||=', '|=' is sugar for 'AssignStat', it is a binding form that +-- declares @foo = bar@ /assuming/ foo has been already declared. +-- '||=' is more sugar on top of '|=', it is also a binding form that +-- declares the LHS of '|=' before calling '|=' to bind a value, bar, +-- to a variable foo. Other common examples are the 'if_' and 'math_' +-- helpers such as 'math_cos'. +-- +-- * Consumers +-- +-- The entire JS backend consumes this module, e.g., the modules in +-- GHC.StgToJS.\*. +-- +-- * Notation +-- +-- In this module we use @==>@ in docstrings to show the translation from +-- the JS EDSL domain to JS code. For example, @foo ||= bar ==> var foo; foo +-- = bar;@ should be read as @foo ||= bar@ is in the EDSL domain and results +-- in the JS code @var foo; foo = bar;@ when compiled. +-- +-- In most cases functions prefixed with a 'j' are monadic because the +-- observably allocate. Notable exceptions are `jwhenS`, 'jString' and the +-- helpers for HashMaps. +----------------------------------------------------------------------------- +module GHC.JS.Make + ( -- * Injection Type classes + -- $classes + ToJExpr(..) + , ToStat(..) + , JVarMagic(..) + , JSArgument(..) + -- * Introduction functions + -- $intro_funcs + , jString + , jLam, jLam', jFunction, jFunctionSized, jFunction' + , jVar, jVars, jFor, jForIn, jForEachIn, jTryCatchFinally + -- * Combinators + -- $combinators + , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!) + , (.>.), (.>=.), (.<.), (.<=.) + , (.<<.), (.>>.), (.>>>.) + , (.|.), (.||.), (.&&.) + , if_, if10, if01, ifS, ifBlockS, jBlock, jIf + , jwhenS + , app, appS, returnS + , loop, loopBlockS + , preIncrS, postIncrS + , preDecrS, postDecrS + , off8, off16, off32, off64 + , mask8, mask16 + , signExtend8, signExtend16 + , typeOf + , returnStack, assignAllEqual, assignAll, assignAllReverseOrder + , declAssignAll + , nullStat, (.^) + -- ** Hash combinators + , jhEmpty + , jhSingle + , jhAdd + , jhFromList + -- * Literals + -- $literals + , null_ + , undefined_ + , false_ + , true_ + , zero_ + , one_ + , two_ + , three_ + -- ** Math functions + -- $math + , math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, + math_atan, math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, + math_cosh, math_sinh, math_tanh, math_expm1, math_log1p, math_fround, + math_min, math_max + -- * Statement helpers + , Solo(..) + , decl + ) +where + +import GHC.Prelude hiding ((.|.)) + +import GHC.JS.Ident +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import GHC.JS.Transform + +import Control.Arrow ((***)) +import Control.Monad (replicateM) +import Data.Tuple + +import qualified Data.Map as M + +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Types.Unique.Map + +-------------------------------------------------------------------------------- +-- Type Classes +-------------------------------------------------------------------------------- +-- $classes +-- The 'ToJExpr' class handles injection of of things into the EDSL as a JS +-- expression + +-- | Things that can be marshalled into javascript values. +-- Instantiate for any necessary data structures. +class ToJExpr a where + toJExpr :: a -> JStgExpr + toJExprFromList :: [a] -> JStgExpr + toJExprFromList = ValExpr . JList . map toJExpr + +instance ToJExpr a => ToJExpr [a] where + toJExpr = toJExprFromList + +instance ToJExpr JStgExpr where + toJExpr = id + +instance ToJExpr () where + toJExpr _ = ValExpr $ JList [] + +instance ToJExpr Bool where + toJExpr True = global "true" + toJExpr False = global "false" + +instance ToJExpr JVal where + toJExpr = ValExpr + +instance ToJExpr a => ToJExpr (UniqMap FastString a) where + toJExpr = ValExpr . JHash . mapUniqMap toJExpr + +instance ToJExpr a => ToJExpr (M.Map String a) where + toJExpr = ValExpr . JHash . listToUniqMap . map (mkFastString *** toJExpr) . M.toList + +instance ToJExpr Double where + toJExpr = ValExpr . JDouble . SaneDouble + +instance ToJExpr Int where + toJExpr = ValExpr . JInt . fromIntegral + +instance ToJExpr Integer where + toJExpr = ValExpr . JInt + +instance ToJExpr Char where + toJExpr = ValExpr . JStr . mkFastString . (:[]) + toJExprFromList = ValExpr . JStr . mkFastString +-- where escQuotes = tailDef "" . initDef "" . show + +instance ToJExpr Ident where + toJExpr = ValExpr . JVar + +instance ToJExpr FastString where + toJExpr = ValExpr . JStr + +instance (ToJExpr a, ToJExpr b) => ToJExpr (a,b) where + toJExpr (a,b) = ValExpr . JList $ [toJExpr a, toJExpr b] + +instance (ToJExpr a, ToJExpr b, ToJExpr c) => ToJExpr (a,b,c) where + toJExpr (a,b,c) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c] + +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d) => ToJExpr (a,b,c,d) where + toJExpr (a,b,c,d) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d] +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e) => ToJExpr (a,b,c,d,e) where + toJExpr (a,b,c,d,e) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e] +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e, ToJExpr f) => ToJExpr (a,b,c,d,e,f) where + toJExpr (a,b,c,d,e,f) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f] + + +-- | The 'ToStat' class handles injection of of things into the EDSL as a JS +-- statement. This ends up being polymorphic sugar for JS blocks, see helper +-- function 'GHC.JS.Make.expr2stat'. Instantiate for any necessary data +-- structures. +class ToStat a where + toStat :: a -> JStgStat + +instance ToStat JStgStat where + toStat = id + +instance ToStat [JStgStat] where + toStat = BlockStat + +instance ToStat JStgExpr where + toStat = expr2stat + +instance ToStat [JStgExpr] where + toStat = BlockStat . map expr2stat + +-- | Convert A JS expression to a JS statement where applicable. This only +-- affects applications; 'ApplExpr', If-expressions; 'IfExpr', and Unary +-- expression; 'UOpExpr'. +expr2stat :: JStgExpr -> JStgStat +expr2stat (ApplExpr x y) = (ApplStat x y) +expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z) +expr2stat (UOpExpr o x) = UOpStat o x +expr2stat _ = nullStat + +-------------------------------------------------------------------------------- +-- Introduction Functions +-------------------------------------------------------------------------------- +-- $intro_functions +-- Introduction functions are functions that map values or terms in the Haskell +-- domain to the JS EDSL domain + +-- | Create a new anonymous function. The result is a 'GHC.JS.Syntax.JExpr' +-- expression. +-- Usage: +-- +-- > jLam $ \x -> jVar x + one_ +-- > jLam $ \f -> (jLam $ \x -> (f `app` (x `app` x))) `app` (jLam $ \x -> (f `app` (x `app` x))) +jLam :: JSArgument args => (args -> JSM JStgStat) -> JSM JStgExpr +jLam body = do xs <- args + ValExpr . JFunc (argList xs) <$> body xs + +-- | Special case of @jLam@ where the anonymous function requires no fresh +-- arguments. +jLam' :: JStgStat -> JStgExpr +jLam' body = ValExpr $ JFunc mempty body + +-- | Introduce only one new variable into scope for the duration of the +-- enclosed expression. The result is a block statement. Usage: +-- +-- 'jVar $ \x -> mconcat [jVar x ||= one_, ...' +jVar :: (JVarMagic t, ToJExpr t) => (t -> JSM JStgStat) -> JSM JStgStat +jVar f = jVars $ \(MkSolo only_one) -> f only_one + +-- | Introduce one or many new variables into scope for the duration of the +-- enclosed expression. This function reifies the number of arguments based on +-- the container of the input function. We intentionally avoid lists and instead +-- opt for tuples because lists are not sized in general. The result is a block +-- statement. Usage: +-- +-- @jVars $ \(x,y) -> mconcat [ x |= one_, y |= two_, x + y]@ +jVars :: (JSArgument args) => (args -> JSM JStgStat) -> JSM JStgStat +jVars f = do as <- args + body <- f as + return $ mconcat $ fmap decl (argList as) ++ [body] + +-- | Construct a top-level function subject to JS hoisting. This combinator is +-- polymorphic over function arity so you can you use to define a JS syntax +-- object in Haskell, which is a function in JS that takes 2 or 4 or whatever +-- arguments. For a singleton function use the @Solo@ constructor @MkSolo@. +-- Usage: +-- +-- an example from the Rts that defines a 1-arity JS function +-- > jFunction (global "h$getReg") (\(MkSolo n) -> return $ SwitchStat n getRegCases mempty) +-- +-- an example of a two argument function from the Rts +-- > jFunction (global "h$bh_lne") (\(x, frameSize) -> bhLneStats s x frameSize) +jFunction + :: (JSArgument args) + => Ident -- ^ global name + -> (args -> JSM JStgStat) -- ^ function body, input is locally unique generated variables + -> JSM JStgStat +jFunction name body = do + func_args <- args + FuncStat name (argList func_args) <$> (body func_args) + +-- | Construct a top-level function subject to JS hoisting. Special case where +-- the arity cannot be deduced from the 'args' parameter (atleast not without +-- dependent types). +jFunctionSized + :: Ident -- ^ global name + -> Int -- ^ Arity + -> ([JStgExpr] -> JSM JStgStat) -- ^ function body, input is locally unique generated variables + -> JSM JStgStat +jFunctionSized name arity body = do + func_args <- replicateM arity newIdent + FuncStat name func_args <$> (body $ toJExpr <$> func_args) + +-- | Construct a top-level function subject to JS hoisting. Special case where +-- the function binds no parameters +jFunction' + :: Ident -- ^ global name + -> JSM JStgStat -- ^ function body, input is locally unique generated variables + -> JSM JStgStat +jFunction' name body = FuncStat name mempty <$> body + +jBlock :: Monoid a => [JSM a] -> JSM a +jBlock = fmap mconcat . sequence + +-- | Create a 'for in' statement. +-- Usage: +-- +-- @jForIn {expression} $ \x -> {block involving x}@ +jForIn :: JStgExpr -> (JStgExpr -> JStgStat) -> JSM JStgStat +jForIn e f = do + i <- newIdent + return $ decl i `mappend` ForInStat False i e (f (ValExpr $! JVar i)) + +-- | As with "jForIn" but creating a \"for each in\" statement. +jForEachIn :: JStgExpr -> (JStgExpr -> JStgStat) -> JSM JStgStat +jForEachIn e f = do i <- newIdent + return $ decl i `mappend` ForInStat True i e (f (ValExpr $! JVar i)) + +-- | Create a 'for' statement given a function for initialization, a predicate +-- to step to, a step and a body +-- Usage: +-- +-- @ jFor (|= zero_) (.<. Int 65536) preIncrS +-- (\j -> ...something with the counter j...)@ +-- +jFor :: (JStgExpr -> JStgStat) -- ^ initialization function + -> (JStgExpr -> JStgExpr) -- ^ predicate + -> (JStgExpr -> JStgStat) -- ^ step function + -> (JStgExpr -> JStgStat) -- ^ body + -> JSM JStgStat +jFor init pred step body = do id <- newIdent + let i = ValExpr (JVar id) + return + $ decl id `mappend` ForStat (init i) (pred i) (step i) (body i) + +-- | As with "jForIn" but creating a \"for each in\" statement. +jTryCatchFinally :: (Ident -> JStgStat) -> (Ident -> JStgStat) -> (Ident -> JStgStat) -> JSM JStgStat +jTryCatchFinally c f f2 = do i <- newIdent + return $ TryStat (c i) i (f i) (f2 i) + +-- | Convert a FastString to a Javascript String +jString :: FastString -> JStgExpr +jString = toJExpr + +-- | construct a js declaration with the given identifier +decl :: Ident -> JStgStat +decl i = DeclStat i Nothing + +-- | The empty JS HashMap +jhEmpty :: M.Map k JStgExpr +jhEmpty = M.empty + +-- | A singleton JS HashMap +jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JStgExpr +jhSingle k v = jhAdd k v jhEmpty + +-- | insert a key-value pair into a JS HashMap +jhAdd :: (Ord k, ToJExpr a) => k -> a -> M.Map k JStgExpr -> M.Map k JStgExpr +jhAdd k v m = M.insert k (toJExpr v) m + +-- | Construct a JS HashMap from a list of key-value pairs +jhFromList :: [(FastString, JStgExpr)] -> JVal +jhFromList = JHash . listToUniqMap + +-- | The empty JS statement +nullStat :: JStgStat +nullStat = BlockStat [] + + +-------------------------------------------------------------------------------- +-- Combinators +-------------------------------------------------------------------------------- +-- $combinators +-- Combinators operate on terms in the JS EDSL domain to create new terms in the +-- EDSL domain. + +-- | JS infix Equality operators +(.==.), (.===.), (.!=.), (.!==.) :: JStgExpr -> JStgExpr -> JStgExpr +(.==.) = InfixExpr EqOp +(.===.) = InfixExpr StrictEqOp +(.!=.) = InfixExpr NeqOp +(.!==.) = InfixExpr StrictNeqOp + +infixl 6 .==., .===., .!=., .!==. + +-- | JS infix Ord operators +(.>.), (.>=.), (.<.), (.<=.) :: JStgExpr -> JStgExpr -> JStgExpr +(.>.) = InfixExpr GtOp +(.>=.) = InfixExpr GeOp +(.<.) = InfixExpr LtOp +(.<=.) = InfixExpr LeOp + +infixl 7 .>., .>=., .<., .<=. + +-- | JS infix bit operators +(.|.), (.||.), (.&&.) :: JStgExpr -> JStgExpr -> JStgExpr +(.|.) = InfixExpr BOrOp +(.||.) = InfixExpr LOrOp +(.&&.) = InfixExpr LAndOp + +infixl 8 .||., .&&. + +-- | JS infix bit shift operators +(.<<.), (.>>.), (.>>>.) :: JStgExpr -> JStgExpr -> JStgExpr +(.<<.) = InfixExpr LeftShiftOp +(.>>.) = InfixExpr RightShiftOp +(.>>>.) = InfixExpr ZRightShiftOp + +infixl 9 .<<., .>>., .>>>. + +-- | Given a 'JStgExpr', return the its type. +typeOf :: JStgExpr -> JStgExpr +typeOf = UOpExpr TypeofOp + +-- | JS if-expression +-- +-- > if_ e1 e2 e3 ==> e1 ? e2 : e3 +if_ :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr +if_ e1 e2 e3 = IfExpr e1 e2 e3 + +-- | If-expression which returns statements, see related 'ifBlockS' +-- +-- > if e s1 s2 ==> if(e) { s1 } else { s2 } +ifS :: JStgExpr -> JStgStat -> JStgStat -> JStgStat +ifS e s1 s2 = IfStat e s1 s2 + + +-- | Version of a JS if-expression which admits monadic actions in its branches +jIf :: JStgExpr -> JSM JStgStat -> JSM JStgStat -> JSM JStgStat +jIf e ma mb = do + !a <- ma + !b <- mb + pure $ IfStat e a b + +-- | A when-statement as syntactic sugar via `ifS` +-- +-- > jwhenS cond block ==> if(cond) { block } else { } +jwhenS :: JStgExpr -> JStgStat -> JStgStat +jwhenS cond block = IfStat cond block mempty + +-- | If-expression which returns blocks +-- +-- > ifBlockS e s1 s2 ==> if(e) { s1 } else { s2 } +ifBlockS :: JStgExpr -> [JStgStat] -> [JStgStat] -> JStgStat +ifBlockS e s1 s2 = IfStat e (mconcat s1) (mconcat s2) + +-- | if-expression that returns 1 if condition <=> true, 0 otherwise +-- +-- > if10 e ==> e ? 1 : 0 +if10 :: JStgExpr -> JStgExpr +if10 e = IfExpr e one_ zero_ + +-- | if-expression that returns 0 if condition <=> true, 1 otherwise +-- +-- > if01 e ==> e ? 0 : 1 +if01 :: JStgExpr -> JStgExpr +if01 e = IfExpr e zero_ one_ + +-- | an application expression, see related 'appS' +-- +-- > app f xs ==> f(xs) +app :: FastString -> [JStgExpr] -> JStgExpr +app f xs = ApplExpr (global f) xs + +-- | A statement application, see the expression form 'app' +appS :: FastString -> [JStgExpr] -> JStgStat +appS f xs = ApplStat (global f) xs + +-- | Return a 'JStgExpr' +returnS :: JStgExpr -> JStgStat +returnS e = ReturnStat e + +-- | "for" loop with increment at end of body +loop :: JStgExpr -> (JStgExpr -> JStgExpr) -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat +loop initial test body_ = jVar $ \i -> + do body <- body_ i + return $ + mconcat [ i |= initial + , WhileStat False (test i) body + ] + +-- | "for" loop with increment at end of body +loopBlockS :: JStgExpr -> (JStgExpr -> JStgExpr) -> (JStgExpr -> [JStgStat]) -> JSM JStgStat +loopBlockS initial test body = jVar $ \i -> + return $ + mconcat [ i |= initial + , WhileStat False (test i) (mconcat (body i)) + ] + +-- | Prefix-increment a 'JStgExpr' +preIncrS :: JStgExpr -> JStgStat +preIncrS x = UOpStat PreIncOp x + +-- | Postfix-increment a 'JStgExpr' +postIncrS :: JStgExpr -> JStgStat +postIncrS x = UOpStat PostIncOp x + +-- | Prefix-decrement a 'JStgExpr' +preDecrS :: JStgExpr -> JStgStat +preDecrS x = UOpStat PreDecOp x + +-- | Postfix-decrement a 'JStgExpr' +postDecrS :: JStgExpr -> JStgStat +postDecrS x = UOpStat PostDecOp x + +-- | Byte indexing of o with a 64-bit offset +off64 :: JStgExpr -> JStgExpr -> JStgExpr +off64 o i = Add o (i .<<. three_) + +-- | Byte indexing of o with a 32-bit offset +off32 :: JStgExpr -> JStgExpr -> JStgExpr +off32 o i = Add o (i .<<. two_) + +-- | Byte indexing of o with a 16-bit offset +off16 :: JStgExpr -> JStgExpr -> JStgExpr +off16 o i = Add o (i .<<. one_) + +-- | Byte indexing of o with a 8-bit offset +off8 :: JStgExpr -> JStgExpr -> JStgExpr +off8 o i = Add o i + +-- | a bit mask to retrieve the lower 8-bits +mask8 :: JStgExpr -> JStgExpr +mask8 x = BAnd x (Int 0xFF) + +-- | a bit mask to retrieve the lower 16-bits +mask16 :: JStgExpr -> JStgExpr +mask16 x = BAnd x (Int 0xFFFF) + +-- | Sign-extend/narrow a 8-bit value +signExtend8 :: JStgExpr -> JStgExpr +signExtend8 x = (BAnd x (Int 0x7F )) `Sub` (BAnd x (Int 0x80)) + +-- | Sign-extend/narrow a 16-bit value +signExtend16 :: JStgExpr -> JStgExpr +signExtend16 x = (BAnd x (Int 0x7FFF)) `Sub` (BAnd x (Int 0x8000)) + +-- | Select a property 'prop', from and object 'obj' +-- +-- > obj .^ prop ==> obj.prop +(.^) :: JStgExpr -> FastString -> JStgExpr +obj .^ prop = SelExpr obj (name prop) +infixl 8 .^ + +-- | Assign a variable to an expression +-- +-- > foo |= expr ==> var foo = expr; +(|=) :: JStgExpr -> JStgExpr -> JStgStat +(|=) l r = AssignStat l AssignOp r + +-- | Declare a variable and then Assign the variable to an expression +-- +-- > foo |= expr ==> var foo; foo = expr; +(||=) :: Ident -> JStgExpr -> JStgStat +i ||= ex = DeclStat i (Just ex) + +infixl 2 ||=, |= + +-- | return the expression at idx of obj +-- +-- > obj .! idx ==> obj[idx] +(.!) :: JStgExpr -> JStgExpr -> JStgExpr +(.!) = IdxExpr + +infixl 8 .! + +assignAllEqual :: HasDebugCallStack => [JStgExpr] -> [JStgExpr] -> JStgStat +assignAllEqual xs ys = mconcat (zipWithEqual (|=) xs ys) + +assignAll :: [JStgExpr] -> [JStgExpr] -> JStgStat +assignAll xs ys = mconcat (zipWith (|=) xs ys) + +assignAllReverseOrder :: [JStgExpr] -> [JStgExpr] -> JStgStat +assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys)) + +declAssignAll :: [Ident] -> [JStgExpr] -> JStgStat +declAssignAll xs ys = mconcat (zipWith (||=) xs ys) + + +-------------------------------------------------------------------------------- +-- Literals +-------------------------------------------------------------------------------- +-- $literals +-- Literals in the JS EDSL are constants in the Haskell domain. These are useful +-- helper values and never change + +-- | The JS literal 'null' +null_ :: JStgExpr +null_ = global "null" + +-- | The JS literal 0 +zero_ :: JStgExpr +zero_ = Int 0 + +-- | The JS literal 1 +one_ :: JStgExpr +one_ = Int 1 + +-- | The JS literal 2 +two_ :: JStgExpr +two_ = Int 2 + +-- | The JS literal 3 +three_ :: JStgExpr +three_ = Int 3 + +-- | The JS literal 'undefined' +undefined_ :: JStgExpr +undefined_ = global "undefined" + +-- | The JS literal 'true' +true_ :: JStgExpr +true_ = ValExpr (JBool True) + +-- | The JS literal 'false' +false_ :: JStgExpr +false_ = ValExpr (JBool False) + +returnStack :: JStgStat +returnStack = ReturnStat (ApplExpr (global "h$rs") []) + + +-------------------------------------------------------------------------------- +-- Math functions +-------------------------------------------------------------------------------- +-- $math +-- Math functions in the EDSL are literals, with the exception of 'math_' which +-- is the sole math introduction function. + +math :: JStgExpr +math = global "Math" + +math_ :: FastString -> [JStgExpr] -> JStgExpr +math_ op args = ApplExpr (math .^ op) args + +math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, math_atan, + math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, math_sign, + math_sinh, math_cosh, math_tanh, math_expm1, math_log1p, math_fround, + math_min, math_max + :: [JStgExpr] -> JStgExpr +math_log = math_ "log" +math_sin = math_ "sin" +math_cos = math_ "cos" +math_tan = math_ "tan" +math_exp = math_ "exp" +math_acos = math_ "acos" +math_asin = math_ "asin" +math_atan = math_ "atan" +math_abs = math_ "abs" +math_pow = math_ "pow" +math_sign = math_ "sign" +math_sqrt = math_ "sqrt" +math_asinh = math_ "asinh" +math_acosh = math_ "acosh" +math_atanh = math_ "atanh" +math_sinh = math_ "sinh" +math_cosh = math_ "cosh" +math_tanh = math_ "tanh" +math_expm1 = math_ "expm1" +math_log1p = math_ "log1p" +math_fround = math_ "fround" +math_min = math_ "min" +math_max = math_ "max" + +instance Num JStgExpr where + x + y = InfixExpr AddOp x y + x - y = InfixExpr SubOp x y + x * y = InfixExpr MulOp x y + abs x = math_abs [x] + negate x = UOpExpr NegOp x + signum x = math_sign [x] + fromInteger x = ValExpr (JInt x) + +instance Fractional JStgExpr where + x / y = InfixExpr DivOp x y + fromRational x = ValExpr (JDouble (realToFrac x)) + + + +-------------------------------------------------------------------------------- +-- New Identifiers +-------------------------------------------------------------------------------- + +-- | Type class that generates fresh @a@'s for the JS backend. You should almost +-- never need to use this directly. Instead use @JSArgument@, for examples of +-- how to employ these classes please see @jVar@, @jFunction@ and call sites in +-- the Rts. +class JVarMagic a where + fresh :: JSM a + +-- | Type class that finds the form of arguments required for a JS syntax +-- object. This class gives us a single interface to generate variables for +-- functions that have different arities. Thus with it, we can have only one +-- @jFunction@ which is polymorphic over its arity, instead of 'jFunction2', +-- 'jFunction3' and so on. +class JSArgument args where + argList :: args -> [Ident] + args :: JSM args + +instance JVarMagic Ident where + fresh = newIdent + +instance JVarMagic JVal where + fresh = JVar <$> fresh + +instance JVarMagic JStgExpr where + fresh = do i <- fresh + return $ ValExpr $ JVar i + +instance (JVarMagic a, ToJExpr a) => JSArgument (Solo a) where + argList (MkSolo a) = concatMap identsE [toJExpr a] + args = do i <- fresh + return $ MkSolo i + +instance (JVarMagic a, JVarMagic b, ToJExpr a, ToJExpr b) => JSArgument (a,b) where + argList (a,b) = concatMap identsE [toJExpr a , toJExpr b] + args = (,) <$> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + ) => JSArgument (a,b,c) where + argList (a,b,c) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c] + args = (,,) <$> fresh <*> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + ) => JSArgument (a,b,c,d) where + argList (a,b,c,d) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d] + args = (,,,) <$> fresh <*> fresh <*> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + ) => JSArgument (a,b,c,d,e) where + argList (a,b,c,d,e) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e] + args = (,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + , JVarMagic f, ToJExpr f + ) => JSArgument (a,b,c,d,e,f) where + argList (a,b,c,d,e,f) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f] + args = (,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + , JVarMagic f, ToJExpr f + , JVarMagic g, ToJExpr g + ) => JSArgument (a,b,c,d,e,f,g) where + argList (a,b,c,d,e,f,g) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g] + args = (,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + , JVarMagic f, ToJExpr f + , JVarMagic g, ToJExpr g + , JVarMagic h, ToJExpr h + ) => JSArgument (a,b,c,d,e,f,g,h) where + argList (a,b,c,d,e,f,g,h) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h] + args = (,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + , JVarMagic f, ToJExpr f + , JVarMagic g, ToJExpr g + , JVarMagic h, ToJExpr h + , JVarMagic i, ToJExpr i + ) => JSArgument (a,b,c,d,e,f,g,h,i) where + argList (a,b,c,d,e,f,g,h,i) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h, toJExpr i] + args = (,,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh + + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + , JVarMagic f, ToJExpr f + , JVarMagic g, ToJExpr g + , JVarMagic h, ToJExpr h + , JVarMagic i, ToJExpr i + , JVarMagic j, ToJExpr j + ) => JSArgument (a,b,c,d,e,f,g,h,i,j) where + argList (a,b,c,d,e,f,g,h,i,j) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h, toJExpr i, toJExpr j] + args = (,,,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh diff --git a/GHC/JS/Opt/Expr.hs b/GHC/JS/Opt/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Opt/Expr.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Opt.Expr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- This module contains a simple expression optimizer that performs constant +-- folding and some boolean expression optimizations. +----------------------------------------------------------------------------- + +module GHC.JS.Opt.Expr (optExprs) where + +import GHC.Prelude hiding (shiftL, shiftR) + +import GHC.JS.Syntax + +import Data.Bifunctor (second) +import Data.Bits (shiftL, shiftR, (.^.)) +import Data.Int (Int32) + +{- + Optimize expressions in a statement. + + This is best done after running the simple optimizer in GHC.JS.Opt.Simple, + which eliminates redundant assignments and produces expressions that can be + optimized more effectively. + -} +optExprs :: JStat -> JStat +optExprs s = go s + where + go (DeclStat v mb_e) = DeclStat v (fmap opt mb_e) + go (AssignStat lhs op rhs) = AssignStat (opt lhs) op (opt rhs) + go (ReturnStat e) = ReturnStat (opt e) + go (BlockStat ss) = BlockStat (map go ss) + go (IfStat e s1 s2) = IfStat (optCond e) (go s1) (go s2) + go (WhileStat b e s) = WhileStat b (optCond e) (go s) + go (ForStat s1 e s2 s3) = ForStat (go s1) (optCond e) (go s2) (go s3) + go (ForInStat b v e s) = ForInStat b v (opt e) (go s) + go (SwitchStat e cases s) = SwitchStat (opt e) + (map (second go) cases) + (go s) + go (TryStat s1 v s2 s3) = TryStat (go s1) v (go s2) (go s3) + go (ApplStat e es) = ApplStat (opt e) (map opt es) + go (UOpStat op e) = UOpStat op (opt e) + go (LabelStat lbl s) = LabelStat lbl (go s) + go s@(BreakStat{}) = s + go s@(ContinueStat{}) = s + go (FuncStat n vs s) = FuncStat n vs (go s) + + -- remove double negation if we're using the expression in a loop/if condition +optCond :: JExpr -> JExpr +optCond e = let f (UOpExpr NotOp (UOpExpr NotOp e')) = f e' + f e' = e' + in f (opt e) + +opt :: JExpr -> JExpr +opt (ValExpr v) = ValExpr v +opt (SelExpr e i) = SelExpr (opt e) i +opt (IdxExpr e1 e2) = IdxExpr (opt e1) (opt e2) +-- ((c_e ? 1 : 0) === 1) ==> !!c_e +-- ((c_e ? 1 : 0) === 0) ==> !c_e +opt(InfixExpr StrictEqOp (IfExpr c_e (opt -> t_e) (opt -> f_e)) (opt -> e)) + | ValExpr t_v <- t_e + , ValExpr v <- e + , eqVal t_v v = UOpExpr NotOp (UOpExpr NotOp c_e) + | ValExpr f_v <- f_e + , ValExpr v <- e + , eqVal f_v v = UOpExpr NotOp (opt c_e) + | otherwise = InfixExpr StrictEqOp (IfExpr c_e t_e f_e) e +-- (1 === (c_e ? 1 : 0)) ==> !!c_e +-- (0 === (c_e ? 1 : 0)) ==> !c_e +opt(InfixExpr StrictEqOp (opt -> e) (IfExpr (opt -> c_e) (opt -> t_e) (opt -> f_e))) + | ValExpr t_v <- t_e + , ValExpr v <- e + , eqVal t_v v = UOpExpr NotOp (UOpExpr NotOp c_e) + | ValExpr f_v <- f_e + , ValExpr v <- e + , eqVal f_v v = UOpExpr NotOp c_e + | otherwise = InfixExpr StrictEqOp e (IfExpr c_e t_e f_e) +opt (InfixExpr op (opt -> e1) (opt -> e2)) + | (ValExpr (JInt n1)) <- e1 + , (ValExpr (JInt n2)) <- e2 + , Just v <- optInt op n1 n2 = ValExpr v + | (ValExpr (JBool b1)) <- e1 + , (ValExpr (JBool b2)) <- e2 + , Just v <- optBool op b1 b2 = ValExpr v + | otherwise = InfixExpr op e1 e2 +opt (UOpExpr op e) = UOpExpr op (opt e) +opt (IfExpr e1 e2 e3) = IfExpr (optCond e1) (opt e2) (opt e3) +opt (ApplExpr e es) = ApplExpr (opt e) (map opt es) + +{- + Optimizations for operations on two known boolean values + -} +optBool :: Op -> Bool -> Bool -> Maybe JVal +optBool LAndOp x y = Just (JBool (x && y)) +optBool LOrOp x y = Just (JBool (x || y)) +optBool EqOp x y = Just (JBool (x == y)) +optBool StrictEqOp x y = Just (JBool (x == y)) +optBool NeqOp x y = Just (JBool (x /= y)) +optBool StrictNeqOp x y = Just (JBool (x /= y)) +optBool _ _ _ = Nothing + +{- + Optimizations for operations on two known integer values + -} +optInt :: Op -> Integer -> Integer -> Maybe JVal +optInt ZRightShiftOp n m = Just $ + JInt (toInteger $ (n .&. 0xffffffff) `shiftR` fromInteger (m .&. 0x1f)) +optInt BOrOp n m = Just (truncOp (.|.) n m) +optInt BAndOp n m = Just (truncOp (.&.) n m) +optInt BXorOp n m = Just (truncOp (.^.) n m) +optInt RightShiftOp n m = Just (shiftOp shiftR n m) +optInt LeftShiftOp n m = Just (shiftOp shiftL n m) +optInt AddOp n m = smallIntOp (+) n m +optInt SubOp n m = smallIntOp (-) n m +optInt MulOp n m = smallIntOp (*) n m +optInt op n m + | Just cmp <- getCmpOp op, isSmall52 n && isSmall52 m + = Just (JBool (cmp n m)) +optInt _ _ _ = Nothing + +smallIntOp :: (Integer -> Integer -> Integer) + -> Integer -> Integer -> Maybe JVal +smallIntOp op n m + | isSmall52 n && isSmall52 m && isSmall52 r = Just (JInt r) + | otherwise = Nothing + where + r = op n m + +getCmpOp :: Op -> Maybe (Integer -> Integer -> Bool) +getCmpOp EqOp = Just (==) +getCmpOp StrictEqOp = Just (==) +getCmpOp NeqOp = Just (/=) +getCmpOp StrictNeqOp = Just (/=) +getCmpOp GtOp = Just (>) +getCmpOp GeOp = Just (>=) +getCmpOp LtOp = Just (<) +getCmpOp LeOp = Just (<=) +getCmpOp _ = Nothing + +shiftOp :: (Int32 -> Int -> Int32) -> Integer -> Integer -> JVal +shiftOp op n m = JInt $ toInteger + (fromInteger n `op` (fromInteger m .&. 0x1f)) + +{- + JavaScript bitwise operations truncate numbers to 32 bit signed integers. + Here we do the same when constant folding with this kind of operators. + -} +truncOp :: (Int32 -> Int32 -> Int32) -> Integer -> Integer -> JVal +truncOp op n m = JInt $ toInteger + (fromInteger n `op` fromInteger m) + +{- + JavaScript numbers are IEEE 754 double precision floats, which have a + 52-bit mantissa. This returns True if the given integer can definitely + be represented without loss of precision in a JavaScript number. + -} +isSmall52 :: Integer -> Bool +isSmall52 n = n >= -0x10000000000000 && n <= 0xfffffffffffff + +{- + In JavaScript, e1 === e2 is not always true even if expressions e1 and e2 + are syntactically equal, examples: + + - NaN !== NaN (NaN is not equal to itself) + - [1] !== [1] (different arrays allocated) + - f() !== f() + + This returns True if the values are definitely equal in JavaScript + -} +eqVal :: JVal -> JVal -> Bool +eqVal (JInt n1) (JInt n2) = n1 == n2 +eqVal (JStr s1) (JStr s2) = s1 == s2 +eqVal (JBool b1) (JBool b2) = b1 == b2 +eqVal (JDouble (SaneDouble d1)) (JDouble (SaneDouble d2)) + | not (isNaN d1) && not (isNaN d2) = d1 == d2 +eqVal _ _ = False diff --git a/GHC/JS/Opt/Simple.hs b/GHC/JS/Opt/Simple.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Opt/Simple.hs @@ -0,0 +1,607 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Opt.Simple +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Simple optimizer for the JavaScript IR +-- +-- This is a simple optimizer for the JavaScript IR. It is intended to be +-- the first optimization pass after generating the JavaScript IR. +-- +-- * Design +-- +-- The optimizer is invoked on the top-level JStat. It leaves the top-level +-- scope alone, but traverses into each function body and optimizes it. +-- Nested functions are mostly left alone, since they are uncommon in +-- generated code. +-- +-- The optimizations are: +-- +-- - rename local variables to shorter names +-- - remove unused variables +-- - remove trivial assignments: x = x +-- - "float" expressions without side effects: +-- - var x = 1; var y = x + 1; -> var y = 1 + 1; +-- +-- * Limitations +-- +-- The simple optimization pass is intended to be fast and applicable to +-- almost all generated JavaScript code. Limitations are: +-- +-- - optimization is disabled if an `eval` statement is encountered +-- - variables declared in nested scopes are not renamed +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings #-} +module GHC.JS.Opt.Simple (simpleOpt) where + +import GHC.Prelude + +import GHC.JS.Opt.Expr +import GHC.JS.Syntax + +import GHC.Data.FastString +import qualified GHC.Types.Unique.Map as UM +import GHC.Types.Unique.Map (UniqMap) +import qualified GHC.Types.Unique.Set as US + +import Control.Monad +import Data.Function +import Data.List (sortBy) +import Data.Maybe +import qualified Data.Semigroup as Semi + + +data Multiplicity = Zero | One | Many + deriving (Eq, Ord, Show) + +data VarValue = Unassigned + | AssignedOnce + | AssignedOnceKnown !JExpr + | AssignedMany + +data VarDecl = NoDecl -- not declared in analyzed scope (possibly deeper or global) + | ArgDecl !Int -- argument in analyzed scope + | LocalDecl !Int -- local variable in analyzed scope + deriving (Eq, Show) + +isLocalOrArg :: VarDecl -> Bool +isLocalOrArg (LocalDecl {}) = True +isLocalOrArg (ArgDecl {}) = True +isLocalOrArg _ = False + +isDecl :: VarDecl -> Bool +isDecl NoDecl = False +isDecl _ = True + +instance Semi.Semigroup VarDecl where + NoDecl <> x = x + x <> NoDecl = x + ArgDecl n <> ArgDecl m = ArgDecl (min n m) + LocalDecl n <> LocalDecl m = LocalDecl (min n m) + ArgDecl n <> _ = ArgDecl n + _ <> ArgDecl n = ArgDecl n + +instance Ord VarDecl where + compare NoDecl NoDecl = EQ + compare NoDecl _ = LT + compare _ NoDecl = GT + compare (ArgDecl n) (ArgDecl m) = compare n m + compare (ArgDecl {}) _ = LT + compare _ (ArgDecl {}) = GT + compare (LocalDecl n) (LocalDecl m) = compare n m + +data JFunction = JFunction [Ident] JStat + +instance Semi.Semigroup VarValue where + Unassigned <> x = x + x <> Unassigned = x + _ <> _ = AssignedMany + +instance Monoid VarValue where + mempty = Unassigned + mappend = (Semi.<>) + +instance Semigroup Multiplicity where + Zero <> x = x + x <> Zero = x + _ <> _ = Many + +instance Monoid Multiplicity where + mempty = Zero + mappend = (Semi.<>) + +data VarUsage = VarUsage + { varUsed :: !Multiplicity + , varAssigned :: !VarValue + , varDeclared :: !VarDecl + , varDeepDeclared :: !Bool + } + +assignedMultiple :: VarUsage -> Bool +assignedMultiple VarUsage { varAssigned = AssignedMany } = True +assignedMultiple _ = False + +data SimpleRewrite = SimpleRewrite + { renameVar :: UniqMap Ident Ident + , varUsage :: UniqMap Ident VarUsage + } + +instance Semigroup VarUsage where + x <> y = VarUsage + { varUsed = varUsed x Semi.<> varUsed y + , varAssigned = varAssigned x Semi.<> varAssigned y + , varDeclared = varDeclared x Semi.<> varDeclared y + , varDeepDeclared = varDeepDeclared x || varDeepDeclared y + } + +instance Monoid VarUsage where + mempty = VarUsage Zero Unassigned NoDecl False + +disableOpt :: Bool +-- disableOpt = True +disableOpt = False + +simpleOpt :: JStat -> JStat +simpleOpt x | disableOpt = x +simpleOpt (BlockStat xs) = BlockStat (map simpleOpt xs) +simpleOpt (AssignStat lhs AssignOp (ValExpr (JFunc args body))) = + let JFunction args' body' = simpleOptFunction (JFunction args body) + in AssignStat lhs AssignOp (ValExpr (JFunc args' body')) +simpleOpt (FuncStat name args body) = + let JFunction args' body' = simpleOptFunction (JFunction args body) + in FuncStat name args' body' +simpleOpt s = s + +simpleOptFunction :: JFunction -> JFunction +simpleOptFunction jf = s_opt + where + -- we need to run it twice since floating in the first pass can + -- cause unused variables that can be removed in the second pass + s_opt = functionOptExprs $ maybe jf (`simpleRewrite` s_opt0) mb_rw + mb_rw = mkRewrite True (simpleAnalyze s_opt0) + s_opt0 = functionOptExprs $ maybe jf (`simpleRewrite` jf) mb_rw0 + mb_rw0 = mkRewrite False (simpleAnalyze jf) + +functionOptExprs :: JFunction -> JFunction +functionOptExprs (JFunction args s) = JFunction args (optExprs s) + +newLocals :: [Ident] +newLocals = filter (not . isReserved ) $ + map (TxtI . mkFastString) $ + map (:[]) chars0 ++ concatMap mkIdents [1..] + where + mkIdents n = [c0:cs | c0 <- chars0, cs <- replicateM n chars] + chars0 = ['a'..'z']++['A'..'Z'] + chars = chars0++['0'..'9'] + isReserved (TxtI i) = i `US.elementOfUniqSet` reservedSet + reservedSet = US.mkUniqSet reserved + reserved = [ -- reserved words + "abstract", "arguments", "await", "boolean" + , "break", "byte", "case", "catch" + , "char", "class", "const", "continue" + , "debugger", "default", "delete", "do" + , "double", "else", "enum", "eval" + , "export", "extends", "false", "final" + , "finally", "float", "for", "function" + , "goto", "if", "implements", "import" + , "in", "instanceof", "int", "interface" + , "let", "long", "native", "new" + , "null", "package", "private", "protected" + , "public", "return", "short", "static" + , "super", "switch", "synchronized", "this" + , "throw", "throws", "transient", "true" + , "try", "typeof", "var", "void" + , "volatile", "while", "with", "yield" + -- some special values + , "as", "async", "from", "get" + , "of", "NaN", "prototype", "undefined" + ] + +mkRewrite :: Bool -> AnalysisResult -> Maybe SimpleRewrite +mkRewrite do_rename a + | arBailout a = Nothing + | otherwise = Just $ + SimpleRewrite { renameVar = if do_rename + then UM.listToUniqMap (zip localVars newVars) + else UM.emptyUniqMap + , varUsage = vu + } + where + vu :: UM.UniqMap Ident VarUsage + vu = arVarUsage a + + -- local variables in the order that they were declared + localVars :: [Ident] + localVars = + map fst + -- recover original order and remove non-determinism + . sortBy (compare `on` snd) + . map (\(v, u) -> (v, varDeclared u)) + . filter (isDecl . varDeclared . snd) + -- non-determinism is removed by sorting afterwards + $ UM.nonDetUniqMapToList vu + -- we can't rename variables that are used in the global scope + blockedNames :: US.UniqSet Ident + blockedNames = + US.mkUniqSet $ + map fst ( + filter (\(_k,v) -> (not . isDecl) (varDeclared v) || varDeepDeclared v) + (UM.nonDetUniqMapToList vu)) + + + newVars :: [Ident] + newVars = filter (not . (`US.elementOfUniqSet` blockedNames)) newLocals + +simpleRewrite :: SimpleRewrite -> JFunction -> JFunction +simpleRewrite rw (JFunction args stat)= JFunction (map varReplace args) (go stat) + where + zeroUsed :: JExpr -> Bool + zeroUsed (ValExpr (JVar v)) = + maybe True ((== Zero) . varUsed) (UM.lookupUniqMap (varUsage rw) v) && + maybe False (isDecl . varDeclared) (UM.lookupUniqMap (varUsage rw) v) + zeroUsed _ = False + + varReplace :: Ident -> Ident + varReplace v = fromMaybe v (UM.lookupUniqMap (renameVar rw) v) + + {- + We can sometimes float down an expression to avoid an assignment: + + var x = e; + f(x); + ==> + f(e); + + This can only be done if the expression has no side effects and x is + only used once. + + Heap object property lookups cannot be floated just yet, since we + don't know whether an object is mutable or not. For example a thunk + can be blackholed, which would change the result if we float the lookup + after the blackholing. + -} + + mayBeFloated :: JExpr -> Bool + mayBeFloated (ValExpr v) = mayBeFloatedV v + mayBeFloated (SelExpr _e _) = False + mayBeFloated (IdxExpr _e1 _e2) = False + mayBeFloated (InfixExpr _ e1 e2)= mayBeFloated e1 && mayBeFloated e2 + mayBeFloated (UOpExpr _ _e) = False + mayBeFloated (IfExpr e1 e2 e3) = mayBeFloated e1 && + mayBeFloated e2 && + mayBeFloated e3 + mayBeFloated (ApplExpr e es) + | ValExpr (JVar (TxtI i)) <- e, isClosureAllocator i = all mayBeFloated es + | otherwise = False + + mayBeFloatedV :: JVal -> Bool + mayBeFloatedV (JVar v) + | Just vu <- UM.lookupUniqMap (varUsage rw) v + = isDecl (varDeclared vu) && not (assignedMultiple vu) + | otherwise = False + mayBeFloatedV (JList es) = all mayBeFloated es + mayBeFloatedV (JDouble {}) = True + mayBeFloatedV (JInt {}) = True + mayBeFloatedV (JStr {}) = True + mayBeFloatedV (JRegEx {}) = True + mayBeFloatedV (JBool {}) = True + mayBeFloatedV (JHash ps) = all (mayBeFloated . snd) + (UM.nonDetUniqMapToList ps) + mayBeFloatedV (JFunc {}) = False + + {- + we allow small literals and local variables and arguments to be + duplicated, since they tend to take up little space. + -} + mayDuplicate :: JExpr -> Bool + mayDuplicate (ValExpr (JVar i)) + | Just vu <- (UM.lookupUniqMap (varUsage rw) i) + = isLocalOrArg (varDeclared vu) + mayDuplicate (ValExpr (JInt n)) = abs n < 1000000 + mayDuplicate (ValExpr (JDouble {})) = True + mayDuplicate _ = False + + zeroAssigned :: Ident -> Bool + zeroAssigned v + | Just vu <- UM.lookupUniqMap (varUsage rw) v + = case varAssigned vu of + Unassigned -> True + _ -> False + | otherwise = False + + assignedAtMostOnce :: Ident -> Bool + assignedAtMostOnce v + | Just vu <- UM.lookupUniqMap (varUsage rw) v = + case varAssigned vu of + Unassigned -> True + AssignedOnce -> True + AssignedOnceKnown {} -> True + AssignedMany -> False + | otherwise = False + + go :: JStat -> JStat + go (DeclStat v mb_e) + | zeroUsed (ValExpr (JVar v)) = + case mb_e of + Nothing | zeroAssigned v -> BlockStat [] + | otherwise -> DeclStat (varReplace v) Nothing + Just e | not (mayHaveSideEffects e) && assignedAtMostOnce v + -> BlockStat [] + | otherwise -> DeclStat (varReplace v) (Just (goE True e)) + | otherwise = DeclStat (varReplace v) (fmap (goE True) mb_e) + go (AssignStat lhs aop e) + | ValExpr (JVar i) <- lhs, isTrivialAssignment i aop e = BlockStat [] + | zeroUsed lhs && not (mayHaveSideEffects e) = BlockStat [] + | zeroUsed lhs = AssignStat (goE False lhs) aop (goE True e) + | otherwise = AssignStat (goE False lhs) aop (goE True e) + go (ReturnStat e) = ReturnStat (goE True e) + go (BlockStat ss) = flattenBlock (map go ss) + go (IfStat e s1 s2) = IfStat (goE True e) (go s1) (go s2) + go (WhileStat b e s) = WhileStat b (goE True e) (go s) + go (ForStat s1 e s2 s3) = ForStat (go s1) (goE True e) (go s2) (go s3) + go (ForInStat b v e s) = ForInStat b (varReplace v) (goE True e) (go s) + go (SwitchStat e cases s) = SwitchStat (goE True e) + (map (\(c,cs) -> (c, go cs)) cases) + (go s) + go (TryStat s1 v s2 s3) = TryStat (go s1) (varReplace v) (go s2) (go s3) + go (ApplStat e es) = ApplStat (goE True e) (map (goE True) es) + go (UOpStat uop e) = UOpStat uop (goE False e) + go (LabelStat lbl s) = LabelStat lbl (go s) + go s@(BreakStat {}) = s + go s@(ContinueStat {}) = s + go (FuncStat i args s) = FuncStat i (map varReplace args) (go s) + + goE :: Bool -> JExpr -> JExpr + goE rhs (ValExpr (JVar v)) + | rhs + , Just vu <- UM.lookupUniqMap (varUsage rw) v + , AssignedOnceKnown ee <- varAssigned vu + , varUsed vu == One || mayDuplicate ee + , isDecl (varDeclared vu) + , mayBeFloated ee + = goE rhs ee + goE _rhs (ValExpr v) = ValExpr (goV v) + goE rhs (SelExpr e i) = SelExpr (goE rhs e) i + goE rhs (IdxExpr e1 e2) = IdxExpr (goE rhs e1) (goE rhs e2) + goE rhs (InfixExpr op e1 e2) = InfixExpr op (goE rhs e1) (goE rhs e2) + goE rhs (UOpExpr op e) = UOpExpr op (goE rhs e) + goE rhs (IfExpr e1 e2 e3) = IfExpr (goE rhs e1) (goE rhs e2) (goE rhs e3) + goE rhs (ApplExpr e es) = ApplExpr (goE rhs e) (map (goE rhs) es) + + goV :: JVal -> JVal + goV (JVar v) = JVar (varReplace v) + goV (JList es) = JList (map (goE True) es) + goV (JHash ps) = JHash (fmap (goE True) ps) + goV v@(JFunc {}) = v + goV v@(JDouble {}) = v + goV v@(JInt {}) = v + goV v@(JStr {}) = v + goV v@(JRegEx {}) = v + goV v@(JBool {}) = v + +flattenBlock :: [JStat] -> JStat +flattenBlock stats = + case filter (/= BlockStat []) stats of + [] -> BlockStat [] + [s] -> s + ss -> BlockStat ss + +data AnalysisResult = AnalysisResult + { arBailout :: !Bool + , arVarUsage :: !(UniqMap Ident VarUsage) + , arDeclaredCount :: !Int + } + +simpleAnalyze :: JFunction -> AnalysisResult +simpleAnalyze (JFunction args body) = go False (AnalysisResult False start 0) body + where + start :: UniqMap Ident VarUsage + start = UM.listToUniqMap + $ zipWith (\n v -> (v, VarUsage Zero Unassigned (ArgDecl n) False)) + [0..] + args + + add :: Ident -> VarUsage -> AnalysisResult -> AnalysisResult + add i vu m = m { arVarUsage = UM.addToUniqMap_C (Semi.<>) (arVarUsage m) i vu } + + + declare :: Bool -> Ident -> Maybe JExpr -> AnalysisResult -> AnalysisResult + declare True i _assign m = -- declaration in deeper scope + let vu = VarUsage Zero AssignedMany NoDecl True + in m { arVarUsage = UM.addToUniqMap_C (Semi.<>) (arVarUsage m) i vu} + declare False i assign m = -- declaration in analyzed scope + let count = arDeclaredCount m + !newCount + | Just (VarUsage _ _ (LocalDecl _) _) <- + UM.lookupUniqMap (arVarUsage m) i = count -- already declared + | otherwise = count + 1 + vassign | Just e <- assign = AssignedOnceKnown e + | otherwise = Unassigned + !vu = VarUsage Zero vassign (LocalDecl count) False + in m { arDeclaredCount = newCount + , arVarUsage = UM.addToUniqMap_C (Semi.<>) (arVarUsage m) i vu + } + + go :: Bool -> AnalysisResult -> JStat -> AnalysisResult + go deep u (DeclStat v mb_e) = + case mb_e of + Nothing -> declare deep v mb_e u + Just e -> declare deep v mb_e (goE u e) + go _deep u (AssignStat (ValExpr (JVar v)) aop e) = + let use = case aop of + AssignOp -> Zero + _ -> One + in add v (VarUsage use (AssignedOnceKnown e) NoDecl False) (goE u e) + go _deep u (AssignStat lhs _aop rhs) = goE (goE u lhs) rhs + go _deep u (ReturnStat e) = goE u e + go deep u (BlockStat ss) = foldl' (go deep) u ss + go deep u (IfStat e s1 s2) = go deep (go deep (goE u e) s1) s2 + go deep u (WhileStat _b e s) = go deep (goE u e) s + go deep u (ForStat s1 e s2 s3) + = go deep (go deep (goE (go deep u s1) e) s2) s3 + go deep u (ForInStat b v e s) = + let !u' = if b then declare deep v Nothing u else u + in add v (VarUsage Zero AssignedMany NoDecl True) + (go deep (go deep (goE u' e) s) s) + go deep u (SwitchStat e cases s) + = go deep (goE (foldl' (go deep) u (map snd cases)) e) s + go deep u (TryStat s1 v s2 s3) + = add v (VarUsage Zero AssignedMany NoDecl True) + (go deep (go deep (go deep u s1) s2) s3) + go _deep u (ApplStat e es) + | (ValExpr (JVar (TxtI i))) <- e, i == "eval" = u { arBailout = True } + | otherwise = foldl' goE (goE u e) es + go _deep u (UOpStat op e) + | ValExpr (JVar v) <- e + , op `elem` [PreIncOp, PostIncOp, PreDecOp, PostDecOp] = + add v (VarUsage One AssignedOnce NoDecl False) u + | otherwise = goE u e + go deep u (LabelStat _ s) = go deep u s + go _deep u (BreakStat _) = u + go _deep u (ContinueStat _) = u + go _deep u (FuncStat _ vs s) + = go True (foldl' (\u v -> add v (VarUsage Zero AssignedOnce NoDecl True) u) u vs) s + + goE :: AnalysisResult -> JExpr -> AnalysisResult + goE u (ValExpr v) = goV u v + goE u (SelExpr e _i) = goE u e + goE u (IdxExpr e1 e2) = goE (goE u e1) e2 + goE u (InfixExpr _ e1 e2) = goE (goE u e1) e2 + goE u (UOpExpr _ e) = goE u e + goE u (IfExpr e1 e2 e3) = goE (goE (goE u e1) e2) e3 + goE u (ApplExpr e es) + | (ValExpr (JVar (TxtI i))) <- e, i == "eval" = u { arBailout = True } + | otherwise = foldl' goE (goE u e) es + + goV :: AnalysisResult -> JVal -> AnalysisResult + goV u (JVar v) = add v (VarUsage One Unassigned NoDecl False) u + goV u (JList es) = foldl' goE u es + goV u (JDouble _) = u + goV u (JInt _) = u + goV u (JStr _) = u + goV u (JRegEx _) = u + goV u (JBool _) = u + goV u (JHash ps) = foldl' goE u (map snd $ UM.nonDetUniqMapToList ps) + goV u (JFunc vs s) + = go True (foldl (\u v -> add v (VarUsage Zero AssignedOnce NoDecl True) u) u vs) s + +-- | A trivial assignment is an assignment of a variable to itself: x = x +isTrivialAssignment :: Ident -> AOp -> JExpr -> Bool +isTrivialAssignment v AssignOp (ValExpr (JVar v')) = v == v' +isTrivialAssignment _ _ _ = False + +-- | Does the expression have side effects? +-- +-- This only returns False if the expression definitely does not have side +-- effects, i.e. it can be removed without changing the semantics if the +-- result is not used. +-- +-- Note: We have some assumptions here about Haskell RTS related values, which +-- may not be true for all JavaScript code. We should really replace +-- these with explicit nodes or annotations in the AST. +-- +mayHaveSideEffects :: JExpr -> Bool +-- special cases for Haskell things. These should really be special operations +-- in the AST: +-- 1. stack indexing does not have side effects +mayHaveSideEffects (IdxExpr (ValExpr (JVar (TxtI i))) e) + | i == "h$stack" = mayHaveSideEffects e +-- 2. we assume that x.d1, x.d2, ... are heap object property lookups, +-- which do not have side effects +mayHaveSideEffects (SelExpr e (TxtI i)) + | isHeapObjectProperty i = mayHaveSideEffects e + +-- general cases (no Haskell RTS specific assumptions here): +mayHaveSideEffects (ValExpr v) = mayHaveSideEffectsV v +mayHaveSideEffects (SelExpr {}) = True +mayHaveSideEffects (IdxExpr {}) = True +mayHaveSideEffects (UOpExpr uop e) = uo || mayHaveSideEffects e + where + uo = case uop of + NotOp -> False + BNotOp -> False + NegOp -> False + PlusOp -> False + TypeofOp -> False + _ -> True +mayHaveSideEffects (InfixExpr _o e1 e2) = + mayHaveSideEffects e1 || mayHaveSideEffects e2 +mayHaveSideEffects (IfExpr e1 e2 e3) = + mayHaveSideEffects e1 || mayHaveSideEffects e2 || mayHaveSideEffects e3 +mayHaveSideEffects (ApplExpr {}) = True + +mayHaveSideEffectsV :: JVal -> Bool +mayHaveSideEffectsV (JVar {}) = False +mayHaveSideEffectsV (JList es) = any mayHaveSideEffects es +mayHaveSideEffectsV (JDouble {}) = False +mayHaveSideEffectsV (JInt {}) = False +mayHaveSideEffectsV (JStr {}) = False +mayHaveSideEffectsV (JRegEx {}) = False +mayHaveSideEffectsV (JBool {}) = False +mayHaveSideEffectsV (JHash ps) = UM.anyUniqMap mayHaveSideEffects ps +mayHaveSideEffectsV (JFunc {}) = True + +isHeapObjectProperty :: FastString -> Bool +isHeapObjectProperty "d1" = True +isHeapObjectProperty "d2" = True +isHeapObjectProperty "d3" = True +isHeapObjectProperty "d4" = True +isHeapObjectProperty "d5" = True +isHeapObjectProperty "d6" = True +isHeapObjectProperty "d7" = True +isHeapObjectProperty "d8" = True +isHeapObjectProperty "d9" = True +isHeapObjectProperty "d10" = True +isHeapObjectProperty "d11" = True +isHeapObjectProperty "d12" = True +isHeapObjectProperty "d13" = True +isHeapObjectProperty "d14" = True +isHeapObjectProperty "d15" = True +isHeapObjectProperty "d16" = True +isHeapObjectProperty "d17" = True +isHeapObjectProperty "d18" = True +isHeapObjectProperty "d19" = True +isHeapObjectProperty "d20" = True +isHeapObjectProperty "d21" = True +isHeapObjectProperty "d22" = True +isHeapObjectProperty "d23" = True +isHeapObjectProperty "d24" = True + +isHeapObjectProperty _ = False + +isClosureAllocator :: FastString -> Bool +isClosureAllocator "h$c1" = True +isClosureAllocator "h$c2" = True +isClosureAllocator "h$c3" = True +isClosureAllocator "h$c4" = True +isClosureAllocator "h$c5" = True +isClosureAllocator "h$c6" = True +isClosureAllocator "h$c7" = True +isClosureAllocator "h$c8" = True +isClosureAllocator "h$c9" = True +isClosureAllocator "h$c10" = True +isClosureAllocator "h$c11" = True +isClosureAllocator "h$c12" = True +isClosureAllocator "h$c13" = True +isClosureAllocator "h$c14" = True +isClosureAllocator "h$c15" = True +isClosureAllocator "h$c16" = True +isClosureAllocator "h$c17" = True +isClosureAllocator "h$c18" = True +isClosureAllocator "h$c19" = True +isClosureAllocator "h$c20" = True +isClosureAllocator "h$c21" = True +isClosureAllocator "h$c22" = True +isClosureAllocator "h$c23" = True +isClosureAllocator "h$c24" = True +isClosureAllocator _ = False diff --git a/GHC/JS/Optimizer.hs b/GHC/JS/Optimizer.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Optimizer.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE LambdaCase, OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Optimizer +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Optimizer is a shallow embedding of a peephole optimizer. That is, +-- this module defines transformations over the JavaScript IR in +-- 'GHC.JS.Syntax', transforming the IR forms from inefficient, or +-- non-idiomatic, JavaScript to more efficient and idiomatic JavaScript. The +-- optimizer is written in continuation passing style so optimizations +-- compose. +-- +-- * Architecture of the optimizer +-- +-- The design is that each optimization pattern matches on the head of a +-- block by pattern matching onto the head of the stream of nodes in the +-- JavaScript IR. If an optimization gets a successful match then it performs +-- whatever rewrite is necessary and then calls the 'loop' continuation. This +-- ensures that the result of the optimization is subject to the same +-- optimization, /and/ the rest of the optimizations. If there is no match +-- then the optimization should call the 'next' continuation to pass the +-- stream to the next optimization in the optimization chain. We then define +-- the last "optimization" to be @tailLoop@ which selects the next block of +-- code to optimize and begin the optimization pipeline again. +----------------------------------------------------------------------------- +module GHC.JS.Optimizer + ( jsOptimize + ) where + + +import Prelude + +import GHC.JS.Syntax + +import Control.Arrow + +import qualified GHC.JS.Opt.Simple as Simple + +{- +Note [Unsafe JavaScript optimizations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a number of optimizations that the JavaScript Backend performs that +are not sound with respect to arbritrary JavaScript. We still perform these +optimizations because we are not optimizing arbritrary javascript and under the +assumption that the JavaScript backend will not generate code that violates the +soundness of the optimizer. For example, the @deadCodeElim@ optimization removes +all statements that occur after a 'return' in JavaScript, however this is not +always sound because of hoisting, consider this program: + + function foo() { + var x = 2; + bar(); + return x; + + function bar() { + x = 10; + }} + + which is transformed to: + + function foo() { + var x = 2; + bar(); + return x; + }} + +The optimized form is clearly a program that goes wrong because `bar()` is no +longer defined. But the JavaScript backend will never generate this code, so as +long as that assumption holds we are safe to perform optimizations that would +normally be unsafe. +-} + + +-------------------------------------------------------------------------------- +-- Top level Driver +-------------------------------------------------------------------------------- +jsOptimize :: JStat -> JStat +jsOptimize s0 = jsOptimizeStat (Simple.simpleOpt s0) + +jsOptimizeStat :: JStat -> JStat +jsOptimizeStat s0 = go s0 + where + p_opt = jsOptimizeStat + opt = jsOptimize' + e_opt = jExprOptimize + -- base case + go (BlockStat xs) = BlockStat (opt xs) + -- recursive cases + go (ForStat i p s body) = ForStat (go i) (e_opt p) (go s) (p_opt body) + go (ForInStat b i p body) = ForInStat b i p (p_opt body) + go (WhileStat b c body) = WhileStat b (e_opt c) (p_opt body) + go (SwitchStat s ps body) = SwitchStat s (fmap (second go) ps) (p_opt body) + go (FuncStat i args body) = FuncStat i args (p_opt body) + go (IfStat c t e) = IfStat (e_opt c) (p_opt t) (p_opt e) + go (TryStat ths i c f) = TryStat (p_opt ths) i (p_opt c) (p_opt f) + go (LabelStat lbl s) = LabelStat lbl (p_opt s) + -- special case: drive the optimizer into expressions + go (AssignStat id op rhs) = AssignStat (e_opt id) op (e_opt rhs) + go (DeclStat i (Just e)) = DeclStat i (Just $ e_opt e) + go (ReturnStat e) = ReturnStat (e_opt e) + go (UOpStat op e) = UOpStat op (e_opt e) + go (ApplStat f args) = ApplStat (e_opt f) (e_opt <$> args) + -- all else is terminal, we match on these to force a warning in the event + -- another constructor is added + go x@BreakStat{} = x + go x@ContinueStat{} = x + go x@DeclStat{} = x -- match on the nothing case + +jsOptimize' :: [JStat] -> [JStat] +jsOptimize' = runBlockOpt opts . single_pass_opts + where + opts :: BlockOpt + opts = safe_opts + <> unsafe_opts + <> tailLoop -- tailloop must be last, see module description + + unsafe_opts :: BlockOpt + unsafe_opts = mconcat [ deadCodeElim ] + + safe_opts :: BlockOpt + safe_opts = mconcat [ declareAssign, combineOps ] + + single_pass_opts :: BlockTrans + single_pass_opts = runBlockTrans sp_opts + + sp_opts = [flattenBlocks] + +-- | recur over a @JExpr@ and optimize the @JVal@s +jExprOptimize :: JExpr -> JExpr +-- the base case +jExprOptimize (ValExpr val) = ValExpr (jValOptimize val) +-- recursive cases +jExprOptimize (SelExpr obj field) = SelExpr (jExprOptimize obj) field +jExprOptimize (IdxExpr obj ix) = IdxExpr (jExprOptimize obj) (jExprOptimize ix) +jExprOptimize (UOpExpr op exp) = UOpExpr op (jExprOptimize exp) +jExprOptimize (IfExpr c t e) = IfExpr c (jExprOptimize t) (jExprOptimize e) +jExprOptimize (ApplExpr f args ) = ApplExpr (jExprOptimize f) (jExprOptimize <$> args) +jExprOptimize (InfixExpr op l r) = InfixExpr op (jExprOptimize l) (jExprOptimize r) + +-- | drive optimizations to anonymous functions and over expressions +jValOptimize :: JVal -> JVal +-- base case +jValOptimize (JFunc args body) = JFunc args (jsOptimizeStat body) +-- recursive cases +jValOptimize (JList exprs) = JList (jExprOptimize <$> exprs) +jValOptimize (JHash hash) = JHash (jExprOptimize <$> hash) +-- all else is terminal +jValOptimize x@JVar{} = x +jValOptimize x@JDouble{} = x +jValOptimize x@JInt{} = x +jValOptimize x@JStr{} = x +jValOptimize x@JRegEx{} = x +jValOptimize x@JBool{} = x + +-- | A block transformation is a function from a stream of syntax to another +-- stream +type BlockTrans = [JStat] -> [JStat] + +-- | A BlockOpt is a function that alters the stream, and a continuation that +-- represents the rest of the stream. The first @BlockTrans@ represents +-- restarting the optimizer after a change has happened. The second @BlockTrans@ +-- represents the rest of the continuation stream. +newtype BlockOpt = BlockOpt (BlockTrans -> BlockTrans -> BlockTrans) + +-- | To merge two BlockOpt we first run the left-hand side optimization and +-- capture the right-hand side in the continuation +instance Semigroup BlockOpt where + BlockOpt opt0 <> BlockOpt opt1 = BlockOpt + $ \loop next -> opt0 loop (opt1 loop next) + +instance Monoid BlockOpt where + -- don't loop, just finalize + mempty = BlockOpt $ \_loop next -> next + +-- | loop until a fixpoint is reached +runBlockOpt :: BlockOpt -> [JStat] -> [JStat] +runBlockOpt (BlockOpt opt) xs = recur xs + where recur = opt recur id + +runBlockTrans :: [BlockTrans] -> [JStat] -> [JStat] +runBlockTrans opts = foldl (.) id opts + +-- | Perform all the optimizations on the tail of a block. +tailLoop :: BlockOpt +tailLoop = BlockOpt $ \loop next -> \case + [] -> next [] + -- this call to jsOptimize is required or else the optimizer will not + -- properly recur down JStat. See the 'deadCodeElim' test for examples which + -- were failing before this change + (x:xs) -> next (jsOptimizeStat x : loop xs) + +{- | + Catch modify and assign operators: + case 1: + i = i + 1; ==> ++i; + case 2: + i = i - 1; ==> --i; + case 3: + i = i + n; ==> i += n; + case 4: + i = i - n; ==> i -= n; +-} +combineOps :: BlockOpt +combineOps = BlockOpt $ \loop next -> + -- find an op pattern, and rerun the optimizer on its result unless there is + -- nothing to optimize, in which case call the next optimization + \case + -- var x = expr; return x; ==> return expr; + (DeclStat i (Just e) : ReturnStat (ValExpr (JVar i')) : xs) + | i == i' -> loop $ ReturnStat e : xs + + -- x = expr; return x; ==> return expr; + (AssignStat (ValExpr (JVar i)) AssignOp e : ReturnStat (ValExpr (JVar i')) : xs) + | i == i' -> loop $ ReturnStat e : xs + + -- h$sp -= 2; h$sp += 5; ==> h$sp += 3; + (op1 : op2 : xs) + | Just s1 <- isStackAdjust op1 + , Just s2 <- isStackAdjust op2 -> loop $ mkStackAdjust (s1 + s2) ++ xs + + -- x = x + 1; ==> ++x; + -- x = x - 1; ==> --x; + -- x = x + n; ==> x += n; + -- x = x - n; ==> x -= n; + (unchanged@(AssignStat + ident@(ValExpr (JVar i)) + AssignOp + (InfixExpr op (ValExpr (JVar i')) e)) : xs) + | i == i' -> case (op, e) of + (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs + (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs + (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs + (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs + _ -> next $ unchanged : xs + -- commutative cases + (unchanged@(AssignStat + ident@(ValExpr (JVar i)) + AssignOp + (InfixExpr op e (ValExpr (JVar i')))) : xs) + | i == i' -> case (op, e) of + (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs + (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs + _ -> next $ unchanged : xs + -- general case, we had nothing to optimize in this case so call the next + -- optimization + xs -> next xs + + +-- | Catch 'var i; i = q;' ==> 'var i = q;' +declareAssign :: BlockOpt +declareAssign = BlockOpt $ + \loop next -> \case + ( (DeclStat i Nothing) + : (AssignStat (ValExpr (JVar i')) AssignOp v) + : xs + ) | i == i' -> loop (DeclStat i (Just v) : xs) + xs -> next xs + +-- | Eliminate all code after a return statement. This is a special case +-- optimization that doesn't need to loop. See Note [Unsafe JavaScript +-- optimizations] +deadCodeElim :: BlockOpt +deadCodeElim = BlockOpt $ + \_loop next -> \case + (x@ReturnStat{}:_) -> next [x] + xs -> next xs + +-- | remove nested blocks +flattenBlocks :: BlockTrans +flattenBlocks (BlockStat y : ys) = flattenBlocks y ++ flattenBlocks ys +flattenBlocks (x:xs) = x : flattenBlocks xs +flattenBlocks [] = [] + +-- | stack adjustments +sp :: JExpr +sp = ValExpr (JVar (TxtI "h$sp")) + +isStackAdjust :: JStat -> Maybe Integer +isStackAdjust (UOpStat op (ValExpr (JVar (TxtI "h$sp")))) + | op == PreIncOp || op == PostIncOp = Just 1 +isStackAdjust (UOpStat op (ValExpr (JVar (TxtI "h$sp")))) + | op == PreDecOp || op == PostDecOp = Just (-1) +isStackAdjust (AssignStat (ValExpr (JVar (TxtI "h$sp"))) op (ValExpr (JInt n))) + | op == AddAssignOp = Just n + | op == SubAssignOp = Just (-n) +isStackAdjust (AssignStat (ValExpr (JVar (TxtI "h$sp"))) AssignOp (InfixExpr op (ValExpr (JVar (TxtI "h$sp"))) (ValExpr (JInt n)))) + | op == AddOp = Just n + | op == SubOp = Just (-n) +isStackAdjust (AssignStat (ValExpr (JVar (TxtI "h$sp"))) AssignOp (InfixExpr AddOp (ValExpr (JInt n)) (ValExpr (JVar (TxtI "h$sp"))))) + = Just n +isStackAdjust _ = Nothing + +mkStackAdjust :: Integer -> [JStat] +mkStackAdjust 0 = [] +mkStackAdjust 1 = [UOpStat PostIncOp sp] +mkStackAdjust (-1) = [UOpStat PostDecOp sp] +mkStackAdjust x + | x < 0 = [AssignStat sp AssignOp (InfixExpr SubOp sp (ValExpr (JInt (-x))))] + | otherwise = [AssignStat sp AssignOp (InfixExpr AddOp sp (ValExpr (JInt x)))] diff --git a/GHC/JS/Ppr.hs b/GHC/JS/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Ppr.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} + +-- For Outputable instances for JS syntax +{-# OPTIONS_GHC -Wno-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Ppr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Ppr defines the code generation facilities for the JavaScript +-- backend. That is, this module exports a function from the JS backend IR +-- to JavaScript compliant concrete syntax that can readily be executed by +-- nodejs or called in a browser. +-- +-- * Design +-- +-- This module follows the architecture and style of the other backends in +-- GHC: it instances Outputable for the relevant types, creates a class that +-- describes a morphism from the IR domain to JavaScript concrete Syntax and +-- then generates that syntax on a case by case basis. +-- +-- * How to use +-- +-- The key functions are @renderJS@, @jsToDoc@, and the @RenderJS@ record. +-- Use the @RenderJS@ record and @jsToDoc@ to define a custom renderers for +-- specific parts of the backend, for example in 'GHC.StgToJS.Linker.Opt' a +-- custom renderer ensures all @Ident@ generated by the linker optimization +-- pass are prefixed differently than the default. Use @renderJS@ to +-- generate JavaScript concrete syntax in the general case, suitable for +-- human consumption. +----------------------------------------------------------------------------- + +module GHC.JS.Ppr + ( renderJs + , renderPrefixJs + , renderPrefixJs' + , JsToDoc(..) + , defaultRenderJs + , RenderJs(..) + , JsRender(..) + , jsToDoc + , pprStringLit + , interSemi + , braceNest + , hangBrace + ) +where + +import GHC.Prelude + +import GHC.JS.Ident +import GHC.JS.Syntax + +import Data.Char (isControl, ord) +import Data.List (sortOn) + +import Numeric(showHex) + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Unique.Map + +instance Outputable JExpr where + ppr = renderJs + +instance Outputable JVal where + ppr = renderJs + +-------------------------------------------------------------------------------- +-- Top level API +-------------------------------------------------------------------------------- + +-- | Render a syntax tree as a pretty-printable document +-- (simply showing the resultant doc produces a nice, +-- well formatted String). +renderJs :: (JsToDoc a) => a -> SDoc +renderJs = renderJs' defaultRenderJs + +{-# SPECIALISE renderJs' :: JsToDoc a => RenderJs HLine -> a -> HLine #-} +{-# SPECIALISE renderJs' :: JsToDoc a => RenderJs SDoc -> a -> SDoc #-} +renderJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc +renderJs' r = jsToDocR r + +data RenderJs doc = RenderJs + { renderJsS :: !(JsRender doc => RenderJs doc -> JStat -> doc) + , renderJsE :: !(JsRender doc => RenderJs doc -> JExpr -> doc) + , renderJsV :: !(JsRender doc => RenderJs doc -> JVal -> doc) + , renderJsI :: !(JsRender doc => RenderJs doc -> Ident -> doc) + } + +defaultRenderJs :: RenderJs doc +defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI + +jsToDoc :: JsToDoc a => a -> SDoc +jsToDoc = jsToDocR defaultRenderJs + +-- | Render a syntax tree as a pretty-printable document, using a given prefix +-- to all generated names. Use this with distinct prefixes to ensure distinct +-- generated names between independent calls to render(Prefix)Js. +renderPrefixJs :: (JsToDoc a) => a -> SDoc +renderPrefixJs = renderPrefixJs' defaultRenderJs + +renderPrefixJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc +renderPrefixJs' r = jsToDocR r + +-------------------------------------------------------------------------------- +-- Code Generator +-------------------------------------------------------------------------------- + +class JsToDoc a where jsToDocR :: JsRender doc => RenderJs doc -> a -> doc +instance JsToDoc JStat where jsToDocR r = renderJsS r r +instance JsToDoc JExpr where jsToDocR r = renderJsE r r +instance JsToDoc JVal where jsToDocR r = renderJsV r r +instance JsToDoc Ident where jsToDocR r = renderJsI r r +instance JsToDoc [JExpr] where jsToDocR r = jcat . map (addSemi . jsToDocR r) +instance JsToDoc [JStat] where jsToDocR r = jcat . map (addSemi . jsToDocR r) + +defRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc +defRenderJsS r = \case + IfStat cond x y -> jcat + [ hangBrace (text "if" <+?> parens (jsToDocR r cond)) (optBlock r x) + , mbElse + ] + where mbElse | y == BlockStat [] = empty + | otherwise = hangBrace (text "else") (optBlock r y) + DeclStat x Nothing -> text "var" <+> jsToDocR r x + -- special treatment for functions, otherwise there is too much left padding + -- (more than the length of the expression assigned to). E.g. + -- + -- var long_variable_name = (function() + -- { + -- ... + -- }); + -- + DeclStat x (Just (ValExpr f@(JFunc {}))) -> jhang (text "var" <+> jsToDocR r x <+?> char '=') (jsToDocR r f) + DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+?> char '=' <+?> jsToDocR r e + WhileStat False p b -> hangBrace (text "while" <+?> parens (jsToDocR r p)) (optBlock r b) + WhileStat True p b -> hangBrace (text "do") (optBlock r b) <+?> text "while" <+?> parens (jsToDocR r p) + BreakStat l -> addSemi $ maybe (text "break") (\(LexicalFastString s) -> (text "break" <+> ftext s)) l + ContinueStat l -> addSemi $ maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l + LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$$ printBS s + where + printBS (BlockStat ss) = interSemi $ map (jsToDocR r) ss + printBS x = jsToDocR r x + + ForStat init p s1 sb -> hangBrace (text "for" <+?> parens forCond) (optBlock r sb) + where + forCond = jsToDocR r init <> semi <+?> jsToDocR r p <> semi <+?> parens (jsToDocR r s1) + ForInStat each i e b -> hangBrace (text txt <+?> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (optBlock r b) + where txt | each = "for each" + | otherwise = "for" + SwitchStat e l d -> hangBrace (text "switch" <+?> parens (jsToDocR r e)) cases + where l' = map (\(c,s) -> (text "case" <+?> parens (jsToDocR r c) <> colon) $$$ jnest (optBlock r s)) l + ++ [(text "default:") $$$ jnest (optBlock r d)] + cases = foldl1 ($$$) $ expectNonEmpty l' + ReturnStat e -> text "return" <+> jsToDocR r e + ApplStat e es -> jsToDocR r e <> (parens . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) es) + FuncStat i is b -> hangBrace (text "function" <+> jsToDocR r i + <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is)) + (optBlock r b) + TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) <+?> mbCatch <+?> mbFinally + where mbCatch | s1 == BlockStat [] = empty + | otherwise = hangBrace (text "catch" <+?> parens (jsToDocR r i)) (optBlock r s1) + mbFinally | s2 == BlockStat [] = empty + | otherwise = hangBrace (text "finally") (optBlock r s2) + AssignStat i op x -> case x of + -- special treatment for functions, otherwise there is too much left padding + -- (more than the length of the expression assigned to). E.g. + -- + -- long_variable_name = (function() + -- { + -- ... + -- }); + -- + ValExpr f@(JFunc {}) -> jhang (jsToDocR r i <> ftext (aOpText op)) (jsToDocR r f) + _ -> jsToDocR r i <+?> ftext (aOpText op) <+?> jsToDocR r x + UOpStat op x + | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x + | isPre op -> ftext (uOpText op) <+> optParens r x + | otherwise -> optParens r x <+> ftext (uOpText op) + BlockStat xs -> jsToDocR r xs + +-- | Remove one Block layering if we know we already have braces around the +-- statement +optBlock :: JsRender doc => RenderJs doc -> JStat -> doc +optBlock r x = case x of + BlockStat{} -> jsToDocR r x + _ -> addSemi (jsToDocR r x) + +optParens :: JsRender doc => RenderJs doc -> JExpr -> doc +optParens r x = case x of + UOpExpr _ _ -> parens (jsToDocR r x) + _ -> jsToDocR r x + +defRenderJsE :: JsRender doc => RenderJs doc -> JExpr -> doc +defRenderJsE r = \case + ValExpr x -> jsToDocR r x + SelExpr x y -> jsToDocR r x <> char '.' <> jsToDocR r y + IdxExpr x y -> jsToDocR r x <> brackets (jsToDocR r y) + IfExpr x y z -> parens (jsToDocR r x <+?> char '?' <+?> jsToDocR r y <+?> colon <+?> jsToDocR r z) + InfixExpr op x y -> parens $ jsToDocR r x <+?> ftext (opText op) <+?> jsToDocR r y + UOpExpr op x + | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x + | isPre op -> ftext (uOpText op) <+> optParens r x + | otherwise -> optParens r x <+> ftext (uOpText op) + ApplExpr je xs -> jsToDocR r je <> (parens . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) xs) + +defRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc +defRenderJsV r = \case + JVar i -> jsToDocR r i + JList xs -> brackets . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) xs + JDouble (SaneDouble d) + | d < 0 || isNegativeZero d -> parens (double d) + | otherwise -> double d + JInt i + | i < 0 -> parens (integer i) + | otherwise -> integer i + JStr s -> pprStringLit s + JRegEx s -> char '/' <> ftext s <> char '/' + JBool b -> text (if b then "true" else "false") + JHash m + | isNullUniqMap m -> text "{}" + | otherwise -> braceNest . foldl' (<+?>) empty . punctuate comma . + map (\(x,y) -> char '\'' <> ftext x <> char '\'' <> colon <+?> jsToDocR r y) + -- nonDetKeysUniqMap doesn't introduce non-determinism here + -- because we sort the elements lexically + $ sortOn (LexicalFastString . fst) (nonDetUniqMapToList m) + JFunc is b -> parens $ hangBrace (text "function" <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b) + +defRenderJsI :: JsRender doc => RenderJs doc -> Ident -> doc +defRenderJsI _ t = ftext (identFS t) + +aOpText :: AOp -> FastString +aOpText = \case + AssignOp -> "=" + AddAssignOp -> "+=" + SubAssignOp -> "-=" + + +uOpText :: UOp -> FastString +uOpText = \case + NotOp -> "!" + BNotOp -> "~" + NegOp -> "-" + PlusOp -> "+" + NewOp -> "new" + TypeofOp -> "typeof" + DeleteOp -> "delete" + YieldOp -> "yield" + VoidOp -> "void" + PreIncOp -> "++" + PostIncOp -> "++" + PreDecOp -> "--" + PostDecOp -> "--" + +opText :: Op -> FastString +opText = \case + EqOp -> "==" + StrictEqOp -> "===" + NeqOp -> "!=" + StrictNeqOp -> "!==" + GtOp -> ">" + GeOp -> ">=" + LtOp -> "<" + LeOp -> "<=" + AddOp -> "+" + SubOp -> "-" + MulOp -> "*" + DivOp -> "/" + ModOp -> "%" + LeftShiftOp -> "<<" + RightShiftOp -> ">>" + ZRightShiftOp -> ">>>" + BAndOp -> "&" + BOrOp -> "|" + BXorOp -> "^" + LAndOp -> "&&" + LOrOp -> "||" + InstanceofOp -> "instanceof" + InOp -> "in" + + +isPre :: UOp -> Bool +isPre = \case + PostIncOp -> False + PostDecOp -> False + _ -> True + +isAlphaOp :: UOp -> Bool +isAlphaOp = \case + NewOp -> True + TypeofOp -> True + DeleteOp -> True + YieldOp -> True + VoidOp -> True + _ -> False + +pprStringLit :: IsLine doc => FastString -> doc +pprStringLit s = char '\"' <> encodeJson s <> char '\"' + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +encodeJson :: IsLine doc => FastString -> doc +encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) + +encodeJsonChar :: IsLine doc => Char -> doc +encodeJsonChar = \case + '/' -> text "\\/" + '\b' -> text "\\b" + '\f' -> text "\\f" + '\n' -> text "\\n" + '\r' -> text "\\r" + '\t' -> text "\\t" + '"' -> text "\\\"" + '\\' -> text "\\\\" + c + | not (isControl c) && ord c <= 127 -> char c + | ord c <= 0xff -> hexxs "\\x" 2 (ord c) + | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) + | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair + in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> + hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) + where hexxs prefix pad cp = + let h = showHex cp "" + in text (prefix ++ replicate (pad - length h) '0' ++ h) + + +interSemi :: JsRender doc => [doc] -> doc +interSemi = foldl ($$$) empty . punctuateFinal semi semi + +-- | The structure `{body}`, optionally indented over multiple lines +{-# INLINE braceNest #-} +braceNest :: JsRender doc => doc -> doc +braceNest x = lbrace $$$ jnest x $$$ rbrace + +-- | The structure `hdr {body}`, optionally indented over multiple lines +{-# INLINE hangBrace #-} +hangBrace :: JsRender doc => doc -> doc -> doc +hangBrace hdr body = jcat [ hdr <> char ' ' <> char '{', jnest body, char '}' ] + +{-# INLINE jhang #-} +jhang :: JsRender doc => doc -> doc -> doc +jhang hdr body = jcat [ hdr, jnest body] + +-- | JsRender controls the differences in whitespace between HLine and SDoc. +-- Generally, this involves the indentation and newlines in the human-readable +-- SDoc implementation being replaced in the HLine version by the minimal +-- whitespace required for valid JavaScript syntax. +class IsLine doc => JsRender doc where + + -- | Concatenate with an optional single space + (<+?>) :: doc -> doc -> doc + -- | Concatenate with an optional newline + ($$$) :: doc -> doc -> doc + -- | Concatenate these `doc`s, either vertically (SDoc) or horizontally (HLine) + jcat :: [doc] -> doc + -- | Optionally indent the following + jnest :: doc -> doc + -- | Append semi-colon (and line-break in HLine mode) + addSemi :: doc -> doc + +instance JsRender SDoc where + (<+?>) = (<+>) + {-# INLINE (<+?>) #-} + ($$$) = ($+$) + {-# INLINE ($$$) #-} + jcat = vcat + {-# INLINE jcat #-} + jnest = nest 2 + {-# INLINE jnest #-} + addSemi x = x <> semi + {-# INLINE addSemi #-} + + +instance JsRender HLine where + (<+?>) = (<>) + {-# INLINE (<+?>) #-} + ($$$) = (<>) + {-# INLINE ($$$) #-} + jcat = hcat + {-# INLINE jcat #-} + jnest = id + {-# INLINE jnest #-} + addSemi x = x <> semi <> char '\n' + -- we add a line-break to avoid issues with lines too long in minified outputs + {-# INLINE addSemi #-} diff --git a/GHC/JS/Syntax.hs b/GHC/JS/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Syntax.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Syntax +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Syntax defines the Syntax for the JS backend in GHC. It comports +-- with the [ECMA-262](https://tc39.es/ecma262/) although not every +-- production rule of the standard is represented. Code in this module is a +-- fork of [JMacro](https://hackage.haskell.org/package/jmacro) (BSD 3 +-- Clause) by Gershom Bazerman, heavily modified to accomodate GHC's +-- constraints. +-- +-- +-- * Strategy +-- +-- Nothing fancy in this module, this is a classic deeply embedded AST for +-- JS. We define numerous ADTs and pattern synonyms to make pattern matching +-- and constructing ASTs easier. +-- +-- +-- * Consumers +-- +-- The entire JS backend consumes this module, e.g., the modules in +-- GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides +-- helper functions that use the deeply embedded DSL defined in this module +-- to provide some of the benefits of a shallow embedding. +-- +----------------------------------------------------------------------------- + +module GHC.JS.Syntax + ( -- * Deeply embedded JS datatypes + JStat(..) + , JExpr(..) + , JVal(..) + , Op(..) + , UOp(..) + , AOp(..) + , Ident(..) + , JLabel + -- * pattern synonyms over JS operators + , pattern New + , pattern Not + , pattern Negate + , pattern Add + , pattern Sub + , pattern Mul + , pattern Div + , pattern Mod + , pattern BOr + , pattern BAnd + , pattern BXor + , pattern BNot + , pattern LOr + , pattern LAnd + , pattern Int + , pattern String + , pattern Var + , pattern PreInc + , pattern PostInc + , pattern PreDec + , pattern PostDec + -- * Utility + , SaneDouble(..) + , var + , true_ + , false_ + ) where + +import GHC.Prelude + +import GHC.JS.Ident + +import GHC.Data.FastString +import GHC.Types.Unique.Map +import GHC.Types.SaneDouble + +import Control.DeepSeq + +import Data.Data +import qualified Data.Semigroup as Semigroup + +import GHC.Generics + + +-------------------------------------------------------------------------------- +-- Statements +-------------------------------------------------------------------------------- +-- | JavaScript statements, see the [ECMA262 +-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) +-- for details +data JStat + = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JExpr -- ^ Return + | IfStat JExpr JStat JStat -- ^ If + | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForStat JStat JExpr JStat JStat -- ^ For + | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True + | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch + | TryStat JStat Ident JStat JStat -- ^ Try + | BlockStat [JStat] -- ^ Blocks + | ApplStat JExpr [JExpr] -- ^ Application + | UOpStat UOp JExpr -- ^ Unary operators + | AssignStat JExpr AOp JExpr -- ^ Binding form: @ @ + | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JLabel) -- ^ Break + | ContinueStat (Maybe JLabel) -- ^ Continue + | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition + deriving (Eq, Generic) + +-- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of +-- course 'LabelStat' +type JLabel = LexicalFastString + +instance Semigroup JStat where + (<>) = appendJStat + +instance Monoid JStat where + mempty = BlockStat [] + +-- | Append a statement to another statement. 'appendJStat' only returns a +-- 'JStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty +-- 'BlockStat'. That is: +-- > (BlockStat [] , y ) = y +-- > (x , BlockStat []) = x +appendJStat :: JStat -> JStat -> JStat +appendJStat mx my = case (mx,my) of + (BlockStat [] , y ) -> y + (x , BlockStat []) -> x + (BlockStat xs , BlockStat ys) -> BlockStat $! xs ++ ys + (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $! xs : ys + (xs , ys ) -> BlockStat [xs,ys] + + +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- +-- | JavaScript Expressions +data JExpr + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' + | InfixExpr Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms + | UOpExpr UOp JExpr -- ^ Unary Expressions + | IfExpr JExpr JExpr JExpr -- ^ If-expression + | ApplExpr JExpr [JExpr] -- ^ Application + deriving (Eq, Generic) + +-- * Useful pattern synonyms to ease programming with the deeply embedded JS +-- AST. Each pattern wraps @UOp@ and @Op@ into a @JExpr@s to save typing and +-- for convienience. In addition we include a string wrapper for JS string +-- and Integer literals. + +-- | pattern synonym for a unary operator new +pattern New :: JExpr -> JExpr +pattern New x = UOpExpr NewOp x + +-- | pattern synonym for prefix increment @++x@ +pattern PreInc :: JExpr -> JExpr +pattern PreInc x = UOpExpr PreIncOp x + +-- | pattern synonym for postfix increment @x++@ +pattern PostInc :: JExpr -> JExpr +pattern PostInc x = UOpExpr PostIncOp x + +-- | pattern synonym for prefix decrement @--x@ +pattern PreDec :: JExpr -> JExpr +pattern PreDec x = UOpExpr PreDecOp x + +-- | pattern synonym for postfix decrement @--x@ +pattern PostDec :: JExpr -> JExpr +pattern PostDec x = UOpExpr PostDecOp x + +-- | pattern synonym for logical not @!@ +pattern Not :: JExpr -> JExpr +pattern Not x = UOpExpr NotOp x + +-- | pattern synonym for unary negation @-@ +pattern Negate :: JExpr -> JExpr +pattern Negate x = UOpExpr NegOp x + +-- | pattern synonym for addition @+@ +pattern Add :: JExpr -> JExpr -> JExpr +pattern Add x y = InfixExpr AddOp x y + +-- | pattern synonym for subtraction @-@ +pattern Sub :: JExpr -> JExpr -> JExpr +pattern Sub x y = InfixExpr SubOp x y + +-- | pattern synonym for multiplication @*@ +pattern Mul :: JExpr -> JExpr -> JExpr +pattern Mul x y = InfixExpr MulOp x y + +-- | pattern synonym for division @*@ +pattern Div :: JExpr -> JExpr -> JExpr +pattern Div x y = InfixExpr DivOp x y + +-- | pattern synonym for remainder @%@ +pattern Mod :: JExpr -> JExpr -> JExpr +pattern Mod x y = InfixExpr ModOp x y + +-- | pattern synonym for Bitwise Or @|@ +pattern BOr :: JExpr -> JExpr -> JExpr +pattern BOr x y = InfixExpr BOrOp x y + +-- | pattern synonym for Bitwise And @&@ +pattern BAnd :: JExpr -> JExpr -> JExpr +pattern BAnd x y = InfixExpr BAndOp x y + +-- | pattern synonym for Bitwise XOr @^@ +pattern BXor :: JExpr -> JExpr -> JExpr +pattern BXor x y = InfixExpr BXorOp x y + +-- | pattern synonym for Bitwise Not @~@ +pattern BNot :: JExpr -> JExpr +pattern BNot x = UOpExpr BNotOp x + +-- | pattern synonym for logical Or @||@ +pattern LOr :: JExpr -> JExpr -> JExpr +pattern LOr x y = InfixExpr LOrOp x y + +-- | pattern synonym for logical And @&&@ +pattern LAnd :: JExpr -> JExpr -> JExpr +pattern LAnd x y = InfixExpr LAndOp x y + +-- | pattern synonym to create integer values +pattern Int :: Integer -> JExpr +pattern Int x = ValExpr (JInt x) + +-- | pattern synonym to create string values +pattern String :: FastString -> JExpr +pattern String x = ValExpr (JStr x) + +-- | pattern synonym to create a local variable reference +pattern Var :: Ident -> JExpr +pattern Var x = ValExpr (JVar x) + +-------------------------------------------------------------------------------- +-- Values +-------------------------------------------------------------------------------- + +-- | JavaScript values +data JVal + = JVar Ident -- ^ A variable reference + | JList [JExpr] -- ^ A JavaScript list, or what JS calls an Array + | JDouble SaneDouble -- ^ A Double + | JInt Integer -- ^ A BigInt + | JStr FastString -- ^ A String + | JRegEx FastString -- ^ A Regex + | JBool Bool -- ^ A Boolean + | JHash (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@ + | JFunc [Ident] JStat -- ^ A function + deriving (Eq, Generic) + + +-------------------------------------------------------------------------------- +-- Operators +-------------------------------------------------------------------------------- + +-- | JS Binary Operators. We do not deeply embed the comma operator and the +-- assignment operators +data Op + = EqOp -- ^ Equality: `==` + | StrictEqOp -- ^ Strict Equality: `===` + | NeqOp -- ^ InEquality: `!=` + | StrictNeqOp -- ^ Strict InEquality `!==` + | GtOp -- ^ Greater Than: `>` + | GeOp -- ^ Greater Than or Equal: `>=` + | LtOp -- ^ Less Than: < + | LeOp -- ^ Less Than or Equal: <= + | AddOp -- ^ Addition: + + | SubOp -- ^ Subtraction: - + | MulOp -- ^ Multiplication \* + | DivOp -- ^ Division: \/ + | ModOp -- ^ Remainder: % + | LeftShiftOp -- ^ Left Shift: \<\< + | RightShiftOp -- ^ Right Shift: \>\> + | ZRightShiftOp -- ^ Unsigned RightShift: \>\>\> + | BAndOp -- ^ Bitwise And: & + | BOrOp -- ^ Bitwise Or: | + | BXorOp -- ^ Bitwise XOr: ^ + | LAndOp -- ^ Logical And: && + | LOrOp -- ^ Logical Or: || + | InstanceofOp -- ^ @instanceof@ + | InOp -- ^ @in@ + deriving (Show, Eq, Ord, Enum, Data, Generic) + +instance NFData Op + +-- | JS Unary Operators +data UOp + = NotOp -- ^ Logical Not: @!@ + | BNotOp -- ^ Bitwise Not: @~@ + | NegOp -- ^ Negation: @-@ + | PlusOp -- ^ Unary Plus: @+x@ + | NewOp -- ^ new x + | TypeofOp -- ^ typeof x + | DeleteOp -- ^ delete x + | YieldOp -- ^ yield x + | VoidOp -- ^ void x + | PreIncOp -- ^ Prefix Increment: @++x@ + | PostIncOp -- ^ Postfix Increment: @x++@ + | PreDecOp -- ^ Prefix Decrement: @--x@ + | PostDecOp -- ^ Postfix Decrement: @x--@ + deriving (Show, Eq, Ord, Enum, Data, Generic) + +instance NFData UOp + +-- | JS Unary Operators +data AOp + = AssignOp -- ^ Vanilla Assignment: = + | AddAssignOp -- ^ Addition Assignment: += + | SubAssignOp -- ^ Subtraction Assignment: -= + deriving (Show, Eq, Ord, Enum, Data, Generic) + +instance NFData AOp + +-- | construct a JS variable reference +var :: FastString -> JExpr +var = Var . name + +-- | The JS literal 'true' +true_ :: JExpr +true_ = ValExpr (JBool True) + +-- | The JS literal 'false' +false_ :: JExpr +false_ = ValExpr (JBool False) diff --git a/GHC/JS/Transform.hs b/GHC/JS/Transform.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Transform.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} + +module GHC.JS.Transform + ( identsS + , identsV + , identsE + , jStgExprToJS + , jStgStatToJS + ) +where + +import GHC.Prelude + +import GHC.JS.Ident +import GHC.JS.JStg.Syntax +import qualified GHC.JS.Syntax as JS + +import Data.List (sortBy) + +import GHC.Data.FastString +import GHC.Types.Unique.Map +import GHC.Types.Unique.FM + + +{-# INLINE identsS #-} +identsS :: JStgStat -> [Ident] +identsS = \case + DeclStat i e -> [i] ++ maybe [] identsE e + ReturnStat e -> identsE e + IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2 + WhileStat _ e s -> identsE e ++ identsS s + ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body + ForInStat _ i e s -> [i] ++ identsE e ++ identsS s + SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s + where traverseCase (e,s) = identsE e ++ identsS s + TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3 + BlockStat xs -> concatMap identsS xs + ApplStat e es -> identsE e ++ concatMap identsE es + UOpStat _op e -> identsE e + AssignStat e1 _op e2 -> identsE e1 ++ identsE e2 + LabelStat _l s -> identsS s + BreakStat{} -> [] + ContinueStat{} -> [] + FuncStat i args body -> [i] ++ args ++ identsS body + +{-# INLINE identsE #-} +identsE :: JStgExpr -> [Ident] +identsE = \case + ValExpr v -> identsV v + SelExpr e _i -> identsE e -- do not rename properties + IdxExpr e1 e2 -> identsE e1 ++ identsE e2 + InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2 + UOpExpr _ e -> identsE e + IfExpr e1 e2 e3 -> identsE e1 ++ identsE e2 ++ identsE e3 + ApplExpr e es -> identsE e ++ concatMap identsE es + +{-# INLINE identsV #-} +identsV :: JVal -> [Ident] +identsV = \case + JVar i -> [i] + JList xs -> concatMap identsE xs + JDouble{} -> [] + JInt{} -> [] + JStr{} -> [] + JRegEx{} -> [] + JBool{} -> [] + JHash m -> concatMap identsE (nonDetEltsUniqMap m) + JFunc args s -> args ++ identsS s + +-------------------------------------------------------------------------------- +-- Translation +-- +-------------------------------------------------------------------------------- +jStgStatToJS :: JStgStat -> JS.JStat +jStgStatToJS = \case + DeclStat i rhs -> JS.DeclStat i $ fmap jStgExprToJS rhs + ReturnStat e -> JS.ReturnStat $ jStgExprToJS e + IfStat c t e -> JS.IfStat (jStgExprToJS c) (jStgStatToJS t) (jStgStatToJS e) + WhileStat is_do c e -> JS.WhileStat is_do (jStgExprToJS c) (jStgStatToJS e) + ForStat init p step body -> JS.ForStat (jStgStatToJS init) (jStgExprToJS p) + (jStgStatToJS step) (jStgStatToJS body) + ForInStat is_each i iter body -> JS.ForInStat (is_each) i (jStgExprToJS iter) (jStgStatToJS body) + SwitchStat struct ps def -> JS.SwitchStat + (jStgExprToJS struct) + (map (\(p1, p2) -> (jStgExprToJS p1, jStgStatToJS p2)) ps) + (jStgStatToJS def) + TryStat t i c f -> JS.TryStat (jStgStatToJS t) i (jStgStatToJS c) (jStgStatToJS f) + BlockStat bs -> JS.BlockStat $ map jStgStatToJS bs + ApplStat rator rand -> JS.ApplStat (jStgExprToJS rator) $ map jStgExprToJS rand + UOpStat rator rand -> JS.UOpStat (jStgUOpToJS rator) (jStgExprToJS rand) + AssignStat lhs op rhs -> JS.AssignStat (jStgExprToJS lhs) (jStgAOpToJS op) (jStgExprToJS rhs) + LabelStat lbl stmt -> JS.LabelStat lbl (jStgStatToJS stmt) + BreakStat m_l -> JS.BreakStat $! m_l + ContinueStat m_l -> JS.ContinueStat $! m_l + FuncStat i args body -> JS.FuncStat i args $ jStgStatToJS body + +jStgExprToJS :: JStgExpr -> JS.JExpr +jStgExprToJS = \case + ValExpr v -> JS.ValExpr $ jStgValToJS v + SelExpr obj i -> JS.SelExpr (jStgExprToJS obj) i + IdxExpr o i -> JS.IdxExpr (jStgExprToJS o) (jStgExprToJS i) + InfixExpr op l r -> JS.InfixExpr (jStgOpToJS op) (jStgExprToJS l) (jStgExprToJS r) + UOpExpr op r -> JS.UOpExpr (jStgUOpToJS op) (jStgExprToJS r) + IfExpr c t e -> JS.IfExpr (jStgExprToJS c) (jStgExprToJS t) (jStgExprToJS e) + ApplExpr rator rands -> JS.ApplExpr (jStgExprToJS rator) $ map jStgExprToJS rands + +jStgValToJS :: JVal -> JS.JVal +jStgValToJS = \case + JVar i -> JS.JVar i + JList xs -> JS.JList $ map jStgExprToJS xs + JDouble d -> JS.JDouble d + JInt i -> JS.JInt i + JStr s -> JS.JStr s + JRegEx f -> JS.JRegEx f + JBool b -> JS.JBool b + JHash m -> JS.JHash $ mapUniqMapM satHash m + where + satHash (i, x) = (i,) . (i,) $ jStgExprToJS x + compareHash (i,_) (j,_) = lexicalCompareFS i j + -- By lexically sorting the elements, the non-determinism introduced by nonDetEltsUFM is avoided + mapUniqMapM f (UniqMap m) = UniqMap . listToUFM $ (map f . sortBy compareHash $ nonDetEltsUFM m) + JFunc args body -> JS.JFunc args $ jStgStatToJS body + +jStgOpToJS :: Op -> JS.Op +jStgOpToJS = go + where + go EqOp = JS.EqOp + go StrictEqOp = JS.StrictEqOp + go NeqOp = JS.NeqOp + go StrictNeqOp = JS.StrictNeqOp + go GtOp = JS.GtOp + go GeOp = JS.GeOp + go LtOp = JS.LtOp + go LeOp = JS.LeOp + go AddOp = JS.AddOp + go SubOp = JS.SubOp + go MulOp = JS.MulOp + go DivOp = JS.DivOp + go ModOp = JS.ModOp + go LeftShiftOp = JS.LeftShiftOp + go RightShiftOp = JS.RightShiftOp + go ZRightShiftOp = JS.ZRightShiftOp + go BAndOp = JS.BAndOp + go BOrOp = JS.BOrOp + go BXorOp = JS.BXorOp + go LAndOp = JS.LAndOp + go LOrOp = JS.LOrOp + go InstanceofOp = JS.InstanceofOp + go InOp = JS.InOp + +jStgUOpToJS :: UOp -> JS.UOp +jStgUOpToJS = go + where + go NotOp = JS.NotOp + go BNotOp = JS.BNotOp + go NegOp = JS.NegOp + go PlusOp = JS.PlusOp + go NewOp = JS.NewOp + go TypeofOp = JS.TypeofOp + go DeleteOp = JS.DeleteOp + go YieldOp = JS.YieldOp + go VoidOp = JS.VoidOp + go PreIncOp = JS.PreIncOp + go PostIncOp = JS.PostIncOp + go PreDecOp = JS.PreDecOp + go PostDecOp = JS.PostDecOp + +jStgAOpToJS :: AOp -> JS.AOp +jStgAOpToJS AssignOp = JS.AssignOp +jStgAOpToJS AddAssignOp = JS.AddAssignOp +jStgAOpToJS SubAssignOp = JS.SubAssignOp diff --git a/GHC/Linker/Config.hs b/GHC/Linker/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/Config.hs @@ -0,0 +1,27 @@ +-- | Linker configuration + +module GHC.Linker.Config + ( FrameworkOpts(..) + , LinkerConfig(..) + ) +where + +import GHC.Prelude +import GHC.Utils.TmpFs +import GHC.Utils.CliOption + +-- used on darwin only +data FrameworkOpts = FrameworkOpts + { foFrameworkPaths :: [String] + , foCmdlineFrameworks :: [String] + } + +-- | External linker configuration +data LinkerConfig = LinkerConfig + { linkerProgram :: String -- ^ Linker program + , linkerOptionsPre :: [Option] -- ^ Linker options (before user options) + , linkerOptionsPost :: [Option] -- ^ Linker options (after user options) + , linkerTempDir :: TempDir -- ^ Temporary directory to use + , linkerFilter :: [String] -> [String] -- ^ Output filter + } + diff --git a/GHC/Linker/Deps.hs b/GHC/Linker/Deps.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/Deps.hs @@ -0,0 +1,312 @@ +-- The transition from Int to Word64 for uniques makes functions slightly larger +-- without this GHC option some optimizations fail to fire. +-- See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10568#note_505751 +{-# OPTIONS_GHC -fspec-constr-threshold=10000 #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Linker.Deps + ( LinkDepsOpts (..) + , LinkDeps (..) + , getLinkDeps + ) +where + +import GHC.Prelude + +import GHC.Platform.Ways + +import GHC.Runtime.Interpreter + +import GHC.Linker.Types + +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.Error + +import GHC.Unit.Env +import GHC.Unit.Finder +import GHC.Unit.Module +import GHC.Unit.Module.WholeCoreBindings +import GHC.Unit.Home.ModInfo + +import GHC.Iface.Errors.Types + +import GHC.Utils.Misc +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Data.Maybe + +import Control.Applicative + +import Data.List (isSuffixOf) + +import System.FilePath +import System.Directory + +data LinkDepsOpts = LinkDepsOpts + { ldObjSuffix :: !String -- ^ Suffix of .o files + , ldForceDyn :: !Bool -- ^ Always use .dyn_o? + , ldUnitEnv :: !UnitEnv + , ldPprOpts :: !SDocContext -- ^ Rendering options for error messages + , ldUseByteCode :: !Bool -- ^ Use bytecode rather than objects + , ldMsgOpts :: !(DiagnosticOpts IfaceMessage) -- ^ Options for diagnostics + , ldWays :: !Ways -- ^ Enabled ways + , ldFinderCache :: !FinderCache + , ldFinderOpts :: !FinderOpts + , ldLoadByteCode :: !(Module -> IO (Maybe Linkable)) + , ldGetDependencies :: !([Module] -> IO ([Module], UniqDSet UnitId)) + } + +data LinkDeps = LinkDeps + { ldNeededLinkables :: [Linkable] + , ldAllLinkables :: [Linkable] + , ldUnits :: [UnitId] + , ldNeededUnits :: UniqDSet UnitId + } + +-- | Find all the packages and linkables that a set of modules depends on +-- +-- Return the module and package dependencies for the needed modules. +-- See Note [Object File Dependencies] +-- +-- Fails with an IO exception if it can't find enough files +-- +getLinkDeps + :: LinkDepsOpts + -> Interp + -> LoaderState + -> SrcSpan -- for error messages + -> [Module] -- If you need these + -> IO LinkDeps -- ... then link these first +getLinkDeps opts interp pls span mods = do + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. + maybe_normal_osuf <- checkNonStdWay opts interp span + + get_link_deps opts pls maybe_normal_osuf span mods + +get_link_deps + :: LinkDepsOpts + -> LoaderState + -> Maybe FilePath -- replace object suffixes? + -> SrcSpan + -> [Module] + -> IO LinkDeps +get_link_deps opts pls maybe_normal_osuf span mods = do + + -- Three step process: + + -- 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) <- ldGetDependencies opts relevant_mods + + let + -- 2. Exclude ones already linked + -- Main reason: avoid findModule calls in get_linkable + (mods_needed, links_got) = partitionWith split_mods mods_s + pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls + + split_mods mod = + let is_linked = lookupModuleEnv (objs_loaded pls) mod + <|> lookupModuleEnv (bcos_loaded pls) mod + in case is_linked of + Just linkable -> Right linkable + Nothing -> Left mod + + -- 3. For each dependent module, find its linkable + -- This will either be in the HPT or (in the case of one-shot + -- compilation) we may need to use maybe_getFileLinkable + lnks_needed <- mapM (get_linkable (ldObjSuffix opts)) mods_needed + + return $ LinkDeps + { ldNeededLinkables = lnks_needed + , ldAllLinkables = links_got ++ lnks_needed + , ldUnits = pkgs_needed + , ldNeededUnits = pkgs_s + } + where + unit_env = ldUnitEnv opts + relevant_mods = filterOut isInteractiveModule mods + + no_obj :: Outputable a => a -> IO b + no_obj mod = dieWith opts span $ + text "cannot find object file for module " <> + quotes (ppr mod) $$ + while_linking_expr + + while_linking_expr = text "while linking an interpreted expression" + + + -- See Note [Using Byte Code rather than Object Code for Template Haskell] + homeModLinkable :: HomeModInfo -> Maybe Linkable + homeModLinkable hmi = + if ldUseByteCode opts + then homeModInfoByteCode hmi <|> homeModInfoObject hmi + else homeModInfoObject hmi <|> homeModInfoByteCode hmi + + get_linkable osuf mod -- A home-package module + = HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case + Just mod_info -> adjust_linkable (expectJust (homeModLinkable mod_info)) + Nothing -> do + -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + case ue_homeUnit unit_env of + Nothing -> no_obj mod + Just home_unit -> do + from_bc <- ldLoadByteCode opts mod + maybe (fallback_no_bytecode home_unit mod) pure from_bc + where + + fallback_no_bytecode home_unit mod = do + let fc = ldFinderCache opts + let fopts = ldFinderOpts opts + mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod) + case mb_stuff of + Found loc _ -> do + mb_lnk <- findObjectLinkableMaybe mod loc + case mb_lnk of + Nothing -> no_obj mod + Just lnk -> adjust_linkable lnk + _ -> no_obj (moduleName mod) + + adjust_linkable lnk + | Just new_osuf <- maybe_normal_osuf = do + new_parts <- mapM (adjust_part new_osuf) + (linkableParts lnk) + return lnk{ linkableParts=new_parts } + | otherwise = + return lnk + + adjust_part new_osuf part = case part of + DotO file ModuleObject -> do + massert (osuf `isSuffixOf` file) + let file_base = fromJust (stripExtension osuf file) + new_file = file_base <.> new_osuf + ok <- doesFileExist new_file + if (not ok) + then dieWith opts span $ + text "cannot find object file " + <> quotes (text new_file) $$ while_linking_expr + else return (DotO new_file ModuleObject) + DotO file ForeignObject -> pure (DotO file ForeignObject) + DotA fp -> panic ("adjust_ul DotA " ++ show fp) + DotDLL fp -> panic ("adjust_ul DotDLL " ++ show fp) + BCOs {} -> pure part + LazyBCOs{} -> pure part + CoreBindings WholeCoreBindings {wcb_module} -> + pprPanic "Unhydrated core bindings" (ppr wcb_module) + + + +{- +Note [Using Byte Code rather than Object Code for Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The `-fprefer-byte-code` flag allows a user to specify that they want to use +byte code (if available) rather than object code for home module dependencies +when executing Template Haskell splices. + +Why might you want to use byte code rather than object code? + +* Producing object code is much slower than producing byte code (for example if you're using -fno-code) +* Linking many large object files, which happens once per splice, is quite expensive. (#21700) + +So we allow the user to choose to use byte code rather than object files if they want to avoid these +two pitfalls. + +When using `-fprefer-byte-code` you have to arrange to have the byte code available. +In normal --make mode it will not be produced unless you enable `-fbyte-code-and-object-code`. +See Note [Home module build products] for some more information about that. + +The only other place where the flag is consulted is when enabling code generation +with `-fno-code`, which does so to anticipate what decision we will make at the +splice point about what we would prefer. +-} + +dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a +dieWith opts span msg = throwProgramError opts (mkLocMessage MCFatal span msg) + +throwProgramError :: LinkDepsOpts -> SDoc -> IO a +throwProgramError opts doc = throwGhcExceptionIO (ProgramError (renderWithContext (ldPprOpts opts) doc)) + +checkNonStdWay :: LinkDepsOpts -> Interp -> SrcSpan -> IO (Maybe FilePath) +checkNonStdWay _opts interp _srcspan + -- On some targets (e.g. wasm) the RTS linker only supports loading + -- dynamic code, in which case we need to ensure the .dyn_o object + -- is picked (instead of .o which is also present because of + -- -dynamic-too) + | ldForceDyn _opts = do + let target_ways = fullWays $ ldWays _opts + pure $ if target_ways `hasWay` WayDyn + then Nothing + else Just $ waysTag (WayDyn `addWay` target_ways) ++ "_o" + + | 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 opts _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) + + | ldObjSuffix opts == normalObjectSuffix && not (null targetFullWays) + = failNonStd opts srcspan + + | otherwise = return (Just (hostWayTag ++ "o")) + where + targetFullWays = fullWays (ldWays opts) + hostWayTag = case waysTag hostFullWays of + "" -> "" + tag -> tag ++ "_" + + normalObjectSuffix :: String + normalObjectSuffix = "o" + +data Way' = Normal | Prof | Dyn | ProfDyn + +failNonStd :: LinkDepsOpts -> SrcSpan -> IO (Maybe FilePath) +failNonStd opts srcspan = dieWith opts srcspan $ + text "Cannot load" <+> pprWay' compWay <+> + text "objects when GHC is built" <+> pprWay' ghciWay $$ + text "To fix this, either:" $$ + text " (1) Use -fexternal-interpreter, or" $$ + buildTwiceMsg + where compWay + | ldWays opts `hasWay` WayDyn && ldWays opts `hasWay` WayProf = ProfDyn + | ldWays opts `hasWay` WayDyn = Dyn + | ldWays opts `hasWay` WayProf = Prof + | otherwise = Normal + ghciWay + | hostIsDynamic && hostIsProfiled = ProfDyn + | 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" + ProfDyn -> "with -prof and -dynamic" +#endif diff --git a/GHC/Linker/Dynamic.hs b/GHC/Linker/Dynamic.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/Dynamic.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE CPP #-} + +-- | Dynamic linker +module GHC.Linker.Dynamic + ( linkDynLib + -- * Platform-specifics + , libmLinkOpts + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Platform.Ways +import GHC.Settings (ToolSettings(toolSettings_ldSupportsSingleModule)) + +import GHC.Driver.Config.Linker +import GHC.Driver.Session + +import GHC.Unit.Env +import GHC.Unit.Types +import GHC.Unit.State +import GHC.Linker.MacOS +import GHC.Linker.Unit +import GHC.Linker.External +import GHC.Utils.Logger +import GHC.Utils.TmpFs + +import Control.Monad (when) +import System.FilePath + +linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages + = do + let platform = ue_platform unit_env + arch = platformArch platform + os = platformOS platform + + -- This is a rather ugly hack to fix dynamically linked + -- GHC on Windows. If GHC is linked with -threaded, then + -- it links against libHSrts_thr. But if base is linked + -- against libHSrts, then both end up getting loaded, + -- and things go wrong. We therefore link the libraries + -- with the same RTS flags that we link GHC with. + dflags | OSMinGW32 <- os + , hostWays `hasWay` WayDyn + = dflags0 { targetWays_ = hostWays } + | otherwise + = dflags0 + + verbFlags = getVerbFlags dflags + o_file = outputFile_ dflags + + pkgs_with_rts <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) + + let pkg_lib_paths = collectLibraryDirs (ways dflags) pkgs_with_rts + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | osElfTarget os || osMachOTarget os + , dynLibLoader dflags == SystemDependent + , -- Only if we want dynamic libraries + ways dflags `hasWay` WayDyn + -- Only use RPath if we explicitly asked for it + , useXLinkerRPath dflags os + = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l] + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + | otherwise = ["-L" ++ l] + + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + -- In general we don't want to link our dynamic libs against the RTS + -- package, because the RTS lib comes in several flavours and we want to be + -- able to pick the flavour when a binary is linked. + -- + -- But: + -- * on Windows we need to link the RTS import lib as Windows does not + -- allow undefined symbols. + -- + -- * the RTS library path is still added to the library search path above + -- in case the RTS is being explicitly linked in (see #3807). + -- + -- * if -flink-rts is used, we link with the rts. + -- + -- * on wasm we need to ensure libHSrts*.so is listed in + -- WASM_DYLINK_NEEDED, otherwise dyld can't load it. + -- + -- + let pkgs_without_rts = filter ((/= rtsUnitId) . unitId) pkgs_with_rts + pkgs + | ArchWasm32 <- arch = pkgs_with_rts + | OSMinGW32 <- os = pkgs_with_rts + | gopt Opt_LinkRts dflags = pkgs_with_rts + | otherwise = pkgs_without_rts + pkg_link_opts = hsLibs unit_link_opts ++ extraLibs unit_link_opts ++ otherFlags unit_link_opts + where + namever = ghcNameVersion dflags + ways_ = ways dflags + unit_link_opts = collectLinkOpts namever ways_ pkgs + + -- probably _stub.o files + -- and last temporary shared object file + let extra_ld_inputs = ldInputs dflags + + -- frameworks + pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs) + let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform + + let linker_config = initLinkerConfig dflags + + case os of + OSMinGW32 -> do + ------------------------------------------------------------- + -- Making a DLL + ------------------------------------------------------------- + let output_fn = case o_file of + Just s -> s + Nothing -> "HSdll.dll" + + runLink logger tmpfs linker_config ( + map Option verbFlags + ++ [ Option "-o" + , FileOption "" output_fn + , Option "-shared" + ] ++ + [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + | gopt Opt_SharedImplib dflags + ] + ++ map (FileOption "") o_files + + -- Permit the linker to auto link _symbol to _imp_symbol + -- This lets us link against DLLs without needing an "import library" + ++ [Option "-Wl,--enable-auto-import"] + + ++ extra_ld_inputs + ++ map Option ( + lib_path_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) + _ | os == OSDarwin -> do + ------------------------------------------------------------------- + -- Making a darwin dylib + ------------------------------------------------------------------- + -- About the options used for Darwin: + -- -dynamiclib + -- Apple's way of saying -shared + -- -undefined dynamic_lookup: + -- Without these options, we'd have to specify the correct + -- dependencies for each of the dylibs. Note that we could + -- (and should) do without this for all libraries except + -- the RTS; all we need to do is to pass the correct + -- HSfoo_dyn.dylib files to the link command. + -- -single_module + -- Build the dynamic library as a single "module", i.e. no + -- dynamic binding nonsense when referring to symbols from + -- within the library. The NCG assumes that this option is + -- specified (on i386, at least). + -- In XCode 15, -single_module is the default and passing the + -- flag is now obsolete and raises a warning (#24168). We encode + -- this information into the toolchain field ...SupportsSingleModule. + -- -install_name + -- Mac OS/X stores the path where a dynamic library is (to + -- be) installed in the library itself. It's called the + -- "install name" of the library. Then any library or + -- executable that links against it before it's installed + -- will search for it in its ultimate install location. + -- By default we set the install name to the absolute path + -- at build time, but it can be overridden by the + -- -dylib-install-name option passed to ghc. Cabal does + -- this. + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + + instName <- case dylibInstallName dflags of + Just n -> return n + Nothing -> return $ "@rpath" `combine` (takeFileName output_fn) + runLink logger tmpfs linker_config ( + map Option verbFlags + ++ [ Option "-dynamiclib" + , Option "-o" + , FileOption "" output_fn + ] + ++ map Option o_files + ++ [ Option "-undefined", + Option "dynamic_lookup" + ] + ++ (if toolSettings_ldSupportsSingleModule (toolSettings dflags) + then [ Option "-single_module" ] + else [ ]) + ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ] + then [ ] + else [ Option "-Wl,-read_only_relocs,suppress" ]) + ++ [ Option "-install_name", Option instName ] + ++ map Option lib_path_opts + ++ extra_ld_inputs + ++ map Option framework_opts + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ++ map Option pkg_framework_opts + -- dead_strip_dylibs, will remove unused dylibs, and thus save + -- space in the load commands. The -headerpad is necessary so + -- that we can inject more @rpath's later for the leftover + -- libraries in the runInjectRpaths phase below. + -- + -- See Note [Dynamic linking on macOS] + ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ] + ) + -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 + when (gopt Opt_RPath dflags) $ + runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn + _ -> do + ------------------------------------------------------------------- + -- Making a DSO + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + platform = targetPlatform dflags + unregisterised = platformUnregisterised platform + let bsymbolicFlag = -- we need symbolic linking to resolve + -- non-PIC intra-package-relocations for + -- performance (where symbolic linking works) + -- See Note [-Bsymbolic assumptions by GHC] + -- wasm-ld accepts --Bsymbolic instead + ["-Wl,-Bsymbolic" | not unregisterised && arch /= ArchWasm32 ] + + runLink logger tmpfs linker_config ( + map Option verbFlags + ++ libmLinkOpts platform + ++ [ Option "-o" + , FileOption "" output_fn + ] + ++ map Option o_files + ++ [ Option "-shared" ] + ++ map Option bsymbolicFlag + -- Set the library soname. We use -h rather than -soname as + -- Solaris 10 doesn't support the latter: + -- wasm-ld only accepts -soname and it's of little use anyway + ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) | arch /= ArchWasm32 ] + -- 1. On wasm, --Bsymbolic is an optimization, not + -- a requirement. We build the wasi-sdk sysroot + -- shared libs as well as all Haskell shared + -- libs with --Bsymbolic, but dyld can handle + -- shared libs without --Bsymbolic at + -- link-time. Though there will be more + -- imports/exports to slow things down. + -- 2. --experimental-pic silences wasm-ld warnings + -- that PIC is experimental. + -- 3. --unresolved-symbols=import-dynamic turns + -- unresolved symbols to GOT.mem/GOT.func/env + -- imports, which can be gracefully handled by + -- dyld as lazy bindings. Ideally we'd only + -- enable this for rts since it forward + -- references ghc-prim/ghc-internal, but too + -- many Haskell packages would be rejected at + -- link-time even if their code refers to + -- something that will not be called at + -- run-time in wasm, so enabling it in the + -- driver is a more pragmatic solution. + ++ [ Option "-Wl,--Bsymbolic,--experimental-pic,--unresolved-symbols=import-dynamic" | arch == ArchWasm32 ] + ++ extra_ld_inputs + ++ map Option lib_path_opts + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ) + +-- | Some platforms require that we explicitly link against @libm@ if any +-- math-y things are used (which we assume to include all programs). See #14022. +libmLinkOpts :: Platform -> [Option] +libmLinkOpts platform + | platformHasLibm platform = [Option "-lm"] + | otherwise = [] + +{- +Note [-Bsymbolic assumptions by GHC] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC has a few assumptions about interaction of relocations in NCG and linker: + +1. -Bsymbolic resolves internal references when the shared library is linked, + which is important for performance. +2. When there is a reference to data in a shared library from the main program, + the runtime linker relocates the data object into the main program using an + R_*_COPY relocation. +3. If we used -Bsymbolic, then this results in multiple copies of the data + object, because some references have already been resolved to point to the + original instance. This is bad! + +We work around [3.] for native compiled code by avoiding the generation of +R_*_COPY relocations. + +Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable +-Bsymbolic linking there. + +See related tickets: #4210, #15338 +-} diff --git a/GHC/Linker/External.hs b/GHC/Linker/External.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/External.hs @@ -0,0 +1,26 @@ +-- | External ("system") linker +module GHC.Linker.External + ( LinkerConfig(..) + , runLink + ) +where + +import GHC.Prelude +import GHC.Utils.TmpFs +import GHC.Utils.Logger +import GHC.Utils.Error +import GHC.Utils.CliOption +import GHC.SysTools.Process +import GHC.Linker.Config + +-- | Run the external linker +runLink :: Logger -> TmpFs -> LinkerConfig -> [Option] -> IO () +runLink logger tmpfs cfg args = traceSystoolCommand logger "linker" $ do + let all_args = linkerOptionsPre cfg ++ args ++ linkerOptionsPost cfg + + -- on Windows, mangle environment variables to account for a bug in Windows + -- Vista + mb_env <- getGccEnv all_args + + runSomethingResponseFile logger tmpfs (linkerTempDir cfg) (linkerFilter cfg) + "Linker" (linkerProgram cfg) all_args mb_env diff --git a/GHC/Linker/ExtraObj.hs b/GHC/Linker/ExtraObj.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/ExtraObj.hs @@ -0,0 +1,257 @@ +----------------------------------------------------------------------------- +-- +-- GHC Extra object linking code +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- + +module GHC.Linker.ExtraObj + ( mkExtraObj + , mkExtraObjToLinkIntoBinary + , mkNoteObjsToLinkIntoBinary + , checkLinkInfo + , getLinkInfo + , ghcLinkInfoSectionName + , ghcLinkInfoNoteName + , platformSupportsSavingLinkOpts + , haveRtsOptsFlags + ) +where + +import GHC.Prelude +import GHC.Platform + +import GHC.Unit +import GHC.Unit.Env + +import GHC.Utils.Asm +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Logger +import GHC.Utils.TmpFs + +import GHC.Driver.Session +import GHC.Driver.Ppr + +import qualified GHC.Data.ShortText as ST + +import GHC.SysTools.Elf +import GHC.SysTools.Tasks +import GHC.Linker.Unit + +import Control.Monad +import Data.Maybe + +mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath +mkExtraObj logger tmpfs dflags unit_state extn xs + = do cFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule extn + oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o" + writeFile cFile xs + runCc Nothing logger tmpfs dflags + ([Option "-c", + FileOption "" cFile, + Option "-o", + FileOption "" oFile] + ++ if extn /= "s" + then cOpts + else []) + return oFile + where + -- Pass a different set of options to the C compiler depending one whether + -- we're compiling C or assembler. When compiling C, we pass the usual + -- set of include directories and PIC flags. + cOpts = map Option (picCCOpts dflags) + ++ map (FileOption "-I" . ST.unpack) + (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit) + +-- When linking a binary, we need to create a C main() function that +-- starts everything off. This used to be compiled statically as part +-- of the RTS, but that made it hard to change the -rtsopts setting, +-- so now we generate and compile a main() stub as part of every +-- binary and pass the -rtsopts setting directly to the RTS (#5373) +-- +-- On Windows, when making a shared library we also may need a DllMain. +-- +mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath) +mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do + when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ + logInfo logger $ withPprStyle defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + + case ghcLink dflags of + -- Don't try to build the extra object if it is not needed. Compiling the + -- extra object assumes the presence of the RTS in the unit database + -- (because the extra object imports Rts.h) but GHC's build system may try + -- to build some helper programs before building and registering the RTS! + -- See #18938 for an example where hp2ps failed to build because of a failed + -- (unsafe) lookup for the RTS in the unit db. + _ | gopt Opt_NoHsMain dflags + -> return Nothing + + LinkDynLib + | OSMinGW32 <- platformOS (targetPlatform dflags) + -> mk_extra_obj dllMain + + | otherwise + -> return Nothing + + _ -> mk_extra_obj exeMain + + where + mk_extra_obj = fmap Just . mkExtraObj logger tmpfs dflags unit_state "c" . showSDoc dflags + + exeMain = vcat [ + text "#include ", + text "extern StgClosure ZCMain_main_closure;", + text "int main(int argc, char *argv[])", + char '{', + text " RtsConfig __conf = defaultRtsConfig;", + text " __conf.rts_opts_enabled = " + <> text (show (rtsOptsEnabled dflags)) <> semi, + text " __conf.rts_opts_suggestions = " + <> (if rtsOptsSuggestions dflags + then text "true" + else text "false") <> semi, + text "__conf.keep_cafs = " + <> (if gopt Opt_KeepCAFs dflags + then text "true" + else text "false") <> semi, + case rtsOpts dflags of + Nothing -> Outputable.empty + Just opts -> text " __conf.rts_opts= " <> + text (show opts) <> semi, + text " __conf.rts_hs_main = true;", + text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", + char '}', + char '\n' -- final newline, to keep gcc happy + ] + + dllMain = vcat [ + text "#include ", + text "#include ", + text "#include ", + char '\n', + text "bool", + text "WINAPI", + text "DllMain ( HINSTANCE hInstance STG_UNUSED", + text " , DWORD reason STG_UNUSED", + text " , LPVOID reserved STG_UNUSED", + text " )", + text "{", + text " return true;", + text "}", + char '\n' -- final newline, to keep gcc happy + ] + +-- Write out the link info section into a new assembly file. Previously +-- this was included as inline assembly in the main.c file but this +-- is pretty fragile. gas gets upset trying to calculate relative offsets +-- that span the .note section (notably .text) when debug info is present +mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_packages = do + link_info <- getLinkInfo dflags unit_env dep_packages + + if (platformSupportsSavingLinkOpts (platformOS platform )) + then fmap (:[]) $ mkExtraObj logger tmpfs dflags unit_state "s" (showSDoc dflags (link_opts link_info)) + else return [] + + where + unit_state = ue_homeUnitState unit_env + platform = ue_platform unit_env + link_opts info = hcat + [ -- "link info" section (see Note [LinkInfo section]) + makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info + + -- ALL generated assembly must have this section to disable + -- executable stacks. See also + -- "GHC.CmmToAsm" for another instance + -- where we need to do this. + , if platformHasGnuNonexecStack platform + then text ".section .note.GNU-stack,\"\"," + <> sectionType platform "progbits" <> char '\n' + else Outputable.empty + ] + +-- | Return the "link info" string +-- +-- See Note [LinkInfo section] +getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String +getLinkInfo dflags unit_env dep_packages = do + package_link_opts <- getUnitLinkOpts (ghcNameVersion dflags) (ways dflags) unit_env dep_packages + pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env)) + then return [] + else do + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) + return (collectFrameworks ps) + let link_info = + ( package_link_opts + , pkg_frameworks + , rtsOpts dflags + , rtsOptsEnabled dflags + , gopt Opt_NoHsMain dflags + , map showOpt (ldInputs dflags) + , getOpts dflags opt_l + ) + return (show link_info) + +platformSupportsSavingLinkOpts :: OS -> Bool +platformSupportsSavingLinkOpts os + | os == OSSolaris2 = False -- see #5382 + | otherwise = osElfTarget os + +-- See Note [LinkInfo section] +ghcLinkInfoSectionName :: String +ghcLinkInfoSectionName = ".debug-ghc-link-info" + -- if we use the ".debug" prefix, then strip will strip it by default + +-- Identifier for the note (see Note [LinkInfo section]) +ghcLinkInfoNoteName :: String +ghcLinkInfoNoteName = "GHC link info" + +-- Returns 'False' if it was, and we can avoid linking, because the +-- previous binary was linked with "the same options". +checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool +checkLinkInfo logger dflags unit_env pkg_deps exe_file + | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env))) + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = return False -- conservatively we should return True, but not + -- linking in this case was the behaviour for a long + -- time so we leave it as-is. + | otherwise + = do + link_info <- getLinkInfo dflags unit_env pkg_deps + debugTraceMsg logger 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfNoteAsString logger exe_file + ghcLinkInfoSectionName ghcLinkInfoNoteName + let sameLinkInfo = (Just link_info == m_exe_link_info) + debugTraceMsg logger 3 $ case m_exe_link_info of + Nothing -> text "Exe link info: Not found" + Just s + | sameLinkInfo -> text ("Exe link info is the same") + | otherwise -> text ("Exe link info is different: " ++ s) + return (not sameLinkInfo) + +{- Note [LinkInfo section] + ~~~~~~~~~~~~~~~~~~~~~~~ + +The "link info" is a string representing the parameters of the link. We save +this information in the binary, and the next time we link, if nothing else has +changed, we use the link info stored in the existing binary to decide whether +to re-link or not. + +The "link info" string is stored in a ELF section called ".debug-ghc-link-info" +(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to +not follow the specified record-based format (see #11022). + +-} + +haveRtsOptsFlags :: DynFlags -> Bool +haveRtsOptsFlags dflags = + isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of + RtsOptsSafeOnly -> False + _ -> True diff --git a/GHC/Linker/Loader.hs b/GHC/Linker/Loader.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/Loader.hs @@ -0,0 +1,1732 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} + +-- +-- (c) The University of Glasgow 2002-2006 + +-- | The loader +-- +-- This module deals with the top-level issues of dynamic linking (loading), +-- calling the object-code linker and the byte-code linker where necessary. +module GHC.Linker.Loader + ( Loader (..) + , LoaderState (..) + , initLoaderState + , uninitializedLoader + , showLoaderState + , getLoaderState + -- * Load & Unload + , loadDecls + , loadPackages + , loadModule + , loadCmdLineLibs + , loadName + , unload + -- * LoadedEnv + , withExtendedLoadedEnv + , extendLoadedEnv + , deleteFromLoadedEnv + -- * Internals + , allocateBreakArrays + , rmDupLinkables + , modifyLoaderState + , initLinkDepsOpts + , getGccSearchDirectory + ) +where + +import GHC.Prelude + +import GHC.Settings + +import GHC.Platform +import GHC.Platform.Ways + +import GHC.Driver.Phases +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Finder + +import GHC.Tc.Utils.Monad + +import GHC.Runtime.Interpreter +import GHCi.BreakArray +import GHCi.RemoteTypes +import GHC.Iface.Load +import GHCi.Message (ConInfoTable(..), LoadedDLL) + +import GHC.ByteCode.Breakpoints +import GHC.ByteCode.Linker +import GHC.ByteCode.Asm +import GHC.ByteCode.Types + +import GHC.Stack.CCS +import GHC.SysTools + +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Types.Unique.DSet +import GHC.Types.Unique.DFM + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.TmpFs + +import GHC.Unit.Env +import GHC.Unit.Home.ModInfo +import GHC.Unit.External (ExternalPackageState (..)) +import GHC.Unit.Module +import GHC.Unit.Module.ModNodeKey +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModIface +import GHC.Unit.State as Packages + +import qualified GHC.Data.ShortText as ST +import GHC.Data.FastString + +import GHC.Linker.Deps +import GHC.Linker.MacOS +import GHC.Linker.Dynamic +import GHC.Linker.Types + +-- Standard libraries +import Control.Monad + +import Data.Array +import Data.ByteString (ByteString) +import qualified Data.Set as Set +import Data.Char (isSpace) +import qualified Data.Foldable as Foldable +import Data.IORef +import Data.List (intercalate, isPrefixOf, nub, partition) +import Data.Maybe +import Data.Either +import Control.Concurrent.MVar +import qualified Control.Monad.Catch as MC +import qualified Data.List.NonEmpty as NE + +import System.FilePath +import System.Directory +import System.IO.Unsafe +import System.Environment (lookupEnv) + +#if defined(mingw32_HOST_OS) +import System.Win32.Info (getSystemDirectory) +#endif + +import GHC.Utils.Exception +import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey) +import GHC.Driver.Downsweep +import qualified GHC.Runtime.Interpreter as GHCi +import qualified Data.IntMap.Strict as IM +import qualified Data.Map.Strict as M +import Foreign.Ptr (nullPtr) + +-- 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. + +uninitialised :: a +uninitialised = panic "Loader not initialised" + +modifyLoaderState_ :: Interp -> (LoaderState -> IO LoaderState) -> IO () +modifyLoaderState_ interp f = + modifyMVar_ (loader_state (interpLoader interp)) + (fmap pure . f . fromMaybe uninitialised) + +modifyLoaderState :: Interp -> (LoaderState -> IO (LoaderState, a)) -> IO a +modifyLoaderState interp f = + modifyMVar (loader_state (interpLoader interp)) + (fmapFst pure . f . fromMaybe uninitialised) + where fmapFst f = fmap (\(x, y) -> (f x, y)) + +getLoaderState :: Interp -> IO (Maybe LoaderState) +getLoaderState interp = readMVar (loader_state (interpLoader interp)) + + +emptyLoaderState :: LoaderState +emptyLoaderState = LoaderState + { linker_env = LinkerEnv + { closure_env = emptyNameEnv + , itbl_env = emptyNameEnv + , addr_env = emptyNameEnv + } + , pkgs_loaded = init_pkgs + , bcos_loaded = emptyModuleEnv + , objs_loaded = emptyModuleEnv + , temp_sos = [] + , linked_breaks = LinkedBreaks + { breakarray_env = emptyModuleEnv + , ccs_env = emptyModuleEnv + } + } + -- Packages that don't need loading, because the compiler + -- shares them with the interpreted program. + -- + -- The linker's symbol table is populated with RTS symbols using an + -- explicit list. See rts/Linker.c for details. + where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet) + +extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () +extendLoadedEnv interp new_bindings = + modifyLoaderState_ interp $ \pls -> do + return $! modifyClosureEnv pls $ \ce -> + extendClosureEnv ce new_bindings + -- strictness is important for not retaining old copies of the pls + +deleteFromLoadedEnv :: Interp -> [Name] -> IO () +deleteFromLoadedEnv interp to_remove = + modifyLoaderState_ interp $ \pls -> do + return $ modifyClosureEnv pls $ \ce -> + delListFromNameEnv ce to_remove + +-- | Load the module containing the given Name and get its associated 'HValue'. +-- +-- Throws a 'ProgramError' if loading fails or the name cannot be found. +loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded) +loadName interp hsc_env name = do + initLoaderState interp hsc_env + modifyLoaderState interp $ \pls0 -> do + (pls, links, pkgs) <- if not (isExternalName name) + then return (pls0, [], emptyUDFM) + else do + (pls', ok, links, pkgs) <- loadDependencies interp hsc_env pls0 noSrcSpan + [nameModule name] + if failed ok + then throwGhcExceptionIO (ProgramError "") + else return (pls', links, pkgs) + + case lookupNameEnv (closure_env (linker_env pls)) name of + Just (_,aa) -> return (pls,(aa, links, pkgs)) + Nothing -> assertPpr (isExternalName name) (ppr name) $ + do let sym_to_find = IClosureSymbol name + m <- lookupClosure interp sym_to_find + r <- case m of + Just hvref -> mkFinalizedHValue interp hvref + Nothing -> linkFail "GHC.Linker.Loader.loadName" + (ppr sym_to_find) + return (pls,(r, links, pkgs)) + +loadDependencies + :: Interp + -> HscEnv + -> LoaderState + -> SrcSpan + -> [Module] + -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required +-- When called, the loader state must have been initialized (see `initLoaderState`) +loadDependencies interp hsc_env pls span needed_mods = do + let opts = initLinkDepsOpts hsc_env + + -- Find what packages and linkables are required + deps <- getLinkDeps opts interp pls span needed_mods + + let this_pkgs_needed = ldNeededUnits deps + + -- Link the packages and modules required + pls1 <- loadPackages' interp hsc_env (ldUnits deps) pls + (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 (ldNeededLinkables deps) + 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, ldAllLinkables deps, this_pkgs_loaded) + + +-- | Temporarily extend the loaded env. +withExtendedLoadedEnv + :: (ExceptionMonad m) + => Interp + -> [(Name,ForeignHValue)] + -> m a + -> m a +withExtendedLoadedEnv interp new_env action + = MC.bracket (liftIO $ extendLoadedEnv interp new_env) + (\_ -> reset_old_env) + (\_ -> action) + where + -- Remember that the linker state might be side-effected + -- during the execution of the IO action, and we don't want to + -- lose those changes (we might have linked a new module or + -- package), so the reset action only removes the names we + -- added earlier. + reset_old_env = liftIO $ + deleteFromLoadedEnv interp (map fst new_env) + + +-- | Display the loader state. +showLoaderState :: Interp -> IO SDoc +showLoaderState interp = do + ls <- readMVar (loader_state (interpLoader interp)) + let docs = case ls of + Nothing -> [ text "Loader not initialised"] + Just pls -> [ text "Pkgs:" <+> ppr (map loaded_pkg_uid $ eltsUDFM $ pkgs_loaded pls) + , text "Objs:" <+> ppr (moduleEnvElts $ objs_loaded pls) + , text "BCOs:" <+> ppr (moduleEnvElts $ bcos_loaded pls) + ] + + return $ withPprStyle defaultDumpStyle + $ vcat (text "----- Loader state -----":docs) + + +{- ********************************************************************** + + Initialisation + + ********************************************************************* -} + +-- | Initialise the dynamic linker. This entails +-- +-- a) Calling the C initialisation procedure, +-- +-- b) Loading any packages specified on the command line, +-- +-- c) Loading any packages specified on the command line, now held in the +-- @-l@ options in @v_Opt_l@, +-- +-- d) Loading any @.o\/.dll@ files specified on the command line, now held +-- in @ldInputs@, +-- +-- e) Loading any MacOS frameworks. +-- +-- NOTE: This function is idempotent; if called more than once, it does +-- nothing. This is useful in Template Haskell, where we call it before +-- trying to link. +-- +initLoaderState :: Interp -> HscEnv -> IO () +initLoaderState interp hsc_env = do + modifyMVar_ (loader_state (interpLoader interp)) $ \pls -> do + case pls of + Just _ -> return pls + Nothing -> Just <$> reallyInitLoaderState interp hsc_env + +reallyInitLoaderState :: Interp -> HscEnv -> IO LoaderState +reallyInitLoaderState interp hsc_env = do + -- Initialise the linker state + let pls0 = emptyLoaderState + + case platformArch (targetPlatform (hsc_dflags hsc_env)) of + -- FIXME: we don't initialize anything with the JS interpreter. + -- Perhaps we should load preload packages. We'll load them on demand + -- anyway. + ArchJavaScript -> return pls0 + + _ -> do + -- (a) initialise the C dynamic linker + initObjLinker interp + + + -- (b) Load packages from the command-line (Note [preload packages]) + pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env) + + -- steps (c), (d) and (e) + loadCmdLineLibs' interp hsc_env pls + + +loadCmdLineLibs :: Interp -> HscEnv -> IO () +loadCmdLineLibs interp hsc_env = do + initLoaderState interp hsc_env + modifyLoaderState_ interp $ \pls -> + loadCmdLineLibs' interp hsc_env pls + + +loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState +loadCmdLineLibs' interp hsc_env pls = snd <$> + foldM + (\(done', pls') cur_uid -> load done' cur_uid pls') + (Set.empty, pls) + (hsc_all_home_unit_ids hsc_env) + + where + load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState) + load done uid pls | uid `Set.member` done = return (done, pls) + load done uid pls = do + let hsc' = hscSetActiveUnitId uid hsc_env + -- Load potential dependencies first + (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls) + (homeUnitDepends (hsc_units hsc')) + pls'' <- loadCmdLineLibs'' interp hsc' pls' + return $ (Set.insert uid done', pls'') + +loadCmdLineLibs'' + :: Interp + -> HscEnv + -> LoaderState + -> IO LoaderState +loadCmdLineLibs'' interp hsc_env pls = + do + + let dflags@(DynFlags { ldInputs = cmdline_ld_inputs + , libraryPaths = lib_paths_base}) + = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + + -- (c) Link libraries from the command-line + let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] + + -- On Windows we want to add libpthread by default just as GCC would. + -- However because we don't know the actual name of pthread's dll we + -- need to defer this to the locateLib call so we can't initialize it + -- inside of the rts. Instead we do it here to be able to find the + -- import library for pthreads. See #13210. + let platform = targetPlatform dflags + os = platformOS platform + minus_ls = case os of + OSMinGW32 -> "pthread" : minus_ls_1 + _ -> minus_ls_1 + -- See Note [Fork/Exec Windows] + gcc_paths <- getGCCPaths logger dflags os + + lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base + + maybePutStrLn logger "Search directories (user):" + maybePutStr logger (unlines $ map (" "++) lib_paths_env) + maybePutStrLn logger "Search directories (gcc):" + maybePutStr logger (unlines $ map (" "++) gcc_paths) + + libspecs + <- mapM (locateLib interp hsc_env False lib_paths_env gcc_paths) minus_ls + + -- (d) Link .o files from the command-line + classified_ld_inputs <- mapM (classifyLdInput logger platform) + [ f | FileOption _ f <- cmdline_ld_inputs ] + + -- (e) Link any MacOS frameworks + let platform = targetPlatform dflags + let (framework_paths, frameworks) = + if platformUsesFrameworks platform + then (frameworkPaths dflags, cmdlineFrameworks dflags) + else ([],[]) + + -- Finally do (c),(d),(e) + let cmdline_lib_specs = catMaybes classified_ld_inputs + ++ libspecs + ++ map Framework frameworks + if null cmdline_lib_specs + then return pls + else do + -- Add directories to library search paths, this only has an effect + -- on Windows. On Unix OSes this function is a NOP. + let all_paths = let paths = takeDirectory (pgm_c dflags) + : framework_paths + ++ lib_paths_base + ++ [ takeDirectory dll | DLLPath dll <- libspecs ] + in nub $ map normalise paths + let lib_paths = nub $ lib_paths_base ++ gcc_paths + all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths + pathCache <- mapM (addLibrarySearchPath interp) all_paths_env + + let merged_specs = mergeStaticObjects cmdline_lib_specs + pls1 <- foldM (preloadLib interp hsc_env lib_paths framework_paths) pls + merged_specs + + maybePutStr logger "final link ... " + ok <- resolveObjs interp + + -- DLLs are loaded, reset the search paths + mapM_ (removeLibrarySearchPath interp) $ reverse pathCache + + if succeeded ok then maybePutStrLn logger "done" + else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") + + return pls1 + +-- | Merge runs of consecutive of 'Objects'. This allows for resolution of +-- cyclic symbol references when dynamically linking. Specifically, we link +-- together all of the static objects into a single shared object, avoiding +-- the issue we saw in #13786. +mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec] +mergeStaticObjects specs = go [] specs + where + go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec] + go accum (Objects objs : rest) = go (objs ++ accum) rest + go accum@(_:_) rest = Objects (reverse accum) : go [] rest + go [] (spec:rest) = spec : go [] rest + go [] [] = [] + +{- Note [preload packages] + ~~~~~~~~~~~~~~~~~~~~~~~ +Why do we need to preload packages from the command line? This is an +explanation copied from #2437: + +I tried to implement the suggestion from #3560, thinking it would be +easy, but there are two reasons we link in packages eagerly when they +are mentioned on the command line: + + * So that you can link in extra object files or libraries that + depend on the packages. e.g. ghc -package foo -lbar where bar is a + C library that depends on something in foo. So we could link in + foo eagerly if and only if there are extra C libs or objects to + link in, but.... + + * Haskell code can depend on a C function exported by a package, and + the normal dependency tracking that TH uses can't know about these + dependencies. The test ghcilink004 relies on this, for example. + +I conclude that we need two -package flags: one that says "this is a +package I want to make available", and one that says "this is a +package I want to link in eagerly". Would that be too complicated for +users? +-} + +classifyLdInput :: Logger -> Platform -> FilePath -> IO (Maybe LibrarySpec) +classifyLdInput logger platform f + | isObjectFilename platform f = return (Just (Objects [f])) + | isDynLibFilename platform f = return (Just (DLLPath f)) + | otherwise = do + logMsg logger MCInfo noSrcSpan + $ withPprStyle defaultUserStyle + (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) + return Nothing + +preloadLib + :: Interp + -> HscEnv + -> [String] + -> [String] + -> LoaderState + -> LibrarySpec + -> IO LoaderState +preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do + maybePutStr logger ("Loading object " ++ showLS lib_spec ++ " ... ") + case lib_spec of + Objects static_ishs -> do + (b, pls1) <- preload_statics lib_paths static_ishs + maybePutStrLn logger (if b then "done" else "not found") + return pls1 + + Archive static_ish -> do + b <- preload_static_archive lib_paths static_ish + maybePutStrLn logger (if b then "done" else "not found") + return pls + + DLL dll_unadorned -> do + maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned) + case maybe_errstr of + Right _ -> maybePutStrLn logger "done" + Left mm | platformOS platform /= OSDarwin -> + preloadFailed mm lib_paths lib_spec + Left mm | otherwise -> do + -- As a backup, on Darwin, try to also load a .so file + -- since (apparently) some things install that way - see + -- ticket #8770. + let libfile = ("lib" ++ dll_unadorned) <.> "so" + err2 <- loadDLL interp libfile + case err2 of + Right _ -> maybePutStrLn logger "done" + Left _ -> preloadFailed mm lib_paths lib_spec + return pls + + DLLPath dll_path -> do + do maybe_errstr <- loadDLL interp dll_path + case maybe_errstr of + Right _ -> maybePutStrLn logger "done" + Left mm -> preloadFailed mm lib_paths lib_spec + return pls + + Framework framework -> + if platformUsesFrameworks (targetPlatform dflags) + then do maybe_errstr <- loadFramework interp framework_paths framework + case maybe_errstr of + Nothing -> maybePutStrLn logger "done" + Just mm -> preloadFailed mm framework_paths lib_spec + return pls + else throwGhcExceptionIO (ProgramError "preloadLib Framework") + + where + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + + platform = targetPlatform dflags + + preloadFailed :: String -> [String] -> LibrarySpec -> IO () + preloadFailed sys_errmsg paths spec + = do maybePutStr logger "failed.\n" + throwGhcExceptionIO $ + CmdLineError ( + "user specified .o/.so/.DLL could not be loaded (" + ++ sys_errmsg ++ ")\nWhilst trying to load: " + ++ showLS spec ++ "\nAdditional directories searched:" + ++ (if null paths then " (none)" else + intercalate "\n" (map (" "++) paths))) + + -- Not interested in the paths in the static case. + preload_statics _paths names + = do b <- or <$> mapM doesFileExist names + if not b then return (False, pls) + else if interpreterDynamic interp + then do pls1 <- dynLoadObjs interp hsc_env pls names + return (True, pls1) + else do mapM_ (loadObj interp) names + return (True, pls) + + preload_static_archive _paths name + = do b <- doesFileExist name + if not b then return False + else do if interpreterDynamic interp + then throwGhcExceptionIO $ + CmdLineError dynamic_msg + else loadArchive interp name + return True + where + dynamic_msg = unlines + [ "User-specified static library could not be loaded (" + ++ name ++ ")" + , "Loading static libraries is not supported in this configuration." + , "Try using a dynamic library instead." + ] + +initLinkDepsOpts :: HscEnv -> LinkDepsOpts +initLinkDepsOpts hsc_env = opts + where + opts = LinkDepsOpts + { ldObjSuffix = objectSuf dflags + , ldForceDyn = sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags + , ldUnitEnv = hsc_unit_env hsc_env + , ldPprOpts = initSDocContext dflags defaultUserStyle + , ldFinderCache = hsc_FC hsc_env + , ldFinderOpts = initFinderOpts dflags + , ldUseByteCode = gopt Opt_UseBytecodeRatherThanObjects dflags + , ldMsgOpts = initIfaceMessageOpts dflags + , ldWays = ways dflags + , ldGetDependencies = get_reachable_nodes hsc_env + , ldLoadByteCode + } + dflags = hsc_dflags hsc_env + + ldLoadByteCode mod = do + _ <- initIfaceLoad hsc_env $ + loadInterface (text "get_reachable_nodes" <+> parens (ppr mod)) + mod ImportBySystem + EPS {eps_iface_bytecode} <- hscEPS hsc_env + sequence (lookupModuleEnv eps_iface_bytecode mod) + + +get_reachable_nodes :: HscEnv -> [Module] -> IO ([Module], UniqDSet UnitId) +get_reachable_nodes hsc_env mods + + -- Fallback case if the ModuleGraph has not been initialised by the user. + -- This can happen if is the user is loading plugins or doing something else very + -- early in the compiler pipeline. + | isEmptyMG (hsc_mod_graph hsc_env) + = do + mg <- downsweepInstalledModules hsc_env mods + go mg + + | otherwise + = go (hsc_mod_graph hsc_env) + + where + unit_env = hsc_unit_env hsc_env + mkModuleNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m) + + hmgModKey mg m + | let k = NodeKey_Module (mkModuleNk m) + , mgMember mg k = k + | otherwise = NodeKey_ExternalUnit (moduleUnitId m) + + -- The main driver for getting dependencies, which calls the given + -- functions to compute the reachable nodes. + go :: ModuleGraph -> IO ([Module], UniqDSet UnitId) + go mg = do + let mod_keys = map (hmgModKey mg) mods + all_reachable = mod_keys ++ map mkNodeKey (mgReachableLoop mg mod_keys) + (mods_s, pkgs_s) <- partitionEithers <$> mapMaybeM get_mod_info all_reachable + return (mods_s, mkUniqDSet pkgs_s) + + get_mod_info :: NodeKey -> IO (Maybe (Either Module UnitId)) + get_mod_info (NodeKey_Module m@(ModNodeKeyWithUid gwib uid)) = + lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) >>= \case + Just hmi -> return $ Just (Left (mi_module (hm_iface hmi))) + Nothing -> return (Just (Left (mnkToModule m))) + get_mod_info (NodeKey_ExternalUnit uid) = return (Just (Right uid)) + get_mod_info _ = return Nothing + + +{- ********************************************************************** + + Loading a Decls statement + + ********************************************************************* -} + +loadDecls :: Interp -> HscEnv -> SrcSpan -> Linkable -> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded) +loadDecls interp hsc_env span linkable = do + -- Initialise the linker (if it's not been done already) + initLoaderState interp hsc_env + + -- Take lock for the actual work. + modifyLoaderState interp $ \pls0 -> do + -- Link the foreign objects first; BCOs in linkable are ignored here. + (pls1, objs_ok) <- loadObjects interp hsc_env pls0 [linkable] + when (failed objs_ok) $ throwGhcExceptionIO $ ProgramError "loadDecls: failed to load foreign objects" + + -- Link the packages and modules required + (pls, ok, links_needed, units_needed) <- loadDependencies interp hsc_env pls1 span needed_mods + if failed ok + then throwGhcExceptionIO (ProgramError "") + else do + -- Link the expression itself + let le = linker_env pls + let lb = linked_breaks pls + le2_itbl_env <- linkITbls interp (itbl_env le) (concat $ map bc_itbls cbcs) + le2_addr_env <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le) cbcs + le2_breakarray_env <- allocateBreakArrays interp (breakarray_env lb) (catMaybes $ map bc_breaks cbcs) + le2_ccs_env <- allocateCCS interp (ccs_env lb) (catMaybes $ map bc_breaks cbcs) + let le2 = le { itbl_env = le2_itbl_env + , addr_env = le2_addr_env } + let lb2 = lb { breakarray_env = le2_breakarray_env + , ccs_env = le2_ccs_env } + + -- Link the necessary packages and linkables + new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs + nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings + let ce2 = extendClosureEnv (closure_env le2) nms_fhvs + !pls2 = pls { linker_env = le2 { closure_env = ce2 } + , linked_breaks = lb2 } + return (pls2, (nms_fhvs, links_needed, units_needed)) + where + cbcs = linkableBCOs linkable + + free_names = uniqDSetToList $ + foldl' + (\acc cbc -> foldl' (\acc' bco -> bcoFreeNames bco `unionUniqDSets` acc') acc (bc_bcos cbc)) + emptyUniqDSet cbcs + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- free_names, + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + +{- ********************************************************************** + + Loading a single module + + ********************************************************************* -} + +loadModule :: Interp -> HscEnv -> Module -> IO () +loadModule interp hsc_env mod = do + initLoaderState interp hsc_env + modifyLoaderState_ interp $ \pls -> do + (pls', ok, _, _) <- loadDependencies interp hsc_env pls noSrcSpan [mod] + if failed ok + then throwGhcExceptionIO (ProgramError "could not load module") + else return pls' + +{- ********************************************************************** + + Link some linkables + The linkables may consist of a mixture of + byte-code modules and object modules + + ********************************************************************* -} + +loadModuleLinkables :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag) +loadModuleLinkables interp hsc_env pls linkables + = mask_ $ do -- don't want to be interrupted by ^C in here + + debugTraceMsg (hsc_logger hsc_env) 3 $ + hang (text "Loading module linkables") 2 $ vcat [ + hang (text "Objects:") 2 (vcat (ppr <$> objs)), + hang (text "Bytecode:") 2 (vcat (ppr <$> bcos)) + ] + + -- Load objects first; they can't depend on BCOs + (pls1, ok_flag) <- loadObjects interp hsc_env pls objs + + if failed ok_flag then + return (pls1, Failed) + else do + pls2 <- dynLinkBCOs interp pls1 bcos + return (pls2, Succeeded) + where + (objs, bcos) = partitionLinkables linkables + + +linkableInSet :: Linkable -> LinkableSet -> Bool +linkableInSet l objs_loaded = + case lookupModuleEnv objs_loaded (linkableModule l) of + Nothing -> False + Just m -> linkableTime l == linkableTime m + + +{- ********************************************************************** + + The object-code linker + + ********************************************************************* -} + +-- | Load the object files and link them +-- +-- If the interpreter uses dynamic-linking, build a shared library and load it. +-- Otherwise, use the RTS linker. +loadObjects + :: Interp + -> HscEnv + -> LoaderState + -> [Linkable] + -> IO (LoaderState, SuccessFlag) +loadObjects interp hsc_env pls objs = do + let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs + pls1 = pls { objs_loaded = objs_loaded' } + wanted_objs = concatMap linkableFiles new_objs + + if interpreterDynamic interp + then do pls2 <- dynLoadObjs interp hsc_env pls1 wanted_objs + return (pls2, Succeeded) + else do mapM_ (loadObj interp) wanted_objs + + -- Link them all together + ok <- resolveObjs interp + + -- If resolving failed, unload all our + -- object modules and carry on + if succeeded ok then + return (pls1, Succeeded) + else do + pls2 <- unload_wkr interp [] pls1 + return (pls2, Failed) + + +-- | Create a shared library containing the given object files and load it. +dynLoadObjs :: Interp -> HscEnv -> LoaderState -> [FilePath] -> IO LoaderState +dynLoadObjs _ _ pls [] = return pls +dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do + let unit_env = hsc_unit_env hsc_env + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env + let platform = ue_platform unit_env + let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] + let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] + (soFile, libPath , libName) <- + newTempLibName logger tmpfs (tmpDir dflags) TFL_CurrentModule (platformSOExt platform) + let + dflags2 = dflags { + -- We don't want the original ldInputs in + -- (they're already linked in), but we do want + -- to link against previous dynLoadObjs + -- libraries if there were any, so that the linker + -- can resolve dependencies when it loads this + -- library. + ldInputs = + concatMap (\l -> [ Option ("-l" ++ l) ]) + (nub $ snd <$> temp_sos) + ++ concatMap (\lp -> Option ("-L" ++ lp) + : if useXLinkerRPath dflags (platformOS platform) + then [ Option "-Xlinker" + , Option "-rpath" + , Option "-Xlinker" + , Option lp ] + else []) + (nub $ fst <$> temp_sos) + ++ concatMap + (\lp -> Option ("-L" ++ lp) + : if useXLinkerRPath dflags (platformOS platform) + then [ Option "-Xlinker" + , Option "-rpath" + , Option "-Xlinker" + , Option lp ] + else []) + minus_big_ls + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + ++ map (\l -> Option ("-l" ++ l)) minus_ls, + + + -- Add -l options and -L options from dflags. + -- + -- When running TH for a non-dynamic way, we still + -- need to make -l flags to link against the dynamic + -- libraries, so we need to add WayDyn to ways. + -- + -- Likewise if loading if the profiled way then need to + -- add WayProf. + targetWays_ = let ws = Set.singleton WayDyn + in if interpreterProfiled interp + then addWay WayProf ws + else ws, + outputFile_ = Just soFile + } + -- link all "loaded packages" so symbols in those can be resolved + -- Note: We are loading packages with local scope, so to see the + -- symbols in this link we must link all loaded packages again. + linkDynLib logger tmpfs dflags2 unit_env objs (loaded_pkg_uid <$> eltsUDFM pkgs_loaded) + + -- if we got this far, extend the lifetime of the library file + changeTempFilesLifetime tmpfs TFL_GhcSession [soFile] + m <- loadDLL interp soFile + case m of + Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos } + Left err -> linkFail msg (text err) + where + msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" + +rmDupLinkables :: LinkableSet -- Already loaded + -> [Linkable] -- New linkables + -> (LinkableSet, -- New loaded set (including new ones) + [Linkable]) -- New linkables (excluding dups) +rmDupLinkables already ls + = go already [] ls + where + go already extras [] = (already, extras) + go already extras (l:ls) + | linkableInSet l already = go already extras ls + | otherwise = go (extendModuleEnv already (linkableModule l) l) (l:extras) ls + +{- ********************************************************************** + + The byte-code linker + + ********************************************************************* -} + + +dynLinkBCOs :: Interp -> LoaderState -> [Linkable] -> IO LoaderState +dynLinkBCOs interp pls bcos = do + + let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos + pls1 = pls { bcos_loaded = bcos_loaded' } + + parts :: [LinkablePart] + parts = concatMap (NE.toList . linkableParts) new_bcos + + cbcs :: [CompiledByteCode] + cbcs = concatMap linkablePartAllBCOs parts + + + le1 = linker_env pls + lb1 = linked_breaks pls + ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs) + ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs + be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks cbcs) + ce2 <- allocateCCS interp (ccs_env lb1) (catMaybes $ map bc_breaks cbcs) + let le2 = le1 { itbl_env = ie2, addr_env = ae2 } + let lb2 = lb1 { breakarray_env = be2, ccs_env = ce2 } + + names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs + + -- We only want to add the external ones to the ClosureEnv + let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs + + -- Immediately release any HValueRefs we're not going to add + freeHValueRefs interp (map snd to_drop) + -- Wrap finalizers on the ones we want to keep + new_binds <- makeForeignNamedHValueRefs interp to_add + + let ce2 = extendClosureEnv (closure_env le2) new_binds + return $! pls1 { linker_env = le2 { closure_env = ce2 } + , linked_breaks = lb2 } + +-- Link a bunch of BCOs and return references to their values +linkSomeBCOs :: Interp + -> PkgsLoaded + -> LinkerEnv + -> LinkedBreaks + -> [CompiledByteCode] + -> IO [(Name,HValueRef)] + -- The returned HValueRefs are associated 1-1 with + -- the incoming unlinked BCOs. Each gives the + -- value of the corresponding unlinked BCO + +linkSomeBCOs interp pkgs_loaded le lb mods = foldr fun do_link mods [] + where + fun CompiledByteCode{..} inner accum = + inner (Foldable.toList bc_bcos : accum) + + do_link [] = return [] + do_link mods = do + let flat = [ bco | bcos <- mods, bco <- bcos ] + names = map unlinkedBCOName flat + bco_ix = mkNameEnv (zip names [0..]) + resolved <- sequence [ linkBCO interp pkgs_loaded le lb bco_ix bco | bco <- flat ] + hvrefs <- createBCOs interp resolved + return (zip names hvrefs) + +-- | Useful to apply to the result of 'linkSomeBCOs' +makeForeignNamedHValueRefs + :: Interp -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)] +makeForeignNamedHValueRefs interp bindings = + mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue interp hvref) bindings + +linkITbls :: Interp -> ItblEnv -> [(Name, ConInfoTable)] -> IO ItblEnv +linkITbls interp = foldlM $ \env (nm, itbl) -> do + r <- interpCmd interp $ MkConInfoTable itbl + evaluate $ extendNameEnv env nm (nm, ItblPtr r) + +{- ********************************************************************** + + Unload some object modules + + ********************************************************************* -} + +-- --------------------------------------------------------------------------- +-- | Unloading old objects ready for a new compilation sweep. +-- +-- The compilation manager provides us with a list of linkables that it +-- considers \"stable\", i.e. won't be recompiled this time around. For +-- each of the modules current linked in memory, +-- +-- * if the linkable is stable (and it's the same one -- the user may have +-- recompiled the module on the side), we keep it, +-- +-- * otherwise, we unload it. +-- +-- * we also implicitly unload all temporary bindings at this point. +-- +unload + :: Interp + -> HscEnv + -> [Linkable] -- ^ The linkables to *keep*. + -> IO () +unload interp hsc_env linkables + = mask_ $ do -- mask, so we're safe from Ctrl-C in here + + -- Initialise the linker (if it's not been done already) + initLoaderState interp hsc_env + + new_pls + <- modifyLoaderState interp $ \pls -> do + pls1 <- unload_wkr interp linkables pls + return (pls1, pls1) + + let logger = hsc_logger hsc_env + debugTraceMsg logger 3 $ + text "unload: retaining objs" <+> ppr (moduleEnvElts $ objs_loaded new_pls) + debugTraceMsg logger 3 $ + text "unload: retaining bcos" <+> ppr (moduleEnvElts $ bcos_loaded new_pls) + return () + +unload_wkr + :: Interp + -> [Linkable] -- stable linkables + -> LoaderState + -> IO LoaderState +-- Does the core unload business +-- (the wrapper blocks exceptions and deals with the LS get and put) + +unload_wkr interp keep_linkables pls@LoaderState{..} = do + -- NB. careful strictness here to avoid keeping the old LS when + -- we're unloading some code. -fghci-leak-check with the tests in + -- testsuite/ghci can detect space leaks here. + + let (objs_to_keep', bcos_to_keep') = partition linkableIsNativeCodeOnly keep_linkables + objs_to_keep = mkLinkableSet objs_to_keep' + bcos_to_keep = mkLinkableSet bcos_to_keep' + + discard keep l = not (linkableInSet l keep) + + (objs_to_unload, remaining_objs_loaded) = + partitionModuleEnv (discard objs_to_keep) objs_loaded + (bcos_to_unload, remaining_bcos_loaded) = + partitionModuleEnv (discard bcos_to_keep) bcos_loaded + + linkables_to_unload = moduleEnvElts objs_to_unload ++ moduleEnvElts bcos_to_unload + + mapM_ unloadObjs linkables_to_unload + + -- If we unloaded any object files at all, we need to purge the cache + -- of lookupSymbol results. + when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $ + purgeLookupSymbolCache interp + + let -- Note that we want to remove all *local* + -- (i.e. non-isExternal) names too (these are the + -- temporary bindings from the command line). + keep_name :: Name -> Bool + keep_name n = isExternalName n && + nameModule n `elemModuleEnv` remaining_bcos_loaded + + keep_mod :: Module -> Bool + keep_mod m = m `elemModuleEnv` remaining_bcos_loaded + + !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env, + linked_breaks = filterLinkedBreaks keep_mod linked_breaks, + bcos_loaded = remaining_bcos_loaded, + objs_loaded = remaining_objs_loaded } + + return new_pls + where + unloadObjs :: Linkable -> IO () + unloadObjs lnk + | interpreterDynamic interp = return () + -- We don't do any cleanup when linking objects with the + -- dynamic linker. Doing so introduces extra complexity for + -- not much benefit. + + | otherwise + = mapM_ (unloadObj interp) (linkableObjs lnk) + -- The components of a BCO linkable may contain + -- dot-o files (generated from C stubs). + -- + -- But the BCO parts can be unlinked just by + -- letting go of them (plus of course depopulating + -- the symbol table which is done in the main body) + +showLS :: LibrarySpec -> String +showLS (Objects nms) = "(static) [" ++ intercalate ", " nms ++ "]" +showLS (Archive nm) = "(static archive) " ++ nm +showLS (DLL nm) = "(dynamic) " ++ nm +showLS (DLLPath nm) = "(dynamic) " ++ nm +showLS (Framework nm) = "(framework) " ++ nm + +-- | Load exactly the specified packages, and their dependents (unless of +-- course they are already loaded). The dependents are loaded +-- automatically, and it doesn't matter what order you specify the input +-- packages. +-- +loadPackages :: Interp -> HscEnv -> [UnitId] -> IO () +-- NOTE: in fact, since each module tracks all the packages it depends on, +-- we don't really need to use the package-config dependencies. +-- +-- However we do need the package-config stuff (to find aux libs etc), +-- and following them lets us load libraries in the right order, which +-- perhaps makes the error message a bit more localised if we get a link +-- failure. So the dependency walking code is still here. + +loadPackages interp hsc_env new_pkgs = do + -- It's probably not safe to try to load packages concurrently, so we take + -- a lock. + initLoaderState interp hsc_env + modifyLoaderState_ interp $ \pls -> + loadPackages' interp hsc_env new_pkgs pls + +loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState +loadPackages' interp hsc_env new_pks pls = do + pkgs' <- link (pkgs_loaded pls) new_pks + return $! pls { pkgs_loaded = pkgs' + } + where + link :: PkgsLoaded -> [UnitId] -> IO PkgsLoaded + link pkgs new_pkgs = + foldM link_one pkgs new_pkgs + + link_one pkgs new_pkg + | new_pkg `elemUDFM` pkgs -- Already linked + = return pkgs + + | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg + = do { let deps = unitDepends pkg_cfg + -- Link dependents first + ; pkgs' <- link pkgs deps + -- Now link the package itself + ; (hs_cls, extra_cls, loaded_dlls) <- 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 loaded_dlls trans_deps)) } + + | otherwise + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) + + +loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL]) +loadPackage interp hsc_env pkg + = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + platform = targetPlatform dflags + is_dyn = interpreterDynamic interp + dirs | is_dyn = map ST.unpack $ Packages.unitLibraryDynDirs pkg + | otherwise = map ST.unpack $ Packages.unitLibraryDirs pkg + + let hs_libs = map ST.unpack $ Packages.unitLibraries pkg + -- The FFI GHCi import lib isn't needed as + -- GHC.Linker.Loader + rts/Linker.c link the + -- interpreted references to FFI to the compiled FFI. + -- We therefore filter it out so that we don't get + -- duplicate symbol errors. + hs_libs' = filter ("HSffi" /=) hs_libs + + -- Because of slight differences between the GHC dynamic linker and + -- the native system linker some packages have to link with a + -- different list of libraries when using GHCi. Examples include: libs + -- that are actually gnu ld scripts, and the possibility that the .a + -- libs do not exactly match the .so/.dll equivalents. So if the + -- package file provides an "extra-ghci-libraries" field then we use + -- that instead of the "extra-libraries" field. + extdeplibs = map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg) + then Packages.unitExtDepLibsSys pkg + else Packages.unitExtDepLibsGhc pkg) + linkerlibs = [ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ] + extra_libs = extdeplibs ++ linkerlibs + + -- See Note [Fork/Exec Windows] + gcc_paths <- getGCCPaths logger dflags (platformOS platform) + dirs_env <- addEnvPaths "LIBRARY_PATH" dirs + + hs_classifieds + <- mapM (locateLib interp hsc_env True dirs_env gcc_paths) hs_libs' + extra_classifieds + <- mapM (locateLib interp hsc_env False dirs_env gcc_paths) extra_libs + let classifieds = hs_classifieds ++ extra_classifieds + + -- Complication: all the .so's must be loaded before any of the .o's. + let known_hs_dlls = [ dll | DLLPath dll <- hs_classifieds ] + known_extra_dlls = [ dll | DLLPath dll <- extra_classifieds ] + known_dlls = known_hs_dlls ++ known_extra_dlls +#if defined(CAN_LOAD_DLL) + dlls = [ dll | DLL dll <- classifieds ] +#endif + objs = [ obj | Objects objs <- classifieds + , obj <- objs ] + archs = [ arch | Archive arch <- classifieds ] + + -- Add directories to library search paths + let dll_paths = map takeDirectory known_dlls + all_paths = nub $ map normalise $ dll_paths ++ dirs + all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths + pathCache <- mapM (addLibrarySearchPath interp) all_paths_env + + maybePutSDoc logger + (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") + +#if defined(CAN_LOAD_DLL) + loadFrameworks interp platform pkg + -- See Note [Crash early load_dyn and locateLib] + -- Crash early if can't load any of `known_dlls` + mapM_ (load_dyn interp hsc_env True) known_extra_dlls + loaded_dlls <- mapMaybeM (load_dyn interp hsc_env True) known_hs_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 +#else + let loaded_dlls = [] +#endif + -- After loading all the DLLs, we can load the static objects. + -- Ordering isn't important here, because we do one final link + -- step to resolve everything. + mapM_ (loadObj interp) objs + mapM_ (loadArchive interp) archs + + maybePutStr logger "linking ... " + ok <- resolveObjs interp + + -- DLLs are loaded, reset the search paths + -- Import libraries will be loaded via loadArchive so only + -- reset the DLL search path after all archives are loaded + -- as well. + mapM_ (removeLibrarySearchPath interp) $ reverse pathCache + + if succeeded ok + then do + maybePutStrLn logger "done." + return (hs_classifieds, extra_classifieds, loaded_dlls) + else let errmsg = text "unable to load unit `" + <> pprUnitInfoForUser pkg <> text "'" + in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) + +{- +Note [Crash early load_dyn and locateLib] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a package is "normal" (exposes it's code from more than zero Haskell +modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then +it has it's code compiled and linked into the DLL, which GHCi linker picks +when loading the package's code (see the big comment in the beginning of +`locateLib`). + +When loading DLLs, GHCi linker simply calls the system's `dlopen` or +`LoadLibrary` APIs. This is quite different from the case when GHCi linker +loads an object file or static library. When loading an object file or static +library GHCi linker parses them and resolves all symbols "manually". +These object file or static library may reference some external symbols +defined in some external DLLs. And GHCi should know which these +external DLLs are. + +But when GHCi loads a DLL, it's the *system* linker who manages all +the necessary dependencies, and it is able to load this DLL not having +any extra info. Thus we don't *have to* crash in this case even if we +are unable to load any supposed dependencies explicitly. + +Suppose during GHCi session a client of the package wants to +`foreign import` a symbol which isn't exposed by the package DLL, but +is exposed by such an external (dependency) DLL. +If the DLL isn't *explicitly* loaded because `load_dyn` failed to do +this, then the client code eventually crashes because the GHCi linker +isn't able to locate this symbol (GHCi linker maintains a list of +explicitly loaded DLLs it looks into when trying to find a symbol). + +This is why we still should try to load all the dependency DLLs +even though we know that the system linker loads them implicitly when +loading the package DLL. + +Why we still keep the `crash_early` opportunity then not allowing such +a permissive behaviour for any DLLs? Well, we, perhaps, improve a user +experience in some cases slightly. + +But if it happens there exist other corner cases where our current +usage of `crash_early` flag is overly restrictive, we may lift the +restriction very easily. +-} + +#if defined(CAN_LOAD_DLL) +-- we have already searched the filesystem; the strings passed to load_dyn +-- can be passed directly to loadDLL. They are either fully-qualified +-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, +-- loadDLL is going to search the system paths to find the library. +load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO (Maybe (RemotePtr LoadedDLL)) +load_dyn interp hsc_env crash_early dll = do + r <- loadDLL interp dll + case r of + Right loaded_dll -> pure (Just loaded_dll) + Left err -> + if crash_early + then cmdLineErrorIO err + else do + when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts) + $ logMsg logger + (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing) + noSrcSpan $ withPprStyle defaultUserStyle (note err) + pure Nothing + where + diag_opts = initDiagOpts (hsc_dflags hsc_env) + logger = hsc_logger hsc_env + note err = vcat $ map text + [ err + , "It's OK if you don't want to use symbols from it directly." + , "(the package DLL is loaded by the system linker" + , " which manages dependencies by itself)." ] + +loadFrameworks :: Interp -> Platform -> UnitInfo -> IO () +loadFrameworks interp platform pkg + = when (platformUsesFrameworks platform) $ mapM_ load frameworks + where + fw_dirs = map ST.unpack $ Packages.unitExtDepFrameworkDirs pkg + frameworks = map ST.unpack $ Packages.unitExtDepFrameworks pkg + + load fw = do r <- loadFramework interp fw_dirs fw + case r of + Nothing -> return () + Just err -> cmdLineErrorIO ("can't load framework: " + ++ fw ++ " (" ++ err ++ ")" ) +#endif + +-- Try to find an object file for a given library in the given paths. +-- If it isn't present, we assume that addDLL in the RTS can find it, +-- which generally means that it should be a dynamic library in the +-- standard system search path. +-- For GHCi we tend to prefer dynamic libraries over static ones as +-- they are easier to load and manage, have less overhead. +locateLib + :: Interp + -> HscEnv + -> Bool + -> [FilePath] + -> [FilePath] + -> String + -> IO LibrarySpec +locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 + | not is_hs + -- For non-Haskell libraries (e.g. gmp, iconv): + -- first look in library-dirs for a dynamic library (on User paths only) + -- (libfoo.so) + -- then try looking for import libraries on Windows (on User paths only) + -- (.dll.a, .lib) + -- first look in library-dirs for a dynamic library (on GCC paths only) + -- (libfoo.so) + -- then check for system dynamic libraries (e.g. kernel32.dll on windows) + -- then try looking for import libraries on Windows (on GCC paths only) + -- (.dll.a, .lib) + -- then look in library-dirs for a static library (libfoo.a) + -- then look in library-dirs and inplace GCC for a dynamic library (libfoo.so) + -- then try looking for import libraries on Windows (.dll.a, .lib) + -- then look in library-dirs and inplace GCC for a static library (libfoo.a) + -- then try "gcc --print-file-name" to search gcc's search path + -- for a dynamic library (#5289) + -- otherwise, assume loadDLL can find it + -- + -- The logic is a bit complicated, but the rationale behind it is that + -- loading a shared library for us is O(1) while loading an archive is + -- O(n). Loading an import library is also O(n) so in general we prefer + -- shared libraries because they are simpler and faster. + -- + = +#if defined(CAN_LOAD_DLL) + findDll user `orElse` +#endif + tryImpLib user `orElse` +#if defined(CAN_LOAD_DLL) + findDll gcc `orElse` + findSysDll `orElse` +#endif + tryImpLib gcc `orElse` + findArchive `orElse` + tryGcc `orElse` + assumeDll + + | loading_dynamic_hs_libs -- search for .so libraries first. + = findHSDll `orElse` + findDynObject `orElse` + assumeDll + + | otherwise + -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a + = findObject `orElse` + findArchive `orElse` + assumeDll + + where + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + diag_opts = initDiagOpts dflags + dirs = lib_dirs ++ gcc_dirs + gcc = False + user = True + + -- Emulate ld's behavior of treating $LIB in `-l:$LIB` as a literal file + -- name + (lib, verbatim) = case lib0 of + ':' : rest -> (rest, True) + other -> (other, False) + + obj_file + | is_hs && loading_profiled_hs_libs = lib <.> "p_o" + | otherwise = lib <.> "o" + dyn_obj_file = lib <.> "dyn_o" + arch_files + | verbatim = [lib] + | otherwise = [ "lib" ++ lib ++ lib_tag <.> "a" + , lib <.> "a" -- native code has no lib_tag + , "lib" ++ lib + , lib + ] + lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" + + loading_profiled_hs_libs = interpreterProfiled interp + loading_dynamic_hs_libs = interpreterDynamic interp + + import_libs + | verbatim = [lib] + | otherwise = [ lib <.> "lib" + , "lib" ++ lib <.> "lib" + , "lib" ++ lib <.> "dll.a" + , lib <.> "dll.a" + ] + + hs_dyn_lib_name = lib ++ lib_tag ++ dynLibSuffix (ghcNameVersion dflags) + hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name + +#if defined(CAN_LOAD_DLL) + so_name = platformSOName platform lib + lib_so_name = "lib" ++ so_name + dyn_lib_file + | verbatim && any (`isExtensionOf` lib) [".so", ".dylib", ".dll"] + = lib + + | ArchX86_64 <- arch + , OSSolaris2 <- os + = "64" so_name + + | otherwise + = so_name +#endif + + findObject = liftM (fmap $ Objects . (:[])) $ findFile dirs obj_file + findDynObject = liftM (fmap $ Objects . (:[])) $ findFile dirs dyn_obj_file + findArchive = let local name = liftM (fmap Archive) $ findFile dirs name + in apply (map local arch_files) + findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file +#if defined(CAN_LOAD_DLL) + findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs + in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file + findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ + findSystemLibrary interp so_name +#endif + tryGcc = let search = searchForLibUsingGcc logger dflags +#if defined(CAN_LOAD_DLL) + dllpath = liftM (fmap DLLPath) + short = dllpath $ search so_name lib_dirs + full = dllpath $ search lib_so_name lib_dirs + dlls = [short, full] +#endif + gcc name = liftM (fmap Archive) $ search name lib_dirs + files = import_libs ++ arch_files + archives = map gcc files + in apply $ +#if defined(CAN_LOAD_DLL) + dlls ++ +#endif + archives + tryImpLib re = case os of + OSMinGW32 -> + let dirs' = if re == user then lib_dirs else gcc_dirs + implib name = liftM (fmap Archive) $ + findFile dirs' name + in apply (map implib import_libs) + _ -> return Nothing + + -- TH Makes use of the interpreter so this failure is not obvious. + -- So we are nice and warn/inform users why we fail before we do. + -- But only for haskell libraries, as C libraries don't have a + -- profiling/non-profiling distinction to begin with. + assumeDll + | is_hs + , not loading_dynamic_hs_libs + , interpreterProfiled interp + = do + let diag = mkMCDiagnostic diag_opts WarningWithoutFlag Nothing + logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $ + text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ + text " \tTrying dynamic library instead. If this fails try to rebuild" <+> + text "libraries with profiling support." + return (DLL lib) + | otherwise = return (DLL lib) + infixr `orElse` + f `orElse` g = f >>= maybe g return + + apply :: [IO (Maybe a)] -> IO (Maybe a) + apply [] = return Nothing + apply (x:xs) = do x' <- x + if isJust x' + then return x' + else apply xs + + platform = targetPlatform dflags +#if defined(CAN_LOAD_DLL) + arch = platformArch platform +#endif + os = platformOS platform + +searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) +searchForLibUsingGcc logger dflags so dirs = do + -- GCC does not seem to extend the library search path (using -L) when using + -- --print-file-name. So instead pass it a new base location. + str <- askLd logger dflags (map (FileOption "-B") dirs + ++ [Option "--print-file-name", Option so]) + let file = case lines str of + [] -> "" + l:_ -> l + if (file == so) + then return Nothing + else do b <- doesFileExist file -- file could be a folder (see #16063) + return (if b then Just file else Nothing) + +-- | Retrieve the list of search directory GCC and the System use to find +-- libraries and components. See Note [Fork/Exec Windows]. +getGCCPaths :: Logger -> DynFlags -> OS -> IO [FilePath] +getGCCPaths logger dflags os + | os == OSMinGW32 || platformArch (targetPlatform dflags) == ArchWasm32 = + do gcc_dirs <- getGccSearchDirectory logger dflags "libraries" + sys_dirs <- getSystemDirectories + return $ nub $ gcc_dirs ++ sys_dirs + | otherwise = return [] + +-- | Cache for the GCC search directories as this can't easily change +-- during an invocation of GHC. (Maybe with some env. variable but we'll) +-- deal with that highly unlikely scenario then. +{-# NOINLINE gccSearchDirCache #-} +gccSearchDirCache :: IORef [(String, [String])] +gccSearchDirCache = unsafePerformIO $ newIORef [] + +-- Note [Fork/Exec Windows] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- fork/exec is expensive on Windows, for each time we ask GCC for a library we +-- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1. +-- So instead get a list of location that GCC would search and use findDirs +-- which hopefully is written in an optimized manner to take advantage of +-- caching. At the very least we remove the overhead of the fork/exec and waits +-- which dominate a large percentage of startup time on Windows. +getGccSearchDirectory :: Logger -> DynFlags -> String -> IO [FilePath] +getGccSearchDirectory logger dflags key = do + cache <- readIORef gccSearchDirCache + case lookup key cache of + Just x -> return x + Nothing -> do + str <- askLd logger dflags [Option "--print-search-dirs"] + let line = dropWhile isSpace str + name = key ++ ": =" + if null line + then return [] + else do let val = split $ find name line + dirs <- filterM doesDirectoryExist val + modifyIORef' gccSearchDirCache ((key, dirs):) + return val + where split :: FilePath -> [FilePath] + split r = case break (`elem` [';', ':']) r of + (s, [] ) -> [s] + (s, (_:xs)) -> s : split xs + + find :: String -> String -> String + find r x = let lst = lines x + val = filter (r `isPrefixOf`) lst + in case val of + [] -> [] + x:_ -> case break (=='=') x of + (_ , []) -> [] + (_, (_:xs)) -> xs + +-- | Get a list of system search directories, this to alleviate pressure on +-- the findSysDll function. +getSystemDirectories :: IO [FilePath] +#if defined(mingw32_HOST_OS) +getSystemDirectories = fmap (:[]) getSystemDirectory +#else +getSystemDirectories = return [] +#endif + +-- | Merge the given list of paths with those in the environment variable +-- given. If the variable does not exist then just return the identity. +addEnvPaths :: String -> [String] -> IO [String] +addEnvPaths name list + = do -- According to POSIX (chapter 8.3) a zero-length prefix means current + -- working directory. Replace empty strings in the env variable with + -- `working_dir` (see also #14695). + working_dir <- getCurrentDirectory + values <- lookupEnv name + case values of + Nothing -> return list + Just arr -> return $ list ++ splitEnv working_dir arr + where + splitEnv :: FilePath -> String -> [String] + splitEnv working_dir value = + case break (== envListSep) value of + (x, [] ) -> + [if null x then working_dir else x] + (x, (_:xs)) -> + (if null x then working_dir else x) : splitEnv working_dir xs +#if defined(mingw32_HOST_OS) + envListSep = ';' +#else + envListSep = ':' +#endif + +-- ---------------------------------------------------------------------------- +-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) + + +{- ********************************************************************** + + Helper functions + + ********************************************************************* -} + +maybePutSDoc :: Logger -> SDoc -> IO () +maybePutSDoc logger s + = when (logVerbAtLeast logger 2) $ + logMsg logger + MCInteractive + noSrcSpan + $ withPprStyle defaultUserStyle s + +maybePutStr :: Logger -> String -> IO () +maybePutStr logger s = maybePutSDoc logger (text s) + +maybePutStrLn :: Logger -> String -> IO () +maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n") + +-- | see Note [Generating code for top-level string literal bindings] +allocateTopStrings :: + Interp -> [(Name, ByteString)] -> AddrEnv -> IO AddrEnv +allocateTopStrings interp topStrings prev_env = do + let (bndrs, strings) = unzip topStrings + ptrs <- interpCmd interp $ MallocStrings strings + evaluate $ extendNameEnvList prev_env (zipWith mk_entry bndrs ptrs) + where + mk_entry nm ptr = (nm, (nm, AddrPtr ptr)) + +-- | Given a list of 'InternalModBreaks' collected from a list of +-- 'CompiledByteCode', allocate the 'BreakArray' used to trigger breakpoints. +allocateBreakArrays :: + Interp -> + ModuleEnv (ForeignRef BreakArray) -> + [InternalModBreaks] -> + IO (ModuleEnv (ForeignRef BreakArray)) +allocateBreakArrays interp = + foldlM + ( \be0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks {..}} -> do + -- If no BreakArray is assigned to this module yet, create one + if not $ elemModuleEnv modBreaks_module be0 then do + let count = maybe 0 ((+1) . fst) $ IM.lookupMax imodBreaks_breakInfo + breakArray <- GHCi.newBreakArray interp count + evaluate $ extendModuleEnv be0 modBreaks_module breakArray + else + return be0 + ) + +-- | Given a list of 'InternalModBreaks' collected from a list +-- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is +-- enabled. +-- +-- Note that the resulting arrays are indexed by 'BreakInfoIndex' (internal +-- breakpoint index), not by tick index +allocateCCS :: + Interp -> + ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre)) -> + [InternalModBreaks] -> + IO (ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre))) +allocateCCS interp ce mbss + | interpreterProfiled interp = do + -- 1. Create a mapping from source BreakpointId to CostCentre ptr + ccss <- M.unions <$> mapM + ( \InternalModBreaks{imodBreaks_modBreaks=ModBreaks{..}} -> do + ccs <- {- one ccs ptr per tick index -} + mkCostCentres + interp + (moduleNameString $ moduleName modBreaks_module) + (elems modBreaks_ccs) + return $ M.fromList $ + zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..] + ) + mbss + -- 2. Create an array with one element for every InternalBreakpointId, + -- where every element has the CCS for the corresponding BreakpointId + foldlM + (\ce0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks{..}} -> do + if not $ elemModuleEnv modBreaks_module ce then do + let count = maybe 0 ((+1) . fst) $ IM.lookupMax imodBreaks_breakInfo + let ccs = IM.map + (\info -> + fromMaybe (toRemotePtr nullPtr) + (M.lookup (either internalBreakLoc id (cgb_tick_id info)) ccss) + ) + imodBreaks_breakInfo + assertPpr (count == length ccs) + (text "expected CgBreakInfo map to have one entry per valid ix") $ + evaluate $ + extendModuleEnv ce0 modBreaks_module $ + listArray + (0, count) + (IM.elems ccs) + else + return ce0 + ) + ce + mbss + + | otherwise = pure ce diff --git a/GHC/Linker/MacOS.hs b/GHC/Linker/MacOS.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/MacOS.hs @@ -0,0 +1,177 @@ +module GHC.Linker.MacOS + ( runInjectRPaths + , getUnitFrameworkOpts + , getFrameworkOpts + , loadFramework + ) +where + +import GHC.Prelude +import GHC.Platform + +import GHC.Linker.Config + +import GHC.Driver.DynFlags + +import GHC.Unit.Types +import GHC.Unit.State +import GHC.Unit.Env + +import GHC.Settings +import GHC.SysTools.Tasks + +import GHC.Runtime.Interpreter + +import GHC.Utils.Exception +import GHC.Utils.Logger + +import Data.List (isPrefixOf, nub, sort, intersperse, intercalate) +import Data.Char +import Data.Maybe +import Control.Monad (join, forM, filterM, void) +import System.Directory (doesFileExist, getHomeDirectory) +import System.FilePath ((), (<.>)) +import Text.ParserCombinators.ReadP as Parser + +-- | On macOS we rely on the linkers @-dead_strip_dylibs@ flag to remove unused +-- libraries from the dynamic library. We do this to reduce the number of load +-- commands that end up in the dylib, and has been limited to 32K (32768) since +-- macOS Sierra (10.14). +-- +-- @-dead_strip_dylibs@ does not dead strip @-rpath@ entries, as such passing +-- @-l@ and @-rpath@ to the linker will result in the unnecessary libraries not +-- being included in the load commands, however the @-rpath@ entries are all +-- forced to be included. This can lead to 100s of @-rpath@ entries being +-- included when only a handful of libraries end up being truly linked. +-- +-- Thus after building the library, we run a fixup phase where we inject the +-- @-rpath@ for each found library (in the given library search paths) into the +-- dynamic library through @-add_rpath@. +-- +-- See Note [Dynamic linking on macOS] +runInjectRPaths :: Logger -> ToolSettings -> [FilePath] -> FilePath -> IO () +runInjectRPaths logger toolSettings lib_paths dylib = do + info <- lines <$> askOtool logger toolSettings Nothing [Option "-L", Option dylib] + -- filter the output for only the libraries. And then drop the @rpath prefix. + let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info + -- find any pre-existing LC_PATH items + info <- lines <$> askOtool logger toolSettings Nothing [Option "-l", Option dylib] + let paths = mapMaybe get_rpath info + lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ] + -- only find those rpaths, that aren't already in the library. + rpaths <- nub . sort . join <$> forM libs (\f -> filterM (\l -> doesFileExist (l f)) lib_paths') + -- inject the rpaths + case rpaths of + [] -> return () + _ -> runInstallNameTool logger toolSettings $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] + +get_rpath :: String -> Maybe FilePath +get_rpath l = case readP_to_S rpath_parser l of + [(rpath, "")] -> Just rpath + _ -> Nothing + + +rpath_parser :: ReadP FilePath +rpath_parser = do + skipSpaces + void $ string "path" + void $ many1 (satisfy isSpace) + rpath <- many get + void $ many1 (satisfy isSpace) + void $ string "(offset " + void $ munch1 isDigit + void $ Parser.char ')' + skipSpaces + return rpath + + +getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [String] +getUnitFrameworkOpts unit_env dep_packages + | platformUsesFrameworks (ue_platform unit_env) = do + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) + let pkg_framework_path_opts = map ("-F" ++) (collectFrameworksDirs ps) + pkg_framework_opts = concat [ ["-framework", fw] + | fw <- collectFrameworks ps + ] + return (pkg_framework_path_opts ++ pkg_framework_opts) + + | otherwise = return [] + +getFrameworkOpts :: FrameworkOpts -> Platform -> [String] +getFrameworkOpts fwOpts platform + | platformUsesFrameworks platform = framework_path_opts ++ framework_opts + | otherwise = [] + where + framework_paths = foFrameworkPaths fwOpts + framework_path_opts = map ("-F" ++) framework_paths + + frameworks = foCmdlineFrameworks fwOpts + -- reverse because they're added in reverse order from the cmd line: + framework_opts = concat [ ["-framework", fw] + | fw <- reverse frameworks ] + + +{- +Note [macOS Big Sur dynamic libraries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +macOS Big Sur makes the following change to how frameworks are shipped +with the OS: + +> New in macOS Big Sur 11 beta, the system ships with a built-in +> dynamic linker cache of all system-provided libraries. As part of +> this change, copies of dynamic libraries are no longer present on +> the filesystem. Code that attempts to check for dynamic library +> presence by looking for a file at a path or enumerating a directory +> will fail. Instead, check for library presence by attempting to +> dlopen() the path, which will correctly check for the library in the +> cache. (62986286) + +(https://developer.apple.com/documentation/macos-release-notes/macos-big-sur-11-beta-release-notes/) + +Therefore, the previous method of checking whether a library exists +before attempting to load it makes GHC.Linker.MacOS.loadFramework +fail to find frameworks installed at /System/Library/Frameworks. +Instead, any attempt to load a framework at runtime, such as by +passing -framework OpenGL to runghc or running code loading such a +framework with GHCi, fails with a 'not found' message. + +GHC.Linker.MacOS.loadFramework now opportunistically loads the +framework libraries without checking for their existence first, +failing only if all attempts to load a given framework from any of the +various possible locations fail. See also #18446, which this change +addresses. +-} + +-- Darwin / MacOS X only: load a framework +-- a framework is a dynamic library packaged inside a directory of the same +-- name. They are searched for in different paths than normal libraries. +loadFramework :: Interp -> [FilePath] -> FilePath -> IO (Maybe String) +loadFramework interp extraPaths rootname + = do { either_dir <- tryIO getHomeDirectory + ; let homeFrameworkPath = case either_dir of + Left _ -> [] + Right dir -> [dir "Library/Frameworks"] + ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths + ; errs <- findLoadDLL ps [] + ; return $ fmap (intercalate ", ") errs + } + where + fwk_file = rootname <.> "framework" rootname + + -- sorry for the hardcoded paths, I hope they won't change anytime soon: + defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] + + -- Try to call loadDLL for each candidate path. + -- + -- See Note [macOS Big Sur dynamic libraries] + findLoadDLL [] errs = + -- Tried all our known library paths, but dlopen() + -- has no built-in paths for frameworks: give up + return $ Just errs + findLoadDLL (p:ps) errs = + do { dll <- loadDLL interp (p fwk_file) + ; case dll of + Right _ -> return Nothing + Left err -> findLoadDLL ps ((p ++ ": " ++ err):errs) + } diff --git a/GHC/Linker/Static.hs b/GHC/Linker/Static.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/Static.hs @@ -0,0 +1,312 @@ +module GHC.Linker.Static + ( linkBinary + , linkStaticLib + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Platform.Ways +import GHC.Settings + +import GHC.SysTools +import GHC.SysTools.Ar + +import GHC.Unit.Env +import GHC.Unit.Types +import GHC.Unit.Info +import GHC.Unit.State + +import GHC.Utils.Logger +import GHC.Utils.Monad +import GHC.Utils.Misc +import GHC.Utils.TmpFs + +import GHC.Linker.MacOS +import GHC.Linker.Unit +import GHC.Linker.Dynamic +import GHC.Linker.ExtraObj +import GHC.Linker.External +import GHC.Linker.Windows +import GHC.Linker.Static.Utils + +import GHC.Driver.Config.Linker +import GHC.Driver.Session + +import System.FilePath +import System.Directory +import Control.Monad +import Data.Maybe + +----------------------------------------------------------------------------- +-- Static linking, of .o files + +-- The list of packages passed to link is the list of packages on +-- which this program depends, as discovered by the compilation +-- manager. It is combined with the list of packages that the user +-- specifies on the command line with -package flags. +-- +-- In one-shot linking mode, we can't discover the package +-- dependencies (because we haven't actually done any compilation or +-- read any interface files), so the user must explicitly specify all +-- the packages. + +{- +Note [-Xlinker -rpath vs -Wl,-rpath] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-Wl takes a comma-separated list of options which in the case of +-Wl,-rpath -Wl,some,path,with,commas parses the path with commas +as separate options. +Buck, the build system, produces paths with commas in them. + +-Xlinker doesn't have this disadvantage and as far as I can tell +it is supported by both gcc and clang. Anecdotally nvcc supports +-Xlinker, but not -Wl. +-} + +linkBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkBinary = linkBinary' False + +linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do + let platform = ue_platform unit_env + unit_state = ue_homeUnitState unit_env + toolSettings' = toolSettings dflags + verbFlags = getVerbFlags dflags + arch_os = platformArchOS platform + output_fn = exeFileName arch_os staticLink (outputFile_ dflags) + namever = ghcNameVersion dflags + -- For the wasm target, when ghc is invoked with -dynamic, + -- when linking the final .wasm binary we must still ensure + -- the static archives are selected. Otherwise wasm-ld would + -- fail to find and link the .so library dependencies. wasm-ld + -- can link PIC objects into static .wasm binaries fine, so we + -- only adjust the ways in the final linking step, and only + -- when linking .wasm binary (which is supposed to be fully + -- static), not when linking .so shared libraries. + ways_ + | ArchWasm32 <- platformArch platform = removeWay WayDyn $ targetWays_ dflags + | otherwise = ways dflags + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d output_fn) + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. + pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) + let pkg_lib_paths = collectLibraryDirs ways_ pkgs + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | osElfTarget (platformOS platform) && + dynLibLoader dflags == SystemDependent && + ways_ `hasWay` WayDyn + = let libpath = if gopt Opt_RelativeDynlibPaths dflags + then "$ORIGIN" + (l `makeRelativeTo` full_output_fn) + else l + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + rpath = if useXLinkerRPath dflags (platformOS platform) + then ["-Xlinker", "-rpath", "-Xlinker", libpath] + else [] + -- Solaris 11's linker does not support -rpath-link option. It silently + -- ignores it and then complains about next option which is -l as being a directory and not expected object file, E.g + -- ld: elf error: file + -- /tmp/ghc-src/libraries/base/dist-install/build: + -- elf_begin: I/O error: region read: Is a directory + rpathlink = if (platformOS platform) == OSSolaris2 + then [] + else ["-Xlinker", "-rpath-link", "-Xlinker", l] + in ["-L" ++ l] ++ rpathlink ++ rpath + | osMachOTarget (platformOS platform) && + dynLibLoader dflags == SystemDependent && + ways_ `hasWay` WayDyn && + useXLinkerRPath dflags (platformOS platform) + = let libpath = if gopt Opt_RelativeDynlibPaths dflags + then "@loader_path" + (l `makeRelativeTo` full_output_fn) + else l + in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath] + | otherwise = ["-L" ++ l] + + pkg_lib_path_opts <- + if gopt Opt_SingleLibFolder dflags + then do + libs <- getLibs namever ways_ unit_env dep_units + tmpDir <- newTempSubDir logger tmpfs (tmpDir dflags) + sequence_ [ copyFile lib (tmpDir basename) + | (lib, basename) <- libs] + return [ "-L" ++ tmpDir ] + else pure pkg_lib_path_opts + + let + dead_strip + | gopt Opt_WholeArchiveHsLibs dflags = [] + | otherwise = if osSubsectionsViaSymbols (platformOS platform) + then ["-Wl,-dead_strip"] + else [] + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state + noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_units + + let + (pre_hs_libs, post_hs_libs) + | gopt Opt_WholeArchiveHsLibs dflags + = if platformOS platform == OSDarwin + then (["-Wl,-all_load"], []) + -- OS X does not have a flag to turn off -all_load + else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"]) + | otherwise + = ([],[]) + + pkg_link_opts <- do + unit_link_opts <- getUnitLinkOpts namever ways_ unit_env dep_units + return $ otherFlags unit_link_opts ++ dead_strip + ++ pre_hs_libs ++ hsLibs unit_link_opts ++ post_hs_libs + ++ extraLibs unit_link_opts + -- -Wl,-u, contained in other_flags + -- needs to be put before -l, + -- otherwise Solaris linker fails linking + -- a binary with unresolved symbols in RTS + -- which are defined in base package + -- the reason for this is a note in ld(1) about + -- '-u' option: "The placement of this option + -- on the command line is significant. + -- This option must be placed before the library + -- that defines the symbol." + + -- frameworks + pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units + let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform + + -- probably _stub.o files + let extra_ld_inputs = ldInputs dflags + + rc_objs <- case platformOS platform of + OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger tmpfs dflags output_fn + _ -> return [] + + let linker_config = initLinkerConfig dflags + let link dflags args = do + runLink logger tmpfs linker_config args + -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 + when (platformOS platform == OSDarwin && gopt Opt_RPath dflags) $ + GHC.Linker.MacOS.runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn + + link dflags ( + map GHC.SysTools.Option verbFlags + ++ [ GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ] + ++ libmLinkOpts platform + ++ map GHC.SysTools.Option ( + [] + + -- See Note [No PIE when linking] + ++ pieCCLDOpts dflags + + -- Permit the linker to auto link _symbol to _imp_symbol. + -- This lets us link against DLLs without needing an "import library". + ++ (if platformOS platform == OSMinGW32 + then ["-Wl,--enable-auto-import"] + else []) + + -- '-no_compact_unwind' + -- C++/Objective-C exceptions cannot use optimised + -- stack unwinding code. The optimised form is the + -- default in Xcode 4 on at least x86_64, and + -- without this flag we're also seeing warnings + -- like + -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog + -- on x86. + ++ (if not (gopt Opt_CompactUnwind dflags) && + toolSettings_ldSupportsCompactUnwind toolSettings' && + (platformOS platform == OSDarwin) && + case platformArch platform of + ArchX86_64 -> True + ArchAArch64 -> True + _ -> False + then ["-Wl,-no_compact_unwind"] + else []) + + -- We should rather be asking does it support --gc-sections? + ++ (if toolSettings_ldIsGnuLd toolSettings' && + not (gopt Opt_WholeArchiveHsLibs dflags) + then ["-Wl,--gc-sections"] + else []) + + ++ o_files + ++ lib_path_opts) + ++ extra_ld_inputs + ++ map GHC.SysTools.Option ( + rc_objs + ++ framework_opts + ++ pkg_lib_path_opts + ++ extraLinkObj + ++ noteLinkObjs + -- See Note [RTS/ghc-internal interface] + -- (-u must come before -lghc-internal...!) + ++ (if ghcInternalUnitId `elem` map unitId pkgs + then [concat [ "-Wl,-u," + , ['_' | platformLeadingUnderscore platform] + , "init_ghc_hs_iface" ]] + else []) + ++ pkg_link_opts + ++ pkg_framework_opts + ++ (if platformOS platform == OSDarwin + -- dead_strip_dylibs, will remove unused dylibs, and thus save + -- space in the load commands. The -headerpad is necessary so + -- that we can inject more @rpath's later for the left over + -- libraries during runInjectRpaths phase. + -- + -- See Note [Dynamic linking on macOS]. + then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ] + else []) + )) + +-- | Linking a static lib will not really link anything. It will merely produce +-- a static archive of all dependent static libraries. The resulting library +-- will still need to be linked with any remaining link flags. +linkStaticLib :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkStaticLib logger dflags unit_env o_files dep_units = do + let platform = ue_platform unit_env + extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] + modules = o_files ++ extra_ld_inputs + arch_os = platformArchOS platform + output_fn = exeFileName arch_os True (outputFile_ dflags) + namever = ghcNameVersion dflags + ways_ = ways dflags + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d output_fn) + output_exists <- doesFileExist full_output_fn + (when output_exists) $ removeFile full_output_fn + + pkg_cfgs_init <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) + + let pkg_cfgs + | gopt Opt_LinkRts dflags + = pkg_cfgs_init + | otherwise + = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init + + archives <- concatMapM (collectArchives namever ways_) pkg_cfgs + + ar <- foldl mappend + <$> (Archive <$> mapM loadObj modules) + <*> mapM loadAr archives + + if toolSettings_ldIsGnuLd (toolSettings dflags) + then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar + else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar + + -- run ranlib over the archive. write*Ar does *not* create the symbol index. + runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn] diff --git a/GHC/Linker/Static/Utils.hs b/GHC/Linker/Static/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/Static/Utils.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE MultiWayIf #-} + +module GHC.Linker.Static.Utils where + +import GHC.Prelude +import GHC.Platform +import System.FilePath + +-- | Compute the output file name of a program. +-- +-- StaticLink boolean is used to indicate if the program is actually a static library +-- (e.g., on iOS). +-- +-- Use the provided filename (if any), otherwise use "main.exe" (Windows), +-- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the +-- extension if it is missing. +exeFileName :: ArchOS -> Bool -> Maybe FilePath -> FilePath +exeFileName (ArchOS arch os) staticLink output_fn + | Just s <- output_fn = if + | OSMinGW32 <- os -> s "exe" + | ArchJavaScript <- arch -> s "jsexe" + | ArchWasm32 <- arch -> s "wasm" + | staticLink -> s "a" + | otherwise -> s + | otherwise = if + | OSMinGW32 <- os -> "main.exe" + | ArchJavaScript <- arch -> "main.jsexe" + | staticLink -> "liba.a" + | otherwise -> "a.out" + where s ext | null (takeExtension s) = s <.> ext + | otherwise = s diff --git a/GHC/Linker/Types.hs b/GHC/Linker/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/Types.hs @@ -0,0 +1,510 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- +-- Types for the linkers and the loader +-- +-- (c) The University of Glasgow 2019 +-- +----------------------------------------------------------------------------- +module GHC.Linker.Types + ( Loader (..) + , LoaderState (..) + , uninitializedLoader + , modifyClosureEnv + , LinkerEnv(..) + , filterLinkerEnv + , ClosureEnv + , emptyClosureEnv + , extendClosureEnv + , LinkedBreaks(..) + , filterLinkedBreaks + , LinkableSet + , mkLinkableSet + , unionLinkableSet + , ObjFile + , SptEntry(..) + , LibrarySpec(..) + , LoadedPkgInfo(..) + , PkgsLoaded + + -- * Linkable + , Linkable(..) + , LinkablePart(..) + , LinkableObjectSort (..) + , linkableIsNativeCodeOnly + , linkableObjs + , linkableLibs + , linkableFiles + , linkableBCOs + , linkableNativeParts + , linkablePartitionParts + , linkablePartPath + , linkablePartAllBCOs + , isNativeCode + , isNativeLib + , linkableFilterByteCode + , linkableFilterNative + , partitionLinkables + ) +where + +import GHC.Prelude +import GHC.Unit ( UnitId, Module ) +import GHC.ByteCode.Types +import GHCi.BreakArray +import GHCi.RemoteTypes +import GHCi.Message ( LoadedDLL ) + +import GHC.Stack.CCS +import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) +import GHC.Types.Name ( Name ) +import GHC.Types.SptEntry + +import GHC.Utils.Outputable + +import Control.Concurrent.MVar +import Data.Array +import Data.Time ( UTCTime ) +import GHC.Unit.Module.Env +import GHC.Types.Unique.DSet +import GHC.Types.Unique.DFM +import GHC.Unit.Module.WholeCoreBindings +import Data.Maybe (mapMaybe) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import qualified Data.List.NonEmpty as NE + + +{- ********************************************************************** + + The Loader's state + + ********************************************************************* -} + +{- +The loader state *must* match the actual state of the C dynamic linker at all +times. + +The MVar used to hold the LoaderState contains a Maybe LoaderState. The MVar +serves to ensure mutual exclusion between multiple loaded copies of the GHC +library. The Maybe may be Nothing to indicate that the linker has not yet been +initialised. + +The LinkerEnv maps Names to actual closures (for interpreted code only), for +use during linking. + +Note [Looking up symbols in the relevant objects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #23415, we determined that a lot of time (>10s, or even up to >35s!) was +being spent on dynamically loading symbols before actually interpreting code +when `:main` was run in GHCi. The root cause was that for each symbol we wanted +to lookup, we would traverse the list of loaded objects and try find the symbol +in each of them with dlsym (i.e. looking up a symbol was, worst case, linear in +the amount of loaded objects). + +To drastically improve load time (from +-38 seconds down to +-2s), we now: + +1. For every of the native objects loaded for a given unit, store the handles returned by `dlopen`. + - In `pkgs_loaded` of the `LoaderState`, which maps `UnitId`s to + `LoadedPkgInfo`s, where the handles live in its field `loaded_pkg_hs_dlls`. + +2. When looking up a Name (e.g. `lookupHsSymbol`), find that name's `UnitId` in + the `pkgs_loaded` mapping, + +3. And only look for the symbol (with `dlsym`) on the /handles relevant to that + unit/, rather than in every loaded object. + +Note [Symbols may not be found in pkgs_loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently the `pkgs_loaded` mapping only contains the dynamic objects +associated with loaded units. Symbols defined in a static object (e.g. from a +statically-linked Haskell library) are found via the generic `lookupSymbol` +function call by `lookupHsSymbol` when the symbol is not found in any of the +dynamic objects of `pkgs_loaded`. + +The rationale here is two-fold: + + * we have only observed major link-time issues in dynamic linking; lookups in + the RTS linker's static symbol table seem to be fast enough + + * allowing symbol lookups restricted to a single ObjectCode would require the + maintenance of a symbol table per `ObjectCode`, which would introduce time and + space overhead + +This fallback is further needed because we don't look in the haskell objects +loaded for the home units (see the call to `loadModuleLinkables` in +`loadDependencies`, as opposed to the call to `loadPackages'` in the same +function which updates `pkgs_loaded`). We should ultimately keep track of the +objects loaded (probably in `objs_loaded`, for which `LinkableSet` is a bit +unsatisfactory, see a suggestion in 51c5c4eb1f2a33e4dc88e6a37b7b7c135234ce9b) +and be able to lookup symbols specifically in them too (similarly to +`lookupSymbolInDLL`). +-} + +newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) } + +data LoaderState = LoaderState + { linker_env :: !LinkerEnv + -- ^ Current global mapping from Names to their true values + + , bcos_loaded :: !LinkableSet + -- ^ The currently loaded interpreted modules (home package) + + , objs_loaded :: !LinkableSet + -- ^ And the currently-loaded compiled modules (home package) + + , pkgs_loaded :: !PkgsLoaded + -- ^ The currently-loaded packages; always object code + -- haskell libraries, system libraries, transitive dependencies + + , temp_sos :: ![(FilePath, String)] + -- ^ We need to remember the name of previous temporary DLL/.so + -- libraries so we can link them (see #10322) + + , linked_breaks :: !LinkedBreaks + -- ^ Mapping from loaded modules to their breakpoint arrays + } + +uninitializedLoader :: IO Loader +uninitializedLoader = Loader <$> newMVar Nothing + +modifyClosureEnv :: LoaderState -> (ClosureEnv -> ClosureEnv) -> LoaderState +modifyClosureEnv pls f = + let le = linker_env pls + ce = closure_env le + in pls { linker_env = le { closure_env = f ce } } + +data LinkerEnv = LinkerEnv + { closure_env :: !ClosureEnv + -- ^ Current global mapping from closure Names to their true values + + , itbl_env :: !ItblEnv + -- ^ The current global mapping from RdrNames of DataCons to + -- info table addresses. + -- When a new LinkablePart is linked into the running image, or an existing + -- module in the image is replaced, the itbl_env must be updated + -- appropriately. + + , addr_env :: !AddrEnv + -- ^ Like 'closure_env' and 'itbl_env', but for top-level 'Addr#' literals, + -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode. + } + +filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv +filterLinkerEnv f (LinkerEnv closure_e itbl_e addr_e) = LinkerEnv + { closure_env = filterNameEnv (f . fst) closure_e + , itbl_env = filterNameEnv (f . fst) itbl_e + , addr_env = filterNameEnv (f . fst) addr_e + } + +type ClosureEnv = NameEnv (Name, ForeignHValue) + +emptyClosureEnv :: ClosureEnv +emptyClosureEnv = emptyNameEnv + +extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv +extendClosureEnv cl_env pairs + = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs] + +-- | 'BreakArray's and CCSs are allocated per-module at link-time. +-- +-- Specifically, a module's 'BreakArray' is allocated either: +-- - When a BCO for that module is linked +-- - When :break is used on a given module *before* the BCO has been linked. +-- +-- We keep this structure in the 'LoaderState' +data LinkedBreaks + = LinkedBreaks + { breakarray_env :: !(ModuleEnv (ForeignRef BreakArray)) + -- ^ Each 'Module's remote pointer of 'BreakArray'. + + , ccs_env :: !(ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre))) + -- ^ Each 'Module's array of remote pointers of 'CostCentre'. + -- Untouched when not profiling. + } + +filterLinkedBreaks :: (Module -> Bool) -> LinkedBreaks -> LinkedBreaks +filterLinkedBreaks f (LinkedBreaks ba_e ccs_e) = LinkedBreaks + { breakarray_env = filterModuleEnv (\m _ -> f m) ba_e + , ccs_env = filterModuleEnv (\m _ -> f m) ccs_e + } + +type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo + +data LoadedPkgInfo + = LoadedPkgInfo + { loaded_pkg_uid :: !UnitId + , loaded_pkg_hs_objs :: ![LibrarySpec] + , loaded_pkg_non_hs_objs :: ![LibrarySpec] + , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL] + -- ^ See Note [Looking up symbols in the relevant objects] + , loaded_pkg_trans_deps :: UniqDSet UnitId + } + +instance Outputable LoadedPkgInfo where + ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) = + vcat [ppr uid + , ppr hs_objs + , ppr non_hs_objs + , ppr trans_deps ] + + +-- | Information we can use to dynamically link modules into the compiler +data Linkable = Linkable + { linkableTime :: !UTCTime + -- ^ Time at which this linkable was built + -- (i.e. when the bytecodes were produced, + -- or the mod date on the files) + + , linkableModule :: !Module + -- ^ The linkable module itself + + , linkableParts :: NonEmpty LinkablePart + -- ^ Files and chunks of code to link. + } + +type LinkableSet = ModuleEnv Linkable + +mkLinkableSet :: [Linkable] -> LinkableSet +mkLinkableSet ls = mkModuleEnv [(linkableModule l, l) | l <- ls] + +-- | Union of LinkableSets. +-- +-- In case of conflict, keep the most recent Linkable (as per linkableTime) +unionLinkableSet :: LinkableSet -> LinkableSet -> LinkableSet +unionLinkableSet = plusModuleEnv_C go + where + go l1 l2 + | linkableTime l1 > linkableTime l2 = l1 + | otherwise = l2 + +instance Outputable Linkable where + ppr (Linkable when_made mod parts) + = (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod) + $$ nest 3 (ppr parts) + +type ObjFile = FilePath + +-- | Classify the provenance of @.o@ products. +data LinkableObjectSort = + -- | The object is the final product for a module. + -- When linking splices, its file extension will be adapted to the + -- interpreter's way if needed. + ModuleObject + | + -- | The object was created from generated code for foreign stubs or foreign + -- sources added by the user. + -- Its file extension must be preserved, since there are no objects for + -- alternative ways available. + ForeignObject + +-- | Objects which have yet to be linked by the compiler +data LinkablePart + = DotO + ObjFile + -- ^ An object file (.o) + LinkableObjectSort + -- ^ Whether the object is an internal, intermediate build product that + -- should not be adapted to the interpreter's way. Used for foreign stubs + -- loaded from interfaces. + + | DotA FilePath + -- ^ Static archive file (.a) + + | DotDLL FilePath + -- ^ Dynamically linked library file (.so, .dll, .dylib) + + | CoreBindings WholeCoreBindings + -- ^ Serialised core which we can turn into BCOs (or object files), or + -- used by some other backend See Note [Interface Files with Core + -- Definitions] + + | LazyBCOs + CompiledByteCode + -- ^ Some BCOs generated on-demand when forced. This is used for + -- WholeCoreBindings, see Note [Interface Files with Core Definitions] + [FilePath] + -- ^ Objects containing foreign stubs and files + + | BCOs CompiledByteCode + -- ^ A byte-code object, lives only in memory. + +instance Outputable LinkablePart where + ppr (DotO path sort) = text "DotO" <+> text path <+> pprSort sort + where + pprSort = \case + ModuleObject -> empty + ForeignObject -> brackets (text "foreign") + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path + ppr (BCOs bco) = text "BCOs" <+> ppr bco + ppr (LazyBCOs{}) = text "LazyBCOs" + ppr (CoreBindings {}) = text "CoreBindings" + +-- | Return true if the linkable only consists of native code (no BCO) +linkableIsNativeCodeOnly :: Linkable -> Bool +linkableIsNativeCodeOnly l = all isNativeCode (NE.toList (linkableParts l)) + +-- | List the BCOs parts of a linkable. +-- +-- This excludes the LazyBCOs and the CoreBindings parts +linkableBCOs :: Linkable -> [CompiledByteCode] +linkableBCOs l = [ cbc | BCOs cbc <- NE.toList (linkableParts l) ] + +-- | List the native linkable parts (.o/.so/.dll) of a linkable +linkableNativeParts :: Linkable -> [LinkablePart] +linkableNativeParts l = NE.filter isNativeCode (linkableParts l) + +-- | Split linkable parts into (native code parts, BCOs parts) +linkablePartitionParts :: Linkable -> ([LinkablePart],[LinkablePart]) +linkablePartitionParts l = NE.partition isNativeCode (linkableParts l) + +-- | List the native objects (.o) of a linkable +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = concatMap linkablePartObjectPaths (linkableParts l) + +-- | List the native libraries (.so/.dll) of a linkable +linkableLibs :: Linkable -> [LinkablePart] +linkableLibs l = NE.filter isNativeLib (linkableParts l) + +-- | List the paths of the native objects and libraries (.o/.so/.dll) +linkableFiles :: Linkable -> [FilePath] +linkableFiles l = concatMap linkablePartNativePaths (NE.toList (linkableParts l)) + +------------------------------------------- + +-- | Is the part a native object or library? (.o/.so/.dll) +isNativeCode :: LinkablePart -> Bool +isNativeCode = \case + DotO {} -> True + DotA {} -> True + DotDLL {} -> True + BCOs {} -> False + LazyBCOs{} -> False + CoreBindings {} -> False + +-- | Is the part a native library? (.so/.dll) +isNativeLib :: LinkablePart -> Bool +isNativeLib = \case + DotO {} -> False + DotA {} -> True + DotDLL {} -> True + BCOs {} -> False + LazyBCOs{} -> False + CoreBindings {} -> False + +-- | Get the FilePath of linkable part (if applicable) +linkablePartPath :: LinkablePart -> Maybe FilePath +linkablePartPath = \case + DotO fn _ -> Just fn + DotA fn -> Just fn + DotDLL fn -> Just fn + CoreBindings {} -> Nothing + LazyBCOs {} -> Nothing + BCOs {} -> Nothing + +-- | Return the paths of all object code files (.o, .a, .so) contained in this +-- 'LinkablePart'. +linkablePartNativePaths :: LinkablePart -> [FilePath] +linkablePartNativePaths = \case + DotO fn _ -> [fn] + DotA fn -> [fn] + DotDLL fn -> [fn] + CoreBindings {} -> [] + LazyBCOs _ fos -> fos + BCOs {} -> [] + +-- | Return the paths of all object files (.o) contained in this 'LinkablePart'. +linkablePartObjectPaths :: LinkablePart -> [FilePath] +linkablePartObjectPaths = \case + DotO fn _ -> [fn] + DotA _ -> [] + DotDLL _ -> [] + CoreBindings {} -> [] + LazyBCOs _ fos -> fos + BCOs {} -> [] + +-- | Retrieve the compiled byte-code from the linkable part. +-- +-- Contrary to linkableBCOs, this includes byte-code from LazyBCOs. +linkablePartAllBCOs :: LinkablePart -> [CompiledByteCode] +linkablePartAllBCOs = \case + BCOs bco -> [bco] + LazyBCOs bcos _ -> [bcos] + _ -> [] + +linkableFilter :: (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable +linkableFilter f linkable = do + new <- nonEmpty (concatMap f (linkableParts linkable)) + Just linkable {linkableParts = new} + +linkablePartNative :: LinkablePart -> [LinkablePart] +linkablePartNative = \case + u@DotO {} -> [u] + u@DotA {} -> [u] + u@DotDLL {} -> [u] + LazyBCOs _ os -> [DotO f ForeignObject | f <- os] + _ -> [] + +linkablePartByteCode :: LinkablePart -> [LinkablePart] +linkablePartByteCode = \case + u@BCOs {} -> [u] + LazyBCOs bcos _ -> [BCOs bcos] + _ -> [] + +-- | Transform the 'LinkablePart' list in this 'Linkable' to contain only +-- object code files (.o, .a, .so) without 'LazyBCOs'. +-- If no 'LinkablePart' remains, return 'Nothing'. +linkableFilterNative :: Linkable -> Maybe Linkable +linkableFilterNative = linkableFilter linkablePartNative + +-- | Transform the 'LinkablePart' list in this 'Linkable' to contain only byte +-- code without 'LazyBCOs'. +-- If no 'LinkablePart' remains, return 'Nothing'. +linkableFilterByteCode :: Linkable -> Maybe Linkable +linkableFilterByteCode = linkableFilter linkablePartByteCode + +-- | Split the 'LinkablePart' lists in each 'Linkable' into only object code +-- files (.o, .a, .so) and only byte code, without 'LazyBCOs', and return two +-- lists containing the nonempty 'Linkable's for each. +partitionLinkables :: [Linkable] -> ([Linkable], [Linkable]) +partitionLinkables linkables = + ( + mapMaybe linkableFilterNative linkables, + mapMaybe linkableFilterByteCode linkables + ) + +{- ********************************************************************** + + 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 (map (text @SDoc) 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 diff --git a/GHC/Linker/Unit.hs b/GHC/Linker/Unit.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/Unit.hs @@ -0,0 +1,71 @@ + +-- | Linking Haskell units +module GHC.Linker.Unit + ( UnitLinkOpts (..) + , collectLinkOpts + , collectArchives + , getUnitLinkOpts + , getLibs + ) +where + +import GHC.Prelude +import GHC.Platform.Ways +import GHC.Unit.Types +import GHC.Unit.Info +import GHC.Unit.State +import GHC.Unit.Env +import GHC.Utils.Misc + +import qualified GHC.Data.ShortText as ST + +import GHC.Settings + +import Control.Monad +import System.Directory +import System.FilePath + +-- | Linker flags collected from units +data UnitLinkOpts = UnitLinkOpts + { hsLibs :: [String] -- ^ Haskell libraries (as a list of "-lHSfoo...") + , extraLibs :: [String] -- ^ External libraries (as a list of "-lfoo...") + , otherFlags :: [String] -- ^ Extra linker options + } + deriving (Show) + +-- | Find all the link options in these and the preload packages, +-- returning (package hs lib options, extra library options, other flags) +getUnitLinkOpts :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO UnitLinkOpts +getUnitLinkOpts namever ways unit_env pkgs = do + ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs + return (collectLinkOpts namever ways ps) + +collectLinkOpts :: GhcNameVersion -> Ways -> [UnitInfo] -> UnitLinkOpts +collectLinkOpts namever ways ps = UnitLinkOpts + { hsLibs = concatMap (map ("-l" ++) . unitHsLibs namever ways) ps + , extraLibs = concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps + , otherFlags = concatMap (map ST.unpack . unitLinkerOptions) ps + } + +collectArchives :: GhcNameVersion -> Ways -> UnitInfo -> IO [FilePath] +collectArchives namever ways pc = + filterM doesFileExist [ searchPath ("lib" ++ lib ++ ".a") + | searchPath <- searchPaths + , lib <- libs ] + where searchPaths = ordNub . filter notNull . libraryDirsForWay ways $ pc + libs = unitHsLibs namever ways pc ++ map ST.unpack (unitExtDepLibsSys pc) + +-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. +libraryDirsForWay :: Ways -> UnitInfo -> [String] +libraryDirsForWay ws + | hasWay ws WayDyn = map ST.unpack . unitLibraryDynDirs + | otherwise = map ST.unpack . unitLibraryDirs + +getLibs :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO [(String,String)] +getLibs namever ways unit_env pkgs = do + ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs + fmap concat . forM ps $ \p -> do + let candidates = [ (l f, f) | l <- collectLibraryDirs ways [p] + , f <- (\n -> "lib" ++ n ++ ".a") <$> unitHsLibs namever ways p ] + filterM (doesFileExist . fst) candidates + diff --git a/GHC/Linker/Windows.hs b/GHC/Linker/Windows.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/Windows.hs @@ -0,0 +1,65 @@ +module GHC.Linker.Windows + ( maybeCreateManifest + ) +where + +import GHC.Prelude +import GHC.SysTools +import GHC.Driver.Session +import GHC.Utils.TmpFs +import GHC.Utils.Logger + +import System.FilePath +import System.Directory + +maybeCreateManifest + :: Logger + -> TmpFs + -> DynFlags + -> FilePath -- ^ filename of executable + -> IO [FilePath] -- ^ extra objects to embed, maybe +maybeCreateManifest logger tmpfs dflags exe_filename = do + let manifest_filename = exe_filename <.> "manifest" + manifest = + "\n\ + \ \n\ + \ \n\n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \\n" + + writeFile manifest_filename manifest + + -- Windows will find the manifest file if it is named + -- foo.exe.manifest. However, for extra robustness, and so that + -- we can move the binary around, we can embed the manifest in + -- the binary itself using windres: + if not (gopt Opt_EmbedManifest dflags) + then return [] + else do + rc_filename <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rc" + rc_obj_filename <- + newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession (objectSuf dflags) + + writeFile rc_filename $ + "1 24 MOVEABLE PURE \"" ++ manifest_filename ++ "\"\n" + -- magic numbers :-) + + runWindres logger dflags $ map GHC.SysTools.Option $ + ["--input="++rc_filename, + "--output="++rc_obj_filename, + "--output-format=coff"] + -- no FileOptions here: windres doesn't like seeing + -- backslashes, apparently + + removeFile manifest_filename + + return [rc_obj_filename] diff --git a/GHC/Llvm.hs b/GHC/Llvm.hs new file mode 100644 --- /dev/null +++ b/GHC/Llvm.hs @@ -0,0 +1,67 @@ +-- ---------------------------------------------------------------------------- +-- | This module supplies bindings to generate Llvm IR from Haskell +-- (). +-- +-- Note: this module is developed in a demand driven way. It is no complete +-- LLVM binding library in Haskell, but enough to generate code for GHC. +-- +-- This code is derived from code taken from the Essential Haskell Compiler +-- (EHC) project. +-- + +module GHC.Llvm ( + -- * Modules, Functions and Blocks + LlvmModule(..), + + LlvmFunction(..), LlvmFunctionDecl(..), + LlvmFunctions, LlvmFunctionDecls, + LlvmStatement(..), LlvmExpression(..), + LlvmBlocks, LlvmBlock(..), LlvmBlockId, + LlvmParamAttr(..), LlvmParameter, + + -- * Atomic operations + LlvmAtomicOp(..), + + -- * Fence synchronization + LlvmSyncOrdering(..), + + -- * Call Handling + LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..), + LlvmLinkageType(..), LlvmFuncAttr(..), + + -- * Operations and Comparisons + LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..), + + -- * Variables and Type System + LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..), + LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign, + LMConst(..), + + -- ** Some basic types + i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, + + -- ** Metadata types + MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..), + -- *** Module flags + ModuleFlagBehavior(..), + ModuleFlag(..), + moduleFlagToMetaExpr, + + -- ** Operations on the type system. + isGlobal, getLitType, getVarType, + getLink, getStatType, pVarLift, pVarLower, + pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits, + + -- * Pretty Printing + ppVar, ppLit, ppTypeLit, ppName, ppPlainName, + ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, + ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, + ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, + + ) where + +import GHC.Llvm.Syntax +import GHC.Llvm.MetaData +import GHC.Llvm.Ppr +import GHC.Llvm.Types + diff --git a/GHC/Llvm/MetaData.hs b/GHC/Llvm/MetaData.hs new file mode 100644 --- /dev/null +++ b/GHC/Llvm/MetaData.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Llvm.MetaData + ( MetaId(..) + , ppMetaId + , MetaExpr(..) + , MetaAnnot(..) + , MetaDecl(..) + -- * Module flags + , ModuleFlagBehavior(..) + , ModuleFlag(..) + , moduleFlagToMetaExpr + ) where + +import GHC.Prelude + +import GHC.Llvm.Types +import GHC.Utils.Outputable + +-- The LLVM Metadata System. +-- +-- The LLVM metadata feature is poorly documented but roughly follows the +-- following design: +-- - Metadata can be constructed in a few different ways (See below). +-- - After which it can either be attached to LLVM statements to pass along +-- extra information to the optimizer and code generator OR specifically named +-- metadata has an affect on the whole module (i.e., linking behaviour). +-- +-- +-- # Constructing metadata +-- Metadata comes largely in three forms: +-- +-- - Metadata expressions -- these are the raw metadata values that encode +-- information. They consist of metadata strings, metadata nodes, regular +-- LLVM values (both literals and references to global variables) and +-- metadata expressions (i.e., recursive data type). Some examples: +-- !{ !"hello", !0, i32 0 } +-- !{ !1, !{ i32 0 } } +-- +-- - Metadata nodes -- global metadata variables that attach a metadata +-- expression to a number. For example: +-- !0 = !{ [] !} +-- +-- - Named metadata -- global metadata variables that attach a metadata nodes +-- to a name. Used ONLY to communicated module level information to LLVM +-- through a meaningful name. For example: +-- !llvm.module.linkage = !{ !0, !1 } +-- +-- +-- # Using Metadata +-- Using metadata depends on the form it is in: +-- +-- - Attach to instructions -- metadata can be attached to LLVM instructions +-- using a specific reference as follows: +-- %l = load i32* @glob, !nontemporal !10 +-- %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } } +-- Only metadata nodes or expressions can be attached, named metadata cannot. +-- Refer to LLVM documentation for which instructions take metadata and its +-- meaning. +-- +-- - As arguments -- llvm functions can take metadata as arguments, for +-- example: +-- call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1) +-- As with instructions, only metadata nodes or expressions can be attached. +-- +-- - As a named metadata -- Here the metadata is simply declared in global +-- scope using a specific name to communicate module level information to LLVM. +-- For example: +-- !llvm.module.linkage = !{ !0, !1 } +-- + +-- | A reference to an un-named metadata node. +newtype MetaId = MetaId Int + deriving (Eq, Ord, Enum) + +instance Outputable MetaId where + ppr = ppMetaId + +ppMetaId :: IsLine doc => MetaId -> doc +ppMetaId (MetaId n) = char '!' <> int n +{-# SPECIALIZE ppMetaId :: MetaId -> SDoc #-} +{-# SPECIALIZE ppMetaId :: MetaId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | LLVM metadata expressions +data MetaExpr = MetaStr !LMString + | MetaLit !LlvmLit + | MetaNode !MetaId + | MetaVar !LlvmVar + | MetaStruct [MetaExpr] + deriving (Eq) + +-- | Associates some metadata with a specific label for attaching to an +-- instruction. +data MetaAnnot = MetaAnnot LMString MetaExpr + deriving (Eq) + +-- | Metadata declarations. Metadata can only be declared in global scope. +data MetaDecl + -- | Named metadata. Only used for communicating module information to + -- LLVM. ('!name = !{ [!\] }' form). + = MetaNamed !LMString [MetaId] + -- | Metadata node declaration. + -- ('!0 = metadata !{ \ }' form). + | MetaUnnamed !MetaId !MetaExpr + +---------------------------------------------------------------- +-- Module flags +---------------------------------------------------------------- +data ModuleFlagBehavior + = MFBError + | MFBWarning + | MFBRequire + | MFBOverride + | MFBAppend + | MFBAppendUnique + | MFBMax + | MFBMin + +moduleFlagBehaviorToMetaExpr :: ModuleFlagBehavior -> MetaExpr +moduleFlagBehaviorToMetaExpr mfb = + MetaLit $ LMIntLit n i32 + where + n = case mfb of + MFBError -> 1 + MFBWarning -> 2 + MFBRequire -> 3 + MFBOverride -> 4 + MFBAppend -> 5 + MFBAppendUnique -> 6 + MFBMax -> 7 + MFBMin -> 8 + +data ModuleFlag = ModuleFlag { mfBehavior :: ModuleFlagBehavior + , mfName :: LMString + , mfValue :: MetaExpr + } + +moduleFlagToMetaExpr :: ModuleFlag -> MetaExpr +moduleFlagToMetaExpr flag = MetaStruct + [ moduleFlagBehaviorToMetaExpr (mfBehavior flag) + , MetaStr (mfName flag) + , mfValue flag + ] diff --git a/GHC/Llvm/Ppr.hs b/GHC/Llvm/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Llvm/Ppr.hs @@ -0,0 +1,735 @@ + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} + +-------------------------------------------------------------------------------- +-- | Pretty print LLVM IR Code. +-- + +module GHC.Llvm.Ppr ( + + -- * Top level LLVM objects. + ppLlvmModule, + ppLlvmComments, + ppLlvmComment, + ppLlvmGlobals, + ppLlvmGlobal, + ppLlvmAliases, + ppLlvmAlias, + ppLlvmMetas, + ppLlvmMeta, + ppLlvmFunctionDecls, + ppLlvmFunctionDecl, + ppLlvmFunctions, + ppLlvmFunction, + + ppVar, + ppLit, + ppTypeLit, + ppName, + ppPlainName, + + ) where + +import GHC.Prelude + +import GHC.Llvm.Syntax +import GHC.Llvm.MetaData +import GHC.Llvm.Types + +import Data.List ( intersperse ) +import GHC.Utils.Outputable + +import GHC.CmmToLlvm.Config +import GHC.Utils.Panic +import GHC.Types.Unique + +-------------------------------------------------------------------------------- +-- * Top Level Print functions +-------------------------------------------------------------------------------- + +-- | Print out a whole LLVM module. +ppLlvmModule :: IsDoc doc => LlvmCgConfig -> LlvmModule -> doc +ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs) + = ppLlvmComments comments $$ newLine + $$ ppLlvmAliases aliases $$ newLine + $$ ppLlvmMetas opts meta $$ newLine + $$ ppLlvmGlobals opts globals $$ newLine + $$ ppLlvmFunctionDecls decls $$ newLine + $$ ppLlvmFunctions opts funcs +{-# SPECIALIZE ppLlvmModule :: LlvmCgConfig -> LlvmModule -> SDoc #-} +{-# SPECIALIZE ppLlvmModule :: LlvmCgConfig -> LlvmModule -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Print out a multi-line comment, can be inside a function or on its own +ppLlvmComments :: IsDoc doc => [LMString] -> doc +ppLlvmComments comments = lines_ $ map ppLlvmComment comments +{-# SPECIALIZE ppLlvmComments :: [LMString] -> SDoc #-} +{-# SPECIALIZE ppLlvmComments :: [LMString] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print out a comment, can be inside a function or on its own +ppLlvmComment :: IsLine doc => LMString -> doc +ppLlvmComment com = semi <+> ftext com +{-# SPECIALIZE ppLlvmComment :: LMString -> SDoc #-} +{-# SPECIALIZE ppLlvmComment :: LMString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Print out a list of global mutable variable definitions +ppLlvmGlobals :: IsDoc doc => LlvmCgConfig -> [LMGlobal] -> doc +ppLlvmGlobals opts ls = lines_ $ map (ppLlvmGlobal opts) ls +{-# SPECIALIZE ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> SDoc #-} +{-# SPECIALIZE ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print out a global mutable variable definition +ppLlvmGlobal :: IsLine doc => LlvmCgConfig -> LMGlobal -> doc +ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = + let sect = case x of + Just x' -> text ", section" <+> doubleQuotes (ftext x') + Nothing -> empty + + align = case a of + Just a' -> text ", align" <+> int a' + Nothing -> empty + + rhs = case dat of + Just stat -> pprSpecialStatic opts stat + Nothing -> ppLlvmType (pLower $ getVarType var) + + -- Position of linkage is different for aliases. + const = case c of + Global -> "global" + Constant -> "constant" + Alias -> "alias" + + in ppAssignment opts var $ ppLlvmLinkageType link <+> text const <+> rhs <> sect <> align + +ppLlvmGlobal opts (LMGlobal var val) = pprPanic "ppLlvmGlobal" $ + text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic @SDoc opts) val) +{-# SPECIALIZE ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> SDoc #-} +{-# SPECIALIZE ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Print out a list of LLVM type aliases. +ppLlvmAliases :: IsDoc doc => [LlvmAlias] -> doc +ppLlvmAliases tys = lines_ $ map ppLlvmAlias tys +{-# SPECIALIZE ppLlvmAliases :: [LlvmAlias] -> SDoc #-} +{-# SPECIALIZE ppLlvmAliases :: [LlvmAlias] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print out an LLVM type alias. +ppLlvmAlias :: IsLine doc => LlvmAlias -> doc +ppLlvmAlias (name, ty) + = char '%' <> ftext name <+> equals <+> text "type" <+> ppLlvmType ty +{-# SPECIALIZE ppLlvmAlias :: LlvmAlias -> SDoc #-} +{-# SPECIALIZE ppLlvmAlias :: LlvmAlias -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Print out a list of LLVM metadata. +ppLlvmMetas :: IsDoc doc => LlvmCgConfig -> [MetaDecl] -> doc +ppLlvmMetas opts metas = lines_ $ map (ppLlvmMeta opts) metas +{-# SPECIALIZE ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> SDoc #-} +{-# SPECIALIZE ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print out an LLVM metadata definition. +ppLlvmMeta :: IsLine doc => LlvmCgConfig -> MetaDecl -> doc +ppLlvmMeta opts (MetaUnnamed n m) + = ppMetaId n <+> equals <+> ppMetaExpr opts m + +ppLlvmMeta _opts (MetaNamed n m) + = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes + where + nodes = hcat $ intersperse comma $ map ppMetaId m +{-# SPECIALIZE ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> SDoc #-} +{-# SPECIALIZE ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Print out a list of function definitions. +ppLlvmFunctions :: IsDoc doc => LlvmCgConfig -> LlvmFunctions -> doc +ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs +{-# SPECIALIZE ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print out a function definition. +ppLlvmFunction :: IsDoc doc => LlvmCgConfig -> LlvmFunction -> doc +ppLlvmFunction opts fun = + let attrDoc = ppSpaceJoin ppLlvmFuncAttr (funcAttrs fun) + secDoc = case funcSect fun of + Just s' -> text "section" <+> (doubleQuotes $ ftext s') + Nothing -> empty + prefixDoc = case funcPrefix fun of + Just v -> text "prefix" <+> ppStatic opts v + Nothing -> empty + in vcat + [line $ text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun) + <+> attrDoc <+> secDoc <+> prefixDoc + , line lbrace + , ppLlvmBlocks opts (funcBody fun) + , line rbrace + , newLine + , newLine] +{-# SPECIALIZE ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> SDoc #-} +{-# SPECIALIZE ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print out a function definition header. +ppLlvmFunctionHeader :: IsLine doc => LlvmFunctionDecl -> [LMString] -> doc +ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args + = let varg' = case varg of + VarArgs | null p -> text "..." + | otherwise -> text ", ..." + _otherwise -> text "" + align = case a of + Just a' -> text " align " <> int a' + Nothing -> empty + args' = zipWith (\(ty,p) n -> ppLlvmType ty <+> ppSpaceJoin ppLlvmParamAttr p <+> char '%' + <> ftext n) + p + args + in ppLlvmLinkageType l <+> ppLlvmCallConvention c <+> ppLlvmType r <+> char '@' <> ftext n <> lparen <> + hsep (punctuate comma args') <> varg' <> rparen <> align +{-# SPECIALIZE ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print out a list of function declaration. +ppLlvmFunctionDecls :: IsDoc doc => LlvmFunctionDecls -> doc +ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs +{-# SPECIALIZE ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctionDecls :: LlvmFunctionDecls -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print out a function declaration. +-- Declarations define the function type but don't define the actual body of +-- the function. +ppLlvmFunctionDecl :: IsDoc doc => LlvmFunctionDecl -> doc +ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) + = let varg' = case varg of + VarArgs | null p -> text "..." + | otherwise -> text ", ..." + _otherwise -> text "" + align = case a of + Just a' -> text " align" <+> int a' + Nothing -> empty + args = hcat $ intersperse (comma <> space) $ + map (\(t,a) -> ppLlvmType t <+> ppSpaceJoin ppLlvmParamAttr a) p + in lines_ + [ text "declare" <+> ppLlvmLinkageType l <+> ppLlvmCallConvention c + <+> ppLlvmType r <+> char '@' <> ftext n <> lparen <> args <> varg' <> rparen <> align + , empty] +{-# SPECIALIZE ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctionDecl :: LlvmFunctionDecl -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Print out a list of LLVM blocks. +ppLlvmBlocks :: IsDoc doc => LlvmCgConfig -> LlvmBlocks -> doc +ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks +{-# SPECIALIZE ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> SDoc #-} +{-# SPECIALIZE ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print out an LLVM block. +-- It must be part of a function definition. +ppLlvmBlock :: IsDoc doc => LlvmCgConfig -> LlvmBlock -> doc +ppLlvmBlock opts (LlvmBlock blockId stmts) = + let isLabel (MkLabel _) = True + isLabel _ = False + (block, rest) = break isLabel stmts + ppRest = case rest of + MkLabel id:xs -> ppLlvmBlock opts (LlvmBlock id xs) + _ -> empty + in vcat $ + line (ppLlvmBlockLabel blockId) + : map (ppLlvmStatement opts) block + ++ [ empty , ppRest ] +{-# SPECIALIZE ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> SDoc #-} +{-# SPECIALIZE ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print out an LLVM block label. +ppLlvmBlockLabel :: IsLine doc => LlvmBlockId -> doc +ppLlvmBlockLabel id = pprUniqueAlways id <> colon +{-# SPECIALIZE ppLlvmBlockLabel :: LlvmBlockId -> SDoc #-} +{-# SPECIALIZE ppLlvmBlockLabel :: LlvmBlockId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Print out an LLVM statement, with any metadata to append to the statement. +ppLlvmStatement :: IsDoc doc => LlvmCgConfig -> LlvmStatement -> doc +ppLlvmStatement opts stmt = + let ind = line . (text " " <>) + in case stmt of + Assignment dst expr -> ind $ ppAssignment opts dst (ppLlvmExpression opts expr) + Fence st ord -> ind $ ppFence st ord + Branch target -> ind $ ppBranch opts target + BranchIf cond ifT ifF -> ind $ ppBranchIf opts cond ifT ifF + Comment comments -> ppLlvmComments comments + MkLabel label -> line $ ppLlvmBlockLabel label + Store value ptr align metas + -> ind $ ppStore opts value ptr align metas + Switch scrut def tgs -> ppSwitch opts scrut def tgs + Return result -> ind $ ppReturn opts result + Expr expr -> ind $ ppLlvmExpression opts expr + Unreachable -> ind $ text "unreachable" + Nop -> line empty + +{-# SPECIALIZE ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> SDoc #-} +{-# SPECIALIZE ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print out an LLVM expression. +ppLlvmExpression :: IsLine doc => LlvmCgConfig -> LlvmExpression -> doc +ppLlvmExpression opts expr + = case expr of + Alloca tp amount -> ppAlloca opts tp amount + LlvmOp op left right -> ppMachOp opts op left right + Call tp fp args attrs -> ppCall opts tp fp (map MetaVar args) attrs + CallM tp fp args attrs -> ppCall opts tp fp args attrs + Cast op from to -> ppCast opts op from to + Compare op left right -> ppCmpOp opts op left right + Extract vec idx -> ppExtract opts vec idx + ExtractV struct idx -> ppExtractV opts struct idx + Insert vec elt idx -> ppInsert opts vec elt idx + Shuffle v1 v2 idxs -> ppShuffle opts v1 v2 idxs + GetElemPtr inb ptr indexes -> ppGetElementPtr opts inb ptr indexes + Load ptr align -> ppLoad opts ptr align + ALoad ord st ptr -> ppALoad opts ord st ptr + Malloc tp amount -> ppMalloc opts tp amount + AtomicRMW aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering + CmpXChg addr old new s_ord f_ord -> ppCmpXChg opts addr old new s_ord f_ord + Phi tp predecessors -> ppPhi opts tp predecessors + Asm asm c ty v se sk -> ppAsm opts asm c ty v se sk + MExpr meta expr -> ppMetaAnnotExpr opts meta expr +{-# SPECIALIZE ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc #-} +{-# SPECIALIZE ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppMetaExpr :: IsLine doc => LlvmCgConfig -> MetaExpr -> doc +ppMetaExpr opts = \case + MetaVar (LMLitVar (LMNullLit _)) -> text "null" + MetaStr s -> char '!' <> doubleQuotes (ftext s) + MetaLit l -> ppTypeLit opts l + MetaNode n -> ppMetaId n + MetaVar v -> ppVar opts v + MetaStruct es -> char '!' <> braces (ppCommaJoin (ppMetaExpr opts) es) +{-# SPECIALIZE ppMetaExpr :: LlvmCgConfig -> MetaExpr -> SDoc #-} +{-# SPECIALIZE ppMetaExpr :: LlvmCgConfig -> MetaExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-------------------------------------------------------------------------------- +-- * Individual print functions +-------------------------------------------------------------------------------- + +-- | Should always be a function pointer. So a global var of function type +-- (since globals are always pointers) or a local var of pointer function type. +ppCall :: forall doc. IsLine doc => LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] + -> [LlvmFuncAttr] -> doc +ppCall opts ct fptr args attrs = case fptr of + -- + -- if local var function pointer, unwrap + LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d + + -- should be function type otherwise + LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d + + -- not pointer or function, so error + _other -> error $ "ppCall called with non LMFunction type!\nMust be " + ++ " called with either global var of function type or " + ++ "local var of pointer function type." + + where + ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = + let tc = if ct == TailCall then text "tail " else empty + ppValues = ppCallParams opts (map snd params) args + ppArgTy = ppCommaJoin (ppLlvmType . fst) params <> + (case argTy of + VarArgs -> text ", ..." + FixedArgs -> empty) + fnty = space <> lparen <> ppArgTy <> rparen + attrDoc = ppSpaceJoin ppLlvmFuncAttr attrs + in tc <> text "call" <+> ppLlvmCallConvention cc <+> ppLlvmType ret + <> fnty <+> ppName opts fptr <> lparen <+> ppValues + <+> rparen <+> attrDoc + + ppCallParams :: LlvmCgConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> doc + ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args + where + -- Metadata needs to be marked as having the `metadata` type when used + -- in a call argument + ppCallMetaExpr attrs (MetaVar v) = ppVar' attrs opts v + ppCallMetaExpr _ v = text "metadata" <+> ppMetaExpr opts v +{-# SPECIALIZE ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc #-} +{-# SPECIALIZE ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +ppMachOp :: IsLine doc => LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> doc +ppMachOp opts op left right = + ppLlvmMachOp op <+> ppLlvmType (getVarType left) <+> ppName opts left + <> comma <+> ppName opts right +{-# SPECIALIZE ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +ppCmpOp :: IsLine doc => LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> doc +ppCmpOp opts op left right = + let cmpOp + | isInt (getVarType left) && isInt (getVarType right) = text "icmp" + | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp" + | otherwise = text "icmp" -- Just continue as its much easier to debug + {- + | otherwise = error ("can't compare different types, left = " + ++ (show $ getVarType left) ++ ", right = " + ++ (show $ getVarType right)) + -} + in cmpOp <+> ppLlvmCmpOp op <+> ppLlvmType (getVarType left) + <+> ppName opts left <> comma <+> ppName opts right +{-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppAssignment :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc -> doc +ppAssignment opts var expr = ppName opts var <+> equals <+> expr +{-# SPECIALIZE ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc #-} +{-# SPECIALIZE ppAssignment :: LlvmCgConfig -> LlvmVar -> HLine -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppFence :: IsLine doc => Bool -> LlvmSyncOrdering -> doc +ppFence st ord = + let singleThread = case st of True -> text "singlethread" + False -> empty + in text "fence" <+> singleThread <+> ppSyncOrdering ord +{-# SPECIALIZE ppFence :: Bool -> LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppFence :: Bool -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppSyncOrdering :: IsLine doc => LlvmSyncOrdering -> doc +ppSyncOrdering SyncUnord = text "unordered" +ppSyncOrdering SyncMonotonic = text "monotonic" +ppSyncOrdering SyncAcquire = text "acquire" +ppSyncOrdering SyncRelease = text "release" +ppSyncOrdering SyncAcqRel = text "acq_rel" +ppSyncOrdering SyncSeqCst = text "seq_cst" +{-# SPECIALIZE ppSyncOrdering :: LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppSyncOrdering :: LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppAtomicOp :: IsLine doc => LlvmAtomicOp -> doc +ppAtomicOp LAO_Xchg = text "xchg" +ppAtomicOp LAO_Add = text "add" +ppAtomicOp LAO_Sub = text "sub" +ppAtomicOp LAO_And = text "and" +ppAtomicOp LAO_Nand = text "nand" +ppAtomicOp LAO_Or = text "or" +ppAtomicOp LAO_Xor = text "xor" +ppAtomicOp LAO_Max = text "max" +ppAtomicOp LAO_Min = text "min" +ppAtomicOp LAO_Umax = text "umax" +ppAtomicOp LAO_Umin = text "umin" +{-# SPECIALIZE ppAtomicOp :: LlvmAtomicOp -> SDoc #-} +{-# SPECIALIZE ppAtomicOp :: LlvmAtomicOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppAtomicRMW :: IsLine doc => LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> doc +ppAtomicRMW opts aop tgt src ordering = + text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma + <+> ppVar opts src <+> ppSyncOrdering ordering +{-# SPECIALIZE ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppCmpXChg :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar + -> LlvmSyncOrdering -> LlvmSyncOrdering -> doc +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 +{-# SPECIALIZE ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +ppLoad :: IsLine doc => LlvmCgConfig -> LlvmVar -> LMAlign -> doc +ppLoad opts var alignment = + text "load" <+> ppLlvmType derefType <> comma <+> ppVar opts var <> align + where + derefType = pLower $ getVarType var + align = + case alignment of + Just n -> text ", align" <+> int n + Nothing -> empty +{-# SPECIALIZE ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> SDoc #-} +{-# SPECIALIZE ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppALoad :: IsLine doc => LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> doc +ppALoad opts ord st var = + let alignment = llvmWidthInBits (llvmCgPlatform opts) (getVarType var) `quot` 8 + align = text ", align" <+> int alignment + sThreaded | st = text " singlethread" + | otherwise = empty + derefType = pLower $ getVarType var + in text "load atomic" <+> ppLlvmType derefType <> comma <+> ppVar opts var <> sThreaded + <+> ppSyncOrdering ord <> align +{-# SPECIALIZE ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppStore :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> doc +ppStore opts val dst alignment metas = + text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align <+> ppMetaAnnots opts metas + where + align = + case alignment of + Just n -> text ", align" <+> int n + Nothing -> empty +{-# SPECIALIZE ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> SDoc #-} +{-# SPECIALIZE ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +ppCast :: IsLine doc => LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> doc +ppCast opts op from to + = ppLlvmCastOp op + <+> ppLlvmType (getVarType from) <+> ppName opts from + <+> text "to" + <+> ppLlvmType to +{-# SPECIALIZE ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc #-} +{-# SPECIALIZE ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +ppMalloc :: IsLine doc => LlvmCgConfig -> LlvmType -> Int -> doc +ppMalloc opts tp amount = + let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 + in text "malloc" <+> ppLlvmType tp <> comma <+> ppVar opts amount' +{-# SPECIALIZE ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> SDoc #-} +{-# SPECIALIZE ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppAlloca :: IsLine doc => LlvmCgConfig -> LlvmType -> Int -> doc +ppAlloca opts tp amount = + let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 + in text "alloca" <+> ppLlvmType tp <> comma <+> ppVar opts amount' +{-# SPECIALIZE ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> SDoc #-} +{-# SPECIALIZE ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppGetElementPtr :: IsLine doc => LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> doc +ppGetElementPtr opts inb ptr idx = + let indexes = comma <+> ppCommaJoin (ppVar opts) idx + inbound = if inb then text "inbounds" else empty + derefType = pLower $ getVarType ptr + in text "getelementptr" <+> inbound <+> ppLlvmType derefType <> comma <+> ppVar opts ptr + <> indexes +{-# SPECIALIZE ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc #-} +{-# SPECIALIZE ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +ppReturn :: IsLine doc => LlvmCgConfig -> Maybe LlvmVar -> doc +ppReturn opts (Just var) = text "ret" <+> ppVar opts var +ppReturn _ Nothing = text "ret" <+> ppLlvmType LMVoid +{-# SPECIALIZE ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> SDoc #-} +{-# SPECIALIZE ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppBranch :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc +ppBranch opts var = text "br" <+> ppVar opts var +{-# SPECIALIZE ppBranch :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppBranch :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +ppBranchIf :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> doc +ppBranchIf opts cond trueT falseT + = text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT +{-# SPECIALIZE ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +ppPhi :: IsLine doc => LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> doc +ppPhi opts tp preds = + let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label + in text "phi" <+> ppLlvmType tp <+> hsep (punctuate comma $ map ppPreds preds) +{-# SPECIALIZE ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc #-} +{-# SPECIALIZE ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +ppSwitch :: IsDoc doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> doc +ppSwitch opts scrut dflt targets = + let ppTarget (val, lab) = text " " <> ppVar opts val <> comma <+> ppVar opts lab + in lines_ $ concat + [ [text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt <+> char '['] + , map ppTarget targets + , [char ']'] + ] +{-# SPECIALIZE ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc #-} +{-# SPECIALIZE ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +ppAsm :: IsLine doc => LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> doc +ppAsm opts asm constraints rty vars sideeffect alignstack = + let asm' = doubleQuotes $ ftext asm + cons = doubleQuotes $ ftext constraints + rty' = ppLlvmType rty + vars' = lparen <+> ppCommaJoin (ppVar opts) vars <+> rparen + side = if sideeffect then text "sideeffect" else empty + align = if alignstack then text "alignstack" else empty + in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma + <+> cons <> vars' +{-# SPECIALIZE ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc #-} +{-# SPECIALIZE ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppExtract :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> doc +ppExtract opts vec idx = + text "extractelement" + <+> ppLlvmType (getVarType vec) <+> ppName opts vec <> comma + <+> ppVar opts idx +{-# SPECIALIZE ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppExtractV :: IsLine doc => LlvmCgConfig -> LlvmVar -> Int -> doc +ppExtractV opts struct idx = + text "extractvalue" + <+> ppLlvmType (getVarType struct) <+> ppName opts struct <> comma + <+> int idx +{-# SPECIALIZE ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> SDoc #-} +{-# SPECIALIZE ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppInsert :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> doc +ppInsert opts vec elt idx = + text "insertelement" + <+> ppLlvmType (getVarType vec) <+> ppName opts vec <> comma + <+> ppLlvmType (getVarType elt) <+> ppName opts elt <> comma + <+> ppVar opts idx +{-# SPECIALIZE ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppShuffle :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> [Int] -> doc +ppShuffle opts v1 v2 idxs = + text "shufflevector" + <+> ppLlvmType (getVarType v1) <+> ppName opts v1 <> comma + <+> ppLlvmType (getVarType v2) <+> ppName opts v2 <> comma + <+> ppLlvmType (LMVector (length idxs) (LMInt 32)) <+> ppLit opts (LMVectorLit $ map ((`LMIntLit` (LMInt 32)) . fromIntegral) idxs) +{-# SPECIALIZE ppShuffle :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [Int] -> SDoc #-} +{-# SPECIALIZE ppShuffle :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [Int] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppMetaAnnotExpr :: IsLine doc => LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> doc +ppMetaAnnotExpr opts meta expr = + ppLlvmExpression opts expr <> ppMetaAnnots opts meta +{-# SPECIALIZE ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> SDoc #-} +{-# SPECIALIZE ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppMetaAnnots :: IsLine doc => LlvmCgConfig -> [MetaAnnot] -> doc +ppMetaAnnots opts meta = hcat $ map ppMeta meta + where + ppMeta (MetaAnnot name e) + = comma <+> exclamation <> ftext name <+> + case e of + MetaNode n -> ppMetaId n + MetaStruct ms -> exclamation <> braces (ppCommaJoin (ppMetaExpr opts) ms) + other -> exclamation <> braces (ppMetaExpr opts other) -- possible? +{-# SPECIALIZE ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> SDoc #-} +{-# SPECIALIZE ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Return the variable name or value of the 'LlvmVar' +-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@). +ppName :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc +ppName opts v = case v of + LMGlobalVar {} -> char '@' <> ppPlainName opts v + LMLocalVar {} -> char '%' <> ppPlainName opts v + LMNLocalVar {} -> char '%' <> ppPlainName opts v + LMLitVar {} -> ppPlainName opts v +{-# SPECIALIZE ppName :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppName :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Return the variable name or value of the 'LlvmVar' +-- in a plain textual representation (e.g. @x@, @y@ or @42@). +ppPlainName :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc +ppPlainName opts v = case v of + (LMGlobalVar x _ _ _ _ _) -> ftext x + (LMLocalVar x LMLabel ) -> pprUniqueAlways x + (LMLocalVar x _ ) -> char 'l' <> pprUniqueAlways x + (LMNLocalVar x _ ) -> ftext x + (LMLitVar x ) -> ppLit opts x +{-# SPECIALIZE ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppPlainName :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print a literal value. No type. +ppLit :: IsLine doc => LlvmCgConfig -> LlvmLit -> doc +ppLit opts l = case l of + (LMIntLit i _ ) -> integer i + (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 (ppTypeLit opts) ls <+> char '>' + (LMNullLit _ ) -> text "null" + -- #11487 was an issue where we passed undef for some arguments + -- that were actually live. By chance the registers holding those + -- arguments usually happened to have the right values anyways, but + -- that was not guaranteed. To find such bugs reliably, we set the + -- flag below when validating, which replaces undef literals (at + -- common types) with values that are likely to cause a crash or test + -- failure. + (LMUndefLit t ) + | llvmCgFillUndefWithGarbage opts + , Just lit <- garbageLit t -> ppLit opts lit + | otherwise -> text "undef" +{-# SPECIALIZE ppLit :: LlvmCgConfig -> LlvmLit -> SDoc #-} +{-# SPECIALIZE ppLit :: LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppVar :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc +ppVar = ppVar' [] +{-# SPECIALIZE ppVar :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppVar :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppVar' :: IsLine doc => [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> doc +ppVar' attrs opts v = case v of + LMLitVar x -> ppTypeLit' attrs opts x + x -> ppLlvmType (getVarType x) <+> ppSpaceJoin ppLlvmParamAttr attrs <+> ppName opts x +{-# SPECIALIZE ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppTypeLit :: IsLine doc => LlvmCgConfig -> LlvmLit -> doc +ppTypeLit = ppTypeLit' [] +{-# SPECIALIZE ppTypeLit :: LlvmCgConfig -> LlvmLit -> SDoc #-} +{-# SPECIALIZE ppTypeLit :: LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppTypeLit' :: IsLine doc => [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> doc +ppTypeLit' attrs opts l = ppLlvmType (getLitType l) <+> ppSpaceJoin ppLlvmParamAttr attrs <+> ppLit opts l +{-# SPECIALIZE ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc #-} +{-# SPECIALIZE ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppStatic :: IsLine doc => LlvmCgConfig -> LlvmStatic -> doc +ppStatic opts st = case st of + LMComment s -> text "; " <> ftext s + LMStaticLit l -> ppTypeLit opts l + LMUninitType t -> ppLlvmType t <> text " undef" + LMStaticStr s t -> ppLlvmType t <> text " c\"" <> ftext s <> text "\\00\"" + LMStaticArray d t -> ppLlvmType t <> text " [" <> ppCommaJoin (ppStatic opts) d <> char ']' + LMStaticStruc d t -> ppLlvmType t <> text "<{" <> ppCommaJoin (ppStatic opts) d <> text "}>" + LMStaticStrucU d t -> ppLlvmType t <> text "{" <> ppCommaJoin (ppStatic opts) d <> text "}" + LMStaticPointer v -> ppVar opts v + LMTrunc v t -> ppLlvmType t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')' + LMBitc v t -> ppLlvmType t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')' + LMPtoI v t -> ppLlvmType t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')' + LMAdd s1 s2 -> pprStaticArith opts s1 s2 (text "add") (text "fadd") (text "LMAdd") + LMSub s1 s2 -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub") +{-# SPECIALIZE ppStatic :: LlvmCgConfig -> LlvmStatic -> SDoc #-} +{-# SPECIALIZE ppStatic :: LlvmCgConfig -> LlvmStatic -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +pprSpecialStatic :: IsLine doc => LlvmCgConfig -> LlvmStatic -> doc +pprSpecialStatic opts stat = case stat of + LMBitc v t -> ppLlvmType (pLower t) + <> text ", bitcast (" + <> ppStatic opts v <> text " to " <> ppLlvmType t + <> char ')' + LMStaticPointer x -> ppLlvmType (pLower $ getVarType x) + <> comma <+> ppStatic opts stat + _ -> ppStatic opts stat +{-# SPECIALIZE pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> SDoc #-} +{-# SPECIALIZE pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +pprStaticArith :: IsLine doc => LlvmCgConfig -> LlvmStatic -> LlvmStatic -> doc -> doc -> SDoc -> doc +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 ppLlvmType ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen + else pprPanic "pprStaticArith" $ + op_name <> text " with different types! s1: " <> ppStatic opts s1 + <> text", s2: " <> ppStatic opts s2 +{-# SPECIALIZE pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc -> SDoc -> SDoc #-} +{-# SPECIALIZE pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> HLine -> HLine -> SDoc -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-------------------------------------------------------------------------------- +-- * Misc functions +-------------------------------------------------------------------------------- + +-- | Blank line. +newLine :: IsDoc doc => doc +newLine = empty +{-# SPECIALIZE newLine :: SDoc #-} +{-# SPECIALIZE newLine :: HDoc #-} + +-- | Exclamation point. +exclamation :: IsLine doc => doc +exclamation = char '!' +{-# SPECIALIZE exclamation :: SDoc #-} +{-# SPECIALIZE exclamation :: HLine #-} diff --git a/GHC/Llvm/Syntax.hs b/GHC/Llvm/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/Llvm/Syntax.hs @@ -0,0 +1,351 @@ +-------------------------------------------------------------------------------- +-- | The LLVM abstract syntax. +-- + +module GHC.Llvm.Syntax where + +import GHC.Prelude + +import GHC.Llvm.MetaData +import GHC.Llvm.Types + +import GHC.Types.Unique + +-- | Block labels +type LlvmBlockId = Unique + +-- | A block of LLVM code. +data LlvmBlock = LlvmBlock { + -- | The code label for this block + blockLabel :: LlvmBlockId, + + -- | A list of LlvmStatement's representing the code for this block. + -- This list must end with a control flow statement. + blockStmts :: [LlvmStatement] + } + +type LlvmBlocks = [LlvmBlock] + +-- | An LLVM Module. This is a top level container in LLVM. +data LlvmModule = LlvmModule { + -- | Comments to include at the start of the module. + modComments :: [LMString], + + -- | LLVM Alias type definitions. + modAliases :: [LlvmAlias], + + -- | LLVM meta data. + modMeta :: [MetaDecl], + + -- | Global variables to include in the module. + modGlobals :: [LMGlobal], + + -- | LLVM Functions used in this module but defined in other modules. + modFwdDecls :: LlvmFunctionDecls, + + -- | LLVM Functions defined in this module. + modFuncs :: LlvmFunctions + } + +-- | An LLVM Function +data LlvmFunction = LlvmFunction { + -- | The signature of this declared function. + funcDecl :: LlvmFunctionDecl, + + -- | The functions arguments + funcArgs :: [LMString], + + -- | The function attributes. + funcAttrs :: [LlvmFuncAttr], + + -- | The section to put the function into, + funcSect :: LMSection, + + -- | Prefix data + funcPrefix :: Maybe LlvmStatic, + + -- | The body of the functions. + funcBody :: LlvmBlocks + } + +type LlvmFunctions = [LlvmFunction] + +type SingleThreaded = Bool + +-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM +-- 3.0). Please see the LLVM documentation for a better description. +data LlvmSyncOrdering + -- | Some partial order of operations exists. + = SyncUnord + -- | A single total order for operations at a single address exists. + | SyncMonotonic + -- | Acquire synchronization operation. + | SyncAcquire + -- | Release synchronization operation. + | SyncRelease + -- | Acquire + Release synchronization operation. + | SyncAcqRel + -- | Full sequential Consistency operation. + | SyncSeqCst + deriving (Show, Eq) + +-- | LLVM atomic operations. Please see the @atomicrmw@ instruction in +-- the LLVM documentation for a complete description. +data LlvmAtomicOp + = LAO_Xchg + | LAO_Add + | LAO_Sub + | LAO_And + | LAO_Nand + | LAO_Or + | LAO_Xor + | LAO_Max + | LAO_Min + | LAO_Umax + | LAO_Umin + deriving (Show, Eq) + +-- | Llvm Statements +data LlvmStatement + {- | + Assign an expression to a variable: + * dest: Variable to assign to + * source: Source expression + -} + = Assignment LlvmVar LlvmExpression + + {- | + Memory fence operation + -} + | Fence Bool LlvmSyncOrdering + + {- | + Always branch to the target label + -} + | Branch LlvmVar + + {- | + Branch to label targetTrue if cond is true otherwise to label targetFalse + * cond: condition that will be tested, must be of type i1 + * targetTrue: label to branch to if cond is true + * targetFalse: label to branch to if cond is false + -} + | BranchIf LlvmVar LlvmVar LlvmVar + + {- | + Comment + Plain comment. + -} + | Comment [LMString] + + {- | + Set a label on this position. + * name: Identifier of this label, unique for this module + -} + | MkLabel LlvmBlockId + + {- | + Store variable value in pointer ptr. If value is of type t then ptr must + be of type t*. + * value: Variable/Constant to store. + * ptr: Location to store the value in + -} + | Store LlvmVar LlvmVar LMAlign [MetaAnnot] + + {- | + Multiway branch + * scrutinee: Variable or constant which must be of integer type that is + determines which arm is chosen. + * def: The default label if there is no match in target. + * target: A list of (value,label) where the value is an integer + constant and label the corresponding label to jump to if the + scrutinee matches the value. + -} + | Switch LlvmVar LlvmVar [(LlvmVar, LlvmVar)] + + {- | + Return a result. + * result: The variable or constant to return + -} + | Return (Maybe LlvmVar) + + {- | + An instruction for the optimizer that the code following is not reachable + -} + | Unreachable + + {- | + Raise an expression to a statement (if don't want result or want to use + Llvm unnamed values. + -} + | Expr LlvmExpression + + {- | + A nop LLVM statement. Useful as its often more efficient to use this + then to wrap LLvmStatement in a Just or []. + -} + | Nop + + deriving (Eq) + + +-- | Llvm Expressions +data LlvmExpression + {- | + Allocate amount * sizeof(tp) bytes on the stack + * tp: LlvmType to reserve room for + * amount: The nr of tp's which must be allocated + -} + = Alloca LlvmType Int + + {- | + Perform the machine operator op on the operands left and right + * op: operator + * left: left operand + * right: right operand + -} + | LlvmOp LlvmMachOp LlvmVar LlvmVar + + {- | + Perform a compare operation on the operands left and right + * op: operator + * left: left operand + * right: right operand + -} + | Compare LlvmCmpOp LlvmVar LlvmVar + + {- | + Extract a scalar element from a vector + * val: The vector + * idx: The index of the scalar within the vector + -} + | Extract LlvmVar LlvmVar + + {- | + Extract a scalar element from a structure + * val: The structure + * idx: The index of the scalar within the structure + Corresponds to "extractvalue" instruction. + -} + | ExtractV LlvmVar Int + + {- | + Insert a scalar element into a vector + * val: The source vector + * elt: The scalar to insert + * index: The index at which to insert the scalar + -} + | Insert LlvmVar LlvmVar LlvmVar + + {- | Shuffle two vectors into a destination vector using given indices + -} + | Shuffle LlvmVar LlvmVar [Int] + + {- | + Allocate amount * sizeof(tp) bytes on the heap + * tp: LlvmType to reserve room for + * amount: The nr of tp's which must be allocated + -} + | Malloc LlvmType Int + + {- | + Load the value at location ptr + -} + | Load LlvmVar LMAlign + + {- | + Atomic load of the value at location ptr + -} + | ALoad LlvmSyncOrdering SingleThreaded LlvmVar + + {- | + Navigate in a structure, selecting elements + * inbound: Is the pointer inbounds? (computed pointer doesn't overflow) + * ptr: Location of the structure + * indexes: A list of indexes to select the correct value. + -} + | GetElemPtr Bool LlvmVar [LlvmVar] + + {- | + Cast the variable from to the to type. This is an abstraction of three + cast operators in Llvm, inttoptr, ptrtoint and bitcast. + * cast: Cast type + * from: Variable to cast + * to: type to cast to + -} + | Cast LlvmCastOp LlvmVar LlvmType + + {- | + Atomic read-modify-write operation + * op: Atomic operation + * addr: Address to modify + * operand: Operand to operation + * ordering: Ordering requirement + -} + | AtomicRMW LlvmAtomicOp LlvmVar LlvmVar LlvmSyncOrdering + + {- | + Compare-and-exchange operation + * addr: Address to modify + * old: Expected value + * new: New value + * suc_ord: Ordering required in success case + * fail_ord: Ordering required in failure case, can be no stronger than + suc_ord + + Result is an @i1@, true if store was successful. + -} + | CmpXChg LlvmVar LlvmVar LlvmVar LlvmSyncOrdering LlvmSyncOrdering + + {- | + Call a function. The result is the value of the expression. + * tailJumps: CallType to signal if the function should be tail called + * fnptrval: An LLVM value containing a pointer to a function to be + invoked. Can be indirect. Should be LMFunction type. + * args: Concrete arguments for the parameters + * attrs: A list of function attributes for the call. Only NoReturn, + NoUnwind, ReadOnly and ReadNone are valid here. + -} + | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr] + + {- | + Call a function as above but potentially taking metadata as arguments. + * tailJumps: CallType to signal if the function should be tail called + * fnptrval: An LLVM value containing a pointer to a function to be + invoked. Can be indirect. Should be LMFunction type. + * args: Arguments that may include metadata. + * attrs: A list of function attributes for the call. Only NoReturn, + NoUnwind, ReadOnly and ReadNone are valid here. + -} + | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr] + + {- | + Merge variables from different basic blocks which are predecessors of this + basic block in a new variable of type tp. + * tp: type of the merged variable, must match the types of the + predecessor variables. + * predecessors: A list of variables and the basic block that they originate + from. + -} + | Phi LlvmType [(LlvmVar,LlvmVar)] + + {- | + Inline assembly expression. Syntax is very similar to the style used by GCC. + * assembly: Actual inline assembly code. + * constraints: Operand constraints. + * return ty: Return type of function. + * vars: Any variables involved in the assembly code. + * sideeffect: Does the expression have side effects not visible from the + constraints list. + * alignstack: Should the stack be conservatively aligned before this + expression is executed. + -} + | Asm LMString LMString LlvmType [LlvmVar] Bool Bool + + {- | + A LLVM expression with metadata attached to it. + -} + | MExpr [MetaAnnot] LlvmExpression + + deriving (Eq) + diff --git a/GHC/Llvm/Types.hs b/GHC/Llvm/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Llvm/Types.hs @@ -0,0 +1,856 @@ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +-- Workaround for #21972. It can be removed once the minimal bootstrapping +-- compiler has a fix for this bug. +#if defined(darwin_HOST_OS) +{-# OPTIONS_GHC -fno-asm-shortcutting #-} +#endif + +-------------------------------------------------------------------------------- +-- | The LLVM Type System. +-- + +module GHC.Llvm.Types where + +import GHC.Prelude + +import Data.Char +import Numeric + +import GHC.Platform +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.Unique + +-- from NCG +import GHC.CmmToAsm.Ppr + +import GHC.Float + +-- ----------------------------------------------------------------------------- +-- * LLVM Basic Types and Variables +-- + +-- | A global mutable variable. Maybe defined or external +data LMGlobal = LMGlobal { + getGlobalVar :: LlvmVar, -- ^ Returns the variable of the 'LMGlobal' + getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal' + } + +-- | A String in LLVM +type LMString = FastString + +-- | A type alias +type LlvmAlias = (LMString, LlvmType) + +-- | Llvm Types +data LlvmType + = LMInt Int -- ^ An integer with a given width in bits. + | LMFloat -- ^ 32 bit floating point + | LMDouble -- ^ 64 bit floating point + | LMFloat80 -- ^ 80 bit (x86 only) floating point + | LMFloat128 -- ^ 128 bit floating point + | LMPointer LlvmType -- ^ A pointer to a 'LlvmType' + | LMArray Int LlvmType -- ^ An array of 'LlvmType' + | LMVector Int LlvmType -- ^ A vector of 'LlvmType' + | LMLabel -- ^ A 'LlvmVar' can represent a label (address) + | LMVoid -- ^ Void type + | LMStruct [LlvmType] -- ^ Packed structure type + | LMStructU [LlvmType] -- ^ Unpacked structure type + | LMAlias LlvmAlias -- ^ A type alias + | LMMetadata -- ^ LLVM Metadata + + -- | Function type, used to create pointers to functions + | LMFunction LlvmFunctionDecl + deriving (Eq) + +instance Outputable LlvmType where + ppr = ppLlvmType + +ppLlvmType :: IsLine doc => LlvmType -> doc +ppLlvmType t = case t of + LMInt size -> char 'i' <> int size + LMFloat -> text "float" + LMDouble -> text "double" + LMFloat80 -> text "x86_fp80" + LMFloat128 -> text "fp128" + LMPointer x -> ppLlvmType x <> char '*' + LMArray nr tp -> char '[' <> int nr <> text " x " <> ppLlvmType tp <> char ']' + LMVector nr tp -> char '<' <> int nr <> text " x " <> ppLlvmType tp <> char '>' + LMLabel -> text "label" + LMVoid -> text "void" + LMStruct tys -> text "<{" <> ppCommaJoin ppLlvmType tys <> text "}>" + LMStructU tys -> text "{" <> ppCommaJoin ppLlvmType tys <> text "}" + LMMetadata -> text "metadata" + LMAlias (s,_) -> char '%' <> ftext s + LMFunction (LlvmFunctionDecl _ _ _ r varg p _) + -> ppLlvmType r <+> lparen <> ppParams varg p <> rparen +{-# SPECIALIZE ppLlvmType :: LlvmType -> SDoc #-} +{-# SPECIALIZE ppLlvmType :: LlvmType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Pretty-print a short name for a scalar or vector type, e.g. @"i16"@ or @"v4f32"@. +ppLlvmTypeShort :: LlvmType -> String +ppLlvmTypeShort t = case t of + LMInt w -> 'i' : show w + LMFloat -> "f32" + LMDouble -> "f64" + LMVector l t -> "v" ++ show l ++ ppLlvmTypeShort t + _ -> pprPanic "ppLlvmTypeShort" (ppLlvmType t) + +ppParams :: IsLine doc => LlvmParameterListType -> [LlvmParameter] -> doc +ppParams varg p + = let varg' = case varg of + VarArgs | null args -> text "..." + | otherwise -> text ", ..." + _otherwise -> text "" + -- by default we don't print param attributes + args = map fst p + in ppCommaJoin ppLlvmType args <> varg' +{-# SPECIALIZE ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc #-} +{-# SPECIALIZE ppParams :: LlvmParameterListType -> [LlvmParameter] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | An LLVM section definition. If Nothing then let LLVM decide the section +type LMSection = Maybe LMString +type LMAlign = Maybe Int + +data LMConst = Global -- ^ Mutable global variable + | Constant -- ^ Constant global variable + | Alias -- ^ Alias of another variable + deriving (Eq) + +-- | LLVM Variables +data LlvmVar + -- | Variables with a global scope. + = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst + -- | Variables local to a function or parameters. + | LMLocalVar Unique LlvmType + -- | Named local variables. Sometimes we need to be able to explicitly name + -- variables (e.g for function arguments). + | LMNLocalVar LMString LlvmType + -- | A constant variable + | LMLitVar LlvmLit + deriving (Eq) + +-- | Llvm Literal Data. +-- +-- These can be used inline in expressions. +data LlvmLit + -- | Refers to an integer constant (i64 42). + = LMIntLit Integer LlvmType + -- | Floating point literal + | LMFloatLit Double LlvmType + -- | Literal NULL, only applicable to pointer types + | LMNullLit LlvmType + -- | Vector literal + | LMVectorLit [LlvmLit] + -- | Undefined value, random bit pattern. Useful for optimisations. + | LMUndefLit LlvmType + deriving (Eq) + +-- | Llvm Static Data. +-- +-- These represent the possible global level variables and constants. +data LlvmStatic + = LMComment LMString -- ^ A comment in a static section + | LMStaticLit LlvmLit -- ^ A static variant of a literal value + | LMUninitType LlvmType -- ^ For uninitialised data + | LMStaticStr LMString LlvmType -- ^ Defines a static 'LMString' + | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array + | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type + | LMStaticStrucU [LlvmStatic] LlvmType -- ^ A static structure type + | LMStaticPointer LlvmVar -- ^ A pointer to other data + + -- static expressions, could split out but leave + -- for moment for ease of use. Not many of them. + + | LMTrunc LlvmStatic LlvmType -- ^ Truncate + | LMBitc LlvmStatic LlvmType -- ^ Pointer to Pointer conversion + | LMPtoI LlvmStatic LlvmType -- ^ Pointer to Integer conversion + | LMAdd LlvmStatic LlvmStatic -- ^ Constant addition operation + | LMSub LlvmStatic LlvmStatic -- ^ Constant subtraction operation + +-- ----------------------------------------------------------------------------- +-- ** Operations on LLVM Basic Types and Variables +-- + +garbageLit :: LlvmType -> Maybe LlvmLit +garbageLit t@(LMInt w) = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t) + -- Use a value that looks like an untagged pointer, so we are more + -- likely to try to enter it +garbageLit t + | isFloat t = Just (LMFloatLit 12345678.9 t) +garbageLit t@(LMPointer _) = Just (LMNullLit t) + -- Using null isn't totally ideal, since some functions may check for null. + -- But producing another value is inconvenient since it needs a cast, + -- and the knowledge for how to format casts is in PpLlvm. +garbageLit _ = Nothing + -- More cases could be added, but this should do for now. + +-- | Return the 'LlvmType' of the 'LlvmVar' +getVarType :: LlvmVar -> LlvmType +getVarType (LMGlobalVar _ y _ _ _ _) = y +getVarType (LMLocalVar _ y ) = y +getVarType (LMNLocalVar _ y ) = y +getVarType (LMLitVar l ) = getLitType l + +-- | Return the 'LlvmType' of a 'LlvmLit' +getLitType :: LlvmLit -> LlvmType +getLitType (LMIntLit _ t) = t +getLitType (LMFloatLit _ t) = t +getLitType (LMVectorLit []) = panic "getLitType" +getLitType (LMVectorLit ls@(l:_)) = LMVector (length ls) (getLitType l) +getLitType (LMNullLit t) = t +getLitType (LMUndefLit t) = t + +-- | Return the 'LlvmType' of the 'LlvmStatic' +getStatType :: LlvmStatic -> LlvmType +getStatType (LMStaticLit l ) = getLitType l +getStatType (LMUninitType t) = t +getStatType (LMStaticStr _ t) = t +getStatType (LMStaticArray _ t) = t +getStatType (LMStaticStruc _ t) = t +getStatType (LMStaticStrucU _ t) = t +getStatType (LMStaticPointer v) = getVarType v +getStatType (LMTrunc _ t) = t +getStatType (LMBitc _ t) = t +getStatType (LMPtoI _ t) = t +getStatType (LMAdd t _) = getStatType t +getStatType (LMSub t _) = getStatType t +getStatType (LMComment _) = error "Can't call getStatType on LMComment!" + +-- | Return the 'LlvmLinkageType' for a 'LlvmVar' +getLink :: LlvmVar -> LlvmLinkageType +getLink (LMGlobalVar _ _ l _ _ _) = l +getLink _ = Internal + +-- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid' +-- cannot be lifted. +pLift :: LlvmType -> LlvmType +pLift LMLabel = error "Labels are unliftable" +pLift LMVoid = error "Voids are unliftable" +pLift LMMetadata = error "Metadatas are unliftable" +pLift x = LMPointer x + +-- | Lift a variable to 'LMPointer' type. +pVarLift :: LlvmVar -> LlvmVar +pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c +pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t) +pVarLift (LMNLocalVar s t ) = LMNLocalVar s (pLift t) +pVarLift (LMLitVar _ ) = error $ "Can't lift a literal type!" + +-- | Remove the pointer indirection of the supplied type. Only 'LMPointer' +-- constructors can be lowered. +pLower :: LlvmType -> LlvmType +pLower (LMPointer x) = x +pLower x = pprPanic "llvmGen(pLower)" + $ ppr x <+> text " is a unlowerable type, need a pointer" + +-- | Lower a variable of 'LMPointer' type. +pVarLower :: LlvmVar -> LlvmVar +pVarLower (LMGlobalVar s t l x a c) = LMGlobalVar s (pLower t) l x a c +pVarLower (LMLocalVar s t ) = LMLocalVar s (pLower t) +pVarLower (LMNLocalVar s t ) = LMNLocalVar s (pLower t) +pVarLower (LMLitVar _ ) = error $ "Can't lower a literal type!" + +-- | Test if the given 'LlvmType' is an integer +isInt :: LlvmType -> Bool +isInt (LMInt _) = True +isInt _ = False + +-- | Test if the given 'LlvmType' is a floating point type +isFloat :: LlvmType -> Bool +isFloat LMFloat = True +isFloat LMDouble = True +isFloat LMFloat80 = True +isFloat LMFloat128 = True +isFloat _ = False + +-- | Test if the given 'LlvmType' is an 'LMPointer' construct +isPointer :: LlvmType -> Bool +isPointer (LMPointer _) = True +isPointer _ = False + +-- | Test if the given 'LlvmType' is an 'LMVector' construct +isVector :: LlvmType -> Bool +isVector (LMVector {}) = True +isVector _ = False + +-- | Test if a 'LlvmVar' is global. +isGlobal :: LlvmVar -> Bool +isGlobal (LMGlobalVar _ _ _ _ _ _) = True +isGlobal _ = False + +-- | Width in bits of an 'LlvmType', returns 0 if not applicable +llvmWidthInBits :: Platform -> LlvmType -> Int +llvmWidthInBits platform = \case + (LMInt n) -> n + (LMFloat) -> 32 + (LMDouble) -> 64 + (LMFloat80) -> 80 + (LMFloat128) -> 128 + -- Could return either a pointer width here or the width of what + -- it points to. We will go with the former for now. + -- PMW: At least judging by the way LLVM outputs constants, pointers + -- should use the former, but arrays the latter. + (LMPointer _) -> llvmWidthInBits platform (llvmWord platform) + (LMArray n t) -> n * llvmWidthInBits platform t + (LMVector n ty) -> n * llvmWidthInBits platform ty + LMLabel -> 0 + LMVoid -> 0 + (LMStruct tys) -> sum $ map (llvmWidthInBits platform) tys + (LMStructU _) -> + -- It's not trivial to calculate the bit width of the unpacked structs, + -- since they will be aligned depending on the specified datalayout ( + -- http://llvm.org/docs/LangRef.html#data-layout ). One way we could support + -- this could be to make the GHC.CmmToLlvm.Ppr.moduleLayout be a data type + -- that exposes the alignment information. However, currently the only place + -- we use unpacked structs is LLVM intrinsics that return them (e.g., + -- llvm.sadd.with.overflow.*), so we don't actually need to compute their + -- bit width. + panic "llvmWidthInBits: not implemented for LMStructU" + (LMFunction _) -> 0 + (LMAlias (_,t)) -> llvmWidthInBits platform t + LMMetadata -> panic "llvmWidthInBits: Meta-data has no runtime representation!" + + +-- ----------------------------------------------------------------------------- +-- ** Shortcut for Common Types +-- + +i128, i64, i32, i16, i8, i1, i8Ptr :: LlvmType +i128 = LMInt 128 +i64 = LMInt 64 +i32 = LMInt 32 +i16 = LMInt 16 +i8 = LMInt 8 +i1 = LMInt 1 +i8Ptr = pLift i8 + +-- | The target architectures word size +llvmWord, llvmWordPtr :: Platform -> LlvmType +llvmWord platform = LMInt (platformWordSizeInBytes platform * 8) +llvmWordPtr platform = pLift (llvmWord platform) + +-- ----------------------------------------------------------------------------- +-- * LLVM Function Types +-- + +-- | An LLVM Function +data LlvmFunctionDecl = LlvmFunctionDecl { + -- | Unique identifier of the function + decName :: LMString, + -- | LinkageType of the function + funcLinkage :: LlvmLinkageType, + -- | The calling convention of the function + funcCc :: LlvmCallConvention, + -- | Type of the returned value + decReturnType :: LlvmType, + -- | Indicates if this function uses varargs + decVarargs :: LlvmParameterListType, + -- | Parameter types and attributes + decParams :: [LlvmParameter], + -- | Function align value, must be power of 2 + funcAlign :: LMAlign + } + deriving (Eq) + +type LlvmFunctionDecls = [LlvmFunctionDecl] + +type LlvmParameter = (LlvmType, [LlvmParamAttr]) + +-- | LLVM Parameter Attributes. +-- +-- Parameter attributes are used to communicate additional information about +-- the result or parameters of a function +data LlvmParamAttr + -- | This indicates to the code generator that the parameter or return value + -- should be zero-extended to a 32-bit value by the caller (for a parameter) + -- or the callee (for a return value). + = ZeroExt + -- | This indicates to the code generator that the parameter or return value + -- should be sign-extended to a 32-bit value by the caller (for a parameter) + -- or the callee (for a return value). + | SignExt + -- | This indicates that this parameter or return value should be treated in + -- a special target-dependent fashion during while emitting code for a + -- function call or return (usually, by putting it in a register as opposed + -- to memory). + | InReg + -- | This indicates that the pointer parameter should really be passed by + -- value to the function. + | ByVal + -- | This indicates that the pointer parameter specifies the address of a + -- structure that is the return value of the function in the source program. + | SRet + -- | This indicates that the pointer does not alias any global or any other + -- parameter. + | NoAlias + -- | This indicates that the callee does not make any copies of the pointer + -- that outlive the callee itself + | NoCapture + -- | This indicates that the pointer parameter can be excised using the + -- trampoline intrinsics. + | Nest + deriving (Eq) + +instance Outputable LlvmParamAttr where + ppr = ppLlvmParamAttr + +ppLlvmParamAttr :: IsLine doc => LlvmParamAttr -> doc +ppLlvmParamAttr ZeroExt = text "zeroext" +ppLlvmParamAttr SignExt = text "signext" +ppLlvmParamAttr InReg = text "inreg" +ppLlvmParamAttr ByVal = text "byval" +ppLlvmParamAttr SRet = text "sret" +ppLlvmParamAttr NoAlias = text "noalias" +ppLlvmParamAttr NoCapture = text "nocapture" +ppLlvmParamAttr Nest = text "nest" +{-# SPECIALIZE ppLlvmParamAttr :: LlvmParamAttr -> SDoc #-} +{-# SPECIALIZE ppLlvmParamAttr :: LlvmParamAttr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Llvm Function Attributes. +-- +-- Function attributes are set to communicate additional information about a +-- function. Function attributes are considered to be part of the function, +-- not of the function type, so functions with different parameter attributes +-- can have the same function type. Functions can have multiple attributes. +-- +-- Descriptions taken from +data LlvmFuncAttr + -- | This attribute indicates that the inliner should attempt to inline this + -- function into callers whenever possible, ignoring any active inlining + -- size threshold for this caller. + = AlwaysInline + -- | This attribute indicates that the source code contained a hint that + -- inlining this function is desirable (such as the \"inline\" keyword in + -- C/C++). It is just a hint; it imposes no requirements on the inliner. + | InlineHint + -- | This attribute indicates that the inliner should never inline this + -- function in any situation. This attribute may not be used together + -- with the alwaysinline attribute. + | NoInline + -- | This attribute suggests that optimization passes and code generator + -- passes make choices that keep the code size of this function low, and + -- otherwise do optimizations specifically to reduce code size. + | OptSize + -- | This function attribute indicates that the function never returns + -- normally. This produces undefined behavior at runtime if the function + -- ever does dynamically return. + | NoReturn + -- | This function attribute indicates that the function never returns with + -- an unwind or exceptional control flow. If the function does unwind, its + -- runtime behavior is undefined. + | NoUnwind + -- | This attribute indicates that the function computes its result (or + -- decides to unwind an exception) based strictly on its arguments, without + -- dereferencing any pointer arguments or otherwise accessing any mutable + -- state (e.g. memory, control registers, etc) visible to caller functions. + -- It does not write through any pointer arguments (including byval + -- arguments) and never changes any state visible to callers. This means + -- that it cannot unwind exceptions by calling the C++ exception throwing + -- methods, but could use the unwind instruction. + | ReadNone + -- | This attribute indicates that the function does not write through any + -- pointer arguments (including byval arguments) or otherwise modify any + -- state (e.g. memory, control registers, etc) visible to caller functions. + -- It may dereference pointer arguments and read state that may be set in + -- the caller. A readonly function always returns the same value (or unwinds + -- an exception identically) when called with the same set of arguments and + -- global state. It cannot unwind an exception by calling the C++ exception + -- throwing methods, but may use the unwind instruction. + | ReadOnly + -- | This attribute indicates that the function should emit a stack smashing + -- protector. It is in the form of a \"canary\"—a random value placed on the + -- stack before the local variables that's checked upon return from the + -- function to see if it has been overwritten. A heuristic is used to + -- determine if a function needs stack protectors or not. + -- + -- If a function that has an ssp attribute is inlined into a function that + -- doesn't have an ssp attribute, then the resulting function will have an + -- ssp attribute. + | Ssp + -- | This attribute indicates that the function should always emit a stack + -- smashing protector. This overrides the ssp function attribute. + -- + -- If a function that has an sspreq attribute is inlined into a function + -- that doesn't have an sspreq attribute or which has an ssp attribute, + -- then the resulting function will have an sspreq attribute. + | SspReq + -- | This attribute indicates that the code generator should not use a red + -- zone, even if the target-specific ABI normally permits it. + | NoRedZone + -- | This attributes disables implicit floating point instructions. + | NoImplicitFloat + -- | This attribute disables prologue / epilogue emission for the function. + -- This can have very system-specific consequences. + | Naked + deriving (Eq) + +instance Outputable LlvmFuncAttr where + ppr = ppLlvmFuncAttr + +ppLlvmFuncAttr :: IsLine doc => LlvmFuncAttr -> doc +ppLlvmFuncAttr AlwaysInline = text "alwaysinline" +ppLlvmFuncAttr InlineHint = text "inlinehint" +ppLlvmFuncAttr NoInline = text "noinline" +ppLlvmFuncAttr OptSize = text "optsize" +ppLlvmFuncAttr NoReturn = text "noreturn" +ppLlvmFuncAttr NoUnwind = text "nounwind" +ppLlvmFuncAttr ReadNone = text "readnone" +ppLlvmFuncAttr ReadOnly = text "readonly" +ppLlvmFuncAttr Ssp = text "ssp" +ppLlvmFuncAttr SspReq = text "ssqreq" +ppLlvmFuncAttr NoRedZone = text "noredzone" +ppLlvmFuncAttr NoImplicitFloat = text "noimplicitfloat" +ppLlvmFuncAttr Naked = text "naked" +{-# SPECIALIZE ppLlvmFuncAttr :: LlvmFuncAttr -> SDoc #-} +{-# SPECIALIZE ppLlvmFuncAttr :: LlvmFuncAttr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Different types to call a function. +data LlvmCallType + -- | Normal call, allocate a new stack frame. + = StdCall + -- | Tail call, perform the call in the current stack frame. + | TailCall + deriving (Eq,Show) + +-- | Different calling conventions a function can use. +data LlvmCallConvention + -- | The C calling convention. + -- This calling convention (the default if no other calling convention is + -- specified) matches the target C calling conventions. This calling + -- convention supports varargs function calls and tolerates some mismatch in + -- the declared prototype and implemented declaration of the function (as + -- does normal C). + = CC_Ccc + -- | This calling convention attempts to make calls as fast as possible + -- (e.g. by passing things in registers). This calling convention allows + -- the target to use whatever tricks it wants to produce fast code for the + -- target, without having to conform to an externally specified ABI + -- (Application Binary Interface). Implementations of this convention should + -- allow arbitrary tail call optimization to be supported. This calling + -- convention does not support varargs and requires the prototype of al + -- callees to exactly match the prototype of the function definition. + | CC_Fastcc + -- | This calling convention attempts to make code in the caller as efficient + -- as possible under the assumption that the call is not commonly executed. + -- As such, these calls often preserve all registers so that the call does + -- not break any live ranges in the caller side. This calling convention + -- does not support varargs and requires the prototype of all callees to + -- exactly match the prototype of the function definition. + | CC_Coldcc + -- | The GHC-specific 'registerised' calling convention. + | CC_Ghc + -- | Any calling convention may be specified by number, allowing + -- target-specific calling conventions to be used. Target specific calling + -- conventions start at 64. + | CC_Ncc Int + -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it + -- rather than just using CC_Ncc. + | CC_X86_Stdcc + deriving (Eq) + +instance Outputable LlvmCallConvention where + ppr = ppLlvmCallConvention + +ppLlvmCallConvention :: IsLine doc => LlvmCallConvention -> doc +ppLlvmCallConvention CC_Ccc = text "ccc" +ppLlvmCallConvention CC_Fastcc = text "fastcc" +ppLlvmCallConvention CC_Coldcc = text "coldcc" +ppLlvmCallConvention CC_Ghc = text "ghccc" +ppLlvmCallConvention (CC_Ncc i) = text "cc " <> int i +ppLlvmCallConvention CC_X86_Stdcc = text "x86_stdcallcc" +{-# SPECIALIZE ppLlvmCallConvention :: LlvmCallConvention -> SDoc #-} +{-# SPECIALIZE ppLlvmCallConvention :: LlvmCallConvention -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Functions can have a fixed amount of parameters, or a variable amount. +data LlvmParameterListType + -- Fixed amount of arguments. + = FixedArgs + -- Variable amount of arguments. + | VarArgs + deriving (Eq,Show) + + +-- | Linkage type of a symbol. +-- +-- The description of the constructors is copied from the Llvm Assembly Language +-- Reference Manual , because +-- they correspond to the Llvm linkage types. +data LlvmLinkageType + -- | Global values with internal linkage are only directly accessible by + -- objects in the current module. In particular, linking code into a module + -- with an internal global value may cause the internal to be renamed as + -- necessary to avoid collisions. Because the symbol is internal to the + -- module, all references can be updated. This corresponds to the notion + -- of the @static@ keyword in C. + = Internal + -- | Globals with @linkonce@ linkage are merged with other globals of the + -- same name when linkage occurs. This is typically used to implement + -- inline functions, templates, or other code which must be generated + -- in each translation unit that uses it. Unreferenced linkonce globals are + -- allowed to be discarded. + | LinkOnce + -- | @weak@ linkage is exactly the same as linkonce linkage, except that + -- unreferenced weak globals may not be discarded. This is used for globals + -- that may be emitted in multiple translation units, but that are not + -- guaranteed to be emitted into every translation unit that uses them. One + -- example of this are common globals in C, such as @int X;@ at global + -- scope. + | Weak + -- | @appending@ linkage may only be applied to global variables of pointer + -- to array type. When two global variables with appending linkage are + -- linked together, the two global arrays are appended together. This is + -- the Llvm, typesafe, equivalent of having the system linker append + -- together @sections@ with identical names when .o files are linked. + | Appending + -- | The semantics of this linkage follow the ELF model: the symbol is weak + -- until linked, if not linked, the symbol becomes null instead of being an + -- undefined reference. + | ExternWeak + -- | The symbol participates in linkage and can be used to resolve external + -- symbol references. + | ExternallyVisible + -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM + -- assembly. + | External + -- | Symbol is private to the module and should not appear in the symbol table + | Private + deriving (Eq) + +instance Outputable LlvmLinkageType where + ppr = ppLlvmLinkageType + +ppLlvmLinkageType :: IsLine doc => LlvmLinkageType -> doc +ppLlvmLinkageType Internal = text "internal" +ppLlvmLinkageType LinkOnce = text "linkonce" +ppLlvmLinkageType Weak = text "weak" +ppLlvmLinkageType Appending = text "appending" +ppLlvmLinkageType ExternWeak = text "extern_weak" +-- ExternallyVisible does not have a textual representation, it is +-- the linkage type a function resolves to if no other is specified +-- in Llvm. +ppLlvmLinkageType ExternallyVisible = empty +ppLlvmLinkageType External = text "external" +ppLlvmLinkageType Private = text "private" +{-# SPECIALIZE ppLlvmLinkageType :: LlvmLinkageType -> SDoc #-} +{-# SPECIALIZE ppLlvmLinkageType :: LlvmLinkageType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- ----------------------------------------------------------------------------- +-- * LLVM Operations +-- + +-- | Llvm binary operators machine operations. +data LlvmMachOp + = LM_MO_Add -- ^ add two integer, floating point or vector values. + | LM_MO_Sub -- ^ subtract two ... + | LM_MO_Mul -- ^ multiply .. + | LM_MO_UDiv -- ^ unsigned integer or vector division. + | LM_MO_SDiv -- ^ signed integer .. + | LM_MO_URem -- ^ unsigned integer or vector remainder (mod) + | LM_MO_SRem -- ^ signed ... + + | LM_MO_FAdd -- ^ add two floating point or vector values. + | LM_MO_FSub -- ^ subtract two ... + | LM_MO_FMul -- ^ multiply ... + | LM_MO_FDiv -- ^ divide ... + | LM_MO_FRem -- ^ remainder ... + + -- | Left shift + | LM_MO_Shl + -- | Logical shift right + -- Shift right, filling with zero + | LM_MO_LShr + -- | Arithmetic shift right + -- The most significant bits of the result will be equal to the sign bit of + -- the left operand. + | LM_MO_AShr + + | LM_MO_And -- ^ AND bitwise logical operation. + | LM_MO_Or -- ^ OR bitwise logical operation. + | LM_MO_Xor -- ^ XOR bitwise logical operation. + deriving (Eq) + +instance Outputable LlvmMachOp where + ppr = ppLlvmMachOp + +ppLlvmMachOp :: IsLine doc => LlvmMachOp -> doc +ppLlvmMachOp LM_MO_Add = text "add" +ppLlvmMachOp LM_MO_Sub = text "sub" +ppLlvmMachOp LM_MO_Mul = text "mul" +ppLlvmMachOp LM_MO_UDiv = text "udiv" +ppLlvmMachOp LM_MO_SDiv = text "sdiv" +ppLlvmMachOp LM_MO_URem = text "urem" +ppLlvmMachOp LM_MO_SRem = text "srem" +ppLlvmMachOp LM_MO_FAdd = text "fadd" +ppLlvmMachOp LM_MO_FSub = text "fsub" +ppLlvmMachOp LM_MO_FMul = text "fmul" +ppLlvmMachOp LM_MO_FDiv = text "fdiv" +ppLlvmMachOp LM_MO_FRem = text "frem" +ppLlvmMachOp LM_MO_Shl = text "shl" +ppLlvmMachOp LM_MO_LShr = text "lshr" +ppLlvmMachOp LM_MO_AShr = text "ashr" +ppLlvmMachOp LM_MO_And = text "and" +ppLlvmMachOp LM_MO_Or = text "or" +ppLlvmMachOp LM_MO_Xor = text "xor" +{-# SPECIALIZE ppLlvmMachOp :: LlvmMachOp -> SDoc #-} +{-# SPECIALIZE ppLlvmMachOp :: LlvmMachOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Llvm compare operations. +data LlvmCmpOp + = LM_CMP_Eq -- ^ Equal (Signed and Unsigned) + | LM_CMP_Ne -- ^ Not equal (Signed and Unsigned) + | LM_CMP_Ugt -- ^ Unsigned greater than + | LM_CMP_Uge -- ^ Unsigned greater than or equal + | LM_CMP_Ult -- ^ Unsigned less than + | LM_CMP_Ule -- ^ Unsigned less than or equal + | LM_CMP_Sgt -- ^ Signed greater than + | LM_CMP_Sge -- ^ Signed greater than or equal + | LM_CMP_Slt -- ^ Signed less than + | LM_CMP_Sle -- ^ Signed less than or equal + + -- Float comparisons. GHC uses a mix of ordered and unordered float + -- comparisons. + | LM_CMP_Feq -- ^ Float equal + | LM_CMP_Fne -- ^ Float not equal + | LM_CMP_Fgt -- ^ Float greater than + | LM_CMP_Fge -- ^ Float greater than or equal + | LM_CMP_Flt -- ^ Float less than + | LM_CMP_Fle -- ^ Float less than or equal + deriving (Eq) + +instance Outputable LlvmCmpOp where + ppr = ppLlvmCmpOp + +ppLlvmCmpOp :: IsLine doc => LlvmCmpOp -> doc +ppLlvmCmpOp LM_CMP_Eq = text "eq" +ppLlvmCmpOp LM_CMP_Ne = text "ne" +ppLlvmCmpOp LM_CMP_Ugt = text "ugt" +ppLlvmCmpOp LM_CMP_Uge = text "uge" +ppLlvmCmpOp LM_CMP_Ult = text "ult" +ppLlvmCmpOp LM_CMP_Ule = text "ule" +ppLlvmCmpOp LM_CMP_Sgt = text "sgt" +ppLlvmCmpOp LM_CMP_Sge = text "sge" +ppLlvmCmpOp LM_CMP_Slt = text "slt" +ppLlvmCmpOp LM_CMP_Sle = text "sle" +ppLlvmCmpOp LM_CMP_Feq = text "oeq" +ppLlvmCmpOp LM_CMP_Fne = text "une" +ppLlvmCmpOp LM_CMP_Fgt = text "ogt" +ppLlvmCmpOp LM_CMP_Fge = text "oge" +ppLlvmCmpOp LM_CMP_Flt = text "olt" +ppLlvmCmpOp LM_CMP_Fle = text "ole" +{-# SPECIALIZE ppLlvmCmpOp :: LlvmCmpOp -> SDoc #-} +{-# SPECIALIZE ppLlvmCmpOp :: LlvmCmpOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- | Llvm cast operations. +data LlvmCastOp + = LM_Trunc -- ^ Integer truncate + | LM_Zext -- ^ Integer extend (zero fill) + | LM_Sext -- ^ Integer extend (sign fill) + | LM_Fptrunc -- ^ Float truncate + | LM_Fpext -- ^ Float extend + | LM_Fptoui -- ^ Float to unsigned Integer + | LM_Fptosi -- ^ Float to signed Integer + | LM_Uitofp -- ^ Unsigned Integer to Float + | LM_Sitofp -- ^ Signed Int to Float + | LM_Ptrtoint -- ^ Pointer to Integer + | LM_Inttoptr -- ^ Integer to Pointer + | LM_Bitcast -- ^ Cast between types where no bit manipulation is needed + deriving (Eq) + +instance Outputable LlvmCastOp where + ppr = ppLlvmCastOp + +ppLlvmCastOp :: IsLine doc => LlvmCastOp -> doc +ppLlvmCastOp LM_Trunc = text "trunc" +ppLlvmCastOp LM_Zext = text "zext" +ppLlvmCastOp LM_Sext = text "sext" +ppLlvmCastOp LM_Fptrunc = text "fptrunc" +ppLlvmCastOp LM_Fpext = text "fpext" +ppLlvmCastOp LM_Fptoui = text "fptoui" +ppLlvmCastOp LM_Fptosi = text "fptosi" +ppLlvmCastOp LM_Uitofp = text "uitofp" +ppLlvmCastOp LM_Sitofp = text "sitofp" +ppLlvmCastOp LM_Ptrtoint = text "ptrtoint" +ppLlvmCastOp LM_Inttoptr = text "inttoptr" +ppLlvmCastOp LM_Bitcast = text "bitcast" +{-# SPECIALIZE ppLlvmCastOp :: LlvmCastOp -> SDoc #-} +{-# SPECIALIZE ppLlvmCastOp :: LlvmCastOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- ----------------------------------------------------------------------------- +-- * Floating point conversion +-- + +-- | Convert a Haskell Double to an LLVM hex encoded floating point form. In +-- Llvm float literals can be printed in a big-endian hexadecimal format, +-- regardless of underlying architecture. +-- +-- See Note [LLVM Float Types]. +ppDouble :: IsLine doc => Platform -> Double -> doc +ppDouble platform d + = let bs = doubleToBytes d + hex d' = case showHex d' "" of + [] -> error "ppDouble: too few hex digits for float" + [x] -> ['0',x] + [x,y] -> [x,y] + _ -> error "ppDouble: too many hex digits for float" + + fixEndian = case platformByteOrder platform of + BigEndian -> id + LittleEndian -> reverse + str = map toUpper $ concat $ fixEndian $ map hex bs + in text "0x" <> text str +{-# SPECIALIZE ppDouble :: Platform -> Double -> SDoc #-} +{-# SPECIALIZE ppDouble :: Platform -> Double -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- Note [LLVM Float Types] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- We use 'ppDouble' for both printing Float and Double floating point types. This is +-- as LLVM expects all floating point constants (single & double) to be in IEEE +-- 754 Double precision format. However, for single precision numbers (Float) +-- they should be *representable* in IEEE 754 Single precision format. So the +-- easiest way to do this is to narrow and widen again. +-- (i.e., Double -> Float -> Double). We must be careful doing this that GHC +-- doesn't optimize that away. + +-- Note [narrowFp & widenFp] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- NOTE: we use float2Double & co directly as GHC likes to optimize away +-- successive calls of 'realToFrac', defeating the narrowing. (Bug #7600). +-- 'realToFrac' has inconsistent behaviour with optimisation as well that can +-- also cause issues, these methods don't. + +narrowFp :: Double -> Float +{-# NOINLINE narrowFp #-} +narrowFp = double2Float + +widenFp :: Float -> Double +{-# NOINLINE widenFp #-} +widenFp = float2Double + +ppFloat :: IsLine doc => Platform -> Float -> doc +ppFloat platform = ppDouble platform . widenFp +{-# SPECIALIZE ppFloat :: Platform -> Float -> SDoc #-} +{-# SPECIALIZE ppFloat :: Platform -> Float -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-------------------------------------------------------------------------------- +-- * Misc functions +-------------------------------------------------------------------------------- + +ppCommaJoin :: IsLine doc => (a -> doc) -> [a] -> doc +ppCommaJoin ppr strs = hsep $ punctuate comma (map ppr strs) +{-# SPECIALIZE ppCommaJoin :: (a -> SDoc) -> [a] -> SDoc #-} +{-# SPECIALIZE ppCommaJoin :: (a -> HLine) -> [a] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +ppSpaceJoin :: IsLine doc => (a -> doc) -> [a] -> doc +ppSpaceJoin ppr strs = hsep (map ppr strs) +{-# SPECIALIZE ppSpaceJoin :: (a -> SDoc) -> [a] -> SDoc #-} +{-# SPECIALIZE ppSpaceJoin :: (a -> HLine) -> [a] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable diff --git a/GHC/Parser.hs b/GHC/Parser.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser.hs @@ -0,0 +1,14403 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS -XMagicHash -XBangPatterns -XTypeSynonymInstances -XFlexibleInstances -cpp #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# OPTIONS_GHC -XPartialTypeSignatures #-} +#endif +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} + +-- | This module provides the generated Happy parser for Haskell. It exports +-- a number of parsers which may be used in any library that uses the GHC API. +-- A common usage pattern is to initialize the parser state with a given string +-- and then parse that string: +-- +-- @ +-- runParser :: ParserOpts -> String -> P a -> ParseResult a +-- runParser opts str parser = unP parser parseState +-- where +-- filename = "\" +-- location = mkRealSrcLoc (mkFastString filename) 1 1 +-- buffer = stringToStringBuffer str +-- parseState = initParserState opts buffer location +-- @ +module GHC.Parser + ( parseModule, parseSignature, parseImport, parseStatement, parseBackpack + , parseDeclaration, parseExpression, parsePattern + , parseTypeSignature + , parseStmt, parseIdentifier + , parseType, parseHeader + , parseModuleNoHaddock + ) +where + +-- base +import Control.Monad ( unless, liftM, when, (<=<) ) +import GHC.Exts +import Data.Maybe ( maybeToList ) +import Data.List.NonEmpty ( NonEmpty(..), head, init, last, tail ) +import qualified Data.List.NonEmpty as NE +import qualified Prelude -- for happy-generated code + +import GHC.Hs + +import GHC.Driver.Backpack.Syntax + +import GHC.Unit.Info +import GHC.Unit.Module +import GHC.Unit.Module.Warnings + +import GHC.Data.OrdList +import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula, mkTrue ) +import GHC.Data.FastString +import GHC.Data.Maybe ( orElse ) + +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) +import GHC.Utils.Panic +import GHC.Prelude hiding ( head, init, last, tail ) +import qualified GHC.Data.Strict as Strict + +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOccFS) +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Error ( GhcHint(..) ) +import GHC.Types.Fixity +import GHC.Types.ForeignCall +import GHC.Types.SourceFile +import GHC.Types.SourceText +import GHC.Types.PkgQual + +import GHC.Core.Type ( Specificity(..) ) +import GHC.Core.Class ( FunDep ) +import GHC.Core.DataCon ( DataCon, dataConName ) + +import GHC.Parser.PostProcess +import GHC.Parser.PostProcess.Haddock +import GHC.Parser.Lexer +import GHC.Parser.HaddockLex +import GHC.Parser.Annotation +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () + +import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon, + tupleTyCon, tupleDataCon, nilDataCon, + unboxedUnitTyCon, unboxedUnitDataCon, + listTyCon_RDR, consDataCon_RDR, + unrestrictedFunTyCon ) + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import qualified Data.Semigroup as Semi +import qualified Data.Array as Happy_Data_Array +import qualified Data.Bits as Bits +import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) +import Control.Monad (ap) + +-- parser produced by Happy Version 1.20.1.1 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +newtype HappyWrap16 = HappyWrap16 (LocatedN RdrName) +happyIn16 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap16 x) +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> HappyWrap16 +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +newtype HappyWrap17 = HappyWrap17 ([LHsUnit PackageName]) +happyIn17 :: ([LHsUnit PackageName]) -> (HappyAbsSyn ) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap17 x) +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> HappyWrap17 +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +newtype HappyWrap18 = HappyWrap18 (OrdList (LHsUnit PackageName)) +happyIn18 :: (OrdList (LHsUnit PackageName)) -> (HappyAbsSyn ) +happyIn18 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap18 x) +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> HappyWrap18 +happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut18 #-} +newtype HappyWrap19 = HappyWrap19 (LHsUnit PackageName) +happyIn19 :: (LHsUnit PackageName) -> (HappyAbsSyn ) +happyIn19 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap19 x) +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> HappyWrap19 +happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut19 #-} +newtype HappyWrap20 = HappyWrap20 (LHsUnitId PackageName) +happyIn20 :: (LHsUnitId PackageName) -> (HappyAbsSyn ) +happyIn20 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap20 x) +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> HappyWrap20 +happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut20 #-} +newtype HappyWrap21 = HappyWrap21 (OrdList (LHsModuleSubst PackageName)) +happyIn21 :: (OrdList (LHsModuleSubst PackageName)) -> (HappyAbsSyn ) +happyIn21 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap21 x) +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> HappyWrap21 +happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut21 #-} +newtype HappyWrap22 = HappyWrap22 (LHsModuleSubst PackageName) +happyIn22 :: (LHsModuleSubst PackageName) -> (HappyAbsSyn ) +happyIn22 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap22 x) +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> HappyWrap22 +happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut22 #-} +newtype HappyWrap23 = HappyWrap23 (LHsModuleId PackageName) +happyIn23 :: (LHsModuleId PackageName) -> (HappyAbsSyn ) +happyIn23 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap23 x) +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn ) -> HappyWrap23 +happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut23 #-} +newtype HappyWrap24 = HappyWrap24 (Located PackageName) +happyIn24 :: (Located PackageName) -> (HappyAbsSyn ) +happyIn24 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap24 x) +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn ) -> HappyWrap24 +happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut24 #-} +newtype HappyWrap25 = HappyWrap25 (Located FastString) +happyIn25 :: (Located FastString) -> (HappyAbsSyn ) +happyIn25 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap25 x) +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn ) -> HappyWrap25 +happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut25 #-} +newtype HappyWrap26 = HappyWrap26 (()) +happyIn26 :: (()) -> (HappyAbsSyn ) +happyIn26 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap26 x) +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn ) -> HappyWrap26 +happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut26 #-} +newtype HappyWrap27 = HappyWrap27 (Located FastString) +happyIn27 :: (Located FastString) -> (HappyAbsSyn ) +happyIn27 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap27 x) +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn ) -> HappyWrap27 +happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut27 #-} +newtype HappyWrap28 = HappyWrap28 (Maybe [LRenaming]) +happyIn28 :: (Maybe [LRenaming]) -> (HappyAbsSyn ) +happyIn28 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap28 x) +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn ) -> HappyWrap28 +happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut28 #-} +newtype HappyWrap29 = HappyWrap29 (OrdList LRenaming) +happyIn29 :: (OrdList LRenaming) -> (HappyAbsSyn ) +happyIn29 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap29 x) +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn ) -> HappyWrap29 +happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut29 #-} +newtype HappyWrap30 = HappyWrap30 (LRenaming) +happyIn30 :: (LRenaming) -> (HappyAbsSyn ) +happyIn30 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap30 x) +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn ) -> HappyWrap30 +happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut30 #-} +newtype HappyWrap31 = HappyWrap31 (OrdList (LHsUnitDecl PackageName)) +happyIn31 :: (OrdList (LHsUnitDecl PackageName)) -> (HappyAbsSyn ) +happyIn31 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap31 x) +{-# INLINE happyIn31 #-} +happyOut31 :: (HappyAbsSyn ) -> HappyWrap31 +happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut31 #-} +newtype HappyWrap32 = HappyWrap32 (OrdList (LHsUnitDecl PackageName)) +happyIn32 :: (OrdList (LHsUnitDecl PackageName)) -> (HappyAbsSyn ) +happyIn32 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap32 x) +{-# INLINE happyIn32 #-} +happyOut32 :: (HappyAbsSyn ) -> HappyWrap32 +happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut32 #-} +newtype HappyWrap33 = HappyWrap33 (LHsUnitDecl PackageName) +happyIn33 :: (LHsUnitDecl PackageName) -> (HappyAbsSyn ) +happyIn33 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap33 x) +{-# INLINE happyIn33 #-} +happyOut33 :: (HappyAbsSyn ) -> HappyWrap33 +happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut33 #-} +newtype HappyWrap34 = HappyWrap34 (Located (HsModule GhcPs)) +happyIn34 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) +happyIn34 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap34 x) +{-# INLINE happyIn34 #-} +happyOut34 :: (HappyAbsSyn ) -> HappyWrap34 +happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut34 #-} +newtype HappyWrap35 = HappyWrap35 (Located (HsModule GhcPs)) +happyIn35 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) +happyIn35 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap35 x) +{-# INLINE happyIn35 #-} +happyOut35 :: (HappyAbsSyn ) -> HappyWrap35 +happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut35 #-} +newtype HappyWrap36 = HappyWrap36 (()) +happyIn36 :: (()) -> (HappyAbsSyn ) +happyIn36 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap36 x) +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn ) -> HappyWrap36 +happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut36 #-} +newtype HappyWrap37 = HappyWrap37 (()) +happyIn37 :: (()) -> (HappyAbsSyn ) +happyIn37 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap37 x) +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn ) -> HappyWrap37 +happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut37 #-} +newtype HappyWrap38 = HappyWrap38 (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,EpLayout)) +happyIn38 :: (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,EpLayout)) -> (HappyAbsSyn ) +happyIn38 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap38 x) +{-# INLINE happyIn38 #-} +happyOut38 :: (HappyAbsSyn ) -> HappyWrap38 +happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut38 #-} +newtype HappyWrap39 = HappyWrap39 (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,EpLayout)) +happyIn39 :: (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,EpLayout)) -> (HappyAbsSyn ) +happyIn39 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap39 x) +{-# INLINE happyIn39 #-} +happyOut39 :: (HappyAbsSyn ) -> HappyWrap39 +happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut39 #-} +newtype HappyWrap40 = HappyWrap40 (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) +happyIn40 :: (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) -> (HappyAbsSyn ) +happyIn40 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap40 x) +{-# INLINE happyIn40 #-} +happyOut40 :: (HappyAbsSyn ) -> HappyWrap40 +happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut40 #-} +newtype HappyWrap41 = HappyWrap41 (([LImportDecl GhcPs], [LHsDecl GhcPs])) +happyIn41 :: (([LImportDecl GhcPs], [LHsDecl GhcPs])) -> (HappyAbsSyn ) +happyIn41 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap41 x) +{-# INLINE happyIn41 #-} +happyOut41 :: (HappyAbsSyn ) -> HappyWrap41 +happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut41 #-} +newtype HappyWrap42 = HappyWrap42 (Located (HsModule GhcPs)) +happyIn42 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) +happyIn42 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap42 x) +{-# INLINE happyIn42 #-} +happyOut42 :: (HappyAbsSyn ) -> HappyWrap42 +happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut42 #-} +newtype HappyWrap43 = HappyWrap43 ([LImportDecl GhcPs]) +happyIn43 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn43 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap43 x) +{-# INLINE happyIn43 #-} +happyOut43 :: (HappyAbsSyn ) -> HappyWrap43 +happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut43 #-} +newtype HappyWrap44 = HappyWrap44 ([LImportDecl GhcPs]) +happyIn44 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn44 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap44 x) +{-# INLINE happyIn44 #-} +happyOut44 :: (HappyAbsSyn ) -> HappyWrap44 +happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut44 #-} +newtype HappyWrap45 = HappyWrap45 ([LImportDecl GhcPs]) +happyIn45 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn45 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap45 x) +{-# INLINE happyIn45 #-} +happyOut45 :: (HappyAbsSyn ) -> HappyWrap45 +happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut45 #-} +newtype HappyWrap46 = HappyWrap46 ([LImportDecl GhcPs]) +happyIn46 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn46 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap46 x) +{-# INLINE happyIn46 #-} +happyOut46 :: (HappyAbsSyn ) -> HappyWrap46 +happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut46 #-} +newtype HappyWrap47 = HappyWrap47 ((Maybe (LocatedLI [LIE GhcPs]))) +happyIn47 :: ((Maybe (LocatedLI [LIE GhcPs]))) -> (HappyAbsSyn ) +happyIn47 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap47 x) +{-# INLINE happyIn47 #-} +happyOut47 :: (HappyAbsSyn ) -> HappyWrap47 +happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut47 #-} +newtype HappyWrap48 = HappyWrap48 (([EpToken ","], OrdList (LIE GhcPs))) +happyIn48 :: (([EpToken ","], OrdList (LIE GhcPs))) -> (HappyAbsSyn ) +happyIn48 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap48 x) +{-# INLINE happyIn48 #-} +happyOut48 :: (HappyAbsSyn ) -> HappyWrap48 +happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut48 #-} +newtype HappyWrap49 = HappyWrap49 (OrdList (LIE GhcPs)) +happyIn49 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) +happyIn49 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap49 x) +{-# INLINE happyIn49 #-} +happyOut49 :: (HappyAbsSyn ) -> HappyWrap49 +happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut49 #-} +newtype HappyWrap50 = HappyWrap50 (OrdList (LIE GhcPs)) +happyIn50 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) +happyIn50 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap50 x) +{-# INLINE happyIn50 #-} +happyOut50 :: (HappyAbsSyn ) -> HappyWrap50 +happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut50 #-} +newtype HappyWrap51 = HappyWrap51 (LIE GhcPs) +happyIn51 :: (LIE GhcPs) -> (HappyAbsSyn ) +happyIn51 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap51 x) +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn ) -> HappyWrap51 +happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut51 #-} +newtype HappyWrap52 = HappyWrap52 (Located ((EpToken "(", EpToken ")"), ImpExpSubSpec)) +happyIn52 :: (Located ((EpToken "(", EpToken ")"), ImpExpSubSpec)) -> (HappyAbsSyn ) +happyIn52 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap52 x) +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn ) -> HappyWrap52 +happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut52 #-} +newtype HappyWrap53 = HappyWrap53 ([LocatedA ImpExpQcSpec]) +happyIn53 :: ([LocatedA ImpExpQcSpec]) -> (HappyAbsSyn ) +happyIn53 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap53 x) +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn ) -> HappyWrap53 +happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut53 #-} +newtype HappyWrap54 = HappyWrap54 ([LocatedA ImpExpQcSpec]) +happyIn54 :: ([LocatedA ImpExpQcSpec]) -> (HappyAbsSyn ) +happyIn54 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap54 x) +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn ) -> HappyWrap54 +happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut54 #-} +newtype HappyWrap55 = HappyWrap55 (LocatedA ImpExpQcSpec) +happyIn55 :: (LocatedA ImpExpQcSpec) -> (HappyAbsSyn ) +happyIn55 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap55 x) +{-# INLINE happyIn55 #-} +happyOut55 :: (HappyAbsSyn ) -> HappyWrap55 +happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut55 #-} +newtype HappyWrap56 = HappyWrap56 (LocatedA ImpExpQcSpec) +happyIn56 :: (LocatedA ImpExpQcSpec) -> (HappyAbsSyn ) +happyIn56 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap56 x) +{-# INLINE happyIn56 #-} +happyOut56 :: (HappyAbsSyn ) -> HappyWrap56 +happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut56 #-} +newtype HappyWrap57 = HappyWrap57 (LocatedN RdrName) +happyIn57 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn57 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap57 x) +{-# INLINE happyIn57 #-} +happyOut57 :: (HappyAbsSyn ) -> HappyWrap57 +happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut57 #-} +newtype HappyWrap58 = HappyWrap58 (Located [TrailingAnn]) +happyIn58 :: (Located [TrailingAnn]) -> (HappyAbsSyn ) +happyIn58 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap58 x) +{-# INLINE happyIn58 #-} +happyOut58 :: (HappyAbsSyn ) -> HappyWrap58 +happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut58 #-} +newtype HappyWrap59 = HappyWrap59 ([TrailingAnn]) +happyIn59 :: ([TrailingAnn]) -> (HappyAbsSyn ) +happyIn59 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap59 x) +{-# INLINE happyIn59 #-} +happyOut59 :: (HappyAbsSyn ) -> HappyWrap59 +happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut59 #-} +newtype HappyWrap60 = HappyWrap60 ([LImportDecl GhcPs]) +happyIn60 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn60 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap60 x) +{-# INLINE happyIn60 #-} +happyOut60 :: (HappyAbsSyn ) -> HappyWrap60 +happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut60 #-} +newtype HappyWrap61 = HappyWrap61 ([LImportDecl GhcPs]) +happyIn61 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn61 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap61 x) +{-# INLINE happyIn61 #-} +happyOut61 :: (HappyAbsSyn ) -> HappyWrap61 +happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut61 #-} +newtype HappyWrap62 = HappyWrap62 (LImportDecl GhcPs) +happyIn62 :: (LImportDecl GhcPs) -> (HappyAbsSyn ) +happyIn62 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap62 x) +{-# INLINE happyIn62 #-} +happyOut62 :: (HappyAbsSyn ) -> HappyWrap62 +happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut62 #-} +newtype HappyWrap63 = HappyWrap63 (((Maybe (EpaLocation,EpToken "#-}"),SourceText),IsBootInterface)) +happyIn63 :: (((Maybe (EpaLocation,EpToken "#-}"),SourceText),IsBootInterface)) -> (HappyAbsSyn ) +happyIn63 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap63 x) +{-# INLINE happyIn63 #-} +happyOut63 :: (HappyAbsSyn ) -> HappyWrap63 +happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut63 #-} +newtype HappyWrap64 = HappyWrap64 ((Maybe (EpToken "safe"),Bool)) +happyIn64 :: ((Maybe (EpToken "safe"),Bool)) -> (HappyAbsSyn ) +happyIn64 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap64 x) +{-# INLINE happyIn64 #-} +happyOut64 :: (HappyAbsSyn ) -> HappyWrap64 +happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut64 #-} +newtype HappyWrap65 = HappyWrap65 ((Maybe EpAnnLevel)) +happyIn65 :: ((Maybe EpAnnLevel)) -> (HappyAbsSyn ) +happyIn65 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap65 x) +{-# INLINE happyIn65 #-} +happyOut65 :: (HappyAbsSyn ) -> HappyWrap65 +happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut65 #-} +newtype HappyWrap66 = HappyWrap66 ((Maybe EpaLocation, RawPkgQual)) +happyIn66 :: ((Maybe EpaLocation, RawPkgQual)) -> (HappyAbsSyn ) +happyIn66 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap66 x) +{-# INLINE happyIn66 #-} +happyOut66 :: (HappyAbsSyn ) -> HappyWrap66 +happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut66 #-} +newtype HappyWrap67 = HappyWrap67 (Maybe (EpToken "qualified")) +happyIn67 :: (Maybe (EpToken "qualified")) -> (HappyAbsSyn ) +happyIn67 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap67 x) +{-# INLINE happyIn67 #-} +happyOut67 :: (HappyAbsSyn ) -> HappyWrap67 +happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut67 #-} +newtype HappyWrap68 = HappyWrap68 ((Maybe (EpToken "as"),Located (Maybe (LocatedA ModuleName)))) +happyIn68 :: ((Maybe (EpToken "as"),Located (Maybe (LocatedA ModuleName)))) -> (HappyAbsSyn ) +happyIn68 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap68 x) +{-# INLINE happyIn68 #-} +happyOut68 :: (HappyAbsSyn ) -> HappyWrap68 +happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut68 #-} +newtype HappyWrap69 = HappyWrap69 (Located (Maybe (ImportListInterpretation, LocatedLI [LIE GhcPs]))) +happyIn69 :: (Located (Maybe (ImportListInterpretation, LocatedLI [LIE GhcPs]))) -> (HappyAbsSyn ) +happyIn69 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap69 x) +{-# INLINE happyIn69 #-} +happyOut69 :: (HappyAbsSyn ) -> HappyWrap69 +happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut69 #-} +newtype HappyWrap70 = HappyWrap70 (Located (ImportListInterpretation, LocatedLI [LIE GhcPs])) +happyIn70 :: (Located (ImportListInterpretation, LocatedLI [LIE GhcPs])) -> (HappyAbsSyn ) +happyIn70 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap70 x) +{-# INLINE happyIn70 #-} +happyOut70 :: (HappyAbsSyn ) -> HappyWrap70 +happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut70 #-} +newtype HappyWrap71 = HappyWrap71 (([EpToken ","], OrdList (LIE GhcPs))) +happyIn71 :: (([EpToken ","], OrdList (LIE GhcPs))) -> (HappyAbsSyn ) +happyIn71 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap71 x) +{-# INLINE happyIn71 #-} +happyOut71 :: (HappyAbsSyn ) -> HappyWrap71 +happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut71 #-} +newtype HappyWrap72 = HappyWrap72 (OrdList (LIE GhcPs)) +happyIn72 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) +happyIn72 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap72 x) +{-# INLINE happyIn72 #-} +happyOut72 :: (HappyAbsSyn ) -> HappyWrap72 +happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut72 #-} +newtype HappyWrap73 = HappyWrap73 (OrdList (LIE GhcPs)) +happyIn73 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) +happyIn73 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap73 x) +{-# INLINE happyIn73 #-} +happyOut73 :: (HappyAbsSyn ) -> HappyWrap73 +happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut73 #-} +newtype HappyWrap74 = HappyWrap74 (Maybe (Located (SourceText,Int))) +happyIn74 :: (Maybe (Located (SourceText,Int))) -> (HappyAbsSyn ) +happyIn74 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap74 x) +{-# INLINE happyIn74 #-} +happyOut74 :: (HappyAbsSyn ) -> HappyWrap74 +happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut74 #-} +newtype HappyWrap75 = HappyWrap75 (Located FixityDirection) +happyIn75 :: (Located FixityDirection) -> (HappyAbsSyn ) +happyIn75 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap75 x) +{-# INLINE happyIn75 #-} +happyOut75 :: (HappyAbsSyn ) -> HappyWrap75 +happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut75 #-} +newtype HappyWrap76 = HappyWrap76 (Located (OrdList (LocatedN RdrName))) +happyIn76 :: (Located (OrdList (LocatedN RdrName))) -> (HappyAbsSyn ) +happyIn76 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap76 x) +{-# INLINE happyIn76 #-} +happyOut76 :: (HappyAbsSyn ) -> HappyWrap76 +happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut76 #-} +newtype HappyWrap77 = HappyWrap77 (OrdList (LHsDecl GhcPs)) +happyIn77 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) +happyIn77 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap77 x) +{-# INLINE happyIn77 #-} +happyOut77 :: (HappyAbsSyn ) -> HappyWrap77 +happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut77 #-} +newtype HappyWrap78 = HappyWrap78 (OrdList (LHsDecl GhcPs)) +happyIn78 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) +happyIn78 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap78 x) +{-# INLINE happyIn78 #-} +happyOut78 :: (HappyAbsSyn ) -> HappyWrap78 +happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut78 #-} +newtype HappyWrap79 = HappyWrap79 (OrdList (LHsDecl GhcPs)) +happyIn79 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) +happyIn79 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap79 x) +{-# INLINE happyIn79 #-} +happyOut79 :: (HappyAbsSyn ) -> HappyWrap79 +happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut79 #-} +newtype HappyWrap80 = HappyWrap80 (OrdList (LHsDecl GhcPs)) +happyIn80 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) +happyIn80 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap80 x) +{-# INLINE happyIn80 #-} +happyOut80 :: (HappyAbsSyn ) -> HappyWrap80 +happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut80 #-} +newtype HappyWrap81 = HappyWrap81 (LHsDecl GhcPs) +happyIn81 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn81 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap81 x) +{-# INLINE happyIn81 #-} +happyOut81 :: (HappyAbsSyn ) -> HappyWrap81 +happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut81 #-} +newtype HappyWrap82 = HappyWrap82 (LHsDecl GhcPs) +happyIn82 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn82 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap82 x) +{-# INLINE happyIn82 #-} +happyOut82 :: (HappyAbsSyn ) -> HappyWrap82 +happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut82 #-} +newtype HappyWrap83 = HappyWrap83 (LTyClDecl GhcPs) +happyIn83 :: (LTyClDecl GhcPs) -> (HappyAbsSyn ) +happyIn83 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap83 x) +{-# INLINE happyIn83 #-} +happyOut83 :: (HappyAbsSyn ) -> HappyWrap83 +happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut83 #-} +newtype HappyWrap84 = HappyWrap84 (LDefaultDecl GhcPs) +happyIn84 :: (LDefaultDecl GhcPs) -> (HappyAbsSyn ) +happyIn84 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap84 x) +{-# INLINE happyIn84 #-} +happyOut84 :: (HappyAbsSyn ) -> HappyWrap84 +happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut84 #-} +newtype HappyWrap85 = HappyWrap85 (LTyClDecl GhcPs) +happyIn85 :: (LTyClDecl GhcPs) -> (HappyAbsSyn ) +happyIn85 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap85 x) +{-# INLINE happyIn85 #-} +happyOut85 :: (HappyAbsSyn ) -> HappyWrap85 +happyOut85 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut85 #-} +newtype HappyWrap86 = HappyWrap86 (LStandaloneKindSig GhcPs) +happyIn86 :: (LStandaloneKindSig GhcPs) -> (HappyAbsSyn ) +happyIn86 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap86 x) +{-# INLINE happyIn86 #-} +happyOut86 :: (HappyAbsSyn ) -> HappyWrap86 +happyOut86 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut86 #-} +newtype HappyWrap87 = HappyWrap87 (Located [LocatedN RdrName]) +happyIn87 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn87 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap87 x) +{-# INLINE happyIn87 #-} +happyOut87 :: (HappyAbsSyn ) -> HappyWrap87 +happyOut87 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut87 #-} +newtype HappyWrap88 = HappyWrap88 (LInstDecl GhcPs) +happyIn88 :: (LInstDecl GhcPs) -> (HappyAbsSyn ) +happyIn88 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap88 x) +{-# INLINE happyIn88 #-} +happyOut88 :: (HappyAbsSyn ) -> HappyWrap88 +happyOut88 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut88 #-} +newtype HappyWrap89 = HappyWrap89 (Maybe (LocatedP OverlapMode)) +happyIn89 :: (Maybe (LocatedP OverlapMode)) -> (HappyAbsSyn ) +happyIn89 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap89 x) +{-# INLINE happyIn89 #-} +happyOut89 :: (HappyAbsSyn ) -> HappyWrap89 +happyOut89 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut89 #-} +newtype HappyWrap90 = HappyWrap90 (LDerivStrategy GhcPs) +happyIn90 :: (LDerivStrategy GhcPs) -> (HappyAbsSyn ) +happyIn90 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap90 x) +{-# INLINE happyIn90 #-} +happyOut90 :: (HappyAbsSyn ) -> HappyWrap90 +happyOut90 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut90 #-} +newtype HappyWrap91 = HappyWrap91 (LDerivStrategy GhcPs) +happyIn91 :: (LDerivStrategy GhcPs) -> (HappyAbsSyn ) +happyIn91 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap91 x) +{-# INLINE happyIn91 #-} +happyOut91 :: (HappyAbsSyn ) -> HappyWrap91 +happyOut91 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut91 #-} +newtype HappyWrap92 = HappyWrap92 (Maybe (LDerivStrategy GhcPs)) +happyIn92 :: (Maybe (LDerivStrategy GhcPs)) -> (HappyAbsSyn ) +happyIn92 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap92 x) +{-# INLINE happyIn92 #-} +happyOut92 :: (HappyAbsSyn ) -> HappyWrap92 +happyOut92 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut92 #-} +newtype HappyWrap93 = HappyWrap93 (Maybe (LIdP GhcPs)) +happyIn93 :: (Maybe (LIdP GhcPs)) -> (HappyAbsSyn ) +happyIn93 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap93 x) +{-# INLINE happyIn93 #-} +happyOut93 :: (HappyAbsSyn ) -> HappyWrap93 +happyOut93 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut93 #-} +newtype HappyWrap94 = HappyWrap94 (Located (EpToken "|", Maybe (LInjectivityAnn GhcPs))) +happyIn94 :: (Located (EpToken "|", Maybe (LInjectivityAnn GhcPs))) -> (HappyAbsSyn ) +happyIn94 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap94 x) +{-# INLINE happyIn94 #-} +happyOut94 :: (HappyAbsSyn ) -> HappyWrap94 +happyOut94 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut94 #-} +newtype HappyWrap95 = HappyWrap95 (LInjectivityAnn GhcPs) +happyIn95 :: (LInjectivityAnn GhcPs) -> (HappyAbsSyn ) +happyIn95 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap95 x) +{-# INLINE happyIn95 #-} +happyOut95 :: (HappyAbsSyn ) -> HappyWrap95 +happyOut95 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut95 #-} +newtype HappyWrap96 = HappyWrap96 (Located [LocatedN RdrName]) +happyIn96 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn96 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap96 x) +{-# INLINE happyIn96 #-} +happyOut96 :: (HappyAbsSyn ) -> HappyWrap96 +happyOut96 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut96 #-} +newtype HappyWrap97 = HappyWrap97 (Located ((EpToken "where", (EpToken "{", EpToken "..", EpToken "}")),FamilyInfo GhcPs)) +happyIn97 :: (Located ((EpToken "where", (EpToken "{", EpToken "..", EpToken "}")),FamilyInfo GhcPs)) -> (HappyAbsSyn ) +happyIn97 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap97 x) +{-# INLINE happyIn97 #-} +happyOut97 :: (HappyAbsSyn ) -> HappyWrap97 +happyOut97 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut97 #-} +newtype HappyWrap98 = HappyWrap98 (Located ((EpToken "{", EpToken "..", EpToken "}"),Maybe [LTyFamInstEqn GhcPs])) +happyIn98 :: (Located ((EpToken "{", EpToken "..", EpToken "}"),Maybe [LTyFamInstEqn GhcPs])) -> (HappyAbsSyn ) +happyIn98 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap98 x) +{-# INLINE happyIn98 #-} +happyOut98 :: (HappyAbsSyn ) -> HappyWrap98 +happyOut98 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut98 #-} +newtype HappyWrap99 = HappyWrap99 (Located [LTyFamInstEqn GhcPs]) +happyIn99 :: (Located [LTyFamInstEqn GhcPs]) -> (HappyAbsSyn ) +happyIn99 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap99 x) +{-# INLINE happyIn99 #-} +happyOut99 :: (HappyAbsSyn ) -> HappyWrap99 +happyOut99 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut99 #-} +newtype HappyWrap100 = HappyWrap100 (LTyFamInstEqn GhcPs) +happyIn100 :: (LTyFamInstEqn GhcPs) -> (HappyAbsSyn ) +happyIn100 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap100 x) +{-# INLINE happyIn100 #-} +happyOut100 :: (HappyAbsSyn ) -> HappyWrap100 +happyOut100 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut100 #-} +newtype HappyWrap101 = HappyWrap101 (LHsDecl GhcPs) +happyIn101 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn101 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap101 x) +{-# INLINE happyIn101 #-} +happyOut101 :: (HappyAbsSyn ) -> HappyWrap101 +happyOut101 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut101 #-} +newtype HappyWrap102 = HappyWrap102 (EpToken "family") +happyIn102 :: (EpToken "family") -> (HappyAbsSyn ) +happyIn102 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap102 x) +{-# INLINE happyIn102 #-} +happyOut102 :: (HappyAbsSyn ) -> HappyWrap102 +happyOut102 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut102 #-} +newtype HappyWrap103 = HappyWrap103 (EpToken "instance") +happyIn103 :: (EpToken "instance") -> (HappyAbsSyn ) +happyIn103 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap103 x) +{-# INLINE happyIn103 #-} +happyOut103 :: (HappyAbsSyn ) -> HappyWrap103 +happyOut103 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut103 #-} +newtype HappyWrap104 = HappyWrap104 (LInstDecl GhcPs) +happyIn104 :: (LInstDecl GhcPs) -> (HappyAbsSyn ) +happyIn104 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap104 x) +{-# INLINE happyIn104 #-} +happyOut104 :: (HappyAbsSyn ) -> HappyWrap104 +happyOut104 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut104 #-} +newtype HappyWrap105 = HappyWrap105 (Located ((EpToken "data", EpToken "newtype", EpToken "type") + , Bool, NewOrData)) +happyIn105 :: (Located ((EpToken "data", EpToken "newtype", EpToken "type") + , Bool, NewOrData)) -> (HappyAbsSyn ) +happyIn105 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap105 x) +{-# INLINE happyIn105 #-} +happyOut105 :: (HappyAbsSyn ) -> HappyWrap105 +happyOut105 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut105 #-} +newtype HappyWrap106 = HappyWrap106 (Located ((EpToken "data", EpToken "newtype"), NewOrData)) +happyIn106 :: (Located ((EpToken "data", EpToken "newtype"), NewOrData)) -> (HappyAbsSyn ) +happyIn106 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap106 x) +{-# INLINE happyIn106 #-} +happyOut106 :: (HappyAbsSyn ) -> HappyWrap106 +happyOut106 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut106 #-} +newtype HappyWrap107 = HappyWrap107 (Located (TokDcolon, Maybe (LHsKind GhcPs))) +happyIn107 :: (Located (TokDcolon, Maybe (LHsKind GhcPs))) -> (HappyAbsSyn ) +happyIn107 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap107 x) +{-# INLINE happyIn107 #-} +happyOut107 :: (HappyAbsSyn ) -> HappyWrap107 +happyOut107 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut107 #-} +newtype HappyWrap108 = HappyWrap108 (Located (TokDcolon, LFamilyResultSig GhcPs)) +happyIn108 :: (Located (TokDcolon, LFamilyResultSig GhcPs)) -> (HappyAbsSyn ) +happyIn108 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap108 x) +{-# INLINE happyIn108 #-} +happyOut108 :: (HappyAbsSyn ) -> HappyWrap108 +happyOut108 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut108 #-} +newtype HappyWrap109 = HappyWrap109 (Located ((TokDcolon, EpToken "="), LFamilyResultSig GhcPs)) +happyIn109 :: (Located ((TokDcolon, EpToken "="), LFamilyResultSig GhcPs)) -> (HappyAbsSyn ) +happyIn109 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap109 x) +{-# INLINE happyIn109 #-} +happyOut109 :: (HappyAbsSyn ) -> HappyWrap109 +happyOut109 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut109 #-} +newtype HappyWrap110 = HappyWrap110 (Located ((TokDcolon, EpToken "=", EpToken "|"), ( LFamilyResultSig GhcPs + , Maybe (LInjectivityAnn GhcPs)))) +happyIn110 :: (Located ((TokDcolon, EpToken "=", EpToken "|"), ( LFamilyResultSig GhcPs + , Maybe (LInjectivityAnn GhcPs)))) -> (HappyAbsSyn ) +happyIn110 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap110 x) +{-# INLINE happyIn110 #-} +happyOut110 :: (HappyAbsSyn ) -> HappyWrap110 +happyOut110 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut110 #-} +newtype HappyWrap111 = HappyWrap111 (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)) +happyIn111 :: (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)) -> (HappyAbsSyn ) +happyIn111 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap111 x) +{-# INLINE happyIn111 #-} +happyOut111 :: (HappyAbsSyn ) -> HappyWrap111 +happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut111 #-} +newtype HappyWrap112 = HappyWrap112 (Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) +happyIn112 :: (Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) -> (HappyAbsSyn ) +happyIn112 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap112 x) +{-# INLINE happyIn112 #-} +happyOut112 :: (HappyAbsSyn ) -> HappyWrap112 +happyOut112 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut112 #-} +newtype HappyWrap113 = HappyWrap113 (Maybe (LocatedP CType)) +happyIn113 :: (Maybe (LocatedP CType)) -> (HappyAbsSyn ) +happyIn113 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap113 x) +{-# INLINE happyIn113 #-} +happyOut113 :: (HappyAbsSyn ) -> HappyWrap113 +happyOut113 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut113 #-} +newtype HappyWrap114 = HappyWrap114 (LDerivDecl GhcPs) +happyIn114 :: (LDerivDecl GhcPs) -> (HappyAbsSyn ) +happyIn114 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap114 x) +{-# INLINE happyIn114 #-} +happyOut114 :: (HappyAbsSyn ) -> HappyWrap114 +happyOut114 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut114 #-} +newtype HappyWrap115 = HappyWrap115 (LRoleAnnotDecl GhcPs) +happyIn115 :: (LRoleAnnotDecl GhcPs) -> (HappyAbsSyn ) +happyIn115 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap115 x) +{-# INLINE happyIn115 #-} +happyOut115 :: (HappyAbsSyn ) -> HappyWrap115 +happyOut115 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut115 #-} +newtype HappyWrap116 = HappyWrap116 (Located [Located (Maybe FastString)]) +happyIn116 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) +happyIn116 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap116 x) +{-# INLINE happyIn116 #-} +happyOut116 :: (HappyAbsSyn ) -> HappyWrap116 +happyOut116 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut116 #-} +newtype HappyWrap117 = HappyWrap117 (Located [Located (Maybe FastString)]) +happyIn117 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) +happyIn117 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap117 x) +{-# INLINE happyIn117 #-} +happyOut117 :: (HappyAbsSyn ) -> HappyWrap117 +happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut117 #-} +newtype HappyWrap118 = HappyWrap118 (Located (Maybe FastString)) +happyIn118 :: (Located (Maybe FastString)) -> (HappyAbsSyn ) +happyIn118 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap118 x) +{-# INLINE happyIn118 #-} +happyOut118 :: (HappyAbsSyn ) -> HappyWrap118 +happyOut118 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut118 #-} +newtype HappyWrap119 = HappyWrap119 (LHsDecl GhcPs) +happyIn119 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn119 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap119 x) +{-# INLINE happyIn119 #-} +happyOut119 :: (HappyAbsSyn ) -> HappyWrap119 +happyOut119 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut119 #-} +newtype HappyWrap120 = HappyWrap120 ((LocatedN RdrName, HsPatSynDetails GhcPs, (Maybe (EpToken "{"), Maybe (EpToken "}")))) +happyIn120 :: ((LocatedN RdrName, HsPatSynDetails GhcPs, (Maybe (EpToken "{"), Maybe (EpToken "}")))) -> (HappyAbsSyn ) +happyIn120 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap120 x) +{-# INLINE happyIn120 #-} +happyOut120 :: (HappyAbsSyn ) -> HappyWrap120 +happyOut120 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut120 #-} +newtype HappyWrap121 = HappyWrap121 ([LocatedN RdrName]) +happyIn121 :: ([LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn121 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap121 x) +{-# INLINE happyIn121 #-} +happyOut121 :: (HappyAbsSyn ) -> HappyWrap121 +happyOut121 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut121 #-} +newtype HappyWrap122 = HappyWrap122 ([RecordPatSynField GhcPs]) +happyIn122 :: ([RecordPatSynField GhcPs]) -> (HappyAbsSyn ) +happyIn122 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap122 x) +{-# INLINE happyIn122 #-} +happyOut122 :: (HappyAbsSyn ) -> HappyWrap122 +happyOut122 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut122 #-} +newtype HappyWrap123 = HappyWrap123 (LocatedLW (OrdList (LHsDecl GhcPs))) +happyIn123 :: (LocatedLW (OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn123 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap123 x) +{-# INLINE happyIn123 #-} +happyOut123 :: (HappyAbsSyn ) -> HappyWrap123 +happyOut123 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut123 #-} +newtype HappyWrap124 = HappyWrap124 (LSig GhcPs) +happyIn124 :: (LSig GhcPs) -> (HappyAbsSyn ) +happyIn124 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap124 x) +{-# INLINE happyIn124 #-} +happyOut124 :: (HappyAbsSyn ) -> HappyWrap124 +happyOut124 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut124 #-} +newtype HappyWrap125 = HappyWrap125 (LocatedN RdrName) +happyIn125 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn125 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap125 x) +{-# INLINE happyIn125 #-} +happyOut125 :: (HappyAbsSyn ) -> HappyWrap125 +happyOut125 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut125 #-} +newtype HappyWrap126 = HappyWrap126 (LHsDecl GhcPs) +happyIn126 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn126 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap126 x) +{-# INLINE happyIn126 #-} +happyOut126 :: (HappyAbsSyn ) -> HappyWrap126 +happyOut126 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut126 #-} +newtype HappyWrap127 = HappyWrap127 (Located ([EpToken ";"],OrdList (LHsDecl GhcPs))) +happyIn127 :: (Located ([EpToken ";"],OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn127 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap127 x) +{-# INLINE happyIn127 #-} +happyOut127 :: (HappyAbsSyn ) -> HappyWrap127 +happyOut127 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut127 #-} +newtype HappyWrap128 = HappyWrap128 (Located ((EpToken "{", [EpToken ";"], EpToken "}") + , OrdList (LHsDecl GhcPs) + , EpLayout)) +happyIn128 :: (Located ((EpToken "{", [EpToken ";"], EpToken "}") + , OrdList (LHsDecl GhcPs) + , EpLayout)) -> (HappyAbsSyn ) +happyIn128 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap128 x) +{-# INLINE happyIn128 #-} +happyOut128 :: (HappyAbsSyn ) -> HappyWrap128 +happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut128 #-} +newtype HappyWrap129 = HappyWrap129 (Located ((EpToken "where", (EpToken "{", [EpToken ";"], EpToken "}")) + ,(OrdList (LHsDecl GhcPs)) -- Reversed + ,EpLayout)) +happyIn129 :: (Located ((EpToken "where", (EpToken "{", [EpToken ";"], EpToken "}")) + ,(OrdList (LHsDecl GhcPs)) -- Reversed + ,EpLayout)) -> (HappyAbsSyn ) +happyIn129 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap129 x) +{-# INLINE happyIn129 #-} +happyOut129 :: (HappyAbsSyn ) -> HappyWrap129 +happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut129 #-} +newtype HappyWrap130 = HappyWrap130 (Located (OrdList (LHsDecl GhcPs))) +happyIn130 :: (Located (OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn130 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap130 x) +{-# INLINE happyIn130 #-} +happyOut130 :: (HappyAbsSyn ) -> HappyWrap130 +happyOut130 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut130 #-} +newtype HappyWrap131 = HappyWrap131 (Located ([EpToken ";"],OrdList (LHsDecl GhcPs))) +happyIn131 :: (Located ([EpToken ";"],OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn131 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap131 x) +{-# INLINE happyIn131 #-} +happyOut131 :: (HappyAbsSyn ) -> HappyWrap131 +happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut131 #-} +newtype HappyWrap132 = HappyWrap132 (Located ((EpToken "{", EpToken "}", [EpToken ";"]) + , OrdList (LHsDecl GhcPs))) +happyIn132 :: (Located ((EpToken "{", EpToken "}", [EpToken ";"]) + , OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn132 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap132 x) +{-# INLINE happyIn132 #-} +happyOut132 :: (HappyAbsSyn ) -> HappyWrap132 +happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut132 #-} +newtype HappyWrap133 = HappyWrap133 (Located ((EpToken "where", (EpToken "{", EpToken "}", [EpToken ";"])) + , OrdList (LHsDecl GhcPs))) +happyIn133 :: (Located ((EpToken "where", (EpToken "{", EpToken "}", [EpToken ";"])) + , OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn133 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap133 x) +{-# INLINE happyIn133 #-} +happyOut133 :: (HappyAbsSyn ) -> HappyWrap133 +happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut133 #-} +newtype HappyWrap134 = HappyWrap134 (Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs))) +happyIn134 :: (Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn134 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap134 x) +{-# INLINE happyIn134 #-} +happyOut134 :: (HappyAbsSyn ) -> HappyWrap134 +happyOut134 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut134 #-} +newtype HappyWrap135 = HappyWrap135 (Located (AnnList (),Located (OrdList (LHsDecl GhcPs)))) +happyIn135 :: (Located (AnnList (),Located (OrdList (LHsDecl GhcPs)))) -> (HappyAbsSyn ) +happyIn135 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap135 x) +{-# INLINE happyIn135 #-} +happyOut135 :: (HappyAbsSyn ) -> HappyWrap135 +happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut135 #-} +newtype HappyWrap136 = HappyWrap136 (Located (HsLocalBinds GhcPs)) +happyIn136 :: (Located (HsLocalBinds GhcPs)) -> (HappyAbsSyn ) +happyIn136 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap136 x) +{-# INLINE happyIn136 #-} +happyOut136 :: (HappyAbsSyn ) -> HappyWrap136 +happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut136 #-} +newtype HappyWrap137 = HappyWrap137 (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) +happyIn137 :: (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) -> (HappyAbsSyn ) +happyIn137 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap137 x) +{-# INLINE happyIn137 #-} +happyOut137 :: (HappyAbsSyn ) -> HappyWrap137 +happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut137 #-} +newtype HappyWrap138 = HappyWrap138 ([LRuleDecl GhcPs]) +happyIn138 :: ([LRuleDecl GhcPs]) -> (HappyAbsSyn ) +happyIn138 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap138 x) +{-# INLINE happyIn138 #-} +happyOut138 :: (HappyAbsSyn ) -> HappyWrap138 +happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut138 #-} +newtype HappyWrap139 = HappyWrap139 (LRuleDecl GhcPs) +happyIn139 :: (LRuleDecl GhcPs) -> (HappyAbsSyn ) +happyIn139 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap139 x) +{-# INLINE happyIn139 #-} +happyOut139 :: (HappyAbsSyn ) -> HappyWrap139 +happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut139 #-} +newtype HappyWrap140 = HappyWrap140 ((ActivationAnn, Maybe Activation)) +happyIn140 :: ((ActivationAnn, Maybe Activation)) -> (HappyAbsSyn ) +happyIn140 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap140 x) +{-# INLINE happyIn140 #-} +happyOut140 :: (HappyAbsSyn ) -> HappyWrap140 +happyOut140 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut140 #-} +newtype HappyWrap141 = HappyWrap141 ((Maybe (EpToken "~"))) +happyIn141 :: ((Maybe (EpToken "~"))) -> (HappyAbsSyn ) +happyIn141 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap141 x) +{-# INLINE happyIn141 #-} +happyOut141 :: (HappyAbsSyn ) -> HappyWrap141 +happyOut141 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut141 #-} +newtype HappyWrap142 = HappyWrap142 (( ActivationAnn + , Activation)) +happyIn142 :: (( ActivationAnn + , Activation)) -> (HappyAbsSyn ) +happyIn142 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap142 x) +{-# INLINE happyIn142 #-} +happyOut142 :: (HappyAbsSyn ) -> HappyWrap142 +happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut142 #-} +newtype HappyWrap143 = HappyWrap143 (Maybe (RuleBndrs GhcPs)) +happyIn143 :: (Maybe (RuleBndrs GhcPs)) -> (HappyAbsSyn ) +happyIn143 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap143 x) +{-# INLINE happyIn143 #-} +happyOut143 :: (HappyAbsSyn ) -> HappyWrap143 +happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut143 #-} +newtype HappyWrap144 = HappyWrap144 ([LRuleTyTmVar]) +happyIn144 :: ([LRuleTyTmVar]) -> (HappyAbsSyn ) +happyIn144 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap144 x) +{-# INLINE happyIn144 #-} +happyOut144 :: (HappyAbsSyn ) -> HappyWrap144 +happyOut144 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut144 #-} +newtype HappyWrap145 = HappyWrap145 (LRuleTyTmVar) +happyIn145 :: (LRuleTyTmVar) -> (HappyAbsSyn ) +happyIn145 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap145 x) +{-# INLINE happyIn145 #-} +happyOut145 :: (HappyAbsSyn ) -> HappyWrap145 +happyOut145 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut145 #-} +newtype HappyWrap146 = HappyWrap146 (Maybe (LWarningTxt GhcPs)) +happyIn146 :: (Maybe (LWarningTxt GhcPs)) -> (HappyAbsSyn ) +happyIn146 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap146 x) +{-# INLINE happyIn146 #-} +happyOut146 :: (HappyAbsSyn ) -> HappyWrap146 +happyOut146 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut146 #-} +newtype HappyWrap147 = HappyWrap147 (Maybe (LocatedE InWarningCategory)) +happyIn147 :: (Maybe (LocatedE InWarningCategory)) -> (HappyAbsSyn ) +happyIn147 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap147 x) +{-# INLINE happyIn147 #-} +happyOut147 :: (HappyAbsSyn ) -> HappyWrap147 +happyOut147 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut147 #-} +newtype HappyWrap148 = HappyWrap148 (OrdList (LWarnDecl GhcPs)) +happyIn148 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) +happyIn148 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap148 x) +{-# INLINE happyIn148 #-} +happyOut148 :: (HappyAbsSyn ) -> HappyWrap148 +happyOut148 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut148 #-} +newtype HappyWrap149 = HappyWrap149 (OrdList (LWarnDecl GhcPs)) +happyIn149 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) +happyIn149 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap149 x) +{-# INLINE happyIn149 #-} +happyOut149 :: (HappyAbsSyn ) -> HappyWrap149 +happyOut149 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut149 #-} +newtype HappyWrap150 = HappyWrap150 (Located NamespaceSpecifier) +happyIn150 :: (Located NamespaceSpecifier) -> (HappyAbsSyn ) +happyIn150 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap150 x) +{-# INLINE happyIn150 #-} +happyOut150 :: (HappyAbsSyn ) -> HappyWrap150 +happyOut150 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut150 #-} +newtype HappyWrap151 = HappyWrap151 (OrdList (LWarnDecl GhcPs)) +happyIn151 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) +happyIn151 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap151 x) +{-# INLINE happyIn151 #-} +happyOut151 :: (HappyAbsSyn ) -> HappyWrap151 +happyOut151 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut151 #-} +newtype HappyWrap152 = HappyWrap152 (OrdList (LWarnDecl GhcPs)) +happyIn152 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) +happyIn152 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap152 x) +{-# INLINE happyIn152 #-} +happyOut152 :: (HappyAbsSyn ) -> HappyWrap152 +happyOut152 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut152 #-} +newtype HappyWrap153 = HappyWrap153 (Located ((EpToken "[", EpToken "]"),[Located StringLiteral])) +happyIn153 :: (Located ((EpToken "[", EpToken "]"),[Located StringLiteral])) -> (HappyAbsSyn ) +happyIn153 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap153 x) +{-# INLINE happyIn153 #-} +happyOut153 :: (HappyAbsSyn ) -> HappyWrap153 +happyOut153 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut153 #-} +newtype HappyWrap154 = HappyWrap154 (Located (OrdList (Located StringLiteral))) +happyIn154 :: (Located (OrdList (Located StringLiteral))) -> (HappyAbsSyn ) +happyIn154 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap154 x) +{-# INLINE happyIn154 #-} +happyOut154 :: (HappyAbsSyn ) -> HappyWrap154 +happyOut154 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut154 #-} +newtype HappyWrap155 = HappyWrap155 (LHsDecl GhcPs) +happyIn155 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn155 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap155 x) +{-# INLINE happyIn155 #-} +happyOut155 :: (HappyAbsSyn ) -> HappyWrap155 +happyOut155 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut155 #-} +newtype HappyWrap156 = HappyWrap156 (Located (EpToken "foreign" -> HsDecl GhcPs)) +happyIn156 :: (Located (EpToken "foreign" -> HsDecl GhcPs)) -> (HappyAbsSyn ) +happyIn156 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap156 x) +{-# INLINE happyIn156 #-} +happyOut156 :: (HappyAbsSyn ) -> HappyWrap156 +happyOut156 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut156 #-} +newtype HappyWrap157 = HappyWrap157 (Located CCallConv) +happyIn157 :: (Located CCallConv) -> (HappyAbsSyn ) +happyIn157 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap157 x) +{-# INLINE happyIn157 #-} +happyOut157 :: (HappyAbsSyn ) -> HappyWrap157 +happyOut157 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut157 #-} +newtype HappyWrap158 = HappyWrap158 (Located Safety) +happyIn158 :: (Located Safety) -> (HappyAbsSyn ) +happyIn158 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap158 x) +{-# INLINE happyIn158 #-} +happyOut158 :: (HappyAbsSyn ) -> HappyWrap158 +happyOut158 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut158 #-} +newtype HappyWrap159 = HappyWrap159 (Located (TokDcolon + ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs))) +happyIn159 :: (Located (TokDcolon + ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs))) -> (HappyAbsSyn ) +happyIn159 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap159 x) +{-# INLINE happyIn159 #-} +happyOut159 :: (HappyAbsSyn ) -> HappyWrap159 +happyOut159 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut159 #-} +newtype HappyWrap160 = HappyWrap160 (Maybe (EpUniToken "::" "\8759", LHsType GhcPs)) +happyIn160 :: (Maybe (EpUniToken "::" "\8759", LHsType GhcPs)) -> (HappyAbsSyn ) +happyIn160 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap160 x) +{-# INLINE happyIn160 #-} +happyOut160 :: (HappyAbsSyn ) -> HappyWrap160 +happyOut160 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut160 #-} +newtype HappyWrap161 = HappyWrap161 ((Maybe (EpUniToken "::" "\8759"), Maybe (LocatedN RdrName))) +happyIn161 :: ((Maybe (EpUniToken "::" "\8759"), Maybe (LocatedN RdrName))) -> (HappyAbsSyn ) +happyIn161 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap161 x) +{-# INLINE happyIn161 #-} +happyOut161 :: (HappyAbsSyn ) -> HappyWrap161 +happyOut161 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut161 #-} +newtype HappyWrap162 = HappyWrap162 (LHsSigType GhcPs) +happyIn162 :: (LHsSigType GhcPs) -> (HappyAbsSyn ) +happyIn162 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap162 x) +{-# INLINE happyIn162 #-} +happyOut162 :: (HappyAbsSyn ) -> HappyWrap162 +happyOut162 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut162 #-} +newtype HappyWrap163 = HappyWrap163 (LHsSigType GhcPs) +happyIn163 :: (LHsSigType GhcPs) -> (HappyAbsSyn ) +happyIn163 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap163 x) +{-# INLINE happyIn163 #-} +happyOut163 :: (HappyAbsSyn ) -> HappyWrap163 +happyOut163 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut163 #-} +newtype HappyWrap164 = HappyWrap164 (Located [LocatedN RdrName]) +happyIn164 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn164 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap164 x) +{-# INLINE happyIn164 #-} +happyOut164 :: (HappyAbsSyn ) -> HappyWrap164 +happyOut164 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut164 #-} +newtype HappyWrap165 = HappyWrap165 (Located (OrdList (LHsSigType GhcPs))) +happyIn165 :: (Located (OrdList (LHsSigType GhcPs))) -> (HappyAbsSyn ) +happyIn165 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap165 x) +{-# INLINE happyIn165 #-} +happyOut165 :: (HappyAbsSyn ) -> HappyWrap165 +happyOut165 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut165 #-} +newtype HappyWrap166 = HappyWrap166 (Located UnpackednessPragma) +happyIn166 :: (Located UnpackednessPragma) -> (HappyAbsSyn ) +happyIn166 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap166 x) +{-# INLINE happyIn166 #-} +happyOut166 :: (HappyAbsSyn ) -> HappyWrap166 +happyOut166 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut166 #-} +newtype HappyWrap167 = HappyWrap167 (Located (HsForAllTelescope GhcPs)) +happyIn167 :: (Located (HsForAllTelescope GhcPs)) -> (HappyAbsSyn ) +happyIn167 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap167 x) +{-# INLINE happyIn167 #-} +happyOut167 :: (HappyAbsSyn ) -> HappyWrap167 +happyOut167 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut167 #-} +newtype HappyWrap168 = HappyWrap168 (LHsType GhcPs) +happyIn168 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn168 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap168 x) +{-# INLINE happyIn168 #-} +happyOut168 :: (HappyAbsSyn ) -> HappyWrap168 +happyOut168 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut168 #-} +newtype HappyWrap169 = HappyWrap169 (LHsType GhcPs) +happyIn169 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn169 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap169 x) +{-# INLINE happyIn169 #-} +happyOut169 :: (HappyAbsSyn ) -> HappyWrap169 +happyOut169 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut169 #-} +newtype HappyWrap170 = HappyWrap170 (LHsContext GhcPs) +happyIn170 :: (LHsContext GhcPs) -> (HappyAbsSyn ) +happyIn170 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap170 x) +{-# INLINE happyIn170 #-} +happyOut170 :: (HappyAbsSyn ) -> HappyWrap170 +happyOut170 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut170 #-} +newtype HappyWrap171 = HappyWrap171 (forall b. DisambECP b => PV (LocatedC [LocatedA b])) +happyIn171 :: (forall b. DisambECP b => PV (LocatedC [LocatedA b])) -> (HappyAbsSyn ) +happyIn171 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap171 x) +{-# INLINE happyIn171 #-} +happyOut171 :: (HappyAbsSyn ) -> HappyWrap171 +happyOut171 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut171 #-} +newtype HappyWrap172 = HappyWrap172 (LHsType GhcPs) +happyIn172 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn172 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap172 x) +{-# INLINE happyIn172 #-} +happyOut172 :: (HappyAbsSyn ) -> HappyWrap172 +happyOut172 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut172 #-} +newtype HappyWrap173 = HappyWrap173 (Located (EpUniToken "->" "\8594" -> HsMultAnn GhcPs)) +happyIn173 :: (Located (EpUniToken "->" "\8594" -> HsMultAnn GhcPs)) -> (HappyAbsSyn ) +happyIn173 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap173 x) +{-# INLINE happyIn173 #-} +happyOut173 :: (HappyAbsSyn ) -> HappyWrap173 +happyOut173 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut173 #-} +newtype HappyWrap174 = HappyWrap174 (forall b. DisambECP b => PV (Located (EpUniToken "->" "\8594" -> HsMultAnnOf (LocatedA b) GhcPs))) +happyIn174 :: (forall b. DisambECP b => PV (Located (EpUniToken "->" "\8594" -> HsMultAnnOf (LocatedA b) GhcPs))) -> (HappyAbsSyn ) +happyIn174 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap174 x) +{-# INLINE happyIn174 #-} +happyOut174 :: (HappyAbsSyn ) -> HappyWrap174 +happyOut174 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut174 #-} +newtype HappyWrap175 = HappyWrap175 (LHsType GhcPs) +happyIn175 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn175 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap175 x) +{-# INLINE happyIn175 #-} +happyOut175 :: (HappyAbsSyn ) -> HappyWrap175 +happyOut175 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut175 #-} +newtype HappyWrap176 = HappyWrap176 (forall b. DisambTD b => PV (LocatedA b)) +happyIn176 :: (forall b. DisambTD b => PV (LocatedA b)) -> (HappyAbsSyn ) +happyIn176 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap176 x) +{-# INLINE happyIn176 #-} +happyOut176 :: (HappyAbsSyn ) -> HappyWrap176 +happyOut176 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut176 #-} +newtype HappyWrap177 = HappyWrap177 (forall b. DisambTD b => PV (LocatedA b)) +happyIn177 :: (forall b. DisambTD b => PV (LocatedA b)) -> (HappyAbsSyn ) +happyIn177 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap177 x) +{-# INLINE happyIn177 #-} +happyOut177 :: (HappyAbsSyn ) -> HappyWrap177 +happyOut177 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut177 #-} +newtype HappyWrap178 = HappyWrap178 (LHsType GhcPs) +happyIn178 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn178 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap178 x) +{-# INLINE happyIn178 #-} +happyOut178 :: (HappyAbsSyn ) -> HappyWrap178 +happyOut178 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut178 #-} +newtype HappyWrap179 = HappyWrap179 ((LocatedN RdrName, PromotionFlag)) +happyIn179 :: ((LocatedN RdrName, PromotionFlag)) -> (HappyAbsSyn ) +happyIn179 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap179 x) +{-# INLINE happyIn179 #-} +happyOut179 :: (HappyAbsSyn ) -> HappyWrap179 +happyOut179 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut179 #-} +newtype HappyWrap180 = HappyWrap180 (LHsType GhcPs) +happyIn180 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn180 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap180 x) +{-# INLINE happyIn180 #-} +happyOut180 :: (HappyAbsSyn ) -> HappyWrap180 +happyOut180 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut180 #-} +newtype HappyWrap181 = HappyWrap181 (LHsSigType GhcPs) +happyIn181 :: (LHsSigType GhcPs) -> (HappyAbsSyn ) +happyIn181 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap181 x) +{-# INLINE happyIn181 #-} +happyOut181 :: (HappyAbsSyn ) -> HappyWrap181 +happyOut181 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut181 #-} +newtype HappyWrap182 = HappyWrap182 ([LHsSigType GhcPs]) +happyIn182 :: ([LHsSigType GhcPs]) -> (HappyAbsSyn ) +happyIn182 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap182 x) +{-# INLINE happyIn182 #-} +happyOut182 :: (HappyAbsSyn ) -> HappyWrap182 +happyOut182 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut182 #-} +newtype HappyWrap183 = HappyWrap183 ([LHsType GhcPs]) +happyIn183 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) +happyIn183 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap183 x) +{-# INLINE happyIn183 #-} +happyOut183 :: (HappyAbsSyn ) -> HappyWrap183 +happyOut183 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut183 #-} +newtype HappyWrap184 = HappyWrap184 ([LHsType GhcPs]) +happyIn184 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) +happyIn184 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap184 x) +{-# INLINE happyIn184 #-} +happyOut184 :: (HappyAbsSyn ) -> HappyWrap184 +happyOut184 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut184 #-} +newtype HappyWrap185 = HappyWrap185 ([LHsType GhcPs]) +happyIn185 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) +happyIn185 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap185 x) +{-# INLINE happyIn185 #-} +happyOut185 :: (HappyAbsSyn ) -> HappyWrap185 +happyOut185 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut185 #-} +newtype HappyWrap186 = HappyWrap186 ([LHsTyVarBndr Specificity GhcPs]) +happyIn186 :: ([LHsTyVarBndr Specificity GhcPs]) -> (HappyAbsSyn ) +happyIn186 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap186 x) +{-# INLINE happyIn186 #-} +happyOut186 :: (HappyAbsSyn ) -> HappyWrap186 +happyOut186 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut186 #-} +newtype HappyWrap187 = HappyWrap187 (LHsTyVarBndr Specificity GhcPs) +happyIn187 :: (LHsTyVarBndr Specificity GhcPs) -> (HappyAbsSyn ) +happyIn187 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap187 x) +{-# INLINE happyIn187 #-} +happyOut187 :: (HappyAbsSyn ) -> HappyWrap187 +happyOut187 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut187 #-} +newtype HappyWrap188 = HappyWrap188 (LHsTyVarBndr Specificity GhcPs) +happyIn188 :: (LHsTyVarBndr Specificity GhcPs) -> (HappyAbsSyn ) +happyIn188 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap188 x) +{-# INLINE happyIn188 #-} +happyOut188 :: (HappyAbsSyn ) -> HappyWrap188 +happyOut188 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut188 #-} +newtype HappyWrap189 = HappyWrap189 (Located (HsBndrVar GhcPs)) +happyIn189 :: (Located (HsBndrVar GhcPs)) -> (HappyAbsSyn ) +happyIn189 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap189 x) +{-# INLINE happyIn189 #-} +happyOut189 :: (HappyAbsSyn ) -> HappyWrap189 +happyOut189 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut189 #-} +newtype HappyWrap190 = HappyWrap190 (Located (EpToken "|",[LHsFunDep GhcPs])) +happyIn190 :: (Located (EpToken "|",[LHsFunDep GhcPs])) -> (HappyAbsSyn ) +happyIn190 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap190 x) +{-# INLINE happyIn190 #-} +happyOut190 :: (HappyAbsSyn ) -> HappyWrap190 +happyOut190 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut190 #-} +newtype HappyWrap191 = HappyWrap191 (Located [LHsFunDep GhcPs]) +happyIn191 :: (Located [LHsFunDep GhcPs]) -> (HappyAbsSyn ) +happyIn191 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap191 x) +{-# INLINE happyIn191 #-} +happyOut191 :: (HappyAbsSyn ) -> HappyWrap191 +happyOut191 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut191 #-} +newtype HappyWrap192 = HappyWrap192 (LHsFunDep GhcPs) +happyIn192 :: (LHsFunDep GhcPs) -> (HappyAbsSyn ) +happyIn192 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap192 x) +{-# INLINE happyIn192 #-} +happyOut192 :: (HappyAbsSyn ) -> HappyWrap192 +happyOut192 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut192 #-} +newtype HappyWrap193 = HappyWrap193 (Located [LocatedN RdrName]) +happyIn193 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn193 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap193 x) +{-# INLINE happyIn193 #-} +happyOut193 :: (HappyAbsSyn ) -> HappyWrap193 +happyOut193 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut193 #-} +newtype HappyWrap194 = HappyWrap194 (LHsKind GhcPs) +happyIn194 :: (LHsKind GhcPs) -> (HappyAbsSyn ) +happyIn194 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap194 x) +{-# INLINE happyIn194 #-} +happyOut194 :: (HappyAbsSyn ) -> HappyWrap194 +happyOut194 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut194 #-} +newtype HappyWrap195 = HappyWrap195 (Located ((EpToken "where", EpToken "{", EpToken "}") + ,[LConDecl GhcPs])) +happyIn195 :: (Located ((EpToken "where", EpToken "{", EpToken "}") + ,[LConDecl GhcPs])) -> (HappyAbsSyn ) +happyIn195 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap195 x) +{-# INLINE happyIn195 #-} +happyOut195 :: (HappyAbsSyn ) -> HappyWrap195 +happyOut195 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut195 #-} +newtype HappyWrap196 = HappyWrap196 (Located [LConDecl GhcPs]) +happyIn196 :: (Located [LConDecl GhcPs]) -> (HappyAbsSyn ) +happyIn196 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap196 x) +{-# INLINE happyIn196 #-} +happyOut196 :: (HappyAbsSyn ) -> HappyWrap196 +happyOut196 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut196 #-} +newtype HappyWrap197 = HappyWrap197 (LConDecl GhcPs) +happyIn197 :: (LConDecl GhcPs) -> (HappyAbsSyn ) +happyIn197 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap197 x) +{-# INLINE happyIn197 #-} +happyOut197 :: (HappyAbsSyn ) -> HappyWrap197 +happyOut197 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut197 #-} +newtype HappyWrap198 = HappyWrap198 (Located (EpToken "=",[LConDecl GhcPs])) +happyIn198 :: (Located (EpToken "=",[LConDecl GhcPs])) -> (HappyAbsSyn ) +happyIn198 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap198 x) +{-# INLINE happyIn198 #-} +happyOut198 :: (HappyAbsSyn ) -> HappyWrap198 +happyOut198 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut198 #-} +newtype HappyWrap199 = HappyWrap199 (Located [LConDecl GhcPs]) +happyIn199 :: (Located [LConDecl GhcPs]) -> (HappyAbsSyn ) +happyIn199 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap199 x) +{-# INLINE happyIn199 #-} +happyOut199 :: (HappyAbsSyn ) -> HappyWrap199 +happyOut199 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut199 #-} +newtype HappyWrap200 = HappyWrap200 (LConDecl GhcPs) +happyIn200 :: (LConDecl GhcPs) -> (HappyAbsSyn ) +happyIn200 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap200 x) +{-# INLINE happyIn200 #-} +happyOut200 :: (HappyAbsSyn ) -> HappyWrap200 +happyOut200 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut200 #-} +newtype HappyWrap201 = HappyWrap201 (Located ((TokForall, EpToken "."), Maybe [LHsTyVarBndr Specificity GhcPs])) +happyIn201 :: (Located ((TokForall, EpToken "."), Maybe [LHsTyVarBndr Specificity GhcPs])) -> (HappyAbsSyn ) +happyIn201 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap201 x) +{-# INLINE happyIn201 #-} +happyOut201 :: (HappyAbsSyn ) -> HappyWrap201 +happyOut201 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut201 #-} +newtype HappyWrap202 = HappyWrap202 (Located (LocatedN RdrName, HsConDeclH98Details GhcPs)) +happyIn202 :: (Located (LocatedN RdrName, HsConDeclH98Details GhcPs)) -> (HappyAbsSyn ) +happyIn202 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap202 x) +{-# INLINE happyIn202 #-} +happyOut202 :: (HappyAbsSyn ) -> HappyWrap202 +happyOut202 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut202 #-} +newtype HappyWrap203 = HappyWrap203 ((LHsType GhcPs, Int, Int)) +happyIn203 :: ((LHsType GhcPs, Int, Int)) -> (HappyAbsSyn ) +happyIn203 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap203 x) +{-# INLINE happyIn203 #-} +happyOut203 :: (HappyAbsSyn ) -> HappyWrap203 +happyOut203 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut203 #-} +newtype HappyWrap204 = HappyWrap204 ([LHsConDeclRecField GhcPs]) +happyIn204 :: ([LHsConDeclRecField GhcPs]) -> (HappyAbsSyn ) +happyIn204 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap204 x) +{-# INLINE happyIn204 #-} +happyOut204 :: (HappyAbsSyn ) -> HappyWrap204 +happyOut204 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut204 #-} +newtype HappyWrap205 = HappyWrap205 ([LHsConDeclRecField GhcPs]) +happyIn205 :: ([LHsConDeclRecField GhcPs]) -> (HappyAbsSyn ) +happyIn205 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap205 x) +{-# INLINE happyIn205 #-} +happyOut205 :: (HappyAbsSyn ) -> HappyWrap205 +happyOut205 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut205 #-} +newtype HappyWrap206 = HappyWrap206 (LHsConDeclRecField GhcPs) +happyIn206 :: (LHsConDeclRecField GhcPs) -> (HappyAbsSyn ) +happyIn206 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap206 x) +{-# INLINE happyIn206 #-} +happyOut206 :: (HappyAbsSyn ) -> HappyWrap206 +happyOut206 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut206 #-} +newtype HappyWrap207 = HappyWrap207 (Located (HsDeriving GhcPs)) +happyIn207 :: (Located (HsDeriving GhcPs)) -> (HappyAbsSyn ) +happyIn207 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap207 x) +{-# INLINE happyIn207 #-} +happyOut207 :: (HappyAbsSyn ) -> HappyWrap207 +happyOut207 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut207 #-} +newtype HappyWrap208 = HappyWrap208 (Located (HsDeriving GhcPs)) +happyIn208 :: (Located (HsDeriving GhcPs)) -> (HappyAbsSyn ) +happyIn208 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap208 x) +{-# INLINE happyIn208 #-} +happyOut208 :: (HappyAbsSyn ) -> HappyWrap208 +happyOut208 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut208 #-} +newtype HappyWrap209 = HappyWrap209 (LHsDerivingClause GhcPs) +happyIn209 :: (LHsDerivingClause GhcPs) -> (HappyAbsSyn ) +happyIn209 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap209 x) +{-# INLINE happyIn209 #-} +happyOut209 :: (HappyAbsSyn ) -> HappyWrap209 +happyOut209 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut209 #-} +newtype HappyWrap210 = HappyWrap210 (LDerivClauseTys GhcPs) +happyIn210 :: (LDerivClauseTys GhcPs) -> (HappyAbsSyn ) +happyIn210 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap210 x) +{-# INLINE happyIn210 #-} +happyOut210 :: (HappyAbsSyn ) -> HappyWrap210 +happyOut210 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut210 #-} +newtype HappyWrap211 = HappyWrap211 (LHsDecl GhcPs) +happyIn211 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn211 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap211 x) +{-# INLINE happyIn211 #-} +happyOut211 :: (HappyAbsSyn ) -> HappyWrap211 +happyOut211 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut211 #-} +newtype HappyWrap212 = HappyWrap212 (LHsDecl GhcPs) +happyIn212 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn212 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap212 x) +{-# INLINE happyIn212 #-} +happyOut212 :: (HappyAbsSyn ) -> HappyWrap212 +happyOut212 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut212 #-} +newtype HappyWrap213 = HappyWrap213 (Located (GRHSs GhcPs (LHsExpr GhcPs))) +happyIn213 :: (Located (GRHSs GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) +happyIn213 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap213 x) +{-# INLINE happyIn213 #-} +happyOut213 :: (HappyAbsSyn ) -> HappyWrap213 +happyOut213 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut213 #-} +newtype HappyWrap214 = HappyWrap214 (Located (NonEmpty (LGRHS GhcPs (LHsExpr GhcPs)))) +happyIn214 :: (Located (NonEmpty (LGRHS GhcPs (LHsExpr GhcPs)))) -> (HappyAbsSyn ) +happyIn214 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap214 x) +{-# INLINE happyIn214 #-} +happyOut214 :: (HappyAbsSyn ) -> HappyWrap214 +happyOut214 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut214 #-} +newtype HappyWrap215 = HappyWrap215 (LGRHS GhcPs (LHsExpr GhcPs)) +happyIn215 :: (LGRHS GhcPs (LHsExpr GhcPs)) -> (HappyAbsSyn ) +happyIn215 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap215 x) +{-# INLINE happyIn215 #-} +happyOut215 :: (HappyAbsSyn ) -> HappyWrap215 +happyOut215 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut215 #-} +newtype HappyWrap216 = HappyWrap216 (LHsDecl GhcPs) +happyIn216 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn216 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap216 x) +{-# INLINE happyIn216 #-} +happyOut216 :: (HappyAbsSyn ) -> HappyWrap216 +happyOut216 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut216 #-} +newtype HappyWrap217 = HappyWrap217 (Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs)))) +happyIn217 :: (Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs)))) -> (HappyAbsSyn ) +happyIn217 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap217 x) +{-# INLINE happyIn217 #-} +happyOut217 :: (HappyAbsSyn ) -> HappyWrap217 +happyOut217 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut217 #-} +newtype HappyWrap218 = HappyWrap218 ((ActivationAnn,Maybe Activation)) +happyIn218 :: ((ActivationAnn,Maybe Activation)) -> (HappyAbsSyn ) +happyIn218 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap218 x) +{-# INLINE happyIn218 #-} +happyOut218 :: (HappyAbsSyn ) -> HappyWrap218 +happyOut218 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut218 #-} +newtype HappyWrap219 = HappyWrap219 ((ActivationAnn, Activation)) +happyIn219 :: ((ActivationAnn, Activation)) -> (HappyAbsSyn ) +happyIn219 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap219 x) +{-# INLINE happyIn219 #-} +happyOut219 :: (HappyAbsSyn ) -> HappyWrap219 +happyOut219 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut219 #-} +newtype HappyWrap220 = HappyWrap220 (Located (HsUntypedSplice GhcPs)) +happyIn220 :: (Located (HsUntypedSplice GhcPs)) -> (HappyAbsSyn ) +happyIn220 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap220 x) +{-# INLINE happyIn220 #-} +happyOut220 :: (HappyAbsSyn ) -> HappyWrap220 +happyOut220 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut220 #-} +newtype HappyWrap221 = HappyWrap221 (ECP) +happyIn221 :: (ECP) -> (HappyAbsSyn ) +happyIn221 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap221 x) +{-# INLINE happyIn221 #-} +happyOut221 :: (HappyAbsSyn ) -> HappyWrap221 +happyOut221 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut221 #-} +newtype HappyWrap222 = HappyWrap222 (ECP) +happyIn222 :: (ECP) -> (HappyAbsSyn ) +happyIn222 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap222 x) +{-# INLINE happyIn222 #-} +happyOut222 :: (HappyAbsSyn ) -> HappyWrap222 +happyOut222 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut222 #-} +newtype HappyWrap223 = HappyWrap223 (ECP) +happyIn223 :: (ECP) -> (HappyAbsSyn ) +happyIn223 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap223 x) +{-# INLINE happyIn223 #-} +happyOut223 :: (HappyAbsSyn ) -> HappyWrap223 +happyOut223 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut223 #-} +newtype HappyWrap224 = HappyWrap224 (ECP) +happyIn224 :: (ECP) -> (HappyAbsSyn ) +happyIn224 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap224 x) +{-# INLINE happyIn224 #-} +happyOut224 :: (HappyAbsSyn ) -> HappyWrap224 +happyOut224 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut224 #-} +newtype HappyWrap225 = HappyWrap225 (ECP) +happyIn225 :: (ECP) -> (HappyAbsSyn ) +happyIn225 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap225 x) +{-# INLINE happyIn225 #-} +happyOut225 :: (HappyAbsSyn ) -> HappyWrap225 +happyOut225 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut225 #-} +newtype HappyWrap226 = HappyWrap226 (ECP) +happyIn226 :: (ECP) -> (HappyAbsSyn ) +happyIn226 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap226 x) +{-# INLINE happyIn226 #-} +happyOut226 :: (HappyAbsSyn ) -> HappyWrap226 +happyOut226 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut226 #-} +newtype HappyWrap227 = HappyWrap227 ((Maybe (EpToken ";"),Bool)) +happyIn227 :: ((Maybe (EpToken ";"),Bool)) -> (HappyAbsSyn ) +happyIn227 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap227 x) +{-# INLINE happyIn227 #-} +happyOut227 :: (HappyAbsSyn ) -> HappyWrap227 +happyOut227 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut227 #-} +newtype HappyWrap228 = HappyWrap228 (Located (HsPragE GhcPs)) +happyIn228 :: (Located (HsPragE GhcPs)) -> (HappyAbsSyn ) +happyIn228 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap228 x) +{-# INLINE happyIn228 #-} +happyOut228 :: (HappyAbsSyn ) -> HappyWrap228 +happyOut228 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut228 #-} +newtype HappyWrap229 = HappyWrap229 (ECP) +happyIn229 :: (ECP) -> (HappyAbsSyn ) +happyIn229 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap229 x) +{-# INLINE happyIn229 #-} +happyOut229 :: (HappyAbsSyn ) -> HappyWrap229 +happyOut229 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut229 #-} +newtype HappyWrap230 = HappyWrap230 (ECP) +happyIn230 :: (ECP) -> (HappyAbsSyn ) +happyIn230 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap230 x) +{-# INLINE happyIn230 #-} +happyOut230 :: (HappyAbsSyn ) -> HappyWrap230 +happyOut230 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut230 #-} +newtype HappyWrap231 = HappyWrap231 (ECP) +happyIn231 :: (ECP) -> (HappyAbsSyn ) +happyIn231 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap231 x) +{-# INLINE happyIn231 #-} +happyOut231 :: (HappyAbsSyn ) -> HappyWrap231 +happyOut231 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut231 #-} +newtype HappyWrap232 = HappyWrap232 (ECP) +happyIn232 :: (ECP) -> (HappyAbsSyn ) +happyIn232 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap232 x) +{-# INLINE happyIn232 #-} +happyOut232 :: (HappyAbsSyn ) -> HappyWrap232 +happyOut232 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut232 #-} +newtype HappyWrap233 = HappyWrap233 (Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))) +happyIn233 :: (Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))) -> (HappyAbsSyn ) +happyIn233 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap233 x) +{-# INLINE happyIn233 #-} +happyOut233 :: (HappyAbsSyn ) -> HappyWrap233 +happyOut233 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut233 #-} +newtype HappyWrap234 = HappyWrap234 (LHsExpr GhcPs) +happyIn234 :: (LHsExpr GhcPs) -> (HappyAbsSyn ) +happyIn234 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap234 x) +{-# INLINE happyIn234 #-} +happyOut234 :: (HappyAbsSyn ) -> HappyWrap234 +happyOut234 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut234 #-} +newtype HappyWrap235 = HappyWrap235 (Located (HsUntypedSplice GhcPs)) +happyIn235 :: (Located (HsUntypedSplice GhcPs)) -> (HappyAbsSyn ) +happyIn235 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap235 x) +{-# INLINE happyIn235 #-} +happyOut235 :: (HappyAbsSyn ) -> HappyWrap235 +happyOut235 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut235 #-} +newtype HappyWrap236 = HappyWrap236 (Located (HsTypedSplice GhcPs)) +happyIn236 :: (Located (HsTypedSplice GhcPs)) -> (HappyAbsSyn ) +happyIn236 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap236 x) +{-# INLINE happyIn236 #-} +happyOut236 :: (HappyAbsSyn ) -> HappyWrap236 +happyOut236 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut236 #-} +newtype HappyWrap237 = HappyWrap237 ([LHsCmdTop GhcPs]) +happyIn237 :: ([LHsCmdTop GhcPs]) -> (HappyAbsSyn ) +happyIn237 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap237 x) +{-# INLINE happyIn237 #-} +happyOut237 :: (HappyAbsSyn ) -> HappyWrap237 +happyOut237 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut237 #-} +newtype HappyWrap238 = HappyWrap238 (LHsCmdTop GhcPs) +happyIn238 :: (LHsCmdTop GhcPs) -> (HappyAbsSyn ) +happyIn238 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap238 x) +{-# INLINE happyIn238 #-} +happyOut238 :: (HappyAbsSyn ) -> HappyWrap238 +happyOut238 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut238 #-} +newtype HappyWrap239 = HappyWrap239 (((EpToken "{", EpToken "}"),[LHsDecl GhcPs])) +happyIn239 :: (((EpToken "{", EpToken "}"),[LHsDecl GhcPs])) -> (HappyAbsSyn ) +happyIn239 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap239 x) +{-# INLINE happyIn239 #-} +happyOut239 :: (HappyAbsSyn ) -> HappyWrap239 +happyOut239 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut239 #-} +newtype HappyWrap240 = HappyWrap240 ([LHsDecl GhcPs]) +happyIn240 :: ([LHsDecl GhcPs]) -> (HappyAbsSyn ) +happyIn240 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap240 x) +{-# INLINE happyIn240 #-} +happyOut240 :: (HappyAbsSyn ) -> HappyWrap240 +happyOut240 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut240 #-} +newtype HappyWrap241 = HappyWrap241 (ECP) +happyIn241 :: (ECP) -> (HappyAbsSyn ) +happyIn241 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap241 x) +{-# INLINE happyIn241 #-} +happyOut241 :: (HappyAbsSyn ) -> HappyWrap241 +happyOut241 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut241 #-} +newtype HappyWrap242 = HappyWrap242 (forall b. DisambECP b => PV (SumOrTuple b)) +happyIn242 :: (forall b. DisambECP b => PV (SumOrTuple b)) -> (HappyAbsSyn ) +happyIn242 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap242 x) +{-# INLINE happyIn242 #-} +happyOut242 :: (HappyAbsSyn ) -> HappyWrap242 +happyOut242 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut242 #-} +newtype HappyWrap243 = HappyWrap243 (forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn Bool) (LocatedA b)])) +happyIn243 :: (forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn Bool) (LocatedA b)])) -> (HappyAbsSyn ) +happyIn243 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap243 x) +{-# INLINE happyIn243 #-} +happyOut243 :: (HappyAbsSyn ) -> HappyWrap243 +happyOut243 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut243 #-} +newtype HappyWrap244 = HappyWrap244 (forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)]) +happyIn244 :: (forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)]) -> (HappyAbsSyn ) +happyIn244 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap244 x) +{-# INLINE happyIn244 #-} +happyOut244 :: (HappyAbsSyn ) -> HappyWrap244 +happyOut244 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut244 #-} +newtype HappyWrap245 = HappyWrap245 (forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (LocatedA b)) +happyIn245 :: (forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (LocatedA b)) -> (HappyAbsSyn ) +happyIn245 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap245 x) +{-# INLINE happyIn245 #-} +happyOut245 :: (HappyAbsSyn ) -> HappyWrap245 +happyOut245 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut245 #-} +newtype HappyWrap246 = HappyWrap246 (forall b. DisambECP b => PV [LocatedA b]) +happyIn246 :: (forall b. DisambECP b => PV [LocatedA b]) -> (HappyAbsSyn ) +happyIn246 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap246 x) +{-# INLINE happyIn246 #-} +happyOut246 :: (HappyAbsSyn ) -> HappyWrap246 +happyOut246 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut246 #-} +newtype HappyWrap247 = HappyWrap247 (Located [LStmt GhcPs (LHsExpr GhcPs)]) +happyIn247 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) +happyIn247 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap247 x) +{-# INLINE happyIn247 #-} +happyOut247 :: (HappyAbsSyn ) -> HappyWrap247 +happyOut247 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut247 #-} +newtype HappyWrap248 = HappyWrap248 (Located (NonEmpty [LStmt GhcPs (LHsExpr GhcPs)])) +happyIn248 :: (Located (NonEmpty [LStmt GhcPs (LHsExpr GhcPs)])) -> (HappyAbsSyn ) +happyIn248 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap248 x) +{-# INLINE happyIn248 #-} +happyOut248 :: (HappyAbsSyn ) -> HappyWrap248 +happyOut248 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut248 #-} +newtype HappyWrap249 = HappyWrap249 (Located (NonEmpty (LStmt GhcPs (LHsExpr GhcPs)))) +happyIn249 :: (Located (NonEmpty (LStmt GhcPs (LHsExpr GhcPs)))) -> (HappyAbsSyn ) +happyIn249 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap249 x) +{-# INLINE happyIn249 #-} +happyOut249 :: (HappyAbsSyn ) -> HappyWrap249 +happyOut249 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut249 #-} +newtype HappyWrap250 = HappyWrap250 (Located ([LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) +happyIn250 :: (Located ([LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) +happyIn250 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap250 x) +{-# INLINE happyIn250 #-} +happyOut250 :: (HappyAbsSyn ) -> HappyWrap250 +happyOut250 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut250 #-} +newtype HappyWrap251 = HappyWrap251 (Located [LStmt GhcPs (LHsExpr GhcPs)]) +happyIn251 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) +happyIn251 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap251 x) +{-# INLINE happyIn251 #-} +happyOut251 :: (HappyAbsSyn ) -> HappyWrap251 +happyOut251 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut251 #-} +newtype HappyWrap252 = HappyWrap252 (Located [LStmt GhcPs (LHsExpr GhcPs)]) +happyIn252 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) +happyIn252 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap252 x) +{-# INLINE happyIn252 #-} +happyOut252 :: (HappyAbsSyn ) -> HappyWrap252 +happyOut252 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut252 #-} +newtype HappyWrap253 = HappyWrap253 (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b)))) +happyIn253 :: (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b)))) -> (HappyAbsSyn ) +happyIn253 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap253 x) +{-# INLINE happyIn253 #-} +happyOut253 :: (HappyAbsSyn ) -> HappyWrap253 +happyOut253 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut253 #-} +newtype HappyWrap254 = HappyWrap254 (forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b))))) +happyIn254 :: (forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b))))) -> (HappyAbsSyn ) +happyIn254 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap254 x) +{-# INLINE happyIn254 #-} +happyOut254 :: (HappyAbsSyn ) -> HappyWrap254 +happyOut254 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut254 #-} +newtype HappyWrap255 = HappyWrap255 (forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b))))) +happyIn255 :: (forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b))))) -> (HappyAbsSyn ) +happyIn255 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap255 x) +{-# INLINE happyIn255 #-} +happyOut255 :: (HappyAbsSyn ) -> HappyWrap255 +happyOut255 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut255 #-} +newtype HappyWrap256 = HappyWrap256 (Located ((EpToken "{", EpToken "}"), NonEmpty (LGRHS GhcPs (LHsExpr GhcPs)))) +happyIn256 :: (Located ((EpToken "{", EpToken "}"), NonEmpty (LGRHS GhcPs (LHsExpr GhcPs)))) -> (HappyAbsSyn ) +happyIn256 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap256 x) +{-# INLINE happyIn256 #-} +happyOut256 :: (HappyAbsSyn ) -> HappyWrap256 +happyOut256 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut256 #-} +newtype HappyWrap257 = HappyWrap257 (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b))) +happyIn257 :: (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b))) -> (HappyAbsSyn ) +happyIn257 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap257 x) +{-# INLINE happyIn257 #-} +happyOut257 :: (HappyAbsSyn ) -> HappyWrap257 +happyOut257 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut257 #-} +newtype HappyWrap258 = HappyWrap258 (LPat GhcPs) +happyIn258 :: (LPat GhcPs) -> (HappyAbsSyn ) +happyIn258 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap258 x) +{-# INLINE happyIn258 #-} +happyOut258 :: (HappyAbsSyn ) -> HappyWrap258 +happyOut258 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut258 #-} +newtype HappyWrap259 = HappyWrap259 (LPat GhcPs) +happyIn259 :: (LPat GhcPs) -> (HappyAbsSyn ) +happyIn259 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap259 x) +{-# INLINE happyIn259 #-} +happyOut259 :: (HappyAbsSyn ) -> HappyWrap259 +happyOut259 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut259 #-} +newtype HappyWrap260 = HappyWrap260 ([LPat GhcPs]) +happyIn260 :: ([LPat GhcPs]) -> (HappyAbsSyn ) +happyIn260 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap260 x) +{-# INLINE happyIn260 #-} +happyOut260 :: (HappyAbsSyn ) -> HappyWrap260 +happyOut260 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut260 #-} +newtype HappyWrap261 = HappyWrap261 (LPat GhcPs) +happyIn261 :: (LPat GhcPs) -> (HappyAbsSyn ) +happyIn261 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap261 x) +{-# INLINE happyIn261 #-} +happyOut261 :: (HappyAbsSyn ) -> HappyWrap261 +happyOut261 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut261 #-} +newtype HappyWrap262 = HappyWrap262 (LPat GhcPs) +happyIn262 :: (LPat GhcPs) -> (HappyAbsSyn ) +happyIn262 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap262 x) +{-# INLINE happyIn262 #-} +happyOut262 :: (HappyAbsSyn ) -> HappyWrap262 +happyOut262 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut262 #-} +newtype HappyWrap263 = HappyWrap263 ([LPat GhcPs]) +happyIn263 :: ([LPat GhcPs]) -> (HappyAbsSyn ) +happyIn263 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap263 x) +{-# INLINE happyIn263 #-} +happyOut263 :: (HappyAbsSyn ) -> HappyWrap263 +happyOut263 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut263 #-} +newtype HappyWrap264 = HappyWrap264 (LPat GhcPs) +happyIn264 :: (LPat GhcPs) -> (HappyAbsSyn ) +happyIn264 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap264 x) +{-# INLINE happyIn264 #-} +happyOut264 :: (HappyAbsSyn ) -> HappyWrap264 +happyOut264 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut264 #-} +newtype HappyWrap265 = HappyWrap265 (forall b. DisambECP b => PV (LocatedLW [LocatedA (Stmt GhcPs (LocatedA b))])) +happyIn265 :: (forall b. DisambECP b => PV (LocatedLW [LocatedA (Stmt GhcPs (LocatedA b))])) -> (HappyAbsSyn ) +happyIn265 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap265 x) +{-# INLINE happyIn265 #-} +happyOut265 :: (HappyAbsSyn ) -> HappyWrap265 +happyOut265 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut265 #-} +newtype HappyWrap266 = HappyWrap266 (forall b. DisambECP b => PV (Located (OrdList (EpToken ";"),[LStmt GhcPs (LocatedA b)]))) +happyIn266 :: (forall b. DisambECP b => PV (Located (OrdList (EpToken ";"),[LStmt GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) +happyIn266 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap266 x) +{-# INLINE happyIn266 #-} +happyOut266 :: (HappyAbsSyn ) -> HappyWrap266 +happyOut266 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut266 #-} +newtype HappyWrap267 = HappyWrap267 (Maybe (LStmt GhcPs (LHsExpr GhcPs))) +happyIn267 :: (Maybe (LStmt GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) +happyIn267 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap267 x) +{-# INLINE happyIn267 #-} +happyOut267 :: (HappyAbsSyn ) -> HappyWrap267 +happyOut267 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut267 #-} +newtype HappyWrap268 = HappyWrap268 (LStmt GhcPs (LHsExpr GhcPs)) +happyIn268 :: (LStmt GhcPs (LHsExpr GhcPs)) -> (HappyAbsSyn ) +happyIn268 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap268 x) +{-# INLINE happyIn268 #-} +happyOut268 :: (HappyAbsSyn ) -> HappyWrap268 +happyOut268 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut268 #-} +newtype HappyWrap269 = HappyWrap269 (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) +happyIn269 :: (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -> (HappyAbsSyn ) +happyIn269 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap269 x) +{-# INLINE happyIn269 #-} +happyOut269 :: (HappyAbsSyn ) -> HappyWrap269 +happyOut269 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut269 #-} +newtype HappyWrap270 = HappyWrap270 (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) +happyIn270 :: (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -> (HappyAbsSyn ) +happyIn270 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap270 x) +{-# INLINE happyIn270 #-} +happyOut270 :: (HappyAbsSyn ) -> HappyWrap270 +happyOut270 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut270 #-} +newtype HappyWrap271 = HappyWrap271 (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) +happyIn271 :: (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -> (HappyAbsSyn ) +happyIn271 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap271 x) +{-# INLINE happyIn271 #-} +happyOut271 :: (HappyAbsSyn ) -> HappyWrap271 +happyOut271 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut271 #-} +newtype HappyWrap272 = HappyWrap272 (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) +happyIn272 :: (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -> (HappyAbsSyn ) +happyIn272 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap272 x) +{-# INLINE happyIn272 #-} +happyOut272 :: (HappyAbsSyn ) -> HappyWrap272 +happyOut272 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut272 #-} +newtype HappyWrap273 = HappyWrap273 (forall b. DisambECP b => PV (Fbind b)) +happyIn273 :: (forall b. DisambECP b => PV (Fbind b)) -> (HappyAbsSyn ) +happyIn273 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap273 x) +{-# INLINE happyIn273 #-} +happyOut273 :: (HappyAbsSyn ) -> HappyWrap273 +happyOut273 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut273 #-} +newtype HappyWrap274 = HappyWrap274 (Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]) +happyIn274 :: (Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]) -> (HappyAbsSyn ) +happyIn274 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap274 x) +{-# INLINE happyIn274 #-} +happyOut274 :: (HappyAbsSyn ) -> HappyWrap274 +happyOut274 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut274 #-} +newtype HappyWrap275 = HappyWrap275 (Located [LIPBind GhcPs]) +happyIn275 :: (Located [LIPBind GhcPs]) -> (HappyAbsSyn ) +happyIn275 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap275 x) +{-# INLINE happyIn275 #-} +happyOut275 :: (HappyAbsSyn ) -> HappyWrap275 +happyOut275 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut275 #-} +newtype HappyWrap276 = HappyWrap276 (LIPBind GhcPs) +happyIn276 :: (LIPBind GhcPs) -> (HappyAbsSyn ) +happyIn276 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap276 x) +{-# INLINE happyIn276 #-} +happyOut276 :: (HappyAbsSyn ) -> HappyWrap276 +happyOut276 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut276 #-} +newtype HappyWrap277 = HappyWrap277 (Located HsIPName) +happyIn277 :: (Located HsIPName) -> (HappyAbsSyn ) +happyIn277 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap277 x) +{-# INLINE happyIn277 #-} +happyOut277 :: (HappyAbsSyn ) -> HappyWrap277 +happyOut277 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut277 #-} +newtype HappyWrap278 = HappyWrap278 (Located (SourceText, FastString)) +happyIn278 :: (Located (SourceText, FastString)) -> (HappyAbsSyn ) +happyIn278 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap278 x) +{-# INLINE happyIn278 #-} +happyOut278 :: (HappyAbsSyn ) -> HappyWrap278 +happyOut278 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut278 #-} +newtype HappyWrap279 = HappyWrap279 (LBooleanFormula GhcPs) +happyIn279 :: (LBooleanFormula GhcPs) -> (HappyAbsSyn ) +happyIn279 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap279 x) +{-# INLINE happyIn279 #-} +happyOut279 :: (HappyAbsSyn ) -> HappyWrap279 +happyOut279 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut279 #-} +newtype HappyWrap280 = HappyWrap280 (LBooleanFormula GhcPs) +happyIn280 :: (LBooleanFormula GhcPs) -> (HappyAbsSyn ) +happyIn280 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap280 x) +{-# INLINE happyIn280 #-} +happyOut280 :: (HappyAbsSyn ) -> HappyWrap280 +happyOut280 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut280 #-} +newtype HappyWrap281 = HappyWrap281 (LBooleanFormula GhcPs) +happyIn281 :: (LBooleanFormula GhcPs) -> (HappyAbsSyn ) +happyIn281 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap281 x) +{-# INLINE happyIn281 #-} +happyOut281 :: (HappyAbsSyn ) -> HappyWrap281 +happyOut281 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut281 #-} +newtype HappyWrap282 = HappyWrap282 (NonEmpty (LBooleanFormula GhcPs)) +happyIn282 :: (NonEmpty (LBooleanFormula GhcPs)) -> (HappyAbsSyn ) +happyIn282 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap282 x) +{-# INLINE happyIn282 #-} +happyOut282 :: (HappyAbsSyn ) -> HappyWrap282 +happyOut282 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut282 #-} +newtype HappyWrap283 = HappyWrap283 (LBooleanFormula GhcPs) +happyIn283 :: (LBooleanFormula GhcPs) -> (HappyAbsSyn ) +happyIn283 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap283 x) +{-# INLINE happyIn283 #-} +happyOut283 :: (HappyAbsSyn ) -> HappyWrap283 +happyOut283 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut283 #-} +newtype HappyWrap284 = HappyWrap284 (Located [LocatedN RdrName]) +happyIn284 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn284 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap284 x) +{-# INLINE happyIn284 #-} +happyOut284 :: (HappyAbsSyn ) -> HappyWrap284 +happyOut284 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut284 #-} +newtype HappyWrap285 = HappyWrap285 (LocatedN RdrName) +happyIn285 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn285 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap285 x) +{-# INLINE happyIn285 #-} +happyOut285 :: (HappyAbsSyn ) -> HappyWrap285 +happyOut285 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut285 #-} +newtype HappyWrap286 = HappyWrap286 (LocatedN RdrName) +happyIn286 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn286 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap286 x) +{-# INLINE happyIn286 #-} +happyOut286 :: (HappyAbsSyn ) -> HappyWrap286 +happyOut286 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut286 #-} +newtype HappyWrap287 = HappyWrap287 (LocatedN RdrName) +happyIn287 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn287 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap287 x) +{-# INLINE happyIn287 #-} +happyOut287 :: (HappyAbsSyn ) -> HappyWrap287 +happyOut287 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut287 #-} +newtype HappyWrap288 = HappyWrap288 (LocatedN RdrName) +happyIn288 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn288 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap288 x) +{-# INLINE happyIn288 #-} +happyOut288 :: (HappyAbsSyn ) -> HappyWrap288 +happyOut288 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut288 #-} +newtype HappyWrap289 = HappyWrap289 (Located (NonEmpty (LocatedN RdrName))) +happyIn289 :: (Located (NonEmpty (LocatedN RdrName))) -> (HappyAbsSyn ) +happyIn289 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap289 x) +{-# INLINE happyIn289 #-} +happyOut289 :: (HappyAbsSyn ) -> HappyWrap289 +happyOut289 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut289 #-} +newtype HappyWrap290 = HappyWrap290 ([LocatedN RdrName]) +happyIn290 :: ([LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn290 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap290 x) +{-# INLINE happyIn290 #-} +happyOut290 :: (HappyAbsSyn ) -> HappyWrap290 +happyOut290 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut290 #-} +newtype HappyWrap291 = HappyWrap291 (LocatedN DataCon) +happyIn291 :: (LocatedN DataCon) -> (HappyAbsSyn ) +happyIn291 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap291 x) +{-# INLINE happyIn291 #-} +happyOut291 :: (HappyAbsSyn ) -> HappyWrap291 +happyOut291 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut291 #-} +newtype HappyWrap292 = HappyWrap292 (LocatedN RdrName) +happyIn292 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn292 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap292 x) +{-# INLINE happyIn292 #-} +happyOut292 :: (HappyAbsSyn ) -> HappyWrap292 +happyOut292 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut292 #-} +newtype HappyWrap293 = HappyWrap293 (LocatedN DataCon) +happyIn293 :: (LocatedN DataCon) -> (HappyAbsSyn ) +happyIn293 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap293 x) +{-# INLINE happyIn293 #-} +happyOut293 :: (HappyAbsSyn ) -> HappyWrap293 +happyOut293 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut293 #-} +newtype HappyWrap294 = HappyWrap294 (LocatedN RdrName) +happyIn294 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn294 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap294 x) +{-# INLINE happyIn294 #-} +happyOut294 :: (HappyAbsSyn ) -> HappyWrap294 +happyOut294 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut294 #-} +newtype HappyWrap295 = HappyWrap295 (LocatedN RdrName) +happyIn295 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn295 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap295 x) +{-# INLINE happyIn295 #-} +happyOut295 :: (HappyAbsSyn ) -> HappyWrap295 +happyOut295 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut295 #-} +newtype HappyWrap296 = HappyWrap296 (LocatedN RdrName) +happyIn296 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn296 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap296 x) +{-# INLINE happyIn296 #-} +happyOut296 :: (HappyAbsSyn ) -> HappyWrap296 +happyOut296 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut296 #-} +newtype HappyWrap297 = HappyWrap297 (LocatedN RdrName) +happyIn297 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn297 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap297 x) +{-# INLINE happyIn297 #-} +happyOut297 :: (HappyAbsSyn ) -> HappyWrap297 +happyOut297 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut297 #-} +newtype HappyWrap298 = HappyWrap298 (LocatedN RdrName) +happyIn298 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn298 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap298 x) +{-# INLINE happyIn298 #-} +happyOut298 :: (HappyAbsSyn ) -> HappyWrap298 +happyOut298 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut298 #-} +newtype HappyWrap299 = HappyWrap299 (LocatedN RdrName) +happyIn299 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn299 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap299 x) +{-# INLINE happyIn299 #-} +happyOut299 :: (HappyAbsSyn ) -> HappyWrap299 +happyOut299 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut299 #-} +newtype HappyWrap300 = HappyWrap300 (LocatedN RdrName) +happyIn300 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn300 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap300 x) +{-# INLINE happyIn300 #-} +happyOut300 :: (HappyAbsSyn ) -> HappyWrap300 +happyOut300 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut300 #-} +newtype HappyWrap301 = HappyWrap301 (LocatedN RdrName) +happyIn301 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn301 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap301 x) +{-# INLINE happyIn301 #-} +happyOut301 :: (HappyAbsSyn ) -> HappyWrap301 +happyOut301 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut301 #-} +newtype HappyWrap302 = HappyWrap302 (LocatedN RdrName) +happyIn302 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn302 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap302 x) +{-# INLINE happyIn302 #-} +happyOut302 :: (HappyAbsSyn ) -> HappyWrap302 +happyOut302 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut302 #-} +newtype HappyWrap303 = HappyWrap303 (LocatedN RdrName) +happyIn303 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn303 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap303 x) +{-# INLINE happyIn303 #-} +happyOut303 :: (HappyAbsSyn ) -> HappyWrap303 +happyOut303 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut303 #-} +newtype HappyWrap304 = HappyWrap304 (LocatedN RdrName) +happyIn304 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn304 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap304 x) +{-# INLINE happyIn304 #-} +happyOut304 :: (HappyAbsSyn ) -> HappyWrap304 +happyOut304 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut304 #-} +newtype HappyWrap305 = HappyWrap305 (LocatedN RdrName) +happyIn305 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn305 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap305 x) +{-# INLINE happyIn305 #-} +happyOut305 :: (HappyAbsSyn ) -> HappyWrap305 +happyOut305 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut305 #-} +newtype HappyWrap306 = HappyWrap306 (LocatedN RdrName) +happyIn306 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn306 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap306 x) +{-# INLINE happyIn306 #-} +happyOut306 :: (HappyAbsSyn ) -> HappyWrap306 +happyOut306 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut306 #-} +newtype HappyWrap307 = HappyWrap307 (LocatedN RdrName) +happyIn307 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn307 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap307 x) +{-# INLINE happyIn307 #-} +happyOut307 :: (HappyAbsSyn ) -> HappyWrap307 +happyOut307 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut307 #-} +newtype HappyWrap308 = HappyWrap308 (forall b. DisambInfixOp b => PV (LocatedN b)) +happyIn308 :: (forall b. DisambInfixOp b => PV (LocatedN b)) -> (HappyAbsSyn ) +happyIn308 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap308 x) +{-# INLINE happyIn308 #-} +happyOut308 :: (HappyAbsSyn ) -> HappyWrap308 +happyOut308 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut308 #-} +newtype HappyWrap309 = HappyWrap309 (forall b. DisambInfixOp b => PV (LocatedN b)) +happyIn309 :: (forall b. DisambInfixOp b => PV (LocatedN b)) -> (HappyAbsSyn ) +happyIn309 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap309 x) +{-# INLINE happyIn309 #-} +happyOut309 :: (HappyAbsSyn ) -> HappyWrap309 +happyOut309 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut309 #-} +newtype HappyWrap310 = HappyWrap310 (LocatedN RdrName) +happyIn310 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn310 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap310 x) +{-# INLINE happyIn310 #-} +happyOut310 :: (HappyAbsSyn ) -> HappyWrap310 +happyOut310 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut310 #-} +newtype HappyWrap311 = HappyWrap311 (LocatedN RdrName) +happyIn311 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn311 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap311 x) +{-# INLINE happyIn311 #-} +happyOut311 :: (HappyAbsSyn ) -> HappyWrap311 +happyOut311 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut311 #-} +newtype HappyWrap312 = HappyWrap312 (LocatedN RdrName) +happyIn312 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn312 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap312 x) +{-# INLINE happyIn312 #-} +happyOut312 :: (HappyAbsSyn ) -> HappyWrap312 +happyOut312 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut312 #-} +newtype HappyWrap313 = HappyWrap313 (LocatedN RdrName) +happyIn313 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn313 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap313 x) +{-# INLINE happyIn313 #-} +happyOut313 :: (HappyAbsSyn ) -> HappyWrap313 +happyOut313 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut313 #-} +newtype HappyWrap314 = HappyWrap314 (LocatedN RdrName) +happyIn314 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn314 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap314 x) +{-# INLINE happyIn314 #-} +happyOut314 :: (HappyAbsSyn ) -> HappyWrap314 +happyOut314 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut314 #-} +newtype HappyWrap315 = HappyWrap315 (LocatedN RdrName) +happyIn315 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn315 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap315 x) +{-# INLINE happyIn315 #-} +happyOut315 :: (HappyAbsSyn ) -> HappyWrap315 +happyOut315 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut315 #-} +newtype HappyWrap316 = HappyWrap316 (LocatedN RdrName) +happyIn316 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn316 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap316 x) +{-# INLINE happyIn316 #-} +happyOut316 :: (HappyAbsSyn ) -> HappyWrap316 +happyOut316 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut316 #-} +newtype HappyWrap317 = HappyWrap317 (LocatedN RdrName) +happyIn317 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn317 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap317 x) +{-# INLINE happyIn317 #-} +happyOut317 :: (HappyAbsSyn ) -> HappyWrap317 +happyOut317 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut317 #-} +newtype HappyWrap318 = HappyWrap318 (LocatedN FieldLabelString) +happyIn318 :: (LocatedN FieldLabelString) -> (HappyAbsSyn ) +happyIn318 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap318 x) +{-# INLINE happyIn318 #-} +happyOut318 :: (HappyAbsSyn ) -> HappyWrap318 +happyOut318 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut318 #-} +newtype HappyWrap319 = HappyWrap319 (LocatedN RdrName) +happyIn319 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn319 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap319 x) +{-# INLINE happyIn319 #-} +happyOut319 :: (HappyAbsSyn ) -> HappyWrap319 +happyOut319 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut319 #-} +newtype HappyWrap320 = HappyWrap320 (LocatedN RdrName) +happyIn320 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn320 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap320 x) +{-# INLINE happyIn320 #-} +happyOut320 :: (HappyAbsSyn ) -> HappyWrap320 +happyOut320 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut320 #-} +newtype HappyWrap321 = HappyWrap321 (LocatedN RdrName) +happyIn321 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn321 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap321 x) +{-# INLINE happyIn321 #-} +happyOut321 :: (HappyAbsSyn ) -> HappyWrap321 +happyOut321 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut321 #-} +newtype HappyWrap322 = HappyWrap322 (LocatedN RdrName) +happyIn322 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn322 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap322 x) +{-# INLINE happyIn322 #-} +happyOut322 :: (HappyAbsSyn ) -> HappyWrap322 +happyOut322 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut322 #-} +newtype HappyWrap323 = HappyWrap323 (LocatedN RdrName) +happyIn323 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn323 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap323 x) +{-# INLINE happyIn323 #-} +happyOut323 :: (HappyAbsSyn ) -> HappyWrap323 +happyOut323 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut323 #-} +newtype HappyWrap324 = HappyWrap324 (LocatedN RdrName) +happyIn324 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn324 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap324 x) +{-# INLINE happyIn324 #-} +happyOut324 :: (HappyAbsSyn ) -> HappyWrap324 +happyOut324 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut324 #-} +newtype HappyWrap325 = HappyWrap325 (LocatedN RdrName) +happyIn325 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn325 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap325 x) +{-# INLINE happyIn325 #-} +happyOut325 :: (HappyAbsSyn ) -> HappyWrap325 +happyOut325 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut325 #-} +newtype HappyWrap326 = HappyWrap326 (Located FastString) +happyIn326 :: (Located FastString) -> (HappyAbsSyn ) +happyIn326 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap326 x) +{-# INLINE happyIn326 #-} +happyOut326 :: (HappyAbsSyn ) -> HappyWrap326 +happyOut326 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut326 #-} +newtype HappyWrap327 = HappyWrap327 (Located FastString) +happyIn327 :: (Located FastString) -> (HappyAbsSyn ) +happyIn327 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap327 x) +{-# INLINE happyIn327 #-} +happyOut327 :: (HappyAbsSyn ) -> HappyWrap327 +happyOut327 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut327 #-} +newtype HappyWrap328 = HappyWrap328 (LocatedN RdrName) +happyIn328 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn328 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap328 x) +{-# INLINE happyIn328 #-} +happyOut328 :: (HappyAbsSyn ) -> HappyWrap328 +happyOut328 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut328 #-} +newtype HappyWrap329 = HappyWrap329 (LocatedN RdrName) +happyIn329 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn329 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap329 x) +{-# INLINE happyIn329 #-} +happyOut329 :: (HappyAbsSyn ) -> HappyWrap329 +happyOut329 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut329 #-} +newtype HappyWrap330 = HappyWrap330 (LocatedN RdrName) +happyIn330 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn330 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap330 x) +{-# INLINE happyIn330 #-} +happyOut330 :: (HappyAbsSyn ) -> HappyWrap330 +happyOut330 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut330 #-} +newtype HappyWrap331 = HappyWrap331 (LocatedN RdrName) +happyIn331 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn331 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap331 x) +{-# INLINE happyIn331 #-} +happyOut331 :: (HappyAbsSyn ) -> HappyWrap331 +happyOut331 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut331 #-} +newtype HappyWrap332 = HappyWrap332 (Located (HsLit GhcPs)) +happyIn332 :: (Located (HsLit GhcPs)) -> (HappyAbsSyn ) +happyIn332 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap332 x) +{-# INLINE happyIn332 #-} +happyOut332 :: (HappyAbsSyn ) -> HappyWrap332 +happyOut332 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut332 #-} +newtype HappyWrap333 = HappyWrap333 (()) +happyIn333 :: (()) -> (HappyAbsSyn ) +happyIn333 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap333 x) +{-# INLINE happyIn333 #-} +happyOut333 :: (HappyAbsSyn ) -> HappyWrap333 +happyOut333 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut333 #-} +newtype HappyWrap334 = HappyWrap334 (LocatedA ModuleName) +happyIn334 :: (LocatedA ModuleName) -> (HappyAbsSyn ) +happyIn334 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap334 x) +{-# INLINE happyIn334 #-} +happyOut334 :: (HappyAbsSyn ) -> HappyWrap334 +happyOut334 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut334 #-} +newtype HappyWrap335 = HappyWrap335 ((NonEmpty SrcSpan,Int)) +happyIn335 :: ((NonEmpty SrcSpan,Int)) -> (HappyAbsSyn ) +happyIn335 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap335 x) +{-# INLINE happyIn335 #-} +happyOut335 :: (HappyAbsSyn ) -> HappyWrap335 +happyOut335 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut335 #-} +newtype HappyWrap336 = HappyWrap336 (([EpToken "|"],Int)) +happyIn336 :: (([EpToken "|"],Int)) -> (HappyAbsSyn ) +happyIn336 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap336 x) +{-# INLINE happyIn336 #-} +happyOut336 :: (HappyAbsSyn ) -> HappyWrap336 +happyOut336 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut336 #-} +newtype HappyWrap337 = HappyWrap337 (([EpToken "|"],Int)) +happyIn337 :: (([EpToken "|"],Int)) -> (HappyAbsSyn ) +happyIn337 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap337 x) +{-# INLINE happyIn337 #-} +happyOut337 :: (HappyAbsSyn ) -> HappyWrap337 +happyOut337 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut337 #-} +newtype HappyWrap338 = HappyWrap338 (forall b. DisambECP b => PV (LocatedLW [LMatch GhcPs (LocatedA b)])) +happyIn338 :: (forall b. DisambECP b => PV (LocatedLW [LMatch GhcPs (LocatedA b)])) -> (HappyAbsSyn ) +happyIn338 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap338 x) +{-# INLINE happyIn338 #-} +happyOut338 :: (HappyAbsSyn ) -> HappyWrap338 +happyOut338 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut338 #-} +newtype HappyWrap339 = HappyWrap339 (forall b. DisambECP b => PV (LocatedLW [LMatch GhcPs (LocatedA b)])) +happyIn339 :: (forall b. DisambECP b => PV (LocatedLW [LMatch GhcPs (LocatedA b)])) -> (HappyAbsSyn ) +happyIn339 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap339 x) +{-# INLINE happyIn339 #-} +happyOut339 :: (HappyAbsSyn ) -> HappyWrap339 +happyOut339 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut339 #-} +newtype HappyWrap340 = HappyWrap340 (ECP) +happyIn340 :: (ECP) -> (HappyAbsSyn ) +happyIn340 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap340 x) +{-# INLINE happyIn340 #-} +happyOut340 :: (HappyAbsSyn ) -> HappyWrap340 +happyOut340 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut340 #-} +newtype HappyWrap341 = HappyWrap341 (ECP) +happyIn341 :: (ECP) -> (HappyAbsSyn ) +happyIn341 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap341 x) +{-# INLINE happyIn341 #-} +happyOut341 :: (HappyAbsSyn ) -> HappyWrap341 +happyOut341 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut341 #-} +newtype HappyWrap342 = HappyWrap342 (ECP) +happyIn342 :: (ECP) -> (HappyAbsSyn ) +happyIn342 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap342 x) +{-# INLINE happyIn342 #-} +happyOut342 :: (HappyAbsSyn ) -> HappyWrap342 +happyOut342 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut342 #-} +newtype HappyWrap343 = HappyWrap343 (Located (NonEmpty (LPat GhcPs))) +happyIn343 :: (Located (NonEmpty (LPat GhcPs))) -> (HappyAbsSyn ) +happyIn343 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap343 x) +{-# INLINE happyIn343 #-} +happyOut343 :: (HappyAbsSyn ) -> HappyWrap343 +happyOut343 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut343 #-} +newtype HappyWrap344 = HappyWrap344 (Located (NonEmpty (LPat GhcPs))) +happyIn344 :: (Located (NonEmpty (LPat GhcPs))) -> (HappyAbsSyn ) +happyIn344 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap344 x) +{-# INLINE happyIn344 #-} +happyOut344 :: (HappyAbsSyn ) -> HappyWrap344 +happyOut344 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut344 #-} +newtype HappyWrap345 = HappyWrap345 (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) +happyIn345 :: (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) +happyIn345 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap345 x) +{-# INLINE happyIn345 #-} +happyOut345 :: (HappyAbsSyn ) -> HappyWrap345 +happyOut345 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut345 #-} +newtype HappyWrap346 = HappyWrap346 (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) +happyIn346 :: (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) +happyIn346 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap346 x) +{-# INLINE happyIn346 #-} +happyOut346 :: (HappyAbsSyn ) -> HappyWrap346 +happyOut346 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut346 #-} +newtype HappyWrap347 = HappyWrap347 (ECP) +happyIn347 :: (ECP) -> (HappyAbsSyn ) +happyIn347 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap347 x) +{-# INLINE happyIn347 #-} +happyOut347 :: (HappyAbsSyn ) -> HappyWrap347 +happyOut347 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut347 #-} +newtype HappyWrap348 = HappyWrap348 (ECP) +happyIn348 :: (ECP) -> (HappyAbsSyn ) +happyIn348 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap348 x) +{-# INLINE happyIn348 #-} +happyOut348 :: (HappyAbsSyn ) -> HappyWrap348 +happyOut348 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut348 #-} +newtype HappyWrap349 = HappyWrap349 (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) +happyIn349 :: (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) +happyIn349 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap349 x) +{-# INLINE happyIn349 #-} +happyOut349 :: (HappyAbsSyn ) -> HappyWrap349 +happyOut349 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut349 #-} +newtype HappyWrap350 = HappyWrap350 (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) +happyIn350 :: (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) +happyIn350 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap350 x) +{-# INLINE happyIn350 #-} +happyOut350 :: (HappyAbsSyn ) -> HappyWrap350 +happyOut350 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut350 #-} +newtype HappyWrap351 = HappyWrap351 (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) +happyIn351 :: (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -> (HappyAbsSyn ) +happyIn351 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap351 x) +{-# INLINE happyIn351 #-} +happyOut351 :: (HappyAbsSyn ) -> HappyWrap351 +happyOut351 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut351 #-} +newtype HappyWrap352 = HappyWrap352 (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) +happyIn352 :: (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -> (HappyAbsSyn ) +happyIn352 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap352 x) +{-# INLINE happyIn352 #-} +happyOut352 :: (HappyAbsSyn ) -> HappyWrap352 +happyOut352 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut352 #-} +happyInTok :: ((Located Token)) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> ((Located Token)) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyExpList :: HappyAddr +happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x1f\xff\x81\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x37\x5f\xe5\xff\x2f\xff\xbf\x67\x10\x04\x78\x00\xa1\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x8a\xff\x5f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x14\xff\xbf\xf8\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\xb9\x08\xfe\x7f\xf9\xff\x09\x82\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe3\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x10\x10\x11\x02\x54\xd0\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x7a\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x01\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x08\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x14\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x00\x40\x10\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x16\x40\x54\xe0\x0c\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\xff\x00\x00\x00\x00\x2c\x80\xa8\xc0\x19\x78\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0b\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc4\x85\x10\x1d\xfe\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x82\x0b\x21\x6a\xfc\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x00\x00\x00\xc0\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x20\x00\x22\x04\xa8\xa0\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\xaa\x70\x86\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x20\x22\x04\x40\x10\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xc1\xff\x27\xfc\x03\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x10\x3f\x00\x00\x31\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x28\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfc\xff\xc2\x3f\x00\x00\x40\x00\x07\x08\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x17\xff\x81\x00\x00\x12\x3c\x00\x51\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x60\x01\x44\x05\xce\xc0\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x04\xff\xbf\xf0\x0f\x00\x00\x10\xc0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfc\xff\xc2\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf0\xff\x0b\xff\x00\x00\x00\x07\x1c\x20\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xff\x01\x00\x00\x02\x38\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc1\xff\x2f\xfc\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x82\xff\x5f\xf8\x07\x00\x00\x08\xe0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x04\xff\xbf\xf0\x0f\x00\x00\x10\xc0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\xa8\xfe\x7f\xf1\x1f\x08\x00\x24\xc0\x87\x00\x57\xfc\xff\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfd\xff\xe2\x3f\x10\x00\x48\x8a\x0f\x03\xba\xfc\xff\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xfa\xff\xc5\x7f\x20\x00\x90\x04\x1f\x02\xd4\xf9\xff\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf0\xff\x0b\xff\x00\x00\x00\x01\x1c\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x80\xe0\xff\x13\xfe\x01\x00\x00\x00\x00\x00\x50\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xff\x01\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x14\xff\xbf\xf8\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x55\x38\xc3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7c\xc2\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x88\x10\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x01\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x00\x54\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xea\xff\x17\xff\x81\x00\x40\x52\x7c\x18\xd0\xe5\xff\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x20\x42\x00\x00\x62\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x22\x10\x82\xff\x4f\xf8\x07\x30\x00\x01\x70\x21\x44\x05\xff\xc3\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x15\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x90\xe2\xff\x13\xfe\x01\x00\x00\x00\x00\x00\x50\x01\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x03\x00\x00\x00\xb0\x00\xa2\x02\x67\xe0\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\x22\xf8\xff\xc5\x7f\x00\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\xa8\x80\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xfe\x01\x00\x00\x02\x38\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\x22\xf8\xff\x85\x7f\x00\x00\x80\x00\x0e\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x44\x08\x80\x20\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x40\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x40\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x80\x00\x00\x00\x41\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\xa2\x9f\x4f\xf8\x07\x30\x00\x01\x70\x21\x44\x05\xff\xc3\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\x87\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe0\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\x22\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\xff\x00\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x26\x42\x04\x00\x62\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\xa8\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x20\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc1\xff\x2f\xfe\x03\x00\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd5\xff\x2f\xfe\x03\x01\x80\x04\xf8\x10\xa0\xcb\xff\xff\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\xaa\xff\x5f\xfc\x07\x02\x00\x49\xf0\x21\x40\x15\xff\xff\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x16\x40\x54\xe0\x0c\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc1\xff\x2f\xfe\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x00\x60\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x00\x80\x20\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x20\x20\x22\x04\xe8\x90\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x20\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\xa8\x80\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x5c\x04\xff\xbf\xfc\xff\x04\x41\x10\xe0\x01\x84\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\xb9\x08\xfe\x7f\xf9\xff\x09\x82\x20\xc0\x03\x08\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x88\x00\x01\x10\x84\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x11\x02\x00\x10\x33\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x3f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x8a\xff\x7f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\xa8\xfe\x7f\xf1\x1f\x08\x00\x24\xc0\x87\x00\x75\xfe\xff\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\x22\xf8\xff\x85\x7f\x00\x00\x80\x00\x0e\x10\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xfe\x01\x00\x00\x02\x38\x40\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x3f\x00\x00\x00\x00\x0b\x20\x2a\x70\x06\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xe1\x1f\x00\x00\x20\x80\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x10\x00\x00\x00\x20\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x03\x00\x00\x00\xb0\x00\xa2\x02\x67\xe0\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x28\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x74\xf8\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\x00\x80\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x40\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x84\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x00\x00\x04\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\xff\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe0\xe7\x13\xfe\x01\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x60\x01\x44\x05\xce\xc0\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x16\x40\x54\xe0\x0c\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf4\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x60\x01\x44\x05\xce\xc0\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xc1\xc1\x27\xfc\x03\x00\x00\x00\x00\x00\x00\x00\x06\x40\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf4\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x16\x40\x54\xe0\x0c\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\x20\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x7a\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xe1\x1f\x00\x00\x20\x80\x03\x24\x55\x39\xf3\xff\xff\x7f\x7d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfc\xff\xc2\x3f\x00\x00\x40\x00\x07\x08\xab\x72\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa9\xca\x99\xff\xff\xff\xeb\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x17\xff\x81\x00\x00\x02\x3c\x00\x58\x95\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x54\xff\xbf\xf8\x0f\x04\x00\x12\xe0\x43\x80\x2a\xfe\xff\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfd\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xe2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf5\xff\x8b\xff\x40\x00\x20\x01\x3e\x04\xa8\xe2\xff\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfd\xff\xe2\x3f\x10\x00\x48\x80\x0f\x01\xaa\xfc\xff\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xfe\x01\x00\x00\x02\x38\x00\x50\x8d\x33\xff\xff\xff\xd7\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x9b\xaf\xf2\xff\x97\xff\xdf\x33\x08\x02\x3c\x80\x50\x85\x33\xff\xff\xff\xd7\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x80\x88\x10\x00\x80\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x44\x08\x00\x40\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xff\x01\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xc1\xff\x27\xfc\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\x22\xf8\xff\xc5\x7f\x00\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x80\x0a\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x15\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x88\x10\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x30\x11\x22\x00\x10\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc1\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\xa2\xff\x5f\xfc\x07\x00\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x0f\x00\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xe1\x1f\x00\x00\x20\x80\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xfa\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf5\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xea\xff\x17\xff\x81\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\xaa\xff\x5f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x0f\x00\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x8a\xff\x5f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\x87\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x7a\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf4\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x01\x02\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x00\x00\x04\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x00\x10\x40\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x04\x10\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf4\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x28\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x04\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x40\x05\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xe1\x1f\x00\x00\x20\x80\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x80\x00\x01\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x44\x08\x00\x40\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xe6\xab\xfc\xff\xe5\xff\xf7\x0c\x82\x00\x0f\x20\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x15\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x82\xff\x5f\xfc\x07\x00\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x04\x10\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\x00\x00\x00\x00\x00\x10\x04\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x7a\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x01\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\xff\x00\x00\x00\x00\x00\x80\x20\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\xa2\x9f\x4f\xf8\x07\x30\x00\x01\x70\x21\x44\x05\xff\xd3\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x03\x00\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x22\x04\x00\x20\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x11\x02\x00\x10\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x73\x11\xfc\xff\xf2\xff\x13\x04\x41\x80\x07\x10\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x28\xfe\xff\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x8a\xff\x5f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x28\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x39\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xe1\x1f\x00\x00\x20\x80\x03\x04\x55\x39\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x8a\xff\x5f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x14\xff\xbf\xf8\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf5\xff\x8b\xff\x40\x00\x20\x01\x3e\x04\xa8\xe2\xff\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x80\xe0\xff\x13\xfe\x01\x00\x20\x00\x00\x00\x40\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x7a\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x07\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xfe\x01\x00\x00\x02\x38\x40\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x17\xff\x81\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x71\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xe2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf5\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x22\x42\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\xa2\x9f\x4f\xf8\x07\x30\x00\x01\x70\x21\x44\x05\xff\xd3\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x3f\x00\x00\x00\x00\x00\x20\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x01\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x14\xff\xbf\xf8\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x73\x51\xfc\xff\xf2\xff\x13\x04\x41\x80\x07\x10\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\xe6\xa2\xf8\xff\xe5\xff\x27\x08\x82\x00\x0f\x20\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\xff\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\x20\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x20\x42\x00\x00\x62\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x29\xfe\x3f\xe9\x1f\x00\x00\x00\x00\x00\x00\x04\x30\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x15\x30\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x88\x10\x00\x00\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x17\xff\x81\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x17\xc1\xff\x2f\xff\x3f\x41\x10\x04\x78\x00\xa1\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x2e\x82\xff\x5f\xfe\x7f\x82\x20\x08\xf0\x00\x42\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x73\x55\xfc\xff\xf2\xff\x13\x04\x41\x80\x07\x10\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\xe6\xaa\xf8\xff\xe5\xff\x27\x08\x82\x00\x0f\x20\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xff\x01\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x08\xd1\xdf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x78\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x83\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x10\x5c\x08\x51\xe3\xff\xf4\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfd\xff\xe2\x3f\x10\x00\x48\x80\x0f\x01\xaa\xf8\xff\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\x70\xf0\x09\xff\x00\x00\x00\x00\x00\x00\x00\x80\x01\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x07\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x00\x18\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x82\xe0\x42\x88\x1a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xcd\x5c\x14\xff\xbf\xfc\xff\x04\x41\x10\xe0\x01\x84\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x78\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x44\x08\x00\x40\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x18\x00\x17\x42\x54\xf0\x3f\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x30\x00\x2e\x84\xa8\xe0\x7f\x78\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x80\xe0\xe7\x13\xfe\x01\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x22\x00\x8a\xff\x4f\xf8\x07\x00\x80\x00\x00\x00\x00\x01\xcc\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc5\x5c\x15\xff\xbf\xfc\xff\x04\x41\x10\xe0\x01\x84\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe0\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x17\xff\x81\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\xa2\x9f\x4f\xf8\x07\x30\x00\x01\x71\x21\x44\x87\xff\xd3\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x22\x00\x8a\xff\x4f\xf8\x07\x00\x80\x00\x00\x00\x00\x01\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xc1\xcf\x27\xfc\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\x1c\x7c\xc2\x3f\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x29\xfe\x3f\xe9\x1f\x00\x00\x00\x00\x00\x00\x04\x32\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x05\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x29\xfe\x3f\xe9\x1f\x00\x00\x00\x00\x00\x00\x04\x32\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x11\x20\xc5\xff\x27\xfd\x03\x00\x00\x00\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +{-# NOINLINE happyExpListPerState #-} +happyExpListPerState st = + token_strs_expected + where token_strs = ["error","%dummy","%start_parseModuleNoHaddock","%start_parseSignatureNoHaddock","%start_parseImport","%start_parseStatement","%start_parseDeclaration","%start_parseExpression","%start_parsePattern","%start_parseTypeSignature","%start_parseStmt","%start_parseIdentifier","%start_parseType","%start_parseBackpack","%start_parseHeader","identifier","backpack","units","unit","unitid","msubsts","msubst","moduleid","pkgname","litpkgname_segment","HYPHEN","litpkgname","mayberns","rns","rn","unitbody","unitdecls","unitdecl","signature","module","missing_module_keyword","implicit_top","body","body2","top","top1","header","header_body","header_body2","header_top","header_top_importdecls","maybeexports","exportlist","exportlist1","export_cs","export","export_subspec","qcnames","qcnames1","qcname_ext_w_wildcard","qcname_ext","qcname","semis1","semis","importdecls","importdecls_semi","importdecl","maybe_src","maybe_safe","maybe_splice","maybe_pkg","optqualified","maybeas","maybeimpspec","impspec","importlist","importlist1","import","prec","infix","ops","topdecls","topdecls_semi","topdecls_cs","topdecls_cs_semi","topdecl_cs","topdecl","cl_decl","default_decl","ty_decl","standalone_kind_sig","sks_vars","inst_decl","overlap_pragma","deriv_strategy_no_via","deriv_strategy_via","deriv_standalone_strategy","opt_class","opt_injective_info","injectivity_cond","inj_varids","where_type_family","ty_fam_inst_eqn_list","ty_fam_inst_eqns","ty_fam_inst_eqn","at_decl_cls","opt_family","opt_instance","at_decl_inst","type_data_or_newtype","data_or_newtype","opt_kind_sig","opt_datafam_kind_sig","opt_tyfam_kind_sig","opt_at_kind_inj_sig","tycl_hdr","datafam_inst_hdr","capi_ctype","stand_alone_deriving","role_annot","maybe_roles","roles","role","pattern_synonym_decl","pattern_synonym_lhs","vars0","cvars1","where_decls","pattern_synonym_sig","qvarcon","decl_cls","decls_cls","decllist_cls","where_cls","decl_inst","decls_inst","decllist_inst","where_inst","decls","decllist","binds","wherebinds","rules","rule","rule_activation","rule_activation_marker","rule_explicit_activation","rule_foralls","rule_vars","rule_var","maybe_warning_pragma","warning_category","warnings","warning","namespace_spec","deprecations","deprecation","strings","stringlist","annotation","fdecl","callconv","safety","fspec","opt_sig","opt_tyconsig","sigktype","sigtype","sig_vars","sigtypes1","unpackedness","forall_telescope","ktype","ctype","context","expcontext","type","mult","expmult","btype","infixtype","ftype","tyarg","tyop","atype","inst_type","deriv_types","comma_types0","comma_types1","bar_types2","tv_bndrs","tv_bndr","tv_bndr_no_braces","tyvar_wc","fds","fds1","fd","varids0","kind","gadt_constrlist","gadt_constrs","gadt_constr","constrs","constrs1","constr","forall","constr_stuff","usum_constr","fielddecls","fielddecls1","fielddecl","maybe_derivings","derivings","deriving","deriv_clause_types","decl_no_th","decl","rhs","gdrhs","gdrh","sigdecl","sigtypes_maybe","activation","explicit_activation","quasiquote","exp","exp2","infixexp2","infixexp","exp10p","exp10","optSemi","prag_e","fexp","aexp","aexp1","aexp2","projection","splice_exp","splice_untyped","splice_typed","cmdargs","acmd","cvtopbody","cvtopdecls0","texp","tup_exprs","commas_tup_tail","tup_tail","list","lexps","flattenedpquals","pquals","squals","transformqual","guardquals","guardquals1","alt_rhs","ralt","gdpats","ifgdpats","gdpat","pat_syn_pat","pat","pats1","bindpat","argpat","argpats","apat","stmtlist","stmts","maybe_stmt","e_stmt","stmt","qual","fbinds","fbinds1","fbind","fieldToUpdate","dbinds","dbind","ipvar","overloaded_label","name_boolformula_opt","name_boolformula","name_boolformula_and","name_boolformula_and_list","name_boolformula_atom","namelist","name_var","qcon","gen_qcon","con","con_list","qcon_list","sysdcon_nolist","syscon","sysdcon","conop","qconop","gtycon","ntgtycon","oqtycon","oqtycon_no_varcon","qtyconop","qtycon","tycon","qtyconsym","tyconsym","otycon","op","varop","qop","qopm","hole_op","qvarop","qvaropm","tyvar","tyvarop","tyvarid","var","qvar","field","qvarid","varid","qvarsym","qvarsym_no_minus","qvarsym1","varsym","varsym_no_minus","special_id","special_sym","qconid","conid","qconsym","consym","literal","close","modid","commas","bars0","bars","altslist__argpats__","altslist__pats1__","exp_gen__infixexp__","exp_gen__infixexp2__","exp_prag__exp10p__","orpats__exp__","orpats__exp2__","alts__argpats__","alts__pats1__","exp_prag__exp_gen__infixexp2____","exp_prag__exp_gen__infixexp____","alts1__argpats__","alts1__pats1__","alt__argpats__","alt__pats1__","'_'","'as'","'case'","'class'","'data'","'default'","'deriving'","'else'","'hiding'","'if'","'import'","'in'","'infix'","'infixl'","'infixr'","'instance'","'let'","'module'","'newtype'","'of'","'qualified'","'then'","'type'","'where'","'forall'","'foreign'","'export'","'label'","'dynamic'","'safe'","'interruptible'","'unsafe'","'family'","'role'","'stdcall'","'ccall'","'capi'","'prim'","'javascript'","'proc'","'rec'","'group'","'by'","'using'","'pattern'","'static'","'stock'","'anyclass'","'via'","'splice'","'quote'","'unit'","'signature'","'dependency'","'{-# INLINE'","'{-# OPAQUE'","'{-# SPECIALISE'","'{-# SPECIALISE_INLINE'","'{-# SOURCE'","'{-# RULES'","'{-# SCC'","'{-# DEPRECATED'","'{-# WARNING'","'{-# UNPACK'","'{-# NOUNPACK'","'{-# ANN'","'{-# MINIMAL'","'{-# CTYPE'","'{-# OVERLAPPING'","'{-# OVERLAPPABLE'","'{-# OVERLAPS'","'{-# INCOHERENT'","'{-# COMPLETE'","'#-}'","'..'","':'","'::'","'='","'\\\\'","'lcase'","'lcases'","'|'","'<-'","'->'","'->.'","TIGHT_INFIX_AT","'=>'","'-'","PREFIX_TILDE","PREFIX_BANG","PREFIX_MINUS","'*'","'-<'","'>-'","'-<<'","'>>-'","'.'","PREFIX_PROJ","TIGHT_INFIX_PROJ","PREFIX_AT","PREFIX_PERCENT","'{'","'}'","vocurly","vccurly","'['","']'","'('","')'","'(#'","'#)'","'(|'","'|)'","';'","','","'`'","SIMPLEQUOTE","VARID","CONID","VARSYM","CONSYM","QVARID","QCONID","QVARSYM","QCONSYM","DO","MDO","IPDUPVARID","LABELVARID","CHAR","STRING","STRING_MULTI","INTEGER","RATIONAL","PRIMCHAR","PRIMSTRING","PRIMINTEGER","PRIMWORD","PRIMINTEGER8","PRIMINTEGER16","PRIMINTEGER32","PRIMINTEGER64","PRIMWORD8","PRIMWORD16","PRIMWORD32","PRIMWORD64","PRIMFLOAT","PRIMDOUBLE","'[|'","'[p|'","'[t|'","'[d|'","'|]'","'[||'","'||]'","PREFIX_DOLLAR","PREFIX_DOLLAR_DOLLAR","TH_TY_QUOTE","TH_QUASIQUOTE","TH_QQUASIQUOTE","%eof"] + bit_start = st Prelude.* 513 + bit_end = (st Prelude.+ 1) Prelude.* 513 + read_bit = readArrayBit happyExpList + bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] + bits_indexed = Prelude.zip bits [0..512] + token_strs_expected = Prelude.concatMap f bits_indexed + f (Prelude.False, _) = [] + f (Prelude.True, nr) = [token_strs Prelude.!! nr] + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x25\x00\x1b\x00\xa6\x00\xf1\x35\xd1\x28\x31\x3c\x31\x3c\x71\x33\xf1\x35\x75\x6d\x7f\x55\xb6\x00\x47\x01\x70\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x02\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\xa3\x01\xa3\x01\x00\x00\xa7\x00\x0b\x02\x0b\x02\x55\x5b\x7f\x55\xda\x00\xf9\x01\x06\x02\x00\x00\x4e\x1a\x00\x00\x0a\x19\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x19\x00\x00\xc6\x17\x00\x00\x00\x00\x00\x00\x68\x18\x45\x75\x00\x00\x00\x00\x00\x00\x62\x01\x57\x02\x00\x00\x00\x00\xf3\x5d\xf3\x5d\x00\x00\x00\x00\x7e\x76\xe7\x53\xb9\x50\x41\x51\x06\x72\xde\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x4f\x00\x00\x00\x00\x15\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x02\x63\x08\x46\x03\x9c\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x02\xf0\x1a\x00\x00\x31\x3c\x92\x1b\x00\x00\xbd\x02\x00\x00\x00\x00\x00\x00\x7f\x02\x72\x02\x00\x00\x00\x00\x82\x16\x00\x00\x00\x00\xe8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x31\x3c\xb1\x34\xa5\x04\xf3\x5d\xf1\x4e\xf7\x04\xf1\x4e\xf6\x00\x11\x43\x11\x4d\xf1\x4e\xf1\x4e\xf1\x4e\x91\x31\x11\x2a\x31\x2d\xf1\x4e\x0c\x70\xf7\x04\xf7\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x3c\x31\x4b\x7f\x55\x08\x05\x31\x3c\x91\x4f\x24\x17\xc3\x02\x00\x00\x05\x03\x56\x09\x0d\x03\x16\x03\x00\x00\x00\x00\x00\x00\x20\x05\xe0\x03\x70\x70\x70\x72\xd1\x3c\xb1\x43\x70\x72\x74\x73\xdd\x02\x11\x2a\xa2\x01\x12\x03\x00\x00\x12\x03\x12\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x03\xbe\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x0d\x55\x5b\xea\x01\x79\x03\x65\x02\xae\x00\xca\x03\x4f\x52\x2a\x02\xd1\x73\x5d\x03\x2d\x00\x4e\x00\x17\x73\xf3\x5d\x73\x03\x00\x00\x73\x03\xb2\x03\x7a\x03\x30\x04\x7a\x03\x00\x00\x00\x00\x30\x04\x00\x00\xd9\x03\xbb\x03\xae\x00\x00\x00\x00\x00\x33\x00\xae\x00\xc7\x02\xe6\x03\x31\x4b\x38\x71\xf1\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x4e\xca\x01\xc2\x04\x6a\x01\x1e\x00\x00\x00\xf0\x03\x2e\x74\x9f\x00\x00\x00\x00\x00\x00\x00\x0c\x01\x00\x00\x51\x44\xa3\x03\x44\x76\x00\x04\x14\x01\x85\x02\x00\x00\x49\x06\x49\x06\xac\x00\x1b\x04\xe7\x02\x29\x01\x00\x00\xaf\x58\x55\x5b\xda\x02\xf1\x04\x04\x00\x75\x04\x00\x00\x9c\x04\x00\x00\x00\x00\x00\x00\x7f\x55\x45\x04\x00\x00\x55\x5b\x6b\x04\x80\x04\x00\x00\x64\x04\x00\x00\xf1\x44\x00\x00\x00\x00\x7f\x55\x45\x6e\x9f\x04\x55\x5b\x73\x04\x71\x3d\x91\x45\xb3\x04\x81\x04\xcb\x1c\x7d\x4f\x91\x36\x94\x02\x59\x01\xb0\x04\x00\x00\x31\x4b\x00\x00\x00\x00\x00\x00\xfc\x04\x0e\x05\x18\x05\x1e\x05\x71\x2e\x31\x32\x00\x00\x35\x05\x00\x00\xf3\x5d\x00\x00\x43\x05\x11\x4d\xd7\x77\x00\x00\x00\x00\x45\x6e\xad\x04\xc5\x04\xe7\x03\xce\x04\x00\x00\x6c\x05\x00\x00\x46\x05\x00\x00\xae\x72\xfc\xff\x31\x46\x00\x00\x3e\x01\x31\x46\x7f\x55\x86\x05\xd4\x70\x6b\x05\x00\x00\xdd\x05\xd1\x32\xd1\x32\x7e\x76\x7f\x55\x6a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x05\xb6\x06\xd1\x01\x00\x00\x00\x00\x5e\x05\x73\x05\x00\x00\x00\x00\x78\x05\x3b\x06\x7b\x05\x00\x00\x31\x37\x31\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x02\x95\x05\x00\x00\x00\x00\x11\x2f\x00\x00\xb0\x05\x77\x00\xc0\x05\xbb\x05\x00\x00\x00\x00\x00\x00\x00\x00\x34\x1c\x00\x00\xb1\x4d\xe6\x05\x00\x00\x5c\x05\x5f\x05\xf3\x5d\x02\x06\x1e\x06\x00\x00\x00\x00\x22\x06\x00\x00\x37\x06\x18\x06\x43\x00\x00\x00\x00\x00\x11\x3e\x54\x06\x87\x06\xf1\x4e\xb1\x3e\xd7\x77\x3b\x72\x00\x00\xf3\x5d\x00\x00\x7f\x55\xb1\x3e\xb1\x3e\xb1\x3e\xb1\x3e\x35\x06\x4f\x06\x5e\x04\x29\x06\x5c\x06\x11\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x55\xd7\x52\xd1\x71\x59\x06\x7c\x06\x78\x01\x61\x06\x75\x06\xb9\x04\xfa\x01\x00\x00\x68\x02\x31\x50\xef\x02\x72\x06\x00\x00\xdf\x02\x00\x00\x64\x01\xb1\x06\x00\x00\xa8\x06\x00\x00\xa4\x02\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x01\x45\x75\x00\x00\x00\x00\x00\x00\x00\x00\x46\x78\x6f\x28\x7f\x55\xf3\x5d\x00\x00\x55\x5b\x00\x00\xf3\x5d\xc9\x06\x7f\x55\x7f\x55\xf3\x5d\x7f\x55\x7f\x55\x00\x00\x00\x00\x53\x02\x00\x00\x3c\x61\x30\x00\x00\x00\xaf\x06\x33\x03\x33\x03\x00\x00\xc4\x06\xc4\x06\x00\x00\x00\x00\x1f\x07\x00\x00\x00\x00\x00\x00\x00\x00\x05\x07\x28\x07\x33\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x55\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x06\x1b\x01\x00\x00\x00\x00\x00\x00\xdb\x06\x7e\x76\x00\x00\x7f\x55\xf3\x5d\x7e\x76\x00\x00\x7f\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x55\x7f\x55\x00\x00\x00\x00\xdf\x06\xdc\x06\xee\x06\xf2\x06\x04\x07\x11\x07\x00\x00\x15\x07\x16\x07\x17\x07\xf3\x06\x1a\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x07\x00\x00\x1c\x07\x44\x07\x30\x07\x31\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x05\xdb\x01\x46\x07\x25\x07\x00\x00\x00\x00\x00\x00\x8c\x07\x00\x00\xb1\x3e\xb1\x3e\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x46\x77\x1d\x00\x00\x51\x35\xd6\x1c\xb1\x3e\x00\x00\x11\x34\x00\x00\xd1\x37\x71\x38\x11\x34\x00\x00\x2d\x07\x00\x00\x00\x00\x00\x00\xd1\x2d\x53\x07\x00\x00\x51\x4e\x4f\x00\x00\x00\xb0\x02\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x28\x33\x00\x3c\x07\x00\x00\x00\x00\x00\x00\x3d\x07\x00\x00\x00\x00\x7f\x05\x00\x00\x00\x00\x55\x01\x5b\x00\x00\x00\x00\x00\xfa\x0e\x00\x00\xb1\x2f\x51\x30\x67\x00\x00\x00\xf1\x30\xd1\x02\x55\x03\xe0\x03\x61\x07\x00\x00\x00\x00\x00\x00\x00\x00\x62\x07\x31\x4b\xb3\x76\x2b\x07\x00\x00\x00\x00\x42\x07\x31\x4b\x00\x00\x69\x07\x48\x07\x49\x07\x8b\x74\x8b\x74\x00\x00\x6a\x07\xab\x04\x92\x05\x4b\x07\x4f\x07\x00\x00\x00\x00\x00\x00\x00\x00\x67\x07\x54\x07\xfd\x04\x00\x00\x00\x00\xd7\x77\x00\x00\x7d\x4f\x00\x00\x6e\x07\x71\x47\x11\x48\x11\x48\xf1\x4e\x7f\x55\x11\x39\x11\x39\x11\x39\x11\x39\x11\x39\x11\x48\x00\x00\x00\x00\xfe\xff\x44\x04\x37\x59\xff\x04\x00\x00\x00\x00\xb1\x48\x00\x00\x00\x00\xc7\x00\x00\x00\xb1\x3e\x51\x3f\x55\x5b\xae\x07\x00\x00\x7b\x07\x7f\x55\x00\x00\x00\x00\x7f\x07\x67\x04\x04\x00\x88\x07\x55\x07\x00\x00\x7f\x55\x8d\x07\x8f\x07\x91\x07\x92\x07\x2b\x00\x90\x02\xf3\x04\x00\x00\x93\x07\x45\x75\x7f\x55\x7f\x55\xda\x02\x5e\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x60\xd7\x77\x00\x00\x66\x07\x7f\x55\x00\x00\xd7\x77\xf1\x76\xf1\x3f\xf1\x3f\x51\x49\x00\x00\x7a\x01\x00\x00\x5c\x07\x00\x00\xa9\x01\x04\x00\x6f\x07\x00\x00\x00\x00\x51\x00\xe8\x74\x00\x00\xf1\x4e\x9d\x01\x9d\x07\x9e\x07\xc8\x0f\x00\x00\xcd\x07\x00\x00\x00\x00\x80\x07\x00\x00\x80\x07\x00\x00\x00\x00\xe2\x07\x00\x00\x7d\x07\x00\x00\xd1\x28\xd8\x07\x14\x02\xd9\x07\xde\x07\x00\x00\x45\x05\x7f\x55\x00\x00\x00\x00\x89\x07\xab\x07\x04\x00\x00\x00\xe8\x74\x00\x00\x00\x00\x00\x00\xec\x01\x95\x07\x31\x4b\x00\x00\xe5\x07\x00\x00\x9a\x07\x87\x07\x00\x00\x00\x00\x8e\x07\x00\x00\xd1\x60\x00\x00\xb6\x07\xb7\x07\xb8\x07\xb9\x07\xf1\x76\xf1\x76\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x07\x7f\x55\xbe\x07\x7f\x55\x45\x75\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x07\x41\x03\x00\x00\x00\x00\xc1\x07\xf1\x04\x7f\x55\xa4\x07\x00\x00\x7f\x55\x9f\x07\x00\x00\x0c\x78\x00\x00\x80\x05\x00\x00\xc7\x07\xfe\x07\x00\x00\x00\x00\x8c\x05\x00\x00\x09\x05\xc0\x07\x00\x00\x45\x75\x00\x08\x12\x08\x7f\x55\x02\x08\x00\x00\xd4\x07\x00\x00\x93\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x49\x00\x00\x00\x00\xd5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x0f\x00\x00\xb4\x07\xcf\x07\x26\x77\x00\x00\xd7\x77\xe2\x0f\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x07\x00\x00\xd1\x32\xf1\x3f\x00\x00\x00\x00\x7f\x55\xc3\x07\x00\x00\x00\x00\x00\x00\x00\x00\x83\x75\x00\x00\x00\x00\xc2\x07\x00\x00\xb1\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x07\x00\x00\x00\x00\x00\x00\xbb\x01\x00\x00\x00\x00\x91\x40\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x33\x00\xc5\x07\x00\x00\x51\x3a\xd1\x07\x00\x00\x2c\x00\x00\x00\x33\x00\xce\x07\x00\x00\xd1\x4b\xd2\x07\x00\x00\x00\x00\x00\x00\x31\x41\xd1\x41\x71\x42\x00\x00\x00\x00\xd7\x77\x11\x34\x3b\x72\x00\x00\x00\x00\x7f\x55\x00\x00\x00\x00\xed\x07\x00\x00\xd6\x07\xdd\x07\x00\x00\xf4\x07\x00\x00\x00\x00\x00\x00\x7f\x55\x00\x00\x7f\x55\x00\x00\x38\x6d\x00\x00\x00\x00\x00\x00\xa2\x05\x00\x00\x34\x08\x35\x08\x1a\x06\x1a\x06\x00\x00\x3f\x00\x3f\x00\x00\x00\xe7\x07\xee\x07\x7f\x55\x00\x00\x00\x00\xea\x07\x00\x00\x00\x00\x56\x01\x00\x00\x00\x00\x00\x00\xe8\x07\x00\x00\x00\x00\x91\x4a\x00\x00\x00\x00\x44\x08\x0b\x08\x71\x42\x00\x00\x00\x00\x71\x42\x00\x00\x00\x00\x3c\x08\x71\x29\xf1\x3a\xf1\x3a\x91\x3b\x00\x00\xf6\x07\x00\x00\x7f\x05\x00\x00\x00\x00\x00\x00\x00\x00\x11\x08\x22\x08\x7f\x55\x23\x08\x00\x00\x56\x08\x00\x00\x29\x08\x00\x00\x00\x00\x27\x08\x00\x00\xdb\x5b\xbb\x75\x00\x00\x00\x00\x75\x08\x00\x00\x5f\x01\x75\x08\x1d\x06\x1c\x08\x61\x5c\x67\x08\x79\x08\x00\x00\x00\x00\x71\x42\x00\x00\xb1\x2a\xb1\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x55\x00\x00\x00\x00\x03\x08\x00\x00\x2a\x06\x00\x00\x00\x00\x00\x00\x6d\x08\x46\x78\x00\x00\x61\x5c\x3b\x08\x3e\x08\x7f\x55\x00\x00\x00\x00\x64\x77\x00\x00\x00\x00\x5e\x06\xc9\x03\x00\x00\x00\x00\x1e\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x08\x00\x00\x64\x06\x20\x08\x1f\x08\x00\x00\x00\x00\xf9\x6e\x00\x00\x64\x06\x25\x08\x00\x00\x26\x08\x00\x00\x26\x08\x00\x00\x00\x00\x00\x00\x2d\x08\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x70\x25\x05\x26\x05\xda\x02\x92\x05\x7c\x04\x87\x00\x00\x00\x00\x00\x26\x05\x00\x00\x00\x00\x71\x42\xd1\x32\xd1\x32\x00\x00\x00\x00\x7f\x55\x7f\x55\x43\x08\x00\x00\x41\x08\x00\x00\x76\x06\x00\x00\x51\x2b\x51\x2b\x00\x00\x00\x00\x00\x00\x46\x78\x00\x00\x00\x00\x8e\x00\x00\x00\x7a\x08\x71\x4c\x6f\x54\x5f\x03\x00\x00\x00\x00\x93\x08\x00\x00\x61\x5c\x80\x03\x80\x03\x00\x00\xea\x02\x6b\x08\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x54\x00\x00\x3d\x08\x46\x08\x00\x00\x49\x08\x00\x00\x41\x51\x89\x08\x00\x00\x99\x77\x7f\x55\x38\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x42\x71\x42\x71\x42\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x08\x11\x34\xd7\x77\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x01\x00\x00\x73\x08\x26\x05\x71\x61\x66\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x45\x08\x48\x08\xa6\x61\xa4\x05\x26\x05\x00\x00\x00\x00\x00\x00\x71\x42\x00\x00\x00\x00\x84\x08\x7f\x55\x4b\x08\x55\x08\x00\x00\xbc\x01\x4a\x08\x5f\x53\xe7\x5c\x00\x00\x47\x08\x4f\x08\x00\x00\x00\x00\x00\x00\x33\x00\x50\x08\xe0\x03\x5a\x08\x66\x08\x00\x00\x00\x00\x00\x00\xf1\x2b\x00\x00\xe7\x05\xbf\x59\x6d\x5d\x36\x10\x6d\x5d\x00\x00\x00\x00\x00\x00\xb3\x08\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\xb3\x08\x76\x03\x00\x00\x07\x56\x8f\x56\x46\x78\x17\x57\x00\x00\x00\x00\x5c\x01\x77\x03\x00\x00\xf3\x05\x00\x00\x58\x08\x64\x08\x65\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x6f\x33\x00\x60\x08\x00\x00\x00\x00\x68\x08\x61\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x08\x00\x00\x00\x00\x00\x00\x46\x78\x00\x00\x66\x01\x00\x00\x33\x00\xa1\x03\x70\x08\x00\x00\x91\x2c\xbf\x59\x00\x00\x00\x00\x99\x08\x91\x08\x17\x57\xf2\x05\x00\x00\x00\x00\x17\x57\x9f\x57\x00\x00\x6d\x5d\x00\x00\x94\x08\x80\x03\x00\x00\x00\x00\x27\x58\x00\x00\x00\x00\x90\x08\x00\x00\x9a\x08\x27\x58\x00\x00\x00\x00\x00\x00\x71\x42\x00\x00\x11\x06\x7f\x08\x00\x00\x26\x05\x00\x00\x26\x05\x00\x00\x01\x03\x00\x00\xeb\x08\xd8\x03\x00\x00\xf1\xff\xd6\x08\x83\x08\x00\x00\x00\x00\x00\x00\x00\x00\x27\x58\x00\x00\x9e\x08\x18\x1e\x9e\x1e\xc9\x51\x00\x00\x00\x00\x0f\x76\x00\x00\x00\x00\x47\x5a\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x5a\x00\x00\x00\x00\x00\x00\xef\x08\xce\x6f\x00\x00\x00\x00\x28\x00\x26\x05\x00\x00\xfa\x05\x46\x78\x00\x00\xda\x08\x85\x06\x06\x61\x26\x05\x00\x00\x26\x05\x26\x05\x00\x00\x26\x05\x00\x00\x00\x00\x00\x00\x80\x08\xaa\x08\x00\x00\x26\x05\x00\x00\x85\x06\x00\x00\xdf\x08\xf2\x08\x00\x00\x00\x00\x00\x00\x8e\x08\x2e\x6f\x96\x08\x8f\x08\x9b\x08\x00\x00\x26\x05\x92\x05\x00\x00\x2e\x6f\x00\x00\x02\x09\x00\x00\x95\x08\x26\x05\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x08\x00\x00\x00\x00\x99\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\xc8\x04\x00\x09\xe5\x08\xb5\x61\x9e\x01\xa0\x65\x85\x64\x0e\x07\xff\x61\x01\x00\xa2\x20\x6e\x02\x87\x04\x9f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x03\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\xe6\x07\xe9\x07\xc5\x02\x00\x00\x57\x06\x60\x06\xb0\x0f\x72\x24\x00\x00\x00\x00\x00\x00\x00\x00\x86\x08\x00\x00\x8a\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x01\xab\x02\x00\x00\x00\x00\xf9\xff\xe9\x20\x1e\x10\xd2\x0f\xf3\x01\xeb\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x03\xe1\x07\x2b\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x0f\x00\x00\x3b\x6b\xbe\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x66\x8d\x63\x28\x06\x5b\x05\xcf\x79\x2c\x08\x04\x7a\x00\x00\x7b\x77\x1c\x21\x44\x7a\x79\x7a\x8a\x7a\xb2\x09\x2f\x08\x31\x09\xbf\x7a\x65\x0b\x39\x08\x3a\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x66\xc1\x77\xfc\x20\x4e\x08\x97\x66\x00\x7c\x76\x08\xf4\x08\x00\x00\x00\x00\xad\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x06\x8a\x02\xef\x05\xd3\x03\x36\x06\x4b\x06\x8b\x04\x12\x0a\x81\x03\xb0\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\xff\x13\x05\x00\x00\xb9\xff\x8a\x06\xb4\x08\x00\x00\x1e\x01\xab\x08\x9f\xff\xad\x06\x47\x05\x94\x05\x1f\x09\x50\x06\x00\x00\x00\x00\x00\x00\x09\x09\x00\x00\xfb\x07\x00\x00\x38\x01\x00\x00\xfc\x07\x5a\x02\x00\x00\x02\x03\xb9\x08\x00\x00\x00\x00\xff\x07\xbd\x08\x0f\x09\x00\x00\xed\x77\x27\x02\xff\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x7b\x97\x00\xc6\x03\xbb\x08\x00\x00\x00\x00\x00\x00\xab\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x03\x00\x00\xb5\xff\x00\x00\x2f\xff\x76\x04\x00\x00\xb8\x08\xbc\x08\x00\x00\x00\x00\xaf\x08\x00\x00\x00\x00\x6e\x03\x30\x0c\xea\x03\xff\x08\xc4\x08\xcb\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x11\x00\x00\x00\x00\xa2\x0c\xa1\x08\x00\x00\x00\x00\x72\x05\x00\x00\xb3\x6d\x00\x00\x00\x00\x48\x13\x2b\x04\xf0\x08\x58\x07\x00\x00\x0a\x65\x92\x10\x00\x00\x00\x00\x00\x00\x70\x02\xd9\x0d\x00\x00\xc4\xff\x00\x00\x00\x00\x33\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x0a\x08\x0b\x00\x00\x00\x00\x00\x00\x70\x06\x00\x00\x00\x00\x1c\x21\x0e\x03\x00\x00\x00\x00\xe6\x04\x00\x00\xbf\x08\xc8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x3c\x00\x00\xd3\x08\x00\x00\xd9\x08\xd4\x08\x4d\x12\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x23\x03\x9a\x03\x17\x00\x5b\x13\xd2\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x00\x32\x05\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\x15\x00\x00\x00\xad\x0f\x00\x00\x00\x00\x4a\x62\x95\x62\x00\x00\x00\x00\x00\x00\x7d\x08\x00\x00\xc4\xff\x00\x00\x00\x00\x00\x00\x24\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x7b\x00\x00\x5f\x78\x00\x00\x00\x00\x18\x08\x1b\x08\x76\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x08\x70\xff\x00\x00\x00\x00\x08\x63\xf9\x05\x00\x00\x7a\x7b\xa8\x66\x37\x03\x03\x01\x00\x00\x80\x09\x00\x00\x92\x24\x4c\x6b\xbf\x6b\xd0\x6b\x43\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x1e\xf0\x0f\xb1\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x01\x61\xff\xd9\x24\xed\x09\x00\x00\x8f\x20\x00\x00\x5f\x0a\x00\x00\x30\x25\x77\x25\x68\x0a\x8a\x25\x43\x21\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x30\x08\x00\x00\xed\x02\xea\x08\xed\x08\x00\x00\x52\x09\x53\x09\x00\x00\x00\x00\x45\x09\x00\x00\x00\x00\x00\x00\x00\x00\x72\x09\x00\x00\x6c\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\xe4\x25\xda\x0a\x40\x02\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x1f\xe1\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x08\x87\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x67\x2c\x67\x00\x00\x00\x00\x00\x00\x00\x00\x74\x22\xf1\x5e\x00\x00\xd9\x5d\xad\x5d\x9f\x67\x00\x00\x7a\x0b\x00\x00\x53\x0d\x21\x61\xec\x0b\x00\x00\x37\xff\x00\x00\x00\x00\x00\x00\x96\x0a\x00\x00\x00\x00\x57\x79\x40\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x02\x4d\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\xff\x00\x00\x00\x00\x00\x00\x59\x08\x00\x00\x00\x00\x97\xff\x00\x00\x00\x00\x00\x00\x5c\x08\x00\x00\x00\x00\x00\x00\x00\x00\xab\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x78\xaa\xff\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x78\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x07\x94\x06\x00\x00\x00\x00\xe9\x04\x99\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x05\x00\x00\xad\x0f\x00\x00\x00\x00\x6c\x03\x00\x00\xe5\x02\x00\x00\x00\x00\xb3\x6d\xa8\x10\xbe\x10\xba\x7b\x2b\x26\x4b\x0e\x5c\x0e\xce\x0e\xe2\x0e\x42\x0d\x39\x11\x00\x00\x00\x00\x00\x00\xd2\xff\xaf\x07\x00\x00\x00\x00\x00\x00\xc4\x6d\x00\x00\x00\x00\xf2\xff\x00\x00\xb0\x67\x7b\x63\xdf\x26\x0a\x09\x71\x05\x25\x09\x98\x1e\x00\x00\x00\x00\x00\x00\x0b\x09\x0c\x09\x00\x00\x16\x09\x00\x00\x94\x12\x00\x00\x00\x00\x00\x00\x00\x00\x16\x06\x2d\x06\x47\x09\x00\x00\x00\x00\xfd\x01\x9d\x21\x3a\x12\x2a\x04\xeb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xff\x2e\xff\x00\x00\x6c\x08\xa2\x13\x00\x00\xc0\xff\xcc\xff\x1c\x65\x8f\x65\x27\x09\x00\x00\x2d\x09\x00\x00\x30\x09\x00\x00\x6b\x06\x24\x09\x00\x00\x00\x00\x00\x00\x78\x06\x43\x10\x00\x00\xef\x7b\x98\x08\x00\x00\x00\x00\x6b\x01\x00\x00\x7f\x09\x00\x00\x00\x00\x91\x09\x00\x00\x92\x09\x00\x00\x00\x00\x26\x00\x00\x00\x89\x09\x00\x00\x50\x01\x00\x00\x85\x01\x00\x00\x86\x09\x00\x00\xb8\x05\x3e\x26\x00\x00\x00\x00\x00\x00\x00\x00\x32\x09\x00\x00\x90\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x79\x00\x00\x4f\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x02\xff\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x21\x6e\x09\xf7\x21\xc0\x01\x00\x00\x5a\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x09\x00\x00\x00\x00\x00\x00\x00\x00\x79\x09\x3e\x22\x00\x00\x00\x00\x95\x22\x00\x00\x00\x00\x6a\x02\x00\x00\x59\x09\x00\x00\x00\x00\x4d\x09\x00\x00\x00\x00\xbe\x06\x00\x00\xd9\xff\x00\x00\x00\x00\x03\x03\x18\x09\xf1\x05\xdc\x22\x09\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x05\x00\x00\x00\x00\x00\x00\xae\xff\x00\x00\x5c\x02\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x06\x00\x00\xf9\x06\x23\x68\x00\x00\x00\x00\xb5\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x03\x00\x00\x00\x00\xa3\x09\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x68\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x04\x00\x00\x97\x08\x00\x00\x00\x00\x5e\x5e\x00\x00\x00\x00\x67\x05\x00\x00\x9c\x08\x00\x00\x00\x00\x12\x23\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x68\x97\x64\xb8\x68\x00\x00\x00\x00\x32\x01\x5e\x0c\xaf\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x23\x00\x00\x7a\x23\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\xc1\x09\x00\x00\x00\x00\x00\x00\xb6\x09\xbc\x09\x00\x00\x45\x07\x51\x07\x00\x00\x00\x00\x00\x00\x85\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x09\x00\x00\x00\x00\x3c\x5f\x00\x00\x00\x00\x62\x09\xfc\x08\x2b\x69\x00\x00\x00\x00\x8a\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x61\x12\x64\xc5\x0d\x00\x00\x00\x00\x00\x00\x5d\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x0b\x38\x03\x00\x00\x00\x00\x1b\x09\x00\x00\xd1\xff\x19\x06\x00\x00\x00\x00\xf2\x26\x2b\x09\x44\x06\x00\x00\x00\x00\x3c\x69\x00\x00\x16\x04\x90\x04\x00\x00\x3d\x09\xb3\x06\x00\x00\x00\x00\x00\x00\xee\x12\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x09\x00\x00\x00\x00\x00\x00\x9f\x09\xbb\xff\x00\x00\x39\x27\x00\x00\x00\x00\xfc\x13\x00\x00\x00\x00\xdd\xff\x00\x00\x00\x00\x00\x00\xad\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x09\x00\x00\xdd\x09\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\xde\x09\xcc\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x02\xb4\x02\xd3\x09\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x01\x4a\x06\xc0\x08\x5a\x04\x0f\x03\x29\x05\x3d\x00\x00\x00\x00\x00\xc6\x08\x00\x00\x00\x00\xaf\x69\x0b\x06\x82\x06\x00\x00\x00\x00\x0f\x14\x56\x14\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x09\x00\x00\xce\xff\xa3\x02\x00\x00\x00\x00\x00\x00\x6a\x02\x00\x00\x00\x00\xc5\x08\x00\x00\xa4\x09\x43\x79\x14\x04\x00\x00\x00\x00\x00\x00\x47\x06\x00\x00\xbe\x0b\xa4\x01\x0a\x02\x00\x00\x52\xff\xb1\x09\x00\x00\x00\x00\x00\x00\x00\x00\x87\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x0f\xbf\x06\x00\x00\xd8\xff\x98\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x69\x33\x6a\x44\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x0c\xf1\x03\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x08\x00\x00\xdc\x09\xd1\x08\x0e\x00\x00\x00\x00\x00\x07\x03\x22\x03\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x09\x04\x0a\x00\x00\x14\x00\x8f\x09\xd7\x08\x00\x00\x00\x00\x00\x00\xb7\x6a\x00\x00\x00\x00\x00\x00\x01\x13\x00\x00\x00\x00\x00\x00\xd5\x08\x00\x00\x9a\x23\x9d\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x08\x00\x00\xc1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x05\x00\x00\xb9\x09\x70\x04\x4c\x27\xad\x0f\x93\x27\x00\x00\x00\x00\x00\x00\xbd\x09\x00\x00\xde\x08\x00\x00\x00\x00\x00\x00\xc5\x09\x00\x00\x00\x00\x31\x01\xa1\x02\xbd\xff\xda\x23\x00\x00\x00\x00\xe2\x08\x00\x00\x00\x00\xf1\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\xe8\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\x09\x00\x00\x00\x00\x00\x00\x09\x03\x00\x00\xf1\x08\x00\x00\xf3\x08\x00\x00\x00\x00\x00\x00\x15\x05\x6f\x05\x00\x00\x00\x00\xd0\x09\xd9\x09\x69\x14\xda\x09\x00\x00\x00\x00\x32\x24\xe2\x1e\x00\x00\xa6\x27\x00\x00\x00\x00\x31\x02\x00\x00\x00\x00\xf3\x11\x00\x00\x00\x00\x2b\x06\x00\x00\x00\x00\x48\x20\x00\x00\x00\x00\x00\x00\xc8\x6a\x00\x00\xb7\x09\x1b\x0a\x00\x00\xff\xff\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0a\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x14\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x08\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\xca\x07\x00\x00\x00\x00\x00\x00\x00\x00\x56\x06\x00\x00\x00\x00\x00\x00\x08\x0a\x2e\x00\x00\x00\x00\x00\x47\x07\x03\x09\x00\x00\xe7\xff\xbc\xff\x00\x00\x00\x00\x27\x0a\x08\x00\x04\x09\x00\x00\x02\x00\x05\x09\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x09\x00\x00\x28\x0a\x00\x00\x94\x09\x65\x06\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x26\x0a\x00\x00\x00\x00\x00\x00\x12\x09\x6f\x04\x00\x00\x44\x00\x00\x00\x7e\x06\x00\x00\x00\x00\x13\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int# +happyAdjustOffset off = off + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xc1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\xfd\x00\x00\x00\x00\xc0\xff\xc1\xff\x00\x00\xf2\xff\xed\xfc\xe9\xfc\xe6\xfc\xd7\xfc\xd5\xfc\xd6\xfc\xd4\xfc\xd3\xfc\xd2\xfc\xe4\xfc\xe3\xfc\xe5\xfc\xe2\xfc\xe1\xfc\xd1\xfc\xd0\xfc\xcf\xfc\xce\xfc\xcd\xfc\xcc\xfc\xcb\xfc\xca\xfc\xc9\xfc\xc4\xfc\xc5\xfc\xc8\xfc\xc6\xfc\xc7\xfc\x00\x00\xe7\xfc\xe8\xfc\x90\xff\x00\x00\xb5\xff\x00\x00\x00\x00\x90\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\xfe\x00\x00\x7c\xfe\x79\xfe\x73\xfe\x72\xfe\x6e\xfe\x6f\xfe\x50\xfe\x4f\xfe\x00\x00\x65\xfe\x20\xfd\x69\xfe\x1b\xfd\x12\xfd\x15\xfd\x0e\xfd\x64\xfe\x68\xfe\xf6\xfc\xf3\xfc\x63\xfe\x3e\xfe\xf1\xfc\xf0\xfc\xf2\xfc\x00\x00\x00\x00\x0b\xfd\x0a\xfd\x00\x00\x00\x00\x62\xfe\x09\xfd\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xfc\x11\xfd\x0c\xfd\x0d\xfd\x49\xfe\x13\xfd\x0f\xfd\x10\xfd\x4a\xfd\x4c\xfe\x4b\xfe\x4a\xfe\x4d\xfe\x00\x00\xee\xfd\xed\xfd\x00\x00\xf1\xff\x3b\xfd\x2b\xfd\x3a\xfd\x2d\xfd\xef\xff\xf0\xff\xfa\xfc\xdf\xfc\xe0\xfc\xdb\xfc\xd8\xfc\x39\xfd\xc1\xfc\x26\xfd\xbe\xfc\xbb\xfc\xee\xff\xda\xfc\xc2\xfc\xc3\xfc\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xfc\xd9\xfc\xbc\xfc\xc0\xfc\xdc\xfc\xbd\xfc\xa9\xfd\x5b\xfd\x92\xfc\xe4\xfd\x00\x00\xdf\xfd\xd7\xfd\xc8\xfd\xc5\xfd\xb5\xfd\xb4\xfd\x00\x00\x00\x00\x61\xfd\x5e\xfd\xc2\xfd\xc1\xfd\xc3\xfd\xc4\xfd\xc0\xfd\xec\xfd\x91\xfc\xb6\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\xfd\xba\xfc\xb9\xfc\xb8\xfc\xbf\xfd\xbe\xfd\xad\xfc\xac\xfc\xb7\xfc\xb6\xfc\xb5\xfc\xb4\xfc\xb3\xfc\xb2\xfc\xb1\xfc\xb0\xfc\xaf\xfc\xae\xfc\xab\xfc\xaa\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\xfd\x71\xff\xfe\xfd\x00\x00\x00\x00\x00\x00\xe9\xfc\x6f\xff\x6e\xff\x6d\xff\x00\x00\x00\x00\xf2\xfd\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x47\xfd\x00\x00\x00\x00\x86\xfc\x00\x00\x6f\xfd\x00\x00\x00\x00\x63\xff\x5d\xff\x62\xff\x61\xff\x60\xff\x03\xff\x00\x00\x5f\xff\x5e\xff\x09\xfe\x58\xff\x57\xff\x0c\xfe\x56\xff\x00\x00\x1a\xff\x39\xff\x3a\xff\xb6\xfe\x19\xff\x00\x00\x00\x00\x00\x00\xc8\xfe\xac\xfe\xb4\xfe\x00\x00\x00\x00\x00\x00\x5f\xfd\x00\x00\x8a\xff\x00\x00\x00\x00\x00\x00\x90\xff\xc2\xff\x00\x00\x90\xff\x00\x00\x8d\xff\xb6\xfe\xa7\xfc\xa6\xfc\x00\x00\xb6\xfe\x85\xff\x00\x00\x00\x00\x00\x00\x00\x00\x3c\xfd\x35\xfd\x3d\xfd\xef\xfc\x37\xfd\x00\x00\x00\x00\x00\x00\xac\xfe\x00\x00\xb1\xfe\x00\x00\x00\x00\x00\x00\xa9\xfe\xad\xfe\xae\xfe\x00\x00\xc9\xfe\xc6\xfe\x00\x00\x34\xfd\x00\x00\x00\x00\x00\x00\x5c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x79\xfe\x20\xfd\x18\xff\x00\x00\x00\x00\x00\x00\x43\xff\x00\x00\xb4\xfe\x3b\xff\x00\x00\x3c\xff\x3e\xff\x3d\xff\x00\x00\x00\x00\x38\xff\x00\x00\x36\xfe\x00\x00\x0a\xff\x00\x00\x00\xfd\x00\x00\xff\xfc\x01\xfd\x00\x00\x00\x00\x03\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\xfd\x8a\xfc\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xfc\x00\x00\xfc\xfc\xfe\xfc\xf8\xfc\xdd\xfc\x00\x00\xde\xfc\x26\xfd\x00\x00\x00\x00\xeb\xfd\x00\x00\x89\xfc\x00\x00\xa0\xfc\x00\x00\xda\xfc\x00\x00\x2a\xfd\xa4\xfc\x00\x00\x32\xfd\x8e\xfe\x00\x00\x00\x00\x48\xfd\x46\xfd\x44\xfd\x43\xfd\x40\xfd\x00\x00\x00\x00\xbd\xfe\xf1\xfd\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\x34\xfd\xd0\xfe\x00\x00\xd3\xfe\xd3\xfe\x00\x00\x00\x00\xac\xfe\x70\xff\xb0\xfd\x24\xfd\xb1\xfd\x00\x00\x00\x00\x00\x00\xa2\xfd\xc4\xfd\x00\x00\x00\x00\x68\xff\x68\xff\x00\x00\x00\x00\x00\x00\xca\xfd\x62\xfd\x62\xfd\xcb\xfd\xb2\xfd\xb3\xfd\xa0\xfd\x9a\xfd\x00\x00\x00\x00\xdd\xfc\xde\xfc\x00\x00\x2f\xfd\x00\x00\x8f\xfd\x00\x00\x8e\xfd\x29\xfd\xd3\xfd\xd4\xfd\xd5\xfd\xe0\xfd\x68\xfd\x69\xfd\x00\x00\x6c\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xfd\x5d\xfd\x00\x00\x90\xfc\x5a\xfd\xdd\xfd\x00\x00\xcd\xfd\x74\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\xfd\xda\xfd\x00\x00\x7d\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\xfd\x56\xfe\x55\xfe\x67\xfe\x66\xfe\x51\xfe\x03\xfd\x44\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x5c\xfe\x00\x00\x15\xfd\x00\x00\x00\x00\x5e\xfe\x00\x00\x53\xfe\x00\x00\x00\x00\x1b\xfe\x19\xfe\x88\xfe\x00\x00\x60\xfe\x61\xfe\x84\xfe\x85\xfe\x00\x00\x3e\xfe\x3d\xfe\x3a\xfe\x38\xfe\x37\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x6d\xfe\x00\x00\x6b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\xfe\x70\xfe\x00\x00\xe9\xff\x00\x00\x00\x00\xb2\xff\x8d\xff\xb6\xfe\xb6\xfe\xb1\xff\xac\xff\xac\xff\xb0\xff\xae\xff\xaf\xff\x91\xff\xed\xff\xa8\xfc\xa9\xfc\xea\xff\x00\x00\xd6\xff\xdd\xff\xda\xff\xdc\xff\xdb\xff\xde\xff\xec\xff\x2f\xfe\x80\xfe\x7e\xfe\x75\xfe\x76\xfe\x78\xfe\x00\x00\x6c\xfe\x71\xfe\x6a\xfe\x7d\xfe\x00\x00\x00\x00\x3f\xfe\x82\xfe\x83\xfe\x00\x00\x00\x00\x5f\xfe\x00\x00\x00\x00\x00\x00\x59\xfe\x00\x00\x1c\xfd\x1f\xfd\xa5\xfc\x1a\xfd\x58\xfe\x00\x00\xa1\xfc\x1d\xfd\x1e\xfd\x5a\xfe\x5b\xfe\x00\x00\x00\x00\xf5\xfc\x14\xfd\x00\x00\x00\x00\x0b\xfd\x0a\xfd\x62\xfe\x09\xfd\x57\xfe\x0c\xfd\x0d\xfd\x10\xfd\x43\xfe\x00\x00\x45\xfe\x30\xfd\x38\xfd\xeb\xfc\x2e\xfd\x25\xfd\xf9\xfc\x93\xfc\x94\xfc\x95\xfc\x96\xfc\x97\xfc\xd9\xfd\x00\x00\x59\xfd\x56\xfd\x53\xfd\x00\x00\xe9\xfc\x55\xfd\xc6\xfd\xea\xfc\x5c\xfd\xd6\xfd\x00\x00\x00\x00\x00\x00\x7b\xfd\x79\xfd\x75\xfd\x72\xfd\x00\x00\xde\xfd\x00\x00\x00\x00\xdc\xfd\xdb\xfd\x6b\xfd\xcf\xfd\x69\xfd\x00\x00\xd0\xfd\x00\x00\x00\x00\x00\x00\x6a\xfd\x00\x00\xb7\xfd\x8d\xfd\x00\x00\x00\x00\xec\xfc\x91\xfd\x96\xfd\xb8\xfd\x97\xfd\x90\xfd\x95\xfd\xb9\xfd\x00\x00\x00\x00\x63\xfd\x00\x00\xae\xfd\xab\xfd\xac\xfd\x9b\xfd\x9c\xfd\x00\x00\x00\x00\xaa\xfd\xad\xfd\x22\xfd\x00\x00\x23\xfd\x21\xfd\x00\x00\x01\xfe\x8a\xfe\x00\x00\x00\x00\x08\xfe\xd4\xfe\x90\xfe\x07\xfe\xa5\xfd\xa4\xfd\x00\x00\x4c\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xec\xfe\xed\xfe\xfb\xfd\x48\xfe\x00\x00\x00\x00\xbb\xfe\x00\x00\xc4\xfe\xc3\xfe\x00\x00\x00\x00\xfa\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\xfd\x2c\xfd\x88\xfc\xbb\xfd\xa2\xfc\xec\xfc\x98\xfd\xbc\xfd\xbd\xfd\x00\x00\xba\xfd\xea\xfd\x7e\xfc\x00\x00\x99\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\xfd\x85\xfc\x00\x00\x15\xff\x00\x00\x8a\xfe\xe3\xfd\xe2\xfd\x00\x00\xe1\xfd\x0b\xfe\xcc\xfe\x03\xfe\x00\x00\x00\x00\x00\x00\xe1\xfe\x31\xfe\x13\xff\x44\xfe\x3f\xff\x8c\xfe\x8a\xfe\xb6\xfe\x00\x00\x00\x00\xa2\xfe\xa6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x00\x00\x11\xff\x4a\xff\x00\x00\x3e\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x9b\xfe\x9a\xfe\x99\xfe\x98\xfe\x97\xfe\x00\x00\x00\x00\x28\xfd\x00\x00\x00\x00\xf7\xfe\xf4\xfe\x00\x00\x00\x00\x00\x00\xbd\xfe\xc5\xfe\x00\x00\x59\xff\xca\xfe\x5b\xff\xac\xfe\x00\x00\x3f\xfd\xb5\xfe\x5a\xff\xb4\xfe\x00\x00\x08\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x90\xfe\x8b\xff\x88\xff\x87\xff\x86\xff\xac\xff\xbc\xff\xac\xff\xbb\xff\xb8\xff\x65\xff\xbd\xff\x8f\xff\xb9\xff\xba\xff\x00\x00\xb6\xfe\x00\x00\x81\xff\x89\xff\x00\x00\x00\x00\xa1\xfe\x9f\xfe\x00\x00\x00\x00\x00\x00\xb3\xfe\x00\x00\xa7\xfe\xab\xfe\xcb\xfe\x00\x00\x00\x00\x00\x00\x70\xfd\xf9\xfe\xfa\xfe\x00\x00\xf2\xfe\xf3\xfe\xee\xfe\x00\x00\xf6\xfe\x00\x00\x9d\xfe\x00\x00\x95\xfe\x94\xfe\x96\xfe\x00\x00\x00\x00\x9c\xfe\x4d\xff\x4e\xff\x53\xff\x00\x00\x00\x00\x37\xff\x00\x00\x00\x00\x01\xff\xff\xfe\xfe\xfe\xfb\xfe\xfc\xfe\x44\xff\x45\xff\x47\xff\x46\xff\xd7\xfe\x00\x00\xa3\xfe\xb8\xfe\x00\x00\x43\xff\x00\x00\x00\x00\x4f\xff\x00\x00\x35\xfe\x33\xfe\x00\x00\x55\xff\x00\x00\x0b\xff\x00\x00\xcc\xfe\x05\xfe\x04\xfe\x00\x00\x87\xfc\x15\xff\x00\x00\x06\xff\x3e\xfe\x2c\xfe\x16\xfe\x00\x00\x21\xfe\x04\xff\x00\x00\xe6\xfd\x84\xfc\x83\xfc\x8b\xfc\x8c\xfc\x8d\xfc\x8e\xfc\x8f\xfc\x74\xfe\xe7\xfd\xe9\xfd\x00\x00\xa7\xfd\x94\xfd\xa3\xfc\xfb\xfc\xf7\xfc\x31\xfd\x8d\xfe\xfd\xfd\x45\xfd\x42\xfd\x36\xfd\x41\xfd\xf9\xfd\xf3\xfd\xf0\xfd\x00\x00\x00\x00\xbb\xfe\xba\xfe\x00\x00\xf3\xfd\xf6\xfd\xfc\xfd\x33\xfd\xcf\xfe\x4d\xfd\xd2\xfe\xd5\xfe\x00\x00\xce\xfe\xd1\xfe\x00\x00\xff\xfd\x05\xfd\x6b\xff\x06\xfd\x04\xfd\x00\x00\x9e\xfd\x9d\xfd\x6a\xff\x67\xfd\x64\xfd\x66\xfd\x9f\xfd\xa1\xfd\xa8\xfd\x93\xfd\x92\xfd\x9a\xfd\x87\xfd\x89\xfd\x86\xfd\x84\xfd\x81\xfd\x80\xfd\x00\x00\x8b\xfd\x88\xfd\xd1\xfd\x6e\xfd\x00\x00\x98\xfc\x00\x00\x80\xfc\x77\xfc\x00\x00\x00\x00\x99\xfc\x00\x00\x9c\xfc\x00\x00\x82\xfc\x7a\xfc\x69\xfd\x00\x00\x9d\xfc\xc9\xfd\xd2\xfd\x00\x00\x00\x00\x00\x00\x73\xfd\xcc\xfd\x00\x00\x00\x00\x00\x00\xc7\xfd\x52\xfe\x00\x00\x02\xfd\x42\xfe\x41\xfe\x40\xfe\x00\x00\x00\x00\x89\xfe\x00\x00\x18\xfe\x1a\xfe\xee\xfc\x00\x00\x3c\xfe\x00\x00\x77\xfe\x00\x00\xd9\xff\xd8\xff\xd7\xff\x00\x00\xeb\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xff\x00\x00\x00\x00\xd5\xff\x00\x00\x00\x00\x00\x00\x4e\xfe\x5d\xfe\x00\x00\x57\xfd\x54\xfd\x51\xfd\x4f\xfd\x71\xfd\x7a\xfd\xdd\xfd\x9f\xfc\x81\xfc\x7b\xfc\x9e\xfc\x76\xfc\xcc\xfe\x76\xfd\x00\x00\x9b\xfc\x7f\xfc\x78\xfc\x9a\xfc\x75\xfc\x7f\xfd\xcc\xfc\x00\x00\x00\x00\x8c\xfd\x65\xfd\x69\xff\x92\xff\x00\x00\x00\xfe\x4b\xfd\xd6\xfe\x4e\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xbc\xfe\xbe\xfe\xef\xfd\x00\x00\xe8\xfd\x05\xff\x27\xfe\x25\xfe\x00\x00\x3e\xfe\x14\xff\x51\xff\x15\xfe\x13\xfe\x00\x00\x16\xfe\x00\x00\x00\x00\x00\x00\x2c\xfe\x16\xfe\xcd\xfe\x06\xfe\x00\x00\xe2\xfe\xe5\xfe\xe5\xfe\x30\xfe\x31\xfe\x31\xfe\x12\xff\x54\xff\x8b\xfe\x00\x00\xb7\xfe\xa5\xfe\x00\x00\x4b\xff\x00\x00\xfd\xfe\x0f\xff\x10\xff\x32\xff\x00\x00\x27\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9e\xfe\x27\xfd\x00\x00\xf5\xfe\xf8\xfe\x00\x00\x00\x00\xc2\xfe\xc0\xfe\x00\x00\x3e\xfd\xaf\xfe\xa0\xfe\x07\xfd\x8f\xfe\x0a\xfe\x83\xff\x82\xff\x00\x00\x00\x00\xab\xff\xa6\xff\xa5\xff\x00\x00\xa8\xff\x00\x00\x67\xff\x64\xff\x8e\xff\x93\xff\x66\xff\xc3\xff\x90\xff\x90\xff\xa0\xff\x98\xff\x94\xff\x19\xfd\x95\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\xfe\xad\xff\xc4\xff\x00\x00\x84\xff\xc1\xfe\x00\x00\xd3\xfe\xd3\xfe\xf1\xfe\x91\xfe\x00\x00\x00\x00\x00\x00\x36\xff\x00\x00\x52\xff\x00\x00\xd8\xfe\xdb\xfe\xdb\xfe\xa4\xfe\x02\xff\x34\xfe\x32\xfe\xeb\xfe\xe6\xfe\x00\x00\xea\xfe\x21\xff\x00\x00\x00\x00\x00\x00\x02\xfe\x49\xff\x16\xfe\x07\xff\x00\x00\x29\xfe\x29\xfe\x50\xff\x00\x00\x12\xfe\x0f\xfe\x40\xff\x42\xff\x41\xff\x00\x00\x14\xfe\x00\x00\x00\x00\x7b\xfe\x20\xfe\x23\xfe\x00\x00\x21\xfe\xf7\xfd\xbb\xfe\x00\x00\x87\xfe\xf4\xfd\xf8\xfd\x6c\xff\x8a\xfd\x83\xfd\x82\xfd\x85\xfd\x00\x00\x00\x00\x00\x00\x79\xfc\x77\xfd\x78\xfd\x7c\xfc\x00\x00\x00\x00\x00\x00\x54\xfe\x17\xfe\x3b\xfe\x39\xfe\x00\x00\xc9\xff\x8a\xff\x00\x00\x00\x00\x00\x00\xb6\xff\x90\xff\x90\xff\xb7\xff\xb3\xff\xb4\xff\xcd\xff\xca\xff\xd4\xff\xe7\xff\xc6\xfc\xb6\xfe\x00\x00\xcc\xff\x50\xfd\x52\xfd\x00\x00\x7e\xfd\x7d\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x26\xfe\x43\xfe\x00\x00\x00\x00\x00\x00\x22\xfe\x47\xfe\x00\x00\x0e\xfe\x10\xfe\x11\xfe\x00\x00\x2a\xfe\x00\x00\x00\x00\x00\x00\x08\xff\x48\xff\xe4\xfe\xe7\xfe\x23\xff\x0e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x20\xff\xe3\xfe\xe0\xfe\x1f\xff\xdc\xfe\x00\x00\xdf\xfe\x17\xff\x16\xff\x1f\xff\x00\x00\x31\xff\x29\xff\x29\xff\x00\x00\x00\x00\x92\xfe\x93\xfe\x00\x00\x00\x00\xc7\xfe\x85\xff\xa7\xff\x00\x00\x00\x00\x00\x00\xa2\xff\x97\xff\xa3\xff\xa1\xff\x96\xff\xa4\xff\x9e\xff\x00\x00\x00\x00\xbf\xff\xbe\xff\x00\x00\x9d\xff\x9b\xff\x9a\xff\x99\xff\x18\xfd\x17\xfd\x16\xfd\x81\xff\xf0\xfe\xef\xfe\x28\xff\x35\xff\x33\xff\x00\x00\x2a\xff\x00\x00\x00\x00\x00\x00\xda\xfe\xdd\xfe\x00\x00\x1e\xff\xd9\xfe\x03\xff\x13\xff\x00\x00\x0e\xff\x22\xff\x25\xff\x00\x00\x00\x00\xe8\xfe\x00\x00\x2e\xfe\x00\x00\x29\xfe\x2d\xfe\x0d\xfe\x00\x00\x20\xfe\x24\xfe\xa2\xfc\x1f\xfe\x1e\xfe\xa0\xfc\xbf\xfe\xb9\xfe\x86\xfe\x00\x00\xce\xfd\xb6\xfe\xac\xff\xc5\xff\x00\x00\xc6\xff\x00\x00\xcb\xff\x00\x00\xd0\xff\xce\xff\x00\x00\xe3\xff\x00\x00\x00\x00\xac\xff\x7c\xfd\x1d\xfe\x46\xfe\x2b\xfe\x00\x00\x09\xff\x00\x00\x64\xfe\x63\xfe\x00\x00\x0d\xff\x24\xff\x00\x00\xe9\xfe\x26\xff\x00\x00\x1d\xff\xde\xfe\x2e\xff\x30\xff\x2b\xff\x2d\xff\x2f\xff\x34\xff\x7f\xff\x00\x00\x9f\xff\x9c\xff\x7d\xff\x00\x00\x2c\xff\x15\xff\x00\x00\x28\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xe4\xff\x00\x00\xd3\xff\xd1\xff\xd2\xff\xcf\xff\xe5\xff\x00\x00\x00\x00\xe2\xff\x00\x00\xc7\xff\x00\x00\x0c\xff\x2c\xfe\x16\xfe\x80\xff\x8c\xff\x7e\xff\x00\x00\x79\xff\xa0\xff\x00\x00\x7a\xff\x75\xff\x00\x00\x00\x00\x77\xff\x79\xff\x1c\xff\x16\xfe\xc8\xff\x00\x00\x00\x00\xe1\xff\xdf\xff\xe0\xff\x1b\xff\x00\x00\x72\xff\x73\xff\x78\xff\x7c\xff\x74\xff\x76\xff\x7b\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x00\x00\x0d\x00\x0e\x00\x05\x00\x06\x00\x4d\x00\x68\x00\x06\x00\x3b\x00\x4f\x00\x4f\x00\x04\x00\x50\x00\xad\x00\x07\x00\x08\x00\x09\x00\x04\x00\x0b\x00\xc2\x00\x0e\x00\x08\x00\x09\x00\x04\x00\x0b\x00\xe3\x00\x4a\x00\x08\x00\x09\x00\x69\x00\x0b\x00\x08\x00\x09\x00\x09\x00\x0b\x00\x0b\x00\x3c\x00\x58\x00\x90\x00\x5a\x00\x69\x00\x80\x00\x81\x00\x01\x00\x5b\x00\x80\x00\x81\x00\x00\x00\x09\x00\x05\x00\x00\x00\x5b\x00\x67\x00\x6a\x00\x12\x00\x3d\x00\x3e\x00\x6c\x00\xaa\x00\xab\x00\xac\x00\xad\x00\x4e\x00\x72\x00\x73\x00\x5b\x00\x00\x00\x17\x00\x16\x01\x4a\x00\x6a\x00\x4a\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x1d\x00\x00\x00\x35\x00\x12\x00\x3d\x00\x3e\x00\x2e\x00\x27\x00\x28\x00\x29\x00\x80\x00\x81\x00\x0c\x00\x00\x00\x2b\x00\x0c\x00\x30\x01\x22\x00\x23\x00\xf1\x00\x28\x00\x29\x00\x36\x01\x3f\x00\x40\x00\x00\x00\x4a\x00\x78\x00\x3b\x01\x79\x00\x28\x00\x29\x00\x6a\x00\x1d\x01\x1e\x01\x37\x00\x38\x00\x39\x00\x35\x00\x36\x00\x3f\x01\x4a\x00\x28\x00\x29\x00\x8f\x00\x37\x00\x38\x00\x39\x00\x52\x00\x83\x00\x54\x00\x83\x00\x28\x00\x29\x00\x8e\x00\x8f\x00\x8f\x00\x83\x00\xb6\x00\x39\x00\x29\x01\x66\x00\x2b\x01\x94\x00\x00\x00\xb6\x00\x72\x00\xc3\x00\xc4\x00\xc2\x00\x6c\x00\x52\x00\xc8\x00\x36\x01\x4a\x00\x69\x00\xcc\x00\x4a\x00\x69\x00\xb6\x00\xd0\x00\x72\x00\xd2\x00\x76\x00\x72\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xe3\x00\xda\x00\xdb\x00\xdc\x00\x94\x00\x69\x00\x3d\x01\x17\x01\x10\x01\x11\x01\x0b\x00\x13\x01\x14\x01\x15\x01\xbc\x00\xbd\x00\xbe\x00\x69\x00\xc7\x00\x29\x01\x24\x01\x2b\x01\x26\x01\x27\x01\x82\x00\x72\x00\x72\x00\x4b\x00\x72\x00\x69\x00\x3e\x00\x3f\x00\x36\x01\x31\x01\x52\x00\x33\x01\x34\x01\x35\x01\x72\x00\x37\x01\x30\x01\x69\x00\x3a\x01\x3b\x01\x05\x01\x06\x01\x36\x01\x1d\x01\x1e\x01\x39\x01\x72\x00\x30\x01\xe0\x00\x0e\x01\x0f\x01\x30\x01\x18\x00\x36\x01\x13\x01\x14\x01\x15\x01\x36\x01\x30\x01\x2b\x01\x2b\x01\x2b\x01\x4a\x00\x73\x00\x36\x01\x3e\x00\x3f\x00\x1d\x01\x1e\x01\x30\x01\x36\x01\x36\x01\x36\x01\x6d\x00\xe0\x00\x36\x01\x69\x00\x2c\x01\x4d\x00\x2c\x01\x2d\x01\x30\x01\x2f\x01\x30\x01\x16\x01\x72\x00\x94\x00\x36\x01\x3f\x01\x36\x01\x41\x01\x38\x01\x39\x01\x30\x01\x2c\x01\x3c\x01\x22\x01\x23\x01\x30\x01\x36\x01\x0e\x01\x0f\x01\x72\x00\x00\x00\x36\x01\x13\x01\x14\x01\x15\x01\x2c\x01\x17\x01\x52\x00\x00\x00\x30\x01\x66\x00\x34\x01\x35\x01\x73\x00\x37\x01\x36\x01\x2c\x01\x2c\x01\x3b\x01\x2c\x01\x30\x01\x30\x01\x27\x01\x30\x01\xbd\x00\xbe\x00\x36\x01\x36\x01\x2d\x01\x36\x01\x2f\x01\x30\x01\x31\x01\x3e\x01\x33\x01\x34\x01\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3e\x01\x36\x01\x1b\x01\x3e\x01\x1d\x01\x1e\x01\x2c\x01\x36\x01\x3e\x01\x6d\x00\x30\x01\xa1\x00\x1b\x01\x36\x01\x1d\x01\x1e\x01\x36\x01\x36\x01\x36\x01\x18\x00\x2d\x01\x00\x00\x2f\x01\x30\x01\x1b\x01\x4a\x00\x1d\x01\x1e\x01\x12\x00\x36\x01\x2d\x01\x00\x00\x2f\x01\x30\x01\x1b\x01\x4c\x00\x1d\x01\x1e\x01\x2b\x00\x36\x01\x47\x00\x00\x00\x2d\x01\x4d\x00\x2f\x01\x30\x01\x1b\x01\x76\x00\x1d\x01\x1e\x01\x05\x00\x36\x01\x2d\x01\x13\x00\x2f\x01\x30\x01\x1b\x01\x4d\x00\x1d\x01\x1e\x01\x83\x00\x36\x01\xa1\x00\x35\x00\x2d\x01\x72\x00\x2f\x01\x30\x01\x17\x00\x67\x00\x69\x00\x53\x00\x54\x00\x36\x01\x2d\x01\x74\x00\x2f\x01\x30\x01\x3b\x00\x72\x00\x79\x00\x2f\x00\x30\x00\x36\x01\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x59\x00\x48\x00\x2c\x01\xac\x00\xad\x00\x73\x00\x30\x01\xaa\x00\xab\x00\xac\x00\xad\x00\x4d\x00\x36\x01\x4e\x00\x20\x00\x21\x00\x22\x00\x23\x00\x59\x00\x5a\x00\x52\x00\x4a\x00\x66\x00\x05\x00\x00\x01\x01\x01\x4d\x00\x62\x00\x63\x00\x96\x00\x1e\x01\x78\x00\x67\x00\x21\x01\x63\x00\x9c\x00\x69\x00\x6c\x00\x9f\x00\xa0\x00\xa1\x00\x17\x00\xa3\x00\xa4\x00\x85\x00\x72\x00\x69\x00\x6d\x00\x96\x00\x73\x00\x65\x00\x52\x00\x6c\x00\x73\x00\x9c\x00\x72\x00\x69\x00\x9f\x00\xa0\x00\xa1\x00\x59\x00\xa3\x00\xa4\x00\x77\x00\x73\x00\x72\x00\x3b\x00\x7b\x00\x8b\x00\x2d\x01\x2e\x01\x2f\x01\x30\x01\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x36\x01\x48\x00\x0e\x01\x0f\x01\x4c\x00\xcc\x00\x73\x00\x13\x01\x14\x01\x15\x01\x54\x00\x1f\x01\x20\x01\x78\x00\x4a\x00\x52\x00\x58\x00\x54\x00\x59\x00\x5a\x00\xdb\x00\x10\x00\x90\x00\x61\x00\xcc\x00\x61\x00\x85\x00\x62\x00\x63\x00\xff\x00\x00\x01\x01\x01\x67\x00\x2d\x01\x82\x00\x2f\x01\x30\x01\x6c\x00\x21\x00\xdb\x00\x52\x00\x52\x00\x36\x01\x3f\x01\x38\x01\x39\x01\xc3\x00\x72\x00\x78\x00\x79\x00\x29\x01\xc8\x00\x2b\x01\x77\x00\x72\x00\xcc\x00\x29\x01\x7b\x00\x2b\x01\xd0\x00\x6d\x00\xd2\x00\x52\x00\x36\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x8b\x00\x36\x01\xdb\x00\xdc\x00\x52\x00\x73\x00\x73\x00\x2d\x01\x2e\x01\x2f\x01\x30\x01\x02\x01\x0b\x00\x6c\x00\x19\x01\x1a\x01\x36\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x34\x00\x6f\x00\x77\x00\x67\x00\xa1\x00\x73\x00\x1b\x00\x4d\x00\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\x52\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x3e\x00\x3f\x00\x36\x01\x05\x01\x06\x01\x6b\x00\xb4\x00\xb5\x00\x29\x01\x2a\x01\x2b\x01\x57\x00\x0e\x01\x0f\x01\x2e\x01\xc3\x00\x30\x01\x13\x01\x14\x01\x15\x01\xc8\x00\x36\x01\x36\x01\x6f\x00\xcc\x00\xab\x00\xac\x00\xad\x00\xd0\x00\x01\x00\xd2\x00\x85\x00\x18\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd3\x00\x13\x00\xdb\x00\xdc\x00\x4d\x00\x2c\x01\x2d\x01\x6d\x00\x2f\x01\x30\x01\x6d\x00\x17\x01\x15\x00\x73\x00\x2b\x00\x36\x01\x73\x00\x38\x01\x39\x01\x6b\x00\x58\x00\x3c\x01\xa4\x00\x5b\x00\x24\x01\x3b\x00\x26\x01\x27\x01\x52\x00\x2f\x00\x30\x00\x31\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x31\x01\x48\x00\x33\x01\x34\x01\x35\x01\x4a\x00\x37\x01\x05\x01\x06\x01\x3a\x01\x3b\x01\xaa\x00\xab\x00\xac\x00\xad\x00\x78\x00\x0e\x01\x0f\x01\x59\x00\x5a\x00\x6f\x00\x13\x01\x14\x01\x15\x01\x73\x00\xcc\x00\xa1\x00\x62\x00\x63\x00\x29\x01\x67\x00\x2b\x01\x67\x00\x18\x00\xb4\x00\xb5\x00\x53\x00\x6c\x00\x0e\x01\x0f\x01\xdb\x00\x72\x00\x36\x01\x13\x01\x14\x01\x15\x01\x2c\x01\x2d\x01\x18\x00\x2f\x01\x30\x01\x58\x00\x2b\x00\x4c\x00\x53\x00\x5c\x00\x36\x01\x6d\x00\x38\x01\x39\x01\x61\x00\x54\x00\x3c\x01\x73\x00\x4c\x00\xd3\x00\x3b\x00\x2b\x00\x8b\x00\x2d\x01\x1d\x00\x2f\x01\x30\x01\xb4\x00\xb5\x00\x00\x00\x58\x00\x29\x01\x36\x01\x2b\x01\x38\x01\x39\x01\x07\x00\x78\x00\x2b\x00\x61\x00\x6d\x00\x7c\x00\x53\x00\x54\x00\x36\x01\x63\x00\x73\x00\x32\x00\x33\x00\x58\x00\x58\x00\x5a\x00\x79\x00\x18\x00\x5c\x00\x6d\x00\x19\x01\x1a\x01\xd3\x00\x61\x00\x1d\x01\x1e\x01\x78\x00\x79\x00\x67\x00\x1e\x00\x7c\x00\x7d\x00\x9e\x00\x6c\x00\x1d\x01\x1e\x01\x29\x01\xa1\x00\x2b\x01\x72\x00\x73\x00\x67\x00\xc3\x00\x2c\x00\x2d\x00\x19\x00\x78\x00\xc8\x00\x2b\x01\x36\x01\x63\x00\xcc\x00\x72\x00\x66\x00\x1d\x00\xd0\x00\x29\x01\xd2\x00\x2b\x01\x36\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x2c\x00\x2d\x00\xdb\x00\xdc\x00\x2b\x00\x36\x01\x4d\x00\x4e\x00\x0f\x01\x96\x00\x67\x00\x52\x00\x13\x01\x54\x00\x55\x00\x9c\x00\x56\x00\x1d\x00\x9f\x00\xa0\x00\xa1\x00\x72\x00\xa3\x00\xa4\x00\x6c\x00\x6a\x00\x85\x00\x6c\x00\x6b\x00\x6e\x00\x65\x00\x2b\x00\x67\x00\xa4\x00\x69\x00\x77\x00\x73\x00\x2c\x01\x77\x00\x7b\x00\x6c\x00\x30\x01\x7b\x00\x72\x00\x05\x01\x06\x01\x6d\x00\x36\x01\x3b\x00\x38\x01\x39\x01\x77\x00\x73\x00\x0e\x01\x0f\x01\x7b\x00\xc3\x00\xc4\x00\x13\x01\x14\x01\x15\x01\xc8\x00\x2c\x01\xcc\x00\x6d\x00\xcc\x00\x30\x01\x3e\x00\x3f\x00\xd0\x00\x73\x00\xd2\x00\x36\x01\xcc\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xdb\x00\xda\x00\xdb\x00\xdc\x00\x73\x00\x2c\x01\x2d\x01\x9e\x00\x2f\x01\x30\x01\xdb\x00\x17\x01\xa1\x00\x73\x00\x67\x00\x36\x01\x30\x01\x38\x01\x39\x01\x6c\x00\x44\x00\x3c\x01\x36\x01\x29\x01\x24\x01\x2b\x01\x26\x01\x27\x01\x2c\x01\x76\x00\x10\x01\x11\x01\x30\x01\x13\x01\x14\x01\x15\x01\x36\x01\x31\x01\x36\x01\x33\x01\x34\x01\x35\x01\xa1\x00\x37\x01\x05\x01\x06\x01\x3a\x01\x3b\x01\x6b\x00\xaa\x00\xab\x00\xac\x00\xad\x00\x0e\x01\x0f\x01\xa1\x00\x73\x00\x6f\x00\x13\x01\x14\x01\x15\x01\x73\x00\x19\x01\x1a\x01\x67\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x54\x00\x39\x01\x19\x01\x1a\x01\x67\x00\x72\x00\x1d\x01\x1e\x01\x29\x01\x2a\x01\x2b\x01\x67\x00\x10\x00\x2c\x01\x2d\x01\x72\x00\x2f\x01\x30\x01\x29\x01\x3b\x00\x2b\x01\x36\x01\x72\x00\x36\x01\x10\x00\x38\x01\x39\x01\x67\x00\x67\x00\x3c\x01\x83\x00\x36\x01\xaa\x00\xab\x00\xac\x00\xad\x00\xc3\x00\xc4\x00\x72\x00\x72\x00\x6a\x00\xc8\x00\x6c\x00\x3b\x00\x6e\x00\xcc\x00\x77\x00\x4e\x00\x72\x00\xd0\x00\x7b\x00\xd2\x00\x53\x00\x77\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x17\x01\xda\x00\xdb\x00\xdc\x00\x6d\x00\x67\x00\x3a\x01\x3b\x01\x96\x00\x72\x00\x6c\x00\x3f\x01\x67\x00\x24\x01\x9c\x00\x26\x01\x27\x01\x9f\x00\xa0\x00\xa1\x00\x76\x00\xa3\x00\xa4\x00\x72\x00\xa1\x00\x4c\x00\x31\x01\x4e\x00\x33\x01\x34\x01\x35\x01\xa1\x00\x37\x01\x0e\x01\x0f\x01\x3a\x01\x3b\x01\x58\x00\x13\x01\x14\x01\x15\x01\x5c\x00\x03\x01\x04\x01\x05\x01\x06\x01\x61\x00\x2c\x01\x29\x01\x72\x00\x2b\x01\x30\x01\x4a\x00\x0e\x01\x0f\x01\x4c\x00\x2b\x01\x36\x01\x13\x01\x14\x01\x15\x01\x36\x01\xcc\x00\x54\x00\x2e\x01\x74\x00\x30\x01\x36\x01\x67\x00\x78\x00\x79\x00\x6b\x00\x36\x01\x7c\x00\x7d\x00\x38\x01\x39\x01\xdb\x00\x6a\x00\x73\x00\x6c\x00\x4d\x00\x6e\x00\x2c\x01\x2d\x01\x3b\x00\x2f\x01\x30\x01\x6d\x00\x34\x01\x35\x01\x77\x00\x37\x01\x36\x01\x73\x00\x38\x01\x39\x01\xc3\x00\xc4\x00\x3c\x01\x79\x00\x29\x01\xc8\x00\x2b\x01\x7d\x00\x2e\x01\xcc\x00\x30\x01\x54\x00\x4e\x00\xd0\x00\x55\x00\xd2\x00\x36\x01\x36\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x83\x00\xda\x00\xdb\x00\xdc\x00\x33\x01\x34\x01\x35\x01\x7c\x00\x37\x01\x7e\x00\x67\x00\x3a\x01\x3b\x01\x30\x01\x0c\x00\x6c\x00\x3f\x01\x6e\x00\x6f\x00\x36\x01\x19\x01\x1a\x01\x39\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x0e\x01\x0f\x01\x4d\x00\x4e\x00\x12\x01\x13\x01\x14\x01\x15\x01\x29\x01\x2a\x01\x2b\x01\x2e\x01\x14\x00\x30\x01\x03\x01\x04\x01\x05\x01\x06\x01\x1a\x00\x36\x01\x1c\x00\x36\x01\x3e\x00\x3f\x00\x77\x00\x0e\x01\x0f\x01\x96\x00\x7b\x00\x10\x00\x13\x01\x14\x01\x15\x01\x9c\x00\x6c\x00\x4e\x00\x9f\x00\xa0\x00\xa1\x00\x52\x00\xa3\x00\xa4\x00\x38\x01\x39\x01\x10\x01\x11\x01\x52\x00\x13\x01\x14\x01\x15\x01\x33\x01\x34\x01\x35\x01\x54\x00\x37\x01\x2c\x01\x2d\x01\x4c\x00\x2f\x01\x30\x01\x3b\x00\x2d\x01\x6f\x00\x2f\x01\x30\x01\x36\x01\x73\x00\x38\x01\x39\x01\x58\x00\x36\x01\x3c\x01\x57\x00\x5c\x00\xc3\x00\xc4\x00\x13\x00\x14\x00\x61\x00\xc8\x00\x17\x00\xcc\x00\x30\x01\xcc\x00\x44\x00\x39\x01\x55\x00\xd0\x00\x36\x01\xd2\x00\x38\x01\x39\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xdb\x00\xda\x00\xdb\x00\xdc\x00\x72\x00\x78\x00\x79\x00\x83\x00\x67\x00\x7c\x00\x7d\x00\x34\x01\x35\x01\x6c\x00\x37\x01\x6e\x00\x6f\x00\x2d\x01\x3b\x01\x2f\x01\x30\x01\x1a\x01\x3f\x01\x96\x00\x1d\x01\x1e\x01\x36\x01\x57\x00\x66\x00\x9c\x00\x68\x00\x4c\x00\x9f\x00\xa0\x00\xa1\x00\x4d\x00\xa3\x00\xa4\x00\x6a\x00\x54\x00\x6c\x00\x4a\x00\x6e\x00\x58\x00\x05\x01\x06\x01\x6d\x00\x5c\x00\x2e\x01\x73\x00\x30\x01\x77\x00\x61\x00\x0e\x01\x0f\x01\x7b\x00\x36\x01\x6f\x00\x13\x01\x14\x01\x15\x01\x73\x00\x19\x01\x1a\x01\x6d\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x73\x00\x45\x00\x46\x00\x47\x00\x48\x00\x78\x00\x79\x00\xcc\x00\x29\x01\x2a\x01\x2b\x01\x4d\x00\x4e\x00\x2c\x01\x2d\x01\x1a\x01\x2f\x01\x30\x01\x1d\x01\x1e\x01\x4c\x00\x36\x01\xdb\x00\x36\x01\x4e\x00\x38\x01\x39\x01\x3b\x00\x52\x00\x3c\x01\xc3\x00\xc4\x00\x58\x00\x4d\x00\x4e\x00\xc8\x00\x5c\x00\x2f\x01\x30\x01\xcc\x00\x66\x00\x61\x00\x68\x00\xd0\x00\x36\x01\xd2\x00\x38\x01\x39\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x6d\x00\xda\x00\xdb\x00\xdc\x00\x58\x00\x66\x00\x5a\x00\x68\x00\x74\x00\x5f\x00\x16\x01\x1a\x01\x78\x00\x79\x00\x1d\x01\x1e\x01\x7c\x00\x7d\x00\x6d\x00\x67\x00\x0e\x01\x0f\x01\x22\x01\x23\x01\x6c\x00\x13\x01\x14\x01\x15\x01\x6d\x00\x66\x00\x72\x00\x68\x00\x19\x01\x1a\x01\x6d\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x34\x01\x35\x01\x4e\x00\x37\x01\x05\x01\x06\x01\x52\x00\x3b\x01\x29\x01\x2a\x01\x2b\x01\x77\x00\x77\x00\x0e\x01\x0f\x01\x7b\x00\x7b\x00\x6d\x00\x13\x01\x14\x01\x15\x01\x36\x01\x38\x01\x39\x01\x96\x00\xed\x00\xee\x00\xef\x00\x9a\x00\xf1\x00\x9c\x00\x6d\x00\x3b\x01\x9f\x00\xa0\x00\xa1\x00\x3f\x01\xa3\x00\xa4\x00\x2d\x01\x73\x00\x2f\x01\x30\x01\x2c\x01\x2d\x01\x52\x00\x2f\x01\x30\x01\x36\x01\x66\x00\x54\x00\x68\x00\x66\x00\x36\x01\x68\x00\x38\x01\x39\x01\x3b\x00\x4c\x00\x3c\x01\x86\x00\x87\x00\x88\x00\x4a\x00\x10\x01\x11\x01\x54\x00\x13\x01\x14\x01\x15\x01\x58\x00\xc3\x00\xc4\x00\x66\x00\x5c\x00\x68\x00\xc8\x00\x73\x00\xcc\x00\x61\x00\xcc\x00\x3e\x00\x3f\x00\x55\x00\xd0\x00\x66\x00\xd2\x00\x68\x00\x0c\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xdb\x00\xda\x00\xdb\x00\xdc\x00\x66\x00\x74\x00\x68\x00\x6b\x00\x67\x00\x78\x00\x79\x00\x9b\x00\x39\x01\x6c\x00\x6a\x00\x6e\x00\x6c\x00\xa4\x00\x6e\x00\x18\x01\x19\x01\x1a\x01\x6f\x00\x96\x00\x1d\x01\x1e\x01\x66\x00\x77\x00\x68\x00\x9c\x00\x99\x00\x7b\x00\x9f\x00\xa0\x00\xa1\x00\x99\x00\xa3\x00\xa4\x00\x99\x00\x2f\x01\x30\x01\x83\x00\x84\x00\x85\x00\x05\x01\x06\x01\x36\x01\x6d\x00\x38\x01\x39\x01\xaf\x00\xb0\x00\xb1\x00\x0e\x01\x0f\x01\x32\x00\x33\x00\xcc\x00\x13\x01\x14\x01\x15\x01\x6b\x00\x19\x01\x1a\x01\x73\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x4d\x00\x4e\x00\xdb\x00\xc5\x00\xc6\x00\xc7\x00\x54\x00\xcc\x00\x29\x01\x2a\x01\x2b\x01\x4d\x00\x4e\x00\x2c\x01\x2d\x01\x0c\x00\x2f\x01\x30\x01\x3b\x00\x4d\x00\x4e\x00\x36\x01\xdb\x00\x36\x01\x4a\x00\x38\x01\x39\x01\x3e\x00\x3f\x00\x3c\x01\xc3\x00\xc4\x00\xed\x00\xee\x00\xef\x00\xc8\x00\xf1\x00\x02\x00\x03\x00\xcc\x00\x33\x01\x34\x01\x35\x01\xd0\x00\x37\x01\xd2\x00\x02\x00\x03\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4a\x00\xda\x00\xdb\x00\xdc\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x3f\x01\x67\x00\x41\x01\x19\x01\x1a\x01\x54\x00\x6c\x00\x1d\x01\x1e\x01\x64\x00\x65\x00\x66\x00\xc5\x00\xc6\x00\xc7\x00\x66\x00\x76\x00\x68\x00\x66\x00\x29\x01\x68\x00\x2b\x01\x4c\x00\x19\x01\x1a\x01\x72\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x66\x00\x36\x01\x68\x00\x58\x00\x05\x01\x06\x01\x6d\x00\x5c\x00\x29\x01\x2a\x01\x2b\x01\x14\x00\x61\x00\x0e\x01\x0f\x01\x77\x00\x78\x00\xc9\x00\x13\x01\x14\x01\x15\x01\x36\x01\x52\x00\x0e\x01\x0f\x01\x74\x00\x54\x00\x12\x01\x13\x01\x14\x01\x15\x01\x74\x00\xbf\x00\xc0\x00\xc1\x00\x78\x00\x79\x00\x77\x00\x78\x00\x7c\x00\x7d\x00\xca\x00\xcb\x00\x2c\x01\x2d\x01\x3b\x00\x2f\x01\x30\x01\xb7\x00\xb8\x00\xb9\x00\x74\x00\x66\x00\x36\x01\x68\x00\x38\x01\x39\x01\x6d\x00\x66\x00\x3c\x01\x68\x00\x74\x00\xc3\x00\xc4\x00\x6f\x00\x38\x01\x39\x01\xc8\x00\x99\x00\x4b\x00\x4c\x00\xcc\x00\xbf\x00\xc0\x00\xc1\x00\xd0\x00\x66\x00\xd2\x00\x68\x00\x6d\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x6f\x00\xda\x00\xdb\x00\xdc\x00\xef\x00\x67\x00\xf1\x00\x66\x00\x96\x00\x68\x00\x6c\x00\x17\x01\x74\x00\x86\x00\x9c\x00\x88\x00\xa4\x00\x9f\x00\xa0\x00\xa1\x00\x76\x00\xa3\x00\xa4\x00\x83\x00\x24\x01\x85\x00\x26\x01\x27\x01\xca\x00\xcb\x00\x4c\x00\xbf\x00\xc0\x00\xc1\x00\xbf\x00\xc0\x00\xc1\x00\x31\x01\x54\x00\x33\x01\x34\x01\x35\x01\x58\x00\x37\x01\x05\x01\x06\x01\x3a\x01\x3b\x01\xa4\x00\xca\x00\xcb\x00\x61\x00\x67\x00\x0e\x01\x0f\x01\x73\x00\xcc\x00\x54\x00\x13\x01\x14\x01\x15\x01\x72\x00\xcc\x00\x6d\x00\xbf\x00\xc0\x00\xc1\x00\x7a\x00\x7b\x00\x73\x00\x0b\x00\xdb\x00\x40\x01\x41\x01\x78\x00\x79\x00\x6c\x00\xdb\x00\x7c\x00\x7d\x00\x3b\x00\x77\x00\x78\x00\x2c\x01\x2d\x01\x34\x00\x2f\x01\x30\x01\xcc\x00\xbf\x00\xc0\x00\xc1\x00\x18\x00\x36\x01\x4d\x00\x38\x01\x39\x01\xc3\x00\xc4\x00\x3c\x01\x6d\x00\x3b\x00\xc8\x00\xdb\x00\x1f\x01\x20\x01\xcc\x00\x73\x00\x04\x01\x05\x01\xd0\x00\x74\x00\xd2\x00\x10\x00\x11\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x6d\x00\xda\x00\xdb\x00\xdc\x00\x6d\x00\x67\x00\x10\x00\x11\x00\xb0\x00\xb1\x00\x6c\x00\x73\x00\x1d\x01\x1e\x01\x19\x01\x1a\x01\x40\x01\x41\x01\x1d\x01\x1e\x01\x19\x01\x1a\x01\x6d\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xb8\x00\xb9\x00\x29\x01\x6c\x00\x2b\x01\x35\x00\x36\x00\x6d\x00\x29\x01\x2a\x01\x2b\x01\x6d\x00\x6d\x00\x6d\x00\x6b\x00\x36\x01\x05\x01\x06\x01\x19\x01\x1a\x01\x67\x00\x36\x01\x1d\x01\x1e\x01\x73\x00\x0e\x01\x0f\x01\x4e\x00\x63\x00\x63\x00\x13\x01\x14\x01\x15\x01\x73\x00\x29\x01\x54\x00\x2b\x01\x08\x01\x09\x01\x0a\x01\x0b\x01\x73\x00\x0d\x01\x16\x00\x67\x00\x10\x01\x52\x00\x36\x01\x13\x01\x14\x01\x15\x01\x6d\x00\x4a\x00\x4a\x00\x6b\x00\x2c\x01\x2d\x01\x85\x00\x2f\x01\x30\x01\x4a\x00\x4a\x00\x6d\x00\x6d\x00\x5f\x00\x36\x01\x52\x00\x38\x01\x39\x01\xc3\x00\xc4\x00\x3c\x01\x74\x00\x2c\x01\xc8\x00\x54\x00\x74\x00\x30\x01\xcc\x00\x18\x00\x73\x00\x4d\x00\xd0\x00\x36\x01\xd2\x00\x4d\x00\x39\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4a\x00\xda\x00\xdb\x00\xdc\x00\xc8\x00\x4a\x00\x83\x00\x4a\x00\xcc\x00\x4a\x00\x4a\x00\x77\x00\xd0\x00\x83\x00\xd2\x00\x4e\x00\x73\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4a\x00\x4a\x00\xdb\x00\xdc\x00\x1e\x00\x6c\x00\x0b\x00\x96\x00\x72\x00\x18\x00\x18\x00\x9a\x00\x15\x00\x9c\x00\x4a\x00\x6d\x00\x9f\x00\xa0\x00\xa1\x00\x73\x00\xa3\x00\xa4\x00\x18\x00\x05\x01\x06\x01\x6b\x00\x67\x00\x74\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x0e\x01\x0f\x01\x61\x00\x18\x00\x4a\x00\x13\x01\x14\x01\x15\x01\x60\x00\x52\x00\x6d\x00\x73\x00\x05\x01\x06\x01\x4e\x00\x18\x00\x57\x00\x18\x00\x07\x00\xa4\x00\x19\x00\x0e\x01\x0f\x01\x4a\x00\x6b\x00\x96\x00\x13\x01\x14\x01\x15\x01\xcc\x00\x2c\x01\x2d\x01\x52\x00\x2f\x01\x30\x01\x60\x00\x4b\x00\xa2\x00\xa3\x00\xa4\x00\x36\x01\x61\x00\x38\x01\x39\x01\xdb\x00\x72\x00\x3c\x01\x73\x00\x72\x00\x67\x00\x67\x00\x2c\x01\x2d\x01\x80\x00\x2f\x01\x30\x01\x52\x00\x72\x00\x4d\x00\xcc\x00\x6d\x00\x36\x01\x96\x00\x38\x01\x39\x01\x6b\x00\x9a\x00\x3c\x01\x9c\x00\x18\x00\x18\x00\x9f\x00\xa0\x00\xa1\x00\xdb\x00\xa3\x00\xa4\x00\x6d\x00\x67\x00\xcc\x00\x6d\x00\x0a\x01\x0b\x01\x72\x00\x0d\x01\x18\x00\x52\x00\x10\x01\x4e\x00\x96\x00\x13\x01\x14\x01\x15\x01\x9a\x00\xdb\x00\x9c\x00\x2b\x00\x72\x00\x9f\x00\xa0\x00\xa1\x00\x4a\x00\xa3\x00\xa4\x00\x19\x00\x4d\x00\x19\x01\x1a\x01\x4a\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x52\x00\x2c\x01\xcc\x00\x07\x00\x61\x00\x30\x01\x18\x00\x07\x00\x29\x01\x2a\x01\x2b\x01\x36\x01\x18\x00\x83\x00\x39\x01\x4d\x00\x6b\x00\xdb\x00\x4d\x00\x83\x00\x6d\x00\x36\x01\x19\x01\x1a\x01\x4e\x00\x73\x00\x1d\x01\x1e\x01\x54\x00\xcc\x00\x72\x00\x72\x00\x6c\x00\x07\x00\x21\x00\x31\x00\x57\x00\x61\x00\x29\x01\x57\x00\x2b\x01\x19\x00\x19\x01\x1a\x01\xdb\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x73\x00\x36\x01\x08\x00\x3b\x00\x4c\x00\x2c\x00\x6c\x00\x6a\x00\x29\x01\x2a\x01\x2b\x01\x61\x00\x54\x00\x6d\x00\x6f\x00\x73\x00\x58\x00\x6d\x00\x57\x00\xc9\x00\x5c\x00\x36\x01\x67\x00\x72\x00\x10\x00\x61\x00\x6d\x00\x97\x00\x67\x00\x19\x01\x1a\x01\x9b\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x6d\x00\x6d\x00\x6d\x00\x15\x00\x73\x00\x6d\x00\x73\x00\x67\x00\x29\x01\x2a\x01\x2b\x01\x78\x00\x79\x00\x44\x00\x4d\x00\x7c\x00\x7d\x00\x4d\x00\x52\x00\x19\x01\x1a\x01\x36\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x6c\x00\x52\x00\x02\x00\x18\x00\x6c\x00\x52\x00\x02\x00\x18\x00\x29\x01\x2a\x01\x2b\x01\x4c\x00\x18\x00\x78\x00\x07\x00\x6c\x00\xcc\x00\x6d\x00\xce\x00\xcf\x00\xd0\x00\x36\x01\xd2\x00\x6c\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x07\x00\xdb\x00\xdc\x00\x17\x01\x78\x00\x73\x00\x6d\x00\xe1\x00\xe2\x00\x12\x00\x2e\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x24\x01\x9c\x00\x26\x01\x27\x01\x9f\x00\xa0\x00\xa1\x00\x3f\x01\xa3\x00\xa4\x00\x9d\x00\x3e\x01\xf9\x00\x31\x01\x3e\x01\x33\x01\x34\x01\x35\x01\xad\x00\x37\x01\xdf\x00\x3a\x00\x3a\x01\x3b\x01\x61\x00\xf9\x00\xf9\x00\x05\x01\x06\x01\x82\x00\x8c\x00\x2f\x00\x3e\x01\x3e\x01\x82\x00\x3d\x01\x0e\x01\x0f\x01\x82\x00\x31\x00\x86\x00\x13\x01\x14\x01\x15\x01\x8d\x00\x17\x01\x97\x00\x49\x00\x8d\x00\xcc\x00\x9b\x00\x9d\x00\x89\x00\x83\x00\xae\x00\x91\x00\x61\x00\x7f\x00\x7f\x00\x25\x01\x26\x01\x7d\x00\x28\x01\x86\x00\xdb\x00\xdd\x00\x43\x01\x2d\x01\x42\x01\x2f\x01\x30\x01\xd3\x00\x32\x01\x33\x01\x34\x01\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\x82\x00\x3d\x01\x3f\x01\x82\x00\x41\x01\x1f\x00\x1f\x00\x2e\x00\x45\x01\x03\x00\x0a\x00\x48\x01\xf1\x00\x43\x01\x4b\x01\x71\x00\xcc\x00\x3d\x01\xce\x00\xcf\x00\xd0\x00\x5c\x00\xd2\x00\x05\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x3d\x01\xdb\x00\xdc\x00\x82\x00\x18\x01\x19\x01\x1a\x01\xe1\x00\xe2\x00\x1d\x01\x1e\x01\x89\x00\x3d\x01\x19\x01\x1a\x01\x3d\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x29\x01\x8a\x00\x2b\x01\x4c\x00\x4d\x00\x5d\x00\x39\x01\x7f\x00\x29\x01\x2a\x01\x2b\x01\x7d\x00\x7b\x00\x36\x01\x89\x00\x58\x00\x30\x00\x1f\x00\x1f\x00\x5c\x00\x2a\x00\x36\x01\x05\x01\x06\x01\x61\x00\x20\x01\x33\x00\x6b\x00\x89\x00\x4e\x00\x3f\x01\x0e\x01\x0f\x01\x66\x00\x75\x00\x49\x00\x13\x01\x14\x01\x15\x01\x79\x00\x17\x01\x97\x00\x70\x00\x74\x00\xb3\x00\x9b\x00\x2a\x00\x78\x00\x79\x00\x0f\x00\x1b\x00\x7c\x00\x7d\x00\x3d\x01\x25\x01\x26\x01\x1b\x00\x28\x01\x3d\x01\xd3\x00\x79\x00\xc1\x00\x2d\x01\xb3\x00\x2f\x01\x30\x01\x74\x00\x32\x01\x33\x01\x34\x01\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xf1\x00\xb1\x00\x3f\x01\x51\x00\x41\x01\x32\x00\x16\x00\x16\x00\x45\x01\x2a\x00\x24\x00\x48\x01\x52\x00\x56\x00\x4b\x01\x4b\x00\xcc\x00\x3e\x01\xce\x00\xcf\x00\xd0\x00\x3d\x01\xd2\x00\x3e\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x3d\x01\x2f\x00\xdb\x00\xdc\x00\x11\x00\x3e\x01\x0c\x00\x82\x00\xe1\x00\xe2\x00\x57\x00\x3e\x01\x41\x01\x5e\x00\x3d\x01\x92\x00\x93\x00\x3d\x01\x57\x00\x96\x00\x97\x00\x3d\x01\x99\x00\x9a\x00\x31\x00\x9c\x00\xa4\x00\x3d\x01\x9f\x00\xa0\x00\xa1\x00\x33\x00\xa3\x00\xa4\x00\x0d\x01\xa6\x00\x3d\x01\x10\x01\x3d\x01\x61\x00\x13\x01\x14\x01\x15\x01\x5c\x00\x05\x01\x06\x01\x5e\x00\x82\x00\x1f\x00\x1f\x00\x34\x00\x16\x00\x16\x00\x0e\x01\x0f\x01\x3e\x01\x3e\x01\x3e\x01\x13\x01\x14\x01\x15\x01\xb3\x00\x17\x01\x97\x00\x24\x00\x2c\x01\xcc\x00\x9b\x00\x3e\x01\x30\x01\x3e\x01\x3e\x01\xff\xff\xcc\x00\xff\xff\x36\x01\x25\x01\x26\x01\x39\x01\x28\x01\xff\xff\xdb\x00\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xdb\x00\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xff\xff\x3f\x01\xff\xff\x41\x01\xff\xff\xff\xff\xff\xff\x45\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\x05\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xa4\x00\xff\xff\xe1\x00\xff\xff\xff\xff\xff\xff\xe5\x00\xe6\x00\x19\x01\x1a\x01\xff\xff\xff\xff\x1d\x01\x1e\x01\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\x29\x01\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\x36\x01\x05\x01\x06\x01\xcc\x00\xff\xff\x97\x00\xff\xff\x36\x01\xff\xff\x9b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xdb\x00\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xa4\x00\xff\xff\xe1\x00\x19\x01\x1a\x01\xe4\x00\xff\xff\x1d\x01\x1e\x01\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x07\x01\x08\x01\x09\x01\x0a\x01\x0b\x01\xff\xff\x0d\x01\xff\xff\xff\xff\x10\x01\x36\x01\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xcc\x00\xff\xff\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xdb\x00\x17\x01\xff\xff\xff\xff\x2c\x01\xff\xff\xff\xff\xff\xff\x30\x01\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\x25\x01\x26\x01\x39\x01\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe1\x00\x19\x01\x1a\x01\xe4\x00\xff\xff\x1d\x01\x1e\x01\xa4\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\xff\xff\x1d\x01\x1e\x01\xff\xff\x29\x01\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\x96\x00\xdb\x00\xdc\x00\xff\xff\x9a\x00\xff\xff\xff\xff\xe1\x00\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\xba\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\x96\x00\xdb\x00\xdc\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\xe1\x00\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\x29\x01\x2a\x01\x2b\x01\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\x96\x00\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\x9c\x00\xe1\x00\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\x96\x00\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\x9c\x00\xe1\x00\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\xff\xff\xff\xff\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\x0e\x01\x0f\x01\x61\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\x74\x00\x13\x01\x14\x01\x15\x01\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x2d\x01\x97\x00\x2f\x01\x30\x01\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\x45\x01\xff\xff\x36\x01\x48\x01\x38\x01\x39\x01\x4b\x01\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\x0c\x01\x0d\x01\xff\xff\xff\xff\x10\x01\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\x2c\x01\x13\x01\x14\x01\x15\x01\x30\x01\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\x39\x01\xff\xff\x9b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x2d\x01\x97\x00\x2f\x01\x30\x01\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x45\x01\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\x4b\x01\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\x0e\x01\x0f\x01\x61\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\x74\x00\x13\x01\x14\x01\x15\x01\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x2d\x01\x97\x00\x2f\x01\x30\x01\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\x45\x01\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x4b\x01\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x05\x01\x06\x01\xff\xff\xa8\x00\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xbb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xcc\x00\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xdb\x00\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x45\x01\x4c\x00\x4d\x00\xff\xff\xff\xff\x36\x01\x4b\x01\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\x45\x01\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x4b\x01\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x74\x00\xff\xff\x5c\x00\xff\xff\x78\x00\x79\x00\xff\xff\x61\x00\x7c\x00\x7d\x00\x96\x00\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x74\x00\x29\x01\x2a\x01\x2b\x01\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x3f\x01\x9c\x00\x41\x01\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xa8\x00\xa9\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xdb\x00\x9c\x00\xff\xff\x58\x00\x9f\x00\xa0\x00\xa1\x00\x5c\x00\xa3\x00\xa4\x00\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xdb\x00\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xcc\x00\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xdb\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x05\x01\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\x31\x01\xff\xff\x33\x01\x34\x01\x35\x01\xff\xff\x37\x01\xff\xff\x36\x01\x3a\x01\x3b\x01\xff\xff\xcc\x00\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x3f\x01\xff\xff\x41\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x34\x01\x35\x01\x36\x01\x37\x01\xff\xff\x97\x00\x3a\x01\x3b\x01\xff\xff\x9b\x00\xff\xff\x3f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\xff\xff\x10\x01\x36\x01\x97\x00\x13\x01\x14\x01\x15\x01\x9b\x00\xff\xff\xff\xff\xff\xff\x3f\x01\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\x2c\x01\xff\xff\xff\xff\xff\xff\x30\x01\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\x36\x01\xd2\x00\xff\xff\x39\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\x97\x00\x13\x01\x14\x01\x15\x01\x9b\x00\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x97\x00\xff\xff\x3c\x01\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xdb\x00\x3c\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x92\x00\x93\x00\x3c\x01\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xa6\x00\xff\xff\xff\xff\x0c\x01\x0d\x01\x05\x01\xff\xff\x10\x01\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\x2c\x01\xff\xff\xff\xff\xcc\x00\x30\x01\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\x36\x01\xff\xff\xff\xff\x39\x01\xff\xff\xff\xff\x92\x00\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\xff\xff\xff\xff\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x23\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\x2c\x01\xff\xff\xcc\x00\xff\xff\x30\x01\x29\x01\x2a\x01\x2b\x01\x34\x01\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xa5\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xa5\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\x96\x00\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xba\x00\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\x36\x01\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\x4b\x00\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x67\x00\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x69\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x00\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\x00\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\x40\x00\x41\x00\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xa7\x00\xa8\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xcc\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xdb\x00\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\x9c\x00\xa3\x00\xa4\x00\x9f\x00\xa0\x00\xa7\x00\xa8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xac\x00\xad\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\x05\x01\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xa8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\x05\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xa8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xdb\x00\x9c\x00\xff\xff\x36\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xa8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x05\x01\xff\xff\xff\xff\xa8\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xdb\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\x05\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xb2\x00\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xf6\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\x05\x01\x06\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x19\x01\x1a\x01\x3c\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x01\x29\x01\x2a\x01\x2b\x01\x4d\x01\xff\xff\x4f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xf6\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\x05\x01\x06\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\x05\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x19\x01\x1a\x01\x3c\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x01\x29\x01\x2a\x01\x2b\x01\x4d\x01\xff\xff\x4f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xdb\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\x19\x01\x1a\x01\xdb\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\x36\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xdb\x00\x9c\x00\xff\xff\x36\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xdb\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\x05\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\x01\x00\x02\x00\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\x09\x00\x0a\x00\x36\x01\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xff\xff\x13\x00\x76\x00\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\x42\x00\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\x63\x00\x64\x00\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\x13\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\x13\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\x64\x00\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\x64\x00\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\x64\x00\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x08\x01\x09\x01\x0a\x01\x0b\x01\xff\xff\x0d\x01\xff\xff\xff\xff\x10\x01\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x2c\x01\xff\xff\xff\xff\xff\xff\x30\x01\xff\xff\xff\xff\xff\xff\x34\x01\x35\x01\x36\x01\x37\x01\xff\xff\x39\x01\x6a\x00\x3b\x01\x6c\x00\xff\xff\x6e\x00\x3f\x01\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\x71\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\x3d\x01\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x47\x01\xff\xff\xff\xff\x4a\x01\xff\xff\x4c\x01\xff\xff\x4e\x01\xff\xff\x50\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x47\x01\xff\xff\xff\xff\x4a\x01\xff\xff\x4c\x01\xff\xff\x4e\x01\xff\xff\x50\x01\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x47\x01\xff\xff\xff\xff\x4a\x01\xff\xff\x4c\x01\xff\xff\x4e\x01\xff\xff\x50\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\x44\x01\xff\xff\xff\xff\x47\x01\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\xff\xff\x50\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\x3d\x01\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x01\xff\xff\xff\xff\xff\xff\x4d\x01\xff\xff\x4f\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\x15\x00\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x4f\x01\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x83\x00\x84\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x83\x00\x84\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x83\x00\x84\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x76\x00\x77\x00\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x83\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x83\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\x83\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe7\x00\xe8\x00\xe9\x00\xea\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xe8\x00\xe9\x00\xea\x00\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\x44\x01\xff\xff\xfc\x00\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\x44\x01\xfb\x00\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\x44\x01\xfa\x00\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\x44\x01\xfa\x00\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xd8\x00\x38\x01\x39\x01\xdb\x00\xdc\x00\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xeb\x00\xec\x00\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xfe\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xeb\x00\xec\x00\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\x00\xff\xff\xff\xff\xef\x00\xf0\x00\xf1\x00\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x44\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x4c\x01\xff\xff\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xfe\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x44\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x4c\x01\xff\xff\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xfe\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x44\x01\xff\xff\xff\xff\x47\x01\x36\x01\xff\xff\x38\x01\x39\x01\x4c\x01\xff\xff\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x44\x01\xff\xff\xff\xff\x47\x01\x36\x01\xff\xff\x38\x01\x39\x01\x4c\x01\xff\xff\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\x1b\x00\x1c\x00\x1d\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x09\x00\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x01\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x02\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x74\x00\xff\xff\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\x76\x00\x77\x00\x78\x00\x79\x00\xff\xff\x7b\x00\x15\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd1\x00\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd1\x00\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\x46\x01\x36\x01\x02\x00\x38\x01\x39\x01\x05\x00\x06\x00\x3c\x01\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x01\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\x73\x00\x09\x00\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\x09\x00\xff\xff\xff\xff\xff\xff\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x09\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\x15\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x09\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\x15\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x09\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\x15\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x09\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\x15\x00\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\x15\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\x7a\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x76\x00\xff\xff\xff\xff\xff\xff\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x02\x00\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\x09\x00\x73\x00\xff\xff\xff\xff\x76\x00\x77\x00\x78\x00\x79\x00\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x66\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x76\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\x76\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x15\x00\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x66\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\x73\x00\xff\xff\xff\xff\x76\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\xff\xff\x09\x00\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xf6\x00\xf7\x00\xf8\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\x76\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xde\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xcc\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xcc\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xcc\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x73\x00\xa4\x05\xa5\x05\xa7\x05\xa8\x05\x51\x01\x38\x01\xd9\x05\xd9\x00\xcb\x04\xe0\x05\xdb\x05\x76\x05\x48\x02\xdc\x05\x1d\x05\x36\x02\x1c\x05\x37\x02\x35\x05\xd7\x05\x1d\x05\x36\x02\x9f\x05\x37\x02\xed\x03\xe6\x04\x1d\x05\x36\x02\x34\x03\x37\x02\x35\x02\x36\x02\x36\x02\x37\x02\x33\x04\xdd\x03\x47\x05\x57\x01\x48\x05\x73\x03\xcd\x03\xce\x03\x8c\x03\xab\x03\x5f\x04\xce\x03\x33\x02\xe7\x05\x34\x01\x33\x02\x72\x04\xfa\x00\x71\x03\x17\x01\xb2\x02\xb3\x02\xda\x00\x0c\x02\x0d\x02\x0e\x02\x0f\x02\xd1\x05\x49\x05\x4f\x05\xe1\x05\x33\x02\x35\x01\x30\x03\xdb\x02\xc6\x04\xb0\x03\x6a\x05\x6b\x05\x6c\x05\x6d\x05\xb3\x04\x2a\x02\x33\x02\x13\x01\x11\x05\xb2\x02\xb3\x02\x57\x03\xc7\x05\x6d\x05\xb3\x04\x2a\x05\xce\x03\x30\x01\x33\x02\x27\x02\x30\x01\x76\x03\x5b\x05\xa6\x04\x8d\x02\xe8\x05\xb3\x04\x11\x00\x58\x03\x59\x03\x33\x02\x44\x03\xd2\x05\x31\x03\xa3\x03\xe8\x05\xb3\x04\x1a\x03\xe8\x04\x49\x00\xe9\x05\xea\x05\xeb\x05\x12\x05\x13\x05\xa8\x02\xa8\xfe\xe8\x05\xb3\x04\x7f\x03\xf9\x05\xea\x05\xeb\x05\xd5\x01\xdc\x02\x49\x04\xb1\x03\xb2\x04\xb3\x04\x77\x03\x78\x03\x90\x04\x1b\x03\xac\x03\xff\x05\x10\x02\x18\x01\x4e\x00\x02\x02\x33\x02\x73\x04\x45\x03\xc1\x02\x4b\x05\xe7\x04\xe8\x05\xd5\x01\xfd\x00\x4f\x00\xb0\xfe\x34\x02\x93\x00\xb2\xfe\x34\x02\xe2\x05\xc3\x02\xa8\xfe\x96\x00\x8d\x03\x35\x02\x98\x00\x99\x00\x9a\x00\x9b\x00\xa7\x02\xc4\x02\xc5\x02\xc6\x02\xbf\x02\x34\x02\x8e\x02\x58\x01\x39\x01\x3a\x01\x11\x01\x76\x00\x25\x01\x78\x00\x03\x02\x04\x02\x05\x02\x34\x02\xa4\x03\x10\x02\x59\x01\x4e\x00\x5a\x01\x5b\x01\xa7\x04\xb0\xfe\xe8\x03\xa1\x02\xb2\xfe\x34\x02\x4a\x01\x4b\x01\x4f\x00\x7b\x00\xa2\x02\x7c\x00\x7d\x00\x7e\x00\xd9\x03\x7f\x00\x3b\x01\x34\x02\x82\x00\x83\x00\xa2\x00\xa3\x00\x11\x00\x52\x01\x49\x00\x28\x01\xd7\x03\xcf\x03\xb5\x02\xa4\x00\x75\x00\xcf\x03\xa6\x03\x11\x00\x76\x00\x77\x00\x78\x00\x11\x00\x35\x03\xcc\x04\xcc\x04\x77\x05\x3f\x03\xa3\x02\x11\x00\x4a\x01\x4b\x01\xe8\x04\x49\x00\x35\x03\x4f\x00\x4f\x00\x4f\x00\xa9\xff\xb4\x02\x11\x00\x34\x02\x72\x03\x28\x03\xdd\x00\xa5\x00\x27\x01\x0f\x00\xde\x00\xde\x03\x3f\x05\x02\x02\x11\x00\xa8\x02\x11\x00\xa9\x02\x80\x00\x81\x00\xcf\x03\x72\x03\xa6\x00\xdf\x03\xe0\x03\x27\x01\x11\x00\x74\x00\x75\x00\x40\x03\xff\xff\x11\x00\x76\x00\x77\x00\x78\x00\x79\x03\x79\x00\x0e\x03\x33\x02\x27\x01\x37\x00\xef\x01\x7e\x00\x29\x03\x7f\x00\x11\x00\x79\x03\x79\x03\x31\x03\x06\x02\x27\x01\x27\x01\x7a\x00\x27\x01\x20\x04\x05\x02\x11\x00\x11\x00\x0e\x00\x11\x00\x0f\x00\x10\x00\x7b\x00\xa6\x05\x7c\x00\x7d\x00\x7e\x00\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa9\x05\x38\x02\xb4\x04\xa9\x05\xb5\x04\x49\x00\x06\x02\x38\x02\xa6\x05\xcd\x02\x27\x01\xff\xff\xb4\x04\x38\x02\xb5\x04\x49\x00\x11\x00\x38\x02\x38\x02\x1d\x01\xb6\x04\x33\x02\x0f\x00\x10\x00\xb4\x04\x3d\x03\xb5\x04\x49\x00\x32\x00\x11\x00\xb6\x04\x33\x02\x0f\x00\x10\x00\xb4\x04\x85\x00\xb5\x04\x49\x00\x19\x01\x11\x00\x40\x01\x33\x02\xb6\x04\x23\x04\x0f\x00\x10\x00\xb4\x04\xca\x01\xb5\x04\x49\x00\x34\x01\x11\x00\xb6\x04\xea\x04\x0f\x00\x10\x00\xb4\x04\x4c\xff\xb5\x04\x49\x00\xcb\x01\x11\x00\xff\xff\x33\x00\xb6\x04\x3e\x03\x0f\x00\x10\x00\x35\x01\x24\x04\x34\x02\x7b\x05\x79\x05\x11\x00\xb6\x04\x33\x03\x0f\x00\x10\x00\xd9\x00\x1c\x05\x90\x00\xeb\x04\xec\x04\x11\x00\xaa\x04\xab\x04\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xd7\x02\xf5\x00\x06\x02\xb2\x05\x0f\x02\x4c\xff\x27\x01\x4a\x02\x0d\x02\x0e\x02\x0f\x02\xdd\x03\x11\x00\x09\x05\xa3\x04\xa4\x04\xa5\x04\xa6\x04\xf6\x00\xf7\x00\x7b\x01\x0c\x02\x34\x00\x34\x01\x3a\x04\x7f\x02\x51\x02\xf8\x00\xf9\x00\x37\x00\x46\x03\xd8\x02\xfa\x00\x47\x03\x0a\x05\x41\x01\x34\x02\xda\x00\x42\x01\x3e\x00\x3f\x00\x35\x01\x40\x00\x41\x00\xd9\x02\x7f\x05\x34\x02\xef\x02\x37\x00\x53\x02\x52\x02\x61\x02\xed\x04\x80\x01\x24\x03\xd9\x03\x34\x02\x42\x01\x3e\x00\x3f\x00\xd7\x02\x40\x00\x41\x00\x65\x00\x53\x02\xc1\x05\xd9\x00\x69\x00\xfb\x00\x80\x02\x81\x02\x0f\x00\x82\x02\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x11\x00\xf5\x00\xce\x02\x75\x00\x58\x00\x42\x00\x62\x02\x76\x00\x77\x00\x78\x00\x4c\x02\xb9\x02\x4b\x00\xd8\x02\xaa\xfe\x86\xfc\x59\x00\x86\xfc\xf6\x00\xf7\x00\x43\x00\x17\xff\x5f\x03\x4d\x02\x42\x00\x5d\x00\x6d\x03\xf8\x00\xf9\x00\x7d\x02\x7e\x02\x7f\x02\xfa\x00\xcf\x02\xa7\x04\x0f\x00\x10\x00\xda\x00\x54\x01\x43\x00\x51\x04\x98\x05\x11\x00\xfd\x01\x80\x00\x81\x00\xfc\x00\x62\x01\x66\x00\x67\x00\x10\x02\xfd\x00\x4e\x00\x1c\x01\xaa\xfe\x93\x00\x10\x02\x1d\x01\x4e\x00\xfe\x00\x63\x05\x96\x00\x7b\x01\x4f\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xfb\x00\x4f\x00\x9c\x00\x9d\x00\xd5\x01\x52\x04\x62\x02\x80\x02\x81\x02\x0f\x00\x82\x02\x3c\x04\x3f\x01\x49\x03\x45\x00\x43\x01\x11\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x25\x02\xb9\x02\x65\x00\x10\x04\x86\xfc\x80\x01\x40\x01\x20\x02\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x5c\x02\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4a\x01\x4b\x01\x4f\x00\xa2\x00\xa3\x00\x99\x04\x39\x05\x37\x05\x4c\x00\x4d\x00\x4e\x00\x1f\x02\xa4\x00\x75\x00\x3d\x04\xfc\x00\x85\x02\x76\x00\x77\x00\x78\x00\xfd\x00\x4f\x00\x11\x00\x5d\x02\x93\x00\x87\x04\x0e\x02\x0f\x02\xfe\x00\x34\x00\x96\x00\x9a\x04\x18\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x38\x05\x4e\x01\x9c\x00\x9d\x00\x15\x02\xdd\x00\xa5\x00\x72\x02\x0f\x00\xde\x00\xaa\xff\x58\x01\x35\x00\x58\x02\x19\x01\x11\x00\xa9\x04\x80\x00\x81\x00\xbe\x01\x28\x04\xa6\x00\x09\x02\x29\x04\x59\x01\xd9\x00\x5a\x01\x5b\x01\x7b\x01\x4f\x01\x50\x01\x51\x01\xe5\x03\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x7b\x00\xf5\x00\x7c\x00\x7d\x00\x7e\x00\x0b\x02\x7f\x00\xa2\x00\xa3\x00\x82\x00\x83\x00\x83\x03\x0d\x02\x0e\x02\x0f\x02\x2a\x04\xa4\x00\x75\x00\xf6\x00\xf7\x00\xab\x02\x76\x00\x77\x00\x78\x00\x80\x01\x42\x00\xff\xff\xf8\x00\xf9\x00\x49\x02\x3d\x02\x4e\x00\xfa\x00\x67\x05\x36\x05\x37\x05\x6d\xfd\xda\x00\xce\x02\x75\x00\x43\x00\x35\x02\x4f\x00\x76\x00\x77\x00\x78\x00\xdd\x00\xa5\x00\x66\x05\x0f\x00\xde\x00\x87\x00\x19\x01\x85\x00\xd9\x01\x88\x00\x11\x00\x5a\x02\x80\x00\x81\x00\x89\x00\x7c\x01\xa6\x00\x5b\x02\x58\x00\x38\x05\xd9\x00\x19\x01\xfb\x00\xcf\x02\x26\x02\x0f\x00\x10\x00\xaf\x05\x37\x05\x79\xfe\x59\x00\x10\x02\x11\x00\x4e\x00\x80\x00\x81\x00\x79\xfe\x8f\x00\x27\x02\x5d\x00\x7f\x01\x92\x00\x78\x05\x79\x05\x4f\x00\xf0\x02\x80\x01\x4f\x03\x50\x03\x47\x05\x87\x00\x48\x05\x90\x00\x79\xfe\x88\x00\xf1\x02\x45\x00\x46\x00\x38\x05\x89\x00\x48\x00\x49\x00\x66\x00\x67\x00\xfa\x00\x2d\x02\x6a\x00\x6b\x00\xf3\x02\xda\x00\xf3\x01\x49\x00\x4c\x00\xff\xff\x4e\x00\x49\x05\x4a\x05\xe7\x03\xfc\x00\x2e\x02\x2f\x02\x53\x03\x8f\x00\xfd\x00\xf4\x01\x4f\x00\xda\x01\x93\x00\xe8\x03\xdb\x01\x19\x05\xfe\x00\x10\x02\x96\x00\x4e\x00\x4f\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x54\x03\x55\x03\x9c\x00\x9d\x00\x27\x02\x4f\x00\x79\xfe\x79\xfe\xea\x01\x37\x00\xd8\x03\x79\xfe\xeb\x01\x1c\x02\x1d\x02\x24\x03\xd8\x01\x18\x05\x42\x01\x3e\x00\x3f\x00\xd9\x03\x40\x00\x41\x00\x22\x03\x8a\x00\x9c\x01\x84\x01\x54\x02\x8c\x00\x1e\x02\x27\x02\x79\xfe\x08\x02\x79\xfe\x65\x00\x55\x02\xee\x01\x8e\x00\x69\x00\xed\x04\x27\x01\x91\x00\x79\xfe\xa2\x00\xa3\x00\x57\x02\x11\x00\xd9\x00\x80\x00\x81\x00\x65\x00\x58\x02\xa4\x00\x75\x00\x69\x00\xc1\x02\x4b\x05\x76\x00\x77\x00\x78\x00\xfd\x00\x1d\x04\x42\x00\xd6\x05\x93\x00\x27\x01\x4a\x01\x4b\x01\xc3\x02\xd7\x05\x96\x00\x11\x00\x42\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x43\x00\xc4\x02\xc5\x02\xc6\x02\x99\x01\xdd\x00\xa5\x00\xf3\x02\x0f\x00\xde\x00\x43\x00\x58\x01\x79\xfe\xef\xfc\xfa\x00\x11\x00\x5e\x04\x80\x00\x81\x00\xda\x00\x61\x01\xa6\x00\x11\x00\x7a\x04\xf4\x02\x4e\x00\x5a\x01\x5b\x01\x8e\x04\xca\x02\x93\x01\x3a\x01\x27\x01\x76\x00\x25\x01\x78\x00\x4f\x00\x7b\x00\x11\x00\x7c\x00\x7d\x00\x7e\x00\xff\xff\x7f\x00\xa2\x00\xa3\x00\x82\x00\x83\x00\x83\x04\x70\x04\x0d\x02\x0e\x02\x0f\x02\xa4\x00\x75\x00\xff\xff\x84\x04\xb9\x01\x76\x00\x77\x00\x78\x00\x80\x01\x45\x00\x46\x00\xd6\x03\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x23\x03\x28\x01\x45\x00\x46\x00\x3e\x05\xd7\x03\x48\x00\x49\x00\x4c\x00\x4d\x00\x4e\x00\x1b\x05\x5f\x01\xdd\x00\xa5\x00\x3f\x05\x0f\x00\xde\x00\x4c\x00\xd9\x00\x4e\x00\x4f\x00\x1c\x05\x11\x00\x16\xff\x80\x00\x81\x00\x7e\x05\x74\x05\xa6\x00\x38\x01\x4f\x00\xee\x04\x0d\x02\x0e\x02\x0f\x02\xc1\x02\xc2\x02\x7f\x05\xd9\x03\xdd\xfd\xfd\x00\xdd\xfd\x21\x01\xdd\xfd\x93\x00\x65\x00\x38\x03\x91\x02\xc3\x02\x69\x00\x96\x00\x39\x03\xdd\xfd\x98\x00\x99\x00\x9a\x00\x9b\x00\x58\x01\xc4\x02\xc5\x02\xc6\x02\x84\xfc\xfa\x00\xe7\x01\x83\x00\x37\x00\xfe\x02\xda\x00\xe8\x01\xc0\x05\x59\x01\x24\x03\x5a\x01\x5b\x01\x42\x01\x3e\x00\x3f\x00\xc0\x02\x40\x00\x41\x00\xc1\x05\xff\xff\x85\x00\x7b\x00\xc4\x04\x7c\x00\x7d\x00\x7e\x00\xff\xff\x7f\x00\x5f\x05\x75\x00\x82\x00\x83\x00\x87\x00\x76\x00\x77\x00\x78\x00\x88\x00\xcb\x02\xc8\x02\xc9\x02\xa3\x00\x89\x00\x8d\x04\x10\x02\x31\x02\x4e\x00\x27\x01\x4d\x03\xa4\x00\x75\x00\x85\x00\xc3\x05\x11\x00\x76\x00\x77\x00\x78\x00\x4f\x00\x42\x00\x7c\x01\xe6\x02\x5e\x01\x85\x02\x4f\x00\x57\x03\x8f\x00\x90\x00\xd3\x05\x11\x00\x92\x00\x93\x00\x80\x00\x81\x00\x43\x00\x8a\x00\xd4\x05\x3d\x01\x34\x03\x8c\x00\xdd\x00\xa5\x00\xd9\x00\x0f\x00\xde\x00\x7f\x01\x4d\x02\x7e\x00\x8e\x00\x7f\x00\x11\x00\x80\x01\x80\x00\x81\x00\xc1\x02\xc2\x02\xa6\x00\x90\x00\x10\x02\xfd\x00\x4e\x00\x93\x00\x84\x02\x93\x00\x85\x02\x3f\x05\x27\x03\xc3\x02\xd6\x04\x96\x00\x11\x00\x4f\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x43\x03\xc4\x02\xc5\x02\xc6\x02\xe6\x01\xb9\x01\x7e\x00\x39\x03\x7f\x00\x3a\x03\xfa\x00\xe7\x01\x83\x00\x64\x02\x30\x01\xda\x00\xe8\x01\xd7\x04\xdd\x04\x11\x00\x45\x00\x46\x00\x75\x03\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x81\x01\x75\x00\xae\x03\xaf\x03\x82\x01\x76\x00\x77\x00\x78\x00\x4c\x00\x4d\x00\x4e\x00\xbd\x03\x2e\x00\x85\x02\xc7\x02\xc8\x02\xc9\x02\xa3\x00\x2f\x00\x11\x00\x30\x00\x4f\x00\x4a\x01\x4b\x01\x1c\x01\xa4\x00\x75\x00\x37\x00\x1d\x01\x17\x03\x76\x00\x77\x00\x78\x00\x40\x05\x13\x03\x0d\x03\x42\x01\x3e\x00\x3f\x00\x0e\x03\x40\x00\x41\x00\x80\x00\x81\x00\x93\x01\xd4\x03\x11\x03\x76\x00\x25\x01\x78\x00\xe6\x01\xb9\x01\x7e\x00\x86\x05\x7f\x00\xdd\x00\xa5\x00\x5d\x05\x0f\x00\xde\x00\xd9\x00\x0e\x00\x75\x02\x0f\x00\x10\x00\x11\x00\x58\x02\x80\x00\x81\x00\x87\x00\x11\x00\xa6\x00\x0f\x03\x88\x00\xc1\x02\xd9\x04\x13\x01\x14\x01\x89\x00\xfd\x00\x15\x01\x42\x00\x64\x02\x93\x00\x61\x01\x28\x01\xd6\x04\xc3\x02\x11\x00\x96\x00\xe4\x01\x81\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x43\x00\xc4\x02\xc5\x02\xc6\x02\xfe\x02\x8f\x00\x5e\x05\x02\x03\xfa\x00\x92\x00\x5f\x05\x4d\x02\x7e\x00\xda\x00\x7f\x00\xd7\x04\xd8\x04\x91\x01\xdd\x02\x0f\x00\x10\x00\x20\x03\xe8\x01\x37\x00\x48\x00\x49\x00\x11\x00\xff\x02\x97\x01\x24\x03\x98\x01\x85\x00\x42\x01\x3e\x00\x3f\x00\xe3\x02\x40\x00\x41\x00\xa0\x01\x7c\x01\xa1\x01\xe1\x02\xa2\x01\x87\x00\xa2\x00\xa3\x00\xee\x02\x88\x00\x22\x05\xe4\x02\x85\x02\x65\x00\x89\x00\xa4\x00\x75\x00\x69\x00\x11\x00\x5e\x02\x76\x00\x77\x00\x78\x00\x58\x02\x45\x00\x46\x00\x7f\x01\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x80\x01\x1d\x03\x1e\x03\x1f\x03\x20\x03\x8f\x00\x90\x00\x42\x00\x4c\x00\x4d\x00\x4e\x00\x87\x03\x88\x03\xdd\x00\xa5\x00\x80\x03\x0f\x00\xde\x00\x48\x00\x49\x00\x85\x00\x4f\x00\x43\x00\x11\x00\x8f\xfe\x80\x00\x81\x00\xd9\x00\x8f\xfe\xa6\x00\xc1\x02\xd9\x04\x87\x00\xae\x03\xaf\x03\xfd\x00\x88\x00\xe3\x01\x10\x00\x93\x00\xad\x01\x89\x00\xae\x01\xc3\x02\x11\x00\x96\x00\xe4\x01\x81\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x74\x02\xc4\x02\xc5\x02\xc6\x02\x47\x05\xa7\x01\x48\x05\xa8\x01\x5e\x01\x54\x01\xde\x03\x60\x05\x8f\x00\x90\x00\x48\x00\x49\x00\x92\x00\x93\x00\xec\x02\xfa\x00\xfa\x05\x75\x00\xfb\x04\xe0\x03\xda\x00\x76\x00\x77\x00\x78\x00\xdb\xfc\x97\x01\xbd\x05\x98\x01\x45\x00\x46\x00\x73\x02\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xef\x01\x7e\x00\x0d\x03\x7f\x00\xa2\x00\xa3\x00\x0e\x03\x31\x03\x4c\x00\x4d\x00\x4e\x00\x65\x00\x1c\x01\xa4\x00\x75\x00\x69\x00\x1d\x01\xea\x02\x76\x00\x77\x00\x78\x00\x4f\x00\x80\x00\x81\x00\x37\x00\x4d\x04\x46\x04\x47\x04\x55\x01\xd3\x01\x56\x01\xe8\x02\xdd\x02\x3d\x00\x3e\x00\x3f\x00\xe8\x01\x40\x00\x41\x00\x8b\x01\xdf\x02\x0f\x00\x10\x00\xdd\x00\xa5\x00\xe0\x02\x0f\x00\xde\x00\x11\x00\x9b\x02\xbc\x05\x9c\x02\x98\x02\x11\x00\x99\x02\x80\x00\x81\x00\xd9\x00\x85\x00\xa6\x00\x30\x01\x31\x01\x32\x01\xd1\x02\x93\x01\x8d\x05\xe2\x03\x76\x00\x25\x01\x78\x00\x87\x00\xc1\x02\x4b\x05\x9b\x02\x88\x00\x9c\x02\xfd\x00\xcd\x02\x42\x00\x89\x00\x93\x00\x4a\x01\x4b\x01\xd6\x04\xc3\x02\x79\x04\x96\x00\x7a\x04\x92\x02\x98\x00\x99\x00\x9a\x00\x9b\x00\x43\x00\xc4\x02\xc5\x02\xc6\x02\x97\x01\xe3\x03\x98\x01\xbc\x02\xfa\x00\x8f\x00\x90\x00\xb8\x02\x28\x01\xda\x00\x8a\x00\x8a\x05\x84\x01\xce\x01\x8c\x00\xc3\x03\x9d\x01\x46\x00\xa7\x02\x37\x00\x48\x00\x49\x00\x32\x04\x8e\x00\x33\x04\x24\x03\xb7\x02\x91\x00\x42\x01\x3e\x00\x3f\x00\xb2\x02\x40\x00\x41\x00\xb0\x02\xe4\x02\x10\x00\x2c\x01\x2d\x01\x2e\x01\xa2\x00\xa3\x00\x11\x00\xa4\x02\xe4\x01\x81\x00\x9b\x03\x9c\x03\x9d\x03\xa4\x00\x75\x00\x4f\x03\x50\x03\x42\x00\x76\x00\x77\x00\x78\x00\xa0\x02\x45\x00\x46\x00\x9f\x02\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x89\x05\x8a\x05\x43\x00\x09\x03\x0a\x03\x0b\x03\x9d\x02\x42\x00\x4c\x00\x4d\x00\x4e\x00\x89\x05\xb9\x05\xdd\x00\xa5\x00\x92\x02\x0f\x00\xde\x00\xd9\x00\xae\x03\xaf\x03\x4f\x00\x43\x00\x11\x00\x95\x02\x80\x00\x81\x00\x4a\x01\x4b\x01\xa6\x00\xc1\x02\xd9\x04\x45\x04\x46\x04\x47\x04\xfd\x00\xd3\x01\x25\x02\x23\x02\x93\x00\xe6\x01\xb9\x01\x7e\x00\xc3\x02\x7f\x00\x96\x00\x22\x02\x23\x02\x98\x00\x99\x00\x9a\x00\x9b\x00\x94\x02\xc4\x02\xc5\x02\xc6\x02\x2b\x03\x2c\x03\x2d\x03\x2e\x03\x2f\x03\xf8\x01\xfa\x00\xf9\x01\x45\x00\x46\x00\x93\x02\xda\x00\x48\x00\x49\x00\x88\x03\x89\x03\x8a\x03\x9f\x04\x0a\x03\x0b\x03\x16\x05\x58\x05\x17\x05\xe4\x04\x4c\x00\xe5\x04\x4e\x00\x85\x00\x45\x00\x46\x00\x91\x02\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xd1\x04\x4f\x00\xd2\x04\x87\x00\xa2\x00\xa3\x00\x74\x02\x88\x00\x4c\x00\x4d\x00\x4e\x00\x89\x02\x89\x00\xa4\x00\x75\x00\x94\x01\xcf\x01\x62\x04\x76\x00\x77\x00\x78\x00\x4f\x00\xd5\x01\x81\x01\x75\x00\x77\x02\xca\x05\xc2\x03\x76\x00\x77\x00\x78\x00\x5e\x01\x6a\x04\x6b\x04\x6c\x04\x8f\x00\x90\x00\x94\x01\x95\x01\x92\x00\x93\x00\x92\x01\x8d\x01\xdd\x00\xa5\x00\xd9\x00\x0f\x00\xde\x00\x65\x04\x66\x04\x67\x04\x76\x02\xc5\x04\x11\x00\xc6\x04\x80\x00\x81\x00\x73\x02\xb1\x04\xa6\x00\xb2\x04\x64\x02\xc1\x02\xc2\x02\x60\x02\x80\x00\x81\x00\xfd\x00\xb1\x02\x4b\x01\x4c\x01\x93\x00\xe5\x04\x6b\x04\x6c\x04\xc3\x02\x52\x05\x96\x00\x53\x05\x56\x02\x98\x00\x99\x00\x9a\x00\x9b\x00\x5f\x02\xc4\x02\xc5\x02\xc6\x02\x89\x02\xfa\x00\xd3\x01\xb1\x04\x37\x00\xb2\x04\xda\x00\x58\x01\x63\x02\x30\x01\x24\x03\x69\x03\x21\x01\x42\x01\x3e\x00\x3f\x00\x57\x05\x40\x00\x41\x00\x2c\x01\x59\x01\x66\x03\x5a\x01\x5b\x01\x8f\x01\x8d\x01\x58\x00\xdf\x04\x6b\x04\x6c\x04\x3c\x05\x6b\x04\x6c\x04\x7b\x00\xff\x01\x7c\x00\x7d\x00\x7e\x00\x59\x00\x7f\x00\xa2\x00\xa3\x00\x82\x00\x83\x00\xe8\x02\x8c\x01\x8d\x01\x5d\x00\x50\x02\xa4\x00\x75\x00\x4f\x02\x42\x00\x44\x02\x76\x00\x77\x00\x78\x00\x31\x02\x42\x00\xbb\x02\xf0\x05\x6b\x04\x6c\x04\x35\x01\x36\x01\x80\x01\x11\x01\x43\x00\xbe\x03\xbf\x03\x66\x00\x67\x00\x5c\x03\x43\x00\x6a\x00\x6b\x00\xd9\x00\x94\x01\x74\x04\xdd\x00\xa5\x00\x25\x02\x0f\x00\xde\x00\x42\x00\xf8\x05\x6b\x04\x6c\x04\x2b\x04\x11\x00\x25\x04\x80\x00\x81\x00\xc1\x02\xc2\x02\xa6\x00\x22\x04\xd9\x00\xfd\x00\x43\x00\xb9\x02\x4b\x00\x93\x00\x17\x04\x5a\x04\x5b\x04\xc3\x02\x18\x04\x96\x00\x13\x05\x0f\x05\x98\x00\x99\x00\x9a\x00\x9b\x00\xbb\xfc\xc4\x02\xc5\x02\xc6\x02\xda\xfc\xfa\x00\x0e\x05\x0f\x05\xd4\x04\x9d\x03\xda\x00\x62\x02\x62\x05\x49\x00\x45\x00\x46\x00\xad\x05\xbf\x03\x48\x00\x49\x00\x45\x00\x46\x00\xc2\xfc\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x2b\x05\x67\x04\x4c\x00\xda\x00\x4e\x00\xe4\x05\xe5\x05\xc3\xfc\x4c\x00\x4d\x00\x4e\x00\xd9\xfc\xbc\xfc\xbd\xfc\x16\x04\x4f\x00\xa2\x00\xa3\x00\x45\x00\x46\x00\x15\x04\x4f\x00\x48\x00\x49\x00\x14\x04\xa4\x00\x75\x00\x13\x04\x12\x04\xea\xfc\x76\x00\x77\x00\x78\x00\x0e\x04\x4c\x00\x0f\x04\x4e\x00\xc5\x03\x86\x01\x87\x01\x88\x01\x80\x01\x89\x01\x0d\x04\xe4\x03\x24\x01\x5c\x02\x4f\x00\x76\x00\x25\x01\x78\x00\x59\x02\xd4\x03\xd3\x03\xcc\x03\xdd\x00\xa5\x00\xcd\x03\x0f\x00\xde\x00\xca\x03\xc5\x03\xc9\x03\xc8\x03\x02\x03\x11\x00\x7b\x01\x80\x00\x81\x00\xc1\x02\x59\x04\xa6\x00\xc2\x03\x26\x01\xfd\x00\xbd\x03\xc1\x03\x27\x01\x93\x00\xa0\x03\xee\xfc\x9b\x03\xc3\x02\x11\x00\x96\x00\x98\x03\x28\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x95\x03\xc4\x02\xc5\x02\xc6\x02\xdb\x00\x91\x03\x94\x03\x90\x03\x93\x00\x8f\x03\x8e\x03\x8e\x00\xdc\x00\x38\x01\x96\x00\x85\x03\x68\x03\x98\x00\x99\x00\x9a\x00\x9b\x00\x63\x03\x62\x03\x9c\x00\x9d\x00\x5f\x03\x5c\x03\x11\x01\x37\x00\x56\x04\xaa\x04\xa3\x04\x55\x01\xa2\x04\x56\x01\x9d\x04\x9e\x04\x3d\x00\x3e\x00\x3f\x00\x93\x04\x40\x00\x41\x00\x96\x04\xa2\x00\xa3\x00\x98\x04\x94\x04\x92\x04\x90\x04\xe4\xfc\xe3\xfc\xe5\xfc\xa4\x00\x75\x00\x8d\x04\x86\x04\x82\x04\x76\x00\x77\x00\x78\x00\xa7\x03\x8b\x04\x7f\x04\x7d\x04\xa2\x00\xa3\x00\x77\x04\xa6\x03\x72\x04\x70\x04\x6e\x04\x95\x02\x69\x04\xa4\x00\x75\x00\x65\x04\x62\x04\x15\x02\x76\x00\x77\x00\x78\x00\x42\x00\xdd\x00\xa5\x00\x5c\x02\x0f\x00\xde\x00\xcb\x05\x53\x04\x16\x02\x17\x02\x18\x02\x11\x00\x61\x04\x80\x00\x81\x00\x43\x00\x56\x04\xa6\x00\x57\x04\x4c\x04\x4a\x04\x42\x04\xdd\x00\xa5\x00\x6c\x00\x0f\x00\xde\x00\x61\x02\x44\x04\x37\x04\x42\x00\x39\x04\x11\x00\x37\x00\x80\x00\x81\x00\x38\x04\xa8\x03\xa6\x00\xa9\x03\x30\x04\x2f\x04\x3d\x00\x3e\x00\x3f\x00\x43\x00\x40\x00\x41\x00\x0e\x05\x0d\x05\x42\x00\x0b\x05\xc6\x03\x88\x01\x91\x02\x89\x01\xa6\x03\xd5\x01\x24\x01\xda\x03\x37\x00\x76\x00\x25\x01\x78\x00\xa8\x03\x43\x00\xa9\x03\x03\x05\xae\x04\x3d\x00\x3e\x00\x3f\x00\xfb\x04\x40\x00\x41\x00\xf7\x04\xf8\x04\x45\x00\x46\x00\xf6\x04\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xf5\x04\x26\x01\x42\x00\x6e\x04\xe3\x04\x27\x01\x70\x04\x6e\x04\x4c\x00\x4d\x00\x4e\x00\x11\x00\xcf\x04\xd3\x04\x28\x01\xca\x04\xc3\x04\x43\x00\xc9\x04\xc2\x04\xbf\x04\x4f\x00\x45\x00\x46\x00\x55\x05\xbe\x04\x48\x00\x49\x00\x54\x05\x42\x00\x56\x04\xae\x04\x66\x05\x6e\x04\x46\x05\x51\x01\x30\x05\x31\x05\x4c\x00\x73\xfe\x4e\x00\x69\x04\x45\x00\x46\x00\x43\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x29\x05\x4f\x00\x25\x05\x21\x01\x85\x00\x9c\x05\xa3\x05\xa1\x05\x4c\x00\x4d\x00\x4e\x00\x99\x05\x7c\x01\x9a\x05\x96\x05\x92\x05\x87\x00\x91\x05\x8c\x05\x5c\x04\x88\x00\x4f\x00\x8d\x05\x8f\x05\x81\x05\x89\x00\x72\x05\x62\x01\x69\x05\x45\x00\x46\x00\x63\x01\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x7f\x01\x71\x05\x70\x05\xa2\x04\xc6\x05\xc7\x05\x80\x01\xbf\x05\x4c\x00\x4d\x00\x4e\x00\x8f\x00\x90\x00\x61\x01\x9b\x03\x92\x00\x93\x00\xb1\x05\x7b\x01\x45\x00\x46\x00\x4f\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x5c\x03\x5c\x02\xd5\x05\xd0\x05\x5c\x03\xcd\x05\xca\x05\xe0\x05\x4c\x00\x4d\x00\x4e\x00\xf5\x05\x70\x04\xf6\x05\x6e\x04\xf0\x05\x93\x00\xfe\x05\x64\x01\x65\x01\x66\x01\x4f\x00\x96\x00\x66\x05\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x68\x01\x6e\x04\x9c\x00\x9d\x00\x58\x01\xf8\x05\xfd\x05\x01\x06\x69\x01\x6a\x01\x11\x01\x0f\x01\x37\x00\x38\x00\xfb\x01\x3a\x00\x3b\x00\x59\x01\x3c\x00\x5a\x01\x5b\x01\x3d\x00\x3e\x00\x3f\x00\xe5\x01\x40\x00\x41\x00\x1a\x02\x29\x02\xcc\x01\x7b\x00\x28\x02\x7c\x00\x7d\x00\x7e\x00\x48\x02\x7f\x00\xa5\x01\x9a\x01\x82\x00\x83\x00\x5f\x01\xae\x01\xab\x01\xa2\x00\xa3\x00\x48\x01\x3d\x01\x1f\x01\x1e\x01\x1a\x01\x52\x03\x51\x03\xa4\x00\x75\x00\x50\x03\x4d\x03\x45\x03\x76\x00\x77\x00\x78\x00\x2f\x03\x6b\x01\x62\x01\x1b\x03\x29\x03\x42\x00\x63\x01\x1a\x02\x18\x03\x17\x03\x0f\x03\xe1\x02\x03\x03\xd9\x02\xd3\x02\x6c\x01\x6d\x01\xd5\x02\x6e\x01\xbc\x02\x43\x00\xab\x02\x99\x02\xa5\x00\x96\x02\x0f\x00\x10\x00\x8f\x02\x6f\x01\x70\x01\xb9\x01\x72\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x73\x01\x83\x00\xa6\x00\x2c\x02\x31\x02\x74\x01\x2b\x02\x75\x01\x2d\x04\x2c\x04\x57\x03\x76\x01\x2b\x04\x26\x04\x77\x01\x8d\x02\x10\x04\x78\x01\x9e\x03\x93\x00\xe8\x03\x64\x01\x65\x01\x66\x01\x99\x03\x96\x00\x44\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x68\x01\xe4\x03\x9c\x00\x9d\x00\x96\x03\x9c\x01\x9d\x01\x46\x00\x69\x01\x6a\x01\x48\x00\x49\x00\x95\x03\xdb\x03\x45\x00\x46\x00\xda\x03\x47\x00\x48\x00\x49\x00\xfc\x01\x4b\x00\x9e\x01\x92\x03\x4e\x00\x85\x00\x9a\x01\x85\x03\x75\x03\x6d\x03\xb3\x05\x4d\x00\x4e\x00\x6b\x03\x6a\x03\x4f\x00\x68\x03\x87\x00\x5d\x03\x5c\x03\x5a\x03\x88\x00\xac\x04\x4f\x00\xa2\x00\xa3\x00\x89\x00\x63\x03\xa0\x04\x94\x04\x9b\x04\x89\x04\xfd\x01\xa4\x00\x75\x00\x86\x04\x84\x04\x80\x04\x76\x00\x77\x00\x78\x00\x75\x04\x6b\x01\x62\x01\x77\x04\x5e\x01\x6e\x04\x63\x01\x54\x04\x8f\x00\x90\x00\x30\x04\x17\x05\x92\x00\x93\x00\x4c\x04\x6c\x01\x6d\x01\x14\x05\x6e\x01\x44\x04\x07\x05\x05\x05\xed\x04\xa5\x00\xe0\x04\x0f\x00\x10\x00\xcf\x04\x6f\x01\x70\x01\x71\x01\x72\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x73\x01\x83\x00\xa6\x00\x8d\x02\xd5\x04\x74\x01\xcd\x04\x75\x01\xc0\x04\xbf\x04\xaf\x04\x76\x01\xae\x04\x64\x05\x77\x01\x50\x05\x44\x05\x78\x01\x34\x05\x93\x00\x61\x05\xb2\x01\x65\x01\x66\x01\x46\x05\x96\x00\x5a\x05\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x21\x05\x20\x05\x9c\x00\x9d\x00\xa3\x05\x1f\x05\xa1\x05\x9e\x05\xb3\x01\xb4\x01\x82\x05\x9d\x05\x96\x05\x87\x05\x8f\x05\x31\x05\x14\x03\x81\x05\x7f\x05\x37\x00\x38\x00\x74\x05\x15\x03\x3b\x00\x72\x05\x3c\x00\x7c\x02\x69\x05\x3d\x00\x3e\x00\x3f\x00\xc4\x05\x40\x00\x41\x00\x23\x01\x32\x05\xc2\x05\x24\x01\xc1\x05\xbb\x05\x76\x00\x25\x01\x78\x00\xba\x05\xa2\x00\xa3\x00\xb7\x05\xab\x05\xaa\x05\xce\x05\xc8\x05\xde\x05\xf2\x05\xa4\x00\x75\x00\xe3\x05\xda\x05\xd8\x05\x76\x00\x77\x00\x78\x00\xf1\x05\x6b\x01\x62\x01\xfe\x05\x26\x01\x42\x00\x63\x01\xf3\x05\x27\x01\xfb\x05\xf6\x05\x00\x00\x42\x00\x00\x00\x11\x00\x6c\x01\x6d\x01\x28\x01\x6e\x01\x00\x00\x43\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x43\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x00\x00\xb7\x01\x00\x00\x75\x01\x00\x00\x00\x00\x00\x00\x76\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x01\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x00\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x44\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x46\x02\x00\x00\xba\x01\x00\x00\x00\x00\x00\x00\xbb\x01\xbc\x01\x45\x00\x46\x00\x00\x00\x00\x00\x48\x00\x49\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x4c\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\xa2\x00\xa3\x00\x42\x00\x00\x00\x62\x01\x00\x00\x4f\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x43\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x44\x02\x00\x00\xa4\x02\x45\x00\x46\x00\xa5\x02\x00\x00\x48\x00\x49\x00\x40\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x4e\x00\x84\x01\x85\x01\x86\x01\x87\x01\x88\x01\x00\x00\x89\x01\x00\x00\x00\x00\x24\x01\x4f\x00\x00\x00\x76\x00\x25\x01\x78\x00\x00\x00\xa2\x00\xa3\x00\x42\x00\x00\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x43\x00\x6b\x01\x00\x00\x00\x00\x26\x01\x00\x00\x00\x00\x00\x00\x27\x01\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x6c\x01\x6d\x01\x28\x01\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x02\x45\x00\x46\x00\xec\x03\x00\x00\x48\x00\x49\x00\x1e\x04\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x00\x00\x48\x00\x49\x00\x00\x00\x4c\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x4e\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x37\x00\x9c\x00\x9d\x00\x00\x00\xef\x04\x00\x00\x00\x00\xea\x02\x00\x00\xf0\x04\xf1\x04\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x00\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x4e\x00\xf2\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x37\x00\x9c\x00\x9d\x00\x00\x00\x3a\x05\x00\x00\x3b\x05\xf7\x03\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x01\x75\x00\x4c\x00\x4d\x00\x4e\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\xb0\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xee\x03\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x37\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x22\x03\xef\x03\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x37\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x11\x03\x3b\x04\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x03\x65\x01\xf1\x02\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\xf6\x03\x65\x01\xf1\x02\x00\x00\x96\x00\x00\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x5d\x01\x90\xfe\x00\x00\x00\x00\x00\x00\x90\xfe\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x89\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x00\x00\x00\x00\x5e\x01\x76\x00\x77\x00\x78\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x92\x00\x93\x00\xa5\x00\x62\x01\x0f\x00\x10\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x76\x01\x00\x00\x11\x00\xb3\x03\x80\x00\x81\x00\x78\x01\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xfc\x04\x65\x01\xf1\x02\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x65\x01\xf1\x02\x00\x00\x96\x00\x00\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x40\x03\x41\x03\x00\x00\x00\x00\x24\x01\x00\x00\x00\x00\x76\x00\x25\x01\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x26\x01\x76\x00\x77\x00\x78\x00\x27\x01\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x11\x00\x62\x01\x00\x00\x28\x01\x00\x00\x63\x01\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x62\x01\x0f\x00\x10\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x76\x01\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x78\x01\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x65\x01\xf1\x02\x00\x00\x96\x00\xf2\x02\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\x00\x00\x65\x01\xf1\x02\x00\x00\x96\x00\x00\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x89\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x00\x00\x00\x00\x5e\x01\x76\x00\x77\x00\x78\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x92\x00\x93\x00\xa5\x00\x62\x01\x0f\x00\x10\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\xb7\x03\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x78\x01\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x65\x01\xf1\x02\x00\x00\x96\x00\xb6\x03\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x65\x01\xf1\x02\x00\x00\x96\x00\x00\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x2c\x05\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\xa2\x00\xa3\x00\x00\x00\xf6\x01\xf7\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x2d\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x42\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x43\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xb5\x03\x85\x00\x61\x03\x00\x00\x00\x00\x11\x00\x78\x01\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\xb4\x03\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x78\x01\x85\x00\x5e\x04\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x5e\x01\x00\x00\x88\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x89\x00\x92\x00\x93\x00\x37\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x21\x02\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x5e\x01\x4c\x00\x4d\x00\x4e\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x92\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\xf5\x01\x3a\x00\x3b\x00\xf8\x01\x3c\x00\x2e\x05\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\xf6\x01\xf7\x01\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x85\x05\x00\x00\x00\x00\x37\x00\x38\x00\x65\x02\x3a\x00\x3b\x00\x43\x00\x3c\x00\x00\x00\x87\x00\x3d\x00\x3e\x00\x3f\x00\x88\x00\x40\x00\x41\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x43\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x92\x00\x93\x00\x37\x00\x38\x00\xfb\x01\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x42\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x58\x01\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x43\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x59\x01\x00\x00\x5a\x01\x5b\x01\x00\x00\x00\x00\x44\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x7b\x00\x00\x00\x7c\x00\x7d\x00\x7e\x00\x00\x00\x7f\x00\x00\x00\x4f\x00\x82\x00\x83\x00\x00\x00\x42\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xf8\x01\x00\x00\xf9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x4d\x02\x7e\x00\x4f\x00\x7f\x00\x00\x00\x62\x01\xe7\x01\x83\x00\x00\x00\x63\x01\x00\x00\xe8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\xfc\x01\x4b\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x03\x41\x03\x00\x00\x00\x00\x24\x01\x4f\x00\x62\x01\x76\x00\x25\x01\x78\x00\x63\x01\x00\x00\x00\x00\x00\x00\xfd\x01\x93\x00\x00\x00\x00\x00\xff\x02\xf1\x02\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x26\x01\x00\x00\x00\x00\x00\x00\x27\x01\x93\x00\x00\x00\x00\x00\xbb\x03\xf1\x02\x11\x00\x96\x00\x00\x00\x28\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\xba\x03\xf1\x02\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x62\x01\x76\x00\x77\x00\x78\x00\x63\x01\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x62\x01\x00\x00\xa6\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\xb1\x03\xf1\x02\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x93\x00\x00\x00\x00\x00\x63\x04\xf1\x02\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x13\x03\x14\x03\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x15\x03\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x43\x00\xa6\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x31\x05\x14\x03\xa6\x00\x00\x00\x37\x00\x38\x00\x00\x00\x15\x03\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xae\x05\x00\x00\x00\x00\x9a\x04\x41\x03\x44\x00\x00\x00\x24\x01\x00\x00\x00\x00\x76\x00\x25\x01\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x26\x01\x00\x00\x00\x00\x42\x00\x27\x01\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x11\x00\x00\x00\x00\x00\x28\x01\x00\x00\x00\x00\x81\x03\x14\x03\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x15\x03\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xd1\x02\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\xd2\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\xea\x01\x00\x00\x00\x00\x00\x00\xeb\x01\x00\x00\x00\x00\x00\x00\xec\x01\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\xed\x01\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\xee\x01\x00\x00\x42\x00\x00\x00\x27\x01\x4c\x00\x4d\x00\x4e\x00\xef\x01\x7e\x00\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xd1\x02\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x91\x03\xf8\x04\x00\x00\xf9\x04\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x02\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\xd3\x04\xf8\x04\x00\x00\x9a\x05\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x02\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x04\x03\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xbd\x02\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x03\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x57\x04\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x04\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x56\x05\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x05\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xb9\x05\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x92\x05\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xcd\x05\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x93\x05\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x4f\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xaf\xfd\xaf\xfd\x13\x00\xaf\xfd\x00\x00\x00\x00\x00\x00\xaf\xfd\xaf\xfd\x14\x00\xaf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\xfd\xaf\xfd\x00\x00\x00\x00\xaf\xfd\x15\x00\xaf\xfd\x00\x00\xaf\xfd\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\xaf\xfd\xaf\xfd\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\xfd\x00\x00\x23\x00\xaf\xfd\xaf\xfd\x00\x00\xaf\xfd\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\xfd\xaf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x00\x00\x00\x00\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x00\x00\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x00\x00\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x00\x00\xaf\xfd\xa0\x01\xaf\xfd\xa1\x01\xaf\xfd\xa2\x01\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x64\x00\x65\x00\xaf\xfd\xaf\xfd\xaf\xfd\x69\x00\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x72\xfe\x51\x00\x13\x00\x72\xfe\x00\x00\x00\x00\x00\x00\x72\xfe\x72\xfe\x14\x00\x72\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\xfe\x72\xfe\x00\x00\x00\x00\x72\xfe\x15\x00\x72\xfe\x00\x00\x72\xfe\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x72\xfe\x72\xfe\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x72\xfe\x00\x00\x23\x00\x72\xfe\x72\xfe\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\xfe\x72\xfe\x58\x00\x72\xfe\x72\xfe\x72\xfe\x00\x00\x00\x00\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x00\x00\x72\xfe\x59\x00\x5a\x00\x5b\x00\x72\xfe\x5c\x00\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x5d\x00\x00\x00\x00\x00\x1a\x02\x72\xfe\x5e\x00\x72\xfe\x00\x00\x72\xfe\x5f\x00\x72\xfe\x60\x00\x72\xfe\x61\x00\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x6d\x00\x6e\x00\x6f\x00\x70\x00\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x71\x00\x72\xfe\x72\xfe\x72\x00\x73\x00\x72\xfe\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x00\x00\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x00\x00\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\xfe\x79\xfe\x00\x00\x00\x00\x79\xfe\x79\xfe\x79\xfe\x00\x00\x79\xfe\x00\x00\x00\x00\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x79\xfe\x79\xfe\x1c\x02\x1d\x02\x00\x00\x7b\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x79\xfe\x1e\x02\x00\x00\x79\xfe\x00\x00\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x92\xfc\x92\xfc\x92\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\xfc\x00\x00\x00\x00\x92\xfc\x92\xfc\x92\xfc\x00\x00\x92\xfc\x00\x00\x00\x00\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x00\x00\x92\xfc\x92\xfc\x92\xfc\x00\x00\x00\x00\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\xfc\x92\xfc\x85\x00\xdf\x01\x92\xfc\x92\xfc\x00\x00\x00\x00\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x00\x00\x92\xfc\x87\x00\x92\xfc\x92\xfc\x92\xfc\x88\x00\xe0\x01\xe1\x01\xe2\x01\xe3\x01\x89\x00\x00\x00\x00\x00\x92\xfc\x92\xfc\x00\x00\x92\xfc\x00\x00\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x5e\x01\x92\xfc\x92\xfc\x92\xfc\x8f\x00\x90\x00\x92\xfc\x92\xfc\x92\x00\x93\x00\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\xdf\xfd\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\xfd\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\xdf\xfd\x15\x00\xdf\xfd\x00\x00\xdf\xfd\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\xdf\xfd\xdf\xfd\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\xb3\x00\x00\x00\x00\x00\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\x00\x00\xdf\xfd\xdf\xfd\xb5\x00\xb6\x00\xb7\x00\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\x00\x00\x00\x00\xdd\x01\xdf\xfd\x00\x00\xdf\xfd\x00\x00\xdf\xfd\xb8\x00\xdf\xfd\xb9\x00\xdf\xfd\xba\x00\xdf\xfd\xbb\x00\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\xbc\x00\x2d\x00\x8e\x00\xdf\xfd\xdf\xfd\x2e\x00\x91\x00\xdf\xfd\xdf\xfd\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xdf\xfd\xd7\x00\xdf\xfd\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xdf\xfd\xe0\xfd\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\xe0\xfd\x15\x00\xe0\xfd\x00\x00\xe0\xfd\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\xe0\xfd\xe0\xfd\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xb3\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\xe0\xfd\xe0\xfd\xb5\x00\xb6\x00\xb7\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\x00\x00\xdd\x01\xe0\xfd\x00\x00\xe0\xfd\x00\x00\xe0\xfd\xb8\x00\xe0\xfd\xb9\x00\xe0\xfd\xba\x00\xe0\xfd\xbb\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xbc\x00\x2d\x00\x8e\x00\xe0\xfd\xe0\xfd\x2e\x00\x91\x00\xe0\xfd\xe0\xfd\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xe0\xfd\xd7\x00\xe0\xfd\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xe0\xfd\x33\x02\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x8a\xfc\x00\x00\xf9\x02\x00\x00\x00\x00\x00\x00\x00\x00\x8a\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\xfa\x02\xfb\x02\xfc\x02\xfd\x02\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x8a\xfc\x00\x00\x00\x00\x00\x00\x8a\xfc\x00\x00\x8a\xfc\x00\x00\x8a\xfc\x00\x00\x00\x00\x8a\xfc\x8a\xfc\x34\x02\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\x33\x02\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x69\xfd\x00\x00\x69\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x34\x02\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x08\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x38\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x38\xfe\x00\x00\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x63\xfe\x63\xfe\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x6f\x02\x70\x02\x63\xfe\x37\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x37\xfe\x00\x00\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x42\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x43\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x63\xfe\x40\x00\x41\x00\x63\xfe\x63\xfe\x98\x03\x70\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x37\x00\x38\x00\x8b\x04\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x05\x0f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x44\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x1c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x44\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x1b\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x05\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4f\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x37\x00\x38\x00\x19\x04\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x04\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x43\x00\x3c\x00\x00\x00\x4f\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x18\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x44\x00\x00\x00\x00\x00\x39\x04\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x43\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x37\x00\x38\x00\x19\x04\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x44\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x45\x02\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\xa8\x01\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\xc1\x01\x99\x00\x9a\x00\x9b\x00\x3e\x02\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x4f\x00\x37\x00\x38\x00\x82\x03\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x8b\x04\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x7d\x04\x00\x00\x00\x00\xc2\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\xc3\x01\x02\x04\xc5\x01\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\xa2\x00\xa3\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x45\x00\x46\x00\xa6\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x4c\x00\x4d\x00\x4e\x00\x05\x04\x00\x00\x06\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x35\x04\x00\x00\x00\x00\xc2\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\xc3\x01\x02\x04\xc5\x01\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\xa2\x00\xa3\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x04\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x94\x05\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x44\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x45\x00\x46\x00\xa6\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x04\x4c\x00\x4d\x00\x4e\x00\x05\x04\x00\x00\x06\x04\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x75\x05\x3a\x00\x3b\x00\x43\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x45\x00\x46\x00\x43\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x4f\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x20\x02\x3b\x00\x43\x00\x3c\x00\x00\x00\x4f\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x7b\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x43\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x37\x00\x38\x00\x00\x00\x47\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x44\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x42\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x41\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x3f\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x25\x04\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\x1f\x04\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xb8\x03\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\x9e\x04\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x0b\x05\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\x29\x05\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x03\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\xe1\x04\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x04\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x05\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x05\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x05\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x12\x02\x13\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\xaa\x00\x13\x00\xab\x00\x00\x01\x01\x01\x02\x01\x03\x01\x00\x00\x14\x00\xac\x00\x4f\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x04\x01\xe3\x00\x00\x00\x05\x01\x64\x00\x15\x00\x00\x00\x06\x01\x00\x00\x00\x00\x07\x01\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x09\x01\xe9\x00\x0a\x01\x0b\x01\x00\x00\x00\x00\x0c\x01\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\x00\x00\x00\x00\x00\x00\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x01\x05\x02\x05\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x00\x00\x00\x00\xcc\xfc\x00\x00\x00\x00\x00\x00\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x00\x00\xcc\xfc\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x7b\x01\x00\x00\x7c\x01\x00\x00\x00\x00\x00\x00\x7d\x01\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x7e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x7f\x01\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x80\x01\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\xdb\x04\xdc\x04\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xdd\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x4d\x05\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x4e\x05\x00\x00\x15\x00\x00\x00\x4f\x05\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\xdb\x04\xdc\x04\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xdd\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x4d\x05\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x4e\x05\x00\x00\x15\x00\x00\x00\x4f\x05\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x7b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\xb9\x01\xbb\x00\x00\x00\x00\x00\x80\x01\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x90\xfd\xba\x00\x90\xfd\xbb\x00\x00\x00\x00\x00\x58\x02\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x72\x02\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x58\x02\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x75\x02\xbb\x00\x00\x00\x00\x00\x58\x02\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\x00\x00\xb5\xfd\xb5\xfd\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\xb5\xfd\x00\x00\xb5\xfd\x00\x00\xb5\xfd\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\xb5\xfd\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\x00\x00\xb4\xfd\xb4\xfd\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\xb4\xfd\x00\x00\xb4\xfd\x00\x00\xb4\xfd\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\xb4\xfd\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xda\x03\xc2\xfd\x00\x00\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\xc2\xfd\x00\x00\xc2\xfd\x00\x00\xc2\xfd\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xbe\x01\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x5c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\xe4\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\xd5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x01\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x04\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\xb0\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\xb0\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\xf6\x03\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\xb0\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\xf6\x03\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\xdc\x02\x86\x01\x87\x01\x88\x01\x00\x00\x89\x01\x00\x00\x00\x00\x24\x01\x00\x00\x00\x00\x76\x00\x25\x01\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x26\x01\x00\x00\x00\x00\x00\x00\x27\x01\x00\x00\x00\x00\x00\x00\x4d\x02\x7e\x00\x11\x00\x7f\x00\x00\x00\x28\x01\x8f\x01\xdd\x02\xf2\xfd\x00\x00\xf2\xfd\xe8\x01\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\xf2\xfd\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\xc7\x01\xc8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x01\x00\x00\xf2\xfd\x00\x00\xf2\xfd\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\xf2\xfd\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xfe\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xfe\x00\x00\x00\x00\x00\x00\xc6\xfe\x00\x00\x00\x00\x00\x00\xc6\xfe\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\xc6\xfe\x00\x00\x00\x00\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x03\x00\x00\xc6\xfe\x00\x00\xc6\xfe\x00\x00\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\x00\x00\xc6\xfe\xc6\xfe\x00\x00\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\xc6\xfe\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xd5\x02\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\xbd\xfe\xbd\xfe\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x0a\x04\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x08\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xd5\x02\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\xbd\xfe\xbd\xfe\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x69\xfd\x00\x00\x69\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x08\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\xec\x03\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xea\xfd\x85\x00\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xea\xfd\x00\x00\xf6\x02\xf7\x02\x00\x00\x7a\xfe\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x89\x00\x00\x00\x00\x00\x00\x00\xf8\x02\x00\x00\xea\xfd\x00\x00\x00\x00\x00\x00\xea\xfd\x00\x00\xea\xfd\x00\x00\xea\xfd\x00\x00\x00\x00\xea\xfd\xea\xfd\x5e\x01\x00\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x92\x00\x93\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x15\xfd\x00\x00\x15\xfd\x59\x02\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\x00\x00\x00\x15\xfd\x15\xfd\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x01\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x02\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\xfb\x01\x00\x00\x00\x00\x00\x00\x80\x01\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\xb5\x05\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x01\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x02\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x45\x01\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x01\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x47\x01\x48\x01\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x02\x5a\x00\x5b\x00\x00\x00\x69\x02\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x6b\x02\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x62\x00\x63\x00\x64\x00\x65\x00\x6c\x02\x6d\x02\x68\x00\x69\x00\x6a\x00\x6e\x02\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x5d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x02\x02\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x05\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x43\x05\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x34\x05\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x05\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x05\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\xb5\x05\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\xb6\x05\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\xab\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\xab\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\xf4\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\xf4\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x01\x64\x00\x65\x00\x00\x00\x00\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x03\xfa\x03\x00\x00\x00\x00\x00\x00\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x03\xfa\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\xfb\x03\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\xfc\x03\x00\x00\xa8\x00\x00\x00\xfd\x03\x00\x00\xfe\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x04\x00\x00\xa8\x00\x00\x00\xfd\x03\x00\x00\xfe\x03\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x03\xfa\x03\x00\x00\x00\x00\x00\x00\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x03\xfa\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x4a\x04\x00\x00\xa8\x00\x00\x00\xfd\x03\x00\x00\xfe\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\xc2\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\xa7\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x03\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x01\x02\x04\xc5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x03\x04\x00\x00\x00\x00\x00\x00\xc3\x01\x02\x04\xc5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x00\x00\x00\x00\x00\x00\x05\x04\x00\x00\x06\x04\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x15\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x06\x05\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x7b\x03\x7c\x03\x7d\x03\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x03\x7f\x03\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x08\x02\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x03\x7f\x03\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x08\x02\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x7e\x03\x7f\x03\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x3a\x02\x3b\x02\xde\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x3c\x02\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x1f\x05\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x3a\x02\x3b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x3c\x02\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x02\x3b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x3c\x02\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x03\xf1\x03\xf2\x03\xf3\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x02\x3b\x02\x00\x00\xf4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x3c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\xff\x04\xf2\x03\xf3\x03\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\xf4\x03\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x0d\x01\x0e\x01\xa1\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x9f\x00\x00\x00\xa0\x00\xa1\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xae\x02\x00\x00\x00\x00\xad\x02\xa1\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xac\x02\x00\x00\x00\x00\xad\x02\xa1\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\xe9\x01\x80\x00\x81\x00\x9c\x00\x9d\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x02\x8b\x02\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x8c\x02\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa3\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x93\x00\xd0\x01\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa1\x03\x8b\x02\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x02\x00\x00\x00\x00\xd1\x01\xd2\x01\xd3\x01\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa8\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x04\x53\x04\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\xfe\x04\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa8\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x3f\x04\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\xa7\x00\x00\x00\x00\x00\xee\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa8\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x93\x00\x6e\x03\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x03\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x03\x11\x00\x00\x00\x80\x00\x81\x00\xa8\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x6e\x03\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\xef\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\xd6\x01\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\xaa\x01\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\xa4\x01\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x86\x02\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x0b\x04\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x0a\x04\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\xf8\x03\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\xa2\x03\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x58\x04\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x4e\x04\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x40\x04\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x3e\x04\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x04\x05\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\xde\x04\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x59\x05\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x27\x05\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x26\x05\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x25\x05\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x9c\x05\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\xac\x05\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xdd\x01\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x95\x00\x7a\x02\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x79\x02\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x95\x00\x78\x02\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x16\x00\x17\x00\x18\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x14\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x02\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x3a\x02\x3b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x13\x00\x8b\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x8d\x00\x00\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x02\x13\x00\xf1\x01\x00\x00\xf2\x01\x00\x00\x8c\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\xf3\x01\x00\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x15\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x03\x06\x03\x00\x00\x07\x03\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x03\x06\x03\x00\x00\x07\x03\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x03\x11\x00\x13\x00\x80\x00\x81\x00\xb8\x04\xb9\x04\xa6\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x03\xba\x04\x00\x00\x00\x00\x15\x00\x00\x00\xbb\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\xbc\x04\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\xb8\x04\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x05\x00\x00\x00\x00\x15\x00\x00\x00\xbb\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\xee\x05\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xbd\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x65\x00\x00\x00\x00\x00\x2e\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x04\x13\x00\x00\x00\x00\x00\xb8\x04\x00\x00\x00\x00\xef\x05\x14\x00\x00\x00\x2d\x00\x65\x00\x00\x00\x00\x00\x2e\x00\x69\x00\x00\x00\xed\x05\x00\x00\x00\x00\x15\x00\x00\x00\xbb\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\xee\x05\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\xb8\x04\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xbb\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xbd\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x65\x00\x00\x00\x00\x00\x2e\x00\x69\x00\x14\x00\x00\x00\x00\x00\x00\x00\x6f\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xbd\x04\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x2d\x00\x65\x00\x00\x00\x00\x00\x2e\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\xf2\xfd\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\xf2\xfd\x2e\x00\x91\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x8f\x01\x00\x00\xf2\xfd\x14\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x15\x00\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x14\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x15\x00\x2e\x00\x91\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\xf1\x01\x00\x00\xf2\x01\x14\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x15\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x64\x00\x65\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x15\x00\x84\x02\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x01\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x13\x00\x8b\x01\x7f\x01\x8c\x00\x00\x00\x00\x00\x00\x00\x14\x00\x80\x01\x00\x00\x00\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x00\x00\x2a\x01\x00\x00\x00\x00\x15\x00\x00\x00\x2b\x01\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x2c\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x8b\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x3d\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x2c\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x8b\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x02\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x2c\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x13\x02\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x14\x02\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x64\x00\x12\x02\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x02\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x02\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x14\x02\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x64\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x14\x02\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xfe\x15\x00\x00\x00\x00\x00\x00\x00\xf4\xfe\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x37\x03\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\xcd\x02\x00\x00\x00\x00\x2d\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xd1\x03\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xd1\x03\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xd1\x03\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x14\x00\x00\x00\xc2\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x04\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\xc3\x01\xc4\x01\xc5\x01\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xa9\x01\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x64\x00\x4b\x03\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xec\x02\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x01\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x01\x9d\x02\xc5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xd1\x03\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\xca\x03\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\x96\x04\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x43\x05\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xe9\x03\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\xea\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\xdb\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x01\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xc0\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x01\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x93\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x01\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x4a\x03\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x03\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x93\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x02\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xb9\x03\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x03\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x93\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x01\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa3\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (13, 906) [ + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139), + (140 , happyReduce_140), + (141 , happyReduce_141), + (142 , happyReduce_142), + (143 , happyReduce_143), + (144 , happyReduce_144), + (145 , happyReduce_145), + (146 , happyReduce_146), + (147 , happyReduce_147), + (148 , happyReduce_148), + (149 , happyReduce_149), + (150 , happyReduce_150), + (151 , happyReduce_151), + (152 , happyReduce_152), + (153 , happyReduce_153), + (154 , happyReduce_154), + (155 , happyReduce_155), + (156 , happyReduce_156), + (157 , happyReduce_157), + (158 , happyReduce_158), + (159 , happyReduce_159), + (160 , happyReduce_160), + (161 , happyReduce_161), + (162 , happyReduce_162), + (163 , happyReduce_163), + (164 , happyReduce_164), + (165 , happyReduce_165), + (166 , happyReduce_166), + (167 , happyReduce_167), + (168 , happyReduce_168), + (169 , happyReduce_169), + (170 , happyReduce_170), + (171 , happyReduce_171), + (172 , happyReduce_172), + (173 , happyReduce_173), + (174 , happyReduce_174), + (175 , happyReduce_175), + (176 , happyReduce_176), + (177 , happyReduce_177), + (178 , happyReduce_178), + (179 , happyReduce_179), + (180 , happyReduce_180), + (181 , happyReduce_181), + (182 , happyReduce_182), + (183 , happyReduce_183), + (184 , happyReduce_184), + (185 , happyReduce_185), + (186 , happyReduce_186), + (187 , happyReduce_187), + (188 , happyReduce_188), + (189 , happyReduce_189), + (190 , happyReduce_190), + (191 , happyReduce_191), + (192 , happyReduce_192), + (193 , happyReduce_193), + (194 , happyReduce_194), + (195 , happyReduce_195), + (196 , happyReduce_196), + (197 , happyReduce_197), + (198 , happyReduce_198), + (199 , happyReduce_199), + (200 , happyReduce_200), + (201 , happyReduce_201), + (202 , happyReduce_202), + (203 , happyReduce_203), + (204 , happyReduce_204), + (205 , happyReduce_205), + (206 , happyReduce_206), + (207 , happyReduce_207), + (208 , happyReduce_208), + (209 , happyReduce_209), + (210 , happyReduce_210), + (211 , happyReduce_211), + (212 , happyReduce_212), + (213 , happyReduce_213), + (214 , happyReduce_214), + (215 , happyReduce_215), + (216 , happyReduce_216), + (217 , happyReduce_217), + (218 , happyReduce_218), + (219 , happyReduce_219), + (220 , happyReduce_220), + (221 , happyReduce_221), + (222 , happyReduce_222), + (223 , happyReduce_223), + (224 , happyReduce_224), + (225 , happyReduce_225), + (226 , happyReduce_226), + (227 , happyReduce_227), + (228 , happyReduce_228), + (229 , happyReduce_229), + (230 , happyReduce_230), + (231 , happyReduce_231), + (232 , happyReduce_232), + (233 , happyReduce_233), + (234 , happyReduce_234), + (235 , happyReduce_235), + (236 , happyReduce_236), + (237 , happyReduce_237), + (238 , happyReduce_238), + (239 , happyReduce_239), + (240 , happyReduce_240), + (241 , happyReduce_241), + (242 , happyReduce_242), + (243 , happyReduce_243), + (244 , happyReduce_244), + (245 , happyReduce_245), + (246 , happyReduce_246), + (247 , happyReduce_247), + (248 , happyReduce_248), + (249 , happyReduce_249), + (250 , happyReduce_250), + (251 , happyReduce_251), + (252 , happyReduce_252), + (253 , happyReduce_253), + (254 , happyReduce_254), + (255 , happyReduce_255), + (256 , happyReduce_256), + (257 , happyReduce_257), + (258 , happyReduce_258), + (259 , happyReduce_259), + (260 , happyReduce_260), + (261 , happyReduce_261), + (262 , happyReduce_262), + (263 , happyReduce_263), + (264 , happyReduce_264), + (265 , happyReduce_265), + (266 , happyReduce_266), + (267 , happyReduce_267), + (268 , happyReduce_268), + (269 , happyReduce_269), + (270 , happyReduce_270), + (271 , happyReduce_271), + (272 , happyReduce_272), + (273 , happyReduce_273), + (274 , happyReduce_274), + (275 , happyReduce_275), + (276 , happyReduce_276), + (277 , happyReduce_277), + (278 , happyReduce_278), + (279 , happyReduce_279), + (280 , happyReduce_280), + (281 , happyReduce_281), + (282 , happyReduce_282), + (283 , happyReduce_283), + (284 , happyReduce_284), + (285 , happyReduce_285), + (286 , happyReduce_286), + (287 , happyReduce_287), + (288 , happyReduce_288), + (289 , happyReduce_289), + (290 , happyReduce_290), + (291 , happyReduce_291), + (292 , happyReduce_292), + (293 , happyReduce_293), + (294 , happyReduce_294), + (295 , happyReduce_295), + (296 , happyReduce_296), + (297 , happyReduce_297), + (298 , happyReduce_298), + (299 , happyReduce_299), + (300 , happyReduce_300), + (301 , happyReduce_301), + (302 , happyReduce_302), + (303 , happyReduce_303), + (304 , happyReduce_304), + (305 , happyReduce_305), + (306 , happyReduce_306), + (307 , happyReduce_307), + (308 , happyReduce_308), + (309 , happyReduce_309), + (310 , happyReduce_310), + (311 , happyReduce_311), + (312 , happyReduce_312), + (313 , happyReduce_313), + (314 , happyReduce_314), + (315 , happyReduce_315), + (316 , happyReduce_316), + (317 , happyReduce_317), + (318 , happyReduce_318), + (319 , happyReduce_319), + (320 , happyReduce_320), + (321 , happyReduce_321), + (322 , happyReduce_322), + (323 , happyReduce_323), + (324 , happyReduce_324), + (325 , happyReduce_325), + (326 , happyReduce_326), + (327 , happyReduce_327), + (328 , happyReduce_328), + (329 , happyReduce_329), + (330 , happyReduce_330), + (331 , happyReduce_331), + (332 , happyReduce_332), + (333 , happyReduce_333), + (334 , happyReduce_334), + (335 , happyReduce_335), + (336 , happyReduce_336), + (337 , happyReduce_337), + (338 , happyReduce_338), + (339 , happyReduce_339), + (340 , happyReduce_340), + (341 , happyReduce_341), + (342 , happyReduce_342), + (343 , happyReduce_343), + (344 , happyReduce_344), + (345 , happyReduce_345), + (346 , happyReduce_346), + (347 , happyReduce_347), + (348 , happyReduce_348), + (349 , happyReduce_349), + (350 , happyReduce_350), + (351 , happyReduce_351), + (352 , happyReduce_352), + (353 , happyReduce_353), + (354 , happyReduce_354), + (355 , happyReduce_355), + (356 , happyReduce_356), + (357 , happyReduce_357), + (358 , happyReduce_358), + (359 , happyReduce_359), + (360 , happyReduce_360), + (361 , happyReduce_361), + (362 , happyReduce_362), + (363 , happyReduce_363), + (364 , happyReduce_364), + (365 , happyReduce_365), + (366 , happyReduce_366), + (367 , happyReduce_367), + (368 , happyReduce_368), + (369 , happyReduce_369), + (370 , happyReduce_370), + (371 , happyReduce_371), + (372 , happyReduce_372), + (373 , happyReduce_373), + (374 , happyReduce_374), + (375 , happyReduce_375), + (376 , happyReduce_376), + (377 , happyReduce_377), + (378 , happyReduce_378), + (379 , happyReduce_379), + (380 , happyReduce_380), + (381 , happyReduce_381), + (382 , happyReduce_382), + (383 , happyReduce_383), + (384 , happyReduce_384), + (385 , happyReduce_385), + (386 , happyReduce_386), + (387 , happyReduce_387), + (388 , happyReduce_388), + (389 , happyReduce_389), + (390 , happyReduce_390), + (391 , happyReduce_391), + (392 , happyReduce_392), + (393 , happyReduce_393), + (394 , happyReduce_394), + (395 , happyReduce_395), + (396 , happyReduce_396), + (397 , happyReduce_397), + (398 , happyReduce_398), + (399 , happyReduce_399), + (400 , happyReduce_400), + (401 , happyReduce_401), + (402 , happyReduce_402), + (403 , happyReduce_403), + (404 , happyReduce_404), + (405 , happyReduce_405), + (406 , happyReduce_406), + (407 , happyReduce_407), + (408 , happyReduce_408), + (409 , happyReduce_409), + (410 , happyReduce_410), + (411 , happyReduce_411), + (412 , happyReduce_412), + (413 , happyReduce_413), + (414 , happyReduce_414), + (415 , happyReduce_415), + (416 , happyReduce_416), + (417 , happyReduce_417), + (418 , happyReduce_418), + (419 , happyReduce_419), + (420 , happyReduce_420), + (421 , happyReduce_421), + (422 , happyReduce_422), + (423 , happyReduce_423), + (424 , happyReduce_424), + (425 , happyReduce_425), + (426 , happyReduce_426), + (427 , happyReduce_427), + (428 , happyReduce_428), + (429 , happyReduce_429), + (430 , happyReduce_430), + (431 , happyReduce_431), + (432 , happyReduce_432), + (433 , happyReduce_433), + (434 , happyReduce_434), + (435 , happyReduce_435), + (436 , happyReduce_436), + (437 , happyReduce_437), + (438 , happyReduce_438), + (439 , happyReduce_439), + (440 , happyReduce_440), + (441 , happyReduce_441), + (442 , happyReduce_442), + (443 , happyReduce_443), + (444 , happyReduce_444), + (445 , happyReduce_445), + (446 , happyReduce_446), + (447 , happyReduce_447), + (448 , happyReduce_448), + (449 , happyReduce_449), + (450 , happyReduce_450), + (451 , happyReduce_451), + (452 , happyReduce_452), + (453 , happyReduce_453), + (454 , happyReduce_454), + (455 , happyReduce_455), + (456 , happyReduce_456), + (457 , happyReduce_457), + (458 , happyReduce_458), + (459 , happyReduce_459), + (460 , happyReduce_460), + (461 , happyReduce_461), + (462 , happyReduce_462), + (463 , happyReduce_463), + (464 , happyReduce_464), + (465 , happyReduce_465), + (466 , happyReduce_466), + (467 , happyReduce_467), + (468 , happyReduce_468), + (469 , happyReduce_469), + (470 , happyReduce_470), + (471 , happyReduce_471), + (472 , happyReduce_472), + (473 , happyReduce_473), + (474 , happyReduce_474), + (475 , happyReduce_475), + (476 , happyReduce_476), + (477 , happyReduce_477), + (478 , happyReduce_478), + (479 , happyReduce_479), + (480 , happyReduce_480), + (481 , happyReduce_481), + (482 , happyReduce_482), + (483 , happyReduce_483), + (484 , happyReduce_484), + (485 , happyReduce_485), + (486 , happyReduce_486), + (487 , happyReduce_487), + (488 , happyReduce_488), + (489 , happyReduce_489), + (490 , happyReduce_490), + (491 , happyReduce_491), + (492 , happyReduce_492), + (493 , happyReduce_493), + (494 , happyReduce_494), + (495 , happyReduce_495), + (496 , happyReduce_496), + (497 , happyReduce_497), + (498 , happyReduce_498), + (499 , happyReduce_499), + (500 , happyReduce_500), + (501 , happyReduce_501), + (502 , happyReduce_502), + (503 , happyReduce_503), + (504 , happyReduce_504), + (505 , happyReduce_505), + (506 , happyReduce_506), + (507 , happyReduce_507), + (508 , happyReduce_508), + (509 , happyReduce_509), + (510 , happyReduce_510), + (511 , happyReduce_511), + (512 , happyReduce_512), + (513 , happyReduce_513), + (514 , happyReduce_514), + (515 , happyReduce_515), + (516 , happyReduce_516), + (517 , happyReduce_517), + (518 , happyReduce_518), + (519 , happyReduce_519), + (520 , happyReduce_520), + (521 , happyReduce_521), + (522 , happyReduce_522), + (523 , happyReduce_523), + (524 , happyReduce_524), + (525 , happyReduce_525), + (526 , happyReduce_526), + (527 , happyReduce_527), + (528 , happyReduce_528), + (529 , happyReduce_529), + (530 , happyReduce_530), + (531 , happyReduce_531), + (532 , happyReduce_532), + (533 , happyReduce_533), + (534 , happyReduce_534), + (535 , happyReduce_535), + (536 , happyReduce_536), + (537 , happyReduce_537), + (538 , happyReduce_538), + (539 , happyReduce_539), + (540 , happyReduce_540), + (541 , happyReduce_541), + (542 , happyReduce_542), + (543 , happyReduce_543), + (544 , happyReduce_544), + (545 , happyReduce_545), + (546 , happyReduce_546), + (547 , happyReduce_547), + (548 , happyReduce_548), + (549 , happyReduce_549), + (550 , happyReduce_550), + (551 , happyReduce_551), + (552 , happyReduce_552), + (553 , happyReduce_553), + (554 , happyReduce_554), + (555 , happyReduce_555), + (556 , happyReduce_556), + (557 , happyReduce_557), + (558 , happyReduce_558), + (559 , happyReduce_559), + (560 , happyReduce_560), + (561 , happyReduce_561), + (562 , happyReduce_562), + (563 , happyReduce_563), + (564 , happyReduce_564), + (565 , happyReduce_565), + (566 , happyReduce_566), + (567 , happyReduce_567), + (568 , happyReduce_568), + (569 , happyReduce_569), + (570 , happyReduce_570), + (571 , happyReduce_571), + (572 , happyReduce_572), + (573 , happyReduce_573), + (574 , happyReduce_574), + (575 , happyReduce_575), + (576 , happyReduce_576), + (577 , happyReduce_577), + (578 , happyReduce_578), + (579 , happyReduce_579), + (580 , happyReduce_580), + (581 , happyReduce_581), + (582 , happyReduce_582), + (583 , happyReduce_583), + (584 , happyReduce_584), + (585 , happyReduce_585), + (586 , happyReduce_586), + (587 , happyReduce_587), + (588 , happyReduce_588), + (589 , happyReduce_589), + (590 , happyReduce_590), + (591 , happyReduce_591), + (592 , happyReduce_592), + (593 , happyReduce_593), + (594 , happyReduce_594), + (595 , happyReduce_595), + (596 , happyReduce_596), + (597 , happyReduce_597), + (598 , happyReduce_598), + (599 , happyReduce_599), + (600 , happyReduce_600), + (601 , happyReduce_601), + (602 , happyReduce_602), + (603 , happyReduce_603), + (604 , happyReduce_604), + (605 , happyReduce_605), + (606 , happyReduce_606), + (607 , happyReduce_607), + (608 , happyReduce_608), + (609 , happyReduce_609), + (610 , happyReduce_610), + (611 , happyReduce_611), + (612 , happyReduce_612), + (613 , happyReduce_613), + (614 , happyReduce_614), + (615 , happyReduce_615), + (616 , happyReduce_616), + (617 , happyReduce_617), + (618 , happyReduce_618), + (619 , happyReduce_619), + (620 , happyReduce_620), + (621 , happyReduce_621), + (622 , happyReduce_622), + (623 , happyReduce_623), + (624 , happyReduce_624), + (625 , happyReduce_625), + (626 , happyReduce_626), + (627 , happyReduce_627), + (628 , happyReduce_628), + (629 , happyReduce_629), + (630 , happyReduce_630), + (631 , happyReduce_631), + (632 , happyReduce_632), + (633 , happyReduce_633), + (634 , happyReduce_634), + (635 , happyReduce_635), + (636 , happyReduce_636), + (637 , happyReduce_637), + (638 , happyReduce_638), + (639 , happyReduce_639), + (640 , happyReduce_640), + (641 , happyReduce_641), + (642 , happyReduce_642), + (643 , happyReduce_643), + (644 , happyReduce_644), + (645 , happyReduce_645), + (646 , happyReduce_646), + (647 , happyReduce_647), + (648 , happyReduce_648), + (649 , happyReduce_649), + (650 , happyReduce_650), + (651 , happyReduce_651), + (652 , happyReduce_652), + (653 , happyReduce_653), + (654 , happyReduce_654), + (655 , happyReduce_655), + (656 , happyReduce_656), + (657 , happyReduce_657), + (658 , happyReduce_658), + (659 , happyReduce_659), + (660 , happyReduce_660), + (661 , happyReduce_661), + (662 , happyReduce_662), + (663 , happyReduce_663), + (664 , happyReduce_664), + (665 , happyReduce_665), + (666 , happyReduce_666), + (667 , happyReduce_667), + (668 , happyReduce_668), + (669 , happyReduce_669), + (670 , happyReduce_670), + (671 , happyReduce_671), + (672 , happyReduce_672), + (673 , happyReduce_673), + (674 , happyReduce_674), + (675 , happyReduce_675), + (676 , happyReduce_676), + (677 , happyReduce_677), + (678 , happyReduce_678), + (679 , happyReduce_679), + (680 , happyReduce_680), + (681 , happyReduce_681), + (682 , happyReduce_682), + (683 , happyReduce_683), + (684 , happyReduce_684), + (685 , happyReduce_685), + (686 , happyReduce_686), + (687 , happyReduce_687), + (688 , happyReduce_688), + (689 , happyReduce_689), + (690 , happyReduce_690), + (691 , happyReduce_691), + (692 , happyReduce_692), + (693 , happyReduce_693), + (694 , happyReduce_694), + (695 , happyReduce_695), + (696 , happyReduce_696), + (697 , happyReduce_697), + (698 , happyReduce_698), + (699 , happyReduce_699), + (700 , happyReduce_700), + (701 , happyReduce_701), + (702 , happyReduce_702), + (703 , happyReduce_703), + (704 , happyReduce_704), + (705 , happyReduce_705), + (706 , happyReduce_706), + (707 , happyReduce_707), + (708 , happyReduce_708), + (709 , happyReduce_709), + (710 , happyReduce_710), + (711 , happyReduce_711), + (712 , happyReduce_712), + (713 , happyReduce_713), + (714 , happyReduce_714), + (715 , happyReduce_715), + (716 , happyReduce_716), + (717 , happyReduce_717), + (718 , happyReduce_718), + (719 , happyReduce_719), + (720 , happyReduce_720), + (721 , happyReduce_721), + (722 , happyReduce_722), + (723 , happyReduce_723), + (724 , happyReduce_724), + (725 , happyReduce_725), + (726 , happyReduce_726), + (727 , happyReduce_727), + (728 , happyReduce_728), + (729 , happyReduce_729), + (730 , happyReduce_730), + (731 , happyReduce_731), + (732 , happyReduce_732), + (733 , happyReduce_733), + (734 , happyReduce_734), + (735 , happyReduce_735), + (736 , happyReduce_736), + (737 , happyReduce_737), + (738 , happyReduce_738), + (739 , happyReduce_739), + (740 , happyReduce_740), + (741 , happyReduce_741), + (742 , happyReduce_742), + (743 , happyReduce_743), + (744 , happyReduce_744), + (745 , happyReduce_745), + (746 , happyReduce_746), + (747 , happyReduce_747), + (748 , happyReduce_748), + (749 , happyReduce_749), + (750 , happyReduce_750), + (751 , happyReduce_751), + (752 , happyReduce_752), + (753 , happyReduce_753), + (754 , happyReduce_754), + (755 , happyReduce_755), + (756 , happyReduce_756), + (757 , happyReduce_757), + (758 , happyReduce_758), + (759 , happyReduce_759), + (760 , happyReduce_760), + (761 , happyReduce_761), + (762 , happyReduce_762), + (763 , happyReduce_763), + (764 , happyReduce_764), + (765 , happyReduce_765), + (766 , happyReduce_766), + (767 , happyReduce_767), + (768 , happyReduce_768), + (769 , happyReduce_769), + (770 , happyReduce_770), + (771 , happyReduce_771), + (772 , happyReduce_772), + (773 , happyReduce_773), + (774 , happyReduce_774), + (775 , happyReduce_775), + (776 , happyReduce_776), + (777 , happyReduce_777), + (778 , happyReduce_778), + (779 , happyReduce_779), + (780 , happyReduce_780), + (781 , happyReduce_781), + (782 , happyReduce_782), + (783 , happyReduce_783), + (784 , happyReduce_784), + (785 , happyReduce_785), + (786 , happyReduce_786), + (787 , happyReduce_787), + (788 , happyReduce_788), + (789 , happyReduce_789), + (790 , happyReduce_790), + (791 , happyReduce_791), + (792 , happyReduce_792), + (793 , happyReduce_793), + (794 , happyReduce_794), + (795 , happyReduce_795), + (796 , happyReduce_796), + (797 , happyReduce_797), + (798 , happyReduce_798), + (799 , happyReduce_799), + (800 , happyReduce_800), + (801 , happyReduce_801), + (802 , happyReduce_802), + (803 , happyReduce_803), + (804 , happyReduce_804), + (805 , happyReduce_805), + (806 , happyReduce_806), + (807 , happyReduce_807), + (808 , happyReduce_808), + (809 , happyReduce_809), + (810 , happyReduce_810), + (811 , happyReduce_811), + (812 , happyReduce_812), + (813 , happyReduce_813), + (814 , happyReduce_814), + (815 , happyReduce_815), + (816 , happyReduce_816), + (817 , happyReduce_817), + (818 , happyReduce_818), + (819 , happyReduce_819), + (820 , happyReduce_820), + (821 , happyReduce_821), + (822 , happyReduce_822), + (823 , happyReduce_823), + (824 , happyReduce_824), + (825 , happyReduce_825), + (826 , happyReduce_826), + (827 , happyReduce_827), + (828 , happyReduce_828), + (829 , happyReduce_829), + (830 , happyReduce_830), + (831 , happyReduce_831), + (832 , happyReduce_832), + (833 , happyReduce_833), + (834 , happyReduce_834), + (835 , happyReduce_835), + (836 , happyReduce_836), + (837 , happyReduce_837), + (838 , happyReduce_838), + (839 , happyReduce_839), + (840 , happyReduce_840), + (841 , happyReduce_841), + (842 , happyReduce_842), + (843 , happyReduce_843), + (844 , happyReduce_844), + (845 , happyReduce_845), + (846 , happyReduce_846), + (847 , happyReduce_847), + (848 , happyReduce_848), + (849 , happyReduce_849), + (850 , happyReduce_850), + (851 , happyReduce_851), + (852 , happyReduce_852), + (853 , happyReduce_853), + (854 , happyReduce_854), + (855 , happyReduce_855), + (856 , happyReduce_856), + (857 , happyReduce_857), + (858 , happyReduce_858), + (859 , happyReduce_859), + (860 , happyReduce_860), + (861 , happyReduce_861), + (862 , happyReduce_862), + (863 , happyReduce_863), + (864 , happyReduce_864), + (865 , happyReduce_865), + (866 , happyReduce_866), + (867 , happyReduce_867), + (868 , happyReduce_868), + (869 , happyReduce_869), + (870 , happyReduce_870), + (871 , happyReduce_871), + (872 , happyReduce_872), + (873 , happyReduce_873), + (874 , happyReduce_874), + (875 , happyReduce_875), + (876 , happyReduce_876), + (877 , happyReduce_877), + (878 , happyReduce_878), + (879 , happyReduce_879), + (880 , happyReduce_880), + (881 , happyReduce_881), + (882 , happyReduce_882), + (883 , happyReduce_883), + (884 , happyReduce_884), + (885 , happyReduce_885), + (886 , happyReduce_886), + (887 , happyReduce_887), + (888 , happyReduce_888), + (889 , happyReduce_889), + (890 , happyReduce_890), + (891 , happyReduce_891), + (892 , happyReduce_892), + (893 , happyReduce_893), + (894 , happyReduce_894), + (895 , happyReduce_895), + (896 , happyReduce_896), + (897 , happyReduce_897), + (898 , happyReduce_898), + (899 , happyReduce_899), + (900 , happyReduce_900), + (901 , happyReduce_901), + (902 , happyReduce_902), + (903 , happyReduce_903), + (904 , happyReduce_904), + (905 , happyReduce_905), + (906 , happyReduce_906) + ] + +happy_n_terms = 162 :: Prelude.Int +happy_n_nonterms = 337 :: Prelude.Int + +happyReduce_13 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_13 = happySpecReduce_1 0# happyReduction_13 +happyReduction_13 happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + happyIn16 + (happy_var_1 + )} + +happyReduce_14 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_14 = happySpecReduce_1 0# happyReduction_14 +happyReduction_14 happy_x_1 + = case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> + happyIn16 + (happy_var_1 + )} + +happyReduce_15 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_15 = happySpecReduce_1 0# happyReduction_15 +happyReduction_15 happy_x_1 + = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> + happyIn16 + (happy_var_1 + )} + +happyReduce_16 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_16 = happySpecReduce_1 0# happyReduction_16 +happyReduction_16 happy_x_1 + = case happyOut295 happy_x_1 of { (HappyWrap295 happy_var_1) -> + happyIn16 + (happy_var_1 + )} + +happyReduce_17 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_17 = happyMonadReduce 1# 0# happyReduction_17 +happyReduction_17 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( amsr (sLL happy_var_1 happy_var_1 $ getRdrName unrestrictedFunTyCon) + (NameAnnRArrow Nothing (epUniTok happy_var_1) Nothing []))}) + ) (\r -> happyReturn (happyIn16 r)) + +happyReduce_18 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_18 = happySpecReduce_3 1# happyReduction_18 +happyReduction_18 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_2 of { (HappyWrap18 happy_var_2) -> + happyIn17 + (fromOL happy_var_2 + )} + +happyReduce_19 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_19 = happySpecReduce_3 1# happyReduction_19 +happyReduction_19 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_2 of { (HappyWrap18 happy_var_2) -> + happyIn17 + (fromOL happy_var_2 + )} + +happyReduce_20 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_20 = happySpecReduce_3 2# happyReduction_20 +happyReduction_20 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> + case happyOut19 happy_x_3 of { (HappyWrap19 happy_var_3) -> + happyIn18 + (happy_var_1 `appOL` unitOL happy_var_3 + )}} + +happyReduce_21 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_21 = happySpecReduce_2 2# happyReduction_21 +happyReduction_21 happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> + happyIn18 + (happy_var_1 + )} + +happyReduce_22 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_22 = happySpecReduce_1 2# happyReduction_22 +happyReduction_22 happy_x_1 + = case happyOut19 happy_x_1 of { (HappyWrap19 happy_var_1) -> + happyIn18 + (unitOL happy_var_1 + )} + +happyReduce_23 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_23 = happyReduce 4# 3# happyReduction_23 +happyReduction_23 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut24 happy_x_2 of { (HappyWrap24 happy_var_2) -> + case happyOut31 happy_x_4 of { (HappyWrap31 happy_var_4) -> + happyIn19 + (sL1 happy_var_1 $ HsUnit { hsunitName = happy_var_2 + , hsunitBody = fromOL happy_var_4 } + ) `HappyStk` happyRest}}} + +happyReduce_24 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_24 = happySpecReduce_1 4# happyReduction_24 +happyReduction_24 happy_x_1 + = case happyOut24 happy_x_1 of { (HappyWrap24 happy_var_1) -> + happyIn20 + (sL1 happy_var_1 $ HsUnitId happy_var_1 [] + )} + +happyReduce_25 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_25 = happyReduce 4# 4# happyReduction_25 +happyReduction_25 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut24 happy_x_1 of { (HappyWrap24 happy_var_1) -> + case happyOut21 happy_x_3 of { (HappyWrap21 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn20 + (sLL happy_var_1 happy_var_4 $ HsUnitId happy_var_1 (fromOL happy_var_3) + ) `HappyStk` happyRest}}} + +happyReduce_26 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_26 = happySpecReduce_3 5# happyReduction_26 +happyReduction_26 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut21 happy_x_1 of { (HappyWrap21 happy_var_1) -> + case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> + happyIn21 + (happy_var_1 `appOL` unitOL happy_var_3 + )}} + +happyReduce_27 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_27 = happySpecReduce_2 5# happyReduction_27 +happyReduction_27 happy_x_2 + happy_x_1 + = case happyOut21 happy_x_1 of { (HappyWrap21 happy_var_1) -> + happyIn21 + (happy_var_1 + )} + +happyReduce_28 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_28 = happySpecReduce_1 5# happyReduction_28 +happyReduction_28 happy_x_1 + = case happyOut22 happy_x_1 of { (HappyWrap22 happy_var_1) -> + happyIn21 + (unitOL happy_var_1 + )} + +happyReduce_29 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_29 = happySpecReduce_3 6# happyReduction_29 +happyReduction_29 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut334 happy_x_1 of { (HappyWrap334 happy_var_1) -> + case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> + happyIn22 + (sLL happy_var_1 happy_var_3 $ (reLoc happy_var_1, happy_var_3) + )}} + +happyReduce_30 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_30 = happyReduce 4# 6# happyReduction_30 +happyReduction_30 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut334 happy_x_1 of { (HappyWrap334 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut334 happy_x_3 of { (HappyWrap334 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn22 + (sLL happy_var_1 happy_var_4 $ (reLoc happy_var_1, sLL happy_var_2 happy_var_4 $ HsModuleVar (reLoc happy_var_3)) + ) `HappyStk` happyRest}}}} + +happyReduce_31 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_31 = happySpecReduce_3 7# happyReduction_31 +happyReduction_31 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn23 + (sLL happy_var_1 happy_var_3 $ HsModuleVar (reLoc happy_var_2) + )}}} + +happyReduce_32 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_32 = happySpecReduce_3 7# happyReduction_32 +happyReduction_32 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut20 happy_x_1 of { (HappyWrap20 happy_var_1) -> + case happyOut334 happy_x_3 of { (HappyWrap334 happy_var_3) -> + happyIn23 + (sLL happy_var_1 happy_var_3 $ HsModuleId happy_var_1 (reLoc happy_var_3) + )}} + +happyReduce_33 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_33 = happySpecReduce_1 8# happyReduction_33 +happyReduction_33 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn24 + (sL1 happy_var_1 $ PackageName (getSTRING happy_var_1) + )} + +happyReduce_34 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_34 = happySpecReduce_1 8# happyReduction_34 +happyReduction_34 happy_x_1 + = case happyOut27 happy_x_1 of { (HappyWrap27 happy_var_1) -> + happyIn24 + (sL1 happy_var_1 $ PackageName (unLoc happy_var_1) + )} + +happyReduce_35 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_35 = happySpecReduce_1 9# happyReduction_35 +happyReduction_35 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn25 + (sL1 happy_var_1 $ getVARID happy_var_1 + )} + +happyReduce_36 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_36 = happySpecReduce_1 9# happyReduction_36 +happyReduction_36 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn25 + (sL1 happy_var_1 $ getCONID happy_var_1 + )} + +happyReduce_37 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_37 = happySpecReduce_1 9# happyReduction_37 +happyReduction_37 happy_x_1 + = case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> + happyIn25 + (happy_var_1 + )} + +happyReduce_38 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_38 = happySpecReduce_1 10# happyReduction_38 +happyReduction_38 happy_x_1 + = happyIn26 + (() + ) + +happyReduce_39 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_39 = happySpecReduce_1 10# happyReduction_39 +happyReduction_39 happy_x_1 + = happyIn26 + (() + ) + +happyReduce_40 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_40 = happySpecReduce_1 10# happyReduction_40 +happyReduction_40 happy_x_1 + = happyIn26 + (() + ) + +happyReduce_41 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_41 = happySpecReduce_1 11# happyReduction_41 +happyReduction_41 happy_x_1 + = case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> + happyIn27 + (happy_var_1 + )} + +happyReduce_42 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_42 = happySpecReduce_3 11# happyReduction_42 +happyReduction_42 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> + case happyOut27 happy_x_3 of { (HappyWrap27 happy_var_3) -> + happyIn27 + (sLL happy_var_1 happy_var_3 $ concatFS [unLoc happy_var_1, fsLit "-", (unLoc happy_var_3)] + )}} + +happyReduce_43 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_43 = happySpecReduce_0 12# happyReduction_43 +happyReduction_43 = happyIn28 + (Nothing + ) + +happyReduce_44 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_44 = happySpecReduce_3 12# happyReduction_44 +happyReduction_44 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut29 happy_x_2 of { (HappyWrap29 happy_var_2) -> + happyIn28 + (Just (fromOL happy_var_2) + )} + +happyReduce_45 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_45 = happySpecReduce_3 13# happyReduction_45 +happyReduction_45 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut29 happy_x_1 of { (HappyWrap29 happy_var_1) -> + case happyOut30 happy_x_3 of { (HappyWrap30 happy_var_3) -> + happyIn29 + (happy_var_1 `appOL` unitOL happy_var_3 + )}} + +happyReduce_46 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_46 = happySpecReduce_2 13# happyReduction_46 +happyReduction_46 happy_x_2 + happy_x_1 + = case happyOut29 happy_x_1 of { (HappyWrap29 happy_var_1) -> + happyIn29 + (happy_var_1 + )} + +happyReduce_47 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_47 = happySpecReduce_1 13# happyReduction_47 +happyReduction_47 happy_x_1 + = case happyOut30 happy_x_1 of { (HappyWrap30 happy_var_1) -> + happyIn29 + (unitOL happy_var_1 + )} + +happyReduce_48 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_48 = happySpecReduce_3 14# happyReduction_48 +happyReduction_48 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut334 happy_x_1 of { (HappyWrap334 happy_var_1) -> + case happyOut334 happy_x_3 of { (HappyWrap334 happy_var_3) -> + happyIn30 + (sLL happy_var_1 happy_var_3 $ Renaming (reLoc happy_var_1) (Just (reLoc happy_var_3)) + )}} + +happyReduce_49 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_49 = happySpecReduce_1 14# happyReduction_49 +happyReduction_49 happy_x_1 + = case happyOut334 happy_x_1 of { (HappyWrap334 happy_var_1) -> + happyIn30 + (sL1 happy_var_1 $ Renaming (reLoc happy_var_1) Nothing + )} + +happyReduce_50 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_50 = happySpecReduce_3 15# happyReduction_50 +happyReduction_50 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> + happyIn31 + (happy_var_2 + )} + +happyReduce_51 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_51 = happySpecReduce_3 15# happyReduction_51 +happyReduction_51 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> + happyIn31 + (happy_var_2 + )} + +happyReduce_52 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_52 = happySpecReduce_3 16# happyReduction_52 +happyReduction_52 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut32 happy_x_1 of { (HappyWrap32 happy_var_1) -> + case happyOut33 happy_x_3 of { (HappyWrap33 happy_var_3) -> + happyIn32 + (happy_var_1 `appOL` unitOL happy_var_3 + )}} + +happyReduce_53 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_53 = happySpecReduce_2 16# happyReduction_53 +happyReduction_53 happy_x_2 + happy_x_1 + = case happyOut32 happy_x_1 of { (HappyWrap32 happy_var_1) -> + happyIn32 + (happy_var_1 + )} + +happyReduce_54 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_54 = happySpecReduce_1 16# happyReduction_54 +happyReduction_54 happy_x_1 + = case happyOut33 happy_x_1 of { (HappyWrap33 happy_var_1) -> + happyIn32 + (unitOL happy_var_1 + )} + +happyReduce_55 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_55 = happyReduce 7# 17# happyReduction_55 +happyReduction_55 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut63 happy_x_2 of { (HappyWrap63 happy_var_2) -> + case happyOut334 happy_x_3 of { (HappyWrap334 happy_var_3) -> + case happyOut146 happy_x_4 of { (HappyWrap146 happy_var_4) -> + case happyOut47 happy_x_5 of { (HappyWrap47 happy_var_5) -> + case happyOut38 happy_x_7 of { (HappyWrap38 happy_var_7) -> + happyIn33 + (sL1 happy_var_1 $ DeclD + (case snd happy_var_2 of + NotBoot -> HsSrcFile + IsBoot -> HsBootFile) + (reLoc happy_var_3) + (sL1 happy_var_1 (HsModule (XModulePs noAnn (thdOf3 happy_var_7) happy_var_4 Nothing) (Just happy_var_3) happy_var_5 (fst $ sndOf3 happy_var_7) (snd $ sndOf3 happy_var_7))) + ) `HappyStk` happyRest}}}}}} + +happyReduce_56 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_56 = happyReduce 6# 17# happyReduction_56 +happyReduction_56 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> + case happyOut47 happy_x_4 of { (HappyWrap47 happy_var_4) -> + case happyOut38 happy_x_6 of { (HappyWrap38 happy_var_6) -> + happyIn33 + (sL1 happy_var_1 $ DeclD + HsigFile + (reLoc happy_var_2) + (sL1 happy_var_1 (HsModule (XModulePs noAnn (thdOf3 happy_var_6) happy_var_3 Nothing) (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) (snd $ sndOf3 happy_var_6))) + ) `HappyStk` happyRest}}}}} + +happyReduce_57 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_57 = happySpecReduce_3 17# happyReduction_57 +happyReduction_57 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut20 happy_x_2 of { (HappyWrap20 happy_var_2) -> + case happyOut28 happy_x_3 of { (HappyWrap28 happy_var_3) -> + happyIn33 + (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_2 + , idModRenaming = happy_var_3 + , idSignatureInclude = False }) + )}}} + +happyReduce_58 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_58 = happySpecReduce_3 17# happyReduction_58 +happyReduction_58 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut20 happy_x_3 of { (HappyWrap20 happy_var_3) -> + happyIn33 + (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_3 + , idModRenaming = Nothing + , idSignatureInclude = True }) + )}} + +happyReduce_59 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_59 = happyMonadReduce 6# 18# happyReduction_59 +happyReduction_59 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> + case happyOut47 happy_x_4 of { (HappyWrap47 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut38 happy_x_6 of { (HappyWrap38 happy_var_6) -> + ( fileSrcSpan >>= \ loc -> + acs loc (\loc cs-> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule (epTok happy_var_1) NoEpTok (epTok happy_var_5) (fstOf3 happy_var_6) [] Nothing) cs) + (thdOf3 happy_var_6) happy_var_3 Nothing) + (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) + (snd $ sndOf3 happy_var_6))) + ))}}}}}}) + ) (\r -> happyReturn (happyIn34 r)) + +happyReduce_60 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_60 = happyMonadReduce 6# 19# happyReduction_60 +happyReduction_60 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> + case happyOut47 happy_x_4 of { (HappyWrap47 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut38 happy_x_6 of { (HappyWrap38 happy_var_6) -> + ( fileSrcSpan >>= \ loc -> + acsFinal (\cs eof -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok happy_var_1) (epTok happy_var_5) (fstOf3 happy_var_6) [] eof) cs) + (thdOf3 happy_var_6) happy_var_3 Nothing) + (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) + (snd $ sndOf3 happy_var_6)) + )))}}}}}}) + ) (\r -> happyReturn (happyIn35 r)) + +happyReduce_61 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_61 = happyMonadReduce 1# 19# happyReduction_61 +happyReduction_61 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + ( fileSrcSpan >>= \ loc -> + acsFinal (\cs eof -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok NoEpTok NoEpTok (fstOf3 happy_var_1) [] eof) cs) + (thdOf3 happy_var_1) Nothing Nothing) + Nothing Nothing + (fst $ sndOf3 happy_var_1) (snd $ sndOf3 happy_var_1)))))}) + ) (\r -> happyReturn (happyIn35 r)) + +happyReduce_62 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_62 = happyMonadReduce 0# 20# happyReduction_62 +happyReduction_62 (happyRest) tk + = happyThen ((( pushModuleContext)) + ) (\r -> happyReturn (happyIn36 r)) + +happyReduce_63 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_63 = happyMonadReduce 0# 21# happyReduction_63 +happyReduction_63 (happyRest) tk + = happyThen ((( pushModuleContext)) + ) (\r -> happyReturn (happyIn37 r)) + +happyReduce_64 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_64 = happySpecReduce_3 22# happyReduction_64 +happyReduction_64 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_2 of { (HappyWrap40 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn38 + ((fst happy_var_2, snd happy_var_2, epExplicitBraces happy_var_1 happy_var_3) + )}}} + +happyReduce_65 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_65 = happySpecReduce_3 22# happyReduction_65 +happyReduction_65 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_2 of { (HappyWrap40 happy_var_2) -> + happyIn38 + ((fst happy_var_2, snd happy_var_2, EpVirtualBraces (getVOCURLY happy_var_1)) + )}} + +happyReduce_66 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_66 = happySpecReduce_3 23# happyReduction_66 +happyReduction_66 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_2 of { (HappyWrap40 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn39 + ((fst happy_var_2, snd happy_var_2, epExplicitBraces happy_var_1 happy_var_3) + )}}} + +happyReduce_67 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_67 = happySpecReduce_3 23# happyReduction_67 +happyReduction_67 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut40 happy_x_2 of { (HappyWrap40 happy_var_2) -> + happyIn39 + (([], snd happy_var_2, EpVirtualBraces leftmostColumn) + )} + +happyReduce_68 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_68 = happySpecReduce_2 24# happyReduction_68 +happyReduction_68 happy_x_2 + happy_x_1 + = case happyOut59 happy_x_1 of { (HappyWrap59 happy_var_1) -> + case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> + happyIn40 + ((reverse happy_var_1, happy_var_2) + )}} + +happyReduce_69 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_69 = happySpecReduce_2 25# happyReduction_69 +happyReduction_69 happy_x_2 + happy_x_1 + = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> + case happyOut80 happy_x_2 of { (HappyWrap80 happy_var_2) -> + happyIn41 + ((reverse happy_var_1, cvTopDecls happy_var_2) + )}} + +happyReduce_70 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_70 = happySpecReduce_2 25# happyReduction_70 +happyReduction_70 happy_x_2 + happy_x_1 + = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> + case happyOut79 happy_x_2 of { (HappyWrap79 happy_var_2) -> + happyIn41 + ((reverse happy_var_1, cvTopDecls happy_var_2) + )}} + +happyReduce_71 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_71 = happySpecReduce_1 25# happyReduction_71 +happyReduction_71 happy_x_1 + = case happyOut60 happy_x_1 of { (HappyWrap60 happy_var_1) -> + happyIn41 + ((reverse happy_var_1, []) + )} + +happyReduce_72 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_72 = happyMonadReduce 6# 26# happyReduction_72 +happyReduction_72 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> + case happyOut47 happy_x_4 of { (HappyWrap47 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut43 happy_x_6 of { (HappyWrap43 happy_var_6) -> + ( fileSrcSpan >>= \ loc -> + acs loc (\loc cs -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok happy_var_1) (epTok happy_var_5) [] [] Nothing) cs) + EpNoLayout happy_var_3 Nothing) + (Just happy_var_2) happy_var_4 happy_var_6 [] + ))))}}}}}}) + ) (\r -> happyReturn (happyIn42 r)) + +happyReduce_73 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_73 = happyMonadReduce 6# 26# happyReduction_73 +happyReduction_73 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> + case happyOut47 happy_x_4 of { (HappyWrap47 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut43 happy_x_6 of { (HappyWrap43 happy_var_6) -> + ( fileSrcSpan >>= \ loc -> + acs loc (\loc cs -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok happy_var_1) (epTok happy_var_5) [] [] Nothing) cs) + EpNoLayout happy_var_3 Nothing) + (Just happy_var_2) happy_var_4 happy_var_6 [] + ))))}}}}}}) + ) (\r -> happyReturn (happyIn42 r)) + +happyReduce_74 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_74 = happyMonadReduce 1# 26# happyReduction_74 +happyReduction_74 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> + ( fileSrcSpan >>= \ loc -> + return (L loc (HsModule (XModulePs noAnn EpNoLayout Nothing Nothing) Nothing Nothing happy_var_1 [])))}) + ) (\r -> happyReturn (happyIn42 r)) + +happyReduce_75 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_75 = happySpecReduce_2 27# happyReduction_75 +happyReduction_75 happy_x_2 + happy_x_1 + = case happyOut45 happy_x_2 of { (HappyWrap45 happy_var_2) -> + happyIn43 + (happy_var_2 + )} + +happyReduce_76 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_76 = happySpecReduce_2 27# happyReduction_76 +happyReduction_76 happy_x_2 + happy_x_1 + = case happyOut45 happy_x_2 of { (HappyWrap45 happy_var_2) -> + happyIn43 + (happy_var_2 + )} + +happyReduce_77 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_77 = happySpecReduce_2 28# happyReduction_77 +happyReduction_77 happy_x_2 + happy_x_1 + = case happyOut45 happy_x_2 of { (HappyWrap45 happy_var_2) -> + happyIn44 + (happy_var_2 + )} + +happyReduce_78 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_78 = happySpecReduce_2 28# happyReduction_78 +happyReduction_78 happy_x_2 + happy_x_1 + = case happyOut45 happy_x_2 of { (HappyWrap45 happy_var_2) -> + happyIn44 + (happy_var_2 + )} + +happyReduce_79 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_79 = happySpecReduce_2 29# happyReduction_79 +happyReduction_79 happy_x_2 + happy_x_1 + = case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> + happyIn45 + (happy_var_2 + )} + +happyReduce_80 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_80 = happySpecReduce_1 30# happyReduction_80 +happyReduction_80 happy_x_1 + = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> + happyIn46 + (happy_var_1 + )} + +happyReduce_81 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_81 = happySpecReduce_1 30# happyReduction_81 +happyReduction_81 happy_x_1 + = case happyOut60 happy_x_1 of { (HappyWrap60 happy_var_1) -> + happyIn46 + (happy_var_1 + )} + +happyReduce_82 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_82 = happyMonadReduce 3# 31# happyReduction_82 +happyReduction_82 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_2 of { (HappyWrap48 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_3 (fromOL $ snd happy_var_2)) + (AnnList Nothing (ListParens (epTok happy_var_1) (epTok happy_var_3)) [] (noAnn,fst happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn47 r)) + +happyReduce_83 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_83 = happySpecReduce_0 31# happyReduction_83 +happyReduction_83 = happyIn47 + (Nothing + ) + +happyReduce_84 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_84 = happySpecReduce_1 32# happyReduction_84 +happyReduction_84 happy_x_1 + = case happyOut49 happy_x_1 of { (HappyWrap49 happy_var_1) -> + happyIn48 + (([], happy_var_1) + )} + +happyReduce_85 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_85 = happySpecReduce_0 32# happyReduction_85 +happyReduction_85 = happyIn48 + (([], nilOL) + ) + +happyReduce_86 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_86 = happyMonadReduce 2# 32# happyReduction_86 +happyReduction_86 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut49 happy_x_1 of { (HappyWrap49 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingCommaA t (epTok happy_var_2) + return ([], snocOL hs t'))}}) + ) (\r -> happyReturn (happyIn48 r)) + +happyReduce_87 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_87 = happySpecReduce_1 32# happyReduction_87 +happyReduction_87 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn48 + (([epTok happy_var_1], nilOL) + )} + +happyReduce_88 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_88 = happyMonadReduce 3# 33# happyReduction_88 +happyReduction_88 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut49 happy_x_1 of { (HappyWrap49 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut50 happy_x_3 of { (HappyWrap50 happy_var_3) -> + ( let ls = happy_var_1 + in if isNilOL ls + then return (ls `appOL` happy_var_3) + else case ls of + SnocOL hs t -> do + t' <- addTrailingCommaA t (epTok happy_var_2) + return (snocOL hs t' `appOL` happy_var_3))}}}) + ) (\r -> happyReturn (happyIn49 r)) + +happyReduce_89 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_89 = happySpecReduce_1 33# happyReduction_89 +happyReduction_89 happy_x_1 + = case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> + happyIn49 + (happy_var_1 + )} + +happyReduce_90 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_90 = happyMonadReduce 1# 34# happyReduction_90 +happyReduction_90 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> + ( return (unitOL happy_var_1))}) + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_91 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_91 = happyMonadReduce 3# 35# happyReduction_91 +happyReduction_91 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut146 happy_x_1 of { (HappyWrap146 happy_var_1) -> + case happyOut56 happy_x_2 of { (HappyWrap56 happy_var_2) -> + case happyOut52 happy_x_3 of { (HappyWrap52 happy_var_3) -> + ( do { let { span = (maybe comb2 comb3 happy_var_1) happy_var_2 happy_var_3 } + ; impExp <- mkModuleImpExp happy_var_1 (fst $ unLoc happy_var_3) happy_var_2 (snd $ unLoc happy_var_3) + ; return $ reLoc $ sL span $ impExp })}}}) + ) (\r -> happyReturn (happyIn51 r)) + +happyReduce_92 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_92 = happyMonadReduce 3# 35# happyReduction_92 +happyReduction_92 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut146 happy_x_1 of { (HappyWrap146 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut334 happy_x_3 of { (HappyWrap334 happy_var_3) -> + ( do { let { span = (maybe comb2 comb3 happy_var_1) happy_var_2 happy_var_3 + ; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 loc) happy_var_1) happy_var_2 } + ; locImpExp <- return (sL span (IEModuleContents (happy_var_1, (epTok happy_var_2)) happy_var_3)) + ; return $ reLoc $ locImpExp })}}}) + ) (\r -> happyReturn (happyIn51 r)) + +happyReduce_93 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_93 = happyMonadReduce 3# 35# happyReduction_93 +happyReduction_93 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut146 happy_x_1 of { (HappyWrap146 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut286 happy_x_3 of { (HappyWrap286 happy_var_3) -> + ( do { warnPatternNamespaceSpecifier (getLoc happy_var_2) + ; let span = (maybe comb2 comb3 happy_var_1) happy_var_2 happy_var_3 + ; return $ reLoc $ sL span $ IEVar happy_var_1 (sLLa happy_var_2 happy_var_3 (IEPattern (epTok happy_var_2) happy_var_3)) Nothing })}}}) + ) (\r -> happyReturn (happyIn51 r)) + +happyReduce_94 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_94 = happyMonadReduce 3# 35# happyReduction_94 +happyReduction_94 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut146 happy_x_1 of { (HappyWrap146 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut301 happy_x_3 of { (HappyWrap301 happy_var_3) -> + ( do { let { span = (maybe comb2 comb3 happy_var_1) happy_var_2 happy_var_3 } + ; locImpExp <- return (sL span (IEThingAbs happy_var_1 (sLLa happy_var_2 happy_var_3 (IEDefault (epTok happy_var_2) happy_var_3)) Nothing)) + ; return $ reLoc $ locImpExp })}}}) + ) (\r -> happyReturn (happyIn51 r)) + +happyReduce_95 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_95 = happySpecReduce_0 36# happyReduction_95 +happyReduction_95 = happyIn52 + (sL0 (noAnn,ImpExpAbs) + ) + +happyReduce_96 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_96 = happyMonadReduce 3# 36# happyReduction_96 +happyReduction_96 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut53 happy_x_2 of { (HappyWrap53 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( mkImpExpSubSpec (reverse happy_var_2) + >>= \ie -> return $ sLL happy_var_1 happy_var_3 + ((epTok happy_var_1, epTok happy_var_3), ie))}}}) + ) (\r -> happyReturn (happyIn52 r)) + +happyReduce_97 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_97 = happySpecReduce_0 37# happyReduction_97 +happyReduction_97 = happyIn53 + ([] + ) + +happyReduce_98 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_98 = happySpecReduce_1 37# happyReduction_98 +happyReduction_98 happy_x_1 + = case happyOut54 happy_x_1 of { (HappyWrap54 happy_var_1) -> + happyIn53 + (happy_var_1 + )} + +happyReduce_99 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_99 = happyMonadReduce 3# 38# happyReduction_99 +happyReduction_99 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut54 happy_x_1 of { (HappyWrap54 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut55 happy_x_3 of { (HappyWrap55 happy_var_3) -> + ( case happy_var_1 of + ((L la (ImpExpQcWildcard tok _)):t) -> + do { return (happy_var_3 : L la (ImpExpQcWildcard tok (epTok happy_var_2)) : t) } + (l:t) -> + do { l' <- addTrailingCommaA l (epTok happy_var_2) + ; return (happy_var_3 : l' : t)})}}}) + ) (\r -> happyReturn (happyIn54 r)) + +happyReduce_100 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_100 = happySpecReduce_1 38# happyReduction_100 +happyReduction_100 happy_x_1 + = case happyOut55 happy_x_1 of { (HappyWrap55 happy_var_1) -> + happyIn54 + ([happy_var_1] + )} + +happyReduce_101 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_101 = happySpecReduce_1 39# happyReduction_101 +happyReduction_101 happy_x_1 + = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> + happyIn55 + (happy_var_1 + )} + +happyReduce_102 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_102 = happySpecReduce_1 39# happyReduction_102 +happyReduction_102 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn55 + (sL1a happy_var_1 (ImpExpQcWildcard (epTok happy_var_1) NoEpTok) + )} + +happyReduce_103 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_103 = happySpecReduce_1 40# happyReduction_103 +happyReduction_103 happy_x_1 + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + happyIn56 + (sL1a happy_var_1 (mkPlainImpExp happy_var_1) + )} + +happyReduce_104 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_104 = happyMonadReduce 2# 40# happyReduction_104 +happyReduction_104 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut298 happy_x_2 of { (HappyWrap298 happy_var_2) -> + ( do { imp_exp <- mkTypeImpExp (epTok happy_var_1) happy_var_2 + ; return $ sLLa happy_var_1 happy_var_2 imp_exp })}}) + ) (\r -> happyReturn (happyIn56 r)) + +happyReduce_105 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_105 = happyMonadReduce 2# 40# happyReduction_105 +happyReduction_105 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut125 happy_x_2 of { (HappyWrap125 happy_var_2) -> + ( do { imp_exp <- mkDataImpExp (epTok happy_var_1) happy_var_2 + ; return $ sLLa happy_var_1 happy_var_2 imp_exp })}}) + ) (\r -> happyReturn (happyIn56 r)) + +happyReduce_106 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_106 = happySpecReduce_1 41# happyReduction_106 +happyReduction_106 happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + happyIn57 + (happy_var_1 + )} + +happyReduce_107 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_107 = happySpecReduce_1 41# happyReduction_107 +happyReduction_107 happy_x_1 + = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> + happyIn57 + (happy_var_1 + )} + +happyReduce_108 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_108 = happySpecReduce_2 42# happyReduction_108 +happyReduction_108 happy_x_2 + happy_x_1 + = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn58 + (if isZeroWidthSpan (gl happy_var_2) then (sL1 happy_var_1 $ unLoc happy_var_1) else (sLL happy_var_1 happy_var_2 $ AddSemiAnn (epTok happy_var_2) : (unLoc happy_var_1)) + )}} + +happyReduce_109 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_109 = happySpecReduce_1 42# happyReduction_109 +happyReduction_109 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn58 + (case msemi happy_var_1 of + [] -> noLoc [] + ms -> sL1 happy_var_1 $ ms + )} + +happyReduce_110 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_110 = happySpecReduce_2 43# happyReduction_110 +happyReduction_110 happy_x_2 + happy_x_1 + = case happyOut59 happy_x_1 of { (HappyWrap59 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn59 + (if isZeroWidthSpan (gl happy_var_2) then happy_var_1 else (AddSemiAnn (epTok happy_var_2) : happy_var_1) + )}} + +happyReduce_111 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_111 = happySpecReduce_0 43# happyReduction_111 +happyReduction_111 = happyIn59 + ([] + ) + +happyReduce_112 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_112 = happySpecReduce_2 44# happyReduction_112 +happyReduction_112 happy_x_2 + happy_x_1 + = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> + case happyOut62 happy_x_2 of { (HappyWrap62 happy_var_2) -> + happyIn60 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_113 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_113 = happyMonadReduce 3# 45# happyReduction_113 +happyReduction_113 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> + case happyOut62 happy_x_2 of { (HappyWrap62 happy_var_2) -> + case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> + ( do { i <- amsAl happy_var_2 (comb2 happy_var_2 happy_var_3) (reverse $ unLoc happy_var_3) + ; return (i : happy_var_1)})}}}) + ) (\r -> happyReturn (happyIn61 r)) + +happyReduce_114 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_114 = happySpecReduce_0 45# happyReduction_114 +happyReduction_114 = happyIn61 + ([] + ) + +happyReduce_115 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_115 = happyMonadReduce 11# 46# happyReduction_115 +happyReduction_115 (happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut63 happy_x_2 of { (HappyWrap63 happy_var_2) -> + case happyOut65 happy_x_3 of { (HappyWrap65 happy_var_3) -> + case happyOut64 happy_x_4 of { (HappyWrap64 happy_var_4) -> + case happyOut67 happy_x_5 of { (HappyWrap67 happy_var_5) -> + case happyOut66 happy_x_6 of { (HappyWrap66 happy_var_6) -> + case happyOut334 happy_x_7 of { (HappyWrap334 happy_var_7) -> + case happyOut65 happy_x_8 of { (HappyWrap65 happy_var_8) -> + case happyOut67 happy_x_9 of { (HappyWrap67 happy_var_9) -> + case happyOut68 happy_x_10 of { (HappyWrap68 happy_var_10) -> + case happyOut69 happy_x_11 of { (HappyWrap69 happy_var_11) -> + ( do { + ; let { ; mPreQual = happy_var_5 + ; mPostQual = happy_var_9 + ; mPreLevel = happy_var_3 + ; mPostLevel = happy_var_8 } + ; (qualSpec, levelSpec) <- checkImportDecl mPreQual mPostQual mPreLevel mPostLevel + ; let anns + = EpAnnImportDecl + { importDeclAnnImport = epTok happy_var_1 + , importDeclAnnPragma = fst $ fst happy_var_2 + , importDeclAnnLevel = fst $ levelSpec + , importDeclAnnSafe = fst happy_var_4 + , importDeclAnnQualified = fst $ qualSpec + , importDeclAnnPackage = fst happy_var_6 + , importDeclAnnAs = fst happy_var_10 + } + ; let loc = (comb6 happy_var_1 happy_var_7 happy_var_8 happy_var_9 (snd happy_var_10) happy_var_11); + ; fmap reLoc $ acs loc (\loc cs -> L loc $ + ImportDecl { ideclExt = XImportDeclPass (EpAnn (spanAsAnchor loc) anns cs) (snd $ fst happy_var_2) False + , ideclName = happy_var_7, ideclPkgQual = snd happy_var_6 + , ideclSource = snd happy_var_2 + , ideclLevelSpec = snd $ levelSpec + , ideclSafe = snd happy_var_4 + , ideclQualified = snd $ qualSpec + , ideclAs = unLoc (snd happy_var_10) + , ideclImportList = unLoc happy_var_11 }) + })}}}}}}}}}}}) + ) (\r -> happyReturn (happyIn62 r)) + +happyReduce_116 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_116 = happySpecReduce_2 47# happyReduction_116 +happyReduction_116 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn63 + (((Just (glR happy_var_1,epTok happy_var_2),getSOURCE_PRAGs happy_var_1) + , IsBoot) + )}} + +happyReduce_117 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_117 = happySpecReduce_0 47# happyReduction_117 +happyReduction_117 = happyIn63 + (((Nothing,NoSourceText),NotBoot) + ) + +happyReduce_118 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_118 = happySpecReduce_1 48# happyReduction_118 +happyReduction_118 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn64 + ((Just (epTok happy_var_1),True) + )} + +happyReduce_119 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_119 = happySpecReduce_0 48# happyReduction_119 +happyReduction_119 = happyIn64 + ((Nothing, False) + ) + +happyReduce_120 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_120 = happySpecReduce_1 49# happyReduction_120 +happyReduction_120 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn65 + ((Just (EpAnnLevelSplice (epTok happy_var_1))) + )} + +happyReduce_121 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_121 = happySpecReduce_1 49# happyReduction_121 +happyReduction_121 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn65 + ((Just (EpAnnLevelQuote (epTok happy_var_1))) + )} + +happyReduce_122 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_122 = happySpecReduce_0 49# happyReduction_122 +happyReduction_122 = happyIn65 + ((Nothing) + ) + +happyReduce_123 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_123 = happyMonadReduce 1# 50# happyReduction_123 +happyReduction_123 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( do { let { pkgFS = getSTRING happy_var_1 } + ; unless (looksLikePackageName (unpackFS pkgFS)) $ + addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $ + (PsErrInvalidPackageName pkgFS) + ; return (Just (glR happy_var_1), RawPkgQual (StringLiteral (getSTRINGs happy_var_1) pkgFS Nothing)) })}) + ) (\r -> happyReturn (happyIn66 r)) + +happyReduce_124 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_124 = happySpecReduce_0 50# happyReduction_124 +happyReduction_124 = happyIn66 + ((Nothing,NoRawPkgQual) + ) + +happyReduce_125 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_125 = happySpecReduce_1 51# happyReduction_125 +happyReduction_125 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn67 + (Just (epTok happy_var_1) + )} + +happyReduce_126 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_126 = happySpecReduce_0 51# happyReduction_126 +happyReduction_126 = happyIn67 + (Nothing + ) + +happyReduce_127 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_127 = happySpecReduce_2 52# happyReduction_127 +happyReduction_127 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + happyIn68 + ((Just (epTok happy_var_1) + ,sLL happy_var_1 happy_var_2 (Just happy_var_2)) + )}} + +happyReduce_128 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_128 = happySpecReduce_0 52# happyReduction_128 +happyReduction_128 = happyIn68 + ((Nothing,noLoc Nothing) + ) + +happyReduce_129 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_129 = happyMonadReduce 1# 53# happyReduction_129 +happyReduction_129 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut70 happy_x_1 of { (HappyWrap70 happy_var_1) -> + ( let (b, ie) = unLoc happy_var_1 in + checkImportSpec ie + >>= \checkedIe -> + return (L (gl happy_var_1) (Just (b, checkedIe))))}) + ) (\r -> happyReturn (happyIn69 r)) + +happyReduce_130 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_130 = happySpecReduce_0 53# happyReduction_130 +happyReduction_130 = happyIn69 + (noLoc Nothing + ) + +happyReduce_131 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_131 = happyMonadReduce 3# 54# happyReduction_131 +happyReduction_131 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut71 happy_x_2 of { (HappyWrap71 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { es <- amsr (sLL happy_var_1 happy_var_3 $ fromOL $ snd happy_var_2) + (AnnList Nothing (ListParens (epTok happy_var_1) (epTok happy_var_3)) [] (noAnn,fst happy_var_2) []) + ; return $ sLL happy_var_1 happy_var_3 (Exactly, es)})}}}) + ) (\r -> happyReturn (happyIn70 r)) + +happyReduce_132 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_132 = happyMonadReduce 4# 54# happyReduction_132 +happyReduction_132 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut71 happy_x_3 of { (HappyWrap71 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( do { es <- amsr (sLL happy_var_1 happy_var_4 $ fromOL $ snd happy_var_3) + (AnnList Nothing (ListParens (epTok happy_var_2) (epTok happy_var_4)) [] (epTok happy_var_1,fst happy_var_3) []) + ; return $ sLL happy_var_1 happy_var_4 (EverythingBut, es)})}}}}) + ) (\r -> happyReturn (happyIn70 r)) + +happyReduce_133 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_133 = happySpecReduce_1 55# happyReduction_133 +happyReduction_133 happy_x_1 + = case happyOut72 happy_x_1 of { (HappyWrap72 happy_var_1) -> + happyIn71 + (([], happy_var_1) + )} + +happyReduce_134 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_134 = happySpecReduce_0 55# happyReduction_134 +happyReduction_134 = happyIn71 + (([], nilOL) + ) + +happyReduce_135 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_135 = happyMonadReduce 2# 55# happyReduction_135 +happyReduction_135 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut72 happy_x_1 of { (HappyWrap72 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingCommaA t (epTok happy_var_2) + return ([], snocOL hs t'))}}) + ) (\r -> happyReturn (happyIn71 r)) + +happyReduce_136 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_136 = happySpecReduce_1 55# happyReduction_136 +happyReduction_136 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn71 + (([epTok happy_var_1], nilOL) + )} + +happyReduce_137 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_137 = happyMonadReduce 3# 56# happyReduction_137 +happyReduction_137 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut72 happy_x_1 of { (HappyWrap72 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut73 happy_x_3 of { (HappyWrap73 happy_var_3) -> + ( let ls = happy_var_1 + in if isNilOL ls + then return (ls `appOL` happy_var_3) + else case ls of + SnocOL hs t -> do + t' <- addTrailingCommaA t (epTok happy_var_2) + return (snocOL hs t' `appOL` happy_var_3))}}}) + ) (\r -> happyReturn (happyIn72 r)) + +happyReduce_138 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_138 = happySpecReduce_1 56# happyReduction_138 +happyReduction_138 happy_x_1 + = case happyOut73 happy_x_1 of { (HappyWrap73 happy_var_1) -> + happyIn72 + (happy_var_1 + )} + +happyReduce_139 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_139 = happyMonadReduce 2# 57# happyReduction_139 +happyReduction_139 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> + case happyOut52 happy_x_2 of { (HappyWrap52 happy_var_2) -> + ( fmap (unitOL . reLoc . (sLL happy_var_1 happy_var_2)) $ mkModuleImpExp Nothing (fst $ unLoc happy_var_2) happy_var_1 (snd $ unLoc happy_var_2))}}) + ) (\r -> happyReturn (happyIn73 r)) + +happyReduce_140 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_140 = happyMonadReduce 2# 57# happyReduction_140 +happyReduction_140 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + ( fmap (unitOL . reLoc) $ return (sLL happy_var_1 happy_var_2 (IEModuleContents (Nothing, (epTok happy_var_1)) happy_var_2)))}}) + ) (\r -> happyReturn (happyIn73 r)) + +happyReduce_141 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_141 = happyMonadReduce 2# 57# happyReduction_141 +happyReduction_141 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut286 happy_x_2 of { (HappyWrap286 happy_var_2) -> + ( do { warnPatternNamespaceSpecifier (getLoc happy_var_1) + ; return $ unitOL $ reLoc $ sLL happy_var_1 happy_var_2 $ IEVar Nothing (sLLa happy_var_1 happy_var_2 (IEPattern (epTok happy_var_1) happy_var_2)) Nothing })}}) + ) (\r -> happyReturn (happyIn73 r)) + +happyReduce_142 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_142 = happySpecReduce_0 58# happyReduction_142 +happyReduction_142 = happyIn74 + (Nothing + ) + +happyReduce_143 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_143 = happySpecReduce_1 58# happyReduction_143 +happyReduction_143 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn74 + (Just (sL1 happy_var_1 (getINTEGERs happy_var_1,fromInteger (il_value (getINTEGER happy_var_1)))) + )} + +happyReduce_144 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_144 = happySpecReduce_1 59# happyReduction_144 +happyReduction_144 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn75 + (sL1 happy_var_1 InfixN + )} + +happyReduce_145 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_145 = happySpecReduce_1 59# happyReduction_145 +happyReduction_145 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn75 + (sL1 happy_var_1 InfixL + )} + +happyReduce_146 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_146 = happySpecReduce_1 59# happyReduction_146 +happyReduction_146 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn75 + (sL1 happy_var_1 InfixR + )} + +happyReduce_147 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_147 = happyMonadReduce 3# 60# happyReduction_147 +happyReduction_147 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut76 happy_x_1 of { (HappyWrap76 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut306 happy_x_3 of { (HappyWrap306 happy_var_3) -> + ( case (unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingCommaN t (gl happy_var_2) + return (sLL happy_var_1 happy_var_3 (snocOL hs t' `appOL` unitOL happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn76 r)) + +happyReduce_148 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_148 = happySpecReduce_1 60# happyReduction_148 +happyReduction_148 happy_x_1 + = case happyOut306 happy_x_1 of { (HappyWrap306 happy_var_1) -> + happyIn76 + (sL1 happy_var_1 (unitOL happy_var_1) + )} + +happyReduce_149 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_149 = happySpecReduce_2 61# happyReduction_149 +happyReduction_149 happy_x_2 + happy_x_1 + = case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> + case happyOut82 happy_x_2 of { (HappyWrap82 happy_var_2) -> + happyIn77 + (happy_var_1 `snocOL` happy_var_2 + )}} + +happyReduce_150 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_150 = happyMonadReduce 3# 62# happyReduction_150 +happyReduction_150 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> + case happyOut82 happy_x_2 of { (HappyWrap82 happy_var_2) -> + case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> + ( do { t <- amsAl happy_var_2 (comb2 happy_var_2 happy_var_3) (reverse $ unLoc happy_var_3) + ; return (happy_var_1 `snocOL` t) })}}}) + ) (\r -> happyReturn (happyIn78 r)) + +happyReduce_151 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_151 = happySpecReduce_0 62# happyReduction_151 +happyReduction_151 = happyIn78 + (nilOL + ) + +happyReduce_152 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_152 = happySpecReduce_2 63# happyReduction_152 +happyReduction_152 happy_x_2 + happy_x_1 + = case happyOut80 happy_x_1 of { (HappyWrap80 happy_var_1) -> + case happyOut81 happy_x_2 of { (HappyWrap81 happy_var_2) -> + happyIn79 + (happy_var_1 `snocOL` happy_var_2 + )}} + +happyReduce_153 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_153 = happyMonadReduce 3# 64# happyReduction_153 +happyReduction_153 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut80 happy_x_1 of { (HappyWrap80 happy_var_1) -> + case happyOut81 happy_x_2 of { (HappyWrap81 happy_var_2) -> + case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> + ( do { t <- amsAl happy_var_2 (comb2 happy_var_2 happy_var_3) (reverse $ unLoc happy_var_3) + ; return (happy_var_1 `snocOL` t) })}}}) + ) (\r -> happyReturn (happyIn80 r)) + +happyReduce_154 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_154 = happySpecReduce_0 64# happyReduction_154 +happyReduction_154 = happyIn80 + (nilOL + ) + +happyReduce_155 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_155 = happyMonadReduce 1# 65# happyReduction_155 +happyReduction_155 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut82 happy_x_1 of { (HappyWrap82 happy_var_1) -> + ( commentsPA happy_var_1)}) + ) (\r -> happyReturn (happyIn81 r)) + +happyReduce_156 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_156 = happySpecReduce_1 66# happyReduction_156 +happyReduction_156 happy_x_1 + = case happyOut83 happy_x_1 of { (HappyWrap83 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (TyClD noExtField (unLoc happy_var_1)) + )} + +happyReduce_157 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_157 = happySpecReduce_1 66# happyReduction_157 +happyReduction_157 happy_x_1 + = case happyOut85 happy_x_1 of { (HappyWrap85 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (TyClD noExtField (unLoc happy_var_1)) + )} + +happyReduce_158 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_158 = happySpecReduce_1 66# happyReduction_158 +happyReduction_158 happy_x_1 + = case happyOut86 happy_x_1 of { (HappyWrap86 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (KindSigD noExtField (unLoc happy_var_1)) + )} + +happyReduce_159 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_159 = happySpecReduce_1 66# happyReduction_159 +happyReduction_159 happy_x_1 + = case happyOut88 happy_x_1 of { (HappyWrap88 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (InstD noExtField (unLoc happy_var_1)) + )} + +happyReduce_160 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_160 = happySpecReduce_1 66# happyReduction_160 +happyReduction_160 happy_x_1 + = case happyOut114 happy_x_1 of { (HappyWrap114 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (DerivD noExtField (unLoc happy_var_1)) + )} + +happyReduce_161 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_161 = happySpecReduce_1 66# happyReduction_161 +happyReduction_161 happy_x_1 + = case happyOut115 happy_x_1 of { (HappyWrap115 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (RoleAnnotD noExtField (unLoc happy_var_1)) + )} + +happyReduce_162 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_162 = happySpecReduce_1 66# happyReduction_162 +happyReduction_162 happy_x_1 + = case happyOut84 happy_x_1 of { (HappyWrap84 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (DefD noExtField (unLoc happy_var_1)) + )} + +happyReduce_163 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_163 = happyMonadReduce 2# 66# happyReduction_163 +happyReduction_163 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut156 happy_x_2 of { (HappyWrap156 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 ((unLoc happy_var_2) (epTok happy_var_1))))}}) + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_164 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_164 = happyMonadReduce 3# 66# happyReduction_164 +happyReduction_164 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut151 happy_x_2 of { (HappyWrap151 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings ((glR happy_var_1,epTok happy_var_3), (getDEPRECATED_PRAGs happy_var_1)) (fromOL happy_var_2))))}}}) + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_165 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_165 = happyMonadReduce 3# 66# happyReduction_165 +happyReduction_165 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut148 happy_x_2 of { (HappyWrap148 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings ((glR happy_var_1,epTok happy_var_3), (getWARNING_PRAGs happy_var_1)) (fromOL happy_var_2))))}}}) + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_166 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_166 = happyMonadReduce 3# 66# happyReduction_166 +happyReduction_166 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut138 happy_x_2 of { (HappyWrap138 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ RuleD noExtField (HsRules ((glR happy_var_1,epTok happy_var_3), (getRULES_PRAGs happy_var_1)) (reverse happy_var_2))))}}}) + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_167 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_167 = happySpecReduce_1 66# happyReduction_167 +happyReduction_167 happy_x_1 + = case happyOut155 happy_x_1 of { (HappyWrap155 happy_var_1) -> + happyIn82 + (happy_var_1 + )} + +happyReduce_168 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_168 = happySpecReduce_1 66# happyReduction_168 +happyReduction_168 happy_x_1 + = case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> + happyIn82 + (happy_var_1 + )} + +happyReduce_169 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_169 = happyMonadReduce 1# 66# happyReduction_169 +happyReduction_169 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + commentsPA $ mkSpliceDecl happy_var_1)}) + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_170 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_170 = happyMonadReduce 4# 67# happyReduction_170 +happyReduction_170 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut111 happy_x_2 of { (HappyWrap111 happy_var_2) -> + case happyOut190 happy_x_3 of { (HappyWrap190 happy_var_3) -> + case happyOut129 happy_x_4 of { (HappyWrap129 happy_var_4) -> + ( do { let {(wtok, (oc,semis,cc)) = fstOf3 $ unLoc happy_var_4} + ; mkClassDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) happy_var_2 happy_var_3 (sndOf3 $ unLoc happy_var_4) (thdOf3 $ unLoc happy_var_4) + (AnnClassDecl (epTok happy_var_1) [] [] (fst $ unLoc happy_var_3) wtok oc cc semis) })}}}}) + ) (\r -> happyReturn (happyIn83 r)) + +happyReduce_171 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_171 = happyMonadReduce 5# 68# happyReduction_171 +happyReduction_171 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut93 happy_x_2 of { (HappyWrap93 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut183 happy_x_4 of { (HappyWrap183 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( amsA' (sLL happy_var_1 happy_var_5 (DefaultDecl (epTok happy_var_1,epTok happy_var_3,epTok happy_var_5) happy_var_2 happy_var_4)))}}}}}) + ) (\r -> happyReturn (happyIn84 r)) + +happyReduce_172 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_172 = happyMonadReduce 4# 69# happyReduction_172 +happyReduction_172 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut172 happy_x_2 of { (HappyWrap172 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut168 happy_x_4 of { (HappyWrap168 happy_var_4) -> + ( mkTySynonym (comb2 happy_var_1 happy_var_4) happy_var_2 happy_var_4 (epTok happy_var_1) (epTok happy_var_3))}}}}) + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_173 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_173 = happyMonadReduce 6# 69# happyReduction_173 +happyReduction_173 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + case happyOut109 happy_x_4 of { (HappyWrap109 happy_var_4) -> + case happyOut94 happy_x_5 of { (HappyWrap94 happy_var_5) -> + case happyOut97 happy_x_6 of { (HappyWrap97 happy_var_6) -> + ( do { let { (tdcolon, tequal) = fst $ unLoc happy_var_4 } + ; let { tvbar = fst $ unLoc happy_var_5 } + ; let { (twhere, (toc, tdd, tcc)) = fst $ unLoc happy_var_6 } + ; mkFamDecl (comb5 happy_var_1 happy_var_3 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_6) TopLevel happy_var_3 + (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) + (AnnFamilyDecl [] [] (epTok happy_var_1) noAnn (epTok happy_var_2) tdcolon tequal tvbar twhere toc tdd tcc) })}}}}}}) + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_174 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_174 = happyMonadReduce 5# 69# happyReduction_174 +happyReduction_174 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut105 happy_x_1 of { (HappyWrap105 happy_var_1) -> + case happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> + case happyOut111 happy_x_3 of { (HappyWrap111 happy_var_3) -> + case happyOut198 happy_x_4 of { (HappyWrap198 happy_var_4) -> + case happyOut207 happy_x_5 of { (HappyWrap207 happy_var_5) -> + ( do { let { (tdata, tnewtype, ttype) = fstOf3 $ unLoc happy_var_1} + ; let { tequal = fst $ unLoc happy_var_4 } + ; mkTyData (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (sndOf3 $ unLoc happy_var_1) (thdOf3 $ unLoc happy_var_1) happy_var_2 happy_var_3 + Nothing (reverse (snd $ unLoc happy_var_4)) + (fmap reverse happy_var_5) + (AnnDataDefn [] [] ttype tnewtype tdata NoEpTok NoEpUniTok NoEpTok NoEpTok NoEpTok tequal) + })}}}}}) + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_175 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_175 = happyMonadReduce 6# 69# happyReduction_175 +happyReduction_175 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut105 happy_x_1 of { (HappyWrap105 happy_var_1) -> + case happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> + case happyOut111 happy_x_3 of { (HappyWrap111 happy_var_3) -> + case happyOut107 happy_x_4 of { (HappyWrap107 happy_var_4) -> + case happyOut195 happy_x_5 of { (HappyWrap195 happy_var_5) -> + case happyOut207 happy_x_6 of { (HappyWrap207 happy_var_6) -> + ( do { let { (tdata, tnewtype, ttype) = fstOf3 $ unLoc happy_var_1} + ; let { tdcolon = fst $ unLoc happy_var_4 } + ; let { (twhere, oc, cc) = fst $ unLoc happy_var_5 } + ; mkTyData (comb5 happy_var_1 happy_var_3 happy_var_4 happy_var_5 happy_var_6) (sndOf3 $ unLoc happy_var_1) (thdOf3 $ unLoc happy_var_1) happy_var_2 happy_var_3 + (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) + (fmap reverse happy_var_6) + (AnnDataDefn [] [] ttype tnewtype tdata NoEpTok tdcolon twhere oc cc NoEpTok)})}}}}}}) + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_176 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_176 = happyMonadReduce 4# 69# happyReduction_176 +happyReduction_176 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + case happyOut108 happy_x_4 of { (HappyWrap108 happy_var_4) -> + ( do { let { tdcolon = fst $ unLoc happy_var_4 } + ; mkFamDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) DataFamily TopLevel happy_var_3 + (snd $ unLoc happy_var_4) Nothing + (AnnFamilyDecl [] [] noAnn (epTok happy_var_1) (epTok happy_var_2) tdcolon noAnn noAnn noAnn noAnn noAnn noAnn) })}}}}) + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_177 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_177 = happyMonadReduce 4# 70# happyReduction_177 +happyReduction_177 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut87 happy_x_2 of { (HappyWrap87 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut162 happy_x_4 of { (HappyWrap162 happy_var_4) -> + ( mkStandaloneKindSig (comb2 happy_var_1 happy_var_4) (L (gl happy_var_2) $ unLoc happy_var_2) happy_var_4 + (epTok happy_var_1,epUniTok happy_var_3))}}}}) + ) (\r -> happyReturn (happyIn86 r)) + +happyReduce_178 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_178 = happyMonadReduce 3# 71# happyReduction_178 +happyReduction_178 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut87 happy_x_1 of { (HappyWrap87 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut298 happy_x_3 of { (HappyWrap298 happy_var_3) -> + ( case unLoc happy_var_1 of + (h:t) -> do + h' <- addTrailingCommaN h (gl happy_var_2) + return (sLL happy_var_1 happy_var_3 (happy_var_3 : h' : t)))}}}) + ) (\r -> happyReturn (happyIn87 r)) + +happyReduce_179 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_179 = happySpecReduce_1 71# happyReduction_179 +happyReduction_179 happy_x_1 + = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> + happyIn87 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_180 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_180 = happyMonadReduce 5# 72# happyReduction_180 +happyReduction_180 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut146 happy_x_2 of { (HappyWrap146 happy_var_2) -> + case happyOut89 happy_x_3 of { (HappyWrap89 happy_var_3) -> + case happyOut181 happy_x_4 of { (HappyWrap181 happy_var_4) -> + case happyOut133 happy_x_5 of { (HappyWrap133 happy_var_5) -> + ( do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc happy_var_5) + ; let (twhere, (openc, closec, semis)) = fst $ unLoc happy_var_5 + ; let anns = AnnClsInstDecl (epTok happy_var_1) twhere openc semis closec + ; let cid = ClsInstDecl + { cid_ext = (happy_var_2, anns, NoAnnSortKey) + , cid_poly_ty = happy_var_4, cid_binds = binds + , cid_sigs = mkClassOpSigs sigs + , cid_tyfam_insts = ats + , cid_overlap_mode = happy_var_3 + , cid_datafam_insts = adts } + ; amsA' (L (comb3 happy_var_1 happy_var_4 happy_var_5) + (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) + })}}}}}) + ) (\r -> happyReturn (happyIn88 r)) + +happyReduce_181 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_181 = happyMonadReduce 3# 72# happyReduction_181 +happyReduction_181 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut100 happy_x_3 of { (HappyWrap100 happy_var_3) -> + ( mkTyFamInst (comb2 happy_var_1 happy_var_3) (unLoc happy_var_3) + (epTok happy_var_1) (epTok happy_var_2))}}}) + ) (\r -> happyReturn (happyIn88 r)) + +happyReduce_182 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_182 = happyMonadReduce 6# 72# happyReduction_182 +happyReduction_182 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut106 happy_x_1 of { (HappyWrap106 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut113 happy_x_3 of { (HappyWrap113 happy_var_3) -> + case happyOut112 happy_x_4 of { (HappyWrap112 happy_var_4) -> + case happyOut198 happy_x_5 of { (HappyWrap198 happy_var_5) -> + case happyOut207 happy_x_6 of { (HappyWrap207 happy_var_6) -> + ( do { let { (tdata, tnewtype) = fst $ unLoc happy_var_1 } + ; let { tequal = fst $ unLoc happy_var_5 } + ; mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4) + Nothing (reverse (snd $ unLoc happy_var_5)) + (fmap reverse happy_var_6) + (AnnDataDefn [] [] NoEpTok tnewtype tdata (epTok happy_var_2) NoEpUniTok NoEpTok NoEpTok NoEpTok tequal)})}}}}}}) + ) (\r -> happyReturn (happyIn88 r)) + +happyReduce_183 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_183 = happyMonadReduce 7# 72# happyReduction_183 +happyReduction_183 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut106 happy_x_1 of { (HappyWrap106 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut113 happy_x_3 of { (HappyWrap113 happy_var_3) -> + case happyOut112 happy_x_4 of { (HappyWrap112 happy_var_4) -> + case happyOut107 happy_x_5 of { (HappyWrap107 happy_var_5) -> + case happyOut195 happy_x_6 of { (HappyWrap195 happy_var_6) -> + case happyOut207 happy_x_7 of { (HappyWrap207 happy_var_7) -> + ( do { let { (tdata, tnewtype) = fst $ unLoc happy_var_1 } + ; let { dcolon = fst $ unLoc happy_var_5 } + ; let { (twhere, oc, cc) = fst $ unLoc happy_var_6 } + ; mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4) + (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) + (fmap reverse happy_var_7) + (AnnDataDefn [] [] NoEpTok tnewtype tdata (epTok happy_var_2) dcolon twhere oc cc NoEpTok)})}}}}}}}) + ) (\r -> happyReturn (happyIn88 r)) + +happyReduce_184 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_184 = happyMonadReduce 2# 73# happyReduction_184 +happyReduction_184 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_2 (Overlappable (getOVERLAPPABLE_PRAGs happy_var_1))) + (AnnPragma (glR happy_var_1) (epTok happy_var_2) noAnn noAnn noAnn noAnn noAnn))}}) + ) (\r -> happyReturn (happyIn89 r)) + +happyReduce_185 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_185 = happyMonadReduce 2# 73# happyReduction_185 +happyReduction_185 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_2 (Overlapping (getOVERLAPPING_PRAGs happy_var_1))) + (AnnPragma (glR happy_var_1) (epTok happy_var_2) noAnn noAnn noAnn noAnn noAnn))}}) + ) (\r -> happyReturn (happyIn89 r)) + +happyReduce_186 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_186 = happyMonadReduce 2# 73# happyReduction_186 +happyReduction_186 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_2 (Overlaps (getOVERLAPS_PRAGs happy_var_1))) + (AnnPragma (glR happy_var_1) (epTok happy_var_2) noAnn noAnn noAnn noAnn noAnn))}}) + ) (\r -> happyReturn (happyIn89 r)) + +happyReduce_187 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_187 = happyMonadReduce 2# 73# happyReduction_187 +happyReduction_187 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_2 (Incoherent (getINCOHERENT_PRAGs happy_var_1))) + (AnnPragma (glR happy_var_1) (epTok happy_var_2) noAnn noAnn noAnn noAnn noAnn))}}) + ) (\r -> happyReturn (happyIn89 r)) + +happyReduce_188 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_188 = happySpecReduce_0 73# happyReduction_188 +happyReduction_188 = happyIn89 + (Nothing + ) + +happyReduce_189 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_189 = happyMonadReduce 1# 74# happyReduction_189 +happyReduction_189 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( amsA' (sL1 happy_var_1 (StockStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn90 r)) + +happyReduce_190 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_190 = happyMonadReduce 1# 74# happyReduction_190 +happyReduction_190 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( amsA' (sL1 happy_var_1 (AnyclassStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn90 r)) + +happyReduce_191 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_191 = happyMonadReduce 1# 74# happyReduction_191 +happyReduction_191 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( amsA' (sL1 happy_var_1 (NewtypeStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn90 r)) + +happyReduce_192 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_192 = happyMonadReduce 2# 75# happyReduction_192 +happyReduction_192 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut162 happy_x_2 of { (HappyWrap162 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 (ViaStrategy (XViaStrategyPs (epTok happy_var_1) happy_var_2))))}}) + ) (\r -> happyReturn (happyIn91 r)) + +happyReduce_193 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_193 = happyMonadReduce 1# 76# happyReduction_193 +happyReduction_193 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( fmap Just $ amsA' (sL1 happy_var_1 (StockStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn92 r)) + +happyReduce_194 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_194 = happyMonadReduce 1# 76# happyReduction_194 +happyReduction_194 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( fmap Just $ amsA' (sL1 happy_var_1 (AnyclassStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn92 r)) + +happyReduce_195 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_195 = happyMonadReduce 1# 76# happyReduction_195 +happyReduction_195 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( fmap Just $ amsA' (sL1 happy_var_1 (NewtypeStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn92 r)) + +happyReduce_196 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_196 = happySpecReduce_1 76# happyReduction_196 +happyReduction_196 happy_x_1 + = case happyOut91 happy_x_1 of { (HappyWrap91 happy_var_1) -> + happyIn92 + (Just happy_var_1 + )} + +happyReduce_197 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_197 = happySpecReduce_0 76# happyReduction_197 +happyReduction_197 = happyIn92 + (Nothing + ) + +happyReduce_198 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_198 = happySpecReduce_0 77# happyReduction_198 +happyReduction_198 = happyIn93 + (Nothing + ) + +happyReduce_199 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_199 = happyMonadReduce 1# 77# happyReduction_199 +happyReduction_199 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> + ( fmap Just $ amsA' (reLoc happy_var_1))}) + ) (\r -> happyReturn (happyIn93 r)) + +happyReduce_200 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_200 = happySpecReduce_0 78# happyReduction_200 +happyReduction_200 = happyIn94 + (noLoc (noAnn, Nothing) + ) + +happyReduce_201 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_201 = happySpecReduce_2 78# happyReduction_201 +happyReduction_201 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { (HappyWrap95 happy_var_2) -> + happyIn94 + (sLL happy_var_1 happy_var_2 ((epTok happy_var_1) + , Just (happy_var_2)) + )}} + +happyReduce_202 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_202 = happyMonadReduce 3# 79# happyReduction_202 +happyReduction_202 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut96 happy_x_3 of { (HappyWrap96 happy_var_3) -> + ( amsA' (sLL happy_var_1 happy_var_3 (InjectivityAnn (epUniTok happy_var_2) happy_var_1 (reverse (unLoc happy_var_3)))))}}}) + ) (\r -> happyReturn (happyIn95 r)) + +happyReduce_203 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_203 = happySpecReduce_2 80# happyReduction_203 +happyReduction_203 happy_x_2 + happy_x_1 + = case happyOut96 happy_x_1 of { (HappyWrap96 happy_var_1) -> + case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> + happyIn96 + (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) + )}} + +happyReduce_204 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_204 = happySpecReduce_1 80# happyReduction_204 +happyReduction_204 happy_x_1 + = case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> + happyIn96 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_205 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_205 = happySpecReduce_0 81# happyReduction_205 +happyReduction_205 = happyIn97 + (noLoc (noAnn,OpenTypeFamily) + ) + +happyReduce_206 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_206 = happySpecReduce_2 81# happyReduction_206 +happyReduction_206 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut98 happy_x_2 of { (HappyWrap98 happy_var_2) -> + happyIn97 + (sLL happy_var_1 happy_var_2 ((epTok happy_var_1,(fst $ unLoc happy_var_2)) + ,ClosedTypeFamily (fmap reverse $ snd $ unLoc happy_var_2)) + )}} + +happyReduce_207 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_207 = happySpecReduce_3 82# happyReduction_207 +happyReduction_207 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut99 happy_x_2 of { (HappyWrap99 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn98 + (sLL happy_var_1 happy_var_3 ((epTok happy_var_1,noAnn, epTok happy_var_3) + ,Just (unLoc happy_var_2)) + )}}} + +happyReduce_208 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_208 = happySpecReduce_3 82# happyReduction_208 +happyReduction_208 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut99 happy_x_2 of { (HappyWrap99 happy_var_2) -> + happyIn98 + (let (L loc _) = happy_var_2 in + L loc (noAnn,Just (unLoc happy_var_2)) + )} + +happyReduce_209 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_209 = happySpecReduce_3 82# happyReduction_209 +happyReduction_209 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn98 + (sLL happy_var_1 happy_var_3 ((epTok happy_var_1,epTok happy_var_2 ,epTok happy_var_3),Nothing) + )}}} + +happyReduce_210 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_210 = happySpecReduce_3 82# happyReduction_210 +happyReduction_210 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn98 + (let (L loc _) = happy_var_2 in + L loc ((noAnn,epTok happy_var_2, noAnn),Nothing) + )} + +happyReduce_211 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_211 = happyMonadReduce 3# 83# happyReduction_211 +happyReduction_211 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut100 happy_x_3 of { (HappyWrap100 happy_var_3) -> + ( let (L loc eqn) = happy_var_3 in + case unLoc happy_var_1 of + [] -> return (sLL happy_var_1 happy_var_3 (L loc eqn : unLoc happy_var_1)) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (happy_var_3 : h' : t)))}}}) + ) (\r -> happyReturn (happyIn99 r)) + +happyReduce_212 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_212 = happyMonadReduce 2# 83# happyReduction_212 +happyReduction_212 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( case unLoc happy_var_1 of + [] -> return (sLZ happy_var_1 happy_var_2 (unLoc happy_var_1)) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (h':t)))}}) + ) (\r -> happyReturn (happyIn99 r)) + +happyReduce_213 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_213 = happySpecReduce_1 83# happyReduction_213 +happyReduction_213 happy_x_1 + = case happyOut100 happy_x_1 of { (HappyWrap100 happy_var_1) -> + happyIn99 + (sLL happy_var_1 happy_var_1 [happy_var_1] + )} + +happyReduce_214 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_214 = happySpecReduce_0 83# happyReduction_214 +happyReduction_214 = happyIn99 + (noLoc [] + ) + +happyReduce_215 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_215 = happyMonadReduce 6# 84# happyReduction_215 +happyReduction_215 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut172 happy_x_4 of { (HappyWrap172 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut168 happy_x_6 of { (HappyWrap168 happy_var_6) -> + ( do { hintExplicitForall happy_var_1 + ; tvbs <- fromSpecTyVarBndrs happy_var_2 + ; let loc = comb2 happy_var_1 happy_var_6 + ; !cs <- getCommentsFor loc + ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glEE happy_var_1 happy_var_3) (epUniTok happy_var_1, epTok happy_var_3) cs) tvbs) happy_var_4 happy_var_6 (epTok happy_var_5) })}}}}}}) + ) (\r -> happyReturn (happyIn100 r)) + +happyReduce_216 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_216 = happyMonadReduce 3# 84# happyReduction_216 +happyReduction_216 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut172 happy_x_1 of { (HappyWrap172 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> + ( mkTyFamInstEqn (comb2 happy_var_1 happy_var_3) mkHsOuterImplicit happy_var_1 happy_var_3 (epTok happy_var_2))}}}) + ) (\r -> happyReturn (happyIn100 r)) + +happyReduce_217 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_217 = happyMonadReduce 4# 85# happyReduction_217 +happyReduction_217 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut102 happy_x_2 of { (HappyWrap102 happy_var_2) -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + case happyOut108 happy_x_4 of { (HappyWrap108 happy_var_4) -> + ( do { let { tdcolon = fst $ unLoc happy_var_4 } + ; liftM mkTyClD (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) DataFamily NotTopLevel happy_var_3 + (snd $ unLoc happy_var_4) Nothing + (AnnFamilyDecl [] [] noAnn (epTok happy_var_1) happy_var_2 tdcolon noAnn noAnn noAnn noAnn noAnn noAnn)) })}}}}) + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_218 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_218 = happyMonadReduce 3# 85# happyReduction_218 +happyReduction_218 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut172 happy_x_2 of { (HappyWrap172 happy_var_2) -> + case happyOut110 happy_x_3 of { (HappyWrap110 happy_var_3) -> + ( do { let { (tdcolon, tequal, tvbar) = fst $ unLoc happy_var_3 } + ; liftM mkTyClD + (mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_3) OpenTypeFamily NotTopLevel happy_var_2 + (fst . snd $ unLoc happy_var_3) + (snd . snd $ unLoc happy_var_3) + (AnnFamilyDecl [] [] (epTok happy_var_1) noAnn noAnn tdcolon tequal tvbar noAnn noAnn noAnn noAnn)) })}}}) + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_219 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_219 = happyMonadReduce 4# 85# happyReduction_219 +happyReduction_219 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + case happyOut110 happy_x_4 of { (HappyWrap110 happy_var_4) -> + ( do { let { (tdcolon, tequal, tvbar) = fst $ unLoc happy_var_4 } + ; liftM mkTyClD + (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) OpenTypeFamily NotTopLevel happy_var_3 + (fst . snd $ unLoc happy_var_4) + (snd . snd $ unLoc happy_var_4) + (AnnFamilyDecl [] [] (epTok happy_var_1) noAnn (epTok happy_var_2) tdcolon tequal tvbar noAnn noAnn noAnn noAnn)) })}}}}) + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_220 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_220 = happyMonadReduce 2# 85# happyReduction_220 +happyReduction_220 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut100 happy_x_2 of { (HappyWrap100 happy_var_2) -> + ( liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_2) (unLoc happy_var_2) + (epTok happy_var_1) NoEpTok))}}) + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_221 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_221 = happyMonadReduce 3# 85# happyReduction_221 +happyReduction_221 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut100 happy_x_3 of { (HappyWrap100 happy_var_3) -> + ( liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_3) (unLoc happy_var_3) + (epTok happy_var_1) (epTok happy_var_2) ))}}}) + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_222 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_222 = happySpecReduce_0 86# happyReduction_222 +happyReduction_222 = happyIn102 + (noAnn + ) + +happyReduce_223 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_223 = happySpecReduce_1 86# happyReduction_223 +happyReduction_223 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn102 + ((epTok happy_var_1) + )} + +happyReduce_224 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_224 = happySpecReduce_0 87# happyReduction_224 +happyReduction_224 = happyIn103 + (NoEpTok + ) + +happyReduce_225 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_225 = happySpecReduce_1 87# happyReduction_225 +happyReduction_225 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn103 + (epTok happy_var_1 + )} + +happyReduce_226 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_226 = happyMonadReduce 3# 88# happyReduction_226 +happyReduction_226 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut103 happy_x_2 of { (HappyWrap103 happy_var_2) -> + case happyOut100 happy_x_3 of { (HappyWrap100 happy_var_3) -> + ( mkTyFamInst (comb2 happy_var_1 happy_var_3) (unLoc happy_var_3) + (epTok happy_var_1) happy_var_2)}}}) + ) (\r -> happyReturn (happyIn104 r)) + +happyReduce_227 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_227 = happyMonadReduce 6# 88# happyReduction_227 +happyReduction_227 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut106 happy_x_1 of { (HappyWrap106 happy_var_1) -> + case happyOut103 happy_x_2 of { (HappyWrap103 happy_var_2) -> + case happyOut113 happy_x_3 of { (HappyWrap113 happy_var_3) -> + case happyOut112 happy_x_4 of { (HappyWrap112 happy_var_4) -> + case happyOut198 happy_x_5 of { (HappyWrap198 happy_var_5) -> + case happyOut207 happy_x_6 of { (HappyWrap207 happy_var_6) -> + ( do { let { (tdata, tnewtype) = fst $ unLoc happy_var_1 } + ; let { tequal = fst $ unLoc happy_var_5 } + ; mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4) + Nothing (reverse (snd $ unLoc happy_var_5)) + (fmap reverse happy_var_6) + (AnnDataDefn [] [] NoEpTok tnewtype tdata happy_var_2 NoEpUniTok NoEpTok NoEpTok NoEpTok tequal)})}}}}}}) + ) (\r -> happyReturn (happyIn104 r)) + +happyReduce_228 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_228 = happyMonadReduce 7# 88# happyReduction_228 +happyReduction_228 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut106 happy_x_1 of { (HappyWrap106 happy_var_1) -> + case happyOut103 happy_x_2 of { (HappyWrap103 happy_var_2) -> + case happyOut113 happy_x_3 of { (HappyWrap113 happy_var_3) -> + case happyOut112 happy_x_4 of { (HappyWrap112 happy_var_4) -> + case happyOut107 happy_x_5 of { (HappyWrap107 happy_var_5) -> + case happyOut195 happy_x_6 of { (HappyWrap195 happy_var_6) -> + case happyOut207 happy_x_7 of { (HappyWrap207 happy_var_7) -> + ( do { let { (tdata, tnewtype) = fst $ unLoc happy_var_1 } + ; let { dcolon = fst $ unLoc happy_var_5 } + ; let { (twhere, oc, cc) = fst $ unLoc happy_var_6 } + ; mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 + (unLoc happy_var_4) (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) + (fmap reverse happy_var_7) + (AnnDataDefn [] [] NoEpTok tnewtype tdata happy_var_2 dcolon twhere oc cc NoEpTok)})}}}}}}}) + ) (\r -> happyReturn (happyIn104 r)) + +happyReduce_229 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_229 = happySpecReduce_1 89# happyReduction_229 +happyReduction_229 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn105 + (sL1 happy_var_1 ((epTok happy_var_1, NoEpTok, NoEpTok), False,DataType) + )} + +happyReduce_230 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_230 = happySpecReduce_1 89# happyReduction_230 +happyReduction_230 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn105 + (sL1 happy_var_1 ((NoEpTok, epTok happy_var_1, NoEpTok), False,NewType) + )} + +happyReduce_231 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_231 = happySpecReduce_2 89# happyReduction_231 +happyReduction_231 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn105 + (sL1 happy_var_1 ((epTok happy_var_2, NoEpTok, epTok happy_var_1), True ,DataType) + )}} + +happyReduce_232 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_232 = happySpecReduce_1 90# happyReduction_232 +happyReduction_232 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn106 + (sL1 happy_var_1 ((epTok happy_var_1, NoEpTok), DataType) + )} + +happyReduce_233 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_233 = happySpecReduce_1 90# happyReduction_233 +happyReduction_233 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn106 + (sL1 happy_var_1 ((NoEpTok, epTok happy_var_1),NewType) + )} + +happyReduce_234 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_234 = happySpecReduce_0 91# happyReduction_234 +happyReduction_234 = happyIn107 + (noLoc (NoEpUniTok , Nothing) + ) + +happyReduce_235 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_235 = happySpecReduce_2 91# happyReduction_235 +happyReduction_235 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut194 happy_x_2 of { (HappyWrap194 happy_var_2) -> + happyIn107 + (sLL happy_var_1 happy_var_2 (epUniTok happy_var_1, Just happy_var_2) + )}} + +happyReduce_236 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_236 = happySpecReduce_0 92# happyReduction_236 +happyReduction_236 = happyIn108 + (noLoc (noAnn, noLocA (NoSig noExtField) ) + ) + +happyReduce_237 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_237 = happySpecReduce_2 92# happyReduction_237 +happyReduction_237 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut194 happy_x_2 of { (HappyWrap194 happy_var_2) -> + happyIn108 + (sLL happy_var_1 happy_var_2 (epUniTok happy_var_1, sLLa happy_var_1 happy_var_2 (KindSig noExtField happy_var_2)) + )}} + +happyReduce_238 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_238 = happySpecReduce_0 93# happyReduction_238 +happyReduction_238 = happyIn109 + (noLoc (noAnn , noLocA (NoSig noExtField) ) + ) + +happyReduce_239 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_239 = happySpecReduce_2 93# happyReduction_239 +happyReduction_239 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut194 happy_x_2 of { (HappyWrap194 happy_var_2) -> + happyIn109 + (sLL happy_var_1 happy_var_2 ((epUniTok happy_var_1, noAnn), sLLa happy_var_1 happy_var_2 (KindSig noExtField happy_var_2)) + )}} + +happyReduce_240 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_240 = happyMonadReduce 2# 93# happyReduction_240 +happyReduction_240 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut187 happy_x_2 of { (HappyWrap187 happy_var_2) -> + ( do { tvb <- fromSpecTyVarBndr happy_var_2 + ; return $ sLL happy_var_1 happy_var_2 ((noAnn, epTok happy_var_1), sLLa happy_var_1 happy_var_2 (TyVarSig noExtField tvb))})}}) + ) (\r -> happyReturn (happyIn109 r)) + +happyReduce_241 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_241 = happySpecReduce_0 94# happyReduction_241 +happyReduction_241 = happyIn110 + (noLoc (noAnn, (noLocA (NoSig noExtField), Nothing)) + ) + +happyReduce_242 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_242 = happySpecReduce_2 94# happyReduction_242 +happyReduction_242 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut194 happy_x_2 of { (HappyWrap194 happy_var_2) -> + happyIn110 + (sLL happy_var_1 happy_var_2 ( (epUniTok happy_var_1, noAnn, noAnn) + , (sL1a happy_var_2 (KindSig noExtField happy_var_2), Nothing)) + )}} + +happyReduce_243 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_243 = happyMonadReduce 4# 94# happyReduction_243 +happyReduction_243 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut188 happy_x_2 of { (HappyWrap188 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut95 happy_x_4 of { (HappyWrap95 happy_var_4) -> + ( do { tvb <- fromSpecTyVarBndr happy_var_2 + ; return $ sLL happy_var_1 happy_var_4 ((noAnn, epTok happy_var_1, epTok happy_var_3) + , (sLLa happy_var_1 happy_var_2 (TyVarSig noExtField tvb), Just happy_var_4))})}}}}) + ) (\r -> happyReturn (happyIn110 r)) + +happyReduce_244 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_244 = happyMonadReduce 3# 95# happyReduction_244 +happyReduction_244 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut170 happy_x_1 of { (HappyWrap170 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + ( acs (comb2 happy_var_1 happy_var_3) (\loc cs -> (L loc (Just (addTrailingDarrowC happy_var_1 happy_var_2 cs), happy_var_3))))}}}) + ) (\r -> happyReturn (happyIn111 r)) + +happyReduce_245 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_245 = happySpecReduce_1 95# happyReduction_245 +happyReduction_245 happy_x_1 + = case happyOut172 happy_x_1 of { (HappyWrap172 happy_var_1) -> + happyIn111 + (sL1 happy_var_1 (Nothing, happy_var_1) + )} + +happyReduce_246 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_246 = happyMonadReduce 6# 96# happyReduction_246 +happyReduction_246 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut170 happy_x_4 of { (HappyWrap170 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut172 happy_x_6 of { (HappyWrap172 happy_var_6) -> + ( hintExplicitForall happy_var_1 + >> fromSpecTyVarBndrs happy_var_2 + >>= \tvbs -> + (acs (comb2 happy_var_1 happy_var_6) (\loc cs -> (L loc + (Just ( addTrailingDarrowC happy_var_4 happy_var_5 cs) + , mkHsOuterExplicit (EpAnn (glEE happy_var_1 happy_var_3) (epUniTok happy_var_1, epTok happy_var_3) emptyComments) tvbs, happy_var_6)))))}}}}}}) + ) (\r -> happyReturn (happyIn112 r)) + +happyReduce_247 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_247 = happyMonadReduce 4# 96# happyReduction_247 +happyReduction_247 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut172 happy_x_4 of { (HappyWrap172 happy_var_4) -> + ( do { hintExplicitForall happy_var_1 + ; tvbs <- fromSpecTyVarBndrs happy_var_2 + ; let loc = comb2 happy_var_1 happy_var_4 + ; !cs <- getCommentsFor loc + ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glEE happy_var_1 happy_var_3) (epUniTok happy_var_1, epTok happy_var_3) cs) tvbs, happy_var_4)) + })}}}}) + ) (\r -> happyReturn (happyIn112 r)) + +happyReduce_248 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_248 = happyMonadReduce 3# 96# happyReduction_248 +happyReduction_248 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut170 happy_x_1 of { (HappyWrap170 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + ( acs (comb2 happy_var_1 happy_var_3) (\loc cs -> (L loc (Just (addTrailingDarrowC happy_var_1 happy_var_2 cs), mkHsOuterImplicit, happy_var_3))))}}}) + ) (\r -> happyReturn (happyIn112 r)) + +happyReduce_249 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_249 = happySpecReduce_1 96# happyReduction_249 +happyReduction_249 happy_x_1 + = case happyOut172 happy_x_1 of { (HappyWrap172 happy_var_1) -> + happyIn112 + (sL1 happy_var_1 (Nothing, mkHsOuterImplicit, happy_var_1) + )} + +happyReduce_250 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_250 = happyMonadReduce 4# 97# happyReduction_250 +happyReduction_250 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_4 (CType (getCTYPEs happy_var_1) (Just (Header (getSTRINGs happy_var_2) (getSTRING happy_var_2))) + (getSTRINGs happy_var_3,getSTRING happy_var_3))) + (AnnPragma (glR happy_var_1) (epTok happy_var_4) noAnn (glR happy_var_2) (glR happy_var_3) noAnn noAnn))}}}}) + ) (\r -> happyReturn (happyIn113 r)) + +happyReduce_251 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_251 = happyMonadReduce 3# 97# happyReduction_251 +happyReduction_251 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_3 (CType (getCTYPEs happy_var_1) Nothing (getSTRINGs happy_var_2, getSTRING happy_var_2))) + (AnnPragma (glR happy_var_1) (epTok happy_var_3) noAnn noAnn (glR happy_var_2) noAnn noAnn))}}}) + ) (\r -> happyReturn (happyIn113 r)) + +happyReduce_252 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_252 = happySpecReduce_0 97# happyReduction_252 +happyReduction_252 = happyIn113 + (Nothing + ) + +happyReduce_253 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_253 = happyMonadReduce 6# 98# happyReduction_253 +happyReduction_253 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut92 happy_x_2 of { (HappyWrap92 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut146 happy_x_4 of { (HappyWrap146 happy_var_4) -> + case happyOut89 happy_x_5 of { (HappyWrap89 happy_var_5) -> + case happyOut181 happy_x_6 of { (HappyWrap181 happy_var_6) -> + ( do { let { err = text "in the stand-alone deriving instance" + <> colon <+> quotes (ppr happy_var_6) } + ; amsA' (sLL happy_var_1 happy_var_6 + (DerivDecl (happy_var_4, (epTok happy_var_1, epTok happy_var_3)) (mkHsWildCardBndrs happy_var_6) happy_var_2 happy_var_5)) })}}}}}}) + ) (\r -> happyReturn (happyIn114 r)) + +happyReduce_254 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_254 = happyMonadReduce 4# 99# happyReduction_254 +happyReduction_254 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut298 happy_x_3 of { (HappyWrap298 happy_var_3) -> + case happyOut116 happy_x_4 of { (HappyWrap116 happy_var_4) -> + ( mkRoleAnnotDecl (comb3 happy_var_1 happy_var_4 happy_var_3) happy_var_3 (reverse (unLoc happy_var_4)) + (epTok happy_var_1,epTok happy_var_2))}}}}) + ) (\r -> happyReturn (happyIn115 r)) + +happyReduce_255 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_255 = happySpecReduce_0 100# happyReduction_255 +happyReduction_255 = happyIn116 + (noLoc [] + ) + +happyReduce_256 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_256 = happySpecReduce_1 100# happyReduction_256 +happyReduction_256 happy_x_1 + = case happyOut117 happy_x_1 of { (HappyWrap117 happy_var_1) -> + happyIn116 + (happy_var_1 + )} + +happyReduce_257 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_257 = happySpecReduce_1 101# happyReduction_257 +happyReduction_257 happy_x_1 + = case happyOut118 happy_x_1 of { (HappyWrap118 happy_var_1) -> + happyIn117 + (sLL happy_var_1 happy_var_1 [happy_var_1] + )} + +happyReduce_258 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_258 = happySpecReduce_2 101# happyReduction_258 +happyReduction_258 happy_x_2 + happy_x_1 + = case happyOut117 happy_x_1 of { (HappyWrap117 happy_var_1) -> + case happyOut118 happy_x_2 of { (HappyWrap118 happy_var_2) -> + happyIn117 + (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 + )}} + +happyReduce_259 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_259 = happySpecReduce_1 102# happyReduction_259 +happyReduction_259 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn118 + (sL1 happy_var_1 $ Just $ getVARID happy_var_1 + )} + +happyReduce_260 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_260 = happySpecReduce_1 102# happyReduction_260 +happyReduction_260 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn118 + (sL1 happy_var_1 Nothing + )} + +happyReduce_261 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_261 = happyMonadReduce 4# 103# happyReduction_261 +happyReduction_261 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut120 happy_x_2 of { (HappyWrap120 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut258 happy_x_4 of { (HappyWrap258 happy_var_4) -> + ( let (name, args, (mo, mc) ) = happy_var_2 in + amsA' (sLL happy_var_1 happy_var_4 . ValD noExtField $ mkPatSynBind name args happy_var_4 + ImplicitBidirectional + (AnnPSB (epTok happy_var_1) mo mc Nothing (Just (epTok happy_var_3)))))}}}}) + ) (\r -> happyReturn (happyIn119 r)) + +happyReduce_262 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_262 = happyMonadReduce 4# 103# happyReduction_262 +happyReduction_262 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut120 happy_x_2 of { (HappyWrap120 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut258 happy_x_4 of { (HappyWrap258 happy_var_4) -> + ( let (name, args, (mo,mc)) = happy_var_2 in + amsA' (sLL happy_var_1 happy_var_4 . ValD noExtField $ mkPatSynBind name args happy_var_4 Unidirectional + (AnnPSB (epTok happy_var_1) mo mc (Just (epUniTok happy_var_3)) Nothing)))}}}}) + ) (\r -> happyReturn (happyIn119 r)) + +happyReduce_263 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_263 = happyMonadReduce 5# 103# happyReduction_263 +happyReduction_263 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut120 happy_x_2 of { (HappyWrap120 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut258 happy_x_4 of { (HappyWrap258 happy_var_4) -> + case happyOut123 happy_x_5 of { (HappyWrap123 happy_var_5) -> + ( do { let (name, args, (mo,mc)) = happy_var_2 + ; mg <- mkPatSynMatchGroup name happy_var_5 + ; amsA' (sLL happy_var_1 happy_var_5 . ValD noExtField $ + mkPatSynBind name args happy_var_4 (ExplicitBidirectional mg) + (AnnPSB (epTok happy_var_1) mo mc (Just (epUniTok happy_var_3)) Nothing)) + })}}}}}) + ) (\r -> happyReturn (happyIn119 r)) + +happyReduce_264 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_264 = happySpecReduce_2 104# happyReduction_264 +happyReduction_264 happy_x_2 + happy_x_1 + = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> + case happyOut121 happy_x_2 of { (HappyWrap121 happy_var_2) -> + happyIn120 + ((happy_var_1, PrefixCon happy_var_2, noAnn) + )}} + +happyReduce_265 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_265 = happySpecReduce_3 104# happyReduction_265 +happyReduction_265 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> + case happyOut320 happy_x_3 of { (HappyWrap320 happy_var_3) -> + happyIn120 + ((happy_var_2, InfixCon happy_var_1 happy_var_3, noAnn) + )}}} + +happyReduce_266 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_266 = happyReduce 4# 104# happyReduction_266 +happyReduction_266 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut122 happy_x_3 of { (HappyWrap122 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn120 + ((happy_var_1, RecCon happy_var_3, (Just (epTok happy_var_2), Just (epTok happy_var_4))) + ) `HappyStk` happyRest}}}} + +happyReduce_267 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_267 = happySpecReduce_0 105# happyReduction_267 +happyReduction_267 = happyIn121 + ([] + ) + +happyReduce_268 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_268 = happySpecReduce_2 105# happyReduction_268 +happyReduction_268 happy_x_2 + happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + case happyOut121 happy_x_2 of { (HappyWrap121 happy_var_2) -> + happyIn121 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_269 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_269 = happySpecReduce_1 106# happyReduction_269 +happyReduction_269 happy_x_1 + = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + happyIn122 + ([RecordPatSynField (mkFieldOcc happy_var_1) happy_var_1] + )} + +happyReduce_270 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_270 = happyMonadReduce 3# 106# happyReduction_270 +happyReduction_270 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut122 happy_x_3 of { (HappyWrap122 happy_var_3) -> + ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) + ; return ((RecordPatSynField (mkFieldOcc h) h) : happy_var_3 )})}}}) + ) (\r -> happyReturn (happyIn122 r)) + +happyReduce_271 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_271 = happyMonadReduce 4# 107# happyReduction_271 +happyReduction_271 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut134 happy_x_3 of { (HappyWrap134 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( amsr (sLL happy_var_1 happy_var_4 (thdOf3 $ unLoc happy_var_3)) + (AnnList (Just (fstOf3 $ unLoc happy_var_3)) (ListBraces (epTok happy_var_2) (epTok happy_var_4)) (sndOf3 $ unLoc happy_var_3) (epTok happy_var_1) []))}}}}) + ) (\r -> happyReturn (happyIn123 r)) + +happyReduce_272 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_272 = happyMonadReduce 4# 107# happyReduction_272 +happyReduction_272 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut134 happy_x_3 of { (HappyWrap134 happy_var_3) -> + ( amsr (sLL happy_var_1 happy_var_3 (thdOf3 $ unLoc happy_var_3)) + (AnnList (Just (fstOf3 $ unLoc happy_var_3)) ListNone (sndOf3 $ unLoc happy_var_3) (epTok happy_var_1) []))}}) + ) (\r -> happyReturn (happyIn123 r)) + +happyReduce_273 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_273 = happyMonadReduce 4# 108# happyReduction_273 +happyReduction_273 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut289 happy_x_2 of { (HappyWrap289 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut163 happy_x_4 of { (HappyWrap163 happy_var_4) -> + ( amsA' (sLL happy_var_1 happy_var_4 + $ PatSynSig (AnnSig (epUniTok happy_var_3) (Just (epTok happy_var_1)) Nothing) + (toList $ unLoc happy_var_2) happy_var_4))}}}}) + ) (\r -> happyReturn (happyIn124 r)) + +happyReduce_274 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_274 = happySpecReduce_1 109# happyReduction_274 +happyReduction_274 happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + happyIn125 + (happy_var_1 + )} + +happyReduce_275 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_275 = happySpecReduce_1 109# happyReduction_275 +happyReduction_275 happy_x_1 + = case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> + happyIn125 + (happy_var_1 + )} + +happyReduce_276 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_276 = happySpecReduce_1 110# happyReduction_276 +happyReduction_276 happy_x_1 + = case happyOut101 happy_x_1 of { (HappyWrap101 happy_var_1) -> + happyIn126 + (happy_var_1 + )} + +happyReduce_277 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_277 = happySpecReduce_1 110# happyReduction_277 +happyReduction_277 happy_x_1 + = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> + happyIn126 + (happy_var_1 + )} + +happyReduce_278 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_278 = happyMonadReduce 4# 110# happyReduction_278 +happyReduction_278 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut163 happy_x_4 of { (HappyWrap163 happy_var_4) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + do { v <- checkValSigLhs happy_var_2 + ; let err = text "in default signature" <> colon <+> + quotes (ppr happy_var_2) + ; amsA' (sLL happy_var_1 happy_var_4 $ SigD noExtField $ ClassOpSig (AnnSig (epUniTok happy_var_3) Nothing (Just (epTok happy_var_1))) True [v] happy_var_4) })}}}}) + ) (\r -> happyReturn (happyIn126 r)) + +happyReduce_279 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_279 = happyMonadReduce 3# 111# happyReduction_279 +happyReduction_279 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut127 happy_x_1 of { (HappyWrap127 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut126 happy_x_3 of { (HappyWrap126 happy_var_3) -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + , unitOL happy_var_3)) + else case (snd $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 + , snocOL hs t' `appOL` unitOL happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn127 r)) + +happyReduce_280 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_280 = happyMonadReduce 2# 111# happyReduction_280 +happyReduction_280 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut127 happy_x_1 of { (HappyWrap127 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLZ happy_var_1 happy_var_2 ( (fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,snd $ unLoc happy_var_1)) + else case (snd $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (fst $ unLoc happy_var_1 + , snocOL hs t')))}}) + ) (\r -> happyReturn (happyIn127 r)) + +happyReduce_281 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_281 = happySpecReduce_1 111# happyReduction_281 +happyReduction_281 happy_x_1 + = case happyOut126 happy_x_1 of { (HappyWrap126 happy_var_1) -> + happyIn127 + (sL1 happy_var_1 ([], unitOL happy_var_1) + )} + +happyReduce_282 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_282 = happySpecReduce_0 111# happyReduction_282 +happyReduction_282 = happyIn127 + (noLoc ([],nilOL) + ) + +happyReduce_283 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_283 = happySpecReduce_3 112# happyReduction_283 +happyReduction_283 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut127 happy_x_2 of { (HappyWrap127 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn128 + (sLL happy_var_1 happy_var_3 ((epTok happy_var_1, fst $ unLoc happy_var_2, epTok happy_var_3) + ,snd $ unLoc happy_var_2, epExplicitBraces happy_var_1 happy_var_3) + )}}} + +happyReduce_284 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_284 = happySpecReduce_3 112# happyReduction_284 +happyReduction_284 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut127 happy_x_2 of { (HappyWrap127 happy_var_2) -> + happyIn128 + (let { L l (anns, decls) = happy_var_2 } + in L l ((NoEpTok, anns, NoEpTok), decls, EpVirtualBraces (getVOCURLY happy_var_1)) + )}} + +happyReduce_285 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_285 = happySpecReduce_2 113# happyReduction_285 +happyReduction_285 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_2 of { (HappyWrap128 happy_var_2) -> + happyIn129 + (sLL happy_var_1 happy_var_2 ((epTok happy_var_1,fstOf3 $ unLoc happy_var_2) + ,sndOf3 $ unLoc happy_var_2,thdOf3 $ unLoc happy_var_2) + )}} + +happyReduce_286 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_286 = happySpecReduce_0 113# happyReduction_286 +happyReduction_286 = happyIn129 + (noLoc ((noAnn, noAnn),nilOL,EpNoLayout) + ) + +happyReduce_287 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_287 = happySpecReduce_1 114# happyReduction_287 +happyReduction_287 happy_x_1 + = case happyOut104 happy_x_1 of { (HappyWrap104 happy_var_1) -> + happyIn130 + (sL1 happy_var_1 (unitOL (sL1a happy_var_1 (InstD noExtField (unLoc happy_var_1)))) + )} + +happyReduce_288 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_288 = happySpecReduce_1 114# happyReduction_288 +happyReduction_288 happy_x_1 + = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> + happyIn130 + (sL1 happy_var_1 (unitOL happy_var_1) + )} + +happyReduce_289 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_289 = happyMonadReduce 3# 115# happyReduction_289 +happyReduction_289 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut131 happy_x_1 of { (HappyWrap131 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut130 happy_x_3 of { (HappyWrap130 happy_var_3) -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + , unLoc happy_var_3)) + else case (snd $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 + , snocOL hs t' `appOL` unLoc happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn131 r)) + +happyReduce_290 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_290 = happyMonadReduce 2# 115# happyReduction_290 +happyReduction_290 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut131 happy_x_1 of { (HappyWrap131 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLZ happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,snd $ unLoc happy_var_1)) + else case (snd $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (fst $ unLoc happy_var_1 + , snocOL hs t')))}}) + ) (\r -> happyReturn (happyIn131 r)) + +happyReduce_291 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_291 = happySpecReduce_1 115# happyReduction_291 +happyReduction_291 happy_x_1 + = case happyOut130 happy_x_1 of { (HappyWrap130 happy_var_1) -> + happyIn131 + (sL1 happy_var_1 ([],unLoc happy_var_1) + )} + +happyReduce_292 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_292 = happySpecReduce_0 115# happyReduction_292 +happyReduction_292 = happyIn131 + (noLoc ([],nilOL) + ) + +happyReduce_293 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_293 = happySpecReduce_3 116# happyReduction_293 +happyReduction_293 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut131 happy_x_2 of { (HappyWrap131 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn132 + (sLL happy_var_1 happy_var_3 ((epTok happy_var_1,epTok happy_var_3,fst $ unLoc happy_var_2),snd $ unLoc happy_var_2) + )}}} + +happyReduce_294 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_294 = happySpecReduce_3 116# happyReduction_294 +happyReduction_294 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut131 happy_x_2 of { (HappyWrap131 happy_var_2) -> + happyIn132 + (L (gl happy_var_2) ((noAnn,noAnn,fst $ unLoc happy_var_2),snd $ unLoc happy_var_2) + )} + +happyReduce_295 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_295 = happySpecReduce_2 117# happyReduction_295 +happyReduction_295 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut132 happy_x_2 of { (HappyWrap132 happy_var_2) -> + happyIn133 + (sLL happy_var_1 happy_var_2 ((epTok happy_var_1,(fst $ unLoc happy_var_2)) + ,snd $ unLoc happy_var_2) + )}} + +happyReduce_296 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_296 = happySpecReduce_0 117# happyReduction_296 +happyReduction_296 = happyIn133 + (noLoc (noAnn,nilOL) + ) + +happyReduce_297 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_297 = happyMonadReduce 3# 118# happyReduction_297 +happyReduction_297 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut134 happy_x_1 of { (HappyWrap134 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> + ( if isNilOL (thdOf3 $ unLoc happy_var_1) + then return (sLL happy_var_2 happy_var_3 (glR happy_var_3, (sndOf3 $ unLoc happy_var_1) ++ (msemiA happy_var_2) + , unitOL happy_var_3)) + else case (thdOf3 $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + let { this = unitOL happy_var_3; + rest = snocOL hs t'; + these = rest `appOL` this } + return (rest `seq` this `seq` these `seq` + (sLL happy_var_1 happy_var_3 (glEE (fstOf3 $ unLoc happy_var_1) happy_var_3, sndOf3 $ unLoc happy_var_1, these))))}}}) + ) (\r -> happyReturn (happyIn134 r)) + +happyReduce_298 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_298 = happyMonadReduce 2# 118# happyReduction_298 +happyReduction_298 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut134 happy_x_1 of { (HappyWrap134 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL (thdOf3 $ unLoc happy_var_1) + then return (sLZ happy_var_1 happy_var_2 (glR happy_var_2, (sndOf3 $ unLoc happy_var_1) ++ (msemiA happy_var_2) + ,thdOf3 $ unLoc happy_var_1)) + else case (thdOf3 $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (glEEz happy_var_1 happy_var_2, sndOf3 $ unLoc happy_var_1, snocOL hs t')))}}) + ) (\r -> happyReturn (happyIn134 r)) + +happyReduce_299 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_299 = happySpecReduce_1 118# happyReduction_299 +happyReduction_299 happy_x_1 + = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> + happyIn134 + (sL1 happy_var_1 (glR happy_var_1, [], unitOL happy_var_1) + )} + +happyReduce_300 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_300 = happySpecReduce_0 118# happyReduction_300 +happyReduction_300 = happyIn134 + (noLoc (noAnn, [],nilOL) + ) + +happyReduce_301 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_301 = happySpecReduce_3 119# happyReduction_301 +happyReduction_301 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn135 + (sLL happy_var_1 happy_var_3 (AnnList (Just (fstOf3 $ unLoc happy_var_2)) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) (sndOf3 $ unLoc happy_var_2) noAnn [] + ,sL1 happy_var_2 $ thdOf3 $ unLoc happy_var_2) + )}}} + +happyReduce_302 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_302 = happySpecReduce_3 119# happyReduction_302 +happyReduction_302 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> + happyIn135 + (sL1 happy_var_2 (AnnList (Just (fstOf3 $ unLoc happy_var_2)) ListNone (sndOf3 $ unLoc happy_var_2) noAnn [] + ,sL1 happy_var_2 $ thdOf3 $ unLoc happy_var_2) + )} + +happyReduce_303 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_303 = happyMonadReduce 1# 120# happyReduction_303 +happyReduction_303 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut135 happy_x_1 of { (HappyWrap135 happy_var_1) -> + ( do { let { (AnnList anc p s _ t, decls) = unLoc happy_var_1 } + ; val_binds <- cvBindGroup (unLoc $ decls) + ; !cs <- getCommentsFor (gl happy_var_1) + ; return (sL1 happy_var_1 $ HsValBinds (EpAnn (glR happy_var_1) (AnnList anc p s noAnn t) cs) val_binds)})}) + ) (\r -> happyReturn (happyIn136 r)) + +happyReduce_304 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_304 = happyMonadReduce 3# 120# happyReduction_304 +happyReduction_304 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut275 happy_x_2 of { (HappyWrap275 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( acs (comb3 happy_var_1 happy_var_2 happy_var_3) (\loc cs -> (L loc + $ HsIPBinds (EpAnn (spanAsAnchor (comb3 happy_var_1 happy_var_2 happy_var_3)) (AnnList (Just$ glR happy_var_2) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) [] noAnn []) cs) (IPBinds noExtField (reverse $ unLoc happy_var_2)))))}}}) + ) (\r -> happyReturn (happyIn136 r)) + +happyReduce_305 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_305 = happyMonadReduce 3# 120# happyReduction_305 +happyReduction_305 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut275 happy_x_2 of { (HappyWrap275 happy_var_2) -> + ( acs (gl happy_var_2) (\loc cs -> (L loc + $ HsIPBinds (EpAnn (glR happy_var_1) (AnnList (Just $ glR happy_var_2) ListNone [] noAnn []) cs) (IPBinds noExtField (reverse $ unLoc happy_var_2)))))}}) + ) (\r -> happyReturn (happyIn136 r)) + +happyReduce_306 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_306 = happyMonadReduce 2# 121# happyReduction_306 +happyReduction_306 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut136 happy_x_2 of { (HappyWrap136 happy_var_2) -> + ( do { r <- acs (comb2 happy_var_1 happy_var_2) (\loc cs -> + (L loc (annBinds (epTok happy_var_1) cs (unLoc happy_var_2)))) + ; return $ Just r})}}) + ) (\r -> happyReturn (happyIn137 r)) + +happyReduce_307 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_307 = happySpecReduce_0 121# happyReduction_307 +happyReduction_307 = happyIn137 + (Nothing + ) + +happyReduce_308 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_308 = happyMonadReduce 3# 122# happyReduction_308 +happyReduction_308 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut138 happy_x_1 of { (HappyWrap138 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut139 happy_x_3 of { (HappyWrap139 happy_var_3) -> + ( case happy_var_1 of + [] -> return (happy_var_3:happy_var_1) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (happy_var_3:h':t))}}}) + ) (\r -> happyReturn (happyIn138 r)) + +happyReduce_309 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_309 = happyMonadReduce 2# 122# happyReduction_309 +happyReduction_309 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut138 happy_x_1 of { (HappyWrap138 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( case happy_var_1 of + [] -> return happy_var_1 + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (h':t))}}) + ) (\r -> happyReturn (happyIn138 r)) + +happyReduce_310 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_310 = happySpecReduce_1 122# happyReduction_310 +happyReduction_310 happy_x_1 + = case happyOut139 happy_x_1 of { (HappyWrap139 happy_var_1) -> + happyIn138 + ([happy_var_1] + )} + +happyReduce_311 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_311 = happySpecReduce_0 122# happyReduction_311 +happyReduction_311 = happyIn138 + ([] + ) + +happyReduce_312 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_312 = happyMonadReduce 6# 123# happyReduction_312 +happyReduction_312 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut140 happy_x_2 of { (HappyWrap140 happy_var_2) -> + case happyOut143 happy_x_3 of { (HappyWrap143 happy_var_3) -> + case happyOut224 happy_x_4 of { (HappyWrap224 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut221 happy_x_6 of { (HappyWrap221 happy_var_6) -> + (runPV (unECP happy_var_4) >>= \ happy_var_4 -> + runPV (unECP happy_var_6) >>= \ happy_var_6 -> + amsA' (sLL happy_var_1 happy_var_6 $ HsRule + { rd_ext =((fst happy_var_2, epTok happy_var_5), getSTRINGs happy_var_1) + , rd_name = L (noAnnSrcSpan $ gl happy_var_1) (getSTRING happy_var_1) + , rd_act = snd happy_var_2 `orElse` AlwaysActive + , rd_bndrs = ruleBndrsOrDef happy_var_3 + , rd_lhs = happy_var_4, rd_rhs = happy_var_6 }))}}}}}}) + ) (\r -> happyReturn (happyIn139 r)) + +happyReduce_313 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_313 = happySpecReduce_0 124# happyReduction_313 +happyReduction_313 = happyIn140 + ((noAnn, Nothing) + ) + +happyReduce_314 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_314 = happySpecReduce_1 124# happyReduction_314 +happyReduction_314 happy_x_1 + = case happyOut142 happy_x_1 of { (HappyWrap142 happy_var_1) -> + happyIn140 + ((fst happy_var_1,Just (snd happy_var_1)) + )} + +happyReduce_315 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_315 = happySpecReduce_1 125# happyReduction_315 +happyReduction_315 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn141 + ((Just (epTok happy_var_1)) + )} + +happyReduce_316 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_316 = happyMonadReduce 1# 125# happyReduction_316 +happyReduction_316 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( if (getVARSYM happy_var_1 == fsLit "~") + then return (Just (epTok happy_var_1)) + else do { addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $ + PsErrInvalidRuleActivationMarker + ; return Nothing })}) + ) (\r -> happyReturn (happyIn141 r)) + +happyReduce_317 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_317 = happySpecReduce_3 126# happyReduction_317 +happyReduction_317 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn142 + (( ActivationAnn (epTok happy_var_1) (epTok happy_var_3) Nothing (Just (glR happy_var_2)) + , ActiveAfter (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2)))) + )}}} + +happyReduce_318 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_318 = happyReduce 4# 126# happyReduction_318 +happyReduction_318 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut141 happy_x_2 of { (HappyWrap141 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn142 + (( ActivationAnn (epTok happy_var_1) (epTok happy_var_4) happy_var_2 (Just (glR happy_var_3)) + , ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3)))) + ) `HappyStk` happyRest}}}} + +happyReduce_319 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_319 = happySpecReduce_3 126# happyReduction_319 +happyReduction_319 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut141 happy_x_2 of { (HappyWrap141 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn142 + (( ActivationAnn (epTok happy_var_1) (epTok happy_var_3) happy_var_2 Nothing + , NeverActive) + )}}} + +happyReduce_320 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_320 = happyMonadReduce 6# 127# happyReduction_320 +happyReduction_320 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut144 happy_x_5 of { (HappyWrap144 happy_var_5) -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( hintExplicitForall happy_var_1 + >> checkRuleTyVarBndrNames happy_var_2 + >> let ann = HsRuleBndrsAnn + (Just (epUniTok happy_var_1,epTok happy_var_3)) + (Just (epUniTok happy_var_4,epTok happy_var_6)) + in return (Just (mkRuleBndrs ann (Just happy_var_2) happy_var_5)))}}}}}}) + ) (\r -> happyReturn (happyIn143 r)) + +happyReduce_321 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_321 = happySpecReduce_3 127# happyReduction_321 +happyReduction_321 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn143 + (Just (mkRuleBndrs (HsRuleBndrsAnn Nothing (Just (epUniTok happy_var_1,epTok happy_var_3))) + Nothing happy_var_2) + )}}} + +happyReduce_322 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_322 = happySpecReduce_0 127# happyReduction_322 +happyReduction_322 = happyIn143 + (Nothing + ) + +happyReduce_323 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_323 = happySpecReduce_2 128# happyReduction_323 +happyReduction_323 happy_x_2 + happy_x_1 + = case happyOut145 happy_x_1 of { (HappyWrap145 happy_var_1) -> + case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> + happyIn144 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_324 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_324 = happySpecReduce_0 128# happyReduction_324 +happyReduction_324 = happyIn144 + ([] + ) + +happyReduce_325 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_325 = happySpecReduce_1 129# happyReduction_325 +happyReduction_325 happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + happyIn145 + (sL1a happy_var_1 (RuleTyTmVar noAnn happy_var_1 Nothing) + )} + +happyReduce_326 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_326 = happyMonadReduce 5# 129# happyReduction_326 +happyReduction_326 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut320 happy_x_2 of { (HappyWrap320 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut169 happy_x_4 of { (HappyWrap169 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( amsA' (sLL happy_var_1 happy_var_5 (RuleTyTmVar (AnnTyVarBndr [glR happy_var_1] [glR happy_var_5] noAnn (epUniTok happy_var_3)) happy_var_2 (Just happy_var_4))))}}}}}) + ) (\r -> happyReturn (happyIn145 r)) + +happyReduce_327 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_327 = happyMonadReduce 3# 130# happyReduction_327 +happyReduction_327 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut153 happy_x_2 of { (HappyWrap153 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_3 $ DeprecatedTxt (getDEPRECATED_PRAGs happy_var_1) (map stringLiteralToHsDocWst $ snd $ unLoc happy_var_2)) + (AnnPragma (glR happy_var_1) (epTok happy_var_3) (fst $ unLoc happy_var_2) noAnn noAnn noAnn noAnn))}}}) + ) (\r -> happyReturn (happyIn146 r)) + +happyReduce_328 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_328 = happyMonadReduce 4# 130# happyReduction_328 +happyReduction_328 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut147 happy_x_2 of { (HappyWrap147 happy_var_2) -> + case happyOut153 happy_x_3 of { (HappyWrap153 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_4 $ WarningTxt happy_var_2 (getWARNING_PRAGs happy_var_1) (map stringLiteralToHsDocWst $ snd $ unLoc happy_var_3)) + (AnnPragma (glR happy_var_1) (epTok happy_var_4) (fst $ unLoc happy_var_3) noAnn noAnn noAnn noAnn))}}}}) + ) (\r -> happyReturn (happyIn146 r)) + +happyReduce_329 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_329 = happySpecReduce_0 130# happyReduction_329 +happyReduction_329 = happyIn146 + (Nothing + ) + +happyReduce_330 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_330 = happySpecReduce_2 131# happyReduction_330 +happyReduction_330 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn147 + (Just (reLoc $ sLL happy_var_1 happy_var_2 $ InWarningCategory (epTok happy_var_1) (getSTRINGs happy_var_2) + (reLoc $ sL1 happy_var_2 $ mkWarningCategory (getSTRING happy_var_2))) + )}} + +happyReduce_331 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_331 = happySpecReduce_0 131# happyReduction_331 +happyReduction_331 = happyIn147 + (Nothing + ) + +happyReduce_332 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_332 = happyMonadReduce 3# 132# happyReduction_332 +happyReduction_332 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut148 happy_x_1 of { (HappyWrap148 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut149 happy_x_3 of { (HappyWrap149 happy_var_3) -> + ( if isNilOL happy_var_1 + then return (happy_var_1 `appOL` happy_var_3) + else case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (snocOL hs t' `appOL` happy_var_3))}}}) + ) (\r -> happyReturn (happyIn148 r)) + +happyReduce_333 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_333 = happyMonadReduce 2# 132# happyReduction_333 +happyReduction_333 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut148 happy_x_1 of { (HappyWrap148 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL happy_var_1 + then return happy_var_1 + else case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (snocOL hs t'))}}) + ) (\r -> happyReturn (happyIn148 r)) + +happyReduce_334 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_334 = happySpecReduce_1 132# happyReduction_334 +happyReduction_334 happy_x_1 + = case happyOut149 happy_x_1 of { (HappyWrap149 happy_var_1) -> + happyIn148 + (happy_var_1 + )} + +happyReduce_335 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_335 = happySpecReduce_0 132# happyReduction_335 +happyReduction_335 = happyIn148 + (nilOL + ) + +happyReduce_336 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_336 = happyMonadReduce 4# 133# happyReduction_336 +happyReduction_336 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut147 happy_x_1 of { (HappyWrap147 happy_var_1) -> + case happyOut150 happy_x_2 of { (HappyWrap150 happy_var_2) -> + case happyOut284 happy_x_3 of { (HappyWrap284 happy_var_3) -> + case happyOut153 happy_x_4 of { (HappyWrap153 happy_var_4) -> + ( fmap unitOL $ amsA' (L (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) + (Warning (unLoc happy_var_2, fst $ unLoc happy_var_4) (unLoc happy_var_3) + (WarningTxt happy_var_1 NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc happy_var_4))))}}}}) + ) (\r -> happyReturn (happyIn149 r)) + +happyReduce_337 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_337 = happySpecReduce_1 134# happyReduction_337 +happyReduction_337 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn150 + (sL1 happy_var_1 $ TypeNamespaceSpecifier (epTok happy_var_1) + )} + +happyReduce_338 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_338 = happySpecReduce_1 134# happyReduction_338 +happyReduction_338 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn150 + (sL1 happy_var_1 $ DataNamespaceSpecifier (epTok happy_var_1) + )} + +happyReduce_339 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_339 = happySpecReduce_0 134# happyReduction_339 +happyReduction_339 = happyIn150 + (sL0 $ NoNamespaceSpecifier + ) + +happyReduce_340 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_340 = happyMonadReduce 3# 135# happyReduction_340 +happyReduction_340 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut151 happy_x_1 of { (HappyWrap151 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut152 happy_x_3 of { (HappyWrap152 happy_var_3) -> + ( if isNilOL happy_var_1 + then return (happy_var_1 `appOL` happy_var_3) + else case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (snocOL hs t' `appOL` happy_var_3))}}}) + ) (\r -> happyReturn (happyIn151 r)) + +happyReduce_341 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_341 = happyMonadReduce 2# 135# happyReduction_341 +happyReduction_341 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut151 happy_x_1 of { (HappyWrap151 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL happy_var_1 + then return happy_var_1 + else case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (snocOL hs t'))}}) + ) (\r -> happyReturn (happyIn151 r)) + +happyReduce_342 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_342 = happySpecReduce_1 135# happyReduction_342 +happyReduction_342 happy_x_1 + = case happyOut152 happy_x_1 of { (HappyWrap152 happy_var_1) -> + happyIn151 + (happy_var_1 + )} + +happyReduce_343 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_343 = happySpecReduce_0 135# happyReduction_343 +happyReduction_343 = happyIn151 + (nilOL + ) + +happyReduce_344 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_344 = happyMonadReduce 3# 136# happyReduction_344 +happyReduction_344 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut150 happy_x_1 of { (HappyWrap150 happy_var_1) -> + case happyOut284 happy_x_2 of { (HappyWrap284 happy_var_2) -> + case happyOut153 happy_x_3 of { (HappyWrap153 happy_var_3) -> + ( fmap unitOL $ amsA' (sL (comb3 happy_var_1 happy_var_2 happy_var_3) $ (Warning (unLoc happy_var_1, fst $ unLoc happy_var_3) (unLoc happy_var_2) + (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc happy_var_3))))}}}) + ) (\r -> happyReturn (happyIn152 r)) + +happyReduce_345 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_345 = happySpecReduce_1 137# happyReduction_345 +happyReduction_345 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn153 + (sL1 happy_var_1 (noAnn,[L (gl happy_var_1) (getStringLiteral happy_var_1)]) + )} + +happyReduce_346 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_346 = happySpecReduce_3 137# happyReduction_346 +happyReduction_346 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut154 happy_x_2 of { (HappyWrap154 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn153 + (sLL happy_var_1 happy_var_3 $ ((epTok happy_var_1,epTok happy_var_3),fromOL (unLoc happy_var_2)) + )}}} + +happyReduce_347 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_347 = happyMonadReduce 3# 138# happyReduction_347 +happyReduction_347 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut154 happy_x_1 of { (HappyWrap154 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( if isNilOL (unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (unLoc happy_var_1 `snocOL` + (L (gl happy_var_3) (getStringLiteral happy_var_3)))) + else case (unLoc happy_var_1) of + SnocOL hs t -> do + let { t' = addTrailingCommaS t (glR happy_var_2) } + return (sLL happy_var_1 happy_var_3 (snocOL hs t' `snocOL` + (L (gl happy_var_3) (getStringLiteral happy_var_3)))))}}}) + ) (\r -> happyReturn (happyIn154 r)) + +happyReduce_348 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_348 = happySpecReduce_1 138# happyReduction_348 +happyReduction_348 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn154 + (sLL happy_var_1 happy_var_1 (unitOL (L (gl happy_var_1) (getStringLiteral happy_var_1))) + )} + +happyReduce_349 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_349 = happySpecReduce_0 138# happyReduction_349 +happyReduction_349 = happyIn154 + (noLoc nilOL + ) + +happyReduce_350 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_350 = happyMonadReduce 4# 139# happyReduction_350 +happyReduction_350 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut285 happy_x_2 of { (HappyWrap285 happy_var_2) -> + case happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( runPV (unECP happy_var_3) >>= \ happy_var_3 -> + amsA' (sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation + (AnnPragma (glR happy_var_1) (epTok happy_var_4) noAnn noAnn noAnn noAnn noAnn, + (getANN_PRAGs happy_var_1)) + (ValueAnnProvenance happy_var_2) happy_var_3)))}}}}) + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_351 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_351 = happyMonadReduce 5# 139# happyReduction_351 +happyReduction_351 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut305 happy_x_3 of { (HappyWrap305 happy_var_3) -> + case happyOut230 happy_x_4 of { (HappyWrap230 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> + amsA' (sLL happy_var_1 happy_var_5 (AnnD noExtField $ HsAnnotation + (AnnPragma (glR happy_var_1) (epTok happy_var_5) noAnn noAnn noAnn (epTok happy_var_2) noAnn, + (getANN_PRAGs happy_var_1)) + (TypeAnnProvenance happy_var_3) happy_var_4)))}}}}}) + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_352 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_352 = happyMonadReduce 4# 139# happyReduction_352 +happyReduction_352 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( runPV (unECP happy_var_3) >>= \ happy_var_3 -> + amsA' (sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation + (AnnPragma (glR happy_var_1) (epTok happy_var_4) noAnn noAnn noAnn noAnn (epTok happy_var_2), + (getANN_PRAGs happy_var_1)) + ModuleAnnProvenance happy_var_3)))}}}}) + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_353 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_353 = happyMonadReduce 4# 140# happyReduction_353 +happyReduction_353 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut157 happy_x_2 of { (HappyWrap157 happy_var_2) -> + case happyOut158 happy_x_3 of { (HappyWrap158 happy_var_3) -> + case happyOut159 happy_x_4 of { (HappyWrap159 happy_var_4) -> + ( mkImport happy_var_2 happy_var_3 (snd $ unLoc happy_var_4) (epTok happy_var_1, fst $ unLoc happy_var_4) >>= \i -> + return (sLL happy_var_1 happy_var_4 i))}}}}) + ) (\r -> happyReturn (happyIn156 r)) + +happyReduce_354 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_354 = happyMonadReduce 3# 140# happyReduction_354 +happyReduction_354 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut157 happy_x_2 of { (HappyWrap157 happy_var_2) -> + case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> + ( do { d <- mkImport happy_var_2 (noLoc PlaySafe) (snd $ unLoc happy_var_3) (epTok happy_var_1, fst $ unLoc happy_var_3); + return (sLL happy_var_1 happy_var_3 d) })}}}) + ) (\r -> happyReturn (happyIn156 r)) + +happyReduce_355 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_355 = happyMonadReduce 3# 140# happyReduction_355 +happyReduction_355 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut157 happy_x_2 of { (HappyWrap157 happy_var_2) -> + case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> + ( mkExport happy_var_2 (snd $ unLoc happy_var_3) (epTok happy_var_1, fst $ unLoc happy_var_3) >>= \i -> + return (sLL happy_var_1 happy_var_3 i ))}}}) + ) (\r -> happyReturn (happyIn156 r)) + +happyReduce_356 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_356 = happySpecReduce_1 141# happyReduction_356 +happyReduction_356 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn157 + (sLL happy_var_1 happy_var_1 StdCallConv + )} + +happyReduce_357 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_357 = happySpecReduce_1 141# happyReduction_357 +happyReduction_357 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn157 + (sLL happy_var_1 happy_var_1 CCallConv + )} + +happyReduce_358 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_358 = happySpecReduce_1 141# happyReduction_358 +happyReduction_358 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn157 + (sLL happy_var_1 happy_var_1 CApiConv + )} + +happyReduce_359 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_359 = happySpecReduce_1 141# happyReduction_359 +happyReduction_359 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn157 + (sLL happy_var_1 happy_var_1 PrimCallConv + )} + +happyReduce_360 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_360 = happySpecReduce_1 141# happyReduction_360 +happyReduction_360 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn157 + (sLL happy_var_1 happy_var_1 JavaScriptCallConv + )} + +happyReduce_361 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_361 = happySpecReduce_1 142# happyReduction_361 +happyReduction_361 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn158 + (sLL happy_var_1 happy_var_1 PlayRisky + )} + +happyReduce_362 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_362 = happySpecReduce_1 142# happyReduction_362 +happyReduction_362 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn158 + (sLL happy_var_1 happy_var_1 PlaySafe + )} + +happyReduce_363 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_363 = happySpecReduce_1 142# happyReduction_363 +happyReduction_363 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn158 + (sLL happy_var_1 happy_var_1 PlayInterruptible + )} + +happyReduce_364 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_364 = happyReduce 4# 143# happyReduction_364 +happyReduction_364 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut163 happy_x_4 of { (HappyWrap163 happy_var_4) -> + happyIn159 + (sLL happy_var_1 happy_var_4 (epUniTok happy_var_3 + ,(L (getLoc happy_var_1) + (getStringLiteral happy_var_1), happy_var_2, happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_365 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_365 = happyReduce 4# 143# happyReduction_365 +happyReduction_365 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut163 happy_x_4 of { (HappyWrap163 happy_var_4) -> + happyIn159 + (sLL happy_var_1 happy_var_4 (epUniTok happy_var_3 + ,(L (getLoc happy_var_1) + (getStringMultiLiteral happy_var_1), happy_var_2, happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_366 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_366 = happySpecReduce_3 143# happyReduction_366 +happyReduction_366 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut163 happy_x_3 of { (HappyWrap163 happy_var_3) -> + happyIn159 + (sLL happy_var_1 happy_var_3 (epUniTok happy_var_2 + ,(noLoc (StringLiteral NoSourceText nilFS Nothing), happy_var_1, happy_var_3)) + )}}} + +happyReduce_367 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_367 = happySpecReduce_0 144# happyReduction_367 +happyReduction_367 = happyIn160 + (Nothing + ) + +happyReduce_368 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_368 = happySpecReduce_2 144# happyReduction_368 +happyReduction_368 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut169 happy_x_2 of { (HappyWrap169 happy_var_2) -> + happyIn160 + (Just (epUniTok happy_var_1, happy_var_2) + )}} + +happyReduce_369 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_369 = happySpecReduce_0 145# happyReduction_369 +happyReduction_369 = happyIn161 + ((Nothing, Nothing) + ) + +happyReduce_370 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_370 = happySpecReduce_2 145# happyReduction_370 +happyReduction_370 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut296 happy_x_2 of { (HappyWrap296 happy_var_2) -> + happyIn161 + ((Just (epUniTok happy_var_1), Just happy_var_2) + )}} + +happyReduce_371 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_371 = happySpecReduce_1 146# happyReduction_371 +happyReduction_371 happy_x_1 + = case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> + happyIn162 + (happy_var_1 + )} + +happyReduce_372 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_372 = happyMonadReduce 3# 146# happyReduction_372 +happyReduction_372 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut194 happy_x_3 of { (HappyWrap194 happy_var_3) -> + ( amsA' (sLL happy_var_1 happy_var_3 $ mkHsImplicitSigType $ + sLLa happy_var_1 happy_var_3 $ HsKindSig (epUniTok happy_var_2) happy_var_1 happy_var_3))}}}) + ) (\r -> happyReturn (happyIn162 r)) + +happyReduce_373 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_373 = happySpecReduce_1 147# happyReduction_373 +happyReduction_373 happy_x_1 + = case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> + happyIn163 + (hsTypeToHsSigType happy_var_1 + )} + +happyReduce_374 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_374 = happyMonadReduce 3# 148# happyReduction_374 +happyReduction_374 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut316 happy_x_3 of { (HappyWrap316 happy_var_3) -> + ( case unLoc happy_var_1 of + [] -> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)) + (h:t) -> do + h' <- addTrailingCommaN h (gl happy_var_2) + return (sLL happy_var_1 happy_var_3 (happy_var_3 : h' : t)))}}}) + ) (\r -> happyReturn (happyIn164 r)) + +happyReduce_375 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_375 = happySpecReduce_1 148# happyReduction_375 +happyReduction_375 happy_x_1 + = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + happyIn164 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_376 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_376 = happySpecReduce_1 149# happyReduction_376 +happyReduction_376 happy_x_1 + = case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> + happyIn165 + (sL1 happy_var_1 (unitOL happy_var_1) + )} + +happyReduce_377 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_377 = happyMonadReduce 3# 149# happyReduction_377 +happyReduction_377 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut165 happy_x_3 of { (HappyWrap165 happy_var_3) -> + ( do { st <- addTrailingCommaA happy_var_1 (epTok happy_var_2) + ; return $ sLL happy_var_1 happy_var_3 (unitOL st `appOL` unLoc happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn165 r)) + +happyReduce_378 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_378 = happySpecReduce_2 150# happyReduction_378 +happyReduction_378 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn166 + (sLL happy_var_1 happy_var_2 (UnpackednessPragma (glR happy_var_1, epTok happy_var_2) (getUNPACK_PRAGs happy_var_1) SrcUnpack) + )}} + +happyReduce_379 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_379 = happySpecReduce_2 150# happyReduction_379 +happyReduction_379 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn166 + (sLL happy_var_1 happy_var_2 (UnpackednessPragma (glR happy_var_1, epTok happy_var_2) (getNOUNPACK_PRAGs happy_var_1) SrcNoUnpack) + )}} + +happyReduce_380 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_380 = happyMonadReduce 3# 151# happyReduction_380 +happyReduction_380 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { hintExplicitForall happy_var_1 + ; acs (comb2 happy_var_1 happy_var_3) (\loc cs -> (L loc $ + mkHsForAllInvisTele (EpAnn (glEE happy_var_1 happy_var_3) (epUniTok happy_var_1,epTok happy_var_3) cs) happy_var_2 )) })}}}) + ) (\r -> happyReturn (happyIn167 r)) + +happyReduce_381 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_381 = happyMonadReduce 3# 151# happyReduction_381 +happyReduction_381 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { hintExplicitForall happy_var_1 + ; req_tvbs <- fromSpecTyVarBndrs happy_var_2 + ; acs (comb2 happy_var_1 happy_var_3) (\loc cs -> (L loc $ + mkHsForAllVisTele (EpAnn (glEE happy_var_1 happy_var_3) (epUniTok happy_var_1,epUniTok happy_var_3) cs) req_tvbs )) })}}}) + ) (\r -> happyReturn (happyIn167 r)) + +happyReduce_382 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_382 = happySpecReduce_1 152# happyReduction_382 +happyReduction_382 happy_x_1 + = case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> + happyIn168 + (happy_var_1 + )} + +happyReduce_383 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_383 = happyMonadReduce 3# 152# happyReduction_383 +happyReduction_383 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut194 happy_x_3 of { (HappyWrap194 happy_var_3) -> + ( amsA' (sLL happy_var_1 happy_var_3 $ HsKindSig (epUniTok happy_var_2) happy_var_1 happy_var_3))}}}) + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_384 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_384 = happySpecReduce_2 153# happyReduction_384 +happyReduction_384 happy_x_2 + happy_x_1 + = case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> + case happyOut169 happy_x_2 of { (HappyWrap169 happy_var_2) -> + happyIn169 + (sLLa happy_var_1 happy_var_2 $ + HsForAllTy { hst_tele = unLoc happy_var_1 + , hst_xforall = noExtField + , hst_body = happy_var_2 } + )}} + +happyReduce_385 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_385 = happyMonadReduce 3# 153# happyReduction_385 +happyReduction_385 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut170 happy_x_1 of { (HappyWrap170 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + ( acsA (comb2 happy_var_1 happy_var_3) (\loc cs -> (L loc $ + HsQualTy { hst_ctxt = addTrailingDarrowC happy_var_1 happy_var_2 cs + , hst_xqual = NoExtField + , hst_body = happy_var_3 })))}}}) + ) (\r -> happyReturn (happyIn169 r)) + +happyReduce_386 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_386 = happyMonadReduce 3# 153# happyReduction_386 +happyReduction_386 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut277 happy_x_1 of { (HappyWrap277 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + ( amsA' (sLL happy_var_1 happy_var_3 (HsIParamTy (epUniTok happy_var_2) (reLoc happy_var_1) happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn169 r)) + +happyReduce_387 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_387 = happySpecReduce_1 153# happyReduction_387 +happyReduction_387 happy_x_1 + = case happyOut172 happy_x_1 of { (HappyWrap172 happy_var_1) -> + happyIn169 + (happy_var_1 + )} + +happyReduce_388 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_388 = happyMonadReduce 1# 154# happyReduction_388 +happyReduction_388 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> + ( checkContext happy_var_1)}) + ) (\r -> happyReturn (happyIn170 r)) + +happyReduce_389 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_389 = happySpecReduce_1 155# happyReduction_389 +happyReduction_389 happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + happyIn171 + (unECP happy_var_1 >>= \ happy_var_1 -> + checkContextPV happy_var_1 + )} + +happyReduce_390 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_390 = happySpecReduce_1 156# happyReduction_390 +happyReduction_390 happy_x_1 + = case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> + happyIn172 + (happy_var_1 + )} + +happyReduce_391 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_391 = happyMonadReduce 3# 156# happyReduction_391 +happyReduction_391 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + ( amsA' (sLL happy_var_1 happy_var_3 + $ HsFunTy noExtField (HsUnannotated (EpArrow (epUniTok happy_var_2))) happy_var_1 happy_var_3))}}}) + ) (\r -> happyReturn (happyIn172 r)) + +happyReduce_392 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_392 = happyMonadReduce 4# 156# happyReduction_392 +happyReduction_392 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> + case happyOut173 happy_x_2 of { (HappyWrap173 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut169 happy_x_4 of { (HappyWrap169 happy_var_4) -> + ( hintLinear (getLoc happy_var_2) + >> let arr = (unLoc happy_var_2) (epUniTok happy_var_3) + in amsA' (sLL happy_var_1 happy_var_4 $ HsFunTy noExtField arr happy_var_1 happy_var_4))}}}}) + ) (\r -> happyReturn (happyIn172 r)) + +happyReduce_393 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_393 = happyMonadReduce 3# 156# happyReduction_393 +happyReduction_393 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + ( hintLinear (getLoc happy_var_2) >> + amsA' (sLL happy_var_1 happy_var_3 $ HsFunTy noExtField (HsLinearAnn (EpLolly (epTok happy_var_2))) happy_var_1 happy_var_3))}}}) + ) (\r -> happyReturn (happyIn172 r)) + +happyReduce_394 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_394 = happySpecReduce_2 157# happyReduction_394 +happyReduction_394 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + happyIn173 + (sLL happy_var_1 happy_var_2 (mkMultAnn (epTok happy_var_1) happy_var_2 . EpArrow) + )}} + +happyReduce_395 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_395 = happySpecReduce_2 158# happyReduction_395 +happyReduction_395 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + happyIn174 + (unECP happy_var_2 >>= \ happy_var_2 -> + fmap (sLL happy_var_1 happy_var_2) (mkHsMultPV (epTok happy_var_1) happy_var_2) + )}} + +happyReduce_396 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_396 = happyMonadReduce 1# 159# happyReduction_396 +happyReduction_396 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut176 happy_x_1 of { (HappyWrap176 happy_var_1) -> + ( runPV happy_var_1)}) + ) (\r -> happyReturn (happyIn175 r)) + +happyReduce_397 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_397 = happySpecReduce_1 160# happyReduction_397 +happyReduction_397 happy_x_1 + = case happyOut177 happy_x_1 of { (HappyWrap177 happy_var_1) -> + happyIn176 + (happy_var_1 + )} + +happyReduce_398 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_398 = happySpecReduce_3 160# happyReduction_398 +happyReduction_398 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut177 happy_x_1 of { (HappyWrap177 happy_var_1) -> + case happyOut179 happy_x_2 of { (HappyWrap179 happy_var_2) -> + case happyOut176 happy_x_3 of { (HappyWrap176 happy_var_3) -> + happyIn176 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> + do { let (op, prom) = happy_var_2 + ; when (looksLikeMult happy_var_1 op happy_var_3) $ hintLinear (getLocA op) + ; mkHsOpTyPV prom happy_var_1 op happy_var_3 } + )}}} + +happyReduce_399 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_399 = happySpecReduce_2 160# happyReduction_399 +happyReduction_399 happy_x_2 + happy_x_1 + = case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> + case happyOut176 happy_x_2 of { (HappyWrap176 happy_var_2) -> + happyIn176 + (happy_var_2 >>= \ happy_var_2 -> + mkUnpackednessPV happy_var_1 happy_var_2 + )}} + +happyReduce_400 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_400 = happySpecReduce_1 161# happyReduction_400 +happyReduction_400 happy_x_1 + = case happyOut180 happy_x_1 of { (HappyWrap180 happy_var_1) -> + happyIn177 + (mkHsAppTyHeadPV happy_var_1 + )} + +happyReduce_401 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_401 = happySpecReduce_1 161# happyReduction_401 +happyReduction_401 happy_x_1 + = case happyOut179 happy_x_1 of { (HappyWrap179 happy_var_1) -> + happyIn177 + (failOpFewArgs (fst happy_var_1) + )} + +happyReduce_402 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_402 = happySpecReduce_2 161# happyReduction_402 +happyReduction_402 happy_x_2 + happy_x_1 + = case happyOut177 happy_x_1 of { (HappyWrap177 happy_var_1) -> + case happyOut178 happy_x_2 of { (HappyWrap178 happy_var_2) -> + happyIn177 + (happy_var_1 >>= \ happy_var_1 -> + mkHsAppTyPV happy_var_1 happy_var_2 + )}} + +happyReduce_403 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_403 = happySpecReduce_3 161# happyReduction_403 +happyReduction_403 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut177 happy_x_1 of { (HappyWrap177 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut180 happy_x_3 of { (HappyWrap180 happy_var_3) -> + happyIn177 + (happy_var_1 >>= \ happy_var_1 -> + mkHsAppKindTyPV happy_var_1 (epTok happy_var_2) happy_var_3 + )}}} + +happyReduce_404 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_404 = happySpecReduce_1 162# happyReduction_404 +happyReduction_404 happy_x_1 + = case happyOut180 happy_x_1 of { (HappyWrap180 happy_var_1) -> + happyIn178 + (happy_var_1 + )} + +happyReduce_405 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_405 = happyMonadReduce 2# 162# happyReduction_405 +happyReduction_405 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + ( addUnpackednessP happy_var_1 happy_var_2)}}) + ) (\r -> happyReturn (happyIn178 r)) + +happyReduce_406 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_406 = happySpecReduce_1 163# happyReduction_406 +happyReduction_406 happy_x_1 + = case happyOut300 happy_x_1 of { (HappyWrap300 happy_var_1) -> + happyIn179 + ((happy_var_1, NotPromoted) + )} + +happyReduce_407 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_407 = happySpecReduce_1 163# happyReduction_407 +happyReduction_407 happy_x_1 + = case happyOut314 happy_x_1 of { (HappyWrap314 happy_var_1) -> + happyIn179 + ((happy_var_1, NotPromoted) + )} + +happyReduce_408 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_408 = happyMonadReduce 2# 163# happyReduction_408 +happyReduction_408 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut295 happy_x_2 of { (HappyWrap295 happy_var_2) -> + ( do { op <- amsr (sLL happy_var_1 happy_var_2 (unLoc happy_var_2)) + (NameAnnQuote (epTok happy_var_1) (gl happy_var_2) []) + ; return (op, IsPromoted) })}}) + ) (\r -> happyReturn (happyIn179 r)) + +happyReduce_409 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_409 = happyMonadReduce 2# 163# happyReduction_409 +happyReduction_409 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut307 happy_x_2 of { (HappyWrap307 happy_var_2) -> + ( do { op <- amsr (sLL happy_var_1 happy_var_2 (unLoc happy_var_2)) + (NameAnnQuote (epTok happy_var_1) (gl happy_var_2) []) + ; return (op, IsPromoted) })}}) + ) (\r -> happyReturn (happyIn179 r)) + +happyReduce_410 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_410 = happyMonadReduce 1# 164# happyReduction_410 +happyReduction_410 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> + ( amsA' (sL1 happy_var_1 (HsTyVar noAnn NotPromoted happy_var_1)))}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_411 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_411 = happyMonadReduce 1# 164# happyReduction_411 +happyReduction_411 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> + ( amsA' (sL1 happy_var_1 (HsTyVar noAnn NotPromoted happy_var_1)))}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_412 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_412 = happySpecReduce_1 164# happyReduction_412 +happyReduction_412 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn180 + (sL1a happy_var_1 $ mkAnonWildCardTy (epTok happy_var_1) + )} + +happyReduce_413 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_413 = happyMonadReduce 1# 164# happyReduction_413 +happyReduction_413 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( do { warnStarIsType (getLoc happy_var_1) + ; return $ sL1a happy_var_1 (HsStarTy noExtField (isUnicode happy_var_1)) })}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_414 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_414 = happyMonadReduce 2# 164# happyReduction_414 +happyReduction_414 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 (mkBangTy (glR happy_var_1) SrcLazy happy_var_2)))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_415 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_415 = happyMonadReduce 2# 164# happyReduction_415 +happyReduction_415 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 (mkBangTy (glR happy_var_1) SrcStrict happy_var_2)))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_416 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_416 = happyMonadReduce 3# 164# happyReduction_416 +happyReduction_416 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut204 happy_x_2 of { (HappyWrap204 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { decls <- amsA' (sLL happy_var_1 happy_var_3 $ XHsType $ HsRecTy (AnnList (listAsAnchorM happy_var_2) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) [] noAnn []) happy_var_2) + ; checkRecordSyntax decls })}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_417 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_417 = happyMonadReduce 2# 164# happyReduction_417 +happyReduction_417 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsA' . sLL happy_var_1 happy_var_2 =<< (mkTupleSyntaxTy (epTok happy_var_1) [] (epTok happy_var_2)))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_418 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_418 = happyMonadReduce 5# 164# happyReduction_418 +happyReduction_418 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut184 happy_x_4 of { (HappyWrap184 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( do { h <- addTrailingCommaA happy_var_2 (epTok happy_var_3) + ; amsA' . sLL happy_var_1 happy_var_5 =<< (mkTupleSyntaxTy (epTok happy_var_1) (h : happy_var_4) (epTok happy_var_5)) })}}}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_419 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_419 = happyMonadReduce 2# 164# happyReduction_419 +happyReduction_419 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( do { requireLTPuns PEP_TupleSyntaxType happy_var_1 happy_var_2 + ; amsA' (sLL happy_var_1 happy_var_2 $ HsTupleTy (AnnParensHash (epTok happy_var_1) (epTok happy_var_2)) HsUnboxedTuple []) })}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_420 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_420 = happyMonadReduce 3# 164# happyReduction_420 +happyReduction_420 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut184 happy_x_2 of { (HappyWrap184 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { requireLTPuns PEP_TupleSyntaxType happy_var_1 happy_var_3 + ; amsA' (sLL happy_var_1 happy_var_3 $ HsTupleTy (AnnParensHash (epTok happy_var_1) (epTok happy_var_3)) HsUnboxedTuple happy_var_2) })}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_421 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_421 = happyMonadReduce 3# 164# happyReduction_421 +happyReduction_421 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut185 happy_x_2 of { (HappyWrap185 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { requireLTPuns PEP_SumSyntaxType happy_var_1 happy_var_3 + ; amsA' (sLL happy_var_1 happy_var_3 $ HsSumTy (AnnParensHash (epTok happy_var_1) (epTok happy_var_3)) happy_var_2) })}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_422 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_422 = happyMonadReduce 3# 164# happyReduction_422 +happyReduction_422 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' . sLL happy_var_1 happy_var_3 =<< (mkListSyntaxTy1 (epTok happy_var_1) happy_var_2 (epTok happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_423 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_423 = happyMonadReduce 3# 164# happyReduction_423 +happyReduction_423 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ HsParTy (epTok happy_var_1, epTok happy_var_3) happy_var_2))}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_424 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_424 = happyMonadReduce 3# 164# happyReduction_424 +happyReduction_424 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { requireLTPuns PEP_QuoteDisambiguation happy_var_1 happy_var_3 + ; amsA' (sLL happy_var_1 happy_var_3 $ HsExplicitTupleTy (epTok happy_var_1,epTok happy_var_2,epTok happy_var_3) IsPromoted []) })}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_425 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_425 = happyMonadReduce 2# 164# happyReduction_425 +happyReduction_425 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut287 happy_x_2 of { (HappyWrap287 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 $ HsTyVar (epTok happy_var_1) IsPromoted happy_var_2))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_426 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_426 = happyMonadReduce 2# 164# happyReduction_426 +happyReduction_426 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut291 happy_x_2 of { (HappyWrap291 happy_var_2) -> + ( do { requireLTPuns PEP_QuoteDisambiguation happy_var_1 (reLoc happy_var_2) + ; amsA' (sLL happy_var_1 happy_var_2 $ HsTyVar (epTok happy_var_1) IsPromoted (L (getLoc happy_var_2) $ nameRdrName (dataConName (unLoc happy_var_2)))) })}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_427 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_427 = happyMonadReduce 6# 164# happyReduction_427 +happyReduction_427 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut184 happy_x_5 of { (HappyWrap184 happy_var_5) -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( do { requireLTPuns PEP_QuoteDisambiguation happy_var_1 happy_var_6 + ; h <- addTrailingCommaA happy_var_3 (epTok happy_var_4) + ; amsA' (sLL happy_var_1 happy_var_6 $ HsExplicitTupleTy (epTok happy_var_1,epTok happy_var_2,epTok happy_var_6) IsPromoted (h : happy_var_5)) })}}}}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_428 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_428 = happyMonadReduce 2# 164# happyReduction_428 +happyReduction_428 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( withCombinedComments happy_var_1 happy_var_2 (mkListSyntaxTy0 (epTok happy_var_1) (epTok happy_var_2)))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_429 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_429 = happyMonadReduce 4# 164# happyReduction_429 +happyReduction_429 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut183 happy_x_3 of { (HappyWrap183 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( do { requireLTPuns PEP_QuoteDisambiguation happy_var_1 happy_var_4 + ; amsA' (sLL happy_var_1 happy_var_4 $ HsExplicitListTy (epTok happy_var_1, epTok happy_var_2, epTok happy_var_4) IsPromoted happy_var_3) })}}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_430 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_430 = happyMonadReduce 2# 164# happyReduction_430 +happyReduction_430 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 $ HsTyVar (epTok happy_var_1) IsPromoted happy_var_2))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_431 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_431 = happySpecReduce_1 164# happyReduction_431 +happyReduction_431 happy_x_1 + = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> + happyIn180 + (mapLocA (HsSpliceTy noExtField) happy_var_1 + )} + +happyReduce_432 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_432 = happySpecReduce_1 164# happyReduction_432 +happyReduction_432 happy_x_1 + = case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> + happyIn180 + (mapLocA (HsSpliceTy noExtField) happy_var_1 + )} + +happyReduce_433 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_433 = happyMonadReduce 5# 164# happyReduction_433 +happyReduction_433 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut184 happy_x_4 of { (HappyWrap184 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( do { h <- addTrailingCommaA happy_var_2 (epTok happy_var_3) + ; amsA' (sLL happy_var_1 happy_var_5 $ HsExplicitListTy (NoEpTok,epTok happy_var_1,epTok happy_var_5) NotPromoted (h:happy_var_4)) })}}}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_434 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_434 = happySpecReduce_1 164# happyReduction_434 +happyReduction_434 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn180 + (sLLa happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsNumTy (getINTEGERs happy_var_1) + (il_value (getINTEGER happy_var_1)) + )} + +happyReduce_435 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_435 = happySpecReduce_1 164# happyReduction_435 +happyReduction_435 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn180 + (sLLa happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsCharTy (getCHARs happy_var_1) + (getCHAR happy_var_1) + )} + +happyReduce_436 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_436 = happySpecReduce_1 164# happyReduction_436 +happyReduction_436 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn180 + (sLLa happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsStrTy (getSTRINGs happy_var_1) + (getSTRING happy_var_1) + )} + +happyReduce_437 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_437 = happySpecReduce_1 164# happyReduction_437 +happyReduction_437 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn180 + (sLLa happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsStrTy (getSTRINGMULTIs happy_var_1) + (getSTRINGMULTI happy_var_1) + )} + +happyReduce_438 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_438 = happyMonadReduce 1# 164# happyReduction_438 +happyReduction_438 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( let qname = mkQual tvName (getQVARID happy_var_1) + in amsA' (sL1 happy_var_1 (HsTyVar noAnn NotPromoted (sL1n happy_var_1 $ qname))))}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_439 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_439 = happySpecReduce_1 165# happyReduction_439 +happyReduction_439 happy_x_1 + = case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> + happyIn181 + (happy_var_1 + )} + +happyReduce_440 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_440 = happySpecReduce_1 166# happyReduction_440 +happyReduction_440 happy_x_1 + = case happyOut162 happy_x_1 of { (HappyWrap162 happy_var_1) -> + happyIn182 + ([happy_var_1] + )} + +happyReduce_441 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_441 = happyMonadReduce 3# 166# happyReduction_441 +happyReduction_441 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut162 happy_x_1 of { (HappyWrap162 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut182 happy_x_3 of { (HappyWrap182 happy_var_3) -> + ( do { h <- addTrailingCommaA happy_var_1 (epTok happy_var_2) + ; return (h : happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn182 r)) + +happyReduce_442 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_442 = happySpecReduce_1 167# happyReduction_442 +happyReduction_442 happy_x_1 + = case happyOut184 happy_x_1 of { (HappyWrap184 happy_var_1) -> + happyIn183 + (happy_var_1 + )} + +happyReduce_443 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_443 = happySpecReduce_0 167# happyReduction_443 +happyReduction_443 = happyIn183 + ([] + ) + +happyReduce_444 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_444 = happySpecReduce_1 168# happyReduction_444 +happyReduction_444 happy_x_1 + = case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> + happyIn184 + ([happy_var_1] + )} + +happyReduce_445 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_445 = happyMonadReduce 3# 168# happyReduction_445 +happyReduction_445 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut184 happy_x_3 of { (HappyWrap184 happy_var_3) -> + ( do { h <- addTrailingCommaA happy_var_1 (epTok happy_var_2) + ; return (h : happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn184 r)) + +happyReduce_446 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_446 = happyMonadReduce 3# 169# happyReduction_446 +happyReduction_446 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> + ( do { h <- addTrailingVbarA happy_var_1 (epTok happy_var_2) + ; return [h,happy_var_3] })}}}) + ) (\r -> happyReturn (happyIn185 r)) + +happyReduce_447 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_447 = happyMonadReduce 3# 169# happyReduction_447 +happyReduction_447 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut185 happy_x_3 of { (HappyWrap185 happy_var_3) -> + ( do { h <- addTrailingVbarA happy_var_1 (epTok happy_var_2) + ; return (h : happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn185 r)) + +happyReduce_448 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_448 = happySpecReduce_2 170# happyReduction_448 +happyReduction_448 happy_x_2 + happy_x_1 + = case happyOut187 happy_x_1 of { (HappyWrap187 happy_var_1) -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + happyIn186 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_449 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_449 = happySpecReduce_0 170# happyReduction_449 +happyReduction_449 = happyIn186 + ([] + ) + +happyReduce_450 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_450 = happySpecReduce_1 171# happyReduction_450 +happyReduction_450 happy_x_1 + = case happyOut188 happy_x_1 of { (HappyWrap188 happy_var_1) -> + happyIn187 + (happy_var_1 + )} + +happyReduce_451 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_451 = happyMonadReduce 3# 171# happyReduction_451 +happyReduction_451 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut313 happy_x_2 of { (HappyWrap313 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 + (HsTvb { tvb_ext = AnnTyVarBndr [glR happy_var_1] [glR happy_var_3] noAnn noAnn + , tvb_flag = InferredSpec + , tvb_var = HsBndrVar noExtField happy_var_2 + , tvb_kind = HsBndrNoKind noExtField })))}}}) + ) (\r -> happyReturn (happyIn187 r)) + +happyReduce_452 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_452 = happyMonadReduce 5# 171# happyReduction_452 +happyReduction_452 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut313 happy_x_2 of { (HappyWrap313 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut194 happy_x_4 of { (HappyWrap194 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( amsA' (sLL happy_var_1 happy_var_5 + (HsTvb { tvb_ext = AnnTyVarBndr [glR happy_var_1] [glR happy_var_5] noAnn (epUniTok happy_var_3) + , tvb_flag = InferredSpec + , tvb_var = HsBndrVar noExtField happy_var_2 + , tvb_kind = HsBndrKind noExtField happy_var_4 })))}}}}}) + ) (\r -> happyReturn (happyIn187 r)) + +happyReduce_453 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_453 = happyMonadReduce 1# 172# happyReduction_453 +happyReduction_453 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut189 happy_x_1 of { (HappyWrap189 happy_var_1) -> + ( amsA' (sL1 happy_var_1 + (HsTvb { tvb_ext = noAnn + , tvb_flag = SpecifiedSpec + , tvb_var = unLoc happy_var_1 + , tvb_kind = HsBndrNoKind noExtField })))}) + ) (\r -> happyReturn (happyIn188 r)) + +happyReduce_454 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_454 = happyMonadReduce 5# 172# happyReduction_454 +happyReduction_454 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut189 happy_x_2 of { (HappyWrap189 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut194 happy_x_4 of { (HappyWrap194 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( amsA' (sLL happy_var_1 happy_var_5 + (HsTvb { tvb_ext = AnnTyVarBndr [glR happy_var_1] [glR happy_var_5] noAnn (epUniTok happy_var_3) + , tvb_flag = SpecifiedSpec + , tvb_var = unLoc happy_var_2 + , tvb_kind = HsBndrKind noExtField happy_var_4 })))}}}}}) + ) (\r -> happyReturn (happyIn188 r)) + +happyReduce_455 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_455 = happySpecReduce_1 173# happyReduction_455 +happyReduction_455 happy_x_1 + = case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> + happyIn189 + (sL1 happy_var_1 (HsBndrVar noExtField happy_var_1) + )} + +happyReduce_456 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_456 = happySpecReduce_1 173# happyReduction_456 +happyReduction_456 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn189 + (sL1 happy_var_1 (HsBndrWildCard (epTok happy_var_1)) + )} + +happyReduce_457 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_457 = happySpecReduce_0 174# happyReduction_457 +happyReduction_457 = happyIn190 + (noLoc (NoEpTok,[]) + ) + +happyReduce_458 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_458 = happySpecReduce_2 174# happyReduction_458 +happyReduction_458 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut191 happy_x_2 of { (HappyWrap191 happy_var_2) -> + happyIn190 + ((sLL happy_var_1 happy_var_2 (epTok happy_var_1 ,reverse (unLoc happy_var_2))) + )}} + +happyReduce_459 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_459 = happyMonadReduce 3# 175# happyReduction_459 +happyReduction_459 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut191 happy_x_1 of { (HappyWrap191 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut192 happy_x_3 of { (HappyWrap192 happy_var_3) -> + ( + do { let (h:t) = unLoc happy_var_1 -- Safe from fds1 rules + ; h' <- addTrailingCommaA h (epTok happy_var_2) + ; return (sLL happy_var_1 happy_var_3 (happy_var_3 : h' : t)) })}}}) + ) (\r -> happyReturn (happyIn191 r)) + +happyReduce_460 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_460 = happySpecReduce_1 175# happyReduction_460 +happyReduction_460 happy_x_1 + = case happyOut192 happy_x_1 of { (HappyWrap192 happy_var_1) -> + happyIn191 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_461 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_461 = happyMonadReduce 3# 176# happyReduction_461 +happyReduction_461 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut193 happy_x_1 of { (HappyWrap193 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut193 happy_x_3 of { (HappyWrap193 happy_var_3) -> + ( amsA' (L (comb3 happy_var_1 happy_var_2 happy_var_3) + (FunDep (epUniTok happy_var_2) + (reverse (unLoc happy_var_1)) + (reverse (unLoc happy_var_3)))))}}}) + ) (\r -> happyReturn (happyIn192 r)) + +happyReduce_462 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_462 = happySpecReduce_0 177# happyReduction_462 +happyReduction_462 = happyIn193 + (noLoc [] + ) + +happyReduce_463 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_463 = happySpecReduce_2 177# happyReduction_463 +happyReduction_463 happy_x_2 + happy_x_1 + = case happyOut193 happy_x_1 of { (HappyWrap193 happy_var_1) -> + case happyOut313 happy_x_2 of { (HappyWrap313 happy_var_2) -> + happyIn193 + (sLL happy_var_1 happy_var_2 (happy_var_2 : (unLoc happy_var_1)) + )}} + +happyReduce_464 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_464 = happySpecReduce_1 178# happyReduction_464 +happyReduction_464 happy_x_1 + = case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> + happyIn194 + (happy_var_1 + )} + +happyReduce_465 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_465 = happyMonadReduce 4# 179# happyReduction_465 +happyReduction_465 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut196 happy_x_3 of { (HappyWrap196 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( checkEmptyGADTs $ + L (comb2 happy_var_1 happy_var_4) + ((epTok happy_var_1 + ,epTok happy_var_2 + ,epTok happy_var_4) + , unLoc happy_var_3))}}}}) + ) (\r -> happyReturn (happyIn195 r)) + +happyReduce_466 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_466 = happyMonadReduce 4# 179# happyReduction_466 +happyReduction_466 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut196 happy_x_3 of { (HappyWrap196 happy_var_3) -> + ( checkEmptyGADTs $ + L (comb2 happy_var_1 happy_var_3) + ((epTok happy_var_1, NoEpTok, NoEpTok) + , unLoc happy_var_3))}}) + ) (\r -> happyReturn (happyIn195 r)) + +happyReduce_467 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_467 = happySpecReduce_0 179# happyReduction_467 +happyReduction_467 = happyIn195 + (noLoc (noAnn,[]) + ) + +happyReduce_468 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_468 = happyMonadReduce 3# 180# happyReduction_468 +happyReduction_468 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut197 happy_x_1 of { (HappyWrap197 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut196 happy_x_3 of { (HappyWrap196 happy_var_3) -> + ( do { h <- addTrailingSemiA happy_var_1 (epTok happy_var_2) + ; return (L (comb2 happy_var_1 happy_var_3) (h : unLoc happy_var_3)) })}}}) + ) (\r -> happyReturn (happyIn196 r)) + +happyReduce_469 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_469 = happySpecReduce_1 180# happyReduction_469 +happyReduction_469 happy_x_1 + = case happyOut197 happy_x_1 of { (HappyWrap197 happy_var_1) -> + happyIn196 + (L (glA happy_var_1) [happy_var_1] + )} + +happyReduce_470 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_470 = happySpecReduce_0 180# happyReduction_470 +happyReduction_470 = happyIn196 + (noLoc [] + ) + +happyReduce_471 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_471 = happyMonadReduce 4# 181# happyReduction_471 +happyReduction_471 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut289 happy_x_2 of { (HappyWrap289 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut163 happy_x_4 of { (HappyWrap163 happy_var_4) -> + ( mkGadtDecl (comb2 happy_var_2 happy_var_4) (unLoc happy_var_2) (epUniTok happy_var_3) happy_var_4)}}}) + ) (\r -> happyReturn (happyIn197 r)) + +happyReduce_472 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_472 = happySpecReduce_2 182# happyReduction_472 +happyReduction_472 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut199 happy_x_2 of { (HappyWrap199 happy_var_2) -> + happyIn198 + (sLL happy_var_1 happy_var_2 (epTok happy_var_1,unLoc happy_var_2) + )}} + +happyReduce_473 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_473 = happyMonadReduce 3# 183# happyReduction_473 +happyReduction_473 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut199 happy_x_1 of { (HappyWrap199 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut200 happy_x_3 of { (HappyWrap200 happy_var_3) -> + ( do { let (h:t) = unLoc happy_var_1 + ; h' <- addTrailingVbarA h (epTok happy_var_2) + ; return (sLL happy_var_1 happy_var_3 (happy_var_3 : h' : t)) })}}}) + ) (\r -> happyReturn (happyIn199 r)) + +happyReduce_474 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_474 = happySpecReduce_1 183# happyReduction_474 +happyReduction_474 happy_x_1 + = case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> + happyIn199 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_475 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_475 = happyMonadReduce 4# 184# happyReduction_475 +happyReduction_475 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> + case happyOut170 happy_x_2 of { (HappyWrap170 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut202 happy_x_4 of { (HappyWrap202 happy_var_4) -> + ( amsA' (let (con,details) = unLoc happy_var_4 in + (L (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) (mkConDeclH98 + (epUniTok happy_var_3,(fst $ unLoc happy_var_1)) + con + (snd $ unLoc happy_var_1) + (Just happy_var_2) + details))))}}}}) + ) (\r -> happyReturn (happyIn200 r)) + +happyReduce_476 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_476 = happyMonadReduce 2# 184# happyReduction_476 +happyReduction_476 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> + case happyOut202 happy_x_2 of { (HappyWrap202 happy_var_2) -> + ( amsA' (let (con,details) = unLoc happy_var_2 in + (L (comb2 happy_var_1 happy_var_2) (mkConDeclH98 (noAnn, fst $ unLoc happy_var_1) + con + (snd $ unLoc happy_var_1) + Nothing -- No context + details))))}}) + ) (\r -> happyReturn (happyIn200 r)) + +happyReduce_477 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_477 = happySpecReduce_3 185# happyReduction_477 +happyReduction_477 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn201 + (sLL happy_var_1 happy_var_3 ((epUniTok happy_var_1,epTok happy_var_3), Just happy_var_2) + )}}} + +happyReduce_478 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_478 = happySpecReduce_0 185# happyReduction_478 +happyReduction_478 = happyIn201 + (noLoc (noAnn, Nothing) + ) + +happyReduce_479 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_479 = happyMonadReduce 1# 186# happyReduction_479 +happyReduction_479 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut176 happy_x_1 of { (HappyWrap176 happy_var_1) -> + ( do { b <- runPV happy_var_1 + ; return (sL1 b (dataConBuilderCon b, dataConBuilderDetails b)) })}) + ) (\r -> happyReturn (happyIn202 r)) + +happyReduce_480 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_480 = happyMonadReduce 3# 186# happyReduction_480 +happyReduction_480 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut203 happy_x_2 of { (HappyWrap203 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( let (t, tag, arity) = happy_var_2 in pure (sLL happy_var_1 happy_var_3 $ mkUnboxedSumCon t tag arity))}}}) + ) (\r -> happyReturn (happyIn202 r)) + +happyReduce_481 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_481 = happySpecReduce_2 187# happyReduction_481 +happyReduction_481 happy_x_2 + happy_x_1 + = case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> + case happyOut337 happy_x_2 of { (HappyWrap337 happy_var_2) -> + happyIn203 + ((happy_var_1, 1, (snd happy_var_2 + 1)) + )}} + +happyReduce_482 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_482 = happySpecReduce_3 187# happyReduction_482 +happyReduction_482 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut337 happy_x_1 of { (HappyWrap337 happy_var_1) -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOut336 happy_x_3 of { (HappyWrap336 happy_var_3) -> + happyIn203 + ((happy_var_2, snd happy_var_1 + 1, snd happy_var_1 + snd happy_var_3 + 1) + )}}} + +happyReduce_483 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_483 = happySpecReduce_0 188# happyReduction_483 +happyReduction_483 = happyIn204 + ([] + ) + +happyReduce_484 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_484 = happySpecReduce_1 188# happyReduction_484 +happyReduction_484 happy_x_1 + = case happyOut205 happy_x_1 of { (HappyWrap205 happy_var_1) -> + happyIn204 + (happy_var_1 + )} + +happyReduce_485 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_485 = happyMonadReduce 3# 189# happyReduction_485 +happyReduction_485 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut205 happy_x_3 of { (HappyWrap205 happy_var_3) -> + ( do { h <- addTrailingCommaA happy_var_1 (epTok happy_var_2) + ; return (h : happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn205 r)) + +happyReduce_486 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_486 = happySpecReduce_1 189# happyReduction_486 +happyReduction_486 happy_x_1 + = case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> + happyIn205 + ([happy_var_1] + )} + +happyReduce_487 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_487 = happyMonadReduce 3# 190# happyReduction_487 +happyReduction_487 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + ( amsA' (L (comb2 happy_var_1 happy_var_3) + (HsConDeclRecField noExtField + (reverse (map (\ln@(L l n) + -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc happy_var_1))) + (mkConDeclField (HsUnannotated (EpColon (epUniTok happy_var_2))) happy_var_3))))}}}) + ) (\r -> happyReturn (happyIn206 r)) + +happyReduce_488 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_488 = happyMonadReduce 5# 190# happyReduction_488 +happyReduction_488 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut180 happy_x_3 of { (HappyWrap180 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut169 happy_x_5 of { (HappyWrap169 happy_var_5) -> + ( amsA' (L (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_5) + (HsConDeclRecField noExtField + (reverse (map (\ln@(L l n) + -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc happy_var_1))) + (mkMultField (epTok happy_var_2) happy_var_3 (epUniTok happy_var_4) happy_var_5))))}}}}}) + ) (\r -> happyReturn (happyIn206 r)) + +happyReduce_489 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_489 = happySpecReduce_0 191# happyReduction_489 +happyReduction_489 = happyIn207 + (noLoc [] + ) + +happyReduce_490 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_490 = happySpecReduce_1 191# happyReduction_490 +happyReduction_490 happy_x_1 + = case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> + happyIn207 + (happy_var_1 + )} + +happyReduce_491 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_491 = happySpecReduce_2 192# happyReduction_491 +happyReduction_491 happy_x_2 + happy_x_1 + = case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> + case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> + happyIn208 + (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) + )}} + +happyReduce_492 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_492 = happySpecReduce_1 192# happyReduction_492 +happyReduction_492 happy_x_1 + = case happyOut209 happy_x_1 of { (HappyWrap209 happy_var_1) -> + happyIn208 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_493 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_493 = happyMonadReduce 2# 193# happyReduction_493 +happyReduction_493 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut210 happy_x_2 of { (HappyWrap210 happy_var_2) -> + ( let { full_loc = comb2 happy_var_1 happy_var_2 } + in amsA' (L full_loc $ HsDerivingClause (epTok happy_var_1) Nothing happy_var_2))}}) + ) (\r -> happyReturn (happyIn209 r)) + +happyReduce_494 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_494 = happyMonadReduce 3# 193# happyReduction_494 +happyReduction_494 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut90 happy_x_2 of { (HappyWrap90 happy_var_2) -> + case happyOut210 happy_x_3 of { (HappyWrap210 happy_var_3) -> + ( let { full_loc = comb2 happy_var_1 happy_var_3 } + in amsA' (L full_loc $ HsDerivingClause (epTok happy_var_1) (Just happy_var_2) happy_var_3))}}}) + ) (\r -> happyReturn (happyIn209 r)) + +happyReduce_495 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_495 = happyMonadReduce 3# 193# happyReduction_495 +happyReduction_495 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut210 happy_x_2 of { (HappyWrap210 happy_var_2) -> + case happyOut91 happy_x_3 of { (HappyWrap91 happy_var_3) -> + ( let { full_loc = comb2 happy_var_1 happy_var_3 } + in amsA' (L full_loc $ HsDerivingClause (epTok happy_var_1) (Just happy_var_3) happy_var_2))}}}) + ) (\r -> happyReturn (happyIn209 r)) + +happyReduce_496 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_496 = happySpecReduce_1 194# happyReduction_496 +happyReduction_496 happy_x_1 + = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> + happyIn210 + (let { tc = sL1a happy_var_1 $ mkHsImplicitSigType $ + sL1a happy_var_1 $ HsTyVar noAnn NotPromoted happy_var_1 } in + sL1a happy_var_1 (DctSingle noExtField tc) + )} + +happyReduce_497 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_497 = happyMonadReduce 2# 194# happyReduction_497 +happyReduction_497 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 (DctMulti noExtField [])) + (AnnContext Nothing [epTok happy_var_1] [epTok happy_var_2]))}}) + ) (\r -> happyReturn (happyIn210 r)) + +happyReduce_498 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_498 = happyMonadReduce 3# 194# happyReduction_498 +happyReduction_498 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut182 happy_x_2 of { (HappyWrap182 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (DctMulti noExtField happy_var_2)) + (AnnContext Nothing [epTok happy_var_1] [epTok happy_var_3]))}}}) + ) (\r -> happyReturn (happyIn210 r)) + +happyReduce_499 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_499 = happySpecReduce_1 195# happyReduction_499 +happyReduction_499 happy_x_1 + = case happyOut216 happy_x_1 of { (HappyWrap216 happy_var_1) -> + happyIn211 + (happy_var_1 + )} + +happyReduce_500 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_500 = happyMonadReduce 3# 195# happyReduction_500 +happyReduction_500 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOut160 happy_x_2 of { (HappyWrap160 happy_var_2) -> + case happyOut213 happy_x_3 of { (HappyWrap213 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + do { let { l = comb2 happy_var_1 happy_var_3 } + ; r <- checkValDef l happy_var_1 (HsUnannotated EpPatBind, happy_var_2) happy_var_3; + -- Depending upon what the pattern looks like we might get either + -- a FunBind or PatBind back from checkValDef. See Note + -- [FunBind vs PatBind] + ; !cs <- getCommentsFor l + ; return $! (sL (commentsA l cs) $ ValD noExtField r) })}}}) + ) (\r -> happyReturn (happyIn211 r)) + +happyReduce_501 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_501 = happyMonadReduce 5# 195# happyReduction_501 +happyReduction_501 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + case happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> + case happyOut160 happy_x_4 of { (HappyWrap160 happy_var_4) -> + case happyOut213 happy_x_5 of { (HappyWrap213 happy_var_5) -> + ( runPV (unECP happy_var_3) >>= \ happy_var_3 -> + do { let { l = comb2 happy_var_1 happy_var_5 } + ; r <- checkValDef l happy_var_3 (mkMultAnn (epTok happy_var_1) happy_var_2 EpPatBind, happy_var_4) happy_var_5; + -- parses bindings of the form %p x or + -- %p x :: sig + -- + -- Depending upon what the pattern looks like we might get either + -- a FunBind or PatBind back from checkValDef. See Note + -- [FunBind vs PatBind] + ; !cs <- getCommentsFor l + ; return $! (sL (commentsA l cs) $ ValD noExtField r) })}}}}}) + ) (\r -> happyReturn (happyIn211 r)) + +happyReduce_502 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_502 = happySpecReduce_1 195# happyReduction_502 +happyReduction_502 happy_x_1 + = case happyOut119 happy_x_1 of { (HappyWrap119 happy_var_1) -> + happyIn211 + (happy_var_1 + )} + +happyReduce_503 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_503 = happySpecReduce_1 196# happyReduction_503 +happyReduction_503 happy_x_1 + = case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> + happyIn212 + (happy_var_1 + )} + +happyReduce_504 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_504 = happySpecReduce_1 196# happyReduction_504 +happyReduction_504 happy_x_1 + = case happyOut234 happy_x_1 of { (HappyWrap234 happy_var_1) -> + happyIn212 + (mkSpliceDecl happy_var_1 + )} + +happyReduce_505 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_505 = happyMonadReduce 3# 197# happyReduction_505 +happyReduction_505 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOut137 happy_x_3 of { (HappyWrap137 happy_var_3) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + do { let L l (bs, csw) = adaptWhereBinds happy_var_3 + ; let loc = (comb3 happy_var_1 happy_var_2 (L l bs)) + ; let locg = (comb2 happy_var_1 happy_var_2) + ; acs loc (\loc cs -> + sL loc (GRHSs csw (unguardedRHS (EpAnn (spanAsAnchor locg) (GrhsAnn Nothing (Left $ epTok happy_var_1)) cs) locg happy_var_2) + bs)) })}}}) + ) (\r -> happyReturn (happyIn213 r)) + +happyReduce_506 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_506 = happyMonadReduce 2# 197# happyReduction_506 +happyReduction_506 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> + case happyOut137 happy_x_2 of { (HappyWrap137 happy_var_2) -> + ( do { let {L l (bs, csw) = adaptWhereBinds happy_var_2} + ; acs (comb2 happy_var_1 (L l bs)) (\loc cs -> L loc + (GRHSs (cs Semi.<> csw) (NE.reverse (unLoc happy_var_1)) bs)) })}}) + ) (\r -> happyReturn (happyIn213 r)) + +happyReduce_507 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_507 = happySpecReduce_2 198# happyReduction_507 +happyReduction_507 happy_x_2 + happy_x_1 + = case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> + case happyOut215 happy_x_2 of { (HappyWrap215 happy_var_2) -> + happyIn214 + (sLL happy_var_1 happy_var_2 (happy_var_2 NE.<| unLoc happy_var_1) + )}} + +happyReduce_508 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_508 = happySpecReduce_1 198# happyReduction_508 +happyReduction_508 happy_x_1 + = case happyOut215 happy_x_1 of { (HappyWrap215 happy_var_1) -> + happyIn214 + (sL1 happy_var_1 (NE.singleton happy_var_1) + )} + +happyReduce_509 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_509 = happyMonadReduce 4# 199# happyReduction_509 +happyReduction_509 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut251 happy_x_2 of { (HappyWrap251 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> + acsA (comb2 happy_var_1 happy_var_4) (\loc cs -> L loc $ GRHS (EpAnn (glEE happy_var_1 happy_var_4) (GrhsAnn (Just $ epTok happy_var_1) (Left $ epTok happy_var_3)) cs) (unLoc happy_var_2) happy_var_4))}}}}) + ) (\r -> happyReturn (happyIn215 r)) + +happyReduce_510 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_510 = happyMonadReduce 3# 200# happyReduction_510 +happyReduction_510 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut163 happy_x_3 of { (HappyWrap163 happy_var_3) -> + ( do { happy_var_1 <- runPV (unECP happy_var_1) + ; v <- checkValSigLhs happy_var_1 + ; amsA' (sLL happy_var_1 happy_var_3 $ SigD noExtField $ + TypeSig (AnnSig (epUniTok happy_var_2) Nothing Nothing) [v] (mkHsWildCardBndrs happy_var_3))})}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_511 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_511 = happyMonadReduce 5# 200# happyReduction_511 +happyReduction_511 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut164 happy_x_3 of { (HappyWrap164 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut163 happy_x_5 of { (HappyWrap163 happy_var_5) -> + ( do { v <- addTrailingCommaN happy_var_1 (gl happy_var_2) + ; let sig = TypeSig (AnnSig (epUniTok happy_var_4) Nothing Nothing) (v : reverse (unLoc happy_var_3)) + (mkHsWildCardBndrs happy_var_5) + ; amsA' (sLL happy_var_1 happy_var_5 $ SigD noExtField sig ) })}}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_512 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_512 = happyMonadReduce 4# 200# happyReduction_512 +happyReduction_512 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut75 happy_x_1 of { (HappyWrap75 happy_var_1) -> + case happyOut74 happy_x_2 of { (HappyWrap74 happy_var_2) -> + case happyOut150 happy_x_3 of { (HappyWrap150 happy_var_3) -> + case happyOut76 happy_x_4 of { (HappyWrap76 happy_var_4) -> + ( do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 happy_var_4 + ; pure (glR l2) }) + happy_var_2 + ; let (fixText, fixPrec) = case happy_var_2 of + -- If an explicit precedence isn't supplied, + -- it defaults to maxPrecedence + Nothing -> (NoSourceText, maxPrecedence) + Just l2 -> (fst $ unLoc l2, snd $ unLoc l2) + ; amsA' (sLL happy_var_1 happy_var_4 $ SigD noExtField + (FixSig ((glR happy_var_1, mbPrecAnn), fixText) (FixitySig (unLoc happy_var_3) (fromOL $ unLoc happy_var_4) + (Fixity fixPrec (unLoc happy_var_1))))) + })}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_513 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_513 = happySpecReduce_1 200# happyReduction_513 +happyReduction_513 happy_x_1 + = case happyOut124 happy_x_1 of { (HappyWrap124 happy_var_1) -> + happyIn216 + (L (getLoc happy_var_1) . SigD noExtField . unLoc $ happy_var_1 + )} + +happyReduce_514 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_514 = happyMonadReduce 4# 200# happyReduction_514 +happyReduction_514 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut290 happy_x_2 of { (HappyWrap290 happy_var_2) -> + case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( let (dcolon, tc) = happy_var_3 + in amsA' (sLL happy_var_1 happy_var_4 + (SigD noExtField (CompleteMatchSig ((glR happy_var_1,dcolon,epTok happy_var_4), (getCOMPLETE_PRAGs happy_var_1)) happy_var_2 tc))))}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_515 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_515 = happyMonadReduce 4# 200# happyReduction_515 +happyReduction_515 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> + case happyOut125 happy_x_3 of { (HappyWrap125 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( amsA' (sLL happy_var_1 happy_var_4 $ SigD noExtField (InlineSig (glR happy_var_1, epTok happy_var_4, fst happy_var_2) happy_var_3 + (mkInlinePragma (getINLINE_PRAGs happy_var_1) (getINLINE happy_var_1) + (snd happy_var_2)))))}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_516 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_516 = happyMonadReduce 3# 200# happyReduction_516 +happyReduction_516 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ SigD noExtField (InlineSig (glR happy_var_1, epTok happy_var_3, noAnn) happy_var_2 + (mkOpaquePragma (getOPAQUE_PRAGs happy_var_1)))))}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_517 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_517 = happyMonadReduce 3# 200# happyReduction_517 +happyReduction_517 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 (SigD noExtField (SCCFunSig ((glR happy_var_1, epTok happy_var_3), (getSCC_PRAGs happy_var_1)) happy_var_2 Nothing))))}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_518 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_518 = happyMonadReduce 4# 200# happyReduction_518 +happyReduction_518 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( do { scc <- getSCC happy_var_3 + ; let str_lit = StringLiteral (getSTRINGs happy_var_3) scc Nothing + ; amsA' (sLL happy_var_1 happy_var_4 (SigD noExtField (SCCFunSig ((glR happy_var_1, epTok happy_var_4), (getSCC_PRAGs happy_var_1)) happy_var_2 (Just ( sL1a happy_var_3 str_lit))))) })}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_519 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_519 = happyMonadReduce 6# 200# happyReduction_519 +happyReduction_519 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> + case happyOut143 happy_x_3 of { (HappyWrap143 happy_var_3) -> + case happyOut224 happy_x_4 of { (HappyWrap224 happy_var_4) -> + case happyOut217 happy_x_5 of { (HappyWrap217 happy_var_5) -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> do + let inl_prag = mkInlinePragma (getSPEC_PRAGs happy_var_1) + (NoUserInlinePrag, FunLike) + (snd happy_var_2) + spec <- mkSpecSig inl_prag (AnnSpecSig (glR happy_var_1) (epTok happy_var_6) Nothing (fst happy_var_2)) happy_var_3 happy_var_4 happy_var_5 + amsA' $ sLL happy_var_1 happy_var_6 $ SigD noExtField spec)}}}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_520 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_520 = happyMonadReduce 6# 200# happyReduction_520 +happyReduction_520 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> + case happyOut143 happy_x_3 of { (HappyWrap143 happy_var_3) -> + case happyOut224 happy_x_4 of { (HappyWrap224 happy_var_4) -> + case happyOut217 happy_x_5 of { (HappyWrap217 happy_var_5) -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> do + let inl_prag = mkInlinePragma (getSPEC_INLINE_PRAGs happy_var_1) + (getSPEC_INLINE happy_var_1) + (snd happy_var_2) + spec <- mkSpecSig inl_prag (AnnSpecSig (glR happy_var_1) (epTok happy_var_6) Nothing (fst happy_var_2)) happy_var_3 happy_var_4 happy_var_5 + amsA' $ sLL happy_var_1 happy_var_6 $ SigD noExtField spec)}}}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_521 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_521 = happyMonadReduce 4# 200# happyReduction_521 +happyReduction_521 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut181 happy_x_3 of { (HappyWrap181 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( amsA' (sLL happy_var_1 happy_var_4 $ SigD noExtField (SpecInstSig ((glR happy_var_1,epTok happy_var_2,epTok happy_var_4), (getSPEC_PRAGs happy_var_1)) happy_var_3)))}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_522 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_522 = happyMonadReduce 3# 200# happyReduction_522 +happyReduction_522 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut279 happy_x_2 of { (HappyWrap279 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ SigD noExtField (MinimalSig ((glR happy_var_1,epTok happy_var_3), (getMINIMAL_PRAGs happy_var_1)) happy_var_2)))}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_523 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_523 = happySpecReduce_2 201# happyReduction_523 +happyReduction_523 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut165 happy_x_2 of { (HappyWrap165 happy_var_2) -> + happyIn217 + (Just (sLL happy_var_1 happy_var_2 (epUniTok happy_var_1, unLoc happy_var_2)) + )}} + +happyReduce_524 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_524 = happySpecReduce_0 201# happyReduction_524 +happyReduction_524 = happyIn217 + (Nothing + ) + +happyReduce_525 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_525 = happySpecReduce_0 202# happyReduction_525 +happyReduction_525 = happyIn218 + ((noAnn ,Nothing) + ) + +happyReduce_526 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_526 = happySpecReduce_1 202# happyReduction_526 +happyReduction_526 happy_x_1 + = case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> + happyIn218 + ((fst happy_var_1,Just (snd happy_var_1)) + )} + +happyReduce_527 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_527 = happySpecReduce_3 203# happyReduction_527 +happyReduction_527 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn219 + ((ActivationAnn (epTok happy_var_1) (epTok happy_var_3) Nothing (Just (glR happy_var_2)) + ,ActiveAfter (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2)))) + )}}} + +happyReduce_528 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_528 = happyReduce 4# 203# happyReduction_528 +happyReduction_528 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut141 happy_x_2 of { (HappyWrap141 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn219 + ((ActivationAnn (epTok happy_var_1) (epTok happy_var_4) happy_var_2 (Just (glR happy_var_3)) + ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3)))) + ) `HappyStk` happyRest}}}} + +happyReduce_529 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_529 = happySpecReduce_1 204# happyReduction_529 +happyReduction_529 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn220 + (let { loc = getLoc happy_var_1 + ; ITquasiQuote (quoter, quoterSpan, quote, quoteSpan) = unLoc happy_var_1 + ; quoterId = L (noAnnSrcSpan (mkSrcSpanPs quoterSpan)) (mkUnqual varName quoter) } + in sL1 happy_var_1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) + )} + +happyReduce_530 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_530 = happySpecReduce_1 204# happyReduction_530 +happyReduction_530 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn220 + (let { loc = getLoc happy_var_1 + ; ITqQuasiQuote (qual, quoter, quoterSpan, quote, quoteSpan) = unLoc happy_var_1 + ; quoterId = L (noAnnSrcSpan (mkSrcSpanPs quoterSpan)) (mkQual varName (qual, quoter)) } + in sL1 happy_var_1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) + )} + +happyReduce_531 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_531 = happySpecReduce_1 205# happyReduction_531 +happyReduction_531 happy_x_1 + = case happyOut340 happy_x_1 of { (HappyWrap340 happy_var_1) -> + happyIn221 + (happy_var_1 + )} + +happyReduce_532 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_532 = happySpecReduce_1 206# happyReduction_532 +happyReduction_532 happy_x_1 + = case happyOut341 happy_x_1 of { (HappyWrap341 happy_var_1) -> + happyIn222 + (happy_var_1 + )} + +happyReduce_533 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_533 = happySpecReduce_1 207# happyReduction_533 +happyReduction_533 happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + happyIn223 + (happy_var_1 + )} + +happyReduce_534 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_534 = happySpecReduce_3 207# happyReduction_534 +happyReduction_534 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut223 happy_x_3 of { (HappyWrap223 happy_var_3) -> + happyIn223 + (ECP $ + withArrowParsingMode' $ \mode -> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + let arr = HsUnannotated (EpArrow (epUniTok happy_var_2)) + in mkHsArrowPV (comb2 happy_var_1 happy_var_3) mode happy_var_1 arr happy_var_3 + )}}} + +happyReduce_535 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_535 = happyReduce 4# 207# happyReduction_535 +happyReduction_535 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut223 happy_x_4 of { (HappyWrap223 happy_var_4) -> + happyIn223 + (ECP $ + unECP happy_var_1 >>= \ happy_var_1 -> + happy_var_2 >>= \ happy_var_2 -> + unECP happy_var_4 >>= \ happy_var_4 -> + hintLinear (getLoc happy_var_2) >> + let arr = (unLoc happy_var_2) (epUniTok happy_var_3) + in mkHsArrowPV (comb2 happy_var_1 happy_var_4) ArrowIsFunType happy_var_1 arr happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_536 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_536 = happySpecReduce_3 207# happyReduction_536 +happyReduction_536 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut223 happy_x_3 of { (HappyWrap223 happy_var_3) -> + happyIn223 + (ECP $ + hintLinear (getLoc happy_var_2) >> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + let arr = HsLinearAnn (EpLolly (epTok happy_var_2)) + in mkHsArrowPV (comb2 happy_var_1 happy_var_3) ArrowIsFunType happy_var_1 arr happy_var_3 + )}}} + +happyReduce_537 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_537 = happySpecReduce_3 207# happyReduction_537 +happyReduction_537 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut171 happy_x_1 of { (HappyWrap171 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut223 happy_x_3 of { (HappyWrap223 happy_var_3) -> + happyIn223 + (ECP $ + happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + mkQualPV (comb2 happy_var_1 happy_var_3) (addTrailingDarrowC happy_var_1 happy_var_2 emptyComments) happy_var_3 + )}}} + +happyReduce_538 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_538 = happySpecReduce_2 207# happyReduction_538 +happyReduction_538 happy_x_2 + happy_x_1 + = case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> + case happyOut223 happy_x_2 of { (HappyWrap223 happy_var_2) -> + happyIn223 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsForallPV (comb2 happy_var_1 happy_var_2) (unLoc happy_var_1) happy_var_2 + )}} + +happyReduce_539 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_539 = happySpecReduce_1 208# happyReduction_539 +happyReduction_539 happy_x_1 + = case happyOut226 happy_x_1 of { (HappyWrap226 happy_var_1) -> + happyIn224 + (happy_var_1 + )} + +happyReduce_540 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_540 = happySpecReduce_3 208# happyReduction_540 +happyReduction_540 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOut308 happy_x_2 of { (HappyWrap308 happy_var_2) -> + case happyOut225 happy_x_3 of { (HappyWrap225 happy_var_3) -> + happyIn224 + (ECP $ + superInfixOp $ + happy_var_2 >>= \ happy_var_2 -> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + rejectPragmaPV happy_var_1 >> + (mkHsOpAppPV (comb2 happy_var_1 happy_var_3) happy_var_1 happy_var_2 happy_var_3) + )}}} + +happyReduce_541 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_541 = happySpecReduce_1 209# happyReduction_541 +happyReduction_541 happy_x_1 + = case happyOut226 happy_x_1 of { (HappyWrap226 happy_var_1) -> + happyIn225 + (happy_var_1 + )} + +happyReduce_542 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_542 = happySpecReduce_1 209# happyReduction_542 +happyReduction_542 happy_x_1 + = case happyOut342 happy_x_1 of { (HappyWrap342 happy_var_1) -> + happyIn225 + (happy_var_1 + )} + +happyReduce_543 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_543 = happySpecReduce_2 210# happyReduction_543 +happyReduction_543 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut229 happy_x_2 of { (HappyWrap229 happy_var_2) -> + happyIn226 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsNegAppPV (comb2 happy_var_1 happy_var_2) happy_var_2 + (epTok happy_var_1) + )}} + +happyReduce_544 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_544 = happySpecReduce_1 210# happyReduction_544 +happyReduction_544 happy_x_1 + = case happyOut229 happy_x_1 of { (HappyWrap229 happy_var_1) -> + happyIn226 + (happy_var_1 + )} + +happyReduce_545 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_545 = happySpecReduce_1 211# happyReduction_545 +happyReduction_545 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn227 + ((msemim happy_var_1,True) + )} + +happyReduce_546 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_546 = happySpecReduce_0 211# happyReduction_546 +happyReduction_546 = happyIn227 + ((Nothing,False) + ) + +happyReduce_547 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_547 = happyMonadReduce 3# 212# happyReduction_547 +happyReduction_547 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { scc <- getSCC happy_var_2 + ; return (sLL happy_var_1 happy_var_3 + (HsPragSCC + (AnnPragma (glR happy_var_1) (epTok happy_var_3) noAnn (glR happy_var_2) noAnn noAnn noAnn, + (getSCC_PRAGs happy_var_1)) + (StringLiteral (getSTRINGs happy_var_2) scc Nothing)))})}}}) + ) (\r -> happyReturn (happyIn228 r)) + +happyReduce_548 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_548 = happySpecReduce_3 212# happyReduction_548 +happyReduction_548 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn228 + (sLL happy_var_1 happy_var_3 + (HsPragSCC + (AnnPragma (glR happy_var_1) (epTok happy_var_3) noAnn (glR happy_var_2) noAnn noAnn noAnn, + (getSCC_PRAGs happy_var_1)) + (StringLiteral NoSourceText (getVARID happy_var_2) Nothing)) + )}}} + +happyReduce_549 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_549 = happySpecReduce_2 213# happyReduction_549 +happyReduction_549 happy_x_2 + happy_x_1 + = case happyOut229 happy_x_1 of { (HappyWrap229 happy_var_1) -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + happyIn229 + (ECP $ + superFunArg $ + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_2 >>= \ happy_var_2 -> + spanWithComments (comb2 happy_var_1 happy_var_2) >>= \l -> + mkHsAppPV l happy_var_1 happy_var_2 + )}} + +happyReduce_550 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_550 = happySpecReduce_3 213# happyReduction_550 +happyReduction_550 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut229 happy_x_1 of { (HappyWrap229 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut180 happy_x_3 of { (HappyWrap180 happy_var_3) -> + happyIn229 + (ECP $ + unECP happy_var_1 >>= \ happy_var_1 -> + mkHsAppTypePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) happy_var_1 (epTok happy_var_2) happy_var_3 + )}}} + +happyReduce_551 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_551 = happyMonadReduce 2# 213# happyReduction_551 +happyReduction_551 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_2 $ HsStatic (epTok happy_var_1) happy_var_2))}}) + ) (\r -> happyReturn (happyIn229 r)) + +happyReduce_552 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_552 = happySpecReduce_1 213# happyReduction_552 +happyReduction_552 happy_x_1 + = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> + happyIn229 + (happy_var_1 + )} + +happyReduce_553 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_553 = happySpecReduce_3 214# happyReduction_553 +happyReduction_553 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> + happyIn230 + (ECP $ + unECP happy_var_3 >>= \ happy_var_3 -> + mkHsAsPatPV (comb2 happy_var_1 happy_var_3) happy_var_1 (epTok happy_var_2) happy_var_3 + )}}} + +happyReduce_554 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_554 = happySpecReduce_2 214# happyReduction_554 +happyReduction_554 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + happyIn230 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsLazyPatPV (comb2 happy_var_1 happy_var_2) happy_var_2 (epTok happy_var_1) + )}} + +happyReduce_555 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_555 = happySpecReduce_2 214# happyReduction_555 +happyReduction_555 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + happyIn230 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsBangPatPV (comb2 happy_var_1 happy_var_2) happy_var_2 (epTok happy_var_1) + )}} + +happyReduce_556 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_556 = happySpecReduce_2 214# happyReduction_556 +happyReduction_556 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + happyIn230 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsNegAppPV (comb2 happy_var_1 happy_var_2) happy_var_2 (epTok happy_var_1) + )}} + +happyReduce_557 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_557 = happyReduce 4# 214# happyReduction_557 +happyReduction_557 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut136 happy_x_2 of { (HappyWrap136 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + happyIn230 + (ECP $ + unECP happy_var_4 >>= \ happy_var_4 -> + mkHsLetPV (comb2 happy_var_1 happy_var_4) (epTok happy_var_1) (unLoc happy_var_2) (epTok happy_var_3) happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_558 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_558 = happyReduce 4# 214# happyReduction_558 +happyReduction_558 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut263 happy_x_2 of { (HappyWrap263 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + happyIn230 + (ECP $ + unECP happy_var_4 >>= \ happy_var_4 -> + mkHsLamPV (comb2 happy_var_1 happy_var_4) LamSingle + (sLLld happy_var_1 happy_var_4 + [sLLa happy_var_1 happy_var_4 + $ Match { m_ext = noExtField + , m_ctxt = LamAlt LamSingle + , m_pats = L (listLocation happy_var_2) happy_var_2 + , m_grhss = unguardedGRHSs (comb2 happy_var_3 happy_var_4) happy_var_4 (EpAnn (glR happy_var_3) (GrhsAnn Nothing (Right $ epUniTok happy_var_3)) emptyComments) }]) + (EpAnnLam (epTok happy_var_1) Nothing) + ) `HappyStk` happyRest}}}} + +happyReduce_559 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_559 = happySpecReduce_3 214# happyReduction_559 +happyReduction_559 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut339 happy_x_3 of { (HappyWrap339 happy_var_3) -> + happyIn230 + (ECP $ happy_var_3 >>= \ happy_var_3 -> + mkHsLamPV (comb3 happy_var_1 happy_var_2 happy_var_3) LamCase happy_var_3 (EpAnnLam (epTok happy_var_1) (Just (glR happy_var_2))) + )}}} + +happyReduce_560 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_560 = happySpecReduce_3 214# happyReduction_560 +happyReduction_560 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut338 happy_x_3 of { (HappyWrap338 happy_var_3) -> + happyIn230 + (ECP $ happy_var_3 >>= \ happy_var_3 -> + mkHsLamPV (comb3 happy_var_1 happy_var_2 happy_var_3) LamCases happy_var_3 (EpAnnLam (epTok happy_var_1) (Just (glR happy_var_2))) + )}}} + +happyReduce_561 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_561 = happyMonadReduce 8# 214# happyReduction_561 +happyReduction_561 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOut227 happy_x_3 of { (HappyWrap227 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut221 happy_x_5 of { (HappyWrap221 happy_var_5) -> + case happyOut227 happy_x_6 of { (HappyWrap227 happy_var_6) -> + case happyOutTok happy_x_7 of { happy_var_7 -> + case happyOut221 happy_x_8 of { (HappyWrap221 happy_var_8) -> + ( runPV (unECP happy_var_2) >>= \ (happy_var_2 :: LHsExpr GhcPs) -> + return $ ECP $ + unECP happy_var_5 >>= \ happy_var_5 -> + unECP happy_var_8 >>= \ happy_var_8 -> + mkHsIfPV (comb2 happy_var_1 happy_var_8) happy_var_2 (snd happy_var_3) happy_var_5 (snd happy_var_6) happy_var_8 + (AnnsIf + { aiIf = epTok happy_var_1 + , aiThen = epTok happy_var_4 + , aiElse = epTok happy_var_7 + , aiThenSemi = fst happy_var_3 + , aiElseSemi = fst happy_var_6}))}}}}}}}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_562 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_562 = happyMonadReduce 2# 214# happyReduction_562 +happyReduction_562 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut256 happy_x_2 of { (HappyWrap256 happy_var_2) -> + ( hintMultiWayIf (getLoc happy_var_1) >>= \_ -> + fmap ecpFromExp $ + do { let (L _ ((o,c),_)) = happy_var_2 + ; amsA' (sLL happy_var_1 happy_var_2 $ HsMultiIf (epTok happy_var_1, o, c) + (NE.reverse $ snd $ unLoc happy_var_2)) })}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_563 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_563 = happyMonadReduce 4# 214# happyReduction_563 +happyReduction_563 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut339 happy_x_4 of { (HappyWrap339 happy_var_4) -> + ( runPV (unECP happy_var_2) >>= \ (happy_var_2 :: LHsExpr GhcPs) -> + return $ ECP $ + happy_var_4 >>= \ happy_var_4 -> + mkHsCasePV (comb3 happy_var_1 happy_var_3 happy_var_4) happy_var_2 happy_var_4 + (EpAnnHsCase (epTok happy_var_1) (epTok happy_var_3)))}}}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_564 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_564 = happyMonadReduce 2# 214# happyReduction_564 +happyReduction_564 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut265 happy_x_2 of { (HappyWrap265 happy_var_2) -> + ( do + hintQualifiedDo happy_var_1 + return $ ECP $ + happy_var_2 >>= \ happy_var_2 -> + mkHsDoPV (comb2 happy_var_1 happy_var_2) + (fmap mkModuleNameFS (getDO happy_var_1)) + happy_var_2 + (glR happy_var_1) + (glR happy_var_2))}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_565 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_565 = happyMonadReduce 2# 214# happyReduction_565 +happyReduction_565 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut265 happy_x_2 of { (HappyWrap265 happy_var_2) -> + ( hintQualifiedDo happy_var_1 >> runPV happy_var_2 >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' (L (comb2 happy_var_1 happy_var_2) + (mkMDo (MDoExpr $ fmap mkModuleNameFS (getMDO happy_var_1)) + happy_var_2 + (glR happy_var_1) + (glR happy_var_2))))}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_566 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_566 = happyMonadReduce 4# 214# happyReduction_566 +happyReduction_566 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + ( (checkPattern <=< runPV) (unECP happy_var_2) >>= \ p -> + runPV (unECP happy_var_4) >>= \ happy_var_4@cmd -> + fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_4 $HsProc (epTok happy_var_1, epUniTok happy_var_3) p (sLLa happy_var_1 happy_var_4 $ HsCmdTop noExtField cmd)))}}}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_567 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_567 = happySpecReduce_1 214# happyReduction_567 +happyReduction_567 happy_x_1 + = case happyOut231 happy_x_1 of { (HappyWrap231 happy_var_1) -> + happyIn230 + (happy_var_1 + )} + +happyReduce_568 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_568 = happyReduce 4# 215# happyReduction_568 +happyReduction_568 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut231 happy_x_1 of { (HappyWrap231 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut271 happy_x_3 of { (HappyWrap271 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn231 + (ECP $ + getBit OverloadedRecordUpdateBit >>= \ overloaded -> + unECP happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> + mkHsRecordPV overloaded (comb2 happy_var_1 happy_var_4) (comb2 happy_var_2 happy_var_4) happy_var_1 happy_var_3 + (Just (epTok happy_var_2), Just (epTok happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_569 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_569 = happyMonadReduce 3# 215# happyReduction_569 +happyReduction_569 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut231 happy_x_1 of { (HappyWrap231 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut318 happy_x_3 of { (HappyWrap318 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + fmap ecpFromExp $ amsA' ( + let fl = sLLa happy_var_2 happy_var_3 (DotFieldOcc (AnnFieldLabel (Just $ epTok happy_var_2)) happy_var_3) in + sLL happy_var_1 happy_var_3 $ mkRdrGetField happy_var_1 fl))}}}) + ) (\r -> happyReturn (happyIn231 r)) + +happyReduce_570 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_570 = happySpecReduce_1 215# happyReduction_570 +happyReduction_570 happy_x_1 + = case happyOut232 happy_x_1 of { (HappyWrap232 happy_var_1) -> + happyIn231 + (happy_var_1 + )} + +happyReduce_571 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_571 = happySpecReduce_1 216# happyReduction_571 +happyReduction_571 happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + happyIn232 + (ECP $ mkHsVarPV $! happy_var_1 + )} + +happyReduce_572 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_572 = happySpecReduce_1 216# happyReduction_572 +happyReduction_572 happy_x_1 + = case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> + happyIn232 + (ECP $ mkHsVarPV $! happy_var_1 + )} + +happyReduce_573 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_573 = happyMonadReduce 1# 216# happyReduction_573 +happyReduction_573 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut277 happy_x_1 of { (HappyWrap277 happy_var_1) -> + ( fmap ecpFromExp + (ams1 happy_var_1 (HsIPVar NoExtField $! unLoc happy_var_1)))}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_574 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_574 = happyMonadReduce 1# 216# happyReduction_574 +happyReduction_574 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut278 happy_x_1 of { (HappyWrap278 happy_var_1) -> + ( fmap ecpFromExp + (ams1 happy_var_1 (HsOverLabel (fst $! unLoc happy_var_1) (snd $! unLoc happy_var_1))))}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_575 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_575 = happySpecReduce_1 216# happyReduction_575 +happyReduction_575 happy_x_1 + = case happyOut332 happy_x_1 of { (HappyWrap332 happy_var_1) -> + happyIn232 + (ECP $ mkHsLitPV $! happy_var_1 + )} + +happyReduce_576 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_576 = happySpecReduce_1 216# happyReduction_576 +happyReduction_576 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn232 + (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsIntegral (getINTEGER happy_var_1)) + )} + +happyReduce_577 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_577 = happySpecReduce_1 216# happyReduction_577 +happyReduction_577 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn232 + (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsFractional (getRATIONAL happy_var_1)) + )} + +happyReduce_578 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_578 = happySpecReduce_3 216# happyReduction_578 +happyReduction_578 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut241 happy_x_2 of { (HappyWrap241 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsParPV (comb2 happy_var_1 happy_var_3) (epTok happy_var_1) happy_var_2 (epTok happy_var_3) + )}}} + +happyReduce_579 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_579 = happySpecReduce_3 216# happyReduction_579 +happyReduction_579 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut242 happy_x_2 of { (HappyWrap242 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ + happy_var_2 >>= \ happy_var_2 -> + mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Boxed happy_var_2 + (glR happy_var_1,glR happy_var_3) + )}}} + +happyReduce_580 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_580 = happyMonadReduce 3# 216# happyReduction_580 +happyReduction_580 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut344 happy_x_2 of { (HappyWrap344 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do + { pat <- hintOrPats (sL1a happy_var_2 (OrPat NoExtField (unLoc happy_var_2))) + ; fmap ecpFromPat + (amsA' (sLL happy_var_1 happy_var_3 (ParPat (epTok happy_var_1, epTok happy_var_3) pat))) })}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_581 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_581 = happySpecReduce_3 216# happyReduction_581 +happyReduction_581 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut233 happy_x_2 of { (HappyWrap233 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ + amsA' (sLL happy_var_1 happy_var_3 $ mkRdrProjection (NE.reverse (unLoc happy_var_2)) (AnnProjection (epTok happy_var_1) (epTok happy_var_3)) ) + >>= ecpFromExp' + )}}} + +happyReduce_582 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_582 = happySpecReduce_3 216# happyReduction_582 +happyReduction_582 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut241 happy_x_2 of { (HappyWrap241 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Unboxed (Tuple [Right happy_var_2]) + (glR happy_var_1,glR happy_var_3) + )}}} + +happyReduce_583 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_583 = happySpecReduce_3 216# happyReduction_583 +happyReduction_583 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut242 happy_x_2 of { (HappyWrap242 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ + happy_var_2 >>= \ happy_var_2 -> + mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Unboxed happy_var_2 + (glR happy_var_1,glR happy_var_3) + )}}} + +happyReduce_584 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_584 = happySpecReduce_3 216# happyReduction_584 +happyReduction_584 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut245 happy_x_2 of { (HappyWrap245 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ happy_var_2 (comb2 happy_var_1 happy_var_3) (glR happy_var_1,glR happy_var_3) + )}}} + +happyReduce_585 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_585 = happySpecReduce_1 216# happyReduction_585 +happyReduction_585 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn232 + (ECP $ mkHsWildCardPV (getLoc happy_var_1) + )} + +happyReduce_586 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_586 = happySpecReduce_1 216# happyReduction_586 +happyReduction_586 happy_x_1 + = case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> + happyIn232 + (ECP $ mkHsSplicePV happy_var_1 + )} + +happyReduce_587 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_587 = happySpecReduce_1 216# happyReduction_587 +happyReduction_587 happy_x_1 + = case happyOut236 happy_x_1 of { (HappyWrap236 happy_var_1) -> + happyIn232 + (ecpFromExp $ fmap (HsTypedSplice noExtField) (reLoc happy_var_1) + )} + +happyReduce_588 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_588 = happyMonadReduce 2# 216# happyReduction_588 +happyReduction_588 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> + ( fmap ecpFromExp $ amsA' (sLL happy_var_1 happy_var_2 $ HsUntypedBracket noExtField (VarBr (glR happy_var_1) True happy_var_2)))}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_589 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_589 = happyMonadReduce 2# 216# happyReduction_589 +happyReduction_589 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut286 happy_x_2 of { (HappyWrap286 happy_var_2) -> + ( fmap ecpFromExp $ amsA' (sLL happy_var_1 happy_var_2 $ HsUntypedBracket noExtField (VarBr (glR happy_var_1) True happy_var_2)))}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_590 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_590 = happyMonadReduce 2# 216# happyReduction_590 +happyReduction_590 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut313 happy_x_2 of { (HappyWrap313 happy_var_2) -> + ( fmap ecpFromExp $ amsA' (sLL happy_var_1 happy_var_2 $ HsUntypedBracket noExtField (VarBr (glR happy_var_1) False happy_var_2)))}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_591 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_591 = happyMonadReduce 2# 216# happyReduction_591 +happyReduction_591 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut296 happy_x_2 of { (HappyWrap296 happy_var_2) -> + ( fmap ecpFromExp $ amsA' (sLL happy_var_1 happy_var_2 $ HsUntypedBracket noExtField (VarBr (glR happy_var_1) False happy_var_2)))}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_592 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_592 = happyMonadReduce 1# 216# happyReduction_592 +happyReduction_592 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( reportEmptyDoubleQuotes (getLoc happy_var_1))}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_593 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_593 = happyMonadReduce 3# 216# happyReduction_593 +happyReduction_593 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_3 $ HsUntypedBracket noExtField (ExpBr (if (hasE happy_var_1) then (BracketHasE (epTok happy_var_1), epUniTok happy_var_3) + else (BracketNoE (epUniTok happy_var_1), epUniTok happy_var_3)) happy_var_2)))}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_594 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_594 = happyMonadReduce 3# 216# happyReduction_594 +happyReduction_594 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_3 $ HsTypedBracket (if (hasE happy_var_1) then (BracketHasE (epTok happy_var_1),epTok happy_var_3) else (BracketNoE (epTok happy_var_1),epTok happy_var_3)) happy_var_2))}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_595 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_595 = happyMonadReduce 3# 216# happyReduction_595 +happyReduction_595 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_3 $ HsUntypedBracket noExtField (TypBr (epTok happy_var_1,epUniTok happy_var_3) happy_var_2)))}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_596 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_596 = happyMonadReduce 3# 216# happyReduction_596 +happyReduction_596 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( (checkPattern <=< runPV) (unECP happy_var_2) >>= \p -> + fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_3 $ HsUntypedBracket noExtField (PatBr (epTok happy_var_1,epUniTok happy_var_3) p)))}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_597 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_597 = happyMonadReduce 3# 216# happyReduction_597 +happyReduction_597 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut239 happy_x_2 of { (HappyWrap239 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_3 $ HsUntypedBracket noExtField (DecBrL (epTok happy_var_1,epUniTok happy_var_3, fst happy_var_2) (snd happy_var_2))))}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_598 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_598 = happySpecReduce_1 216# happyReduction_598 +happyReduction_598 happy_x_1 + = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> + happyIn232 + (ECP $ mkHsSplicePV happy_var_1 + )} + +happyReduce_599 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_599 = happyMonadReduce 4# 216# happyReduction_599 +happyReduction_599 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + case happyOut237 happy_x_3 of { (HappyWrap237 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_4 $ HsCmdArrForm (AnnList (glRM happy_var_1) (ListBanana (epUniTok happy_var_1) (epUniTok happy_var_4)) [] noAnn []) happy_var_2 Prefix + (reverse happy_var_3)))}}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_600 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_600 = happySpecReduce_3 217# happyReduction_600 +happyReduction_600 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut233 happy_x_1 of { (HappyWrap233 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut318 happy_x_3 of { (HappyWrap318 happy_var_3) -> + happyIn233 + (sLL happy_var_1 happy_var_3 ((sLLa happy_var_2 happy_var_3 $ DotFieldOcc (AnnFieldLabel (Just $ epTok happy_var_2)) happy_var_3) `NE.cons` unLoc happy_var_1) + )}}} + +happyReduce_601 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_601 = happySpecReduce_2 217# happyReduction_601 +happyReduction_601 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut318 happy_x_2 of { (HappyWrap318 happy_var_2) -> + happyIn233 + (sLL happy_var_1 happy_var_2 ((sLLa happy_var_1 happy_var_2 $ DotFieldOcc (AnnFieldLabel (Just $ epTok happy_var_1)) happy_var_2) :| []) + )}} + +happyReduce_602 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_602 = happySpecReduce_1 218# happyReduction_602 +happyReduction_602 happy_x_1 + = case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> + happyIn234 + (fmap (HsUntypedSplice noExtField) (reLoc happy_var_1) + )} + +happyReduce_603 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_603 = happySpecReduce_1 218# happyReduction_603 +happyReduction_603 happy_x_1 + = case happyOut236 happy_x_1 of { (HappyWrap236 happy_var_1) -> + happyIn234 + (fmap (HsTypedSplice noExtField) (reLoc happy_var_1) + )} + +happyReduce_604 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_604 = happyMonadReduce 2# 219# happyReduction_604 +happyReduction_604 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut232 happy_x_2 of { (HappyWrap232 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + return (sLL happy_var_1 happy_var_2 $ HsUntypedSpliceExpr (epTok happy_var_1) happy_var_2))}}) + ) (\r -> happyReturn (happyIn235 r)) + +happyReduce_605 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_605 = happyMonadReduce 2# 220# happyReduction_605 +happyReduction_605 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut232 happy_x_2 of { (HappyWrap232 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + return (sLL happy_var_1 happy_var_2 $ (HsTypedSpliceExpr (epTok happy_var_1) happy_var_2)))}}) + ) (\r -> happyReturn (happyIn236 r)) + +happyReduce_606 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_606 = happySpecReduce_2 221# happyReduction_606 +happyReduction_606 happy_x_2 + happy_x_1 + = case happyOut237 happy_x_1 of { (HappyWrap237 happy_var_1) -> + case happyOut238 happy_x_2 of { (HappyWrap238 happy_var_2) -> + happyIn237 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_607 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_607 = happySpecReduce_0 221# happyReduction_607 +happyReduction_607 = happyIn237 + ([] + ) + +happyReduce_608 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_608 = happyMonadReduce 1# 222# happyReduction_608 +happyReduction_608 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> + ( runPV (unECP happy_var_1) >>= \ (cmd :: LHsCmd GhcPs) -> + runPV (checkCmdBlockArguments cmd) >>= \ _ -> + return (sL1a cmd $ HsCmdTop noExtField cmd))}) + ) (\r -> happyReturn (happyIn238 r)) + +happyReduce_609 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_609 = happySpecReduce_3 223# happyReduction_609 +happyReduction_609 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut240 happy_x_2 of { (HappyWrap240 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn239 + (((epTok happy_var_1 ,epTok happy_var_3),happy_var_2) + )}}} + +happyReduce_610 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_610 = happySpecReduce_3 223# happyReduction_610 +happyReduction_610 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut240 happy_x_2 of { (HappyWrap240 happy_var_2) -> + happyIn239 + (((NoEpTok, NoEpTok),happy_var_2) + )} + +happyReduce_611 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_611 = happySpecReduce_1 224# happyReduction_611 +happyReduction_611 happy_x_1 + = case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> + happyIn240 + (cvTopDecls happy_var_1 + )} + +happyReduce_612 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_612 = happySpecReduce_1 224# happyReduction_612 +happyReduction_612 happy_x_1 + = case happyOut77 happy_x_1 of { (HappyWrap77 happy_var_1) -> + happyIn240 + (cvTopDecls happy_var_1 + )} + +happyReduce_613 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_613 = happySpecReduce_1 225# happyReduction_613 +happyReduction_613 happy_x_1 + = case happyOut222 happy_x_1 of { (HappyWrap222 happy_var_1) -> + happyIn241 + (happy_var_1 + )} + +happyReduce_614 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_614 = happyMonadReduce 2# 225# happyReduction_614 +happyReduction_614 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOut308 happy_x_2 of { (HappyWrap308 happy_var_2) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (rejectPragmaPV happy_var_1) >> + runPV happy_var_2 >>= \ happy_var_2 -> + return $ ecpFromExp $ + sLLa happy_var_1 happy_var_2 $ SectionL noExtField happy_var_1 (n2l happy_var_2))}}) + ) (\r -> happyReturn (happyIn241 r)) + +happyReduce_615 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_615 = happySpecReduce_2 225# happyReduction_615 +happyReduction_615 happy_x_2 + happy_x_1 + = case happyOut309 happy_x_1 of { (HappyWrap309 happy_var_1) -> + case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> + happyIn241 + (ECP $ + superInfixOp $ + unECP happy_var_2 >>= \ happy_var_2 -> + happy_var_1 >>= \ happy_var_1 -> + mkHsSectionR_PV (comb2 happy_var_1 happy_var_2) (n2l happy_var_1) happy_var_2 + )}} + +happyReduce_616 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_616 = happySpecReduce_2 226# happyReduction_616 +happyReduction_616 happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOut243 happy_x_2 of { (HappyWrap243 happy_var_2) -> + happyIn242 + (unECP happy_var_1 >>= \ happy_var_1 -> + happy_var_2 >>= \ happy_var_2 -> + do { t <- amsA happy_var_1 [AddCommaAnn (EpTok $ srcSpan2e $ fst happy_var_2)] + ; return (Tuple (Right t : snd happy_var_2)) } + )}} + +happyReduce_617 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_617 = happySpecReduce_2 226# happyReduction_617 +happyReduction_617 happy_x_2 + happy_x_1 + = case happyOut335 happy_x_1 of { (HappyWrap335 happy_var_1) -> + case happyOut244 happy_x_2 of { (HappyWrap244 happy_var_2) -> + happyIn242 + (happy_var_2 >>= \ happy_var_2 -> + do { let {cos = NE.map (\ll -> (Left (EpAnn (spanAsAnchor ll) True emptyComments))) (fst happy_var_1) } + ; return (Tuple (toList cos ++ happy_var_2)) } + )}} + +happyReduce_618 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_618 = happySpecReduce_2 226# happyReduction_618 +happyReduction_618 happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOut337 happy_x_2 of { (HappyWrap337 happy_var_2) -> + happyIn242 + (unECP happy_var_1 >>= \ happy_var_1 -> return $ + (Sum 1 (snd happy_var_2 + 1) happy_var_1 [] (fst happy_var_2)) + )}} + +happyReduce_619 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_619 = happySpecReduce_3 226# happyReduction_619 +happyReduction_619 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut337 happy_x_1 of { (HappyWrap337 happy_var_1) -> + case happyOut241 happy_x_2 of { (HappyWrap241 happy_var_2) -> + case happyOut336 happy_x_3 of { (HappyWrap336 happy_var_3) -> + happyIn242 + (unECP happy_var_2 >>= \ happy_var_2 -> return $ + (Sum (snd happy_var_1 + 1) (snd happy_var_1 + snd happy_var_3 + 1) happy_var_2 (fst happy_var_1) (fst happy_var_3)) + )}}} + +happyReduce_620 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_620 = happySpecReduce_2 227# happyReduction_620 +happyReduction_620 happy_x_2 + happy_x_1 + = case happyOut335 happy_x_1 of { (HappyWrap335 happy_var_1) -> + case happyOut244 happy_x_2 of { (HappyWrap244 happy_var_2) -> + happyIn243 + (happy_var_2 >>= \ happy_var_2 -> + do { let {cos = map (\l -> (Left (EpAnn (spanAsAnchor l) True emptyComments))) (tail $ fst happy_var_1) } + ; return ((head $ fst happy_var_1, cos ++ happy_var_2)) } + )}} + +happyReduce_621 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_621 = happySpecReduce_2 228# happyReduction_621 +happyReduction_621 happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOut243 happy_x_2 of { (HappyWrap243 happy_var_2) -> + happyIn244 + (unECP happy_var_1 >>= \ happy_var_1 -> + happy_var_2 >>= \ happy_var_2 -> + do { t <- amsA happy_var_1 [AddCommaAnn (EpTok $ srcSpan2e $ fst happy_var_2)] + ; return (Right t : snd happy_var_2) } + )}} + +happyReduce_622 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_622 = happySpecReduce_1 228# happyReduction_622 +happyReduction_622 happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + happyIn244 + (unECP happy_var_1 >>= \ happy_var_1 -> + return [Right happy_var_1] + )} + +happyReduce_623 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_623 = happySpecReduce_0 228# happyReduction_623 +happyReduction_623 = happyIn244 + (return [Left noAnn] + ) + +happyReduce_624 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_624 = happySpecReduce_1 229# happyReduction_624 +happyReduction_624 happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + happyIn245 + (\loc (ao,ac) -> unECP happy_var_1 >>= \ happy_var_1 -> + mkHsExplicitListPV loc [happy_var_1] (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] noAnn []) + )} + +happyReduce_625 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_625 = happySpecReduce_1 229# happyReduction_625 +happyReduction_625 happy_x_1 + = case happyOut246 happy_x_1 of { (HappyWrap246 happy_var_1) -> + happyIn245 + (\loc (ao,ac) -> happy_var_1 >>= \ happy_var_1 -> + mkHsExplicitListPV loc (reverse happy_var_1) (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] noAnn []) + )} + +happyReduce_626 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_626 = happySpecReduce_2 229# happyReduction_626 +happyReduction_626 happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn245 + (\loc (ao,ac) -> unECP happy_var_1 >>= \ happy_var_1 -> + amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) Nothing (epTok happy_var_2) (EpTok ac)) Nothing (From happy_var_1)) + >>= ecpFromExp' + )}} + +happyReduce_627 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_627 = happyReduce 4# 229# happyReduction_627 +happyReduction_627 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut222 happy_x_3 of { (HappyWrap222 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn245 + (\loc (ao,ac) -> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) (Just (epTok happy_var_2)) (epTok happy_var_4) (EpTok ac)) Nothing (FromThen happy_var_1 happy_var_3)) + >>= ecpFromExp' + ) `HappyStk` happyRest}}}} + +happyReduce_628 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_628 = happySpecReduce_3 229# happyReduction_628 +happyReduction_628 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut222 happy_x_3 of { (HappyWrap222 happy_var_3) -> + happyIn245 + (\loc (ao,ac) -> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) Nothing (epTok happy_var_2) (EpTok ac)) Nothing (FromTo happy_var_1 happy_var_3)) + >>= ecpFromExp' + )}}} + +happyReduce_629 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_629 = happyReduce 5# 229# happyReduction_629 +happyReduction_629 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut222 happy_x_3 of { (HappyWrap222 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut222 happy_x_5 of { (HappyWrap222 happy_var_5) -> + happyIn245 + (\loc (ao,ac) -> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + unECP happy_var_5 >>= \ happy_var_5 -> + amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) (Just (epTok happy_var_2)) (epTok happy_var_4) (EpTok ac)) Nothing (FromThenTo happy_var_1 happy_var_3 happy_var_5)) + >>= ecpFromExp' + ) `HappyStk` happyRest}}}}} + +happyReduce_630 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_630 = happySpecReduce_3 229# happyReduction_630 +happyReduction_630 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut247 happy_x_3 of { (HappyWrap247 happy_var_3) -> + happyIn245 + (\loc (ao,ac) -> + checkMonadComp >>= \ ctxt -> + unECP happy_var_1 >>= \ happy_var_1 -> do { t <- addTrailingVbarA happy_var_1 (epTok happy_var_2) + ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc happy_var_3) t (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] noAnn [])) + >>= ecpFromExp' } + )}}} + +happyReduce_631 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_631 = happySpecReduce_3 230# happyReduction_631 +happyReduction_631 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut246 happy_x_1 of { (HappyWrap246 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut241 happy_x_3 of { (HappyWrap241 happy_var_3) -> + happyIn246 + (happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + case happy_var_1 of + (h:t) -> do + h' <- addTrailingCommaA h (epTok happy_var_2) + return (((:) $! happy_var_3) $! (h':t)) + )}}} + +happyReduce_632 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_632 = happySpecReduce_3 230# happyReduction_632 +happyReduction_632 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut241 happy_x_3 of { (HappyWrap241 happy_var_3) -> + happyIn246 + (unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + do { h <- addTrailingCommaA happy_var_1 (epTok happy_var_2) + ; return [happy_var_3,h] } + )}}} + +happyReduce_633 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_633 = happySpecReduce_1 231# happyReduction_633 +happyReduction_633 happy_x_1 + = case happyOut248 happy_x_1 of { (HappyWrap248 happy_var_1) -> + happyIn247 + (case unLoc happy_var_1 of + qs:|[] -> sL1 happy_var_1 qs + -- We just had one thing in our "parallel" list so + -- we simply return that thing directly + + qss -> sL1 happy_var_1 [sL1a happy_var_1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr | + qs <- qss] + noExpr noSyntaxExpr] + -- We actually found some actual parallel lists so + -- we wrap them into as a ParStmt + )} + +happyReduce_634 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_634 = happyMonadReduce 3# 232# happyReduction_634 +happyReduction_634 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut249 happy_x_1 of { (HappyWrap249 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut248 happy_x_3 of { (HappyWrap248 happy_var_3) -> + ( case unLoc happy_var_1 of + h:|t -> do + h' <- addTrailingVbarA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (reverse (h':t) NE.<| unLoc happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn248 r)) + +happyReduce_635 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_635 = happySpecReduce_1 232# happyReduction_635 +happyReduction_635 happy_x_1 + = case happyOut249 happy_x_1 of { (HappyWrap249 happy_var_1) -> + happyIn248 + (L (getLoc happy_var_1) (NE.singleton (reverse (toList (unLoc happy_var_1)))) + )} + +happyReduce_636 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_636 = happyMonadReduce 3# 233# happyReduction_636 +happyReduction_636 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut249 happy_x_1 of { (HappyWrap249 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut250 happy_x_3 of { (HappyWrap250 happy_var_3) -> + ( case unLoc happy_var_1 of + h:|t -> do + h' <- addTrailingCommaA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (NE.singleton (sLLa happy_var_1 happy_var_3 ((unLoc happy_var_3) (reverse (h':t)))))))}}}) + ) (\r -> happyReturn (happyIn249 r)) + +happyReduce_637 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_637 = happyMonadReduce 3# 233# happyReduction_637 +happyReduction_637 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut249 happy_x_1 of { (HappyWrap249 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut270 happy_x_3 of { (HappyWrap270 happy_var_3) -> + ( runPV happy_var_3 >>= \ happy_var_3 -> + case unLoc happy_var_1 of + h:|t -> do + h' <- addTrailingCommaA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (happy_var_3 :| (h':t))))}}}) + ) (\r -> happyReturn (happyIn249 r)) + +happyReduce_638 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_638 = happySpecReduce_1 233# happyReduction_638 +happyReduction_638 happy_x_1 + = case happyOut250 happy_x_1 of { (HappyWrap250 happy_var_1) -> + happyIn249 + (sLL happy_var_1 happy_var_1 (NE.singleton (L (getLocAnn happy_var_1) ((unLoc happy_var_1) []))) + )} + +happyReduce_639 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_639 = happyMonadReduce 1# 233# happyReduction_639 +happyReduction_639 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> + ( runPV happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 (NE.singleton happy_var_1))}) + ) (\r -> happyReturn (happyIn249 r)) + +happyReduce_640 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_640 = happyMonadReduce 2# 234# happyReduction_640 +happyReduction_640 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + return ( + sLL happy_var_1 happy_var_2 (\ss -> (mkTransformStmt (AnnTransStmt (epTok happy_var_1) noAnn noAnn noAnn) ss happy_var_2))))}}) + ) (\r -> happyReturn (happyIn250 r)) + +happyReduce_641 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_641 = happyMonadReduce 4# 234# happyReduction_641 +happyReduction_641 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + runPV (unECP happy_var_4) >>= \ happy_var_4 -> + return (sLL happy_var_1 happy_var_4 (\ss -> (mkTransformByStmt (AnnTransStmt (epTok happy_var_1) noAnn (Just (epTok happy_var_3)) noAnn) ss happy_var_2 happy_var_4))))}}}}) + ) (\r -> happyReturn (happyIn250 r)) + +happyReduce_642 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_642 = happyMonadReduce 4# 234# happyReduction_642 +happyReduction_642 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> + return (sLL happy_var_1 happy_var_4 (\ss -> (mkGroupUsingStmt (AnnTransStmt (epTok happy_var_1) (Just (epTok happy_var_2)) noAnn (Just (epTok happy_var_3))) ss happy_var_4))))}}}}) + ) (\r -> happyReturn (happyIn250 r)) + +happyReduce_643 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_643 = happyMonadReduce 6# 234# happyReduction_643 +happyReduction_643 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut221 happy_x_6 of { (HappyWrap221 happy_var_6) -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> + runPV (unECP happy_var_6) >>= \ happy_var_6 -> + return (sLL happy_var_1 happy_var_6 (\ss -> (mkGroupByUsingStmt (AnnTransStmt (epTok happy_var_1) (Just (epTok happy_var_2)) (Just (epTok happy_var_3)) (Just (epTok happy_var_5))) ss happy_var_4 happy_var_6))))}}}}}}) + ) (\r -> happyReturn (happyIn250 r)) + +happyReduce_644 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_644 = happySpecReduce_1 235# happyReduction_644 +happyReduction_644 happy_x_1 + = case happyOut252 happy_x_1 of { (HappyWrap252 happy_var_1) -> + happyIn251 + (L (getLoc happy_var_1) (reverse (unLoc happy_var_1)) + )} + +happyReduce_645 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_645 = happyMonadReduce 3# 236# happyReduction_645 +happyReduction_645 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut252 happy_x_1 of { (HappyWrap252 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut270 happy_x_3 of { (HappyWrap270 happy_var_3) -> + ( runPV happy_var_3 >>= \ happy_var_3 -> + case unLoc happy_var_1 of + (h:t) -> do + h' <- addTrailingCommaA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (happy_var_3 : (h':t))))}}}) + ) (\r -> happyReturn (happyIn252 r)) + +happyReduce_646 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_646 = happyMonadReduce 1# 236# happyReduction_646 +happyReduction_646 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> + ( runPV happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 [happy_var_1])}) + ) (\r -> happyReturn (happyIn252 r)) + +happyReduce_647 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_647 = happySpecReduce_2 237# happyReduction_647 +happyReduction_647 happy_x_2 + happy_x_1 + = case happyOut254 happy_x_1 of { (HappyWrap254 happy_var_1) -> + case happyOut137 happy_x_2 of { (HappyWrap137 happy_var_2) -> + happyIn253 + (happy_var_1 >>= \alt -> + do { let {L l (bs, csw) = adaptWhereBinds happy_var_2} + ; acs (comb2 alt (L l bs)) (\loc cs -> L loc (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) } + )}} + +happyReduce_648 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_648 = happySpecReduce_2 238# happyReduction_648 +happyReduction_648 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + happyIn254 + (unECP happy_var_2 >>= \ happy_var_2 -> + acs (comb2 happy_var_1 happy_var_2) (\loc cs -> L loc (unguardedRHS (EpAnn (spanAsAnchor $ comb2 happy_var_1 happy_var_2) (GrhsAnn Nothing (Right $ epUniTok happy_var_1)) cs) (comb2 happy_var_1 happy_var_2) happy_var_2)) + )}} + +happyReduce_649 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_649 = happySpecReduce_1 238# happyReduction_649 +happyReduction_649 happy_x_1 + = case happyOut255 happy_x_1 of { (HappyWrap255 happy_var_1) -> + happyIn254 + (happy_var_1 >>= \gdpats -> + return $ sL1 gdpats (NE.reverse (unLoc gdpats)) + )} + +happyReduce_650 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_650 = happySpecReduce_2 239# happyReduction_650 +happyReduction_650 happy_x_2 + happy_x_1 + = case happyOut255 happy_x_1 of { (HappyWrap255 happy_var_1) -> + case happyOut257 happy_x_2 of { (HappyWrap257 happy_var_2) -> + happyIn255 + (happy_var_1 >>= \gdpats -> + happy_var_2 >>= \gdpat -> + return $ sLL gdpats gdpat (gdpat NE.<| unLoc gdpats) + )}} + +happyReduce_651 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_651 = happySpecReduce_1 239# happyReduction_651 +happyReduction_651 happy_x_1 + = case happyOut257 happy_x_1 of { (HappyWrap257 happy_var_1) -> + happyIn255 + (happy_var_1 >>= \gdpat -> return $ sL1 gdpat (NE.singleton gdpat) + )} + +happyReduce_652 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_652 = happyMonadReduce 3# 240# happyReduction_652 +happyReduction_652 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut255 happy_x_2 of { (HappyWrap255 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( runPV happy_var_2 >>= \ happy_var_2 -> + return $ sLL happy_var_1 happy_var_3 ((epTok happy_var_1,epTok happy_var_3),unLoc happy_var_2))}}}) + ) (\r -> happyReturn (happyIn256 r)) + +happyReduce_653 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_653 = happyMonadReduce 2# 240# happyReduction_653 +happyReduction_653 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut255 happy_x_1 of { (HappyWrap255 happy_var_1) -> + ( runPV happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 ((NoEpTok, NoEpTok),unLoc happy_var_1))}) + ) (\r -> happyReturn (happyIn256 r)) + +happyReduce_654 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_654 = happyReduce 4# 241# happyReduction_654 +happyReduction_654 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut251 happy_x_2 of { (HappyWrap251 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + happyIn257 + (unECP happy_var_4 >>= \ happy_var_4 -> + acsA (comb2 happy_var_1 happy_var_4) (\loc cs -> sL loc $ GRHS (EpAnn (glEE happy_var_1 happy_var_4) (GrhsAnn (Just $ epTok happy_var_1) (Right $ epUniTok happy_var_3)) cs) (unLoc happy_var_2) happy_var_4) + ) `HappyStk` happyRest}}}} + +happyReduce_655 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_655 = happyMonadReduce 1# 242# happyReduction_655 +happyReduction_655 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> + ( (checkPattern <=< runPV) (unECP happy_var_1))}) + ) (\r -> happyReturn (happyIn258 r)) + +happyReduce_656 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_656 = happyMonadReduce 1# 243# happyReduction_656 +happyReduction_656 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut343 happy_x_1 of { (HappyWrap343 happy_var_1) -> + ( case unLoc happy_var_1 of + pat :| [] -> return pat + pats -> hintOrPats (sL1a happy_var_1 (OrPat NoExtField pats)))}) + ) (\r -> happyReturn (happyIn259 r)) + +happyReduce_657 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_657 = happySpecReduce_1 244# happyReduction_657 +happyReduction_657 happy_x_1 + = case happyOut259 happy_x_1 of { (HappyWrap259 happy_var_1) -> + happyIn260 + ([ happy_var_1 ] + )} + +happyReduce_658 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_658 = happyMonadReduce 1# 245# happyReduction_658 +happyReduction_658 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> + ( -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess + checkPattern_details incompleteDoBlock + (unECP happy_var_1))}) + ) (\r -> happyReturn (happyIn261 r)) + +happyReduce_659 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_659 = happySpecReduce_1 246# happyReduction_659 +happyReduction_659 happy_x_1 + = case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> + happyIn262 + (happy_var_1 + )} + +happyReduce_660 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_660 = happySpecReduce_2 246# happyReduction_660 +happyReduction_660 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + happyIn262 + (sLLa happy_var_1 happy_var_2 (InvisPat (epTok happy_var_1, SpecifiedSpec) (mkHsTyPat happy_var_2)) + )}} + +happyReduce_661 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_661 = happySpecReduce_2 247# happyReduction_661 +happyReduction_661 happy_x_2 + happy_x_1 + = case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> + case happyOut263 happy_x_2 of { (HappyWrap263 happy_var_2) -> + happyIn263 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_662 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_662 = happySpecReduce_0 247# happyReduction_662 +happyReduction_662 = happyIn263 + ([] + ) + +happyReduce_663 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_663 = happyMonadReduce 1# 248# happyReduction_663 +happyReduction_663 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> + ( (checkPattern <=< runPV) (unECP happy_var_1))}) + ) (\r -> happyReturn (happyIn264 r)) + +happyReduce_664 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_664 = happySpecReduce_3 249# happyReduction_664 +happyReduction_664 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut266 happy_x_2 of { (HappyWrap266 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn265 + (happy_var_2 >>= \ happy_var_2 -> + amsr (sLL happy_var_1 happy_var_3 (reverse $ snd $ unLoc happy_var_2)) (AnnList (stmtsAnchor happy_var_2) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) (fromOL $ fst $ unLoc happy_var_2) noAnn []) + )}}} + +happyReduce_665 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_665 = happySpecReduce_3 249# happyReduction_665 +happyReduction_665 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut266 happy_x_2 of { (HappyWrap266 happy_var_2) -> + happyIn265 + (happy_var_2 >>= \ happy_var_2 -> amsr + (L (stmtsLoc happy_var_2) (reverse $ snd $ unLoc happy_var_2)) (AnnList (stmtsAnchor happy_var_2) ListNone (fromOL $ fst $ unLoc happy_var_2) noAnn []) + )} + +happyReduce_666 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_666 = happySpecReduce_3 250# happyReduction_666 +happyReduction_666 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut269 happy_x_3 of { (HappyWrap269 happy_var_3) -> + happyIn266 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ (happy_var_3 :: LStmt GhcPs (LocatedA b)) -> + case (snd $ unLoc happy_var_1) of + [] -> return (sLL happy_var_1 happy_var_3 ( (fst $ unLoc happy_var_1) `snocOL` (epTok happy_var_2) + , happy_var_3 : (snd $ unLoc happy_var_1))) + (h:t) -> do + { h' <- addTrailingSemiA h (epTok happy_var_2) + ; return $ sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,happy_var_3 :(h':t)) } + )}}} + +happyReduce_667 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_667 = happySpecReduce_2 250# happyReduction_667 +happyReduction_667 happy_x_2 + happy_x_1 + = case happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn266 + (happy_var_1 >>= \ happy_var_1 -> + case (snd $ unLoc happy_var_1) of + [] -> return (sLZ happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) `snocOL` (epTok happy_var_2),snd $ unLoc happy_var_1)) + (h:t) -> do + { h' <- addTrailingSemiA h (epTok happy_var_2) + ; return $ sLZ happy_var_1 happy_var_2 (fst $ unLoc happy_var_1,h':t) } + )}} + +happyReduce_668 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_668 = happySpecReduce_1 250# happyReduction_668 +happyReduction_668 happy_x_1 + = case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> + happyIn266 + (happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 (nilOL,[happy_var_1]) + )} + +happyReduce_669 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_669 = happySpecReduce_0 250# happyReduction_669 +happyReduction_669 = happyIn266 + (return $ noLoc (nilOL,[]) + ) + +happyReduce_670 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_670 = happyMonadReduce 1# 251# happyReduction_670 +happyReduction_670 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> + ( fmap Just (runPV happy_var_1))}) + ) (\r -> happyReturn (happyIn267 r)) + +happyReduce_671 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_671 = happySpecReduce_0 251# happyReduction_671 +happyReduction_671 = happyIn267 + (Nothing + ) + +happyReduce_672 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_672 = happyMonadReduce 1# 252# happyReduction_672 +happyReduction_672 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> + ( runPV happy_var_1)}) + ) (\r -> happyReturn (happyIn268 r)) + +happyReduce_673 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_673 = happySpecReduce_1 253# happyReduction_673 +happyReduction_673 happy_x_1 + = case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> + happyIn269 + (happy_var_1 + )} + +happyReduce_674 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_674 = happySpecReduce_2 253# happyReduction_674 +happyReduction_674 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut265 happy_x_2 of { (HappyWrap265 happy_var_2) -> + happyIn269 + (happy_var_2 >>= \ happy_var_2 -> + amsA' (sLL happy_var_1 happy_var_2 $ mkRecStmt (hsDoAnn (epTok happy_var_1) happy_var_2) happy_var_2) + )}} + +happyReduce_675 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_675 = happySpecReduce_3 254# happyReduction_675 +happyReduction_675 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut261 happy_x_1 of { (HappyWrap261 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut221 happy_x_3 of { (HappyWrap221 happy_var_3) -> + happyIn270 + (unECP happy_var_3 >>= \ happy_var_3 -> + amsA' (sLL happy_var_1 happy_var_3 $ mkPsBindStmt (epUniTok happy_var_2) happy_var_1 happy_var_3) + )}}} + +happyReduce_676 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_676 = happySpecReduce_1 254# happyReduction_676 +happyReduction_676 happy_x_1 + = case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> + happyIn270 + (unECP happy_var_1 >>= \ happy_var_1 -> + return $ sL1a happy_var_1 $ mkBodyStmt happy_var_1 + )} + +happyReduce_677 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_677 = happySpecReduce_2 254# happyReduction_677 +happyReduction_677 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut136 happy_x_2 of { (HappyWrap136 happy_var_2) -> + happyIn270 + (amsA' (sLL happy_var_1 happy_var_2 $ mkLetStmt (epTok happy_var_1) (unLoc happy_var_2)) + )}} + +happyReduce_678 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_678 = happySpecReduce_1 255# happyReduction_678 +happyReduction_678 happy_x_1 + = case happyOut272 happy_x_1 of { (HappyWrap272 happy_var_1) -> + happyIn271 + (happy_var_1 + )} + +happyReduce_679 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_679 = happySpecReduce_0 255# happyReduction_679 +happyReduction_679 = happyIn271 + (return ([], Nothing) + ) + +happyReduce_680 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_680 = happySpecReduce_3 256# happyReduction_680 +happyReduction_680 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut273 happy_x_1 of { (HappyWrap273 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut272 happy_x_3 of { (HappyWrap272 happy_var_3) -> + happyIn272 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> do + h <- addTrailingCommaFBind happy_var_1 (epTok happy_var_2) + return (case happy_var_3 of (flds, dd) -> (h : flds, dd)) + )}}} + +happyReduce_681 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_681 = happySpecReduce_1 256# happyReduction_681 +happyReduction_681 happy_x_1 + = case happyOut273 happy_x_1 of { (HappyWrap273 happy_var_1) -> + happyIn272 + (happy_var_1 >>= \ happy_var_1 -> + return ([happy_var_1], Nothing) + )} + +happyReduce_682 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_682 = happySpecReduce_1 256# happyReduction_682 +happyReduction_682 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn272 + (return ([], Just (getLoc happy_var_1)) + )} + +happyReduce_683 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_683 = happySpecReduce_3 257# happyReduction_683 +happyReduction_683 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut241 happy_x_3 of { (HappyWrap241 happy_var_3) -> + happyIn273 + (unECP happy_var_3 >>= \ happy_var_3 -> + fmap Left $ amsA' (sLL happy_var_1 happy_var_3 $ HsFieldBind (Just (epTok happy_var_2)) (sL1a happy_var_1 $ mkFieldOcc happy_var_1) happy_var_3 False) + )}}} + +happyReduce_684 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_684 = happySpecReduce_1 257# happyReduction_684 +happyReduction_684 happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + happyIn273 + (placeHolderPunRhs >>= \rhs -> + fmap Left $ amsA' (sL1 happy_var_1 $ HsFieldBind Nothing (sL1a happy_var_1 $ mkFieldOcc happy_var_1) rhs True) + )} + +happyReduce_685 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_685 = happyReduce 5# 257# happyReduction_685 +happyReduction_685 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut274 happy_x_3 of { (HappyWrap274 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut241 happy_x_5 of { (HappyWrap241 happy_var_5) -> + happyIn273 + (do + let top = sL1a happy_var_1 $ DotFieldOcc noAnn happy_var_1 + ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc happy_var_3) + lf' = comb2 happy_var_2 (L lf ()) + fields = top :| L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok happy_var_2)) f) : t + final = last fields + l = comb2 happy_var_1 happy_var_3 + isPun = False + happy_var_5 <- unECP happy_var_5 + fmap Right $ mkHsProjUpdatePV (comb2 happy_var_1 happy_var_5) (L l fields) happy_var_5 isPun + (Just (epTok happy_var_4)) + ) `HappyStk` happyRest}}}}} + +happyReduce_686 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_686 = happySpecReduce_3 257# happyReduction_686 +happyReduction_686 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut274 happy_x_3 of { (HappyWrap274 happy_var_3) -> + happyIn273 + (do + let top = sL1a happy_var_1 $ DotFieldOcc noAnn happy_var_1 + ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc happy_var_3) + lf' = comb2 happy_var_2 (L lf ()) + fields = top :| L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok happy_var_2)) f) : t + final = last fields + l = comb2 happy_var_1 happy_var_3 + isPun = True + var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOccFS . field_label . unLoc . dfoLabel . unLoc $ final)) + fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun Nothing + )}}} + +happyReduce_687 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_687 = happySpecReduce_3 258# happyReduction_687 +happyReduction_687 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut318 happy_x_3 of { (HappyWrap318 happy_var_3) -> + happyIn274 + (sLL happy_var_1 happy_var_3 ((sLLa happy_var_2 happy_var_3 (DotFieldOcc (AnnFieldLabel $ Just $ epTok happy_var_2) happy_var_3)) : unLoc happy_var_1) + )}}} + +happyReduce_688 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_688 = happySpecReduce_1 258# happyReduction_688 +happyReduction_688 happy_x_1 + = case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> + happyIn274 + (sL1 happy_var_1 [sL1a happy_var_1 (DotFieldOcc (AnnFieldLabel Nothing) happy_var_1)] + )} + +happyReduce_689 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_689 = happyMonadReduce 3# 259# happyReduction_689 +happyReduction_689 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut275 happy_x_1 of { (HappyWrap275 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut276 happy_x_3 of { (HappyWrap276 happy_var_3) -> + ( case unLoc happy_var_1 of + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (let { this = happy_var_3; rest = h':t } + in rest `seq` this `seq` sLL happy_var_1 happy_var_3 (this : rest)))}}}) + ) (\r -> happyReturn (happyIn275 r)) + +happyReduce_690 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_690 = happyMonadReduce 2# 259# happyReduction_690 +happyReduction_690 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut275 happy_x_1 of { (HappyWrap275 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( case unLoc happy_var_1 of + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (h':t)))}}) + ) (\r -> happyReturn (happyIn275 r)) + +happyReduce_691 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_691 = happySpecReduce_1 259# happyReduction_691 +happyReduction_691 happy_x_1 + = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> + happyIn275 + (let this = happy_var_1 in this `seq` (sL1 happy_var_1 [this]) + )} + +happyReduce_692 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_692 = happyMonadReduce 3# 260# happyReduction_692 +happyReduction_692 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut277 happy_x_1 of { (HappyWrap277 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut221 happy_x_3 of { (HappyWrap221 happy_var_3) -> + ( runPV (unECP happy_var_3) >>= \ happy_var_3 -> + amsA' (sLL happy_var_1 happy_var_3 (IPBind (epTok happy_var_2) (reLoc happy_var_1) happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn276 r)) + +happyReduce_693 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_693 = happySpecReduce_1 261# happyReduction_693 +happyReduction_693 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn277 + (sL1 happy_var_1 (HsIPName (getIPDUPVARID happy_var_1)) + )} + +happyReduce_694 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_694 = happySpecReduce_1 262# happyReduction_694 +happyReduction_694 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn278 + (sL1 happy_var_1 (getLABELVARIDs happy_var_1, getLABELVARID happy_var_1) + )} + +happyReduce_695 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_695 = happySpecReduce_1 263# happyReduction_695 +happyReduction_695 happy_x_1 + = case happyOut280 happy_x_1 of { (HappyWrap280 happy_var_1) -> + happyIn279 + (happy_var_1 + )} + +happyReduce_696 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_696 = happySpecReduce_0 263# happyReduction_696 +happyReduction_696 = happyIn279 + (noLocA mkTrue + ) + +happyReduce_697 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_697 = happySpecReduce_1 264# happyReduction_697 +happyReduction_697 happy_x_1 + = case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> + happyIn280 + (happy_var_1 + )} + +happyReduce_698 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_698 = happyMonadReduce 3# 264# happyReduction_698 +happyReduction_698 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut280 happy_x_3 of { (HappyWrap280 happy_var_3) -> + ( do { h <- addTrailingVbarL happy_var_1 (epTok happy_var_2) + ; return (sLLa happy_var_1 happy_var_3 (Or [h,happy_var_3])) })}}}) + ) (\r -> happyReturn (happyIn280 r)) + +happyReduce_699 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_699 = happySpecReduce_1 265# happyReduction_699 +happyReduction_699 happy_x_1 + = case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> + happyIn281 + (sLLa (head happy_var_1) (last happy_var_1) (And (toList happy_var_1)) + )} + +happyReduce_700 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_700 = happySpecReduce_1 266# happyReduction_700 +happyReduction_700 happy_x_1 + = case happyOut283 happy_x_1 of { (HappyWrap283 happy_var_1) -> + happyIn282 + (NE.singleton happy_var_1 + )} + +happyReduce_701 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_701 = happyMonadReduce 3# 266# happyReduction_701 +happyReduction_701 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut283 happy_x_1 of { (HappyWrap283 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut282 happy_x_3 of { (HappyWrap282 happy_var_3) -> + ( do { h <- addTrailingCommaL happy_var_1 (epTok happy_var_2) + ; return (h NE.<| happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn282 r)) + +happyReduce_702 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_702 = happyMonadReduce 3# 267# happyReduction_702 +happyReduction_702 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut280 happy_x_2 of { (HappyWrap280 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (Parens happy_var_2)) + (AnnList Nothing (ListParens (epTok happy_var_1) (epTok happy_var_3)) [] noAnn []))}}}) + ) (\r -> happyReturn (happyIn283 r)) + +happyReduce_703 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_703 = happySpecReduce_1 267# happyReduction_703 +happyReduction_703 happy_x_1 + = case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> + happyIn283 + (sL1a happy_var_1 (Var happy_var_1) + )} + +happyReduce_704 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_704 = happySpecReduce_1 268# happyReduction_704 +happyReduction_704 happy_x_1 + = case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> + happyIn284 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_705 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_705 = happyMonadReduce 3# 268# happyReduction_705 +happyReduction_705 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut284 happy_x_3 of { (HappyWrap284 happy_var_3) -> + ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) + ; return (sLL happy_var_1 happy_var_3 (h : unLoc happy_var_3)) })}}}) + ) (\r -> happyReturn (happyIn284 r)) + +happyReduce_706 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_706 = happySpecReduce_1 269# happyReduction_706 +happyReduction_706 happy_x_1 + = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + happyIn285 + (happy_var_1 + )} + +happyReduce_707 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_707 = happySpecReduce_1 269# happyReduction_707 +happyReduction_707 happy_x_1 + = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> + happyIn285 + (happy_var_1 + )} + +happyReduce_708 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_708 = happySpecReduce_1 270# happyReduction_708 +happyReduction_708 happy_x_1 + = case happyOut287 happy_x_1 of { (HappyWrap287 happy_var_1) -> + happyIn286 + (happy_var_1 + )} + +happyReduce_709 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_709 = happySpecReduce_1 270# happyReduction_709 +happyReduction_709 happy_x_1 + = case happyOut292 happy_x_1 of { (HappyWrap292 happy_var_1) -> + happyIn286 + (happy_var_1 + )} + +happyReduce_710 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_710 = happySpecReduce_1 271# happyReduction_710 +happyReduction_710 happy_x_1 + = case happyOut328 happy_x_1 of { (HappyWrap328 happy_var_1) -> + happyIn287 + (happy_var_1 + )} + +happyReduce_711 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_711 = happyMonadReduce 3# 271# happyReduction_711 +happyReduction_711 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut330 happy_x_2 of { (HappyWrap330 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn287 r)) + +happyReduce_712 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_712 = happySpecReduce_1 272# happyReduction_712 +happyReduction_712 happy_x_1 + = case happyOut329 happy_x_1 of { (HappyWrap329 happy_var_1) -> + happyIn288 + (happy_var_1 + )} + +happyReduce_713 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_713 = happyMonadReduce 3# 272# happyReduction_713 +happyReduction_713 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut331 happy_x_2 of { (HappyWrap331 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn288 r)) + +happyReduce_714 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_714 = happySpecReduce_1 272# happyReduction_714 +happyReduction_714 happy_x_1 + = case happyOut292 happy_x_1 of { (HappyWrap292 happy_var_1) -> + happyIn288 + (happy_var_1 + )} + +happyReduce_715 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_715 = happySpecReduce_1 273# happyReduction_715 +happyReduction_715 happy_x_1 + = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> + happyIn289 + (sL1 happy_var_1 (pure happy_var_1) + )} + +happyReduce_716 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_716 = happyMonadReduce 3# 273# happyReduction_716 +happyReduction_716 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut289 happy_x_3 of { (HappyWrap289 happy_var_3) -> + ( sLL happy_var_1 happy_var_3 . (:| toList (unLoc happy_var_3)) <$> addTrailingCommaN happy_var_1 (gl happy_var_2))}}}) + ) (\r -> happyReturn (happyIn289 r)) + +happyReduce_717 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_717 = happySpecReduce_1 274# happyReduction_717 +happyReduction_717 happy_x_1 + = case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> + happyIn290 + ([happy_var_1] + )} + +happyReduce_718 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_718 = happyMonadReduce 3# 274# happyReduction_718 +happyReduction_718 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut290 happy_x_3 of { (HappyWrap290 happy_var_3) -> + ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) + ; return (h : happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn290 r)) + +happyReduce_719 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_719 = happyMonadReduce 3# 275# happyReduction_719 +happyReduction_719 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut335 happy_x_2 of { (HappyWrap335 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 $ tupleDataCon Boxed (snd happy_var_2 + 1)) + (NameAnnCommas (NameParens (epTok happy_var_1) (epTok happy_var_3)) (map (EpTok . srcSpan2e) (toList $ fst happy_var_2)) []))}}}) + ) (\r -> happyReturn (happyIn291 r)) + +happyReduce_720 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_720 = happyMonadReduce 2# 275# happyReduction_720 +happyReduction_720 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 $ unboxedUnitDataCon) (NameAnnOnly (NameParensHash (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn291 r)) + +happyReduce_721 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_721 = happyMonadReduce 3# 275# happyReduction_721 +happyReduction_721 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut335 happy_x_2 of { (HappyWrap335 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 $ tupleDataCon Unboxed (snd happy_var_2 + 1)) + (NameAnnCommas (NameParensHash (epTok happy_var_1) (epTok happy_var_3)) (map (EpTok . srcSpan2e) (toList $ fst happy_var_2)) []))}}}) + ) (\r -> happyReturn (happyIn291 r)) + +happyReduce_722 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_722 = happySpecReduce_1 276# happyReduction_722 +happyReduction_722 happy_x_1 + = case happyOut293 happy_x_1 of { (HappyWrap293 happy_var_1) -> + happyIn292 + (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1)) + )} + +happyReduce_723 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_723 = happyMonadReduce 3# 276# happyReduction_723 +happyReduction_723 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 $ getRdrName unrestrictedFunTyCon) + (NameAnnRArrow (Just $ epTok happy_var_1) (epUniTok happy_var_2) (Just $ epTok happy_var_3) []))}}}) + ) (\r -> happyReturn (happyIn292 r)) + +happyReduce_724 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_724 = happySpecReduce_1 277# happyReduction_724 +happyReduction_724 happy_x_1 + = case happyOut291 happy_x_1 of { (HappyWrap291 happy_var_1) -> + happyIn293 + (happy_var_1 + )} + +happyReduce_725 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_725 = happyMonadReduce 2# 277# happyReduction_725 +happyReduction_725 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 unitDataCon) (NameAnnOnly (NameParens (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn293 r)) + +happyReduce_726 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_726 = happyMonadReduce 2# 277# happyReduction_726 +happyReduction_726 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 nilDataCon) (NameAnnOnly (NameSquare (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn293 r)) + +happyReduce_727 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_727 = happySpecReduce_1 278# happyReduction_727 +happyReduction_727 happy_x_1 + = case happyOut331 happy_x_1 of { (HappyWrap331 happy_var_1) -> + happyIn294 + (happy_var_1 + )} + +happyReduce_728 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_728 = happyMonadReduce 3# 278# happyReduction_728 +happyReduction_728 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut329 happy_x_2 of { (HappyWrap329 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn294 r)) + +happyReduce_729 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_729 = happySpecReduce_1 279# happyReduction_729 +happyReduction_729 happy_x_1 + = case happyOut330 happy_x_1 of { (HappyWrap330 happy_var_1) -> + happyIn295 + (happy_var_1 + )} + +happyReduce_730 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_730 = happyMonadReduce 3# 279# happyReduction_730 +happyReduction_730 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut328 happy_x_2 of { (HappyWrap328 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn295 r)) + +happyReduce_731 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_731 = happySpecReduce_1 280# happyReduction_731 +happyReduction_731 happy_x_1 + = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> + happyIn296 + (happy_var_1 + )} + +happyReduce_732 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_732 = happyMonadReduce 2# 280# happyReduction_732 +happyReduction_732 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 $ getRdrName unitTyCon) + (NameAnnOnly (NameParens (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn296 r)) + +happyReduce_733 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_733 = happyMonadReduce 2# 280# happyReduction_733 +happyReduction_733 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 $ getRdrName unboxedUnitTyCon) + (NameAnnOnly (NameParensHash (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn296 r)) + +happyReduce_734 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_734 = happyMonadReduce 2# 280# happyReduction_734 +happyReduction_734 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 $ listTyCon_RDR) + (NameAnnOnly (NameSquare (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn296 r)) + +happyReduce_735 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_735 = happySpecReduce_1 281# happyReduction_735 +happyReduction_735 happy_x_1 + = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> + happyIn297 + (happy_var_1 + )} + +happyReduce_736 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_736 = happyMonadReduce 3# 281# happyReduction_736 +happyReduction_736 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut335 happy_x_2 of { (HappyWrap335 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { n <- mkTupleSyntaxTycon Boxed (snd happy_var_2 + 1) + ; amsr (sLL happy_var_1 happy_var_3 n) (NameAnnCommas (NameParens (epTok happy_var_1) (epTok happy_var_3)) (map (EpTok . srcSpan2e) (toList $ fst happy_var_2)) []) })}}}) + ) (\r -> happyReturn (happyIn297 r)) + +happyReduce_737 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_737 = happyMonadReduce 3# 281# happyReduction_737 +happyReduction_737 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut335 happy_x_2 of { (HappyWrap335 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { n <- mkTupleSyntaxTycon Unboxed (snd happy_var_2 + 1) + ; amsr (sLL happy_var_1 happy_var_3 n) (NameAnnCommas (NameParensHash (epTok happy_var_1) (epTok happy_var_3)) (map (EpTok . srcSpan2e) (toList $ fst happy_var_2)) []) })}}}) + ) (\r -> happyReturn (happyIn297 r)) + +happyReduce_738 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_738 = happyMonadReduce 3# 281# happyReduction_738 +happyReduction_738 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut337 happy_x_2 of { (HappyWrap337 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { requireLTPuns PEP_SumSyntaxType happy_var_1 happy_var_3 + ; amsr (sLL happy_var_1 happy_var_3 $ (getRdrName (sumTyCon (snd happy_var_2 + 1)))) + (NameAnnBars (epTok happy_var_1, epTok happy_var_3) (toList $ fst happy_var_2) []) })}}}) + ) (\r -> happyReturn (happyIn297 r)) + +happyReduce_739 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_739 = happyMonadReduce 3# 281# happyReduction_739 +happyReduction_739 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 $ getRdrName unrestrictedFunTyCon) + (NameAnnRArrow (Just $ epTok happy_var_1) (epUniTok happy_var_2) (Just $ epTok happy_var_3) []))}}}) + ) (\r -> happyReturn (happyIn297 r)) + +happyReduce_740 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_740 = happySpecReduce_1 282# happyReduction_740 +happyReduction_740 happy_x_1 + = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> + happyIn298 + (happy_var_1 + )} + +happyReduce_741 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_741 = happyMonadReduce 3# 282# happyReduction_741 +happyReduction_741 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut303 happy_x_2 of { (HappyWrap303 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn298 r)) + +happyReduce_742 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_742 = happySpecReduce_1 283# happyReduction_742 +happyReduction_742 happy_x_1 + = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> + happyIn299 + (happy_var_1 + )} + +happyReduce_743 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_743 = happyMonadReduce 3# 283# happyReduction_743 +happyReduction_743 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( let { name :: Located RdrName + ; name = sL1 happy_var_2 $! mkQual tcClsName (getQCONSYM happy_var_2) } + in amsr (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn299 r)) + +happyReduce_744 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_744 = happyMonadReduce 3# 283# happyReduction_744 +happyReduction_744 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( let { name :: Located RdrName + ; name = sL1 happy_var_2 $! mkUnqual tcClsName (getCONSYM happy_var_2) } + in amsr (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn299 r)) + +happyReduce_745 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_745 = happyMonadReduce 3# 283# happyReduction_745 +happyReduction_745 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( let { name :: Located RdrName + ; name = sL1 happy_var_2 $! consDataCon_RDR } + in amsr (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn299 r)) + +happyReduce_746 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_746 = happySpecReduce_1 284# happyReduction_746 +happyReduction_746 happy_x_1 + = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> + happyIn300 + (happy_var_1 + )} + +happyReduce_747 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_747 = happyMonadReduce 3# 284# happyReduction_747 +happyReduction_747 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut301 happy_x_2 of { (HappyWrap301 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn300 r)) + +happyReduce_748 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_748 = happySpecReduce_1 285# happyReduction_748 +happyReduction_748 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn301 + (sL1n happy_var_1 $! mkQual tcClsName (getQCONID happy_var_1) + )} + +happyReduce_749 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_749 = happySpecReduce_1 285# happyReduction_749 +happyReduction_749 happy_x_1 + = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> + happyIn301 + (happy_var_1 + )} + +happyReduce_750 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_750 = happySpecReduce_1 286# happyReduction_750 +happyReduction_750 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn302 + (sL1n happy_var_1 $! mkUnqual tcClsName (getCONID happy_var_1) + )} + +happyReduce_751 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_751 = happySpecReduce_1 287# happyReduction_751 +happyReduction_751 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn303 + (sL1n happy_var_1 $! mkQual tcClsName (getQCONSYM happy_var_1) + )} + +happyReduce_752 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_752 = happySpecReduce_1 287# happyReduction_752 +happyReduction_752 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn303 + (sL1n happy_var_1 $! mkQual tcClsName (getQVARSYM happy_var_1) + )} + +happyReduce_753 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_753 = happySpecReduce_1 287# happyReduction_753 +happyReduction_753 happy_x_1 + = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> + happyIn303 + (happy_var_1 + )} + +happyReduce_754 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_754 = happySpecReduce_1 288# happyReduction_754 +happyReduction_754 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn304 + (sL1n happy_var_1 $! mkUnqual tcClsName (getCONSYM happy_var_1) + )} + +happyReduce_755 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_755 = happySpecReduce_1 288# happyReduction_755 +happyReduction_755 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn304 + (sL1n happy_var_1 $! mkUnqual tcClsName (getVARSYM happy_var_1) + )} + +happyReduce_756 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_756 = happySpecReduce_1 288# happyReduction_756 +happyReduction_756 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn304 + (sL1n happy_var_1 $! consDataCon_RDR + )} + +happyReduce_757 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_757 = happySpecReduce_1 288# happyReduction_757 +happyReduction_757 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn304 + (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit "-") + )} + +happyReduce_758 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_758 = happySpecReduce_1 288# happyReduction_758 +happyReduction_758 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn304 + (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit ".") + )} + +happyReduce_759 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_759 = happySpecReduce_1 289# happyReduction_759 +happyReduction_759 happy_x_1 + = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> + happyIn305 + (happy_var_1 + )} + +happyReduce_760 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_760 = happyMonadReduce 3# 289# happyReduction_760 +happyReduction_760 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut304 happy_x_2 of { (HappyWrap304 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn305 r)) + +happyReduce_761 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_761 = happySpecReduce_1 290# happyReduction_761 +happyReduction_761 happy_x_1 + = case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> + happyIn306 + (happy_var_1 + )} + +happyReduce_762 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_762 = happySpecReduce_1 290# happyReduction_762 +happyReduction_762 happy_x_1 + = case happyOut294 happy_x_1 of { (HappyWrap294 happy_var_1) -> + happyIn306 + (happy_var_1 + )} + +happyReduce_763 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_763 = happyMonadReduce 1# 290# happyReduction_763 +happyReduction_763 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( amsr (sLL happy_var_1 happy_var_1 $ getRdrName unrestrictedFunTyCon) + (NameAnnRArrow Nothing (epUniTok happy_var_1) Nothing []))}) + ) (\r -> happyReturn (happyIn306 r)) + +happyReduce_764 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_764 = happySpecReduce_1 291# happyReduction_764 +happyReduction_764 happy_x_1 + = case happyOut324 happy_x_1 of { (HappyWrap324 happy_var_1) -> + happyIn307 + (happy_var_1 + )} + +happyReduce_765 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_765 = happyMonadReduce 3# 291# happyReduction_765 +happyReduction_765 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut320 happy_x_2 of { (HappyWrap320 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn307 r)) + +happyReduce_766 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_766 = happySpecReduce_1 292# happyReduction_766 +happyReduction_766 happy_x_1 + = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> + happyIn308 + (mkHsVarOpPV happy_var_1 + )} + +happyReduce_767 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_767 = happySpecReduce_1 292# happyReduction_767 +happyReduction_767 happy_x_1 + = case happyOut295 happy_x_1 of { (HappyWrap295 happy_var_1) -> + happyIn308 + (mkHsConOpPV happy_var_1 + )} + +happyReduce_768 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_768 = happySpecReduce_1 292# happyReduction_768 +happyReduction_768 happy_x_1 + = case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> + happyIn308 + (mkHsInfixHolePV happy_var_1 + )} + +happyReduce_769 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_769 = happySpecReduce_1 293# happyReduction_769 +happyReduction_769 happy_x_1 + = case happyOut312 happy_x_1 of { (HappyWrap312 happy_var_1) -> + happyIn309 + (mkHsVarOpPV happy_var_1 + )} + +happyReduce_770 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_770 = happySpecReduce_1 293# happyReduction_770 +happyReduction_770 happy_x_1 + = case happyOut295 happy_x_1 of { (HappyWrap295 happy_var_1) -> + happyIn309 + (mkHsConOpPV happy_var_1 + )} + +happyReduce_771 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_771 = happySpecReduce_1 293# happyReduction_771 +happyReduction_771 happy_x_1 + = case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> + happyIn309 + (mkHsInfixHolePV happy_var_1 + )} + +happyReduce_772 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_772 = happyMonadReduce 3# 294# happyReduction_772 +happyReduction_772 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (mkUnqual varName (fsLit "_"))) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn310 r)) + +happyReduce_773 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_773 = happySpecReduce_1 295# happyReduction_773 +happyReduction_773 happy_x_1 + = case happyOut321 happy_x_1 of { (HappyWrap321 happy_var_1) -> + happyIn311 + (happy_var_1 + )} + +happyReduce_774 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_774 = happyMonadReduce 3# 295# happyReduction_774 +happyReduction_774 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut319 happy_x_2 of { (HappyWrap319 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn311 r)) + +happyReduce_775 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_775 = happySpecReduce_1 296# happyReduction_775 +happyReduction_775 happy_x_1 + = case happyOut322 happy_x_1 of { (HappyWrap322 happy_var_1) -> + happyIn312 + (happy_var_1 + )} + +happyReduce_776 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_776 = happyMonadReduce 3# 296# happyReduction_776 +happyReduction_776 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut319 happy_x_2 of { (HappyWrap319 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn312 r)) + +happyReduce_777 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_777 = happySpecReduce_1 297# happyReduction_777 +happyReduction_777 happy_x_1 + = case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> + happyIn313 + (happy_var_1 + )} + +happyReduce_778 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_778 = happyMonadReduce 3# 298# happyReduction_778 +happyReduction_778 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn314 r)) + +happyReduce_779 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_779 = happySpecReduce_1 299# happyReduction_779 +happyReduction_779 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn315 + (sL1n happy_var_1 $! mkUnqual tvName (getVARID happy_var_1) + )} + +happyReduce_780 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_780 = happySpecReduce_1 299# happyReduction_780 +happyReduction_780 happy_x_1 + = case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> + happyIn315 + (sL1n happy_var_1 $! mkUnqual tvName (unLoc happy_var_1) + )} + +happyReduce_781 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_781 = happySpecReduce_1 299# happyReduction_781 +happyReduction_781 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn315 + (sL1n happy_var_1 $! mkUnqual tvName (fsLit "unsafe") + )} + +happyReduce_782 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_782 = happySpecReduce_1 299# happyReduction_782 +happyReduction_782 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn315 + (sL1n happy_var_1 $! mkUnqual tvName (fsLit "safe") + )} + +happyReduce_783 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_783 = happySpecReduce_1 299# happyReduction_783 +happyReduction_783 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn315 + (sL1n happy_var_1 $! mkUnqual tvName (fsLit "interruptible") + )} + +happyReduce_784 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_784 = happySpecReduce_1 300# happyReduction_784 +happyReduction_784 happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + happyIn316 + (happy_var_1 + )} + +happyReduce_785 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_785 = happyMonadReduce 3# 300# happyReduction_785 +happyReduction_785 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn316 r)) + +happyReduce_786 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_786 = happySpecReduce_1 301# happyReduction_786 +happyReduction_786 happy_x_1 + = case happyOut319 happy_x_1 of { (HappyWrap319 happy_var_1) -> + happyIn317 + (happy_var_1 + )} + +happyReduce_787 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_787 = happyMonadReduce 3# 301# happyReduction_787 +happyReduction_787 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn317 r)) + +happyReduce_788 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_788 = happyMonadReduce 3# 301# happyReduction_788 +happyReduction_788 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut323 happy_x_2 of { (HappyWrap323 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn317 r)) + +happyReduce_789 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_789 = happySpecReduce_1 302# happyReduction_789 +happyReduction_789 happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + happyIn318 + (fmap (FieldLabelString . occNameFS . rdrNameOcc) happy_var_1 + )} + +happyReduce_790 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_790 = happySpecReduce_1 303# happyReduction_790 +happyReduction_790 happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + happyIn319 + (happy_var_1 + )} + +happyReduce_791 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_791 = happySpecReduce_1 303# happyReduction_791 +happyReduction_791 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn319 + (sL1n happy_var_1 $! mkQual varName (getQVARID happy_var_1) + )} + +happyReduce_792 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_792 = happySpecReduce_1 304# happyReduction_792 +happyReduction_792 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (getVARID happy_var_1) + )} + +happyReduce_793 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_793 = happySpecReduce_1 304# happyReduction_793 +happyReduction_793 happy_x_1 + = case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (unLoc happy_var_1) + )} + +happyReduce_794 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_794 = happySpecReduce_1 304# happyReduction_794 +happyReduction_794 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (fsLit "unsafe") + )} + +happyReduce_795 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_795 = happySpecReduce_1 304# happyReduction_795 +happyReduction_795 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (fsLit "safe") + )} + +happyReduce_796 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_796 = happySpecReduce_1 304# happyReduction_796 +happyReduction_796 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (fsLit "interruptible") + )} + +happyReduce_797 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_797 = happySpecReduce_1 304# happyReduction_797 +happyReduction_797 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (fsLit "family") + )} + +happyReduce_798 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_798 = happySpecReduce_1 304# happyReduction_798 +happyReduction_798 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (fsLit "role") + )} + +happyReduce_799 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_799 = happySpecReduce_1 305# happyReduction_799 +happyReduction_799 happy_x_1 + = case happyOut324 happy_x_1 of { (HappyWrap324 happy_var_1) -> + happyIn321 + (happy_var_1 + )} + +happyReduce_800 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_800 = happySpecReduce_1 305# happyReduction_800 +happyReduction_800 happy_x_1 + = case happyOut323 happy_x_1 of { (HappyWrap323 happy_var_1) -> + happyIn321 + (happy_var_1 + )} + +happyReduce_801 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_801 = happySpecReduce_1 306# happyReduction_801 +happyReduction_801 happy_x_1 + = case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> + happyIn322 + (happy_var_1 + )} + +happyReduce_802 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_802 = happySpecReduce_1 306# happyReduction_802 +happyReduction_802 happy_x_1 + = case happyOut323 happy_x_1 of { (HappyWrap323 happy_var_1) -> + happyIn322 + (happy_var_1 + )} + +happyReduce_803 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_803 = happySpecReduce_1 307# happyReduction_803 +happyReduction_803 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn323 + (sL1n happy_var_1 $ mkQual varName (getQVARSYM happy_var_1) + )} + +happyReduce_804 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_804 = happySpecReduce_1 308# happyReduction_804 +happyReduction_804 happy_x_1 + = case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> + happyIn324 + (happy_var_1 + )} + +happyReduce_805 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_805 = happySpecReduce_1 308# happyReduction_805 +happyReduction_805 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn324 + (sL1n happy_var_1 $ mkUnqual varName (fsLit "-") + )} + +happyReduce_806 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_806 = happySpecReduce_1 309# happyReduction_806 +happyReduction_806 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn325 + (sL1n happy_var_1 $ mkUnqual varName (getVARSYM happy_var_1) + )} + +happyReduce_807 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_807 = happySpecReduce_1 309# happyReduction_807 +happyReduction_807 happy_x_1 + = case happyOut327 happy_x_1 of { (HappyWrap327 happy_var_1) -> + happyIn325 + (sL1n happy_var_1 $ mkUnqual varName (unLoc happy_var_1) + )} + +happyReduce_808 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_808 = happySpecReduce_1 310# happyReduction_808 +happyReduction_808 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "as") + )} + +happyReduce_809 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_809 = happySpecReduce_1 310# happyReduction_809 +happyReduction_809 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "qualified") + )} + +happyReduce_810 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_810 = happySpecReduce_1 310# happyReduction_810 +happyReduction_810 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "hiding") + )} + +happyReduce_811 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_811 = happySpecReduce_1 310# happyReduction_811 +happyReduction_811 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "export") + )} + +happyReduce_812 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_812 = happySpecReduce_1 310# happyReduction_812 +happyReduction_812 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "label") + )} + +happyReduce_813 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_813 = happySpecReduce_1 310# happyReduction_813 +happyReduction_813 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "dynamic") + )} + +happyReduce_814 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_814 = happySpecReduce_1 310# happyReduction_814 +happyReduction_814 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "stdcall") + )} + +happyReduce_815 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_815 = happySpecReduce_1 310# happyReduction_815 +happyReduction_815 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "ccall") + )} + +happyReduce_816 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_816 = happySpecReduce_1 310# happyReduction_816 +happyReduction_816 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "capi") + )} + +happyReduce_817 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_817 = happySpecReduce_1 310# happyReduction_817 +happyReduction_817 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "prim") + )} + +happyReduce_818 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_818 = happySpecReduce_1 310# happyReduction_818 +happyReduction_818 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "javascript") + )} + +happyReduce_819 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_819 = happySpecReduce_1 310# happyReduction_819 +happyReduction_819 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "group") + )} + +happyReduce_820 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_820 = happySpecReduce_1 310# happyReduction_820 +happyReduction_820 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "stock") + )} + +happyReduce_821 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_821 = happySpecReduce_1 310# happyReduction_821 +happyReduction_821 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "anyclass") + )} + +happyReduce_822 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_822 = happySpecReduce_1 310# happyReduction_822 +happyReduction_822 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "via") + )} + +happyReduce_823 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_823 = happySpecReduce_1 310# happyReduction_823 +happyReduction_823 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "unit") + )} + +happyReduce_824 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_824 = happySpecReduce_1 310# happyReduction_824 +happyReduction_824 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "dependency") + )} + +happyReduce_825 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_825 = happySpecReduce_1 310# happyReduction_825 +happyReduction_825 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "signature") + )} + +happyReduce_826 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_826 = happySpecReduce_1 310# happyReduction_826 +happyReduction_826 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "quote") + )} + +happyReduce_827 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_827 = happySpecReduce_1 310# happyReduction_827 +happyReduction_827 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "splice") + )} + +happyReduce_828 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_828 = happySpecReduce_1 311# happyReduction_828 +happyReduction_828 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn327 + (sL1 happy_var_1 (fsLit ".") + )} + +happyReduce_829 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_829 = happySpecReduce_1 311# happyReduction_829 +happyReduction_829 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn327 + (sL1 happy_var_1 (starSym (isUnicode happy_var_1)) + )} + +happyReduce_830 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_830 = happySpecReduce_1 312# happyReduction_830 +happyReduction_830 happy_x_1 + = case happyOut329 happy_x_1 of { (HappyWrap329 happy_var_1) -> + happyIn328 + (happy_var_1 + )} + +happyReduce_831 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_831 = happySpecReduce_1 312# happyReduction_831 +happyReduction_831 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn328 + (sL1n happy_var_1 $! mkQual dataName (getQCONID happy_var_1) + )} + +happyReduce_832 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_832 = happySpecReduce_1 313# happyReduction_832 +happyReduction_832 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn329 + (sL1n happy_var_1 $ mkUnqual dataName (getCONID happy_var_1) + )} + +happyReduce_833 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_833 = happySpecReduce_1 314# happyReduction_833 +happyReduction_833 happy_x_1 + = case happyOut331 happy_x_1 of { (HappyWrap331 happy_var_1) -> + happyIn330 + (happy_var_1 + )} + +happyReduce_834 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_834 = happySpecReduce_1 314# happyReduction_834 +happyReduction_834 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn330 + (sL1n happy_var_1 $ mkQual dataName (getQCONSYM happy_var_1) + )} + +happyReduce_835 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_835 = happySpecReduce_1 315# happyReduction_835 +happyReduction_835 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn331 + (sL1n happy_var_1 $ mkUnqual dataName (getCONSYM happy_var_1) + )} + +happyReduce_836 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_836 = happySpecReduce_1 315# happyReduction_836 +happyReduction_836 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn331 + (sL1n happy_var_1 $ consDataCon_RDR + )} + +happyReduce_837 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_837 = happySpecReduce_1 316# happyReduction_837 +happyReduction_837 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsChar (getCHARs happy_var_1) $ getCHAR happy_var_1 + )} + +happyReduce_838 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_838 = happySpecReduce_1 316# happyReduction_838 +happyReduction_838 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsString (getSTRINGs happy_var_1) + $ getSTRING happy_var_1 + )} + +happyReduce_839 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_839 = happySpecReduce_1 316# happyReduction_839 +happyReduction_839 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsMultilineString (getSTRINGMULTIs happy_var_1) + $ getSTRINGMULTI happy_var_1 + )} + +happyReduce_840 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_840 = happySpecReduce_1 316# happyReduction_840 +happyReduction_840 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsIntPrim (getPRIMINTEGERs happy_var_1) + $ getPRIMINTEGER happy_var_1 + )} + +happyReduce_841 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_841 = happySpecReduce_1 316# happyReduction_841 +happyReduction_841 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsWordPrim (getPRIMWORDs happy_var_1) + $ getPRIMWORD happy_var_1 + )} + +happyReduce_842 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_842 = happySpecReduce_1 316# happyReduction_842 +happyReduction_842 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsInt8Prim (getPRIMINTEGER8s happy_var_1) + $ getPRIMINTEGER8 happy_var_1 + )} + +happyReduce_843 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_843 = happySpecReduce_1 316# happyReduction_843 +happyReduction_843 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsInt16Prim (getPRIMINTEGER16s happy_var_1) + $ getPRIMINTEGER16 happy_var_1 + )} + +happyReduce_844 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_844 = happySpecReduce_1 316# happyReduction_844 +happyReduction_844 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsInt32Prim (getPRIMINTEGER32s happy_var_1) + $ getPRIMINTEGER32 happy_var_1 + )} + +happyReduce_845 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_845 = happySpecReduce_1 316# happyReduction_845 +happyReduction_845 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsInt64Prim (getPRIMINTEGER64s happy_var_1) + $ getPRIMINTEGER64 happy_var_1 + )} + +happyReduce_846 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_846 = happySpecReduce_1 316# happyReduction_846 +happyReduction_846 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsWord8Prim (getPRIMWORD8s happy_var_1) + $ getPRIMWORD8 happy_var_1 + )} + +happyReduce_847 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_847 = happySpecReduce_1 316# happyReduction_847 +happyReduction_847 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsWord16Prim (getPRIMWORD16s happy_var_1) + $ getPRIMWORD16 happy_var_1 + )} + +happyReduce_848 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_848 = happySpecReduce_1 316# happyReduction_848 +happyReduction_848 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsWord32Prim (getPRIMWORD32s happy_var_1) + $ getPRIMWORD32 happy_var_1 + )} + +happyReduce_849 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_849 = happySpecReduce_1 316# happyReduction_849 +happyReduction_849 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsWord64Prim (getPRIMWORD64s happy_var_1) + $ getPRIMWORD64 happy_var_1 + )} + +happyReduce_850 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_850 = happySpecReduce_1 316# happyReduction_850 +happyReduction_850 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsCharPrim (getPRIMCHARs happy_var_1) + $ getPRIMCHAR happy_var_1 + )} + +happyReduce_851 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_851 = happySpecReduce_1 316# happyReduction_851 +happyReduction_851 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsStringPrim (getPRIMSTRINGs happy_var_1) + $ getPRIMSTRING happy_var_1 + )} + +happyReduce_852 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_852 = happySpecReduce_1 316# happyReduction_852 +happyReduction_852 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsFloatPrim noExtField $ getPRIMFLOAT happy_var_1 + )} + +happyReduce_853 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_853 = happySpecReduce_1 316# happyReduction_853 +happyReduction_853 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsDoublePrim noExtField $ getPRIMDOUBLE happy_var_1 + )} + +happyReduce_854 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_854 = happySpecReduce_1 317# happyReduction_854 +happyReduction_854 happy_x_1 + = happyIn333 + (() + ) + +happyReduce_855 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_855 = happyMonadReduce 1# 317# happyReduction_855 +happyReduction_855 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( popContext)) + ) (\r -> happyReturn (happyIn333 r)) + +happyReduce_856 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_856 = happySpecReduce_1 318# happyReduction_856 +happyReduction_856 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn334 + (sL1a happy_var_1 $ mkModuleNameFS (getCONID happy_var_1) + )} + +happyReduce_857 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_857 = happySpecReduce_1 318# happyReduction_857 +happyReduction_857 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn334 + (sL1a happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in + mkModuleNameFS + (concatFS [mod, fsLit ".", c]) + )} + +happyReduce_858 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_858 = happySpecReduce_2 319# happyReduction_858 +happyReduction_858 happy_x_2 + happy_x_1 + = case happyOut335 happy_x_1 of { (HappyWrap335 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn335 + ((foldr (NE.<|) (NE.singleton $ gl happy_var_2) (fst happy_var_1) ,snd happy_var_1 + 1) + )}} + +happyReduce_859 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_859 = happySpecReduce_1 319# happyReduction_859 +happyReduction_859 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn335 + ((NE.singleton $ gl happy_var_1, 1) + )} + +happyReduce_860 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_860 = happySpecReduce_1 320# happyReduction_860 +happyReduction_860 happy_x_1 + = case happyOut337 happy_x_1 of { (HappyWrap337 happy_var_1) -> + happyIn336 + (happy_var_1 + )} + +happyReduce_861 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_861 = happySpecReduce_0 320# happyReduction_861 +happyReduction_861 = happyIn336 + (([], 0) + ) + +happyReduce_862 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_862 = happySpecReduce_2 321# happyReduction_862 +happyReduction_862 happy_x_2 + happy_x_1 + = case happyOut337 happy_x_1 of { (HappyWrap337 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn337 + (((fst happy_var_1)++[epTok happy_var_2],snd happy_var_1 + 1) + )}} + +happyReduce_863 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_863 = happySpecReduce_1 321# happyReduction_863 +happyReduction_863 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn337 + (([epTok happy_var_1],1) + )} + +happyReduce_864 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_864 = happySpecReduce_3 322# happyReduction_864 +happyReduction_864 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut345 happy_x_2 of { (HappyWrap345 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn338 + (happy_var_2 >>= \ happy_var_2 -> amsr + (sLL happy_var_1 happy_var_3 (reverse (snd $ unLoc happy_var_2))) + (AnnList (Just $ glR happy_var_2) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) (fst $ unLoc happy_var_2) noAnn []) + )}}} + +happyReduce_865 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_865 = happySpecReduce_3 322# happyReduction_865 +happyReduction_865 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut345 happy_x_2 of { (HappyWrap345 happy_var_2) -> + happyIn338 + (happy_var_2 >>= \ happy_var_2 -> amsr + (L (getLoc happy_var_2) (reverse (snd $ unLoc happy_var_2))) + (AnnList (Just $ glR happy_var_2) ListNone (fst $ unLoc happy_var_2) noAnn []) + )} + +happyReduce_866 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_866 = happySpecReduce_2 322# happyReduction_866 +happyReduction_866 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn338 + (amsr (sLL happy_var_1 happy_var_2 []) (AnnList Nothing (ListBraces (epTok happy_var_1) (epTok happy_var_2)) [] noAnn []) + )}} + +happyReduce_867 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_867 = happySpecReduce_2 322# happyReduction_867 +happyReduction_867 happy_x_2 + happy_x_1 + = happyIn338 + (return $ noLocA [] + ) + +happyReduce_868 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_868 = happySpecReduce_3 323# happyReduction_868 +happyReduction_868 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut346 happy_x_2 of { (HappyWrap346 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn339 + (happy_var_2 >>= \ happy_var_2 -> amsr + (sLL happy_var_1 happy_var_3 (reverse (snd $ unLoc happy_var_2))) + (AnnList (Just $ glR happy_var_2) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) (fst $ unLoc happy_var_2) noAnn []) + )}}} + +happyReduce_869 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_869 = happySpecReduce_3 323# happyReduction_869 +happyReduction_869 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut346 happy_x_2 of { (HappyWrap346 happy_var_2) -> + happyIn339 + (happy_var_2 >>= \ happy_var_2 -> amsr + (L (getLoc happy_var_2) (reverse (snd $ unLoc happy_var_2))) + (AnnList (Just $ glR happy_var_2) ListNone (fst $ unLoc happy_var_2) noAnn []) + )} + +happyReduce_870 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_870 = happySpecReduce_2 323# happyReduction_870 +happyReduction_870 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn339 + (amsr (sLL happy_var_1 happy_var_2 []) (AnnList Nothing (ListBraces (epTok happy_var_1) (epTok happy_var_2)) [] noAnn []) + )}} + +happyReduce_871 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_871 = happySpecReduce_2 323# happyReduction_871 +happyReduction_871 happy_x_2 + happy_x_1 + = happyIn339 + (return $ noLocA [] + ) + +happyReduce_872 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_872 = happySpecReduce_3 324# happyReduction_872 +happyReduction_872 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + happyIn340 + (ECP $ + unECP happy_var_1 >>= \ happy_var_1 -> + rejectPragmaPV happy_var_1 >> + mkHsTySigPV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) happy_var_1 happy_var_3 + (epUniTok happy_var_2) + )}}} + +happyReduce_873 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_873 = happyMonadReduce 3# 324# happyReduction_873 +happyReduction_873 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut340 happy_x_3 of { (HappyWrap340 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_1 happy_var_3 + HsFirstOrderApp True))}}}) + ) (\r -> happyReturn (happyIn340 r)) + +happyReduce_874 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_874 = happyMonadReduce 3# 324# happyReduction_874 +happyReduction_874 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut340 happy_x_3 of { (HappyWrap340 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_3 happy_var_1 + HsFirstOrderApp False))}}}) + ) (\r -> happyReturn (happyIn340 r)) + +happyReduce_875 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_875 = happyMonadReduce 3# 324# happyReduction_875 +happyReduction_875 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut340 happy_x_3 of { (HappyWrap340 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_1 happy_var_3 + HsHigherOrderApp True))}}}) + ) (\r -> happyReturn (happyIn340 r)) + +happyReduce_876 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_876 = happyMonadReduce 3# 324# happyReduction_876 +happyReduction_876 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut340 happy_x_3 of { (HappyWrap340 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_3 happy_var_1 + HsHigherOrderApp False))}}}) + ) (\r -> happyReturn (happyIn340 r)) + +happyReduce_877 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_877 = happySpecReduce_1 324# happyReduction_877 +happyReduction_877 happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + happyIn340 + (happy_var_1 + )} + +happyReduce_878 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_878 = happySpecReduce_1 324# happyReduction_878 +happyReduction_878 happy_x_1 + = case happyOut348 happy_x_1 of { (HappyWrap348 happy_var_1) -> + happyIn340 + (happy_var_1 + )} + +happyReduce_879 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_879 = happySpecReduce_2 324# happyReduction_879 +happyReduction_879 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + happyIn340 + (ECP $ mkHsEmbTyPV (comb2 happy_var_1 happy_var_2) (epTok happy_var_1) happy_var_2 + )}} + +happyReduce_880 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_880 = happySpecReduce_3 325# happyReduction_880 +happyReduction_880 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + happyIn341 + (ECP $ + unECP happy_var_1 >>= \ happy_var_1 -> + rejectPragmaPV happy_var_1 >> + mkHsTySigPV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) happy_var_1 happy_var_3 + (epUniTok happy_var_2) + )}}} + +happyReduce_881 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_881 = happyMonadReduce 3# 325# happyReduction_881 +happyReduction_881 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut341 happy_x_3 of { (HappyWrap341 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_1 happy_var_3 + HsFirstOrderApp True))}}}) + ) (\r -> happyReturn (happyIn341 r)) + +happyReduce_882 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_882 = happyMonadReduce 3# 325# happyReduction_882 +happyReduction_882 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut341 happy_x_3 of { (HappyWrap341 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_3 happy_var_1 + HsFirstOrderApp False))}}}) + ) (\r -> happyReturn (happyIn341 r)) + +happyReduce_883 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_883 = happyMonadReduce 3# 325# happyReduction_883 +happyReduction_883 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut341 happy_x_3 of { (HappyWrap341 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_1 happy_var_3 + HsHigherOrderApp True))}}}) + ) (\r -> happyReturn (happyIn341 r)) + +happyReduce_884 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_884 = happyMonadReduce 3# 325# happyReduction_884 +happyReduction_884 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut341 happy_x_3 of { (HappyWrap341 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_3 happy_var_1 + HsHigherOrderApp False))}}}) + ) (\r -> happyReturn (happyIn341 r)) + +happyReduce_885 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_885 = happySpecReduce_1 325# happyReduction_885 +happyReduction_885 happy_x_1 + = case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + happyIn341 + (happy_var_1 + )} + +happyReduce_886 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_886 = happySpecReduce_1 325# happyReduction_886 +happyReduction_886 happy_x_1 + = case happyOut347 happy_x_1 of { (HappyWrap347 happy_var_1) -> + happyIn341 + (happy_var_1 + )} + +happyReduce_887 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_887 = happySpecReduce_2 325# happyReduction_887 +happyReduction_887 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + happyIn341 + (ECP $ mkHsEmbTyPV (comb2 happy_var_1 happy_var_2) (epTok happy_var_1) happy_var_2 + )}} + +happyReduce_888 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_888 = happyMonadReduce 2# 326# happyReduction_888 +happyReduction_888 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> + case happyOut225 happy_x_2 of { (HappyWrap225 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' $ (sLL happy_var_1 happy_var_2 $ HsPragE noExtField (unLoc happy_var_1) happy_var_2))}}) + ) (\r -> happyReturn (happyIn342 r)) + +happyReduce_889 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_889 = happyMonadReduce 1# 327# happyReduction_889 +happyReduction_889 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> + ( do + { pat <- (checkPattern <=< runPV) (unECP happy_var_1) + ; return (sL1 pat (NE.singleton pat)) })}) + ) (\r -> happyReturn (happyIn343 r)) + +happyReduce_890 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_890 = happyMonadReduce 3# 327# happyReduction_890 +happyReduction_890 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut343 happy_x_3 of { (HappyWrap343 happy_var_3) -> + ( do + { pat <- (checkPattern <=< runPV) (unECP happy_var_1) + ; pat <- addTrailingSemiA pat (epTok happy_var_2) + ; return (sLL pat happy_var_3 (pat NE.<| unLoc happy_var_3)) })}}}) + ) (\r -> happyReturn (happyIn343 r)) + +happyReduce_891 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_891 = happyMonadReduce 1# 328# happyReduction_891 +happyReduction_891 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut222 happy_x_1 of { (HappyWrap222 happy_var_1) -> + ( do + { pat <- (checkPattern <=< runPV) (unECP happy_var_1) + ; return (sL1 pat (NE.singleton pat)) })}) + ) (\r -> happyReturn (happyIn344 r)) + +happyReduce_892 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_892 = happyMonadReduce 3# 328# happyReduction_892 +happyReduction_892 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut222 happy_x_1 of { (HappyWrap222 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut344 happy_x_3 of { (HappyWrap344 happy_var_3) -> + ( do + { pat <- (checkPattern <=< runPV) (unECP happy_var_1) + ; pat <- addTrailingSemiA pat (epTok happy_var_2) + ; return (sLL pat happy_var_3 (pat NE.<| unLoc happy_var_3)) })}}}) + ) (\r -> happyReturn (happyIn344 r)) + +happyReduce_893 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_893 = happySpecReduce_1 329# happyReduction_893 +happyReduction_893 happy_x_1 + = case happyOut349 happy_x_1 of { (HappyWrap349 happy_var_1) -> + happyIn345 + (happy_var_1 >>= \ happy_var_1 -> return $ + sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) + )} + +happyReduce_894 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_894 = happySpecReduce_2 329# happyReduction_894 +happyReduction_894 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut345 happy_x_2 of { (HappyWrap345 happy_var_2) -> + happyIn345 + (happy_var_2 >>= \ happy_var_2 -> return $ + sLL happy_var_1 happy_var_2 (((mzEpTok happy_var_1) : (fst $ unLoc happy_var_2) ) + ,snd $ unLoc happy_var_2) + )}} + +happyReduce_895 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_895 = happySpecReduce_1 330# happyReduction_895 +happyReduction_895 happy_x_1 + = case happyOut350 happy_x_1 of { (HappyWrap350 happy_var_1) -> + happyIn346 + (happy_var_1 >>= \ happy_var_1 -> return $ + sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) + )} + +happyReduce_896 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_896 = happySpecReduce_2 330# happyReduction_896 +happyReduction_896 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut346 happy_x_2 of { (HappyWrap346 happy_var_2) -> + happyIn346 + (happy_var_2 >>= \ happy_var_2 -> return $ + sLL happy_var_1 happy_var_2 (((mzEpTok happy_var_1) : (fst $ unLoc happy_var_2) ) + ,snd $ unLoc happy_var_2) + )}} + +happyReduce_897 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_897 = happyMonadReduce 2# 331# happyReduction_897 +happyReduction_897 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> + case happyOut341 happy_x_2 of { (HappyWrap341 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' $ (sLL happy_var_1 happy_var_2 $ HsPragE noExtField (unLoc happy_var_1) happy_var_2))}}) + ) (\r -> happyReturn (happyIn347 r)) + +happyReduce_898 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_898 = happyMonadReduce 2# 332# happyReduction_898 +happyReduction_898 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> + case happyOut340 happy_x_2 of { (HappyWrap340 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' $ (sLL happy_var_1 happy_var_2 $ HsPragE noExtField (unLoc happy_var_1) happy_var_2))}}) + ) (\r -> happyReturn (happyIn348 r)) + +happyReduce_899 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_899 = happySpecReduce_3 333# happyReduction_899 +happyReduction_899 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut349 happy_x_1 of { (HappyWrap349 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut351 happy_x_3 of { (HappyWrap351 happy_var_3) -> + happyIn349 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> + case snd $ unLoc happy_var_1 of + [] -> return (sLL happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,[happy_var_3])) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,happy_var_3 : h' : t)) + )}}} + +happyReduce_900 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_900 = happySpecReduce_2 333# happyReduction_900 +happyReduction_900 happy_x_2 + happy_x_1 + = case happyOut349 happy_x_1 of { (HappyWrap349 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn349 + (happy_var_1 >>= \ happy_var_1 -> + case snd $ unLoc happy_var_1 of + [] -> return (sLZ happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,[])) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (fst $ unLoc happy_var_1, h' : t)) + )}} + +happyReduce_901 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_901 = happySpecReduce_1 333# happyReduction_901 +happyReduction_901 happy_x_1 + = case happyOut351 happy_x_1 of { (HappyWrap351 happy_var_1) -> + happyIn349 + (happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 ([],[happy_var_1]) + )} + +happyReduce_902 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_902 = happySpecReduce_3 334# happyReduction_902 +happyReduction_902 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut350 happy_x_1 of { (HappyWrap350 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut352 happy_x_3 of { (HappyWrap352 happy_var_3) -> + happyIn350 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> + case snd $ unLoc happy_var_1 of + [] -> return (sLL happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,[happy_var_3])) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,happy_var_3 : h' : t)) + )}}} + +happyReduce_903 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_903 = happySpecReduce_2 334# happyReduction_903 +happyReduction_903 happy_x_2 + happy_x_1 + = case happyOut350 happy_x_1 of { (HappyWrap350 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn350 + (happy_var_1 >>= \ happy_var_1 -> + case snd $ unLoc happy_var_1 of + [] -> return (sLZ happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,[])) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (fst $ unLoc happy_var_1, h' : t)) + )}} + +happyReduce_904 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_904 = happySpecReduce_1 334# happyReduction_904 +happyReduction_904 happy_x_1 + = case happyOut352 happy_x_1 of { (HappyWrap352 happy_var_1) -> + happyIn350 + (happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 ([],[happy_var_1]) + )} + +happyReduce_905 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_905 = happySpecReduce_2 335# happyReduction_905 +happyReduction_905 happy_x_2 + happy_x_1 + = case happyOut263 happy_x_1 of { (HappyWrap263 happy_var_1) -> + case happyOut253 happy_x_2 of { (HappyWrap253 happy_var_2) -> + happyIn351 + (happy_var_2 >>= \ happy_var_2 -> + amsA' (sLLAsl happy_var_1 happy_var_2 + (Match { m_ext = noExtField + , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing + , m_pats = L (listLocation happy_var_1) happy_var_1 + , m_grhss = unLoc happy_var_2 })) + )}} + +happyReduce_906 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_906 = happySpecReduce_2 336# happyReduction_906 +happyReduction_906 happy_x_2 + happy_x_1 + = case happyOut260 happy_x_1 of { (HappyWrap260 happy_var_1) -> + case happyOut253 happy_x_2 of { (HappyWrap253 happy_var_2) -> + happyIn352 + (happy_var_2 >>= \ happy_var_2 -> + amsA' (sLLAsl happy_var_1 happy_var_2 + (Match { m_ext = noExtField + , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing + , m_pats = L (listLocation happy_var_1) happy_var_1 + , m_grhss = unLoc happy_var_2 })) + )}} + +happyNewToken action sts stk + = (lexer True)(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + L _ ITeof -> happyDoAction 161# tk action sts stk; + L _ ITunderscore -> cont 1#; + L _ ITas -> cont 2#; + L _ ITcase -> cont 3#; + L _ ITclass -> cont 4#; + L _ ITdata -> cont 5#; + L _ ITdefault -> cont 6#; + L _ ITderiving -> cont 7#; + L _ ITelse -> cont 8#; + L _ IThiding -> cont 9#; + L _ ITif -> cont 10#; + L _ ITimport -> cont 11#; + L _ ITin -> cont 12#; + L _ ITinfix -> cont 13#; + L _ ITinfixl -> cont 14#; + L _ ITinfixr -> cont 15#; + L _ ITinstance -> cont 16#; + L _ ITlet -> cont 17#; + L _ ITmodule -> cont 18#; + L _ ITnewtype -> cont 19#; + L _ ITof -> cont 20#; + L _ ITqualified -> cont 21#; + L _ ITthen -> cont 22#; + L _ ITtype -> cont 23#; + L _ ITwhere -> cont 24#; + L _ (ITforall _) -> cont 25#; + L _ ITforeign -> cont 26#; + L _ ITexport -> cont 27#; + L _ ITlabel -> cont 28#; + L _ ITdynamic -> cont 29#; + L _ ITsafe -> cont 30#; + L _ ITinterruptible -> cont 31#; + L _ ITunsafe -> cont 32#; + L _ ITfamily -> cont 33#; + L _ ITrole -> cont 34#; + L _ ITstdcallconv -> cont 35#; + L _ ITccallconv -> cont 36#; + L _ ITcapiconv -> cont 37#; + L _ ITprimcallconv -> cont 38#; + L _ ITjavascriptcallconv -> cont 39#; + L _ ITproc -> cont 40#; + L _ ITrec -> cont 41#; + L _ ITgroup -> cont 42#; + L _ ITby -> cont 43#; + L _ ITusing -> cont 44#; + L _ ITpattern -> cont 45#; + L _ ITstatic -> cont 46#; + L _ ITstock -> cont 47#; + L _ ITanyclass -> cont 48#; + L _ ITvia -> cont 49#; + L _ ITsplice -> cont 50#; + L _ ITquote -> cont 51#; + L _ ITunit -> cont 52#; + L _ ITsignature -> cont 53#; + L _ ITdependency -> cont 54#; + L _ (ITinline_prag _ _ _) -> cont 55#; + L _ (ITopaque_prag _) -> cont 56#; + L _ (ITspec_prag _) -> cont 57#; + L _ (ITspec_inline_prag _ _) -> cont 58#; + L _ (ITsource_prag _) -> cont 59#; + L _ (ITrules_prag _) -> cont 60#; + L _ (ITscc_prag _) -> cont 61#; + L _ (ITdeprecated_prag _) -> cont 62#; + L _ (ITwarning_prag _) -> cont 63#; + L _ (ITunpack_prag _) -> cont 64#; + L _ (ITnounpack_prag _) -> cont 65#; + L _ (ITann_prag _) -> cont 66#; + L _ (ITminimal_prag _) -> cont 67#; + L _ (ITctype _) -> cont 68#; + L _ (IToverlapping_prag _) -> cont 69#; + L _ (IToverlappable_prag _) -> cont 70#; + L _ (IToverlaps_prag _) -> cont 71#; + L _ (ITincoherent_prag _) -> cont 72#; + L _ (ITcomplete_prag _) -> cont 73#; + L _ ITclose_prag -> cont 74#; + L _ ITdotdot -> cont 75#; + L _ ITcolon -> cont 76#; + L _ (ITdcolon _) -> cont 77#; + L _ ITequal -> cont 78#; + L _ ITlam -> cont 79#; + L _ ITlcase -> cont 80#; + L _ ITlcases -> cont 81#; + L _ ITvbar -> cont 82#; + L _ (ITlarrow _) -> cont 83#; + L _ (ITrarrow _) -> cont 84#; + L _ ITlolly -> cont 85#; + L _ ITat -> cont 86#; + L _ (ITdarrow _) -> cont 87#; + L _ ITminus -> cont 88#; + L _ ITtilde -> cont 89#; + L _ ITbang -> cont 90#; + L _ ITprefixminus -> cont 91#; + L _ (ITstar _) -> cont 92#; + L _ (ITlarrowtail _) -> cont 93#; + L _ (ITrarrowtail _) -> cont 94#; + L _ (ITLarrowtail _) -> cont 95#; + L _ (ITRarrowtail _) -> cont 96#; + L _ ITdot -> cont 97#; + L _ (ITproj True) -> cont 98#; + L _ (ITproj False) -> cont 99#; + L _ ITtypeApp -> cont 100#; + L _ ITpercent -> cont 101#; + L _ ITocurly -> cont 102#; + L _ ITccurly -> cont 103#; + L _ ITvocurly -> cont 104#; + L _ ITvccurly -> cont 105#; + L _ ITobrack -> cont 106#; + L _ ITcbrack -> cont 107#; + L _ IToparen -> cont 108#; + L _ ITcparen -> cont 109#; + L _ IToubxparen -> cont 110#; + L _ ITcubxparen -> cont 111#; + L _ (IToparenbar _) -> cont 112#; + L _ (ITcparenbar _) -> cont 113#; + L _ ITsemi -> cont 114#; + L _ ITcomma -> cont 115#; + L _ ITbackquote -> cont 116#; + L _ ITsimpleQuote -> cont 117#; + L _ (ITvarid _) -> cont 118#; + L _ (ITconid _) -> cont 119#; + L _ (ITvarsym _) -> cont 120#; + L _ (ITconsym _) -> cont 121#; + L _ (ITqvarid _) -> cont 122#; + L _ (ITqconid _) -> cont 123#; + L _ (ITqvarsym _) -> cont 124#; + L _ (ITqconsym _) -> cont 125#; + L _ (ITdo _) -> cont 126#; + L _ (ITmdo _) -> cont 127#; + L _ (ITdupipvarid _) -> cont 128#; + L _ (ITlabelvarid _ _) -> cont 129#; + L _ (ITchar _ _) -> cont 130#; + L _ (ITstring _ _) -> cont 131#; + L _ (ITstringMulti _ _) -> cont 132#; + L _ (ITinteger _) -> cont 133#; + L _ (ITrational _) -> cont 134#; + L _ (ITprimchar _ _) -> cont 135#; + L _ (ITprimstring _ _) -> cont 136#; + L _ (ITprimint _ _) -> cont 137#; + L _ (ITprimword _ _) -> cont 138#; + L _ (ITprimint8 _ _) -> cont 139#; + L _ (ITprimint16 _ _) -> cont 140#; + L _ (ITprimint32 _ _) -> cont 141#; + L _ (ITprimint64 _ _) -> cont 142#; + L _ (ITprimword8 _ _) -> cont 143#; + L _ (ITprimword16 _ _) -> cont 144#; + L _ (ITprimword32 _ _) -> cont 145#; + L _ (ITprimword64 _ _) -> cont 146#; + L _ (ITprimfloat _) -> cont 147#; + L _ (ITprimdouble _) -> cont 148#; + L _ (ITopenExpQuote _ _) -> cont 149#; + L _ ITopenPatQuote -> cont 150#; + L _ ITopenTypQuote -> cont 151#; + L _ ITopenDecQuote -> cont 152#; + L _ (ITcloseQuote _) -> cont 153#; + L _ (ITopenTExpQuote _) -> cont 154#; + L _ ITcloseTExpQuote -> cont 155#; + L _ ITdollar -> cont 156#; + L _ ITdollardollar -> cont 157#; + L _ ITtyQuote -> cont 158#; + L _ (ITquasiQuote _) -> cont 159#; + L _ (ITqQuasiQuote _) -> cont 160#; + _ -> happyError' (tk, []) + }) + +happyError_ explist 161# tk = happyError' (tk, explist) +happyError_ explist _ tk = happyError' (tk, explist) + +happyThen :: () => P a -> (a -> P b) -> P b +happyThen = (>>=) +happyReturn :: () => a -> P a +happyReturn = (return) +happyParse :: () => Happy_GHC_Exts.Int# -> P (HappyAbsSyn ) + +happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) + +happyDoAction :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) + +happyReduceArr :: () => Happy_Data_Array.Array Prelude.Int (Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )) + +happyThen1 :: () => P a -> (a -> P b) -> P b +happyThen1 = happyThen +happyReturn1 :: () => a -> P a +happyReturn1 = happyReturn +happyError' :: () => (((Located Token)), [Prelude.String]) -> P a +happyError' tk = (\(tokens, explist) -> happyError) tk +parseModuleNoHaddock = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (let {(HappyWrap35 x') = happyOut35 x} in x')) + +parseSignatureNoHaddock = happySomeParser where + happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (let {(HappyWrap34 x') = happyOut34 x} in x')) + +parseImport = happySomeParser where + happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (let {(HappyWrap62 x') = happyOut62 x} in x')) + +parseStatement = happySomeParser where + happySomeParser = happyThen (happyParse 3#) (\x -> happyReturn (let {(HappyWrap268 x') = happyOut268 x} in x')) + +parseDeclaration = happySomeParser where + happySomeParser = happyThen (happyParse 4#) (\x -> happyReturn (let {(HappyWrap82 x') = happyOut82 x} in x')) + +parseExpression = happySomeParser where + happySomeParser = happyThen (happyParse 5#) (\x -> happyReturn (let {(HappyWrap221 x') = happyOut221 x} in x')) + +parsePattern = happySomeParser where + happySomeParser = happyThen (happyParse 6#) (\x -> happyReturn (let {(HappyWrap259 x') = happyOut259 x} in x')) + +parseTypeSignature = happySomeParser where + happySomeParser = happyThen (happyParse 7#) (\x -> happyReturn (let {(HappyWrap216 x') = happyOut216 x} in x')) + +parseStmt = happySomeParser where + happySomeParser = happyThen (happyParse 8#) (\x -> happyReturn (let {(HappyWrap267 x') = happyOut267 x} in x')) + +parseIdentifier = happySomeParser where + happySomeParser = happyThen (happyParse 9#) (\x -> happyReturn (let {(HappyWrap16 x') = happyOut16 x} in x')) + +parseType = happySomeParser where + happySomeParser = happyThen (happyParse 10#) (\x -> happyReturn (let {(HappyWrap168 x') = happyOut168 x} in x')) + +parseBackpack = happySomeParser where + happySomeParser = happyThen (happyParse 11#) (\x -> happyReturn (let {(HappyWrap17 x') = happyOut17 x} in x')) + +parseHeader = happySomeParser where + happySomeParser = happyThen (happyParse 12#) (\x -> happyReturn (let {(HappyWrap42 x') = happyOut42 x} in x')) + +happySeq = happyDoSeq + + +happyError :: P a +happyError = srcParseFail + +getVARID (L _ (ITvarid x)) = x +getCONID (L _ (ITconid x)) = x +getVARSYM (L _ (ITvarsym x)) = x +getCONSYM (L _ (ITconsym x)) = x +getDO (L _ (ITdo x)) = x +getMDO (L _ (ITmdo x)) = x +getQVARID (L _ (ITqvarid x)) = x +getQCONID (L _ (ITqconid x)) = x +getQVARSYM (L _ (ITqvarsym x)) = x +getQCONSYM (L _ (ITqconsym x)) = x +getIPDUPVARID (L _ (ITdupipvarid x)) = x +getLABELVARID (L _ (ITlabelvarid _ x)) = x +getCHAR (L _ (ITchar _ x)) = x +getSTRING (L _ (ITstring _ x)) = x +getSTRINGMULTI (L _ (ITstringMulti _ x)) = x +getINTEGER (L _ (ITinteger x)) = x +getRATIONAL (L _ (ITrational x)) = x +getPRIMCHAR (L _ (ITprimchar _ x)) = x +getPRIMSTRING (L _ (ITprimstring _ x)) = x +getPRIMINTEGER (L _ (ITprimint _ x)) = x +getPRIMWORD (L _ (ITprimword _ x)) = x +getPRIMINTEGER8 (L _ (ITprimint8 _ x)) = x +getPRIMINTEGER16 (L _ (ITprimint16 _ x)) = x +getPRIMINTEGER32 (L _ (ITprimint32 _ x)) = x +getPRIMINTEGER64 (L _ (ITprimint64 _ x)) = x +getPRIMWORD8 (L _ (ITprimword8 _ x)) = x +getPRIMWORD16 (L _ (ITprimword16 _ x)) = x +getPRIMWORD32 (L _ (ITprimword32 _ x)) = x +getPRIMWORD64 (L _ (ITprimword64 _ x)) = x +getPRIMFLOAT (L _ (ITprimfloat x)) = x +getPRIMDOUBLE (L _ (ITprimdouble x)) = x +getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) +getSPEC_INLINE (L _ (ITspec_inline_prag src True)) = (Inline src,FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike) +getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x +getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l + +getINTEGERs (L _ (ITinteger (IL src _ _))) = src +getCHARs (L _ (ITchar src _)) = src +getSTRINGs (L _ (ITstring src _)) = src +getSTRINGMULTIs (L _ (ITstringMulti src _)) = src +getPRIMCHARs (L _ (ITprimchar src _)) = src +getPRIMSTRINGs (L _ (ITprimstring src _)) = src +getPRIMINTEGERs (L _ (ITprimint src _)) = src +getPRIMWORDs (L _ (ITprimword src _)) = src +getPRIMINTEGER8s (L _ (ITprimint8 src _)) = src +getPRIMINTEGER16s (L _ (ITprimint16 src _)) = src +getPRIMINTEGER32s (L _ (ITprimint32 src _)) = src +getPRIMINTEGER64s (L _ (ITprimint64 src _)) = src +getPRIMWORD8s (L _ (ITprimword8 src _)) = src +getPRIMWORD16s (L _ (ITprimword16 src _)) = src +getPRIMWORD32s (L _ (ITprimword32 src _)) = src +getPRIMWORD64s (L _ (ITprimword64 src _)) = src + +getLABELVARIDs (L _ (ITlabelvarid src _)) = src + +-- See Note [Pragma source text] in "GHC.Types.SourceText" for the following +getINLINE_PRAGs (L _ (ITinline_prag _ inl _)) = inlineSpecSource inl +getOPAQUE_PRAGs (L _ (ITopaque_prag src)) = src +getSPEC_PRAGs (L _ (ITspec_prag src)) = src +getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src +getSOURCE_PRAGs (L _ (ITsource_prag src)) = src +getRULES_PRAGs (L _ (ITrules_prag src)) = src +getWARNING_PRAGs (L _ (ITwarning_prag src)) = src +getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src +getSCC_PRAGs (L _ (ITscc_prag src)) = src +getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src +getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src +getANN_PRAGs (L _ (ITann_prag src)) = src +getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src +getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src +getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src +getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src +getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src +getCTYPEs (L _ (ITctype src)) = src + +getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing +getStringMultiLiteral l = StringLiteral (getSTRINGMULTIs l) (getSTRINGMULTI l) Nothing + +isUnicode :: Located Token -> Bool +isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax +isUnicode (L _ ITlolly) = True +isUnicode _ = False + +hasE :: Located Token -> Bool +hasE (L _ (ITopenExpQuote HasE _)) = True +hasE (L _ (ITopenTExpQuote HasE)) = True +hasE _ = False + +getSCC :: Located Token -> P FastString +getSCC lt = do let s = getSTRING lt + -- We probably actually want to be more restrictive than this + if ' ' `elem` unpackFS s + then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC + else return s + +stringLiteralToHsDocWst :: Located StringLiteral -> LocatedE (WithHsDocIdentifiers StringLiteral GhcPs) +stringLiteralToHsDocWst sl = reLoc $ lexStringLiteral parseIdentifier sl + +-- Utilities for combining source spans +comb2 :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan +comb2 !a !b = combineHasLocs a b + +comb3 :: (HasLoc a, HasLoc b, HasLoc c) => a -> b -> c -> SrcSpan +comb3 !a !b !c = combineSrcSpans (getHasLoc a) (combineHasLocs b c) + +comb4 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d) => a -> b -> c -> d -> SrcSpan +comb4 !a !b !c !d = + combineSrcSpans (getHasLoc a) $ + combineSrcSpans (getHasLoc b) $ + combineSrcSpans (getHasLoc c) (getHasLoc d) + +comb5 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d, HasLoc e) => a -> b -> c -> d -> e -> SrcSpan +comb5 !a !b !c !d !e = + combineSrcSpans (getHasLoc a) $ + combineSrcSpans (getHasLoc b) $ + combineSrcSpans (getHasLoc c) $ + combineSrcSpans (getHasLoc d) (getHasLoc e) + +comb6 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d, HasLoc e, HasLoc f) => a -> b -> c -> d -> e -> f -> SrcSpan +comb6 !a !b !c !d !e !f = + combineSrcSpans (getHasLoc a) $ + combineSrcSpans (getHasLoc b) $ + combineSrcSpans (getHasLoc c) $ + combineSrcSpans (getHasLoc d) $ + combineSrcSpans (getHasLoc e) (getHasLoc f) + +-- strict constructor version: +{-# INLINE sL #-} +sL :: l -> a -> GenLocated l a +sL !loc !a = L loc a + +-- See Note [Adding location info] for how these utility functions are used + +-- replaced last 3 CPP macros in this file +{-# INLINE sL0 #-} +sL0 :: a -> Located a +sL0 = L noSrcSpan -- #define L0 L noSrcSpan + +{-# INLINE sL1 #-} +sL1 :: HasLoc a => a -> b -> Located b +sL1 !x = sL (getHasLoc x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sL1a #-} +sL1a :: (HasLoc a, HasAnnotation t) => a -> b -> GenLocated t b +sL1a !x = sL (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sL1n #-} +sL1n :: HasLoc a => a -> b -> LocatedN b +sL1n !x = L (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sLL #-} +sLL :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c +sLL !x !y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) + +{-# INLINE sLLa #-} +sLLa :: (HasLoc a, HasLoc b, NoAnn t) => a -> b -> c -> LocatedAn t c +sLLa !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) + +{-# INLINE sLLl #-} +sLLl :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedL c +sLLl !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) + +{-# INLINE sLLld #-} +sLLld :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedLW c +sLLld !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) + +{-# INLINE sLLAsl #-} +sLLAsl :: (HasLoc a) => [a] -> Located b -> c -> Located c +sLLAsl [] = sL1 +sLLAsl (!x:_) = sLL x + +{-# INLINE sLZ #-} +sLZ :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c +sLZ !x !y = if isZeroWidthSpan (getHasLoc y) + then sL (getHasLoc x) + else sL (comb2 x y) + +{- Note [Adding location info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This is done using the three functions below, sL0, sL1 +and sLL. Note that these functions were mechanically +converted from the three macros that used to exist before, +namely L0, L1 and LL. + +They each add a SrcSpan to their argument. + + sL0 adds 'noSrcSpan', used for empty productions + -- This doesn't seem to work anymore -=chak + + sL1 for a production with a single token on the lhs. Grabs the SrcSpan + from that token. + + sLL for a production with >1 token on the lhs. Makes up a SrcSpan from + the first and last tokens. + +These suffice for the majority of cases. However, we must be +especially careful with empty productions: sLL won't work if the first +or last token on the lhs can represent an empty span. In these cases, +we have to calculate the span using more of the tokens from the lhs, eg. + + | 'newtype' tycl_hdr '=' newconstr deriving + { L (comb3 $1 $4 $5) + (mkTyData NewType (unLoc $2) $4 (unLoc $5)) } + +We provide comb3 and comb4 functions which are useful in such cases. + +Be careful: there's no checking that you actually got this right, the +only symptom will be that the SrcSpans of your syntax will be +incorrect. + +-} + +-- Make a source location for the file. We're a bit lazy here and just +-- make a point SrcSpan at line 1, column 0. Strictly speaking we should +-- try to find the span of the whole file (ToDo). +fileSrcSpan :: P SrcSpan +fileSrcSpan = do + l <- getRealSrcLoc; + let loc = mkSrcLoc (srcLocFile l) 1 1; + return (mkSrcSpan loc loc) + +-- Hint about linear types +hintLinear :: MonadP m => SrcSpan -> m () +hintLinear span = do + linearEnabled <- getBit LinearTypesBit + unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction + +-- Does this look like (a %m)? +looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool +looksLikeMult ty1 l_op ty2 + | Unqual op_name <- unLoc l_op + , occNameFS op_name == fsLit "%" + , Strict.Just ty1_pos <- getBufSpan (getLocA ty1) + , Strict.Just pct_pos <- getBufSpan (getLocA l_op) + , Strict.Just ty2_pos <- getBufSpan (getLocA ty2) + , bufSpanEnd ty1_pos /= bufSpanStart pct_pos + , bufSpanEnd pct_pos == bufSpanStart ty2_pos + = True + | otherwise = False + +-- Hint about or-patterns +hintOrPats :: MonadP m => LPat GhcPs -> m (LPat GhcPs) +hintOrPats pat = do + orPatsEnabled <- getBit OrPatternsBit + unless orPatsEnabled $ addError $ mkPlainErrorMsgEnvelope (locA (getLoc pat)) $ PsErrIllegalOrPat pat + return pat + +-- Hint about the MultiWayIf extension +hintMultiWayIf :: SrcSpan -> P () +hintMultiWayIf span = do + mwiEnabled <- getBit MultiWayIfBit + unless mwiEnabled $ addError $ mkPlainErrorMsgEnvelope span PsErrMultiWayIf + +-- Hint about explicit-forall +hintExplicitForall :: Located Token -> P () +hintExplicitForall tok = do + explicit_forall_enabled <- getBit ExplicitForallBit + in_rule_prag <- getBit InRulePragBit + unless (explicit_forall_enabled || in_rule_prag) $ + addError $ mkPlainErrorMsgEnvelope (getLoc tok) $ + PsErrExplicitForall (isUnicode tok) + +-- Hint about qualified-do +hintQualifiedDo :: Located Token -> P () +hintQualifiedDo tok = do + qualifiedDo <- getBit QualifiedDoBit + case maybeQDoDoc of + Just qdoDoc | not qualifiedDo -> + addError $ mkPlainErrorMsgEnvelope (getLoc tok) $ + (PsErrIllegalQualifiedDo qdoDoc) + _ -> return () + where + maybeQDoDoc = case unLoc tok of + ITdo (Just m) -> Just $ ftext m <> text ".do" + ITmdo (Just m) -> Just $ ftext m <> text ".mdo" + t -> Nothing + +-- When two single quotes don't followed by tyvar or gtycon, we report the +-- error as empty character literal, or TH quote that missing proper type +-- variable or constructor. See #13450. +reportEmptyDoubleQuotes :: SrcSpan -> P a +reportEmptyDoubleQuotes span = do + thQuotes <- getBit ThQuotesBit + addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ + +For the general principles of the following routines, see Note [exact print annotations] +in GHC.Parser.Annotation + +-} + +msemi :: Located Token -> [TrailingAnn] +msemi !l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (epTok l)] + +msemiA :: Located Token -> [EpToken ";"] +msemiA !l = if isZeroWidthSpan (gl l) then [] else [epTok l] + +msemim :: Located Token -> Maybe (EpToken ";") +msemim !l = if isZeroWidthSpan (gl l) then Nothing else Just (epTok l) + +toUnicode :: Located Token -> IsUnicodeSyntax +toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax + +-- ------------------------------------- + +gl :: GenLocated l a -> l +gl = getLoc + +glA :: HasLoc a => a -> SrcSpan +glA = getHasLoc + +glR :: HasLoc a => a -> EpaLocation +glR !la = EpaSpan (getHasLoc la) + +glEE :: (HasLoc a, HasLoc b) => a -> b -> EpaLocation +glEE !x !y = spanAsAnchor $ comb2 x y + +glEEz :: (HasLoc a, HasLoc b) => a -> b -> EpaLocation +glEEz !x !y = if isZeroWidthSpan (getHasLoc y) + then spanAsAnchor (getHasLoc x) + else spanAsAnchor $ comb2 x y + +glRM :: Located a -> Maybe EpaLocation +glRM (L !l _) = Just $ spanAsAnchor l + +n2l :: LocatedN a -> LocatedA a +n2l (L !la !a) = L (l2l la) a + +-- Called at the very end to pick up the EOF position, as well as any comments not allocated yet. +acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a) +acsFinal a = do + let (L l _) = a emptyComments Nothing + !cs <- getCommentsFor l + csf <- getFinalCommentsFor l + meof <- getEofPos + let ce = case meof of + Strict.Nothing -> Nothing + Strict.Just (pos `Strict.And` gap) -> Just (pos,gap) + return (a (cs Semi.<> csf) ce) + +acs :: (HasLoc l, MonadP m) => l -> (l -> EpAnnComments -> GenLocated l a) -> m (GenLocated l a) +acs !l a = do + !cs <- getCommentsFor (locA l) + return (a l cs) + +acsA :: (HasLoc l, HasAnnotation t, MonadP m) => l -> (l -> EpAnnComments -> Located a) -> m (GenLocated t a) +acsA !l a = do + !cs <- getCommentsFor (locA l) + return $ reLoc (a l cs) + +ams1 :: MonadP m => Located a -> b -> m (LocatedA b) +ams1 (L l a) b = do + !cs <- getCommentsFor l + return (L (EpAnn (spanAsAnchor l) noAnn cs) b) + +amsA' :: (NoAnn t, MonadP m) => Located a -> m (GenLocated (EpAnn t) a) +amsA' (L l a) = do + !cs <- getCommentsFor l + return (L (EpAnn (spanAsAnchor l) noAnn cs) a) + +amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a) +amsA (L !l a) bs = do + !cs <- getCommentsFor (locA l) + return (L (addAnnsA l bs cs) a) + +amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a) +amsAl (L l a) loc bs = do + !cs <- getCommentsFor loc + return (L (addAnnsA l bs cs) a) + +amsr :: MonadP m => Located a -> an -> m (LocatedAn an a) +amsr (L l a) an = do + !cs <- getCommentsFor l + return (L (EpAnn (spanAsAnchor l) an cs) a) + +-- | Parse a Haskell module with Haddock comments. This is done in two steps: +-- +-- * 'parseModuleNoHaddock' to build the AST +-- * 'addHaddockToModule' to insert Haddock comments into it +-- +-- This and the signature module parser are the only parser entry points that +-- deal with Haddock comments. The other entry points ('parseDeclaration', +-- 'parseExpression', etc) do not insert them into the AST. +parseModule :: P (Located (HsModule GhcPs)) +parseModule = parseModuleNoHaddock >>= addHaddockToModule + +-- | Parse a Haskell signature module with Haddock comments. This is done in two +-- steps: +-- +-- * 'parseSignatureNoHaddock' to build the AST +-- * 'addHaddockToModule' to insert Haddock comments into it +-- +-- This and the module parser are the only parser entry points that deal with +-- Haddock comments. The other entry points ('parseDeclaration', +-- 'parseExpression', etc) do not insert them into the AST. +parseSignature :: P (Located (HsModule GhcPs)) +parseSignature = parseSignatureNoHaddock >>= addHaddockToModule + +commentsA :: (NoAnn ann) => SrcSpan -> EpAnnComments -> EpAnn ann +commentsA loc cs = EpAnn (EpaSpan loc) noAnn cs + +spanWithComments :: (NoAnn ann, MonadP m) => SrcSpan -> m (EpAnn ann) +spanWithComments l = do + !cs <- getCommentsFor l + return (commentsA l cs) + +-- | Instead of getting the *enclosed* comments, this includes the +-- *preceding* ones. It is used at the top level to get comments +-- between top level declarations. +commentsPA :: (NoAnn ann) => LocatedAn ann a -> P (LocatedAn ann a) +commentsPA la@(L l a) = do + !cs <- getPriorCommentsFor (getLocA la) + return (L (addCommentsToEpAnn l cs) a) + +hsDoAnn :: EpToken "rec" -> LocatedAn t b -> AnnList (EpToken "rec") +hsDoAnn tok (L ll _) + = AnnList (Just $ spanAsAnchor (locA ll)) ListNone [] tok [] + +listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation +listAsAnchorM [] = Nothing +listAsAnchorM (L l _:_) = + case locA l of + RealSrcSpan ll _ -> Just $ realSpanAsAnchor ll + _ -> Nothing + +epTok :: Located Token -> EpToken tok +epTok (L !l _) = EpTok (EpaSpan l) + +epUniTok :: Located Token -> EpUniToken tok utok +epUniTok t@(L !l _) = EpUniTok (EpaSpan l) u + where + u = if isUnicode t then UnicodeSyntax else NormalSyntax + +-- |Construct an EpToken from the location of the token, provided the span is not zero width +mzEpTok :: Located Token -> EpToken tok +mzEpTok !l = if isZeroWidthSpan (gl l) then NoEpTok else (epTok l) + +epExplicitBraces :: Located Token -> Located Token -> EpLayout +epExplicitBraces !t1 !t2 = EpExplicitBraces (epTok t1) (epTok t2) + +-- ------------------------------------- + +addTrailingCommaFBind :: MonadP m => Fbind b -> EpToken "," -> m (Fbind b) +addTrailingCommaFBind (Left b) l = fmap Left (addTrailingCommaA b l) +addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l) + +addTrailingVbarA :: MonadP m => LocatedA a -> EpToken "|" -> m (LocatedA a) +addTrailingVbarA la tok = addTrailingAnnA la tok AddVbarAnn + +addTrailingSemiA :: MonadP m => LocatedA a -> EpToken ";" -> m (LocatedA a) +addTrailingSemiA la span = addTrailingAnnA la span AddSemiAnn + +addTrailingCommaA :: MonadP m => LocatedA a -> EpToken "," -> m (LocatedA a) +addTrailingCommaA la span = addTrailingAnnA la span AddCommaAnn + +addTrailingAnnA :: (MonadP m, HasLoc tok) => LocatedA a -> tok -> (tok -> TrailingAnn) -> m (LocatedA a) +addTrailingAnnA (L anns a) tok ta = do + let cs = emptyComments + -- AZ:TODO: generalise updating comments into an annotation + let + anns' = if isZeroWidthSpan (getHasLoc tok) + then anns + else addTrailingAnnToA (ta tok) cs anns + return (L anns' a) + +-- ------------------------------------- + +addTrailingVbarL :: MonadP m => LocatedL a -> EpToken "|" -> m (LocatedL a) +addTrailingVbarL la tok = addTrailingAnnL la (AddVbarAnn tok) + +addTrailingCommaL :: MonadP m => LocatedL a -> EpToken "," -> m (LocatedL a) +addTrailingCommaL la tok = addTrailingAnnL la (AddCommaAnn tok) + +addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a) +addTrailingAnnL (L anns a) ta = do + !cs <- getCommentsFor (locA anns) + let anns' = addTrailingAnnToL ta cs anns + return (L anns' a) + +-- ------------------------------------- + +-- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation +addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a) +addTrailingCommaN (L anns a) span = do + let cs = emptyComments + -- AZ:TODO: generalise updating comments into an annotation + let anns' = if isZeroWidthSpan span + then anns + else addTrailingCommaToN anns (srcSpan2e span) + return (L anns' a) + +addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral +addTrailingCommaS (L l sl) span + = L (widenSpanL l [span]) (sl { sl_tc = Just (epaToNoCommentsLocation span) }) + +-- ------------------------------------- + +addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a +addTrailingDarrowC (L (EpAnn lr (AnnContext _ o c) csc) a) lt cs = + let + u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax + in L (EpAnn lr (AnnContext (Just (epUniTok lt)) o c) (cs Semi.<> csc)) a + +-- ------------------------------------- + +isUnicodeSyntax :: Located Token -> IsUnicodeSyntax +isUnicodeSyntax lt = if isUnicode lt then UnicodeSyntax else NormalSyntax + +-- We need a location for the where binds, when computing the SrcSpan +-- for the AST element using them. Where there is a span, we return +-- it, else noLoc, which is ignored in the comb2 call. +adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments)) + -> Located (HsLocalBinds GhcPs, EpAnnComments) +adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments) +adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc) + +combineHasLocs :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan +combineHasLocs a b = combineSrcSpans (getHasLoc a) (getHasLoc b) + +fromTrailingN :: SrcSpanAnnN -> SrcSpanAnnA +fromTrailingN (EpAnn anc ann cs) + = EpAnn anc (AnnListItem (nann_trailing ann)) cs +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ + + + + + + + + + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Prelude.Bool) +#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Prelude.Bool) +#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Prelude.Bool) +#else +#define LT(n,m) (n Happy_GHC_Exts.<# m) +#define GTE(n,m) (n Happy_GHC_Exts.>=# m) +#define EQ(n,m) (n Happy_GHC_Exts.==# m) +#endif + + + + + + + + + + + + + + + + + + + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is ERROR_TOK, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + case action of + 0# -> {- nothing -} + happyFail (happyExpListPerState ((Happy_GHC_Exts.I# (st)) :: Prelude.Int)) i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + happyShift new_state i tk st + where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where off = happyAdjustOffset (indexShortOffAddr happyActOffsets st) + off_i = (off Happy_GHC_Exts.+# i) + check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) + then EQ(indexShortOffAddr happyCheck off_i, i) + else Prelude.False + action + | check = indexShortOffAddr happyTable off_i + | Prelude.otherwise = indexShortOffAddr happyDefActions st + + + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# + + + + +{-# INLINE happyLt #-} +happyLt x y = LT(x,y) + + +readArrayBit arr bit = + Bits.testBit (Happy_GHC_Exts.I# (indexShortOffAddr arr ((unbox_int bit) `Happy_GHC_Exts.iShiftRA#` 4#))) (bit `Prelude.mod` 16) + where unbox_int (Happy_GHC_Exts.I# x) = x + + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + + + + + + + + + + + + + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk + + off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st1) + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st) + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (ERROR_TOK is the error token) + +-- parse error if we are in recovery and we fail again +happyFail explist 0# tk old_st _ stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "failing" $ + happyError_ explist i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail explist i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ((Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = Prelude.error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `Prelude.seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/GHC/Parser.hs-boot b/GHC/Parser.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Parser.hs-boot @@ -0,0 +1,7 @@ +module GHC.Parser where + +import GHC.Types.Name.Reader (RdrName) +import GHC.Parser.Lexer (P) +import GHC.Parser.Annotation (LocatedN) + +parseIdentifier :: P (LocatedN RdrName) diff --git a/GHC/Parser/Annotation.hs b/GHC/Parser/Annotation.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Annotation.hs @@ -0,0 +1,1271 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} + +module GHC.Parser.Annotation ( + -- * Core Exact Print Annotation types + EpToken(..), EpUniToken(..), + getEpTokenSrcSpan, + getEpTokenBufSpan, + getEpTokenLocs, getEpTokenLoc, getEpUniTokenLoc, + TokDcolon, TokDarrow, TokRarrow, TokForall, + EpLayout(..), + EpaComment(..), EpaCommentTok(..), + IsUnicodeSyntax(..), + HasE(..), + + -- * In-tree Exact Print Annotations + EpaLocation, EpaLocation'(..), epaLocationRealSrcSpan, + DeltaPos(..), deltaPos, getDeltaLine, + + EpAnn(..), + spanAsAnchor, realSpanAsAnchor, + noSpanAnchor, + NoAnn(..), + + -- ** Comments in Annotations + + EpAnnComments(..), LEpaComment, NoCommentsLocation, NoComments(..), emptyComments, + epaToNoCommentsLocation, noCommentsToEpaLocation, + getFollowingComments, setFollowingComments, setPriorComments, + EpAnnCO, + + -- ** Annotations in 'GenLocated' + LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP, + LocatedLC, LocatedLS, LocatedLW, LocatedLI, + SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN, + SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS, SrcSpanAnnLI, + LocatedE, + + -- ** Annotation data types used in 'GenLocated' + + AnnListItem(..), AnnList(..), AnnListBrackets(..), + AnnParen(..), + AnnPragma(..), + AnnContext(..), + NameAnn(..), NameAdornment(..), + NoEpAnns(..), + AnnSortKey(..), DeclTag(..), BindTag(..), + + -- ** Trailing annotations in lists + TrailingAnn(..), ta_location, + addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN, + noTrailingN, + + -- ** Utilities for converting between different 'GenLocated' when + -- ** we do not care about the annotations. + l2l, la2la, + reLoc, + HasLoc(..), getHasLocList, + + srcSpan2e, realSrcSpan, + + -- ** Building up annotations + addAnnsA, widenSpanL, widenSpanT, widenAnchorT, widenAnchorS, + widenLocatedAnL, + listLocation, + + -- ** Querying annotations + getLocAnn, + epAnnComments, + + -- ** Working with locations of annotations + sortLocatedA, + mapLocA, + combineLocsA, + combineSrcSpansA, + addCLocA, + + -- ** Constructing 'GenLocated' annotation types when we do not care + -- about annotations. + HasAnnotation(..), + locA, + noLocA, + getLocA, + noSrcSpanA, + + -- ** Working with comments in annotations + noComments, comment, addCommentsToEpAnn, setCommentsEpAnn, + transferAnnsA, transferAnnsOnlyA, transferCommentsOnlyA, + transferPriorCommentsA, transferFollowingA, + + placeholderRealSpan, + ) where + +import GHC.Prelude + +import Data.Data +import Data.Function (on) +import Data.List (sortBy) +import Data.Semigroup +import GHC.Data.FastString +import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Hs.DocString +import GHC.Utils.Misc +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Utils.Panic +import qualified GHC.Data.Strict as Strict +import GHC.Types.SourceText (SourceText (NoSourceText)) + +{- +Note [exact print annotations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a parse tree of a Haskell module, how can we reconstruct +the original Haskell source code, retaining all whitespace and +source code comments? We need to track the locations of all +elements from the original source: this includes keywords such as +'let' / 'in' / 'do' etc as well as punctuation such as commas and +braces, and also comments. We collectively refer to this +metadata as the "exact print annotations". + +NON-COMMENT ELEMENTS + +Intuitively, every AST element directly contains a bag of keywords +(keywords can show up more than once in a node: a semicolon i.e. newline +can show up multiple times before the next AST element), each of which +needs to be associated with its location in the original source code. + +These keywords are recorded directly in the AST element in which they +occur, for the GhcPs phase. + +For any given element in the AST, there is only a set number of +keywords that are applicable for it (e.g., you'll never see an +'import' keyword associated with a let-binding.) The set of allowed +keywords is documented in a comment associated with the constructor +of a given AST element, although the ground truth is in GHC.Parser +and GHC.Parser.PostProcess (which actually add the annotations). + +COMMENT ELEMENTS + +We associate comments with the lowest (most specific) AST element +enclosing them + +PARSER STATE + +There are three fields in PState (the parser state) which play a role +with annotation comments. + +> comment_q :: [LEpaComment], +> header_comments :: Maybe [LEpaComment], +> eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token + +The 'comment_q' field captures comments as they are seen in the token stream, +so that when they are ready to be allocated via the parser they are +available. + +The 'header_comments' capture the comments coming at the top of the +source file. They are moved there from the `comment_q` when comments +are allocated for the first top-level declaration. + +The 'eof_pos' captures the final location in the file, and the +location of the immediately preceding token to the last location, so +that the exact-printer can work out how far to advance to add the +trailing whitespace. + +PARSER EMISSION OF ANNOTATIONS + +The parser interacts with the lexer using the functions + +> getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments +> getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments +> getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments + +The 'getCommentsFor' function is the one used most often. It takes +the AST element SrcSpan and removes and returns any comments in the +'comment_q' that are inside the span. 'allocateComments' in 'Lexer' is +responsible for making sure we only return comments that actually fit +in the 'SrcSpan'. + +The 'getPriorCommentsFor' function is used for top-level declarations, +and removes and returns any comments in the 'comment_q' that either +precede or are included in the given SrcSpan. This is to ensure that +preceding documentation comments are kept together with the +declaration they belong to. + +The 'getFinalCommentsFor' function is called right at the end when EOF +is hit. This drains the 'comment_q' completely, and returns the +'header_comments', remaining 'comment_q' entries and the +'eof_pos'. These values are inserted into the 'HsModule' AST element. + +The wiki page describing this feature is +https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations + +-} + +-- -------------------------------------------------------------------- + +-- | Certain tokens can have alternate representations when unicode syntax is +-- enabled. This flag is attached to those tokens in the lexer so that the +-- original source representation can be reproduced in the corresponding +-- 'EpAnnotation' +data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax + deriving (Eq, Ord, Data, Show) + +-- | Some template haskell tokens have two variants, one with an `e` the other +-- not: +-- +-- > [| or [e| +-- > [|| or [e|| +-- +-- This type indicates whether the 'e' is present or not. +data HasE = HasE | NoE + deriving (Eq, Ord, Data, Show) + +-- --------------------------------------------------------------------- + +-- | A token stored in the syntax tree. For example, when parsing a +-- let-expression, we store @EpToken "let"@ and @EpToken "in"@. +-- The locations of those tokens can be used to faithfully reproduce +-- (exactprint) the original program text. +data EpToken (tok :: Symbol) + = NoEpTok + | EpTok !EpaLocation + +instance KnownSymbol tok => Outputable (EpToken tok) where + ppr _ = text (symbolVal (Proxy @tok)) + +-- | With @UnicodeSyntax@, there might be multiple ways to write the same +-- token. For example an arrow could be either @->@ or @→@. This choice must be +-- recorded in order to exactprint such tokens, so instead of @EpToken "->"@ we +-- introduce @EpUniToken "->" "→"@. +data EpUniToken (tok :: Symbol) (utok :: Symbol) + = NoEpUniTok + | EpUniTok !EpaLocation !IsUnicodeSyntax + +deriving instance Eq (EpToken tok) +deriving instance Eq (EpUniToken tok utok) +deriving instance KnownSymbol tok => Data (EpToken tok) +deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (EpUniToken tok utok) + +instance (KnownSymbol tok, KnownSymbol utok) => Outputable (EpUniToken tok utok) where + ppr NoEpUniTok = text $ symbolVal (Proxy @tok) + ppr (EpUniTok _ NormalSyntax) = text $ symbolVal (Proxy @tok) + ppr (EpUniTok _ UnicodeSyntax) = text $ symbolVal (Proxy @utok) + +getEpTokenSrcSpan :: EpToken tok -> SrcSpan +getEpTokenSrcSpan NoEpTok = noSrcSpan +getEpTokenSrcSpan (EpTok EpaDelta{}) = noSrcSpan +getEpTokenSrcSpan (EpTok (EpaSpan span)) = span + +getEpTokenBufSpan :: EpToken tok -> Strict.Maybe BufSpan +getEpTokenBufSpan NoEpTok = Strict.Nothing +getEpTokenBufSpan (EpTok EpaDelta{}) = Strict.Nothing +getEpTokenBufSpan (EpTok (EpaSpan span)) = getBufSpan span + +getEpTokenLocs :: [EpToken tok] -> [EpaLocation] +getEpTokenLocs ls = concatMap go ls + where + go NoEpTok = [] + go (EpTok l) = [l] + +getEpTokenLoc :: EpToken tok -> EpaLocation +getEpTokenLoc NoEpTok = noAnn +getEpTokenLoc (EpTok l) = l + +getEpUniTokenLoc :: EpUniToken tok toku -> EpaLocation +getEpUniTokenLoc NoEpUniTok = noAnn +getEpUniTokenLoc (EpUniTok l _) = l + +-- TODO:AZ: check we have all of the unicode tokens +type TokDcolon = EpUniToken "::" "∷" +type TokDarrow = EpUniToken "=>" "⇒" +type TokRarrow = EpUniToken "->" "→" +type TokForall = EpUniToken "forall" "∀" + +-- | Layout information for declarations. +data EpLayout = + + -- | Explicit braces written by the user. + -- + -- @ + -- class C a where { foo :: a; bar :: a } + -- @ + EpExplicitBraces !(EpToken "{") !(EpToken "}") + | + -- | Virtual braces inserted by the layout algorithm. + -- + -- @ + -- class C a where + -- foo :: a + -- bar :: a + -- @ + EpVirtualBraces + !Int -- ^ Layout column (indentation level, begins at 1) + | + -- | Empty or compiler-generated blocks do not have layout information + -- associated with them. + EpNoLayout + +deriving instance Data EpLayout + +-- --------------------------------------------------------------------- + +data EpaComment = + EpaComment + { ac_tok :: EpaCommentTok + , ac_prior_tok :: RealSrcSpan + -- ^ The location of the prior token, used in exact printing. The + -- 'EpaComment' appears as an 'LEpaComment' containing its + -- location. The difference between the end of the prior token + -- and the start of this location is used for the spacing when + -- exact printing the comment. + } + deriving (Eq, Data, Show) + +data EpaCommentTok = + -- Documentation annotations + EpaDocComment HsDocString -- ^ a docstring that can be pretty printed using pprHsDocString + | EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc) + | EpaLineComment String -- ^ comment starting by "--" + | EpaBlockComment String -- ^ comment in {- -} + deriving (Eq, Data, Show) +-- Note: these are based on the Token versions, but the Token type is +-- defined in GHC.Parser.Lexer and bringing it in here would create a loop + +instance Outputable EpaComment where + ppr x = text (show x) + +-- --------------------------------------------------------------------- + +type EpaLocation = EpaLocation' [LEpaComment] + +epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation +epaToNoCommentsLocation (EpaSpan ss) = EpaSpan ss +epaToNoCommentsLocation (EpaDelta ss dp []) = EpaDelta ss dp NoComments +epaToNoCommentsLocation (EpaDelta _ _ _ ) = panic "epaToNoCommentsLocation" + +noCommentsToEpaLocation :: NoCommentsLocation -> EpaLocation +noCommentsToEpaLocation (EpaSpan ss) = EpaSpan ss +noCommentsToEpaLocation (EpaDelta ss dp NoComments) = EpaDelta ss dp [] + +-- | Used in the parser only, extract the 'RealSrcSpan' from an +-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the +-- partial function is safe. +epaLocationRealSrcSpan :: EpaLocation' a -> RealSrcSpan +epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r +epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan" + +-- --------------------------------------------------------------------- + +-- | The exact print annotations (EPAs) are kept in the HsSyn AST for +-- the GhcPs phase. They are usually inserted into the AST by the parser, +-- and in case of generated code (e.g. by TemplateHaskell) they are usually +-- initialized using 'NoAnn' type class. +-- +-- A goal of the annotations is that an AST can be edited, including +-- moving subtrees from one place to another, duplicating them, and so +-- on. This means that each fragment must be self-contained. To this +-- end, each annotated fragment keeps track of the anchor position it +-- was originally captured at, being simply the start span of the +-- topmost element of the ast fragment. This gives us a way to later +-- re-calculate all Located items in this layer of the AST, as well as +-- any annotations captured. The comments associated with the AST +-- fragment are also captured here. +-- +-- The 'ann' type parameter allows this general structure to be +-- specialised to the specific set of locations of original exact +-- print annotation elements. For example +-- +-- @ +-- type SrcSpannAnnA = EpAnn AnnListItem +-- @ +-- +-- is a commonly used type alias that specializes the 'ann' type parameter to +-- 'AnnListItem'. +-- +-- The spacing between the items under the scope of a given EpAnn is +-- normally derived from the original 'Anchor'. But if a sub-element +-- is not in its original position, the required spacing can be +-- captured using an appropriate 'EpaDelta' value for the 'entry' Anchor. +-- This allows us to freely move elements around, and stitch together +-- new AST fragments out of old ones, and have them still printed out +-- in a precise way. +data EpAnn ann + = EpAnn { entry :: !EpaLocation + -- ^ Base location for the start of the syntactic element + -- holding the annotations. + , anns :: !ann -- ^ Annotations added by the Parser + , comments :: !EpAnnComments + -- ^ Comments enclosed in the SrcSpan of the element + -- this `EpAnn` is attached to + } + deriving (Data, Eq, Functor) +-- See Note [XRec and Anno in the AST] + + +spanAsAnchor :: SrcSpan -> (EpaLocation' a) +spanAsAnchor ss = EpaSpan ss + +realSpanAsAnchor :: RealSrcSpan -> (EpaLocation' a) +realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing) + +noSpanAnchor :: (NoAnn a) => EpaLocation' a +noSpanAnchor = EpaDelta noSrcSpan (SameLine 0) noAnn + +-- --------------------------------------------------------------------- + +-- | When we are parsing we add comments that belong to a particular AST +-- element, and print them together with the element, interleaving +-- them into the output stream. But when editing the AST to move +-- fragments around it is useful to be able to first separate the +-- comments into those occurring before the AST element and those +-- following it. The 'EpaCommentsBalanced' constructor is used to do +-- this. The GHC parser will only insert the 'EpaComments' form. +data EpAnnComments = EpaComments + { priorComments :: ![LEpaComment] } + | EpaCommentsBalanced + { priorComments :: ![LEpaComment] + , followingComments :: ![LEpaComment] } + deriving (Data, Eq) + +type LEpaComment = GenLocated NoCommentsLocation EpaComment + +emptyComments :: EpAnnComments +emptyComments = EpaComments [] + +-- --------------------------------------------------------------------- +-- Annotations attached to a 'SrcSpan'. +-- --------------------------------------------------------------------- + +type LocatedA = GenLocated SrcSpanAnnA +type LocatedN = GenLocated SrcSpanAnnN + +type LocatedL = GenLocated SrcSpanAnnL +type LocatedLC = GenLocated SrcSpanAnnLC +type LocatedLS = GenLocated SrcSpanAnnLS +type LocatedLW = GenLocated SrcSpanAnnLW +type LocatedLI = GenLocated SrcSpanAnnLI +type LocatedP = GenLocated SrcSpanAnnP +type LocatedC = GenLocated SrcSpanAnnC + +type SrcSpanAnnA = EpAnn AnnListItem +type SrcSpanAnnN = EpAnn NameAnn + +type SrcSpanAnnL = EpAnn (AnnList ()) +type SrcSpanAnnLC = EpAnn (AnnList [EpToken ","]) +type SrcSpanAnnLS = EpAnn (AnnList ()) +type SrcSpanAnnLW = EpAnn (AnnList (EpToken "where")) +type SrcSpanAnnLI = EpAnn (AnnList (EpToken "hiding", [EpToken ","])) +type SrcSpanAnnP = EpAnn AnnPragma +type SrcSpanAnnC = EpAnn AnnContext + +type LocatedE = GenLocated EpaLocation + +-- | General representation of a 'GenLocated' type carrying a +-- parameterised annotation type. +type LocatedAn an = GenLocated (EpAnn an) + +{- +Note [XRec and Anno in the AST] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The exact print annotations are captured directly inside the AST, using +TTG extension points. However certain annotations need to be captured +on the Located versions too. There is a general form for these, +captured in the type 'EpAnn ann' with the specific usage captured in +the 'ann' parameter in different contexts. + +Some of the particular use cases are + +1) RdrNames, which can have additional items such as backticks or parens + +2) Items which occur in lists, and the annotation relates purely +to its usage inside a list. + +See the section above this note for the rest. + +The Anno type family maps to the specific EpAnn variant for a given +item. + +So + + type instance XRec (GhcPass p) a = XRecGhc a + type XRecGhc a = GenLocated (Anno a) a + + type instance Anno RdrName = SrcSpanAnnN + type LocatedN = GenLocated SrcSpanAnnN + +meaning we can have type LocatedN RdrName + +-} + +-- --------------------------------------------------------------------- +-- Annotations for items in a list +-- --------------------------------------------------------------------- + +-- | Captures the location of punctuation occurring between items, +-- normally in a list. It is captured as a trailing annotation. +data TrailingAnn + = AddSemiAnn (EpToken ";") -- ^ Trailing ';' + | AddCommaAnn (EpToken ",") -- ^ Trailing ',' + | AddVbarAnn (EpToken "|") -- ^ Trailing '|' + | AddDarrowAnn TokDarrow -- ^ Trailing '=>' / '⇒' + deriving (Data, Eq) + +ta_location :: TrailingAnn -> EpaLocation +ta_location (AddSemiAnn tok) = getEpTokenLoc tok +ta_location (AddCommaAnn tok) = getEpTokenLoc tok +ta_location (AddVbarAnn tok) = getEpTokenLoc tok +ta_location (AddDarrowAnn tok) = getEpUniTokenLoc tok + + +instance Outputable TrailingAnn where + ppr (AddSemiAnn tok) = text "AddSemiAnn" <+> ppr tok + ppr (AddCommaAnn tok) = text "AddCommaAnn" <+> ppr tok + ppr (AddVbarAnn tok) = text "AddVbarAnn" <+> ppr tok + ppr (AddDarrowAnn tok) = text "AddDarrowAnn" <+> ppr tok + +-- | Annotation for items appearing in a list. They can have one or +-- more trailing punctuations items, such as commas or semicolons. +data AnnListItem + = AnnListItem { + lann_trailing :: [TrailingAnn] + } + deriving (Data, Eq) + +-- --------------------------------------------------------------------- +-- Annotations for the context of a list of items +-- --------------------------------------------------------------------- + +-- | Annotation for the "container" of a list. This captures +-- surrounding items such as braces if present, and introductory +-- keywords such as 'where'. +data AnnList a + = AnnList { + al_anchor :: !(Maybe EpaLocation), -- ^ start point of a list having layout + al_brackets :: !AnnListBrackets, + al_semis :: [EpToken ";"], -- decls + al_rest :: !a, + al_trailing :: ![TrailingAnn] -- ^ items appearing after the + -- list, such as '=>' for a + -- context + } deriving (Data,Eq) + +data AnnListBrackets + = ListParens (EpToken "(") (EpToken ")") + | ListBraces (EpToken "{") (EpToken "}") + | ListSquare (EpToken "[") (EpToken "]") + | ListBanana (EpUniToken "(|" "⦇") (EpUniToken "|)" "⦈") + | ListNone + deriving (Data,Eq) + +-- --------------------------------------------------------------------- +-- Annotations for parenthesised elements, such as tuples, lists +-- --------------------------------------------------------------------- + +-- | exact print annotation for an item having surrounding "brackets", such as +-- tuples or lists +data AnnParen + = AnnParens (EpToken "(") (EpToken ")") -- ^ '(', ')' + | AnnParensHash (EpToken "(#") (EpToken "#)") -- ^ '(#', '#)' + | AnnParensSquare (EpToken "[") (EpToken "]") -- ^ '[', ']' + deriving Data + +-- --------------------------------------------------------------------- + +-- | Exact print annotation for the 'Context' data type. +data AnnContext + = AnnContext { + ac_darrow :: Maybe TokDarrow, + -- ^ location of the '=>', if present. + ac_open :: [EpToken "("], -- ^ zero or more opening parentheses. + ac_close :: [EpToken ")"] -- ^ zero or more closing parentheses. + } deriving (Data) + + +-- --------------------------------------------------------------------- +-- Annotations for names +-- --------------------------------------------------------------------- + +-- | exact print annotations for a 'RdrName'. There are many kinds of +-- adornment that can be attached to a given 'RdrName'. This type +-- captures them, as detailed on the individual constructors. +data NameAnn + -- | Used for a name with an adornment, so '`foo`', '(bar)' + = NameAnn { + nann_adornment :: NameAdornment, + nann_name :: EpaLocation, + nann_trailing :: [TrailingAnn] + } + -- | Used for @(,,,)@, or @(#,,,#)@ + | NameAnnCommas { + nann_adornment :: NameAdornment, + nann_commas :: [EpToken ","], + nann_trailing :: [TrailingAnn] + } + -- | Used for @(# | | #)@ + | NameAnnBars { + nann_parensh :: (EpToken "(#", EpToken "#)"), + nann_bars :: [EpToken "|"], + nann_trailing :: [TrailingAnn] + } + -- | Used for @()@, @(##)@, @[]@ + | NameAnnOnly { + nann_adornment :: NameAdornment, + nann_trailing :: [TrailingAnn] + } + -- | Used for @->@, as an identifier + | NameAnnRArrow { + nann_mopen :: Maybe (EpToken "("), + nann_arrow :: TokRarrow, + nann_mclose :: Maybe (EpToken ")"), + nann_trailing :: [TrailingAnn] + } + -- | Used for an item with a leading @'@. The annotation for + -- unquoted item is stored in 'nann_quoted'. + | NameAnnQuote { + nann_quote :: EpToken "'", + nann_quoted :: SrcSpanAnnN, + nann_trailing :: [TrailingAnn] + } + -- | Used when adding a 'TrailingAnn' to an existing 'LocatedN' + -- which has no Api Annotation. + | NameAnnTrailing { + nann_trailing :: [TrailingAnn] + } + deriving (Data, Eq) + +-- | A 'NameAnn' can capture the locations of surrounding adornments, +-- such as parens or backquotes. This data type identifies what +-- particular pair are being used. +data NameAdornment + = NameParens (EpToken "(") (EpToken ")") + | NameParensHash (EpToken "(#") (EpToken "#)") + | NameBackquotes (EpToken "`") (EpToken "`") + | NameSquare (EpToken "[") (EpToken "]") + | NameNoAdornment + deriving (Eq, Data) + + +-- --------------------------------------------------------------------- + +-- | exact print annotation used for capturing the locations of +-- annotations in pragmas. +data AnnPragma + = AnnPragma { + apr_open :: EpaLocation, + apr_close :: EpToken "#-}", + apr_squares :: (EpToken "[", EpToken "]"), + apr_loc1 :: EpaLocation, + apr_loc2 :: EpaLocation, + apr_type :: EpToken "type", + apr_module :: EpToken "module" + } deriving (Data,Eq) + +-- --------------------------------------------------------------------- + +-- | Captures the sort order of sub elements for `ValBinds`, +-- `ClassDecl`, `ClsInstDecl` +data AnnSortKey tag + -- See Note [AnnSortKey] below + = NoAnnSortKey + | AnnSortKey [tag] + deriving (Data, Eq) + +-- | Used to track of interleaving of binds and signatures for ValBind +data BindTag + -- See Note [AnnSortKey] below + = BindTag + | SigDTag + deriving (Eq,Data,Ord,Show) + +-- | Used to track interleaving of class methods, class signatures, +-- associated types and associate type defaults in `ClassDecl` and +-- `ClsInstDecl`. +data DeclTag + -- See Note [AnnSortKey] below + = ClsMethodTag + | ClsSigTag + | ClsAtTag + | ClsAtdTag + deriving (Eq,Data,Ord,Show) + +{- +Note [AnnSortKey] +~~~~~~~~~~~~~~~~~ + +For some constructs in the ParsedSource we have mixed lists of items +that can be freely intermingled. + +An example is the binds in a where clause, captured in + + ValBinds + (XValBinds idL idR) + (LHsBindsLR idL idR) [LSig idR] + +This keeps separate ordered collections of LHsBind GhcPs and LSig GhcPs. + +But there is no constraint on the original source code as to how these +should appear, so they can have all the signatures first, then their +binds, or grouped with a signature preceding each bind. + + fa :: Int + fa = 1 + + fb :: Char + fb = 'c' + +Or + + fa :: Int + fb :: Char + + fb = 'c' + fa = 1 + +When exact printing these, we need to restore the original order. As +initially parsed we have the SrcSpan, and can sort on those. But if we +have modified the AST prior to printing, we cannot rely on the +SrcSpans for order any more. + +The bag of LHsBind GhcPs is physically ordered, as is the list of LSig +GhcPs. So in effect we have a list of binds in the order we care +about, and a list of sigs in the order we care about. The only problem +is to know how to merge the lists. + +This is where AnnSortKey comes in, which we store in the TTG extension +point for ValBinds. + + data AnnSortKey tag + = NoAnnSortKey + | AnnSortKey [tag] + +When originally parsed, with SrcSpans we can rely on, we do not need +any extra information, so we tag it with NoAnnSortKey. + +If the binds and signatures are updated in any way, such that we can +no longer rely on their SrcSpans (e.g. they are copied from elsewhere, +parsed from scratch for insertion, have a fake SrcSpan), we use +`AnnSortKey [BindTag]` to keep track. + + data BindTag + = BindTag + | SigDTag + +We use it as a merge selector, and have one entry for each bind and +signature. + +So for the first example we have + + binds: fa = 1 , fb = 'c' + sigs: fa :: Int, fb :: Char + tags: SigDTag, BindTag, SigDTag, BindTag + +so we draw first from the signatures, then the binds, and same again. + +For the second example we have + + binds: fb = 'c', fa = 1 + sigs: fa :: Int, fb :: Char + tags: SigDTag, SigDTag, BindTag, BindTag + +so we draw two signatures, then two binds. + +We do similar for ClassDecl and ClsInstDecl, but we have four +different lists we must manage. For this we use DeclTag. + +-} + +-- --------------------------------------------------------------------- + +-- | Helper function used in the parser to add a 'TrailingAnn' items +-- to an existing annotation. +addTrailingAnnToL :: TrailingAnn -> EpAnnComments + -> EpAnn (AnnList a) -> EpAnn (AnnList a) +addTrailingAnnToL t cs n = n { anns = addTrailing (anns n) + , comments = comments n <> cs } + where + -- See Note [list append in addTrailing*] + addTrailing n = n { al_trailing = al_trailing n ++ [t]} + +-- | Helper function used in the parser to add a 'TrailingAnn' items +-- to an existing annotation. +addTrailingAnnToA :: TrailingAnn -> EpAnnComments + -> EpAnn AnnListItem -> EpAnn AnnListItem +addTrailingAnnToA t cs n = n { anns = addTrailing (anns n) + , comments = comments n <> cs } + where + -- See Note [list append in addTrailing*] + addTrailing n = n { lann_trailing = lann_trailing n ++ [t] } + +-- | Helper function used in the parser to add a comma location to an +-- existing annotation. +addTrailingCommaToN :: EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn +addTrailingCommaToN n l = n { anns = addTrailing (anns n) l } + where + -- See Note [list append in addTrailing*] + addTrailing :: NameAnn -> EpaLocation -> NameAnn + addTrailing n l = n { nann_trailing = nann_trailing n ++ [AddCommaAnn (EpTok l)]} + +noTrailingN :: SrcSpanAnnN -> SrcSpanAnnN +noTrailingN s = s { anns = (anns s) { nann_trailing = [] } } + +{- +Note [list append in addTrailing*] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The addTrailingAnnToL, addTrailingAnnToA and addTrailingCommaToN +functions are used to add a separator for an item when it occurs in a +list. So they are used to capture a comma, vbar, semicolon and similar. + +In general, a given element will have zero or one of these. In +extreme (test) cases, there may be multiple semicolons. + +In exact printing we sometimes convert the EpaLocation variant for an +trailing annotation to the EpaDelta variant, which cannot be sorted. + +Hence it is critical that these annotations are captured in the order +they appear in the original source file. + +And so we use the less efficient list append to preserve the order, +knowing that in most cases the original list is empty. +-} + +-- --------------------------------------------------------------------- + +-- |Helper function for converting annotation types. +-- Discards any annotations +l2l :: (HasLoc a, HasAnnotation b) => a -> b +l2l a = noAnnSrcSpan (getHasLoc a) + +-- |Helper function for converting annotation types. +-- Discards any annotations +la2la :: (HasLoc l, HasAnnotation l2) => GenLocated l a -> GenLocated l2 a +la2la (L la a) = L (noAnnSrcSpan (getHasLoc la)) a + +locA :: (HasLoc a) => a -> SrcSpan +locA = getHasLoc + +reLoc :: (HasLoc (GenLocated a e), HasAnnotation b) + => GenLocated a e -> GenLocated b e +reLoc (L la a) = L (noAnnSrcSpan $ locA (L la a) ) a + + +-- --------------------------------------------------------------------- + +class HasAnnotation e where + noAnnSrcSpan :: SrcSpan -> e + +instance HasAnnotation SrcSpan where + noAnnSrcSpan l = l + +instance HasAnnotation EpaLocation where + noAnnSrcSpan l = EpaSpan l + +instance (NoAnn ann) => HasAnnotation (EpAnn ann) where + noAnnSrcSpan l = EpAnn (spanAsAnchor l) noAnn emptyComments + +noLocA :: (HasAnnotation e) => a -> GenLocated e a +noLocA = L (noAnnSrcSpan noSrcSpan) + +getLocA :: (HasLoc a) => GenLocated a e -> SrcSpan +getLocA = getHasLoc + +noSrcSpanA :: (HasAnnotation e) => e +noSrcSpanA = noAnnSrcSpan noSrcSpan + +-- --------------------------------------------------------------------- + +class NoAnn a where + -- | equivalent of `mempty`, but does not need Semigroup + noAnn :: a + +-- --------------------------------------------------------------------- + +class HasLoc a where + -- ^ conveniently calculate locations for things without locations attached + getHasLoc :: a -> SrcSpan + +instance (HasLoc l) => HasLoc (GenLocated l a) where + getHasLoc (L l _) = getHasLoc l + +instance HasLoc SrcSpan where + getHasLoc l = l + +instance (HasLoc a) => (HasLoc (Maybe a)) where + getHasLoc (Just a) = getHasLoc a + getHasLoc Nothing = noSrcSpan + +instance HasLoc (EpAnn a) where + getHasLoc (EpAnn l _ _) = getHasLoc l + +instance HasLoc EpaLocation where + getHasLoc (EpaSpan l) = l + getHasLoc (EpaDelta l _ _) = l + +instance HasLoc (EpToken tok) where + getHasLoc = getEpTokenSrcSpan + +instance HasLoc (EpUniToken tok utok) where + getHasLoc NoEpUniTok = noSrcSpan + getHasLoc (EpUniTok l _) = getHasLoc l + +getHasLocList :: HasLoc a => [a] -> SrcSpan +getHasLocList = foldl1WithDefault' noSrcSpan combineSrcSpans . map getHasLoc + +-- --------------------------------------------------------------------- + +realSrcSpan :: SrcSpan -> RealSrcSpan +realSrcSpan (RealSrcSpan s _) = s +realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary + where + l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1) + +srcSpan2e :: SrcSpan -> EpaLocation +srcSpan2e ss@(RealSrcSpan _ _) = EpaSpan ss +srcSpan2e span = EpaSpan (RealSrcSpan (realSrcSpan span) Strict.Nothing) + +getLocAnn :: Located a -> SrcSpanAnnA +getLocAnn (L l _) = noAnnSrcSpan l + +-- AZ:TODO use widenSpan here too +addAnnsA :: SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA +addAnnsA (EpAnn l as1 cs) as2 cs2 + = EpAnn l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2) + +-- | The annotations need to all come after the anchor. Make sure +-- this is the case. +widenSpanL :: SrcSpan -> [EpaLocation] -> SrcSpan +widenSpanL s as = foldl combineSrcSpans s (go as) + where + go [] = [] + go ((EpaSpan (RealSrcSpan s mb):rest)) = RealSrcSpan s mb : go rest + go ((EpaSpan _):rest) = go rest + go ((EpaDelta _ _ _):rest) = go rest + +widenSpanT :: SrcSpan -> EpToken tok -> SrcSpan +widenSpanT l (EpTok loc) = widenSpanL l [loc] +widenSpanT l NoEpTok = l + +listLocation :: [LocatedAn an a] -> EpaLocation +listLocation as = EpaSpan (go noSrcSpan as) + where + combine l r = combineSrcSpans l r + + go acc [] = acc + go acc (L (EpAnn (EpaSpan s) _ _) _:rest) = go (combine acc s) rest + go acc (_:rest) = go acc rest + +widenAnchorT :: EpaLocation -> EpToken tok -> EpaLocation +widenAnchorT (EpaSpan ss) (EpTok l) = widenAnchorS l ss +widenAnchorT ss _ = ss + +widenAnchorS :: EpaLocation -> SrcSpan -> EpaLocation +widenAnchorS (EpaSpan (RealSrcSpan s mbe)) (RealSrcSpan r mbr) + = EpaSpan (RealSrcSpan (combineRealSrcSpans s r) (liftA2 combineBufSpans mbe mbr)) +widenAnchorS (EpaSpan us) _ = EpaSpan us +widenAnchorS EpaDelta{} (RealSrcSpan r mb) = EpaSpan (RealSrcSpan r mb) +widenAnchorS anc _ = anc + +widenLocatedAnL :: EpAnn an -> [EpaLocation] -> EpAnn an +widenLocatedAnL (EpAnn (EpaSpan l) a cs) as = EpAnn (spanAsAnchor l') a cs + where + l' = widenSpanL l as +widenLocatedAnL (EpAnn anc a cs) _as = EpAnn anc a cs + +epAnnComments :: EpAnn an -> EpAnnComments +epAnnComments (EpAnn _ _ cs) = cs + +-- --------------------------------------------------------------------- +sortLocatedA :: (HasLoc (EpAnn a)) => [GenLocated (EpAnn a) e] -> [GenLocated (EpAnn a) e] +sortLocatedA = sortBy (leftmost_smallest `on` getLocA) + +mapLocA :: (NoAnn ann) => (a -> b) -> GenLocated SrcSpan a -> GenLocated (EpAnn ann) b +mapLocA f (L l a) = L (noAnnSrcSpan l) (f a) + +-- AZ:TODO: move this somewhere sane +combineLocsA :: Semigroup a => GenLocated (EpAnn a) e1 -> GenLocated (EpAnn a) e2 -> EpAnn a +combineLocsA (L a _) (L b _) = combineSrcSpansA a b + +combineSrcSpansA :: Semigroup a => EpAnn a -> EpAnn a -> EpAnn a +combineSrcSpansA aa ab = aa <> ab + +-- | Combine locations from two 'Located' things and add them to a third thing +addCLocA :: (HasLoc a, HasLoc b, HasAnnotation l) + => a -> b -> c -> GenLocated l c +addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (getHasLoc a) (getHasLoc b)) c + +-- --------------------------------------------------------------------- +-- Utilities for manipulating EpAnnComments +-- --------------------------------------------------------------------- + +getFollowingComments :: EpAnnComments -> [LEpaComment] +getFollowingComments (EpaComments _) = [] +getFollowingComments (EpaCommentsBalanced _ cs) = cs + +setFollowingComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments +setFollowingComments (EpaComments ls) cs = EpaCommentsBalanced ls cs +setFollowingComments (EpaCommentsBalanced ls _) cs = EpaCommentsBalanced ls cs + +setPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments +setPriorComments (EpaComments _) cs = EpaComments cs +setPriorComments (EpaCommentsBalanced _ ts) cs = EpaCommentsBalanced cs ts + +-- --------------------------------------------------------------------- +-- Comment-only annotations +-- --------------------------------------------------------------------- + +type EpAnnCO = EpAnn NoEpAnns -- ^ Api Annotations for comments only + +data NoEpAnns = NoEpAnns + deriving (Data,Eq,Ord) + +noComments ::EpAnnCO +noComments = EpAnn noSpanAnchor NoEpAnns emptyComments + +-- TODO:AZ get rid of this +placeholderRealSpan :: RealSrcSpan +placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1)) + +comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO +comment loc cs = EpAnn (EpaSpan (RealSrcSpan loc Strict.Nothing)) NoEpAnns cs + +-- --------------------------------------------------------------------- +-- Utilities for managing comments in an `EpAnn a` structure. +-- --------------------------------------------------------------------- + +-- | Add additional comments to a 'EpAnn', used for manipulating the +-- AST prior to exact printing the changed one. +addCommentsToEpAnn :: (NoAnn ann) => EpAnn ann -> EpAnnComments -> EpAnn ann +addCommentsToEpAnn (EpAnn a an cs) cs' = EpAnn a an (cs <> cs') + +-- | Replace any existing comments on a 'EpAnn', used for manipulating the +-- AST prior to exact printing the changed one. +setCommentsEpAnn :: (NoAnn ann) => EpAnn ann -> EpAnnComments -> EpAnn ann +setCommentsEpAnn (EpAnn a an _) cs = (EpAnn a an cs) + +-- | Transfer comments and trailing items from the annotations in the +-- first 'SrcSpanAnnA' argument to those in the second. +transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA) +transferAnnsA (EpAnn a an cs) (EpAnn a' an' cs') + = (EpAnn a noAnn emptyComments, EpAnn a' (an' <> an) (cs' <> cs)) + +-- | Transfer trailing items but not comments from the annotations in the +-- first 'SrcSpanAnnA' argument to those in the second. +transferFollowingA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA) +transferFollowingA (EpAnn a1 an1 cs1) (EpAnn a2 an2 cs2) + = (EpAnn a1 noAnn cs1', EpAnn a2 (an1 <> an2) cs2') + where + pc = priorComments cs1 + fc = getFollowingComments cs1 + cs1' = setPriorComments emptyComments pc + cs2' = setFollowingComments cs2 fc + +-- | Transfer trailing items from the annotations in the +-- first 'SrcSpanAnnA' argument to those in the second. +transferAnnsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA) +transferAnnsOnlyA (EpAnn a an cs) (EpAnn a' an' cs') + = (EpAnn a noAnn cs, EpAnn a' (an' <> an) cs') + +-- | Transfer comments from the annotations in the +-- first 'SrcSpanAnnA' argument to those in the second. +transferCommentsOnlyA :: EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b) +transferCommentsOnlyA (EpAnn a an cs) (EpAnn a' an' cs') + = (EpAnn a an emptyComments, EpAnn a' an' (cs <> cs')) + +-- | Transfer prior comments only from the annotations in the +-- first 'SrcSpanAnnA' argument to those in the second. +transferPriorCommentsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA) +transferPriorCommentsA (EpAnn a1 an1 cs1) (EpAnn a2 an2 cs2) + = (EpAnn a1 an1 cs1', EpAnn a2 an2 cs2') + where + pc = priorComments cs1 + fc = getFollowingComments cs1 + cs1' = setFollowingComments emptyComments fc + cs2' = setPriorComments cs2 (priorComments cs2 <> pc) + +-- --------------------------------------------------------------------- +-- Semigroup instances, to allow easy combination of annotation elements +-- --------------------------------------------------------------------- + +instance (Semigroup a) => Semigroup (EpAnn a) where + (EpAnn l1 a1 b1) <> (EpAnn l2 a2 b2) = EpAnn (l1 <> l2) (a1 <> a2) (b1 <> b2) + -- The critical part about the anchor is its left edge, and all + -- annotations must follow it. So we combine them which yields the + -- largest span + +instance Semigroup EpaLocation where + EpaSpan s1 <> EpaSpan s2 = EpaSpan (combineSrcSpans s1 s2) + EpaSpan s1 <> _ = EpaSpan s1 + _ <> EpaSpan s2 = EpaSpan s2 + EpaDelta s1 dp1 cs1 <> EpaDelta s2 _dp2 cs2 = EpaDelta (combineSrcSpans s1 s2) dp1 (cs1<>cs2) + +instance Semigroup EpAnnComments where + EpaComments cs1 <> EpaComments cs2 = EpaComments (cs1 ++ cs2) + EpaComments cs1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) as2 + EpaCommentsBalanced cs1 as1 <> EpaComments cs2 = EpaCommentsBalanced (cs1 ++ cs2) as1 + EpaCommentsBalanced cs1 as1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) (as1++as2) + +instance Semigroup AnnListItem where + (AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2) + +instance Semigroup (AnnSortKey tag) where + NoAnnSortKey <> x = x + x <> NoAnnSortKey = x + AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2) + +instance Monoid (AnnSortKey tag) where + mempty = NoAnnSortKey + +-- --------------------------------------------------------------------- +-- NoAnn instances +-- --------------------------------------------------------------------- + +instance NoAnn EpaLocation where + noAnn = EpaDelta noSrcSpan (SameLine 0) [] + +instance NoAnn [a] where + noAnn = [] + +instance NoAnn (Maybe a) where + noAnn = Nothing + +instance NoAnn a => NoAnn (Either a b) where + noAnn = Left noAnn + +instance (NoAnn a, NoAnn b) => NoAnn (a, b) where + noAnn = (noAnn, noAnn) + +instance (NoAnn a, NoAnn b, NoAnn c) => NoAnn (a, b, c) where + noAnn = (noAnn, noAnn, noAnn) + +instance (NoAnn a, NoAnn b, NoAnn c, NoAnn d) => NoAnn (a, b, c, d) where + noAnn = (noAnn, noAnn, noAnn, noAnn) + +instance NoAnn Bool where + noAnn = False + +instance NoAnn () where + noAnn = () + +instance (NoAnn ann) => NoAnn (EpAnn ann) where + noAnn = EpAnn noSpanAnchor noAnn emptyComments + +instance NoAnn NoEpAnns where + noAnn = NoEpAnns + +instance NoAnn AnnListItem where + noAnn = AnnListItem [] + +instance NoAnn AnnContext where + noAnn = AnnContext Nothing [] [] + +instance NoAnn a => NoAnn (AnnList a) where + noAnn = AnnList Nothing ListNone noAnn noAnn [] + +instance NoAnn NameAnn where + noAnn = NameAnnTrailing [] + +instance NoAnn AnnPragma where + noAnn = AnnPragma noAnn noAnn noAnn noAnn noAnn noAnn noAnn + +instance NoAnn AnnParen where + noAnn = AnnParens noAnn noAnn + +instance NoAnn (EpToken s) where + noAnn = NoEpTok + +instance NoAnn (EpUniToken s t) where + noAnn = NoEpUniTok + +instance NoAnn SourceText where + noAnn = NoSourceText + +-- --------------------------------------------------------------------- + +instance (Outputable a) => Outputable (EpAnn a) where + ppr (EpAnn l a c) = text "EpAnn" <+> ppr l <+> ppr a <+> ppr c + +instance Outputable NoEpAnns where + ppr NoEpAnns = text "NoEpAnns" + +instance Outputable (GenLocated NoCommentsLocation EpaComment) where + ppr (L l c) = text "L" <+> ppr l <+> ppr c + +instance Outputable EpAnnComments where + ppr (EpaComments cs) = text "EpaComments" <+> ppr cs + ppr (EpaCommentsBalanced cs ts) = text "EpaCommentsBalanced" <+> ppr cs <+> ppr ts + +instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where + getName (L l a) = getName (L (locA l) a) + +instance Outputable AnnContext where + ppr (AnnContext a o c) = text "AnnContext" <+> ppr a <+> ppr o <+> ppr c + +instance Outputable BindTag where + ppr tag = text $ show tag + +instance Outputable DeclTag where + ppr tag = text $ show tag + +instance Outputable tag => Outputable (AnnSortKey tag) where + ppr NoAnnSortKey = text "NoAnnSortKey" + ppr (AnnSortKey ls) = text "AnnSortKey" <+> ppr ls + +instance Outputable IsUnicodeSyntax where + ppr = text . show + +instance (Outputable a, Outputable e) + => Outputable (GenLocated (EpAnn a) e) where + ppr = pprLocated + +instance (Outputable a, OutputableBndr e) + => OutputableBndr (GenLocated (EpAnn a) e) where + pprInfixOcc = pprInfixOcc . unLoc + pprPrefixOcc = pprPrefixOcc . unLoc + +instance (Outputable e) + => Outputable (GenLocated EpaLocation e) where + ppr = pprLocated + +instance Outputable AnnParen where + ppr (AnnParens o c) = text "AnnParens" <+> ppr o <+> ppr c + ppr (AnnParensHash o c) = text "AnnParensHash" <+> ppr o <+> ppr c + ppr (AnnParensSquare o c) = text "AnnParensSquare" <+> ppr o <+> ppr c + +instance Outputable AnnListItem where + ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts + +instance Outputable NameAdornment where + ppr (NameParens o c) = text "NameParens" <+> ppr o <+> ppr c + ppr (NameParensHash o c) = text "NameParensHash" <+> ppr o <+> ppr c + ppr (NameBackquotes o c) = text "NameBackquotes" <+> ppr o <+> ppr c + ppr (NameSquare o c) = text "NameSquare" <+> ppr o <+> ppr c + ppr NameNoAdornment = text "NameNoAdornment" + +instance Outputable NameAnn where + ppr (NameAnn a n t) + = text "NameAnn" <+> ppr a <+> ppr n <+> ppr t + ppr (NameAnnCommas a n t) + = text "NameAnnCommas" <+> ppr a <+> ppr n <+> ppr t + ppr (NameAnnBars a n t) + = text "NameAnnBars" <+> ppr a <+> ppr n <+> ppr t + ppr (NameAnnOnly a t) + = text "NameAnnOnly" <+> ppr a <+> ppr t + ppr (NameAnnRArrow o n c t) + = text "NameAnnRArrow" <+> ppr o <+> ppr n <+> ppr c <+> ppr t + ppr (NameAnnQuote q n t) + = text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t + ppr (NameAnnTrailing t) + = text "NameAnnTrailing" <+> ppr t + +instance (Outputable a) => Outputable (AnnList a) where + ppr (AnnList anc p s a t) + = text "AnnList" <+> ppr anc <+> ppr p <+> ppr s <+> ppr a <+> ppr t + +instance Outputable AnnListBrackets where + ppr (ListParens o c) = text "ListParens" <+> ppr o <+> ppr c + ppr (ListBraces o c) = text "ListBraces" <+> ppr o <+> ppr c + ppr (ListSquare o c) = text "ListSquare" <+> ppr o <+> ppr c + ppr (ListBanana o c) = text "ListBanana" <+> ppr o <+> ppr c + ppr ListNone = text "ListNone" + +instance Outputable AnnPragma where + ppr (AnnPragma o c s l ca t m) + = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr s <+> ppr l + <+> ppr ca <+> ppr ca <+> ppr t <+> ppr m diff --git a/GHC/Parser/CharClass.hs b/GHC/Parser/CharClass.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/CharClass.hs @@ -0,0 +1,212 @@ +-- Character classification + +module GHC.Parser.CharClass + ( is_ident -- Char# -> Bool + , is_symbol -- Char# -> Bool + , is_any -- Char# -> Bool + , is_space -- Char# -> Bool + , is_lower -- Char# -> Bool + , is_upper -- Char# -> Bool + , is_digit -- Char# -> Bool + , is_alphanum -- Char# -> Bool + + , is_decdigit, is_hexdigit, is_octdigit, is_bindigit + , hexDigit, octDecDigit + ) where + +import GHC.Prelude + +import Data.Char ( ord, chr ) +import Data.Word +import GHC.Utils.Panic + +-- Bit masks + +cIdent, cSymbol, cAny, cSpace, cLower, cUpper, cDigit :: Word8 +cIdent = 1 +cSymbol = 2 +cAny = 4 +cSpace = 8 +cLower = 16 +cUpper = 32 +cDigit = 64 + +-- | The predicates below look costly, but aren't, GHC+GCC do a great job +-- at the big case below. + +{-# INLINABLE is_ctype #-} +is_ctype :: Word8 -> Char -> Bool +is_ctype mask c = c <= '\127' && (charType c .&. mask) /= 0 + +is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit, + is_alphanum :: Char -> Bool +is_ident = is_ctype cIdent +is_symbol = is_ctype cSymbol +is_any = is_ctype cAny +is_space = is_ctype cSpace +is_lower = is_ctype cLower +is_upper = is_ctype cUpper +is_digit = is_ctype cDigit +is_alphanum = is_ctype (cLower+cUpper+cDigit) + +-- Utils + +hexDigit :: Char -> Int +hexDigit c | is_decdigit c = ord c - ord '0' + | otherwise = ord (to_lower c) - ord 'a' + 10 + +octDecDigit :: Char -> Int +octDecDigit c = ord c - ord '0' + +is_decdigit :: Char -> Bool +is_decdigit c + = c >= '0' && c <= '9' + +is_hexdigit :: Char -> Bool +is_hexdigit c + = is_decdigit c + || (c >= 'a' && c <= 'f') + || (c >= 'A' && c <= 'F') + +is_octdigit :: Char -> Bool +is_octdigit c = c >= '0' && c <= '7' + +is_bindigit :: Char -> Bool +is_bindigit c = c == '0' || c == '1' + +to_lower :: Char -> Char +to_lower c + | c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a')) + | otherwise = c + +charType :: Char -> Word8 +charType c = case c of + '\0' -> 0 -- \000 + '\1' -> 0 -- \001 + '\2' -> 0 -- \002 + '\3' -> 0 -- \003 + '\4' -> 0 -- \004 + '\5' -> 0 -- \005 + '\6' -> 0 -- \006 + '\7' -> 0 -- \007 + '\8' -> 0 -- \010 + '\9' -> cSpace -- \t (not allowed in strings, so !cAny) + '\10' -> cSpace -- \n (ditto) + '\11' -> cSpace -- \v (ditto) + '\12' -> cSpace -- \f (ditto) + '\13' -> cSpace -- ^M (ditto) + '\14' -> 0 -- \016 + '\15' -> 0 -- \017 + '\16' -> 0 -- \020 + '\17' -> 0 -- \021 + '\18' -> 0 -- \022 + '\19' -> 0 -- \023 + '\20' -> 0 -- \024 + '\21' -> 0 -- \025 + '\22' -> 0 -- \026 + '\23' -> 0 -- \027 + '\24' -> 0 -- \030 + '\25' -> 0 -- \031 + '\26' -> 0 -- \032 + '\27' -> 0 -- \033 + '\28' -> 0 -- \034 + '\29' -> 0 -- \035 + '\30' -> 0 -- \036 + '\31' -> 0 -- \037 + '\32' -> cAny .|. cSpace -- + '\33' -> cAny .|. cSymbol -- ! + '\34' -> cAny -- " + '\35' -> cAny .|. cSymbol -- # + '\36' -> cAny .|. cSymbol -- $ + '\37' -> cAny .|. cSymbol -- % + '\38' -> cAny .|. cSymbol -- & + '\39' -> cAny .|. cIdent -- ' + '\40' -> cAny -- ( + '\41' -> cAny -- ) + '\42' -> cAny .|. cSymbol -- * + '\43' -> cAny .|. cSymbol -- + + '\44' -> cAny -- , + '\45' -> cAny .|. cSymbol -- - + '\46' -> cAny .|. cSymbol -- . + '\47' -> cAny .|. cSymbol -- / + '\48' -> cAny .|. cIdent .|. cDigit -- 0 + '\49' -> cAny .|. cIdent .|. cDigit -- 1 + '\50' -> cAny .|. cIdent .|. cDigit -- 2 + '\51' -> cAny .|. cIdent .|. cDigit -- 3 + '\52' -> cAny .|. cIdent .|. cDigit -- 4 + '\53' -> cAny .|. cIdent .|. cDigit -- 5 + '\54' -> cAny .|. cIdent .|. cDigit -- 6 + '\55' -> cAny .|. cIdent .|. cDigit -- 7 + '\56' -> cAny .|. cIdent .|. cDigit -- 8 + '\57' -> cAny .|. cIdent .|. cDigit -- 9 + '\58' -> cAny .|. cSymbol -- : + '\59' -> cAny -- ; + '\60' -> cAny .|. cSymbol -- < + '\61' -> cAny .|. cSymbol -- = + '\62' -> cAny .|. cSymbol -- > + '\63' -> cAny .|. cSymbol -- ? + '\64' -> cAny .|. cSymbol -- @ + '\65' -> cAny .|. cIdent .|. cUpper -- A + '\66' -> cAny .|. cIdent .|. cUpper -- B + '\67' -> cAny .|. cIdent .|. cUpper -- C + '\68' -> cAny .|. cIdent .|. cUpper -- D + '\69' -> cAny .|. cIdent .|. cUpper -- E + '\70' -> cAny .|. cIdent .|. cUpper -- F + '\71' -> cAny .|. cIdent .|. cUpper -- G + '\72' -> cAny .|. cIdent .|. cUpper -- H + '\73' -> cAny .|. cIdent .|. cUpper -- I + '\74' -> cAny .|. cIdent .|. cUpper -- J + '\75' -> cAny .|. cIdent .|. cUpper -- K + '\76' -> cAny .|. cIdent .|. cUpper -- L + '\77' -> cAny .|. cIdent .|. cUpper -- M + '\78' -> cAny .|. cIdent .|. cUpper -- N + '\79' -> cAny .|. cIdent .|. cUpper -- O + '\80' -> cAny .|. cIdent .|. cUpper -- P + '\81' -> cAny .|. cIdent .|. cUpper -- Q + '\82' -> cAny .|. cIdent .|. cUpper -- R + '\83' -> cAny .|. cIdent .|. cUpper -- S + '\84' -> cAny .|. cIdent .|. cUpper -- T + '\85' -> cAny .|. cIdent .|. cUpper -- U + '\86' -> cAny .|. cIdent .|. cUpper -- V + '\87' -> cAny .|. cIdent .|. cUpper -- W + '\88' -> cAny .|. cIdent .|. cUpper -- X + '\89' -> cAny .|. cIdent .|. cUpper -- Y + '\90' -> cAny .|. cIdent .|. cUpper -- Z + '\91' -> cAny -- [ + '\92' -> cAny .|. cSymbol -- backslash + '\93' -> cAny -- ] + '\94' -> cAny .|. cSymbol -- ^ + '\95' -> cAny .|. cIdent .|. cLower -- _ + '\96' -> cAny -- ` + '\97' -> cAny .|. cIdent .|. cLower -- a + '\98' -> cAny .|. cIdent .|. cLower -- b + '\99' -> cAny .|. cIdent .|. cLower -- c + '\100' -> cAny .|. cIdent .|. cLower -- d + '\101' -> cAny .|. cIdent .|. cLower -- e + '\102' -> cAny .|. cIdent .|. cLower -- f + '\103' -> cAny .|. cIdent .|. cLower -- g + '\104' -> cAny .|. cIdent .|. cLower -- h + '\105' -> cAny .|. cIdent .|. cLower -- i + '\106' -> cAny .|. cIdent .|. cLower -- j + '\107' -> cAny .|. cIdent .|. cLower -- k + '\108' -> cAny .|. cIdent .|. cLower -- l + '\109' -> cAny .|. cIdent .|. cLower -- m + '\110' -> cAny .|. cIdent .|. cLower -- n + '\111' -> cAny .|. cIdent .|. cLower -- o + '\112' -> cAny .|. cIdent .|. cLower -- p + '\113' -> cAny .|. cIdent .|. cLower -- q + '\114' -> cAny .|. cIdent .|. cLower -- r + '\115' -> cAny .|. cIdent .|. cLower -- s + '\116' -> cAny .|. cIdent .|. cLower -- t + '\117' -> cAny .|. cIdent .|. cLower -- u + '\118' -> cAny .|. cIdent .|. cLower -- v + '\119' -> cAny .|. cIdent .|. cLower -- w + '\120' -> cAny .|. cIdent .|. cLower -- x + '\121' -> cAny .|. cIdent .|. cLower -- y + '\122' -> cAny .|. cIdent .|. cLower -- z + '\123' -> cAny -- { + '\124' -> cAny .|. cSymbol -- | + '\125' -> cAny -- } + '\126' -> cAny .|. cSymbol -- ~ + '\127' -> 0 -- \177 + _ -> panic ("charType: " ++ show c) diff --git a/GHC/Parser/Errors/Basic.hs b/GHC/Parser/Errors/Basic.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Errors/Basic.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE LambdaCase #-} +module GHC.Parser.Errors.Basic where + +import GHC.Utils.Outputable ( SDoc, text ) + +-- | The operator symbol in the 'PsOperatorWhitespaceExtConflictMessage' diagnostic. +data OperatorWhitespaceSymbol + = OperatorWhitespaceSymbol_PrefixPercent + | OperatorWhitespaceSymbol_PrefixDollar + | OperatorWhitespaceSymbol_PrefixDollarDollar + +pprOperatorWhitespaceSymbol :: OperatorWhitespaceSymbol -> SDoc +pprOperatorWhitespaceSymbol = \case + OperatorWhitespaceSymbol_PrefixPercent -> text "%" + OperatorWhitespaceSymbol_PrefixDollar -> text "$" + OperatorWhitespaceSymbol_PrefixDollarDollar -> text "$$" + +-- | The operator occurrence type in the 'PsOperatorWhitespaceMessage' diagnostic. +data OperatorWhitespaceOccurrence + = OperatorWhitespaceOccurrence_Prefix + | OperatorWhitespaceOccurrence_Suffix + | OperatorWhitespaceOccurrence_TightInfix diff --git a/GHC/Parser/Errors/Ppr.hs b/GHC/Parser/Errors/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Errors/Ppr.hs @@ -0,0 +1,954 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage + +module GHC.Parser.Errors.Ppr where + +import GHC.Prelude +import GHC.Driver.Flags +import GHC.Parser.Errors.Basic +import GHC.Parser.Errors.Types +import GHC.Parser.Types +import GHC.Types.Basic +import GHC.Types.Hint +import GHC.Types.Error +import GHC.Types.Hint.Ppr (perhapsAsPat) +import GHC.Types.SrcLoc +import GHC.Types.Error.Codes +import GHC.Types.Name.Reader ( opIsAt, rdrNameOcc, mkUnqual ) +import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Data.Maybe (catMaybes) +import GHC.Hs.Expr (prependQualified, HsExpr(..), HsLamVariant(..), lamCaseKeyword) +import GHC.Hs.Type (pprLHsContext, pprHsArrow, pprHsForAll) +import GHC.Builtin.Names (allNameStringList) +import qualified GHC.LanguageExtensions as LangExt +import Data.List.NonEmpty (NonEmpty((:|))) +import GHC.Hs.Pat (Pat(..), LPat) +import GHC.Hs.Extension +import GHC.Parser.Annotation (noAnn) + + +instance Diagnostic PsMessage where + type DiagnosticOpts PsMessage = NoDiagnosticOpts + diagnosticMessage opts = \case + PsUnknownMessage (UnknownDiagnostic f _ m) + -> diagnosticMessage (f opts) m + + PsHeaderMessage m + -> psHeaderMessageDiagnostic m + + PsWarnHaddockInvalidPos + -> mkSimpleDecorated $ text "A Haddock comment cannot appear in this position and will be ignored." + PsWarnHaddockIgnoreMulti + -> mkSimpleDecorated $ + text "Multiple Haddock comments for a single entity are not allowed." $$ + text "The extraneous comment will be ignored." + PsWarnBidirectionalFormatChars ((loc,_,desc) :| xs) + -> mkSimpleDecorated $ + text "A unicode bidirectional formatting character" <+> parens (text desc) + $$ text "was found at offset" <+> ppr (bufPos (psBufPos loc)) <+> text "in the file" + $$ (case xs of + [] -> empty + xs -> text "along with further bidirectional formatting characters at" <+> pprChars xs + where + pprChars [] = empty + pprChars ((loc,_,desc):xs) = text "offset" <+> ppr (bufPos (psBufPos loc)) <> text ":" <+> text desc + $$ pprChars xs + ) + $$ text "Bidirectional formatting characters may be rendered misleadingly in certain editors" + + PsWarnTab tc + -> mkSimpleDecorated $ + text "Tab character found here" + <> (if tc == 1 + then text "" + else text ", and in" <+> speakNOf (fromIntegral (tc - 1)) (text "further location")) + <> text "." + PsWarnTransitionalLayout reason + -> mkSimpleDecorated $ + text "transitional layout will not be accepted in the future:" + $$ (case reason of + TransLayout_Where -> text "`where' clause at the same depth as implicit layout block" + TransLayout_Pipe -> text "`|' at the same depth as implicit layout block" + ) + PsWarnOperatorWhitespaceExtConflict sym + -> let mk_prefix_msg extension_name syntax_meaning = + text "The prefix use of a" <+> quotes (pprOperatorWhitespaceSymbol sym) + <+> text "would denote" <+> syntax_meaning + $$ nest 2 (text "were the" <+> extension_name <+> text "extension enabled.") + in mkSimpleDecorated $ + case sym of + OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg (text "LinearTypes") (text "a multiplicity annotation") + OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg (text "TemplateHaskell") (text "an untyped splice") + OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg (text "TemplateHaskell") (text "a typed splice") + PsWarnOperatorWhitespace sym occ_type + -> let mk_msg occ_type_str = + text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym) + <+> text "might be repurposed as special syntax" + $$ nest 2 (text "by a future language extension.") + in mkSimpleDecorated $ + case occ_type of + OperatorWhitespaceOccurrence_Prefix -> mk_msg "prefix" + OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix" + OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" + PsWarnStarBinder + -> mkSimpleDecorated $ + text "Found binding occurrence of" <+> quotes (text "*") + <+> text "yet StarIsType is enabled." + PsWarnStarIsType + -> mkSimpleDecorated $ + text "Using" <+> quotes (text "*") + <+> text "(or its Unicode variant) to mean" + <+> quotes (text "Data.Kind.Type") + $$ text "relies on the StarIsType extension, which will become" + $$ text "deprecated in the future." + PsWarnUnrecognisedPragma prag _ + -> mkSimpleDecorated $ text "Unrecognised pragma" + <> if null prag then empty else text ":" <+> text prag + PsWarnMisplacedPragma prag + -> mkSimpleDecorated $ text "Misplaced" <+> pprFileHeaderPragmaType prag <+> text "pragma" + PsWarnImportPreQualified + -> mkSimpleDecorated $ + text "Found" <+> quotes (text "qualified") + <+> text "in prepositive position" + PsWarnViewPatternSignatures old new + -> mkDecorated $ + [ text "Found an unparenthesized pattern signature on the RHS of a view pattern." + , vcat [ text "This code might stop working in a future GHC release" + , text "due to a planned change to the precedence of view patterns," + , text "unless the view function is an endofunction." ] + , nest 2 $ + vcat [ text "Current parse:" <+> quotes (ppr (add_parens_sig old)) + , text "Future parse:" <+> quotes (ppr (add_parens_view new)) ] + ] + where + add_parens_sig :: LPat GhcPs -> LPat GhcPs + add_parens_sig = go + where go (L l (ViewPat x e p)) = L l (ViewPat x e (go p)) + go (L l (SigPat x p sig)) = par_pat (L l (SigPat x p sig)) + go p = p + + add_parens_view :: LPat GhcPs -> LPat GhcPs + add_parens_view = go + where go (L l (ViewPat x e p)) = par_pat (L l (ViewPat x e p)) + go (L l (SigPat x p sig)) = L l (SigPat x (go p) sig) + go p = p + + par_pat :: LPat GhcPs -> LPat GhcPs + par_pat p = L noAnn (ParPat noAnn p) + + PsErrLexer err kind + -> mkSimpleDecorated $ hcat + [ case err of + LexError -> text "lexical error" + LexUnknownPragma -> text "unknown pragma" + LexErrorInPragma -> text "lexical error in pragma" + LexNumEscapeRange -> text "numeric escape sequence out of range" + LexUnterminatedComment -> text "unterminated `{-'" + LexUnterminatedOptions -> text "unterminated OPTIONS pragma" + LexUnterminatedQQ -> text "unterminated quasiquotation" + + , case kind of + LexErrKind_EOF -> text " at end of input" + LexErrKind_UTF8 -> text " (UTF-8 decoding error)" + LexErrKind_Char c -> text $ " at character " ++ show c + ] + PsErrParse token _details + | null token + -> mkSimpleDecorated $ text "parse error (possibly incorrect indentation or mismatched brackets)" + | otherwise + -> mkSimpleDecorated $ text "parse error on input" <+> quotes (text token) + PsErrCmmLexer + -> mkSimpleDecorated $ text "Cmm lexical error" + PsErrCmmParser cmm_err -> mkSimpleDecorated $ case cmm_err of + CmmUnknownPrimitive name -> text "unknown primitive" <+> ftext name + CmmUnknownMacro fun -> text "unknown macro" <+> ftext fun + CmmUnknownCConv cconv -> text "unknown calling convention:" <+> text cconv + CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety + CmmUnrecognisedHint hint -> text "unrecognised hint:" <+> text hint + + PsErrTypeAppWithoutSpace v e + -> mkSimpleDecorated $ + sep [ text "@-pattern in expression context:" + , nest 4 (pprPrefixOcc v <> text "@" <> ppr e) + ] + $$ text "Type application syntax requires a space before '@'" + PsErrLazyPatWithoutSpace e + -> mkSimpleDecorated $ + sep [ text "Lazy pattern in expression context:" + , nest 4 (text "~" <> ppr e) + ] + $$ text "Did you mean to add a space after the '~'?" + PsErrBangPatWithoutSpace e + -> mkSimpleDecorated $ + sep [ text "Bang pattern in expression context:" + , nest 4 (text "!" <> ppr e) + ] + $$ text "Did you mean to add a space after the '!'?" + PsErrInvalidInfixHole + -> mkSimpleDecorated $ text "Invalid infix hole, expected an infix operator" + PsErrExpectedHyphen + -> mkSimpleDecorated $ text "Expected a hyphen" + PsErrSpaceInSCC + -> mkSimpleDecorated $ text "Spaces are not allowed in SCCs" + PsErrEmptyDoubleQuotes _th_on + -> mkSimpleDecorated $ vcat msg + where + msg = [ text "Parser error on `''`" + , text "Character literals may not be empty" + ] + PsErrLambdaCase + -- we can't get this error for \cases, since without -XLambdaCase, that's + -- just a regular lambda expression + -> mkSimpleDecorated $ text "Illegal" <+> lamCaseKeyword LamCase + PsErrEmptyLambda + -> mkSimpleDecorated $ text "A lambda requires at least one parameter" + PsErrLinearFunction + -> mkSimpleDecorated $ text "Illegal use of linear functions" + PsErrOverloadedRecordUpdateNotEnabled + -> mkSimpleDecorated $ text "Illegal overloaded record update" + PsErrMultiWayIf + -> mkSimpleDecorated $ text "Illegal multi-way if-expression" + PsErrNumUnderscores reason + -> mkSimpleDecorated $ + text $ case reason of + NumUnderscore_Integral -> "Illegal underscores in integer literals" + NumUnderscore_Float -> "Illegal underscores in floating literals" + PsErrIllegalBangPattern e + -> mkSimpleDecorated $ text "Illegal bang-pattern or strict binding" $$ ppr e + PsErrOverloadedRecordDotInvalid + -> mkSimpleDecorated $ + text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)" + PsErrIllegalPatSynExport + -> mkSimpleDecorated $ text "Illegal export form" + PsErrOverloadedRecordUpdateNoQualifiedFields + -> mkSimpleDecorated $ text "Fields cannot be qualified when OverloadedRecordUpdate is enabled" + PsErrExplicitForall is_unicode + -> mkSimpleDecorated $ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type" + PsErrIllegalQualifiedDo qdoDoc + -> mkSimpleDecorated $ + text "Illegal qualified" <+> quotes qdoDoc <+> text "block" + PsErrQualifiedDoInCmd m + -> mkSimpleDecorated $ + hang (text "Parse error in command:") 2 $ + text "Found a qualified" <+> ppr m <> text ".do block in a command, but" + $$ text "qualified 'do' is not supported in commands." + PsErrRecordSyntaxInPatSynDecl pat + -> mkSimpleDecorated $ + text "record syntax not supported for pattern synonym declarations:" + $$ ppr pat + PsErrEmptyWhereInPatSynDecl patsyn_name + -> mkSimpleDecorated $ + text "pattern synonym 'where' clause cannot be empty" + $$ text "In the pattern synonym declaration for: " + <+> ppr (patsyn_name) + PsErrInvalidWhereBindInPatSynDecl patsyn_name decl + -> mkSimpleDecorated $ + text "pattern synonym 'where' clause must bind the pattern synonym's name" + <+> quotes (ppr patsyn_name) $$ ppr decl + PsErrNoSingleWhereBindInPatSynDecl _patsyn_name decl + -> mkSimpleDecorated $ + text "pattern synonym 'where' clause must contain a single binding:" + $$ ppr decl + PsErrDeclSpliceNotAtTopLevel d + -> mkSimpleDecorated $ + hang (text "Declaration splices are allowed only" + <+> text "at the top level:") + 2 (ppr d) + PsErrMultipleNamesInStandaloneKindSignature vs + -> mkSimpleDecorated $ + vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:") + 2 (pprWithCommas ppr vs) + , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." + ] + PsErrIllegalExplicitNamespace kw + -> mkSimpleDecorated $ + text "Illegal keyword" <+> quotes kw_doc + where + kw_doc = case kw of + ExplicitTypeNamespace{} -> text "type" + ExplicitDataNamespace{} -> text "data" + + + PsErrUnallowedPragma prag + -> mkSimpleDecorated $ + hang (text "A pragma is not allowed in this position:") 2 + (ppr prag) + PsErrImportPostQualified + -> mkSimpleDecorated $ + text "Found" <+> quotes (text "qualified") + <+> text "in postpositive position. " + PsErrImportQualifiedTwice + -> mkSimpleDecorated $ text "Multiple occurrences of 'qualified'" + PsErrSpliceOrQuoteTwice + -> mkSimpleDecorated $ text "Multiple occurrences of a splice or quote keyword" + PsErrIllegalImportBundleForm + -> mkSimpleDecorated $ + text "Illegal import form, this syntax can only be used to bundle" + $+$ text "pattern synonyms with types in module exports." + PsErrInvalidRuleActivationMarker + -> mkSimpleDecorated $ text "Invalid rule activation marker" + + PsErrMissingBlock + -> mkSimpleDecorated $ text "Missing block" + PsErrUnsupportedBoxedSumExpr s + -> mkSimpleDecorated $ + hang (text "Boxed sums not supported:") 2 + (pprSumOrTuple Boxed s) + PsErrUnsupportedBoxedSumPat s + -> mkSimpleDecorated $ + hang (text "Boxed sums not supported:") 2 + (pprSumOrTuple Boxed s) + PsErrUnexpectedQualifiedConstructor v + -> mkSimpleDecorated $ + hang (text "Expected an unqualified type constructor:") 2 + (ppr v) + PsErrTupleSectionInPat + -> mkSimpleDecorated $ text "Tuple section in pattern context" + PsErrOpFewArgs _ op + -> mkSimpleDecorated $ + text "Operator applied to too few arguments:" <+> ppr op + PsErrVarForTyCon name + -> mkSimpleDecorated $ + text "Expecting a type constructor but found a variable," + <+> quotes (ppr name) <> text "." + $$ if isSymOcc $ rdrNameOcc name + then text "If" <+> quotes (ppr name) <+> text "is a type constructor" + <+> text "then enable ExplicitNamespaces and use the 'type' keyword." + else empty + PsErrMalformedEntityString + -> mkSimpleDecorated $ text "Malformed entity string" + PsErrDotsInRecordUpdate + -> mkSimpleDecorated $ text "You cannot use `..' in a record update" + PsErrInvalidDataCon t + -> mkSimpleDecorated $ + hang (text "Cannot parse data constructor in a data/newtype declaration:") 2 + (ppr t) + PsErrInvalidInfixDataCon lhs tc rhs + -> mkSimpleDecorated $ + hang (text "Cannot parse an infix data constructor in a data/newtype declaration:") 2 + (ppr lhs <+> ppr tc <+> ppr rhs) + PsErrIllegalPromotionQuoteDataCon name + -> mkSimpleDecorated $ + text "Illegal promotion quote mark in the declaration of" $$ + text "data/newtype constructor" <+> pprPrefixOcc name + PsErrUnpackDataCon + -> mkSimpleDecorated $ text "{-# UNPACK #-} cannot be applied to a data constructor." + PsErrUnexpectedKindAppInDataCon lhs ki + -> mkSimpleDecorated $ + hang (text "Unexpected kind application in a data/newtype declaration:") 2 + (ppr lhs <+> text "@" <> ppr ki) + PsErrInvalidRecordCon p + -> mkSimpleDecorated $ text "Not a record constructor:" <+> ppr p + PsErrIllegalUnboxedStringInPat lit + -> mkSimpleDecorated $ text "Illegal unboxed string literal in pattern:" $$ ppr lit + PsErrIllegalUnboxedFloatingLitInPat lit + -> mkSimpleDecorated $ text "Illegal unboxed floating point literal in pattern:" $$ ppr lit + PsErrDoNotationInPat + -> mkSimpleDecorated $ text "do-notation in pattern" + PsErrIfThenElseInPat + -> mkSimpleDecorated $ text "(if ... then ... else ...)-syntax in pattern" + PsErrCaseInPat + -> mkSimpleDecorated $ text "(case ... of ...)-syntax in pattern" + PsErrLetInPat + -> mkSimpleDecorated $ text "(let ... in ...)-syntax in pattern" + PsErrLambdaInPat lam_variant + -> mkSimpleDecorated $ text "Illegal" <+> lamCaseKeyword lam_variant <> text "-syntax in pattern" + PsErrArrowExprInPat e + -> mkSimpleDecorated $ text "Expression syntax in pattern:" <+> ppr e + PsErrArrowCmdInPat c + -> mkSimpleDecorated $ text "Command syntax in pattern:" <+> ppr c + PsErrArrowCmdInExpr c + -> mkSimpleDecorated $ + vcat + [ text "Arrow command found where an expression was expected:" + , nest 2 (ppr c) + ] + PsErrOrPatInExpr p + -> mkSimpleDecorated $ + sep [ text "Or pattern in expression context:" + , nest 4 (ppr p) + ] + PsErrCaseCmdInFunAppCmd a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a + PsErrLambdaCmdInFunAppCmd lam_variant a + -> mkSimpleDecorated $ + pp_unexpected_fun_app (lamCaseKeyword lam_variant <+> text "command") a + PsErrIfCmdInFunAppCmd a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if command") a + PsErrLetCmdInFunAppCmd a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let command") a + PsErrDoCmdInFunAppCmd a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "do command") a + PsErrDoInFunAppExpr m a + -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "do block")) a + PsErrMDoInFunAppExpr m a + -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "mdo block")) a + PsErrCaseInFunAppExpr a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case expression") a + PsErrLambdaInFunAppExpr lam_variant a + -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lam_variant <+> text "expression") a + PsErrLetInFunAppExpr a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let expression") a + PsErrIfInFunAppExpr a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if expression") a + PsErrProcInFunAppExpr a + -> mkSimpleDecorated $ pp_unexpected_fun_app (text "proc expression") a + PsErrMalformedTyOrClDecl ty + -> mkSimpleDecorated $ + text "Malformed head of type or class declaration:" <+> ppr ty + PsErrIllegalWhereInDataDecl + -> mkSimpleDecorated $ text "Illegal keyword 'where' in data declaration" + PsErrIllegalDataTypeContext c + -> mkSimpleDecorated $ + text "Illegal datatype context:" + <+> pprLHsContext (Just c) + PsErrPrimStringInvalidChar + -> mkSimpleDecorated $ text "primitive string literal must contain only characters <= \'\\xFF\'" + PsErrSuffixAT + -> mkSimpleDecorated $ + text "The symbol '@' occurs as a suffix." $$ + text "For an as-pattern, there must not be any whitespace surrounding '@'." + PsErrPrecedenceOutOfRange i + -> mkSimpleDecorated $ text "Precedence out of range: " <> int i + PsErrSemiColonsInCondExpr c st t se e + -> mkSimpleDecorated $ + text "Unexpected semi-colons in conditional:" + $$ nest 4 expr + where + pprOptSemi True = semi + pprOptSemi False = empty + expr = text "if" <+> ppr c <> pprOptSemi st <+> + text "then" <+> ppr t <> pprOptSemi se <+> + text "else" <+> ppr e + PsErrSemiColonsInCondCmd c st t se e + -> mkSimpleDecorated $ + text "Unexpected semi-colons in conditional:" + $$ nest 4 expr + where + pprOptSemi True = semi + pprOptSemi False = empty + expr = text "if" <+> ppr c <> pprOptSemi st <+> + text "then" <+> ppr t <> pprOptSemi se <+> + text "else" <+> ppr e + PsErrAtInPatPos + -> mkSimpleDecorated $ + text "Found a binding for the" + <+> quotes (text "@") + <+> text "operator in a pattern position." + $$ perhapsAsPat + PsErrParseErrorOnInput occ + -> mkSimpleDecorated $ text "parse error on input" <+> ftext (occNameFS occ) + PsErrMalformedDecl what for + -> mkSimpleDecorated $ + text "Malformed" <+> what + <+> text "declaration for" <+> quotes (ppr for) + PsErrNotADataCon name + -> mkSimpleDecorated $ text "Not a data constructor:" <+> quotes (ppr name) + PsErrInferredTypeVarNotAllowed + -> mkSimpleDecorated $ text "Inferred type variables are not allowed here" + PsErrIllegalTraditionalRecordSyntax s + -> mkSimpleDecorated $ + text "Illegal record syntax:" <+> s + PsErrParseErrorInCmd s + -> mkSimpleDecorated $ hang (text "Parse error in command:") 2 s + PsErrInPat s details + -> let msg = parse_error_in_pat + body = case details of + PEIP_NegApp -> text "-" <> ppr s + PEIP_OtherPatDetails (ParseContext (Just fun) _) + -> ppr s <+> text "In a function binding for the" + <+> quotes (ppr fun) + <+> text "operator." + $$ if opIsAt fun + then perhapsAsPat + else empty + _ -> ppr s + in mkSimpleDecorated $ msg <+> body + PsErrParseRightOpSectionInPat infixOcc s + -> mkSimpleDecorated $ parse_error_in_pat <+> pprInfixOcc infixOcc <> ppr s + PsErrIllegalRoleName role _nearby + -> mkSimpleDecorated $ + text "Illegal role name" <+> quotes (ppr role) + PsErrInvalidTypeSignature reason lhs + -> mkSimpleDecorated $ case reason of + PsErrInvalidTypeSig_DataCon -> text "Invalid data constructor" <+> quotes (ppr lhs) <+> + text "in type signature" <> colon $$ + text "You can only define data constructors in data type declarations." + PsErrInvalidTypeSig_Qualified -> text "Invalid qualified name in type signature." + PsErrInvalidTypeSig_Other -> text "Invalid type signature" <> colon $$ + text "A type signature should be of form" <+> + placeHolder "variables" <+> dcolon <+> placeHolder "type" <> + dot + where placeHolder = angleBrackets . text + PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where + -> mkSimpleDecorated $ + vcat [ text "Unexpected type" <+> quotes (ppr t) + , text "In the" <+> what + <+> text "declaration for" <+> quotes (ppr tc) + , vcat[ (text "A" <+> what + <+> text "declaration should have form") + , nest 2 + (what + <+> ppr tc + <+> hsep (map text (takeList tparms allNameStringList)) + <+> equals_or_where) ] ] + PsErrInvalidPackageName pkg + -> mkSimpleDecorated $ vcat + [ text "Parse error" <> colon <+> quotes (ftext pkg) + , text "Version number or non-alphanumeric" <+> + text "character in package name" + ] + + PsErrIllegalGadtRecordMultiplicity arr + -> mkSimpleDecorated $ vcat + [ text "Parse error" <> colon <+> quotes (ppr arr) + , text "Record constructors in GADTs must use an ordinary, non-linear arrow." + ] + PsErrInvalidCApiImport {} -> mkSimpleDecorated $ vcat [ text "Wrapper stubs can't be used with CApiFFI."] + + PsErrMultipleConForNewtype tycon n -> mkSimpleDecorated $ vcat + [ sep + [ text "A newtype must have exactly one constructor," + , nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] + , text "In the newtype declaration for" <+> quotes (ppr tycon) ] + + PsErrUnicodeCharLooksLike bad_char looks_like_char looks_like_char_name + -> mkSimpleDecorated $ + hsep [ text "Unicode character" + -- purposefully not using `quotes (text [bad_char])`, because the quotes function adds smart quotes, + -- and smart quotes may be the topic of this error message + , text "'" <> text [bad_char] <> text "' (" <> text (show bad_char) <> text ")" + , text "looks like" + , text "'" <> text [looks_like_char] <> text "' (" <> text looks_like_char_name <> text ")" <> comma + , text "but it is not" ] + + PsErrInvalidPun PEP_QuoteDisambiguation + -> mkSimpleDecorated $ vcat + [ text "Disambiguating data constructors of tuples and lists is disabled." + , text "Remove the quote to use the data constructor." + ] + + PsErrInvalidPun PEP_TupleSyntaxType + -> mkSimpleDecorated $ vcat + [ text "Unboxed tuple data constructors are not supported in types." + , text "Use" <+> quotes (text "Tuple# a b c ...") <+> text "to refer to the type constructor." + ] + + PsErrInvalidPun PEP_SumSyntaxType + -> mkSimpleDecorated $ vcat + [ text "Unboxed sum data constructors are not supported in types." + , text "Use" <+> quotes (text "Sum# a b c ...") <+> text "to refer to the type constructor." + ] + PsErrTypeSyntaxInPat ctx + -> mkSimpleDecorated $ vcat + [ text "Illegal" <+> text what <+> "in pattern:" <+> quotes ctx' + , text "Type syntax in patterns isn't supported at the time"] + where + (what, ctx') = case ctx of + PETS_FunctionArrow arg arr res -> ("function arrow", ppr arg <+> pprHsArrow arr <+> ppr res) + PETS_Multiplicity tok p -> ("multiplicity annotation", ppr tok <> ppr p) + PETS_ForallTelescope tele body -> ("forall telescope", pprHsForAll tele Nothing <+> ppr body) + PETS_ConstraintContext ctx -> ("constraint context", ppr ctx) + + PsErrIllegalOrPat pat + -> mkSimpleDecorated $ vcat [text "Illegal or-pattern:" <+> ppr (unLoc pat)] + + PsErrSpecExprMultipleTypeAscription + -> mkSimpleDecorated $ + text "SPECIALISE expression doesn't support multiple type ascriptions" + + PsWarnSpecMultipleTypeAscription + -> mkSimpleDecorated $ + text "SPECIALISE pragmas with multiple type ascriptions are deprecated, and will be removed in GHC 9.18" + + PsWarnPatternNamespaceSpecifier _explicit_namespaces + -> mkSimpleDecorated $ + text "The" <+> quotes (text "pattern") <+> "namespace specifier is deprecated." + + diagnosticReason = \case + PsUnknownMessage m -> diagnosticReason m + PsHeaderMessage m -> psHeaderMessageReason m + PsWarnBidirectionalFormatChars{} -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters + PsWarnTab{} -> WarningWithFlag Opt_WarnTabs + PsWarnTransitionalLayout{} -> WarningWithFlag Opt_WarnAlternativeLayoutRuleTransitional + PsWarnOperatorWhitespaceExtConflict{} -> WarningWithFlag Opt_WarnOperatorWhitespaceExtConflict + PsWarnOperatorWhitespace{} -> WarningWithFlag Opt_WarnOperatorWhitespace + PsWarnHaddockInvalidPos -> WarningWithFlag Opt_WarnInvalidHaddock + PsWarnHaddockIgnoreMulti -> WarningWithFlag Opt_WarnInvalidHaddock + PsWarnStarBinder -> WarningWithFlag Opt_WarnStarBinder + PsWarnStarIsType -> WarningWithFlag Opt_WarnStarIsType + PsWarnUnrecognisedPragma{} -> WarningWithFlag Opt_WarnUnrecognisedPragmas + PsWarnMisplacedPragma{} -> WarningWithFlag Opt_WarnMisplacedPragmas + PsWarnImportPreQualified -> WarningWithFlag Opt_WarnPrepositiveQualifiedModule + PsWarnViewPatternSignatures{} -> WarningWithFlag Opt_WarnViewPatternSignatures + PsErrLexer{} -> ErrorWithoutFlag + PsErrCmmLexer -> ErrorWithoutFlag + PsErrCmmParser{} -> ErrorWithoutFlag + PsErrParse{} -> ErrorWithoutFlag + PsErrTypeAppWithoutSpace{} -> ErrorWithoutFlag + PsErrLazyPatWithoutSpace{} -> ErrorWithoutFlag + PsErrBangPatWithoutSpace{} -> ErrorWithoutFlag + PsErrInvalidInfixHole -> ErrorWithoutFlag + PsErrExpectedHyphen -> ErrorWithoutFlag + PsErrSpaceInSCC -> ErrorWithoutFlag + PsErrEmptyDoubleQuotes{} -> ErrorWithoutFlag + PsErrLambdaCase{} -> ErrorWithoutFlag + PsErrEmptyLambda{} -> ErrorWithoutFlag + PsErrLinearFunction{} -> ErrorWithoutFlag + PsErrMultiWayIf{} -> ErrorWithoutFlag + PsErrOverloadedRecordUpdateNotEnabled{} -> ErrorWithoutFlag + PsErrNumUnderscores{} -> ErrorWithoutFlag + PsErrIllegalBangPattern{} -> ErrorWithoutFlag + PsErrOverloadedRecordDotInvalid{} -> ErrorWithoutFlag + PsErrIllegalPatSynExport -> ErrorWithoutFlag + PsErrOverloadedRecordUpdateNoQualifiedFields -> ErrorWithoutFlag + PsErrExplicitForall{} -> ErrorWithoutFlag + PsErrIllegalQualifiedDo{} -> ErrorWithoutFlag + PsErrQualifiedDoInCmd{} -> ErrorWithoutFlag + PsErrRecordSyntaxInPatSynDecl{} -> ErrorWithoutFlag + PsErrEmptyWhereInPatSynDecl{} -> ErrorWithoutFlag + PsErrInvalidWhereBindInPatSynDecl{} -> ErrorWithoutFlag + PsErrNoSingleWhereBindInPatSynDecl{} -> ErrorWithoutFlag + PsErrDeclSpliceNotAtTopLevel{} -> ErrorWithoutFlag + PsErrMultipleNamesInStandaloneKindSignature{} -> ErrorWithoutFlag + PsErrIllegalExplicitNamespace{} -> ErrorWithoutFlag + PsErrUnallowedPragma{} -> ErrorWithoutFlag + PsErrImportPostQualified -> ErrorWithoutFlag + PsErrImportQualifiedTwice -> ErrorWithoutFlag + PsErrSpliceOrQuoteTwice -> ErrorWithoutFlag + PsErrIllegalImportBundleForm -> ErrorWithoutFlag + PsErrInvalidRuleActivationMarker -> ErrorWithoutFlag + PsErrMissingBlock -> ErrorWithoutFlag + PsErrUnsupportedBoxedSumExpr{} -> ErrorWithoutFlag + PsErrUnsupportedBoxedSumPat{} -> ErrorWithoutFlag + PsErrUnexpectedQualifiedConstructor{} -> ErrorWithoutFlag + PsErrTupleSectionInPat{} -> ErrorWithoutFlag + PsErrOpFewArgs{} -> ErrorWithoutFlag + PsErrVarForTyCon{} -> ErrorWithoutFlag + PsErrMalformedEntityString -> ErrorWithoutFlag + PsErrDotsInRecordUpdate -> ErrorWithoutFlag + PsErrInvalidDataCon{} -> ErrorWithoutFlag + PsErrInvalidInfixDataCon{} -> ErrorWithoutFlag + PsErrIllegalPromotionQuoteDataCon{} -> ErrorWithoutFlag + PsErrUnpackDataCon -> ErrorWithoutFlag + PsErrUnexpectedKindAppInDataCon{} -> ErrorWithoutFlag + PsErrInvalidRecordCon{} -> ErrorWithoutFlag + PsErrIllegalUnboxedStringInPat{} -> ErrorWithoutFlag + PsErrIllegalUnboxedFloatingLitInPat{} -> ErrorWithoutFlag + PsErrDoNotationInPat{} -> ErrorWithoutFlag + PsErrIfThenElseInPat -> ErrorWithoutFlag + PsErrCaseInPat -> ErrorWithoutFlag + PsErrLetInPat -> ErrorWithoutFlag + PsErrLambdaInPat{} -> ErrorWithoutFlag + PsErrArrowExprInPat{} -> ErrorWithoutFlag + PsErrArrowCmdInPat{} -> ErrorWithoutFlag + PsErrArrowCmdInExpr{} -> ErrorWithoutFlag + PsErrOrPatInExpr{} -> ErrorWithoutFlag + PsErrCaseCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrLambdaCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrIfCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrLetCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrDoCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrDoInFunAppExpr{} -> ErrorWithoutFlag + PsErrMDoInFunAppExpr{} -> ErrorWithoutFlag + PsErrLambdaInFunAppExpr{} -> ErrorWithoutFlag + PsErrCaseInFunAppExpr{} -> ErrorWithoutFlag + PsErrLetInFunAppExpr{} -> ErrorWithoutFlag + PsErrIfInFunAppExpr{} -> ErrorWithoutFlag + PsErrProcInFunAppExpr{} -> ErrorWithoutFlag + PsErrMalformedTyOrClDecl{} -> ErrorWithoutFlag + PsErrIllegalWhereInDataDecl -> ErrorWithoutFlag + PsErrIllegalDataTypeContext{} -> ErrorWithoutFlag + PsErrPrimStringInvalidChar -> ErrorWithoutFlag + PsErrSuffixAT -> ErrorWithoutFlag + PsErrPrecedenceOutOfRange{} -> ErrorWithoutFlag + PsErrSemiColonsInCondExpr{} -> ErrorWithoutFlag + PsErrSemiColonsInCondCmd{} -> ErrorWithoutFlag + PsErrAtInPatPos -> ErrorWithoutFlag + PsErrParseErrorOnInput{} -> ErrorWithoutFlag + PsErrMalformedDecl{} -> ErrorWithoutFlag + PsErrNotADataCon{} -> ErrorWithoutFlag + PsErrInferredTypeVarNotAllowed -> ErrorWithoutFlag + PsErrIllegalTraditionalRecordSyntax{} -> ErrorWithoutFlag + PsErrParseErrorInCmd{} -> ErrorWithoutFlag + PsErrInPat{} -> ErrorWithoutFlag + PsErrIllegalRoleName{} -> ErrorWithoutFlag + PsErrInvalidTypeSignature{} -> ErrorWithoutFlag + PsErrUnexpectedTypeInDecl{} -> ErrorWithoutFlag + PsErrInvalidPackageName{} -> ErrorWithoutFlag + PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag + PsErrIllegalGadtRecordMultiplicity{} -> ErrorWithoutFlag + PsErrInvalidCApiImport {} -> ErrorWithoutFlag + PsErrMultipleConForNewtype {} -> ErrorWithoutFlag + PsErrUnicodeCharLooksLike{} -> ErrorWithoutFlag + PsErrInvalidPun {} -> ErrorWithoutFlag + PsErrIllegalOrPat{} -> ErrorWithoutFlag + PsErrTypeSyntaxInPat{} -> ErrorWithoutFlag + PsErrSpecExprMultipleTypeAscription{} -> ErrorWithoutFlag + PsWarnSpecMultipleTypeAscription{} -> WarningWithFlag Opt_WarnDeprecatedPragmas + PsWarnPatternNamespaceSpecifier{} -> WarningWithFlag Opt_WarnPatternNamespaceSpecifier + + diagnosticHints = \case + PsUnknownMessage m -> diagnosticHints m + PsHeaderMessage m -> psHeaderMessageHints m + PsWarnBidirectionalFormatChars{} -> noHints + PsWarnTab{} -> [SuggestUseSpaces] + PsWarnTransitionalLayout{} -> noHints + PsWarnOperatorWhitespaceExtConflict sym -> [SuggestUseWhitespaceAfter sym] + PsWarnOperatorWhitespace sym occ -> [SuggestUseWhitespaceAround (unpackFS sym) occ] + PsWarnHaddockInvalidPos -> noHints + PsWarnHaddockIgnoreMulti -> noHints + PsWarnStarBinder -> [SuggestQualifyStarOperator] + PsWarnStarIsType -> [SuggestUseTypeFromDataKind Nothing] + PsWarnUnrecognisedPragma "" _ -> noHints + PsWarnUnrecognisedPragma p avail -> + let suggestions = fuzzyMatch p avail + in if null suggestions + then noHints + else [SuggestCorrectPragmaName suggestions] + PsWarnMisplacedPragma{} -> [SuggestPlacePragmaInHeader] + PsWarnImportPreQualified -> [ SuggestQualifiedAfterModuleName + , suggestExtension LangExt.ImportQualifiedPost] + PsWarnViewPatternSignatures{} -> [SuggestParenthesizePatternRHS] + PsErrLexer{} -> noHints + PsErrCmmLexer -> noHints + PsErrCmmParser{} -> noHints + PsErrParse token PsErrParseDetails{..} -> case token of + "" -> [] + "$" | not ped_th_enabled -> [suggestExtension LangExt.TemplateHaskell] -- #7396 + "$$" | not ped_th_enabled -> [suggestExtension LangExt.TemplateHaskell] -- #20157 + "<-" | ped_mdo_in_last_100 -> [suggestExtension LangExt.RecursiveDo] + | otherwise -> [SuggestMissingDo] + "=" | ped_do_in_last_100 -> [SuggestLetInDo] -- #15849 + _ | not ped_pat_syn_enabled + , ped_pattern_parsed -> [suggestExtension LangExt.PatternSynonyms] -- #12429 + | otherwise -> [] + PsErrTypeAppWithoutSpace{} -> noHints + PsErrLazyPatWithoutSpace{} -> noHints + PsErrBangPatWithoutSpace{} -> noHints + PsErrInvalidInfixHole -> noHints + PsErrExpectedHyphen -> noHints + PsErrSpaceInSCC -> noHints + PsErrEmptyDoubleQuotes th_on | th_on -> [SuggestThQuotationSyntax] + | otherwise -> noHints + PsErrLambdaCase{} -> [suggestExtension LangExt.LambdaCase] + PsErrEmptyLambda{} -> noHints + PsErrLinearFunction{} -> [suggestExtension LangExt.LinearTypes] + PsErrMultiWayIf{} -> [suggestExtension LangExt.MultiWayIf] + PsErrOverloadedRecordUpdateNotEnabled{} -> [suggestExtension LangExt.OverloadedRecordUpdate] + PsErrNumUnderscores{} -> [suggestExtension LangExt.NumericUnderscores] + PsErrIllegalBangPattern{} -> [suggestExtension LangExt.BangPatterns] + PsErrOverloadedRecordDotInvalid{} -> noHints + PsErrIllegalPatSynExport -> [suggestExtension LangExt.PatternSynonyms] + PsErrOverloadedRecordUpdateNoQualifiedFields -> noHints + PsErrExplicitForall is_unicode -> [useExtensionInOrderTo info LangExt.ExplicitForAll] + where info = "to enable syntax:" <+> forallSym is_unicode <+> angleBrackets "tvs" <> dot <+> angleBrackets "type" + PsErrIllegalQualifiedDo{} -> [suggestExtension LangExt.QualifiedDo] + PsErrQualifiedDoInCmd{} -> noHints + PsErrRecordSyntaxInPatSynDecl{} -> noHints + PsErrEmptyWhereInPatSynDecl{} -> noHints + PsErrInvalidWhereBindInPatSynDecl{} -> noHints + PsErrNoSingleWhereBindInPatSynDecl{} -> noHints + PsErrDeclSpliceNotAtTopLevel{} -> noHints + PsErrMultipleNamesInStandaloneKindSignature{} -> noHints + PsErrIllegalExplicitNamespace{} -> [suggestExtension LangExt.ExplicitNamespaces] + PsErrUnallowedPragma{} -> noHints + PsErrImportPostQualified -> [suggestExtension LangExt.ImportQualifiedPost] + PsErrImportQualifiedTwice -> noHints + PsErrSpliceOrQuoteTwice -> noHints + PsErrIllegalImportBundleForm -> noHints + PsErrInvalidRuleActivationMarker -> noHints + PsErrMissingBlock -> noHints + PsErrUnsupportedBoxedSumExpr{} -> noHints + PsErrUnsupportedBoxedSumPat{} -> noHints + PsErrUnexpectedQualifiedConstructor{} -> noHints + PsErrTupleSectionInPat{} -> noHints + PsErrOpFewArgs star_is_type op + -> noStarIsTypeHints star_is_type op + PsErrVarForTyCon{} -> noHints + PsErrMalformedEntityString -> noHints + PsErrDotsInRecordUpdate -> noHints + PsErrInvalidDataCon{} -> noHints + PsErrInvalidInfixDataCon{} -> noHints + PsErrIllegalPromotionQuoteDataCon{} -> noHints + PsErrUnpackDataCon -> noHints + PsErrUnexpectedKindAppInDataCon{} -> noHints + PsErrInvalidRecordCon{} -> noHints + PsErrIllegalUnboxedStringInPat{} -> noHints + PsErrIllegalUnboxedFloatingLitInPat{} -> noHints + PsErrDoNotationInPat{} -> noHints + PsErrIfThenElseInPat -> noHints + PsErrCaseInPat -> noHints + PsErrLetInPat -> noHints + PsErrLambdaInPat{} -> noHints + PsErrArrowExprInPat{} -> noHints + PsErrArrowCmdInPat{} -> noHints + PsErrArrowCmdInExpr{} -> noHints + PsErrOrPatInExpr{} -> noHints + PsErrLambdaCmdInFunAppCmd{} -> suggestParensAndBlockArgs + PsErrCaseCmdInFunAppCmd{} -> suggestParensAndBlockArgs + PsErrIfCmdInFunAppCmd{} -> suggestParensAndBlockArgs + PsErrLetCmdInFunAppCmd{} -> suggestParensAndBlockArgs + PsErrDoCmdInFunAppCmd{} -> suggestParensAndBlockArgs + PsErrDoInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrMDoInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrLambdaInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrCaseInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrLetInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrIfInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrProcInFunAppExpr{} -> suggestParensAndBlockArgs + PsErrMalformedTyOrClDecl{} -> noHints + PsErrIllegalWhereInDataDecl -> [useExtensionInOrderTo "to enable syntax: data T where" LangExt.GADTSyntax] + PsErrIllegalDataTypeContext{} -> [suggestExtension LangExt.DatatypeContexts] + PsErrPrimStringInvalidChar -> noHints + PsErrSuffixAT -> noHints + PsErrPrecedenceOutOfRange{} -> noHints + PsErrSemiColonsInCondExpr{} -> [suggestExtension LangExt.DoAndIfThenElse] + PsErrSemiColonsInCondCmd{} -> [suggestExtension LangExt.DoAndIfThenElse] + PsErrAtInPatPos -> noHints + PsErrParseErrorOnInput{} -> noHints + PsErrMalformedDecl{} -> noHints + PsErrNotADataCon{} -> noHints + PsErrInferredTypeVarNotAllowed -> noHints + PsErrIllegalTraditionalRecordSyntax{} -> [suggestExtension LangExt.TraditionalRecordSyntax] + PsErrParseErrorInCmd{} -> noHints + PsErrInPat _ details -> case details of + PEIP_RecPattern args YesPatIsRecursive ctx + | length args /= 0 -> catMaybes [sug_recdo, sug_missingdo ctx] + | otherwise -> catMaybes [sug_missingdo ctx] + PEIP_OtherPatDetails ctx -> catMaybes [sug_missingdo ctx] + _ -> [] + where + sug_recdo = Just (suggestExtension LangExt.RecursiveDo) + sug_missingdo (ParseContext _ YesIncompleteDoBlock) = Just SuggestMissingDo + sug_missingdo _ = Nothing + PsErrParseRightOpSectionInPat{} -> noHints + PsErrIllegalRoleName _ nearby -> [SuggestRoles nearby] + PsErrInvalidTypeSignature reason lhs -> + if | foreign_RDR `looks_like` lhs + -> [suggestExtension LangExt.ForeignFunctionInterface] + | default_RDR `looks_like` lhs + -> [suggestExtension LangExt.DefaultSignatures] + | pattern_RDR `looks_like` lhs + -> [suggestExtension LangExt.PatternSynonyms] + | PsErrInvalidTypeSig_Qualified <- reason + -> [SuggestTypeSignatureRemoveQualifier] + | otherwise + -> [] + where + -- A common error is to forget the ForeignFunctionInterface flag + -- so check for that, and suggest. cf #3805 + -- Sadly 'foreign import' still barfs 'parse error' because + -- 'import' is a keyword + -- looks_like :: RdrName -> LHsExpr GhcPsErr -> Bool -- AZ + looks_like s (L _ (HsVar _ (L _ v))) = v == s + looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs + looks_like _ _ = False + + foreign_RDR = mkUnqual varName (fsLit "foreign") + default_RDR = mkUnqual varName (fsLit "default") + pattern_RDR = mkUnqual varName (fsLit "pattern") + PsErrUnexpectedTypeInDecl{} -> noHints + PsErrInvalidPackageName{} -> noHints + PsErrIllegalGadtRecordMultiplicity{} -> noHints + PsErrInvalidCApiImport {} -> noHints + PsErrMultipleConForNewtype {} -> noHints + PsErrUnicodeCharLooksLike{} -> noHints + PsErrInvalidPun {} -> [suggestExtension LangExt.ListTuplePuns] + PsErrIllegalOrPat{} -> [suggestExtension LangExt.OrPatterns] + PsErrTypeSyntaxInPat{} -> noHints + PsErrSpecExprMultipleTypeAscription {} -> [SuggestSplittingIntoSeveralSpecialisePragmas] + PsWarnSpecMultipleTypeAscription{} -> [SuggestSplittingIntoSeveralSpecialisePragmas] + PsWarnPatternNamespaceSpecifier explicit_namespaces + | explicit_namespaces -> [SuggestDataKeyword] + | otherwise -> + let info = text "and replace" <+> quotes (text "pattern") + <+> text "with" <+> quotes (text "data") <> "." + in [useExtensionInOrderTo info LangExt.ExplicitNamespaces] + + diagnosticCode = constructorCode @GHC + +psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc +psHeaderMessageDiagnostic = \case + PsErrParseLanguagePragma + -> mkSimpleDecorated $ + vcat [ text "Cannot parse LANGUAGE pragma" + , text "Expecting comma-separated list of language options," + , text "each starting with a capital letter" + , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ] + PsErrUnsupportedExt unsup _ + -> mkSimpleDecorated $ text "Unsupported extension: " <> text unsup + PsErrParseOptionsPragma str + -> mkSimpleDecorated $ + vcat [ text "Error while parsing OPTIONS_GHC pragma." + , text "Expecting whitespace-separated list of GHC options." + , text " E.g. {-# OPTIONS_GHC -Wall -O2 #-}" + , text ("Input was: " ++ show str) ] + PsErrUnknownOptionsPragma flag + -> mkSimpleDecorated $ text "Unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag + +psHeaderMessageReason :: PsHeaderMessage -> DiagnosticReason +psHeaderMessageReason = \case + PsErrParseLanguagePragma + -> ErrorWithoutFlag + PsErrUnsupportedExt{} + -> ErrorWithoutFlag + PsErrParseOptionsPragma{} + -> ErrorWithoutFlag + PsErrUnknownOptionsPragma{} + -> ErrorWithoutFlag + +psHeaderMessageHints :: PsHeaderMessage -> [GhcHint] +psHeaderMessageHints = \case + PsErrParseLanguagePragma + -> noHints + PsErrUnsupportedExt unsup supported + -> if null suggestions + then noHints + -- FIXME(adn) To fix the compiler crash in #19923 we just rewrap this into an + -- UnknownHint, but we should have here a proper hint, but that would require + -- changing 'supportedExtensions' to emit a list of 'Extension'. + else [UnknownHint $ text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)] + where + suggestions :: [String] + suggestions = fuzzyMatch unsup supported + PsErrParseOptionsPragma{} + -> noHints + PsErrUnknownOptionsPragma{} + -> noHints + + +suggestParensAndBlockArgs :: [GhcHint] +suggestParensAndBlockArgs = + [SuggestParentheses, suggestExtension LangExt.BlockArguments] + +pp_unexpected_fun_app :: Outputable a => SDoc -> a -> SDoc +pp_unexpected_fun_app e a = + text "Unexpected " <> e <> text " in function application:" + $$ nest 4 (ppr a) + +parse_error_in_pat :: SDoc +parse_error_in_pat = text "Parse error in pattern:" + +forallSym :: Bool -> SDoc +forallSym True = text "∀" +forallSym False = text "forall" + +pprFileHeaderPragmaType :: FileHeaderPragmaType -> SDoc +pprFileHeaderPragmaType OptionsPrag = text "OPTIONS" +pprFileHeaderPragmaType IncludePrag = text "INCLUDE" +pprFileHeaderPragmaType LanguagePrag = text "LANGUAGE" +pprFileHeaderPragmaType DocOptionsPrag = text "OPTIONS_HADDOCK" diff --git a/GHC/Parser/Errors/Types.hs b/GHC/Parser/Errors/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Errors/Types.hs @@ -0,0 +1,638 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +module GHC.Parser.Errors.Types where + +import GHC.Prelude + +import GHC.Core.TyCon (Role) +import GHC.Data.FastString +import GHC.Hs +import GHC.Parser.Types +import GHC.Parser.Errors.Basic +import GHC.Types.Error +import GHC.Types.Hint +import GHC.Types.Name.Occurrence (OccName) +import GHC.Types.Name.Reader +import Data.List.NonEmpty (NonEmpty) +import GHC.Types.SrcLoc (PsLoc) + +import GHC.Generics ( Generic ) + +-- The type aliases below are useful to make some type signatures a bit more +-- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'. + +type PsWarning = PsMessage -- /INVARIANT/: The diagnosticReason is a Warning reason +type PsError = PsMessage -- /INVARIANT/: The diagnosticReason is ErrorWithoutFlag + +{- +Note [Messages from GHC.Parser.Header +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We group the messages from 'GHC.Parser.Header' because we need to +be able to pattern match on them in the driver code. This is because +in functions like 'GHC.Driver.Pipeline.preprocess' we want to handle +only a specific subset of parser messages, during dependency analysis, +and having a single constructor to handle them all is handy. + +-} + +data PsHeaderMessage + = PsErrParseLanguagePragma + | PsErrUnsupportedExt !String ![String] + | PsErrParseOptionsPragma !String + + {-| PsErrUnsupportedOptionsPragma is an error that occurs when an unknown + OPTIONS_GHC pragma is supplied is found. + + Example(s): + {-# OPTIONS_GHC foo #-} + + Test case(s): + + tests/safeHaskell/flags/SafeFlags28 + tests/safeHaskell/flags/SafeFlags19 + tests/safeHaskell/flags/SafeFlags29 + tests/parser/should_fail/T19923c + tests/parser/should_fail/T19923b + tests/parser/should_fail/readFail044 + tests/driver/T2499 + -} + | PsErrUnknownOptionsPragma !String + deriving Generic + + +data PsMessage + = + {-| An \"unknown\" message from the parser. This type constructor allows + arbitrary messages to be embedded. The typical use case would be GHC plugins + willing to emit custom diagnostics. + -} + PsUnknownMessage (UnknownDiagnosticFor PsMessage) + + {-| A group of parser messages emitted in 'GHC.Parser.Header'. + See Note [Messages from GHC.Parser.Header]. + -} + | PsHeaderMessage !PsHeaderMessage + + {-| PsWarnBidirectionalFormatChars is a warning (controlled by the -Wwarn-bidirectional-format-characters flag) + that occurs when unicode bi-directional format characters are found within in a file + + The 'PsLoc' contains the exact position in the buffer the character occurred, and the + string contains a description of the character. + -} + | PsWarnBidirectionalFormatChars (NonEmpty (PsLoc, Char, String)) + + {-| PsWarnTab is a warning (controlled by the -Wwarn-tabs flag) that occurs + when tabulations (tabs) are found within a file. + + Test case(s): parser/should_fail/T12610 + parser/should_compile/T9723b + parser/should_compile/T9723a + parser/should_compile/read043 + parser/should_fail/T16270 + warnings/should_compile/T9230 + + -} + | PsWarnTab !Word -- ^ Number of other occurrences other than the first one + + {-| PsWarnTransitionalLayout is a warning (controlled by the + -Walternative-layout-rule-transitional flag) that occurs when pipes ('|') + or 'where' are at the same depth of an implicit layout block. + + Example(s): + + f :: IO () + f + | True = do + let x = () + y = () + return () + | True = return () + + Test case(s): layout/layout006 + layout/layout003 + layout/layout001 + + -} + | PsWarnTransitionalLayout !TransLayoutReason + + -- | Unrecognised pragma. First field is the actual pragma name which + -- might be empty. Second field is the set of valid candidate pragmas. + | PsWarnUnrecognisedPragma !String ![String] + | PsWarnMisplacedPragma !FileHeaderPragmaType + + -- | Invalid Haddock comment position + | PsWarnHaddockInvalidPos + + -- | Multiple Haddock comment for the same entity + | PsWarnHaddockIgnoreMulti + + -- | Found binding occurrence of "*" while StarIsType is enabled + | PsWarnStarBinder + + -- | Using "*" for "Type" without StarIsType enabled + | PsWarnStarIsType + + -- | Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled + | PsWarnImportPreQualified + + | PsWarnOperatorWhitespaceExtConflict !OperatorWhitespaceSymbol + + | PsWarnOperatorWhitespace !FastString !OperatorWhitespaceOccurrence + + {- | PsWarnViewPatternSignatures is a warning triggered by view patterns whose + RHS is an unparenthesised pattern signature. It warns on code that is + highly likely to break when the precedence of view patterns relative to + pattern signatures is changed per GHC Proposal #281. The suggested fix + is to add parentheses. + + Example: + f1 (isJust -> True :: Bool) = () + + Suggested fix: + f1 (isJust -> (True :: Bool)) = () + + Test cases: + T24159_viewpat + -} + | PsWarnViewPatternSignatures !(LPat GhcPs) !(LPat GhcPs) + + -- | LambdaCase syntax used without the extension enabled + | PsErrLambdaCase + + -- | A lambda requires at least one parameter + | PsErrEmptyLambda + + -- | Underscores in literals without the extension enabled + | PsErrNumUnderscores !NumUnderscoreReason + + -- | Invalid character in primitive string + | PsErrPrimStringInvalidChar + + -- | Missing block + | PsErrMissingBlock + + -- | Lexer error + | PsErrLexer !LexErr !LexErrKind + + -- | Suffix occurrence of `@` + | PsErrSuffixAT + + -- | Parse errors + | PsErrParse !String !PsErrParseDetails + + -- | Cmm lexer error + | PsErrCmmLexer + + -- | Unsupported boxed sum in expression + | PsErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs)) + + -- | Unsupported boxed sum in pattern + | PsErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs)) + + -- | Unexpected qualified constructor + | PsErrUnexpectedQualifiedConstructor !RdrName + + -- | Tuple section in pattern context + | PsErrTupleSectionInPat + + -- | Bang-pattern without BangPattterns enabled + | PsErrIllegalBangPattern !(Pat GhcPs) + + -- | Operator applied to too few arguments + | PsErrOpFewArgs !StarIsType !RdrName + + -- | Import: multiple occurrences of 'qualified' + | PsErrImportQualifiedTwice + + -- | Multiple occurrences of a splice or quote keyword + | PsErrSpliceOrQuoteTwice + + -- | Post qualified import without 'ImportQualifiedPost' + | PsErrImportPostQualified + + -- | Explicit namespace keyword without 'ExplicitNamespaces' + | PsErrIllegalExplicitNamespace !ExplicitNamespaceKeyword + + -- | Expecting a type constructor but found a variable + | PsErrVarForTyCon !RdrName + + -- | Illegal export form allowed by PatternSynonyms + | PsErrIllegalPatSynExport + + -- | Malformed entity string + | PsErrMalformedEntityString + + -- | Dots used in record update + | PsErrDotsInRecordUpdate + + -- | Precedence out of range + | PsErrPrecedenceOutOfRange !Int + + -- | Invalid use of record dot syntax `.' + | PsErrOverloadedRecordDotInvalid + + -- | `OverloadedRecordUpdate` is not enabled. + | PsErrOverloadedRecordUpdateNotEnabled + + -- | Can't use qualified fields when OverloadedRecordUpdate is enabled. + | PsErrOverloadedRecordUpdateNoQualifiedFields + + -- | Cannot parse data constructor in a data/newtype declaration + | PsErrInvalidDataCon !(HsType GhcPs) + + -- | Cannot parse data constructor in a data/newtype declaration + | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs) + + -- | Illegal DataKinds quote mark in data/newtype constructor declaration + | PsErrIllegalPromotionQuoteDataCon !RdrName + + -- | UNPACK applied to a data constructor + | PsErrUnpackDataCon + + -- | Unexpected kind application in data/newtype declaration + | PsErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs) + + -- | Not a record constructor + | PsErrInvalidRecordCon !(PatBuilder GhcPs) + + -- | Illegal unboxed string literal in pattern + | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs) + + -- | Illegal primitive floating point literal in pattern + | PsErrIllegalUnboxedFloatingLitInPat !(HsLit GhcPs) + + -- | Do-notation in pattern + | PsErrDoNotationInPat + + -- | If-then-else syntax in pattern + | PsErrIfThenElseInPat + + -- | Lambda or Lambda-case in pattern + | PsErrLambdaInPat HsLamVariant + + -- | case..of in pattern + | PsErrCaseInPat + + -- | let-syntax in pattern + | PsErrLetInPat + + -- | Arrow expression-syntax in pattern + | PsErrArrowExprInPat !(HsExpr GhcPs) + + -- | Arrow command-syntax in pattern + | PsErrArrowCmdInPat !(HsCmd GhcPs) + + -- | Arrow command-syntax in expression + | PsErrArrowCmdInExpr !(HsCmd GhcPs) + + -- | Or-pattern in expression + | PsErrOrPatInExpr !(LPat GhcPs) + + -- | Type-application without space before '@' + | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs) + + -- | Lazy-pattern ('~') without space after it + | PsErrLazyPatWithoutSpace !(LHsExpr GhcPs) + + -- | Bang-pattern ('!') without space after it + | PsErrBangPatWithoutSpace !(LHsExpr GhcPs) + + -- | Pragma not allowed in this position + | PsErrUnallowedPragma !(HsPragE GhcPs) + + -- | Qualified do block in command + | PsErrQualifiedDoInCmd !ModuleName + + -- | Invalid infix hole, expected an infix operator + | PsErrInvalidInfixHole + + -- | Unexpected semi-colons in conditional expression + | PsErrSemiColonsInCondExpr + !(HsExpr GhcPs) -- ^ conditional expr + !Bool -- ^ "then" semi-colon? + !(HsExpr GhcPs) -- ^ "then" expr + !Bool -- ^ "else" semi-colon? + !(HsExpr GhcPs) -- ^ "else" expr + + -- | Unexpected semi-colons in conditional command + | PsErrSemiColonsInCondCmd + !(HsExpr GhcPs) -- ^ conditional expr + !Bool -- ^ "then" semi-colon? + !(HsCmd GhcPs) -- ^ "then" expr + !Bool -- ^ "else" semi-colon? + !(HsCmd GhcPs) -- ^ "else" expr + + -- | @-operator in a pattern position + | PsErrAtInPatPos + + -- | Unexpected case command in function application + | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs) + + -- | Unexpected lambda or \case(s) command in function application + | PsErrLambdaCmdInFunAppCmd !HsLamVariant !(LHsCmd GhcPs) + + -- | Unexpected if command in function application + | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs) + + -- | Unexpected let command in function application + | PsErrLetCmdInFunAppCmd !(LHsCmd GhcPs) + + -- | Unexpected do command in function application + | PsErrDoCmdInFunAppCmd !(LHsCmd GhcPs) + + -- | Unexpected do block in function application + | PsErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) + + -- | Unexpected mdo block in function application + | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) + + -- | Unexpected case expression in function application + | PsErrCaseInFunAppExpr !(LHsExpr GhcPs) + + -- | Unexpected lambda or \case(s) expression in function application + | PsErrLambdaInFunAppExpr !HsLamVariant !(LHsExpr GhcPs) + + -- | Unexpected let expression in function application + | PsErrLetInFunAppExpr !(LHsExpr GhcPs) + + -- | Unexpected if expression in function application + | PsErrIfInFunAppExpr !(LHsExpr GhcPs) + + -- | Unexpected proc expression in function application + | PsErrProcInFunAppExpr !(LHsExpr GhcPs) + + -- | Malformed head of type or class declaration + | PsErrMalformedTyOrClDecl !(LHsType GhcPs) + + -- | Illegal 'where' keyword in data declaration + | PsErrIllegalWhereInDataDecl + + -- | Illegal datatype context + | PsErrIllegalDataTypeContext !(LHsContext GhcPs) + + -- | Parse error on input + | PsErrParseErrorOnInput !OccName + + -- | Malformed ... declaration for ... + | PsErrMalformedDecl !SDoc !RdrName + + -- | Not a data constructor + | PsErrNotADataCon !RdrName + + -- | Record syntax used in pattern synonym declaration + | PsErrRecordSyntaxInPatSynDecl !(LPat GhcPs) + + -- | Empty 'where' clause in pattern-synonym declaration + | PsErrEmptyWhereInPatSynDecl !RdrName + + -- | Invalid binding name in 'where' clause of pattern-synonym declaration + | PsErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs) + + -- | Multiple bindings in 'where' clause of pattern-synonym declaration + | PsErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs) + + -- | Declaration splice not a top-level + | PsErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs) + + -- | Inferred type variables not allowed here + | PsErrInferredTypeVarNotAllowed + + -- | Multiple names in standalone kind signatures + | PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs] + + -- | Illegal import bundle form + | PsErrIllegalImportBundleForm + + -- | Illegal role name + | PsErrIllegalRoleName !FastString [Role] + + -- | Invalid type signature + | PsErrInvalidTypeSignature !PsInvalidTypeSignature !(LHsExpr GhcPs) + + -- | Unexpected type in declaration + | PsErrUnexpectedTypeInDecl !(LHsType GhcPs) + !SDoc + !RdrName + [LHsTypeArg GhcPs] + !SDoc + + -- | Expected a hyphen + | PsErrExpectedHyphen + + -- | Found a space in a SCC + | PsErrSpaceInSCC + + -- | Found two single quotes + | PsErrEmptyDoubleQuotes !Bool + -- ^ Is TH on? + + -- | Invalid package name + | PsErrInvalidPackageName !FastString + + -- | Invalid rule activation marker + | PsErrInvalidRuleActivationMarker + + -- | Linear function found but LinearTypes not enabled + | PsErrLinearFunction + + -- | Multi-way if-expression found but MultiWayIf not enabled + | PsErrMultiWayIf + + -- | Explicit forall found but no extension allowing it is enabled + | PsErrExplicitForall !Bool + -- ^ is Unicode forall? + + -- | Found qualified-do without QualifiedDo enabled + | PsErrIllegalQualifiedDo !SDoc + + -- | Cmm parser error + | PsErrCmmParser !CmmParserError + + -- | Illegal traditional record syntax + -- + -- TODO: distinguish errors without using SDoc + | PsErrIllegalTraditionalRecordSyntax !SDoc + + -- | Parse error in command + -- + -- TODO: distinguish errors without using SDoc + | PsErrParseErrorInCmd !SDoc + + -- | Parse error in pattern + | PsErrInPat !(PatBuilder GhcPs) !PsErrInPatDetails + + -- | Parse error in right operator section pattern + -- TODO: embed the proper operator, if possible + | PsErrParseRightOpSectionInPat !RdrName !(PatBuilder GhcPs) + + -- | Illegal linear arrow or multiplicity annotation in GADT record syntax + | PsErrIllegalGadtRecordMultiplicity !(HsMultAnn GhcPs) + + | PsErrInvalidCApiImport + + | PsErrMultipleConForNewtype !RdrName !Int + + | PsErrUnicodeCharLooksLike + Char -- ^ the problematic character + Char -- ^ the character it looks like + String -- ^ the name of the character that it looks like + + | PsErrInvalidPun !PsErrPunDetails + + -- | Or pattern used without -XOrPatterns + | PsErrIllegalOrPat (LPat GhcPs) + + -- | Temporary error until GHC gains support for type syntax in patterns. + -- Test cases: T24159_pat_parse_error_1 + -- T24159_pat_parse_error_2 + -- T24159_pat_parse_error_3 + -- T24159_pat_parse_error_4 + -- T24159_pat_parse_error_5 + -- T24159_pat_parse_error_6 + | PsErrTypeSyntaxInPat !PsErrTypeSyntaxDetails + + -- | 'PsErrSpecExprMultipleTypeAscription' is an error that occurs when + -- a user attempts to use the new form SPECIALISE pragma syntax with + -- multiple type signatures, e.g. + -- + -- @{-# SPECIALISE foo 3 :: Float -> Float; Double -> Double #-} + | PsErrSpecExprMultipleTypeAscription + + -- | 'PsWarnSpecMultipleTypeAscription' is a warning that occurs when + -- a user uses the old-form SPECIALISE pragma syntax with + -- multiple type signatures, e.g. + -- + -- @{-# SPECIALISE bar :: Float -> Float; Double -> Double #-} + -- + -- This constructor is deprecated and will be removed in GHC 9.18. + | PsWarnSpecMultipleTypeAscription + + -- | The deprecated ``pattern`` namespace specifier was used in an import or + -- export list. Suggested fix: use the ``data`` keyword instead. + | PsWarnPatternNamespaceSpecifier + !Bool -- ^ Is ExplicitNamespaces on? + + deriving Generic + +-- | Extra details about a parse error, which helps +-- us in determining which should be the hints to +-- suggest. +data PsErrParseDetails + = PsErrParseDetails + { ped_th_enabled :: !Bool + -- Is 'TemplateHaskell' enabled? + , ped_do_in_last_100 :: !Bool + -- ^ Is there a 'do' in the last 100 characters? + , ped_mdo_in_last_100 :: !Bool + -- ^ Is there an 'mdo' in the last 100 characters? + , ped_pat_syn_enabled :: !Bool + -- ^ Is 'PatternSynonyms' enabled? + , ped_pattern_parsed :: !Bool + -- ^ Did we parse a \"pattern\" keyword? + } + +data PsInvalidTypeSignature + = PsErrInvalidTypeSig_Qualified + | PsErrInvalidTypeSig_DataCon + | PsErrInvalidTypeSig_Other + +-- | Is the parsed pattern recursive? +data PatIsRecursive + = YesPatIsRecursive + | NoPatIsRecursive + +data PatIncompleteDoBlock + = YesIncompleteDoBlock + | NoIncompleteDoBlock + deriving Eq + +-- | Extra information for the expression GHC is currently inspecting/parsing. +-- It can be used to generate more informative parser diagnostics and hints. +data ParseContext + = ParseContext + { is_infix :: !(Maybe RdrName) + -- ^ If 'Just', this is an infix + -- pattern with the bound operator name + , incomplete_do_block :: !PatIncompleteDoBlock + -- ^ Did the parser likely fail due to an incomplete do block? + } deriving Eq + +data PsErrInPatDetails + = PEIP_NegApp + -- ^ Negative application pattern? + | PEIP_RecPattern [LPat GhcPs] -- ^ The pattern arguments + !PatIsRecursive -- ^ Is the parsed pattern recursive? + !ParseContext + | PEIP_OtherPatDetails !ParseContext + +data PsErrPunDetails + = PEP_QuoteDisambiguation + | PEP_TupleSyntaxType + | PEP_SumSyntaxType + +data PsErrTypeSyntaxDetails + = PETS_FunctionArrow + !(LocatedA (PatBuilder GhcPs)) + !(HsMultAnnOf (LocatedA (PatBuilder GhcPs)) GhcPs) + !(LocatedA (PatBuilder GhcPs)) + | PETS_Multiplicity + !(EpToken "%") + !(LocatedA (PatBuilder GhcPs)) + | PETS_ForallTelescope + !(HsForAllTelescope GhcPs) + !(LocatedA (PatBuilder GhcPs)) + | PETS_ConstraintContext !(LocatedA (PatBuilder GhcPs)) + +noParseContext :: ParseContext +noParseContext = ParseContext Nothing NoIncompleteDoBlock + +incompleteDoBlock :: ParseContext +incompleteDoBlock = ParseContext Nothing YesIncompleteDoBlock + +-- | Builds a 'PsErrInPatDetails' with the information provided by the 'ParseContext'. +fromParseContext :: ParseContext -> PsErrInPatDetails +fromParseContext = PEIP_OtherPatDetails + +data NumUnderscoreReason + = NumUnderscore_Integral + | NumUnderscore_Float + deriving (Show,Eq,Ord) + + +data LexErrKind + = LexErrKind_EOF -- ^ End of input + | LexErrKind_UTF8 -- ^ UTF-8 decoding error + | LexErrKind_Char !Char -- ^ Error at given character + deriving (Show,Eq,Ord) + +data LexErr + = LexError -- ^ Lexical error + | LexUnknownPragma -- ^ Unknown pragma + | LexErrorInPragma -- ^ Lexical error in pragma + | LexNumEscapeRange -- ^ Numeric escape sequence out of range + | LexUnterminatedComment -- ^ Unterminated `{-' + | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma + | LexUnterminatedQQ -- ^ Unterminated quasiquotation + deriving (Show,Eq,Ord) + +-- | Errors from the Cmm parser +data CmmParserError + = CmmUnknownPrimitive !FastString -- ^ Unknown Cmm primitive + | CmmUnknownMacro !FastString -- ^ Unknown macro + | CmmUnknownCConv !String -- ^ Unknown calling convention + | CmmUnrecognisedSafety !String -- ^ Unrecognised safety + | CmmUnrecognisedHint !String -- ^ Unrecognised hint + +data TransLayoutReason + = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block" + | TransLayout_Pipe -- ^ "`|' at the same depth as implicit layout block") + + +data FileHeaderPragmaType + = OptionsPrag + | IncludePrag + | LanguagePrag + | DocOptionsPrag diff --git a/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/HaddockLex.hs @@ -0,0 +1,461 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LINE 1 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/HaddockLex.x" #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +module GHC.Parser.HaddockLex (lexHsDoc, lexStringLiteral) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Hs.Doc +import GHC.Parser.Lexer +import GHC.Parser.Lexer.Interface (adjustChar) +import GHC.Parser.Annotation +import GHC.Types.SrcLoc +import GHC.Types.SourceText +import GHC.Data.StringBuffer +import qualified GHC.Data.Strict as Strict +import GHC.Types.Name.Reader +import GHC.Utils.Error +import GHC.Utils.Encoding +import GHC.Hs.Extension + +import qualified GHC.Data.EnumSet as EnumSet + +import Data.Maybe +import Data.Word + +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS + +import qualified GHC.LanguageExtensions as LangExt +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array.Base (unsafeAt) +import GHC.Exts +#else +import GlaExts +#endif +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: AlexAddr +alex_base = AlexA# + "\xda\xff\xff\xff\x0b\x00\x00\x00\x65\x00\x00\x00\xe3\x00\x00\x00\x3d\x01\x00\x00\xbb\x01\x00\x00\xe5\xff\xff\xff\x15\x02\x00\x00\x55\x02\x00\x00\xaf\x02\x00\x00\x00\x00\x00\x00\x2d\x03\x00\x00\xab\x03\x00\x00\x05\x04\x00\x00\xe6\xff\xff\xff\x61\x04\x00\x00\xa1\x04\x00\x00\x1b\x05\x00\x00\x99\x05\x00\x00\x00\x00\x00\x00\x13\x06\x00\x00\x6d\x06\x00\x00\xeb\x06\x00\x00\x65\x07\x00\x00\xdf\xff\xff\xff\xbf\x07\x00\x00\x00\x00\x00\x00\xdc\xff\xff\xff\xff\x07\x00\x00\x59\x08\x00\x00\xe1\xff\xff\xff\x9c\x08\x00\x00\xa5\xff\xff\xff"# + +alex_table :: AlexAddr +alex_table = AlexA# + "\x00\x00\x0b\x00\x18\x00\x1a\x00\x1e\x00\x1a\x00\x13\x00\x00\x00\x06\x00\x0e\x00\x1b\x00\x00\x00\x01\x00\x01\x00\x01\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x09\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x1b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x11\x00\x00\x00\x11\x00\x01\x00\x00\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x00\x00\x11\x00\x00\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x11\x00\x00\x00\x11\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x08\x00\x00\x00\x07\x00\x03\x00\x1b\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x07\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x07\x00\x00\x00\x07\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x07\x00\x00\x00\x07\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x07\x00\x05\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x07\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\x07\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x07\x00\x00\x00\x07\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0c\x00\x10\x00\x00\x00\x0f\x00\x08\x00\x1b\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x02\x00\x00\x00\x0f\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x16\x00\x14\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x00\x00\x1f\x00\x00\x00\x19\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x19\x00\x00\x00\x19\x00\x14\x00\x04\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x19\x00\x00\x00\x19\x00\x0c\x00\x0c\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x10\x00\x00\x00\x0f\x00\x0c\x00\x13\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x10\x00\x0f\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x10\x00\x10\x00\x10\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x00\x00\x13\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x13\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x20\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x11\x00\x00\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x11\x00\x00\x00\x11\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x16\x00\x14\x00\x00\x00\x19\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x19\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x19\x00\x00\x00\x19\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x19\x00\x00\x00\x19\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x19\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x13\x00\x00\x00\x00\x00\x19\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x1c\x00\x1c\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x00\x00\x00\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1c\x00\x00\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1d\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x1b\x00\x1d\x00\x1d\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x05\x00\x1c\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1d\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x1d\x00\x00\x00\x1d\x00\x1c\x00\x00\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x00\x00\x1d\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# + "\xff\xff\x27\x00\x23\x00\x27\x00\x23\x00\x60\x00\x27\x00\xff\xff\x23\x00\x23\x00\x29\x00\xff\xff\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x60\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x60\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# + "\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0 :: Int, 32) + [ AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccSkip + , AlexAccSkip + , AlexAccSkip + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 3 + , AlexAcc 2 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 1 + , AlexAccNone + , AlexAccNone + , AlexAcc 0 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + ] + +alex_actions = array (0 :: Int, 4) + [ (3,alex_action_0) + , (2,alex_action_0) + , (1,alex_action_0) + , (0,alex_action_1) + ] + +alex_action_0 = getIdentifier 1 +alex_action_1 = getIdentifier 2 + +#define ALEX_GHC 1 +#define ALEX_LATIN1 1 +#define ALEX_NOPRED 1 +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +#ifdef ALEX_GHC +# define ILIT(n) n# +# define IBOX(n) (I# (n)) +# define FAST_INT Int# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +# if __GLASGOW_HASKELL__ > 706 +# define GTE(n,m) (tagToEnum# (n >=# m)) +# define EQ(n,m) (tagToEnum# (n ==# m)) +# else +# define GTE(n,m) (n >=# m) +# define EQ(n,m) (n ==# m) +# endif +# define PLUS(n,m) (n +# m) +# define MINUS(n,m) (n -# m) +# define TIMES(n,m) (n *# m) +# define NEGATE(n) (negateInt# (n)) +# define IF_GHC(x) (x) +#else +# define ILIT(n) (n) +# define IBOX(n) (n) +# define FAST_INT Int +# define GTE(n,m) (n >= m) +# define EQ(n,m) (n == m) +# define PLUS(n,m) (n + m) +# define MINUS(n,m) (n - m) +# define TIMES(n,m) (n * m) +# define NEGATE(n) (negate (n)) +# define IF_GHC(x) +#endif + +#ifdef ALEX_GHC +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else +#if __GLASGOW_HASKELL__ >= 901 + int16ToInt# +#endif + (indexInt16OffAddr# arr off) +#endif +#else +alexIndexInt16OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else +#if __GLASGOW_HASKELL__ >= 901 + int32ToInt# +#endif + (indexInt32OffAddr# arr off) +#endif +#else +alexIndexInt32OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif +#else +quickIndex arr i = arr ! i +#endif + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ IBOX(sc) + = alexScanUser undefined input__ IBOX(sc) + +alexScanUser user__ input__ IBOX(sc) + = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> +#ifdef ALEX_DEBUG + trace ("End of input.") $ +#endif + AlexEOF + Just _ -> +#ifdef ALEX_DEBUG + trace ("Error.") $ +#endif + AlexError input__' + + (AlexLastSkip input__'' len, _) -> +#ifdef ALEX_DEBUG + trace ("Skipping.") $ +#endif + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> +#ifdef ALEX_DEBUG + trace ("Accept.") $ +#endif + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` IBOX(s))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> +#ifdef ALEX_DEBUG + trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $ +#endif + case fromIntegral c of { IBOX(ord_c) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = PLUS(base,ord_c) + + new_s = if GTE(offset,ILIT(0)) + && let check = alexIndexInt16OffAddr alex_check offset + in EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + ILIT(-1) -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input +#ifdef ALEX_LATIN1 + PLUS(len,ILIT(1)) + -- issue 119: in the latin1 encoding, *each* byte is one character +#else + (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) +#endif + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ IBOX(len) + check_accs (AlexAccSkip) = AlexLastSkip input__ IBOX(len) +#ifndef ALEX_NOPRED + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastAcc a input__ IBOX(len) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastSkip input__ IBOX(len) + | otherwise + = check_accs rest +#endif + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip +#ifndef ALEX_NOPRED + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext IBOX(sc) user__ _ _ input__ = + case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. +#endif +{-# LINE 85 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/HaddockLex.x" #-} +data AlexInput = AlexInput + { alexInput_position :: !RealSrcLoc + , alexInput_string :: !ByteString + } + +-- NB: As long as we don't use a left-context we don't need to track the +-- previous input character. +alexInputPrevChar :: AlexInput -> Word8 +alexInputPrevChar = error "Left-context not supported" + +alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) +alexGetByte (AlexInput p s) = case utf8UnconsByteString s of + Nothing -> Nothing + Just (c,bs) -> Just (adjustChar c, AlexInput (advanceSrcLoc p c) bs) + +alexScanTokens :: RealSrcLoc -> ByteString -> [(RealSrcSpan, ByteString)] +alexScanTokens start str0 = go (AlexInput start str0) + where go inp@(AlexInput pos str) = + case alexScan inp 0 of + AlexSkip inp' _ln -> go inp' + AlexToken inp'@(AlexInput _ str') _ act -> act pos (BS.length str - BS.length str') str : go inp' + AlexEOF -> [] + AlexError (AlexInput p _) -> error $ "lexical error at " ++ show p + +-------------------------------------------------------------------------------- + +-- | Extract identifier from Alex state. +getIdentifier :: Int -- ^ adornment length + -> RealSrcLoc + -> Int + -- ^ Token length + -> ByteString + -- ^ The remaining input beginning with the found token + -> (RealSrcSpan, ByteString) +getIdentifier !i !loc0 !len0 !s0 = + (mkRealSrcSpan loc1 loc2, ident) + where + (adornment, s1) = BS.splitAt i s0 + ident = BS.take (len0 - 2*i) s1 + loc1 = advanceSrcLocBS loc0 adornment + loc2 = advanceSrcLocBS loc1 ident + +advanceSrcLocBS :: RealSrcLoc -> ByteString -> RealSrcLoc +advanceSrcLocBS !loc bs = case utf8UnconsByteString bs of + Nothing -> loc + Just (c, bs') -> advanceSrcLocBS (advanceSrcLoc loc c) bs' + +-- | Lex 'StringLiteral' for warning messages +lexStringLiteral :: P (LocatedN RdrName) -- ^ A precise identifier parser + -> Located StringLiteral + -> Located (WithHsDocIdentifiers StringLiteral GhcPs) +lexStringLiteral identParser (L l sl@(StringLiteral _ fs _)) + = L l (WithHsDocIdentifiers sl idents) + where + bs = bytesFS fs + + idents = mapMaybe (uncurry (validateIdentWith identParser)) plausibleIdents + + plausibleIdents :: [(SrcSpan,ByteString)] + plausibleIdents = case l of + RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] + UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs] + + fakeLoc = mkRealSrcLoc nilFS 0 0 + +-- | Lex identifiers from a docstring. +lexHsDoc :: P (LocatedN RdrName) -- ^ A precise identifier parser + -> HsDocString + -> HsDoc GhcPs +lexHsDoc identParser doc = + WithHsDocIdentifiers doc idents + where + docStrings = docStringChunks doc + idents = concat [mapMaybe maybeDocIdentifier (plausibleIdents doc) | doc <- docStrings] + + maybeDocIdentifier :: (SrcSpan, ByteString) -> Maybe (Located RdrName) + maybeDocIdentifier = uncurry (validateIdentWith identParser) + + plausibleIdents :: LHsDocStringChunk -> [(SrcSpan,ByteString)] + plausibleIdents (L (RealSrcSpan span _) (HsDocStringChunk s)) + = [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) s] + plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s)) + = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason + + fakeLoc = mkRealSrcLoc nilFS 0 0 + +validateIdentWith :: P (LocatedN RdrName) -> SrcSpan -> ByteString -> Maybe (Located RdrName) +validateIdentWith identParser mloc str0 = + let -- These ParserFlags should be as "inclusive" as possible, allowing + -- identifiers defined with any language extension. + pflags = mkParserOpts + (EnumSet.fromList [LangExt.MagicHash]) + dopts + False False False False + dopts = emptyDiagOpts + buffer = stringBufferFromByteString str0 + realSrcLc = case mloc of + RealSrcSpan loc _ -> realSrcSpanStart loc + UnhelpfulSpan _ -> mkRealSrcLoc nilFS 0 0 + pstate = initParserState pflags buffer realSrcLc + in case unP identParser pstate of + POk _ name -> Just $ case mloc of + RealSrcSpan _ _ -> reLoc name + UnhelpfulSpan _ -> L mloc (unLoc name) -- Preserve the original reason + _ -> Nothing diff --git a/GHC/Parser/Header.hs b/GHC/Parser/Header.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Header.hs @@ -0,0 +1,476 @@ +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- +-- | Parsing the top of a Haskell source file to get its module name, +-- imports and options. +-- +-- (c) Simon Marlow 2005 +-- (c) Lemmih 2006 +-- +----------------------------------------------------------------------------- + +module GHC.Parser.Header + ( getImports + , mkPrelImports -- used by the renamer too + , getOptionsFromFile + , getOptions + , toArgs + , checkProcessArgsResult + ) +where + +import GHC.Prelude + +import GHC.Data.Bag + +import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions! + +import GHC.Parser.Errors.Types +import GHC.Parser ( parseHeader ) +import GHC.Parser.Lexer + +import GHC.Hs +import GHC.Builtin.Names + +import GHC.Types.Error +import GHC.Types.SrcLoc +import GHC.Types.SourceError +import GHC.Types.SourceText +import GHC.Types.PkgQual +import GHC.Types.Basic (ImportLevel(..), convImportLevel) + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Monad +import GHC.Utils.Error +import GHC.Utils.Exception as Exception + +import GHC.Data.StringBuffer +import GHC.Data.Maybe +import GHC.Data.FastString +import qualified GHC.Data.Strict as Strict + +import Control.Monad +import System.IO +import System.IO.Unsafe +import Data.List (partition) +import Data.Char (isSpace) +import Text.ParserCombinators.ReadP (readP_to_S, gather) +import Text.ParserCombinators.ReadPrec (readPrec_to_P) +import Text.Read (readPrec) + +------------------------------------------------------------------------------ + +-- | Parse the imports of a source file. +-- +-- Throws a 'SourceError' if parsing fails. +getImports :: ParserOpts -- ^ Parser options + -> Bool -- ^ Implicit Prelude? + -> StringBuffer -- ^ Parse this. + -> FilePath -- ^ Filename the buffer came from. Used for + -- reporting parse error locations. + -> FilePath -- ^ The original source filename (used for locations + -- in the function result) + -> IO (Either + (Messages PsMessage) + ([Located ModuleName], + [(ImportLevel, RawPkgQual, Located ModuleName)], + Located ModuleName)) + -- ^ The source imports and normal imports (with optional package + -- names from -XPackageImports), and the module name. +getImports popts implicit_prelude buf filename source_filename = do + let loc = mkRealSrcLoc (mkFastString filename) 1 1 + case unP parseHeader (initParserState popts buf loc) of + PFailed pst -> + -- assuming we're not logging warnings here as per below + return $ Left $ getPsErrorMessages pst + POk pst rdr_module -> fmap Right $ do + let (_warns, errs) = getPsMessages pst + -- don't log warnings: they'll be reported when we parse the file + -- for real. See #2500. + if not (isEmptyMessages errs) + then throwErrors (GhcPsMessage <$> errs) + else + let hsmod = unLoc rdr_module + mb_mod = hsmodName hsmod + imps = hsmodImports hsmod + main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) + 1 1) + mod = mb_mod `orElse` L (noAnnSrcSpan main_loc) mAIN_NAME + (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps + + implicit_imports = mkPrelImports (unLoc mod) main_loc + implicit_prelude imps + convImport (L _ (i :: ImportDecl GhcPs)) = (convImportLevel (ideclLevelSpec i), ideclPkgQual i, reLoc $ ideclName i) + convImport_src (L _ (i :: ImportDecl GhcPs)) = (reLoc $ ideclName i) + in + return (map convImport_src src_idecls + , map convImport (implicit_imports ++ ord_idecls) + , reLoc mod) + + + +mkPrelImports :: ModuleName + -> SrcSpan -- Attribute the "import Prelude" to this location + -> Bool -> [LImportDecl GhcPs] + -> [LImportDecl GhcPs] +-- Construct the implicit declaration "import Prelude" (or not) +-- +-- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); +-- because the former doesn't even look at Prelude.hi for instance +-- declarations, whereas the latter does. +mkPrelImports this_mod loc implicit_prelude import_decls + | this_mod == pRELUDE_NAME + || explicit_prelude_import + || not implicit_prelude + = [] + | otherwise = [preludeImportDecl] + where + explicit_prelude_import = any is_prelude_import import_decls + + is_prelude_import (L _ (decl::ImportDecl GhcPs)) = + unLoc (ideclName decl) == pRELUDE_NAME + -- See #17045, package qualified imports are never counted as + -- explicit prelude imports + && case ideclPkgQual decl of + NoRawPkgQual -> True + RawPkgQual {} -> False + -- Only a "normal" level import will override the implicit prelude import. + && case ideclLevelSpec decl of + NotLevelled -> True + _ -> False + + + loc' = noAnnSrcSpan loc + preludeImportDecl :: LImportDecl GhcPs + preludeImportDecl + = L loc' $ ImportDecl { ideclExt = XImportDeclPass + { ideclAnn = noAnn + , ideclSourceText = NoSourceText + , ideclImplicit = True -- Implicit! + }, + ideclName = L loc' pRELUDE_NAME, + ideclPkgQual = NoRawPkgQual, + ideclSource = NotBoot, + ideclSafe = False, -- Not a safe import + ideclQualified = NotQualified, + ideclAs = Nothing, + ideclLevelSpec = NotLevelled, + ideclImportList = Nothing } + +-------------------------------------------------------------- +-- Get options +-------------------------------------------------------------- + +-- | Parse OPTIONS and LANGUAGE pragmas of the source file. +-- +-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) +getOptionsFromFile :: ParserOpts + -> [String] -- ^ Supported LANGUAGE pragmas + -> FilePath -- ^ Input file + -> IO (Messages PsMessage, [Located String]) -- ^ Parsed options, if any. +getOptionsFromFile opts supported filename + = Exception.bracket + (openBinaryFile filename ReadMode) + (hClose) + (\handle -> do + (warns, opts) <- fmap (getOptions' opts supported) + (lazyGetToks opts' filename handle) + seqList opts + $ seqList (bagToList $ getMessages warns) + $ return (warns, opts)) + where -- We don't need to get haddock doc tokens when we're just + -- getting the options from pragmas, and lazily lexing them + -- correctly is a little tricky: If there is "\n" or "\n-" + -- left at the end of a buffer then the haddock doc may + -- continue past the end of the buffer, despite the fact that + -- we already have an apparently-complete token. + -- We therefore just turn Opt_Haddock off when doing the lazy + -- lex. + opts' = disableHaddock opts + +blockSize :: Int +-- blockSize = 17 -- for testing :-) +blockSize = 1024 + +lazyGetToks :: ParserOpts -> FilePath -> Handle -> IO [Located Token] +lazyGetToks popts filename handle = do + buf <- hGetStringBufferBlock handle blockSize + let prag_state = initPragState popts buf loc + unsafeInterleaveIO $ lazyLexBuf handle prag_state False blockSize + where + loc = mkRealSrcLoc (mkFastString filename) 1 1 + + lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] + lazyLexBuf handle state eof size = + case unP (lexer False return) state of + POk state' t -> do + -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) + if atEnd (buffer state') && not eof + -- if this token reached the end of the buffer, and we haven't + -- necessarily read up to the end of the file, then the token might + -- be truncated, so read some more of the file and lex it again. + then getMore handle state size + else case unLoc t of + ITeof -> return [t] + _other -> do rest <- lazyLexBuf handle state' eof size + return (t : rest) + _ | not eof -> getMore handle state size + | otherwise -> return [L (mkSrcSpanPs (last_loc state)) ITeof] + -- parser assumes an ITeof sentinel at the end + + getMore :: Handle -> PState -> Int -> IO [Located Token] + getMore handle state size = do + -- pprTrace "getMore" (text (show (buffer state))) (return ()) + let new_size = size * 2 + -- double the buffer size each time we read a new block. This + -- counteracts the quadratic slowdown we otherwise get for very + -- large module names (#5981) + nextbuf <- hGetStringBufferBlock handle new_size + if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do + newbuf <- appendStringBuffers (buffer state) nextbuf + unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size + + +getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token] +getToks popts filename buf = lexAll pstate + where + pstate = initPragState popts buf loc + loc = mkRealSrcLoc (mkFastString filename) 1 1 + + lexAll state = case unP (lexer False return) state of + POk _ t@(L _ ITeof) -> [t] + POk state' t -> t : lexAll state' + _ -> [L (mkSrcSpanPs (last_loc state)) ITeof] + + +-- | Parse OPTIONS and LANGUAGE pragmas of the source file. +-- +-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) +getOptions :: ParserOpts + -> [String] -- ^ Supported LANGUAGE pragmas + -> StringBuffer -- ^ Input Buffer + -> FilePath -- ^ Source filename. Used for location info. + -> (Messages PsMessage,[Located String]) -- ^ warnings and parsed options. +getOptions opts supported buf filename + = getOptions' opts supported (getToks opts filename buf) + +-- The token parser is written manually because Happy can't +-- return a partial result when it encounters a lexer error. +-- We want to extract options before the buffer is passed through +-- CPP, so we can't use the same trick as 'getImports'. +getOptions' :: ParserOpts + -> [String] + -> [Located Token] -- Input buffer + -> (Messages PsMessage,[Located String]) -- Options. +getOptions' opts supported toks + = parseToks toks + where + parseToks (open:close:xs) + | IToptions_prag str <- unLoc open + , ITclose_prag <- unLoc close + = case toArgs starting_loc str of + Left _err -> optionsParseError str $ -- #15053 + combineSrcSpans (getLoc open) (getLoc close) + Right args -> fmap (args ++) (parseToks xs) + where + src_span = getLoc open + real_src_span = expectJust (srcSpanToRealSrcSpan src_span) + starting_loc = realSrcSpanStart real_src_span + parseToks (open:close:xs) + | ITinclude_prag str <- unLoc open + , ITclose_prag <- unLoc close + = fmap (map (L (getLoc open)) ["-#include",removeSpaces str] ++) + (parseToks xs) + parseToks (open:close:xs) + | ITdocOptions str _ <- unLoc open + , ITclose_prag <- unLoc close + = fmap (map (L (getLoc open)) ["-haddock-opts", removeSpaces str] ++) + (parseToks xs) + parseToks (open:xs) + | ITlanguage_prag <- unLoc open + = parseLanguage xs + parseToks (comment:xs) -- Skip over comments + | isComment (unLoc comment) + = parseToks xs + -- At the end of the header, warn about all the misplaced pragmas + parseToks xs = (unionManyMessages $ mapMaybe mkMessage xs ,[]) + + parseLanguage ((L loc (ITconid fs)):rest) + = fmap (checkExtension supported (L loc fs) :) $ + case rest of + (L _loc ITcomma):more -> parseLanguage more + (L _loc ITclose_prag):more -> parseToks more + (L loc _):_ -> languagePragParseError loc + [] -> panic "getOptions'.parseLanguage(1) went past eof token" + parseLanguage (tok:_) + = languagePragParseError (getLoc tok) + parseLanguage [] + = panic "getOptions'.parseLanguage(2) went past eof token" + + -- Warn for all the misplaced pragmas + mkMessage :: Located Token -> Maybe (Messages PsMessage) + mkMessage (L loc token) + | IToptions_prag _ <- token + = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma OptionsPrag)) + | ITinclude_prag _ <- token + = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma IncludePrag)) + | ITdocOptions _ _ <- token + = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma DocOptionsPrag)) + | ITlanguage_prag <- token + = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma LanguagePrag)) + | otherwise = Nothing + where diag_opts = pDiagOpts opts + + isComment :: Token -> Bool + isComment c = + case c of + (ITlineComment {}) -> True + (ITblockComment {}) -> True + (ITdocComment {}) -> True + _ -> False + +toArgs :: RealSrcLoc + -> String -> Either String -- Error + [Located String] -- Args +toArgs starting_loc orig_str + = let (after_spaces_loc, after_spaces_str) = consume_spaces starting_loc orig_str in + case after_spaces_str of + '[':after_bracket -> + let after_bracket_loc = advanceSrcLoc after_spaces_loc '[' + (after_bracket_spaces_loc, after_bracket_spaces_str) + = consume_spaces after_bracket_loc after_bracket in + case after_bracket_spaces_str of + ']':rest | all isSpace rest -> Right [] + _ -> readAsList after_bracket_spaces_loc after_bracket_spaces_str + + _ -> toArgs' after_spaces_loc after_spaces_str + where + consume_spaces :: RealSrcLoc -> String -> (RealSrcLoc, String) + consume_spaces loc [] = (loc, []) + consume_spaces loc (c:cs) + | isSpace c = consume_spaces (advanceSrcLoc loc c) cs + | otherwise = (loc, c:cs) + + break_with_loc :: (Char -> Bool) -> RealSrcLoc -> String + -> (String, RealSrcLoc, String) -- location is start of second string + break_with_loc p = go [] + where + go reversed_acc loc [] = (reverse reversed_acc, loc, []) + go reversed_acc loc (c:cs) + | p c = (reverse reversed_acc, loc, c:cs) + | otherwise = go (c:reversed_acc) (advanceSrcLoc loc c) cs + + advance_src_loc_many :: RealSrcLoc -> String -> RealSrcLoc + advance_src_loc_many = foldl' advanceSrcLoc + + locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a + locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end) Strict.Nothing) x + + toArgs' :: RealSrcLoc -> String -> Either String [Located String] + -- Remove outer quotes: + -- > toArgs' "\"foo\" \"bar baz\"" + -- Right ["foo", "bar baz"] + -- + -- Keep inner quotes: + -- > toArgs' "-DFOO=\"bar baz\"" + -- Right ["-DFOO=\"bar baz\""] + toArgs' loc s = + let (after_spaces_loc, after_spaces_str) = consume_spaces loc s in + case after_spaces_str of + [] -> Right [] + '"' : _ -> do + -- readAsString removes outer quotes + (arg, new_loc, rest) <- readAsString after_spaces_loc after_spaces_str + check_for_space rest + (locate after_spaces_loc new_loc arg:) + `fmap` toArgs' new_loc rest + _ -> case break_with_loc (isSpace <||> (== '"')) after_spaces_loc after_spaces_str of + (argPart1, loc2, s''@('"':_)) -> do + (argPart2, loc3, rest) <- readAsString loc2 s'' + check_for_space rest + -- show argPart2 to keep inner quotes + (locate after_spaces_loc loc3 (argPart1 ++ show argPart2):) + `fmap` toArgs' loc3 rest + (arg, loc2, s'') -> (locate after_spaces_loc loc2 arg:) + `fmap` toArgs' loc2 s'' + + check_for_space :: String -> Either String () + check_for_space [] = Right () + check_for_space (c:_) + | isSpace c = Right () + | otherwise = Left ("Whitespace expected after string in " ++ show orig_str) + + reads_with_consumed :: Read a => String + -> [((String, a), String)] + -- ((consumed string, parsed result), remainder of input) + reads_with_consumed = readP_to_S (gather (readPrec_to_P readPrec 0)) + + readAsString :: RealSrcLoc + -> String + -> Either String (String, RealSrcLoc, String) + readAsString loc s = case reads_with_consumed s of + [((consumed, arg), rest)] -> + Right (arg, advance_src_loc_many loc consumed, rest) + _ -> + Left ("Couldn't read " ++ show s ++ " as String") + + -- input has had the '[' stripped off + readAsList :: RealSrcLoc -> String -> Either String [Located String] + readAsList loc s = do + let (after_spaces_loc, after_spaces_str) = consume_spaces loc s + (arg, after_arg_loc, after_arg_str) <- readAsString after_spaces_loc after_spaces_str + let (after_arg_spaces_loc, after_arg_spaces_str) + = consume_spaces after_arg_loc after_arg_str + (locate after_spaces_loc after_arg_loc arg :) <$> + case after_arg_spaces_str of + ',':after_comma -> readAsList (advanceSrcLoc after_arg_spaces_loc ',') after_comma + ']':after_bracket + | all isSpace after_bracket + -> Right [] + _ -> Left ("Couldn't read " ++ show ('[' : s) ++ " as [String]") + -- reinsert missing '[' for clarity. + +----------------------------------------------------------------------------- + +-- | Complain about non-dynamic flags in OPTIONS pragmas. +-- +-- Throws a 'SourceError' if the input list is non-empty claiming that the +-- input flags are unknown. +checkProcessArgsResult :: MonadIO m => [Located String] -> m () +checkProcessArgsResult flags + = when (notNull flags) $ + liftIO $ throwErrors $ foldMap (singleMessage . mkMsg) flags + where mkMsg (L loc flag) + = mkPlainErrorMsgEnvelope loc $ + GhcPsMessage $ PsHeaderMessage $ PsErrUnknownOptionsPragma flag + +----------------------------------------------------------------------------- + +checkExtension :: [String] -> Located FastString -> Located String +checkExtension supported (L l ext) +-- Checks if a given extension is valid, and if so returns +-- its corresponding flag. Otherwise it throws an exception. + = if ext' `elem` supported + then L l ("-X"++ext') + else unsupportedExtnError supported l ext' + where + ext' = unpackFS ext + +languagePragParseError :: SrcSpan -> a +languagePragParseError loc = + throwErr loc $ PsErrParseLanguagePragma + +unsupportedExtnError :: [String] -> SrcSpan -> String -> a +unsupportedExtnError supported loc unsup = + throwErr loc $ PsErrUnsupportedExt unsup supported + +optionsParseError :: String -> SrcSpan -> a -- #15053 +optionsParseError str loc = + throwErr loc $ PsErrParseOptionsPragma str + +throwErr :: SrcSpan -> PsHeaderMessage -> a -- #15053 +throwErr loc ps_msg = + let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage (PsHeaderMessage ps_msg) + in throw $ mkSrcErr $ singleMessage msg diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Lexer.hs @@ -0,0 +1,4028 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LINE 43 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/Lexer.x" #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnliftedNewtypes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DataKinds #-} + + +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Parser.Lexer ( + Token(..), lexer, lexerDbg, + ParserOpts(..), mkParserOpts, + PState (..), initParserState, initPragState, + P(..), ParseResult(POk, PFailed), + allocateComments, allocatePriorComments, allocateFinalComments, + MonadP(..), getBit, + getRealSrcLoc, getPState, + failMsgP, failLocMsgP, srcParseFail, + getPsErrorMessages, getPsMessages, + popContext, pushModuleContext, setLastToken, setSrcLoc, + activeContext, nextIsEOF, + getLexState, popLexState, pushLexState, + ExtBits(..), + xtest, xunset, xset, + disableHaddock, + lexTokenStream, + mkParensEpToks, + mkParensLocs, + getCommentsFor, getPriorCommentsFor, getFinalCommentsFor, + getEofPos, + commentToAnnotation, + HdkComment(..), + warnopt, + addPsMessage + ) where + +import GHC.Prelude +import qualified GHC.Data.Strict as Strict + +-- base +import Control.Monad +import Control.Applicative +import Data.Char +import Data.List (stripPrefix, isInfixOf, partition) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import Data.Word +import Debug.Trace (trace) + +import GHC.Data.EnumSet as EnumSet + +-- ghc-boot +import qualified GHC.LanguageExtensions as LangExt + +-- bytestring +import Data.ByteString (ByteString) + +-- containers +import Data.Map (Map) +import qualified Data.Map as Map + +-- compiler +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Types.Error +import GHC.Types.Unique.FM +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair ) + +import GHC.Types.SrcLoc +import GHC.Types.SourceText +import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..)) +import GHC.Hs.Doc + +import GHC.Parser.CharClass + +import GHC.Parser.Annotation +import GHC.Driver.Flags +import GHC.Parser.Errors.Basic +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () +import GHC.Parser.Lexer.Interface +import qualified GHC.Parser.Lexer.String as Lexer.String +import GHC.Parser.String +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array.Base (unsafeAt) +import GHC.Exts +#else +import GlaExts +#endif +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: AlexAddr +alex_base = AlexA# + "\x01\x00\x00\x00\x7b\x00\x00\x00\x84\x00\x00\x00\xa0\x00\x00\x00\xbc\x00\x00\x00\xc5\x00\x00\x00\xce\x00\x00\x00\xf7\x00\x00\x00\x05\x01\x00\x00\x2f\x01\x00\x00\x4b\x01\x00\x00\x86\x01\x00\x00\x85\xff\xff\xff\xfe\x01\x00\x00\x3d\x02\x00\x00\x86\x02\x00\x00\xdf\xff\xff\xff\xad\x02\x00\x00\x0c\x03\x00\x00\x46\x03\x00\x00\xc2\xff\xff\xff\xc6\xff\xff\xff\xa0\x03\x00\x00\xc3\xff\xff\xff\x45\x00\x00\x00\x47\x00\x00\x00\xcb\xff\xff\xff\xca\xff\xff\xff\x41\x00\x00\x00\xc5\xff\xff\xff\xd8\xff\xff\xff\xc4\xff\xff\xff\x13\x01\x00\x00\x00\x00\x00\x00\xfc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x04\x00\x00\xa1\xff\xff\xff\x78\x00\x00\x00\x00\x00\x00\x00\xb8\x04\x00\x00\xf1\xff\xff\xff\xc3\x00\x00\x00\x32\x05\x00\x00\xac\x05\x00\x00\x08\x06\x00\x00\xf2\xff\xff\xff\xa3\xff\xff\xff\x00\x00\x00\x00\x48\x06\x00\x00\xc2\x06\x00\x00\x3b\x04\x00\x00\x56\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x17\x00\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\x3c\x07\x00\x00\xb6\x07\x00\x00\x64\x01\x00\x00\x2c\x08\x00\x00\x39\x01\x00\x00\x6c\x08\x00\x00\xea\x08\x00\x00\x97\x00\x00\x00\xa8\x00\x00\x00\x68\x09\x00\x00\x00\x02\x00\x00\xc2\x09\x00\x00\x8b\x00\x00\x00\x8c\x00\x00\x00\x85\x01\x00\x00\x38\x0a\x00\x00\x0e\x02\x00\x00\x78\x0a\x00\x00\xf6\x0a\x00\x00\x74\x0b\x00\x00\xee\x0b\x00\x00\x68\x0c\x00\x00\xe2\x0c\x00\x00\x5c\x0d\x00\x00\xd6\x0d\x00\x00\x50\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x02\x00\x00\x1b\x02\x00\x00\x21\x08\x00\x00\x9d\x06\x00\x00\x17\x07\x00\x00\x9d\x02\x00\x00\x2d\x0a\x00\x00\x91\x07\x00\x00\x6a\x00\x00\x00\x11\x02\x00\x00\x7c\x00\x00\x00\xbc\x03\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x1a\x04\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x46\x00\x00\x00\x48\x00\x00\x00\x43\x00\x00\x00\x4d\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x63\x00\x00\x00\x51\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd3\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x49\x01\x00\x00\x97\x04\x00\x00\xa4\x0e\x00\x00\xfd\x03\x00\x00\x10\x05\x00\x00\xbb\x0e\x00\x00\x29\x0e\x00\x00\x35\x02\x00\x00\x6e\x01\x00\x00\x27\x0d\x00\x00\x9f\x00\x00\x00\x9c\x00\x00\x00\x9a\x00\x00\x00\x9e\x00\x00\x00\xc4\x00\x00\x00\xa5\x00\x00\x00\xa4\x00\x00\x00\x94\x00\x00\x00\xb4\x00\x00\x00\xb0\x00\x00\x00\x98\x00\x00\x00\xa1\x00\x00\x00\x07\x0f\x00\x00\x2f\x0f\x00\x00\x72\x0f\x00\x00\x9a\x0f\x00\x00\xd1\x00\x00\x00\xdd\x0f\x00\x00\x05\x10\x00\x00\xfb\x00\x00\x00\xfd\x00\x00\x00\xfe\x00\x00\x00\x09\x01\x00\x00\x0b\x01\x00\x00\x0c\x01\x00\x00\x19\x01\x00\x00\xbe\x00\x00\x00\x31\x01\x00\x00\xd4\x00\x00\x00\x35\x01\x00\x00\xe1\x00\x00\x00\xd8\x00\x00\x00\xc1\x01\x00\x00\xd5\x00\x00\x00\xde\x00\x00\x00\x54\x01\x00\x00\x10\x01\x00\x00\xb8\x02\x00\x00\x00\x00\x00\x00\x64\x10\x00\x00\x00\x00\x00\x00\x81\x02\x00\x00\xe2\x10\x00\x00\x5e\x11\x00\x00\x00\x00\x00\x00\xdc\x11\x00\x00\x5a\x12\x00\x00\xc7\x03\x00\x00\xeb\x00\x00\x00\xf6\x00\x00\x00\xf3\x00\x00\x00\x28\x01\x00\x00\xfa\x00\x00\x00\x06\x01\x00\x00\x2c\x01\x00\x00\x17\x01\x00\x00\x0f\x01\x00\x00\x18\x01\x00\x00\x2e\x01\x00\x00\x99\x12\x00\x00\xf1\x02\x00\x00\xbb\x10\x00\x00\xf4\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x13\x00\x00\x00\x00\x00\x00\x52\x01\x00\x00\x55\x01\x00\x00\x26\x01\x00\x00\x2a\x01\x00\x00\x49\x02\x00\x00\x36\x01\x00\x00\x6a\x01\x00\x00\x59\x02\x00\x00\x3d\x01\x00\x00\xf4\x01\x00\x00\x40\x01\x00\x00\xd5\x01\x00\x00\x00\x00\x00\x00\x89\x01\x00\x00\x00\x00\x00\x00\x8e\x01\x00\x00\xa3\x13\x00\x00\x00\x00\x00\x00\x8a\x01\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\x00\x9d\x01\x00\x00\x00\x00\x00\x00\x9f\x01\x00\x00\x21\x14\x00\x00\x9b\x14\x00\x00\x15\x15\x00\x00\x8f\x15\x00\x00\x09\x16\x00\x00\x83\x16\x00\x00\xfd\x16\x00\x00\x77\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x17\x00\x00\x6b\x18\x00\x00\xe5\x18\x00\x00\x5f\x19\x00\x00\xd9\x19\x00\x00\x53\x1a\x00\x00\xcd\x1a\x00\x00\x47\x1b\x00\x00\x29\x06\x00\x00\x9f\x1b\x00\x00\x2f\x04\x00\x00\xe0\x1b\x00\x00\xa9\x04\x00\x00\xfa\x13\x00\x00\x21\x1c\x00\x00\x49\x09\x00\x00\x65\x1c\x00\x00\x23\x05\x00\x00\xa6\x1c\x00\x00\x87\x05\x00\x00\x74\x14\x00\x00\xe7\x1c\x00\x00\x55\x0b\x00\x00\x91\x05\x00\x00\x0a\x08\x00\x00\x18\x10\x00\x00\x16\x0a\x00\x00\xf0\x14\x00\x00\x3a\x06\x00\x00\xcf\x0b\x00\x00\xa7\x06\x00\x00\x46\x0c\x00\x00\xb6\x06\x00\x00\x2b\x1d\x00\x00\x6c\x1d\x00\x00\xc3\x0c\x00\x00\x0a\x06\x00\x00\x02\x02\x00\x00\xf6\x01\x00\x00\x85\x1d\x00\x00\xa6\x1d\x00\x00\x43\x01\x00\x00\x1f\x01\x00\x00\x5b\x01\x00\x00\x3e\x07\x00\x00\x76\x01\x00\x00\xef\x1d\x00\x00\x30\x1e\x00\x00\xb7\x0d\x00\x00\xc3\x09\x00\x00\x08\x03\x00\x00\x28\x02\x00\x00\x49\x1e\x00\x00\x6a\x1e\x00\x00\xad\x1e\x00\x00\xe2\x1e\x00\x00\x28\x1f\x00\x00\x4b\x1f\x00\x00\x6e\x1f\x00\x00\xe1\x01\x00\x00\xee\x01\x00\x00\xef\x01\x00\x00\xf5\x01\x00\x00\x07\x02\x00\x00\x0c\x02\x00\x00\xae\x1f\x00\x00\x28\x20\x00\x00\xa2\x20\x00\x00\x1c\x21\x00\x00\x96\x21\x00\x00\x10\x22\x00\x00\x8a\x22\x00\x00\x04\x23\x00\x00\x7e\x23\x00\x00\xf8\x23\x00\x00\x32\x24\x00\x00\xac\x24\x00\x00\x26\x25\x00\x00\xa0\x25\x00\x00\x1a\x26\x00\x00\x94\x26\x00\x00\x0e\x27\x00\x00\x88\x27\x00\x00\x02\x28\x00\x00\x7c\x28\x00\x00\xd2\x12\x00\x00\x82\x09\x00\x00\xf6\x28\x00\x00\x70\x29\x00\x00\xea\x29\x00\x00\x00\x00\x00\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x02\x00\x00\x00\x00\x00\x00\x64\x2a\x00\x00\xe3\x01\x00\x00\xf2\x01\x00\x00\x90\x02\x00\x00\xf9\x01\x00\x00\x3c\x02\x00\x00\x83\x07\x00\x00\xfa\x01\x00\x00\x94\x02\x00\x00\x13\x02\x00\x00\x73\x02\x00\x00\xe2\x2a\x00\x00\x5c\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x2b\x00\x00\x00\x00\x00\x00\x52\x2c\x00\x00\x00\x00\x00\x00\xce\x2c\x00\x00\x00\x00\x00\x00\x4a\x2d\x00\x00\x00\x00\x00\x00\xc6\x2d\x00\x00\x00\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# + "\x00\x00\x6e\x01\x2f\x01\x3c\x00\x55\x01\x26\x01\xaf\x00\x78\x00\x55\x01\x55\x01\xac\x00\x56\x00\xaf\x00\xaf\x00\xaf\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x59\x01\x55\x01\x24\x00\x2b\x00\x30\x00\x31\x00\xaf\x00\x26\x01\xd9\x00\x2d\x00\x26\x01\x26\x01\x26\x01\xb1\x00\x53\x01\x4f\x01\x26\x01\x26\x01\x4c\x01\x25\x01\x26\x01\x26\x01\x23\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x24\x01\x4b\x01\x26\x01\x26\x01\x26\x01\x16\x00\x26\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x25\x00\x26\x01\x4d\x01\x26\x01\x32\x01\x4a\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x2a\x00\x22\x00\x48\x01\x26\x01\xaf\x00\x7a\x00\x1b\x00\x36\x00\xac\x00\x77\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x7a\x00\x55\x01\x1a\x00\xac\x00\x37\x00\xaf\x00\xaf\x00\xaf\x00\x39\x00\x55\x01\x3b\x00\xff\xff\xff\xff\x1a\x01\x55\x01\x67\x00\x55\x01\x63\x00\x28\x00\x66\x00\x72\x00\x97\x00\x6a\x00\xff\xff\x28\x00\x6c\x00\xaf\x00\xaf\x00\x7a\x00\x6d\x00\x96\x00\xac\x00\x59\x00\xaf\x00\xaf\x00\xaf\x00\x70\x00\x6e\x00\x6f\x00\x96\x00\xff\xff\x71\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x68\x00\x75\x00\xaf\x00\xaf\x00\x7a\x00\x1b\x01\xa9\x00\xac\x00\x59\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x7a\x00\x74\x00\x96\x00\xac\x00\x59\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x7a\x00\x94\x00\x28\x00\xac\x00\x76\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xff\xff\xca\x00\x1b\x01\xca\x00\xca\x00\xca\x00\x27\x00\xca\x00\xaf\x00\x2c\x00\x28\x00\x1b\x01\x96\x00\x8c\x00\xc9\x00\xca\x00\x28\x00\xaf\x00\x3b\x00\xca\x00\xca\x00\x96\x00\xce\x00\x28\x00\x8d\x00\xaa\x00\xca\x00\xca\x00\xca\x00\xff\xff\x96\x00\xaf\x00\x7a\x00\x97\x00\xaa\x00\xac\x00\xb4\x00\xaf\x00\xaf\x00\xaf\x00\xff\xff\xca\x00\xff\xff\xff\xff\x73\x00\x46\x00\x79\x00\xca\x00\x6b\x00\x48\x00\xff\xff\x46\x00\x46\x00\x46\x00\xff\xff\x9b\x00\xff\xff\xff\xff\xaf\x00\x20\x00\xb4\x00\x9b\x00\x62\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x28\x00\xa5\x00\xb4\x00\x96\x00\x46\x00\xb4\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\xb4\x00\x44\x00\x20\x00\xaf\x00\x7a\x00\xbb\x00\x62\x00\xac\x00\xa5\x00\xaf\x00\xaf\x00\xaf\x00\x1a\x01\x40\x00\x28\x00\x62\x00\x57\x00\x40\x00\xb4\x00\x40\x00\x40\x00\x40\x00\xb4\x00\xb4\x00\xaa\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x9b\x00\xaf\x00\xaf\x00\x7a\x00\xb4\x00\xff\xff\xac\x00\xb4\x00\xaf\x00\xaf\x00\xaf\x00\x40\x00\xb4\x00\x41\x00\x96\x00\xb4\x00\xff\xff\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\xba\x00\xb4\x00\xaf\x00\x9b\x00\x9a\x00\x38\x00\x55\x01\xb4\x00\xbb\x00\xaa\x00\x9a\x00\x9f\x00\xc8\x00\xbb\x00\x45\x00\x3a\x00\xca\x00\xb4\x00\xca\x00\xc9\x00\xa2\x00\xb4\x00\xb4\x00\x43\x00\xca\x00\xca\x00\xca\x00\xb4\x00\xb4\x00\xb4\x00\x30\x01\x31\x01\xb6\x00\xbf\x00\xaf\x00\x7a\x00\x17\x01\xba\x00\xac\x00\x56\x00\xaf\x00\xaf\x00\xaf\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\xaf\x00\x9a\x00\x58\x00\x2f\x00\xaa\x00\xce\x00\xd5\x00\xda\x00\x50\x01\x4f\x01\xd7\x00\xd5\x00\x4c\x01\x96\x00\xdc\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x8c\x00\xde\x00\x4b\x01\xe0\x00\x3e\x00\x18\x01\x9a\x00\xaa\x00\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x4e\x01\x19\x01\x4d\x01\x4a\x00\x31\x01\x4a\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x49\x01\x26\x01\x48\x01\x29\x01\x46\x00\xca\x00\xca\x00\xca\x00\xca\x00\xff\xff\x46\x00\x46\x00\x46\x00\xb4\x00\xa7\x00\xb8\x00\x2c\x01\x2a\x01\x4c\x00\xa0\x00\xc0\x00\xaf\x00\x4c\x00\x2c\x01\x4c\x00\x4c\x00\x4c\x00\xaf\x00\xaf\x00\xaf\x00\x26\x01\x46\x00\x26\x01\x26\x01\x26\x01\x26\x01\xf0\x00\x13\x01\x13\x01\x26\x01\x26\x01\x2d\x01\x26\x01\x26\x01\x26\x01\x4c\x00\x2e\x01\x4d\x00\xaf\x00\x13\x01\x13\x01\x64\x00\xab\x00\x55\x01\xd4\x00\x26\x01\x8c\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x55\x01\xd1\x00\x52\x01\x20\x00\x55\x01\x55\x01\x00\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x14\x01\x55\x01\x00\x00\x20\x01\x20\x01\x26\x01\x21\x00\x26\x01\x20\x00\x00\x00\x55\x01\x00\x00\x14\x01\x00\x00\x55\x01\x55\x01\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x59\x01\x1e\x00\x19\x00\x1c\x00\x5d\x01\x58\x01\x18\x00\x56\x01\x1d\x00\xaf\x00\x21\x01\x00\x00\x17\x00\x00\x00\x5a\x01\xaf\x00\xaf\x00\xaf\x00\x56\x01\x5b\x01\x1a\x00\x56\x01\x1d\x00\x83\x00\x00\x00\xca\x00\xcc\x00\x90\x00\x55\x01\x63\x01\x11\x00\xd3\x00\x86\x00\x55\x01\x55\x01\x00\x00\xaf\x00\xca\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x8a\x00\xca\x00\x00\x00\x55\x01\x10\x00\x91\x00\x87\x00\x55\x01\x00\x00\x55\x01\x8d\x00\x55\x01\x00\x00\x0f\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x5f\x01\x27\x00\x1a\x00\x00\x00\x29\x00\x28\x00\x55\x01\x57\x01\x1d\x00\x5c\x01\x00\x00\x28\x00\x5e\x01\x14\x00\x00\x00\x00\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x28\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\xf4\x00\x0e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x28\x00\x00\x00\x00\x00\x00\x00\x20\x01\x20\x01\x13\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x5a\x00\x12\x00\x65\x01\x00\x00\x00\x00\x00\x00\x0e\x01\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x21\x01\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x61\x01\x00\x00\x26\x01\x65\x01\x00\x00\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x26\x01\x26\x01\xb5\x00\x26\x01\x26\x01\x26\x01\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x61\x01\x26\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x65\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\xb4\x00\xc9\x00\x62\x01\x26\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x00\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x12\x00\x67\x01\x00\x00\x44\x01\x00\x00\x00\x00\x00\x00\x44\x01\x44\x01\x44\x01\x44\x01\x44\x01\x00\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x23\x00\x26\x01\x44\x01\x83\x00\x00\x00\x35\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\x00\x00\x00\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x69\x00\x26\x01\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x43\x01\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x6b\x01\xb0\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x6d\x01\x67\x01\x67\x01\x67\x01\x69\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x26\x00\x52\x00\x52\x00\x52\x00\x00\x00\x51\x00\xc9\x00\x52\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\xf8\x00\x00\x00\x51\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x50\x00\x50\x00\x50\x00\x00\x00\x4f\x00\x00\x00\x50\x00\x00\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x60\x01\x60\x01\x60\x01\x26\x01\x00\x00\xff\x00\x60\x01\xff\x00\x00\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x00\x00\x26\x01\x55\x01\x26\x01\x26\x01\x26\x01\x26\x01\x60\x01\x00\x00\x51\x01\x26\x01\x26\x01\x00\x00\x2e\x00\x26\x01\x26\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x00\x00\x26\x01\x00\x00\x26\x01\x60\x01\x26\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x26\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x33\x00\x33\x00\x33\x00\xdb\x00\x32\x00\x00\x00\x33\x00\x00\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x00\x00\x00\x00\x00\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\x00\x00\x26\x01\x05\x01\x26\x01\x05\x01\x32\x00\x12\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x00\x00\x00\x00\x26\x01\x31\x00\x26\x01\x00\x00\x69\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0c\x01\x0e\x01\x0c\x01\x00\x00\x00\x00\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x00\x00\x00\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x01\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x27\x00\x2c\x01\x00\x00\x54\x00\x28\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x28\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x28\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x00\x00\x55\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x01\x55\x01\x00\x00\x00\x00\x0a\x01\x1f\x00\x15\x00\x2c\x01\x00\x00\x00\x00\x1b\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x36\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x36\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x40\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x40\x00\x40\x00\x40\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\xe1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x0e\x01\x00\x00\x00\x00\x06\x01\x00\x00\x00\x00\x00\x00\x41\x00\x41\x00\x41\x00\x41\x00\x00\x00\x41\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x41\x00\x41\x00\x42\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x00\x00\x41\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x41\x00\x42\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x53\x00\x53\x00\x53\x00\xdd\x00\x45\x00\x00\x00\x53\x00\x00\x00\x45\x00\x54\x00\x45\x00\x45\x00\x45\x00\x00\x00\x00\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x01\x45\x00\x00\x00\x00\x00\x44\x01\x44\x01\x44\x01\x44\x01\x44\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x44\x01\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x65\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x37\x01\x3d\x01\x00\x00\x28\x01\x53\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x28\x01\x00\x00\x28\x01\x28\x01\x28\x01\x28\x01\x00\x00\x00\x00\x00\x00\x28\x01\x28\x01\x00\x00\x28\x01\x28\x01\x28\x01\x00\x00\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x00\x00\x27\x01\x00\x00\x28\x01\x28\x01\x28\x01\x28\x01\x28\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x00\x00\x28\x01\x00\x00\x28\x01\x3d\x01\x1f\x01\x3d\x01\x3d\x01\x3d\x01\x3e\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3f\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x4c\x00\x28\x01\x00\x00\x28\x01\x4c\x00\x00\x00\x4c\x00\x4c\x00\x4c\x00\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x00\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x0a\x01\x00\x00\x00\x00\x08\x01\x00\x00\x00\x00\x00\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4d\x00\x4d\x00\x4e\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x4d\x00\x4e\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x50\x00\x50\x00\x50\x00\xdf\x00\x4f\x00\x00\x00\x50\x00\x00\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\xe1\x00\x32\x00\x00\x00\x50\x00\x00\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x00\x00\x00\x00\x00\x00\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x52\x00\x52\x00\x52\x00\x00\x00\x51\x00\x00\x00\x52\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\xef\x00\x32\x00\x00\x00\x52\x00\x00\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x00\x00\x00\x00\x00\x00\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x01\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\xff\xff\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x55\x00\x55\x00\x55\x00\xf3\x00\x54\x00\x00\x00\x55\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x01\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x81\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x26\x01\x26\x01\x26\x01\x93\x00\x26\x01\x26\x01\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x26\x01\x26\x01\x00\x00\x93\x00\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x95\x00\x49\x00\x49\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x49\x00\x26\x01\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x00\x00\x95\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\x98\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x98\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x00\x00\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xae\x00\xae\x00\xae\x00\xae\x00\x00\x00\xae\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\x00\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x0c\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xb2\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xc7\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb3\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xd6\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xc4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb3\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xd6\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xc4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb5\x00\xc5\x00\x00\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x43\x01\x00\x00\x00\x00\x00\x00\xb7\x00\xbc\x00\xb9\x00\xa1\x00\xa6\x00\xbd\x00\xa8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xa4\x00\xc6\x00\x00\x00\x00\x00\xa8\x00\xa3\x00\x00\x00\xa8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xc1\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\xb4\x00\xc2\x00\xca\x00\x00\x00\xb4\x00\x00\x00\xb4\x00\x00\x00\xb4\x00\x00\x00\xc3\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x8b\x00\x8e\x00\xd2\x00\xcd\x00\x89\x00\xcb\x00\x90\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcb\x00\xd0\x00\x00\x00\xcb\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x85\x00\x00\x00\x00\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb3\x00\xb4\x00\xca\x00\x84\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\x00\x00\xca\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xd8\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xc4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x09\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x00\x00\xfb\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\xf1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x5f\x00\x00\x00\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x0a\x01\x10\x01\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x5f\x00\x00\x00\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x14\x01\x00\x00\x0a\x01\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x14\x01\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\xf5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x5b\x00\x00\x00\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x00\x0e\x01\x1d\x01\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x5b\x00\x00\x00\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x21\x01\x00\x00\x0e\x01\x0e\x01\x00\x00\x24\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x21\x01\x00\x00\x24\x01\x0e\x01\x24\x01\x24\x01\x24\x01\x24\x01\x00\x00\x00\x00\x00\x00\x24\x01\x24\x01\x1f\x01\x24\x01\x24\x01\x24\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x01\x00\x00\x00\x00\x00\x00\x26\x01\x24\x01\x00\x00\x24\x01\x24\x01\x24\x01\x24\x01\x24\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x24\x01\x00\x00\x24\x01\x26\x01\x26\x01\x00\x00\x92\x00\x26\x01\x26\x01\x16\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x01\x00\x00\x24\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x27\x01\x00\x00\x00\x00\x26\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x27\x01\x00\x00\x27\x01\x27\x01\x27\x01\x27\x01\x28\x01\x00\x00\x00\x00\x27\x01\x27\x01\x00\x00\x27\x01\x27\x01\x27\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x27\x01\x26\x01\x27\x01\x27\x01\x27\x01\x27\x01\x27\x01\x00\x00\x00\x00\x00\x00\x28\x01\x00\x00\x28\x01\x28\x01\x28\x01\x28\x01\x00\x00\x00\x00\x00\x00\x28\x01\x28\x01\x00\x00\x28\x01\x28\x01\x28\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x27\x01\x28\x01\x27\x01\x28\x01\x28\x01\x28\x01\x28\x01\x28\x01\x2f\x01\x2f\x01\x2f\x01\x00\x00\x00\x00\x00\x00\x2f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x01\x00\x00\x27\x01\x28\x01\x00\x00\x28\x01\x00\x00\x00\x00\x00\x00\x00\x00\x29\x01\x00\x00\x00\x00\x00\x00\x2f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x00\x00\x00\x00\x28\x01\x00\x00\x28\x01\x00\x00\x00\x00\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x01\x00\x00\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x30\x01\x30\x01\x30\x01\x00\x00\x00\x00\x00\x00\x30\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x01\x00\x00\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x00\x00\x00\x00\x00\x00\x00\x00\x30\x01\x00\x00\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x31\x01\x31\x01\x31\x01\x00\x00\x00\x00\x00\x00\x31\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x00\x00\x00\x00\x00\x00\x00\x00\x31\x01\x00\x00\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x01\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x01\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x01\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x01\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x01\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x01\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x01\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x36\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x36\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x01\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x0c\x01\x00\x00\x0c\x01\x00\x00\x00\x00\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x37\x01\x37\x01\x37\x01\x00\x00\x00\x00\x00\x00\x37\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x01\x00\x00\x00\x00\x00\x00\x37\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x00\x00\x00\x00\x00\x00\x00\x00\x37\x01\x00\x00\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x38\x01\x38\x01\x38\x01\x00\x00\x00\x00\x00\x00\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x01\x00\x00\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x00\x00\x38\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x38\x01\x00\x00\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3b\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3c\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x46\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x41\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x47\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x45\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x40\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x42\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x01\x55\x01\x54\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x0e\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x60\x01\x60\x01\x60\x01\x00\x00\x00\x00\x00\x00\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x60\x01\x00\x00\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x61\x01\x61\x01\x61\x01\x00\x00\x00\x00\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x00\x00\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x65\x01\x65\x01\x65\x01\x00\x00\x00\x00\x00\x00\x65\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x00\x00\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x00\x00\x64\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x66\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x68\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x6a\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x6c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# + "\xff\xff\x7c\x00\x01\x00\x02\x00\x42\x00\x04\x00\x05\x00\x06\x00\x42\x00\x46\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x4c\x00\x4e\x00\x54\x00\x58\x00\x43\x00\x58\x00\x7c\x00\x2d\x00\x2d\x00\x7d\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\x06\x00\x41\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x46\x00\x45\x00\x09\x00\x7d\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x52\x00\x7d\x00\x0a\x00\x0a\x00\x2d\x00\x53\x00\x0a\x00\x53\x00\x20\x00\x24\x00\x21\x00\x23\x00\x2d\x00\x0a\x00\x0a\x00\x2a\x00\x72\x00\x20\x00\x05\x00\x06\x00\x61\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x61\x00\x67\x00\x6d\x00\x2d\x00\x0a\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x21\x00\x6e\x00\x20\x00\x05\x00\x06\x00\x23\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x69\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x2d\x00\x5e\x00\x09\x00\x65\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x0a\x00\x42\x00\x23\x00\x46\x00\x42\x00\x4e\x00\x20\x00\x46\x00\x20\x00\x23\x00\x24\x00\x23\x00\x2d\x00\x45\x00\x27\x00\x54\x00\x2a\x00\x20\x00\x7d\x00\x4c\x00\x53\x00\x2d\x00\x43\x00\x7c\x00\x41\x00\x7b\x00\x58\x00\x53\x00\x58\x00\x0a\x00\x2d\x00\x05\x00\x06\x00\x2d\x00\x7b\x00\x09\x00\x43\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x52\x00\x0a\x00\x0a\x00\x6c\x00\x05\x00\x06\x00\x48\x00\x70\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x24\x00\x0a\x00\x0a\x00\x20\x00\x05\x00\x45\x00\x2a\x00\x7b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x5e\x00\x41\x00\x4b\x00\x2d\x00\x20\x00\x51\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x53\x00\x2d\x00\x20\x00\x05\x00\x06\x00\x55\x00\x7b\x00\x09\x00\x43\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x05\x00\x7c\x00\x7b\x00\x7c\x00\x09\x00\x58\x00\x0b\x00\x0c\x00\x0d\x00\x54\x00\x4e\x00\x7b\x00\x31\x00\x32\x00\x33\x00\x34\x00\x5e\x00\x20\x00\x05\x00\x06\x00\x4c\x00\x0a\x00\x09\x00\x46\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x42\x00\x22\x00\x2d\x00\x46\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x41\x00\x53\x00\x20\x00\x7c\x00\x24\x00\x23\x00\x5c\x00\x42\x00\x45\x00\x7b\x00\x2a\x00\x43\x00\x23\x00\x45\x00\x23\x00\x2d\x00\x53\x00\x52\x00\x51\x00\x27\x00\x4c\x00\x49\x00\x53\x00\x7b\x00\x4b\x00\x45\x00\x43\x00\x4f\x00\x50\x00\x58\x00\x01\x00\x02\x00\x54\x00\x55\x00\x05\x00\x06\x00\x6e\x00\x59\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x20\x00\x5e\x00\x65\x00\x23\x00\x7b\x00\x41\x00\x23\x00\x23\x00\x28\x00\x29\x00\x22\x00\x23\x00\x2c\x00\x2d\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x55\x00\x23\x00\x3b\x00\x23\x00\x5f\x00\x69\x00\x7c\x00\x7b\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x6c\x00\x5d\x00\x5f\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x04\x00\x7d\x00\x23\x00\x05\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x4d\x00\x4e\x00\x4f\x00\x23\x00\x23\x00\x05\x00\x53\x00\x54\x00\x05\x00\x09\x00\x23\x00\x0b\x00\x0c\x00\x0d\x00\x0b\x00\x0c\x00\x0d\x00\x21\x00\x20\x00\x23\x00\x24\x00\x25\x00\x26\x00\x23\x00\x30\x00\x31\x00\x2a\x00\x2b\x00\x23\x00\x2d\x00\x2e\x00\x2f\x00\x20\x00\x23\x00\x22\x00\x20\x00\x30\x00\x31\x00\x23\x00\x2d\x00\x53\x00\x43\x00\x3a\x00\x45\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x45\x00\x4c\x00\x23\x00\x05\x00\x51\x00\x4b\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\x43\x00\xff\xff\x30\x00\x31\x00\x5c\x00\x5d\x00\x5e\x00\x20\x00\xff\xff\x22\x00\xff\xff\x5f\x00\xff\xff\x26\x00\x27\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x05\x00\x5f\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\x0b\x00\x0c\x00\x0d\x00\x52\x00\x53\x00\x55\x00\x55\x00\x56\x00\x5f\x00\xff\xff\x4d\x00\x4e\x00\x4f\x00\x5c\x00\x7c\x00\x5e\x00\x53\x00\x54\x00\x61\x00\x62\x00\xff\xff\x20\x00\x49\x00\x66\x00\x31\x00\x32\x00\x33\x00\x34\x00\x4f\x00\x50\x00\xff\xff\x6e\x00\x6f\x00\x54\x00\x55\x00\x72\x00\xff\xff\x74\x00\x59\x00\x76\x00\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x43\x00\x20\x00\x45\x00\xff\xff\x23\x00\x24\x00\x4d\x00\x4e\x00\x4f\x00\x4c\x00\xff\xff\x2a\x00\x53\x00\x54\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\x5e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\x23\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x7c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5f\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x05\x00\x2d\x00\x2e\x00\x2f\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x5f\x00\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x5c\x00\x27\x00\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\x20\x00\x5f\x00\xff\xff\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7c\x00\x5f\x00\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x5f\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x27\x00\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x2b\x00\x07\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x5c\x00\x2b\x00\x5e\x00\x2d\x00\x20\x00\x5f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2b\x00\x45\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\x20\x00\x23\x00\xff\xff\x23\x00\x24\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x5e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x7c\x00\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\xff\xff\xff\xff\x45\x00\x54\x00\x55\x00\x23\x00\xff\xff\xff\xff\x59\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x45\x00\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x05\x00\x20\x00\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x5f\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x05\x00\x7c\x00\xff\xff\x7e\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x45\x00\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x05\x00\x06\x00\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\x4e\x00\x06\x00\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\x6e\x00\x6f\x00\x27\x00\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\x76\x00\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x6e\x00\x6f\x00\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\x76\x00\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x45\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x42\x00\xff\xff\x65\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x45\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x42\x00\xff\xff\x65\x00\x45\x00\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\x21\x00\x65\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x6f\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\x04\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x5c\x00\xff\xff\x5e\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# + "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x49\x00\x49\x00\x49\x00\xff\xff\x49\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\x68\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\x9e\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9d\x00\x99\x00\x9d\x00\x99\x00\xff\xff\x9d\x00\x99\x00\x99\x00\x9c\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0 :: Int, 366) + [ AlexAccNone + , AlexAcc 210 + , AlexAccNone + , AlexAcc 209 + , AlexAcc 208 + , AlexAcc 207 + , AlexAcc 206 + , AlexAcc 205 + , AlexAcc 204 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 203 (ifExtension ThQuotesBit)(AlexAccPred 202 (ifExtension QqBit)(AlexAccNone)) + , AlexAcc 201 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 200 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 199 + , AlexAcc 198 + , AlexAcc 197 + , AlexAcc 196 + , AlexAcc 195 + , AlexAcc 194 + , AlexAccNone + , AlexAccPred 193 (ifExtension HaddockBit)(AlexAccNone) + , AlexAcc 192 + , AlexAcc 191 + , AlexAccPred 190 (isNormalComment)(AlexAccNone) + , AlexAcc 189 + , AlexAcc 188 + , AlexAcc 187 + , AlexAccNone + , AlexAccNone + , AlexAcc 186 + , AlexAccNone + , AlexAccPred 185 (known_pragma twoWordPrags)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 184 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 183 + , AlexAcc 182 + , AlexAcc 181 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 180 + , AlexAcc 179 + , AlexAcc 178 + , AlexAcc 177 + , AlexAccSkip + , AlexAccNone + , AlexAcc 176 + , AlexAcc 175 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 174 + , AlexAccNone + , AlexAccPred 173 (known_pragma linePrags)(AlexAccPred 172 (known_pragma oneWordPrags)(AlexAccPred 171 (known_pragma ignoredPrags)(AlexAccPred 170 (known_pragma fileHeaderPrags)(AlexAcc 169)))) + , AlexAccNone + , AlexAccPred 168 (known_pragma linePrags)(AlexAccPred 167 (known_pragma oneWordPrags)(AlexAccPred 166 (known_pragma ignoredPrags)(AlexAccPred 165 (known_pragma fileHeaderPrags)(AlexAcc 164)))) + , AlexAccPred 163 (known_pragma linePrags)(AlexAcc 162) + , AlexAccNone + , AlexAccPred 161 (known_pragma linePrags)(AlexAccNone) + , AlexAcc 160 + , AlexAccPred 159 (notFollowedBySymbol)(AlexAccNone) + , AlexAccPred 158 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccSkip + , AlexAccNone + , AlexAccNone + , AlexAcc 157 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 156 (negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccPred 155 (notFollowedBy '-')(AlexAccNone) + , AlexAccSkip + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccPred 154 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False) `alexAndPred` followedByDigit)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 153 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccSkip + , AlexAccPred 152 (isSmartQuote)(AlexAccPred 151 (ifCurrentChar '⟦' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ThQuotesBit)(AlexAccPred 150 (ifCurrentChar '⟧' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ThQuotesBit)(AlexAccPred 149 (ifCurrentChar '⦇' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ArrowsBit)(AlexAccPred 148 (ifCurrentChar '⦈' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ArrowsBit)(AlexAccNone))))) + , AlexAccPred 147 (isSmartQuote)(AlexAcc 146) + , AlexAccPred 145 (isSmartQuote)(AlexAccNone) + , AlexAccPred 144 (atEOL)(AlexAcc 143) + , AlexAccPred 142 (atEOL)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 141 (atEOL)(AlexAcc 140) + , AlexAccPred 139 (atEOL)(AlexAcc 138) + , AlexAccPred 137 (atEOL)(AlexAcc 136) + , AlexAccPred 135 (atEOL)(AlexAcc 134) + , AlexAccNone + , AlexAccPred 133 (atEOL)(AlexAccNone) + , AlexAccPred 132 (atEOL)(AlexAccNone) + , AlexAcc 131 + , AlexAccPred 130 (alexNotPred (ifExtension HaddockBit))(AlexAccPred 129 (ifExtension HaddockBit)(AlexAccNone)) + , AlexAccPred 128 (alexNotPred (ifExtension HaddockBit))(AlexAcc 127) + , AlexAccPred 126 (alexNotPred (ifExtension HaddockBit))(AlexAccNone) + , AlexAcc 125 + , AlexAcc 124 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 123 (isNormalComment)(AlexAcc 122) + , AlexAccNone + , AlexAccPred 121 (isNormalComment)(AlexAccNone) + , AlexAcc 120 + , AlexAccNone + , AlexAccSkip + , AlexAccSkip + , AlexAccNone + , AlexAccPred 119 (alexRightContext 173)(AlexAccNone) + , AlexAcc 118 + , AlexAccPred 117 (isSmartQuote)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 116 (isSmartQuote)(AlexAccNone) + , AlexAccPred 115 (isSmartQuote)(AlexAccNone) + , AlexAccNone + , AlexAccPred 114 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAcc 113 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 112 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAcc 111 + , AlexAccPred 110 (ifExtension MultilineStringsBit)(AlexAccNone) + , AlexAcc 109 + , AlexAccNone + , AlexAccPred 108 (ifExtension HexFloatLiteralsBit `alexAndPred` negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 107 (ifExtension HexFloatLiteralsBit `alexAndPred` negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 106 (ifExtension MagicHashBit `alexAndPred` ifExtension HexFloatLiteralsBit)(AlexAccNone) + , AlexAccPred 105 (ifExtension MagicHashBit `alexAndPred` ifExtension HexFloatLiteralsBit)(AlexAccNone) + , AlexAccPred 104 (negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 103 (negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 102 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 101 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 100 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 99 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 98 (negHashLitPred ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccPred 97 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 96 (ifExtension ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 95 (ifExtension ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 94 (ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccPred 93 (ifExtension ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 92 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 91 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 90 (ifExtension MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccPred 89 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 88 (negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 87 (negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 86 (negHashLitPred MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccPred 85 (negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 84 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 83 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 82 (ifExtension MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccPred 81 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 80 (ifExtension HexFloatLiteralsBit `alexAndPred` + negLitPred)(AlexAccNone) + , AlexAccPred 79 (ifExtension HexFloatLiteralsBit `alexAndPred` + negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 78 (ifExtension HexFloatLiteralsBit)(AlexAccNone) + , AlexAccPred 77 (ifExtension HexFloatLiteralsBit)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 76 (negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 75 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 74 (negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccPred 73 (negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccPred 72 (negLitPred `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccNone + , AlexAccPred 71 (negLitPred)(AlexAccNone) + , AlexAccPred 70 (negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 69 (isNormalComment)(AlexAccNone) + , AlexAccPred 68 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAcc 67 + , AlexAccNone + , AlexAcc 66 + , AlexAccNone + , AlexAccPred 65 (ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccNone + , AlexAcc 64 + , AlexAcc 63 + , AlexAcc 62 + , AlexAcc 61 + , AlexAcc 60 + , AlexAcc 59 + , AlexAcc 58 + , AlexAccPred 57 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 56 (ifExtension MagicHashBit)(AlexAccPred 55 (ifExtension MagicHashBit)(AlexAccNone)) + , AlexAccPred 54 (ifExtension MagicHashBit)(AlexAccPred 53 (ifExtension MagicHashBit)(AlexAccNone)) + , AlexAccPred 52 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 51 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 50 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAcc 49 + , AlexAcc 48 + , AlexAcc 47 + , AlexAcc 46 + , AlexAcc 45 + , AlexAcc 44 + , AlexAcc 43 + , AlexAcc 42 + , AlexAcc 41 + , AlexAcc 40 + , AlexAccNone + , AlexAcc 39 + , AlexAcc 38 + , AlexAcc 37 + , AlexAcc 36 + , AlexAcc 35 + , AlexAcc 34 + , AlexAccPred 33 (ifExtension RecursiveDoBit)(AlexAcc 32) + , AlexAcc 31 + , AlexAccPred 30 (ifExtension RecursiveDoBit)(AlexAcc 29) + , AlexAccNone + , AlexAccNone + , AlexAcc 28 + , AlexAcc 27 + , AlexAcc 26 + , AlexAcc 25 + , AlexAcc 24 + , AlexAcc 23 + , AlexAcc 22 + , AlexAcc 21 + , AlexAcc 20 + , AlexAcc 19 + , AlexAcc 18 + , AlexAcc 17 + , AlexAccPred 16 (ifExtension UnboxedParensBit)(AlexAccNone) + , AlexAccPred 15 (ifExtension UnboxedParensBit)(AlexAccNone) + , AlexAcc 14 + , AlexAccPred 13 (ifExtension OverloadedLabelsBit)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 12 (ifExtension OverloadedLabelsBit)(AlexAccNone) + , AlexAccPred 11 (ifExtension IpBit)(AlexAccNone) + , AlexAccPred 10 (ifExtension ArrowsBit)(AlexAccNone) + , AlexAccPred 9 (ifExtension ArrowsBit `alexAndPred` + notFollowedBySymbol)(AlexAccNone) + , AlexAccPred 8 (ifExtension QqBit)(AlexAccNone) + , AlexAccNone + , AlexAccPred 7 (ifExtension QqBit)(AlexAccNone) + , AlexAccNone + , AlexAccPred 6 (ifExtension ThQuotesBit)(AlexAccPred 5 (ifExtension QqBit)(AlexAccNone)) + , AlexAccNone + , AlexAccPred 4 (ifExtension ThQuotesBit)(AlexAccPred 3 (ifExtension QqBit)(AlexAccNone)) + , AlexAccNone + , AlexAccPred 2 (ifExtension ThQuotesBit)(AlexAccPred 1 (ifExtension QqBit)(AlexAccNone)) + , AlexAccNone + , AlexAccPred 0 (ifExtension ThQuotesBit)(AlexAccNone) + ] + +alex_actions = array (0 :: Int, 211) + [ (210,alex_action_16) + , (209,alex_action_22) + , (208,alex_action_23) + , (207,alex_action_21) + , (206,alex_action_24) + , (205,alex_action_28) + , (204,alex_action_29) + , (203,alex_action_47) + , (202,alex_action_52) + , (201,alex_action_86) + , (200,alex_action_86) + , (199,alex_action_46) + , (198,alex_action_86) + , (197,alex_action_45) + , (196,alex_action_44) + , (195,alex_action_67) + , (194,alex_action_43) + , (193,alex_action_42) + , (192,alex_action_40) + , (191,alex_action_72) + , (190,alex_action_2) + , (189,alex_action_40) + , (188,alex_action_86) + , (187,alex_action_86) + , (186,alex_action_36) + , (185,alex_action_33) + , (184,alex_action_32) + , (183,alex_action_31) + , (182,alex_action_78) + , (181,alex_action_78) + , (180,alex_action_30) + , (179,alex_action_29) + , (178,alex_action_29) + , (177,alex_action_29) + , (176,alex_action_1) + , (175,alex_action_29) + , (174,alex_action_27) + , (173,alex_action_26) + , (172,alex_action_34) + , (171,alex_action_35) + , (170,alex_action_38) + , (169,alex_action_39) + , (168,alex_action_26) + , (167,alex_action_34) + , (166,alex_action_35) + , (165,alex_action_37) + , (164,alex_action_39) + , (163,alex_action_26) + , (162,alex_action_29) + , (161,alex_action_26) + , (160,alex_action_25) + , (159,alex_action_20) + , (158,alex_action_19) + , (157,alex_action_96) + , (156,alex_action_97) + , (155,alex_action_17) + , (154,alex_action_12) + , (153,alex_action_11) + , (152,alex_action_9) + , (151,alex_action_54) + , (150,alex_action_55) + , (149,alex_action_58) + , (148,alex_action_59) + , (147,alex_action_9) + , (146,alex_action_29) + , (145,alex_action_9) + , (144,alex_action_8) + , (143,alex_action_29) + , (142,alex_action_8) + , (141,alex_action_7) + , (140,alex_action_86) + , (139,alex_action_7) + , (138,alex_action_86) + , (137,alex_action_7) + , (136,alex_action_29) + , (135,alex_action_7) + , (134,alex_action_29) + , (133,alex_action_7) + , (132,alex_action_7) + , (131,alex_action_6) + , (130,alex_action_5) + , (129,alex_action_41) + , (128,alex_action_5) + , (127,alex_action_29) + , (126,alex_action_5) + , (125,alex_action_4) + , (124,alex_action_3) + , (123,alex_action_2) + , (122,alex_action_29) + , (121,alex_action_2) + , (120,alex_action_1) + , (119,alex_action_137) + , (118,alex_action_136) + , (117,alex_action_135) + , (116,alex_action_134) + , (115,alex_action_133) + , (114,alex_action_132) + , (113,alex_action_131) + , (112,alex_action_130) + , (111,alex_action_129) + , (110,alex_action_128) + , (109,alex_action_129) + , (108,alex_action_127) + , (107,alex_action_126) + , (106,alex_action_125) + , (105,alex_action_124) + , (104,alex_action_123) + , (103,alex_action_122) + , (102,alex_action_121) + , (101,alex_action_120) + , (100,alex_action_119) + , (99,alex_action_118) + , (98,alex_action_117) + , (97,alex_action_116) + , (96,alex_action_115) + , (95,alex_action_114) + , (94,alex_action_113) + , (93,alex_action_112) + , (92,alex_action_111) + , (91,alex_action_110) + , (90,alex_action_109) + , (89,alex_action_108) + , (88,alex_action_107) + , (87,alex_action_106) + , (86,alex_action_105) + , (85,alex_action_104) + , (84,alex_action_103) + , (83,alex_action_102) + , (82,alex_action_101) + , (81,alex_action_100) + , (80,alex_action_99) + , (79,alex_action_99) + , (78,alex_action_98) + , (77,alex_action_98) + , (76,alex_action_97) + , (75,alex_action_96) + , (74,alex_action_95) + , (73,alex_action_94) + , (72,alex_action_93) + , (71,alex_action_92) + , (70,alex_action_92) + , (69,alex_action_2) + , (68,alex_action_19) + , (67,alex_action_91) + , (66,alex_action_90) + , (65,alex_action_89) + , (64,alex_action_88) + , (63,alex_action_88) + , (62,alex_action_87) + , (61,alex_action_86) + , (60,alex_action_86) + , (59,alex_action_85) + , (58,alex_action_84) + , (57,alex_action_83) + , (56,alex_action_82) + , (55,alex_action_121) + , (54,alex_action_82) + , (53,alex_action_120) + , (52,alex_action_82) + , (51,alex_action_81) + , (50,alex_action_80) + , (49,alex_action_79) + , (48,alex_action_79) + , (47,alex_action_78) + , (46,alex_action_78) + , (45,alex_action_78) + , (44,alex_action_78) + , (43,alex_action_78) + , (42,alex_action_78) + , (41,alex_action_77) + , (40,alex_action_77) + , (39,alex_action_76) + , (38,alex_action_76) + , (37,alex_action_76) + , (36,alex_action_76) + , (35,alex_action_76) + , (34,alex_action_76) + , (33,alex_action_75) + , (32,alex_action_76) + , (31,alex_action_76) + , (30,alex_action_75) + , (29,alex_action_76) + , (28,alex_action_76) + , (27,alex_action_74) + , (26,alex_action_74) + , (25,alex_action_73) + , (24,alex_action_72) + , (23,alex_action_71) + , (22,alex_action_70) + , (21,alex_action_69) + , (20,alex_action_68) + , (19,alex_action_67) + , (18,alex_action_66) + , (17,alex_action_65) + , (16,alex_action_64) + , (15,alex_action_63) + , (14,alex_action_65) + , (13,alex_action_62) + , (12,alex_action_61) + , (11,alex_action_60) + , (10,alex_action_57) + , (9,alex_action_56) + , (8,alex_action_53) + , (7,alex_action_52) + , (6,alex_action_51) + , (5,alex_action_52) + , (4,alex_action_50) + , (3,alex_action_52) + , (2,alex_action_49) + , (1,alex_action_52) + , (0,alex_action_48) + ] + + +bol,column_prag,layout,layout_do,layout_if,layout_left,line_prag1,line_prag1a,line_prag2,line_prag2a,option_prags :: Int +bol = 1 +column_prag = 2 +layout = 3 +layout_do = 4 +layout_if = 5 +layout_left = 6 +line_prag1 = 7 +line_prag1a = 8 +line_prag2 = 9 +line_prag2a = 10 +option_prags = 11 +alex_action_1 = warnTab +alex_action_2 = nested_comment +alex_action_3 = lineCommentToken +alex_action_4 = lineCommentToken +alex_action_5 = lineCommentToken +alex_action_6 = lineCommentToken +alex_action_7 = lineCommentToken +alex_action_8 = lineCommentToken +alex_action_9 = smart_quote_error +alex_action_11 = begin line_prag1 +alex_action_12 = begin line_prag1 +alex_action_16 = do_bol +alex_action_17 = hopefully_open_brace +alex_action_19 = begin line_prag1 +alex_action_20 = new_layout_context True dontGenerateSemic ITvbar +alex_action_21 = pop +alex_action_22 = new_layout_context True generateSemic ITvocurly +alex_action_23 = new_layout_context False generateSemic ITvocurly +alex_action_24 = do_layout_left +alex_action_25 = begin bol +alex_action_26 = dispatch_pragmas linePrags +alex_action_27 = setLineAndFile line_prag1a +alex_action_28 = failLinePrag1 +alex_action_29 = popLinePrag1 +alex_action_30 = setLineAndFile line_prag2a +alex_action_31 = pop +alex_action_32 = setColumn +alex_action_33 = dispatch_pragmas twoWordPrags +alex_action_34 = dispatch_pragmas oneWordPrags +alex_action_35 = dispatch_pragmas ignoredPrags +alex_action_36 = endPrag +alex_action_37 = dispatch_pragmas fileHeaderPrags +alex_action_38 = nested_comment +alex_action_39 = warn_unknown_prag (Map.unions [ oneWordPrags, fileHeaderPrags, ignoredPrags, linePrags ]) +alex_action_40 = warn_unknown_prag Map.empty +alex_action_41 = multiline_doc_comment +alex_action_42 = nested_doc_comment +alex_action_43 = token (ITopenExpQuote NoE NormalSyntax) +alex_action_44 = token (ITopenTExpQuote NoE) +alex_action_45 = token (ITcloseQuote NormalSyntax) +alex_action_46 = token ITcloseTExpQuote +alex_action_47 = token (ITopenExpQuote HasE NormalSyntax) +alex_action_48 = token (ITopenTExpQuote HasE) +alex_action_49 = token ITopenPatQuote +alex_action_50 = layout_token ITopenDecQuote +alex_action_51 = token ITopenTypQuote +alex_action_52 = lex_quasiquote_tok +alex_action_53 = lex_qquasiquote_tok +alex_action_54 = token (ITopenExpQuote NoE UnicodeSyntax) +alex_action_55 = token (ITcloseQuote UnicodeSyntax) +alex_action_56 = special (IToparenbar NormalSyntax) +alex_action_57 = special (ITcparenbar NormalSyntax) +alex_action_58 = special (IToparenbar UnicodeSyntax) +alex_action_59 = special (ITcparenbar UnicodeSyntax) +alex_action_60 = skip_one_varid ITdupipvarid +alex_action_61 = skip_one_varid_src ITlabelvarid +alex_action_62 = tok_quoted_label +alex_action_63 = token IToubxparen +alex_action_64 = token ITcubxparen +alex_action_65 = special IToparen +alex_action_66 = special ITcparen +alex_action_67 = special ITobrack +alex_action_68 = special ITcbrack +alex_action_69 = special ITcomma +alex_action_70 = special ITsemi +alex_action_71 = special ITbackquote +alex_action_72 = open_brace +alex_action_73 = close_brace +alex_action_74 = qdo_token ITdo +alex_action_75 = qdo_token ITmdo +alex_action_76 = idtoken qvarid +alex_action_77 = idtoken qconid +alex_action_78 = varid +alex_action_79 = idtoken conid +alex_action_80 = idtoken qvarid +alex_action_81 = idtoken qconid +alex_action_82 = varid +alex_action_83 = idtoken conid +alex_action_84 = idtoken qvarsym +alex_action_85 = idtoken qconsym +alex_action_86 = with_op_ws varsym +alex_action_87 = with_op_ws consym +alex_action_88 = tok_num positive 0 0 decimal +alex_action_89 = tok_num positive 2 2 binary +alex_action_90 = tok_num positive 2 2 octal +alex_action_91 = tok_num positive 2 2 hexadecimal +alex_action_92 = tok_num negative 1 1 decimal +alex_action_93 = tok_num negative 3 3 binary +alex_action_94 = tok_num negative 3 3 octal +alex_action_95 = tok_num negative 3 3 hexadecimal +alex_action_96 = tok_frac 0 tok_float +alex_action_97 = tok_frac 0 tok_float +alex_action_98 = tok_frac 0 tok_hex_float +alex_action_99 = tok_frac 0 tok_hex_float +alex_action_100 = tok_primint positive 0 1 decimal +alex_action_101 = tok_primint positive 2 3 binary +alex_action_102 = tok_primint positive 2 3 octal +alex_action_103 = tok_primint positive 2 3 hexadecimal +alex_action_104 = tok_primint negative 1 2 decimal +alex_action_105 = tok_primint negative 3 4 binary +alex_action_106 = tok_primint negative 3 4 octal +alex_action_107 = tok_primint negative 3 4 hexadecimal +alex_action_108 = tok_primword 0 2 decimal +alex_action_109 = tok_primword 2 4 binary +alex_action_110 = tok_primword 2 4 octal +alex_action_111 = tok_primword 2 4 hexadecimal +alex_action_112 = tok_prim_num_ext positive 0 decimal +alex_action_113 = tok_prim_num_ext positive 2 binary +alex_action_114 = tok_prim_num_ext positive 2 octal +alex_action_115 = tok_prim_num_ext positive 2 hexadecimal +alex_action_116 = tok_prim_num_ext negative 1 decimal +alex_action_117 = tok_prim_num_ext negative 3 binary +alex_action_118 = tok_prim_num_ext negative 3 octal +alex_action_119 = tok_prim_num_ext negative 3 hexadecimal +alex_action_120 = tok_frac 1 tok_primfloat +alex_action_121 = tok_frac 2 tok_primdouble +alex_action_122 = tok_frac 1 tok_primfloat +alex_action_123 = tok_frac 2 tok_primdouble +alex_action_124 = tok_frac 1 tok_prim_hex_float +alex_action_125 = tok_frac 2 tok_prim_hex_double +alex_action_126 = tok_frac 1 tok_prim_hex_float +alex_action_127 = tok_frac 2 tok_prim_hex_double +alex_action_128 = tok_string_multi +alex_action_129 = tok_string +alex_action_130 = tok_string +alex_action_131 = tok_char +alex_action_132 = tok_char +alex_action_133 = smart_quote_error +alex_action_134 = smart_quote_error +alex_action_135 = smart_quote_error +alex_action_136 = token ITtyQuote +alex_action_137 = token ITsimpleQuote + +#define ALEX_GHC 1 +#define ALEX_LATIN1 1 +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +#ifdef ALEX_GHC +# define ILIT(n) n# +# define IBOX(n) (I# (n)) +# define FAST_INT Int# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +# if __GLASGOW_HASKELL__ > 706 +# define GTE(n,m) (tagToEnum# (n >=# m)) +# define EQ(n,m) (tagToEnum# (n ==# m)) +# else +# define GTE(n,m) (n >=# m) +# define EQ(n,m) (n ==# m) +# endif +# define PLUS(n,m) (n +# m) +# define MINUS(n,m) (n -# m) +# define TIMES(n,m) (n *# m) +# define NEGATE(n) (negateInt# (n)) +# define IF_GHC(x) (x) +#else +# define ILIT(n) (n) +# define IBOX(n) (n) +# define FAST_INT Int +# define GTE(n,m) (n >= m) +# define EQ(n,m) (n == m) +# define PLUS(n,m) (n + m) +# define MINUS(n,m) (n - m) +# define TIMES(n,m) (n * m) +# define NEGATE(n) (negate (n)) +# define IF_GHC(x) +#endif + +#ifdef ALEX_GHC +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else +#if __GLASGOW_HASKELL__ >= 901 + int16ToInt# +#endif + (indexInt16OffAddr# arr off) +#endif +#else +alexIndexInt16OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else +#if __GLASGOW_HASKELL__ >= 901 + int32ToInt# +#endif + (indexInt32OffAddr# arr off) +#endif +#else +alexIndexInt32OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif +#else +quickIndex arr i = arr ! i +#endif + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ IBOX(sc) + = alexScanUser undefined input__ IBOX(sc) + +alexScanUser user__ input__ IBOX(sc) + = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> +#ifdef ALEX_DEBUG + trace ("End of input.") $ +#endif + AlexEOF + Just _ -> +#ifdef ALEX_DEBUG + trace ("Error.") $ +#endif + AlexError input__' + + (AlexLastSkip input__'' len, _) -> +#ifdef ALEX_DEBUG + trace ("Skipping.") $ +#endif + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> +#ifdef ALEX_DEBUG + trace ("Accept.") $ +#endif + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` IBOX(s))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> +#ifdef ALEX_DEBUG + trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $ +#endif + case fromIntegral c of { IBOX(ord_c) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = PLUS(base,ord_c) + + new_s = if GTE(offset,ILIT(0)) + && let check = alexIndexInt16OffAddr alex_check offset + in EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + ILIT(-1) -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input +#ifdef ALEX_LATIN1 + PLUS(len,ILIT(1)) + -- issue 119: in the latin1 encoding, *each* byte is one character +#else + (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) +#endif + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ IBOX(len) + check_accs (AlexAccSkip) = AlexLastSkip input__ IBOX(len) +#ifndef ALEX_NOPRED + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastAcc a input__ IBOX(len) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastSkip input__ IBOX(len) + | otherwise + = check_accs rest +#endif + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip +#ifndef ALEX_NOPRED + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext IBOX(sc) user__ _ _ input__ = + case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. +#endif +{-# LINE 762 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/Lexer.x" #-} +-- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. +data OpWs + = OpWsPrefix -- a !b + | OpWsSuffix -- a! b + | OpWsTightInfix -- a!b + | OpWsLooseInfix -- a ! b + deriving Show + +-- ----------------------------------------------------------------------------- +-- The token type + +data Token + = ITas -- Haskell keywords + | ITcase + | ITclass + | ITdata + | ITdefault + | ITderiving + | ITdo (Maybe FastString) + | ITelse + | IThiding + | ITforeign + | ITif + | ITimport + | ITin + | ITinfix + | ITinfixl + | ITinfixr + | ITinstance + | ITlet + | ITmodule + | ITnewtype + | ITof + | ITqualified + | ITthen + | ITtype + | ITwhere + + | ITforall IsUnicodeSyntax -- GHC extension keywords + | ITexport + | ITlabel + | ITdynamic + | ITsafe + | ITinterruptible + | ITunsafe + | ITstdcallconv + | ITccallconv + | ITcapiconv + | ITprimcallconv + | ITjavascriptcallconv + | ITmdo (Maybe FastString) + | ITfamily + | ITrole + | ITgroup + | ITby + | ITusing + | ITpattern + | ITstatic + | ITstock + | ITanyclass + | ITvia + + -- Backpack tokens + | ITunit + | ITsignature + | ITdependency + | ITrequires + + -- Pragmas, see Note [Pragma source text] in "GHC.Types.SourceText" + | ITinline_prag SourceText InlineSpec RuleMatchInfo + | ITopaque_prag SourceText + | ITspec_prag SourceText -- SPECIALISE + | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) + | ITsource_prag SourceText + | ITrules_prag SourceText + | ITwarning_prag SourceText + | ITdeprecated_prag SourceText + | ITline_prag SourceText -- not usually produced, see 'UsePosPragsBit' + | ITcolumn_prag SourceText -- not usually produced, see 'UsePosPragsBit' + | ITscc_prag SourceText + | ITunpack_prag SourceText + | ITnounpack_prag SourceText + | ITann_prag SourceText + | ITcomplete_prag SourceText + | ITclose_prag + | IToptions_prag String + | ITinclude_prag String + | ITlanguage_prag + | ITminimal_prag SourceText + | IToverlappable_prag SourceText -- instance overlap mode + | IToverlapping_prag SourceText -- instance overlap mode + | IToverlaps_prag SourceText -- instance overlap mode + | ITincoherent_prag SourceText -- instance overlap mode + | ITctype SourceText + | ITcomment_line_prag -- See Note [Nested comment line pragmas] + + | ITdotdot -- reserved symbols + | ITcolon + | ITdcolon IsUnicodeSyntax + | ITequal + | ITlam + | ITlcase + | ITlcases + | ITvbar + | ITlarrow IsUnicodeSyntax + | ITrarrow IsUnicodeSyntax + | ITdarrow IsUnicodeSyntax + | ITlolly -- The (⊸) arrow (for LinearTypes) + | ITminus -- See Note [Minus tokens] + | ITprefixminus -- See Note [Minus tokens] + | ITbang -- Prefix (!) only, e.g. f !x = rhs + | ITtilde -- Prefix (~) only, e.g. f ~x = rhs + | ITat -- Tight infix (@) only, e.g. f x@pat = rhs + | ITtypeApp -- Prefix (@) only, e.g. f @t + | ITpercent -- Prefix (%) only, e.g. a %1 -> b + | ITstar IsUnicodeSyntax + | ITdot + | ITproj Bool -- Extension: OverloadedRecordDotBit + + | ITbiglam -- GHC-extension symbols + + | ITocurly -- special symbols + | ITccurly + | ITvocurly + | ITvccurly + | ITobrack + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays + | ITcbrack + | IToparen + | ITcparen + | IToubxparen + | ITcubxparen + | ITsemi + | ITcomma + | ITunderscore + | ITbackquote + | ITsimpleQuote -- ' + + | ITvarid FastString -- identifiers + | ITconid FastString + | ITvarsym FastString + | ITconsym FastString + | ITqvarid (FastString,FastString) + | ITqconid (FastString,FastString) + | ITqvarsym (FastString,FastString) + | ITqconsym (FastString,FastString) + + | ITdupipvarid FastString -- GHC extension: implicit param: ?x + | ITlabelvarid SourceText FastString -- Overloaded label: #x + -- The SourceText is required because we can + -- have a string literal as a label + -- Note [Literal source text] in "GHC.Types.SourceText" + + | ITchar SourceText Char -- Note [Literal source text] in "GHC.Types.SourceText" + | ITstring SourceText FastString -- Note [Literal source text] in "GHC.Types.SourceText" + | ITstringMulti SourceText FastString -- Note [Literal source text] in "GHC.Types.SourceText" + | ITinteger IntegralLit -- Note [Literal source text] in "GHC.Types.SourceText" + | ITrational FractionalLit + + | ITprimchar SourceText Char -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimstring SourceText ByteString -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint8 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint16 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint32 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint64 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword8 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword16 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword32 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword64 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit + + -- Template Haskell extension tokens + | ITopenExpQuote HasE IsUnicodeSyntax -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote IsUnicodeSyntax -- |] + | ITopenTExpQuote HasE -- [|| or [e|| + | ITcloseTExpQuote -- ||] + | ITdollar -- prefix $ + | ITdollardollar -- prefix $$ + | ITtyQuote -- '' + | ITquasiQuote (FastString, PsSpan, FastString, PsSpan) + -- ITquasiQuote(quoter, quoter_loc, quote, quote_loc) + -- represents a quasi-quote of the form + -- [quoter| quote |] + | ITqQuasiQuote (FastString,FastString,PsSpan, FastString, PsSpan) + -- ITqQuasiQuote(Qual, quoter, quoter_loc, quote, quote_loc) + -- represents a qualified quasi-quote of the form + -- [Qual.quoter| quote |] + + | ITsplice + | ITquote + + -- Arrow notation extension + | ITproc + | ITrec + | IToparenbar IsUnicodeSyntax -- ^ @(|@ + | ITcparenbar IsUnicodeSyntax -- ^ @|)@ + | ITlarrowtail IsUnicodeSyntax -- ^ @-<@ + | ITrarrowtail IsUnicodeSyntax -- ^ @>-@ + | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@ + | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@ + + | ITunknown String -- ^ Used when the lexer can't make sense of it + | ITeof -- ^ end of file token + + -- Documentation annotations. See Note [PsSpan in Comments] + | ITdocComment HsDocString PsSpan -- ^ The HsDocString contains more details about what + -- this is and how to pretty print it + | ITdocOptions String PsSpan -- ^ doc options (prune, ignore-exports, etc) + | ITlineComment String PsSpan -- ^ comment starting by "--" + | ITblockComment String PsSpan -- ^ comment in {- -} + + deriving Show + +instance Outputable Token where + ppr x = text (show x) + +{- Note [PsSpan in Comments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When using the Api Annotations to exact print a modified AST, managing +the space before a comment is important. The PsSpan in the comment +token allows this to happen, and this location is tracked in prev_loc +in PState. This only tracks physical tokens, so is not updated for +zero-width ones. + +We also use this to track the space before the end-of-file marker. +-} + +{- Note [Minus tokens] +~~~~~~~~~~~~~~~~~~~~~~ +A minus sign can be used in prefix form (-x) and infix form (a - b). + +When LexicalNegation is on: + * ITprefixminus represents the prefix form + * ITvarsym "-" represents the infix form + * ITminus is not used + +When LexicalNegation is off: + * ITminus represents all forms + * ITprefixminus is not used + * ITvarsym "-" is not used +-} + +{- Note [Why not LexicalNegationBit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One might wonder why we define NoLexicalNegationBit instead of +LexicalNegationBit. The problem lies in the following line in reservedSymsFM: + + ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit) + +We want to generate ITminus only when LexicalNegation is off. How would one +do it if we had LexicalNegationBit? I (int-index) tried to use bitwise +complement: + + ,("-", ITminus, NormalSyntax, complement (xbit LexicalNegationBit)) + +This did not work, so I opted for NoLexicalNegationBit instead. +-} + + +-- the bitmap provided as the third component indicates whether the +-- corresponding extension keyword is valid under the extension options +-- provided to the compiler; if the extension corresponding to *any* of the +-- bits set in the bitmap is enabled, the keyword is valid (this setup +-- facilitates using a keyword in two different extensions that can be +-- activated independently) +-- +reservedWordsFM :: UniqFM FastString (Token, ExtsBitmap) +reservedWordsFM = listToUFM $ + map (\(x, y, z) -> (mkFastString x, (y, z))) + [( "_", ITunderscore, 0 ), + ( "as", ITas, 0 ), + ( "case", ITcase, 0 ), + ( "cases", ITlcases, xbit LambdaCaseBit ), + ( "class", ITclass, 0 ), + ( "data", ITdata, 0 ), + ( "default", ITdefault, 0 ), + ( "deriving", ITderiving, 0 ), + ( "do", ITdo Nothing, 0 ), + ( "else", ITelse, 0 ), + ( "hiding", IThiding, 0 ), + ( "if", ITif, 0 ), + ( "import", ITimport, 0 ), + ( "in", ITin, 0 ), + ( "infix", ITinfix, 0 ), + ( "infixl", ITinfixl, 0 ), + ( "infixr", ITinfixr, 0 ), + ( "instance", ITinstance, 0 ), + ( "let", ITlet, 0 ), + ( "module", ITmodule, 0 ), + ( "newtype", ITnewtype, 0 ), + ( "of", ITof, 0 ), + ( "qualified", ITqualified, 0 ), + ( "then", ITthen, 0 ), + ( "type", ITtype, 0 ), + ( "where", ITwhere, 0 ), + + ( "forall", ITforall NormalSyntax, 0), + ( "mdo", ITmdo Nothing, xbit RecursiveDoBit), + -- See Note [Lexing type pseudo-keywords] + ( "family", ITfamily, 0 ), + ( "role", ITrole, 0 ), + ( "pattern", ITpattern, xbit PatternSynonymsBit), + ( "static", ITstatic, xbit StaticPointersBit ), + ( "stock", ITstock, 0 ), + ( "anyclass", ITanyclass, 0 ), + ( "via", ITvia, 0 ), + ( "group", ITgroup, xbit TransformComprehensionsBit), + ( "by", ITby, xbit TransformComprehensionsBit), + ( "using", ITusing, xbit TransformComprehensionsBit), + + ( "foreign", ITforeign, xbit FfiBit), + ( "export", ITexport, xbit FfiBit), + ( "label", ITlabel, xbit FfiBit), + ( "dynamic", ITdynamic, xbit FfiBit), + ( "safe", ITsafe, xbit FfiBit .|. + xbit SafeHaskellBit), + ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), + ( "unsafe", ITunsafe, xbit FfiBit), + ( "stdcall", ITstdcallconv, xbit FfiBit), + ( "ccall", ITccallconv, xbit FfiBit), + ( "capi", ITcapiconv, xbit CApiFfiBit), + ( "prim", ITprimcallconv, xbit FfiBit), + ( "javascript", ITjavascriptcallconv, xbit FfiBit), + + ( "unit", ITunit, 0 ), + ( "dependency", ITdependency, 0 ), + ( "signature", ITsignature, 0 ), + + ( "rec", ITrec, xbit ArrowsBit .|. + xbit RecursiveDoBit), + ( "proc", ITproc, xbit ArrowsBit), + ( "splice", ITsplice, xbit LevelImportsBit), + ( "quote", ITquote, xbit LevelImportsBit) + ] + +{----------------------------------- +Note [Lexing type pseudo-keywords] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +One might think that we wish to treat 'family' and 'role' as regular old +varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively. +But, there is no need to do so. These pseudo-keywords are not stolen syntax: +they are only used after the keyword 'type' at the top-level, where varids are +not allowed. Furthermore, checks further downstream (GHC.Tc.TyCl) ensure that +type families and role annotations are never declared without their extensions +on. In fact, by unconditionally lexing these pseudo-keywords as special, we +can get better error messages. + +Also, note that these are included in the `varid` production in the parser -- +a key detail to make all this work. +-------------------------------------} + +reservedSymsFM :: UniqFM FastString (Token, IsUnicodeSyntax, ExtsBitmap) +reservedSymsFM = listToUFM $ + map (\ (x,w,y,z) -> (mkFastString x,(w,y,z))) + [ ("..", ITdotdot, NormalSyntax, 0 ) + -- (:) is a reserved op, meaning only list cons + ,(":", ITcolon, NormalSyntax, 0 ) + ,("::", ITdcolon NormalSyntax, NormalSyntax, 0 ) + ,("=", ITequal, NormalSyntax, 0 ) + ,("\\", ITlam, NormalSyntax, 0 ) + ,("|", ITvbar, NormalSyntax, 0 ) + ,("<-", ITlarrow NormalSyntax, NormalSyntax, 0 ) + ,("->", ITrarrow NormalSyntax, NormalSyntax, 0 ) + ,("=>", ITdarrow NormalSyntax, NormalSyntax, 0 ) + ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit) + + ,("*", ITstar NormalSyntax, NormalSyntax, xbit StarIsTypeBit) + + ,("-<", ITlarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,(">-", ITrarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,("-<<", ITLarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,(">>-", ITRarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + + ,("∷", ITdcolon UnicodeSyntax, UnicodeSyntax, 0 ) + ,("⇒", ITdarrow UnicodeSyntax, UnicodeSyntax, 0 ) + ,("∀", ITforall UnicodeSyntax, UnicodeSyntax, 0 ) + ,("→", ITrarrow UnicodeSyntax, UnicodeSyntax, 0 ) + ,("←", ITlarrow UnicodeSyntax, UnicodeSyntax, 0 ) + + ,("⊸", ITlolly, UnicodeSyntax, 0) + + ,("⤙", ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤚", ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤛", ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤜", ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + + ,("★", ITstar UnicodeSyntax, UnicodeSyntax, xbit StarIsTypeBit) + + -- ToDo: ideally, → and ∷ should be "specials", so that they cannot + -- form part of a large operator. This would let us have a better + -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). + ] + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = PsSpan -> StringBuffer -> Int -> StringBuffer -> P (PsLocated Token) + +special :: Token -> Action +special tok span _buf _len _buf2 = return (L span tok) + +token, layout_token :: Token -> Action +token t span _buf _len _buf2 = return (L span t) +layout_token t span _buf _len _buf2 = pushLexState layout >> return (L span t) + +idtoken :: (StringBuffer -> Int -> Token) -> Action +idtoken f span buf len _buf2 = return (L span $! (f buf len)) + +qdo_token :: (Maybe FastString -> Token) -> Action +qdo_token con span buf len _buf2 = do + maybe_layout token + return (L span $! token) + where + !token = con $! Just $! fst $! splitQualName buf len False + +skip_one_varid :: (FastString -> Token) -> Action +skip_one_varid f span buf len _buf2 + = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) + +skip_one_varid_src :: (SourceText -> FastString -> Token) -> Action +skip_one_varid_src f span buf len _buf2 + = return (L span $! f (SourceText $ lexemeToFastString (stepOn buf) (len-1)) + (lexemeToFastString (stepOn buf) (len-1))) + +skip_two_varid :: (FastString -> Token) -> Action +skip_two_varid f span buf len _buf2 + = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) + +strtoken :: (String -> Token) -> Action +strtoken f span buf len _buf2 = + return (L span $! (f $! lexemeToString buf len)) + +fstrtoken :: (FastString -> Token) -> Action +fstrtoken f span buf len _buf2 = + return (L span $! (f $! lexemeToFastString buf len)) + +begin :: Int -> Action +begin code _span _str _len _buf2 = do pushLexState code; lexToken + +pop :: Action +pop _span _buf _len _buf2 = + do _ <- popLexState + lexToken +-- See Note [Nested comment line pragmas] +failLinePrag1 :: Action +failLinePrag1 span _buf _len _buf2 = do + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) + else lexError LexErrorInPragma + +-- See Note [Nested comment line pragmas] +popLinePrag1 :: Action +popLinePrag1 span _buf _len _buf2 = do + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) else do + _ <- popLexState + lexToken + +hopefully_open_brace :: Action +hopefully_open_brace span buf len buf2 + = do relaxed <- getBit RelaxedLayoutBit + ctx <- getContext + (AI l _) <- getInput + let offset = srcLocCol (psRealLoc l) + isOK = relaxed || + case ctx of + Layout prev_off _ : _ -> prev_off < offset + _ -> True + if isOK then pop_and open_brace span buf len buf2 + else addFatalError $ + mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock + +pop_and :: Action -> Action +pop_and act span buf len buf2 = + do _ <- popLexState + act span buf len buf2 + +-- See Note [Whitespace-sensitive operator parsing] +followedByOpeningToken, precededByClosingToken :: AlexAccPred ExtsBitmap +followedByOpeningToken _ _ _ (AI _ buf) = followedByOpeningToken' buf +precededByClosingToken _ (AI _ buf) _ _ = precededByClosingToken' buf + +-- The input is the buffer *after* the token. +followedByOpeningToken' :: StringBuffer -> Bool +followedByOpeningToken' buf + | atEnd buf = False + | otherwise = + case nextChar buf of + ('{', buf') -> nextCharIsNot buf' (== '-') + ('(', _) -> True + ('[', _) -> True + ('\"', _) -> True + ('\'', _) -> True + ('_', _) -> True + ('⟦', _) -> True + ('⦇', _) -> True + (c, _) -> isAlphaNum c + +-- The input is the buffer *before* the token. +precededByClosingToken' :: StringBuffer -> Bool +precededByClosingToken' buf = + case prevChar buf '\n' of + '}' -> decodePrevNChars 1 buf /= "-" + ')' -> True + ']' -> True + '\"' -> True + '\'' -> True + '_' -> True + '⟧' -> True + '⦈' -> True + c -> isAlphaNum c + +get_op_ws :: StringBuffer -> StringBuffer -> OpWs +get_op_ws buf1 buf2 = + mk_op_ws (precededByClosingToken' buf1) (followedByOpeningToken' buf2) + where + mk_op_ws False True = OpWsPrefix + mk_op_ws True False = OpWsSuffix + mk_op_ws True True = OpWsTightInfix + mk_op_ws False False = OpWsLooseInfix + +{-# INLINE with_op_ws #-} +with_op_ws :: (OpWs -> Action) -> Action +with_op_ws act span buf len buf2 = act (get_op_ws buf buf2) span buf len buf2 + +{-# INLINE nextCharIs #-} +nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIs buf p = not (atEnd buf) && p (currentChar buf) + +{-# INLINE nextCharIsNot #-} +nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIsNot buf p = not (nextCharIs buf p) + +notFollowedBy :: Char -> AlexAccPred ExtsBitmap +notFollowedBy char _ _ _ (AI _ buf) + = nextCharIsNot buf (== char) + +notFollowedBySymbol :: AlexAccPred ExtsBitmap +notFollowedBySymbol _ _ _ (AI _ buf) + = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") + +followedByDigit :: AlexAccPred ExtsBitmap +followedByDigit _ _ _ (AI _ buf) + = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9'])) + +ifCurrentChar :: Char -> AlexAccPred ExtsBitmap +ifCurrentChar char _ (AI _ buf) _ _ + = nextCharIs buf (== char) + +-- We must reject doc comments as being ordinary comments everywhere. +-- In some cases the doc comment will be selected as the lexeme due to +-- maximal munch, but not always, because the nested comment rule is +-- valid in all states, but the doc-comment rules are only valid in +-- the non-layout states. +isNormalComment :: AlexAccPred ExtsBitmap +isNormalComment bits _ _ (AI _ buf) + | HaddockBit `xtest` bits = notFollowedByDocOrPragma + | otherwise = nextCharIsNot buf (== '#') + where + notFollowedByDocOrPragma + = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) + +afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool +afterOptionalSpace buf p + = if nextCharIs buf (== ' ') + then p (snd (nextChar buf)) + else p buf + +atEOL :: AlexAccPred ExtsBitmap +atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' + +-- Check if we should parse a negative literal (e.g. -123) as a single token. +negLitPred :: AlexAccPred ExtsBitmap +negLitPred = + prefix_minus `alexAndPred` + (negative_literals `alexOrPred` lexical_negation) + where + negative_literals = ifExtension NegativeLiteralsBit + + lexical_negation = + -- See Note [Why not LexicalNegationBit] + alexNotPred (ifExtension NoLexicalNegationBit) + + prefix_minus = + -- Note [prefix_minus in negLitPred and negHashLitPred] + alexNotPred precededByClosingToken + +-- Check if we should parse an unboxed negative literal (e.g. -123#) as a single token. +negHashLitPred :: ExtBits -> AlexAccPred ExtsBitmap +negHashLitPred ext = prefix_minus `alexAndPred` magic_hash + where + magic_hash = ifExtension ext -- Either MagicHashBit or ExtendedLiteralsBit + prefix_minus = + -- Note [prefix_minus in negLitPred and negHashLitPred] + alexNotPred precededByClosingToken + +{- Note [prefix_minus in negLitPred and negHashLitPred] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to parse -1 as a single token, but x-1 as three tokens. +So in negLitPred (and negHashLitPred) we require that we have a prefix +occurrence of the minus sign. See Note [Whitespace-sensitive operator parsing] +for a detailed definition of a prefix occurrence. + +The condition for a prefix occurrence of an operator is: + + not precededByClosingToken && followedByOpeningToken + +but we don't check followedByOpeningToken when parsing a negative literal. +It holds simply because we immediately lex a literal after the minus. +-} + +ifExtension :: ExtBits -> AlexAccPred ExtsBitmap +ifExtension extBits bits _ _ _ = extBits `xtest` bits + +alexNotPred p userState in1 len in2 + = not (p userState in1 len in2) + +alexOrPred p1 p2 userState in1 len in2 + = p1 userState in1 len in2 || p2 userState in1 len in2 + +multiline_doc_comment :: Action +multiline_doc_comment span buf _len _buf2 = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker + where + worker input@(AI start_loc _) docType checkNextLine = go start_loc "" [] input + where + go start_loc curLine prevLines input@(AI end_loc _) = case alexGetChar' input of + Just ('\n', input') + | checkNextLine -> case checkIfCommentLine input' of + Just input@(AI next_start _) -> go next_start "" (locatedLine : prevLines) input -- Start a new line + Nothing -> endComment + | otherwise -> endComment + Just (c, input) -> go start_loc (c:curLine) prevLines input + Nothing -> endComment + where + lineSpan = mkSrcSpanPs $ mkPsSpan start_loc end_loc + locatedLine = L lineSpan (mkHsDocStringChunk $ reverse curLine) + commentLines = NE.reverse $ locatedLine :| prevLines + endComment = docCommentEnd input (docType (\dec -> MultiLineDocString dec commentLines)) buf span + + -- Check if the next line of input belongs to this doc comment as well. + -- A doc comment continues onto the next line when the following + -- conditions are met: + -- * The line starts with "--" + -- * The line doesn't start with "---". + -- * The line doesn't start with "-- $", because that would be the + -- start of a /new/ named haddock chunk (#10398). + checkIfCommentLine :: AlexInput -> Maybe AlexInput + checkIfCommentLine input = check (dropNonNewlineSpace input) + where + check input = do + ('-', input) <- alexGetChar' input + ('-', input) <- alexGetChar' input + (c, after_c) <- alexGetChar' input + case c of + '-' -> Nothing + ' ' -> case alexGetChar' after_c of + Just ('$', _) -> Nothing + _ -> Just input + _ -> Just input + + dropNonNewlineSpace input = case alexGetChar' input of + Just (c, input') + | isSpace c && c /= '\n' -> dropNonNewlineSpace input' + | otherwise -> input + Nothing -> input + +lineCommentToken :: Action +lineCommentToken span buf len buf2 = do + b <- getBit RawTokenStreamBit + if b then do + lt <- getLastLocIncludingComments + strtoken (\s -> ITlineComment s lt) span buf len buf2 + else lexToken + + +{- + nested comments require traversing by hand, they can't be parsed + using regular expressions. +-} +nested_comment :: Action +nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do + l <- getLastLocIncludingComments + let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span + input <- getInput + -- Include decorator in comment + let start_decorator = reverse $ lexemeToString buf len + nested_comment_logic endComment start_decorator input span + +nested_doc_comment :: Action +nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker + where + worker input@(AI start_loc _) docType _checkNextLine = nested_comment_logic endComment "" input (mkPsSpan start_loc (psSpanEnd span)) + where + endComment input lcomment + = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span + + dropTrailingDec [] = [] + dropTrailingDec "-}" = "" + dropTrailingDec (x:xs) = x:dropTrailingDec xs + +{-# INLINE nested_comment_logic #-} +-- | Includes the trailing '-}' decorators +-- drop the last two elements with the callback if you don't want them to be included +nested_comment_logic + :: (AlexInput -> Located String -> P (PsLocated Token)) -- ^ Continuation that gets the rest of the input and the lexed comment + -> String -- ^ starting value for accumulator (reversed) - When we want to include a decorator '{-' in the comment + -> AlexInput + -> PsSpan + -> P (PsLocated Token) +nested_comment_logic endComment commentAcc input span = go commentAcc (1::Int) input + where + go commentAcc 0 input@(AI end_loc _) = do + let comment = reverse commentAcc + cspan = mkSrcSpanPs $ mkPsSpan (psSpanStart span) end_loc + lcomment = L cspan comment + endComment input lcomment + go commentAcc n input = case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('-',input) -> case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' + Just (_,_) -> go ('-':commentAcc) n input + Just ('\123',input) -> case alexGetChar' input of -- '{' char + Nothing -> errBrace input (psRealSpan span) + Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input + Just (_,_) -> go ('\123':commentAcc) n input + -- See Note [Nested comment line pragmas] + Just ('\n',input) -> case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input + go (parsedAcc ++ '\n':commentAcc) n input + Just (_,_) -> go ('\n':commentAcc) n input + Just (c,input) -> go (c:commentAcc) n input + +-- See Note [Nested comment line pragmas] +parseNestedPragma :: AlexInput -> P (String,AlexInput) +parseNestedPragma input@(AI _ buf) = do + origInput <- getInput + setInput input + setExts (.|. xbit InNestedCommentBit) + pushLexState bol + lt <- lexToken + _ <- popLexState + setExts (.&. complement (xbit InNestedCommentBit)) + postInput@(AI _ postBuf) <- getInput + setInput origInput + case unLoc lt of + ITcomment_line_prag -> do + let bytes = byteDiff buf postBuf + diff = lexemeToString buf bytes + return (reverse diff, postInput) + lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt')) + +{- +Note [Nested comment line pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to ignore cpp-preprocessor-generated #line pragmas if they were inside +nested comments. + +Now, when parsing a nested comment, if we encounter a line starting with '#' we +call parseNestedPragma, which executes the following: +1. Save the current lexer input (loc, buf) for later +2. Set the current lexer input to the beginning of the line starting with '#' +3. Turn the 'InNestedComment' extension on +4. Push the 'bol' lexer state +5. Lex a token. Due to (2), (3), and (4), this should always lex a single line + or less and return the ITcomment_line_prag token. This may set source line + and file location if a #line pragma is successfully parsed +6. Restore lexer input and state to what they were before we did all this +7. Return control to the function parsing a nested comment, informing it of + what the lexer parsed + +Regarding (5) above: +Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1) +checks if the 'InNestedComment' extension is set. If it is, that function will +return control to parseNestedPragma by returning the ITcomment_line_prag token. + +See #314 for more background on the bug this fixes. +-} + +{-# INLINE withLexedDocType #-} +withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)) -> Bool -> P (PsLocated Token)) + -> P (PsLocated Token) +withLexedDocType lexDocComment = do + input@(AI _ buf) <- getInput + l <- getLastLocIncludingComments + case prevChar buf ' ' of + -- The `Bool` argument to lexDocComment signals whether or not the next + -- line of input might also belong to this doc comment. + '|' -> lexDocComment input (mkHdkCommentNext l) True + '^' -> lexDocComment input (mkHdkCommentPrev l) True + '$' -> case lexDocName input of + Nothing -> do setInput input; lexToken -- eof reached, lex it normally + Just (name, input) -> lexDocComment input (mkHdkCommentNamed l name) True + '*' -> lexDocSection l 1 input + _ -> panic "withLexedDocType: Bad doc type" + where + lexDocSection l n input = case alexGetChar' input of + Just ('*', input) -> lexDocSection l (n+1) input + Just (_, _) -> lexDocComment input (mkHdkCommentSection l n) False + Nothing -> do setInput input; lexToken -- eof reached, lex it normally + + lexDocName :: AlexInput -> Maybe (String, AlexInput) + lexDocName = go "" + where + go acc input = case alexGetChar' input of + Just (c, input') + | isSpace c -> Just (reverse acc, input) + | otherwise -> go (c:acc) input' + Nothing -> Nothing + +mkHdkCommentNext, mkHdkCommentPrev :: PsSpan -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentNext loc mkDS = (HdkCommentNext ds,ITdocComment ds loc) + where ds = mkDS HsDocStringNext +mkHdkCommentPrev loc mkDS = (HdkCommentPrev ds,ITdocComment ds loc) + where ds = mkDS HsDocStringPrevious + +mkHdkCommentNamed :: PsSpan -> String -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentNamed loc name mkDS = (HdkCommentNamed name ds, ITdocComment ds loc) + where ds = mkDS (HsDocStringNamed name) + +mkHdkCommentSection :: PsSpan -> Int -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc) + where ds = mkDS (HsDocStringGroup n) + +-- RULES pragmas turn on the forall and '.' keywords, and we turn them +-- off again at the end of the pragma. +rulePrag :: Action +rulePrag span buf len _buf2 = do + setExts (.|. xbit InRulePragBit) + let !src = lexemeToFastString buf len + return (L span (ITrules_prag (SourceText src))) + +-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead +-- of updating the position in 'PState' +linePrag :: Action +linePrag span buf len buf2 = do + usePosPrags <- getBit UsePosPragsBit + if usePosPrags + then begin line_prag2 span buf len buf2 + else let !src = lexemeToFastString buf len + in return (L span (ITline_prag (SourceText src))) + +-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead +-- of updating the position in 'PState' +columnPrag :: Action +columnPrag span buf len buf2 = do + usePosPrags <- getBit UsePosPragsBit + if usePosPrags + then begin column_prag span buf len buf2 + else let !src = lexemeToFastString buf len + in return (L span (ITcolumn_prag (SourceText src))) + +endPrag :: Action +endPrag span _buf _len _buf2 = do + setExts (.&. complement (xbit InRulePragBit)) + return (L span ITclose_prag) + +-- docCommentEnd +------------------------------------------------------------------------------- +-- This function is quite tricky. We can't just return a new token, we also +-- need to update the state of the parser. Why? Because the token is longer +-- than what was lexed by Alex, and the lexToken function doesn't know this, so +-- it writes the wrong token length to the parser state. This function is +-- called afterwards, so it can just update the state. + +{-# INLINE commentEnd #-} +commentEnd :: P (PsLocated Token) + -> AlexInput + -> (Maybe HdkComment, Token) + -> StringBuffer + -> PsSpan + -> P (PsLocated Token) +commentEnd cont input (m_hdk_comment, hdk_token) buf span = do + setInput input + let (AI loc nextBuf) = input + span' = mkPsSpan (psSpanStart span) loc + last_len = byteDiff buf nextBuf + span `seq` setLastToken span' last_len + whenIsJust m_hdk_comment $ \hdk_comment -> + P $ \s -> POk (s {hdk_comments = hdk_comments s `snocOL` L span' hdk_comment}) () + b <- getBit RawTokenStreamBit + if b then return (L span' hdk_token) + else cont + +{-# INLINE docCommentEnd #-} +docCommentEnd :: AlexInput -> (HdkComment, Token) -> StringBuffer -> + PsSpan -> P (PsLocated Token) +docCommentEnd input (hdk_comment, tok) buf span + = commentEnd lexToken input (Just hdk_comment, tok) buf span + +errBrace :: AlexInput -> RealSrcSpan -> P a +errBrace (AI end _) span = + failLocMsgP (realSrcSpanStart span) + (psRealLoc end) + (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF)) + +open_brace, close_brace :: Action +open_brace span _str _len _buf2 = do + ctx <- getContext + setContext (NoLayout:ctx) + return (L span ITocurly) +close_brace span _str _len _buf2 = do + popContext + return (L span ITccurly) + +qvarid, qconid :: StringBuffer -> Int -> Token +qvarid buf len = ITqvarid $! splitQualName buf len False +qconid buf len = ITqconid $! splitQualName buf len False + +splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) +-- takes a StringBuffer and a length, and returns the module name +-- and identifier parts of a qualified name. Splits at the *last* dot, +-- because of hierarchical module names. +-- +-- Throws an error if the name is not qualified. +splitQualName orig_buf len parens = split orig_buf orig_buf + where + split buf dot_buf + | orig_buf `byteDiff` buf >= len = done dot_buf + | c == '.' = found_dot buf' + | otherwise = split buf' dot_buf + where + (c,buf') = nextChar buf + + -- careful, we might get names like M.... + -- so, if the character after the dot is not upper-case, this is + -- the end of the qualifier part. + found_dot buf -- buf points after the '.' + | isUpper c = split buf' buf + | otherwise = done buf + where + (c,buf') = nextChar buf + + done dot_buf + | qual_size < 1 = error "splitQualName got an unqualified named" + | otherwise = + (lexemeToFastString orig_buf (qual_size - 1), + if parens -- Prelude.(+) + then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) + else lexemeToFastString dot_buf (len - qual_size)) + where + qual_size = orig_buf `byteDiff` dot_buf + +varid :: Action +varid span buf len _buf2 = + case lookupUFM reservedWordsFM fs of + Just (ITcase, _) -> do + lastTk <- getLastTk + keyword <- case lastTk of + Strict.Just (L _ ITlam) -> do + lambdaCase <- getBit LambdaCaseBit + unless lambdaCase $ do + pState <- getPState + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) PsErrLambdaCase + return ITlcase + _ -> return ITcase + maybe_layout keyword + return $ L span keyword + Just (ITlcases, _) -> do + lastTk <- getLastTk + lambdaCase <- getBit LambdaCaseBit + token <- case lastTk of + Strict.Just (L _ ITlam) | lambdaCase -> return ITlcases + _ -> return $ ITvarid fs + maybe_layout token + return $ L span token + Just (keyword, 0) -> do + maybe_layout keyword + return $ L span keyword + Just (keyword, i) -> do + exts <- getExts + if exts .&. i /= 0 + then do + maybe_layout keyword + return $ L span keyword + else + return $ L span $ ITvarid fs + Nothing -> + return $ L span $ ITvarid fs + where + !fs = lexemeToFastString buf len + +conid :: StringBuffer -> Int -> Token +conid buf len = ITconid $! lexemeToFastString buf len + +qvarsym, qconsym :: StringBuffer -> Int -> Token +qvarsym buf len = ITqvarsym $! splitQualName buf len False +qconsym buf len = ITqconsym $! splitQualName buf len False + + +errSuffixAt :: PsSpan -> P a +errSuffixAt span = do + input <- getInput + failLocMsgP start (go input start) (\srcSpan -> mkPlainErrorMsgEnvelope srcSpan $ PsErrSuffixAT) + where + start = psRealLoc (psSpanStart span) + go inp loc + | Just (c, i) <- alexGetChar inp + , let next = advanceSrcLoc loc c = + if c == ' ' + then go i next + else next + | otherwise = loc + +-- See Note [Whitespace-sensitive operator parsing] +varsym :: OpWs -> Action +varsym opws@OpWsPrefix = sym $ \span exts s -> + let warnExtConflict errtok = + do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok) + ; return (ITvarsym s) } + in + if | s == fsLit "@" -> + return ITtypeApp -- regardless of TypeApplications for better error messages + | s == fsLit "%" -> + if xtest LinearTypesBit exts + then return ITpercent + else warnExtConflict OperatorWhitespaceSymbol_PrefixPercent + | s == fsLit "$" -> + if xtest ThQuotesBit exts + then return ITdollar + else warnExtConflict OperatorWhitespaceSymbol_PrefixDollar + | s == fsLit "$$" -> + if xtest ThQuotesBit exts + then return ITdollardollar + else warnExtConflict OperatorWhitespaceSymbol_PrefixDollarDollar + | s == fsLit "-" -> + return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus + -- and don't hit this code path. See Note [Minus tokens] + | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> + return (ITproj True) -- e.g. '(.x)' + | s == fsLit "." -> return ITdot + | s == fsLit "!" -> return ITbang + | s == fsLit "~" -> return ITtilde + | otherwise -> + do { warnOperatorWhitespace opws span s + ; return (ITvarsym s) } +varsym opws@OpWsSuffix = sym $ \span _ s -> + if | s == fsLit "@" -> errSuffixAt span + | s == fsLit "." -> return ITdot + | otherwise -> + do { warnOperatorWhitespace opws span s + ; return (ITvarsym s) } +varsym opws@OpWsTightInfix = sym $ \span exts s -> + if | s == fsLit "@" -> return ITat + | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> return (ITproj False) + | s == fsLit "." -> return ITdot + | otherwise -> + do { warnOperatorWhitespace opws span s + ; return (ITvarsym s) } +varsym OpWsLooseInfix = sym $ \_ _ s -> + if | s == fsLit "." + -> return ITdot + | otherwise + -> return $ ITvarsym s + +consym :: OpWs -> Action +consym opws = sym $ \span _exts s -> + do { warnOperatorWhitespace opws span s + ; return (ITconsym s) } + +warnOperatorWhitespace :: OpWs -> PsSpan -> FastString -> P () +warnOperatorWhitespace opws span s = + whenIsJust (check_unusual_opws opws) $ \opws' -> + addPsMessage + (mkSrcSpanPs span) + (PsWarnOperatorWhitespace s opws') + +-- Check an operator occurrence for unusual whitespace (prefix, suffix, tight infix). +-- This determines if -Woperator-whitespace is triggered. +check_unusual_opws :: OpWs -> Maybe OperatorWhitespaceOccurrence +check_unusual_opws opws = + case opws of + OpWsPrefix -> Just OperatorWhitespaceOccurrence_Prefix + OpWsSuffix -> Just OperatorWhitespaceOccurrence_Suffix + OpWsTightInfix -> Just OperatorWhitespaceOccurrence_TightInfix + OpWsLooseInfix -> Nothing + +sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action +sym con span buf len _buf2 = + case lookupUFM reservedSymsFM fs of + Just (keyword, NormalSyntax, 0) -> + return $ L span keyword + Just (keyword, NormalSyntax, i) -> do + exts <- getExts + if exts .&. i /= 0 + then return $ L span keyword + else L span <$!> con span exts fs + Just (keyword, UnicodeSyntax, 0) -> do + exts <- getExts + if xtest UnicodeSyntaxBit exts + then return $ L span keyword + else L span <$!> con span exts fs + Just (keyword, UnicodeSyntax, i) -> do + exts <- getExts + if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts + then return $ L span keyword + else L span <$!> con span exts fs + Nothing -> do + exts <- getExts + L span <$!> con span exts fs + where + !fs = lexemeToFastString buf len + +-- Variations on the integral numeric literal. +tok_integral + :: (SourceText -> Integer -> Token) -- ^ token constructor + -> (Integer -> Integer) -- ^ value transformation (e.g. negate) + -> Int -- ^ Offset of the unsigned value (e.g. 1 when we parsed "-", 2 for "0x", etc.) + -> Int -- ^ Number of non-numeric characters parsed (e.g. 6 in "-12#Int8") + -> (Integer, (Char -> Int)) -- ^ (radix, char_to_int parsing function) + -> Action +tok_integral mk_token transval offset translen (radix,char_to_int) span buf len _buf2 = do + numericUnderscores <- getBit NumericUnderscoresBit -- #14473 + let src = lexemeToFastString buf len + when ((not numericUnderscores) && ('_' `elem` unpackFS src)) $ do + pState <- getPState + let msg = PsErrNumUnderscores NumUnderscore_Integral + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg + return $ L span $ mk_token (SourceText src) + $! transval $ parseUnsignedInteger + (offsetBytes offset buf) (subtract translen len) radix char_to_int + +-- | Helper to parse ExtendedLiterals (e.g. -0x10#Word32) +-- +-- This function finds the offset of the "#" character and checks that the +-- suffix is valid. Then it calls tok_integral with the appropriate suffix +-- length taken into account. +tok_prim_num_ext + :: (Integer -> Integer) -- ^ value transformation (e.g. negate) + -> Int -- ^ Offset of the unsigned value (e.g. 1 when we parsed "-", 2 for "0x", etc.) + -> (Integer, (Char -> Int)) -- ^ (radix, char_to_int parsing function) + -> Action +tok_prim_num_ext transval offset (radix,char_to_int) span buf len buf2 = do + let !suffix_offset = findHashOffset buf + 1 + let !suffix_len = len - suffix_offset + let !suffix = lexemeToFastString (offsetBytes suffix_offset buf) suffix_len + + mk_token <- if + | suffix == fsLit "Word" -> pure ITprimword + | suffix == fsLit "Word8" -> pure ITprimword8 + | suffix == fsLit "Word16" -> pure ITprimword16 + | suffix == fsLit "Word32" -> pure ITprimword32 + | suffix == fsLit "Word64" -> pure ITprimword64 + | suffix == fsLit "Int" -> pure ITprimint + | suffix == fsLit "Int8" -> pure ITprimint8 + | suffix == fsLit "Int16" -> pure ITprimint16 + | suffix == fsLit "Int32" -> pure ITprimint32 + | suffix == fsLit "Int64" -> pure ITprimint64 + | otherwise -> srcParseFail + + let !translen = suffix_len+offset+1 + tok_integral mk_token transval offset translen (radix,char_to_int) span buf len buf2 + + + +tok_num :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_num = tok_integral $ \case + st@(SourceText (unconsFS -> Just ('-',_))) -> itint st (const True) + st@(SourceText _) -> itint st (const False) + st@NoSourceText -> itint st (< 0) + where + itint :: SourceText -> (Integer -> Bool) -> Integer -> Token + itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val) + +tok_primint :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primint = tok_integral ITprimint + + +tok_primword :: Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primword = tok_integral ITprimword positive + +positive, negative :: (Integer -> Integer) +positive = id +negative = negate + +binary, octal, decimal, hexadecimal :: (Integer, Char -> Int) +binary = (2,octDecDigit) +octal = (8,octDecDigit) +decimal = (10,octDecDigit) +hexadecimal = (16,hexDigit) + +-- readSignificandExponentPair can understand negative rationals, exponents, everything. +tok_frac :: Int -> (String -> Token) -> Action +tok_frac drop f span buf len _buf2 = do + numericUnderscores <- getBit NumericUnderscoresBit -- #14473 + let src = lexemeToString buf (len-drop) + when ((not numericUnderscores) && ('_' `elem` src)) $ do + pState <- getPState + let msg = PsErrNumUnderscores NumUnderscore_Float + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg + return (L span $! (f $! src)) + +tok_float, tok_primfloat, tok_primdouble, tok_prim_hex_float, tok_prim_hex_double :: String -> Token +tok_float str = ITrational $! readFractionalLit str +tok_hex_float str = ITrational $! readHexFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str +tok_prim_hex_float str = ITprimfloat $! readHexFractionalLit str +tok_prim_hex_double str = ITprimdouble $! readHexFractionalLit str + +readFractionalLit, readHexFractionalLit :: String -> FractionalLit +readHexFractionalLit = readFractionalLitX readHexSignificandExponentPair Base2 +readFractionalLit = readFractionalLitX readSignificandExponentPair Base10 + +readFractionalLitX :: (String -> (Integer, Integer)) + -> FractionalExponentBase + -> String -> FractionalLit +readFractionalLitX readStr b str = + mkSourceFractionalLit str is_neg i e b + where + is_neg = case str of + '-' : _ -> True + _ -> False + (i, e) = readStr str + +-- ----------------------------------------------------------------------------- +-- Layout processing + +-- we're at the first token on a line, insert layout tokens if necessary +do_bol :: Action +do_bol span _str _len _buf2 = do + -- See Note [Nested comment line pragmas] + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) else do + (pos, gen_semic) <- getOffside + case pos of + LT -> do + --trace "layout: inserting '}'" $ do + popContext + -- do NOT pop the lex state, we might have a ';' to insert + return (L span ITvccurly) + EQ | gen_semic -> do + --trace "layout: inserting ';'" $ do + _ <- popLexState + return (L span ITsemi) + _ -> do + _ <- popLexState + lexToken + +-- certain keywords put us in the "layout" state, where we might +-- add an opening curly brace. +maybe_layout :: Token -> P () +maybe_layout t = do -- If the alternative layout rule is enabled then + -- we never create an implicit layout context here. + -- Layout is handled XXX instead. + -- The code for closing implicit contexts, or + -- inserting implicit semi-colons, is therefore + -- irrelevant as it only applies in an implicit + -- context. + alr <- getBit AlternativeLayoutRuleBit + unless alr $ f t + where f (ITdo _) = pushLexState layout_do + f (ITmdo _) = pushLexState layout_do + f ITof = pushLexState layout + f ITlcase = pushLexState layout + f ITlcases = pushLexState layout + f ITlet = pushLexState layout + f ITwhere = pushLexState layout + f ITrec = pushLexState layout + f ITif = pushLexState layout_if + f _ = return () + +-- Pushing a new implicit layout context. If the indentation of the +-- next token is not greater than the previous layout context, then +-- Haskell 98 says that the new layout context should be empty; that is +-- the lexer must generate {}. +-- +-- We are slightly more lenient than this: when the new context is started +-- by a 'do', then we allow the new context to be at the same indentation as +-- the previous context. This is what the 'strict' argument is for. +new_layout_context :: Bool -> Bool -> Token -> Action +new_layout_context strict gen_semic tok span _buf len _buf2 = do + _ <- popLexState + (AI l _) <- getInput + let offset = srcLocCol (psRealLoc l) - len + ctx <- getContext + nondecreasing <- getBit NondecreasingIndentationBit + let strict' = strict || not nondecreasing + case ctx of + Layout prev_off _ : _ | + (strict' && prev_off >= offset || + not strict' && prev_off > offset) -> do + -- token is indented to the left of the previous context. + -- we must generate a {} sequence now. + pushLexState layout_left + return (L span tok) + _ -> do setContext (Layout offset gen_semic : ctx) + return (L span tok) + +do_layout_left :: Action +do_layout_left span _buf _len _buf2 = do + _ <- popLexState + pushLexState bol -- we must be at the start of a line + return (L span ITvccurly) + +-- ----------------------------------------------------------------------------- +-- LINE pragmas + +setLineAndFile :: Int -> Action +setLineAndFile code (PsSpan span _) buf len _buf2 = do + let src = lexemeToString buf (len - 1) -- drop trailing quotation mark + linenumLen = length $ head $ words src + linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit + file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src + -- skip everything through first quotation mark to get to the filename + where go ('\\':c:cs) = c : go cs + go (c:cs) = c : go cs + go [] = [] + -- decode escapes in the filename. e.g. on Windows + -- when our filenames have backslashes in, gcc seems to + -- escape the backslashes. One symptom of not doing this + -- is that filenames in error messages look a bit strange: + -- C:\\foo\bar.hs + -- only the first backslash is doubled, because we apply + -- System.FilePath.normalise before printing out + -- filenames and it does not remove duplicate + -- backslashes after the drive letter (should it?). + resetAlrLastLoc file + setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span)) + -- subtract one: the line number refers to the *following* line + addSrcFile file + _ <- popLexState + pushLexState code + lexToken + +setColumn :: Action +setColumn (PsSpan span _) buf len _buf2 = do + let column = + case reads (lexemeToString buf len) of + [(column, _)] -> column + _ -> error "setColumn: expected integer" -- shouldn't happen + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span) + (fromIntegral (column :: Integer))) + _ <- popLexState + lexToken + +alrInitialLoc :: FastString -> RealSrcSpan +alrInitialLoc file = mkRealSrcSpan loc loc + where -- This is a hack to ensure that the first line in a file + -- looks like it is after the initial location: + loc = mkRealSrcLoc file (-1) (-1) + +-- ----------------------------------------------------------------------------- +-- Options, includes and language pragmas. + + +lex_string_prag :: (String -> Token) -> Action +lex_string_prag mkTok = lex_string_prag_comment mkTok' + where + mkTok' s _ = mkTok s + +lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action +lex_string_prag_comment mkTok span _buf _len _buf2 + = do input <- getInput + start <- getParsedLoc + l <- getLastLocIncludingComments + tok <- go l [] input + end <- getParsedLoc + return (L (mkPsSpan start end) tok) + where go l acc input + = if isString input "#-}" + then do setInput input + return (mkTok (reverse acc) l) + else case alexGetChar input of + Just (c,i) -> go l (c:acc) i + Nothing -> err input + isString _ [] = True + isString i (x:xs) + = case alexGetChar i of + Just (c,i') | c == x -> isString i' xs + _other -> False + err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) + (psRealLoc end) + (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexUnterminatedOptions LexErrKind_EOF) + +-- ----------------------------------------------------------------------------- +-- Strings & Chars + +tok_string :: Action +tok_string span buf len _buf2 = do + s <- lex_chars ("\"", "\"") span buf (if endsInHash then len - 1 else len) + + if endsInHash + then do + when (any (> '\xFF') s) $ do + pState <- getPState + let msg = PsErrPrimStringInvalidChar + let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg + addError err + pure $ L span (ITprimstring src (unsafeMkByteString s)) + else + pure $ L span (ITstring src (mkFastString s)) + where + src = SourceText $ lexemeToFastString buf len + endsInHash = currentChar (offsetBytes (len - 1) buf) == '#' + +{- Note [Lexing multiline strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ideally, we would lex multiline strings completely with Alex syntax, like +normal strings. However, we can't because: + + 1. The multiline string should all be one lexical token, not multiple + 2. We need to allow bare quotes, which can't be done with one regex + +Instead, we'll lex them with a hybrid solution in tok_string_multi by manually +invoking lex states. This allows us to get the performance of native Alex +syntax as much as possible, and just gluing the pieces together outside of +Alex. + +Implemented in string_multi_content in GHC/Parser/Lexer/String.x +-} + +-- | See Note [Lexing multiline strings] +tok_string_multi :: Action +tok_string_multi startSpan startBuf _len _buf2 = do + -- advance to the end of the multiline string + let startLoc = psSpanStart startSpan + let i@(AI _ contentStartBuf) = + case lexDelim $ AI startLoc startBuf of + Just i -> i + Nothing -> panic "tok_string_multi did not start with a delimiter" + (AI _ contentEndBuf, i'@(AI endLoc endBuf)) <- goContent i + + -- build the values pertaining to the entire multiline string, including delimiters + let span = mkPsSpan startLoc endLoc + let len = byteDiff startBuf endBuf + let src = SourceText $ lexemeToFastString startBuf len + + -- load the content of the multiline string + let contentLen = byteDiff contentStartBuf contentEndBuf + s <- + either (throwStringLexError (AI startLoc startBuf)) pure $ + lexMultilineString contentLen contentStartBuf + + setInput i' + pure $ L span $ ITstringMulti src (mkFastString s) + where + goContent i0 = + case Lexer.String.alexScan i0 Lexer.String.string_multi_content of + Lexer.String.AlexToken i1 len _ + | Just i2 <- lexDelim i1 -> pure (i1, i2) + | isEOF i1 -> checkSmartQuotes >> setInput i1 >> lexError LexError + -- Can happen if no patterns match, e.g. an unterminated gap + | len == 0 -> setInput i1 >> lexError LexError + | otherwise -> goContent i1 + Lexer.String.AlexSkip i1 _ -> goContent i1 + _ -> setInput i0 >> lexError LexError + + lexDelim = + let go 0 i = Just i + go n i = + case alexGetChar' i of + Just ('"', i') -> go (n - 1) i' + _ -> Nothing + in go (3 :: Int) + + -- See Note [Bare smart quote error] + checkSmartQuotes = do + let findSmartQuote i0@(AI loc _) = + case alexGetChar' i0 of + Just ('\\', i1) | Just (_, i2) <- alexGetChar' i1 -> findSmartQuote i2 + Just (c, i1) + | isDoubleSmartQuote c -> Just (c, loc) + | otherwise -> findSmartQuote i1 + _ -> Nothing + case findSmartQuote (AI (psSpanStart startSpan) startBuf) of + Just (c, loc) -> throwSmartQuoteError c loc + Nothing -> pure () + +lex_chars :: (String, String) -> PsSpan -> StringBuffer -> Int -> P String +lex_chars (startDelim, endDelim) span buf len = + either (throwStringLexError i0) pure $ + lexString contentLen contentBuf + where + i0@(AI _ contentBuf) = advanceInputBytes (length startDelim) $ AI (psSpanStart span) buf + + -- assumes delimiters are ASCII, with 1 byte per Char + contentLen = len - length startDelim - length endDelim + +throwStringLexError :: AlexInput -> StringLexError -> P a +throwStringLexError i (StringLexError e pos) = setInput (advanceInputTo pos i) >> lexError e + + +tok_quoted_label :: Action +tok_quoted_label span buf len _buf2 = do + s <- lex_chars ("#\"", "\"") span buf len + pure $ L span (ITlabelvarid src (mkFastString s)) + where + -- skip leading '#' + src = SourceText . mkFastString . drop 1 $ lexemeToString buf len + + +tok_char :: Action +tok_char span buf len _buf2 = do + c <- lex_chars ("'", "'") span buf (if endsInHash then len - 1 else len) >>= \case + [c] -> pure c + s -> panic $ "tok_char expected exactly one character, got: " ++ show s + pure . L span $ + if endsInHash + then ITprimchar src c + else ITchar src c + where + src = SourceText $ lexemeToFastString buf len + endsInHash = currentChar (offsetBytes (len - 1) buf) == '#' + + +-- ----------------------------------------------------------------------------- +-- QuasiQuote + +lex_qquasiquote_tok :: Action +lex_qquasiquote_tok span buf len _buf2 = do + let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False + quoteStart <- getParsedLoc + let quoter_span_start = advancePsLoc (psSpanStart span) '[' + quoter_span_end = foldl' advancePsLoc quoter_span_start + (take (len - 2) (repeat 'a')) + quoter_span = mkPsSpan quoter_span_start quoter_span_end + quote <- lex_quasiquote (psRealLoc quoteStart) "" + end <- getParsedLoc + return (L (mkPsSpan (psSpanStart span) end) + (ITqQuasiQuote (qual, + quoter, + quoter_span, + mkFastString (reverse quote), + mkPsSpan quoteStart end))) + +lex_quasiquote_tok :: Action +lex_quasiquote_tok span buf len _buf2 = do + let quoter = tail (lexemeToString buf (len - 1)) + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' + quoteStart <- getParsedLoc + let quoter_span_start = advancePsLoc (psSpanStart span) '[' + quoter_span_end = foldl' advancePsLoc quoter_span_start quoter + quoter_span = mkPsSpan quoter_span_start quoter_span_end + quote <- lex_quasiquote (psRealLoc quoteStart) "" + end <- getParsedLoc + return (L (mkPsSpan (psSpanStart span) end) + (ITquasiQuote (mkFastString quoter, + quoter_span, + mkFastString (reverse quote), + mkPsSpan quoteStart end))) + +lex_quasiquote :: RealSrcLoc -> String -> P String +lex_quasiquote start s = do + i <- getInput + case alexGetChar' i of + Nothing -> quasiquote_error start + + -- NB: The string "|]" terminates the quasiquote, + -- with absolutely no escaping. See the extensive + -- discussion on #5348 for why there is no + -- escape handling. + Just ('|',i) + | Just (']',i) <- alexGetChar' i + -> do { setInput i; return s } + + Just (c, i) -> do + setInput i; lex_quasiquote start (c : s) + +quasiquote_error :: RealSrcLoc -> P a +quasiquote_error start = do + (AI end buf) <- getInput + reportLexError start (psRealLoc end) buf + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k)) + +-- ----------------------------------------------------------------------------- +-- Unicode Smart Quote detection (#21843) + +isSmartQuote :: AlexAccPred ExtsBitmap +isSmartQuote _ _ _ (AI _ buf) = let c = prevChar buf ' ' in isSingleSmartQuote c || isDoubleSmartQuote c + +throwSmartQuoteError :: Char -> PsLoc -> P a +throwSmartQuoteError c loc = addFatalError err + where + err = + mkPlainErrorMsgEnvelope (mkSrcSpanPs (mkPsSpan loc loc)) $ + PsErrUnicodeCharLooksLike c correct_char correct_char_name + (correct_char, correct_char_name) = + if isSingleSmartQuote c + then ('\'', "Single Quote") + else ('"', "Quotation Mark") + +-- | Throw a smart quote error, where the smart quote was the last character lexed +smart_quote_error :: Action +smart_quote_error span _ _ buf2 = do + let c = prevChar buf2 (panic "smart_quote_error unexpectedly called on beginning of input") + throwSmartQuoteError c (psSpanStart span) + +-- Note [Bare smart quote error] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A smart quote inside of a string is allowed, but if a complete valid string +-- couldn't be lexed, we want to see if there's a smart quote that the user +-- thought ended the string, but in fact didn't. + +-- ----------------------------------------------------------------------------- +-- Warnings + +warnTab :: Action +warnTab srcspan _buf _len _buf2 = do + addTabWarning (psRealSpan srcspan) + lexToken + +warnThen :: PsMessage -> Action -> Action +warnThen warning action srcspan buf len buf2 = do + addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning + action srcspan buf len buf2 + +-- ----------------------------------------------------------------------------- +-- The Parse Monad + +-- | Do we want to generate ';' layout tokens? In some cases we just want to +-- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates +-- alternatives (unlike a `case` expression where we need ';' to as a separator +-- between alternatives). +type GenSemic = Bool + +generateSemic, dontGenerateSemic :: GenSemic +generateSemic = True +dontGenerateSemic = False + +data LayoutContext + = NoLayout + | Layout !Int !GenSemic + deriving Show + +-- | The result of running a parser. +newtype ParseResult a = PR (# (# PState, a #) | PState #) + +-- | The parser has consumed a (possibly empty) prefix of the input and produced +-- a result. Use 'getPsMessages' to check for accumulated warnings and non-fatal +-- errors. +-- +-- The carried parsing state can be used to resume parsing. +pattern POk :: PState -> a -> ParseResult a +pattern POk s a = PR (# (# s , a #) | #) + +-- | The parser has consumed a (possibly empty) prefix of the input and failed. +-- +-- The carried parsing state can be used to resume parsing. It is the state +-- right before failure, including the fatal parse error. 'getPsMessages' and +-- 'getPsErrorMessages' must return a non-empty bag of errors. +pattern PFailed :: PState -> ParseResult a +pattern PFailed s = PR (# | s #) + +{-# COMPLETE POk, PFailed #-} + +-- | Test whether a 'WarningFlag' is set +warnopt :: WarningFlag -> ParserOpts -> Bool +warnopt f options = f `EnumSet.member` pWarningFlags options + +-- | Parser options. +-- +-- See 'mkParserOpts' to construct this. +data ParserOpts = ParserOpts + { pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions + , pDiagOpts :: !DiagOpts + -- ^ Options to construct diagnostic messages. + } + +pWarningFlags :: ParserOpts -> EnumSet WarningFlag +pWarningFlags opts = diag_warning_flags (pDiagOpts opts) + +-- | Haddock comment as produced by the lexer. These are accumulated in 'PState' +-- and then processed in "GHC.Parser.PostProcess.Haddock". The location of the +-- 'HsDocString's spans over the contents of the docstring - i.e. it does not +-- include the decorator ("-- |", "{-|" etc.) +data HdkComment + = HdkCommentNext HsDocString + | HdkCommentPrev HsDocString + | HdkCommentNamed String HsDocString + | HdkCommentSection Int HsDocString + deriving Show + +data PState = PState { + buffer :: StringBuffer, + options :: ParserOpts, + warnings :: Messages PsMessage, + errors :: Messages PsMessage, + tab_first :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file + tab_count :: !Word, -- number of tab warnings in the file + last_tk :: Strict.Maybe (PsLocated Token), -- last non-comment token + prev_loc :: PsSpan, -- pos of previous non-virtual token, including comments, + last_loc :: PsSpan, -- pos of current token + last_len :: !Int, -- len of current token + loc :: PsLoc, -- current loc (end of prev token + 1) + context :: [LayoutContext], + lex_state :: [Int], + srcfiles :: [FastString], + -- Used in the alternative layout rule: + -- These tokens are the next ones to be sent out. They are + -- just blindly emitted, without the rule looking at them again: + alr_pending_implicit_tokens :: [PsLocated Token], + -- This is the next token to be considered or, if it is Nothing, + -- we need to get the next token from the input stream: + alr_next_token :: Maybe (PsLocated Token), + -- This is what we consider to be the location of the last token + -- emitted: + alr_last_loc :: PsSpan, + -- The stack of layout contexts: + alr_context :: [ALRContext], + -- Are we expecting a '{'? If it's Just, then the ALRLayout tells + -- us what sort of layout the '{' will open: + alr_expecting_ocurly :: Maybe ALRLayout, + -- Have we just had the '}' for a let block? If so, than an 'in' + -- token doesn't need to close anything: + alr_justClosedExplicitLetBlock :: Bool, + + -- The next three are used to implement Annotations giving the + -- locations of 'noise' tokens in the source, so that users of + -- the GHC API can do source to source conversions. + -- See Note [exact print annotations] in GHC.Parser.Annotation + eof_pos :: Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan), -- pos, gap to prior token + header_comments :: Strict.Maybe [LEpaComment], + comment_q :: [LEpaComment], + + -- Haddock comments accumulated in ascending order of their location + -- (BufPos). We use OrdList to get O(1) snoc. + -- + -- See Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock + hdk_comments :: OrdList (PsLocated HdkComment) + } + -- last_loc and last_len are used when generating error messages, + -- and in pushCurrentContext only. Sigh, if only Happy passed the + -- current token to happyError, we could at least get rid of last_len. + -- Getting rid of last_loc would require finding another way to + -- implement pushCurrentContext (which is only called from one place). + + -- AZ question: setLastToken which sets last_loc and last_len + -- is called when processing AlexToken, immediately prior to + -- calling the action in the token. So from the perspective + -- of the action, it is the *current* token. Do I understand + -- correctly? + +data ALRContext = ALRNoLayout Bool{- does it contain commas? -} + Bool{- is it a 'let' block? -} + | ALRLayout ALRLayout Int +data ALRLayout = ALRLayoutLet + | ALRLayoutWhere + | ALRLayoutOf + | ALRLayoutDo + +-- | The parsing monad, isomorphic to @StateT PState Maybe@. +newtype P a = P { unP :: PState -> ParseResult a } + +instance Functor P where + fmap = liftM + +instance Applicative P where + pure = returnP + (<*>) = ap + +instance Monad P where + (>>=) = thenP + +returnP :: a -> P a +returnP a = a `seq` (P $ \s -> POk s a) + +thenP :: P a -> (a -> P b) -> P b +(P m) `thenP` k = P $ \ s -> + case m s of + POk s1 a -> (unP (k a)) s1 + PFailed s1 -> PFailed s1 + +failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a +failMsgP f = do + pState <- getPState + addFatalError (f (mkSrcSpanPs (last_loc pState))) + +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a +failLocMsgP loc1 loc2 f = + addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing)) + +getPState :: P PState +getPState = P $ \s -> POk s s + +getExts :: P ExtsBitmap +getExts = P $ \s -> POk s (pExtsBitmap . options $ s) + +setExts :: (ExtsBitmap -> ExtsBitmap) -> P () +setExts f = P $ \s -> POk s { + options = + let p = options s + in p { pExtsBitmap = f (pExtsBitmap p) } + } () + +setSrcLoc :: RealSrcLoc -> P () +setSrcLoc new_loc = + P $ \s@(PState{ loc = PsLoc _ buf_loc }) -> + POk s{ loc = PsLoc new_loc buf_loc } () + +getRealSrcLoc :: P RealSrcLoc +getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s (psRealLoc loc) + +getParsedLoc :: P PsLoc +getParsedLoc = P $ \s@(PState{ loc=loc }) -> POk s loc + +addSrcFile :: FastString -> P () +addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () + +setEofPos :: RealSrcSpan -> RealSrcSpan -> P () +setEofPos span gap = P $ \s -> POk s{ eof_pos = Strict.Just (span `Strict.And` gap) } () + +setLastToken :: PsSpan -> Int -> P () +setLastToken loc len = P $ \s -> POk s { + last_loc=loc, + last_len=len + } () + +setLastTk :: PsLocated Token -> P () +setLastTk tk@(L l _) = P $ \s -> + if isPointRealSpan (psRealSpan l) + then POk s { last_tk = Strict.Just tk } () + else POk s { last_tk = Strict.Just tk + , prev_loc = l } () + +setLastComment :: PsLocated Token -> P () +setLastComment (L l _) = P $ \s -> POk s { prev_loc = l } () + +getLastTk :: P (Strict.Maybe (PsLocated Token)) +getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk + +-- see Note [PsSpan in Comments] +getLastLocIncludingComments :: P PsSpan +getLastLocIncludingComments = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc + +getLastLoc :: P PsSpan +getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc + +{-# INLINE alexGetChar' #-} +-- This version does not squash unicode characters, it is used when +-- lexing strings. +alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar' (AI loc s) + | atEnd s = Nothing + | otherwise = c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (c, (AI loc' s')) + where (c,s') = nextChar s + loc' = advancePsLoc loc c + +-- | Advance the given input N bytes. +advanceInputBytes :: Int -> AlexInput -> AlexInput +advanceInputBytes n i0@(AI _ buf0) = advanceInputTo (cur buf0 + n) i0 + +-- | Advance the given input to the given position. +advanceInputTo :: Int -> AlexInput -> AlexInput +advanceInputTo pos = go + where + go i@(AI _ buf) + | cur buf >= pos = i + | Just (_, i') <- alexGetChar' i = go i' + | otherwise = i -- reached the end, just return the last input + +getInput :: P AlexInput +getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) + +setInput :: AlexInput -> P () +setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () + +nextIsEOF :: P Bool +nextIsEOF = isEOF <$> getInput + +isEOF :: AlexInput -> Bool +isEOF (AI _ buf) = atEnd buf + +pushLexState :: Int -> P () +pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () + +popLexState :: P Int +popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls + +getLexState :: P Int +getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls + +popNextToken :: P (Maybe (PsLocated Token)) +popNextToken + = P $ \s@PState{ alr_next_token = m } -> + POk (s {alr_next_token = Nothing}) m + +activeContext :: P Bool +activeContext = do + ctxt <- getALRContext + expc <- getAlrExpectingOCurly + impt <- implicitTokenPending + case (ctxt,expc) of + ([],Nothing) -> return impt + _other -> return True + +resetAlrLastLoc :: FastString -> P () +resetAlrLastLoc file = + P $ \s@(PState {alr_last_loc = PsSpan _ buf_span}) -> + POk s{ alr_last_loc = PsSpan (alrInitialLoc file) buf_span } () + +setAlrLastLoc :: PsSpan -> P () +setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () + +getAlrLastLoc :: P PsSpan +getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l + +getALRContext :: P [ALRContext] +getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs + +setALRContext :: [ALRContext] -> P () +setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () + +getJustClosedExplicitLetBlock :: P Bool +getJustClosedExplicitLetBlock + = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b + +setJustClosedExplicitLetBlock :: Bool -> P () +setJustClosedExplicitLetBlock b + = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () + +setNextToken :: PsLocated Token -> P () +setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () + +implicitTokenPending :: P Bool +implicitTokenPending + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s False + _ -> POk s True + +popPendingImplicitToken :: P (Maybe (PsLocated Token)) +popPendingImplicitToken + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s Nothing + (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) + +setPendingImplicitTokens :: [PsLocated Token] -> P () +setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () + +getAlrExpectingOCurly :: P (Maybe ALRLayout) +getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b + +setAlrExpectingOCurly :: Maybe ALRLayout -> P () +setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () + +-- | For reasons of efficiency, boolean parsing flags (eg, language extensions +-- or whether we are currently in a @RULE@ pragma) are represented by a bitmap +-- stored in a @Word64@. +type ExtsBitmap = Word64 + +xbit :: ExtBits -> ExtsBitmap +xbit = bit . fromEnum + +xtest :: ExtBits -> ExtsBitmap -> Bool +xtest ext xmap = testBit xmap (fromEnum ext) + +xset :: ExtBits -> ExtsBitmap -> ExtsBitmap +xset ext xmap = setBit xmap (fromEnum ext) + +xunset :: ExtBits -> ExtsBitmap -> ExtsBitmap +xunset ext xmap = clearBit xmap (fromEnum ext) + +-- | Various boolean flags, mostly language extensions, that impact lexing and +-- parsing. Note that a handful of these can change during lexing/parsing. +data ExtBits + -- Flags that are constant once parsing starts + = FfiBit + | InterruptibleFfiBit + | CApiFfiBit + | ArrowsBit + | ThBit + | ThQuotesBit + | IpBit + | OverloadedLabelsBit -- #x overloaded labels + | ExplicitForallBit -- the 'forall' keyword + | BangPatBit -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) + | PatternSynonymsBit -- pattern synonyms + | HaddockBit-- Lex and parse Haddock comments + | MagicHashBit -- "#" in both functions and operators + | RecursiveDoBit -- mdo + | QualifiedDoBit -- .do and .mdo + | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc + | UnboxedParensBit -- (# and #) + | DatatypeContextsBit + | MonadComprehensionsBit + | TransformComprehensionsBit + | QqBit -- enable quasiquoting + | RawTokenStreamBit -- producing a token stream with all comments included + | AlternativeLayoutRuleBit + | ALRTransitionalBit + | RelaxedLayoutBit + | NondecreasingIndentationBit + | SafeHaskellBit + | TraditionalRecordSyntaxBit + | ExplicitNamespacesBit + | LambdaCaseBit + | BinaryLiteralsBit + | NegativeLiteralsBit + | HexFloatLiteralsBit + | StaticPointersBit + | NumericUnderscoresBit + | StarIsTypeBit + | BlockArgumentsBit + | NPlusKPatternsBit + | DoAndIfThenElseBit + | MultiWayIfBit + | GadtSyntaxBit + | ImportQualifiedPostBit + | LinearTypesBit + | NoLexicalNegationBit -- See Note [Why not LexicalNegationBit] + | OverloadedRecordDotBit + | OverloadedRecordUpdateBit + | OrPatternsBit + | ExtendedLiteralsBit + | ListTuplePunsBit + | ViewPatternsBit + | RequiredTypeArgumentsBit + | MultilineStringsBit + | LevelImportsBit + + -- Flags that are updated once parsing starts + | InRulePragBit + | InNestedCommentBit -- See Note [Nested comment line pragmas] + | UsePosPragsBit + -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' + -- update the internal position. Otherwise, those pragmas are lexed as + -- tokens of their own. + deriving Enum + +{-# INLINE mkParserOpts #-} +mkParserOpts + :: EnumSet LangExt.Extension -- ^ permitted language extensions enabled + -> DiagOpts -- ^ diagnostic options + -> Bool -- ^ are safe imports on? + -> Bool -- ^ keeping Haddock comment tokens + -> Bool -- ^ keep regular comment tokens + + -> Bool + -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update + -- the internal position kept by the parser. Otherwise, those pragmas are + -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens. + + -> ParserOpts +-- ^ Given exactly the information needed, set up the 'ParserOpts' +mkParserOpts extensionFlags diag_opts + safeImports isHaddock rawTokStream usePosPrags = + ParserOpts { + pDiagOpts = diag_opts + , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits + } + where + safeHaskellBit = SafeHaskellBit `setBitIf` safeImports + langExtBits = + FfiBit `xoptBit` LangExt.ForeignFunctionInterface + .|. InterruptibleFfiBit `xoptBit` LangExt.InterruptibleFFI + .|. CApiFfiBit `xoptBit` LangExt.CApiFFI + .|. ArrowsBit `xoptBit` LangExt.Arrows + .|. ThBit `xoptBit` LangExt.TemplateHaskell + .|. ThQuotesBit `xoptBit` LangExt.TemplateHaskellQuotes + .|. QqBit `xoptBit` LangExt.QuasiQuotes + .|. IpBit `xoptBit` LangExt.ImplicitParams + .|. OverloadedLabelsBit `xoptBit` LangExt.OverloadedLabels + .|. ExplicitForallBit `xoptBit` LangExt.ExplicitForAll + .|. BangPatBit `xoptBit` LangExt.BangPatterns + .|. MagicHashBit `xoptBit` LangExt.MagicHash + .|. RecursiveDoBit `xoptBit` LangExt.RecursiveDo + .|. QualifiedDoBit `xoptBit` LangExt.QualifiedDo + .|. UnicodeSyntaxBit `xoptBit` LangExt.UnicodeSyntax + .|. UnboxedParensBit `orXoptsBit` [LangExt.UnboxedTuples, LangExt.UnboxedSums] + .|. DatatypeContextsBit `xoptBit` LangExt.DatatypeContexts + .|. TransformComprehensionsBit `xoptBit` LangExt.TransformListComp + .|. MonadComprehensionsBit `xoptBit` LangExt.MonadComprehensions + .|. AlternativeLayoutRuleBit `xoptBit` LangExt.AlternativeLayoutRule + .|. ALRTransitionalBit `xoptBit` LangExt.AlternativeLayoutRuleTransitional + .|. RelaxedLayoutBit `xoptBit` LangExt.RelaxedLayout + .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation + .|. TraditionalRecordSyntaxBit `xoptBit` LangExt.TraditionalRecordSyntax + .|. ExplicitNamespacesBit `xoptBit` LangExt.ExplicitNamespaces + .|. LambdaCaseBit `xoptBit` LangExt.LambdaCase + .|. BinaryLiteralsBit `xoptBit` LangExt.BinaryLiterals + .|. NegativeLiteralsBit `xoptBit` LangExt.NegativeLiterals + .|. HexFloatLiteralsBit `xoptBit` LangExt.HexFloatLiterals + .|. PatternSynonymsBit `xoptBit` LangExt.PatternSynonyms + .|. StaticPointersBit `xoptBit` LangExt.StaticPointers + .|. NumericUnderscoresBit `xoptBit` LangExt.NumericUnderscores + .|. StarIsTypeBit `xoptBit` LangExt.StarIsType + .|. BlockArgumentsBit `xoptBit` LangExt.BlockArguments + .|. NPlusKPatternsBit `xoptBit` LangExt.NPlusKPatterns + .|. DoAndIfThenElseBit `xoptBit` LangExt.DoAndIfThenElse + .|. MultiWayIfBit `xoptBit` LangExt.MultiWayIf + .|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax + .|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost + .|. LinearTypesBit `xoptBit` LangExt.LinearTypes + .|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit] + .|. OverloadedRecordDotBit `xoptBit` LangExt.OverloadedRecordDot + .|. OverloadedRecordUpdateBit `xoptBit` LangExt.OverloadedRecordUpdate -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information). + .|. OrPatternsBit `xoptBit` LangExt.OrPatterns + .|. ExtendedLiteralsBit `xoptBit` LangExt.ExtendedLiterals + .|. ListTuplePunsBit `xoptBit` LangExt.ListTuplePuns + .|. ViewPatternsBit `xoptBit` LangExt.ViewPatterns + .|. RequiredTypeArgumentsBit `xoptBit` LangExt.RequiredTypeArguments + .|. MultilineStringsBit `xoptBit` LangExt.MultilineStrings + .|. LevelImportsBit `xoptBit` LangExt.ExplicitLevelImports + optBits = + HaddockBit `setBitIf` isHaddock + .|. RawTokenStreamBit `setBitIf` rawTokStream + .|. UsePosPragsBit `setBitIf` usePosPrags + + xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags + xoptNotBit bit ext = bit `setBitIf` not (EnumSet.member ext extensionFlags) + + orXoptsBit bit exts = bit `setBitIf` any (`EnumSet.member` extensionFlags) exts + + setBitIf :: ExtBits -> Bool -> ExtsBitmap + b `setBitIf` cond | cond = xbit b + | otherwise = 0 + +disableHaddock :: ParserOpts -> ParserOpts +disableHaddock opts = upd_bitmap (xunset HaddockBit) + where + upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) } + + +-- | Set parser options for parsing OPTIONS pragmas +initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState +initPragState options buf loc = (initParserState options buf loc) + { lex_state = [bol, option_prags, 0] + } + +-- | Creates a parse state from a 'ParserOpts' value +initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState +initParserState options buf loc = + PState { + buffer = buf, + options = options, + errors = emptyMessages, + warnings = emptyMessages, + tab_first = Strict.Nothing, + tab_count = 0, + last_tk = Strict.Nothing, + prev_loc = mkPsSpan init_loc init_loc, + last_loc = mkPsSpan init_loc init_loc, + last_len = 0, + loc = init_loc, + context = [], + lex_state = [bol, 0], + srcfiles = [], + alr_pending_implicit_tokens = [], + alr_next_token = Nothing, + alr_last_loc = PsSpan (alrInitialLoc (fsLit "")) (BufSpan (BufPos 0) (BufPos 0)), + alr_context = [], + alr_expecting_ocurly = Nothing, + alr_justClosedExplicitLetBlock = False, + eof_pos = Strict.Nothing, + header_comments = Strict.Nothing, + comment_q = [], + hdk_comments = nilOL + } + where init_loc = PsLoc loc (BufPos 0) + +-- | An mtl-style class for monads that support parsing-related operations. +-- For example, sometimes we make a second pass over the parsing results to validate, +-- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume +-- input but can report parsing errors, check for extension bits, and accumulate +-- parsing annotations. Both P and PV are instances of MonadP. +-- +-- MonadP grants us convenient overloading. The other option is to have separate operations +-- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on. +-- +class Monad m => MonadP m where + -- | Add a non-fatal error. Use this when the parser can produce a result + -- despite the error. + -- + -- For example, when GHC encounters a @forall@ in a type, + -- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@ + -- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to + -- the accumulator. + -- + -- Control flow wise, non-fatal errors act like warnings: they are added + -- to the accumulator and parsing continues. This allows GHC to report + -- more than one parse error per file. + -- + addError :: MsgEnvelope PsMessage -> m () + + -- | Add a warning to the accumulator. + -- Use 'getPsMessages' to get the accumulated warnings. + addWarning :: MsgEnvelope PsMessage -> m () + + -- | Add a fatal error. This will be the last error reported by the parser, and + -- the parser will not produce any result, ending in a 'PFailed' state. + addFatalError :: MsgEnvelope PsMessage -> m a + + -- | Get parser options + getParserOpts :: m ParserOpts + + -- | Go through the @comment_q@ in @PState@ and remove all comments + -- that belong within the given span + allocateCommentsP :: RealSrcSpan -> m EpAnnComments + -- | Go through the @comment_q@ in @PState@ and remove all comments + -- that come before or within the given span + allocatePriorCommentsP :: RealSrcSpan -> m EpAnnComments + -- | Go through the @comment_q@ in @PState@ and remove all comments + -- that come after the given span + allocateFinalCommentsP :: RealSrcSpan -> m EpAnnComments + +instance MonadP P where + addError err + = P $ \s -> POk s { errors = err `addMessage` errors s} () + + -- If the warning is meant to be suppressed, GHC will assign + -- a `SevIgnore` severity and the message will be discarded, + -- so we can simply add it no matter what. + addWarning w + = P $ \s -> POk (s { warnings = w `addMessage` warnings s }) () + + addFatalError err = + addError err >> P PFailed + + getParserOpts = P $ \s -> POk s $! options s + + allocateCommentsP ss = P $ \s -> + if null (comment_q s) then POk s emptyComments else -- fast path + let (comment_q', newAnns) = allocateComments ss (comment_q s) in + POk s { + comment_q = comment_q' + } (EpaComments newAnns) + allocatePriorCommentsP ss = P $ \s -> + let (header_comments', comment_q', newAnns) + = allocatePriorComments ss (comment_q s) (header_comments s) in + POk s { + header_comments = header_comments', + comment_q = comment_q' + } (EpaComments newAnns) + allocateFinalCommentsP ss = P $ \s -> + let (header_comments', comment_q', newAnns) + = allocateFinalComments ss (comment_q s) (header_comments s) in + POk s { + header_comments = header_comments', + comment_q = comment_q' + } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns) + +-- | Check if a given flag is currently set in the bitmap. +getBit :: MonadP m => ExtBits -> m Bool +getBit ext = (\opts -> ext `xtest` pExtsBitmap opts) <$> getParserOpts + +getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments +getCommentsFor (RealSrcSpan l _) = allocateCommentsP l +getCommentsFor _ = return emptyComments + +getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments +getPriorCommentsFor (RealSrcSpan l _) = allocatePriorCommentsP l +getPriorCommentsFor _ = return emptyComments + +getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments +getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l +getFinalCommentsFor _ = return emptyComments + +getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan)) +getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos + +addPsMessage :: MonadP m => SrcSpan -> PsMessage -> m () +addPsMessage srcspan msg = do + diag_opts <- pDiagOpts <$> getParserOpts + addWarning (mkPlainMsgEnvelope diag_opts srcspan msg) + +addTabWarning :: RealSrcSpan -> P () +addTabWarning srcspan + = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> + let tf' = tf <|> Strict.Just srcspan + tc' = tc + 1 + s' = if warnopt Opt_WarnTabs o + then s{tab_first = tf', tab_count = tc'} + else s + in POk s' () + +-- | Get a bag of the errors that have been accumulated so far. +-- Does not take -Werror into account. +getPsErrorMessages :: PState -> Messages PsMessage +getPsErrorMessages p = errors p + +-- | Get the warnings and errors accumulated so far. +-- Does not take -Werror into account. +getPsMessages :: PState -> (Messages PsMessage, Messages PsMessage) +getPsMessages p = + let ws = warnings p + diag_opts = pDiagOpts (options p) + -- we add the tabulation warning on the fly because + -- we count the number of occurrences of tab characters + ws' = case tab_first p of + Strict.Nothing -> ws + Strict.Just tf -> + let msg = mkPlainMsgEnvelope diag_opts + (RealSrcSpan tf Strict.Nothing) + (PsWarnTab (tab_count p)) + in msg `addMessage` ws + in (ws', errors p) + +getContext :: P [LayoutContext] +getContext = P $ \s@PState{context=ctx} -> POk s ctx + +setContext :: [LayoutContext] -> P () +setContext ctx = P $ \s -> POk s{context=ctx} () + +popContext :: P () +popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, + last_len = len, last_loc = last_loc }) -> + case ctx of + (_:tl) -> + POk s{ context = tl } () + [] -> + unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s + +-- Push a new layout context at the indentation of the last token read. +pushCurrentContext :: GenSemic -> P () +pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } -> + POk s{context = Layout (srcSpanStartCol (psRealSpan loc)) gen_semic : ctx} () + +-- This is only used at the outer level of a module when the 'module' keyword is +-- missing. +pushModuleContext :: P () +pushModuleContext = pushCurrentContext generateSemic + +getOffside :: P (Ordering, Bool) +getOffside = P $ \s@PState{last_loc=loc, context=stk} -> + let offs = srcSpanStartCol (psRealSpan loc) in + let ord = case stk of + Layout n gen_semic : _ -> + --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + (compare offs n, gen_semic) + _ -> + (GT, dontGenerateSemic) + in POk s ord + +-- --------------------------------------------------------------------------- +-- Construct a parse error + +srcParseErr + :: ParserOpts + -> StringBuffer -- current buffer (placed just after the last token) + -> Int -- length of the previous token + -> SrcSpan + -> MsgEnvelope PsMessage +srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token details) + where + token = lexemeToString (offsetBytes (-len) buf) len + pattern_ = decodePrevNChars 8 buf + last100 = decodePrevNChars 100 buf + doInLast100 = "do" `isInfixOf` last100 + mdoInLast100 = "mdo" `isInfixOf` last100 + th_enabled = ThQuotesBit `xtest` pExtsBitmap options + ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options + details = PsErrParseDetails { + ped_th_enabled = th_enabled + , ped_do_in_last_100 = doInLast100 + , ped_mdo_in_last_100 = mdoInLast100 + , ped_pat_syn_enabled = ps_enabled + , ped_pattern_parsed = pattern_ == "pattern " + } + +-- Report a parse failure, giving the span of the previous token as +-- the location of the error. This is the entry point for errors +-- detected during parsing. +srcParseFail :: P a +srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, + last_loc = last_loc } -> + unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s + +-- A lexical error is reported at a particular position in the source file, +-- not over a token range. +lexError :: LexErr -> P a +lexError e = do + loc <- getRealSrcLoc + (AI end buf) <- getInput + reportLexError loc (psRealLoc end) buf + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer e k) + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +lexer, lexerDbg :: Bool -> (Located Token -> P a) -> P a + +lexer queueComments cont = do + alr <- getBit AlternativeLayoutRuleBit + let lexTokenFun = if alr then lexTokenAlr else lexToken + (L span tok) <- lexTokenFun + --trace ("token: " ++ show tok) $ do + + if (queueComments && isComment tok) + then queueComment (L (psRealSpan span) tok) >> lexer queueComments cont + else cont (L (mkSrcSpanPs span) tok) + +-- Use this instead of 'lexer' in GHC.Parser to dump the tokens for debugging. +lexerDbg queueComments cont = lexer queueComments contDbg + where + contDbg tok = trace ("token: " ++ show (unLoc tok)) (cont tok) + +lexTokenAlr :: P (PsLocated Token) +lexTokenAlr = do mPending <- popPendingImplicitToken + t <- case mPending of + Nothing -> + do mNext <- popNextToken + t <- case mNext of + Nothing -> lexToken + Just next -> return next + alternativeLayoutRuleToken t + Just t -> + return t + setAlrLastLoc (getLoc t) + case unLoc t of + ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) + ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) + ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITlcases -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITmdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) + _ -> return () + return t + +alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token) +alternativeLayoutRuleToken t + = do context <- getALRContext + lastLoc <- getAlrLastLoc + mExpectingOCurly <- getAlrExpectingOCurly + transitional <- getBit ALRTransitionalBit + justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock + setJustClosedExplicitLetBlock False + let thisLoc = getLoc t + thisCol = srcSpanStartCol (psRealSpan thisLoc) + newLine = srcSpanStartLine (psRealSpan thisLoc) > srcSpanEndLine (psRealSpan lastLoc) + case (unLoc t, context, mExpectingOCurly) of + -- This case handles a GHC extension to the original H98 + -- layout rule... + (ITocurly, _, Just alrLayout) -> + do setAlrExpectingOCurly Nothing + let isLet = case alrLayout of + ALRLayoutLet -> True + _ -> False + setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) + return t + -- ...and makes this case unnecessary + {- + -- I think our implicit open-curly handling is slightly + -- different to John's, in how it interacts with newlines + -- and "in" + (ITocurly, _, Just _) -> + do setAlrExpectingOCurly Nothing + setNextToken t + lexTokenAlr + -} + (_, ALRLayout _ col : _ls, Just expectingOCurly) + | (thisCol > col) || + (thisCol == col && + isNonDecreasingIndentation expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITvocurly) + | otherwise -> + do setAlrExpectingOCurly Nothing + setPendingImplicitTokens [L lastLoc ITvccurly] + setNextToken t + return (L lastLoc ITvocurly) + (_, _, Just expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITvocurly) + -- We do the [] cases earlier than in the spec, as we + -- have an actual EOF token + (ITeof, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + (ITeof, _, _) -> + return t + -- the other ITeof case omitted; general case below covers it + (ITin, _, _) + | justClosedExplicitLetBlock -> + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) + | newLine -> + do setPendingImplicitTokens [t] + setALRContext ls + return (L thisLoc ITvccurly) + -- This next case is to handle a transitional issue: + (ITwhere, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addPsMessage + (mkSrcSpanPs thisLoc) + (PsWarnTransitionalLayout TransLayout_Where) + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + -- This next case is to handle a transitional issue: + (ITvbar, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addPsMessage + (mkSrcSpanPs thisLoc) + (PsWarnTransitionalLayout TransLayout_Pipe) + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + (_, ALRLayout _ col : ls, _) + | newLine && thisCol == col -> + do setNextToken t + let loc = psSpanStart thisLoc + zeroWidthLoc = mkPsSpan loc loc + return (L zeroWidthLoc ITsemi) + | newLine && thisCol < col -> + do setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + -- We need to handle close before open, as 'then' is both + -- an open and a close + (u, _, _) + | isALRclose u -> + case context of + ALRLayout _ _ : ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + ALRNoLayout _ isLet : ls -> + do let ls' = if isALRopen u + then ALRNoLayout (containsCommas u) False : ls + else ls + setALRContext ls' + when isLet $ setJustClosedExplicitLetBlock True + return t + [] -> + do let ls = if isALRopen u + then [ALRNoLayout (containsCommas u) False] + else [] + setALRContext ls + -- XXX This is an error in John's code, but + -- it looks reachable to me at first glance + return t + (u, _, _) + | isALRopen u -> + do setALRContext (ALRNoLayout (containsCommas u) False : context) + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITvccurly) + (ITin, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + -- the other ITin case omitted; general case below covers it + (ITcomma, ALRLayout _ _ : ls, _) + | topNoLayoutContainsCommas ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITvccurly) + -- the other ITwhere case omitted; general case below covers it + (_, _, _) -> return t + +isALRopen :: Token -> Bool +isALRopen ITcase = True +isALRopen ITif = True +isALRopen ITthen = True +isALRopen IToparen = True +isALRopen ITobrack = True +isALRopen ITocurly = True +-- GHC Extensions: +isALRopen IToubxparen = True +isALRopen _ = False + +isALRclose :: Token -> Bool +isALRclose ITof = True +isALRclose ITthen = True +isALRclose ITelse = True +isALRclose ITcparen = True +isALRclose ITcbrack = True +isALRclose ITccurly = True +-- GHC Extensions: +isALRclose ITcubxparen = True +isALRclose _ = False + +isNonDecreasingIndentation :: ALRLayout -> Bool +isNonDecreasingIndentation ALRLayoutDo = True +isNonDecreasingIndentation _ = False + +containsCommas :: Token -> Bool +containsCommas IToparen = True +containsCommas ITobrack = True +-- John doesn't have {} as containing commas, but records contain them, +-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs +-- (defaultInstallDirs). +containsCommas ITocurly = True +-- GHC Extensions: +containsCommas IToubxparen = True +containsCommas _ = False + +topNoLayoutContainsCommas :: [ALRContext] -> Bool +topNoLayoutContainsCommas [] = False +topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls +topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b + +#ifdef MIN_TOOL_VERSION_alex +#if !MIN_TOOL_VERSION_alex(3,5,2) +-- If the generated alexScan/alexScanUser functions are called multiple times +-- in this file, alexScanUser gets broken out into a separate function and +-- increases memory usage. Make sure GHC inlines this function and optimizes it. +-- https://github.com/haskell/alex/pull/262 +{-# INLINE alexScanUser #-} +#endif +#endif + +lexToken :: P (PsLocated Token) +lexToken = do + inp@(AI loc1 buf) <- getInput + sc <- getLexState + exts <- getExts + case alexScanUser exts inp sc of + AlexEOF -> do + let span = mkPsSpan loc1 loc1 + lc <- getLastLocIncludingComments + setEofPos (psRealSpan span) (psRealSpan lc) + setLastToken span 0 + return (L span ITeof) + AlexError (AI loc2 buf) -> + reportLexError (psRealLoc loc1) (psRealLoc loc2) buf + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexError k) + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(AI end buf2) _ t -> do + setInput inp2 + let span = mkPsSpan loc1 end + let bytes = byteDiff buf buf2 + span `seq` setLastToken span bytes + lt <- t span buf bytes buf2 + let lt' = unLoc lt + if (isComment lt') then setLastComment lt else setLastTk lt + return lt + +reportLexError :: RealSrcLoc + -> RealSrcLoc + -> StringBuffer + -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage) + -> P a +reportLexError loc1 loc2 buf f + | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF) + | otherwise = + let c = fst (nextChar buf) + in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# + then failLocMsgP loc2 loc2 (f LexErrKind_UTF8) + else failLocMsgP loc1 loc2 (f (LexErrKind_Char c)) + +lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token] +lexTokenStream opts buf loc = unP go initState{ options = opts' } + where + new_exts = xunset UsePosPragsBit -- parse LINE/COLUMN pragmas as tokens + $ xset RawTokenStreamBit -- include comments + $ pExtsBitmap opts + opts' = opts { pExtsBitmap = new_exts } + initState = initParserState opts' buf loc + go = do + ltok <- lexer False return + case ltok of + L _ ITeof -> return [] + _ -> liftM (ltok:) go + +linePrags = Map.singleton "line" linePrag + +fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), + ("options_ghc", lex_string_prag IToptions_prag), + ("options_haddock", lex_string_prag_comment ITdocOptions), + ("language", token ITlanguage_prag), + ("include", lex_string_prag ITinclude_prag)]) + +ignoredPrags = Map.fromList (map ignored pragmas) + where ignored opt = (opt, nested_comment) + impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] + options_pragmas = map ("options_" ++) impls + -- CFILES is a hugs-only thing. + pragmas = options_pragmas ++ ["cfiles", "contract"] + +oneWordPrags = Map.fromList [ + ("rules", rulePrag), + ("inline", + fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))), + ("inlinable", + fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))), + ("inlineable", + fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))), + -- Spelling variant + ("notinline", + fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))), + ("opaque", fstrtoken (\s -> ITopaque_prag (SourceText s))), + ("specialize", fstrtoken (\s -> ITspec_prag (SourceText s))), + ("source", fstrtoken (\s -> ITsource_prag (SourceText s))), + ("warning", fstrtoken (\s -> ITwarning_prag (SourceText s))), + ("deprecated", fstrtoken (\s -> ITdeprecated_prag (SourceText s))), + ("scc", fstrtoken (\s -> ITscc_prag (SourceText s))), + ("unpack", fstrtoken (\s -> ITunpack_prag (SourceText s))), + ("nounpack", fstrtoken (\s -> ITnounpack_prag (SourceText s))), + ("ann", fstrtoken (\s -> ITann_prag (SourceText s))), + ("minimal", fstrtoken (\s -> ITminimal_prag (SourceText s))), + ("overlaps", fstrtoken (\s -> IToverlaps_prag (SourceText s))), + ("overlappable", fstrtoken (\s -> IToverlappable_prag (SourceText s))), + ("overlapping", fstrtoken (\s -> IToverlapping_prag (SourceText s))), + ("incoherent", fstrtoken (\s -> ITincoherent_prag (SourceText s))), + ("ctype", fstrtoken (\s -> ITctype (SourceText s))), + ("complete", fstrtoken (\s -> ITcomplete_prag (SourceText s))), + ("column", columnPrag) + ] + +twoWordPrags = Map.fromList [ + ("inline conlike", + fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))), + ("notinline conlike", + fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))), + ("specialize inline", + fstrtoken (\s -> (ITspec_inline_prag (SourceText s) True))), + ("specialize notinline", + fstrtoken (\s -> (ITspec_inline_prag (SourceText s) False))) + ] + +dispatch_pragmas :: Map String Action -> Action +dispatch_pragmas prags span buf len buf2 = + case Map.lookup (clean_pragma (lexemeToString buf len)) prags of + Just found -> found span buf len buf2 + Nothing -> lexError LexUnknownPragma + +known_pragma :: Map String Action -> AlexAccPred ExtsBitmap +known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) + = isKnown && nextCharIsNot curbuf pragmaNameChar + where l = lexemeToString startbuf (byteDiff startbuf curbuf) + isKnown = isJust $ Map.lookup (clean_pragma l) prags + pragmaNameChar c = isAlphaNum c || c == '_' + +clean_pragma :: String -> String +clean_pragma prag = canon_ws (map toLower (unprefix prag)) + where unprefix prag' = case stripPrefix "{-#" prag' of + Just rest -> rest + Nothing -> prag' + canonical prag' = case prag' of + "noinline" -> "notinline" + "specialise" -> "specialize" + "constructorlike" -> "conlike" + _ -> prag' + canon_ws s = unwords (map canonical (words s)) + +warn_unknown_prag :: Map String Action -> Action +warn_unknown_prag prags span buf len buf2 = do + let uppercase = map toUpper + unknown_prag = uppercase (clean_pragma (lexemeToString buf len)) + suggestions = map uppercase (Map.keys prags) + addPsMessage (RealSrcSpan (psRealSpan span) Strict.Nothing) $ + PsWarnUnrecognisedPragma unknown_prag suggestions + nested_comment span buf len buf2 + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ +-} + +-- TODO:AZ: we should have only mkParensEpToks. Delee mkParensEpAnn, mkParensLocs + +-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate +-- 'EpToken' values for the opening and closing bordering on the start +-- and end of the span +mkParensEpToks :: RealSrcSpan -> (EpToken "(", EpToken ")") +mkParensEpToks ss = (EpTok (EpaSpan (RealSrcSpan lo Strict.Nothing)), + EpTok (EpaSpan (RealSrcSpan lc Strict.Nothing))) + where + f = srcSpanFile ss + sl = srcSpanStartLine ss + sc = srcSpanStartCol ss + el = srcSpanEndLine ss + ec = srcSpanEndCol ss + lo = mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1)) + lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss) + + +-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate +-- 'EpaLocation' values for the opening and closing bordering on the start +-- and end of the span +mkParensLocs :: RealSrcSpan -> (EpaLocation, EpaLocation) +mkParensLocs ss = (EpaSpan (RealSrcSpan lo Strict.Nothing), + EpaSpan (RealSrcSpan lc Strict.Nothing)) + where + f = srcSpanFile ss + sl = srcSpanStartLine ss + sc = srcSpanStartCol ss + el = srcSpanEndLine ss + ec = srcSpanEndCol ss + lo = mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1)) + lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss) + +queueComment :: RealLocated Token -> P() +queueComment c = P $ \s -> POk s { + comment_q = commentToAnnotation c : comment_q s + } () + +allocateComments + :: RealSrcSpan + -> [LEpaComment] + -> ([LEpaComment], [LEpaComment]) +allocateComments ss comment_q = + let + (before,rest) = break (\(L l _) -> isRealSubspanOf (epaLocationRealSrcSpan l) ss) comment_q + (middle,after) = break (\(L l _) -> not (isRealSubspanOf (epaLocationRealSrcSpan l) ss)) rest + comment_q' = before ++ after + newAnns = middle + in + (comment_q', reverse newAnns) + +-- Comments appearing without a line-break before the first +-- declaration are associated with the declaration +splitPriorComments + :: RealSrcSpan + -> [LEpaComment] + -> ([LEpaComment], [LEpaComment]) +splitPriorComments ss prior_comments = + let + -- True if there is only one line between the earlier and later span, + -- And the token preceding the comment is on a different line + cmp :: RealSrcSpan -> LEpaComment -> Bool + cmp later (L l c) + = srcSpanStartLine later - srcSpanEndLine (epaLocationRealSrcSpan l) == 1 + && srcSpanEndLine (ac_prior_tok c) /= srcSpanStartLine (epaLocationRealSrcSpan l) + + go :: [LEpaComment] -> RealSrcSpan -> [LEpaComment] + -> ([LEpaComment], [LEpaComment]) + go decl_comments _ [] = ([],decl_comments) + go decl_comments r (c@(L l _):cs) = if cmp r c + then go (c:decl_comments) (epaLocationRealSrcSpan l) cs + else (reverse (c:cs), decl_comments) + in + go [] ss prior_comments + +allocatePriorComments + :: RealSrcSpan + -> [LEpaComment] + -> Strict.Maybe [LEpaComment] + -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment]) +allocatePriorComments ss comment_q mheader_comments = + let + cmp (L l _) = epaLocationRealSrcSpan l <= ss + (newAnns,after) = partition cmp comment_q + comment_q'= after + (prior_comments, decl_comments) = splitPriorComments ss newAnns + in + case mheader_comments of + Strict.Nothing -> (Strict.Just prior_comments, comment_q', decl_comments) + Strict.Just _ -> (mheader_comments, comment_q', reverse newAnns) + +allocateFinalComments + :: RealSrcSpan + -> [LEpaComment] + -> Strict.Maybe [LEpaComment] + -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment]) +allocateFinalComments _ss comment_q mheader_comments = + -- We ignore the RealSrcSpan as the parser currently provides a + -- point span at (1,1). + case mheader_comments of + Strict.Nothing -> (Strict.Just (reverse comment_q), [], []) + Strict.Just _ -> (mheader_comments, [], reverse comment_q) + +commentToAnnotation :: RealLocated Token -> LEpaComment +commentToAnnotation (L l (ITdocComment s ll)) = mkLEpaComment l ll (EpaDocComment s) +commentToAnnotation (L l (ITdocOptions s ll)) = mkLEpaComment l ll (EpaDocOptions s) +commentToAnnotation (L l (ITlineComment s ll)) = mkLEpaComment l ll (EpaLineComment s) +commentToAnnotation (L l (ITblockComment s ll)) = mkLEpaComment l ll (EpaBlockComment s) +commentToAnnotation _ = panic "commentToAnnotation" + +-- see Note [PsSpan in Comments] +mkLEpaComment :: RealSrcSpan -> PsSpan -> EpaCommentTok -> LEpaComment +mkLEpaComment l ll tok = L (realSpanAsAnchor l) (EpaComment tok (psRealSpan ll)) + +-- --------------------------------------------------------------------- + +isComment :: Token -> Bool +isComment (ITlineComment _ _) = True +isComment (ITblockComment _ _) = True +isComment (ITdocComment _ _) = True +isComment (ITdocOptions _ _) = True +isComment _ = False diff --git a/GHC/Parser/Lexer/Interface.hs b/GHC/Parser/Lexer/Interface.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Lexer/Interface.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE MagicHash #-} + +{- | +This module defines the types and functions necessary for an Alex-generated +lexer. + +https://haskell-alex.readthedocs.io/en/latest/api.html# +-} +module GHC.Parser.Lexer.Interface ( + AlexInput (..), + alexGetByte, + alexInputPrevChar, + + -- * Helpers + alexGetChar, + adjustChar, +) where + +import GHC.Prelude + +import Data.Char (GeneralCategory (..), generalCategory, ord) +import Data.Word (Word8) +import GHC.Data.StringBuffer (StringBuffer, atEnd, nextChar, prevChar) +import GHC.Exts +import GHC.Types.SrcLoc (PsLoc, advancePsLoc) + +data AlexInput = AI !PsLoc !StringBuffer deriving (Show) + +-- See Note [Unicode in Alex] +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (AI loc s) + | atEnd s = Nothing + | otherwise = byte `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (byte, (AI loc' s')) + where (c,s') = nextChar s + loc' = advancePsLoc loc c + byte = adjustChar c + +-- Getting the previous 'Char' isn't enough here - we need to convert it into +-- the same format that 'alexGetByte' would have produced. +-- +-- See Note [Unicode in Alex] and #13986. +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (AI _ buf) = unsafeChr (fromIntegral (adjustChar pc)) + where pc = prevChar buf '\n' + +-- backwards compatibility for Alex 2.x +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar inp = case alexGetByte inp of + Nothing -> Nothing + Just (b,i) -> c `seq` Just (c,i) + where c = unsafeChr $ fromIntegral b + +unsafeChr :: Int -> Char +unsafeChr (I# c) = GHC.Exts.C# (GHC.Exts.chr# c) + +{- +Note [Unicode in Alex] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Although newer versions of Alex support unicode, this grammar is processed with +the old style '--latin1' behaviour. This means that when implementing the +functions + + alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) + alexInputPrevChar :: AlexInput -> Char + +which Alex uses to take apart our 'AlexInput', we must + + * return a latin1 character in the 'Word8' that 'alexGetByte' expects + * return a latin1 character in 'alexInputPrevChar'. + +We handle this in 'adjustChar' by squishing entire classes of unicode +characters into single bytes. +-} + +{-# INLINE adjustChar #-} +adjustChar :: Char -> Word8 +adjustChar c = adj_c + where non_graphic = 0x00 + upper = 0x01 + lower = 0x02 + digit = 0x03 + symbol = 0x04 + space = 0x05 + other_graphic = 0x06 + uniidchar = 0x07 + + adj_c + | c <= '\x07' = non_graphic + | c <= '\x7f' = fromIntegral (ord c) + -- Alex doesn't handle Unicode, so when Unicode + -- character is encountered we output these values + -- with the actual character value hidden in the state. + | otherwise = + -- NB: The logic behind these definitions is also reflected + -- in "GHC.Utils.Lexeme" + -- Any changes here should likely be reflected there. + + case generalCategory c of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> uniidchar -- see #10196 + OtherLetter -> lower -- see #1103 + NonSpacingMark -> uniidchar -- see #7650 + SpacingCombiningMark -> other_graphic + EnclosingMark -> other_graphic + DecimalNumber -> digit + LetterNumber -> digit + OtherNumber -> digit -- see #4373 + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OpenPunctuation -> other_graphic + ClosePunctuation -> other_graphic + InitialQuote -> other_graphic + FinalQuote -> other_graphic + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + Space -> space + _other -> non_graphic diff --git a/GHC/Parser/Lexer/String.hs b/GHC/Parser/Lexer/String.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Lexer/String.hs @@ -0,0 +1,353 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LINE 1 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/Lexer/String.x" #-} +{- | +This module defines lex states for strings. + +This needs to be separate from the normal lexer because the normal lexer +automatically includes rules like skipping whitespace or lexing comments, +which we don't want in these contexts. +-} +module GHC.Parser.Lexer.String ( + AlexReturn (..), + alexScan, + string_multi_content, +) where + +import GHC.Prelude + +import GHC.Parser.Lexer.Interface +import GHC.Utils.Panic (panic) +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array.Base (unsafeAt) +import GHC.Exts +#else +import GlaExts +#endif +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: AlexAddr +alex_base = AlexA# + "\x00\x00\x00\x00\x01\x00\x00\x00\x40\x00\x00\x00\xdf\xff\xff\xff\x70\x00\x00\x00\xb7\x00\x00\x00\x2f\x01\x00\x00\xe7\xff\xff\xff\xe6\xff\xff\xff\xbe\xff\xff\xff\xc5\xff\xff\xff\x76\x00\x00\x00\xcb\xff\xff\xff\xd0\xff\xff\xff\x6a\x00\x00\x00\xcc\xff\xff\xff\xc9\xff\xff\xff\xad\x01\x00\x00\xfc\xff\xff\xff\x84\x00\x00\x00\x00\x00\x00\x00\x27\x02\x00\x00\xc7\xff\xff\xff\x67\x00\x00\x00\x57\x00\x00\x00\x7a\x00\x00\x00\x5e\x00\x00\x00\x61\x00\x00\x00\x75\x00\x00\x00\x87\x00\x00\x00\x68\x00\x00\x00\x30\x02\x00\x00\x5e\x02\x00\x00\x6d\x00\x00\x00\x8c\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# + "\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x14\x00\x11\x00\x06\x00\x0d\x00\x06\x00\x06\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\xff\xff\x11\x00\x1b\x00\x11\x00\x11\x00\x07\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x05\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x0d\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x0f\x00\x18\x00\x1b\x00\x1a\x00\x15\x00\x09\x00\x22\x00\x11\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x11\x00\x11\x00\x08\x00\x11\x00\x1b\x00\x16\x00\x21\x00\x11\x00\x11\x00\x11\x00\x1a\x00\x0a\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x15\x00\x00\x00\x11\x00\x11\x00\x00\x00\x00\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x1c\x00\x19\x00\x13\x00\x0e\x00\x1d\x00\x10\x00\x18\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x10\x00\x0b\x00\x00\x00\x10\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x02\x00\x00\x00\x00\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x03\x00\x00\x00\x00\x00\x11\x00\x00\x00\x11\x00\x00\x00\x11\x00\x00\x00\x04\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x06\x00\x06\x00\x00\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x20\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x06\x00\x00\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x05\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x15\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x11\x00\x00\x00\x00\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x1c\x00\x19\x00\x13\x00\x0e\x00\x1d\x00\x10\x00\x18\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x10\x00\x0b\x00\x00\x00\x10\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x02\x00\x00\x00\x00\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x03\x00\x00\x00\x00\x00\x11\x00\x00\x00\x11\x00\x00\x00\x11\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# + "\xff\xff\x43\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x22\x00\x45\x00\x0a\x00\x41\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x31\x00\x32\x00\x33\x00\x34\x00\x4b\x00\x53\x00\x51\x00\x22\x00\x58\x00\x55\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x43\x00\x54\x00\x4e\x00\x4c\x00\x46\x00\x42\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x4d\x00\x4e\x00\x4f\x00\x45\x00\x41\x00\x05\x00\x53\x00\x54\x00\x49\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x4f\x00\x50\x00\x43\x00\x53\x00\x45\x00\x54\x00\x55\x00\x52\x00\x46\x00\x42\x00\x59\x00\x4c\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x20\x00\xff\xff\x22\x00\x53\x00\xff\xff\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\x76\x00\xff\xff\x78\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\x09\x00\x0a\x00\xff\xff\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\x0a\x00\xff\xff\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\x5c\x00\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\x76\x00\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# + "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0 :: Int, 34) + [ AlexAccSkip + , AlexAcc 4 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 3 + , AlexAccPred 2 (alexRightContext 18)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 1 + , AlexAccNone + , AlexAccNone + , AlexAccPred 0 (alexRightContext 18)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + ] + +alex_actions = array (0 :: Int, 5) + [ (4,alex_action_1) + , (3,alex_action_1) + , (2,alex_action_2) + , (1,alex_action_1) + , (0,alex_action_2) + ] + + +string_multi_content :: Int +string_multi_content = 1 +alex_action_1 = string_multi_content_action +alex_action_2 = string_multi_content_action + +#define ALEX_GHC 1 +#define ALEX_LATIN1 1 +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +#ifdef ALEX_GHC +# define ILIT(n) n# +# define IBOX(n) (I# (n)) +# define FAST_INT Int# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +# if __GLASGOW_HASKELL__ > 706 +# define GTE(n,m) (tagToEnum# (n >=# m)) +# define EQ(n,m) (tagToEnum# (n ==# m)) +# else +# define GTE(n,m) (n >=# m) +# define EQ(n,m) (n ==# m) +# endif +# define PLUS(n,m) (n +# m) +# define MINUS(n,m) (n -# m) +# define TIMES(n,m) (n *# m) +# define NEGATE(n) (negateInt# (n)) +# define IF_GHC(x) (x) +#else +# define ILIT(n) (n) +# define IBOX(n) (n) +# define FAST_INT Int +# define GTE(n,m) (n >= m) +# define EQ(n,m) (n == m) +# define PLUS(n,m) (n + m) +# define MINUS(n,m) (n - m) +# define TIMES(n,m) (n * m) +# define NEGATE(n) (negate (n)) +# define IF_GHC(x) +#endif + +#ifdef ALEX_GHC +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else +#if __GLASGOW_HASKELL__ >= 901 + int16ToInt# +#endif + (indexInt16OffAddr# arr off) +#endif +#else +alexIndexInt16OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else +#if __GLASGOW_HASKELL__ >= 901 + int32ToInt# +#endif + (indexInt32OffAddr# arr off) +#endif +#else +alexIndexInt32OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif +#else +quickIndex arr i = arr ! i +#endif + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ IBOX(sc) + = alexScanUser undefined input__ IBOX(sc) + +alexScanUser user__ input__ IBOX(sc) + = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> +#ifdef ALEX_DEBUG + trace ("End of input.") $ +#endif + AlexEOF + Just _ -> +#ifdef ALEX_DEBUG + trace ("Error.") $ +#endif + AlexError input__' + + (AlexLastSkip input__'' len, _) -> +#ifdef ALEX_DEBUG + trace ("Skipping.") $ +#endif + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> +#ifdef ALEX_DEBUG + trace ("Accept.") $ +#endif + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` IBOX(s))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> +#ifdef ALEX_DEBUG + trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $ +#endif + case fromIntegral c of { IBOX(ord_c) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = PLUS(base,ord_c) + + new_s = if GTE(offset,ILIT(0)) + && let check = alexIndexInt16OffAddr alex_check offset + in EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + ILIT(-1) -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input +#ifdef ALEX_LATIN1 + PLUS(len,ILIT(1)) + -- issue 119: in the latin1 encoding, *each* byte is one character +#else + (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) +#endif + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ IBOX(len) + check_accs (AlexAccSkip) = AlexLastSkip input__ IBOX(len) +#ifndef ALEX_NOPRED + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastAcc a input__ IBOX(len) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastSkip input__ IBOX(len) + | otherwise + = check_accs rest +#endif + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip +#ifndef ALEX_NOPRED + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext IBOX(sc) user__ _ _ input__ = + case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. +#endif +{-# LINE 91 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/Lexer/String.x" #-} +-- | Dummy action that should never be called. Should only be used in lex states +-- that are manually lexed in tok_string_multi. +string_multi_content_action :: a +string_multi_content_action = panic "string_multi_content_action unexpectedly invoked" diff --git a/GHC/Parser/PostProcess.hs b/GHC/Parser/PostProcess.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/PostProcess.hs @@ -0,0 +1,3787 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- Functions over HsSyn specialised to RdrName. + +module GHC.Parser.PostProcess ( + mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot + mkHsOpApp, + mkHsIntegral, mkHsFractional, mkHsIsString, + mkHsDo, mkMDo, mkSpliceDecl, + mkRoleAnnotDecl, + mkClassDecl, + mkTyData, mkDataFamInst, + mkTySynonym, mkTyFamInstEqn, + mkStandaloneKindSig, + mkTyFamInst, + mkFamDecl, + mkInlinePragma, + mkOpaquePragma, + mkPatSynMatchGroup, + mkRecConstrOrUpdate, + mkTyClD, mkInstD, + mkRdrRecordCon, mkRdrRecordUpd, + setRdrNameSpace, + fromSpecTyVarBndr, fromSpecTyVarBndrs, + annBinds, + stmtsAnchor, stmtsLoc, + + cvBindGroup, + cvBindsAndSigs, + cvTopDecls, + placeHolderPunRhs, + + -- Stuff to do with Foreign declarations + mkImport, + parseCImport, + mkExport, + mkExtName, -- RdrName -> CLabelString + mkGadtDecl, -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName + mkConDeclH98, + + -- Bunch of functions in the parser monad for + -- checking and constructing values + checkImportDecl, + checkExpBlockArguments, checkCmdBlockArguments, + checkPrecP, -- Int -> P Int + checkContext, -- HsType -> P HsContext + checkPattern, -- HsExp -> P HsPat + checkPattern_details, + incompleteDoBlock, + ParseContext(..), + checkMonadComp, + checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + checkValSigLhs, + LRuleTyTmVar, RuleTyTmVar(..), + mkRuleBndrs, + ruleBndrsOrDef, + checkRuleTyVarBndrNames, + mkSpecSig, + checkRecordSyntax, + checkEmptyGADTs, + addFatalError, hintBangPat, + mkBangTy, + UnpackednessPragma(..), + mkMultAnn, + mkMultField, + mkConDeclField, + + -- Help with processing exports + ImpExpSubSpec(..), + ImpExpQcSpec(..), + mkModuleImpExp, + mkPlainImpExp, + mkTypeImpExp, + mkDataImpExp, + mkImpExpSubSpec, + checkImportSpec, + warnPatternNamespaceSpecifier, + + -- Token symbols + starSym, + + -- Warnings and errors + warnStarIsType, + warnPrepositiveQualifiedModule, + failOpFewArgs, + failNotEnabledImportQualifiedPost, + failImportQualifiedTwice, + failSpliceOrQuoteTwice, + + SumOrTuple (..), + + -- Expression/command/pattern ambiguity resolution + PV, + runPV, + ECP(ECP, unECP), + DisambInfixOp(..), + DisambECP(..), + ecpFromExp, + ecpFromCmd, + ecpFromPat, + ArrowParsingMode(..), + withArrowParsingMode, withArrowParsingMode', + setTelescopeBndrsNameSpace, + PatBuilder, + + -- Type/datacon ambiguity resolution + DisambTD(..), + addUnpackednessP, + dataConBuilderCon, + dataConBuilderDetails, + mkUnboxedSumCon, + + -- ListTuplePuns related parsers + mkTupleSyntaxTy, + mkTupleSyntaxTycon, + mkListSyntaxTy0, + mkListSyntaxTy1, + withCombinedComments, + requireLTPuns, + ) where + +import GHC.Prelude +import GHC.Hs -- Lots of it +import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) +import GHC.Core.DataCon ( DataCon, dataConTyCon, dataConName ) +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Types.Error +import GHC.Types.Fixity +import GHC.Types.Hint +import GHC.Types.SourceText +import GHC.Parser.Types +import GHC.Parser.Lexer +import GHC.Parser.Errors.Types +import GHC.Utils.Lexeme ( okConOcc ) +import GHC.Types.TyThing +import GHC.Core.Type ( Specificity(..) ) +import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon, + nilDataConName, nilDataConKey, + listTyConName, listTyConKey, sumDataCon, + unrestrictedFunTyCon , listTyCon_RDR, unitDataCon ) +import GHC.Types.ForeignCall +import GHC.Types.SrcLoc +import GHC.Types.Unique ( hasKey ) +import GHC.Data.OrdList +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Monad (unlessM) +import Data.Either +import Data.List ( findIndex ) +import Data.Foldable +import qualified Data.Semigroup as Semi +import GHC.Unit.Module.Warnings +import GHC.Utils.Panic +import qualified GHC.Data.Strict as Strict + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.Monad +import Text.ParserCombinators.ReadP as ReadP +import Data.Char +import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) +import Data.Kind ( Type ) +import Data.List.NonEmpty ( NonEmpty (..) ) + +{- ********************************************************************** + + Construction functions for Rdr stuff + + ********************************************************************* -} + +-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and +-- datacon by deriving them from the name of the class. We fill in the names +-- for the tycon and datacon corresponding to the class, by deriving them +-- from the name of the class itself. This saves recording the names in the +-- interface file (which would be equally good). + +-- Similarly for mkConDecl, mkClassOpSig and default-method names. + +-- *** See Note [The Naming story] in GHC.Hs.Decls **** + +mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) +mkTyClD (L loc d) = L loc (TyClD noExtField d) + +mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) +mkInstD (L loc d) = L loc (InstD noExtField d) + +mkClassDecl :: SrcSpan + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Located (a,[LHsFunDep GhcPs]) + -> OrdList (LHsDecl GhcPs) + -> EpLayout + -> AnnClassDecl + -> P (LTyClDecl GhcPs) + +mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn + = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls + ; (cls, tparams, fixity, ops, cps, cs) <- checkTyClHdr True tycl_hdr + ; tyvars <- checkTyVars (text "class") whereDots cls tparams + ; let anns' = annsIn { acd_openp = ops, acd_closep = cps} + ; let loc = EpAnn (spanAsAnchor loc') noAnn cs + ; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey) + , tcdCtxt = mcxt + , tcdLName = cls, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdFDs = snd (unLoc fds) + , tcdSigs = mkClassOpSigs sigs + , tcdMeths = binds + , tcdATs = ats, tcdATDefs = at_defs + , tcdDocs = docs })) } + +mkTyData :: SrcSpan + -> Bool + -> NewOrData + -> Maybe (LocatedP CType) + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> Located (HsDeriving GhcPs) + -> AnnDataDefn + -> P (LTyClDecl GhcPs) +mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) + ksig data_cons (L _ maybe_deriv) annsIn + = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False tycl_hdr + ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams + ; let anns = annsIn {andd_openp = ops, andd_closep = cps} + ; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons + ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv anns + ; !cs' <- getCommentsFor loc' + ; let loc = EpAnn (spanAsAnchor loc') noAnn (cs' Semi.<> cs) + ; return (L loc (DataDecl { tcdDExt = noExtField, + tcdLName = tc, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn })) } + +mkDataDefn :: Maybe (LocatedP CType) + -> Maybe (LHsContext GhcPs) + -> Maybe (LHsKind GhcPs) + -> DataDefnCons (LConDecl GhcPs) + -> HsDeriving GhcPs + -> AnnDataDefn + -> P (HsDataDefn GhcPs) +mkDataDefn cType mcxt ksig data_cons maybe_deriv anns + = do { checkDatatypeContext mcxt + ; return (HsDataDefn { dd_ext = anns + , dd_cType = cType + , dd_ctxt = mcxt + , dd_cons = data_cons + , dd_kindSig = ksig + , dd_derivs = maybe_deriv }) } + +mkTySynonym :: SrcSpan + -> LHsType GhcPs -- LHS + -> LHsType GhcPs -- RHS + -> EpToken "type" + -> EpToken "=" + -> P (LTyClDecl GhcPs) +mkTySynonym loc lhs rhs antype aneq + = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs + ; tyvars <- checkTyVars (text "type") equalsDots tc tparams + ; let anns = AnnSynDecl ops cps antype aneq + ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs + ; return (L loc' (SynDecl { tcdSExt = anns + , tcdLName = tc, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdRhs = rhs })) } + +mkStandaloneKindSig + :: SrcSpan + -> Located [LocatedN RdrName] -- LHS + -> LHsSigType GhcPs -- RHS + -> (EpToken "type", TokDcolon) + -> P (LStandaloneKindSig GhcPs) +mkStandaloneKindSig loc lhs rhs anns = + do { vs <- mapM check_lhs_name (unLoc lhs) + ; v <- check_singular_lhs (reverse vs) + ; return $ L (noAnnSrcSpan loc) + $ StandaloneKindSig anns v rhs } + where + check_lhs_name v@(unLoc->name) = + if isUnqual name && isTcOcc (rdrNameOcc name) + then return v + else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $ + (PsErrUnexpectedQualifiedConstructor (unLoc v)) + check_singular_lhs vs = + case vs of + [] -> panic "mkStandaloneKindSig: empty left-hand side" + [v] -> return v + _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $ + (PsErrMultipleNamesInStandaloneKindSignature vs) + +mkTyFamInstEqn :: SrcSpan + -> HsOuterFamEqnTyVarBndrs GhcPs + -> LHsType GhcPs + -> LHsType GhcPs + -> EpToken "=" + -> P (LTyFamInstEqn GhcPs) +mkTyFamInstEqn loc bndrs lhs rhs annEq + = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs + ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs + ; return (L loc' $ FamEqn + { feqn_ext = (ops, cps, annEq) + , feqn_tycon = tc + , feqn_bndrs = bndrs + , feqn_pats = tparams + , feqn_fixity = fixity + , feqn_rhs = rhs })} + +mkDataFamInst :: SrcSpan + -> NewOrData + -> Maybe (LocatedP CType) + -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs + , LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> Located (HsDeriving GhcPs) + -> AnnDataDefn + -> P (LInstDecl GhcPs) +mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) + ksig data_cons (L _ maybe_deriv) anns + = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False tycl_hdr + ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons + ; let anns' = anns {andd_openp = ops, andd_closep = cps} + ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv anns' + ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs + ; return (L loc' (DataFamInstD noExtField (DataFamInstDecl + (FamEqn { feqn_ext = ([], [], NoEpTok) + , feqn_tycon = tc + , feqn_bndrs = bndrs + , feqn_pats = tparams + , feqn_fixity = fixity + , feqn_rhs = defn })))) } + + + +mkTyFamInst :: SrcSpan + -> TyFamInstEqn GhcPs + -> EpToken "type" + -> EpToken "instance" + -> P (LInstDecl GhcPs) +mkTyFamInst loc eqn t i = do + return (L (noAnnSrcSpan loc) (TyFamInstD noExtField + (TyFamInstDecl (t,i) eqn))) + +mkFamDecl :: SrcSpan + -> FamilyInfo GhcPs + -> TopLevelFlag + -> LHsType GhcPs -- LHS + -> LFamilyResultSig GhcPs -- Optional result signature + -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation + -> AnnFamilyDecl + -> P (LTyClDecl GhcPs) +mkFamDecl loc info topLevel lhs ksig injAnn annsIn + = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs + ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams + ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs + ; let anns' = annsIn { afd_openp = ops, afd_closep = cps } + ; return (L loc' (FamDecl noExtField (FamilyDecl + { fdExt = anns' + , fdTopLevel = topLevel + , fdInfo = info, fdLName = tc + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = ksig + , fdInjectivityAnn = injAnn }))) } + where + equals_or_where = case info of + DataFamily -> empty + OpenTypeFamily -> empty + ClosedTypeFamily {} -> whereDots + +mkSpliceDecl :: LHsExpr GhcPs -> (LHsDecl GhcPs) +-- If the user wrote +-- [pads| ... ] then return a QuasiQuoteD +-- $(e) then return a SpliceD +-- but if they wrote, say, +-- f x then behave as if they'd written $(f x) +-- ie a SpliceD +-- +-- Typed splices are not allowed at the top level, thus we do not represent them +-- as spliced declaration. See #10945 +mkSpliceDecl lexpr@(L loc expr) + | HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr + = L loc $ SpliceD noExtField (SpliceDecl noExtField (L (l2l loc) splice) DollarSplice) + + | HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr + = L loc $ SpliceD noExtField (SpliceDecl noExtField (L (l2l loc) splice) DollarSplice) + + | otherwise + = L loc $ SpliceD noExtField (SpliceDecl noExtField + (L (l2l loc) (HsUntypedSpliceExpr noAnn (la2la lexpr))) + BareSplice) + +mkRoleAnnotDecl :: SrcSpan + -> LocatedN RdrName -- type being annotated + -> [Located (Maybe FastString)] -- roles + -> (EpToken "type", EpToken "role") + -> P (LRoleAnnotDecl GhcPs) +mkRoleAnnotDecl loc tycon roles anns + = do { roles' <- mapM parse_role roles + ; !cs <- getCommentsFor loc + ; return $ L (EpAnn (spanAsAnchor loc) noAnn cs) + $ RoleAnnotDecl anns tycon roles' } + where + role_data_type = dataTypeOf (undefined :: Role) + all_roles = map fromConstr $ dataTypeConstrs role_data_type + possible_roles = [(fsFromRole role, role) | role <- all_roles] + + parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing + parse_role (L loc_role (Just role)) + = case lookup role possible_roles of + Just found_role -> return $ L (noAnnSrcSpan loc_role) $ Just found_role + Nothing -> + let nearby = fuzzyLookup (unpackFS role) + (mapFst unpackFS possible_roles) + in + addFatalError $ mkPlainErrorMsgEnvelope loc_role $ + (PsErrIllegalRoleName role nearby) + +mkMDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs +mkMDo ctxt stmts tok loc + = mkHsDoAnns ctxt stmts (AnnList (Just loc) ListNone [] tok []) + +-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to +-- binders without annotations. Only accepts specified variables, and errors if +-- any of the provided binders has an 'InferredSpec' annotation. +fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs] +fromSpecTyVarBndrs = mapM fromSpecTyVarBndr + +-- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without +-- annotations. Only accepts specified variables, and errors if the provided +-- binder has an 'InferredSpec' annotation. +fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs) +fromSpecTyVarBndr (L loc (HsTvb xtv flag idp k)) = do + case flag of + SpecifiedSpec -> return () + InferredSpec -> addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + PsErrInferredTypeVarNotAllowed + return $ L loc (HsTvb xtv () idp k) + +-- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@ +annBinds :: EpToken "where" -> EpAnnComments -> HsLocalBinds GhcPs + -> (HsLocalBinds GhcPs, Maybe EpAnnComments) +annBinds w cs (HsValBinds an bs) = (HsValBinds (add_where w an cs) bs, Nothing) +annBinds w cs (HsIPBinds an bs) = (HsIPBinds (add_where w an cs) bs, Nothing) +annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs) + +add_where :: EpToken "where" -> EpAnn (AnnList (EpToken "where")) -> EpAnnComments -> EpAnn (AnnList (EpToken "where")) +add_where w@(EpTok (EpaSpan (RealSrcSpan rs _))) (EpAnn a al cs) cs2 + | valid_anchor a + = EpAnn (widenAnchorT a w) (al { al_rest = w}) (cs Semi.<> cs2) + | otherwise + = EpAnn (patch_anchor rs a) + (al { al_anchor = (fmap (patch_anchor rs) (al_anchor al)) + , al_rest = w}) + (cs Semi.<> cs2) +add_where _ _ _ = panic "add_where" + -- EpaDelta should only be used for transformations + +valid_anchor :: EpaLocation -> Bool +valid_anchor (EpaSpan (RealSrcSpan r _)) = srcSpanStartLine r >= 0 +valid_anchor _ = False + +-- If the decl list for where binds is empty, the anchor ends up +-- invalid. In this case, use the parent one +patch_anchor :: RealSrcSpan -> EpaLocation -> EpaLocation +patch_anchor r EpaDelta{} = EpaSpan (RealSrcSpan r Strict.Nothing) +patch_anchor r1 (EpaSpan (RealSrcSpan r0 mb)) = EpaSpan (RealSrcSpan r mb) + where + r = if srcSpanStartLine r0 < 0 then r1 else r0 +patch_anchor _ (EpaSpan ss) = EpaSpan ss + +-- | The anchor for a stmtlist is based on either the location or +-- the first semicolon annotion. +stmtsAnchor :: Located (OrdList (EpToken tok),a) -> Maybe EpaLocation +stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (EpTok (EpaSpan (RealSrcSpan r rb))) _), _)) + = Just $ widenAnchorS (EpaSpan (RealSrcSpan l mb)) (RealSrcSpan r rb) +stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan (RealSrcSpan l mb) +stmtsAnchor _ = Nothing + +stmtsLoc :: Located (OrdList (EpToken tok),a) -> SrcSpan +stmtsLoc (L l ((ConsOL aa _), _)) + = widenSpanT l aa +stmtsLoc (L l _) = l + +{- ********************************************************************** + + #cvBinds-etc# Converting to @HsBinds@, etc. + + ********************************************************************* -} + +-- | Function definitions are restructured here. Each is assumed to be recursive +-- initially, and non recursive definitions are discovered by the dependency +-- analyser. + + +-- | Groups together bindings for a single function +cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] +cvTopDecls decls = getMonoBindAll (fromOL decls) + +-- Declaration list may only contain value bindings and signatures. +cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) +cvBindGroup binding + = do { (mbs, sigs, fam_ds, tfam_insts + , dfam_insts, _) <- cvBindsAndSigs binding + ; massert (null fam_ds && null tfam_insts && null dfam_insts) + ; return $ ValBinds NoAnnSortKey mbs sigs } + +cvBindsAndSigs :: OrdList (LHsDecl GhcPs) + -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] + , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) +-- Input decls contain just value bindings and signatures +-- and in case of class or instance declarations also +-- associated type declarations. They might also contain Haddock comments. +cvBindsAndSigs fb = do + fb' <- drop_bad_decls (fromOL fb) + return (partitionBindsAndSigs (getMonoBindAll fb')) + where + -- cvBindsAndSigs is called in several places in the parser, + -- and its items can be produced by various productions: + -- + -- * decl (when parsing a where clause or a let-expression) + -- * decl_inst (when parsing an instance declaration) + -- * decl_cls (when parsing a class declaration) + -- + -- partitionBindsAndSigs can handle almost all declaration forms produced + -- by the aforementioned productions, except for SpliceD, which we filter + -- out here (in drop_bad_decls). + -- + -- We're not concerned with every declaration form possible, such as those + -- produced by the topdecl parser production, because cvBindsAndSigs is not + -- called on top-level declarations. + drop_bad_decls [] = return [] + drop_bad_decls (L l (SpliceD _ d) : ds) = do + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d + drop_bad_decls ds + drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds + +----------------------------------------------------------------------------- +-- Group function bindings into equation groups + +getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] + -> (LHsBind GhcPs, [LHsDecl GhcPs]) +-- Suppose (b',ds') = getMonoBind b ds +-- ds is a list of parsed bindings +-- b is a MonoBinds that has just been read off the front + +-- Then b' is the result of grouping more equations from ds that +-- belong with b into a single MonoBinds, and ds' is the depleted +-- list of parsed bindings. +-- +-- All Haddock comments between equations inside the group are +-- discarded. +-- +-- No AndMonoBinds or EmptyMonoBinds here; just single equations + +getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1) + , fun_matches = + MG { mg_alts = (L _ m1@[L _ mtchs1]) } })) + binds + | has_args m1 + = go [L loc1 mtchs1] (noAnnSrcSpan $ locA loc1) binds [] + where + -- See Note [Exact Print Annotations for FunBind] + go :: [LMatch GhcPs (LHsExpr GhcPs)] -- accumulates matches for current fun + -> SrcSpanAnnA -- current top level loc + -> [LHsDecl GhcPs] -- Any docbinds seen + -> [LHsDecl GhcPs] -- rest of decls to be processed + -> (LHsBind GhcPs, [LHsDecl GhcPs]) -- FunBind, rest of decls + go mtchs loc + ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2) + , fun_matches = + MG { mg_alts = (L _ [L lm2 mtchs2]) } }))) + : binds) _ + | f1 == f2 = + let (loc2', lm2') = transferAnnsA loc2 lm2 + in go (L lm2' mtchs2 : mtchs) + (combineSrcSpansA loc loc2') binds [] + go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls + = let doc_decls' = doc_decl : doc_decls + in go mtchs (combineSrcSpansA loc loc2) binds doc_decls' + go mtchs loc binds doc_decls + = let + L llm last_m = head mtchs -- Guaranteed at least one + (llm',loc') = transferAnnsOnlyA llm loc -- Keep comments, transfer trailing + + matches' = reverse (L llm' last_m:tail mtchs) + L lfm first_m = head matches' + (lfm', loc'') = transferCommentsOnlyA lfm loc' + in + ( L loc'' (makeFunBind fun_id1 (mkLocatedList $ (L lfm' first_m:tail matches'))) + , (reverse doc_decls) ++ binds) + -- Reverse the final matches, to get it back in the right order + -- Do the same thing with the trailing doc comments + +getMonoBind bind binds = (bind, binds) + +{- Note [Exact Print Annotations for FunBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +An individual Match that ends up in a FunBind MatchGroup is initially +parsed as a LHsDecl. This takes the form + + L loc (ValD NoExtField (FunBind ... [L lm (Match ..)])) + +The loc contains the annotations, in particular comments, which are to +precede the declaration when printed, and [TrailingAnn] which are to +follow it. The [TrailingAnn] captures semicolons that may appear after +it when using the braces and semis style of coding. + +The match location (lm) has only a location in it at this point, no +annotations. Its location is the same as the top level location in +loc. + +What getMonoBind does it to take a sequence of FunBind LHsDecls that +belong to the same function and group them into a single function with +the component declarations all combined into the single MatchGroup as +[LMatch GhcPs]. + +Given that when exact printing a FunBind the exact printer simply +iterates over all the matches and prints each in turn, the simplest +behaviour would be to simply take the top level annotations (loc) for +each declaration, and use them for the individual component matches +(lm). + +The problem is the exact printer first has to deal with the top level +LHsDecl, which means annotations for the loc. This needs to be able to +be exact printed in the context of surrounding declarations, and if +some refactor decides to move the declaration elsewhere, the leading +comments and trailing semicolons need to be handled at that level. + +So the solution is to combine all the matches into one, pushing the +annotations into the LMatch's, and then at the end extract the +comments from the first match and [TrailingAnn] from the last to go in +the top level LHsDecl. +-} + +-- Group together adjacent FunBinds for every function. +getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] +getMonoBindAll [] = [] +getMonoBindAll (L l (ValD _ b) : ds) = + let (L l' b', ds') = getMonoBind (L l b) ds + in L l' (ValD noExtField b') : getMonoBindAll ds' +getMonoBindAll (d : ds) = d : getMonoBindAll ds + +has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool +has_args [] = panic "GHC.Parser.PostProcess.has_args" +has_args (L _ (Match { m_pats = L _ args }) : _) = not (null args) + -- Don't group together FunBinds if they have + -- no arguments. This is necessary now that variable bindings + -- with no arguments are now treated as FunBinds rather + -- than pattern bindings (tests/rename/should_fail/rnfail002). + +{- ********************************************************************** + + #PrefixToHS-utils# Utilities for conversion + + ********************************************************************* -} + +{- Note [Parsing data constructors is hard] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The problem with parsing data constructors is that they look a lot like types. +Compare: + + (s1) data T = C t1 t2 + (s2) type T = C t1 t2 + +Syntactically, there's little difference between these declarations, except in +(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor. + +This similarity would pose no problem if we knew ahead of time if we are +parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple +(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing +data constructors, and in other contexts (e.g. 'type' declarations) assume we +are parsing type constructors. + +This simple rule does not work because of two problematic cases: + + (p1) data T = C t1 t2 :+ t3 + (p2) data T = C t1 t2 => t3 + +In (p1) we encounter (:+) and it turns out we are parsing an infix data +declaration, so (C t1 t2) is a type and 'C' is a type constructor. +In (p2) we encounter (=>) and it turns out we are parsing an existential +context, so (C t1 t2) is a constraint and 'C' is a type constructor. + +As the result, in order to determine whether (C t1 t2) declares a data +constructor, a type, or a context, we would need unlimited lookahead which +'happy' is not so happy with. +-} + +-- | Reinterpret a type constructor, including type operators, as a data +-- constructor. +-- See Note [Parsing data constructors is hard] +tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName) +tyConToDataCon (L loc tc) + | okConOcc (occNameString occ) + = return (L loc (setRdrNameSpace tc srcDataName)) + + | otherwise + = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc) + where + occ = rdrNameOcc tc + +mkPatSynMatchGroup :: LocatedN RdrName + -> LocatedLW (OrdList (LHsDecl GhcPs)) + -> P (MatchGroup GhcPs (LHsExpr GhcPs)) +mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) = + do { matches <- mapM fromDecl (fromOL decls) + ; when (null matches) (wrongNumberErr (locA loc)) + ; return $ mkMatchGroup FromSource (L ld matches) } + where + fromDecl (L loc decl@(ValD _ (PatBind _ + pat@(L _ (ConPat _conAnn ln@(L _ name) details)) + _ rhs))) = + do { unless (name == patsyn_name) $ + wrongNameBindingErr (locA loc) decl + -- conAnn should only be AnnOpenP, AnnCloseP, so the rest should be empty + ; let ann_fun = mk_ann_funrhs [] [] + ; match <- case details of + PrefixCon pats -> return $ Match { m_ext = noExtField + , m_ctxt = ctxt, m_pats = L l pats + , m_grhss = rhs } + where + l = listLocation pats + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Prefix + , mc_strictness = NoSrcStrict + , mc_an = ann_fun } + + InfixCon p1 p2 -> return $ Match { m_ext = noExtField + , m_ctxt = ctxt + , m_pats = L l [p1, p2] + , m_grhss = rhs } + where + l = listLocation [p1, p2] + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Infix + , mc_strictness = NoSrcStrict + , mc_an = ann_fun } + + RecCon{} -> recordPatSynErr (locA loc) pat + ; return $ L loc match } + fromDecl (L loc decl) = extraDeclErr (locA loc) decl + + extraDeclErr loc decl = + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) + + wrongNameBindingErr loc decl = + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) + + wrongNumberErr loc = + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrEmptyWhereInPatSynDecl patsyn_name) + +recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a +recordPatSynErr loc pat = + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrRecordSyntaxInPatSynDecl pat) + +mkConDeclH98 :: (TokDarrow, (TokForall, EpToken ".")) -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] + -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs + -> ConDecl GhcPs + +mkConDeclH98 (tdarrow, (tforall,tdot)) name mb_forall mb_cxt args + = ConDeclH98 { con_ext = AnnConDeclH98 tforall tdot tdarrow + , con_name = name + , con_forall = isJust mb_forall + , con_ex_tvs = mb_forall `orElse` [] + , con_mb_cxt = mb_cxt + , con_args = args + , con_doc = Nothing } + +-- | Construct a GADT-style data constructor from the constructor names and +-- their type. Some interesting aspects of this function: +-- +-- * This splits up the constructor type into its quantified type variables (if +-- provided), context (if provided), argument types, and result type, and +-- records whether this is a prefix or record GADT constructor. See +-- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. +mkGadtDecl :: SrcSpan + -> NonEmpty (LocatedN RdrName) + -> TokDcolon + -> LHsSigType GhcPs + -> P (LConDecl GhcPs) +mkGadtDecl loc names dcol ty = do + + (args, res_ty, (ops, cps), csa) <- + case body_ty of + L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (XHsType (HsRecTy an rf))) res_ty) -> do + arr <- case hsArr of + HsUnannotated (EpArrow arr) -> return arr + _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $ + (PsErrIllegalGadtRecordMultiplicity hsArr) + return noAnn + + return ( RecConGADT arr (L (EpAnn anc an cs) rf), res_ty + , ([], []), epAnnComments ll) + _ -> do + let ((ops, cps), cs, arg_types, res_type) = splitHsFunType body_ty + return (PrefixConGADT noExtField arg_types, res_type, (ops,cps), cs) + + let l = EpAnn (spanAsAnchor loc) noAnn csa + + pure $ L l ConDeclGADT + { con_g_ext = AnnConDeclGADT ops cps dcol + , con_names = names + , con_outer_bndrs = L outer_bndrs_loc outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = mcxt + , con_g_args = args + , con_res_ty = res_ty + , con_doc = Nothing } + where + (outer_bndrs, inner_bndrs, mcxt, body_ty) = splitLHsGadtTy ty + outer_bndrs_loc = case outer_bndrs of + HsOuterImplicit{} -> getLoc ty + HsOuterExplicit an _ -> EpAnn (entry an) noAnn emptyComments + + +setRdrNameSpace :: RdrName -> NameSpace -> RdrName +-- ^ This rather gruesome function is used mainly by the parser. +-- +-- Case #1. When parsing: +-- +-- > data T a = T | T1 Int +-- +-- we parse the data constructors as /types/ because of parser ambiguities, +-- so then we need to change the /type constr/ to a /data constr/ +-- +-- The exact-name case /can/ occur when parsing: +-- +-- > data [] a = [] | a : [a] +-- +-- For the exact-name case we return an original name. +-- +-- Case #2. When parsing: +-- +-- > x = fn (forall a. a) -- RequiredTypeArguments +-- +-- we use setRdrNameSpace to set the namespace of forall-bound variables. +-- +setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) +setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) +setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) +setRdrNameSpace (Exact n) ns + | Just thing <- wiredInNameTyThing_maybe n + = setWiredInNameSpace thing ns + -- Preserve Exact Names for wired-in things, + -- notably tuples and lists + + | isExternalName n + = Orig (nameModule n) occ + + | otherwise -- This can happen when quoting and then + -- splicing a fixity declaration for a type + = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) + where + occ = setOccNameSpace ns (nameOccName n) + +setWiredInNameSpace :: TyThing -> NameSpace -> RdrName +setWiredInNameSpace (ATyCon tc) ns + | isDataConNameSpace ns + = ty_con_data_con tc + | isTcClsNameSpace ns + = Exact (getName tc) -- No-op + +setWiredInNameSpace (AConLike (RealDataCon dc)) ns + | isTcClsNameSpace ns + = data_con_ty_con dc + | isDataConNameSpace ns + = Exact (getName dc) -- No-op + +setWiredInNameSpace thing ns + = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) + +ty_con_data_con :: TyCon -> RdrName +ty_con_data_con tc + | isTupleTyCon tc + , Just dc <- tyConSingleDataCon_maybe tc + = Exact (getName dc) + + | tc `hasKey` listTyConKey + = Exact nilDataConName + + | otherwise -- See Note [setRdrNameSpace for wired-in names] + = Unqual (setOccNameSpace srcDataName (getOccName tc)) + +data_con_ty_con :: DataCon -> RdrName +data_con_ty_con dc + | let tc = dataConTyCon dc + , isTupleTyCon tc + = Exact (getName tc) + + | dc `hasKey` nilDataConKey + = Exact listTyConName + + | otherwise -- See Note [setRdrNameSpace for wired-in names] + = Unqual (setOccNameSpace tcClsName (getOccName dc)) + + + +{- Note [setRdrNameSpace for wired-in names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC.Types, which declares (:), we have + infixr 5 : +The ambiguity about which ":" is meant is resolved by parsing it as a +data constructor, but then using dataTcOccs to try the type constructor too; +and that in turn calls setRdrNameSpace to change the name-space of ":" to +tcClsName. There isn't a corresponding ":" type constructor, but it's painful +to make setRdrNameSpace partial, so we just make an Unqual name instead. It +really doesn't matter! +-} + +eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a +-- Adapts the Either monad to the P monad +eitherToP (Left err) = addFatalError err +eitherToP (Right thing) = return thing + +checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs] + -> P (LHsQTyVars GhcPs) -- the synthesized type variables +-- ^ Check whether the given list of type parameters are all type variables +-- (possibly with a kind signature). +checkTyVars pp_what equals_or_where tc tparms + = do { tvs <- mapM check tparms + ; return (mkHsQTvs tvs) } + where + check (HsTypeArg at ki) = chkParens [] [] (HsBndrInvisible at) ki + check (HsValArg _ ty) = chkParens [] [] (HsBndrRequired noExtField) ty + check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $ + (PsErrMalformedDecl pp_what (unLoc tc)) + -- Keep around an action for adjusting the annotations of extra parens + chkParens :: [EpaLocation] -> [EpaLocation] -> HsBndrVis GhcPs -> LHsType GhcPs + -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs) + chkParens ops cps bvis (L l (HsParTy _ (L lt ty))) + = let + (o,c) = mkParensLocs (realSrcSpan $ locA l) + (_,lt') = transferCommentsOnlyA l lt + in + chkParens (o:ops) (c:cps) bvis (L lt' ty) + chkParens ops cps bvis ty = chk ops cps bvis ty + + -- Check that the name space is correct! + chk :: [EpaLocation] -> [EpaLocation] -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs) + chk ops cps bvis (L l (HsKindSig tok_dc (L annt t) k)) + | Just (ann, bvar) <- match_bndr_var t + = let + bkind = HsBndrKind noExtField k + an = (reverse ops) ++ cps + in + return (L (widenLocatedAnL (l Semi.<> annt) (for_widening bvis:an)) + (HsTvb (AnnTyVarBndr (reverse ops) cps ann tok_dc) bvis bvar bkind)) + chk ops cps bvis (L l t) + | Just (ann, bvar) <- match_bndr_var t + = let + bkind = HsBndrNoKind noExtField + an = (reverse ops) ++ cps + in + return (L (widenLocatedAnL l (for_widening bvis:an)) + (HsTvb (AnnTyVarBndr (reverse ops) cps ann noAnn) bvis bvar bkind)) + chk _ _ _ t@(L loc _) + = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) + + match_bndr_var :: HsType GhcPs -> Maybe (EpToken "'", HsBndrVar GhcPs) + match_bndr_var (HsTyVar ann _ tv) | isRdrTyVar (unLoc tv) + = Just (ann, HsBndrVar noExtField tv) + match_bndr_var (HsWildCardTy tok) + = Just (noAnn, HsBndrWildCard tok) + match_bndr_var _ = Nothing + + -- Return a EpaLocation for use in widenLocatedAnL. + for_widening :: HsBndrVis GhcPs -> EpaLocation + for_widening (HsBndrInvisible (EpTok loc)) = loc + for_widening _ = noAnn + + +whereDots, equalsDots :: SDoc +-- Second argument to checkTyVars +whereDots = text "where ..." +equalsDots = text "= ..." + +checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () +checkDatatypeContext Nothing = return () +checkDatatypeContext (Just c) + = do allowed <- getBit DatatypeContextsBit + unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $ + (PsErrIllegalDataTypeContext c) + +type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar +data RuleTyTmVar = RuleTyTmVar AnnTyVarBndr (LocatedN RdrName) (Maybe (LHsType GhcPs)) +-- ^ Essentially a wrapper for a @RuleBndr GhcPs@ + +ruleBndrsOrDef :: Maybe (RuleBndrs GhcPs) -> RuleBndrs GhcPs +ruleBndrsOrDef (Just bndrs) = bndrs +ruleBndrsOrDef Nothing = mkRuleBndrs noAnn Nothing [] + +mkRuleBndrs :: HsRuleBndrsAnn -> Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs +mkRuleBndrs ann tvbs tmbs + = RuleBndrs { rb_ext = ann + , rb_tyvs = fmap (fmap (setLHsTyVarBndrNameSpace tvName . cvt_tv)) tvbs + , rb_tmvs = fmap (fmap cvt_tm) tmbs } + where + -- cvt_tm turns RuleTyTmVars into RuleBnrs - this is straightforward + cvt_tm (RuleTyTmVar ann v Nothing) = RuleBndr ann v + cvt_tm (RuleTyTmVar ann v (Just sig)) = RuleBndrSig ann v (mkHsPatSigType noAnn sig) + + -- cvt_tv turns RuleTyTmVars into HsTyVarBndrs - this is more interesting + cvt_tv (L l (RuleTyTmVar ann v msig)) + = L (l2l l) (HsTvb ann () (HsBndrVar noExtField v) (cvt_sig msig)) + cvt_sig Nothing = HsBndrNoKind noExtField + cvt_sig (Just sig) = HsBndrKind noExtField sig + +checkRuleTyVarBndrNames :: [LRuleTyTmVar] -> P () +-- See Note [Parsing explicit foralls in Rules] in Parser.y +checkRuleTyVarBndrNames bndrs + = sequence_ [ check lname | L _ (RuleTyTmVar _ lname _) <- bndrs ] + where + check (L loc (Unqual occ)) = + when (occNameFS occ `elem` [fsLit "family",fsLit "role"]) $ + addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + PsErrParseErrorOnInput occ + check _ = panic "checkRuleTyVarBndrNames" + +-- | Deal with both old-form and new-form specialise pragmas, using the new +-- 'SpecSigE' form unless there are multiple comma-separated type signatures, +-- in which case we use the old-form. +-- +-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig. +mkSpecSig :: InlinePragma + -> AnnSpecSig + -> Maybe (RuleBndrs GhcPs) + -> LHsExpr GhcPs + -> Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs))) + -> P (Sig GhcPs) +mkSpecSig inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr + = case m_sigtypes_ascr of + Nothing + -- New form, no trailing type signature, e.g {-# SPECIALISE f @Int #-} + -> pure $ + SpecSigE activation_anns + (ruleBndrsOrDef m_rule_binds) expr inl_prag + + Just (L lt (colon_ann, sigtype_ol)) + + -- Singleton, e.g. {-# SPECIALISE f :: ty #-} + -- Use the SpecSigE route + | [sigtype] <- sigtype_list + -> pure $ + SpecSigE activation_anns + (ruleBndrsOrDef m_rule_binds) + (L ((combineSrcSpansA (getLoc expr) (noAnnSrcSpan lt))) + (ExprWithTySig colon_ann expr (mkHsWildCardBndrs sigtype))) + inl_prag + + -- So we must have the old form {# SPECIALISE f :: ty1, ty2, ty3 #-} + -- Use the old SpecSig route + | Nothing <- m_rule_binds + , L _ (HsVar _ var) <- expr + -> do addPsMessage sigs_loc PsWarnSpecMultipleTypeAscription + pure $ + SpecSig (activation_anns {ass_dcolon = Just colon_ann }) + var sigtype_list inl_prag + + | otherwise -> + addFatalError $ + mkPlainErrorMsgEnvelope sigs_loc PsErrSpecExprMultipleTypeAscription + + where + sigtype_list = fromOL sigtype_ol + sigs_loc = + getHasLoc colon_ann `combineSrcSpans` getHasLoc (last sigtype_list) + +checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a) +checkRecordSyntax lr@(L loc r) + = do allowed <- getBit TraditionalRecordSyntaxBit + unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrIllegalTraditionalRecordSyntax (ppr r)) + return lr + +-- | Check if the gadt_constrlist is empty. Only raise parse error for +-- `data T where` to avoid affecting existing error message, see #8258. +checkEmptyGADTs :: Located ((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs]) + -> P (Located ((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs])) +checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. + = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax + unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $ + PsErrIllegalWhereInDataDecl + return gadts +checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. + +checkTyClHdr :: Bool -- True <=> class header + -- False <=> type header + -> LHsType GhcPs + -> P (LocatedN RdrName, -- the head symbol (type or class name) + [LHsTypeArg GhcPs], -- parameters of head symbol + LexicalFixity, -- the declaration is in infix format + [EpToken "("], -- API Annotation for HsParTy + [EpToken ")"], -- when stripping parens + EpAnnComments) -- Accumulated comments from re-arranging +-- Well-formedness check and decomposition of type and class heads. +-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) +-- Int :*: Bool into (:*:, [Int, Bool]) +-- returning the pieces +checkTyClHdr is_cls ty + = goL emptyComments ty [] [] [] Prefix + where + goL cs (L l ty) acc ops cps fix = go cs l ty acc ops cps fix + + -- workaround to define '*' despite StarIsType + go cs ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix + = do { addPsMessage (locA l) PsWarnStarBinder + ; let name = mkOccNameFS tcClsName (starSym isUni) + ; let a' = newAnns ll l an + ; return (L a' (Unqual name), acc, fix + , (reverse ops'), cps', cs) } + + go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix + | isRdrTc tc = return (ltc, acc, fix, (reverse ops), cps, cs Semi.<> comments l) + go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix + | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops), cps, cs Semi.<> comments l) + where lhs = HsValArg noExtField t1 + rhs = HsValArg noExtField t2 + go cs l (HsParTy (o,c) ty) acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix + go cs l (HsAppTy _ t1 t2) acc ops cps fix = goL (cs Semi.<> comments l) t1 (HsValArg noExtField t2:acc) ops cps fix + go cs l (HsAppKindTy at ty ki) acc ops cps fix = goL (cs Semi.<> comments l) ty (HsTypeArg at ki:acc) ops cps fix + go cs l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix + = return (L (l2l l) (nameRdrName tup_name) + , map (HsValArg noExtField) ts, fix, (reverse ops), cps, cs Semi.<> comments l) + where + arity = length ts + tup_name | is_cls = cTupleTyConName arity + | otherwise = getName (tupleTyCon Boxed arity) + -- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?) + go _ l _ _ _ _ _ + = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrMalformedTyOrClDecl ty) + + -- Combine the annotations from the HsParTy and HsStarTy into a + -- new one for the LocatedN RdrName + newAnns :: SrcSpanAnnA -> SrcSpanAnnA -> (EpToken "(", EpToken ")") -> SrcSpanAnnN + newAnns l@(EpAnn _ (AnnListItem _) csp0) l1@(EpAnn ap (AnnListItem ta) csp) (o,c) = + let + lr = combineSrcSpans (locA l1) (locA l) + in + EpAnn (EpaSpan lr) (NameAnn (NameParens o c) ap ta) (csp0 Semi.<> csp) + +-- | Yield a parse error if we have a function applied directly to a do block +-- etc. and BlockArguments is not enabled. +checkExpBlockArguments :: LHsExpr GhcPs -> PV () +checkCmdBlockArguments :: LHsCmd GhcPs -> PV () +(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd) + where + checkExpr :: LHsExpr GhcPs -> PV () + checkExpr expr = case unLoc expr of + HsDo _ (DoExpr m) _ -> check (PsErrDoInFunAppExpr m) expr + HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m) expr + HsCase {} -> check PsErrCaseInFunAppExpr expr + HsLam _ lam_variant _ -> check (PsErrLambdaInFunAppExpr lam_variant) expr + HsLet {} -> check PsErrLetInFunAppExpr expr + HsIf {} -> check PsErrIfInFunAppExpr expr + HsProc {} -> check PsErrProcInFunAppExpr expr + _ -> return () + + checkCmd :: LHsCmd GhcPs -> PV () + checkCmd cmd = case unLoc cmd of + HsCmdLam _ lam_variant _ -> check (PsErrLambdaCmdInFunAppCmd lam_variant) cmd + HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd cmd + HsCmdIf {} -> check PsErrIfCmdInFunAppCmd cmd + HsCmdLet {} -> check PsErrLetCmdInFunAppCmd cmd + HsCmdDo {} -> check PsErrDoCmdInFunAppCmd cmd + _ -> return () + + check err a = do + blockArguments <- getBit BlockArgumentsBit + unless blockArguments $ + addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a) + +-- | Validate the context constraints and break up a context into a list +-- of predicates. +-- +-- @ +-- (Eq a, Ord b) --> [Eq a, Ord b] +-- Eq a --> [Eq a] +-- (Eq a) --> [Eq a] +-- (((Eq a))) --> [Eq a] +-- @ +checkContext :: LHsType GhcPs -> P (LHsContext GhcPs) +checkContext orig_t@(L (EpAnn l _ cs) _orig_t) = + check ([],[],cs) orig_t + where + check :: ([EpToken "("],[EpToken ")"],EpAnnComments) + -> LHsType GhcPs -> P (LHsContext GhcPs) + check (oparens,cparens,cs) (L _l (HsTupleTy (AnnParens o c) HsBoxedOrConstraintTuple ts)) + -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can + -- be used as context constraints. + -- Ditto () + = mkCTuple (oparens ++ [o], c : cparens, cs) ts + + -- With NoListTuplePuns, contexts are parsed as data constructors, which causes failure + -- downstream. + -- This converts them just like when they are parsed as types in the punned case. + check (oparens,cparens,cs) (L _l (HsExplicitTupleTy (q,o,c) _ ts)) + = punsAllowed >>= \case + True -> unprocessed + False -> do + let + (op, cp) = case q of + EpTok ql -> ([EpTok ql], [c]) + _ -> ([o], [c]) + mkCTuple (oparens ++ op, cp ++ cparens, cs) ts + check (opi,cpi,csi) (L _lp1 (HsParTy (o,c) ty)) + -- to be sure HsParTy doesn't get into the way + = check (o:opi, c:cpi, csi) ty + + -- No need for anns, returning original + check (_opi,_cpi,_csi) _t = unprocessed + + unprocessed = + return (L (EpAnn l (AnnContext Nothing [] []) emptyComments) [orig_t]) + + + mkCTuple (oparens, cparens, cs) ts = + -- Append parens so that the original order in the source is maintained + return (L (EpAnn l (AnnContext Nothing oparens cparens) cs) ts) + +-- | The same as `checkContext`, but for expressions. +-- +-- Validate the context constraints and break up a context into a list +-- of predicates. +-- +-- @ +-- (Eq a, Ord b) --> [Eq a, Ord b] +-- Eq a --> [Eq a] +-- (Eq a) --> [Eq a] +-- (((Eq a))) --> [Eq a] +-- @ +checkContextExpr :: LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs]) +checkContextExpr orig_expr@(L (EpAnn l _ cs) _) = + check ([],[], cs) orig_expr + where + check :: ([EpToken "("],[EpToken ")"],EpAnnComments) + -> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs]) + check (oparens,cparens,cs) (L _ (ExplicitTuple (ap_open, ap_close) tup_args boxity)) + -- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be a context + | isBoxed boxity + , Just es <- tupArgsPresent_maybe tup_args + = mkCTuple (oparens ++ [EpTok ap_open], EpTok ap_close : cparens, cs) es + check (opi, cpi, csi) (L _ (HsPar (open_tok, close_tok) expr)) + = check (opi ++ [open_tok], close_tok : cpi, csi) expr + check (oparens,cparens,cs) (L _ (HsVar _ (L (EpAnn _ (NameAnnOnly (NameParens open closed) []) _) name))) + | name == nameRdrName (dataConName unitDataCon) + = mkCTuple (oparens ++ [open], closed : cparens, cs) [] + check _ _ = unprocessed + + unprocessed = + return (L (EpAnn l (AnnContext Nothing [] []) emptyComments) [orig_expr]) + + mkCTuple (oparens, cparens, cs) ts = + -- Append parens so that the original order in the source is maintained + return (L (EpAnn l (AnnContext Nothing oparens cparens) cs) ts) + +checkImportDecl :: Maybe (EpToken "qualified") + -> Maybe (EpToken "qualified") + -> Maybe EpAnnLevel + -> Maybe EpAnnLevel + -> P ((Maybe (EpToken "qualified"), ImportDeclQualifiedStyle) + , (Maybe EpAnnLevel, ImportDeclLevelStyle)) +checkImportDecl mPre mPost preLevel postLevel = do + let whenJust mg f = maybe (pure ()) f mg + tokenSpan tok = RealSrcSpan (epaLocationRealSrcSpan $ getEpTokenLoc tok) Strict.Nothing + + importQualifiedPostEnabled <- getBit ImportQualifiedPostBit + + -- Error if 'qualified' found in postpositive position and + -- 'ImportQualifiedPost' is not in effect. + whenJust mPost $ \post -> + when (not importQualifiedPostEnabled) $ + failNotEnabledImportQualifiedPost (tokenSpan post) + + -- Error if 'qualified' occurs in both pre and postpositive + -- positions. + qualSpec <- importDeclQualifiedStyle mPre mPost + levelSpec <- importDeclLevelStyle preLevel postLevel + + -- Warn if 'qualified' found in prepositive position and + -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. + whenJust mPre $ \pre -> + warnPrepositiveQualifiedModule (tokenSpan pre) + + return (qualSpec, levelSpec) + +-- | Given two possible located 'qualified' tokens, compute a style +-- (in a conforming Haskell program only one of the two can be not +-- 'Nothing'). This is called from "GHC.Parser". +importDeclQualifiedStyle :: Maybe (EpToken "qualified") + -> Maybe (EpToken "qualified") + -> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle) +importDeclQualifiedStyle mPre mPost = + case (mPre, mPost) of + (Just {}, Just post) -> failImportQualifiedTwice (getEpTokenSrcSpan post) + >> return (Just post, QualifiedPost) + (Nothing, Just post) -> pure (Just post, QualifiedPost) + (Just pre, Nothing) -> pure (Just pre, QualifiedPre) + (Nothing, Nothing) -> pure (Nothing, NotQualified) + +importDeclLevelStyle :: (Maybe EpAnnLevel) + -> (Maybe EpAnnLevel) + -> P (Maybe EpAnnLevel, ImportDeclLevelStyle) +importDeclLevelStyle preImportLevel postImportLevel = + case (preImportLevel, postImportLevel) of + (Just {}, Just tok) -> failSpliceOrQuoteTwice tok + >> return (Just tok, LevelStylePost (tokToLevel tok)) + (Nothing, Just post) -> pure (Just post, LevelStylePost (tokToLevel post)) + (Just pre, Nothing) -> pure (Just pre, LevelStylePre (tokToLevel pre)) + (Nothing, Nothing) -> pure (Nothing, NotLevelled) + where + tokToLevel tok = case tok of + EpAnnLevelSplice {} -> ImportDeclSplice + EpAnnLevelQuote {} -> ImportDeclQuote + + + +-- ------------------------------------------------------------------------- +-- Checking Patterns. + +-- We parse patterns as expressions and check for valid patterns below, +-- converting the expression into a pattern at the same time. + +checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) +checkPattern = runPV . checkLPat + +checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) +checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat) + +checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) +checkLPat (L l@(EpAnn anc an _) p) = do + (L l' p', cs) <- checkPat (EpAnn anc an emptyComments) emptyComments (L l p) [] + return (L (addCommentsToEpAnn l' cs) p') + +checkPat :: SrcSpanAnnA -> EpAnnComments -> LocatedA (PatBuilder GhcPs) -> [LPat GhcPs] + -> PV (LPat GhcPs, EpAnnComments) +-- SG: I think this function checks what Haskell2010 calls the `pat` and `lpat` +-- productions +checkPat loc cs (L l e@(PatBuilderVar (L ln c))) args + | isRdrDataCon c || isRdrTc c + = return (L loc $ ConPat + { pat_con_ext = noAnn -- AZ: where should this come from? + , pat_con = L ln c + , pat_args = PrefixCon args + }, comments l Semi.<> cs) + | (not (null args) && patIsRec c) = do + ctx <- askParseContext + patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx +checkPat loc cs (L la (PatBuilderAppType f at t)) args = + checkPat loc (cs Semi.<> comments la) f (mkInvisLPat at t : args) +checkPat loc cs (L la (PatBuilderApp f e)) args = do + p <- checkLPat e + checkPat loc (cs Semi.<> comments la) f (p : args) +checkPat loc cs (L l e) [] = do + p <- checkAPat loc e + return (L l p, cs) +checkPat loc _ e _ = do + details <- fromParseContext <$> askParseContext + patFail (locA loc) (PsErrInPat (unLoc e) details) + +mkInvisLPat :: EpToken "@" -> HsTyPat GhcPs -> LPat GhcPs +mkInvisLPat tok ty_pat = L l invis_pat + where + HsTP _ (L (EpAnn anc _ _) _) = ty_pat + l = EpAnn (widenAnchorT anc tok) noAnn emptyComments + invis_pat = InvisPat (tok, SpecifiedSpec) ty_pat + +checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) +checkAPat loc e0 = do + nPlusKPatterns <- getBit NPlusKPatternsBit + case e0 of + PatBuilderPat p -> return p + PatBuilderVar x -> return (VarPat noExtField x) + + -- Overloaded numeric patterns (e.g. f 0 x = x) + -- Negation is recorded separately, so that the literal is zero or +ve + -- NB. Negative *primitive* literals are already handled by the lexer + PatBuilderOverLit pos_lit -> return (mkNPat (L (l2l loc) pos_lit) Nothing noAnn) + + -- n+k patterns + PatBuilderOpApp + (L _ (PatBuilderVar (L nloc n))) + (L l plus) + (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) + _ + | nPlusKPatterns && (plus == plus_RDR) + -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit) + (EpTok $ entry l)) + + -- Improve error messages for the @-operator when the user meant an @-pattern + PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do + addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos + return (WildPat noExtField) + + PatBuilderOpApp l (L cl c) r (_os,_cs) + | isRdrDataCon c || isRdrTc c -> do + l <- checkLPat l + r <- checkLPat r + return $ ConPat + { pat_con_ext = noAnn + , pat_con = L cl c + , pat_args = InfixCon l r + } + + PatBuilderPar lpar e rpar -> do + p <- checkLPat e + return (ParPat (lpar, rpar) p) + + _ -> do + details <- fromParseContext <$> askParseContext + patFail (locA loc) (PsErrInPat e0 details) + +placeHolderPunRhs :: DisambECP b => PV (LocatedA b) +-- The RHS of a punned record field will be filled in by the renamer +-- It's better not to make it an error, in case we want to print it when +-- debugging +placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR) + +plus_RDR, pun_RDR :: RdrName +plus_RDR = mkUnqual varName (fsLit "+") -- Hack +pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") + +checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs)) + -> PV (LHsRecField GhcPs (LPat GhcPs)) +checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld) + return (L l (fld { hfbRHS = p })) + +patFail :: SrcSpan -> PsMessage -> PV a +patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg + +patIsRec :: RdrName -> Bool +patIsRec e = e == mkUnqual varName (fsLit "rec") + +--------------------------------------------------------------------------- +-- Check Equation Syntax + +checkValDef :: SrcSpan + -> LocatedA (PatBuilder GhcPs) + -> (HsMultAnn GhcPs, Maybe (TokDcolon, LHsType GhcPs)) + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P (HsBind GhcPs) + +checkValDef loc lhs (mult, Just (sigAnn, sig)) grhss + -- x :: ty = rhs parses as a *pattern* binding + = do lhs' <- runPV $ mkHsTySigPV (combineLocsA lhs sig) lhs sig sigAnn + >>= checkLPat + checkPatBind loc lhs' grhss mult + +checkValDef loc lhs (mult_ann, Nothing) grhss + | HsUnannotated{} <- mult_ann + = do { mb_fun <- isFunLhs lhs + ; case mb_fun of + Just (fun, is_infix, pats, ops, cps) -> do + let ann_fun = mk_ann_funrhs ops cps + let l = listLocation pats + checkFunBind loc ann_fun + fun is_infix (L l pats) grhss + Nothing -> do + lhs' <- checkPattern lhs + checkPatBind loc lhs' grhss mult_ann } + +checkValDef loc lhs (mult_ann, Nothing) ghrss + -- %p x = rhs parses as a *pattern* binding + = do lhs' <- checkPattern lhs + checkPatBind loc lhs' ghrss mult_ann + +mk_ann_funrhs :: [EpToken "("] -> [EpToken ")"] -> AnnFunRhs +mk_ann_funrhs ops cps = AnnFunRhs NoEpTok ops cps + +checkFunBind :: SrcSpan + -> AnnFunRhs + -> LocatedN RdrName + -> LexicalFixity + -> LocatedE [LocatedA (PatBuilder GhcPs)] + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P (HsBind GhcPs) +checkFunBind locF ann_fun (L lf fun) is_infix (L lp pats) (L _ grhss) + = do ps <- runPV_details extraDetails (mapM checkLPat pats) + let match_span = noAnnSrcSpan $ locF + return (makeFunBind (L (l2l lf) fun) (L (noAnnSrcSpan $ locA match_span) + [L match_span (Match { m_ext = noExtField + , m_ctxt = FunRhs + { mc_fun = L lf fun + , mc_fixity = is_infix + , mc_strictness = NoSrcStrict + , mc_an = ann_fun } + , m_pats = L lp ps + , m_grhss = grhss })])) + -- The span of the match covers the entire equation. + -- That isn't quite right, but it'll do for now. + where + extraDetails + | Infix <- is_infix = ParseContext (Just fun) NoIncompleteDoBlock + | otherwise = noParseContext + +makeFunBind :: LocatedN RdrName -> LocatedLW [LMatch GhcPs (LHsExpr GhcPs)] + -> HsBind GhcPs +-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too +makeFunBind fn ms + = FunBind { fun_ext = noExtField, + fun_id = fn, + fun_matches = mkMatchGroup FromSource ms } + +-- See Note [FunBind vs PatBind] +checkPatBind :: SrcSpan + -> LPat GhcPs + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> HsMultAnn GhcPs + -> P (HsBind GhcPs) +checkPatBind loc (L _ (BangPat an (L _ (VarPat _ v)))) + (L _match_span grhss) (HsUnannotated _) + = return (makeFunBind v (L (noAnnSrcSpan loc) + [L (noAnnSrcSpan loc) (m an v)])) + where + m a v = Match { m_ext = noExtField + , m_ctxt = FunRhs { mc_fun = v + , mc_fixity = Prefix + , mc_strictness = SrcStrict + , mc_an = AnnFunRhs a [] [] } + , m_pats = noLocA [] + , m_grhss = grhss } + +checkPatBind _loc lhs (L _ grhss) mult = do + return (PatBind noExtField lhs mult grhss) + + +checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName) +checkValSigLhs lhs@(L l lhs_expr) = + case lhs_expr of + HsVar _ lrdr@(L _ v) -> check_var v lrdr + _ -> make_err PsErrInvalidTypeSig_Other + where + check_var v lrdr + | not (isUnqual v) = make_err PsErrInvalidTypeSig_Qualified + | isDataOcc occ_n = make_err PsErrInvalidTypeSig_DataCon + | otherwise = pure lrdr + where occ_n = rdrNameOcc v + make_err reason = addFatalError $ + mkPlainErrorMsgEnvelope (locA l) (PsErrInvalidTypeSignature reason lhs) + + +checkDoAndIfThenElse + :: (Outputable a, Outputable b, Outputable c) + => (a -> Bool -> b -> Bool -> c -> PsMessage) + -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV () +checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr + | semiThen || semiElse = do + doAndIfThenElse <- getBit DoAndIfThenElseBit + let e = err (unLoc guardExpr) + semiThen (unLoc thenExpr) + semiElse (unLoc elseExpr) + loc = combineLocs (reLoc guardExpr) (reLoc elseExpr) + + unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e) + | otherwise = return () + +isFunLhs :: LocatedA (PatBuilder GhcPs) + -> P (Maybe (LocatedN RdrName, LexicalFixity, + [LocatedA (PatBuilder GhcPs)],[EpToken "("],[EpToken ")"])) +-- A variable binding is parsed as a FunBind. +-- Just (fun, is_infix, arg_pats) if e is a function LHS +isFunLhs e = go e [] [] [] + where + go (L l (PatBuilderVar (L loc f))) es ops cps + | not (isRdrDataCon f) = do + let (_l, loc') = transferCommentsOnlyA l loc + return (Just (L loc' f, Prefix, es, (reverse ops), cps)) + go (L l (PatBuilderApp (L lf f) e)) es ops cps = do + let (_l, lf') = transferCommentsOnlyA l lf + go (L lf' f) (e:es) ops cps + go (L l (PatBuilderPar _ (L le e) _)) es@(_:_) ops cps = go (L le' e) es (o:ops) (c:cps) + -- NB: es@(_:_) means that there must be an arg after the parens for the + -- LHS to be a function LHS. This corresponds to the Haskell Report's definition + -- of funlhs. + where + (_l, le') = transferCommentsOnlyA l le + (o,c) = mkParensEpToks (realSrcSpan $ locA l) + go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r (os,cs))) es ops cps + | not (isRdrDataCon op) -- We have found the function! + = do { let (_l, ll') = transferCommentsOnlyA loc ll + ; return (Just (L loc' op, Infix, ((L ll' l):r:es), (os ++ reverse ops), (cs ++ cps))) } + | otherwise -- Infix data con; keep going + = do { let (_l, ll') = transferCommentsOnlyA loc ll + ; mb_l <- go (L ll' l) es ops cps + ; return (reassociate =<< mb_l) } + where + reassociate (op', Infix, j : L k_loc k : es', ops', cps') + = Just (op', Infix, j : op_app : es', ops', cps') + where + op_app = L loc (PatBuilderOpApp (L k_loc k) + (L loc' op) r (reverse ops, cps)) + reassociate _other = Nothing + go (L l (PatBuilderAppType (L lp pat) tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps + = go (L lp' pat) (L (EpAnn anc' ann cs) (PatBuilderPat invis_pat) : es) ops cps + where invis_pat = InvisPat (tok, SpecifiedSpec) ty_pat + anc' = widenAnchorT anc tok + (_l, lp') = transferCommentsOnlyA l lp + go _ _ _ _ = return Nothing + +mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs +mkBangTy tok_loc strictness lty = + XHsType (HsBangTy (noAnn, noAnn, tok_loc) (HsSrcBang NoSourceText NoSrcUnpack strictness) lty) + +-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@. +data UnpackednessPragma = + UnpackednessPragma (EpaLocation, EpToken "#-}") SourceText SrcUnpackedness + +-- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma. +addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs) +addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do + let l' = combineSrcSpans lprag (getLocA ty) + let t' = addUnpackedness anns ty + return (L (noAnnSrcSpan l') t') + where + -- If we have a HsBangTy that only has a strictness annotation, + -- such as ~T or !T, then add the pragma to the existing HsBangTy. + -- + -- Otherwise, wrap the type in a new HsBangTy constructor. + addUnpackedness (o,c) (L _ (XHsType (HsBangTy (_,_,tl) bang t))) + | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang + = XHsType (HsBangTy (o,c,tl) (HsSrcBang prag unpk strictness) t) + addUnpackedness (o,c) t + = XHsType (HsBangTy (o,c,noAnn) (HsSrcBang prag unpk NoSrcStrict) t) + +--------------------------------------------------------------------------- +-- | Check for monad comprehensions +-- +-- If the flag MonadComprehensions is set, return a 'MonadComp' context, +-- otherwise use the usual 'ListComp' context + +checkMonadComp :: PV HsDoFlavour +checkMonadComp = do + monadComprehensions <- getBit MonadComprehensionsBit + return $ if monadComprehensions + then MonadComp + else ListComp + +-- ------------------------------------------------------------------------- +-- Expression/command/pattern ambiguity. +-- See Note [Ambiguous syntactic categories] +-- + +-- See Note [Ambiguous syntactic categories] +-- +-- This newtype is required to avoid impredicative types in monadic +-- productions. That is, in a production that looks like +-- +-- | ... {% return (ECP ...) } +-- +-- we are dealing with +-- P ECP +-- whereas without a newtype we would be dealing with +-- P (forall b. DisambECP b => PV (Located b)) +-- +newtype ECP = + ECP { unECP :: forall b. DisambECP b => PV (LocatedA b) } + +ecpFromExp :: LHsExpr GhcPs -> ECP +ecpFromExp a = ECP (ecpFromExp' a) + +ecpFromCmd :: LHsCmd GhcPs -> ECP +ecpFromCmd a = ECP (ecpFromCmd' a) + +ecpFromPat :: LPat GhcPs -> ECP +ecpFromPat a = ECP (ecpFromPat' a) + +-- The 'fbinds' parser rule produces values of this type. See Note +-- [RecordDotSyntax field updates]. +type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b)) + +-- | Disambiguate infix operators. +-- See Note [Ambiguous syntactic categories] +class DisambInfixOp b where + mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b) + mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b) + mkHsInfixHolePV :: LocatedN RdrName -> PV (LocatedN b) + +instance DisambInfixOp (HsExpr GhcPs) where + mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v) + mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v) + mkHsInfixHolePV v = return $ L (getLoc v) (HsHole (HoleVar v)) + +instance DisambInfixOp RdrName where + mkHsConOpPV (L l v) = return $ L l v + mkHsVarOpPV (L l v) = return $ L l v + mkHsInfixHolePV (L l _) = addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole + +type AnnoBody b + = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ EpAnnCO + , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnLW + , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA + , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA + , Anno [LocatedA (StmtLR GhcPs GhcPs + (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnLW + ) + +-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are +-- parsing an expression, a command, or a pattern. +-- See Note [Ambiguous syntactic categories] +class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where + -- | See Note [Body in DisambECP] + type Body b :: Type -> Type + -- | Return a command without ambiguity, or fail in a non-command context. + ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b) + -- | Return an expression without ambiguity, or fail in a non-expression context. + ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b) + -- | Return a pattern without ambiguity, or fail in a non-pattern context. + ecpFromPat' :: LPat GhcPs -> PV (LocatedA b) + mkHsProjUpdatePV :: SrcSpan -> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) + -> LocatedA b -> Bool -> Maybe (EpToken "=") -> PV (LHsRecProj GhcPs (LocatedA b)) + -- | Disambiguate "let ... in ..." + mkHsLetPV + :: SrcSpan + -> EpToken "let" + -> HsLocalBinds GhcPs + -> EpToken "in" + -> LocatedA b + -> PV (LocatedA b) + -- | Infix operator representation + type InfixOp b + -- | Bring superclass constraints on InfixOp into scope. + -- See Note [UndecidableSuperClasses for associated types] + superInfixOp + :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b) + -- | Disambiguate "f # x" (infix operator) + mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b + -> PV (LocatedA b) + -- | Disambiguate "case ... of ..." + mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedLW [LMatch GhcPs (LocatedA b)]) + -> EpAnnHsCase -> PV (LocatedA b) + -- | Disambiguate "\... -> ..." (lambda), "\case" and "\cases" + mkHsLamPV :: SrcSpan -> HsLamVariant + -> (LocatedLW [LMatch GhcPs (LocatedA b)]) -> EpAnnLam + -> PV (LocatedA b) + -- | Function argument representation + type FunArg b + -- | Bring superclass constraints on FunArg into scope. + -- See Note [UndecidableSuperClasses for associated types] + superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b) + -- | Disambiguate "f x" (function application) + mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b) + -- | Disambiguate "f @t" (visible type application) + mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b) + -- | Disambiguate "if ... then ... else ..." + mkHsIfPV :: SrcSpan + -> LHsExpr GhcPs + -> Bool -- semicolon? + -> LocatedA b + -> Bool -- semicolon? + -> LocatedA b + -> AnnsIf + -> PV (LocatedA b) + -- | Disambiguate "do { ... }" (do notation) + mkHsDoPV :: + SrcSpan -> + Maybe ModuleName -> + LocatedLW [LStmt GhcPs (LocatedA b)] -> + EpaLocation -> -- Token + EpaLocation -> -- Anchor + PV (LocatedA b) + -- | Disambiguate "( ... )" (parentheses) + mkHsParPV :: SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b) + -- | Disambiguate a variable "f" or a data constructor "MkF". + mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b) + -- | Disambiguate a monomorphic literal + mkHsLitPV :: Located (HsLit GhcPs) -> PV (LocatedA b) + -- | Disambiguate an overloaded literal + mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b) + -- | Disambiguate a wildcard + mkHsWildCardPV :: (NoAnn a) => SrcSpan -> PV (LocatedAn a b) + -- | Disambiguate "a :: t" (type annotation) + mkHsTySigPV + :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> TokDcolon -> PV (LocatedA b) + -- | Disambiguate "[a,b,c]" (list syntax) + mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList () -> PV (LocatedA b) + -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) + mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b) + -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) + mkHsRecordPV :: + Bool -> -- Is OverloadedRecordUpdate in effect? + SrcSpan -> + SrcSpan -> + LocatedA b -> + ([Fbind b], Maybe SrcSpan) -> + (Maybe (EpToken "{"), Maybe (EpToken "}")) -> + PV (LocatedA b) + -- | Disambiguate "-a" (negation) + mkHsNegAppPV :: SrcSpan -> LocatedA b -> EpToken "-" -> PV (LocatedA b) + -- | Disambiguate "(# a)" (right operator section) + mkHsSectionR_PV + :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (LocatedA b) + -- | Disambiguate "(a -> b)" (view pattern or function type arrow) + mkHsArrowPV + :: SrcSpan -> ArrowParsingMode lhs b -> LocatedA lhs -> HsMultAnnOf (LocatedA b) GhcPs -> LocatedA b -> PV (LocatedA b) + -- | Disambiguate "%m" to the left of "->" (multiplicity) + mkHsMultPV + :: EpToken "%" -> LocatedA b -> PV (TokRarrow -> HsMultAnnOf (LocatedA b) GhcPs) + -- | Disambiguate "forall a. b" and "forall a -> b" (forall telescope) + mkHsForallPV :: SrcSpan -> HsForAllTelescope GhcPs -> LocatedA b -> PV (LocatedA b) + -- | Disambiguate "(a,b,c)" to the left of "=>" (constraint list) + checkContextPV :: LocatedA b -> PV (LocatedC [LocatedA b]) + -- | Disambiguate "a => b" (constraint context) + mkQualPV :: SrcSpan -> LocatedC [LocatedA b] -> LocatedA b -> PV (LocatedA b) + -- | Disambiguate "a@b" (as-pattern) + mkHsAsPatPV + :: SrcSpan -> LocatedN RdrName -> EpToken "@" -> LocatedA b -> PV (LocatedA b) + -- | Disambiguate "~a" (lazy pattern) + mkHsLazyPatPV :: SrcSpan -> LocatedA b -> EpToken "~" -> PV (LocatedA b) + -- | Disambiguate "!a" (bang pattern) + mkHsBangPatPV :: SrcSpan -> LocatedA b -> EpToken "!" -> PV (LocatedA b) + -- | Disambiguate tuple sections and unboxed sums + mkSumOrTuplePV + :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> (EpaLocation, EpaLocation) -> PV (LocatedA b) + -- | Disambiguate "type t" (embedded type) + mkHsEmbTyPV :: SrcSpan -> EpToken "type" -> LHsType GhcPs -> PV (LocatedA b) + -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas + rejectPragmaPV :: LocatedA b -> PV () + +{- Note [UndecidableSuperClasses for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This Note is about the code in GHC, not about the user code that we are parsing) + +Assume we have a class C with an associated type T: + + class C a where + type T a + ... + +If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses: + + {-# LANGUAGE UndecidableSuperClasses #-} + class C (T a) => C a where + type T a + ... + +Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes +making GHC loop. The workaround is to bring this constraint into scope +manually with a helper method: + + class C a where + type T a + superT :: (C (T a) => r) -> r + +In order to avoid ambiguous types, 'r' must mention 'a'. + +For consistency, we use this approach for all constraints on associated types, +even when -XUndecidableSuperClasses are not required. +-} + +{- Note [Body in DisambECP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that +require their argument to take a form of (body GhcPs) for some (body :: Type -> +*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the +superclass constraints of DisambECP. + +The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop +this requirement. It is possible and would allow removing the type index of +PatBuilder, but leads to worse type inference, breaking some code in the +typechecker. +-} + +instance DisambECP (HsCmd GhcPs) where + type Body (HsCmd GhcPs) = HsCmd + ecpFromCmd' = return + ecpFromExp' (L l e) = cmdFail (locA l) (ppr e) + ecpFromPat' (L l p) = cmdFail (locA l) (ppr p) + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ + PsErrOverloadedRecordDotInvalid + mkHsLamPV l lam_variant (L lm m) anns = do + !cs <- getCommentsFor l + let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLam anns lam_variant mg) + + mkHsLetPV l tkLet bs tkIn e = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLet (tkLet, tkIn) bs e) + + type InfixOp (HsCmd GhcPs) = HsExpr GhcPs + + superInfixOp m = m + + mkHsOpAppPV l c1 op c2 = do + let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm noAnn (reLoc op) Infix [cmdArg c1, cmdArg c2] + + mkHsCasePV l c (L lm m) anns = do + !cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdCase anns c mg) + + type FunArg (HsCmd GhcPs) = HsExpr GhcPs + superFunArg m = m + mkHsAppPV l c e = do + checkCmdBlockArguments c + checkExpBlockArguments e + return $ L l (HsCmdApp noExtField c e) + mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t) + mkHsIfPV l c semi1 a semi2 b anns = do + checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns) + mkHsDoPV l Nothing stmts tok_loc anc = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) ListNone [] tok_loc []) stmts) + mkHsDoPV l (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m + mkHsParPV l lpar c rpar = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c) + mkHsVarPV (L l v) = cmdFail (locA l) (ppr v) + mkHsLitPV (L l a) = cmdFail l (ppr a) + mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a) + mkHsWildCardPV l = cmdFail l (text "_") + mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> dcolon <+> ppr sig) + mkHsExplicitListPV l xs _ = cmdFail l $ + brackets (pprWithCommas ppr xs) + mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp) + mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do + let (fs, ps) = partitionEithers fbinds + if not (null ps) + then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid + else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc) + mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a) + mkHsSectionR_PV l op c = cmdFail l $ + let pp_op = fromMaybe (panic "cannot print infix operator") + (ppr_infix_expr (unLoc op)) + in pp_op <> ppr c + mkHsArrowPV l mode a arr b = cmdFail l $ + case mode of -- matching on the mode brings Outputable instances into scope + ArrowIsViewPat -> ppr a <+> pprHsArrow arr <+> ppr b + ArrowIsFunType -> ppr a <+> pprHsArrow arr <+> ppr b + mkHsMultPV pct mult = cmdFail l $ + ppr pct <> ppr mult + where l = getHasLoc pct `combineSrcSpans` getHasLoc mult + mkHsForallPV l tele cmd = cmdFail l $ + pprHsForAll tele Nothing <+> ppr cmd + checkContextPV ctxt = cmdFail (getLocA ctxt) $ ppr ctxt + mkQualPV l ctxt cmd = cmdFail l $ + ppr ctxt <+> text "=>" <+> ppr cmd + mkHsAsPatPV l v _ c = cmdFail l $ + pprPrefixOcc (unLoc v) <> text "@" <> ppr c + mkHsLazyPatPV l c _ = cmdFail l $ + text "~" <> ppr c + mkHsBangPatPV l c _ = cmdFail l $ + text "!" <> ppr c + mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a) + mkHsEmbTyPV l _ ty = cmdFail l (text "type" <+> ppr ty) + rejectPragmaPV _ = return () + +cmdFail :: SrcSpan -> SDoc -> PV a +cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e + +checkLamMatchGroup :: SrcSpan -> HsLamVariant -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV () +checkLamMatchGroup l LamSingle (MG { mg_alts = (L _ (matches:_))}) = do + when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda +checkLamMatchGroup _ _ _ = return () + +instance DisambECP (HsExpr GhcPs) where + type Body (HsExpr GhcPs) = HsExpr + ecpFromCmd' (L l c) = do + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c + return (L l parseError) + ecpFromExp' = return + ecpFromPat' p@(L l _) = do + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrOrPatInExpr p + return (L l parseError) + mkHsProjUpdatePV l fields arg isPun anns = do + !cs <- getCommentsFor l + return $ mkRdrProjUpdate (EpAnn (spanAsAnchor l) noAnn cs) fields arg isPun anns + mkHsLetPV l tkLet bs tkIn c = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLet (tkLet, tkIn) bs c) + type InfixOp (HsExpr GhcPs) = HsExpr GhcPs + superInfixOp m = m + mkHsOpAppPV l e1 op e2 = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ OpApp noExtField e1 (reLoc op) e2 + mkHsCasePV l e (L lm m) anns = do + !cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCase anns e mg) + mkHsLamPV l lam_variant (L lm m) anns = do + !cs <- getCommentsFor l + let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m) + checkLamMatchGroup l lam_variant mg + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLam anns lam_variant mg) + type FunArg (HsExpr GhcPs) = HsExpr GhcPs + superFunArg m = m + mkHsAppPV l e1 e2 = do + checkExpBlockArguments e1 + checkExpBlockArguments e2 + return $ L l (HsApp noExtField e1 e2) + mkHsAppTypePV l e at t = do + checkExpBlockArguments e + return $ L l (HsAppType at e (mkHsWildCardBndrs t)) + mkHsIfPV l c semi1 a semi2 b anns = do + checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns) + mkHsDoPV l mod stmts loc_tok anc = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) ListNone [] loc_tok []) (DoExpr mod) stmts) + mkHsParPV l lpar e rpar = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e) + mkHsVarPV v@(L l@(EpAnn anc _ _) _) = do + !cs <- getCommentsFor (getHasLoc l) + return $ L (EpAnn anc noAnn cs) (HsVar noExtField v) + mkHsLitPV (L l a) = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLit noExtField a) + mkHsOverLitPV (L (EpAnn l an csIn) a) = do + !cs <- getCommentsFor (locA l) + return $ L (EpAnn l an (cs Semi.<> csIn)) (HsOverLit NoExtField a) + mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (HsHole (HoleVar (L (noAnnSrcSpan l) (mkUnqual varName (fsLit "_"))))) + mkHsTySigPV l@(EpAnn anc an csIn) a sig anns = do + !cs <- getCommentsFor (locA l) + return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExprWithTySig anns a (hsTypeToHsSigWcType sig)) + mkHsExplicitListPV l xs anns = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (ExplicitList anns xs) + mkHsSplicePV (L l a) = do + !cs <- getCommentsFor l + return $ fmap (HsUntypedSplice NoExtField) (L (EpAnn (spanAsAnchor l) noAnn cs) a) + mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do + !cs <- getCommentsFor l + r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) anns + checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r) + mkHsNegAppPV l a anns = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (NegApp anns a noSyntaxExpr) + mkHsSectionR_PV l op e = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (SectionR noExtField op e) + mkHsAsPatPV l v _ e = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e) + >> return (L (noAnnSrcSpan l) parseError) + mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e) + >> return (L (noAnnSrcSpan l) parseError) + mkHsBangPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e) + >> return (L (noAnnSrcSpan l) parseError) + mkSumOrTuplePV = mkSumOrTupleExpr + mkHsEmbTyPV l toktype ty = + return $ L (noAnnSrcSpan l) $ + HsEmbTy toktype (mkHsWildCardBndrs ty) + mkHsArrowPV l mode arg arr res = + -- In expressions, (e1 -> e2) is always parsed as a function type, + -- even if ViewPatterns are enabled. + exprArrowParsingMode mode $ + return $ L (noAnnSrcSpan l) $ + HsFunArr noExtField arr arg res + mkHsMultPV pct t = + return $ mkMultExpr pct t + mkHsForallPV l telescope ty = + return $ L (noAnnSrcSpan l) $ + HsForAll noExtField (setTelescopeBndrsNameSpace varName telescope) ty + checkContextPV = checkContextExpr + mkQualPV l qual ty = + return $ L (noAnnSrcSpan l) $ + HsQual noExtField qual ty + rejectPragmaPV (L _ (OpApp _ _ _ e)) = + -- assuming left-associative parsing of operators + rejectPragmaPV e + rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrUnallowedPragma prag) + rejectPragmaPV _ = return () + +instance DisambECP (PatBuilder GhcPs) where + type Body (PatBuilder GhcPs) = PatBuilder + ecpFromCmd' (L l c) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c + ecpFromExp' (L l e) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e + ecpFromPat' (L l p) = return $ L l (PatBuilderPat p) + mkHsLetPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid + type InfixOp (PatBuilder GhcPs) = RdrName + superInfixOp m = m + mkHsOpAppPV l p1 op p2 = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 ([],[]) + + mkHsLamPV l lam_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaInPat lam_variant) + + mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat + type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs + superFunArg m = m + mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) + mkHsAppTypePV l p at t = do + !cs <- getCommentsFor (locA l) + return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t)) + mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat + mkHsDoPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat + mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) + mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v) + mkHsLitPV lit@(L l a) = do + checkUnboxedLitPat lit + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LitPat noExtField a)) + mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a) + mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (PatBuilderPat (WildPat noExtField)) + mkHsTySigPV l p t anns = do + p' <- checkLPat p + let sig = mkHsPatSigType noAnn t + sig_pat <- addSigPatP l p' sig anns + return $ fmap PatBuilderPat sig_pat + mkHsExplicitListPV l xs anns = do + ps <- traverse checkLPat xs + !cs <- getCommentsFor l + return (L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ListPat anns ps))) + mkHsSplicePV (L l sp) = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (SplicePat noExtField sp)) + mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do + let (fs, ps) = partitionEithers fbinds + if not (null ps) + then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid + else do + !cs <- getCommentsFor l + r <- mkPatRec a (mk_rec_fields fs ddLoc) anns + checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r) + mkHsNegAppPV l (L lp p) anns = do + lit <- case p of + PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit) + _ -> patFail l $ PsErrInPat p PEIP_NegApp + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) anns)) + mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p)) + mkHsArrowPV l ArrowIsViewPat a arr b = do + p <- checkLPat b + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ViewPat tok a p)) + where + tok :: TokRarrow + tok = case arr of + HsUnannotated (EpArrow x) -> x + _ -> -- unreachable case because in Parser.y the reduction rules for + -- (a %m -> b) and (a ->. b) use ArrowIsFunType + panic "mkHsArrowPV ArrowIsViewPat: expected HsUnannotated" + mkHsArrowPV l ArrowIsFunType a arr b = + patFail l (PsErrTypeSyntaxInPat (PETS_FunctionArrow a arr b)) + mkHsMultPV tok arg = + let l = getHasLoc tok `combineSrcSpans` getLocA arg in + patFail l (PsErrTypeSyntaxInPat (PETS_Multiplicity tok arg)) + mkHsForallPV l tele body = patFail l (PsErrTypeSyntaxInPat (PETS_ForallTelescope tele body)) + checkContextPV ctx = patFail (getLocA ctx) (PsErrTypeSyntaxInPat (PETS_ConstraintContext ctx)) + mkQualPV _ _ _ = -- unreachable because mkQualPV is only called on the result + -- of checkContextPV, which fails in patterns + panic "mkQualPV in a pattern" + mkHsAsPatPV l v at e = do + p <- checkLPat e + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (AsPat at v p)) + mkHsLazyPatPV l e a = do + p <- checkLPat e + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LazyPat a p)) + mkHsBangPatPV l e an = do + p <- checkLPat e + !cs <- getCommentsFor l + let pb = BangPat an p + hintBangPat l pb + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat pb) + mkSumOrTuplePV = mkSumOrTuplePat + mkHsEmbTyPV l toktype ty = + return $ L (noAnnSrcSpan l) $ + PatBuilderPat (EmbTyPat toktype (mkHsTyPat ty)) + rejectPragmaPV _ = return () + +-- For reasons of backwards compatibility, we can't simply add the pattern +-- signature if the inner pattern is a view pattern. Consider: +-- (f -> p :: t) +-- There are two ways to parse it +-- (f -> (p :: t)) -- legacy parse +-- ((f -> p) :: t) -- future parse +-- The grammar in Parser.y is structured in such a way that we get the +-- future parse by default. Until we're ready to make the breaking change, +-- we need to do some extra work here to push the signature under the view +-- pattern (and emit a warning). +addSigPatP :: SrcSpanAnnA -> LPat GhcPs -> HsPatSigType GhcPs -> TokDcolon -> PV (LPat GhcPs) +addSigPatP l viewpat@(L _ ViewPat{}) sig anns = + -- Test case: T24159_viewpat + do { let futureParse = L l (SigPat anns viewpat sig) + ; legacyParse <- go viewpat + ; addPsMessage (locA l) (PsWarnViewPatternSignatures legacyParse futureParse) + ; return legacyParse } + where + sig_loc_no_comments :: SrcSpan + sig_loc_no_comments = getLocA (hsps_body sig) + + -- Test case for comments and locations preservation: Test24159 + go :: LPat GhcPs -> PV (LPat GhcPs) + go (L (EpAnn (EpaSpan view_pat_loc) anns cs1) (ViewPat anns' e' p')) = do + sig' <- go p' + let new_loc = view_pat_loc `combineSrcSpans` sig_loc_no_comments + cs2 <- getCommentsFor new_loc + let ep_ann_loc = EpAnn (spanAsAnchor new_loc) anns (cs1 Semi.<> cs2) + pure (L ep_ann_loc (ViewPat anns' e' sig')) + + go p = pure $ L new_loc (SigPat anns p sig) + where new_loc = noAnnSrcSpan ((getLocA p) `combineSrcSpans` sig_loc_no_comments) + +addSigPatP l p sig anns = do + return $ L l (SigPat anns p sig) + +{- Note [Arrow parsing mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example: + f (K (a -> b)) = () + +A pattern of the form (a -> b) could be parsed in one of two ways: + * a view pattern `viewfn -> pat` (with ViewPatterns) + * a function type `t1 -> t2` (with RequiredTypeArguments) + +This depends on the enabled extensions: + NoViewPatterns, RequiredTypeArguments => function type + NoViewPatterns, NoRequiredTypeArguments => error (suggest ViewPatterns) + ViewPatterns, RequiredTypeArguments => view pattern + ViewPatterns, NoRequiredTypeArguments => view pattern + +The decision how to parse arrow patterns (p1 -> p2) is captured by the +`ArrowParsingMode` data type, produced in `withArrowParsingMode` and +consumed in `mkHsArrowPV`. + +Naively, one might expect to see the following definition: + + -- a simple (but insufficient) definition + data ArrowParsingMode = ArrowIsViewPat | ArrowIsFunType + +However, there is a slight complication that leads us to parameterize these +constructor with GADT type indices. In a pattern (p1 -> p2), what is the AST +type to represent the LHS `p1`? It depends: + * if (p1 -> p2) is a view pattern, `p1` is an HsExpr + * if (p1 -> p2) is a function type, `p1` is a Pat (PatBuilder) + +And since the decision how to parse `p1` depends on the arrow parsing mode, we +could try to encode the LHS type as a GADT index: + + -- a less simple (but still insufficient) definition + data ArrowParsingMode lhs where + ArrowIsViewPat :: ArrowParsingMode (PatBuilder GhcPs) + ArrowIsFunType :: ArrowParsingMode (HsExpr GhcPs) + +This definition would suffice for parsing patterns, but remember that +expressions, commands, and patterns are all parsed using a unified framework +`DisambECP`, as described in Note [Ambiguous syntactic categories]. + +In an expression (e1 -> e2), the LHS is always represented by an HsExpr. +We can account for this with a further refinement of the definition: + + -- actual definition + data ArrowParsingMode lhs rhs where + ArrowIsViewPat :: ArrowParsingMode (HsExpr GhcPs) b + ArrowIsFunType :: ArrowParsingMode b b + +So when parsing a view pattern, the LHS is an HsExpr; and when parsing a +function type, the type of the LHS is assumed to match the type of the RHS, +which works out just right both for expressions and patterns. +-} + +-- The arrow parsing mode is selected depending on the enabled extensions and +-- determines how we parse patterns of the form (p1 -> p2). See Note [Arrow parsing mode] +data ArrowParsingMode lhs rhs where + ArrowIsViewPat :: ArrowParsingMode (HsExpr GhcPs) b -- the LHS is always of type HsExpr + ArrowIsFunType :: ArrowParsingMode b b -- the LHS is of the same type as RHS + +-- When parsing an expression (e1 -> e2), the LHS `e1` is an HsExpr regardless of +-- the arrow parsing mode. `exprArrowParsingMode` proves this to the type checker. +-- See Note [Arrow parsing mode] +exprArrowParsingMode :: ArrowParsingMode lhs (HsExpr GhcPs) -> (lhs ~ HsExpr GhcPs => r) -> r +exprArrowParsingMode ArrowIsViewPat k = k +exprArrowParsingMode ArrowIsFunType k = k + +-- Check the enabled extensions and select the appropriate ArrowParsingMode, +-- then pass it to a continuation. See Note [Arrow parsing mode] +withArrowParsingMode :: DisambECP b => (forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV r) -> PV r +withArrowParsingMode cont = do + vpEnabled <- getBit ViewPatternsBit + rtaEnabled <- getBit RequiredTypeArgumentsBit + if | vpEnabled -> cont ArrowIsViewPat + | rtaEnabled -> cont ArrowIsFunType + | otherwise -> cont ArrowIsViewPat -- Error message should suggest ViewPatterns in patterns + +-- Type-restricted variant of `withArrowParsingMode` to aid type inference (#25103) +withArrowParsingMode' :: DisambECP b => (forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV (LocatedA b)) -> PV (LocatedA b) +withArrowParsingMode' = withArrowParsingMode + +-- When a forall-type occurs in term syntax, forall-bound variables should +-- inhabit the term namespace `varName` rather than the usual `tvName`. +-- See Note [Types in terms]. +-- +-- Since type variable binders in a `HsForAllTelescope` produced by the +-- `forall_telescope` nonterminal have their namespaces set to `tvName`, +-- we use `setTelescopeBndrsNameSpace` to fix them up. +setTelescopeBndrsNameSpace :: NameSpace -> HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs +setTelescopeBndrsNameSpace ns forall_telescope = + case forall_telescope of + HsForAllInvis x bndrs -> HsForAllInvis x (set_bndrs_ns bndrs) + HsForAllVis x bndrs -> HsForAllVis x (set_bndrs_ns bndrs) + where + set_bndrs_ns :: [LHsTyVarBndr flag GhcPs] -> [LHsTyVarBndr flag GhcPs] + set_bndrs_ns = map (setLHsTyVarBndrNameSpace ns) + +setLHsTyVarBndrNameSpace :: NameSpace -> LHsTyVarBndr flag GhcPs -> LHsTyVarBndr flag GhcPs +setLHsTyVarBndrNameSpace ns (L l tvb) = L l tvb' + where tvb' = tvb { tvb_var = setHsBndrVarNameSpace ns (tvb_var tvb) } + +setHsBndrVarNameSpace :: NameSpace -> HsBndrVar GhcPs -> HsBndrVar GhcPs +setHsBndrVarNameSpace ns (HsBndrVar x (L l rdr)) = HsBndrVar x (L l rdr') + where rdr' = setRdrNameSpace rdr ns +setHsBndrVarNameSpace _ (HsBndrWildCard x) = HsBndrWildCard x + +-- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#. +checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV () +checkUnboxedLitPat (L loc lit) = + case lit of + -- Don't allow primitive string literal patterns. + -- See #13260. + HsStringPrim {} + -> addError $ mkPlainErrorMsgEnvelope loc $ + (PsErrIllegalUnboxedStringInPat lit) + + -- Don't allow Float#/Double# literal patterns. + -- See #9238 and Note [Rules for floating-point comparisons] + -- in GHC.Core.Opt.ConstantFold. + _ | is_floating_lit lit + -> addError $ mkPlainErrorMsgEnvelope loc $ + (PsErrIllegalUnboxedFloatingLitInPat lit) + + | otherwise + -> return () + + where + is_floating_lit :: HsLit GhcPs -> Bool + is_floating_lit (HsFloatPrim {}) = True + is_floating_lit (HsDoublePrim {}) = True + is_floating_lit _ = False + +mkPatRec :: + LocatedA (PatBuilder GhcPs) -> + HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) -> + (Maybe (EpToken "{"), Maybe (EpToken "}")) -> + PV (PatBuilder GhcPs) +mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields x fs dd) anns + | isRdrDataCon (unLoc c) + = do fs <- mapM checkPatField fs + return $ PatBuilderPat $ ConPat + { pat_con_ext = anns + , pat_con = c + , pat_args = RecCon (HsRecFields x fs dd) + } +mkPatRec p _ _ = + addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $ + (PsErrInvalidRecordCon (unLoc p)) + +-- | Disambiguate constructs that may appear when we do not know +-- ahead of time whether we are parsing a type or a newtype/data constructor. +-- +-- See Note [Ambiguous syntactic categories] for the general idea. +-- +-- See Note [Parsing data constructors is hard] for the specific issue this +-- particular class is solving. +-- +class DisambTD b where + -- | Process the head of a type-level function/constructor application, + -- i.e. the @H@ in @H a b c@. + mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b) + -- | Disambiguate @f x@ (function application or prefix data constructor). + mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b) + -- | Disambiguate @f \@t@ (visible kind application) + mkHsAppKindTyPV :: LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b) + -- | Disambiguate @f \# x@ (infix operator) + mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b) + -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma) + mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b) + +instance DisambTD (HsType GhcPs) where + mkHsAppTyHeadPV = return + mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2) + mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki) + mkHsOpTyPV prom t1 op t2 = do + let (L l ty) = mkLHsOpTy prom t1 op t2 + !cs <- getCommentsFor (locA l) + return (L (addCommentsToEpAnn l cs) ty) + mkUnpackednessPV = addUnpackednessP + +dataConBuilderCon :: LocatedA DataConBuilder -> LocatedN RdrName +dataConBuilderCon (L _ (PrefixDataConBuilder _ dc)) = dc +dataConBuilderCon (L _ (InfixDataConBuilder _ dc _)) = dc + +dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs + +-- Detect when the record syntax is used: +-- data T = MkT { ... } +dataConBuilderDetails (L _ (PrefixDataConBuilder flds _)) + | [L (EpAnn anc _ cs) (XHsType (HsRecTy an fields))] <- toList flds + = RecCon (L (EpAnn anc an cs) fields) + +-- Normal prefix constructor, e.g. data T = MkT A B C +dataConBuilderDetails (L _ (PrefixDataConBuilder flds _)) + = PrefixCon (map hsPlainTypeField (toList flds)) + +-- Infix constructor, e.g. data T = Int :! Bool +dataConBuilderDetails (L (EpAnn _ _ csl) (InfixDataConBuilder (L (EpAnn anc ann csll) lhs) _ rhs)) + = InfixCon (hsPlainTypeField (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsPlainTypeField rhs) + + +instance DisambTD DataConBuilder where + mkHsAppTyHeadPV = tyToDataConBuilder + + mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t = + return $ + L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t)) + (PrefixDataConBuilder (flds `snocOL` t) fn) + mkHsAppTyPV (L _ InfixDataConBuilder{}) _ = + -- This case is impossible because of the way + -- the grammar in Parser.y is written (see infixtype/ftype). + panic "mkHsAppTyPV: InfixDataConBuilder" + + mkHsAppKindTyPV lhs at ki = + addFatalError $ mkPlainErrorMsgEnvelope (getEpTokenSrcSpan at) $ + (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) + + mkHsOpTyPV prom lhs tc rhs = do + check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative + data_con <- eitherToP $ tyConToDataCon tc + !cs <- getCommentsFor (locA l) + checkNotPromotedDataCon prom data_con + return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs) + where + l = combineLocsA lhs rhs + check_no_ops (XHsType (HsBangTy _ _ t)) = check_no_ops (unLoc t) + check_no_ops (HsOpTy{}) = + addError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) + check_no_ops _ = return () + + mkUnpackednessPV unpk constr_stuff + | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff + = -- When the user writes data T = {-# UNPACK #-} Int :+ Bool + -- we apply {-# UNPACK #-} to the LHS + do lhs' <- addUnpackednessP unpk lhs + let l = combineLocsA (reLoc unpk) constr_stuff + return $ L l (InfixDataConBuilder lhs' data_con rhs) + | otherwise = + do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon + return constr_stuff + +tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder) +tyToDataConBuilder (L l (HsTyVar _ prom v)) = do + data_con <- eitherToP $ tyConToDataCon v + checkNotPromotedDataCon prom data_con + return $ L l (PrefixDataConBuilder nilOL data_con) +tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do + let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts))) + return $ L l (PrefixDataConBuilder (toOL ts) data_con) +tyToDataConBuilder (L l (HsTupleTy _ HsUnboxedTuple ts)) = do + let data_con = L (l2l l) (getRdrName (tupleDataCon Unboxed (length ts))) + return $ L l (PrefixDataConBuilder (toOL ts) data_con) +tyToDataConBuilder t = + addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $ + (PsErrInvalidDataCon (unLoc t)) + +-- | Rejects declarations such as @data T = 'MkT@ (note the leading tick). +checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV () +checkNotPromotedDataCon NotPromoted _ = return () +checkNotPromotedDataCon IsPromoted (L l name) = + addError $ mkPlainErrorMsgEnvelope (locA l) $ + PsErrIllegalPromotionQuoteDataCon name + +mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs) +mkUnboxedSumCon t tag arity = + (noLocA (getRdrName (sumDataCon tag arity)), PrefixCon [hsPlainTypeField t]) + +{- Note [Ambiguous syntactic categories] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are places in the grammar where we do not know whether we are parsing an +expression or a pattern without unlimited lookahead (which we do not have in +'happy'): + +View patterns: + + f (Con a b ) = ... -- 'Con a b' is a pattern + f (Con a b -> x) = ... -- 'Con a b' is an expression + +do-notation: + + do { Con a b <- x } -- 'Con a b' is a pattern + do { Con a b } -- 'Con a b' is an expression + +Guards: + + x | True <- p && q = ... -- 'True' is a pattern + x | True = ... -- 'True' is an expression + +Top-level value/function declarations (FunBind/PatBind): + + f ! a -- TH splice + f ! a = ... -- function declaration + + Until we encounter the = sign, we don't know if it's a top-level + TemplateHaskell splice where ! is used, or if it's a function declaration + where ! is bound. + +There are also places in the grammar where we do not know whether we are +parsing an expression or a command: + + proc x -> do { (stuff) -< x } -- 'stuff' is an expression + proc x -> do { (stuff) } -- 'stuff' is a command + + Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff' + as an expression or a command. + +In fact, do-notation is subject to both ambiguities: + + proc x -> do { (stuff) -< x } -- 'stuff' is an expression + proc x -> do { (stuff) <- f -< x } -- 'stuff' is a pattern + proc x -> do { (stuff) } -- 'stuff' is a command + +There are many possible solutions to this problem. For an overview of the ones +we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives] + +The solution that keeps basic definitions (such as HsExpr) clean, keeps the +concerns local to the parser, and does not require duplication of hsSyn types, +or an extra pass over the entire AST, is to parse into an overloaded +parser-validator (a so-called tagless final encoding): + + class DisambECP b where ... + instance DisambECP (HsCmd GhcPs) where ... + instance DisambECP (HsExp GhcPs) where ... + instance DisambECP (PatBuilder GhcPs) where ... + +The 'DisambECP' class contains functions to build and validate 'b'. For example, +to add parentheses we have: + + mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b) + +'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for +expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat, +see Note [PatBuilder]). + +Consider the 'alts' production used to parse case-of alternatives: + + alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +We abstract over LHsExpr GhcPs, and it becomes: + + alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located b)])) } + : alts1 { $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Compared to the initial definition, the added bits are: + + forall b. DisambECP b => PV ( ... ) -- in the type signature + $1 >>= \ $1 -> return $ -- in one reduction rule + $2 >>= \ $2 -> return $ -- in another reduction rule + +The overhead is constant relative to the size of the rest of the reduction +rule, so this approach scales well to large parser productions. + +Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding +position and shadows the previous $1. We can do this because internally +'happy' desugars $n to happy_var_n, and the rationale behind this idiom +is to be able to write (sLL $1 $>) later on. The alternative would be to +write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer +to the last fresh name as $>. + +Finally, we instantiate the polymorphic type to a concrete one, and run the +parser-validator, for example: + + stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } + e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } + : stmt {% runPV $1 } + +In e_stmt, three things happen: + + 1. we instantiate: b ~ HsExpr GhcPs + 2. we embed the PV computation into P by using runPV + 3. we run validation by using a monadic production, {% ... } + +At this point the ambiguity is resolved. +-} + + +{- Note [Resolving parsing ambiguities: non-taken alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Alternative I, extra constructors in GHC.Hs.Expr +------------------------------------------------ +We could add extra constructors to HsExpr to represent command-specific and +pattern-specific syntactic constructs. Under this scheme, we parse patterns +and commands as expressions and rejig later. This is what GHC used to do, and +it polluted 'HsExpr' with irrelevant constructors: + + * for commands: 'HsArrForm', 'HsArrApp' + * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat' + +(As of now, we still do that for patterns, but we plan to fix it). + +There are several issues with this: + + * The implementation details of parsing are leaking into hsSyn definitions. + + * Code that uses HsExpr has to panic on these impossible-after-parsing cases. + + * HsExpr is arbitrarily selected as the extension basis. Why not extend + HsCmd or HsPat with extra constructors instead? + +Alternative II, extra constructors in GHC.Hs.Expr for GhcPs +----------------------------------------------------------- +We could address some of the problems with Alternative I by using Trees That +Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to +the output of parsing, not to its intermediate results, so we wouldn't want +them there either. + +Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs +--------------------------------------------------------------- +We could introduce a new pass, GhcPrePs, to keep GhcPs pristine. +Unfortunately, creating a new pass would significantly bloat conversion code +and slow down the compiler by adding another linear-time pass over the entire +AST. For example, in order to build HsExpr GhcPrePs, we would need to build +HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds +GhcPrePs. + + +Alternative IV, sum type and bottom-up data flow +------------------------------------------------ +Expressions and commands are disjoint. There are no user inputs that could be +interpreted as either an expression or a command depending on outer context: + + 5 -- definitely an expression + x -< y -- definitely a command + +Even though we have both 'HsLam' and 'HsCmdLam', we can look at +the body to disambiguate: + + \p -> 5 -- definitely an expression + \p -> x -< y -- definitely a command + +This means we could use a bottom-up flow of information to determine +whether we are parsing an expression or a command, using a sum type +for intermediate results: + + Either (LHsExpr GhcPs) (LHsCmd GhcPs) + +There are two problems with this: + + * We cannot handle the ambiguity between expressions and + patterns, which are not disjoint. + + * Bottom-up flow of information leads to poor error messages. Consider + + if ... then 5 else (x -< y) + + Do we report that '5' is not a valid command or that (x -< y) is not a + valid expression? It depends on whether we want the entire node to be + 'HsIf' or 'HsCmdIf', and this information flows top-down, from the + surrounding parsing context (are we in 'proc'?) + +Alternative V, backtracking with parser combinators +--------------------------------------------------- +One might think we could sidestep the issue entirely by using a backtracking +parser and doing something along the lines of (try pExpr <|> pPat). + +Turns out, this wouldn't work very well, as there can be patterns inside +expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns +(e.g. view patterns). To handle this, we would need to backtrack while +backtracking, and unbound levels of backtracking lead to very fragile +performance. + +Alternative VI, an intermediate data type +----------------------------------------- +There are common syntactic elements of expressions, commands, and patterns +(e.g. all of them must have balanced parentheses), and we can capture this +common structure in an intermediate data type, Frame: + +data Frame + = FrameVar RdrName + -- ^ Identifier: Just, map, BS.length + | FrameTuple [LTupArgFrame] Boxity + -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,) + | FrameTySig LFrame (LHsSigWcType GhcPs) + -- ^ Type signature: x :: ty + | FramePar (SrcSpan, SrcSpan) LFrame + -- ^ Parentheses + | FrameIf LFrame LFrame LFrame + -- ^ If-expression: if p then x else y + | FrameCase LFrame [LFrameMatch] + -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 } + | FrameDo HsStmtContextRn [LFrameStmt] + -- ^ Do-expression: do { s1; a <- s2; s3 } + ... + | FrameExpr (HsExpr GhcPs) -- unambiguously an expression + | FramePat (HsPat GhcPs) -- unambiguously a pattern + | FrameCommand (HsCmd GhcPs) -- unambiguously a command + +To determine which constructors 'Frame' needs to have, we take the union of +intersections between HsExpr, HsCmd, and HsPat. + +The intersection between HsPat and HsExpr: + + HsPat = VarPat | TuplePat | SigPat | ParPat | ... + HsExpr = HsVar | ExplicitTuple | ExprWithTySig | HsPar | ... + ------------------------------------------------------------------- + Frame = FrameVar | FrameTuple | FrameTySig | FramePar | ... + +The intersection between HsCmd and HsExpr: + + HsCmd = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar + HsExpr = HsIf | HsCase | HsDo | HsPar + ------------------------------------------------ + Frame = FrameIf | FrameCase | FrameDo | FramePar + +The intersection between HsCmd and HsPat: + + HsPat = ParPat | ... + HsCmd = HsCmdPar | ... + ----------------------- + Frame = FramePar | ... + +Take the union of each intersection and this yields the final 'Frame' data +type. The problem with this approach is that we end up duplicating a good +portion of hsSyn: + + Frame for HsExpr, HsPat, HsCmd + TupArgFrame for HsTupArg + FrameMatch for Match + FrameStmt for StmtLR + FrameGRHS for GRHS + FrameGRHSs for GRHSs + ... + +Alternative VII, a product type +------------------------------- +We could avoid the intermediate representation of Alternative VI by parsing +into a product of interpretations directly: + + type ExpCmdPat = ( PV (LHsExpr GhcPs) + , PV (LHsCmd GhcPs) + , PV (LHsPat GhcPs) ) + +This means that in positions where we do not know whether to produce +expression, a pattern, or a command, we instead produce a parser-validator for +each possible option. + +Then, as soon as we have parsed far enough to resolve the ambiguity, we pick +the appropriate component of the product, discarding the rest: + + checkExpOf3 (e, _, _) = e -- interpret as an expression + checkCmdOf3 (_, c, _) = c -- interpret as a command + checkPatOf3 (_, _, p) = p -- interpret as a pattern + +We can easily define ambiguities between arbitrary subsets of interpretations. +For example, when we know ahead of type that only an expression or a command is +possible, but not a pattern, we can use a smaller type: + + type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs)) + + checkExpOf2 (e, _) = e -- interpret as an expression + checkCmdOf2 (_, c) = c -- interpret as a command + +However, there is a slight problem with this approach, namely code duplication +in parser productions. Consider the 'alts' production used to parse case-of +alternatives: + + alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Under the new scheme, we have to completely duplicate its type signature and +each reduction rule: + + alts :: { ( PV (Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression + , PV (Located ([AddEpAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command + ) } + : alts1 + { ( checkExpOf2 $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) + , checkCmdOf2 $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) + ) } + | ';' alts + { ( checkExpOf2 $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) + , checkCmdOf2 $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) + ) } + +And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs', +'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code! + +Alternative VIII, a function from a GADT +---------------------------------------- +We could avoid code duplication of the Alternative VII by representing the product +as a function from a GADT: + + data ExpCmdG b where + ExpG :: ExpCmdG HsExpr + CmdG :: ExpCmdG HsCmd + + type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs)) + + checkExp :: ExpCmd -> PV (LHsExpr GhcPs) + checkCmd :: ExpCmd -> PV (LHsCmd GhcPs) + checkExp f = f ExpG -- interpret as an expression + checkCmd f = f CmdG -- interpret as a command + +Consider the 'alts' production used to parse case-of alternatives: + + alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +We abstract over LHsExpr, and it becomes: + + alts :: { forall b. ExpCmdG b -> PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) } + : alts1 + { \tag -> $1 tag >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts + { \tag -> $2 tag >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Note that 'ExpCmdG' is a singleton type, the value is completely +determined by the type: + + when (b~HsExpr), tag = ExpG + when (b~HsCmd), tag = CmdG + +This is a clear indication that we can use a class to pass this value behind +the scenes: + + class ExpCmdI b where expCmdG :: ExpCmdG b + instance ExpCmdI HsExpr where expCmdG = ExpG + instance ExpCmdI HsCmd where expCmdG = CmdG + +And now the 'alts' production is simplified, as we no longer need to +thread 'tag' explicitly: + + alts :: { forall b. ExpCmdI b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) } + : alts1 { $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +This encoding works well enough, but introduces an extra GADT unlike the +tagless final encoding, and there's no need for this complexity. + +-} + +{- Note [PatBuilder] +~~~~~~~~~~~~~~~~~~~~ +Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms, +so we introduce the notion of a PatBuilder. + +Consider a pattern like this: + + Con a b c + +We parse arguments to "Con" one at a time in the fexp aexp parser production, +building the result with mkHsAppPV, so the intermediate forms are: + + 1. Con + 2. Con a + 3. Con a b + 4. Con a b c + +In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like +this (pseudocode): + + 1. "Con" + 2. HsApp "Con" "a" + 3. HsApp (HsApp "Con" "a") "b" + 3. HsApp (HsApp (HsApp "Con" "a") "b") "c" + +Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have +instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for +the intermediate forms. + +We also need an intermediate representation to postpone disambiguation between +FunBind and PatBind. Consider: + + a `Con` b = ... + a `fun` b = ... + +How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We +learn this by inspecting an intermediate representation in 'isFunLhs' and +seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate +representation capable of representing both a FunBind and a PatBind, so Pat is +insufficient. + +PatBuilder is an extension of Pat that is capable of representing intermediate +parsing results for patterns and function bindings: + + data PatBuilder p + = PatBuilderPat (Pat p) + | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) + | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p)) + ... + +It can represent any pattern via 'PatBuilderPat', but it also has a variety of +other constructors which were added by following a simple principle: we never +pattern match on the pattern stored inside 'PatBuilderPat'. +-} + +--------------------------------------------------------------------------- +-- Miscellaneous utilities + +-- | Check if a fixity is valid. We support bypassing the usual bound checks +-- for some special operators. +checkPrecP + :: Located (SourceText,Int) -- ^ precedence + -> Located (OrdList (LocatedN RdrName)) -- ^ operators + -> P () +checkPrecP (L l (_,i)) (L _ ol) + | 0 <= i, i <= maxPrecedence = pure () + | all specialOp ol = pure () + | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i) + where + -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs + specialOp op = unLoc op == getRdrName unrestrictedFunTyCon + +mkRecConstrOrUpdate + :: Bool + -> LHsExpr GhcPs + -> SrcSpan + -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) + -> (Maybe (EpToken "{"), Maybe (EpToken "}")) + -> PV (HsExpr GhcPs) +mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns + | isRdrDataCon c + = do + let (fs, ps) = partitionEithers fbinds + case ps of + p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $ + PsErrOverloadedRecordDotInvalid + _ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) +mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns + | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $ + PsErrDotsInRecordUpdate + | otherwise = mkRdrRecordUpd overloaded_update exp fs anns + +mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> (Maybe (EpToken "{"), Maybe (EpToken "}")) + -> PV (HsExpr GhcPs) +mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do + -- We do not need to know if OverloadedRecordDot is in effect. We do + -- however need to know if OverloadedRecordUpdate (passed in + -- overloaded_on) is in effect because it affects the Left/Right nature + -- of the RecordUpd value we calculate. + let (fs, ps) = partitionEithers fbinds + fs' :: [LHsRecUpdField GhcPs GhcPs] + fs' = map (fmap mk_rec_upd_field) fs + case overloaded_on of + False | not $ null ps -> + -- A '.' was found in an update and OverloadedRecordUpdate isn't on. + addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled + False -> + -- This is just a regular record update. + return RecordUpd { + rupd_ext = anns + , rupd_expr = exp + , rupd_flds = + RegularRecUpdFields + { xRecUpdFields = noExtField + , recUpdFields = fs' } } + -- This is a RecordDotSyntax update. + True -> do + let qualifiedFields = + [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs' + , isQual . fieldOccRdrName $ lbl + ] + case qualifiedFields of + qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $ + PsErrOverloadedRecordUpdateNoQualifiedFields + _ -> return $ + RecordUpd + { rupd_ext = anns + , rupd_expr = exp + , rupd_flds = + OverloadedRecUpdFields + { xOLRecUpdFields = noExtField + , olRecUpdFields = toProjUpdates fbinds } } + where + toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs] + toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f }) + + -- Convert a top-level field update like {foo=2} or {bar} (punned) + -- to a projection update. + recFieldToProjUpdate :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs + recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) = + -- The idea here is to convert the label to a singleton [FastString]. + let f = occNameFS . rdrNameOcc $ rdr + fl = DotFieldOcc noAnn (L loc (FieldLabelString f)) + lf = locA loc + in mkRdrProjUpdate l (L lf (L (l2l loc) fl :| [])) (punnedVar f) pun anns + where + -- If punning, compute HsVar "f" otherwise just arg. This + -- has the effect that sentinel HsVar "pun-rhs" is replaced + -- by HsVar "f" here, before the update is written to a + -- setField expressions. + punnedVar :: FastString -> LHsExpr GhcPs + punnedVar f = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f + +mkRdrRecordCon + :: LocatedN RdrName -> HsRecordBinds GhcPs -> (Maybe (EpToken "{"), Maybe (EpToken "}")) -> HsExpr GhcPs +mkRdrRecordCon con flds anns + = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds } + +mk_rec_fields :: [LocatedA (HsRecField GhcPs arg)] -> Maybe SrcSpan -> HsRecFields GhcPs arg +mk_rec_fields fs Nothing = HsRecFields { rec_ext = noExtField, rec_flds = fs, rec_dotdot = Nothing } +mk_rec_fields fs (Just s) = HsRecFields { rec_ext = noExtField, rec_flds = fs + , rec_dotdot = Just (L (l2l s) (RecFieldsDotDot $ length fs)) } + +mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs +mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun) + = HsFieldBind noAnn (L loc (FieldOcc noExtField rdr)) arg pun + +mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation + -> InlinePragma +-- The (Maybe Activation) is because the user can omit +-- the activation spec (and usually does) +mkInlinePragma src (inl, match_info) mb_act + = InlinePragma { inl_src = src -- See Note [Pragma source text] in "GHC.Types.SourceText" + , inl_inline = inl + , inl_sat = Nothing + , inl_act = act + , inl_rule = match_info } + where + act = case mb_act of + Just act -> act + Nothing -> -- No phase specified + case inl of + NoInline _ -> NeverActive + Opaque _ -> NeverActive + _other -> AlwaysActive + +mkOpaquePragma :: SourceText -> InlinePragma +mkOpaquePragma src + = InlinePragma { inl_src = src + , inl_inline = Opaque src + , inl_sat = Nothing + -- By marking the OPAQUE pragma NeverActive we stop + -- (constructor) specialisation on OPAQUE things. + -- + -- See Note [OPAQUE pragma] + , inl_act = NeverActive + , inl_rule = FunLike + } + +checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs] + -> P (DataDefnCons (LConDecl GhcPs)) +checkNewOrData span name is_type_data = curry $ \ case + (NewType, [a]) -> pure $ NewTypeCon a + (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as) + (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as) + where + -- In a "type data" declaration, the constructors are in the type/class + -- namespace rather than the data constructor namespace. + -- See Note [Type data declarations] in GHC.Rename.Module. + handle_type_data + | is_type_data = map (fmap promote_constructor) + | otherwise = id + + promote_constructor (dc@ConDeclGADT { con_names = cons }) + = dc { con_names = fmap (fmap promote_name) cons } + promote_constructor (dc@ConDeclH98 { con_name = con }) + = dc { con_name = fmap promote_name con } + promote_constructor dc = dc + + promote_name name = fromMaybe name (promoteRdrName name) + +----------------------------------------------------------------------------- +-- utilities for foreign declarations + +-- construct a foreign import declaration +-- +mkImport :: Located CCallConv + -> Located Safety + -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) + -> (EpToken "import", TokDcolon) + -> P (EpToken "foreign" -> HsDecl GhcPs) +mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td) = + case unLoc cconv of + CCallConv -> returnSpec =<< mkCImport + CApiConv -> do + imp <- mkCImport + if isCWrapperImport imp + then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport + else returnSpec imp + StdCallConv -> returnSpec =<< mkCImport + PrimCallConv -> mkOtherImport + JavaScriptCallConv -> mkOtherImport + where + -- Parse a C-like entity string of the following form: + -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper" + -- If 'cid' is missing, the function name 'v' is used instead as symbol + -- name (cf section 8.5.1 in Haskell 2010 report). + mkCImport = do + let e = unpackFS entity + case parseCImport (reLoc cconv) (reLoc safety) (mkExtName (unLoc v)) e (L loc esrc) of + Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $ + PsErrMalformedEntityString + Just importSpec -> return importSpec + + isCWrapperImport (CImport _ _ _ _ CWrapper) = True + isCWrapperImport _ = False + + -- currently, all the other import conventions only support a symbol name in + -- the entity string. If it is missing, we use the function name instead. + mkOtherImport = returnSpec importSpec + where + entity' = if nullFS entity + then mkExtName (unLoc v) + else entity + funcTarget = CFunction (StaticTarget esrc entity' Nothing True) + importSpec = CImport (L (l2l loc) esrc) (reLoc cconv) (reLoc safety) Nothing funcTarget + + returnSpec spec = return $ \tforeign -> ForD noExtField $ ForeignImport + { fd_i_ext = (tforeign, timport, td) + , fd_name = v + , fd_sig_ty = ty + , fd_fi = spec + } + + + +-- the string "foo" is ambiguous: either a header or a C identifier. The +-- C identifier case comes first in the alternatives below, so we pick +-- that one. +parseCImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String + -> Located SourceText + -> Maybe (ForeignImport (GhcPass p)) +parseCImport cconv safety nm str sourceText = + listToMaybe $ map fst $ filter (null.snd) $ + readP_to_S parse str + where + parse = do + skipSpaces + r <- choice [ + string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), + string "wrapper" >> return (mk Nothing CWrapper), + do optional (token "static" >> skipSpaces) + ((mk Nothing <$> cimp nm) +++ + (do h <- munch1 hdr_char + skipSpaces + let src = mkFastString h + mk (Just (Header (SourceText src) src)) + <$> cimp nm)) + ] + skipSpaces + return r + + token str = do _ <- string str + toks <- look + case toks of + c : _ + | id_char c -> pfail + _ -> return () + + mk h n = CImport (reLoc sourceText) (reLoc cconv) (reLoc safety) h n + + hdr_char c = not (isSpace c) + -- header files are filenames, which can contain + -- pretty much any char (depending on the platform), + -- so just accept any non-space character + id_first_char c = isAlpha c || c == '_' + id_char c = isAlphaNum c || c == '_' + + cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) + +++ (do isFun <- case unLoc cconv of + CApiConv -> + option True + (do token "value" + skipSpaces + return False) + _ -> return True + cid' <- cid + return (CFunction (StaticTarget NoSourceText cid' + Nothing isFun))) + where + cid = return nm +++ + (do c <- satisfy id_first_char + cs <- many (satisfy id_char) + return (mkFastString (c:cs))) + + +-- construct a foreign export declaration +-- +mkExport :: Located CCallConv + -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) + -> ( EpToken "export", TokDcolon) + -> P (EpToken "foreign" -> HsDecl GhcPs) +mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty) (texport, td) + = return $ \tforeign -> ForD noExtField $ + ForeignExport { fd_e_ext = (tforeign, texport, td), fd_name = v, fd_sig_ty = ty + , fd_fe = CExport (L (l2l le) esrc) (L (l2l lc) (CExportStatic esrc entity' cconv)) } + where + entity' | nullFS entity = mkExtName (unLoc v) + | otherwise = entity + +-- Supplying the ext_name in a foreign decl is optional; if it +-- isn't there, the Haskell name is assumed. Note that no transformation +-- of the Haskell name is then performed, so if you foreign export (++), +-- it's external name will be "++". Too bad; it's important because we don't +-- want z-encoding (e.g. names with z's in them shouldn't be doubled) +-- +mkExtName :: RdrName -> CLabelString +mkExtName rdrNm = occNameFS (rdrNameOcc rdrNm) + +-------------------------------------------------------------------------------- +-- Help with module system imports/exports + +data ImpExpSubSpec = ImpExpAbs + | ImpExpAll (EpToken "..") + | ImpExpList [LocatedA ImpExpQcSpec] + | ImpExpAllWith [LocatedA ImpExpQcSpec] + +data ImpExpQcSpec = ImpExpQcName (Maybe ExplicitNamespaceKeyword) (LocatedN RdrName) + | ImpExpQcWildcard (EpToken "..") (EpToken ",") + +mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> (EpToken "(", EpToken ")") -> LocatedA ImpExpQcSpec + -> ImpExpSubSpec -> P (IE GhcPs) +mkModuleImpExp warning (top, tcp) (L l specname) subs = do + case subs of + ImpExpAbs + | isVarNameSpace (rdrNameSpace name) + -> return $ IEVar warning + (L l (ieNameFromSpec specname)) Nothing + | otherwise -> IEThingAbs warning . L l <$> nameT <*> pure noExportDoc + ImpExpAll tok -> IEThingAll (warning, (top, tok, tcp)) . L l <$> nameT <*> pure noExportDoc + ImpExpList xs -> + (\newName -> IEThingWith (warning, (top,NoEpTok,NoEpTok,tcp)) (L l newName) + NoIEWildcard (wrapped xs)) <$> nameT <*> pure noExportDoc + ImpExpAllWith xs -> + do allowed <- getBit PatternSynonymsBit + if allowed + then + let withs = map unLoc xs + pos = maybe NoIEWildcard IEWildcard + (findIndex isImpExpQcWildcard withs) + (td,tc) = case find isImpExpQcWildcard withs of + Just (ImpExpQcWildcard td tc) -> (td,tc) + _ -> (NoEpTok, NoEpTok) + ies :: [LocatedA (IEWrappedName GhcPs)] + ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs + in (\newName + -> IEThingWith (warning, (top,td,tc,tcp)) (L l newName) pos ies) + <$> nameT <*> pure noExportDoc + else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ + PsErrIllegalPatSynExport + where + noExportDoc :: Maybe (LHsDoc GhcPs) + noExportDoc = Nothing + + name = ieNameVal specname + nameT = + if isVarNameSpace (rdrNameSpace name) + then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrVarForTyCon name) + else return $ ieNameFromSpec specname + + ieNameVal (ImpExpQcName _ ln) = unLoc ln + ieNameVal ImpExpQcWildcard{} = panic "ieNameVal got wildcard" + + ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs + ieNameFromSpec (ImpExpQcName m_kw name) = case m_kw of + Nothing -> IEName noExtField name + Just (ExplicitTypeNamespace tok) -> IEType tok name + Just (ExplicitDataNamespace tok) -> IEData tok name + ieNameFromSpec ImpExpQcWildcard{} = panic "ieNameFromSpec got wildcard" + + wrapped = map (fmap ieNameFromSpec) + +mkPlainImpExp :: LocatedN RdrName -> ImpExpQcSpec +mkPlainImpExp name = ImpExpQcName Nothing name + +mkTypeImpExp :: EpToken "type" + -> LocatedN RdrName -- TcCls or Var name space + -> P ImpExpQcSpec +mkTypeImpExp tok name = do + let name' = fmap (`setRdrNameSpace` tcClsName) name + ns_kw = ExplicitTypeNamespace tok + requireExplicitNamespaces ns_kw + return (ImpExpQcName (Just ns_kw) name') + +mkDataImpExp :: EpToken "data" + -> LocatedN RdrName + -> P ImpExpQcSpec +mkDataImpExp tok name = do + let ns_kw = ExplicitDataNamespace tok + requireExplicitNamespaces ns_kw + return (ImpExpQcName (Just ns_kw) name) + +checkImportSpec :: LocatedLI [LIE GhcPs] -> P (LocatedLI [LIE GhcPs]) +checkImportSpec ie@(L _ specs) = + case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of + [] -> return ie + (l:_) -> importSpecError (locA l) + where + importSpecError l = + addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm + +-- In the correct order +mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ImpExpSubSpec +mkImpExpSubSpec [] = return (ImpExpList []) +mkImpExpSubSpec [L _ (ImpExpQcWildcard td _tc)] = + return (ImpExpAll td) +mkImpExpSubSpec xs = + if (any (isImpExpQcWildcard . unLoc) xs) + then return $ (ImpExpAllWith xs) + else return $ (ImpExpList xs) + +isImpExpQcWildcard :: ImpExpQcSpec -> Bool +isImpExpQcWildcard (ImpExpQcWildcard _ _) = True +isImpExpQcWildcard _ = False + +----------------------------------------------------------------------------- +-- Warnings and failures + +warnPrepositiveQualifiedModule :: SrcSpan -> P () +warnPrepositiveQualifiedModule span = + addPsMessage span PsWarnImportPreQualified + +failNotEnabledImportQualifiedPost :: SrcSpan -> P () +failNotEnabledImportQualifiedPost loc = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified + +failImportQualifiedTwice :: SrcSpan -> P () +failImportQualifiedTwice loc = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice + +failSpliceOrQuoteTwice :: EpAnnLevel -> P () +failSpliceOrQuoteTwice lvl = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrSpliceOrQuoteTwice + where + loc = case lvl of + EpAnnLevelSplice tok -> getEpTokenSrcSpan tok + EpAnnLevelQuote tok -> getEpTokenSrcSpan tok + +warnStarIsType :: SrcSpan -> P () +warnStarIsType span = addPsMessage span PsWarnStarIsType + +failOpFewArgs :: MonadP m => LocatedN RdrName -> m a +failOpFewArgs (L loc op) = + do { star_is_type <- getBit StarIsTypeBit + ; let is_star_type = if star_is_type then StarIsType else StarIsNotType + ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrOpFewArgs is_star_type op) } + +requireExplicitNamespaces :: MonadP m => ExplicitNamespaceKeyword -> m () +requireExplicitNamespaces kw = do + allowed <- getBit ExplicitNamespacesBit + unless allowed $ + addError $ mkPlainErrorMsgEnvelope loc $ PsErrIllegalExplicitNamespace kw + where + loc = case kw of + ExplicitTypeNamespace tok -> getEpTokenSrcSpan tok + ExplicitDataNamespace tok -> getEpTokenSrcSpan tok + +warnPatternNamespaceSpecifier :: MonadP m => SrcSpan -> m () +warnPatternNamespaceSpecifier l = do + explicit_namespaces <- getBit ExplicitNamespacesBit + addPsMessage l (PsWarnPatternNamespaceSpecifier explicit_namespaces) + +----------------------------------------------------------------------------- +-- Misc utils + +data PV_Context = + PV_Context + { pv_options :: ParserOpts + , pv_details :: ParseContext -- See Note [Parser-Validator Details] + } + +data PV_Accum = + PV_Accum + { pv_warnings :: Messages PsMessage + , pv_errors :: Messages PsMessage + , pv_header_comments :: Strict.Maybe [LEpaComment] + , pv_comment_q :: [LEpaComment] + } + +data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum + deriving (Foldable, Functor, Traversable) + +-- During parsing, we make use of several monadic effects: reporting parse errors, +-- accumulating warnings, adding API annotations, and checking for extensions. These +-- effects are captured by the 'MonadP' type class. +-- +-- Sometimes we need to postpone some of these effects to a later stage due to +-- ambiguities described in Note [Ambiguous syntactic categories]. +-- We could use two layers of the P monad, one for each stage: +-- +-- abParser :: forall x. DisambAB x => P (P x) +-- +-- The outer layer of P consumes the input and builds the inner layer, which +-- validates the input. But this type is not particularly helpful, as it obscures +-- the fact that the inner layer of P never consumes any input. +-- +-- For clarity, we introduce the notion of a parser-validator: a parser that does +-- not consume any input, but may fail or use other effects. Thus we have: +-- +-- abParser :: forall x. DisambAB x => P (PV x) +-- +newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a } + deriving (Functor) + +instance Applicative PV where + pure a = a `seq` PV (\_ acc -> PV_Ok acc a) + (<*>) = ap + +instance Monad PV where + m >>= f = PV $ \ctx acc -> + case unPV m ctx acc of + PV_Ok acc' a -> unPV (f a) ctx acc' + PV_Failed acc' -> PV_Failed acc' + +runPV :: PV a -> P a +runPV = runPV_details noParseContext + +askParseContext :: PV ParseContext +askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details + +runPV_details :: ParseContext -> PV a -> P a +runPV_details details m = + P $ \s -> + let + pv_ctx = PV_Context + { pv_options = options s + , pv_details = details } + pv_acc = PV_Accum + { pv_warnings = warnings s + , pv_errors = errors s + , pv_header_comments = header_comments s + , pv_comment_q = comment_q s } + mkPState acc' = + s { warnings = pv_warnings acc' + , errors = pv_errors acc' + , comment_q = pv_comment_q acc' } + in + case unPV m pv_ctx pv_acc of + PV_Ok acc' a -> POk (mkPState acc') a + PV_Failed acc' -> PFailed (mkPState acc') + +instance MonadP PV where + addError err = + PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} () + addWarning w = + PV $ \_ctx acc -> + -- No need to check for the warning flag to be set, GHC will correctly discard suppressed + -- diagnostics. + PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} () + addFatalError err = + addError err >> PV (const PV_Failed) + getParserOpts = PV $ \ctx acc -> PV_Ok acc $! pv_options ctx + allocateCommentsP ss = PV $ \_ s -> + if null (pv_comment_q s) then PV_Ok s emptyComments else -- fast path + let (comment_q', newAnns) = allocateComments ss (pv_comment_q s) in + PV_Ok s { + pv_comment_q = comment_q' + } (EpaComments newAnns) + allocatePriorCommentsP ss = PV $ \_ s -> + let (header_comments', comment_q', newAnns) + = allocatePriorComments ss (pv_comment_q s) (pv_header_comments s) in + PV_Ok s { + pv_header_comments = header_comments', + pv_comment_q = comment_q' + } (EpaComments newAnns) + allocateFinalCommentsP ss = PV $ \_ s -> + let (header_comments', comment_q', newAnns) + = allocateFinalComments ss (pv_comment_q s) (pv_header_comments s) in + PV_Ok s { + pv_header_comments = header_comments', + pv_comment_q = comment_q' + } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns) + +{- Note [Parser-Validator Details] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A PV computation is parameterized by some 'ParseContext' for diagnostic messages, which can be set +depending on validation context. We use this in checkPattern to fix #984. + +Consider this example, where the user has forgotten a 'do': + + f _ = do + x <- computation + case () of + _ -> + result <- computation + case () of () -> undefined + +GHC parses it as follows: + + f _ = do + x <- computation + (case () of + _ -> + result) <- computation + case () of () -> undefined + +Note that this fragment is parsed as a pattern: + + case () of + _ -> + result + +We attempt to detect such cases and add a hint to the diagnostic messages: + + T984.hs:6:9: + Parse error in pattern: case () of { _ -> result } + Possibly caused by a missing 'do'? + +The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed +out of the 'ParseContext', which are read by functions like 'patFail' when +constructing the 'PsParseErrorInPatDetails' data structure. When validating in a +context other than 'bindpat' (a pattern to the left of <-), we set the +details to 'noParseContext' and it has no effect on the diagnostic messages. + +-} + +-- | Hint about bang patterns, assuming @BangPatterns@ is off. +hintBangPat :: SrcSpan -> Pat GhcPs -> PV () +hintBangPat span e = do + bang_on <- getBit BangPatBit + unless bang_on $ + addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e + +mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs) + -> (EpaLocation, EpaLocation) + -> PV (LHsExpr GhcPs) + +-- Tuple +mkSumOrTupleExpr l@(EpAnn anc an csIn) boxity (Tuple es) anns = do + !cs <- getCommentsFor (locA l) + return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExplicitTuple anns (map toTupArg es) boxity) + where + toTupArg :: Either (EpAnn Bool) (LHsExpr GhcPs) -> HsTupArg GhcPs + toTupArg (Left ann) = missingTupArg ann + toTupArg (Right a) = Present noExtField a + +-- Sum +-- mkSumOrTupleExpr l Unboxed (Sum alt arity e) = +-- return $ L l (ExplicitSum noExtField alt arity e) +mkSumOrTupleExpr l@(EpAnn anc anIn csIn) Unboxed (Sum alt arity e barsp barsa) (o, c) = do + let an = AnnExplicitSum o barsp barsa c + !cs <- getCommentsFor (locA l) + return $ L (EpAnn anc anIn (csIn Semi.<> cs)) (ExplicitSum an alt arity e) +mkSumOrTupleExpr l Boxed a@Sum{} _ = + addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a + +mkSumOrTuplePat + :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> (EpaLocation, EpaLocation) + -> PV (LocatedA (PatBuilder GhcPs)) + +-- Tuple +mkSumOrTuplePat l boxity (Tuple ps) anns = do + ps' <- traverse toTupPat ps + return $ L l (PatBuilderPat (TuplePat anns ps' boxity)) + where + toTupPat :: Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs) + -- Ignore the element location so that the error message refers to the + -- entire tuple. See #19504 (and the discussion) for details. + toTupPat p = case p of + Left _ -> addFatalError $ + mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat + Right p' -> checkLPat p' + +-- Sum +mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do + p' <- checkLPat p + let an = EpAnnSumPat anns barsb barsa + return $ L l (PatBuilderPat (SumPat an p' alt arity)) +mkSumOrTuplePat l Boxed a@Sum{} _ = + addFatalError $ + mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a + +mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs +mkLHsOpTy prom x op y = + let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y + in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y) + +mkMultExpr :: EpToken "%" -> LHsExpr GhcPs -> TokRarrow -> HsMultAnnOf (LHsExpr GhcPs) GhcPs +mkMultExpr pct t@(L _ (HsOverLit _ (OverLit _ (HsIntegral (IL (SourceText (unpackFS -> "1")) _ 1))))) arr + -- See #18888 for the use of (SourceText "1") above + = HsLinearAnn (EpPct1 pct1 (EpArrow arr)) + where + -- The location of "%" combined with the location of "1". + pct1 :: EpToken "%1" + pct1 = epTokenWidenR pct (locA (getLoc t)) +mkMultExpr pct t arr = HsExplicitMult (pct, EpArrow arr) t + +mkMultAnn :: EpToken "%" -> LHsType GhcPs -> EpArrowOrColon -> HsMultAnn GhcPs +mkMultAnn pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) ep + -- See #18888 for the use of (SourceText "1") above + = HsLinearAnn (EpPct1 pct1 ep) + where + -- The location of "%" combined with the location of "1". + pct1 :: EpToken "%1" + pct1 = epTokenWidenR pct (locA (getLoc t)) +mkMultAnn pct t ep = HsExplicitMult (pct, ep) t + +mkMultField :: EpToken "%" -> LHsType GhcPs -> TokDcolon -> LHsType GhcPs -> HsConDeclField GhcPs +mkMultField pct mult col t = mkConDeclField (mkMultAnn pct mult (EpColon col)) t + +-- Precondition: the EpToken has EpaSpan, never EpaDelta. +epTokenWidenR :: EpToken tok -> SrcSpan -> EpToken tok' +epTokenWidenR NoEpTok _ = NoEpTok +epTokenWidenR (EpTok l) (UnhelpfulSpan _) = EpTok l +epTokenWidenR (EpTok (EpaSpan s1)) s2 = EpTok (EpaSpan (combineSrcSpans s1 s2)) +epTokenWidenR (EpTok EpaDelta{}) _ = + -- Never happens because the parser does not produce EpaDelta. + panic "epTokenWidenR: EpaDelta" + +----------------------------------------------------------------------------- +-- Token symbols + +starSym :: Bool -> FastString +starSym True = fsLit "★" +starSym False = fsLit "*" + +----------------------------------------- +-- Bits and pieces for RecordDotSyntax. + +mkRdrGetField :: LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs) + -> HsExpr GhcPs +mkRdrGetField arg field = + HsGetField { + gf_ext = NoExtField + , gf_expr = arg + , gf_field = field + } + +mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> AnnProjection -> HsExpr GhcPs +mkRdrProjection flds anns = + HsProjection { + proj_ext = anns + , proj_flds = fmap unLoc flds + } + +mkRdrProjUpdate :: SrcSpanAnnA -> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) + -> LHsExpr GhcPs -> Bool -> Maybe (EpToken "=") + -> LHsRecProj GhcPs (LHsExpr GhcPs) +mkRdrProjUpdate loc (L l flds) arg isPun anns = + L loc HsFieldBind { + hfbAnn = anns + , hfbLHS = L (noAnnSrcSpan l) (FieldLabelStrings flds) + , hfbRHS = arg + , hfbPun = isPun + } + +----------------------------------------------------------------------------- +-- Tuple and list punning + +punsAllowed :: P Bool +punsAllowed = getBit ListTuplePunsBit + +-- | Check whether @ListTuplePuns@ is enabled and return the first arg if it is, +-- the second arg otherwise. +punsIfElse :: a -> a -> P a +punsIfElse enabled disabled = do + allowed <- punsAllowed + pure (if allowed then enabled else disabled) + +-- | Emit an error of type 'PsErrInvalidPun' with a location from @start@ to +-- @end@ if the extension @ListTuplePuns@ is disabled. +-- +-- This is used in Parser.y to guard rules that require punning. +requireLTPuns :: PsErrPunDetails -> Located a -> Located b -> P () +requireLTPuns err start end = + unlessM punsAllowed $ do + addError (mkPlainErrorMsgEnvelope loc (PsErrInvalidPun err)) + where + loc = (combineSrcSpans (getLoc start) (getLoc end)) + +-- | Call a parser with a span and its comments given by a start and end token. +withCombinedComments :: + HasLoc l1 => + HasLoc l2 => + l1 -> + l2 -> + (SrcSpan -> P a) -> + P (LocatedA a) +withCombinedComments start end use = do + cs <- getCommentsFor fullSpan + a <- use fullSpan + pure (L (EpAnn (spanAsAnchor fullSpan) noAnn cs) a) + where + fullSpan = combineSrcSpans (getHasLoc start) (getHasLoc end) + +-- | Decide whether to parse tuple syntax @(Int, Double)@ in a type as a +-- type or data constructor, based on the extension @ListTuplePuns@. +-- The case with an explicit promotion quote, @'(Int, Double)@, is handled +-- by 'mkExplicitTupleTy'. +mkTupleSyntaxTy :: EpToken "(" + -> [LocatedA (HsType GhcPs)] + -> EpToken ")" + -> P (HsType GhcPs) +mkTupleSyntaxTy parOpen args parClose = + punsIfElse enabled disabled + where + enabled = + HsTupleTy annParen HsBoxedOrConstraintTuple args + disabled = + HsExplicitTupleTy annsKeyword NotPromoted args + + annParen = AnnParens parOpen parClose + annsKeyword = (NoEpTok, parOpen, parClose) + +-- | Decide whether to parse tuple con syntax @(,)@ in a type as a +-- type or data constructor, based on the extension @ListTuplePuns@. +-- The case with an explicit promotion quote, @'(,)@, is handled +-- by the rule @SIMPLEQUOTE sysdcon_nolist@ in @atype@. +mkTupleSyntaxTycon :: Boxity -> Int -> P RdrName +mkTupleSyntaxTycon boxity n = + punsIfElse + (getRdrName (tupleTyCon boxity n)) + (getRdrName (tupleDataCon boxity n)) + +-- | Decide whether to parse list tycon syntax @[]@ in a type as a type or data +-- constructor, based on the extension @ListTuplePuns@. +-- The case with an explicit promotion quote, @'[]@, is handled by +-- 'mkExplicitListTy'. +mkListSyntaxTy0 :: EpToken "[" + -> EpToken "]" + -> SrcSpan + -> P (HsType GhcPs) +mkListSyntaxTy0 brkOpen brkClose span = + punsIfElse enabled disabled + where + enabled = HsTyVar noAnn NotPromoted rn + + -- attach the comments only to the RdrName since it's the innermost AST node + rn = L (EpAnn fullLoc rdrNameAnn emptyComments) listTyCon_RDR + + disabled = + HsExplicitListTy annsKeyword NotPromoted [] + + rdrNameAnn = NameAnnOnly (NameSquare brkOpen brkClose) [] + annsKeyword = (NoEpTok, brkOpen, brkClose) + fullLoc = EpaSpan span + +-- | Decide whether to parse list type syntax @[Int]@ in a type as a +-- type or data constructor, based on the extension @ListTuplePuns@. +-- The case with an explicit promotion quote, @'[Int]@, is handled +-- by 'mkExplicitListTy'. +mkListSyntaxTy1 :: EpToken "[" + -> LocatedA (HsType GhcPs) + -> EpToken "]" + -> P (HsType GhcPs) +mkListSyntaxTy1 brkOpen t brkClose = + punsIfElse enabled disabled + where + enabled = HsListTy annParen t + + disabled = + HsExplicitListTy annsKeyword NotPromoted [t] + + annsKeyword = (NoEpTok, brkOpen, brkClose) + annParen = AnnParensSquare brkOpen brkClose + +parseError :: HsExpr GhcPs +parseError = HsHole HoleError diff --git a/GHC/Parser/PostProcess/Haddock.hs b/GHC/Parser/PostProcess/Haddock.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/PostProcess/Haddock.hs @@ -0,0 +1,1561 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{- | This module implements 'addHaddockToModule', which inserts Haddock + comments accumulated during parsing into the AST (#17544). + +We process Haddock comments in two phases: + +1. Parse the program (via the Happy parser in `Parser.y`), generating + an AST, and (quite separately) a list of all the Haddock comments + found in the file. More precisely, the Haddock comments are + accumulated in the `hdk_comments` field of the `PState`, the parser + state (see Lexer.x): + + data PState = PState { ... + , hdk_comments :: [PsLocated HdkComment] } + + Each of these Haddock comments has a `PsSpan`, which gives the `BufPos` of + the beginning and end of the Haddock comment. + +2. Walk over the AST, attaching the Haddock comments to the correct + parts of the tree. This step is called `addHaddockToModule`, and is + implemented in this module. + + See Note [Adding Haddock comments to the syntax tree]. + +This approach codifies an important principle: + + The presence or absence of a Haddock comment should never change the parsing + of a program. + +Alternative approaches that did not work properly: + +1. Using 'RealSrcLoc' instead of 'BufPos'. This led to failures in presence + of {-# LANGUAGE CPP #-} and other sources of line pragmas. See documentation + on 'BufPos' (in GHC.Types.SrcLoc) for the details. + +2. In earlier versions of GHC, the Haddock comments were incorporated into the + Parser.y grammar. The parser constructed the AST and attached comments to it in + a single pass. See Note [Old solution: Haddock in the grammar] for the details. +-} +module GHC.Parser.PostProcess.Haddock (addHaddockToModule) where + +import GHC.Prelude hiding (head, init, last, mod, tail) + +import GHC.Hs + +import GHC.Types.SrcLoc + +import Data.Semigroup +import Data.Foldable +import Data.Traversable +import qualified Data.List.NonEmpty as NE +import Control.Applicative +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader +import Data.Functor.Identity + +import {-# SOURCE #-} GHC.Parser (parseIdentifier) +import GHC.Parser.Lexer +import GHC.Parser.HaddockLex +import GHC.Parser.Errors.Types +import GHC.Utils.Misc (mergeListsBy, filterOut, (<&&>)) +import qualified GHC.Data.Strict as Strict + +{- Note [Adding Haddock comments to the syntax tree] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'addHaddock' traverses the AST in concrete syntax order, building a computation +(represented by HdkA) that reconstructs the AST but with Haddock comments +inserted in appropriate positions: + + addHaddock :: HasHaddock a => a -> HdkA a + +Consider this code example: + + f :: Int -- ^ comment on argument + -> Bool -- ^ comment on result + +In the AST, the "Int" part of this snippet is represented like this +(pseudo-code): + + L (BufSpan 6 8) (HsTyVar "Int") :: LHsType GhcPs + +And the comments are represented like this (pseudo-code): + + L (BufSpan 11 35) (HdkCommentPrev "comment on argument") + L (BufSpan 46 69) (HdkCommentPrev "comment on result") + +So when we are traversing the AST and 'addHaddock' is applied to HsTyVar "Int", +how does it know to associate it with "comment on argument" but not with +"comment on result"? + +The trick is to look in the space between syntactic elements. In the example above, +the location range in which we search for HdkCommentPrev is as follows: + + f :: Int████████████████████████ + ████Bool -- ^ comment on result + +We search for comments after HsTyVar "Int" and until the next syntactic +element, in this case HsTyVar "Bool". + +Ignoring the "->" allows us to accommodate alternative coding styles: + + f :: Int -> -- ^ comment on argument + Bool -- ^ comment on result + +Sometimes we also need to take indentation information into account. +Compare the following examples: + + class C a where + f :: a -> Int + -- ^ comment on f + + class C a where + f :: a -> Int + -- ^ comment on C + +Notice how "comment on f" and "comment on C" differ only by indentation level. + +Therefore, in order to know the location range in which the comments are applicable +to a syntactic elements, we need three nuggets of information: + 1. lower bound on the BufPos of a comment + 2. upper bound on the BufPos of a comment + 3. minimum indentation level of a comment + +This information is represented by the 'LocRange' type. + +In order to propagate this information, we have the 'HdkA' applicative. +'HdkA' is defined as follows: + + data HdkA a = HdkA (Maybe BufSpan) (HdkM a) + +The first field contains a 'BufSpan', which represents the location +span taken by a syntactic element: + + addHaddock (L bufSpan ...) = HdkA (Just bufSpan) ... + +The second field, 'HdkM', is a stateful computation that looks up Haddock +comments in the specified location range: + + HdkM a ≈ + LocRange -- The allowed location range + -> [PsLocated HdkComment] -- Unallocated comments + -> (a, -- AST with comments inserted into it + [PsLocated HdkComment]) -- Leftover comments + +The 'Applicative' instance for 'HdkA' is defined in such a way that the +location range of every computation is defined by its neighbours: + + addHaddock aaa <*> addHaddock bbb <*> addHaddock ccc + +Here, the 'LocRange' passed to the 'HdkM' computation of addHaddock bbb +is determined by the BufSpan recorded in addHaddock aaa and addHaddock ccc. + +This is why it's important to traverse the AST in the order of the concrete +syntax. In the example above we assume that aaa, bbb, ccc are ordered by location: + + * getBufSpan (getLoc aaa) < getBufSpan (getLoc bbb) + * getBufSpan (getLoc bbb) < getBufSpan (getLoc ccc) + +Violation of this assumption would lead to bugs, and care must be taken to +traverse the AST correctly. For example, when dealing with class declarations, +we have to use 'flattenBindsAndSigs' to traverse it in the correct order. +-} + +-- | Add Haddock documentation accumulated in the parser state +-- to a parsed HsModule. +-- +-- Reports badly positioned comments when -Winvalid-haddock is enabled. +addHaddockToModule :: Located (HsModule GhcPs) -> P (Located (HsModule GhcPs)) +addHaddockToModule lmod = do + pState <- getPState + let all_comments = toList (hdk_comments pState) + initial_hdk_st = HdkSt all_comments [] + (lmod', final_hdk_st) = runHdkA (addHaddock lmod) initial_hdk_st + hdk_warnings = collectHdkWarnings final_hdk_st + -- lmod': module with Haddock comments inserted into the AST + -- hdk_warnings: warnings accumulated during AST/comment processing + mapM_ reportHdkWarning hdk_warnings + return lmod' + +reportHdkWarning :: HdkWarn -> P () +reportHdkWarning (HdkWarnInvalidComment (L l _)) = + addPsMessage (mkSrcSpanPs l) PsWarnHaddockInvalidPos +reportHdkWarning (HdkWarnExtraComment (L l _)) = + addPsMessage l PsWarnHaddockIgnoreMulti + +collectHdkWarnings :: HdkSt -> [HdkWarn] +collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } = + map HdkWarnInvalidComment hdk_st_pending -- leftover Haddock comments not inserted into the AST + ++ hdk_st_warnings + +{- ********************************************************************* +* * +* addHaddock: a family of functions that processes the AST * +* in concrete syntax order, adding documentation comments to it * +* * +********************************************************************* -} + +-- HasHaddock is a convenience class for overloading the addHaddock operation. +-- Alternatively, we could define a family of monomorphic functions: +-- +-- addHaddockSomeTypeX :: SomeTypeX -> HdkA SomeTypeX +-- addHaddockAnotherTypeY :: AnotherTypeY -> HdkA AnotherTypeY +-- addHaddockOneMoreTypeZ :: OneMoreTypeZ -> HdkA OneMoreTypeZ +-- +-- But having a single name for all of them is just easier to read, and makes it clear +-- that they all are of the form t -> HdkA t for some t. +-- +-- If you need to handle a more complicated scenario that doesn't fit this pattern, +-- it's always possible to define separate functions outside of this class. +-- +-- See Note [Adding Haddock comments to the syntax tree]. +class HasHaddock a where + addHaddock :: a -> HdkA a + +instance HasHaddock a => HasHaddock [a] where + addHaddock = traverse addHaddock + +-- -- | Module header comment +-- module M ( +-- -- * Export list comment +-- Item1, +-- Item2, +-- -- * Export list comment +-- item3, +-- item4 +-- ) where +-- +instance HasHaddock (Located (HsModule GhcPs)) where + addHaddock (L l_mod mod) = do + let mod_anns = anns (hsmodAnn (hsmodExt mod)) + + -- Step 1, get the module header documentation comment: + -- + -- -- | Module header comment + -- module M where + -- + -- Only do this when the module header exists. + headerDocs <- + case hsmodName mod of + Nothing -> pure Nothing + Just (L l_name _) -> do + let modspan = + getEpTokenBufSpan (am_mod mod_anns) <> + getEpTokenBufSpan (am_sig mod_anns) <> + getBufSpan (locA l_name) + HdkA modspan $ do + docs <- + inLocRange (locRangeTo (fmap bufSpanStart modspan)) $ + takeHdkComments mkDocNext + dc <- selectDocString docs + pure $ lexLHsDocString <$> dc + + -- Step 2, process documentation comments in the export list: + -- + -- module M ( + -- -- * Export list comment + -- Item1, + -- Item2, + -- -- * Export list comment + -- item3, + -- item4 + -- ) where + -- + -- Only do this when the export list exists. + hsmodExports' <- traverse @Maybe addHaddock (hsmodExports mod) + + -- Step 3, register the import section to reject invalid comments: + -- + -- import Data.Maybe + -- -- | rejected comment (cannot appear here) + -- import Data.Bool + -- + traverse_ registerHdkA (hsmodImports mod) + + -- Step 4, process declarations: + -- + -- module M where + -- -- | Comment on D + -- data D = MkD -- ^ Comment on MkD + -- data C = MkC -- ^ Comment on MkC + -- -- ^ Comment on C + -- + let layout = hsmodLayout (hsmodExt mod) + hsmodDecls' <- addHaddockInterleaveItems layout (mkDocHsDecl layout) (hsmodDecls mod) + + pure $ L l_mod $ + mod { hsmodExports = hsmodExports' + , hsmodDecls = hsmodDecls' + , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = headerDocs } } + +lexHsDocString :: HsDocString -> HsDoc GhcPs +lexHsDocString = lexHsDoc parseIdentifier + +lexLHsDocString :: Located HsDocString -> LHsDoc GhcPs +lexLHsDocString = fmap lexHsDocString + +-- | Only for module exports, not module imports. +-- +-- module M (a, b, c) where -- use on this [LIE GhcPs] +-- import I (a, b, c) -- do not use here! +-- +-- Imports cannot have documentation comments anyway. +instance HasHaddock (LocatedLI [LocatedA (IE GhcPs)]) where + addHaddock (L l_exports exports) = + extendHdkA (locA l_exports) $ do + exports' <- addHaddockInterleaveItems EpNoLayout mkDocIE exports + registerLocHdkA (srcLocSpan (srcSpanEnd (locA l_exports))) -- Do not consume comments after the closing parenthesis + pure $ L l_exports exports' + +-- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'. +instance HasHaddock (LocatedA (IE GhcPs)) where + addHaddock (L l_export ie ) = + extendHdkA (locA l_export) $ liftHdkA $ do + docs <- inLocRange (locRangeFrom (getBufPos (srcSpanEnd (locA l_export)))) $ + takeHdkComments mkDocPrev + mb_doc <- selectDocString docs + let mb_ldoc = lexLHsDocString <$> mb_doc + let ie' = case ie of + IEVar ext nm _ -> IEVar ext nm mb_ldoc + IEThingAbs ext nm _ -> IEThingAbs ext nm mb_ldoc + IEThingAll ext nm _ -> IEThingAll ext nm mb_ldoc + IEThingWith ext nm wild subs _ -> IEThingWith ext nm wild subs mb_ldoc + x -> x + pure $ L l_export ie' + +{- Add Haddock items to a list of non-Haddock items. +Used to process export lists (with mkDocIE) and declarations (with mkDocHsDecl). + +For example: + + module M where + -- | Comment on D + data D = MkD -- ^ Comment on MkD + data C = MkC -- ^ Comment on MkC + -- ^ Comment on C + +In this case, we should produce four HsDecl items (pseudo-code): + + 1. DocD (DocCommentNext "Comment on D") + 2. TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... (Just "Comment on MkD")]) + 3. TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... (Just "Comment on MkC")]) + 4. DocD (DocCommentPrev "Comment on C") + +The inputs to addHaddockInterleaveItems are: + + * layout :: EpLayout + + In the example above, note that the indentation level inside the module is + 2 spaces. It would be represented as layout = EpVirtualBraces 2. + + It is used to delimit the search space for comments when processing + declarations. Here, we restrict indentation levels to >=(2+1), so that when + we look up comment on MkC, we get "Comment on MkC" but not "Comment on C". + + * get_doc_item :: PsLocated HdkComment -> Maybe a + + This is the function used to look up documentation comments. + In the above example, get_doc_item = mkDocHsDecl layout, + and it will produce the following parts of the output: + + DocD (DocCommentNext "Comment on D") + DocD (DocCommentPrev "Comment on C") + + * The list of items. These are the declarations that will be annotated with + documentation comments. + + Before processing: + TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... Nothing]) + TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... Nothing]) + + After processing: + TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... (Just "Comment on MkD")]) + TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... (Just "Comment on MkC")]) +-} +addHaddockInterleaveItems + :: forall a. + HasHaddock a + => EpLayout + -> (PsLocated HdkComment -> Maybe a) -- Get a documentation item + -> [a] -- Unprocessed (non-documentation) items + -> HdkA [a] -- Documentation items & processed non-documentation items +addHaddockInterleaveItems layout get_doc_item = go + where + go :: [a] -> HdkA [a] + go [] = liftHdkA (takeHdkComments get_doc_item) + go (item : items) = do + docItems <- liftHdkA (takeHdkComments get_doc_item) + item' <- with_layout (addHaddock item) + other_items <- go items + pure $ docItems ++ item':other_items + + with_layout :: HdkA a -> HdkA a + with_layout = case layout of + EpNoLayout -> id + EpExplicitBraces{} -> id + EpVirtualBraces n -> + let loc_range = mempty { loc_range_col = ColumnFrom (n+1) } + in hoistHdkA (inLocRange loc_range) + +instance HasHaddock (LocatedA (HsDecl GhcPs)) where + addHaddock ldecl = + extendHdkA (getLocA ldecl) $ + traverse @LocatedA addHaddock ldecl + +-- Process documentation comments *inside* a declaration, for example: +-- +-- data T = MkT -- ^ Comment on MkT (inside DataDecl) +-- f, g +-- :: Int -- ^ Comment on Int (inside TypeSig) +-- -> Bool -- ^ Comment on Bool (inside TypeSig) +-- +-- Comments that relate to the entire declaration are processed elsewhere: +-- +-- -- | Comment on T (not processed in this instance) +-- data T = MkT +-- +-- -- | Comment on f, g (not processed in this instance) +-- f, g :: Int -> Bool +-- f = ... +-- g = ... +-- +-- Such comments are inserted into the syntax tree as DocD declarations +-- by addHaddockInterleaveItems, and then associated with other declarations +-- in GHC.HsToCore.Docs (see DeclDocMap). +-- +-- In this instance, we only process comments that relate to parts of the +-- declaration, not to the declaration itself. +instance HasHaddock (HsDecl GhcPs) where + + -- Type signatures: + -- + -- f, g + -- :: Int -- ^ Comment on Int + -- -> Bool -- ^ Comment on Bool + -- + addHaddock (SigD _ (TypeSig x names t)) = do + traverse_ registerHdkA names + t' <- addHaddock t + pure (SigD noExtField (TypeSig x names t')) + + -- Pattern synonym type signatures: + -- + -- pattern MyPat + -- :: Bool -- ^ Comment on Bool + -- -> Maybe Bool -- ^ Comment on Maybe Bool + -- + addHaddock (SigD _ (PatSynSig x names t)) = do + traverse_ registerHdkA names + t' <- addHaddock t + pure (SigD noExtField (PatSynSig x names t')) + + -- Class method signatures and default signatures: + -- + -- class C x where + -- method_of_c + -- :: Maybe x -- ^ Comment on Maybe x + -- -> IO () -- ^ Comment on IO () + -- default method_of_c + -- :: Eq x + -- => Maybe x -- ^ Comment on Maybe x + -- -> IO () -- ^ Comment on IO () + -- + addHaddock (SigD _ (ClassOpSig x is_dflt names t)) = do + traverse_ registerHdkA names + t' <- addHaddock t + pure (SigD noExtField (ClassOpSig x is_dflt names t')) + + -- Data/newtype declarations: + -- + -- data T = MkT -- ^ Comment on MkT + -- A -- ^ Comment on A + -- B -- ^ Comment on B + -- + -- data G where + -- -- | Comment on MkG + -- MkG :: A -- ^ Comment on A + -- -> B -- ^ Comment on B + -- -> G + -- + -- newtype N = MkN { getN :: Natural } -- ^ Comment on N + -- deriving newtype (Eq {- ^ Comment on Eq N -}) + -- deriving newtype (Ord {- ^ Comment on Ord N -}) + -- + addHaddock (TyClD x decl) + | DataDecl { tcdDExt, tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl + = do + registerHdkA tcdLName + defn' <- addHaddock defn + pure $ + TyClD x (DataDecl { + tcdDExt, + tcdLName, tcdTyVars, tcdFixity, + tcdDataDefn = defn' }) + + -- Class declarations: + -- + -- class C a where + -- -- | Comment on the first method + -- first_method :: a -> Bool + -- second_method :: a -> String + -- -- ^ Comment on the second method + -- + addHaddock (TyClD _ decl) + | ClassDecl { tcdCExt = (x, layout, NoAnnSortKey), + tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs, + tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl + = do + registerHdkA tcdLName + registerEpTokenHdkA (acd_where x) + where_cls' <- + addHaddockInterleaveItems layout (mkDocHsDecl layout) $ + flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], []) + pure $ + let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls' + decl' = ClassDecl { tcdCExt = (x, layout, NoAnnSortKey) + , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs + , tcdSigs = tcdSigs' + , tcdMeths = tcdMeths' + , tcdATs = tcdATs' + , tcdATDefs = tcdATDefs' + , tcdDocs } + in TyClD noExtField decl' + + -- Data family instances: + -- + -- data instance D Bool where ... (same as data/newtype declarations) + -- data instance D Bool = ... (same as data/newtype declarations) + -- + addHaddock (InstD _ decl) + | DataFamInstD { dfid_ext, dfid_inst } <- decl + , DataFamInstDecl { dfid_eqn } <- dfid_inst + = do + dfid_eqn' <- case dfid_eqn of + FamEqn { feqn_ext, feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs } + -> do + registerHdkA feqn_tycon + feqn_rhs' <- addHaddock feqn_rhs + pure $ FamEqn { + feqn_ext, + feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, + feqn_rhs = feqn_rhs' } + pure $ InstD noExtField (DataFamInstD { + dfid_ext, + dfid_inst = DataFamInstDecl { dfid_eqn = dfid_eqn' } }) + + -- Type synonyms: + -- + -- type T = Int -- ^ Comment on Int + -- + addHaddock (TyClD _ decl) + | SynDecl { tcdSExt, tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl + = do + registerHdkA tcdLName + tcdRhs' <- addHaddock tcdRhs + pure $ + TyClD noExtField (SynDecl { + tcdSExt, + tcdLName, tcdTyVars, tcdFixity, + tcdRhs = tcdRhs' }) + + -- Foreign imports: + -- + -- foreign import ccall unsafe + -- o :: Float -- ^ The input float + -- -> IO Float -- ^ The output float + -- + addHaddock (ForD _ decl) = do + registerHdkA (fd_name decl) + fd_sig_ty' <- addHaddock (fd_sig_ty decl) + pure $ ForD noExtField (decl{ fd_sig_ty = fd_sig_ty' }) + + -- Other declarations + addHaddock d = pure d + +-- The right-hand side of a data/newtype declaration or data family instance. +instance HasHaddock (HsDataDefn GhcPs) where + addHaddock defn@HsDataDefn{} = do + + -- Register the kind signature: + -- data D :: Type -> Type where ... + -- data instance D Bool :: Type where ... + traverse_ @Maybe registerHdkA (dd_kindSig defn) + registerEpTokenHdkA (andd_where (dd_ext defn)) + + -- Process the data constructors: + -- + -- data T + -- = MkT1 Int Bool -- ^ Comment on MkT1 + -- | MkT2 Char Int -- ^ Comment on MkT2 + -- + dd_cons' <- traverse addHaddock (dd_cons defn) + + -- Process the deriving clauses: + -- + -- newtype N = MkN Natural + -- deriving (Eq {- ^ Comment on Eq N -}) + -- deriving (Ord {- ^ Comment on Ord N -}) + -- + dd_derivs' <- addHaddock (dd_derivs defn) + + pure $ defn { dd_cons = dd_cons', + dd_derivs = dd_derivs' } + +-- Process the deriving clauses of a data/newtype declaration. +-- Not used for standalone deriving. +instance HasHaddock (Located [LocatedAn NoEpAnns (HsDerivingClause GhcPs)]) where + addHaddock lderivs = + extendHdkA (getLoc lderivs) $ + traverse @Located addHaddock lderivs + +-- Process a single deriving clause of a data/newtype declaration: +-- +-- newtype N = MkN Natural +-- deriving newtype (Eq {- ^ Comment on Eq N -}) +-- deriving (Ord {- ^ Comment on Ord N -}) via Down N +-- +-- Not used for standalone deriving. +instance HasHaddock (LocatedAn NoEpAnns (HsDerivingClause GhcPs)) where + addHaddock lderiv = + extendHdkA (getLocA lderiv) $ + for @(LocatedAn NoEpAnns) lderiv $ \deriv -> + case deriv of + HsDerivingClause { deriv_clause_ext, deriv_clause_strategy, deriv_clause_tys } -> do + let + -- 'stock', 'anyclass', and 'newtype' strategies come + -- before the clause types. + -- + -- 'via' comes after. + -- + -- See tests/.../T11768.hs + (register_strategy_before, register_strategy_after) = + case deriv_clause_strategy of + Nothing -> (pure (), pure ()) + Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA (locA l)) + Just (L l _) -> (registerLocHdkA (locA l), pure ()) + register_strategy_before + deriv_clause_tys' <- addHaddock deriv_clause_tys + register_strategy_after + pure HsDerivingClause + { deriv_clause_ext, + deriv_clause_strategy, + deriv_clause_tys = deriv_clause_tys' } + +-- Process the types in a single deriving clause, which may come in one of the +-- following forms: +-- +-- 1. A singular type constructor: +-- deriving Eq -- ^ Comment on Eq +-- +-- 2. A list of comma-separated types surrounded by enclosing parentheses: +-- deriving ( Eq -- ^ Comment on Eq +-- , C a -- ^ Comment on C a +-- ) +instance HasHaddock (LocatedC (DerivClauseTys GhcPs)) where + addHaddock (L l_dct dct) = + extendHdkA (locA l_dct) $ + case dct of + DctSingle x ty -> do + ty' <- addHaddock ty + pure $ L l_dct $ DctSingle x ty' + DctMulti x tys -> do + tys' <- addHaddock tys + pure $ L l_dct $ DctMulti x tys' + +-- Process a single data constructor declaration, which may come in one of the +-- following forms: +-- +-- 1. H98-syntax PrefixCon: +-- data T = +-- MkT -- ^ Comment on MkT +-- Int -- ^ Comment on Int +-- Bool -- ^ Comment on Bool +-- +-- 2. H98-syntax InfixCon: +-- data T = +-- Int -- ^ Comment on Int +-- :+ -- ^ Comment on (:+) +-- Bool -- ^ Comment on Bool +-- +-- 3. H98-syntax RecCon: +-- data T = +-- MkT { int_field :: Int, -- ^ Comment on int_field +-- bool_field :: Bool } -- ^ Comment on bool_field +-- +-- 4. GADT-syntax PrefixCon: +-- data T where +-- -- | Comment on MkT +-- MkT :: Int -- ^ Comment on Int +-- -> Bool -- ^ Comment on Bool +-- -> T +-- +-- 5. GADT-syntax RecCon: +-- data T where +-- -- | Comment on MkT +-- MkT :: { int_field :: Int, -- ^ Comment on int_field +-- bool_field :: Bool } -- ^ Comment on bool_field +-- -> T +-- +instance HasHaddock (LocatedA (ConDecl GhcPs)) where + addHaddock (L l_con_decl con_decl) = + extendHdkA (locA l_con_decl) $ + case con_decl of + ConDeclGADT { con_g_ext, con_names, con_outer_bndrs, con_inner_bndrs + , con_mb_cxt, con_g_args, con_res_ty } -> do + con_doc' <- getConDoc (getLocA (NE.head con_names)) + con_g_args' <- + case con_g_args of + PrefixConGADT x ts -> PrefixConGADT x <$> addHaddock ts + RecConGADT arr (L l_rec flds) -> do + flds' <- traverse addHaddock flds + pure $ RecConGADT arr (L l_rec flds') + con_res_ty' <- addHaddock con_res_ty + pure $ L l_con_decl $ + ConDeclGADT { con_g_ext, con_names, + con_outer_bndrs, con_inner_bndrs, con_mb_cxt, + con_doc = lexLHsDocString <$> con_doc', + con_g_args = con_g_args', + con_res_ty = con_res_ty' } + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> + let + -- See Note [Leading and trailing comments on H98 constructors] + getTrailingLeading :: HdkM (LocatedA (ConDecl GhcPs)) + getTrailingLeading = do + con_doc' <- getPrevNextDoc (locA l_con_decl) + return $ L l_con_decl $ + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args + , con_doc = lexLHsDocString <$> con_doc' } + + -- See Note [Leading and trailing comments on H98 constructors] + getMixed :: HdkA (LocatedA (ConDecl GhcPs)) + getMixed = + case con_args of + PrefixCon ts -> do + con_doc' <- getConDoc (getLocA con_name) + ts' <- traverse addHaddock ts + pure $ L l_con_decl $ + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, + con_doc = lexLHsDocString <$> con_doc', + con_args = PrefixCon ts' } + InfixCon t1 t2 -> do + t1' <- addHaddock t1 + con_doc' <- getConDoc (getLocA con_name) + t2' <- addHaddock t2 + pure $ L l_con_decl $ + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, + con_doc = lexLHsDocString <$> con_doc', + con_args = InfixCon t1' t2' } + RecCon (L l_rec flds) -> do + con_doc' <- getConDoc (getLocA con_name) + flds' <- traverse addHaddock flds + pure $ L l_con_decl $ + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, + con_doc = lexLHsDocString <$> con_doc', + con_args = RecCon (L l_rec flds') } + in + hoistHdkA + (\m -> do { a <- onlyTrailingOrLeading (locA l_con_decl) + ; if a then getTrailingLeading else m }) + getMixed + +-- See Note [Leading and trailing comments on H98 constructors] +onlyTrailingOrLeading :: SrcSpan -> HdkM Bool +onlyTrailingOrLeading l = peekHdkM $ do + leading <- + inLocRange (locRangeTo (getBufPos (srcSpanStart l))) $ + takeHdkComments mkDocNext + inner <- + inLocRange (locRangeIn (getBufSpan l)) $ + takeHdkComments (\x -> mkDocNext x <|> mkDocPrev x) + trailing <- + inLocRange (locRangeFrom (getBufPos (srcSpanEnd l))) $ + takeHdkComments mkDocPrev + return $ case (leading, inner, trailing) of + (_:_, [], []) -> True -- leading comment only + ([], [], _:_) -> True -- trailing comment only + _ -> False + +-- Get the documentation comment associated with the data constructor in a +-- data/newtype declaration. +getConDoc + :: SrcSpan -- Location of the data constructor + -> HdkA (Maybe (Located HsDocString)) +getConDoc l = extendHdkA l $ liftHdkA $ getPrevNextDoc l + +instance HasHaddock (LocatedA (HsConDeclRecField GhcPs)) where + addHaddock (L l_fld (HsConDeclRecField ext nms cfs)) = + extendHdkA (locA l_fld) $ liftHdkA $ do + cdf_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld) + return $ L l_fld (HsConDeclRecField ext nms (cfs { cdf_doc })) + +{- Note [Leading and trailing comments on H98 constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The trailing comment after a constructor declaration is associated with the +constructor itself when it is the only comment: + + data T = MkT A B -- ^ Comment on MkT + data T = MkT { x :: A } -- ^ Comment on MkT + data T = A `MkT` B -- ^ Comment on MkT + +When there are other comments, the trailing comment applies to the last field: + + data T = MkT -- ^ Comment on MkT + A -- ^ Comment on A + B -- ^ Comment on B + + data T = + MkT { a :: A -- ^ Comment on a + , b :: B -- ^ Comment on b + , c :: C } -- ^ Comment on c + + data T = + A -- ^ Comment on A + `MkT` -- ^ Comment on MkT + B -- ^ Comment on B + +When it comes to the leading comment, there is no such ambiguity in /prefix/ +constructor declarations (plain or record syntax): + + data T = + -- | Comment on MkT + MkT A B + + data T = + -- | Comment on MkT + MkT + -- | Comment on A + A + -- | Comment on B + B + + data T = + -- | Comment on MkT + MkT { x :: A } + + data T = + -- | Comment on MkT + MkT { + -- | Comment on a + a :: A, + -- | Comment on b + b :: B, + -- | Comment on c + c :: C + } + +However, in /infix/ constructor declarations the leading comment is associated +with the constructor itself if it is the only comment, and with the first +field if there are other comments: + + data T = + -- | Comment on MkT + A `MkT` B + + data T = + -- | Comment on A + A + -- | Comment on MkT + `MkT` + -- | Comment on B + B + +This makes the leading and trailing comments context-sensitive. Example: + data T = + -- | comment 1 + MkT Int Bool -- ^ comment 2 + + Here, "comment 2" applies to the Bool field. + But if we removed "comment 1", then "comment 2" would be apply to the data + constructor rather than its field. + +All of this applies to H98-style data declarations only. +GADTSyntax data constructors don't have any special treatment for the trailing comment. + +We implement this in two steps: + + 1. Gather information about available comments using `onlyTrailingOrLeading`. + It inspects available comments but does not consume them, and returns a + boolean that tells us what algorithm we should use + True <=> expect a single leading/trailing comment + False <=> expect inner comments or more than one comment + + 2. Collect the comments using the algorithm determined in the previous step + + a) `getTrailingLeading`: + a single leading/trailing comment is applied to the entire + constructor declaration as a whole; see the `con_doc` field + b) `getMixed`: + comments apply to individual parts of a constructor declaration, + including its field types +-} + +instance HasHaddock (HsConDeclField GhcPs) where + addHaddock cfs = do + cdf_type <- addHaddock (cdf_type cfs) + return $ case cdf_type of + L _ (HsDocTy _ ty doc) -> cfs { cdf_type = ty, cdf_doc = Just doc } + _ -> cfs { cdf_type } + +instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where + addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t + +instance HasHaddock (LocatedA (HsSigType GhcPs)) where + addHaddock (L l (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) = + extendHdkA (locA l) $ do + case outer_bndrs of + HsOuterImplicit{} -> pure () + HsOuterExplicit{hso_bndrs = bndrs} -> + registerLocHdkA (getLHsTyVarBndrsLoc bndrs) + body' <- addHaddock body + pure $ L l $ HsSig noExtField outer_bndrs body' + +-- Process a type, adding documentation comments to function arguments +-- and the result. Many formatting styles are supported. +-- +-- my_function :: +-- forall a. +-- Eq a => +-- Maybe a -> -- ^ Comment on Maybe a (function argument) +-- Bool -> -- ^ Comment on Bool (function argument) +-- String -- ^ Comment on String (the result) +-- +-- my_function +-- :: forall a. Eq a +-- => Maybe a -- ^ Comment on Maybe a (function argument) +-- -> Bool -- ^ Comment on Bool (function argument) +-- -> String -- ^ Comment on String (the result) +-- +-- my_function :: +-- forall a. Eq a => +-- -- | Comment on Maybe a (function argument) +-- Maybe a -> +-- -- | Comment on Bool (function argument) +-- Bool -> +-- -- | Comment on String (the result) +-- String +-- +-- This is achieved by simply ignoring (not registering the location of) the +-- function arrow (->). +instance HasHaddock (LocatedA (HsType GhcPs)) where + addHaddock (L l t) = + extendHdkA (locA l) $ + case t of + + -- forall a b c. t + HsForAllTy x tele body -> do + registerLocHdkA (getForAllTeleLoc tele) + body' <- addHaddock body + pure $ L l (HsForAllTy x tele body') + + -- (Eq a, Num a) => t + HsQualTy x lhs rhs -> do + registerHdkA lhs + rhs' <- addHaddock rhs + pure $ L l (HsQualTy x lhs rhs') + + -- arg -> res + HsFunTy u mult lhs rhs -> do + lhs' <- addHaddock lhs + rhs' <- addHaddock rhs + pure $ L l (HsFunTy u mult lhs' rhs') + + -- other types + _ -> liftHdkA $ do + mDoc <- getPrevNextDoc (locA l) + return (mkLHsDocTy (L l t) mDoc) + +{- ********************************************************************* +* * +* HdkA: a layer over HdkM that propagates location information * +* * +********************************************************************* -} + +-- See Note [Adding Haddock comments to the syntax tree]. +-- +-- 'HdkA' provides a way to propagate location information from surrounding +-- computations: +-- +-- left_neighbour <*> HdkA inner_span inner_m <*> right_neighbour +-- +-- Here, the following holds: +-- +-- * the 'left_neighbour' will only see Haddock comments until 'bufSpanStart' of 'inner_span' +-- * the 'right_neighbour' will only see Haddock comments after 'bufSpanEnd' of 'inner_span' +-- * the 'inner_m' will only see Haddock comments between its 'left_neighbour' and its 'right_neighbour' +-- +-- In other words, every computation: +-- +-- * delimits the surrounding computations +-- * is delimited by the surrounding computations +-- +-- Therefore, a 'HdkA' computation must be always considered in the context in +-- which it is used. +data HdkA a = + HdkA + !(Strict.Maybe BufSpan) + -- Just b <=> BufSpan occupied by the processed AST element. + -- The surrounding computations will not look inside. + -- + -- Nothing <=> No BufSpan (e.g. when the HdkA is constructed by 'pure' or 'liftHdkA'). + -- The surrounding computations are not delimited. + + !(HdkM a) -- The stateful computation that looks up Haddock comments and + -- adds them to the resulting AST node. + + deriving (Functor) + +instance Applicative HdkA where + HdkA l1 m1 <*> HdkA l2 m2 = + HdkA + (l1 <> l2) -- The combined BufSpan that covers both subcomputations. + -- + -- The Semigroup instance for Maybe quite conveniently does the right thing: + -- Nothing <> b = b + -- a <> Nothing = a + -- Just a <> Just b = Just (a <> b) + + (delim1 m1 <*> delim2 m2) -- Stateful computations are run in left-to-right order, + -- without any smart reordering strategy. So users of this + -- operation must take care to traverse the AST + -- in concrete syntax order. + -- See Note [Smart reordering in HdkA (or lack thereof)] + -- + -- Each computation is delimited ("sandboxed") + -- in a way that it doesn't see any Haddock + -- comments past the neighbouring AST node. + -- These delim1/delim2 are key to how HdkA operates. + where + -- Delimit the LHS by the location information from the RHS + delim1 = inLocRange (locRangeTo (fmap @Strict.Maybe bufSpanStart l2)) + -- Delimit the RHS by the location information from the LHS + delim2 = inLocRange (locRangeFrom (fmap @Strict.Maybe bufSpanEnd l1)) + + pure a = + -- Return a value without performing any stateful computation, and without + -- any delimiting effect on the surrounding computations. + liftHdkA (pure a) + +{- Note [Smart reordering in HdkA (or lack thereof)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When traversing the AST, the user must take care to traverse it in concrete +syntax order. + +For example, when processing HsFunTy, it's important to get it right and write +it like so: + + HsFunTy _ mult lhs rhs -> do + lhs' <- addHaddock lhs + rhs' <- addHaddock rhs + pure $ L l (HsFunTy noExtField mult lhs' rhs') + +Rather than like so: + + HsFunTy _ mult lhs rhs -> do + rhs' <- addHaddock rhs -- bad! wrong order + lhs' <- addHaddock lhs -- bad! wrong order + pure $ L l (HsFunTy noExtField mult lhs' rhs') + +This is somewhat bug-prone, so we could try to fix this with some Applicative +magic. When we define (<*>) for HdkA, why not reorder the computations as +necessary? In pseudo-code: + + a1 <*> a2 | a1 `before` a2 = ... normal processing ... + | otherwise = a1 <**> a2 + +While this trick could work for any two *adjacent* AST elements out of order +(as in HsFunTy example above), it would fail in more elaborate scenarios (e.g. +processing a list of declarations out of order). + +If it's not obvious why this trick doesn't work, ponder this: it's a bit like trying to get +a sorted list by defining a 'smart' concatenation operator in the following manner: + + a ?++ b | a <= b = a ++ b + | otherwise = b ++ a + +At first glance it seems to work: + + ghci> [1] ?++ [2] ?++ [3] + [1,2,3] + + ghci> [2] ?++ [1] ?++ [3] + [1,2,3] -- wow, sorted! + +But it actually doesn't: + + ghci> [3] ?++ [1] ?++ [2] + [1,3,2] -- not sorted... +-} + +-- Run a HdkA computation in an unrestricted LocRange. This is only used at the +-- top level to run the final computation for the entire module. +runHdkA :: HdkA a -> HdkSt -> (a, HdkSt) +runHdkA (HdkA _ m) = unHdkM m mempty + +-- Let the neighbours know about an item at this location. +-- +-- Consider this example: +-- +-- class -- | peculiarly placed comment +-- MyClass a where +-- my_method :: a -> a +-- +-- How do we know to reject the "peculiarly placed comment" instead of +-- associating it with my_method? Its indentation level matches. +-- +-- But clearly, there's "MyClass a where" separating the comment and my_method. +-- To take it into account, we must register its location using registerLocHdkA +-- or registerHdkA. +-- +-- See Note [Register keyword location]. +-- See Note [Adding Haddock comments to the syntax tree]. +registerLocHdkA :: SrcSpan -> HdkA () +registerLocHdkA l = HdkA (getBufSpan l) (pure ()) + +-- Let the neighbours know about an item at this location. +-- A small wrapper over registerLocHdkA. +-- +-- See Note [Adding Haddock comments to the syntax tree]. +registerHdkA :: GenLocated (EpAnn a) e -> HdkA () +registerHdkA a = registerLocHdkA (getLocA a) + +-- Let the neighbours know about a token at this location. +-- Similar to registerLocHdkA and registerHdkA. +-- +-- See Note [Adding Haddock comments to the syntax tree]. +registerEpTokenHdkA :: EpToken tok -> HdkA () +registerEpTokenHdkA tok = HdkA (getEpTokenBufSpan tok) (pure ()) + +-- Modify the action of a HdkA computation. +hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b +hoistHdkA f (HdkA l m) = HdkA l (f m) + +-- Lift a HdkM computation to HdkA. +liftHdkA :: HdkM a -> HdkA a +liftHdkA = HdkA mempty + +-- Extend the declared location span of a 'HdkA' computation: +-- +-- left_neighbour <*> extendHdkA l x <*> right_neighbour +-- +-- The declared location of 'x' now includes 'l', so that the surrounding +-- computations 'left_neighbour' and 'right_neighbour' will not look for +-- Haddock comments inside the 'l' location span. +extendHdkA :: SrcSpan -> HdkA a -> HdkA a +extendHdkA l' (HdkA l m) = HdkA (getBufSpan l' <> l) m + + +{- ********************************************************************* +* * +* HdkM: a stateful computation to associate * +* accumulated documentation comments with AST nodes * +* * +********************************************************************* -} + +-- The state of 'HdkM' contains a list of pending Haddock comments. We go +-- over the AST, looking up these comments using 'takeHdkComments' and removing +-- them from the state. The remaining, un-removed ones are ignored with a +-- warning (-Winvalid-haddock). Also, using a state means we never use the same +-- Haddock twice. +-- +-- See Note [Adding Haddock comments to the syntax tree]. +newtype HdkM a = HdkM { unHdkM :: LocRange -> HdkSt -> (a, HdkSt) } + deriving (Functor, Applicative, Monad) via (ReaderT LocRange (State HdkSt)) + +-- | The state of HdkM. +data HdkSt = + HdkSt + { hdk_st_pending :: [PsLocated HdkComment] + -- a list of pending (unassociated with an AST node) + -- Haddock comments, sorted by location: in ascending order of the starting 'BufPos' + , hdk_st_warnings :: [HdkWarn] + -- accumulated warnings (order doesn't matter) + } + +-- | Warnings accumulated in HdkM. +data HdkWarn + = HdkWarnInvalidComment (PsLocated HdkComment) + | HdkWarnExtraComment (Located HsDocString) + +-- Restrict the range in which a HdkM computation will look up comments: +-- +-- inLocRange r1 $ +-- inLocRange r2 $ +-- takeHdkComments ... -- Only takes comments in the (r1 <> r2) location range. +-- +-- Note that it does not blindly override the range but tightens it using (<>). +-- At many use sites, you will see something along the lines of: +-- +-- inLocRange (locRangeTo end_pos) $ ... +-- +-- And 'locRangeTo' defines a location range from the start of the file to +-- 'end_pos'. This does not mean that we now search for every comment from the +-- start of the file, as this restriction will be combined with other +-- restrictions. Somewhere up the callstack we might have: +-- +-- inLocRange (locRangeFrom start_pos) $ ... +-- +-- The net result is that the location range is delimited by 'start_pos' on +-- one side and by 'end_pos' on the other side. +-- +-- In 'HdkA', every (<*>) may restrict the location range of its +-- subcomputations. +inLocRange :: LocRange -> HdkM a -> HdkM a +inLocRange r (HdkM m) = HdkM (\r' -> m (r <> r')) + +-- Take the Haddock comments that satisfy the matching function, +-- leaving the rest pending. +takeHdkComments :: forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a] +takeHdkComments f = + HdkM $ + \(LocRange hdk_from hdk_to hdk_col) -> + \hdk_st -> + let + comments = hdk_st_pending hdk_st + (comments_before_range, comments') = break (is_after hdk_from) comments + (comments_in_range, comments_after_range) = span (is_before hdk_to <&&> is_indented hdk_col) comments' + (items, other_comments) = foldr add_comment ([], []) comments_in_range + remaining_comments = comments_before_range ++ other_comments ++ comments_after_range + hdk_st' = hdk_st{ hdk_st_pending = remaining_comments } + in (items, hdk_st') + where + is_after StartOfFile _ = True + is_after (StartLoc l) (L l_comment _) = bufSpanStart (psBufSpan l_comment) >= l + is_before EndOfFile _ = True + is_before (EndLoc l) (L l_comment _) = bufSpanStart (psBufSpan l_comment) <= l + is_indented (ColumnFrom n) (L l_comment _) = srcSpanStartCol (psRealSpan l_comment) >= n + + add_comment + :: PsLocated HdkComment + -> ([a], [PsLocated HdkComment]) + -> ([a], [PsLocated HdkComment]) + add_comment hdk_comment (items, other_hdk_comments) = + case f hdk_comment of + Just item -> (item : items, other_hdk_comments) + Nothing -> (items, hdk_comment : other_hdk_comments) + +-- Run a HdkM action and restore the original state. +peekHdkM :: HdkM a -> HdkM a +peekHdkM m = + HdkM $ \r s -> + case unHdkM m r s of + (a, _) -> (a, s) + +-- Get the docnext or docprev comment for an AST node at the given source span. +getPrevNextDoc :: SrcSpan -> HdkM (Maybe (Located HsDocString)) +getPrevNextDoc l = do + let (l_start, l_end) = (srcSpanStart l, srcSpanEnd l) + before_t = locRangeTo (getBufPos l_start) + after_t = locRangeFrom (getBufPos l_end) + nextDocs <- inLocRange before_t $ takeHdkComments mkDocNext + prevDocs <- inLocRange after_t $ takeHdkComments mkDocPrev + selectDocString (nextDocs ++ prevDocs) + +appendHdkWarning :: HdkWarn -> HdkM () +appendHdkWarning e = HdkM $ \_ hdk_st -> + let hdk_st' = hdk_st { hdk_st_warnings = e : hdk_st_warnings hdk_st } + in ((), hdk_st') + +selectDocString :: [Located HsDocString] -> HdkM (Maybe (Located HsDocString)) +selectDocString = select . filterOut (isEmptyDocString . unLoc) + where + select [] = return Nothing + select [doc] = return (Just doc) + select (doc : extra_docs) = do + reportExtraDocs extra_docs + return (Just doc) + +reportExtraDocs :: [Located HsDocString] -> HdkM () +reportExtraDocs = + traverse_ (\extra_doc -> appendHdkWarning (HdkWarnExtraComment extra_doc)) + +{- ********************************************************************* +* * +* Matching functions for extracting documentation comments * +* * +********************************************************************* -} + +mkDocHsDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) +mkDocHsDecl layout a = fmap (DocD noExtField) <$> mkDocDecl layout a + +mkDocDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) +mkDocDecl layout (L l_comment hdk_comment) + | indent_mismatch = Nothing + | otherwise = + Just $ L (noAnnSrcSpan span) $ + case hdk_comment of + HdkCommentNext doc -> DocCommentNext (L span $ lexHsDocString doc) + HdkCommentPrev doc -> DocCommentPrev (L span $ lexHsDocString doc) + HdkCommentNamed s doc -> DocCommentNamed s (L span $ lexHsDocString doc) + HdkCommentSection n doc -> DocGroup n (L span $ lexHsDocString doc) + where + span = mkSrcSpanPs l_comment + -- 'indent_mismatch' checks if the documentation comment has the exact + -- indentation level expected by the parent node. + -- + -- For example, when extracting documentation comments between class + -- method declarations, there are three cases to consider: + -- + -- 1. Indent matches (indent_mismatch=False): + -- class C a where + -- f :: a -> a + -- -- ^ doc on f + -- + -- 2. Indented too much (indent_mismatch=True): + -- class C a where + -- f :: a -> a + -- -- ^ indent mismatch + -- + -- 3. Indented too little (indent_mismatch=True): + -- class C a where + -- f :: a -> a + -- -- ^ indent mismatch + indent_mismatch = case layout of + EpNoLayout -> False + EpExplicitBraces{} -> False + EpVirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment) + +mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) +mkDocIE (L l_comment hdk_comment) = + case hdk_comment of + HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n $ L span $ lexHsDocString doc) + HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s) + HdkCommentNext doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc) + HdkCommentPrev doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc) + where l = noAnnSrcSpan span + span = mkSrcSpanPs l_comment + +mkDocNext :: PsLocated HdkComment -> Maybe (Located HsDocString) +mkDocNext (L l (HdkCommentNext doc)) = Just (L (mkSrcSpanPs l) doc) +mkDocNext _ = Nothing + +mkDocPrev :: PsLocated HdkComment -> Maybe (Located HsDocString) +mkDocPrev (L l (HdkCommentPrev doc)) = Just (L (mkSrcSpanPs l) doc) +mkDocPrev _ = Nothing + + +{- ********************************************************************* +* * +* LocRange: a location range * +* * +********************************************************************* -} + +-- A location range for extracting documentation comments. +data LocRange = + LocRange + { loc_range_from :: !LowerLocBound, + loc_range_to :: !UpperLocBound, + loc_range_col :: !ColumnBound } + +instance Semigroup LocRange where + LocRange from1 to1 col1 <> LocRange from2 to2 col2 = + LocRange (from1 <> from2) (to1 <> to2) (col1 <> col2) + +instance Monoid LocRange where + mempty = LocRange mempty mempty mempty + +-- The location range from the specified position to the end of the file. +locRangeFrom :: Strict.Maybe BufPos -> LocRange +locRangeFrom (Strict.Just l) = mempty { loc_range_from = StartLoc l } +locRangeFrom Strict.Nothing = mempty + +-- The location range from the start of the file to the specified position. +locRangeTo :: Strict.Maybe BufPos -> LocRange +locRangeTo (Strict.Just l) = mempty { loc_range_to = EndLoc l } +locRangeTo Strict.Nothing = mempty + +-- The location range within the specified span. +locRangeIn :: Strict.Maybe BufSpan -> LocRange +locRangeIn (Strict.Just l) = + mempty { loc_range_from = StartLoc (bufSpanStart l) + , loc_range_to = EndLoc (bufSpanEnd l) } +locRangeIn Strict.Nothing = mempty + +-- Represents a predicate on BufPos: +-- +-- LowerLocBound | BufPos -> Bool +-- --------------+----------------- +-- StartOfFile | const True +-- StartLoc p | (>= p) +-- +-- The semigroup instance corresponds to (&&). +-- +-- We don't use the BufPos -> Bool representation +-- as it would lead to redundant checks. +-- +-- That is, instead of +-- +-- (pos >= 20) && (pos >= 30) && (pos >= 40) +-- +-- We'd rather only do the (>=40) check. So we reify the predicate to make +-- sure we only check for the most restrictive bound. +data LowerLocBound = StartOfFile | StartLoc !BufPos + deriving Show + +instance Semigroup LowerLocBound where + StartOfFile <> l = l + l <> StartOfFile = l + StartLoc l1 <> StartLoc l2 = StartLoc (max l1 l2) + +instance Monoid LowerLocBound where + mempty = StartOfFile + +-- Represents a predicate on BufPos: +-- +-- UpperLocBound | BufPos -> Bool +-- --------------+----------------- +-- EndOfFile | const True +-- EndLoc p | (<= p) +-- +-- The semigroup instance corresponds to (&&). +-- +-- We don't use the BufPos -> Bool representation +-- as it would lead to redundant checks. +-- +-- That is, instead of +-- +-- (pos <= 40) && (pos <= 30) && (pos <= 20) +-- +-- We'd rather only do the (<=20) check. So we reify the predicate to make +-- sure we only check for the most restrictive bound. +data UpperLocBound = EndOfFile | EndLoc !BufPos + deriving Show + +instance Semigroup UpperLocBound where + EndOfFile <> l = l + l <> EndOfFile = l + EndLoc l1 <> EndLoc l2 = EndLoc (min l1 l2) + +instance Monoid UpperLocBound where + mempty = EndOfFile + +-- | Represents a predicate on the column number. +-- +-- ColumnBound | Int -> Bool +-- --------------+----------------- +-- ColumnFrom n | (>=n) +-- +-- The semigroup instance corresponds to (&&). +-- +newtype ColumnBound = ColumnFrom Int -- n >= GHC.Types.SrcLoc.leftmostColumn + deriving Show + +instance Semigroup ColumnBound where + ColumnFrom n <> ColumnFrom m = ColumnFrom (max n m) + +instance Monoid ColumnBound where + mempty = ColumnFrom leftmostColumn + + +{- ********************************************************************* +* * +* AST manipulation utilities * +* * +********************************************************************* -} + +mkLHsDocTy :: LHsType GhcPs -> Maybe (Located HsDocString) -> LHsType GhcPs +mkLHsDocTy t Nothing = t +mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noExtField t $ lexLHsDocString doc) + +getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan +getForAllTeleLoc tele = + case tele of + HsForAllVis{ hsf_vis_bndrs } -> getLHsTyVarBndrsLoc hsf_vis_bndrs + HsForAllInvis { hsf_invis_bndrs } -> getLHsTyVarBndrsLoc hsf_invis_bndrs + +getLHsTyVarBndrsLoc :: [LHsTyVarBndr flag GhcPs] -> SrcSpan +getLHsTyVarBndrsLoc bndrs = foldr combineSrcSpans noSrcSpan $ map getLocA bndrs + +-- | The inverse of 'partitionBindsAndSigs' that merges partitioned items back +-- into a flat list. Elements are put back into the order in which they +-- appeared in the original program before partitioning, using BufPos to order +-- them. +-- +-- Precondition (unchecked): the input lists are already sorted. +flattenBindsAndSigs + :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], + [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) + -> [LHsDecl GhcPs] +flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) = + -- 'cmpBufSpan' is safe here with the following assumptions: + -- + -- - 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan' + -- - 'partitionBindsAndSigs' does not discard this 'BufSpan' + mergeListsBy cmpBufSpanA [ + mapLL (\b -> ValD noExtField b) all_bs, + mapLL (\s -> SigD noExtField s) all_ss, + mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts, + mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis, + mapLL (\dfi -> InstD noExtField (DataFamInstD noExtField dfi)) all_dfis, + mapLL (\d -> DocD noExtField d) all_docs + ] + +cmpBufSpanA :: GenLocated (EpAnn a1) a2 -> GenLocated (EpAnn a3) a2 -> Ordering +cmpBufSpanA (L la a) (L lb b) = cmpBufSpan (L (locA la) a) (L (locA lb) b) + +{- ********************************************************************* +* * +* General purpose utilities * +* * +********************************************************************* -} + +-- Map a function over a list of located items. +mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b] +mapLL f = map (fmap f) + +{- Note [Old solution: Haddock in the grammar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the past, Haddock comments were incorporated into the grammar (Parser.y). +This led to excessive complexity and duplication. + +For example, here's the grammar production for types without documentation: + + type : btype + | btype '->' ctype + +To support Haddock, we had to also maintain an additional grammar production +for types with documentation on function arguments and function result: + + typedoc : btype + | btype docprev + | docnext btype + | btype '->' ctypedoc + | btype docprev '->' ctypedoc + | docnext btype '->' ctypedoc + +Sometimes handling documentation comments during parsing led to bugs (#17561), +and sometimes it simply made it hard to modify and extend the grammar. + +Another issue was that sometimes Haddock would fail to parse code +that GHC could parse successfully: + + class BadIndent where + f :: a -> Int + -- ^ comment + g :: a -> Int + +This declaration was accepted by ghc but rejected by ghc -haddock. +-} + +{- Note [Register keyword location] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment, 'addHaddock' erroneously associates some comments with +constructs that are separated by a keyword. For example: + + data Foo -- | Comment for MkFoo + where MkFoo :: Foo + +We could use EPA (exactprint annotations) to fix this, but not without +modification. For example, EpaLocation contains RealSrcSpan but not BufSpan. +Also, the fix would be more straightforward after #19623. + +For examples, see tests/haddock/should_compile_flag_haddock/T17544_kw.hs +-} diff --git a/GHC/Parser/String.hs b/GHC/Parser/String.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/String.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Parser.String ( + StringLexError (..), + lexString, + lexMultilineString, + + -- * Unicode smart quote helpers + isDoubleSmartQuote, + isSingleSmartQuote, +) where + +import GHC.Prelude hiding (getChar) + +import Control.Arrow ((>>>)) +import Control.Monad (when) +import Data.Char (chr, ord) +import qualified Data.Foldable1 as Foldable1 +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (listToMaybe, mapMaybe) +import GHC.Data.StringBuffer (StringBuffer) +import qualified GHC.Data.StringBuffer as StringBuffer +import GHC.Parser.CharClass ( + hexDigit, + is_decdigit, + is_hexdigit, + is_octdigit, + is_space, + octDecDigit, + ) +import GHC.Parser.Errors.Types (LexErr (..)) +import GHC.Utils.Panic (panic) + +type BufPos = Int +data StringLexError = StringLexError LexErr BufPos + deriving (Show, Eq) + +lexString :: Int -> StringBuffer -> Either StringLexError String +lexString = lexStringWith processChars processChars + where + processChars :: HasChar c => [c] -> Either (c, LexErr) [c] + processChars = + collapseGaps + >>> resolveEscapes + +-- ----------------------------------------------------------------------------- +-- Lexing interface + +{- +Note [Lexing strings] +~~~~~~~~~~~~~~~~~~~~~ + +After verifying if a string is lexically valid with Alex, we still need to do +some post processing of the string, namely: +1. Collapse string gaps +2. Resolve escape characters + +The problem: 'lexemeToString' is more performant than manually reading +characters from the StringBuffer. However, that completely erases the position +of each character, which we need in order to report the correct position for +error messages (e.g. when resolving escape characters). + +So what we'll do is do two passes. The first pass is optimistic; just convert +to a plain String and process it. If this results in an error, we do a second +pass, this time where each character is annotated with its position. Now, the +error has all the information it needs. + +Ideally, lexStringWith would take a single (forall c. HasChar c => ...) function, +but to help the specializer, we pass it in twice to concretize it for the two +types we actually use. +-} + +-- | See Note [Lexing strings] +lexStringWith :: + ([Char] -> Either (Char, LexErr) [Char]) + -> ([CharPos] -> Either (CharPos, LexErr) [CharPos]) + -> Int + -> StringBuffer + -> Either StringLexError String +lexStringWith processChars processCharsPos len buf = + case processChars $ bufferChars buf len of + Right s -> Right s + Left _ -> + case processCharsPos $ bufferLocatedChars buf len of + Right _ -> panic "expected lex error on second pass" + Left ((_, pos), e) -> Left $ StringLexError e pos + +class HasChar c where + getChar :: c -> Char + setChar :: Char -> c -> c + +instance HasChar Char where + getChar = id + setChar = const + +instance HasChar (Char, x) where + getChar = fst + setChar c (_, x) = (c, x) + +pattern Char :: HasChar c => Char -> c +pattern Char c <- (getChar -> c) +{-# COMPLETE Char #-} + +bufferChars :: StringBuffer -> Int -> [Char] +bufferChars = StringBuffer.lexemeToString + +type CharPos = (Char, BufPos) + +bufferLocatedChars :: StringBuffer -> Int -> [CharPos] +bufferLocatedChars initialBuf len = go initialBuf + where + go buf + | atEnd buf = [] + | otherwise = + let (c, buf') = StringBuffer.nextChar buf + in (c, StringBuffer.cur buf) : go buf' + + atEnd buf = StringBuffer.byteDiff initialBuf buf >= len + +-- ----------------------------------------------------------------------------- +-- Lexing phases + +-- | Collapse all string gaps in the given input. +-- +-- Iterates through the input in `go` until we encounter a backslash. The +-- @stringchar Alex regex only allows backslashes in two places: escape codes +-- and string gaps. +-- +-- * If the next character is a space, it has to be the start of a string gap +-- AND it must end, since the @gap Alex regex will only match if it ends. +-- Collapse the gap and continue the main iteration loop. +-- +-- * Otherwise, this is an escape code. If it's an escape code, there are +-- ONLY three possibilities (see the @escape Alex regex): +-- 1. The escape code is "\\" +-- 2. The escape code is "\^\" +-- 3. The escape code does not have a backslash, other than the initial +-- backslash +-- +-- In the first two possibilities, just skip them and continue the main +-- iteration loop ("skip" as in "keep in the list as-is"). In the last one, +-- we can just skip the backslash, then continue the main iteration loop. +-- the rest of the escape code will be skipped as normal characters in the +-- string; no need to fully parse a proper escape code. +collapseGaps :: HasChar c => [c] -> [c] +collapseGaps = go + where + go = \case + -- Match the start of a string gap + drop gap + -- #25784: string gaps are semantically equivalent to "\&" + c1@(Char '\\') : Char c : cs + | is_space c -> c1 : setChar '&' c1 : go (dropGap cs) + -- Match all possible escape characters that include a backslash + c1@(Char '\\') : c2@(Char '\\') : cs + -> c1 : c2 : go cs + c1@(Char '\\') : c2@(Char '^') : c3@(Char '\\') : cs + -> c1 : c2 : c3 : go cs + -- Otherwise, just keep looping + c : cs -> c : go cs + [] -> [] + + dropGap = \case + Char '\\' : cs -> cs + _ : cs -> dropGap cs + -- Unreachable since gaps must end; see docstring + [] -> panic "gap unexpectedly ended" + +resolveEscapes :: HasChar c => [c] -> Either (c, LexErr) [c] +resolveEscapes = go dlistEmpty + where + go !acc = \case + [] -> pure $ dlistToList acc + Char '\\' : Char '&' : cs -> go acc cs + backslash@(Char '\\') : cs -> + case resolveEscapeChar cs of + Right (esc, cs') -> go (acc `dlistSnoc` setChar esc backslash) cs' + Left (c, e) -> Left (c, e) + c : cs -> go (acc `dlistSnoc` c) cs + +-- ----------------------------------------------------------------------------- +-- Escape characters + +-- | Resolve a escape character, after having just lexed a backslash. +-- Assumes escape character is valid. +resolveEscapeChar :: HasChar c => [c] -> Either (c, LexErr) (Char, [c]) +resolveEscapeChar = \case + Char 'a' : cs -> pure ('\a', cs) + Char 'b' : cs -> pure ('\b', cs) + Char 'f' : cs -> pure ('\f', cs) + Char 'n' : cs -> pure ('\n', cs) + Char 'r' : cs -> pure ('\r', cs) + Char 't' : cs -> pure ('\t', cs) + Char 'v' : cs -> pure ('\v', cs) + Char '\\' : cs -> pure ('\\', cs) + Char '"' : cs -> pure ('\"', cs) + Char '\'' : cs -> pure ('\'', cs) + -- escape codes + Char 'x' : cs -> parseNum is_hexdigit 16 hexDigit cs + Char 'o' : cs -> parseNum is_octdigit 8 octDecDigit cs + cs@(Char c : _) | is_decdigit c -> parseNum is_decdigit 10 octDecDigit cs + -- control characters (e.g. '\^M') + Char '^' : Char c : cs -> pure (chr $ ord c - ord '@', cs) + -- long form escapes (e.g. '\NUL') + cs | Just (esc, cs') <- parseLongEscape cs -> pure (esc, cs') + -- shouldn't happen + Char c : _ -> panic $ "found unexpected escape character: " ++ show c + [] -> panic "escape character unexpectedly ended" + where + parseNum isDigit base toDigit = + let go x = \case + ch@(Char c) : cs | isDigit c -> do + let x' = x * base + toDigit c + when (x' > 0x10ffff) $ Left (ch, LexNumEscapeRange) + go x' cs + cs -> pure (chr x, cs) + in go 0 + +parseLongEscape :: HasChar c => [c] -> Maybe (Char, [c]) +parseLongEscape cs = listToMaybe (mapMaybe tryParse longEscapeCodes) + where + tryParse (code, esc) = + case splitAt (length code) cs of + (pre, cs') | map getChar pre == code -> Just (esc, cs') + _ -> Nothing + + longEscapeCodes = + [ ("NUL", '\NUL') + , ("SOH", '\SOH') + , ("STX", '\STX') + , ("ETX", '\ETX') + , ("EOT", '\EOT') + , ("ENQ", '\ENQ') + , ("ACK", '\ACK') + , ("BEL", '\BEL') + , ("BS" , '\BS' ) + , ("HT" , '\HT' ) + , ("LF" , '\LF' ) + , ("VT" , '\VT' ) + , ("FF" , '\FF' ) + , ("CR" , '\CR' ) + , ("SO" , '\SO' ) + , ("SI" , '\SI' ) + , ("DLE", '\DLE') + , ("DC1", '\DC1') + , ("DC2", '\DC2') + , ("DC3", '\DC3') + , ("DC4", '\DC4') + , ("NAK", '\NAK') + , ("SYN", '\SYN') + , ("ETB", '\ETB') + , ("CAN", '\CAN') + , ("EM" , '\EM' ) + , ("SUB", '\SUB') + , ("ESC", '\ESC') + , ("FS" , '\FS' ) + , ("GS" , '\GS' ) + , ("RS" , '\RS' ) + , ("US" , '\US' ) + , ("SP" , '\SP' ) + , ("DEL", '\DEL') + ] + +-- ----------------------------------------------------------------------------- +-- Unicode Smart Quote detection (#21843) + +isDoubleSmartQuote :: Char -> Bool +isDoubleSmartQuote = \case + '“' -> True + '”' -> True + _ -> False + +isSingleSmartQuote :: Char -> Bool +isSingleSmartQuote = \case + '‘' -> True + '’' -> True + _ -> False + +-- ----------------------------------------------------------------------------- +-- Multiline strings + +-- | See Note [Multiline string literals] +-- +-- Assumes string is lexically valid. Skips the steps about splitting +-- and rejoining lines, and instead manually find newline characters, +-- for performance. +lexMultilineString :: Int -> StringBuffer -> Either StringLexError String +lexMultilineString = lexStringWith processChars processChars + where + processChars :: HasChar c => [c] -> Either (c, LexErr) [c] + processChars = + collapseGaps -- Step 1 + >>> normalizeEOL + >>> expandLeadingTabs -- Step 3 + >>> rmCommonWhitespacePrefix -- Step 4 + >>> collapseOnlyWsLines -- Step 5 + >>> rmFirstNewline -- Step 7a + >>> rmLastNewline -- Step 7b + >>> resolveEscapes -- Step 8 + + -- Normalize line endings to LF. The spec dictates that lines should be + -- split on newline characters and rejoined with ``\n``. But because we + -- aren't actually splitting/rejoining, we'll manually normalize here + normalizeEOL :: HasChar c => [c] -> [c] + normalizeEOL = + let go = \case + Char '\r' : c@(Char '\n') : cs -> c : go cs + c@(Char '\r') : cs -> setChar '\n' c : go cs + c@(Char '\f') : cs -> setChar '\n' c : go cs + c : cs -> c : go cs + [] -> [] + in go + + -- expands all tabs, since the lexer will verify that tabs can only appear + -- as leading indentation + expandLeadingTabs :: HasChar c => [c] -> [c] + expandLeadingTabs = + let go !col = \case + c@(Char '\t') : cs -> + let fill = 8 - (col `mod` 8) + in replicate fill (setChar ' ' c) ++ go (col + fill) cs + c : cs -> c : go (if getChar c == '\n' then 0 else col + 1) cs + [] -> [] + in go 0 + + rmCommonWhitespacePrefix :: HasChar c => [c] -> [c] + rmCommonWhitespacePrefix cs0 = + let commonWSPrefix = getCommonWsPrefix (map getChar cs0) + go = \case + c@(Char '\n') : cs -> c : go (dropLine commonWSPrefix cs) + c : cs -> c : go cs + [] -> [] + -- drop x characters from the string, or up to a newline, whichever + -- comes first + dropLine !x = \case + cs | x <= 0 -> cs + cs@(Char '\n' : _) -> cs + _ : cs -> dropLine (x - 1) cs + [] -> [] + in go cs0 + + collapseOnlyWsLines :: HasChar c => [c] -> [c] + collapseOnlyWsLines = + let go = \case + c@(Char '\n') : cs | Just cs' <- checkAllWs cs -> c : go cs' + c : cs -> c : go cs + [] -> [] + checkAllWs = \case + -- got all the way to a newline or the end of the string, return + cs@(Char '\n' : _) -> Just cs + cs@[] -> Just cs + -- found whitespace, continue + Char c : cs | is_space c -> checkAllWs cs + -- anything else, stop + _ -> Nothing + in go + + rmFirstNewline :: HasChar c => [c] -> [c] + rmFirstNewline = \case + Char '\n' : cs -> cs + cs -> cs + + rmLastNewline :: HasChar c => [c] -> [c] + rmLastNewline = + let go = \case + [] -> [] + [Char '\n'] -> [] + c : cs -> c : go cs + in go + +-- | See step 4 in Note [Multiline string literals] +-- +-- Assumes tabs have already been expanded. +getCommonWsPrefix :: String -> Int +getCommonWsPrefix s = + case NonEmpty.nonEmpty includedLines of + Nothing -> 0 + Just ls -> Foldable1.minimum $ NonEmpty.map (length . takeWhile is_space) ls + where + includedLines = + filter (not . all is_space) -- ignore whitespace-only lines + . drop 1 -- ignore first line in calculation + $ lines s + +{- +Note [Multiline string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Multiline string literals were added following the acceptance of the +proposal: https://github.com/ghc-proposals/ghc-proposals/pull/569 + +Multiline string literals are syntax sugar for normal string literals, +with an extra post processing step. This all happens in the Lexer; that +is, HsMultilineString will contain the post-processed string. This matches +the same behavior as HsString, which contains the normalized string +(see Note [Literal source text]). + +The canonical steps for post processing a multiline string are: +1. Collapse string gaps +2. Split the string by newlines +3. Convert leading tabs into spaces + * In each line, any tabs preceding non-whitespace characters are replaced with spaces up to the next tab stop +4. Remove common whitespace prefix in every line except the first (see below) +5. If a line contains only whitespace, remove all of the whitespace +6. Join the string back with `\n` delimiters +7a. If the first character of the string is a newline, remove it +7b. If the last character of the string is a newline, remove it +8. Interpret escaped characters + +The common whitespace prefix can be informally defined as "The longest +prefix of whitespace shared by all lines in the string, excluding the +first line and any whitespace-only lines". + +It's more precisely defined with the following algorithm: + +1. Take a list representing the lines in the string +2. Ignore the following elements in the list: + * The first line (we want to ignore everything before the first newline) + * Empty lines + * Lines with only whitespace characters +3. Calculate the longest prefix of whitespace shared by all lines in the remaining list +-} + +-- ----------------------------------------------------------------------------- +-- DList + +newtype DList a = DList ([a] -> [a]) + +dlistEmpty :: DList a +dlistEmpty = DList id + +dlistToList :: DList a -> [a] +dlistToList (DList f) = f [] + +dlistSnoc :: DList a -> a -> DList a +dlistSnoc (DList f) x = DList (f . (x :)) diff --git a/GHC/Parser/Types.hs b/GHC/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Types.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} + +module GHC.Parser.Types + ( SumOrTuple(..) + , pprSumOrTuple + , PatBuilder(..) + , DataConBuilder(..) + , ExplicitNamespaceKeyword(..) + ) +where + +import GHC.Prelude +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Name.Reader +import GHC.Hs.Extension +import GHC.Hs.Lit +import GHC.Hs.Pat +import GHC.Hs.Type +import GHC.Utils.Outputable as Outputable +import GHC.Data.OrdList + +import Data.Foldable +import GHC.Parser.Annotation +import Language.Haskell.Syntax + +data SumOrTuple b + = Sum ConTag Arity (LocatedA b) [EpToken "|"] [EpToken "|"] + -- ^ Last two are the locations of the '|' before and after the payload + | Tuple [Either (EpAnn Bool) (LocatedA b)] + +pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc +pprSumOrTuple boxity = \case + Sum alt arity e _ _ -> + parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) + <+> parClose + Tuple xs -> + parOpen <> (fcat . punctuate comma $ map ppr_tup xs) + <> parClose + where + ppr_tup (Left _) = empty + ppr_tup (Right e) = ppr e + + ppr_bars n = hsep (replicate n (Outputable.char '|')) + (parOpen, parClose) = + case boxity of + Boxed -> (text "(", text ")") + Unboxed -> (text "(#", text "#)") + + +-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] +data PatBuilder p + = PatBuilderPat (Pat p) + | PatBuilderPar (EpToken "(") (LocatedA (PatBuilder p)) (EpToken ")") + | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) + | PatBuilderAppType (LocatedA (PatBuilder p)) (EpToken "@") (HsTyPat GhcPs) + | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName) + (LocatedA (PatBuilder p)) ([EpToken "("], [EpToken ")"]) + | PatBuilderVar (LocatedN RdrName) + | PatBuilderOverLit (HsOverLit GhcPs) + +-- These instances are here so that they are not orphans +type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = EpAnnCO +type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW +type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA +type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA + +instance Outputable (PatBuilder GhcPs) where + ppr (PatBuilderPat p) = ppr p + ppr (PatBuilderPar _ (L _ p) _) = parens (ppr p) + ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 + ppr (PatBuilderAppType (L _ p) _ t) = ppr p <+> text "@" <> ppr t + ppr (PatBuilderOpApp (L _ p1) op (L _ p2) _) = ppr p1 <+> ppr op <+> ppr p2 + ppr (PatBuilderVar v) = ppr v + ppr (PatBuilderOverLit l) = ppr l + +-- | An accumulator to build a prefix data constructor, +-- e.g. when parsing @MkT A B C@, the accumulator will evolve as follows: +-- +-- @ +-- 1. PrefixDataConBuilder [] MkT +-- 2. PrefixDataConBuilder [A] MkT +-- 3. PrefixDataConBuilder [A, B] MkT +-- 4. PrefixDataConBuilder [A, B, C] MkT +-- @ +-- +-- There are two reasons we have a separate builder type instead of using +-- @HsConDeclDetails GhcPs@ directly: +-- +-- 1. It's faster, because 'OrdList' gives us constant-time snoc. +-- 2. Having a separate type helps ensure that we don't forget to finalize a +-- 'RecTy' into a 'RecCon' (we do that in 'dataConBuilderDetails'). +-- +-- See Note [PatBuilder] for another builder type used in the parser. +-- Here the technique is similar, but the motivation is different. +data DataConBuilder + = PrefixDataConBuilder + (OrdList (LHsType GhcPs)) -- Data constructor fields + (LocatedN RdrName) -- Data constructor name + | InfixDataConBuilder + (LHsType GhcPs) -- LHS field + (LocatedN RdrName) -- Data constructor name + (LHsType GhcPs) -- RHS field + +instance Outputable DataConBuilder where + ppr (PrefixDataConBuilder flds data_con) = + hang (ppr data_con) 2 (sep (map ppr (toList flds))) + ppr (InfixDataConBuilder lhs data_con rhs) = + ppr lhs <+> ppr data_con <+> ppr rhs + +type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW + +data ExplicitNamespaceKeyword + = ExplicitTypeNamespace !(EpToken "type") + | ExplicitDataNamespace !(EpToken "data") diff --git a/GHC/Parser/Utils.hs b/GHC/Parser/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Utils.hs @@ -0,0 +1,58 @@ +module GHC.Parser.Utils + ( isStmt + , hasImport + , isImport + , isDecl + ) +where + +import GHC.Prelude +import GHC.Hs +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Types.SrcLoc + +import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState) +import GHC.Parser.Lexer (ParserOpts) +import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport) + + +-- | Returns @True@ if passed string is a statement. +isStmt :: ParserOpts -> String -> Bool +isStmt pflags stmt = + case parseThing Parser.parseStmt pflags stmt of + Lexer.POk _ _ -> True + Lexer.PFailed _ -> False + +-- | Returns @True@ if passed string has an import declaration. +hasImport :: ParserOpts -> String -> Bool +hasImport pflags stmt = + case parseThing Parser.parseModule pflags stmt of + Lexer.POk _ thing -> hasImports thing + Lexer.PFailed _ -> False + where + hasImports = not . null . hsmodImports . unLoc + +-- | Returns @True@ if passed string is an import declaration. +isImport :: ParserOpts -> String -> Bool +isImport pflags stmt = + case parseThing Parser.parseImport pflags stmt of + Lexer.POk _ _ -> True + Lexer.PFailed _ -> False + +-- | Returns @True@ if passed string is a declaration but __/not a splice/__. +isDecl :: ParserOpts -> String -> Bool +isDecl pflags stmt = + case parseThing Parser.parseDeclaration pflags stmt of + Lexer.POk _ thing -> + case unLoc thing of + SpliceD _ _ -> False + _ -> True + Lexer.PFailed _ -> False + +parseThing :: Lexer.P thing -> ParserOpts -> String -> Lexer.ParseResult thing +parseThing parser opts stmt = do + let buf = stringToStringBuffer stmt + loc = mkRealSrcLoc (fsLit "") 1 1 + + Lexer.unP parser (Lexer.initParserState opts buf loc) diff --git a/GHC/Platform.hs b/GHC/Platform.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} + +-- | Platform description +module GHC.Platform + ( Platform (..) + , PlatformWordSize(..) + , platformArch + , platformOS + , ArchOS(..) + , Arch(..) + , OS(..) + , ArmISA(..) + , ArmISAExt(..) + , ArmABI(..) + , PPC_64ABI(..) + , ByteOrder(..) + , target32Bit + , isARM + , isPPC + , osElfTarget + , osMachOTarget + , osSubsectionsViaSymbols + , platformUsesFrameworks + , platformWordSizeInBytes + , platformWordSizeInBits + , platformMinInt + , platformMaxInt + , platformMaxWord + , platformInIntRange + , platformInWordRange + , platformCConvNeedsExtension + , platformHasRTSLinker + , PlatformMisc(..) + , SseVersion (..) + , BmiVersion (..) + , wordAlignment + -- * SSE and AVX + , isSseEnabled + , isSse2Enabled + -- * Platform constants + , PlatformConstants(..) + , lookupPlatformConstants + , platformConstants + -- * Shared libraries + , platformSOName + , platformHsSOName + , platformSOExt + , genericPlatform + ) +where + +import Prelude -- See Note [Why do we import Prelude here?] + +import GHC.Read +import GHC.ByteOrder (ByteOrder(..)) +import GHC.Platform.Constants +import GHC.Platform.ArchOS +import GHC.Types.Basic (Alignment, alignmentOf) +import GHC.Utils.Panic.Plain + +import Data.Word +import Data.Int +import System.FilePath +import System.Directory + +-- | Platform description +-- +-- This is used to describe platforms so that we can generate code for them. +data Platform = Platform + { platformArchOS :: !ArchOS -- ^ Architecture and OS + , platformWordSize :: !PlatformWordSize -- ^ Word size + , platformByteOrder :: !ByteOrder -- ^ Byte order (endianness) + , platformUnregisterised :: !Bool + , platformHasGnuNonexecStack :: !Bool + , platformHasIdentDirective :: !Bool + , platformHasSubsectionsViaSymbols :: !Bool + -- ^ Enable Darwin .subsections_via_symbols directive + -- + -- See Note [Subsections Via Symbols] in GHC.CmmToAsm.X86.Ppr + , platformIsCrossCompiling :: !Bool + , platformLeadingUnderscore :: !Bool -- ^ Symbols need underscore prefix + , platformTablesNextToCode :: !Bool + -- ^ Determines whether we will be compiling info tables that reside just + -- before the entry code, or with an indirection to the entry code. See + -- TABLES_NEXT_TO_CODE in @rts/include/rts/storage/InfoTables.h@. + , platformHasLibm :: !Bool + -- ^ Some platforms require that we explicitly link against @libm@ if any + -- math-y things are used (which we assume to include all programs). See + -- #14022. + + , platform_constants :: !(Maybe PlatformConstants) + -- ^ Constants such as structure offsets, type sizes, etc. + } + deriving (Read, Show, Eq, Ord) + +wordAlignment :: Platform -> Alignment +wordAlignment platform = alignmentOf (platformWordSizeInBytes platform) + +-- ----------------------------------------------------------------------------- +-- SSE and AVX + +-- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to +-- check if SSE is enabled, we might have x86-64 imply the -msse2 +-- flag. + +isSseEnabled :: Platform -> Bool +isSseEnabled platform = case platformArch platform of + ArchX86_64 -> True + ArchX86 -> True + _ -> False + +isSse2Enabled :: Platform -> Bool +isSse2Enabled platform = case platformArch platform of + -- We assume SSE1 and SSE2 operations are available on both + -- x86 and x86_64. Historically we didn't default to SSE2 and + -- SSE1 on x86, which results in defacto nondeterminism for how + -- rounding behaves in the associated x87 floating point instructions + -- because variations in the spill/fpu stack placement of arguments for + -- operations would change the precision and final result of what + -- would otherwise be the same expressions with respect to single or + -- double precision IEEE floating point computations. + ArchX86_64 -> True + ArchX86 -> True + _ -> False + +-- ----------------------------------------------------------------------------- +-- Platform Constants + +platformConstants :: Platform -> PlatformConstants +platformConstants platform = case platform_constants platform of + Nothing -> panic "Platform constants not available!" + Just c -> c + +genericPlatform :: Platform +genericPlatform = Platform + { platformArchOS = ArchOS ArchX86_64 OSLinux + , platformWordSize = PW8 + , platformByteOrder = LittleEndian + , platformUnregisterised = False + , platformHasGnuNonexecStack = False + , platformHasIdentDirective = False + , platformHasSubsectionsViaSymbols= False + , platformHasLibm = False + , platformIsCrossCompiling = False + , platformLeadingUnderscore = False + , platformTablesNextToCode = True + , platform_constants = Nothing + } + +data PlatformWordSize + = PW4 -- ^ A 32-bit platform + | PW8 -- ^ A 64-bit platform + deriving (Eq, Ord) + +instance Show PlatformWordSize where + show PW4 = "4" + show PW8 = "8" + +instance Read PlatformWordSize where + readPrec = do + i :: Int <- readPrec + case i of + 4 -> return PW4 + 8 -> return PW8 + other -> fail ("Invalid PlatformWordSize: " ++ show other) + +platformWordSizeInBytes :: Platform -> Int +platformWordSizeInBytes p = + case platformWordSize p of + PW4 -> 4 + PW8 -> 8 + +platformWordSizeInBits :: Platform -> Int +platformWordSizeInBits p = platformWordSizeInBytes p * 8 + +-- | Platform architecture +platformArch :: Platform -> Arch +platformArch platform = case platformArchOS platform of + ArchOS arch _ -> arch + +-- | Platform OS +platformOS :: Platform -> OS +platformOS platform = case platformArchOS platform of + ArchOS _ os -> os + +-- | This predicate tells us whether the platform is 32-bit. +target32Bit :: Platform -> Bool +target32Bit p = + case platformWordSize p of + PW4 -> True + PW8 -> False + +osUsesFrameworks :: OS -> Bool +osUsesFrameworks OSDarwin = True +osUsesFrameworks _ = False + +platformUsesFrameworks :: Platform -> Bool +platformUsesFrameworks = osUsesFrameworks . platformOS + +osSubsectionsViaSymbols :: OS -> Bool +osSubsectionsViaSymbols OSDarwin = True +osSubsectionsViaSymbols _ = False + +-- | Minimum representable Int value for the given platform +platformMinInt :: Platform -> Integer +platformMinInt p = case platformWordSize p of + PW4 -> toInteger (minBound :: Int32) + PW8 -> toInteger (minBound :: Int64) + +-- | Maximum representable Int value for the given platform +platformMaxInt :: Platform -> Integer +platformMaxInt p = case platformWordSize p of + PW4 -> toInteger (maxBound :: Int32) + PW8 -> toInteger (maxBound :: Int64) + +-- | Maximum representable Word value for the given platform +platformMaxWord :: Platform -> Integer +platformMaxWord p = case platformWordSize p of + PW4 -> toInteger (maxBound :: Word32) + PW8 -> toInteger (maxBound :: Word64) + +-- | Test if the given Integer is representable with a platform Int +platformInIntRange :: Platform -> Integer -> Bool +platformInIntRange platform x = x >= platformMinInt platform && x <= platformMaxInt platform + +-- | Test if the given Integer is representable with a platform Word +platformInWordRange :: Platform -> Integer -> Bool +platformInWordRange platform x = x >= 0 && x <= platformMaxWord platform + +-- | For some architectures the C calling convention is that any +-- integer shorter than 64 bits is replaced by its 64 bits +-- representation using sign or zero extension. +platformCConvNeedsExtension :: Platform -> Bool +platformCConvNeedsExtension platform = case platformArch platform of + ArchPPC_64 _ -> True + ArchS390X -> True + ArchRISCV64 -> True + ArchLoongArch64 -> True + ArchAArch64 + -- Apple's AArch64 ABI requires that the caller sign-extend + -- small integer arguments. See + -- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms + | OSDarwin <- platformOS platform -> True + _ -> False + +-- | Does this platform have an RTS linker? +platformHasRTSLinker :: Platform -> Bool +-- Note that we've inlined this logic in hadrian's +-- Settings.Builders.RunTest.inTreeCompilerArgs. +-- If you change this, be sure to change it too +platformHasRTSLinker p = case archOS_arch (platformArchOS p) of + ArchPPC -> False -- powerpc + ArchPPC_64 ELF_V1 -> False -- powerpc64 + ArchPPC_64 ELF_V2 -> False -- powerpc64le + ArchS390X -> False + ArchLoongArch64 -> False + ArchJavaScript -> False + _ -> True + + + +-------------------------------------------------- +-- Instruction sets +-------------------------------------------------- + +-- | x86 SSE instructions +data SseVersion + = SSE1 + | SSE2 + | SSE3 + | SSSE3 + | SSE4 + | SSE42 + deriving (Eq, Ord) + +-- | x86 BMI (bit manipulation) instructions +data BmiVersion + = BMI1 + | BMI2 + deriving (Eq, Ord) + +-- | Platform-specific settings formerly hard-coded in Config.hs. +-- +-- These should probably be all be triaged whether they can be computed from +-- other settings or belong in another another place (like 'Platform' above). +data PlatformMisc = PlatformMisc + { -- TODO Recalculate string from richer info? + platformMisc_targetPlatformString :: String + , platformMisc_ghcWithInterpreter :: Bool + , platformMisc_libFFI :: Bool + , platformMisc_llvmTarget :: String + , platformMisc_targetRTSLinkerOnlySupportsSharedLibs :: Bool + } + +platformSOName :: Platform -> FilePath -> FilePath +platformSOName platform root = case platformOS platform of + OSMinGW32 -> root <.> platformSOExt platform + _ -> ("lib" ++ root) <.> platformSOExt platform + +platformHsSOName :: Platform -> FilePath -> FilePath +platformHsSOName platform root = ("lib" ++ root) <.> platformSOExt platform + +platformSOExt :: Platform -> FilePath +platformSOExt platform + = case platformOS platform of + OSDarwin -> "dylib" + OSMinGW32 -> "dll" + _ -> "so" + +-- Note [Platform constants] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The RTS is partly written in C, hence we use an external C compiler to build +-- it. Thus GHC must somehow retrieve some information about the produced code +-- (sizes of types, offsets of struct fields, etc.) to produce compatible code. +-- +-- This is the role of utils/deriveConstants utility: it produces a C +-- source, compiles it with the same toolchain that will be used to build the +-- RTS, and finally retrieves the constants from the built artefact. We can't +-- directly run the produced program because we may be cross-compiling. +-- +-- These constants are then stored in DerivedConstants.h header file that is +-- bundled with the RTS unit. This file is directly imported by Cmm codes and it +-- is also read by GHC. deriveConstants also produces the Haskell definition of +-- the PlatformConstants datatype and the Haskell parser for the +-- DerivedConstants.h file. +-- +-- For quite some time, constants used by GHC were globally installed in +-- ${libdir}/platformConstants but now GHC reads the DerivedConstants.h header +-- bundled with the RTS unit. GHC detects when it builds the RTS unit itself and +-- in this case it loads the header from the include-dirs passed on the +-- command-line. +-- +-- Note that GHC doesn't parse every "#define SOME_CONSTANT 123" individually. +-- Instead there is a single #define that contains all the constants useful to +-- GHC in a comma separated list: +-- +-- #define HS_CONSTANTS "123,45,..." +-- +-- Note that GHC mustn't directly import DerivedConstants.h as these constants +-- are only valid for a specific target platform and we want GHC to be target +-- agnostic. +-- + + +-- | Try to locate "DerivedConstants.h" file in the given dirs and to parse the +-- PlatformConstants from it. +-- +-- See Note [Platform constants] +lookupPlatformConstants :: [FilePath] -> IO (Maybe PlatformConstants) +lookupPlatformConstants include_dirs = find_constants include_dirs + where + try_parse d = do + let p = d "DerivedConstants.h" + doesFileExist p >>= \case + True -> Just <$> parseConstantsHeader p + False -> return Nothing + + find_constants [] = return Nothing + find_constants (x:xs) = try_parse x >>= \case + Nothing -> find_constants xs + Just c -> return (Just c) diff --git a/GHC/Platform/AArch64.hs b/GHC/Platform/AArch64.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/AArch64.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.AArch64 where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_aarch64 1 +#include "CodeGen.Platform.h" diff --git a/GHC/Platform/ARM.hs b/GHC/Platform/ARM.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/ARM.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.ARM where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_arm 1 +#include "CodeGen.Platform.h" + diff --git a/GHC/Platform/LA64.hs b/GHC/Platform/LA64.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/LA64.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.LA64 where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_loongarch64 1 +#include "CodeGen.Platform.h" diff --git a/GHC/Platform/NoRegs.hs b/GHC/Platform/NoRegs.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/NoRegs.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.NoRegs where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 1 +#include "CodeGen.Platform.h" + diff --git a/GHC/Platform/PPC.hs b/GHC/Platform/PPC.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/PPC.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.PPC where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_powerpc 1 +#include "CodeGen.Platform.h" + diff --git a/GHC/Platform/Profile.hs b/GHC/Platform/Profile.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Profile.hs @@ -0,0 +1,53 @@ +-- | Platform profiles +module GHC.Platform.Profile + ( Profile (..) + , profileBuildTag + , profileConstants + , profileIsProfiling + , profileWordSizeInBytes + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Ways + +-- | A platform profile fully describes the kind of objects that are generated +-- for a platform. +-- +-- 'Platform' doesn't fully describe the ABI of an object. Compiler ways +-- (profiling, debug, dynamic) also modify the ABI. +-- +data Profile = Profile + { profilePlatform :: !Platform -- ^ Platform + , profileWays :: !Ways -- ^ Ways + } + deriving (Eq, Ord, Show, Read) + +-- | Get platform constants +profileConstants :: Profile -> PlatformConstants +{-# INLINE profileConstants #-} +profileConstants profile = platformConstants (profilePlatform profile) + +-- | Is profiling enabled +profileIsProfiling :: Profile -> Bool +{-# INLINE profileIsProfiling #-} +profileIsProfiling profile = profileWays profile `hasWay` WayProf + +-- | Word size in bytes +profileWordSizeInBytes :: Profile -> Int +{-# INLINE profileWordSizeInBytes #-} +profileWordSizeInBytes profile = platformWordSizeInBytes (profilePlatform profile) + +-- | Unique build tag for the profile +profileBuildTag :: Profile -> String +profileBuildTag profile + -- profiles using unregisterised convention are not binary compatible with + -- those that don't. Make sure to make it apparent in the tag so that our + -- interface files can't be mismatched by mistake. + | platformUnregisterised platform = 'u':wayTag + | otherwise = wayTag + where + platform = profilePlatform profile + wayTag = waysBuildTag (profileWays profile) diff --git a/GHC/Platform/RISCV64.hs b/GHC/Platform/RISCV64.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/RISCV64.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.RISCV64 where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_riscv64 1 +#include "CodeGen.Platform.h" + diff --git a/GHC/Platform/Reg.hs b/GHC/Platform/Reg.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Reg.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE MagicHash #-} + +-- | An architecture independent description of a register. +-- This needs to stay architecture independent because it is used +-- by NCGMonad and the register allocators, which are shared +-- by all architectures. +-- +module GHC.Platform.Reg ( + RegNo, + Reg(..), + regSingle, + realRegSingle, + isRealReg, takeRealReg, + isVirtualReg, takeVirtualReg, + + VirtualReg(..), + renameVirtualReg, + classOfVirtualReg, + getHiVirtualRegFromLo, + getHiVRegFromLo, + + RealReg(..), + regNosOfRealReg, + realRegsAlias, + + liftPatchFnToRegReg +) + +where + +import GHC.Prelude +import GHC.Exts ( Int(I#), dataToTag# ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.Unique +import GHC.Builtin.Uniques +import GHC.Platform.Reg.Class +import qualified GHC.Platform.Reg.Class.Unified as Unified +import qualified GHC.Platform.Reg.Class.Separate as Separate +import qualified GHC.Platform.Reg.Class.NoVectors as NoVectors +import GHC.Platform.ArchOS + +-- | An identifier for a primitive real machine register. +type RegNo + = Int + +-- VirtualRegs are virtual registers. The register allocator will +-- eventually have to map them into RealRegs, or into spill slots. +-- +-- VirtualRegs are allocated on the fly, usually to represent a single +-- value in the abstract assembly code (i.e. dynamic registers are +-- usually single assignment). +-- +-- The single assignment restriction isn't necessary to get correct code, +-- although a better register allocation will result if single +-- assignment is used -- because the allocator maps a VirtualReg into +-- a single RealReg, even if the VirtualReg has multiple live ranges. +-- +-- Virtual regs can be of either class, so that info is attached. +-- +data VirtualReg + -- | Integer virtual register + = VirtualRegI { virtualRegUnique :: {-# UNPACK #-} !Unique } + -- | High part of 2-word virtual register + | VirtualRegHi { virtualRegUnique :: {-# UNPACK #-} !Unique } + -- | Double virtual register + | VirtualRegD { virtualRegUnique :: {-# UNPACK #-} !Unique } + -- | 128-bit wide vector virtual register + | VirtualRegV128 { virtualRegUnique :: {-# UNPACK #-} !Unique } + deriving (Eq, Show) + +-- We can't derive Ord, because Unique doesn't have an Ord instance. +-- Note nonDetCmpUnique in the implementation. See Note [No Ord for Unique]. +-- This is non-deterministic but we do not currently support deterministic +-- code-generation. See Note [Unique Determinism and code generation] +instance Ord VirtualReg where + compare vr1 vr2 = + case compare (I# (dataToTag# vr1)) (I# (dataToTag# vr2)) of + LT -> LT + GT -> GT + EQ -> nonDetCmpUnique (virtualRegUnique vr1) (virtualRegUnique vr2) + +instance Uniquable VirtualReg where + getUnique = virtualRegUnique + +instance Outputable VirtualReg where + ppr reg + = case reg of + VirtualRegI u -> text "%vI_" <> pprUniqueAlways u + VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u + VirtualRegD u -> text "%vDouble_" <> pprUniqueAlways u + VirtualRegV128 u -> text "%vV128_" <> pprUniqueAlways u + + +renameVirtualReg :: Unique -> VirtualReg -> VirtualReg +renameVirtualReg u r = r { virtualRegUnique = u } + +classOfVirtualReg :: Arch -> VirtualReg -> RegClass +classOfVirtualReg arch vr + = case vr of + VirtualRegI{} -> + case regArch of + Unified -> Unified.RcInteger + Separate -> Separate.RcInteger + NoVectors -> NoVectors.RcInteger + VirtualRegHi{} -> + case regArch of + Unified -> Unified.RcInteger + Separate -> Separate.RcInteger + NoVectors -> NoVectors.RcInteger + VirtualRegD{} -> + case regArch of + Unified -> Unified.RcFloatOrVector + Separate -> Separate.RcFloat + NoVectors -> NoVectors.RcFloat + VirtualRegV128{} -> + case regArch of + Unified -> Unified.RcFloatOrVector + Separate -> Separate.RcVector + NoVectors -> pprPanic "classOfVirtualReg VirtualRegV128" + ( text "arch:" <+> text ( show arch ) ) + where + regArch = registerArch arch + +-- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform +-- when supplied with the vreg for the lower-half of the quantity. +-- (NB. Not reversible). +getHiVirtualRegFromLo :: VirtualReg -> VirtualReg +getHiVirtualRegFromLo reg + = case reg of + -- makes a pseudo-unique with tag 'H' + VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') + _ -> panic "Reg.getHiVirtualRegFromLo" + +getHiVRegFromLo :: Reg -> Reg +getHiVRegFromLo reg + = case reg of + RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) + RegReal _ -> panic "Reg.getHiVRegFromLo" + + +------------------------------------------------------------------------------------ +-- | RealRegs are machine regs which are available for allocation, in +-- the usual way. We know what class they are, because that's part of +-- the processor's architecture. +-- +newtype RealReg + = RealRegSingle RegNo + deriving (Eq, Show, Ord) + +instance Uniquable RealReg where + getUnique reg + = case reg of + RealRegSingle i -> mkRegSingleUnique i + +instance Outputable RealReg where + ppr reg + = case reg of + RealRegSingle i -> text "%r" <> int i + +regNosOfRealReg :: RealReg -> [RegNo] +regNosOfRealReg rr + = case rr of + RealRegSingle r1 -> [r1] + + +realRegsAlias :: RealReg -> RealReg -> Bool +realRegsAlias rr1 rr2 = + -- used to be `not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)` + -- but that resulted in some gnarly, gnarly, allocating code. So we manually + -- write out all the cases which gives us nice non-allocating code. + case rr1 of + RealRegSingle r1 -> + case rr2 of RealRegSingle r2 -> r1 == r2 + +-------------------------------------------------------------------------------- +-- | A register, either virtual or real +data Reg + = RegVirtual !VirtualReg + | RegReal !RealReg + deriving (Eq, Ord, Show) + +regSingle :: RegNo -> Reg +regSingle regNo = RegReal (realRegSingle regNo) + +realRegSingle :: RegNo -> RealReg +realRegSingle regNo = RealRegSingle regNo + + +-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets +-- in the register allocator. +instance Uniquable Reg where + getUnique reg + = case reg of + RegVirtual vr -> getUnique vr + RegReal rr -> getUnique rr + +-- | Print a reg in a generic manner +-- If you want the architecture specific names, then use the pprReg +-- function from the appropriate Ppr module. +instance Outputable Reg where + ppr reg + = case reg of + RegVirtual vr -> ppr vr + RegReal rr -> ppr rr + + +isRealReg :: Reg -> Bool +isRealReg reg + = case reg of + RegReal _ -> True + RegVirtual _ -> False + +takeRealReg :: Reg -> Maybe RealReg +takeRealReg reg + = case reg of + RegReal rr -> Just rr + _ -> Nothing + + +isVirtualReg :: Reg -> Bool +isVirtualReg reg + = case reg of + RegReal _ -> False + RegVirtual _ -> True + +takeVirtualReg :: Reg -> Maybe VirtualReg +takeVirtualReg reg + = case reg of + RegReal _ -> Nothing + RegVirtual vr -> Just vr + + +-- | The patch function supplied by the allocator maps VirtualReg to RealReg +-- regs, but sometimes we want to apply it to plain old Reg. +-- +liftPatchFnToRegReg :: (VirtualReg -> RealReg) -> (Reg -> Reg) +liftPatchFnToRegReg patchF reg + = case reg of + RegVirtual vr -> RegReal (patchF vr) + RegReal _ -> reg diff --git a/GHC/Platform/Reg/Class.hs b/GHC/Platform/Reg/Class.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Reg/Class.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE LambdaCase #-} +module GHC.Platform.Reg.Class + ( RegClass (..), RegArch(..), registerArch ) +where + +import GHC.Prelude + +import GHC.Types.Unique +import GHC.Builtin.Uniques ( mkRegClassUnique ) +import GHC.Platform.ArchOS +import GHC.Utils.Outputable ( Outputable(ppr), text ) + + +-- | The class of a register. +-- Used in the register allocator. +-- We treat all registers in a class as being interchangeable. +-- +newtype RegClass = RegClass Int + deriving ( Eq, Ord, Show ) + +instance Uniquable RegClass where + getUnique ( RegClass i ) = mkRegClassUnique i + +-- | This instance is just used for the graph colouring register allocator. +-- Prefer using either 'GHC.Platform.Reg.Class.Separate.pprRegClass' +-- or 'GHC.Platform.Reg.Class.Unified.pprRegClass', which is more informative. +instance Outputable RegClass where + ppr (RegClass i) = ppr i + +-- | The register architecture of a given machine. +data RegArch + -- | Floating-point and vector registers are unified (e.g. X86, AArch64). + = Unified + -- | Floating-point and vector registers are separate (e.g. RISC-V). + | Separate + -- | No vector registers. + | NoVectors + deriving ( Eq, Ord, Show ) + +instance Outputable RegArch where + ppr regArch = text (show regArch) + +-- | What is the register architecture of the given architecture? +registerArch :: Arch -> RegArch +registerArch arch = + case arch of + ArchX86 -> Unified + ArchX86_64 -> Unified + ArchPPC -> Unified + ArchPPC_64 {} -> Unified + ArchAArch64 -> Unified + -- Support for vector registers not yet implemented for RISC-V + -- see panic in `getFreeRegs`. + --ArchRISCV64 -> Separate + ArchRISCV64 -> NoVectors + _ -> NoVectors diff --git a/GHC/Platform/Reg/Class/NoVectors.hs b/GHC/Platform/Reg/Class/NoVectors.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Reg/Class/NoVectors.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Register classes for architectures which don't have any vector registers. +module GHC.Platform.Reg.Class.NoVectors + ( RegClass ( RcInteger, RcFloat ) + , pprRegClass, allRegClasses + ) + +where + +import GHC.Utils.Outputable ( SDoc, text ) +import GHC.Platform.Reg.Class ( RegClass(..) ) + +pattern RcInteger, RcFloat :: RegClass +pattern RcInteger = RegClass 0 +pattern RcFloat = RegClass 1 +{-# COMPLETE RcInteger, RcFloat #-} + +pprRegClass :: RegClass -> SDoc +pprRegClass = \case + RcInteger -> text "I" + RcFloat -> text "F" + +allRegClasses :: [RegClass] +allRegClasses = [RcInteger, RcFloat] diff --git a/GHC/Platform/Reg/Class/Separate.hs b/GHC/Platform/Reg/Class/Separate.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Reg/Class/Separate.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Register classes for architectures which have registers +-- for scalar floating-point values that are separate from all vector registers. +module GHC.Platform.Reg.Class.Separate + ( RegClass ( RcInteger, RcFloat, RcVector ) + , pprRegClass, allRegClasses + ) + +where + +import GHC.Utils.Outputable ( SDoc, text ) +import GHC.Platform.Reg.Class ( RegClass(..) ) + +pattern RcInteger, RcFloat, RcVector :: RegClass +pattern RcInteger = RegClass 0 +pattern RcFloat = RegClass 1 +pattern RcVector = RegClass 2 +{-# COMPLETE RcInteger, RcFloat, RcVector #-} + +pprRegClass :: RegClass -> SDoc +pprRegClass = \case + RcInteger -> text "I" + RcFloat -> text "F" + RcVector -> text "V" + +allRegClasses :: [RegClass] +allRegClasses = [RcInteger, RcFloat, RcVector] diff --git a/GHC/Platform/Reg/Class/Unified.hs b/GHC/Platform/Reg/Class/Unified.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Reg/Class/Unified.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Register classes for architectures which don't have separate registers +-- for scalar floating-point values separate from vector registers. +module GHC.Platform.Reg.Class.Unified + ( RegClass ( RcInteger, RcFloatOrVector ) + , pprRegClass, allRegClasses + ) + +where + +import GHC.Utils.Outputable ( SDoc, text ) +import GHC.Platform.Reg.Class ( RegClass(..) ) + +pattern RcInteger, RcFloatOrVector :: RegClass +pattern RcInteger = RegClass 0 +pattern RcFloatOrVector = RegClass 1 +{-# COMPLETE RcInteger, RcFloatOrVector #-} + +pprRegClass :: RegClass -> SDoc +pprRegClass = \case + RcInteger -> text "I" + RcFloatOrVector -> text "F" + +allRegClasses :: [RegClass] +allRegClasses = [RcInteger, RcFloatOrVector] diff --git a/GHC/Platform/Regs.hs b/GHC/Platform/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Regs.hs @@ -0,0 +1,134 @@ +module GHC.Platform.Regs + (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg) + where + +import GHC.Prelude + +import GHC.Cmm.Expr +import GHC.Platform +import GHC.Platform.Reg + +import qualified GHC.Platform.ARM as ARM +import qualified GHC.Platform.AArch64 as AArch64 +import qualified GHC.Platform.PPC as PPC +import qualified GHC.Platform.S390X as S390X +import qualified GHC.Platform.X86 as X86 +import qualified GHC.Platform.X86_64 as X86_64 +import qualified GHC.Platform.RISCV64 as RISCV64 +import qualified GHC.Platform.Wasm32 as Wasm32 +import qualified GHC.Platform.LA64 as LA64 +import qualified GHC.Platform.NoRegs as NoRegs + +-- | Returns 'True' if this global register is stored in a caller-saves +-- machine register. + +callerSaves :: Platform -> GlobalReg -> Bool +callerSaves platform + | platformUnregisterised platform = NoRegs.callerSaves + | otherwise + = case platformArch platform of + ArchX86 -> X86.callerSaves + ArchX86_64 -> X86_64.callerSaves + ArchS390X -> S390X.callerSaves + ArchARM {} -> ARM.callerSaves + ArchAArch64 -> AArch64.callerSaves + ArchRISCV64 -> RISCV64.callerSaves + ArchWasm32 -> Wasm32.callerSaves + ArchLoongArch64 -> LA64.callerSaves + arch + | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> + PPC.callerSaves + + | otherwise -> NoRegs.callerSaves + +-- | Here is where the STG register map is defined for each target arch. +-- The order matters (for the llvm backend anyway)! We must make sure to +-- maintain the order here with the order used in the LLVM calling conventions. +-- Note that also, this isn't all registers, just the ones that are currently +-- possibly mapped to real registers. +activeStgRegs :: Platform -> [GlobalReg] +activeStgRegs platform + | platformUnregisterised platform = NoRegs.activeStgRegs + | otherwise + = case platformArch platform of + ArchX86 -> X86.activeStgRegs + ArchX86_64 -> X86_64.activeStgRegs + ArchS390X -> S390X.activeStgRegs + ArchARM {} -> ARM.activeStgRegs + ArchAArch64 -> AArch64.activeStgRegs + ArchRISCV64 -> RISCV64.activeStgRegs + ArchWasm32 -> Wasm32.activeStgRegs + ArchLoongArch64 -> LA64.activeStgRegs + arch + | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> + PPC.activeStgRegs + + | otherwise -> NoRegs.activeStgRegs + +haveRegBase :: Platform -> Bool +haveRegBase platform + | platformUnregisterised platform = NoRegs.haveRegBase + | otherwise + = case platformArch platform of + ArchX86 -> X86.haveRegBase + ArchX86_64 -> X86_64.haveRegBase + ArchS390X -> S390X.haveRegBase + ArchARM {} -> ARM.haveRegBase + ArchAArch64 -> AArch64.haveRegBase + ArchRISCV64 -> RISCV64.haveRegBase + ArchWasm32 -> Wasm32.haveRegBase + ArchLoongArch64 -> LA64.haveRegBase + arch + | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> + PPC.haveRegBase + + | otherwise -> NoRegs.haveRegBase + +globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg +globalRegMaybe platform + | platformUnregisterised platform = NoRegs.globalRegMaybe + | otherwise + = case platformArch platform of + ArchX86 -> X86.globalRegMaybe + ArchX86_64 -> X86_64.globalRegMaybe + ArchS390X -> S390X.globalRegMaybe + ArchARM {} -> ARM.globalRegMaybe + ArchAArch64 -> AArch64.globalRegMaybe + ArchRISCV64 -> RISCV64.globalRegMaybe + ArchWasm32 -> Wasm32.globalRegMaybe + ArchLoongArch64 -> LA64.globalRegMaybe + arch + | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> + PPC.globalRegMaybe + + | otherwise -> NoRegs.globalRegMaybe + +freeReg :: Platform -> RegNo -> Bool +freeReg platform + | platformUnregisterised platform = NoRegs.freeReg + | otherwise + = case platformArch platform of + ArchX86 -> X86.freeReg + ArchX86_64 -> X86_64.freeReg + ArchS390X -> S390X.freeReg + ArchARM {} -> ARM.freeReg + ArchAArch64 -> + -- See Note [Aarch64 Register x18 at Darwin and Windows]. + -- It already has `freeReg 18 = False` but that line does not work for cross-compile when + -- we use host not from the list (darwin_HOST_OS, ios_HOST_OS, mingw32_HOST_OS) i.e. Linux + if platformOS platform == OSMinGW32 || platformOS platform == OSDarwin + then + let + x18Check :: RegNo -> Bool + x18Check 18 = False + x18Check a = AArch64.freeReg a + in x18Check + else AArch64.freeReg + ArchRISCV64 -> RISCV64.freeReg + ArchWasm32 -> Wasm32.freeReg + ArchLoongArch64 -> LA64.freeReg + arch + | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> + PPC.freeReg + + | otherwise -> NoRegs.freeReg diff --git a/GHC/Platform/S390X.hs b/GHC/Platform/S390X.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/S390X.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.S390X where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_s390x 1 +#include "CodeGen.Platform.h" + diff --git a/GHC/Platform/Wasm32.hs b/GHC/Platform/Wasm32.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Wasm32.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.Wasm32 where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_wasm32 1 +#include "CodeGen.Platform.h" diff --git a/GHC/Platform/Ways.hs b/GHC/Platform/Ways.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Ways.hs @@ -0,0 +1,259 @@ + +-- | Ways +-- +-- The central concept of a "way" is that all objects in a given +-- program must be compiled in the same "way". Certain options change +-- parameters of the virtual machine, eg. profiling adds an extra word +-- to the object header, so profiling objects cannot be linked with +-- non-profiling objects. +-- +-- After parsing the command-line options, we determine which "way" we +-- are building - this might be a combination way, eg. profiling+threaded. +-- +-- There are two kinds of ways: +-- - RTS only: only affect the runtime system (RTS) and don't affect code +-- generation (e.g. threaded, debug) +-- - Full ways: affect code generation and the RTS (e.g. profiling, dynamic +-- linking) +-- +-- We then find the "build-tag" associated with this way, and this +-- becomes the suffix used to find .hi files and libraries used in +-- this compilation. +module GHC.Platform.Ways + ( Way(..) + , Ways + , hasWay + , hasNotWay + , addWay + , removeWay + , allowed_combination + , wayGeneralFlags + , wayUnsetGeneralFlags + , wayOptc + , wayOptcxx + , wayOptl + , wayOptP + , wayDesc + , wayRTSOnly + , wayTag + , waysTag + , waysBuildTag + , fullWays + , rtsWays + -- * Host GHC ways + , hostWays + , hostFullWays + , hostIsProfiled + , hostIsDynamic + , hostIsThreaded + , hostIsDebugged + , hostIsTracing + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Driver.Flags + +import qualified Data.Set as Set +import Data.Set (Set) +import Data.List (intersperse) + +-- | A way +-- +-- Don't change the constructor order as it is used by `waysTag` to create a +-- unique tag (e.g. thr_debug_p) which is expected by other tools (e.g. Cabal). +data Way + = WayCustom String -- ^ for GHC API clients building custom variants + | WayThreaded -- ^ (RTS only) Multithreaded runtime system + | WayDebug -- ^ Debugging, enable trace messages and extra checks + | WayProf -- ^ Profiling, enable cost-centre stacks and profiling reports + | WayDyn -- ^ Dynamic linking + deriving (Eq, Ord, Show, Read) + +type Ways = Set Way + +-- | Test if a way is enabled +hasWay :: Ways -> Way -> Bool +hasWay ws w = Set.member w ws + +-- | Test if a way is not enabled +hasNotWay :: Ways -> Way -> Bool +hasNotWay ws w = Set.notMember w ws + +-- | Add a way +addWay :: Way -> Ways -> Ways +addWay = Set.insert + +-- | Remove a way +removeWay :: Way -> Ways -> Ways +removeWay = Set.delete + +-- | Check if a combination of ways is allowed +allowed_combination :: Ways -> Bool +allowed_combination ways = not disallowed + where + disallowed = or [ hasWay ways x && hasWay ways y + | (x,y) <- couples + ] + -- List of disallowed couples of ways + couples = [] -- we don't have any disallowed combination of ways nowadays + +-- | Unique tag associated to a list of ways +waysTag :: Ways -> String +waysTag = concat . intersperse "_" . map wayTag . Set.toAscList + +-- | Unique build-tag associated to a list of ways +-- +-- RTS only ways are filtered out because they have no impact on the build. +waysBuildTag :: Ways -> String +waysBuildTag ws = waysTag (Set.filter (not . wayRTSOnly) ws) + + +-- | Unique build-tag associated to a way +wayTag :: Way -> String +wayTag (WayCustom xs) = xs +wayTag WayThreaded = "thr" +wayTag WayDebug = "debug" +wayTag WayDyn = "dyn" +wayTag WayProf = "p" + +-- | Return true for ways that only impact the RTS, not the generated code +wayRTSOnly :: Way -> Bool +wayRTSOnly (WayCustom {}) = False +wayRTSOnly WayDyn = False +wayRTSOnly WayProf = False +wayRTSOnly WayThreaded = True +wayRTSOnly WayDebug = True + +-- | Filter ways that have an impact on compilation +fullWays :: Ways -> Ways +fullWays ws = Set.filter (not . wayRTSOnly) ws + +-- | Filter RTS-only ways (ways that don't have an impact on compilation) +rtsWays :: Ways -> Ways +rtsWays ws = Set.filter wayRTSOnly ws + +wayDesc :: Way -> String +wayDesc (WayCustom xs) = xs +wayDesc WayThreaded = "Threaded" +wayDesc WayDebug = "Debug" +wayDesc WayDyn = "Dynamic" +wayDesc WayProf = "Profiling" + +-- | Turn these flags on when enabling this way +wayGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayGeneralFlags _ (WayCustom {}) = [] +wayGeneralFlags _ WayThreaded = [] +wayGeneralFlags _ WayDebug = [] +wayGeneralFlags _ WayDyn = [Opt_PIC, Opt_ExternalDynamicRefs] + -- We could get away without adding -fPIC when compiling the + -- modules of a program that is to be linked with -dynamic; the + -- program itself does not need to be position-independent, only + -- the libraries need to be. HOWEVER, GHCi links objects into a + -- .so before loading the .so using the system linker. Since only + -- PIC objects can be linked into a .so, we have to compile even + -- modules of the main program with -fPIC when using -dynamic. +wayGeneralFlags _ WayProf = [] + +-- | Turn these flags off when enabling this way +wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayUnsetGeneralFlags _ (WayCustom {}) = [] +wayUnsetGeneralFlags _ WayThreaded = [] +wayUnsetGeneralFlags _ WayDebug = [] +wayUnsetGeneralFlags _ WayDyn = [Opt_SplitSections] + -- There's no point splitting when we're going to be dynamically linking. + -- Plus it breaks compilation on OSX x86. +wayUnsetGeneralFlags _ WayProf = [] + +-- | Pass these options to the C compiler when enabling this way +wayOptc :: Platform -> Way -> [String] +wayOptc _ (WayCustom {}) = [] +wayOptc platform WayThreaded = case platformOS platform of + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptc _ WayDebug = [] +wayOptc _ WayDyn = [] +wayOptc _ WayProf = ["-DPROFILING"] + +wayOptcxx :: Platform -> Way -> [String] +wayOptcxx = wayOptc -- Use the same flags as C + +-- | Pass these options to linker when enabling this way +wayOptl :: Platform -> Way -> [String] +wayOptl _ (WayCustom {}) = [] +wayOptl platform WayThreaded = + case platformOS platform of + -- N.B. FreeBSD cc throws a warning if we pass -pthread without + -- actually using any pthread symbols. + OSFreeBSD -> ["-pthread", "-Wno-unused-command-line-argument"] + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptl _ WayDebug = [] +wayOptl _ WayDyn = [] +wayOptl _ WayProf = [] + +-- | Pass these options to the preprocessor when enabling this way +wayOptP :: Platform -> Way -> [String] +wayOptP _ (WayCustom {}) = [] +wayOptP _ WayThreaded = [] +wayOptP _ WayDebug = [] +wayOptP _ WayDyn = [] +wayOptP _ WayProf = ["-DPROFILING"] + + +-- | Consult the RTS to find whether it has been built with profiling enabled. +hostIsProfiled :: Bool +hostIsProfiled = rtsIsProfiled_ /= 0 + +foreign import ccall unsafe "rts_isProfiled" rtsIsProfiled_ :: Int + +-- | Consult the RTS to find whether GHC itself has been built with +-- dynamic linking. This can't be statically known at compile-time, +-- because we build both the static and dynamic versions together with +-- -dynamic-too. +hostIsDynamic :: Bool +hostIsDynamic = rtsIsDynamic_ /= 0 + +foreign import ccall unsafe "rts_isDynamic" rtsIsDynamic_ :: Int + + +-- | Consult the RTS to find whether it is threaded. +hostIsThreaded :: Bool +hostIsThreaded = rtsIsThreaded_ /= 0 + +foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int + +-- | Consult the RTS to find whether it is debugged. +hostIsDebugged :: Bool +hostIsDebugged = rtsIsDebugged_ /= 0 + +foreign import ccall unsafe "rts_isDebugged" rtsIsDebugged_ :: Int + +-- | Consult the RTS to find whether it is tracing. +hostIsTracing :: Bool +hostIsTracing = rtsIsTracing_ /= 0 + +foreign import ccall unsafe "rts_isTracing" rtsIsTracing_ :: Int + + + + +-- | Host ways. +hostWays :: Ways +hostWays = Set.unions + [ if hostIsDynamic then Set.singleton WayDyn else Set.empty + , if hostIsProfiled then Set.singleton WayProf else Set.empty + , if hostIsThreaded then Set.singleton WayThreaded else Set.empty + , if hostIsDebugged then Set.singleton WayDebug else Set.empty + ] + +-- | Host "full" ways (i.e. ways that have an impact on the compilation, +-- not RTS only ways). +-- +-- These ways must be used when compiling codes targeting the internal +-- interpreter. +hostFullWays :: Ways +hostFullWays = fullWays hostWays diff --git a/GHC/Platform/X86.hs b/GHC/Platform/X86.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/X86.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.X86 where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_i386 1 +#include "CodeGen.Platform.h" + diff --git a/GHC/Platform/X86_64.hs b/GHC/Platform/X86_64.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/X86_64.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.X86_64 where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_x86_64 1 +#include "CodeGen.Platform.h" + diff --git a/GHC/Plugins.hs b/GHC/Plugins.hs new file mode 100644 --- /dev/null +++ b/GHC/Plugins.hs @@ -0,0 +1,217 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-} + +-- | This module is not used by GHC itself. Rather, it exports all of +-- the functions and types you are likely to need when writing a +-- plugin for GHC. So authors of plugins can probably get away simply +-- with saying "import GHC.Plugins". +-- +-- Particularly interesting modules for plugin writers include +-- "GHC.Core" and "GHC.Core.Opt.Monad". +module GHC.Plugins + ( module GHC.Driver.Plugins + , module GHC.Types.Name.Reader + , module GHC.Types.Name.Occurrence + , module GHC.Types.Name + , module GHC.Types.Var + , module GHC.Types.Id + , module GHC.Types.Id.Info + , module GHC.Types.PkgQual + , module GHC.Core.Opt.Monad + , module GHC.Core.Opt.Pipeline.Types + , module GHC.Core.Opt.Stats + , module GHC.Core + , module GHC.Types.Literal + , module GHC.Core.DataCon + , module GHC.Core.Utils + , module GHC.Core.Make + , module GHC.Core.FVs + , module GHC.Core.Subst + , module GHC.Core.Rules + , module GHC.Types.Annotations + , module GHC.Driver.Session + , module GHC.Driver.Ppr + , module GHC.Unit.State + , module GHC.Unit.Module + , module GHC.Unit.Home + , module GHC.Core.Type + , module GHC.Core.TyCon + , module GHC.Core.Coercion + , module GHC.Builtin.Types + , module GHC.Driver.Env + , module GHC.Types.Basic + , module GHC.Types.Var.Set + , module GHC.Types.Var.Env + , module GHC.Types.Name.Set + , module GHC.Types.Name.Env + , module GHC.Types.Unique + , module GHC.Types.Unique.Set + , module GHC.Types.Unique.FM + , module GHC.Data.FiniteMap + , module GHC.Utils.Misc + , module GHC.Serialized + , module GHC.Types.SrcLoc + , module GHC.Utils.Outputable + , module GHC.Utils.Panic + , module GHC.Types.Unique.Supply + , module GHC.Data.FastString + , module GHC.Tc.Errors.Hole.FitTypes -- for hole-fit plugins + , module GHC.Tc.Errors.Hole.Plugin -- for hole-fit plugins + , module GHC.Unit.Module.ModGuts + , module GHC.Unit.Module.ModSummary + , module GHC.Unit.Module.ModIface + , module GHC.Types.Meta + , module GHC.Types.SourceError + , module GHC.Parser.Errors.Types + , module GHC.Types.Error + , module GHC.Hs + , -- * Getting 'Name's + thNameToGhcName + , thNameToGhcNameIO + ) +where + +-- Plugin stuff itself +import GHC.Driver.Plugins + +-- Variable naming +import GHC.Types.TyThing +import GHC.Types.PkgQual +import GHC.Types.SourceError +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence hiding ( varName {- conflicts with Var.varName -} ) +import GHC.Types.Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) +import GHC.Types.Var +import GHC.Types.Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} ) +import GHC.Types.Id.Info + +-- Core +import GHC.Core.Opt.Monad +import GHC.Core.Opt.Pipeline.Types +import GHC.Core.Opt.Stats +import GHC.Core +import GHC.Types.Literal +import GHC.Core.DataCon +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Core.FVs +import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst, extendSubstInScopeSet ) + -- These names are also exported by Type + +import GHC.Core.Rules +import GHC.Types.Annotations +import GHC.Types.Meta + +import GHC.Driver.Session +import GHC.Unit.State + +import GHC.Unit.Home +import GHC.Unit.Module +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -} + ( substTy, extendTvSubst, extendTvSubstList, isInScope ) +import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -} + ( substCo ) +import GHC.Core.TyCon +import GHC.Builtin.Types +import GHC.Driver.Env +import GHC.Types.Basic + +-- Collections and maps +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +-- Conflicts with UniqFM: +--import LazyUniqFM +import GHC.Data.FiniteMap + +-- Common utilities +import GHC.Utils.Misc +import GHC.Serialized +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Driver.Ppr +import GHC.Types.Unique.Supply +import GHC.Types.Unique ( Unique, Uniquable(..) ) +import GHC.Data.FastString +import Data.Maybe + +import GHC.Iface.Env ( lookupNameCache ) +import GHC.Prelude +import GHC.Utils.Monad ( mapMaybeM ) +import GHC.ThToHs ( thRdrNameGuesses ) +import GHC.Tc.Utils.Env ( lookupGlobal ) +import GHC.Types.Name.Cache ( NameCache ) + +import GHC.Tc.Errors.Hole.FitTypes +import GHC.Tc.Errors.Hole.Plugin + +-- For parse result plugins +import GHC.Parser.Errors.Types ( PsWarning, PsError ) +import GHC.Types.Error ( Messages ) +import GHC.Hs ( HsParsedModule ) + +import qualified GHC.Boot.TH.Syntax as TH + +{- This instance is defined outside GHC.Core.Opt.Monad so that + GHC.Core.Opt.Monad does not depend on GHC.Tc.Utils.Env -} +instance MonadThings CoreM where + lookupThing name = do { hsc_env <- getHscEnv + ; liftIO $ lookupGlobal hsc_env name } + +{- +************************************************************************ +* * + Template Haskell interoperability +* * +************************************************************************ +-} + +-- | Attempt to convert a Template Haskell name to one that GHC can +-- understand. Original TH names such as those you get when you use +-- the @'foo@ syntax will be translated to their equivalent GHC name +-- exactly. Qualified or unqualified TH names will be dynamically bound +-- to names in the module being compiled, if possible. Exact TH names +-- will be bound to the name they represent, exactly. +thNameToGhcName :: TH.Name -> CoreM (Maybe Name) +thNameToGhcName th_name = do + hsc_env <- getHscEnv + liftIO $ thNameToGhcNameIO (hsc_NC hsc_env) th_name + +-- | Attempt to convert a Template Haskell name to one that GHC can +-- understand. Original TH names such as those you get when you use +-- the @'foo@ syntax will be translated to their equivalent GHC name +-- exactly. Qualified or unqualified TH names will be dynamically bound +-- to names in the module being compiled, if possible. Exact TH names +-- will be bound to the name they represent, exactly. +-- +-- One must be careful to consistently use the same 'NameCache' to +-- create identifier that might be compared. (C.f. how the +-- 'Control.Monad.ST.ST' Monad enforces that variables from separate +-- 'Control.Monad.ST.runST' invocations are never intermingled; it would +-- be valid to use the same tricks for 'Name's and 'NameCache's.) +-- +-- For now, the easiest and recommended way to ensure a consistent +-- 'NameCache' is used it to retrieve the preexisting one from an active +-- 'HscEnv'. A single 'HscEnv' is created per GHC "session", and this +-- ensures everything in that session will get the same name cache. +thNameToGhcNameIO :: NameCache -> TH.Name -> IO (Maybe Name) +thNameToGhcNameIO cache th_name + = do { let listTuplePuns = True -- conservative assumption + ; names <- mapMaybeM lookup (thRdrNameGuesses listTuplePuns th_name) + -- Pick the first that works + -- E.g. reify (mkName "A") will pick the class A in preference + -- to the data constructor A + ; return (listToMaybe names) } + where + lookup rdr_name + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = return $ if isExternalName n then Just n else Nothing + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = Just <$> lookupNameCache cache rdr_mod rdr_occ + | otherwise = return Nothing diff --git a/GHC/Prelude.hs b/GHC/Prelude.hs new file mode 100644 --- /dev/null +++ b/GHC/Prelude.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude] + +-- | Custom GHC "Prelude" +-- +-- This module serves as a replacement for the "Prelude" module +-- and abstracts over differences between the bootstrapping +-- GHC version, and may also provide a common default vocabulary. + +-- Every module in GHC +-- * Is compiled with -XNoImplicitPrelude +-- * Explicitly imports GHC.Prelude + +module GHC.Prelude + (module GHC.Prelude + ,module GHC.Utils.Trace + ) where + + +{- Note [-O2 Prelude] +~~~~~~~~~~~~~~~~~~~~~ +There is some code in GHC that is *always* compiled with -O[2] because +of it's impact on compile time performance. Some of this code might depend +on the definitions like shiftL being defined here being performant. + +So we always compile this module with -O2. It's (currently) tiny so I +have little reason to suspect this impacts overall GHC compile times +negatively. + +-} +-- We export the 'Semigroup' class but w/o the (<>) operator to avoid +-- clashing with the (Outputable.<>) operator which is heavily used +-- through GHC's code-base. + +{- +Note [Why do we import Prelude here?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The files ghc-boot-th.cabal, ghc-boot.cabal, ghci.cabal and +ghc-heap.cabal contain the directive default-extensions: +NoImplicitPrelude. There are two motivations for this: + - Consistency with the compiler directory, which enables + NoImplicitPrelude; + - Allows loading the above dependent packages with ghc-in-ghci, + giving a smoother development experience when adding new + extensions. +-} + +import GHC.Prelude.Basic as GHC.Prelude + +-- import {-# SOURCE #-} GHC.Utils.Trace +import GHC.Utils.Trace hiding ( trace ) diff --git a/GHC/Prelude/Basic.hs b/GHC/Prelude/Basic.hs new file mode 100644 --- /dev/null +++ b/GHC/Prelude/Basic.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude] + +-- See Note [Proxies for head and tail] +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} + +-- | Custom minimal GHC "Prelude" +-- +-- This module serves as a replacement for the "Prelude" module +-- and abstracts over differences between the bootstrapping +-- GHC version, and may also provide a common default vocabulary. + +-- Every module in GHC +-- * Is compiled with -XNoImplicitPrelude +-- * Explicitly imports GHC.Prelude.Basic or GHC.Prelude +-- * The later provides some functionality with within ghc itself +-- like pprTrace. + +module GHC.Prelude.Basic + ( module X + , Applicative (..) + , module Bits + , bit + , shiftL, shiftR + , setBit, clearBit + , head, tail, unzip + + , strictGenericLength + ) where + + +{- Note [-O2 Prelude] +~~~~~~~~~~~~~~~~~~~~~ +There is some code in GHC that is *always* compiled with -O[2] because +of it's impact on compile time performance. Some of this code might depend +on the definitions like shiftL being defined here being performant. + +So we always compile this module with -O2. It's (currently) tiny so I +have little reason to suspect this impacts overall GHC compile times +negatively. + +-} +-- We export the 'Semigroup' class but w/o the (<>) operator to avoid +-- clashing with the (Outputable.<>) operator which is heavily used +-- through GHC's code-base. + +{- +Note [Why do we import Prelude here?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The files ghc-boot-th.cabal, ghc-boot.cabal, ghci.cabal and +ghc-heap.cabal contain the directive default-extensions: +NoImplicitPrelude. There are two motivations for this: + - Consistency with the compiler directory, which enables + NoImplicitPrelude; + - Allows loading the above dependent packages with ghc-in-ghci, + giving a smoother development experience when adding new + extensions. +-} + +import qualified Prelude +import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip) +import Control.Applicative (Applicative(..)) +import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum)) +import Data.Foldable1 as X hiding (head, last) +import qualified Data.List as List +import qualified GHC.Data.List.NonEmpty as NE +import GHC.Stack.Types (HasCallStack) + +import GHC.Bits as Bits hiding (bit, shiftL, shiftR, setBit, clearBit) +# if defined(DEBUG) +import qualified GHC.Bits as Bits (shiftL, shiftR) +# endif + + +{- Note [Default to unsafe shifts inside GHC] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The safe shifts can introduce branches which come +at the cost of performance. We still want the additional +debuggability for debug builds. So we define it as one or the +other depending on the DEBUG setting. + +Why do we then continue on to re-export the rest of Data.Bits? +If we would not what is likely to happen is: +* Someone imports Data.Bits, uses xor. Things are fine. +* They add a shift and get an ambiguous definition error. +* The are puzzled for a bit. +* They either: + + Remove the import of Data.Bits and get an error because xor is not in scope. + + Add the hiding clause to the Data.Bits import for the shifts. + +Either is quite annoying. Simply re-exporting all of Data.Bits avoids this +making for a smoother developer experience. At the cost of having a few more +names in scope at all time. But that seems like a fair tradeoff. + +See also #19618 +-} + +-- We always want the Data.Bits method to show up for rules etc. +{-# INLINE shiftL #-} +{-# INLINE shiftR #-} +shiftL, shiftR :: Bits.Bits a => a -> Int -> a +#if defined(DEBUG) +shiftL = Bits.shiftL +shiftR = Bits.shiftR +#else +shiftL = Bits.unsafeShiftL +shiftR = Bits.unsafeShiftR +#endif + +{-# INLINE bit #-} +bit :: (Num a, Bits.Bits a) => Int -> a +bit = \ i -> 1 `shiftL` i +{-# INLINE setBit #-} +setBit :: (Num a, Bits.Bits a) => a -> Int -> a +setBit = \ x i -> x Bits..|. bit i +{-# INLINE clearBit #-} +clearBit :: (Num a, Bits.Bits a) => a -> Int -> a +clearBit = \ x i -> x Bits..&. Bits.complement (bit i) + +{- Note [Proxies for head and tail] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-}, +but the GHC codebase uses them fairly extensively and insists on building warning-free. +Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which +employs them, we define warning-less proxies and export them from GHC.Prelude. +-} + +-- See Note [Proxies for head and tail] +head :: HasCallStack => [a] -> a +head = Prelude.head +{-# INLINE head #-} + +-- See Note [Proxies for head and tail] +tail :: HasCallStack => [a] -> [a] +tail = Prelude.tail +{-# INLINE tail #-} + +{- | +The 'genericLength' function defined in base can't be specialised due to the +NOINLINE pragma. + +It is also not strict in the accumulator, and strictGenericLength is not exported. + +See #25706 for why it is important to use a strict, specialised version. + +-} +strictGenericLength :: Num a => [x] -> a +strictGenericLength = fromIntegral . length + +-- This is `Data.Functor.unzip`. Unfortunately, that function lacks the RULES for specialization. +unzip :: Functor f => f (a, b) -> (f a, f b) +unzip = \ xs -> (fmap fst xs, fmap snd xs) +{-# NOINLINE [1] unzip #-} +{-# RULES "unzip/List" unzip = List.unzip #-} +{-# RULES "unzip/NonEmpty" unzip = NE.unzip #-} diff --git a/GHC/Rename/Bind.hs b/GHC/Rename/Bind.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Bind.hs @@ -0,0 +1,1547 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Renaming and dependency analysis of bindings + +This module does renaming and dependency analysis on value bindings in +the abstract syntax. It does {\em not} do cycle-checks on class or +type-synonym declarations; those cannot be done at this stage because +they may be affected by renaming (which isn't fully worked out yet). +-} + +module GHC.Rename.Bind ( + -- Renaming top-level bindings + rnTopBindsLHS, rnTopBindsLHSBoot, rnTopBindsBoot, rnValBindsRHS, + + -- Renaming local bindings + rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, + + -- Other bindings + rnMethodBinds, renameSigs, bindRuleBndrs, + rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl, + makeMiniFixityEnv, MiniFixityEnv, emptyMiniFixityEnv, + HsSigCtxt(..), + + -- Utility for hs-boot files + rejectBootDecls, + + -- Utility for COMPLETE pragmas + localCompletePragmas + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Rename.Expr( rnExpr, rnLExpr, rnStmts ) + +import GHC.Hs +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Rename.HsType +import GHC.Rename.Pat +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils +import GHC.Driver.DynFlags + +import GHC.Data.BooleanFormula ( bfTraverse ) +import GHC.Data.Graph.Directed ( SCC(..) ) +import GHC.Data.Maybe ( orElse, mapMaybe ) +import GHC.Data.OrdList +import GHC.Data.List.SetOps ( findDupsEq ) + + +import GHC.Types.Error +import GHC.Types.FieldLabel +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.SourceFile +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) ) + +import GHC.Types.CompleteMatch +import GHC.Types.Hint ( SigLike(..) ) +import GHC.Types.Unique.DSet ( mkUniqDSet ) +import GHC.Types.Unique.Set + +import GHC.Unit.Module + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import qualified GHC.LanguageExtensions as LangExt + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.Monad +import Data.List ( partition ) +import Data.List.NonEmpty ( NonEmpty(..) ) + +{- +-- ToDo: Put the annotations into the monad, so that they arrive in the proper +-- place and can be used when complaining. + +The code tree received by the function @rnBinds@ contains definitions +in where-clauses which are all apparently mutually recursive, but which may +not really depend upon each other. For example, in the top level program +\begin{verbatim} +f x = y where a = x + y = x +\end{verbatim} +the definitions of @a@ and @y@ do not depend on each other at all. +Unfortunately, the typechecker cannot always check such definitions. +\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive +definitions. In Proceedings of the International Symposium on Programming, +Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} +However, the typechecker usually can check definitions in which only the +strongly connected components have been collected into recursive bindings. +This is precisely what the function @rnBinds@ does. + +ToDo: deal with case where a single monobinds binds the same variable +twice. + +The vertag tag is a unique @Int@; the tags only need to be unique +within one @MonoBinds@, so that unique-Int plumbing is done explicitly +(heavy monad machinery not needed). + + +************************************************************************ +* * +* naming conventions * +* * +************************************************************************ + +\subsection[name-conventions]{Name conventions} + +The basic algorithm involves walking over the tree and returning a tuple +containing the new tree plus its free variables. Some functions, such +as those walking polymorphic bindings (HsBinds) and qualifier lists in +list comprehensions (@Quals@), return the variables bound in local +environments. These are then used to calculate the free variables of the +expression evaluated in these environments. + +Conventions for variable names are as follows: +\begin{itemize} +\item +new code is given a prime to distinguish it from the old. + +\item +a set of variables defined in @Exp@ is written @dvExp@ + +\item +a set of variables free in @Exp@ is written @fvExp@ +\end{itemize} + +************************************************************************ +* * +* analysing polymorphic bindings (HsBindGroup, HsBind) +* * +************************************************************************ + +\subsubsection[dep-HsBinds]{Polymorphic bindings} + +Non-recursive expressions are reconstructed without any changes at top +level, although their component expressions may have to be altered. +However, non-recursive expressions are currently not expected as +\Haskell{} programs, and this code should not be executed. + +Monomorphic bindings contain information that is returned in a tuple +(a @FlatMonoBinds@) containing: + +\begin{enumerate} +\item +a unique @Int@ that serves as the ``vertex tag'' for this binding. + +\item +the name of a function or the names in a pattern. These are a set +referred to as @dvLhs@, the defined variables of the left hand side. + +\item +the free variables of the body. These are referred to as @fvBody@. + +\item +the definition's actual code. This is referred to as just @code@. +\end{enumerate} + +The function @nonRecDvFv@ returns two sets of variables. The first is +the set of variables defined in the set of monomorphic bindings, while the +second is the set of free variables in those bindings. + +The set of variables defined in a non-recursive binding is just the +union of all of them, as @union@ removes duplicates. However, the +free variables in each successive set of cumulative bindings is the +union of those in the previous set plus those of the newest binding after +the defined variables of the previous set have been removed. + +@rnMethodBinds@ deals only with the declarations in class and +instance declarations. It expects only to see @FunMonoBind@s, and +it expects the global environment to contain bindings for the binders +(which are all class operations). + +************************************************************************ +* * +\subsubsection{ Top-level bindings} +* * +************************************************************************ +-} + +-- for top-level bindings, we need to make top-level names, +-- so we have a different entry point than for local bindings +rnTopBindsLHS :: MiniFixityEnv + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) +rnTopBindsLHS fix_env binds + = rnValBindsLHS (topRecNameMaker fix_env) binds + +-- Ensure that a hs-boot file has no top-level bindings. +rnTopBindsLHSBoot :: MiniFixityEnv + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) +rnTopBindsLHSBoot fix_env binds + = do { topBinds <- rnTopBindsLHS fix_env binds + ; case topBinds of + ValBinds x mbinds sigs -> + do { rejectBootDecls HsBoot BootBindsPs mbinds + ; pure (ValBinds x [] sigs) } + _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) } + +rejectBootDecls :: HsBootOrSig + -> (NonEmpty (LocatedA decl) -> BadBootDecls) + -> [LocatedA decl] + -> TcM () +rejectBootDecls _ _ [] = return () +rejectBootDecls hsc_src what (decl@(L loc _) : decls) + = addErrAt (locA loc) + $ TcRnIllegalHsBootOrSigDecl hsc_src + (what $ decl :| decls) + +rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) +-- A hs-boot file has no bindings. +-- Return a single HsBindGroup with empty binds and renamed signatures +rnTopBindsBoot bound_names (ValBinds _ _ sigs) + = do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs + ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } +rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) + +{- +********************************************************* +* * + HsLocalBinds +* * +********************************************************* +-} + +rnLocalBindsAndThen :: HsLocalBinds GhcPs + -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +-- This version (a) assumes that the binding vars are *not* already in scope +-- (b) removes the binders from the free vars of the thing inside +-- The parser doesn't produce ThenBinds +rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside = + thing_inside (EmptyLocalBinds x) emptyNameSet + +rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside + = rnLocalValBindsAndThen val_binds $ \ val_binds' -> + thing_inside (HsValBinds x val_binds') + +rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do + (binds',fv_binds) <- rnIPBinds binds + (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds + return (thing, fvs_thing `plusFV` fv_binds) + +rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) +rnIPBinds (IPBinds _ ip_binds ) = do + (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstMA rnIPBind) ip_binds + return (IPBinds noExtField ip_binds', plusFVs fvs_s) + +rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) +rnIPBind (IPBind _ n expr) = do + (expr',fvExpr) <- rnLExpr expr + return (IPBind noExtField n expr', fvExpr) + +{- +************************************************************************ +* * + ValBinds +* * +************************************************************************ +-} + +-- Renaming local binding groups +-- Does duplicate/shadow check +rnLocalValBindsLHS :: MiniFixityEnv + -> HsValBinds GhcPs + -> RnM ([Name], HsValBindsLR GhcRn GhcPs) +rnLocalValBindsLHS fix_env binds + = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds + + -- Check for duplicates and shadowing + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in GHC.Hs.Utils + + -- We need to check for dups here because we + -- don't don't bind all of the variables from the ValBinds at once + -- with bindLocatedLocals any more. + -- + -- Note that we don't want to do this at the top level, since + -- sorting out duplicates and shadowing there happens elsewhere. + -- The behavior is even different. For example, + -- import A(f) + -- f = ... + -- should not produce a shadowing warning (but it will produce + -- an ambiguity warning if you use f), but + -- import A(f) + -- g = let f = ... in f + -- should. + ; let bound_names = collectHsValBinders CollNoDictBinders binds' + -- There should be only Ids, but if there are any bogus + -- pattern synonyms, we'll collect them anyway, so that + -- we don't generate subsequent out-of-scope messages + ; envs <- getRdrEnvs + ; checkDupAndShadowedNames envs bound_names + + ; return (bound_names, binds') } + +-- renames the left-hand sides +-- generic version used both at the top level and for local binds +-- does some error checking, but not what gets done elsewhere at the top level +rnValBindsLHS :: NameMaker + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) +rnValBindsLHS topP (ValBinds x mbinds sigs) + = do { mbinds' <- mapM (wrapLocMA (rnBindLHS topP doc)) mbinds + ; return $ ValBinds x mbinds' sigs } + where + bndrs = collectHsBindsBinders CollNoDictBinders mbinds + doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs + +rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) + +-- General version used both from the top-level and for local things +-- Assumes the LHS vars are in scope +-- +-- Does not bind the local fixity declarations +rnValBindsRHS :: HsSigCtxt + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) + +rnValBindsRHS ctxt (ValBinds _ mbinds sigs) + = do { (sigs', sig_fvs) <- renameSigs ctxt sigs + + -- Update the TcGblEnv with renamed COMPLETE pragmas from the current + -- module, for pattern irrefutability checking in do notation. + ; let localCompletePrags = localCompletePragmas sigs' + ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags + , tcg_complete_match_env = tcg_complete_match_env gblEnv ++ localCompletePrags }) $ + do { binds_w_dus <- mapM (rnLBind (mkScopedTvFn sigs')) mbinds + ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus + + ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $ + getPatSynBinds anal_binds + -- The uses in binds_w_dus for PatSynBinds do not include + -- variables used in the patsyn builders; see + -- Note [Pattern synonym builders don't yield dependencies] + -- But psb_fvs /does/ include those builder fvs. So we + -- add them back in here to avoid bogus warnings about + -- unused variables (#12548) + + valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs + `plusDU` usesOnly patsyn_fvs + -- Put the sig uses *after* the bindings + -- so that the binders are removed from + -- the uses in the sigs + + ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } } + +rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) + +-- Wrapper for local binds +-- +-- The *client* of this function is responsible for checking for unused binders; +-- it doesn't (and can't: we don't have the thing inside the binds) happen here +-- +-- The client is also responsible for bringing the fixities into scope +rnLocalValBindsRHS :: NameSet -- names bound by the LHSes + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) +rnLocalValBindsRHS bound_names binds + = rnValBindsRHS (LocalBindCtxt bound_names) binds + +-- for local binds +-- wrapper that does both the left- and right-hand sides +-- +-- here there are no local fixity decls passed in; +-- the local fixity decls come from the ValBinds sigs +rnLocalValBindsAndThen + :: HsValBinds GhcPs + -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside + = do { -- (A) Create the local fixity environment + new_fixities <- makeMiniFixityEnv [ L loc sig + | L loc (FixSig _ sig) <- sigs] + + -- (B) Rename the LHSes + ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds + + -- ...and bring them (and their fixities) into scope + ; bindLocalNamesFV bound_names $ + addLocalFixities new_fixities bound_names $ do + + { -- (C) Do the RHS and thing inside + (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs + ; (result, result_fvs) <- thing_inside binds' (allUses dus) + + -- Report unused bindings based on the (accurate) + -- findUses. E.g. + -- let x = x in 3 + -- should report 'x' unused + ; let real_uses = findUses dus result_fvs + -- Insert fake uses for variables introduced implicitly by + -- wildcards (#4404) + rec_uses = hsValBindsImplicits binds' + implicit_uses = mkNameSet $ concatMap (concatMap implFlBndr_binders . snd) + $ rec_uses + ; mapM_ (\(loc, ns) -> + checkUnusedRecordWildcard loc real_uses (Just ns)) + rec_uses + ; warnUnusedLocalBinds bound_names + (real_uses `unionNameSet` implicit_uses) + + ; let + -- The variables "used" in the val binds are: + -- (1) the uses of the binds (allUses) + -- (2) the FVs of the thing-inside + all_uses = allUses dus `plusFV` result_fvs + -- Note [Unused binding hack] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Note that *in contrast* to the above reporting of + -- unused bindings, (1) above uses duUses to return *all* + -- the uses, even if the binding is unused. Otherwise consider: + -- x = 3 + -- y = let p = x in 'x' -- NB: p not used + -- If we don't "see" the dependency of 'y' on 'x', we may put the + -- bindings in the wrong order, and the type checker will complain + -- that x isn't in scope + -- + -- But note that this means we won't report 'x' as unused, + -- whereas we would if we had { x = 3; p = x; y = 'x' } + + ; return (result, all_uses) }} + -- The bound names are pruned out of all_uses + -- by the bindLocalNamesFV call above + +rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) + + +--------------------- + +-- renaming a single bind + +rnBindLHS :: NameMaker + -> SDoc + -> HsBind GhcPs + -- returns the renamed left-hand side, + -- and the FreeVars *of the LHS* + -- (i.e., any free variables of the pattern) + -> RnM (HsBindLR GhcRn GhcPs) + +rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat, pat_mult = pat_mult }) + = do + -- we don't actually use the FV processing of rnPatsAndThen here + (pat',pat'_fvs) <- rnBindPat name_maker pat + (pat_mult', mult'_fvs) <- rnHsMultAnnWith (rnLHsType PatCtx) pat_mult + return (bind { pat_lhs = pat', pat_ext = pat'_fvs `plusFV` mult'_fvs, pat_mult = pat_mult' }) + -- We temporarily store the pat's FVs in bind_fvs; + -- gets updated to the FVs of the whole bind + -- when doing the RHS below + +rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) + = do { name <- applyNameMaker name_maker rdr_name + ; return (bind { fun_id = name + , fun_ext = noExtField }) } + +rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname }) + | isTopRecNameMaker name_maker + = do { addLocM checkConName rdrname + ; name <- + lookupLocatedTopBndrRnN WL_ConLike rdrname -- Should be in scope already + ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) } + + | otherwise -- Pattern synonym, not at top level + = do { addErr localPatternSynonymErr -- Complain, but make up a fake + -- name so that we can carry on + ; name <- applyNameMaker name_maker rdrname + ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) } + where + localPatternSynonymErr :: TcRnMessage + localPatternSynonymErr = TcRnIllegalPatSynDecl rdrname + +rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) + +rnLBind :: (Name -> [Name]) -- Signature tyvar function + -> LHsBindLR GhcRn GhcPs + -> RnM (LHsBind GhcRn, [Name], Uses) +rnLBind sig_fn (L loc bind) + = setSrcSpanA loc $ + do { (bind', bndrs, dus) <- rnBind sig_fn bind + ; return (L loc bind', bndrs, dus) } + +-- assumes the left-hands-side vars are in scope +rnBind :: (Name -> [Name]) -- Signature tyvar function + -> HsBindLR GhcRn GhcPs + -> RnM (HsBind GhcRn, [Name], Uses) +rnBind _ bind@(PatBind { pat_lhs = pat + , pat_rhs = grhss + -- pat fvs were stored in bind_fvs + -- after processing the LHS + , pat_ext = pat_fvs }) + = do { mod <- getModule + ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss + + -- No scoped type variables for pattern bindings + ; let all_fvs = pat_fvs `plusFV` rhs_fvs + fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan + bndrs = collectPatBinders CollNoDictBinders pat + bind' = bind { pat_rhs = grhss' + , pat_ext = fvs' } + + -- Warn if the pattern binds no variables + -- See Note [Pattern bindings that bind no variables] + ; whenWOptM Opt_WarnUnusedPatternBinds $ + when (null bndrs && not (isOkNoBindPattern pat)) $ + addTcRnDiagnostic (TcRnUnusedPatternBinds bind') + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind', bndrs, all_fvs) } + +rnBind sig_fn bind@(FunBind { fun_id = name + , fun_matches = matches }) + -- invariant: no free vars here when it's a FunBind + = do { let plain_name = unLoc name + + ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + -- bindSigTyVars tests for LangExt.ScopedTyVars + rnMatchGroup (mkPrefixFunRhs name noAnn) + rnLExpr matches + ; let is_infix = isInfixFunBind bind + ; when is_infix $ checkPrecMatch plain_name matches' + + ; mod <- getModule + ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind { fun_matches = matches' + , fun_ext = fvs' }, + [plain_name], rhs_fvs) + } + +rnBind sig_fn (PatSynBind x bind) + = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind + ; return (PatSynBind x bind', name, fvs) } + +rnBind _ (VarBind { var_ext = x }) = dataConCantHappen x + + -- See Note [Pattern bindings that bind no variables] +isOkNoBindPattern :: LPat GhcRn -> Bool +isOkNoBindPattern (L _ pat) = + case pat of + WildPat{} -> True -- Exception (1) + BangPat {} -> True -- Exception (2) #9127, #13646 + p -> patternContainsSplice p -- Exception (3) + + where + lpatternContainsSplice :: LPat GhcRn -> Bool + lpatternContainsSplice (L _ p) = patternContainsSplice p + patternContainsSplice :: Pat GhcRn -> Bool + patternContainsSplice p = + case p of + -- A top-level splice has been evaluated by this point, so we know the pattern it is evaluated to + SplicePat (HsUntypedSpliceTop _ p) _ -> patternContainsSplice p + -- A nested splice isn't evaluated so we can't guess what it will expand to + SplicePat (HsUntypedSpliceNested {}) _ -> True + -- The base cases + VarPat {} -> False + WildPat {} -> False + LitPat {} -> False + NPat {} -> False + NPlusKPat {} -> False + -- Recursive cases + BangPat _ lp -> lpatternContainsSplice lp + LazyPat _ lp -> lpatternContainsSplice lp + AsPat _ _ lp -> lpatternContainsSplice lp + ParPat _ lp -> lpatternContainsSplice lp + ViewPat _ _ lp -> lpatternContainsSplice lp + OrPat _ lps -> any lpatternContainsSplice lps + SigPat _ lp _ -> lpatternContainsSplice lp + ListPat _ lps -> any lpatternContainsSplice lps + TuplePat _ lps _ -> any lpatternContainsSplice lps + SumPat _ lp _ _ -> lpatternContainsSplice lp + ConPat _ _ cpd -> any lpatternContainsSplice (hsConPatArgs cpd) + XPat (HsPatExpanded _orig new) -> patternContainsSplice new + + -- The behavior of this case is unimportant, as GHC will throw an error shortly + -- after reaching this case for other reasons (see TcRnIllegalTypePattern). + EmbTyPat{} -> True + + InvisPat{} -> True + +{- Note [Pattern bindings that bind no variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally, we want to warn about pattern bindings like + Just _ = e +because they don't do anything! But we have three exceptions: + +(1) A wildcard pattern + _ = rhs + which (a) is not that different from _v = rhs + (b) is sometimes used to give a type sig for, + or an occurrence of, a variable on the RHS + +(2) A strict pattern binding; that is, one with an outermost bang + !Just _ = e + This can fail, so unlike the lazy variant, it is not a no-op. + Moreover, #13646 argues that even for single constructor + types, you might want to write the constructor. See also #9127. + +(3) A splice pattern + $(th-lhs) = rhs + It is impossible to determine whether or not th-lhs really + binds any variable. You have to recurse all the way into the pattern to check + it doesn't contain any splices like this. See #22057. + +Note [Free-variable space leak] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have + fvs' = trim fvs +and we seq fvs' before turning it as part of a record. + +The reason is that trim is sometimes something like + \xs -> intersectNameSet (mkNameSet bound_names) xs +and we don't want to retain the list bound_names. This showed up in +ticket #1136. +-} + +{- ********************************************************************* +* * + Dependency analysis and other support functions +* * +********************************************************************* -} + +depAnalBinds :: [(LHsBind GhcRn, [Name], Uses)] + -> ([(RecFlag, LHsBinds GhcRn)], DefUses) +-- Dependency analysis; this is important so that +-- unused-binding reporting is accurate +depAnalBinds binds_w_dus + = (map get_binds sccs, toOL $ map get_du sccs) + where + sccs = depAnal (\(_, defs, _) -> defs) + (\(_, _, uses) -> nonDetEltsUniqSet uses) + -- It's OK to use nonDetEltsUniqSet here as explained in + -- Note [depAnal determinism] in GHC.Types.Name.Env. + binds_w_dus + + get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, [bind]) + get_binds (CyclicSCC binds_w_dus) = (Recursive, [b | (b,_,_) <- binds_w_dus]) + + get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) + get_du (CyclicSCC binds_w_dus) = (Just defs, uses) + where + defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] + uses = unionNameSets [u | (_,_,u) <- binds_w_dus] + +--------------------- +-- Bind the top-level forall'd type variables in the sigs. +-- E.g f :: forall a. a -> a +-- f = rhs +-- The 'a' scopes over the rhs +-- +-- NB: there'll usually be just one (for a function binding) +-- but if there are many, one may shadow the rest; too bad! +-- e.g x :: forall a. [a] -> [a] +-- y :: forall a. [(a,a)] -> a +-- (x,y) = e +-- In e, 'a' will be in scope, and it'll be the one from 'y'! + +mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name]) +-- Return a lookup function that maps an Id Name to the names +-- of the type variables that should scope over its body. +mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` [] + where + env = mkHsSigEnv get_scoped_tvs sigs + + get_scoped_tvs :: LSig GhcRn -> Maybe ([LocatedN Name], [Name]) + -- Returns (binders, scoped tvs for those binders) + get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty)) + = Just (names, hsScopedTvs sig_ty) + get_scoped_tvs (L _ (TypeSig _ names sig_ty)) + = Just (names, hsWcScopedTvs sig_ty) + get_scoped_tvs (L _ (PatSynSig _ names sig_ty)) + = Just (names, hsScopedTvs sig_ty) + get_scoped_tvs _ = Nothing + +-- Process the fixity declarations, making a FastString -> (Located Fixity) map +-- (We keep the location around for reporting duplicate fixity declarations.) +-- +-- Checks for duplicates, but not that only locally defined things are fixed. +-- Note: for local fixity declarations, duplicates would also be checked in +-- check_sigs below. But we also use this function at the top level. + +makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv + +makeMiniFixityEnv decls = foldlM add_one_sig emptyMiniFixityEnv decls + where + add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv + add_one_sig env (L loc (FixitySig ns_spec names fixity)) = + foldlM add_one env [ (locA loc,locA name_loc,name,fixity, ns_spec) + | L name_loc name <- names ] + + add_one env (loc, name_loc, name, fixity, ns_spec) = do + { -- this fixity decl is a duplicate iff + -- the ReaderName's OccName's FastString is already in the env + -- (we only need to check the local fix_env because + -- definitions of non-local will be caught elsewhere) + let { fs = occNameFS (rdrNameOcc name) + ; fix_item = L loc fixity}; + + case search_for_dups ns_spec env fs of + Nothing -> return $ extend_mini_fixity_env ns_spec env fs fix_item + Just (L loc' _) -> do + { setSrcSpan loc $ + addErrAt name_loc (TcRnMultipleFixityDecls loc' name) + ; return env} + } + search_for_dups ns_spec MFE{mfe_data_level_names, mfe_type_level_names} fs + = case ns_spec of + NoNamespaceSpecifier -> case lookupFsEnv mfe_data_level_names fs of + -- We only need to find a single duplicate to emit an error about + -- multiple fixity decls. Therefore, if we find a duplicate in the + -- term-level namespace, then there is no need to look in the type-level namespace. + Nothing -> lookupFsEnv mfe_type_level_names fs + just_dup -> just_dup + TypeNamespaceSpecifier{} -> lookupFsEnv mfe_type_level_names fs + DataNamespaceSpecifier{} -> lookupFsEnv mfe_data_level_names fs + + extend_mini_fixity_env ns_spec env@MFE{mfe_data_level_names, mfe_type_level_names} fs fix_item + = case ns_spec of + NoNamespaceSpecifier -> MFE { mfe_data_level_names = (extendFsEnv mfe_data_level_names fs fix_item) + , mfe_type_level_names = (extendFsEnv mfe_type_level_names fs fix_item)} + + TypeNamespaceSpecifier{} -> env { mfe_type_level_names = (extendFsEnv mfe_type_level_names fs fix_item)} + + DataNamespaceSpecifier{} -> env { mfe_data_level_names = (extendFsEnv mfe_data_level_names fs fix_item)} + +{- ********************************************************************* +* * + Pattern synonym bindings +* * +********************************************************************* -} + +rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function + -> PatSynBind GhcRn GhcPs + -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses) +rnPatSynBind sig_fn bind@(PSB { psb_id = L l name + , psb_args = details + , psb_def = pat + , psb_dir = dir }) + -- invariant: no free vars here when it's a FunBind + = do { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms + ; unless pattern_synonym_ok (addErr TcRnIllegalPatternSynonymDecl) + ; let scoped_tvs = sig_fn name + + ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $ + rnPat PatSyn pat $ \pat' -> + -- We check the 'RdrName's instead of the 'Name's + -- so that the binding locations are reported + -- from the left-hand side + case details of + PrefixCon vars -> + do { checkDupRdrNames vars + ; names <- mapM lookupPatSynBndr vars + ; return ( (pat', PrefixCon names) + , mkFVs (map unLoc names)) } + InfixCon var1 var2 -> + do { checkDupRdrNames [var1, var2] + ; name1 <- lookupPatSynBndr var1 + ; name2 <- lookupPatSynBndr var2 + -- ; checkPrecMatch -- TODO + ; return ( (pat', InfixCon name1 name2) + , mkFVs (map unLoc [name1, name2])) } + RecCon vars -> + do { checkDupRdrNames (map (foLabel . recordPatSynField) vars) + ; fls <- lookupConstructorFields $ noUserRdr name + ; let fld_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ] + ; let rnRecordPatSynField + (RecordPatSynField { recordPatSynField = visible + , recordPatSynPatVar = hidden }) + = do { let visible' = lookupField fld_env visible + ; hidden' <- lookupPatSynBndr hidden + ; return $ RecordPatSynField { recordPatSynField = visible' + , recordPatSynPatVar = hidden' } } + ; names <- mapM rnRecordPatSynField vars + ; return ( (pat', RecCon names) + , mkFVs (map (unLoc . recordPatSynPatVar) names)) } + + ; (dir', fvs2) <- case dir of + Unidirectional -> return (Unidirectional, emptyFVs) + ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) + ExplicitBidirectional mg -> + do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $ + rnMatchGroup (mkPrefixFunRhs (L l name) noAnn) + rnLExpr mg + ; return (ExplicitBidirectional mg', fvs) } + + ; mod <- getModule + ; let fvs = fvs1 `plusFV` fvs2 + fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan + + bind' = bind{ psb_args = details' + , psb_def = pat' + , psb_dir = dir' + , psb_ext = fvs' } + selector_names = case details' of + RecCon names -> + map (unLoc . foLabel . recordPatSynField) names + _ -> [] + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind', name : selector_names , fvs1) + -- Why fvs1? See Note [Pattern synonym builders don't yield dependencies] + } + where + -- See Note [Renaming pattern synonym variables] + lookupPatSynBndr = wrapLocMA lookupLocalOccRn + + +{- +Note [Renaming pattern synonym variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We rename pattern synonym declarations backwards to normal to reuse +the logic already implemented for renaming patterns. + +We first rename the RHS of a declaration which brings into +scope the variables bound by the pattern (as they would be +in normal function definitions). We then lookup the variables +which we want to bind in this local environment. + +It is crucial that we then only lookup in the *local* environment which +only contains the variables brought into scope by the pattern and nothing +else. Amazingly no-one encountered this bug for 3 GHC versions but +it was possible to define a pattern synonym which referenced global +identifiers and worked correctly. + +``` +x = 5 + +pattern P :: Int -> () +pattern P x <- _ + +f (P x) = x + +> f () = 5 +``` + +See #13470 for the original report. + +Note [Pattern synonym builders don't yield dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a pattern synonym that has an explicit builder, +references in the builder definition should not be used when +calculating dependencies. For example, consider the following pattern +synonym definition: + +pattern P x <- C1 x where + P x = f (C1 x) + +f (P x) = C2 x + +In this case, 'P' needs to be typechecked in two passes: + +1. Typecheck the pattern definition of 'P', which fully determines the + type of 'P'. This step doesn't require knowing anything about 'f', + since the builder definition is not looked at. + +2. Typecheck the builder definition, which needs the typechecked + definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind + in GHC.Tc.Gen.Bind.tcValBinds. + +This behaviour is implemented in 'tcValBinds', but it crucially +depends on 'P' not being put in a recursive group with 'f' (which +would make it look like a recursive pattern synonym a la 'pattern P = +P' which is unsound and rejected). + +So: + * We do not include builder fvs in the Uses returned by rnPatSynBind + (which is then used for dependency analysis) + * But we /do/ include them in the psb_fvs for the PatSynBind + * In rnValBinds we record these builder uses, to avoid bogus + unused-variable warnings (#12548) +-} + +{- ********************************************************************* +* * + Class/instance method bindings +* * +********************************************************************* -} + +{- @rnMethodBinds@ is used for the method bindings of a class and an instance +declaration. Like @rnBinds@ but without dependency analysis. + +NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. +That's crucial when dealing with an instance decl: +\begin{verbatim} + instance Foo (T a) where + op x = ... +\end{verbatim} +This might be the {\em sole} occurrence of @op@ for an imported class @Foo@, +and unless @op@ occurs we won't treat the type signature of @op@ in the class +decl for @Foo@ as a source of instance-decl gates. But we should! Indeed, +in many ways the @op@ in an instance decl is just like an occurrence, not +a binder. +-} + +rnMethodBinds :: Bool -- True <=> is a class declaration + -> Name -- Class name + -> [Name] -- Type variables from the class/instance header + -> LHsBinds GhcPs -- Binds + -> [LSig GhcPs] -- and signatures/pragmas + -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars) +-- Used for +-- * the default method bindings in a class decl +-- * the method bindings in an instance decl +rnMethodBinds is_cls_decl cls ktv_names binds sigs + = do { checkDupRdrNames (collectMethodBinders binds) + -- Check that the same method is not given twice in the + -- same instance decl instance C T where + -- f x = ... + -- g y = ... + -- f x = ... + -- We must use checkDupRdrNames because the Name of the + -- method is the Name of the class selector, whose SrcSpan + -- points to the class declaration; and we use rnMethodBinds + -- for instance decls too + + -- Rename the bindings LHSs + ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) [] binds + + -- 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 + bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds') + sig_ctxt | is_cls_decl = ClsDeclCtxt cls + | otherwise = InstDeclCtxt (mkOccEnv [ (nameOccName n, n) + | n <- nonDetEltsUniqSet bound_nms ]) + ; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags + ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $ + renameSigs sig_ctxt other_sigs + ; let localCompletePrags = localCompletePragmas spec_prags' + + -- Update the TcGblEnv with renamed COMPLETE pragmas from the current + -- module, for pattern irrefutability checking in do notation. + ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags + , tcg_complete_match_env = tcg_complete_match_env gblEnv ++ localCompletePrags}) $ + do { + -- Rename the bindings RHSs. Again there's an issue about whether the + -- type variables from the class/instance head are in scope. + -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables + ; (binds'', bind_fvs) <- bindSigTyVarsFV ktv_names $ + do { binds_w_dus <- mapM (rnLBind (mkScopedTvFn other_sigs')) binds' + ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2) + emptyFVs binds_w_dus + ; return (map 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. +-} + +rnMethodBindLHS :: Bool -> Name + -> LHsBindLR GhcPs GhcPs + -> LHsBindsLR GhcRn GhcPs + -> RnM (LHsBindsLR GhcRn GhcPs) +rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest + = setSrcSpanA loc $ do + do { sel_name <- wrapLocMA (lookupInstDeclBndr cls MethodOfClass) name + -- We use the selector name as the binder + ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField } + ; return (L loc bind' : rest ) } + +-- Report error for all other forms of bindings +-- This is why we use a fold rather than map +rnMethodBindLHS is_cls_decl _ (L loc bind) rest + = do { addErrAt (locA loc) $ TcRnIllegalClassBinding decl_sort bind + ; return rest } + where + decl_sort | is_cls_decl = ClassDeclSort + | otherwise = InstanceDeclSort + +{- +************************************************************************ +* * +\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} +* * +************************************************************************ + +@renameSigs@ checks for: +\begin{enumerate} +\item more than one sig for one thing; +\item signatures given for things not bound here; +\end{enumerate} + +At the moment we don't gather free-var info from the types in +signatures. We'd only need this if we wanted to report unused tyvars. +-} + +renameSigs :: HsSigCtxt + -> [LSig GhcPs] + -> RnM ([LSig GhcRn], FreeVars) +-- Renames the signatures and performs error checks +renameSigs ctxt sigs + = do { mapM_ dupSigDeclErr (findDupSigs sigs) + + ; checkDupMinimalSigs sigs + + ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstMA (renameSig ctxt)) sigs + + ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' + ; mapM_ misplacedSigErr bad_sigs -- Misplaced + + ; return (good_sigs, sig_fvs) } + +---------------------- +renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) +renameSig ctxt sig@(TypeSig _ vs ty) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; let doc = TypeSigCtx vs + ; (new_ty, fvs) <- rnHsSigWcType doc ty + ; return (TypeSig noAnn new_vs new_ty, fvs) } + +renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) + = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures + ; when (is_deflt && not defaultSigs_on) $ + addErr (TcRnUnexpectedDefaultSig sig) + ; new_v <- mapM (lookupSigOccRn ctxt sig) vs + ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) } + where + v1:|_ = expectNonEmpty vs + ty_ctxt = ClassMethodSigCtx v1 + +renameSig _ (SpecInstSig (_, src) ty) + = do { checkInferredVars doc ty + ; (new_ty, fvs) <- rnHsSigType doc TypeLevel ty + -- Check if there are any nested `forall`s or contexts, which are + -- illegal in the type of an instance declaration (see + -- Note [No nested foralls or contexts in instance types] in + -- GHC.Hs.Type). + ; addNoNestedForallsContextsErr doc NFC_Specialize + (getLHsInstDeclHead new_ty) + ; return (SpecInstSig (noAnn, src) new_ty,fvs) } + where + doc = SpecInstSigCtx + +-- {-# SPECIALISE #-} pragmas can refer to imported Ids +-- so, in the top-level case (when mb_names is Nothing) +-- we use lookupOccRn. If there's both an imported and a local 'f' +-- then the SPECIALISE pragma is ambiguous, unlike all other signatures +renameSig ctxt sig@(SpecSig _ v tys inl) + = do { new_v <- case ctxt of + TopSigCtxt {} -> lookupLocatedOccRn WL_TermVariable v + _ -> lookupSigOccRn ctxt sig v + ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys + ; return (SpecSig noAnn new_v new_ty inl, fvs) } + where + do_one (tys,fvs) ty + = do { (new_ty, fvs_ty) <- rnHsSigType (SpecialiseSigCtx v) TypeLevel ty + ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } + +renameSig _ctxt (SpecSigE _ bndrs spec_e inl) + = do { fn_rdr <- checkSpecESigShape spec_e + ; fn_name <- lookupOccRn WL_TermVariable fn_rdr -- Checks that the head isn't forall-bound + ; bindRuleBndrs (SpecECtx fn_rdr) bndrs $ \_ bndrs' -> + do { (spec_e', fvs) <- rnLExpr spec_e + ; return (SpecSigE fn_name bndrs' spec_e' inl, fvs) } } + +renameSig ctxt sig@(InlineSig _ v s) + = do { new_v <- lookupSigOccRn ctxt sig v + ; return (InlineSig noAnn new_v s, emptyFVs) } + +renameSig ctxt (FixSig _ fsig) + = do { new_fsig <- rnSrcFixityDecl ctxt fsig + ; return (FixSig noAnn new_fsig, emptyFVs) } + +renameSig ctxt sig@(MinimalSig (_, s) (L l bf)) + = do new_bf <- bfTraverse (lookupSigOccRn ctxt sig) bf + return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs) + +renameSig ctxt sig@(PatSynSig _ vs ty) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; return (PatSynSig noAnn new_vs ty', fvs) } + where + ty_ctxt = PatSynSigCtx vs + +renameSig ctxt sig@(SCCFunSig (_, st) v s) + = do { new_v <- lookupSigOccRn ctxt sig v + ; return (SCCFunSig (noAnn, st) new_v s, emptyFVs) } + +-- COMPLETE Sigs can refer to imported IDs which is why we use +-- lookupLocatedOccRn rather than lookupSigOccRn +renameSig _ctxt (CompleteMatchSig (_, s) bf mty) + = do new_bf <- traverse (lookupLocatedOccRn WL_ConLike) bf + new_mty <- traverse (lookupLocatedOccRn WL_TyCon) mty + + this_mod <- fmap tcg_mod getGblEnv + let rn_sig = CompleteMatchSig (noAnn, s) new_bf new_mty + unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ + -- Why 'any'? See Note [Orphan COMPLETE pragmas] + addErrCtxt (SigCtxt rn_sig) $ failWithTc TcRnOrphanCompletePragma + + return (rn_sig, emptyFVs) + + +checkSpecESigShape :: LHsExpr GhcPs -> RnM RdrName +-- Checks the shape of a SPECIALISE +-- That it looks like (f a1 .. an [ :: ty ]) +checkSpecESigShape spec_e = go_l spec_e + where + go_l (L _ e) = go e + + go :: HsExpr GhcPs -> RnM RdrName + go (ExprWithTySig _ fn _) = go_l fn + go (HsApp _ fn _) = go_l fn + go (HsAppType _ fn _) = go_l fn + go (HsVar _ (L _ fn)) = return fn + go (HsPar _ e) = go_l e + go _ = failWithTc (TcRnSpecSigShape spec_e) + +{- +Note [Orphan COMPLETE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define a COMPLETE pragma to be a non-orphan if it includes at least +one conlike defined in the current module. Why is this sufficient? +Well if you have a pattern match + + case expr of + P1 -> ... + P2 -> ... + P3 -> ... + +any COMPLETE pragma which mentions a conlike other than P1, P2 or P3 +will not be of any use in verifying that the pattern match is +exhaustive. So as we have certainly read the interface files that +define P1, P2 and P3, we will have loaded all non-orphan COMPLETE +pragmas that could be relevant to this pattern match. + +For now we simply disallow orphan COMPLETE pragmas, as the added +complexity of supporting them properly doesn't seem worthwhile. +-} + +okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool +okHsSig ctxt (L _ sig) + = case (sig, ctxt) of + (ClassOpSig {}, ClsDeclCtxt {}) -> True + (ClassOpSig {}, InstDeclCtxt {}) -> True + (ClassOpSig {}, _) -> False + + (TypeSig {}, ClsDeclCtxt {}) -> False + (TypeSig {}, InstDeclCtxt {}) -> False + (TypeSig {}, _) -> True + + (PatSynSig {}, TopSigCtxt{}) -> True + (PatSynSig {}, _) -> False + + (FixSig {}, InstDeclCtxt {}) -> False + (FixSig {}, _) -> True + + (InlineSig {}, HsBootCtxt {}) -> False + (InlineSig {}, _) -> True + + (SpecSig {}, ctxt) -> ok_spec_ctxt ctxt + (SpecSigE {}, ctxt) -> ok_spec_ctxt ctxt + + (SpecInstSig {}, InstDeclCtxt {}) -> True + (SpecInstSig {}, _) -> False + + (MinimalSig {}, ClsDeclCtxt {}) -> True + (MinimalSig {}, _) -> False + + (SCCFunSig {}, HsBootCtxt {}) -> False + (SCCFunSig {}, _) -> True + + (CompleteMatchSig {}, TopSigCtxt {} ) -> True + (CompleteMatchSig {}, _) -> False + + (XSig {}, TopSigCtxt {}) -> True + (XSig {}, InstDeclCtxt {}) -> True + (XSig {}, _) -> False + +ok_spec_ctxt ::HsSigCtxt -> Bool +-- Contexts where SPECIALISE can occur +ok_spec_ctxt (TopSigCtxt {}) = True +ok_spec_ctxt (LocalBindCtxt {}) = True +ok_spec_ctxt (InstDeclCtxt {}) = True +ok_spec_ctxt _ = False + +------------------- +findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)] +-- Check for duplicates on RdrName version, +-- because renamed version has unboundName for +-- not-in-scope binders, which gives bogus dup-sig errors +-- NB: in a class decl, a 'generic' sig is not considered +-- equal to an ordinary sig, so we allow, say +-- class C a where +-- op :: a -> a +-- default op :: Eq a => a -> a +findDupSigs sigs + = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) + where + expand_sig :: Sig GhcPs -> [(LocatedN RdrName, Sig GhcPs)] -- AZ + expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig) + expand_sig sig@(InlineSig _ n _) = [(n,sig)] + expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns] + expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns] + expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns] + expand_sig sig@(SCCFunSig (_, _) n _) = [(n,sig)] + expand_sig _ = [] + + matching_sig :: (LocatedN RdrName, Sig GhcPs) -> (LocatedN RdrName, Sig GhcPs) -> Bool --AZ + matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 + mtch (FixSig {}) (FixSig {}) = True + mtch (InlineSig {}) (InlineSig {}) = True + mtch (TypeSig {}) (TypeSig {}) = True + mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2 + mtch (PatSynSig _ _ _) (PatSynSig _ _ _) = True + mtch (SCCFunSig{}) (SCCFunSig{}) = True + mtch _ _ = False + +-- Warn about multiple MINIMAL signatures +checkDupMinimalSigs :: [LSig GhcPs] -> RnM () +checkDupMinimalSigs sigs + = case filter isMinimalLSig sigs of + sig1 : sig2 : otherSigs -> dupMinimalSigErr sig1 sig2 otherSigs + _ -> return () + +localCompletePragmas :: [LSig GhcRn] -> CompleteMatches +localCompletePragmas sigs = mapMaybe (getCompleteSig . unLoc) $ reverse sigs + where + getCompleteSig = \case + CompleteMatchSig _ cons mbTyCon -> + Just $ CompleteMatch (mkUniqDSet $ map unLoc cons) (fmap unLoc mbTyCon) + _ -> Nothing + -- SG: for some reason I haven't investigated further, the signatures come in + -- backwards wrt. declaration order. So we reverse them here, because it makes + -- a difference for incomplete match suggestions. + +bindRuleBndrs :: HsDocContext -> RuleBndrs GhcPs + -> ([Name] -> RuleBndrs GhcRn -> RnM (a,FreeVars)) + -> RnM (a,FreeVars) +bindRuleBndrs doc (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) thing_inside + = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs + ; checkDupRdrNames rdr_names_w_loc + ; checkShadowedRdrNames rdr_names_w_loc + ; names <- newLocalBndrsRn rdr_names_w_loc + ; bindRuleTyVars doc tyvs $ \ tyvs' -> + bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> + thing_inside names (RuleBndrs { rb_ext = noExtField + , rb_tyvs = tyvs', rb_tmvs = tmvs' }) } + where + get_var :: RuleBndr GhcPs -> LocatedN RdrName + get_var (RuleBndrSig _ v _) = v + get_var (RuleBndr _ v) = v + + +bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs + -> [LRuleBndr GhcPs] -> [Name] + -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindRuleTmVars doc tyvs vars names thing_inside + = go vars names $ \ vars' -> + bindLocalNamesFV names (thing_inside vars') + where + go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside + = go vars ns $ \ vars' -> + thing_inside (L l (RuleBndr noAnn (L loc n)) : vars') + + go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) + (n : ns) thing_inside + = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' -> + go vars ns $ \ vars' -> + thing_inside (L l (RuleBndrSig noAnn (L loc n) bsig') : vars') + + go [] [] thing_inside = thing_inside [] + go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) + + bind_free_tvs = case tyvs of Nothing -> AlwaysBind + Just _ -> NeverBind + +bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs] + -> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindRuleTyVars doc (Just bndrs) thing_inside + = bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs (thing_inside . Just) +bindRuleTyVars _ _ thing_inside = thing_inside Nothing + +{- +************************************************************************ +* * +\subsection{Match} +* * +************************************************************************ +-} + +type AnnoBody body + = ( Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnLW + , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW + , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA + , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA + , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO + , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ EpAnnCO + , 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) => HsMatchContextRn + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> MatchGroup GhcPs (LocatedA (body GhcPs)) + -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) +rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin }) + -- see Note [Empty MatchGroups] + = do { when (null ms) $ checkEmptyCase ctxt + ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms + ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) } + +-- Check the validity of a MatchGroup with an empty list of alternatives. +-- +-- 1. Normal `case x of {}` passes this check as long as EmptyCase is enabled. +-- Ditto lambda-case `\case {}`. +-- +-- 2. Multi-case with no alternatives `\cases {}` is never valid. +-- +-- 3. Other MatchGroup contexts (FunRhs, LamAlt LamSingle, etc) are not +-- considered here because there is no syntax to construct them with +-- no alternatives. +-- +-- Test case: rename/should_fail/RnEmptyCaseFail +-- +-- Validation continues in the type checker, namely in tcMatches. +-- See Note [Pattern types for EmptyCase] in GHC.Tc.Gen.Match +checkEmptyCase :: HsMatchContextRn -> RnM () +checkEmptyCase ctxt + | disallowed_ctxt = + addErr (TcRnEmptyCase ctxt EmptyCaseDisallowedCtxt) + | otherwise = + unlessXOptM LangExt.EmptyCase $ + addErr (TcRnEmptyCase ctxt EmptyCaseWithoutFlag) + where + disallowed_ctxt = + case ctxt of + LamAlt LamCases -> True + ArrowMatchCtxt (ArrowLamAlt LamCases) -> True + _ -> False + +rnMatch :: AnnoBody body + => HsMatchContextRn + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> LMatch GhcPs (LocatedA (body GhcPs)) + -> RnM (LMatch GhcRn (LocatedA (body GhcRn)), FreeVars) +rnMatch ctxt rnBody = wrapLocFstMA (rnMatch' ctxt rnBody) + +rnMatch' :: (AnnoBody body) + => HsMatchContextRn + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> Match GhcPs (LocatedA (body GhcPs)) + -> RnM (Match GhcRn (LocatedA (body GhcRn)), FreeVars) +rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = L l pats, m_grhss = grhss }) + = rnPats ctxt pats $ \ pats' -> do + { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss + ; let mf' = case (ctxt, mf) of + (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) + -> mf { mc_fun = L lf funid } + _ -> ctxt + ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = L l pats' + , m_grhss = grhss'}, grhss_fvs ) } + + +{- +************************************************************************ +* * +\subsubsection{Guarded right-hand sides (GRHSs)} +* * +************************************************************************ +-} + +rnGRHSs :: AnnoBody body + => HsMatchContextRn + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> GRHSs GhcPs (LocatedA (body GhcPs)) + -> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), FreeVars) +rnGRHSs ctxt rnBody (GRHSs _ grhss binds) + = rnLocalBindsAndThen binds $ \ binds' _ -> do + (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss + return (GRHSs emptyComments grhss' binds', fvGRHSs) + +rnGRHS :: AnnoBody body + => HsMatchContextRn + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> LGRHS GhcPs (LocatedA (body GhcPs)) + -> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars) +rnGRHS ctxt rnBody = wrapLocFstMA (rnGRHS' ctxt rnBody) + +rnGRHS' :: HsMatchContextRn + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> GRHS GhcPs (LocatedA (body GhcPs)) + -> RnM (GRHS GhcRn (LocatedA (body GhcRn)), FreeVars) +rnGRHS' ctxt rnBody (GRHS _ guards rhs) + = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnExpr guards $ \ _ -> + rnBody rhs + + ; unless (pattern_guards_allowed || is_standard_guard guards') $ + addDiagnostic (nonStdGuardErr guards') + + ; return (GRHS noAnn guards' rhs', fvs) } + where + -- Standard Haskell 1.4 guards are just a single boolean + -- expression, rather than a list of qualifiers as in the + -- Glasgow extension + is_standard_guard [] = True + is_standard_guard [L _ (BodyStmt {})] = True + is_standard_guard _ = False + +{- +********************************************************* +* * + Source-code fixity declarations +* * +********************************************************* +-} + +rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn) +-- Rename a fixity decl, so we can put +-- the renamed decl in the renamed syntax tree +-- Errors if the thing being fixed is not defined locally. +rnSrcFixityDecl sig_ctxt = rn_decl + where + rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn) + -- GHC extension: look up both the tycon and data con + -- for con-like things; hence returning a list + -- If neither are in scope, report an error; otherwise + -- return a fixity sig for each (slightly odd) + rn_decl sig@(FixitySig ns_spec fnames fixity) + = do unlessXOptM LangExt.ExplicitNamespaces $ + when (ns_spec /= NoNamespaceSpecifier) $ + addErr (TcRnNamespacedFixitySigWithoutFlag sig) + names <- concatMapM (lookup_one ns_spec) fnames + return (FixitySig ns_spec names fixity) + + lookup_one :: NamespaceSpecifier -> LocatedN RdrName -> RnM [LocatedN Name] + lookup_one ns_spec (L name_loc rdr_name) + = setSrcSpanA name_loc $ + -- This lookup will fail if the name is not defined in the + -- same binding group as this fixity declaration. + do names <- lookupLocalTcNames sig_ctxt SigLikeFixitySig ns_spec rdr_name + return [ L name_loc name | (_, name) <- names ] + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM () +dupSigDeclErr pairs@((L loc _, _) :| _) + = addErrAt (locA loc) $ TcRnDuplicateSigDecl pairs + +misplacedSigErr :: LSig GhcRn -> RnM () +misplacedSigErr (L loc sig) + = addErrAt (locA loc) $ TcRnMisplacedSigDecl sig + +nonStdGuardErr :: (Outputable body, + Anno (Stmt GhcRn body) ~ SrcSpanAnnA) + => [LStmtLR GhcRn GhcRn body] -> TcRnMessage +nonStdGuardErr guards = TcRnNonStdGuards (NonStandardGuards guards) + +dupMinimalSigErr :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> RnM () +dupMinimalSigErr sig1 sig2 otherSigs + = addErrAt (getLocA sig1) $ TcRnDuplicateMinimalSig sig1 sig2 otherSigs diff --git a/GHC/Rename/Doc.hs b/GHC/Rename/Doc.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Doc.hs @@ -0,0 +1,44 @@ +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) + +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_env ns = + [ L l $ greName gre + | L l rdr_name <- ns + , gre <- lookupGRE gre_env (LookupRdrName rdr_name AllRelevantGREs) + ] diff --git a/GHC/Rename/Env.hs b/GHC/Rename/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Env.hs @@ -0,0 +1,2493 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-2006 + +GHC.Rename.Env contains functions which convert RdrNames into Names. + +-} + +module GHC.Rename.Env ( + newTopSrcBinder, + + lookupLocatedTopBndrRnN, lookupTopBndrRn, + + lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField, + lookupLocatedOccRnNone, + lookupOccRn, lookupOccRn_maybe, lookupSameOccRn_maybe, + lookupLocalOccRn_maybe, lookupInfoOccRn, + lookupLocalOccThLvl_maybe, lookupLocalOccRn, + lookupTypeOccRn, + lookupGlobalOccRn_maybe, + + lookupExprOccRn, + lookupRecFieldOcc, + lookupRecUpdFields, + getFieldUpdLbl, + getUpdFieldLbls, + + ChildLookupResult(..), + lookupSubBndrOcc_helper, + + HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, + lookupSigCtxtOccRn, + + lookupInstDeclBndr, lookupFamInstName, + lookupConstructorInfo, lookupConstructorFields, + lookupGREInfo, + + irrefutableConLikeRn, irrefutableConLikeTc, + + lookupGreAvailRn, + + -- Rebindable Syntax + lookupSyntax, lookupSyntaxExpr, lookupSyntaxNames, + lookupSyntaxName, + lookupIfThenElse, + + -- QualifiedDo + lookupQualifiedDo, lookupQualifiedDoName, lookupNameWithQualifier, + + -- Constructing usage information + DeprecationWarnings(..), + addUsedGRE, addUsedGREs, addUsedDataCons, + + dataTcOccs, --TODO: Move this somewhere, into utils? + + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import GHC.Iface.Load +import GHC.Iface.Env +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr (pprScopeError) +import GHC.Tc.Utils.Env +import GHC.Tc.Types.LclEnv +import GHC.Tc.Utils.Monad +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import GHC.Builtin.Types +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Avail +import GHC.Types.Hint +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Builtin.Names( rOOT_MAIN ) +import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..), tupleSortBoxity ) +import GHC.Types.TyThing ( tyThingGREInfo ) +import GHC.Types.SrcLoc as SrcLoc +import GHC.Utils.Outputable as Outputable +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet +import GHC.Types.Unique.Set +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Data.Maybe +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Data.List.SetOps ( minusList ) +import qualified GHC.LanguageExtensions as LangExt +import GHC.Rename.Unbound +import GHC.Rename.Utils +import GHC.Data.Bag +import GHC.Types.CompleteMatch +import GHC.Types.PkgQual +import GHC.Types.GREInfo + +import Control.Arrow ( first ) +import Control.Monad +import Data.Either ( partitionEithers ) +import Data.Function ( on ) +import Data.List ( find, partition, sortBy ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as Semi +import System.IO.Unsafe ( unsafePerformIO ) + +{- +********************************************************* +* * + Source-code binders +* * +********************************************************* + +Note [Signature lazy interface loading] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC's lazy interface loading can be a bit confusing, so this Note is an +empirical description of what happens in one interesting case. When +compiling a signature module against an its implementation, we do NOT +load interface files associated with its names until after the type +checking phase. For example: + + module ASig where + data T + f :: T -> T + +Suppose we compile this with -sig-of "A is ASig": + + module B where + data T = T + f T = T + + module A(module B) where + import B + +During type checking, we'll load A.hi because we need to know what the +RdrEnv for the module is, but we DO NOT load the interface for B.hi! +It's wholly unnecessary: our local definition 'data T' in ASig is all +the information we need to finish type checking. This is contrast to +type checking of ordinary Haskell files, in which we would not have the +local definition "data T" and would need to consult B.hi immediately. +(Also, this situation never occurs for hs-boot files, since you're not +allowed to reexport from another module.) + +After type checking, we then check that the types we provided are +consistent with the backing implementation (in checkHiBootOrHsigIface). +At this point, B.hi is loaded, because we need something to compare +against. + +I discovered this behavior when trying to figure out why type class +instances for Data.Map weren't in the EPS when I was type checking a +test very much like ASig (sigof02dm): the associated interface hadn't +been loaded yet! (The larger issue is a moot point, since an instance +declared in a signature can never be a duplicate.) + +This behavior might change in the future. Consider this +alternate module B: + + module B where + {-# DEPRECATED T, f "Don't use" #-} + data T = T + f T = T + +One might conceivably want to report deprecation warnings when compiling +ASig with -sig-of B, in which case we need to look at B.hi to find the +deprecation warnings during renaming. At the moment, you don't get any +warning until you use the identifier further downstream. This would +require adjusting addUsedGRE so that during signature compilation, +we do not report deprecation warnings for LocalDef. See also +Note [Handling of deprecations] in GHC.Rename.Utils +-} + +newTopSrcBinder :: LocatedN RdrName -> RnM Name +newTopSrcBinder (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = -- This is here to catch + -- (a) Exact-name binders created by Template Haskell + -- (b) The PrelBase defn of (say) [] and similar, for which + -- the parser reads the special syntax and returns an Exact RdrName + -- We are at a binding site for the name, so check first that it + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- data T = (,) Int Int + -- unless we are in GHC.Tup + if isExternalName name then + do { this_mod <- getModule + ; unless (this_mod == nameModule name) + (addErrAt (locA loc) (TcRnBindingOfExistingName rdr_name)) + ; return name } + else -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + do { this_mod <- getModule + ; externaliseName this_mod name } + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { this_mod <- getModule + ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) + (addErrAt (locA loc) (TcRnBindingOfExistingName rdr_name)) + -- When reading External Core we get Orig names as binders, + -- but they should agree with the module gotten from the monad + -- + -- We can get built-in syntax showing up here too, sadly. If you type + -- data T = (,,,) + -- the constructor is parsed as a type, and then GHC.Parser.PostProcess.tyConToDataCon + -- uses setRdrNameSpace to make it into a data constructors. At that point + -- the nice Exact name for the TyCon gets swizzled to an Orig name. + -- Hence the TcRnBindingOfExistingName error message. + -- + + -- MP 2022: I suspect this code path is never called for `rOOT_MAIN` anymore + -- because External Core has been removed but we instead have some similar logic for + -- serialising whole programs into interface files in GHC.IfaceToCore.mk_top_id. + + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module; ugh! + + -- Because of this latter case, we call newGlobalBinder with a module from + -- the RdrName, not from the environment. In principle, it'd be fine to + -- have an arbitrary mixture of external core definitions in a single module, + -- (apart from module-initialisation issues, perhaps). + ; newGlobalBinder rdr_mod rdr_occ (locA loc) } + + | otherwise + = do { when (isQual rdr_name) + (addErrAt (locA loc) (badQualBndrErr rdr_name)) + -- Binders should not be qualified; if they are, and with a different + -- module name, we get a confusing "M.T is not in scope" error later + + ; level <- getThLevel + ; if isBrackLevel level then + -- We are inside a TH bracket, so make an *Internal* name + -- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names + do { uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) } + else + do { this_mod <- getModule + ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr (locA loc)) + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (locA loc) } + } + +{- +********************************************************* +* * + Source code occurrences +* * +********************************************************* + +Looking up a name in the GHC.Rename.Env. + +Note [Type and class operator definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to reject all of these unless we have -XTypeOperators (#3265) + data a :*: b = ... + class a :*: b where ... + data (:*:) a b = .... + class (:*:) a b where ... +The latter two mean that we are not just looking for a +*syntactically-infix* declaration, but one that uses an operator +OccName. We use OccName.isSymOcc to detect that case, which isn't +terribly efficient, but there seems to be no better way. +-} + +-- Can be made to not be exposed +-- Only used unwrapped in rnAnnProvenance +lookupTopBndrRn :: WhatLooking -> RdrName -> RnM (WithUserRdr Name) +-- Look up a top-level source-code binder. We may be looking up an unqualified 'f', +-- and there may be several imported 'f's too, which must not confuse us. +-- For example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course +-- So we have to filter out the non-local ones. +-- +-- A separate function (importsFromLocalDecls) reports duplicate top level +-- decls, so here it's safe just to choose an arbitrary one. +lookupTopBndrRn which_suggest rdr_name = + lookupExactOrOrig rdr_name (WithUserRdr rdr_name . greName) $ + do { -- Check for operators in type or class declarations + -- See Note [Type and class operator definitions] + let occ = rdrNameOcc rdr_name + ; when (isTcOcc occ && isSymOcc occ) + (do { op_ok <- xoptM LangExt.TypeOperators + ; unless op_ok (addErr (TcRnIllegalTypeOperatorDecl rdr_name)) }) + ; env <- getGlobalRdrEnv + ; WithUserRdr rdr_name <$> + case filter isLocalGRE (lookupGRE env $ LookupRdrName rdr_name $ RelevantGREsFOS WantNormal) of + [gre] -> return (greName gre) + _ -> do -- Ambiguous (can't happen) or unbound + traceRn "lookupTopBndrRN fail" (ppr rdr_name) + unboundName (LF which_suggest WL_LocalTop) rdr_name + } + +lookupLocatedTopBndrRnN :: WhatLooking -> LocatedN RdrName -> RnM (LocatedN Name) +lookupLocatedTopBndrRnN what_look = + wrapLocMA (fmap getName . lookupTopBndrRn what_look) + +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This never adds an error, but it may return one, see +-- Note [Errors in lookup functions] +lookupExactOcc_either :: Name -> RnM (Either NotInScopeError GlobalRdrElt) +lookupExactOcc_either name + | Just thing <- wiredInNameTyThing_maybe name + , Just (tycon, mkInfo) + <- case thing of + ATyCon tc -> + Just (tc, IAmTyCon . TupleFlavour . tupleSortBoxity) + AConLike (RealDataCon dc) -> + let tc = dataConTyCon dc + in Just (tc, IAmConLike . (\ _ -> mkConInfo (ConIsData $ map dataConName $ tyConDataCons tc) (dataConSourceArity dc) [])) + _ -> Nothing + , Just tupleSort <- tyConTuple_maybe tycon + = do { let tupArity = case tupleSort of + -- Unboxed tuples have twice as many arguments because of the + -- 'RuntimeRep's (#17837) + UnboxedTuple -> tyConArity tycon `div` 2 + _ -> tyConArity tycon + ; let info = mkInfo tupleSort + ; checkTupSize tupArity + ; return $ Right $ mkExactGRE name info } + + | isExternalName name + = do { info <- lookupExternalExactName name + ; return $ Right $ mkExactGRE name info } + + | otherwise + = lookupLocalExactGRE name + +lookupExternalExactName :: Name -> RnM GREInfo +lookupExternalExactName name + = do { thing <- + case wiredInNameTyThing_maybe name of + Just thing -> return thing + _ -> tcLookupGlobal name + ; return $ tyThingGREInfo thing } + +lookupLocalExactGRE :: Name -> RnM (Either NotInScopeError GlobalRdrElt) +lookupLocalExactGRE name + = do { env <- getGlobalRdrEnv + ; let lk = LookupExactName { lookupExactName = name + , lookInAllNameSpaces = True } + -- We want to check for clashes where the same Unique + -- occurs in two different NameSpaces, as per + -- Note [Template Haskell ambiguity]. So we + -- check ALL namespaces, not just the NameSpace of the Name. + -- See test cases T9066, T11809. + ; case lookupGRE env lk of + [gre] -> return (Right gre) + + [] -> -- See Note [Splicing Exact names] + do { lcl_env <- getLocalRdrEnv + ; let gre = mkLocalVanillaGRE NoParent name -- LocalRdrEnv only contains Vanilla things + ; if name `inLocalRdrEnvScope` lcl_env + then return (Right gre) + else + do { th_topnames_var <- fmap tcg_th_topnames getGblEnv + ; th_topnames <- readTcRef th_topnames_var + ; if name `elemNameSet` th_topnames + then return (Right gre) + else return (Left (NoExactName name)) + } + } + + gres -> return (Left (SameName gres)) } + -- Ugh! See Note [Template Haskell ambiguity] } + +----------------------------------------------- +lookupInstDeclBndr :: Name -> Subordinate -> RdrName -> RnM Name +-- This is called on the method name on the left-hand side of an +-- instance declaration binding. eg. instance Functor T where +-- fmap = ... +-- ^^^^ called on this +-- Regardless of how many unqualified fmaps are in scope, we want +-- the one that comes from the Functor class. +-- +-- Furthermore, note that we take no account of whether the +-- name is only in scope qualified. I.e. even if method op is +-- in scope as M.op, we still allow plain 'op' on the LHS of +-- an instance decl +-- +-- The "what" parameter says "method" or "associated type", +-- depending on what we are looking up +lookupInstDeclBndr cls what_subordinate rdr + = do { when (isQual rdr) + (addErr (badQualBndrErr rdr)) + -- In an instance decl you aren't allowed + -- to use a qualified name for the method + -- (Although it'd make perfect sense.) + ; mb_name <- lookupSubBndrOcc + NoDeprecationWarnings + -- we don't give deprecated + -- warnings when a deprecated class + -- method is defined. We only warn + -- when it's used + (ParentGRE cls (IAmTyCon ClassFlavour)) what_subordinate rdr + ; case mb_name of + Left err -> do { addErr $ TcRnNotInScope err rdr + ; return (mkUnboundNameRdr rdr) } + Right nm -> return nm } + +----------------------------------------------- +lookupFamInstName :: Maybe Name -> LocatedN RdrName + -> RnM (LocatedN Name) +-- Used for TyData and TySynonym family instances only, +-- See Note [Family instance binders] +lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f GHC.Rename.Bind.rnMethodBind + = wrapLocMA (lookupInstDeclBndr cls AssociatedTypeOfClass) tc_rdr +lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* + = lookupLocatedOccRn WL_TyCon tc_rdr + +----------------------------------------------- +lookupConstructorFields :: HasDebugCallStack => WithUserRdr Name -> RnM [FieldLabel] +lookupConstructorFields = fmap conInfoFields . lookupConstructorInfo + +-- | Look up the arity and record fields of a constructor. +lookupConstructorInfo :: HasDebugCallStack => WithUserRdr Name -> RnM ConInfo +lookupConstructorInfo qcon@(WithUserRdr _ con_name) + = do { info <- lookupGREInfo_GRE con_name + ; case info of + IAmConLike con_info -> return con_info + UnboundGRE -> return $ ConInfo (ConIsData []) ConHasPositionalArgs + IAmTyCon {} -> failIllegalTyCon WL_ConLike qcon + _ -> pprPanic "lookupConstructorInfo: not a ConLike" $ + vcat [ text "name:" <+> ppr con_name ] + } + +-- In CPS style as `RnM r` is monadic +-- Reports an error if the name is an Exact or Orig and it can't find the name +-- Otherwise if it is not an Exact or Orig, returns k +lookupExactOrOrig :: RdrName -> (GlobalRdrElt -> r) -> RnM r -> RnM r +lookupExactOrOrig rdr_name res k + = do { men <- lookupExactOrOrig_base rdr_name + ; case men of + FoundExactOrOrig gre -> return $ res gre + NotExactOrOrig -> k + ExactOrOrigError e -> + do { addErr $ TcRnNotInScope e rdr_name + ; return $ res (mkUnboundGRERdr rdr_name) } } + +-- Variant of 'lookupExactOrOrig' that does not report an error +-- See Note [Errors in lookup functions] +-- Calls k if the name is neither an Exact nor Orig +lookupExactOrOrig_maybe :: RdrName -> (Maybe GlobalRdrElt -> r) -> RnM r -> RnM r +lookupExactOrOrig_maybe rdr_name res k + = do { men <- lookupExactOrOrig_base rdr_name + ; case men of + FoundExactOrOrig gre -> return (res (Just gre)) + ExactOrOrigError _ -> return (res Nothing) + NotExactOrOrig -> k } + +data ExactOrOrigResult + = FoundExactOrOrig GlobalRdrElt + -- ^ Found an Exact Or Orig Name + | ExactOrOrigError NotInScopeError + -- ^ The RdrName was an Exact + -- or Orig, but there was an + -- error looking up the Name + | NotExactOrOrig + -- ^ The RdrName is neither an Exact nor Orig + +-- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult' +lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult +lookupExactOrOrig_base rdr_name + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = cvtEither <$> lookupExactOcc_either n + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { nm <- lookupOrig rdr_mod rdr_occ + + ; this_mod <- getModule + ; mb_gre <- + if nameIsLocalOrFrom this_mod nm + then lookupLocalExactGRE nm + else do { info <- lookupExternalExactName nm + ; return $ Right $ mkExactGRE nm info } + ; return $ case mb_gre of + Left err -> ExactOrOrigError err + Right gre -> FoundExactOrOrig gre } + | otherwise = return NotExactOrOrig + where + cvtEither (Left e) = ExactOrOrigError e + cvtEither (Right gre) = FoundExactOrOrig gre + +{- Note [Errors in lookup functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Many of these lookup functions will attach an error if it can't find the Name it +is trying to lookup. However there are also _maybe and _either variants for many +of these functions. + +These variants should *not* attach any errors, as there are +places where we want to attempt looking up a name, but it's not the end of the +world if we don't find it. + +For example, see lookupThName_maybe: It calls lookupOccRn_maybe multiple +times for varying names in different namespaces. lookupOccRn_maybe should +therefore never attach an error, instead just return a Nothing. + +For these _maybe/_either variant functions then, avoid calling further lookup +functions that can attach errors and instead call their _maybe/_either +counterparts. +-} + +----------------------------------------------- +-- | Look up an occurrence of a field in record construction or pattern +-- matching (but not update). +-- +-- If -XDisambiguateRecordFields is off, then we will pass 'Nothing' for the +-- 'DataCon' 'Name', i.e. we don't use the data constructor for disambiguation. +-- See Note [DisambiguateRecordFields] and Note [NoFieldSelectors]. +lookupRecFieldOcc :: Maybe (WithUserRdr Name) + -- Nothing => just look it up as usual + -- Just con => use data con to disambiguate + -> RdrName + -> RnM Name +lookupRecFieldOcc mb_con rdr_name + | Just (WithUserRdr _ con) <- mb_con + , isUnboundName con -- Avoid error cascade + = return $ mk_unbound_rec_fld con + | Just qcon@(WithUserRdr _ con) <- mb_con + = do { let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name) + ; mb_nm <- lookupExactOrOrig rdr_name ensure_recfld $ -- See Note [Record field names and Template Haskell] + do { flds <- lookupConstructorFields qcon + ; env <- getGlobalRdrEnv + ; let mb_gre = do fl <- find ((== lbl) . flLabel) flds + -- We have the label, now check it is in scope. If + -- there is a qualifier, use pickGREs to check that + -- the qualifier is correct, and return the filtered + -- GRE so we get import usage right (see #17853). + gre <- lookupGRE_FieldLabel env fl + if isQual rdr_name + then listToMaybe $ pickGREs rdr_name [gre] + else return gre + ; traceRn "lookupRecFieldOcc" $ + vcat [ text "mb_con:" <+> ppr mb_con + , text "rdr_name:" <+> ppr rdr_name + , text "flds:" <+> ppr flds + , text "mb_gre:" <+> ppr mb_gre ] + ; mapM_ (addUsedGRE AllDeprecationWarnings) mb_gre + ; return $ flSelector . fieldGRELabel <$> mb_gre } + ; case mb_nm of + { Nothing -> do { addErr (badFieldConErr con lbl) + ; return $ mk_unbound_rec_fld con } + ; Just nm -> return nm } } + + | otherwise -- Can't use the data constructor to disambiguate + = lookupExactOrOrig rdr_name greName $ + do { mb_gre <- lookupGlobalOccRn_base which_gres rdr_name + ; case mb_gre of + Just gre -> return (greName gre) + Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) + ; unboundName looking_for rdr_name } } + where + which_gres = RelevantGREsFOS WantField + looking_for = LF { lf_which = WL_RecField, lf_where = WL_Global } + -- This use of Global is right as we are looking up a selector, + -- which can only be defined at the top level. + + -- When lookup fails, make an unbound name with the right record field + -- namespace, as that's what we expect to be returned + -- from 'lookupRecFieldOcc'. See T14307. + mk_unbound_rec_fld con = mkUnboundName $ + mkRecFieldOccFS (getOccFS con) (occNameFS occ) + occ = rdrNameOcc rdr_name + + ensure_recfld :: GlobalRdrElt -> Maybe Name + ensure_recfld gre = do { guard (isRecFldGRE gre) + ; return $ greName gre } + +{- Note [DisambiguateRecordFields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are looking up record fields in record construction or pattern +matching, we can take advantage of the data constructor name to +resolve fields that would otherwise be ambiguous (provided the +-XDisambiguateRecordFields flag is on). + +For example, consider: + + data S = MkS { x :: Int } + data T = MkT { x :: Int } + + e = MkS { x = 3 } + +When we are renaming the occurrence of `x` in `e`, instead of looking +`x` up directly (and finding both fields), lookupRecFieldOcc will +search the fields of `MkS` to find the only possible `x` the user can +mean. + +Of course, we still have to check the field is in scope, using +lookupGRE_FieldLabel. The handling of qualified imports is slightly +subtle: the occurrence may be unqualified even if the field is +imported only qualified (but if the occurrence is qualified, the +qualifier must be correct). For example: + + module A where + data S = MkS { x :: Int } + data T = MkT { x :: Int } + + module B where + import qualified A (S(..)) + import A (T(MkT)) + + e1 = MkT { x = 3 } -- x not in scope, so fail + e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail + e3 = A.MkS { x = 3 } -- x in scope (lack of module qualifier permitted) + +In case `e1`, lookupGRE_FieldLabel will return Nothing. In case `e2`, +lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard +will fail because the field RdrName `B.x` is qualified and pickGREs +rejects the GRE. In case `e3`, lookupGRE_FieldLabel will return the +GRE for `A.x` and the guard will succeed because the field RdrName `x` +is unqualified. + + +Note [DisambiguateRecordFields for updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are looking up record fields in record update, we can take advantage of +the fact that we know we are looking for a field, even though we do not know the +data constructor name (as in Note [DisambiguateRecordFields]), provided the +-XDisambiguateRecordFields flag is on. + +For example, consider: + + module N where + f = () + + {-# LANGUAGE DisambiguateRecordFields #-} + module M where + import N (f) + data T = MkT { f :: Int } + t = MkT { f = 1 } -- unambiguous because MkT determines which field we mean + u = t { f = 2 } -- unambiguous because we ignore the non-field 'f' + +We filter out non-fields in lookupFieldGREs by using isRecFldGRE, which allows +us to accept the above program. +Of course, if a record update has two fields in scope with the same name, +it is still ambiguous. + +We also look up the non-fields with the same textual name + + 1. to throw an error if the user hasn't enabled DisambiguateRecordFields, + 2. in order to improve the error message when a user mistakenly tries to use + a non-field in a record update: + + f = () + e x = x { f = () } + +Unlike with constructors or pattern-matching, we do not allow the module +qualifier to be omitted from the field names, because we do not have a +data constructor to use to determine the appropriate qualifier. + +This is all done in the function lookupFieldGREs, which is called by +GHC.Rename.Pat.rnHsRecUpdFields, which deals with record updates. + +Note [Record field names and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12130): + + module Foo where + import M + b = $(funny) + + module M(funny) where + data T = MkT { x :: Int } + funny :: Q Exp + funny = [| MkT { x = 3 } |] + +When we splice, `MkT` is not lexically in scope, so +lookupGRE_FieldLabel will fail. But there is no need for +disambiguation anyway, because `x` is an original name, and +lookupGlobalOccRn will find it. +-} + +-- | Used in export lists to lookup the children. +lookupSubBndrOcc_helper :: Bool + -> DeprecationWarnings + -> ParentGRE -- ^ parent + -> RdrName -- ^ thing we are looking up + -> RnM ChildLookupResult +lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent_gre rdr_name + | isUnboundName (parentGRE_name parent_gre) + -- Avoid an error cascade + = return (FoundChild (mkUnboundGRERdr rdr_name)) + + | otherwise = do + gre_env <- getGlobalRdrEnv + let original_gres = lookupGRE gre_env (LookupChildren parent_gre (rdrNameOcc rdr_name)) + picked_gres = pick_gres original_gres + -- The remaining GREs are things that we *could* export here. + -- Note that this includes things which have `NoParent`; + -- those are sorted in `checkPatSynParent`. + traceRn "parent" (ppr (parentGRE_name parent_gre)) + traceRn "lookupExportChild original_gres:" (ppr original_gres) + traceRn "lookupExportChild picked_gres:" (ppr picked_gres $$ ppr must_have_parent) + case picked_gres of + NoOccurrence -> + noMatchingParentErr original_gres + UniqueOccurrence g -> + if must_have_parent + then noMatchingParentErr original_gres + else checkFld g + DisambiguatedOccurrence g -> + checkFld g + AmbiguousOccurrence gres -> + mkNameClashErr gres + where + checkFld :: GlobalRdrElt -> RnM ChildLookupResult + checkFld g = do + addUsedGRE warn_if_deprec g + return $ FoundChild g + + -- Called when we find no matching GREs after disambiguation but + -- there are three situations where this happens. + -- 1. There were none to begin with. + -- 2. None of the matching ones were the parent but + -- a. They were from an overloaded record field so we can report + -- a better error + -- b. The original lookup was actually ambiguous. + -- For example, the case where overloading is off and two + -- record fields are in scope from different record + -- constructors, neither of which is the parent. + noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult + noMatchingParentErr original_gres = do + traceRn "npe" (ppr original_gres) + dup_fields_ok <- xoptM LangExt.DuplicateRecordFields + case original_gres of + [] -> return NameNotFound + [g] -> return $ IncorrectParent parent_gre g + [p | ParentIs p <- [greParent g]] + gss@(g:gss'@(_:_)) -> + if all isRecFldGRE gss && dup_fields_ok + then return $ + IncorrectParent parent_gre g + [p | x <- gss, ParentIs p <- [greParent x]] + else mkNameClashErr $ g NE.:| gss' + + mkNameClashErr :: NE.NonEmpty GlobalRdrElt -> RnM ChildLookupResult + mkNameClashErr gres = do + addNameClashErrRn rdr_name gres + return (FoundChild (NE.head gres)) + + pick_gres :: [GlobalRdrElt] -> DisambigInfo + pick_gres gres + | isUnqual rdr_name + -- The child is not qualified: find GREs that are in scope, whether + -- qualified or unqualified, as per the Haskell 2010 report, 5.2.2: + -- + -- - In all cases, the parent type constructor T must be in scope. + -- - A subordinate name is legal if and only if: + -- (a) it names a constructor or field of T, and + -- (b) the constructor or field is in scope, regardless of whether + -- it is in scope under a qualified or unqualified name. + = mconcat (map right_parent gres) + | otherwise + -- The child is qualified: find GREs that are in scope + -- with that qualification. + = mconcat (map right_parent (pickGREs rdr_name gres)) + + right_parent :: GlobalRdrElt -> DisambigInfo + right_parent gre + = case greParent gre of + ParentIs cur_parent + | parentGRE_name parent_gre == cur_parent -> DisambiguatedOccurrence gre + | otherwise -> NoOccurrence + NoParent -> UniqueOccurrence gre + +-- | This domain specific datatype is used to record why we decided it was +-- possible that a GRE could be exported with a parent. +data DisambigInfo + = NoOccurrence + -- ^ The GRE could not be found, or it has the wrong parent. + | UniqueOccurrence GlobalRdrElt + -- ^ The GRE has no parent. It could be a pattern synonym. + | DisambiguatedOccurrence GlobalRdrElt + -- ^ The parent of the GRE is the correct parent. + | AmbiguousOccurrence (NE.NonEmpty GlobalRdrElt) + -- ^ The GRE is ambiguous. + -- + -- For example, two normal identifiers with the same name are in + -- scope. They will both be resolved to "UniqueOccurrence" and the + -- monoid will combine them to this failing case. + +instance Outputable DisambigInfo where + ppr NoOccurrence = text "NoOccurrence" + ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre + ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre + ppr (AmbiguousOccurrence gres) = text "Ambiguous:" <+> ppr gres + +instance Semi.Semigroup DisambigInfo where + -- These are the key lines: we prefer disambiguated occurrences to other + -- names. + _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g' + DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g' + + NoOccurrence <> m = m + m <> NoOccurrence = m + UniqueOccurrence g <> UniqueOccurrence g' + = AmbiguousOccurrence $ g NE.:| [g'] + UniqueOccurrence g <> AmbiguousOccurrence gs + = AmbiguousOccurrence (g `NE.cons` gs) + AmbiguousOccurrence gs <> UniqueOccurrence g' + = AmbiguousOccurrence (g' `NE.cons` gs) + AmbiguousOccurrence gs <> AmbiguousOccurrence gs' + = AmbiguousOccurrence (gs Semi.<> gs') + +instance Monoid DisambigInfo where + mempty = NoOccurrence + mappend = (Semi.<>) + +-- Lookup SubBndrOcc can never be ambiguous +-- +-- Records the result of looking up a child. +data ChildLookupResult + -- | We couldn't find a suitable name + = NameNotFound + -- | The child has an incorrect parent + | IncorrectParent ParentGRE -- ^ parent + GlobalRdrElt -- ^ child we were looking for + [Name] -- ^ list of possible parents + -- | We resolved to a child + | FoundChild GlobalRdrElt + +instance Outputable ChildLookupResult where + ppr NameNotFound = text "NameNotFound" + ppr (FoundChild n) = text "Found:" <+> ppr (greParent n) <+> ppr n + ppr (IncorrectParent parent g ns) + = text "IncorrectParent" + <+> hsep [ppr (parentGRE_name parent), ppr $ greName g, ppr ns] + +lookupSubBndrOcc :: DeprecationWarnings + -> ParentGRE + -> Subordinate + -> RdrName + -> RnM (Either NotInScopeError Name) +-- ^ Find all the things the 'RdrName' maps to, +-- and pick the one with the right 'Parent' 'Name'. +lookupSubBndrOcc warn_if_deprec the_parent what_subordinate rdr_name = + lookupExactOrOrig rdr_name (Right . greName) $ + -- This happens for built-in classes, see mod052 for example + do { child <- lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name + ; return $ case child of + FoundChild g -> Right (greName g) + NameNotFound -> Left unknown_sub + IncorrectParent {} -> Left unknown_sub } + -- See [Mismatched class methods and associated type families] + -- in TcInstDecls. + where + unknown_sub = UnknownSubordinate (parentGRE_name the_parent) what_subordinate + +{- Note [Family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family F a + data instance F T = X1 | X2 + +The 'data instance' decl has an *occurrence* of F (and T), and *binds* +X1 and X2. (This is unlike a normal data type declaration which would +bind F too.) So we want an AvailTC F [X1,X2]. + +Now consider a similar pair: + class C a where + data G a + instance C S where + data G S = Y1 | Y2 + +The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. + +But there is a small complication: in an instance decl, we don't use +qualified names on the LHS; instead we use the class to disambiguate. +Thus: + module M where + import Blib( G ) + class C a where + data G a + instance C S where + data G S = Y1 | Y2 +Even though there are two G's in scope (M.G and Blib.G), the occurrence +of 'G' in the 'instance C S' decl is unambiguous, because C has only +one associated type called G. This is exactly what happens for methods, +and it is only consistent to do the same thing for types. That's the +role of the function lookupTcdName; the (Maybe Name) give the class of +the enclosing instance decl, if any. + +Note [Looking up Exact RdrNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames are generated by: + +* Template Haskell (See Note [Binders in Template Haskell] in GHC.ThToHs) +* Derived instances (See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate) + +For data types and classes have Exact system Names in the binding +positions for constructors, TyCons etc. For example + [d| data T = MkT Int |] +when we splice in and convert to HsSyn RdrName, we'll get + data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... +These System names are generated by GHC.ThToHs.thRdrName + +But, constructors and the like need External Names, not System Names! +So we do the following + + * In GHC.Rename.Env.newTopSrcBinder we spot Exact RdrNames that wrap a + non-External Name, and make an External name for it. This is + the name that goes in the GlobalRdrEnv + + * When looking up an occurrence of an Exact name, done in + GHC.Rename.Env.lookupExactOcc, we find the Name with the right unique in the + GlobalRdrEnv, and use the one from the envt -- it will be an + External Name in the case of the data type/constructor above. + + * Exact names are also use for purely local binders generated + by TH, such as \x_33. x_33 + Both binder and occurrence are Exact RdrNames. The occurrence + gets looked up in the LocalRdrEnv by GHC.Rename.Env.lookupOccRn, and + misses, because lookupLocalRdrEnv always returns Nothing for + an Exact Name. Now we fall through to lookupExactOcc, which + will find the Name is not in the GlobalRdrEnv, so we just use + the Exact supplied Name. + +Note [Splicing Exact names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the splice $(do { x <- newName "x"; return (VarE x) }) +This will generate a (HsExpr RdrName) term that mentions the +Exact RdrName "x_56" (or whatever), but does not bind it. So +when looking such Exact names we want to check that it's in scope, +otherwise the type checker will get confused. To do this we need to +keep track of all the Names in scope, and the LocalRdrEnv does just that; +we consult it with RdrName.inLocalRdrEnvScope. + +There is another wrinkle. With TH and -XDataKinds, consider + $( [d| data Nat = Zero + data T = MkT (Proxy 'Zero) |] ) +After splicing, but before renaming we get this: + data Nat_77{tc} = Zero_78{d} + data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) +The occurrence of 'Zero in the data type for T has the right unique, +but it has a TcClsName name-space in its OccName. (This is set by +the ctxt_ns argument of Convert.thRdrName.) When we check that is +in scope in the GlobalRdrEnv, we need to look up the DataName namespace +too. (An alternative would be to make the GlobalRdrEnv also have +a Name -> GRE mapping.) + +Note [Template Haskell ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GlobalRdrEnv invariant says that if + occ -> [gre1, ..., gren] +then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv). +This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre). + +So how can we get multiple gres in lookupExactOcc_maybe? Because in +TH we might use the same TH NameU in two different name spaces. +eg (#7241): + $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) +Here we generate a type constructor and data constructor with the same +unique, but different name spaces. + +It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would +mean looking up the OccName in every name-space, just in case, and that +seems a bit brutal. So it's just done here on lookup. But we might +need to revisit that choice. + +Note [Usage for sub-bndrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you have this + import qualified M( C( f ) ) + instance M.C T where + f x = x +then is the qualified import M.f used? Obviously yes. +But the RdrName used in the instance decl is unqualified. In effect, +we fill in the qualification by looking for f's whose class is M.C +But when adding to the UsedRdrNames we must make that qualification +explicit (saying "used M.f"), otherwise we get "Redundant import of M.f". + +So we make up a suitable (fake) RdrName. But be careful + import qualified M + import M( C(f) ) + instance C T where + f x = x +Here we want to record a use of 'f', not of 'M.f', otherwise +we'll miss the fact that the qualified import is redundant. + +-------------------------------------------------- +-- Occurrences +-------------------------------------------------- +-} + +lookupLocatedOccRn :: WhatLooking + -> GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) +lookupLocatedOccRn what = wrapLocMA (lookupOccRn what) + +lookupLocatedOccRnConstr :: GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) +lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr + +lookupLocatedOccRnRecField :: GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) +lookupLocatedOccRnRecField = wrapLocMA lookupOccRnRecField + +lookupLocatedOccRnNone :: GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) +lookupLocatedOccRnNone = wrapLocMA lookupOccRnNone + +lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- Just look in the local environment +lookupLocalOccRn_maybe rdr_name + = do { local_env <- getLocalRdrEnv + ; return (lookupLocalRdrEnv local_env rdr_name) } + +lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevelIndex)) +-- Just look in the local environment +lookupLocalOccThLvl_maybe name + = do { lcl_env <- getLclEnv + ; return (lookupNameEnv (getLclEnvThBndrs lcl_env) name) } + +-- | lookupOccRn looks up an occurrence of a RdrName, and uses its argument to +-- determine what kind of suggestions should be displayed if it is not in scope +lookupOccRn :: WhatLooking -> RdrName -> RnM Name +lookupOccRn which_suggest rdr_name + = do { mb_gre <- lookupOccRn_maybe rdr_name + ; case mb_gre of + Just gre -> return $ greName gre + Nothing -> reportUnboundName which_suggest rdr_name } + +-- | Look up an occurrence of a 'RdrName'. +-- +-- Displays constructors and pattern synonyms as suggestions if +-- it is not in scope. +-- +-- See Note [lookupOccRnConstr] +lookupOccRnConstr :: RdrName -> RnM Name +lookupOccRnConstr rdr_name + = do { mb_gre <- lookupOccRn_maybe rdr_name + ; case mb_gre of + Just gre -> return $ greName gre + Nothing -> do + { mb_ty_gre <- lookup_promoted rdr_name + ; case mb_ty_gre of + Just gre -> return $ greName gre + Nothing -> + reportUnboundName WL_ConLike rdr_name + } } + +{- Note [lookupOccRnConstr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +lookupOccRnConstr looks up a data constructor or pattern synonym. Simple. + +However, there is a fallback to the type level when the lookup fails. +This is required to implement a pat-to-type transformation +(See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat) + +Consider this example: + + data VisProxy a where VP :: forall a -> VisProxy a + + f :: VisProxy Int -> () + f (VP Int) = () + +Here `Int` is actually a type, but it occurs in a position in which we expect +a data constructor. + +In all other cases we just use this additional lookup for better +error messaging (See Note [Promotion]). +-} + +-- lookupOccRnRecField looks up an occurrence of a RdrName and displays +-- record fields as suggestions if it is not in scope +lookupOccRnRecField :: RdrName -> RnM Name +lookupOccRnRecField = lookupOccRn WL_RecField + +-- lookupOccRnRecField looks up an occurrence of a RdrName and displays +-- no suggestions if it is not in scope +lookupOccRnNone :: RdrName -> RnM Name +lookupOccRnNone = lookupOccRn WL_None + +-- Only used in one place, to rename pattern synonym binders. +-- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind +lookupLocalOccRn :: RdrName -> RnM Name +lookupLocalOccRn rdr_name + = do { mb_name <- lookupLocalOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> unboundName (LF WL_TermVariable WL_LocalOnly) rdr_name } + +-- lookupTypeOccRn looks up an optionally promoted RdrName. +-- Used for looking up type variables. +lookupTypeOccRn :: RdrName -> RnM Name +-- see Note [Demotion] +lookupTypeOccRn rdr_name + = do { mb_gre <- lookupOccRn_maybe rdr_name + ; case mb_gre of + Just gre -> return $ greName gre + 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. +-} + +-- Used when looking up a term name (varName or dataName) in a type +lookup_demoted :: RdrName -> RnM Name +lookup_demoted rdr_name + | Just demoted_rdr <- demoteRdrNameTcCls rdr_name + -- Maybe it's the name of a *data* constructor + = do { data_kinds <- xoptM LangExt.DataKinds + ; star_is_type <- xoptM LangExt.StarIsType + ; let is_star_type = if star_is_type then StarIsType else StarIsNotType + star_is_type_hints = noStarIsTypeHints is_star_type rdr_name + ; if data_kinds + then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr + ; case mb_demoted_gre of + Nothing -> unboundNameX looking_for rdr_name star_is_type_hints + Just demoted_gre -> return $ greName demoted_gre} + else do { -- We need to check if a data constructor of this name is + -- in scope to give good error messages. However, we do + -- not want to give an additional error if the data + -- constructor happens to be out of scope! See #13947. + mb_demoted_name <- discardErrs $ + lookupOccRn_maybe demoted_rdr + ; let suggestion | isJust mb_demoted_name + , let additional = text "to refer to the data constructor of that name?" + = [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds] + | otherwise + = star_is_type_hints + ; unboundNameX looking_for rdr_name suggestion } } + + | isQual rdr_name, + Just demoted_rdr_name <- demoteRdrNameTv rdr_name + -- Definitely an illegal term variable, as type variables are never exported. + -- See Note [Demotion of unqualified variables] (W2) + = report_qualified_term_in_types rdr_name demoted_rdr_name + + | isUnqual rdr_name, + Just demoted_rdr_name <- demoteRdrNameTv rdr_name + -- See Note [Demotion of unqualified variables] + = do { required_type_arguments <- xoptM LangExt.RequiredTypeArguments + ; if required_type_arguments + then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr_name + ; case mb_demoted_gre of + Nothing -> unboundName (LF WL_Anything WL_Anywhere) rdr_name + Just demoted_gre -> return $ greName demoted_gre } + else unboundName looking_for rdr_name } + + | otherwise + = unboundName looking_for rdr_name + + where + looking_for = LF WL_Type WL_Anywhere + +{- Note [Demotion of unqualified variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Under RequiredTypeArguments, a term-level variable name (i.e. a name whose +`occNameSpace` is `varName` as opposed to `tvName`) does not necessarily denote +a term variable. It can actually stand for a type: + + {-# LANGUAGE RequiredTypeArguments #-} + idv :: forall a -> a -> a -- Note the "forall a ->" in the type + idv t (x :: t) = id @t x -- #23739 + -- ^ ^ ^ + -- varName tvName tvName -- NameSpace (GHC.Types.Name.Occurrence) + +The variable `t` is an alias for the type variable `a`, so it's valid to use it +in type-level contexts. The only problem is that the namespaces do not match. +Demotion allows us to connect the `tvName` usages to the `varName` binding. + +Demotion of an RdrName means that we change its namespace from tvName/tcClsName +to varName/dataName. Suppose we are looking up an occurrence of a variable `a` +in a type (in `lookupTypeOccRn`). The parser gave `a` a `tvName` occurrence, +so we try looking that up first. If that fails, and RequiredTypeArguments is +on, then "demote" it to the `varName` namespace with `demoteRdrNameTv` and look +that up instead. If that succeeds, use it. + +(W1) Wrinkle 1 + As a side effect of demotion, the renamer accepts all these examples: + t = True -- Ordinary term-level binding + x = Proxy @t -- (1) Bad usage in a HsExpr + type T = t -- (2) Bad usage in a TyClDecl + f :: t -> t -- (3) Bad usage in a SigDecl + + However, GHC doesn't promote arbitrary terms to types. See the "T2T-Mapping" + section of GHC Proposal #281: "In the type checking environment, the variable + must stand for a type variable". Even though the renamer accepts these + constructs, the type checker has to reject the uses of `t` shown above. + + All three examples are rejected with the `TermVariablePE` promotion error. + The error is generated by `tcTyVar` (GHC.Tc.Gen.HsType) + tcTyVar :: Name -> TcM (TcType, TcKind) + The first thing `tcTyVar` does is call the `tcLookup` helper (GHC.Tc.Utils.Env) + to find the variable in the type checking environment + tcLookup :: Name -> TcM TcTyThing + What happens next depends on the example in question. + + * In the HsExpr example (1), `tcLookup` finds `ATcId` that corresponds to + the `t = True` binding. The `ATcId` is then then turned into an error by + the following clause in `tcTyVar`: + ATcId{} -> promotionErr name TermVariablePE + + * In the TyClDecl example (2) and the SigDecl example (3), we don't have + `ATcId` in the environment just yet because type declarations and signatures + are type-checked /before/ term-level bindings. + + This means that `tcLookup` fails to find `t` in the local environment and + calls `tcLookupGlobal` (GHC.Tc.Utils.Env) + tcLookupGlobal :: Name -> TcM TyThing + + The global environment does not contain `t` either, so `tcLookupGlobal` + calls `notFound` (GHC.Tc.Utils.Env) + notFound :: Name -> TcM TyThing + + At this point GHC would normally generate a panic: if the variable is + neither in the local nor in the global environment, then it shouldn't have + passed the renamer. Unfortunately, this expectation is tiresome and + expensive to maintain, so we add a special case in `notFound` instead. + If the namespace of the variable is `varName`, the only explanation other + than a bug in GHC is that the user tried to use a term variable in a type + context. Hence the following clause in `notFound`: + _ | isTermVarOrFieldNameSpace (nameNameSpace name) -> + failWithTc $ TcRnUnpromotableThing name TermVariablePE + +(W2) Wrinkle 2 + Only unqualified variable names are demoted, e.g. `f` but not `M.f`. + The reason is that type variables are never bound to a qualified name: + they can't be bound at the top level of a module, nor can they be + exported or imported, so a qualified occurrence `M.f` must refer to a + term-level definition and is never legal at the type level. + Demotion of qualified names would not allow us to accept any new programs. + We use this fact to generate better suggestions in error messages, + see `report_qualified_term_in_types`. +-} + +-- Report a qualified variable name in a type signature: +-- badSig :: Prelude.head +-- ^^^^^^^^^^^ +report_qualified_term_in_types :: RdrName -> RdrName -> RnM Name +report_qualified_term_in_types rdr_name demoted_rdr_name = + do { mName <- lookupGlobalOccRn_maybe (RelevantGREsFOS WantNormal) demoted_rdr_name + ; case mName of + Just _ -> termNameInType looking_for rdr_name demoted_rdr_name [] + Nothing -> unboundTermNameInTypes looking_for rdr_name demoted_rdr_name } + where + looking_for = LF WL_Constructor WL_Global + +-- If the given RdrName can be promoted to the type level and its promoted variant is in scope, +-- lookup_promoted returns the corresponding type-level Name. +-- Otherwise, the function returns Nothing. +-- See Note [Promotion] below. +lookup_promoted :: RdrName -> RnM (Maybe GlobalRdrElt) +lookup_promoted rdr_name + | Just promoted_rdr <- promoteRdrName rdr_name + = lookupOccRn_maybe promoted_rdr + | otherwise + = return Nothing + +{- Note [Demotion] +~~~~~~~~~~~~~~~~~~ +When the user writes: + data Nat = Zero | Succ Nat + foo :: f Zero -> Int + +'Zero' in the type signature of 'foo' is parsed as: + HsTyVar ("Zero", TcClsName) + +When the renamer hits this occurrence of 'Zero' it's going to realise +that it's not in scope. But because it is renaming a type, it knows +that 'Zero' might be a promoted data constructor, so it will demote +its namespace to DataName and do a second lookup. + +The final result (after the renamer) will be: + HsTyVar ("Zero", DataName) + +Another case of demotion happens when the user tries to +use a qualified term at the type level: + + f :: Prelude.id -> Int + +This signature passes the parser to be caught by the renamer. +It allows the compiler to create more informative error messages. + +'Prelude.id' in the type signature is parsed as + HsTyVar ("id", TvName) + +To separate the case of a typo from the case of an +intentional attempt to use an imported term's name the compiler demotes +the namespace to VarName (using 'demoteTvNameSpace') and does a lookup. + +The same type of demotion happens when the compiler needs to check +if a name of a type variable has already been used for a term that is in scope. +We need to do it to check if a user should change the name +to make his code compatible with the RequiredTypeArguments extension. + +Note [Promotion] +~~~~~~~~~~~~~~~ +When the user mentions a type constructor or a type variable in a +term-level context, then we report that a value identifier was expected +instead of a type-level one. That makes error messages more precise. +Previously, such errors contained only the info that a given value was out of scope (#18740). +We promote the namespace of RdrName and look up after that +(see the functions promotedRdrName and lookup_promoted). + +In particular, we have the following error message + • Illegal term-level use of the type constructor ‘Int' + imported from ‘Prelude' (and originally defined in ‘GHC.Types') + • In the first argument of ‘id' + In the expression: id Int + In an equation for ‘x': x = id Int + +when the user writes the following declaration + + x = id Int +-} + +lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (GlobalRdrElt -> RnM r) -> RdrName + -> RnM (Maybe r) +lookupOccRnX_maybe globalLookup wrapper rdr_name + = runMaybeT . msum . map MaybeT $ + [ do { res <- lookupLocalOccRn_maybe rdr_name + ; case res of + { Nothing -> return Nothing + ; Just nm -> + -- Elements in the LocalRdrEnv are always Vanilla GREs + do { let gre = mkLocalVanillaGRE NoParent nm + ; Just <$> wrapper gre } } } + , globalLookup rdr_name ] + +lookupOccRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupOccRn_maybe = + lookupOccRnX_maybe + (lookupGlobalOccRn_maybe $ RelevantGREsFOS WantNormal) + return + +-- Used outside this module only by TH name reification (lookupName, lookupThName_maybe) +lookupSameOccRn_maybe :: RdrName -> RnM (Maybe Name) +lookupSameOccRn_maybe = + lookupOccRnX_maybe + (get_name <$> lookupGlobalOccRn_maybe SameNameSpace) + (return . greName) + where + get_name :: RnM (Maybe GlobalRdrElt) -> RnM (Maybe Name) + get_name = fmap (fmap greName) + +-- | Look up a 'RdrName' used as a variable in an expression. +-- +-- This may be a local variable, global variable, or one or more record selector +-- functions. It will not return record fields created with the +-- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]). +-- +-- If the name is not in scope at the term level, but its promoted equivalent is +-- in scope at the type level, the lookup will succeed (so that the type-checker +-- can report a more informative error later). See Note [Promotion]. +-- +lookupExprOccRn :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupExprOccRn rdr_name + = do { mb_name <- lookupOccRnX_maybe + lookupGlobalOccRn_overloaded + return + rdr_name + ; case mb_name of + Nothing -> lookup_promoted rdr_name + -- See Note [Promotion]. + -- We try looking up the name as a + -- type constructor or type variable, if + -- we failed to look up the name at the term level. + p -> return p } + +lookupGlobalOccRn_maybe :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) +-- Looks up a RdrName occurrence in the top-level +-- environment, including using lookupQualifiedNameGHCi +-- for the GHCi case, but first tries to find an Exact or Orig name. +-- No filter function; does not report an error on failure +-- See Note [Errors in lookup functions] +-- Uses addUsedRdrName to record use and deprecations +-- +-- Used directly only by getLocalNonValBinders (new_assoc). +lookupGlobalOccRn_maybe which_gres rdr_name = + lookupExactOrOrig_maybe rdr_name id $ + lookupGlobalOccRn_base which_gres rdr_name + +-- Looks up a RdrName occurrence in the GlobalRdrEnv and with +-- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first. +-- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like +-- 'Data.Map.elems' is typed, even if you didn't import Data.Map +lookupGlobalOccRn_base :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) +lookupGlobalOccRn_base which_gres rdr_name = + runMaybeT . msum . map MaybeT $ + [ lookupGreRn_maybe which_gres rdr_name + , lookupOneQualifiedNameGHCi fos rdr_name ] + -- This test is not expensive, + -- and only happens for failed lookups + where + fos = case which_gres of + RelevantGREs { includeFieldSelectors = sel } -> sel + _ -> if isFieldOcc (rdrNameOcc rdr_name) + then WantField + else WantNormal + +-- | Lookup a 'Name' in the 'GlobalRdrEnv', falling back to looking up +-- in the type environment it if fails. +lookupGREInfo_GRE :: HasDebugCallStack => Name -> RnM GREInfo +lookupGREInfo_GRE name + = do { rdr_env <- getGlobalRdrEnv + ; case lookupGRE_Name rdr_env name of + Just ( GRE { gre_info = info } ) + -> return info + _ -> do { hsc_env <- getTopEnv + ; return $ lookupGREInfo hsc_env name } } + -- Just looking in the GlobalRdrEnv is insufficient, as we also + -- need to handle qualified imports in GHCi; see e.g. T9815ghci. + +lookupInfoOccRn :: RdrName -> RnM [Name] +-- ^ lookupInfoOccRn is intended for use in GHCi's ":info" command +-- It finds all the GREs that RdrName could mean, not complaining +-- about ambiguity, but rather returning them all (c.f. #9881). +-- +-- lookupInfoOccRn is also used in situations where we check for +-- at least one definition of the RdrName, not complaining about +-- multiple definitions (see #17832). +lookupInfoOccRn rdr_name = + lookupExactOrOrig rdr_name (\ gre -> [greName gre]) $ + do { rdr_env <- getGlobalRdrEnv + ; let nms = map greName $ lookupGRE rdr_env (LookupRdrName rdr_name (RelevantGREsFOS WantBoth)) + ; qual_nms <- map greName <$> lookupQualifiedNameGHCi WantBoth rdr_name + ; return $ nms ++ (qual_nms `minusList` nms) } + +-- | Look up all record field names, available in the 'GlobalRdrEnv', +-- that a given 'RdrName' might refer to. +-- (Also includes implicit qualified imports in GHCi). +-- +-- Throws an error if no fields are found. +-- +-- See Note [DisambiguateRecordFields for updates]. +lookupFieldGREs :: GlobalRdrEnv -> LocatedN RdrName -> RnM (NE.NonEmpty FieldGlobalRdrElt) +lookupFieldGREs env (L loc rdr) + = setSrcSpanA loc + $ do { res <- lookupExactOrOrig rdr (\ gre -> maybeToList $ fieldGRE_maybe gre) $ + do { let (env_fld_gres, env_var_gres) = + partition isRecFldGRE $ + lookupGRE env (LookupRdrName rdr (RelevantGREsFOS WantBoth)) + -- Make sure to use 'LookupRdrName': if a record update contains + -- a qualified field name, only look up GREs which are in scope + -- with that same qualification. + -- + -- See Wrinkle [Qualified names in record updates] + -- in Note [Disambiguating record updates] in GHC.Rename.Pat. + + -- Handle implicit qualified imports in GHCi. See T10439. + ; ghci_gres <- lookupQualifiedNameGHCi WantBoth rdr + ; let (ghci_fld_gres, ghci_var_gres) = + partition isRecFldGRE $ + ghci_gres + + ; let fld_gres = ghci_fld_gres ++ env_fld_gres + var_gres = ghci_var_gres ++ env_var_gres + + -- Add an error for ambiguity when -XDisambiguateRecordFields is off. + -- + -- See Note [DisambiguateRecordFields for updates]. + ; disamb_ok <- xoptM LangExt.DisambiguateRecordFields + ; if | not disamb_ok + , gre1 : gre2 : others <- fld_gres ++ var_gres + -> addErrTc $ TcRnAmbiguousFieldInUpdate (gre1, gre2, others) + | otherwise + -> return () + ; return fld_gres } + + -- Add an error if lookup failed. + ; case res of + { gre : gres -> return $ gre NE.:| gres + ; [] -> + do { show_helpful_errors <- goptM Opt_HelpfulErrors + ; (imp_errs, hints) <- + if show_helpful_errors + then unknownNameSuggestions emptyLocalRdrEnv WL_RecField rdr + else return ([], []) + ; err_msg <- unknownNameSuggestionsMessage (TcRnNotInScope NotARecordField rdr) imp_errs hints + ; failWithTc err_msg + } } } + +-- | Look up a 'RdrName', which might refer to an overloaded record field. +-- +-- Don't allow any ambiguity: emit a name-clash error if there are multiple +-- matching GREs. +lookupGlobalOccRn_overloaded :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupGlobalOccRn_overloaded rdr_name = + lookupExactOrOrig_maybe rdr_name id $ + do { res <- lookupGreRn_helper (RelevantGREsFOS WantNormal) rdr_name AllDeprecationWarnings + ; case res of + GreNotFound -> lookupOneQualifiedNameGHCi WantNormal rdr_name + OneNameMatch gre -> return $ Just gre + MultipleNames gres@(gre NE.:| _) -> do + addNameClashErrRn rdr_name gres + return (Just gre) } + +getFieldUpdLbl :: IsPass p => LHsRecUpdField (GhcPass p) q -> LocatedN RdrName +getFieldUpdLbl = fieldOccLRdrName . unLoc . hfbLHS . unLoc + +-- | Returns all possible collections of field labels for the given +-- record update. +-- +-- Example: +-- +-- data D = MkD { fld1 :: Int, fld2 :: Bool } +-- data E = MkE1 { fld1 :: Int, fld2 :: Bool, fld3 :: Char } +-- | MkE2 { fld1 :: Int, fld2 :: Bool } +-- data F = MkF1 { fld1 :: Int } | MkF2 { fld2 :: Bool } +-- +-- f r = r { fld1 = a, fld2 = b } +-- +-- This function will return: +-- +-- [ [ D.fld1, D.fld2 ] -- could be a record update at type D +-- , [ E.fld1, E.fld2 ] -- could be a record update at type E +-- ] -- cannot be a record update at type F: no constructor has both +-- -- of the fields fld1 and fld2 +-- +-- If there are no valid parents for the record update, +-- throws a 'TcRnBadRecordUpdate' error. +lookupRecUpdFields :: NE.NonEmpty (LHsRecUpdField GhcPs GhcPs) + -> RnM (NE.NonEmpty (HsRecUpdParent GhcRn)) +lookupRecUpdFields flds +-- See Note [Disambiguating record updates] in GHC.Rename.Pat. + = do { -- (1) Retrieve the possible GlobalRdrElts that each field could refer to. + ; gre_env <- getGlobalRdrEnv + ; fld1_gres NE.:| other_flds_gres <- mapM (lookupFieldGREs gre_env . getFieldUpdLbl) flds + -- (2) Take an intersection: we are only interested in constructors + -- which have all of the fields. + ; let possible_GREs = intersect_by_cons fld1_gres other_flds_gres + + ; traceRn "lookupRecUpdFields" $ + vcat [ text "flds:" <+> ppr (fmap getFieldUpdLbl flds) + , text "possible_GREs:" <+> + ppr (map (fmap greName . rnRecUpdLabels) possible_GREs) ] + + ; case possible_GREs of + + -- (3) (a) There is at least one parent: we can proceed. + -- The typechecker might be able to finish disambiguating. + -- See Note [Type-directed record disambiguation] in GHC.Rename.Pat. + { p1:ps -> return (p1 NE.:| ps) + + -- (3) (b) There are no possible parents for the record update: + -- compute a minimal set of fields which does not belong to any + -- data constructor, to report an informative error to the user. + ; _ -> do + hsc_env <- getTopEnv + let + -- The constructors which have the first field. + fld1_cons :: UniqSet ConLikeName + fld1_cons = unionManyUniqSets + $ NE.toList + $ NE.map (recFieldCons . fieldGREInfo) fld1_gres + -- The field labels of the constructors which have the first field. + fld1_cons_fields :: UniqFM ConLikeName [FieldLabel] + fld1_cons_fields + = fmap (lkp_con_fields hsc_env gre_env) + $ getUniqSet fld1_cons + failWithTc $ badFieldsUpd (NE.toList flds) fld1_cons_fields } } + + where + intersect_by_cons :: NE.NonEmpty FieldGlobalRdrElt + -> [NE.NonEmpty FieldGlobalRdrElt] + -> [HsRecUpdParent GhcRn] + intersect_by_cons this [] = + map + (\ fld -> RnRecUpdParent (fld NE.:| []) (recFieldCons (fieldGREInfo fld))) + (NE.toList this) + intersect_by_cons this (new : rest) = + [ RnRecUpdParent (this_fld NE.<| next_flds) both_cons + | this_fld <- NE.toList this + , let this_cons = recFieldCons $ fieldGREInfo this_fld + , RnRecUpdParent next_flds next_cons <- intersect_by_cons new rest + , let both_cons = next_cons `intersectUniqSets` this_cons + , not $ isEmptyUniqSet both_cons + ] + + -- Look up all in-scope fields of a 'ConLike'. + lkp_con_fields :: HscEnv -> GlobalRdrEnv -> ConLikeName -> [FieldLabel] + lkp_con_fields hsc_env gre_env con = + [ fl + | let con_nm = conLikeName_Name con + gre_info = + (greInfo <$> lookupGRE_Name gre_env con_nm) + `orElse` + lookupGREInfo hsc_env con_nm + -- See Wrinkle [Out of scope constructors] + -- in Note [Disambiguating record updates] in GHC.Rename.Pat. + , IAmConLike con_info <- [ gre_info ] + , fl <- conInfoFields con_info + , isJust $ lookupGRE_FieldLabel gre_env fl + -- Ensure the fields are in scope. + ] + +{-********************************************************************** +* * + Record field errors +* * +**********************************************************************-} + +getUpdFieldLbls :: forall p q. IsPass p + => [LHsRecUpdField (GhcPass p) q] -> [RdrName] +getUpdFieldLbls + = map $ fieldOccRdrName + . unXRec @(GhcPass p) + . hfbLHS + . unXRec @(GhcPass p) + +-- | Create an error message when there is no single 'ConLike' which +-- has all of the required fields for a record update. +-- +-- This boils down the problem to a smaller set of fields, to avoid +-- the error message containing a lot of uninformative field names that +-- aren't really relevant to the problem. +-- +-- NB: this error message should only be triggered when all the field names +-- are in scope. It's OK if the constructors themselves are not in scope +-- (see Wrinkle [Out of scope constructors] in Note [Disambiguating record updates] +-- in GHC.Rename.Pat). +badFieldsUpd + :: (OutputableBndrId p) + => [LHsRecUpdField (GhcPass p) q] + -- ^ Field names that don't belong to a single datacon + -> UniqFM ConLikeName [FieldLabel] + -- ^ The list of field labels for each constructor. + -- (These are the constructors in which the first field occurs.) + -> TcRnMessage +badFieldsUpd rbinds fld1_cons_fields + = TcRnBadRecordUpdate + (getUpdFieldLbls rbinds) + (NoConstructorHasAllFields conflictingFields) + -- See Note [Finding the conflicting fields] + where + -- A (preferably small) set of fields such that no constructor contains + -- all of them. See Note [Finding the conflicting fields] + conflictingFields = case nonMembers of + -- nonMember belongs to a different type. + (nonMember, _) : _ -> [aMember, nonMember] + [] -> let + -- All of rbinds belong to one type. In this case, repeatedly add + -- a field to the set until no constructor contains the set. + + -- Each field, together with a list indicating which constructors + -- have all the fields so far. + growingSets :: [(FieldLabelString, [Bool])] + growingSets = scanl1 combine membership + combine (_, setMem) (field, fldMem) + = (field, zipWith (&&) setMem fldMem) + in + -- Fields that don't change the membership status of the set + -- are redundant and can be dropped. + map (fst . NE.head) $ NE.groupBy ((==) `on` snd) growingSets + + aMember = assert (not (null members) ) fst (head members) + (members, nonMembers) = partition (or . snd) membership + + -- For each field, which constructors contain the field? + membership :: [(FieldLabelString, [Bool])] + membership + = sortMembership $ + map + ( (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) + . FieldLabelString . occNameFS . rdrNameOcc . unLoc . getFieldUpdLbl ) + rbinds + + fieldLabelSets :: [UniqSet FieldLabelString] + fieldLabelSets = map (mkUniqSet . map flLabel) $ nonDetEltsUFM fld1_cons_fields + + -- Sort in order of increasing number of True, so that a smaller + -- conflicting set can be found. + sortMembership = + map snd . + sortBy (compare `on` fst) . + map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) + + countTrue = count id + +{- +Note [Finding the conflicting fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data A = A {a0, a1 :: Int} + | B {b0, b1 :: Int} +and we see a record update + x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } +Then we'd like to find the smallest subset of fields that no +constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. +We don't really want to report that no constructor has all of +{a0,a1,b0,b1}, because when there are hundreds of fields it's +hard to see what was really wrong. + +We may need more than two fields, though; eg + data T = A { x,y :: Int, v::Int } + | B { y,z :: Int, v::Int } + | C { z,x :: Int, v::Int } +with update + r { x=e1, y=e2, z=e3 }, we + +Finding the smallest subset is hard, so the code here makes +a decent stab, no more. See #7989. +-} + +-------------------------------------------------- +-- Lookup in the Global RdrEnv of the module +-------------------------------------------------- + +data GreLookupResult = GreNotFound + | OneNameMatch GlobalRdrElt + | MultipleNames (NE.NonEmpty GlobalRdrElt) + +lookupGreRn_maybe :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) +-- Look up the RdrName in the GlobalRdrEnv +-- Exactly one binding: records it as "used", return (Just gre) +-- No bindings: return Nothing +-- Many bindings: report "ambiguous", return an arbitrary (Just gre) +-- Uses addUsedRdrName to record use and deprecations +lookupGreRn_maybe which_gres rdr_name + = do + res <- lookupGreRn_helper which_gres rdr_name AllDeprecationWarnings + case res of + OneNameMatch gre -> return $ Just gre + MultipleNames gres -> do + traceRn "lookupGreRn_maybe:NameClash" (ppr gres) + addNameClashErrRn rdr_name gres + return $ Just (NE.head gres) + GreNotFound -> return Nothing + +{- + +Note [ Unbound vs Ambiguous Names ] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +lookupGreRn_maybe deals with failures in two different ways. If a name +is unbound then we return a `Nothing` but if the name is ambiguous +then we raise an error and return a dummy name. + +The reason for this is that when we call `lookupGreRn_maybe` we are +speculatively looking for whatever we are looking up. If we don't find it, +then we might have been looking for the wrong thing and can keep trying. +On the other hand, if we find a clash then there is no way to recover as +we found the thing we were looking for but can no longer resolve which +the correct one is. + +One example of this is in `lookupTypeOccRn` which first looks in the type +constructor namespace before looking in the data constructor namespace to +deal with `DataKinds`. + +There is however, as always, one exception to this scheme. If we find +an ambiguous occurrence of a record selector and DuplicateRecordFields +is enabled then we defer the selection until the typechecker. + +-} + + +-- Internal Function +lookupGreRn_helper :: WhichGREs GREInfo -> RdrName -> DeprecationWarnings -> RnM GreLookupResult +lookupGreRn_helper which_gres rdr_name warn_if_deprec + = do { env <- getGlobalRdrEnv + ; case lookupGRE env (LookupRdrName rdr_name which_gres) of + [] -> return GreNotFound + [gre] -> do { addUsedGRE warn_if_deprec gre + ; return (OneNameMatch gre) } + -- Don't record usage for ambiguous names + -- until we know which is meant + (gre:others) -> return (MultipleNames (gre NE.:| others)) } + +lookupGreAvailRn :: WhatLooking -> RdrName -> RnM (Maybe GlobalRdrElt) +-- Used in export lists +-- If not found or ambiguous, add error message, and fake with UnboundName +-- Uses addUsedRdrName to record use and deprecations +lookupGreAvailRn what_looking rdr_name + = do + mb_gre <- lookupGreRn_helper (RelevantGREsFOS WantNormal) rdr_name ExportDeprecationWarnings + case mb_gre of + GreNotFound -> + do + traceRn "lookupGreAvailRn" (ppr rdr_name) + _ <- unboundName (LF what_looking WL_Global) rdr_name + return Nothing + MultipleNames gres -> + do + addNameClashErrRn rdr_name gres + return Nothing + -- Prevent error cascade + OneNameMatch gre -> + return $ Just gre + +{- +********************************************************* +* * + Deprecations +* * +********************************************************* + +Note [Using isImportedGRE in addUsedGRE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In addUsedGRE, we want to add any used imported GREs to the tcg_used_gres field, +so that we can emit appropriate warnings (see GHC.Rename.Names.warnUnusedImportDecls). + +We want to do this for GREs that were brought into scope through imports. As per +Note [GlobalRdrElt provenance] in GHC.Types.Name.Reader, this means we should +check that gre_imp is non-empty. Checking that gre_lcl is False is INCORRECT, +because we might have obtained the GRE by an Exact or Orig direct reference, +in which case we have both gre_lcl = False and gre_imp = emptyBag. + +Geting this wrong can lead to panics in e.g. bestImport, see #23240. +-} + +addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM () +-- Remember use of in-scope data constructors (#7969) +addUsedDataCons rdr_env tycon + = addUsedGREs NoDeprecationWarnings + [ gre + | dc <- tyConDataCons tycon + , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ] + +addUsedGRE :: DeprecationWarnings -> GlobalRdrElt -> RnM () +-- Called for both local and imported things +-- Add usage *and* warn if deprecated +addUsedGRE warn_if_deprec gre + = do { warnIfDeprecated warn_if_deprec [gre] + ; when (isImportedGRE gre) $ -- See Note [Using isImportedGRE in addUsedGRE] + do { env <- getGblEnv + -- Do not report the GREInfo (#23424) + ; traceRn "addUsedGRE" (ppr $ greName gre) + ; updTcRef (tcg_used_gres env) (gre :) } } + +addUsedGREs :: DeprecationWarnings -> [GlobalRdrElt] -> RnM () +-- Record uses of any *imported* GREs +-- Used for recording used sub-bndrs +-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] in GHC.Rename.Utils +addUsedGREs warn_if_deprec gres + = do { warnIfDeprecated warn_if_deprec gres + ; unless (null imp_gres) $ + do { env <- getGblEnv + -- Do not report the GREInfo (#23424) + ; traceRn "addUsedGREs" (ppr $ map greName imp_gres) + ; updTcRef (tcg_used_gres env) (imp_gres ++) } } + where + imp_gres = filter isImportedGRE gres + -- See Note [Using isImportedGRE in addUsedGRE] + +{- +Note [Used names with interface not loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's (just) possible to find a used +Name whose interface hasn't been loaded: + +a) It might be a WiredInName; in that case we may not load + its interface (although we could). + +b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger + These are seen as "used" by the renamer (if -XRebindableSyntax) + is on), but the typechecker may discard their uses + if in fact the in-scope fromRational is GHC.Read.fromRational, + (see tcPat.tcOverloadedLit), and the typechecker sees that the type + is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). + In that obscure case it won't force the interface in. + +In both cases we simply don't permit deprecations; +this is, after all, wired-in stuff. + + +********************************************************* +* * + GHCi support +* * +********************************************************* + +A qualified name on the command line can refer to any module at +all: we try to load the interface if we don't already have it, just +as if there was an "import qualified M" declaration for every +module. + +For example, writing `Data.List.sort` will load the interface file for +`Data.List` as if the user had written `import qualified Data.List`. + +If we fail we just return Nothing, rather than bleating +about "attempting to use module 'D' (./D.hs) which is not loaded" +which is what loadSrcInterface does. + +It is enabled by default and disabled by the flag +`-fno-implicit-import-qualified`. + +Note [Safe Haskell and GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We DON'T do this Safe Haskell as we need to check imports. We can +and should instead check the qualified import but at the moment +this requires some refactoring so leave as a TODO + +Note [DuplicateRecordFields and -fimplicit-import-qualified] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When DuplicateRecordFields is used, a single module can export the same OccName +multiple times, for example: + + module M where + data S = MkS { foo :: Int } + data T = MkT { foo :: Int } + +Now if we refer to M.foo via -fimplicit-import-qualified, we need to report an +ambiguity error. + +-} + +-- | Like 'lookupQualifiedNameGHCi' but returning at most one name, reporting an +-- ambiguity error if there are more than one. +lookupOneQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM (Maybe GlobalRdrElt) +lookupOneQualifiedNameGHCi fos rdr_name = do + all_gres <- lookupQualifiedNameGHCi fos rdr_name + case all_gres of + [] -> return Nothing + [gre] -> return $ Just $ gre + (gre:gres) -> + do addNameClashErrRn rdr_name (gre NE.:| gres) + return (Just (mkUnboundGRE $ greOccName gre)) + -- (Use mkUnboundGRE to get the correct namespace) + +-- | Look up *all* the names to which the 'RdrName' may refer in GHCi (using +-- @-fimplicit-import-qualified@). This will normally be zero or one, but may +-- be more in the presence of @DuplicateRecordFields@. +lookupQualifiedNameGHCi :: HasDebugCallStack => FieldsOrSelectors -> RdrName -> RnM [GlobalRdrElt] +lookupQualifiedNameGHCi fos rdr_name + = -- We want to behave as we would for a source file import here, + -- and respect hiddenness of modules/packages, hence loadSrcInterface. + do { dflags <- getDynFlags + ; is_ghci <- getIsGHCi + ; go_for_it dflags is_ghci } + + where + go_for_it dflags is_ghci + | Just (mod_name,occ) <- isQual_maybe rdr_name + , let ns = occNameSpace occ + , 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_name NotBoot NoPkgQual + ; case res of + Succeeded iface + -> do { hsc_env <- getTopEnv + ; let gres = + [ gre + | avail <- mi_exports iface + , gname <- availNames avail + , let lk_occ = occName gname + lk_ns = occNameSpace lk_occ + , occNameFS occ == occNameFS lk_occ + , ns == lk_ns || (ns == varName && isFieldNameSpace lk_ns) + , let mod = mi_module iface + gre = lookupGRE_PTE mod hsc_env gname + , allowGRE fos gre + -- Include a field if it has a selector or we are looking for all fields; + -- see Note [NoFieldSelectors]. + ] + ; return gres } + + _ -> -- Either we couldn't load the interface, or + -- we could but we didn't find the name in it + do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name) + ; return [] } } + + | otherwise + = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name) + ; return [] } + + doc = text "Need to find" <+> ppr rdr_name + + -- Lookup a Name for an implicit qualified import in GHCi + -- in the given PackageTypeEnv. + lookupGRE_PTE :: Module -> HscEnv -> Name -> GlobalRdrElt + lookupGRE_PTE mod hsc_env nm = + -- Fake a GRE so we can report a sensible name clash error if + -- -fimplicit-import-qualified is used with a module that exports the same + -- field name multiple times (see + -- Note [DuplicateRecordFields and -fimplicit-import-qualified]). + GRE { gre_name = nm + , gre_par = NoParent + , gre_lcl = False + , gre_imp = unitBag is + , gre_info = info } + where + info = lookupGREInfo hsc_env nm + spec = ImpDeclSpec { is_mod = mod + , is_as = moduleName mod + , is_pkg_qual = NoPkgQual + , is_qual = True + , is_isboot = NotBoot + , is_dloc = noSrcSpan + , is_level = NormalLevel } + is = ImpSpec { is_decl = spec, is_item = ImpAll } + +-- | Look up the 'GREInfo' associated with the given 'Name' +-- by looking up in the type environment. +lookupGREInfo :: HasDebugCallStack => HscEnv -> Name -> GREInfo +lookupGREInfo hsc_env nm + | Just ty_thing <- wiredInNameTyThing_maybe nm + = tyThingGREInfo ty_thing + | otherwise + -- Create a thunk which, when forced, loads the interface + -- and looks up the TyThing in the type environment. + -- + -- See Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. + -- Note: This function is very similar to 'tcIfaceGlobal', it would be better to + -- use that if possible. + = case nameModule_maybe nm of + Nothing -> UnboundGRE + Just mod -> + unsafePerformIO $ do + _ <- initIfaceLoad hsc_env $ + loadInterface (text "lookupGREInfo" <+> parens (ppr nm)) + mod ImportBySystem + mb_ty_thing <- lookupType hsc_env nm + case mb_ty_thing of + Nothing -> do + pprPanic "lookupGREInfo" $ + vcat [ text "lookup failed:" <+> ppr nm ] + Just ty_thing -> return $ tyThingGREInfo ty_thing + +{- +Note [Looking up signature names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +lookupSigOccRn is used for type signatures and pragmas +Is this valid? + module A + import M( f ) + f :: Int -> Int + f x = x +It's clear that the 'f' in the signature must refer to A.f +The Haskell98 report does not stipulate this, but it will! +So we must treat the 'f' in the signature in the same way +as the binding occurrence of 'f', using lookupBndrRn + +However, consider this case: + import M( f ) + f :: Int -> Int + g x = x +We don't want to say 'f' is out of scope; instead, we want to +return the imported 'f', so that later on the renamer will +correctly report "misplaced type sig". + +Note [Signatures for top level things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +data HsSigCtxt = ... | TopSigCtxt NameSet | .... + +* The NameSet says what is bound in this group of bindings. + We can't use isLocalGRE from the GlobalRdrEnv, because of this: + f x = x + $( ...some TH splice... ) + f :: Int -> Int + When we encounter the signature for 'f', the binding for 'f' + will be in the GlobalRdrEnv, and will be a LocalDef. Yet the + signature is mis-placed + +* For type signatures the NameSet should be the names bound by the + value bindings; for fixity declarations, the NameSet should also + include class sigs and record selectors + + infix 3 `f` -- Yes, ok + f :: C a => a -> a -- No, not ok + class C a where + f :: a -> a + +Note [Signatures in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class C a where + op :: a -> a + nop :: a -> a + + instance C ty where + bop :: [a] -> [a] + bop x = x + + nop :: [a] -> [a] + +When renameing the `bop` binding we'll give it an UnboundName (still with +OccName "bop") because `bop` is not a method of C. Then + +* when doing lookupSigOcc on `bop :: blah` we want to find `bop`, even though it + is an UnboundName (failing to do this causes #16610, and #25437) + +* When doing lookupSigOcc on `nop :: blah` we want to complain that there + is no accompanying binding, even though `nop` is a class method +-} + +data HsSigCtxt + = TopSigCtxt NameSet -- At top level, binding these names + -- See Note [Signatures for top level things] + | LocalBindCtxt NameSet -- In a local binding, binding these names + | ClsDeclCtxt Name -- Class decl for this class + | InstDeclCtxt (OccEnv Name) -- Instance decl whose user-written method + -- bindings are described by this OccEnv + | HsBootCtxt NameSet -- Top level of a hs-boot file, binding these names + | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types + -- in the group + +instance Outputable HsSigCtxt where + ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns + ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns + ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n + ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns + ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns + ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns + +lookupSigOccRn :: HsSigCtxt + -> Sig GhcPs + -> GenLocated (EpAnn ann) RdrName + -> RnM (GenLocated (EpAnn ann) Name) +lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (SigLikeSig sig) + +-- | Lookup a name in relation to the names in a 'HsSigCtxt' +lookupSigCtxtOccRn :: HsSigCtxt + -> SigLike -- ^ what are we looking for, e.g. a type family + -> GenLocated (EpAnn ann) RdrName + -> RnM (GenLocated (EpAnn ann) Name) +lookupSigCtxtOccRn ctxt what + = wrapLocMA $ \ rdr_name -> + do { let also_try_tycons = False + ; mb_names <- lookupBindGroupOcc ctxt what rdr_name also_try_tycons NoNamespaceSpecifier + ; case mb_names of + Right name NE.:| rest -> + do { massertPpr (null rest) $ + vcat (text "lookupSigCtxtOccRn" <+> ppr name : map (either (pprScopeError rdr_name) ppr) rest) + ; return name } + Left err NE.:| _ -> + do { addErr $ TcRnNotInScope err rdr_name + ; return (mkUnboundNameRdr rdr_name) } + } + +lookupBindGroupOcc :: HsSigCtxt + -> SigLike -- ^ what kind of thing are we looking for? + -> RdrName -- ^ what to look up + -> Bool -- ^ if the 'RdrName' we are looking up is in + -- a value 'NameSpace', should we also look up + -- in the type constructor 'NameSpace'? + -> NamespaceSpecifier + -> RnM (NE.NonEmpty (Either NotInScopeError Name)) +-- ^ Looks up the 'RdrName', expecting it to resolve to one of the +-- bound names currently in scope. If not, return an appropriate error message. +-- +-- See Note [Looking up signature names]. +lookupBindGroupOcc ctxt what rdr_name also_try_tycon_ns ns_spec + | Just n <- isExact_maybe rdr_name + = do { mb_gre <- lookupExactOcc_either n + ; return $ case mb_gre of + Left err -> NE.singleton $ Left err + Right gre -> finish (NoExactName $ greName gre) gre } + -- Maybe we should check the side conditions + -- but it's a pain, and Exact things only show + -- up when you know what you are doing + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { NE.singleton . Right <$> lookupOrig rdr_mod rdr_occ } + + | otherwise + = case ctxt of + HsBootCtxt ns -> lookup_top (elem_name_set_with_namespace ns) + TopSigCtxt ns -> lookup_top (elem_name_set_with_namespace ns) + RoleAnnotCtxt ns -> lookup_top (elem_name_set_with_namespace ns) + LocalBindCtxt ns -> lookup_group ns + ClsDeclCtxt cls -> lookup_cls_op cls + InstDeclCtxt occ_env-> lookup_inst occ_env + where + elem_name_set_with_namespace ns n = check_namespace n && (n `elemNameSet` ns) + + check_namespace = coveredByNamespaceSpecifier ns_spec . nameNameSpace + + namespace = occNameSpace occ + occ = rdrNameOcc rdr_name + ok_gre = greIsRelevant relevant_gres namespace + relevant_gres = RelevantGREs { includeFieldSelectors = WantBoth + , lookupVariablesForFields = True + , lookupTyConsAsWell = also_try_tycon_ns } + + finish err gre + | ok_gre gre + = NE.singleton (Right (greName gre)) + | otherwise + = NE.singleton (Left err) + + succeed_with n = return $ NE.singleton $ Right n + + lookup_cls_op cls + = NE.singleton <$> + lookupSubBndrOcc AllDeprecationWarnings + (ParentGRE cls (IAmTyCon ClassFlavour)) + MethodOfClass rdr_name + + lookup_inst occ_env -- See Note [Signatures in instance decls] + = case lookupOccEnv occ_env occ of + Nothing -> bale_out_with [] + Just n -> succeed_with n + + lookup_top keep_me + = do { env <- getGlobalRdrEnv + ; let occ = rdrNameOcc rdr_name + all_gres = lookupGRE env (LookupOccName occ relevant_gres) + names_in_scope = -- If rdr_name lacks a binding, only + -- recommend alternatives from relevant + -- namespaces. See #17593. + map greName + $ filter (ok_gre <&&> isLocalGRE) + $ globalRdrEnvElts env + candidates_msg = candidates names_in_scope + ; case filter (keep_me . greName) all_gres of + [] | null all_gres -> bale_out_with candidates_msg + | otherwise -> bale_out_with local_msg + (gre1:gres) -> return (fmap (Right . greName) (gre1 NE.:| gres)) } + + lookup_group bound_names -- Look in the local envt (not top level) + = do { mname <- lookupLocalOccRn_maybe rdr_name + ; env <- getLocalRdrEnv + ; let candidates_msg = candidates $ localRdrEnvElts env + ; case mname of + Just n + | n `elemNameSet` bound_names -> succeed_with n + | otherwise -> bale_out_with local_msg + Nothing -> bale_out_with candidates_msg } + + bale_out_with hints = return $ NE.singleton $ Left $ MissingBinding what hints + + local_msg = [SuggestMoveToDeclarationSite what rdr_name] + + -- Identify all similar names and produce a message listing them + candidates :: [Name] -> [GhcHint] + candidates names_in_scope + | (nm : nms) <- map SimilarName similar_names + = [SuggestSimilarNames rdr_name (nm NE.:| nms)] + | otherwise + = [] + where + similar_names + = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name) + $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) + names_in_scope + + +--------------- +lookupLocalTcNames :: HsSigCtxt -> SigLike -> NamespaceSpecifier -> RdrName -> RnM [(RdrName, Name)] +-- GHC extension: look up both the tycon and data con or variable. +-- Used for top-level fixity signatures and deprecations. +-- Complain if neither is in scope. +-- See Note [Fixity signature lookup] +lookupLocalTcNames ctxt what ns_spec rdr + = do { this_mod <- getModule + ; let also_try_tycon_ns = True + ; nms_eithers <- fmap (guard_builtin_syntax this_mod rdr) <$> + lookupBindGroupOcc ctxt what rdr also_try_tycon_ns ns_spec + ; let (errs, names) = partitionEithers (NE.toList nms_eithers) + ; when (null names) $ + addErr (head errs) -- Bleat about one only + ; return names } + where + -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233 + guard_builtin_syntax this_mod rdr (Right name) + | isBuiltInOcc (occName rdr) + , this_mod /= nameModule name + = Left $ TcRnIllegalBuiltinSyntax what rdr + | otherwise + = Right (rdr, name) + guard_builtin_syntax _ _ (Left err) + = Left $ TcRnNotInScope err rdr + +dataTcOccs :: RdrName -> [RdrName] +-- Return both the given name and the same name promoted to the TcClsName +-- namespace. This is useful when we aren't sure which we are looking at. +-- See also Note [dataTcOccs and Exact Names] +dataTcOccs rdr_name + | isDataOcc occ || isVarOcc occ + = [rdr_name, rdr_name_tc] + | otherwise + = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName + +{- Note [dataTcOccs and Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames can occur in code generated by Template Haskell, and generally +those references are, well, exact. However, the TH `Name` type isn't expressive +enough to always track the correct namespace information, so we sometimes get +the right Unique but wrong namespace. Thus, we still have to do the double-lookup +for Exact RdrNames. + +There is also an awkward situation for built-in syntax. Example in GHCi + :info [] +This parses as the Exact RdrName for nilDataCon, but we also want +the list type constructor. + +Note that setRdrNameSpace on an Exact name requires the Name to be External, +which it always is for built in syntax. +-} + +{- +************************************************************************ +* * + Rebindable names + Dealing with rebindable syntax is driven by the + Opt_RebindableSyntax dynamic flag. + + In "deriving" code we don't want to use rebindable syntax + so we switch off the flag locally + +* * +************************************************************************ + +Haskell 98 says that when you say "3" you get the "fromInteger" from the +Standard Prelude, regardless of what is in scope. However, to experiment +with having a language that is less coupled to the standard prelude, we're +trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" +happens to be in scope. Then you can + import Prelude () + import MyPrelude as Prelude +to get the desired effect. + +At the moment this just happens for + * fromInteger, fromRational on literals (in expressions and patterns) + * negate (in expressions) + * minus (arising from n+k patterns) + * "do" notation + +We store the relevant Name in the HsSyn tree, in + * HsIntegral/HsFractional/HsIsString + * NegApp + * NPlusKPat + * HsDo +respectively. Initially, we just store the "standard" name (GHC.Builtin.Names.fromIntegralName, +fromRationalName etc), but the renamer changes this to the appropriate user +name if Opt_NoImplicitPrelude is on. That is what lookupSyntax does. + +We treat the original (standard) names as free-vars too, because the type checker +checks the type of the user thing against the type of the standard thing. +-} + +lookupIfThenElse :: RnM (Maybe Name) +-- Looks up "ifThenElse" if rebindable syntax is on +lookupIfThenElse + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on + then return Nothing + else do { ite <- lookupOccRnNone (mkVarUnqual (fsLit "ifThenElse")) + ; return (Just ite) } } + +lookupSyntaxName :: Name -- ^ The standard name + -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name +-- Lookup a Name that may be subject to Rebindable Syntax (RS). +-- +-- - When RS is off, just return the supplied (standard) Name +-- +-- - When RS is on, look up the OccName of the supplied Name; return +-- what we find, or the supplied Name if there is nothing in scope +lookupSyntaxName std_name + = do { rebind <- xoptM LangExt.RebindableSyntax + ; if not rebind + then return (std_name, emptyFVs) + else do { nm <- lookupOccRnNone (mkRdrUnqual (nameOccName std_name)) + ; return (nm, unitFV nm) } } + +lookupSyntaxExpr :: Name -- ^ The standard name + -> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name +lookupSyntaxExpr std_name + = do { (name, fvs) <- lookupSyntaxName std_name + ; return (genHsVar name, fvs) } + +lookupSyntax :: Name -- The standard name + -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard + -- name +lookupSyntax std_name + = do { (name, fvs) <- lookupSyntaxName std_name + ; return (mkRnSyntaxExpr name, fvs) } + +lookupSyntaxNames :: [Name] -- Standard names + -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames + -- this works with CmdTop, which wants HsExprs, not SyntaxExprs +lookupSyntaxNames std_names + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on then + return (map (mkHsVar . noLocA) std_names, emptyFVs) + else + do { usr_names <- + mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names + ; return (map (mkHsVar . noLocA) usr_names, mkFVs usr_names) } } + + +{- +Note [QualifiedDo] +~~~~~~~~~~~~~~~~~~ +QualifiedDo is implemented using the same placeholders for operation names in +the AST that were devised for RebindableSyntax. Whenever the renamer checks +which names to use for do syntax, it first checks if the do block is qualified +(e.g. M.do { stmts }), in which case it searches for qualified names. If the +qualified names are not in scope, an error is produced. If the do block is not +qualified, the renamer does the usual search of the names which considers +whether RebindableSyntax is enabled or not. Dealing with QualifiedDo is driven +by the Opt_QualifiedDo dynamic flag. +-} + +-- Lookup operations for a qualified do. If the context is not a qualified +-- do, then use lookupSyntaxExpr. See Note [QualifiedDo]. +lookupQualifiedDo :: HsStmtContext fn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) +lookupQualifiedDo ctxt std_name + = first mkRnSyntaxExpr <$> lookupQualifiedDoName ctxt std_name + +lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars) +lookupNameWithQualifier std_name modName + = do { qname <- lookupOccRnNone (mkRdrQual modName (nameOccName std_name)) + ; return (qname, unitFV qname) } + +-- See Note [QualifiedDo]. +lookupQualifiedDoName :: HsStmtContext fn -> Name -> RnM (Name, FreeVars) +lookupQualifiedDoName ctxt std_name + = case qualifiedDoModuleName_maybe ctxt of + Nothing -> lookupSyntaxName std_name + Just modName -> lookupNameWithQualifier std_name modName + +-------------------------------------------------------------------------------- +-- Helper functions for 'isIrrefutableHsPat'. +-- +-- (Defined here to avoid import cycles.) + +-- | Check irrefutability of a 'ConLike' in a 'ConPat GhcRn' +-- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]). +irrefutableConLikeRn :: HasDebugCallStack + => HscEnv + -> GlobalRdrEnv + -> CompleteMatches -- ^ in-scope COMPLETE pragmas + -> WithUserRdr Name -- ^ the 'Name' of the 'ConLike' + -> Bool +irrefutableConLikeRn hsc_env rdr_env comps (WithUserRdr _ con_nm) + | Just gre <- lookupGRE_Name rdr_env con_nm + = go $ greInfo gre + | otherwise + = go $ lookupGREInfo hsc_env con_nm + where + go ( IAmConLike conInfo ) = + case conLikeInfo conInfo of + ConIsData { conLikeDataCons = tc_cons } -> + length tc_cons == 1 + ConIsPatSyn -> + in_single_complete_match con_nm comps + go _ = False + +-- | Check irrefutability of the 'ConLike' in a 'ConPat GhcTc' +-- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]), +-- given all in-scope COMPLETE pragmas ('CompleteMatches' in the typechecker, +-- 'DsCompleteMatches' in the desugarer). +irrefutableConLikeTc :: NamedThing con + => [CompleteMatchX con] + -- ^ in-scope COMPLETE pragmas + -> ConLike + -> Bool +irrefutableConLikeTc comps con = + case con of + RealDataCon dc -> length (tyConDataCons (dataConTyCon dc)) == 1 + PatSynCon {} -> in_single_complete_match con_nm comps + where + con_nm = conLikeName con + +-- | Internal helper function: check whether a 'ConLike' is the single member +-- of a COMPLETE set without a result 'TyCon'. +-- +-- Why 'without a result TyCon'? See Wrinkle [Irrefutability and COMPLETE pragma result TyCons] +-- in Note [Irrefutability of ConPat]. +in_single_complete_match :: NamedThing con => Name -> [CompleteMatchX con] -> Bool +in_single_complete_match con_nm = go + where + go [] = False + go (comp:comps) + | Nothing <- cmResultTyCon comp + -- conservative, as we don't have enough info to compute + -- 'completeMatchAppliesAtType' + , let comp_nms = mapUniqDSet getName $ cmConLikes comp + , comp_nms == mkUniqDSet [con_nm] + = True + | otherwise + = go comps + +-------------------------------------------------------------------------------- diff --git a/GHC/Rename/Expr.hs b/GHC/Rename/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Expr.hs @@ -0,0 +1,2911 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Renaming of expressions + +Basically dependency analysis. + +Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In +general, all of these functions return a renamed thing, and a set of +free variables. +-} + +module GHC.Rename.Expr ( + rnLExpr, rnExpr, rnStmts, + AnnoBody, UnexpectedStatement(..) + ) where + +import GHC.Prelude hiding (head, init, last, scanl, tail) +import GHC.Hs + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Env ( isBrackLevel ) +import GHC.Tc.Utils.Monad + +import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS + , rnMatchGroup, rnGRHS, makeMiniFixityEnv) +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils +import GHC.Rename.Unbound ( reportUnboundName ) +import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnTypedSplice + , rnUntypedSpliceExpr, checkThLocalNameWithLift, checkThLocalNameNoLift ) +import GHC.Rename.HsType +import GHC.Rename.Pat + +import GHC.Driver.DynFlags +import GHC.Builtin.Names +import GHC.Builtin.Types ( nilDataConName ) +import GHC.Unit.Module ( getModule, isInteractiveModule ) + +import GHC.Types.Basic (TypeOrKind (TypeLevel)) +import GHC.Types.FieldLabel +import GHC.Types.Fixity +import GHC.Types.Id.Make +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.Unique.Set +import GHC.Types.SourceText +import GHC.Types.SrcLoc + +import GHC.Utils.Misc +import qualified GHC.Data.List.NonEmpty as NE +import GHC.Utils.Error +import GHC.Utils.Panic +import GHC.Utils.Outputable as Outputable + +import GHC.Data.FastString +import GHC.Data.List.SetOps ( removeDupsOn ) +import GHC.Data.Maybe + +import qualified GHC.LanguageExtensions as LangExt + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.Monad +import qualified Data.Foldable as Partial (maximum) +import Data.List (unzip4) +import Data.List.NonEmpty ( NonEmpty(..), head, init, last, nonEmpty, scanl, tail ) +import Control.Arrow (first) +import Data.Ord +import Data.Array +import GHC.Driver.Env (HscEnv) +import Data.Foldable (toList) + +{- Note [Handling overloaded and rebindable constructs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Nomenclature +------------- +* Expansion (`HsExpr GhcRn -> HsExpr GhcRn`): expand between renaming and + typechecking, using the `XXExprGhcRn` constructor of `HsExpr`. +* Desugaring (`HsExpr GhcTc -> Core.Expr`): convert the typechecked `HsSyn` to Core. This is done in GHC.HsToCore + + +For overloaded constructs (overloaded literals, lists, strings), and +rebindable constructs (e.g. if-then-else), our general plan is this, +using overloaded labels #foo as an example: + +* In the RENAMER: transform + HsOverLabel "foo" + ==> XExpr (ExpandedThingRn (HsOverLabel #foo) + (fromLabel `HsAppType` "foo")) + We write this more compactly in concrete-syntax form like this + #foo ==> fromLabel @"foo" + + Recall that in (ExpandedThingRn orig expanded), 'orig' is the original term + the user wrote, and 'expanded' is the expanded or desugared version + to be typechecked. + +* In the TYPECHECKER: typecheck the expansion, in this case + fromLabel @"foo" + The typechecker (and desugarer) will never see HsOverLabel + +In effect, the renamer does a bit of desugaring. Recall GHC.Hs.Expr +Note [Rebindable syntax and XXExprGhcRn], which describes the use of XXExprGhcRn. + +RebindableSyntax: + If RebindableSyntax is off we use the built-in 'fromLabel', defined in + GHC.Builtin.Names.fromLabelClassOpName + If RebindableSyntax if ON, we look up "fromLabel" in the environment + to get whichever one is in scope. +This is accomplished by lookupSyntaxName, and it applies to all the +constructs below. + +See also Note [Handling overloaded and rebindable patterns] in GHC.Rename.Pat +for the story with patterns. + +Here are the expressions that we transform in this way. Some are uniform, +but several have a little bit of special treatment: + +* HsIf (if-the-else) + if b then e1 else e2 ==> ifThenElse b e1 e2 + We do this /only/ if rebindable syntax is on, because the coverage + checker looks for HsIf (see GHC.HsToCore.Ticks.addTickHsExpr) + That means the typechecker and desugarer need to understand HsIf + for the non-rebindable-syntax case. + +* OverLabel (overloaded labels, #lbl) + #lbl ==> fromLabel @"lbl" + As ever, we use lookupSyntaxName to look up 'fromLabel' + See Note [Overloaded labels] below + +* ExplicitList (explicit lists [a,b,c]) + When (and only when) OverloadedLists is on + [e1,e2] ==> fromListN 2 [e1,e2] + NB: the type checker and desugarer still see ExplicitList, + but to them it always means the built-in lists. + +* SectionL and SectionR (left and right sections) + (`op` e) ==> rightSection op e + (e `op`) ==> leftSection (op e) + where `leftSection` and `rightSection` are representation-polymorphic + wired-in Ids. See Note [Left and right sections] + +* To understand why expansions for `OpApp` is done in `GHC.Tc.Gen.Head.splitHsApps` + see Note [Doing XXExprGhcRn in the Renamer vs Typechecker] below. + +* RecordUpd: we desugar record updates into case expressions, + in GHC.Tc.Gen.Expr.tcExpr. + + Example: + + data T p q = T1 { x :: Int, y :: Bool, z :: Char } + | T2 { v :: Char } + | T3 { x :: Int } + | T4 { p :: Float, y :: Bool, x :: Int } + | T5 + + e { x=e1, y=e2 } + ===> + let { x' = e1; y' = e2 } in + case e of + T1 _ _ z -> T1 x' y' z + T4 p _ _ -> T4 p y' x' + + See Note [Record Updates] in GHC.Tc.Gen.Expr for more details. + + To understand Why is this done in the typechecker, and not in the renamer + see Note [Doing XXExprGhcRn in the Renamer vs Typechecker] + +* HsDo: We expand `HsDo` statements in `Ghc.Tc.Gen.Do`. + + - For example, a user written code: + + do { x <- e1 ; g x ; return (f x) } + + is expanded to: + + (>>=) e1 + (\x -> ((>>) (g x) + (return (f x)))) + + See Note [Expanding HsDo with XXExprGhcRn] in `Ghc.Tc.Gen.Do` for more details. + To understand why is this done in the typechecker and not in the renamer. + See Note [Doing XXExprGhcRn in the Renamer vs Typechecker] + +Note [Overloaded labels] +~~~~~~~~~~~~~~~~~~~~~~~~ +For overloaded labels, note that we /only/ apply `fromLabel` to the +Symbol argument, so the resulting expression has type + fromLabel @"foo" :: forall a. IsLabel "foo" a => a +Now ordinary Visible Type Application can be used to instantiate the 'a': +the user may have written (#foo @Int). + +Notice that this all works fine in a kind-polymorphic setting (#19154). +Suppose we have + fromLabel :: forall {k1} {k2} (a:k1). blah + +Then we want to instantiate those inferred quantifiers k1,k2, before +type-applying to "foo", so we get + fromLabel @Symbol @blah @"foo" ... + +And those inferred kind quantifiers will indeed be instantiated when we +typecheck the renamed-syntax call (fromLabel @"foo"). + +Note [Doing XXExprGhcRn in the Renamer vs Typechecker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand some `HsExpr GhcRn` code at various places, usually, on the fly, +depending on when it is more convenient. It may be beneficial to have a +separate `HsExpr GhcRn -> HsExpr GhcRn` pass that does this expansion uniformly +in the future when we have enough cases to cater for. For the time being, +this note documents which language feature is expanded at which phase, +and the reasons for doing so. + + ** `HsIf` Expansions + -------------------- + `HsIf` expansions are expanded in the Renamer becuase it is more convinent + to do so there and then not worry about it in the later stage. + `-XRebindableSyntax` is used to decide whether we use the `HsIf` or user defined if + + + ** `OpApp` Expansions + --------------------- + The typechecker turns `OpApp` into a use of `XXExprGhcRn` + on the fly, in `GHC.Tc.Gen.Head.splitHsApps`. + The language extension `RebindableSyntax` does not affect this behaviour. + + It's a bit painful to transform `OpApp e1 op e2` to a `XXExprGhcRn` + form, because the renamer does precedence rearrangement after name + resolution. So the renamer leaves an `OpApp` as an `OpApp`. + + ** Record Update Syntax `RecordUpd` Expansions + ---------------------------------------------- + This is done in the typechecker on the fly (`GHC.Tc.Expr.tcExpr`), and not the renamer, for two reasons: + + - (Until we implement GHC proposal #366) + We need to know the type of the record to disambiguate its fields. + + - We use the type signature of the data constructor to provide `IdSigs` + to the let-bound variables (x', y' in the example of + Note [Handling overloaded and rebindable constructs] above). + This is needed to accept programs such as + + data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } + foo r = r { f = \ k -> (k 3, k 'x') } + + in which an updated field has a higher-rank type. + See Wrinkle [Using IdSig] in Note [Record Updates] in GHC.Tc.Gen.Expr. + + ** `HsDo` Statement Expansions + ----------------------------------- + The expansion for do block statements is done on the fly right before typechecking in `GHC.Tc.Gen.Expr` + using `GHC.Tc.Gen.Do.expandDoStmts`. There are 2 main reasons: + + - During the renaming phase, we may not have all the constructor details `HsConDetails` populated in the + data structure. This would result in an inaccurate irrefutability analysis causing + the continuation lambda body to be wrapped with `fail` alternatives when not needed. + See Part 1. of Note [Expanding HsDo with XXExprGhcRn] (test pattern-fails.hs) + + - If the expansion is done on the fly during renaming, expressions that + have explicit type applications using (-XTypeApplciations) will not work (cf. Let statements expansion) + as the name freshening happens from the root of the AST to the leaves, + but the expansion happens in the opposite direction (from leaves to the root), + causing the renamer to miss the scoped type variables. +-} + +{- +************************************************************************ +* * +\subsubsection{Expressions} +* * +************************************************************************ +-} + +rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars) +rnExprs ls = rnExprs' ls emptyUniqSet + where + rnExprs' [] acc = return ([], acc) + rnExprs' (expr:exprs) acc = + do { (expr', fvExpr) <- rnLExpr expr + -- Now we do a "seq" on the free vars because typically it's small + -- or empty, especially in very long lists of constants + ; let acc' = acc `plusFV` fvExpr + ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc' + ; return (expr':exprs', fvExprs) } + +-- Variables. We look up the variable and return the resulting name. + +rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) +rnLExpr = wrapLocFstMA rnExpr + +rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) + +rnUnboundVar :: SrcSpanAnnN -> RdrName -> RnM (HsExpr GhcRn, FreeVars) +rnUnboundVar l v = do + deferOutofScopeVariables <- goptM Opt_DeferOutOfScopeVariables + -- See Note [Reporting unbound names] for difference between qualified and unqualified names. + unless (isUnqual v || deferOutofScopeVariables) $ + void $ reportUnboundName WL_Term v + return (HsHole (HoleVar (L l v)), emptyFVs) + +rnExpr (HsVar _ (L l v)) + = do { dflags <- getDynFlags + ; mb_gre <- lookupExprOccRn v + ; case mb_gre of { + Nothing -> rnUnboundVar l v ; + Just gre -> + do { let nm = greName gre + info = greInfo gre + ; if | IAmRecField fld_info <- info + -- Since GHC 9.4, such occurrences of record fields must be + -- unambiguous. For ambiguous occurrences, we arbitrarily pick one + -- matching GRE and add a name clash error + -- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn). + -> do { let sel_name = flSelector $ recFieldLabel fld_info + ; checkThLocalNameNoLift (L (l2l l) (WithUserRdr v sel_name)) + ; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFV sel_name) + } + | nm == nilDataConName + -- Treat [] as an ExplicitList, so that + -- OverloadedLists works correctly + -- Note [Empty lists] in GHC.Hs.Expr + , xopt LangExt.OverloadedLists dflags + -> rnExpr (ExplicitList noAnn []) + + | otherwise + -> do { res_expr <- checkThLocalNameWithLift (L (l2l l) (WithUserRdr v nm)) + ; return (res_expr, unitFV nm) } + }}} + + +rnExpr (HsIPVar x v) + = return (HsIPVar x v, emptyFVs) + +rnExpr (HsHole h) + = return (HsHole h, emptyFVs) + +-- HsOverLabel: see Note [Handling overloaded and rebindable constructs] +rnExpr (HsOverLabel src v) + = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName + ; return ( mkExpandedExpr (HsOverLabel src v) $ + HsAppType noExtField (genLHsVar from_label) hs_ty_arg + , fvs ) } + where + hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $ + HsTyLit noExtField (HsStrTy NoSourceText v) + +rnExpr (HsLit x lit) | Just (src, s) <- stringLike lit + = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings + ; if opt_OverloadedStrings then + rnExpr (HsOverLit x (mkHsIsString src s)) + else do { + ; rnLit lit + ; return (HsLit x (convertLit lit), emptyFVs) } } + where + stringLike = \case + HsString src s -> Just (src, s) + HsMultilineString src s -> Just (src, s) + _ -> Nothing + +rnExpr (HsLit x lit) + = do { rnLit lit + ; return (HsLit x (convertLit lit), emptyFVs) } + +rnExpr (HsOverLit x lit) + = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] + ; case mb_neg of + Nothing -> return (HsOverLit x lit', fvs) + Just neg -> + return (HsApp noExtField (noLocA neg) (noLocA (HsOverLit x lit')) + , fvs ) } + +rnExpr (HsApp x fun arg) + = do { (fun',fvFun) <- rnLExpr fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } + +rnExpr (HsAppType _ fun arg) + = do { type_app <- xoptM LangExt.TypeApplications + ; unless type_app $ addErr $ typeAppErr TypeLevel $ hswc_body arg + ; (fun',fvFun) <- rnLExpr fun + ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg + ; return (HsAppType noExtField fun' arg', fvFun `plusFV` fvArg) } + +rnExpr (OpApp _ e1 op e2) + = do { (e1', fv_e1) <- rnLExpr e1 + ; (e2', fv_e2) <- rnLExpr e2 + ; (op', fv_op) <- rnLExpr op + + -- Deal with fixity + -- When renaming code synthesised from "deriving" declarations + -- we used to avoid fixity stuff, but we can't easily tell any + -- more, so I've removed the test. Adding HsPars in GHC.Tc.Deriv.Generate + -- should prevent bad things happening. + ; fixity <- case op' of + L _ (HsVar _ (L _ (WithUserRdr _ n))) -> lookupFixityRn n + L _ (XExpr (HsRecSelRn f)) -> lookupFieldFixityRn f + _ -> return (Fixity minPrecedence InfixL) + -- c.f. lookupFixity for unbound + + ; lexical_negation <- xoptM LangExt.LexicalNegation + ; let negation_handling | lexical_negation = KeepNegationIntact + | otherwise = ReassociateNegation + ; final_e <- mkOpAppRn negation_handling e1' op' fixity e2' + ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } + +rnExpr (NegApp _ e _) + = do { (e', fv_e) <- rnLExpr e + ; (neg_name, fv_neg) <- lookupSyntax negateName + ; final_e <- mkNegAppRn e' neg_name + ; return (final_e, fv_e `plusFV` fv_neg) } + +------------------------------------------ +-- Record dot syntax + +rnExpr (HsGetField _ e f) + = do { (getField, fv_getField) <- lookupSyntaxName getFieldName + ; (e, fv_e) <- rnLExpr e + ; let f' = rnDotFieldOcc <$> f + ; return ( mkExpandedExpr + (HsGetField noExtField e f') + (mkGetField getField e (fmap (unLoc . dfoLabel) f')) + , fv_e `plusFV` fv_getField ) } + +rnExpr (HsProjection _ fs) + = do { (getField, fv_getField) <- lookupSyntaxName getFieldName + ; circ <- lookupOccRn WL_TermVariable compose_RDR + ; let fs' = NE.map rnDotFieldOcc fs + ; return ( mkExpandedExpr + (HsProjection noExtField fs') + (mkProjection getField circ $ NE.map (unLoc . dfoLabel) fs') + , unitFV circ `plusFV` fv_getField) } + +------------------------------------------ +-- Template Haskell extensions +rnExpr e@(HsTypedBracket _ br_body) = rnTypedBracket e br_body +rnExpr e@(HsUntypedBracket _ br_body) = rnUntypedBracket e br_body + +rnExpr (HsTypedSplice _ splice) = rnTypedSplice splice +rnExpr (HsUntypedSplice _ splice) = rnUntypedSpliceExpr splice + +--------------------------------------------- +-- Sections +-- See Note [Parsing sections] in GHC.Parser +rnExpr (HsPar _ (L loc (section@(SectionL {})))) + = do { (section', fvs) <- rnSection section + ; return (HsPar noExtField (L loc section'), fvs) } + +rnExpr (HsPar _ (L loc (section@(SectionR {})))) + = do { (section', fvs) <- rnSection section + ; return (HsPar noExtField (L loc section'), fvs) } + +rnExpr (HsPar _ e) + = do { (e', fvs_e) <- rnLExpr e + ; return (HsPar noExtField e', fvs_e) } + +rnExpr expr@(SectionL {}) + = do { addErr (sectionErr expr); rnSection expr } +rnExpr expr@(SectionR {}) + = do { addErr (sectionErr expr); rnSection expr } + +--------------------------------------------- +rnExpr (HsPragE x prag expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsPragE x (rn_prag prag) expr', fvs_expr) } + where + rn_prag :: HsPragE GhcPs -> HsPragE GhcRn + rn_prag (HsPragSCC x ann) = HsPragSCC x ann + +rnExpr (HsLam x lam_variant matches) + = do { (matches', fvs_ms) <- rnMatchGroup (LamAlt lam_variant) rnLExpr matches + ; return (HsLam x lam_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 CaseAlt new_expr new_matches, e_fvs `plusFV` ms_fvs) } + +rnExpr (HsLet _ binds expr) + = rnLocalBindsAndThen binds $ \binds' _ -> do + { (expr',fvExpr) <- rnLExpr expr + ; return (HsLet noExtField binds' expr', fvExpr) } + +rnExpr (HsDo _ do_or_lc (L l stmts)) + = do { ((stmts1, _), fvs1) <- + rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts + (\ _ -> return ((), emptyFVs)) + ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1 + ; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) } +-- ExplicitList: see Note [Handling overloaded and rebindable constructs] +rnExpr (ExplicitList _ exps) + = do { (exps', fvs) <- rnExprs exps + ; opt_OverloadedLists <- xoptM LangExt.OverloadedLists + ; if not opt_OverloadedLists + then return (ExplicitList noExtField exps', fvs) + else + do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName + ; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls] + ; let rn_list = ExplicitList noExtField exps' + lit_n = mkIntegralLit (length exps) + hs_lit = genHsIntegralLit lit_n + exp_list = genHsApps' (L (noAnnSrcSpan loc) from_list_n_name) [hs_lit, wrapGenSpan rn_list] + ; return ( mkExpandedExpr rn_list exp_list + , fvs `plusFV` fvs') } } + +rnExpr (ExplicitTuple _ tup_args boxity) + = do { checkTupleSection tup_args + ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args + ; return (ExplicitTuple noExtField tup_args' boxity, plusFVs fvs) } + where + rnTupArg (Present x e) = do { (e',fvs) <- rnLExpr e + ; return (Present x e', fvs) } + rnTupArg (Missing _) = return (Missing noExtField, emptyFVs) + +rnExpr (ExplicitSum _ alt arity expr) + = do { (expr', fvs) <- rnLExpr expr + ; return (ExplicitSum noExtField alt arity expr', fvs) } + +rnExpr (RecordCon { rcon_con = con_rdr + , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) + = do { L con_loc con_name <- lookupLocatedOccRnConstr con_rdr + ; let qcon = WithUserRdr (unLoc con_rdr) con_name + ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon qcon) mk_hs_var rec_binds + ; (flds', fvss) <- mapAndUnzipM rn_field flds + ; let rec_binds' = HsRecFields { rec_ext = noExtField, rec_flds = flds', rec_dotdot = dd } + ; return (RecordCon { rcon_ext = noExtField + , rcon_con = L con_loc qcon + , rcon_flds = rec_binds' } + , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } + where + mk_hs_var l n = mkHsVarWithUserRdr (unLoc con_rdr) (L (noAnnSrcSpan l) n) + rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld) + ; return (L l (fld { hfbRHS = arg' }), fvs) } + +rnExpr (RecordUpd { rupd_expr = L l expr, rupd_flds = rbinds }) + = setSrcSpanA l $ + case rbinds of + + -- 'OverloadedRecordUpdate' is not in effect. Regular record update. + RegularRecUpdFields { recUpdFields = flds } -> + do { (e, fv_e) <- rnExpr expr + ; (parents, flds, fv_flds) <- rnHsRecUpdFields flds + ; let upd_flds = + RegularRecUpdFields + { xRecUpdFields = parents + , recUpdFields = flds } + ; return ( RecordUpd noExtField (L l e) upd_flds + , fv_e `plusFV` fv_flds ) } + + -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. + OverloadedRecUpdFields { olRecUpdFields = flds } -> + do { unlessXOptM LangExt.RebindableSyntax $ + addErr TcRnNoRebindableSyntaxRecordDot + ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] + ; punsEnabled <- xoptM LangExt.NamedFieldPuns + ; unless (null punnedFields || punsEnabled) $ + addErr TcRnNoFieldPunsRecordDot + ; (getField, fv_getField) <- lookupSyntaxName getFieldName + ; (setField, fv_setField) <- lookupSyntaxName setFieldName + ; (e, fv_e) <- rnExpr expr + ; (us, fv_us) <- rnHsUpdProjs flds + ; let upd_flds = OverloadedRecUpdFields + { xOLRecUpdFields = noExtField + , olRecUpdFields = us } + ; return ( mkExpandedExpr + (RecordUpd noExtField (L l e) upd_flds) + (mkRecordDotUpd getField setField (L l e) us) + , plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) } + + +rnExpr (ExprWithTySig _ expr pty) + = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty + ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ + rnLExpr expr + ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } + +-- HsIf: see Note [Handling overloaded and rebindable constructs] +-- Because of the coverage checker it is most convenient /not/ to +-- expand HsIf; unless we are in rebindable syntax. +rnExpr (HsIf _ p b1 b2) = rnHsIf p b1 b2 + +rnExpr (HsMultiIf _ alts) + = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts + ; return (HsMultiIf noExtField alts', fvs) } + +rnExpr (ArithSeq _ _ seq) + = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists + ; (new_seq, fvs) <- rnArithSeq seq + ; if opt_OverloadedLists + then do { + ; (from_list_name, fvs') <- lookupSyntax fromListName + ; return (ArithSeq noExtField (Just from_list_name) new_seq + , fvs `plusFV` fvs') } + else + return (ArithSeq noExtField Nothing new_seq, fvs) } + +rnExpr (HsEmbTy _ ty) + = do { (ty', fvs) <- rnHsWcType HsTypeCtx ty + ; checkTypeSyntaxExtension TypeKeywordSyntax + ; return (HsEmbTy noExtField ty', fvs) } + +rnExpr (HsQual _ (L ann ctxt) ty) + = do { (ctxt', fvs_ctxt) <- mapAndUnzipM rnLExpr ctxt + ; (ty', fvs_ty) <- rnLExpr ty + ; checkTypeSyntaxExtension ContextArrowSyntax + ; return (HsQual noExtField (L ann ctxt') ty', plusFVs fvs_ctxt `plusFV` fvs_ty) } + +rnExpr (HsForAll _ tele expr) + = bindHsForAllTelescope HsTypeCtx tele $ \tele' -> + do { (expr', fvs) <- rnLExpr expr + ; checkTypeSyntaxExtension ForallTelescopeSyntax + ; return (HsForAll noExtField tele' expr', fvs) } + +rnExpr (HsFunArr _ mult arg res) + = do { (arg', fvs1) <- rnLExpr arg + ; (mult', fvs2) <- rnHsMultAnnWith rnLExpr mult + ; (res', fvs3) <- rnLExpr res + ; checkTypeSyntaxExtension FunctionArrowSyntax + ; return (HsFunArr noExtField mult' arg' res', plusFVs [fvs1, fvs2, fvs3]) } + +{- +************************************************************************ +* * + Static values +* * +************************************************************************ + +For the static form we check that it is not used in splices. +We also collect the free variables of the term which come from +this module. See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. +-} + +rnExpr e@(HsStatic _ expr) = do + -- Normally, you wouldn't be able to construct a static expression without + -- first enabling -XStaticPointers in the first place, since that extension + -- is what makes the parser treat `static` as a keyword. But this is not a + -- sufficient safeguard, as one can construct static expressions by another + -- mechanism: Template Haskell (see #14204). To ensure that GHC is + -- absolutely prepared to cope with static forms, we check for + -- -XStaticPointers here as well. + unlessXOptM LangExt.StaticPointers $ + addErr $ TcRnIllegalStaticExpression e + (expr',fvExpr) <- rnLExpr expr + level <- getThLevel + case level of + Splice _ _ -> addErr $ TcRnTHError $ IllegalStaticFormInSplice e + _ -> return () + mod <- getModule + let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr + return (HsStatic fvExpr' expr', fvExpr) + +{- +************************************************************************ +* * + Arrow notation +* * +********************************************************************* -} + +rnExpr (HsProc x pat body) + = newArrowScope $ + rnPat (ArrowMatchCtxt ProcExpr) pat $ \ pat' -> do + { (body',fvBody) <- rnCmdTop body + ; return (HsProc x pat' body', fvBody) } + + +{- +************************************************************************ +* * + Type syntax +* * +********************************************************************* -} + +checkTypeSyntaxExtension :: TypeSyntax -> RnM () +checkTypeSyntaxExtension syntax = + unlessXOptM (typeSyntaxExtension syntax) $ + addErr (TcRnUnexpectedTypeSyntaxInTerms syntax) + +{- +************************************************************************ +* * + Operator sections +* * +********************************************************************* -} + + +rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) +-- See Note [Parsing sections] in GHC.Parser +-- Also see Note [Handling overloaded and rebindable constructs] + +rnSection section@(SectionR x op expr) + -- See Note [Left and right sections] + = do { (op', fvs_op) <- rnLExpr op + ; (expr', fvs_expr) <- rnLExpr expr + ; checkSectionPrec InfixR section op' expr' + ; let rn_section = SectionR x op' expr' + ds_section = genHsApps rightSectionName [op',expr'] + ; return ( mkExpandedExpr rn_section ds_section + , fvs_op `plusFV` fvs_expr) } + +rnSection section@(SectionL x expr op) + -- See Note [Left and right sections] + = do { (expr', fvs_expr) <- rnLExpr expr + ; (op', fvs_op) <- rnLExpr op + ; checkSectionPrec InfixL section op' expr' + ; postfix_ops <- xoptM LangExt.PostfixOperators + -- Note [Left and right sections] + ; let rn_section = SectionL x expr' op' + ds_section + | postfix_ops = HsApp noExtField op' expr' + | otherwise = genHsApps leftSectionName + [wrapGenSpan $ HsApp noExtField op' expr'] + ; return ( mkExpandedExpr rn_section ds_section + , fvs_op `plusFV` fvs_expr) } + +rnSection other = pprPanic "rnSection" (ppr other) + +{- Note [Left and right sections] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dealing with left sections (x *) and right sections (* x) is +surprisingly fiddly. We expand like this + (`op` e) ==> rightSection op e + (e `op`) ==> leftSection (op e) + +Using an auxiliary function in this way avoids the awkwardness of +generating a lambda, esp if `e` is a redex, so we *don't* want +to generate `(\x -> op x e)`. See Historical +Note [Desugaring operator sections] + +Here are their definitions: + leftSection :: forall r1 r2 n (a::TYPE r1) (b::TYPE r2). + (a %n-> b) -> a %n-> b + leftSection f x = f x + + rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3). + (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c + rightSection f y x = f x y + +Note the wrinkles: + +* We do /not/ use lookupSyntaxName, which would make left and right + section fall under RebindableSyntax. Reason: it would be a user- + facing change, and there are some tricky design choices (#19354). + Plus, infix operator applications would be trickier to make + rebindable, so it'd be inconsistent to do so for sections. + + TL;DR: we still use the renamer-expansion mechanism for operator + sections, but only to eliminate special-purpose code paths in the + renamer and desugarer. + +* leftSection and rightSection must be representation-polymorphic, to allow + (+# 4#) and (4# +#) to work. See + Note [Wired-in Ids for rebindable syntax] in GHC.Types.Id.Make. + +* leftSection and rightSection must be multiplicity-polymorphic. + (Test linear/should_compile/OldList showed this up.) + +* Because they are representation-polymorphic, we have to define them + as wired-in Ids, with compulsory inlining. See + GHC.Types.Id.Make.leftSectionId, rightSectionId. + +* leftSection is just ($) really; but unlike ($) it is + representation-polymorphic in the result type, so we can write + `(x +#)`, say. + +* The type of leftSection must have an arrow in its first argument, + because (x `ord`) should be rejected, because ord does not take two + arguments + +* It's important that we define leftSection in an eta-expanded way, + (i.e. not leftSection f = f), so that + (True `undefined`) `seq` () + = (leftSection (undefined True) `seq` ()) + evaluates to () and not undefined + +* If PostfixOperators is ON, then we expand a left section like this: + (e `op`) ==> op e + with no auxiliary function at all. Simple! + +* leftSection and rightSection switch on ImpredicativeTypes locally, + during Quick Look; see GHC.Tc.Gen.App.wantQuickLook. Consider + test DeepSubsumption08: + type Setter st t a b = forall f. Identical f => blah + (.~) :: Setter s t a b -> b -> s -> t + clear :: Setter a a' b (Maybe b') -> a -> a' + clear = (.~ Nothing) + The expansion look like (rightSection (.~) Nothing). So we must + instantiate `rightSection` first type argument to a polytype! + Hence the special magic in App.wantQuickLook. + +Historical Note [Desugaring operator sections] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note explains some historical trickiness in desugaring left and +right sections. That trickiness has completely disappeared now that +we desugar to calls to 'leftSection` and `rightSection`, but I'm +leaving it here to remind us how nice the new story is. + +Desugaring left sections with -XPostfixOperators is straightforward: convert +(expr `op`) to (op expr). + +Without -XPostfixOperators it's a bit more tricky. At first it looks as if we +can convert + + (expr `op`) + +naively to + + \x -> op expr x + +But no! expr might be a redex, and we can lose laziness badly this +way. Consider + + map (expr `op`) xs + +for example. If expr were a redex then eta-expanding naively would +result in multiple evaluations where the user might only have expected one. + +So we convert instead to + + let y = expr in \x -> op y x + +Also, note that we must do this for both right and (perhaps surprisingly) left +sections. Why are left sections necessary? Consider the program (found in #18151), + + seq (True `undefined`) () + +according to the Haskell Report this should reduce to () (as it specifies +desugaring via eta expansion). However, if we fail to eta expand we will rather +bottom. Consequently, we must eta expand even in the case of a left section. + +If `expr` is actually just a variable, say, then the simplifier +will inline `y`, eliminating the redundant `let`. + +Note that this works even in the case that `expr` is unlifted. In this case +bindNonRec will automatically do the right thing, giving us: + + case expr of y -> (\x -> op y x) + +See #18151. + +Note [Reporting unbound names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Faced with an out-of-scope `RdrName` there are two courses of action +A. Report an error immediately (and return a `HsHole (HoleVar ...)`). This will halt GHC after the renamer is complete +B. Return a `HsHole (HoleVar ...)` without reporting an error. That will allow the typechecker to run, which in turn + can give a better error message, notably giving the type of the variable via the "typed holes" mechanism. + +When `-fdefer-out-of-scope-variables` is on we follow plan B. + +When it is not, we follow plan B for unqualified names, and plan A for qualified names. + +If a name is qualified, and out of scope, then by default an error will be raised +because the user was already more precise. They specified a specific qualification +and either + * The qualification didn't exist, so that precision was wrong. + * Or the qualification existed and the thing we were looking for wasn't where + the qualification said it would be. + +However we can still defer this error completely, and we do defer it if +`-fdefer-out-of-scope-variables` is enabled. + +-} + +{- +************************************************************************ +* * + Field Labels +* * +************************************************************************ +-} + +rnDotFieldOcc :: DotFieldOcc GhcPs -> DotFieldOcc GhcRn +rnDotFieldOcc (DotFieldOcc x label) = DotFieldOcc x label + +rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn +rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (fmap (fmap rnDotFieldOcc) fls) + +{- +************************************************************************ +* * + Arrow commands +* * +************************************************************************ +-} + +rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars) +rnCmdArgs [] = return ([], emptyFVs) +rnCmdArgs (arg:args) + = do { (arg',fvArg) <- rnCmdTop arg + ; (args',fvArgs) <- rnCmdArgs args + ; return (arg':args', fvArg `plusFV` fvArgs) } + +rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) +rnCmdTop = wrapLocFstMA rnCmdTop' + where + rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars) + rnCmdTop' (HsCmdTop _ cmd) + = do { (cmd', fvCmd) <- rnLCmd cmd + ; let cmd_names = [arrAName, composeAName, firstAName] ++ + nameSetElemsStable (methodNamesCmd (unLoc cmd')) + -- Generate the rebindable syntax for the monad + ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names + + ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd', + fvCmd `plusFV` cmd_fvs) } + +rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) +rnLCmd = wrapLocFstMA rnCmd + +rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) + +rnCmd (HsCmdArrApp _ arrow arg ho rtl) + = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdArrApp noExtField arrow' arg' ho rtl, + fvArrow `plusFV` fvArg) } + where + select_arrow_scope tc = case ho of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc + -- See Note [Escaping the arrow scope] in GHC.Tc.Types + -- Before renaming 'arrow', use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside 'arrow'. In the higher-order case (-<<), they are. + +rnCmd (HsCmdArrForm _ op f cmds) + = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) + ; (cmds',fvCmds) <- rnCmdArgs cmds + ; return ( HsCmdArrForm Nothing op' f cmds' + , fvOp `plusFV` fvCmds) } + +rnCmd (HsCmdApp x fun arg) + = do { (fun',fvFun) <- rnLCmd fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } + +rnCmd (HsCmdLam x lam_variant matches) + = do { let ctxt = ArrowMatchCtxt $ ArrowLamAlt lam_variant + ; (new_matches, ms_fvs) <- rnMatchGroup ctxt rnLCmd matches + ; return (HsCmdLam x lam_variant new_matches, ms_fvs) } + +rnCmd (HsCmdPar _ e) + = do { (e', fvs_e) <- rnLCmd e + ; return (HsCmdPar noExtField e', fvs_e) } + +rnCmd (HsCmdCase _ expr matches) + = do { (new_expr, e_fvs) <- rnLExpr expr + ; (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches + ; return (HsCmdCase noExtField new_expr new_matches + , e_fvs `plusFV` ms_fvs) } + +rnCmd (HsCmdIf _ _ p b1 b2) + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLCmd b1 + ; (b2', fvB2) <- rnLCmd b2 + + ; mb_ite <- lookupIfThenElse + ; let (ite, fvITE) = case mb_ite of + Just ite_name -> (mkRnSyntaxExpr ite_name, unitFV ite_name) + Nothing -> (NoSyntaxExprRn, emptyFVs) + + ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} + +rnCmd (HsCmdLet _ binds cmd) + = rnLocalBindsAndThen binds $ \ binds' _ -> do + { (cmd',fvExpr) <- rnLCmd cmd + ; return (HsCmdLet noExtField binds' cmd', fvExpr) } + +rnCmd (HsCmdDo _ (L l stmts)) + = do { ((stmts', _), fvs) <- + rnStmts ArrowExpr rnCmd stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsCmdDo noExtField (L l stmts'), fvs ) } + +--------------------------------------------------- +type CmdNeeds = FreeVars -- Only inhabitants are + -- appAName, choiceAName, loopAName + +-- find what methods the Cmd needs (loop, choice, apply) +methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds +methodNamesLCmd = methodNamesCmd . unLoc + +methodNamesCmd :: HsCmd GhcRn -> CmdNeeds + +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl) + = emptyFVs +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl) + = unitFV appAName +methodNamesCmd (HsCmdArrForm {}) = emptyFVs + +methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c + +methodNamesCmd (HsCmdIf _ _ _ c1 c2) + = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName + +methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts +methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c + +methodNamesCmd (HsCmdCase _ _ matches) = methodNamesMatch matches `addOneFV` choiceAName +methodNamesCmd (HsCmdLam _ LamSingle matches) = methodNamesMatch matches +methodNamesCmd (HsCmdLam _ _ matches) = methodNamesMatch matches `addOneFV` choiceAName + +--methodNamesCmd _ = emptyFVs + -- Other forms can't occur in commands, but it's not convenient + -- to error here so we just do what's convenient. + -- The type checker will complain later + +--------------------------------------------------- +methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars +methodNamesMatch (MG { mg_alts = L _ ms }) + = plusFVs (map do_one ms) + where + do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss + +------------------------------------------------- +-- gaw 2004 +methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars +methodNamesGRHSs (GRHSs _ grhss _) + = foldl' (flip plusFV) emptyFVs (NE.map methodNamesGRHS grhss) + +------------------------------------------------- + +methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds +methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs + +--------------------------------------------------- +methodNamesStmts :: [LStmtLR GhcRn GhcRn (LHsCmd GhcRn)] -> FreeVars +methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) + +--------------------------------------------------- +methodNamesLStmt :: LStmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars +methodNamesLStmt = methodNamesStmt . unLoc + +methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars +methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (BindStmt _ _ cmd) = methodNamesLCmd cmd +methodNamesStmt (RecStmt { recS_stmts = L _ stmts }) = + methodNamesStmts stmts `addOneFV` loopAName +methodNamesStmt (LetStmt {}) = emptyFVs +methodNamesStmt (ParStmt {}) = emptyFVs +methodNamesStmt (TransStmt {}) = emptyFVs +methodNamesStmt (XStmtLR ApplicativeStmt{}) = emptyFVs + -- ParStmt and TransStmt can't occur in commands, but it's not + -- convenient to error here so we just do what's convenient + +{- +************************************************************************ +* * + Arithmetic sequences +* * +************************************************************************ +-} + +rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars) +rnArithSeq (From expr) + = do { (expr', fvExpr) <- rnLExpr expr + ; return (From expr', fvExpr) } + +rnArithSeq (FromThen expr1 expr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) } + +rnArithSeq (FromTo expr1 expr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) } + +rnArithSeq (FromThenTo expr1 expr2 expr3) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; (expr3', fvExpr3) <- rnLExpr expr3 + ; return (FromThenTo expr1' expr2' expr3', + plusFVs [fvExpr1, fvExpr2, fvExpr3]) } + +{- +************************************************************************ +* * +\subsubsection{@Stmt@s: in @do@ expressions} +* * +************************************************************************ +-} + +{- +Note [Deterministic ApplicativeDo and RecursiveDo desugaring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both ApplicativeDo and RecursiveDo need to create tuples not +present in the source text. + +For ApplicativeDo we create: + + (a,b,c) <- (\c b a -> (a,b,c)) <$> + +For RecursiveDo we create: + + mfix (\ ~(a,b,c) -> do ...; return (a',b',c')) + +The order of the components in those tuples needs to be stable +across recompilations, otherwise they can get optimized differently +and we end up with incompatible binaries. +To get a stable order we use nameSetElemsStable. +See Note [Deterministic UniqFM] to learn more about nondeterminism. +-} + +type AnnoBody body + = ( Outputable (body GhcPs) + ) + +-- | Rename some Stmts +rnStmts :: AnnoBody body + => HsStmtContextRn + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) + -- ^ How to rename the body of each statement (e.g. rnLExpr) + -> [LStmt GhcPs (LocatedA (body GhcPs))] + -- ^ Statements + -> ([Name] -> RnM (thing, FreeVars)) + -- ^ if these statements scope over something, this renames it + -- and returns the result. + -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars) +rnStmts ctxt rnBody stmts thing_inside + = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside + ; return ((map fst stmts', thing), fvs) } + +-- | maybe rearrange statements according to the ApplicativeDo transformation +postProcessStmtsForApplicativeDo + :: HsDoFlavour + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) +postProcessStmtsForApplicativeDo ctxt stmts + = do { + -- rearrange the statements using ApplicativeStmt if + -- -XApplicativeDo is on. Also strip out the FreeVars attached + -- to each Stmt body. + ado_is_on <- xoptM LangExt.ApplicativeDo + ; let is_do_expr | DoExpr{} <- ctxt = True + | otherwise = False + -- don't apply the transformation inside TH brackets, because + -- GHC.HsToCore.Quote does not handle ApplicativeDo. + ; in_th_bracket <- isBrackLevel <$> getThLevel + ; if ado_is_on && is_do_expr && not in_th_bracket + then do { traceRn "ppsfa" (ppr stmts) + ; rearrangeForApplicativeDo ctxt stmts } + else noPostProcessStmts (HsDoStmt ctxt) stmts } + +-- | strip the FreeVars annotations from statements +noPostProcessStmts + :: HsStmtContextRn + -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) +noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) + + +rnStmtsWithFreeVars :: AnnoBody body + => HsStmtContextRn + -> ((body GhcPs) -> RnM ((body GhcRn), FreeVars)) + -> [LStmt GhcPs (LocatedA (body GhcPs))] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing) + , FreeVars) +-- Each Stmt body is annotated with its FreeVars, so that +-- we can rearrange statements for ApplicativeDo. +-- +-- Variables bound by the Stmts, and mentioned in thing_inside, +-- do not appear in the result FreeVars + +rnStmtsWithFreeVars ctxt _ [] thing_inside + = do { checkEmptyStmts ctxt + ; (thing, fvs) <- thing_inside [] + ; return (([], thing), fvs) } + +rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody (nonEmpty -> Just stmts) thing_inside -- Deal with mdo + = -- Behave like do { rec { ...all but last... }; last } + do { ((stmts1, (stmts2, thing)), fvs) + <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA (NE.init stmts))) $ \ _ -> + do { last_stmt' <- checkLastStmt mDoExpr (NE.last stmts) + ; rnStmt mDoExpr rnBody last_stmt' thing_inside } + ; return (((stmts1 ++ stmts2), thing), fvs) } + +rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside + | null lstmts + = setSrcSpanA loc $ + do { lstmt' <- checkLastStmt ctxt lstmt + ; rnStmt ctxt rnBody lstmt' thing_inside } + + | otherwise + = do { ((stmts1, (stmts2, thing)), fvs) + <- setSrcSpanA loc $ + do { checkStmt ctxt lstmt + ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> + rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 -> + thing_inside (bndrs1 ++ bndrs2) } + ; return (((stmts1 ++ stmts2), thing), fvs) } + +---------------------- + +{- +Note [Failing pattern matches in Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Many things desugar to HsStmts including monadic things like `do` and `mdo` +statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an +exhaustive list). How we deal with pattern match failure is context-dependent. + + * In the case of list comprehensions and pattern guards we don't need any + 'fail' function; the desugarer ignores the fail function of 'BindStmt' + entirely. So, for list comprehensions, the fail function is set to 'Nothing' + for clarity. + +* In the case of monadic contexts (e.g. monad comprehensions, do, and mdo + expressions) we want pattern match failure to be desugared to the + 'fail' function (from MonadFail type class). + +At one point we failed to make this distinction, leading to #11216. +-} + +rnStmt :: AnnoBody body + => HsStmtContextRn + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) + -- ^ How to rename the body of the statement + -> LStmt GhcPs (LocatedA (body GhcPs)) + -- ^ The statement + -> ([Name] -> RnM (thing, FreeVars)) + -- ^ Rename the stuff that this statement scopes over + -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing) + , FreeVars) +-- Variables bound by the Stmt, and mentioned in thing_inside, +-- do not appear in the result FreeVars + +rnStmt ctxt rnBody (L loc (LastStmt _ (L lb body) noret _)) thing_inside + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- if isMonadCompContext ctxt + then lookupStmtName ctxt returnMName + else return (noSyntaxExpr, emptyFVs) + -- The 'return' in a LastStmt is used only + -- for MonadComp; and we don't want to report + -- "not in scope: return" in other cases + -- #15607 + + ; (thing, fvs3) <- thing_inside [] + ; return (([(L loc (LastStmt noExtField (L lb body') noret ret_op), fv_expr)] + , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } + +rnStmt ctxt rnBody (L loc (BodyStmt _ (L lb body) _ _)) thing_inside + = do { (body', fv_expr) <- rnBody body + ; (then_op, fvs1) <- lookupQualifiedDoStmtName ctxt thenMName + + ; (guard_op, fvs2) <- if isComprehensionContext ctxt + then lookupStmtName ctxt guardMName + else return (noSyntaxExpr, emptyFVs) + -- Only list/monad comprehensions use 'guard' + -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] + -- Here "gd" is a guard + + ; (thing, fvs3) <- thing_inside [] + ; return ( ([(L loc (BodyStmt noExtField (L lb body') then_op guard_op), fv_expr)] + , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } + +rnStmt ctxt rnBody (L loc (BindStmt _ pat (L lb body))) thing_inside + = do { (body', fv_expr) <- rnBody body + -- The binders do not scope over the expression + ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName + + ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do + { (thing, fvs2) <- thing_inside (collectPatBinders CollNoDictBinders pat') + ; (fail_op, fvs3) <- monadFailOp pat' ctxt + ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } + ; return (( [( L loc (BindStmt xbsrn pat' (L lb body')), fv_expr )] + , thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} + -- fv_expr shouldn't really be filtered by the rnPatsAndThen + -- but it does not matter because the names are unique + +rnStmt _ _ (L loc (LetStmt _ binds)) thing_inside + = rnLocalBindsAndThen binds $ \binds' bind_fvs -> do + { (thing, fvs) <- thing_inside (collectLocalBinders CollNoDictBinders binds') + ; return ( ([(L loc (LetStmt noAnn binds'), bind_fvs)], thing) + , fvs) } + +rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = L _ rec_stmts })) thing_inside + = do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName + ; (mfix_op, fvs2) <- lookupQualifiedDoStmtName ctxt mfixName + ; (bind_op, fvs3) <- lookupQualifiedDoStmtName ctxt bindMName + ; let empty_rec_stmt = (emptyRecStmtName :: StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) + { recS_ret_fn = return_op + , recS_mfix_fn = mfix_op + , recS_bind_fn = bind_op } + + -- Step1: Bring all the binders of the mdo into scope + -- (Remember that this also removes the binders from the + -- finally-returned free-vars.) + -- And rename each individual stmt, making a + -- singleton segment. At this stage the FwdRefs field + -- isn't finished: it's empty for all except a BindStmt + -- for which it's the fwd refs within the bind itself + -- (This set may not be empty, because we're in a recursive + -- context.) + ; rnRecStmtsAndThen ctxt rnBody rec_stmts $ \ segs -> do + { let bndrs = nameSetElemsStable $ + foldr (unionNameSet . (\(ds,_,_,_) -> ds)) + emptyNameSet + segs + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + ; (thing, fvs_later) <- thing_inside bndrs + -- In interactive mode, all variables could be used later. So we pass whether + -- we are in GHCi along to segmentRecStmts. See Note [What is "used later" in a rec stmt] + ; is_interactive <- isInteractiveModule . tcg_mod <$> getGblEnv + ; let + (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs (fvs_later, is_interactive) + -- We aren't going to try to group RecStmts with + -- ApplicativeDo, so attaching empty FVs is fine. + ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing) + , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } + +rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside + = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName + ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside + ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing) + , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } + +rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form + , trS_using = using })) thing_inside + = do { -- Rename the 'using' expression in the context before the transform is begun + (using', fvs1) <- rnLExpr using + + -- Rename the stmts and the 'by' expression + -- Keep track of the variables mentioned in the 'by' expression + ; ((stmts', (by', used_bndrs, thing)), fvs2) + <- rnStmts (TransStmtCtxt ctxt) rnExpr stmts $ \ bndrs -> + do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by + ; (thing, fvs_thing) <- thing_inside bndrs + ; let fvs = fvs_by `plusFV` fvs_thing + used_bndrs = filter (`elemNameSet` fvs) bndrs + -- The paper (Fig 5) has a bug here; we must treat any free variable + -- of the "thing inside", **or of the by-expression**, as used + ; return ((by', used_bndrs, thing), fvs) } + + -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName + ; (fmap_op, fvs5) <- case form of + ThenForm -> return (noExpr, emptyFVs) + _ -> lookupStmtNamePoly ctxt fmapName + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + `plusFV` fvs4 `plusFV` fvs5 + bndr_map = used_bndrs `zip` used_bndrs + -- See Note [TransStmt binder map] in GHC.Hs.Expr + + ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map) + ; return (([(L loc (TransStmt { trS_ext = noExtField + , trS_stmts = stmts', trS_bndrs = bndr_map + , trS_by = by', trS_using = using', trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) } + +rnParallelStmts :: forall thing. HsStmtContextRn + -> SyntaxExpr GhcRn + -> NonEmpty (ParStmtBlock GhcPs GhcPs) + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM ((NonEmpty (ParStmtBlock GhcRn GhcRn), thing), FreeVars) +-- Note [Renaming parallel Stmts] +rnParallelStmts ctxt return_op segs thing_inside + = do { orig_lcl_env <- getLocalRdrEnv + ; rn_segs (:|) orig_lcl_env [] segs } + where + -- The `cons` argument is how we cons the first `ParStmtBlock` onto the rest. + -- It is called with `cons = (:)` or `cons = (:|)`. + -- Thus, the return type `parStmtBlocks` is `[ParStmtBlock _ _]` or + -- `NonEmpty (ParStmtBlock _ _)`, in turn. + rn_segs :: (ParStmtBlock GhcRn GhcRn -> [ParStmtBlock GhcRn GhcRn] -> parStmtBlocks) + -> LocalRdrEnv + -> [Name] -> NonEmpty (ParStmtBlock GhcPs GhcPs) + -> RnM ((parStmtBlocks, thing), FreeVars) + rn_segs cons env bndrs_so_far (ParStmtBlock x stmts _ _ :| segs) + = do { ((stmts', (used_bndrs, segs', thing)), fvs) + <- rnStmts ctxt rnExpr stmts $ \ bndrs -> + setLocalRdrEnv env $ do + { ((segs', thing), fvs) <- rn_segs1 env (bndrs ++ bndrs_so_far) segs + ; let used_bndrs = filter (`elemNameSet` fvs) bndrs + ; return ((used_bndrs, segs', thing), fvs) } + + ; let seg' = ParStmtBlock x stmts' used_bndrs return_op + ; return ((cons seg' segs', thing), fvs) } + + rn_segs1 _ bndrs [] = do + { let (bndrs', dups) = removeDupsOn nameOccName bndrs + ; mapM_ dupErr dups + ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') + ; return (([], thing), fvs) } + rn_segs1 env bndrs (x:xs) = rn_segs (:) env bndrs (x:|xs) + + dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs) + +lookupQualifiedDoStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) +-- Like lookupStmtName, but respects QualifiedDo +lookupQualifiedDoStmtName ctxt n + = case qualifiedDoModuleName_maybe ctxt of + Nothing -> lookupStmtName ctxt n + Just modName -> + first mkRnSyntaxExpr <$> lookupNameWithQualifier n modName + +lookupStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) +-- Like lookupSyntax, but respects contexts +lookupStmtName ctxt n + | rebindableContext ctxt + = lookupSyntax n + | otherwise + = return (mkRnSyntaxExpr n, emptyFVs) + +lookupStmtNamePoly :: HsStmtContextRn -> Name -> RnM (HsExpr GhcRn, FreeVars) +lookupStmtNamePoly ctxt name + | rebindableContext ctxt + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if rebindable_on + then do { fm <- lookupOccRn WL_TermVariable (nameRdrName name) + ; return (mkHsVar (noLocA fm), unitFV fm) } + else not_rebindable } + | otherwise + = not_rebindable + where + not_rebindable = return (mkHsVar (noLocA name), emptyFVs) + +-- | Is this a context where we respect RebindableSyntax? +-- but ListComp are never rebindable +-- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows +rebindableContext :: HsStmtContextRn -> Bool +rebindableContext ctxt = case ctxt of + HsDoStmt flavour -> rebindableDoStmtContext flavour + ArrowExpr -> False + PatGuard {} -> False + + + ParStmtCtxt c -> rebindableContext c -- Look inside to + TransStmtCtxt c -> rebindableContext c -- the parent context + +rebindableDoStmtContext :: HsDoFlavour -> Bool +rebindableDoStmtContext flavour = case flavour of + ListComp -> False + DoExpr m -> isNothing m + MDoExpr m -> isNothing m + MonadComp -> True + GhciStmtCtxt -> True -- I suppose? + +{- +Note [Renaming parallel Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Renaming parallel statements is painful. Given, say + [ a+c | a <- as, bs <- bss + | c <- bs, a <- ds ] +Note that + (a) In order to report "Defined but not used" about 'bs', we must + rename each group of Stmts with a thing_inside whose FreeVars + include at least {a,c} + + (b) We want to report that 'a' is illegally bound in both branches + + (c) The 'bs' in the second group must obviously not be captured by + the binding in the first group + +To satisfy (a) we nest the segments. +To satisfy (b) we check for duplicates just before thing_inside. +To satisfy (c) we reset the LocalRdrEnv each time. + +************************************************************************ +* * +\subsubsection{mdo expressions} +* * +************************************************************************ +-} + +type FwdRefs = NameSet +type Segment stmts = (Defs, + Uses, -- May include defs + FwdRefs, -- A subset of uses that are + -- (a) used before they are bound in this segment, or + -- (b) used here, and bound in subsequent segments + stmts) -- Either Stmt or [Stmt] + + +-- wrapper that does both the left- and right-hand sides +rnRecStmtsAndThen :: AnnoBody body + => HsStmtContextRn + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) + -> [LStmt GhcPs (LocatedA (body GhcPs))] + -- assumes that the FreeVars returned includes + -- the FreeVars of the Segments + -> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))] + -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnRecStmtsAndThen ctxt rnBody s cont + = do { -- (A) Make the mini fixity env for all of the stmts + fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) + + -- (B) Do the LHSes + ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s + + -- ...bring them and their fixities into scope + ; let bound_names = collectLStmtsBinders CollNoDictBinders (map fst new_lhs_and_fv) + -- Fake uses of variables introduced implicitly (warning suppression, see #4404) + rec_uses = lStmtsImplicits (map fst new_lhs_and_fv) + implicit_uses = mkNameSet $ concatMap (concatMap implFlBndr_binders . snd) $ rec_uses + ; bindLocalNamesFV bound_names $ + addLocalFixities fix_env bound_names $ do + + -- (C) do the right-hand-sides and thing-inside + { segs <- rn_rec_stmts ctxt rnBody bound_names new_lhs_and_fv + ; (res, fvs) <- cont segs + ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns)) + rec_uses + ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses) + ; return (res, fvs) }} + +-- get all the fixity decls in any Let stmt +collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] +collectRecStmtsFixities l = + foldr (\ s -> \acc -> case s of + (L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) -> + foldr (\ sig -> \ acc -> case sig of + (L loc (FixSig _ s)) -> (L loc s) : acc + _ -> acc) acc sigs + _ -> acc) [] l + +-- left-hand sides + +rn_rec_stmt_lhs :: AnnoBody body => MiniFixityEnv + -> LStmt GhcPs (LocatedA (body GhcPs)) + -- rename LHS, and return its FVs + -- Warning: we will only need the FreeVars below in the case of a BindStmt, + -- so we don't bother to compute it accurately in the other cases + -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] + +rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b)) + = return [(L loc (BodyStmt noExtField body a b), emptyFVs)] + +rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a)) + = return [(L loc (LastStmt noExtField body noret a), emptyFVs)] + +rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body)) + = do + -- should the ctxt be MDo instead? + (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat + return [(L loc (BindStmt noAnn pat' body), fv_pat)] + +rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {}))) + = failWith (badIpBinds (Left binds)) + + +rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds))) + = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds + return [(L loc (LetStmt noAnn (HsValBinds x binds')), + -- Warning: this is bogus; see function invariant + emptyFVs + )] + +-- XXX Do we need to do something with the return and mfix names? +rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = L _ stmts })) -- Flatten Rec inside Rec + = rn_rec_stmts_lhs fix_env stmts + +rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ (L _ (LetStmt _ (EmptyLocalBinds _))) + = panic "rn_rec_stmt LetStmt EmptyLocalBinds" + +rn_rec_stmts_lhs :: AnnoBody body => MiniFixityEnv + -> [LStmt GhcPs (LocatedA (body GhcPs))] + -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] +rn_rec_stmts_lhs fix_env stmts + = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts + ; let boundNames = collectLStmtsBinders CollNoDictBinders (map fst ls) + -- First do error checking: we need to check for dups here because we + -- don't bind all of the variables from the Stmt at once + -- with bindLocatedLocals. + ; checkDupNames boundNames + ; return ls } + + +-- right-hand-sides + +rn_rec_stmt :: AnnoBody body => + HsStmtContextRn + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) + -> [Name] + -> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars) + -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] + -- Rename a Stmt that is inside a RecStmt (or mdo) + -- Assumes all binders are already in scope + -- Turns each stmt into a singleton Stmt +rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ (L lb body) noret _), _) + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- lookupQualifiedDo ctxt returnMName + ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, + L loc (LastStmt noExtField (L lb body') noret ret_op))] } + +rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ (L lb body) _ _), _) + = do { (body', fvs) <- rnBody body + ; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMName + ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, + L loc (BodyStmt noExtField (L lb body') then_op noSyntaxExpr))] } + +rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' (L lb body)), fv_pat) + = do { (body', fv_expr) <- rnBody body + ; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName + + ; (fail_op, fvs2) <- getMonadFailOp ctxt + + ; let bndrs = mkNameSet (collectPatBinders CollNoDictBinders pat') + fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 + ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } + ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, + L loc (BindStmt xbsrn pat' (L lb body')))] } + +rn_rec_stmt _ _ _ (L _ (LetStmt _ binds@(HsIPBinds {})), _) + = failWith (badIpBinds (Right binds)) + +rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (HsValBinds x binds')), _) + = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' + -- fixities and unused are handled above in rnRecStmtsAndThen + ; let fvs = allUses du_binds + ; return [(duDefs du_binds, fvs, emptyNameSet, + L loc (LetStmt noAnn (HsValBinds x binds')))] } + +-- no RecStmt case because they get flattened above when doing the LHSes +rn_rec_stmt _ _ _ stmt@(L _ (RecStmt {}), _) + = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) + +rn_rec_stmt _ _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) + +rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) + +rn_rec_stmt _ _ _ (L _ (LetStmt _ (EmptyLocalBinds _)), _) + = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" + +rn_rec_stmts :: AnnoBody body + => HsStmtContextRn + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) + -> [Name] + -> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] + -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] +rn_rec_stmts ctxt rnBody bndrs stmts + = do { segs_s <- mapM (rn_rec_stmt ctxt rnBody bndrs) stmts + ; return (concat segs_s) } + +--------------------------------------------- +segmentRecStmts :: SrcSpan -> HsStmtContextRn + -> Stmt GhcRn (LocatedA (body GhcRn)) + -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] + -> (FreeVars, Bool) + -- ^ The free variables used in later statements. + -- If the boolean is 'True', this might be an underestimate + -- because we are in GHCi, and might thus be missing some "used later" + -- FVs. See Note [What is "used later" in a rec stmt] + -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) + +segmentRecStmts loc ctxt empty_rec_stmt segs (fvs_later, might_be_more_fvs_later) + | null segs + = ([], final_fv_uses) + + | HsDoStmt (MDoExpr _) <- ctxt + = segsToStmts empty_rec_stmt grouped_segs fvs_later + -- Step 4: Turn the segments into Stmts + -- Use RecStmt when and only when there are fwd refs + -- Also gather up the uses from the end towards the + -- start, so we can tell the RecStmt which things are + -- used 'after' the RecStmt + + | otherwise + = ([ L (noAnnSrcSpan loc) $ + empty_rec_stmt { recS_stmts = noLocA ss + , recS_later_ids = nameSetElemsStable final_fvs_later + , recS_rec_ids = nameSetElemsStable + (defs `intersectNameSet` uses) }] + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + , uses `plusFV` final_fv_uses) + + where + (final_fv_uses, final_fvs_later) + | might_be_more_fvs_later + = (defs, defs) + -- If there might be more uses later (e.g. we are in GHCi and have not + -- yet seen the whole rec statement), conservatively assume that everything + -- will be used later (as is possible). + | otherwise + = ( uses `plusFV` fvs_later + , defs `intersectNameSet` fvs_later ) + + (defs_s, uses_s, _, ss) = unzip4 segs + defs = plusFVs defs_s + uses = plusFVs uses_s + + -- Step 2: Fill in the fwd refs. + -- The segments are all singletons, but their fwd-ref + -- field mentions all the things used by the segment + -- that are bound after their use + segs_w_fwd_refs = addFwdRefs segs + + -- Step 3: Group together the segments to make bigger segments + -- Invariant: in the result, no segment uses a variable + -- bound in a later segment + grouped_segs = glomSegments ctxt segs_w_fwd_refs + +---------------------------- +addFwdRefs :: [Segment a] -> [Segment a] +-- So far the segments only have forward refs *within* the Stmt +-- (which happens for bind: x <- ...x...) +-- This function adds the cross-seg fwd ref info + +addFwdRefs segs + = fst (foldr mk_seg ([], emptyNameSet) segs) + where + mk_seg (defs, uses, fwds, stmts) (segs, later_defs) + = (new_seg : segs, all_defs) + where + new_seg = (defs, uses, new_fwds, stmts) + all_defs = later_defs `unionNameSet` defs + new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs) + -- Add the downstream fwd refs here + +{- +Note [Segmenting mdo] +~~~~~~~~~~~~~~~~~~~~~ +NB. June 7 2012: We only glom segments that appear in an explicit mdo; +and leave those found in "do rec"'s intact. See +https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion +leading to this design choice. Hence the test in segmentRecStmts. + +Note [Glomming segments] +~~~~~~~~~~~~~~~~~~~~~~~~ +Glomming the singleton segments of an mdo into minimal recursive groups. + +At first I thought this was just strongly connected components, but +there's an important constraint: the order of the stmts must not change. + +Consider + mdo { x <- ...y... + p <- z + y <- ...x... + q <- x + z <- y + r <- x } + +Here, the first stmt mention 'y', which is bound in the third. +But that means that the innocent second stmt (p <- z) gets caught +up in the recursion. And that in turn means that the binding for +'z' has to be included... and so on. + +Start at the tail { r <- x } +Now add the next one { z <- y ; r <- x } +Now add one more { q <- x ; z <- y ; r <- x } +Now one more... but this time we have to group a bunch into rec + { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x } +Now one more, which we can add on without a rec + { p <- z ; + rec { y <- ...x... ; q <- x ; z <- y } ; + r <- x } +Finally we add the last one; since it mentions y we have to +glom it together with the first two groups + { rec { x <- ...y...; p <- z ; y <- ...x... ; + q <- x ; z <- y } ; + r <- x } + +Note [What is "used later" in a rec stmt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We desugar a recursive Stmt to something like + + (a,_,c) <- mfix (\(a,b,_) -> do { ... ; return (a,b,c) }) + ...stuff after the rec... + +The knot-tied tuple must contain +* All the variables that are used before they are bound in the `rec` block +* All the variables that are used after the entire `rec` block + +In the case of GHCi, however, we don't know what variables will be used +after the `rec` (#20206). For example, we might have + ghci> rec { x <- e1; y <- e2 } + ghci> print x + ghci> print y + +So we have to assume that *all* the variables bound in the `rec` are used +afterwards. We pass a Boolean to segmentRecStmts to signal such a situation, +in which case that function conservatively assumes that everything might well +be used later. +-} + +glomSegments :: HsStmtContextRn + -> [Segment (LStmt GhcRn body)] + -> [Segment (NonEmpty (LStmt GhcRn body))] + -- Each segment has a non-empty list of Stmts +-- See Note [Glomming segments] + +glomSegments _ [] = [] +glomSegments ctxt ((defs,uses,fwds,stmt) : segs) + -- Actually stmts will always be a singleton + = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others + where + segs' = glomSegments ctxt segs + (extras, others) = grab uses segs' + (ds, us, fs, ss) = unzip4 extras + + seg_defs = plusFVs ds `plusFV` defs + seg_uses = plusFVs us `plusFV` uses + seg_fwds = plusFVs fs `plusFV` fwds + seg_stmts = stmt :| concatMap toList ss + + grab :: NameSet -- The client + -> [Segment a] + -> ([Segment a], -- Needed by the 'client' + [Segment a]) -- Not needed by the client + -- The result is simply a split of the input + grab uses dus + = (reverse yeses, reverse noes) + where + (noes, yeses) = span not_needed (reverse dus) + not_needed (defs,_,_,_) = disjointNameSet defs uses + +---------------------------------------------------- +segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn)) + -- A RecStmt with the SyntaxOps filled in + -> [Segment (NonEmpty (LStmt GhcRn (LocatedA (body GhcRn))))] + -- Each Segment has a non-empty list of Stmts + -> FreeVars -- Free vars used 'later' + -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) + +segsToStmts _ [] fvs_later = ([], fvs_later) +segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later + = (new_stmt : later_stmts, later_uses `plusFV` uses) + where + (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later + new_stmt | non_rec = head ss + | otherwise = L (getLoc (head ss)) rec_stmt + rec_stmt = empty_rec_stmt { recS_stmts = noLocA (toList ss) + , recS_later_ids = nameSetElemsStable used_later + , recS_rec_ids = nameSetElemsStable fwds } + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + non_rec = NE.isSingleton ss && isEmptyNameSet fwds + used_later = defs `intersectNameSet` later_uses + -- The ones needed after the RecStmt + +{- +************************************************************************ +* * +ApplicativeDo +* * +************************************************************************ + +Note [ApplicativeDo] +~~~~~~~~~~~~~~~~~~~~ += Example = + +For a sequence of statements + + do + x <- A + y <- B x + z <- C + return (f x y z) + +We want to transform this to + + (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C + +It would be easy to notice that "y <- B x" and "z <- C" are +independent and do something like this: + + do + x <- A + (y,z) <- (,) <$> B x <*> C + return (f x y z) + +But this isn't enough! If A and C were also independent, then this +transformation loses the ability to do A and C in parallel. + +The algorithm works by first splitting the sequence of statements into +independent "segments", and a separate "tail" (the final statement). In +our example above, the segments would be + + [ x <- A + , y <- B x ] + + [ z <- C ] + +and the tail is: + + return (f x y z) + +Then we take these segments and make an Applicative expression from them: + + (\(x,y) z -> return (f x y z)) + <$> do { x <- A; y <- B x; return (x,y) } + <*> C + +Finally, we recursively apply the transformation to each segment, to +discover any nested parallelism. + += Syntax & spec = + + expr ::= ... | do {stmt_1; ..; stmt_n} expr | ... + + stmt ::= pat <- expr + | (arg_1 | ... | arg_n) -- applicative composition, n>=1 + | ... -- other kinds of statement (e.g. let) + + arg ::= pat <- expr + | {stmt_1; ..; stmt_n} {var_1..var_n} + +(note that in the actual implementation,the expr in a do statement is +represented by a LastStmt as the final stmt, this is just a +representational issue and may change later.) + +== Transformation to introduce applicative stmts == + +ado {} tail = tail +ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr' +ado {one} tail = one : tail +ado stmts tail + | n == 1 = ado before (ado after tail) + where (before,after) = split(stmts_1) + | n > 1 = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail + where + {stmts_1 .. stmts_n} = segments(stmts) + +segments(stmts) = + -- divide stmts into segments with no interdependencies + +mkArg({pat <- expr}) = (pat <- expr) +mkArg({stmt_1; ...; stmt_n}) = + {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)} + +split({stmt_1; ..; stmt_n) = + ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n}) + -- 1 <= i <= n + -- i is a good place to insert a bind + +== Desugaring for do == + +dsDo {} expr = expr + +dsDo {pat <- rhs; stmts} expr = + rhs >>= \pat -> dsDo stmts expr + +dsDo {(arg_1 | ... | arg_n)} (return expr) = + (\argpat (arg_1) .. argpat(arg_n) -> expr) + <$> argexpr(arg_1) + <*> ... + <*> argexpr(arg_n) + +dsDo {(arg_1 | ... | arg_n); stmts} expr = + join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr) + <$> argexpr(arg_1) + <*> ... + <*> argexpr(arg_n) + +== Special cases == + +If a do-expression contains only "return E" or "return $ E" plus +zero or more let-statements, we replace the "return" with "pure". +See Section 3.6 of the paper. + += Relevant modules in the rest of the compiler = + +ApplicativeDo touches a few phases in the compiler: + +* Renamer: The journey begins here in the renamer, where do-blocks are + scheduled as outlined above and transformed into applicative + combinators. However, the code is still represented as a do-block + with special forms of applicative statements. This allows us to + recover the original do-block when e.g. printing type errors, where + we don't want to show any of the applicative combinators since they + don't exist in the source code. + See ApplicativeStmt and ApplicativeArg in HsExpr. + +* Typechecker: ApplicativeDo passes through the typechecker much like any + other form of expression. The only crux is that the typechecker has to + be aware of the special ApplicativeDo statements in the do-notation, and + typecheck them appropriately. + Relevant module: GHC.Tc.Gen.Match + +* Desugarer: Any do-block which contains applicative statements is desugared + as outlined above, to use the Applicative combinators. + Relevant module: GHC.HsToCore.Expr + +-} + +-- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and +-- 'pureName' due to @QualifiedDo@ or @RebindableSyntax@. +data MonadNames = MonadNames { return_name, pure_name :: Name } + +instance Outputable MonadNames where + ppr (MonadNames {return_name=return_name,pure_name=pure_name}) = + hcat + [text "MonadNames { return_name = " + ,ppr return_name + ,text ", pure_name = " + ,ppr pure_name + ,text "}" + ] + +-- | rearrange a list of statements using ApplicativeDoStmt. See +-- Note [ApplicativeDo]. +rearrangeForApplicativeDo + :: HsDoFlavour + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) + +rearrangeForApplicativeDo _ [] = return ([], emptyNameSet) +-- If the do-block contains a single @return@ statement, change it to +-- @pure@ if ApplicativeDo is turned on. See Note [ApplicativeDo]. +rearrangeForApplicativeDo ctxt [(one,_)] = do + (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName + (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName + let monad_names = MonadNames { return_name = return_name + , pure_name = pure_name } + return $ case needJoin monad_names [one] (Just pure_name) of + (False, one') -> (one', emptyNameSet) + (True, _) -> ([one], emptyNameSet) +rearrangeForApplicativeDo ctxt stmts0 = do + optimal_ado <- goptM Opt_OptimalApplicativeDo + let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts + | otherwise = mkStmtTreeHeuristic stmts + traceRn "rearrangeForADo" (ppr stmt_tree) + (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName + (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName + let monad_names = MonadNames { return_name = return_name + , pure_name = pure_name } + stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs + where + (stmts,(last,last_fvs)) = findLast stmts0 + findLast [] = error "findLast" + findLast [last] = ([],last) + findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs + +-- | A tree of statements using a mixture of applicative and bind constructs. +data StmtTree a + = StmtTreeOne a + | StmtTreeBind (StmtTree a) (StmtTree a) + | StmtTreeApplicative [StmtTree a] + +instance Outputable a => Outputable (StmtTree a) where + ppr (StmtTreeOne x) = parens (text "StmtTreeOne" <+> ppr x) + ppr (StmtTreeBind x y) = parens (hang (text "StmtTreeBind") + 2 (sep [ppr x, ppr y])) + ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative") + 2 (vcat (map ppr xs))) + +flattenStmtTree :: StmtTree a -> [a] +flattenStmtTree t = go t [] + where + go (StmtTreeOne a) as = a : as + go (StmtTreeBind l r) as = go l (go r as) + go (StmtTreeApplicative ts) as = foldr go as ts + +type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars) +type Cost = Int + +-- | Turn a sequence of statements into an ExprStmtTree using a +-- heuristic algorithm. /O(n^2)/ +mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree +mkStmtTreeHeuristic [one] = StmtTreeOne one +mkStmtTreeHeuristic stmts = + case segments stmts of + [one] -> split one + segs -> StmtTreeApplicative (map split segs) + where + split [one] = StmtTreeOne one + split stmts = + StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after) + where (before, after) = splitSegment stmts + +-- | Turn a sequence of statements into an ExprStmtTree optimally, +-- using dynamic programming. /O(n^3)/ +mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree +mkStmtTreeOptimal stmts = + assert (not (null stmts)) $ -- the empty case is handled by the caller; + -- we don't support empty StmtTrees. + fst (arr ! (0,n)) + where + n = length stmts - 1 + stmt_arr = listArray (0,n) stmts + + -- lazy cache of optimal trees for subsequences of the input + arr :: Array (Int,Int) (ExprStmtTree, Cost) + arr = array ((0,0),(n,n)) + [ ((lo,hi), tree lo hi) + | lo <- [0..n] + , hi <- [lo..n] ] + + -- compute the optimal tree for the sequence [lo..hi] + tree lo hi + | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) + | otherwise = + case segments [ stmt_arr ! i | i <- [lo..hi] ] of + [] -> panic "mkStmtTree" + [_one] -> split lo hi + segs -> (StmtTreeApplicative trees, Partial.maximum costs) + where + bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs + -- We know `costs` must be non-empty, as `length segs >= 2` here. + (trees,costs) = unzip (map (uncurry split) (tail bounds)) + + -- find the best place to split the segment [lo..hi] + split :: Int -> Int -> (ExprStmtTree, Cost) + split lo hi + | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) + | otherwise = (StmtTreeBind before after, c1+c2) + where + -- As per the paper, for a sequence s1...sn, we want to find + -- the split with the minimum cost, where the cost is the + -- sum of the cost of the left and right subsequences. + -- + -- As an optimisation (also in the paper) if the cost of + -- s1..s(n-1) is different from the cost of s2..sn, we know + -- that the optimal solution is the lower of the two. Only + -- in the case that these two have the same cost do we need + -- to do the exhaustive search. + -- + ((before,c1),(after,c2)) = case nonEmpty [lo .. hi-1] of + Nothing -> + ( (StmtTreeOne (stmt_arr ! lo), 1), + (StmtTreeOne (stmt_arr ! hi), 1) ) + Just ks + | left_cost < right_cost + -> ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1)) + | left_cost > right_cost + -> ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost)) + | otherwise -> minimumBy (comparing cost) + [ (arr ! (lo,k), arr ! (k+1,hi)) | k <- ks ] + where + (left, left_cost) = arr ! (lo,hi-1) + (right, right_cost) = arr ! (lo+1,hi) + cost ((_,c1),(_,c2)) = c1 + c2 + + +-- | Turn the ExprStmtTree back into a sequence of statements, using +-- ApplicativeStmt where necessary. +stmtTreeToStmts + :: MonadNames + -> HsDoFlavour + -> ExprStmtTree + -> [ExprLStmt GhcRn] -- ^ the "tail" + -> FreeVars -- ^ free variables of the tail + -> RnM ( [ExprLStmt GhcRn] -- ( output statements, + , FreeVars ) -- , things we needed + +-- If we have a single bind, and we can do it without a join, transform +-- to an ApplicativeStmt. This corresponds to the rule +-- dsBlock [pat <- rhs] (return expr) = expr <$> rhs +-- In the spec, but we do it here rather than in the desugarer, +-- because we need the typechecker to typecheck the <$> form rather than +-- the bind form, which would give rise to a Monad constraint. +-- +-- If we have a single let, and the last statement is @return E@ or @return $ E@, +-- change the @return@ to @pure@. +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _)) + tail _tail_fvs + | definitelyLazyPattern pat, (False,tail') <- needJoin monad_names tail Nothing + -- See Note [ApplicativeDo and strict patterns] + = mkApplicativeStmt ctxt [ApplicativeArgOne + { xarg_app_arg_one = xbsrn_failOp xbs + , app_arg_pattern = pat + , arg_expr = rhs + , is_body_stmt = False + }] + False tail' +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) + tail _tail_fvs + | (False,tail') <- needJoin monad_names tail Nothing + = mkApplicativeStmt ctxt + [ApplicativeArgOne + { xarg_app_arg_one = Nothing + , app_arg_pattern = nlWildPatName + , arg_expr = rhs + , is_body_stmt = True + }] False tail' +stmtTreeToStmts monad_names ctxt (StmtTreeOne (let_stmt@(L _ LetStmt{}),_)) + tail _tail_fvs = do + (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName + return $ case needJoin monad_names tail (Just pure_name) of + (False, tail') -> (let_stmt : tail', emptyNameSet) + (True, _) -> (let_stmt : tail, emptyNameSet) + +stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = + return (s : tail, emptyNameSet) + +stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do + (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs + let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after)) + (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs + return (stmts2, fvs1 `plusFV` fvs2) + +stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do + hscEnv <- getTopEnv + rdrEnv <- getGlobalRdrEnv + comps <- getCompleteMatchesTcM + pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees + strict <- xoptM LangExt.Strict + let (stmts', fvss) = unzip pairs + let (need_join, tail') = + -- See Note [ApplicativeDo and refutable patterns] + if any (hasRefutablePattern strict hscEnv rdrEnv comps) stmts' + then (True, tail) + else needJoin monad_names tail Nothing + + (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' + return (stmts, unionNameSets (fvs:fvss)) + where + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt xbs pat exp), _)) + = return (ApplicativeArgOne + { xarg_app_arg_one = xbsrn_failOp xbs + , app_arg_pattern = pat + , arg_expr = exp + , is_body_stmt = False + }, emptyFVs) + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) = + return (ApplicativeArgOne + { xarg_app_arg_one = Nothing + , app_arg_pattern = nlWildPatName + , arg_expr = exp + , is_body_stmt = True + }, emptyFVs) + stmtTreeArg ctxt tail_fvs tree = do + let stmts = flattenStmtTree tree + pvarset = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts) + `intersectNameSet` tail_fvs + pvars = nameSetElemsStable pvarset + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + pat = mkBigLHsVarPatTup pvars + tup = mkBigLHsVarTup pvars noExtField + (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset + (mb_ret, fvs1) <- + if | Just (L _ (XStmtLR ApplicativeStmt{})) <- lastMaybe stmts' -> + return (unLoc tup, emptyNameSet) + | otherwise -> do + -- Need 'pureAName' and not 'returnMName' here, so that it requires + -- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed). + (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName + let expr = HsApp noExtField (noLocA (genHsVar pure_name)) tup + return (expr, emptyFVs) + return ( ApplicativeArgMany + { xarg_app_arg_many = noExtField + , app_stmts = stmts' + , final_expr = mb_ret + , bv_pattern = pat + , stmt_context = ctxt + } + , fvs1 `plusFV` fvs2) + + +-- | Divide a sequence of statements into segments, where no segment +-- depends on any variables defined by a statement in another segment. +segments + :: [(ExprLStmt GhcRn, FreeVars)] + -> [[(ExprLStmt GhcRn, FreeVars)]] +segments stmts = merge $ reverse $ map reverse $ walk (reverse stmts) + where + allvars = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts) + + -- We would rather not have a segment that just has LetStmts in + -- it, so combine those with the next segment where possible. + -- We don't merge it with the previous segment because the merged segment + -- would require 'Monad' while it may otherwise only require 'Applicative'. + merge [] = [] + merge (seg : segs) + = case rest of + s:ss | all_lets -> (seg ++ s) : ss + _otherwise -> seg : rest + where + rest = merge segs + all_lets = all (isLetStmt . fst) seg + + -- walk splits the statement sequence into segments, traversing + -- the sequence from the back to the front, and keeping track of + -- the set of free variables of the current segment. Whenever + -- this set of free variables is empty, we have a complete segment. + walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]] + walk [] = [] + walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest + where (seg,rest) = chunter fvs' stmts + (_, fvs') = stmtRefs stmt fvs + + chunter _ [] = ([], []) + chunter vars orig@((stmt,fvs) : rest) + | isEmptyNameSet vars, definitelyLazyPatternBind stmt + = ([], orig) + | otherwise + -- See Note [ApplicativeDo and strict patterns] + = ((stmt,fvs) : chunk, rest') + where (chunk,rest') = chunter vars' rest + (pvars, evars) = stmtRefs stmt fvs + vars' = (vars `minusNameSet` pvars) `unionNameSet` evars + + stmtRefs stmt fvs + | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars) + | otherwise = (pvars, fvs') + where fvs' = fvs `intersectNameSet` allvars + pvars = mkNameSet (collectStmtBinders CollNoDictBinders (unLoc stmt)) + + definitelyLazyPatternBind :: ExprLStmt GhcRn -> Bool + definitelyLazyPatternBind (L _ (BindStmt _ pat _)) = definitelyLazyPattern pat + definitelyLazyPatternBind _ = True + +{- +Note [ApplicativeDo and strict patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A strict pattern match is really a dependency. For example, + +do + (x,y) <- A + z <- B + return C + +The pattern (_,_) must be matched strictly before we do B. If we +allowed this to be transformed into + + (\(x,y) -> \z -> C) <$> A <*> B + +then it could be lazier than the standard desugaring using >>=. See #13875 +for more examples. + +Thus, whenever we have a potentially strict pattern match, we treat it as a +dependency between that statement and the following one. The +dependency prevents those two statements from being performed "in +parallel" in an ApplicativeStmt, but doesn't otherwise affect what we +can do with the rest of the statements in the same "do" expression. + +The necessary "definitely lazy" test is similar, but distinct to irrefutability. +See Note [definitelyLazyPattern vs. isIrrefutableHsPat]. + +Note [definitelyLazyPattern vs. isIrrefutableHsPat] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Lazy patterns are irrefutable, but not all irrefutable patterns are lazy. +Examples: + * (x,y) is an irrefutable pattern, but not lazy. + * x is both irrefutable and lazy. + * The or pattern (~True; False) is both irrefutable and lazy, + because the first pattern alt accepts without forcing the scrutinee. + * The or pattern (False; ~True) is irrefutable, but not lazy, + because the first pattern alt forces the scrutinee and may fail, + but the second alt is irrefutable and hence the whole pattern is. +-} + +definitelyLazyPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool +-- See Note [definitelyLazyPattern vs. isIrrefutableHsPat] +-- A conservative analysis that says False if in doubt, hence "definitely". +-- E.g., the ViewPat (const 5 -> 13) is really lazy, but below we say False. +definitelyLazyPattern (L loc pat) = + case pat of + WildPat{} -> True + VarPat{} -> True + LazyPat{} -> True + AsPat _ _ p -> definitelyLazyPattern p + ParPat _ p -> definitelyLazyPattern p + ViewPat _ _f p -> definitelyLazyPattern p --- || definitelyLazyFun _f + -- NB: We keep it simple and assume `definitelyLazyFun _ = False` + SigPat _ p _ -> definitelyLazyPattern p + OrPat _ p -> definitelyLazyPattern (NE.head p) + -- NB: foo (~True; False) = () is lazy! + -- See Note [definitelyLazyPattern vs. isIrrefutableHsPat] + BangPat{} -> False + ListPat{} -> False + TuplePat{} -> False + SumPat{} -> False + ConPat{} -> False -- Some PatSyns are lazy; False is conservative + LitPat{} -> False + NPat{} -> False -- Some NPats are lazy; False is conservative + NPlusKPat{} -> False + SplicePat{} -> False + + -- The behavior of this case is unimportant, as GHC will throw an error shortly + -- after reaching this case for other reasons (see TcRnIllegalTypePattern). + EmbTyPat{} -> True + InvisPat{} -> True + + XPat ext -> case ghcPass @p of + GhcRn + | HsPatExpanded _ p <- ext + -> definitelyLazyPattern (L loc p) + GhcTc -> case ext of + ExpansionPat _ p -> definitelyLazyPattern (L loc p) + CoPat {} -> panic "definitelyLazyPattern: CoPat" + +{- +Note [ApplicativeDo and refutable patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Refutable patterns in do blocks are desugared to use the monadic 'fail' operation. +This means that sometimes an applicative block needs to be wrapped in 'join' simply because +of a refutable pattern, in order for the types to work out. + +-} + +hasRefutablePattern :: Bool -- ^ is -XStrict enabled? + -> HscEnv + -> GlobalRdrEnv + -> CompleteMatches + -> ApplicativeArg GhcRn -> Bool +hasRefutablePattern is_strict hsc_env rdr_env comps arg = + case arg of + ApplicativeArgOne { app_arg_pattern = pat, is_body_stmt = False} + -> not (isIrrefutableHsPat is_strict (irrefutableConLikeRn hsc_env rdr_env comps) pat) + _ -> False + +isLetStmt :: LStmt (GhcPass a) b -> Bool +isLetStmt (L _ LetStmt{}) = True +isLetStmt _ = False + +-- | Find a "good" place to insert a bind in an indivisible segment. +-- This is the only place where we use heuristics. The current +-- heuristic is to peel off the first group of independent statements +-- and put the bind after those. +splitSegment + :: [(ExprLStmt GhcRn, FreeVars)] + -> ( [(ExprLStmt GhcRn, FreeVars)] + , [(ExprLStmt GhcRn, FreeVars)] ) +splitSegment [one,two] = ([one],[two]) + -- there is no choice when there are only two statements; this just saves + -- some work in a common case. +splitSegment stmts + | Just (lets,binds,rest) <- slurpIndependentStmts stmts + = if not (null lets) + then (lets, binds++rest) + else (lets++binds, rest) + | otherwise + = case stmts of + (x:xs) -> ([x],xs) + _other -> (stmts,[]) + +slurpIndependentStmts + :: [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] + -> Maybe ( [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- LetStmts + , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- BindStmts + , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] ) +slurpIndependentStmts stmts = go [] [] emptyNameSet stmts + where + -- If we encounter a BindStmt that doesn't depend on a previous BindStmt + -- in this group, then add it to the group. We have to be careful about + -- strict patterns though; splitSegments expects that if we return Just + -- then we have actually done some splitting. Otherwise it will go into + -- an infinite loop (#14163). + go lets indep bndrs ((L loc (BindStmt xbs pat body), fvs): rest) + | disjointNameSet bndrs fvs, definitelyLazyPattern pat + = go lets ((L loc (BindStmt xbs pat body), fvs) : indep) + bndrs' rest + where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders CollNoDictBinders pat) + -- If we encounter a LetStmt that doesn't depend on a BindStmt in this + -- group, then move it to the beginning, so that it doesn't interfere with + -- grouping more BindStmts. + -- TODO: perhaps we shouldn't do this if there are any strict bindings, + -- because we might be moving evaluation earlier. + go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest) + | disjointNameSet bndrs fvs + = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest + go _ [] _ _ = Nothing + go _ [_] _ _ = Nothing + go lets indep _ stmts = Just (reverse lets, reverse indep, stmts) + +-- | Build an ApplicativeStmt, and strip the "return" from the tail +-- if necessary. +-- +-- For example, if we start with +-- do x <- E1; y <- E2; return (f x y) +-- then we get +-- do (E1[x] | E2[y]); f x y +-- +-- the LastStmt in this case has the return removed, but we set the +-- flag on the LastStmt to indicate this, so that we can print out the +-- original statement correctly in error messages. It is easier to do +-- it this way rather than try to ignore the return later in both the +-- typechecker and the desugarer (I tried it that way first!). +mkApplicativeStmt + :: HsDoFlavour + -> [ApplicativeArg GhcRn] -- ^ The args + -> Bool -- ^ True <=> need a join + -> [ExprLStmt GhcRn] -- ^ The body statements + -> RnM ([ExprLStmt GhcRn], FreeVars) +mkApplicativeStmt ctxt args need_join body_stmts + = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) fmapName + ; (ap_op, fvs2) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) apAName + ; (mb_join, fvs3) <- + if need_join then + do { (join_op, fvs) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) joinMName + ; return (Just join_op, fvs) } + else + return (Nothing, emptyNameSet) + -- We cannot really say where the ApplicativeStmt is located with more accuracy + -- than the span of the do-block, but it is better than nothing for IDE info + -- See Note [Source locations for implicit function calls] + ; loc <- getSrcSpanM + ; let applicative_stmt = L (noAnnSrcSpan loc) $ XStmtLR $ ApplicativeStmt noExtField + (zip (fmap_op : repeat ap_op) args) + mb_join + ; return ( applicative_stmt : body_stmts + , fvs1 `plusFV` fvs2 `plusFV` fvs3) } + +-- | Given the statements following an ApplicativeStmt, determine whether +-- we need a @join@ or not, and remove the @return@ if necessary. +-- +-- We don't need @join@ if there's a single @LastStmt@ in the form of +-- @return E@, @return $ E@, @pure E@ or @pure $ E@. +needJoin :: MonadNames + -> [ExprLStmt GhcRn] + -- If this is @Just pure@, replace return by pure + -- If this is @Nothing@, strip the return/pure + -> Maybe Name + -> (Bool, [ExprLStmt GhcRn]) +needJoin _monad_names [] _mb_pure = (False, []) -- we're in an ApplicativeArg +needJoin monad_names [L loc (LastStmt _ e _ t)] mb_pure + | Just (arg, noret) <- isReturnApp monad_names e mb_pure = + (False, [L loc (LastStmt noExtField arg noret t)]) +needJoin _monad_names stmts _mb_pure = (True, stmts) + +-- | @(Just e, Just False)@, if the expression is @return/pure e@, +-- and the third argument is Nothing, +-- @(Just e, Just True)@ if the expression is @return/pure $ e@, +-- and the third argument is Nothing, +-- @(Just (pure e), Nothing)@ if the expression is @return/pure e@, +-- and the third argument is @Just pure_expr@, +-- @(Just (pure $ e), Nothing)@ if the expression is @return/pure $ e@, +-- and the third argument is @Just pure_expr@, +-- otherwise @Nothing@. +isReturnApp :: MonadNames + -> LHsExpr GhcRn + -- If this is @Just pure@, replace return by pure + -- If this is @Nothing@, strip the return/pure + -> Maybe Name + -> 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_name <- mb_pure, is_return l, is_dollar op -> + Just (L loc (OpApp x (to_pure l pure_name) op r), Nothing) + | is_return l, is_dollar op -> Just (r, Just True) + HsApp x f arg + | Just pure_name <- mb_pure, is_return f -> + Just (L loc (HsApp x (to_pure f pure_name) arg), Nothing) + | is_return f -> Just (arg, Just False) + _otherwise -> Nothing + where + is_var f (L _ (HsPar _ e)) = is_var f e + is_var f (L _ (HsAppType _ e _)) = is_var f e + is_var f (L _ (HsVar _ (L _ (WithUserRdr _q r)))) = f r + -- TODO: I don't know how to get this right for rebindable syntax + is_var _ _ = False + + is_return = is_var (\n -> n == return_name monad_names + || n == pure_name monad_names) + to_pure (L loc _) pure_name = L loc (genHsVar pure_name) + is_dollar = is_var (`hasKey` dollarIdKey) + +{- +************************************************************************ +* * +\subsubsection{Errors} +* * +************************************************************************ +-} + +checkEmptyStmts :: HsStmtContextRn -> RnM () +-- We've seen an empty sequence of Stmts... is that ok? +checkEmptyStmts ctxt + = mapM_ (addErr . TcRnEmptyStmtsGroup) mb_err + where + mb_err = case ctxt of + PatGuard {} -> Nothing -- Pattern guards can be empty + ParStmtCtxt {} -> Just EmptyStmtsGroupInParallelComp + TransStmtCtxt {} -> Just EmptyStmtsGroupInTransformListComp + HsDoStmt flav -> Just $ EmptyStmtsGroupInDoNotation flav + ArrowExpr -> Just EmptyStmtsGroupInArrowNotation + +---------------------- +checkLastStmt :: AnnoBody body + => HsStmtContextRn + -> LStmt GhcPs (LocatedA (body GhcPs)) + -> RnM (LStmt GhcPs (LocatedA (body GhcPs))) +checkLastStmt ctxt lstmt@(L loc stmt) + = case ctxt of + HsDoStmt ListComp -> check_comp + HsDoStmt MonadComp -> check_comp + HsDoStmt DoExpr{} -> check_do + HsDoStmt MDoExpr{} -> check_do + ArrowExpr -> check_do + _ -> check_other + where + check_do -- Expect BodyStmt, and change it to LastStmt + = case stmt of + BodyStmt _ e _ _ -> return (L loc (mkLastStmt e)) + LastStmt {} -> return lstmt -- "Deriving" clauses may generate a + -- LastStmt directly (unlike the parser) + _ -> do { addErr $ TcRnLastStmtNotExpr ctxt + $ UnexpectedStatement stmt + ; return lstmt } + + + check_comp -- Expect LastStmt; this should be enforced by the parser! + = case stmt of + LastStmt {} -> return lstmt + _ -> pprPanic "checkLastStmt" (ppr lstmt) + + check_other -- Behave just as if this wasn't the last stmt + = do { checkStmt ctxt lstmt; return lstmt } + +-- Checking when a particular Stmt is ok +checkStmt :: AnnoBody body + => HsStmtContextRn + -> LStmt GhcPs (LocatedA (body GhcPs)) + -> RnM () +checkStmt ctxt (L _ stmt) + = do { dflags <- getDynFlags + ; case okStmt dflags ctxt stmt of + IsValid -> return () + NotValid ext -> addErr $ + TcRnUnexpectedStatementInContext + ctxt (UnexpectedStatement stmt) ext } + +------------ +emptyInvalid :: Validity' (Maybe LangExt.Extension) +emptyInvalid = NotValid Nothing -- Invalid, and no extension to suggest + +okStmt, okDoStmt, okCompStmt, okParStmt + :: DynFlags -> HsStmtContextRn + -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension) +-- Return Nothing if OK, (Just extra) if not ok +-- The "extra" is an SDoc that is appended to a generic error message + +okStmt dflags ctxt stmt + = case ctxt of + PatGuard {} -> okPatGuardStmt stmt + ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt + HsDoStmt flavour -> okDoFlavourStmt dflags flavour ctxt stmt + ArrowExpr -> okDoStmt dflags ctxt stmt + TransStmtCtxt ctxt -> okStmt dflags ctxt stmt + +okDoFlavourStmt + :: DynFlags -> HsDoFlavour -> HsStmtContextRn + -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension) +okDoFlavourStmt dflags flavour ctxt stmt = case flavour of + DoExpr{} -> okDoStmt dflags ctxt stmt + MDoExpr{} -> okDoStmt dflags ctxt stmt + GhciStmtCtxt -> okDoStmt dflags ctxt stmt + ListComp -> okCompStmt dflags ctxt stmt + MonadComp -> okCompStmt dflags ctxt stmt + +------------- +okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension) +okPatGuardStmt stmt + = case stmt of + BodyStmt {} -> IsValid + BindStmt {} -> IsValid + LetStmt {} -> IsValid + _ -> emptyInvalid + +------------- +okParStmt dflags ctxt stmt + = case stmt of + LetStmt _ (HsIPBinds {}) -> emptyInvalid + _ -> okStmt dflags ctxt stmt + +---------------- +okDoStmt dflags ctxt stmt + = case stmt of + RecStmt {} + | LangExt.RecursiveDo `xopt` dflags -> IsValid + | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec' + | otherwise -> NotValid (Just LangExt.RecursiveDo) + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid + _ -> emptyInvalid + +---------------- +okCompStmt dflags _ stmt + = case stmt of + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid + ParStmt {} + | LangExt.ParallelListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (Just LangExt.ParallelListComp) + TransStmt {} + | LangExt.TransformListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (Just LangExt.TransformListComp) + RecStmt {} -> emptyInvalid + LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) + +--------- +checkTupleSection :: [HsTupArg GhcPs] -> RnM () +checkTupleSection args + = do { tuple_section <- xoptM LangExt.TupleSections + ; checkErr (all tupArgPresent args || tuple_section) msg } + where + msg :: TcRnMessage + msg = TcRnIllegalTupleSection + +--------- +sectionErr :: HsExpr GhcPs -> TcRnMessage +sectionErr = TcRnSectionWithoutParentheses + +badIpBinds :: Either (HsLocalBindsLR GhcPs GhcPs) (HsLocalBindsLR GhcRn GhcPs) -> TcRnMessage +badIpBinds = TcRnIllegalImplicitParameterBindings + +--------- + +monadFailOp :: LPat GhcRn + -> HsStmtContextRn + -> RnM (FailOperator GhcRn, FreeVars) +monadFailOp pat ctxt = do + strict <- xoptM LangExt.Strict + hscEnv <- getTopEnv + rdrEnv <- getGlobalRdrEnv + comps <- getCompleteMatchesTcM + -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) + -- we should not need to fail. + if | isIrrefutableHsPat strict (irrefutableConLikeRn hscEnv rdrEnv comps) pat + -> return (Nothing, emptyFVs) + + -- For non-monadic contexts (e.g. guard patterns, list + -- comprehensions, etc.) we should not need to fail, or failure is handled in + -- a different way. See Note [Failing pattern matches in Stmts]. + | not (isMonadStmtContext ctxt) + -> return (Nothing, emptyFVs) + + | otherwise + -> getMonadFailOp ctxt + +{- +Note [Monad fail : Rebindable syntax, overloaded strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Given the code + foo x = do { Just y <- x; return y } + +we expect it to desugar as + foo x = x >>= \r -> case r of + Just y -> return y + Nothing -> fail "Pattern match error" + +But with RebindableSyntax and OverloadedStrings, we really want +it to desugar thus: + foo x = x >>= \r -> case r of + Just y -> return y + Nothing -> fail (fromString "Patterm match error") + +So, in this case, we synthesize the function + \x -> fail (fromString x) + +(rather than plain 'fail') for the 'fail' operation. This is done in +'getMonadFailOp'. + +Similarly with QualifiedDo and OverloadedStrings, we also want to desugar +using fromString: + + foo x = M.do { Just y <- x; return y } + + ===> + + foo x = x M.>>= \r -> case r of + Just y -> return y + Nothing -> M.fail (fromString "Pattern match error") + +-} +getMonadFailOp :: HsStmtContext fn -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op +getMonadFailOp ctxt + = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags + ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags + ; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings + ; return (Just fail, fvs) + } + where + isQualifiedDo = isJust (qualifiedDoModuleName_maybe ctxt) + + reallyGetMonadFailOp rebindableSyntax overloadedStrings + | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do + (failName, failFvs) <- lookupQualifiedDoName ctxt failMName + (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName + let arg_lit = mkVarOccFS (fsLit "arg") + arg_name <- newSysName arg_lit + let arg_syn_expr = nlHsVar arg_name + body :: LHsExpr GhcRn = + nlHsApp (noLocA (genHsVar failName)) + (nlHsApp (noLocA $ fromStringExpr) arg_syn_expr) + let failAfterFromStringExpr :: HsExpr GhcRn = + unLoc $ mkHsLam (noLocA [noLocA $ VarPat noExtField $ noLocA arg_name]) body + let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = + mkSyntaxExpr failAfterFromStringExpr + return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) + | otherwise = lookupQualifiedDo ctxt failMName + + +{- ********************************************************************* +* * + Generating code for ExpandedThingRn + See Note [Handling overloaded and rebindable constructs] +* * +********************************************************************* -} + +-- | Expand `HsIf` if rebindable syntax is turned on +-- See Note [Handling overloaded and rebindable constructs] +rnHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnHsIf p b1 b2 + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLExpr b1 + ; (b2', fvB2) <- rnLExpr b2 + ; let fvs_if = plusFVs [fvP, fvB1, fvB2] + rn_if = HsIf noExtField p' b1' b2' + + -- Deal with rebindable syntax + ; mb_ite <- lookupIfThenElse + ; case mb_ite of + Nothing -- Non rebindable-syntax case + -> return (rn_if, fvs_if) + + Just ite_name -- Rebindable-syntax case + -> do { let ds_if = genHsApps ite_name [p', b1', b2'] + fvs = plusFVs [fvs_if, unitFV ite_name] + ; return (mkExpandedExpr rn_if ds_if, fvs) } } + +----------------------------------------- +-- Bits and pieces for RecordDotSyntax. +-- +-- See Note [Overview of record dot syntax] in GHC.Hs.Expr. + +-- mkGetField arg field calculates a get_field @field arg expression. +-- e.g. z.x = mkGetField z x = get_field @x z +mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn +mkGetField get_field arg field = unLoc (head $ mkGet get_field (arg :| []) field) + +-- mkSetField a field b calculates a set_field @field expression. +-- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' to a on b"). +-- NB: the order of aruments is specified by GHC Proposal 583: HasField redesign. +mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn +mkSetField set_field a (L _ (FieldLabelString field)) b = + genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) b) a + +mkGet :: Name -> NonEmpty (LHsExpr GhcRn) -> LocatedAn NoEpAnns FieldLabelString -> NonEmpty (LHsExpr GhcRn) +mkGet get_field l@(r :| _) (L _ (FieldLabelString field)) = + wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) NE.<| l + +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 FieldLabelString -> HsExpr GhcRn +mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields + where + f :: HsExpr GhcRn -> FieldLabelString -> HsExpr GhcRn + f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc] + + proj :: FieldLabelString -> HsExpr GhcRn + proj (FieldLabelString f) = genHsVar getFieldName `genAppType` genHsTyLit f + +-- mkProjUpdateSetField calculates functions representing dot notation record updates. +-- e.g. Suppose an update like foo.bar = 1. +-- We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1). +mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn) +mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } )) + = let { + ; flds = NE.map (fmap (unLoc . dfoLabel)) flds' + ; final = last flds -- quux + ; fields = init flds -- [foo, bar, baz] + ; getters = \a -> foldl' (mkGet get_field) (a :| []) fields -- Ordered from deep to shallow. + -- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a] + ; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow. + -- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)] + } + in (\a -> foldl' (mkSet set_field) arg (zips a)) + -- setField@"foo" (a) (setField@"bar" (getField @"foo" (a))(setField@"baz" (getField @"bar" (getField @"foo" (a)))(setField@"quux" (getField @"baz" (getField @"bar" (getField @"foo" (a))))(quux)))) + +mkRecordDotUpd :: Name -> Name -> LHsExpr GhcRn -> [LHsRecUpdProj GhcRn] -> HsExpr GhcRn +mkRecordDotUpd get_field set_field exp updates = foldl' fieldUpdate (unLoc exp) updates + where + fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn + fieldUpdate acc lpu = unLoc $ (mkProjUpdateSetField get_field set_field lpu) (wrapGenSpan acc) + +rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeVars) +rnHsUpdProjs us = do + (u, fvs) <- unzip <$> mapM rnRecUpdProj us + pure (u, plusFVs fvs) + where + rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars) + rnRecUpdProj (L l (HsFieldBind _ fs arg pun)) + = do { (arg, fv) <- rnLExpr arg + ; return $ + (L l (HsFieldBind { + hfbAnn = noAnn + , hfbLHS = fmap rnFieldLabelStrings fs + , hfbRHS = arg + , hfbPun = pun }), fv ) } diff --git a/GHC/Rename/Expr.hs-boot b/GHC/Rename/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Rename/Expr.hs-boot @@ -0,0 +1,25 @@ +{-# LANGUAGE ConstraintKinds #-} +module GHC.Rename.Expr where + +import GHC.Types.Name +import GHC.Hs +import GHC.Types.Name.Set ( FreeVars ) +import GHC.Tc.Types +import GHC.Utils.Outputable ( Outputable ) + +rnExpr :: HsExpr GhcPs + -> RnM (HsExpr GhcRn, FreeVars) + +rnLExpr :: LHsExpr GhcPs + -> RnM (LHsExpr GhcRn, FreeVars) + +type AnnoBody body + = ( Outputable (body GhcPs) + ) + +rnStmts :: --forall thing body. + AnnoBody body => HsStmtContextRn + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) + -> [LStmt GhcPs (LocatedA (body GhcPs))] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars) diff --git a/GHC/Rename/Fixity.hs b/GHC/Rename/Fixity.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Fixity.hs @@ -0,0 +1,205 @@ +{- +This module contains code which maintains and manipulates the +fixity environment during renaming. +-} + +module GHC.Rename.Fixity + ( MiniFixityEnv(..) + , addLocalFixities + , lookupMiniFixityEnv + , emptyMiniFixityEnv + , lookupFixityRn + , lookupFixityRn_help + , lookupFieldFixityRn + , lookupTyFixityRn + ) where + +import GHC.Prelude + +import GHC.Iface.Load +import GHC.Hs +import GHC.Tc.Utils.Monad + +import GHC.Unit.Module +import GHC.Unit.Module.ModIface + +import GHC.Types.Fixity.Env +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Fixity +import GHC.Types.SrcLoc + +import GHC.Utils.Outputable + +import GHC.Data.Maybe + +import GHC.Rename.Unbound + +{- +********************************************************* +* * + Fixities +* * +********************************************************* + +Note [Fixity signature lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A fixity declaration like + + infixr 2 ? + +can refer to a value-level operator, e.g.: + + (?) :: String -> String -> String + +or a type-level operator, like: + + data (?) a b = A a | B b + +so we extend the lookup of the reader name '?' to the TcClsName namespace, as +well as the original namespace. + +The extended lookup is also used in other places, like resolution of +deprecation declarations, and lookup of names in GHCi. +-} + +-------------------------------- + +-- | Mini fixity env for the names we're about +-- to bind, in a single binding group +-- +-- It is keyed by the *FastString*, not the *OccName*, because +-- the single fixity decl @infix 3 T@ +-- affects both the data constructor T and the type constructor T +-- +-- We keep the location so that if we find +-- a duplicate, we can report it sensibly +-- +-- Fixity declarations may influence names in a single namespace by using +-- a type or data specifier, e.g. in: +-- +-- > data a :*: b = a :*: b +-- > infix 3 type :*: +-- +-- To handle that correctly, MiniFixityEnv contains separate +-- fields for type-level and data-level names. +-- If no namespace specifier is provided, the declaration will +-- populate both the type-level and data-level fields. +data MiniFixityEnv = MFE + { mfe_data_level_names :: FastStringEnv (Located Fixity) + , mfe_type_level_names :: FastStringEnv (Located Fixity) + } + +-------------------------------- +-- Used for nested fixity decls to bind names along with their fixities. +-- the fixities are given as a UFM from an OccName's FastString to a fixity decl + +addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a +addLocalFixities env names thing_inside + = extendFixityEnv (mapMaybe find_fixity names) thing_inside + where + find_fixity name = case lookupMiniFixityEnv env name of + Just lfix -> Just (name, FixItem occ (unLoc lfix)) + Nothing -> Nothing + where + occ = nameOccName name + +lookupMiniFixityEnv :: MiniFixityEnv -> Name -> Maybe (Located Fixity) +lookupMiniFixityEnv MFE{mfe_data_level_names, mfe_type_level_names} name + | isValNameSpace namespace = find_fixity_in_env mfe_data_level_names name + | otherwise = find_fixity_in_env mfe_type_level_names name + where + namespace = nameNameSpace name + + find_fixity_in_env mini_fix_env name + = lookupFsEnv mini_fix_env (occNameFS occ) + where + occ = nameOccName name + +emptyMiniFixityEnv :: MiniFixityEnv +emptyMiniFixityEnv = MFE emptyFsEnv emptyFsEnv + +{- +-------------------------------- +lookupFixity is a bit strange. + +* Nested local fixity decls are put in the local fixity env, which we + find with getFixtyEnv + +* Imported fixities are found in the PIT + +* Top-level fixity decls in this module may be for Names that are + either Global (constructors, class operations) + or Local/Exported (everything else) + (See notes with GHC.Rename.Names.getLocalDeclBinders for why we have this split.) + We put them all in the local fixity environment +-} + +lookupFixityRn :: Name -> RnM Fixity +lookupFixityRn = fmap snd . lookupFixityRn_help + +-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity' +-- in a local environment or from an interface file. Otherwise, it returns +-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without +-- user-supplied fixity declarations). +lookupFixityRn_help :: Name + -> RnM (Bool, Fixity) +lookupFixityRn_help name + | isUnboundName name + = return (False, Fixity minPrecedence InfixL) + -- Minimise errors from unbound names; eg + -- a>0 `foo` b>0 + -- where 'foo' is not in scope, should not give an error (#7937) + + | otherwise + = do { local_fix_env <- getFixityEnv + ; case lookupNameEnv local_fix_env name of { + Just (FixItem _ fix) -> return (True, fix) ; + Nothing -> + + do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name + -- Local (and interactive) names are all in the + -- fixity env, and don't have entries in the HPT + then return (False, defaultFixity) + else lookup_imported } } } + where + occ = nameOccName name + lookup_imported + -- For imported names, we have to get their fixities by doing a + -- loadInterfaceForName, and consulting the Ifaces that comes back + -- from that, because the interface file for the Name might not + -- have been loaded yet. Why not? Suppose you import module A, + -- which exports a function 'f', thus; + -- module CurrentModule where + -- import A( f ) + -- module A( f ) where + -- import B( f ) + -- Then B isn't loaded right away (after all, it's possible that + -- nothing from B will be used). When we come across a use of + -- 'f', we need to know its fixity, and it's then, and only + -- then, that we load B.hi. That is what's happening here. + -- + -- loadInterfaceForName will find B.hi even if B is a hidden module, + -- and that's what we want. + = do { iface <- loadInterfaceForName doc name + ; let mb_fix = mi_fix_fn iface occ + ; let msg = case mb_fix of + Nothing -> + text "looking up name" <+> ppr name + <+> text "in iface, but found no fixity for it." + <+> text "Using default fixity instead." + Just f -> + text "looking up name in iface and found:" + <+> vcat [ppr name, ppr f] + ; traceRn "lookupFixityRn_either:" msg + ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) } + + doc = text "Checking fixity for" <+> ppr name + +--------------- +lookupTyFixityRn :: LocatedN Name -> RnM Fixity +lookupTyFixityRn = lookupFixityRn . unLoc + +lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity +lookupFieldFixityRn (FieldOcc _ n) = lookupFixityRn (unLoc n) diff --git a/GHC/Rename/HsType.hs b/GHC/Rename/HsType.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/HsType.hs @@ -0,0 +1,2219 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +module GHC.Rename.HsType ( + -- Type related stuff + rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext, + rnLHsKind, rnLHsTypeArgs, + rnHsSigType, rnHsWcType, rnHsTyLit, rnHsMultAnnWith, + HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, rnHsPatSigKind, + newTyVarNameRn, + rnHsConDeclRecFields, + lookupField, mkHsOpTyRn, + rnLTyVar, + + rnHsConDeclField, + + -- Precence related stuff + NegationHandling(..), + mkOpAppRn, mkNegAppRn, mkConOpPatRn, + checkPrecMatch, checkSectionPrec, + + -- Binding related stuff + bindHsOuterTyVarBndrs, bindHsForAllTelescope, + bindHsForAllTelescopes, + bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..), + rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars, + FreeKiTyVars, filterInScopeM, + extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars, + extractHsTysRdrTyVars, extractRdrKindSigVars, + extractConDeclGADTDetailsTyVars, extractDataDefnKindVars, + extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars, + extractHsForAllTelescopes, + nubL, nubN, + + -- Error helpers + badKindSigErr + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType, checkThLocalTyName ) + +import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) +import GHC.Core.TyCon ( isKindName ) +import GHC.Hs +import GHC.Rename.Env +import GHC.Rename.Doc +import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV + , typeAppErr, newLocalBndrRn, checkDupRdrNames + , checkShadowedRdrNames ) +import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn + , lookupTyFixityRn ) +import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) +import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr ( pprHsDocContext ) +import GHC.Tc.Utils.Monad +import GHC.Unit.Module ( getModule ) +import GHC.Types.Name.Reader +import GHC.Builtin.Names +import GHC.Types.Hint ( UntickedPromotedThing(..) ) +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Name.Set +import GHC.Types.FieldLabel +import GHC.Types.Error + +import GHC.Utils.Misc +import GHC.Types.Fixity ( compareFixity, negateFixity + , Fixity(..), FixityDirection(..), LexicalFixity(..) ) +import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.Maybe +import qualified GHC.LanguageExtensions as LangExt + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Data.List (nubBy, partition) +import Control.Monad + +{- +These type renamers are in a separate module, rather than in (say) GHC.Rename.Module, +to break several loops. + +********************************************************* +* * + HsSigWcType and HsPatSigType (i.e with wildcards) +* * +********************************************************* +-} + +data HsPatSigTypeScoping + = AlwaysBind + -- ^ Always bind any free tyvars of the given type, regardless of whether we + -- have a forall at the top. + -- + -- For pattern type sigs, we /do/ want to bring those type + -- variables into scope, even if there's a forall at the top which usually + -- stops that happening, e.g: + -- + -- > \ (x :: forall a. a -> b) -> e + -- + -- Here we do bring 'b' into scope. + -- + -- RULES can also use 'AlwaysBind', such as in the following example: + -- + -- > {-# RULES \"f\" forall (x :: forall a. a -> b). f x = ... b ... #-} + -- + -- This only applies to RULES that do not explicitly bind their type + -- variables. If a RULE explicitly quantifies its type variables, then + -- 'NeverBind' is used instead. See also + -- @Note [Pattern signature binders and scoping]@ in "GHC.Hs.Type". + | NeverBind + -- ^ Never bind any free tyvars. This is used for RULES that have both + -- explicit type and term variable binders, e.g.: + -- + -- > {-# RULES \"const\" forall a. forall (x :: a) y. const x y = x #-} + -- + -- The presence of the type variable binder @forall a.@ implies that the + -- free variables in the types of the term variable binders @x@ and @y@ + -- are /not/ bound. In the example above, there are no such free variables, + -- but if the user had written @(y :: b)@ instead of @y@ in the term + -- variable binders, then @b@ would be rejected for being out of scope. + -- See also @Note [Pattern signature binders and scoping]@ in + -- "GHC.Hs.Type". + +rnHsSigWcType :: HsDocContext + -> LHsSigWcType GhcPs + -> RnM (LHsSigWcType GhcRn, FreeVars) +rnHsSigWcType doc (HsWC { hswc_body = + sig_ty@(L loc (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty })) }) + = do { free_vars <- filterInScopeM (extract_lhs_sig_ty sig_ty) + ; (nwc_rdrs', imp_tv_nms) <- partition_nwcs free_vars + ; let nwc_rdrs = nubL nwc_rdrs' + ; bindHsOuterTyVarBndrs doc Nothing imp_tv_nms outer_bndrs $ \outer_bndrs' -> + do { (wcs, body_ty', fvs) <- rnWcBodyType doc nwc_rdrs body_ty + ; pure ( HsWC { hswc_ext = wcs, hswc_body = L loc $ + HsSig { sig_ext = noExtField + , sig_bndrs = outer_bndrs', sig_body = body_ty' }} + , fvs) } } + +rnHsPatSigType :: HsPatSigTypeScoping + -> HsDocContext + -> HsPatSigType GhcPs + -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnHsPatSigType = rnHsPatSigTyKi TypeLevel + +rnHsPatSigKind :: HsPatSigTypeScoping + -> HsDocContext + -> HsPatSigType GhcPs + -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnHsPatSigKind = rnHsPatSigTyKi KindLevel + +rnHsPatSigTyKi :: TypeOrKind + -> HsPatSigTypeScoping + -> HsDocContext + -> HsPatSigType GhcPs + -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- Used for +-- - Pattern type signatures, which are only allowed with ScopedTypeVariables +-- - Signatures on binders in a RULE, which are allowed even if +-- ScopedTypeVariables isn't enabled +-- Wildcards are allowed +-- +-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type +rnHsPatSigTyKi level scoping ctx sig_ty thing_inside + = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables + ; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty) + ; free_vars <- filterInScopeM (extractHsTyRdrTyVars pat_sig_ty) + ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars + ; let nwc_rdrs = nubN nwc_rdrs' + implicit_bndrs = case scoping of + AlwaysBind -> tv_rdrs + NeverBind -> [] + ; rnImplicitTvOccs Nothing implicit_bndrs $ \ imp_tvs -> + do { (nwcs, pat_sig_ty', fvs1) <- rnWcBodyTyKi level ctx nwc_rdrs pat_sig_ty + ; let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs } + sig_ty' = HsPS { hsps_ext = sig_names, hsps_body = pat_sig_ty' } + ; (res, fvs2) <- thing_inside sig_ty' + ; return (res, fvs1 `plusFV` fvs2) } } + where + pat_sig_ty = hsPatSigType sig_ty + +rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) +rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) + = do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty) + ; (nwc_rdrs', _) <- partition_nwcs free_vars + ; let nwc_rdrs = nubL nwc_rdrs' + ; (wcs, hs_ty', fvs) <- rnWcBodyType ctxt nwc_rdrs hs_ty + ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' } + ; return (sig_ty', fvs) } + + +rnWcBodyType :: HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs + -> RnM ([Name], LHsType GhcRn, FreeVars) +rnWcBodyType = rnWcBodyTyKi TypeLevel + +rnWcBodyTyKi :: TypeOrKind -> HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs + -> RnM ([Name], LHsType GhcRn, FreeVars) +rnWcBodyTyKi level ctxt nwc_rdrs hs_ty + = do { nwcs <- mapM newLocalBndrRn nwc_rdrs + ; let env = RTKE { rtke_level = level + , rtke_what = RnTypeBody + , rtke_nwcs = mkNameSet nwcs + , rtke_ctxt = ctxt } + ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $ + rn_lty env hs_ty + ; return (nwcs, hs_ty', fvs) } + where + rn_lty env (L loc hs_ty) + = setSrcSpanA loc $ + do { (hs_ty', fvs) <- rn_ty env hs_ty + ; return (L loc hs_ty', fvs) } + + rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) + -- A lot of faff just to allow the extra-constraints wildcard to appear + rn_ty env (HsForAllTy { hst_tele = tele, hst_body = hs_body }) + = bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' -> + do { (hs_body', fvs) <- rn_lty env hs_body + ; return (HsForAllTy { hst_xforall = noExtField + , hst_tele = tele', hst_body = hs_body' } + , fvs) } + + rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt + , hst_body = hs_ty }) + | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt + , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last + = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 + ; setSrcSpanA lx $ checkExtraConstraintWildCard env hs_ctxt1 + ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)] + ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty + ; return (HsQualTy { hst_xqual = noExtField + , hst_ctxt = L cx hs_ctxt' + , hst_body = hs_ty' } + , fvs1 `plusFV` fvs2) } + + | otherwise + = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt + ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty + ; return (HsQualTy { hst_xqual = noExtField + , hst_ctxt = L cx hs_ctxt' + , hst_body = hs_ty' } + , fvs1 `plusFV` fvs2) } + + + rn_ty env hs_ty = rnHsTyKi env hs_ty + + rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) + + +checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM () +-- Rename the extra-constraint spot in a type signature +-- (blah, _) => type +-- Check that extra-constraints are allowed at all, and +-- if so that it's an anonymous wildcard +checkExtraConstraintWildCard env hs_ctxt + = checkWildCard env Nothing mb_bad + where + mb_bad | not (extraConstraintWildCardsAllowed env) + = Just $ ExtraConstraintWildcardNotAllowed + SoleExtraConstraintWildcardNotAllowed + -- Currently, we do not allow wildcards in their full glory in + -- standalone deriving declarations. We only allow a single + -- extra-constraints wildcard à la: + -- + -- deriving instance _ => Eq (Foo a) + -- + -- i.e., we don't support things like + -- + -- deriving instance (Eq a, _) => Eq (Foo a) + | DerivDeclCtx {} <- rtke_ctxt env + , not (null hs_ctxt) + = Just $ ExtraConstraintWildcardNotAllowed + SoleExtraConstraintWildcardAllowed + | otherwise + = Nothing + +extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool +extraConstraintWildCardsAllowed env + = case rtke_ctxt env of + TypeSigCtx {} -> True + ExprWithTySigCtx {} -> True + DerivDeclCtx {} -> True + StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in "GHC.Hs.Decls" + _ -> False + +-- | When the NamedWildCards extension is enabled, partition_nwcs +-- removes type variables that start with an underscore from the +-- FreeKiTyVars in the argument and returns them in a separate list. +-- When the extension is disabled, the function returns the argument +-- and empty list. See Note [Renaming named wild cards] +partition_nwcs :: FreeKiTyVars -> RnM ([LocatedN RdrName], FreeKiTyVars) +partition_nwcs free_vars + = do { wildcards_enabled <- xoptM LangExt.NamedWildCards + ; return $ + if wildcards_enabled + then partition is_wildcard free_vars + else ([], free_vars) } + where + is_wildcard :: LocatedN RdrName -> Bool + is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr)) + +{- Note [Renaming named wild cards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Identifiers starting with an underscore are always parsed as type variables. +It is only here in the renamer that we give the special treatment. +See Note [The wildcard story for types] in GHC.Hs.Type. + +It's easy! When we collect the implicitly bound type variables, ready +to bring them into scope, and NamedWildCards is on, we partition the +variables into the ones that start with an underscore (the named +wildcards) and the rest. Then we just add them to the hswc_wcs field +of the HsWildCardBndrs structure, and we are done. + + +********************************************************* +* * + HsSigType (i.e. no wildcards) +* * +****************************************************** -} + +rnHsSigType :: HsDocContext + -> TypeOrKind + -> LHsSigType GhcPs + -> RnM (LHsSigType GhcRn, FreeVars) +-- Used for source-language type signatures +-- that cannot have wildcards +rnHsSigType ctx level + (L loc sig_ty@(HsSig { sig_bndrs = outer_bndrs, sig_body = body })) + = setSrcSpanA loc $ + do { traceRn "rnHsSigType" (ppr sig_ty) + ; case outer_bndrs of + HsOuterExplicit{} -> checkPolyKinds env (HsSigType sig_ty) + HsOuterImplicit{} -> pure () + ; imp_vars <- filterInScopeM $ extractHsTyRdrTyVars body + ; bindHsOuterTyVarBndrs ctx Nothing imp_vars outer_bndrs $ \outer_bndrs' -> + do { (body', fvs) <- rnLHsTyKi env body + + ; return ( L loc $ HsSig { sig_ext = noExtField + , sig_bndrs = outer_bndrs', sig_body = body' } + , fvs ) } } + where + env = mkTyKiEnv ctx level RnTypeBody + +-- | Create new renamed type variables corresponding to source-level ones. +-- Duplicates are permitted, but will be removed. This is intended especially for +-- the case of handling the implicitly bound free variables of a type signature. +rnImplicitTvOccs :: Maybe assoc + -- ^ @'Just' _@ => an associated type decl + -> FreeKiTyVars + -- ^ Surface-syntax free vars that we will implicitly bind. + -- May have duplicates, which are removed here. + -> ([Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnImplicitTvOccs mb_assoc implicit_vs_with_dups thing_inside + = do { let implicit_vs = nubN implicit_vs_with_dups + + ; traceRn "rnImplicitTvOccs" $ + vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ] + + -- Use the currently set SrcSpan as the new source location for each Name. + -- See Note [Source locations for implicitly bound type variables]. + ; loc <- getSrcSpanM + ; let loc' = noAnnSrcSpan loc + ; vars <- mapM (newTyVarNameRnImplicit mb_assoc . L loc' . unLoc) implicit_vs + + ; bindLocalNamesFV vars $ + thing_inside vars } + +{- +Note [Source locations for implicitly bound type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When bringing implicitly bound type variables into scope (in rnImplicitTvOccs), +we do something peculiar: we drop the original SrcSpan attached to each +variable and replace it with the currently set SrcSpan. Moreover, this new +SrcSpan is usually /less/ precise than the original one, and that's OK. To see +why this is done, consider the following example: + + f :: a -> b -> a + +Suppose that a warning or error message needs to point to the SrcSpans of the +binding sites for `a` and `b`. But where /are/ they bound, anyway? Technically, +they're bound by an unwritten `forall` at the front of the type signature, but +there is no SrcSpan for that. We could point to the first occurrence of `a` as +the binding site for `a`, but that would make the first occurrence of `a` +special. Moreover, we don't want IDEs to confuse binding sites and occurrences. + +As a result, we make the `SrcSpan`s for `a` and `b` span the entirety of the +type signature, since the type signature implicitly carries their binding +sites. This is less precise, but more accurate. +-} + +{- ****************************************************** +* * + LHsType and HsType +* * +****************************************************** -} + +{- +rnHsType is here because we call it from loadInstDecl, and I didn't +want a gratuitous knot. +-} + +data RnTyKiEnv + = RTKE { rtke_ctxt :: HsDocContext + , rtke_level :: TypeOrKind -- Am I renaming a type or a kind? + , rtke_what :: RnTyKiWhat -- And within that what am I renaming? + , rtke_nwcs :: NameSet -- These are the in-scope named wildcards + } + +data RnTyKiWhat = RnTypeBody + | RnTopConstraint -- Top-level context of HsSigWcTypes + | RnConstraint -- All other constraints + +instance Outputable RnTyKiEnv where + ppr (RTKE { rtke_level = lev, rtke_what = what + , rtke_nwcs = wcs, rtke_ctxt = ctxt }) + = text "RTKE" + <+> braces (sep [ ppr lev, ppr what, ppr wcs + , pprHsDocContext ctxt ]) + +instance Outputable RnTyKiWhat where + ppr RnTypeBody = text "RnTypeBody" + ppr RnTopConstraint = text "RnTopConstraint" + ppr RnConstraint = text "RnConstraint" + +mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv +mkTyKiEnv cxt level what + = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet + , rtke_what = what, rtke_ctxt = cxt } + +isRnKindLevel :: RnTyKiEnv -> Bool +isRnKindLevel (RTKE { rtke_level = KindLevel }) = True +isRnKindLevel _ = False + +-------------- +rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty + +rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) +rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys + +rnHsConDeclField :: HsDocContext -> HsConDeclField GhcPs + -> RnM (HsConDeclField GhcRn, FreeVars) +rnHsConDeclField doc = rnHsConDeclFieldTyKi (mkTyKiEnv doc TypeLevel RnTypeBody) + +rnHsConDeclFieldTyKi :: RnTyKiEnv -> HsConDeclField GhcPs + -> RnM (HsConDeclField GhcRn, FreeVars) +rnHsConDeclFieldTyKi env cdf@(CDF { cdf_multiplicity, cdf_type, cdf_doc }) = do + (w , fvs_w) <- rnHsMultAnnWith (rnLHsTyKi env) cdf_multiplicity + (ty, fvs) <- rnLHsTyKi env cdf_type + doc <- traverse rnLHsDoc cdf_doc + return (cdf { cdf_multiplicity = w, cdf_type = ty, cdf_doc = doc }, fvs `plusFV` fvs_w) + + +rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) +rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty + +rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars) +rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind + +-- renaming a type only, not a kind +rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs + -> RnM (LHsTypeArg GhcRn, FreeVars) +rnLHsTypeArg ctxt (HsValArg _ ty) + = do { (tys_rn, fvs) <- rnLHsType ctxt ty + ; return (HsValArg noExtField tys_rn, fvs) } +rnLHsTypeArg ctxt (HsTypeArg _ ki) + = do { (kis_rn, fvs) <- rnLHsKind ctxt ki + ; return (HsTypeArg noExtField kis_rn, fvs) } +rnLHsTypeArg _ (HsArgPar sp) + = return (HsArgPar sp, emptyFVs) + +rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs] + -> RnM ([LHsTypeArg GhcRn], FreeVars) +rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args + +-------------- +rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) +rnTyKiContext env (L loc cxt) + = do { traceRn "rncontext" (ppr cxt) + ; let env' = env { rtke_what = RnConstraint } + ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt + ; return (L loc cxt', fvs) } + +rnContext :: HsDocContext -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) +rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta + +rnMaybeContext :: HsDocContext -> Maybe (LHsContext GhcPs) + -> RnM (Maybe (LHsContext GhcRn), FreeVars) +rnMaybeContext _ Nothing = return (Nothing, emptyFVs) +rnMaybeContext doc (Just theta) + = do { (theta', fvs) <- rnContext doc theta + ; return (Just theta', fvs) + } + + +-------------- +rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnLHsTyKi env (L loc ty) + = setSrcSpanA loc $ + do { (ty', fvs) <- rnHsTyKi env ty + ; return (L loc ty', fvs) } + +rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) + +rnHsTyKi env ty@(HsForAllTy { hst_tele = tele, hst_body = tau }) + = do { checkPolyKinds env (HsType ty) + ; bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' -> + do { (tau', fvs) <- rnLHsTyKi env tau + ; return ( HsForAllTy { hst_xforall = noExtField + , hst_tele = tele' , hst_body = tau' } + , fvs) } } + +rnHsTyKi env (HsQualTy { hst_ctxt = lctxt, hst_body = tau }) + = do { -- no need to check type vs kind level here; this is + -- checked in the type checker. See + -- Note [No constraints in kinds] in GHC.Tc.Validity + (ctxt', fvs1) <- rnTyKiContext env lctxt + ; (tau', fvs2) <- rnLHsTyKi env tau + ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt' + , hst_body = tau' } + , fvs1 `plusFV` fvs2) } + +rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name)) + = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ + unlessXOptM LangExt.PolyKinds $ addErr $ + TcRnWithHsDocContext (rtke_ctxt env) $ + TcRnUnexpectedKindVar rdr_name + -- Any type variable at the kind level is illegal without the use + -- of PolyKinds (see #14710) + ; name <- rnTyVar env rdr_name + ; this_mod <- getModule + ; when (nameIsLocalOrFrom this_mod name) $ + checkThLocalTyName name + ; when (isDataConName name && not (isKindName name)) $ + -- Any use of a promoted data constructor name (that is not + -- specifically exempted by isKindName) is illegal without the use + -- of DataKinds. See Note [Checking for DataKinds] in + -- GHC.Tc.Validity. + checkDataKinds env tv + ; 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 $ WithUserRdr rdr_name name), unitFV name) } + +rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2) + = setSrcSpan (getLocA l_op) $ + do { let op_rdr = unLoc l_op + ; (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op + ; let op_name = unLoc l_op' + ; fix <- lookupTyFixityRn l_op' + ; (ty1', fvs2) <- rnLHsTyKi env ty1 + ; (ty2', fvs3) <- rnLHsTyKi env ty2 + ; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2' + ; when (isDataConName op_name && not (isPromoted prom)) $ + addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name) + ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } + +rnHsTyKi env (HsParTy _ ty) + = do { (ty', fvs) <- rnLHsTyKi env ty + ; return (HsParTy noAnn ty', fvs) } + +rnHsTyKi env (HsFunTy u mult ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi env ty1 + ; (ty2', fvs2) <- rnLHsTyKi env ty2 + ; (mult', w_fvs) <- rnHsMultAnnWith (rnLHsTyKi env) mult + ; return (HsFunTy u mult' ty1' ty2' + , plusFVs [fvs1, fvs2, w_fvs]) } + +rnHsTyKi env listTy@(HsListTy x ty) + = do { when (isRnKindLevel env) $ + checkDataKinds env listTy + ; (ty', fvs) <- rnLHsTyKi env ty + ; return (HsListTy x ty', fvs) } + +rnHsTyKi env (HsKindSig x ty k) + = do { kind_sigs_ok <- xoptM LangExt.KindSignatures + ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) k) + ; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k + ; (ty', lhs_fvs) <- bindSigTyVarsFV (hsScopedKvs k') $ + rnLHsTyKi env ty + ; return (HsKindSig x ty' k', lhs_fvs `plusFV` sig_fvs) } + +-- Unboxed tuples are allowed to have poly-typed arguments. These +-- sometimes crop up as a result of CPR worker-wrappering dictionaries. +rnHsTyKi env tupleTy@(HsTupleTy x tup_con tys) + = do { when (isRnKindLevel env) $ + checkDataKinds env tupleTy + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsTupleTy x tup_con tys', fvs) } + +rnHsTyKi env sumTy@(HsSumTy x tys) + = do { when (isRnKindLevel env) $ + checkDataKinds env sumTy + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsSumTy x tys', fvs) } + +-- Ensure that a type-level integer is nonnegative (#8306, #8412) +rnHsTyKi env tyLit@(HsTyLit src t) + = do { checkDataKinds env tyLit + ; t' <- rnHsTyLit t + ; return (HsTyLit src t', emptyFVs) } + +rnHsTyKi env (HsAppTy _ ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi env ty1 + ; (ty2', fvs2) <- rnLHsTyKi env ty2 + ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) } + +rnHsTyKi env (HsAppKindTy _ ty k) + = do { kind_app <- xoptM LangExt.TypeApplications + ; unless kind_app (addErr (typeAppErr KindLevel k)) + ; (ty', fvs1) <- rnLHsTyKi env ty + ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k + ; return (HsAppKindTy noExtField ty' k', fvs1 `plusFV` fvs2) } + +rnHsTyKi env t@(HsIParamTy x n ty) + = do { notInKinds env t + ; (ty', fvs) <- rnLHsTyKi env ty + ; return (HsIParamTy x n ty', fvs) } + +rnHsTyKi _ (HsStarTy _ isUni) + = return (HsStarTy noExtField isUni, emptyFVs) + +rnHsTyKi _ (HsSpliceTy _ sp) + = rnSpliceType sp + +rnHsTyKi env (HsDocTy x ty haddock_doc) + = do { (ty', fvs) <- rnLHsTyKi env ty + ; haddock_doc' <- rnLHsDoc haddock_doc + ; return (HsDocTy x ty' haddock_doc', fvs) } + +-- See Note [Renaming HsCoreTys] +rnHsTyKi env (XHsType (HsCoreTy ty)) + = do mapM_ (check_in_scope . nameRdrName) fvs_list + return (XHsType ty, fvs) + where + fvs_list = map getName $ tyCoVarsOfTypeList ty + fvs = mkFVs fvs_list + + check_in_scope :: RdrName -> RnM () + check_in_scope rdr_name = do + mb_name <- lookupLocalOccRn_maybe rdr_name + when (isNothing mb_name) $ + addErr $ + TcRnWithHsDocContext (rtke_ctxt env) $ + TcRnNotInScope (notInScopeErr WL_LocalOnly rdr_name) rdr_name + +rnHsTyKi env ty@(XHsType (HsBangTy _ bang (L _ inner))) = do + -- 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) + addErr $ + TcRnWithHsDocContext (rtke_ctxt env) $ + TcRnUnexpectedAnnotation ty bang + rnHsTyKi env inner + +rnHsTyKi env ty@(XHsType (HsRecTy {})) = do + -- Record types (which only show up temporarily in constructor + -- signatures) should have been removed by now + addErr $ + TcRnWithHsDocContext (rtke_ctxt env) $ + TcRnIllegalRecordSyntax ty + return (HsWildCardTy noExtField, emptyFVs) -- trick to avoid `failWithTc` + +rnHsTyKi env ty@(HsExplicitListTy _ ip tys) + = do { checkDataKinds env ty + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; unless (isPromoted ip) $ + addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList) + ; return (HsExplicitListTy noExtField ip tys', fvs) } + +rnHsTyKi env ty@(HsExplicitTupleTy _ ip tys) + = do { checkDataKinds env ty + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsExplicitTupleTy noExtField ip tys', fvs) } + +rnHsTyKi env (HsWildCardTy _) + = do { checkAnonWildCard env + ; return (HsWildCardTy noExtField, emptyFVs) } + + +rnHsTyLit :: HsTyLit GhcPs -> RnM (HsTyLit GhcRn) +rnHsTyLit (HsStrTy x s) = pure (HsStrTy x s) +rnHsTyLit tyLit@(HsNumTy x i) = do + when (i < 0) $ + addErr $ TcRnNegativeNumTypeLiteral tyLit + pure (HsNumTy x i) +rnHsTyLit (HsCharTy x c) = pure (HsCharTy x c) + + +rnHsMultAnnWith :: (LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars)) + -> HsMultAnnOf (LocatedA (mult GhcPs)) GhcPs + -> RnM (HsMultAnnOf (LocatedA (mult GhcRn)) GhcRn, FreeVars) +rnHsMultAnnWith _rn (HsUnannotated _) = pure (HsUnannotated noExtField, emptyFVs) +rnHsMultAnnWith _rn (HsLinearAnn _) = pure (HsLinearAnn noExtField, emptyFVs) +rnHsMultAnnWith rn (HsExplicitMult _ p) + = (\(mult, fvs) -> (HsExplicitMult noExtField mult, fvs)) <$> rn p + +{- +Note [Renaming HsCoreTys] +~~~~~~~~~~~~~~~~~~~~~~~~~ +HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes. +As such, there's not much to be done in order to rename an HsCoreTy, +since it's already been renamed to some extent. However, in an attempt to +detect ill-formed HsCoreTys, the renamer checks to see if all free type +variables in an HsCoreTy are in scope. To see why this can matter, consider +this example from #18914: + + type T f = forall a. f a + + class C f where + m :: T f + + newtype N f a = MkN (f a) + deriving C + +Because of #18914, a previous GHC would generate the following code: + + instance C f => C (N f) where + m :: T (N f) + m = coerce @(f a) -- The type within @(...) is an HsCoreTy + @(N f a) -- So is this + (m @f) + +There are two HsCoreTys in play—(f a) and (N f a)—both of which have +`f` and `a` as free type variables. The `f` is in scope from the instance head, +but `a` is completely unbound, which is what led to #18914. To avoid this sort +of mistake going forward, the renamer will now detect that `a` is unbound and +throw an error accordingly. +-} + +-------------- +rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name +rnTyVar env rdr_name + = do { name <- lookupTypeOccRn rdr_name + ; checkNamedWildCard env name + ; return name } + +rnLTyVar :: LocatedN RdrName -> RnM (LocatedN Name) +-- Called externally; does not deal with wildcards +rnLTyVar (L loc rdr_name) + = do { tyvar <- lookupTypeOccRn rdr_name + ; return (L loc tyvar) } + +-------------- +rnHsTyOp :: RnTyKiEnv -> SDoc -> LocatedN RdrName + -> RnM (LocatedN Name, FreeVars) +rnHsTyOp env overall_ty (L loc op) + = do { op' <- rnTyVar env op + ; unlessXOptM LangExt.TypeOperators $ + if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env + then addDiagnostic TcRnTypeEqualityRequiresOperators + else addErr $ TcRnIllegalTypeOperator overall_ty op + ; return (L loc op', unitFV op') } + +-------------- +checkWildCard :: RnTyKiEnv + -> Maybe Name -- ^ name of the wildcard, + -- or 'Nothing' for an anonymous wildcard + -> Maybe BadAnonWildcardContext + -> RnM () +checkWildCard env mb_name (Just bad) + = addErr $ TcRnWithHsDocContext (rtke_ctxt env) $ + TcRnIllegalWildcardInType mb_name bad +checkWildCard _ _ Nothing + = return () + +checkAnonWildCard :: RnTyKiEnv -> RnM () +-- Report an error if an anonymous wildcard is illegal here +checkAnonWildCard env + = checkWildCard env Nothing mb_bad + where + mb_bad :: Maybe BadAnonWildcardContext + mb_bad | not (wildCardsAllowed env) + = Just WildcardsNotAllowedAtAll + | otherwise + = case rtke_what env of + RnTypeBody -> Nothing + RnTopConstraint -> Just WildcardNotLastInConstraint + RnConstraint -> Just WildcardNotLastInConstraint + +checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () +-- Report an error if a named wildcard is illegal here +checkNamedWildCard env name + = checkWildCard env (Just name) mb_bad + where + mb_bad | not (name `elemNameSet` rtke_nwcs env) + = Nothing -- Not a wildcard + | not (wildCardsAllowed env) + = Just WildcardsNotAllowedAtAll + | otherwise + = case rtke_what env of + RnTypeBody -> Nothing -- Allowed + RnTopConstraint -> Nothing -- Allowed; e.g. + -- f :: (Eq _a) => _a -> Int + -- g :: (_a, _b) => T _a _b -> Int + -- The named tyvars get filled in from elsewhere + RnConstraint -> Just WildcardNotLastInConstraint + +wildCardsAllowed :: RnTyKiEnv -> Bool +-- ^ In what contexts are wildcards permitted +wildCardsAllowed env + = case rtke_ctxt env of + TypeSigCtx {} -> True + TypBrCtx {} -> True -- Template Haskell quoted type + SpliceTypeCtx {} -> True -- Result of a Template Haskell splice + ExprWithTySigCtx {} -> True + PatCtx {} -> True + RuleCtx {} -> True + SpecECtx {} -> True + FamPatCtx {} -> True -- Not named wildcards though + GHCiCtx {} -> True + HsTypeCtx {} -> True + StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in "GHC.Hs.Decls" + _ -> False + + + +--------------- +-- | Ensures either that we're in a type or that -XPolyKinds is set +checkPolyKinds :: RnTyKiEnv + -> HsTypeOrSigType GhcPs + -> RnM () +checkPolyKinds env ty + | isRnKindLevel env + = do { polykinds <- xoptM LangExt.PolyKinds + ; unless polykinds $ + addErr $ TcRnIllegalKind ty True } +checkPolyKinds _ _ = return () + +notInKinds :: RnTyKiEnv + -> HsType GhcPs + -> RnM () +notInKinds env ty + | isRnKindLevel env + = addErr $ TcRnIllegalKind (HsType ty) False +notInKinds _ _ = return () + +{- ***************************************************** +* * + Binding type variables +* * +***************************************************** -} + +bindSigTyVarsFV :: [Name] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +-- Used just before renaming the defn of a function +-- with a separate type signature, to bring its tyvars into scope +-- With no -XScopedTypeVariables, this is a no-op +bindSigTyVarsFV tvs thing_inside + = do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } + +--------------- +bindHsQTyVars :: forall a b. + HsDocContext + -> Maybe (a, [Name]) -- Just _ => an associated type decl + -> FreeKiTyVars -- Kind variables from scope + -> LHsQTyVars GhcPs + -> (LHsQTyVars GhcRn -> FreeKiTyVars -> RnM (b, FreeVars)) + -- The FreeKiTyVars is null <=> all kind variables used in the + -- kind signature are bound on the left. Reason: + -- the last clause of Note [CUSKs: complete user-supplied kind signatures] + -- in GHC.Hs.Decls + -> RnM (b, FreeVars) + +-- See Note [bindHsQTyVars examples] +-- (a) Bring kind variables into scope +-- both (i) passed in body_kv_occs +-- and (ii) mentioned in the kinds of hsq_bndrs +-- (b) Bring type variables into scope +-- +bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside + = do { let bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs + + ; let -- See Note [bindHsQTyVars examples] for what + -- all these various things are doing + bndrs, all_implicit_kvs :: [LocatedN RdrName] + bndrs = mapMaybe hsLTyVarLocName hs_tv_bndrs + all_implicit_kvs = filterFreeVarsToBind bndrs $ + bndr_kv_occs ++ body_kv_occs + body_remaining = filterFreeVarsToBind bndr_kv_occs $ + filterFreeVarsToBind bndrs body_kv_occs + + ; implicit_kvs <- + case mb_assoc of + Nothing -> filterInScopeM all_implicit_kvs + Just (_, cls_tvs) -> filterInScopeNonClassM cls_tvs all_implicit_kvs + -- See Note [Class variables and filterInScope] + + ; traceRn "checkMixedVars3" $ + vcat [ text "bndrs" <+> ppr hs_tv_bndrs + , text "bndr_kv_occs" <+> ppr bndr_kv_occs + , text "body_kv_occs" <+> ppr body_kv_occs + , text "implicit_kvs" <+> ppr implicit_kvs + , text "body_remaining" <+> ppr body_remaining + ] + + ; rnImplicitTvOccs mb_assoc implicit_kvs $ \ implicit_kv_nms' -> + bindLHsTyVarBndrs doc NoWarnUnusedForalls mb_assoc hs_tv_bndrs $ \ rn_bndrs -> + -- This is the only call site for bindLHsTyVarBndrs where we pass + -- NoWarnUnusedForalls, which suppresses -Wunused-foralls warnings. + -- See Note [Suppress -Wunused-foralls when binding LHsQTyVars]. + do { rn_bndrs <- traverse rnLHsTyVarBndrVisFlag rn_bndrs + ; let -- The SrcSpan that rnImplicitTvOccs will attach to each Name will + -- span the entire declaration to which the LHsQTyVars belongs, + -- which will be reflected in warning and error messages. We can + -- be a little more precise than that by pointing to the location + -- of the LHsQTyVars instead, which is what bndrs_loc + -- corresponds to. + implicit_kv_nms = map (`setNameLoc` bndrs_loc) implicit_kv_nms' + + ; traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs) + ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms + , hsq_explicit = rn_bndrs }) + body_remaining } } + where + hs_tv_bndrs = hsQTvExplicit hsq_bndrs + + -- The SrcSpan of the LHsQTyVars. For example, bndrs_loc would be the + -- highlighted part in the class below: + -- + -- class C (a :: j) (b :: k) where + -- ^^^^^^^^^^^^^^^ + bndrs_loc = case map get_bndr_loc hs_tv_bndrs ++ map getLocA body_kv_occs of + [] -> panic "bindHsQTyVars.bndrs_loc" + [loc] -> loc + (loc:locs) -> loc `combineSrcSpans` last locs + + -- The in-tree API annotations extend the LHsTyVarBndr location to + -- include surrounding parens. for error messages to be + -- compatible, we recreate the location from the contents + get_bndr_loc :: LHsTyVarBndr flag GhcPs -> SrcSpan + get_bndr_loc (L l tvb) = + combineSrcSpans + (case hsBndrVar tvb of + HsBndrWildCard tok -> + case tok of + NoEpTok -> locA l + EpTok loc -> locA loc + HsBndrVar _ ln -> getLocA ln) + (case hsBndrKind tvb of + HsBndrNoKind _ -> noSrcSpan + HsBndrKind _ lk -> getLocA lk) + +{- Note [bindHsQTyVars examples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data T k (a::k1) (b::k) :: k2 -> k1 -> * + +Then: + hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables + bndrs = [k,a,b] + + bndr_kv_occs = [k,k1], kind variables free in kind signatures + of hs_tv_bndrs + + body_kv_occs = [k2,k1], kind variables free in the + result kind signature + + implicit_kvs = [k1,k2,k1], kind variables free in kind signatures + of hs_tv_bndrs, and not bound by bndrs + +* We want to quantify add implicit bindings for implicit_kvs + +* If body_kv_occs is non-empty, then there is a kind variable + mentioned in the kind signature that is not bound "on the left". + That's one of the rules for a CUSK, so we pass that info on + as the second argument to thing_inside. + +* Order is important in these lists. Consider + data T (a::k1) (b::k2) + We want implicit_kvs to be [k1,k2], not [k2,k1], so that the inferred kind for + T quantifies over kind variables in the user-specified order + T :: forall k1 k2. k1 -> k2 -> Type -- OK + T :: forall k2 k1. k1 -> k2 -> Type -- Bad + This matters with TypeApplications + +* bndr_kv_occs, body_kv_occs, and implicit_kvs can contain duplicates. All + duplicate occurrences are removed when we bind them with rnImplicitTvOccs. + +Finally, you may wonder why filterFreeVarsToBind removes in-scope variables +from bndr/body_kv_occs. How can anything be in scope? Answer: +HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax +ConDecls + data T a = forall (b::k). MkT a b +The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire +ConDecl. Hence the local RdrEnv may be non-empty and we must filter +out 'a' from the free vars. (Mind you, in this situation all the +implicit kind variables are bound at the data type level, so there +are none to bind in the ConDecl, so there are no implicitly bound +variables at all. + +Note [Kind variable scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + data T (a :: k) k = ... +we report "k is out of scope" for (a::k). Reason: k is not brought +into scope until the explicit k-binding that follows. It would be +terribly confusing to bring into scope an /implicit/ k for a's kind +and a distinct, shadowing explicit k that follows, something like + data T {k1} (a :: k1) k = ... + +So the rule is: + + the implicit binders never include any + of the explicit binders in the group + +Note that in the denerate case + data T (a :: a) = blah +we get a complaint the second 'a' is not in scope. + +That applies to foralls too: e.g. + forall (a :: k) k . blah + +But if the foralls are split, we treat the two groups separately: + forall (a :: k). forall k. blah +Here we bring into scope an implicit k, which is later shadowed +by the explicit k. + +In implementation terms + +* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete + the binders {a,k}, and so end with no implicit binders. Then we + rename the binders left-to-right, and hence see that 'k' is out of + scope in the kind of 'a'. + +* Similarly in extract_hs_tv_bndrs + +Note [Variables used as both types and kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We bind the type variables tvs, and kvs is the set of free variables of the +kinds in the scope of the binding. Here is one typical example: + + forall a b. a -> (b::k) -> (c::a) + +Here, tvs will be {a,b}, and kvs {k,a}. + +We must make sure that kvs includes all of variables in the kinds of type +variable bindings. For instance: + + forall k (a :: k). Proxy a + +If we only look in the body of the `forall` type, we will mistakenly conclude +that kvs is {}. But in fact, the type variable `k` is also used as a kind +variable in (a :: k), later in the binding. (This mistake lead to #14710.) +So tvs is {k,a} and kvs is {k}. + +NB: we do this only at the binding site of 'tvs'. + +Note [Suppress -Wunused-foralls when binding LHsQTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The WarnUnusedForalls flag controls whether bindLHsTyVarBndrs should warn about +explicit type variable binders that go unused (e.g., the `a` in +`forall a. Int`). We almost always want to warn about these, since unused type +variables can usually be deleted without any repercussions. There is one +exception to this rule, however: binding LHsQTyVars. Consider this example: + + data Proxy a = Proxy + +The `a` in `Proxy a` is bound by an LHsQTyVars, and the code which brings it +into scope, bindHsQTyVars, will invoke bindLHsTyVarBndrs in turn. As such, it +has a choice to make about whether to emit -Wunused-foralls warnings or not. +If it /did/ emit warnings, then the `a` would be flagged as unused. However, +this is not what we want! Removing the `a` in `Proxy a` would change its kind +entirely, which is a huge price to pay for fixing a warning. + +Unlike other forms of type variable binders, dropping "unused" variables in +an LHsQTyVars can be semantically significant. As a result, we suppress +-Wunused-foralls warnings in exactly one place: in bindHsQTyVars. +-} + +bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed + => HsDocContext + -> Maybe assoc + -- ^ @'Just' _@ => an associated type decl + -> FreeKiTyVars + -> HsOuterTyVarBndrs flag GhcPs + -> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside = + case outer_bndrs of + HsOuterImplicit{} -> + rnImplicitTvOccs mb_cls implicit_vars $ \implicit_vars' -> + thing_inside $ HsOuterImplicit { hso_ximplicit = implicit_vars' } + HsOuterExplicit{hso_bndrs = exp_bndrs} -> + -- Note: If we pass mb_cls instead of Nothing below, bindLHsTyVarBndrs + -- will use class variables for any names the user meant to bring in + -- scope here. This is an explicit forall, so we want fresh names, not + -- class variables. Thus: always pass Nothing. + bindLHsTyVarBndrs doc WarnUnusedForalls Nothing exp_bndrs $ \exp_bndrs' -> do + checkForAllTelescopeWildcardBndrs doc exp_bndrs' + thing_inside $ HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = exp_bndrs' } + +-- See Note [Term variable capture and implicit quantification] +warn_term_var_capture :: LocatedN RdrName -> RnM () +warn_term_var_capture lVar = do + gbl_env <- getGlobalRdrEnv + local_env <- getLocalRdrEnv + case demoteRdrNameTv $ unLoc lVar of + Nothing -> return () + Just demoted_name -> do + let global_vars = lookupGRE gbl_env (LookupRdrName demoted_name SameNameSpace) + let mlocal_var = lookupLocalRdrEnv local_env demoted_name + case mlocal_var of + Just name -> warnCapturedTerm lVar (Right name) + Nothing -> unless (null global_vars) $ + warnCapturedTerm lVar (Left global_vars) + +bindHsForAllTelescope :: HsDocContext + -> HsForAllTelescope GhcPs + -> (HsForAllTelescope GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindHsForAllTelescope doc tele thing_inside = + case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' -> do + checkForAllTelescopeWildcardBndrs doc bndrs' + thing_inside $ mkHsForAllVisTele noAnn bndrs' + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' -> do + checkForAllTelescopeWildcardBndrs doc bndrs' + thing_inside $ mkHsForAllInvisTele noAnn bndrs' + +bindHsForAllTelescopes :: HsDocContext + -> [HsForAllTelescope GhcPs] + -> ([HsForAllTelescope GhcRn] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindHsForAllTelescopes _ [] thing_inside = + thing_inside [] +bindHsForAllTelescopes doc (tele:teles) thing_inside = + bindHsForAllTelescope doc tele $ \tele' -> + bindHsForAllTelescopes doc teles $ \teles' -> + thing_inside (tele':teles') + +-- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type +checkForAllTelescopeWildcardBndrs :: HsDocContext + -> [LHsTyVarBndr flag (GhcPass p)] + -> RnM () +checkForAllTelescopeWildcardBndrs doc tvbs = mapM_ report_err wc_bndr_locs + where + report_err :: SrcSpan -> RnM () + report_err loc = + addErrAt loc $ TcRnWithHsDocContext doc $ + TcRnIllegalWildcardInType Nothing WildcardBndrInForallTelescope + + wc_bndr_locs :: [SrcSpan] + wc_bndr_locs = [locA l | L l (HsTvb _ _ HsBndrWildCard{} _) <- tvbs ] + +-- | Should GHC warn if a quantified type variable goes unused? Usually, the +-- answer is \"yes\", but in the particular case of binding 'LHsQTyVars', we +-- avoid emitting warnings. +-- See @Note [Suppress -Wunused-foralls when binding LHsQTyVars]@. +data WarnUnusedForalls + = WarnUnusedForalls + | NoWarnUnusedForalls + +instance Outputable WarnUnusedForalls where + ppr wuf = text $ case wuf of + WarnUnusedForalls -> "WarnUnusedForalls" + NoWarnUnusedForalls -> "NoWarnUnusedForalls" + +bindLHsTyVarBndrs :: (OutputableBndrFlag flag 'Renamed) + => HsDocContext + -> WarnUnusedForalls + -> Maybe a -- Just _ => an associated type decl + -> [LHsTyVarBndr flag GhcPs] -- User-written tyvars + -> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindLHsTyVarBndrs doc wuf mb_assoc tv_bndrs thing_inside + = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) + ; checkDupRdrNames tv_names_w_loc + ; go tv_bndrs thing_inside } + where + tv_names_w_loc = mapMaybe hsLTyVarLocName tv_bndrs + + go [] thing_inside = thing_inside [] + go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' -> + do { (res, fvs) <- go bs $ \ bs' -> + thing_inside (b' : bs') + ; warn_unused b' fvs + ; return (res, fvs) } + + warn_unused tv_bndr fvs = case wuf of + WarnUnusedForalls -> warnUnusedForAll doc tv_bndr fvs + NoWarnUnusedForalls -> return () + +bindLHsTyVarBndr :: HsDocContext + -> Maybe a -- associated class + -> LHsTyVarBndr flag GhcPs + -> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindLHsTyVarBndr doc mb_assoc (L loc (HsTvb x fl bvar kind)) thing_inside + = do { (kind', fvs1) <- rnHsBndrKind doc kind + ; (b, fvs2) <- bindHsBndrVar mb_assoc bvar $ \bvar' -> + thing_inside (L loc (HsTvb x fl bvar' kind')) + ; return (b, fvs1 `plusFV` fvs2) } + +bindHsBndrVar :: Maybe a -- associated class + -> HsBndrVar GhcPs + -> (HsBndrVar GhcRn -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindHsBndrVar mb_assoc (HsBndrVar _ lrdr@(L lv _)) thing_inside + = do { tv_nm <- newTyVarNameRn mb_assoc lrdr + ; bindLocalNamesFV [tv_nm] $ + thing_inside (HsBndrVar noExtField (L lv tv_nm)) } +bindHsBndrVar _ (HsBndrWildCard _) thing_inside + = thing_inside (HsBndrWildCard noExtField) + +rnHsBndrKind :: HsDocContext -> HsBndrKind GhcPs -> RnM (HsBndrKind GhcRn, FreeVars) +rnHsBndrKind _ (HsBndrNoKind _) = return (HsBndrNoKind noExtField, emptyFVs) +rnHsBndrKind doc (HsBndrKind _ kind) = + do { sig_ok <- xoptM LangExt.KindSignatures + ; unless sig_ok (badKindSigErr doc kind) + ; (kind', fvs) <- rnLHsKind doc kind + ; return (HsBndrKind noExtField kind', fvs) } + +-- Check for TypeAbstractions and update the type parameter of HsBndrVis. +-- The binder itself is already renamed and is returned unmodified. +rnLHsTyVarBndrVisFlag + :: LHsTyVarBndr (HsBndrVis GhcPs) GhcRn + -> RnM (LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) +rnLHsTyVarBndrVisFlag (L loc bndr) = do + let lbndr = L loc (updateHsTyVarBndrFlag rnHsBndrVis bndr) + unlessXOptM LangExt.TypeAbstractions $ do + when (isHsBndrInvisible (hsTyVarBndrFlag bndr)) $ + addErr (TcRnIllegalInvisTyVarBndr lbndr) + when (isHsBndrWildCard (hsBndrVar bndr)) $ + addErr (TcRnIllegalWildcardTyVarBndr lbndr) + return lbndr + +-- rnHsBndrVis is almost a no-op, it simply discards the token for "@". +rnHsBndrVis :: HsBndrVis GhcPs -> HsBndrVis GhcRn +rnHsBndrVis (HsBndrRequired _) = HsBndrRequired noExtField +rnHsBndrVis (HsBndrInvisible _at) = HsBndrInvisible noExtField + +newTyVarNameRn, newTyVarNameRnImplicit + :: Maybe a -- associated class + -> LocatedN RdrName -> RnM Name +newTyVarNameRn mb_assoc = new_tv_name_rn mb_assoc newLocalBndrRn +newTyVarNameRnImplicit mb_assoc = new_tv_name_rn mb_assoc $ \lrdr -> + do { warn_term_var_capture lrdr + ; newLocalBndrRn lrdr } + +new_tv_name_rn :: Maybe a -- associated class + -> (LocatedN RdrName -> RnM Name) -- how to create a new name + -> (LocatedN RdrName -> RnM Name) +new_tv_name_rn Nothing cont lrdr = cont lrdr +new_tv_name_rn (Just _) cont lrdr@(L _ rdr) + = do { rdr_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv rdr_env rdr of + Just n -> return n -- Use the same Name as the parent class decl + _ -> cont lrdr } + +{- Note [Term variable capture and implicit quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-Wterm-variable-capture is a warning introduced in GHC Proposal #281 "Visible forall in types of terms", +Section 7.3: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0281-visible-forall.rst#73implicit-quantification + +Its purpose is to notify users when implicit quantification occurs that would +stop working under RequiredTypeArguments. Example: + + a = 42 + id :: a -> a + +As it stands, the `a` in the signature `id :: a -> a` is considered free and +leads to implicit quantification, as if the user wrote `id :: forall a. a -> a`. +Under RequiredTypeArguments it captures the term-level variable `a` (bound by `a = 42`), +leading to a type error. + +`warn_term_var_capture` detects this by demoting the namespace of the +implicitly quantified type variable (`TvName` becomes `VarName`) and looking it up +in the environment. But when do we call `warn_term_var_capture`? It's tempting +to do so at the start of `rnImplicitTvOccs`, as soon as we know our implicit +variables: + + rnImplicitTvOccs mb_assoc implicit_vs_with_dups thing_inside + = do { let implicit_vs = nubN implicit_vs_with_dups + ; mapM_ warn_term_var_capture implicit_vs + ... } + +This approach generates false positives (#23434) because it misses a corner +case: class variables in associated types. Consider the following example: + + k = 12 + class C k a where + type AT a :: k -> Type + +If we look at the signature for `AT` in isolation, the `k` looks like a free +variable, so it's passed to `rnImplicitTvOccs`. And if we passed it to +`warn_term_var_capture`, we would find the `k` bound by `k = 12` and report a warning. +But we don't want that: `k` is actually bound in the declaration header of the +parent class. + +The solution is to check if it's a class variable (this is done in `new_tv_name_rn`) +before we check for term variable capture. +-} + +{- +********************************************************* +* * + HsConDeclRecField +* * +********************************************************* + +When renaming a HsConDeclRecField, we have to find the FieldLabel +associated with each field. But we already have all the FieldLabels +available (since they were brought into scope by +GHC.Rename.Names.getLocalNonValBinders), so we just take the list as an +argument, build a map and look them up. +-} + +rnHsConDeclRecFields :: HsDocContext -> [FieldLabel] -> [LHsConDeclRecField GhcPs] + -> RnM ([LHsConDeclRecField GhcRn], FreeVars) +-- Also called from GHC.Rename.Module +-- No wildcards can appear in record fields +rnHsConDeclRecFields ctxt fls fields + = mapFvRn (rnField fl_env env) fields + where + env = mkTyKiEnv ctxt TypeLevel RnTypeBody + fl_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ] + +rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LHsConDeclRecField GhcPs + -> RnM (LHsConDeclRecField GhcRn, FreeVars) +rnField fl_env env (L l (HsConDeclRecField _ names ty)) + = do { let new_names = map (fmap (lookupField fl_env)) names + ; (new_ty, fvs) <- rnHsConDeclFieldTyKi env ty + ; return (L l (HsConDeclRecField noExtField new_names new_ty) + , fvs) } + +lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn +lookupField fl_env (FieldOcc _ (L lr rdr)) = + FieldOcc (mkRdrUnqual $ occName sel) (L lr sel) + where + lbl = occNameFS $ rdrNameOcc rdr + sel = flSelector + $ expectJust + $ lookupFsEnv fl_env lbl + +{- +************************************************************************ +* * + Fixities and precedence parsing +* * +************************************************************************ + +@mkOpAppRn@ deals with operator fixities. The argument expressions +are assumed to be already correctly arranged. It needs the fixities +recorded in the OpApp nodes, because fixity info applies to the things +the programmer actually wrote, so you can't find it out from the Name. + +Furthermore, the second argument is guaranteed not to be another +operator application. Why? Because the parser parses all +operator applications left-associatively, EXCEPT negation, which +we need to handle specially. +Infix types are read in a *right-associative* way, so that + a `op` b `op` c +is always read in as + a `op` (b `op` c) + +mkHsOpTyRn rearranges where necessary. The two arguments +have already been renamed and rearranged. + +In the past, mkHsOpTyRn used to handle (->), but this was unnecessary. In the +syntax tree produced by the parser, the arrow already has the least possible +precedence and does not require rearrangement. +-} + +--------------- +-- Building (ty1 `op1` (ty2a `op2` ty2b)) +mkHsOpTyRn :: PromotionFlag + -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn -> LHsType GhcRn + -> RnM (HsType GhcRn) + +mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b)) + = do { fix2 <- lookupTyFixityRn (fmap getName op2) + ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 } + +mkHsOpTyRn prom1 op1 _ ty1 ty2 -- Default case, no rearrangement + = return (HsOpTy noExtField prom1 ty1 op1 ty2) + +--------------- +mk_hs_op_ty :: PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn + -> PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn + -> LHsType GhcRn -> SrcSpanAnnA + -> RnM (HsType GhcRn) +mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 + | nofix_error = do { precParseErr (NormalOp (unLoc op1),fix1) + (NormalOp (unLoc op2),fix2) + ; return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) } + | associate_right = return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) + | otherwise = do { -- Rearrange to ((ty1 `op1` ty2a) `op2` ty2b) + new_ty <- mkHsOpTyRn prom1 op1 fix1 ty1 ty2a + ; return (noLocA new_ty `op2ty` ty2b) } + where + lhs `op1ty` rhs = HsOpTy noExtField prom1 lhs op1 rhs + lhs `op2ty` rhs = HsOpTy noExtField prom2 lhs op2 rhs + (nofix_error, associate_right) = compareFixity fix1 fix2 + + +--------------------------- +mkOpAppRn :: NegationHandling + -> LHsExpr GhcRn -- Left operand; already rearranged + -> LHsExpr GhcRn -> Fixity -- Operator and fixity + -> LHsExpr GhcRn -- Right operand (not an OpApp, but might + -- be a NegApp) + -> RnM (HsExpr GhcRn) + +-- (e1a `op1` e1b) `op2` e2 +mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e1a op1 e1b)) op2 fix2 e2 + | nofix_error + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (OpApp fix2 e1 op2 e2) + + | associate_right = do + new_e <- mkOpAppRn negation_handling e1b op2 fix2 e2 + return (OpApp fix1 e1a op1 (L loc' new_e)) + where + loc'= combineLocsA e1b e2 + (nofix_error, associate_right) = compareFixity fix1 fix2 + +--------------------------- +-- (- neg_arg) `op` e2 +mkOpAppRn ReassociateNegation e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 + | nofix_error + = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) + return (OpApp fix2 e1 op2 e2) + + | associate_right + = do new_e <- mkOpAppRn ReassociateNegation neg_arg op2 fix2 e2 + return (NegApp noExtField (L loc' new_e) neg_name) + where + loc' = combineLocsA neg_arg e2 + (nofix_error, associate_right) = compareFixity negateFixity fix2 + +--------------------------- +-- e1 `op` - neg_arg +mkOpAppRn ReassociateNegation e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right + | not associate_right -- We *want* right association + = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) + return (OpApp fix1 e1 op1 e2) + where + (_, associate_right) = compareFixity fix1 negateFixity + +--------------------------- +-- Default case +mkOpAppRn _ e1 op fix e2 -- Default case, no rearrangement + = assertPpr (right_op_ok fix (unLoc e2)) + (ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2) $ + return (OpApp fix e1 op e2) + +data NegationHandling = ReassociateNegation | KeepNegationIntact + +---------------------------- + +get_op :: LHsExpr GhcRn -> OpName +-- An unbound name could be either HsVar or (HsHole (HoleVar _, _)) +-- See GHC.Rename.Expr.rnUnboundVar +get_op (L _ (HsVar _ n)) = NormalOp (unLoc n) +get_op (L _ (HsHole (HoleVar (L _ uv)))) = UnboundOp uv +get_op (L _ (XExpr (HsRecSelRn fld))) = RecFldOp fld +get_op other = pprPanic "get_op" (ppr other) + +-- Parser left-associates everything, but +-- derived instances may have correctly-associated things to +-- in the right operand. So we just check that the right operand is OK +right_op_ok :: Fixity -> HsExpr GhcRn -> Bool +right_op_ok fix1 (OpApp fix2 _ _ _) + = not error_please && associate_right + where + (error_please, associate_right) = compareFixity fix1 fix2 +right_op_ok _ _ + = True + +-- Parser initially makes negation bind more tightly than any other operator +-- And "deriving" code should respect this (use HsPar if not) +mkNegAppRn :: LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn) +mkNegAppRn neg_arg neg_name + = assert (not_op_app (unLoc neg_arg)) $ + return (NegApp noExtField neg_arg neg_name) + +not_op_app :: HsExpr id -> Bool +not_op_app (OpApp {}) = False +not_op_app _ = True + +-------------------------------------- +mkConOpPatRn :: LocatedN (WithUserRdr Name) + -> Fixity -> LPat GhcRn -> LPat GhcRn + -> RnM (Pat GhcRn) + +mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p1a p1b))) p2 + = do { fix1 <- lookupFixityRn (getName op1) + ; let (nofix_error, associate_right) = compareFixity fix1 fix2 + + ; if nofix_error then do + { precParseErr (NormalOp (unLoc op1),fix1) + (NormalOp (unLoc op2),fix2) + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = op2 + , pat_args = InfixCon p1 p2 + } + } + + else if associate_right then do + { new_p <- mkConOpPatRn op2 fix2 p1b p2 + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = op1 + , pat_args = InfixCon p1a (L loc new_p) + } + } + -- XXX loc right? + else return $ ConPat + { pat_con_ext = noExtField + , pat_con = op2 + , pat_args = InfixCon p1 p2 + } + } + +mkConOpPatRn op _ p1 p2 -- Default case, no rearrangement + = assert (not_op_pat (unLoc p2)) $ + return $ ConPat + { pat_con_ext = noExtField + , pat_con = op + , pat_args = InfixCon p1 p2 + } + +not_op_pat :: Pat GhcRn -> Bool +not_op_pat (ConPat NoExtField _ (InfixCon _ _)) = False +not_op_pat _ = True + +-------------------------------------- +checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () + -- Check precedence of a function binding written infix + -- eg a `op` b `C` c = ... + -- See comments with rnExpr (OpApp ...) about "deriving" + +checkPrecMatch op (MG { mg_alts = (L _ ms) }) + = mapM_ check ms + where + check (L _ (Match { m_pats = L _ ( (L l1 p1) + : (L l2 p2) + : _) })) + = setSrcSpan (locA $ combineSrcSpansA l1 l2) $ + do checkPrec op p1 False + checkPrec op p2 True + + check _ = return () + -- This can happen. Consider + -- a `op` True = ... + -- op = ... + -- The infix flag comes from the first binding of the group + -- but the second eqn has no args (an error, but not discovered + -- until the type checker). So we don't want to crash on the + -- second eqn. + +checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () +checkPrec op (ConPat NoExtField op1 (InfixCon _ _)) right = do + op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op + op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (getName op1) + let + inf_ok = op1_prec > op_prec || + (op1_prec == op_prec && + (op1_dir == InfixR && op_dir == InfixR && right || + op1_dir == InfixL && op_dir == InfixL && not right)) + + info = (NormalOp (noUserRdr op), op_fix) + info1 = (NormalOp (unLoc op1), op1_fix) + (infol, infor) = if right then (info, info1) else (info1, info) + unless inf_ok (precParseErr infol infor) + +checkPrec _ _ _ + = return () + +-- Check precedence of (arg op) or (op arg) respectively +-- If arg is itself an operator application, then either +-- (a) its precedence must be higher than that of op +-- (b) its precedency & associativity must be the same as that of op +checkSectionPrec :: FixityDirection -> HsExpr GhcPs + -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM () +checkSectionPrec direction section op arg + = case unLoc arg of + OpApp fix _ op' _ -> go_for_it (get_op op') fix + NegApp _ _ _ -> go_for_it NegateOp negateFixity + _ -> return () + where + op_name = get_op op + go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do + op_fix@(Fixity op_prec _) <- lookupFixityOp op_name + unless (op_prec < arg_prec + || (op_prec == arg_prec && direction == assoc)) + (sectionPrecErr (get_op op, op_fix) + (arg_op, arg_fix) section) + +-- | Look up the fixity for an operator name. +lookupFixityOp :: OpName -> RnM Fixity +lookupFixityOp (NormalOp n) = lookupFixityRn (getName n) +lookupFixityOp NegateOp = lookupFixityRn negateName +lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (occName u)) +lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f + +-- Precedence-related error messages + +precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM () +precParseErr op1@(n1,_) op2@(n2,_) + | is_unbound n1 || is_unbound n2 + = return () -- Avoid error cascade + | otherwise + = addErr $ TcRnPrecedenceParsingError op1 op2 + +sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM () +sectionPrecErr op@(n1,_) arg_op@(n2,_) section + | is_unbound n1 || is_unbound n2 + = return () -- Avoid error cascade + | otherwise + = addErr $ TcRnSectionPrecedenceError op arg_op section + +is_unbound :: OpName -> Bool +is_unbound (NormalOp n) = isUnboundName (getName n) +is_unbound UnboundOp{} = True +is_unbound _ = False + + +{- ***************************************************** +* * + Errors +* * +***************************************************** -} + +unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage +unexpectedPatSigTypeErr ty + = TcRnUnexpectedPatSigType ty + +badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () +badKindSigErr doc (L loc ty) + = setSrcSpanA loc $ addErr $ + TcRnWithHsDocContext doc $ + TcRnKindSignaturesDisabled (Left ty) + +-- | Check for DataKinds violations in a type context, as well as \"obvious\" +-- violations in kind contexts. +-- See @Note [Checking for DataKinds]@ in "GHC.Tc.Validity" for more on this. +checkDataKinds :: RnTyKiEnv -> HsType GhcPs -> TcM () +checkDataKinds env thing + = do data_kinds <- xoptM LangExt.DataKinds + unless data_kinds $ + addErr $ TcRnDataKindsError type_or_kind $ Left thing + where + type_or_kind | isRnKindLevel env = KindLevel + | otherwise = TypeLevel + +warnUnusedForAll :: OutputableBndrFlag flag 'Renamed + => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () +warnUnusedForAll doc (L loc tvb) used_names = + case hsBndrVar tvb of + HsBndrWildCard _ -> return () + HsBndrVar _ (L _ tv) -> + unless (tv `elemNameSet` used_names) $ do + let msg = TcRnUnusedQuantifiedTypeVar doc (HsTyVarBndrExistentialFlag tvb) + addDiagnosticAt (locA loc) msg + +warnCapturedTerm :: LocatedN RdrName -> Either [GlobalRdrElt] Name -> TcM () +warnCapturedTerm (L loc tv) shadowed_term_names + = let msg = TcRnCapturedTermName tv shadowed_term_names + in addDiagnosticAt (locA loc) msg + +{- +************************************************************************ +* * + Finding the free type variables of a (HsType RdrName) +* * +************************************************************************ + + +Note [Kind and type-variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type signature we may implicitly bind type/kind variables. For example: + * f :: a -> a + f = ... + Here we need to find the free type variables of (a -> a), + so that we know what to quantify + + * class C (a :: k) where ... + This binds 'k' in ..., as well as 'a' + + * f (x :: a -> [a]) = .... + Here we bind 'a' in .... + + * f (x :: T a -> T (b :: k)) = ... + Here we bind both 'a' and the kind variable 'k' + + * type instance F (T (a :: Maybe k)) = ...a...k... + Here we want to constrain the kind of 'a', and bind 'k'. + +To do that, we need to walk over a type and find its free type/kind variables. +We preserve the left-to-right order of each variable occurrence. +See Note [Ordering of implicit variables]. + +It is common for lists of free type variables to contain duplicates. For +example, in `f :: a -> a`, the free type variable list is [a, a]. When these +implicitly bound variables are brought into scope (with rnImplicitTvOccs), +duplicates are removed with nubL. + +Note [Ordering of implicit variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the advent of -XTypeApplications, GHC makes promises about the ordering +of implicit variable quantification. Specifically, we offer that implicitly +quantified variables (such as those in const :: a -> b -> a, without a `forall`) +will occur in left-to-right order of first occurrence. Here are a few examples: + + const :: a -> b -> a -- forall a b. ... + f :: Eq a => b -> a -> a -- forall a b. ... contexts are included + + type a <-< b = b -> a + g :: a <-< b -- forall a b. ... type synonyms matter + + class Functor f where + fmap :: (a -> b) -> f a -> f b -- forall f a b. ... + -- The f is quantified by the class, so only a and b are considered in fmap + +This simple story is complicated by the possibility of dependency: all variables +must come after any variables mentioned in their kinds. + + typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... + +The k comes first because a depends on k, even though the k appears later than +the a in the code. Thus, GHC does ScopedSort on the variables. +See Note [ScopedSort] in GHC.Core.Type. + +Implicitly bound variables are collected by any function which returns a +FreeKiTyVars, which notably includes the `extract-` family of functions +(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.). +These functions thus promise to keep left-to-right ordering. + +Note that for 'HsFunTy m ty1 ty2', we quantify in the order ty1, m, ty2, +since this type is written ty1 %m -> ty2 in the source syntax. + +Note [Implicit quantification in type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We typically bind type/kind variables implicitly when they are in a kind +annotation on the LHS, for example: + + data Proxy (a :: k) = Proxy + type KindOf (a :: k) = k + +Here 'k' is in the kind annotation of a type variable binding, HsBndrKind, and +we want to implicitly quantify over it. This is easy: just extract all free +variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs + +By contrast, on the RHS we can't simply collect *all* free variables. Which of +the following are allowed? + + type TySyn1 = a :: Type + type TySyn2 = 'Nothing :: Maybe a + type TySyn3 = 'Just ('Nothing :: Maybe a) + type TySyn4 = 'Left a :: Either Type a + +After some design deliberations (see non-taken alternatives below), the answer +is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now. +We implicitly quantify over free variables of the outermost kind signature, if +one exists: + + * In TySyn1, the outermost kind signature is (:: Type), and it does not have + any free variables. + * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a + free variable 'a', which we implicitly quantify over. + * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature + is hidden inside 'Just. + * In TySyn4, the outermost kind signature is (:: Either Type a), it contains + a free variable 'a', which we implicitly quantify over. That is why we can + also use it to the left of the double colon: 'Left a + +The logic resides in extractHsTyRdrTyVarsKindVars. + +This was a stopgap solution until we could explicitly bind invisible +type/kind variables: + + type TySyn3 :: forall a. Maybe a + type TySyn3 @a = 'Just ('Nothing :: Maybe a) + +Now that the new syntax was proposed in #425 and implemented in 9.8, we issue a warning +-Wimplicit-rhs-quantification for TySyn2 and TySyn4 and will eventually disallow them. + +Note [Implicit quantification in type synonyms: non-taken alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Alternative I: No quantification +-------------------------------- +We could offer no implicit quantification on the RHS, accepting none of the +TySyn examples. The user would have to bind the variables explicitly: + + type TySyn1 a = a :: Type + type TySyn2 a = 'Nothing :: Maybe a + type TySyn3 a = 'Just ('Nothing :: Maybe a) + type TySyn4 a = 'Left a :: Either Type a + +However, this would mean that one would have to specify 'a' at call sites every +time, which could be undesired. + +Alternative II: Indiscriminate quantification +--------------------------------------------- +We could implicitly quantify over all free variables on the RHS just like we do +on the LHS. Then we would infer the following kinds: + + TySyn1 :: forall {a}. Type + TySyn2 :: forall {a}. Maybe a + TySyn3 :: forall {a}. Maybe (Maybe a) + TySyn4 :: forall {a}. Either Type a + +This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable +is free-floating, not fixed by anything. + +Alternative III: reportFloatingKvs +---------------------------------- +We could augment Alternative II by hunting down free-floating variables during +type checking. While viable, this would mean we'd end up accepting this: + + data Prox k (a :: k) + type T = Prox k + +-} + +-- A list of free type/kind variables, which can contain duplicates. +-- See Note [Kind and type-variable binders] +-- These lists are guaranteed to preserve left-to-right ordering of +-- the types the variables were extracted from. See also +-- Note [Ordering of implicit variables]. +type FreeKiTyVars = [LocatedN RdrName] + +-- When renaming a type, do we want to capture or ignore term variables? +-- Suppose we have a variable binding `a` and we are renaming a type signature +-- that mentions `a`: +-- +-- f :: forall t -> ... +-- f a = ... +-- where g :: a -> Bool +-- +-- Does the `a` in the signature for `g` refer to the term variable or is it +-- implicitly quantified, as if the user wrote `g :: forall a. a -> Bool`? +-- `CaptureTermVars` selects the former behavior, `DontCaptureTermVars` the latter. +data TermVariableCapture = + CaptureTermVars + | DontCaptureTermVars + +getTermVariableCapture :: RnM TermVariableCapture +getTermVariableCapture + = do { required_type_arguments <- xoptM LangExt.RequiredTypeArguments + ; let tvc | required_type_arguments = CaptureTermVars + | otherwise = DontCaptureTermVars + ; return tvc } + +-- | Filter out any type and kind variables that are already in scope in the +-- the supplied LocalRdrEnv. Note that this includes named wildcards, which +-- look like perfectly ordinary type variables at this point. +filterInScope :: TermVariableCapture -> (GlobalRdrEnv, LocalRdrEnv) -> FreeKiTyVars -> FreeKiTyVars +filterInScope tvc envs = filterOut (inScope tvc envs . unLoc) + +-- | Like 'filterInScope', but keep parent class variables intact. +-- Used with associated types. See Note [Class variables and filterInScope] +filterInScopeNonClass :: [Name] -> TermVariableCapture -> (GlobalRdrEnv, LocalRdrEnv) -> FreeKiTyVars -> FreeKiTyVars +filterInScopeNonClass cls_tvs tvc envs = filterOut (in_scope_non_class . unLoc) + where + in_scope_non_class :: RdrName -> Bool + in_scope_non_class rdr + | occName rdr `elemOccSet` cls_tvs_set = False + | otherwise = inScope tvc envs rdr + + cls_tvs_set :: OccSet + cls_tvs_set = mkOccSet (map nameOccName cls_tvs) + +-- | Filter out any type and kind variables that are already in scope in the +-- the environment's LocalRdrEnv. Note that this includes named wildcards, +-- which look like perfectly ordinary type variables at this point. +filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars +filterInScopeM vars + = do { tvc <- getTermVariableCapture + ; envs <- getRdrEnvs + ; return (filterInScope tvc envs vars) } + +-- | Like 'filterInScopeM', but keep parent class variables intact. +-- Used with associated types. See Note [Class variables and filterInScope] +filterInScopeNonClassM :: [Name] -> FreeKiTyVars -> RnM FreeKiTyVars +filterInScopeNonClassM cls_tvs vars + = do { tvc <- getTermVariableCapture + ; envs <- getRdrEnvs + ; return (filterInScopeNonClass cls_tvs tvc envs vars) } + +inScope :: TermVariableCapture -> (GlobalRdrEnv, LocalRdrEnv) -> RdrName -> Bool +inScope tvc (gbl, lcl) rdr = + case tvc of + DontCaptureTermVars -> rdr_in_scope + CaptureTermVars -> rdr_in_scope || demoted_rdr_in_scope + where + rdr_in_scope, demoted_rdr_in_scope :: Bool + rdr_in_scope = elem_lcl rdr + demoted_rdr_in_scope = maybe False (elem_lcl <||> elem_gbl) (demoteRdrNameTv rdr) + + elem_lcl, elem_gbl :: RdrName -> Bool + elem_lcl name = elemLocalRdrEnv name lcl + elem_gbl name = (not . null) (lookupGRE gbl (LookupRdrName name (RelevantGREsFOS WantBoth))) + +{- Note [Class variables and filterInScope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `bindHsQTyVars` free variables are collected and bound implicitly. Example: + type ElemKind (a :: Maybe k) = k +Both occurrences of `k` are usages, so GHC creates an implicit binding for `k`. +We can also bind it explicitly with the help of TypeAbstractions: + type ElemKind @k (a :: Maybe k) = k + +This is similar to implicit quantification that happens in type signatures + const :: a -> b -> a -- `a` and `b` bound implicitly + const :: forall a b. a -> b -> a -- `a` and `b` bound explicitly + +In both cases we need to compute the list of free variables to implicitly +quantify over (NB: list, not set, because order matters with TypeApplications) + * implicitly bound variables in ElemKind: [k] + * implicitly bound variables in const: [a, b] + +However, variables that are already in scope are captured. Example: + {-# LANGUAGE ScopedTypeVariables #-} + f (x :: a) = ... + where g :: a -> a + g _ = x +When we look at `g` in isolation, `a` is a free variable: + g :: a -> a +But due to ScopedTypeVariables, `a` is actually bound in the surrounding +context, namely the (x :: a) pattern. +It is important that we do /not/ insert an implicit forall in the type of `g` + g :: forall a. a -> a -- No! That would mean a different thing +The solution is to use `filterInScopeM` to remove variables already in scope +from candidates for implicit quantification. + +Using `filterInScopeM` is additionally important when RequiredTypeArguments is +in effect. Consider + import Prelude (id) + data T (a :: id) = MkT -- Test case T23740e + +With RequiredTypeArguments, variables in the term namespace can be referred to +at the type level, so `id` in the `:: id` kind signature ought to refer to `id` +from Prelude. Of course it is not a valid program, but we want a proper error +message rather than implicit quantification: + T23740e.hs:5:14: error: [GHC-45510] + • Term variable ‘id’ cannot be used here + (term variables cannot be promoted) + +This leads us to use `filterInScopeM` in `bindHsQTyVars`. +Unfortunately, associated types make matters more complex. Consider + class C (a::k1) (b::k2) (c::k3) where + type T (a::k1) b +When renaming `T`, we have to implicitly quantify over the class variable `k1`, +despite the fact that `k1` is in scope from the class header. The type checker +expects to find `k1` in `HsQTvsRn` (the `hsq_ext` field of `LHsQTyVars`). But it +won't find it there if it is filtered out by `filterInScopeM`. + +To account for that, we introduce another helper, `filterInScopeNonClassM`, +which acts much like `filterInScopeM` but leaves class variables intact. -} + +extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars +extract_tyarg (HsValArg _ ty) acc = extract_lty ty acc +extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc +extract_tyarg (HsArgPar _) acc = acc + +extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVars -> FreeKiTyVars +extract_tyargs args acc = foldr extract_tyarg acc args + +extractHsTyArgRdrKiTyVars :: [LHsTypeArg GhcPs] -> FreeKiTyVars +extractHsTyArgRdrKiTyVars args + = extract_tyargs args [] + +-- | 'extractHsTyRdrTyVars' finds the type/kind variables +-- of a HsType/HsKind. +-- It's used when making the @forall@s explicit. +-- See Note [Kind and type-variable binders] +extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars +extractHsTyRdrTyVars ty = extract_lty ty [] + +-- | Extracts the free type/kind variables from the kind signature of a HsType. +-- This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@. +-- The left-to-right order of variables is preserved. +-- See Note [Kind and type-variable binders] and +-- Note [Ordering of implicit variables] and +-- Note [Implicit quantification in type synonyms]. +extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVars +extractHsTyRdrTyVarsKindVars (L _ ty) = + case ty of + HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty + HsKindSig _ _ ki -> extractHsTyRdrTyVars ki + _ -> [] + +-- | Extracts free type and kind variables from types in a list. +-- When the same name occurs multiple times in the types, all occurrences +-- are returned. +extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars +extractHsTysRdrTyVars tys = extract_ltys tys + +-- Returns the free kind variables of any explicitly-kinded binders, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +-- NB: Does /not/ delete the binders themselves. +-- E.g. given [k1, a:k1, b:k2] +-- the function returns [k1,k2], even though k1 is bound here +extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars +extractHsTyVarBndrsKVs tv_bndrs = extract_hs_tv_bndrs_kvs tv_bndrs + +-- Returns the free kind variables in a type family result signature, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +extractRdrKindSigVars :: LFamilyResultSig GhcPs -> FreeKiTyVars +extractRdrKindSigVars (L _ resultSig) = case resultSig of + KindSig _ k -> extractHsTyRdrTyVars k + TyVarSig _ (L _ tvb) | HsTvb { tvb_kind = HsBndrKind _ k } <- tvb + -> extractHsTyRdrTyVars k + _ -> [] + +-- | Extracts free type and kind variables from an argument in a GADT +-- constructor, returning variable occurrences in left-to-right order. +-- See @Note [Ordering of implicit variables]@. +extractConDeclGADTDetailsTyVars :: + HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars +extractConDeclGADTDetailsTyVars con_args = case con_args of + PrefixConGADT _ args -> extract_scaled_ltys args + RecConGADT _ (L _ flds) -> extract_scaled_ltys $ map (cdrf_spec . unLoc) $ flds + +-- | Get type/kind variables mentioned in the kind signature, preserving +-- left-to-right order: +-- +-- * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type -- result: [k2,k1] +-- * data T a (b :: k1) -- result: [] +-- +-- See Note [Ordering of implicit variables]. +extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVars +extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig }) + = maybe [] extractHsTyRdrTyVars ksig + +extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars +extract_lctxt ctxt = extract_ltys (unLoc ctxt) + +extract_scaled_ltys :: [HsConDeclField GhcPs] + -> FreeKiTyVars -> FreeKiTyVars +extract_scaled_ltys args acc = foldr extract_scaled_lty acc args + +extract_scaled_lty :: HsConDeclField GhcPs + -> FreeKiTyVars -> FreeKiTyVars +extract_scaled_lty (CDF { cdf_multiplicity, cdf_type }) acc + = extract_lty cdf_type $ extract_hs_mult_ann cdf_multiplicity acc + +extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars +extract_ltys tys acc = foldr extract_lty acc tys + +extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars +extract_lty (L _ ty) acc + = case ty of + HsTyVar _ _ ltv -> extract_tv ltv acc + HsAppTy _ ty1 ty2 -> extract_lty ty1 $ + extract_lty ty2 acc + HsAppKindTy _ ty k -> extract_lty ty $ + extract_lty k acc + HsListTy _ ty -> extract_lty ty acc + HsTupleTy _ _ tys -> extract_ltys tys acc + HsSumTy _ tys -> extract_ltys tys acc + HsFunTy _ m ty1 ty2 -> extract_lty ty1 $ + extract_hs_mult_ann m $ -- See Note [Ordering of implicit variables] + extract_lty ty2 acc + HsIParamTy _ _ ty -> extract_lty ty acc + HsOpTy _ _ ty1 tv ty2 -> extract_lty ty1 $ + extract_tv tv $ + extract_lty ty2 acc + HsParTy _ ty -> extract_lty ty acc + HsSpliceTy {} -> acc -- Type splices mention no tvs + HsDocTy _ ty _ -> extract_lty ty acc + HsExplicitListTy _ _ tys -> extract_ltys tys acc + HsExplicitTupleTy _ _ tys -> extract_ltys tys acc + HsTyLit _ _ -> acc + HsStarTy _ _ -> acc + HsKindSig _ ty ki -> extract_kind_sig ty ki acc + HsForAllTy { hst_tele = tele, hst_body = ty } + -> extract_hs_for_all_telescope tele acc $ + extract_lty ty [] + HsQualTy { hst_ctxt = ctxt, hst_body = ty } + -> extract_lctxt ctxt $ + extract_lty ty acc + XHsType {} -> acc + -- We deal with these separately in rnLHsTypeWithWildCards + HsWildCardTy {} -> acc + +extract_kind_sig :: LHsType GhcPs -- type + -> LHsType GhcPs -- kind + -> FreeKiTyVars -> FreeKiTyVars +extract_kind_sig ty ki acc + | (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs } + , hst_body = ki_body }) <- ki + = extract_hs_tv_bndrs bndrs acc $ + extract_lty ty $ + extract_lty ki_body [] +extract_kind_sig ty ki acc + = extract_lty ty $ + extract_lty ki acc + +extract_lhs_sig_ty :: LHsSigType GhcPs -> FreeKiTyVars +extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) = + extractHsOuterTvBndrs outer_bndrs $ extract_lty body [] + +extract_hs_mult_ann :: HsMultAnn GhcPs -> FreeKiTyVars -> FreeKiTyVars +extract_hs_mult_ann (HsExplicitMult _ p) acc = extract_lty p acc +extract_hs_mult_ann _ acc = acc + +extract_hs_for_all_telescope :: HsForAllTelescope GhcPs + -> FreeKiTyVars -- Accumulator + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars +extract_hs_for_all_telescope tele acc_vars body_fvs = + case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + extract_hs_tv_bndrs bndrs acc_vars body_fvs + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + extract_hs_tv_bndrs bndrs acc_vars body_fvs + +extractHsOuterTvBndrs :: HsOuterTyVarBndrs flag GhcPs + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars -- Free in result +extractHsOuterTvBndrs outer_bndrs body_fvs = + case outer_bndrs of + HsOuterImplicit{} -> body_fvs + HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs + +extractHsForAllTelescopes :: [HsForAllTelescope GhcPs] + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars -- Free in result +extractHsForAllTelescopes [] body_fvs = body_fvs +extractHsForAllTelescopes (tele:teles) body_fvs = + extract_hs_for_all_telescope tele [] $ + extractHsForAllTelescopes teles body_fvs + +extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs] + -> FreeKiTyVars -- Accumulator + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars +-- In (forall (a :: Maybe e). a -> b) we have +-- 'a' is bound by the forall +-- 'b' is a free type variable +-- 'e' is a free kind variable +extract_hs_tv_bndrs tv_bndrs acc_vars body_vars = new_vars ++ acc_vars + where + new_vars + | null tv_bndrs = body_vars + | otherwise = filterFreeVarsToBind tv_bndr_rdrs $ bndr_vars ++ body_vars + -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars. + -- See Note [Kind variable scoping] + bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs + tv_bndr_rdrs = mapMaybe hsLTyVarLocName tv_bndrs + +extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars +-- Returns the free kind variables of any explicitly-kinded binders, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +-- NB: Does /not/ delete the binders themselves. +-- E.g. given [k1, a:k1, b:k2] +-- the function returns [k1,k2], even though k1 is bound here +extract_hs_tv_bndrs_kvs tv_bndrs = + foldr extract_lty [] + [k | L _ (HsTvb { tvb_kind = HsBndrKind _ k }) <- tv_bndrs] + +extract_tv :: LocatedN RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_tv tv acc = + if isRdrTyVar (unLoc tv) && (not . isQual) (unLoc tv) then tv:acc else acc + +-- Deletes duplicates in a list of Located things. This is used to: +-- +-- * Delete duplicate occurrences of implicitly bound type/kind variables when +-- bringing them into scope (in rnImplicitTvOccs). +-- +-- * Delete duplicate occurrences of named wildcards (in rn_hs_sig_wc_type and +-- rnHsWcType). +-- +-- Importantly, this function is stable with respect to the original ordering +-- of things in the list. This is important, as it is a property that GHC +-- relies on to maintain the left-to-right ordering of implicitly quantified +-- type variables. +-- See Note [Ordering of implicit variables]. +nubL :: Eq a => [GenLocated l a] -> [GenLocated l a] +nubL = nubBy eqLocated + +nubN :: Eq a => [LocatedN a] -> [LocatedN a] +nubN = nubBy eqLocated + +-- | Filter out any potential implicit binders that are either +-- already in scope, or are explicitly bound in the binder. +filterFreeVarsToBind :: FreeKiTyVars + -- ^ Explicitly bound here + -> FreeKiTyVars + -- ^ Potential implicit binders + -> FreeKiTyVars + -- ^ Final implicit binders +filterFreeVarsToBind bndrs = filterOut is_in_scope + -- Make sure to list the binder kvs before the body kvs, as mandated by + -- Note [Ordering of implicit variables] + where + is_in_scope locc = any (eqLocated locc) bndrs diff --git a/GHC/Rename/Module.hs b/GHC/Rename/Module.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Module.hs @@ -0,0 +1,2877 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Main pass of renamer +-} + +module GHC.Rename.Module ( + rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt, rnLWarningTxt + ) where + +import GHC.Prelude hiding ( head ) + +import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) +import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) + +import GHC.Hs + +import GHC.Rename.HsType +import GHC.Rename.Bind +import GHC.Rename.Doc +import GHC.Rename.Env +import GHC.Rename.Utils ( mapFvRn, bindLocalNames + , checkDupRdrNames, bindLocalNamesFV + , warnUnusedTypePatterns + , noNestedForallsContextsErr + , addNoNestedForallsContextsErr, checkInferredVars ) +import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) +import GHC.Rename.Names + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin ( TypedThing(..) ) + +import GHC.Unit +import GHC.Unit.Module.Warnings +import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName + , monadClassName, returnMName, thenMName + , semigroupClassName, sappendName + , monoidClassName, mappendName + ) + +import GHC.Types.FieldLabel +import GHC.Types.Name.Reader +import GHC.Types.ForeignCall ( CCallTarget(..) ) +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Basic ( VisArity, TyConFlavour(..), TypeOrKind(..), RuleName ) +import GHC.Types.GREInfo (ConLikeInfo (..), ConInfo, mkConInfo, conInfoFields) +import GHC.Types.Hint (SigLike(..)) +import GHC.Types.Unique.Set +import GHC.Types.SrcLoc as SrcLoc + +import GHC.Driver.DynFlags +import GHC.Driver.Env ( HscEnv(..), hsc_home_unit) + +import GHC.Utils.Misc ( lengthExceeds ) +import GHC.Utils.Panic +import GHC.Utils.Outputable + +import GHC.Data.FastString +import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses ) +import GHC.Data.Graph.Directed ( SCC, flattenSCC, Node(..) + , stronglyConnCompFromEdgedVerticesUniq ) +import GHC.Data.OrdList +import qualified GHC.LanguageExtensions as LangExt +import GHC.Core.DataCon ( isSrcStrict ) + +import Control.Monad +import Control.Arrow ( first ) +import Data.Foldable ( toList, for_ ) +import Data.List.NonEmpty ( NonEmpty(..), head, nonEmpty ) +import Data.Maybe ( isNothing, fromMaybe, mapMaybe, maybeToList ) +import qualified Data.Set as Set ( difference, fromList, toList, null ) + +{- | @rnSourceDecl@ "renames" declarations. +It simultaneously performs dependency analysis and precedence parsing. +It also does the following error checks: + +* Checks that tyvars are used properly. This includes checking + for undefined tyvars, and tyvars in contexts that are ambiguous. + (Some of this checking has now been moved to module @TcMonoType@, + since we don't have functional dependency information at this point.) + +* Checks that all variable occurrences are defined. + +* Checks the @(..)@ etc constraints in the export list. + +Brings the binders of the group into scope in the appropriate places; +does NOT assume that anything is in scope already +-} +rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn) +-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files +rnSrcDecls group@(HsGroup { hs_valds = val_decls, + hs_splcds = splice_decls, + hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = warn_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_docs = docs }) + = do { + -- (A) Process the top-level fixity declarations, creating a mapping from + -- FastStrings to FixItems. Also checks for duplicates. + -- See Note [Top-level fixity signatures in an HsGroup] in GHC.Hs.Decls + local_fix_env <- makeMiniFixityEnv $ hsGroupTopLevelFixitySigs group ; + + -- (B) Bring top level binders (and their fixities) into scope, + -- *except* for the value bindings, which get done in step (D) + -- with collectHsIdBinders. However *do* include + -- + -- * Class ops, data constructors, and record fields, + -- because they do not have value declarations. + -- + -- * For hs-boot files, include the value signatures + -- Again, they have no value declarations + -- + (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; + + + restoreEnvs tc_envs $ do { + + failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations + + -- (D1) Bring pattern synonyms into scope. + -- Need to do this before (D2) because rnTopBindsLHS + -- looks up those pattern synonyms (#9889) + + dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags ; + has_sel <- xopt_FieldSelectors <$> getDynFlags ; + extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env $ \pat_syn_bndrs -> do { + + -- (D2) Rename the left-hand sides of the value bindings. + -- This depends on everything from (B) being in scope. + -- It uses the fixity env from (A) to bind fixities for view patterns. + + -- We need to throw an error on such value bindings when in a boot file. + is_boot <- tcIsHsBootOrSig ; + new_lhs <- if is_boot + then rnTopBindsLHSBoot local_fix_env val_decls + else rnTopBindsLHS local_fix_env val_decls ; + + -- Bind the LHSes (and their fixities) in the global rdr environment + let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ; + -- Excludes pattern-synonym binders + -- They are already in scope + traceRn "rnSrcDecls" (ppr id_bndrs) ; + tc_envs <- extendGlobalRdrEnvRn (map (mkLocalVanillaGRE NoParent) id_bndrs) local_fix_env ; + restoreEnvs tc_envs $ do { + + -- Now everything is in scope, as the remaining renaming assumes. + + -- (E) Rename type and class decls + -- (note that value LHSes need to be in scope for default methods) + -- + -- You might think that we could build proper def/use information + -- for type and class declarations, but they can be involved + -- in mutual recursion across modules, and we only do the SCC + -- analysis for them in the type checker. + -- So we content ourselves with gathering uses only; that + -- means we'll only report a declaration as unused if it isn't + -- mentioned at all. Ah well. + traceRn "Start rnTyClDecls" (ppr tycl_decls) ; + (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; + + -- (F) Rename Value declarations right-hand sides + traceRn "Start rnmono" empty ; + let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; + (rn_val_decls@(XValBindsLR (NValBinds _ sigs')), bind_dus) <- if is_boot + -- For an hs-boot, use tc_bndrs (which collects how we're renamed + -- signatures), since val_bndr_set is empty (there are no x = ... + -- bindings in an hs-boot.) + then rnTopBindsBoot tc_bndrs new_lhs + else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ; + traceRn "finish rnmono" (ppr rn_val_decls) ; + + -- (G) Rename Fixity and deprecations + + -- Rename fixity declarations and error if we try to + -- fix something from another module (duplicates were checked in (A)) + let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ; + traceRn "rnSrcDecls fixity" $ + vcat [ text "all_bndrs:" <+> ppr all_bndrs ] ; + rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs))) + fix_decls ; + + -- Rename deprec decls; + -- check for duplicates and ensure that deprecated things are defined locally + -- at the moment, we don't keep these around past renaming + rn_decl_warns <- rnSrcWarnDecls all_bndrs warn_decls ; + + -- (H) Rename Everything else + + (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $ + rnList rnHsRuleDecls rule_decls ; + -- Inside RULES, scoped type variables are on + (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ; + (rn_ann_decls, src_fvs4) <- rnList rnAnnDecl ann_decls ; + (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; + (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ; + rn_docs <- traverse rnLDocDecl docs ; + + -- Update the TcGblEnv with renamed COMPLETE pragmas from the current + -- module, for pattern irrefutability checking in do notation. + last_tcg_env0 <- getGblEnv ; + let { last_tcg_env = + last_tcg_env0 + { tcg_complete_matches = tcg_complete_matches last_tcg_env0 ++ localCompletePragmas sigs' + , tcg_complete_match_env = tcg_complete_match_env last_tcg_env0 ++ localCompletePragmas sigs'} + } ; + -- (I) Compute the results and return + let {rn_group = HsGroup { hs_ext = noExtField, + hs_valds = rn_val_decls, + hs_splcds = rn_splice_decls, + hs_tyclds = rn_tycl_decls, + hs_derivds = rn_deriv_decls, + hs_fixds = rn_fix_decls, + hs_warnds = [], -- warns are returned in the tcg_env + -- (see below) not in the HsGroup + hs_fords = rn_foreign_decls, + hs_annds = rn_ann_decls, + hs_defds = rn_default_decls, + hs_ruleds = rn_rule_decls, + hs_docs = rn_docs } ; + + tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; + other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7] ; + -- It is tiresome to gather the binders from type and class decls + + src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ; + -- Instance decls may have occurrences of things bound in bind_dus + -- so we must put other_fvs last + + final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) + in -- we return the deprecs in the env, not in the HsGroup above + tcg_env' { tcg_warns = insertWarnDecls (tcg_warns tcg_env') rn_decl_warns }; + } ; + traceRn "finish rnSrc" (ppr rn_group) ; + traceRn "finish Dus" (ppr src_dus ) ; + return (final_tcg_env, rn_group) + }}}} + +addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv +-- This function could be defined lower down in the module hierarchy, +-- but there doesn't seem anywhere very logical to put it. +addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } + +rnList :: (a -> RnM (b, FreeVars)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars) +rnList f xs = mapFvRn (wrapLocFstMA f) xs + +{- +********************************************************* +* * + Source-code deprecations declarations +* * +********************************************************* + +Check that the deprecated names are defined, are defined locally, and +that there are no duplicate deprecations. + +It's only imported deprecations, dealt with in RnIfaces, that we +gather them together. +-} + +-- checks that the deprecations are defined locally, and that there are no duplicates +rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (DeclWarnOccNames GhcRn) +rnSrcWarnDecls _ [] + = return [] + +rnSrcWarnDecls bndr_set decls' + = do { -- check for duplicates + ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = fmap snd dups + in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr)) + warn_rdr_dups + ; pairs_s <- mapM (addLocM rn_deprec) decls + ; return $ concat pairs_s } + where + decls = concatMap (wd_warnings . unLoc) decls' + + sig_ctxt = TopSigCtxt bndr_set + + rn_deprec w@(Warning (ns_spec, _) rdr_names txt) + -- ensures that the names are defined locally + = do { names <- concatMapM (lookupLocalTcNames sig_ctxt SigLikeDeprecation ns_spec . unLoc) + rdr_names + ; unlessXOptM LangExt.ExplicitNamespaces $ + when (ns_spec /= NoNamespaceSpecifier) $ + addErr (TcRnNamespacedWarningPragmaWithoutFlag w) + ; txt' <- rnWarningTxt txt + ; return [(nameOccName nm, txt') | (_, nm) <- names] } + -- Use the OccName from the Name we looked up, rather than from the RdrName, + -- as we might hit multiple different NameSpaces when looking up + -- (e.g. deprecating both a variable and a record field). + + warn_rdr_dups = find_dup_warning_names + $ concatMap (\(L _ (Warning (ns_spec, _) ns _)) -> (ns_spec,) <$> ns) decls + + find_dup_warning_names :: [(NamespaceSpecifier, LocatedN RdrName)] -> [NonEmpty (NamespaceSpecifier, LocatedN RdrName)] + find_dup_warning_names = findDupsEq (\ (spec1, x) -> \ (spec2, y) -> + overlappingNamespaceSpecifiers spec1 spec2 && + rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) + +rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn) +rnWarningTxt (WarningTxt mb_cat st wst) = do + forM_ mb_cat $ \(L _ (InWarningCategory _ _ (L loc cat))) -> + unless (validWarningCategory cat) $ + addErrAt (locA loc) (TcRnInvalidWarningCategory cat) + wst' <- traverse (traverse rnHsDoc) wst + pure (WarningTxt mb_cat st wst') +rnWarningTxt (DeprecatedTxt st wst) = do + wst' <- traverse (traverse rnHsDoc) wst + pure (DeprecatedTxt st wst') + +rnLWarningTxt :: LWarningTxt GhcPs -> RnM (LWarningTxt GhcRn) +rnLWarningTxt (L loc warn) = L loc <$> rnWarningTxt warn + +-- look for duplicates among the OccNames; +-- we check that the names are defined above +-- invt: the lists returned by findDupsEq always have at least two elements + +{- +********************************************************* +* * +\subsection{Annotation declarations} +* * +********************************************************* +-} + +rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) +rnAnnDecl ann@(HsAnnotation (_, s) provenance expr) + = addErrCtxt (AnnCtxt ann) $ + do { (provenance', provenance_fvs) <- rnAnnProvenance provenance + ; cur_level <- getThLevel + ; (expr', expr_fvs) <- setThLevel (Splice Untyped cur_level) $ + rnLExpr expr + ; return (HsAnnotation (noAnn, s) provenance' expr', + provenance_fvs `plusFV` expr_fvs) } + +rnAnnProvenance :: AnnProvenance GhcPs + -> RnM (AnnProvenance GhcRn, FreeVars) +rnAnnProvenance provenance = do + provenance' <- case provenance of + ValueAnnProvenance n -> ValueAnnProvenance + <$> lookupLocatedTopBndrRnN WL_Term n + TypeAnnProvenance n -> TypeAnnProvenance + <$> lookupLocatedTopBndrRnN WL_Type n + ModuleAnnProvenance -> return ModuleAnnProvenance + return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) + +{- +********************************************************* +* * +\subsection{Default declarations} +* * +********************************************************* +-} + +rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) +rnDefaultDecl (DefaultDecl _ mb_cls tys) + = do { + ; mb_cls' <- traverse (traverse $ lookupOccRn WL_TyCon) mb_cls + ; (tys', ty_fvs) <- rnLHsTypes doc_str tys + ; return (DefaultDecl noExtField mb_cls' tys', ty_fvs) } + where + doc_str = DefaultDeclCtx + +{- +********************************************************* +* * +\subsection{Foreign declarations} +* * +********************************************************* +-} + +rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) +rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) + = do { topEnv :: HscEnv <- getTopEnv + ; name' <- lookupLocatedTopBndrRnN WL_TermVariable name + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + + -- Mark any PackageTarget style imports as coming from the current package + ; let home_unit = hsc_home_unit topEnv + spec' = patchForeignImport (homeUnitAsUnit home_unit) spec + + ; return (ForeignImport { fd_i_ext = noExtField + , fd_name = name', fd_sig_ty = ty' + , fd_fi = spec' }, fvs) } + +rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) + = do { name' <- lookupLocatedOccRn WL_TermVariable name + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + ; return (ForeignExport { fd_e_ext = noExtField + , fd_name = name', fd_sig_ty = ty' + , fd_fe = (\(CExport x c) -> CExport x c) spec } + , fvs `addOneFV` unLoc name') } + -- NB: a foreign export is an *occurrence site* for name, so + -- we add it to the free-variable list. It might, for example, + -- be imported from another module + +-- | For Windows DLLs we need to know what packages imported symbols are from +-- to generate correct calls. Imported symbols are tagged with the current +-- package, so if they get inlined across a package boundary we'll still +-- know where they're from. +-- +patchForeignImport :: Unit -> (ForeignImport GhcPs) -> (ForeignImport GhcRn) +patchForeignImport unit (CImport ext cconv safety fs spec) + = CImport ext cconv safety fs (patchCImportSpec unit spec) + +patchCImportSpec :: Unit -> CImportSpec -> CImportSpec +patchCImportSpec unit spec + = case spec of + CFunction callTarget -> CFunction $ patchCCallTarget unit callTarget + _ -> spec + +patchCCallTarget :: Unit -> CCallTarget -> CCallTarget +patchCCallTarget unit callTarget = + case callTarget of + StaticTarget src label Nothing isFun + -> StaticTarget src label (Just unit) isFun + _ -> callTarget + +{- +********************************************************* +* * +\subsection{Instance declarations} +* * +********************************************************* +-} + +rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) +rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) + = do { (tfi', fvs) <- rnTyFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) tfi + ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) } + +rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) + = do { (dfi', fvs) <- rnDataFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) dfi + ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) } + +rnSrcInstDecl (ClsInstD { cid_inst = cid }) + = do { traceRn "rnSrcIstDecl {" (ppr cid) + ; (cid', fvs) <- rnClsInstDecl cid + ; traceRn "rnSrcIstDecl end }" empty + ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) } + +-- | Warn about non-canonical typeclass instance declarations +-- +-- A "non-canonical" instance definition can occur for instances of a +-- class which redundantly defines an operation its superclass +-- provides as well (c.f. `return`/`pure`). In such cases, a canonical +-- instance is one where the subclass inherits its method +-- implementation from its superclass instance (usually the subclass +-- has a default method implementation to that effect). Consequently, +-- a non-canonical instance occurs when this is not the case. +-- +-- See also descriptions of 'checkCanonicalMonadInstances' and +-- 'checkCanonicalMonoidInstances' +checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () +checkCanonicalInstances cls poly_ty mbinds = do + whenWOptM Opt_WarnNonCanonicalMonadInstances + $ checkCanonicalMonadInstances + + whenWOptM Opt_WarnNonCanonicalMonoidInstances + $ checkCanonicalMonoidInstances + + where + -- Warn about unsound/non-canonical 'Applicative'/'Monad' instance + -- declarations. Specifically, the following conditions are verified: + -- + -- In 'Monad' instances declarations: + -- + -- * If 'return' is overridden it must be canonical (i.e. @return = pure@) + -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@) + -- + -- In 'Applicative' instance declarations: + -- + -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). + -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). + -- + checkCanonicalMonadInstances + | cls == applicativeClassName = + forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $ + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == pureAName, isAliasMG mg == Just returnMName + -> addWarnNonCanonicalMonad NonCanonical_Pure + + | name == thenAName, isAliasMG mg == Just thenMName + -> addWarnNonCanonicalMonad NonCanonical_ThenA + + _ -> return () + + | cls == monadClassName = + forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $ + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == returnMName, isAliasMG mg /= Just pureAName + -> addWarnNonCanonicalMonad NonCanonical_Return + + | name == thenMName, isAliasMG mg /= Just thenAName + -> addWarnNonCanonicalMonad NonCanonical_ThenM + + _ -> return () + + | otherwise = return () + + -- Check whether Monoid(mappend) is defined in terms of + -- Semigroup((<>)) (and not the other way round). Specifically, + -- the following conditions are verified: + -- + -- In 'Monoid' instances declarations: + -- + -- * If 'mappend' is overridden it must be canonical + -- (i.e. @mappend = (<>)@) + -- + -- In 'Semigroup' instance declarations: + -- + -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). + -- + checkCanonicalMonoidInstances + | cls == semigroupClassName = + forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $ + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == sappendName, isAliasMG mg == Just mappendName + -> addWarnNonCanonicalMonoid NonCanonical_Sappend + + _ -> return () + + | cls == monoidClassName = + forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $ + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == mappendName, isAliasMG mg /= Just sappendName + -> addWarnNonCanonicalMonoid NonCanonical_Mappend + + _ -> return () + + | otherwise = return () + + -- test whether MatchGroup represents a trivial \"lhsName = rhsName\" + -- binding, and return @Just rhsName@ if this is the case + isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name + isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = L _ [] + , m_grhss = grhss })])} + | GRHSs _ (L _ (GRHS _ [] body) :| []) lbinds <- grhss + , EmptyLocalBinds _ <- lbinds + , HsVar _ lrhsName <- unLoc body + = Just (getName lrhsName) + isAliasMG _ = Nothing + + addWarnNonCanonicalMonoid reason = + addWarnNonCanonicalDefinition (NonCanonicalMonoid reason) + + addWarnNonCanonicalMonad reason = + addWarnNonCanonicalDefinition (NonCanonicalMonad reason) + + addWarnNonCanonicalDefinition reason = + addDiagnostic (TcRnNonCanonicalDefinition reason poly_ty) + +rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) +rnClsInstDecl (ClsInstDecl { cid_ext = (inst_warn_ps, _, _) + , cid_poly_ty = inst_ty, cid_binds = mbinds + , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = oflag + , cid_datafam_insts = adts }) + = do { rec { let ctxt = ClassInstanceCtx head_ty' + ; checkInferredVars ctxt inst_ty + ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty + ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' + } + ; env <- getGlobalRdrEnv + ; let + -- Check if there are any nested `forall`s or contexts, which are + -- illegal in the type of an instance declaration (see + -- Note [No nested foralls or contexts in instance types] in + -- GHC.Hs.Type)... + mb_nested_msg = noNestedForallsContextsErr NFC_InstanceHead head_ty' + -- ...then check if the instance head is actually headed by a + -- class type constructor... + instance_head :: Either IllegalInstanceHeadReason Name + instance_head = + case hsTyGetAppHead_maybe head_ty' of + Just (L _ nm_with_rdr) -> + let nm = getName nm_with_rdr in + case lookupGRE_Name env nm of + Just (GRE { gre_info = IAmTyCon flav }) -> + if + | flav == ClassFlavour + -> Right nm + | flav == AbstractTypeFlavour + -> Left $ InstHeadAbstractClass nm_with_rdr + | otherwise + -> Left $ InstHeadNonClassHead $ InstNonClassTyCon nm_with_rdr flav + _ -> + -- The head of the instance head is out of scope; + -- we'll deal with that later. Continue for now. + Right nm + + Nothing -> + Left $ InstHeadNonClassHead InstNonTyCon + eith_cls = + case instance_head of + Right cls -> Right cls + Left illegal_head_reason -> + Left + ( getLocA head_ty' + , TcRnIllegalInstance $ + IllegalClassInstance (HsTypeRnThing $ unLoc head_ty') $ + IllegalInstanceHead illegal_head_reason + ) + -- ...finally, attempt to retrieve the class type constructor, failing + -- with an error message if there isn't one. To avoid excessive + -- amounts of error messages, we will only report one of the errors + -- from mb_nested_msg or eith_cls at a time. + ; cls <- case (mb_nested_msg, eith_cls) of + (Nothing, Right cls) -> pure cls + (Just err1, _) -> bail_out ctxt err1 + (_, Left err2) -> bail_out ctxt err2 + + -- Rename the bindings + -- The typechecker (not the renamer) checks that all + -- the bindings are for the right class + -- (Slightly strangely) when scoped type variables are on, the + -- forall-d tyvars scope over the method bindings too + ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags + + ; checkCanonicalInstances cls inst_ty' mbinds' + + -- Rename the associated types, and type signatures + -- Both need to have the instance type variables in scope + ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names) + ; ((ats', adts'), more_fvs) + <- bindLocalNamesFV ktv_names $ + do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats + ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts + ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } + + ; let all_fvs = meth_fvs `plusFV` more_fvs + `plusFV` inst_fvs + ; inst_warn_rn <- mapM rnLWarningTxt inst_warn_ps + ; return (ClsInstDecl { cid_ext = inst_warn_rn + , cid_poly_ty = inst_ty', cid_binds = mbinds' + , cid_sigs = uprags', cid_tyfam_insts = ats' + , cid_overlap_mode = oflag + , cid_datafam_insts = adts' }, + all_fvs) } + -- We return the renamed associated data type declarations so + -- that they can be entered into the list of type declarations + -- for the binding group, but we also keep a copy in the instance. + -- The latter is needed for well-formedness checks in the type + -- checker (eg, to ensure that all ATs of the instance actually + -- receive a declaration). + -- NB: Even the copies in the instance declaration carry copies of + -- the instance context after renaming. This is a bit + -- strange, but should not matter (and it would be more work + -- to remove the context). + where + -- The instance is malformed. We'd still like to make *some* progress + -- (rather than failing outright), so we report an error and continue for + -- as long as we can. Importantly, this error should be thrown before we + -- reach the typechecker, lest we encounter different errors that are + -- hopelessly confusing (such as the one in #16114). + bail_out ctxt (l, err_msg) = do + addErrAt l $ TcRnWithHsDocContext ctxt err_msg + pure $ mkUnboundName (mkTcOccFS (fsLit "")) + +rnFamEqn :: HsDocContext + -> AssocTyFamInfo + -> FamEqn GhcPs rhs + -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) + -> RnM (FamEqn GhcRn rhs', FreeVars) +rnFamEqn doc atfi + (FamEqn { feqn_tycon = tycon + , feqn_bndrs = outer_bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = payload }) rn_payload + = do { tycon' <- lookupFamInstName mb_cls tycon + + -- all_imp_vars represent the implicitly bound type variables. This is + -- empty if we have an explicit `forall` (see + -- Note [forall-or-nothing rule] in GHC.Hs.Type), which means + -- ignoring pat_kity_vars, the free variables mentioned in the type patterns + -- on the LHS of the equation + -- + -- Some examples: + -- + -- @ + -- type family F a b + -- type instance forall a b c. F [(a, b)] c = a -> b -> c + -- -- all_imp_vars = [] + -- type instance F [(a, b)] c = a -> b -> c + -- -- all_imp_vars = [a, b, c] + -- + -- type family G :: Maybe a + -- type instance forall a. G = (Nothing :: Maybe a) + -- -- all_imp_vars = [] + -- + -- data family H :: k -> Type + -- data instance forall k. H :: k -> Type where ... + -- -- all_imp_vars = [] + -- data instance H :: k -> Type where ... + -- -- all_imp_vars = [k] + -- @ + -- + -- For associated type family instances, exclude the type variables + -- bound by the instance head with filterInScopeM (#19649). + ; all_imp_vars <- filterInScopeM $ pat_kity_vars + + ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs -> + do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats + ; (payload', rhs_fvs) <- rn_payload doc payload + + -- Report unused binders on the LHS + -- See Note [Unused type variables in family instances] + ; let -- The SrcSpan that bindHsOuterFamEqnTyVarBndrs will attach to each + -- implicitly bound type variable Name in outer_bndrs' will + -- span the entire type family instance, which will be reflected in + -- -Wunused-type-patterns warnings. We can be a little more precise + -- than that by pointing to the LHS of the instance instead, which + -- is what lhs_loc corresponds to. + rn_outer_bndrs' = mapHsOuterImplicit (map (`setNameLoc` lhs_loc)) + rn_outer_bndrs + + groups :: [NonEmpty (LocatedN RdrName)] + groups = equivClasses cmpLocated pat_kity_vars + ; nms_dups <- mapM (lookupOccRn WL_TyVar . unLoc) $ + [ tv | (tv :| (_:_)) <- groups ] + -- Add to the used variables + -- a) any variables that appear *more than once* on the LHS + -- e.g. F a Int a = Bool + -- b) for associated instances, the variables + -- of the instance decl. See + -- Note [Unused type variables in family instances] + ; let nms_used = extendNameSetList rhs_fvs $ + nms_dups {- (a) -} ++ inst_head_tvs {- (b) -} + all_nms = hsOuterTyVarNames rn_outer_bndrs' + ; warnUnusedTypePatterns all_nms nms_used + + -- For associated family instances, if a type variable from the + -- parent instance declaration is mentioned on the RHS of the + -- associated family instance but not bound on the LHS, then reject + -- that type variable as being out of scope. + -- See Note [Renaming associated types]. + -- Per that Note, the LHS type variables consist of the variables + -- mentioned in the instance's type patterns (pat_fvs) + ; let improperly_scoped cls_tkv = + cls_tkv `elemNameSet` rhs_fvs + -- Mentioned on the RHS... + && not (cls_tkv `elemNameSet` pat_fvs) + -- ...but not bound on the LHS. + bad_tvs = filter improperly_scoped inst_head_tvs + ; for_ (nonEmpty bad_tvs) $ \ ne_bad_tvs -> + addErr $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamInstRHSOutOfScopeTyVars Nothing ne_bad_tvs + + ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs + -- See Note [Type family equations and occurrences] + all_fvs = case atfi of + NonAssocTyFamEqn ClosedTyFam + -> eqn_fvs + _ -> eqn_fvs `addOneFV` unLoc tycon' + + ; return (FamEqn { feqn_ext = noAnn + , feqn_tycon = tycon' + -- Note [Wildcards in family instances] + , feqn_bndrs = rn_outer_bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = payload' }, + all_fvs) } } + where + -- The parent class, if we are dealing with an associated type family + -- instance. + mb_cls = case atfi of + NonAssocTyFamEqn _ -> Nothing + AssocTyFamDeflt cls -> Just cls + AssocTyFamInst cls _ -> Just cls + + -- The type variables from the instance head, if we are dealing with an + -- associated type family instance. + inst_head_tvs = case atfi of + NonAssocTyFamEqn _ -> [] + AssocTyFamDeflt _ -> [] + AssocTyFamInst _ inst_head_tvs -> inst_head_tvs + + pat_kity_vars = extractHsTyArgRdrKiTyVars pats + -- It is crucial that extractHsTyArgRdrKiTyVars return + -- duplicate occurrences, since they're needed to help + -- determine unused binders on the LHS. + + -- The SrcSpan of the LHS of the instance. For example, lhs_loc would be + -- the highlighted part in the example below: + -- + -- type instance F a b c = Either a b + -- ^^^^^ + lhs_loc = case map lhsTypeArgSrcSpan pats of + [] -> panic "rnFamEqn.lhs_loc" + [loc] -> loc + (loc:locs) -> loc `combineSrcSpans` last locs + +rnTyFamInstDecl :: AssocTyFamInfo + -> TyFamInstDecl GhcPs + -> RnM (TyFamInstDecl GhcRn, FreeVars) +rnTyFamInstDecl atfi (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn }) + = do { (eqn', fvs) <- rnTyFamInstEqn atfi eqn + ; return (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn' }, fvs) } + +-- | Tracks whether we are renaming: +-- +-- 1. A type family equation that is not associated +-- with a parent type class ('NonAssocTyFamEqn'). Examples: +-- +-- @ +-- type family F a +-- type instance F Int = Bool -- NonAssocTyFamEqn NotClosed +-- +-- type family G a where +-- G Int = Bool -- NonAssocTyFamEqn Closed +-- @ +-- +-- 2. An associated type family default declaration ('AssocTyFamDeflt'). +-- Example: +-- +-- @ +-- class C a where +-- type A a +-- type instance A a = a -> a -- AssocTyFamDeflt C +-- @ +-- +-- 3. An associated type family instance declaration ('AssocTyFamInst'). +-- Example: +-- +-- @ +-- instance C a => C [a] where +-- type A [a] = Bool -- AssocTyFamInst C [a] +-- @ +data AssocTyFamInfo + = NonAssocTyFamEqn + ClosedTyFamInfo -- Is this a closed type family? + | AssocTyFamDeflt + Name -- Name of the parent class + | AssocTyFamInst + Name -- Name of the parent class + [Name] -- Names of the tyvars of the parent instance decl + +-- | Tracks whether we are renaming an equation in a closed type family +-- equation ('ClosedTyFam') or not ('NotClosedTyFam'). +data ClosedTyFamInfo + = NotClosedTyFam + | ClosedTyFam + +rnTyFamInstEqn :: AssocTyFamInfo + -> TyFamInstEqn GhcPs + -> RnM (TyFamInstEqn GhcRn, FreeVars) +rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon }) + = rnFamEqn (TySynCtx tycon) atfi eqn rnTySyn + + +rnTyFamDefltDecl :: Name + -> TyFamDefltDecl GhcPs + -> RnM (TyFamDefltDecl GhcRn, FreeVars) +rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls) + +rnDataFamInstDecl :: AssocTyFamInfo + -> DataFamInstDecl GhcPs + -> RnM (DataFamInstDecl GhcRn, FreeVars) +rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = + eqn@(FamEqn { feqn_tycon = tycon })}) + = do { (eqn', fvs) <- + rnFamEqn (TyDataCtx tycon) atfi eqn rnDataDefn + ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } + +-- Renaming of the associated types in instances. + +-- Rename associated type family decl in class +rnATDecls :: Name -- Class + -> [Name] -- Class variables. See Note [Class variables and filterInScope] in GHC.Rename.HsType + -> [LFamilyDecl GhcPs] + -> RnM ([LFamilyDecl GhcRn], FreeVars) +rnATDecls cls cls_tvs at_decls + = rnList (rnFamDecl (Just (cls, cls_tvs))) at_decls + +rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames + decl GhcPs -> -- an instance. rnTyFamInstDecl + RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl + -> Name -- Class + -> [Name] + -> [LocatedA (decl GhcPs)] + -> RnM ([LocatedA (decl GhcRn)], FreeVars) +-- Used for data and type family defaults in a class decl +-- and the family instance declarations in an instance +-- +-- NB: We allow duplicate associated-type decls; +-- See Note [Associated type instances] in GHC.Tc.TyCl.Instance +rnATInstDecls rnFun cls tv_ns at_insts + = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts + -- See Note [Renaming associated types] + +{- Note [Wildcards in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Wild cards can be used in type/data family instance declarations to indicate +that the name of a type variable doesn't matter. Each wild card will be +replaced with a new unique type variable. For instance: + + type family F a b :: * + type instance F Int _ = Int + +is the same as + + type family F a b :: * + type instance F Int b = Int + +This is implemented as follows: Unnamed wildcards remain unchanged after +the renamer, and then given fresh meta-variables during typechecking, and +it is handled pretty much the same way as the ones in partial type signatures. +We however don't want to emit hole constraints on wildcards in family +instances, so we turn on PartialTypeSignatures and turn off warning flag to +let typechecker know this. +See related Note [Wildcards in visible kind application] in GHC.Tc.Gen.HsType + +Note [Unused type variables in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the flag -fwarn-unused-type-patterns is on, the compiler reports +warnings about unused type variables in type-family instances. A +tpye variable is considered used (i.e. cannot be turned into a wildcard) +when + + * it occurs on the RHS of the family instance + e.g. type instance F a b = a -- a is used on the RHS + + * it occurs multiple times in the patterns on the LHS + e.g. type instance F a a = Int -- a appears more than once on LHS + + * it is one of the instance-decl variables, for associated types + e.g. instance C (a,b) where + type T (a,b) = a + Here the type pattern in the type instance must be the same as that + for the class instance, so + type T (a,_) = a + would be rejected. So we should not complain about an unused variable b + +As usual, the warnings are not reported for type variables with names +beginning with an underscore. + +Extra-constraints wild cards are not supported in type/data family +instance declarations. + +Relevant tickets: #3699, #10586, #10982 and #11451. + +Note [Renaming associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a type/data family instance, be it top-level or associated with +a class, we must check that all of the type variables mentioned on the RHS are +properly scoped. Specifically, the rule is this: + + Every variable mentioned on the RHS of a type instance declaration + (whether associated or not) must be mentioned on the LHS + +Here is a simple example of something we should reject: + + class C a b where + type F a x + instance C Int Bool where + type F Int x = z + +Here, `z` is mentioned on the RHS of the associated instance without being +mentioned on the LHS. The renamer will reject `z` as being out of scope without much fuss. + +Things get slightly trickier when the instance header itself binds type +variables. Consider this example (adapted from #5515): + + instance C (p,q) z where + type F (p,q) x = (x, z) + +According to the rule above, this instance is improperly scoped. However, due +to the way GHC's renamer works, `z` is /technically/ in scope, as GHC will +always bring type variables from an instance header into scope over the +associated type family instances. As a result, the renamer won't simply reject +the `z` as being out of scope (like it would for the `type F Int x = z` +example) unless further action is taken. It is important to reject this sort of +thing in the renamer, because if it is allowed to make it through to the +typechecker, unexpected shenanigans can occur (see #18021 for examples). + +To prevent these sorts of shenanigans, we reject programs like the one above +with an extra validity check in rnFamEqn. For each type variable bound in the +parent instance head, we check if it is mentioned on the RHS of the associated +family instance but not bound on the LHS. If any of the instance-head-bound +variables meet these criteria, we throw an error. +(See rnFamEqn.improperly_scoped for how this is implemented.) + +Some additional wrinkles: + +* This Note only applies to *instance* declarations. In *class* declarations + there is no RHS to worry about, and the class variables can all be in scope + (#5862): + + class Category (x :: k -> k -> *) where + type Ob x :: k -> Constraint + id :: Ob x a => x a a + (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c + + Here 'k' is in scope in the kind signature, just like 'x'. + +* Although type family equations can bind type variables with explicit foralls, + it need not be the case that all variables that appear on the RHS must be + bound by a forall. For instance, the following is acceptable: + + class C4 a where + type T4 a b + instance C4 (Maybe a) where + type forall b. T4 (Maybe a) b = Either a b + + Even though `a` is not bound by the forall, this is still accepted because `a` + was previously bound by the `instance C4 (Maybe a)` part. (see #16116). + +* In addition to the validity check in rnFamEqn.improperly_scoped, there is an + additional check in GHC.Tc.Validity.checkFamPatBinders that checks each family + instance equation for type variables used on the RHS but not bound on the + LHS. This is not made redundant by rmFamEqn.improperly_scoped, as there are + programs that each check will reject that the other check will not catch: + + - checkValidFamPats is used on all forms of family instances, whereas + rmFamEqn.improperly_scoped only checks associated family instances. Since + checkFamPatBinders occurs after typechecking, it can catch programs that + introduce dodgy scoping by way of type synonyms (see #7536), which is + impractical to accomplish in the renamer. + - rnFamEqn.improperly_scoped catches some programs that, if allowed to escape + the renamer, would accidentally be accepted by the typechecker. Here is one + such program (#18021): + + class C5 a where + data family D a + + instance forall a. C5 Int where + data instance D Int = MkD a + + If this is not rejected in the renamer, the typechecker would treat this + program as though the `a` were existentially quantified, like so: + + data instance D Int = forall a. MkD a + + This is likely not what the user intended! + + Here is another such program (#9574): + + class Funct f where + type Codomain f + instance Funct ('KProxy :: KProxy o) where + type Codomain 'KProxy = NatTr (Proxy :: o -> Type) + + Where: + + data Proxy (a :: k) = Proxy + data KProxy (t :: Type) = KProxy + data NatTr (c :: o -> Type) + + Note that the `o` in the `Codomain 'KProxy` instance should be considered + improperly scoped. It does not meet the criteria for being explicitly + quantified, as it is not mentioned by name on the LHS. + However, `o` /is/ bound by the instance header, so if this + program is not rejected by the renamer, the typechecker would treat it as + though you had written this: + + instance Funct ('KProxy :: KProxy o) where + type Codomain ('KProxy @o) = NatTr (Proxy :: o -> Type) + + Although this is a valid program, it's probably a stretch too far to turn + `type Codomain 'KProxy = ...` into `type Codomain ('KProxy @o) = ...` here. + If the user really wants the latter, it is simple enough to communicate + their intent by mentioning `o` on the LHS by name. + +* Historical note: Previously we had to add type variables from the outermost + kind signature on the RHS to the scope of associated type family instance, + i.e. GHC did implicit quantification over them. But now that we implement + GHC Proposal #425 "Invisible binders in type declarations" + we don't need to do this anymore. + +Note [Type family equations and occurrences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In most data/type family equations, the type family name used in the equation +is treated as an occurrence. For example: + + module A where + type family F a + + module B () where + import B (F) + type instance F Int = Bool + +We do not want to warn about `F` being unused in the module `B`, as the +instance constitutes a use site for `F`. The exception to this rule is closed +type families, whose equations constitute a definition, not occurrences. For +example: + + module C () where + type family CF a where + CF Char = Float + +Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is +defined but not used (#18470). + +GHC accomplishes this in rnFamEqn when determining the set of free +variables to return at the end. If renaming a data family or open type family +equation, we add the name of the type family constructor to the set of returned +free variables to ensure that the name is marked as an occurrence. If renaming +a closed type family equation, we avoid adding the type family constructor name +to the free variables. This is quite simple, but it is not a perfect solution. +Consider this example: + + module X () where + type family F a where + F Int = Bool + F Double = F Int + +At present, GHC will treat any use of a type family constructor on the RHS of a +type family equation as an occurrence. Since `F` is used on the RHS of the +second equation of `F`, it is treated as an occurrence, causing `F` not to be +warned about. This is not ideal, since `F` isn't exported—it really /should/ +cause a warning to be emitted. There is some discussion in #10089/#12920 about +how this limitation might be overcome, but until then, we stick to the +simplistic solution above, as it fixes the egregious bug in #18470. +-} + + +{- +********************************************************* +* * +\subsection{Stand-alone deriving declarations} +* * +********************************************************* +-} + +rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) +rnSrcDerivDecl (DerivDecl (inst_warn_ps, ann) ty mds overlap) + = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving + ; unless standalone_deriv_ok (addErr TcRnUnexpectedStandaloneDerivingDecl) + ; checkInferredVars ctxt nowc_ty + ; (mds', ty', fvs) <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt ty + -- Check if there are any nested `forall`s or contexts, which are + -- illegal in the type of an instance declaration (see + -- Note [No nested foralls or contexts in instance types] in + -- GHC.Hs.Type). + ; addNoNestedForallsContextsErr ctxt + NFC_StandaloneDerivedInstanceHead + (getLHsInstDeclHead $ dropWildCards ty') + ; inst_warn_rn <- mapM rnLWarningTxt inst_warn_ps + ; return (DerivDecl (inst_warn_rn, ann) ty' mds' overlap, fvs) } + where + ctxt = DerivDeclCtx + nowc_ty = dropWildCards ty + +{- +********************************************************* +* * +\subsection{Rules} +* * +********************************************************* +-} + +rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) +rnHsRuleDecls (HsRules { rds_ext = (_, src) + , rds_rules = rules }) + = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules + ; return (HsRules { rds_ext = src + , rds_rules = rn_rules }, fvs) } + +rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) +rnHsRuleDecl (HsRule { rd_ext = (_, st) + , rd_name = lrule_name@(L _ rule_name) + , rd_act = act + , rd_bndrs = bndrs + , rd_lhs = lhs + , rd_rhs = rhs }) + = bindRuleBndrs (RuleCtx rule_name) bndrs $ \tm_names bndrs' -> + do { (lhs', fv_lhs') <- rnLExpr lhs + ; (rhs', fv_rhs') <- rnLExpr rhs + ; checkValidRule rule_name tm_names lhs' fv_lhs' + ; return (HsRule { rd_ext = (HsRuleRn fv_lhs' fv_rhs', st) + , rd_name = lrule_name + , rd_act = act + , rd_bndrs = bndrs' + , rd_lhs = lhs' + , rd_rhs = rhs' } + , fv_lhs' `plusFV` fv_rhs') } + +{- +Note [Rule LHS validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check the shape of a rewrite rule LHS. Currently we only allow +LHSs of the form @(f e1 .. en)@, where @f@ is not one of the +@forall@'d variables. + +We used restrict the form of the 'ei' to prevent you writing rules +with LHSs with a complicated desugaring (and hence unlikely to match); +(e.g. a case expression is not allowed: too elaborate.) + +But there are legitimate non-trivial args ei, like sections and +lambdas. So it seems simpler not to check at all, and that is why +check_e is commented out. + +Note [Parens on the LHS of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You may think that no one would write + + {-# RULES "foo" (f True) = blah #-} + +with the LHS wrapped in parens. But Template Haskell does (#24621)! +So we should accommodate them. +-} + +checkValidRule :: RuleName -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM () +checkValidRule rule_name ids lhs' fv_lhs' + = do { -- Check for the form of the LHS + case (validRuleLhs ids lhs') of + Nothing -> return () + Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) + + -- Check that LHS vars are all bound + ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] + ; mapM_ (addErr . TcRnUnusedVariableInRuleDecl rule_name) bad_vars } + +validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) +-- Nothing => OK +-- Just e => Not ok, and e is the offending sub-expression +validRuleLhs foralls lhs + = checkl lhs + where + checkl = check . unLoc + + check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 + `mplus` checkl_e e2 + check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 + check (HsAppType _ e _) = checkl e + check (HsVar _ lv) + | getName lv `notElem` foralls = Nothing + -- See Note [Parens on the LHS of a RULE] + check (HsPar _ e) = checkl e + check other = Just other -- Failure + + -- Check an argument + checkl_e _ = Nothing + -- Was (check_e e); see Note [Rule LHS validity checking] + +{- Commented out; see Note [Rule LHS validity checking] above + check_e (HsVar v) = Nothing + check_e (HsPar e) = checkl_e e + check_e (HsLit e) = Nothing + check_e (HsOverLit e) = Nothing + + check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 + check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 + check_e (NegApp e _) = checkl_e e + check_e (ExplicitList _ es) = checkl_es es + check_e other = Just other -- Fails + + checkl_es es = foldr (mplus . checkl_e) Nothing es +-} + + +badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage +badRuleLhsErr name lhs bad_e + = TcRnIllegalRuleLhs errReason name lhs bad_e + where + errReason = case bad_e of + HsHole (HoleVar (L _ uv)) -> + UnboundVariable uv $ notInScopeErr WL_Global uv + _ -> IllegalExpression + +{- ************************************************************** + * * + Renaming type, class, instance and role declarations +* * +***************************************************************** + +@rnTyDecl@ uses the `global name function' to create a new type +declaration in which local names have been replaced by their original +names, reporting any unknown names. + +Renaming type variables is a pain. Because they now contain uniques, +it is necessary to pass in an association list which maps a parsed +tyvar to its @Name@ representation. +In some cases (type signatures of values), +it is even necessary to go over the type first +in order to get the set of tyvars used by it, make an assoc list, +and then go over it again to rename the tyvars! +However, we can also do some scoping checks at the same time. + +Note [Dependency analysis of type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A TyClGroup represents a strongly connected component of type/class/instance +decls, together with the role annotations and standalone kind signatures for the +type/class declarations. The renamer uses strongly connected component analysis +to build these groups. We do this for a number of reasons: + +* Improve kind error messages. Consider + + data T f a = MkT f a + data S f a = MkS f (T f a) + + This has a kind error, but the error message is better if you + check T first, (fixing its kind) and *then* S. If you do kind + inference together, you might get an error reported in S, which + is jolly confusing. See #4875 + +* Increase kind polymorphism. See GHC.Tc.TyCl + Note [Grouping of type and class declarations] + +What about instances? Based on a number of tickets (#12088, #12239, #14668, +#15561, #16410, #16448, #16693, #19611, #20875, #21172, #22257, #25238, #25834, +etc) we concluded that we cannot handle them at this stage. + +It is not possible, by looking at the free variables of a declaration, to +determine which instances a declaration depends on; furthermore, it is not +possible to discover dependencies between instances, for the same reason. + +Previously GHC inserted instances at the earliest positions where their FVs are +bound, but it only helped with a subset of tickets. The current approach is to +accept that the dependency analysis here is incomplete and recover in the kind +checker with a retrying mechanism. See Note [Retrying TyClGroups] in GHC.Tc.TyCl + +------------------------------------ +So much for why we want SCCs. What about how and when we construct them? + +First, an overview: + (TCDEP1) Flatten TyClGroups from the parser + (TCDEP2) Rename the type/class declarations, standalone kind signatures, role + declarations, and instances individually + (TCDEP3) Preprocess FVs and build a dependency graph + (TCDEP4) Find strongly connected components (SCCs) of declarations + (TCDEP5) Attach roles and kind signatures to the appropriate SCC + (TCDEP6) Create one singleton "SCC" per instance and put them at the end + +And now the deep dive: + +(TCDEP1) We start with a `HsGroup GhcPs`, containing a `[TyClGroup GhcPs]`: + a big pile of declarations. It is not important how the parser distributes + declarations across those TyClGroups, as the first thing we do in `rnTyClDecls` + is flatten them using a few helpers: + + tyClGroupTyClDecls = Data.List.concatMap group_tyclds + tyClGroupInstDecls = Data.List.concatMap group_instds + tyClGroupRoleDecls = Data.List.concatMap group_roles + tyClGroupKindSigs = Data.List.concatMap group_kisigs + + In practice, the parser just puts all declarations in a single `TyClGroup`, + so the `concatMap` is a no-op. + +(TCDEP2) Rename each declaration separately, yielding the following lists + in `rnTyClDecls`: + + tycls_w_fvs :: [(LTyClDecl GhcRn, FreeVars)] + instds_w_fvs :: [(LInstDecl GhcRn, FreeVars)] + kisigs_w_fvs :: [(LStandaloneKindSig GhcRn, FreeVars)] + role_annots :: [LRoleAnnotDecl GhcRn] + + The `FreeVars` are the free type/data constructors of the decl. For example: + + type family F (a :: k) -- FVs: {} + data X = MkX Char (Maybe X) -- FVs: {Char, Maybe, X} + data Y = MkY X (Maybe Y) -- FVs: {Maybe, Y, X} + type instance F MkX = X -- FVs: {F, MkX, X} + type instance F MkY = Int -- FVs: {F, MkY, Int} + +(TCDEP3) Build a graph where each node is a `TyClDecl` keyed by its name, and + its `FreeVars` give rise to edges. Happens in `depAnalTyClDecls`. Examples: + + data A x = MkA x -- node `A`, edges: {} + data B x = MkB (A x) -- node `B`, edges: {B -> A} + data C = MkC (B C) -- node `C`, edges: {C -> B, C -> C} + + The `FreeVars` are not used "as is" to create the edges. They first undergo a + few transformations. + + (TCDEP3.fvs_kisig) If a standalone kind signature is present, add its free + variables to those of the declaration. Consider: + + data A = MkA + data B = MkB + + type P :: A -> Type -- sig FVs: {A, Type} + data P x = MkP (Proxy MkB) -- decl FVs: {Proxy, MkB} + + By adding the sig and decl FVs together, we get {A, Type, Proxy, MkB}. + Then proceed to the next step. + + (TCDEP3.fvs_parent) Replace any mention of a (promoted) data constructor + with its parent TyCon. Consider the FVs from the previous step: + + the name set {A, Type, Proxy, MkB} + turns into {A, Type, Proxy, B} + + MkB does not get its own node in the graph, so an edge to it must actually + point to B. + + (TCDEP3.fvs_nogbl) Filter out references to type constructors outside this + `HsGroup`. They just clutter things up: + + the name set {A, Type, Proxy, B} + turns into {A, B} + + Note [Prepare TyClGroup FVs] describes these transformations in more detail. + Back to our `P` example, the final nodes and edges are as follows: + + data A = MkA -- node `A`, edges: {} + data B = MkB -- node `B`, edges: {} + + type P :: A -> Type + data P x = MkP (Proxy MkB) -- node `P`, edges: {P -> A, P -> B} + +(TCDEP4) Find strongly connected components (SCCs) of `TyClDecl`s. + This happens immediately after building the dependency graph in + `depAnalTyClDecls`. As the result, in `rnTyClDecls` we get + + tycl_sccs :: [SCC (LTyClDecl GhcRn, NameSet)] + + These SCCs are topologically sorted, but only according to lexical + dependencies (i.e. dependencies that can be found by looking at the FVs). + Non-lexical dependencies (i.e. dependencies on instances) are ignored because + they can't be reliably found prior to type checking. + + More on that in Note [Retrying TyClGroups] in GHC.Tc.TyCl. + +(TCDEP5) For each SCC, create a `TyClGroup GhcRn`. Standalone kind signatures + and role annotations are looked up by name and included in the same + `TyClGroup` as the corresponding type/class declarations. + + The extension field `group_ext` of `TyClGroup GhcRn` contains the dependencies + of the SCC computed from FVs in step (TCDEP3), but /excluding/ the type + constructors bound by the group itself. Example: + + -- TyClGroup: binds {Z} + -- depends on {} + data Z = MkZ -- FVs: {} + + -- TyClGroup: binds {X, Y} + -- depends on {Z} rather than {X, Y, Z} + data X = MkX Y Z -- FVs: {Y, Z} + data Y = MkY X Z -- FVs: {X, Z} + + Reason: `isReadyTyClGroup` in GHC.Tc.TyCl is a function that checks whether + all of a TyClGroup's dependencies are present in the type checking env, and we + wouldn't want it to consider a group to be "blocked" on its own declarations. + +(TCDEP6) For each instance, create a singleton `TyClGroup GhcRn`, and put them + all at the end, where their lexical dependencies are surely satisfied. + More on that in Note [Put instances at the end]. + + The `group_ext` field in an instance TyClGroup is set to the FVs of the + instance, preprocessed much in the same way as declaration FVs in step + (TCDEP3). See Note [Prepare TyClGroup FVs] for details. + +Note [No dependencies on data instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family D a + data instance D Int = D1 + data S = MkS (Proxy 'D1) + +Here the declaration of S depends on the /data instance/ declaration +for 'D Int'. That makes things a lot more complicated, especially +if the data instance is an associated type of an enclosing class instance. +(And the class instance might have several associated type instances +with different dependency structure!) + +Ugh. For now we simply don't allow promotion of data constructors for +data instances. See Note [AFamDataCon: not promoting data family +constructors] in GHC.Tc.Utils.Env + +Note [Put instances at the end] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no point including type family instances or class instances in the +graph for SCC analysis because instances are not referred to by name. We cannot +discover, by looking at the free variables of a declaration, what instances it +depends on. + +Instead, we create one singleton "SCC" per instance using mkInstGroups and put +them at the end. This is simple and guarantees that the FVs of all instances are +bound in the preceding TyClGroups. + +The problem is that if there are any declarations that depend on instances, +they're going to fail kind checking, because instances come after the +declarations. To account for that, the kind checker goes through a multipass +ordeal described in Note [Retrying TyClGroups] in GHC.Tc.TyCl. + +One might ask, "why not insert instances at the earliest positions where their +FVs are bound?" Indeed, this sounds like a plausible solution, and GHC used to +do it at one point. However, there are many tickets (and now test cases) +demonstrating its inadequacy: #12088, #12239, #14668, #15561, #16410, #16448, +#16693, #19611, #20875, #21172, #22257, #25238, #25834, etc. + +As to why we put each instance in its own group, as opposed to using just one +group with all the instances, the reason is that an instance may depend on +another instance, so we better add them to the environment one by one. +-} + + +rnTyClDecls :: [TyClGroup GhcPs] + -> RnM ([TyClGroup GhcRn], FreeVars) +-- Rename the declarations and do dependency analysis on them +rnTyClDecls tycl_ds + = do { -- Flatten TyClGroups and rename each declaration individually. + -- Steps (TCDEP1) and (TCDEP2) of Note [Dependency analysis of type and class decls] + ; tycls_w_fvs <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds) + ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) + ; traceRn "rnTyClDecls" $ + vcat [ text "tyClGroupTyClDecls:" <+> ppr tycls_w_fvs + , text "tc_names:" <+> ppr tc_names ] + ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) + ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) + ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) + + -- Do SCC analysis on the type/class declarations. + -- Steps (TCDEP3) and (TCDEP4) of Note [Dependency analysis of type and class decls] + ; rdr_env <- getGlobalRdrEnv + ; traceRn "rnTyClDecls SCC analysis" $ + vcat [ text "rdr_env:" <+> ppr rdr_env ] + ; let tycl_sccs = depAnalTyClDecls rdr_env tc_names kisig_fv_env tycls_w_fvs + (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs + role_annot_env = mkRoleAnnotEnv role_annots + + -- Construct renamed TyClGroups. + -- Steps (TCDEP5) and (TCDEP6) of Note [Dependency analysis of type and class decls] + ; let tycl_groups = map (mk_group role_annot_env kisig_env) tycl_sccs + inst_groups = mkInstGroups rdr_env tc_names instds_w_fvs + all_groups = tycl_groups ++ inst_groups + + ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) + + ; let all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV` + foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV` + foldr (plusFV . snd) emptyFVs kisigs_w_fvs + + ; return (all_groups, all_fvs) } + where + -- Construct a type/class declaration TyClGroup. + -- Step (TCDEP5) of Note [Dependency analysis of type and class decls] + mk_group :: RoleAnnotEnv + -> KindSigEnv + -> SCC (LTyClDecl GhcRn, NameSet) + -> TyClGroup GhcRn + mk_group role_env kisig_env scc = group + where + (tycl_ds, nodes_deps) = unzip (flattenSCC scc) + node_bndrs = map (tcdName . unLoc) tycl_ds + deps = delFVs node_bndrs (plusFVs nodes_deps) + -- (delFVs node_bndrs) removes the self-references. + -- See Note [Prepare TyClGroup FVs] + group = TyClGroup { group_ext = deps + , group_tyclds = tycl_ds + , group_kisigs = getKindSigs node_bndrs kisig_env + , group_roles = getRoleAnnots node_bndrs role_env + , group_instds = [] } + +-- | Free variables of standalone kind signatures. +newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars) + +lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars +lookupKindSig_FV_Env (KindSig_FV_Env e) name + = fromMaybe emptyFVs (lookupNameEnv e name) + +-- | Standalone kind signatures. +type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn) + +mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env) +mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env) + where + kisig_env = mapNameEnv fst compound_env + kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env) + compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars) + = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs + +getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn] +getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs + +rnStandaloneKindSignatures + :: NameSet -- names of types and classes in the current TyClGroup + -> [LStandaloneKindSig GhcPs] + -> RnM [(LStandaloneKindSig GhcRn, FreeVars)] +rnStandaloneKindSignatures tc_names kisigs + = do { let (no_dups, dup_kisigs) = removeDupsOn get_name kisigs + get_name = standaloneKindSigName . unLoc + ; mapM_ dupKindSig_Err dup_kisigs + ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups + } + +rnStandaloneKindSignature + :: NameSet -- names of types and classes in the current TyClGroup + -> StandaloneKindSig GhcPs + -> RnM (StandaloneKindSig GhcRn, FreeVars) +rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) + = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures + ; unless standalone_ki_sig_ok $ addErr TcRnUnexpectedStandaloneKindSig + ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) SigLikeStandaloneKindSig v + ; (new_ki, fvs) <- rnHsSigType (StandaloneKindSigCtx v) KindLevel ki + ; return (StandaloneKindSig noExtField new_v new_ki, fvs) + } + +-- See Note [Dependency analysis of type and class decls] +depAnalTyClDecls :: GlobalRdrEnv + -> NameSet -- Names in the current HsGroup + -> KindSig_FV_Env -- FVs of standalone kind signatures + -> [(LTyClDecl GhcRn, FreeVars)] + -> [SCC (LTyClDecl GhcRn, NameSet)] +depAnalTyClDecls rdr_env tc_names kisig_fv_env ds_w_fvs + = stronglyConnCompFromEdgedVerticesUniq edges + where + -- Build a graph where each node is a `TyClDecl` keyed by its name, and + -- its `FreeVars` give rise to edges. + -- Step (TCDEP3) of Note [Dependency analysis of type and class decls] + edges :: [ Node Name (LTyClDecl GhcRn, NameSet) ] + edges = [ DigraphNode (d, deps) name (nonDetEltsUniqSet deps) + -- nonDetEltsUniqSet is OK to use here because the order of the edges + -- has no effect on the result of stronglyConnCompFromEdgedVerticesUniq. + -- See Note [Deterministic SCC] in GHC.Data.Graph.Directed. + + | (d, fvs) <- ds_w_fvs, + let { name = tcdName (unLoc d) + ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name + ; node_fvs = fvs `plusFV` kisig_fvs -- (TCDEP3.fvs_kisig) + ; deps = toParents rdr_env node_fvs `intersectFVs` tc_names + -- (toParents rdr_env) maps datacons to parent tycons (TCDEP3.fvs_parent), + -- (`intersectFVs` tc_names) filters out imported names (TCDEP3.fvs_nogbl). + -- See also Note [Prepare TyClGroup FVs] + } + ] + +toParents :: GlobalRdrEnv -> NameSet -> NameSet +toParents rdr_env ns + = nonDetStrictFoldUniqSet add emptyNameSet ns + -- It's OK to use a non-deterministic fold because we immediately forget the + -- ordering by creating a set + where + add n s = extendNameSet s (getParent rdr_env n) + +getParent :: GlobalRdrEnv -> Name -> Name +getParent rdr_env n + = case lookupGRE_Name rdr_env n of + Just gre -> case greParent gre of + ParentIs { par_is = p } -> p + _ -> n + Nothing -> n + +{- Note [Prepare TyClGroup FVs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The renamer returns, alongside each renamed type/class declaration or instance, +the set of its free variables: + + rnTyClDecl :: TyClDecl GhcPs -> RnM (TyClDecl GhcRn, FreeVars) + rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) + +For example: + + type family F (a :: k) -- FVs: {} + data X = MkX Char (Maybe X) -- FVs: {Char, Maybe, X} + data Y = MkY X (Maybe Y) -- FVs: {Maybe, Y, X} + type instance F MkX = X -- FVs: {F, MkX, X} + type instance F MkY = Int -- FVs: {F, MkY, Int} + +This is almost what we need for dependency analysis (i.e. to figure out in which +order to check the declarations), but first we apply a few transformations: + +* toParents rdr_env inst_fvs `intersectFVs` tc_names -- in mkInstGroups +* toParents rdr_env node_fvs `intersectFVs` tc_names -- in depAnalTyClDecls +* delFVs node_bndrs (plusFVs nodes_deps) -- in rnTyClGroups + +The cited lines of code are somewhat far apart; to see the big picture, refer +to Note [Dependency analysis of type and class decls], and more specifically +steps TCDEP3, TCDEP5, and TCDEP6. + +The cumulative effect of these transformations is as follows: + +* Data constructor names are replaced by the parent type constructors: + {MkX} ==> {X} + Part of the code: + toParents rdr_env + Reason: + MkX does not get its own node in the dependency graph, + so we cannot make an edge to it in `depAnalTyClDecls` + +* Names defined outside the current HsGroup are filtered out: + {Char,Maybe} ==> {} + Part of the code: + `intersectFVs` tc_names + Reason: + makes the NameSet smaller, so there are fewer subsequent lookups + in `graphFromEdgedVertices` (GHC.Data.Graph.Directed) + and in `isReadyTyClGroup` (GHC.Tc.TyCl) + +* Self-references are removed: + {A,B,C} ==> {C}, iff in the TyClGroup that defines {A,B} + Part of the code: + delFVs node_bndrs + Reason: + avoids the problem that `isReadyTyClGroup` would otherwise consider + a recursive TyClGroup to be blocked on itself + Note: + needs to happen after the SCC analysis because of + mutually-recursive data types + +These "prepared" FVs are the lexical dependencies of a TyClGroup that are stored +in the XCTyClGroup extension field: + + type family F (a :: k) -- XCTyClGroup: {} + data X = MkX Char (Maybe X) -- XCTyClGroup: {} + data Y = MkY X (Maybe Y) -- XCTyClGroup: {X} + type instance F MkX = X -- XCTyClGroup: {F, X} + type instance F MkY = Int -- XCTyClGroup: {F, Y} + +Before attempting to kind-check a TyClGroup, all of its lexical dependencies +need to be satisfied, i.e. there must be a TyThing in the TypeEnv for each of +these names. + +Imported names {Char,Maybe} don't need to be explicitly included in the set of +lexical dependencies because `isReadyTyClGroup` can safely assume those are +definitely already in the env. +-} + + +{- ****************************************************** +* * + Role annotations +* * +****************************************************** -} + +-- | Renames role annotations, returning them as the values in a NameEnv +-- and checks for duplicate role annotations. +-- It is quite convenient to do both of these in the same place. +-- See also Note [Role annotations in the renamer] +rnRoleAnnots :: NameSet + -> [LRoleAnnotDecl GhcPs] + -> RnM [LRoleAnnotDecl GhcRn] +rnRoleAnnots tc_names role_annots + = do { -- Check for duplicates *before* renaming, to avoid + -- lumping together all the unboundNames + let (no_dups, dup_annots) = removeDupsOn get_name role_annots + get_name = roleAnnotDeclName . unLoc + ; mapM_ dupRoleAnnotErr dup_annots + ; mapM (wrapLocMA rn_role_annot1) no_dups } + where + rn_role_annot1 (RoleAnnotDecl _ tycon roles) + = do { -- the name is an *occurrence*, but look it up only in the + -- decls defined in this group (see #10263) + tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) + SigLikeRoleAnnotation + tycon + ; return $ RoleAnnotDecl noExtField tycon' roles } + +dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () +dupRoleAnnotErr list@(L loc _ :| _) + = addErrAt (locA loc) (TcRnDuplicateRoleAnnot list) + +dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () +dupKindSig_Err list@(L loc _ :| _) + = addErrAt (locA loc) (TcRnDuplicateKindSig list) + +{- Note [Role annotations in the renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must ensure that a type's role annotation is put in the same group as the +proper type declaration. This is because role annotations are needed during +type-checking when creating the type's TyCon. So, rnRoleAnnots builds a +NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that +type, if any. Then, this map can be used to add the role annotations to the +groups after dependency analysis. + +This process checks for duplicate role annotations, where we must be careful +to do the check *before* renaming to avoid calling all unbound names duplicates +of one another. + +The renaming process, as usual, might identify and report errors for unbound +names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using +lookupGlobalOccRn led to #8485). +-} + + +{- ****************************************************** +* * + Dependency info for instances +* * +****************************************************** -} + +---------------------------------------------------------- +-- | Construct a @TyClGroup@ for each @InstDecl@. +-- Step (TCDEP6) of Note [Dependency analysis of type and class decls] +mkInstGroups :: GlobalRdrEnv + -> NameSet + -> [(LInstDecl GhcRn, FreeVars)] + -> [TyClGroup GhcRn] +mkInstGroups rdr_env tc_names inst_ds_fvs + = [ mk_inst_group deps inst_decl + | (inst_decl, inst_fvs) <- inst_ds_fvs + , let deps = toParents rdr_env inst_fvs `intersectFVs` tc_names ] + -- (toParents rdr_env) maps datacons to parent tycons, + -- (`intersectFVs` tc_names) filters out imported names. + -- See Note [Prepare TyClGroup FVs] + where + mk_inst_group :: NameSet -> LInstDecl GhcRn -> TyClGroup GhcRn + mk_inst_group deps inst_d = + TyClGroup { group_ext = deps + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [] + , group_instds = [inst_d] } + +{- ****************************************************** +* * + Renaming a type or class declaration +* * +****************************************************** -} + +rnTyClDecl :: TyClDecl GhcPs + -> RnM (TyClDecl GhcRn, FreeVars) + +-- All flavours of top-level type family declarations ("type family", "newtype +-- family", and "data family") +rnTyClDecl (FamDecl { tcdFam = fam }) + = do { (fam', fvs) <- rnFamDecl Nothing fam + ; return (FamDecl noExtField fam', fvs) } + +rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, tcdRhs = rhs }) + = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon + ; let kvs = extractHsTyRdrTyVarsKindVars rhs + doc = TySynCtx tycon + ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) + ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' free_rhs_kvs -> + do { mapM_ warn_implicit_kvs (nubL free_rhs_kvs) + ; (rhs', fvs) <- rnTySyn doc rhs + ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' + , tcdFixity = fixity + , tcdRhs = rhs', tcdSExt = fvs }, fvs) } } + where + warn_implicit_kvs :: LocatedN RdrName -> RnM () + warn_implicit_kvs kv = + addDiagnosticAt (getLocA kv) (TcRnImplicitRhsQuantification kv) + +-- "data", "newtype" declarations +rnTyClDecl (DataDecl + { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn@HsDataDefn{ dd_cons = cons, dd_kindSig = kind_sig} }) + = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon + ; let kvs = extractDataDefnKindVars defn + doc = TyDataCtx tycon + new_or_data = dataDefnConsNewOrData cons + ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) + ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' free_rhs_kvs -> + do { (defn', fvs) <- rnDataDefn doc defn + ; cusk <- data_decl_has_cusk tyvars' new_or_data (null free_rhs_kvs) kind_sig + ; let rn_info = DataDeclRn { tcdDataCusk = cusk + , tcdFVs = fvs } + ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr free_rhs_kvs) + ; return (DataDecl { tcdLName = tycon' + , tcdTyVars = tyvars' + , tcdFixity = fixity + , tcdDataDefn = defn' + , tcdDExt = rn_info }, fvs) } } + +rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, + tcdTyVars = tyvars, tcdFixity = fixity, + tcdFDs = fds, tcdSigs = sigs, + tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = docs}) + = do { lcls' <- lookupLocatedTopBndrRnN WL_TyCon lcls + ; let cls' = unLoc lcls' + kvs = [] -- No scoped kind vars except those in + -- kind signatures on the tyvars + + -- Tyvars scope over superclass context and method signatures + ; ((tyvars', context', fds', ats'), stuff_fvs) + <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' _ -> do + -- Checks for distinct tyvars + { (context', cxt_fvs) <- rnMaybeContext cls_doc context + ; fds' <- rnFds fds + -- The fundeps have no free variables + ; (ats', fv_ats) <- rnATDecls cls' (hsAllLTyVarNames tyvars') ats + ; let fvs = cxt_fvs `plusFV` + fv_ats + ; return ((tyvars', context', fds', ats'), fvs) } + + ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs + + -- No need to check for duplicate associated type decls + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + + -- Check the signatures + -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). + ; let sig_rdr_names_w_locs = + [op | L _ (ClassOpSig _ False ops _) <- sigs + , op <- ops] + ; checkDupRdrNames sig_rdr_names_w_locs + -- Typechecker is responsible for checking that we only + -- give default-method bindings for things in this class. + -- The renamer *could* check this for class decls, but can't + -- for instance decls. + + -- The newLocals call is tiresome: given a generic class decl + -- class C a where + -- op :: a -> a + -- op {| x+y |} (Inl a) = ... + -- op {| x+y |} (Inr b) = ... + -- op {| a*b |} (a*b) = ... + -- we want to name both "x" tyvars with the same unique, so that they are + -- easy to group together in the typechecker. + ; (mbinds', sigs', meth_fvs) + <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs + -- No need to check for duplicate method signatures + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + -- and the methods are already in scope + + ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs + ; docs' <- traverse rnLDocDecl docs + ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', + tcdTyVars = tyvars', tcdFixity = fixity, + tcdFDs = fds', tcdSigs = sigs', + tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', + tcdDocs = docs', tcdCExt = all_fvs }, + all_fvs ) } + where + cls_doc = ClassDeclCtx lcls + +-- Does the data type declaration include a CUSK? +data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool +data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do + { -- See Note [Unlifted Newtypes and CUSKs], and for a broader + -- picture, see Note [Implementation of UnliftedNewtypes]. + ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; let non_cusk_newtype + | NewType <- new_or_data = + unlifted_newtypes && isNothing kind_sig + | otherwise = False + -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls + ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype + } + +{- Note [Unlifted Newtypes and CUSKs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When unlifted newtypes are enabled, a newtype must have a kind signature +in order to be considered have a CUSK. This is because the flow of +kind inference works differently. Consider: + + newtype Foo = FooC Int + +When UnliftedNewtypes is disabled, we decide that Foo has kind +`TYPE 'LiftedRep` without looking inside the data constructor. So, we +can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled, +we fill in the kind of Foo as a metavar that gets solved by unification +with the kind of the field inside FooC (that is, Int, whose kind is +`TYPE 'LiftedRep`). But since we have to look inside the data constructors +to figure out the kind signature of Foo, it does not have a CUSK. + +See Note [Implementation of UnliftedNewtypes] for where this fits in to +the broader picture of UnliftedNewtypes. +-} + +-- "type" and "type instance" declarations +rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnTySyn doc rhs = rnLHsType doc rhs + +rnDataDefn :: HsDocContext -> HsDataDefn GhcPs + -> RnM (HsDataDefn GhcRn, FreeVars) +rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = condecls + , dd_kindSig = m_sig, dd_derivs = derivs }) + = do { -- DatatypeContexts (i.e., stupid contexts) can't be combined with + -- GADT syntax. See Note [The stupid context] in GHC.Core.DataCon. + checkTc (h98_style || null (fromMaybeContext context)) + (TcRnStupidThetaInGadt doc) + + -- Check restrictions on "type data" declarations. + -- See Note [Type data declarations]. + ; when (isTypeDataDefnCons condecls) check_type_data + + ; (m_sig', sig_fvs) <- case m_sig of + Just sig -> first Just <$> rnLHsKind doc sig + Nothing -> return (Nothing, emptyFVs) + ; (context', fvs1) <- rnMaybeContext doc context + ; (derivs', fvs3) <- rn_derivs derivs + + -- For the constructor declarations, drop the LocalRdrEnv + -- in the GADT case, where the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; let { zap_lcl_env | h98_style = \ thing -> thing + | otherwise = setLocalRdrEnv emptyLocalRdrEnv } + ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls + -- No need to check for duplicate constructor decls + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + + ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` + con_fvs `plusFV` sig_fvs + ; return ( HsDataDefn { dd_ext = noAnn, dd_cType = cType + , dd_ctxt = context', dd_kindSig = m_sig' + , dd_cons = condecls' + , dd_derivs = derivs' } + , all_fvs ) + } + where + h98_style = not $ anyLConIsGadt condecls -- Note [Stupid theta] + + rn_derivs ds + = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies + ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) + TcRnIllegalMultipleDerivClauses + ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds + ; return (ds', fvs) } + + -- Given a "type data" declaration, check that the TypeData extension + -- is enabled and check restrictions (R1), (R2), (R3) and (R5) + -- on the declaration. See Note [Type data declarations]. + check_type_data + = do { unlessXOptM LangExt.TypeData $ failWith TcRnIllegalTypeData + ; unless (null (fromMaybeContext context)) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsDatatypeContexts + ; mapM_ (addLocM check_type_data_condecl) condecls + ; unless (null derivs) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsDerivingClauses + } + + -- Check restrictions (R2) and (R3) on a "type data" constructor. + -- See Note [Type data declarations]. + check_type_data_condecl :: ConDecl GhcPs -> RnM () + check_type_data_condecl condecl + = do { + ; when (has_labelled_fields condecl) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsLabelledFields + ; when (has_strictness_flags condecl) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsStrictnessAnnotations + } + + has_labelled_fields (ConDeclGADT { con_g_args = RecConGADT _ _ }) = True + has_labelled_fields (ConDeclH98 { con_args = RecCon flds }) + = not (null (unLoc flds)) + has_labelled_fields _ = False + + has_strictness_flags condecl + = any isSrcStrict (con_arg_bangs condecl) + + con_arg_bangs (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = map cdf_bang args + con_arg_bangs (ConDeclH98 { con_args = PrefixCon args }) = map cdf_bang args + con_arg_bangs (ConDeclH98 { con_args = InfixCon arg1 arg2 }) = [cdf_bang arg1, cdf_bang arg2] + con_arg_bangs _ = [] + +{- +Note [Type data declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With the TypeData extension (GHC proposal #106), one can write `type data` +declarations, like + + type data Nat = Zero | Succ Nat + +or equivalently in GADT style: + + type data Nat where + Zero :: Nat + Succ :: Nat -> Nat + +This defines the constructors `Zero` and `Succ` in the TcCls namespace +(type constructors and classes) instead of the Data namespace (data +constructors). This contrasts with the DataKinds extension, which +allows constructors defined in the Data namespace to be promoted to the +TcCls namespace at the point of use in a type. + +Type data declarations have the syntax of `data` declarations (but not +`newtype` declarations), either ordinary algebraic data types or GADTs, +preceded by `type`, with the following restrictions: + +(R0) 'data' decls only, not 'newtype' decls. This is checked by + the parser. + +(R1) There are no data type contexts (even with the DatatypeContexts + extension). + +(R2) There are no labelled fields. Perhaps these could be supported + using type families, but they are omitted for now. + +(R3) There are no strictness flags, because they don't make sense at + the type level. + +(R4) The types of the constructors contain no constraints. + +(R5) There are no deriving clauses. + +The data constructors of a `type data` declaration obey the following +Core invariant: + +(I1) The data constructors of a `type data` declaration may be mentioned in + /types/, but never in /terms/ or the /pattern of a case alternative/. + +Wrinkles: + +(W0) Wrappers. The data constructor of a `type data` declaration has a worker + (like every data constructor) but does /not/ have a wrapper. Wrappers + only make sense for value-level data constructors. Indeed, the worker Id + is never used (invariant (I1)), so it barely makes sense to talk about + the worker. A `type data` constructor only shows up in types, where it + appears as a TyCon, specifically a PromotedDataCon -- no Id in sight. + See #24620 for an example of what happens if you accidentally include + a wrapper. + + See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where + this check is implemented. + + This specifically includes `type data` declarations implemented as GADTs, + such as this example from #22948: + + type data T a where + A :: T Int + B :: T a + + If `T` were an ordinary `data` declaration, then `A` would have a wrapper + to account for the GADT-like equality in its return type. Because `T` is + declared as a `type data` declaration, however, the wrapper is omitted. + +(W1) To prevent users from conjuring up `type data` values at the term level, + we disallow using the tagToEnum# function on a type headed by a `type + data` type. For instance, GHC will reject this code: + + type data Letter = A | B | C + + f :: Letter + f = tagToEnum# 0# + + See `GHC.Tc.Gen.App.checkTagToEnum`, specifically `check_enumeration`. + +(W2) Although `type data` data constructors do not exist at the value level, + it is still possible to match on a value whose type is headed by a `type data` + type constructor, such as this example from #22964: + + type data T a where + A :: T Int + B :: T a + + f :: T a -> () + f x = case x of {} + + And yet we must guarantee invariant (I1). This has three consequences: + + (W2a) During checking the coverage of `f`'s pattern matches, we treat `T` + as if it were an empty data type so that GHC does not warn the user + to match against `A` or `B`. (Otherwise, you end up with the bug + reported in #22964.) See GHC.HsToCore.Pmc.Solver.vanillaCompleteMatchTC. + + (W2b) In `GHC.Core.Utils.refineDataAlt`, do /not/ fill in the DEFAULT case + with the data constructor, else (I1) is violated. See GHC.Core.Utils + Note [Refine DEFAULT case alternatives] Exception 2 + + (W2c) In `GHC.Core.Opt.ConstantFold.caseRules`, we do not want to transform + case dataToTagLarge# x of t -> blah + into + case x of { A -> ...; B -> .. } + because again that conjures up the type-level-only data constructors + `A` and `B` in a pattern, violating (I1) (#23023). + So we check for "type data" TyCons before applying this + transformation. (In practice, this doesn't matter because + we also refuse to solve DataToTag instances at types + corresponding to type data declarations. See rule C1 from + Note [DataToTag overview] in GHC.Tc.Instance.Class.) + +The main parts of the implementation are: + +* The parser recognizes `type data` (but not `type newtype`); this ensures (R0). + +* During the initial construction of the AST, + GHC.Parser.PostProcess.checkNewOrData sets the `Bool` argument of the + `DataTypeCons` inside a `HsDataDefn` to mark a `type data` declaration. + It also puts the the constructor names (`Zero` and `Succ` in our + example) in the TcCls namespace. + +* GHC.Rename.Module.rnDataDefn calls `check_type_data` on these + declarations, which checks that the TypeData extension is enabled and + checks restrictions (R1), (R2), (R3) and (R5). They could equally + well be checked in the typechecker, but we err on the side of catching + imposters early. + +* GHC.Tc.TyCl.checkValidDataCon checks restriction (R4) on these declarations. + +* When beginning to type check a mutually recursive group of declarations, + the `type data` constructors (`Zero` and `Succ` in our example) are + added to the type-checker environment as `APromotionErr TyConPE` by + GHC.Tc.TyCl.mkPromotionErrorEnv, so they cannot be used within the + recursive group. This mirrors the DataKinds behaviour described + at Note [Recursion and promoting data constructors] in GHC.Tc.TyCl. + For example, this is rejected: + + type data T f = K (f (K Int)) -- illegal: tycon K is recursively defined + +* The `type data` data type, such as `Nat` in our example, is represented + by a `TyCon` that is an `AlgTyCon`, but its `AlgTyConRhs` has the + `is_type_data` field set. + +* The constructors of the data type, `Zero` and `Succ` in our example, + are each represented by a `DataCon` as usual. That `DataCon`'s + `dcPromotedField` is a `TyCon` (for `Zero`, say) that you can use + in a type. + +* After a `type data` declaration has been type-checked, the + type-checker environment entry (a `TyThing`) for each constructor + (`Zero` and `Succ` in our example) is + - just an `ATyCon` for the promoted type constructor, + - not the bundle (`ADataCon` for the data con, `AnId` for the work id, + wrap id) required for a normal data constructor + See GHC.Types.TyThing.implicitTyConThings. + +* GHC.Core.TyCon.isDataKindsPromotedDataCon ignores promoted constructors + from `type data`, which do not use the distinguishing quote mark added + to constructors promoted by DataKinds. + +* GHC.Core.TyCon.isBoxedDataTyCon ignores types coming from a `type data` + declaration (by checking the `is_type_data` field), so that these do + not contribute executable code such as constructor wrappers. + +* The `is_type_data` field is copied into a Boolean argument + of the `IfDataTyCon` constructor of `IfaceConDecls` by + GHC.Iface.Make.tyConToIfaceDecl. + +* The Template Haskell `Dec` type has an constructor `TypeDataD` for + `type data` declarations. When these are converted back to Hs types + in a splice, the constructors are placed in the TcCls namespace. + +-} + +rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs + -> RnM (LHsDerivingClause GhcRn, FreeVars) +rnLHsDerivingClause doc + (L loc (HsDerivingClause + { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs + , deriv_clause_tys = dct })) + = do { (dcs', dct', fvs) + <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct + ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs' + , deriv_clause_tys = dct' }) + , fvs ) } + where + rn_deriv_clause_tys :: LDerivClauseTys GhcPs + -> RnM (LDerivClauseTys GhcRn, FreeVars) + rn_deriv_clause_tys (L l dct) = case dct of + DctSingle x ty -> do + (ty', fvs) <- rn_clause_pred ty + pure (L l (DctSingle x ty'), fvs) + DctMulti x tys -> do + (tys', fvs) <- mapFvRn rn_clause_pred tys + pure (L l (DctMulti x tys'), fvs) + + rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) + rn_clause_pred pred_ty = do + checkInferredVars doc pred_ty + ret@(pred_ty', _) <- rnHsSigType doc TypeLevel pred_ty + -- Check if there are any nested `forall`s, which are illegal in a + -- `deriving` clause. + -- See Note [No nested foralls or contexts in instance types] + -- (Wrinkle: Derived instances) in GHC.Hs.Type. + addNoNestedForallsContextsErr doc NFC_DerivedClassType + (getLHsInstDeclHead pred_ty') + pure ret + +rnLDerivStrategy :: forall a. + HsDocContext + -> Maybe (LDerivStrategy GhcPs) + -> RnM (a, FreeVars) + -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) +rnLDerivStrategy doc mds thing_inside + = case mds of + Nothing -> boring_case Nothing + Just (L loc ds) -> + setSrcSpanA loc $ do + (ds', thing, fvs) <- rn_deriv_strat ds + pure (Just (L loc ds'), thing, fvs) + where + rn_deriv_strat :: DerivStrategy GhcPs + -> RnM (DerivStrategy GhcRn, a, FreeVars) + rn_deriv_strat ds = do + let extNeeded :: LangExt.Extension + extNeeded + | ViaStrategy{} <- ds + = LangExt.DerivingVia + | otherwise + = LangExt.DerivingStrategies + + unlessXOptM extNeeded $ + failWith $ TcRnIllegalDerivStrategy ds + + case ds of + StockStrategy _ -> boring_case (StockStrategy noExtField) + AnyclassStrategy _ -> boring_case (AnyclassStrategy noExtField) + NewtypeStrategy _ -> boring_case (NewtypeStrategy noExtField) + ViaStrategy (XViaStrategyPs _ via_ty) -> + do checkInferredVars doc via_ty + (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty + let HsSig { sig_bndrs = via_outer_bndrs + , sig_body = via_body } = unLoc via_ty' + via_tvs = hsOuterTyVarNames via_outer_bndrs + -- Check if there are any nested `forall`s, which are illegal in a + -- `via` type. + -- See Note [No nested foralls or contexts in instance types] + -- (Wrinkle: Derived instances) in GHC.Hs.Type. + addNoNestedForallsContextsErr doc + NFC_ViaType via_body + (thing, fvs2) <- bindLocalNamesFV via_tvs thing_inside + pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) + + boring_case :: ds -> RnM (ds, a, FreeVars) + boring_case ds = do + (thing, fvs) <- thing_inside + pure (ds, thing, fvs) + +rnFamDecl :: Maybe (Name, [Name]) + -- Just (cls, cls_tvs) => this FamilyDecl is nested + -- inside an *class decl* for cls + -- used for associated types + -> FamilyDecl GhcPs + -> RnM (FamilyDecl GhcRn, FreeVars) +rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars + , fdTopLevel = toplevel + , fdFixity = fixity + , fdInfo = info, fdResultSig = res_sig + , fdInjectivityAnn = injectivity }) + = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon + ; ((tyvars', res_sig', injectivity'), fv1) <- + bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ -> + do { let rn_sig = rnFamResultSig doc + ; (res_sig', fv_kind) <- wrapLocFstMA rn_sig res_sig + ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') + injectivity + ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } + ; (info', fv2) <- rn_info info + ; return (FamilyDecl { fdExt = noAnn + , fdLName = tycon', fdTyVars = tyvars' + , fdTopLevel = toplevel + , fdFixity = fixity + , fdInfo = info', fdResultSig = res_sig' + , fdInjectivityAnn = injectivity' } + , fv1 `plusFV` fv2) } + where + doc = TyFamilyCtx tycon + kvs = extractRdrKindSigVars res_sig + + ---------------------- + rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) + rn_info (ClosedTypeFamily (Just eqns)) + = do { (eqns', fvs) + <- rnList (rnTyFamInstEqn (NonAssocTyFamEqn ClosedTyFam)) eqns + -- no class context + ; return (ClosedTypeFamily (Just eqns'), fvs) } + rn_info (ClosedTypeFamily Nothing) + = return (ClosedTypeFamily Nothing, emptyFVs) + rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) + rn_info DataFamily = return (DataFamily, emptyFVs) + +rnFamResultSig :: HsDocContext + -> FamilyResultSig GhcPs + -> RnM (FamilyResultSig GhcRn, FreeVars) +rnFamResultSig _ (NoSig _) + = return (NoSig noExtField, emptyFVs) +rnFamResultSig doc (KindSig _ kind) + = do { (rndKind, ftvs) <- rnLHsKind doc kind + ; return (KindSig noExtField rndKind, ftvs) } +rnFamResultSig doc (TyVarSig _ tvbndr) + = do { -- `TyVarSig` tells us that user named the result of a type family by + -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to + -- be sure that the supplied result name is not identical to an + -- already in-scope type variable from an enclosing class. + -- + -- Example of disallowed declaration: + -- class C a b where + -- type F b = a | a -> b + rdr_env <- getLocalRdrEnv + + ; case hsBndrVar (unLoc tvbndr) of + HsBndrWildCard _ -> + -- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type + addErrAt (getLocA tvbndr) $ + TcRnIllegalWildcardInType Nothing WildcardBndrInTyFamResultVar + HsBndrVar _ (L _ resName) -> + when (resName `elemLocalRdrEnv` rdr_env) $ + addErrAt (getLocA tvbndr) $ + TcRnShadowedTyVarNameInFamResult resName + + ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for + -- scoping checks that are irrelevant here + tvbndr $ \ tvbndr' -> + return (TyVarSig noExtField tvbndr', maybe emptyFVs unitFV (hsLTyVarName tvbndr')) } + +-- Note [Renaming injectivity annotation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- During renaming of injectivity annotation we have to make several checks to +-- make sure that it is well-formed. At the moment injectivity annotation +-- consists of a single injectivity condition, so the terms "injectivity +-- annotation" and "injectivity condition" might be used interchangeably. See +-- Note [Injectivity annotation] for a detailed discussion of currently allowed +-- injectivity annotations. +-- +-- Checking LHS is simple because the only type variable allowed on the LHS of +-- injectivity condition is the variable naming the result in type family head. +-- Example of disallowed annotation: +-- +-- type family Foo a b = r | b -> a +-- +-- Verifying RHS of injectivity consists of checking that: +-- +-- 1. only variables defined in type family head appear on the RHS (kind +-- variables are also allowed). Example of disallowed annotation: +-- +-- type family Foo a = r | r -> b +-- +-- 2. for associated types the result variable does not shadow any of type +-- class variables. Example of disallowed annotation: +-- +-- class Foo a b where +-- type F a = b | b -> a +-- +-- Breaking any of these assumptions results in an error. + +-- | Rename injectivity annotation. Note that injectivity annotation is just the +-- part after the "|". Everything that appears before it is renamed in +-- rnFamDecl. +rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in + -- type family head + -> LFamilyResultSig GhcRn -- ^ Result signature + -> LInjectivityAnn GhcPs -- ^ Injectivity annotation + -> RnM (LInjectivityAnn GhcRn) +rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) + (L srcSpan (InjectivityAnn x injFrom injTo)) + = do + { (injDecl'@(L _ (InjectivityAnn _ injFrom' injTo')), noRnErrors) + <- askNoErrs $ + bindLocalNames (maybeToList (hsLTyVarName resTv)) $ + -- The return type variable scopes over the injectivity annotation + -- e.g. type family F a = (r::*) | r -> a + do { injFrom' <- rnLTyVar injFrom + ; injTo' <- mapM rnLTyVar injTo + -- Note: srcSpan is unchanged, but typechecker gets + -- confused, l2l call makes it happy + ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') } + + ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs + + ; case hsLTyVarName resTv of { Nothing -> return () + ; Just resName -> do { + + ; let -- See Note [Renaming injectivity annotation] + lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) + rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames + + -- if renaming of type variables ended with errors (eg. there were + -- not-in-scope variables) don't check the validity of injectivity + -- annotation. This gives better error messages. + ; when (noRnErrors && not lhsValid) $ + addErrAt (getLocA injFrom) $ + TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom + + ; when (noRnErrors && not (Set.null rhsValid)) $ + do { let errorVars = Set.toList rhsValid + ; addErrAt (locA srcSpan) $ + TcRnUnknownTyVarsOnRhsOfInjCond errorVars } } } + + ; return injDecl' } + +-- We can only hit this case when the user writes injectivity annotation without +-- naming the result: +-- +-- type family F a | result -> a +-- type family F a :: * | result -> a +-- +-- So we rename injectivity annotation like we normally would except that +-- this time we expect "result" to be reported not in scope by rnLTyVar. +rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) = + setSrcSpanA srcSpan $ do + (injDecl', _) <- askNoErrs $ do + injFrom' <- rnLTyVar injFrom + injTo' <- mapM rnLTyVar injTo + return $ L srcSpan (InjectivityAnn x injFrom' injTo') + return $ injDecl' + +{- +Note [Stupid theta] +~~~~~~~~~~~~~~~~~~~ +#3850 complains about a regression wrt 6.10 for + data Show a => T a +There is no reason not to allow the stupid theta if there are no data +constructors. It's still stupid, but does no harm, and I don't want +to cause programs to break unnecessarily (notably HList). So if there +are no data constructors we allow h98_style = True +-} + + +{- ***************************************************** +* * + Support code for type/data declarations +* * +***************************************************** -} + +----------------- +rnConDecls :: DataDefnCons (LConDecl GhcPs) -> RnM (DataDefnCons (LConDecl GhcRn), FreeVars) +rnConDecls = mapFvRn (wrapLocFstMA rnConDecl) + +rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) +rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt, con_args = args + , con_doc = mb_doc, con_forall = forall_ }) + = do { _ <- addLocM checkConName name + ; new_name <- lookupLocatedTopBndrRnN WL_ConLike name + + -- We bind no implicit binders here; this is just like + -- a nested HsForAllTy. E.g. consider + -- data T a = forall (b::k). MkT (...) + -- The 'k' will already be in scope from the bindHsQTyVars + -- for the data decl itself. So we'll get + -- data T {k} a = ... + -- And indeed we may later discover (a::k). But that's the + -- scoping we get. So no implicit binders at the existential forall + + ; let ctxt = ConDeclCtx [new_name] + ; bindLHsTyVarBndrs ctxt WarnUnusedForalls + Nothing ex_tvs $ \ new_ex_tvs -> + do { (new_context, fvs1) <- rnMbContext ctxt mcxt + ; (new_args, fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args + ; let all_fvs = fvs1 `plusFV` fvs2 + ; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat + [ text "ex_tvs:" <+> ppr ex_tvs + , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) + + ; mb_doc' <- traverse rnLHsDoc mb_doc + ; return (decl { con_ext = noExtField + , con_name = new_name, con_ex_tvs = new_ex_tvs + , con_mb_cxt = new_context, con_args = new_args + , con_doc = mb_doc' + , con_forall = forall_ }, -- Remove when #18311 is fixed + all_fvs) }} + +rnConDecl (ConDeclGADT { con_names = names + , con_outer_bndrs = L outer_bndrs_loc outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = mcxt + , con_g_args = args + , con_res_ty = res_ty + , con_doc = mb_doc }) + = do { mapM_ (addLocM checkConName) names + ; new_names <- mapM (lookupLocatedTopBndrRnN WL_ConLike) names + + ; let -- We must ensure that we extract the free tkvs in left-to-right + -- order of their appearance in the constructor type. + -- That order governs the order the implicitly-quantified type + -- variable, and hence the order needed for visible type application + -- See #14808. + implicit_bndrs = + extractHsOuterTvBndrs outer_bndrs $ + extractHsForAllTelescopes inner_bndrs $ + extractHsTysRdrTyVars (hsConDeclTheta mcxt) $ + extractConDeclGADTDetailsTyVars args $ + extractHsTysRdrTyVars [res_ty] [] + + ; let ctxt = ConDeclCtx (toList new_names) + + ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' -> + bindHsForAllTelescopes ctxt inner_bndrs $ \inner_bndrs' -> + do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt + ; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args + ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty + + -- Ensure that there are no nested `forall`s or contexts, per + -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts) + -- in GHC.Hs.Type. + ; addNoNestedForallsContextsErr ctxt + NFC_GadtConSig new_res_ty + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + + ; traceRn "rnConDecl (ConDeclGADT)" + (ppr names $$ ppr outer_bndrs' $$ ppr inner_bndrs') + ; new_mb_doc <- traverse rnLHsDoc mb_doc + ; return (ConDeclGADT { con_g_ext = noExtField, con_names = new_names + , con_outer_bndrs = L outer_bndrs_loc outer_bndrs' + , con_inner_bndrs = inner_bndrs' + , con_mb_cxt = new_cxt + , con_g_args = new_args, con_res_ty = new_res_ty + , con_doc = new_mb_doc }, + all_fvs) } } + +rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) + -> RnM (Maybe (LHsContext GhcRn), FreeVars) +rnMbContext _ Nothing = return (Nothing, emptyFVs) +rnMbContext doc cxt = do { (ctx',fvs) <- rnMaybeContext doc cxt + ; return (ctx',fvs) } + +rnConDeclH98Details :: + Name + -> HsDocContext + -> HsConDeclH98Details GhcPs + -> RnM (HsConDeclH98Details GhcRn, FreeVars) +rnConDeclH98Details _ doc (PrefixCon tys) + = do { (new_tys, fvs) <- mapFvRn (rnHsConDeclField doc) tys + ; return (PrefixCon new_tys, fvs) } +rnConDeclH98Details _ doc (InfixCon ty1 ty2) + = do { (new_ty1, fvs1) <- rnHsConDeclField doc ty1 + ; (new_ty2, fvs2) <- rnHsConDeclField doc ty2 + ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } +rnConDeclH98Details con doc (RecCon flds) + = do { (new_flds, fvs) <- rnRecHsConDeclRecFields con doc flds + ; return (RecCon new_flds, fvs) } + +rnConDeclGADTDetails :: + Name + -> HsDocContext + -> HsConDeclGADTDetails GhcPs + -> RnM (HsConDeclGADTDetails GhcRn, FreeVars) +rnConDeclGADTDetails _ doc (PrefixConGADT _ tys) + = do { (new_tys, fvs) <- mapFvRn (rnHsConDeclField doc) tys + ; return (PrefixConGADT noExtField new_tys, fvs) } +rnConDeclGADTDetails con doc (RecConGADT _ flds) + = do { (new_flds, fvs) <- rnRecHsConDeclRecFields con doc flds + ; return (RecConGADT noExtField new_flds, fvs) } + +rnRecHsConDeclRecFields :: + Name + -> HsDocContext + -> LocatedL [LHsConDeclRecField GhcPs] + -> RnM (LocatedL [LHsConDeclRecField GhcRn], FreeVars) +rnRecHsConDeclRecFields con doc (L l fields) + = do { fls <- lookupConstructorFields (noUserRdr con) + ; (new_fields, fvs) <- rnHsConDeclRecFields doc fls fields + -- No need to check for duplicate fields + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + ; pure (L l new_fields, fvs) } + +------------------------------------------------- + +-- | Brings pattern synonym names and also pattern synonym selectors +-- from record pattern synonyms into scope. +extendPatSynEnv :: DuplicateRecordFields -> FieldSelectors -> HsValBinds GhcPs -> MiniFixityEnv + -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a +extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { + names_with_fls <- new_ps val_decls + ; let pat_syn_bndrs = concat [ conLikeName_Name name : map flSelector flds + | (name, con_info) <- names_with_fls + , let flds = conInfoFields con_info ] + ; let gres = map (mkLocalConLikeGRE NoParent) names_with_fls + ++ mkLocalFieldGREs NoParent names_with_fls + -- Recall Note [Parents] in GHC.Types.Name.Reader: + -- + -- pattern synonym constructors and their record fields have no parent + -- in the module in which they are defined. + ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn gres local_fix_env + ; restoreEnvs (gbl_env, lcl_env) (thing pat_syn_bndrs) } + where + + new_ps :: HsValBinds GhcPs -> TcM [(ConLikeName, ConInfo)] + new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds + new_ps _ = panic "new_ps" + + new_ps' :: LHsBindLR GhcPs GhcPs + -> [(ConLikeName, ConInfo)] + -> TcM [(ConLikeName, ConInfo)] + new_ps' bind names + | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n + , psb_args = RecCon as }))) <- bind + = do + bnd_name <- newTopSrcBinder (L (l2l bind_loc) n) + let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as + flds <- mapM (newRecordFieldLabel dup_fields_ok has_sel [bnd_name]) field_occs + let con_info = mkConInfo ConIsPatSyn (conDetailsVisArity (RecCon as)) flds + return ((PatSynName bnd_name, con_info) : names) + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n, psb_args = as })) <- bind + = do + bnd_name <- newTopSrcBinder (L (l2l bind_loc) n) + let con_info = mkConInfo ConIsPatSyn (conDetailsVisArity as) [] + return ((PatSynName bnd_name, con_info) : names) + | otherwise + = return names + +conDetailsVisArity :: HsPatSynDetails (GhcPass p) -> VisArity +conDetailsVisArity = \case + PrefixCon args -> length args + RecCon flds -> length flds + InfixCon _ _ -> 2 + +{- +********************************************************* +* * +\subsection{Support code to rename types} +* * +********************************************************* +-} + +rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn] +rnFds fds + = mapM (wrapLocMA rn_fds) fds + where + rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn) + rn_fds (FunDep x tys1 tys2) + = do { tys1' <- rnHsTyVars tys1 + ; tys2' <- rnHsTyVars tys2 + ; return (FunDep x tys1' tys2') } + +rnHsTyVars :: [LocatedN RdrName] -> RnM [LocatedN Name] +rnHsTyVars tvs = mapM rnHsTyVar tvs + +rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name) +rnHsTyVar (L l tyvar) = do + tyvar' <- lookupOccRn WL_TyVar tyvar + return (L l tyvar') + +{- +********************************************************* +* * + findSplice +* * +********************************************************* + +This code marches down the declarations, looking for the first +Template Haskell splice. As it does so it + a) groups the declarations into a HsGroup + b) runs any top-level quasi-quotes +-} + +findSplice :: [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) +findSplice ds = addl emptyRdrGroup ds + +addl :: HsGroup GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) +-- This stuff reverses the declarations (again) but it doesn't matter +addl gp [] = return (gp, Nothing) +addl gp (L l d : ds) = add gp l d ds + + +add :: HsGroup GhcPs -> SrcSpanAnnA -> HsDecl GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) + +-- #10047: Declaration QuasiQuoters are expanded immediately, without +-- causing a group split +add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds + = do { (ds', _) <- rnTopSpliceDecls qq + ; addl gp (ds' ++ ds) + } + +add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds + = do { -- We've found a top-level splice. If it is an *implicit* one + -- (i.e. a naked top level expression), throw an error if + -- TemplateHaskell is not enabled. + case flag of + DollarSplice -> return () + BareSplice -> do { unlessXOptM LangExt.TemplateHaskell + $ setSrcSpan (locA loc) + $ failWith badImplicitSplice } + + ; return (gp, Just (splice, ds)) } + where + badImplicitSplice :: TcRnMessage + badImplicitSplice = TcRnTHError (THSyntaxError BadImplicitSplice) + +-- Class declarations: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds + = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds + +-- Signatures: fixity sigs go a different place than all others +add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds + = addl (gp {hs_fixds = L l f : ts}) ds + +-- Standalone kind signatures: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds + = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds + +add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds + +-- Value declarations: use add_bind +add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds + +-- Role annotations: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds + = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds + +-- NB instance declarations go into TyClGroups. We throw them into the first +-- group, just as we do for the TyClD case. The renamer will go on to group +-- and order them later. +add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds + = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds + +-- The rest are routine +add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds + = addl (gp { hs_derivds = L l d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds + = addl (gp { hs_defds = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds + = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds + = addl (gp { hs_warnds = L l d : ts }) ds +add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds + = addl (gp { hs_annds = L l d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds + = addl (gp { hs_ruleds = L l d : ts }) ds +add gp l (DocD _ d) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds + +add_tycld :: LTyClDecl GhcPs -> [TyClGroup GhcPs] + -> [TyClGroup GhcPs] +add_tycld d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [d] + , group_kisigs = [] + , group_roles = [] + , group_instds = [] + } + ] +add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) + = ds { group_tyclds = d : tyclds } : dss + +add_instd :: LInstDecl GhcPs -> [TyClGroup GhcPs] + -> [TyClGroup GhcPs] +add_instd d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [] + , group_instds = [d] + } + ] +add_instd d (ds@(TyClGroup { group_instds = instds }):dss) + = ds { group_instds = d : instds } : dss + +add_role_annot :: LRoleAnnotDecl GhcPs -> [TyClGroup GhcPs] + -> [TyClGroup GhcPs] +add_role_annot d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [d] + , group_instds = [] + } + ] +add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) + = tycls { group_roles = d : roles } : rest + +add_kisig :: LStandaloneKindSig GhcPs + -> [TyClGroup GhcPs] -> [TyClGroup GhcPs] +add_kisig d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [d] + , group_roles = [] + , group_instds = [] + } + ] +add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) + = tycls { group_kisigs = d : kisigs } : rest + +add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a +add_bind b (ValBinds x bs sigs) = ValBinds x (bs ++ [b]) sigs +add_bind _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_bind" + +add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) +add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) +add_sig _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_sig" diff --git a/GHC/Rename/Names.hs b/GHC/Rename/Names.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Names.hs @@ -0,0 +1,2501 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Extracting imported and top-level names in scope +-} + +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Rename.Names ( + rnImports, getLocalNonValBinders, newRecordFieldLabel, + importsFromIface, + ImportUserSpec(..), + extendGlobalRdrEnvRn, + gresFromAvails, + calculateAvails, + reportUnusedNames, + checkConName, + mkChildEnv, + findChildren, + findImportUsage, + getMinimalImports, + printMinimalImports, + renamePkgQual, renameRawPkgQual, + classifyGREs, + ImportDeclUsage + ) where + +import GHC.Prelude hiding ( head, init, last, tail ) + +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Ppr + +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( warnUnusedTopBinds ) +import GHC.Rename.Unbound +import qualified GHC.Rename.Unbound as Unbound + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.LclEnv +import GHC.Tc.Zonk.TcType ( tcInitTidyEnv ) + +import GHC.Hs +import GHC.Iface.Load ( loadSrcInterface ) +import GHC.Iface.Syntax ( fromIfaceWarnings ) +import GHC.Builtin.Names +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import GHC.Core.TyCo.Tidy +import GHC.Core.PatSyn +import GHC.Core.TyCon ( TyCon, tyConName ) +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Misc as Utils +import GHC.Utils.Panic + +import GHC.Types.Fixity.Env +import GHC.Types.SafeHaskell +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.Avail +import GHC.Types.FieldLabel +import GHC.Types.Hint +import GHC.Types.SourceFile +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Basic ( TopLevelFlag(..), TyConFlavour (..), convImportLevel ) +import GHC.Types.SourceText +import GHC.Types.Id +import GHC.Types.PkgQual +import GHC.Types.GREInfo (ConInfo(..), ConFieldInfo (..), ConLikeInfo (ConIsData)) + +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.Bag +import GHC.Data.FastString +import GHC.Data.FastString.Env +import GHC.Data.Maybe +import GHC.Data.List.SetOps ( removeDups ) + +import Control.Arrow ( second ) +import Control.Monad +import Data.Foldable ( for_ ) +import Data.IntMap ( IntMap ) +import qualified Data.IntMap as IntMap +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Ord ( comparing ) +import Data.Semigroup ( Any(..) ) +import qualified Data.Semigroup as S +import Data.List ( partition, find, sortBy ) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Function ( on ) +import qualified Data.Set as S +import System.FilePath (()) +import System.IO + + +{- +************************************************************************ +* * +\subsection{rnImports} +* * +************************************************************************ + +Note [Tracking Trust Transitively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we import a package as well as checking that the direct imports are safe +according to the rules outlined in the Note [Safe Haskell Trust Check] in GHC.Driver.Main +we must also check that these rules hold transitively for all dependent modules +and packages. Doing this without caching any trust information would be very +slow as we would need to touch all packages and interface files a module depends +on. To avoid this we make use of the property that if a modules Safe Haskell +mode changes, this triggers a recompilation from that module in the dependency +graph. So we can just worry mostly about direct imports. + +There is one trust property that can change for a package though without +recompilation being triggered: package trust. So we must check that all +packages a module transitively depends on to be trusted are still trusted when +we are compiling this module (as due to recompilation avoidance some modules +below may not be considered trusted any more without recompilation being +triggered). + +We handle this by augmenting the existing transitive list of packages a module M +depends on with a bool for each package that says if it must be trusted when the +module M is being checked for trust. This list of trust required packages for a +single import is gathered in the rnImportDecl function and stored in an +ImportAvails data structure. The union of these trust required packages for all +imports is done by the rnImports function using the combine function which calls +the plusImportAvails function that is a union operation for the ImportAvails +type. This gives us in an ImportAvails structure all packages required to be +trusted for the module we are currently compiling. Checking that these packages +are still trusted (and that direct imports are trusted) is done in +GHC.Driver.Main.checkSafeImports. + +See the note below, [Trust Own Package] for a corner case in this method and +how its handled. + + +Note [Trust Own Package] +~~~~~~~~~~~~~~~~~~~~~~~~ +There is a corner case of package trust checking that the usual transitive check +doesn't cover. (For how the usual check operates see the Note [Tracking Trust +Transitively] below). The case is when you import a -XSafe module M and M +imports a -XTrustworthy module N. If N resides in a different package than M, +then the usual check works as M will record a package dependency on N's package +and mark it as required to be trusted. If N resides in the same package as M +though, then importing M should require its own package be trusted due to N +(since M is -XSafe so doesn't create this requirement by itself). The usual +check fails as a module doesn't record a package dependency of its own package. +So instead we now have a bool field in a modules interface file that simply +states if the module requires its own package to be trusted. This field avoids +us having to load all interface files that the module depends on to see if one +is trustworthy. + + +Note [Trust Transitive Property] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +So there is an interesting design question in regards to transitive trust +checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch +of modules and packages, some packages it requires to be trusted as its using +-XTrustworthy modules from them. Now if I have a module A that doesn't use safe +haskell at all and simply imports B, should A inherit all the trust +requirements from B? Should A now also require that a package p is trusted since +B required it? + +We currently say no but saying yes also makes sense. The difference is, if a +module M that doesn't use Safe Haskell imports a module N that does, should all +the trusted package requirements be dropped since M didn't declare that it cares +about Safe Haskell (so -XSafe is more strongly associated with the module doing +the importing) or should it be done still since the author of the module N that +uses Safe Haskell said they cared (so -XSafe is more strongly associated with +the module that was compiled that used it). + +Going with yes is a simpler semantics we think and harder for the user to stuff +up but it does mean that Safe Haskell will affect users who don't care about +Safe Haskell as they might grab a package from Cabal which uses safe haskell (say +network) and that packages imports -XTrustworthy modules from another package +(say bytestring), so requires that package is trusted. The user may now get +compilation errors in code that doesn't do anything with Safe Haskell simply +because they are using the network package. They will have to call 'ghc-pkg +trust network' to get everything working. Due to this invasive nature of going +with yes we have gone with no for now. +-} + +-- | Process Import Decls. See 'rnImportDecl' for a description of what +-- the return types represent. +-- Note: Do the non SOURCE ones first, so that we get a helpful warning +-- for SOURCE ones that are unnecessary +rnImports :: [(LImportDecl GhcPs, SDoc)] + -> RnM ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails) +rnImports imports = do + tcg_env <- getGblEnv + -- NB: want an identity module here, because it's OK for a signature + -- module to import from its implementor + let this_mod = tcg_mod tcg_env + let (source, ordinary) = partition (is_source_import . fst) imports + is_source_import (d::LImportDecl GhcPs) = 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, imp_user_spec, rdr_env, imp_avails) = combine (stuff1 ++ stuff2) + -- Update imp_boot_mods if imp_direct_mods mentions any of them + let merged_import_avail = clobberSourceImports imp_avails + return (decls, imp_user_spec, rdr_env, merged_import_avail) + + 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, ImportUserSpec, GlobalRdrEnv, ImportAvails)] + -> ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails) + combine ss = + let (decls, imp_user_spec, rdr_env, imp_avails, finsts) = foldr + plus + ([], [], emptyGlobalRdrEnv, emptyImportAvails, emptyModuleSet) + ss + in (decls, imp_user_spec, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }) + + plus (decl, us, gbl_env1, imp_avails1) + (decls, uss, gbl_env2, imp_avails2, finsts_set) + = ( decl:decls, + us:uss, + gbl_env1 `plusGlobalRdrEnv` gbl_env2, + imp_avails1' `plusImportAvails` imp_avails2, + extendModuleSetList finsts_set new_finsts ) + where + imp_avails1' = imp_avails1 { imp_finsts = [] } + new_finsts = imp_finsts imp_avails1 + +{- +Note [Combining ImportAvails] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +imp_finsts in ImportAvails is a list of family instance modules +transitively depended on by an import. imp_finsts for a currently +compiled module is a union of all the imp_finsts of imports. +Computing the union of two lists of size N is O(N^2) and if we +do it to M imports we end up with O(M*N^2). That can get very +expensive for bigger module hierarchies. + +Union can be optimized to O(N log N) if we use a Set. +imp_finsts is converted back and forth between dep_finsts, so +changing a type of imp_finsts means either paying for the conversions +or changing the type of dep_finsts as well. + +I've measured that the conversions would cost 20% of allocations on my +test case, so that can be ruled out. + +Changing the type of dep_finsts forces checkFamInsts to +get the module lists in non-deterministic order. If we wanted to restore +the deterministic order, we'd have to sort there, which is an additional +cost. As far as I can tell, using a non-deterministic order is fine there, +but that's a brittle nonlocal property which I'd like to avoid. + +Additionally, dep_finsts is read from an interface file, so its "natural" +type is a list. Which makes it a natural type for imp_finsts. + +Since rnImports.combine is really the only place that would benefit from +it being a Set, it makes sense to optimize the hot loop in rnImports.combine +without changing the representation. + +So here's what we do: instead of naively merging ImportAvails with +plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts +and compute the union on the side using Sets. When we're done, we can +convert it back to a list. One nice side effect of this approach is that +if there's a lot of overlap in the imp_finsts of imports, the +Set doesn't really need to grow and we don't need to allocate. + +Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in +23s before, and 11s after. +-} + +-- | Given a located import declaration @decl@ from @this_mod@, +-- calculate the following pieces of information: +-- +-- 1. An updated 'LImportDecl', where all unresolved 'RdrName' in +-- the entity lists have been resolved into 'Name's, +-- +-- 2. A 'GlobalRdrEnv' representing the new identifiers that were +-- brought into scope (taking into account module qualification +-- and hiding), +-- +-- 3. 'ImportAvails' summarizing the identifiers that were imported +-- by this declaration, and +-- +-- 4. A boolean 'AnyHpcUsage' which is true if the imported module +-- used HPC. +rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc) + -> RnM (LImportDecl GhcRn, ImportUserSpec , GlobalRdrEnv, ImportAvails) +rnImportDecl this_mod + (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name + , ideclPkgQual = raw_pkg_qual + , ideclSource = want_boot + , ideclSafe = mod_safe + , ideclLevelSpec = import_level + , ideclQualified = qual_style + , ideclExt = XImportDeclPass { ideclImplicit = implicit } + , ideclAs = as_mod, ideclImportList = imp_details }), import_reason) + = setSrcSpanA loc $ do + + case raw_pkg_qual of + NoRawPkgQual -> pure () + RawPkgQual _ -> do + pkg_imports <- xoptM LangExt.PackageImports + when (not pkg_imports) $ addErr TcRnPackageImportsDisabled + + let qual_only = isImportDeclQualified qual_style + + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' + let imp_mod_name = unLoc loc_imp_mod_name + doc = ppr imp_mod_name <+> import_reason + + hsc_env <- getTopEnv + unit_env <- hsc_unit_env <$> getTopEnv + let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual + + -- Check for self-import, which confuses the typechecker (#9032) + -- ghc --make rejects self-import cycles already, but batch-mode may not + -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid + -- typechecker crashes. (Indirect self imports are not caught until + -- GHC.IfaceToCore, see #10337 tracking how to make this error better.) + -- + -- Originally, we also allowed 'import {-# SOURCE #-} M', but this + -- caused bug #10182: in one-shot mode, we should never load an hs-boot + -- file for the module we are compiling into the EPS. In principle, + -- it should be possible to support this mode of use, but we would have to + -- extend Provenance to support a local definition in a qualified location. + -- For now, we don't support it, but see #10336 + when (imp_mod_name == moduleName this_mod && + (case pkg_qual of -- If we have import "" M, then we should + -- check that "" 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 (TcRnSelfImport imp_mod_name)) + + -- Check for a missing import list (Opt_WarnMissingImportList also + -- checks for T(..) items but that is done in checkDodgyImport below) + case imp_details of + Just (Exactly, _) -> return () -- Explicit import list + _ | implicit -> return () -- Do not bleat for implicit imports + | qual_only -> return () + | otherwise -> addDiagnostic (TcRnNoExplicitImportList imp_mod_name) + + + iface <- loadSrcInterface doc imp_mod_name want_boot pkg_qual + + -- Compiler sanity check: if the import didn't say + -- {-# SOURCE #-} we should not get a hi-boot file + warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) "rnImportDecl" (ppr imp_mod_name) $ do + + -- Issue a user warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports. + -- + -- in --make and GHCi, the compilation manager checks for this, + -- and indeed we shouldn't do it here because the existence of + -- the non-boot module depends on the compilation order, which + -- is not deterministic. The hs-boot test can show this up. + dflags <- getDynFlags + warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags)) + (TcRnRedundantSourceImport imp_mod_name) + when (mod_safe && not (safeImportsOn dflags)) $ + addErr (TcRnSafeImportsDisabled imp_mod_name) + + let imp_mod = mi_module iface + qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name + imp_spec = ImpDeclSpec { is_mod = imp_mod, is_qual = qual_only, + is_dloc = locA loc, is_as = qual_mod_name, + is_pkg_qual = pkg_qual, is_isboot = want_boot, + is_level = convImportLevel import_level } + + -- filter the imports according to the import declaration + (new_imp_details, imp_user_list, gbl_env) <- filterImports hsc_env iface imp_spec imp_details + + -- for certain error messages, we’d like to know what could be imported + -- here, if everything were imported + potential_gres <- (\(_,_,x) -> x) <$> filterImports hsc_env iface imp_spec Nothing + + let is_hiding | Just (EverythingBut,_) <- imp_details = True + | otherwise = False + + -- should the import be safe? + mod_safe' = mod_safe + || (not implicit && safeDirectImpsReq dflags) + || (implicit && safeImplicitImpsReq dflags) + + hsc_env <- getTopEnv + let home_unit = hsc_home_unit hsc_env + other_home_units = hsc_all_home_unit_ids hsc_env + imv = ImportedModsVal + { imv_name = is_as imp_spec + , imv_span = locA loc + , imv_is_safe = mod_safe' + , imv_is_hiding = is_hiding + , imv_all_exports = potential_gres + , imv_qualified = qual_only + , imv_is_level = convImportLevel import_level + } + imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv) + + -- Complain if we import a deprecated module + case fromIfaceWarnings (mi_warns iface) of + WarnAll txt -> addDiagnostic (TcRnDeprecatedModule imp_mod_name txt) + _ -> return () + + let new_imp_decl = ImportDecl + { ideclExt = ideclExt decl + , ideclName = ideclName decl + , ideclPkgQual = pkg_qual + , ideclSource = ideclSource decl + , ideclSafe = mod_safe' + , ideclQualified = ideclQualified decl + , ideclAs = ideclAs decl + , ideclImportList = new_imp_details + , ideclLevelSpec = ideclLevelSpec decl + } + + return (L loc new_imp_decl, ImpUserSpec imp_spec imp_user_list, gbl_env, imports) + + +-- | 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 unit_state 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 + + unit_state = ue_homeUnitState unit_env + + hpt_deps :: [UnitId] + hpt_deps = homeUnitDepends unit_state + + +-- | Calculate the 'ImportAvails' induced by an import of a particular +-- interface, but without 'imp_mods'. +calculateAvails :: HomeUnit + -> S.Set UnitId + -> ModIface + -> IsSafeImport + -> IsBootInterface + -> ImportedBy + -> ImportAvails +calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by = + let imp_mod = mi_module iface + imp_sem_mod= mi_semantic_module iface + orph_iface = mi_orphan iface + has_finsts = mi_finsts iface + deps = mi_deps iface + trust = getSafeMode $ mi_trust iface + trust_pkg = mi_trust_pkg iface + is_sig = mi_hsc_src iface == HsigFile + + -- If the module exports anything defined in this module, just + -- ignore it. Reason: otherwise it looks as if there are two + -- local definition sites for the thing, and an error gets + -- reported. Easiest thing is just to filter them out up + -- front. This situation only arises if a module imports + -- itself, or another module that imported it. (Necessarily, + -- this involves a loop.) + -- + -- We do this *after* filterImports, so that if you say + -- module A where + -- import B( AType ) + -- type AType = ... + -- + -- module B( AType ) where + -- import {-# SOURCE #-} A( AType ) + -- + -- then you won't get a 'B does not export AType' message. + + + -- Compute new transitive dependencies + -- + -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module + -- itself, but we DO need to include this module in 'imp_orphs' and + -- 'imp_finsts' if it defines an orphan or instance family; thus the + -- orph_iface/has_iface tests. + + deporphs = dep_orphs deps + depfinsts = dep_finsts deps + + orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` deporphs)) (ppr imp_sem_mod <+> ppr deporphs) $ + imp_sem_mod : deporphs + | otherwise = deporphs + + finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` depfinsts)) (ppr imp_sem_mod <+> ppr depfinsts) $ + imp_sem_mod : depfinsts + | otherwise = depfinsts + + -- Trusted packages are a lot like orphans. + trusted_pkgs | mod_safe' = dep_trusted_pkgs deps + | otherwise = S.empty + + + pkg = moduleUnit (mi_module iface) + ipkg = toUnitId pkg + + -- Does this import mean we now require our own pkg + -- to be trusted? See Note [Trust Own Package] + ptrust = trust == Sf_Trustworthy || trust_pkg + pkg_trust_req + | isHomeUnit home_unit pkg = ptrust + | otherwise = False + + dependent_pkgs = if toUnitId pkg `S.member` other_home_units + then S.empty + else S.singleton (lvl, ipkg) + + lvl = case imported_by of + ImportedByUser imv -> imv_is_level imv + ImportedBySystem -> NormalLevel + + + direct_mods = if toUnitId pkg `S.member` other_home_units + then mkPlusModDeps (moduleUnitId imp_mod) lvl (GWIB (moduleName imp_mod) want_boot) + else emptyInstalledModuleEnv + + 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 = Map.singleton (mi_module iface) [imported_by], + imp_orphs = orphans, + imp_finsts = finsts, + imp_sig_mods = sig_mods, + imp_direct_dep_mods = direct_mods, + imp_dep_direct_pkgs = dependent_pkgs, + imp_boot_mods = boot_mods, + + -- Add in the imported modules trusted package + -- requirements. ONLY do this though if we import the + -- module as a safe import. + -- See Note [Tracking Trust Transitively] + -- and Note [Trust Transitive Property] + imp_trust_pkgs = trusted_pkgs, + -- Do we require our own pkg to be trusted? + -- See Note [Trust Own Package] + imp_trust_own_pkg = pkg_trust_req + } + +mkPlusModDeps :: UnitId -> ImportLevel -> ModuleNameWithIsBoot + -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot) +mkPlusModDeps uid st elt = extendInstalledModuleEnv emptyInstalledModuleEnv (mkModule uid (gwib_mod elt)) (S.singleton st, elt) + +{- +************************************************************************ +* * +\subsection{importsFromLocalDecls} +* * +************************************************************************ + +From the top-level declarations of this module produce + * the lexical environment + * the ImportAvails +created by its bindings. + +Note [Top-level Names in Template Haskell decl quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env + Note [Looking up Exact RdrNames] in GHC.Rename.Env + +Consider a Template Haskell declaration quotation like this: + module M where + f x = h [d| f = 3 |] +When renaming the declarations inside [d| ...|], we treat the +top level binders specially in two ways + +1. We give them an Internal Name, not (as usual) an External one. + This is done by GHC.Rename.Env.newTopSrcBinder. + +2. We make them *shadow* the outer bindings. + See Note [GlobalRdrEnv shadowing] + +3. We find out whether we are inside a [d| ... |] by testing the TH + level. This is a slight hack, because the level field was really + meant for the type checker, and here we are not interested in the + fields of Brack, hence the error thunks in thRnBrack. +-} + +extendGlobalRdrEnvRn :: [GlobalRdrElt] + -> MiniFixityEnv + -> RnM (TcGblEnv, TcLclEnv) +-- Updates both the GlobalRdrEnv and the FixityEnv +-- We return a new TcLclEnv only because we might have to +-- delete some bindings from it; +-- see Note [Top-level Names in Template Haskell decl quotes] + +extendGlobalRdrEnvRn new_gres new_fixities + = checkNoErrs $ -- See Note [Fail fast on duplicate definitions] + do { (gbl_env, lcl_env) <- getEnvs + ; level <- getThLevel + ; isGHCi <- getIsGHCi + ; let rdr_env = tcg_rdr_env gbl_env + fix_env = tcg_fix_env gbl_env + th_bndrs = getLclEnvThBndrs lcl_env + th_lvl = thLevelIndex level + + -- Delete new_occs from global and local envs + -- If we are in a TemplateHaskell decl bracket, + -- we are going to shadow them + -- See Note [GlobalRdrEnv shadowing] + inBracket = isBrackLevel level + + lcl_env_TH = modifyLclCtxt (\lcl_env -> lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_gres_env }) lcl_env + -- See Note [GlobalRdrEnv shadowing] + + lcl_env2 | inBracket = lcl_env_TH + | otherwise = lcl_env + + -- Deal with shadowing: see Note [GlobalRdrEnv shadowing] + want_shadowing = isGHCi || inBracket + rdr_env1 | want_shadowing = shadowNames False rdr_env new_gres_env + | otherwise = rdr_env + + lcl_env3 = modifyLclCtxt (\lcl_env -> lcl_env { tcl_th_bndrs = extendNameEnvList th_bndrs + [ ( n, (TopLevel, th_lvl) ) + | n <- new_names ] }) lcl_env2 + + ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres + + ; let fix_env' = foldl' extend_fix_env fix_env new_gres + gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' } + + ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2) + ; return (gbl_env', lcl_env3) } + where + new_names = map greName new_gres + new_gres_env = mkGlobalRdrEnv new_gres + + -- If there is a fixity decl for the gre, add it to the fixity env + extend_fix_env fix_env gre + | Just (L _ fi) <- lookupMiniFixityEnv new_fixities name + = extendNameEnv fix_env name (FixItem occ fi) + | otherwise + = fix_env + where + name = greName gre + occ = greOccName gre + + add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv + -- Extend the GlobalRdrEnv with a LocalDef GRE + -- If there is already a LocalDef GRE with the same OccName, + -- report an error and discard the new GRE + -- This establishes INVARIANT 1 of GlobalRdrEnvs + add_gre env gre + | not (null dups) -- Same OccName defined twice + = do { addDupDeclErr (gre :| dups); return env } + + | otherwise + = return (extendGlobalRdrEnv env gre) + where + -- See Note [Reporting duplicate local declarations] + dups = filter isBadDupGRE + $ lookupGRE env (LookupOccName (greOccName gre) (RelevantGREsFOS WantBoth)) + isBadDupGRE old_gre = isLocalGRE old_gre && greClashesWith gre old_gre + +{- Note [Fail fast on duplicate definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there are duplicate bindings for the same thing, we want to fail +fast. Having two bindings for the same thing can cause follow-on errors. +Example (test T9975a): + data Test = Test { x :: Int } + pattern Test wat = Test { x = wat } +This defines 'Test' twice. The second defn has no field-names; and then +we get an error from Test { x=wat }, saying "Test has no field 'x'". + +Easiest thing is to bale out fast on duplicate definitions, which +we do via `checkNoErrs` on `extendGlobalRdrEnvRn`. + +Note [Reporting duplicate local declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, a single module may not define the same OccName multiple times. This +is checked in extendGlobalRdrEnvRn: when adding a new locally-defined GRE to the +GlobalRdrEnv we report an error if there are already duplicates in the +environment. This establishes INVARIANT 1 (see comments on GlobalRdrEnv in +GHC.Types.Name.Reader), which says that for a given OccName, all the +GlobalRdrElts to which it maps must have distinct 'greName's. + +For example, the following will be rejected: + + f x = x + g x = x + f x = x -- Duplicate! + +Users are allowed to introduce new GREs with the same OccName as an imported GRE, +as disambiguation is possible through the module system, e.g.: + + module M where + import N (f) + f x = x + g x = M.f x + N.f x + +If both GREs are local, the general rule is that two GREs clash if they have +the same OccName, i.e. they share a textual name and live in the same namespace. +However, there are additional clashes due to record fields: + + - a new variable clashes with previously defined record fields + which define field selectors, + + - a new record field shadows: + + - previously defined variables, if it defines a field selector, + - previously defined record fields, unless it is a duplicate record field. + +This logic is implemented in the function 'GHC.Types.Name.Reader.greClashesWith'. + +See also Note [Skipping ambiguity errors at use sites of local declarations] in +GHC.Rename.Utils. +-} + + +{- ********************************************************************* +* * + getLocalDeclBindersd@ returns the names for an HsDecl + It's used for source code. + + *** See Note [The Naming story] in GHC.Hs.Decls **** +* * +********************************************************************* -} + +getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs + -> RnM ((TcGblEnv, TcLclEnv), NameSet) +-- Get all the top-level binders bound the group *except* +-- for value bindings, which are treated separately +-- Specifically we return AvailInfo for +-- * type decls (incl constructors and record selectors) +-- * class decls (including class ops) +-- * associated types +-- * foreign imports +-- * value signatures (in hs-boot files only) + +getLocalNonValBinders fixity_env + (HsGroup { hs_valds = binds, + hs_tyclds = tycl_decls, + hs_fords = foreign_decls }) + = do { -- Process all type/class decls *except* family instances + ; let inst_decls = tycl_decls >>= group_instds + ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags + ; has_sel <- xopt_FieldSelectors <$> getDynFlags + ; tc_gres + <- concatMapM + (new_tc dup_fields_ok has_sel) + (tyClGroupTyClDecls tycl_decls) + ; traceRn "getLocalNonValBinders 1" (ppr tc_gres) + ; envs <- extendGlobalRdrEnvRn tc_gres fixity_env + ; restoreEnvs envs $ do { + -- Bring these things into scope first + -- See Note [Looking up family names in family instances] + + -- Process all family instances + -- to bring new data constructors into scope + ; nti_gress <- mapM (new_assoc dup_fields_ok has_sel) inst_decls + + -- Finish off with value binders: + -- foreign decls and pattern synonyms for an ordinary module + -- type sigs in case of a hs-boot file only + ; is_boot <- tcIsHsBootOrSig + ; let val_bndrs + | is_boot = case binds of + ValBinds _ _val_binds val_sigs -> + -- In a hs-boot file, the value binders come from the + -- *signatures*, and there should be no foreign binders + [ L (l2l decl_loc) (unLoc n) + | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] + _ -> panic "Non-ValBinds in hs-boot group" + | otherwise = for_hs_bndrs + ; val_gres <- mapM new_simple val_bndrs + + ; let avails = concat nti_gress ++ val_gres + new_bndrs = gresToNameSet avails `unionNameSet` + gresToNameSet tc_gres + ; traceRn "getLocalNonValBinders 2" (ppr avails) + ; envs <- extendGlobalRdrEnvRn avails fixity_env + ; return (envs, new_bndrs) } } + where + for_hs_bndrs :: [LocatedN RdrName] + for_hs_bndrs = hsForeignDeclsBinders foreign_decls + + -- the SrcSpan attached to the input should be the span of the + -- declaration, not just the name + new_simple :: LocatedN RdrName -> RnM GlobalRdrElt + new_simple rdr_name = do { nm <- newTopSrcBinder rdr_name + ; return (mkLocalVanillaGRE NoParent nm) } + + new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs + -> RnM [GlobalRdrElt] + new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances + = do { let TyDeclBinders (main_bndr, tc_flav) at_bndrs sig_bndrs + (LConsWithFields cons_with_flds flds) = hsLTyClDeclBinders tc_decl + ; tycon_name <- newTopSrcBinder $ la2la main_bndr + ; at_names <- mapM (newTopSrcBinder . la2la . fst) at_bndrs + ; sig_names <- mapM (newTopSrcBinder . la2la) sig_bndrs + ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds + ; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst con_names_with_flds) flds + ; mapM_ (add_dup_fld_errs flds') con_names_with_flds + ; let tc_gre = mkLocalTyConGRE (fmap (const tycon_name) tc_flav) tycon_name + fld_env = mk_fld_env con_names_with_flds flds' + at_gres = zipWith (\ (_, at_flav) at_nm -> mkLocalTyConGRE (fmap (const tycon_name) at_flav) at_nm) + at_bndrs at_names + sig_gres = map (mkLocalVanillaGRE (ParentIs tycon_name)) sig_names + con_gres = map (mkLocalConLikeGRE (ParentIs tycon_name)) fld_env + fld_gres = mkLocalFieldGREs (ParentIs tycon_name) fld_env + sub_gres = at_gres ++ sig_gres ++ con_gres ++ fld_gres + ; traceRn "getLocalNonValBinders new_tc" $ + vcat [ text "tycon:" <+> ppr tycon_name + , text "tc_gre:" <+> ppr tc_gre + , text "sub_gres:" <+> ppr sub_gres ] + ; return $ tc_gre : sub_gres } + + -- Calculate the record field information, which feeds into the GlobalRdrElts + -- for DataCons and their fields. It's convenient to do this here where + -- we are working with a single datatype definition. + -- + -- The information we needed was all set up for us: + -- see Note [Collecting record fields in data declarations] in GHC.Hs.Utils. + mk_fld_env :: [(Name, Maybe [Located Int])] -> IntMap FieldLabel + -> [(ConLikeName, ConInfo)] + mk_fld_env names flds = + [ (DataConName con, ConInfo (ConIsData (map fst names)) fld_info) + | (con, mb_fl_indxs) <- names + , let fld_info = case fmap (map ((flds IntMap.!) . unLoc)) mb_fl_indxs of + Nothing -> ConHasPositionalArgs + Just [] -> ConIsNullary + Just (fld:flds) -> ConHasRecordFields $ fld NE.:| flds ] + + new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs + -> RnM [GlobalRdrElt] + new_assoc _ _ (L _ (TyFamInstD {})) = return [] + -- type instances don't bind new names + + new_assoc dup_fields_ok has_sel (L _ (DataFamInstD _ d)) + = new_di dup_fields_ok has_sel Nothing d + new_assoc dup_fields_ok has_sel + (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty + , cid_datafam_insts = adts }))) + = do -- First, attempt to grab the name of the class from the instance. + -- This step could fail if the instance is not headed by a class, + -- such as in the following examples: + -- + -- (1) The class is headed by a bang pattern, such as in + -- `instance !Show Int` (#3811c) + -- (2) The class is headed by a type variable, such as in + -- `instance c` (#16385) + -- + -- If looking up the class name fails, then mb_cls_gre will + -- be Nothing. + mb_cls_gre <- runMaybeT $ do + -- See (1) above + L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty + -- See (2) above + MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe SameNameSpace cls_rdr + -- Assuming the previous step succeeded, process any associated data + -- family instances. If the previous step failed, bail out. + case mb_cls_gre of + Nothing + -> pure [] + Just cls_gre + -> let cls_nm = greName cls_gre + in concatMapM (new_di dup_fields_ok has_sel (Just cls_nm) . unLoc) adts + + new_di :: DuplicateRecordFields -> FieldSelectors + -> Maybe Name -- class name + -> DataFamInstDecl GhcPs + -> RnM [GlobalRdrElt] + new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl }) + = do { main_name <- unLoc <$> lookupFamInstName mb_cls (feqn_tycon ti_decl) + ; let LConsWithFields cons_with_flds flds = hsDataFamInstBinders dfid + ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds + ; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst sub_names) flds + ; mapM_ (add_dup_fld_errs flds') sub_names + ; let fld_env = mk_fld_env sub_names flds' + con_gres = map (mkLocalConLikeGRE (ParentIs main_name)) fld_env + field_gres = mkLocalFieldGREs (ParentIs main_name) fld_env + -- NB: the data family name is not bound here, + -- so we don't return a GlobalRdrElt for it here! + ; return $ con_gres ++ field_gres } + + -- Add errors if a constructor has a duplicate record field. + add_dup_fld_errs :: IntMap FieldLabel + -> (Name, Maybe [Located Int]) + -> IOEnv (Env TcGblEnv TcLclEnv) () + add_dup_fld_errs all_flds (con, mb_con_flds) + | Just con_flds <- mb_con_flds + , let (_, dups) = removeDups (comparing unLoc) con_flds + = for_ dups $ \ dup_flds -> + -- Report the error at the location of the second occurrence + -- of the duplicate field. + let loc = + case dup_flds of + _ :| ( L loc _ : _) -> loc + L loc _ :| _ -> loc + dup_rdrs = fmap (nameRdrName . flSelector . (all_flds IntMap.!) . unLoc) dup_flds + in addErrAt loc $ TcRnDuplicateFieldName (RecordFieldDecl con) dup_rdrs + | otherwise + = return () + +newRecordFieldLabel :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel +newRecordFieldLabel _ _ [] _ = error "newRecordFieldLabel: datatype has no constructors!" +newRecordFieldLabel dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld))) + = do { selName <- newTopSrcBinder $ L (l2l loc) $ field + ; return $ FieldLabel { flHasDuplicateRecordFields = dup_fields_ok + , flHasFieldSelector = has_sel + , flSelector = selName } } + where + fld_occ = rdrNameOcc fld + dc_fs = occNameFS $ nameOccName dc + field + -- Use an Exact RdrName as-is, to preserve the bindings + -- of an already renamer-resolved field and its use + -- sites. This is needed to correctly support record + -- selectors in Template Haskell. See Note [Binders in + -- Template Haskell] in "GHC.ThToHs" and Note [Looking up + -- Exact RdrNames] in "GHC.Rename.Env". + | isExact fld + = assertPpr (fieldOcc_maybe fld_occ == Just dc_fs) + (vcat [ text "newRecordFieldLabel: incorrect namespace for exact Name" <+> quotes (ppr fld) + , text "expected namespace:" <+> pprNameSpace (fieldName dc_fs) + , text " actual namespace:" <+> pprNameSpace (occNameSpace fld_occ) ]) + fld + + -- Field names produced by the parser are namespaced with VarName. + -- Here we namespace them according to the first constructor. + -- See Note [Record field namespacing] in GHC.Types.Name.Occurrence. + | otherwise + = mkRdrUnqual $ varToRecFieldOcc dc_fs fld_occ + +{- +Note [Looking up family names in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + module M where + type family T a :: * + type instance M.T Int = Bool + +We might think that we can simply use 'lookupOccRn' when processing the type +instance to look up 'M.T'. Alas, we can't! The type family declaration is in +the *same* HsGroup as the type instance declaration. Hence, as we are +currently collecting the binders declared in that HsGroup, these binders will +not have been added to the global environment yet. + +Solution is simple: process the type family declarations first, extend +the environment, and then process the type instances. + + +************************************************************************ +* * +\subsection{Filtering imports} +* * +************************************************************************ + +@filterImports@ takes the @ExportEnv@ telling what the imported module makes +available, and filters it through the import spec (if any). + +Note [Dealing with imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For import M( ies ), we take each AvailInfo from the mi_exports of M, and make + + imp_occ_env :: OccEnv (NameEnv ImpOccItem) + +This map contains one entry for each OccName that M exports, mapping each OccName +to the following information: + + 1. the GlobalRdrElt corresponding to the OccName, + 2. whether this GlobalRdrElt was the parent in the AvailInfo we found + the OccName in. + 3. the GlobalRdrElts that were bundled together in the AvailInfo we found + this OccName in (not including the parent), + +We need (2) and (3) during the construction of the OccEnv because of associated +types and bundled pattern synonyms, respectively. +(3) is explained in Note [Importing PatternSynonyms]. + +To explain (2), consider for example: + + module M where + class C a where { data T a } + instance C Int where { data T Int = T1 | T2 } + instance C Bool where { data T Int = T3 } + +Here, M's exports avails are (recalling the AvailTC invariant from GHC.Types.Avail) + + C(C,T), T(T,T1,T2,T3) + +Notice that T appears *twice*, once as a child and once as a parent. From +these two exports, respectively, during construction of the imp_occ_env, we begin +by associating the following two elements with the key T: + + T -> ImpOccItem { imp_item = gre1, imp_bundled = [C,T] , imp_is_parent = False } + T -> ImpOccItem { imp_item = gre2, imp_bundled = [T1,T2,T3], imp_is_parent = True } + +where `gre1`, `gre2` are two GlobalRdrElts with greName T. +We combine these (in function 'combine' in 'mkImportOccEnv') by discarding the +non-parent item, thusly: + + T -> IE_ITem { imp_item = gre1 `plusGRE` gre2, imp_bundled = [T1,T2,T3], imp_is_parent = True } + +Note the `plusGRE`: this ensures we don't drop parent information; +see Note [Preserve parent information when combining import OccEnvs]. + +So the overall imp_occ_env is: + + C -> ImpOccItem { imp_item = C, imp_bundled = [T ], imp_is_parent = True } + T -> ImpOccItem { imp_item = T , imp_bundled = [T1,T2,T3], imp_is_parent = True } + T1 -> ImpOccItem { imp_item = T1, imp_bundled = [T1,T2,T3], imp_is_parent = False } + -- similarly for T2, T3 + +Note that the imp_occ_env will have entries for data constructors too, +although we never look up data constructors. + +Note [Importing PatternSynonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Dealing with imports], associated types can lead to the +same Name appearing twice, both as a child and once as a parent, when +constructing the imp_occ_env. The same thing can happen with pattern synonyms +if they are exported bundled with a type. + +A simplified example, based on #11959: + + {-# LANGUAGE PatternSynonyms #-} + module M (T(P), pattern P) where -- Duplicate export warning, but allowed + data T = MkT + pattern P = MkT + +Here we have T(P) and P in export_avails, and respectively construct both + + P -> ImpOccItem { imp_item = P, imp_bundled = [P], imp_is_parent = False } + P -> ImpOccItem { imp_item = P, imp_bundled = [] , imp_is_parent = False } + +We combine these by dropping the one with no siblings, leaving us with: + + P -> ImpOccItem { imp_item = P, imp_bundled = [P], imp_is_parent = False } + +That is, we simply discard the non-bundled Avail. + +Note [Importing DuplicateRecordFields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In filterImports, another complicating factor is DuplicateRecordFields. +Suppose we have: + + {-# LANGUAGE DuplicateRecordFields #-} + module M (S(foo), T(foo)) where + data S = MkS { foo :: Int } + data T = MkT { foo :: Int } + + module N where + import M (foo) -- this is allowed (A) + import M (S(foo)) -- this is allowed (B) + +Here M exports 'foo' at two different OccNames, with different namespaces for +the two construtors MkS and MkT. Then, when we look up 'foo' in lookup_names +for case (A), we have a variable foo but must look in all the record field +namespaces to find the two fields (and hence two different Avails). +Whereas in case (B) we reach the lookup_ie case for IEThingWith, +which looks up 'S' and then finds the unique 'foo' amongst its children. + +See T16745 for a test of this. + +Note [Preserve parent information when combining import OccEnvs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When discarding one ImpOccItem in favour of another, as described in +Note [Dealing with imports], we must make sure to combine the GREs so that +we don't lose information. + +Consider for example #24084: + + module M1 where { class C a where { type T a } } + module M2 ( module M1 ) where { import M1 } + module M3 where { import M2 ( C, T ); instance C () where T () = () } + +When processing the import list of `M3`, we will have two `Avail`s attached +to `T`, namely `C(C, T)` and `T(T)`. We combine them in the `combine` function +of `mkImportOccEnv`; as described in Note [Dealing with imports] we discard +`C(C, T)` in favour of `T(T)`. However, in doing so, we **must not** +discard the information want that `C` is the parent of `T`. Indeed, +losing track of this information can cause errors when importing, +as we could get an error of the form + + ‘T’ is not a (visible) associated type of class ‘C’ + +This explains why we use `plusGRE` when combining the two ImpOccItems, even +though we are discarding one in favour of the other. +-} + +-- | All the 'GlobalRdrElt's associated with an 'AvailInfo'. +gresFromAvail :: HasDebugCallStack + => HscEnv -> Maybe ImportSpec -> AvailInfo -> [GlobalRdrElt] +gresFromAvail hsc_env prov avail = + [ mk_gre nm info + | nm <- availNames avail + , let info = lookupGREInfo hsc_env nm ] + where + + mk_gre n info + = case prov of + -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = True, gre_imp = emptyBag + , gre_info = info } + Just is -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = False, gre_imp = unitBag is + , gre_info = info } + +-- | All the 'GlobalRdrElt's associated with a collection of 'AvailInfo's. +gresFromAvails :: HscEnv -> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] +gresFromAvails hsc_env prov = concatMap (gresFromAvail hsc_env prov) + +importsFromIface :: HscEnv -> ModIface -> ImpDeclSpec -> Maybe NameSet -> GlobalRdrEnv +importsFromIface hsc_env iface decl_spec hidden = mkGlobalRdrEnv $ case hidden of + Nothing -> all_gres + Just hidden_names -> filter (not . (`elemNameSet` hidden_names) . greName) all_gres + where + all_gres = gresFromAvails hsc_env (Just imp_spec) (mi_exports iface) + imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + +filterImports + :: HasDebugCallStack + => HscEnv + -> ModIface + -> ImpDeclSpec + -- ^ Import spec + -> Maybe (ImportListInterpretation, LocatedLI [LIE GhcPs]) + -- ^ Whether this is a "hiding" import list + -> RnM (Maybe (ImportListInterpretation, LocatedLI [LIE GhcRn]), -- Import spec w/ Names + ImpUserList, -- same, but designed for storage in interfaces + GlobalRdrEnv) -- Same again, but in GRE form +filterImports hsc_env iface decl_spec Nothing + = return (Nothing, ImpUserAll, importsFromIface hsc_env iface decl_spec Nothing) +filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items)) + = do -- check for errors, convert RdrNames to Names + items1 <- mapM lookup_lie import_items + + let items2 :: [(LIE GhcRn, [GlobalRdrElt])] + items2 = concat items1 + -- NB we may have duplicates, and several items + -- for the same parent; e.g N(x) and N(y) + + (gres, imp_user_list) = case want_hiding of + Exactly -> + let gres = concatMap (gresFromIE decl_spec) items2 + gre_env = mkGlobalRdrEnv gres + implicit_parents = mkNameSet $ mapMaybe parentOfImplicitlyImportedGRE gres + in (gre_env, ImpUserExplicit (gresToAvailInfo $ globalRdrEnvElts $ gre_env) implicit_parents) + EverythingBut -> + let hidden_names = mkNameSet $ concatMap (map greName . snd) items2 + in (importsFromIface hsc_env iface decl_spec (Just hidden_names), ImpUserEverythingBut hidden_names) + + return (Just (want_hiding, L l (map fst items2)), imp_user_list, gres) + where + import_mod = mi_module iface + all_avails = mi_exports iface + imp_occ_env = mkImportOccEnv hsc_env decl_spec all_avails + + -- Look up a parent (type constructor, class or data constructor) + -- in an import. + lookup_parent :: IE GhcPs -> RdrName -> IELookupM ImpOccItem + lookup_parent ie rdr = + assertPpr (not $ isVarNameSpace ns) + (vcat [ text "filterImports lookup_parent: unexpected variable" + , text "rdr:" <+> ppr rdr + , text "namespace:" <+> pprNameSpace ns ]) $ + do { xs <- lookup_names ie rdr + ; case xs of + cax :| [] -> return cax + _ -> pprPanic "filter_imports lookup_parent ambiguous" $ + vcat [ text "rdr:" <+> ppr rdr + , text "lookups:" <+> ppr (fmap imp_item xs) ] } + -- Looking up non-variables is always unambiguous, + -- as there can be at most one corresponding item + -- in the imp_occ_env. + -- See item (1) of Note [Exporting duplicate declarations] + -- in GHC.Tc.Gen.Export. + where + occ = rdrNameOcc rdr + ns = occNameSpace occ + + -- Look up a RdrName used in an import, returning multiple values if there + -- are several fields with the same name exposed by the module + lookup_names :: IE GhcPs -> RdrName -> IELookupM (NonEmpty ImpOccItem) + lookup_names ie rdr + | isQual rdr + = failLookupWith (QualImportError rdr) + | otherwise + = case lookups of + [] -> failLookupWith (BadImport ie IsNotSubordinate) + item:items -> return $ item :| items + where + lookups = concatMap nonDetNameEnvElts + $ lookupImpOccEnv (RelevantGREsFOS WantNormal) imp_occ_env (rdrNameOcc rdr) + + lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, [GlobalRdrElt])] + lookup_lie (L loc ieRdr) + = setSrcSpanA loc $ + do (stuff, warns) <- run_lookup ([],[]) (lookup_ie ieRdr) + mapM_ (addTcRnDiagnostic <=< warning_msg) warns + return [ (L loc ie, gres) | (ie,gres) <- stuff ] + where + + -- Warn when importing T(..) and no children are brought in scope + warning_msg (DodgyImport n) = + pure (TcRnDodgyImports (DodgyImportsEmptyParent n)) + warning_msg MissingImportList = + pure (TcRnMissingImportList ieRdr) + warning_msg (BadImportW ie sub) = do + -- 'BadImportW' is only constructed below in 'bad_import_w', in + -- the 'EverythingBut' case, so here we assume a 'hiding' clause. + (reason :| _) <- badImportItemErr iface decl_spec ie sub all_avails + pure (TcRnDodgyImports (DodgyImportsHiding reason)) + warning_msg (DeprecatedExport n w) = + pure $ TcRnPragmaWarning + PragmaWarningExport + { pwarn_occname = occName n + , pwarn_impmod = moduleName import_mod } + w + + run_lookup :: a -> IELookupM a -> TcRn a + run_lookup def m = case m of + Failed err -> do + msgs <- lookup_err_msgs err + forM_ msgs $ \msg -> addErr (TcRnImportLookup msg) + return def + Succeeded a -> return a + + lookup_err_msgs err = case err of + BadImport ie sub -> badImportItemErr iface decl_spec ie sub all_avails + IllegalImport -> pure $ NE.singleton ImportLookupIllegal + QualImportError rdr -> pure $ NE.singleton (ImportLookupQualified rdr) + + -- For each import item, we convert its RdrNames to Names, + -- and at the same time compute all the GlobalRdrElt corresponding + -- to what is actually imported by this item. + -- Returns Nothing on error. + -- + -- Returns a list because, with DuplicateRecordFields, a naked + -- import/export of a record field can correspond to multiple + -- different GlobalRdrElts. See Note [Importing DuplicateRecordFields]. + lookup_ie :: IE GhcPs + -> IELookupM ([(IE GhcRn, [GlobalRdrElt])], [IELookupWarning]) + lookup_ie ie = handle_bad_import $ + case ie of + IEVar _ (L l n) _ -> do + -- See Note [Importing DuplicateRecordFields] + xs <- lookup_names ie (ieWrappedName n) + let gres = map imp_item $ NE.toList xs + export_depr_warns + | want_hiding == Exactly + = mapMaybe mk_depr_export_warning gres + | otherwise = [] + return ( [ (IEVar Nothing (L l (replaceWrappedName n name)) noDocstring, [gre]) + | gre <- gres + , let name = greName gre ] + , export_depr_warns ) + + IEThingAll _ (L l tc) _ -> do + ImpOccItem { imp_item = gre + , imp_bundled = bundled_gres + , imp_is_parent = is_par + } + <- lookup_parent ie $ ieWrappedName tc + let name = greName gre + child_gres = if is_par then bundled_gres else [] + imp_list_warn + + | null child_gres + -- e.g. f(..) or T(..) where T is a type synonym + = [DodgyImport gre] + + -- e.g. import M( T(..) ) + | not (is_qual decl_spec) + = [MissingImportList] + + | otherwise + = [] + + renamed_ie = IEThingAll (Nothing, noAnn) (L l (replaceWrappedName tc name)) noDocstring + export_depr_warn + | want_hiding == Exactly + = maybeToList $ mk_depr_export_warning gre + -- We don't want to warn about the children as they + -- are not explicitly mentioned; the warning will + -- be emitted later on if they are used + | otherwise = [] + + return ( [(renamed_ie, gre:child_gres)] + , imp_list_warn ++ export_depr_warn) + + + IEThingAbs _ (L l tc') _ + | want_hiding == EverythingBut -- hiding ( C ) + -- Here the 'C' can be a data constructor + -- *or* a type/class, or even both + -> let tc = ieWrappedName tc' + tc_name = lookup_parent ie tc + dc_name = lookup_parent ie (setRdrNameSpace tc srcDataName) + in + case catIELookupM [ tc_name, dc_name ] of + [] -> failLookupWith (BadImport ie IsNotSubordinate) + names -> return ( [mkIEThingAbs tc' l (imp_item name) | name <- names], []) + | otherwise + -> do ImpOccItem { imp_item = gre } <- lookup_parent ie (ieWrappedName tc') + return ( [mkIEThingAbs tc' l gre] + , maybeToList $ mk_depr_export_warning gre) + + IEThingWith (deprecation, ann) ltc@(L l rdr_tc) wc rdr_ns _ -> do + ImpOccItem { imp_item = gre, imp_bundled = subnames } + <- lookup_parent (IEThingAbs Nothing ltc noDocstring) (ieWrappedName rdr_tc) + let name = greName gre + + -- Look up the children in the sub-names of the parent + -- See Note [Importing DuplicateRecordFields] + let (children_errs, childnames) = lookupChildren subnames rdr_ns + + bad_import_warns <- + if null children_errs then return [] else + let items = map lce_wrapped_name children_errs + ie = IEThingWith (deprecation, ann) ltc wc items noDocstring + -- We are trying to import T( a,b,c,d ), and failed + -- to find 'b' and 'd'. So we make up an import item + -- to report as failing, namely T( b, d ). + -- c.f. #15413 + subordinate_err = mkSubordinateError gre children_errs + in bad_import_w ie subordinate_err + + let name' = replaceWrappedName rdr_tc name + childnames' = map (to_ie_post_rn . fmap greName) childnames + gres = gre : map unLoc childnames + export_depr_warns + | want_hiding == Exactly = mapMaybe mk_depr_export_warning gres + | otherwise = [] + return ([ (IEThingWith (Nothing, ann) (L l name') wc childnames' noDocstring + ,gres)] + , bad_import_warns ++ export_depr_warns) + + _other -> failLookupWith IllegalImport + -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed... + -- all of those constitute errors. + + where + mkIEThingAbs tc l gre + = (IEThingAbs Nothing (L l (replaceWrappedName tc n)) noDocstring, [gre]) + where n = greName gre + + -- N.B. imports never have docstrings + noDocstring = Nothing + + handle_bad_import m = catchIELookup m $ \case + BadImport ie sub -> do + ws <- bad_import_w ie sub + return ([], ws) + err -> failLookupWith err + + bad_import_w :: IE GhcPs -> IsSubordinateError -> IELookupM [IELookupWarning] + bad_import_w ie sub + | want_hiding == EverythingBut = return [BadImportW ie sub] + | otherwise = failLookupWith (BadImport ie sub) + + mk_depr_export_warning gre + = DeprecatedExport name <$> mi_export_warn_fn iface name + where + name = greName gre + +type IELookupM = MaybeErr IELookupError + +data IELookupWarning + = BadImportW (IE GhcPs) IsSubordinateError + | MissingImportList + | DodgyImport GlobalRdrElt + | DeprecatedExport Name (WarningTxt GhcRn) + +-- | Is this import/export item a subordinate or not? +data IsSubordinateError + = IsSubordinateError { subordinate_err_parent :: !GlobalRdrElt + , subordinate_err_unavailable :: [FastString] + , subordinate_err_nontype :: [GlobalRdrElt] + , subordinate_err_nondata :: [GlobalRdrElt] } + | IsNotSubordinate + +mkSubordinateError :: GlobalRdrElt -> [LookupChildError] -> IsSubordinateError +mkSubordinateError gre children_errs = foldr add init_acc children_errs + where + init_acc :: IsSubordinateError + init_acc = IsSubordinateError gre [] [] [] + + add :: LookupChildError -> IsSubordinateError -> IsSubordinateError + add children_err sub@IsSubordinateError{} = + case children_err of + LookupChildNonType{lce_nontype_item = g} -> + sub { subordinate_err_nontype = g : subordinate_err_nontype sub } + LookupChildNonData{lce_nondata_item = g} -> + sub { subordinate_err_nondata = g : subordinate_err_nondata sub } + LookupChildNotFound (L _ wname) -> + let fs = (occNameFS . rdrNameOcc . ieWrappedName) wname + in sub { subordinate_err_unavailable = fs : subordinate_err_unavailable sub } + add _ IsNotSubordinate = panic "mkSubordinateError: IsNotSubordinate" + +data IELookupError + = QualImportError RdrName + | BadImport (IE GhcPs) IsSubordinateError + | IllegalImport + +failLookupWith :: IELookupError -> IELookupM a +failLookupWith err = Failed err + +catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a +catchIELookup m h = case m of + Succeeded r -> return r + Failed err -> h err + +catIELookupM :: [IELookupM a] -> [a] +catIELookupM ms = [ a | Succeeded a <- ms ] + +-- | Information associated to an 'AvailInfo' used in constructing +-- an 'OccEnv' corresponding to imports. +-- +-- See Note [Dealing with imports]. +data ImpOccItem + = ImpOccItem + { imp_item :: GlobalRdrElt + -- ^ The import item + , imp_bundled :: [GlobalRdrElt] + -- ^ Items bundled in the Avail this import item came from, + -- not including the import item itself if it is a parent. + , imp_is_parent :: Bool + -- ^ Is the import item a parent? See Note [Dealing with imports]. + } + +instance Outputable ImpOccItem where + ppr (ImpOccItem { imp_item = item, imp_bundled = bundled, imp_is_parent = is_par }) + = braces $ hsep + [ text "ImpOccItem" + , if is_par then text "[is_par]" else empty + , ppr (greName item) <+> ppr (greParent item) + , braces $ text "bundled:" <+> ppr (map greName bundled) ] + +-- | Make an 'OccEnv' of all the imports. +-- +-- Complicated by the fact that associated data types and pattern synonyms +-- can appear twice. See Note [Dealing with imports]. +mkImportOccEnv :: HscEnv -> ImpDeclSpec -> [IfaceExport] -> OccEnv (NameEnv ImpOccItem) +mkImportOccEnv hsc_env decl_spec all_avails = + mkOccEnv_C (plusNameEnv_C combine) + [ (occ, mkNameEnv [(nm, item)]) + | avail <- all_avails + , let gres = gresFromAvail hsc_env (Just hiding_spec) avail + , gre <- gres + , let nm = greName gre + occ = greOccName gre + (is_parent, bundled) = case avail of + AvailTC c _ + | c == nm -- (Recall the AvailTC invariant from GHC.Types.AvailInfo) + -> ( True, drop 1 gres ) -- "drop 1": don't include the parent itself. + | otherwise + -> ( False, gres ) + _ -> ( False, [] ) + item = ImpOccItem + { imp_item = gre + , imp_bundled = bundled + , imp_is_parent = is_parent } + ] + where + + hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + + -- See Note [Dealing with imports] + -- 'combine' may be called for associated data types which appear + -- twice in the all_avails. In the example, we have two Avails for T, + -- namely T(T,T1,T2,T3) and C(C,T), and we combine them by dropping the + -- latter, in which T is not the parent. + combine :: ImpOccItem -> ImpOccItem -> ImpOccItem + combine item1@(ImpOccItem { imp_item = gre1, imp_is_parent = is_parent1 }) + item2@(ImpOccItem { imp_item = gre2, imp_is_parent = is_parent2 }) + | is_parent1 || is_parent2 + , not (isRecFldGRE gre1 || isRecFldGRE gre2) -- NB: does not force GREInfo. + , let name1 = greName gre1 + name2 = greName gre2 + gre = gre1 `plusGRE` gre2 + -- See Note [Preserve parent information when combining import OccEnvs] + = assertPpr (name1 == name2) + (ppr name1 <+> ppr name2) $ + if is_parent1 + then item1 { imp_item = gre } + else item2 { imp_item = gre } + -- Discard C(C,T) in favour of T(T, T1, T2, T3). + + -- 'combine' may also be called for pattern synonyms which appear both + -- unassociated and associated (see Note [Importing PatternSynonyms]). + combine item1@(ImpOccItem { imp_item = c1, imp_bundled = kids1 }) + item2@(ImpOccItem { imp_item = c2, imp_bundled = kids2 }) + = assertPpr (greName c1 == greName c2 + && (not (null kids1 && null kids2))) + (ppr c1 <+> ppr c2 <+> ppr kids1 <+> ppr kids2) $ + if null kids1 + then item2 + else item1 + -- Discard standalone pattern P in favour of T(P). + +-- | Essentially like @lookupGRE env (LookupOccName occ which_gres)@, +-- but working with 'ImpOccItem's instead of 'GlobalRdrElt's. +lookupImpOccEnv :: WhichGREs GREInfo + -> OccEnv (NameEnv ImpOccItem) -> OccName -> [NameEnv ImpOccItem] +lookupImpOccEnv which_gres env occ = + mapMaybe relevant_items $ lookupOccEnv_AllNameSpaces env occ + where + is_relevant :: ImpOccItem -> Bool + is_relevant (ImpOccItem { imp_item = gre }) = + greIsRelevant which_gres (occNameSpace occ) gre + relevant_items :: NameEnv ImpOccItem -> Maybe (NameEnv ImpOccItem) + relevant_items nms + | let nms' = filterNameEnv is_relevant nms + = if isEmptyNameEnv nms' + then Nothing + else Just nms' + +{- +************************************************************************ +* * +\subsection{Import/Export Utils} +* * +************************************************************************ +-} + +-- | Given an import\/export spec, appropriately set the @gre_imp@ field +-- for the 'GlobalRdrElt's. +gresFromIE :: ImpDeclSpec -> (LIE GhcRn, [GlobalRdrElt]) -> [GlobalRdrElt] +gresFromIE decl_spec (L loc ie, gres) + = map set_gre_imp gres + where + is_explicit = case ie of + IEThingAll _ name _ -> \n -> n == lieWrappedName name + _ -> \_ -> True + prov_fn name + = ImpSpec { is_decl = decl_spec, is_item = item_spec } + where + item_spec = ImpSome { is_explicit = is_explicit name + , is_iloc = locA loc } + set_gre_imp gre@( GRE { gre_name = nm } ) + = gre { gre_imp = unitBag $ prov_fn nm } + +parentOfImplicitlyImportedGRE :: Outputable info => GlobalRdrEltX info -> Maybe Name +parentOfImplicitlyImportedGRE gre = + if any (explicit_import . is_item) $ gre_imp gre + then Nothing + else + case greParent gre of + NoParent -> + pprPanic "parentOfImplicitlyImportedGRE" $ + (text "implicitly imported GRE with no parent" <+> ppr gre) + ParentIs par -> + Just par + where + explicit_import :: ImpItemSpec -> Bool + explicit_import (ImpAll {}) = + pprPanic "parentOfImplicitlyImportedGRE: ImpAll" (ppr gre) + explicit_import (ImpSome { is_explicit }) = is_explicit + +{- Note [Children for duplicate record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the module + + {-# LANGUAGE DuplicateRecordFields #-} + module M (F(foo, MkFInt, MkFBool)) where + data family F a + data instance F Int = MkFInt { foo :: Int } + data instance F Bool = MkFBool { foo :: Bool } + +The `foo` in the export list refers to *both* selectors! For this +reason, lookupChildren builds an environment that maps the FastString +to a list of items, rather than a single item. +-} + +mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] +mkChildEnv gres = foldr add emptyNameEnv gres + where + add gre env = case greParent gre of + ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre + NoParent -> env + +findChildren :: NameEnv [a] -> Name -> [a] +findChildren env n = lookupNameEnv env n `orElse` [] + +data LookupChildError + = LookupChildNotFound { lce_wrapped_name :: !(LIEWrappedName GhcPs) } + | LookupChildNonType { lce_wrapped_name :: !(LIEWrappedName GhcPs) + , lce_nontype_item :: !GlobalRdrElt } + | LookupChildNonData { lce_wrapped_name :: !(LIEWrappedName GhcPs) + , lce_nondata_item :: !GlobalRdrElt } + +lookupChildren :: [GlobalRdrElt] + -> [LIEWrappedName GhcPs] + -> ( [LookupChildError] -- The ones for which the lookup failed + , [LocatedA GlobalRdrElt] ) +-- (lookupChildren all_kids rdr_items) maps each rdr_item to its +-- corresponding Name in all_kids, if the former exists +-- The matching is done by FastString, not OccName, so that +-- Cls( meth, AssocTy ) +-- will correctly find AssocTy among the all_kids of Cls, even though +-- the RdrName for AssocTy may have a (bogus) DataName namespace +-- (Really the rdr_items should be FastStrings in the first place.) +lookupChildren all_kids rdr_items = (fails, successes) + where + mb_xs = map do_one rdr_items + fails = [ err | Failed err <- mb_xs ] + successes = [ ok | Succeeded oks <- mb_xs, ok <- NE.toList oks ] + + do_one :: LIEWrappedName GhcPs -> MaybeErr LookupChildError (NonEmpty (LocatedA GlobalRdrElt)) + do_one item@(L l r) = + case r of + IEName{} + -- IEName (unadorned name) places no restriction on the namespace of + -- the imported entity, so we look in both `val_gres` and `typ_gres`. + -- In case of conflict (punning), the value namespace takes priority. + -- See Note [Prioritise the value namespace in subordinate import lists] + | (gre:gres) <- val_gres -> Succeeded $ fmap (L l) (gre:|gres) + | (gre:gres) <- typ_gres -> Succeeded $ fmap (L l) (gre:|gres) + | otherwise -> Failed $ LookupChildNotFound item + + IEType{} + -- IEType ('type' namespace specifier) restricts the lookup to the + -- type namespace, i.e. to `typ_gres`. In case of failure, we check + -- `val_gres` to produce a more helpful error message. + | (gre:gres) <- typ_gres -> Succeeded $ fmap (L l) (gre:|gres) + | (gre:_) <- val_gres -> Failed $ LookupChildNonType item gre + | otherwise -> Failed $ LookupChildNotFound item + + IEData{} + -- IEData ('data' namespace specifier) restricts the lookup to the + -- data namespace, i.e. to `val_gres`. In case of failure, we check + -- `typ_gres` to produce a more helpful error message. + | (gre:gres) <- val_gres -> Succeeded $ fmap (L l) (gre:|gres) + | (gre:_) <- typ_gres -> Failed $ LookupChildNonData item gre + | otherwise -> Failed $ LookupChildNotFound item + + IEPattern{} -> panic "lookupChildren: IEPattern" -- Never happens (invalid syntax) + IEDefault{} -> panic "lookupChildren: IEDefault" -- Never happens (invalid syntax) + where + fs = (occNameFS . rdrNameOcc . ieWrappedName) r + gres = fromMaybe [] (lookupFsEnv kid_env fs) + (val_gres, typ_gres) = partition (isValNameSpace . greNameSpace) gres + + -- See Note [Children for duplicate record fields] + kid_env :: FastStringEnv [GlobalRdrElt] + kid_env = extendFsEnvList_C (++) emptyFsEnv + [(occNameFS (occName x), [x]) | x <- all_kids] + + +{- Note [Prioritise the value namespace in subordinate import lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this program that defines a class that has both an associated type +named (#) and a method named (#) + + module M_assoc where + class C a b where + type a # b + (#) :: a -> b -> () + module N_assoc where + import M_assoc( C((#)) ) + +In the import declaration, when we see the unadorned name (#) in the subordinate +import list of C, which children should we bring into scope? Our options are: + + a) only the method (#) + b) only the associated type (#) + c) both the method and the associated type + +To follow the precedent established by top-level items, we go with option (a). +Indeed, consider a slightly different program + + module M_top where + type family a # b + a # b = () + module N_top where + import M_top( (#) ) + +Here the import brings only the function (#) into scope, and one has to say +`type (#)` to get the type family. +-} + +------------------------------- + +{- +********************************************************* +* * +\subsection{Unused names} +* * +********************************************************* +-} + +reportUnusedNames :: TcGblEnv -> HscSource -> RnM () +reportUnusedNames gbl_env hsc_src + = do { keep <- readTcRef (tcg_keep gbl_env) + ; traceRn "RUN" (ppr (tcg_dus gbl_env)) + ; warnUnusedImportDecls gbl_env hsc_src + ; warnUnusedTopBinds $ unused_locals keep + ; warnMissingSignatures gbl_env + ; warnMissingKindSignatures gbl_env } + where + used_names :: NameSet -> NameSet + used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep + -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used + -- Hence findUses + + -- Collect the defined names from the in-scope environment + defined_names :: [GlobalRdrElt] + defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) + + kids_env = mkChildEnv defined_names + -- This is done in mkExports too; duplicated work + + gre_is_used :: NameSet -> GlobalRdrElt -> Bool + gre_is_used used_names gre0 + = name `elemNameSet` used_names + || any (\ gre -> greName gre `elemNameSet` used_names) (findChildren kids_env name) + -- A use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + where + name = greName gre0 + + -- Filter out the ones that are + -- (a) defined in this module, and + -- (b) not defined by a 'deriving' clause + -- The latter have an Internal Name, so we can filter them out easily + unused_locals :: NameSet -> [GlobalRdrElt] + unused_locals keep = + let -- Note that defined_and_used, defined_but_not_used + -- are both [GRE]; that's why we need defined_and_used + -- rather than just used_names + _defined_and_used, defined_but_not_used :: [GlobalRdrElt] + (_defined_and_used, defined_but_not_used) + = partition (gre_is_used (used_names keep)) defined_names + + in filter is_unused_local defined_but_not_used + is_unused_local :: GlobalRdrElt -> Bool + is_unused_local gre = isLocalGRE gre + && isExternalName (greName gre) + +{- ********************************************************************* +* * + Missing signatures +* * +********************************************************************* -} + +{- +Note [Missing signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There are four warning flags in play: + + * -Wmissing-exported-signatures + Warn about any exported top-level function/value without a type signature. + Does not include pattern synonyms. + + * -Wmissing-signatures + Warn about any top-level function/value without a type signature. Does not + include pattern synonyms. Takes priority over -Wmissing-exported-signatures. + + * -Wmissing-exported-pattern-synonym-signatures + Warn about any exported pattern synonym without a type signature. + + * -Wmissing-pattern-synonym-signatures + Warn about any pattern synonym without a type signature. Takes priority over + -Wmissing-exported-pattern-synonym-signatures. + +-} + +-- | Warn the user about top level binders that lack type signatures. +-- Called /after/ type inference, so that we can report the +-- inferred type of the function +warnMissingSignatures :: TcGblEnv -> RnM () +warnMissingSignatures gbl_env + = do { let exports = availsToNameSet (tcg_exports gbl_env) + sig_ns = tcg_sigs gbl_env + -- We use sig_ns to exclude top-level bindings that are generated by GHC + binds = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env + pat_syns = tcg_patsyns gbl_env + + not_ghc_generated :: Name -> Bool + not_ghc_generated name = name `elemNameSet` sig_ns + + add_binding_warn :: Id -> RnM () + add_binding_warn id = + when (not_ghc_generated name) $ + do { env <- liftZonkM $ tcInitTidyEnv -- Why not use emptyTidyEnv? + ; let ty = tidyOpenType env (idType id) + missing = MissingTopLevelBindingSig name ty + diag = TcRnMissingSignature missing exported + ; addDiagnosticAt (getSrcSpan name) diag } + where + name = idName id + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported + + add_patsyn_warn :: PatSyn -> RnM () + add_patsyn_warn ps = + when (not_ghc_generated name) $ + addDiagnosticAt (getSrcSpan name) + (TcRnMissingSignature missing exported) + where + name = patSynName ps + missing = MissingPatSynSig ps + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported + + -- Warn about missing signatures + -- Do this only when we have a type to offer + -- See Note [Missing signatures] + ; mapM_ add_binding_warn binds + ; mapM_ add_patsyn_warn pat_syns + } + +-- | Warn the user about tycons that lack kind signatures. +-- Called /after/ type (and kind) inference, so that we can report the +-- inferred kinds. +warnMissingKindSignatures :: TcGblEnv -> RnM () +warnMissingKindSignatures gbl_env + = do { cusks_enabled <- xoptM LangExt.CUSKs + ; mapM_ (add_ty_warn cusks_enabled) tcs + } + where + tcs = tcg_tcs gbl_env + ksig_ns = tcg_ksigs gbl_env + exports = availsToNameSet (tcg_exports gbl_env) + + has_kind_signature :: Name -> Bool + has_kind_signature name = name `elemNameSet` ksig_ns + + add_ty_warn :: Bool -> TyCon -> RnM () + add_ty_warn cusks_enabled tyCon = + when (has_kind_signature name) $ + addDiagnosticAt (getSrcSpan name) diag + where + name = tyConName tyCon + diag = TcRnMissingSignature missing exported + missing = MissingTyConKindSig tyCon cusks_enabled + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported + +{- +********************************************************* +* * +\subsection{Unused imports} +* * +********************************************************* + +This code finds which import declarations are unused. The +specification and implementation notes are here: + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports + +See also Note [Choosing the best import declaration] in GHC.Types.Name.Reader +-} + +type ImportDeclUsage + = ( LImportDecl GhcRn -- The import declaration + , [GlobalRdrElt] -- What *is* used (normalised) + , [Name] ) -- What is imported but *not* used + +warnUnusedImportDecls :: TcGblEnv -> HscSource -> RnM () +warnUnusedImportDecls gbl_env hsc_src + = do { uses <- readMutVar (tcg_used_gres gbl_env) + ; let user_imports = filterOut + (ideclImplicit . ideclExt . unLoc) + (tcg_rn_imports gbl_env) + -- This whole function deals only with *user* imports + -- both for warning about unnecessary ones, and for + -- deciding the minimal ones + rdr_env = tcg_rdr_env gbl_env + + ; let usage :: [ImportDeclUsage] + usage = findImportUsage user_imports uses + + ; traceRn "warnUnusedImportDecls" $ + (vcat [ text "Uses:" <+> ppr uses + , text "Import usage" <+> ppr usage]) + + ; mapM_ (warnUnusedImport rdr_env) usage + + ; whenGOptM Opt_D_dump_minimal_imports $ + printMinimalImports hsc_src usage } + +findImportUsage :: [LImportDecl GhcRn] + -> [GlobalRdrElt] + -> [ImportDeclUsage] + +findImportUsage imports used_gres + = map unused_decl imports + where + import_usage :: ImportMap + import_usage = mkImportMap used_gres + + unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name]) + unused_decl decl@(L loc (ImportDecl { ideclImportList = imps })) + = (decl, used_gres, nameSetElemsStable unused_imps) + where + used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage + -- srcSpanEnd: see Note [The ImportMap] + `orElse` [] + + used_gre_env = mkGlobalRdrEnv used_gres + used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) + + unused_imps -- Not trivial; see eg #7454 + = case imps of + Just (Exactly, L _ imp_ies) -> + let unused = foldr (add_unused . unLoc) (UnusedNames emptyNameSet emptyFsEnv) imp_ies + in collectUnusedNames unused + _other -> emptyNameSet -- No explicit import list => no unused-name list + + add_unused :: IE GhcRn -> UnusedNames -> UnusedNames + add_unused (IEVar _ n _) acc = add_unused_name (lieWrappedName n) True acc + add_unused (IEThingAbs _ n _) acc = add_unused_name (lieWrappedName n) False acc + add_unused (IEThingAll _ n _) acc = add_unused_all (lieWrappedName n) acc + add_unused (IEThingWith _ p wc ns _) acc = add_wc_all (add_unused_with pn xs acc) + where pn = lieWrappedName p + xs = map lieWrappedName ns + add_wc_all = case wc of + NoIEWildcard -> id + IEWildcard _ -> add_unused_all pn + add_unused _ acc = acc + + add_unused_name :: Name -> Bool -> UnusedNames -> UnusedNames + add_unused_name n is_ie_var acc@(UnusedNames acc_ns acc_fs) + | is_ie_var + , isFieldName n + -- See Note [Reporting unused imported duplicate record fields] + = let + fs = getOccFS n + (flds, flds_used) = lookupFsEnv acc_fs fs `orElse` (emptyNameSet, Any False) + acc_fs' = extendFsEnv acc_fs fs (extendNameSet flds n, Any used S.<> flds_used) + in UnusedNames acc_ns acc_fs' + | used + = acc + | otherwise + = UnusedNames (acc_ns `extendNameSet` n) acc_fs + where + used = isJust $ lookupGRE_Name used_gre_env n + + add_unused_all :: Name -> UnusedNames -> UnusedNames + add_unused_all n (UnusedNames acc_ns acc_fs) + | Just {} <- lookupGRE_Name used_gre_env n = UnusedNames acc_ns acc_fs + | n `elemNameSet` used_parents = UnusedNames acc_ns acc_fs + | otherwise = UnusedNames (acc_ns `extendNameSet` n) acc_fs + + add_unused_with :: Name -> [Name] -> UnusedNames -> UnusedNames + add_unused_with p ns acc + | all (`elemNameSet` acc1_ns) ns = add_unused_name p False acc1 + | otherwise = acc1 + where + acc1@(UnusedNames acc1_ns _acc1_fs) = foldr (\n acc' -> add_unused_name n False acc') acc ns + -- If you use 'signum' from Num, then the user may well have + -- imported Num(signum). We don't want to complain that + -- Num is not itself mentioned. Hence the two cases in add_unused_with. + + +-- | An accumulator for unused names in an import list. +-- +-- See Note [Reporting unused imported duplicate record fields]. +data UnusedNames = + UnusedNames + { unused_names :: NameSet + -- ^ Unused 'Name's in an import list, not including record fields + -- that are plain 'IEVar' imports + , rec_fld_uses :: FastStringEnv (NameSet, Any) + -- ^ Record fields imported without a parent (i.e. an 'IEVar' import). + -- + -- The 'Any' value records whether any of the record fields + -- sharing the same underlying 'FastString' have been used. + } +instance Outputable UnusedNames where + ppr (UnusedNames nms flds) = + text "UnusedNames" <+> + braces (ppr nms <+> ppr (fmap (second getAny) flds)) + +-- | Collect all unused names from a 'UnusedNames' value. +collectUnusedNames :: UnusedNames -> NameSet +collectUnusedNames (UnusedNames { unused_names = nms, rec_fld_uses = flds }) + = nms S.<> unused_flds + where + unused_flds = nonDetFoldFsEnv collect_unused emptyNameSet flds + collect_unused :: (NameSet, Any) -> NameSet -> NameSet + collect_unused (nms, Any at_least_one_name_is_used) acc + | at_least_one_name_is_used = acc + | otherwise = unionNameSet nms acc + +{- Note [Reporting unused imported duplicate record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#24035): + + {-# LANGUAGE DuplicateRecordFields #-} + module M1 (R1(..), R2(..)) where + data R1 = MkR1 { fld :: Int } + data R2 = MkR2 { fld :: Int } + + {-# LANGUAGE DuplicateRecordFields #-} + module M2 where + import M1 (R1(MkR1), R2, fld) + f :: R1 -> Int + f (MkR1 { fld = x }) = x + g :: R2 -> Int + g _ = 3 + +In the import of 'M1' in 'M2', the 'fld' import resolves to two separate GREs, +namely R1(fld) and R2(fld). From the perspective of the renamer, and in particular +the 'findImportUsage' function, it's as if the user had imported the two names +separately (even though no source syntax allows that). + +This means that we need to be careful when reporting unused imports: the R2(fld) +import is indeed unused, but because R1(fld) is used, we should not report +fld as unused altogether. + +To achieve this, we keep track of record field imports without a parent (i.e. +using the IEVar constructor) separately from other import items, using the +UnusedNames datatype. +Once we have accumulated usages, we emit warnings for unused record fields +without parents one whole group (of record fields sharing the same textual name) +at a time, and only if *all* of the record fields in the group are unused; +see 'collectUnusedNames'. + +Note that this only applies to record fields imported without a parent. If we +had: + + import M1 (R1(MkR1, fld), R2(fld)) + f :: R1 -> Int + f (MkR1 { fld = x }) = x + g :: R2 -> Int + g _ = 3 + +then of course we should report the second 'fld' as unused. +-} + + +{- Note [The ImportMap] +~~~~~~~~~~~~~~~~~~~~~~~ +The ImportMap is a short-lived intermediate data structure records, for +each import declaration, what stuff brought into scope by that +declaration is actually used in the module. + +The SrcLoc is the location of the END of a particular 'import' +declaration. Why *END*? Because we don't want to get confused +by the implicit Prelude import. Consider (#7476) the module + import Foo( foo ) + main = print foo +There is an implicit 'import Prelude(print)', and it gets a SrcSpan +of line 1:1 (just the point, not a span). If we use the *START* of +the SrcSpan to identify the import decl, we'll confuse the implicit +import Prelude with the explicit 'import Foo'. So we use the END. +It's just a cheap hack; we could equally well use the Span too. + +The [GlobalRdrElt] are the things imported from that decl. +-} + +type ImportMap = Map RealSrcLoc [GlobalRdrElt] -- See [The ImportMap] + -- If loc :-> gres, then + -- 'loc' = the end loc of the bestImport of each GRE in 'gres' + +mkImportMap :: [GlobalRdrElt] -> ImportMap +-- For each of a list of used GREs, find all the import decls that brought +-- it into scope; choose one of them (bestImport), and record +-- the RdrName in that import decl's entry in the ImportMap +mkImportMap gres + = foldr add_one Map.empty gres + where + add_one gre@(GRE { gre_imp = imp_specs }) imp_map = + case srcSpanEnd (is_dloc (is_decl best_imp_spec)) of + -- For srcSpanEnd see Note [The ImportMap] + RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map + UnhelpfulLoc _ -> imp_map + where + best_imp_spec = + case bagToList imp_specs of + [] -> pprPanic "mkImportMap: GRE with no ImportSpecs" (ppr gre) + is:iss -> bestImport (is NE.:| iss) + add _ gres = gre : gres + +warnUnusedImport :: GlobalRdrEnv -> ImportDeclUsage -> RnM () +warnUnusedImport rdr_env (L loc decl, used, unused) + + -- Do not warn for 'import M()' + | Just (Exactly, L _ []) <- ideclImportList decl + = return () + + -- Note [Do not warn about Prelude hiding] + | Just (EverythingBut, L _ hides) <- ideclImportList decl + , not (null hides) + , pRELUDE_NAME == unLoc (ideclName decl) + = return () + + -- Nothing used; drop entire declaration + | null used + = addDiagnosticAt (locA loc) (TcRnUnusedImport decl UnusedImportNone) + + -- Everything imported is used; nop + | null unused + = return () + + -- Some imports are unused: make the `SrcSpan` cover only the unused + -- items instead of the whole import statement + | Just (_, L _ imports) <- ideclImportList decl + , let unused_locs = [ locA loc | L loc ie <- imports + , name <- ieNames ie + , name `elem` unused ] + , loc1 : locs <- unused_locs + , let span = foldr1 combineSrcSpans ( loc1 NE.:| locs ) + = addDiagnosticAt span (TcRnUnusedImport decl (UnusedImportSome sort_unused)) + + -- Some imports are unused + | otherwise + = addDiagnosticAt (locA loc) (TcRnUnusedImport decl (UnusedImportSome sort_unused)) + + where + -- In warning message, pretty-print identifiers unqualified unconditionally + -- to improve the consistent for ambiguous/unambiguous identifiers. + -- See #14881. + possible_field n = + case lookupGRE_Name rdr_env n of + Just (GRE { gre_par = par, gre_info = IAmRecField info }) -> + let fld_occ :: OccName + fld_occ = nameOccName $ flSelector $ recFieldLabel info + in UnusedImportNameRecField par fld_occ + _ -> UnusedImportNameRegular n + + -- Print unused names in a deterministic (lexicographic) order + sort_unused :: [UnusedImportName] + sort_unused = fmap possible_field $ + sortBy (comparing nameOccName) unused + +{- +Note [Do not warn about Prelude hiding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not warn about + import Prelude hiding( x, y ) +because even if nothing else from Prelude is used, it may be essential to hide +x,y to avoid name-shadowing warnings. Example (#9061) + import Prelude hiding( log ) + f x = log where log = () + + + +Note [Printing minimal imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To print the minimal imports we walk over the user-supplied import +decls, and simply trim their import lists. NB that + + * We do *not* change the 'qualified' or 'as' parts! + + * We do not discard a decl altogether; we might need instances + from it. Instead we just trim to an empty import list +-} + +getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn] +getMinimalImports ie_decls + = do { rdr_env <- getGlobalRdrEnv + ; fmap combine $ mapM (mk_minimal rdr_env) ie_decls } + where + mk_minimal rdr_env (L l decl, used_gres, unused) + | null unused + , Just (Exactly, _) <- ideclImportList decl + = return (L l decl) + | otherwise + = do { let ImportDecl { ideclName = L _ mod_name + , ideclSource = is_boot + , ideclPkgQual = pkg_qual } = decl + ; iface <- loadSrcInterface doc mod_name is_boot pkg_qual + ; let used_avails = gresToAvailInfo used_gres + ; lies <- map (L l) <$> concatMapM (to_ie rdr_env iface) used_avails + ; return (L l (decl { ideclImportList = Just (Exactly, L (l2l l) lies) })) } + where + doc = text "Compute minimal imports for" <+> ppr decl + + to_ie :: GlobalRdrEnv -> ModIface -> AvailInfo -> RnM [IE GhcRn] + -- The main trick here is that if we're importing all the constructors + -- we want to say "T(..)", but if we're importing only a subset we want + -- to say "T(A,B,C)". So we have to find out what the module exports. + to_ie rdr_env _ (Avail c) -- Note [Overloaded field import] + = do { let + gre = expectJust $ lookupGRE_Name rdr_env c + ; return $ [IEVar Nothing (to_ie_post_rn $ noLocA $ greName gre) Nothing] } + to_ie _ _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else + | availExportsDecl avail + = return [IEThingAbs Nothing (to_ie_post_rn $ noLocA n) Nothing] + to_ie rdr_env iface (AvailTC n cs) = + case [ xs | avail@(AvailTC x xs) <- mi_exports iface + , x == n + , availExportsDecl avail -- Note [Partial export] + ] of + [xs] + | all_used xs + -> return [IEThingAll (Nothing, noAnn) (to_ie_post_rn $ noLocA n) Nothing] + | otherwise + -> do { let ns_gres = map (expectJust . lookupGRE_Name rdr_env) cs + ns = map greName ns_gres + ; return [IEThingWith (Nothing, noAnn) (to_ie_post_rn $ noLocA n) NoIEWildcard + (map (to_ie_post_rn . noLocA) (filter (/= n) ns)) Nothing] } + -- Note [Overloaded field import] + _other + -> do { let infos = map (expectJust . lookupGRE_Name rdr_env) cs + (ns_gres,fs_gres) = classifyGREs infos + ns = map greName (ns_gres ++ fs_gres) + fs = map fieldGREInfo fs_gres + ; return $ + if all_non_overloaded fs + then map (\nm -> IEVar Nothing (to_ie_post_rn_var $ noLocA nm) Nothing) ns + else [IEThingWith (Nothing, noAnn) (to_ie_post_rn $ noLocA n) NoIEWildcard + (map (to_ie_post_rn . noLocA) (filter (/= n) ns)) Nothing] } + where + + all_used avail_cs = all (`elem` cs) avail_cs + + all_non_overloaded = all (not . flIsOverloaded . recFieldLabel) + + combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn] + combine = map merge . NE.groupAllWith getKey + + getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName) + getKey decl = + ( isImportDeclQualified . ideclQualified $ idecl -- is this qualified? (important that this be first) + , unLoc <$> ideclAs idecl -- what is the qualifier (inside Maybe monad) + , unLoc . ideclName $ idecl -- Module Name + ) + where + idecl :: ImportDecl GhcRn + idecl = unLoc decl + + merge :: NonEmpty (LImportDecl GhcRn) -> LImportDecl GhcRn + merge decls@((L l decl) :| _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) }) + where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) $ NE.toList decls + +classifyGREs :: [GlobalRdrElt] -> ([GlobalRdrElt], [FieldGlobalRdrElt]) +classifyGREs = partition (not . isRecFldGRE) + +printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM () +-- See Note [Printing minimal imports] +printMinimalImports hsc_src imports_w_usage + = do { imports' <- getMinimalImports imports_w_usage + ; this_mod <- getModule + ; dflags <- getDynFlags + ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h -> + printForUser dflags h neverQualify AllTheWay (vcat (map ppr imports')) + -- The neverQualify is important. We are printing Names + -- but they are in the context of an 'import' decl, and + -- we never qualify things inside there + -- E.g. import Blag( f, b ) + -- not import Blag( Blag.f, Blag.g )! + } + where + mkFilename dflags this_mod + | Just d <- dumpDir dflags = d basefn + | otherwise = basefn + where + suffix = case hsc_src of + HsBootFile -> ".imports-boot" + HsSrcFile -> ".imports" + HsigFile -> ".imports" + basefn = moduleNameString (moduleName this_mod) ++ suffix + + +to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn +to_ie_post_rn_var (L l n) + | isDataOcc $ occName n = L l (IEPattern noAnn (L (l2l l) n)) + | otherwise = L l (IEName noExtField (L (l2l l) n)) + + +to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn +to_ie_post_rn (L l n) + | isTcOcc occ && isSymOcc occ = L l (IEType noAnn (L (l2l l) n)) + | otherwise = L l (IEName noExtField (L (l2l l) n)) + where occ = occName n + +{- +Note [Partial export] +~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + module A( op ) where + class C a where + op :: a -> a + + module B where + import A + f = ..op... + +Then the minimal import for module B is + import A( op ) +not + import A( C( op ) ) +which we would usually generate if C was exported from B. Hence +the availExportsDecl test when deciding what to generate. + + +Note [Overloaded field import] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On the other hand, if we have + + {-# LANGUAGE DuplicateRecordFields #-} + module A where + data T = MkT { foo :: Int } + + module B where + import A + f = ...foo... + +then the minimal import for module B must be + import A ( T(foo) ) +because when DuplicateRecordFields is enabled, field selectors are +not in scope without their enclosing datatype. + +On the third hand, if we have + + {-# LANGUAGE DuplicateRecordFields #-} + module A where + pattern MkT { foo } = Just foo + + module B where + import A + f = ...foo... + +then the minimal import for module B must be + import A ( foo ) +because foo doesn't have a parent. This might actually be ambiguous if A +exports another field called foo, but there is no good answer to return and this +is a very obscure corner, so it seems to be the best we can do. See +DRFPatSynExport for a test of this. + + +************************************************************************ +* * +\subsection{Errors} +* * +************************************************************************ +-} + +badImportItemErr + :: ModIface -> ImpDeclSpec -> IE GhcPs + -> IsSubordinateError + -> [AvailInfo] + -> TcRn (NonEmpty ImportLookupReason) +badImportItemErr iface decl_spec ie sub avails = do + exts <- importLookupExtensions + let import_lookup_bad :: BadImportKind -> ImportLookupReason + import_lookup_bad k = ImportLookupBad k iface decl_spec ie exts + dflags <- getDynFlags + hsc_env <- getTopEnv + let rdr_env = mkGlobalRdrEnv + $ gresFromAvails hsc_env (Just imp_spec) all_avails + pure $ fmap import_lookup_bad (importErrorKind dflags rdr_env) + where + importErrorKind :: DynFlags -> GlobalRdrEnv -> NonEmpty BadImportKind + importErrorKind dflags rdr_env + | any checkIfTyCon avails = case sub of + IsNotSubordinate -> NE.singleton BadImportAvailTyCon + IsSubordinateError { subordinate_err_parent = gre + , subordinate_err_unavailable = unavailable + , subordinate_err_nontype = nontype + , subordinate_err_nondata = nondata } + -> NE.fromList $ catMaybes $ + [ fmap (BadImportNotExportedSubordinates gre) (NE.nonEmpty unavailable) + , fmap (BadImportNonTypeSubordinates gre) (NE.nonEmpty nontype) + , fmap (BadImportNonDataSubordinates gre) (NE.nonEmpty nondata) ] + | any checkIfVarName avails = NE.singleton BadImportAvailVar + | Just con <- find checkIfDataCon avails = NE.singleton (BadImportAvailDataCon (availOccName con)) + | otherwise = NE.singleton (BadImportNotExported suggs) + where + suggs = similar_suggs ++ fieldSelectorSuggestions rdr_env rdr + what_look = case sub of + IsNotSubordinate -> WL_TyCon_or_TermVar + IsSubordinateError { subordinate_err_parent = gre } -> + case greInfo gre of + IAmTyCon ClassFlavour + -> WL_TyCon_or_TermVar + _ -> WL_Term + similar_names = + similarNameSuggestions (Unbound.LF what_look WL_Global) + dflags rdr_env emptyLocalRdrEnv rdr + similar_suggs = + case NE.nonEmpty $ mapMaybe imported_item $ similar_names of + Just similar -> [ SuggestSimilarNames rdr similar ] + Nothing -> [ ] + + -- Only keep imported items, and set the "HowInScope" to + -- "Nothing" to avoid printing "imported from..." in the suggestion + -- error message. + imported_item (SimilarRdrName rdr_name (Just (ImportedBy {}))) + = Just (SimilarRdrName rdr_name Nothing) + imported_item _ = Nothing + + checkIfDataCon = checkIfAvailMatches isDataConName + checkIfTyCon = checkIfAvailMatches isTyConName + checkIfVarName = + \case + AvailTC{} -> False + Avail n -> importedFS == occNameFS (occName n) + && (isVarOcc <||> isFieldOcc) (occName n) + checkIfAvailMatches namePred = + \case + AvailTC _ ns -> + case find (\n -> importedFS == occNameFS (occName n)) ns of + Just n -> namePred n + Nothing -> False + Avail{} -> False + availOccName = occName . availName + rdr = ieName ie + importedFS = occNameFS $ rdrNameOcc rdr + imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + all_avails = mi_exports iface + +importLookupExtensions :: TcRn ImportLookupExtensions +importLookupExtensions = do + ile_pattern_synonyms <- xoptM LangExt.PatternSynonyms + ile_explicit_namespaces <- xoptM LangExt.ExplicitNamespaces + return ImportLookupExtensions{ile_pattern_synonyms, ile_explicit_namespaces} + +addDupDeclErr :: NonEmpty GlobalRdrElt -> TcRn () +addDupDeclErr gres@(gre :| _) + -- Report the error at the later location + = addErrAt (getSrcSpan (NE.last sorted_names)) $ (TcRnDuplicateDecls (greOccName gre) sorted_names) + where + sorted_names = + NE.sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) + (fmap greName gres) + +-- This data decl will parse OK +-- data T = a Int +-- treating "a" as the constructor. +-- It is really hard to make the parser spot this malformation. +-- So the renamer has to check that the constructor is legal +-- +-- We can get an operator as the constructor, even in the prefix form: +-- data T = :% Int Int +-- from interface files, which always print in prefix form +-- +-- We also allow type constructor names, which are defined by "type data" +-- declarations. See Note [Type data declarations] in GHC.Rename.Module. + +checkConName :: RdrName -> TcRn () +checkConName name + = checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name) + diff --git a/GHC/Rename/Pat.hs b/GHC/Rename/Pat.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Pat.hs @@ -0,0 +1,1560 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use camelCase" #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Renaming of patterns + +Basically dependency analysis. + +Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In +general, all of these functions return a renamed thing, and a set of +free variables. +-} +module GHC.Rename.Pat (-- main entry points + rnPat, rnPats, rnBindPat, + + NameMaker, applyNameMaker, -- a utility for making names: + localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names, + -- sometimes we want to make top (qualified) names. + isTopRecNameMaker, + + rnHsRecFields, HsRecFieldContext(..), + rnHsRecUpdFields, + + -- CpsRn monad + CpsRn, liftCps, liftCpsWithCont, + + -- Literals + rnLit, rnOverLit, + ) where + +-- ENH: thin imports to only what is necessary for patterns + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) +import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat, rnSpliceTyPat ) + +import GHC.Hs +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType ( hsOverLitName ) +import GHC.Rename.Doc (rnLHsDoc) +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( newLocalBndrRn, bindLocalNames + , warnUnusedMatches, newLocalBndrRn + , checkUnusedRecordWildcard + , checkDupNames, checkDupAndShadowedNames + , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, delLocalNames, typeAppErr ) +import GHC.Rename.HsType +import GHC.Builtin.Names + +import GHC.Types.Hint +import GHC.Types.Fixity (LexicalFixity(..)) +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.Unique.Set +import GHC.Types.Basic +import GHC.Types.SourceText + +import GHC.Data.FastString ( uniqCompareFS ) +import GHC.Data.List.SetOps( removeDups ) + +import GHC.Utils.Misc +import GHC.Utils.Panic.Plain +import GHC.Types.SrcLoc +import GHC.Types.Literal ( inCharRange ) +import GHC.Types.GREInfo ( ConInfo(..), conInfoFields, ConFieldInfo (..) ) +import GHC.Builtin.Types ( nilDataCon ) +import GHC.Core.DataCon +import GHC.Core.TyCon ( isKindName ) +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad ( when, ap, guard, unless ) +import Data.Foldable +import Data.Function ( on ) +import Data.Functor.Identity ( Identity (..) ) +import qualified Data.List.NonEmpty as NE +import Data.Ratio +import Control.Monad.Trans.Writer.CPS +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Data.Functor ((<&>)) +import Data.Coerce + +{- +********************************************************* +* * + The CpsRn Monad +* * +********************************************************* + +Note [CpsRn monad] +~~~~~~~~~~~~~~~~~~ +The CpsRn monad uses continuation-passing style to support this +style of programming: + + do { ... + ; ns <- bindNames rs + ; ...blah... } + + where rs::[RdrName], ns::[Name] + +The idea is that '...blah...' + a) sees the bindings of ns + b) returns the free variables it mentions + so that bindNames can report unused ones + +In particular, + mapM rnPatAndThen [p1, p2, p3] +has a *left-to-right* scoping: it makes the binders in +p1 scope over p2,p3. +-} + +newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars)) + -> RnM (r, FreeVars) } + deriving (Functor) + -- See Note [CpsRn monad] + +instance Applicative CpsRn where + pure x = CpsRn (\k -> k x) + (<*>) = ap + +instance Monad CpsRn where + (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k)) + +runCps :: CpsRn a -> RnM (a, FreeVars) +runCps (CpsRn m) = m (\r -> return (r, emptyFVs)) + +liftCps :: RnM a -> CpsRn a +liftCps rn_thing = CpsRn (\k -> rn_thing >>= k) + +liftCpsFV :: RnM (a, FreeVars) -> CpsRn a +liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing + ; (r,fvs2) <- k v + ; return (r, fvs1 `plusFV` fvs2) }) + +liftCpsWithCont :: (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)) -> CpsRn b +liftCpsWithCont = CpsRn + +wrapSrcSpanCps :: (a -> CpsRn b) -> LocatedA a -> CpsRn (LocatedA b) +-- Set the location, and also wrap it around the value returned +wrapSrcSpanCps fn (L loc a) + = CpsRn (\k -> setSrcSpanA loc $ + unCpsRn (fn a) $ \v -> + k (L loc v)) + +lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN (WithUserRdr Name)) +lookupConCps lcon_rdr@(L _ con_rdr) + = CpsRn $ \k -> + do { con_name <- lookupLocatedOccRnConstr lcon_rdr + ; (r, fvs) <- k (fmap (WithUserRdr con_rdr) con_name) + ; return (r, addOneFV fvs (unLoc con_name)) } + -- We add the constructor name to the free vars + -- See Note [Patterns are uses] + +{- +Note [Patterns are uses] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + module Foo( f, g ) where + data T = T1 | T2 + + f T1 = True + f T2 = False + + g _ = T1 + +Arguably we should report T2 as unused, even though it appears in a +pattern, because it never occurs in a constructed position. +See #7336. +However, implementing this in the face of pattern synonyms would be +less straightforward, since given two pattern synonyms + + pattern P1 <- P2 + pattern P2 <- () + +we need to observe the dependency between P1 and P2 so that type +checking can be done in the correct order (just like for value +bindings). Dependencies between bindings is analyzed in the renamer, +where we don't know yet whether P2 is a constructor or a pattern +synonym. So for now, we do report conid occurrences in patterns as +uses. + +********************************************************* +* * + Name makers +* * +********************************************************* + +Externally abstract type of name makers, +which is how you go from a RdrName to a Name +-} + +data NameMaker + = LamMk -- Lambdas + Bool -- True <=> report unused bindings + -- (even if True, the warning only comes out + -- if -Wunused-matches is on) + + | LetMk -- Let bindings, incl top level + -- Do *not* check for unused bindings + TopLevelFlag + MiniFixityEnv + +topRecNameMaker :: MiniFixityEnv -> NameMaker +topRecNameMaker fix_env = LetMk TopLevel fix_env + +isTopRecNameMaker :: NameMaker -> Bool +isTopRecNameMaker (LetMk TopLevel _) = True +isTopRecNameMaker _ = False + +localRecNameMaker :: MiniFixityEnv -> NameMaker +localRecNameMaker fix_env = LetMk NotTopLevel fix_env + +matchNameMaker :: HsMatchContext fn -> NameMaker +matchNameMaker ctxt = LamMk report_unused + where + -- Do not report unused names in interactive contexts + -- i.e. when you type 'x <- e' at the GHCi prompt + report_unused = case ctxt of + StmtCtxt (HsDoStmt GhciStmtCtxt) -> False + -- also, don't warn in pattern quotes, as there + -- is no RHS where the variables can be used! + ThPatQuote -> False + _ -> True + +newPatLName :: NameMaker -> LocatedN RdrName -> CpsRn (LocatedN Name) +newPatLName name_maker rdr_name@(L loc _) + = do { name <- newPatName name_maker rdr_name + ; return (L loc name) } + +newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name +newPatName (LamMk report_unused) rdr_name + = CpsRn (\ thing_inside -> + do { name <- newLocalBndrRn rdr_name + ; (res, fvs) <- bindLocalNames [name] (thing_inside name) + ; when report_unused $ warnUnusedMatches [name] fvs + ; return (res, name `delFV` fvs) }) + +newPatName (LetMk is_top fix_env) rdr_name + = CpsRn (\ thing_inside -> + do { name <- case is_top of + NotTopLevel -> newLocalBndrRn rdr_name + TopLevel -> newTopSrcBinder rdr_name + ; bindLocalNames [name] $ + -- Do *not* use bindLocalNameFV here; + -- see Note [View pattern usage] + -- For the TopLevel case + -- see Note [bindLocalNames for an External name] + addLocalFixities fix_env [name] $ + thing_inside name }) + +{- Note [bindLocalNames for an External name] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the TopLevel case, the use of bindLocalNames here is somewhat +suspicious because it binds a top-level External name in the +LocalRdrEnv. c.f. Note [LocalRdrEnv] in GHC.Types.Name.Reader. + +However, this only happens when renaming the LHS (only) of a top-level +pattern binding. Even though this only the LHS, we need to bring the +binder into scope in the pattern itself in case the binder is used in +subsequent view patterns. A bit bizarre, something like + (x, Just y <- f x) = e + +Anyway, bindLocalNames does work, and the binding only exists for the +duration of the pattern; then the top-level name is added to the +global env before going on to the RHSes (see GHC.Rename.Module). + +Note [View pattern usage] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let (r, (r -> x)) = x in ... +Here the pattern binds 'r', and then uses it *only* in the view pattern. +We want to "see" this use, and in let-bindings we collect all uses and +report unused variables at the binding level. So we must use bindLocalNames +here, *not* bindLocalNameFV. #3943. + + +Note [Don't report shadowing for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is one special context where a pattern doesn't introduce any new binders - +pattern synonym declarations. Therefore we don't check to see if pattern +variables shadow existing identifiers as they are never bound to anything +and have no scope. + +Without this check, there would be quite a cryptic warning that the `x` +in the RHS of the pattern synonym declaration shadowed the top level `x`. + +``` +x :: () +x = () + +pattern P x = Just x +``` + +See #12615 for some more examples. + +Note [Handling overloaded and rebindable patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Overloaded patterns and rebindable patterns are desugared in the renamer +using the HsPatExpansion mechanism detailed in: +Note [Rebindable syntax and XXExprGhcRn] +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 XXExprGhcRn]. + +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 the type being matched on is already a list type, so that the +pattern looks like + toList @[ty] dict -> pat +then we know for certain that `toList` is an identity function, so we can +behave exactly as if the pattern was just `pat`. This is important when +we have `OverloadedLists`. For example (#14547, #25257) + +> {-# 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. +(NB: Because of -XRebindableSyntax we have to check that the `toList` we see is +actually resolved to `GHC.Exts.toList`.) + +Note however that this is not necessarily sound, because it is possible to have +a list `l` such that `toList l` is not the same as `l`. +This can happen with an overlapping instance, such as the following: + +instance {-# OVERLAPPING #-} IsList [Int] where + type Item [Int] = Int + toList = reverse + fromList = reverse + +We make the assumption that no such instance exists, in order to avoid worsening +pattern-match warnings (see #14547). + +********************************************************* +* * + External entry points +* * +********************************************************* + +There are various entry points to renaming patterns, depending on + (1) whether the names created should be top-level names or local names + (2) whether the scope of the names is entirely given in a continuation + (e.g., in a case or lambda, but not in a let or at the top-level, + because of the way mutually recursive bindings are handled) + (3) whether the a type signature in the pattern can bind + lexically-scoped type variables (for unpacking existential + type vars in data constructors) + (4) whether we do duplicate and unused variable checking + (5) whether there are fixity declarations associated with the names + bound by the patterns that need to be brought into scope with them. + + Rather than burdening the clients of this module with all of these choices, + we export the three points in this design space that we actually need: +-} + +-- ----------- Entry point 1: rnPats ------------------- +-- Binds local names; the scope of the bindings is entirely in the thing_inside +-- * allows type sigs to bind type vars +-- * local namemaker +-- * unused and duplicate checking +-- * no fixities + +-- rn_pats_general is the generalisation of two functions: +-- rnPats, rnPat +-- Those are the only call sites, so we inline it for improved performance. +-- Kind of like a macro. +{-# INLINE rn_pats_general #-} +rn_pats_general :: Traversable f => HsMatchContextRn + -> f (LPat GhcPs) + -> (f (LPat GhcRn) -> RnM (r, FreeVars)) + -> RnM (r, FreeVars) +rn_pats_general ctxt pats thing_inside = do + envs_before <- getRdrEnvs + + -- (1) rename the patterns, bringing into scope all of the term variables + -- (2) then do the thing inside. + unCpsRn (rn_pats_fun (matchNameMaker ctxt) pats) $ \ pats' -> do + -- Check for duplicated and shadowed names + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in GHC.Hs.Utils + -- Because we don't bind the vars all at once, we can't + -- check incrementally for duplicates; + -- Nor can we check incrementally for shadowing, else we'll + -- complain *twice* about duplicates e.g. f (x,x) = ... + -- + -- See Note [Don't report shadowing for pattern synonyms] + let bndrs = collectPatsBinders CollVarTyVarBinders (toList pats') + addErrCtxt (MatchCtxt ctxt) $ + if isPatSynCtxt ctxt + then checkDupNames bndrs + else checkDupAndShadowedNames envs_before bndrs + thing_inside pats' + where + + -- See Note [Invisible binders in functions] in GHC.Hs.Pat + -- + -- BTW, Or-patterns would be awesome here + rn_pats_fun = case ctxt of + FunRhs{} -> mapM . rnLArgPatAndThen + LamAlt LamSingle -> mapM . rnLArgPatAndThen + LamAlt LamCases -> mapM . rnLArgPatAndThen + _ -> mapM . rnLPatAndThen + +rnPats :: HsMatchContextRn -- For error messages and choosing if @-patterns are allowed + -> [LPat GhcPs] + -> ([LPat GhcRn] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnPats = rn_pats_general + +rnPat :: forall a. HsMatchContextRn -- For error messages and choosing if @-patterns are allowed + -> LPat GhcPs + -> (LPat GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) -- Variables bound by pattern do not + -- appear in the result FreeVars +rnPat + = coerce (rn_pats_general @Identity @a) + +applyNameMaker :: NameMaker -> LocatedN RdrName -> RnM (LocatedN Name) +applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) + ; return n } + +-- ----------- Entry point 2: rnBindPat ------------------- +-- Binds local names; in a recursive scope that involves other bound vars +-- e.g let { (x, Just y) = e1; ... } in ... +-- * does NOT allows type sig to bind type vars +-- * local namemaker +-- * no unused and duplicate checking +-- * fixities might be coming in +rnBindPat :: NameMaker + -> LPat GhcPs + -> RnM (LPat GhcRn, FreeVars) + -- Returned FreeVars are the free variables of the pattern, + -- of course excluding variables bound by this pattern + +rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat) + +{- +********************************************************* +* * + The main event +* * +********************************************************* +-} + + +rnLArgPatAndThen :: NameMaker -> LocatedA (Pat GhcPs) -> CpsRn (LocatedA (Pat GhcRn)) +rnLArgPatAndThen mk = wrapSrcSpanCps rnArgPatAndThen where + + rnArgPatAndThen (InvisPat (_, spec) tp) = do + tp' <- rnHsTyPat HsTypePatCtx tp + liftCps $ unlessXOptM LangExt.TypeAbstractions $ + addErr (TcRnIllegalInvisibleTypePattern tp' InvisPatWithoutFlag) + pure (InvisPat spec tp') + rnArgPatAndThen p = rnPatAndThen mk p + +-- ----------- Entry point 3: rnLPatAndThen ------------------- +-- General version: parameterized by how you make new names + +rnLPatsAndThen :: Traversable f => NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn)) +rnLPatsAndThen mk = traverse (rnLPatAndThen mk) + -- Despite the map, the monad ensures that each pattern binds + -- variables that may be mentioned in subsequent patterns in the list +{-# SPECIALISE rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] #-} +{-# SPECIALISE rnLPatsAndThen :: NameMaker -> NE.NonEmpty (LPat GhcPs) -> CpsRn (NE.NonEmpty (LPat GhcRn)) #-} + +rnLArgPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] +rnLArgPatsAndThen mk = traverse (rnLArgPatAndThen mk) + +-------------------- +-- The workhorse +rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn) +rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat + +rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) +rnPatAndThen _ (WildPat _) = return (WildPat noExtField) +rnPatAndThen mk (ParPat _ pat) = + do { pat' <- rnLPatAndThen mk pat + ; return (ParPat noExtField pat') } +rnPatAndThen mk (LazyPat _ pat) = do { pat' <- rnLPatAndThen mk pat + ; return (LazyPat noExtField pat') } +rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat + ; return (BangPat noExtField pat') } +rnPatAndThen mk (VarPat x (L l rdr)) + = do { loc <- liftCps getSrcSpanM + ; name <- newPatName mk (L (noAnnSrcSpan loc) rdr) + ; return (VarPat x (L l name)) } + -- we need to bind pattern variables for view pattern expressions + -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) + +rnPatAndThen mk (SigPat _ pat sig) + -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is + -- important to rename its type signature _before_ renaming the rest of the + -- pattern, so that type variables are first bound by the _outermost_ pattern + -- type signature they occur in. This keeps the type checker happy when + -- pattern type signatures happen to be nested (#7827) + -- + -- f ((Just (x :: a) :: Maybe a) + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here + -- ~~~~~~~~~~~~~~~^ the same `a' then used here + = do { sig' <- rnHsPatSigTypeAndThen sig + ; pat' <- rnLPatAndThen mk pat + ; return (SigPat noExtField pat' sig' ) } + where + rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn) + rnHsPatSigTypeAndThen sig = liftCpsWithCont (rnHsPatSigType AlwaysBind PatCtx sig) + +rnPatAndThen mk (LitPat x lit) + | HsString src s <- lit + = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings) + ; if ovlStr + then rnPatAndThen mk + (mkNPat (noLocA (mkHsIsString src s)) + Nothing noAnn) + else normal_lit } + | otherwise = normal_lit + where + normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } + +rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) + = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit + ; mb_neg' -- See Note [Negative zero] + <- let negative = do { (neg, fvs) <- lookupSyntax negateName + ; return (Just neg, fvs) } + positive = return (Nothing, emptyFVs) + in liftCpsFV $ case (mb_neg , mb_neg') of + (Nothing, Just _ ) -> negative + (Just _ , Nothing) -> negative + (Nothing, Nothing) -> positive + (Just _ , Just _ ) -> positive + ; eq' <- liftCpsFV $ lookupSyntax eqName + ; return (NPat x (L l lit') mb_neg' eq') } + +rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ ) + = do { new_name <- newPatName mk (la2la rdr) + ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] + -- We skip negateName as + -- negative zero doesn't make + -- sense in n + k patterns + ; minus <- liftCpsFV $ lookupSyntax minusName + ; ge <- liftCpsFV $ lookupSyntax geName + ; return (NPlusKPat noExtField (L (noAnnSrcSpan $ nameSrcSpan new_name) new_name) + (L l lit') lit' ge minus) } + -- The Report says that n+k patterns must be in Integral + +rnPatAndThen mk (AsPat _ rdr pat) + = do { new_name <- newPatLName mk rdr + ; pat' <- rnLPatAndThen mk pat + ; return (AsPat noExtField new_name pat') } + +rnPatAndThen mk p@(ViewPat _ expr pat) + = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns + ; checkErr vp_flag (TcRnIllegalViewPattern p) } + -- Because of the way we're arranging the recursive calls, + -- this will be in the right context + ; expr' <- liftCpsFV $ rnLExpr expr + ; pat' <- rnLPatAndThen mk pat + -- Note: at this point the PreTcType in ty can only be a placeHolder + -- ; return (ViewPat expr' pat' ty) } + + -- Note: we can't cook up an inverse for an arbitrary view pattern, + -- so we pass 'Nothing'. + ; return (ViewPat Nothing expr' pat') } + +rnPatAndThen mk (ConPat _ con args) + -- rnConPatAndThen takes care of reconstructing the pattern + -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. + = case unLoc con == nameRdrName (dataConName nilDataCon) of + True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists + ; if ol_flag then rnPatAndThen mk (ListPat noAnn []) + else rnConPatAndThen mk con args} + False -> rnConPatAndThen mk con args + +rnPatAndThen mk (ListPat _ pats) + = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists + ; pats' <- rnLPatsAndThen mk pats + ; if not opt_OverloadedLists + then return (ListPat noExtField pats') + else + -- If OverloadedLists is enabled, desugar to a view pattern. + -- See Note [Desugaring overloaded list patterns] + do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName + -- Use 'fromList' as proof of invertibility of the view pattern. + -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn + ; (from_list_n_name,_) <- liftCps $ lookupSyntaxName fromListNName + ; let + lit_n = mkIntegralLit (length pats) + hs_lit = genHsIntegralLit lit_n + inverse = genHsApps from_list_n_name [hs_lit] + rn_list_pat = ListPat noExtField pats' + exp_expr = genLHsVar to_list_name + exp_list_pat = ViewPat (Just inverse) exp_expr (wrapGenSpan rn_list_pat) + ; return $ mkExpandedPat rn_list_pat exp_list_pat }} + +rnPatAndThen mk (TuplePat _ pats boxed) + = do { pats' <- rnLPatsAndThen mk pats + ; return (TuplePat noExtField pats' boxed) } + +rnPatAndThen mk (OrPat _ pats) + = do { loc <- liftCps getSrcSpanM + ; pats' <- rnLPatsAndThen mk pats + ; let bndrs = collectPatsBinders CollVarTyVarBinders (NE.toList pats') + ; liftCps $ setSrcSpan loc $ checkErr (null bndrs) $ + TcRnOrPatBindsVariables (NE.fromList (ordNubOn getOccName bndrs)) + ; return (OrPat noExtField pats') } + +rnPatAndThen mk (SumPat _ pat alt arity) + = do { pat <- rnLPatAndThen mk pat + ; return (SumPat noExtField pat alt arity) + } + +rnPatAndThen mk (SplicePat _ splice) + = do { eith <- liftCpsFV $ rnSplicePat splice + ; case eith of -- See Note [rnSplicePat] in GHC.Rename.Splice + (rn_splice, HsUntypedSpliceTop mfs pat) -> -- Splice was top-level and thus run, creating Pat GhcPs + gParPat . (fmap (flip SplicePat rn_splice . HsUntypedSpliceTop mfs)) <$> rnLPatAndThen mk pat + (rn_splice, HsUntypedSpliceNested splice_name) -> return (SplicePat (HsUntypedSpliceNested splice_name) rn_splice) -- Splice was nested and thus already renamed + } + +rnPatAndThen _ (EmbTyPat _ tp) + = do { tp' <- rnHsTyPat HsTypePatCtx tp + ; return (EmbTyPat noExtField tp') } +rnPatAndThen _ (InvisPat (_, spec) tp) + = do { -- Invisible patterns are handled in `rnLArgPatAndThen` + -- so unconditionally emit error here + ; tp' <- rnHsTyPat HsTypePatCtx tp + ; liftCps $ addErr (TcRnIllegalInvisibleTypePattern tp' InvisPatMisplaced) + ; return (InvisPat spec tp') + } + +-------------------- +rnConPatAndThen :: NameMaker + -> LocatedN RdrName -- the constructor + -> HsConPatDetails GhcPs + -> CpsRn (Pat GhcRn) + +rnConPatAndThen mk con (PrefixCon pats) + = do { con' <- lookupConCps con + ; pats' <- rnLArgPatsAndThen mk pats + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = con' + , pat_args = PrefixCon pats' + } + } + +rnConPatAndThen mk con (InfixCon pat1 pat2) + = do { con' <- lookupConCps con + ; pat1' <- rnLPatAndThen mk pat1 + ; pat2' <- rnLPatAndThen mk pat2 + ; fixity <- liftCps $ lookupFixityRn (getName con') + ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' } + +rnConPatAndThen mk con (RecCon rpats) + = do { con' <- lookupConCps con + ; rpats' <- rnHsRecPatsAndThen mk con' rpats + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = con' + , pat_args = RecCon rpats' + } + } +checkUnusedRecordWildcardCps :: SrcSpan + -> Maybe [ImplicitFieldBinders] + -> CpsRn () +checkUnusedRecordWildcardCps loc dotdot_names = + CpsRn (\thing -> do + (r, fvs) <- thing () + checkUnusedRecordWildcard loc fvs dotdot_names + return (r, fvs) ) + +-------------------- +rnHsRecPatsAndThen :: NameMaker + -> LocatedN (WithUserRdr Name) -- constructor + -> HsRecFields GhcPs (LPat GhcPs) + -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) +rnHsRecPatsAndThen mk (L _ con) + hs_rec_fields@(HsRecFields { rec_dotdot = dd }) + = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat + hs_rec_fields + ; flds' <- mapM rn_field (flds `zip` [1..]) + ; check_unused_wildcard (lHsRecFieldsImplicits flds' <$> unLoc <$> dd) + ; return (HsRecFields { rec_ext = noExtField, rec_flds = flds', rec_dotdot = dd }) } + where + mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n) + rn_field (L l fld, n') = + do { arg' <- rnLPatAndThen (nested_mk dd mk (RecFieldsDotDot n')) (hfbRHS fld) + ; return (L l (fld { hfbRHS = arg' })) } + + loc = maybe noSrcSpan getLocA dd + + -- Don't warn for let P{..} = ... in ... + check_unused_wildcard = case mk of + LetMk{} -> const (return ()) + LamMk{} -> checkUnusedRecordWildcardCps loc + + -- Suppress unused-match reporting for fields introduced by ".." + nested_mk Nothing mk _ = mk + nested_mk (Just _) mk@(LetMk {}) _ = mk + nested_mk (Just (unLoc -> n)) (LamMk report_unused) n' + = LamMk (report_unused && (n' <= n)) + + +{- ********************************************************************* +* * + Generating code for HsPatExpanded + See Note [Handling overloaded and rebindable constructs] +* * +********************************************************************* -} + +-- | Build a 'HsPatExpansion' out of an extension constructor, +-- and the two components of the expansion: original and +-- desugared patterns +mkExpandedPat + :: Pat GhcRn -- ^ source pattern + -> Pat GhcRn -- ^ expanded pattern + -> Pat GhcRn -- ^ suitably wrapped 'HsPatExpansion' +mkExpandedPat a b = XPat (HsPatExpanded a b) + +{- +************************************************************************ +* * + Record fields +* * +************************************************************************ +-} + +data HsRecFieldContext + = HsRecFieldCon (WithUserRdr Name) + | HsRecFieldPat (WithUserRdr Name) + | HsRecFieldUpd + +rnHsRecFields + :: forall arg. + HsRecFieldContext + -> (SrcSpan -> RdrName -> arg) + -- When punning, use this to build a new field + -> HsRecFields GhcPs (LocatedA arg) + -> RnM ([LHsRecField GhcRn (LocatedA arg)], FreeVars) + +-- This surprisingly complicated pass +-- a) looks up the field name (possibly using disambiguation) +-- b) fills in puns and dot-dot stuff +-- When we've finished, we've renamed the LHS, but not the RHS, +-- of each x=e binding +-- +-- This is used for record construction and pattern-matching, but not updates. + +rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) + = do { pun_ok <- xoptM LangExt.NamedFieldPuns + ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields + ; let parent = guard disambig_ok >> mb_con + ; flds1 <- mapM (rn_fld pun_ok parent) flds + ; mapM_ (addErr . dupFieldErr ctxt) dup_flds + ; dotdot_flds <- rn_dotdot dotdot mb_con flds1 + ; let all_flds | null dotdot_flds = flds1 + | otherwise = flds1 ++ dotdot_flds + ; return (all_flds, mkFVs (getFieldIds all_flds)) } + where + mb_con = case ctxt of + HsRecFieldCon con -> Just con + HsRecFieldPat con -> Just con + HsRecFieldUpd -> Nothing + + rn_fld :: Bool + -> Maybe (WithUserRdr Name) + -> LHsRecField GhcPs (LocatedA arg) + -> RnM (LHsRecField GhcRn (LocatedA arg)) + rn_fld pun_ok parent (L l + (HsFieldBind + { hfbLHS = L loc (FieldOcc _ (L ll lbl)) + , hfbRHS = arg + , hfbPun = pun })) + = do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl + ; let arg_rdr = mkRdrUnqual $ recFieldToVarOcc $ occName sel + -- Discard any module qualifier (#11662) + ; arg' <- if pun + then do { checkErr pun_ok $ + TcRnIllegalFieldPunning (L (locA loc) arg_rdr) + ; return $ L (l2l loc) $ + mk_arg (locA loc) arg_rdr } + else return arg + ; return $ L l $ + HsFieldBind + { hfbAnn = noAnn + , hfbLHS = L loc (FieldOcc arg_rdr (L ll sel)) + , hfbRHS = arg' + , hfbPun = pun } } + + rn_dotdot :: Maybe (LocatedE RecFieldsDotDot) -- See Note [DotDot fields] in GHC.Hs.Pat + -> Maybe (WithUserRdr Name) + -- The constructor (Nothing for an out of scope constructor) + -> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields + -> RnM [LHsRecField GhcRn (LocatedA arg)] -- Field Labels we need to fill in + rn_dotdot (Just (L loc_e (RecFieldsDotDot n))) (Just qcon@(WithUserRdr _ con)) flds -- ".." on record construction / pat match + | not (isUnboundName con) -- This test is because if the constructor + -- isn't in scope the constructor lookup will add + -- an error but still return an unbound name. We + -- don't want that to screw up the dot-dot fill-in stuff. + = assert (flds `lengthIs` n) $ + do { dd_flag <- xoptM LangExt.RecordWildCards + ; checkErr dd_flag (needFlagDotDot ctxt) + ; (rdr_env, lcl_env) <- getRdrEnvs + ; conInfo <- lookupConstructorInfo qcon + ; when (conFieldInfo conInfo == ConHasPositionalArgs) (addErr (TcRnIllegalWildcardsInConstructor con)) + ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldRdrs flds) + + -- For constructor uses (but not patterns) + -- the arg should be in scope locally; + -- i.e. not top level or imported + -- Eg. data R = R { x,y :: Int } + -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} + arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env + + (dot_dot_fields, dot_dot_gres) = + unzip [ (fl, gre) + | fl <- conInfoFields conInfo + , let lbl = recFieldToVarOcc $ occName $ flSelector fl + , not (lbl `elemOccSet` present_flds) + , Just gre <- [lookupGRE_FieldLabel rdr_env fl] + -- Check selector is in scope + , case ctxt of + HsRecFieldCon {} -> arg_in_scope lbl + _other -> True ] + + ; addUsedGREs NoDeprecationWarnings dot_dot_gres + ; let loc = locA loc_e + ; let locn = noAnnSrcSpan loc + ; return [ L (noAnnSrcSpan loc) (HsFieldBind + { hfbAnn = noAnn + , hfbLHS + = L (noAnnSrcSpan loc) (FieldOcc arg_rdr (L (noAnnSrcSpan loc) sel)) + , hfbRHS = L locn (mk_arg loc arg_rdr) + , hfbPun = False }) + | fl <- dot_dot_fields + , let sel = flSelector fl + arg_rdr = mkRdrUnqual + $ recFieldToVarOcc + $ nameOccName sel ] } + + rn_dotdot _dotdot _mb_con _flds + = return [] + -- _dotdot = Nothing => No ".." at all + -- _mb_con = Nothing => Record update + -- _mb_con = Just unbound => Out of scope data constructor + + dup_flds :: [NE.NonEmpty RdrName] + -- Each list represents a RdrName that occurred more than once + -- (the list contains all occurrences) + -- Each list in dup_fields is non-empty + (_, dup_flds) = removeDups (uniqCompareFS `on` (occNameFS . rdrNameOcc)) (getFieldLbls flds) + -- See the same duplicate handling logic in rnHsRecUpdFields below for further context. + +-- | Rename a regular (non-overloaded) record field update, +-- disambiguating the fields if necessary. +rnHsRecUpdFields + :: [LHsRecUpdField GhcPs GhcPs] + -> RnM (XLHsRecUpdLabels GhcRn, [LHsRecUpdField GhcRn GhcRn], FreeVars) +rnHsRecUpdFields flds + = do { pun_ok <- xoptM LangExt.NamedFieldPuns + + -- Check for an empty record update: e {} + -- NB: don't complain about e { .. }, because rn_dotdot has done that already + ; case flds of + { [] -> failWithTc TcRnEmptyRecordUpdate + ; fld:other_flds -> + do { let dup_lbls :: [NE.NonEmpty RdrName] + (_, dup_lbls) = removeDups (uniqCompareFS `on` (occNameFS . rdrNameOcc)) + (fmap (unLoc . getFieldUpdLbl) flds) + -- NB: we compare using the underlying field label FastString, + -- in order to catch duplicates involving qualified names, + -- as in the record update `r { fld = x, Mod.fld = y }`. + -- See #21959. + -- Note that this test doesn't correctly handle exact Names, but those + -- aren't handled properly by the rest of the compiler anyway. See #22122. + ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_lbls + + -- See Note [Disambiguating record updates] + ; possible_parents <- lookupRecUpdFields (fld NE.:| other_flds) + ; let mb_unambig_lbls :: Maybe [FieldLabel] + fvs :: FreeVars + (mb_unambig_lbls, fvs) = + case possible_parents of + RnRecUpdParent { rnRecUpdLabels = gres } NE.:| [] + | let lbls = map fieldGRELabel $ NE.toList gres + -> ( Just lbls, mkFVs $ map flSelector lbls) + _ -> ( Nothing + , plusFVs $ map (plusFVs . map pat_syn_free_vars . NE.toList . rnRecUpdLabels) + $ NE.toList possible_parents + -- See Note [Using PatSyn FreeVars] + ) + + -- Rename each field. + ; (upd_flds, fvs') <- rn_flds pun_ok mb_unambig_lbls flds + ; let all_fvs = fvs `plusFV` fvs' + ; return (possible_parents, upd_flds, all_fvs) } } } + + where + + -- For an ambiguous record update involving pattern synonym record fields, + -- we must add all the possibly-relevant field selector names to ensure that + -- we typecheck the record update **after** we typecheck the pattern synonym + -- definition. See Note [Using PatSyn FreeVars]. + pat_syn_free_vars :: FieldGlobalRdrElt -> FreeVars + pat_syn_free_vars (GRE { gre_info = info }) + | IAmRecField fld_info <- info + , RecFieldInfo { recFieldLabel = fl, recFieldCons = cons } <- fld_info + , uniqSetAny is_PS cons + = unitFV (flSelector fl) + pat_syn_free_vars _ + = emptyFVs + + is_PS :: ConLikeName -> Bool + is_PS (PatSynName {}) = True + is_PS (DataConName {}) = False + + rn_flds :: Bool -> Maybe [FieldLabel] + -> [LHsRecUpdField GhcPs GhcPs] + -> RnM ([LHsRecUpdField GhcRn GhcRn], FreeVars) + rn_flds _ _ [] = return ([], emptyFVs) + rn_flds pun_ok mb_unambig_lbls + ((L l (HsFieldBind { hfbLHS = L loc (FieldOcc _ f) + , hfbRHS = arg + , hfbPun = pun })):flds) + = do { let lbl = unLoc f + ; (arg' :: LHsExpr GhcPs) <- if pun + then do { setSrcSpanA loc $ + checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) + -- Discard any module qualifier (#11662) + ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) + ; return (L (l2l loc) (mkHsVarWithUserRdr lbl (L (l2l loc) arg_rdr))) } + else return arg + ; (arg'', fvs) <- rnLExpr arg' + ; let lbl' :: FieldOcc GhcRn + lbl' = case mb_unambig_lbls of + { Just (fl:_) -> + let sel_name = flSelector fl + in FieldOcc lbl (L (l2l loc) sel_name) + -- We have one last chance to be disambiguated during type checking. + -- At least, until type-directed disambiguation stops being supported. + -- see note [Ambiguous FieldOcc in record updates] for more info. + ; _ -> FieldOcc lbl (L (l2l loc) (mkUnboundName $ rdrNameOcc lbl)) } + fld' :: LHsRecUpdField GhcRn GhcRn + fld' = L l (HsFieldBind { hfbAnn = noAnn + , hfbLHS = L (l2l loc) lbl' + , hfbRHS = arg'' + , hfbPun = pun }) + ; (flds', fvs') <- rn_flds pun_ok (tail <$> mb_unambig_lbls) flds + ; return (fld' : flds', fvs `plusFV` fvs') } + +getFieldIds :: [LHsRecField GhcRn arg] -> [Name] +getFieldIds flds = map (hsRecFieldSel . unLoc) flds + +getFieldRdrs :: [LHsRecField GhcRn arg] -> [RdrName] +getFieldRdrs flds = map (foExt . unXRec @GhcRn . hfbLHS . unLoc) flds + +getFieldLbls :: [LHsRecField (GhcPass p) arg] -> [IdGhcP p] +getFieldLbls flds + = map (unLoc . foLabel . unLoc . hfbLHS . unLoc) flds + +needFlagDotDot :: HsRecFieldContext -> TcRnMessage +needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart + +dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> TcRnMessage +dupFieldErr ctxt = TcRnDuplicateFieldName (toRecordFieldPart ctxt) + +toRecordFieldPart :: HsRecFieldContext -> RecordFieldPart +toRecordFieldPart (HsRecFieldCon n) = RecordFieldConstructor (getName n) +toRecordFieldPart (HsRecFieldPat n) = RecordFieldPattern (getName n) +toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldUpdate + +{- Note [Disambiguating record updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the -XDuplicateRecordFields extension is used, to rename and typecheck +a non-overloaded record update, we might need to disambiguate the field labels. + +Consider the following definitions: + + {-# LANGUAGE DuplicateRecordFields #-} + + data R = MkR1 { fld1 :: Int, fld2 :: Char } + | MKR2 { fld1 :: Int, fld2 :: Char, fld3 :: Bool } + data S = MkS1 { fld1 :: Int } | MkS2 { fld2 :: Char } + +In a record update, the `lookupRecUpdFields` function tries to determine +the parent datatype by computing the parents (TyCon/PatSyn) which have +at least one constructor (DataCon/PatSyn) with all of the fields. + +To do this, given the (non-empty) set of fields in the record update, +lookupRecUpdFields proceeds as follows: + + (1) For each field, retrieve all the in-scope GREs that it could possibly + refer to. + + (2) Take an intersection to compute the possible parent data constructors. + For example, for an update + + r { fld1 = 3, fld2 = 'x' } + + the possible parents for each field are: + + fld1: [MkR1 |-> R.fld1, MkR2 |-> R.fld1, MkS1 |> S.fld1] + fld2: [MkR1 |-> R.fld2, MkR2 |-> R.fld2, MkS2 |> S.fld2] + + after intersecting by constructor, we get: + + fld1: [MkR1 |-> R.fld1, MkR2 |-> R.fld1] + fld2: [MkR1 |-> R.fld2, MkR2 |-> R.fld2] + + This reflects the fact that only the TyCon R contains at least one DataCon + which has both of the fields being updated: MkR1 and MkR2. + The TyCon S also has both fields fld1 and fld2, but no single constructor + has both of those fields, so S is not a valid parent for this record update. + + (3) + (a) + If there is at least one possible parent TyCon, succeed. The typechecker + might still be able to disambiguate if there remains more than one + candidate parent TyCon (see Note [Type-directed record disambiguation]). + (b) + Otherwise, report an error saying "No constructor has all these fields". + This is the job of GHC.Rename.Env.badFieldsUpd. This function tries + to report a minimal set of fields, so that in a record update like + + r { fld1 = x1, fld2 = x2, [...], fld99 = x99 } + + we don't report a massive error message saying "No constructor has all + the fields fld1, ..., fld99" and instead report e.g. "No constructor + has all the fields { fld3, fld17 }". + +Wrinkle [Qualified names in record updates] + + Note that we must take into account qualified names in (1), so that a record + update such as + + import qualified M ( R (fld1, fld2) ) + f r = r { M.fld1 = 3 } + + is unambiguous: only R contains the field fld1 with the M qualifier. + + The function that looks up the GREs for the record update is 'lookupFieldGREs', + which uses 'lookupGRE env (LookupRdrName ...)', ensuring that we correctly + filter the GREs with the correct module qualification (with 'pickGREs'). + + (See however #22122 for issues relating to the usage of exact Names in + record fields.) + +Wrinkle [Out of scope constructors] + + For (3)(b), we have an invalid record update because no constructor has + all of the fields of the record update. The 'badFieldsUpd' then tries to + compute a minimal set of fields which are not children of any single + constructor. The way this is done is explained in + Note [Finding the conflicting fields] in GHC.Rename.Env, but in short that + function needs a mapping from ConLike to all of its fields to do its business. + (You may remark that we did not need such a mapping for step (2).) + + This means we need to look up each constructor and find its fields; this + information is stored in the GREInfo field of a constructor GRE. + We need this information even if the constructor itself is not in scope, so + we proceed as follows: + + 1. First look up the constructor in the GlobalRdrEnv, using lookupGRE_Name. + This handles constructors defined in the current module being renamed, + as well as in-scope imported constructors. + 2. If that fails (e.g. the field is imported but the constructor is not), + then look up the GREInfo of the constructor in the TypeEnv, using + lookupGREInfo. This makes sure we give the right error message even when + the constructors are not in scope (#26391). + + Note that we do need (1), as (2) does not handle constructors defined in the + current module being renamed (as those have not yet been added to the TypeEnv). + +Note [Using PatSyn FreeVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are disambiguating a non-overloaded record update, as per +Note [Disambiguating record updates], and have determined that this +record update might involve pattern synonym record fields, it is important +to declare usage of all these pattern synonyms record fields in the returned +FreeVars of rnHsRecUpdFields. This ensures that the typechecker sees +that the typechecking of the record update depends on the typechecking +of the pattern synonym, and typechecks the pattern synonyms first. +Not doing so caused #21898. + +Note that this can be removed once GHC proposal #366 is implemented, +as we will be able to fully disambiguate the record update in the renamer, +and can immediately declare the correct used FreeVars instead of having +to over-estimate in case of ambiguity. + +************************************************************************ +* * +\subsubsection{Literals} +* * +************************************************************************ + +When literals occur we have to make sure +that the types and classes they involve +are made available. +-} + +rnLit :: HsLit p -> RnM () +rnLit (HsChar _ c) = checkErr (inCharRange c) (TcRnCharLiteralOutOfRange c) +rnLit _ = return () + +-- | Turn a Fractional-looking literal which happens to be an integer into an +-- Integer-looking literal. +-- We only convert numbers where the exponent is between 0 and 100 to avoid +-- converting huge numbers and incurring long compilation times. See #15646. +generalizeOverLitVal :: OverLitVal -> OverLitVal +generalizeOverLitVal (HsFractional fl@(FL {fl_text=src,fl_neg=neg,fl_exp=e})) + | e >= -100 && e <= 100 + , let val = rationalFromFractionalLit fl + , denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val}) +generalizeOverLitVal lit = lit + +isNegativeZeroOverLit :: (XXOverLit t ~ DataConCantHappen) => HsOverLit t -> Bool +isNegativeZeroOverLit lit + = case ol_val lit of + HsIntegral i -> 0 == il_value i && il_neg i + -- For HsFractional, the value of fl is n * (b ^^ e) so it is sufficient + -- to check if n = 0. b is equal to either 2 or 10. We don't call + -- rationalFromFractionalLit here as it is expensive when e is big. + HsFractional fl -> 0 == fl_signi fl && fl_neg fl + _ -> False + +{- +Note [Negative zero] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There were problems with negative zero in conjunction with Negative Literals +extension. Numeric literal value is contained in Integer and Rational types +inside IntegralLit and FractionalLit. These types cannot represent negative +zero value. So we had to add explicit field 'neg' which would hold information +about literal sign. Here in rnOverLit we use it to detect negative zeroes and +in this case return not only literal itself but also negateName so that users +can apply it explicitly. In this case it stays negative zero. #13211 +-} + +rnOverLit :: (XXOverLit t ~ DataConCantHappen) => HsOverLit t -> + RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars) +rnOverLit origLit + = do { opt_NumDecimals <- xoptM LangExt.NumDecimals + ; let { lit@(OverLit {ol_val=val}) + | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)} + | otherwise = origLit + } + ; let std_name = hsOverLitName val + ; (from_thing_name, fvs1) <- lookupSyntaxName std_name + ; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast + ; let rebindable = from_thing_name /= std_name + lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable + , ol_from_fun = L (noAnnSrcSpan loc) from_thing_name } } + ; if isNegativeZeroOverLit lit' + then do { (negate_expr, fvs2) <- lookupSyntaxExpr negateName + ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_expr) + , fvs1 `plusFV` fvs2) } + else return ((lit', Nothing), fvs1) } + + +rnHsTyPat :: HsDocContext + -> HsTyPat GhcPs + -> CpsRn (HsTyPat GhcRn) +rnHsTyPat ctxt sigType = case sigType of + (HsTP { hstp_body = hs_ty }) -> do + (hs_ty', tpb) <- runTPRnM (rn_lty_pat hs_ty) ctxt + pure HsTP + { hstp_body = hs_ty' + , hstp_ext = buildHsTyPatRn tpb + } + +-- | Type pattern renaming monad +-- For the OccSet in the ReaderT, see Note [Locally bound names in type patterns] +-- For the HsTyPatRnBuilderRn in the WriterT, see Note [Implicit and explicit type variable binders] +-- For the CpsRn base monad, see Note [CpsRn monad] +-- For why we need CpsRn in TPRnM see Note [Left-to-right scoping of type patterns] +newtype TPRnM a = + MkTPRnM (ReaderT (HsDocContext, OccSet) (WriterT HsTyPatRnBuilder CpsRn) a) + deriving newtype (Functor, Applicative, Monad) + +runTPRnM :: TPRnM a -> HsDocContext -> CpsRn (a, HsTyPatRnBuilder) +runTPRnM (MkTPRnM thing_inside) doc_ctxt = runWriterT $ runReaderT thing_inside (doc_ctxt, emptyOccSet) + +askLocals :: TPRnM OccSet +askLocals = MkTPRnM (asks snd) + +askDocContext :: TPRnM HsDocContext +askDocContext = MkTPRnM (asks fst) + +tellTPB :: HsTyPatRnBuilder -> TPRnM () +tellTPB = MkTPRnM . lift . tell + +liftRnFV :: RnM (a, FreeVars) -> TPRnM a +liftRnFV = liftTPRnCps . liftCpsFV + +liftRn :: RnM a -> TPRnM a +liftRn = liftTPRnCps . liftCps + +liftRnWithCont :: (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)) -> TPRnM b +liftRnWithCont cont = liftTPRnCps (liftCpsWithCont cont) + +liftTPRnCps :: CpsRn a -> TPRnM a +liftTPRnCps = MkTPRnM . lift . lift + +liftTPRnRaw :: + ( forall r . + HsDocContext -> + OccSet -> + ((a, HsTyPatRnBuilder) -> RnM (r, FreeVars)) -> + RnM (r, FreeVars) + ) -> TPRnM a +liftTPRnRaw cont = MkTPRnM $ ReaderT $ \(doc_ctxt, locals) -> writerT $ liftCpsWithCont (cont doc_ctxt locals) + +unTPRnRaw :: + TPRnM a -> + HsDocContext -> + OccSet -> + ((a, HsTyPatRnBuilder) -> RnM (r, FreeVars)) -> + RnM (r, FreeVars) +unTPRnRaw (MkTPRnM m) doc_ctxt locals = unCpsRn $ runWriterT $ runReaderT m (doc_ctxt, locals) + +wrapSrcSpanTPRnM :: (a -> TPRnM b) -> LocatedAn ann a -> TPRnM (LocatedAn ann b) +wrapSrcSpanTPRnM fn (L loc a) = do + a' <- fn a + pure (L loc a') + +lookupTypeOccTPRnM :: RdrName -> TPRnM Name +lookupTypeOccTPRnM rdr_name = liftRnFV $ do + name <- lookupTypeOccRn rdr_name + pure (name, unitFV name) + +rn_lty_pat :: LHsType GhcPs -> TPRnM (LHsType GhcRn) +rn_lty_pat (L l hs_ty) = do + hs_ty' <- rn_ty_pat hs_ty + pure (L l hs_ty') + +rn_ty_pat_var :: LocatedN RdrName -> TPRnM (LocatedN (WithUserRdr Name)) +rn_ty_pat_var lrdr@(L l rdr) = do + locals <- askLocals + if isRdrTyVar rdr + && not (elemOccSet (occName rdr) locals) -- See Note [Locally bound names in type patterns] + + then do -- binder + name <- liftTPRnCps $ newPatName (LamMk True) lrdr + tellTPB (tpBuilderExplicitTV name) + pure (L l $ WithUserRdr rdr name) + + else do -- usage + name <- lookupTypeOccTPRnM rdr + pure (L l $ WithUserRdr rdr name) + +-- | Rename type patterns +-- +-- For the difference between `rn_ty_pat` and `rnHsTyKi` see Note [CpsRn monad] +-- and Note [Implicit and explicit type variable binders] +rn_ty_pat :: HsType GhcPs -> TPRnM (HsType GhcRn) +rn_ty_pat tv@(HsTyVar an prom lrdr) = do + L l (WithUserRdr _ name) <- rn_ty_pat_var lrdr + when (isDataConName name && not (isKindName name)) $ + -- Any use of a promoted data constructor name (that is not specifically + -- exempted by isKindName) is illegal without the use of DataKinds. + -- See Note [Checking for DataKinds] in GHC.Tc.Validity. + check_data_kinds tv + pure (HsTyVar an prom (L l $ WithUserRdr (unLoc lrdr) name)) + +rn_ty_pat (HsForAllTy an tele body) = liftTPRnRaw $ \ctxt locals thing_inside -> + bindHsForAllTelescope ctxt tele $ \tele' -> do + let + tele_names = hsForAllTelescopeNames tele' + locals' = locals `extendOccSetList` map occName tele_names + + unTPRnRaw (rn_lty_pat body) ctxt locals' $ \(body', tpb) -> + delLocalNames tele_names $ -- locally bound names do not scope over the continuation + thing_inside ((HsForAllTy an tele' body'), tpb) + +rn_ty_pat (HsQualTy an lctx body) = do + lctx' <- wrapSrcSpanTPRnM (mapM rn_lty_pat) lctx + body' <- rn_lty_pat body + pure (HsQualTy an lctx' body') + +rn_ty_pat (HsAppTy _ fun_ty arg_ty) = do + fun_ty' <- rn_lty_pat fun_ty + arg_ty' <- rn_lty_pat arg_ty + pure (HsAppTy noExtField fun_ty' arg_ty') + +rn_ty_pat (HsAppKindTy _ ty ki) = do + kind_app <- liftRn $ xoptM LangExt.TypeApplications + unless kind_app (liftRn $ addErr (typeAppErr KindLevel ki)) + ty' <- rn_lty_pat ty + ki' <- rn_lty_pat ki + pure (HsAppKindTy noExtField ty' ki') + +rn_ty_pat (HsFunTy an mult lhs rhs) = do + lhs' <- rn_lty_pat lhs + mult' <- rn_ty_pat_mult mult + rhs' <- rn_lty_pat rhs + pure (HsFunTy an mult' lhs' rhs') + +rn_ty_pat (HsListTy an ty) = do + ty' <- rn_lty_pat ty + pure (HsListTy an ty') + +rn_ty_pat (HsTupleTy an con tys) = do + tys' <- mapM rn_lty_pat tys + pure (HsTupleTy an con tys') + +rn_ty_pat (HsSumTy an tys) = do + tys' <- mapM rn_lty_pat tys + pure (HsSumTy an tys') + +rn_ty_pat (HsOpTy _ prom ty1 l_op ty2) = do + ty1' <- rn_lty_pat ty1 + l_op' <- rn_ty_pat_var l_op + ty2' <- rn_lty_pat ty2 + fix <- liftRn $ lookupTyFixityRn $ fmap getName l_op' + let op_name = getName l_op' + when (isDataConName op_name && not (isPromoted prom)) $ + liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name) + liftRn $ mkHsOpTyRn prom l_op' fix ty1' ty2' + +rn_ty_pat (HsParTy an ty) = do + ty' <- rn_lty_pat ty + pure (HsParTy an ty') + +rn_ty_pat (HsIParamTy an n ty) = do + ty' <- rn_lty_pat ty + pure (HsIParamTy an n ty') + +rn_ty_pat (HsStarTy an unicode) = + pure (HsStarTy an unicode) + +rn_ty_pat (HsDocTy an ty haddock_doc) = do + ty' <- rn_lty_pat ty + haddock_doc' <- liftRn $ rnLHsDoc haddock_doc + pure (HsDocTy an ty' haddock_doc') + +rn_ty_pat ty@(HsExplicitListTy _ prom tys) = do + check_data_kinds ty + + unless (isPromoted prom) $ + liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList) + + tys' <- mapM rn_lty_pat tys + pure (HsExplicitListTy noExtField prom tys') + +rn_ty_pat ty@(HsExplicitTupleTy _ prom tys) = do + check_data_kinds ty + tys' <- mapM rn_lty_pat tys + pure (HsExplicitTupleTy noExtField prom tys') + +rn_ty_pat tyLit@(HsTyLit src t) = do + check_data_kinds tyLit + t' <- liftRn $ rnHsTyLit t + pure (HsTyLit src t') + +rn_ty_pat (HsWildCardTy _) = + pure (HsWildCardTy noExtField) + +rn_ty_pat (HsKindSig an ty ki) = do + ctxt <- askDocContext + kind_sigs_ok <- liftRn $ xoptM LangExt.KindSignatures + unless kind_sigs_ok (liftRn $ badKindSigErr ctxt ki) + ~(HsPS hsps ki') <- liftRnWithCont $ + rnHsPatSigKind AlwaysBind ctxt (HsPS noAnn ki) + ty' <- rn_lty_pat ty + tellTPB (tpBuilderPatSig hsps) + pure (HsKindSig an ty' ki') + +rn_ty_pat (HsSpliceTy _ splice) = do + res <- liftRnFV $ rnSpliceTyPat splice + case res of + (rn_splice, HsUntypedSpliceTop mfs pat) -> do -- Splice was top-level and thus run, creating LHsType GhcPs + pat' <- rn_lty_pat pat + pure (HsSpliceTy (HsUntypedSpliceTop mfs (mb_paren pat')) rn_splice) + (rn_splice, HsUntypedSpliceNested splice_name) -> + pure (HsSpliceTy (HsUntypedSpliceNested splice_name) rn_splice) -- Splice was nested and thus already renamed + where + mb_paren :: LHsType GhcRn -> LHsType GhcRn + mb_paren lhs_ty@(L loc hs_ty) + | hsTypeNeedsParens maxPrec hs_ty = L loc (HsParTy noAnn lhs_ty) + | otherwise = lhs_ty + +rn_ty_pat ty@(XHsType{}) = do + ctxt <- askDocContext + liftRnFV $ rnHsType ctxt ty + +rn_ty_pat_mult :: HsMultAnn GhcPs -> TPRnM (HsMultAnn GhcRn) +rn_ty_pat_mult (HsUnannotated _) = pure (HsUnannotated noExtField) +rn_ty_pat_mult (HsLinearAnn _) = pure (HsLinearAnn noExtField) +rn_ty_pat_mult (HsExplicitMult _ p) + = rn_lty_pat p <&> (\mult -> HsExplicitMult noExtField mult) + +check_data_kinds :: HsType GhcPs -> TPRnM () +check_data_kinds thing = liftRn $ do + data_kinds <- xoptM LangExt.DataKinds + unless data_kinds $ + addErr $ TcRnDataKindsError TypeLevel $ Left thing + +{- Note [Locally bound names in type patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type patterns can bind local names using forall. Compare the following examples: + f (Proxy @(Either a b)) = ... + g (Proxy @(forall a . Either a b)) = ... + +In `f` both `a` and `b` are bound by the pattern and scope over the RHS of f. +In `g` only `b` is bound by the pattern, whereas `a` is locally bound in the pattern +and does not scope over the RHS of `g`. + +We track locally bound names in the `OccSet` in `TPRnM` monad, and use it to +decide whether occurrences of type variables are usages or bindings. + +The check is done in `rn_ty_pat_var` + +Note [Implicit and explicit type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type patterns are renamed differently from ordinary types. + * Types are renamed by `rnHsType` where all type variable occurrences are considered usages + * Type patterns are renamed by `rnHsTyPat` where some type variable occurrences are usages + and other are bindings + +Here is an example: + {-# LANGUAGE ScopedTypeVariables #-} + f :: forall b. Proxy _ -> ... + f (Proxy @(x :: (a, b))) = ... + +In the (x :: (a,b)) type pattern + * `x` is a type variable explicitly bound by type pattern + * `a` is a type variable implicitly bound in a pattern signature + * `b` is a usage of type variable bound by the outer forall + +This classification is clear to us in `rnHsTyPat`, but it is also useful in later passes, such +as `collectPatBinders` and `tcHsTyPat`, so we store it in the extension field of `HsTyPat`, namely +`HsTyPatRn`. + +To collect lists of those variables efficiently we use `HsTyPatRnBuilder` which is exactly like +`HsTyPatRn`, but uses Bags. + +Note [Left-to-right scoping of type patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In term-level patterns, we use continuation passing to implement left-to-right +scoping, see Note [CpsRn monad]. Left-to-right scoping manifests itself when +e.g. view patterns are involved: + + f (x, g x -> Just y) = ... + +Here the first occurrence of `x` is a binder, and the second occurrence is a +use of `x` in a view pattern. This example does not work if we swap the +components of the tuple: + + f (g x -> Just y, x) = ... + -- ^^^ + -- Variable not in scope: x + +In type patterns there are no view patterns, but there is a different feature +that is served well by left-to-right scoping: kind annotations. Compare: + + f (Proxy @(T k (a :: k))) = ... + g (Proxy @(T (a :: k) k)) = ... + +In `f`, the first occurrence of `k` is an explicit binder, + and the second occurrence is a usage. Simple. +In `g`, the first occurrence of `k` is an implicit binder, + and then the second occurrence is an explicit binder that shadows it. + +So we get two different results after renaming: + + f (Proxy @(T k1 (a :: k1))) = ... + g (Proxy @(T (a :: k1) k2)) = ... + +This makes GHC accept the first example but rejects the second example with an +error about duplicate binders. + +One could argue that we don't want order-sensitivity here. Historically, we +used a different principle when renaming types: collect all free variables, +bind them on the outside, and then rename all occurrences as usages. +This approach does not scale to multiple patterns. Consider: + + f' (MkP @k @(a :: k)) = ... + g' (MkP @(a :: k) @k) = ... + +Here a difference in behavior is inevitable, as we rename type patterns +one at a time. Could we perhaps concatenate the free variables from all +type patterns in a ConPat? But then we still get the same problem one level up, +when we have multiple patterns in a function LHS + + f'' (Proxy @k) (Proxy @(a :: k)) = ... + g'' (Proxy @(a :: k)) (Proxy @k) = ... + +And if we tried to avoid order sensitivity at this level, then we'd still be left +with lambdas: + + f''' (Proxy @k) = \(Proxy @(a :: k)) -> ... + g''' (Proxy @(a :: k)) = \(Proxy @k) -> ... + + +So we have at least three options where we could do free variable extraction: +HsTyPat, ConPat, or a Match (used to represent a function LHS). And none +of those would be general enough. Rather than make an arbitrary choice, we +embrace left-to-right scoping in types and implement it with CPS, just like +it's done for view patterns in terms. +-} diff --git a/GHC/Rename/Splice.hs b/GHC/Rename/Splice.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Splice.hs @@ -0,0 +1,1101 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Rename.Splice ( + rnTopSpliceDecls, + + -- Typed splices + rnTypedSplice, + -- Untyped splices + rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceTyPat, rnSpliceDecl, + + -- Brackets + rnTypedBracket, rnUntypedBracket, + + checkThLocalName, checkThLocalNameWithLift, checkThLocalNameNoLift, traceSplice, SpliceInfo(..), + checkThLocalTyName, + ) where + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Driver.Env.Types + +import GHC.Rename.Env +import GHC.Rename.Utils ( newLocalBndrRn ) +import GHC.Rename.Unbound ( isUnboundName ) +import GHC.Rename.Module ( rnSrcDecls, findSplice ) +import GHC.Rename.Pat ( rnPat ) +import GHC.Types.Error +import GHC.Types.Basic ( TopLevelFlag, isTopLevel, maxPrec ) +import GHC.Types.SourceText ( SourceText(..) ) +import GHC.Utils.Outputable +import GHC.Unit.Module +import GHC.Types.SrcLoc +import GHC.Rename.HsType ( rnLHsType ) + +import Control.Monad ( unless, when ) + +import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) + +import GHC.Tc.Utils.Env ( tcMetaTy ) + +import GHC.Driver.DynFlags +import GHC.Data.FastString +import GHC.Utils.Logger +import GHC.Utils.Panic +import GHC.Driver.Hooks +import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName + , patQTyConName, quoteDecName, quoteExpName + , quotePatName, quoteTypeName, typeQTyConName) + +import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckPolyExpr ) +import {-# SOURCE #-} GHC.Tc.Gen.Splice + ( runMetaD + , runMetaE + , runMetaP + , runMetaT + , tcTopSpliceExpr + ) + +import GHC.Tc.Zonk.Type + +import GHCi.RemoteTypes ( ForeignRef ) +import qualified GHC.Boot.TH.Syntax as TH (Q) + +import qualified GHC.LanguageExtensions as LangExt +import qualified Data.Set as Set + +{- +************************************************************************ +* * + Template Haskell brackets +* * +************************************************************************ +-} + +-- Check that -XTemplateHaskellQuotes is enabled and available +checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM () +checkForTemplateHaskellQuotes e = + unlessXOptM LangExt.TemplateHaskellQuotes $ + failWith $ thSyntaxError $ IllegalTHQuotes e + +{- + +Note [Untyped quotes in typed splices and vice versa] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this typed splice + $$(f [| x |]) + +Is there anything wrong with that /typed/ splice containing an /untyped/ +quote [| x |]? One could ask the same about an /untyped/ slice containing a +/typed/ quote. + +In fact, both are fine (#24190). Presumably f's type looks something like: + f :: Q Expr -> Code Q Int + +It is pretty hard for `f` to use its (untyped code) argument to build a typed +syntax tree, but not impossible: +* `f` could use `unsafeCodeCoerce :: Q Exp -> Code Q a` +* `f` could just perform case analysis on the tree + +But in the end all that matters is that in $$( e ), the expression `e` has the +right type. It doesn't matter how `e` is built. To put it another way, the +untyped quote `[| x |]` could also be written `varE 'x`, which is an ordinary +expression. + +Moreover the ticked variable, 'x :: Name, is itself treated as an untyped quote; +but it is a perfectly fine sub-expression to have in a typed splice. + +(Historical note: GHC used to unnecessarily check that a typed quote only +occurred in a typed splice: #24190.) + +-} + +rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnTypedBracket e br_body + = addErrCtxt (TypedTHBracketCtxt br_body) $ + do { checkForTemplateHaskellQuotes e + + -- Check for nested brackets + ; cur_level <- getThLevel + ; case cur_level of + { Splice _ _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] + ; RunSplice _ -> + -- See Note [RunSplice ThLevel] in GHC.Tc.Types. + pprPanic "rnTypedBracket: Renaming typed bracket when running a splice" + (ppr e) + ; Comp -> return () + ; Brack {} -> failWithTc $ thSyntaxError + $ NestedTHBrackets + } + + -- Brackets are desugared to code that mentions the TH package + ; recordThUse + + ; traceRn "Renaming typed TH bracket" empty + ; (body', fvs_e) <- setThLevel (Brack cur_level RnPendingTyped) $ rnLExpr br_body + ; return (HsTypedBracket noExtField body', fvs_e) + + } + +rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnUntypedBracket e br_body + = addErrCtxt (UntypedTHBracketCtxt br_body) $ + do { checkForTemplateHaskellQuotes e + + -- Check for nested brackets + ; cur_level <- getThLevel + ; case cur_level of + { Splice _ _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] + ; RunSplice _ -> + -- See Note [RunSplice ThLevel] in GHC.Tc.Types. + pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice" + (ppr e) + ; Comp -> return () + ; Brack {} -> failWithTc $ thSyntaxError + $ NestedTHBrackets + } + + -- 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 $ + setThLevel (UntypedBrack cur_level ps_var) $ + rn_utbracket br_body + ; pendings <- readMutVar ps_var + ; return (HsUntypedBracket pendings body', fvs_e) + + } + +rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars) +rn_utbracket (VarBr _ flg rdr_name) + = do { name <- lookupOccRn (if flg then WL_Term else WL_Type) (unLoc rdr_name) + ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) name) + ; if flg then checkThLocalNameNoLift res_name else checkThLocalTyName name + ; check_namespace flg name + ; return (VarBr noExtField flg (noLocA name), unitFV name) } + +rn_utbracket (ExpBr _ e) = do { (e', fvs) <- rnLExpr e + ; return (ExpBr noExtField e', fvs) } + +rn_utbracket (PatBr _ p) + = rnPat ThPatQuote p $ \ p' -> return (PatBr noExtField p', emptyFVs) + +rn_utbracket (TypBr _ t) = do { (t', fvs) <- rnLHsType TypBrCtx t + ; return (TypBr noExtField t', fvs) } + +rn_utbracket (DecBrL _ decls) + = do { group <- groupDecls decls + ; gbl_env <- getGblEnv + ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } + -- The emptyDUs is so that we just collect uses for this + -- group alone in the call to rnSrcDecls below + ; (tcg_env, group') <- setGblEnv new_gbl_env $ + rnSrcDecls group + + -- Discard the tcg_env; it contains only extra info about fixity + ; traceRn "rn_utbracket dec" (ppr (tcg_dus tcg_env) $$ + ppr (duUses (tcg_dus tcg_env))) + ; return (DecBrG noExtField group', duUses (tcg_dus tcg_env)) } + where + groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) + groupDecls decls + = do { (group, mb_splice) <- findSplice decls + ; case mb_splice of + { Nothing -> return group + ; Just (splice, rest) -> + do { group' <- groupDecls rest + ; let group'' = appendGroups group group' + ; return group'' { hs_splcds = noLocA splice : hs_splcds group' } + } + }} + +rn_utbracket (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG" + + +-- | Ensure that we are not using a term-level name in a type-level namespace +-- or vice-versa. Throws a 'TcRnIncorrectNameSpace' error if there is a problem. +check_namespace :: Bool -> Name -> RnM () +check_namespace is_single_tick nm + = unless (isValNameSpace ns == is_single_tick) $ + failWithTc $ (TcRnIncorrectNameSpace nm True) + where + ns = nameNameSpace nm + +{- +********************************************************* +* * + Splices +* * +********************************************************* + +Note [Free variables of typed splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider renaming this: + f = ... + h = ...$(thing "f")... + +where the splice is a *typed* splice. The splice can expand into +literally anything, so when we do dependency analysis we must assume +that it might mention 'f'. So we simply treat all locally-defined +names as mentioned by any splice. This is terribly brutal, but I +don't see what else to do. For example, it'll mean that every +locally-defined thing will appear to be used, so no unused-binding +warnings. But if we miss the dependency, then we might typecheck 'h' +before 'f', and that will crash the type checker because 'f' isn't in +scope. + +Currently, I'm not treating a splice as also mentioning every import, +which is a bit inconsistent -- but there are a lot of them. We might +thereby get some bogus unused-import warnings, but we won't crash the +type checker. Not very satisfactory really. + +Note [Renamer errors] +~~~~~~~~~~~~~~~~~~~~~ +It's important to wrap renamer calls in checkNoErrs, because the +renamer does not fail for out of scope variables etc. Instead it +returns a bogus term/type, so that it can report more than one error. +We don't want the type checker to see these bogus unbound variables. +-} + +rnUntypedSpliceGen :: (HsUntypedSplice GhcRn -> RnM (a, FreeVars)) + -- Outside brackets, run splice + -> (UntypedSpliceFlavour, HsUntypedSpliceResult z -> HsUntypedSplice GhcRn -> RnM a) + -- Inside brackets, make it pending + -> HsUntypedSplice GhcPs + -> RnM (a, FreeVars) +rnUntypedSpliceGen run_splice (flavour, run_pending) splice + = addErrCtxt (UntypedSpliceCtxt splice) $ do + { level <- getThLevel + ; case level of + TypedBrack {} + -> failWithTc $ thSyntaxError + $ MismatchedSpliceType Untyped IsSplice + + UntypedBrack pop_level ps_var + -> do { (splice', fvs) <- setThLevel pop_level $ + rnUntypedSplice splice flavour + ; loc <- getSrcSpanM + ; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice) + ; result <- run_pending (HsUntypedSpliceNested splice_name) splice' + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (PendingRnSplice splice_name splice' : ps) + ; return (result, fvs) } + + _ -> do { checkTopSpliceAllowed splice + ; cur_level <- getThLevel + ; (splice', fvs1) <- checkNoErrs $ + setThLevel (Splice Untyped cur_level) $ + rnUntypedSplice splice flavour + -- checkNoErrs: don't attempt to run the splice if + -- renaming it failed; otherwise we get a cascade of + -- errors from e.g. unbound variables + ; (result, fvs2) <- run_splice splice' + ; return (result, fvs1 `plusFV` fvs2) } } + + +-- Nested splices are fine without TemplateHaskell because they +-- are not executed until the top-level splice is run. +checkTopSpliceAllowed :: HsUntypedSplice GhcPs -> RnM () +checkTopSpliceAllowed splice = do + let (ext, err) = spliceExtension splice + unlessXOptM ext $ failWith err + where + spliceExtension :: HsUntypedSplice GhcPs -> (LangExt.Extension, TcRnMessage) + spliceExtension (HsQuasiQuote {}) = + (LangExt.QuasiQuotes, TcRnIllegalQuasiQuotes) + spliceExtension (HsUntypedSpliceExpr {}) = + (LangExt.TemplateHaskell, thSyntaxError $ IllegalTHSplice) + +------------------ + +-- | Returns the result of running a splice and the modFinalizers collected +-- during the execution. +-- +-- See Note [Delaying modFinalizers in untyped splices]. +runRnSplice :: UntypedSpliceFlavour + -> (LHsExpr GhcTc -> TcRn res) + -> (res -> SDoc) -- How to pretty-print res + -- Usually just ppr, but not for [Decl] + -> HsUntypedSplice GhcRn + -> TcRn (res, [ForeignRef (TH.Q ())]) +runRnSplice flavour run_meta ppr_res splice + = do { hooks <- hsc_hooks <$> getTopEnv + ; splice' <- case runRnSpliceHook hooks of + Nothing -> return splice + Just h -> h splice + + -- TODO: Should call tcUntypedSplice here + ; let the_expr = case splice' of + HsUntypedSpliceExpr _ e -> e + HsQuasiQuote _ q str -> mkQuasiQuoteExpr flavour q str + XUntypedSplice {} -> pprPanic "runRnSplice: XUntypedSplice" (pprUntypedSplice False Nothing splice') + + -- Typecheck the expression + ; meta_exp_ty <- tcMetaTy meta_ty_name + ; zonked_q_expr <- zonkTopLExpr =<< + tcTopSpliceExpr Untyped + (tcCheckPolyExpr the_expr meta_exp_ty) + + -- Run the expression + ; mod_finalizers_ref <- newTcRef [] + ; result <- setThLevel (RunSplice mod_finalizers_ref) $ + run_meta zonked_q_expr + ; mod_finalizers <- readTcRef mod_finalizers_ref + ; traceSplice (SpliceInfo { spliceDescription = what + , spliceIsDecl = is_decl + , spliceSource = Just the_expr + , spliceGenerated = ppr_res result }) + + ; return (result, mod_finalizers) } + + where + meta_ty_name = case flavour of + UntypedExpSplice -> expQTyConName + UntypedPatSplice -> patQTyConName + UntypedTypeSplice -> typeQTyConName + UntypedDeclSplice -> decsQTyConName + what = case flavour of + UntypedExpSplice -> "expression" + UntypedPatSplice -> "pattern" + UntypedTypeSplice -> "type" + UntypedDeclSplice -> "declarations" + is_decl = case flavour of + UntypedDeclSplice -> True + _ -> False + + +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +recordPendingSplice :: SplicePointName -> HsImplicitLiftSplice -> PendingStuff -> TcM (HsExpr GhcRn) +recordPendingSplice sp pn (RnPending ref) = do + let untyped_splice = XUntypedSplice pn + updTcRef ref (PendingRnSplice sp untyped_splice : ) + return (HsUntypedSplice (HsUntypedSpliceNested sp) untyped_splice) +-- Splices are not lifted for typed brackets +-- See Note [Lifecycle of an typed splice, and PendingTcSplice] +recordPendingSplice sp pn (RnPendingTyped) = do + let typed_splice = XTypedSplice pn + return (HsTypedSplice (HsTypedSpliceNested sp) typed_splice) +recordPendingSplice _ _ (TcPending _ _ _) = panic "impossible" + +------------------ +mkQuasiQuoteExpr :: UntypedSpliceFlavour -> LIdP GhcRn + -> XRec GhcPs FastString + -> LHsExpr GhcRn +-- Return the expression (quoter "...quote...") +-- which is what we must run in a quasi-quote +mkQuasiQuoteExpr flavour quoter (L q_span' quote) + = L q_span $ HsApp noExtField (L q_span + $ HsApp noExtField (L q_span + (mkHsVar (L (l2l q_span) quote_selector))) + quoterExpr) + quoteExpr + where + q_span = noAnnSrcSpan (locA q_span') + quoterExpr = L (l2l quoter) $! mkHsVar $! quoter + quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote + quote_selector = case flavour of + UntypedExpSplice -> quoteExpName + UntypedPatSplice -> quotePatName + UntypedTypeSplice -> quoteTypeName + UntypedDeclSplice -> quoteDecName + +--------------------- +unqualSplice :: RdrName +-- The RdrName for a SplicePointName. See GHC.Hs.Expr +-- Note [Lifecycle of an untyped splice, and PendingRnSplice] +-- We use "spn" (which is arbitrary) because it is brief but grepable-for. +unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "spn")) + +rnUntypedSplice :: HsUntypedSplice GhcPs + -> UntypedSpliceFlavour + -> RnM ( HsUntypedSplice GhcRn + , FreeVars) +-- Not exported...used for all +rnUntypedSplice (HsUntypedSpliceExpr _ expr) flavour + = do { (expr', fvs) <- rnLExpr expr + ; return (HsUntypedSpliceExpr (HsUserSpliceExt flavour) expr', fvs) } + +rnUntypedSplice (HsQuasiQuote _ quoter quote) flavour + = do { -- Rename the quoter; akin to the HsVar case of rnExpr + ; quoter' <- lookupLocatedOccRn WL_TermVariable quoter + ; let res_name = WithUserRdr (unLoc quoter) <$> quoter' + ; checkThLocalNameNoLift res_name + ; return (HsQuasiQuote (HsQuasiQuoteExt flavour) quoter' quote, unitFV (unLoc quoter')) } + +--------------------- +rnTypedSplice :: HsTypedSplice GhcPs -- Typed splice expression + -> RnM (HsExpr GhcRn, FreeVars) +rnTypedSplice sp@(HsTypedSpliceExpr _ expr) + = addErrCtxt (TypedSpliceCtxt Nothing sp) $ do + { level <- getThLevel + ; case level of + TypedBrack pop_level + -> do { loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice) + ; (e, fvs) <- setThLevel pop_level rn_splice + ; return (HsTypedSplice (HsTypedSpliceNested n') (HsTypedSpliceExpr noExtField e), fvs) + } + + UntypedBrack {} + -> failWithTc $ thSyntaxError $ MismatchedSpliceType Typed IsSplice + + _ -> do { unlessXOptM LangExt.TemplateHaskell + (failWith $ thSyntaxError IllegalTHSplice) + + ; cur_level <- getThLevel + ; (result, fvs1) <- checkNoErrs $ setThLevel (Splice Typed cur_level) rn_splice + -- checkNoErrs: don't attempt to run the splice if + -- renaming it failed; otherwise we get a cascade of + -- errors from e.g. unbound variables + + -- Run typed splice later, in the type checker + -- Ugh! See Note [Free variables of typed splices] above + ; traceRn "rnTypedSplice: typed expression splice" empty + ; lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [ greName gre + | gre <- globalRdrEnvElts gbl_rdr + , isLocalGRE gre] + lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) + fvs2 = lcl_names `plusFV` gbl_names + + ; return (HsTypedSplice HsTypedSpliceTop (HsTypedSpliceExpr noExtField result), fvs1 `plusFV` fvs2) } } + where + rn_splice :: RnM (LHsExpr GhcRn, FreeVars) + rn_splice = rnLExpr expr + +rnUntypedSpliceExpr :: HsUntypedSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnUntypedSpliceExpr splice + = rnUntypedSpliceGen run_expr_splice pend_expr_splice splice + where + pend_expr_splice :: (UntypedSpliceFlavour, HsUntypedSpliceResult (HsExpr GhcRn) -> HsUntypedSplice GhcRn -> RnM (HsExpr GhcRn)) + pend_expr_splice + = (UntypedExpSplice, \x y -> pure $ HsUntypedSplice x y) + + run_expr_splice rn_splice + = do { traceRn "rnUntypedSpliceExpr: untyped expression splice" empty + + -- Run the splice here, see Note [Running splices in the Renamer] + ; (expr_ps, mod_finalizers) + <- runRnSplice UntypedExpSplice runMetaE ppr rn_splice + -- mod_finalizers: See Note [Delaying modFinalizers in untyped splices]. + + -- Rename the expanded expression + ; (L l expr_rn, fvs) <- checkNoErrs (rnLExpr expr_ps) + + -- rn_splice :: HsUntypedSplice GhcRn is the original TH expression, + -- before expansion + -- expr_ps :: LHsExpr GhcPs is the result of running the splice + -- expr_rn :: HsExpr GhcRn is the result of renaming ps_expr + ; let res :: HsUntypedSpliceResult (HsExpr GhcRn) + res = HsUntypedSpliceTop + { utsplice_result_finalizers = ThModFinalizers mod_finalizers + , utsplice_result = expr_rn } + ; return (gHsPar (L l (HsUntypedSplice res rn_splice)), fvs) + } + +thSyntaxError :: THSyntaxError -> TcRnMessage +thSyntaxError err = TcRnTHError $ THSyntaxError err + +{- Note [Running splices in the Renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Splices used to be run in the typechecker, which led to (#4364). Since the +renamer must decide which expressions depend on which others, and it cannot +reliably do this for arbitrary splices, we used to conservatively say that +splices depend on all other expressions in scope. Unfortunately, this led to +the problem of cyclic type declarations seen in (#4364). Instead, by +running splices in the renamer, we side-step the problem of determining +dependencies: by the time the dependency analysis happens, any splices have +already been run, and expression dependencies can be determined as usual. + +However, see (#9813), for an example where we would like to run splices +*after* performing dependency analysis (that is, after renaming). It would be +desirable to typecheck "non-splicy" expressions (those expressions that do not +contain splices directly or via dependence on an expression that does) before +"splicy" expressions, such that types/expressions within the same declaration +group would be available to `reify` calls, for example consider the following: + +> module M where +> data D = C +> f = 1 +> g = $(mapM reify ['f, 'D, ''C] ...) + +Compilation of this example fails since D/C/f are not in the type environment +and thus cannot be reified as they have not been typechecked by the time the +splice is renamed and thus run. + +These requirements are at odds: we do not want to run splices in the renamer as +we wish to first determine dependencies and typecheck certain expressions, +making them available to reify, but cannot accurately determine dependencies +without running splices in the renamer! + +Indeed, the conclusion of (#9813) was that it is not worth the complexity +to try and + a) implement and maintain the code for renaming/typechecking non-splicy + expressions before splicy expressions, + b) explain to TH users which expressions are/not available to reify at any + given point. + +-} + +{- Note [Rebindable syntax and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When processing Template Haskell quotes with Rebindable Syntax (RS) enabled, +there are two possibilities: apply the RS rules to the quotes or don't. + +One might expect that with {-# LANGUAGE RebindableSyntax #-} at the top of a +module, any 'if' expression would end up being turned into a call to whatever +'ifThenElse' function is in scope, regardless of whether the said if expression +appears in "normal" Haskell code or in a TH quote. This however comes with its +problems. Consider the following code: + + {-# LANGUAGE TemplateHaskell, RebindableSyntax #-} + + module X where + + import Prelude ( Monad(..), Bool(..), print, ($) ) + import Language.Haskell.TH.Syntax + + $( do stuff <- [| if True then 10 else 15 |] + runIO $ print stuff + return [] ) + +If we apply the RS rules, then GHC would complain about not having suitable +fromInteger/ifThenElse functions in scope. But this quote is just a bit of +Haskell syntax that has yet to be used, or, to put it differently, placed +(spliced) in some context where the said functions might be available. More +generally, untyped TH quotes are meant to work with yet-unbound identifiers. +This tends to show that untyped TH and Rebindable Syntax overall don't play +well together. Users still have the option to splice "normal" if expressions +into modules where RS is enabled, to turn them into applications of +an 'ifThenElse' function of their choice. + +Typed TH (TTH) quotes, on the other hand, come with different constraints. They +don't quite have this "delayed" nature: we typecheck them while processing +them, and TTH users expect RS to Just Work in their quotes, exactly like it does +outside of the quotes. There, we do not have to accept unbound identifiers and +we can apply the RS rules both in the typechecking and desugaring of the quotes +without triggering surprising/bad behaviour for users. For instance, the +following code is expected to be rejected (because of the lack of suitable +'fromInteger'/'ifThenElse' functions in scope): + + {-# LANGUAGE TemplateHaskell, RebindableSyntax #-} + + module X where + + import Prelude ( Monad(..), Bool(..), print, ($) ) + import Language.Haskell.TH.Syntax + + $$( do stuff <- [|| if True then 10 else 15 ||] + runIO $ print stuff + return [] ) + +The conclusion is that even if RS is enabled for a given module, GHC disables it +when processing untyped TH quotes from that module, to avoid the aforementioned +problems, but keeps it on while processing typed TH quotes. + +This note and approach originated in #18102. + +-} + +{- Note [Delaying modFinalizers in untyped splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When splices run in the renamer, 'reify' does not have access to the local +type environment (#11832, [1]). + +For instance, in + +> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |]) + +'reify' cannot find @x@, because the local type environment is not yet +populated. To address this, we allow 'reify' execution to be deferred with +'addModFinalizer'. + +> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print) + [| return () |] + ) + +The finalizer is run with the local type environment when type checking is +complete. + +Since the local type environment is not available in the renamer, we annotate +the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where +@e@ is the result of splicing and @finalizers@ are the finalizers that have been +collected during evaluation of the splice [3]. In our example, + +> HsLet +> (x = e) +> (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print] +> (HsSplicedExpr $ return ()) +> ) + +When the typechecker finds the annotation, it inserts the finalizers in the +global environment and exposes the current local environment to them [4, 5, 6]. + +> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print] + +References: + +[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify +[2] 'rnSpliceExpr' +[3] 'GHC.Tc.Gen.Splice.qAddModFinalizer' +[4] 'GHC.Tc.Gen.Expr.tcExpr' ('HsSpliceE' ('HsSpliced' ...)) +[5] 'GHC.Tc.Gen.HsType.tcHsType' ('HsSpliceTy' ('HsSpliced' ...)) +[6] 'GHC.Tc.Gen.Pat.tc_pat' ('SplicePat' ('HsSpliced' ...)) + +-} + +---------------------- +rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars) +rnSpliceType splice + = rnUntypedSpliceGen run_type_splice pend_type_splice splice + where + pend_type_splice + = ( UntypedTypeSplice + , \x y -> pure $ HsSpliceTy x y) + + run_type_splice :: HsUntypedSplice GhcRn -> RnM (HsType GhcRn, FreeVars) + run_type_splice rn_splice + = do { traceRn "rnSpliceType: untyped type splice" empty + ; (hs_ty2, mod_finalizers) <- + runRnSplice UntypedTypeSplice runMetaT ppr rn_splice + ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2 + ; checkNoErrs $ rnLHsType doc hs_ty2 } + -- checkNoErrs: see Note [Renamer errors] + + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( HsSpliceTy (HsUntypedSpliceTop (ThModFinalizers mod_finalizers) + (mb_paren hs_ty3)) + rn_splice + , fvs + ) } + -- Wrap the result of the splice in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + + -- Wrap a non-atomic result in HsParTy parens; + -- but not if it's atomic to avoid double parens for operators + -- This is to account for, say foo :: $(blah) -> Int + -- when we want $(blah) to expand to (this -> that), with parens. + -- Sadly, it's awkward add precisely the correct parens, because + -- that depends on the context. + mb_paren :: LHsType GhcRn -> LHsType GhcRn + mb_paren lhs_ty@(L loc hs_ty) + | hsTypeNeedsParens maxPrec hs_ty = L loc (HsParTy noAnn lhs_ty) + | otherwise = lhs_ty + +{- Note [Partial Type Splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Partial Type Signatures are partially supported in TH type splices: only +anonymous wild cards are allowed. + + -- ToDo: SLPJ says: I don't understand all this + +Normally, named wild cards are collected before renaming a (partial) type +signature. However, TH type splices are run during renaming, i.e. after the +initial traversal, leading to out of scope errors for named wild cards. We +can't just extend the initial traversal to collect the named wild cards in TH +type splices, as we'd need to expand them, which is supposed to happen only +once, during renaming. + +Similarly, the extra-constraints wild card is handled right before renaming +too, and is therefore also not supported in a TH type splice. Another reason +to forbid extra-constraints wild cards in TH type splices is that a single +signature can contain many TH type splices, whereas it mustn't contain more +than one extra-constraints wild card. Enforcing would this be hard the way +things are currently organised. + +Anonymous wild cards pose no problem, because they start out without names and +are given names during renaming. These names are collected right after +renaming. The names generated for anonymous wild cards in TH type splices will +thus be collected as well. + +For more details about renaming wild cards, see GHC.Rename.HsType.rnHsSigWcType + +Note that partial type signatures are fully supported in TH declaration +splices, e.g.: + + [d| foo :: _ => _ + foo x y = x == y |] + +This is because in this case, the partial type signature can be treated as a +whole signature, instead of as an arbitrary type. + +-} + + +---------------------- +-- | Rename a splice pattern. See Note [rnSplicePat] +rnSplicePat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs)) + , FreeVars) +rnSplicePat splice + = rnUntypedSpliceGen run_pat_splice pend_pat_splice splice + where + pend_pat_splice + = (UntypedPatSplice + , \x y -> pure (y, x)) -- Pat splice is nested and thus simply renamed + + run_pat_splice rn_splice + = do { traceRn "rnSplicePat: untyped pattern splice" empty + ; (pat, mod_finalizers) <- + runRnSplice UntypedPatSplice runMetaP ppr rn_splice + -- See Note [Delaying modFinalizers in untyped splices]. + ; let p = HsUntypedSpliceTop (ThModFinalizers mod_finalizers) pat + ; return ((rn_splice, p), emptyFVs) } + -- Wrap the result of the quasi-quoter in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + +-- | Rename a splice type pattern. Much the same as `rnSplicePat`, but works with LHsType instead of LPat +rnSpliceTyPat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LHsType GhcPs)) + , FreeVars) +rnSpliceTyPat splice + = rnUntypedSpliceGen run_ty_pat_splice pend_ty_pat_splice splice + where + pend_ty_pat_splice + = (UntypedTypeSplice + , \x y -> pure (y, x)) + + run_ty_pat_splice rn_splice + = do { traceRn "rnSpliceTyPat: untyped pattern splice" empty + ; (ty, mod_finalizers) <- + runRnSplice UntypedTypeSplice runMetaT ppr rn_splice + -- See Note [Delaying modFinalizers in untyped splices]. + ; let t = HsUntypedSpliceTop (ThModFinalizers mod_finalizers) ty + ; return ((rn_splice, t), emptyFVs) } + -- Wrap the result of the quasi-quoter in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + +---------------------- +rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) +rnSpliceDecl (SpliceDecl _ (L loc splice) flg) + = rnUntypedSpliceGen run_decl_splice pend_decl_splice splice + where + pend_decl_splice + = ( UntypedDeclSplice + , \_ y -> pure $ SpliceDecl noExtField (L loc y) flg) + + run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (pprUntypedSplice True Nothing rn_splice) + +rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) +-- Declaration splice at the very top level of the module +rnTopSpliceDecls splice + = do { checkTopSpliceAllowed splice + ; cur_level <- getThLevel + ; (rn_splice, fvs) <- checkNoErrs $ + setThLevel (Splice Untyped cur_level) $ + rnUntypedSplice splice UntypedDeclSplice + -- As always, be sure to checkNoErrs above lest we end up with + -- holes making it to typechecking, hence #12584. + -- + -- Note that we cannot call checkNoErrs for the whole duration + -- of rnTopSpliceDecls. The reason is that checkNoErrs changes + -- the local environment to temporarily contain a new + -- reference to store errors, and add_mod_finalizers would + -- cause this reference to be stored after checkNoErrs finishes. + -- This is checked by test TH_finalizer. + ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty + ; (decls, mod_finalizers) <- checkNoErrs $ + runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice + ; add_mod_finalizers_now mod_finalizers + ; return (decls,fvs) } + where + ppr_decls :: [LHsDecl GhcPs] -> SDoc + ppr_decls ds = vcat (map ppr ds) + + -- Adds finalizers to the global environment instead of delaying them + -- to the type checker. + -- + -- Declaration splices do not have an interesting local environment so + -- there is no point in delaying them. + -- + -- See Note [Delaying modFinalizers in untyped splices]. + add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn () + add_mod_finalizers_now [] = return () + add_mod_finalizers_now mod_finalizers = do + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + env <- getLclEnv + updTcRef th_modfinalizers_var $ \fins -> + (env, ThModFinalizers mod_finalizers) : fins + + +{- +Note [rnSplicePat] +~~~~~~~~~~~~~~~~~~ +Renaming a pattern splice is a bit tricky, because we need the variables +bound in the pattern to be in scope in the RHS of the pattern. This scope +management is effectively done by using continuation-passing style in +GHC.Rename.Pat, through the CpsRn monad. We don't wish to be in that monad here +(it would create import cycles and generally conflict with renaming other +splices), so we really want to return a (Pat GhcPs) -- the result of +running the splice -- which can then be further renamed in GHC.Rename.Pat, in +the CpsRn monad. + +The problem is that if we're renaming a splice within a bracket, we +*don't* want to run the splice now. We really do just want to rename +it to an HsUntypedSplice Name. Of course, then we can't know what variables +are bound within the splice. So we accept any unbound variables and +rename them again when the bracket is spliced in. If a variable is brought +into scope by a pattern splice all is fine. If it is not then an error is +reported. + +In any case, when we're done in rnSplicePat, we'll have both the renamed +splice, and either a Pat RdrName and ThModFinalizers (the result of running a +top-level splice) or a splice point name. Thus, rnSplicePat returns both +HsUntypedSplice GhcRn, and HsUntypedSpliceResult (Pat GhcPs) -- which models +the existence of either the result of running the splice (HsUntypedSpliceTop), +or its splice point name if nested (HsUntypedSpliceNested) +-} + +-- | The splice data to be logged +data SpliceInfo + = SpliceInfo + { spliceDescription :: String + , spliceSource :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls + -- added by addTopDecls + , spliceIsDecl :: Bool -- True <=> put the generate code in a file + -- when -dth-dec-file is on + , spliceGenerated :: SDoc + } + -- Note that 'spliceSource' is *renamed* but not *typechecked* + -- Reason (a) less typechecking crap + -- (b) data constructors after type checking have been + -- changed to their *wrappers*, and that makes them + -- print always fully qualified + +-- | outputs splice information for 2 flags which have different output formats: +-- `-ddump-splices` and `-dth-dec-file` +traceSplice :: SpliceInfo -> TcM () +traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src + , spliceGenerated = gen, spliceIsDecl = is_decl }) + = do loc <- case mb_src of + Nothing -> getSrcSpanM + Just (L loc _) -> return (locA loc) + traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) + + when is_decl $ do -- Raw material for -dth-dec-file + logger <- getLogger + liftIO $ putDumpFileMaybe logger Opt_D_th_dec_file "" FormatHaskell (spliceCodeDoc loc) + where + -- `-ddump-splices` + spliceDebugDoc :: SrcSpan -> SDoc + spliceDebugDoc loc + = let code = case mb_src of + Nothing -> ending + Just e -> nest 2 (ppr (stripParensLHsExpr e)) : ending + ending = [ text "======>", nest 2 gen ] + in hang (ppr loc <> colon <+> text "Splicing" <+> text sd) + 2 (sep code) + + -- `-dth-dec-file` + spliceCodeDoc :: SrcSpan -> SDoc + spliceCodeDoc loc + = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd + , gen ] + +checkThLocalTyName :: Name -> RnM () +checkThLocalTyName name + | isUnboundName name -- Do not report two errors for + = return () -- $(not_in_scope args) + + | otherwise + = do { traceRn "checkThLocalTyName" (ppr name) + ; mb_local_use <- getCurrentAndBindLevel name + ; case mb_local_use of { + Nothing -> return () ; -- Not a locally-bound thing + Just (top_lvl, bind_lvl, use_lvl) -> + do { let use_lvl_idx = thLevelIndex use_lvl + -- We don't check the well levelledness of name here. + -- this would break test for #20969 + -- + -- Consequently there is no check&restiction for top level splices. + -- But it's annoying anyway. + -- + -- Therefore checkCrossLevelLiftingTy shouldn't assume anything + -- about bind_lvl and use_lvl relation. + -- + ; traceRn "checkThLocalTyName" (ppr name <+> ppr bind_lvl + <+> ppr use_lvl + <+> ppr use_lvl) + ; dflags <- getDynFlags + ; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl use_lvl_idx name } } } + +-- | Check whether we are allowed to use a Name in this context (for TH purposes) +-- In the case of a level incorrect program, attempt to fix it by using +-- a Lift constraint. +checkThLocalNameWithLift :: LIdOccP GhcRn -> RnM (HsExpr GhcRn) +checkThLocalNameWithLift = checkThLocalName True + +-- | Check whether we are allowed to use a Name in this context (for TH purposes) +-- In the case of a level incorrect program, do not attempt to fix it by using +-- a Lift constraint. +checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM () +checkThLocalNameNoLift name = checkThLocalName False name >> return () + +-- | Implemenation of the level checks +-- See Note [Template Haskell levels] +checkThLocalName :: Bool -> LIdOccP GhcRn -> RnM (HsExpr GhcRn) +checkThLocalName allow_lifting name_var + -- Exact and Orig names are not imported, so presumed available at all levels. + | isExact (userRdrName (unLoc name_var)) || isOrig (userRdrName (unLoc name_var)) + = return (HsVar noExtField name_var) + | isUnboundName name -- Do not report two errors for + = return (HsVar noExtField name_var) -- $(not_in_scope args) + | isWiredInName name + = return (HsVar noExtField name_var) + | otherwise + = do { + mb_local_use <- getCurrentAndBindLevel name + ; case mb_local_use of { + Nothing -> return (HsVar noExtField name_var) ; -- Not a locally-bound thing + Just (top_lvl, bind_lvl, use_lvl) -> + do { let use_lvl_idx = thLevelIndex use_lvl + ; cur_mod <- extractModule <$> getGblEnv + ; let is_local + | Just mod <- nameModule_maybe name = mod == cur_mod + | otherwise = True + ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl <+> ppr use_lvl) + ; dflags <- getDynFlags + ; env <- getGlobalRdrEnv + ; let mgre = lookupGRE_Name env name + ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var } } } + where + name = getName name_var + +-------------------------------------- +checkCrossLevelLifting :: DynFlags + -> LevelCheckReason + -> TopLevelFlag + -> Bool + -> Bool + -> Set.Set ThLevelIndex + -> ThLevel + -> ThLevelIndex + -> LIdOccP GhcRn + -> TcM (HsExpr GhcRn) +checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var + -- 1. If name is in-scope, at the correct level. + | use_lvl_idx `Set.member` bind_lvl = return (HsVar noExtField name_var) + -- 2. Name is imported with -XImplicitStagePersistence + | not is_local + , xopt LangExt.ImplicitStagePersistence dflags = return (HsVar noExtField name_var) + -- 3. Name is top-level, with -XImplicitStagePersistence, and needs + -- to be persisted into the future. + | isTopLevel top_lvl + , is_local + , any (use_lvl_idx >=) (Set.toList bind_lvl) + , xopt LangExt.ImplicitStagePersistence dflags = when (isExternalName name) (keepAlive name) >> return (HsVar noExtField name_var) + -- 4. Name is in a bracket, and lifting is allowed + | Brack _ pending <- use_lvl + , any (use_lvl_idx >=) (Set.toList bind_lvl) + , allow_lifting + = do + let mgre = case reason of + LevelCheckSplice _ gre -> gre + _ -> Nothing + (splice_name :: Name) <- newLocalBndrRn (noLocA unqualSplice) + let pend_splice :: HsImplicitLiftSplice + pend_splice = HsImplicitLiftSplice bind_lvl use_lvl_idx mgre name_var + -- Warning for implicit lift (#17804) + addDetailedDiagnostic (TcRnImplicitLift name) + + -- Update the pending splices if we are renaming a typed bracket + recordPendingSplice splice_name pend_splice pending + -- Otherwise, we have a level error, report. + | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx Nothing ErrorWithoutFlag ) >> return (HsVar noExtField name_var) + where + name = getName name_var + +checkCrossLevelLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex -> Name -> TcM () +checkCrossLevelLiftingTy dflags top_lvl bind_lvl _use_lvl use_lvl_idx name + | isTopLevel top_lvl + , xopt LangExt.ImplicitStagePersistence dflags + = return () + + -- There is no liftType (yet), so we could error, or more conservatively, just warn. + -- + -- For now, we check here for both untyped and typed splices, as we don't create splices. + + -- Can also happen for negative cases + -- See comment in checkThLocalTyName: + | use_lvl_idx `notElem` bind_lvl + = addDiagnostic $ TcRnBadlyLevelledType name bind_lvl use_lvl_idx + + | otherwise + = return () + +{- +Note [Keeping things alive for Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = x+1 + g y = [| f 3 |] + +Here 'f' is referred to from inside the bracket, which turns into data +and mentions only f's *name*, not 'f' itself. So we need some other +way to keep 'f' alive, lest it get dropped as dead code. That's what +keepAlive does. It puts it in the keep-alive set, which subsequently +ensures that 'f' stays as a top level binding. + +This must be done by the renamer, not the type checker (as of old), +because the type checker doesn't typecheck the body of untyped +brackets (#8540). + +A thing can have a bind_lvl of outerLevel, but have an internal name: + foo = [d| op = 3 + bop = op + 1 |] +Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is +bound inside a bracket. That is because we don't even record +binding levels for top-level things; the binding levels are in the +LocalRdrEnv. + +So the occurrence of 'op' in the rhs of 'bop' looks a bit like a +cross-stage thing, but it isn't really. And in fact we never need +to do anything here for top-level bound things, so all is fine, if +a bit hacky. + +For these chaps (which have Internal Names) we don't want to put +them in the keep-alive set. + +Note [Quoting names] +~~~~~~~~~~~~~~~~~~~~ +A quoted name 'n is a bit like a quoted expression [| n |], except that we +have no cross-level lifting (c.f. GHC.Tc.Gen.Expr.thBrackId). So, after incrementing +the use-level to account for the brackets, the cases are: + + bind > use Error + bind = use+1 OK + bind < use + Imported things OK + Top-level things OK + Non-top-level Error + +where 'use' is the binding level of the 'n quote. (So inside the implied +bracket the level would be use+1.) + +Examples: + + f 'map -- OK; also for top-level defns of this module + + \x. f 'x -- Not ok (bind = 1, use = 1) + -- (whereas \x. f [| x |] might have been ok, by + -- cross-level lifting + + \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1) + + [| \x. $(f 'x) |] -- OK (bind = 2, use = 1) +-} diff --git a/GHC/Rename/Splice.hs-boot b/GHC/Rename/Splice.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Rename/Splice.hs-boot @@ -0,0 +1,18 @@ +module GHC.Rename.Splice where + +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Types.Name (Name) +import GHC.Types.Name.Set + + +rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars) +rnSplicePat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs)) + , FreeVars) +rnSpliceTyPat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LHsType GhcPs)) + , FreeVars) +rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) + +rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) + +checkThLocalTyName :: Name -> RnM () diff --git a/GHC/Rename/Unbound.hs b/GHC/Rename/Unbound.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Unbound.hs @@ -0,0 +1,504 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +{- + +This module contains helper functions for reporting and creating +unbound variables. + +-} +module GHC.Rename.Unbound + ( mkUnboundName + , mkUnboundNameRdr + , mkUnboundGRE + , mkUnboundGRERdr + , isUnboundName + , reportUnboundName + , unknownNameSuggestions + , unknownNameSuggestionsMessage + , similarNameSuggestions + , fieldSelectorSuggestions + , WhatLooking(..) + , WhereLooking(..) + , LookingFor(..) + , unboundName + , unboundNameX + , unboundTermNameInTypes + , IsTermInTypes(..) + , notInScopeErr + , relevantNameSpace + , suggestionIsRelevant + , termNameInType + ) +where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Driver.Ppr +import GHC.Driver.Env (hsc_units) +import GHC.Driver.Env.Types + +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( getHoleFitDispConfig ) +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Builtin.Names ( mkUnboundName, isUnboundName ) +import GHC.Utils.Misc +import GHC.Utils.Panic (panic) + +import GHC.Data.Maybe +import GHC.Data.FastString + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Types.Hint + ( GhcHint (SuggestExtension, RemindFieldSelectorSuppressed, ImportSuggestion, SuggestSimilarNames) + , LanguageExtensionHint (SuggestSingleExtension) + , ImportSuggestion(..), SimilarName(..), HowInScope(..) ) +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Name +import GHC.Types.Name.Reader + +import GHC.Unit.Module +import GHC.Unit.Module.Imported +import GHC.Utils.Outputable +import GHC.Runtime.Context + +import GHC.Data.Bag +import Language.Haskell.Syntax.ImpExp + +import Data.List (sortBy, partition) +import Data.List.NonEmpty ( pattern (:|), NonEmpty ) +import qualified Data.List.NonEmpty as NE ( nonEmpty ) +import Data.Function ( on ) +import qualified Data.Semigroup as S +import qualified Data.Map as M + +{- +************************************************************************ +* * + What to do when a lookup fails +* * +************************************************************************ +-} + +data WhereLooking = WL_Anywhere -- Any binding + | WL_Global -- Any top-level binding (local or imported) + | WL_LocalTop -- Any top-level binding in this module + | WL_LocalOnly + -- Only local bindings + -- (pattern synonyms declarations, + -- see Note [Renaming pattern synonym variables] + -- in GHC.Rename.Bind) + +data LookingFor = LF { lf_which :: WhatLooking + , lf_where :: WhereLooking + } + +data IsTermInTypes = UnknownTermInTypes RdrName | TermInTypes RdrName | NoTermInTypes + +mkUnboundNameRdr :: RdrName -> Name +mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) + +mkUnboundGRE :: OccName -> GlobalRdrElt +mkUnboundGRE occ = mkLocalGRE UnboundGRE NoParent $ mkUnboundName occ + +mkUnboundGRERdr :: RdrName -> GlobalRdrElt +mkUnboundGRERdr rdr = mkLocalGRE UnboundGRE NoParent $ mkUnboundNameRdr rdr + +reportUnboundName :: WhatLooking -> RdrName -> RnM Name +reportUnboundName what_look rdr = unboundName (LF what_look WL_Anywhere) rdr + +unboundName :: LookingFor -> RdrName -> RnM Name +unboundName lf rdr = unboundNameX lf rdr [] + +unboundNameX :: LookingFor -> RdrName -> [GhcHint] -> RnM Name +unboundNameX looking_for rdr_name hints + = unboundNameOrTermInType NoTermInTypes looking_for rdr_name hints + +unboundTermNameInTypes :: LookingFor -> RdrName -> RdrName -> RnM Name +unboundTermNameInTypes looking_for rdr_name demoted_rdr_name + = unboundNameOrTermInType (UnknownTermInTypes demoted_rdr_name) looking_for rdr_name [] + +-- Catches imported qualified terms in type signatures +-- with proper error message and suggestions +termNameInType :: LookingFor -> RdrName -> RdrName -> [GhcHint] -> RnM Name +termNameInType looking_for rdr_name demoted_rdr_name external_hints + = unboundNameOrTermInType (TermInTypes demoted_rdr_name) looking_for rdr_name external_hints + +unboundNameOrTermInType :: IsTermInTypes -> LookingFor -> RdrName -> [GhcHint] -> RnM Name +unboundNameOrTermInType if_term_in_type looking_for rdr_name hints + = do { dflags <- getDynFlags + ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags + ; if not show_helpful_errors + then addErr =<< make_error [] hints + else do { local_env <- getLocalRdrEnv + ; global_env <- getGlobalRdrEnv + ; impInfo <- getImports + ; currmod <- getModule + ; ic <- hsc_IC <$> getTopEnv + ; let (imp_errs, suggs) = + unknownNameSuggestions_ looking_for + dflags ic currmod global_env local_env impInfo + rdr_name + ; traceTc "unboundNameOrTermInType" $ + vcat [ text "rdr_name:" <+> ppr rdr_name + , text "what_looking:" <+> text (show $ lf_which looking_for) + , text "imp_errs:" <+> ppr imp_errs + , text "suggs:" <+> ppr suggs + ] + ; addErr =<< + make_error imp_errs (hints ++ suggs) } + ; return (mkUnboundNameRdr rdr_name) } + where + name_to_search = case if_term_in_type of + NoTermInTypes -> rdr_name + UnknownTermInTypes demoted_name -> demoted_name + TermInTypes demoted_name -> demoted_name + + err = notInScopeErr (lf_where looking_for) name_to_search + + make_error imp_errs hints = + case if_term_in_type of + TermInTypes demoted_name -> + unknownNameSuggestionsMessage (TcRnTermNameInType demoted_name) + [] -- no import errors + hints + _ -> unknownNameSuggestionsMessage (TcRnNotInScope err name_to_search) + imp_errs hints + +unknownNameSuggestionsMessage :: TcRnMessage -> [ImportError] -> [GhcHint] -> RnM TcRnMessage +unknownNameSuggestionsMessage msg imp_errs hints + = do { unit_state <- hsc_units <$> getTopEnv + ; hfdc <- getHoleFitDispConfig + ; let supp = case NE.nonEmpty imp_errs of + Nothing -> Nothing + Just ne_imp_errs -> + (Just (hfdc, [SupplementaryImportErrors ne_imp_errs])) + ; return $ + TcRnMessageWithInfo unit_state $ + mkDetailedMessage (ErrInfo [] supp hints) msg + } + +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 :: LocalRdrEnv -> WhatLooking -> RdrName -> RnM ([ImportError], [GhcHint]) +unknownNameSuggestions lcl_env what_look tried_rdr_name = + do { dflags <- getDynFlags + ; rdr_env <- getGlobalRdrEnv + ; imp_info <- getImports + ; curr_mod <- getModule + ; interactive_context <- hsc_IC <$> getTopEnv + ; return $ + unknownNameSuggestions_ + (LF what_look WL_Anywhere) + dflags interactive_context curr_mod rdr_env lcl_env imp_info tried_rdr_name } + +unknownNameSuggestions_ :: LookingFor -> DynFlags -> InteractiveContext + -> Module + -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails + -> RdrName -> ([ImportError], [GhcHint]) +unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env + imports tried_rdr_name = (imp_errs, suggs) + where + suggs = mconcat + [ if_ne (SuggestSimilarNames tried_rdr_name) $ + similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name + , map (ImportSuggestion $ rdrNameOcc tried_rdr_name) imp_suggs + , extensionSuggestions tried_rdr_name + , fieldSelectorSuggestions global_env tried_rdr_name ] + (imp_errs, imp_suggs) = importSuggestions looking_for hpt curr_mod imports tried_rdr_name + + if_ne :: (NonEmpty a -> b) -> [a] -> [b] + if_ne _ [] = [] + if_ne f (a : as) = [f (a :| as)] + +-- | When the name is in scope as field whose selector has been suppressed by +-- NoFieldSelectors, display a helpful message explaining this. +fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> [GhcHint] +fieldSelectorSuggestions global_env tried_rdr_name + | null gres = [] + | otherwise = [RemindFieldSelectorSuppressed tried_rdr_name parents] + where + gres = filter isNoFieldSelectorGRE + $ lookupGRE global_env (LookupRdrName tried_rdr_name AllRelevantGREs) + parents = [ parent | ParentIs parent <- map greParent gres ] + +similarNameSuggestions :: LookingFor -> DynFlags + -> GlobalRdrEnv -> LocalRdrEnv + -> RdrName -> [SimilarName] +similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env + local_env tried_rdr_name + = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities + where + all_possibilities :: [(String, SimilarName)] + all_possibilities = case what_look of + WL_None -> [] + _ -> [ (showPpr dflags r, SimilarRdrName r (Just $ 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_is_qual = isQual tried_rdr_name + + is_relevant sugg_occ = + suggestionIsRelevant dflags what_look sugg_occ + && isSymOcc sugg_occ == tried_is_sym + -- Treat operator and non-operators as non-matching + -- This heuristic avoids things like + -- Not in scope 'f'; perhaps you meant '+' (from Prelude) + + local_ok = case where_look of { WL_Anywhere -> True + ; WL_LocalOnly -> True + ; _ -> False } + + local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)] + local_possibilities env + | tried_is_qual = [] + | not local_ok = [] + | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name) + | name <- localRdrEnvElts env + , let occ = nameOccName name + , is_relevant occ + ] + + global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)] + global_possibilities global_env + | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual (Just how)) + | gre <- globalRdrEnvElts global_env + , isGreOk looking_for gre + , let occ = greOccName gre + , is_relevant occ + , (mod, how) <- qualsInScope gre + , let rdr_qual = mkRdrQual mod occ ] + + | otherwise = [ (rdr_unqual, sim) + | gre <- globalRdrEnvElts global_env + , isGreOk looking_for gre + , let occ = greOccName gre + rdr_unqual = mkRdrUnqual occ + , is_relevant occ + , sim <- case (unquals_in_scope gre, quals_only gre) of + (how:_, _) -> [ SimilarRdrName rdr_unqual (Just how) ] + ([], pr:_) -> [ pr ] -- See Note [Only-quals] + ([], []) -> [] ] + + -- Note [Only-quals] + -- ~~~~~~~~~~~~~~~~~ + -- The second alternative returns those names with the same + -- OccName as the one we tried, but live in *qualified* imports + -- e.g. if you have: + -- + -- > import qualified Data.Map as Map + -- > foo :: Map + -- + -- then we suggest @Map.Map@. + + -------------------- + unquals_in_scope :: GlobalRdrElt -> [HowInScope] + unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is }) + | lcl = [ LocallyBoundAt (greDefinitionSrcSpan gre) ] + | otherwise = [ ImportedBy ispec + | i <- bagToList is, let ispec = is_decl i + , not (is_qual ispec) ] + + + -------------------- + quals_only :: GlobalRdrElt -> [SimilarName] + -- Ones for which *only* the qualified version is in scope + quals_only (gre@GRE { gre_imp = is }) + = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (Just $ ImportedBy ispec)) + | i <- bagToList is, let ispec = is_decl i, is_qual ispec ] + + +-- | Generate errors and helpful suggestions if a qualified name Mod.foo is not in scope. +importSuggestions :: LookingFor + -> InteractiveContext -> Module + -> ImportAvails -> RdrName -> ([ImportError], [ImportSuggestion]) +importSuggestions looking_for ic currMod imports rdr_name + | WL_LocalOnly <- lf_where looking_for = ([], []) + | WL_LocalTop <- lf_where looking_for = ([], []) + | not (isQual rdr_name || isUnqual rdr_name) = ([], []) + | Just name <- mod_name + , show_not_imported_line name + = ([MissingModule name], []) + | is_qualified + , null helpful_imports + , (mod : mods) <- map fst interesting_imports + = ([ModulesDoNotExport (mod :| mods) (lf_which looking_for) occ_name], []) + | mod : mods <- helpful_imports_non_hiding + = ([], [CouldImportFrom (mod :| mods)]) + | mod : mods <- helpful_imports_hiding + = ([], [CouldUnhideFrom (mod :| mods)]) + | otherwise + = ([], []) + where + is_qualified = isQual rdr_name + (mod_name, occ_name) = case rdr_name of + Unqual occ_name -> (Nothing, occ_name) + Qual mod_name occ_name -> (Just mod_name, occ_name) + _ -> panic "importSuggestions: dead code" + + + -- What import statements provide "Mod" at all + -- or, if this is an unqualified name, are not qualified imports + interesting_imports = [ (mod, imp) + | (mod, mod_imports) <- M.toList (imp_mods imports) + , Just imp <- return $ pick (importedByUser mod_imports) + ] + + -- Choose the imports from the interactive context which might have provided + -- a module. + interactive_imports = + filter pick_interactive (ic_imports ic) + + pick_interactive :: InteractiveImport -> Bool + pick_interactive (IIDecl d) | mod_name == Just (unLoc (ideclName d)) = True + | mod_name == fmap unLoc (ideclAs d) = True + pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True + pick_interactive _ = False + + -- We want to keep only one for each original module; preferably one with an + -- explicit import list (for no particularly good reason) + pick :: [ImportedModsVal] -> Maybe ImportedModsVal + pick = listToMaybe . sortBy cmp . filter select + where select imv = case mod_name of Just name -> imv_name imv == name + Nothing -> not (imv_qualified imv) + cmp = on compare imv_is_hiding S.<> on SrcLoc.leftmost_smallest imv_span + + -- Which of these would export a 'foo' + -- (all of these are restricted imports, because if they were not, we + -- wouldn't have an out-of-scope error in the first place) + helpful_imports = filter helpful interesting_imports + where helpful (_,imv) + = any (isGreOk looking_for) $ + lookupGRE (imv_all_exports imv) + (LookupOccName occ_name $ RelevantGREsFOS WantNormal) + + -- Which of these do that because of an explicit hiding list resp. an + -- explicit import list + (helpful_imports_hiding, helpful_imports_non_hiding) + = partition (imv_is_hiding . snd) helpful_imports + + -- See Note [When to show/hide the module-not-imported line] + show_not_imported_line :: ModuleName -> Bool -- #15611 + show_not_imported_line modnam + | not (null interactive_imports) = False -- 1 (interactive context) + | not (null interesting_imports) = False -- 1 (normal module import) + | moduleName currMod == modnam = False -- 2 + | otherwise = True + +extensionSuggestions :: RdrName -> [GhcHint] +extensionSuggestions rdrName + | rdrName == mkUnqual varName (fsLit "mdo") || + rdrName == mkUnqual varName (fsLit "rec") + = [SuggestExtension $ SuggestSingleExtension empty LangExt.RecursiveDo] + | otherwise + = [] + +qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)] +-- Ones for which the qualified version is in scope +qualsInScope gre@GRE { gre_lcl = lcl, gre_imp = is } + | lcl = case greDefinitionModule gre of + Nothing -> [] + Just m -> [(moduleName m, LocallyBoundAt (greDefinitionSrcSpan gre))] + | otherwise = [ (is_as ispec, ImportedBy ispec) + | i <- bagToList is, let ispec = is_decl i ] + +isGreOk :: LookingFor -> GlobalRdrElt -> Bool +isGreOk (LF what_look where_look) gre = what_ok && where_ok + where + -- when looking for record fields, what_ok checks whether the GRE is a + -- record field. Otherwise, it checks whether the GRE is a record field + -- defined in a module with -XNoFieldSelectors - it wouldn't be a useful + -- suggestion in that case. + what_ok = case what_look of + WL_RecField -> isRecFldGRE gre + _ -> not (isNoFieldSelectorGRE gre) + + where_ok = case where_look of + WL_LocalTop -> isLocalGRE gre + WL_LocalOnly -> False + _ -> True + +-- | Is it OK to suggest an identifier in some other 'NameSpace', +-- given what we are looking for? +-- +-- See Note [Related name spaces] +suggestionIsRelevant + :: DynFlags -- ^ to find out whether -XDataKinds is enabled + -> WhatLooking -- ^ What kind of name are we looking for? + -> OccName -- ^ The suggestion + -- + -- We only look at the suggestion's 'NameSpace', + -- but passing the whole 'OccName' is convenient + -- for debugging. + -> Bool +suggestionIsRelevant dflags what_looking suggestion = + relevantNameSpace data_kinds what_looking suggestion_ns + where + suggestion_ns = occNameSpace suggestion + data_kinds = xopt LangExt.DataKinds dflags + +-- | Is a 'NameSpace' relevant for what we are looking for? +relevantNameSpace :: Bool -- ^ is @-XDataKinds@ enabled? + -> WhatLooking -- ^ what are we looking for? + -> NameSpace -- ^ is this 'NameSpace' relevant? + -> Bool +relevantNameSpace data_kinds = \case + WL_Anything -> const True + WL_TyCon -> isTcClsNameSpace + WL_TyCon_or_TermVar -> isTcClsNameSpace <||> isTermVarOrFieldNameSpace + WL_TyVar -> isTvNameSpace + WL_Constructor -> isTcClsNameSpace <||> isDataConNameSpace + WL_ConLike -> isDataConNameSpace + WL_RecField -> isFieldNameSpace + WL_Term -> isValNameSpace + WL_TermVariable -> isTermVarOrFieldNameSpace + WL_Type -> if data_kinds + then not . isTermVarOrFieldNameSpace + else not . isValNameSpace + WL_None -> const False + +{- Note [Related name spaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Name spaces are related if there is a chance to mean the one when one writes +the other, i.e. variables <-> data constructors and type variables <-> type +constructors. + +In most contexts, this mistake can happen in both directions. Not so in +patterns: + +When a user writes + foo (just a) = ... +It is possible that they meant to use `Just` instead. However, when they write + foo (Map a) = ... +It is unlikely that they mean to use `map`, since variables cannot be used here. + +Similarly, when we look for record fields, data constructors are not in a +related namespace. + +Furthermore, with -XDataKinds, the data constructor name space is related to +the type variable and type constructor name spaces. + +Note [When to show/hide the module-not-imported line] -- #15611 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the error message: + Not in scope X.Y + Module X does not export Y + No module named ‘X’ is imported: +there are 2 cases, where we hide the last "no module is imported" line: +1. If the module X has been imported (normally or via interactive context). +2. It is the current module we are trying to compile + then we can use the getModule function to get the current module name. + (See test T15611a) +-} diff --git a/GHC/Rename/Utils.hs b/GHC/Rename/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Utils.hs @@ -0,0 +1,812 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +{- + +This module contains miscellaneous functions related to renaming. + +-} + +module GHC.Rename.Utils ( + checkDupRdrNames, checkShadowedRdrNames, + checkDupNames, checkDupAndShadowedNames, dupNamesErr, + checkTupSize, checkCTupSize, + addFvRn, mapFvRn, mapMaybeFvRn, + warnUnusedMatches, warnUnusedTypePatterns, + warnUnusedTopBinds, warnUnusedLocalBinds, + DeprecationWarnings(..), warnIfDeprecated, + checkUnusedRecordWildcard, + badQualBndrErr, typeAppErr, badFieldConErr, + wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genHsExpApps, + genLHsApp, genAppType, + genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat, + genVarPat, genWildPat, + genSimpleFunBind, genFunBind, + genHsLamDoExp, genHsCaseAltDoExp, genSimpleMatch, genHsLet, + + mkRnSyntaxExpr, + + newLocalBndrRn, newLocalBndrsRn, + + bindLocalNames, bindLocalNamesFV, delLocalNames, + + addNameClashErrRn, mkNameClashErr, + + checkInferredVars, + noNestedForallsContextsErr, addNoNestedForallsContextsErr +) + +where + + +import GHC.Prelude + +import GHC.Core.Type +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Tc.Errors.Types +-- import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Types.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.Misc +import GHC.Unit.Module.ModIface +import GHC.Utils.Panic +import GHC.Types.Basic +import GHC.Data.List.SetOps ( removeDupsOn ) +import GHC.Data.Maybe ( whenIsJust ) +import GHC.Driver.DynFlags +import GHC.Data.FastString +import GHC.Data.Bag ( mapBagM, headMaybe ) +import Control.Monad +import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) +import GHC.Unit.Module +import GHC.Unit.Module.Warnings ( WarningTxt(..) ) +import GHC.Iface.Load +import qualified GHC.LanguageExtensions as LangExt + +import qualified Data.List.NonEmpty as NE +import Data.Foldable (for_) +import Data.Maybe + + +{- +********************************************************* +* * +\subsection{Binding} +* * +********************************************************* +-} + +newLocalBndrRn :: LocatedN RdrName -> RnM Name +-- Used for non-top-level binders. These should +-- never be qualified. +newLocalBndrRn (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = return name -- This happens in code generated by Template Haskell + -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + | otherwise + = do { unless (isUnqual rdr_name) + (addErrAt (locA loc) (badQualBndrErr rdr_name)) + ; uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) } + +newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name] +newLocalBndrsRn = mapM newLocalBndrRn + +bindLocalNames :: [Name] -> RnM a -> RnM a +bindLocalNames names + = updLclCtxt $ \ lcl_env -> + let th_level = thLevelIndex (tcl_th_ctxt lcl_env) + th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) + [ (n, (NotTopLevel, th_level)) | n <- names ] + rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names + in lcl_env { tcl_th_bndrs = th_bndrs' + , tcl_rdr = rdr_env' } + +bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +bindLocalNamesFV names enclosed_scope + = do { (result, fvs) <- bindLocalNames names enclosed_scope + ; return (result, delFVs names fvs) } + +delLocalNames :: [Name] -> RnM a -> RnM a +delLocalNames names + = updLclCtxt $ \ lcl_env -> + let th_bndrs' = delListFromNameEnv (tcl_th_bndrs lcl_env) names + rdr_env' = minusLocalRdrEnvList (tcl_rdr lcl_env) (map occName names) + in lcl_env { tcl_th_bndrs = th_bndrs' + , tcl_rdr = rdr_env' } + +------------------------------------- +checkDupRdrNames :: [LocatedN RdrName] -> RnM () +-- Check for duplicated names in a binding group +checkDupRdrNames rdr_names_w_loc + = mapM_ (\ ns -> dupNamesErr (getLocA <$> ns) (unLoc <$> ns)) dups + where + (_, dups) = removeDupsOn unLoc rdr_names_w_loc + +checkDupNames :: [Name] -> RnM () +-- Check for duplicated names in a binding group +checkDupNames names = check_dup_names (filterOut isSystemName names) + -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + +check_dup_names :: [Name] -> RnM () +check_dup_names names + = mapM_ (\ ns -> dupNamesErr (nameSrcSpan <$> ns) (getRdrName <$> ns)) dups + where + (_, dups) = removeDupsOn nameOccName names + +--------------------- +checkShadowedRdrNames :: [LocatedN RdrName] -> RnM () +checkShadowedRdrNames loc_rdr_names + = do { envs <- getRdrEnvs + ; checkShadowedOccs envs get_loc_occ filtered_rdrs } + where + filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names + -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + get_loc_occ (L loc rdr) = (locA loc,rdrNameOcc rdr) + +checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () +checkDupAndShadowedNames envs names + = do { check_dup_names filtered_names + ; checkShadowedOccs envs get_loc_occ filtered_names } + where + filtered_names = filterOut isSystemName names + -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + get_loc_occ name = (nameSrcSpan name, nameOccName name) + +------------------------------------- +checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) + -> (a -> (SrcSpan, OccName)) + -> [a] -> RnM () +checkShadowedOccs (global_env,local_env) get_loc_occ ns + = whenWOptM Opt_WarnNameShadowing $ + do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns)) + ; mapM_ check_shadow ns } + where + check_shadow n + | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" + -- See #3262 + | Just n <- mb_local = complain (ShadowedNameProvenanceLocal (nameSrcLoc n)) + | otherwise = do { gres' <- filterM is_shadowed_gre gres + ; when (not . null $ gres') $ complain (ShadowedNameProvenanceGlobal gres') } + where + (loc,occ) = get_loc_occ n + mb_local = lookupLocalRdrOcc local_env occ + gres = lookupGRE global_env (LookupRdrName (mkRdrUnqual occ) (RelevantGREsFOS WantNormal)) + -- Make an Unqualified RdrName and look that up, so that + -- we don't find any GREs that are in scope qualified-only + + complain provenance = addDiagnosticAt loc (TcRnShadowedName occ provenance) + + is_shadowed_gre :: GlobalRdrElt -> RnM Bool + -- Returns False for record selectors that are shadowed, when + -- punning or wild-cards are on (cf #2723) + is_shadowed_gre gre | isRecFldGRE gre + = do { dflags <- getDynFlags + ; return $ not (xopt LangExt.NamedFieldPuns dflags + || xopt LangExt.RecordWildCards dflags) } + is_shadowed_gre _other = return True + +------------------------------------- +-- | Throw an error message if a user attempts to quantify an inferred type +-- variable in a place where specificity cannot be observed. For example, +-- @forall {a}. [a] -> [a]@ would be rejected to the inferred type variable +-- @{a}@, but @forall a. [a] -> [a]@ would be accepted. +-- See @Note [Unobservably inferred type variables]@. +checkInferredVars :: HsDocContext + -> LHsSigType GhcPs + -> RnM () +checkInferredVars ctxt ty = + let bndrs = sig_ty_bndrs ty + in case filter ((==) InferredSpec . hsTyVarBndrFlag) bndrs of + [] -> return () + iv : ivs -> addErr $ + TcRnWithHsDocContext ctxt $ + TcRnIllegalInferredTyVars (iv NE.:| ivs) + where + sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs] + sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs})) + = map unLoc (hsOuterExplicitBndrs outer_bndrs) + +{- +Note [Unobservably inferred type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While GHC's parser allows the use of inferred type variables +(e.g., `forall {a}. <...>`) just about anywhere that type variable binders can +appear, there are some situations where the distinction between inferred and +specified type variables cannot be observed. For example, consider this +instance declaration: + + instance forall {a}. Eq (T a) where ... + +Making {a} inferred is pointless, as there is no way for user code to +"apply" an instance declaration in a way where the inferred/specified +distinction would make a difference. (Notably, there is no opportunity +for visible type application of an instance declaration.) Anyone who +writes such code is likely confused, so in an attempt to be helpful, +we emit an error message if a user writes code like this. The +checkInferredVars function is responsible for implementing this +restriction. + +It turns out to be somewhat cumbersome to enforce this restriction in +certain cases. Specifically: + +* Quantified constraints. In the type `f :: (forall {a}. C a) => Proxy Int`, + there is no way to observe that {a} is inferred. Nevertheless, actually + rejecting this code would be tricky, as we would need to reject + `forall {a}. <...>` as a constraint but *accept* other uses of + `forall {a}. <...>` as a type (e.g., `g :: (forall {a}. a -> a) -> b -> b`). + This is quite tedious to do in practice, so we don't bother. + +* Default method type signatures (#18432). These are tricky because inferred + type variables can appear nested, e.g., + + class C a where + m :: forall b. a -> b -> forall c. c -> c + default m :: forall b. a -> b -> forall {c}. c -> c + m _ _ = id + + Robustly checking for nested, inferred type variables ends up being a pain, + so we don't try to do this. + +For now, we simply allow inferred quantifiers to be specified here, +even though doing so is pointless. All we lose is a warning. + +Aside from the places where we already use checkInferredVars, most of +the other places where inferred vars don't make sense are in any case +already prohibited from having foralls /at all/. For example: + + instance forall a. forall {b}. Eq (Either a b) where ... + +Here the nested `forall {b}` is already prohibited. (See +Note [No nested foralls or contexts in instance types] in GHC.Hs.Type). +-} + +-- | Examines a non-outermost type for @forall@s or contexts, which are assumed +-- to be nested. For example, in the following declaration: +-- +-- @ +-- instance forall a. forall b. C (Either a b) +-- @ +-- +-- The outermost @forall a@ is fine, but the nested @forall b@ is not. We +-- invoke 'noNestedForallsContextsErr' on the type @forall b. C (Either a b)@ +-- to catch the nested @forall@ and create a suitable error message. +-- 'noNestedForallsContextsErr' returns @'Just' err_msg@ if such a @forall@ or +-- context is found, and returns @Nothing@ otherwise. +-- +-- This is currently used in the following places: +-- +-- * In GADT constructor types (in 'rnConDecl'). +-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@ +-- in "GHC.Hs.Type". +-- +-- * In instance declaration types (in 'rnClsIntDecl' and 'rnSrcDerivDecl' in +-- "GHC.Rename.Module" and 'renameSig' in "GHC.Rename.Bind"). +-- See @Note [No nested foralls or contexts in instance types]@ in +-- "GHC.Hs.Type". +noNestedForallsContextsErr :: NestedForallsContextsIn + -> LHsType GhcRn + -> Maybe (SrcSpan, TcRnMessage) +noNestedForallsContextsErr what lty = + case ignoreParens lty of + L l (HsForAllTy { hst_tele = tele }) + | HsForAllVis{} <- tele + -- The only two places where this function is called correspond to + -- types of terms, so we give a slightly more descriptive error + -- message in the event that they contain visible dependent + -- quantification (currently only allowed in kinds). + -> Just (locA l, TcRnVDQInTermType Nothing) + | HsForAllInvis{} <- tele + -> Just (locA l, nested_foralls_contexts_err) + L l (HsQualTy {}) + -> Just (locA l, nested_foralls_contexts_err) + _ -> Nothing + where + nested_foralls_contexts_err = + TcRnNestedForallsContexts what + +-- | A common way to invoke 'noNestedForallsContextsErr'. +addNoNestedForallsContextsErr :: HsDocContext + -> NestedForallsContextsIn + -> LHsType GhcRn + -> RnM () +addNoNestedForallsContextsErr ctxt what lty = + whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) -> + addErrAt l $ TcRnWithHsDocContext ctxt err_msg + +{- +************************************************************************ +* * +\subsection{Free variable manipulation} +* * +************************************************************************ +-} + +-- A useful utility +addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars) +addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside + ; return (res, fvs1 `plusFV` fvs2) } + +mapFvRn :: Traversable f => (a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars) +mapFvRn f xs = do + stuff <- mapM f xs + case unzip stuff of + (ys, fvs_s) -> return (ys, foldl' (flip plusFV) emptyFVs fvs_s) +{-# SPECIALIZE mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) #-} + +mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) +mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) +mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) } + +{- +************************************************************************ +* * +\subsection{Envt utility functions} +* * +************************************************************************ +-} + +warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () +warnUnusedTopBinds gres + = whenWOptM Opt_WarnUnusedTopBinds + $ do env <- getGblEnv + let isBoot = isHsBootFile $ tcg_src env + let noParent gre = case greParent gre of + NoParent -> True + _ -> False + -- Don't warn about unused bindings with parents in + -- .hs-boot files, as you are sometimes required to give + -- unused bindings (#3449). + -- HOWEVER, in a signature file, you are never obligated to put a + -- definition in the main text. Thus, if you define something + -- and forget to export it, we really DO want to warn. + gres' = if isBoot then filter noParent gres + else gres + warnUnusedGREs gres' + + +-- | Checks to see if we need to warn for -Wunused-record-wildcards or +-- -Wredundant-record-wildcards +checkUnusedRecordWildcard :: SrcSpan + -> FreeVars + -> Maybe [ImplicitFieldBinders] + -> RnM () +checkUnusedRecordWildcard _ _ Nothing = return () +checkUnusedRecordWildcard loc fvs (Just dotdot_fields_binders) + = setSrcSpan loc $ case concatMap implFlBndr_binders dotdot_fields_binders of + -- Add a new warning if the .. pattern binds no variables + [] -> warnRedundantRecordWildcard + dotdot_names + -> do + warnUnusedRecordWildcard dotdot_names fvs + deprecateUsedRecordWildcard dotdot_fields_binders fvs + + +-- | Produce a warning when the `..` pattern binds no new +-- variables. +-- +-- @ +-- data P = P { x :: Int } +-- +-- foo (P{x, ..}) = x +-- @ +-- +-- The `..` here doesn't bind any variables as `x` is already bound. +warnRedundantRecordWildcard :: RnM () +warnRedundantRecordWildcard = addDiagnostic TcRnRedundantRecordWildcard + + +-- | Produce a warning when no variables bound by a `..` pattern are used. +-- +-- @ +-- data P = P { x :: Int } +-- +-- foo (P{..}) = () +-- @ +-- +-- The `..` pattern binds `x` but it is not used in the RHS so we issue +-- a warning. +warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM () +warnUnusedRecordWildcard ns used_names = do + let used = filter (`elemNameSet` used_names) ns + traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used) + warnIf (null used) (TcRnUnusedRecordWildcard ns) + +-- | Emit a deprecation message whenever one of the implicit record wild +-- card field binders was used in FreeVars. +-- +-- @ +-- module A where +-- data P = P { x :: Int, y :: Int } +-- {-# DEPRECATED x, y "depr msg" #-} +-- +-- module B where +-- import A +-- foo (P{..}) = x +-- @ +-- +-- Even though both `x` and `y` have deprecations, only `x` +-- will be deprecated since only its implicit variable is used in the RHS. +deprecateUsedRecordWildcard :: [ImplicitFieldBinders] + -> FreeVars -> RnM () +deprecateUsedRecordWildcard dotdot_fields_binders fvs + = mapM_ depr_field_binders dotdot_fields_binders + where + depr_field_binders (ImplicitFieldBinders {..}) + = when (mkFVs implFlBndr_binders `intersectsFVs` fvs) $ do + env <- getGlobalRdrEnv + let gre = fromJust $ lookupGRE_Name env implFlBndr_field + -- Must be in the env since it was instantiated + -- in the implicit binders + warnIfDeprecated AllDeprecationWarnings [gre] + + +warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns + :: [Name] -> FreeVars -> RnM () +warnUnusedLocalBinds = check_unused UnusedNameLocalBind +warnUnusedMatches = check_unused UnusedNameMatch +warnUnusedTypePatterns = check_unused UnusedNameTypePattern + +check_unused :: UnusedNameProv -> [Name] -> FreeVars -> RnM () +check_unused prov bound_names used_names + = warnUnused prov (filterOut (`elemNameSet` used_names) bound_names) + +{- +************************************************************************ +* * +\subsection{Custom deprecations utility functions} +* * +************************************************************************ + +Note [Handling of deprecations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We report deprecations at each *occurrence* of the deprecated thing + (see #5867 and #4879) + +* We do not report deprecations for locally-defined names. For a + start, we may be exporting a deprecated thing. Also we may use a + deprecated thing in the defn of another deprecated things. We may + even use a deprecated thing in the defn of a non-deprecated thing, + when changing a module's interface. + +* We also report deprecations at export sites, but only for names + deprecated with export deprecations (since those are not transitive as opposed + to regular name deprecations and are only reported at the importing module) + +* addUsedGREs: we do not report deprecations for sub-binders: + - the ".." completion for records + - the ".." in an export item 'T(..)' + - the things exported by a module export 'module M' +-} + +-- | Whether to report deprecation warnings when registering a used GRE +-- +-- There is no option to only emit declaration warnings since everywhere +-- we emit the declaration warnings we also emit export warnings +-- (See Note [Handling of deprecations] for details) +data DeprecationWarnings + = NoDeprecationWarnings + | ExportDeprecationWarnings + | AllDeprecationWarnings + +warnIfDeprecated :: DeprecationWarnings -> [GlobalRdrElt] -> RnM () +warnIfDeprecated NoDeprecationWarnings _ = return () +warnIfDeprecated opt gres = do + this_mod <- getModule + let external_gres + = filterOut (nameIsLocalOrFrom this_mod . greName) gres + mapM_ (\gre -> warnIfExportDeprecated gre >> maybeWarnDeclDepr gre) external_gres + where + maybeWarnDeclDepr = case opt of + ExportDeprecationWarnings -> const $ return () + AllDeprecationWarnings -> warnIfDeclDeprecated + +warnIfDeclDeprecated :: GlobalRdrElt -> RnM () +warnIfDeclDeprecated gre@(GRE { gre_imp = iss }) + | Just imp_spec <- headMaybe iss + = do { dflags <- getDynFlags + ; when (wopt_any_custom dflags) $ + -- See Note [Handling of deprecations] + do { iface <- loadInterfaceForName doc name + ; case lookupImpDeclDeprec iface gre of + Just deprText -> addDiagnostic $ + TcRnPragmaWarning + PragmaWarningName + { pwarn_occname = occ + , pwarn_impmod = importSpecModule imp_spec + , pwarn_declmod = definedMod } + deprText + Nothing -> return () } } + | otherwise + = return () + where + occ = greOccName gre + name = greName gre + definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name) + doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" + +lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) +lookupImpDeclDeprec iface gre + -- Bleat if the thing, or its parent, is warn'd + = mi_decl_warn_fn iface (greOccName gre) `mplus` + case greParent gre of + ParentIs p -> mi_decl_warn_fn iface (nameOccName p) + NoParent -> Nothing + +warnIfExportDeprecated :: GlobalRdrElt -> RnM () +warnIfExportDeprecated gre@(GRE { gre_imp = iss }) + = do { mod_warn_mbs <- mapBagM process_import_spec iss + ; for_ (sequence mod_warn_mbs) $ mapM + $ \(importing_mod, warn_txt) -> addDiagnostic $ + TcRnPragmaWarning + PragmaWarningExport + { pwarn_occname = occ + , pwarn_impmod = importing_mod } + warn_txt } + where + occ = greOccName gre + name = greName gre + doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" + process_import_spec :: ImportSpec -> RnM (Maybe (ModuleName, WarningTxt GhcRn)) + process_import_spec is = do + let mod = is_mod $ is_decl is + iface <- loadInterfaceForModule doc mod + let mb_warn_txt = mi_export_warn_fn iface name + return $ (moduleName mod, ) <$> mb_warn_txt + +------------------------- +-- Helpers +warnUnusedGREs :: [GlobalRdrElt] -> RnM () +warnUnusedGREs gres = mapM_ warnUnusedGRE gres + +-- NB the Names must not be the names of record fields! +warnUnused :: UnusedNameProv -> [Name] -> RnM () +warnUnused prov names = + mapM_ (\ nm -> warnUnused1 prov nm (nameOccName nm)) names + +warnUnused1 :: UnusedNameProv -> Name -> OccName -> RnM () +warnUnused1 prov child child_occ + = when (reportable child child_occ) $ + warn_unused_name prov (nameSrcSpan child) child_occ + +warn_unused_name :: UnusedNameProv -> SrcSpan -> OccName -> RnM () +warn_unused_name prov span child_occ = + addDiagnosticAt span (TcRnUnusedName child_occ prov) + +warnUnusedGRE :: GlobalRdrElt -> RnM () +warnUnusedGRE gre@(GRE { gre_lcl = lcl, gre_imp = is }) + | lcl = warnUnused1 UnusedNameTopDecl nm occ + | otherwise = when (reportable nm occ) (mapM_ warn is) + where + occ = greOccName gre + nm = greName gre + warn spec = + warn_unused_name (UnusedNameImported (importSpecModule spec)) span occ + where + span = importSpecLoc spec + +-- | Should we report the fact that this 'Name' is unused? The +-- 'OccName' may differ from 'nameOccName' due to +-- DuplicateRecordFields. +reportable :: Name -> OccName -> Bool +reportable child child_occ + | isWiredInName child + = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise + = not (startsWithUnderscore child_occ) + +{- +Note [Skipping ambiguity errors at use sites of local declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, we do not report ambiguous occurrences at use sites where all the +clashing names are defined locally, because the error will have been reported at +the definition site, and we want to avoid an error cascade. + +However, when DuplicateRecordFields is enabled, it is possible to define the +same field name multiple times, so we *do* need to report an error at the use +site when there is ambiguity between multiple fields. Moreover, when +NoFieldSelectors is enabled, it is possible to define a field with the same name +as a non-field, so again we need to report ambiguity at the use site. + +We can skip reporting an ambiguity error whenever defining the GREs must have +yielded a duplicate declarations error. More precisely, we can skip if: + + * there are at least two non-fields amongst the GREs; or + + * there are at least two fields amongst the GREs, and DuplicateRecordFields is + *disabled*; or + + * there is at least one non-field, at least one field, and NoFieldSelectors is + *disabled*. + +These conditions ensure that a duplicate local declaration will have been +reported. See also Note [Reporting duplicate local declarations] in +GHC.Rename.Names). + +-} + +addNameClashErrRn :: RdrName -> NE.NonEmpty GlobalRdrElt -> RnM () +addNameClashErrRn rdr_name gres + | all isLocalGRE gres && can_skip + -- If there are two or more *local* defns, we'll usually have reported that + -- already, and we don't want an error cascade. + = return () + | otherwise + = do { gre_env <- getGlobalRdrEnv + ; addErr $ mkNameClashErr gre_env rdr_name gres } + where + -- If all the GREs are defined locally, can we skip reporting an ambiguity + -- error at use sites, because it will have been reported already? See + -- Note [Skipping ambiguity errors at use sites of local declarations] + can_skip = num_non_flds >= 2 + || (num_flds >= 2 && not (isDuplicateRecFldGRE (head flds))) + || (num_non_flds >= 1 && num_flds >= 1 + && not (isNoFieldSelectorGRE (head flds))) + (flds, non_flds) = NE.partition isRecFldGRE gres + num_flds = length flds + num_non_flds = length non_flds + +mkNameClashErr :: GlobalRdrEnv -> RdrName -> NE.NonEmpty GlobalRdrElt -> TcRnMessage +mkNameClashErr gre_env rdr_name gres = TcRnAmbiguousName gre_env rdr_name gres + +dupNamesErr :: NE.NonEmpty SrcSpan -> NE.NonEmpty RdrName -> RnM () +dupNamesErr locs names + = addErrAt big_loc (TcRnBindingNameConflict (NE.head names) locs) + where + big_loc = foldr1 combineSrcSpans locs + +badQualBndrErr :: RdrName -> TcRnMessage +badQualBndrErr rdr_name = TcRnQualifiedBinder rdr_name + +typeAppErr :: TypeOrKind -> LHsType GhcPs -> TcRnMessage +typeAppErr what (L _ k) = TcRnTypeApplicationsDisabled k what + +badFieldConErr :: Name -> FieldLabelString -> TcRnMessage +badFieldConErr con field = TcRnInvalidRecordField con field + +-- | Ensure that a boxed or unboxed tuple has arity no larger than +-- 'mAX_TUPLE_SIZE'. +checkTupSize :: Int -> TcM () +checkTupSize tup_size + | tup_size <= mAX_TUPLE_SIZE + = return () + | otherwise + = addErr (TcRnTupleTooLarge tup_size) + +-- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'. +checkCTupSize :: Int -> TcM () +checkCTupSize tup_size + | tup_size <= mAX_CTUPLE_SIZE + = return () + | otherwise + = addErr (TcRnCTupleTooLarge tup_size) + +{- ********************************************************************* +* * + Generating code for ExpandedThingRn + See Note [Handling overloaded and rebindable constructs] +* * +********************************************************************* -} + +wrapGenSpan :: (HasAnnotation an) => a -> GenLocated an a +-- Wrap something in a "generatedSrcSpan" +-- See Note [Rebindable syntax and XXExprGhcRn] +wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x + +-- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the +-- renamer). +mkRnSyntaxExpr :: Name -> SyntaxExprRn +mkRnSyntaxExpr = SyntaxExprRn . genHsVar + +genHsVar :: Name -> HsExpr GhcRn +genHsVar n = mkHsVar (wrapGenSpan n) + +genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn +genHsApps fun args = foldl genHsApp (genHsVar fun) args + +-- | Keeps the span given to the 'Name' for the application head only +genHsApps' :: LocatedN Name -> [LHsExpr GhcRn] -> HsExpr GhcRn +genHsApps' (L _ fun) [] = genHsVar fun +genHsApps' (L loc fun) (arg:args) = foldl genHsApp (unLoc $ mkHsApp (L (l2l loc) $ genHsVar fun) arg) args + +genHsExpApps :: HsExpr GhcRn -> [LHsExpr GhcRn] -> HsExpr GhcRn +genHsExpApps fun arg = foldl genHsApp fun arg + +genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn +genHsApp fun arg = HsApp noExtField (wrapGenSpan fun) arg + +genLHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn +genLHsApp fun arg = wrapGenSpan (genHsApp fun arg) + +genLHsVar :: Name -> LHsExpr GhcRn +genLHsVar nm = wrapGenSpan $ genHsVar nm + +genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn +genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) (mkEmptyWildCardBndrs (wrapGenSpan ty)) + +genLHsLit :: (NoAnn an) => HsLit GhcRn -> LocatedAn an (HsExpr GhcRn) +genLHsLit = wrapGenSpan . HsLit noExtField + +genHsIntegralLit :: (NoAnn an) => IntegralLit -> LocatedAn an (HsExpr GhcRn) +genHsIntegralLit = genLHsLit . HsInt noExtField + +genHsTyLit :: FastString -> HsType GhcRn +genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText + +genSimpleConPat :: Name -> [LPat GhcRn] -> LPat GhcRn +-- The pattern (C p1 .. pn) +genSimpleConPat con pats + = wrapGenSpan $ ConPat { pat_con_ext = noExtField + , pat_con = wrapGenSpan $ noUserRdr con + , pat_args = PrefixCon pats } + +genVarPat :: Name -> LPat GhcRn +genVarPat n = wrapGenSpan $ VarPat noExtField (wrapGenSpan n) + +genWildPat :: LPat GhcRn +genWildPat = wrapGenSpan $ WildPat noExtField + +genSimpleFunBind :: Name -> [LPat GhcRn] + -> LHsExpr GhcRn -> LHsBind GhcRn +genSimpleFunBind fun pats expr + = noLocA $ genFunBind (noLocA fun) + [mkMatch (mkPrefixFunRhs (noLocA fun) noAnn) (noLocA pats) expr + emptyLocalBinds] + +genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)] + -> HsBind GhcRn +genFunBind fn ms + = FunBind { fun_id = fn + , fun_matches = mkMatchGroup (Generated OtherExpansion SkipPmc) (wrapGenSpan ms) + , fun_ext = emptyNameSet + } + +genHsLet :: HsLocalBindsLR GhcRn GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn +genHsLet bindings body = HsLet noExtField bindings body + +genHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) + => HsDoFlavour + -> [LPat (GhcPass p)] + -> LHsExpr (GhcPass p) + -> LHsExpr (GhcPass p) +genHsLamDoExp doFlav pats body = mkHsPar (wrapGenSpan $ HsLam noAnn LamSingle matches) + where + matches = mkMatchGroup (doExpansionOrigin doFlav) + (wrapGenSpan [genSimpleMatch (StmtCtxt (HsDoStmt doFlav)) pats' body]) + pats' = map (parenthesizePat appPrec) pats + + +genHsCaseAltDoExp :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ EpAnnCO, + Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpanAnnA) + => HsDoFlavour -> LPat (GhcPass p) -> (LocatedA (body (GhcPass p))) + -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) +genHsCaseAltDoExp doFlav pat expr + = genSimpleMatch (StmtCtxt (HsDoStmt doFlav)) [pat] expr + + +genSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpanAnnA, + Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ EpAnnCO) + => HsMatchContext (LIdP (NoGhcTc (GhcPass p))) + -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) + -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) +genSimpleMatch ctxt pats rhs + = wrapGenSpan $ + Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = noLocA pats + , m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn } diff --git a/GHC/Runtime/Context.hs b/GHC/Runtime/Context.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Context.hs @@ -0,0 +1,509 @@ +module GHC.Runtime.Context + ( InteractiveContext (..) + , InteractiveImport (..) + , emptyInteractiveContext + , extendInteractiveContext + , extendInteractiveContextWithIds + , setInteractivePrintName + , substInteractiveContext + , replaceImportEnv + , icReaderEnv + , icExtendGblRdrEnv + , icInteractiveModule + , icInScopeTTs + , icNamePprCtx + ) +where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Driver.DynFlags +import {-# SOURCE #-} GHC.Driver.Plugins + +import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume ) + +import GHC.Unit +import GHC.Unit.Env + +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv +import GHC.Core.Type + +import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv ) +import GHC.Types.Fixity.Env +import GHC.Types.Id.Info ( IdDetails(..) ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Reader +import GHC.Types.Name.Ppr +import GHC.Types.TyThing +import GHC.Types.Var + +import GHC.Builtin.Names ( ioTyConName, printName, mkInteractiveModule ) + +import GHC.Utils.Outputable + +{- +Note [The interactive package] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type, class, and value declarations at the command prompt are treated +as if they were defined in modules + interactive:Ghci1 + interactive:Ghci2 + ...etc... +with each bunch of declarations using a new module, all sharing a +common package 'interactive' (see Module.interactiveUnitId, and +GHC.Builtin.Names.mkInteractiveModule). + +This scheme deals well with shadowing. For example: + + ghci> data T = A + ghci> data T = B + ghci> :i A + data Ghci1.T = A -- Defined at :2:10 + +Here we must display info about constructor A, but its type T has been +shadowed by the second declaration. But it has a respectable +qualified name (Ghci1.T), and its source location says where it was +defined, and it can also be used with the qualified name. + +So the main invariant continues to hold, that in any session an +original name M.T only refers to one unique thing. (In a previous +iteration both the T's above were called :Interactive.T, albeit with +different uniques, which gave rise to all sorts of trouble.) + +The details are a bit tricky though: + + * The field ic_mod_index counts which Ghci module we've got up to. + It is incremented when extending ic_tythings + + * ic_tythings contains only things from the 'interactive' package. + + * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go + in the Home Package Table (HPT). When you say :load, that's when we + extend the HPT. + + * The 'homeUnitId' field of DynFlags is *not* set to 'interactive'. + It stays as 'main' (or whatever -this-unit-id says), and is the + package to which :load'ed modules are added to. + + * So how do we arrange that declarations at the command prompt get to + be in the 'interactive' package? Simply by setting the tcg_mod + field of the TcGblEnv to "interactive:Ghci1". This is done by the + call to initTc in initTcInteractive, which in turn get the module + from it 'icInteractiveModule' field of the interactive context. + + The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says). + + * The main trickiness is that the type environment (tcg_type_env) and + fixity envt (tcg_fix_env), now contain entities from all the + interactive-package modules (Ghci1, Ghci2, ...) together, rather + than just a single module as is usually the case. So you can't use + "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs + the HPT/PTE. This is a change, but not a problem provided you + know. + +* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields + of the TcGblEnv, which collect "things defined in this module", all + refer to stuff define in a single GHCi command, *not* all the commands + so far. + + In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from + all GhciN modules, which makes sense -- they are all "home package" + modules. + + +Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'InteractiveContext' is used to store 'DynFlags', 'Plugins' and similar +information about the so-called interactive "home unit". We are using +quotes here, since, originally, GHC wasn't aware of more than one 'HomeUnitEnv's. +So the 'InteractiveContext' was a hack/solution to have 'DynFlags' and 'Plugins' +independent of the 'DynFlags' and 'Plugins' stored in 'HscEnv'. +Nowadays, GHC has support for multiple home units via the 'HomeUnitGraph', thus, +this part of the 'InteractiveContext' is strictly speaking redundant, as we +can simply manage one 'HomeUnitEnv' for the 'DynFlags' and 'Plugins' that are +currently stored in the 'InteractiveContext'. + +As a matter of fact, that's exactly what we do nowadays. +That means, we can also lift other restrictions in the future, for example +allowing @:seti@ commands to modify the package-flags, since we now have a +separate 'UnitState' for the interactive session. +However, we did not rip out 'ic_dflags' and 'ic_plugins', yet, as it makes +it easier to access them for functions that want to use the interactive 'DynFlags', +such as 'runInteractiveHsc' and 'mkInteractiveHscEnv', without having to look that +information up in the 'HomeUnitGraph'. +It is reasonable to change this in the future, and remove 'ic_dflags' and 'ic_plugins'. + +We keep 'ic_dflags' and 'ic_plugins' around, but we also store a 'HomeUnitEnv' +for the 'DynFlags' and 'Plugins' of the interactive session. + +It is important to keep the 'DynFlags' in these two places consistent. + +In other words, whenever you update the 'DynFlags' of the 'interactiveGhciUnitId' +in the 'HscEnv', then you also need to update the 'DynFlags' of the +'InteractiveContext'. +The easiest way to update them is via 'setInteractiveDynFlags'. +However, careful, footgun! It is very easy to call 'setInteractiveDynFlags' +and forget to call 'normaliseInteractiveDynFlags' on the 'DynFlags' in the +'HscEnv'! This is important, because you may, accidentally, have enabled +Language Extensions that are not supported in the interactive ghc session, +which we do not want. + +To summarise, the 'ic_dflags' and 'ic_plugins' are currently used to +conveniently cache them for easy access. +The 'ic_dflags' must be identical to the 'DynFlags' stored in the 'HscEnv' +for the 'HomeUnitEnv' identified by 'interactiveGhciUnitId'. + +See Note [Multiple Home Units aware GHCi] for the design and rationale for +the current 'interactiveGhciUnitId'. + +Note [Interactively-bound Ids in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Ids bound by previous Stmts in GHCi are currently + a) GlobalIds, with + b) An External Name, like Ghci4.foo + See Note [The interactive package] above + c) A tidied type + + (a) They must be GlobalIds (not LocalIds) otherwise when we come to + compile an expression using these ids later, the byte code + generator will consider the occurrences to be free rather than + global. + + (b) Having an External Name is important because of Note + [GlobalRdrEnv shadowing] in GHC.Types.Names.RdrName + + (c) Their types are tidied. This is important, because :info may ask + to look at them, and :info expects the things it looks up to have + tidy types + +Where do interactively-bound Ids come from? + + - GHCi REPL Stmts e.g. + ghci> let foo x = x+1 + These start with an Internal Name because a Stmt is a local + construct, so the renamer naturally builds an Internal name for + each of its binders. Then in tcRnStmt they are externalised via + GHC.Tc.Module.externaliseAndTidyId, so they get Names like Ghic4.foo. + + - Ids bound by the debugger etc have Names constructed by + GHC.Iface.Env.newInteractiveBinder; at the call sites it is followed by + mkVanillaGlobal or mkVanillaGlobalWithInfo. So again, they are + all Global, External. + + - TyCons, Classes, and Ids bound by other top-level declarations in + GHCi (eg foreign import, record selectors) also get External + Names, with Ghci9 (or 8, or 7, etc) as the module name. + + +Note [ic_tythings] +~~~~~~~~~~~~~~~~~~ +The ic_tythings field contains + * The TyThings declared by the user at the command prompt + (eg Ids, TyCons, Classes) + + * The user-visible Ids that arise from such things, which + *don't* come from 'implicitTyThings', notably: + - record selectors + - class ops + The implicitTyThings are readily obtained from the TyThings + but record selectors etc are not + +It does *not* contain + * DFunIds (they can be gotten from ic_instances) + * CoAxioms (ditto) + +See also Note [Interactively-bound Ids in GHCi] + +Note [Override identical instances in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you declare a new instance in GHCi that is identical to a previous one, +we simply override the previous one; we don't regard it as overlapping. +e.g. Prelude> data T = A | B + Prelude> instance Eq T where ... + Prelude> instance Eq T where ... -- This one overrides + +It's exactly the same for type-family instances. See #7102 + +Note [icReaderEnv recalculation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GlobalRdrEnv describing what’s in scope at the prompts consists +of all the imported things, followed by all the things defined on the prompt, +with shadowing. Defining new things on the prompt is easy: we shadow as needed, +and then extend the environment. + +But changing the set of imports, which can happen later as well, is tricky +we need to re-apply the shadowing from all the things defined at the prompt! + +For example: + + ghci> let empty = True + ghci> import Data.IntMap.Strict -- Exports 'empty' + ghci> empty -- Still gets the 'empty' defined at the prompt + True + +It would be correct to re-construct the env from scratch based on +`ic_tythings`, but that'd be quite expensive if there are many entries in +`ic_tythings` that shadow each other. + +Therefore we keep around a `GlobalRdrEnv` in `igre_prompt_env` that contains +_just_ the things defined at the prompt, and use that in `replaceImportEnv` to +rebuild the full env. Conveniently, `shadowNames` takes such an `OccEnv` +to denote the set of names to shadow. + +INVARIANT: Every `OccName` in `igre_prompt_env` is present unqualified as well +(else it would not be right to pass `igre_prompt_env` to `shadowNames`.) + +The definition of the IcGlobalRdrEnv type should conceptually be in this module, +and made abstract, but it’s used in `Resume`, so it lives in GHC.Runtime.Eval.Type. + +-} + +-- | Interactive context, recording information about the state of the +-- context in which statements are executed in a GHCi session. +data InteractiveContext + = InteractiveContext { + ic_dflags :: DynFlags, + -- ^ The 'DynFlags' used to evaluate interactive expressions + -- and statements. + + ic_mod_index :: Int, + -- ^ Each GHCi stmt or declaration brings some new things into + -- scope. We give them names like interactive:Ghci9.T, + -- where the ic_index is the '9'. The ic_mod_index is + -- incremented whenever we add something to ic_tythings + -- See Note [The interactive package] + + ic_imports :: [InteractiveImport], + -- ^ The GHCi top-level scope (icReaderEnv) is extended with + -- these imports + -- + -- This field is only stored here so that the client + -- can retrieve it with GHC.getContext. GHC itself doesn't + -- use it, but does reset it to empty sometimes (such + -- as before a GHC.load). The context is set with GHC.setContext. + + ic_tythings :: [TyThing], + -- ^ TyThings defined by the user, in reverse order of + -- definition (ie most recent at the front). + -- Also used in GHC.Tc.Module.runTcInteractive to fill the type + -- checker environment. + -- See Note [ic_tythings] + + ic_gre_cache :: IcGlobalRdrEnv, + -- ^ Essentially the cached 'GlobalRdrEnv'. + -- + -- The GlobalRdrEnv contains everything in scope at the command + -- line, both imported and everything in ic_tythings, with the + -- correct shadowing. + -- + -- The IcGlobalRdrEnv contains extra data to allow efficient + -- recalculation when the set of imports change. + -- See Note [icReaderEnv recalculation] + + ic_instances :: (InstEnv, [FamInst]), + -- ^ All instances and family instances created during + -- this session. These are grabbed en masse after each + -- update to be sure that proper overlapping is retained. + -- That is, rather than re-check the overlapping each + -- time we update the context, we just take the results + -- from the instance code that already does that. + + ic_fix_env :: FixityEnv, + -- ^ Fixities declared in let statements + + ic_default :: DefaultEnv, + -- ^ The current default classes and types, set by 'default' declarations + + ic_resume :: [Resume], + -- ^ The stack of breakpoint contexts + + ic_monad :: Name, + -- ^ The monad that GHCi is executing in + + ic_int_print :: Name, + -- ^ The function that is used for printing results + -- of expressions in ghci and -e mode. + + ic_cwd :: Maybe FilePath, + -- ^ virtual CWD of the program + + ic_plugins :: !Plugins + -- ^ Cache of loaded plugins. We store them here to avoid having to + -- load them every time we switch to the interactive context. + } + +data InteractiveImport + = IIDecl (ImportDecl GhcPs) + -- ^ Bring the exports of a particular module + -- (filtered by an import decl) into scope + + | IIModule Module + -- ^ Bring into scope the entire top-level envt of + -- of this module, including the things imported + -- into it. + +emptyIcGlobalRdrEnv :: IcGlobalRdrEnv +emptyIcGlobalRdrEnv = IcGlobalRdrEnv + { igre_env = emptyGlobalRdrEnv + , igre_prompt_env = emptyGlobalRdrEnv + } + +-- | Constructs an empty InteractiveContext. +emptyInteractiveContext :: DynFlags -> InteractiveContext +emptyInteractiveContext dflags + = InteractiveContext { + ic_dflags = dflags, + ic_imports = [], + ic_gre_cache = emptyIcGlobalRdrEnv, + ic_mod_index = 1, + ic_tythings = [], + ic_instances = (emptyInstEnv,[]), + ic_fix_env = emptyNameEnv, + ic_monad = ioTyConName, -- IO monad by default + ic_int_print = printName, -- System.IO.print by default + ic_default = emptyDefaultEnv, + ic_resume = [], + ic_cwd = Nothing, + ic_plugins = emptyPlugins + } + +icReaderEnv :: InteractiveContext -> GlobalRdrEnv +icReaderEnv = igre_env . ic_gre_cache + +icInteractiveModule :: InteractiveContext -> Module +icInteractiveModule (InteractiveContext { ic_mod_index = index }) + = mkInteractiveModule (show index) + +-- | This function returns the list of visible TyThings (useful for +-- e.g. showBindings). +-- +-- It picks only those TyThings that are not shadowed by later definitions on the interpreter, +-- to not clutter :showBindings with shadowed ids, which would show up as Ghci9.foo. +-- +-- Some TyThings define many names; we include them if _any_ name is still +-- available unqualified. +icInScopeTTs :: InteractiveContext -> [TyThing] +icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt) + where + in_scope_unqualified thing = or + [ unQualOK gre + | gre <- tyThingLocalGREs thing + , let name = greName gre + , Just gre <- [lookupGRE_Name (icReaderEnv ictxt) name] + ] + +-- | Get the NamePprCtx function based on the flags and this InteractiveContext +icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx +icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt) + where ptc = initPromotionTickContext (ic_dflags ictxt) + +-- | extendInteractiveContext is called with new TyThings recently defined to update the +-- InteractiveContext to include them. By putting new things first, unqualified +-- use will pick the most recently defined thing with a given name, while +-- still keeping the old names in scope in their qualified form (Ghci1.foo). +extendInteractiveContext :: InteractiveContext + -> [TyThing] + -> InstEnv -> [FamInst] + -> DefaultEnv + -> FixityEnv + -> InteractiveContext +extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env + = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + -- Always bump this; even instances should create + -- a new mod_index (#9426) + , ic_tythings = new_tythings ++ ic_tythings ictxt + , ic_gre_cache = ic_gre_cache ictxt `icExtendIcGblRdrEnv` new_tythings + , ic_instances = ( new_cls_insts `unionInstEnv` old_cls_insts + , new_fam_insts ++ fam_insts ) + -- we don't shadow old family instances (#7102), + -- so don't need to remove them here + , ic_default = defaults + , ic_fix_env = fix_env -- See Note [Fixity declarations in GHCi] + } + where + -- Discard old instances that have been fully overridden + -- See Note [Override identical instances in GHCi] + (cls_insts, fam_insts) = ic_instances ictxt + old_cls_insts = filterInstEnv (\i -> not $ anyInstEnv (identicalClsInstHead i) new_cls_insts) cls_insts + +extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext +-- Just a specialised version +extendInteractiveContextWithIds ictxt new_ids + | null new_ids = ictxt + | otherwise + = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + , ic_tythings = new_tythings ++ ic_tythings ictxt + , ic_gre_cache = ic_gre_cache ictxt `icExtendIcGblRdrEnv` new_tythings + } + where + new_tythings = map AnId new_ids + +setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext +setInteractivePrintName ic n = ic{ic_int_print = n} + +icExtendIcGblRdrEnv :: IcGlobalRdrEnv -> [TyThing] -> IcGlobalRdrEnv +icExtendIcGblRdrEnv igre tythings = IcGlobalRdrEnv + { igre_env = icExtendGblRdrEnv False (igre_env igre) tythings + , igre_prompt_env = icExtendGblRdrEnv True (igre_prompt_env igre) tythings + -- Pass 'True' <=> drop names that are only available qualified. + -- This is done to maintain the invariant of Note [icReaderEnv recalculation] + -- that igre_prompt_env should only contain Names that are available unqualified. + } + +-- This is used by setContext in GHC.Runtime.Eval when the set of imports +-- changes, and recalculates the GlobalRdrEnv. See Note [icReaderEnv recalculation] +replaceImportEnv :: IcGlobalRdrEnv -> GlobalRdrEnv -> IcGlobalRdrEnv +replaceImportEnv igre import_env = igre { igre_env = new_env } + where + import_env_shadowed = shadowNames False import_env (igre_prompt_env igre) + new_env = import_env_shadowed `plusGlobalRdrEnv` igre_prompt_env igre + +-- | Add 'TyThings' to the 'GlobalRdrEnv', earlier ones in the list shadowing +-- later ones, and shadowing existing entries in the 'GlobalRdrEnv'. +icExtendGblRdrEnv :: Bool -- ^ discard names that are only available qualified? + -> GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv +icExtendGblRdrEnv drop_only_qualified env tythings + = foldr add env tythings -- Foldr makes things in the front of + -- the list shadow things at the back + where + -- One at a time, to ensure each shadows the previous ones + add thing env + | is_sub_bndr thing + = env + | otherwise + = foldl' extendGlobalRdrEnv env1 new_gres + where + new_gres = tyThingLocalGREs thing + env1 = shadowNames drop_only_qualified env $ mkGlobalRdrEnv new_gres + + -- Ugh! The new_tythings may include record selectors, since they + -- are not implicit-ids, and must appear in the TypeEnv. But they + -- will also be brought into scope by the corresponding (ATyCon + -- tc). And we want the latter, because that has the correct + -- parent (#10520) + is_sub_bndr (AnId f) = case idDetails f of + RecSelId {} -> True + ClassOpId {} -> True + _ -> False + is_sub_bndr _ = False + +substInteractiveContext :: InteractiveContext -> Subst -> InteractiveContext +substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst + | isEmptyTCvSubst subst = ictxt + | otherwise = ictxt { ic_tythings = map subst_ty tts } + where + subst_ty (AnId id) + = AnId $ updateIdTypeAndMult (substTyAddInScope subst) id + -- Variables in the interactive context *can* mention free type variables + -- because of the runtime debugger. Otherwise you'd expect all + -- variables bound in the interactive context to be closed. + subst_ty tt + = tt + +instance Outputable InteractiveImport where + ppr (IIModule m) = char '*' <> ppr m + ppr (IIDecl d) = ppr d diff --git a/GHC/Runtime/Debugger.hs b/GHC/Runtime/Debugger.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Debugger.hs @@ -0,0 +1,275 @@ +----------------------------------------------------------------------------- +-- +-- 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.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf + +import GHC.Driver.DynFlags +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.Core.TyCo.Tidy( tidyOpenType ) + +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 qualified Data.List.NonEmpty as NE +import Data.Maybe +import Data.IORef + +------------------------------------- +-- | The :print & friends commands +------------------------------------- +pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m () +pprintClosureCommand bindThings force str = do + tythings <- (catMaybes . concatMap NE.toList) `liftM` + mapM (\w -> GHC.parseName w >>= + mapM GHC.lookupName) + (words str) + + -- Sort out good and bad tythings for :print and friends + let (pprintables, unpprintables) = partition can_pprint tythings + + -- Obtain the terms and the recovered type information + let ids = [id | AnId id <- pprintables] + (subst, terms) <- mapAccumLM go emptySubst ids + + -- Apply the substitutions obtained after recovering the types + modifySession $ \hsc_env -> + hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst} + + -- Finally, print the Results + docterms <- mapM showTerm terms + let sdocTerms = zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) + ids + docterms + printSDocs $ (no_pprint <$> unpprintables) ++ sdocTerms + where + -- Check whether a TyThing can be processed by :print and friends. + -- Take only Ids, exclude pseudoops, they don't have any HValues. + can_pprint :: TyThing -> Bool -- #19394 + can_pprint (AnId x) + | x `notElem` ghcPrimIds = True + | otherwise = False + can_pprint _ = False + + -- Create a short message for a TyThing, that cannot processed by :print + no_pprint :: TyThing -> SDoc + no_pprint tything = ppr tything <+> + text "is not eligible for the :print, :sprint or :force commands." + + -- Helper to print out the results of :print and friends + printSDocs :: GhcMonad m => [SDoc] -> m () + printSDocs sdocs = do + logger <- getLogger + name_ppr_ctx <- GHC.getNamePprCtx + liftIO $ printOutputForUser logger name_ppr_ctx $ vcat sdocs + + -- Do the obtainTerm--bindSuspensions-computeSubstitution dance + go :: GhcMonad m => Subst -> Id -> m (Subst, Term) + go subst id = do + let id' = updateIdTypeAndMult (substTy subst) id + id_ty' = idType id' + term_ <- GHC.obtainTermFromId maxBound force id' + term <- tidyTermTyVars term_ + term' <- if bindThings + then bindSuspensions term + else return term + -- Before leaving, we compare the type obtained to see if it's more specific + -- Then, we extract a substitution, + -- mapping the old tyvars to the reconstructed types. + let reconstructed_type = termType term + hsc_env <- getSession + case (improveRTTIType hsc_env id_ty' reconstructed_type) of + Nothing -> return (subst, term') + Just subst' -> do { logger <- getLogger + ; liftIO $ + putDumpFileMaybe logger Opt_D_dump_rtti "RTTI" + FormatText + (fsep $ [text "RTTI Improvement for", ppr id, + text "old substitution:" , ppr subst, + text "new substitution:" , ppr subst']) + ; return (subst `unionSubst` subst', term')} + + tidyTermTyVars :: GhcMonad m => Term -> m Term + tidyTermTyVars t = + withSession $ \hsc_env -> do + let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env + my_tvs = termTyCoVars t + tvs = env_tvs `minusVarSet` my_tvs + tyvarOccName = nameOccName . tyVarName + tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs)) + -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv + -- forgets the ordering immediately by creating an env + , getUniqSet $ env_tvs `intersectVarSet` my_tvs) + return $ mapTermType (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 = (Inf.filter (`notElem` alreadyUsedNames) . fmap ((prefix++) . show)) (Inf.enumFrom (1::Int)) + availNames_var <- liftIO $ newIORef availNames + (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t + let (names, tys, fhvs) = unzip3 stuff + let ids = [ mkVanillaGlobal name ty + | (name,ty) <- zip names tys] + new_ic = extendInteractiveContextWithIds ictxt ids + interp = hscInterp hsc_env + liftIO $ extendLoadedEnv interp (zip names fhvs) + setSession hsc_env {hsc_IC = new_ic } + return t' + where + +-- Processing suspensions. Give names and collect info + nameSuspensionsAndGetInfos :: HscEnv -> IORef (Infinite 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 ipe = do + name <- atomicModifyIORef' freeNames (\(Inf x xs)->(xs, x)) + n <- newGrimName hsc_env name + return (Suspension ct ty hval (Just n) ipe, [(n,ty,hval)]) + + +-- A custom Term printer to enable the use of Show instances +showTerm :: GhcMonad m => Term -> m SDoc +showTerm term = do + dflags <- GHC.getSessionDynFlags + if gopt Opt_PrintEvldWithShow dflags + then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term + else cPprTerm cPprTermBase term + where + cPprShowable prec t@Term{ty=ty, val=fhv} = + if not (isFullyEvaluatedTerm t) + then return Nothing + else do + let set_session = do + hsc_env <- getSession + (new_env, bname) <- bindToFreshName hsc_env ty "showme" + setSession new_env + + -- this disables logging of errors + let noop_log _ _ _ _ = return () + pushLogHookM (const noop_log) + + return (hsc_env, bname) + + reset_session (old_env,_) = setSession old_env + + MC.bracket set_session reset_session $ \(_,bname) -> do + hsc_env <- getSession + dflags <- GHC.getSessionDynFlags + let expr = "Prelude.return (Prelude.show " ++ + showPpr dflags bname ++ + ") :: Prelude.IO Prelude.String" + interp = hscInterp hsc_env + txt_ <- withExtendedLoadedEnv interp + [(bname, fhv)] + (GHC.compileExprRemote expr) + let myprec = 10 -- application precedence. TODO Infix constructors + txt <- liftIO $ evalString interp txt_ + if not (null txt) then + return $ Just $ cparen (prec >= myprec && needsParens txt) + (text txt) + else return Nothing + + cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = + cPprShowable prec t{ty=new_ty} + cPprShowable _ _ = return Nothing + + needsParens ('"':_) = False -- some simple heuristics to see whether parens + -- are redundant in an arbitrary Show output + needsParens ('(':_) = False + needsParens txt = ' ' `elem` txt + + + bindToFreshName hsc_env ty userName = do + name <- newGrimName hsc_env userName + let id = mkVanillaGlobal name ty + new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id] + return (hsc_env {hsc_IC = new_ic }, name) + +-- Create new uniques and give them sequentially numbered names +newGrimName :: MonadIO m => HscEnv -> String -> m Name +newGrimName hsc_env userName + = liftIO (newInteractiveBinder hsc_env occ noSrcSpan) + where + occ = mkOccName varName userName + +pprTypeAndContents :: GhcMonad m => Id -> m SDoc +pprTypeAndContents id = do + dflags <- GHC.getSessionDynFlags + let pcontents = gopt Opt_PrintBindContents dflags + pprdId = (pprTyThing showToHeader . AnId) id + if pcontents + then do + let depthBound = 100 + -- If the value is an exception, make sure we catch it and + -- show the exception, rather than propagating the exception out. + e_term <- MC.try $ GHC.obtainTermFromId depthBound False id + docs_term <- case e_term of + Right term -> showTerm term + Left exn -> return (text "*** Exception:" <+> + text (show (exn :: SomeException))) + return $ pprdId <+> equals <+> docs_term + else return pprdId diff --git a/GHC/Runtime/Debugger/Breakpoints.hs b/GHC/Runtime/Debugger/Breakpoints.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Debugger/Breakpoints.hs @@ -0,0 +1,298 @@ + +-- | GHC API debugger module for finding and setting breakpoints. +-- +-- This module is user facing and is at least used by `GHCi` and `ghc-debugger` +-- to find and set breakpoints. +module GHC.Runtime.Debugger.Breakpoints where + +import GHC.Prelude + +import Control.Monad.Catch +import Control.Monad +import Data.Array +import Data.Function +import Data.List +import Data.Maybe +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as S + +import GHC.HsToCore.Breakpoints +import GHC.ByteCode.Breakpoints +import GHC.Driver.Env +import GHC.Driver.Monad +import GHC.Driver.Session.Inspect +import GHC.Runtime.Eval +import GHC.Runtime.Eval.Utils +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Unit.Module +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModSummary +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified GHC.Data.Strict as Strict +import qualified Data.IntMap.Strict as IntMap +import qualified GHC.Unit.Home.Graph as HUG +import qualified GHC.Unit.Home.PackageTable as HPT + +-------------------------------------------------------------------------------- +-- Finding Module breakpoints +-------------------------------------------------------------------------------- + +-- | Find a breakpoint given a Module's 'TickArray' and the line number. +-- +-- When a line number is specified, the current policy for choosing +-- the best breakpoint is this: +-- - the leftmost complete subexpression on the specified line, or +-- - the leftmost subexpression starting on the specified line, or +-- - the rightmost subexpression enclosing the specified line +-- +findBreakByLine :: Int {-^ Line number -} -> TickArray -> Maybe (BreakTickIndex, RealSrcSpan) +findBreakByLine line arr + | not (inRange (bounds arr) line) = Nothing + | otherwise = + listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus` + listToMaybe (sortBy (compare `on` snd) incomp) `mplus` + listToMaybe (sortBy (flip compare `on` snd) ticks) + where + ticks = arr ! line + + starts_here = [ (ix,pan) | (ix, pan) <- ticks, + srcSpanStartLine pan == line ] + + (comp, incomp) = partition ends_here starts_here + where ends_here (_,pan) = srcSpanEndLine pan == line + +-- | Find a breakpoint in the 'TickArray' of a module, given a line number and a column coordinate. +findBreakByCoord :: (Int, Int) -> TickArray -> Maybe (BreakTickIndex, RealSrcSpan) +findBreakByCoord (line, col) arr + | not (inRange (bounds arr) line) = Nothing + | otherwise = + listToMaybe (sortBy (flip compare `on` snd) contains ++ + sortBy (compare `on` snd) after_here) + where + ticks = arr ! line + + -- the ticks that span this coordinate + contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col) ] + + after_here = [ tick | tick@(_,pan) <- ticks, + srcSpanStartLine pan == line, + srcSpanStartCol pan >= col ] + +leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering +leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd + +-- | Returns the span of the largest tick containing the srcspan given +enclosingTickSpan :: TickArray -> SrcSpan -> RealSrcSpan +enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" +enclosingTickSpan ticks (RealSrcSpan src _) = + assert (inRange (bounds ticks) line) $ + Data.List.minimumBy leftmostLargestRealSrcSpan $ enclosing_spans + where + line = srcSpanStartLine src + enclosing_spans = [ pan | (_,pan) <- ticks ! line + , realSrcSpanEnd pan >= realSrcSpanEnd src] + +-------------------------------------------------------------------------------- +-- Finding Function breakpoints +-------------------------------------------------------------------------------- + +-- | Process and validate the user string of form @[Module.]function@ into the +-- relevant module information and function name. +-- +-- Validation guarantees +-- 1. The module exists +-- 2. The identifier is in an interpreted module +-- 3. The identifier has a breakpoint entry in the module's 'ModBreaks' +-- +-- Returns either an error SDoc or the 'Module' and 'ModuleInfo' for the relevant module +-- paired with the function name +-- +-- See also Note [Setting Breakpoints by Id] +resolveFunctionBreakpoint :: GhcMonad m => String -> m (Either SDoc (Module, ModuleInfo, String)) +resolveFunctionBreakpoint inp = do + let (mod_str, top_level, fun_str) = splitIdent inp + mod_top_lvl = combineModIdent mod_str top_level + mb_mod <- catch (lookupModuleInscope mod_top_lvl) + (\(_ :: SomeException) -> lookupModuleInGraph mod_str) + -- If the top-level name is not in scope, `lookupModuleInscope` will + -- throw an exception, then lookup the module name in the module graph. + mb_err_msg <- validateBP mod_str fun_str mb_mod + case mb_err_msg of + Just err_msg -> pure . Left $ + text "Cannot set breakpoint on" <+> quotes (text inp) + <> text ":" <+> err_msg + Nothing -> do + -- No errors found, go and return the module info + let mod = fromMaybe (panic "resolveFunctionBreakpoint") mb_mod + mb_mod_info <- getModuleInfo mod + case mb_mod_info of + Nothing -> pure . Left $ + text "Could not find ModuleInfo of " <> ppr mod + Just mod_info -> pure $ Right (mod, mod_info, fun_str) + where + -- Try to lookup the module for an identifier that is in scope. + -- `parseName` throws an exception, if the identifier is not in scope + lookupModuleInscope :: GhcMonad m => String -> m (Maybe Module) + lookupModuleInscope mod_top_lvl = do + names <- parseName mod_top_lvl + pure $ Just $ NE.head $ nameModule <$> names + + -- Lookup the Module of a module name in the module graph + lookupModuleInGraph :: GhcMonad m => String -> m (Maybe Module) + lookupModuleInGraph mod_str = do + graph <- getModuleGraph + let hmods = ms_mod <$> mgModSummaries graph + pure $ find ((== mod_str) . moduleNameString . moduleName) hmods + + -- Check validity of an identifier to set a breakpoint: + -- 1. The module of the identifier must exist + -- 2. the identifier must be in an interpreted module + -- 3. the ModBreaks array for module `mod` must have an entry + -- for the function + validateBP :: GhcMonad m => String -> String -> Maybe Module + -> m (Maybe SDoc) + validateBP mod_str fun_str Nothing = pure $ Just $ quotes (text + (combineModIdent mod_str (takeWhile (/= '.') fun_str))) + <+> text "not in scope" + validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing" + validateBP _ fun_str (Just modl) = do + isInterpr <- moduleIsInterpreted modl + mb_err_msg <- case isInterpr of + False -> pure $ Just $ text "Module" <+> quotes (ppr modl) <+> text "is not interpreted" + True -> do + mb_modbreaks <- getModBreak modl + let found = case mb_modbreaks of + Nothing -> False + Just mb -> fun_str `elem` (intercalate "." <$> elems (modBreaks_decls mb)) + if found + then pure Nothing + else pure $ Just $ text "No breakpoint found for" <+> quotes (text fun_str) + <+> text "in module" <+> quotes (ppr modl) + pure mb_err_msg + +-- | The aim of this function is to find the breakpoints for all the RHSs of +-- the equations corresponding to a binding. So we find all breakpoints +-- for +-- (a) this binder only (it maybe a top-level or a nested declaration) +-- (b) that do not have an enclosing breakpoint +findBreakForBind :: String {-^ Name of bind to break at -} -> ModBreaks -> [(BreakTickIndex, RealSrcSpan)] +findBreakForBind str_name modbreaks = filter (not . enclosed) ticks + where + ticks = [ (index, span) + | (index, decls) <- assocs (modBreaks_decls modbreaks), + str_name == intercalate "." decls, + RealSrcSpan span _ <- [modBreaks_locs modbreaks ! index] ] + enclosed (_,sp0) = any subspan ticks + where subspan (_,sp) = sp /= sp0 && + realSrcSpanStart sp <= realSrcSpanStart sp0 && + realSrcSpanEnd sp0 <= realSrcSpanEnd sp + +-------------------------------------------------------------------------------- +-- Mapping line numbers to ticks +-------------------------------------------------------------------------------- + +-- | Maps line numbers to the breakpoint ticks existing at that line for a module. +type TickArray = Array Int [(BreakTickIndex,RealSrcSpan)] + +-- | Construct the 'TickArray' for the given module. +makeModuleLineMap :: GhcMonad m => Module -> m (Maybe TickArray) +makeModuleLineMap m = do + mi <- getModuleInfo m + return $ mkTickArray . assocs . modBreaks_locs . imodBreaks_modBreaks <$> (modInfoModBreaks =<< mi) + where + mkTickArray :: [(BreakTickIndex, SrcSpan)] -> TickArray + mkTickArray ticks + = accumArray (flip (:)) [] (1, max_line) + [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ] + where + max_line = foldr max 0 [ srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ] + srcSpanLines pan = [ srcSpanStartLine pan .. srcSpanEndLine pan ] + +-- | Get the 'ModBreaks' of the given 'Module' when available +getModBreak :: GhcMonad m => Module -> m (Maybe ModBreaks) +getModBreak m = do + mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m + pure $ imodBreaks_modBreaks <$> modInfoModBreaks mod_info + +-------------------------------------------------------------------------------- +-- Mapping source-level BreakpointIds to IBI occurrences +-- (See Note [Breakpoint identifiers]) +-------------------------------------------------------------------------------- + +-- | A source-level breakpoint may have been inlined into many occurrences, now +-- referred by 'InternalBreakpointId'. When a breakpoint is set on a certain +-- source breakpoint, it means all *ocurrences* of that breakpoint across +-- modules should be stopped at -- hence we keep a trie from BreakpointId to +-- the list of internal break ids using it. +-- See also Note [Breakpoint identifiers] +type BreakpointOccurrences = ModuleEnv (IntMap.IntMap [InternalBreakpointId]) + +-- | Lookup all InternalBreakpointIds matching the given BreakpointId +-- Nothing if BreakpointId not in map +lookupBreakpointOccurrences :: BreakpointOccurrences -> BreakpointId -> Maybe [InternalBreakpointId] +lookupBreakpointOccurrences bmp (BreakpointId md tick) = + lookupModuleEnv bmp md >>= IntMap.lookup tick + +-- | Construct a mapping from Source 'BreakpointId's to 'InternalBreakpointId's from the given list of 'ModInfo's +mkBreakpointOccurrences :: forall m. GhcMonad m => m BreakpointOccurrences +mkBreakpointOccurrences = do + hug <- hsc_HUG <$> getSession + liftIO $ foldr go (pure emptyModuleEnv) hug + where + go :: HUG.HomeUnitEnv -> IO BreakpointOccurrences -> IO BreakpointOccurrences + go hue mbmp = do + bmp <- mbmp + ibrkss <- HPT.concatHpt (\hmi -> maybeToList (getModBreaks hmi)) + (HUG.homeUnitEnv_hpt hue) + return $ foldr addBreakToMap bmp ibrkss + + addBreakToMap :: InternalModBreaks -> BreakpointOccurrences -> BreakpointOccurrences + addBreakToMap ibrks bmp0 = do + let imod = modBreaks_module $ imodBreaks_modBreaks ibrks + IntMap.foldrWithKey (\info_ix cgi bmp -> do + let ibi = InternalBreakpointId imod info_ix + case cgb_tick_id cgi of + Right (BreakpointId tick_mod tick_ix) + -> extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi]) + Left _ + -- Do not include internal breakpoints in the visible breakpoint + -- occurrences! + -> bmp + ) bmp0 (imodBreaks_breakInfo ibrks) + +-------------------------------------------------------------------------------- +-- Getting current breakpoint information +-------------------------------------------------------------------------------- + +getCurrentBreakSpan :: GhcMonad m => m (Maybe SrcSpan) +getCurrentBreakSpan = do + hug <- hsc_HUG <$> getSession + resumes <- getResumeContext + case resumes of + [] -> return Nothing + (r:_) -> do + let ix = resumeHistoryIx r + if ix == 0 + then return (Just (resumeSpan r)) + else do + let hist = resumeHistory r !! (ix-1) + pan <- liftIO $ getHistorySpan hug hist + return (Just pan) + +getCurrentBreakModule :: GhcMonad m => m (Maybe Module) +getCurrentBreakModule = do + resumes <- getResumeContext + hug <- hsc_HUG <$> getSession + liftIO $ case resumes of + [] -> pure Nothing + (r:_) -> case resumeHistoryIx r of + 0 -> case resumeBreakpointId r of + Nothing -> pure Nothing + Just ibi -> do + brks <- readIModBreaks hug ibi + return $ Just $ getBreakSourceMod ibi brks + ix -> + Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) + diff --git a/GHC/Runtime/Eval.hs b/GHC/Runtime/Eval.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Eval.hs @@ -0,0 +1,1346 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2007 +-- +-- Running statements interactively +-- +-- ----------------------------------------------------------------------------- + +module GHC.Runtime.Eval ( + Resume(..), History(..), + execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec, + runDecls, runDeclsWithLocation, runParsedDecls, + parseImportDecl, SingleStep(..), + abandon, abandonAll, + getResumeContext, + getHistorySpan, + getModBreaks, readIModBreaks, readIModModBreaks, + getHistoryModule, + setupBreakpoint, + back, forward, + setContext, getContext, + mkTopLevEnv, mkTopLevImportedEnv, + getNamesInScope, + getRdrNamesInScope, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + parseInstanceHead, + getInstancesForType, + getDocs, + GetDocsFailure(..), + showModule, + moduleIsBootOrNotObjectLinkable, + parseExpr, compileParsedExpr, + compileExpr, dynCompileExpr, + compileExprRemote, compileParsedExprRemote, + Term(..), obtainTermFromId, obtainTermFromVal, reconstructType + ) where + +import GHC.Prelude + +import GHC.Driver.Monad +import GHC.Driver.Main +import GHC.Driver.Errors.Types ( hoistTcRnMessage ) +import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Driver.Ppr +import GHC.Driver.Config + +import GHC.Rename.Names (importsFromIface, gresFromAvails) + +import GHC.Runtime.Eval.Types +import GHC.Runtime.Interpreter as GHCi +import GHC.Runtime.Heap.Inspect +import GHC.Runtime.Context +import GHCi.Message +import GHCi.RemoteTypes +import GHC.ByteCode.Types + +import GHC.Linker.Loader as Loader +import GHC.Linker.Types (LinkedBreaks (..)) + +import GHC.Hs + +import GHC.Core.Class (classTyCon) +import GHC.Core.FamInstEnv ( FamInst, orphNamesOfFamInst ) +import GHC.Core.InstEnv +import GHC.Core.Predicate +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Tidy( tidyType, tidyOpenTypes ) +import GHC.Core.TyCon +import GHC.Core.Type hiding( typeKind ) +import qualified GHC.Core.Type as Type + +import GHC.Iface.Env ( newInteractiveBinder ) +import GHC.Iface.Load ( loadInterfaceForModule ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin + +import GHC.Builtin.Names ( toDynName ) +import GHC.Builtin.Types ( pretendNameIsInScope ) + +import GHC.Data.Maybe +import GHC.Data.FastString +import GHC.Data.Bag + +import GHC.Utils.Error +import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Types.RepType +import GHC.Types.Fixity.Env +import GHC.Types.Var +import GHC.Types.Id as Id +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.Var.Env +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import GHC.Types.Unique.DSet +import GHC.Types.TyThing +import GHC.Types.Unique.Map + +import GHC.Types.Avail +import GHC.Unit +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModIface +import GHC.Unit.Home.ModInfo + +import GHC.Tc.Module ( runTcInteractive, tcRnTypeSkolemising, loadUnqualIfaces ) +import GHC.Tc.Solver (simplifyWantedsTcM) +import GHC.Tc.Utils.Env (tcGetInstEnvs) +import GHC.Tc.Utils.Instantiate (instDFunType) +import GHC.Tc.Utils.Monad + +import GHC.IfaceToCore +import GHC.ByteCode.Breakpoints + +import Control.Monad +import Data.Dynamic +import Data.IntMap (IntMap) +import Data.List (find,intercalate) +import Data.List.NonEmpty (NonEmpty) +import Unsafe.Coerce ( unsafeCoerce ) +import qualified GHC.Unit.Home.Graph as HUG +import GHCi.BreakArray (BreakArray) + +-- ----------------------------------------------------------------------------- +-- running a statement interactively + +getResumeContext :: GhcMonad m => m [Resume] +getResumeContext = withSession (return . ic_resume . hsc_IC) + +mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History +mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi + +getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module +getHistoryModule hug hist = do + let ibi = historyBreakpointId hist + brks <- readIModBreaks hug ibi + return $ getBreakSourceMod ibi brks + +getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan +getHistorySpan hug hist = do + let ibi = historyBreakpointId hist + brks <- readIModBreaks hug ibi + getBreakLoc (readIModModBreaks hug) ibi brks + +{- | Finds the enclosing top level function name -} +-- ToDo: a better way to do this would be to keep hold of the decl_path computed +-- by the coverage pass, which gives the list of lexically-enclosing bindings +-- for each tick. +findEnclosingDecls :: HUG.HomeUnitGraph -> InternalBreakpointId -> IO [String] +findEnclosingDecls hug ibi = do + brks <- readIModBreaks hug ibi + getBreakDecls (readIModModBreaks hug) ibi brks + +-- | Update fixity environment in the current interactive context. +updateFixityEnv :: GhcMonad m => FixityEnv -> m () +updateFixityEnv fix_env = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } } + +-- ----------------------------------------------------------------------------- +-- execStmt + +-- | default ExecOptions +execOptions :: ExecOptions +execOptions = ExecOptions + { execSingleStep = RunToCompletion + , execSourceFile = "" + , execLineNumber = 1 + , execWrap = EvalThis -- just run the statement, don't wrap it in anything + } + +-- | Run a statement in the current interactive context. +execStmt + :: GhcMonad m + => String -- ^ a statement (bind or expression) + -> ExecOptions + -> m ExecResult +execStmt input exec_opts@ExecOptions{..} = do + hsc_env <- getSession + + mb_stmt <- + liftIO $ + runInteractiveHsc hsc_env $ + hscParseStmtWithLocation execSourceFile execLineNumber input + + case mb_stmt of + -- empty statement / comment + Nothing -> return (ExecComplete (Right []) 0) + Just stmt -> execStmt' stmt input exec_opts + +-- | Like `execStmt`, but takes a parsed statement as argument. Useful when +-- doing preprocessing on the AST before execution, e.g. in GHCi (see +-- GHCi.UI.runStmt). +execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult +execStmt' stmt stmt_text ExecOptions{..} = do + hsc_env <- getSession + let interp = hscInterp hsc_env + + -- Turn off -fwarn-unused-local-binds when running a statement, to hide + -- warnings about the implicit bindings we introduce. + let ic = hsc_IC hsc_env -- use the interactive dflags + idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds + hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' }}) + + r <- liftIO $ hscParsedStmt hsc_env' stmt + + case r of + Nothing -> + -- empty statement / comment + return (ExecComplete (Right []) 0) + Just (ids, hval, fix_env) -> do + updateFixityEnv fix_env + + status <- + liftIO $ do + let eval_opts = initEvalOpts idflags' (enableGhcStepMode execSingleStep) + evalStmt interp eval_opts (execWrap hval) + + let ic = hsc_IC hsc_env + bindings = (ic_tythings ic, ic_gre_cache ic) + + size = ghciHistSize idflags' + + handleRunStatus execSingleStep stmt_text bindings ids + status (emptyHistory size) + +runDecls :: GhcMonad m => String -> m [Name] +runDecls = runDeclsWithLocation "" 1 + +-- | Run some declarations and return any user-visible names that were brought +-- into scope. +runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] +runDeclsWithLocation source line_num input = do + hsc_env <- getSession + decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input) + runParsedDecls decls + +-- | Like `runDeclsWithLocation`, but takes parsed declarations as argument. +-- Useful when doing preprocessing on the AST before execution, e.g. in GHCi +-- (see GHCi.UI.runStmt). +runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name] +runParsedDecls decls = do + hsc_env <- getSession + (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls) + + setSession $ hsc_env { hsc_IC = ic } + hsc_env <- getSession + hsc_env' <- liftIO $ rttiEnvironment hsc_env + setSession hsc_env' + return $ filter (not . isDerivedOccName . nameOccName) + -- For this filter, see Note [What to show to users] + $ map getName tyThings + +{- Note [What to show to users] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to display internally-generated bindings to users. +Things like the coercion axiom for newtypes. These bindings all get +OccNames that users can't write, to avoid the possibility of name +clashes (in linker symbols). That gives a convenient way to suppress +them. The relevant predicate is OccName.isDerivedOccName. +See #11051 for more background and examples. +-} + +parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs) +parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr + +emptyHistory :: Int -> BoundedList History +emptyHistory size = nilBL size + +-- | Turn an 'EvalStatus_' result from interpreting Haskell into a GHCi 'ExecResult'. +-- +-- This function is responsible for resuming execution at an intermediate +-- breakpoint if we don't care about that breakpoint (e.g. if using :steplocal +-- or :stepmodule, rather than :step, we only care about certain breakpoints). +handleRunStatus :: GhcMonad m + => SingleStep -> String + -> ResumeBindings + -> [Id] + -> EvalStatus_ [ForeignHValue] [HValueRef] + -> BoundedList History + -> m ExecResult + +handleRunStatus step expr bindings final_ids status history0 = do + hsc_env <- getSession + let + interp = hscInterp hsc_env + dflags = hsc_dflags hsc_env + case status of + + -- Completed successfully + EvalComplete allocs (EvalSuccess hvals) -> do + let + final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids + final_names = map getName final_ids + liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals) + hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} + setSession hsc_env' + return (ExecComplete (Right final_names) allocs) + + -- Completed with an exception + EvalComplete alloc (EvalException e) -> + return (ExecComplete (Left (fromSerializableException e)) alloc) + + -- Nothing case: we stopped when an exception was raised, not at a breakpoint. + EvalBreak apStack_ref Nothing resume_ctxt ccs -> do + resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt + apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref + let span = mkGeneralSrcSpan (fsLit "") + (hsc_env1, names) <- liftIO $ + bindLocalsAtBreakpoint hsc_env apStack_fhv span Nothing + let + resume = Resume + { resumeStmt = expr + , resumeContext = resume_ctxt_fhv + , resumeBindings = bindings + , resumeFinalIds = final_ids + , resumeApStack = apStack_fhv + , resumeBreakpointId = Nothing + , resumeSpan = span + , resumeHistory = toListBL history0 + , resumeDecl = "" + , resumeCCS = ccs + , resumeHistoryIx = 0 + } + hsc_env2 = pushResume hsc_env1 resume + + setSession hsc_env2 + return (ExecBreak names Nothing) + + -- EvalBreak (Just ...) case: the interpreter stopped at a breakpoint + -- + -- The interpreter yields on a breakpoint if: + -- - the breakpoint was explicitly enabled (in @BreakArray@) + -- - or one of the stepping options in @EvalOpts@ caused us to stop at one + EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do + let ibi = evalBreakpointToId eval_break + let hug = hsc_HUG hsc_env + info_brks <- liftIO $ readIModBreaks hug ibi + span <- liftIO $ getBreakLoc (readIModModBreaks hug) ibi info_brks + decl <- liftIO $ intercalate "." <$> getBreakDecls (readIModModBreaks hug) ibi info_brks + + -- Was this breakpoint explicitly enabled (ie. in @BreakArray@)? + bactive <- liftIO $ do + breakArray <- getBreakArray interp ibi info_brks + breakpointStatus interp breakArray (ibi_info_index ibi) + + apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref + resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt + + -- This breakpoint is enabled or we mean to break here; + -- we want to stop instead of just logging it. + if breakHere bactive step span then do + -- This function only returns control to ghci with 'ExecBreak' when it is really meant to break. + -- Specifically, for :steplocal or :stepmodule, don't return control + -- and simply resume execution from here until we hit a breakpoint we do want to stop at. + (hsc_env1, names) <- liftIO $ + bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) + let + resume = Resume + { resumeStmt = expr + , resumeContext = resume_ctxt_fhv + , resumeBindings = bindings + , resumeFinalIds = final_ids + , resumeApStack = apStack_fhv + , resumeBreakpointId = Just ibi + , resumeSpan = span + , resumeHistory = toListBL history0 + , resumeDecl = decl + , resumeCCS = ccs + , resumeHistoryIx = 0 + } + hsc_env2 = pushResume hsc_env1 resume + setSession hsc_env2 + return (ExecBreak names (Just ibi)) + else do + -- resume with the same step type + let eval_opts = initEvalOpts dflags (enableGhcStepMode step) + status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv + history <- if not tracing then pure history0 else do + history1 <- liftIO $ mkHistory hug apStack_fhv ibi + let !history' = history1 `consBL` history0 + -- history is strict, otherwise our BoundedList is pointless. + return history' + handleRunStatus step expr bindings final_ids status history + where + tracing | RunAndLogSteps <- step = True + | otherwise = False + +resumeExec :: GhcMonad m => SingleStep -> Maybe Int + -> m ExecResult +resumeExec step mbCnt + = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + + case resume of + [] -> liftIO $ + throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") + (r:rs) -> do + -- unbind the temporary locals by restoring the TypeEnv from + -- before the breakpoint, and drop this Resume from the + -- InteractiveContext. + let (resume_tmp_te,resume_gre_cache) = resumeBindings r + ic' = ic { ic_tythings = resume_tmp_te, + ic_gre_cache = resume_gre_cache, + ic_resume = rs } + setSession hsc_env{ hsc_IC = ic' } + + -- remove any bindings created since the breakpoint from the + -- linker's environment + let old_names = map getName resume_tmp_te + new_names = [ n | thing <- ic_tythings ic + , let n = getName thing + , not (n `elem` old_names) ] + interp = hscInterp hsc_env + dflags = hsc_dflags hsc_env + liftIO $ Loader.deleteFromLoadedEnv interp new_names + + case r of + Resume { resumeStmt = expr + , resumeContext = fhv + , resumeBindings = bindings + , resumeFinalIds = final_ids + , resumeApStack = apStack + , resumeBreakpointId = mb_brkpt + , resumeSpan = span + , resumeHistory = hist } -> + do + -- When the user specified a break ignore count, set it + -- in the interpreter + case (mb_brkpt, mbCnt) of + (Just brkpt, Just cnt) -> setupBreakpoint interp brkpt cnt + _ -> return () + + let eval_opts = initEvalOpts dflags (enableGhcStepMode step) + status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv + let prevHistoryLst = fromListBL 50 hist + hug = hsc_HUG hsc_env + hist' = case mb_brkpt of + Nothing -> pure prevHistoryLst + Just bi + | breakHere False step span -> do + hist1 <- liftIO (mkHistory hug apStack bi) + return $ hist1 `consBL` fromListBL 50 hist + | otherwise -> pure prevHistoryLst + handleRunStatus step expr bindings final_ids status =<< hist' + +setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m () -- #19157 +setupBreakpoint interp ibi cnt = do + hug <- hsc_HUG <$> getSession + liftIO $ do + modBreaks <- readIModBreaks hug ibi + breakArray <- getBreakArray interp ibi modBreaks + GHCi.storeBreakpoint interp breakArray (ibi_info_index ibi) cnt + +getBreakArray :: Interp -> InternalBreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray) +getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do + breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp + case lookupModuleEnv (breakarray_env breaks0) ibi_info_mod of + Just ba -> return ba + Nothing -> do + modifyLoaderState interp $ \ld_st -> do + let lb = linked_breaks ld_st + + -- Recall that BreakArrays are allocated only at BCO link time, so if we + -- haven't linked the BCOs we intend to break at yet, we allocate the arrays here. + ba_env <- allocateBreakArrays interp (breakarray_env lb) [imbs] + + let ld_st' = ld_st { linked_breaks = lb{breakarray_env = ba_env} } + let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env ibi_info_mod + + return + ( ld_st' + , ba + ) +back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) +back n = moveHist (+n) + +forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) +forward n = moveHist (subtract n) + +moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan) +moveHist fn = do + hsc_env <- getSession + case ic_resume (hsc_IC hsc_env) of + [] -> liftIO $ + throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") + (r:rs) -> do + let ix = resumeHistoryIx r + history = resumeHistory r + new_ix = fn ix + -- + when (history `lengthLessThan` new_ix) $ liftIO $ + throwGhcExceptionIO (ProgramError "no more logged breakpoints") + when (new_ix < 0) $ liftIO $ + throwGhcExceptionIO (ProgramError "already at the beginning of the history") + + let + update_ic apStack mb_info = do + span <- case mb_info of + Nothing -> return $ mkGeneralSrcSpan (fsLit "") + Just ibi -> liftIO $ do + let hug = hsc_HUG hsc_env + brks <- readIModBreaks hug ibi + getBreakLoc (readIModModBreaks hug) ibi brks + (hsc_env1, names) <- + liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info + let ic = hsc_IC hsc_env1 + r' = r { resumeHistoryIx = new_ix } + ic' = ic { ic_resume = r':rs } + + setSession hsc_env1{ hsc_IC = ic' } + + return (names, new_ix, span) + + -- careful: we want apStack to be the AP_STACK itself, not a thunk + -- around it, hence the cases are carefully constructed below to + -- make this the case. ToDo: this is v. fragile, do something better. + if new_ix == 0 + then case r of + Resume { resumeApStack = apStack, + resumeBreakpointId = mb_brkpt } -> + update_ic apStack mb_brkpt + else case history !! (new_ix - 1) of + History{..} -> + update_ic historyApStack (Just historyBreakpointId) + + +-- ----------------------------------------------------------------------------- +-- After stopping at a breakpoint, add free variables to the environment + +result_fs :: FastString +result_fs = fsLit "_result" + +bindLocalsAtBreakpoint + :: HscEnv + -> ForeignHValue + -> SrcSpan + -> Maybe InternalBreakpointId + -> IO (HscEnv, [Name]) + +-- Nothing case: we stopped when an exception was raised, not at a +-- breakpoint. We have no location information or local variables to +-- bind, all we can do is bind a local variable to the exception +-- value. +bindLocalsAtBreakpoint hsc_env apStack span Nothing = do + let exn_occ = mkVarOccFS (fsLit "_exception") + exn_name <- newInteractiveBinder hsc_env exn_occ span + + let e_fs = fsLit "e" + e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span + e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind + exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) + + ictxt0 = hsc_IC hsc_env + ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] + interp = hscInterp hsc_env + -- + Loader.extendLoadedEnv interp [(exn_name, apStack)] + return (hsc_env{ hsc_IC = ictxt1 }, [exn_name]) + +-- Just case: we stopped at a breakpoint, we have information about the location +-- of the breakpoint and the free variables of the expression. +bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do + let hug = hsc_HUG hsc_env + info_brks <- readIModBreaks hug ibi + let info = getInternalBreak ibi info_brks + interp = hscInterp hsc_env + occs <- getBreakVars (readIModModBreaks hug) ibi info_brks + + -- Rehydrate to understand the breakpoint info relative to the current environment. + -- This design is critical to preventing leaks (#22530) + (mbVars, result_ty) <- initIfaceLoad hsc_env + $ initIfaceLcl (ibi_info_mod ibi) (text "debugger") NotBoot + $ hydrateCgBreakInfo info + + let + + -- Filter out any unboxed ids by changing them to Nothings; + -- we can't bind these at the prompt + mbPointers = nullUnboxed <$> mbVars + + (ids, offsets, occs') = syncOccs mbPointers occs + + free_tvs = tyCoVarsOfTypesWellScoped (result_ty:map idType ids) + + -- It might be that getIdValFromApStack fails, because the AP_STACK + -- has been accidentally evaluated, or something else has gone wrong. + -- So that we don't fall over in a heap when this happens, just don't + -- bind any free variables instead, and we emit a warning. + mb_hValues <- + mapM (getBreakpointVar interp apStack_fhv . fromIntegral) offsets + when (any isNothing mb_hValues) $ + debugTraceMsg (hsc_logger hsc_env) 1 $ + text "Warning: _result has been evaluated, some bindings have been lost" + + us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time + let tv_subst = newTyVars us free_tvs + (filtered_ids, occs'') = unzip -- again, sync the occ-names + [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ] + tidy_tys = tidyOpenTypes emptyTidyEnv $ + map (substTy tv_subst . idType) filtered_ids + + new_ids <- zipWith3M mkNewId occs'' tidy_tys filtered_ids + result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span + + let result_id = Id.mkVanillaGlobal result_name + (substTy tv_subst result_ty) + result_ok = isPointer result_id + + final_ids | result_ok = result_id : new_ids + | otherwise = new_ids + ictxt0 = hsc_IC hsc_env + ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids + names = map idName new_ids + + let fhvs = catMaybes mb_hValues + Loader.extendLoadedEnv interp (zip names fhvs) + when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)] + hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } + return (hsc_env1, if result_ok then result_name:names else names) + where + -- We need a fresh Unique for each Id we bind, because the linker + -- state is single-threaded and otherwise we'd spam old bindings + -- whenever we stop at a breakpoint. The InteractveContext is properly + -- saved/restored, but not the linker state. See #1743, test break026. + mkNewId :: OccName -> Type -> Id -> IO Id + mkNewId occ ty old_id + = do { name <- newInteractiveBinder hsc_env (mkVarOccFS (occNameFS occ)) (getSrcSpan old_id) + -- NB: use variable namespace. + -- Don't use record field namespaces, lest we cause #25109. + ; return $ Id.mkVanillaGlobalWithInfo name ty (idInfo old_id) } + + newTyVars :: UniqSupply -> [TcTyVar] -> Subst + -- Similarly, clone the type variables mentioned in the types + -- we have here, *and* make them all RuntimeUnk tyvars + newTyVars us tvs = foldl' new_tv emptySubst (tvs `zip` uniqsFromSupply us) + new_tv subst (tv,uniq) = extendTCvSubstWithClone subst tv new_tv + where + new_tv = mkRuntimeUnkTyVar (setNameUnique (tyVarName tv) uniq) + (substTy subst (tyVarKind tv)) + + isPointer id | [rep] <- typePrimRep (idType id) + , isGcPtrRep rep = True + | otherwise = False + + -- Convert unboxed Id's to Nothings + nullUnboxed (Just (fv@(id, _))) + | isPointer id = Just fv + | otherwise = Nothing + nullUnboxed Nothing = Nothing + + -- See Note [Syncing breakpoint info] + syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c]) + syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs + where + joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)] + joinOccs = zipWithEqual joinOcc + joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc + +rttiEnvironment :: HscEnv -> IO HscEnv +rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do + let tmp_ids = [id | AnId id <- ic_tythings ic] + incompletelyTypedIds = + [id | id <- tmp_ids + , not $ noSkolems id + , (occNameFS.nameOccName.idName) id /= result_fs] + foldM improveTypes hsc_env (map idName incompletelyTypedIds) + where + noSkolems = noFreeVarsOfType . idType + improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do + let tmp_ids = [id | AnId id <- ic_tythings ic] + id = expectJust $ find (\i -> idName i == name) tmp_ids + if noSkolems id + then return hsc_env + else do + mb_new_ty <- reconstructType hsc_env 10 id + let old_ty = idType id + case mb_new_ty of + Nothing -> return hsc_env + Just new_ty -> do + case improveRTTIType hsc_env old_ty new_ty of + Nothing -> warnPprTrace True (":print failed to calculate the " + ++ "improvement for a type") + (vcat [ text "id" <+> ppr id + , text "old_ty" <+> debugPprType old_ty + , text "new_ty" <+> debugPprType new_ty ]) $ + return hsc_env + Just subst -> do + let logger = hsc_logger hsc_env + putDumpFileMaybe logger Opt_D_dump_rtti "RTTI" + FormatText + (fsep [text "RTTI Improvement for", ppr id, equals, + ppr subst]) + + let ic' = substInteractiveContext ic subst + return hsc_env{hsc_IC=ic'} + +pushResume :: HscEnv -> Resume -> HscEnv +pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } + where + ictxt0 = hsc_IC hsc_env + ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 } + + + {- + Note [Syncing breakpoint info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + To display the values of the free variables for a single breakpoint, the + function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` pulls + out the information from the fields `modBreaks_breakInfo` and + `modBreaks_vars` of the `ModBreaks` data structure. + For a specific breakpoint this gives 2 lists of type `Id` (or `Var`) + and `OccName`. + They are used to create the Id's for the free variables and must be kept + in sync! + + There are 3 situations where items are removed from the Id list + (or replaced with `Nothing`): + 1.) If function `GHC.StgToByteCode.schemeER_wrk` (which creates + the Id list) doesn't find an Id in the ByteCode environment. + 2.) If function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` + filters out unboxed elements from the Id list, because GHCi cannot + yet handle them. + 3.) If the GHCi interpreter doesn't find the reference to a free variable + of our breakpoint. This also happens in the function + bindLocalsAtBreakpoint. + + If an element is removed from the Id list, then the corresponding element + must also be removed from the Occ list. Otherwise GHCi will confuse + variable names as in #8487. + -} + +-- ----------------------------------------------------------------------------- +-- Abandoning a resume context + +abandon :: GhcMonad m => m Bool +abandon = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + interp = hscInterp hsc_env + case resume of + [] -> return False + r:rs -> do + setSession hsc_env{ hsc_IC = ic { ic_resume = rs } } + liftIO $ abandonStmt interp (resumeContext r) + return True + +abandonAll :: GhcMonad m => m Bool +abandonAll = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + interp = hscInterp hsc_env + case resume of + [] -> return False + rs -> do + setSession hsc_env{ hsc_IC = ic { ic_resume = [] } } + liftIO $ mapM_ (abandonStmt interp. resumeContext) rs + return True + +-- ----------------------------------------------------------------------------- +-- Bounded list, optimised for repeated cons + +data BoundedList a = BL + {-# UNPACK #-} !Int -- length + {-# UNPACK #-} !Int -- bound + [a] -- left + [a] -- right, list is (left ++ reverse right) + +nilBL :: Int -> BoundedList a +nilBL bound = BL 0 bound [] [] + +consBL :: a -> BoundedList a -> BoundedList a +consBL a (BL len bound left right) + | len < bound = BL (len+1) bound (a:left) right + | null right = BL len bound [a] $! tail (reverse left) + | otherwise = BL len bound (a:left) $! tail right + +toListBL :: BoundedList a -> [a] +toListBL (BL _ _ left right) = left ++ reverse right + +fromListBL :: Int -> [a] -> BoundedList a +fromListBL bound l = BL (length l) bound l [] + +-- lenBL (BL len _ _ _) = len + +-- ----------------------------------------------------------------------------- +-- | Set the interactive evaluation context. +-- +-- (setContext imports) sets the ic_imports field (which in turn +-- determines what is in scope at the prompt) to 'imports', and +-- updates the icReaderEnv environment to reflect it. +-- +-- We retain in scope all the things defined at the prompt, and kept +-- in ic_tythings. (Indeed, they shadow stuff from ic_imports.) + +setContext :: GhcMonad m => [InteractiveImport] -> m () +setContext imports + = do { hsc_env <- getSession + ; let dflags = hsc_dflags hsc_env + ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports + ; case all_env_err of + Left (mod, err) -> + liftIO $ throwGhcExceptionIO (formatError dflags mod err) + Right all_env -> do { + ; let old_ic = hsc_IC hsc_env + !final_gre_cache = ic_gre_cache old_ic `replaceImportEnv` all_env + ; setSession + hsc_env{ hsc_IC = old_ic { ic_imports = imports + , ic_gre_cache = final_gre_cache }}}} + where + formatError dflags mod err = ProgramError . showSDoc dflags $ + text "Cannot add module" <+> ppr mod <+> + text "to context:" <+> text err + +findGlobalRdrEnv :: HscEnv -> [InteractiveImport] + -> IO (Either (Module, String) GlobalRdrEnv) +-- Compute the GlobalRdrEnv for the interactive context +findGlobalRdrEnv hsc_env imports + = do { idecls_env <- hscRnImportDecls hsc_env idecls + -- This call also loads any orphan modules + ; partitionWithM mkEnv imods >>= \case + (err : _, _) -> return $ Left err + ([], imods_env) -> return $ Right (foldr plusGlobalRdrEnv idecls_env imods_env) + } + where + idecls :: [LImportDecl GhcPs] + idecls = [noLocA d | IIDecl d <- imports] + + imods :: [Module] + imods = [m | IIModule m <- imports] + + mkEnv mod = do + mkTopLevEnv hsc_env mod >>= \case + Left err -> pure $ Left (mod, err) + Right env -> pure $ Right env + +mkTopLevEnv :: HscEnv -> Module -> IO (Either String GlobalRdrEnv) +mkTopLevEnv hsc_env modl + = HUG.lookupHugByModule modl hug >>= \case + Nothing -> pure $ Left "not a home module" + Just details -> + case mi_top_env (hm_iface details) of + (IfaceTopEnv exports _imports) -> do + imports_env <- mkTopLevImportedEnv hsc_env details + let exports_env = mkGlobalRdrEnv $ gresFromAvails hsc_env Nothing (getDetOrdAvails exports) + pure $ Right $ plusGlobalRdrEnv imports_env exports_env + where + hug = hsc_HUG hsc_env + +-- | Make the top-level environment with all bindings imported by this module. +-- Exported bindings from this module are not included in the result. +mkTopLevImportedEnv :: HscEnv -> HomeModInfo -> IO GlobalRdrEnv +mkTopLevImportedEnv hsc_env details = do + runInteractiveHsc hsc_env + $ ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env + $ fmap (foldr plusGlobalRdrEnv emptyGlobalRdrEnv) + $ forM imports $ \iface_import -> do + let ImpUserSpec spec details = tcIfaceImport iface_import + iface <- loadInterfaceForModule (text "imported by GHCi") (is_mod spec) + pure $ case details of + ImpUserAll -> importsFromIface hsc_env iface spec Nothing + ImpUserEverythingBut ns -> importsFromIface hsc_env iface spec (Just ns) + ImpUserExplicit x _parents_of_implicits -> + -- TODO: Not quite right, is_explicit should refer to whether the user wrote A(..) or A(x,y). + -- It is only used for error messages. It seems dubious even to add an import context to these GREs as + -- they are not "imported" into the top-level scope of the REPL. I changed this for now so that + -- the test case produce the same output as before. + let spec' = ImpSpec { is_decl = spec, is_item = ImpSome { is_explicit = True, is_iloc = noSrcSpan } } + in mkGlobalRdrEnv $ gresFromAvails hsc_env (Just spec') x + where + IfaceTopEnv _ imports = mi_top_env (hm_iface details) + +-- | Get the interactive evaluation context, consisting of a pair of the +-- set of modules from which we take the full top-level scope, and the set +-- of modules from which we take just the exports respectively. +getContext :: GhcMonad m => m [InteractiveImport] +getContext = withSession $ \HscEnv{ hsc_IC=ic } -> + return (ic_imports ic) + +-- | Returns @True@ if the specified module is interpreted, and hence has +-- its full top-level scope available. +moduleIsInterpreted :: GhcMonad m => Module -> m Bool +moduleIsInterpreted modl = withSession $ \h -> + liftIO (HUG.lookupHugByModule modl (hsc_HUG h)) >>= \case + Just hmi -> return (isJust $ homeModInfoByteCode hmi) + _not_a_home_module -> return False + +-- | Looks up an identifier in the current interactive context (for :info) +-- Filter the instances by the ones whose tycons (or classes resp) +-- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! +-- The exact choice of which ones to show, and which to hide, is a judgement call. +-- (see #1581) +getInfo :: GhcMonad m => Bool -> Name + -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc)) +getInfo allInfo name + = withSession $ \hsc_env -> + do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name + case mb_stuff of + Nothing -> return Nothing + Just (thing, fixity, cls_insts, fam_insts, docs) -> do + let rdr_env = icReaderEnv (hsc_IC hsc_env) + + -- Filter the instances based on whether the constituent names of their + -- instance heads are all in scope. + let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts + fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts + return (Just (thing, fixity, cls_insts', fam_insts', docs)) + where + plausible rdr_env names + -- Dfun involving only names that are in icReaderEnv + = allInfo + || nameSetAll ok names + where -- A name is ok if it's in the rdr_env, + -- whether qualified or not + ok n | n == name = True + -- The one we looked for in the first place! + | pretendNameIsInScope n = True + -- See Note [pretendNameIsInScope] in GHC.Builtin.Names + | isExternalName n = isJust (lookupGRE_Name rdr_env n) + | otherwise = True + +-- | Returns all names in scope in the current interactive context +getNamesInScope :: GhcMonad m => m [Name] +getNamesInScope = withSession $ \hsc_env -> + return $ map greName $ globalRdrEnvElts (icReaderEnv (hsc_IC hsc_env)) + +-- | Returns all 'RdrName's in scope in the current interactive +-- context, excluding any that are internally-generated. +getRdrNamesInScope :: GhcMonad m => m [RdrName] +getRdrNamesInScope = withSession $ \hsc_env -> do + let + ic = hsc_IC hsc_env + gbl_rdrenv = icReaderEnv ic + gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv + -- Exclude internally generated names; see e.g. #11328 + return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names) + + +-- | Parses a string as an identifier, and returns the list of 'Name's that +-- the identifier can refer to in the current interactive context. +parseName :: GhcMonad m => String -> m (NonEmpty Name) +parseName str = withSession $ \hsc_env -> liftIO $ + do { lrdr_name <- hscParseIdentifier hsc_env str + ; hscTcRnLookupRdrName hsc_env lrdr_name } + + +getDocs :: GhcMonad m + => Name + -> m (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))) + -- TODO: What about docs for constructors etc.? +getDocs name = + withSession $ \hsc_env -> do + case nameModule_maybe name of + Nothing -> pure (Left (NameHasNoModule name)) + Just mod -> do + if isInteractiveModule mod + then pure (Left InteractiveName) + else do + iface <- liftIO $ hscGetModuleInterface hsc_env mod + case mi_docs iface of + Nothing -> pure (Left (NoDocsInIface mod compiled)) + Just Docs { docs_decls = decls + , docs_args = args + } -> + pure (Right ( lookupUniqMap decls name + , fromMaybe mempty $ lookupUniqMap args name)) + where + compiled = + -- TODO: Find a more direct indicator. + case nameSrcLoc name of + RealSrcLoc {} -> False + UnhelpfulLoc {} -> True + +-- | Failure modes for 'getDocs'. +data GetDocsFailure + + -- | 'nameModule_maybe' returned 'Nothing'. + = NameHasNoModule Name + + -- | The module was loaded without @-haddock@, + | NoDocsInIface + Module + Bool -- ^ 'True': The module was compiled. + -- 'False': The module was :loaded. + + -- | The 'Name' was defined interactively. + | InteractiveName + +instance Outputable GetDocsFailure where + ppr (NameHasNoModule name) = + quotes (ppr name) <+> text "has no module where we could look for docs." + ppr (NoDocsInIface mod compiled) = vcat + [ text "Can't find any documentation for" <+> ppr mod <> char '.' + , if compiled + then text "Try re-compiling with '-haddock'." + else text "Try running ':set -haddock' and :load the file again." + -- TODO: Figure out why :reload doesn't load the docs and maybe fix it. + ] + ppr InteractiveName = + text "Docs are unavailable for interactive declarations." + +-- ----------------------------------------------------------------------------- +-- Getting the type of an expression + +-- | Get the type of an expression +-- Returns the type as described by 'TcRnExprMode' +exprType :: GhcMonad m => TcRnExprMode -> String -> m Type +exprType mode expr = withSession $ \hsc_env -> do + ty <- liftIO $ hscTcExpr hsc_env mode expr + return $ tidyType emptyTidyEnv ty + +-- ----------------------------------------------------------------------------- +-- Getting the kind of a type + +-- | Get the kind of a type +typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind) +typeKind normalise str = withSession $ \hsc_env -> + liftIO $ hscKcType hsc_env normalise str + +-- ---------------------------------------------------------------------------- +-- Getting the class instances for a type + +{- + Note [Querying instances for a type] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Here is the implementation of GHC proposal 41. + (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst) + + The objective is to take a query string representing a (partial) type, and + report all the class single-parameter class instances available to that type. + Extending this feature to multi-parameter typeclasses is left as future work. + + The general outline of how we solve this is: + + 1. Parse the type, leaving skolems in the place of type-holes. + 2. For every class, get a list of all instances that match with the query type. + 3. For every matching instance, ask GHC for the context the instance dictionary needs. + 4. Format and present the results, substituting our query into the instance + and simplifying the context. + + For example, given the query "Maybe Int", we want to return: + + instance Show (Maybe Int) + instance Read (Maybe Int) + instance Eq (Maybe Int) + .... + + [Holes in queries] + + Often times we want to know what instances are available for a polymorphic type, + like `Maybe a`, and we'd like to return instances such as: + + instance Show a => Show (Maybe a) + .... + + These queries are expressed using type holes, so instead of `Maybe a` the user writes + `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes + with (un-named) type variables. + + When zonking the type holes we have two real choices: replace them with Any or replace + them with skolem typevars. Using skolem type variables ensures that the output is more + intuitive to end users, and there is no difference in the results between Any and skolems. + +-} + +-- Find all instances that match a provided type +getInstancesForType :: GhcMonad m => Type -> m [ClsInst] +getInstancesForType ty = withSession $ \hsc_env -> + liftIO $ runInteractiveHsc hsc_env $ + ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env $ do + -- Bring class and instances from unqualified modules into scope, this fixes #16793. + loadUnqualIfaces hsc_env (hsc_IC hsc_env) + matches <- findMatchingInstances ty + + fmap catMaybes . forM matches $ uncurry checkForExistence + +-- Parse a type string and turn any holes into skolems +parseInstanceHead :: GhcMonad m => String -> m Type +parseInstanceHead str = withSession $ \hsc_env0 -> do + (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ty <- hscParseType str + ioMsgMaybe $ hoistTcRnMessage $ + tcRnTypeSkolemising hsc_env ty + -- I'm not sure what to do about those zonked skolems + return ty + +-- Get all the constraints required of a dictionary binding +getDictionaryBindings :: PredType -> TcM CtEvidence +getDictionaryBindings theta = do + dictName <- newName (mkDictOcc (mkVarOccFS (fsLit "magic"))) + let dict_var = mkVanillaGlobal dictName theta + loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing + + return $ CtWanted $ WantedCt { + ctev_pred = varType dict_var, + ctev_dest = EvVarDest dict_var, + ctev_loc = loc, + ctev_rewriters = emptyRewriterSet + } + +-- Find instances where the head unifies with the provided type +findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] +findMatchingInstances ty = do + ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs + let allClasses = uniqDSetToList $ instEnvClasses ie_global `unionUniqDSets` instEnvClasses ie_local + return $ concatMap (try_cls ies) allClasses + where + {- Check that a class instance is well-kinded. + Since `:instances` only works for unary classes, we're looking for instances of kind + k -> Constraint where k is the type of the queried type. + -} + try_cls ies cls + | Just (_, _, arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) + , isConstraintKind res_kind + , Type.typeKind ty `eqType` arg_kind + , (matches, _, _) <- lookupInstEnv True ies cls [ty] + = matches + | otherwise + = [] + + +{- + When we've found an instance that a query matches against, we still need to + check that all the instance's constraints are satisfiable. checkForExistence + creates an instance dictionary and verifies that any unsolved constraints + mention a type-hole, meaning it is blocked on an unknown. + + If the instance satisfies this condition, then we return it with the query + substituted into the instance and all constraints simplified, for example given: + + instance D a => C (MyType a b) where + + and the query `MyType _ String` + + the unsolved constraints will be [D _] so we apply the substitution: + + { a -> _; b -> String} + + and return the instance: + + instance D _ => C (MyType _ String) + +-} + +checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst) +checkForExistence clsInst mb_inst_tys = do + -- We want to force the solver to attempt to solve the constraints for clsInst. + -- Usually, this isn't a problem since there should only be a single instance + -- for a type. However, when we have overlapping instances, the solver will give up + -- since it can't decide which instance to use. To get around this restriction, instead + -- of asking the solver to solve a constraint for clsInst, we ask it to solve the + -- thetas of clsInst. + (tys, thetas) <- instDFunType (is_dfun clsInst) mb_inst_tys + wanteds <- mapM getDictionaryBindings thetas + -- It's important to zonk constraints after solving in order to expose things like TypeErrors + -- which otherwise appear as opaque type variables. (See #18262). + WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds + + -- The simples might contain superclasses. This clutters up the output + -- (we want e.g. instance Ord a => Ord (Maybe a), not + -- instance (Ord a, Eq a) => Ord (Maybe a)). So we use mkMinimalBySCs + let simple_preds = map ctPred (bagToList simples) + let minimal_simples = mkMinimalBySCs id simple_preds + + if all allowedSimple minimal_simples && solvedImplics impls + then return . Just $ substInstArgs tys minimal_simples clsInst + else return Nothing + + where + allowedSimple :: PredType -> Bool + allowedSimple pred = isSatisfiablePred pred + + solvedImplics :: Bag Implication -> Bool + solvedImplics impls = allBag (isSolvedStatus . ic_status) impls + + -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least + -- one argument or for the head to be a TyVar. The reason is that we want to ensure + -- that all residual constraints mention a type-hole somewhere in the constraint, + -- meaning that with the correct choice of a concrete type it could be possible for + -- the constraint to be discharged. + isSatisfiablePred :: PredType -> Bool + isSatisfiablePred ty = case getClassPredTys_maybe ty of + Just (_, tys@(_:_)) -> all isTyVarTy tys + _ -> isTyVarTy ty + + empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun clsInst))) + + {- Create a ClsInst with instantiated arguments and constraints. + + The thetas are the list of constraints that couldn't be solved because + they mention a type-hole. + -} + substInstArgs :: [Type] -> [PredType] -> ClsInst -> ClsInst + substInstArgs tys thetas inst = let + subst = foldl' (\a b -> uncurry (extendTvSubstAndInScope a) b) empty_subst (zip dfun_tvs tys) + -- Build instance head with arguments substituted in + tau = mkClassPred cls (substTheta subst args) + -- Constrain the instance with any residual constraints + phi = mkPhiTy thetas tau + sigma = mkForAllTys (map (\v -> Bndr v Inferred) dfun_tvs) phi + + in inst { is_dfun = (is_dfun inst) { varType = sigma }} + where + (dfun_tvs, _, cls, args) = instanceSig inst + +----------------------------------------------------------------------------- +-- Compile an expression, run it, and deliver the result + +-- | Parse an expression, the parsed expression can be further processed and +-- passed to compileParsedExpr. +parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs) +parseExpr expr = withSession $ \hsc_env -> + liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr + +-- | Compile an expression, run it, and deliver the resulting HValue. +compileExpr :: GhcMonad m => String -> m HValue +compileExpr expr = do + parsed_expr <- parseExpr expr + compileParsedExpr parsed_expr + +-- | Compile an expression, run it, and deliver the resulting HValue. +compileExprRemote :: GhcMonad m => String -> m ForeignHValue +compileExprRemote expr = do + parsed_expr <- parseExpr expr + compileParsedExprRemote parsed_expr + +-- | Compile a parsed expression (before renaming), run it, and deliver +-- the resulting HValue. +compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue +compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do + let dflags = hsc_dflags hsc_env + let interp = hscInterp hsc_env + + -- > let _compileParsedExpr = expr + -- Create let stmt from expr to make hscParsedStmt happy. + -- We will ignore the returned [Id], namely [expr_id], and not really + -- create a new binding. + let expr_fs = fsLit "_compileParsedExpr" + loc' = locA loc + expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc' + let_stmt = L loc . LetStmt noAnn . (HsValBinds noAnn) $ + ValBinds NoAnnSortKey + [mkHsVarBind loc' (getRdrName expr_name) expr] [] + + pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt + let (hvals_io, fix_env) = case pstmt of + Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env') + _ -> panic "compileParsedExprRemote" + + updateFixityEnv fix_env + let eval_opts = initEvalOpts dflags EvalStepNone + status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io) + case status of + EvalComplete _ (EvalSuccess [hval]) -> return hval + EvalComplete _ (EvalException e) -> + liftIO $ throwIO (fromSerializableException e) + _ -> panic "compileParsedExpr" + +compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue +compileParsedExpr expr = do + fhv <- compileParsedExprRemote expr + interp <- hscInterp <$> getSession + liftIO $ wormhole interp fhv + +-- | Compile an expression, run it and return the result as a Dynamic. +dynCompileExpr :: GhcMonad m => String -> m Dynamic +dynCompileExpr expr = do + parsed_expr <- parseExpr expr + -- > Data.Dynamic.toDyn expr + let loc = getLoc parsed_expr + to_dyn_expr = mkHsApp (L loc . mkHsVar . L (l2l loc) $ getRdrName toDynName) + parsed_expr + hval <- compileParsedExpr to_dyn_expr + return (unsafeCoerce hval :: Dynamic) + +----------------------------------------------------------------------------- +-- show a module and its source/object filenames + +showModule :: GhcMonad m => ModuleNodeInfo -> m String +showModule mni = do + let mod = moduleNodeInfoModule mni + withSession $ \hsc_env -> do + let dflags = hsc_dflags hsc_env + interpreted <- liftIO $ + HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case + Nothing -> panic "missing linkable" + Just mod_info -> isJust (homeModInfoByteCode mod_info) && isNothing (homeModInfoObject mod_info) + return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mni)) + +moduleIsBootOrNotObjectLinkable :: GhcMonad m => Module -> m Bool +moduleIsBootOrNotObjectLinkable mod = withSession $ \hsc_env -> liftIO $ + HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case + Nothing -> panic "missing linkable" + Just mod_info -> isNothing $ homeModInfoByteCode mod_info + +---------------------------------------------------------------------------- +-- RTTI primitives + +obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term +#if defined(HAVE_INTERNAL_INTERPRETER) +obtainTermFromVal hsc_env bound force ty x = case interpInstance interp of + InternalInterp -> cvObtainTerm hsc_env bound force ty (unsafeCoerce x) +#else +obtainTermFromVal hsc_env _bound _force _ty _x = case interpInstance interp of +#endif + ExternalInterp {} -> throwIO (InstallationError + "this operation requires -fno-external-interpreter") + where + interp = hscInterp hsc_env + +obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term +obtainTermFromId hsc_env bound force id = do + (hv, _, _) <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id) + cvObtainTerm hsc_env bound force (idType id) hv + +-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic +reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) +reconstructType hsc_env bound id = do + (hv, _, _) <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id) + cvReconstructType hsc_env bound (idType id) hv + +mkRuntimeUnkTyVar :: Name -> Kind -> TyVar +mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk diff --git a/GHC/Runtime/Eval/Types.hs b/GHC/Runtime/Eval/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Eval/Types.hs @@ -0,0 +1,198 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2007 +-- +-- Running statements interactively +-- +-- ----------------------------------------------------------------------------- + +module GHC.Runtime.Eval.Types ( + Resume(..), ResumeBindings, IcGlobalRdrEnv(..), + History(..), ExecResult(..), + SingleStep(..), enableGhcStepMode, breakHere, + ExecOptions(..) + ) where + +import GHC.Prelude + +import GHCi.RemoteTypes +import GHCi.Message (EvalExpr, ResumeContext) +import GHC.ByteCode.Types (InternalBreakpointId(..)) +import GHC.Driver.Config (EvalStep(..)) +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.TyThing +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import GHC.Utils.Exception + +import Data.Word +import GHC.Stack.CCS + +data ExecOptions + = ExecOptions + { execSingleStep :: SingleStep -- ^ stepping mode + , execSourceFile :: String -- ^ filename (for errors) + , execLineNumber :: Int -- ^ line number (for errors) + , execWrap :: ForeignHValue -> EvalExpr ForeignHValue + } + +-- | What kind of stepping are we doing? +data SingleStep + = RunToCompletion + + -- | :trace [expr] + | RunAndLogSteps + + -- | :step [expr] + | SingleStep + + -- | :stepout + | StepOut + { initiatedFrom :: Maybe SrcSpan + -- ^ Step-out locations are filtered to make sure we don't stop at a + -- continuation that is within the function from which step-out was + -- initiated. See Note [Debugger: Step-out] + } + + -- | :steplocal [expr] + | LocalStep + { breakAt :: SrcSpan } + + -- | :stepmodule [expr] + | ModuleStep + { breakAt :: SrcSpan } + +-- | Whether this 'SingleStep' mode requires instructing the interpreter to +-- step at every breakpoint or after every return (see @'EvalStep'@). +enableGhcStepMode :: SingleStep -> EvalStep +enableGhcStepMode RunToCompletion = EvalStepNone +enableGhcStepMode StepOut{} = EvalStepOut +-- for the remaining step modes we need to stop at every single breakpoint. +enableGhcStepMode _ = EvalStepSingle + +-- | Given a 'SingleStep' mode, whether the breakpoint was explicitly active, +-- and the SrcSpan of a breakpoint we hit, return @True@ if we should stop at +-- this breakpoint. +-- +-- In particular, this will always be @False@ for @'RunToCompletion'@ and +-- @'RunAndLogSteps'@. We'd need further information e.g. about the user +-- breakpoints to determine whether to break in those modes. +breakHere :: Bool -- ^ Was this breakpoint explicitly active (in the @BreakArray@s)? + -> SingleStep -- ^ What kind of stepping were we doing + -> SrcSpan -- ^ The span of the breakpoint we hit + -> Bool -- ^ Should we stop here then? +breakHere b RunToCompletion _ = b +breakHere b RunAndLogSteps _ = b +breakHere _ SingleStep _ = True +breakHere b step break_span = case step of + LocalStep start_span -> b || break_span `isSubspanOf` start_span + ModuleStep start_span -> b || srcSpanFileName_maybe start_span == srcSpanFileName_maybe break_span + StepOut Nothing -> True + StepOut (Just start) -> + -- See Note [Debugger: Filtering step-out stops] + not (break_span `isSubspanOf` start) + +{- +Note [Debugger: Filtering step-out stops] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall from Note [Debugger: Step-out] that the RTS explicitly enables the +breakpoint at the start of the first continuation frame on the stack, when +the step-out flag is set. + +Often, the continuation on top of the stack will be part of the same function +from which step-out was initiated. A trivial example is a case expression: + + f x = case g x of ... + +If we're stopped in , the continuation will be in the case alternatives rather +than in the function which called `f`. This is especially relevant for monadic +do-blocks which may end up being compiled to long chains of case expressions, +such as IO, and we don't want to stop at every line in the block while stepping out! + +To make sure we only stop at a continuation outside of the current function, we +compare the continuation breakpoint `SrcSpan` against the current one. If the +continuation breakpoint is within the current function, instead of stopping, we +re-trigger step-out and return to the RTS interpreter right away. + +This behaviour is very similar to `:steplocal`, which is implemented by +yielding from the RTS at every breakpoint (using `:step`) but only really +stopping when the breakpoint's `SrcSpan` is contained in the current function. + +The function which determines if we should stop at the current breakpoint is +`breakHere`. For `StepOut`, `breakHere` will only return `True` if the +breakpoint is not contained in the function from which step-out was initiated. + +Notably, this means we will ignore breakpoints enabled by the user if they are +contained in the function we are stepping out of. + +If we had a way to distinguish whether a breakpoint was explicitly enabled (in +`BreakArrays`) by the user vs by step-out we could additionally break on +user-enabled breakpoints; however, it's not straightforward to determine this +and arguably it may be uncommon for a user to use step-out to run until the +next breakpoint in the same function. Of course, if a breakpoint in any other +function is hit before returning to the continuation, we will still stop there +(`breakHere` will be `True` because the break point is not within the initiator +function). +-} + +data ExecResult + + -- | Execution is complete with either an exception or the list of + -- user-visible names that were brought into scope. + = ExecComplete + { execResult :: Either SomeException [Name] + , execAllocation :: Word64 + } + + -- | Execution stopped at a breakpoint. + -- + -- Note: `ExecBreak` is only returned by `handleRunStatus` when GHCi should + -- definitely stop at this breakpoint. GHCi is /not/ responsible for + -- subsequently deciding whether to really stop here. + -- `ExecBreak` always means GHCi breaks. + | ExecBreak + { breakNames :: [Name] + , breakPointId :: Maybe InternalBreakpointId + } + +-- | Essentially a GlobalRdrEnv, but with additional cached values to allow +-- efficient re-calculation when the imports change. +-- Fields are strict to avoid space leaks (see T4029) +-- All operations are in GHC.Runtime.Context. +-- See Note [icReaderEnv recalculation] +data IcGlobalRdrEnv = IcGlobalRdrEnv + { igre_env :: !GlobalRdrEnv + -- ^ The final environment + , igre_prompt_env :: !GlobalRdrEnv + -- ^ Just the things defined at the prompt (excluding imports!) + } + +data Resume = Resume + { resumeStmt :: String -- the original statement + , resumeContext :: ForeignRef (ResumeContext [HValueRef]) + , resumeBindings :: ResumeBindings + , resumeFinalIds :: [Id] -- [Id] to bind on completion + , resumeApStack :: ForeignHValue -- The object from which we can get + -- value of the free variables. + , resumeBreakpointId :: Maybe InternalBreakpointId + -- ^ the internal breakpoint we stopped at + -- (Nothing <=> exception) + , resumeSpan :: SrcSpan -- just a copy of the SrcSpan + -- from the ModBreaks, + -- otherwise it's a pain to + -- fetch the ModDetails & + -- ModBreaks to get this. + , resumeDecl :: String -- ditto + , resumeCCS :: RemotePtr CostCentreStack + , resumeHistory :: [History] + , resumeHistoryIx :: Int -- 0 <==> at the top of the history + } + +type ResumeBindings = ([TyThing], IcGlobalRdrEnv) + +data History = History + { historyApStack :: ForeignHValue + , historyBreakpointId :: InternalBreakpointId -- ^ breakpoint identifier + , historyEnclosingDecls :: [String] -- ^ declarations enclosing the breakpoint + } diff --git a/GHC/Runtime/Eval/Utils.hs b/GHC/Runtime/Eval/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Eval/Utils.hs @@ -0,0 +1,48 @@ +module GHC.Runtime.Eval.Utils where + +import GHC.Prelude +import Data.Char +import Data.List (elemIndices) + +-- | Split up a string with an eventually qualified declaration name into 3 components +-- +-- 1. module name +-- 2. top-level decl +-- 3. full-name of the eventually nested decl, but without module qualification +-- +-- === __Example__ +-- +-- @ +-- "foo" = ("", "foo", "foo") +-- "A.B.C.foo" = ("A.B.C", "foo", "foo") +-- "M.N.foo.bar" = ("M.N", "foo", "foo.bar") +-- @ +splitIdent :: String -> (String, String, String) +splitIdent [] = ("", "", "") +splitIdent inp@(a : _) + | (isUpper a) = case fixs of + [] -> (inp, "", "") + (i1 : [] ) -> (upto i1, from i1, from i1) + (i1 : i2 : _) -> (upto i1, take (i2 - i1 - 1) (from i1), from i1) + | otherwise = case ixs of + [] -> ("", inp, inp) + (i1 : _) -> ("", upto i1, inp) + where + ixs = elemIndices '.' inp -- indices of '.' in whole input + fixs = dropWhile isNextUc ixs -- indices of '.' in function names -- + isNextUc ix = isUpper $ safeInp !! (ix+1) + safeInp = inp ++ " " + upto i = take i inp + from i = drop (i + 1) inp + +-- | Qualify an identifier name with a module name +-- +-- @ +-- combineModIdent "A" "foo" = "A.foo" +-- combineModIdent "" "foo" = "foo" +-- @ +combineModIdent :: String -> String -> String +combineModIdent mod ident + | null mod = ident + | null ident = mod + | otherwise = mod ++ "." ++ ident diff --git a/GHC/Runtime/Heap/Inspect.hs b/GHC/Runtime/Heap/Inspect.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Heap/Inspect.hs @@ -0,0 +1,1476 @@ +{-# LANGUAGE MagicHash #-} + +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ > 912 +{-# OPTIONS_GHC -Wwarn=incomplete-record-selectors #-} +-- This module has a bunch of uses of incomplete record selectors +-- and it is FAR from obvious that they won't cause crashes. +-- But I don't want them to kill CI, so the above flag turns +-- them into warnings +#endif + + +----------------------------------------------------------------------------- +-- +-- GHC Interactive support for inspecting arbitrary closures at runtime +-- +-- Pepe Iborra (supported by Google SoC) 2006 +-- +----------------------------------------------------------------------------- +module GHC.Runtime.Heap.Inspect( + -- * Entry points and types + cvObtainTerm, + cvReconstructType, + improveRTTIType, + Term(..), + + -- * Utils + isFullyEvaluatedTerm, + termType, mapTermType, termTyCoVars, + foldTerm, TermFold(..), + cPprTerm, cPprTermBase, + + constrClosToName -- exported to use in test T4891 + ) where + +import GHC.Prelude hiding (head, init, last, tail) +import GHC.Platform + +import GHC.Runtime.Interpreter as GHCi +import GHCi.RemoteTypes +import GHC.Driver.Env +import GHCi.Message ( fromSerializableException ) + +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped ) +import GHC.Types.RepType +import GHC.Core.Multiplicity +import qualified GHC.Core.Unify as U +import GHC.Core.TyCon + +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Zonk.Type +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Env +import GHC.Tc.Zonk.TcType + +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Name.Occurrence as OccName +import GHC.Unit.Module +import GHC.Iface.Env +import GHC.Utils.Misc +import GHC.Types.Var.Set +import GHC.Types.Basic ( Boxity(..) ) +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Driver.DynFlags +import GHC.Driver.Ppr +import GHC.Utils.Outputable as Ppr +import GHC.Utils.Panic +import GHC.Char +import GHC.Exts.Heap +import GHC.Runtime.Heap.Layout ( roundUpTo ) +import GHC.IO (throwIO) + +import Control.Monad +import Data.Maybe +import Data.List ((\\)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import GHC.Exts +import qualified Data.Sequence as Seq +import Data.Sequence (viewl, ViewL(..)) +import Foreign hiding (shiftL, shiftR) +import System.IO.Unsafe +import GHC.InfoProv + +--------------------------------------------- +-- * A representation of semi evaluated Terms +--------------------------------------------- + +data Term = Term { ty :: RttiType + , dc :: Either String DataCon + -- Carries a text representation if the datacon is + -- not exported by the .hi file, which is the case + -- for private constructors in -O0 compiled libraries + , val :: ForeignHValue + , subTerms :: [Term] } + + | Prim { ty :: RttiType + , valRaw :: [Word] } + + | Suspension { ctype :: ClosureType + , ty :: RttiType + , val :: ForeignHValue + , bound_to :: Maybe Name -- Useful for printing + , infoprov :: Maybe InfoProv -- Provenance is printed when available + } + | NewtypeWrap{ -- At runtime there are no newtypes, and hence no + -- newtype constructors. A NewtypeWrap is just a + -- made-up tag saying "heads up, there used to be + -- a newtype constructor here". + ty :: RttiType + , dc :: Either String DataCon + , wrapped_term :: Term } + | RefWrap { -- The contents of a reference + ty :: RttiType + , wrapped_term :: Term } + +termType :: Term -> RttiType +termType t = ty t + +isFullyEvaluatedTerm :: Term -> Bool +isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt +isFullyEvaluatedTerm Prim {} = True +isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t +isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t +isFullyEvaluatedTerm _ = False + +-- | Gives an error if the term doesn't have subterms +expectSubTerms :: Term -> [Term] +expectSubTerms (Term { subTerms = subTerms} ) = subTerms +expectSubTerms _ = panic "expectSubTerms" + +instance Outputable (Term) where + ppr t | Just doc <- cPprTerm cPprTermBase t = doc + | otherwise = panic "Outputable Term instance" + +---------------------------------------- +-- Runtime Closure information functions +---------------------------------------- + +isThunk :: GenClosure a -> Bool +isThunk ThunkClosure{} = True +isThunk APClosure{} = True +isThunk APStackClosure{} = True +isThunk _ = False + +-- Lookup the name in a constructor closure +constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name) +constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do + let occName = mkOccName OccName.dataName occ + modName = mkModule (stringToUnit pkg) (mkModuleName mod) + Right `fmap` lookupNameCache (hsc_NC hsc_env) modName occName +constrClosToName _hsc_env clos = + return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos))) + +----------------------------------- +-- * Traversals for Terms +----------------------------------- +type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b + +data TermFold a = TermFold { fTerm :: TermProcessor a a + , fPrim :: RttiType -> [Word] -> a + , fSuspension :: ClosureType -> RttiType -> ForeignHValue + -> Maybe Name -> Maybe InfoProv -> a + , fNewtypeWrap :: RttiType -> Either String DataCon + -> a -> a + , fRefWrap :: RttiType -> a -> a + } + + +data TermFoldM m a = + TermFoldM {fTermM :: TermProcessor a (m a) + , fPrimM :: RttiType -> [Word] -> m a + , fSuspensionM :: ClosureType -> RttiType -> ForeignHValue + -> Maybe Name -> Maybe InfoProv -> m a + , fNewtypeWrapM :: RttiType -> Either String DataCon + -> a -> m a + , fRefWrapM :: RttiType -> a -> m a + } + +foldTerm :: TermFold a -> Term -> a +foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt) +foldTerm tf (Prim ty v ) = fPrim tf ty v +foldTerm tf (Suspension ct ty v b i) = fSuspension tf ct ty v b i +foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t) +foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t) + + +foldTermM :: Monad m => TermFoldM m a -> Term -> m a +foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v +foldTermM tf (Prim ty v ) = fPrimM tf ty v +foldTermM tf (Suspension ct ty v b i) = fSuspensionM tf ct ty v b i +foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc +foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty + +idTermFold :: TermFold Term +idTermFold = TermFold { + fTerm = Term, + fPrim = Prim, + fSuspension = Suspension, + fNewtypeWrap = NewtypeWrap, + fRefWrap = RefWrap + } + +mapTermType :: (RttiType -> Type) -> Term -> Term +mapTermType f = foldTerm idTermFold { + fTerm = \ty dc hval tt -> Term (f ty) dc hval tt, + fSuspension = \ct ty hval n i -> + Suspension ct (f ty) hval n i, + fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t, + fRefWrap = \ty t -> RefWrap (f ty) t} + +mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term +mapTermTypeM f = foldTermM TermFoldM { + fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt, + fPrimM = (return.) . Prim, + fSuspensionM = \ct ty hval n i -> + f ty >>= \ty' -> return $ Suspension ct ty' hval n i, + fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t, + fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t} + +termTyCoVars :: Term -> TyCoVarSet +termTyCoVars = foldTerm TermFold { + fTerm = \ty _ _ tt -> + tyCoVarsOfType ty `unionVarSet` concatVarEnv tt, + fSuspension = \_ ty _ _ _ -> tyCoVarsOfType ty, + fPrim = \ _ _ -> emptyVarSet, + fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t, + fRefWrap = \ty t -> tyCoVarsOfType ty `unionVarSet` t} + where concatVarEnv = foldr unionVarSet emptyVarSet + +---------------------------------- +-- Pretty printing of terms +---------------------------------- + +type Precedence = Int +type TermPrinterM m = Precedence -> Term -> m SDoc + +app_prec,cons_prec, max_prec ::Int +max_prec = 10 +app_prec = max_prec +cons_prec = 5 -- TODO Extract this info from GHC itself + +pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m +pprTermM y p t = pprDeeper `liftM` ppr_termM y p t + +ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do + tt_docs <- mapM (y app_prec) tt + return $ cparen (not (null tt) && p >= app_prec) + (text dc_tag <+> pprDeeperList fsep tt_docs) + +ppr_termM y p Term{dc=Right dc, subTerms=tt} +{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity + = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) + <+> hsep (map (ppr_term1 True) tt) +-} -- TODO Printing infix constructors properly + = do { tt_docs' <- mapM (y app_prec) tt + ; return $ ifPprDebug (show_tm tt_docs') + (show_tm (dropList (dataConTheta dc) tt_docs')) + -- Don't show the dictionary arguments to + -- constructors unless -dppr-debug is on + } + where + show_tm tt_docs + | null tt_docs = ppr dc + | otherwise = cparen (p >= app_prec) $ + sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] + +ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t +ppr_termM y p RefWrap{wrapped_term=t} = do + contents <- y app_prec t + return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents) + -- The constructor name is wired in here ^^^ for the sake of simplicity. + -- I don't think mutvars are going to change in a near future. + -- In any case this is solely a presentation matter: MutVar# is + -- a datatype with no constructors, implemented by the RTS + -- (hence there is no way to obtain a datacon and print it). +ppr_termM _ _ t = ppr_termM1 t + + +ppr_termM1 :: Monad m => Term -> m SDoc +ppr_termM1 Prim{valRaw=words, ty=ty} = + return $ repPrim (tyConAppTyCon ty) words +ppr_termM1 Suspension{ty=ty, bound_to=Nothing, infoprov=mipe} = + return $ hcat $ +    [ char '_' +    , whenPprDebug $ + space <> + dcolon <> + pprSigmaType ty +    ] ++ +    [ whenPprDebug $ + space <> + char '<' <> + text (ipSrcFile ipe) <> + char ':' <> + text (ipSrcSpan ipe) <> + char '>' +    | Just ipe <- [mipe] + , not $ null $ ipSrcFile ipe +    ] +ppr_termM1 Suspension{ty=ty, bound_to=Just n} + | otherwise = return$ parens$ ppr n <> dcolon <> pprSigmaType ty +ppr_termM1 Term{} = panic "ppr_termM1 - Term" +ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap" +ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap" + +pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} + | Just (tc,_) <- tcSplitTyConApp_maybe ty + , assert (isNewTyCon tc) True + , Just new_dc <- tyConSingleDataCon_maybe tc = do + real_term <- y max_prec t + return $ cparen (p >= app_prec) (ppr new_dc <+> real_term) +pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" + +------------------------------------------------------- +-- Custom Term Pretty Printers +------------------------------------------------------- + +-- We can want to customize the representation of a +-- term depending on its type. +-- However, note that custom printers have to work with +-- type representations, instead of directly with types. +-- We cannot use type classes here, unless we employ some +-- typerep trickery (e.g. Weirich's RepLib tricks), +-- which I didn't. Therefore, this code replicates a lot +-- of what type classes provide for free. + +type CustomTermPrinter m = TermPrinterM m + -> [Precedence -> Term -> (m (Maybe SDoc))] + +-- | Takes a list of custom printers with a explicit recursion knot and a term, +-- and returns the output of the first successful printer, or the default printer +cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc +cPprTerm printers_ = go 0 where + printers = printers_ go + go prec t = do + let default_ = Just `liftM` pprTermM go prec t + mb_customDocs = [pp prec t | pp <- printers] ++ [default_] + mdoc <- firstJustM mb_customDocs + case mdoc of + Nothing -> panic "cPprTerm" + Just doc -> return $ cparen (prec>app_prec+1) doc + + firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just) + firstJustM [] = return Nothing + +-- Default set of custom printers. Note that the recursion knot is explicit +cPprTermBase :: forall m. Monad m => CustomTermPrinter m +cPprTermBase y = + [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) + . mapM (y (-1)) + . expectSubTerms) + , ifTerm (\t -> isTyCon listTyCon (ty t) && expectSubTerms t `lengthIs` 2) + ppr_list + , ifTerm' (isTyCon intTyCon . ty) ppr_int + , ifTerm' (isTyCon charTyCon . ty) ppr_char + , ifTerm' (isTyCon floatTyCon . ty) ppr_float + , ifTerm' (isTyCon doubleTyCon . ty) ppr_double + , ifTerm' (isTyCon integerTyCon . ty) ppr_integer + , ifTerm' (isTyCon naturalTyCon . ty) ppr_natural + ] + where + ifTerm :: (Term -> Bool) + -> (Precedence -> Term -> m SDoc) + -> Precedence -> Term -> m (Maybe SDoc) + ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t) + + ifTerm' :: (Term -> Bool) + -> (Precedence -> Term -> m (Maybe SDoc)) + -> Precedence -> Term -> m (Maybe SDoc) + ifTerm' pred f prec t@Term{} + | pred t = f prec t + ifTerm' _ _ _ _ = return Nothing + + isTupleTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (isBoxedTupleTyCon tc) + + isTyCon a_tc ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (a_tc == tc) + + ppr_int, ppr_char, ppr_float, ppr_double + :: Precedence -> Term -> m (Maybe SDoc) + ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} = + return (Just (Ppr.int (fromIntegral w))) + ppr_int _ _ = return Nothing + + ppr_char _ Term{subTerms=[Prim{valRaw=[w]}]} = + return (Just (Ppr.pprHsChar (chr (fromIntegral w)))) + ppr_char _ _ = return Nothing + + ppr_float _ Term{subTerms=[Prim{valRaw=[w]}]} = do + let f = unsafeDupablePerformIO $ + alloca $ \p -> poke p w >> peek (castPtr p) + return (Just (Ppr.float f)) + ppr_float _ _ = return Nothing + + ppr_double _ Term{subTerms=[Prim{valRaw=[w]}]} = do + let f = unsafeDupablePerformIO $ + alloca $ \p -> poke p w >> peek (castPtr p) + return (Just (Ppr.double f)) + -- let's assume that if we get two words, we're on a 32-bit + -- machine. There's no good way to get a Platform to check the word + -- size here. + ppr_double _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do + let f = unsafeDupablePerformIO $ + alloca $ \p -> do + poke p (fromIntegral w1 :: Word32) + poke (p `plusPtr` 4) (fromIntegral w2 :: Word32) + peek (castPtr p) + return (Just (Ppr.double f)) + ppr_double _ _ = return Nothing + + ppr_bignat :: Bool -> Precedence -> [Word] -> m (Maybe SDoc) + ppr_bignat sign _ ws = do + let + wordSize = finiteBitSize (0 :: Word) -- does the word size depend on the target? + makeInteger n _ [] = n + makeInteger n s (x:xs) = makeInteger (n + (fromIntegral x `shiftL` s)) (s + wordSize) xs + signf = case sign of + False -> 1 + True -> -1 + return $ Just $ Ppr.integer $ signf * (makeInteger 0 0 ws) + + -- Reconstructing Bignums is a bit of a pain. This depends deeply on their + -- representation, so it'll break if that changes (but there are several + -- tests in tests/ghci.debugger/scripts that will tell us if this is wrong). + -- + -- data Integer + -- = IS !Int# + -- | IP !BigNat + -- | IN !BigNat + -- + -- data Natural + -- = NS !Word# + -- | NB !BigNat + -- + -- type BigNat = ByteArray# + + ppr_integer :: Precedence -> Term -> m (Maybe SDoc) + ppr_integer _ Term{dc=Right con, subTerms=[Prim{valRaw=ws}]} + | con == integerISDataCon + , [W# w] <- ws + = return (Just (Ppr.integer (fromIntegral (I# (word2Int# w))))) + ppr_integer p Term{dc=Right con, subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} + | con == integerIPDataCon = ppr_bignat False p ws + | con == integerINDataCon = ppr_bignat True p ws + | otherwise = panic "Unexpected Integer constructor" + ppr_integer _ _ = return Nothing + + ppr_natural :: Precedence -> Term -> m (Maybe SDoc) + ppr_natural _ Term{dc=Right con, subTerms=[Prim{valRaw=ws}]} + | con == naturalNSDataCon + , [w] <- ws + = return (Just (Ppr.integer (fromIntegral w))) + ppr_natural p Term{dc=Right con, subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} + | con == naturalNBDataCon = ppr_bignat False p ws + | otherwise = panic "Unexpected Natural constructor" + ppr_natural _ _ = return Nothing + + --Note pprinting of list terms is not lazy + ppr_list :: Precedence -> Term -> m SDoc + ppr_list p (Term{subTerms=[h,t]}) = do + let elems = h :| getListTerms t + elemList = toList elems + isConsLast = not (termType (NE.last elems) `eqType` termType h) + is_string = all (isCharTy . ty) elems + chars = [ chr (fromIntegral w) + | Term{subTerms=[Prim{valRaw=[w]}]} <- elemList ] + + print_elems <- mapM (y cons_prec) elemList + if is_string + then return (Ppr.doubleQuotes (Ppr.text chars)) + else if isConsLast + then return $ cparen (p >= cons_prec) + $ pprDeeperList fsep + $ punctuate (space<>colon) print_elems + else return $ brackets + $ pprDeeperList fcat + $ punctuate comma print_elems + + where getListTerms Term{subTerms=[h,t]} = h : getListTerms t + getListTerms Term{subTerms=[]} = [] + getListTerms t@Suspension{} = [t] + getListTerms t = pprPanic "getListTerms" (ppr t) + ppr_list _ _ = panic "doList" + + +repPrim :: TyCon -> [Word] -> SDoc +repPrim t = rep where + rep x + -- Char# uses native machine words, whereas Char's Storable instance uses + -- Int32, so we have to read it as an Int. + | t == charPrimTyCon = text $ show (chr (build x :: Int)) + | t == intPrimTyCon = text $ show (build x :: Int) + | t == wordPrimTyCon = text $ show (build x :: Word) + | t == floatPrimTyCon = text $ show (build x :: Float) + | t == doublePrimTyCon = text $ show (build x :: Double) + | t == int8PrimTyCon = text $ show (build x :: Int8) + | t == word8PrimTyCon = text $ show (build x :: Word8) + | t == int16PrimTyCon = text $ show (build x :: Int16) + | t == word16PrimTyCon = text $ show (build x :: Word16) + | t == int32PrimTyCon = text $ show (build x :: Int32) + | t == word32PrimTyCon = text $ show (build x :: Word32) + | t == int64PrimTyCon = text $ show (build x :: Int64) + | t == word64PrimTyCon = text $ show (build x :: Word64) + | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x) + | otherwise = char '<' <> ppr t <> char '>' + where build ww = unsafePerformIO $ withArray ww (peek . castPtr) +-- This ^^^ relies on the representation of Haskell heap values being +-- the same as in a C array. + +----------------------------------- +-- Type Reconstruction +----------------------------------- +{- +Type Reconstruction is type inference done on heap closures. +The algorithm walks the heap generating a set of equations, which +are solved with syntactic unification. +A type reconstruction equation looks like: + + = + +The full equation set is generated by traversing all the subterms, starting +from a given term. + +The only difficult part is that newtypes are only found in the lhs of equations. +Right hand sides are missing them. We can either (a) drop them from the lhs, or +(b) reconstruct them in the rhs when possible. + +The function congruenceNewtypes takes a shot at (b) +-} + + +-- See Note [RttiType] +type RttiType = Type + +-- An incomplete type as stored in GHCi: +-- no polymorphism: no quantifiers & all tyvars are skolem. +type GhciType = Type + + +-- The Type Reconstruction monad +-------------------------------- +type TR a = TcM a + +runTR :: HscEnv -> TR a -> IO a +runTR hsc_env thing = do + mb_val <- runTR_maybe hsc_env thing + case mb_val of + Nothing -> error "unable to :print the term" + Just x -> return x + +runTR_maybe :: HscEnv -> TR a -> IO (Maybe a) +runTR_maybe hsc_env thing_inside + = do { (_errs, res) <- initTcInteractive hsc_env thing_inside + ; return res } + +-- | Term Reconstruction trace +traceTR :: SDoc -> TR () +traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti + + +-- Semantically different to recoverM in GHC.Tc.Utils.Monad +-- recoverM retains the errors in the first action, +-- whereas recoverTc here does not +recoverTR :: TR a -> TR a -> TR a +recoverTR = tryTcDiscardingErrs + +trIO :: IO a -> TR a +trIO = liftTcM . liftIO + +liftTcM :: TcM a -> TR a +liftTcM = id + +-- When we make new unification variables in the GHCi debugger, +-- we use RuntimeUnkTvs. See Note [RuntimeUnkTv]. +newVar :: Kind -> TR TcType +newVar kind = liftTcM (do { tv <- newAnonMetaTyVar RuntimeUnkTv kind + ; return (mkTyVarTy tv) }) + +newOpenVar :: TR TcType +newOpenVar = liftTcM (do { kind <- newOpenTypeKind + ; newVar kind }) + +{- Note [RttiType] +~~~~~~~~~~~~~~~~~~ +The type synonym `type RttiType = Type` is the type synonym used +by the debugger for the types of the data type `Term`. + +For a long time the `RttiType` carried the following comment: + +> A (non-mutable) tau type containing +> existentially quantified tyvars. +> (since GHC type language currently does not support +> existentials, we leave these variables unquantified) + +The tau type part is only correct for terms representing the results +of fully saturated functions that return non-function (data) values +and not functions. + +For non-function values, the GHC runtime always works with concrete +types eg `[Maybe Int]`, but never with polymorphic types like eg +`(Traversable t, Monad m) => t (m a)`. The concrete types, don't +need a quantification. They are always tau types. + +The debugger binds the terms of :print commands and of the free +variables at a breakpoint to names. These newly bound names can +be used in new GHCi expressions. If these names represent functions, +then the type checker expects that the types of these functions are +fully-fledged. They must contain the necessary `forall`s and type +constraints. Hence the types of terms that represent functions must +be sigmas and not taus. +(See #12449) +-} + +{- Note [RuntimeUnkTv] +~~~~~~~~~~~~~~~~~~~~~~ +In the GHCi debugger we use unification variables whose MetaInfo is +RuntimeUnkTv. The special property of a RuntimeUnkTv is that it can +unify with a polytype (see GHC.Tc.Utils.Unify.checkTypeEq). +If we don't do this `:print ` will fail if the type of +has nested `forall`s or `=>`s. + +This is because the GHCi debugger's internals will attempt to unify a +metavariable with the type of and then display the result, but +if the type has nested `forall`s or `=>`s, then unification will fail +unless we do something special. As a result, `:print` will bail out +and the unhelpful result will be ` = (_t1::t1)` (where `t1` is a +metavariable). + +Beware: can have nested `forall`s even if its definition doesn't use +RankNTypes! Here is an example from #14828: + + class Functor f where + fmap :: (a -> b) -> f a -> f b + +Somewhat surprisingly, `:print fmap` considers the type of fmap to have +nested foralls. This is because the GHCi debugger sees the type +`fmap :: forall f. Functor f => forall a b. (a -> b) -> f a -> f b`. +We could envision deeply instantiating this type to get the type +`forall f a b. Functor f => (a -> b) -> f a -> f b`, +but this trick wouldn't work for higher-rank types. + +Instead, we adopt a simpler fix: allow RuntimeUnkTv to unify with a +polytype (specifically, see ghci_tv in GHC.Tc.Utils.Unify.preCheck). +This allows metavariables to unify with types that have +nested (or higher-rank) `forall`s/`=>`s, which makes `:print fmap` +display as +`fmap = (_t1::forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b)`, +as expected. +-} + + +instTyVars :: [TyVar] -> TR (Subst, [TcTyVar]) +-- Instantiate fresh mutable type variables from some TyVars +-- This function preserves the print-name, which helps error messages +instTyVars tvs + = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs) + +type RttiInstantiation = [(TcTyVar, TyVar)] + -- Associates the typechecker-world meta type variables + -- (which are mutable and may be refined), to their + -- debugger-world RuntimeUnk counterparts. + -- If the TcTyVar has not been refined by the runtime type + -- elaboration, then we want to turn it back into the + -- original RuntimeUnk + -- + -- July 20: I'm not convinced that the little dance from + -- RuntimeUnkTv unification variables to RuntimeUnk skolems + -- is buying us anything. ToDo: get rid of it. + +-- | Returns the instantiated type scheme ty', and the +-- mapping from new (instantiated) -to- old (skolem) type variables +instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation) +instScheme (tvs, ty) + = do { (subst, tvs') <- instTyVars tvs + ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] + ; traceTR (text "instScheme" <+> (ppr tvs $$ ppr ty $$ ppr tvs')) + ; return (substTy subst ty, rtti_inst) } + +applyRevSubst :: RttiInstantiation -> TR () +-- Apply the *reverse* substitution in-place to any un-filled-in +-- meta tyvars. This recovers the original debugger-world variable +-- unless it has been refined by new information from the heap +applyRevSubst pairs = liftTcM (liftZonkM $ mapM_ do_pair pairs) + where + do_pair (tc_tv, rtti_tv) + = do { tc_ty <- zonkTcTyVar tc_tv + ; case getTyVar_maybe tc_ty of + Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv) + _ -> return () } + +-- Adds a constraint of the form t1 == t2 +-- t1 is expected to come from walking the heap +-- t2 is expected to come from a datacon signature +-- Before unification, congruenceNewtypes needs to +-- do its magic. +addConstraint :: TcType -> TcType -> TR () +addConstraint actual expected = do + traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected]) + recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual, + text "with", ppr expected]) $ + discardResult $ + captureConstraints $ + do { (ty1, ty2) <- congruenceNewtypes actual expected + ; unifyType Nothing ty1 ty2 } + -- TOMDO: what about the coercion? + -- we should consider family instances + + +-- | Term reconstruction +-- +-- Given a pointer to a heap object (`HValue`) and its type, build a `Term` +-- representation of the object. Subterms (objects in the payload) are also +-- built up to the given `max_depth`. After `max_depth` any subterms will appear +-- as `Suspension`s. Any thunks found while traversing the object will be forced +-- based on `force` parameter. +-- +-- Types of terms will be refined based on constructors we find during term +-- reconstruction. See `cvReconstructType` for an overview of how type +-- reconstruction works. +-- +cvObtainTerm + :: HscEnv + -> Int -- ^ How many times to recurse for subterms + -> Bool -- ^ Force thunks + -> RttiType -- ^ Type of the object to reconstruct + -> ForeignHValue -- ^ Object to reconstruct + -> IO Term +cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do + -- we quantify existential tyvars as universal, + -- as this is needed to be able to manipulate + -- them properly + let quant_old_ty@(old_tvs, _) = quantifyType old_ty + traceTR (text "Term reconstruction started with initial type " <> ppr old_ty) + term <- + if null old_tvs + then do + term <- go max_depth old_ty old_ty hval + term' <- zonkTerm term + return $ fixFunDictionaries $ expandNewtypes term' + else do + (old_ty', rev_subst) <- instScheme quant_old_ty + my_ty <- newOpenVar + when (check1 old_tvs) (traceTR (text "check1 passed") >> + addConstraint my_ty old_ty') + term <- go max_depth my_ty old_ty hval + new_ty <- liftTcM $ liftZonkM $ zonkTcType (termType term) + if isMonomorphic new_ty || check2 new_ty old_ty + then do + traceTR (text "check2 passed") + addConstraint new_ty old_ty' + applyRevSubst rev_subst + zterm' <- zonkTerm term + return ((fixFunDictionaries . expandNewtypes) zterm') + else do + traceTR (text "check2 failed" <+> parens + (ppr term <+> text "::" <+> ppr new_ty)) + -- we have unsound types. Replace constructor types in + -- subterms with tyvars + zterm' <- mapTermTypeM + (\ty -> case splitTyConApp_maybe ty of + -- SPJ: I have no idea why we are + -- matching on (:) here, nor + -- what the isFunTy is for + Just (_tc, _ : _) | not (isFunTy ty) + -> newOpenVar + _ -> return ty) + term + zonkTerm zterm' + traceTR (text "Term reconstruction completed." $$ + text "Term obtained: " <> ppr term $$ + text "Type obtained: " <> ppr (termType term)) + return term + where + interp = hscInterp hsc_env + unit_env = hsc_unit_env hsc_env + + go :: Int -> Type -> Type -> ForeignHValue -> TcM Term + -- [SPJ May 11] I don't understand the difference between my_ty and old_ty + + go 0 my_ty _old_ty a = do + traceTR (text "Gave up reconstructing a term after" <> + int max_depth <> text " steps") + clos <- trIO $ GHCi.getClosure interp a + ipe <- trIO $ GHCi.whereFrom interp a +#if MIN_VERSION_ghc_heap(9,15,0) + return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing ipe) +#else + return (Suspension (tipe (info clos)) my_ty a Nothing ipe) +#endif + go !max_depth my_ty old_ty a = do + let monomorphic = not(isTyVarTy my_ty) + -- This ^^^ is a convention. The ancestor tests for + -- monomorphism and passes a type instead of a tv + clos <- trIO $ GHCi.getClosure interp a + ipe <- trIO $ GHCi.whereFrom interp a + case clos of +-- Thunks we may want to force + t | isThunk t && force -> do + traceTR (text "Forcing a " <> text (show (fmap (const ()) t))) + evalRslt <- liftIO $ GHCi.seqHValue interp unit_env a + case evalRslt of -- #2950 + EvalSuccess _ -> go (pred max_depth) my_ty old_ty a + EvalException ex -> do + -- Report the exception to the UI + traceTR $ text "Exception occurred:" <+> text (show ex) + liftIO $ throwIO $ fromSerializableException ex +-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If +-- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as +-- the suspension so that entering it in GHCi will enter the BLACKHOLE instead +-- of entering the TSO or BLOCKING_QUEUE (which leads to runtime panic). + BlackholeClosure{indirectee=ind} -> do + traceTR (text "Following a BLACKHOLE") + ind_clos <- trIO (GHCi.getClosure interp ind) + ind_ipe <- trIO (GHCi.whereFrom interp ind) + let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing ind_ipe) + case ind_clos of + -- TSO and BLOCKING_QUEUE cases + BlockingQueueClosure{} -> return_bh_value + OtherClosure info _ _ + | tipe info == TSO -> return_bh_value + UnsupportedClosure info + | tipe info == TSO -> return_bh_value + -- Otherwise follow the indirectee + -- (NOTE: This code will break if we support TSO in ghc-heap one day) + _ -> go max_depth my_ty old_ty ind +-- We always follow indirections + IndClosure{indirectee=ind} -> do + traceTR (text "Following an indirection" ) + go max_depth my_ty old_ty ind +-- We also follow references + MutVarClosure{var=contents} + | Just (tycon,[lev,world,contents_ty]) <- tcSplitTyConApp_maybe old_ty + -> do + -- Deal with the MutVar# primitive + -- It does not have a constructor at all, + -- so we simulate the following one + -- MutVar# :: contents_ty -> MutVar# s contents_ty + massert (tycon == mutVarPrimTyCon) + massert (isUnliftedType my_ty) + traceTR (text "Following a MutVar") + let contents_kind = mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev]) + contents_tv <- newVar contents_kind + (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTyMany + contents_ty (mkTyConApp tycon [lev, world,contents_ty]) + addConstraint (mkVisFunTyMany contents_tv my_ty) mutvar_ty + x <- go (pred max_depth) contents_tv contents_ty contents + return (RefWrap my_ty x) + + -- The interesting case + ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do + traceTR (text "entering a constructor " <> ppr dArgs <+> + if monomorphic + then parens (text "already monomorphic: " <> ppr my_ty) + else Ppr.empty) + Right dcname <- liftIO $ constrClosToName hsc_env clos + (mb_dc, _) <- tryTc (tcLookupDataCon dcname) + case mb_dc of + Nothing -> do -- This can happen for private constructors compiled -O0 + -- where the .hi descriptor does not export them + -- In such case, we return a best approximation: + -- ignore the unpointed args, and recover the pointed ones + -- This preserves laziness, and should be safe. + traceTR (text "Not constructor" <+> ppr dcname) + let dflags = hsc_dflags hsc_env + tag = showPpr dflags dcname + vars <- mapM (const (newVar liftedTypeKind)) pArgs + subTerms <- sequence $ zipWith (\x tv -> + go (pred max_depth) tv tv x) pArgs vars + return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) + Just dc -> do + traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty)) + subTtypes <- getDataConArgTys dc my_ty + subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) pArgs dArgs subTtypes + return (Term my_ty (Right dc) a subTerms) + + -- This is to support printing of Integers. It's not a general + -- mechanism by any means; in particular we lose the size in + -- bytes of the array. + ArrWordsClosure{bytes=b, arrWords=ws} -> do + traceTR (text "ByteArray# closure, size " <> ppr b) + return (Term my_ty (Left "ByteArray#") a [Prim my_ty ws]) + +-- The otherwise case: can be a Thunk,AP,PAP,etc. + _ -> do + traceTR (text "Unknown closure:" <+> + text (show (fmap (const ()) clos))) +#if MIN_VERSION_ghc_heap(9,15,0) + return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing ipe) +#else + return (Suspension (tipe (info clos)) my_ty a Nothing ipe) +#endif + -- insert NewtypeWraps around newtypes + expandNewtypes = foldTerm idTermFold { fTerm = worker } where + worker ty dc hval tt + | Just (tc, args) <- tcSplitTyConApp_maybe ty + , isNewTyCon tc + , wrapped_type <- newTyConInstRhs tc args + , Just dc' <- tyConSingleDataCon_maybe tc + , t' <- worker wrapped_type dc hval tt + = NewtypeWrap ty (Right dc') t' + | otherwise = Term ty dc hval tt + + + -- Avoid returning types where predicates have been expanded to dictionaries. + fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where + worker ct ty hval n i | isFunTy ty = Suspension ct (dictsView ty) hval n i + | otherwise = Suspension ct ty hval n i + +extractSubTerms :: (Type -> ForeignHValue -> TcM Term) + -> [ForeignHValue] -- ^ pointer arguments + -> [Word] -- ^ data arguments + -> [Type] + -> TcM [Term] +extractSubTerms recurse ptr_args data_args = liftM thdOf3 . go 0 0 + where + go ptr_i arr_i [] = return (ptr_i, arr_i, []) + go ptr_i arr_i (ty:tys) + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + = do (ptr_i, arr_i, terms0) <- + go ptr_i arr_i (dropRuntimeRepArgs elem_tys) + (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys + return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) + | otherwise + = case typePrimRep ty of + [rep_ty] -> do + (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty + (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys + return (ptr_i, arr_i, term0 : terms1) + rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys + (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys + return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) + + go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, []) + go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do + tv <- newVar liftedTypeKind + (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i tv rep_ty + (ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys + return (ptr_i, arr_i, term0 : terms1) + + go_rep ptr_i arr_i ty rep + | isGcPtrRep rep = do + t <- recurse ty $ ptr_args !! ptr_i + return (ptr_i + 1, arr_i, t) + | otherwise = do + -- This is a bit involved since we allow packing multiple fields + -- within a single word. See also + -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding + platform <- getPlatform + let word_size = platformWordSizeInBytes platform + endian = platformByteOrder platform + size_b = primRepSizeB platform rep + -- Align the start offset (eg, 2-byte value should be 2-byte + -- aligned). But not more than to a word. The offset calculation + -- should be the same with the offset calculation in + -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding. + !aligned_idx = roundUpTo arr_i (min word_size size_b) + !new_arr_i = aligned_idx + size_b + ws | size_b < word_size = + [index size_b aligned_idx word_size endian] + | otherwise = + let (q, r) = size_b `quotRem` word_size + in assert (r == 0 ) + [ data_args !! i + | o <- [0.. q - 1] + , let i = (aligned_idx `quot` word_size) + o + ] + return (ptr_i, new_arr_i, Prim ty ws) + + unboxedTupleTerm ty terms + = Term ty (Right (tupleDataCon Unboxed (length terms))) + (error "unboxedTupleTerm: no HValue for unboxed tuple") terms + + -- Extract a sub-word sized field from a word + -- A sub word is aligned to the left-most part of a word on big-endian + -- platforms, and to the right-most part of a word on little-endian + -- platforms. This allows to write and read it back from memory + -- independent of endianness. Bits not belonging to a sub word are zeroed + -- out, although, this is strictly speaking not necessary since a sub word + -- is read back from memory by appropriately casted pointers (see e.g. + -- ppr_float of cPprTermBase). + index size_b aligned_idx word_size endian = case endian of + BigEndian -> (word `shiftL` moveBits) `shiftR` zeroOutBits `shiftL` zeroOutBits + LittleEndian -> (word `shiftR` moveBits) `shiftL` zeroOutBits `shiftR` zeroOutBits + where + (q, r) = aligned_idx `quotRem` word_size + word = data_args !! q + moveBits = r * 8 + zeroOutBits = (word_size - size_b) * 8 + + +-- | Fast, breadth-first Type reconstruction +-- +-- Given a heap object (`HValue`) and its (possibly polymorphic) type (usually +-- obtained in GHCi), try to reconstruct a more monomorphic type of the object. +-- This is used for improving type information in debugger. For example, if we +-- have a polymorphic function: +-- +-- sumNumList :: Num a => [a] -> a +-- sumNumList [] = 0 +-- sumNumList (x : xs) = x + sumList xs +-- +-- and add a breakpoint to it: +-- +-- ghci> break sumNumList +-- ghci> sumNumList ([0 .. 9] :: [Int]) +-- +-- ghci shows us more precise types than just `a`s: +-- +-- Stopped in Main.sumNumList, debugger.hs:3:23-39 +-- _result :: Int = _ +-- x :: Int = 0 +-- xs :: [Int] = _ +-- +cvReconstructType + :: HscEnv + -> Int -- ^ How many times to recurse for subterms + -> GhciType -- ^ Type to refine + -> ForeignHValue -- ^ Refine the type using this value + -> IO (Maybe Type) +cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do + traceTR (text "RTTI started with initial type " <> ppr old_ty) + let sigma_old_ty@(old_tvs, _) = quantifyType old_ty + new_ty <- + if null old_tvs + then return old_ty + else do + (old_ty', rev_subst) <- instScheme sigma_old_ty + my_ty <- newOpenVar + when (check1 old_tvs) (traceTR (text "check1 passed") >> + addConstraint my_ty old_ty') + search (isMonomorphic `fmap` liftZonkM (zonkTcType my_ty)) + (\(ty,a) -> go ty a) + (Seq.singleton (my_ty, hval)) + max_depth + new_ty <- liftZonkM $ zonkTcType my_ty + if isMonomorphic new_ty || check2 new_ty old_ty + then do + traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty) + addConstraint my_ty old_ty' + applyRevSubst rev_subst + zonkRttiType new_ty + else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >> + return old_ty + traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty) + return new_ty + where + interp = hscInterp hsc_env + +-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m () + search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> + int max_depth <> text " steps") + search stop expand l d = + case viewl l of + EmptyL -> return () + x :< xx -> unlessM stop $ do + new <- expand x + search stop expand (xx `mappend` Seq.fromList new) $! (pred d) + + -- returns unification tasks,since we are going to want a breadth-first search + go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)] + go my_ty a = do + traceTR (text "go" <+> ppr my_ty) + clos <- trIO $ GHCi.getClosure interp a + case clos of + BlackholeClosure{indirectee=ind} -> go my_ty ind + IndClosure{indirectee=ind} -> go my_ty ind + MutVarClosure{var=contents} + | Just (_tycon,[lev,_world,_contents_ty]) <- tcSplitTyConApp_maybe my_ty + -> do + massert (_tycon == mutVarPrimTyCon) + tv' <- newVar $ mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev]) + world <- newVar liftedTypeKind + addConstraint my_ty $ mkMutVarPrimTy world tv' + return [(tv', contents)] + APClosure {payload=pLoad} -> do -- #19559 (incr) + mapM_ (go my_ty) pLoad + return [] + ConstrClosure{ptrArgs=pArgs} -> do + Right dcname <- liftIO $ constrClosToName hsc_env clos + traceTR (text "Constr1" <+> ppr dcname) + (mb_dc, _) <- tryTc (tcLookupDataCon dcname) + case mb_dc of + Nothing-> + forM pArgs $ \x -> do + tv <- newVar liftedTypeKind + return (tv, x) + + Just dc -> do + arg_tys <- getDataConArgTys dc my_ty + (_, itys) <- findPtrTyss 0 arg_tys + traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) + return $ zipWith (\(_,ty) x -> (ty, x)) itys pArgs + _ -> return [] + +findPtrTys :: Int -- Current pointer index + -> Type -- Type + -> TR (Int, [(Int, Type)]) +findPtrTys i ty + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + = findPtrTyss i elem_tys + + | otherwise + = case typePrimRep ty of + [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)]) + | otherwise -> return (i, []) + prim_reps -> + foldM (\(i, extras) prim_rep -> + if isGcPtrRep prim_rep + then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)]) + else return (i, extras)) + (i, []) prim_reps + +findPtrTyss :: Int + -> [Type] + -> TR (Int, [(Int, Type)]) +findPtrTyss i tys = foldM step (i, []) tys + where step (i, discovered) elem_ty = do + (i, extras) <- findPtrTys i elem_ty + return (i, discovered ++ extras) + + +-- Compute the difference between a base type and the type found by RTTI +-- improveType +-- The types can contain skolem type variables, which need to be treated as normal vars. +-- In particular, we want them to unify with things. +improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe Subst +improveRTTIType _ base_ty new_ty = U.tcUnifyDebugger base_ty new_ty + +getDataConArgTys :: DataCon -> Type -> TR [Type] +-- Given the result type ty of a constructor application (D a b c :: ty) +-- return the types of the arguments. This is RTTI-land, so 'ty' might +-- not be fully known. Moreover, the arg types might involve existentials; +-- if so, make up fresh RTTI type variables for them +getDataConArgTys dc con_app_ty + = do { let rep_con_app_ty = unwrapType con_app_ty + ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty + $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty))) + ; assert (all isTyVar ex_tvs ) return () + -- ex_tvs can only be tyvars as data types in source + -- Haskell cannot mention covar yet (Aug 2018) + ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs) + ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) + -- See Note [Constructor arg types] + ; let con_arg_tys = substTys subst (map scaledThing $ dataConRepArgTys dc) + ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst)) + ; return con_arg_tys } + where + univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyCoVars dc + +{- Note [Constructor arg types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a GADT (cf #7386) + data family D a b + data instance D [a] a where + MkT :: a -> D [a] (Maybe a) + ... + +In getDataConArgTys +* con_app_ty is the known type (from outside) of the constructor application, + say D [Int] Int + +* The data constructor MkT has a (representation) dataConTyCon = DList, + say where + data DList a where + MkT :: a -> DList a (Maybe a) + ... + +So the dataConTyCon of the data constructor, DList, differs from +the "outside" type, D. So we can't straightforwardly decompose the +"outside" type, and we end up in the "_" branch of the case. + +Then we match the dataConOrigResTy of the data constructor against the +outside type, hoping to get a substitution that tells how to instantiate +the *representation* type constructor. This looks a bit delicate to +me, but it seems to work. +-} + +-- Soundness checks +-------------------- +{- +This is not formalized anywhere, so hold to your seats! +RTTI in the presence of newtypes can be a tricky and unsound business. + +Example: +~~~~~~~~~ +Suppose we are doing RTTI for a partially evaluated +closure t, the real type of which is t :: MkT Int, for + + newtype MkT a = MkT [Maybe a] + +The table below shows the results of RTTI and the improvement +calculated for different combinations of evaluatedness and :type t. +Regard the two first columns as input and the next two as output. + + # | t | :type t | rtti(t) | improv. | result + ------------------------------------------------------------ + 1 | _ | t b | a | none | OK + 2 | _ | MkT b | a | none | OK + 3 | _ | t Int | a | none | OK + + If t is not evaluated at *all*, we are safe. + + 4 | (_ : _) | t b | [a] | t = [] | UNSOUND + 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype) + 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND + + If a is a minimal whnf, we run into trouble. Note that + row 5 above does newtype enrichment on the ty_rtty parameter. + + 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND + | | | b = Maybe a| + + 8 | (Just _:_)| MkT b | MkT a | none | OK + 9 | (Just _:_)| t Int | FAIL | none | OK + + And if t is any more evaluated than whnf, we are still in trouble. + Because constraints are solved in top-down order, when we reach the + Maybe subterm what we got is already unsound. This explains why the + row 9 fails to complete. + + 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK + 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK + + We can undo the failure in row 9 by leaving out the constraint + coming from the type signature of t (i.e., the 2nd column). + Note that this type information is still used + to calculate the improvement. But we fail + when trying to calculate the improvement, as there is no unifier for + t Int = [Maybe a] or t Int = [Maybe Int]. + + + Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]] + + # | t | :type t | rtti(t) | improvement | result + --------------------------------------------------------------------- + 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] | + | | | | b = Maybe a | + +The checks: +~~~~~~~~~~~ +Consider a function obtainType that takes a value and a type and produces +the Term representation and a substitution (the improvement). +Assume an auxiliary rtti' function which does the actual job if recovering +the type, but which may produce a false type. + +In pseudocode: + + rtti' :: a -> IO Type -- Does not use the static type information + + obtainType :: a -> Type -> IO (Maybe (Term, Improvement)) + obtainType v old_ty = do + rtti_ty <- rtti' v + if monomorphic rtti_ty || (check rtti_ty old_ty) + then ... + else return Nothing + where check rtti_ty old_ty = check1 rtti_ty && + check2 rtti_ty old_ty + + check1 :: Type -> Bool + check2 :: Type -> Type -> Bool + +Now, if rtti' returns a monomorphic type, we are safe. +If that is not the case, then we consider two conditions. + + +1. To prevent the class of unsoundness displayed by + rows 4 and 7 in the example: no higher kind tyvars + accepted. + + check1 (t a) = NO + check1 (t Int) = NO + check1 ([] a) = YES + +2. To prevent the class of unsoundness shown by row 6, + the rtti type should be structurally more + defined than the old type we are comparing it to. + check2 :: NewType -> OldType -> Bool + check2 a _ = True + check2 [a] a = True + check2 [a] (t Int) = False + check2 [a] (t a) = False -- By check1 we never reach this equation + check2 [Int] a = True + check2 [Int] (t Int) = True + check2 [Maybe a] (t Int) = False + check2 [Maybe Int] (t Int) = True + check2 (Maybe [a]) (m [Int]) = False + check2 (Maybe [Int]) (m [Int]) = True + +-} + +check1 :: [TyVar] -> Bool +check1 tvs = not $ any isHigherKind (map tyVarKind tvs) + where + isHigherKind = not . null . fst . splitPiTys + +check2 :: Type -> Type -> Bool +check2 rtti_ty old_ty = check2' (tauPart rtti_ty) (tauPart old_ty) + -- The function `tcSplitTyConApp_maybe` doesn't split foralls or types + -- headed with (=>). Hence here we need only the tau part of a type. + -- See Note [Missing test case]. + where + check2' rtti_ty old_ty + | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty + = case () of + _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty + -> and$ zipWith check2 rttis olds + _ | Just _ <- splitAppTy_maybe old_ty + -> isMonomorphicOnNonPhantomArgs rtti_ty + _ -> True + | otherwise = True + tauPart ty = tau + where + (_, _, tau) = tcSplitNestedSigmaTys ty +{- +Note [Missing test case] +~~~~~~~~~~~~~~~~~~~~~~~~ +Her we miss a test case. It should be a term, with a function `f` +with a non-empty sigma part and an unsound type. The result of +`check2 f` should be different if we omit or do the calls to `tauPart`. +I (R.Senn) was unable to find such a term, and I'm in doubt, whether it exists. +-} + +-- Dealing with newtypes +-------------------------- +{- + congruenceNewtypes does a parallel fold over two Type values, + compensating for missing newtypes on both sides. + This is necessary because newtypes are not present + in runtime, but sometimes there is evidence available. + Evidence can come from DataCon signatures or + from compile-time type inference. + What we are doing here is an approximation + of unification modulo a set of equations derived + from newtype definitions. These equations should be the + same as the equality coercions generated for newtypes + in System Fc. The idea is to perform a sort of rewriting, + taking those equations as rules, before launching unification. + + The caller must ensure the following. + The 1st type (lhs) comes from the heap structure of ptrs,nptrs. + The 2nd type (rhs) comes from a DataCon type signature. + Rewriting (i.e. adding/removing a newtype wrapper) can happen + in both types, but in the rhs it is restricted to the result type. + + Note that it is very tricky to make this 'rewriting' + work with the unification implemented by TcM, where + substitutions are operationally inlined. The order in which + constraints are unified is vital as we cannot modify + anything that has been touched by a previous unification step. +Therefore, congruenceNewtypes is sound only if the types +recovered by the RTTI mechanism are unified Top-Down. +-} +congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType) +congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') + where + go l r + -- TyVar lhs inductive case + | Just tv <- getTyVar_maybe l + , isTcTyVar tv + , isMetaTyVar tv + = recoverTR (return r) $ do + Indirect ty_v <- readMetaTyVar tv + traceTR $ fsep [text "(congruence) Following indirect tyvar:", + ppr tv, equals, ppr ty_v] + go ty_v r +-- FunTy inductive case + | Just (af1,w1,l1,l2) <- splitFunTy_maybe l + , Just (af2,w2,r1,r2) <- splitFunTy_maybe r + , af1==af2 + , w1 `eqType` w2 + = do r2' <- go l2 r2 + r1' <- go l1 r1 + return (mkFunTy af1 w1 r1' r2') +-- TyconApp Inductive case; this is the interesting bit. + | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs + , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs + , tycon_l /= tycon_r + = upgrade tycon_l r + + | otherwise = return r + + where upgrade :: TyCon -> Type -> TR Type + upgrade new_tycon ty + | not (isNewTyCon new_tycon) = do + traceTR (text "(Upgrade) Not matching newtype evidence: " <> + ppr new_tycon <> text " for " <> ppr ty) + return ty + | otherwise = do + traceTR (text "(Upgrade) upgraded " <> ppr ty <> + text " in presence of newtype evidence " <> ppr new_tycon) + (_, vars) <- instTyVars (tyConTyVars new_tycon) + let ty' = mkTyConApp new_tycon (mkTyVarTys vars) + rep_ty = unwrapType ty' + _ <- liftTcM (unifyType Nothing ty rep_ty) + -- assumes that reptype doesn't ^^^^ touch tyconApp args + return ty' + + +zonkTerm :: Term -> TcM Term +zonkTerm = foldTermM (TermFoldM + { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' -> + return (Term ty' dc v tt) + , fSuspensionM = \ct ty v b i -> zonkRttiType ty >>= \ty -> + return (Suspension ct ty v b i) + , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' -> + return$ NewtypeWrap ty' dc t + , fRefWrapM = \ty t -> return RefWrap `ap` + zonkRttiType ty `ap` return t + , fPrimM = (return.) . Prim }) + +zonkRttiType :: TcType -> TcM Type +-- Zonk the type, replacing any unbound Meta tyvars +-- by RuntimeUnk skolems, safely out of Meta-tyvar-land +zonkRttiType ty + = initZonkEnv RuntimeUnkFlexi $ zonkTcTypeToTypeX ty + +-------------------------------------------------------------------------------- +-- Restore Class predicates out of a representation type +dictsView :: Type -> Type +dictsView ty = ty + + +-- Use only for RTTI types +isMonomorphic :: RttiType -> Bool +isMonomorphic ty = noExistentials && noUniversals + where (tvs, _, ty') = tcSplitSigmaTy ty + noExistentials = noFreeVarsOfType ty' + noUniversals = null tvs + +-- Use only for RTTI types +isMonomorphicOnNonPhantomArgs :: RttiType -> Bool +isMonomorphicOnNonPhantomArgs ty + | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty) + , phantom_vars <- tyConPhantomTyVars tc + , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args + , tyv `notElem` phantom_vars] + = all isMonomorphicOnNonPhantomArgs concrete_args + | Just (_, _, ty1, ty2) <- splitFunTy_maybe ty + = all isMonomorphicOnNonPhantomArgs [ty1,ty2] + | otherwise = isMonomorphic ty + +tyConPhantomTyVars :: TyCon -> [TyVar] +tyConPhantomTyVars tc + | isAlgTyCon tc + , Just dcs <- tyConDataCons_maybe tc + , dc_vars <- concatMap dataConUnivTyVars dcs + = tyConTyVars tc \\ dc_vars +tyConPhantomTyVars _ = [] + +type QuantifiedType = ([TyVar], Type) + -- Make the free type variables explicit + +quantifyType :: Type -> QuantifiedType +-- Find all free and forall'd tyvars and return them +-- together with the unmodified input type. +quantifyType ty = ( filter isTyVar $ + tyCoVarsOfTypeWellScoped rho + , ty) + where + (_tvs, _, rho) = tcSplitNestedSigmaTys ty diff --git a/GHC/Runtime/Heap/Layout.hs b/GHC/Runtime/Heap/Layout.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Heap/Layout.hs @@ -0,0 +1,581 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +-- Storage manager representation of closures + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Runtime.Heap.Layout ( + -- * Words and bytes + WordOff, ByteOff, + wordsToBytes, bytesToWordsRoundUp, + roundUpToWords, roundUpTo, + + StgWord, fromStgWord, toStgWord, + StgHalfWord, fromStgHalfWord, toStgHalfWord, + halfWordSize, halfWordSizeInBits, + + -- * Closure representation + SMRep(..), -- CmmInfo sees the rep; no one else does + IsStatic, + ClosureTypeInfo(..), ArgDescr(..), Liveness, + ConstrDescription, + + -- ** Construction + mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep, + smallArrPtrsRep, arrWordsRep, + + -- ** Predicates + isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon, + isStackRep, + + -- ** Size-related things + heapClosureSizeW, + fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize, + arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW, + smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW, + fixedHdrSize, + + -- ** RTS closure types + rtsClosureType, rET_SMALL, rET_BIG, + aRG_GEN, aRG_GEN_BIG, + + -- ** Arrays + card, cardRoundUp, cardTableSizeB, cardTableSizeW + ) where + +import GHC.Prelude + +import GHC.Types.Basic( ConTagZ ) +import GHC.Platform +import GHC.Platform.Profile + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Word +import Data.ByteString (ByteString) + +{- +************************************************************************ +* * + Words and bytes +* * +************************************************************************ +-} + +-- | Byte offset, or byte count +type ByteOff = Int + +-- | Word offset, or word count +type WordOff = Int + +-- | Round up the given byte count to the next byte count that's a +-- multiple of the machine's word size. +roundUpToWords :: Platform -> ByteOff -> ByteOff +roundUpToWords platform n = roundUpTo n (platformWordSizeInBytes platform) + +-- | Round up @base@ to a multiple of @size@. +roundUpTo :: ByteOff -> ByteOff -> ByteOff +roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1)) + +-- | Convert the given number of words to a number of bytes. +-- +-- This function morally has type @WordOff -> ByteOff@, but uses @Num +-- a@ to allow for overloading. +wordsToBytes :: Num a => Platform -> a -> a +wordsToBytes platform n = fromIntegral (platformWordSizeInBytes platform) * n +{-# SPECIALIZE wordsToBytes :: Platform -> Int -> Int #-} +{-# SPECIALIZE wordsToBytes :: Platform -> Word -> Word #-} +{-# SPECIALIZE wordsToBytes :: Platform -> Integer -> Integer #-} + +-- | First round the given byte count up to a multiple of the +-- machine's word size and then convert the result to words. +bytesToWordsRoundUp :: Platform -> ByteOff -> WordOff +bytesToWordsRoundUp platform n = (n + word_size - 1) `quot` word_size + where word_size = platformWordSizeInBytes platform +-- StgWord is a type representing an StgWord on the target platform. +-- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform +newtype StgWord = StgWord Word64 + deriving (Eq, Bits) + +fromStgWord :: StgWord -> Integer +fromStgWord (StgWord i) = toInteger i + +toStgWord :: Platform -> Integer -> StgWord +toStgWord platform i + = case platformWordSize platform of + -- These conversions mean that things like toStgWord (-1) + -- do the right thing + PW4 -> StgWord (fromIntegral (fromInteger i :: Word32)) + PW8 -> StgWord (fromInteger i) + +instance Outputable StgWord where + ppr (StgWord i) = integer (toInteger i) + +-- + +-- A Word32 is large enough to hold half a Word for either a 32bit or +-- 64bit platform +newtype StgHalfWord = StgHalfWord Word32 + deriving Eq + +fromStgHalfWord :: StgHalfWord -> Integer +fromStgHalfWord (StgHalfWord w) = toInteger w + +toStgHalfWord :: Platform -> Integer -> StgHalfWord +toStgHalfWord platform i + = case platformWordSize platform of + -- These conversions mean that things like toStgHalfWord (-1) + -- do the right thing + PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16)) + PW8 -> StgHalfWord (fromInteger i :: Word32) + +instance Outputable StgHalfWord where + ppr (StgHalfWord w) = integer (toInteger w) + +-- | Half word size in bytes +halfWordSize :: Platform -> ByteOff +halfWordSize platform = platformWordSizeInBytes platform `div` 2 + +halfWordSizeInBits :: Platform -> Int +halfWordSizeInBits platform = platformWordSizeInBits platform `div` 2 + +{- +************************************************************************ +* * +\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation} +* * +************************************************************************ +-} + +-- | A description of the layout of a closure. Corresponds directly +-- to the closure types in includes\/rts\/storage\/ClosureTypes.h. +data SMRep + = HeapRep -- GC routines consult sizes in info tbl + IsStatic + !WordOff -- # ptr words + !WordOff -- # non-ptr words INCLUDING SLOP (see mkHeapRep below) + ClosureTypeInfo -- type-specific info + + | ArrayPtrsRep + !WordOff -- # ptr words + !WordOff -- # card table words + + | SmallArrayPtrsRep + !WordOff -- # ptr words + + | ArrayWordsRep + !WordOff -- # bytes expressed in words, rounded up + + | StackRep -- Stack frame (RET_SMALL or RET_BIG) + Liveness + + | RTSRep -- The RTS needs to declare info tables with specific + Int -- type tags, so this form lets us override the default + SMRep -- tag for an SMRep. + deriving (Eq, Ord) + +-- | True \<=> This is a static closure. Affects how we garbage-collect it. +-- Static closure have an extra static link field at the end. +-- Constructors do not have a static variant; see Note [static constructors] +type IsStatic = Bool + +-- From an SMRep you can get to the closure type defined in +-- rts/include/rts/storage/ClosureTypes.h. Described by the function +-- rtsClosureType below. + +data ClosureTypeInfo + = Constr ConTagZ ConstrDescription + | Fun FunArity ArgDescr + | Thunk + | ThunkSelector SelectorOffset + | BlackHole + | IndStatic + deriving (Eq, Ord) + +type ConstrDescription = ByteString -- result of dataConIdentity +type FunArity = Int +type SelectorOffset = Int + +-- | We represent liveness bitmaps as a Bitmap (whose internal representation +-- really is a bitmap). These are pinned onto case return vectors to indicate +-- the state of the stack for the garbage collector. +-- +-- In the compiled program, liveness bitmaps that fit inside a single word +-- (StgWord) are stored as a single word, while larger bitmaps are stored as a +-- pointer to an array of words. + +type Liveness = [Bool] -- One Bool per word; True <=> non-ptr or dead + -- False <=> ptr + +-------------------------------------------------------------------------------- +-- | An ArgDescr describes the argument pattern of a function + +data ArgDescr + = ArgSpec -- Fits one of the standard patterns + !Int -- RTS type identifier ARG_P, ARG_N, ... + + | ArgGen -- General case + Liveness -- Details about the arguments + + | ArgUnknown -- For imported binds. + -- Invariant: Never Unknown for binds of the module + -- we are compiling. + deriving (Eq, Ord) + +instance Outputable ArgDescr where + ppr (ArgSpec n) = text "ArgSpec" <+> ppr n + ppr (ArgGen ls) = text "ArgGen" <+> ppr ls + ppr ArgUnknown = text "ArgUnknown" + +----------------------------------------------------------------------------- +-- Construction + +mkHeapRep :: Profile -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo + -> SMRep +mkHeapRep profile is_static ptr_wds nonptr_wds cl_type_info + = HeapRep is_static + ptr_wds + (nonptr_wds + slop_wds) + cl_type_info + where + slop_wds + | is_static = 0 + | otherwise = max 0 (minClosureSize profile - (hdr_size + payload_size)) + + hdr_size = closureTypeHdrSize profile cl_type_info + payload_size = ptr_wds + nonptr_wds + +mkRTSRep :: Int -> SMRep -> SMRep +mkRTSRep = RTSRep + +mkStackRep :: [Bool] -> SMRep +mkStackRep liveness = StackRep liveness + +blackHoleRep :: SMRep +blackHoleRep = HeapRep False 0 0 BlackHole + +indStaticRep :: SMRep +indStaticRep = HeapRep True 1 0 IndStatic + +arrPtrsRep :: Platform -> WordOff -> SMRep +arrPtrsRep platform elems = ArrayPtrsRep elems (cardTableSizeW platform elems) + +smallArrPtrsRep :: WordOff -> SMRep +smallArrPtrsRep elems = SmallArrayPtrsRep elems + +arrWordsRep :: Platform -> ByteOff -> SMRep +arrWordsRep platform bytes = ArrayWordsRep (bytesToWordsRoundUp platform bytes) + +----------------------------------------------------------------------------- +-- Predicates + +isStaticRep :: SMRep -> IsStatic +isStaticRep (HeapRep is_static _ _ _) = is_static +isStaticRep (RTSRep _ rep) = isStaticRep rep +isStaticRep _ = False + +isStackRep :: SMRep -> Bool +isStackRep StackRep{} = True +isStackRep (RTSRep _ rep) = isStackRep rep +isStackRep _ = False + +isConRep :: SMRep -> Bool +isConRep (HeapRep _ _ _ Constr{}) = True +isConRep _ = False + +isThunkRep :: SMRep -> Bool +isThunkRep (HeapRep _ _ _ Thunk) = True +isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True +isThunkRep (HeapRep _ _ _ BlackHole) = True +isThunkRep (HeapRep _ _ _ IndStatic) = True +isThunkRep _ = False + +isFunRep :: SMRep -> Bool +isFunRep (HeapRep _ _ _ Fun{}) = True +isFunRep _ = False + +isStaticNoCafCon :: SMRep -> Bool +-- This should line up exactly with CONSTR_NOCAF below +-- See Note [Static NoCaf constructors] +isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True +isStaticNoCafCon _ = False + + +----------------------------------------------------------------------------- +-- Size-related things + +fixedHdrSize :: Profile -> ByteOff +fixedHdrSize profile = wordsToBytes (profilePlatform profile) (fixedHdrSizeW profile) + +-- | Size of a closure header (StgHeader in includes\/rts\/storage\/Closures.h) +fixedHdrSizeW :: Profile -> WordOff +fixedHdrSizeW profile = pc_STD_HDR_SIZE (profileConstants profile) + profHdrSize profile + +-- | Size of the profiling part of a closure header +-- (StgProfHeader in includes\/rts\/storage\/Closures.h) +profHdrSize :: Profile -> WordOff +profHdrSize profile = + if profileIsProfiling profile + then pc_PROF_HDR_SIZE (profileConstants profile) + else 0 + +-- | The garbage collector requires that every closure is at least as +-- big as this. +minClosureSize :: Profile -> WordOff +minClosureSize profile + = fixedHdrSizeW profile + + pc_MIN_PAYLOAD_SIZE (profileConstants profile) + +arrWordsHdrSize :: Profile -> ByteOff +arrWordsHdrSize profile + = fixedHdrSize profile + + pc_SIZEOF_StgArrBytes_NoHdr (profileConstants profile) + +arrWordsHdrSizeW :: Profile -> WordOff +arrWordsHdrSizeW profile + = fixedHdrSizeW profile + + (pc_SIZEOF_StgArrBytes_NoHdr (profileConstants profile) `quot` + platformWordSizeInBytes (profilePlatform profile)) + +arrPtrsHdrSize :: Profile -> ByteOff +arrPtrsHdrSize profile + = fixedHdrSize profile + + pc_SIZEOF_StgMutArrPtrs_NoHdr (profileConstants profile) + +arrPtrsHdrSizeW :: Profile -> WordOff +arrPtrsHdrSizeW profile + = fixedHdrSizeW profile + + (pc_SIZEOF_StgMutArrPtrs_NoHdr (profileConstants profile) `quot` + platformWordSizeInBytes (profilePlatform profile)) + +smallArrPtrsHdrSize :: Profile -> ByteOff +smallArrPtrsHdrSize profile + = fixedHdrSize profile + + pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (profileConstants profile) + +smallArrPtrsHdrSizeW :: Profile -> WordOff +smallArrPtrsHdrSizeW profile + = fixedHdrSizeW profile + + (pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (profileConstants profile) `quot` + platformWordSizeInBytes (profilePlatform profile)) + +-- Thunks have an extra header word on SMP, so the update doesn't +-- splat the payload. +thunkHdrSize :: Profile -> WordOff +thunkHdrSize profile = fixedHdrSizeW profile + smp_hdr + where + platform = profilePlatform profile + smp_hdr = pc_SIZEOF_StgSMPThunkHeader (platformConstants platform) `quot` + platformWordSizeInBytes platform + +hdrSize :: Profile -> SMRep -> ByteOff +hdrSize profile rep = wordsToBytes (profilePlatform profile) (hdrSizeW profile rep) + +hdrSizeW :: Profile -> SMRep -> WordOff +hdrSizeW profile (HeapRep _ _ _ ty) = closureTypeHdrSize profile ty +hdrSizeW profile (ArrayPtrsRep _ _) = arrPtrsHdrSizeW profile +hdrSizeW profile (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW profile +hdrSizeW profile (ArrayWordsRep _) = arrWordsHdrSizeW profile +hdrSizeW _ _ = panic "GHC.Runtime.Heap.Layout.hdrSizeW" + +nonHdrSize :: Platform -> SMRep -> ByteOff +nonHdrSize platform rep = wordsToBytes platform (nonHdrSizeW rep) + +nonHdrSizeW :: SMRep -> WordOff +nonHdrSizeW (HeapRep _ p np _) = p + np +nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct +nonHdrSizeW (SmallArrayPtrsRep elems) = elems +nonHdrSizeW (ArrayWordsRep words) = words +nonHdrSizeW (StackRep bs) = length bs +nonHdrSizeW (RTSRep _ rep) = nonHdrSizeW rep + +-- | The total size of the closure, in words. +heapClosureSizeW :: Profile -> SMRep -> WordOff +heapClosureSizeW profile rep = case rep of + HeapRep _ p np ty -> closureTypeHdrSize profile ty + p + np + ArrayPtrsRep elems ct -> arrPtrsHdrSizeW profile + elems + ct + SmallArrayPtrsRep elems -> smallArrPtrsHdrSizeW profile + elems + ArrayWordsRep words -> arrWordsHdrSizeW profile + words + _ -> panic "GHC.Runtime.Heap.Layout.heapClosureSize" + +closureTypeHdrSize :: Profile -> ClosureTypeInfo -> WordOff +closureTypeHdrSize profile ty = case ty of + Thunk -> thunkHdrSize profile + ThunkSelector{} -> thunkHdrSize profile + BlackHole -> thunkHdrSize profile + IndStatic -> thunkHdrSize profile + _ -> fixedHdrSizeW profile + -- All thunks use thunkHdrSize, even if they are non-updatable. + -- this is because we don't have separate closure types for + -- updatable vs. non-updatable thunks, so the GC can't tell the + -- difference. If we ever have significant numbers of non- + -- updatable thunks, it might be worth fixing this. + +-- --------------------------------------------------------------------------- +-- Arrays + +-- | The byte offset into the card table of the card for a given element +card :: Platform -> Int -> Int +card platform i = i `shiftR` pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform) + +-- | Convert a number of elements to a number of cards, rounding up +cardRoundUp :: Platform -> Int -> Int +cardRoundUp platform i = + card platform (i + ((1 `shiftL` pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)) - 1)) + +-- | The size of a card table, in bytes +cardTableSizeB :: Platform -> Int -> ByteOff +cardTableSizeB platform elems = cardRoundUp platform elems + +-- | The size of a card table, in words +cardTableSizeW :: Platform -> Int -> WordOff +cardTableSizeW platform elems = + bytesToWordsRoundUp platform (cardTableSizeB platform elems) + +----------------------------------------------------------------------------- +-- deriving the RTS closure type from an SMRep + +#include "ClosureTypes.h" +#include "FunTypes.h" +-- Defines CONSTR, CONSTR_1_0 etc + +-- | Derives the RTS closure type from an 'SMRep' +rtsClosureType :: SMRep -> Int +rtsClosureType rep + = case rep of + RTSRep ty _ -> ty + + -- See Note [static constructors] + HeapRep _ 1 0 Constr{} -> CONSTR_1_0 + HeapRep _ 0 1 Constr{} -> CONSTR_0_1 + HeapRep _ 2 0 Constr{} -> CONSTR_2_0 + HeapRep _ 1 1 Constr{} -> CONSTR_1_1 + HeapRep _ 0 2 Constr{} -> CONSTR_0_2 + HeapRep _ 0 _ Constr{} -> CONSTR_NOCAF + -- See Note [Static NoCaf constructors] + HeapRep _ _ _ Constr{} -> CONSTR + + HeapRep False 1 0 Fun{} -> FUN_1_0 + HeapRep False 0 1 Fun{} -> FUN_0_1 + HeapRep False 2 0 Fun{} -> FUN_2_0 + HeapRep False 1 1 Fun{} -> FUN_1_1 + HeapRep False 0 2 Fun{} -> FUN_0_2 + HeapRep False _ _ Fun{} -> FUN + + HeapRep False 1 0 Thunk -> THUNK_1_0 + HeapRep False 0 1 Thunk -> THUNK_0_1 + HeapRep False 2 0 Thunk -> THUNK_2_0 + HeapRep False 1 1 Thunk -> THUNK_1_1 + HeapRep False 0 2 Thunk -> THUNK_0_2 + HeapRep False _ _ Thunk -> THUNK + + HeapRep False _ _ ThunkSelector{} -> THUNK_SELECTOR + + HeapRep True _ _ Fun{} -> FUN_STATIC + HeapRep True _ _ Thunk -> THUNK_STATIC + HeapRep False _ _ BlackHole -> BLACKHOLE + HeapRep False _ _ IndStatic -> IND_STATIC + + StackRep _ -> STACK + + _ -> panic "rtsClosureType" + +-- We export these ones +rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int +rET_SMALL = RET_SMALL +rET_BIG = RET_BIG +aRG_GEN = ARG_GEN +aRG_GEN_BIG = ARG_GEN_BIG + +{- +Note [static constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We used to have a CONSTR_STATIC closure type, and each constructor had +two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with +CONSTR_STATIC. + +This distinction was removed, because when copying a data structure +into a compact region, we must copy static constructors into the +compact region too. If we didn't do this, we would need to track the +references from the compact region out to the static constructors, +because they might (indirectly) refer to CAFs. + +Since static constructors will be copied to the heap, if we wanted to +use different info tables for static and dynamic constructors, we +would have to switch the info pointer when copying the constructor +into the compact region, which means we would need an extra field of +the static info table to point to the dynamic one. + +However, since the distinction between static and dynamic closure +types is never actually needed (other than for assertions), we can +just drop the distinction and use the same info table for both. + +The GC *does* need to distinguish between static and dynamic closures, +but it does this using the HEAP_ALLOCED() macro which checks whether +the address of the closure resides within the dynamic heap. +HEAP_ALLOCED() doesn't read the closure's info table. + +Note [Static NoCaf constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we know that a top-level binding 'x' is not Caffy (ie no CAFs are +reachable from 'x'), then a statically allocated constructor (Just x) +is also not Caffy, and the garbage collector need not follow its +argument fields. Exploiting this would require two static info tables +for Just, for the two cases where the argument was Caffy or non-Caffy. + +Currently we don't do this; instead we treat nullary constructors +as non-Caffy, and the others as potentially Caffy. + + +************************************************************************ +* * + Pretty printing of SMRep and friends +* * +************************************************************************ +-} + +instance Outputable ClosureTypeInfo where + ppr = pprTypeInfo + +instance Outputable SMRep where + ppr (HeapRep static ps nps tyinfo) + = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace) + where + header = text "HeapRep" + <+> if static then text "static" else empty + <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps + pp_n :: String -> Int -> SDoc + pp_n _ 0 = empty + pp_n s n = int n <+> text s + + ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size + + ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size + + ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words + + ppr (StackRep bs) = text "StackRep" <+> ppr bs + + ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep + +pprTypeInfo :: ClosureTypeInfo -> SDoc +pprTypeInfo (Constr tag descr) + = text "Con" <+> + braces (sep [ text "tag:" <+> ppr tag + , text "descr:" <> text (show descr) ]) + +pprTypeInfo (Fun arity args) + = text "Fun" <+> + braces (sep [ text "arity:" <+> ppr arity + , text "fun_type:" <+> ppr args ]) + +pprTypeInfo (ThunkSelector offset) + = text "ThunkSel" <+> ppr offset + +pprTypeInfo Thunk = text "Thunk" +pprTypeInfo BlackHole = text "BlackHole" +pprTypeInfo IndStatic = text "IndStatic" diff --git a/GHC/Runtime/Interpreter.hs b/GHC/Runtime/Interpreter.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter.hs @@ -0,0 +1,764 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | 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 + , whereFrom + , getModBreaks + , readIModBreaks + , readIModBreaksMaybe + , readIModModBreaks + , seqHValue + , evalBreakpointToId + + -- * The object-code linker + , initObjLinker + , lookupSymbol + , lookupSymbolInDLL + , lookupClosure + , loadDLL + , loadArchive + , loadObj + , unloadObj + , addLibrarySearchPath + , removeLibrarySearchPath + , resolveObjs + , findSystemLibrary + + , interpCmd + , withExtInterp + , withExtInterpStatus + , withIServ + , withJSInterp + , stopInterp + , purgeLookupSymbolCache + , freeReallyRemoteRef + , freeHValueRefs + , mkFinalizedHValue + , wormhole, wormholeRef + , fromEvalResult + + -- * Reexport for convenience + , Message (..) + , module GHC.Runtime.Interpreter.Process + ) where + +import GHC.Prelude + +import GHC.Runtime.Interpreter.Types +import GHC.Runtime.Interpreter.JS +import GHC.Runtime.Interpreter.Wasm +import GHC.Runtime.Interpreter.Process +import GHC.Runtime.Utils +import GHCi.Message +import GHCi.RemoteTypes +import GHCi.ResolvedBCO +import GHCi.BreakArray (BreakArray) +import GHC.ByteCode.Breakpoints + +import GHC.ByteCode.Types +import GHC.Linker.Types + +import GHC.Data.Maybe +import GHC.Data.FastString + +import GHC.Types.SrcLoc +import GHC.Types.Basic + +import GHC.Utils.Panic +import GHC.Utils.Exception as Ex +import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe) +import GHC.Utils.Fingerprint + +import GHC.Unit.Module +import GHC.Unit.Home.ModInfo +import GHC.Unit.Env + +#if defined(HAVE_INTERNAL_INTERPRETER) +import GHCi.Run +#endif + +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Catch as MC (mask) +import Data.Binary +import Data.ByteString (ByteString) +import Foreign hiding (void) +import qualified GHC.Exts.Heap as Heap +import GHC.Stack.CCS (CostCentre,CostCentreStack) +import System.Directory +import System.Process +import qualified GHC.InfoProv as InfoProv + +import GHC.Builtin.Names +import GHC.Types.Name +import qualified GHC.Unit.Home.Graph as HUG + +-- Standard libraries +import GHC.Exts + +{- 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 code for 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 ext -> withExtInterp ext $ \inst -> + uninterruptibleMask_ $ -- Note [uninterruptibleMask_ and interpCmd] + sendMessage inst msg + + +withExtInterp :: ExceptionMonad m => ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a +withExtInterp ext action = case ext of + ExtJS i -> withJSInterp i action + ExtWasm i -> withWasmInterp i action + ExtIServ i -> withIServ i action + +withExtInterpStatus :: ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a +withExtInterpStatus ext action = case ext of + ExtJS i -> action (interpStatus i) + ExtWasm i -> action $ interpStatus i + ExtIServ i -> action (interpStatus 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) + => IServ -> (ExtInterpInstance () -> m a) -> m a +withIServ (ExtInterpState cfg mstate) action = do + inst <- spawnInterpMaybe cfg spawnIServ mstate + action inst + +-- | Spawn JS interpreter if it isn't already running and execute the given action +-- +-- Update the interpreter state. +withJSInterp :: ExceptionMonad m => JSInterp -> (ExtInterpInstance JSInterpExtra -> m a) -> m a +withJSInterp (ExtInterpState cfg mstate) action = do + inst <- spawnInterpMaybe cfg spawnJSInterp mstate + action inst + +withWasmInterp :: ExceptionMonad m => WasmInterp -> (ExtInterpInstance () -> m a) -> m a +withWasmInterp (ExtInterpState cfg mstate) action = do + inst <- spawnInterpMaybe cfg spawnWasmInterp mstate + action inst + +-- | Spawn an interpreter if not already running according to the status in the +-- MVar. Update the status, free pending heap references, and return the +-- interpreter instance. +-- +-- This function is generic to support both the native external interpreter and +-- the JS one. +spawnInterpMaybe :: ExceptionMonad m => cfg -> (cfg -> IO (ExtInterpInstance d)) -> ExtInterpStatusVar d -> m (ExtInterpInstance d) +spawnInterpMaybe cfg spawn mstatus = do + inst <- liftIO $ modifyMVarMasked mstatus $ \case + -- start the external iserv process if we haven't done so yet + InterpPending -> do + inst <- spawn cfg + pure (InterpRunning inst, inst) + + InterpRunning inst -> do + pure (InterpRunning inst, inst) + + -- free any ForeignRef that have been garbage collected. + pending_frees <- liftIO $ swapMVar (instPendingFrees inst) [] + liftIO $ when (not (null (pending_frees))) $ + sendMessage inst (FreeHValueRefs pending_frees) + + -- run the inner action + pure inst + +withExtInterpMaybe + :: (ExceptionMonad m) + => ExtInterp -> (forall d. Maybe (ExtInterpInstance d) -> m a) -> m a +withExtInterpMaybe ext action = withExtInterpStatus ext $ \mstate -> do + liftIO (readMVar mstate) >>= \case + InterpPending {} -> action Nothing -- already shut down or never launched + InterpRunning inst -> action (Just inst) + +-- ----------------------------------------------------------------------------- +-- Wrappers around messages + +-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for +-- each of the results. +evalStmt + :: Interp + -> EvalOpts + -> EvalExpr ForeignHValue + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +evalStmt interp opts foreign_expr = do + status <- withExpr foreign_expr $ \expr -> + interpCmd interp (EvalStmt opts expr) + handleEvalStatus interp status + where + withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a + withExpr (EvalThis fhv) cont = + withForeignRef fhv $ \hvref -> cont (EvalThis hvref) + withExpr (EvalApp fl fr) cont = + withExpr fl $ \fl' -> + withExpr fr $ \fr' -> + cont (EvalApp fl' fr') + +resumeStmt + :: Interp + -> EvalOpts + -> ForeignRef (ResumeContext [HValueRef]) + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +resumeStmt interp opts resume_ctxt = do + status <- withForeignRef resume_ctxt $ \rhv -> + interpCmd interp (ResumeStmt opts rhv) + handleEvalStatus interp status + +abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO () +abandonStmt interp resume_ctxt = + withForeignRef resume_ctxt $ \rhv -> + interpCmd interp (AbandonStmt rhv) + +handleEvalStatus + :: Interp + -> EvalStatus [HValueRef] + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +handleEvalStatus interp status = + case status of + EvalBreak a b c d -> return (EvalBreak a b c d) + 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 -> [ResolvedBCO] -> IO [HValueRef] +createBCOs interp rbcos = do + interpCmd interp (CreateBCOs rbcos) + +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 + +whereFrom :: Interp -> ForeignHValue -> IO (Maybe InfoProv.InfoProv) +whereFrom interp ref = + withForeignRef ref $ \hval -> do + interpCmd interp (WhereFrom hval) + +-- | Send a Seq message to the iserv process to force a value #2950 +seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ()) +seqHValue interp unit_env ref = + withForeignRef ref $ \hval -> do + status <- interpCmd interp (Seq hval) + handleSeqHValueStatus interp unit_env status + +evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId +evalBreakpointToId eval_break = + let + mkUnitId u = fsToUnit $ mkFastStringShortByteString u + toModule u n = mkModule (mkUnitId u) (mkModuleName n) + in + InternalBreakpointId + { ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break) + , ibi_info_index = eb_info_index eval_break + } + +-- | Process the result of a Seq or ResumeSeq message. #2950 +handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ()) +handleSeqHValueStatus interp unit_env eval_status = + case eval_status of + (EvalBreak _ maybe_break 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 put x = putStrLn ("*** Ignoring breakpoint " ++ (showSDocUnsafe x)) + let nothing_case = put $ brackets . ppr $ mkGeneralSrcSpan (fsLit "") + case maybe_break of + Nothing -> nothing_case + -- Nothing case - should not occur! + -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq + + Just break -> do + let ibi = evalBreakpointToId break + hug = ue_home_unit_graph unit_env + + -- Just case: Stopped at a breakpoint, extract SrcSpan information + -- from the breakpoint. + mb_modbreaks <- readIModBreaksMaybe hug (ibi_info_mod ibi) + case mb_modbreaks of + -- Nothing case - should not occur! We should have the appropriate + -- breakpoint information + Nothing -> nothing_case + Just modbreaks -> put . brackets . ppr =<< + getBreakLoc (readIModModBreaks hug) ibi modbreaks + + -- resume the seq (:force) processing in the iserv process + withForeignRef resume_ctxt_fhv $ \hval -> do + status <- interpCmd interp (ResumeSeq hval) + handleSeqHValueStatus interp unit_env status + (EvalComplete _ r) -> return r + + +-- ----------------------------------------------------------------------------- +-- Interface to the object-code linker + +initObjLinker :: Interp -> IO () +initObjLinker interp = interpCmd interp InitLinker + +lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ())) +lookupSymbol interp str = withSymbolCache interp str $ + case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str))) +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do + uninterruptibleMask_ $ + sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str))) + ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) + ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do + uninterruptibleMask_ $ + sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str))) + +lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ())) +lookupSymbolInDLL interp dll str = withSymbolCache interp str $ + case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str))) +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do + uninterruptibleMask_ $ + sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str))) + ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) + -- wasm dyld doesn't track which symbol comes from which .so + ExtWasm {} -> lookupSymbol interp str + +interpSymbolToCLabel :: forall s . InterpSymbol s -> FastString +interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is -> + let + n = interpSymbolName is + suffix = interpSymbolSuffix is + + encodeZ = fastZStringToByteString . zEncodeFS + (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of + -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers + -- See Note [Primop wrappers] in GHC.Builtin.PrimOps. + mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS + mod -> mod + packagePart = encodeZ (unitFS pkgKey) + modulePart = encodeZ (moduleNameFS modName) + occPart = encodeZ $ occNameMangledFS (nameOccName n) + + label = mconcat $ + [ packagePart `mappend` "_" | pkgKey /= mainUnit ] + ++ + [modulePart + , "_" + , occPart + , "_" + , fromString suffix + ] + in mkFastStringByteString label + +lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef) +lookupClosure interp str = + interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str))) + +-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache' +-- which maps symbols to the address where they are loaded. +-- When there's a cache hit we simply return the cached address, when there is +-- a miss we run the action which determines the symbol's address and populate +-- the cache with the answer. +withSymbolCache :: Interp + -> InterpSymbol s + -- ^ The symbol we are looking up in the cache + -> IO (Maybe (Ptr ())) + -- ^ An action which determines the address of the symbol we + -- are looking up in the cache, which is run if there is a + -- cache miss. The result will be cached. + -> IO (Maybe (Ptr ())) +withSymbolCache interp str determine_addr = 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. + -- + -- The analysis in #23415 further showed this cache should also benefit the + -- internal interpreter's loading times, and needn't be used by the external + -- interpreter only. + cached_val <- lookupInterpSymbolCache str (interpSymbolCache interp) + case cached_val of + Just {} -> return cached_val + Nothing -> do + maddr <- determine_addr + case maddr of + Nothing -> return Nothing + Just p -> do + updateInterpSymbolCache str (interpSymbolCache interp) p + return maddr + +purgeLookupSymbolCache :: Interp -> IO () +purgeLookupSymbolCache interp = purgeInterpSymbolCache (interpSymbolCache interp) + +-- | 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 :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL)) +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) + +-- ----------------------------------------------------------------------------- +-- IServ specific calls and messages + +-- | Spawn an external interpreter +spawnIServ :: IServConfig -> IO (ExtInterpInstance ()) +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) + interpPipe <- mkPipeFromHandles rh wh + lock <- newMVar () + let process = InterpProcess + { interpHandle = ph + , interpPipe + , interpLock = lock + } + + pending_frees <- newMVar [] + let inst = ExtInterpInstance + { instProcess = process + , instPendingFrees = pending_frees + , instExtra = () + } + pure inst + +-- | Stop the interpreter +stopInterp :: Interp -> IO () +stopInterp interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> pure () +#endif + ExternalInterp ext -> withExtInterpStatus ext $ \mstate -> do + MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do + case state of + InterpPending -> pure state -- already stopped + InterpRunning i -> do + ex <- getProcessExitCode (interpHandle (instProcess i)) + if isJust ex + then pure () + else sendMessage i Shutdown + pure InterpPending + +-- ----------------------------------------------------------------------------- +{- 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 +or the JS 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 + case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> mkForeignRef rref (freeRemoteRef rref) +#endif + ExternalInterp ext -> withExtInterpMaybe ext $ \case + Nothing -> mkForeignRef rref (pure ()) -- nothing to do, interpreter already stopped + Just inst -> mkForeignRef rref (freeReallyRemoteRef inst rref) + +freeReallyRemoteRef :: ExtInterpInstance d -> RemoteRef a -> IO () +freeReallyRemoteRef inst rref = + -- add to the list of HValues to free + modifyMVar_ (instPendingFrees inst) (\xs -> pure (castRemoteRef rref : xs)) + + +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") + +-------------------------------------------------------------------------------- +-- * Finding breakpoint information +-------------------------------------------------------------------------------- + +-- | Get the breakpoint information from the ByteCode object associated to this +-- 'HomeModInfo'. +getModBreaks :: HomeModInfo -> Maybe InternalModBreaks +getModBreaks hmi + | Just linkable <- homeModInfoByteCode hmi, + -- The linkable may have 'DotO's as well; only consider BCOs. See #20570. + [cbc] <- linkableBCOs linkable + = bc_breaks cbc + | otherwise + = Nothing -- probably object code + +-- | Read the 'InternalModBreaks' of the given home 'Module' (via +-- 'InternalBreakpointId') from the 'HomeUnitGraph'. +readIModBreaks :: HomeUnitGraph -> InternalBreakpointId -> IO InternalModBreaks +readIModBreaks hug ibi = expectJust <$> readIModBreaksMaybe hug (ibi_info_mod ibi) + +-- | Read the 'InternalModBreaks' of the given home 'Module' from the 'HomeUnitGraph'. +readIModBreaksMaybe :: HomeUnitGraph -> Module -> IO (Maybe InternalModBreaks) +readIModBreaksMaybe hug mod = getModBreaks . expectJust <$> HUG.lookupHugByModule mod hug + +-- | Read the 'ModBreaks' from the given module's 'InternalModBreaks' +readIModModBreaks :: HUG.HomeUnitGraph -> Module -> IO ModBreaks +readIModModBreaks hug mod = imodBreaks_modBreaks . expectJust <$> readIModBreaksMaybe hug mod + +-- ----------------------------------------------------------------------------- +-- Misc utils + +fromEvalResult :: EvalResult a -> IO a +fromEvalResult (EvalException e) = throwIO (fromSerializableException e) +fromEvalResult (EvalSuccess a) = return a + diff --git a/GHC/Runtime/Interpreter/JS.hs b/GHC/Runtime/Interpreter/JS.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter/JS.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +-- | JavaScript interpreter +-- +-- See Note [The JS interpreter] +-- +module GHC.Runtime.Interpreter.JS + ( spawnJSInterp + , jsLinkRts + , jsLinkInterp + , jsLinkObject + , jsLinkObjects + , jsLoadFile + , jsRunServer + -- * Reexported for convenience + , mkExportedModFuns + ) +where + +import GHC.Prelude +import GHC.Runtime.Interpreter.Types +import GHC.Runtime.Interpreter.Process +import GHC.Runtime.Utils +import GHCi.Message + +import GHC.StgToJS.Linker.Types +import GHC.StgToJS.Linker.Linker +import GHC.StgToJS.Types +import GHC.StgToJS.Object + +import GHC.Unit.Env +import GHC.Unit.Types +import GHC.Unit.State + +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Utils.Panic +import GHC.Utils.Error (logInfo) +import GHC.Utils.Outputable (text) +import GHC.Data.FastString + +import Control.Concurrent +import Control.Monad + +import System.Process +import System.IO +import System.FilePath + +import Data.IORef +import qualified Data.Set as Set +import qualified Data.ByteString as B + +import Foreign.C.String + + +-- Note [The JS interpreter] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The JS interpreter works as follows: +-- +-- ghc-interp.js is a simple JS script used to bootstrap the external +-- interpreter server (iserv) that is written in Haskell. This script waits for +-- commands on stdin: +-- +-- LOAD foo.js +-- +-- load a JS file in the current JS environment +-- +-- RUN_SERVER ghci_unit_id +-- +-- execute h$main(h$ghci_unit_idZCGHCiziServerzidefaultServer), +-- the entry point of the interpreter server +-- +-- On the GHC side, when we need the interpreter we do the following: +-- +-- 1. spawn nodejs with $topdir/ghc-interp.js script +-- 2. link the JS rts and send a LOAD command to load it +-- 3. link iserv (i.e. use GHCi.Server.defaultServer as root) and LOAD it +-- 4. send a RUN_SERVER command to execute the JS iserv +-- +-- From this moment on, everything happens as with the native iserv, using a +-- pipe for communication, with the following differences: +-- +-- - the JS iserv only supports the LoadObj linking command which has been +-- repurposed to load a JS source file. The JS iserv doesn't deal with +-- libraries (.a) and with object files (.o). The linker state is maintained on +-- the GHC side and GHC only sends the appropriate chunks of JS code to link. +-- +-- - the JS iserv doesn't support ByteCode (i.e. it doesn't support CreateBCOs +-- messages). JS iserv clients should use the usual JS compilation pipeline and +-- send JS code instead. See GHC.Driver.Main.hscCompileCoreExpr for an example. +-- +-- GHC keeps track of JS blocks (JS unit of linking corresponding to top-level +-- binding groups) that have already been linked by the JS interpreter. It only +-- links new ones when necessary. +-- +-- Note that the JS interpreter isn't subject to staging issues: we can use it +-- in a Stage1 GHC. +-- + +--------------------------------------------------------- +-- Running node +--------------------------------------------------------- + +-- | Start NodeJS interactively with "ghc-interp.js" script loaded in +startTHRunnerProcess :: FilePath -> NodeJsSettings -> IO (Handle,InterpProcess) +startTHRunnerProcess interp_js settings = do + interp_in <- newIORef undefined + + let createProc cp = do + let cp' = cp + { std_in = CreatePipe + , std_out = Inherit + , std_err = Inherit + } + (mb_in, _mb_out, _mb_err, hdl) <- createProcess cp' + -- we can't directly return stdin for the process given the current + -- implementation of runWithPipes. So we just use an IORef for this... + case mb_in of + Nothing -> panic "startTHRunnerProcess: expected stdin for interpreter" + Just i -> writeIORef interp_in i + return hdl + + (hdl, rh, wh) <- runWithPipes createProc (nodeProgram settings) + [interp_js] + (nodeExtraArgs settings) + std_in <- readIORef interp_in + + interpPipe <- mkPipeFromHandles rh wh + lock <- newMVar () + let proc = InterpProcess + { interpHandle = hdl + , interpPipe + , interpLock = lock + } + pure (std_in, proc) + +-- | Spawn a JS interpreter +-- +-- Run NodeJS with "ghc-interp.js" loaded in. Then load GHCi.Server and its deps +-- (including the rts) and run GHCi.Server.defaultServer. +spawnJSInterp :: JSInterpConfig -> IO (ExtInterpInstance JSInterpExtra) +spawnJSInterp cfg = do + let logger= jsInterpLogger cfg + when (logVerbAtLeast logger 2) $ + logInfo logger (text "Spawning JS interpreter") + + let tmpfs = jsInterpTmpFs cfg + tmp_dir = jsInterpTmpDir cfg + logger = jsInterpLogger cfg + codegen_cfg = jsInterpCodegenCfg cfg + unit_env = jsInterpUnitEnv cfg + finder_opts = jsInterpFinderOpts cfg + finder_cache = jsInterpFinderCache cfg + + (std_in, proc) <- startTHRunnerProcess (jsInterpScript cfg) (jsInterpNodeConfig cfg) + + js_state <- newMVar (JSState + { jsLinkState = emptyLinkPlan + , jsServerStarted = False + }) + + -- get the unit-id of the ghci package. We need this to load the + -- interpreter code. + ghci_unit_id <- case lookupPackageName (ue_homeUnitState unit_env) (PackageName (fsLit "ghci")) of + Nothing -> cmdLineErrorIO "JS interpreter: couldn't find \"ghci\" package" + Just i -> pure i + + let extra = JSInterpExtra + { instStdIn = std_in + , instJSState = js_state + , instFinderCache = finder_cache + , instFinderOpts = finder_opts + , instGhciUnitId = ghci_unit_id + } + + pending_frees <- newMVar [] + let inst = ExtInterpInstance + { instProcess = proc + , instPendingFrees = pending_frees + , instExtra = extra + } + + -- TODO: to support incremental linking of wasm modules (e.g. produced from C + -- sources), we should: + -- + -- 1. link the emcc rts without trimming dead code as we don't know what might + -- be needed later by the Wasm modules we will dynamically load (cf + -- -sMAIN_MODULE). + -- 2. make the RUN_SERVER command wait for the emcc rts to be loaded. + -- 3. link wasm modules with -sSIDE_MODULE + -- 4. add a new command to load side modules with Emscripten's dlopen + -- + -- cf https://emscripten.org/docs/compiling/Dynamic-Linking.html + + -- link rts and its deps + jsLinkRts logger tmpfs tmp_dir codegen_cfg unit_env inst + + -- link interpreter and its deps + jsLinkInterp logger tmpfs tmp_dir codegen_cfg unit_env inst + + -- run interpreter main loop + jsRunServer inst + + pure inst + + + +--------------------------------------------------------- +-- Interpreter commands +--------------------------------------------------------- + +-- | Link JS RTS +jsLinkRts :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> IO () +jsLinkRts logger tmpfs tmp_dir cfg unit_env inst = do + let link_cfg = JSLinkConfig + { lcNoStats = True -- we don't need the stats + , lcNoRts = False -- we need the RTS + , lcCombineAll = False -- we don't need the combined all.js, we'll link each part independently below + , lcForeignRefs = False -- we don't need foreign references + , lcNoJSExecutables = True -- we don't need executables + , lcNoHsMain = True -- nor HsMain + , lcForceEmccRts = False -- nor the emcc rts + , lcLinkCsources = False -- we know that there are no C sources to load for the RTS + } + + -- link the RTS and its dependencies (things it uses from `ghc-internal`, etc.) + let link_spec = LinkSpec + { lks_unit_ids = [rtsUnitId, ghcInternalUnitId] + , lks_obj_root_filter = const False + , lks_extra_roots = mempty + , lks_objs_hs = mempty + , lks_objs_js = mempty + , lks_objs_cc = mempty + } + + let finder_opts = instFinderOpts (instExtra inst) + finder_cache = instFinderCache (instExtra inst) + + ar_cache <- newArchiveCache + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache + jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan + +-- | Link JS interpreter +jsLinkInterp :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> IO () +jsLinkInterp logger tmpfs tmp_dir cfg unit_env inst = do + + let link_cfg = JSLinkConfig + { lcNoStats = True -- we don't need the stats + , lcNoRts = True -- we don't need the RTS + , lcCombineAll = False -- we don't need the combined all.js, we'll link each part independently below + , lcForeignRefs = False -- we don't need foreign references + , lcNoJSExecutables = True -- we don't need executables + , lcNoHsMain = True -- nor HsMain + , lcForceEmccRts = False -- nor the emcc rts + , lcLinkCsources = True -- enable C sources, if any + } + + let is_root _ = True -- FIXME: we shouldn't consider every function as a root + + let ghci_unit_id = instGhciUnitId (instExtra inst) + + -- compute unit dependencies of ghc_unit_id + let unit_map = unitInfoMap (ue_homeUnitState unit_env) + dep_units <- mayThrowUnitErr $ closeUnitDeps unit_map [(ghci_unit_id,Nothing)] + let units = dep_units ++ [ghci_unit_id] + + -- indicate that our root function is GHCi.Server.defaultServer + let root_deps = Set.fromList $ mkExportedFuns ghci_unit_id (fsLit "GHCi.Server") [fsLit "defaultServer"] + + -- link the interpreter and its dependencies + let link_spec = LinkSpec + { lks_unit_ids = units + , lks_obj_root_filter = is_root + , lks_extra_roots = root_deps + , lks_objs_hs = mempty + , lks_objs_js = mempty + , lks_objs_cc = mempty + } + + let finder_cache = instFinderCache (instExtra inst) + finder_opts = instFinderOpts (instExtra inst) + + ar_cache <- newArchiveCache + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache + jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan + + +-- | Link object files +jsLinkObjects :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> [FilePath] -> (ExportedFun -> Bool) -> IO () +jsLinkObjects logger tmpfs tmp_dir cfg unit_env inst objs is_root = do + let link_cfg = JSLinkConfig + { lcNoStats = True -- we don't need the stats + , lcNoRts = True -- we don't need the RTS (already linked) + , lcCombineAll = False -- we don't need the combined all.js, we'll link each part independently below + , lcForeignRefs = False -- we don't need foreign references + , lcNoJSExecutables = True -- we don't need executables + , lcNoHsMain = True -- nor HsMain + , lcForceEmccRts = False -- nor the emcc rts + , lcLinkCsources = True -- enable C sources, if any + } + + let units = preloadUnits (ue_homeUnitState unit_env) + + -- compute dependencies + let link_spec = LinkSpec + { lks_unit_ids = units + , lks_obj_root_filter = is_root + , lks_extra_roots = mempty + , lks_objs_hs = objs + , lks_objs_js = mempty + , lks_objs_cc = mempty + } + + let finder_opts = instFinderOpts (instExtra inst) + finder_cache = instFinderCache (instExtra inst) + + ar_cache <- newArchiveCache + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache + jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan + + + +-- | Link an object file using the given functions as roots +jsLinkObject :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> FilePath -> [ExportedFun] -> IO () +jsLinkObject logger tmpfs tmp_dir cfg unit_env inst obj roots = do + let is_root f = Set.member f (Set.fromList roots) + let objs = [obj] + jsLinkObjects logger tmpfs tmp_dir cfg unit_env inst objs is_root + + +-- | Link the given link plan +-- +-- Perform incremental linking by removing what is already linked from the plan +jsLinkPlan :: Logger -> TmpFs -> TempDir -> ArchiveCache -> JSLinkConfig -> StgToJSConfig -> ExtInterpInstance JSInterpExtra -> LinkPlan -> IO () +jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan = do + ---------------------------------------------------------------- + -- Get already linked stuff and compute incremental plan + ---------------------------------------------------------------- + + old_plan <- jsLinkState <$> readMVar (instJSState (instExtra inst)) + + -- compute new plan discarding what's already linked + let (diff_plan, total_plan) = incrementLinkPlan old_plan link_plan + + ---------------------------------------------------------------- + -- Generate JS code for the incremental plan + ---------------------------------------------------------------- + + tmp_out <- newTempSubDir logger tmpfs tmp_dir + void $ jsLink link_cfg cfg logger tmpfs ar_cache tmp_out diff_plan + + -- Code has been linked into the following files: + -- - generated rts from tmp_out/rts.js (depends on link options) + -- - raw js files from tmp_out/lib.js + -- - Haskell generated JS from tmp_out/out.js + + -- We need to combine at least rts.js and lib.js for the RTS because they + -- depend on each other. We might as well combine them all, so that's what we + -- do. + let filenames + | lcNoRts link_cfg = ["lib.js", "out.js"] + | otherwise = ["rts.js", "lib.js", "out.js"] + let files = map (tmp_out ) filenames + let all_js = tmp_out "all.js" + let all_files = all_js : files + withBinaryFile all_js WriteMode $ \h -> do + let cpy i = B.readFile i >>= B.hPut h + mapM_ cpy files + + -- add files to clean + addFilesToClean tmpfs TFL_CurrentModule all_files + + ---------------------------------------------------------------- + -- Link JS code + ---------------------------------------------------------------- + + -- linking JS code depends on the phase we're in: + -- - during in the initialization phase, we send a LoadFile message to the + -- JS server; + -- - once the Haskell server is started, we send a LoadObj message to the + -- Haskell server. + server_started <- jsServerStarted <$> readMVar (instJSState (instExtra inst)) + if server_started + then sendMessageNoResponse inst $ LoadObj all_js + else jsLoadFile inst all_js + + ---------------------------------------------------------------- + -- update linker state + ---------------------------------------------------------------- + modifyMVar_ (instJSState (instExtra inst)) $ \state -> pure state { jsLinkState = total_plan } + + +-- | Send a command to the JS interpreter +jsSendCommand :: ExtInterpInstance JSInterpExtra -> String -> IO () +jsSendCommand inst cmd = send_cmd cmd + where + extra = instExtra inst + handle = instStdIn extra + send_cmd s = do + withCStringLen s \(p,n) -> hPutBuf handle p n + hFlush handle + +-- | Load a JS file in the interpreter +jsLoadFile :: ExtInterpInstance JSInterpExtra -> FilePath -> IO () +jsLoadFile inst path = jsSendCommand inst ("LOAD " ++ path ++ "\n") + +-- | Run JS server +jsRunServer :: ExtInterpInstance JSInterpExtra -> IO () +jsRunServer inst = do + let ghci_unit_id = instGhciUnitId (instExtra inst) + let zghci_unit_id = zString (zEncodeFS (unitIdFS ghci_unit_id)) + + -- Run `GHCi.Server.defaultServer` + jsSendCommand inst ("RUN_SERVER " ++ zghci_unit_id ++ "\n") + + -- indicate that the Haskell server is now started + modifyMVar_ (instJSState (instExtra inst)) $ \state -> pure state { jsServerStarted = True } diff --git a/GHC/Runtime/Interpreter/Process.hs b/GHC/Runtime/Interpreter/Process.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter/Process.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE LambdaCase #-} +module GHC.Runtime.Interpreter.Process + ( + -- * Message API + Message(..) + , DelayedResponse (..) + -- * Top-level message API (these acquire/release a lock) + , sendMessage + , sendMessageNoResponse + , sendMessageDelayedResponse + , receiveDelayedResponse + -- * Nested message API (these require the interpreter to already be locked) + , sendAnyValue + , receiveAnyValue + , receiveTHMessage + ) +where + +import GHC.Prelude + +import GHC.Runtime.Interpreter.Types +import GHCi.Message + +import GHC.IO (catchException) +import GHC.Utils.Panic +import GHC.Utils.Exception as Ex + +import Data.Binary +import System.Exit +import System.Process +import Control.Concurrent.MVar (MVar, withMVar, takeMVar, putMVar, isEmptyMVar) + +data DelayedResponse a = DelayedResponse + +-- ----------------------------------------------------------------------------- +-- Top-level Message API + +-- | Send a message to the interpreter process that doesn't expect a response +-- (locks the interpreter while sending) +sendMessageNoResponse :: ExtInterpInstance d -> Message () -> IO () +sendMessageNoResponse i m = + withLock i $ writeInterpProcess (instProcess i) (putMessage m) + +-- | Send a message to the interpreter that expects a response +-- (locks the interpreter while until the response is received) +sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a +sendMessage i m = withLock i $ callInterpProcess (instProcess i) m + +-- | Send a message to the interpreter process whose response is expected later +-- +-- This is useful to avoid forgetting to receive the value and to ensure that +-- the type of the response isn't lost. Use receiveDelayedResponse to read it. +-- (locks the interpreter until the response is received using +-- `receiveDelayedResponse`) +sendMessageDelayedResponse :: ExtInterpInstance d -> Message a -> IO (DelayedResponse a) +sendMessageDelayedResponse i m = do + lock i + writeInterpProcess (instProcess i) (putMessage m) + pure DelayedResponse + +-- | Expect a delayed result to be received now +receiveDelayedResponse :: Binary a => ExtInterpInstance d -> DelayedResponse a -> IO a +receiveDelayedResponse i DelayedResponse = do + ensureLocked i + r <- readInterpProcess (instProcess i) get + unlock i + pure r + +-- ----------------------------------------------------------------------------- +-- Nested Message API + +-- | Send any value (requires locked interpreter) +sendAnyValue :: Binary a => ExtInterpInstance d -> a -> IO () +sendAnyValue i m = ensureLocked i >> writeInterpProcess (instProcess i) (put m) + +-- | Expect a value to be received (requires locked interpreter) +receiveAnyValue :: ExtInterpInstance d -> Get a -> IO a +receiveAnyValue i get = ensureLocked i >> readInterpProcess (instProcess i) get + +-- | Wait for a Template Haskell message (requires locked interpreter) +receiveTHMessage :: ExtInterpInstance d -> IO THMsg +receiveTHMessage i = ensureLocked i >> receiveAnyValue i getTHMessage + +-- ----------------------------------------------------------------------------- + +getLock :: ExtInterpInstance d -> MVar () +getLock = interpLock . instProcess + +withLock :: ExtInterpInstance d -> IO a -> IO a +withLock i f = withMVar (getLock i) (const f) + +lock :: ExtInterpInstance d -> IO () +lock i = takeMVar (getLock i) + +unlock :: ExtInterpInstance d -> IO () +unlock i = putMVar (getLock i) () + +ensureLocked :: ExtInterpInstance d -> IO () +ensureLocked i = + isEmptyMVar (getLock i) >>= \case + False -> panic "ensureLocked: external interpreter not locked" + _ -> pure () + + +-- | Send a 'Message' and receive the response from the interpreter process +callInterpProcess :: Binary a => InterpProcess -> Message a -> IO a +callInterpProcess i msg = + remoteCall (interpPipe i) msg + `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e + +-- | Read a value from the interpreter process +readInterpProcess :: InterpProcess -> Get a -> IO a +readInterpProcess i get = + readPipe (interpPipe i) get + `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e + +-- | Send a value to the interpreter process +writeInterpProcess :: InterpProcess -> Put -> IO () +writeInterpProcess i put = + writePipe (interpPipe i) put + `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e + +handleInterpProcessFailure :: InterpProcess -> SomeException -> IO a +handleInterpProcessFailure i e = do + let hdl = interpHandle i + ex <- getProcessExitCode hdl + case ex of + Just (ExitFailure n) -> + throwIO (InstallationError ("External interpreter terminated (" ++ show n ++ ")")) + _ -> do + terminateProcess hdl + _ <- waitForProcess hdl + throw e diff --git a/GHC/Runtime/Interpreter/Types.hs b/GHC/Runtime/Interpreter/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter/Types.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Types used by the runtime interpreter +module GHC.Runtime.Interpreter.Types + ( Interp(..) + , InterpInstance(..) + , InterpProcess (..) + , ExtInterp (..) + , ExtInterpStatusVar + , ExtInterpInstance (..) + , ExtInterpState (..) + , InterpStatus(..) + -- * InterpSymbolCache + , InterpSymbolCache(..) + , mkInterpSymbolCache + , lookupInterpSymbolCache + , updateInterpSymbolCache + , purgeInterpSymbolCache + , InterpSymbol(..) + , SuffixOrInterpreted(..) + , interpSymbolName + , interpSymbolSuffix + , eliminateInterpSymbol + , interpretedInterpSymbol + , interpreterProfiled + , interpreterDynamic + + -- * IServ + , IServ + , IServConfig(..) + -- * JSInterp + , JSInterp + , JSInterpExtra (..) + , JSInterpConfig (..) + , JSState (..) + , NodeJsSettings (..) + , defaultNodeJsSettings + , WasmInterp + , WasmInterpConfig (..) + ) +where + +import GHC.Prelude +import GHC.Linker.Types + +import GHCi.RemoteTypes +import GHCi.Message ( Pipe ) + +import GHC.Platform +#if defined(HAVE_INTERNAL_INTERPRETER) +import GHC.Platform.Ways +#endif +import GHC.Utils.TmpFs +import GHC.Utils.Logger +import GHC.Unit.Env +import GHC.Unit.State +import GHC.Unit.Types +import GHC.StgToJS.Types +import GHC.StgToJS.Linker.Types +import GHC.Runtime.Interpreter.Types.SymbolCache + +import Control.Concurrent +import System.Process ( ProcessHandle, CreateProcess ) +import System.IO +import GHC.Unit.Finder.Types (FinderCache, FinderOpts) + +-- | Interpreter +data Interp = Interp + { interpInstance :: !InterpInstance + -- ^ Interpreter instance (internal, external) + + , interpLoader :: !Loader + -- ^ Interpreter loader + + , interpSymbolCache :: !InterpSymbolCache + -- ^ LookupSymbol cache + } + +data InterpInstance + = ExternalInterp !ExtInterp -- ^ External interpreter +#if defined(HAVE_INTERNAL_INTERPRETER) + | InternalInterp -- ^ Internal interpreter +#endif + +data ExtInterp + = ExtIServ !IServ + | ExtJS !JSInterp + | ExtWasm !WasmInterp + +-- | External interpreter +-- +-- The external interpreter is spawned lazily (on first use) to avoid slowing +-- down sessions that don't require it. The contents of the MVar reflects the +-- state of the interpreter (running or not). +data ExtInterpState cfg details = ExtInterpState + { interpConfig :: !cfg + , interpStatus :: !(ExtInterpStatusVar details) + } + +type ExtInterpStatusVar d = MVar (InterpStatus (ExtInterpInstance d)) + +type IServ = ExtInterpState IServConfig () +type JSInterp = ExtInterpState JSInterpConfig JSInterpExtra +type WasmInterp = ExtInterpState WasmInterpConfig () + +data InterpProcess = InterpProcess + { interpPipe :: !Pipe -- ^ Pipe to communicate with the server + , interpHandle :: !ProcessHandle -- ^ Process handle of the server + , interpLock :: !(MVar ()) -- ^ Lock to prevent concurrent access to the stream + } + +-- | Status of an external interpreter +data InterpStatus inst + = InterpPending -- ^ Not spawned yet + | InterpRunning !inst -- ^ Running + +-- | Configuration needed to spawn an external interpreter +data IServConfig = IServConfig + { iservConfProgram :: !String -- ^ External program to run + , iservConfOpts :: ![String] -- ^ Command-line options + , iservConfProfiled :: !Bool -- ^ Use Profiling way + , iservConfDynamic :: !Bool -- ^ Use Dynamic way + , iservConfHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) -- ^ Hook + , iservConfTrace :: IO () -- ^ Trace action executed after spawn + } + +-- | Common field between native external interpreter and the JS one +data ExtInterpInstance c = ExtInterpInstance + { instProcess :: {-# UNPACK #-} !InterpProcess + -- ^ External interpreter process and its pipe (communication channel) + + , instPendingFrees :: !(MVar [HValueRef]) + -- ^ Values that need to be freed before the next command is sent. + -- Finalizers for ForeignRefs can append values to this list + -- asynchronously. + + , instExtra :: !c + -- ^ Instance specific extra fields + } + +-- | Interpreter uses Profiling way +interpreterProfiled :: Interp -> Bool +interpreterProfiled interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsProfiled +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfProfiled (interpConfig i) + ExtJS {} -> False -- we don't support profiling yet in the JS backend + ExtWasm i -> wasmInterpProfiled $ interpConfig i + +-- | Interpreter uses Dynamic way +interpreterDynamic :: Interp -> Bool +interpreterDynamic interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsDynamic +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfDynamic (interpConfig i) + ExtJS {} -> False -- dynamic doesn't make sense for JS + ExtWasm {} -> True -- wasm dyld can only load dynamic code + +------------------------ +-- JS Stuff +------------------------ + +data JSInterpExtra = JSInterpExtra + { instStdIn :: !Handle -- ^ Stdin for the process + , instFinderCache :: !FinderCache + , instFinderOpts :: !FinderOpts + , instJSState :: !(MVar JSState) -- ^ Mutable state + , instGhciUnitId :: !UnitId -- ^ GHCi unit-id + } + +data JSState = JSState + { jsLinkState :: !LinkPlan -- ^ Linker state of the interpreter + , jsServerStarted :: !Bool -- ^ Is the Haskell server started? + } + +-- | NodeJs configuration +data NodeJsSettings = NodeJsSettings + { nodeProgram :: FilePath -- ^ location of node.js program + , nodePath :: Maybe FilePath -- ^ value of NODE_PATH environment variable (search path for Node modules; GHCJS used to provide some) + , nodeExtraArgs :: [String] -- ^ extra arguments to pass to node.js + , nodeKeepAliveMaxMem :: Integer -- ^ keep node.js (TH, GHCJSi) processes alive if they don't use more than this + } + +defaultNodeJsSettings :: NodeJsSettings +defaultNodeJsSettings = NodeJsSettings + { nodeProgram = "node" + , nodePath = Nothing + , nodeExtraArgs = [] + , nodeKeepAliveMaxMem = 536870912 + } + + +data JSInterpConfig = JSInterpConfig + { jsInterpNodeConfig :: !NodeJsSettings -- ^ NodeJS settings + , jsInterpScript :: !FilePath -- ^ Path to "ghc-interp.js" script + , jsInterpTmpFs :: !TmpFs + , jsInterpTmpDir :: !TempDir + , jsInterpLogger :: !Logger + , jsInterpCodegenCfg :: !StgToJSConfig + , jsInterpUnitEnv :: !UnitEnv + , jsInterpFinderOpts :: !FinderOpts + , jsInterpFinderCache :: !FinderCache + } + +------------------------ +-- Wasm Stuff +------------------------ + +data WasmInterpConfig = WasmInterpConfig + { wasmInterpDyLD :: !FilePath -- ^ Location of dyld.mjs script + , wasmInterpLibDir :: FilePath -- ^ wasi-sdk sysroot libdir containing libc.so, etc + , wasmInterpOpts :: ![String] -- ^ Additional command line arguments for iserv + + -- wasm ghci browser mode + , wasmInterpBrowser :: !Bool + , wasmInterpBrowserHost :: !String + , wasmInterpBrowserPort :: !Int + , wasmInterpBrowserRedirectWasiConsole :: !Bool + , wasmInterpBrowserPuppeteerLaunchOpts :: !(Maybe String) + , wasmInterpBrowserPlaywrightBrowserType :: !(Maybe String) + , wasmInterpBrowserPlaywrightLaunchOpts :: !(Maybe String) + + , wasmInterpTargetPlatform :: !Platform + , wasmInterpProfiled :: !Bool -- ^ Are we profiling yet? + , wasmInterpHsSoSuffix :: !String -- ^ Shared lib filename common suffix sans .so, e.g. p-ghc9.13.20241001 + , wasmInterpUnitState :: !UnitState + } diff --git a/GHC/Runtime/Interpreter/Types/SymbolCache.hs b/GHC/Runtime/Interpreter/Types/SymbolCache.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter/Types/SymbolCache.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} + +-- | The SymbolCache is used to cache lookups for specific symbols when using +-- the interpreter. +module GHC.Runtime.Interpreter.Types.SymbolCache ( + InterpSymbolCache(..) + , mkInterpSymbolCache + , lookupInterpSymbolCache + , updateInterpSymbolCache + , purgeInterpSymbolCache + , InterpSymbol(..) + , SuffixOrInterpreted(..) + , interpSymbolName + , interpSymbolSuffix + , eliminateInterpSymbol + , interpretedInterpSymbol + ) where + +import GHC.Prelude + +import GHC.Types.Unique.FM +import GHC.Types.Name +import GHC.Data.FastString +import Foreign + +import Control.Concurrent +import GHC.Utils.Outputable +import GHC.TypeLits + + +-- The symbols records the suffix which each cache deals with. +newtype SymbolCache (s :: Symbol) = SymbolCache { _getSymbolCache :: UniqFM Name (Ptr ()) } + +-- Each cache is keyed by Name, there is one cache for each type of symbol we will +-- potentially lookup. The caches are keyed by 'Name' so that it is not necessary to consult +-- a complicated `FastString` each time. +data InterpSymbolCache = InterpSymbolCache { + interpClosureCache :: MVar (SymbolCache "closure") + , interpConInfoCache :: MVar (SymbolCache "con_info") + , interpStaticInfoCache :: MVar (SymbolCache "static_info") + , interpBytesCache :: MVar (SymbolCache "bytes") + , interpFaststringCache :: MVar (UniqFM FastString (Ptr ())) + } + +data SuffixOrInterpreted = Suffix Symbol | Interpreted + +data InterpSymbol (s :: SuffixOrInterpreted) where + IClosureSymbol :: Name -> InterpSymbol (Suffix "closure") + IConInfoSymbol :: Name -> InterpSymbol (Suffix "con_info") + IStaticInfoSymbol :: Name -> InterpSymbol (Suffix "static_info") + IBytesSymbol :: Name -> InterpSymbol (Suffix "bytes") + IFaststringSymbol :: FastString -> InterpSymbol Interpreted + +instance Outputable (InterpSymbol s) where + ppr s = eliminateInterpSymbol s + (\(IFaststringSymbol s) -> text "interpreted:" <> ppr s) + (\s -> text (interpSymbolSuffix s) <> colon <> ppr (interpSymbolName s)) + +eliminateInterpSymbol :: InterpSymbol s -> (InterpSymbol Interpreted -> r) + -> (forall x . InterpSymbol (Suffix x) -> r) + -> r +eliminateInterpSymbol s k1 k2 = + case s of + IFaststringSymbol {} -> k1 s + IBytesSymbol {} -> k2 s + IStaticInfoSymbol {} -> k2 s + IConInfoSymbol {} -> k2 s + IClosureSymbol {} -> k2 s + + +interpSymbolName :: InterpSymbol (Suffix s) -> Name +interpSymbolName (IClosureSymbol n) = n +interpSymbolName (IConInfoSymbol n) = n +interpSymbolName (IStaticInfoSymbol n) = n +interpSymbolName (IBytesSymbol n) = n + +interpretedInterpSymbol :: InterpSymbol Interpreted -> FastString +interpretedInterpSymbol (IFaststringSymbol s) = s + +interpSymbolSuffix :: InterpSymbol (Suffix s) -> String +interpSymbolSuffix (IClosureSymbol {}) = "closure" +interpSymbolSuffix (IConInfoSymbol {}) = "con_info" +interpSymbolSuffix (IStaticInfoSymbol {}) = "static_info" +interpSymbolSuffix (IBytesSymbol {}) = "bytes" + +emptySymbolCache :: SymbolCache s +emptySymbolCache = SymbolCache emptyUFM + +lookupSymbolCache :: InterpSymbol (Suffix s) -> SymbolCache s -> Maybe (Ptr ()) +lookupSymbolCache s (SymbolCache cache) = lookupUFM cache (interpSymbolName s) + +insertSymbolCache :: InterpSymbol (Suffix s) -> Ptr () -> SymbolCache s -> SymbolCache s +insertSymbolCache s v (SymbolCache cache) = SymbolCache (addToUFM cache (interpSymbolName s) v) + +lookupInterpSymbolCache :: InterpSymbol s -> InterpSymbolCache -> IO (Maybe (Ptr ())) +lookupInterpSymbolCache = withInterpSymbolCache + (\(IFaststringSymbol f) mvar_var -> (\cache -> lookupUFM cache f) <$> readMVar mvar_var) + (\s mvar_var -> lookupSymbolCache s <$> readMVar mvar_var) + + +updateInterpSymbolCache :: InterpSymbol s + -> InterpSymbolCache -> Ptr () -> IO () +updateInterpSymbolCache = withInterpSymbolCache + (\(IFaststringSymbol f) mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ addToUFM cache f v)) + (\s mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ insertSymbolCache s v cache)) + +withInterpSymbolCache :: + (InterpSymbol Interpreted -> MVar (UniqFM FastString (Ptr ())) -> r) + -> (forall x . InterpSymbol (Suffix x) -> MVar (SymbolCache x) -> r) + -> InterpSymbol s + -> InterpSymbolCache + -> r +withInterpSymbolCache k1 k2 key InterpSymbolCache{..} = + case key of + IClosureSymbol {} -> k2 key interpClosureCache + IConInfoSymbol {} -> k2 key interpConInfoCache + IStaticInfoSymbol {} -> k2 key interpStaticInfoCache + IBytesSymbol {} -> k2 key interpBytesCache + IFaststringSymbol {} -> k1 key interpFaststringCache + +-- | Clear all symbol caches. +purgeInterpSymbolCache :: InterpSymbolCache -> IO () +purgeInterpSymbolCache (InterpSymbolCache a b c d e) = do + modifyMVar_ a (\_ -> do + modifyMVar_ b (\_ -> do + modifyMVar_ c (\_ -> do + modifyMVar_ d (\_ -> do + modifyMVar_ e (\_ -> pure emptyUFM) + pure emptySymbolCache) + pure emptySymbolCache) + pure emptySymbolCache) + pure emptySymbolCache) + +mkInterpSymbolCache :: IO InterpSymbolCache +mkInterpSymbolCache = do + InterpSymbolCache <$> newMVar emptySymbolCache + <*> newMVar emptySymbolCache + <*> newMVar emptySymbolCache + <*> newMVar emptySymbolCache + <*> newMVar emptyUFM diff --git a/GHC/Runtime/Interpreter/Wasm.hs b/GHC/Runtime/Interpreter/Wasm.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter/Wasm.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Runtime.Interpreter.Wasm (spawnWasmInterp) where + +import GHC.Prelude +import GHC.Runtime.Interpreter.Types + +#if !defined(mingw32_HOST_OS) + +import Control.Concurrent.MVar +import Data.Maybe +import GHC.Data.FastString +import qualified GHC.Data.ShortText as ST +import GHC.Platform +import GHC.Unit +import GHCi.Message +import System.Directory +import System.Environment.Blank +import System.IO +import qualified System.Posix.IO as Posix +import System.Process + +#else + +import GHC.Utils.Panic + +#endif + +spawnWasmInterp :: WasmInterpConfig -> IO (ExtInterpInstance ()) + +#if !defined(mingw32_HOST_OS) + +-- See Note [The Wasm Dynamic Linker] for details +spawnWasmInterp WasmInterpConfig {..} = do + let Just ghci_unit_id = + lookupPackageName + wasmInterpUnitState + (PackageName $ fsLit "ghci") + ghci_unit_info = unsafeLookupUnitId wasmInterpUnitState ghci_unit_id + ghci_so_dirs = map ST.unpack $ unitLibraryDynDirs ghci_unit_info + [ghci_lib_name] = map ST.unpack $ unitLibraries ghci_unit_info + ghci_so_name = ghci_lib_name ++ wasmInterpHsSoSuffix + ghci_so_file = platformHsSOName wasmInterpTargetPlatform ghci_so_name + Just ghci_so_path <- findFile ghci_so_dirs ghci_so_file + (rfd1, wfd1) <- Posix.createPipe + (rfd2, wfd2) <- Posix.createPipe + Posix.setFdOption rfd1 Posix.CloseOnExec True + Posix.setFdOption wfd2 Posix.CloseOnExec True + ghc_env <- getEnvironment + let dyld_env = + [("GHCI_BROWSER", "1") | wasmInterpBrowser] + ++ [("GHCI_BROWSER_HOST", wasmInterpBrowserHost), ("GHCI_BROWSER_PORT", show wasmInterpBrowserPort)] + ++ [("GHCI_BROWSER_REDIRECT_WASI_CONSOLE", "1") | wasmInterpBrowserRedirectWasiConsole] + ++ [("GHCI_BROWSER_PUPPETEER_LAUNCH_OPTS", f) | f <- maybeToList wasmInterpBrowserPuppeteerLaunchOpts] + ++ [("GHCI_BROWSER_PLAYWRIGHT_BROWSER_TYPE", f) | f <- maybeToList wasmInterpBrowserPlaywrightBrowserType] + ++ [("GHCI_BROWSER_PLAYWRIGHT_LAUNCH_OPTS", f) | f <- maybeToList wasmInterpBrowserPlaywrightLaunchOpts] + ++ ghc_env + (_, _, _, ph) <- + createProcess + ( proc wasmInterpDyLD $ + [wasmInterpLibDir, ghci_so_path, show wfd1, show rfd2] + ++ wasmInterpOpts + ++ ["+RTS", "-H64m", "-RTS"] + ) { env = Just dyld_env } + Posix.closeFd wfd1 + Posix.closeFd rfd2 + rh <- Posix.fdToHandle rfd1 + wh <- Posix.fdToHandle wfd2 + hSetBuffering wh NoBuffering + hSetBuffering rh NoBuffering + interpPipe <- mkPipeFromHandles rh wh + pending_frees <- newMVar [] + lock <- newMVar () + pure + $ ExtInterpInstance + { instProcess = + InterpProcess + { interpHandle = ph, + interpPipe, + interpLock = lock + }, + instPendingFrees = pending_frees, + instExtra = () + } + +#else + +-- Due to difficulty of using inherited pipe file descriptor in +-- nodejs, unfortunately we don't support Win32 host yet +spawnWasmInterp _ = sorry "Wasm iserv doesn't work on Win32 host yet" + +#endif diff --git a/GHC/Runtime/Loader.hs b/GHC/Runtime/Loader.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Loader.hs @@ -0,0 +1,385 @@ + + +-- | Dynamically lookup up values from modules and loading them. +module GHC.Runtime.Loader ( + initializePlugins, initializeSessionPlugins, + -- * Loading plugins + loadFrontendPlugin, + + -- * Force loading information + forceLoadModuleInterfaces, + forceLoadNameModuleInterface, + forceLoadTyCon, + + -- * Finding names + lookupRdrNameInModuleForPlugins, + + -- * Loading values + getValueSafely, + getHValueSafely, + lessUnsafeCoerce + ) where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Driver.DynFlags +import GHC.Driver.Ppr +import GHC.Driver.Hooks +import GHC.Driver.Plugins +import GHC.Driver.Plugins.External + +import GHC.Linker.Loader ( loadModule, loadName ) +import GHC.Runtime.Interpreter ( wormhole ) +import GHC.Runtime.Interpreter.Types + +import GHC.Rename.Names ( gresFromAvails ) + +import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn ) +import GHC.Iface.Load ( loadPluginInterface, cannotFindModule ) +import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) + +import GHC.Driver.Env +import GHCi.RemoteTypes ( HValue ) +import GHC.Core.Type ( Type, mkTyConTy ) +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCon ( TyCon(tyConName) ) + + +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Types.Name ( Name, nameModule, nameModule_maybe ) +import GHC.Types.Id ( idType ) +import GHC.Types.PkgQual +import GHC.Types.TyThing +import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS ) +import GHC.Types.Name.Reader +import GHC.Types.Unique.DFM + +import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) +import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts ) +import GHC.Unit.Module ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit), IsBootInterface(NotBoot) ) +import GHC.Unit.Module.ModIface +import GHC.Unit.Env + +import GHC.Utils.Panic +import GHC.Utils.Logger +import GHC.Utils.Misc ( HasDebugCallStack ) +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Exception + +import Control.Monad ( unless ) +import Data.Maybe ( mapMaybe ) +import Unsafe.Coerce ( unsafeCoerce ) +import GHC.Linker.Types +import Data.List (unzip4) +import GHC.Iface.Errors.Ppr +import GHC.Driver.Monad + +{- Note [Timing of plugin initialization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Plugins needs to be initialised as soon as possible in the pipeline. This is because +driver plugins are executed immediately after being loaded, which can modify anything +in the HscEnv, including the logger and DynFlags (for example #21279). For example, +in ghc/Main.hs the logger is used almost immediately after the session has been initialised +and so if a user overwrites the logger expecting all output to go there then unless +the plugins are initialised before that point then unexpected things will happen. + +We initialise plugins in ghc/Main.hs for the main ghc executable. + +When people are using the GHC API, they also need to initialise plugins +at the highest level possible for things to work as expected. We keep +some defensive calls to plugin initialisation in functions like `load'` and `oneshot` +to catch cases where API users have not initialised their own plugins. + +In addition to this, there needs to be an initialisation call for each module +just in case the user has enabled a plugin just for that module using OPTIONS_GHC +pragma. + +-} + +-- | Initialise plugins specified by the current DynFlags and update the session. +initializeSessionPlugins :: GhcMonad m => m () +initializeSessionPlugins = getSession >>= liftIO . initializePlugins >>= setSession + +-- | Loads the plugins specified in the pluginModNames field of the dynamic +-- flags. Should be called after command line arguments are parsed, but before +-- actual compilation starts. Idempotent operation. Should be re-called if +-- pluginModNames or pluginModNameOpts changes. +initializePlugins :: HscEnv -> IO HscEnv +initializePlugins hsc_env + -- check that plugin specifications didn't change + + -- dynamic plugins + | loaded_plugins <- loadedPlugins (hsc_plugins hsc_env) + , map lpModuleName loaded_plugins == reverse (pluginModNames dflags) + , all same_args loaded_plugins + + -- external plugins + , external_plugins <- externalPlugins (hsc_plugins hsc_env) + , check_external_plugins external_plugins (externalPluginSpecs dflags) + + -- ensure we have initialised static plugins + , all spInitialised (staticPlugins (hsc_plugins hsc_env)) + + = return hsc_env -- no change, no need to reload plugins + + | otherwise + = do (loaded_plugins, links, pkgs) <- loadPlugins hsc_env + external_plugins <- loadExternalPlugins (externalPluginSpecs dflags) + let plugins' = (hsc_plugins hsc_env) { staticPlugins = map (\sp -> sp{ spInitialised = True }) $ staticPlugins (hsc_plugins hsc_env) + , externalPlugins = external_plugins + , loadedPlugins = loaded_plugins + , loadedPluginDeps = (links, pkgs) + } + let hsc_env' = hsc_env { hsc_plugins = plugins' } + withPlugins (hsc_plugins hsc_env') driverPlugin hsc_env' + where + dflags = hsc_dflags hsc_env + -- dynamic plugins + plugin_args = pluginModNameOpts dflags + same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args + argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) + -- external plugins + check_external_plugin p spec = and + [ epUnit p == esp_unit_id spec + , epModule p == esp_module spec + , paArguments (epPlugin p) == esp_args spec + ] + check_external_plugins eps specs = case (eps,specs) of + ([] , []) -> True + (_ , []) -> False -- some external plugin removed + ([] , _ ) -> False -- some external plugin added + (p:ps,s:ss) -> check_external_plugin p s && check_external_plugins ps ss + +loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded) +loadPlugins hsc_env + = do { unless (null to_load) $ + checkExternalInterpreter hsc_env + ; plugins_with_deps <- mapM loadPlugin to_load + ; let (plugins, ifaces, links, pkgs) = unzip4 plugins_with_deps + ; return (zipWith attachOptions to_load (zip plugins ifaces), concat links, foldl' plusUDFM emptyUDFM pkgs) + } + where + dflags = hsc_dflags hsc_env + to_load = reverse $ pluginModNames dflags + + attachOptions mod_nm (plug, mod) = + LoadedPlugin (PluginWithArgs plug (reverse options)) mod + where + options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags + , opt_mod_nm == mod_nm ] + loadPlugin = loadPlugin' (mkVarOccFS (fsLit "plugin")) pluginTyConName hsc_env + + +loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded) +loadFrontendPlugin hsc_env mod_name = do + checkExternalInterpreter hsc_env + (plugin, _iface, links, pkgs) + <- loadPlugin' (mkVarOccFS (fsLit "frontendPlugin")) frontendPluginTyConName + hsc_env mod_name + return (plugin, links, pkgs) + +-- #14335 +checkExternalInterpreter :: HscEnv -> IO () +checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of + Just (ExternalInterp {}) + -> throwIO (InstallationError "Plugins require -fno-external-interpreter") + _ -> pure () + +loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [Linkable], PkgsLoaded) +loadPlugin' occ_name plugin_name hsc_env mod_name + = do { let plugin_rdr_name = mkRdrQual mod_name occ_name + dflags = hsc_dflags hsc_env + ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name + plugin_rdr_name + ; case mb_name of { + Nothing -> + throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep + [ text "The module", ppr mod_name + , text "did not export the plugin name" + , ppr plugin_rdr_name ]) ; + Just (name, mod_iface) -> + + do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name + ; case thisGhcUnit == (moduleUnit . nameModule . tyConName) plugin_tycon of { + False -> + throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep + [ text "The plugin module", ppr mod_name + , text "was built with a compiler that is incompatible with the one loading it" + ]) ; + True -> + do { eith_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) + ; case eith_plugin of + Left actual_type -> + throwGhcExceptionIO (CmdLineError $ + showSDocForUser dflags (ue_homeUnitState (hsc_unit_env hsc_env)) + alwaysQualify $ hsep + [ text "The value", ppr name + , text "with type", ppr actual_type + , text "did not have the type" + , text "GHC.Plugins.Plugin" + , text "as required"]) + Right (plugin, links, pkgs) -> return (plugin, mod_iface, links, pkgs) } } } } } + + +-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () +forceLoadModuleInterfaces hsc_env doc modules + = (initTcInteractive hsc_env $ + initIfaceTcRn $ + mapM_ (loadPluginInterface doc) modules) + >> return () + +-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO () +forceLoadNameModuleInterface hsc_env reason name = do + let name_modules = mapMaybe nameModule_maybe [name] + forceLoadModuleInterfaces hsc_env reason name_modules + +-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if: +-- +-- * The interface could not be loaded +-- * The name is not that of a 'TyCon' +-- * The name did not exist in the loaded module +forceLoadTyCon :: HscEnv -> Name -> IO TyCon +forceLoadTyCon hsc_env con_name = do + forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name + + mb_con_thing <- lookupType hsc_env con_name + case mb_con_thing of + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name + Just (ATyCon tycon) -> return tycon + Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing + where dflags = hsc_dflags hsc_env + +-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety +-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! +-- +-- If the value found was not of the correct type, returns @Left @. Any other condition results in an exception: +-- +-- * If we could not load the names module +-- * If the thing being loaded is not a value +-- * If the Name does not exist in the module +-- * If the link failed + +getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded)) +getValueSafely hsc_env val_name expected_type = do + eith_hval <- case getValueSafelyHook hooks of + Nothing -> getHValueSafely interp hsc_env val_name expected_type + Just h -> h hsc_env val_name expected_type + case eith_hval of + Left actual_type -> return (Left actual_type) + Right (hval, links, pkgs) -> do + value <- lessUnsafeCoerce logger "getValueSafely" hval + return (Right (value, links, pkgs)) + where + interp = hscInterp hsc_env + logger = hsc_logger hsc_env + hooks = hsc_hooks hsc_env + +getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded)) +getHValueSafely interp hsc_env val_name expected_type = do + forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name + -- Now look up the names for the value and type constructor in the type environment + mb_val_thing <- lookupType hsc_env val_name + case mb_val_thing of + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name + Just (AnId id) -> do + -- Check the value type in the interface against the type recovered from the type constructor + -- before finally casting the value to the type we assume corresponds to that constructor + if expected_type `eqType` idType id + then do + -- Link in the module that contains the value, if it has such a module + case nameModule_maybe val_name of + Just mod -> do loadModule interp hsc_env mod + return () + Nothing -> return () + -- Find the value that we just linked in and cast it given that we have proved it's type + hval <- do + (v, links, pkgs) <- loadName interp hsc_env val_name + hv <- wormhole interp v + return (hv, links, pkgs) + return (Right hval) + else return (Left (idType id)) + Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing + where dflags = hsc_dflags hsc_env + +-- | Coerce a value as usual, but: +-- +-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong +-- +-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened +-- if it /does/ segfault +lessUnsafeCoerce :: Logger -> String -> a -> IO b +lessUnsafeCoerce logger context what = do + debugTraceMsg logger 3 $ + (text "Coercing a value in") <+> (text context) <> (text "...") + output <- evaluate (unsafeCoerce what) + debugTraceMsg logger 3 (text "Successfully evaluated coercion") + return output + + +-- | Finds the 'Name' corresponding to the given 'RdrName' in the +-- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name' +-- could be found. Any other condition results in an exception: +-- +-- * If the module could not be found +-- * If we could not determine the imports of the module +-- +-- Can only be used for looking up names while loading plugins (and is +-- *not* suitable for use within plugins). The interface file is +-- loaded very partially: just enough that it can be used, without its +-- rules and instances affecting (and being linked from!) the module +-- being compiled. This was introduced by 57d6798. +-- +-- Need the module as well to record information in the interface file +lookupRdrNameInModuleForPlugins :: HasDebugCallStack + => HscEnv -> ModuleName -> RdrName + -> IO (Maybe (Name, ModIface)) +lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do + let dflags = hsc_dflags hsc_env + -- First find the unit the module resides in by searching exposed units and home modules + found_module <- findPluginModule hsc_env mod_name + case found_module of + Found _ mod -> do + -- Find the exports of the module + (_, mb_iface) <- initTcInteractive hsc_env $ + initIfaceTcRn $ + loadPluginInterface doc mod + case mb_iface of + Just iface -> do + -- Try and find the required name in the exports + let decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod_name, is_pkg_qual = NoPkgQual + , is_qual = False, is_dloc = noSrcSpan, is_isboot = NotBoot, is_level = SpliceLevel } + imp_spec = ImpSpec decl_spec ImpAll + env = mkGlobalRdrEnv + $ gresFromAvails hsc_env (Just imp_spec) (mi_exports iface) + case lookupGRE env (LookupRdrName rdr_name (RelevantGREsFOS WantNormal)) of + [gre] -> return (Just (greName gre, iface)) + [] -> return Nothing + _ -> panic "lookupRdrNameInModule" + + Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] + err -> + let opts = initIfaceMessageOpts dflags + err_txt = missingInterfaceErrorDiagnostic opts + $ cannotFindModule hsc_env mod_name err + in throwCmdLineErrorS dflags err_txt + where + doc = text "contains a name used in an invocation of lookupRdrNameInModule" + +wrongTyThingError :: Name -> TyThing -> SDoc +wrongTyThingError name got_thing = hsep [text "The name", ppr name, text "is not that of a value but rather a", pprTyThingCategory got_thing] + +missingTyThingError :: Name -> SDoc +missingTyThingError name = hsep [text "The name", ppr name, text "is not in the type environment: are you sure it exists?"] + +throwCmdLineErrorS :: DynFlags -> SDoc -> IO a +throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags + +throwCmdLineError :: String -> IO a +throwCmdLineError = throwGhcExceptionIO . CmdLineError diff --git a/GHC/Runtime/Utils.hs b/GHC/Runtime/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Utils.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} + +module GHC.Runtime.Utils + ( runWithPipes + ) +where + +import GHC.Prelude + +#if defined(mingw32_HOST_OS) +import Foreign.C +import GHC.IO.Handle.FD (fdToHandle) +import GHC.Utils.Exception as Ex +# if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem (()) +import GHC.IO.Handle.Windows (handleToHANDLE) +import GHC.Event.Windows (associateHandle') +# endif +#else +import System.Posix as Posix +#endif +import System.Process +import System.IO + +runWithPipes :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> [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 CIntPtr + +runWithPipesPOSIX :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle) +runWithPipesPOSIX createProc prog pre_opts 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 = pre_opts ++ (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) + +# if defined (__IO_MANAGER_WINIO__) +runWithPipesNative :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle) +runWithPipesNative createProc prog pre_opts opts = do + (rh, wfd1) <- createPipe -- we read on rfd1 + (rfd2, wh) <- createPipe -- we write on wfd2 + wh_client <- handleToHANDLE wfd1 + rh_client <- handleToHANDLE rfd2 + -- Associate the handle with the current manager + -- but don't touch the ones we're passing to the child + -- since it needs to register the handle with its own manager. + associateHandle' =<< handleToHANDLE rh + associateHandle' =<< handleToHANDLE wh + let args = pre_opts ++ (show wh_client : show rh_client : opts) + ph <- createProc (proc prog args) + return (ph, rh, wh) + +runWithPipes = runWithPipesPOSIX runWithPipesNative +# else +runWithPipes = runWithPipesPOSIX +# endif +#else +runWithPipes createProc prog pre_opts 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 = pre_opts ++ (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 + diff --git a/GHC/Settings.hs b/GHC/Settings.hs new file mode 100644 --- /dev/null +++ b/GHC/Settings.hs @@ -0,0 +1,315 @@ + + +-- | Run-time settings +module GHC.Settings + ( Settings (..) + , ToolSettings (..) + , FileSettings (..) + , UnitSettings(..) + , GhcNameVersion (..) + , Platform (..) + , PlatformMisc (..) + -- * Accessors + , dynLibSuffix + , sProgramName + , sProjectVersion + , sGhcUsagePath + , sGhciUsagePath + , sToolDir + , sTopDir + , sGlobalPackageDatabasePath + , sLdSupportsCompactUnwind + , sLdSupportsFilelist + , sMergeObjsSupportsResponseFiles + , sLdIsGnuLd + , sGccSupportsNoPie + , sUseInplaceMinGW + , sArSupportsDashL + , sPgm_L + , sPgm_P + , sPgm_JSP + , sPgm_CmmP + , sPgm_F + , sPgm_c + , sPgm_cxx + , sPgm_cpp + , sPgm_a + , sPgm_l + , sPgm_lm + , sPgm_windres + , sPgm_ar + , sPgm_otool + , sPgm_install_name_tool + , sPgm_ranlib + , sPgm_lo + , sPgm_lc + , sPgm_las + , sPgm_i + , sOpt_L + , sOpt_P + , sOpt_P_fingerprint + , sOpt_JSP + , sOpt_JSP_fingerprint + , sOpt_CmmP + , sOpt_CmmP_fingerprint + , sOpt_F + , sOpt_c + , sOpt_cxx + , sOpt_a + , sOpt_l + , sOpt_lm + , sOpt_windres + , sOpt_lo + , sOpt_lc + , sOpt_i + , sExtraGccViaCFlags + , sTargetPlatformString + , sGhcWithInterpreter + , sLibFFI + , sTargetRTSLinkerOnlySupportsSharedLibs + ) where + +import GHC.Prelude + +import GHC.Utils.CliOption +import GHC.Utils.Fingerprint +import GHC.Platform +import GHC.Unit.Types + +data Settings = Settings + { sGhcNameVersion :: {-# UNPACk #-} !GhcNameVersion + , sFileSettings :: {-# UNPACK #-} !FileSettings + , sTargetPlatform :: Platform -- Filled in by SysTools + , sToolSettings :: {-# UNPACK #-} !ToolSettings + , sPlatformMisc :: {-# UNPACK #-} !PlatformMisc + , sUnitSettings :: !UnitSettings + + -- You shouldn't need to look things up in rawSettings directly. + -- They should have their own fields instead. + , sRawSettings :: [(String, String)] + } + +data UnitSettings = UnitSettings { unitSettings_baseUnitId :: !UnitId } + +-- | Settings for other executables GHC calls. +-- +-- Probably should further split down by phase, or split between +-- platform-specific and platform-agnostic. +data ToolSettings = ToolSettings + { toolSettings_ldSupportsCompactUnwind :: Bool + , toolSettings_ldSupportsFilelist :: Bool + , toolSettings_ldSupportsSingleModule :: Bool + , toolSettings_mergeObjsSupportsResponseFiles :: Bool + , toolSettings_ldIsGnuLd :: Bool + , toolSettings_ccSupportsNoPie :: Bool + , toolSettings_useInplaceMinGW :: Bool + , toolSettings_arSupportsDashL :: Bool + , toolSettings_cmmCppSupportsG0 :: Bool + + -- commands for particular phases + , toolSettings_pgm_L :: String + , -- | The Haskell C preprocessor and default options (not added by -optP) + toolSettings_pgm_P :: (String, [Option]) + , -- | The JavaScript C preprocessor and default options (not added by -optP) + toolSettings_pgm_JSP :: (String, [Option]) + , -- | The C-- C Preprocessor and default options (not added by -optP) + toolSettings_pgm_CmmP :: (String, [Option]) + , toolSettings_pgm_F :: String + , toolSettings_pgm_c :: String + , toolSettings_pgm_cxx :: String + , -- | The C preprocessor (distinct from the Haskell C preprocessor!) + toolSettings_pgm_cpp :: (String, [Option]) + , toolSettings_pgm_a :: (String, [Option]) + , toolSettings_pgm_l :: (String, [Option]) + , toolSettings_pgm_lm :: Maybe (String, [Option]) + -- ^ N.B. On Windows we don't have a linker which supports object + -- merging, hence the 'Maybe'. See Note [Object merging] in + -- "GHC.Driver.Pipeline.Execute" for details. + , toolSettings_pgm_windres :: String + , toolSettings_pgm_ar :: String + , toolSettings_pgm_otool :: String + , toolSettings_pgm_install_name_tool :: String + , toolSettings_pgm_ranlib :: String + , -- | LLVM: opt llvm optimiser + toolSettings_pgm_lo :: (String, [Option]) + , -- | LLVM: llc static compiler + toolSettings_pgm_lc :: (String, [Option]) + -- | LLVM: assembler + , toolSettings_pgm_las :: (String, [Option]) + , toolSettings_pgm_i :: String + + -- options for particular phases + , toolSettings_opt_L :: [String] + , toolSettings_opt_P :: [String] + , toolSettings_opt_JSP :: [String] + , toolSettings_opt_CmmP :: [String] + , -- | cached Fingerprint of sOpt_P + -- See Note [Repeated -optP hashing] + toolSettings_opt_P_fingerprint :: Fingerprint + , -- | cached Fingerprint of sOpt_JSP + -- See Note [Repeated -optP hashing] + toolSettings_opt_JSP_fingerprint :: Fingerprint + , -- | cached Fingerprint of sOpt_CmmP + -- See Note [Repeated -optP hashing] + toolSettings_opt_CmmP_fingerprint :: Fingerprint + , toolSettings_opt_F :: [String] + , toolSettings_opt_c :: [String] + , toolSettings_opt_cxx :: [String] + , toolSettings_opt_a :: [String] + , toolSettings_opt_l :: [String] + , toolSettings_opt_lm :: [String] + , toolSettings_opt_windres :: [String] + , -- | LLVM: llvm optimiser + toolSettings_opt_lo :: [String] + , -- | LLVM: llc static compiler + toolSettings_opt_lc :: [String] + , toolSettings_opt_las :: [String] + , -- | iserv options + toolSettings_opt_i :: [String] + + , toolSettings_extraGccViaCFlags :: [String] + } + + +-- | Paths to various files and directories used by GHC, including those that +-- provide more settings. +data FileSettings = FileSettings + { fileSettings_ghcUsagePath :: FilePath -- ditto + , fileSettings_ghciUsagePath :: FilePath -- ditto + , fileSettings_toolDir :: Maybe FilePath -- ditto + , fileSettings_topDir :: FilePath -- ditto + , fileSettings_globalPackageDatabase :: FilePath + } + + +-- | Settings for what GHC this is. +data GhcNameVersion = GhcNameVersion + { ghcNameVersion_programName :: String + , ghcNameVersion_projectVersion :: String + } + +-- | Dynamic library suffix +dynLibSuffix :: GhcNameVersion -> String +dynLibSuffix (GhcNameVersion name ver) = '-':name ++ ver + +----------------------------------------------------------------------------- +-- Accessors from 'Settings' + +sProgramName :: Settings -> String +sProgramName = ghcNameVersion_programName . sGhcNameVersion +sProjectVersion :: Settings -> String +sProjectVersion = ghcNameVersion_projectVersion . sGhcNameVersion + +sGhcUsagePath :: Settings -> FilePath +sGhcUsagePath = fileSettings_ghcUsagePath . sFileSettings +sGhciUsagePath :: Settings -> FilePath +sGhciUsagePath = fileSettings_ghciUsagePath . sFileSettings +sToolDir :: Settings -> Maybe FilePath +sToolDir = fileSettings_toolDir . sFileSettings +sTopDir :: Settings -> FilePath +sTopDir = fileSettings_topDir . sFileSettings +sGlobalPackageDatabasePath :: Settings -> FilePath +sGlobalPackageDatabasePath = fileSettings_globalPackageDatabase . sFileSettings + +sLdSupportsCompactUnwind :: Settings -> Bool +sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings +sLdSupportsFilelist :: Settings -> Bool +sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings +sMergeObjsSupportsResponseFiles :: Settings -> Bool +sMergeObjsSupportsResponseFiles = toolSettings_mergeObjsSupportsResponseFiles . sToolSettings +sLdIsGnuLd :: Settings -> Bool +sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings +sGccSupportsNoPie :: Settings -> Bool +sGccSupportsNoPie = toolSettings_ccSupportsNoPie . sToolSettings +sUseInplaceMinGW :: Settings -> Bool +sUseInplaceMinGW = toolSettings_useInplaceMinGW . sToolSettings +sArSupportsDashL :: Settings -> Bool +sArSupportsDashL = toolSettings_arSupportsDashL . sToolSettings + +sPgm_L :: Settings -> String +sPgm_L = toolSettings_pgm_L . sToolSettings +sPgm_P :: Settings -> (String, [Option]) +sPgm_P = toolSettings_pgm_P . sToolSettings +sPgm_JSP :: Settings -> (String, [Option]) +sPgm_JSP = toolSettings_pgm_JSP . sToolSettings +sPgm_CmmP :: Settings -> (String, [Option]) +sPgm_CmmP = toolSettings_pgm_CmmP . sToolSettings +sPgm_F :: Settings -> String +sPgm_F = toolSettings_pgm_F . sToolSettings +sPgm_c :: Settings -> String +sPgm_c = toolSettings_pgm_c . sToolSettings +sPgm_cxx :: Settings -> String +sPgm_cxx = toolSettings_pgm_cxx . sToolSettings +sPgm_cpp :: Settings -> (String, [Option]) +sPgm_cpp = toolSettings_pgm_cpp . sToolSettings +sPgm_a :: Settings -> (String, [Option]) +sPgm_a = toolSettings_pgm_a . sToolSettings +sPgm_l :: Settings -> (String, [Option]) +sPgm_l = toolSettings_pgm_l . sToolSettings +sPgm_lm :: Settings -> Maybe (String, [Option]) +sPgm_lm = toolSettings_pgm_lm . sToolSettings +sPgm_windres :: Settings -> String +sPgm_windres = toolSettings_pgm_windres . sToolSettings +sPgm_ar :: Settings -> String +sPgm_ar = toolSettings_pgm_ar . sToolSettings +sPgm_otool :: Settings -> String +sPgm_otool = toolSettings_pgm_otool . sToolSettings +sPgm_install_name_tool :: Settings -> String +sPgm_install_name_tool = toolSettings_pgm_install_name_tool . sToolSettings +sPgm_ranlib :: Settings -> String +sPgm_ranlib = toolSettings_pgm_ranlib . sToolSettings +sPgm_lo :: Settings -> (String, [Option]) +sPgm_lo = toolSettings_pgm_lo . sToolSettings +sPgm_lc :: Settings -> (String, [Option]) +sPgm_lc = toolSettings_pgm_lc . sToolSettings +sPgm_las :: Settings -> (String, [Option]) +sPgm_las = toolSettings_pgm_las . sToolSettings +sPgm_i :: Settings -> String +sPgm_i = toolSettings_pgm_i . sToolSettings +sOpt_L :: Settings -> [String] +sOpt_L = toolSettings_opt_L . sToolSettings +sOpt_P :: Settings -> [String] +sOpt_P = toolSettings_opt_P . sToolSettings +sOpt_P_fingerprint :: Settings -> Fingerprint +sOpt_P_fingerprint = toolSettings_opt_P_fingerprint . sToolSettings +sOpt_JSP :: Settings -> [String] +sOpt_JSP = toolSettings_opt_JSP . sToolSettings +sOpt_JSP_fingerprint :: Settings -> Fingerprint +sOpt_JSP_fingerprint = toolSettings_opt_JSP_fingerprint . sToolSettings +sOpt_CmmP :: Settings -> [String] +sOpt_CmmP = toolSettings_opt_CmmP . sToolSettings +sOpt_CmmP_fingerprint :: Settings -> Fingerprint +sOpt_CmmP_fingerprint = toolSettings_opt_CmmP_fingerprint . sToolSettings +sOpt_F :: Settings -> [String] +sOpt_F = toolSettings_opt_F . sToolSettings +sOpt_c :: Settings -> [String] +sOpt_c = toolSettings_opt_c . sToolSettings +sOpt_cxx :: Settings -> [String] +sOpt_cxx = toolSettings_opt_cxx . sToolSettings +sOpt_a :: Settings -> [String] +sOpt_a = toolSettings_opt_a . sToolSettings +sOpt_l :: Settings -> [String] +sOpt_l = toolSettings_opt_l . sToolSettings +sOpt_lm :: Settings -> [String] +sOpt_lm = toolSettings_opt_lm . sToolSettings +sOpt_windres :: Settings -> [String] +sOpt_windres = toolSettings_opt_windres . sToolSettings +sOpt_lo :: Settings -> [String] +sOpt_lo = toolSettings_opt_lo . sToolSettings +sOpt_lc :: Settings -> [String] +sOpt_lc = toolSettings_opt_lc . sToolSettings +sOpt_i :: Settings -> [String] +sOpt_i = toolSettings_opt_i . sToolSettings + +sExtraGccViaCFlags :: Settings -> [String] +sExtraGccViaCFlags = toolSettings_extraGccViaCFlags . sToolSettings + +sTargetPlatformString :: Settings -> String +sTargetPlatformString = platformMisc_targetPlatformString . sPlatformMisc +sGhcWithInterpreter :: Settings -> Bool +sGhcWithInterpreter = platformMisc_ghcWithInterpreter . sPlatformMisc +sLibFFI :: Settings -> Bool +sLibFFI = platformMisc_libFFI . sPlatformMisc + +sTargetRTSLinkerOnlySupportsSharedLibs :: Settings -> Bool +sTargetRTSLinkerOnlySupportsSharedLibs = platformMisc_targetRTSLinkerOnlySupportsSharedLibs . sPlatformMisc diff --git a/GHC/Settings/Constants.hs b/GHC/Settings/Constants.hs new file mode 100644 --- /dev/null +++ b/GHC/Settings/Constants.hs @@ -0,0 +1,66 @@ +-- | Compile-time settings +module GHC.Settings.Constants where + +import GHC.Prelude + +import GHC.Settings.Config + +hiVersion :: Integer +hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer + +-- All pretty arbitrary: + +mAX_TUPLE_SIZE :: Int +mAX_TUPLE_SIZE = 64 -- Should really match the number + -- of decls in GHC.Tuple + +mAX_CTUPLE_SIZE :: Int -- Constraint tuples +mAX_CTUPLE_SIZE = 64 -- Should match the number of decls in GHC.Classes + +mAX_SUM_SIZE :: Int -- We use 6 bits to record sum size, +mAX_SUM_SIZE = 63 -- so max sum size is 63. Sadly inconsistent. + +-- | Default maximum depth for both class instance search and type family +-- reduction. See also #5395. +mAX_REDUCTION_DEPTH :: Int +mAX_REDUCTION_DEPTH = 200 + +-- | Default maximum constraint-solver iterations +-- Typically there should be very few +mAX_SOLVER_ITERATIONS :: Int +mAX_SOLVER_ITERATIONS = 4 + +-- | In case of loopy quantified constraints constraints, +-- how many times should we allow superclass expansions +-- Should be less than mAX_SOLVER_ITERATIONS +-- See Note [Expanding Recursive Superclasses and ExpansionFuel] +mAX_QC_FUEL :: Int +mAX_QC_FUEL = 3 + +-- | In case of loopy wanted constraints, +-- how many times should we allow superclass expansions +-- Should be less than mAX_GIVENS_FUEL +-- See Note [Expanding Recursive Superclasses and ExpansionFuel] +mAX_WANTEDS_FUEL :: Int +mAX_WANTEDS_FUEL = 1 + +-- | In case of loopy given constraints, +-- how many times should we allow superclass expansions +-- Should be less than max_SOLVER_ITERATIONS +-- See Note [Expanding Recursive Superclasses and ExpansionFuel] +mAX_GIVENS_FUEL :: Int +mAX_GIVENS_FUEL = 3 + +wORD64_SIZE :: Int +wORD64_SIZE = 8 + +-- Size of float in bytes. +fLOAT_SIZE :: Int +fLOAT_SIZE = 4 + +-- Size of double in bytes. +dOUBLE_SIZE :: Int +dOUBLE_SIZE = 8 + +tARGET_MAX_CHAR :: Int +tARGET_MAX_CHAR = 0x10ffff diff --git a/GHC/Settings/IO.hs b/GHC/Settings/IO.hs new file mode 100644 --- /dev/null +++ b/GHC/Settings/IO.hs @@ -0,0 +1,324 @@ + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Settings.IO + ( SettingsError (..) + , initSettings + ) where + +import GHC.Prelude + +import GHC.Settings.Utils + +import GHC.Settings.Config +import GHC.Utils.CliOption +import GHC.Utils.Fingerprint +import GHC.Platform +import GHC.Utils.Panic +import GHC.ResponseFile +import GHC.Settings +import GHC.SysTools.BaseDir +import GHC.Unit.Types + +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import Data.Char +import qualified Data.Map as Map +import System.FilePath +import System.Directory + + +data SettingsError + = SettingsError_MissingData String + | SettingsError_BadData String + +initSettings + :: forall m + . MonadIO m + => String -- ^ TopDir path + -> ExceptT SettingsError m Settings +initSettings top_dir = do + let installed :: FilePath -> FilePath + installed file = top_dir file + libexec :: FilePath -> FilePath + libexec file = top_dir ".." "bin" file + settingsFile = installed "settings" + + readFileSafe :: FilePath -> ExceptT SettingsError m String + readFileSafe path = liftIO (doesFileExist path) >>= \case + True -> liftIO $ readFile path + False -> throwE $ SettingsError_MissingData $ "Missing file: " ++ path + + settingsStr <- readFileSafe settingsFile + settingsList <- case maybeReadFuzzy settingsStr of + Just s -> pure s + Nothing -> throwE $ SettingsError_BadData $ + "Can't parse " ++ show settingsFile + let mySettings = Map.fromList settingsList + getBooleanSetting :: String -> ExceptT SettingsError m Bool + getBooleanSetting key = either pgmError pure $ + getRawBooleanSetting settingsFile mySettings key + + -- On Windows, by mingw is often distributed with GHC, + -- so we look in TopDir/../mingw/bin, + -- as well as TopDir/../../mingw/bin for hadrian. + -- But we might be disabled, in which we we don't do that. + useInplaceMinGW <- getBooleanSetting "Use inplace MinGW toolchain" + + -- see Note [topdir: How GHC finds its files] + -- NB: top_dir is assumed to be in standard Unix + -- format, '/' separated + mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir + -- see Note [tooldir: How GHC finds mingw on Windows] + + -- Escape 'top_dir' and 'mtool_dir', to make sure we don't accidentally + -- introduce unescaped spaces. See #24265 and #25204. + let escaped_top_dir = escapeArg top_dir + escaped_mtool_dir = fmap escapeArg mtool_dir + + getSetting_raw key = either pgmError pure $ + getRawSetting settingsFile mySettings key + getSetting_topDir top key = either pgmError pure $ + getRawFilePathSetting top settingsFile mySettings key + getSetting_toolDir top tool key = + expandToolDir useInplaceMinGW tool <$> getSetting_topDir top key + + getSetting :: String -> ExceptT SettingsError m String + getSetting key = getSetting_topDir top_dir key + getToolSetting :: String -> ExceptT SettingsError m String + getToolSetting key = getSetting_toolDir top_dir mtool_dir key + getFlagsSetting :: String -> ExceptT SettingsError m [String] + getFlagsSetting key = unescapeArgs <$> getSetting_toolDir escaped_top_dir escaped_mtool_dir key + -- Make sure to unescape, as we have escaped top_dir and tool_dir. + + -- 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. + targetPlatformString <- getSetting_raw "target platform string" + cc_prog <- getToolSetting "C compiler command" + cxx_prog <- getToolSetting "C++ compiler command" + cc_args0 <- getFlagsSetting "C compiler flags" + cxx_args <- getFlagsSetting "C++ compiler flags" + gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" + cmmCppSupportsG0 <- getBooleanSetting "C-- CPP supports -g0" + cpp_prog <- getToolSetting "CPP command" + cpp_args <- map Option <$> getFlagsSetting "CPP flags" + hs_cpp_prog <- getToolSetting "Haskell CPP command" + hs_cpp_args <- map Option <$> getFlagsSetting "Haskell CPP flags" + js_cpp_prog <- getToolSetting "JavaScript CPP command" + js_cpp_args <- map Option <$> getFlagsSetting "JavaScript CPP flags" + cmmCpp_prog <- getToolSetting "C-- CPP command" + cmmCpp_args <- map Option <$> getFlagsSetting "C-- CPP flags" + + platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings + + let unreg_cc_args = if platformUnregisterised platform + then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] + else [] + cc_args = cc_args0 ++ unreg_cc_args + + -- The extra flags we need to pass gcc when we invoke it to compile .hc code. + -- + -- -fwrapv is needed for gcc to emit well-behaved code in the presence of + -- integer wrap around (#952). + extraGccViaCFlags = if platformUnregisterised platform + -- configure guarantees cc support these flags + then ["-fwrapv", "-fno-builtin"] + else [] + + ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" + ldSupportsFilelist <- getBooleanSetting "ld supports filelist" + ldSupportsSingleModule <- getBooleanSetting "ld supports single module" + mergeObjsSupportsResponseFiles <- getBooleanSetting "Merge objects supports response files" + ldIsGnuLd <- getBooleanSetting "ld is GNU ld" + arSupportsDashL <- getBooleanSetting "ar supports -L" + + + -- The package database is either a relative path to the location of the settings file + -- OR an absolute path. + -- In case the path is absolute then top_dir abs_path == abs_path + -- the path is relative then top_dir rel_path == top_dir rel_path + globalpkgdb_path <- installed <$> getSetting "Relative Global Package DB" + + let ghc_usage_msg_path = installed "ghc-usage.txt" + ghci_usage_msg_path = installed "ghci-usage.txt" + + -- For all systems, unlit, split, mangle are GHC utilities + -- architecture-specific stuff is done when building Config.hs + unlit_path <- getToolSetting "unlit command" + + windres_path <- getToolSetting "windres command" + ar_path <- getToolSetting "ar command" + otool_path <- getToolSetting "otool command" + install_name_tool_path <- getToolSetting "install_name_tool command" + ranlib_path <- getToolSetting "ranlib command" + + -- HACK, see setPgmP below. We keep 'words' here to remember to fix + -- Config.hs one day. + + + -- Other things being equal, 'as' and 'ld' are simply 'gcc' + cc_link_args <- getFlagsSetting "C compiler link flags" + let as_prog = cc_prog + as_args = map Option cc_args + ld_prog = cc_prog + ld_args = map Option (cc_args ++ cc_link_args) + ld_r_prog <- getToolSetting "Merge objects command" + ld_r_args <- getFlagsSetting "Merge objects flags" + let ld_r + | null ld_r_prog = Nothing + | otherwise = Just (ld_r_prog, map Option ld_r_args) + + llvmTarget <- getSetting_raw "LLVM target" + + -- We just assume on command line + lc_prog <- getToolSetting "LLVM llc command" + lo_prog <- getToolSetting "LLVM opt command" + las_prog <- getToolSetting "LLVM llvm-as command" + las_args <- map Option <$> getFlagsSetting "LLVM llvm-as flags" + + let iserv_prog = libexec "ghc-iserv" + + targetRTSLinkerOnlySupportsSharedLibs <- getBooleanSetting "target RTS linker only supports shared libraries" + ghcWithInterpreter <- getBooleanSetting "Use interpreter" + useLibFFI <- getBooleanSetting "Use LibFFI" + + baseUnitId <- getSetting_raw "base unit-id" + + return $ Settings + { sGhcNameVersion = GhcNameVersion + { ghcNameVersion_programName = "ghc" + , ghcNameVersion_projectVersion = cProjectVersion + } + + , sFileSettings = FileSettings + { fileSettings_ghcUsagePath = ghc_usage_msg_path + , fileSettings_ghciUsagePath = ghci_usage_msg_path + , fileSettings_toolDir = mtool_dir + , fileSettings_topDir = top_dir + , fileSettings_globalPackageDatabase = globalpkgdb_path + } + + , sUnitSettings = UnitSettings + { + unitSettings_baseUnitId = stringToUnitId baseUnitId + } + + , sToolSettings = ToolSettings + { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind + , toolSettings_ldSupportsFilelist = ldSupportsFilelist + , toolSettings_ldSupportsSingleModule = ldSupportsSingleModule + , toolSettings_mergeObjsSupportsResponseFiles = mergeObjsSupportsResponseFiles + , toolSettings_ldIsGnuLd = ldIsGnuLd + , toolSettings_ccSupportsNoPie = gccSupportsNoPie + , toolSettings_useInplaceMinGW = useInplaceMinGW + , toolSettings_arSupportsDashL = arSupportsDashL + , toolSettings_cmmCppSupportsG0 = cmmCppSupportsG0 + + , toolSettings_pgm_L = unlit_path + , toolSettings_pgm_P = (hs_cpp_prog, hs_cpp_args) + , toolSettings_pgm_JSP = (js_cpp_prog, js_cpp_args) + , toolSettings_pgm_CmmP = (cmmCpp_prog, cmmCpp_args) + , toolSettings_pgm_F = "" + , toolSettings_pgm_c = cc_prog + , toolSettings_pgm_cxx = cxx_prog + , toolSettings_pgm_cpp = (cpp_prog, cpp_args) + , toolSettings_pgm_a = (as_prog, as_args) + , toolSettings_pgm_l = (ld_prog, ld_args) + , toolSettings_pgm_lm = ld_r + , toolSettings_pgm_windres = windres_path + , toolSettings_pgm_ar = ar_path + , toolSettings_pgm_otool = otool_path + , toolSettings_pgm_install_name_tool = install_name_tool_path + , toolSettings_pgm_ranlib = ranlib_path + , toolSettings_pgm_lo = (lo_prog,[]) + , toolSettings_pgm_lc = (lc_prog,[]) + , toolSettings_pgm_las = (las_prog, las_args) + , toolSettings_pgm_i = iserv_prog + , toolSettings_opt_L = [] + , toolSettings_opt_P = [] + , toolSettings_opt_JSP = [] + , toolSettings_opt_CmmP = [] + , toolSettings_opt_P_fingerprint = fingerprint0 + , toolSettings_opt_JSP_fingerprint = fingerprint0 + , toolSettings_opt_CmmP_fingerprint = fingerprint0 + , toolSettings_opt_F = [] + , toolSettings_opt_c = cc_args + , toolSettings_opt_cxx = cxx_args + , toolSettings_opt_a = [] + , toolSettings_opt_l = [] + , toolSettings_opt_lm = [] + , toolSettings_opt_windres = [] + , toolSettings_opt_lo = [] + , toolSettings_opt_lc = [] + , toolSettings_opt_las = [] + , toolSettings_opt_i = [] + + , toolSettings_extraGccViaCFlags = extraGccViaCFlags + } + + , sTargetPlatform = platform + , sPlatformMisc = PlatformMisc + { platformMisc_targetPlatformString = targetPlatformString + , platformMisc_ghcWithInterpreter = ghcWithInterpreter + , platformMisc_libFFI = useLibFFI + , platformMisc_llvmTarget = llvmTarget + , platformMisc_targetRTSLinkerOnlySupportsSharedLibs = targetRTSLinkerOnlySupportsSharedLibs + } + + , sRawSettings = settingsList + } + +getTargetPlatform + :: FilePath -- ^ Settings filepath (for error messages) + -> RawSettings -- ^ Raw settings file contents + -> Either String Platform +getTargetPlatform settingsFile settings = do + let + getBooleanSetting = getRawBooleanSetting settingsFile settings + readSetting :: (Show a, Read a) => String -> Either String a + readSetting = readRawSetting settingsFile settings + + targetArchOS <- getTargetArchOS settingsFile settings + targetWordSize <- readSetting "target word size" + targetWordBigEndian <- getBooleanSetting "target word big endian" + targetLeadingUnderscore <- getBooleanSetting "Leading underscore" + targetUnregisterised <- getBooleanSetting "Unregisterised" + targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack" + targetHasIdentDirective <- getBooleanSetting "target has .ident directive" + targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols" + targetHasLibm <- getBooleanSetting "target has libm" + crossCompiling <- getBooleanSetting "cross compiling" + tablesNextToCode <- getBooleanSetting "Tables next to code" + + pure $ Platform + { platformArchOS = targetArchOS + , platformWordSize = targetWordSize + , platformByteOrder = if targetWordBigEndian then BigEndian else LittleEndian + , platformUnregisterised = targetUnregisterised + , platformHasGnuNonexecStack = targetHasGnuNonexecStack + , platformHasIdentDirective = targetHasIdentDirective + , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols + , platformIsCrossCompiling = crossCompiling + , platformLeadingUnderscore = targetLeadingUnderscore + , platformTablesNextToCode = tablesNextToCode + , platformHasLibm = targetHasLibm + , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit + } + +-- ---------------------------------------------------------------------------- +-- Escape Args helpers +-- ---------------------------------------------------------------------------- + +-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base. +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs diff --git a/GHC/Stg/BcPrep.hs b/GHC/Stg/BcPrep.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/BcPrep.hs @@ -0,0 +1,216 @@ +{-| + 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) typ) = 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') typ) +bcPrepRHS (StgRhsClosure fvs cc upd args expr typ) = + StgRhsClosure fvs cc upd args <$> bcPrepExpr expr <*> pure typ +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' + tick_ty + ) + 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' + tick_ty + ) + 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 typ) + | isNNLJoinPoint x + = ( protectNNLJoinPointId x + , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body typ) +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 (# #) argument. +-- Precondition: the Id is a not-necessarily-lifted join point. +-- See Note [Not-necessarily-lifted join points] +protectNNLJoinPointId :: Id -> Id +protectNNLJoinPointId x + = assert (isNNLJoinPoint x ) + updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x + +newUnique :: BcPrepM Unique +newUnique = state $ + \st -> case takeUniqFromSupply (prepUniqSupply st) of + (uniq, us) -> (uniq, st { prepUniqSupply = us }) + +newId :: Type -> BcPrepM Id +newId ty = do + uniq <- newUnique + return $ mkSysLocal prepFS uniq ManyTy ty + +prepFS :: FastString +prepFS = fsLit "bcprep" + +{- + +Note [Not-necessarily-lifted join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A join point variable is essentially a goto-label: it is, for example, +never used as an argument to another function, and it is called only +in tail position. See Note [Join points] and Note [Invariants on join points], +both in GHC.Core. Because join points do not compile to true, red-blooded +variables (with, e.g., registers allocated to them), they are allowed +to be representation-polymorphic. +(See invariant #6 in Note [Invariants on join points] in GHC.Core.) + +However, in this byte-code generator, join points *are* treated just as +ordinary variables. There is no check whether a binding is for a join point +or not; they are all treated uniformly. (Perhaps there is a missed optimization +opportunity here, but that is beyond the scope of my (Richard E's) Thursday.) + +We thus must have *some* strategy for dealing with representation-polymorphic +and unlifted join points. Representation-polymorphic variables are generally +not allowed (though representation-polymorphic join points *are*; see +Note [Invariants on join points] in GHC.Core, point 6), and we don't wish to +evaluate unlifted join points eagerly. +The questionable join points are *not-necessarily-lifted join points* +(NNLJPs). (Not having such a strategy led to #16509, which panicked in the +isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy: + +1. Detect NNLJPs. This is done in isNNLJoinPoint. + +2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the + type to tack on a `(# #) ->`. + Note that functions are never representation-polymorphic, so this + transformation changes an NNLJP to a non-representation-polymorphic + join point. This is done in bcPrepSingleBind. + +3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId), + being careful to note the new type of the NNLJP. This is done in the AnnVar + case of schemeE, with help from protectNNLJoinPointId. + +Here is an example. Suppose we have + + f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). + join j :: a + j = error @r @a "bloop" + in case x of + A -> j + B -> j + C -> error @r @a "blurp" + +Our plan is to behave is if the code was + + f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). + let j :: ((# #) -> a) + j = \ _ -> error @r @a "bloop" + in case x of + A -> j void# + B -> j void# + C -> error @r @a "blurp" + +It's a bit hacky, but it works well in practice and is local. I suspect the +Right Fix is to take advantage of join points as goto-labels. + +-} + diff --git a/GHC/Stg/CSE.hs b/GHC/Stg/CSE.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/CSE.hs @@ -0,0 +1,599 @@ +{-# LANGUAGE TypeFamilies #-} + +{-| +Note [CSE for Stg] +~~~~~~~~~~~~~~~~~~ + +This module implements a simple common subexpression elimination pass for STG. +This is useful because there are expressions that we want to common up (because +they are operationally equivalent), but that we cannot common up in Core, because +their types differ. +This was originally reported as #9291. + +There are two types of common code occurrences that we aim for, see +Note [Case 1: CSEing allocated closures] and +Note [Case 2: CSEing case binders] below. + + +Note [Case 1: CSEing allocated closures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The first kind of CSE opportunity we aim for is generated by this Haskell code: + + bar :: a -> (Either Int a, Either Bool a) + bar x = (Right x, Right x) + +which produces this Core: + + bar :: forall a. a -> (Either Int a, Either Bool a) + bar @a x = (Right @Int @a x, Right @Bool @a x) + +where the two components of the tuple are different terms, and cannot be +commoned up (easily). On the STG level we have + + bar [x] = let c1 = Right [x] + c2 = Right [x] + in (c1,c2) + +and now it is obvious that we can write + + bar [x] = let c1 = Right [x] + in (c1,c1) + +instead. + + +Note [Case 2: CSEing case binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The second kind of CSE opportunity we aim for is more interesting, and +came up in #9291 and #5344: The Haskell code + + foo :: Either Int a -> Either Bool a + foo (Right x) = Right x + foo _ = Left False + +produces this Core + + foo :: forall a. Either Int a -> Either Bool a + foo @a e = case e of b { Left n -> … + , Right x -> Right @Bool @a x } + +where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have +different types. But in STG we have + + foo [e] = case e of b { Left [n] -> … + , Right [x] -> Right [x] } + +and nothing stops us from transforming that to + + foo [e] = case e of b { Left [n] -> … + , Right [x] -> b} + + +Note that this can revive dead case binders (e.g. "b" above), hence we zap +occurrence information on all case binders during STG CSE. +See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr. + + +Note [StgCse after unarisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider two unboxed sum terms: + + (# 1 | #) :: (# Int | Int# #) + (# 1 | #) :: (# Int | Int #) + +These two terms are not equal as they unarise to different unboxed +tuples. However if we run StgCse before Unarise, it'll think the two +terms (# 1 | #) are equal, and replace one of these with a binder to +the other. That's bad -- #15300. + +Solution: do unarise first. + +-} + +module GHC.Stg.CSE (stgCse) where + +import GHC.Prelude + +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Stg.Syntax +import GHC.Types.Basic (isWeakLoopBreaker) +import GHC.Types.Var.Env +import GHC.Core (AltCon(..)) +import Data.List (mapAccumL) +import Data.Maybe (fromMaybe) +import GHC.Core.Map.Expr +import GHC.Data.TrieMap +import GHC.Types.Name.Env +import Control.Monad( (>=>) ) +import qualified Data.Map as Map +import GHC.Types.Literal (Literal) + +-------------- +-- The Trie -- +-------------- + +-- A lookup trie for data constructor applications, i.e. +-- keys of type `(DataCon, [StgArg])`, following the patterns in GHC.Data.TrieMap. + +data StgArgMap a = SAM + { sam_var :: DVarEnv a + , sam_lit :: LiteralMap a + } + +type LiteralMap a = Map.Map Literal a + +-- TODO(22292): derive +instance Functor StgArgMap where + fmap f SAM { sam_var = varm, sam_lit = litm } = SAM + { sam_var = fmap f varm, sam_lit = fmap f litm } + +instance TrieMap StgArgMap where + type Key StgArgMap = StgArg + emptyTM = SAM { sam_var = emptyTM + , sam_lit = emptyTM } + lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var + lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit + alterTM (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f } + alterTM (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f } + foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m) + filterTM f (SAM {sam_var = varm, sam_lit = litm}) = + SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm } + mapMaybeTM f (SAM {sam_var = varm, sam_lit = litm}) = + SAM { sam_var = mapMaybeTM f varm, sam_lit = mapMaybeTM f litm } + +newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) } + +-- TODO(22292): derive +instance Functor ConAppMap where + fmap f = CAM . fmap (fmap f) . un_cam + {-# INLINE fmap #-} + +instance TrieMap ConAppMap where + type Key ConAppMap = (DataCon, [StgArg]) + emptyTM = CAM emptyTM + lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args + alterTM (dataCon, args) f m = + m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f } + foldTM k = un_cam >.> foldTM (foldTM k) + filterTM f = un_cam >.> fmap (filterTM f) >.> CAM + mapMaybeTM f = un_cam >.> fmap (mapMaybeTM f) >.> CAM + +----------------- +-- The CSE Env -- +----------------- + +-- | The CSE environment. See Note [CseEnv Example] +data CseEnv = CseEnv + { ce_conAppMap :: ConAppMap OutId + -- ^ The main component of the environment is the trie that maps + -- data constructor applications (with their `OutId` arguments) + -- to an in-scope name that can be used instead. + -- This name is always either a let-bound variable or a case binder. + , ce_subst :: IdEnv OutId + -- ^ This substitution is applied to the code as we traverse it. + -- Entries have one of two reasons: + -- + -- * The input might have shadowing (see Note [Shadowing in Core]), + -- so we have to rename some binders as we traverse the tree. + -- * If we remove `let x = Con z` because `let y = Con z` is in scope, + -- we note this here as x ↦ y. + , ce_bndrMap :: IdEnv OutId + -- ^ If we come across a case expression case x as b of … with a trivial + -- binder, we add b ↦ x to this. + -- This map is *only* used when looking something up in the ce_conAppMap. + -- See Note [Trivial case scrutinee] + , ce_in_scope :: InScopeSet + -- ^ The third component is an in-scope set, to rename away any + -- shadowing binders + } + +{-| +Note [CseEnv Example] +~~~~~~~~~~~~~~~~~~~~~ +The following tables shows how the CseEnvironment changes as code is traversed, +as well as the changes to that code. + + InExpr OutExpr + conAppMap subst in_scope + ─────────────────────────────────────────────────────────── + -- empty {} {} + case … as a of {Con x y -> case … as a of {Con x y -> + -- Con x y ↦ a {} {a,x,y} + let b = Con x y (removed) + -- Con x y ↦ a b↦a {a,x,y,b} + let c = Bar a let c = Bar a + -- Con x y ↦ a, Bar a ↦ c b↦a {a,x,y,b,c} + let c = some expression let c' = some expression + -- Con x y ↦ a, Bar a ↦ c b↦a, c↦c', {a,x,y,b,c,c'} + let d = Bar b (removed) + -- Con x y ↦ a, Bar a ↦ c b↦a, c↦c', d↦c {a,x,y,b,c,c',d} + (a, b, c d) (a, a, c' c) +-} + +initEnv :: InScopeSet -> CseEnv +initEnv in_scope = CseEnv + { ce_conAppMap = emptyTM + , ce_subst = emptyVarEnv + , ce_bndrMap = emptyVarEnv + , ce_in_scope = in_scope + } + +------------------- +normaliseConArgs :: CseEnv -> [OutStgArg] -> [OutStgArg] +-- See Note [Trivial case scrutinee] +normaliseConArgs env args + = map go args + where + bndr_map = ce_bndrMap env + go (StgVarArg v ) = StgVarArg (normaliseId bndr_map v) + go (StgLitArg lit) = StgLitArg lit + +normaliseId :: IdEnv OutId -> OutId -> OutId +normaliseId bndr_map v = case lookupVarEnv bndr_map v of + Just v' -> v' + Nothing -> v + +addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv +-- See Note [Trivial case scrutinee] +addTrivCaseBndr from to env + = env { ce_bndrMap = extendVarEnv bndr_map from norm_to } + where + bndr_map = ce_bndrMap env + norm_to = normaliseId bndr_map to + +envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId +envLookup dataCon args env + = lookupTM (dataCon, normaliseConArgs env args) + (ce_conAppMap env) + -- normaliseConArgs: See Note [Trivial case scrutinee] + +addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv +-- Do not bother with nullary data constructors; they are static anyway +addDataCon _ _ [] env = env +addDataCon bndr dataCon args env + = env { ce_conAppMap = new_env } + where + new_env = insertTM (dataCon, normaliseConArgs env args) + bndr (ce_conAppMap env) + -- normaliseConArgs: See Note [Trivial case scrutinee] + +------------------- +forgetCse :: CseEnv -> CseEnv +forgetCse env = env { ce_conAppMap = emptyTM } + -- See Note [Free variables of an StgClosure] + +addSubst :: OutId -> OutId -> CseEnv -> CseEnv +addSubst from to env + = env { ce_subst = extendVarEnv (ce_subst env) from to } + +substArgs :: CseEnv -> [InStgArg] -> [OutStgArg] +substArgs env = map (substArg env) + +substArg :: CseEnv -> InStgArg -> OutStgArg +substArg env (StgVarArg from) = StgVarArg (substVar env from) +substArg _ (StgLitArg lit) = StgLitArg lit + +substVar :: CseEnv -> InId -> OutId +substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id + +-- Functions to enter binders + +-- This is much simpler than the equivalent code in GHC.Core.Subst: +-- * We do not substitute type variables, and +-- * There is nothing relevant in GHC.Types.Id.Info at this stage +-- that needs substitutions. +-- Therefore, no special treatment for a recursive group is required. + +substBndr :: CseEnv -> InId -> (CseEnv, OutId) +substBndr env old_id + = (new_env, new_id) + where + new_id = uniqAway (ce_in_scope env) old_id + no_change = new_id == old_id + env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id } + new_env | no_change = env' + | otherwise = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id } + +substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar]) +substBndrs env bndrs = mapAccumL substBndr env bndrs + +substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)]) +substPairs env bndrs = mapAccumL go env bndrs + where go env (id, x) = let (env', id') = substBndr env id + in (env', (id', x)) + +-- Main entry point + +stgCse :: [InStgTopBinding] -> [OutStgTopBinding] +stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds + +-- Top level bindings. +-- +-- We do not CSE these, as top-level closures are allocated statically anyways. +-- Also, they might be exported. +-- But we still have to collect the set of in-scope variables, otherwise +-- uniqAway might shadow a top-level closure. + +stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding) +stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t) +stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs)) + = (in_scope' + , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs))) + where in_scope' = in_scope `extendInScopeSet` bndr + +stgCseTopLvl in_scope (StgTopLifted (StgRec eqs)) + = ( in_scope' + , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ])) + where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ] + +stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs +stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body typ) + = let body' = stgCseExpr (initEnv in_scope) body + in StgRhsClosure ext ccs upd args body' typ +stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args typ) + = StgRhsCon ccs dataCon mu ticks args typ + +------------------------------ +-- The actual AST traversal -- +------------------------------ + +-- Trivial cases +stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr +stgCseExpr env (StgApp fun args) + = StgApp fun' args' + where fun' = substVar env fun + args' = substArgs env args +stgCseExpr _ (StgLit lit) + = StgLit lit +stgCseExpr env (StgOpApp op args tys) + = StgOpApp op args' tys + where args' = substArgs env args +stgCseExpr env (StgTick tick body) + = let body' = stgCseExpr env body + in StgTick tick body' +stgCseExpr env (StgCase scrut bndr ty alts) + = mkStgCase scrut' bndr'' ty alts' + where + scrut' = stgCseExpr env scrut + (env1, bndr') = substBndr env bndr + -- we must zap occurrence information on the case binder + -- because CSE might revive it. + -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr + bndr'' = zapIdOccInfo bndr' + env2 | StgApp trivial_scrut [] <- scrut' + = addTrivCaseBndr bndr trivial_scrut env1 + -- See Note [Trivial case scrutinee] + | otherwise + = env1 + alts' = map (stgCseAlt env2 ty bndr'') alts + + +-- A constructor application. +-- To be removed by a variable use when found in the CSE environment +stgCseExpr env (StgConApp dataCon n args tys) + | Just bndr' <- envLookup dataCon args' env + = StgApp bndr' [] + | otherwise + = StgConApp dataCon n args' tys + where args' = substArgs env args + +-- Let bindings +-- The binding might be removed due to CSE (we do not want trivial bindings on +-- the STG level), so use the smart constructor `mkStgLet` to remove the binding +-- if empty. +stgCseExpr env (StgLet ext binds body) + = let (binds', env') = stgCseBind env binds + body' = stgCseExpr env' body + in mkStgLet (StgLet ext) binds' body' +stgCseExpr env (StgLetNoEscape ext binds body) + = let (binds', env') = stgCseBind env binds + body' = stgCseExpr env' body + in mkStgLet (StgLetNoEscape ext) binds' body' + +-- Case alternatives +-- Extend the CSE environment +stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt +stgCseAlt env ty case_bndr GenStgAlt{alt_con=DataAlt dataCon, alt_bndrs=args, alt_rhs=rhs} + = let (env1, args') = substBndrs env args + env2 + -- To avoid dealing with unboxed sums StgCse runs after unarise and + -- should maintain invariants listed in Note [Post-unarisation + -- invariants]. One of the invariants is that some binders are not + -- used (unboxed tuple case binders) which is what we check with + -- `stgCaseBndrInScope` here. If the case binder is not in scope we + -- don't add it to the CSE env. See also #15300. + | stgCaseBndrInScope ty True -- CSE runs after unarise + = addDataCon case_bndr dataCon (map StgVarArg args') env1 + | otherwise + = env1 + -- see Note [Case 2: CSEing case binders] + rhs' = stgCseExpr env2 rhs + in GenStgAlt (DataAlt dataCon) args' rhs' +stgCseAlt env _ _ g@GenStgAlt{alt_con=_, alt_bndrs=args, alt_rhs=rhs} + = let (env1, args') = substBndrs env args + rhs' = stgCseExpr env1 rhs + in g {alt_bndrs=args', alt_rhs=rhs'} + +-- Bindings +stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv) +stgCseBind env (StgNonRec b e) + = let (env1, b') = substBndr env b + in case stgCseRhs env1 b' e of + (Nothing, env2) -> (Nothing, env2) + (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2) +stgCseBind env (StgRec pairs) + = let (env1, pairs1) = substPairs env pairs + in case stgCsePairs env1 pairs1 of + ([], env2) -> (Nothing, env2) + (pairs2, env2) -> (Just (StgRec pairs2), env2) + +stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv) +stgCsePairs env [] = ([], env) +stgCsePairs env0 ((b,e):pairs) + = let (pairMB, env1) = stgCseRhs env0 b e + (pairs', env2) = stgCsePairs env1 pairs + in (pairMB `mbCons` pairs', env2) + where + mbCons = maybe id (:) + +-- The RHS of a binding. +-- If it is a constructor application, either short-cut it or extend the environment +stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv) +stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args typ) + | Just other_bndr <- envLookup dataCon args' env + , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers] + = let env' = addSubst bndr other_bndr env + in (Nothing, env') + | otherwise + = let env' = addDataCon bndr dataCon args' env + -- see Note [Case 1: CSEing allocated closures] + pair = (bndr, StgRhsCon ccs dataCon mu ticks args' typ) + in (Just pair, env') + where args' = substArgs env args + +stgCseRhs env bndr (StgRhsClosure ext ccs upd args body typ) + = let (env1, args') = substBndrs env args + env2 = forgetCse env1 -- See Note [Free variables of an StgClosure] + body' = stgCseExpr env2 body + in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body' typ), env) + + +mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr +mkStgCase scrut bndr ty alts | all isBndr alts = scrut + | otherwise = StgCase scrut bndr ty alts + + where + -- see Note [All alternatives are the binder] + isBndr GenStgAlt{alt_con=_,alt_bndrs=_,alt_rhs=StgApp f []} = f == bndr + isBndr _ = False + + +{- Note [Care with loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When doing CSE on a letrec we must be careful about loop +breakers. Consider + rec { y = K z + ; z = K z } +Now if, somehow (and wrongly)), y and z are both marked as +loop-breakers, we do *not* want to drop the (z = K z) binding +in favour of a substitution (z :-> y). + +I think this bug will only show up if the loop-breaker-ness is done +wrongly (itself a bug), but it still seems better to do the right +thing regardless. +-} + +-- Utilities + +-- | This function short-cuts let-bindings that are now obsolete +mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b +mkStgLet _ Nothing body = body +mkStgLet stgLet (Just binds) body = stgLet binds body + + +{- +Note [All alternatives are the binder] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When all alternatives simply refer to the case binder, then we do not have +to bother with the case expression at all (#13588). CoreSTG does this as well, +but sometimes, types get into the way: + + newtype T = MkT Int + f :: (Int, Int) -> (T, Int) + f (x, y) = (MkT x, y) + +Core cannot just turn this into + + f p = p + +as this would not be well-typed. But to STG, where MkT is no longer in the way, +we can. + +Note [Trivial case scrutinee] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to be able to CSE nested reconstruction of constructors as in + + nested :: Either Int (Either Int a) -> Either Bool (Either Bool a) + nested (Right (Right v)) = Right (Right v) + nested _ = Left True + +We want the RHS of the first branch to be just the original argument. +The RHS of 'nested' will look like + case x of r1 + Right a -> case a of r2 + Right b -> let v = Right b + in Right v +Then: +* We create the ce_conAppMap [Right a :-> r1, Right b :-> r2]. +* When we encounter v = Right b, we'll drop the binding and extend + the substitution with [v :-> r2] +* But now when we see (Right v), we'll substitute to get (Right r2)...and + fail to find that in the ce_conAppMap! + +Solution: + +* When passing (case x of bndr { alts }), where 'x' is a variable, we + add [bndr :-> x] to the ce_bndrMap. In our example the ce_bndrMap will + be [r1 :-> x, r2 :-> a]. This is done in addTrivCaseBndr. + +* Before doing the /lookup/ in ce_conAppMap, we "normalise" the + arguments with the ce_bndrMap. In our example, we normalise + (Right r2) to (Right a), and then find it in the map. Normalisation + is done by normaliseConArgs. + +* Similarly before /inserting/ in ce_conAppMap, we normalise the arguments. + This is a bit more subtle. Suppose we have + case x of y + DEFAULT -> let a = Just y + let b = Just y + in ... + We'll have [y :-> x] in the ce_bndrMap. When looking up (Just y) in + the map, we'll normalise it to (Just x). So we'd better normalise + the (Just y) in the defn of 'a', before inserting it! + +* When inserting into cs_bndrMap, we must normalise that too! + case x of y + DEFAULT -> case y of z + DEFAULT -> ... + We want the cs_bndrMap to be [y :-> x, z :-> x]! + Hence the call to normaliseId in addTrivCaseBinder. + +All this is a bit tricky. Why does it not occur for the Core version +of CSE? See Note [CSE for bindings] in GHC.Core.Opt.CSE. The reason +is this: in Core CSE we augment the /main substitution/ with [y :-> x] +etc, so as a side consequence we transform + case x of y ===> case x of y + pat -> ...y... pat -> ...x... +That is, the /exact reverse/ of the binder-swap transformation done by +the occurrence analyser. However, it's easy for CSE to do on-the-fly, +and it completely solves the above tricky problem, using only two maps: +the main reverse-map, and the substitution. The occurrence analyser +puts it back the way it should be, the next time it runs. + +However in STG there is no occurrence analyser, and we don't want to +require another pass. So the ce_bndrMap is a little swizzle that we +apply just when manipulating the ce_conAppMap, but that does not +affect the output program. + + +Note [Free variables of an StgClosure] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +StgClosures (function and thunks) have an explicit list of free variables: + +foo [x] = + let not_a_free_var = Left [x] + let a_free_var = Right [x] + let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var + in closure + +If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`, +then the list of free variables would be wrong, so for now, we do not CSE +across such a closure, simply because I (Joachim) was not sure about possible +knock-on effects. If deemed safe and worth the slight code complication of +re-calculating this list during or after this pass, this can surely be done. +-} diff --git a/GHC/Stg/Debug.hs b/GHC/Stg/Debug.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Debug.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE TupleSections #-} + +-- This module contains functions which implement +-- the -finfo-table-map and -fdistinct-constructor-tables flags +module GHC.Stg.Debug + ( StgDebugOpts(..) + , collectDebugInformation + ) where + +import GHC.Prelude + +import GHC.Stg.Syntax + +import GHC.Types.Unique.DFM +import GHC.Types.Id +import GHC.Types.Tickish +import GHC.Core.DataCon +import GHC.Types.IPE +import GHC.Unit.Module +import GHC.Types.Name ( getName, getOccName, occNameFS, nameSrcSpan) +import GHC.Data.FastString + +import Control.Monad (when) +import Control.Monad.Trans.Reader +import GHC.Utils.Monad.State.Strict +import Control.Monad.Trans.Class +import GHC.Types.SrcLoc +import Control.Applicative +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) + +data SpanWithLabel = SpanWithLabel RealSrcSpan LexicalFastString + +data StgDebugOpts = StgDebugOpts + { stgDebug_infoTableMap :: !Bool + , stgDebug_distinctConstructorTables :: !Bool + } + +data R = R { rOpts :: StgDebugOpts, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel } + +type M a = ReaderT R (State InfoTableProvMap) a + +withSpan :: IpeSourceLocation -> M a -> M a +withSpan (new_s, new_l) act = local maybe_replace act + where + maybe_replace r@R{ rModLocation = cur_mod, rSpan = Just (SpanWithLabel old_s _old_l) } + -- prefer spans from the current module + | Just (unpackFS $ srcSpanFile old_s) == ml_hs_file cur_mod + , Just (unpackFS $ srcSpanFile new_s) /= ml_hs_file cur_mod + = r + maybe_replace r + = r { rSpan = Just (SpanWithLabel new_s new_l) } + +collectDebugInformation :: StgDebugOpts -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap) +collectDebugInformation opts ml bs = + runState (runReaderT (mapM collectTop bs) (R opts ml Nothing)) emptyInfoTableProvMap + +collectTop :: StgTopBinding -> M StgTopBinding +collectTop (StgTopLifted t) = StgTopLifted <$> collectStgBind t +collectTop tb = return tb + +collectStgBind :: StgBinding -> M StgBinding +collectStgBind (StgNonRec bndr rhs) = do + rhs' <- collectStgRhs bndr rhs + return (StgNonRec bndr rhs') +collectStgBind (StgRec pairs) = do + es <- mapM (\(b, e) -> (b,) <$> collectStgRhs b e) pairs + return (StgRec es) + +collectStgRhs :: Id -> StgRhs -> M StgRhs +collectStgRhs bndr rhs = + case rhs of + StgRhsClosure ext cc us bs e t -> do + e' <- with_span $ collectExpr e + recordInfo bndr e' + return $ StgRhsClosure ext cc us bs e' t + StgRhsCon cc dc _mn ticks args typ -> do + n' <- with_span $ numberDataCon dc ticks + return (StgRhsCon cc dc n' ticks args typ) + where + -- If the binder name has a span, use that initially as the source position + -- in case we don't get anything better + with_span :: M a -> M a + with_span = + let name = idName bndr in + case nameSrcSpan name of + RealSrcSpan pos _ -> + withSpan (pos, LexicalFastString $ occNameFS (getOccName name)) + _ -> id + +recordInfo :: Id -> StgExpr -> M () +recordInfo bndr new_rhs = do + modLoc <- asks rModLocation + let + thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc + -- A span from the ticks surrounding the new_rhs + best_span = quickSourcePos thisFile new_rhs + -- A back-up span if the bndr had a source position, many do not (think internally generated ids) + bndr_span = (\s -> SpanWithLabel s (LexicalFastString $ occNameFS (getOccName bndr))) + <$> srcSpanToRealSrcSpan (nameSrcSpan (getName bndr)) + recordStgIdPosition bndr best_span bndr_span + +collectExpr :: StgExpr -> M StgExpr +collectExpr = go + where + go (StgApp occ as) = return $ StgApp occ as + go (StgLit lit) = return $ StgLit lit + go (StgConApp dc _mn as tys) = do + n' <- numberDataCon dc [] + return (StgConApp dc n' as tys) + go (StgOpApp op as ty) = return (StgOpApp op as ty) + go (StgCase scrut bndr ty alts) = + StgCase <$> collectExpr scrut <*> pure bndr <*> pure ty <*> mapM collectAlt alts + go (StgLet ext bind body) = do + bind' <- collectStgBind bind + body' <- go body + return (StgLet ext bind' body') + go (StgLetNoEscape ext bind body) = do + bind' <- collectStgBind bind + body' <- go body + return (StgLetNoEscape ext bind' body') + + go (StgTick tick e) = do + let k = case tick of + SourceNote ss fp -> withSpan (ss, fp) + _ -> id + e' <- k (go e) + return (StgTick tick e') + +collectAlt :: StgAlt -> M StgAlt +collectAlt alt = do e' <- collectExpr $ alt_rhs alt + return $! alt { alt_rhs = e' } + +-- | Try to find the best source position surrounding a 'StgExpr'. The +-- heuristic strips ticks from the current expression until it finds one which +-- is from the module currently being compiled. This is the same method that +-- the DWARF information uses to give locations to info tables. +-- +-- It is usually a better alternative than using the 'RealSrcSpan' which is carefully +-- propagated downwards by 'withSpan'. It's "quick" because it works only using immediate context rather +-- than looking at the parent context like 'withSpan' +quickSourcePos :: FastString -> StgExpr -> Maybe SpanWithLabel +quickSourcePos cur_mod (StgTick (SourceNote ss m) e) + | srcSpanFile ss == cur_mod = Just (SpanWithLabel ss m) + | otherwise = quickSourcePos cur_mod e +quickSourcePos _ _ = Nothing + +recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M () +recordStgIdPosition id best_span ss = do + opts <- asks rOpts + when (stgDebug_infoTableMap opts) $ do + cc <- asks rSpan + --Useful for debugging why a certain Id gets given a certain span + --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss) + let mbspan = (\(SpanWithLabel rss d) -> (rss, d)) <$> (best_span <|> cc <|> ss) + lift $ modify (\env -> env { provClosure = addToUDFM (provClosure env) (idName id) (idName id, (idType id, mbspan)) }) + +numberDataCon :: DataCon -> [StgTickish] -> M ConstructorNumber +-- Unboxed tuples and sums do not allocate so they +-- have no info tables. +numberDataCon dc _ | isUnboxedTupleDataCon dc = return NoNumber +numberDataCon dc _ | isUnboxedSumDataCon dc = return NoNumber +numberDataCon dc ts = do + opts <- asks rOpts + if not (stgDebug_distinctConstructorTables opts) then return NoNumber else do + env <- lift get + mcc <- asks rSpan + let !mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc) + let !dcMap' = alterUDFM (maybe (Just (dc, (0, mbest_span) :| [] )) + (\(_dc, xs@((k, _):|_)) -> Just $! (dc, (k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc + lift $ put (env { provDC = dcMap' }) + let r = lookupUDFM dcMap' dc + return $ case r of + Nothing -> NoNumber + Just (_, res) -> Numbered (fst (NE.head res)) + +selectTick :: [StgTickish] -> Maybe SpanWithLabel +selectTick [] = Nothing +selectTick (SourceNote rss d : ts ) = selectTick ts <|> Just (SpanWithLabel rss d) +selectTick (_:ts) = selectTick ts + +{- +Note [Mapping Info Tables to Source Positions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This note describes what the `-finfo-table-map` flag achieves. + +When debugging memory issues it is very useful to be able to map a specific closure +to a position in the source. The prime example is being able to map a THUNK to +a specific place in the source program, the mapping is usually quite precise because +a fresh info table is created for each distinct THUNK. + +The info table map is also used to generate stacktraces. +See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] +for details. + +There are three parts to the implementation + +1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location + to some specific closures. +2. In GHC.Driver.GenerateCgIPEStub, the actually used info tables are collected after the + Cmm pipeline. This is important as it's hard to predict beforehand what code generation + will do and which ids will end up in the generated program. Additionally, info tables of + return frames (used to create stacktraces) are generated in the Cmm pipeline and aren't + available before. +3. During code generation, a mapping from the info table to the statically determined location + is emitted which can then be queried at runtime by various tools. + +-- Giving Source Locations to Closures + +At the moment thunk and constructor closures are added to the map. This information +is collected in the `InfoTableProvMap` which provides a mapping from: + +1. Data constructors to a list of where they are used. +2. `Name`s and where they originate from. +3. Stack represented info tables (return frames) to an approximated source location + of the call that pushed a continuation on the stacks. + +During the CoreToStg phase, this map is populated whenever something is turned into +a StgRhsClosure or an StgConApp. The current source position is recorded +depending on the location indicated by the surrounding SourceNote. + +The functions which add information to the map are `recordStgIdPosition` and +`numberDataCon`. + +When the `-fdistinct-constructor-tables` flag is turned on then every +usage of a data constructor gets its own distinct info table. This is orchestrated +in `collectExpr` where an incrementing number is used to distinguish each +occurrence of a data constructor. + +-- GenerateCgIPEStub + +The info tables which are actually used in the generated program are collected after +the Cmm pipeline. `initInfoTableProv` is used to create a CStub, that initializes the +map in C code. + +This step has to be done after the Cmm pipeline to make sure that all info tables are +really used and, even more importantly, return frame info tables are generated by the +pipeline. + +-- Code Generation + +The output of these two phases is combined together during code generation. +A C stub is generated which creates the static map from info table pointer to the +information about where that info table was created from. This is created by +`ipInitCode` in the same manner as a C stub is generated for cost centres. + +This information can be consumed in two ways. + +1. The complete mapping is emitted into the eventlog so that external tools such +as eventlog2html can use the information with the heap profile by info table mode. +2. The `lookupIPE` function can be used via the `whereFrom#` primop to introspect +information about a closure in a running Haskell program. + +Note [Distinct Info Tables for Constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the old times, each usage of a data constructor used the same info table. +This made it impossible to distinguish which actual usage of a data constructor was +contributing primarily to the allocation in a program. Using the `-fdistinct-constructor-tables` flag you +can cause code generation to generate a distinct info table for each usage of +a constructor. Then, when inspecting the heap you can see precisely which usage of a constructor +was responsible for each allocation. + +-} diff --git a/GHC/Stg/EnforceEpt.hs b/GHC/Stg/EnforceEpt.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/EnforceEpt.hs @@ -0,0 +1,750 @@ +{-# 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.EnforceEpt ( enforceEpt ) 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.Demand (isDeadEndAppSig) +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.EnforceEpt.Types +import GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds) +import Data.Maybe +import GHC.Types.Name.Env (mkNameEnv, NameEnv) +import GHC.Driver.DynFlags +import GHC.Utils.Logger +import qualified GHC.Unit.Types + +{- Note [Evaluated and Properly Tagged] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A pointer is Evaluated and Properly Tagged (EPT) when the pointer + + (a) points directly to the value (not to an indirection, and not to a thunk) + (b) is tagged with the tag corresponding to said value (e.g. constructor tag + or arity of a function). + +A binder is EPT when all the runtime pointers it binds are EPT. + +Note that a lifted EPT pointer will never point to a thunk, nor will it be +tagged `000` (meaning "might be a thunk"). + +See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/rts/haskell-execution/pointer-tagging +for more information on pointer tagging. + +Examples: +* Case binders are always EPT; hence an eval + case x of x' { __DEFAULT -> ... } + ensures that x' is EPT even if x was not. +* Data constructor bindings + let x = Just y in ... + are EPT: x will point to the heap-allocated constructor closure for (Just y), + and the tag-bits of the pointer will encode the tag for Just (i.e. `010`). +* In practice, GHC also guarantees that strict fields (and others) are EPT; + see Note [EPT enforcement]. + +Caveat: +Currently, the proper tag for builtin *unlifted* data types such as `Array#` is +not `001` but `000`, which is not a proper tag for lifted data. +This means that UnliftedRep is not a proper sub-rep of LiftedRep. +SG thinks it would be good to fix this; see #21792. + +Note [EPT enforcement] +~~~~~~~~~~~~~~~~~~~~~~ +The goal of EnforceEPT pass is to mark as many binders as possible as EPT +(see Note [Evaluated and Properly Tagged]). +To find more EPT binders, it establishes the following + +EPT INVARIANT: +> Any binder of +> * a strict field (see Note [Strict fields in Core]), or +> * a CBV argument (see Note [CBV Function Ids]) +> is EPT. + +(Note that prior to EPT enforcement, this invariant may *not* always be upheld. +An example can be found at the end of this Note.) +This is all to optimise code such as the following: + + data SPair a b = SP !a !b + case p :: SP Bool Bool of + SP x y -> + case x of + True -> ... + False -> ... + +We can infer that the strict field x is EPT and hence may safely +omit the code to enter x and the check for the presence of a tag that goes along +with it. However we still branch on the tag as usual to jump to the True or +False case. + +Note that for every example involving strict fields we could find a similar +example using CBV functions, e.g. + + $wf x[EPT] y = + case x of + True -> ... + False -> ... + +is the above example translated to use a CBV function $wf. +Note that /any/ strict function can in principle be chosen as a CBV function; +however, we presently only promote worker functions such as $wf to CBV because +we see all its call sites and can use the proper by-value calling convention. +More precisely, with -O0, we guarantee that no CBV functions are visible in +the interface file, so that naïve clients do not need to know how to call CBV +functions. See Note [CBV Function Ids] for more details. + +Specification +------------- +EPT enforcement works like implicit type conversions in C, such as from int to +float, only much simpler (no overloaded operations such as +). +For EPT enforcement, the "type system" in question is whether a binder is +statically EPT. We differentiate "EPT binder" from "non-EPT binder", where the +latter means "might be EPT, but we could not prove it so". +In this sense, EPT binders form a subtype of non-EPT binders. +We differentiate two conversion directions: + + * Downcast: EPT binders can be converted into non-EPT binders for free. + * Upcast: non-EPT binders can be converted into EPT binders by inserting an eval. + +The EPT invariant expresses type signatures. In particular, these type +signatures entail two things: + + * A _precondition_: Any binder that is passed as a CBV arg/strict field + must be EPT (i.e. must have type "EPT binder"). + * A _postcondition_: Any binder of a CBV arg/strict field is EPT. + +EPT enforcement is then simply a matter of figuring out where to insert +Upcasts (remember that Downcasts are free). +Since Upcasts (evals!) are not free, it is desirable to insert as few as possible. +To this end, we run a static *EPT analysis*, the purpose of which is to identify +as many EPT binders as possible. +Beyond discovering case binders and value bindings, EPT analysis exploits the +type signatures provided by the EPT invariant, looks inside returned tuples and +does some limited amount of fixpointing. +Afterwards, the *EPT rewriter* inserts the actual evals realising Upcasts. + +Implementation +-------------- + +* EPT analysis is implemented in GHC.Stg.EnforceEpt.inferTags. + It attaches its result to /binders/, not occurrence sites. +* The EPT rewriter establishes the EPT invariant by inserting evals. That is, if + (a) a binder x is used to + * construct a strict field (`SP x y`), or + * passed as a CBV argument (`$wf x`), + and + (b) x was not inferred EPT, + then the EPT rewriter inserts an eval prior to the call, e.g. + case x of x' { __ DEFAULT -> SP x' y }. + case x of x' { __ DEFAULT -> $wf x' }. + (Recall that the case binder x' is always EPT.) + This is implemented in GHC.Stg.EnforceEpt.Rewrite.rewriteTopBinds. + This pass also propagates the EPTness from binders to occurrences. + It is sound to insert evals on strict fields (Note [Strict fields in Core]), + and on CBV arguments as well (Note [CBV Function Ids]). +* We also export the EPTness of top level bindings to allow this optimisation + to work across module boundaries. + NB: The EPT Invariant *must* be upheld, regardless of the optimisation level; + hence EPTness is practically part of the internal ABI of a strict data + constructor or CBV function. Note [CBV Function Ids] contains the details. +* Finally, code generation skips the thunk check when branching on binders that + are EPT. This is done by `cgExpr`/`cgCase` in the backend. + +Evaluation +---------- +EPT enforcement can have large impact on spine-strict tree data structure +performance. 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. + +Note that EPT enforcement may cause regressions in rare cases. +For example consider this code: + + foo x = ... + let c = StrictJust x + in ... + +When x cannot be inferred EPT, the rewriter transforms to + + foo x = ... + let c = case x of x' -> StrictJust x' + in ... + +which allocates an additional thunk for `c` that returns the constructor. Boo! + +Note [EPT enforcement lowers strict constructor worker semantics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Core, a saturated application of a strict constructor worker evaluates its +strict fields and thus is *not* a value; see Note [Strict fields in Core]. +This is also the semantics of strict constructor workers in STG *before* EPT +enforcement (see Note [EPT enforcement]) + +However, after enforcing the EPT Invariant, all constructor workers can +effectively be lazy. That is, when actually generating code to allocate the +data constructor, the code generator does not need to evaluate the argument; +that has already been done by the EPT pass. + +Thus for code-gen reasons (StgToX), all constructor workers are considered lazy +after EPT enforcement. + +Note [Why isn't the EPT Invariant enforced during Core passes?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall the definition of the EPT Invariant from Note [EPT enforcement]. +Why can't it be established as an invariant right while desugaring to Core? +The reason is that some Core optimisations, such as FloatOut, will drop or delay +evals whenever they think it useful and thus destroy the Invariant. Example: + + data Set a = Tip | Bin !a (Set a) (Set a) + +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 Core optimisation passes +might destroy the EPT Invariant, hence we need to enforce the EPT invariant +*after* passes such as FloatOut. +-} + +{- Note [TagInfo of functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The purpose of tag inference is really to figure out when we don't have to enter +value closures. There the meaning of the tag is fairly obvious. +For functions we never make use of the tag info so we have two choices: +* Treat them as TagDunno +* Treat them as TagProper (as they *are* tagged with their arity) and be really + careful to make sure we still enter them when needed. +As it makes little difference for runtime performance I've treated functions as TagDunno in a few places where +it made the code simpler. But besides implementation complexity there isn't any reason +why we couldn't be more rigorous in dealing with functions. + +NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions. +So option two isn't really an option without reworking this anyway. + +Note [EPT enforcement debugging] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a flag -dtag-inference-checks which inserts various +compile/runtime checks in order to ensure the EPT 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. + +Note [EPT enforcement for interpreted code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The bytecode interpreter has a different behaviour when it comes +to the tagging of binders in certain situations than the StgToCmm code generator. + +a) Tags for let-bindings: + + When compiling a binding for a constructor like `let x = Just True` + Whether `x` will be properly tagged depends on the backend. + For the interpreter x points to a BCO which once + evaluated returns a properly tagged pointer to the heap object. + In the Cmm backend for the same binding we would allocate the constructor right + away and x will immediately be represented by a tagged pointer. + This means for interpreted code we can not assume let bound constructors are + properly tagged. Hence we distinguish between targeting bytecode and native in + the analysis. + We make this differentiation in `mkLetSig` where we simply never assume + lets are tagged when targeting bytecode. + +b) When referencing ids from other modules the Cmm backend will try to put a + proper tag on these references through various means. When doing analysis we + usually predict these cases to improve precision of the analysis. + But to my knowledge the bytecode generator makes no such attempts so we must + not infer imported bindings as tagged. + This is handled in GHC.Stg.EnforceEpt.Types.lookupInfo + + +-} + +{- ********************************************************************* +* * + EPT enforcement pass +* * +********************************************************************* -} + +enforceEpt :: StgPprOpts -> Bool -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig) +enforceEpt ppr_opts !for_bytecode logger this_mod stg_binds = do + -- pprTraceM "enforceEpt for " (ppr this_mod <> text " bytecode:" <> ppr for_bytecode) + -- Annotate binders with tag information. + let (!stg_binds_w_tags) = {-# SCC "StgEptInfer" #-} + inferTags for_bytecode stg_binds + putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags) + + let export_tag_info = collectExportInfo stg_binds_w_tags + + -- Rewrite STG to uphold the strict field invariant + us_t <- mkSplitUniqSupply 't' + let rewritten_binds = {-# SCC "StgEptRewrite" #-} 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) + +inferTags :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders] +inferTags for_bytecode binds = + -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $ + snd (mapAccumL inferTagTopBind (initEnv for_bytecode) 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 + -- It's important that we check for bottoms before all else. + -- See Note [Bottom functions are TagTagged] and #24806 for why. + | isDeadEndAppSig (idDmdSig fun) (length args) + = TagTagged + + | fun_arity == 0 -- Unknown arity => Thunk or unknown call + = TagDunno + + | 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 + +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) + -- Which primops guarantee to return a properly tagged value? + -- Probably none, and that is the conservative assumption anyway. + -- (And foreign calls definitely need not make promises.) + = (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 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, out_sig) rhs') + where + id = getBinderId in_env bndr + (in_sig,rhs') = inferTagRhs id in_env rhs + out_sig = mkLetSig in_env in_sig + env' = extendSigEnv in_env [(id, out_sig)] + +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 + in_bndrs = in_ids `zip` in_sigs + out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive + rhs_env = extendSigEnv go_env in_bndrs + (out_sigs, rhss') = unzip (zipWithEqual anaRhs in_ids go_rhss) + env' = makeTagged go_env + + anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders) + anaRhs bnd rhs = + let (sig_rhs,rhs') = inferTagRhs bnd rhs_env rhs + in (mkLetSig go_env sig_rhs, 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. + +NB: After the analysis is done we go back to treating bottoming functions as +untagged to ensure they are evaluated as expected in code like: + + case bottom_id of { ...} + +-} + +----------------------------- +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 typ) + | isDeadEndId bnd_id && (notNull) bndrs + -- See Note [Bottom functions are TagTagged] + = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body' typ) + | otherwise + = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $ + (TagSig info', StgRhsClosure ext cc upd out_bndrs body' typ) + 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 typ) +-- 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 typ) + +-- Adjust let semantics to the targeted backend. +-- See Note [EPT enforcement for interpreted code] +mkLetSig :: TagEnv p -> TagSig -> TagSig +mkLetSig env in_sig + | for_bytecode = TagSig TagDunno + | otherwise = in_sig + where + for_bytecode = te_bytecode env + +{- 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 = f ... + let c = 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 = f ... + let c = StrictPair x True + +Which in the rewrite stage will then be rewritten into: + + let x = f ... + let c = 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 = True + let x = ... + let f z = case z of z' -> (# c, x #) + +Here we will infer for f the Signature . +This information will be used if we scrutinize a saturated application of +`f` in order to determine the taggedness of the result. +That is for `case f x of (# r1,r2 #) -> rhs` we can infer +r1 and r2 which allows us to skip all tag checks on `r1` +in `rhs`. + +Things get a bit more complicated with nesting: + + let closeFd = ... + let f x = ... + case x of + _ -> Solo# closeFd + +The "natural" signature for the Solo# branch in `f` would be . +But we flatten this out to 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 args (dataConRuntimeRepStrictness con) :: ([(StgArg, StrictnessMark)]) + arg_needs_eval (arg,strict) + -- lazy args + | not (isMarkedStrict strict) = False + | tag <- (lookupInfo env arg) + -- banged args need to be tagged, or require eval + = not (isTaggedInfo tag) + + flatten_arg_tag (TagTagged) = TagProper + flatten_arg_tag (TagProper ) = TagProper + flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs] + flatten_arg_tag (TagDunno) = TagDunno + + +collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig +collectExportInfo binds = + mkNameEnv bndr_info + where + bndr_info = concatMap collect binds :: [(Name,TagSig)] + + collect (StgTopStringLit {}) = [] + collect (StgTopLifted bnd) = + case bnd of + StgNonRec (id,sig) _rhs + | TagSig TagDunno <- sig -> [] + | otherwise -> [(idName id,sig)] + StgRec bnds -> collectRec bnds + + collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)] + collectRec [] = [] + collectRec (bnd:bnds) + | (p,_rhs) <- bnd + , (id,sig) <- p + , TagSig TagDunno <- sig + = (idName id,sig) : collectRec bnds + | otherwise = collectRec bnds diff --git a/GHC/Stg/EnforceEpt/Rewrite.hs b/GHC/Stg/EnforceEpt/Rewrite.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/EnforceEpt/Rewrite.hs @@ -0,0 +1,562 @@ + +-- Copyright (c) 2019 Andreas Klebinger +-- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds, rewriteOpApp) +where + +import GHC.Prelude + +import GHC.Builtin.PrimOps ( PrimOp(..) ) +import GHC.Types.Basic ( CbvMark (..), isMarkedCbv + , TopLevelFlag(..), isTopLevel ) +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Unique.Supply +import GHC.Types.Unique.FM +import GHC.Types.RepType +import GHC.Types.Var.Set +import GHC.Unit.Types + +import GHC.Core.DataCon +import GHC.Core ( AltCon(..) ) +import GHC.Core.Type + +import GHC.StgToCmm.Types +import GHC.StgToCmm.Closure (importedIdLFInfo) + +import GHC.Stg.Utils +import GHC.Stg.Syntax as StgSyn + +import GHC.Data.Maybe +import GHC.Utils.Panic + +import GHC.Utils.Outputable +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Misc + +import GHC.Stg.EnforceEpt.Types + +import Control.Monad + +newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) } + deriving (Functor, Monad, Applicative) + +------------------------------------------------------------ +-- Add cases around strict fields where required. +------------------------------------------------------------ +{- +The work of this pass is simple: +* We traverse the STG AST looking for constructor allocations. +* For all allocations we check if there are strict fields in the constructor. +* For any strict field we check if the argument is known to be properly tagged. +* If it's not known to be properly tagged, we wrap the whole thing in a case, + which will force the argument before allocation. +This is described in detail in Note [Evaluated and Properly Tagged]. + +The only slight complication is that we have to make sure not to invalidate free +variable analysis in the process. + +Note [Partially applied workers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes we will get a function f of the form + -- Arity 1 + f :: Dict a -> a -> b -> (c -> d) + f dict a b = case dict of + C m1 m2 -> m1 a b + +Which will result in a W/W split along the lines of + -- Arity 1 + f :: Dict a -> a -> b -> (c -> d) + f dict a = case dict of + C m1 m2 -> $wf m1 a b + + -- Arity 4 + $wf :: (a -> b -> d -> c) -> a -> b -> c -> d + $wf m1 a b c = m1 a b c + +It's notable that the worker is called *undersaturated* in the wrapper. +At runtime what happens is that the wrapper will allocate a PAP which +once fully applied will call the worker. And all is fine. + +But what about a call by value function! Well the function returned by `f` would +be a unknown call, so we lose the ability to enforce the invariant that +cbv marked arguments from StictWorkerId's are actually properly tagged +as the annotations would be unavailable at the (unknown) call site. + +The fix is easy. We eta-expand all calls to functions taking call-by-value +arguments during CorePrep just like we do with constructor allocations. + +Note [Upholding free variable annotations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The code generator requires us to maintain exact information +about free variables about closures. Since we convert some +RHSs from constructor allocations to closures we have to provide +fvs of these closures. Not all constructor arguments will become +free variables. Only these which are not bound at the top level +have to be captured. +To facilitate this we keep track of a set of locally bound variables in +the current context which we then use to filter constructor arguments +when building the free variable list. +-} + +-------------------------------- +-- Utilities +-------------------------------- + +instance MonadUnique RM where + getUniqueSupplyM = RM $ do + (m, us, mod,lcls) <- get + let (us1, us2) = splitUniqSupply us + (put) (m,us2,mod,lcls) + return us1 + +getMap :: RM (UniqFM Id TagSig) +getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get) + +setMap :: (UniqFM Id TagSig) -> RM () +setMap !m = RM $ do + (_,us,mod,lcls) <- get + put (m, us,mod,lcls) + +getMod :: RM Module +getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get) + +getFVs :: RM IdSet +getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get) + +setFVs :: IdSet -> RM () +setFVs !fvs = RM $ do + (tag_map,us,mod,_lcls) <- get + put (tag_map, us,mod,fvs) + +-- Rewrite the RHS(s) while making the id and it's sig available +-- to determine if things are tagged/need to be captured as FV. +withBind :: TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a +withBind top_flag (StgNonRec bnd _) cont = withBinder top_flag bnd cont +withBind top_flag (StgRec binds) cont = do + let (bnds,_rhss) = unzip binds :: ([(Id, TagSig)], [GenStgRhs 'InferTaggedBinders]) + withBinders top_flag bnds cont + +addTopBind :: GenStgBinding 'InferTaggedBinders -> RM () +addTopBind (StgNonRec (id, tag) _) = do + s <- getMap + -- pprTraceM "AddBind" (ppr id) + setMap $ addToUFM s id tag + return () +addTopBind (StgRec binds) = do + let (bnds,_rhss) = unzip binds + !s <- getMap + -- pprTraceM "AddBinds" (ppr $ map fst bnds) + setMap $! addListToUFM s bnds + +withBinder :: TopLevelFlag -> (Id, TagSig) -> RM a -> RM a +withBinder top_flag (id,sig) cont = do + oldMap <- getMap + setMap $ addToUFM oldMap id sig + a <- if isTopLevel top_flag + then cont + else withLcl id cont + setMap oldMap + return a + +withBinders :: TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a +withBinders TopLevel sigs cont = do + oldMap <- getMap + setMap $ addListToUFM oldMap sigs + a <- cont + setMap oldMap + return a +withBinders NotTopLevel sigs cont = do + oldMap <- getMap + oldFvs <- getFVs + setMap $ addListToUFM oldMap sigs + setFVs $ extendVarSetList oldFvs (map fst sigs) + a <- cont + setMap oldMap + setFVs oldFvs + return a + +-- | Compute the argument with the given set of ids treated as requiring capture +-- as free variables. +withClosureLcls :: DIdSet -> RM a -> RM a +withClosureLcls fvs act = do + old_fvs <- getFVs + let !fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs + setFVs fvs' + !r <- act + setFVs old_fvs + return r + +-- | Compute the argument with the given id treated as requiring capture +-- as free variables in closures. +withLcl :: Id -> RM a -> RM a +withLcl fv act = do + old_fvs <- getFVs + let !fvs' = extendVarSet old_fvs fv + setFVs fvs' + !r <- act + setFVs old_fvs + return r + +{- Note [Tag inference for interactive contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When compiling bytecode we call myCoreToStg to get STG code first. +myCoreToStg in turn calls out to stg2stg which runs the STG to STG +passes followed by free variables analysis and the tag inference pass including +its rewriting phase at the end. +Running tag inference is important as it upholds Note [Evaluated and Properly Tagged]. +While code executed by GHCi doesn't take advantage of the SFI it can call into +compiled code which does. So it must still make sure that the SFI is upheld. +See also #21083 and #22042. + +However there one important difference in code generation for GHCi and regular +compilation. When compiling an entire module (not a GHCi expression), we call +`stg2stg` on the entire module which allows us to build up a map which is guaranteed +to have an entry for every binder in the current module. +For non-interactive compilation the tag inference rewrite pass takes advantage +of this by building up a map from binders to their tag signatures. + +When compiling a GHCi expression on the other hand we invoke stg2stg separately +for each expression on the prompt. This means in GHCi for a sequence of: + > let x = True + > let y = StrictJust x +We first run stg2stg for `[x = True]`. And then again for [y = StrictJust x]`. + +While computing the tag signature for `y` during tag inference inferConTag will check +if `x` is already tagged by looking up the tagsig of `x` in the binder->signature mapping. +However since this mapping isn't persistent between stg2stg +invocations the lookup will fail. This isn't a correctness issue since it's always +safe to assume a binding isn't tagged and that's what we do in such cases. + +However for non-interactive mode we *don't* want to do this. Since in non-interactive mode +we have all binders of the module available for each invocation we can expect the binder->signature +mapping to be complete and all lookups to succeed. This means in non-interactive contexts a failed lookup +indicates a bug in the tag inference implementation. +For this reason we assert that we are running in interactive mode if a lookup fails. +-} +isTagged :: Id -> RM Bool +isTagged v + -- See Note [Bottom functions are TagTagged] + | isDeadEndId v = pure False + | otherwise = do + this_mod <- getMod + -- See Note [Tag inference for interactive contexts] + let lookupDefault v = assertPpr (isInteractiveModule this_mod) + (text "unknown Id:" <> ppr this_mod <+> ppr v) + (TagSig TagDunno) + case nameIsLocalOrFrom this_mod (idName v) of + True + | definitelyUnliftedType (idType v) + -- NB: v might be the Id of a representation-polymorphic join point, + -- so we shouldn't use isUnliftedType here. See T22212. + -> return True + | otherwise -> do -- Local binding + !s <- getMap + let !sig = lookupWithDefaultUFM s (lookupDefault v) v + return $ case sig of + TagSig info -> + case info of + TagDunno -> False + TagProper -> True + TagTagged -> True + TagTuple _ -> True -- Consider unboxed tuples tagged. + -- Imported + False -> return $! + -- Determine whether it is tagged from the LFInfo of the imported id. + -- See Note [The LFInfo of Imported Ids] + case importedIdLFInfo v 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 + + +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 typ) = {-# 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 typ) + 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) + + -- We mark the closure updatable to retain sharing in the case that + -- conExpr is an infinite recursive data type. See #23783. + return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) typ +rewriteRhs _binding (StgRhsClosure fvs ccs flag args body typ) = do + withBinders NotTopLevel args $ + withClosureLcls fvs $ + StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body <*> pure typ + -- return (closure) + +fvArgs :: [StgArg] -> RM DVarSet +fvArgs args = do + fv_lcls <- getFVs + -- pprTraceM "fvArgs" (text "args:" <> ppr args $$ text "lcls:" <> pprVarSet (fv_lcls) (braces . fsep . map ppr) ) + return $ mkDVarSet [ v | StgVarArg v <- args, elemVarSet v fv_lcls] + +rewriteArgs :: [StgArg] -> RM [StgArg] +rewriteArgs = mapM rewriteArg +rewriteArg :: StgArg -> RM StgArg +rewriteArg (StgVarArg v) = StgVarArg <$!> rewriteId v +rewriteArg (lit@StgLitArg{}) = return lit + +rewriteId :: Id -> RM Id +rewriteId v = do + !is_tagged <- isTagged v + if is_tagged then return $! setIdTagSig v (TagSig TagProper) + else return v + +rewriteExpr :: GenStgExpr 'InferTaggedBinders -> RM (GenStgExpr 'CodeGen) +rewriteExpr (e@StgCase {}) = rewriteCase e +rewriteExpr (e@StgLet {}) = rewriteLet e +rewriteExpr (e@StgLetNoEscape {}) = rewriteLetNoEscape e +rewriteExpr (StgTick t e) = StgTick t <$!> rewriteExpr e +rewriteExpr e@(StgConApp {}) = rewriteConApp e +rewriteExpr e@(StgApp {}) = rewriteApp e +rewriteExpr (StgLit lit) = return $! (StgLit lit) +rewriteExpr (StgOpApp op args res_ty) = (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty + + +rewriteCase :: InferStgExpr -> RM TgStgExpr +rewriteCase (StgCase scrut bndr alt_type alts) = + withBinder NotTopLevel bndr $ + pure StgCase <*> + rewriteExpr scrut <*> + rewriteId (fst bndr) <*> + pure alt_type <*> + mapM rewriteAlt alts + +rewriteCase _ = panic "Impossible: nodeCase" + +rewriteAlt :: InferStgAlt -> RM TgStgAlt +rewriteAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} = + withBinders NotTopLevel bndrs $ do + !rhs' <- rewriteExpr rhs + return $! alt {alt_bndrs = map fst bndrs, alt_rhs = rhs'} + +rewriteLet :: InferStgExpr -> RM TgStgExpr +rewriteLet (StgLet xt bind expr) = do + (!bind') <- rewriteBinds NotTopLevel bind + withBind NotTopLevel bind $ do + -- pprTraceM "withBindLet" (ppr $ bindersOfX bind) + !expr' <- rewriteExpr expr + return $! (StgLet xt bind' expr') +rewriteLet _ = panic "Impossible" + +rewriteLetNoEscape :: InferStgExpr -> RM TgStgExpr +rewriteLetNoEscape (StgLetNoEscape xt bind expr) = do + (!bind') <- rewriteBinds NotTopLevel bind + withBind NotTopLevel bind $ do + !expr' <- rewriteExpr expr + return $! (StgLetNoEscape xt bind' expr') +rewriteLetNoEscape _ = panic "Impossible" + +rewriteConApp :: InferStgExpr -> RM TgStgExpr +rewriteConApp (StgConApp con cn args tys) = do + -- We check if the strict field arguments are already known to be tagged. + -- If not we evaluate them first. + fieldInfos <- mapM isArgTagged args + let strictIndices = getStrictConArgs con (zip fieldInfos args) :: [(Bool, StgArg)] + let needsEval = map snd . filter (not . fst) $ strictIndices :: [StgArg] + let evalArgs = [v | StgVarArg v <- needsEval] :: [Id] + if (not $ null evalArgs) + then do + -- pprTraceM "Creating conAppSeqs for " $ ppr nodeId <+> parens ( ppr evalArgs ) -- <+> parens ( ppr fieldInfos ) + mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs tys) + else return $! (StgConApp con cn args tys) + +rewriteConApp _ = panic "Impossible" + +-- Special case: Atomic binders, usually in a case context like `case f of ...`. +rewriteApp :: InferStgExpr -> RM TgStgExpr +rewriteApp (StgApp f []) = do + f' <- rewriteId f + return $! StgApp f' [] +rewriteApp (StgApp f args) + -- pprTrace "rewriteAppOther" (ppr f <+> ppr args) False + -- = undefined + | Just marks <- idCbvMarks_maybe f + , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks + , any isMarkedCbv relevant_marks + = assertPpr (length relevant_marks <= length args) (ppr f $$ ppr args $$ ppr relevant_marks) + unliftArg relevant_marks + + where + -- If the function expects any argument to be call-by-value ensure the argument is already + -- evaluated. + unliftArg relevant_marks = do + argTags <- mapM isArgTagged args + let argInfo = zipWith3 ((,,)) args (relevant_marks++repeat NotMarkedCbv) argTags :: [(StgArg, CbvMark, Bool)] + + -- untagged cbv argument positions + cbvArgInfo = filter (\x -> sndOf3 x == MarkedCbv && thdOf3 x == False) argInfo + cbvArgIds = [x | StgVarArg x <- map fstOf3 cbvArgInfo] :: [Id] + mkSeqs args cbvArgIds (\cbv_args -> StgApp f cbv_args) + +rewriteApp (StgApp f args) = return $ StgApp f args +rewriteApp _ = panic "Impossible" + +{- +Note [Rewriting primop arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given an application `op# x y`, is it worth applying `rewriteArg` to +`x` and `y`? All that will do will be to set the `tagSig` for that +occurrence of `x` and `y` to record whether it is evaluated and +properly tagged. For the vast majority of primops that's a waste of +time: the argument is an `Int#` or something. + +But code generation for `seq#` and the `dataToTag#` ops /does/ consult that +tag, to statically avoid generating an eval. All three do so via `cgIdApp`, +which in turn uses `getCallMethod` which looks at the `tagSig`. + +So for these we should call `rewriteArgs`. + +-} + +rewriteOpApp :: InferStgExpr -> RM TgStgExpr +rewriteOpApp (StgOpApp op args res_ty) = case op of + op@(StgPrimOp primOp) + | primOp == DataToTagSmallOp || primOp == DataToTagLargeOp + -- see Note [Rewriting primop arguments] + -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty + _ -> pure $! StgOpApp op args res_ty +rewriteOpApp _ = 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 -> } +{-# INLINE mkSeqs #-} -- We inline to avoid allocating mkExpr +mkSeqs :: [StgArg] -- ^ Original arguments + -> [Id] -- ^ var args to be evaluated ahead of time + -> ([StgArg] -> TgStgExpr) + -- ^ Function that reconstructs the expressions when passed + -- the list of evaluated arguments. + -> RM TgStgExpr +mkSeqs args untaggedIds mkExpr = do + argMap <- mapM (\arg -> (arg,) <$> mkLocalArgId arg ) untaggedIds :: RM [(InId, OutId)] + -- mapM_ (pprTraceM "Forcing strict args before allocation:" . ppr) argMap + let taggedArgs :: [StgArg] + = map (\v -> case v of + StgVarArg v' -> StgVarArg $ fromMaybe v' $ lookup v' argMap + lit -> lit) + args + + let conBody = mkExpr taggedArgs + let body = foldr (\(v,bndr) expr -> mkSeq v bndr expr) conBody argMap + return $! body + +-- Out of all arguments passed at runtime only return these ending up in a +-- strict field +getStrictConArgs :: Outputable a => DataCon -> [a] -> [a] +getStrictConArgs con args + -- These are always lazy in their arguments. + | isUnboxedTupleDataCon con = [] + | isUnboxedSumDataCon con = [] + -- For proper data cons we have to check. + | otherwise = + assertPpr (length args == length (dataConRuntimeRepStrictness con)) + (text "Mismatched con arg and con rep strictness lengths:" $$ + text "Con" <> ppr con <+> text "is applied to" <+> ppr args $$ + text "But seems to have arity" <> ppr (length repStrictness)) $ + [ arg | (arg,MarkedStrict) + <- zipEqual args + repStrictness] + where + repStrictness = (dataConRuntimeRepStrictness con) diff --git a/GHC/Stg/EnforceEpt/TagSig.hs b/GHC/Stg/EnforceEpt/TagSig.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/EnforceEpt/TagSig.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} + +-- We export this type from this module instead of GHC.Stg.EnforceEpt.Types +-- because it's used by more than the analysis itself. For example in interface +-- files where we record a tag signature for bindings. +-- By putting the sig into its own module we can avoid module loops. +module GHC.Stg.EnforceEpt.TagSig + +where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Name.Env( NameEnv ) +import GHC.Utils.Outputable +import GHC.Utils.Binary +import GHC.Utils.Panic.Plain +import Data.Coerce + +-- | Information to be exposed in interface files which is produced +-- by the stg2stg passes. +type StgCgInfos = NameEnv TagSig + +newtype TagSig -- The signature for each binding, this is a newtype as we might + -- want to track more information in the future. + = TagSig TagInfo + deriving (Eq) + +data TagInfo + = TagDunno -- We don't know anything about the tag. + | TagTuple [TagInfo] -- Represents a function/thunk which when evaluated + -- will return a Unboxed tuple whos components have + -- the given TagInfos. + | TagProper -- Heap pointer to properly-tagged value + | TagTagged -- Bottom of the domain. + deriving (Eq) + +instance Outputable TagInfo where + ppr TagTagged = text "TagTagged" + ppr TagDunno = text "TagDunno" + ppr TagProper = text "TagProper" + ppr (TagTuple tis) = text "TagTuple" <> brackets (pprWithCommas ppr tis) + +instance Binary TagInfo where + put_ bh TagDunno = putByte bh 1 + put_ bh (TagTuple flds) = putByte bh 2 >> put_ bh flds + put_ bh TagProper = putByte bh 3 + put_ bh TagTagged = putByte bh 4 + + get bh = do tag <- getByte bh + case tag of 1 -> return TagDunno + 2 -> TagTuple <$> get bh + 3 -> return TagProper + 4 -> return TagTagged + _ -> panic ("get TagInfo " ++ show tag) + +instance Outputable TagSig where + ppr (TagSig ti) = char '<' <> ppr ti <> char '>' +instance OutputableBndr (Id,TagSig) where + pprInfixOcc = ppr + pprPrefixOcc = ppr + +instance Binary TagSig where + put_ bh (TagSig sig) = put_ bh sig + get bh = pure TagSig <*> get bh + +isTaggedSig :: TagSig -> Bool +isTaggedSig (TagSig TagProper) = True +isTaggedSig (TagSig TagTagged) = True +isTaggedSig _ = False + +seqTagSig :: TagSig -> () +seqTagSig = coerce seqTagInfo + +seqTagInfo :: TagInfo -> () +seqTagInfo TagTagged = () +seqTagInfo TagDunno = () +seqTagInfo TagProper = () +seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis diff --git a/GHC/Stg/EnforceEpt/Types.hs b/GHC/Stg/EnforceEpt/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/EnforceEpt/Types.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} + +{-# LANGUAGE UndecidableInstances #-} + -- To permit: type instance XLet 'InferTaggedBinders = XLet 'CodeGen + +module GHC.Stg.EnforceEpt.Types + ( module GHC.Stg.EnforceEpt.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.EnforceEpt.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 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 = TagDunno -- This can happen with rep-polymorphic result, see #26107 +combineAltInfo TagProper (TagTuple {}) = TagDunno -- This can happen with rep-polymorphic result, see #26107 +combineAltInfo TagProper TagProper = TagProper +combineAltInfo (TagTuple is1) (TagTuple is2) = TagTuple (zipWithEqual 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 + , te_bytecode :: !Bool + } + +instance Outputable (TagEnv p) where + ppr te = for_txt <+> ppr (te_env te) + where + for_txt = if te_bytecode te + then text "for_bytecode" + else text "for_native" + +getBinderId :: TagEnv p -> BinderP p -> Id +getBinderId = te_get + +initEnv :: Bool -> TagEnv 'CodeGen +initEnv for_bytecode = TE { te_env = emptyVarEnv + , te_get = \x -> x + , te_bytecode = for_bytecode } + +-- | 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 + , te_bytecode = te_bytecode env } + +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 + +-- | Look up a sig in the given env +lookupSig :: TagEnv p -> Id -> Maybe TagSig +lookupSig env fun = lookupVarEnv (te_env env) fun + +-- | Look up a sig in the env or derive it from information +-- in the arg itself. +lookupInfo :: TagEnv p -> StgArg -> TagInfo +lookupInfo env (StgVarArg var) + -- Nullary data constructors like True, False + | Just dc <- isDataConWorkId_maybe var + , isNullaryRepDataCon dc + , not for_bytecode + = TagProper + + | isUnliftedType (idType var) + = TagProper + + -- Variables in the environment. + | Just (TagSig info) <- lookupVarEnv (te_env env) var + = info + + | Just lf_info <- idLFInfo_maybe var + , not for_bytecode + = 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 + where + for_bytecode = te_bytecode env + +lookupInfo _ (StgLitArg {}) + = TagProper + +isDunnoSig :: TagSig -> Bool +isDunnoSig (TagSig TagDunno) = True +isDunnoSig (TagSig TagProper) = False +isDunnoSig (TagSig TagTuple{}) = False +isDunnoSig (TagSig TagTagged{}) = False + +isTaggedInfo :: TagInfo -> Bool +isTaggedInfo TagProper = True +isTaggedInfo TagTagged = True +isTaggedInfo _ = False + +extendSigEnv :: TagEnv p -> [(Id,TagSig)] -> TagEnv p +extendSigEnv env@(TE { te_env = sig_env }) bndrs + = env { te_env = extendVarEnvList sig_env bndrs } diff --git a/GHC/Stg/FVs.hs b/GHC/Stg/FVs.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/FVs.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} + +{- | +Non-global free variable analysis on STG terms. This pass annotates +non-top-level closure bindings with captured variables. Global variables are not +captured. For example, in a top-level binding like (pseudo-STG) + + f = \[x,y] . + let g = \[p] . reverse (x ++ p) + in g y + +In g, `reverse` and `(++)` are global variables so they're not considered free. +`p` is an argument, so `x` is the only actual free variable here. The annotated +version is thus: + + f = \[x,y] . + let g = [x] \[p] . reverse (x ++ p) + in g y + +Note that non-top-level recursive bindings are also considered free within the +group: + + map = {} \r [f xs0] + let { + Rec { + go = {f, go} \r [xs1] + case xs1 of { + [] -> [] []; + : x xs2 -> + let { xs' = {go, xs2} \u [] go xs2; } in + let { x' = {f, x} \u [] f x; } in + : [x' xs']; + }; + end Rec } + } in go xs0; + +Here go is free in its RHS. + +Top-level closure bindings never capture variables as all of their free +variables are global. +-} +module GHC.Stg.FVs ( + depSortWithAnnotStgPgm, + annBindingFreeVars + ) where + +import GHC.Prelude hiding (mod) + +import GHC.Stg.Syntax +import GHC.Stg.Utils (bindersOf) +import GHC.Types.Id +import GHC.Types.Name (Name, nameIsLocalOrFrom) +import GHC.Types.Tickish ( GenTickish(Breakpoint) ) +import GHC.Types.Unique.Set (nonDetEltsUniqSet) +import GHC.Types.Var.Set +import GHC.Unit.Module (Module) +import GHC.Utils.Misc + +import Data.Graph (SCC (..)) +import GHC.Data.Graph.Directed( Node(..), stronglyConnCompFromEdgedVerticesUniq ) + +{- Note [Why do we need dependency analysis?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The program needs to be in dependency order for the SRT algorithm to +work (see CmmBuildInfoTables, which also includes a detailed +description of the algorithm). + +But isn't it in correct dependency order already? No: + +* The simplifier does not guarantee to produce programs in dependency + order (see #16192 and Note [Glomming] in GHC.Core.Opt.OccurAnal). + This could be solved by a final run of the occurrence analyser, but + that's more work + +* We also don't guarantee that StgLiftLams will preserve the order or + only create minimal recursive groups. +-} + +-------------------------------------------------------------------------------- +-- | Dependency sort a STG program, and annotate it with free variables +-- The returned bindings: +-- * Are in dependency order +-- * Each StgRhsClosure is correctly annotated (in its extension field) +-- with the free variables needed in the closure +-- * Each StgCase is correctly annotated (in its extension field) with +-- the variables that must be saved across the case +depSortWithAnnotStgPgm :: Module -> [StgTopBinding] -> [(CgStgTopBinding,ImpFVs)] +depSortWithAnnotStgPgm this_mod binds + = {-# SCC "STG.depSortWithAnnotStgPgm" #-} + zip lit_binds (repeat emptyVarSet) ++ map from_scc sccs + where + lit_binds :: [CgStgTopBinding] + pairs :: [(Id, StgRhs)] + (lit_binds, pairs) = flattenTopStgBindings binds + + nodes :: [Node Name (Id, CgStgRhs, ImpFVs)] + 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,ImpFVs)] + sccs = stronglyConnCompFromEdgedVerticesUniq nodes + + from_scc = \case + AcyclicSCC (bndr,rhs,imp_fvs) -> (StgTopLifted (StgNonRec bndr rhs), imp_fvs) + CyclicSCC triples -> (StgTopLifted (StgRec pairs), imp_fvs) + where + (ids,rhss,imp_fvss) = unzip3 triples + pairs = zip ids rhss + imp_fvs = unionVarSets imp_fvss + + +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, ImpFVs) +annotateTopPair env0 (bndr, rhs) + = DigraphNode { node_key = idName bndr + , node_payload = (bndr, rhs', imp_fvs) + , node_dependencies = map idName (nonDetEltsUniqSet top_fvs) } + where + (rhs', imp_fvs, top_fvs, _) = rhsFVs env0 rhs + +-------------------------------------------------------------------------------- +-- * Non-global free variable analysis + +data Env + = Env + { -- | Set of locally-bound, not-top-level binders in scope. + -- That is, variables bound by a let (but not let-no-escape), a lambda + -- (in a StgRhsClsoure), a case binder, or a case alternative. These + -- are the variables that must be captured in a function closure, if they + -- are free in the RHS. Example + -- f = \x. let g = \y. x+1 + -- let h = \z. g z + 1 + -- in h x + -- In the body of h we have locals = {x, g, z}. Note that f is top level + -- and does not appear in locals. + locals :: IdSet + , mod :: Module + } + +addLocals :: [Id] -> Env -> Env +addLocals bndrs env + = env { locals = extendVarSetList (locals env) bndrs } + +-------------------------------------------------------------------------------- +-- | TopFVs: set of variables that are: +-- (a) bound at the top level of this module, and +-- (b) appear free in the expression +-- It is a /non-deterministic/ set because we use it only to perform dependency +-- analysis on the top-level bindings. +type TopFVs = IdSet + +-- | ImpFVs: set of variables that are imported +-- +-- It is a /non-deterministic/ set because we use it only to perform module +-- dependency analysis. +type ImpFVs = IdSet + +-- | LocalFVs: set of variable that are: +-- (a) bound locally (by a lambda, non-top-level let, or case); that is, +-- it appears in the 'locals' field of 'Env' +-- (b) appear free in the expression +-- It is a /deterministic/ set because it is used to annotate closures with +-- their free variables, and we want closure layout to be deterministic. +-- +-- Invariant: the LocalFVs returned is a subset of the 'locals' field of Env +type LocalFVs = DIdSet + +-- | Dependency analysis on STG terms. +-- +-- Dependencies of a binding are just free variables in the binding. This +-- includes imported ids and ids in the current module. For recursive groups we +-- just return one set of free variables which is just the union of dependencies +-- of all bindings in the group. +-- +-- Implementation: pass bound variables (NestedIds) to recursive calls, get free +-- variables (TopFVs) back. We ignore imported TopFVs as they do not change the +-- ordering but it improves performance (see `nameIsExternalFrom` call in `vars_fvs`). +-- + +annBindingFreeVars :: Module -> StgBinding -> CgStgBinding +annBindingFreeVars this_mod = fstOf4 . bindingFVs (Env emptyVarSet this_mod) emptyDVarSet + +bindingFVs :: Env -> LocalFVs -> StgBinding -> (CgStgBinding, ImpFVs, TopFVs, LocalFVs) +bindingFVs env body_fv b = + case b of + StgNonRec bndr r -> (StgNonRec bndr r', imp_fvs, top_fvs, lcl_fvs) + where + (r', imp_fvs, top_fvs, rhs_lcl_fvs) = rhsFVs env r + lcl_fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_lcl_fvs + + StgRec pairs -> (StgRec pairs', imp_fvs, top_fvs, lcl_fvss) + where + bndrs = map fst pairs + env' = addLocals bndrs env + (rhss, rhs_imp_fvss, rhs_top_fvss, rhs_lcl_fvss) = mapAndUnzip4 (rhsFVs env' . snd) pairs + top_fvs = unionVarSets rhs_top_fvss + imp_fvs = unionVarSets rhs_imp_fvss + pairs' = zip bndrs rhss + lcl_fvss = delDVarSetList (unionDVarSets (body_fv:rhs_lcl_fvss)) bndrs + +varFVs :: Env -> Id -> (ImpFVs, TopFVs, LocalFVs) -> (ImpFVs, TopFVs, LocalFVs) +varFVs env v (imp_fvs, top_fvs, lcl_fvs) + | v `elemVarSet` locals env -- v is locally bound + = (imp_fvs, top_fvs, lcl_fvs `extendDVarSet` v) + | nameIsLocalOrFrom (mod env) (idName v) -- v is bound at top level + = (imp_fvs, top_fvs `extendVarSet` v, lcl_fvs) + | otherwise -- v is imported + = (imp_fvs `extendVarSet` v, top_fvs, lcl_fvs) + +exprFVs :: Env -> StgExpr -> (CgStgExpr, ImpFVs, TopFVs, LocalFVs) +exprFVs env = go + where + go (StgApp f as) + | (imp_fvs, top_fvs, lcl_fvs) <- varFVs env f (argsFVs env as) + = (StgApp f as, imp_fvs, top_fvs, lcl_fvs) + + go (StgLit lit) = (StgLit lit, emptyVarSet, emptyVarSet, emptyDVarSet) + + go (StgConApp dc n as tys) + | (imp_fvs, top_fvs, lcl_fvs) <- argsFVs env as + = (StgConApp dc n as tys, imp_fvs, top_fvs, lcl_fvs) + + go (StgOpApp op as ty) + | (imp_fvs, top_fvs, lcl_fvs) <- argsFVs env as + = (StgOpApp op as ty, imp_fvs, top_fvs, lcl_fvs) + + go (StgCase scrut bndr ty alts) + | (scrut',scrut_imp_fvs,scrut_top_fvs,scrut_lcl_fvs) <- exprFVs env scrut + , (alts',alts_imp_fvss,alts_top_fvss,alts_lcl_fvss) + <- mapAndUnzip4 (altFVs (addLocals [bndr] env)) alts + , let top_fvs = scrut_top_fvs `unionVarSet` unionVarSets alts_top_fvss + imp_fvs = scrut_imp_fvs `unionVarSet` unionVarSets alts_imp_fvss + alts_lcl_fvs = unionDVarSets alts_lcl_fvss + lcl_fvs = delDVarSet (unionDVarSet scrut_lcl_fvs alts_lcl_fvs) bndr + = (StgCase scrut' bndr ty alts', imp_fvs, top_fvs, lcl_fvs) + + go (StgLet ext bind body) = go_bind (StgLet ext) bind body + go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body + + go (StgTick tick e) + | (e', imp_fvs, top_fvs, lcl_fvs) <- exprFVs env e + , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs + = (StgTick tick e', imp_fvs, top_fvs, lcl_fvs') + where + tickish (Breakpoint _ _ ids) = mkDVarSet ids + tickish _ = emptyDVarSet + + go_bind dc bind body = (dc bind' body', imp_fvs, top_fvs, lcl_fvs) + where + env' = addLocals (bindersOf bind) env + (body', body_imp_fvs, body_top_fvs, body_lcl_fvs) = exprFVs env' body + (bind', bind_imp_fvs, bind_top_fvs, lcl_fvs) = bindingFVs env' body_lcl_fvs bind + top_fvs = bind_top_fvs `unionVarSet` body_top_fvs + imp_fvs = bind_imp_fvs `unionVarSet` body_imp_fvs + + +rhsFVs :: Env -> StgRhs -> (CgStgRhs, ImpFVs, TopFVs, LocalFVs) +rhsFVs env (StgRhsClosure _ ccs uf bs body typ) + | (body', imp_fvs, top_fvs, lcl_fvs) <- exprFVs (addLocals bs env) body + , let lcl_fvs' = delDVarSetList lcl_fvs bs + = (StgRhsClosure lcl_fvs' ccs uf bs body' typ, imp_fvs, top_fvs, lcl_fvs') +rhsFVs env (StgRhsCon ccs dc mu ts bs typ) + | (imp_fvs, top_fvs, lcl_fvs) <- argsFVs env bs + = (StgRhsCon ccs dc mu ts bs typ, imp_fvs, top_fvs, lcl_fvs) + +argsFVs :: Env -> [StgArg] -> (ImpFVs, TopFVs, LocalFVs) +argsFVs env = foldl' f (emptyVarSet, emptyVarSet, emptyDVarSet) + where + f (imp_fvs,fvs,ids) StgLitArg{} = (imp_fvs, fvs, ids) + f (imp_fvs,fvs,ids) (StgVarArg v) = varFVs env v (imp_fvs, fvs, ids) + +altFVs :: Env -> StgAlt -> (CgStgAlt, ImpFVs, TopFVs, LocalFVs) +altFVs env GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e} + | (e', imp_fvs, 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, imp_fvs, top_fvs, lcl_fvs') diff --git a/GHC/Stg/Lift.hs b/GHC/Stg/Lift.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Lift.hs @@ -0,0 +1,255 @@ + + +-- | Implements a selective lambda lifter, running late in the optimisation +-- pipeline. +-- +-- If you are interested in the cost model that is employed to decide whether +-- to lift a binding or not, look at "GHC.Stg.Lift.Analysis". +-- "GHC.Stg.Lift.Monad" contains the transformation monad that hides away some +-- plumbing of the transformation. +module GHC.Stg.Lift + ( + -- * Late lambda lifting in STG + -- $note + StgLiftConfig (..), + stgLiftLams + ) +where + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Stg.FVs ( annBindingFreeVars ) +import GHC.Stg.Lift.Config +import GHC.Stg.Lift.Analysis +import GHC.Stg.Lift.Monad +import GHC.Stg.Syntax +import GHC.Unit.Module (Module) +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.Var.Set +import Control.Monad ( when ) +import Data.Maybe ( isNothing ) + +-- Note [Late lambda lifting in STG] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- $note +-- See also the +-- and #9476. +-- +-- The basic idea behind lambda lifting is to turn locally defined functions +-- into top-level functions. Free variables are then passed as additional +-- arguments at *call sites* instead of having a closure allocated for them at +-- *definition site*. Example: +-- +-- @ +-- let x = ...; y = ... in +-- let f = {x y} \a -> a + x + y in +-- let g = {f x} \b -> f b + x in +-- g 5 +-- @ +-- +-- Lambda lifting @f@ would +-- +-- 1. Turn @f@'s free variables into formal parameters +-- 2. Update @f@'s call site within @g@ to @f x y b@ +-- 3. Update @g@'s closure: Add @y@ as an additional free variable, while +-- removing @f@, because @f@ no longer allocates and can be floated to +-- top-level. +-- 4. Actually float the binding of @f@ to top-level, eliminating the @let@ +-- in the process. +-- +-- This results in the following program (with free var annotations): +-- +-- @ +-- f x y a = a + x + y; +-- let x = ...; y = ... in +-- let g = {x y} \b -> f x y b + x in +-- g 5 +-- @ +-- +-- This optimisation is all about lifting only when it is beneficial to do so. +-- The above seems like a worthwhile lift, judging from heap allocation: +-- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while +-- not changing the size of @g@'s closure. +-- +-- You can probably sense that there's some kind of cost model at play here. +-- And you are right! But we also employ a couple of other heuristics for the +-- lifting decision which are outlined in "GHC.Stg.Lift.Analysis#when". +-- +-- The transformation is done in "GHC.Stg.Lift", which calls out to +-- 'GHC.Stg.Lift.Analysis.goodToLift' for its lifting decision. It relies on +-- "GHC.Stg.Lift.Monad", which abstracts some subtle STG invariants into a +-- monadic substrate. +-- +-- Suffice to say: We trade heap allocation for stack allocation. +-- The additional arguments have to passed on the stack (or in registers, +-- depending on architecture) every time we call the function to save a single +-- heap allocation when entering the let binding. Nofib suggests a mean +-- improvement of about 1% for this pass, so it seems like a worthwhile thing to +-- do. Compile-times went up by 0.6%, so all in all a very modest change. +-- +-- For a concrete example, look at @spectral/atom@. There's a call to 'zipWith' +-- that is ultimately compiled to something like this +-- (module desugaring/lowering to actual STG): +-- +-- @ +-- propagate dt = ...; +-- runExperiment ... = +-- let xs = ... in +-- let ys = ... in +-- let go = {dt go} \xs ys -> case (xs, ys) of +-- ([], []) -> [] +-- (x:xs', y:ys') -> propagate dt x y : go xs' ys' +-- in go xs ys +-- @ +-- +-- This will lambda lift @go@ to top-level, speeding up the resulting program +-- by roughly one percent: +-- +-- @ +-- propagate dt = ...; +-- go dt xs ys = case (xs, ys) of +-- ([], []) -> [] +-- (x:xs', y:ys') -> propagate dt x y : go dt xs' ys' +-- runExperiment ... = +-- let xs = ... in +-- let ys = ... in +-- in go dt xs ys +-- @ + + + +-- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift'). +-- +-- (Mostly) textbook instance of the lambda lifting transformation, selecting +-- which bindings to lambda lift by consulting 'goodToLift'. +stgLiftLams :: Module -> StgLiftConfig -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding] +stgLiftLams this_mod cfg us = runLiftM cfg us . foldr (liftTopLvl this_mod) (pure ()) + +liftTopLvl :: Module -> InStgTopBinding -> LiftM () -> LiftM () +liftTopLvl _ (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do + addTopStringLit bndr' lit + rest +liftTopLvl this_mod (StgTopLifted bind) rest = do + let is_rec = isRec $ fst $ decomposeStgBinding bind + when is_rec startBindingGroup + let bind_w_fvs = annBindingFreeVars this_mod bind + withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do + -- We signal lifting of a binding through returning Nothing. + -- Should never happen for a top-level binding, though, since we are already + -- at top-level. + case mb_bind' of + Nothing -> pprPanic "StgLiftLams" (text "Lifted top-level binding") + Just bind' -> addLiftedBinding bind' + when is_rec endBindingGroup + rest + +withLiftedBind + :: TopLevelFlag + -> LlStgBinding + -> Skeleton + -> (Maybe OutStgBinding -> LiftM a) + -> LiftM a +withLiftedBind top_lvl bind scope k + = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec)) + where + (rec, pairs) = decomposeStgBinding bind + +withLiftedBindPairs + :: TopLevelFlag + -> RecFlag + -> [(BinderInfo, LlStgRhs)] + -> Skeleton + -> (Maybe [(Id, OutStgRhs)] -> LiftM a) + -> LiftM a +withLiftedBindPairs top rec pairs scope k = do + let (infos, rhss) = unzip pairs + let bndrs = map binderInfoBndr infos + expander <- liftedIdsExpander + cfg <- getConfig + case goodToLift cfg top rec expander pairs scope of + -- @abs_ids@ is the set of all variables that need to become parameters. + Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do + -- Within this block, all binders in @bndrs@ will be noted as lifted, so + -- that the return value of @liftedIdsExpander@ in this context will also + -- expand the bindings in @bndrs@ to their free variables. + -- Now we can recurse into the RHSs and see if we can lift any further + -- bindings. We pass the set of expanded free variables (thus OutIds) on + -- to @liftRhs@ so that it can add them as parameter binders. + when (isRec rec) startBindingGroup + rhss' <- traverse (liftRhs (Just abs_ids)) rhss + let pairs' = zip bndrs' rhss' + addLiftedBinding (mkStgBinding rec pairs') + when (isRec rec) endBindingGroup + k Nothing + Nothing -> withSubstBndrs bndrs $ \bndrs' -> do + -- Don't lift the current binding, but possibly some bindings in their + -- RHSs. + rhss' <- traverse (liftRhs Nothing) rhss + let pairs' = zip bndrs' rhss' + k (Just pairs') + +liftRhs + :: Maybe (DIdSet) + -- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@ + -- as lambda binders, discarding all free vars. + -> LlStgRhs + -> LiftM OutStgRhs +liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args typ) + = assertPpr (isNothing mb_former_fvs) + (text "Should never lift a constructor" + $$ pprStgRhs panicStgPprOpts rhs) $ + StgRhsCon ccs con mn ts <$> traverse liftArgs args <*> pure typ +liftRhs Nothing (StgRhsClosure _ ccs upd infos body typ) = + -- This RHS wasn't lifted. + withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> + StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body <*> pure typ +liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body typ) = + -- This RHS was lifted. Insert extra binders for @former_fvs@. + withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do + let bndrs'' = dVarSetElems former_fvs ++ bndrs' + StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body <*> pure typ + +liftArgs :: InStgArg -> LiftM OutStgArg +liftArgs a@(StgLitArg _) = pure a +liftArgs (StgVarArg occ) = do + assertPprM (not <$> isLifted occ) (text "StgArgs should never be lifted" $$ ppr occ) + StgVarArg <$> substOcc occ + +liftExpr :: LlStgExpr -> LiftM OutStgExpr +liftExpr (StgLit lit) = pure (StgLit lit) +liftExpr (StgTick t e) = StgTick t <$> liftExpr e +liftExpr (StgApp f args) = do + f' <- substOcc f + args' <- traverse liftArgs args + fvs' <- formerFreeVars f + let top_lvl_args = map StgVarArg fvs' ++ args' + pure (StgApp f' top_lvl_args) +liftExpr (StgConApp con mn args tys) = StgConApp con mn <$> traverse liftArgs args <*> pure tys +liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty +liftExpr (StgCase scrut info ty alts) = do + scrut' <- liftExpr scrut + withSubstBndr (binderInfoBndr info) $ \bndr' -> do + alts' <- traverse liftAlt alts + pure (StgCase scrut' bndr' ty alts') +liftExpr (StgLet scope bind body) + = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do + body' <- liftExpr body + case mb_bind' of + Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats + Just bind' -> pure (StgLet noExtFieldSilent bind' body') +liftExpr (StgLetNoEscape scope bind body) + = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do + body' <- liftExpr body + case mb_bind' of + Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs") + Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body') + +liftAlt :: LlStgAlt -> LiftM OutStgAlt +liftAlt alt@GenStgAlt{alt_con=_, alt_bndrs=infos, alt_rhs=rhs} = + withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> + do !rhs' <- liftExpr rhs + return $! alt {alt_bndrs = bndrs', alt_rhs = rhs'} diff --git a/GHC/Stg/Lift/Analysis.hs b/GHC/Stg/Lift/Analysis.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Lift/Analysis.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +-- | Provides the heuristics for when it's beneficial to lambda lift bindings. +-- Most significantly, this employs a cost model to estimate impact on heap +-- allocations, by looking at an STG expression's 'Skeleton'. +module GHC.Stg.Lift.Analysis ( + -- * #when# When to lift + -- $when + + -- * #clogro# Estimating closure growth + -- $clogro + + -- * AST annotation + Skeleton(..), BinderInfo(..), binderInfoBndr, + LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind, + -- * Lifting decision + goodToLift, + closureGrowth -- Exported just for the docs + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Profile + +import GHC.Types.Basic +import GHC.Types.Demand +import GHC.Types.Id + +import GHC.Runtime.Heap.Layout ( WordOff ) + +import GHC.Stg.Lift.Config +import GHC.Stg.Lift.Types +import GHC.Stg.Syntax + +import qualified GHC.StgToCmm.ArgRep as StgToCmm.ArgRep +import qualified GHC.StgToCmm.Closure as StgToCmm.Closure +import qualified GHC.StgToCmm.Layout as StgToCmm.Layout +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Var.Set + +import Data.Maybe ( mapMaybe ) + +-- Note [When to lift] +-- ~~~~~~~~~~~~~~~~~~~ +-- $when +-- The analysis proceeds in two steps: +-- +-- 1. It tags the syntax tree with analysis information in the form of +-- 'BinderInfo' at each binder and 'Skeleton's at each let-binding +-- by 'tagSkeletonTopBind' and friends. +-- 2. The resulting syntax tree is treated by the "GHC.Stg.Lift" +-- module, calling out to 'goodToLift' to decide if a binding is worthwhile +-- to lift. +-- 'goodToLift' consults argument occurrence information in 'BinderInfo' +-- and estimates 'closureGrowth', for which it needs the 'Skeleton'. +-- +-- So the annotations from 'tagSkeletonTopBind' ultimately fuel 'goodToLift', +-- which employs a number of heuristics to identify and exclude lambda lifting +-- opportunities deemed non-beneficial: +-- +-- [Top-level bindings] can't be lifted. +-- [Thunks] and data constructors shouldn't be lifted in order not to destroy +-- sharing. +-- [Argument occurrences] #arg_occs# of binders prohibit them to be lifted. +-- Doing the lift would re-introduce the very allocation at call sites that +-- we tried to get rid off in the first place. We capture analysis +-- information in 'BinderInfo'. Note that we also consider a nullary +-- application as argument occurrence, because it would turn into an n-ary +-- partial application created by a generic apply function. This occurs in +-- CPS-heavy code like the CS benchmark. +-- [Join points] should not be lifted, simply because there's no reduction in +-- allocation to be had. +-- [Abstracting over join points] destroys join points, because they end up as +-- arguments to the lifted function. +-- [Abstracting over known local functions] turns a known call into an unknown +-- call (e.g. some @stg_ap_*@), which is generally slower. Can be turned off +-- with @-fstg-lift-lams-known@. +-- [Calling convention] Don't lift when the resulting function would have a +-- higher arity than available argument registers for the calling convention. +-- Can be influenced with @-fstg-lift-(non)rec-args(-any)@. +-- [Closure growth] introduced when former free variables have to be available +-- at call sites may actually lead to an increase in overall allocations +-- resulting from a lift. Estimating closure growth is described in +-- "GHC.Stg.Lift.Analysis#clogro" and is what most of this module is ultimately +-- concerned with. +-- +-- There's a with +-- some more background and history. + +-- Note [Estimating closure growth] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- $clogro +-- We estimate closure growth by abstracting the syntax tree into a 'Skeleton', +-- capturing only syntactic details relevant to 'closureGrowth', such as +-- +-- * 'ClosureSk', representing closure allocation. +-- * 'RhsSk', representing a RHS of a binding and how many times it's called +-- by an appropriate 'Card'. +-- * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element. +-- +-- This abstraction is mostly so that the main analysis function 'closureGrowth' +-- can stay simple and focused. Also, skeletons tend to be much smaller than +-- the syntax tree they abstract, so it makes sense to construct them once and +-- and operate on them instead of the actual syntax tree. +-- +-- A more detailed treatment of computing closure growth, including examples, +-- can be found in the paper referenced from the +-- . + +llTrace :: String -> SDoc -> a -> a +llTrace _ _ c = c +-- llTrace a b c = pprTrace a b c + +mkArgOccs :: [StgArg] -> IdSet +mkArgOccs = mkVarSet . mapMaybe stg_arg_var + where + stg_arg_var (StgVarArg occ) = Just occ + stg_arg_var _ = Nothing + +-- | Tags every binder with its 'BinderInfo' and let bindings with their +-- 'Skeleton's. +tagSkeletonTopBind :: CgStgBinding -> LlStgBinding +-- NilSk is OK when tagging top-level bindings. Also, top-level things are never +-- lambda-lifted, so no need to track their argument occurrences. They can also +-- never be let-no-escapes (thus we pass False). +tagSkeletonTopBind bind = bind' + where + (_, _, _, bind') = tagSkeletonBinding False NilSk emptyVarSet bind + +-- | Tags binders of an 'StgExpr' with its 'BinderInfo' and let bindings with +-- their 'Skeleton's. Additionally, returns its 'Skeleton' and the set of binder +-- occurrences in argument and nullary application position +-- (cf. "GHC.Stg.Lift.Analysis#arg_occs"). +tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr) +tagSkeletonExpr (StgLit lit) + = (NilSk, emptyVarSet, StgLit lit) +tagSkeletonExpr (StgConApp con mn args tys) + = (NilSk, mkArgOccs args, StgConApp con mn args tys) +tagSkeletonExpr (StgOpApp op args ty) + = (NilSk, mkArgOccs args, StgOpApp op args ty) +tagSkeletonExpr (StgApp f args) + = (NilSk, arg_occs, StgApp f args) + where + arg_occs + -- This checks for nullary applications, which we treat the same as + -- argument occurrences, see "GHC.Stg.Lift.Analysis#arg_occs". + | null args = unitVarSet f + | otherwise = mkArgOccs args +tagSkeletonExpr (StgCase scrut bndr ty alts) + = (skel, arg_occs, StgCase scrut' bndr' ty alts') + where + (scrut_skel, scrut_arg_occs, scrut') = tagSkeletonExpr scrut + (alt_skels, alt_arg_occss, alts') = mapAndUnzip3 tagSkeletonAlt alts + skel = bothSk scrut_skel (foldr altSk NilSk alt_skels) + arg_occs = unionVarSets (scrut_arg_occs:alt_arg_occss) `delVarSet` bndr + bndr' = BoringBinder bndr +tagSkeletonExpr (StgTick t e) + = (skel, arg_occs, StgTick t e') + where + (skel, arg_occs, e') = tagSkeletonExpr e +tagSkeletonExpr (StgLet _ bind body) = tagSkeletonLet False body bind +tagSkeletonExpr (StgLetNoEscape _ bind body) = tagSkeletonLet True body bind + +mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr +mkLet True = StgLetNoEscape +mkLet _ = StgLet + +tagSkeletonLet + :: Bool + -- ^ Is the binding a let-no-escape? + -> CgStgExpr + -- ^ Let body + -> CgStgBinding + -- ^ Binding group + -> (Skeleton, IdSet, LlStgExpr) + -- ^ RHS skeletons, argument occurrences and annotated binding +tagSkeletonLet is_lne body bind + = (let_skel, arg_occs, mkLet is_lne scope bind' body') + where + (body_skel, body_arg_occs, body') = tagSkeletonExpr body + (let_skel, arg_occs, scope, bind') + = tagSkeletonBinding is_lne body_skel body_arg_occs bind + +tagSkeletonBinding + :: Bool + -- ^ Is the binding a let-no-escape? + -> Skeleton + -- ^ Let body skeleton + -> IdSet + -- ^ Argument occurrences in the body + -> CgStgBinding + -- ^ Binding group + -> (Skeleton, IdSet, Skeleton, LlStgBinding) + -- ^ Let skeleton, argument occurrences, scope skeleton of binding and + -- the annotated binding +tagSkeletonBinding is_lne body_skel body_arg_occs (StgNonRec bndr rhs) + = (let_skel, arg_occs, scope, bind') + where + (rhs_skel, rhs_arg_occs, rhs') = tagSkeletonRhs bndr rhs + arg_occs = (body_arg_occs `unionVarSet` rhs_arg_occs) `delVarSet` bndr + bind_skel + | is_lne = rhs_skel -- no closure is allocated for let-no-escapes + | otherwise = ClosureSk bndr (freeVarsOfRhs rhs) rhs_skel + let_skel = bothSk body_skel bind_skel + occurs_as_arg = bndr `elemVarSet` body_arg_occs + -- Compared to the recursive case, this exploits the fact that @bndr@ is + -- never free in @rhs@. + scope = body_skel + bind' = StgNonRec (BindsClosure bndr occurs_as_arg) rhs' +tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs) + = (let_skel, arg_occs, scope, StgRec pairs') + where + (bndrs, _) = unzip pairs + -- Local recursive STG bindings also regard the defined binders as free + -- vars. We want to delete those for our cost model, as these are known + -- calls anyway when we add them to the same top-level recursive group as + -- the top-level binding currently being analysed. + skel_occs_rhss' = map (uncurry tagSkeletonRhs) pairs + rhss_arg_occs = map sndOf3 skel_occs_rhss' + scope_occs = unionVarSets (body_arg_occs:rhss_arg_occs) + arg_occs = scope_occs `delVarSetList` bndrs + -- @skel_rhss@ aren't yet wrapped in closures. We'll do that in a moment, + -- but we also need the un-wrapped skeletons for calculating the @scope@ + -- of the group, as the outer closures don't contribute to closure growth + -- when we lift this specific binding. + scope = foldr (bothSk . fstOf3) body_skel skel_occs_rhss' + -- Now we can build the actual Skeleton for the expression just by + -- iterating over each bind pair. + (bind_skels, pairs') = unzip (zipWith single_bind bndrs skel_occs_rhss') + let_skel = foldr bothSk body_skel bind_skels + single_bind bndr (skel_rhs, _, rhs') = (bind_skel, (bndr', rhs')) + where + -- Here, we finally add the closure around each @skel_rhs@. + bind_skel + | is_lne = skel_rhs -- no closure is allocated for let-no-escapes + | otherwise = ClosureSk bndr fvs skel_rhs + fvs = freeVarsOfRhs rhs' `dVarSetMinusVarSet` mkVarSet bndrs + bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs) + +tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs) +tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args typ) + = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args typ) +tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body typ) + = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body' typ) + where + bndrs' = map BoringBinder bndrs + (body_skel, body_arg_occs, body') = tagSkeletonExpr body + rhs_skel = rhsSk (rhsCard bndr) body_skel + +-- | How many times will the lambda body of the RHS bound to the given +-- identifier be evaluated, relative to its defining context? This function +-- computes the answer in form of a 'Card'. +rhsCard :: Id -> Card +rhsCard bndr + | is_thunk = oneifyCard n + | otherwise = n `multCard` (fst $ peelManyCalls (idArity bndr) cd) + where + is_thunk = idArity bndr == 0 + -- Let's pray idDemandInfo is still OK after unarise... + n :* cd = idDemandInfo bndr + +tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt) +tagSkeletonAlt old@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} + = (alt_skel, arg_occs, old {alt_bndrs=fmap BoringBinder bndrs, alt_rhs=rhs'}) + where + (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs + arg_occs = alt_arg_occs `delVarSetList` bndrs + +-- | Combines several heuristics to decide whether to lambda-lift a given +-- @let@-binding to top-level. See "GHC.Stg.Lift.Analysis#when" for details. +goodToLift + :: StgLiftConfig + -> TopLevelFlag + -> RecFlag + -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into + -- 'OutId's. See 'GHC.Stg.Lift.Monad.liftedIdsExpander'. + -> [(BinderInfo, LlStgRhs)] + -> Skeleton + -> Maybe DIdSet -- ^ @Just abs_ids@ <=> This binding is beneficial to + -- lift and @abs_ids@ are the variables it would + -- abstract over +goodToLift cfg top_lvl rec_flag expander pairs scope = decide + [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift] + , ("memoized", any_memoized) + , ("argument occurrences", arg_occs) + , ("join point", is_join_point) + , ("abstracts join points", abstracts_join_ids) + , ("abstracts known local function", abstracts_known_local_fun) + , ("args spill on stack", args_spill_on_stack) + , ("increases allocation", inc_allocs) + ] where + profile = c_targetProfile cfg + platform = profilePlatform profile + decide deciders + | not (fancy_or deciders) + = llTrace "stgLiftLams:lifting" + (ppr bndrs <+> ppr abs_ids $$ + ppr allocs $$ + ppr scope) $ + Just abs_ids + | otherwise + = Nothing + ppr_deciders = vcat . map (text . fst) . filter snd + fancy_or deciders + = llTrace "stgLiftLams:goodToLift" (ppr bndrs $$ ppr_deciders deciders) $ + any snd deciders + + bndrs = map (binderInfoBndr . fst) pairs + bndrs_set = mkVarSet bndrs + rhss = map snd pairs + + -- First objective: Calculate @abs_ids@, e.g. the former free variables + -- the lifted binding would abstract over. We have to merge the free + -- variables of all RHS to get the set of variables that will have to be + -- passed through parameters. + fvs = unionDVarSets (map freeVarsOfRhs rhss) + -- To lift the binding to top-level, we want to delete the lifted binders + -- themselves from the free var set. Local let bindings track recursive + -- occurrences in their free variable set. We neither want to apply our + -- cost model to them (see 'tagSkeletonRhs'), nor pass them as parameters + -- when lifted, as these are known calls. We call the resulting set the + -- identifiers we abstract over, thus @abs_ids@. These are all 'OutId's. + -- We will save the set in 'LiftM.e_expansions' for each of the variables + -- if we perform the lift. + abs_ids = expander (delDVarSetList fvs bndrs) + + -- We don't lift updatable thunks or constructors + any_memoized = any is_memoized_rhs rhss + is_memoized_rhs StgRhsCon{} = True + is_memoized_rhs (StgRhsClosure _ _ upd _ _ _) = isUpdatable upd + + -- Don't lift binders occurring as arguments. This would result in complex + -- argument expressions which would have to be given a name, reintroducing + -- the very allocation at each call site that we wanted to get rid off in + -- the first place. + arg_occs = or (mapMaybe (binderInfoOccursAsArg . fst) pairs) + + -- These don't allocate anyway. + is_join_point = any isJoinId bndrs + + -- Abstracting over join points/let-no-escapes spoils them. + abstracts_join_ids = any isJoinId (dVarSetElems abs_ids) + + -- Abstracting over known local functions that aren't floated themselves + -- turns a known, fast call into an unknown, slow call: + -- + -- let f x = ... + -- g y = ... f x ... -- this was a known call + -- in g 4 + -- + -- After lifting @g@, but not @f@: + -- + -- l_g f y = ... f y ... -- this is now an unknown call + -- let f x = ... + -- in l_g f 4 + -- + -- We can abuse the results of arity analysis for this: + -- idArity f > 0 ==> known + known_fun id = idArity id > 0 + abstracts_known_local_fun + = not (c_liftLamsKnown cfg) && any known_fun (dVarSetElems abs_ids) + + -- Number of arguments of a RHS in the current binding group if we decide + -- to lift it + n_args + = length + . StgToCmm.Closure.nonVoidIds -- void parameters don't appear in Cmm + . (dVarSetElems abs_ids ++) + . rhsLambdaBndrs + max_n_args + | isRec rec_flag = c_liftLamsRecArgs cfg + | otherwise = c_liftLamsNonRecArgs cfg + -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess + -- args are passed on the stack, which means slow memory accesses + args_spill_on_stack + | Just n <- max_n_args = any (> n) (map n_args rhss) + | otherwise = False + + -- We only perform the lift if allocations didn't increase. + -- Note that @clo_growth@ will be 'infinity' if there was positive growth + -- under a multi-shot lambda. + -- Also, abstracting over LNEs is unacceptable. LNEs might return + -- unlifted tuples, which idClosureFootprint can't cope with. + inc_allocs = abstracts_join_ids || allocs > 0 + allocs = clo_growth + mkIntWithInf (negate closuresSize) + -- We calculate and then add up the size of each binding's closure. + -- GHC does not currently share closure environments, and we either lift + -- the entire recursive binding group or none of it. + closuresSize = sum $ flip map rhss $ \rhs -> + closureSize profile + . dVarSetElems + . expander + . flip dVarSetMinusVarSet bndrs_set + $ freeVarsOfRhs rhs + clo_growth = closureGrowth expander (idClosureFootprint platform) bndrs_set abs_ids scope + +rhsLambdaBndrs :: LlStgRhs -> [Id] +rhsLambdaBndrs StgRhsCon{} = [] +rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _ _) = map binderInfoBndr bndrs + +-- | The size in words of a function closure closing over the given 'Id's, +-- including the header. +closureSize :: Profile -> [Id] -> WordOff +closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePlatform profile)) + -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't + -- optimise differently when profiling is enabled. + where + (words, _, _) + -- Functions have a StdHeader (as opposed to ThunkHeader). + = StgToCmm.Layout.mkVirtHeapOffsets profile StgToCmm.Layout.StdHeader + . StgToCmm.Closure.addIdReps + . StgToCmm.Closure.nonVoidIds + $ ids + +-- | The number of words a single 'Id' adds to a closure's size. +-- Note that this can't handle unboxed tuples (which may still be present in +-- let-no-escapes, even after Unarise), in which case +-- @'GHC.StgToCmm.ArgRep.idArgRep'@ will crash. +idClosureFootprint:: Platform -> Id -> WordOff +idClosureFootprint platform + = StgToCmm.ArgRep.argRepSizeW platform + . StgToCmm.ArgRep.idArgRep platform + +-- | @closureGrowth expander sizer f fvs@ computes the closure growth in words +-- as a result of lifting @f@ to top-level. If there was any growing closure +-- under a multi-shot lambda, the result will be 'infinity'. +-- Also see "GHC.Stg.Lift.Analysis#clogro". +closureGrowth + :: (DIdSet -> DIdSet) + -- ^ Expands outer free ids that were lifted to their free vars + -> (Id -> Int) + -- ^ Computes the closure footprint of an identifier + -> IdSet + -- ^ Binding group for which lifting is to be decided + -> DIdSet + -- ^ Free vars of the whole binding group prior to lifting it. These must be + -- available at call sites if we decide to lift the binding group. + -> Skeleton + -- ^ Abstraction of the scope of the function + -> IntWithInf + -- ^ Closure growth. 'infinity' indicates there was growth under a + -- (multi-shot) lambda. +closureGrowth expander sizer group abs_ids = go + where + go NilSk = 0 + go (BothSk a b) = go a + go b + go (AltSk a b) = max (go a) (go b) + go (ClosureSk _ clo_fvs rhs) + -- If no binder of the @group@ occurs free in the closure, the lifting + -- won't have any effect on it and we can omit the recursive call. + | n_occs == 0 = 0 + -- Otherwise, we account the cost of allocating the closure and add it to + -- the closure growth of its RHS. + | otherwise = mkIntWithInf cost + go rhs + where + n_occs = sizeDVarSet (clo_fvs' `dVarSetIntersectVarSet` group) + -- What we close over considering prior lifting decisions + clo_fvs' = expander clo_fvs + -- Variables that would additionally occur free in the closure body if + -- we lift @f@ + newbies = abs_ids `minusDVarSet` clo_fvs' + -- Lifting @f@ removes @f@ from the closure but adds all @newbies@ + cost = nonDetStrictFoldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs + -- Using a non-deterministic fold is OK here because addition is commutative. + go (RhsSk n body) + -- The conservative assumption would be that + -- 1. Every RHS with positive growth would be called multiple times, + -- modulo thunks. + -- 2. Every RHS with negative growth wouldn't be called at all. + -- + -- In the first case, we'd have to return 'infinity', while in the + -- second case, we'd have to return 0. But we can do far better + -- considering information from the demand analyser, which provides us + -- with conservative estimates on minimum and maximum evaluation + -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of + -- 'rhsCard' and accurately captures the cardinality of the RHSs body + -- relative to its defining context. + | isAbs n = 0 + | cg <= 0 = if isStrict n then cg else 0 + | isAtMostOnce n = cg + | otherwise = infinity + where + cg = go body diff --git a/GHC/Stg/Lift/Config.hs b/GHC/Stg/Lift/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Lift/Config.hs @@ -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) diff --git a/GHC/Stg/Lift/Monad.hs b/GHC/Stg/Lift/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Lift/Monad.hs @@ -0,0 +1,331 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Hides away distracting bookkeeping while lambda lifting into a 'LiftM' +-- monad. +module GHC.Stg.Lift.Monad ( + decomposeStgBinding, mkStgBinding, + Env (..), + -- * #floats# Handling floats + -- $floats + FloatLang (..), collectFloats, -- Exported just for the docs + -- * Transformation monad + LiftM, runLiftM, + -- ** Get config + getConfig, + -- ** Adding bindings + startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding, + -- ** Substitution and binders + withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs, + -- ** Occurrences + substOcc, isLifted, formerFreeVars, liftedIdsExpander + ) where + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Types.CostCentre ( isCurrentCCS, dontCareCCS ) +import GHC.Data.FastString +import GHC.Types.Id +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Data.OrdList + +import GHC.Stg.Lift.Config +import GHC.Stg.Subst +import GHC.Stg.Syntax + +import GHC.Core.Utils +import GHC.Types.Unique.Supply +import GHC.Utils.Panic +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Core.Multiplicity + +import Control.Arrow ( second ) +import Control.Monad.Trans.Class +import Control.Monad.Trans.RWS.Strict ( RWST, runRWST ) +import qualified Control.Monad.Trans.RWS.Strict as RWS +import Control.Monad.Trans.Cont ( ContT (..) ) +import Data.ByteString ( ByteString ) + +-- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@ +decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)]) +decomposeStgBinding (StgRec pairs) = (Recursive, pairs) +decomposeStgBinding (StgNonRec bndr rhs) = (NonRecursive, [(bndr, rhs)]) + +mkStgBinding :: RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass +mkStgBinding Recursive = StgRec +mkStgBinding NonRecursive = uncurry StgNonRec . head + +-- | Environment threaded around in a scoped, @Reader@-like fashion. +data Env + = Env + { e_config :: StgLiftConfig + -- ^ Read-only. + , e_subst :: !Subst + -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId', + -- because shadowing might make a closure's free variables unavailable at its + -- call sites. Consider: + -- @ + -- let f y = x + y in let x = 4 in f x + -- @ + -- Here, @f@ can't be lifted to top-level, because its free variable @x@ isn't + -- available at its call site. + , e_expansions :: !(IdEnv DIdSet) + -- ^ Lifted 'Id's don't occur as free variables in any closure anymore, because + -- they are bound at the top-level. Every occurrence must supply the formerly + -- free variables of the lifted 'Id', so they in turn become free variables of + -- the call sites. This environment tracks this expansion from lifted 'Id's to + -- their free variables. + -- + -- 'InId's to 'OutId's. + -- + -- Invariant: 'Id's not present in this map won't be substituted. + } + +emptyEnv :: StgLiftConfig -> Env +emptyEnv cfg = Env + { e_config = cfg + , e_subst = emptySubst + , e_expansions = emptyVarEnv + } + + +-- Note [Handling floats] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- $floats +-- Consider the following expression: +-- +-- @ +-- f x = +-- let g y = ... f y ... +-- in g x +-- @ +-- +-- What happens when we want to lift @g@? Normally, we'd put the lifted @l_g@ +-- binding above the binding for @f@: +-- +-- @ +-- g f y = ... f y ... +-- f x = g f x +-- @ +-- +-- But this very unnecessarily turns a known call to @f@ into an unknown one, in +-- addition to complicating matters for the analysis. +-- Instead, we'd really like to put both functions in the same recursive group, +-- thereby preserving the known call: +-- +-- @ +-- Rec { +-- g y = ... f y ... +-- f x = g x +-- } +-- @ +-- +-- But we don't want this to happen for just /any/ binding. That would create +-- possibly huge recursive groups in the process, calling for an occurrence +-- analyser on STG. +-- So, we need to track when we lift a binding out of a recursive RHS and add +-- the binding to the same recursive group as the enclosing recursive binding +-- (which must have either already been at the top-level or decided to be +-- lifted itself in order to preserve the known call). +-- +-- This is done by expressing this kind of nesting structure as a 'Writer' over +-- @['FloatLang']@ and flattening this expression in 'runLiftM' by a call to +-- 'collectFloats'. +-- API-wise, the analysis will not need to know about the whole 'FloatLang' +-- business and will just manipulate it indirectly through actions in 'LiftM'. + +-- | We need to detect when we are lifting something out of the RHS of a +-- recursive binding (c.f. "GHC.Stg.Lift.Monad#floats"), in which case that +-- binding needs to be added to the same top-level recursive group. This +-- requires we detect a certain nesting structure, which is encoded by +-- 'StartBindingGroup' and 'EndBindingGroup'. +-- +-- Although 'collectFloats' will only ever care if the current binding to be +-- lifted (through 'LiftedBinding') will occur inside such a binding group or +-- not, e.g. doesn't care about the nesting level as long as its greater than 0. +data FloatLang + = StartBindingGroup + | EndBindingGroup + | PlainTopBinding OutStgTopBinding + | LiftedBinding OutStgBinding + +instance Outputable FloatLang where + ppr StartBindingGroup = char '(' + ppr EndBindingGroup = char ')' + ppr (PlainTopBinding StgTopStringLit{}) = text "" + ppr (PlainTopBinding (StgTopLifted b)) = ppr (LiftedBinding b) + ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs) + where + (rec, pairs) = decomposeStgBinding bind + +-- | Flattens an expression in @['FloatLang']@ into an STG program, see "GHC.Stg.Lift.Monad#floats". +-- Important pre-conditions: The nesting of opening 'StartBindinGroup's and +-- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding +-- group has at least one recursive binding inside. Otherwise there's no point +-- in announcing the binding group in the first place and an @ASSERT@ will +-- trigger. +collectFloats :: [FloatLang] -> [OutStgTopBinding] +collectFloats = go (0 :: Int) [] + where + go 0 [] [] = [] + go _ _ [] = pprPanic "collectFloats" (text "unterminated group") + go n binds (f:rest) = case f of + StartBindingGroup -> go (n+1) binds rest + EndBindingGroup + | n == 0 -> pprPanic "collectFloats" (text "no group to end") + | n == 1 -> StgTopLifted (merge_binds binds) : go 0 [] rest + | otherwise -> go (n-1) binds rest + PlainTopBinding top_bind + | n == 0 -> top_bind : go n binds rest + | otherwise -> pprPanic "collectFloats" (text "plain top binding inside group") + LiftedBinding bind + | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest + | otherwise -> go n (bind:binds) rest + + map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding + rm_cccs = map_rhss removeRhsCCCS + merge_binds binds = assert (any is_rec binds) $ + StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds) + is_rec StgRec{} = True + is_rec _ = False + +-- | Omitting this makes for strange closure allocation schemes that crash the +-- GC. +removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass +removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body typ) + | isCurrentCCS ccs + = StgRhsClosure ext dontCareCCS upd bndrs body typ +removeRhsCCCS (StgRhsCon ccs con mu ts args typ) + | isCurrentCCS ccs + = StgRhsCon dontCareCCS con mu ts args typ +removeRhsCCCS rhs = rhs + +-- | The analysis monad consists of the following 'RWST' components: +-- +-- * 'Env': Reader-like context. Contains a substitution, info about how +-- how lifted identifiers are to be expanded into applications and +-- configuration options. +-- +-- * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program. +-- +-- * No pure state component +-- +-- * But wrapping around 'UniqSM' for generating fresh lifted binders. +-- (The @uniqAway@ approach could give the same name to two different +-- lifted binders, so this is necessary.) +newtype LiftM a + = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a } + deriving (Functor, Applicative, Monad) + +instance MonadUnique LiftM where + getUniqueSupplyM = LiftM (lift getUniqueSupplyM) + getUniqueM = LiftM (lift getUniqueM) + getUniquesM = LiftM (lift getUniquesM) + +runLiftM :: StgLiftConfig -> UniqSupply -> LiftM () -> [OutStgTopBinding] +runLiftM cfg us (LiftM m) = collectFloats (fromOL floats) + where + (_, _, floats) = initUs_ us (runRWST m (emptyEnv cfg) ()) + +getConfig :: LiftM StgLiftConfig +getConfig = LiftM $ e_config <$> RWS.ask + +-- | Writes a plain 'StgTopStringLit' to the output. +addTopStringLit :: OutId -> ByteString -> LiftM () +addTopStringLit id = LiftM . RWS.tell . unitOL . PlainTopBinding . StgTopStringLit id + +-- | Starts a recursive binding group. See "GHC.Stg.Lift.Monad#floats" and 'collectFloats'. +startBindingGroup :: LiftM () +startBindingGroup = LiftM $ RWS.tell $ unitOL $ StartBindingGroup + +-- | Ends a recursive binding group. See "GHC.Stg.Lift.Monad#floats" and 'collectFloats'. +endBindingGroup :: LiftM () +endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup + +-- | Lifts a binding to top-level. Depending on whether it's declared inside +-- a recursive RHS (see "GHC.Stg.Lift.Monad#floats" and 'collectFloats'), this might be added to +-- an existing recursive top-level binding group. +addLiftedBinding :: OutStgBinding -> LiftM () +addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding + +-- | Takes a binder and a continuation which is called with the substituted +-- binder. The continuation will be evaluated in a 'LiftM' context in which that +-- binder is deemed in scope. Think of it as a 'RWS.local' computation: After +-- the continuation finishes, the new binding won't be in scope anymore. +withSubstBndr :: Id -> (Id -> LiftM a) -> LiftM a +withSubstBndr bndr inner = LiftM $ do + subst <- RWS.asks e_subst + let (bndr', subst') = substBndr bndr subst + RWS.local (\e -> e { e_subst = subst' }) (unwrapLiftM (inner bndr')) + +-- | See 'withSubstBndr'. +withSubstBndrs :: Traversable f => f Id -> (f Id -> LiftM a) -> LiftM a +withSubstBndrs = runContT . traverse (ContT . withSubstBndr) + +-- | Similarly to 'withSubstBndr', this function takes a set of variables to +-- abstract over, the binder to lift (and generate a fresh, substituted name +-- for) and a continuation in which that fresh, lifted binder is in scope. +-- +-- It takes care of all the details involved with copying and adjusting the +-- binder and fresh name generation. +withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a +withLiftedBndr abs_ids bndr inner = do + let str = fsLit "$l" `appendFS` occNameFS (getOccName bndr) + let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr) + bndr' <- + -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least + -- for arity information. + transferPolyIdInfo bndr (dVarSetElems abs_ids) + <$> mkSysLocalM str ManyTy ty + LiftM $ RWS.local + (\e -> e + { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e + , e_expansions = extendVarEnv (e_expansions e) bndr abs_ids + }) + (unwrapLiftM (inner bndr')) + +-- | See 'withLiftedBndr'. +withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a +withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids) + +-- | Substitutes a binder /occurrence/, which was brought in scope earlier by +-- 'withSubstBndr' \/ 'withLiftedBndr'. +substOcc :: Id -> LiftM Id +substOcc id = LiftM (RWS.asks (lookupIdSubst id . e_subst)) + +-- | Whether the given binding was decided to be lambda lifted. +isLifted :: InId -> LiftM Bool +isLifted bndr = LiftM (RWS.asks (elemVarEnv bndr . e_expansions)) + +-- | Returns an empty list for a binding that was not lifted and the list of all +-- local variables the binding abstracts over (so, exactly the additional +-- arguments at adjusted call sites) otherwise. +formerFreeVars :: InId -> LiftM [OutId] +formerFreeVars f = LiftM $ do + expansions <- RWS.asks e_expansions + pure $ case lookupVarEnv expansions f of + Nothing -> [] + Just fvs -> dVarSetElems fvs + +-- | Creates an /expander function/ for the current set of lifted binders. +-- This expander function will replace any 'InId' by their corresponding 'OutId' +-- and, in addition, will expand any lifted binders by the former free variables +-- it abstracts over. +liftedIdsExpander :: LiftM (DIdSet -> DIdSet) +liftedIdsExpander = LiftM $ do + expansions <- RWS.asks e_expansions + subst <- RWS.asks e_subst + -- We use @noWarnLookupIdSubst@ here in order to suppress "not in scope" + -- warnings generated by 'lookupIdSubst' due to local bindings within RHS. + -- These are not in the InScopeSet of @subst@ and extending the InScopeSet in + -- @goodToLift@/@closureGrowth@ before passing it on to @expander@ is too much + -- trouble. + let go set fv = case lookupVarEnv expansions fv of + Nothing -> extendDVarSet set (noWarnLookupIdSubst fv subst) -- Not lifted + Just fvs' -> unionDVarSet set fvs' + let expander fvs = foldl' go emptyDVarSet (dVarSetElems fvs) + pure expander diff --git a/GHC/Stg/Lift/Types.hs b/GHC/Stg/Lift/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Lift/Types.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} + +-- This module declares some basic types used by GHC.Stg.Lift +-- We can import this module into GHC.Stg.Syntax, where the +-- type instance declarations for BinderP etc live + +module GHC.Stg.Lift.Types( + Skeleton(..), + bothSk, altSk, rhsSk, + + BinderInfo(..), + binderInfoBndr, binderInfoOccursAsArg + ) where + +import GHC.Prelude + +import GHC.Types.Id +import GHC.Types.Demand +import GHC.Types.Var.Set + +import GHC.Utils.Outputable + +-- | Captures details of the syntax tree relevant to the cost model, such as +-- closures, multi-shot lambdas and case expressions. +data Skeleton + = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton + | RhsSk !Card {- ^ how often the RHS was entered -} !Skeleton + | AltSk !Skeleton !Skeleton + | BothSk !Skeleton !Skeleton + | NilSk + +bothSk :: Skeleton -> Skeleton -> Skeleton +bothSk NilSk b = b +bothSk a NilSk = a +bothSk a b = BothSk a b + +altSk :: Skeleton -> Skeleton -> Skeleton +altSk NilSk b = b +altSk a NilSk = a +altSk a b = AltSk a b + +rhsSk :: Card -> Skeleton -> Skeleton +rhsSk _ NilSk = NilSk +rhsSk body_dmd skel = RhsSk body_dmd skel + +-- | The type used in binder positions in 'GenStgExpr's. +data BinderInfo + = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag + -- indicating whether it occurs as an argument + -- or in a nullary application + -- (see "GHC.Stg.Lift.Analysis#arg_occs"). + | BoringBinder !Id -- ^ Every other kind of binder + +-- | Gets the bound 'Id' out a 'BinderInfo'. +binderInfoBndr :: BinderInfo -> Id +binderInfoBndr (BoringBinder bndr) = bndr +binderInfoBndr (BindsClosure bndr _) = bndr + +-- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating +-- occurrences as argument or in a nullary applications otherwise. +binderInfoOccursAsArg :: BinderInfo -> Maybe Bool +binderInfoOccursAsArg BoringBinder{} = Nothing +binderInfoOccursAsArg (BindsClosure _ b) = Just b + +instance Outputable Skeleton where + ppr NilSk = text "" + ppr (AltSk l r) = vcat + [ text "{ " <+> ppr l + , text "ALT" + , text " " <+> ppr r + , text "}" + ] + ppr (BothSk l r) = ppr l $$ ppr r + ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body) + ppr (RhsSk card body) = hcat + [ lambda + , ppr card + , dot + , ppr body + ] + +instance Outputable BinderInfo where + ppr = ppr . binderInfoBndr + +instance OutputableBndr BinderInfo where + pprBndr b = pprBndr b . binderInfoBndr + pprPrefixOcc = pprPrefixOcc . binderInfoBndr + pprInfixOcc = pprInfixOcc . binderInfoBndr + bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr + diff --git a/GHC/Stg/Lint.hs b/GHC/Stg/Lint.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Lint.hs @@ -0,0 +1,576 @@ +{- | +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +A lint pass to check basic STG invariants: + +- Variables should be defined before used. + +- Let bindings should not have unboxed types (unboxed bindings should only + appear in case), except when they're join points (see Note [Core let-can-float + invariant] and #14117). + +- If linting after unarisation, invariants listed in Note [Post-unarisation + invariants]. + +Because we don't have types and coercions in STG we can't really check types +here. + +Some history: + +StgLint used to check types, but it never worked and so it was disabled in 2000 +with this note: + + WARNING: + ~~~~~~~~ + + This module has suffered bit-rot; it is likely to yield lint errors + for Stg code that is currently perfectly acceptable for code + generation. Solution: don't use it! (KSW 2000-05). + +Since then there were some attempts at enabling it again, as summarised in #14787. +It's finally decided that we remove all type checking and only look for +basic properties listed above. + +Note [Linting StgApp] +~~~~~~~~~~~~~~~~~~~~~ +To lint an application of the form `f a_1 ... a_n`, we check that +the representations of the arguments `a_1`, ..., `a_n` match those +that the function expects. + +More precisely, suppose the types in the application `f a_1 ... a_n` +are as follows: + + f :: t_1 -> ... -> t_n -> res + a_1 :: s_1, ..., a_n :: s_n + + t_1 :: TYPE r_1, ..., t_n :: TYPE r_n + s_1 :: TYPE p_1, ..., a_n :: TYPE p_n + +Before unarisation, we must check that each r_i is compatible with s_i. +Compatibility is weaker than on-the-nose equality: for example, +IntRep and WordRep are compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint. + +After unarisation, a single type might correspond to multiple arguments, e.g. + + (# Int# | Bool #) :: TYPE (SumRep '[ IntRep, LiftedRep ]) + +will result in two arguments: [Int# :: TYPE 'IntRep, Bool :: TYPE LiftedRep] +This means post unarise we potentially have to match up multiple arguments with +the reps of a single argument in the type's definition, because the type of the function +is *not* in unarised form. + +Wrinkle: it can sometimes happen that an argument type in the type of +the function does not have a fixed runtime representation, i.e. +there is an r_i such that runtimeRepPrimRep r_i crashes. +See https://gitlab.haskell.org/ghc/ghc/-/issues/21399 for an example. +Fixing this issue would require significant changes to the type system +of STG, so for now we simply skip the Lint check when we detect such +representation-polymorphic situations. + +Note [Typing the STG language] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Core, programs must be /well-typed/. So if f :: ty1 -> ty2, +then in the application (f e), we must have e :: ty1 + +STG is still a statically typed language, but the type system +is much coarser. In particular, STG programs must be /well-kinded/. +More precisely, if f :: ty1 -> ty2, then in the application (f e) +where e :: ty1', we must have kind(ty1) = kind(ty1'). + +So the STG type system does not distinguish between Int and Bool, +but it /does/ distinguish between Int and Int#, because they have +different kinds. Actually, since all terms have kind (TYPE rep), +we might say that the STG language is well-runtime-rep'd. + +This coarser type system makes fewer distinctions, and that allows +many nonsensical programs (such as ('x' && "foo")) -- but all type +systems accept buggy programs! But the coarseness also permits +some optimisations that are ill-typed in Core. For example, see +the module STG.CSE, which is all about doing CSE in STG that would +be ill-typed in Core. But it must still be well-kinded! + +-} + +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, + DeriveFunctor #-} + +module GHC.Stg.Lint ( lintStgTopBindings ) where + +import GHC.Prelude + +import GHC.Stg.Syntax +import GHC.Stg.Utils + +import GHC.Core.DataCon +import GHC.Core ( AltCon(..) ) +import GHC.Core.Type + +import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isMarkedCbv ) +import GHC.Types.CostCentre ( isCurrentCCS ) +import GHC.Types.Error ( DiagnosticReason(WarningWithoutFlag) ) +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom ) +import GHC.Types.RepType +import GHC.Types.SrcLoc + +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Error ( mkLocMessage, DiagOpts ) +import qualified GHC.Utils.Error as Err + +import GHC.Unit.Module ( Module ) + +import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) + +import Control.Monad +import Data.Maybe +import GHC.Utils.Misc +import GHC.Core.Multiplicity (scaledThing) +import GHC.Settings (Platform) +import GHC.Core.TyCon (primRepCompatible, primRepsCompatible) +import GHC.Utils.Panic.Plain (panic) + +lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) + => Platform + -> Logger + -> DiagOpts + -> StgPprOpts + -> [Var] -- ^ extra vars in scope from GHCi + -> Module -- ^ module being compiled + -> Bool -- ^ have we run Unarise yet? + -> String -- ^ who produced the STG? + -> [GenStgTopBinding a] + -> IO () + +lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised whodunit binds + = {-# SCC "StgLint" #-} + case initL platform diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of + Nothing -> + return () + Just msg -> do + logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] in "GHC.Core.Lint" + $ withPprStyle defaultDumpStyle + (vcat [ text "*** Stg Lint ErrMsgs: in" <+> + text whodunit <+> text "***", + msg, + text "*** Offending Program ***", + pprGenStgTopBindings opts binds, + text "*** End of Offense ***"]) + Err.ghcExit logger 1 + where + -- Bring all top-level binds into scope because CoreToStg does not generate + -- bindings in dependency order (so we may see a use before its definition). + top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds)) + extra_vars + + lint_binds :: [GenStgTopBinding a] -> LintM () + + lint_binds [] = return () + lint_binds (bind:binds) = do + binders <- lint_bind bind + addInScopeVars binders $ + lint_binds binds + + lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind + lint_bind (StgTopStringLit v _) = return [v] + +lintStgConArg :: StgArg -> LintM () +lintStgConArg arg = do + unarised <- lf_unarised <$> getLintFlags + when unarised $ case stgArgRep_maybe arg of + -- Note [Post-unarisation invariants], invariant 4 + Just [_] -> pure () + badRep -> addErrL $ + text "Non-unary constructor arg: " <> ppr arg $$ + text "Its PrimReps are: " <> ppr badRep + + case arg of + StgLitArg _ -> pure () + StgVarArg v -> lintStgVar v + +lintStgFunArg :: StgArg -> LintM () +lintStgFunArg arg = do + unarised <- lf_unarised <$> getLintFlags + when unarised $ case stgArgRep_maybe arg of + -- Note [Post-unarisation invariants], invariant 3 + Just [] -> pure () + Just [_] -> pure () + badRep -> addErrL $ + text "Function arg is not unary or void: " <> ppr arg $$ + text "Its PrimReps are: " <> ppr badRep + + case arg of + StgLitArg _ -> pure () + StgVarArg v -> lintStgVar v + +lintStgVar :: Id -> LintM () +lintStgVar id = checkInScope id + +lintStgBinds + :: (OutputablePass a, BinderP a ~ Id) + => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders +lintStgBinds top_lvl (StgNonRec binder rhs) = do + lint_binds_help top_lvl (binder,rhs) + return [binder] + +lintStgBinds top_lvl (StgRec pairs) + = addInScopeVars binders $ do + mapM_ (lint_binds_help top_lvl) pairs + return binders + where + binders = [b | (b,_) <- pairs] + +lint_binds_help + :: (OutputablePass a, BinderP a ~ Id) + => TopLevelFlag + -> (Id, GenStgRhs a) + -> LintM () +lint_binds_help top_lvl (binder, rhs) + = addLoc (RhsOf binder) $ do + when (isTopLevel top_lvl) (checkNoCurrentCCS rhs) + lintStgRhs rhs + opts <- getStgPprOpts + -- Check binder doesn't have unlifted type or it's a join point + checkL ( isJoinId binder + || not (isUnliftedType (idType binder)) + || isDataConWorkId binder || isDataConWrapId binder) -- until #17521 is fixed + (mkUnliftedTyMsg opts binder rhs) + +-- | Top-level bindings can't inherit the cost centre stack from their +-- (static) allocation site. +checkNoCurrentCCS + :: (OutputablePass a, BinderP a ~ Id) + => GenStgRhs a + -> LintM () +checkNoCurrentCCS rhs = do + opts <- getStgPprOpts + let rhs' = pprStgRhs opts rhs + case rhs of + StgRhsClosure _ ccs _ _ _ _ + | isCurrentCCS ccs + -> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs') + StgRhsCon ccs _ _ _ _ _ + | isCurrentCCS ccs + -> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs') + _ -> return () + +lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM () + +lintStgRhs (StgRhsClosure _ _ _ [] expr _) + = lintStgExpr expr + +lintStgRhs (StgRhsClosure _ _ _ binders expr _) + = addLoc (LambdaBodyOf binders) $ + addInScopeVars binders $ + lintStgExpr expr + +lintStgRhs rhs@(StgRhsCon _ con _ _ args _) = do + opts <- getStgPprOpts + when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do + addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ + pprStgRhs opts rhs) + + lintConApp con args (pprStgRhs opts rhs) + +lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM () + +lintStgExpr (StgLit _) = return () + +lintStgExpr e@(StgApp fun args) = do + lintStgVar fun + mapM_ lintStgFunArg args + lintAppCbvMarks e + lintStgAppReps fun args + + + +lintStgExpr app@(StgConApp con _n args _arg_tys) = do + -- unboxed sums should vanish during unarise + lf <- getLintFlags + let !unarised = lf_unarised lf + when (unarised && isUnboxedSumDataCon con) $ do + opts <- getStgPprOpts + addErrL (text "Unboxed sum after unarise:" $$ + pprStgExpr opts app) + + opts <- getStgPprOpts + lintConApp con args (pprStgExpr opts app) + +lintStgExpr (StgOpApp _ args _) = + mapM_ lintStgFunArg args + +lintStgExpr (StgLet _ binds body) = do + binders <- lintStgBinds NotTopLevel binds + addLoc (BodyOfLet binders) $ + addInScopeVars binders $ + lintStgExpr body + +lintStgExpr (StgLetNoEscape _ binds body) = do + binders <- lintStgBinds NotTopLevel binds + addLoc (BodyOfLet binders) $ + addInScopeVars binders $ + lintStgExpr body + +lintStgExpr (StgTick _ expr) = lintStgExpr expr + +lintStgExpr (StgCase scrut bndr alts_type alts) = do + lintStgExpr scrut + + lf <- getLintFlags + let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf) + + addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts) + +lintAlt + :: (OutputablePass a, BinderP a ~ Id) + => GenStgAlt a -> LintM () + +lintAlt GenStgAlt{ alt_con = DEFAULT + , alt_bndrs = _ + , alt_rhs = rhs} = lintStgExpr rhs + +lintAlt GenStgAlt{ alt_con = LitAlt _ + , alt_bndrs = _ + , alt_rhs = rhs} = lintStgExpr rhs + +lintAlt GenStgAlt{ alt_con = DataAlt _ + , alt_bndrs = bndrs + , alt_rhs = rhs} = + do + mapM_ checkPostUnariseBndr bndrs + addInScopeVars bndrs (lintStgExpr rhs) + +lintConApp :: DataCon -> [StgArg] -> SDoc -> LintM () +lintConApp con args app = do + mapM_ lintStgConArg args + unarised <- lf_unarised <$> getLintFlags + + -- 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; see also #23865 + when (unarised && + not (isUnboxedTupleDataCon con) && + length (dataConRuntimeRepStrictness con) /= length args) $ do + addErrL (text "Constructor applied to incorrect number of arguments:" $$ + text "Application:" <> app) + +-- See Note [Linting StgApp] +-- See Note [Typing the STG language] +lintStgAppReps :: Id -> [StgArg] -> LintM () +lintStgAppReps _fun [] = return () +lintStgAppReps fun args = do + lf <- getLintFlags + let platform = lf_platform lf + + (fun_arg_tys, _res) = splitFunTys (idType fun) + fun_arg_tys' = map scaledThing fun_arg_tys :: [Type] + + -- Might be "wrongly" typed as polymorphic. See #21399 + -- In these cases typePrimRep_maybe will return Nothing + -- and we abort kind checking. + fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]] + fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys' + actual_arg_reps = map stgArgRep_maybe args + + match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM () + match_args (Nothing:_) _ = return () + match_args (_) (Nothing:_) = return () + match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left) + -- Common case, reps are exactly the same (perhaps void) + | actual_rep == expected_rep + = match_args actual_reps_left expected_reps_left + + -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep. + -- We check for that here with primRepCompatible + | primRepsCompatible platform actual_rep expected_rep + = match_args actual_reps_left expected_reps_left + + -- We might distribute args from within one unboxed sum over multiple + -- single rep args. This means we might need to match up things like: + -- [Just [WordRep, LiftedRep]] with [Just [WordRep],Just [LiftedRep]] + -- which happens here. + -- See Note [Linting StgApp]. + | Just (actual,actuals) <- getOneRep actual_rep actual_reps_left + , Just (expected,expecteds) <- getOneRep expected_rep expected_reps_left + , primRepCompatible platform actual expected + = match_args actuals expecteds + + | otherwise = addErrL $ hang (text "Function type reps and function argument reps mismatched") 2 $ + (text "In application " <> ppr fun <+> ppr args $$ + text "argument rep:" <> ppr actual_arg_reps $$ + text "expected rep:" <> ppr fun_arg_tys_reps $$ + -- text "expected reps:" <> ppr arg_ty_reps $$ + text "unarised?:" <> ppr (lf_unarised lf)) + where + -- Try to strip one non-void arg rep from the current argument type returning + -- the remaining list of arguments. We return Nothing for invalid input which + -- will result in a lint failure in match_args. + getOneRep :: [PrimRep] -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]]) + getOneRep [] _rest = Nothing -- Void rep args are invalid at this point. + getOneRep [rep] rest = Just (rep,rest) -- A single arg rep arg + getOneRep (rep:reps) rest = Just (rep,Just reps:rest) -- Multi rep arg. + + match_args _ _ = return () -- Functions are allowed to be over/under applied. + + match_args actual_arg_reps fun_arg_tys_reps + +lintAppCbvMarks :: OutputablePass pass + => GenStgExpr pass -> LintM () +lintAppCbvMarks e@(StgApp fun args) = do + lf <- getLintFlags + when (lf_unarised lf) $ do + -- A function which expects a unlifted argument as n'th argument + -- always needs to be applied to n arguments. + -- See Note [CBV Function Ids]. + let marks = fromMaybe [] $ idCbvMarks_maybe fun + when (length (dropWhileEndLE (not . isMarkedCbv) marks) > length args) $ do + addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $ + (text "marks" <> ppr marks $$ + text "args" <> ppr args $$ + text "arity" <> ppr (idArity fun) $$ + text "join_arity" <> ppr (idJoinPointHood fun)) +lintAppCbvMarks _ = panic "impossible - lintAppCbvMarks" + +{- +************************************************************************ +* * +The Lint monad +* * +************************************************************************ +-} + +newtype LintM a = LintM + { unLintM :: Module + -> LintFlags + -> DiagOpts -- Diagnostic options + -> StgPprOpts -- Pretty-printing options + -> [LintLocInfo] -- Locations + -> IdSet -- Local vars in scope + -> Bag SDoc -- Error messages so far + -> (a, Bag SDoc) -- Result and error messages (if any) + } + deriving (Functor) + +data LintFlags = LintFlags { lf_unarised :: !Bool + , lf_platform :: !Platform + -- ^ have we run the unariser yet? + } + +data LintLocInfo + = RhsOf Id -- The variable bound + | LambdaBodyOf [Id] -- The lambda-binder + | BodyOfLet [Id] -- The binders of the let + +dumpLoc :: LintLocInfo -> (SrcSpan, SDoc) +dumpLoc (RhsOf v) = + (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' ) +dumpLoc (LambdaBodyOf bs) = + (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' ) + +dumpLoc (BodyOfLet bs) = + (srcLocSpan (getSrcLoc (head bs)), text " [in body of let with binders " <> pp_binders bs <> char ']' ) + + +pp_binders :: [Id] -> SDoc +pp_binders bs + = sep (punctuate comma (map pp_binder bs)) + where + pp_binder b + = hsep [ppr b, dcolon, ppr (idType b)] + +initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc +initL platform diag_opts this_mod unarised opts locals (LintM m) = do + let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag + if isEmptyBag errs then + Nothing + else + Just (vcat (punctuate blankLine (bagToList errs))) + +instance Applicative LintM where + pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs) + (<*>) = ap + (*>) = thenL_ + +instance Monad LintM where + (>>=) = thenL + (>>) = (*>) + +thenL :: LintM a -> (a -> LintM b) -> LintM b +thenL m k = LintM $ \mod lf diag_opts opts loc scope errs + -> case unLintM m mod lf diag_opts opts loc scope errs of + (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs' + +thenL_ :: LintM a -> LintM b -> LintM b +thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs + -> case unLintM m mod lf diag_opts opts loc scope errs of + (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs' + +checkL :: Bool -> SDoc -> LintM () +checkL True _ = return () +checkL False msg = addErrL msg + +-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders. +checkPostUnariseBndr :: Id -> LintM () +checkPostUnariseBndr bndr = do + lf <- getLintFlags + when (lf_unarised lf) $ + forM_ (checkPostUnariseId bndr) $ \unexpected -> + addErrL $ + text "After unarisation, binder " <> + ppr bndr <> text " has " <> text unexpected <> text " type " <> + ppr (idType bndr) + +-- Post-unarisation args and case alt binders should not have unboxed tuple, +-- unboxed sum, or void types. Return what the binder is if it is one of these. +checkPostUnariseId :: Id -> Maybe String +checkPostUnariseId id + | isUnboxedSumType id_ty = Just "unboxed sum" + | isUnboxedTupleType id_ty = Just "unboxed tuple" + | isZeroBitTy id_ty = Just "void" + | otherwise = Nothing + where + id_ty = idType id + +addErrL :: SDoc -> LintM () +addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc) + +addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc +addErr diag_opts errs_so_far msg locs + = errs_so_far `snocBag` mk_msg locs + where + mk_msg (loc:_) = let (l,hdr) = dumpLoc loc + in mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) + l (hdr $$ msg) + mk_msg [] = msg + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs + -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs + +addInScopeVars :: [Id] -> LintM a -> LintM a +addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs + -> let + new_set = mkVarSet ids + in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs + +getLintFlags :: LintM LintFlags +getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs) + +getStgPprOpts :: LintM StgPprOpts +getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs) + +checkInScope :: Id -> LintM () +checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs + -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then + ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id), + text "is out of scope"]) loc) + else + ((), errs) + +mkUnliftedTyMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc +mkUnliftedTyMsg opts binder rhs + = (text "Let(rec) binder" <+> quotes (ppr binder) <+> + text "has unlifted type" <+> quotes (ppr (idType binder))) + $$ + (text "RHS:" <+> pprStgRhs opts rhs) diff --git a/GHC/Stg/Make.hs b/GHC/Stg/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Make.hs @@ -0,0 +1,172 @@ +module GHC.Stg.Make + ( MkStgRhs (..) + , mkTopStgRhs + , mkStgRhs + , mkStgRhsCon_maybe + , mkTopStgRhsCon_maybe + ) +where + +import GHC.Prelude +import GHC.Unit.Module + +import GHC.Core.DataCon +import GHC.Core.Type (Type) + +import GHC.Stg.Syntax +import GHC.Stg.Utils (stripStgTicksTop) + +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.CostCentre +import GHC.Types.Demand ( isAtMostOnceDmd ) +import GHC.Types.Tickish + +-- Represents the RHS of a binding for use with mk(Top)StgRhs and +-- mk(Top)StgRhsCon_maybe. +data MkStgRhs = MkStgRhs + { rhs_args :: [Id] -- ^ Empty for thunks + , rhs_expr :: StgExpr -- ^ RHS expression + , rhs_type :: Type -- ^ RHS type (only used in the JS backend: layering violation) + , rhs_is_join :: !Bool -- ^ Is it a RHS for a join-point? + } + + +-- Generate a top-level RHS. Any new cost centres generated for CAFs will be +-- appended to `CollectedCCs` argument. +mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool) + -> Bool -> Module -> CollectedCCs + -> Id -> MkStgRhs -> (StgRhs, CollectedCCs) +mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bndr mk_rhs@(MkStgRhs bndrs rhs typ _) + -- try to make a StgRhsCon first + | Just rhs_con <- mkTopStgRhsCon_maybe (allow_toplevel_con_app this_mod) mk_rhs + = ( rhs_con, ccs ) + + | not (null bndrs) + = -- The list of arguments is non-empty, so not CAF + ( StgRhsClosure noExtFieldSilent + dontCareCCS + ReEntrant + bndrs rhs typ + , ccs ) + + -- Otherwise it's a CAF, see Note [Cost-centre initialization plan]. + | opt_AutoSccsOnIndividualCafs + = ( StgRhsClosure noExtFieldSilent + caf_ccs + upd_flag [] rhs typ + , collectCC caf_cc caf_ccs ccs ) + + | otherwise + = ( StgRhsClosure noExtFieldSilent + all_cafs_ccs + upd_flag [] rhs typ + , ccs ) + + where + upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry + | otherwise = Updatable + + -- CAF cost centres generated for -fcaf-all + caf_cc = mkAutoCC bndr modl + caf_ccs = mkSingletonCCS caf_cc + -- careful: the binder might be :Main.main, + -- which doesn't belong to module mod_name. + -- bug #249, tests prof001, prof002 + modl | Just m <- nameModule_maybe (idName bndr) = m + | otherwise = this_mod + + -- default CAF cost centre + (_, all_cafs_ccs) = getAllCAFsCC this_mod + +-- Generate a non-top-level RHS. Cost-centre is always currentCCS, +-- see Note [Cost-centre initialization plan]. +mkStgRhs :: Id -> MkStgRhs -> StgRhs +mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join) + -- try to make a StgRhsCon first + | Just rhs_con <- mkStgRhsCon_maybe mk_rhs + = rhs_con + + | otherwise + = StgRhsClosure noExtFieldSilent + currentCCS + upd_flag bndrs rhs typ + where + upd_flag | is_join = JumpedTo + | not (null bndrs) = ReEntrant + | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry + | otherwise = Updatable + + {- + SDM: disabled. Eval/Apply can't handle functions with arity zero very + well; and making these into simple non-updatable thunks breaks other + assumptions (namely that they will be entered only once). + + upd_flag | isPAP env rhs = ReEntrant + | otherwise = Updatable + +-- Detect thunks which will reduce immediately to PAPs, and make them +-- non-updatable. This has several advantages: +-- +-- - the non-updatable thunk behaves exactly like the PAP, +-- +-- - the thunk is more efficient to enter, because it is +-- specialised to the task. +-- +-- - we save one update frame, one stg_update_PAP, one update +-- and lots of PAP_enters. +-- +-- - in the case where the thunk is top-level, we save building +-- a black hole and furthermore the thunk isn't considered to +-- be a CAF any more, so it doesn't appear in any SRTs. +-- +-- We do it here, because the arity information is accurate, and we need +-- to do it before the SRT pass to save the SRT entries associated with +-- any top-level PAPs. + +isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args + where + arity = stgArity f (lookupBinding env f) +isPAP env _ = False + +-} + +{- ToDo: + upd = if isOnceDem dem + then (if isNotTop toplev + then SingleEntry -- HA! Paydirt for "dem" + else + (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $ + Updatable) + else Updatable + -- For now we forbid SingleEntry CAFs; they tickle the + -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, + -- and I don't understand why. There's only one SE_CAF (well, + -- only one that tickled a great gaping bug in an earlier attempt + -- at ClosureInfo.getEntryConvention) in the whole of nofib, + -- specifically Main.lvl6 in spectral/cryptarithm2. + -- So no great loss. KSW 2000-07. +-} + + +-- | Try to make a non top-level StgRhsCon if appropriate +mkStgRhsCon_maybe :: MkStgRhs -> Maybe StgRhs +mkStgRhsCon_maybe (MkStgRhs bndrs rhs typ is_join) + | [] <- bndrs + , not is_join + , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs + = Just (StgRhsCon currentCCS con mn ticks args typ) + + | otherwise = Nothing + + +-- | Try to make a top-level StgRhsCon if appropriate +mkTopStgRhsCon_maybe :: (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs +mkTopStgRhsCon_maybe allow_static_con_app (MkStgRhs bndrs rhs typ is_join) + | [] <- bndrs + , not is_join -- shouldn't happen at top-level + , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs + , allow_static_con_app con args + = Just (StgRhsCon dontCareCCS con mn ticks args typ) + + | otherwise = Nothing diff --git a/GHC/Stg/Pipeline.hs b/GHC/Stg/Pipeline.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Pipeline.hs @@ -0,0 +1,180 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[SimplStg]{Driver for simplifying @STG@ programs} +-} + + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Stg.Pipeline + ( StgPipelineOpts (..) + , StgToDo (..) + , stg2stg + , StgCgInfos + ) where + +import GHC.Prelude + +import GHC.Driver.Flags + +import GHC.Stg.Syntax + +import GHC.Stg.Lint ( lintStgTopBindings ) +import GHC.Stg.Stats ( showStgStats ) +import GHC.Stg.FVs ( depSortWithAnnotStgPgm ) +import GHC.Stg.Unarise ( unarise ) +import GHC.Stg.BcPrep ( bcPrep ) +import GHC.Stg.CSE ( stgCse ) +import GHC.Stg.Lift ( StgLiftConfig, stgLiftLams ) +import GHC.Unit.Module ( Module ) + +import GHC.Core.DataCon (DataCon) + +import GHC.Utils.Error +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Utils.Logger +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import GHC.Settings (Platform) +import GHC.Stg.EnforceEpt (enforceEpt) +import GHC.Stg.EnforceEpt.TagSig ( StgCgInfos ) + +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 + , stgPipeline_forBytecode :: !Bool + + , stgPipeline_allowTopLevelConApp :: Module -> DataCon -> [StgArg] -> Bool + -- ^ Is a top-level (static) StgConApp allowed or not. If not, use dynamic allocation. + -- + -- This is typically used to support dynamic linking on Windows and the + -- -fexternal-dynamic-refs flag. See GHC.Stg.Utils.allowTopLevelConApp. + } + +newtype StgM a = StgM { _unStgM :: ReaderT Char IO a } + deriving (Functor, Applicative, Monad, MonadIO) + +instance MonadUnique StgM where + getUniqueSupplyM = StgM $ do { tag <- ask + ; liftIO $! mkSplitUniqSupply tag} + getUniqueM = StgM $ do { tag <- ask + ; liftIO $! uniqFromTag tag} + +runStgM :: Char -> StgM a -> IO a +runStgM mask (StgM m) = runReaderT m mask + +stg2stg :: Logger + -> [Var] -- ^ extra vars in scope from GHCi + -> StgPipelineOpts + -> Module -- ^ module being compiled + -> [StgTopBinding] -- ^ input program + -> IO ([(CgStgTopBinding,IdSet)], StgCgInfos) -- output program +stg2stg logger extra_vars opts this_mod binds + = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds + ; stg_linter False "StgFromCore" binds + ; showPass logger "Stg2Stg" + -- Do the main business! + ; binds' <- runStgM 'g' $ + foldM (do_stg_pass this_mod) binds (stgPipeline_phases opts) + + -- Dependency sort the program as last thing. The program needs to be + -- in dependency order for the SRT algorithm to work (see + -- CmmBuildInfoTables, which also includes a detailed description of + -- the algorithm), and we don't guarantee that the program is already + -- sorted at this point. #16192 is for simplifier not preserving + -- dependency order. We also don't guarantee that StgLiftLams will + -- preserve the order or only create minimal recursive groups, so a + -- sorting pass is necessary. + -- This pass will also augment each closure with non-global free variables + -- annotations (which is used by code generator to compute offsets into closures) + ; let (binds_sorted_with_fvs, imp_fvs) = unzip (depSortWithAnnotStgPgm this_mod binds') + -- See Note [Tag inference for interactive contexts] + ; (cg_binds, cg_infos) <- enforceEpt (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs + ; stg_linter False "StgCodeGen" cg_binds + ; pure (zip cg_binds imp_fvs, cg_infos) + } + + where + stg_linter :: (BinderP a ~ Id, OutputablePass a) => Bool -> String -> [GenStgTopBinding a] -> IO () + stg_linter unarised + | Just diag_opts <- stgPipeline_lint opts + = lintStgTopBindings + (stgPlatform opts) logger + diag_opts ppr_opts + extra_vars this_mod unarised + | otherwise + = \ _whodunit _binds -> return () + + ------------------------------------------- + do_stg_pass :: Module -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding] + do_stg_pass this_mod binds to_do + = case to_do of + StgDoNothing -> + return binds + + StgStats -> + logTraceMsg logger "STG stats" (text (showStgStats binds)) (return binds) + + StgCSE -> do + let binds' = {-# SCC "StgCse" #-} stgCse binds + end_pass "StgCse" binds' + + StgLiftLams cfg -> do + us <- getUniqueSupplyM + -- + let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams this_mod cfg us binds + end_pass "StgLiftLams" binds' + + StgBcPrep -> do + us <- getUniqueSupplyM + let binds' = {-# SCC "StgBcPrep" #-} bcPrep us binds + end_pass "StgBcPrep" binds' + + StgUnarise -> do + us <- getUniqueSupplyM + liftIO (stg_linter False "Pre-unarise" binds) + let binds' = {-# SCC "StgUnarise" #-} unarise us (stgPipeline_allowTopLevelConApp opts this_mod) binds + liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds') + liftIO (stg_linter True "Unarise" binds') + return binds' + + ppr_opts = stgPipeline_pprOpts opts + dump_when flag header binds + = putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings ppr_opts binds) + + end_pass what binds2 + = liftIO $ do -- report verbosely, if required + putDumpFileMaybe logger Opt_D_verbose_stg2stg what + FormatSTG (vcat (map (pprStgTopBinding ppr_opts) binds2)) + stg_linter False what binds2 + return binds2 + +-- ----------------------------------------------------------------------------- +-- StgToDo: abstraction of stg-to-stg passes to run. + +-- | Optional Stg-to-Stg passes. +data StgToDo + = StgCSE + -- ^ Common subexpression elimination + | StgLiftLams StgLiftConfig + -- ^ Lambda lifting closure variables, trading stack/register allocation for + -- heap allocation + | StgStats + | StgUnarise + -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders + | StgBcPrep + -- ^ Mandatory when compiling to bytecode + | StgDoNothing + -- ^ Useful for building up 'getStgToDo' + deriving (Show, Read, Eq, Ord) diff --git a/GHC/Stg/Stats.hs b/GHC/Stg/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Stats.hs @@ -0,0 +1,170 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[StgStats]{Gathers statistical information about programs} + + +The program gather statistics about +\begin{enumerate} +\item number of boxed cases +\item number of unboxed cases +\item number of let-no-escapes +\item number of non-updatable lets +\item number of updatable lets +\item number of applications +\item number of primitive applications +\item number of closures (does not include lets bound to constructors) +\item number of free variables in closures +%\item number of top-level functions +%\item number of top-level CAFs +\item number of constructors +\end{enumerate} +-} + + + +module GHC.Stg.Stats ( showStgStats ) where + +import GHC.Prelude + +import GHC.Stg.Syntax + +import GHC.Types.Id (Id) + +import Data.Map (Map) +import qualified Data.Map as Map + +data CounterType + = Literals + | Applications + | ConstructorApps + | PrimitiveApps + | LetNoEscapes + | StgCases + | FreeVariables + | ConstructorBinds Bool{-True<=>top-level-} + | ReEntrantBinds Bool{-ditto-} + | SingleEntryBinds Bool{-ditto-} + | UpdatableBinds Bool{-ditto-} + | JoinPointBinds Bool{-ditto-} + deriving (Eq, Ord) + +type Count = Int +type StatEnv = Map CounterType Count + +emptySE :: StatEnv +emptySE = Map.empty + +combineSE :: StatEnv -> StatEnv -> StatEnv +combineSE = Map.unionWith (+) + +combineSEs :: [StatEnv] -> StatEnv +combineSEs = foldr combineSE emptySE + +countOne :: CounterType -> StatEnv +countOne c = Map.singleton c 1 + +{- +************************************************************************ +* * +\subsection{Top-level list of bindings (a ``program'')} +* * +************************************************************************ +-} + +showStgStats :: [StgTopBinding] -> String + +showStgStats prog + = "STG Statistics:\n\n" + ++ concatMap showc (Map.toList (gatherStgStats prog)) + where + showc (x,n) = (showString (s x) . shows n) "\n" + + s Literals = "Literals " + s Applications = "Applications " + s ConstructorApps = "ConstructorApps " + s PrimitiveApps = "PrimitiveApps " + s LetNoEscapes = "LetNoEscapes " + s StgCases = "StgCases " + s FreeVariables = "FreeVariables " + s (ConstructorBinds True) = "ConstructorBinds_Top " + s (ReEntrantBinds True) = "ReEntrantBinds_Top " + s (SingleEntryBinds True) = "SingleEntryBinds_Top " + s (UpdatableBinds True) = "UpdatableBinds_Top " + s (ConstructorBinds _) = "ConstructorBinds_Nested " + s (ReEntrantBinds _) = "ReEntrantBindsBinds_Nested " + s (SingleEntryBinds _) = "SingleEntryBinds_Nested " + s (UpdatableBinds _) = "UpdatableBinds_Nested " + s (JoinPointBinds _) = "JoinPointBinds_Nested " + +gatherStgStats :: [StgTopBinding] -> StatEnv +gatherStgStats binds = combineSEs (map statTopBinding binds) + +{- +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +statTopBinding :: StgTopBinding -> StatEnv +statTopBinding (StgTopStringLit _ _) = countOne Literals +statTopBinding (StgTopLifted bind) = statBinding True bind + +statBinding :: Bool -- True <=> top-level; False <=> nested + -> StgBinding + -> StatEnv + +statBinding top (StgNonRec b rhs) + = statRhs top (b, rhs) + +statBinding top (StgRec pairs) + = combineSEs (map (statRhs top) pairs) + +statRhs :: Bool -> (Id, StgRhs) -> StatEnv + +statRhs top (_, StgRhsCon _ _ _ _ _ _) + = countOne (ConstructorBinds top) + +statRhs top (_, StgRhsClosure _ _ u _ body _) + = statExpr body `combineSE` + countOne ( + case u of + ReEntrant -> ReEntrantBinds top + Updatable -> UpdatableBinds top + SingleEntry -> SingleEntryBinds top + JumpedTo -> JoinPointBinds top + ) + +{- +************************************************************************ +* * +\subsection{Expressions} +* * +************************************************************************ +-} + +statExpr :: StgExpr -> StatEnv + +statExpr (StgApp _ _) = countOne Applications +statExpr (StgLit _) = countOne Literals +statExpr (StgConApp {}) = countOne ConstructorApps +statExpr (StgOpApp _ _ _) = countOne PrimitiveApps +statExpr (StgTick _ e) = statExpr e + +statExpr (StgLetNoEscape _ binds body) + = statBinding False{-not top-level-} binds `combineSE` + statExpr body `combineSE` + countOne LetNoEscapes + +statExpr (StgLet _ binds body) + = statBinding False{-not top-level-} binds `combineSE` + statExpr body + +statExpr (StgCase expr _ _ alts) + = statExpr expr `combineSE` + stat_alts alts `combineSE` + countOne StgCases + where + stat_alts = combineSEs . fmap (statExpr . alt_rhs) diff --git a/GHC/Stg/Subst.hs b/GHC/Stg/Subst.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Subst.hs @@ -0,0 +1,86 @@ + + +module GHC.Stg.Subst where + +import GHC.Prelude + +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Utils.Monad.State.Strict + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +-- TODO: This code might make folly of the work done in CorePrep where +-- we clone local ids in order to ensure *all* local binders are unique. +-- It's my understanding that here we use "the rapier"/uniqAway which makes up +-- uniques based on the ids in scope. Which can give the same unique to different +-- binders as long as they are in different scopes. A guarantee which isn't +-- strong enough for code generation in general. See Note [CorePrep Overview]. + +-- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not +-- maintaining pairs of substitutions. Like 'GHC.Core.Subst.Subst', but +-- with the domain being 'Id's instead of entire 'CoreExpr'. +data Subst = Subst InScopeSet IdSubstEnv + +type IdSubstEnv = IdEnv Id + +-- | @emptySubst = 'mkEmptySubst' 'emptyInScopeSet'@ +emptySubst :: Subst +emptySubst = mkEmptySubst emptyInScopeSet + +-- | Constructs a new 'Subst' assuming the variables in the given 'InScopeSet' +-- are in scope. +mkEmptySubst :: InScopeSet -> Subst +mkEmptySubst in_scope = Subst in_scope emptyVarEnv + +-- | Substitutes an 'Id' for another one according to the 'Subst' given in a way +-- that avoids shadowing the 'InScopeSet', returning the result and an updated +-- 'Subst' that should be used by subsequent substitutions. +substBndr :: Id -> Subst -> (Id, Subst) +substBndr id (Subst in_scope env) + = (new_id, Subst new_in_scope new_env) + where + new_id = uniqAway in_scope id + no_change = new_id == id -- in case nothing shadowed + new_in_scope = in_scope `extendInScopeSet` new_id + new_env + | no_change = delVarEnv env id + | otherwise = extendVarEnv env id new_id + +-- | @substBndrs = runState . traverse (state . substBndr)@ +substBndrs :: Traversable f => f Id -> Subst -> (f Id, Subst) +substBndrs = runState . traverse (state . substBndr) + +-- | Substitutes an occurrence of an identifier for its counterpart recorded +-- in the 'Subst'. +lookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id +lookupIdSubst id (Subst in_scope env) + | not (isLocalId id) = id + | Just id' <- lookupVarEnv env id = id' + | Just id' <- lookupInScope in_scope id = id' + | otherwise = warnPprTrace True "StgSubst.lookupIdSubst" (ppr id $$ ppr in_scope) id + +-- | Substitutes an occurrence of an identifier for its counterpart recorded +-- in the 'Subst'. Does not generate a debug warning if the identifier to +-- to substitute wasn't in scope. +noWarnLookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id +noWarnLookupIdSubst id (Subst in_scope env) + | not (isLocalId id) = id + | Just id' <- lookupVarEnv env id = id' + | Just id' <- lookupInScope in_scope id = id' + | otherwise = id + +-- | Add the 'Id' to the in-scope set and remove any existing substitutions for +-- it. +extendInScope :: Id -> Subst -> Subst +extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env + +-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the +-- in-scope set is such that TyCoSubst Note [The substitution invariant] +-- holds after extending the substitution like this. +extendSubst :: Id -> Id -> Subst -> Subst +extendSubst id new_id (Subst in_scope env) + = assertPpr (new_id `elemInScopeSet` in_scope) (ppr id <+> ppr new_id $$ ppr in_scope) $ + Subst in_scope (extendVarEnv env id new_id) diff --git a/GHC/Stg/Syntax.hs b/GHC/Stg/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Syntax.hs @@ -0,0 +1,945 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE UndecidableInstances #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Shared term graph (STG) syntax for spineless-tagless code generation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This data type represents programs just before code generation (conversion to +@Cmm@): basically, what we have is a stylised form of Core syntax, the style +being one that happens to be ideally suited to spineless tagless code +generation. +-} + +module GHC.Stg.Syntax ( + StgArg(..), + + GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), + GenStgAlt(..), AltType(..), + + StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, + NoExtFieldSilent, noExtFieldSilent, + OutputablePass, + + UpdateFlag(..), isUpdatable, + + ConstructorNumber(..), + + -- a set of synonyms for the vanilla parameterisation + StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt, + + -- a set of synonyms for the code gen parameterisation + CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt, + + -- Same for taggedness + TgStgTopBinding, TgStgBinding, TgStgExpr, TgStgRhs, TgStgAlt, + + -- a set of synonyms for the lambda lifting parameterisation + LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, + + -- a set of synonyms to distinguish in- and out variants + InStgArg, InStgTopBinding, InStgBinding, InStgExpr, InStgRhs, InStgAlt, + OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt, + + -- StgOp + StgOp(..), + + -- utils + stgRhsArity, freeVarsOfRhs, + stgArgType, + stgArgRep, + stgArgRep1, + stgArgRepU, + stgArgRep_maybe, + + stgCaseBndrInScope, + + -- ppr + StgPprOpts(..), + panicStgPprOpts, shortStgPprOpts, + pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding, pprStgAlt, + pprGenStgTopBinding, pprStgTopBinding, + pprGenStgTopBindings, pprStgTopBindings + ) where + +import GHC.Prelude + +import GHC.Stg.EnforceEpt.TagSig( TagSig ) +import GHC.Stg.Lift.Types + -- To avoid having an orphan instances for BinderP, XLet etc + +import GHC.Types.CostCentre ( CostCentreStack ) + +import GHC.Core ( AltCon ) +import GHC.Core.DataCon +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), TyCon ) +import GHC.Core.Type ( Type ) +import GHC.Core.Ppr( {- instances -} ) + +import GHC.Types.ForeignCall ( ForeignCall ) +import GHC.Types.Id +import GHC.Types.Tickish ( StgTickish ) +import GHC.Types.Var.Set +import GHC.Types.Literal ( Literal, literalType ) +import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic.Plain + +import GHC.Builtin.PrimOps ( PrimOp, PrimCall ) + +import Data.ByteString ( ByteString ) +import Data.Data ( Data ) +import Data.List ( intersperse ) + +{- +************************************************************************ +* * +GenStgBinding +* * +************************************************************************ + +As usual, expressions are interesting; other things are boring. Here are the +boring things (except note the @GenStgRhs@), parameterised with respect to +binder and occurrence information (just as in @GHC.Core@): +-} + +-- | A top-level binding. +data GenStgTopBinding pass +-- See Note [Core top-level string literals] + = StgTopLifted (GenStgBinding pass) + | StgTopStringLit Id ByteString + +data GenStgBinding pass + = StgNonRec (BinderP pass) (GenStgRhs pass) + | StgRec [(BinderP pass, GenStgRhs pass)] + +{- +************************************************************************ +* * +StgArg +* * +************************************************************************ +-} + +data StgArg + = StgVarArg Id + | StgLitArg Literal + +-- | Type of an @StgArg@ +-- +-- Very half baked because we have lost the type arguments. +-- +-- This function should be avoided: in STG we aren't supposed to +-- look at types, but only PrimReps. +-- Use 'stgArgRep', 'stgArgRep_maybe', 'stgArgRep1' instaed. +stgArgType :: StgArg -> Type +stgArgType (StgVarArg v) = idType v +stgArgType (StgLitArg lit) = literalType lit + +stgArgRep :: StgArg -> [PrimRep] +stgArgRep ty = typePrimRep (stgArgType ty) + +stgArgRep_maybe :: StgArg -> Maybe [PrimRep] +stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty) + +-- | Assumes that the argument has at most one PrimRep, which holds after unarisation. +-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRep1 :: StgArg -> PrimOrVoidRep +stgArgRep1 ty = typePrimRep1 (stgArgType ty) + +-- | Assumes that the argument has exactly one PrimRep. +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRepU :: StgArg -> PrimRep +stgArgRepU ty = typePrimRepU (stgArgType ty) + +-- | Given an alt type and whether the program is unarised, return whether the +-- case binder is in scope. +-- +-- Case binders of unboxed tuple or unboxed sum type always dead after the +-- unariser has run. See Note [Post-unarisation invariants] in GHC.Stg.Unarise. +stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool +stgCaseBndrInScope alt_ty unarised = + case alt_ty of + AlgAlt _ -> True + PrimAlt _ -> True + MultiValAlt _ -> not unarised + PolyAlt -> True + +{- +************************************************************************ +* * +STG expressions +* * +************************************************************************ + +The @GenStgExpr@ data type is parameterised on binder and occurrence info, as +before. + +************************************************************************ +* * +GenStgExpr +* * +************************************************************************ + +An application is of a function to a list of atoms (not expressions). +Operationally, we want to push the arguments on the stack and call the function. +(If the arguments were expressions, we would have to build their closures +first.) + +There is no constructor for a lone variable; it would appear as @StgApp var []@. +-} + +data GenStgExpr pass + = StgApp + Id -- function + [StgArg] -- arguments; may be empty + +{- +************************************************************************ +* * +StgConApp and StgPrimApp --- saturated applications +* * +************************************************************************ + +There are specialised forms of application, for constructors, primitives, and +literals. + +Note [Constructor applications in STG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After the unarisation pass: +* In `StgConApp` and `StgRhsCon` and `StgAlt` we filter out the void arguments, + leaving only non-void ones. +* In `StgApp` and `StgOpApp` we retain void arguments. + +We can do this because we know that `StgConApp` and `StgRhsCon` are saturated applications, +so we lose no information by dropping those void args. In contrast, in `StgApp` we need the + void argument to compare the number of args in the call with the arity of the function. + +This is an open design choice. We could instead choose to treat all these applications +consistently (keeping the void args). But for some reason we don't, and this Note simply +documents that design choice. + +As an example, consider: + + data T a = MkT !Int a Void# + +The wrapper's representation and the worker's representation (i.e. the +datacon's Core representation) are respectively: + + $WMkT :: Int -> a -> Void# -> T a + MkT :: Int# -> a -> Void# -> T a + +T would end up being used in STG post-unarise as: + + let x = MkT 1# y + in ... + case x of + MkT int a -> ... + +The Void# argument is dropped. In essence we only generate binders for runtime +relevant values. + +We also flatten out unboxed tuples in this process. See the unarise +pass for details on how this is done. But as an example consider +`data S = MkS Bool (# Bool | Char #)` which when matched on would +result in an alternative with three binders like this + + MkS bool tag tpl_field -> + +See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] +for the details of this transformation. + +-} + + | StgLit Literal + + -- StgConApp is vital for returning unboxed tuples or sums + -- which can't be let-bound + | StgConApp DataCon + ConstructorNumber + [StgArg] -- Saturated. See Note [Constructor applications in STG] + [[PrimRep]] -- See Note [Representations in StgConApp] in GHC.Stg.Unarise + + | StgOpApp StgOp -- Primitive op or foreign call + [StgArg] -- Saturated. + Type -- Result type + -- We need to know this so that we can + -- assign result registers + +{- +************************************************************************ +* * +GenStgExpr: case-expressions +* * +************************************************************************ + +This has the same boxed/unboxed business as Core case expressions. +-} + + | StgCase + (GenStgExpr pass) -- the thing to examine + (BinderP pass) -- binds the result of evaluating the scrutinee + AltType + [GenStgAlt pass] + -- The DEFAULT case is always *first* + -- if it is there at all + +{- +************************************************************************ +* * +GenStgExpr: let(rec)-expressions +* * +************************************************************************ + +The various forms of let(rec)-expression encode most of the interesting things +we want to do. + +- let-closure x = [free-vars] [args] expr in e + + is equivalent to + + let x = (\free-vars -> \args -> expr) free-vars + + @args@ may be empty (and is for most closures). It isn't under circumstances + like this: + + let x = (\y -> y+z) + + This gets mangled to + + let-closure x = [z] [y] (y+z) + + The idea is that we compile code for @(y+z)@ in an environment in which @z@ is + bound to an offset from Node, and `y` is bound to an offset from the stack + pointer. + + (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.) + +- let-constructor x = Constructor [args] in e + + (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.) + +- Letrec-expressions are essentially the same deal as let-closure/ + let-constructor, so we use a common structure and distinguish between them + with an @is_recursive@ boolean flag. + +- let-unboxed u = in e + + All the stuff on the RHS must be fully evaluated. No function calls either! + + (We've backed away from this toward case-expressions with suitably-magical + alts ...) + +- Advanced stuff here! Not to start with, but makes pattern matching generate + more efficient code. + + let-escapes-not fail = expr + in e' + + Here the idea is that @e'@ guarantees not to put @fail@ in a data structure, + or pass it to another function. All @e'@ will ever do is tail-call @fail@. + Rather than build a closure for @fail@, all we need do is to record the stack + level at the moment of the @let-escapes-not@; then entering @fail@ is just a + matter of adjusting the stack pointer back down to that point and entering the + code for it. + + Another example: + + f x y = let z = huge-expression in + if y==1 then z else + if y==2 then z else + 1 + + (A let-escapes-not is an @StgLetNoEscape@.) + +- We may eventually want: + + let-literal x = Literal in e + +And so the code for let(rec)-things: +-} + + | StgLet + (XLet pass) + (GenStgBinding pass) -- right hand sides (see below) + (GenStgExpr pass) -- body + + | StgLetNoEscape + (XLetNoEscape pass) + (GenStgBinding pass) -- right hand sides (see below) + (GenStgExpr pass) -- body + +{- +************************************************************************* +* * +GenStgExpr: hpc, scc and other debug annotations +* * +************************************************************************* + +Finally for @hpc@ expressions we introduce a new STG construct. +-} + + | StgTick + StgTickish + (GenStgExpr pass) -- sub expression + +-- END of GenStgExpr + +{- +************************************************************************ +* * +STG right-hand sides +* * +************************************************************************ + +Here's the rest of the interesting stuff for @StgLet@s; the first flavour is for +closures: +-} + +data GenStgRhs pass + = StgRhsClosure + (XRhsClosure pass) -- ^ Extension point for non-global free var + -- list just before 'CodeGen'. + CostCentreStack -- ^ CCS to be attached (default is CurrentCCS) + !UpdateFlag -- ^ 'ReEntrant' | 'Updatable' | 'SingleEntry' + [BinderP pass] -- ^ arguments; if empty, then not a function; + -- as above, order is important. + (GenStgExpr pass) -- ^ body + Type -- ^ result type + +{- +An example may be in order. Consider: + + let t = \x -> \y -> ... x ... y ... p ... q in e + +Pulling out the free vars and stylising somewhat, we get the equivalent: + + let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q + +Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are offsets from +@Node@ into the closure, and the code ptr for the closure will be exactly that +in parentheses above. + +The second flavour of right-hand-side is for constructors (simple but +important): +-} + + | StgRhsCon + CostCentreStack -- CCS to be attached (default is CurrentCCS). + -- Top-level (static) ones will end up with + -- DontCareCCS, because we don't count static + -- data in heap profiles, and we don't set CCCS + -- from static closure. + DataCon -- Constructor. Never an unboxed tuple or sum, as those + -- are not allocated. + ConstructorNumber + [StgTickish] + [StgArg] -- Saturated Args. See Note [Constructor applications in STG] + Type -- Type, for rewriting to an StgRhsClosure + +-- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that +-- returns 'empty'. +data NoExtFieldSilent = NoExtFieldSilent + deriving (Data, Eq, Ord) + +instance Outputable NoExtFieldSilent where + ppr _ = empty + +-- | Used when constructing a term with an unused extension point that should +-- not appear in pretty-printed output at all. +noExtFieldSilent :: NoExtFieldSilent +noExtFieldSilent = NoExtFieldSilent +-- TODO: Maybe move this to GHC.Hs.Extension? I'm not sure about the +-- implications on build time... + +stgRhsArity :: StgRhs -> Int +stgRhsArity (StgRhsClosure _ _ _ bndrs _ _) + = assert (all isId bndrs) $ length bndrs + -- The arity never includes type parameters, but they should have gone by now +stgRhsArity (StgRhsCon {}) = 0 + +freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet +freeVarsOfRhs (StgRhsCon _ _ _ _ args _) = mkDVarSet [ id | StgVarArg id <- args ] +freeVarsOfRhs (StgRhsClosure fvs _ _ _ _ _) = fvs + +{- +************************************************************************ +* * +STG case alternatives +* * +************************************************************************ + +Very like in Core syntax (except no type-world stuff). + +The type constructor is guaranteed not to be abstract; that is, we can see its +representation. This is important because the code generator uses it to +determine return conventions etc. But it's not trivial where there's a module +loop involved, because some versions of a type constructor might not have all +the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures that it gets +the TyCon from the constructors or literals (which are guaranteed to have the +Real McCoy) rather than from the scrutinee type. +-} + +data GenStgAlt pass = GenStgAlt + { alt_con :: !AltCon -- alts: data constructor, + , alt_bndrs :: ![BinderP pass] -- constructor's parameters, + , alt_rhs :: !(GenStgExpr pass) -- right-hand side. + } + +data AltType + = PolyAlt -- Polymorphic (a boxed type variable, lifted or unlifted) + | MultiValAlt Int -- Multi value of this arity (unboxed tuple or sum) + -- the arity could indeed be 1 for unary unboxed tuple + -- or enum-like unboxed sums + | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts + | PrimAlt PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts + +{- +************************************************************************ +* * +The Plain STG parameterisation +* * +************************************************************************ + + Note [STG Extension points] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We now make use of extension points in STG for different passes which want + to associate information with AST nodes. + + Currently the pipeline is roughly: + + CoreToStg: Core -> Stg + StgSimpl: Stg -> Stg + CodeGen: Stg -> Cmm + + As part of StgSimpl we run late lambda lifting (Ll). + Late lambda lift: + Stg -> FvStg -> LlStg -> Stg + + CodeGen: + As part of CodeGen we run tag inference. + Tag Inference: + Stg -> Stg 'InferTaggedBinders` -> Stg + + And at a last step we add the free Variables: + Stg -> CgStg + + Which finally CgStg being used to generate Cmm. + +-} + +type StgTopBinding = GenStgTopBinding 'Vanilla +type StgBinding = GenStgBinding 'Vanilla +type StgExpr = GenStgExpr 'Vanilla +type StgRhs = GenStgRhs 'Vanilla +type StgAlt = GenStgAlt 'Vanilla + +type LlStgTopBinding = GenStgTopBinding 'LiftLams +type LlStgBinding = GenStgBinding 'LiftLams +type LlStgExpr = GenStgExpr 'LiftLams +type LlStgRhs = GenStgRhs 'LiftLams +type LlStgAlt = GenStgAlt 'LiftLams + +type CgStgTopBinding = GenStgTopBinding 'CodeGen +type CgStgBinding = GenStgBinding 'CodeGen +type CgStgExpr = GenStgExpr 'CodeGen +type CgStgRhs = GenStgRhs 'CodeGen +type CgStgAlt = GenStgAlt 'CodeGen + +type TgStgTopBinding = GenStgTopBinding 'CodeGen +type TgStgBinding = GenStgBinding 'CodeGen +type TgStgExpr = GenStgExpr 'CodeGen +type TgStgRhs = GenStgRhs 'CodeGen +type TgStgAlt = GenStgAlt 'CodeGen + +{- Many passes apply a substitution, and it's very handy to have type + synonyms to remind us whether or not the substitution has been applied. + See GHC.Core for precedence in Core land +-} + +type InStgTopBinding = StgTopBinding +type InStgBinding = StgBinding +type InStgArg = StgArg +type InStgExpr = StgExpr +type InStgRhs = StgRhs +type InStgAlt = StgAlt +type OutStgTopBinding = StgTopBinding +type OutStgBinding = StgBinding +type OutStgArg = StgArg +type OutStgExpr = StgExpr +type OutStgRhs = StgRhs +type OutStgAlt = StgAlt + +-- | When `-fdistinct-constructor-tables` is turned on then +-- each usage of a constructor is given an unique number and +-- an info table is generated for each different constructor. +data ConstructorNumber = + NoNumber | Numbered Int + +instance Outputable ConstructorNumber where + ppr NoNumber = empty + ppr (Numbered n) = text "#" <> ppr n + +{- +Note Stg Passes +~~~~~~~~~~~~~~~ +Here is a short summary of the STG pipeline and where we use the different +StgPass data type indexes: + + 1. CoreToStg.Prep performs several transformations that prepare the desugared + and simplified core to be converted to STG. One of these transformations is + making it so that value lambdas only exist as the RHS of a binding. + See Note [CorePrep Overview]. + + 2. CoreToStg converts the prepared core to STG, specifically GenStg* + parameterised by 'Vanilla. See the GHC.CoreToStg Module. + + 3. Stg.Pipeline does a number of passes on the generated STG. One of these is + the lambda-lifting pass, which internally uses the 'LiftLams + parameterisation to store information for deciding whether or not to lift + each binding. + See Note [Late lambda lifting in STG]. + + 4. EPT enforcement takes in 'Vanilla and produces 'InferTagged STG, while using + the InferTaggedBinders annotated AST internally. + See Note [EPT enforcement]. + + 5. Stg.FVs annotates closures with their free variables. To store these + annotations we use the 'CodeGen parameterisation. + See the GHC.Stg.FVs module. + + 6. The Module Stg.StgToCmm generates Cmm from the CodeGen annotated STG. +-} + + +-- | Used as a data type index for the stgSyn AST +data StgPass + = Vanilla + | LiftLams -- ^ Use internally by the lambda lifting pass + | InferTaggedBinders -- ^ Tag inference information on binders. + -- See Note [EPT enforcement] in GHC.Stg.EnforceEpt + | InferTagged -- ^ Tag inference information put on relevant StgApp nodes + -- See Note [EPT enforcement] in GHC.Stg.EnforceEpt + | CodeGen + +type family BinderP (pass :: StgPass) +type instance BinderP 'Vanilla = Id +type instance BinderP 'CodeGen = Id +type instance BinderP 'InferTagged = Id +type instance BinderP 'InferTaggedBinders = (Id, TagSig) +type instance BinderP 'LiftLams = BinderInfo + +type family XRhsClosure (pass :: StgPass) +type instance XRhsClosure 'Vanilla = NoExtFieldSilent +type instance XRhsClosure 'LiftLams = DIdSet +type instance XRhsClosure 'InferTagged = NoExtFieldSilent +type instance XRhsClosure 'InferTaggedBinders = XRhsClosure 'CodeGen +-- | Code gen needs to track non-global free vars +type instance XRhsClosure 'CodeGen = DIdSet + + +type family XLet (pass :: StgPass) +type instance XLet 'Vanilla = NoExtFieldSilent +type instance XLet 'LiftLams = Skeleton +type instance XLet 'InferTagged = NoExtFieldSilent +type instance XLet 'InferTaggedBinders = XLet 'CodeGen +type instance XLet 'CodeGen = NoExtFieldSilent + +type family XLetNoEscape (pass :: StgPass) +type instance XLetNoEscape 'Vanilla = NoExtFieldSilent +type instance XLetNoEscape 'LiftLams = Skeleton +type instance XLetNoEscape 'InferTagged = NoExtFieldSilent +type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen +type instance XLetNoEscape 'CodeGen = NoExtFieldSilent + +{- + +************************************************************************ +* * +UpdateFlag +* * +************************************************************************ + +This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. + +-} + +data UpdateFlag + = ReEntrant + -- ^ A @ReEntrant@ closure may be entered multiple times, but should not + -- be updated or blackholed. + | Updatable + -- ^ An @Updatable@ closure should be updated after evaluation (and may be + -- blackholed during evaluation). + | SingleEntry + -- ^ A @SingleEntry@ closure will only be entered once, and so need not be + -- updated but may safely be blackholed. + | JumpedTo + -- ^ A @JumpedTo@ (join-point) closure is entered once or multiple times + -- but has no heap-allocated associated closure. + deriving (Show,Eq) + +instance Outputable UpdateFlag where + ppr u = char $ case u of + ReEntrant -> 'r' + Updatable -> 'u' + SingleEntry -> 's' + JumpedTo -> 'j' + +isUpdatable :: UpdateFlag -> Bool +isUpdatable ReEntrant = False +isUpdatable SingleEntry = False +isUpdatable Updatable = True +isUpdatable JumpedTo = False + +{- +************************************************************************ +* * +StgOp +* * +************************************************************************ + +An StgOp allows us to group together PrimOps and ForeignCalls. It's quite useful +to move these around together, notably in StgOpApp and COpStmt. +-} + +data StgOp + = StgPrimOp PrimOp + + | StgPrimCallOp PrimCall + + | StgFCallOp ForeignCall Type + -- The Type, which is obtained from the foreign import declaration + -- itself, is needed by the stg-to-cmm pass to determine the offset to + -- apply to unlifted boxed arguments in GHC.StgToCmm.Foreign. See Note + -- [Unlifted boxed arguments to foreign calls] + +{- +************************************************************************ +* * +Pretty-printing +* * +************************************************************************ + +Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he +likes terminators instead... Ditto for case alternatives. +-} + +type OutputablePass pass = + ( Outputable (XLet pass) + , Outputable (XLetNoEscape pass) + , Outputable (XRhsClosure pass) + , OutputableBndr (BinderP pass) + ) + +-- | STG pretty-printing options +data StgPprOpts = StgPprOpts + { stgSccEnabled :: !Bool -- ^ Enable cost-centres + } + +-- | STG pretty-printing options used for panic messages +panicStgPprOpts :: StgPprOpts +panicStgPprOpts = StgPprOpts + { stgSccEnabled = True + } + +-- | STG pretty-printing options used for short messages +shortStgPprOpts :: StgPprOpts +shortStgPprOpts = StgPprOpts + { stgSccEnabled = False + } + + +pprGenStgTopBinding + :: OutputablePass pass => StgPprOpts -> GenStgTopBinding pass -> SDoc +pprGenStgTopBinding opts b = case b of + StgTopStringLit bndr str -> hang (hsep [pprBndr LetBind bndr, equals]) 4 (pprHsBytes str <> semi) + StgTopLifted bind -> pprGenStgBinding opts bind + +pprGenStgBinding :: OutputablePass pass => StgPprOpts -> GenStgBinding pass -> SDoc +pprGenStgBinding opts b = case b of + StgNonRec bndr rhs -> hang (hsep [pprBndr LetBind bndr, equals]) 4 (pprStgRhs opts rhs <> semi) + StgRec pairs -> vcat [ text "Rec {" + , vcat (intersperse blankLine (map ppr_bind pairs)) + , text "end Rec }" ] + where + ppr_bind (bndr, expr) + = hang (hsep [pprBndr LetBind bndr, equals]) + 4 (pprStgRhs opts expr <> semi) + +instance OutputablePass pass => Outputable (GenStgBinding pass) where + ppr = pprGenStgBinding panicStgPprOpts + +pprGenStgTopBindings :: (OutputablePass pass) => StgPprOpts -> [GenStgTopBinding pass] -> SDoc +pprGenStgTopBindings opts binds + = vcat $ intersperse blankLine (map (pprGenStgTopBinding opts) binds) + +pprStgBinding :: OutputablePass pass => StgPprOpts -> GenStgBinding pass -> SDoc +pprStgBinding = pprGenStgBinding + +pprStgTopBinding :: OutputablePass pass => StgPprOpts -> GenStgTopBinding pass -> SDoc +pprStgTopBinding = pprGenStgTopBinding + +pprStgTopBindings :: OutputablePass pass => StgPprOpts -> [GenStgTopBinding pass] -> SDoc +pprStgTopBindings = pprGenStgTopBindings + +pprIdWithRep :: Id -> SDoc +pprIdWithRep v = ppr v <> pprTypeRep (idType v) + +pprTypeRep :: Type -> SDoc +pprTypeRep ty = + ppUnlessOption sdocSuppressStgReps $ + char ':' <> case typePrimRep ty of + [r] -> ppr r + r -> ppr r + + +instance Outputable StgArg where + ppr = pprStgArg + +pprStgArg :: StgArg -> SDoc +pprStgArg (StgVarArg var) = pprIdWithRep var +pprStgArg (StgLitArg con) = ppr con <> pprTypeRep (literalType con) + +instance OutputablePass pass => Outputable (GenStgExpr pass) where + ppr = pprStgExpr panicStgPprOpts + +pprStgExpr :: OutputablePass pass => StgPprOpts -> GenStgExpr pass -> SDoc +pprStgExpr opts e = case e of + -- special case + StgLit lit -> ppr lit + -- general case + StgApp func args + | null args + , Just sig <- idTagSig_maybe func + -> ppr func <> ppr sig + | otherwise -> hang (ppr func) 4 (interppSP args) -- TODO: Print taggedness + StgConApp con n args _ -> hsep [ ppr con, ppr n, brackets (interppSP args) ] + StgOpApp op args _ -> hsep [ pprStgOp op, brackets (interppSP args)] + +-- special case: let v = +-- in +-- let ... +-- in +-- ... +-- +-- Very special! Suspicious! (SLPJ) + +{- + StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) + expr@(StgLet _ _)) + -> ($$) + (hang (hcat [text "let { ", ppr bndr, text " = ", + ppr cc, + pp_binder_info bi, + text " [", whenPprDebug (interppSP free_vars), text "] \\", + ppr upd_flag, text " [", + interppSP args, char ']']) + 8 (sep [hsep [ppr rhs, text "} in"]])) + (ppr expr) +-} + + -- special case: let ... in let ... + StgLet ext bind expr@StgLet{} -> ($$) + (sep [hang (text "let" <+> ppr ext <+> text "{") + 2 (hsep [pprGenStgBinding opts bind, text "} in"])]) + (pprStgExpr opts expr) + + -- general case + StgLet ext bind expr + -> sep [ hang (text "let" <+> ppr ext <+> text "{") + 2 (pprGenStgBinding opts bind) + , hang (text "} in ") 2 (pprStgExpr opts expr) + ] + + StgLetNoEscape ext bind expr + -> sep [ hang (text "let-no-escape" <+> ppr ext <+> text "{") + 2 (pprGenStgBinding opts bind) + , hang (text "} in ") 2 (pprStgExpr opts expr) + ] + + StgTick tickish expr -> sdocOption sdocSuppressTicks $ \case + True -> pprStgExpr opts expr + False -> sep [ ppr tickish, pprStgExpr opts expr ] + + -- Don't indent for a single case alternative. + StgCase expr bndr alt_type [alt] + -> sep [ sep [ text "case" + , nest 4 (hsep [ pprStgExpr opts expr + , whenPprDebug (dcolon <+> ppr alt_type) + ]) + , text "of" + , pprBndr CaseBind bndr + , char '{' + ] + , pprStgAlt opts False alt + , char '}' + ] + + StgCase expr bndr alt_type alts + -> sep [ sep [ text "case" + , nest 4 (hsep [ pprStgExpr opts expr + , whenPprDebug (dcolon <+> ppr alt_type) + ]) + , text "of" + , pprBndr CaseBind bndr, char '{' + ] + , nest 2 (vcat (map (pprStgAlt opts True) alts)) + , char '}' + ] + + +pprStgAlt :: OutputablePass pass => StgPprOpts -> Bool -> GenStgAlt pass -> SDoc +pprStgAlt opts indent GenStgAlt{alt_con, alt_bndrs, alt_rhs} + | indent = hang altPattern 4 (pprStgExpr opts alt_rhs <> semi) + | otherwise = sep [altPattern, pprStgExpr opts alt_rhs <> semi] + where + altPattern = hsep [ ppr alt_con + , sep (map (pprBndr CasePatBind) alt_bndrs) + , text "->" + ] + + +pprStgOp :: StgOp -> SDoc +pprStgOp (StgPrimOp op) = ppr op +pprStgOp (StgPrimCallOp op)= ppr op +pprStgOp (StgFCallOp op _) = ppr op + +instance Outputable StgOp where + ppr = pprStgOp + +instance Outputable AltType where + ppr PolyAlt = text "Polymorphic" + ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n + ppr (AlgAlt tc) = text "Alg" <+> ppr tc + ppr (PrimAlt tc) = text "Prim" <+> ppr tc + +pprStgRhs :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc +pprStgRhs opts rhs = case rhs of + StgRhsClosure ext cc upd_flag args body _ + -> hang (hsep [ if stgSccEnabled opts then ppr cc else empty + , ppUnlessOption sdocSuppressStgExts (ppr ext) + , char '\\' <> ppr upd_flag, brackets (interppSP args) + ]) + 4 (pprStgExpr opts body) + + StgRhsCon cc con mid _ticks args _ + -> hcat [ if stgSccEnabled opts then ppr cc <> space else empty + , case mid of + NoNumber -> empty + Numbered n -> hcat [ppr n, space] + -- The bang indicates this is an StgRhsCon instead of an StgConApp. + , ppr con, text "! ", brackets (sep (map pprStgArg args))] + +instance OutputablePass pass => Outputable (GenStgRhs pass) where + ppr = pprStgRhs panicStgPprOpts diff --git a/GHC/Stg/Unarise.hs b/GHC/Stg/Unarise.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Unarise.hs @@ -0,0 +1,1193 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiWayIf #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-2012 + +Note [Unarisation] +~~~~~~~~~~~~~~~~~~ +The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum +binders. So for example: + + f (x :: (# Int, Bool #)) = f x + f (# 1, True #) + + ==> + + f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True + +It is important that we do this at the STG level and NOT at the Core level +because it would be very hard to make this pass Core-type-preserving. In this +example the type of 'f' changes, for example. + +STG fed to the code generators *must* be unarised because the code generators do +not support unboxed tuple and unboxed sum binders natively. + +In more detail: (see next note for unboxed sums) + +Suppose that a variable x : (# t1, t2 #). + + * At the binding site for x, make up fresh vars x1:t1, x2:t2 + + * Extend the UnariseEnv x :-> MultiVal [x1,x2] + + * Replace the binding with a curried binding for x1,x2 + + Lambda: \x.e ==> \x1 x2. e + Case alt: MkT a b x c d -> e ==> MkT a b x1 x2 c d -> e + + * Replace argument occurrences with a sequence of args via a lookup in + UnariseEnv + + f a b x c d ==> f a b x1 x2 c d + + * Replace tail-call occurrences with an unboxed tuple via a lookup in + UnariseEnv + + x ==> (# x1, x2 #) + + So, for example + + f x = x ==> f x1 x2 = (# x1, x2 #) + + * We /always/ eliminate a case expression when + + - It scrutinises an unboxed tuple or unboxed sum + + - The scrutinee is a variable (or when it is an explicit tuple, but the + simplifier eliminates those) + + The case alternative (there can be only one) can be one of these two + things: + + - An unboxed tuple pattern. e.g. + + case v of x { (# x1, x2, x3 #) -> ... } + + Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the + environment with + + x :-> MultiVal [t1,t2,t3] + x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3 + + - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3 + +By the end of this pass, we only have unboxed tuples in return positions. +Unboxed sums are completely eliminated, see next note. + +Note [Translating unboxed sums to unboxed tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unarise also eliminates unboxed sum binders, and translates unboxed sums in +return positions to unboxed tuples. We want to overlap fields of a sum when +translating it to a tuple to have efficient memory layout. When translating a +sum pattern to a tuple pattern, we need to translate it so that binders of sum +alternatives will be mapped to right arguments after the term translation. So +translation of sum DataCon applications to tuple DataCon applications and +translation of sum patterns to tuple patterns need to be in sync. + +These translations work like this. Suppose we have + + (# x1 | | ... #) :: (# t1 | t2 | ... #) + +remember that t1, t2 ... can be sums and tuples too. So we first generate +layouts of those. Then we "merge" layouts of each alternative, which gives us a +sum layout with best overlapping possible. + +Layout of a flat type 'ty1' is just [ty1]. +Layout of a tuple is just concatenation of layouts of its fields. + +For layout of a sum type, + + - We first get layouts of all alternatives. + - We sort these layouts based on their "slot types". + - We merge all the alternatives. + +For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #) + + - Layouts of alternatives: [ [Word, LiftedPtr], [Word, Word], [Word] ] + - Sorted: [ [LiftedPtr, Word], [Word, Word], [Word] ] + - Merge all alternatives together: [ LiftedPtr, Word, Word ] + +We add a slot for the tag to the first position. So our tuple type is + + (# Tag#, Any, Word#, Word# #) + (we use Any for pointer slots) + +Now, any term of this sum type needs to generate a tuple of this type instead. +The translation works by simply putting arguments to first slots that they fit +in. Suppose we had + + (# (# 42#, 'c' #) | | #) + +42# fits in Word#, 'c' fits in Any, so we generate this application: + + (# 1#, 'c', 42#, rubbish #) + +Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#, +3# fits in Word #, so we get: + + (# 2#, rubbish, 2#, 3# #). + + +Note [Don't merge lifted and unlifted slots] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When merging slots, one might be tempted to collapse lifted and unlifted +pointers. However, as seen in #19645, this is wrong. Imagine that you have +the program: + + test :: (# Char | ByteArray# #) -> ByteArray# + test (# c | #) = doSomething c + test (# | ba #) = ba + +Collapsing the Char and ByteArray# slots would produce STG like: + + test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray# + = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ] + case tag of tag' + 1# -> doSomething slot0 + 2# -> slot0; + +Note how `slot0` has a lifted type, despite being bound to an unlifted +ByteArray# in the 2# alternative. This liftedness would cause the code generator to +attempt to enter it upon returning. As unlifted objects do not have entry code, +this causes a runtime crash. + +For this reason, Unarise treats unlifted and lifted things as distinct slot +types, despite both being GC pointers. This approach is a slight pessimisation +(since we need to pass more arguments) but appears to be the simplest way to +avoid #19645. Other alternatives considered include: + + a. Giving unlifted objects "trivial" entry code. However, we ultimately + concluded that the value of the "unlifted things are never entered" invariant + outweighed the simplicity of this approach. + + b. Annotating occurrences with calling convention information instead of + relying on the binder's type. This seemed like a very complicated + way to fix what is ultimately a corner-case. + + +Note [Representations in StgConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have this unboxed sum term: + + (# 123 | #) + +What will be the unboxed tuple representation? We can't tell without knowing the +type of this term. For example, these are all valid tuples for this: + + (# 1#, 123 #) -- when type is (# Int | String #) + (# 1#, 123, rubbish #) -- when type is (# Int | Float# #) + (# 1#, 123, rubbish, rubbish #) + -- when type is (# Int | (# Int, Int, Int #) #) + +Therefore, in StgConApp we store a list [[PrimRep]] of representations +to decide what layout to use. +Given (# T_1 | ... | T_n #), this list will be +[typePrimRep T_1, ..., typePrimRep T_n]. +For example, given type + (# Int | String #) we will store [[LiftedRep], [LiftedRep]] + (# Int | Float# #) we will store [[LiftedRep], [FloatRep]] + (# Int | (# Int, Int, Int #) #) we will store [[LiftedRep], [LiftedRep, LiftedRep, LiftedRep]]. + +This field is used for unboxed sums only and it's an empty list otherwise. +Perhaps it would be more elegant to have a separate StgUnboxedSumCon, +but that would require duplication of code in cases where the logic is shared. + +Note that unlifted values can't be let-bound, so we don't need +representations in StgRhsCon. + +Note [Casting slot arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this function which selects between Int32# and Int64# from a unboxed sum. + + foo :: (# Int32# | Int64# #) -> FD + foo x = case x of + (# x1 | #) -> F x1 + (# | x2 #) -> D x2 + +Naturally we would expect x1 to have a PrimRep of Int32Rep and x2 of DoubleRep. +However we used to generate this (bogus) code after Unarise giving rise to #22208: + + M.foo :: (# GHC.Prim.Int32# | GHC.Prim.Int64# #) -> M.FD + [GblId, Arity=1, Unf=OtherCon []] = + {} \r [sum_tag sum_field] + case sum_tag of tag_gsc { + __DEFAULT -> M.F [sum_field]; + 2# -> M.D [sum_field]; + }; + +Where sum_field is used both as Int32# and Int64# depending on the branch +because they share the same SlotTy. +This usually works out since we put all int's in the same sort of register. +So even if the reps where wrong (x :: bits32) = (y :: bits64) would produce +correct code in the most cases. +However there are cases where this goes wrong, causing lint errors,in the case of #22208 +compiler panics or in some cases incorrect results in the C backend. +For now our solution is to construct proper casts between the PrimRep of the slot and +the variables we want to store in, or read out of these slots. + +This means when we have a sum (# Int32# | Int64# #) if we want to store a Int32 +we convert it to a Int64 on construction of the tuple value, and convert it back +to a Int32 once when want to use the field. On most backends these coversions should +be no-ops at runtime so this seems reasonable. + +Conversion for values coming out of a strict field happen in mapSumIdBinders. While +conversion during the construction of sums happen inside mkUbxSum. + +------------- A full example of casting during sum construction ---------------- + +To compile a constructor application of a unboxed sum of type (# Int32# | Int64# ) +in an expression like `let sum = (# x | #)` we will call mkUbxSum to determine +which binders we have to replace sum with at use sites during unarise. +See also Note [Translating unboxed sums to unboxed tuples]. + +Int32# and Int64# in this case will share the same slot in the unboxed sum. This means +the sum after unarise will be represented by two binders. One for the tag and one for +the field. The later having Int64Rep. +However our input for the field is of Int32Rep. So in order to soundly construct +`(# x | #) :: (# Int32# | Int64# )` we must upcast `x` to Int64#. +To do this mkUbxSum will produce an expression with a hole for constructor application +to go into. That is the call to mkUbxSum and it's result will look something like: + + >>> mkUbxSum (#|#) [Int32#, Int64#] (x::Int32#) us (x') + ([1#::Int#, x'::Int64#], \rhs -> case int32ToInt# x of x' -> rhs ) + +We will use the returned arguments to construct an application to an unboxed tuple: + + >>> mkTuple [tag::Int#, x'::Int64#] + (# tag, x' #) + +Which we will then use as the rhs to pass into the casting wrapper to +construct an expression that casts `x` to the right type before constructing the +tuple + + >>> (\rhs -> case int32ToInt# x of x' -> rhs ) (# tag, x' #) + case int32ToInt# x of x' -> (# #) 1# x' + +Which results in the this definition for `sum` after all is said and done: + + let sum = case int32ToInt# x of { x' -> (# #) 1# x' } + +Not that the renaming is not optional. Cmm requires binders of different uniques +to have at least different types. See Note [CorePrep Overview]: 6. Clone all local Ids + +------------- A full example of casting during sum matching -------------------- + +When matching on an unboxed sum constructor we start out with +something like this the pre-unarise: + + f :: (# Int32 | Int64# ) -> ... + f sum = case sum of + (# x |#) -> alt_rhs + ... + +We unarise the function arguments and get: + + f sum_tag sum_slot1 = case sum_tag of + 1# -> ??? + +Now we need to match up the original alternative binders with the sum slots passed +to the function. This is done by mapSumIdBinders which we we call for our +example alternative like this: + + >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env + (env', alt_rhs') + +mapSumIdBinders first matches up the list of binders with the slots passed to +the function which is trivial in this case. Then we check if the slot and the +variable residing inside it agree on their Rep. If alternative binders and +the function arguments agree in their slot reps we we just extend the environment +with a mapping from `x` to `sum_slot1` and we return the rhs as is. + +If the reps of the sum_slots do not agree with alternative binders they represent +then we need to wrap the whole RHS in nested cases which cast the sum_slot +variables to the correct rep. Here `x` is of Int32Rep while `sum_slot1` will be +of Int64Rep. This means instead of retuning the original alt_rhs we will return: + + >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env + ( env'[x=x'] + , case int64ToInt32# (sum_slot1 :: Int64#) of + (x' :: Int32#) -> alt_rhs + ) + +We then run unarise on alt_rhs within that expression, which will replace the first occurrence +of `x` with sum_slot_arg_1 giving us post-unarise: + + f sum_tag sum_slot1 = + case sum_tag of + 1# -> case int64ToInt32# sum_slot1 of + x' -> ... x' ... + ... + +Note [UnariseEnv] +~~~~~~~~~~~~~~~~~~ +At any variable occurrence 'v', +* If the UnariseEnv has a binding for 'v', the binding says what 'v' is bound to +* If not, 'v' stands just for itself. + +Most variables are unaffected by unarisation, and (for efficiency) we don't put +them in the UnariseEnv at all. But NB: when we go under a binding for 'v' we must +remember to delete 'v' from the UnariseEnv, lest occurrences of 'v' see the outer +binding for the variable (#21396). + + +Note [UnariseEnv can map to literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To avoid redundant case expressions when unarising unboxed sums, UnariseEnv +needs to map variables to literals too. Suppose we have this Core: + + f (# x | #) + + ==> (CorePrep) + + case (# x | #) of y { + _ -> f y + } + + ==> (MultiVal) + + case (# 1#, x #) of [x1, x2] { + _ -> f x1 x2 + } + +To eliminate this case expression we need to map x1 to 1# in UnariseEnv: + + x1 :-> UnaryVal 1#, x2 :-> UnaryVal x + +so that `f x1 x2` becomes `f 1# x`. + +Note [Unarisation and arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of unarisation, the arity that will be recorded in the generated info +table for an Id may be larger than the idArity. Instead we record what we call +the RepArity, which is the Arity taking into account any expanded arguments, and +corresponds to the number of (possibly-void) *registers* arguments will arrive +in. + +Note [Post-unarisation invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +STG programs after unarisation have these invariants: + + 1. No unboxed sums at all. + + 2. No unboxed tuple binders. Tuples only appear in return position. + + 3. Binders and literals always have zero (for void arguments) or one PrimRep. + (i.e. typePrimRep1 won't crash; see Note [VoidRep] in GHC.Types.RepType.) + + 4. DataCon applications (StgRhsCon and StgConApp) don't have void arguments. + This means that it's safe to wrap `StgArg`s of DataCon applications with + `GHC.StgToCmm.Env.NonVoid`, for example. + + 5. Alt binders (binders in patterns) are always non-void. +-} + +module GHC.Stg.Unarise (unarise) where + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Core +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Data.FastString (FastString, mkFastString, fsLit) +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID) +import GHC.Types.Id.Make (voidPrimId, voidArgId) +import GHC.Utils.Monad (mapAccumLM) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.RepType +import GHC.Stg.Syntax +import GHC.Stg.Utils +import GHC.Stg.Make +import GHC.Core.Type +import GHC.Builtin.Types.Prim (intPrimTy) +import GHC.Builtin.Types +import GHC.Types.Unique.Supply +import GHC.Types.Unique +import GHC.Utils.Misc +import GHC.Types.Var.Env + +import Data.Bifunctor (second) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (mapMaybe) +import qualified Data.IntMap as IM +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Casts +import Data.List (mapAccumL) + +-- import GHC.Utils.Trace +-------------------------------------------------------------------------------- + +-- | A mapping from binders to the Ids they were expanded/renamed to. +-- +-- x :-> MultiVal [a,b,c] in rho +-- +-- iff x's typePrimRep is not a singleton, or equivalently +-- x's type is an unboxed tuple, sum or void. +-- +-- x :-> UnaryVal x' +-- +-- iff x's RepType is UnaryRep or equivalently +-- x's type is not unboxed tuple, sum or void. +-- +-- So +-- x :-> MultiVal [a] in rho +-- means x is represented by singleton tuple. +-- +-- x :-> MultiVal [] in rho +-- means x is void. +-- +-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes +-- (i.e. no unboxed tuples, sums or voids) +-- +data UnariseEnv = UnariseEnv + { ue_rho :: (VarEnv UnariseVal) + , ue_allow_static_conapp :: DataCon -> [StgArg] -> Bool + } + +initUnariseEnv :: VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv +initUnariseEnv = UnariseEnv + +data UnariseVal + = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). + | UnaryVal OutStgArg -- See Note [Renaming during unarisation]. + +instance Outputable UnariseVal where + ppr (MultiVal args) = text "MultiVal" <+> ppr args + ppr (UnaryVal arg) = text "UnaryVal" <+> ppr arg + +-- | Extend the environment, checking the UnariseEnv invariant. +-- The id is mapped to one or more things. +-- See Note [UnariseEnv] +extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv +extendRho env x (MultiVal args) + = assert (all (isNvUnaryRep . stgArgRep) args) + env { ue_rho = extendVarEnv (ue_rho env) x (MultiVal args) } +extendRho env x (UnaryVal val) + = assert (isNvUnaryRep (stgArgRep val)) + env { ue_rho = extendVarEnv (ue_rho env) x (UnaryVal val) } +-- Properly shadow things from an outer scope. +-- See Note [UnariseEnv] + +-- The id stands for itself so we don't record a mapping. +-- See Note [UnariseEnv] +extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv +extendRhoWithoutValue env x = env { ue_rho = delVarEnv (ue_rho env) x } + +lookupRho :: UnariseEnv -> Id -> Maybe UnariseVal +lookupRho env v = lookupVarEnv (ue_rho env) v + +-------------------------------------------------------------------------------- + +unarise :: UniqSupply -> (DataCon -> [StgArg] -> Bool) -> [StgTopBinding] -> [StgTopBinding] +unarise us is_dll_con_app binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv is_dll_con_app)) binds) + +unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding +unariseTopBinding rho (StgTopLifted bind) + = StgTopLifted <$> unariseBinding rho True bind +unariseTopBinding _ bind@StgTopStringLit{} = return bind + +unariseBinding :: UnariseEnv -> Bool -> StgBinding -> UniqSM StgBinding +unariseBinding rho top_level (StgNonRec x rhs) + = StgNonRec x <$> unariseRhs rho top_level rhs +unariseBinding rho top_level (StgRec xrhss) + = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho top_level rhs) xrhss + +unariseRhs :: UnariseEnv -> Bool -> StgRhs -> UniqSM StgRhs +unariseRhs rho top_level (StgRhsClosure ext ccs update_flag args expr typ) + = do (rho', args1) <- unariseFunArgBinders rho args + expr' <- unariseExpr rho' expr + -- Unarisation can lead to a StgRhsClosure becoming a StgRhsCon. + -- Hence, we call `mk(Top)StgRhsCon_maybe` rather than just building + -- another `StgRhsClosure`. + -- + -- For example with unboxed sums (#25166): + -- + -- foo = \u [] case (# | _ | #) [(##)] of tag { __DEFAULT -> D [True tag] } + -- + -- ====> {unarisation} + -- + -- foo = D [True 2#] + -- + -- Transforming an appropriate StgRhsClosure into a StgRhsCon is + -- important as top-level StgRhsCon are statically allocated. + -- + let mk_rhs = MkStgRhs + { rhs_args = args1 + , rhs_expr = expr' + , rhs_type = typ + , rhs_is_join = update_flag == JumpedTo + } + if | top_level + , Just rhs_con <- mkTopStgRhsCon_maybe (ue_allow_static_conapp rho) mk_rhs + -> pure rhs_con + + | not top_level + , Just rhs_con <- mkStgRhsCon_maybe mk_rhs + -> pure rhs_con + + | otherwise + -> pure (StgRhsClosure ext ccs update_flag args1 expr' typ) + +unariseRhs rho _top (StgRhsCon ccs con mu ts args typ) + = assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)) + return (StgRhsCon ccs con mu ts (unariseConArgs rho args) typ) + +-------------------------------------------------------------------------------- + +unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr + +unariseExpr rho e@(StgApp f []) + = case lookupRho rho f of + Just (MultiVal args) -- Including empty tuples + -> return (mkTuple args) + Just (UnaryVal (StgVarArg f')) + -> return (StgApp f' []) + Just (UnaryVal (StgLitArg f')) + -> return (StgLit f') + Nothing + -> return e + +unariseExpr rho e@(StgApp f args) + = return (StgApp f' (unariseFunArgs rho args)) + where + f' = case lookupRho rho f of + Just (UnaryVal (StgVarArg f')) -> f' + Nothing -> f + err -> pprPanic "unariseExpr - app2" (pprStgExpr panicStgPprOpts e $$ ppr err) + -- Can't happen because 'args' is non-empty, and + -- a tuple or sum cannot be applied to anything + +unariseExpr _ (StgLit l) + = return (StgLit l) + +unariseExpr rho (StgConApp dc n args ty_args) + | isUnboxedSumDataCon dc || isUnboxedTupleDataCon dc + = do + us <- getUniqueSupplyM + case unariseUbxSumOrTupleArgs rho us dc args ty_args of + (args', Just cast_wrapper) + -> return $ cast_wrapper (mkTuple args') + (args', Nothing) + -> return $ (mkTuple args') + | otherwise = + let args' = unariseConArgs rho args in + return $ (StgConApp dc n args' []) + +unariseExpr rho (StgOpApp op args ty) + = return (StgOpApp op (unariseFunArgs rho args) ty) + +unariseExpr rho (StgCase scrut bndr alt_ty alts) + -- tuple/sum binders in the scrutinee can always be eliminated + | StgApp v [] <- scrut + , Just (MultiVal xs) <- lookupRho rho v + = elimCase rho xs bndr alt_ty alts + + -- Handle strict lets for tuples and sums: + -- case (# a,b #) of r -> rhs + -- and analogously for sums + | StgConApp dc _n args ty_args <- scrut + , isUnboxedSumDataCon dc || isUnboxedTupleDataCon dc + = do + us <- getUniqueSupplyM + case unariseUbxSumOrTupleArgs rho us dc args ty_args of + (args',Just wrapper) -> wrapper <$> elimCase rho args' bndr alt_ty alts + (args',Nothing) -> elimCase rho args' bndr alt_ty alts + + -- See (3) of Note [Rubbish literals] in GHC.Types.Literal + | StgLit lit <- scrut + , Just args' <- unariseLiteral_maybe lit + = elimCase rho args' bndr alt_ty alts + + -- general case + | otherwise + = do scrut' <- unariseExpr rho scrut + alts' <- unariseAlts rho alt_ty bndr alts + return (StgCase scrut' bndr alt_ty alts') + -- bndr may have a unboxed sum/tuple type but it will be + -- dead after unarise (checked in GHC.Stg.Lint) + +unariseExpr rho (StgLet ext bind e) + = StgLet ext <$> unariseBinding rho False bind <*> unariseExpr rho e + +unariseExpr rho (StgLetNoEscape ext bind e) + = StgLetNoEscape ext <$> unariseBinding rho False bind <*> unariseExpr rho e + +unariseExpr rho (StgTick tick e) + = StgTick tick <$> unariseExpr rho e + +-- Doesn't return void args. +unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [[PrimRep]] + -> ( [OutStgArg] -- Arguments representing the unboxed sum + , Maybe (StgExpr -> StgExpr)) -- Transformation to apply to the arguments, to bring them + -- into the right Rep +unariseUbxSumOrTupleArgs rho us dc args ty_args + | isUnboxedTupleDataCon dc + = (unariseConArgs rho args, Nothing) + + | isUnboxedSumDataCon dc + , let args1 = assert (isSingleton args) (unariseConArgs rho args) + = let (args2, cast_wrapper) = mkUbxSum dc ty_args args1 us + in (args2, Just cast_wrapper) + + | otherwise + = panic "unariseUbxSumOrTupleArgs: Constructor not a unboxed sum or tuple" + +-- Returns @Nothing@ if the given literal is already unary (exactly +-- one PrimRep). Doesn't return void args. +-- +-- This needs to exist because rubbish literals can have any representation. +-- See also Note [Rubbish literals] in GHC.Types.Literal. +unariseLiteral_maybe :: Literal -> Maybe [OutStgArg] +unariseLiteral_maybe (LitRubbish torc rep) + | [_] <- preps + = Nothing -- Single PrimRep. Nothing to do! + + | otherwise -- Multiple reps, or zero. Eliminate via elimCase + = Just [ StgLitArg (LitRubbish torc (primRepToRuntimeRep prep)) + | prep <- preps ] + where + preps = runtimeRepPrimRep (text "unariseLiteral_maybe") rep + +unariseLiteral_maybe _ = Nothing + +-------------------------------------------------------------------------------- + +elimCase :: UnariseEnv + -> [OutStgArg] -- non-void args + -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr + +elimCase rho args bndr (MultiValAlt _) [GenStgAlt{ alt_con = _ + , alt_bndrs = bndrs + , alt_rhs = rhs}] + = do let rho1 = extendRho rho bndr (MultiVal args) + (rho2, rhs') <- case () of + _ + | isUnboxedTupleBndr bndr + -> return (mapTupleIdBinders bndrs args rho1, rhs) + | otherwise + -> assert (isUnboxedSumBndr bndr) $ + case bndrs of + -- Sum with a void-type binder? + [] -> return (rho1, rhs) + [alt_bndr] -> mapSumIdBinders alt_bndr args rhs rho1 + _ -> pprPanic "mapSumIdBinders" (ppr bndrs $$ ppr args) + + unariseExpr rho2 rhs' + +elimCase rho args@(tag_arg : real_args) bndr (MultiValAlt _) alts + | isUnboxedSumBndr bndr + = do tag_bndr <- mkId (mkFastString "tag") tagTy + -- this won't be used but we need a binder anyway + let rho1 = extendRho rho bndr (MultiVal args) + scrut' = case tag_arg of + StgVarArg v -> StgApp v [] + StgLitArg l -> StgLit l + + alts' <- unariseSumAlts rho1 real_args alts + return (StgCase scrut' tag_bndr tagAltTy alts') + +elimCase _ args bndr alt_ty alts + = pprPanic "elimCase - unhandled case" + (ppr args <+> ppr bndr <+> ppr alt_ty $$ pprPanicAlts alts) + +-------------------------------------------------------------------------------- + +unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt] +unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con = DEFAULT + , alt_bndrs = [] + , alt_rhs = e}] + | isUnboxedTupleBndr bndr + = do (rho', ys) <- unariseConArgBinder rho bndr + !e' <- unariseExpr rho' e + return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys e'] + +unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con = DataAlt _ + , alt_bndrs = ys + , alt_rhs = e}] + | isUnboxedTupleBndr bndr + = do (rho', ys1) <- unariseConArgBinders rho ys + massert (ys1 `lengthIs` n) + let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1)) + !e' <- unariseExpr rho'' e + return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys1 e'] + +unariseAlts _ (MultiValAlt _) bndr alts + | isUnboxedTupleBndr bndr + = pprPanic "unariseExpr: strange multi val alts" (pprPanicAlts alts) + +-- In this case we don't need to scrutinize the tag bit +unariseAlts rho (MultiValAlt _) bndr [GenStgAlt{ alt_con = DEFAULT + , alt_bndrs = [] + , alt_rhs = rhs}] + | isUnboxedSumBndr bndr + = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr + rhs' <- unariseExpr rho_sum_bndrs rhs + return [GenStgAlt (DataAlt (tupleDataCon Unboxed (length sum_bndrs))) sum_bndrs rhs'] + +unariseAlts rho (MultiValAlt _) bndr alts + | isUnboxedSumBndr bndr + = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr + alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts + let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts' + return [GenStgAlt{ alt_con = DataAlt (tupleDataCon Unboxed (length scrt_bndrs)) + , alt_bndrs = scrt_bndrs + , alt_rhs = inner_case + }] + +unariseAlts rho _ _ alts + = mapM (\alt -> unariseAlt rho alt) alts + +unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt +unariseAlt rho alt@GenStgAlt{alt_con=_,alt_bndrs=xs,alt_rhs=e} + = do (rho', xs') <- unariseConArgBinders rho xs + !e' <- unariseExpr rho' e + return $! alt {alt_bndrs = xs', alt_rhs = e'} + +-------------------------------------------------------------------------------- + +-- | Make alternatives that match on the tag of a sum +-- (i.e. generate LitAlts for the tag) +unariseSumAlts :: UnariseEnv + -> [StgArg] -- sum components _excluding_ the tag bit. + -> [StgAlt] -- original alternative with sum LHS + -> UniqSM [StgAlt] +unariseSumAlts env args alts + = do alts' <- mapM (unariseSumAlt env args) alts + return (mkDefaultLitAlt alts') + +unariseSumAlt :: UnariseEnv + -> [StgArg] -- sum components _excluding_ the tag bit. + -> StgAlt -- original alternative with sum LHS + -> UniqSM StgAlt +unariseSumAlt rho _ GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=e} + = GenStgAlt DEFAULT mempty <$> unariseExpr rho e + +unariseSumAlt rho args alt@GenStgAlt{ alt_con = DataAlt sumCon + , alt_bndrs = bs + , alt_rhs = e + } + + = do (rho',e') <- case bs of + [b] -> mapSumIdBinders b args e rho + -- Sums must have one binder + _ -> pprPanic "unariseSumAlt2" (ppr args $$ pprPanicAlt alt) + let lit_case = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))) + GenStgAlt lit_case mempty <$> unariseExpr rho' e' + +unariseSumAlt _ scrt alt + = pprPanic "unariseSumAlt3" (ppr scrt $$ pprPanicAlt alt) + +-------------------------------------------------------------------------------- +-- Mapping binders when matching und a unboxed sum/tuple + +mapTupleIdBinders + :: [InId] -- Un-processed binders of a tuple alternative. + -- Can have void binders. + -> [OutStgArg] -- Arguments that form the tuple (after unarisation). + -- Can't have void args. + -> UnariseEnv + -> UnariseEnv +mapTupleIdBinders ids args0 rho0 + = assert (not (any (null . stgArgRep) args0)) $ + let + map_ids :: UnariseEnv -> [Id] -> [StgArg] -> UnariseEnv + map_ids rho [] _ = rho + map_ids rho (x : xs) args = + let + x_reps = typePrimRep (idType x) + x_arity = length x_reps + (x_args, args') = + assert (args `lengthAtLeast` x_arity) + splitAt x_arity args + + rho' + | x_arity == 1 + = assert (x_args `lengthIs` 1) + extendRho rho x (UnaryVal (head x_args)) + | otherwise + = extendRho rho x (MultiVal x_args) + in + map_ids rho' xs args' + in + map_ids rho0 ids args0 + +mapSumIdBinders + :: InId -- Binder (in the case alternative). + -> [OutStgArg] -- Arguments that form the sum (NOT including the tag). + -- Can't have void args. + -> InStgExpr + -> UnariseEnv + -> UniqSM (UnariseEnv, OutStgExpr) + +mapSumIdBinders alt_bndr args rhs rho0 + = assert (not (any (null . stgArgRep) args)) $ do + uss <- listSplitUniqSupply <$> getUniqueSupplyM + let + fld_reps = typePrimRep (idType alt_bndr) + + -- Slots representing the whole sum + arg_slots = map primRepSlot $ concatMap stgArgRep args + -- The slots representing the field of the sum we bind. + id_slots = map primRepSlot $ fld_reps + layout1 = layoutUbxSum arg_slots id_slots + + -- See Note [Casting slot arguments] + -- Most of the code here is just to make sure our binders are of the + -- right type. + -- Select only the args which contain parts of the current field. + id_arg_exprs = [ args !! i | i <- layout1 ] + id_vars = [v | StgVarArg v <- id_arg_exprs] + + typed_id_arg_input = assert (equalLength id_vars fld_reps) $ + zip3 id_vars fld_reps uss + + mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) + mkCastInput (id,rep,bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRepU $ idType id) rep + cst_opts = zip3 ops types $ uniqsFromSupply bndr_us + out_id = case cst_opts of + [] -> id + _ -> let (_,ty,uq) = last cst_opts + in mkCastVar uq ty + in (cst_opts,id,out_id) + + cast_inputs = map mkCastInput typed_id_arg_input + (rhs_with_casts,typed_ids) = mapAccumL cast_arg (\x->x) cast_inputs + where + cast_arg rhs_in (cast_ops,in_id,out_id) = + let rhs_out = castArgRename cast_ops (StgVarArg in_id) + in (rhs_in . rhs_out, out_id) + + typed_id_args = map StgVarArg typed_ids + + -- pprTrace "mapSumIdBinders" + -- (text "fld_reps" <+> ppr fld_reps $$ + -- text "id_args" <+> ppr id_arg_exprs $$ + -- text "rhs" <+> ppr rhs $$ + -- text "rhs_with_casts" <+> ppr rhs_with_casts + -- ) $ + if isMultiValBndr alt_bndr + then return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs) + else assert (typed_id_args `lengthIs` 1) $ + return (extendRho rho0 alt_bndr (UnaryVal (head typed_id_args)), rhs_with_casts rhs) + +-- Convert the argument to the given type, and wrap the conversion +-- around the given expression. Use the given Id as a name for the +-- converted value. +castArgRename :: [(PrimOp,Type,Unique)] -> StgArg -> StgExpr -> StgExpr +castArgRename ops in_arg rhs = + case ops of + [] -> rhs + ((op,ty,uq):rest_ops) -> + let out_id' = mkCastVar uq ty -- out_name `setIdUnique` uq `setIdType` ty + sub_cast = castArgRename rest_ops (StgVarArg out_id') + in mkCast in_arg op out_id' ty $ sub_cast rhs + +-- Construct a case binder used when casting sums, of a given type and unique. +mkCastVar :: Unique -> Type -> Id +mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty + +mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr +mkCast arg_in cast_op out_id out_ty in_rhs = + let r2 = typePrimRepU out_ty + scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_ty + alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} + alt_ty = PrimAlt r2 + in (StgCase scrut out_id alt_ty [alt]) + +-- | Build a unboxed sum term from arguments of an alternative. +-- +-- Example, for (# x | #) :: (# (# #) | Int #) we call +-- +-- mkUbxSum (# _ | #) [ [], [LiftedRep] ] [ voidPrimId ] +-- +-- which returns +-- +-- [ 1#, rubbish ] +-- +mkUbxSum + :: HasDebugCallStack + => DataCon -- Sum data con + -> [[PrimRep]] -- Representations of type arguments of the sum data con + -> [OutStgArg] -- Actual arguments of the alternative. + -> UniqSupply + -> ([OutStgArg] -- Final tuple arguments + ,(StgExpr->StgExpr) -- We might need to cast the args first + ) +mkUbxSum dc ty_args args0 us + = let + _ :| sum_slots = ubxSumRepType ty_args + -- drop tag slot + field_slots = (mapMaybe (repSlotTy . stgArgRep) args0) + tag = dataConTag dc + layout' = layoutUbxSum sum_slots field_slots + + tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag)) + arg_idxs = IM.fromList (zipEqual layout' args0) + + ((_idx,_idx_map,_us,wrapper),slot_args) + = assert (length arg_idxs <= length sum_slots ) $ + mapAccumL mkTupArg (0,arg_idxs,us,id) sum_slots + + mkTupArg :: (Int, IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr) + -> SlotTy + -> ((Int,IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr), StgArg) + mkTupArg (arg_idx, arg_map, us, wrapper) slot + | Just stg_arg <- IM.lookup arg_idx arg_map + = case castArg us slot stg_arg of + -- Slot and arg type mismatched, do a cast + Just (casted_arg,us',wrapper') -> + ( (arg_idx+1, arg_map, us', wrapper . wrapper') + , casted_arg) + -- Use the arg as-is + Nothing -> + ( (arg_idx+1, arg_map, us, wrapper) + , stg_arg) + -- Garbage slot, fill with rubbish + | otherwise + = ( (arg_idx+1, arg_map, us, wrapper) + , ubxSumRubbishArg slot) + + castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) + castArg us slot_ty arg + -- Cast the argument to the type of the slot if required + | slotPrimRep slot_ty /= stgArgRepU arg + , (ops,types) <- unzip $ getCasts (stgArgRepU arg) $ slotPrimRep slot_ty + , not . null $ ops + = let (us1,us2) = splitUniqSupply us + cast_uqs = uniqsFromSupply us1 + cast_opts = zip3 ops types cast_uqs + (_op,out_ty,out_uq) = last cast_opts + casts = castArgRename cast_opts arg :: StgExpr -> StgExpr + in Just (StgVarArg (mkCastVar out_uq out_ty),us2,casts) + -- No need for casting + | otherwise = Nothing + + tup_args = tag_arg : slot_args + in + -- pprTrace "mkUbxSum" ( + -- text "ty_args (slots)" <+> ppr ty_args $$ + -- text "args0" <+> ppr args0 $$ + -- text "wrapper" <+> + -- (ppr $ wrapper $ StgLit $ LitChar '_')) + (tup_args, wrapper) + + +-- | Return a rubbish value for the given slot type. +-- +-- We use the following rubbish values: +-- * Literals: 0 or 0.0 +-- * Pointers: `ghc-prim:GHC.Prim.Panic.absentSumFieldError` +-- +-- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make" +-- +ubxSumRubbishArg :: SlotTy -> StgArg +ubxSumRubbishArg PtrLiftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID +ubxSumRubbishArg PtrUnliftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID +ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0) +ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) +ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0) +ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) +ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish TypeLike vec_rep) + where vec_rep = primRepToRuntimeRep (VecRep n e) + +-------------------------------------------------------------------------------- + +{- +Note [Unarisation of Void binders and arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For arguments (StgArg) and binders (Id) we have two kind of unarisation: + + - When unarising function arg binders and arguments, we don't want to remove + void binders and arguments. For example, + + f :: (# (# #), (# #) #) -> Void# -> State# RealWorld -> ... + f x y z = + + Here after unarise we should still get a function with arity 3. Similarly + in the call site we shouldn't remove void arguments: + + f (# (# #), (# #) #) void# realWorld# + + When unarising , we extend the environment with these binders: + + x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal [] + + Because their rep types are `MultiRep []` (aka. void). This means that when + we see `x` in a function argument position, we actually replace it with a + void argument. When we see it in a DataCon argument position, we just get + rid of it, because DataCon applications in STG are always saturated. + + - When unarising case alternative binders we remove void binders, but we + still update the environment the same way, because those binders may be + used in the RHS. Example: + + case x of y { + (# x1, x2, x3 #) -> + } + + We know that y can't be void, because we don't scrutinize voids, so x will + be unarised to some number of arguments, and those arguments will have at + least one non-void thing. So in the rho we will have something like: + + x :-> MultiVal [xu1, xu2] + + Now, after we eliminate void binders in the pattern, we get exactly the same + number of binders, and extend rho again with these: + + x1 :-> UnaryVal xu1 + x2 :-> MultiVal [] -- x2 is void + x3 :-> UnaryVal xu2 + + Now when we see x2 in a function argument position or in return position, we + generate void#. In constructor argument position, we just remove it. + +So in short, when we have a void id, + + - We keep it if it's a lambda argument binder or + in argument position of an application. + + - We remove it if it's a DataCon field binder or + in argument position of a DataCon application. +-} + +unariseArgBinder + :: Bool -- data con arg? + -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) +unariseArgBinder is_con_arg rho x = + case typePrimRep (idType x) of + [] + | is_con_arg + -> return (extendRho rho x (MultiVal []), []) + | otherwise -- fun arg, do not remove void binders + -> return (extendRho rho x (MultiVal []), [voidArgId]) + + [rep] + -- Arg represented as single variable, but original type may still be an + -- unboxed sum/tuple, e.g. (# Void# | Void# #). + -- + -- While not unarising the binder in this case does not break any programs + -- (because it unarises to a single variable), it triggers StgLint as we + -- break the post-unarisation invariant that says unboxed tuple/sum + -- binders should vanish. See Note [Post-unarisation invariants]. + | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x) + -> do x' <- mkId (mkFastString "us") (primRepToType rep) + return (extendRho rho x (MultiVal [StgVarArg x']), [x']) + | otherwise + -> return (extendRhoWithoutValue rho x, [x]) + + reps -> do + xs <- mkIds (mkFastString "us") (map primRepToType reps) + return (extendRho rho x (MultiVal (map StgVarArg xs)), xs) + +-------------------------------------------------------------------------------- + +-- | MultiVal a function argument. Never returns an empty list. +unariseFunArg :: UnariseEnv -> StgArg -> [StgArg] +unariseFunArg rho (StgVarArg x) = + case lookupRho rho x of + Just (MultiVal []) -> [voidArg] -- NB: do not remove void args + Just (MultiVal as) -> as + Just (UnaryVal arg) -> [arg] + Nothing -> [StgVarArg x] +unariseFunArg _ arg@(StgLitArg lit) = case unariseLiteral_maybe lit of + -- forgetting to unariseLiteral_maybe here caused #23914 + Just [] -> [voidArg] + Just as -> as + Nothing -> [arg] + +unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg] +unariseFunArgs = concatMap . unariseFunArg + +unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id]) +unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs + +-- Result list of binders is never empty +unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) +unariseFunArgBinder = unariseArgBinder False + +-------------------------------------------------------------------------------- + +-- | MultiVal a DataCon argument. Returns an empty list when argument is void. +unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg] +unariseConArg rho (StgVarArg x) = + case lookupRho rho x of + Just (UnaryVal arg) -> [arg] + Just (MultiVal as) -> as -- 'as' can be empty + Nothing + | isZeroBitTy (idType x) -> [] -- e.g. C realWorld# + -- Here realWorld# is not in the envt, but + -- is a void, and so should be eliminated + | otherwise -> [StgVarArg x] +unariseConArg _ arg@(StgLitArg lit) + | Just as <- unariseLiteral_maybe lit + = as + | otherwise + = assert (isNvUnaryRep (typePrimRep (literalType lit))) -- We have no non-rubbish non-unary literals + [arg] + +unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg] +unariseConArgs = concatMap . unariseConArg + +unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id]) +unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs + +-- Different from `unariseFunArgBinder`: result list of binders may be empty. +-- See DataCon applications case in Note [Post-unarisation invariants]. +unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) +unariseConArgBinder = unariseArgBinder True + +-------------------------------------------------------------------------------- + +mkIds :: FastString -> [NvUnaryType] -> UniqSM [Id] +mkIds fs tys = mkUnarisedIds fs tys + +mkId :: FastString -> NvUnaryType -> UniqSM Id +mkId s t = mkUnarisedId s t + +isMultiValBndr :: Id -> Bool +isMultiValBndr id + | [_] <- typePrimRep (idType id) + = False + | otherwise + = True + +isUnboxedSumBndr :: Id -> Bool +isUnboxedSumBndr = isUnboxedSumType . idType + +isUnboxedTupleBndr :: Id -> Bool +isUnboxedTupleBndr = isUnboxedTupleType . idType + +mkTuple :: [StgArg] -> StgExpr +mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args [] + +tagAltTy :: AltType +tagAltTy = PrimAlt IntRep + +tagTy :: Type +tagTy = intPrimTy + +voidArg :: StgArg +voidArg = StgVarArg voidPrimId + +mkDefaultLitAlt :: [StgAlt] -> [StgAlt] +-- We have an exhaustive list of literal alternatives +-- 1# -> e1 +-- 2# -> e2 +-- Since they are exhaustive, we can replace one with DEFAULT, to avoid +-- generating a final test. Remember, the DEFAULT comes first if it exists. +mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts") +mkDefaultLitAlt alts@(GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=_} : _) = alts +mkDefaultLitAlt (alt@GenStgAlt{alt_con=LitAlt{}, alt_bndrs=[]} : alts) = alt {alt_con = DEFAULT} : alts +mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> pprPanicAlts alts) + +pprPanicAlts :: OutputablePass pass => [GenStgAlt pass] -> SDoc +pprPanicAlts alts = ppr (map pprPanicAlt alts) + +pprPanicAlt :: OutputablePass pass => GenStgAlt pass -> SDoc +pprPanicAlt GenStgAlt{alt_con=c,alt_bndrs=b,alt_rhs=e} = ppr (c,b,pprStgExpr panicStgPprOpts e) diff --git a/GHC/Stg/Utils.hs b/GHC/Stg/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Utils.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +module GHC.Stg.Utils + ( mkStgAltTypeFromStgAlts + , bindersOf, bindersOfX, bindersOfTop, bindersOfTopBinds + + , stripStgTicksTop, stripStgTicksTopE + , idArgs + + , mkUnarisedId, mkUnarisedIds + + , allowTopLevelConApp + ) where + +import GHC.Prelude +import GHC.Platform + +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.Types.Name ( isDynLinkName ) +import GHC.Unit.Module ( Module ) +import GHC.Stg.Syntax + +import GHC.Utils.Outputable + +import GHC.Utils.Panic + +import GHC.Data.FastString + +mkUnarisedIds :: MonadUnique m => FastString -> [NvUnaryType] -> m [Id] +mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys + +mkUnarisedId :: MonadUnique m => FastString -> NvUnaryType -> m Id +mkUnarisedId s t = mkSysLocalM s ManyTy t + +-- Checks if id is a top level error application. +-- isErrorAp_maybe :: Id -> + +-- | Extract the default case alternative +-- findDefaultStg :: [Alt b] -> ([Alt b], Maybe (Expr b)) +findDefaultStg + :: [GenStgAlt p] + -> ([GenStgAlt p], Maybe (GenStgExpr p)) +findDefaultStg (GenStgAlt{ alt_con = DEFAULT + , alt_bndrs = args + , alt_rhs = rhs} : alts) = assert( null args ) (alts, Just rhs) +findDefaultStg alts = (alts, Nothing) + +mkStgAltTypeFromStgAlts :: forall p. Id -> [GenStgAlt p] -> AltType +mkStgAltTypeFromStgAlts bndr alts + | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty + = MultiValAlt (length prim_reps) -- always use MultiValAlt for unboxed tuples + + | otherwise + = case prim_reps of + [rep] | isGcPtrRep rep -> + case tyConAppTyCon_maybe (unwrapType bndr_ty) of + Just tc + | isAbstractTyCon tc -> look_for_better_tycon + | isAlgTyCon tc -> AlgAlt tc + | otherwise -> assertPpr ( _is_poly_alt_tycon tc) (ppr tc) + PolyAlt + Nothing -> PolyAlt + [non_gcd] -> PrimAlt non_gcd + not_unary -> MultiValAlt (length not_unary) + where + bndr_ty = idType bndr + prim_reps = typePrimRep bndr_ty + + _is_poly_alt_tycon tc + = isPrimTyCon tc -- "Any" is lifted but primitive + || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict + -- function application where argument has a + -- type-family type + + -- Sometimes, the TyCon is a AbstractTyCon which may not have any + -- constructors inside it. Then we may get a better TyCon by + -- grabbing the one from a constructor alternative + -- if one exists. + look_for_better_tycon + | (DataAlt con : _) <- alt_con <$> data_alts = + AlgAlt (dataConTyCon con) + | otherwise = + assert(null data_alts) + PolyAlt + where + (data_alts, _deflt) = findDefaultStg alts + +bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id] +bindersOf (StgNonRec binder _) = [binder] +bindersOf (StgRec pairs) = [binder | (binder, _) <- pairs] + +bindersOfX :: GenStgBinding a -> [BinderP a] +bindersOfX (StgNonRec binder _) = [binder] +bindersOfX (StgRec pairs) = [binder | (binder, _) <- pairs] + +bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id] +bindersOfTop (StgTopLifted bind) = bindersOf bind +bindersOfTop (StgTopStringLit binder _) = [binder] + +-- All ids we bind something to on the top level. +bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id] +-- bindersOfTopBinds binds = mapUnionVarSet (mkVarSet . bindersOfTop) binds +bindersOfTopBinds binds = foldr ((++) . bindersOfTop) [] binds + +idArgs :: [StgArg] -> [Id] +idArgs args = [v | StgVarArg v <- args] + +-- | Strip ticks of a given type from an STG expression. +stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p) +stripStgTicksTop p = go [] + where go ts (StgTick t e) | p t = go (t:ts) e + -- This special case avoid building a thunk for "reverse ts" when there are no ticks + go [] other = ([], other) + go ts other = (reverse ts, other) + +-- | Strip ticks of a given type from an STG expression returning only the expression. +stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p +stripStgTicksTopE p = go + where go (StgTick t e) | p t = go e + go other = other + +-- | Do we allow the given top-level (static) ConApp? +allowTopLevelConApp + :: Platform + -> Bool -- is Opt_ExternalDynamicRefs enabled? + -> Module + -> DataCon + -> [StgArg] + -> Bool +allowTopLevelConApp platform ext_dyn_refs this_mod con args + -- we're not using dynamic linking + | not ext_dyn_refs = True + -- if the target OS is Windows, we only allow top-level ConApps if they don't + -- reference external names (Windows DLLs have a problem with static cross-DLL + -- refs) + | platformOS platform == OSMinGW32 = not is_external_con_app + -- otherwise, allowed + -- Sylvain: shouldn't this be False when (ext_dyn_refs && is_external_con_app)? + | otherwise = True + where + is_external_con_app = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args + + -- NB: typePrimRep1 is legit because any free variables won't have + -- unlifted type (there are no unlifted things at top level) + is_dll_arg :: StgArg -> Bool + is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v)) + && isDynLinkName platform this_mod (idName v) + is_dll_arg _ = False + +-- True of machine addresses; these are the things that don't work across DLLs. +-- The key point here is that VoidRep comes out False, so that a top level +-- nullary GADT constructor is True for allowTopLevelConApp +-- +-- data T a where +-- T1 :: T Int +-- +-- gives +-- +-- T1 :: forall a. (a~Int) -> T a +-- +-- and hence the top-level binding +-- +-- $WT1 :: T Int +-- $WT1 = T1 Int (Coercion (Refl Int)) +-- +-- The coercion argument here gets VoidRep +isAddrRep :: PrimOrVoidRep -> Bool +isAddrRep (NVRep AddrRep) = True +isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript +isAddrRep _ = False + diff --git a/GHC/StgToByteCode.hs b/GHC/StgToByteCode.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToByteCode.hs @@ -0,0 +1,2776 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | GHC.StgToByteCode: Generate bytecode from STG +module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Driver.Env + +import GHC.ByteCode.Instr +import GHC.ByteCode.Asm +import GHC.ByteCode.Types + +import GHC.Cmm.CallConv +import GHC.Cmm.Expr +import GHC.Cmm.Reg ( GlobalArgRegs(..) ) +import GHC.Cmm.Node +import GHC.Cmm.Utils + +import GHC.Platform +import GHC.Platform.Profile + +import GHCi.FFI +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.ForeignCall +import GHC.Core +import GHC.Types.Literal +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids (primOpId) +import GHC.Core.Type +import GHC.Core.Predicate( tyCoVarsOfTypesWellScoped ) +import GHC.Core.TyCo.Compare (eqType) +import GHC.Types.RepType +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Utils.Misc +import GHC.Utils.Logger +import GHC.Types.Var.Set +import GHC.Builtin.Types.Prim +import GHC.Core.TyCo.Ppr ( pprType ) +import GHC.Utils.Error +import GHC.Builtin.Uniques +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Utils.Exception (evaluate) +import GHC.CmmToAsm.Config (platformWordWidth) +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, + addIdReps, addArgReps, + assertNonVoidIds, assertNonVoidStgArgs ) +import GHC.StgToCmm.Layout +import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) +import GHC.Runtime.Interpreter ( interpreterProfiled ) +import GHC.Data.Bitmap +import GHC.Data.FlatBag as FlatBag +import GHC.Data.OrdList +import GHC.Data.Maybe +import GHC.Types.Tickish +import GHC.Types.SptEntry +import GHC.ByteCode.Breakpoints + +import Data.List ( genericReplicate, intersperse + , partition, scanl', sortBy, zip4, zip6 ) +import Foreign hiding (shiftL, shiftR) +import Control.Monad +import Data.Char + +import GHC.Unit.Module + +import Data.Coerce (coerce) +#if MIN_VERSION_rts(1,0,3) +import qualified Data.ByteString.Char8 as BS +#endif +import Data.Map (Map) +import Data.IntMap (IntMap) +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified GHC.Data.FiniteMap as Map +import Data.Ord +import Data.Either ( partitionEithers ) + +import GHC.Stg.Syntax +import qualified Data.IntSet as IntSet +import GHC.CoreToIface + +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.State (StateT(..)) +import Data.Bifunctor (Bifunctor(..)) + +-- ----------------------------------------------------------------------------- +-- Generating byte code for a complete module + +byteCodeGen :: HscEnv + -> Module + -> [CgStgTopBinding] + -> [TyCon] + -> Maybe ModBreaks + -> [SptEntry] + -> IO CompiledByteCode +byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries + = withTiming logger + (text "GHC.StgToByteCode"<+>brackets (ppr this_mod)) + (const ()) $ do + -- Split top-level binds into strings and others. + -- See Note [Generating code for top-level string literal bindings]. + let (strings, lifted_binds) = partitionEithers $ do -- list monad + bnd <- binds + case bnd of + StgTopLifted bnd -> [Right bnd] + StgTopStringLit b str -> [Left (getName b, str)] + flattenBind (StgNonRec b e) = [(b,e)] + flattenBind (StgRec bs) = bs + + (proto_bcos, BcM_State{..}) <- + runBc hsc_env this_mod mb_modBreaks $ do + let flattened_binds = concatMap flattenBind (reverse lifted_binds) + FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds + + putDumpFileMaybe logger Opt_D_dump_BCOs + "Proto-BCOs" FormatByteCode + (vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos))) + + let mod_breaks = case mb_modBreaks of + Nothing -> Nothing + Just mb -> Just $ mkInternalModBreaks this_mod breakInfo mb + cbc <- assembleBCOs profile proto_bcos tycs strings mod_breaks spt_entries + + -- Squash space leaks in the CompiledByteCode. This is really + -- important, because when loading a set of modules into GHCi + -- we don't touch the CompiledByteCode until the end when we + -- do linking. Forcing out the thunks here reduces space + -- usage by more than 50% when loading a large number of + -- modules. + evaluate (seqCompiledByteCode cbc) + + return cbc + + where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + profile = targetProfile dflags + +{- Note [Generating code for top-level string literal bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Compilation plan for top-level string literals] +in GHC.Core, the core-to-core optimizer can introduce top-level Addr# +bindings to represent string literals. The creates two challenges for +the bytecode compiler: (1) compiling the bindings themselves, and +(2) compiling references to such bindings. Here is a summary on how +we deal with them: + + 1. Top-level string literal bindings are separated from the rest of + the module. Memory is not allocated until bytecode link-time, the + bc_strs field of the CompiledByteCode result records [(Name, ByteString)] + directly. + + 2. When we encounter a reference to a top-level string literal, we + generate a PUSH_ADDR pseudo-instruction, which is assembled to + a PUSH_UBX instruction with a BCONPtrAddr argument. + + 3. The loader accumulates string literal bindings from loaded + bytecode in the addr_env field of the LinkerEnv. + + 4. The BCO linker resolves BCONPtrAddr references by searching both + the addr_env (to find literals defined in bytecode) and the native + symbol table (to find literals defined in native code). + +This strategy works alright, but it does have one significant problem: +we never free the memory that we allocate for the top-level strings. +In theory, we could explicitly free it when BCOs are unloaded, but +this comes with its own complications; see #22400 for why. For now, +we just accept the leak, but it would nice to find something better. -} + +-- ----------------------------------------------------------------------------- +-- Compilation schema for the bytecode generator + +type BCInstrList = OrdList BCInstr + +wordsToBytes :: Platform -> WordOff -> ByteOff +wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral + +-- Used when we know we have a whole number of words +bytesToWords :: Platform -> ByteOff -> WordOff +bytesToWords platform (ByteOff bytes) = + let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform) + in if r == 0 + then fromIntegral q + else pprPanic "GHC.StgToByteCode.bytesToWords" + (text "bytes=" <> ppr bytes) + +wordSize :: Platform -> ByteOff +wordSize platform = ByteOff (platformWordSizeInBytes platform) + +type Sequel = ByteOff -- back off to this depth before ENTER + +type StackDepth = ByteOff + +-- | Maps Ids to their stack depth. This allows us to avoid having to mess with +-- it after each push/pop. +type BCEnv = Map Id StackDepth -- To find vars on the stack + +{- +ppBCEnv :: BCEnv -> SDoc +ppBCEnv p + = text "begin-env" + $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p)))) + $$ text "end-env" + where + pp_one (var, ByteOff offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgReps var) + cmp_snd x y = compare (snd x) (snd y) +-} + +-- Create a BCO and do a spot of peephole optimisation on the insns +-- at the same time. +mkProtoBCO + :: + Platform + -> Maybe Module + -- ^ Just cur_mod <=> label with @BCO_NAME@ instruction + -- see Note [BCO_NAME] + -> Name + -> BCInstrList + -> Either [CgStgAlt] (CgStgRhs) + -- ^ original expression; for debugging only + -> Int -- ^ arity + -> WordOff -- ^ bitmap size + -> [StgWord] -- ^ bitmap + -> Bool -- ^ True <=> it's a case continuation, rather than a function + -- See also Note [Case continuation BCOs]. + -> ProtoBCO Name +mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret + = ProtoBCO { + protoBCOName = nm, + protoBCOInstrs = maybe_add_bco_name $ maybe_add_stack_check peep_d, + protoBCOBitmap = bitmap, + protoBCOBitmapSize = fromIntegral bitmap_size, + protoBCOArity = arity, + protoBCOExpr = origin + } + where +#if MIN_VERSION_rts(1,0,3) + maybe_add_bco_name instrs + | Just cur_mod <- _add_bco_name = + let str = BS.pack $ showSDocOneLine defaultSDocContext (pprFullNameWithUnique cur_mod nm) + in BCO_NAME str : instrs +#endif + maybe_add_bco_name instrs = instrs + + -- Overestimate the stack usage (in words) of this BCO, + -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit + -- stack check. (The interpreter always does a stack check + -- for iNTERP_STACK_CHECK_THRESH words at the start of each + -- BCO anyway, so we only need to add an explicit one in the + -- (hopefully rare) cases when the (overestimated) stack use + -- exceeds iNTERP_STACK_CHECK_THRESH. + maybe_add_stack_check instrs + | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = instrs + -- don't do stack checks at return points, + -- everything is aggregated up to the top BCO + -- (which must be a function). + -- That is, unless the stack usage is >= AP_STACK_SPLIM, + -- see bug #1466. + | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH + = STKCHECK stack_usage : instrs + | otherwise + = instrs -- the supposedly common case + + -- We assume that this sum doesn't wrap + stack_usage = sum (map bciStackUse peep_d) + + -- Merge local pushes + peep_d = peep (fromOL instrs_ordlist) + + peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest) + = PUSH_LLL off1 (off2-1) (off3-2) : peep rest + peep (PUSH_L off1 : PUSH_L off2 : rest) + = PUSH_LL off1 (off2-1) : peep rest + peep (i:rest) + = i : peep rest + peep [] + = [] + +argBits :: Platform -> [ArgRep] -> [Bool] +argBits _ [] = [] +argBits platform (rep : args) + | isFollowableArg rep = False : argBits platform args + | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args + +-- ----------------------------------------------------------------------------- +-- schemeTopBind + +-- Compile code for the right-hand side of a top-level binding + +schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name) +schemeTopBind (id, rhs) + | Just data_con <- isDataConWorkId_maybe id, + isNullaryRepDataCon data_con = do + platform <- profilePlatform <$> getProfile + add_bco_name <- shouldAddBcoName + -- Special case for the worker of a nullary data con. + -- It'll look like this: Nil = /\a -> Nil a + -- If we feed it into schemeR, we'll get + -- Nil = Nil + -- because mkConAppCode treats nullary constructor applications + -- by just re-using the single top-level definition. So + -- for the worker itself, we must allocate it directly. + -- liftIO (putStrLn $ "top level BCO") + pure (mkProtoBCO platform add_bco_name + (getName id) (toOL [PACK data_con 0, RETURN P]) + (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) + + | otherwise + = schemeR [{- No free variables -}] (getName id, rhs) + + +-- ----------------------------------------------------------------------------- +-- schemeR + +-- Compile code for a right-hand side, to give a BCO that, +-- when executed with the free variables and arguments on top of the stack, +-- will return with a pointer to the result on top of the stack, after +-- removing the free variables and arguments. +-- +-- Park the resulting BCO in the monad. Also requires the +-- name of the variable to which this value was bound, +-- so as to give the resulting BCO a name. +-- +-- The resulting ProtoBCO expects the free variables and the function arguments +-- to be in the stack frame directly before it. +schemeR :: [Id] -- Free vars of the RHS, ordered as they + -- will appear in the thunk. Empty for + -- top-level things, which have no free vars. + -> (Name, CgStgRhs) + -> BcM (ProtoBCO Name) +schemeR fvs (nm, rhs) + = schemeR_wrk fvs nm rhs (collect rhs) + +-- If an expression is a lambda, return the +-- list of arguments to the lambda (in R-to-L order) and the +-- underlying expression + +collect :: CgStgRhs -> ([Var], CgStgExpr) +collect (StgRhsClosure _ _ _ args body _) = (args, body) +collect (StgRhsCon _cc dc cnum _ticks args _typ) = ([], StgConApp dc cnum args []) + +schemeR_wrk + :: [Id] + -> Name + -> CgStgRhs -- expression e, for debugging only + -> ([Var], CgStgExpr) -- result of collect on e + -> BcM (ProtoBCO Name) +schemeR_wrk fvs nm original_body (args, body) + = do + add_bco_name <- shouldAddBcoName + profile <- getProfile + let + platform = profilePlatform profile + all_args = reverse args ++ fvs + arity = length all_args + -- all_args are the args in reverse order. We're compiling a function + -- \fv1..fvn x1..xn -> e + -- i.e. the fvs come first + + -- Stack arguments always take a whole number of words, we never pack + -- them unlike constructor fields. + szsb_args = map (wordsToBytes platform . idSizeW platform) all_args + sum_szsb_args = sum szsb_args + -- Make a stack offset for each argument or free var -- they should + -- appear contiguous in the stack, in order. + p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) + + -- make the arg bitmap + bits = argBits platform (reverse (map (idArgRep platform) all_args)) + bitmap_size = strictGenericLength bits + bitmap = mkBitmap platform bits + body_code <- schemeER_wrk sum_szsb_args p_init body + + pure (mkProtoBCO platform add_bco_name nm body_code (Right original_body) + arity bitmap_size bitmap False{-not alts-}) + +-- | Introduce break instructions for ticked expressions. +-- If no breakpoint information is available, the instruction is omitted. +schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList +schemeER_wrk d p (StgTick bp@(Breakpoint tick_ty tick_id fvs) rhs) = do + platform <- profilePlatform <$> getProfile + + -- When we find a tick we update the "last breakpoint location". + -- We use it when constructing step-out BRK_FUNs in doCase + -- See Note [Debugger: Stepout internal break locs] + code <- withBreakTick bp $ schemeE d 0 p rhs + + -- As per Note [Stack layout when entering run_BCO], the breakpoint AP_STACK + -- as we yield from the interpreter is headed by a stg_apply_interp + BCO to be a valid stack. + -- Therefore, the var offsets are offset by 2 words + let idOffSets = map (fmap (second (+2))) $ + getVarOffSets platform d p fvs + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty + (Right tick_id) + + mibi <- newBreakInfo breakInfo + + return $ case mibi of + Nothing -> code + Just ibi -> BRK_FUN ibi `consOL` code + +schemeER_wrk d p rhs = schemeE d 0 p rhs + +-- | Get the offset in words into this breakpoint's AP_STACK which contains the matching Id +getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)] +getVarOffSets platform depth env = map getOffSet + where + getOffSet id = case lookupBCEnv_maybe id env of + Nothing -> Nothing + Just offset -> + let !var_depth_ws = bytesToWords platform (depth - offset) + in Just (id, var_depth_ws) + +fvsToEnv :: BCEnv -> CgStgRhs -> [Id] +-- Takes the free variables of a right-hand side, and +-- delivers an ordered list of the local variables that will +-- be captured in the thunk for the RHS +-- The BCEnv argument tells which variables are in the local +-- environment: these are the ones that should be captured +-- +-- The code that constructs the thunk, and the code that executes +-- it, have to agree about this layout + +fvsToEnv p rhs = [v | v <- dVarSetElems $ freeVarsOfRhs rhs, + v `Map.member` p] + +-- ----------------------------------------------------------------------------- +-- schemeE + +-- Returning an unlifted value. +-- Heave it on the stack, SLIDE, and RETURN. +returnUnliftedAtom + :: StackDepth + -> Sequel + -> BCEnv + -> StgArg + -> BcM BCInstrList +returnUnliftedAtom d s p e = do + let reps = stgArgRep e + (push, szb) <- pushAtom d p e + ret <- returnUnliftedReps d s szb reps + return (push `appOL` ret) + +-- return an unlifted value from the top of the stack +returnUnliftedReps + :: StackDepth + -> Sequel + -> ByteOff -- size of the thing we're returning + -> [PrimRep] -- representations + -> BcM BCInstrList +returnUnliftedReps d s szb reps = do + profile <- getProfile + let platform = profilePlatform profile + ret <- case reps of + -- use RETURN for nullary/unary representations + [] -> return (unitOL $ RETURN V) + [rep] -> return (unitOL $ RETURN (toArgRep platform rep)) + -- otherwise use RETURN_TUPLE with a tuple descriptor + nv_reps -> do + let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 id nv_reps + tuple_bco = tupleBCO platform call_info args_offsets + return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL` + PUSH_BCO tuple_bco `consOL` + unitOL RETURN_TUPLE + return ( mkSlideB platform szb (d - s) -- clear to sequel + `appOL` ret) -- go + +-- construct and return an unboxed tuple +returnUnboxedTuple + :: StackDepth + -> Sequel + -> BCEnv + -> [StgArg] + -> BcM BCInstrList +returnUnboxedTuple d s p es = do + profile <- getProfile + let platform = profilePlatform profile + (call_info, tuple_components) = layoutNativeCall profile + NativeTupleReturn + d + stgArgRepU + es + go _ pushes [] = return (reverse pushes) + go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a + massert (off == dd + szb) + go (dd + szb) (push:pushes) cs + pushes <- go d [] tuple_components + + ret <- returnUnliftedReps d + s + (wordsToBytes platform $ nativeCallSize call_info) + (map stgArgRepU es) + return (mconcat pushes `appOL` ret) + +-- Compile code to apply the given expression to the remaining args +-- on the stack, returning a HNF. +schemeE :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList +schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) +schemeE d s p (StgApp x []) + | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x) +-- Delegate tail-calls to schemeT. +schemeE d s p e@(StgApp {}) = schemeT d s p e +schemeE d s p e@(StgConApp {}) = schemeT d s p e +schemeE d s p e@(StgOpApp {}) = schemeT d s p e +schemeE d s p (StgLetNoEscape xlet bnd body) + = schemeE d s p (StgLet xlet bnd body) +schemeE d s p (StgLet _xlet + (StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args _typ)) + body) + = do -- Special case for a non-recursive let whose RHS is a + -- saturated constructor application. + -- Just allocate the constructor and carry on + alloc_code <- mkConAppCode d s p data_con args + platform <- targetPlatform <$> getDynFlags + let !d2 = d + wordSize platform + body_code <- schemeE d2 s (Map.insert x d2 p) body + return (alloc_code `appOL` body_code) +-- General case for let. Generates correct, if inefficient, code in +-- all situations. +schemeE d s p (StgLet _ext binds body) = do + platform <- targetPlatform <$> getDynFlags + let (xs,rhss) = case binds of StgNonRec x rhs -> ([x],[rhs]) + StgRec xs_n_rhss -> unzip xs_n_rhss + n_binds = strictGenericLength xs + + fvss = map (fvsToEnv p') rhss + + -- Sizes of free vars + size_w = idSizeW platform + sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss + + -- the arity of each rhs + arities = map (strictGenericLength . fst . collect) rhss + + -- This p', d' defn is safe because all the items being pushed + -- are ptrs, so all have size 1 word. d' and p' reflect the stack + -- after the closures have been allocated in the heap (but not + -- filled in), and pointers to them parked on the stack. + offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform)) + p' = Map.insertList (zipEqual xs offsets) p + d' = d + wordsToBytes platform n_binds + + -- ToDo: don't build thunks for things with no free variables + build_thunk + :: StackDepth + -> [Id] + -> WordOff + -> ProtoBCO Name + -> WordOff + -> HalfWord + -> BcM BCInstrList + build_thunk _ [] size bco off arity + = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) (fromIntegral size))) + where + mkap | arity == 0 = MKAP + | otherwise = MKPAP + build_thunk dd (fv:fvs) size bco off arity = do + (push_code, pushed_szb) <- pushAtom dd p' (StgVarArg fv) + more_push_code <- + build_thunk (dd + pushed_szb) fvs size bco off arity + return (push_code `appOL` more_push_code) + + alloc_code = toOL (zipWith mkAlloc sizes arities) + where mkAlloc sz 0 + | is_tick = ALLOC_AP_NOUPD (fromIntegral sz) + | otherwise = ALLOC_AP (fromIntegral sz) + mkAlloc sz arity = ALLOC_PAP arity (fromIntegral sz) + + is_tick = case binds of + StgNonRec id _ -> occNameFS (getOccName id) == tickFS + _other -> False + + compile_bind d' fvs x (rhs::CgStgRhs) size arity off = do + bco <- schemeR fvs (getName x,rhs) + build_thunk d' fvs size bco off arity + + compile_binds = + [ compile_bind d' fvs x rhs size arity n + | (fvs, x, rhs, size, arity, n) <- + zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] + ] + body_code <- schemeE d' s p' body + thunk_codes <- sequence compile_binds + return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) + +schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs) + = pprPanic "schemeE: Breakpoint without let binding:" + (ppr bp_id <+> text "forgot to run bcPrep?") + +-- ignore other kinds of tick +schemeE d s p (StgTick _ rhs) = schemeE d s p rhs + +-- no alts: scrut is guaranteed to diverge +schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut + +schemeE d s p (StgCase scrut bndr _ alts) + = doCase d s p scrut bndr alts + + +{- + Ticked Expressions + ------------------ + + The idea is that the "breakpoint E" is really just an annotation on + the code. When we find such a thing, we pull out the useful information, + and then compile the code as if it was just the expression E. +-} + +-- Compile code to do a tail call. Specifically, push the fn, +-- slide the on-stack app back down to the sequel depth, +-- and enter. Four cases: +-- +-- 0. (Nasty hack). +-- An application "GHC.Prim.tagToEnum# unboxed-int". +-- The int will be on the stack. Generate a code sequence +-- to convert it to the relevant constructor, SLIDE and ENTER. +-- +-- 1. The fn denotes a ccall. Defer to generateCCall. +-- +-- 2. An unboxed tuple: push the components on the top of +-- the stack and return. +-- +-- 3. Application of a constructor, by defn saturated. +-- Split the args into ptrs and non-ptrs, and push the nonptrs, +-- then the ptrs, and then do PACK and RETURN. +-- +-- 4. Otherwise, it must be a function call. Push the args +-- right to left, SLIDE and ENTER. + +schemeT :: StackDepth -- Stack depth + -> Sequel -- Sequel depth + -> BCEnv -- stack env + -> CgStgExpr + -> BcM BCInstrList + + -- Case 0 +schemeT d s p app + | Just (arg, constr_names) <- maybe_is_tagToEnum_call app + = implement_tagToId d s p arg constr_names + + -- Case 1 +schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty) + = if isSupportedCConv ccall_spec + then generateCCall d s p ccall_spec result_ty args + else unsupportedCConvException + +schemeT d s p (StgOpApp (StgPrimOp op) args _ty) = do + profile <- getProfile + let platform = profilePlatform profile + case doPrimOp platform op d s p args of + -- Can we do this right in the interpreter? + Just prim_code -> prim_code + -- Otherwise we have to do a call to the primop wrapper instead :( + _ -> doTailCall d s p (primOpId op) (reverse args) + +schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty) + = generatePrimCall d s p label (Just unit) result_ty args + +schemeT d s p (StgConApp con _cn args _tys) + -- Case 2: Unboxed tuple + | isUnboxedTupleDataCon con || isUnboxedSumDataCon con + = returnUnboxedTuple d s p args + + -- Case 3: Ordinary data constructor + | otherwise + = do alloc_con <- mkConAppCode d s p con args + platform <- profilePlatform <$> getProfile + return (alloc_con `appOL` + mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN P) + + -- Case 4: Tail call of function +schemeT d s p (StgApp fn args) + = doTailCall d s p fn (reverse args) + +schemeT _ _ _ e = pprPanic "GHC.StgToByteCode.schemeT" + (pprStgExpr shortStgPprOpts e) + +-- ----------------------------------------------------------------------------- +-- Generate code to build a constructor application, +-- leaving it on top of the stack + +mkConAppCode + :: StackDepth + -> Sequel + -> BCEnv + -> DataCon -- The data constructor + -> [StgArg] -- Args, in *reverse* order + -> BcM BCInstrList +mkConAppCode orig_d _ p con args = app_code + where + app_code = do + profile <- getProfile + let platform = profilePlatform profile + + non_voids = + addArgReps (assertNonVoidStgArgs args) + (_, _, args_offsets) = + mkVirtHeapOffsetsWithPadding profile StdHeader non_voids + + do_pushery !d (arg : args) = do + (push, arg_bytes) <- case arg of + (Padding l _) -> return $! pushPadding (ByteOff l) + (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a) + more_push_code <- do_pushery (d + arg_bytes) args + return (push `appOL` more_push_code) + do_pushery !d [] = do + let !n_arg_words = bytesToWords platform (d - orig_d) + return (unitOL (PACK con n_arg_words)) + + -- Push on the stack in the reverse order. + do_pushery orig_d (reverse args_offsets) + +-- ----------------------------------------------------------------------------- +-- Generate code for a tail-call + +doTailCall + :: StackDepth + -> Sequel + -> BCEnv + -> Id + -> [StgArg] + -> BcM BCInstrList +doTailCall init_d s p fn args = do + platform <- profilePlatform <$> getProfile + + -- Do tail call only after + do_pushes init_d args (map (atomRep platform) args) + + where + do_pushes !d [] reps = do + assert (null reps) return () + (push_fn, sz) <- pushAtom d p (StgVarArg fn) + platform <- profilePlatform <$> getProfile + assert (sz == wordSize platform) return () + let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s) + return (push_fn `appOL` (slide `appOL` unitOL ENTER)) + do_pushes !d args reps = do + let (push_apply, n, rest_of_reps) = findPushSeq reps + (these_args, rest_of_args) = splitAt n args + (next_d, push_code) <- push_seq d these_args + platform <- profilePlatform <$> getProfile + instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps + -- ^^^ for the PUSH_APPLY_ instruction + return (push_code `appOL` (push_apply `consOL` instrs)) + + push_seq d [] = return (d, nilOL) + push_seq d (arg:args) = do + (push_code, sz) <- pushAtom d p arg + (final_d, more_push_code) <- push_seq (d + sz) args + return (final_d, push_code `appOL` more_push_code) + +doPrimOp :: Platform + -> PrimOp + -> StackDepth + -> Sequel + -> BCEnv + -> [StgArg] + -> Maybe (BcM BCInstrList) +doPrimOp platform op init_d s p args = + case op of + IntAddOp -> sizedPrimOp OP_ADD + Int64AddOp -> only64bit $ sizedPrimOp OP_ADD + Int32AddOp -> sizedPrimOp OP_ADD + Int16AddOp -> sizedPrimOp OP_ADD + Int8AddOp -> sizedPrimOp OP_ADD + WordAddOp -> sizedPrimOp OP_ADD + Word64AddOp -> only64bit $ sizedPrimOp OP_ADD + Word32AddOp -> sizedPrimOp OP_ADD + Word16AddOp -> sizedPrimOp OP_ADD + Word8AddOp -> sizedPrimOp OP_ADD + AddrAddOp -> sizedPrimOp OP_ADD + + IntMulOp -> sizedPrimOp OP_MUL + Int64MulOp -> only64bit $ sizedPrimOp OP_MUL + Int32MulOp -> sizedPrimOp OP_MUL + Int16MulOp -> sizedPrimOp OP_MUL + Int8MulOp -> sizedPrimOp OP_MUL + WordMulOp -> sizedPrimOp OP_MUL + Word64MulOp -> only64bit $ sizedPrimOp OP_MUL + Word32MulOp -> sizedPrimOp OP_MUL + Word16MulOp -> sizedPrimOp OP_MUL + Word8MulOp -> sizedPrimOp OP_MUL + + IntSubOp -> sizedPrimOp OP_SUB + WordSubOp -> sizedPrimOp OP_SUB + Int64SubOp -> only64bit $ sizedPrimOp OP_SUB + Int32SubOp -> sizedPrimOp OP_SUB + Int16SubOp -> sizedPrimOp OP_SUB + Int8SubOp -> sizedPrimOp OP_SUB + Word64SubOp -> only64bit $ sizedPrimOp OP_SUB + Word32SubOp -> sizedPrimOp OP_SUB + Word16SubOp -> sizedPrimOp OP_SUB + Word8SubOp -> sizedPrimOp OP_SUB + AddrSubOp -> sizedPrimOp OP_SUB + + IntAndOp -> sizedPrimOp OP_AND + WordAndOp -> sizedPrimOp OP_AND + Word64AndOp -> only64bit $ sizedPrimOp OP_AND + Word32AndOp -> sizedPrimOp OP_AND + Word16AndOp -> sizedPrimOp OP_AND + Word8AndOp -> sizedPrimOp OP_AND + + IntNotOp -> sizedPrimOp OP_NOT + WordNotOp -> sizedPrimOp OP_NOT + Word64NotOp -> only64bit $ sizedPrimOp OP_NOT + Word32NotOp -> sizedPrimOp OP_NOT + Word16NotOp -> sizedPrimOp OP_NOT + Word8NotOp -> sizedPrimOp OP_NOT + + IntXorOp -> sizedPrimOp OP_XOR + WordXorOp -> sizedPrimOp OP_XOR + Word64XorOp -> only64bit $ sizedPrimOp OP_XOR + Word32XorOp -> sizedPrimOp OP_XOR + Word16XorOp -> sizedPrimOp OP_XOR + Word8XorOp -> sizedPrimOp OP_XOR + + IntOrOp -> sizedPrimOp OP_OR + WordOrOp -> sizedPrimOp OP_OR + Word64OrOp -> only64bit $ sizedPrimOp OP_OR + Word32OrOp -> sizedPrimOp OP_OR + Word16OrOp -> sizedPrimOp OP_OR + Word8OrOp -> sizedPrimOp OP_OR + + WordSllOp -> sizedPrimOp OP_SHL + Word64SllOp -> only64bit $ sizedPrimOp OP_SHL -- check 32bit platform + Word32SllOp -> sizedPrimOp OP_SHL + Word16SllOp -> sizedPrimOp OP_SHL + Word8SllOp -> sizedPrimOp OP_SHL + IntSllOp -> sizedPrimOp OP_SHL + Int64SllOp -> only64bit $ sizedPrimOp OP_SHL + Int32SllOp -> sizedPrimOp OP_SHL + Int16SllOp -> sizedPrimOp OP_SHL + Int8SllOp -> sizedPrimOp OP_SHL + + WordSrlOp -> sizedPrimOp OP_LSR + Word64SrlOp -> only64bit $ sizedPrimOp OP_LSR + Word32SrlOp -> sizedPrimOp OP_LSR + Word16SrlOp -> sizedPrimOp OP_LSR + Word8SrlOp -> sizedPrimOp OP_LSR + IntSrlOp -> sizedPrimOp OP_LSR + Int64SrlOp -> only64bit $ sizedPrimOp OP_LSR -- check 32bit platform + Int32SrlOp -> sizedPrimOp OP_LSR + Int16SrlOp -> sizedPrimOp OP_LSR + Int8SrlOp -> sizedPrimOp OP_LSR + + IntSraOp -> sizedPrimOp OP_ASR + Int64SraOp -> only64bit $ sizedPrimOp OP_ASR -- check 32bit platform + Int32SraOp -> sizedPrimOp OP_ASR + Int16SraOp -> sizedPrimOp OP_ASR + Int8SraOp -> sizedPrimOp OP_ASR + + + IntNeOp -> sizedPrimOp OP_NEQ + Int64NeOp -> only64bit $ sizedPrimOp OP_NEQ + Int32NeOp -> sizedPrimOp OP_NEQ + Int16NeOp -> sizedPrimOp OP_NEQ + Int8NeOp -> sizedPrimOp OP_NEQ + WordNeOp -> sizedPrimOp OP_NEQ + Word64NeOp -> only64bit $ sizedPrimOp OP_NEQ + Word32NeOp -> sizedPrimOp OP_NEQ + Word16NeOp -> sizedPrimOp OP_NEQ + Word8NeOp -> sizedPrimOp OP_NEQ + AddrNeOp -> sizedPrimOp OP_NEQ + + IntEqOp -> sizedPrimOp OP_EQ + Int64EqOp -> only64bit $ sizedPrimOp OP_EQ + Int32EqOp -> sizedPrimOp OP_EQ + Int16EqOp -> sizedPrimOp OP_EQ + Int8EqOp -> sizedPrimOp OP_EQ + WordEqOp -> sizedPrimOp OP_EQ + Word64EqOp -> only64bit $ sizedPrimOp OP_EQ + Word32EqOp -> sizedPrimOp OP_EQ + Word16EqOp -> sizedPrimOp OP_EQ + Word8EqOp -> sizedPrimOp OP_EQ + AddrEqOp -> sizedPrimOp OP_EQ + CharEqOp -> sizedPrimOp OP_EQ + + IntLtOp -> sizedPrimOp OP_S_LT + Int64LtOp -> only64bit $ sizedPrimOp OP_S_LT + Int32LtOp -> sizedPrimOp OP_S_LT + Int16LtOp -> sizedPrimOp OP_S_LT + Int8LtOp -> sizedPrimOp OP_S_LT + WordLtOp -> sizedPrimOp OP_U_LT + Word64LtOp -> only64bit $ sizedPrimOp OP_U_LT + Word32LtOp -> sizedPrimOp OP_U_LT + Word16LtOp -> sizedPrimOp OP_U_LT + Word8LtOp -> sizedPrimOp OP_U_LT + AddrLtOp -> sizedPrimOp OP_U_LT + CharLtOp -> sizedPrimOp OP_U_LT + + IntGeOp -> sizedPrimOp OP_S_GE + Int64GeOp -> only64bit $ sizedPrimOp OP_S_GE + Int32GeOp -> sizedPrimOp OP_S_GE + Int16GeOp -> sizedPrimOp OP_S_GE + Int8GeOp -> sizedPrimOp OP_S_GE + WordGeOp -> sizedPrimOp OP_U_GE + Word64GeOp -> only64bit $ sizedPrimOp OP_U_GE + Word32GeOp -> sizedPrimOp OP_U_GE + Word16GeOp -> sizedPrimOp OP_U_GE + Word8GeOp -> sizedPrimOp OP_U_GE + AddrGeOp -> sizedPrimOp OP_U_GE + CharGeOp -> sizedPrimOp OP_U_GE + + IntGtOp -> sizedPrimOp OP_S_GT + Int64GtOp -> only64bit $ sizedPrimOp OP_S_GT + Int32GtOp -> sizedPrimOp OP_S_GT + Int16GtOp -> sizedPrimOp OP_S_GT + Int8GtOp -> sizedPrimOp OP_S_GT + WordGtOp -> sizedPrimOp OP_U_GT + Word64GtOp -> only64bit $ sizedPrimOp OP_U_GT + Word32GtOp -> sizedPrimOp OP_U_GT + Word16GtOp -> sizedPrimOp OP_U_GT + Word8GtOp -> sizedPrimOp OP_U_GT + AddrGtOp -> sizedPrimOp OP_U_GT + CharGtOp -> sizedPrimOp OP_U_GT + + IntLeOp -> sizedPrimOp OP_S_LE + Int64LeOp -> only64bit $ sizedPrimOp OP_S_LE + Int32LeOp -> sizedPrimOp OP_S_LE + Int16LeOp -> sizedPrimOp OP_S_LE + Int8LeOp -> sizedPrimOp OP_S_LE + WordLeOp -> sizedPrimOp OP_U_LE + Word64LeOp -> only64bit $ sizedPrimOp OP_U_LE + Word32LeOp -> sizedPrimOp OP_U_LE + Word16LeOp -> sizedPrimOp OP_U_LE + Word8LeOp -> sizedPrimOp OP_U_LE + AddrLeOp -> sizedPrimOp OP_U_LE + CharLeOp -> sizedPrimOp OP_U_LE + + IntNegOp -> sizedPrimOp OP_NEG + Int64NegOp -> only64bit $ sizedPrimOp OP_NEG + Int32NegOp -> sizedPrimOp OP_NEG + Int16NegOp -> sizedPrimOp OP_NEG + Int8NegOp -> sizedPrimOp OP_NEG + + IntToWordOp -> mk_conv (platformWordWidth platform) + WordToIntOp -> mk_conv (platformWordWidth platform) + Int8ToWord8Op -> mk_conv W8 + Word8ToInt8Op -> mk_conv W8 + Int16ToWord16Op -> mk_conv W16 + Word16ToInt16Op -> mk_conv W16 + Int32ToWord32Op -> mk_conv W32 + Word32ToInt32Op -> mk_conv W32 + Int64ToWord64Op -> only64bit $ mk_conv W64 + Word64ToInt64Op -> only64bit $ mk_conv W64 + IntToAddrOp -> mk_conv (platformWordWidth platform) + AddrToIntOp -> mk_conv (platformWordWidth platform) + ChrOp -> mk_conv (platformWordWidth platform) -- Int# and Char# are rep'd the same + OrdOp -> mk_conv (platformWordWidth platform) + + -- Memory primops, expand the ghci-mem-primops test if you add more. + IndexOffAddrOp_Word8 -> primOpWithRep (OP_INDEX_ADDR W8) W8 + IndexOffAddrOp_Word16 -> primOpWithRep (OP_INDEX_ADDR W16) W16 + IndexOffAddrOp_Word32 -> primOpWithRep (OP_INDEX_ADDR W32) W32 + IndexOffAddrOp_Word64 -> only64bit $ primOpWithRep (OP_INDEX_ADDR W64) W64 + + _ -> Nothing + where + only64bit = if platformWordWidth platform == W64 then id else const Nothing + primArg1Width :: StgArg -> Width + primArg1Width arg + | rep <- (stgArgRepU arg) + = case rep of + AddrRep -> platformWordWidth platform + IntRep -> platformWordWidth platform + WordRep -> platformWordWidth platform + + Int64Rep -> W64 + Word64Rep -> W64 + + Int32Rep -> W32 + Word32Rep -> W32 + + Int16Rep -> W16 + Word16Rep -> W16 + + Int8Rep -> W8 + Word8Rep -> W8 + + FloatRep -> unexpectedRep + DoubleRep -> unexpectedRep + + BoxedRep{} -> unexpectedRep + VecRep{} -> unexpectedRep + where + unexpectedRep = panic "doPrimOp: Unexpected argument rep" + + + -- TODO: The slides for the result need to be two words on 32bit for 64bit ops. + mkNReturn width + | W64 <- width = RETURN L -- L works for 64 bit on any platform + | otherwise = RETURN N -- <64bit width, fits in word on all platforms + + mkSlideWords width = if platformWordWidth platform < width then 2 else 1 + + -- Push args, execute primop, slide, return_N + -- Decides width of operation based on first argument. + sizedPrimOp op_inst = Just $ do + let width = primArg1Width (head args) + prim_code <- mkPrimOpCode init_d s p (op_inst width) $ args + let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width + return $ prim_code `appOL` slide + + -- primOpWithRep op w => operation @op@ resulting in result @w@ wide. + primOpWithRep :: BCInstr -> Width -> Maybe (BcM (OrdList BCInstr)) + primOpWithRep op_inst result_width = Just $ do + prim_code <- mkPrimOpCode init_d s p op_inst $ args + let slide = mkSlideW (mkSlideWords result_width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn result_width + return $ prim_code `appOL` slide + + -- Coerce the argument, requires them to be the same size + mk_conv :: Width -> Maybe (BcM (OrdList BCInstr)) + mk_conv target_width = Just $ do + let width = primArg1Width (head args) + massert (width == target_width) + (push_code, _bytes) <- pushAtom init_d p (head args) + let slide = mkSlideW (mkSlideWords target_width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn target_width + return $ push_code `appOL` slide + +-- Push the arguments on the stack and emit the given instruction +-- Pushes at least one word per non void arg. +mkPrimOpCode + :: StackDepth + -> Sequel + -> BCEnv + -> BCInstr -- The operator + -> [StgArg] -- Args, in *reverse* order (must be fully applied) + -> BcM BCInstrList +mkPrimOpCode orig_d _ p op_inst args = app_code + where + app_code = do + profile <- getProfile + let _platform = profilePlatform profile + + do_pushery :: StackDepth -> [StgArg] -> BcM BCInstrList + do_pushery !d (arg : args) = do + (push,arg_bytes) <- pushAtom d p arg + more_push_code <- do_pushery (d + arg_bytes) args + return (push `appOL` more_push_code) + do_pushery !_d [] = do + return (unitOL op_inst) + + -- Push on the stack in the reverse order. + do_pushery orig_d (reverse args) + +-- v. similar to CgStackery.findMatch, ToDo: merge +findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep]) +findPushSeq (P: P: P: P: P: P: rest) + = (PUSH_APPLY_PPPPPP, 6, rest) +findPushSeq (P: P: P: P: P: rest) + = (PUSH_APPLY_PPPPP, 5, rest) +findPushSeq (P: P: P: P: rest) + = (PUSH_APPLY_PPPP, 4, rest) +findPushSeq (P: P: P: rest) + = (PUSH_APPLY_PPP, 3, rest) +findPushSeq (P: P: rest) + = (PUSH_APPLY_PP, 2, rest) +findPushSeq (P: rest) + = (PUSH_APPLY_P, 1, rest) +findPushSeq (V: rest) + = (PUSH_APPLY_V, 1, rest) +findPushSeq (N: rest) + = (PUSH_APPLY_N, 1, rest) +findPushSeq (F: rest) + = (PUSH_APPLY_F, 1, rest) +findPushSeq (D: rest) + = (PUSH_APPLY_D, 1, rest) +findPushSeq (L: rest) + = (PUSH_APPLY_L, 1, rest) +findPushSeq argReps + | any (`elem` [V16, V32, V64]) argReps + = sorry "SIMD vector operations are not available in GHCi" +findPushSeq _ + = panic "GHC.StgToByteCode.findPushSeq" + +-- ----------------------------------------------------------------------------- +-- Case expressions + +-- | Generate ByteCode for a case expression. +-- +-- Note that case BCOs may be "nested" within other parent BCOs and refer to +-- its parent's variables (as in the 'BCEnv' contains variables from parent +-- frames). For more details about the interaction between case BCOs and their +-- parent frames see Note [Case continuation BCOs]. +doCase + :: StackDepth + -> Sequel + -> BCEnv + -> CgStgExpr + -> Id + -> [CgStgAlt] + -> BcM BCInstrList +doCase d s p scrut bndr alts + = do + profile <- getProfile + hsc_env <- getHscEnv + let + platform = profilePlatform profile + + -- Are we dealing with an unboxed tuple with a tuple return frame? + -- + -- 'Simple' tuples with at most one non-void component, + -- like (# Word# #) or (# Int#, State# RealWorld #) do not have a + -- tuple return frame. This is because (# foo #) and (# foo, Void# #) + -- have the same runtime rep. We have more efficient specialized + -- return frames for the situations with one non-void element. + + non_void_arg_reps = typeArgReps platform bndr_ty + ubx_tuple_frame = + (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && + length non_void_arg_reps > 1 + + profiling + | Just interp <- hsc_interp hsc_env + = interpreterProfiled interp + | otherwise = False + + -- Top of stack is the return itbl, as usual. + -- underneath it is the pointer to the alt_code BCO. + -- When an alt is entered, it assumes the returned value is + -- on top of the itbl; see Note [Return convention for non-tuple values] + -- for details. + ctoi_frame_header_w :: WordOff + ctoi_frame_header_w + | ubx_tuple_frame = + if profiling then 5 else 4 + | otherwise = 2 + + -- The size of the ret_*_info frame header, whose frame returns the + -- value to the case continuation frame (ctoi_*_info) + ret_info_header_w :: WordOff + | ubx_tuple_frame = 3 + | otherwise = 1 + + -- The stack space used to save/restore the CCCS when profiling + save_ccs_size_b | profiling && + not ubx_tuple_frame = 2 * wordSize platform + | otherwise = 0 + + (bndr_size, call_info, args_offsets) + | ubx_tuple_frame = + let bndr_reps = typePrimRep (idType bndr) + (call_info, args_offsets) = + layoutNativeCall profile NativeTupleReturn 0 id bndr_reps + in ( nativeCallSize call_info + , call_info + , args_offsets + ) + | otherwise = ( idSizeW platform bndr + , voidTupleReturnInfo + , [] + ) + + -- Depth of stack after the return value has been pushed + -- This is the stack depth at the continuation. + d_bndr = + d + wordsToBytes platform bndr_size + + -- Env in which to compile the alts, not including + -- any vars bound by the alts themselves + p_alts = Map.insert bndr d_bndr p + + bndr_ty = idType bndr + isAlgCase = isAlgType bndr_ty + + -- given an alt, return a discr and code for it. + codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList) + codeAlt GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=rhs} + = do rhs_code <- schemeE d_bndr s p_alts rhs + return (NoDiscr, rhs_code) + + codeAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} + -- primitive or nullary constructor alt: no need to UNPACK + | null real_bndrs = do + rhs_code <- schemeE d_bndr s p_alts rhs + return (my_discr alt, rhs_code) + | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = + let bndr_ty = idPrimRepU . fromNonVoid + tuple_start = d_bndr + (call_info, args_offsets) = + layoutNativeCall profile + NativeTupleReturn + 0 + bndr_ty + (assertNonVoidIds bndrs) + + stack_bot = d_bndr + + p' = Map.insertList + [ (arg, tuple_start - + wordsToBytes platform (nativeCallSize call_info) + + offset) + | (NonVoid arg, offset) <- args_offsets] + p_alts + in do + rhs_code <- schemeE stack_bot s p' rhs + return (NoDiscr, rhs_code) + -- algebraic alt with some binders + | otherwise = + let (tot_wds, _ptrs_wds, args_offsets) = + mkVirtHeapOffsets profile NoHeader + (addIdReps (assertNonVoidIds real_bndrs)) + size = WordOff tot_wds + + stack_bot = d_bndr + wordsToBytes platform size + + -- convert offsets from Sp into offsets into the virtual stack + p' = Map.insertList + [ (arg, stack_bot - ByteOff offset) + | (NonVoid arg, offset) <- args_offsets ] + p_alts + + in do + massert isAlgCase + rhs_code <- schemeE stack_bot s p' rhs + return (my_discr alt, + unitOL (UNPACK size) `appOL` rhs_code) + where + real_bndrs = filterOut isTyVar bndrs + + my_discr alt = case alt_con alt of + DEFAULT -> NoDiscr {-shouldn't really happen-} + DataAlt dc + | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc + -> NoDiscr + | otherwise + -> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) + LitAlt l -> case l of + LitNumber LitNumInt i -> DiscrI (fromInteger i) + LitNumber LitNumInt8 i -> DiscrI8 (fromInteger i) + LitNumber LitNumInt16 i -> DiscrI16 (fromInteger i) + LitNumber LitNumInt32 i -> DiscrI32 (fromInteger i) + LitNumber LitNumInt64 i -> DiscrI64 (fromInteger i) + LitNumber LitNumWord w -> DiscrW (fromInteger w) + LitNumber LitNumWord8 w -> DiscrW8 (fromInteger w) + LitNumber LitNumWord16 w -> DiscrW16 (fromInteger w) + LitNumber LitNumWord32 w -> DiscrW32 (fromInteger w) + LitNumber LitNumWord64 w -> DiscrW64 (fromInteger w) + LitNumber LitNumBigNat _ -> unsupported + LitFloat r -> DiscrF (fromRational r) + LitDouble r -> DiscrD (fromRational r) + LitChar i -> DiscrI (ord i) + LitString {} -> unsupported + LitRubbish {} -> unsupported + LitNullAddr {} -> unsupported + LitLabel {} -> unsupported + where + unsupported = pprPanic "schemeE(StgCase).my_discr:" (ppr l) + + maybe_ncons + | not isAlgCase = Nothing + | otherwise + = case [dc | DataAlt dc <- alt_con <$> alts] of + [] -> Nothing + (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) + + -- the bitmap is relative to stack depth d, i.e. before the + -- BCO, info table and return value are pushed on. + -- This bit of code is v. similar to buildLivenessMask in CgBindery, + -- except that here we build the bitmap from the known bindings of + -- things that are pointers, whereas in CgBindery the code builds the + -- bitmap from the free slots and unboxed bindings. + -- (ToDo: merge?) + -- + -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002. + -- The bitmap must cover the portion of the stack up to the sequel only. + -- Previously we were building a bitmap for the whole depth (d), but we + -- really want a bitmap up to depth (d-s). This affects compilation of + -- case-of-case expressions, which is the only time we can be compiling a + -- case expression with s /= 0. + + -- unboxed tuples get two more words, the second is a pointer (tuple_bco) + (extra_pointers, extra_slots) + | ubx_tuple_frame && profiling = ([1], 3) -- call_info, tuple_BCO, CCCS + | ubx_tuple_frame = ([1], 2) -- call_info, tuple_BCO + | otherwise = ([], 0) + + bitmap_size :: WordOff + bitmap_size = fromIntegral extra_slots + + bytesToWords platform (d - s) + + bitmap_size' :: Int + bitmap_size' = fromIntegral bitmap_size + + + pointers = + extra_pointers ++ + filter (< bitmap_size') (map (+extra_slots) rel_slots) + where + -- NB: unboxed tuple cases bind the scrut binder to the same offset + -- as one of the alt binders, so we have to remove any duplicates here: + -- 'toAscList' takes care of sorting the result, which was previously done after the application of 'filter'. + rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p + spread id offset | isUnboxedTupleType (idType id) || + isUnboxedSumType (idType id) = Nothing + | isFollowableArg (idArgRep platform id) = Just (fromIntegral rel_offset) + | otherwise = Nothing + where rel_offset = bytesToWords platform (d - offset) + + bitmap = intsToReverseBitmap platform bitmap_size' pointers + + alt_stuff <- mapM codeAlt alts + alt_final0 <- mkMultiBranch maybe_ncons alt_stuff + + let + + -- drop the stg_ctoi_*_info header... + alt_final1 = SLIDE bndr_size ctoi_frame_header_w `consOL` alt_final0 + + -- after dropping the stg_ret_*_info header + alt_final2 = SLIDE 0 ret_info_header_w `consOL` alt_final1 + + -- When entering a case continuation BCO, the stack is always headed + -- by the stg_ret frame and the stg_ctoi frame that returned to it. + -- See Note [Stack layout when entering run_BCO] + -- + -- Right after the breakpoint instruction, a case continuation BCO + -- drops the stg_ret and stg_ctoi frame headers (see alt_final1, + -- alt_final2), leaving the stack with the scrutinee followed by the + -- free variables (with depth==d_bndr) + alt_final <- getLastBreakTick >>= \case + Just (Breakpoint tick_ty tick_id fvs) + | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env) + -- Construct an internal breakpoint to put at the start of this case + -- continuation BCO, for step-out. + -- See Note [Debugger: Stepout internal break locs] + -> do + + -- same fvs available in the surrounding tick are available in the case continuation + + -- The variable offsets into the yielded AP_STACK are adjusted + -- differently because a case continuation AP_STACK has the + -- additional stg_ret and stg_ctoi frame headers + -- (as per Note [Stack layout when entering run_BCO]): + let firstVarOff = ret_info_header_w+bndr_size+ctoi_frame_header_w + idOffSets = map (fmap (second (+firstVarOff))) $ + getVarOffSets platform d p fvs + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty + (Left (InternalBreakLoc tick_id)) + + mibi <- newBreakInfo breakInfo + return $ case mibi of + Nothing -> alt_final2 + Just ibi -> BRK_FUN ibi `consOL` alt_final2 + _ -> pure alt_final2 + + add_bco_name <- shouldAddBcoName + let + alt_bco_name = getName bndr + alt_bco = mkProtoBCO platform add_bco_name alt_bco_name alt_final (Left alts) + 0{-no arity-} bitmap_size bitmap True{-is alts-} + scrut_code <- schemeE (d + wordsToBytes platform ctoi_frame_header_w + save_ccs_size_b) + (d + wordsToBytes platform ctoi_frame_header_w + save_ccs_size_b) + p scrut + if ubx_tuple_frame + then do let tuple_bco = tupleBCO platform call_info args_offsets + return (PUSH_ALTS_TUPLE alt_bco call_info tuple_bco + `consOL` scrut_code) + else let scrut_rep = case non_void_arg_reps of + [] -> V + [rep] -> rep + _ -> panic "schemeE(StgCase).push_alts" + in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code) + +{- +Note [Debugger: Stepout internal break locs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Step-out tells the interpreter to run until the current function +returns to where it was called from, and stop there. + +This is achieved by enabling the BRK_FUN found on the first RET_BCO +frame on the stack (See [Note Debugger: Step-out]). + +Case continuation BCOs (which select an alternative branch) must +therefore be headed by a BRK_FUN. An example: + + f x = case g x of <--- end up here + 1 -> ... + 2 -> ... + + g y = ... <--- step out from here + +- `g` will return a value to the case continuation BCO in `f` +- The case continuation BCO will receive the value returned from g +- Match on it and push the alternative continuation for that branch +- And then enter that alternative. + +If we step-out of `g`, the first RET_BCO on the stack is the case +continuation of `f` -- execution should stop at its start, before +selecting an alternative. (One might ask, "why not enable the breakpoint +in the alternative instead?", because the alternative continuation is +only pushed to the stack *after* it is selected by the case cont. BCO) + +However, the case cont. BCO is not associated with any source-level +tick, it is merely the glue code which selects alternatives which do +have source level ticks. Therefore, we have to come up at code +generation time with a breakpoint location ('InternalBreakLoc') to +display to the user when it is stopped there. + +Our solution is to use the last tick seen just before reaching the case +continuation. This is robust because a case continuation will thus +always have a relevant breakpoint location: + + - The source location will be the last source-relevant expression + executed before the continuation is pushed + + - So the source location will point to the thing you've just stepped + out of + + - The variables available are the same as the ones bound just before entering + + - Doing :step-local from there will put you on the selected + alternative (which at the source level may also be the e.g. next + line in a do-block) + +Examples, using angle brackets (<<...>>) to denote the breakpoint span: + + f x = case <> {- step in here -} of + 1 -> ... + 2 -> ...> + + g y = <<...>> <--- step out from here + + ... + + f x = < ... + 2 -> ...>> + + doing :step-local ... + + f x = case g x of + 1 -> <<...>> <--- stop in the alternative + 2 -> ... + +A second example based on T26042d2, where the source is a do-block IO +action, optimised to a chain of `case expressions`. + + main = do + putStrLn "hello1" + <> <--- step-in here + putStrLn "hello3" + putStrLn "hello4" + + f = do + <> <--- step-out from here + putStrLn "hello2.2" + + ... + + main = do + putStrLn "hello1" + <> <--- end up here again, the previously executed expression + putStrLn "hello3" + putStrLn "hello4" + + doing step/step-local ... + + main = do + putStrLn "hello1" + f + <> <--- straight to the next line + putStrLn "hello4" +-} + +-- ----------------------------------------------------------------------------- +-- Deal with tuples + +-- The native calling convention uses registers for tuples, but in the +-- bytecode interpreter, all values live on the stack. + +{- Note [GHCi and native call registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GHCi bytecode interpreter does not have access to the STG registers +that the native calling convention uses for passing arguments. It uses +helper stack frames to move values between the stack and registers. + +If only a single register needs to be moved, GHCi uses a specific stack +frame. For example stg_ctoi_R1p saves a heap pointer value from STG register +R1 and stg_ctoi_D1 saves a double precision floating point value from D1. +In the other direction, helpers stg_ret_p and stg_ret_d move a value from +the stack to the R1 and D1 registers, respectively. + +When GHCi needs to move more than one register it cannot use a specific +helper frame. It would simply be impossible to create a helper for all +possible combinations of register values. Instead, there are generic helper +stack frames that use a call_info word that describes the active registers +and the number of stack words used by the arguments of a call. + +These helper stack frames are currently: + + - stg_ret_t: return a tuple to the continuation at the top of + the stack + - stg_ctoi_t: convert a tuple return value to be used in + bytecode + - stg_primcall: call a function + + +The call_info word contains a bitmap of the active registers +for the call and and a stack offset. The layout is as follows: + + - bit 0-23: Bitmap of active registers for the call, the + order corresponds to the list returned by + allArgRegsCover. + For example if bit 0 (the least significant bit) is set, the + first register in the allArgRegsCover + list is active. Bit 1 for the + second register in the list and so on. + + - bit 24-31: Unsigned byte indicating the stack offset + of the continuation in words. For tuple returns + this is the number of words returned on the + stack. For primcalls this field is unused, since + we don't jump to a continuation. + +The upper 32 bits on 64 bit platforms are currently unused. + +If a register is smaller than a word on the stack (for example a +single precision float on a 64 bit system), then the stack slot +is padded to a whole word. + + Example: + + If a tuple is returned in three registers and an additional two + words on the stack, then three bits in the register bitmap + (bits 0-23) would be set. And bit 24-31 would be + 00000010 (two in binary). + + The values on the stack before a call to POP_ARG_REGS would + be as follows: + + ... + continuation + stack_arg_1 + stack_arg_2 + register_arg_3 + register_arg_2 + register_arg_1 <- Sp + + A call to POP_ARG_REGS(call_info) would move register_arg_1 + to the register corresponding to the lowest set bit in the + call_info word. register_arg_2 would be moved to the register + corresponding to the second lowest set bit, and so on. + + After POP_ARG_REGS(call_info), the stack pointer Sp points + to the topmost stack argument, so the stack looks as follows: + + ... + continuation + stack_arg_1 + stack_arg_2 <- Sp + + At this point all the arguments are in place and we are ready + to jump to the continuation, the location (offset from Sp) of + which is found by inspecting the value of bits 24-31. In this + case the offset is two words. + +On x86_64, the double precision (Dn) and single precision +floating (Fn) point registers overlap, e.g. D1 uses the same +physical register as F1. On this platform, the list returned +by allArgRegsCover contains only entries for the double +precision registers. If an argument is passed in register +Fn, the bit corresponding to Dn should be set. + +Note: if anything changes in how registers for native calls overlap, + make sure to also update GHC.StgToByteCode.layoutNativeCall +-} + +layoutNativeCall :: Profile + -> NativeCallType + -> ByteOff + -> (a -> PrimRep) + -> [a] + -> ( NativeCallInfo -- See Note [GHCi TupleInfo] + , [(a, ByteOff)] -- argument, offset on stack + ) +layoutNativeCall profile call_type start_off arg_rep reps = + let platform = profilePlatform profile + arg_ty = primRepCmmType platform . arg_rep + (orig_stk_bytes, pos) = assignArgumentsPos profile + 0 + NativeReturn + arg_ty + reps + + -- keep the stack parameters in the same place + orig_stk_params = [(x, fromIntegral off) | (x, StackParam off) <- pos] + + -- sort the register parameters by register and add them to the stack + regs_order :: Map.Map GlobalReg Int + regs_order = Map.fromList $ zip (allArgRegsCover platform SCALAR_ARG_REGS) [0..] + + reg_order :: GlobalReg -> (Int, GlobalReg) + reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg) + -- if we don't have a position for a FloatReg then they must be passed + -- in the equivalent DoubleReg + reg_order (FloatReg n) = reg_order (DoubleReg n) + -- one-tuples can be passed in other registers, but then we don't need + -- to care about the order + reg_order reg = (0, reg) + + (regs, reg_params) + = unzip $ sortBy (comparing fst) + [(reg_order reg, x) | (x, RegisterParam reg) <- pos] + + (new_stk_bytes, new_stk_params) = assignStack platform + orig_stk_bytes + arg_ty + reg_params + + regs_set = mkRegSet (map snd regs) + + get_byte_off (x, StackParam y) = (x, fromIntegral y) + get_byte_off _ = + panic "GHC.StgToByteCode.layoutTuple get_byte_off" + + in ( NativeCallInfo + { nativeCallType = call_type + , nativeCallSize = bytesToWords platform (ByteOff new_stk_bytes) + , nativeCallRegs = regs_set + , nativeCallStackSpillSize = bytesToWords platform + (ByteOff orig_stk_bytes) + } + , sortBy (comparing snd) $ + map (\(x, o) -> (x, o + start_off)) + (orig_stk_params ++ map get_byte_off new_stk_params) + ) + +{- Note [Return convention for non-tuple values] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RETURN and ENTER instructions are used to return values. RETURN directly +returns the value at the top of the stack while ENTER evaluates it first (so +RETURN is only used when the result is already known to be evaluated), but the +end result is the same: control returns to the enclosing stack frame with the +result at the top of the stack. + +The PUSH_ALTS instruction pushes a two-word stack frame that receives a single +lifted value. Its payload is a BCO that is executed when control returns, with +the stack set up as if a RETURN instruction had just been executed: the returned +value is at the top of the stack, and beneath it is the two-word frame being +returned to. It is the continuation BCO’s job to pop its own frame off the +stack, so the simplest possible continuation consists of two instructions: + + SLIDE 1 2 -- pop the return frame off the stack, keeping the returned value + RETURN P -- return the returned value to our caller + +RETURN and PUSH_ALTS are not really instructions but are in fact representation- +polymorphic *families* of instructions indexed by ArgRep. ENTER, however, is a +single real instruction, since it is only used to return lifted values, which +are always pointers. + +The RETURN, ENTER, and PUSH_ALTS instructions are only used when the returned +value has nullary or unary representation. Returning/receiving an unboxed +tuple (or, indirectly, an unboxed sum, since unboxed sums have been desugared to +unboxed tuples by Unarise) containing two or more results uses the special +RETURN_TUPLE/PUSH_ALTS_TUPLE instructions, which use a different return +convention. See Note [unboxed tuple bytecodes and tuple_BCO] for details. + +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 call_info. + + The helper data is used to convert tuples between GHCs native calling + convention (object code), which uses stack and registers, and the bytecode + calling convention, which only uses the stack. See Note [GHCi TupleInfo] + for more details. + + + Returning a tuple + ================= + + Bytecode that returns a tuple first pushes all the tuple fields followed + by the appropriate call_info and tuple_BCO onto the stack. It then + executes the RETURN_TUPLE instruction, which causes the interpreter + to push stg_ret_t_info to the top of the stack. The stack (growing down) + then looks as follows: + + ... + next_frame + tuple_field_1 + tuple_field_2 + ... + tuple_field_n + call_info + tuple_BCO + stg_ret_t_info <- Sp + + If next_frame is bytecode, the interpreter will start executing it. If + it's object code, the interpreter jumps back to the scheduler, which in + turn jumps to stg_ret_t. stg_ret_t converts the tuple to the native + calling convention using the description in call_info, and then jumps + to next_frame. + + + Receiving a tuple + ================= + + Bytecode that receives a tuple uses the PUSH_ALTS_TUPLE instruction to + push a continuation, followed by jumping to the code that produces the + tuple. The PUSH_ALTS_TUPLE instuction contains three pieces of data: + + * cont_BCO: the continuation that receives the tuple + * call_info: see below + * tuple_BCO: see below + + The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE + instruction is executed, followed by stg_ctoi_tN_info, with N depending + on the number of stack words used by the tuple in the GHC native calling + convention. N is derived from call_info. + + For example if we expect a tuple with three words on the stack, the stack + looks as follows after PUSH_ALTS_TUPLE: + + ... + next_frame + cont_free_var_1 + cont_free_var_2 + ... + cont_free_var_n + call_info + tuple_BCO + cont_BCO + stg_ctoi_t3_info <- Sp + + If the tuple is returned by object code, stg_ctoi_t3 will deal with + adjusting the stack pointer and converting the tuple to the bytecode + calling convention. See Note [GHCi unboxed tuples stack spills] for more + details. + + + The tuple_BCO + ============= + + The tuple_BCO is a helper bytecode object. Its main purpose is describing + the contents of the stack frame containing the tuple for the storage + manager. It contains only instructions to immediately return the tuple + that is already on the stack. + + + The call_info word + =================== + + The call_info word describes the stack and STG register (e.g. R1..R6, + D1..D6) usage for the tuple. call_info contains enough information to + convert the tuple between the stack-only bytecode and stack+registers + GHC native calling conventions. + + See Note [GHCi and native call registers] for more details of how the + data is packed in a single word. + + -} + +tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> ProtoBCO Name +tupleBCO platform args_info args = + mkProtoBCO platform Nothing invented_name body_code (Left []) + 0{-no arity-} bitmap_size bitmap False{-not alts-} + where + {- + The tuple BCO is never referred to by name, so we can get away + with using a fake name here. We will need to change this if we want + to save some memory by sharing the BCO between places that have + the same tuple shape + -} + invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple") + + -- the first word in the frame is the call_info word, + -- which is not a pointer + nptrs_prefix = 1 + (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args + + body_code = mkSlideW 0 1 -- pop frame header + `snocOL` RETURN_TUPLE -- and add it again + +primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> ProtoBCO Name +primCallBCO platform args_info args = + mkProtoBCO platform Nothing invented_name body_code (Left []) + 0{-no arity-} bitmap_size bitmap False{-not alts-} + where + {- + The primcall BCO is never referred to by name, so we can get away + with using a fake name here. We will need to change this if we want + to save some memory by sharing the BCO between places that have + the same tuple shape + -} + invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "primcall") + + -- The first two words in the frame (after the BCO) are the call_info word + -- and the pointer to the Cmm function being called. Neither of these is a + -- pointer that should be followed by the garbage collector. + nptrs_prefix = 2 + (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args + + -- if the primcall BCO is ever run it's a bug, since the BCO should only + -- be pushed immediately before running the PRIMCALL bytecode instruction, + -- which immediately leaves the interpreter to jump to the stg_primcall_info + -- Cmm function + body_code = unitOL CASEFAIL + +-- | Builds a bitmap for a stack layout with a nonpointer prefix followed by +-- some number of arguments. +mkStackBitmap + :: Platform + -> WordOff + -- ^ The number of nonpointer words that prefix the arguments. + -> NativeCallInfo + -> [(PrimRep, ByteOff)] + -- ^ The stack layout of the arguments, where each offset is relative to the + -- /bottom/ of the stack space they occupy. Their offsets must be word-aligned, + -- and the list must be sorted in order of ascending offset (i.e. bottom to top). + -> (WordOff, [StgWord]) +mkStackBitmap platform nptrs_prefix args_info args + = (bitmap_size, bitmap) + where + bitmap_size = nptrs_prefix + arg_bottom + bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) ptr_offsets + + arg_bottom = nativeCallSize args_info + ptr_offsets = reverse $ map (fromIntegral . convert_arg_offset) + $ mapMaybe get_ptr_offset args + + get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff + get_ptr_offset (rep, byte_offset) + | isFollowableArg (toArgRep platform rep) = Just byte_offset + | otherwise = Nothing + + convert_arg_offset :: ByteOff -> WordOff + convert_arg_offset arg_offset = + -- The argument offsets are relative to `arg_bottom`, but + -- `intsToReverseBitmap` expects offsets from the top, so we need to flip + -- them around. + nptrs_prefix + (arg_bottom - bytesToWords platform arg_offset) + +-- ----------------------------------------------------------------------------- +-- Deal with a primitive call to native code. + +generatePrimCall + :: StackDepth + -> Sequel + -> BCEnv + -> CLabelString -- where to call + -> Maybe Unit + -> Type + -> [StgArg] -- args (atoms) + -> BcM BCInstrList +generatePrimCall d s p target _mb_unit _result_ty args + = do + profile <- getProfile + let + platform = profilePlatform profile + + non_void VoidRep = False + non_void _ = True + + nv_args :: [StgArg] + nv_args = filter (non_void . stgArgRep1) args + + (args_info, args_offsets) = + layoutNativeCall profile + NativePrimCall + 0 + stgArgRepU + nv_args + + prim_args_offsets = mapFst stgArgRepU args_offsets + shifted_args_offsets = mapSnd (+ d) args_offsets + + push_target = PUSH_UBX (LitLabel target IsFunction) 1 + push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1 + {- + compute size to move payload (without stg_primcall_info header) + + size of arguments plus three words for: + - function pointer to the target + - call_info word + - BCO to describe the stack frame + -} + szb = wordsToBytes platform (nativeCallSize args_info + 3) + go _ pushes [] = return (reverse pushes) + go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a + massert (off == dd + szb) + go (dd + szb) (push:pushes) cs + push_args <- go d [] shifted_args_offsets + let args_bco = primCallBCO platform args_info prim_args_offsets + return $ mconcat push_args `appOL` + (push_target `consOL` + push_info `consOL` + PUSH_BCO args_bco `consOL` + (mkSlideB platform szb (d - s) `appOL` unitOL PRIMCALL)) + +-- ----------------------------------------------------------------------------- +-- Deal with a CCall. + +-- Taggedly push the args onto the stack R->L, +-- deferencing ForeignObj#s and adjusting addrs to point to +-- payloads in Ptr/Byte arrays. Then, generate the marshalling +-- (machine) code for the ccall, and create bytecodes to call that and +-- then return in the right way. + +generateCCall + :: StackDepth + -> Sequel + -> BCEnv + -> CCallSpec -- where to call + -> Type + -> [StgArg] -- args (atoms) + -> BcM BCInstrList +generateCCall d0 s p (CCallSpec target PrimCallConv _) result_ty args + | (StaticTarget _ label mb_unit _) <- target + = generatePrimCall d0 s p label mb_unit result_ty args + | otherwise + = panic "GHC.StgToByteCode.generateCCall: primcall convention only supports static targets" +generateCCall d0 s p (CCallSpec target _ safety) result_ty args + = do + profile <- getProfile + + let + args_r_to_l = reverse args + platform = profilePlatform profile + -- useful constants + addr_size_b :: ByteOff + addr_size_b = wordSize platform + + arrayish_rep_hdr_size :: TyCon -> Maybe Int + arrayish_rep_hdr_size t + | t == arrayPrimTyCon || t == mutableArrayPrimTyCon + = Just (arrPtrsHdrSize profile) + | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon + = Just (smallArrPtrsHdrSize profile) + | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon + = Just (arrWordsHdrSize profile) + | otherwise + = Nothing + + -- Get the args on the stack, with tags and suitably + -- dereferenced for the CCall. For each arg, return the + -- depth to the first word of the bits for that arg, and the + -- ArgRep of what was actually pushed. + + pargs + :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimOrVoidRep)] + pargs _ [] = return [] + pargs d (aa@(StgVarArg a):az) + | Just t <- tyConAppTyCon_maybe (idType a) + , Just hdr_sz <- arrayish_rep_hdr_size t + -- Do magic for Ptr/Byte arrays. Push a ptr to the array on + -- the stack but then advance it over the headers, so as to + -- point to the payload. + = do rest <- pargs (d + addr_size_b) az + (push_fo, _) <- pushAtom d p aa + -- The ptr points at the header. Advance it over the + -- header and then pretend this is an Addr#. + let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz) + return ((code, NVRep AddrRep) : rest) + pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa + rest <- pargs (d + sz_a) az + return ((code_a, stgArgRep1 aa) : rest) + + code_n_reps <- pargs d0 args_r_to_l + let + (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps + a_reps_sizeW = sum (map (repSizeWords platform) a_reps_pushed_r_to_l) + + push_args = concatOL pushs_arg + !d_after_args = d0 + wordsToBytes platform a_reps_sizeW + a_reps_pushed_RAW + | VoidRep:xs <- a_reps_pushed_r_to_l + = reverse xs + | otherwise + = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?" + + -- Now: a_reps_pushed_RAW are the reps which are actually on the stack. + -- push_args is the code to do that. + -- d_after_args is the stack depth once the args are on. + + -- Get the result rep. + r_rep = maybe_getCCallReturnRep result_ty + {- + Because the Haskell stack grows down, the a_reps refer to + lowest to highest addresses in that order. The args for the call + are on the stack. Now push an unboxed Addr# indicating + the C function to call. Then push a dummy placeholder for the + result. Finally, emit a CCALL insn with an offset pointing to the + Addr# just pushed, and a literal field holding the mallocville + address of the piece of marshalling code we generate. + So, just prior to the CCALL insn, the stack looks like this + (growing down, as usual): + + + ... + + Addr# address_of_C_fn + (must be an unboxed type) + + The interpreter then calls the marshal code mentioned + in the CCALL insn, passing it (& ), + that is, the addr of the topmost word in the stack. + When this returns, the placeholder will have been + filled in. The placeholder is slid down to the sequel + depth, and we RETURN. + + This arrangement makes it simple to do f-i-dynamic since the Addr# + value is the first arg anyway. + + The marshalling code is generated specifically for this + call site, and so knows exactly the (Haskell) stack + offsets of the args, fn address and placeholder. It + copies the args to the C stack, calls the stacked addr, + and parks the result back in the placeholder. The interpreter + calls it as a normal C call, assuming it has a signature + void marshal_code ( StgWord* ptr_to_top_of_stack ) + -} + -- resolve static address + maybe_static_target :: Maybe Literal + maybe_static_target = + case target of + DynamicTarget -> Nothing + StaticTarget _ _ _ False -> + panic "generateCCall: unexpected FFI value import" + StaticTarget _ target _ True -> + Just (LitLabel target IsFunction) + + let + is_static = isJust maybe_static_target + + -- Get the arg reps, zapping the leading Addr# in the dynamic case + a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" + | is_static = a_reps_pushed_RAW + | _:xs <- a_reps_pushed_RAW = xs + | otherwise = panic "GHC.StgToByteCode.generateCCall: dyn with no args" + + -- push the Addr# + (push_Addr, d_after_Addr) + | Just machlabel <- maybe_static_target + = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b) + | otherwise -- is already on the stack + = (nilOL, d_after_args) + + -- Push the return placeholder. For a call returning nothing, + -- this is a V (tag). + r_sizeW = repSizeWords platform r_rep + d_after_r = d_after_Addr + wordsToBytes platform r_sizeW + push_r = case r_rep of + VoidRep -> nilOL + NVRep r -> unitOL (PUSH_UBX (mkDummyLiteral platform r) r_sizeW) + + -- generate the marshalling code we're going to call + + -- Offset of the next stack frame down the stack. The CCALL + -- instruction needs to describe the chunk of stack containing + -- the ccall args to the GC, so it needs to know how large it + -- is. See comment in Interpreter.c with the CCALL instruction. + stk_offset = bytesToWords platform (d_after_r - s) + + -- the only difference in libffi mode is that we prepare a cif + -- describing the call type by calling libffi, and we attach the + -- address of this to the CCALL instruction. + + + let ffires = primRepToFFIType platform r_rep + ffiargs = map (primRepToFFIType platform) a_reps + + let + -- do the call + do_call = unitOL (CCALL stk_offset (FFIInfo ffiargs ffires) flags) + where flags = case safety of + PlaySafe -> 0x0 + PlayInterruptible -> 0x1 + PlayRisky -> 0x2 + + -- slide and return + d_after_r_min_s = bytesToWords platform (d_after_r - s) + wrapup = mkSlideW r_sizeW (d_after_r_min_s - r_sizeW) + `snocOL` RETURN (toArgRepOrV platform r_rep) + --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ + return ( + push_args `appOL` + push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup + ) + +primRepToFFIType :: Platform -> PrimOrVoidRep -> FFIType +primRepToFFIType _ VoidRep = FFIVoid +primRepToFFIType platform (NVRep r) + = case r of + IntRep -> signed_word + WordRep -> unsigned_word + Int8Rep -> FFISInt8 + Word8Rep -> FFIUInt8 + Int16Rep -> FFISInt16 + Word16Rep -> FFIUInt16 + Int32Rep -> FFISInt32 + Word32Rep -> FFIUInt32 + Int64Rep -> FFISInt64 + Word64Rep -> FFIUInt64 + AddrRep -> FFIPointer + FloatRep -> FFIFloat + DoubleRep -> FFIDouble + BoxedRep _ -> FFIPointer + VecRep{} -> pprPanic "primRepToFFIType" (ppr r) + where + (signed_word, unsigned_word) = case platformWordSize platform of + PW4 -> (FFISInt32, FFIUInt32) + PW8 -> (FFISInt64, FFIUInt64) + +-- Make a dummy literal, to be used as a placeholder for FFI return +-- values on the stack. +mkDummyLiteral :: Platform -> PrimRep -> Literal +mkDummyLiteral platform pr + = case pr of + IntRep -> mkLitInt platform 0 + WordRep -> mkLitWord platform 0 + Int8Rep -> mkLitInt8 0 + Word8Rep -> mkLitWord8 0 + Int16Rep -> mkLitInt16 0 + Word16Rep -> mkLitWord16 0 + Int32Rep -> mkLitInt32 0 + Word32Rep -> mkLitWord32 0 + Int64Rep -> mkLitInt64 0 + Word64Rep -> mkLitWord64 0 + AddrRep -> LitNullAddr + DoubleRep -> LitDouble 0 + FloatRep -> LitFloat 0 + BoxedRep _ -> LitNullAddr + VecRep{} -> pprPanic "mkDummyLiteral" (ppr pr) + + +-- Convert (eg) +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) +-- +-- to NVRep IntRep +-- and check that an unboxed pair is returned wherein the first arg is V'd. +-- +-- Alternatively, for call-targets returning nothing, convert +-- +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) +-- +-- to VoidRep + +maybe_getCCallReturnRep :: Type -> PrimOrVoidRep +maybe_getCCallReturnRep fn_ty + = let + (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) + in + case typePrimRep r_ty of + [] -> VoidRep + [rep] -> NVRep rep + + -- if it was, it would be impossible to create a + -- valid return value placeholder on the stack + _ -> pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) + +maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (StgArg, [Name]) +-- Detect and extract relevant info for the tagToEnum kludge. +maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) args t) + | [v] <- args + = Just (v, extract_constr_Names t) + | otherwise + = pprPanic "StgToByteCode: tagToEnum#" + $ text "Expected exactly one arg, but actual args are:" <+> ppr args + where + extract_constr_Names ty + | rep_ty <- unwrapType ty + , Just tyc <- tyConAppTyCon_maybe rep_ty + , isBoxedDataTyCon tyc + = map (getName . dataConWorkId) (tyConDataCons tyc) + -- NOTE: use the worker name, not the source name of + -- the DataCon. See "GHC.Core.DataCon" for details. + | otherwise + = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) +maybe_is_tagToEnum_call _ = Nothing + +{- ----------------------------------------------------------------------------- +Note [Implementing tagToEnum#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(implement_tagToId arg names) compiles code which takes an argument +'arg', (call it i), and enters the i'th closure in the supplied list +as a consequence. The [Name] is a list of the constructors of this +(enumeration) type. + +The code we generate is this: + push arg + + TESTEQ_I 0 L1 + PUSH_G + JMP L_Exit + + L1: TESTEQ_I 1 L2 + PUSH_G + JMP L_Exit + ...etc... + Ln: TESTEQ_I n L_fail + PUSH_G + JMP L_Exit + + L_fail: CASEFAIL + + L_exit: SLIDE 1 n + ENTER +-} + + +implement_tagToId + :: StackDepth + -> Sequel + -> BCEnv + -> StgArg + -> [Name] + -> BcM BCInstrList +-- See Note [Implementing tagToEnum#] +implement_tagToId d s p arg names + = assert (notNull names) $ + do (push_arg, arg_bytes) <- pushAtom d p arg + labels <- getLabelsBc (strictGenericLength names) + label_fail <- getLabelBc + label_exit <- getLabelBc + dflags <- getDynFlags + let infos = zip4 labels (tail labels ++ [label_fail]) + [0 ..] names + platform = targetPlatform dflags + steps = map (mkStep label_exit) infos + slide_ws = bytesToWords platform (d - s + arg_bytes) + + return (push_arg + `appOL` concatOL steps + `appOL` toOL [ LABEL label_fail, CASEFAIL, + LABEL label_exit ] + `appOL` mkSlideW 1 slide_ws + `appOL` unitOL ENTER) + where + mkStep l_exit (my_label, next_label, n, name_for_n) + = toOL [LABEL my_label, + TESTEQ_I n next_label, + PUSH_G name_for_n, + JMP l_exit] + + +-- ----------------------------------------------------------------------------- +-- pushAtom + +-- Push an atom onto the stack, returning suitable code & number of +-- stack words used. +-- +-- The env p must map each variable to the highest- numbered stack +-- slot for it. For example, if the stack has depth 4 and we +-- tagged-ly push (v :: Int#) on it, the value will be in stack[4], +-- the tag in stack[5], the stack will have depth 6, and p must map v +-- to 5 and not to 4. Stack locations are numbered from zero, so a +-- depth 6 stack has valid words 0 .. 5. + +pushAtom :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff) +-- See Note [Empty case alternatives] in GHC.Core +-- and Note [Bottoming expressions] in GHC.Core.Utils: +-- The scrutinee of an empty case evaluates to bottom +pushAtom d p (StgVarArg var) + | [] <- typePrimRep (idType var) + = return (nilOL, 0) + + | isFCallId var + = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var) + + | Just primop <- isPrimOpId_maybe var + = do + platform <- targetPlatform <$> getDynFlags + return (unitOL (PUSH_PRIMOP primop), wordSize platform) + + | Just d_v <- lookupBCEnv_maybe var p -- var is a local variable + = do platform <- targetPlatform <$> getDynFlags + + let !szb = idSizeCon platform var + with_instr :: (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff) + with_instr instr = do + let !off_b = d - d_v + return (unitOL (instr off_b), wordSize platform) + + case szb of + 1 -> with_instr PUSH8_W + 2 -> with_instr PUSH16_W + 4 -> with_instr PUSH32_W + _ -> do + let !szw = bytesToWords platform szb + !off_w = bytesToWords platform (d - d_v) + szw - 1 + return (toOL (genericReplicate szw (PUSH_L off_w)), + wordsToBytes platform szw) + -- d - d_v offset from TOS to the first slot of the object + -- + -- d - d_v + sz - 1 offset from the TOS of the last slot of the object + -- + -- Having found the last slot, we proceed to copy the right number of + -- slots on to the top of the stack. + + | otherwise -- var must be a global variable + = do platform <- targetPlatform <$> getDynFlags + let !szb = idSizeCon platform var + massert (szb == wordSize platform) + + -- PUSH_G doesn't tag constructors. So we use PACK here + -- if we are dealing with nullary constructor. + case isDataConWorkId_maybe var of + Just con + -- See Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make. + | isNullaryRepDataCon con -> + return (unitOL (PACK con 0), szb) + + _ + -- see Note [Generating code for top-level string literal bindings] + | idType var `eqType` addrPrimTy -> + return (unitOL (PUSH_ADDR (getName var)), szb) + + | otherwise -> do + let varTy = idType var + massertPpr (definitelyLiftedType varTy) $ + vcat [ text "pushAtom: unhandled unlifted type" + , text "var:" <+> ppr var <+> dcolon <+> ppr varTy <> dcolon <+> ppr (typeKind varTy) + ] + return (unitOL (PUSH_G (getName var)), szb) + +pushAtom _ _ (StgLitArg lit) = pushLiteral True lit + +pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff) +pushLiteral padded lit = + do + platform <- targetPlatform <$> getDynFlags + let code :: PrimRep -> BcM (BCInstrList, ByteOff) + code rep = + -- TODO: It's a bit silly to use up to four instructions to put a single literal on the stack. + -- Lot's of better ways to do this. Add a instruction to push it as full word. + -- Store the literal as full word and push it as full word. + -- Maybe more, but for now this will do. + case platformByteOrder platform of + LittleEndian -> return (padding_instr `snocOL` instr, size_bytes + padding_bytes) + BigEndian -> return (instr `consOL` padding_instr, size_bytes + padding_bytes) + where + size_bytes = ByteOff $ primRepSizeB platform rep + + -- Here we handle the non-word-width cases specifically since we + -- must emit different bytecode for them. + + round_to_words (ByteOff bytes) = + ByteOff (roundUpToWords platform bytes) + + padding_bytes + | padded = round_to_words size_bytes - size_bytes + | otherwise = 0 + + (padding_instr, _) = pushPadding padding_bytes + + instr = + case size_bytes of + 1 -> PUSH_UBX8 lit + 2 -> PUSH_UBX16 lit + 4 -> PUSH_UBX32 lit + _ -> PUSH_UBX lit (bytesToWords platform size_bytes) + + case lit of + LitLabel {} -> code AddrRep + LitFloat {} -> code FloatRep + LitDouble {} -> code DoubleRep + LitChar {} -> code WordRep + LitNullAddr -> code AddrRep + LitString {} -> code AddrRep + LitRubbish _ rep-> case runtimeRepPrimRep (text "pushLiteral") rep of + [pr] -> code pr + _ -> pprPanic "pushLiteral" (ppr lit) + LitNumber nt _ -> case nt of + LitNumInt -> code IntRep + LitNumWord -> code WordRep + LitNumInt8 -> code Int8Rep + LitNumWord8 -> code Word8Rep + LitNumInt16 -> code Int16Rep + LitNumWord16 -> code Word16Rep + LitNumInt32 -> code Int32Rep + LitNumWord32 -> code Word32Rep + LitNumInt64 -> code Int64Rep + LitNumWord64 -> code Word64Rep + -- No LitNumBigNat should be left by the time this is called. CorePrep + -- should have converted them all to a real core representation. + LitNumBigNat -> panic "pushAtom: LitNumBigNat" + +-- | Push an atom for constructor (i.e., PACK instruction) onto the stack. +-- This is slightly different to @pushAtom@ due to the fact that we allow +-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@. +pushConstrAtom + :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff) +pushConstrAtom _ _ (StgLitArg lit) = pushLiteral False lit + +pushConstrAtom d p va@(StgVarArg v) + | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable + platform <- targetPlatform <$> getDynFlags + let !szb = idSizeCon platform v + done instr = do + let !off = d - d_v + return (unitOL (instr off), szb) + case szb of + 1 -> done PUSH8 + 2 -> done PUSH16 + 4 -> done PUSH32 + _ -> pushAtom d p va + +pushConstrAtom d p expr = pushAtom d p expr + +pushPadding :: ByteOff -> (BCInstrList, ByteOff) +pushPadding (ByteOff n) = go n (nilOL, 0) + where + go n acc@(!instrs, !off) = case n of + 0 -> acc + 1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1) + 2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2) + 3 -> go 1 (go 2 acc) + 4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4) + _ -> go (n - 4) (go 4 acc) + +-- ----------------------------------------------------------------------------- +-- Given a bunch of alts code and their discrs, do the donkey work +-- of making a multiway branch using a switch tree. +-- What a load of hassle! + +mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt + -- a hint; generates better code + -- Nothing is always safe + -> [(Discr, BCInstrList)] + -> BcM BCInstrList +mkMultiBranch maybe_ncons raw_ways = do + lbl_default <- getLabelBc + + let + mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList + mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default)) + -- shouldn't happen? + + mkTree [val] range_lo range_hi + | range_lo == range_hi + = return (snd val) + | null defaults -- Note [CASEFAIL] + = do lbl <- getLabelBc + return (testEQ (fst val) lbl + `consOL` (snd val + `appOL` (LABEL lbl `consOL` unitOL CASEFAIL))) + | otherwise + = return (testEQ (fst val) lbl_default `consOL` snd val) + + -- Note [CASEFAIL] + -- ~~~~~~~~~~~~~~~ + -- It may be that this case has no default + -- branch, but the alternatives are not exhaustive - this + -- happens for GADT cases for example, where the types + -- prove that certain branches are impossible. We could + -- just assume that the other cases won't occur, but if + -- this assumption was wrong (because of a bug in GHC) + -- then the result would be a segfault. So instead we + -- emit an explicit test and a CASEFAIL instruction that + -- causes the interpreter to barf() if it is ever + -- executed. + + mkTree vals range_lo range_hi + = let n = length vals `div` 2 + (vals_lo, vals_hi) = splitAt n vals + v_mid = fst (head vals_hi) + in do + label_geq <- getLabelBc + code_lo <- mkTree vals_lo range_lo (dec v_mid) + code_hi <- mkTree vals_hi v_mid range_hi + return (testLT v_mid label_geq + `consOL` (code_lo + `appOL` unitOL (LABEL label_geq) + `appOL` code_hi)) + + the_default + = case defaults of + [] -> nilOL + [(_, def)] -> LABEL lbl_default `consOL` def + _ -> panic "mkMultiBranch/the_default" + instrs <- mkTree notd_ways init_lo init_hi + return (instrs `appOL` the_default) + where + (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways + notd_ways = sortBy (comparing fst) not_defaults + + testLT (DiscrI i) fail_label = TESTLT_I i fail_label + testLT (DiscrI8 i) fail_label = TESTLT_I8 (fromIntegral i) fail_label + testLT (DiscrI16 i) fail_label = TESTLT_I16 (fromIntegral i) fail_label + testLT (DiscrI32 i) fail_label = TESTLT_I32 (fromIntegral i) fail_label + testLT (DiscrI64 i) fail_label = TESTLT_I64 (fromIntegral i) fail_label + testLT (DiscrW i) fail_label = TESTLT_W i fail_label + testLT (DiscrW8 i) fail_label = TESTLT_W8 (fromIntegral i) fail_label + testLT (DiscrW16 i) fail_label = TESTLT_W16 (fromIntegral i) fail_label + testLT (DiscrW32 i) fail_label = TESTLT_W32 (fromIntegral i) fail_label + testLT (DiscrW64 i) fail_label = TESTLT_W64 (fromIntegral i) fail_label + testLT (DiscrF i) fail_label = TESTLT_F i fail_label + testLT (DiscrD i) fail_label = TESTLT_D i fail_label + testLT (DiscrP i) fail_label = TESTLT_P i fail_label + testLT NoDiscr _ = panic "mkMultiBranch NoDiscr" + + testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label + testEQ (DiscrI8 i) fail_label = TESTEQ_I8 (fromIntegral i) fail_label + testEQ (DiscrI16 i) fail_label = TESTEQ_I16 (fromIntegral i) fail_label + testEQ (DiscrI32 i) fail_label = TESTEQ_I32 (fromIntegral i) fail_label + testEQ (DiscrI64 i) fail_label = TESTEQ_I64 (fromIntegral i) fail_label + testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label + testEQ (DiscrW8 i) fail_label = TESTEQ_W8 (fromIntegral i) fail_label + testEQ (DiscrW16 i) fail_label = TESTEQ_W16 (fromIntegral i) fail_label + testEQ (DiscrW32 i) fail_label = TESTEQ_W32 (fromIntegral i) fail_label + testEQ (DiscrW64 i) fail_label = TESTEQ_W64 (fromIntegral i) fail_label + testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label + testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label + testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label + testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr" + + -- None of these will be needed if there are no non-default alts + (init_lo, init_hi) = case notd_ways of + [] -> panic "mkMultiBranch: awesome foursome" + (discr, _):_ -> case discr of + DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) + DiscrI8 _ -> ( DiscrI8 minBound, DiscrI8 maxBound ) + DiscrI16 _ -> ( DiscrI16 minBound, DiscrI16 maxBound ) + DiscrI32 _ -> ( DiscrI32 minBound, DiscrI32 maxBound ) + DiscrI64 _ -> ( DiscrI64 minBound, DiscrI64 maxBound ) + DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) + DiscrW8 _ -> ( DiscrW8 minBound, DiscrW8 maxBound ) + DiscrW16 _ -> ( DiscrW16 minBound, DiscrW16 maxBound ) + DiscrW32 _ -> ( DiscrW32 minBound, DiscrW32 maxBound ) + DiscrW64 _ -> ( DiscrW64 minBound, DiscrW64 maxBound ) + DiscrF _ -> ( DiscrF minF, DiscrF maxF ) + DiscrD _ -> ( DiscrD minD, DiscrD maxD ) + DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) + NoDiscr -> panic "mkMultiBranch NoDiscr" + + (algMinBound, algMaxBound) + = case maybe_ncons of + -- XXX What happens when n == 0? + Just n -> (0, fromIntegral n - 1) + Nothing -> (minBound, maxBound) + + isNoDiscr NoDiscr = True + isNoDiscr _ = False + + dec (DiscrI i) = DiscrI (i-1) + dec (DiscrW w) = DiscrW (w-1) + dec (DiscrP i) = DiscrP (i-1) + dec other = other -- not really right, but if you + -- do cases on floating values, you'll get what you deserve + + -- same snotty comment applies to the following + minF, maxF :: Float + minD, maxD :: Double + minF = -1.0e37 + maxF = 1.0e37 + minD = -1.0e308 + maxD = 1.0e308 + + +-- ----------------------------------------------------------------------------- +-- Supporting junk for the compilation schemes + +-- Describes case alts +data Discr + = DiscrI Int + | DiscrI8 Int8 + | DiscrI16 Int16 + | DiscrI32 Int32 + | DiscrI64 Int64 + | DiscrW Word + | DiscrW8 Word8 + | DiscrW16 Word16 + | DiscrW32 Word32 + | DiscrW64 Word64 + | DiscrF Float + | DiscrD Double + | DiscrP Word16 + | NoDiscr + deriving (Eq, Ord) + +instance Outputable Discr where + ppr (DiscrI i) = int i + ppr (DiscrI8 i) = text (show i) + ppr (DiscrI16 i) = text (show i) + ppr (DiscrI32 i) = text (show i) + ppr (DiscrI64 i) = text (show i) + ppr (DiscrW w) = text (show w) + ppr (DiscrW8 w) = text (show w) + ppr (DiscrW16 w) = text (show w) + ppr (DiscrW32 w) = text (show w) + ppr (DiscrW64 w) = text (show w) + ppr (DiscrF f) = text (show f) + ppr (DiscrD d) = text (show d) + ppr (DiscrP i) = ppr i + ppr NoDiscr = text "DEF" + + +lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff +lookupBCEnv_maybe = Map.lookup + +idSizeW :: Platform -> Id -> WordOff +idSizeW platform = WordOff . argRepSizeW platform . idArgRep platform + +idSizeCon :: Platform -> Id -> ByteOff +idSizeCon platform var + -- unboxed tuple components are padded to word size + | isUnboxedTupleType (idType var) || + isUnboxedSumType (idType var) = + wordsToBytes platform . + WordOff . sum . map (argRepSizeW platform . toArgRep platform) . + typePrimRep . idType $ var + | otherwise = ByteOff (primRepSizeB platform (idPrimRepU var)) + +repSizeWords :: Platform -> PrimOrVoidRep -> WordOff +repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRepOrV platform rep) + +isFollowableArg :: ArgRep -> Bool +isFollowableArg P = True +isFollowableArg _ = False + +-- | Indicate if the calling convention is supported +isSupportedCConv :: CCallSpec -> Bool +isSupportedCConv (CCallSpec _ cconv _) = case cconv of + CCallConv -> True -- we explicitly pattern match on every + StdCallConv -> False -- convention to ensure that a warning + PrimCallConv -> True -- is triggered when a new one is added + JavaScriptCallConv -> False + CApiConv -> True + +-- See bug #10462 +unsupportedCConvException :: a +unsupportedCConvException = throwGhcException (ProgramError + ("Error: bytecode compiler can't handle some foreign calling conventions\n"++ + " Workaround: use -fobject-code, or compile this module to .o separately.")) + +mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr +mkSlideB platform nb db = mkSlideW n d + where + !n = bytesToWords platform nb + !d = bytesToWords platform db + +mkSlideW :: WordOff -> WordOff -> OrdList BCInstr +mkSlideW !n !ws + | ws == 0 + = nilOL + | otherwise + = unitOL (SLIDE n $ fromIntegral ws) + + + +atomRep :: Platform -> StgArg -> ArgRep +atomRep platform e = toArgRepOrV platform (stgArgRep1 e) + +-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which +-- has initial depth @original_depth@. Return the values which the stack +-- environment should map these items to. +mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] +mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) + +typeArgReps :: Platform -> Type -> [ArgRep] +typeArgReps platform = map (toArgRep platform) . typePrimRep + +-- ----------------------------------------------------------------------------- +-- The bytecode generator's monad + +-- | Read only environment for generating ByteCode +data BcM_Env + = BcM_Env + { bcm_hsc_env :: !HscEnv + , bcm_module :: !Module -- current module (for breakpoints) + , modBreaks :: !(Maybe ModBreaks) + , last_bp_tick :: !(Maybe StgTickish) + } + +data BcM_State + = BcM_State + { nextlabel :: !Word32 -- ^ For generating local labels + , breakInfoIdx :: !Int -- ^ Next index for breakInfo array + , breakInfo :: !(IntMap CgBreakInfo) + -- ^ Info at breakpoints occurrences. Indexed with + -- 'InternalBreakpointId'. See Note [Breakpoint identifiers] in + -- GHC.ByteCode.Breakpoints. + } + +newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (r, BcM_State)) + deriving (Functor, Applicative, Monad, MonadIO) + via (ReaderT BcM_Env (StateT BcM_State IO)) + +runBc :: HscEnv -> Module -> Maybe ModBreaks -> BcM r -> IO (r, BcM_State) +runBc hsc_env this_mod mbs (BcM m) + = m (BcM_Env hsc_env this_mod mbs Nothing) (BcM_State 0 0 IntMap.empty) + +instance HasDynFlags BcM where + getDynFlags = hsc_dflags <$> getHscEnv + +getHscEnv :: BcM HscEnv +getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st) + +getProfile :: BcM Profile +getProfile = targetProfile <$> getDynFlags + +shouldAddBcoName :: BcM (Maybe Module) +shouldAddBcoName = do + add <- gopt Opt_AddBcoName <$> getDynFlags + if add + then Just <$> getCurrentModule + else return Nothing + +getLabelBc :: BcM LocalLabel +getLabelBc = BcM $ \_ st -> + do let nl = nextlabel st + when (nl == maxBound) $ + panic "getLabelBc: Ran out of labels" + return (LocalLabel nl, st{nextlabel = nl + 1}) + +getLabelsBc :: Word32 -> BcM [LocalLabel] +getLabelsBc n = BcM $ \_ st -> + let ctr = nextlabel st + in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n}) + +newBreakInfo :: CgBreakInfo -> BcM (Maybe InternalBreakpointId) +newBreakInfo info = BcM $ \env st -> do + -- if we're not generating ModBreaks for this module for some reason, we + -- can't store breakpoint occurrence information. + case modBreaks env of + Nothing -> pure (Nothing, st) + Just modBreaks -> do + let ix = breakInfoIdx st + st' = st + { breakInfo = IntMap.insert ix info (breakInfo st) + , breakInfoIdx = ix + 1 + } + return (Just $ InternalBreakpointId (modBreaks_module modBreaks) ix, st') + +getCurrentModule :: BcM Module +getCurrentModule = BcM $ \env st -> return (bcm_module env, st) + +withBreakTick :: StgTickish -> BcM a -> BcM a +withBreakTick bp (BcM act) = BcM $ \env st -> + act env{last_bp_tick=Just bp} st + +getLastBreakTick :: BcM (Maybe StgTickish) +getLastBreakTick = BcM $ \env st -> + pure (last_bp_tick env, st) + +tickFS :: FastString +tickFS = fsLit "ticked" + +-- Dehydrating CgBreakInfo + +dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo +dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid = + CgBreakInfo + { cgb_tyvars = map toIfaceTvBndr ty_vars + , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets + , cgb_resty = toIfaceType tick_ty + , cgb_tick_id = bid + } diff --git a/GHC/StgToCmm.hs b/GHC/StgToCmm.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm.hs @@ -0,0 +1,352 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm ( codeGen ) where + +import GHC.Prelude as Prelude + +import GHC.Cmm.UniqueRenamer +import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Env +import GHC.StgToCmm.Bind +import GHC.StgToCmm.DataCon +import GHC.StgToCmm.Layout +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config +import GHC.StgToCmm.Ticky +import GHC.StgToCmm.Types (ModuleLFInfos) +import GHC.StgToCmm.CgUtils (CgStream) + +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.Cmm.Graph + +import GHC.Stg.Syntax + +import GHC.Types.CostCentre +import GHC.Types.IPE +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.RepType +import GHC.Types.Basic +import GHC.Types.Var.Set ( isEmptyDVarSet ) +import GHC.Types.Unique.DFM +import GHC.Types.Unique.FM +import GHC.Types.Name.Env + +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Multiplicity + + +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Logger + +import GHC.Utils.TmpFs + +import GHC.Data.Stream +import GHC.Data.OrdList + +import Control.Monad (when,void, forM_) +import GHC.Utils.Misc +import System.IO.Unsafe +import qualified Data.ByteString as BS +import Data.IORef +import GHC.Utils.Panic + +codeGen :: Logger + -> TmpFs + -> StgToCmmConfig + -> InfoTableProvMap + -> [TyCon] + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> [CgStgTopBinding] -- Bindings to convert + -> CgStream CmmGroup (ModuleLFInfos, DetUniqFM) -- See Note [Deterministic Uniques in the CG] on CgStream + -- Output as a stream, so codegen can + -- be interleaved with output + +codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) tycons + cost_centre_info stg_binds + = do { -- cg: run the code generator, and yield the resulting CmmGroup + -- Using an IORef to store the state is a bit crude, but otherwise + -- we would need to add a state monad layer which regresses + -- allocations by 0.5-2%. + ; cgref <- liftIO $ initC >>= \s -> newIORef s + ; uniqRnRef <- liftIO $ newIORef emptyDetUFM + ; let fstate = initFCodeState $ stgToCmmPlatform cfg + ; let cg :: FCode a -> CgStream CmmGroup a + cg fcode = do + (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do + st <- readIORef cgref + + rnm0 <- readIORef uniqRnRef + + let + ((a, cmm), st') = runC cfg fstate st (getCmm fcode) + (rnm1, cmm_renamed) = + -- Enable deterministic object code generation by + -- renaming uniques deterministically. + -- See Note [Object determinism] + if stgToCmmObjectDeterminism cfg + then detRenameCmmGroup rnm0 cmm -- The yielded cmm will already be renamed. + else (rnm0, removeDeterm cmm) + + -- NB. stub-out cgs_tops and cgs_stmts. This fixes + -- a big space leak. DO NOT REMOVE! + -- This is observed by the #3294 test + writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop }) + writeIORef uniqRnRef $! rnm1 + + return (a, cmm_renamed) + yield cmm + return a + + ; cg (mkModuleInit cost_centre_info) + + ; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds + -- Put datatype_stuff (cgTyCon) after code_stuff (cgTopBinding), because the + -- datatype closure table (for enumeration types) to + -- (say) PrelBase_True_closure, which is defined in + -- code_stuff + + ; mapM_ (cg . cgTyCon) tycons + + -- Emit special info tables for everything used in this module + -- This will only do something if `-fdistinct-info-tables` is turned on. + ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (eltsUDFM denv) + + ; final_state <- liftIO (readIORef cgref) + ; let cg_id_infos = cgs_binds final_state + + -- See Note [Conveying CAF-info and LFInfo between modules] in + -- GHC.StgToCmm.Types + ; let extractInfo info = (name, lf) + where + !name = idName (cg_id info) + !lf = cg_lf info + + !generatedInfo + | stgToCmmOmitIfPragmas cfg + = emptyNameEnv + | otherwise + = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos)) + + ; rn_mapping <- liftIO (readIORef uniqRnRef) + ; liftIO $ debugTraceMsg logger 3 (text "DetRnM mapping:" <+> ppr rn_mapping) + + ; return (generatedInfo, rn_mapping) + } + +{- +Note [Object determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Object determinism means that GHC, for the same exact input, produces, +deterministically, byte-for-byte identical objects (.o files, executables, +libraries...) on separate multi-threaded runs. + +Deterministic objects are critical, for instance, for reproducible software +packaging and distribution, or build systems with content-sensitive +recompilation avoidance. + +The main cause of non-determinism in objects comes from the non-deterministic +uniques leaking into the generated code. Apart from uniques previously affecting +determinism both directly by showing up in symbol labels and indirectly, e.g. in +the CLabel Ord instance, GHC already did a lot deterministically (modulo bugs) +by the time we set out to achieve full object determinism: + +* The Simplifier is deterministic in the optimisations it applies (c.f. #25170) + +* Interface files are deterministic (which depends on the previous bullet) + +* The Cmm/NCG pipeline processes sections in a deterministic order, so the final + object sections, closures, data, etc., are already always outputted in the + same order for the same module. + +Beyond fixing small bugs in the above bullets and other smaller non-determinism +leaks like the Ord instance of CLabels, we must ensure that/do the following to +make GHC produce fully deterministic objects: + +* In STG -> Cmm, deterministically /rename/ all non-external uniques in the Cmm + chunk, deterministically, before yielding. See Note [Renaming uniques deterministically] + in GHC.Cmm.UniqueRenamer. This pass is necessary for object determinism but + is currently guarded by -fobject-determinism. + +* Multiple Cmm passes work with non-deterministic @LabelMap@s -- that doesn't + change since they are both important for performance and do not affect the + determinism of the end result. As after the renaming pass the uniques are all + produced deterministically, the orderings observable by the map are also going + to be deterministic. In the brief period before a CmmGroup has been renamed, + a list instead of LabelMap is used to preserve the ordering. + See Note [DCmmGroup vs CmmGroup or: Deterministic Info Tables] in GHC.Cmm. + +* In the code generation pipeline from Cmm onwards, when new uniques need to be + created for a given pass, use @UniqDSM@ instead of the previously used @UniqSM@. + @UniqDSM@ supplies uniques iteratively, guaranteeing uniques produced by the + backend are deterministic accross runs. + See Note [Deterministic Uniques in the CG] in GHC.Types.Unique.DSM. + +Also, c.f. Note [Unique Determinism] +-} + + +--------------------------------------------------------------- +-- Top-level bindings +--------------------------------------------------------------- + +{- 'cgTopBinding' is only used for top-level bindings, since they need +to be allocated statically (not in the heap) and need to be labelled. +No unboxed bindings can happen at top level. + +In the code below, the static bindings are accumulated in the +@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@. +This is so that we can write the top level processing in a compositional +style, with the increasing static environment being plumbed as a state +variable. -} + +cgTopBinding :: Logger -> TmpFs -> StgToCmmConfig -> CgStgTopBinding -> FCode () +cgTopBinding logger tmpfs cfg = \case + StgTopLifted (StgNonRec id rhs) -> do + let (info, fcode) = cgTopRhs cfg NonRecursive id rhs + fcode + addBindC info + + StgTopLifted (StgRec pairs) -> do + let (bndrs, rhss) = unzip pairs + let pairs' = zip bndrs rhss + r = unzipWith (cgTopRhs cfg Recursive) pairs' + (infos, fcodes) = unzip r + addBindsC infos + sequence_ fcodes + + StgTopStringLit id str -> do + let label = mkBytesLabel (idName id) + -- emit either a CmmString literal or dump the string in a file and emit a + -- CmmFileEmbed literal. If binary blobs aren't supported, + -- the threshold in `cfg` will be 0. + -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr + let asString = case stgToCmmBinBlobThresh cfg of + Just bin_blob_threshold -> fromIntegral (BS.length str) <= bin_blob_threshold + Nothing -> True + + (lit,decl) = if asString + then mkByteStringCLit label str + else unsafePerformIO $ do + bFile <- newTempName logger tmpfs (stgToCmmTmpDir cfg) TFL_CurrentModule ".dat" + BS.writeFile bFile str + return $ mkFileEmbedLit label bFile (BS.length str) + emitDecl decl + addBindC (litIdInfo (stgToCmmPlatform cfg) id mkLFStringLit lit) + + +cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) + -- The Id is passed along for setting up a binding... + +cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args _typ) + = cgTopRhsCon cfg bndr con mn (assertNonVoidStgArgs args) + -- con args are always non-void, + -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise + +cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body _typ) + = assertPpr (isEmptyDVarSet fvs) (text "fvs:" <> ppr fvs) $ -- There should be no free variables + cgTopRhsClosure (stgToCmmPlatform cfg) rec bndr cc upd_flag args body + + +--------------------------------------------------------------- +-- Module initialisation code +--------------------------------------------------------------- + +mkModuleInit + :: CollectedCCs -- cost centre info + -> FCode () + +mkModuleInit cost_centre_info + = do { initCostCentres cost_centre_info + } + + +--------------------------------------------------------------- +-- Generating static stuff for algebraic data types, including +-- * entry code for each data con +-- * info table for each data con +-- * for enumerations, a table of all the closures +--------------------------------------------------------------- + +--------------------------------------------------------------- +-- Data type constructors +--------------------------------------------------------------- +cgTyCon :: TyCon -> FCode () +-- Generate static data for each algebraic data type +cgTyCon tycon + | not (isBoxedDataTyCon tycon) -- Type families, newtypes, and `type data` constructors + = return () + + | otherwise -- An honest-to-goodness algebraic data type + = do { -- Emit normal info_tables, for data constructors defined in this module. + mapM_ (cgDataCon DefinitionSite) (tyConDataCons tycon) + + ; when (isEnumerationTyCon tycon) $ + cgEnumerationTyCon tycon } + +cgEnumerationTyCon :: TyCon -> FCode () +-- Generate a table of static closures for an enumeration type. +-- Note that the closure pointers in the table are tagged. +cgEnumerationTyCon tycon + = do platform <- getPlatform + emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs) + [ CmmLabelOff (mkClosureLabel (dataConName con) NoCafRefs) + (tagForCon platform con) + | con <- tyConDataCons tycon] + +cgDataCon :: ConInfoTableLocation -> DataCon -> FCode () +-- Generate the entry code, info tables, and (for niladic constructor) +-- the static closure, for a constructor. +cgDataCon mn data_con + = do { massert (not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con)) + ; profile <- getProfile + ; platform <- getPlatform + ; let + (tot_wds, -- #ptr_wds + #nonptr_wds + ptr_wds) -- #ptr_wds + = mkVirtConstrSizes profile arg_reps + + nonptr_wds = tot_wds - ptr_wds + + dyn_info_tbl = + mkDataConInfoTable profile data_con mn False ptr_wds nonptr_wds + + -- We're generating info tables, so we don't know and care about + -- what the actual arguments are. Using () here as the place holder. + arg_reps :: [PrimRep] + arg_reps = [ rep_ty + | ty <- dataConRepArgTys data_con + , rep_ty <- typePrimRep (scaledThing ty) + ] + + ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $ + -- NB: the closure pointer is assumed *untagged* on + -- entry to a constructor. If the pointer is tagged, + -- then we should not be entering it. This assumption + -- is used in ldvEnter and when tagging the pointer to + -- return it. + -- NB 2: We don't set CC when entering data (WDP 94/06) + do { tickyEnterDynCon + ; let node = CmmReg $ nodeReg platform + ; ldvEnter node + ; tickyReturnOldCon (length arg_reps) + ; void $ emitReturn [cmmOffsetB platform node (tagForCon platform data_con)] + } + -- The case continuation code expects a tagged pointer + } diff --git a/GHC/StgToCmm/ArgRep.hs b/GHC/StgToCmm/ArgRep.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/ArgRep.hs @@ -0,0 +1,172 @@ +----------------------------------------------------------------------------- +-- +-- Argument representations used in GHC.StgToCmm.Layout. +-- +-- (c) The University of Glasgow 2013 +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToCmm.ArgRep ( + ArgRep(..), toArgRep, toArgRepOrV, argRepSizeW, + + argRepString, isNonV, idArgRep, + + slowCallPattern, + + ) where + +import GHC.Prelude +import GHC.Platform + +import GHC.StgToCmm.Closure ( idPrimRep1 ) +import GHC.Runtime.Heap.Layout ( WordOff ) +import GHC.Types.Id ( Id ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primElemRepSizeB ) +import GHC.Types.Basic ( RepArity ) +import GHC.Settings.Constants ( wORD64_SIZE, dOUBLE_SIZE ) + +import GHC.Utils.Outputable +import GHC.Data.FastString + +-- I extricated this code as this new module in order to avoid a +-- cyclic dependency between GHC.StgToCmm.Layout and GHC.StgToCmm.Ticky. +-- +-- NSF 18 Feb 2013 + +------------------------------------------------------------------------- +-- Classifying arguments: ArgRep +------------------------------------------------------------------------- + +-- ArgRep is re-exported by GHC.StgToCmm.Layout, but only for use in the +-- byte-code generator which also needs to know about the +-- classification of arguments. + +data ArgRep = P -- GC Ptr + | N -- Word-sized non-ptr + | L -- 64-bit non-ptr (long) + | V -- Void + | F -- Float + | D -- Double + | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc. + | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc. + | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc. + deriving ( Eq, Ord ) +instance Outputable ArgRep where ppr = text . argRepString + +argRepString :: ArgRep -> String +argRepString P = "P" +argRepString N = "N" +argRepString L = "L" +argRepString V = "V" +argRepString F = "F" +argRepString D = "D" +argRepString V16 = "V16" +argRepString V32 = "V32" +argRepString V64 = "V64" + +toArgRep :: Platform -> PrimRep -> ArgRep +toArgRep platform rep = case rep of + BoxedRep _ -> P + IntRep -> N + WordRep -> N + Int8Rep -> N -- Gets widened to native word width for calls + Word8Rep -> N -- Gets widened to native word width for calls + Int16Rep -> N -- Gets widened to native word width for calls + Word16Rep -> N -- Gets widened to native word width for calls + Int32Rep -> N -- Gets widened to native word width for calls + Word32Rep -> N -- Gets widened to native word width for calls + AddrRep -> N + Int64Rep -> case platformWordSize platform of + PW4 -> L + PW8 -> N + Word64Rep -> case platformWordSize platform of + PW4 -> L + PW8 -> N + FloatRep -> F + DoubleRep -> D + (VecRep len elem) -> case len*primElemRepSizeB platform elem of + 16 -> V16 + 32 -> V32 + 64 -> V64 + _ -> error "toArgRep: bad vector primrep" + +toArgRepOrV :: Platform -> PrimOrVoidRep -> ArgRep +toArgRepOrV _ VoidRep = V +toArgRepOrV platform (NVRep rep) = toArgRep platform rep + +isNonV :: ArgRep -> Bool +isNonV V = False +isNonV _ = True + +argRepSizeW :: Platform -> ArgRep -> WordOff -- Size in words +argRepSizeW platform = \case + N -> 1 + P -> 1 + F -> 1 + L -> wORD64_SIZE `quot` ws + D -> dOUBLE_SIZE `quot` ws + V -> 0 + V16 -> 16 `quot` ws + V32 -> 32 `quot` ws + V64 -> 64 `quot` ws + where + ws = platformWordSizeInBytes platform + +idArgRep :: Platform -> Id -> ArgRep +idArgRep platform = toArgRepOrV platform . idPrimRep1 + +-- This list of argument patterns should be kept in sync with at least +-- the following: +-- +-- * GHC.StgToCmm.Layout.stdPattern maybe to some degree? +-- +-- * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast) +-- declarations in rts/include/stg/MiscClosures.h +-- +-- * the SLOW_CALL_*_ctr declarations in rts/include/stg/Ticky.h, +-- +-- * the TICK_SLOW_CALL_*() #defines in rts/include/Cmm.h, +-- +-- * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c, +-- +-- * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and +-- SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c +-- +-- There may be more places that I haven't found; I merely igrep'd for +-- pppppp and excluded things that seemed ghci-specific. +-- +-- Also, it seems at the moment that ticky counters with void +-- arguments will never be bumped, but I'm still declaring those +-- counters, defensively. +-- +-- NSF 6 Mar 2013 + +slowCallPattern :: [ArgRep] -> (FastString, RepArity) +-- Returns the generic apply function and arity +-- +-- The first batch of cases match (some) specialised entries +-- The last group deals exhaustively with the cases for the first argument +-- (and the zero-argument case) +-- +-- In 99% of cases this function will match *all* the arguments in one batch + +slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6) +slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5) +slowCallPattern (P: P: P: P: _) = (fsLit "stg_ap_pppp", 4) +slowCallPattern (P: P: P: V: _) = (fsLit "stg_ap_pppv", 4) +slowCallPattern (P: P: P: _) = (fsLit "stg_ap_ppp", 3) +slowCallPattern (P: P: V: _) = (fsLit "stg_ap_ppv", 3) +slowCallPattern (P: P: _) = (fsLit "stg_ap_pp", 2) +slowCallPattern (P: V: _) = (fsLit "stg_ap_pv", 2) +slowCallPattern (P: _) = (fsLit "stg_ap_p", 1) +slowCallPattern (V: _) = (fsLit "stg_ap_v", 1) +slowCallPattern (N: _) = (fsLit "stg_ap_n", 1) +slowCallPattern (F: _) = (fsLit "stg_ap_f", 1) +slowCallPattern (D: _) = (fsLit "stg_ap_d", 1) +slowCallPattern (L: _) = (fsLit "stg_ap_l", 1) +slowCallPattern (V16: _) = (fsLit "stg_ap_v16", 1) +slowCallPattern (V32: _) = (fsLit "stg_ap_v32", 1) +slowCallPattern (V64: _) = (fsLit "stg_ap_v64", 1) +slowCallPattern [] = (fsLit "stg_ap_0", 0) diff --git a/GHC/StgToCmm/Bind.hs b/GHC/StgToCmm/Bind.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Bind.hs @@ -0,0 +1,902 @@ +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation: bindings +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Bind ( + cgTopRhsClosure, + cgBind, + emitBlackHoleCode, + pushUpdateFrame, emitUpdateFrame + ) where + +import GHC.Prelude hiding ((<*>)) + +import GHC.Core ( AltCon(..) ) +import GHC.Core.Opt.Arity( isOneShotBndr ) +import GHC.Runtime.Heap.Layout +import GHC.Unit.Module + +import GHC.Stg.Syntax + +import GHC.Platform +import GHC.Platform.Profile + +import GHC.Builtin.Names (unpackCStringName, unpackCStringUtf8Name) + +import GHC.StgToCmm.Config +import GHC.StgToCmm.Expr +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Env +import GHC.StgToCmm.DataCon +import GHC.StgToCmm.Heap +import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk, + initUpdFrameProf) +import GHC.StgToCmm.TagCheck +import GHC.StgToCmm.Ticky +import GHC.StgToCmm.Layout +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Closure +import GHC.StgToCmm.Foreign (emitPrimCall) + +import GHC.Cmm.Graph +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Info +import GHC.Cmm.Utils +import GHC.Cmm.CLabel + +import GHC.Stg.Utils +import GHC.Types.CostCentre +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Tickish ( tickishIsCode ) + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.FastString +import GHC.Data.List.SetOps + +import Control.Monad + +------------------------------------------------------------------------ +-- Top-level bindings +------------------------------------------------------------------------ + +-- For closures bound at top level, allocate in static space. +-- They should have no free variables. + +cgTopRhsClosure :: Platform + -> RecFlag -- member of a recursive group? + -> Id + -> CostCentreStack -- Optional cost centre annotation + -> UpdateFlag + -> [Id] -- Args + -> CgStgExpr + -> (CgIdInfo, FCode ()) + +cgTopRhsClosure platform rec id ccs upd_flag args body = + let closure_label = mkClosureLabel (idName id) (idCafInfo id) + cg_id_info = litIdInfo platform id lf_info (CmmLabel closure_label) + lf_info = mkClosureLFInfo platform id TopLevel [] upd_flag args + in (cg_id_info, gen_code lf_info closure_label) + where + + gen_code :: LambdaFormInfo -> CLabel -> FCode () + + -- special case for a indirection (f = g). We create an IND_STATIC + -- closure pointing directly to the indirectee. This is exactly + -- what the CAF will eventually evaluate to anyway, we're just + -- shortcutting the whole process, and generating a lot less code + -- (#7308). Eventually the IND_STATIC closure will be eliminated + -- by assembly '.equiv' directives, where possible (#15155). + -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". + -- + -- Note: we omit the optimisation when this binding is part of a + -- recursive group, because the optimisation would inhibit the black + -- hole detection from working in that case. Test + -- concurrent/should_run/4030 fails, for instance. + -- + gen_code _ closure_label + | StgApp f [] <- body + , null args + , isNonRec rec + = do + cg_info <- getCgIdInfo f + emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)] + + -- Emit standard stg_unpack_cstring closures for top-level unpackCString# thunks. + -- + -- Note that we do not do this for thunks enclosured in code ticks (e.g. hpc + -- ticks) since we want to ensure that these ticks are not lost (e.g. + -- resulting in Strings being reported by hpc as uncovered). However, we + -- don't worry about standard profiling ticks since unpackCString tends not + -- be terribly interesting in profiles. See Note [unpack_cstring closures] in + -- StgStdThunks.cmm. + gen_code _ closure_label + | null args + , Just gen <- isUnpackCStringClosure body + = do (info, lit) <- gen + emitDecl $ CmmData (Section Data closure_label) $ + CmmStatics closure_label info ccs [] [lit] + + gen_code lf_info _closure_label + = do { profile <- getProfile + ; let name = idName id + ; mod_name <- getModuleName + ; let descr = closureDescription mod_name name + closure_info = mkClosureInfo profile True id lf_info 0 0 descr + + -- We don't generate the static closure here, because we might + -- want to add references to static closures to it later. The + -- static closure is generated by GHC.Cmm.Info.Build.updInfoSRTs, + -- See Note [SRTs], specifically the [FUN] optimisation. + + ; let fv_details :: [(NonVoid Id, ByteOff)] + header = if isLFThunk lf_info then ThunkHeader else StdHeader + (_, _, fv_details) = mkVirtHeapOffsets profile header [] + -- Don't drop the non-void args until the closure info has been made + ; forkClosureBody (closureCodeBody True id closure_info ccs + args body fv_details) + + ; return () } + + unLit (CmmLit l) = l + unLit _ = panic "unLit" + +isUnpackCStringClosure :: CgStgExpr -> Maybe (FCode (CmmInfoTable, CmmLit)) +isUnpackCStringClosure body = case stripStgTicksTopE (not . tickishIsCode) body of + StgApp f [arg] + | Just unpack <- is_string_unpack_op f + -> Just $ do + arg' <- getArgAmode (NonVoid arg) + case arg' of + CmmLit lit -> do + let info = CmmInfoTable + { cit_lbl = unpack + , cit_rep = HeapRep True 0 1 Thunk + , cit_prof = NoProfilingInfo + , cit_srt = Nothing + , cit_clo = Nothing + } + return (info, lit) + _ -> panic "isUnpackCStringClosure: not a lit" + StgCase (StgLit l) b _ [alt] + -- In -O0, we might get strings that haven't been floated to top-level, e.g., + -- case "undefined"# of sat { + -- __DEFAULT -> unpackCString# sat + -- } + -- This case is supposed to catch that. + | Just gen <- isUnpackCStringClosure (alt_rhs alt) + -> Just $ do + e <- cgLit l + addBindC (mkCgIdInfo b mkLFStringLit e) + gen + _ -> Nothing + where + is_string_unpack_op f + | idName f == unpackCStringName = Just mkRtsUnpackCStringLabel + | idName f == unpackCStringUtf8Name = Just mkRtsUnpackCStringUtf8Label + | otherwise = Nothing + +------------------------------------------------------------------------ +-- Non-top-level bindings +------------------------------------------------------------------------ + +cgBind :: CgStgBinding -> FCode () +cgBind (StgNonRec name rhs) + = do { (info, fcode) <- cgRhs name rhs + ; addBindC info + ; init <- fcode + ; emit init } + -- init cannot be used in body, so slightly better to sink it eagerly + +cgBind (StgRec pairs) + = do { r <- sequence $ unzipWith cgRhs pairs + ; let (id_infos, fcodes) = unzip r + ; addBindsC id_infos + ; (inits, body) <- getCodeR $ sequence fcodes + ; emit (catAGraphs inits <*> body) } + +{- Note [cgBind rec] + ~~~~~~~~~~~~~~~~~ + Recursive let-bindings are tricky. + Consider the following pseudocode: + + let x = \_ -> ... y ... + y = \_ -> ... z ... + z = \_ -> ... x ... + in ... + + For each binding, we need to allocate a closure, and each closure must + capture the address of the other closures. + We want to generate the following C-- code: + // Initialization Code + x = hp - 24; // heap address of x's closure + y = hp - 40; // heap address of x's closure + z = hp - 64; // heap address of x's closure + // allocate and initialize x + m[hp-8] = ... + m[hp-16] = y // the closure for x captures y + m[hp-24] = x_info; + // allocate and initialize y + m[hp-32] = z; // the closure for y captures z + m[hp-40] = y_info; + // allocate and initialize z + ... + + For each closure, we must generate not only the code to allocate and + initialize the closure itself, but also some initialization Code that + sets a variable holding the closure pointer. + + We could generate a pair of the (init code, body code), but since + the bindings are recursive we also have to initialise the + environment with the CgIdInfo for all the bindings before compiling + anything. So we do this in 3 stages: + + 1. collect all the CgIdInfos and initialise the environment + 2. compile each binding into (init, body) code + 3. emit all the inits, and then all the bodies + + We'd rather not have separate functions to do steps 1 and 2 for + each binding, since in practice they share a lot of code. So we + have just one function, cgRhs, that returns a pair of the CgIdInfo + for step 1, and a monadic computation to generate the code in step + 2. + + The alternative to separating things in this way is to use a + fixpoint. That's what we used to do, but it introduces a + maintenance nightmare because there is a subtle dependency on not + being too strict everywhere. Doing things this way means that the + FCode monad can be strict, for example. + -} + +cgRhs :: Id + -> CgStgRhs + -> FCode ( + CgIdInfo -- The info for this binding + , FCode CmmAGraph -- A computation which will generate the + -- code for the binding, and return an + -- assignment of the form "x = Hp - n" + -- (see above) + ) + +cgRhs id (StgRhsCon cc con mn _ts args _typ) + = 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 _typ) + = do + profile <- getProfile + check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig + use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig + mkRhsClosure profile use_std_ap_thunk check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body + +------------------------------------------------------------------------ +-- Non-constructor right hand sides +------------------------------------------------------------------------ + +mkRhsClosure :: Profile + -> Bool -- Omit AP Thunks to improve profiling + -> Bool -- Lint tag inference checks + -> Id -> CostCentreStack + -> [NonVoid Id] -- Free vars + -> UpdateFlag + -> [Id] -- Args + -> CgStgExpr + -> FCode (CgIdInfo, FCode CmmAGraph) + +{- mkRhsClosure looks for two special forms of the right-hand side: + a) selector thunks + b) AP thunks + +If neither happens, it just calls mkClosureLFInfo. You might think +that mkClosureLFInfo should do all this, but it seems wrong for the +latter to look at the structure of an expression + +Note [Selectors] +~~~~~~~~~~~~~~~~ +We look at the body of the closure to see if it's a selector---turgid, +but nothing deep. We are looking for a closure of {\em exactly} the +form: + +... = [the_fv] \ u [] -> + case the_fv of + con a_1 ... a_n -> a_i + +Note [Ap thunks] +~~~~~~~~~~~~~~~~ +A more generic AP thunk of the form + + x = [ x_1...x_n ] \.. [] -> x_1 ... x_n + +A set of these is compiled statically into the RTS, so we just use +those. We could extend the idea to thunks where some of the x_i are +global ids (and hence not free variables), but this would entail +generating a larger thunk. It might be an option for non-optimising +compilation, though. + +We only generate an Ap thunk if all the free variables are pointers, +for semi-obvious reasons. + +-} + +---------- See Note [Selectors] ------------------ +mkRhsClosure profile _ _check_tags bndr _cc + [NonVoid the_fv] -- Just one free var + upd_flag -- Updatable thunk + [] -- A thunk + expr + | let strip = stripStgTicksTopE (not . tickishIsCode) + , StgCase (StgApp scrutinee [{-no args-}]) + _ -- ignore bndr + (AlgAlt _) + [GenStgAlt{ alt_con = DataAlt _ + , alt_bndrs = params + , alt_rhs = sel_expr}] <- strip expr + , StgApp selectee [{-no args-}] <- strip sel_expr + , the_fv == scrutinee -- Scrutinee is the only free variable + + , let (_, _, params_w_offsets) = mkVirtConstrOffsets profile (addIdReps (assertNonVoidIds params)) + -- pattern binders are always non-void, + -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise + , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee) + + , let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset + - fixedHdrSizeW profile + , offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough + = -- NOT TRUE: assert (is_single_constructor) + -- The simplifier may have statically determined that the single alternative + -- is the only possible case and eliminated the others, even if there are + -- other constructors in the datatype. It's still ok to make a selector + -- thunk in this case, because we *know* which constructor the scrutinee + -- will evaluate to. + -- + -- srt is discarded; it must be empty + let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) + in cgRhsStdThunk bndr lf_info [StgVarArg the_fv] + +---------- See Note [Ap thunks] ------------------ +mkRhsClosure profile use_std_ap check_tags bndr _cc + fvs + upd_flag + [] -- No args; a thunk + (StgApp fun_id args) + + -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure + -- of form (x1 x2 .... xn), where all the xi are locals (not top-level) + -- So the xi will all be free variables + | use_std_ap + , args `lengthIs` (n_fvs-1) -- This happens only if the fun_id and + -- args are all distinct local variables + -- The "-1" is for fun_id + -- Missed opportunity: (f x x) is not detected + , all (isGcPtrRep . idPrimRepU . fromNonVoid) fvs + , isUpdatable upd_flag + , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile) + , not (profileIsProfiling profile) + -- not when profiling: we don't want to + -- lose information about this particular + -- thunk (e.g. its type) (#949) + , idArity fun_id == unknownArity -- don't spoil a known call + -- Ha! an Ap thunk + , not check_tags -- See Note [EPT enforcement debugging] + = cgRhsStdThunk bndr lf_info payload + + where + n_fvs = length fvs + lf_info = mkApLFInfo bndr upd_flag n_fvs + -- the payload has to be in the correct order, hence we can't + -- just use the fvs. + payload = StgVarArg fun_id : args + +---------- Default case ------------------ +mkRhsClosure profile _use_ap _check_tags bndr cc fvs upd_flag args body + = do { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args + ; (id_info, reg) <- rhsIdInfo bndr lf_info + ; return (id_info, gen_code lf_info reg) } + where + gen_code lf_info reg + = do { -- LAY OUT THE OBJECT + -- If the binder is itself a free variable, then don't store + -- it in the closure. Instead, just bind it to Node on entry. + -- NB we can be sure that Node will point to it, because we + -- haven't told mkClosureLFInfo about this; so if the binder + -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is* + -- stored in the closure itself, so it will make sure that + -- Node points to it... + ; let reduced_fvs = filter (NonVoid bndr /=) fvs + + ; profile <- getProfile + ; let platform = profilePlatform profile + + -- MAKE CLOSURE INFO FOR THIS CLOSURE + ; mod_name <- getModuleName + ; let name = idName bndr + descr = closureDescription mod_name name + fv_details :: [(NonVoid Id, ByteOff)] + header = if isLFThunk lf_info then ThunkHeader else StdHeader + (tot_wds, ptr_wds, fv_details) + = mkVirtHeapOffsets profile header (addIdReps reduced_fvs) + closure_info = mkClosureInfo profile False -- Not static + bndr lf_info tot_wds ptr_wds + descr + + -- BUILD ITS INFO TABLE AND CODE + ; forkClosureBody $ + -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere + -- (b) ignore Sequel from context; use empty Sequel + -- And compile the body + closureCodeBody False bndr closure_info cc args + body fv_details + + -- BUILD THE OBJECT +-- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body + ; let use_cc = cccsExpr platform; blame_cc = cccsExpr platform + ; emit (mkComment $ mkFastString "calling allocDynClosure") + ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) + ; let info_tbl = mkCmmInfo closure_info bndr currentCCS + ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc + (map toVarArg fv_details) + + -- RETURN + ; return (mkRhsInit platform reg lf_info hp_plus_n) } + +------------------------- +cgRhsStdThunk + :: Id + -> LambdaFormInfo + -> [StgArg] -- payload + -> FCode (CgIdInfo, FCode CmmAGraph) + +cgRhsStdThunk bndr lf_info payload + = do { (id_info, reg) <- rhsIdInfo bndr lf_info + ; return (id_info, gen_code reg) + } + where + gen_code reg -- AHA! A STANDARD-FORM THUNK + = withNewTickyCounterStdThunk (lfUpdatable lf_info) (bndr) payload $ + do + { -- LAY OUT THE OBJECT + mod_name <- getModuleName + ; profile <- getProfile + ; platform <- getPlatform + ; let + header = if isLFThunk lf_info then ThunkHeader else StdHeader + (tot_wds, ptr_wds, payload_w_offsets) + = mkVirtHeapOffsets profile header + (addArgReps (nonVoidStgArgs payload)) + + descr = closureDescription mod_name (idName bndr) + closure_info = mkClosureInfo profile False -- Not static + bndr lf_info tot_wds ptr_wds + descr + +-- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body + ; let use_cc = cccsExpr platform; blame_cc = cccsExpr platform + + + -- BUILD THE OBJECT + ; let info_tbl = mkCmmInfo closure_info bndr currentCCS + ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info + use_cc blame_cc payload_w_offsets + + -- RETURN + ; return (mkRhsInit platform reg lf_info hp_plus_n) } + + +mkClosureLFInfo :: Platform + -> Id -- The binder + -> TopLevelFlag -- True of top level + -> [NonVoid Id] -- Free vars + -> UpdateFlag -- Update flag + -> [Id] -- Args + -> LambdaFormInfo +mkClosureLFInfo platform bndr top fvs upd_flag args + | null args = + mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag + | otherwise = + mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr platform args) + + +------------------------------------------------------------------------ +-- The code for closures +------------------------------------------------------------------------ + +closureCodeBody :: Bool -- whether this is a top-level binding + -> Id -- the closure's name + -> ClosureInfo -- Lots of information about this closure + -> CostCentreStack -- Optional cost centre attached to closure + -> [Id] -- incoming args to the closure + -> CgStgExpr + -> [(NonVoid Id, ByteOff)] -- the closure's free vars + -> FCode () + +{- There are two main cases for the code for closures. + +* If there are *no arguments*, then the closure is a thunk, and not in + normal form. So it should set up an update frame (if it is + shared). NB: Thunks cannot have a primitive type! + +* If there is *at least one* argument, then this closure is in + normal form, so there is no need to set up an update frame. +-} + +-- No args i.e. thunk +closureCodeBody top_lvl bndr cl_info cc [] body fv_details + = withNewTickyCounterThunk + (isStaticClosure cl_info) + (closureUpdReqd cl_info) + (closureName cl_info) + (map fst fv_details) $ + emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ + \(_, node, _) -> thunkCode cl_info fv_details cc node body + where + lf_info = closureLFInfo cl_info + info_tbl = mkCmmInfo cl_info bndr cc + +-- Functions +closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details + = let nv_args = nonVoidIds args + arity = length args + in + -- See Note [OneShotInfo overview] in GHC.Types.Basic. + withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info) (map fst fv_details) + nv_args $ do { + + ; let + lf_info = closureLFInfo cl_info + info_tbl = mkCmmInfo cl_info bndr cc + + -- Emit the main entry code + ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl nv_args $ + \(_offset, node, arg_regs) -> do + -- Emit slow-entry code (for entering a closure through a PAP) + { mkSlowEntryCode bndr cl_info arg_regs + ; profile <- getProfile + ; platform <- getPlatform + ; let node_points = nodeMustPointToIt profile lf_info + node' = if node_points then Just node else Nothing + ; loop_header_id <- newBlockId + -- Extend reader monad with information that + -- self-recursive tail calls can be optimized into local + -- jumps. See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr. + ; let !self_loop_info = MkSelfLoopInfo + { sli_id = bndr + , sli_arity = arity + , sli_header_block = loop_header_id + , sli_registers = arg_regs + } + ; withSelfLoop self_loop_info $ do + { + -- Main payload + ; entryHeapCheck cl_info node' arity arg_regs $ do + { -- emit LDV code when profiling + when node_points (ldvEnterClosure cl_info (CmmLocal node)) + -- ticky after heap check to avoid double counting + ; tickyEnterFun cl_info + ; enterCostCentreFun cc + (CmmMachOp (mo_wordSub platform) + [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification] + , mkIntExpr platform (funTag platform cl_info) ]) + ; fv_bindings <- mapM bind_fv fv_details + -- Load free vars out of closure *after* + -- heap check, to reduce live vars over check + ; when node_points $ load_fvs node lf_info fv_bindings + ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr args + ; void $ cgExpr body + }}} + + } + +-- Note [NodeReg clobbered with loopification] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Previously we used to pass nodeReg (aka R1) here. With profiling, upon +-- entering a closure, enterFunCCS was called with R1 passed to it. But since R1 +-- may get clobbered inside the body of a closure, and since a self-recursive +-- tail call does not restore R1, a subsequent call to enterFunCCS received a +-- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to +-- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores +-- the original value of R1. This way R1 may get modified but loopification will +-- not care. + +-- A function closure pointer may be tagged, so we +-- must take it into account when accessing the free variables. +bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff) +bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) } + +load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode () +load_fvs node lf_info = mapM_ (\ (reg, off) -> + do platform <- getPlatform + let tag = lfDynTag platform lf_info + emit $ mkTaggedObjectLoad platform reg node off tag) + +----------------------------------------- +-- The "slow entry" code for a function. This entry point takes its +-- arguments on the stack. It loads the arguments into registers +-- according to the calling convention, and jumps to the function's +-- normal entry point. The function's closure is assumed to be in +-- R1/node. +-- +-- The slow entry point is used for unknown calls: eg. stg_PAP_entry + +mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode () +-- If this function doesn't have a specialised ArgDescr, we need +-- to generate the function's arg bitmap and slow-entry code. +-- Here, we emit the slow-entry code. +mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' + | Just (_, ArgGen _) <- closureFunInfo cl_info + = do cfg <- getStgToCmmConfig + upd_frame <- getUpdFrameOff + let node = idToReg platform (NonVoid bndr) + profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg + slow_lbl = closureSlowEntryLabel platform cl_info + fast_lbl = closureLocalEntryLabel platform cl_info + -- mkDirectJump does not clobber `Node' containing function closure + jump = mkJump profile NativeNodeCall + (mkLblExpr fast_lbl) + (map (CmmReg . CmmLocal) (node : arg_regs)) + upd_frame + tscope <- getTickScope + emitProcWithConvention Slow Nothing slow_lbl + (node : arg_regs) (jump, tscope) + | otherwise = return () + +----------------------------------------- +thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack + -> LocalReg -> CgStgExpr -> FCode () +thunkCode cl_info fv_details _cc node body + = do { profile <- getProfile + ; platform <- getPlatform + ; let node_points = nodeMustPointToIt profile (closureLFInfo cl_info) + node' = if node_points then Just node else Nothing + ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling + + -- Heap overflow check + ; entryHeapCheck cl_info node' 0 [] $ do + { -- Overwrite with black hole if necessary + -- but *after* the heap-overflow check + ; tickyEnterThunk cl_info + ; when (blackHoleOnEntry cl_info && node_points) + (blackHoleIt node) + + -- Push update frame + ; setupUpdate cl_info node $ + -- We only enter cc after setting up update so + -- that cc of enclosing scope will be recorded + -- in update frame CAF/DICT functions will be + -- subsumed by this enclosing cc + do { enterCostCentreThunk (CmmReg $ nodeReg platform) + ; let lf_info = closureLFInfo cl_info + ; fv_bindings <- mapM bind_fv fv_details + ; load_fvs node lf_info fv_bindings + ; void $ cgExpr body }}} + + +------------------------------------------------------------------------ +-- Update and black-hole wrappers +------------------------------------------------------------------------ + +blackHoleIt :: LocalReg -> FCode () +-- Only called for closures with no args +-- Node points to the closure +blackHoleIt node_reg + = emitBlackHoleCode (CmmReg (CmmLocal node_reg)) + +emitBlackHoleCode :: CmmExpr -> FCode () +emitBlackHoleCode node = do + cfg <- getStgToCmmConfig + let profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg + is_eager_bh = stgToCmmEagerBlackHole cfg + + -- Eager blackholing is normally disabled, but can be turned on with + -- -feager-blackholing. When it is on, we replace the info pointer + -- of the thunk with stg_EAGER_BLACKHOLE_info on entry. + + -- If we wanted to do eager blackholing with slop filling, we'd need + -- to do it at the *end* of a basic block, otherwise we overwrite + -- the free variables in the thunk that we still need. We have a + -- patch for this from Andy Cheadle, but not incorporated yet. --SDM + -- [6/2004] + -- + -- Previously, eager blackholing was enabled when ticky-ticky was + -- on. But it didn't work, and it wasn't strictly necessary to bring + -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is + -- unconditionally disabled. -- krc 1/2007 + + -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, + -- because emitBlackHoleCode is called from GHC.Cmm.Parser. + + let eager_blackholing = not (profileIsProfiling profile) && is_eager_bh + -- Profiling needs slop filling (to support LDV + -- profiling), so currently eager blackholing doesn't + -- work with profiling. + + when eager_blackholing $ do + whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node + emitAtomicStore platform MemOrderRelease + (cmmOffsetW platform node (fixedHdrSizeW profile)) + (currentTSOExpr platform) + -- See Note [Heap memory barriers] in SMP.h. + emitAtomicStore platform MemOrderRelease + node + (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)) + +emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () +emitAtomicStore platform mord addr val = + emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + where + w = typeWidth $ cmmExprType platform val + +setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () + -- Nota Bene: this function does not change Node (even if it's a CAF), + -- so that the cost centre in the original closure can still be + -- extracted by a subsequent enterCostCentre +setupUpdate closure_info node body + | not (lfUpdatable (closureLFInfo closure_info)) + = body + + | not (isStaticClosure closure_info) + = if not (closureUpdReqd closure_info) + then do tickyUpdateFrameOmitted; body + else do + tickyPushUpdateFrame + cfg <- getStgToCmmConfig + let + bh = blackHoleOnEntry closure_info + && not (stgToCmmSCCProfiling cfg) + && stgToCmmEagerBlackHole cfg + + lbl | bh = mkBHUpdInfoLabel + | otherwise = mkUpdInfoLabel + + pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame lbl (CmmReg (CmmLocal node)) body + + | otherwise -- A static closure + = do { tickyUpdateBhCaf closure_info + + ; if closureUpdReqd closure_info + then do -- Blackhole the (updatable) CAF: + { upd_closure <- link_caf node + ; pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame mkBHUpdInfoLabel upd_closure body } + else do {tickyUpdateFrameOmitted; body} + } + +----------------------------------------------------------------------------- +-- Setting up update frames + +-- Push the update frame on the stack in the Entry area, +-- leaving room for the return address that is already +-- at the old end of the area. +-- +pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode () +pushUpdateFrame lbl updatee body + = do + updfr <- getUpdFrameOff + profile <- getProfile + let hdr = fixedHdrSize profile + frame = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile) + -- + emitUpdateFrame (CmmStackSlot Old frame) lbl updatee + withUpdFrameOff frame body + +emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode () +emitUpdateFrame frame lbl updatee = do + profile <- getProfile + let + hdr = fixedHdrSize profile + off_updatee = hdr + pc_OFFSET_StgUpdateFrame_updatee (platformConstants platform) + platform = profilePlatform profile + -- + emitStore frame (mkLblExpr lbl) + emitStore (cmmOffset platform frame off_updatee) updatee + initUpdFrameProf frame + +----------------------------------------------------------------------------- +-- Original thunk info table frames +-- +-- Note [Original thunk info table frames] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In some debugging scenarios (e.g. when debugging cyclic thunks) it can be very +-- useful to know which thunks the program is in the process of evaluating. +-- However, in the case of updateable thunks this can be very difficult +-- to determine since the process of blackholing overwrites the thunk's +-- info table pointer. +-- +-- To help in such situations we provide the -forig-thunk-info flag. This enables +-- code generation logic which pushes a stg_orig_thunk_info_frame stack frame to +-- accompany each update frame. As the name suggests, this frame captures the +-- the original info table of the thunk being updated. The entry code for these +-- frames has no operational effects; the frames merely exist as breadcrumbs +-- for debugging. + +pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode () +pushOrigThunkInfoFrame closure_info body = do + cfg <- getStgToCmmConfig + if stgToCmmOrigThunkInfo cfg + then do_it + else body + where + orig_itbl = mkLblExpr (closureInfoLabel closure_info) + do_it = do + updfr <- getUpdFrameOff + profile <- getProfile + let platform = profilePlatform profile + hdr = fixedHdrSize profile + orig_info_frame_sz = + hdr + pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr (profileConstants profile) + off_orig_info = hdr + pc_OFFSET_StgOrigThunkInfoFrame_info_ptr (profileConstants profile) + frame_off = updfr + orig_info_frame_sz + frame = CmmStackSlot Old frame_off + -- + emitStore frame (mkLblExpr mkOrigThunkInfoLabel) + emitStore (cmmOffset platform frame off_orig_info) orig_itbl + withUpdFrameOff frame_off body + +----------------------------------------------------------------------------- +-- Entering a CAF +-- +-- See Note [CAF management] in rts/sm/Storage.c + +link_caf :: LocalReg -- pointer to the closure + -> FCode CmmExpr -- Returns amode for closure to be updated +-- This function returns the address of the black hole, so it can be +-- updated with the new value when available. +link_caf node = do + { cfg <- getStgToCmmConfig + -- Call the RTS function newCAF, returning the newly-allocated + -- blackhole indirection closure + ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") + ForeignLabelInExternalPackage IsFunction + ; let profile = stgToCmmProfile cfg + ; let platform = profilePlatform profile + ; bh <- newTemp (bWord platform) + ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl + [ (baseExpr platform, AddrHint), + (CmmReg (CmmLocal node), AddrHint) ] + False + + -- see Note [atomic CAF entry] in rts/sm/Storage.c + ; updfr <- getUpdFrameOff + ; let align_check = stgToCmmAlignCheck cfg + ; let target = entryCode platform + (closureInfoPtr platform align_check (CmmReg (CmmLocal node))) + ; emit =<< mkCmmIfThen + (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform)) + -- re-enter the CAF + (mkJump profile NativeNodeCall target [] updfr) + + ; return (CmmReg (CmmLocal bh)) } + +------------------------------------------------------------------------ +-- Profiling +------------------------------------------------------------------------ + +-- For "global" data constructors the description is simply occurrence +-- name of the data constructor itself. Otherwise it is determined by +-- @closureDescription@ from the let binding information. + +closureDescription + :: Module -- Module + -> Name -- Id of closure binding + -> String + -- Not called for StgRhsCon which have global info tables built in + -- CgConTbls.hs with a description generated from the data constructor +closureDescription mod_name name + = showSDocOneLine defaultSDocContext + (char '<' <> pprFullName mod_name name <> char '>') diff --git a/GHC/StgToCmm/Bind.hs-boot b/GHC/StgToCmm/Bind.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Bind.hs-boot @@ -0,0 +1,6 @@ +module GHC.StgToCmm.Bind where + +import GHC.StgToCmm.Monad( FCode ) +import GHC.Stg.Syntax( CgStgBinding ) + +cgBind :: CgStgBinding -> FCode () diff --git a/GHC/StgToCmm/CgUtils.hs b/GHC/StgToCmm/CgUtils.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/CgUtils.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE GADTs #-} + +----------------------------------------------------------------------------- +-- +-- Code generator utilities; mostly monadic +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.CgUtils ( + fixStgRegisters, + baseRegOffset, + get_Regtable_addr_from_offset, + regTableOffset, + get_GlobalReg_addr, + + -- * Streaming for CG + CgStream + ) where + +import GHC.Prelude + +import GHC.Platform.Regs +import GHC.Platform +import GHC.Cmm +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.Utils.Panic +import GHC.Cmm.Dataflow.Label + +import GHC.Data.Stream (Stream) +import GHC.Types.Unique.DSM (UniqDSMT) + +-- ----------------------------------------------------------------------------- +-- Streaming + +-- | The Stream instantiation used for code generation. +-- Note the underlying monad is @UniqDSMT IO@, where @UniqDSMT@ is a transformer +-- that propagates a deterministic unique supply (essentially an incrementing +-- counter) from which new uniques are deterministically created during the +-- code generation stages following StgToCmm. +-- See Note [Object determinism]. +type CgStream = Stream (UniqDSMT IO) + + +-- ----------------------------------------------------------------------------- +-- Information about global registers + +baseRegOffset :: Platform -> GlobalReg -> Int +baseRegOffset platform reg = case reg of + VanillaReg 1 -> pc_OFFSET_StgRegTable_rR1 constants + VanillaReg 2 -> pc_OFFSET_StgRegTable_rR2 constants + VanillaReg 3 -> pc_OFFSET_StgRegTable_rR3 constants + VanillaReg 4 -> pc_OFFSET_StgRegTable_rR4 constants + VanillaReg 5 -> pc_OFFSET_StgRegTable_rR5 constants + VanillaReg 6 -> pc_OFFSET_StgRegTable_rR6 constants + VanillaReg 7 -> pc_OFFSET_StgRegTable_rR7 constants + VanillaReg 8 -> pc_OFFSET_StgRegTable_rR8 constants + VanillaReg 9 -> pc_OFFSET_StgRegTable_rR9 constants + VanillaReg 10 -> pc_OFFSET_StgRegTable_rR10 constants + VanillaReg n -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") + FloatReg 1 -> pc_OFFSET_StgRegTable_rF1 constants + FloatReg 2 -> pc_OFFSET_StgRegTable_rF2 constants + FloatReg 3 -> pc_OFFSET_StgRegTable_rF3 constants + FloatReg 4 -> pc_OFFSET_StgRegTable_rF4 constants + FloatReg 5 -> pc_OFFSET_StgRegTable_rF5 constants + FloatReg 6 -> pc_OFFSET_StgRegTable_rF6 constants + FloatReg n -> panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")") + DoubleReg 1 -> pc_OFFSET_StgRegTable_rD1 constants + DoubleReg 2 -> pc_OFFSET_StgRegTable_rD2 constants + DoubleReg 3 -> pc_OFFSET_StgRegTable_rD3 constants + DoubleReg 4 -> pc_OFFSET_StgRegTable_rD4 constants + DoubleReg 5 -> pc_OFFSET_StgRegTable_rD5 constants + DoubleReg 6 -> pc_OFFSET_StgRegTable_rD6 constants + DoubleReg n -> panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")") + XmmReg 1 -> pc_OFFSET_StgRegTable_rXMM1 constants + XmmReg 2 -> pc_OFFSET_StgRegTable_rXMM2 constants + XmmReg 3 -> pc_OFFSET_StgRegTable_rXMM3 constants + XmmReg 4 -> pc_OFFSET_StgRegTable_rXMM4 constants + XmmReg 5 -> pc_OFFSET_StgRegTable_rXMM5 constants + XmmReg 6 -> pc_OFFSET_StgRegTable_rXMM6 constants + XmmReg n -> panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")") + YmmReg 1 -> pc_OFFSET_StgRegTable_rYMM1 constants + YmmReg 2 -> pc_OFFSET_StgRegTable_rYMM2 constants + YmmReg 3 -> pc_OFFSET_StgRegTable_rYMM3 constants + YmmReg 4 -> pc_OFFSET_StgRegTable_rYMM4 constants + YmmReg 5 -> pc_OFFSET_StgRegTable_rYMM5 constants + YmmReg 6 -> pc_OFFSET_StgRegTable_rYMM6 constants + YmmReg n -> panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")") + ZmmReg 1 -> pc_OFFSET_StgRegTable_rZMM1 constants + ZmmReg 2 -> pc_OFFSET_StgRegTable_rZMM2 constants + ZmmReg 3 -> pc_OFFSET_StgRegTable_rZMM3 constants + ZmmReg 4 -> pc_OFFSET_StgRegTable_rZMM4 constants + ZmmReg 5 -> pc_OFFSET_StgRegTable_rZMM5 constants + ZmmReg 6 -> pc_OFFSET_StgRegTable_rZMM6 constants + ZmmReg n -> panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")") + Sp -> pc_OFFSET_StgRegTable_rSp constants + SpLim -> pc_OFFSET_StgRegTable_rSpLim constants + LongReg 1 -> pc_OFFSET_StgRegTable_rL1 constants + LongReg n -> panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") + Hp -> pc_OFFSET_StgRegTable_rHp constants + HpLim -> pc_OFFSET_StgRegTable_rHpLim constants + CCCS -> pc_OFFSET_StgRegTable_rCCCS constants + CurrentTSO -> pc_OFFSET_StgRegTable_rCurrentTSO constants + CurrentNursery -> pc_OFFSET_StgRegTable_rCurrentNursery constants + HpAlloc -> pc_OFFSET_StgRegTable_rHpAlloc constants + EagerBlackholeInfo -> pc_OFFSET_stgEagerBlackholeInfo constants + GCEnter1 -> pc_OFFSET_stgGCEnter1 constants + GCFun -> pc_OFFSET_stgGCFun constants + BaseReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:BaseReg" + PicBaseReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:PicBaseReg" + MachSp -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:MachSp" + UnwindReturnReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:UnwindReturnReg" + where + !constants = platformConstants platform + + +-- ----------------------------------------------------------------------------- +-- +-- STG/Cmm GlobalReg +-- +-- ----------------------------------------------------------------------------- + +-- | We map STG registers onto appropriate CmmExprs. Either they map +-- to real machine registers or stored as offsets from BaseReg. Given +-- a GlobalReg, get_GlobalReg_addr always produces the +-- register table address for it. +get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr +get_GlobalReg_addr platform BaseReg = regTableOffset platform 0 +get_GlobalReg_addr platform mid + = get_Regtable_addr_from_offset platform (baseRegOffset platform mid) + +-- Calculate a literal representing an offset into the register table. +-- Used when we don't have an actual BaseReg to offset from. +regTableOffset :: Platform -> Int -> CmmExpr +regTableOffset platform n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (pc_OFFSET_Capability_r (platformConstants platform) + n)) + +get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr +get_Regtable_addr_from_offset platform offset = + if haveRegBase platform + then cmmRegOff (baseReg platform) offset + else regTableOffset platform offset + +-- | Fixup global registers so that they assign to locations within the +-- RegTable if they aren't pinned for the current target. +fixStgRegisters :: Platform -> GenCmmDecl d h (GenCmmGraph CmmNode) -> GenCmmDecl d h (GenCmmGraph CmmNode) +fixStgRegisters _ top@(CmmData _ _) = top + +fixStgRegisters platform (CmmProc info lbl live graph) = + let graph' = modifyGraph (mapGraphBlocks mapMap (fixStgRegBlock platform)) graph + in CmmProc info lbl live graph' + +fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x +fixStgRegBlock platform block = mapBlock (fixStgRegStmt platform) block + +fixStgRegStmt :: Platform -> CmmNode e x -> CmmNode e x +fixStgRegStmt platform stmt = fixAssign $ mapExpDeep fixExpr stmt + where + fixAssign stmt = + case stmt of + CmmAssign (CmmGlobal reg_use) src + -- MachSp isn't an STG register; it's merely here for tracking unwind + -- information + | reg == MachSp -> stmt + | otherwise -> + let baseAddr = get_GlobalReg_addr platform reg + in case reg `elem` activeStgRegs platform of + True -> CmmAssign (CmmGlobal reg_use) src + False -> CmmStore baseAddr src NaturallyAligned + where reg = globalRegUse_reg reg_use + other_stmt -> other_stmt + + fixExpr expr = case expr of + -- MachSp isn't an STG; it's merely here for tracking unwind information + CmmReg (CmmGlobal (GlobalRegUse MachSp _)) -> expr + CmmReg (CmmGlobal reg_use) -> + -- Replace register leaves with appropriate StixTrees for + -- the given target. MagicIds which map to a reg on this + -- arch are left unchanged. For the rest, BaseReg is taken + -- to mean the address of the reg table in MainCapability, + -- and for all others we generate an indirection to its + -- location in the register table. + let reg = globalRegUse_reg reg_use in + case reg `elem` activeStgRegs platform of + True -> expr + False -> + let baseAddr = get_GlobalReg_addr platform reg + in case reg of + BaseReg -> baseAddr + _other -> CmmLoad baseAddr + (globalRegUse_type reg_use) + NaturallyAligned + + CmmRegOff greg@(CmmGlobal reg) offset -> + -- RegOf leaves are just a shorthand form. If the reg maps + -- to a real reg, we keep the shorthand, otherwise, we just + -- expand it and defer to the above code. + -- NB: to ensure type correctness we need to ensure the Add + -- as well as the Int need to be of the same size as the + -- register. + case globalRegUse_reg reg `elem` activeStgRegs platform of + True -> expr + False -> CmmMachOp (MO_Add (cmmRegWidth greg)) [ + fixExpr (CmmReg greg), + CmmLit (CmmInt (fromIntegral offset) + (cmmRegWidth greg))] + + other_expr -> other_expr diff --git a/GHC/StgToCmm/Closure.hs b/GHC/StgToCmm/Closure.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Closure.hs @@ -0,0 +1,1006 @@ + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation: +-- +-- The types LambdaFormInfo +-- ClosureInfo +-- +-- Nothing monadic in here! +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Closure ( + DynTag, tagForCon, isSmallFamily, + + idPrimRep1, idPrimRepU, isGcPtrRep, addIdReps, addArgReps, + + NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs, + assertNonVoidIds, assertNonVoidStgArgs, + + -- * LambdaFormInfo + LambdaFormInfo, -- Abstract + StandardFormInfo, -- ...ditto... + mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, + mkApLFInfo, importedIdLFInfo, mkLFArgument, mkLFLetNoEscape, + mkLFStringLit, + lfDynTag, + isLFThunk, isLFReEntrant, lfUpdatable, + + -- * Used by other modules + CgLoc(..), CallMethod(..), + nodeMustPointToIt, isKnownFun, funTag, tagForArity, + getCallMethod, + + -- * ClosureInfo + ClosureInfo, + mkClosureInfo, + mkCmmInfo, + + -- ** Inspection + closureLFInfo, closureName, + + -- ** Labels + -- These just need the info table label + closureInfoLabel, staticClosureLabel, + closureSlowEntryLabel, closureLocalEntryLabel, + + -- ** Predicates + -- These are really just functions on LambdaFormInfo + closureUpdReqd, + closureReEntrant, closureFunInfo, + isToplevClosure, + + blackHoleOnEntry, -- Needs LambdaFormInfo and SMRep + isStaticClosure, -- Needs SMPre + + -- * InfoTables + mkDataConInfoTable, + cafBlackHoleInfoTable, + indStaticInfoTable, + staticClosureNeedsLink, + mkClosureInfoTableLabel + ) where + +import GHC.Prelude +import GHC.Platform +import GHC.Platform.Profile + +import GHC.Stg.Syntax +import GHC.Runtime.Heap.Layout +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.StgToCmm.Types +import GHC.StgToCmm.Sequel + +import GHC.Types.CostCentre +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.DataCon +import GHC.Types.Name +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Tc.Utils.TcType +import GHC.Core.TyCon +import GHC.Types.RepType +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.Maybe (isNothing) + +import Data.Coerce (coerce) +import qualified Data.ByteString.Char8 as BS8 +import GHC.StgToCmm.Config +import GHC.Stg.EnforceEpt.TagSig (isTaggedSig) + +----------------------------------------------------------------------------- +-- Data types and synonyms +----------------------------------------------------------------------------- + +-- These data types are mostly used by other modules, especially +-- GHC.StgToCmm.Monad, but we define them here because some functions in this +-- module need to have access to them as well + +data CgLoc + = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning + -- Hp, so that it remains valid across calls + + | LneLoc BlockId [LocalReg] -- A join point + -- A join point (= let-no-escape) should only + -- be tail-called, and in a saturated way. + -- To tail-call it, assign to these locals, + -- and branch to the block id + +instance OutputableP Platform CgLoc where + pdoc = pprCgLoc + +pprCgLoc :: Platform -> CgLoc -> SDoc +pprCgLoc platform = \case + CmmLoc e -> text "cmm" <+> pdoc platform e + LneLoc b rs -> text "lne" <+> ppr b <+> ppr rs + +-- used by ticky profiling +isKnownFun :: LambdaFormInfo -> Bool +isKnownFun LFReEntrant{} = True +isKnownFun LFLetNoEscape = True +isKnownFun _ = False + + +------------------------------------- +-- Non-void types +------------------------------------- +-- We frequently need the invariant that an Id or a an argument +-- is of a non-void type. This type is a witness to the invariant. + +newtype NonVoid a = NonVoid a + deriving (Eq, Show) + +fromNonVoid :: NonVoid a -> a +fromNonVoid (NonVoid a) = a + +instance (Outputable a) => Outputable (NonVoid a) where + ppr (NonVoid a) = ppr a + +nonVoidIds :: [Id] -> [NonVoid Id] +nonVoidIds ids = [NonVoid id | id <- ids, not (isZeroBitTy (idType id))] + +-- | Used in places where some invariant ensures that all these Ids are +-- non-void; e.g. constructor field binders in case expressions. +-- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". +assertNonVoidIds :: [Id] -> [NonVoid Id] +assertNonVoidIds ids = assert (not (any (isZeroBitTy . idType) ids)) $ + coerce ids + +nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] +nonVoidStgArgs args = [NonVoid arg | arg <- args, not (null (stgArgRep 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 (null . stgArgRep) args)) $ + coerce args + + +----------------------------------------------------------------------------- +-- Representations +----------------------------------------------------------------------------- + +-- Why are these here? + +-- | Assumes that there is at most one 'PrimRep' of the type. This assumption +-- holds after unarise. +-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. +-- See Note [VoidRep] in GHC.Types.RepType. +idPrimRep1 :: Id -> PrimOrVoidRep +idPrimRep1 id = typePrimRep1 (idType id) + +idPrimRepU :: Id -> PrimRep +idPrimRepU id = typePrimRepU (idType id) + +-- | Assumes that Ids have one PrimRep, which holds after unarisation. +-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. +addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] +addIdReps = map (\id -> let id' = fromNonVoid id + in NonVoid (idPrimRepU id', id')) + +-- | Assumes that arguments have one PrimRep, which holds after unarisation. +-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. +addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)] +addArgReps = map (\arg -> let arg' = fromNonVoid arg + in NonVoid (stgArgRepU arg', arg')) + +------------------------------------------------------ +-- Building LambdaFormInfo +------------------------------------------------------ + +mkLFArgument :: Id -> LambdaFormInfo +mkLFArgument id + | isUnliftedType ty = LFUnlifted + | mightBeFunTy ty = LFUnknown True + | otherwise = LFUnknown False + where + ty = idType id + +------------- +mkLFLetNoEscape :: LambdaFormInfo +mkLFLetNoEscape = LFLetNoEscape + +------------- +mkLFReEntrant :: TopLevelFlag -- True of top level + -> [Id] -- Free vars + -> [Id] -- Args + -> ArgDescr -- Argument descriptor + -> LambdaFormInfo + +mkLFReEntrant _ _ [] _ + = pprPanic "mkLFReEntrant" empty +mkLFReEntrant top fvs args arg_descr + = LFReEntrant top (length args) (null fvs) arg_descr + +------------- +mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo +mkLFThunk thunk_ty top fvs upd_flag + = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty)) $ + LFThunk top (null fvs) + (isUpdatable upd_flag) + NonStandardThunk + (mightBeFunTy thunk_ty) + +------------- +mkConLFInfo :: DataCon -> LambdaFormInfo +mkConLFInfo con = LFCon con + +------------- +mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo +mkSelectorLFInfo id offset updatable + = LFThunk NotTopLevel False updatable (SelectorThunk offset) + (mightBeFunTy (idType id)) + +------------- +mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo +mkApLFInfo id upd_flag arity + = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) + (mightBeFunTy (idType id)) + +------------- +-- | The 'LambdaFormInfo' of an imported Id. +-- See Note [The LFInfo of Imported Ids] +importedIdLFInfo :: Id -> LambdaFormInfo +importedIdLFInfo id = + -- See Note [Conveying CAF-info and LFInfo between modules] in + -- GHC.StgToCmm.Types + case idLFInfo_maybe id of + Just lf_info -> + -- Use the existing LambdaFormInfo + lf_info + Nothing + -- Doesn't have a LambdaFormInfo, but we know it must be 'LFReEntrant' from its arity + | arity > 0 + -> LFReEntrant TopLevel arity True ArgUnknown + + -- We can't be sure of the LambdaFormInfo of this imported Id, + -- so make a conservative one from the type. + | otherwise + -> assert (isNothing (isDataConId_maybe id)) $ -- See Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make + mkLFArgument id -- Not sure of exact arity + where + arity = idFunRepArity id + +{- +Note [The LFInfo of Imported Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [Conveying CAF-info and LFInfo between modules] +the LambdaFormInfo records the details of a closure representation and is +often, when optimisations are enabled, serialized to the interface of a module. + +In particular, the `lfInfo` field of the `IdInfo` field of an `Id`: +* For DataCon workers and wrappers is populated as described in +Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make +* For other Ids defined in the module being compiled: is `Nothing` +* For other imported Ids: + * is (Just lf_info) if the LFInfo was serialised into the interface file + (typically, when the exporting module was compiled with -O) + * is Nothing if it wasn't serialised + +The LambdaFormInfo we give an Id is used in determining how to tag its pointer +(see `litIdInfo` and `lfDynTag`). Therefore, it's crucial we attribute a correct +LambdaFormInfo to imported Ids, or otherwise risk having pointers incorrectly +tagged which can lead to performance issues and even segmentation faults (see +#23231 and Note [Imported unlifted nullary datacon wrappers must have correct LFInfo]). + +In particular, saturated data constructor applications *must* be unambiguously +given `LFCon`, and if the LFInfo says LFCon, then it really is a static data +constructor, and similar for LFReEntrant. + +In `importedIdLFInfo`, we construct a LambdaFormInfo for imported Ids as follows: + +(1) If the `lfInfo` field contains an LFInfo, we use that LFInfo which is +correct by construction (the invariant being that if it exists, it is correct): + (1.1) Either it was serialised to the interface we're importing the Id from, + (1.2) Or it's a DataCon worker or wrapper and its LFInfo was constructed + according to Note [LFInfo of DataCon workers and wrappers] +(2) When the `lfInfo` field is `Nothing` + (2.1) If the `idFunRepArity` of the Id is known and is greater than 0, then + the Id is unambiguously a function and is given `LFReEntrant`, and pointers + to this Id will be tagged (by `litIdInfo`) with the corresponding arity. + (2.2) Otherwise, we can make a conservative estimate from the type. + +-} + +------------- +mkLFStringLit :: LambdaFormInfo +mkLFStringLit = LFUnlifted + +----------------------------------------------------- +-- Dynamic pointer tagging +----------------------------------------------------- + +type DynTag = Int -- The tag on a *pointer* + -- (from the dynamic-tagging paper) + +-- Note [Data constructor dynamic tags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The family size of a data type (the number of constructors +-- or the arity of a function) can be either: +-- * small, if the family size < 2**tag_bits +-- * big, otherwise. +-- +-- Small families can have the constructor tag in the tag bits. +-- Big families always use the tag values 1..mAX_PTR_TAG to represent +-- evaluatedness, the last one lumping together all overflowing ones. +-- We don't have very many tag bits: for example, we have 2 bits on +-- x86-32 and 3 bits on x86-64. +-- +-- Also see Note [Tagging big families] in GHC.StgToCmm.Expr +-- +-- The interpreter also needs to be updated if we change the +-- tagging strategy; see tagConstr in rts/Interpreter.c. + +isSmallFamily :: Platform -> Int -> Bool +isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform + +tagForCon :: Platform -> DataCon -> DynTag +tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform) +-- NB: 1-indexed + +tagForArity :: Platform -> RepArity -> DynTag +tagForArity platform arity + | isSmallFamily platform arity = arity + | otherwise = 0 + +-- | Return the tag in the low order bits of a variable bound +-- to this LambdaForm +lfDynTag :: Platform -> LambdaFormInfo -> DynTag +lfDynTag platform lf = case lf of + LFCon con -> tagForCon platform con + LFReEntrant _ arity _ _ -> tagForArity platform arity + _other -> 0 + + +----------------------------------------------------------------------------- +-- Observing LambdaFormInfo +----------------------------------------------------------------------------- + +------------ +isLFThunk :: LambdaFormInfo -> Bool +isLFThunk (LFThunk {}) = True +isLFThunk _ = False + +isLFReEntrant :: LambdaFormInfo -> Bool +isLFReEntrant (LFReEntrant {}) = True +isLFReEntrant _ = False + +----------------------------------------------------------------------------- +-- Choosing SM reps +----------------------------------------------------------------------------- + +lfClosureType :: LambdaFormInfo -> ClosureTypeInfo +lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd +lfClosureType (LFCon con) = Constr (dataConTagZ con) + (dataConIdentity con) +lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel +lfClosureType _ = panic "lfClosureType" + +thunkClosureType :: StandardFormInfo -> ClosureTypeInfo +thunkClosureType (SelectorThunk off) = ThunkSelector off +thunkClosureType _ = Thunk + +-- We *do* get non-updatable top-level thunks sometimes. eg. f = g +-- gets compiled to a jump to g (if g has non-zero arity), instead of +-- messing around with update frames and PAPs. We set the closure type +-- to FUN_STATIC in this case. + +----------------------------------------------------------------------------- +-- nodeMustPointToIt +----------------------------------------------------------------------------- + +nodeMustPointToIt :: Profile -> LambdaFormInfo -> Bool +-- If nodeMustPointToIt is true, then the entry convention for +-- this closure has R1 (the "Node" register) pointing to the +-- closure itself --- the "self" argument + +nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) + = not no_fvs -- Certainly if it has fvs we need to point to it + || isNotTopLevel top -- See Note [GC recovery] + -- For lex_profiling we also access the cost centre for a + -- non-inherited (i.e. non-top-level) function. + -- The isNotTopLevel test above ensures this is ok. + +nodeMustPointToIt profile (LFThunk top no_fvs updatable NonStandardThunk _) + = not no_fvs -- Self parameter + || isNotTopLevel top -- Note [GC recovery] + || updatable -- Need to push update frame + || profileIsProfiling profile + -- For the non-updatable (single-entry case): + -- + -- True if has fvs (in which case we need access to them, and we + -- should black-hole it) + -- or profiling (in which case we need to recover the cost centre + -- from inside it) ToDo: do we need this even for + -- top-level thunks? If not, + -- isNotTopLevel subsumes this + +nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk + = True + +nodeMustPointToIt _ (LFCon _) = True + + -- Strictly speaking, the above two don't need Node to point + -- to it if the arity = 0. But this is a *really* unlikely + -- situation. If we know it's nil (say) and we are entering + -- it. Eg: let x = [] in x then we will certainly have inlined + -- x, since nil is a simple atom. So we gain little by not + -- having Node point to known zero-arity things. On the other + -- hand, we do lose something; Patrick's code for figuring out + -- when something has been updated but not entered relies on + -- having Node point to the result of an update. SLPJ + -- 27/11/92. + +nodeMustPointToIt _ (LFUnknown _) = True +nodeMustPointToIt _ LFUnlifted = False +nodeMustPointToIt _ LFLetNoEscape = False + +{- Note [GC recovery] +~~~~~~~~~~~~~~~~~~~~~ +If we a have a local let-binding (function or thunk) + let f = in ... +AND allocates, then the heap-overflow check needs to know how +to re-start the evaluation. It uses the "self" pointer to do this. +So even if there are no free variables in , we still make +nodeMustPointToIt be True for non-top-level bindings. + +Why do any such bindings exist? After all, let-floating should have +floated them out. Well, a clever optimiser might leave one there to +avoid a space leak, deliberately recomputing a thunk. Also (and this +really does happen occasionally) let-floating may make a function f smaller +so it can be inlined, so now (f True) may generate a local no-fv closure. +This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind +in GHC.Tc.Deriv.Generate.) -} + +----------------------------------------------------------------------------- +-- getCallMethod +----------------------------------------------------------------------------- + +{- The entry conventions depend on the type of closure being entered, +whether or not it has free variables, and whether we're running +sequentially or in parallel. + +Closure Node Argument Enter +Characteristics Par Req'd Passing Via +--------------------------------------------------------------------------- +Unknown & no & yes & stack & node +Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args) + & slow entry (otherwise) +Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args) +0 arg, no fvs \r,\s & no & no & n/a & direct entry +0 arg, no fvs \u & no & yes & n/a & node +0 arg, fvs \r,\s,selector & no & yes & n/a & node +0 arg, fvs \r,\s & no & yes & n/a & direct entry +0 arg, fvs \u & no & yes & n/a & node +Unknown & yes & yes & stack & node +Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args) + & slow entry (otherwise) +Known fun (>1 arg), fvs & yes & yes & registers & node +0 arg, fvs \r,\s,selector & yes & yes & n/a & node +0 arg, no fvs \r,\s & yes & no & n/a & direct entry +0 arg, no fvs \u & yes & yes & n/a & node +0 arg, fvs \r,\s & yes & yes & n/a & node +0 arg, fvs \u & yes & yes & n/a & node + +When black-holing, single-entry closures could also be entered via node +(rather than directly) to catch double-entry. -} + +data CallMethod + = EnterIt -- ^ No args, not a function + + | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop + + | ReturnIt -- It's a value (function, unboxed value, + -- or constructor), so just return it. + + | InferedReturnIt -- A properly tagged value, as determined by tag inference. + -- See Note [Evaluated and Properly Tagged] + -- and Note [EPT enforcement] in GHC.Stg.EnforceEpt. + -- It behaves /precisely/ like `ReturnIt`, except that when debugging is + -- enabled we emit an extra assertion to check that the returned value is + -- properly tagged. We can use this as a check that tag inference is working + -- correctly. + -- TODO: SPJ suggested we could combine this with EnterIt, but for now I decided + -- not to do so. + + | SlowCall -- Unknown fun, or known fun with + -- too few args. + + | DirectEntry -- Jump directly, with args in regs + CLabel -- The code label + RepArity -- Its arity + +instance Outputable CallMethod where + ppr (EnterIt) = text "Enter" + ppr (JumpToIt {}) = text "JumpToIt" + ppr (ReturnIt ) = text "ReturnIt" + ppr (InferedReturnIt) = text "InferedReturnIt" + ppr (SlowCall ) = text "SlowCall" + ppr (DirectEntry {}) = text "DirectEntry" + +getCallMethod :: StgToCmmConfig + -> Name -- Function being applied + -> Id -- Function Id used to check if it can refer to + -- CAF's and whether the function is tail-calling + -- itself + -> LambdaFormInfo -- Its info + -> RepArity -- Number of available arguments + -- (including void args) + -> CgLoc -- Passed in from cgIdApp so that we can + -- handle let-no-escape bindings and self-recursive + -- tail calls using the same data constructor, + -- JumpToIt. This saves us one case branch in + -- cgIdApp + -> Maybe SelfLoopInfo -- can we perform a self-recursive tail-call + -> CallMethod + +getCallMethod cfg _ id _ n_args _cg_loc (Just self_loop) + | stgToCmmLoopification cfg + , MkSelfLoopInfo + { sli_id = loop_id, sli_arity = arity + , sli_header_block = blk_id, sli_registers = arg_regs + } <- self_loop + , id == loop_id + , n_args == arity + -- If these patterns match then we know that: + -- * loopification optimisation is turned on + -- * function is performing a self-recursive call in a tail position + -- * number of parameters matches the function's arity. + -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr for more details + = JumpToIt blk_id arg_regs + +getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _cg_loc _self_loop_info + | n_args == 0 -- No args at all + && not (profileIsProfiling (stgToCmmProfile cfg)) + -- See Note [Evaluating functions with profiling] in rts/Apply.cmm + = assert (arity /= 0) ReturnIt + | n_args < arity = SlowCall -- Not enough args + | otherwise = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity + +getCallMethod _ _name _ LFUnlifted n_args _cg_loc _self_loop_info + = assert (n_args == 0) ReturnIt + +getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info + = assert (n_args == 0) ReturnIt + -- n_args=0 because it'd be ill-typed to apply a saturated + -- constructor application to anything + +getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun) + n_args _cg_loc _self_loop_info + + | Just sig <- idTagSig_maybe id + , isTaggedSig sig -- Infered to be already evaluated by EPT analysis + , n_args == 0 -- See Note [EPT enforcement] + = InferedReturnIt + + | is_fun -- it *might* be a function, so we must "call" it (which is always safe) + = SlowCall -- We cannot just enter it [in eval/apply, the entry code + -- is the fast-entry code] + + -- Since is_fun is False, we are *definitely* looking at a data value + | updatable || stgToCmmDoTicky cfg -- to catch double entry + {- OLD: || opt_SMP + I decided to remove this, because in SMP mode it doesn't matter + if we enter the same thunk multiple times, so the optimisation + of jumping directly to the entry code is still valid. --SDM + -} + = EnterIt + + -- even a non-updatable selector thunk can be updated by the garbage + -- collector, so we must enter it. (#8817) + | SelectorThunk{} <- std_form_info + = EnterIt + + -- We used to have assert (n_args == 0 ), but actually it is + -- possible for the optimiser to generate + -- let bot :: Int = error Int "urk" + -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3 + -- This happens as a result of the case-of-error transformation + -- So the right thing to do is just to enter the thing + + | otherwise -- Jump direct to code for single-entry thunks + = assert (n_args == 0) $ + DirectEntry (thunkEntryLabel (stgToCmmPlatform cfg) name (idCafInfo id) std_form_info + updatable) 0 + +-- Imported(Unknown) Ids +getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _cg_locs _self_loop_info + | n_args == 0 + , Just sig <- idTagSig_maybe id + , isTaggedSig sig -- Infered to be already evaluated by EPT analysis + -- 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 [EPT enforcement] + + | might_be_a_function = SlowCall + + | otherwise = + assertPpr ( n_args == 0) ( ppr name <+> ppr n_args ) + EnterIt -- Not a function + +-- TODO: Redundant with above match? +-- getCallMethod _ name _ (LFUnknown False) n_args _cg_loc _self_loop_info +-- = assertPpr (n_args == 0) (ppr name <+> ppr n_args) +-- EnterIt -- Not a function + +getCallMethod _ _name _ LFLetNoEscape _n_args (LneLoc blk_id lne_regs) _self_loop_info + = JumpToIt blk_id lne_regs + +getCallMethod _ _ _ _ _ _ _ = panic "Unknown call method" + +----------------------------------------------------------------------------- +-- Data types for closure information +----------------------------------------------------------------------------- + + +{- ClosureInfo: information about a binding + + We make a ClosureInfo for each let binding (both top level and not), + but not bindings for data constructors: for those we build a CmmInfoTable + directly (see mkDataConInfoTable). + + To a first approximation: + ClosureInfo = (LambdaFormInfo, CmmInfoTable) + + A ClosureInfo has enough information + a) to construct the info table itself, and build other things + related to the binding (e.g. slow entry points for a function) + b) to allocate a closure containing that info pointer (i.e. + it knows the info table label) +-} + +data ClosureInfo + = ClosureInfo { + closureName :: !Id, -- The thing bound to this closure + -- we don't really need this field: it's only used in generating + -- code for ticky and profiling, and we could pass the information + -- around separately, but it doesn't do much harm to keep it here. + + closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon + -- this tells us about what the closure contains: it's right-hand-side. + + -- the rest is just an unpacked CmmInfoTable. + closureInfoLabel :: !CLabel, + closureSMRep :: !SMRep, -- representation used by storage mgr + closureProf :: !ProfilingInfo + } + +-- | Convert from 'ClosureInfo' to 'CmmInfoTable'. +mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable +mkCmmInfo ClosureInfo {..} id ccs + = CmmInfoTable { cit_lbl = closureInfoLabel + , cit_rep = closureSMRep + , cit_prof = closureProf + , cit_srt = Nothing + , cit_clo = if isStaticRep closureSMRep + then Just (id,ccs) + else Nothing } + +-------------------------------------- +-- Building ClosureInfos +-------------------------------------- + +mkClosureInfo :: Profile + -> Bool -- Is static + -> Id + -> LambdaFormInfo + -> Int -> Int -- Total and pointer words + -> String -- String descriptor + -> ClosureInfo +mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr + = ClosureInfo { closureName = id + , closureLFInfo = lf_info + , closureInfoLabel = info_lbl -- These three fields are + , closureSMRep = sm_rep -- (almost) an info table + , closureProf = prof } -- (we don't have an SRT yet) + where + sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info) + prof = mkProfilingInfo profile id val_descr + nonptr_wds = tot_wds - ptr_wds + + info_lbl = mkClosureInfoTableLabel (profilePlatform profile) id lf_info + +-------------------------------------- +-- Other functions over ClosureInfo +-------------------------------------- + +-- Eager blackholing is normally disabled, but can be turned on with +-- -feager-blackholing. When it is on, we replace the info pointer of +-- the thunk with stg_EAGER_BLACKHOLE_info on entry. + +-- If we wanted to do eager blackholing with slop filling, +-- we'd need to do it at the *end* of a basic block, otherwise +-- we overwrite the free variables in the thunk that we still +-- need. We have a patch for this from Andy Cheadle, but not +-- incorporated yet. --SDM [6/2004] +-- +-- Previously, eager blackholing was enabled when ticky-ticky +-- was on. But it didn't work, and it wasn't strictly necessary +-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING +-- is unconditionally disabled. -- krc 1/2007 +-- +-- Static closures are never themselves black-holed. + +blackHoleOnEntry :: ClosureInfo -> Bool +blackHoleOnEntry cl_info + | isStaticRep (closureSMRep cl_info) + = False -- Never black-hole a static closure + + | otherwise + = case closureLFInfo cl_info of + LFReEntrant {} -> False + LFLetNoEscape -> False + LFThunk _ _no_fvs upd _ _ -> upd -- See Note [Black-holing non-updatable thunks] + _other -> panic "blackHoleOnEntry" + +{- Note [Black-holing non-updatable thunks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must not black-hole non-updatable (single-entry) thunks otherwise +we run into issues like #10414. Specifically: + + * There is no reason to black-hole a non-updatable thunk: it should + not be competed for by multiple threads + + * It could, conceivably, cause a space leak if we don't black-hole + it, if there was a live but never-followed pointer pointing to it. + Let's hope that doesn't happen. + + * It is dangerous to black-hole a non-updatable thunk because + - is not updated (of course) + - hence, if it is black-holed and another thread tries to evaluate + it, that thread will block forever + This actually happened in #10414. So we do not black-hole + non-updatable thunks. + + * How could two threads evaluate the same non-updatable (single-entry) + thunk? See Reid Barton's example below. + + * Only eager blackholing could possibly black-hole a non-updatable + thunk, because lazy black-holing only affects thunks with an + update frame on the stack. + +Here is and example due to Reid Barton (#10414): + x = \u [] concat [[1], []] +with the following definitions, + + concat x = case x of + [] -> [] + (:) x xs -> (++) x (concat xs) + + (++) xs ys = case xs of + [] -> ys + (:) x rest -> (:) x ((++) rest ys) + +Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to +denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@ +to WHNF and calls @(++)@ the heap will contain the following thunks, + + x = 1 : y + y = \u [] (++) [] z + z = \s [] concat [] + +Now that the stage is set, consider the follow evaluations by two racing threads +A and B, + + 1. Both threads enter @y@ before either is able to replace it with an + indirection + + 2. Thread A does the case analysis in @(++)@ and consequently enters @z@, + replacing it with a black-hole + + 3. At some later point thread B does the same case analysis and also attempts + to enter @z@. However, it finds that it has been replaced with a black-hole + so it blocks. + + 4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@ + accordingly. It does *not* update @z@, however, as it is single-entry. This + leaves Thread B blocked forever on a black-hole which will never be + updated. + +To avoid this sort of condition we never black-hole non-updatable thunks. +-} + +isStaticClosure :: ClosureInfo -> Bool +isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) + +closureUpdReqd :: ClosureInfo -> Bool +closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info + +lfUpdatable :: LambdaFormInfo -> Bool +lfUpdatable (LFThunk _ _ upd _ _) = upd +lfUpdatable _ = False + +closureReEntrant :: ClosureInfo -> Bool +closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True +closureReEntrant _ = False + +closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) +closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info + +lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) +lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) +lfFunInfo _ = Nothing + +funTag :: Platform -> ClosureInfo -> DynTag +funTag platform (ClosureInfo { closureLFInfo = lf_info }) + = lfDynTag platform lf_info + +isToplevClosure :: ClosureInfo -> Bool +isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) + = case lf_info of + LFReEntrant TopLevel _ _ _ -> True + LFThunk TopLevel _ _ _ _ -> True + _other -> False + +-------------------------------------- +-- Label generation +-------------------------------------- + +staticClosureLabel :: Platform -> ClosureInfo -> CLabel +staticClosureLabel platform = toClosureLbl platform . closureInfoLabel + +closureSlowEntryLabel :: Platform -> ClosureInfo -> CLabel +closureSlowEntryLabel platform = toSlowEntryLbl platform . closureInfoLabel + +closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel +closureLocalEntryLabel platform + | platformTablesNextToCode platform = toInfoLbl platform . closureInfoLabel + | otherwise = toEntryLbl platform . closureInfoLabel + +-- | Get the info table label for a *thunk*. +mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel +mkClosureInfoTableLabel platform id lf_info + = case lf_info of + LFThunk _ _ upd_flag (SelectorThunk offset) _ + -> mkSelectorInfoLabel platform upd_flag offset + + LFThunk _ _ upd_flag (ApThunk arity) _ + -> mkApInfoTableLabel platform upd_flag arity + + LFThunk{} -> mkInfoTableLabel name cafs + LFReEntrant{} -> mkInfoTableLabel name cafs + _other -> panic "closureInfoTableLabel" + + where + name = idName id + + cafs = idCafInfo id + +-- | thunkEntryLabel is a local help function, not exported. It's used from +-- getCallMethod. +thunkEntryLabel :: Platform -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel +thunkEntryLabel platform thunk_id caf_info sfi upd_flag = case sfi of + ApThunk arity -> enterApLabel platform upd_flag arity + SelectorThunk offset -> enterSelectorLabel platform upd_flag offset + _ -> enterIdLabel platform thunk_id caf_info + +enterApLabel :: Platform -> Bool -> Arity -> CLabel +enterApLabel platform is_updatable arity + | platformTablesNextToCode platform = mkApInfoTableLabel platform is_updatable arity + | otherwise = mkApEntryLabel platform is_updatable arity + +enterSelectorLabel :: Platform -> Bool -> WordOff -> CLabel +enterSelectorLabel platform upd_flag offset + | platformTablesNextToCode platform = mkSelectorInfoLabel platform upd_flag offset + | otherwise = mkSelectorEntryLabel platform upd_flag offset + +enterIdLabel :: Platform -> Name -> CafInfo -> CLabel +enterIdLabel platform id c + | platformTablesNextToCode platform = mkInfoTableLabel id c + | otherwise = mkEntryLabel id c + + +-------------------------------------- +-- Profiling +-------------------------------------- + +-- Profiling requires two pieces of information to be determined for +-- each closure's info table --- description and type. + +-- The description is stored directly in the @CClosureInfoTable@ when the +-- info table is built. + +-- The type is determined from the type information stored with the @Id@ +-- in the closure info using @closureTypeDescr@. + +mkProfilingInfo :: Profile -> Id -> String -> ProfilingInfo +mkProfilingInfo profile id val_descr + | not (profileIsProfiling profile) = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr) + where + ty_descr_w8 = BS8.pack (getTyDescription (idType id)) + +getTyDescription :: Type -> String +getTyDescription ty + = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> + case tau_ty of + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + TyConApp tycon _ -> getOccString tycon + FunTy {} -> '-' : fun_result tau_ty + ForAllTy _ ty -> getTyDescription ty + LitTy n -> getTyLitDescription n + CastTy ty _ -> getTyDescription ty + CoercionTy co -> pprPanic "getTyDescription" (ppr co) + } + where + fun_result (FunTy { ft_res = res }) = '>' : fun_result res + fun_result other = getTyDescription other + +getTyLitDescription :: TyLit -> String +getTyLitDescription l = + case l of + NumTyLit n -> show n + StrTyLit n -> show n + CharTyLit n -> show n + +-------------------------------------- +-- CmmInfoTable-related things +-------------------------------------- + +mkDataConInfoTable :: Profile -> DataCon -> ConInfoTableLocation -> Bool -> Int -> Int -> CmmInfoTable +mkDataConInfoTable profile data_con mn is_static ptr_wds nonptr_wds + = CmmInfoTable { cit_lbl = info_lbl + , cit_rep = sm_rep + , cit_prof = prof + , cit_srt = Nothing + , cit_clo = Nothing } + where + name = dataConName data_con + info_lbl = mkConInfoTableLabel name mn -- NoCAFRefs + sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds cl_type + cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con) + -- We keep the *zero-indexed* tag in the srt_len field + -- of the info table of a data constructor. + + prof | not (profileIsProfiling profile) = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr val_descr + + ty_descr = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con + val_descr = BS8.pack $ occNameString $ getOccName data_con + +-- We need a black-hole closure info to pass to @allocDynClosure@ when we +-- want to allocate the black hole on entry to a CAF. + +cafBlackHoleInfoTable :: CmmInfoTable +cafBlackHoleInfoTable + = CmmInfoTable { cit_lbl = mkCAFBlackHoleInfoTableLabel + , cit_rep = blackHoleRep + , cit_prof = NoProfilingInfo + , cit_srt = Nothing + , cit_clo = Nothing } + +indStaticInfoTable :: CmmInfoTable +indStaticInfoTable + = CmmInfoTable { cit_lbl = mkIndStaticInfoLabel + , cit_rep = indStaticRep + , cit_prof = NoProfilingInfo + , cit_srt = Nothing + , cit_clo = Nothing } + +staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool +-- A static closure needs a link field to aid the GC when traversing +-- the static closure graph. But it only needs such a field if either +-- a) it has an SRT +-- b) it's a constructor with one or more pointer fields +-- In case (b), the constructor's fields themselves play the role +-- of the SRT. +staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep } + | isConRep smrep = not (isStaticNoCafCon smrep) + | otherwise = has_srt diff --git a/GHC/StgToCmm/Config.hs b/GHC/StgToCmm/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Config.hs @@ -0,0 +1,93 @@ +-- | The stg to cmm code generator configuration + +module GHC.StgToCmm.Config + ( StgToCmmConfig(..) + , stgToCmmPlatform + ) where + +import GHC.Platform.Profile +import GHC.Platform +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Utils.TmpFs + +import GHC.Cmm.MachOp ( FMASign(..) ) +import GHC.Prelude + + +-- This config is static and contains information only passed *downwards* by StgToCmm.Monad +data StgToCmmConfig = StgToCmmConfig + ----------------------------- General Settings -------------------------------- + { stgToCmmProfile :: !Profile -- ^ Current profile + , stgToCmmThisModule :: Module -- ^ The module being compiled. This field kept lazy for + -- Cmm/Parser.y which preloads it with a panic + , stgToCmmTmpDir :: !TempDir -- ^ Temp Dir for files used in compilation + , stgToCmmContext :: !SDocContext -- ^ Context for StgToCmm phase + , stgToCmmEmitDebugInfo :: !Bool -- ^ Whether we wish to output debug information + , stgToCmmBinBlobThresh :: !(Maybe Word) -- ^ Threshold at which Binary literals (e.g. strings) + -- are either dumped to a file and a CmmFileEmbed literal + -- is emitted (over threshold), or become a CmmString + -- Literal (under or at threshold). CmmFileEmbed is only supported + -- with the NCG, thus a Just means two things: We have a threshold, + -- and will be using the NCG. Conversely, a Nothing implies we are not + -- using NCG and disables CmmFileEmbed. See Note + -- [Embedding large binary blobs] in GHC.CmmToAsm.Ppr, and + -- @cgTopBinding@ in GHC.StgToCmm. + , stgToCmmMaxInlAllocSize :: !Int -- ^ Max size, in bytes, of inline array allocations. + ------------------------------ Ticky Options ---------------------------------- + , stgToCmmDoTicky :: !Bool -- ^ Ticky profiling enabled (cf @-ticky@) + , stgToCmmTickyAllocd :: !Bool -- ^ True indicates ticky prof traces allocs of each named + -- thing in addition to allocs _by_ that thing + , stgToCmmTickyLNE :: !Bool -- ^ True indicates ticky uses name-specific counters for + -- join-points (let-no-escape) + , stgToCmmTickyDynThunk :: !Bool -- ^ True indicates ticky uses name-specific counters for + -- dynamic thunks + , stgToCmmTickyTag :: !Bool -- ^ True indicates ticky will count number of avoided tag checks by tag inference. + ---------------------------------- Flags -------------------------------------- + , stgToCmmLoopification :: !Bool -- ^ Loopification enabled (cf @-floopification@) + , stgToCmmAlignCheck :: !Bool -- ^ Insert alignment check (cf @-falignment-sanitisation@) + , stgToCmmFastPAPCalls :: !Bool -- ^ + , stgToCmmSCCProfiling :: !Bool -- ^ Check if cost-centre profiling is enabled + , stgToCmmEagerBlackHole :: !Bool -- ^ + , stgToCmmOrigThunkInfo :: !Bool -- ^ Push @stg_orig_thunk_info@ frames during thunk update. + , stgToCmmInfoTableMap :: !Bool -- ^ true means generate C Stub for IPE map, See Note [Mapping Info Tables to Source Positions] + , stgToCmmInfoTableMapWithFallback :: !Bool -- ^ Include info tables with fallback source locations in the info table map + , stgToCmmInfoTableMapWithStack :: !Bool -- ^ Include info tables for STACK closures in the info table map + , stgToCmmOmitYields :: !Bool -- ^ true means omit heap checks when no allocation is performed + , stgToCmmOmitIfPragmas :: !Bool -- ^ true means don't generate interface programs (implied by -O0) + , stgToCmmPIC :: !Bool -- ^ true if @-fPIC@ + , stgToCmmPIE :: !Bool -- ^ true if @-fPIE@ + , stgToCmmExtDynRefs :: !Bool -- ^ true if @-fexternal-dynamic-refs@, meaning generate + -- code for linking against dynamic libraries + , stgToCmmDoBoundsCheck :: !Bool -- ^ decides whether to check array bounds in StgToCmm.Prim + -- or not + , stgToCmmDoTagCheck :: !Bool -- ^ Verify tag inference predictions. + , stgToCmmObjectDeterminism :: !Bool -- ^ Enable deterministic code generation (more precisely, the deterministic unique-renaming pass in StgToCmm) + ------------------------------ Backend Flags ---------------------------------- + , stgToCmmAllowArith64 :: !Bool -- ^ Allowed to emit 64-bit arithmetic operations + , stgToCmmAllowQuot64 :: !Bool -- ^ Allowed to emit 64-bit division operations + , stgToCmmAllowQuotRemInstr :: !Bool -- ^ Allowed to generate QuotRem instructions + , stgToCmmAllowQuotRem2 :: !Bool -- ^ Allowed to generate QuotRem + , stgToCmmAllowExtendedAddSubInstrs :: !Bool -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc. + , stgToCmmAllowIntMul2Instr :: !Bool -- ^ Allowed to generate IntMul2 instruction + , stgToCmmAllowWordMul2Instr :: !Bool -- ^ Allowed to generate WordMul2 instruction + , stgToCmmAllowFMAInstr :: FMASign -> Bool -- ^ Allowed to generate FMA instruction + , stgToCmmAllowIntWord64X2MinMax :: !Bool -- ^ Allowed to generate min/max instructions for Int64X2/Word64X2 + , stgToCmmTickyAP :: !Bool -- ^ Disable use of precomputed standard thunks. + , stgToCmmSaveFCallTargetToLocal :: !Bool -- ^ Save a foreign call target to a Cmm local, see + -- Note [Saving foreign call target to local] for details + ------------------------------ SIMD flags ------------------------------------ + -- Each of these flags checks vector compatibility with the backend requested + -- during compilation. In essence, this means checking for @-fllvm@ which is + -- the only backend that currently allows SIMD instructions, see + -- Ghc.StgToCmm.Prim.checkVecCompatibility for these flags only call site. + , stgToCmmVecInstrsErr :: Maybe String -- ^ Error (if any) to raise when vector instructions are + -- used, see @StgToCmm.Prim.checkVecCompatibility@ + , stgToCmmAvx :: !Bool -- ^ check for Advanced Vector Extensions + , stgToCmmAvx2 :: !Bool -- ^ check for Advanced Vector Extensions 2 + , stgToCmmAvx512f :: !Bool -- ^ check for Advanced Vector 512-bit Extensions + } + + +stgToCmmPlatform :: StgToCmmConfig -> Platform +stgToCmmPlatform = profilePlatform . stgToCmmProfile diff --git a/GHC/StgToCmm/DataCon.hs b/GHC/StgToCmm/DataCon.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/DataCon.hs @@ -0,0 +1,403 @@ + + +----------------------------------------------------------------------------- +-- +-- Stg to C--: code generation for constructors +-- +-- This module provides the support code for StgToCmm to deal with +-- constructors on the RHSs of let(rec)s. +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.DataCon ( + cgTopRhsCon, buildDynCon, bindConArgs + ) where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Stg.Utils (allowTopLevelConApp) +import GHC.Stg.Syntax +import GHC.Core ( AltCon(..) ) + +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Env +import GHC.StgToCmm.Heap +import GHC.StgToCmm.Layout +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Closure + +import GHC.Cmm.Expr +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.Cmm.Graph +import GHC.Runtime.Heap.Layout +import GHC.Types.CostCentre +import GHC.Unit +import GHC.Core.DataCon +import GHC.Data.FastString +import GHC.Types.Id +import GHC.Types.Id.Info( CafInfo( NoCafRefs ) ) +import GHC.Types.Name (isInternalName) +import GHC.Types.RepType (countConRepArgs) +import GHC.Types.Literal +import GHC.Builtin.Utils +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Monad (mapMaybeM) + +import Data.Char +import GHC.StgToCmm.Config (stgToCmmPlatform) +import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn) +import GHC.Utils.Outputable + +--------------------------------------------------------------- +-- Top-level constructors +--------------------------------------------------------------- + +cgTopRhsCon :: StgToCmmConfig + -> Id -- Name of thing bound to this RHS + -> DataCon -- Id + -> ConstructorNumber + -> [NonVoid StgArg] -- Args + -> (CgIdInfo, FCode ()) +cgTopRhsCon cfg id con mn args + | Just static_info <- precomputedStaticConInfo_maybe cfg id con args + , let static_code | isInternalName name = pure () + | otherwise = gen_code + = -- There is a pre-allocated static closure available; use it + -- See Note [Precomputed static closures]. + -- For External bindings we must keep the binding, + -- since importing modules will refer to it by name; + -- but for Internal ones we can drop it altogether + -- See Note [About the NameSorts] in "GHC.Types.Name" for Internal/External + (static_info, static_code) + + -- Otherwise generate a closure for the constructor. + | otherwise + = (id_Info, gen_code) + + where + platform = stgToCmmPlatform cfg + id_Info = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label) + name = idName id + caffy = idCafInfo id -- any stgArgHasCafRefs args + closure_label = mkClosureLabel name caffy + + gen_code = + do { profile <- getProfile + ; this_mod <- getModuleName + ; massert (allowTopLevelConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args)) + ; massert (args `lengthIs` countConRepArgs con ) + ; checkConArgsStatic (text "TagCheck failed - Top level con") con (map fromNonVoid args) + -- LAY IT OUT + ; let + (tot_wds, -- #ptr_wds + #nonptr_wds + ptr_wds, -- #ptr_wds + nv_args_w_offsets) = + mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args) + + ; let + -- Decompose padding into units of length 8, 4, 2, or 1 bytes to + -- allow the implementation of mk_payload to use widthFromBytes, + -- which only handles these cases. + fix_padding (x@(Padding n off) : rest) + | n == 0 = fix_padding rest + | n `elem` [1,2,4,8] = x : fix_padding rest + | n > 8 = add_pad 8 + | n > 4 = add_pad 4 + | n > 2 = add_pad 2 + | otherwise = add_pad 1 + where add_pad m = Padding m off : fix_padding (Padding (n-m) (off+m) : rest) + fix_padding (x : rest) = x : fix_padding rest + fix_padding [] = [] + + mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len)) + mk_payload (FieldOff arg _) = do + amode <- getArgAmode arg + case amode of + CmmLit lit -> return lit + _ -> panic "GHC.StgToCmm.DataCon.cgTopRhsCon" + + nonptr_wds = tot_wds - ptr_wds + + -- we're not really going to emit an info table, so having + -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields + -- needs to poke around inside it. + info_tbl = mkDataConInfoTable profile con (addModuleLoc this_mod mn) True ptr_wds nonptr_wds + + + ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets) + -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs + -- NB2: all the amodes should be Lits! + -- TODO (osa): Why? + + -- BUILD THE OBJECT + -- + -- We're generating info tables, so we don't know and care about + -- what the actual arguments are. Using () here as the place holder. + + ; emitDataCon closure_label info_tbl dontCareCCS payload } + +addModuleLoc :: Module -> ConstructorNumber -> ConInfoTableLocation +addModuleLoc this_mod mn = do + case mn of + NoNumber -> DefinitionSite + Numbered n -> UsageSite this_mod n + +--------------------------------------------------------------- +-- Lay out and allocate non-top-level constructors +--------------------------------------------------------------- + +buildDynCon :: Id -- Name of the thing to which this constr will + -- be bound + -> ConstructorNumber + -> Bool -- is it genuinely bound to that name, or just + -- for profiling? + -> CostCentreStack -- Where to grab cost centre from; + -- current CCS if currentOrSubsumedCCS + -> DataCon -- The data constructor + -> [NonVoid StgArg] -- Its args + -> FCode (CgIdInfo, FCode CmmAGraph) + -- Return details about how to find it and initialization code +buildDynCon binder mn actually_bound cc con args + = do cfg <- getStgToCmmConfig + -- pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True + case precomputedStaticConInfo_maybe cfg binder con args of + Just cgInfo -> return (cgInfo, return mkNop) + Nothing -> buildDynCon' binder mn actually_bound cc con args + + +buildDynCon' :: Id + -> ConstructorNumber + -> Bool + -> CostCentreStack + -> DataCon + -> [NonVoid StgArg] + -> FCode (CgIdInfo, FCode CmmAGraph) +{- We used to pass a boolean indicating whether all the +args were of size zero, so we could use a static +constructor; but I concluded that it just isn't worth it. +Now I/O uses unboxed tuples there just aren't any constructors +with all size-zero args. + +The reason for having a separate argument, rather than looking at +the addr modes of the args is that we may be in a "knot", and +premature looking at the args will cause the compiler to black-hole! +-} +-------- buildDynCon': the general case ----------- +buildDynCon' binder mn actually_bound ccs con args + = do { (id_info, reg) <- rhsIdInfo binder lf_info + ; return (id_info, gen_code reg) + } + where + lf_info = mkConLFInfo con + + gen_code reg + = do { modu <- getModuleName + ; cfg <- getStgToCmmConfig + ; let platform = stgToCmmPlatform cfg + profile = stgToCmmProfile cfg + (tot_wds, ptr_wds, args_w_offsets) + = mkVirtConstrOffsets profile (addArgReps args) + nonptr_wds = tot_wds - ptr_wds + info_tbl = mkDataConInfoTable profile con (addModuleLoc modu mn) False + ptr_wds nonptr_wds + ; let ticky_name | actually_bound = Just binder + | otherwise = Nothing + + ; checkConArgsDyn (hang (text "TagCheck failed on constructor application.") 4 $ + text "On binder:" <> ppr binder $$ text "Constructor:" <> ppr con) con (map fromNonVoid args) + ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info + (use_cc platform) (blame_cc platform) + args_w_offsets + ; return (mkRhsInit platform reg lf_info hp_plus_n) } + where + use_cc platform -- cost-centre to stick in the object + | isCurrentCCS ccs = cccsExpr platform + | otherwise = panic "buildDynCon: non-current CCS not implemented" + + blame_cc = use_cc -- cost-centre on which to blame the alloc (same) + + +{- Note [Precomputed static closures] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For Char/Int closures there are some value closures +built into the RTS. This is the case for all values in +the range mINT_INTLIKE .. mAX_INTLIKE (or CHARLIKE). +See Note [CHARLIKE and INTLIKE closures] in the RTS code. + +Similarly zero-arity constructors have a closure +in their defining Module we can use. + +If possible we prefer to refer to those existing +closure instead of building new ones. + +This is true at compile time where we do this replacement +in this module. +But also at runtime where the GC does the same (but only for +INT/CHAR closures). + +`precomputedStaticConInfo_maybe` checks if a given constructor application +can be replaced with a reference to a existing static closure. + +If so the code will reference the existing closure when accessing +the binding. +Unless the binding is visible to other modules we also generate +no code for the binding itself. We can do this since then we can +always reference the existing closure. + +See Note [About the NameSorts] for the definition of external names. +For external bindings we must still generate a closure, +but won't use it inside this module. +This can sometimes reduce cache pressure. Since: +* If somebody uses the exported binding: + + This module will reference the existing closure. + + GC will reference the existing closure. + + The importing module will reference the built closure. +* If nobody uses the exported binding: + + This module will reference the RTS closures. + + GC references the RTS closures + +In the later case we avoided loading the built closure into the cache which +is what we optimize for here. + +Consider this example using Ints. + + module M(externalInt, foo, bar) where + + externalInt = 1 :: Int + internalInt = 1 :: Int + { -# NOINLINE foo #- } + foo = Just internalInt :: Maybe Int + bar = Just externalInt + + ==================== STG: ==================== + externalInt = I#! [1#]; + + bar = Just! [externalInt]; + + internalInt_rc = I#! [2#]; + + foo = Just! [internalInt_rc]; + +For externally visible bindings we must generate closures +since those may be referenced by their symbol `_closure` +when imported. + +`externalInt` is visible to other modules so we generate a closure: + + [section ""data" . M.externalInt_closure" { + M.externalInt_closure: + const GHC.Types.I#_con_info; + const 1; + }] + +It will be referenced inside this module via `M.externalInt_closure+1` + +`internalInt` is however a internal name. As such we generate no code for +it. References to it are replaced with references to the static closure as +we can see in the closure built for `foo`: + + [section ""data" . M.foo_closure" { + M.foo_closure: + const GHC.Maybe.Just_con_info; + const stg_INTLIKE_closure+289; // == I# 2 + const 3; + }] + +This holds for both local and top level bindings. + +We don't support this optimization when compiling into Windows DLLs yet +because they don't support cross package data references well. +-} + +-- (precomputedStaticConInfo_maybe cfg id con args) +-- returns (Just cg_id_info) +-- if there is a precomputed static closure for (con args). +-- In that case, cg_id_info addresses it. +-- See Note [Precomputed static closures] +precomputedStaticConInfo_maybe :: StgToCmmConfig -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo +precomputedStaticConInfo_maybe cfg binder con [] +-- Nullary constructors + | isNullaryRepDataCon con + = Just $ litIdInfo (stgToCmmPlatform cfg) binder (mkConLFInfo con) + (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs)) +precomputedStaticConInfo_maybe cfg binder con [arg] + -- Int/Char values with existing closures in the RTS + | intClosure || charClosure + , platformOS platform /= OSMinGW32 || not (stgToCmmPIE cfg || stgToCmmPIC cfg) + , Just val <- getClosurePayload arg + , inRange val + = let intlike_lbl = mkCmmClosureLabel rtsUnitId label + val_int = fromIntegral val :: Int + offsetW = (val_int - fromIntegral min_static_range) * (fixedHdrSizeW profile + 1) + -- INTLIKE/CHARLIKE closures consist of a header and one word payload + static_amode = cmmLabelOffW platform intlike_lbl offsetW + in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode + where + profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg + intClosure = maybeIntLikeCon con + charClosure = maybeCharLikeCon con + getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val + getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just (fromIntegral . ord $ val) + getClosurePayload _ = Nothing + -- Avoid over/underflow by comparisons at type Integer! + inRange :: Integer -> Bool + inRange val + = val >= min_static_range && val <= max_static_range + + constants = platformConstants platform + + min_static_range :: Integer + min_static_range + | intClosure = fromIntegral (pc_MIN_INTLIKE constants) + | charClosure = fromIntegral (pc_MIN_CHARLIKE constants) + | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" + max_static_range + | intClosure = fromIntegral (pc_MAX_INTLIKE constants) + | charClosure = fromIntegral (pc_MAX_CHARLIKE constants) + | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" + label + | intClosure = fsLit "stg_INTLIKE" + | charClosure = fsLit "stg_CHARLIKE" + | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" + +precomputedStaticConInfo_maybe _ _ _ _ = Nothing + +--------------------------------------------------------------- +-- Binding constructor arguments +--------------------------------------------------------------- + +bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg] +-- bindConArgs is called from cgAlt of a case +-- (bindConArgs con args) augments the environment with bindings for the +-- binders args, assuming that we have just returned from a 'case' which +-- found a con +bindConArgs (DataAlt con) base args + = assert (not (isUnboxedTupleDataCon con)) $ + do profile <- getProfile + platform <- getPlatform + let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args) + tag = tagForCon platform con + + -- The binding below forces the masking out of the tag bits + -- when accessing the constructor field. + bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg) + bind_arg (arg@(NonVoid b), offset) + | isDeadBinder b -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr + = return Nothing + | otherwise + = do { emit $ mkTaggedObjectLoad platform (idToReg platform arg) + base offset tag + ; Just <$> bindArgToReg arg } + + mapMaybeM bind_arg args_w_offsets + +bindConArgs _other_con _base args + = assert (null args ) return [] diff --git a/GHC/StgToCmm/Env.hs b/GHC/StgToCmm/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Env.hs @@ -0,0 +1,208 @@ + + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation: the binding environment +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- +module GHC.StgToCmm.Env ( + CgIdInfo, + + mkCgIdInfo, litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit, + idInfoToAmode, + + addBindC, addBindsC, + + bindArgsToRegs, bindToReg, rebindToReg, + bindArgToReg, idToReg, + getCgIdInfo, getCgInfo_maybe, + maybeLetNoEscape, + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Closure + +import GHC.Cmm.CLabel + +import GHC.Cmm.BlockId +import GHC.Cmm.Expr +import GHC.Cmm.Utils +import GHC.Types.Id +import GHC.Cmm.Graph +import GHC.Types.Name +import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Builtin.Types.Prim +import GHC.Types.Unique.FM +import GHC.Types.Var.Env + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Builtin.Names (getUnique) + + +------------------------------------- +-- Manipulating CgIdInfo +------------------------------------- + +mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo +mkCgIdInfo id lf expr + = CgIdInfo { cg_id = id, cg_lf = lf + , cg_loc = CmmLoc expr } + +litIdInfo :: Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo +litIdInfo platform id lf lit + = CgIdInfo { cg_id = id, cg_lf = lf + , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) } + where + tag = lfDynTag platform lf + +lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo +lneIdInfo platform id regs + = CgIdInfo { cg_id = id, cg_lf = lf + , cg_loc = LneLoc blk_id (map (idToReg platform) regs) } + where + lf = mkLFLetNoEscape + blk_id = mkBlockId (idUnique id) + + +rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg) +rhsIdInfo id lf_info + = do platform <- getPlatform + reg <- newTemp (gcWord platform) + return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) + +mkRhsInit :: Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph +mkRhsInit platform reg lf_info expr + = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform lf_info)) + +-- | Returns a 'CmmExpr' for the *tagged* pointer +idInfoToAmode :: CgIdInfo -> CmmExpr +idInfoToAmode CgIdInfo { cg_loc = CmmLoc e } = e +idInfoToAmode cg_info + = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc + +-- | A tag adds a byte offset to the pointer +addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr +addDynTag = cmmOffsetB + +maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) +maybeLetNoEscape CgIdInfo { cg_loc = LneLoc blk_id args} = Just (blk_id, args) +maybeLetNoEscape _other = Nothing + + + +--------------------------------------------------------- +-- The binding environment +-- +-- There are three basic routines, for adding (addBindC), +-- modifying(modifyBindC) and looking up (getCgIdInfo) bindings. +--------------------------------------------------------- + +addBindC :: CgIdInfo -> FCode () +addBindC stuff_to_bind = do + binds <- getBinds + setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind + +addBindsC :: [CgIdInfo] -> FCode () +addBindsC new_bindings = do + binds <- getBinds + let new_binds = foldl' (\ binds info -> extendVarEnv binds (cg_id info) info) + binds + new_bindings + setBinds new_binds + +-- Inside GHC the average module creates 385 external references +-- with notable cgIdInfo (so not generated by mkLFArgument). +-- On average 200 of these are covered by True/False/[] +-- and nullary constructors make up ~80. +-- One would think it would be worthwhile to cache these. +-- Sadly it's not. See #16937 + +getCgIdInfo :: Id -> FCode CgIdInfo +getCgIdInfo id + = do { platform <- getPlatform + ; local_binds <- getBinds -- Try local bindings first + ; case lookupVarEnv local_binds id of { + Just info -> -- pprTrace "getCgIdInfoLocal" (ppr id) $ + return info ; + Nothing -> do { + + -- Should be imported; make up a CgIdInfo for it + let name = idName id + ; if isExternalName name then + let ext_lbl + | isBoxedType (idType id) + = mkClosureLabel name $ idCafInfo id + | isUnliftedType (idType id) + -- An unlifted external Id must refer to a top-level + -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel". + = assert (idType id `eqType` addrPrimTy) $ + mkBytesLabel name + | otherwise + = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id)) + in return $ + litIdInfo platform id (importedIdLFInfo id) (CmmLabel ext_lbl) + else + cgLookupPanic id -- Bug, id is neither in local binds nor is external + }}} + +-- | Retrieve cg info for a name if it already exists. +getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo) +getCgInfo_maybe name + = do { local_binds <- getBinds -- Try local bindings first + ; return $ lookupVarEnv_Directly local_binds (getUnique name) } + +cgLookupPanic :: Id -> FCode a +cgLookupPanic id + = do local_binds <- getBinds + pprPanic "GHC.StgToCmm.Env: variable not found" + (vcat [ppr id, + text "local binds for:", + pprUFM local_binds $ \infos -> + vcat [ ppr (cg_id info) | info <- infos ] + ]) + + +------------------------------------------------------------------------ +-- Interface functions for binding and re-binding names +------------------------------------------------------------------------ + +bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg +-- Bind an Id to a fresh LocalReg +bindToReg nvid@(NonVoid id) lf_info + = do platform <- getPlatform + let reg = idToReg platform nvid + addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) + return reg + +rebindToReg :: NonVoid Id -> FCode LocalReg +-- Like bindToReg, but the Id is already in scope, so +-- get its LF info from the envt +rebindToReg nvid@(NonVoid id) + = do { info <- getCgIdInfo id + ; bindToReg nvid (cg_lf info) } + +bindArgToReg :: NonVoid Id -> FCode LocalReg +bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) + +bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] +bindArgsToRegs = mapM bindArgToReg + +idToReg :: Platform -> NonVoid Id -> LocalReg +-- Make a register from an Id, typically a function argument, +-- free variable, or case binder +-- +-- We re-use the Unique from the Id to make it easier to see what is going on +-- +-- By now the Ids should be uniquely named; else one would worry +-- about accidental collision +idToReg platform (NonVoid id) + = LocalReg (idUnique id) + (primRepCmmType platform (idPrimRepU id)) diff --git a/GHC/StgToCmm/Expr.hs b/GHC/StgToCmm/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Expr.hs @@ -0,0 +1,1276 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation: expressions +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Expr ( cgExpr, cgLit ) where + +import GHC.Prelude hiding ((<*>)) + +import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind ) + +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Heap +import GHC.StgToCmm.Env +import GHC.StgToCmm.DataCon +import GHC.StgToCmm.Prof (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC) +import GHC.StgToCmm.Layout +import GHC.StgToCmm.Lit +import GHC.StgToCmm.Prim +import GHC.StgToCmm.Hpc +import GHC.StgToCmm.TagCheck +import GHC.StgToCmm.Ticky +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Closure + +import GHC.Stg.Syntax + +import GHC.Cmm.Graph +import GHC.Cmm.BlockId +import GHC.Cmm hiding ( succ ) +import GHC.Cmm.Info +import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, mAX_PTR_TAG ) +import GHC.Core +import GHC.Core.DataCon +import GHC.Types.ForeignCall +import GHC.Types.Id +import GHC.Builtin.PrimOps +import GHC.Core.TyCon +import GHC.Core.Type ( isUnliftedType ) +import GHC.Types.RepType ( isZeroBitTy, countConRepArgs, mightBeFunTy ) +import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) +import GHC.Types.Tickish +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Monad ( unless, void ) +import Control.Arrow ( first ) +import Data.List ( partition ) +import GHC.Stg.EnforceEpt.TagSig (isTaggedSig) +import GHC.Platform.Profile (profileIsProfiling) + +------------------------------------------------------------------------ +-- cgExpr: the main function +------------------------------------------------------------------------ + +cgExpr :: CgStgExpr -> FCode ReturnKind + +cgExpr (StgApp fun args) = cgIdApp fun args + +-- dataToTagSmall# :: a_levpoly -> Int# +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do + platform <- getPlatform + emitComment (mkFastString "dataToTagSmall#") + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + tag1 = cmmConstrTag1 platform a_eval_expr + + -- subtract 1 because we need to return a zero-indexed tag + emitReturn [cmmSubWord platform tag1 (CmmLit $ mkWordCLit platform 1)] + +-- dataToTagLarge# :: a_levpoly -> Int# +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do + platform <- getPlatform + emitComment (mkFastString "dataToTagLarge#") + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + + tag1_reg <- assignTemp $ cmmConstrTag1 platform a_eval_expr + result_reg <- newTemp (bWord platform) + let tag1_expr = CmmReg $ CmmLocal tag1_reg + is_too_big_tag = cmmEqWord platform tag1_expr (cmmTagMask platform) + + -- Return the constructor index from the pointer tag + -- (Used if pointer tag is small enough to be unambiguous) + return_ptr_tag <- getCode $ do + emitAssign (CmmLocal result_reg) + $ cmmSubWord platform tag1_expr (CmmLit $ mkWordCLit platform 1) + + -- Return the constructor index recorded in the info table + return_info_tag <- getCode $ do + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + emitAssign (CmmLocal result_reg) + $ getConstrTag profile align_check (cmmUntag platform a_eval_expr) + + emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) + emitReturn [CmmReg $ CmmLocal result_reg] + + +cgExpr (StgOpApp op args ty) = cgOpApp op args ty +cgExpr (StgConApp con mn args _) = cgConApp con mn args +cgExpr (StgTick t e) = cgTick t >> cgExpr e +cgExpr (StgLit lit) = do cmm_expr <- cgLit lit + emitReturn [cmm_expr] + +cgExpr (StgLet _ binds expr) = do { cgBind binds; cgExpr expr } +cgExpr (StgLetNoEscape _ binds expr) = + do { u <- newUnique + ; let join_id = mkBlockId u + ; cgLneBinds join_id binds + ; r <- cgExpr expr + ; emitLabel join_id + ; return r } + +cgExpr (StgCase expr bndr alt_type alts) = + cgCase expr bndr alt_type alts + +------------------------------------------------------------------------ +-- Let no escape +------------------------------------------------------------------------ + +{- Generating code for a let-no-escape binding, aka join point is very +very similar to what we do for a case expression. The duality is +between + let-no-escape x = b + in e +and + case e of ... -> b + +That is, the RHS of 'x' (ie 'b') will execute *later*, just like +the alternative of the case; it needs to be compiled in an environment +in which all volatile bindings are forgotten, and the free vars are +bound only to stable things like stack locations.. The 'e' part will +execute *next*, just like the scrutinee of a case. -} + +------------------------- +cgLneBinds :: BlockId -> CgStgBinding -> FCode () +cgLneBinds join_id (StgNonRec bndr rhs) + = do { local_cc <- saveCurrentCostCentre + -- See Note [Saving the current cost centre] + ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs + ; fcode + ; addBindC info } + +cgLneBinds join_id (StgRec pairs) + = do { local_cc <- saveCurrentCostCentre + ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs + ; let (infos, fcodes) = unzip r + ; addBindsC infos + ; sequence_ fcodes + } + +------------------------- +cgLetNoEscapeRhs + :: BlockId -- join point for successor of let-no-escape + -> Maybe LocalReg -- Saved cost centre + -> Id + -> CgStgRhs + -> FCode (CgIdInfo, FCode ()) + +cgLetNoEscapeRhs join_id local_cc bndr rhs = + do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs + ; let (bid, _) = expectJust $ maybeLetNoEscape info + ; let code = do { (_, body) <- getCodeScoped rhs_code + ; emitOutOfLine bid (first (<*> mkBranch join_id) body) } + ; return (info, code) + } + +cgLetNoEscapeRhsBody + :: Maybe LocalReg -- Saved cost centre + -> Id + -> CgStgRhs + -> FCode (CgIdInfo, FCode ()) +cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body _typ) + = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body +cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args _typ) + = cgLetNoEscapeClosure bndr local_cc cc [] + (StgConApp con mn args (pprPanic "cgLetNoEscapeRhsBody" $ + text "StgRhsCon doesn't have type args")) + -- For a constructor RHS we want to generate a single chunk of + -- code which can be jumped to from many places, which will + -- return the constructor. It's easy; just behave as if it + -- was an StgRhsClosure with a ConApp inside! + +------------------------- +cgLetNoEscapeClosure + :: Id -- binder + -> Maybe LocalReg -- Slot for saved current cost centre + -> CostCentreStack -- XXX: *** NOT USED *** why not? + -> [NonVoid Id] -- Args (as in \ args -> body) + -> CgStgExpr -- Body (as in above) + -> FCode (CgIdInfo, FCode ()) + +cgLetNoEscapeClosure bndr cc_slot _unused_cc args body + = do platform <- getPlatform + let code = forkLneBody $ withNewTickyCounterLNE bndr args $ do + { restoreCurrentCostCentre platform cc_slot + ; arg_regs <- bindArgsToRegs args + ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } + return ( lneIdInfo platform bndr args, code ) + + +------------------------------------------------------------------------ +-- Case expressions +------------------------------------------------------------------------ + +{- Note [Compiling case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is quite interesting to decide whether to put a heap-check at the +start of each alternative. Of course we certainly have to do so if +the case forces an evaluation, or if there is a primitive op which can +trigger GC. + +NB: things are not settled here: see #8326. + +A more interesting situation is this (a Plan-B situation) + + !P!; + ...P... + case x# of + 0# -> !Q!; ...Q... + default -> !R!; ...R... + +where !x! indicates a possible heap-check point. The heap checks +in the alternatives *can* be omitted, in which case the topmost +heapcheck will take their worst case into account. + +In favour of omitting !Q!, !R!: + + - *May* save a heap overflow test, + if ...P... allocates anything. + + - We can use relative addressing from a single Hp to + get at all the closures so allocated. + + - No need to save volatile vars etc across heap checks + in !Q!, !R! + +Against omitting !Q!, !R! + + - May put a heap-check into the inner loop. Suppose + the main loop is P -> R -> P -> R... + Q is the loop exit, and only it does allocation. + This only hurts us if P does no allocation. If P allocates, + then there is a heap check in the inner loop anyway. + + - May do more allocation than reqd. This sometimes bites us + badly. For example, nfib (ha!) allocates about 30\% more space if the + worst-casing is done, because many many calls to nfib are leaf calls + which don't need to allocate anything. + + We can un-allocate, but that costs an instruction + +Neither problem hurts us if there is only one alternative. + +Suppose the inner loop is P->R->P->R etc. Then here is +how many heap checks we get in the *inner loop* under various +conditions + + Alloc Heap check in branches (!Q!, !R!)? + P Q R yes no (absorb to !P!) +-------------------------------------- + n n n 0 0 + n y n 0 1 + n . y 1 1 + y . y 2 1 + y . n 1 1 + +Best choices: absorb heap checks from Q and R into !P! iff + a) P itself does some allocation +or + b) P does allocation, or there is exactly one alternative + +We adopt (b) because that is more likely to put the heap check at the +entry to a function, when not many things are live. After a bunch of +single-branch cases, we may have lots of things live + +Hence: Two basic plans for + + case e of r { alts } + +------ Plan A: the general case --------- + + ...save current cost centre... + + ...code for e, + with sequel (SetLocals r) + + ...restore current cost centre... + ...code for alts... + ...alts do their own heap checks + + When using GcInAlts the return point for heap checks and evaluating + the scrutinee is shared. This does mean we might execute the actual + branching code twice but it's rare enough to not matter. + The huge advantage of this pattern is that we do not require multiple + info tables for returning from gc as they can be shared between all + cases. Reducing code size nicely. + +------ Plan B: special case when --------- + (i) e does not allocate or call GC + (ii) either upstream code performs allocation + or there is just one alternative + + Then heap allocation in the (single) case branch + is absorbed by the upstream check. + Very common example: primops on unboxed values + + ...code for e, + with sequel (SetLocals r)... + + ...code for alts... + ...no heap check... + + There is a variant B.2 which we use if: + + (i) e is already evaluated+tagged + (ii) We have multiple alternatives + (iii) and there is no upstream allocation. + + Here we also place one heap check before the `case` which + branches on `e`. Hopefully to be absorbed by an already existing + heap check further up. However the big difference in this case is that + there is no code for e. So we are not guaranteed that the heap + checks of the alts will be combined with an heap check further up. + + Very common example: Casing on strict fields. + + ...heap check... + ...assign bindings... + + ...code for alts... + ...no heap check... + + -- Reasoning for Plan B.2: + Since the scrutinee is already evaluated there is no evaluation + call which would force a info table that we can use as a shared + return point. + This means currently if we were to do GcInAlts like in Plan A then + we would end up with one info table per alternative. + + To avoid this we unconditionally do gc outside of the alts with all + the pros and cons described in Note [Compiling case expressions]. + Rewriting the logic to generate a shared return point before the case + expression while keeping the heap checks in the alternatives would be + possible. But it's unclear to me that this would actually be an improvement. + + This means if we have code along these lines: + + g x y = case x of + True -> Left $ (y + 1,y,y-1) + False -> Right $! y - (2 :: Int) + + We get these potential heap check placements: + + f = ... + !max(L,R)!; -- Might be absorbed upstream. + case x of + True -> !L!; ...L... + False -> !R!; ...R... + + And we place a heap check at !max(L,R)! + + The downsides of using !max(L,R)! are: + + * If f is recursive, and the hot loop wouldn't allocate, but the exit branch does then we do + a redundant heap check. + * We use one more instruction to de-allocate the unused heap in the branch using less heap. (Negligible) + * A small risk of running gc slightly more often than needed especially if one branch allocates a lot. + + The upsides are: + * May save a heap overflow test if there is an upstream check already. + * If the heap check is absorbed upstream we can also eliminate its info table. + * We generate at most one heap check (versus one per alt otherwise). + * No need to save volatile vars etc across heap checks in !L!, !R! + * We can use relative addressing from a single Hp to get at all the closures so allocated. (seems neglible) + * It fits neatly in the logic we already have for handling A/B + + For containers:Data/Sequence/Internal/Sorting.o the difference is + about 10% in terms of code size compared to using Plan A for this case. + The main downside is we might put heap checks into loops, even if we + could avoid it (See Note [Compiling case expressions]). + + Potential improvement: Investigate if heap checks in alts would be an + improvement if we generate and use a shared return point that is placed + in the common path for all alts. + +-} + + + +------------------------------------- +data GcPlan + = GcInAlts -- Put a GC check at the start the case alternatives, + [LocalReg] -- which binds these registers + | NoGcInAlts -- The scrutinee is a primitive value, or a call to a + -- primitive op which does no GC. Absorb the allocation + -- of the case alternative(s) into the upstream check + +------------------------------------- +cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind + +{- +Note [Scrutinising VoidRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have this STG code: + f = \[s : State# RealWorld] -> + case s of _ -> blah +This is very odd. Why are we scrutinising a state token? But it +can arise with bizarre NOINLINE pragmas (#9964) + crash :: IO () + crash = IO (\s -> let {-# NOINLINE s' #-} + s' = s + in (# s', () #)) + +Now the trouble is that 's' has VoidRep, and we do not bind void +arguments in the environment; they don't live anywhere. See the +calls to nonVoidIds in various places. So we must not look up +'s' in the environment. Instead, just evaluate the RHS! Simple. + +Note [Dead-binder optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + + case x of (y, z) -> rhs + +where `z` is unused in `rhs`. When we return form the eval of `x`, +GHC.StgToCmm.DataCon.bindConArgs will generate some loads, assuming the the +value of `x` is returned in R1: + y := R1[1] + z := R1[2] + +If `z` is never used, the load `z := R1[2]` is a waste of a memory operation. +CmmSink (which sinks loads to their usage sites, if any) will eliminate the dead +load; but + 1. CmmSink only runs with -O + 2. It would save CmmSink work if we simply did not generate the load in the + first place. + +Hence STG uses dead-binder information, in `bindConArgs` to drop dead loads. +That's why we preserve occurrence-info on binders in GHC.Core.Tidy (see +GHC.Core.Tidy.tidyIdBndr). + +So it's important that deadness is accurate. But StgCse can invalidate it +(#14895 #24233). Here is an example: + + map_either :: (a -> b) -> Either String a -> Either String b + map_either = \f e -> case e of b { + Right x -> Right (f x) + Left x -> Left x + } + + The case-binder "b" is dead (not used in the rhss of the alternatives). + StgCse notices that `Left x` doesn't need to be allocated as we can reuse `b`, + and we get: + + map_either :: (a -> b) -> Either String a -> Either String b + map_either = \f e -> case e of b { -- b no longer dead! + Right x -> Right (f x) + Left x -> b + } + +For now StgCse simply zaps occurrence information on case binders. A more +accurate update would complexify the implementation and doesn't seem worth it. + +-} + +cgCase (StgApp v []) _ (PrimAlt _) alts + | isZeroBitTy (idType v) -- See Note [Scrutinising VoidRep] + , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts + = cgExpr rhs + +{- Note [Dodgy unsafeCoerce 1] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case (x :: HValue) |> co of (y :: MutVar# Int) + DEFAULT -> ... +We want to generate an assignment + y := x +We want to allow this assignment to be generated in the case when the +types are compatible, because this allows some slightly-dodgy but +occasionally-useful casts to be used, such as in GHC.Runtime.Heap.Inspect +where we cast an HValue to a MutVar# so we can print out the contents +of the MutVar#. If instead we generate code that enters the HValue, +then we'll get a runtime panic, because the HValue really is a +MutVar#. The types are compatible though, so we can just generate an +assignment. +-} +cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts + | isUnliftedType (idType v) -- Note [Dodgy unsafeCoerce 1] + = -- assignment suffices for unlifted types + do { platform <- getPlatform + ; unless (reps_compatible platform) $ + pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" + (pp_bndr v $$ pp_bndr bndr) + ; v_info <- getCgIdInfo v + ; emitAssign (CmmLocal (idToReg platform (NonVoid bndr))) + (idInfoToAmode v_info) + -- Add bndr to the environment + ; _ <- bindArgToReg (NonVoid bndr) + ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } + where + reps_compatible platform = primRepCompatible platform (idPrimRepU v) (idPrimRepU bndr) + + pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRepU id)) + +{- Note [Dodgy unsafeCoerce 2, #3132] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In all other cases of a lifted Id being cast to an unlifted type, the +Id should be bound to bottom, otherwise this is an unsafe use of +unsafeCoerce. We can generate code to enter the Id and assume that +it will never return. Hence, we emit the usual enter/return code, and +because bottom must be untagged, it will be entered. The Sequel is a +type-correct assignment, albeit bogus. The (dead) continuation loops; +it would be better to invoke some kind of panic function here. +-} +cgCase scrut@(StgApp v []) _ (PrimAlt _) _ + = do { platform <- getPlatform + ; mb_cc <- maybeSaveCostCentre True + ; _ <- withSequel + (AssignTo [idToReg platform (NonVoid v)] False) (cgExpr scrut) + ; restoreCurrentCostCentre platform mb_cc + ; emitComment $ mkFastString "should be unreachable code" + ; l <- newBlockId + ; emitLabel l + ; emit (mkBranch l) -- an infinite loop + ; return AssignedDirectly + } + +{- +Note [Eliminate trivial Solo# continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have code like this: + + case scrut of bndr { + alt -> Solo# bndr + } + +The RHS of the only branch does nothing except wrap the case-binder +returned by 'scrut' in a unary unboxed tuple. But unboxed tuples +don't exist at run-time, i.e. the branch is a no-op! So we can +generate code as if we just had 'scrut' instead of a case-expression. + +This situation can easily arise for IO or ST code, where the last +operation a function performs is commonly 'pure $! someExpr'. +See also #24264 and !11778. More concretely, as of December 2023, +when building a stage2 "perf+no_profiled_libs" ghc: + + * The special case is reached 398 times. + * Of these, 158 have scrutinees that call a function or enter a + potential thunk, and would need to push a useless stack frame if + not for this optimisation. + +We might consider rewriting such case expressions in GHC.Stg.CSE as a +slight extension of Note [All alternatives are the binder]. But the +RuntimeReps of 'bndr' and 'Solo# bndr' are not exactly the same, and +per Note [Typing the STG language] in GHC.Stg.Lint, we do expect Stg +code to remain RuntimeRep-correct. So we just detect the situation in +StgToCmm instead. + +Crucially, the return conventions for 'ty' and '(# ty #)' are compatible: +The returned value is passed in the same register(s) or stack slot in +both conventions, and the set of allowed return values for 'ty' +is a subset of the allowed return values for '(# ty #)': + + * For a lifted type 'ty', the return convention for 'ty' promises to + return an evaluated-properly-tagged heap pointer, while a return + type '(# ty #)' only promises to return a heap pointer to an object + that can be evaluated later if need be. + + * If 'ty' is unlifted, the allowed return + values for 'ty' and '(# ty #)' are identical. +-} + +cgCase scrut bndr _alt_type [GenStgAlt { alt_rhs = rhs}] + -- see Note [Eliminate trivial Solo# continuations] + | StgConApp dc _ [StgVarArg v] _ <- rhs + , isUnboxedTupleDataCon dc + , v == bndr + = cgExpr scrut + +cgCase scrut bndr alt_type alts + = -- the general case + do { platform <- getPlatform + ; up_hp_usg <- getVirtHp -- Upstream heap usage + ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts + alt_regs = map (idToReg platform) ret_bndrs + + ; simple_scrut <- isSimpleScrut scrut alt_type + ; let do_gc | is_cmp_op scrut = False -- See Note [GC for conditionals] + | not simple_scrut = True + | isSingleton alts = False + | up_hp_usg > 0 = False + | otherwise = True + -- cf Note [Compiling case expressions] + gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts + + ; mb_cc <- maybeSaveCostCentre simple_scrut + + ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -} + ; ret_kind <- withSequel sequel (cgExpr scrut) + ; restoreCurrentCostCentre platform mb_cc + ; _ <- bindArgsToRegs ret_bndrs + ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts + } + where + is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op + is_cmp_op _ = False + + +{- Note [GC for conditionals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For comparison operators (`is_cmp_op`) it seems that we have always done +NoGcInAlts. It's odd, and it's flagrantly inconsistent with the rules described +Note [Compiling case expressions]. However, that's the way it has been for ages +(there was some long-gone history involving tagToEnum#; see #13397, #8317, #8326). + +Note [scrut sequel] +~~~~~~~~~~~~~~~~~~~ +The job of the scrutinee is to assign its value(s) to alt_regs. +Additionally, if we plan to do a heap-check in the alternatives (see +Note [Compiling case expressions]), then we *must* retreat Hp to +recover any unused heap before passing control to the sequel. If we +don't do this, then any unused heap will become slop because the heap +check will reset the heap usage. Slop in the heap breaks LDV profiling +(+RTS -hb) which needs to do a linear sweep through the nursery. + + +Note [Inlining out-of-line primops and heap checks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If shouldInlinePrimOp returns True when called from GHC.StgToCmm.Expr for the +purpose of heap check placement, we *must* inline the primop later in +GHC.StgToCmm.Prim. If we don't things will go wrong. +-} + +----------------- +maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg) +maybeSaveCostCentre simple_scrut + | simple_scrut = return Nothing + | otherwise = saveCurrentCostCentre + + +----------------- +isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool +-- Simple scrutinee, does not block or allocate; hence safe to amalgamate +-- heap usage from alternatives into the stuff before the case +-- NB: if you get this wrong, and claim that the expression doesn't allocate +-- when it does, you'll deeply mess up allocation +isSimpleScrut (StgOpApp op args _) _ = isSimpleOp op args +isSimpleScrut (StgLit _) _ = return True -- case 1# of { 0# -> ..; ... } +isSimpleScrut (StgApp _ []) (PrimAlt _) = return True -- case x# of { 0# -> ..; ... } +isSimpleScrut (StgApp f []) _ + | Just sig <- idTagSig_maybe f + , isTaggedSig sig -- case !x of { ... } + = if mightBeFunTy (idType f) + -- See Note [Evaluating functions with profiling] in rts/Apply.cmm + then not . profileIsProfiling <$> getProfile + else pure True +isSimpleScrut _ _ = return False + +isSimpleOp :: StgOp -> [StgArg] -> FCode Bool +-- True iff the op cannot block or allocate +isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) +-- dataToTagSmall#/dataToTagLarge# evaluate an argument; +-- see Note [DataToTag overview] in GHC.Tc.Instance.Class +isSimpleOp (StgPrimOp DataToTagSmallOp) _ = return False +isSimpleOp (StgPrimOp DataToTagLargeOp) _ = return False +isSimpleOp (StgPrimOp op) stg_args = do + arg_exprs <- getNonVoidArgAmodes stg_args + cfg <- getStgToCmmConfig + -- See Note [Inlining out-of-line primops and heap checks] + return $! shouldInlinePrimOp cfg op arg_exprs +isSimpleOp (StgPrimCallOp _) _ = return False + +----------------- +chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id] +-- These are the binders of a case that are assigned by the evaluation of the +-- scrutinee. +-- They're non-void, see Note [Post-unarisation invariants] in GHC.Stg.Unarise. +chooseReturnBndrs bndr (PrimAlt _) _alts + = assertNonVoidIds [bndr] + +chooseReturnBndrs _bndr (MultiValAlt n) [alt] + = assertPpr (ids `lengthIs` n) (ppr n $$ ppr ids $$ ppr _bndr) $ + assertNonVoidIds ids -- 'bndr' is not assigned! + where ids = alt_bndrs alt + +chooseReturnBndrs bndr (AlgAlt _) _alts + = assertNonVoidIds [bndr] -- Only 'bndr' is assigned + +chooseReturnBndrs bndr PolyAlt _alts + = assertNonVoidIds [bndr] -- Only 'bndr' is assigned + +chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs" + -- MultiValAlt has only one alternative + +------------------------------------- +cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt] + -> FCode ReturnKind +-- At this point the result of the case are in the binders +cgAlts gc_plan _bndr PolyAlt [alt] + = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt) + +cgAlts gc_plan _bndr (MultiValAlt _) [alt] + = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt) + -- Here bndrs are *already* in scope, so don't rebind them + +cgAlts gc_plan bndr (PrimAlt _) alts + = do { platform <- getPlatform + + ; tagged_cmms <- cgAltRhss gc_plan bndr alts + + ; let bndr_reg = CmmLocal (idToReg platform bndr) + deflt = case tagged_cmms of + (DEFAULT,deflt):_ -> deflt + _ -> panic "cgAlts PrimAlt" + -- PrimAlts always have a DEFAULT case + -- and it always comes first + + tagged_cmms' = [(lit,code) + | (LitAlt lit, code) <- tagged_cmms] + ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt + ; return AssignedDirectly } + +cgAlts gc_plan bndr (AlgAlt tycon) alts + = do { platform <- getPlatform + + ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts + + ; let !fam_sz = tyConFamilySize tycon + !bndr_reg = CmmLocal (idToReg platform bndr) + !ptag_expr = cmmConstrTag1 platform (CmmReg bndr_reg) + !branches' = first succ <$> branches + !maxpt = mAX_PTR_TAG platform + (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches' + !small = isSmallFamily platform fam_sz + + -- Is the constructor tag in the node reg? + -- See Note [Tagging big families] + ; if small || null via_info + then -- Yes, bndr_reg has constructor tag in ls bits + emitSwitch ptag_expr branches' mb_deflt 1 + (if small then fam_sz else maxpt) + + else -- No, the get exact tag from info table when mAX_PTR_TAG + -- See Note [Double switching for big families] + do + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + let !untagged_ptr = cmmUntag platform (CmmReg bndr_reg) + !itag_expr = getConstrTag profile align_check untagged_ptr + !info0 = first pred <$> via_info + if null via_ptr then + emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1) + else do + infos_lbl <- newBlockId + infos_scp <- getTickScope + + let spillover = (maxpt, (mkBranch infos_lbl, infos_scp)) + + (mb_shared_deflt, mb_shared_branch) <- case mb_deflt of + (Just (stmts, scp)) -> + do lbl <- newBlockId + return ( Just (mkLabel lbl scp <*> stmts, scp) + , Just (mkBranch lbl, scp)) + _ -> return (Nothing, Nothing) + -- Switch on pointer tag + emitSwitch ptag_expr (spillover : via_ptr) mb_shared_deflt 1 maxpt + join_lbl <- newBlockId + emit (mkBranch join_lbl) + -- Switch on info table tag + emitLabel infos_lbl + emitSwitch itag_expr info0 mb_shared_branch + (maxpt - 1) (fam_sz - 1) + emitLabel join_lbl + + ; return AssignedDirectly } + +cgAlts _ _ _ _ = panic "cgAlts" + -- UbxTupAlt and PolyAlt have only one alternative + +-- Note [Double switching for big families] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- An algebraic data type can have a n >= 0 summands +-- (or alternatives), which are identified (labeled) by +-- constructors. In memory they are kept apart by tags +-- (see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure). +-- Due to the characteristics of the platform that +-- contribute to the alignment of memory objects, there +-- is a natural limit of information about constructors +-- that can be encoded in the pointer tag. When the mapping +-- of constructors to the pointer tag range 1..mAX_PTR_TAG +-- is not injective, then we have a "big data type", also +-- called a "big (constructor) family" in the literature. +-- Constructor tags residing in the info table are injective, +-- but considerably more expensive to obtain, due to additional +-- memory access(es). +-- +-- When doing case analysis on a value of a "big data type" +-- we need two nested switch statements to make up for the lack +-- of injectivity of pointer tagging, also taking the info +-- table tag into account. The exact mechanism is described next. +-- +-- In the general case, switching on big family alternatives +-- is done by two nested switch statements. According to +-- Note [Tagging big families], the outer switch +-- looks at the pointer tag and the inner dereferences the +-- pointer and switches on the info table tag. +-- +-- We can handle a simple case first, namely when none +-- of the case alternatives mention a constructor having +-- a pointer tag of 1..mAX_PTR_TAG-1. In this case we +-- simply emit a switch on the info table tag. +-- Note that the other simple case is when all mentioned +-- alternatives lie in 1..mAX_PTR_TAG-1, in which case we can +-- switch on the ptr tag only, just like in the small family case. +-- +-- There is a single intricacy with a nested switch: +-- Both should branch to the same default alternative, and as such +-- avoid duplicate codegen of potentially heavy code. The outer +-- switch generates the actual code with a prepended fresh label, +-- while the inner one only generates a jump to that label. +-- +-- For example, let's assume a 64-bit architecture, so that all +-- heap objects are 8-byte aligned, and hence the address of a +-- heap object ends in `000` (three zero bits). +-- +-- Then consider the following data type +-- +-- > data Big = T0 | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 +-- Ptr tag: 1 2 3 4 5 6 7 7 7 +-- As bits: 001 010 011 100 101 110 111 111 111 +-- Info pointer tag (zero based): +-- 0 1 2 3 4 5 6 7 8 +-- +-- Then \case T2 -> True; T8 -> True; _ -> False +-- will result in following code (slightly cleaned-up and +-- commented -ddump-cmm-from-stg): +{- + R1 = _sqI::P64; -- scrutinee + if (R1 & 7 != 0) goto cqO; else goto cqP; + cqP: // global -- enter + call (I64[R1])(R1) returns to cqO, args: 8, res: 8, upd: 8; + cqO: // global -- already WHNF + _sqJ::P64 = R1; + _cqX::P64 = _sqJ::P64 & 7; -- extract pointer tag + switch [1 .. 7] _cqX::P64 { + case 3 : goto cqW; + case 7 : goto cqR; + default: {goto cqS;} + } + cqR: // global + _cr2 = I32[I64[_sqJ::P64 & (-8)] - 4]; -- tag from info pointer + switch [6 .. 8] _cr2::I64 { + case 8 : goto cr1; + default: {goto cr0;} + } + cr1: // global + R1 = GHC.Types.True_closure+2; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + cr0: // global -- technically necessary label + goto cqS; + cqW: // global + R1 = GHC.Types.True_closure+2; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + cqS: // global + R1 = GHC.Types.False_closure+1; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; +-} +-- +-- For 32-bit systems we only have 2 tag bits in the pointers at our disposal, +-- so the performance win is dubious, especially in face of the increased code +-- size due to double switching. But we can take the viewpoint that 32-bit +-- architectures are not relevant for performance any more, so this can be +-- considered as moot. + + +-- Note [alg-alt heap check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- In an algebraic case with more than one alternative, we will have +-- code like +-- +-- L0: +-- x = R1 +-- goto L1 +-- L1: +-- if (x & 7 >= 2) then goto L2 else goto L3 +-- L2: +-- Hp = Hp + 16 +-- if (Hp > HpLim) then goto L4 +-- ... +-- L4: +-- call gc() returns to L5 +-- L5: +-- x = R1 +-- goto L1 + + +-- Note [Tagging big families] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Both the big and the small constructor families are tagged, +-- that is, greater unions which overflow the tag space of TAG_BITS +-- (i.e. 3 on 32 resp. 7 constructors on 64 bit archs). +-- +-- For example, let's assume a 64-bit architecture, so that all +-- heap objects are 8-byte aligned, and hence the address of a +-- heap object ends in `000` (three zero bits). Then consider +-- > data Maybe a = Nothing | Just a +-- > data Day a = Mon | Tue | Wed | Thu | Fri | Sat | Sun +-- > data Grade = G1 | G2 | G3 | G4 | G5 | G6 | G7 | G8 | G9 | G10 +-- +-- Since `Grade` has more than 7 constructors, it counts as a +-- "big data type" (also referred to as "big constructor family" in papers). +-- On the other hand, `Maybe` and `Day` have 7 constructors or fewer, so they +-- are "small data types". +-- +-- Then +-- * A pointer to an unevaluated thunk of type `Maybe Int`, `Day` or `Grade` will end in `000` +-- * A tagged pointer to a `Nothing`, `Mon` or `G1` will end in `001` +-- * A tagged pointer to a `Just x`, `Tue` or `G2` will end in `010` +-- * A tagged pointer to `Wed` or `G3` will end in `011` +-- ... +-- * A tagged pointer to `Sat` or `G6` will end in `110` +-- * A tagged pointer to `Sun` or `G7` or `G8` or `G9` or `G10` will end in `111` +-- +-- For big families we employ a mildly clever way of combining pointer and +-- info-table tagging. We use 1..MAX_PTR_TAG-1 as pointer-resident tags where +-- the tags in the pointer and the info table are in a one-to-one +-- relation, whereas tag MAX_PTR_TAG is used as "spill over", signifying +-- we have to fall back and get the precise constructor tag from the +-- info-table. +-- +-- Consequently we now cascade switches, because we have to check +-- the pointer tag first, and when it is MAX_PTR_TAG, fetch the precise +-- tag from the info table, and switch on that. The only technically +-- tricky part is that the default case needs (logical) duplication. +-- To do this we emit an extra label for it and branch to that from +-- the second switch. This avoids duplicated codegen. See #14373. +-- See Note [Double switching for big families] for the mechanics +-- involved. +-- +-- Also see Note [Data constructor dynamic tags] +-- and the wiki https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/haskell-execution/pointer-tagging +-- + +------------------- +cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt] + -> FCode ( Maybe CmmAGraphScoped + , [(ConTagZ, CmmAGraphScoped)] ) +cgAlgAltRhss gc_plan bndr alts + = do { tagged_cmms <- cgAltRhss gc_plan bndr alts + + ; let { mb_deflt = case tagged_cmms of + ((DEFAULT,rhs) : _) -> Just rhs + _other -> Nothing + -- DEFAULT is always first, if present + + ; branches = [ (dataConTagZ con, cmm) + | (DataAlt con, cmm) <- tagged_cmms ] + } + + ; return (mb_deflt, branches) + } + + +------------------- +cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt] + -> FCode [(AltCon, CmmAGraphScoped)] +cgAltRhss gc_plan bndr alts = do + platform <- getPlatform + let + base_reg = idToReg platform bndr + cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped) + cg_alt GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=rhs} + = getCodeScoped $ + maybeAltHeapCheck gc_plan $ + do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs) + -- alt binders are always non-void, + -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise + ; _ <- cgExpr rhs + ; return con } + forkAlts (map cg_alt alts) + +maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a +maybeAltHeapCheck (NoGcInAlts,_) code = code +maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code = + altHeapCheck regs code +maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code = + altHeapCheckReturnsTo regs lret off code + +----------------------------------------------------------------------------- +-- Tail calls +----------------------------------------------------------------------------- + +cgConApp :: DataCon -> ConstructorNumber -> [StgArg] -> FCode ReturnKind +cgConApp con mn stg_args + | isUnboxedTupleDataCon con -- Unboxed tuple: assign and return + = do { arg_exprs <- getNonVoidArgAmodes stg_args + ; tickyUnboxedTupleReturn (length arg_exprs) + ; emitReturn arg_exprs } + + | otherwise -- Boxed constructors; allocate and return + = assertPpr (stg_args `lengthIs` countConRepArgs con) + (ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args) $ + do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) mn False + currentCCS con (assertNonVoidStgArgs stg_args) + -- con args are always non-void, + -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise + -- The first "con" says that the name bound to this + -- closure is "con", which is a bit of a fudge, but + -- it only affects profiling (hence the False) + + ; emit =<< fcode_init + ; tickyReturnNewCon (length stg_args) + ; emitReturn [idInfoToAmode idinfo] } + +cgIdApp :: Id -> [StgArg] -> FCode ReturnKind +cgIdApp fun_id args = do + platform <- getPlatform + fun_info <- getCgIdInfo fun_id + cfg <- getStgToCmmConfig + self_loop <- getSelfLoop + let profile = stgToCmmProfile cfg + fun_arg = StgVarArg fun_id + fun_name = idName fun_id + fun = idInfoToAmode fun_info + lf_info = cg_lf fun_info + n_args = length args + case getCallMethod cfg fun_name fun_id lf_info n_args (cg_loc fun_info) self_loop of + -- A value in WHNF, so we can just return it. + ReturnIt + | isZeroBitTy (idType fun_id) -> emitReturn [] + | otherwise -> emitReturn [fun] + + -- A value infered to be in WHNF, so we can just return it. + InferedReturnIt + | isZeroBitTy (idType fun_id) -> trace >> emitReturn [] + | otherwise -> trace >> assertTag >> + emitReturn [fun] + where + trace = do + tickyTagged + use_id <- newUnique + _lbl <- emitTickyCounterTag use_id (NonVoid fun_id) + tickyTagSkip use_id fun_id + + -- pprTraceM "WHNF:" (ppr fun_id <+> ppr args ) + assertTag = whenCheckTags $ do + mod <- getModuleName + emitTagAssertion (showPprUnsafe + (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun)) + fun + + EnterIt -> assertPpr (null args) (ppr fun_id $$ ppr args) $ -- Discarding arguments + emitEnter fun + + SlowCall -> do -- A slow function call via the RTS apply routines + { tickySlowCall lf_info args + ; emitComment $ mkFastString "slowCall" + ; slowCall fun args } + + -- A direct function call (possibly with some left-over arguments) + DirectEntry lbl arity -> do + { tickyDirectCall arity args + ; if nodeMustPointToIt profile lf_info + then directCall NativeNodeCall lbl arity (fun_arg:args) + else directCall NativeDirectCall lbl arity args } + + -- Let-no-escape call or self-recursive tail-call + JumpToIt blk_id lne_regs -> do + { adjustHpBackwards -- always do this before a tail-call + ; cmm_args <- getNonVoidArgAmodes args + ; emitMultiAssign lne_regs cmm_args + ; emit (mkBranch blk_id) + ; return AssignedDirectly } + +-- Note [Self-recursive tail calls] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Self-recursive tail calls can be optimized into a local jump in the same +-- way as let-no-escape bindings (see Note [What is a non-escaping let] in +-- "GHC.CoreToStg"). Consider this: +-- +-- foo.info: +-- a = R1 // calling convention +-- b = R2 +-- goto L1 +-- L1: ... +-- ... +-- ... +-- L2: R1 = x +-- R2 = y +-- call foo(R1,R2) +-- +-- Instead of putting x and y into registers (or other locations required by the +-- calling convention) and performing a call we can put them into local +-- variables a and b and perform jump to L1: +-- +-- foo.info: +-- a = R1 +-- b = R2 +-- goto L1 +-- L1: ... +-- ... +-- ... +-- L2: a = x +-- b = y +-- goto L1 +-- +-- This can be done only when function is calling itself in a tail position +-- and only if the call passes number of parameters equal to function's arity. +-- Note that this cannot be performed if a function calls itself with a +-- continuation. +-- +-- This in fact implements optimization known as "loopification". It was +-- described in "Low-level code optimizations in the Glasgow Haskell Compiler" +-- by Krzysztof Woś, though we use different approach. Krzysztof performed his +-- optimization at the Cmm level, whereas we perform ours during code generation +-- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is +-- generated in the first place. +-- +-- Implementation is spread across a couple of places in the code: +-- +-- * FCode monad stores additional information in its reader +-- environment (stgToCmmSelfLoop field). This `SelfLoopInfo` +-- record tells us which function can tail call itself in an +-- optimized way (it is the function currently being compiled), +-- its RepArity, what is the label of its loop header (L1 in +-- example above) and information about which local registers +-- should receive arguments when making a call (this would be a +-- and b in the example above). +-- +-- * Whenever we are compiling a function, we set that information to reflect +-- the fact that function currently being compiled can be jumped to, instead +-- of called. This is done in closureCodyBody in GHC.StgToCmm.Bind. +-- +-- * We also have to emit a label to which we will be jumping. We make sure +-- that the label is placed after a stack check but before the heap +-- check. The reason is that making a recursive tail-call does not increase +-- the stack so we only need to check once. But it may grow the heap, so we +-- have to repeat the heap check in every self-call. This is done in +-- do_checks in GHC.StgToCmm.Heap. +-- +-- * When we begin compilation of another closure we remove the additional +-- information from the environment. This is done by forkClosureBody +-- in GHC.StgToCmm.Monad. Other functions that duplicate the environment - +-- forkLneBody, forkAlts, codeOnly - duplicate that information. In other +-- words, we only need to clean the environment of the self-loop information +-- when compiling right hand side of a closure (binding). +-- +-- * When compiling a call (cgIdApp) we use getCallMethod to decide what kind +-- of call will be generated. getCallMethod decides to generate a self +-- recursive tail call when (a) environment stores information about +-- possible self tail-call; (b) that tail call is to a function currently +-- being compiled; (c) number of passed arguments is equal to +-- function's unarised arity. (d) loopification is turned on via +-- -floopification command-line option. +-- +-- * Command line option to turn loopification on and off is implemented in +-- DynFlags, then passed to StgToCmmConfig for this phase. + + +emitEnter :: CmmExpr -> FCode ReturnKind +emitEnter fun = do + { platform <- getPlatform + ; profile <- getProfile + ; adjustHpBackwards + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + ; case sequel of + -- For a return, we have the option of generating a tag-test or + -- not. If the value is tagged, we can return directly, which + -- is quicker than entering the value. This is a code + -- size/speed trade-off: when optimising for speed rather than + -- size we could generate the tag test. + -- + -- Right now, we do what the old codegen did, and omit the tag + -- test, just generating an enter. + Return -> do + { let entry = entryCode platform + $ closureInfoPtr platform align_check + $ CmmReg (nodeReg platform) + ; emit $ mkJump profile NativeNodeCall entry + [cmmUntag platform fun] updfr_off + ; return AssignedDirectly + } + + -- The result will be scrutinised in the sequel. This is where + -- we generate a tag-test to avoid entering the closure if + -- possible. + -- + -- The generated code will be something like this: + -- + -- R1 = fun -- copyout + -- if (fun & 7 != 0) goto Lret else goto Lcall + -- Lcall: + -- call [fun] returns to Lret + -- Lret: + -- fun' = R1 -- copyin + -- ... + -- + -- Note in particular that the label Lret is used as a + -- destination by both the tag-test and the call. This is + -- because Lret will necessarily be a proc-point, and we want to + -- ensure that we generate only one proc-point for this + -- sequence. + -- + -- Furthermore, we tell the caller that we generated a native + -- return continuation by returning (ReturnedTo Lret off), so + -- that the continuation can be reused by the heap-check failure + -- code in the enclosing case expression. + -- + AssignTo res_regs _ -> do + { lret <- newBlockId + ; lcall <- newBlockId + ; updfr_off <- getUpdFrameOff + ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs [] + ; let area = Young lret + ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area + [fun] updfr_off [] + -- refer to fun via nodeReg after the copyout, to avoid having + -- both live simultaneously; this sometimes enables fun to be + -- inlined in the RHS of the R1 assignment. + ; let node = CmmReg $ nodeReg platform + entry = entryCode platform (closureInfoPtr platform align_check node) + the_call = toCall entry (Just lret) updfr_off off outArgs regs + ; tscope <- getTickScope + ; emit $ + copyout <*> + mkCbranch (cmmIsTagged platform node) + lret lcall Nothing <*> + outOfLine lcall (the_call,tscope) <*> + mkLabel lret tscope <*> + copyin + ; return (ReturnedTo lret off) + } + } + +------------------------------------------------------------------------ +-- Ticks +------------------------------------------------------------------------ + +-- | Generate Cmm code for a tick. Depending on the type of Tickish, +-- this will either generate actual Cmm instrumentation code, or +-- simply pass on the annotation as a @CmmTickish@. +cgTick :: StgTickish -> FCode () +cgTick tick + = do { platform <- getPlatform + ; case tick of + ProfNote cc t p -> emitSetCCC cc t p + HpcTick m n -> emit (mkTickBox platform m n) + SourceNote s n -> emitTick $ SourceNote s n + _other -> return () -- ignore + } diff --git a/GHC/StgToCmm/ExtCode.hs b/GHC/StgToCmm/ExtCode.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/ExtCode.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TupleSections #-} +-- | Our extended FCode monad. + +-- We add a mapping from names to CmmExpr, to support local variable names in +-- the concrete C-- code. The unique supply of the underlying FCode monad +-- is used to grab a new unique for each local variable. + +-- In C--, a local variable can be declared anywhere within a proc, +-- and it scopes from the beginning of the proc to the end. Hence, we have +-- to collect declarations as we parse the proc, and feed the environment +-- back in circularly (to avoid a two-pass algorithm). + +module GHC.StgToCmm.ExtCode ( + CmmParse, unEC, + Named(..), Env, + + loopDecls, + getEnv, + + withName, + getName, + + newLocal, + newLabel, + newBlockId, + newFunctionName, + newImport, + lookupLabel, + lookupName, + + code, + emit, emitLabel, emitAssign, emitStore, + getCode, getCodeR, getCodeScoped, + emitOutOfLine, + withUpdFrameOff, getUpdFrameOff, + getProfile, getPlatform, getContext +) + +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Profile + +import qualified GHC.StgToCmm.Monad as F +import GHC.StgToCmm.Monad (FCode, newUnique) + +import GHC.Cmm +import GHC.Cmm.CLabel +import GHC.Cmm.Graph + +import GHC.Cmm.BlockId +import GHC.Data.FastString +import GHC.Unit.Module +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import qualified GHC.Types.Unique.DSM as DSM + +import Control.Monad (ap) +import GHC.Utils.Outputable (SDocContext) + +-- | The environment contains variable definitions or blockids. +data Named + = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, + -- eg, RtsLabel, ForeignLabel, CmmLabel etc. + + | FunN UnitId -- ^ A function name from this unit + | LabelN BlockId -- ^ A blockid of some code or data. + +-- | An environment of named things. +type Env = UniqFM FastString Named + +-- | Local declarations that are in scope during code generation. +type Decls = [(FastString,Named)] + +-- | Does a computation in the FCode monad, with a current environment +-- and a list of local declarations. Returns the resulting list of declarations. +newtype CmmParse a + = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) } + deriving (Functor) + +type ExtCode = CmmParse () + +returnExtFC :: a -> CmmParse a +returnExtFC a = EC $ \_ _ s -> return (s, a) + +thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b +thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s' + +instance Applicative CmmParse where + pure = returnExtFC + (<*>) = ap + +instance Monad CmmParse where + (>>=) = thenExtFC + +instance MonadUnique CmmParse where + getUniqueSupplyM = code getUniqueSupplyM + getUniqueM = EC $ \_ _ decls -> do + u <- getUniqueM + return (decls, u) + +instance DSM.MonadGetUnique CmmParse where + getUniqueM = GHC.Types.Unique.Supply.getUniqueM + +getProfile :: CmmParse Profile +getProfile = EC (\_ _ d -> (d,) <$> F.getProfile) + +getPlatform :: CmmParse Platform +getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform) + +getContext :: CmmParse SDocContext +getContext = EC (\_ _ d -> (d,) <$> F.getContext) + +-- | Takes the variable declarations and imports from the monad +-- and makes an environment, which is looped back into the computation. +-- In this way, we can have embedded declarations that scope over the whole +-- procedure, and imports that scope over the entire module. +-- Discards the local declaration contained within decl' +-- +loopDecls :: CmmParse a -> CmmParse a +loopDecls (EC fcode) = + EC $ \c e globalDecls -> do + (_, a) <- F.fixC $ \ ~(decls, _) -> + fcode c (addListToUFM e decls) globalDecls + return (globalDecls, a) + +-- | Get the current environment from the monad. +getEnv :: CmmParse Env +getEnv = EC $ \_ e s -> return (s, e) + +-- | Get the current context name from the monad +getName :: CmmParse String +getName = EC $ \c _ s -> return (s, c) + +-- | Set context name for a sub-parse +withName :: String -> CmmParse a -> CmmParse a +withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s + +addDecl :: FastString -> Named -> ExtCode +addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ()) + + +-- | Add a new variable to the list of local declarations. +-- The CmmExpr says where the value is stored. +addVarDecl :: FastString -> CmmExpr -> ExtCode +addVarDecl var expr = addDecl var (VarN expr) + +-- | Add a new label to the list of local declarations. +addLabel :: FastString -> BlockId -> ExtCode +addLabel name block_id = addDecl name (LabelN block_id) + + +-- | Create a fresh local variable of a given type. +newLocal + :: CmmType -- ^ data type + -> FastString -- ^ name of variable + -> CmmParse LocalReg -- ^ register holding the value + +newLocal ty name = do + u <- code newUnique + let reg = LocalReg u ty + addVarDecl name (CmmReg (CmmLocal reg)) + return reg + + +-- | Allocate a fresh label. +newLabel :: FastString -> CmmParse BlockId +newLabel name = do + u <- code newUnique + addLabel name (mkBlockId u) + return (mkBlockId u) + +-- | Add a local function to the environment. +newFunctionName + :: FastString -- ^ name of the function + -> UnitId -- ^ package of the current module + -> ExtCode + +newFunctionName name pkg = addDecl name (FunN pkg) + + +-- | Add an imported foreign label to the list of local declarations. +-- If this is done at the start of the module the declaration will scope +-- over the whole module. +newImport + :: (FastString, CLabel) + -> CmmParse () + +newImport (name, cmmLabel) + = addVarDecl name (CmmLit (CmmLabel cmmLabel)) + + +-- | Lookup the BlockId bound to the label with this name. +-- If one hasn't been bound yet, create a fresh one based on the +-- Unique of the name. +lookupLabel :: FastString -> CmmParse BlockId +lookupLabel name = do + env <- getEnv + return $ + case lookupUFM env name of + Just (LabelN l) -> l + _other -> mkBlockId (newTagUnique (getUnique name) 'L') + + +-- | Lookup the location of a named variable. +-- Unknown names are treated as if they had been 'import'ed from the runtime system. +-- This saves us a lot of bother in the RTS sources, at the expense of +-- deferring some errors to link time. +lookupName :: FastString -> CmmParse CmmExpr +lookupName name = do + env <- getEnv + return $ + case lookupUFM env name of + Just (VarN e) -> e + Just (FunN uid) -> CmmLit (CmmLabel (mkCmmCodeLabel uid name)) + _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name)) + + +-- | Lift an FCode computation into the CmmParse monad +code :: FCode a -> CmmParse a +code fc = EC $ \_ _ s -> do + r <- fc + return (s, r) + +emit :: CmmAGraph -> CmmParse () +emit = code . F.emit + +emitLabel :: BlockId -> CmmParse () +emitLabel = code . F.emitLabel + +emitAssign :: CmmReg -> CmmExpr -> CmmParse () +emitAssign l r = code (F.emitAssign l r) + +emitStore :: Maybe MemoryOrdering -> CmmExpr -> CmmExpr -> CmmParse () +emitStore (Just mem_ord) l r = do + platform <- getPlatform + let w = typeWidth $ cmmExprType platform r + emit $ mkUnsafeCall (PrimTarget $ MO_AtomicWrite w mem_ord) [] [l,r] +emitStore Nothing l r = code (F.emitStore l r) + +getCode :: CmmParse a -> CmmParse CmmAGraph +getCode (EC ec) = EC $ \c e s -> do + ((s',_), gr) <- F.getCodeR (ec c e s) + return (s', gr) + +getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph) +getCodeR (EC ec) = EC $ \c e s -> do + ((s', r), gr) <- F.getCodeR (ec c e s) + return (s', (r,gr)) + +getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped) +getCodeScoped (EC ec) = EC $ \c e s -> do + ((s', r), gr) <- F.getCodeScoped (ec c e s) + return (s', (r,gr)) + +emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse () +emitOutOfLine l g = code (F.emitOutOfLine l g) + +withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse () +withUpdFrameOff size inner + = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s + +getUpdFrameOff :: CmmParse UpdFrameOffset +getUpdFrameOff = code $ F.getUpdFrameOff diff --git a/GHC/StgToCmm/Foreign.hs b/GHC/StgToCmm/Foreign.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Foreign.hs @@ -0,0 +1,791 @@ +----------------------------------------------------------------------------- +-- +-- Code generation for foreign calls. +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Foreign ( + cgForeignCall, + emitPrimCall, + emitCCall, + emitCCallNeverReturns, + emitForeignCall, + emitSaveThreadState, + saveThreadState, + emitLoadThreadState, + emitSaveRegs, + emitRestoreRegs, + emitPushArgRegs, + emitPopArgRegs, + loadThreadState, + emitOpenNursery, + emitCloseNursery, + ) where + +import GHC.Prelude hiding( succ, (<*>) ) + +import GHC.Platform +import GHC.Platform.Profile + +import GHC.Stg.Syntax +import GHC.StgToCmm.Prof (storeCurCCS, ccsType) +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Closure +import GHC.StgToCmm.Layout + +import GHC.Cmm.BlockId (newBlockId) +import GHC.Cmm +import GHC.Cmm.Reg ( GlobalArgRegs(..) ) +import GHC.Cmm.Utils +import GHC.Cmm.Graph +import GHC.Cmm.CallConv +import GHC.Core.Type +import GHC.Types.RepType +import GHC.Cmm.CLabel +import GHC.Runtime.Heap.Layout +import GHC.Types.ForeignCall +import GHC.Data.Maybe +import GHC.Utils.Panic +import GHC.Types.Basic +import GHC.Types.Unique.DSM +import GHC.Unit.Types + +import GHC.Core.TyCo.Rep +import GHC.Builtin.Types.Prim +import GHC.Utils.Misc (zipEqual) + +import Control.Monad + +----------------------------------------------------------------------------- +-- Code generation for Foreign Calls +----------------------------------------------------------------------------- + +-- | Emit code for a foreign call, and return the results to the sequel. +-- Precondition: the length of the arguments list is the same as the +-- arity of the foreign function. +cgForeignCall :: ForeignCall -- the op + -> Type -- type of foreign function + -> [StgArg] -- x,y arguments + -> Type -- result type + -> FCode ReturnKind + +cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty + = do { cmm_args <- getFCallArgs stg_args typ + -- ; traceM $ show cmm_args + ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty + ; let ((call_args, arg_hints), cmm_target) + = case target of + StaticTarget _ _ _ False -> + panic "cgForeignCall: unexpected FFI value import" + StaticTarget _ lbl mPkgId True + -> let labelSource + = case mPkgId of + Nothing -> ForeignLabelInThisPackage + Just pkgId -> ForeignLabelInPackage (toUnitId pkgId) + in ( unzip cmm_args + , CmmLit (CmmLabel + (mkForeignLabel lbl labelSource IsFunction))) + + DynamicTarget -> case cmm_args of + (fn,_):rest -> (unzip rest, fn) + [] -> panic "cgForeignCall []" + fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn + call_target = ForeignTarget cmm_target fc + + -- we want to emit code for the call, and then emitReturn. + -- However, if the sequel is AssignTo, we shortcut a little + -- and generate a foreign call that assigns the results + -- directly. Otherwise we end up generating a bunch of + -- useless "r = r" assignments, which are not merely annoying: + -- they prevent the common block elimination from working correctly + -- in the case of a safe foreign call. + -- See Note [safe foreign call convention] + -- + ; sequel <- getSequel + ; case sequel of + AssignTo assign_to_these _ -> + emitForeignCall safety assign_to_these call_target call_args + + _something_else -> + do { _ <- emitForeignCall safety res_regs call_target call_args + ; emitReturn (map (CmmReg . CmmLocal) res_regs) + } + } + +{- Note [safe foreign call convention] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simple thing to do for a safe foreign call would be the same as an +unsafe one: just + + emitForeignCall ... + emitReturn ... + +but consider what happens in this case + + case foo x y z of + (# s, r #) -> ... + +The sequel is AssignTo [r]. The call to newUnboxedTupleRegs picks [r] +as the result reg, and we generate + + r = foo(x,y,z) returns to L1 -- emitForeignCall + L1: + r = r -- emitReturn + goto L2 +L2: + ... + +Now L1 is a proc point (by definition, it is the continuation of the +safe foreign call). If L2 does a heap check, then L2 will also be a +proc point. + +Furthermore, the stack layout algorithm has to arrange to save r +somewhere between the call and the jump to L1, which is annoying: we +would have to treat r differently from the other live variables, which +have to be saved *before* the call. + +So we adopt a special convention for safe foreign calls: the results +are copied out according to the NativeReturn convention by the call, +and the continuation of the call should copyIn the results. (The +copyOut code is actually inserted when the safe foreign call is +lowered later). The result regs attached to the safe foreign call are +only used temporarily to hold the results before they are copied out. + +We will now generate this: + + r = foo(x,y,z) returns to L1 + L1: + r = R1 -- copyIn, inserted by mkSafeCall + goto L2 + L2: + ... r ... + +And when the safe foreign call is lowered later (see Note [Lower safe +foreign calls]) we get this: + + suspendThread() + r = foo(x,y,z) + resumeThread() + R1 = r -- copyOut, inserted by lowerSafeForeignCall + jump L1 + L1: + r = R1 -- copyIn, inserted by mkSafeCall + goto L2 + L2: + ... r ... + +Now consider what happens if L2 does a heap check: the Adams +optimisation kicks in and commons up L1 with the heap-check +continuation, resulting in just one proc point instead of two. Yay! +-} + + +emitCCall' :: CmmReturnInfo + -> [(CmmFormal,ForeignHint)] + -> CmmExpr + -> [(CmmActual,ForeignHint)] + -> FCode () +emitCCall' ret_info hinted_results fn hinted_args + = void $ emitForeignCall PlayRisky results target args + where + (args, arg_hints) = unzip hinted_args + (results, result_hints) = unzip hinted_results + target = ForeignTarget fn fc + fc = ForeignConvention CCallConv arg_hints result_hints ret_info + +emitCCall :: [(CmmFormal,ForeignHint)] + -> CmmExpr + -> [(CmmActual,ForeignHint)] + -> FCode () +emitCCall = emitCCall' CmmMayReturn + +emitCCallNeverReturns + :: [(CmmFormal,ForeignHint)] + -> CmmExpr + -> [(CmmActual,ForeignHint)] + -> FCode () +emitCCallNeverReturns = emitCCall' CmmNeverReturns + + +emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () +emitPrimCall res op args + = void $ emitForeignCall PlayRisky res (PrimTarget op) args + +-- alternative entry point, used by GHC.Cmm.Parser +emitForeignCall + :: Safety + -> [CmmFormal] -- where to put the results + -> ForeignTarget -- the op + -> [CmmActual] -- arguments + -> FCode ReturnKind +emitForeignCall safety results target args + | not (playSafe safety) = do + platform <- getPlatform + let (caller_save, caller_load) = callerSaveVolatileRegs platform + emit caller_save + target' <- load_target_into_temp target + args' <- mapM maybe_assign_temp args + emit $ mkUnsafeCall target' results args' + emit caller_load + return AssignedDirectly + + | otherwise = do + profile <- getProfile + platform <- getPlatform + updfr_off <- getUpdFrameOff + target' <- load_target_into_temp target + args' <- mapM maybe_assign_temp args + k <- newBlockId + let (off, _, copyout) = copyInOflow profile NativeReturn (Young k) results [] + -- see Note [safe foreign call convention] + tscope <- getTickScope + emit $ + ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth platform))) + (CmmLit (CmmBlock k)) + <*> mkLast (CmmForeignCall { tgt = target' + , res = results + , args = args' + , succ = k + , ret_args = off + , ret_off = updfr_off + , intrbl = playInterruptible safety }) + <*> mkLabel k tscope + <*> copyout + ) + return (ReturnedTo k off) + +load_target_into_temp :: ForeignTarget -> FCode ForeignTarget +load_target_into_temp (ForeignTarget expr conv) = do + tmp <- maybe_assign_temp expr + return (ForeignTarget tmp conv) +load_target_into_temp other_target@(PrimTarget _) = + return other_target + +-- Note [Saving foreign call target to local] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- What we want to do here is create a new temporary for the foreign +-- call argument if it is not safe to use the expression directly, +-- because the expression mentions caller-saves GlobalRegs (see +-- Note [Register parameter passing]). +-- +-- However, we can't pattern-match on the expression here, because +-- this is used in a loop by GHC.Cmm.Parser, and testing the +-- expression results in a black hole. So when there exist +-- caller-saves GlobalRegs, we create a temporary, and rely on +-- GHC.Cmm.Sink to clean it up later. The generated code ends up being +-- the same if -fcmm-sink is enabled (implied by -O). +-- +-- When there doesn't exist caller-save GlobalRegs, keep the original +-- target in place. This matters for the wasm backend, otherwise it +-- cannot infer the target symbol's correct foreign function type in +-- unoptimized Cmm. For instance: +-- +-- foreign import ccall unsafe "foo" c_foo :: IO () +-- +-- Without optimization, previously this would lower to something like: +-- +-- [Test.c_foo_entry() { // [] +-- { [] +-- } +-- {offset +-- cDk: +-- goto cDm; +-- cDm: +-- _cDj::I32 = foo; +-- call "ccall" arg hints: [] result hints: [] (_cDj::I32)(); +-- R1 = GHC.Tuple.()_closure+1; +-- call (I32[P32[Sp]])(R1) args: 4, res: 0, upd: 4; +-- } +-- }, +-- +-- The wasm backend only sees "foo" being assigned to a local, but +-- there's no type signature associated with a CLabel! So it has to +-- emit a dummy .functype directive and fingers crossed that wasm-ld +-- tolerates function type mismatch. THis is horrible, not future +-- proof against upstream toolchain upgrades, and already known to +-- break in certain cases (e.g. when LTO objects are involved). +-- +-- Therefore, on wasm as well as other targets that don't risk +-- mentioning caller-saved GlobalRegs in a foreign call target, just +-- keep the original call target in place and don't assign it to a +-- local. So this would now lower to something like: +-- +-- [Test.c_foo_entry() { // [] +-- { [] +-- } +-- {offset +-- cDo: +-- goto cDq; +-- cDq: +-- call "ccall" arg hints: [] result hints: [] foo(); +-- R1 = GHC.Tuple.()_closure+1; +-- call (I32[P32[Sp]])(R1) args: 4, res: 0, upd: 4; +-- } +-- }, +-- +-- Since "foo" appears at call site directly, the wasm backend would +-- now be able to infer its type signature correctly. + +maybe_assign_temp :: CmmExpr -> FCode CmmExpr +maybe_assign_temp e = do + do_save <- stgToCmmSaveFCallTargetToLocal <$> getStgToCmmConfig + if do_save + then do + platform <- getPlatform + reg <- newTemp (cmmExprType platform e) + emitAssign (CmmLocal reg) e + return (CmmReg (CmmLocal reg)) + else + pure e + +-- ----------------------------------------------------------------------------- +-- Save/restore the thread state in the TSO + +-- This stuff can't be done in suspendThread/resumeThread, because it +-- refers to global registers which aren't available in the C world. + +emitSaveThreadState :: FCode () +emitSaveThreadState = do + profile <- getProfile + code <- saveThreadState profile + emit code + +-- | Produce code to save the current thread state to @CurrentTSO@ +saveThreadState :: MonadGetUnique m => Profile -> m CmmAGraph +saveThreadState profile = do + let platform = profilePlatform profile + tso <- newTemp (gcWord platform) + close_nursery <- closeNursery profile tso + pure $ catAGraphs + [ -- tso = CurrentTSO; + mkAssign (CmmLocal tso) (currentTSOExpr platform) + + , -- tso->stackobj->sp = Sp; + mkStore (cmmOffset platform + (cmmLoadBWord platform (cmmOffset platform + (CmmReg (CmmLocal tso)) + (tso_stackobj profile))) + (stack_SP profile)) + (spExpr platform) + + , close_nursery + + , -- and save the current cost centre stack in the TSO when profiling: + if profileIsProfiling profile + then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)) + (cccsExpr platform) + else mkNop + ] + + + +-- | Save STG registers +-- +-- STG registers must be saved around a C call, just in case the STG +-- register is mapped to a caller-saves machine register. Normally we +-- don't need to worry about this the code generator has already +-- loaded any live STG registers into variables for us, but in +-- hand-written low-level Cmm code where we don't know which registers +-- are live, we might have to save them all. +emitSaveRegs :: GlobalArgRegs -> FCode () +emitSaveRegs argRegs = do + platform <- getPlatform + let regs = realArgRegsCover platform argRegs + save = catAGraphs (map (callerSaveGlobalReg platform) regs) + emit save + +-- | Restore STG registers (see 'emitSaveRegs') +emitRestoreRegs :: GlobalArgRegs -> FCode () +emitRestoreRegs argRegs = do + platform <- getPlatform + let regs = realArgRegsCover platform argRegs + restore = catAGraphs (map (callerRestoreGlobalReg platform) regs) + emit restore + +-- | Push a subset of STG registers onto the stack, specified by the bitmap +-- +-- Sometimes, a "live" subset of the STG registers needs to be saved on the +-- stack, for example when storing an unboxed tuple to be used in the GHCi +-- bytecode interpreter. +-- +-- The "live registers" bitmap corresponds to the list of registers given by +-- 'allArgRegsCover', with the least significant bit indicating liveness of +-- the first register in the list. +-- +-- Each register is saved to a stack slot of one or more machine words, even +-- if the register size itself is smaller. +-- +-- The resulting Cmm code looks like this, with a line for each real or +-- virtual register used for returning tuples: +-- +-- ... +-- if((mask & 2) != 0) { Sp_adj(-1); Sp(0) = R2; } +-- if((mask & 1) != 0) { Sp_adj(-1); Sp(0) = R1; } +-- +-- See Note [GHCi and native call registers] + +emitPushArgRegs :: GlobalArgRegs -> CmmExpr -> FCode () +emitPushArgRegs argRegs regs_live = do + platform <- getPlatform + let regs = zip (allArgRegsCover platform argRegs) [0..] + save_arg (reg, n) = + let reg_ty = globalRegSpillType platform reg + mask = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform)) + live = cmmAndWord platform regs_live mask + cond = cmmNeWord platform live (zeroExpr platform) + width = roundUpToWords platform + (widthInBytes $ typeWidth reg_ty) + adj_sp = mkAssign (spReg platform) + (cmmOffset platform (spExpr platform) (negate width)) + save_reg = mkStore (spExpr platform) (CmmReg $ CmmGlobal $ GlobalRegUse reg reg_ty) + in mkCmmIfThen cond $ catAGraphs [adj_sp, save_reg] + emit . catAGraphs =<< mapM save_arg (reverse $ regs) + +-- | Pop a subset of STG registers from the stack (see 'emitPushArgRegs') +emitPopArgRegs :: GlobalArgRegs ->CmmExpr -> FCode () +emitPopArgRegs argRegs regs_live = do + platform <- getPlatform + let regs = zip (allArgRegsCover platform argRegs) [0..] + save_arg (reg, n) = + let reg_ty = globalRegSpillType platform reg + mask = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform)) + live = cmmAndWord platform regs_live mask + cond = cmmNeWord platform live (zeroExpr platform) + width = roundUpToWords platform + (widthInBytes $ typeWidth reg_ty) + adj_sp = mkAssign (spReg platform) + (cmmOffset platform (spExpr platform) width) + restore_reg = mkAssign (CmmGlobal (GlobalRegUse reg reg_ty)) + (CmmLoad (spExpr platform) reg_ty NaturallyAligned) + in mkCmmIfThen cond $ catAGraphs [restore_reg, adj_sp] + emit . catAGraphs =<< mapM save_arg regs + + +emitCloseNursery :: FCode () +emitCloseNursery = do + profile <- getProfile + let platform = profilePlatform profile + tso <- newTemp (bWord platform) + code <- closeNursery profile tso + emit $ mkAssign (CmmLocal tso) (currentTSOExpr platform) <*> code + +{- | +@closeNursery dflags tso@ produces code to close the nursery. +A local register holding the value of @CurrentTSO@ is expected for +efficiency. + +Closing the nursery corresponds to the following code: + +@ + tso = CurrentTSO; + cn = CurrentNuresry; + + // Update the allocation limit for the current thread. We don't + // check to see whether it has overflowed at this point, that check is + // made when we run out of space in the current heap block (stg_gc_noregs) + // and in the scheduler when context switching (schedulePostRunThread). + tso->alloc_limit -= Hp + WDS(1) - cn->start; + + // Set cn->free to the next unoccupied word in the block + cn->free = Hp + WDS(1); +@ +-} +closeNursery :: MonadGetUnique m => Profile -> LocalReg -> m CmmAGraph +closeNursery profile tso = do + let tsoreg = CmmLocal tso + platform = profilePlatform profile + cnreg <- CmmLocal <$> newTemp (bWord platform) + pure $ catAGraphs [ + mkAssign cnreg (currentNurseryExpr platform), + + -- CurrentNursery->free = Hp+1; + mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform (hpExpr platform) 1), + + let alloc = + CmmMachOp (mo_wordSub platform) + [ cmmOffsetW platform (hpExpr platform) 1 + , cmmLoadBWord platform (nursery_bdescr_start platform cnreg) + ] + + alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile) + in + + -- tso->alloc_limit += alloc + mkStore alloc_limit (CmmMachOp (MO_Sub W64) + [ CmmLoad alloc_limit b64 NaturallyAligned + , CmmMachOp (mo_WordTo64 platform) [alloc] ]) + ] + +emitLoadThreadState :: FCode () +emitLoadThreadState = do + profile <- getProfile + code <- loadThreadState profile + emit code + +-- | Produce code to load the current thread state from @CurrentTSO@ +loadThreadState :: MonadGetUnique m => Profile -> m CmmAGraph +loadThreadState profile = do + let platform = profilePlatform profile + tso <- newTemp (gcWord platform) + stack <- newTemp (gcWord platform) + open_nursery <- openNursery profile tso + pure $ catAGraphs [ + -- tso = CurrentTSO; + mkAssign (CmmLocal tso) (currentTSOExpr platform), + -- stack = tso->stackobj; + mkAssign (CmmLocal stack) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile))), + -- Sp = stack->sp; + mkAssign (spReg platform) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile))), + -- SpLim = stack->stack + RESERVED_STACK_WORDS; + mkAssign (spLimReg platform) (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile)) + (pc_RESERVED_STACK_WORDS (platformConstants platform))), + -- HpAlloc = 0; + -- HpAlloc is assumed to be set to non-zero only by a failed + -- a heap check, see HeapStackCheck.cmm:GC_GENERIC + mkAssign (hpAllocReg platform) (zeroExpr platform), + open_nursery, + -- and load the current cost centre stack from the TSO when profiling: + if profileIsProfiling profile + then let ccs_ptr = cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile) + in storeCurCCS platform (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned) + else mkNop + ] + + +emitOpenNursery :: FCode () +emitOpenNursery = do + profile <- getProfile + let platform = profilePlatform profile + tso <- newTemp (bWord platform) + code <- openNursery profile tso + emit $ mkAssign (CmmLocal tso) (currentTSOExpr platform) <*> code + +{- | +@openNursery profile tso@ produces code to open the nursery. A local register +holding the value of @CurrentTSO@ is expected for efficiency. + +Opening the nursery corresponds to the following code: + +@ + tso = CurrentTSO; + cn = CurrentNursery; + bdfree = CurrentNursery->free; + bdstart = CurrentNursery->start; + + // We *add* the currently occupied portion of the nursery block to + // the allocation limit, because we will subtract it again in + // closeNursery. + tso->alloc_limit += bdfree - bdstart; + + // Set Hp to the last occupied word of the heap block. Why not the + // next unoccupied word? Doing it this way means that we get to use + // an offset of zero more often, which might lead to slightly smaller + // code on some architectures. + Hp = bdfree - WDS(1); + + // Set HpLim to the end of the current nursery block (note that this block + // might be a block group, consisting of several adjacent blocks. + HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1; +@ +-} +openNursery :: MonadGetUnique m => Profile -> LocalReg -> m CmmAGraph +openNursery profile tso = do + let tsoreg = CmmLocal tso + platform = profilePlatform profile + cnreg <- CmmLocal <$> newTemp (bWord platform) + bdfreereg <- CmmLocal <$> newTemp (bWord platform) + bdstartreg <- CmmLocal <$> newTemp (bWord platform) + + -- These assignments are carefully ordered to reduce register + -- pressure and generate not completely awful code on x86. To see + -- what code we generate, look at the assembly for + -- stg_returnToStackTop in rts/StgStartup.cmm. + pure $ catAGraphs [ + mkAssign cnreg (currentNurseryExpr platform), + mkAssign bdfreereg (cmmLoadBWord platform (nursery_bdescr_free platform cnreg)), + + -- Hp = CurrentNursery->free - 1; + mkAssign (hpReg platform) (cmmOffsetW platform (CmmReg bdfreereg) (-1)), + + mkAssign bdstartreg (cmmLoadBWord platform (nursery_bdescr_start platform cnreg)), + + -- HpLim = CurrentNursery->start + + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; + mkAssign (hpLimReg platform) + (cmmOffsetExpr platform + (CmmReg bdstartreg) + (cmmOffset platform + (CmmMachOp (mo_wordMul platform) + [ CmmMachOp (MO_SS_Conv W32 (wordWidth platform)) + [CmmLoad (nursery_bdescr_blocks platform cnreg) b32 NaturallyAligned] + , mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform)) + ]) + (-1) + ) + ), + + -- alloc = bd->free - bd->start + let alloc = + CmmMachOp (mo_wordSub platform) [CmmReg bdfreereg, CmmReg bdstartreg] + + alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile) + in + + -- tso->alloc_limit += alloc + mkStore alloc_limit (CmmMachOp (MO_Add W64) + [ CmmLoad alloc_limit b64 NaturallyAligned + , CmmMachOp (mo_WordTo64 platform) [alloc] ]) + + ] + +nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks + :: Platform -> CmmReg -> CmmExpr +nursery_bdescr_free platform cn = + cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_free (platformConstants platform)) +nursery_bdescr_start platform cn = + cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_start (platformConstants platform)) +nursery_bdescr_blocks platform cn = + cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_blocks (platformConstants platform)) + +tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: Profile -> ByteOff +tso_stackobj profile = closureField profile (pc_OFFSET_StgTSO_stackobj (profileConstants profile)) +tso_alloc_limit profile = closureField profile (pc_OFFSET_StgTSO_alloc_limit (profileConstants profile)) +tso_CCCS profile = closureField profile (pc_OFFSET_StgTSO_cccs (profileConstants profile)) +stack_STACK profile = closureField profile (pc_OFFSET_StgStack_stack (profileConstants profile)) +stack_SP profile = closureField profile (pc_OFFSET_StgStack_sp (profileConstants profile)) + + +closureField :: Profile -> ByteOff -> ByteOff +closureField profile off = off + fixedHdrSize profile + +-- Note [Unlifted boxed arguments to foreign calls] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- For certain types passed to foreign calls, we adjust the actual +-- value passed to the call. For ByteArray#, Array# and SmallArray#, +-- we pass the address of the array's payload, not the address of +-- the heap object. For example, consider: +-- foreign import "c_foo" foo :: ByteArray# -> Int# -> IO () +-- At a Haskell call like `foo x y`, we'll generate a C call that +-- is more like +-- c_foo( x+8, y ) +-- where the "+8" takes the heap pointer (x :: ByteArray#) and moves +-- it past the header words of the ByteArray object to point directly +-- to the data inside the ByteArray#. (The exact offset depends +-- on the target architecture and on profiling) By contrast, (y :: Int#) +-- requires no such adjustment. +-- +-- This adjustment is performed by 'add_shim'. The size of the +-- adjustment depends on the type of heap object. But +-- how can we determine that type? There are two available options. +-- We could use the types of the actual values that the foreign call +-- has been applied to, or we could use the types present in the +-- foreign function's type. Prior to GHC 8.10, we used the former +-- strategy since it's a little more simple. However, in issue #16650 +-- and more compellingly in the comments of +-- https://gitlab.haskell.org/ghc/ghc/merge_requests/939, it was +-- demonstrated that this leads to bad behavior in the presence +-- of unsafeCoerce#. Returning to the above example, suppose the +-- Haskell call looked like +-- foo (unsafeCoerce# p) +-- where the types of expressions comprising the arguments are +-- p :: (Any :: TYPE 'UnliftedRep) +-- i :: Int# +-- so that the unsafe-coerce is between Any and ByteArray#. +-- These two types have the same kind (they are both represented by +-- a heap pointer) so no GC errors will occur if we do this unsafe coerce. +-- By the time this gets to the code generator the cast has been +-- discarded so we have +-- foo p y +-- But we *must* adjust the pointer to p by a ByteArray# shim, +-- *not* by an Any shim (the Any shim involves no offset at all). +-- +-- To avoid this bad behavior, we adopt the second strategy: use +-- the types present in the foreign function's type. +-- In collectStgFArgTypes, we convert the foreign function's +-- type to a list of StgFArgType. Then, in add_shim, we interpret +-- these as numeric offsets. + +getFCallArgs :: + [StgArg] + -> Type -- the type of the foreign function + -> FCode [(CmmExpr, ForeignHint)] +-- (a) Drop void args +-- (b) Add foreign-call shim code +-- It's (b) that makes this differ from getNonVoidArgAmodes +-- Precondition: args and typs have the same length +-- See Note [Unlifted boxed arguments to foreign calls] +getFCallArgs args typ + = do { mb_cmms <- mapM get (zipEqual args (collectStgFArgTypes typ)) + ; return (catMaybes mb_cmms) } + where + get (arg,typ) + | null arg_reps + = return Nothing + | otherwise + = do { cmm <- getArgAmode (NonVoid arg) + ; profile <- getProfile + ; return (Just (add_shim profile typ cmm, hint)) } + where + arg_ty = stgArgType arg + arg_reps = typePrimRep arg_ty + hint = typeForeignHint arg_ty + +-- The minimum amount of information needed to determine +-- the offset to apply to an argument to a foreign call. +-- See Note [Unlifted boxed arguments to foreign calls] +data StgFArgType + = StgPlainType + | StgArrayType + | StgSmallArrayType + | StgByteArrayType + +-- See Note [Unlifted boxed arguments to foreign calls] +add_shim :: Profile -> StgFArgType -> CmmExpr -> CmmExpr +add_shim profile ty expr = case ty of + StgPlainType -> expr + StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize profile) + StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize profile) + StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize profile) + where + platform = profilePlatform profile + +-- From a function, extract information needed to determine +-- the offset of each argument when used as a C FFI argument. +-- See Note [Unlifted boxed arguments to foreign calls] +collectStgFArgTypes :: Type -> [StgFArgType] +collectStgFArgTypes = go [] + where + -- Skip foralls + go bs (ForAllTy _ res) = go bs res + go bs (AppTy{}) = reverse bs + go bs (TyConApp{}) = reverse bs + go bs (LitTy{}) = reverse bs + go bs (TyVarTy{}) = reverse bs + go _ (CastTy{}) = panic "myCollectTypeArgs: CastTy" + go _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy" + go bs (FunTy {ft_arg = arg, ft_res=res}) = + go (typeToStgFArgType arg:bs) res + +-- Choose the offset based on the type. For anything other +-- than an unlifted boxed type, there is no offset. +-- See Note [Unlifted boxed arguments to foreign calls] +typeToStgFArgType :: Type -> StgFArgType +typeToStgFArgType typ + | tycon == arrayPrimTyCon = StgArrayType + | tycon == mutableArrayPrimTyCon = StgArrayType + | tycon == smallArrayPrimTyCon = StgSmallArrayType + | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType + | tycon == byteArrayPrimTyCon = StgByteArrayType + | tycon == mutableByteArrayPrimTyCon = StgByteArrayType + | otherwise = StgPlainType + where + -- Should be a tycon app, since this is a foreign call. We look + -- through newtypes so the offset does not change if a user replaces + -- a type in a foreign function signature with a representationally + -- equivalent newtype. + tycon = tyConAppTyCon (unwrapType typ) diff --git a/GHC/StgToCmm/Foreign.hs-boot b/GHC/StgToCmm/Foreign.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Foreign.hs-boot @@ -0,0 +1,6 @@ +module GHC.StgToCmm.Foreign where + +import GHC.Cmm +import GHC.StgToCmm.Monad + +emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () diff --git a/GHC/StgToCmm/Heap.hs b/GHC/StgToCmm/Heap.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Heap.hs @@ -0,0 +1,689 @@ +----------------------------------------------------------------------------- +-- +-- Stg to C--: heap management functions +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Heap ( + getVirtHp, setVirtHp, setRealHp, + getHpRelOffset, + + entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo, + heapStackCheckGen, + entryHeapCheck', + + mkStaticClosureFields, mkStaticClosure, + + allocDynClosure, allocDynClosureCmm, allocHeapClosure, + emitSetDynHdr + ) where + +import GHC.Prelude hiding ((<*>)) + +import GHC.Stg.Syntax +import GHC.Cmm.CLabel +import GHC.StgToCmm.Layout +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Prof (profDynAlloc, dynProfHdr, staticProfHdr) +import GHC.StgToCmm.Ticky +import GHC.StgToCmm.Closure + +import GHC.Cmm.Graph + +import GHC.Cmm.Dataflow.Label +import GHC.Runtime.Heap.Layout +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Types.CostCentre +import GHC.Types.Id.Info( CafInfo(..), mayHaveCafRefs ) +import GHC.Types.Id ( Id ) +import GHC.Unit +import GHC.Platform +import GHC.Platform.Profile +import GHC.Data.FastString( mkFastString, fsLit ) +import GHC.Utils.Panic( sorry ) + +import Control.Monad (when) +import Data.Maybe (isJust) + +----------------------------------------------------------- +-- Initialise dynamic heap objects +----------------------------------------------------------- + +allocDynClosure + :: Maybe Id + -> CmmInfoTable + -> LambdaFormInfo + -> CmmExpr -- Cost Centre to stick in the object + -> CmmExpr -- Cost Centre to blame for this alloc + -- (usually the same; sometimes "OVERHEAD") + + -> [(NonVoid StgArg, VirtualHpOffset)] -- Offsets from start of object + -- ie Info ptr has offset zero. + -- No void args in here + -> FCode CmmExpr -- returns Hp+n + +allocDynClosureCmm + :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr + -> [(CmmExpr, ByteOff)] + -> FCode CmmExpr -- returns Hp+n + +-- allocDynClosure allocates the thing in the heap, +-- and modifies the virtual Hp to account for this. +-- The second return value is the graph that sets the value of the +-- returned LocalReg, which should point to the closure after executing +-- the graph. + +-- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is +-- only valid until Hp is changed. The caller should assign the +-- result to a LocalReg if it is required to remain live. +-- +-- The reason we don't assign it to a LocalReg here is that the caller +-- is often about to call regIdInfo, which immediately assigns the +-- result of allocDynClosure to a new temp in order to add the tag. +-- So by not generating a LocalReg here we avoid a common source of +-- new temporaries and save some compile time. This can be quite +-- significant - see test T4801. + + +allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do + let (args, offsets) = unzip args_w_offsets + cmm_args <- mapM getArgAmode args -- No void args + allocDynClosureCmm mb_id info_tbl lf_info + use_cc _blame_cc (zip cmm_args offsets) + + +allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do + -- SAY WHAT WE ARE ABOUT TO DO + let rep = cit_rep info_tbl + tickyDynAlloc mb_id rep lf_info + let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl)) + allocHeapClosure rep info_ptr use_cc amodes_w_offsets + + +-- | Low-level heap object allocation. +allocHeapClosure + :: SMRep -- ^ representation of the object + -> CmmExpr -- ^ info pointer + -> CmmExpr -- ^ cost centre + -> [(CmmExpr,ByteOff)] -- ^ payload + -> FCode CmmExpr -- ^ returns the address of the object +allocHeapClosure rep info_ptr use_cc payload = do + profDynAlloc rep use_cc + + virt_hp <- getVirtHp + + -- Find the offset of the info-ptr word + let info_offset = virt_hp + 1 + -- info_offset is the VirtualHpOffset of the first + -- word of the new object + -- Remember, virtHp points to last allocated word, + -- ie 1 *before* the info-ptr word of new object. + + base <- getHpRelOffset info_offset + emitComment $ mkFastString "allocHeapClosure" + emitSetDynHdr base info_ptr use_cc + + -- Fill in the fields + hpStore base payload + + -- Bump the virtual heap pointer + profile <- getProfile + setVirtHp (virt_hp + heapClosureSizeW profile rep) + + return base + + +emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitSetDynHdr base info_ptr ccs + = do profile <- getProfile + hpStore base (zip (header profile) [0, profileWordSizeInBytes profile ..]) + where + header :: Profile -> [CmmExpr] + header profile = [info_ptr] ++ dynProfHdr profile ccs + -- ToDo: Parallel stuff + -- No ticky header + +-- Store the item (expr,off) in base[off] +hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode () +hpStore base vals = do + platform <- getPlatform + sequence_ $ + [ emitStore (cmmOffsetB platform base off) val | (val,off) <- vals ] + +----------------------------------------------------------- +-- Layout of static closures +----------------------------------------------------------- + +-- | Make a static closure, adding on any extra padding needed for CAFs, and +-- adding a static link field if necessary. +mkStaticClosureFields + :: Profile + -> CmmInfoTable + -> CostCentreStack + -> CafInfo + -> [CmmLit] -- ^ Payload + -> [CmmLit] -- ^ Extra non-pointers that go to the end of the closure. + -- See Note [unpack_cstring closures] in StgStdThunks.cmm. + -> [CmmLit] -- The full closure +mkStaticClosureFields profile info_tbl ccs caf_refs payload extras + = mkStaticClosure profile info_lbl ccs payload padding + static_link_field saved_info_field extras + where + platform = profilePlatform profile + info_lbl = cit_lbl info_tbl + + -- CAFs must have consistent layout, regardless of whether they + -- are actually updatable or not. The layout of a CAF is: + -- + -- 3 saved_info + -- 2 static_link + -- 1 indirectee + -- 0 info ptr + -- + -- the static_link and saved_info fields must always be in the + -- same place. So we use isThunkRep rather than closureUpdReqd + -- here: + + is_caf = isThunkRep (cit_rep info_tbl) + + padding + | is_caf && null payload = [mkIntCLit platform 0] + | otherwise = [] + + static_link_field + | is_caf + = [mkIntCLit platform 0] + | staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl + = [static_link_value] + | otherwise + = [] + + saved_info_field + | is_caf = [mkIntCLit platform 0] + | otherwise = [] + + -- For a static constructor which has NoCafRefs, we set the + -- static link field to a non-zero value so the garbage + -- collector will ignore it. + static_link_value + | mayHaveCafRefs caf_refs = mkIntCLit platform 0 + | otherwise = mkIntCLit platform 3 -- No CAF refs + -- See Note [STATIC_LINK fields] + -- in rts/sm/Storage.h + +mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit] + -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] +mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field extras + = [CmmLabel info_lbl] + ++ staticProfHdr profile ccs + ++ payload + ++ padding + ++ static_link_field + ++ saved_info_field + ++ extras + +----------------------------------------------------------- +-- Heap overflow checking +----------------------------------------------------------- + +{- Note [Heap checks] + ~~~~~~~~~~~~~~~~~~ +Heap checks come in various forms. We provide the following entry +points to the runtime system, all of which use the native C-- entry +convention. + + * gc() performs garbage collection and returns + nothing to its caller + + * A series of canned entry points like + r = gc_1p( r ) + where r is a pointer. This performs gc, and + then returns its argument r to its caller. + + * A series of canned entry points like + gcfun_2p( f, x, y ) + where f is a function closure of arity 2 + This performs garbage collection, keeping alive the + three argument ptrs, and then tail-calls f(x,y) + +These are used in the following circumstances + +* entryHeapCheck: Function entry + (a) With a canned GC entry sequence + f( f_clo, x:ptr, y:ptr ) { + Hp = Hp+8 + if Hp > HpLim goto L + ... + L: HpAlloc = 8 + jump gcfun_2p( f_clo, x, y ) } + Note the tail call to the garbage collector; + it should do no register shuffling + + (b) No canned sequence + f( f_clo, x:ptr, y:ptr, ...etc... ) { + T: Hp = Hp+8 + if Hp > HpLim goto L + ... + L: HpAlloc = 8 + call gc() -- Needs an info table + goto T } + +* altHeapCheck: Immediately following an eval + Started as + case f x y of r { (p,q) -> rhs } + (a) With a canned sequence for the results of f + (which is the very common case since + all boxed cases return just one pointer + ... + r = f( x, y ) + K: -- K needs an info table + Hp = Hp+8 + if Hp > HpLim goto L + ...code for rhs... + + L: r = gc_1p( r ) + goto K } + + Here, the info table needed by the call + to gc_1p should be the *same* as the + one for the call to f; the C-- optimiser + spots this sharing opportunity) + + (b) No canned sequence for results of f + Note second info table + ... + (r1,r2,r3) = call f( x, y ) + K: + Hp = Hp+8 + if Hp > HpLim goto L + ...code for rhs... + + L: call gc() -- Extra info table here + goto K + +* generalHeapCheck: Anywhere else + e.g. entry to thunk + case branch *not* following eval, + or let-no-escape + Exactly the same as the previous case: + + K: -- K needs an info table + Hp = Hp+8 + if Hp > HpLim goto L + ... + + L: call gc() + goto K +-} + +-------------------------------------------------------------- +-- A heap/stack check at a function or thunk entry point. + +entryHeapCheck :: ClosureInfo + -> Maybe LocalReg -- Function (closure environment) + -> Int -- Arity -- not same as len args b/c of voids + -> [LocalReg] -- Non-void args (empty for thunk) + -> FCode () + -> FCode () + +entryHeapCheck cl_info nodeSet arity args code = do + platform <- getPlatform + let + node = case nodeSet of + Just r -> CmmReg (CmmLocal r) + Nothing -> CmmLit (CmmLabel $ staticClosureLabel platform cl_info) + + is_fastf = case closureFunInfo cl_info of + Just (_, ArgGen _) -> False + _otherwise -> True + + entryHeapCheck' is_fastf node arity args code + +-- | lower-level version for "GHC.Cmm.Parser" +entryHeapCheck' :: Bool -- is a known function pattern + -> CmmExpr -- expression for the closure pointer + -> Int -- Arity -- not same as len args b/c of voids + -> [LocalReg] -- Non-void args (empty for thunk) + -> FCode () + -> FCode () +entryHeapCheck' is_fastf node arity args code + = do profile <- getProfile + let platform = profilePlatform profile + is_thunk = arity == 0 + + args' = map (CmmReg . CmmLocal) args + stg_gc_fun = CmmReg (CmmGlobal $ GlobalRegUse GCFun $ bWord platform) + stg_gc_enter1 = CmmReg (CmmGlobal $ GlobalRegUse GCEnter1 $ bWord platform) + + {- Thunks: jump stg_gc_enter_1 + + Function (fast): call (NativeNode) stg_gc_fun(fun, args) + + Function (slow): call (slow) stg_gc_fun(fun, args) + -} + gc_call upd + | is_thunk + = mkJump profile NativeNodeCall stg_gc_enter1 [node] upd + + | is_fastf + = mkJump profile NativeNodeCall stg_gc_fun (node : args') upd + + | otherwise + = mkJump profile Slow stg_gc_fun (node : args') upd + + updfr_sz <- getUpdFrameOff + + loop_id <- newBlockId + emitLabel loop_id + heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code + +-- ------------------------------------------------------------ +-- A heap/stack check in a case alternative + + +-- If there are multiple alts and we need to GC, but don't have a +-- continuation already (the scrut was simple), then we should +-- pre-generate the continuation. (if there are multiple alts it is +-- always a canned GC point). + +-- altHeapCheck: +-- If we have a return continuation, +-- then if it is a canned GC pattern, +-- then we do mkJumpReturnsTo +-- else we do a normal call to stg_gc_noregs +-- else if it is a canned GC pattern, +-- then generate the continuation and do mkCallReturnsTo +-- else we do a normal call to stg_gc_noregs + +altHeapCheck :: [LocalReg] -> FCode a -> FCode a +altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code + +altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a +altOrNoEscapeHeapCheck checkYield regs code = do + profile <- getProfile + platform <- getPlatform + case cannedGCEntryPoint platform regs of + Nothing -> genericGC checkYield code + Just gc -> do + lret <- newBlockId + let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) regs [] + lcont <- newBlockId + tscope <- getTickScope + emitOutOfLine lret (copyin <*> mkBranch lcont, tscope) + emitLabel lcont + cannedGCReturnsTo checkYield False gc regs lret off code + +altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a +altHeapCheckReturnsTo regs lret off code + = do platform <- getPlatform + case cannedGCEntryPoint platform regs of + Nothing -> genericGC False code + Just gc -> cannedGCReturnsTo False True gc regs lret off code + +-- noEscapeHeapCheck is implemented identically to altHeapCheck (which +-- is more efficient), but cannot be optimized away in the non-allocating +-- case because it may occur in a loop +noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a +noEscapeHeapCheck = altOrNoEscapeHeapCheck True + +cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff + -> FCode a + -> FCode a +cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code + = do profile <- getProfile + updfr_sz <- getUpdFrameOff + heapCheck False checkYield (gc_call profile gc updfr_sz) code + where + reg_exprs = map (CmmReg . CmmLocal) regs + -- Note [stg_gc arguments] + + -- NB. we use the NativeReturn convention for passing arguments + -- to the canned heap-check routines, because we are in a case + -- alternative and hence the [LocalReg] was passed to us in the + -- NativeReturn convention. + gc_call profile label sp + | cont_on_stack + = mkJumpReturnsTo profile label NativeReturn reg_exprs lret off sp + | otherwise + = mkCallReturnsTo profile label NativeReturn reg_exprs lret off sp [] + +genericGC :: Bool -> FCode a -> FCode a +genericGC checkYield code + = do updfr_sz <- getUpdFrameOff + lretry <- newBlockId + emitLabel lretry + call <- mkCall generic_gc (GC, GC) [] [] updfr_sz [] + heapCheck False checkYield (call <*> mkBranch lretry) code + +cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr +cannedGCEntryPoint platform regs + = case map localRegType regs of + [] -> Just (mkGcLabel "stg_gc_noregs") + [ty] + | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1") + | isFloatType ty -> case width of + W32 -> Just (mkGcLabel "stg_gc_f1") + W64 -> Just (mkGcLabel "stg_gc_d1") + _ -> Nothing + + | width == wordWidth platform -> Just (mkGcLabel "stg_gc_unbx_r1") + | width == W64 -> Just (mkGcLabel "stg_gc_l1") + | otherwise -> Nothing + where + width = typeWidth ty + [ty1,ty2] + | isGcPtrType ty1 + && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp") + [ty1,ty2,ty3] + | isGcPtrType ty1 + && isGcPtrType ty2 + && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp") + [ty1,ty2,ty3,ty4] + | isGcPtrType ty1 + && isGcPtrType ty2 + && isGcPtrType ty3 + && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp") + _otherwise -> Nothing + +-- Note [stg_gc arguments] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- It might seem that we could avoid passing the arguments to the +-- stg_gc function, because they are already in the right registers. +-- While this is usually the case, it isn't always. Sometimes the +-- code generator has cleverly avoided the eval in a case, e.g. in +-- ffi/should_run/4221.hs we found +-- +-- case a_r1mb of z +-- FunPtr x y -> ... +-- +-- where a_r1mb is bound a top-level constructor, and is known to be +-- evaluated. The codegen just assigns x, y and z, and continues; +-- R1 is never assigned. +-- +-- So we'll have to rely on optimisations to eliminatethese +-- assignments where possible. + + +-- | The generic GC procedure; no params, no results +generic_gc :: CmmExpr +generic_gc = mkGcLabel "stg_gc_noregs" + +-- | Create a CLabel for calling a garbage collector entry point +mkGcLabel :: String -> CmmExpr +mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s))) + +------------------------------- +heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a +heapCheck checkStack checkYield do_gc code + = getHeapUsage $ \ hpHw -> + -- Emit heap checks, but be sure to do it lazily so + -- that the conditionals on hpHw don't cause a black hole + do { platform <- getPlatform + ; let mb_alloc_bytes + | hpHw > mBLOCK_SIZE = sorry $ unlines + [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.", + "", + "This is currently not possible due to a limitation of GHC's code generator.", + "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.", + "Suggestion: read data from a file instead of having large static data", + "structures in code."] + | hpHw > 0 = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform))) + | otherwise = Nothing + where + constants = platformConstants platform + bLOCK_SIZE_W = pc_BLOCK_SIZE (platformConstants platform) `quot` platformWordSizeInBytes platform + mBLOCK_SIZE = pc_BLOCKS_PER_MBLOCK constants * bLOCK_SIZE_W + stk_hwm | checkStack = Just (CmmLit CmmHighStackMark) + | otherwise = Nothing + ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc + ; tickyAllocHeap True hpHw + ; setRealHp hpHw + ; code } + +heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode () +heapStackCheckGen stk_hwm mb_bytes + = do updfr_sz <- getUpdFrameOff + lretry <- newBlockId + emitLabel lretry + call <- mkCall generic_gc (GC, GC) [] [] updfr_sz [] + do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry) + +-- Note [Single stack check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When compiling a function we can determine how much stack space it +-- will use. We therefore need to perform only a single stack check at +-- the beginning of a function to see if we have enough stack space. +-- +-- The check boils down to comparing Sp-N with SpLim, where N is the +-- amount of stack space needed (see Note [Stack usage] below). *BUT* +-- at this stage of the pipeline we are not supposed to refer to Sp +-- itself, because the stack is not yet manifest, so we don't quite +-- know where Sp pointing. + +-- So instead of referring directly to Sp - as we used to do in the +-- past - the code generator uses (old + 0) in the stack check. That +-- is the address of the first word of the old area, so if we add N +-- we'll get the address of highest used word. +-- +-- This makes the check robust. For example, while we need to perform +-- only one stack check for each function, we could in theory place +-- more stack checks later in the function. They would be redundant, +-- but not incorrect (in a sense that they should not change program +-- behaviour). We need to make sure however that a stack check +-- inserted after incrementing the stack pointer checks for a +-- respectively smaller stack space. This would not be the case if the +-- code generator produced direct references to Sp. By referencing +-- (old + 0) we make sure that we always check for a correct amount of +-- stack: when converting (old + 0) to Sp the stack layout phase takes +-- into account changes already made to stack pointer. The idea for +-- this change came from observations made while debugging #8275. + +-- Note [Stack usage] +-- ~~~~~~~~~~~~~~~~~~ +-- At the moment we convert from STG to Cmm we don't know N, the +-- number of bytes of stack that the function will use, so we use a +-- special late-bound CmmLit, namely +-- CmmHighStackMark +-- to stand for the number of bytes needed. When the stack is made +-- manifest, the number of bytes needed is calculated, and used to +-- replace occurrences of CmmHighStackMark +-- +-- The (Maybe CmmExpr) passed to do_checks is usually +-- Just (CmmLit CmmHighStackMark) +-- but can also (in certain hand-written RTS functions) +-- Just (CmmLit 8) or some other fixed valuet +-- If it is Nothing, we don't generate a stack check at all. + +do_checks :: Maybe CmmExpr -- Should we check the stack? + -- See Note [Stack usage] + -> Bool -- Should we check for preemption? + -> Maybe CmmExpr -- Heap headroom (bytes) + -> CmmAGraph -- What to do on failure + -> FCode () +do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do + omit_yields <- stgToCmmOmitYields <$> getStgToCmmConfig + platform <- getPlatform + gc_id <- newBlockId + + let + -- Sp overflow if ((old + 0) - CmmHighStack < SpLim) + -- At the beginning of a function old + 0 = Sp + -- See Note [Single stack check] + sp_oflo sp_hwm = + CmmMachOp (mo_wordULt platform) + [CmmMachOp (MO_Sub (typeWidth (cmmRegType $ spReg platform))) + [CmmStackSlot Old 0, sp_hwm], + CmmReg $ spLimReg platform] + + -- Hp overflow if (Hp > HpLim) + -- (Hp has been incremented by now) + -- HpLim points to the LAST WORD of valid allocation space. + hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr platform, hpLimExpr platform] + + case mb_stk_hwm of + Nothing -> return () + Just stk_hwm -> tickyStackCheck + >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) ) + + -- Emit new label that might potentially be a header + -- of a self-recursive tail call. + -- See Note [Self-recursive loop header]. + self_loop_info <- getSelfLoop + case self_loop_info of + Just MkSelfLoopInfo { sli_header_block = loop_header_id } + | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id + _otherwise -> return () + + case mb_alloc_lit of + Just alloc_lit -> do + let bump_hp = cmmOffsetExprB platform (hpExpr platform) alloc_lit + alloc_n = mkAssign (hpAllocReg platform) alloc_lit + tickyHeapCheck + emitAssign (hpReg platform) bump_hp + emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False) + Nothing -> + when (checkYield && not omit_yields) $ do + -- Yielding if HpLim == 0 + let yielding = CmmMachOp (mo_wordEq platform) + [CmmReg $ hpLimReg platform, + CmmLit (zeroCLit platform)] + emit =<< mkCmmIfGoto' yielding gc_id (Just False) + + tscope <- getTickScope + emitOutOfLine gc_id + (do_gc, tscope) -- this is expected to jump back somewhere + + -- Test for stack pointer exhaustion, then + -- bump heap pointer, and test for heap exhaustion + -- Note that we don't move the heap pointer unless the + -- stack check succeeds. Otherwise we might end up + -- with slop at the end of the current block, which can + -- confuse the LDV profiler. + +-- Note [Self-recursive loop header] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Self-recursive loop header is required by loopification optimization (See +-- Note [Self-recursive tail calls] in GHC.StgToCmm.Expr). We emit it if: +-- +-- 1. There is information about self-loop in the FCode environment. We don't +-- check the binder (first component of the self_loop_info) because we are +-- certain that if the self-loop info is present then we are compiling the +-- binder body. Reason: the only possible way to get here with the +-- self_loop_info present is from closureCodeBody. +-- +-- 2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible +-- to preempt the heap check (see #367 for motivation behind this check). It +-- is True for heap checks placed at the entry to a function and +-- let-no-escape heap checks but false for other heap checks (eg. in case +-- alternatives or created from hand-written high-level Cmm). The second +-- check (isJust mb_stk_hwm) is true for heap checks at the entry to a +-- function and some heap checks created in hand-written Cmm. Otherwise it +-- is Nothing. In other words the only situation when both conditions are +-- true is when compiling stack and heap checks at the entry to a +-- function. This is the only situation when we want to emit a self-loop +-- label. diff --git a/GHC/StgToCmm/Hpc.hs b/GHC/StgToCmm/Hpc.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Hpc.hs @@ -0,0 +1,32 @@ +----------------------------------------------------------------------------- +-- +-- Code generation for coverage +-- +-- (c) Galois Connections, Inc. 2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Hpc ( mkTickBox ) where + +import GHC.Prelude +import GHC.Platform + + +import GHC.Cmm.Graph +import GHC.Cmm.Expr +import GHC.Cmm.CLabel +import GHC.Cmm.Utils + +import GHC.Unit.Module + + +mkTickBox :: Platform -> Module -> Int -> CmmAGraph +mkTickBox platform mod n + = mkStore tick_box (CmmMachOp (MO_Add W64) + [ CmmLoad tick_box b64 NaturallyAligned + , CmmLit (CmmInt 1 W64) + ]) + where + tick_box = cmmIndex platform W64 + (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) + n diff --git a/GHC/StgToCmm/InfoTableProv.hs b/GHC/StgToCmm/InfoTableProv.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/InfoTableProv.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE CPP #-} + +module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where + +import Foreign + +#if defined(HAVE_LIBZSTD) +import Foreign.C.Types +import qualified Data.ByteString.Internal as BSI +import GHC.IO (unsafePerformIO) +#endif + +import GHC.Prelude +import GHC.Platform +import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile) +import GHC.Types.Unique.DSM +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Data.FastString (fastStringToShortText, unpackFS, LexicalFastString(..)) + +import GHC.Cmm +import GHC.Cmm.CLabel +import GHC.Cmm.Utils + +import GHC.StgToCmm.Config +import GHC.StgToCmm.Monad + +import GHC.Data.ShortText (ShortText) +import qualified GHC.Data.ShortText as ST + +import Control.Monad.Trans.State.Strict + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map.Strict as M + +{- +Note [Compression and Decompression of IPE data] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Compiling with `-finfo-table-map` causes build results to include a map from +info tables to source positions called the info table provenance entry (IPE) +map. See Note [Mapping Info Tables to Source Positions]. The IPE information +can grow the size of build results significantly. At the time of writing, a +default build of GHC results in a total of 109M of libHSghc-*.so build results. +A default+ipe build of GHC (see ./hadrian/doc/flavours.md) results in 262M of +libHSghc-*.so build results without compression. + +We reduce the impact of IPE data on the size of build results by compressing +the data before it is emitted using the zstd compression library. See +Note [The Info Table Provenance Entry (IPE) Map] for information on the layout +of IPE data on disk and in the RTS. We cannot simply compress all data held in +the IPE entry buffer, as the pointers to info tables must be converted to +memory addresses during linking. Therefore, we can only compress the strings +table and the IPE entries themselves (which essentially only consist of indices +into the strings table). + +With compression, a default+ipe build of GHC results in a total of 205M of +libHSghc-*.so build results. This is over a 20% reduction from the uncompressed +case. + +Decompression happens lazily, as it only occurs when the IPE map is +constructed (which is also done lazily on first lookup or traversal). During +construction, the 'compressed' field of each IPE buffer list node is examined. +If the field indicates that the data has been compressed, the entry data and +strings table are decompressed before continuing with the normal IPE map +construction. +-} + +emitIpeBufferListNode :: + Module + -> [InfoProvEnt] + -> DUniqSupply -- ^ Symbols created source uniques deterministically + -- All uniques must be created from this supply. + -- NB: If you are creating a new symbol within this function, + -- make sure it is local only (as in not `externallyVisibleCLabel`). + -- If you need it to be global, reconsider the comment on the + -- call of emitIpeBufferListNode in Cmm.Parser. + -> FCode DUniqSupply +emitIpeBufferListNode _ [] dus = return dus +emitIpeBufferListNode this_mod ents dus0 = do + cfg <- getStgToCmmConfig + + let (u1, dus1) = takeUniqueFromDSupply dus0 + (u2, dus2) = takeUniqueFromDSupply dus1 + (u3, dus3) = takeUniqueFromDSupply dus2 + + tables_lbl = mkStringLitLabel u1 + strings_lbl = mkStringLitLabel u2 + entries_lbl = mkStringLitLabel u3 + + ctx = stgToCmmContext cfg + platform = stgToCmmPlatform cfg + int n = mkIntCLit platform n + + ((cg_ipes, unit_id, module_name), strtab) = flip runState emptyStringTable $ do + unit_id <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr $ moduleName this_mod) + module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr $ moduleUnit this_mod) + cg_ipes <- mapM (toCgIPE platform ctx) ents + return (cg_ipes, unit_id, module_name) + + tables :: [CmmStatic] + tables = map (CmmStaticLit . CmmLabel . ipeInfoTablePtr) cg_ipes + + uncompressed_strings :: BS.ByteString + uncompressed_strings = getStringTableStrings strtab + + strings_bytes :: BS.ByteString + strings_bytes = compress defaultCompressionLevel uncompressed_strings + + strings :: [CmmStatic] + strings = [CmmString strings_bytes] + + uncompressed_entries :: BS.ByteString + uncompressed_entries = toIpeBufferEntries (platformByteOrder platform) cg_ipes + + entries_bytes :: BS.ByteString + entries_bytes = compress defaultCompressionLevel uncompressed_entries + + entries :: [CmmStatic] + entries = [CmmString entries_bytes] + + ipe_buffer_lbl :: CLabel + ipe_buffer_lbl = mkIPELabel this_mod + + ipe_buffer_node :: [CmmStatic] + ipe_buffer_node = map CmmStaticLit + [ -- 'next' field + zeroCLit platform + + -- 'compressed' field + , int do_compress + + -- 'count' field + , int $ length cg_ipes + + -- 'tables' field + , CmmLabel tables_lbl + + -- 'entries' field + , CmmLabel entries_lbl + + -- 'entries_size' field (decompressed size) + , int $ BS.length uncompressed_entries + + -- 'string_table' field + , CmmLabel strings_lbl + + -- 'string_table_size' field (decompressed size) + , int $ BS.length uncompressed_strings + + -- 'module_name' field + , CmmInt (fromIntegral module_name) W32 + + -- 'unit_id' field + , CmmInt (fromIntegral unit_id) W32 + ] + + -- Emit the list of info table pointers + emitDecl $ CmmData + (Section Data tables_lbl) + (CmmStaticsRaw tables_lbl tables) + + -- Emit the strings table + emitDecl $ CmmData + (Section Data strings_lbl) + (CmmStaticsRaw strings_lbl strings) + + -- Emit the list of IPE buffer entries + emitDecl $ CmmData + (Section Data entries_lbl) + (CmmStaticsRaw entries_lbl entries) + + -- Emit the IPE buffer list node + emitDecl $ CmmData + (Section Data ipe_buffer_lbl) + (CmmStaticsRaw ipe_buffer_lbl ipe_buffer_node) + + return dus3 + +-- | Emit the fields of an IpeBufferEntry struct for each entry in a given list. +toIpeBufferEntries :: + ByteOrder -- ^ Byte order to write the data in + -> [CgInfoProvEnt] -- ^ List of IPE buffer entries + -> BS.ByteString +toIpeBufferEntries byte_order cg_ipes = + BSL.toStrict . BSB.toLazyByteString . mconcat + $ map (mconcat . map word32Builder . to_ipe_buf_ent) cg_ipes + where + to_ipe_buf_ent :: CgInfoProvEnt -> [Word32] + to_ipe_buf_ent cg_ipe = + [ ipeTableName cg_ipe + , fromIntegral $ ipeClosureDesc cg_ipe + , ipeTypeDesc cg_ipe + , ipeLabel cg_ipe + , ipeSrcFile cg_ipe + , ipeSrcSpan cg_ipe + ] + + word32Builder :: Word32 -> BSB.Builder + word32Builder = case byte_order of + BigEndian -> BSB.word32BE + LittleEndian -> BSB.word32LE + +toCgIPE :: Platform -> SDocContext -> InfoProvEnt -> State StringTable CgInfoProvEnt +toCgIPE platform ctx ipe = do + table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe)) + type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe + let label_str = maybe "" ((\(LexicalFastString s) -> unpackFS s) . snd) (infoTableProv ipe) + let (src_loc_file, src_loc_span) = + case infoTableProv ipe of + Nothing -> (mempty, "") + Just (span, _) -> + let file = fastStringToShortText $ srcSpanFile span + coords = renderWithContext ctx (pprUserRealSpan False span) + in (file, coords) + label <- lookupStringTable $ ST.pack label_str + src_file <- lookupStringTable src_loc_file + src_span <- lookupStringTable $ ST.pack src_loc_span + return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe + , ipeTableName = table_name + , ipeClosureDesc = fromIntegral (infoProvEntClosureType ipe) + , ipeTypeDesc = type_desc + , ipeLabel = label + , ipeSrcFile = src_file + , ipeSrcSpan = src_span + } + +data CgInfoProvEnt = CgInfoProvEnt + { ipeInfoTablePtr :: !CLabel + , ipeTableName :: !StrTabOffset + , ipeClosureDesc :: !Word32 + , ipeTypeDesc :: !StrTabOffset + , ipeLabel :: !StrTabOffset + , ipeSrcFile :: !StrTabOffset + , ipeSrcSpan :: !StrTabOffset + } + +data StringTable = StringTable { stStrings :: DList ShortText + , stLength :: !Int + , stLookup :: !(M.Map ShortText StrTabOffset) + } + +type StrTabOffset = Word32 + +emptyStringTable :: StringTable +emptyStringTable = + StringTable { stStrings = emptyDList + , stLength = 0 + , stLookup = M.empty + } + +getStringTableStrings :: StringTable -> BS.ByteString +getStringTableStrings st = + BSL.toStrict $ BSB.toLazyByteString + $ foldMap f $ dlistToList (stStrings st) + where + f x = BSB.shortByteString (ST.contents x) `mappend` BSB.word8 0 + +lookupStringTable :: ShortText -> State StringTable StrTabOffset +lookupStringTable str = state $ \st -> + case M.lookup str (stLookup st) of + Just off -> (off, st) + Nothing -> + let !st' = st { stStrings = stStrings st `snoc` str + , stLength = stLength st + ST.byteLength str + 1 + , stLookup = M.insert str res (stLookup st) + } + res = fromIntegral (stLength st) + in (res, st') + +do_compress :: Int +compress :: Int -> BS.ByteString -> BS.ByteString +#if !defined(HAVE_LIBZSTD) +do_compress = 0 +compress _ bs = bs +#else +do_compress = 1 + +compress clvl (BSI.PS srcForeignPtr off len) = unsafePerformIO $ + withForeignPtr srcForeignPtr $ \srcPtr -> do + maxCompressedSize <- zstd_compress_bound $ fromIntegral len + dstForeignPtr <- BSI.mallocByteString (fromIntegral maxCompressedSize) + withForeignPtr dstForeignPtr $ \dstPtr -> do + compressedSize <- fromIntegral <$> + zstd_compress + dstPtr + maxCompressedSize + (srcPtr `plusPtr` off) + (fromIntegral len) + (fromIntegral clvl) + BSI.create compressedSize $ \p -> copyBytes p dstPtr compressedSize + +foreign import ccall unsafe "ZSTD_compress" + zstd_compress :: + Ptr dst -- ^ Destination buffer + -> CSize -- ^ Capacity of destination buffer + -> Ptr src -- ^ Source buffer + -> CSize -- ^ Size of source buffer + -> CInt -- ^ Compression level + -> IO CSize + +-- | Compute the maximum compressed size for a given source buffer size +foreign import ccall unsafe "ZSTD_compressBound" + zstd_compress_bound :: + CSize -- ^ Size of source buffer + -> IO CSize +#endif + +defaultCompressionLevel :: Int +defaultCompressionLevel = 3 + +newtype DList a = DList ([a] -> [a]) + +emptyDList :: DList a +emptyDList = DList id + +snoc :: DList a -> a -> DList a +snoc (DList f) x = DList (f . (x:)) + +dlistToList :: DList a -> [a] +dlistToList (DList f) = f [] diff --git a/GHC/StgToCmm/Layout.hs b/GHC/StgToCmm/Layout.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Layout.hs @@ -0,0 +1,660 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Building info tables. +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Layout ( + mkArgDescr, + emitCall, emitReturn, adjustHpBackwards, + + emitClosureProcAndInfoTable, + emitClosureAndInfoTable, + + slowCall, directCall, + + FieldOffOrPadding(..), + ClosureHeader(..), + mkVirtHeapOffsets, + mkVirtHeapOffsetsWithPadding, + mkVirtConstrOffsets, + mkVirtConstrSizes, + getHpRelOffset, + + ArgRep(..), toArgRep, toArgRepOrV, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep + getArgAmode, getNonVoidArgAmodes + ) where + + +import GHC.Prelude hiding ((<*>)) + +import GHC.StgToCmm.Closure +import GHC.StgToCmm.Env +import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern ) +import GHC.StgToCmm.Ticky +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Lit +import GHC.StgToCmm.Utils + +import GHC.Cmm.Graph +import GHC.Runtime.Heap.Layout +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Info +import GHC.Cmm.CLabel +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primRepSizeB ) +import GHC.Types.Basic ( RepArity ) +import GHC.Platform +import GHC.Platform.Profile +import GHC.Unit + +import GHC.Utils.Misc +import Data.List (mapAccumL, partition) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Data.FastString +import Control.Monad +import GHC.StgToCmm.Config (stgToCmmPlatform) +import GHC.StgToCmm.Types +import Data.List.NonEmpty (nonEmpty) + +------------------------------------------------------------------------ +-- Call and return sequences +------------------------------------------------------------------------ + +-- | Return multiple values to the sequel +-- +-- If the sequel is @Return@ +-- +-- > return (x,y) +-- +-- If the sequel is @AssignTo [p,q]@ +-- +-- > p=x; q=y; +-- +emitReturn :: [CmmExpr] -> FCode ReturnKind +emitReturn results + = do { profile <- getProfile + ; platform <- getPlatform + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; case sequel of + Return -> + do { adjustHpBackwards + ; let e = cmmLoadGCWord platform (CmmStackSlot Old updfr_off) + ; emit (mkReturn profile (entryCode platform e) results updfr_off) + } + AssignTo regs adjust -> + do { when adjust adjustHpBackwards + ; emitMultiAssign regs results } + ; return AssignedDirectly + } + + +-- | @emitCall conv fun args@ makes a call to the entry-code of @fun@, +-- using the call/return convention @conv@, passing @args@, and +-- returning the results to the current sequel. +-- +emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind +emitCall convs fun args + = emitCallWithExtraStack convs fun args noExtraStack + + +-- | @emitCallWithExtraStack conv fun args stack@ makes a call to the +-- entry-code of @fun@, using the call/return convention @conv@, +-- passing @args@, pushing some extra stack frames described by +-- @stack@, and returning the results to the current sequel. +-- +emitCallWithExtraStack + :: (Convention, Convention) -> CmmExpr -> [CmmExpr] + -> [CmmExpr] -> FCode ReturnKind +emitCallWithExtraStack (callConv, retConv) fun args extra_stack + = do { profile <- getProfile + ; adjustHpBackwards + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; case sequel of + Return -> do + emit $ mkJumpExtra profile callConv fun args updfr_off extra_stack + return AssignedDirectly + AssignTo res_regs _ -> do + k <- newBlockId + let area = Young k + (off, _, copyin) = copyInOflow profile retConv area res_regs [] + copyout = mkCallReturnsTo profile fun callConv args k off updfr_off + extra_stack + tscope <- getTickScope + emit (copyout <*> mkLabel k tscope <*> copyin) + return (ReturnedTo k off) + } + + +adjustHpBackwards :: FCode () +-- This function adjusts the heap pointer just before a tail call or +-- return. At a call or return, the virtual heap pointer may be less +-- than the real Hp, because the latter was advanced to deal with +-- the worst-case branch of the code, and we may be in a better-case +-- branch. In that case, move the real Hp *back* and retract some +-- ticky allocation count. +-- +-- It *does not* deal with high-water-mark adjustment. That's done by +-- functions which allocate heap. +adjustHpBackwards + = do { hp_usg <- getHpUsage + ; let rHp = realHp hp_usg + vHp = virtHp hp_usg + adjust_words = vHp -rHp + ; new_hp <- getHpRelOffset vHp + + ; platform <- getPlatform + ; emit (if adjust_words == 0 + then mkNop + else mkAssign (hpReg platform) new_hp) -- Generates nothing when vHp==rHp + + ; tickyAllocHeap False adjust_words -- ...ditto + + ; setRealHp vHp + } + + +------------------------------------------------------------------------- +-- Making calls: directCall and slowCall +------------------------------------------------------------------------- + +-- General plan is: +-- - we'll make *one* fast call, either to the function itself +-- (directCall) or to stg_ap__fast (slowCall) +-- Any left-over arguments will be pushed on the stack, +-- +-- e.g. Sp[old+8] = arg1 +-- Sp[old+16] = arg2 +-- Sp[old+32] = stg_ap_pp_info +-- R2 = arg3 +-- R3 = arg4 +-- call f() return to Nothing updfr_off: 32 + + +directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind +-- (directCall f n args) +-- calls f(arg1, ..., argn), and applies the result to the remaining args +-- The function f has arity n, and there are guaranteed at least n args +-- Both arity and args include void args +directCall conv lbl arity stg_args + = do { argreps <- getArgRepsAmodes stg_args + ; direct_call "directCall" conv lbl arity argreps } + + +slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind +-- (slowCall fun args) applies fun to args, returning the results to Sequel +slowCall fun stg_args + = do cfg <- getStgToCmmConfig + let profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg + ctx = stgToCmmContext cfg + fast_pap = stgToCmmFastPAPCalls cfg + align_sat = stgToCmmAlignCheck cfg + argsreps <- getArgRepsAmodes stg_args + let (rts_fun, arity) = slowCallPattern (map fst argsreps) + + (r, slow_code) <- getCodeR $ do + r <- direct_call "slow_call" NativeNodeCall + (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps) + emitComment $ mkFastString ("slow_call for " ++ + showSDocOneLine ctx (pdoc platform fun) ++ + " with pat " ++ unpackFS rts_fun) + return r + + -- See Note [avoid intermediate PAPs] + let n_args = length stg_args + if n_args > arity && fast_pap + then do + funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun + fun_iptr <- (CmmReg . CmmLocal) `fmap` + assignTemp (closureInfoPtr platform align_sat (cmmUntag platform funv)) + + -- ToDo: we could do slightly better here by reusing the + -- continuation from the slow call, which we have in r. + -- Also we'd like to push the continuation on the stack + -- before the branch, so that we only get one copy of the + -- code that saves all the live variables across the + -- call, but that might need some improvements to the + -- special case in the stack layout code to handle this + -- (see Note [diamond proc point]). + + fast_code <- getCode $ + emitCall (NativeNodeCall, NativeReturn) + (entryCode platform fun_iptr) + (nonVArgs ((P,Just funv):argsreps)) + + slow_lbl <- newBlockId + fast_lbl <- newBlockId + is_tagged_lbl <- newBlockId + end_lbl <- newBlockId + + let correct_arity = cmmEqWord platform (funInfoArity profile fun_iptr) + (mkIntExpr platform n_args) + + tscope <- getTickScope + emit (mkCbranch (cmmIsTagged platform funv) + is_tagged_lbl slow_lbl (Just True) + <*> mkLabel is_tagged_lbl tscope + <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True) + <*> mkLabel fast_lbl tscope + <*> fast_code + <*> mkBranch end_lbl + <*> mkLabel slow_lbl tscope + <*> slow_code + <*> mkLabel end_lbl tscope) + return r + + else do + emit slow_code + return r + + +-- Note [avoid intermediate PAPs] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A slow call which needs multiple generic apply patterns will be +-- almost guaranteed to create one or more intermediate PAPs when +-- applied to a function that takes the correct number of arguments. +-- We try to avoid this situation by generating code to test whether +-- we are calling a function with the correct number of arguments +-- first, i.e.: +-- +-- if (TAG(f) != 0} { // f is not a thunk +-- if (f->info.arity == n) { +-- ... make a fast call to f ... +-- } +-- } +-- ... otherwise make the slow call ... +-- +-- We *only* do this when the call requires multiple generic apply +-- functions, which requires pushing extra stack frames and probably +-- results in intermediate PAPs. (I say probably, because it might be +-- that we're over-applying a function, but that seems even less +-- likely). +-- +-- This very rarely applies, but if it does happen in an inner loop it +-- can have a severe impact on performance (#6084). + + +-------------- +direct_call :: String + -> Convention -- e.g. NativeNodeCall or NativeDirectCall + -> CLabel -> RepArity + -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind +direct_call caller call_conv lbl arity args + | debugIsOn && args `lengthLessThan` real_arity -- Too few args + = do -- Caller should ensure that there enough args! + platform <- getPlatform + pprPanic "direct_call" $ + text caller <+> ppr arity <+> + pprDebugCLabel platform lbl <+> ppr (length args) <+> + pdoc platform (map snd args) <+> ppr (map fst args) + + | null rest_args -- Precisely the right number of arguments + = emitCall (call_conv, NativeReturn) target (nonVArgs args) + + | otherwise -- Note [over-saturated calls] + = do do_scc_prof <- stgToCmmSCCProfiling <$> getStgToCmmConfig + platform <- getPlatform + emitCallWithExtraStack (call_conv, NativeReturn) + target + (nonVArgs fast_args) + (nonVArgs (slowArgs platform rest_args do_scc_prof)) + where + target = CmmLit (CmmLabel lbl) + (fast_args, rest_args) = splitAt real_arity args + real_arity = case call_conv of + NativeNodeCall -> arity+1 + _ -> arity + + +-- When constructing calls, it is easier to keep the ArgReps and the +-- CmmExprs zipped together. However, a void argument has no +-- representation, so we need to use Maybe CmmExpr (the alternative of +-- using zeroCLit or even undefined would work, but would be ugly). +-- +getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)] +getArgRepsAmodes args = do + platform <- profilePlatform <$> getProfile + mapM (getArgRepAmode platform) args + where getArgRepAmode platform arg + = case stgArgRep1 arg of + VoidRep -> return (V, Nothing) + NVRep rep -> do expr <- getArgAmode (NonVoid arg) + return (toArgRep platform rep, Just expr) + +nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] +nonVArgs [] = [] +nonVArgs ((_,Nothing) : args) = nonVArgs args +nonVArgs ((_,Just arg) : args) = arg : nonVArgs args + +{- +Note [over-saturated calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The natural thing to do for an over-saturated call would be to call +the function with the correct number of arguments, and then apply the +remaining arguments to the value returned, e.g. + + f a b c d (where f has arity 2) + --> + r = call f(a,b) + call r(c,d) + +but this entails + - saving c and d on the stack + - making a continuation info table + - at the continuation, loading c and d off the stack into regs + - finally, call r + +Note that since there are a fixed number of different r's +(e.g. stg_ap_pp_fast), we can also pre-compile continuations +that correspond to each of them, rather than generating a fresh +one for each over-saturated call. + +Not only does this generate much less code, it is faster too. We will +generate something like: + +Sp[old+16] = c +Sp[old+24] = d +Sp[old+32] = stg_ap_pp_info +call f(a,b) -- usual calling convention + +For the purposes of the CmmCall node, we count this extra stack as +just more arguments that we are passing on the stack (cml_args). +-} + +-- | 'slowArgs' takes a list of function arguments and prepares them for +-- pushing on the stack for "extra" arguments to a function which requires +-- fewer arguments than we currently have. +slowArgs :: Platform -> [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)] +slowArgs platform args sccProfilingEnabled -- careful: reps contains voids (V), but args does not + = case nonEmpty args of + Nothing -> mempty + Just args1 + | sccProfilingEnabled -> save_cccs ++ this_pat ++ slowArgs platform rest_args sccProfilingEnabled + | otherwise -> this_pat ++ slowArgs platform rest_args sccProfilingEnabled + where + (arg_pat, n) = slowCallPattern (fmap fst args) + (call_args, rest_args) = splitAt n args + + stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat + this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args + save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just $ cccsExpr platform)] + save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit $ "stg_restore_cccs_" ++ arg_reps) + arg_reps = case maximum (fmap fst args1) of + V64 -> "v64" + V32 -> "v32" + V16 -> "v16" + _ -> "d" + + + +------------------------------------------------------------------------- +---- Laying out objects on the heap and stack +------------------------------------------------------------------------- + +-- The heap always grows upwards, so hpRel is easy to compute +hpRel :: VirtualHpOffset -- virtual offset of Hp + -> VirtualHpOffset -- virtual offset of The Thing + -> WordOff -- integer word offset +hpRel hp off = off - hp + +getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr +-- See Note [Virtual and real heap pointers] in GHC.StgToCmm.Monad +getHpRelOffset virtual_offset + = do platform <- getPlatform + hp_usg <- getHpUsage + return (cmmRegOffW platform (hpReg platform) (hpRel (realHp hp_usg) virtual_offset)) + +data FieldOffOrPadding a + = FieldOff (NonVoid a) -- Something that needs an offset. + ByteOff -- Offset in bytes. + | Padding ByteOff -- Length of padding in bytes. + ByteOff -- Offset in bytes. + +-- | Used to tell the various @mkVirtHeapOffsets@ functions what kind +-- of header the object has. This will be accounted for in the +-- offsets of the fields returned. +data ClosureHeader + = NoHeader + | StdHeader + | ThunkHeader + +mkVirtHeapOffsetsWithPadding + :: Profile + -> ClosureHeader -- What kind of header to account for + -> [NonVoid (PrimRep, a)] -- Things to make offsets for + -> ( WordOff -- Total number of words allocated + , WordOff -- Number of words allocated for *pointers* + , [FieldOffOrPadding a] -- Either an offset or padding. + ) + +-- Things with their offsets from start of object in order of +-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER +-- First in list gets lowest offset, which is initial offset + 1. +-- +-- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets +-- than the unboxed things + +mkVirtHeapOffsetsWithPadding profile header things = + ( tot_wds + , bytesToWordsRoundUp platform bytes_of_ptrs + , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad + ) + where + platform = profilePlatform profile + hdr_words = case header of + NoHeader -> 0 + StdHeader -> fixedHdrSizeW profile + ThunkHeader -> thunkHdrSize profile + hdr_bytes = wordsToBytes platform hdr_words + + (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things + + (bytes_of_ptrs, ptrs_w_offsets) = + mapAccumL computeOffset 0 ptrs + (tot_bytes, non_ptrs_w_offsets) = + mapAccumL computeOffset bytes_of_ptrs non_ptrs + + tot_wds = bytesToWordsRoundUp platform tot_bytes + + final_pad_size = tot_wds * word_size - tot_bytes + final_pad + | final_pad_size > 0 = [(Padding final_pad_size + (hdr_bytes + tot_bytes))] + | otherwise = [] + + word_size = platformWordSizeInBytes platform + + computeOffset bytes_so_far nv_thing = + (new_bytes_so_far, with_padding field_off) + where + (rep, thing) = fromNonVoid nv_thing + + -- Size of the field in bytes. + !sizeB = primRepSizeB platform rep + + -- Align the start offset (eg, 2-byte value should be 2-byte aligned). + -- But not more than to a word. + !align = min word_size sizeB + !start = roundUpTo bytes_so_far align + !padding = start - bytes_so_far + + -- Final offset is: + -- size of header + bytes_so_far + padding + !final_offset = hdr_bytes + bytes_so_far + padding + !new_bytes_so_far = start + sizeB + field_off = FieldOff (NonVoid thing) final_offset + + with_padding field_off + | padding == 0 = [field_off] + | otherwise = [ Padding padding (hdr_bytes + bytes_so_far) + , field_off + ] + + +mkVirtHeapOffsets + :: Profile + -> ClosureHeader -- What kind of header to account for + -> [NonVoid (PrimRep,a)] -- Things to make offsets for + -> (WordOff, -- _Total_ number of words allocated + WordOff, -- Number of words allocated for *pointers* + [(NonVoid a, ByteOff)]) +mkVirtHeapOffsets profile header things = + ( tot_wds + , ptr_wds + , [ (field, offset) | (FieldOff field offset) <- things_offsets ] + ) + where + (tot_wds, ptr_wds, things_offsets) = + mkVirtHeapOffsetsWithPadding profile header things + +-- | Just like mkVirtHeapOffsets, but for constructors +mkVirtConstrOffsets + :: Profile -> [NonVoid (PrimRep, a)] + -> (WordOff, WordOff, [(NonVoid a, ByteOff)]) +mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader + +-- | Just like mkVirtConstrOffsets, but used when we don't have the actual +-- arguments. Useful when e.g. generating info tables; we just need to know +-- sizes of pointer and non-pointer fields. +mkVirtConstrSizes :: Profile -> [PrimRep] -> (WordOff, WordOff) +mkVirtConstrSizes profile field_reps + = (tot_wds, ptr_wds) + where + (tot_wds, ptr_wds, _) = + mkVirtConstrOffsets profile + (map (\nv_rep -> NonVoid (nv_rep, ())) field_reps) + +------------------------------------------------------------------------- +-- +-- Making argument descriptors +-- +-- An argument descriptor describes the layout of args on the stack, +-- both for * GC (stack-layout) purposes, and +-- * saving/restoring registers when a heap-check fails +-- +-- Void arguments aren't important, therefore (contrast constructSlowCall) +-- +------------------------------------------------------------------------- + +-- bring in ARG_P, ARG_N, etc. +#include "FunTypes.h" + +mkArgDescr :: Platform -> [Id] -> ArgDescr +mkArgDescr platform args + = let arg_bits = argBits platform arg_reps + arg_reps = filter isNonV (map (idArgRep platform) args) + -- Getting rid of voids eases matching of standard patterns + in case stdPattern arg_reps of + Just spec_id -> ArgSpec spec_id + Nothing -> ArgGen arg_bits + +argBits :: Platform -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits _ [] = [] +argBits platform (P : args) = False : argBits platform args +argBits platform (arg : args) = replicate (argRepSizeW platform arg) True + ++ argBits platform args + +---------------------- +stdPattern :: [ArgRep] -> Maybe Int +stdPattern reps + = case reps of + [] -> Just ARG_NONE -- just void args, probably + [N] -> Just ARG_N + [P] -> Just ARG_P + [F] -> Just ARG_F + [D] -> Just ARG_D + [L] -> Just ARG_L + [V16] -> Just ARG_V16 + [V32] -> Just ARG_V32 + [V64] -> Just ARG_V64 + + [N,N] -> Just ARG_NN + [N,P] -> Just ARG_NP + [P,N] -> Just ARG_PN + [P,P] -> Just ARG_PP + + [N,N,N] -> Just ARG_NNN + [N,N,P] -> Just ARG_NNP + [N,P,N] -> Just ARG_NPN + [N,P,P] -> Just ARG_NPP + [P,N,N] -> Just ARG_PNN + [P,N,P] -> Just ARG_PNP + [P,P,N] -> Just ARG_PPN + [P,P,P] -> Just ARG_PPP + + [P,P,P,P] -> Just ARG_PPPP + [P,P,P,P,P] -> Just ARG_PPPPP + [P,P,P,P,P,P] -> Just ARG_PPPPPP + + _ -> Nothing + +------------------------------------------------------------------------- +-- Amodes for arguments +------------------------------------------------------------------------- + +getArgAmode :: NonVoid StgArg -> FCode CmmExpr +getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var +getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit + +getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] +-- NB: Filters out void args, +-- so the result list may be shorter than the argument list +getNonVoidArgAmodes args = mapM getArgAmode (nonVoidStgArgs args) + +------------------------------------------------------------------------- +-- +-- Generating the info table and code for a closure +-- +------------------------------------------------------------------------- + +-- Here we make an info table of type 'CmmInfo'. The concrete +-- representation as a list of 'CmmAddr' is handled later +-- in the pipeline by 'cmmToRawCmm'. +-- When loading the free variables, a function closure pointer may be tagged, +-- so we must take it into account. + +emitClosureProcAndInfoTable :: Bool -- top-level? + -> Id -- name of the closure + -> LambdaFormInfo + -> CmmInfoTable + -> [NonVoid Id] -- incoming arguments + -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body + -> FCode () +emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body + = do { profile <- getProfile + ; platform <- getPlatform + -- Bind the binder itself, but only if it's not a top-level + -- binding. We need non-top let-bindings to refer to the + -- top-level binding, which this binding would incorrectly shadow. + ; node <- if top_lvl then return $ idToReg platform (NonVoid bndr) + else bindToReg (NonVoid bndr) lf_info + ; let node_points = nodeMustPointToIt profile lf_info + ; arg_regs <- bindArgsToRegs args + ; let args' = if node_points then (node : arg_regs) else arg_regs + conv = if nodeMustPointToIt profile lf_info then NativeNodeCall + else NativeDirectCall + (offset, _, _) = mkCallEntry profile conv args' [] + ; emitClosureAndInfoTable (profilePlatform profile) info_tbl conv args' $ body (offset, node, arg_regs) + } + +-- Data constructors need closures, but not with all the argument handling +-- needed for functions. The shared part goes here. +emitClosureAndInfoTable + :: Platform -> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode () +emitClosureAndInfoTable platform info_tbl conv args body + = do { (_, blks) <- getCodeScoped body + ; let entry_lbl = toEntryLbl platform (cit_lbl info_tbl) + ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks + } diff --git a/GHC/StgToCmm/Lit.hs b/GHC/StgToCmm/Lit.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Lit.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation: literals +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Lit ( + cgLit, mkSimpleLit, + newStringCLit, newByteStringCLit + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Env +import GHC.Cmm +import GHC.Cmm.CLabel +import GHC.Cmm.Utils + +import GHC.Types.Literal +import GHC.Types.RepType( runtimeRepPrimRep ) +import GHC.Builtin.Types ( unitDataConId ) +import GHC.Core.TyCon +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (ord) + +newStringCLit :: String -> FCode CmmLit +-- ^ Make a global definition for the string, +-- and return its label +newStringCLit str = newByteStringCLit (BS8.pack str) + +newByteStringCLit :: ByteString -> FCode CmmLit +newByteStringCLit bytes + = do { uniq <- newUnique + ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes + ; emitDecl decl + ; return lit } + +cgLit :: Literal -> FCode CmmExpr +cgLit (LitString s) = + CmmLit <$> newByteStringCLit s + -- not unpackFS; we want the UTF-8 byte stream. +cgLit (LitRubbish _ rep) = + case expectOnly prim_reps of -- Note [Post-unarisation invariants] + BoxedRep _ -> idInfoToAmode <$> getCgIdInfo unitDataConId + AddrRep -> cgLit LitNullAddr + VecRep n elem -> do + platform <- getPlatform + let elem_lit = mkSimpleLit platform (num_rep_lit (primElemRepToPrimRep elem)) + pure (CmmLit (CmmVec (replicate n elem_lit))) + prep -> cgLit (num_rep_lit prep) + where + prim_reps = runtimeRepPrimRep (text "cgLit") rep + + num_rep_lit IntRep = mkLitIntUnchecked 0 + num_rep_lit Int8Rep = mkLitInt8Unchecked 0 + num_rep_lit Int16Rep = mkLitInt16Unchecked 0 + num_rep_lit Int32Rep = mkLitInt32Unchecked 0 + num_rep_lit Int64Rep = mkLitInt64Unchecked 0 + num_rep_lit WordRep = mkLitWordUnchecked 0 + num_rep_lit Word8Rep = mkLitWord8Unchecked 0 + num_rep_lit Word16Rep = mkLitWord16Unchecked 0 + num_rep_lit Word32Rep = mkLitWord32Unchecked 0 + num_rep_lit Word64Rep = mkLitWord64Unchecked 0 + num_rep_lit FloatRep = LitFloat 0 + num_rep_lit DoubleRep = LitDouble 0 + num_rep_lit other = pprPanic "num_rep_lit: Not a num lit" (ppr other) + +cgLit other_lit = do + platform <- getPlatform + pure (CmmLit (mkSimpleLit platform other_lit)) + +mkSimpleLit :: Platform -> Literal -> CmmLit +mkSimpleLit platform = \case + (LitChar c) -> CmmInt (fromIntegral (ord c)) + (wordWidth platform) + LitNullAddr -> zeroCLit platform + (LitNumber LitNumInt i) -> CmmInt i (wordWidth platform) + (LitNumber LitNumInt8 i) -> CmmInt i W8 + (LitNumber LitNumInt16 i) -> CmmInt i W16 + (LitNumber LitNumInt32 i) -> CmmInt i W32 + (LitNumber LitNumInt64 i) -> CmmInt i W64 + (LitNumber LitNumWord i) -> CmmInt i (wordWidth platform) + (LitNumber LitNumWord8 i) -> CmmInt i W8 + (LitNumber LitNumWord16 i) -> CmmInt i W16 + (LitNumber LitNumWord32 i) -> CmmInt i W32 + (LitNumber LitNumWord64 i) -> CmmInt i W64 + (LitFloat r) -> CmmFloat r W32 + (LitDouble r) -> CmmFloat r W64 + (LitLabel fs fod) + -> let -- TODO: Literal labels might not actually be in the current package... + labelSrc = ForeignLabelInThisPackage + in CmmLabel (mkForeignLabel fs labelSrc fod) + other -> pprPanic "mkSimpleLit" (ppr other) diff --git a/GHC/StgToCmm/Monad.hs b/GHC/StgToCmm/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Monad.hs @@ -0,0 +1,895 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- +-- Monad for Stg to C-- code generation +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Monad ( + FCode, -- type + + initC, initFCodeState, runC, fixC, + newUnique, + + emitLabel, + + emit, emitDecl, + emitProcWithConvention, emitProcWithStackFrame, + emitOutOfLine, emitAssign, emitStore, emitStore', + emitComment, emitTick, emitUnwind, + + newTemp, + + getCmm, aGraphToGraph, getPlatform, getProfile, + getCodeR, getCode, getCodeScoped, getHeapUsage, + getContext, + + mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, + mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto', + + mkCall, mkCmmCall, + + forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly, + + ConTagZ, + + Sequel(..), ReturnKind(..), + withSequel, getSequel, + + SelfLoopInfo(..), + + setTickyCtrLabel, getTickyCtrLabel, + tickScope, getTickScope, + + withUpdFrameOff, getUpdFrameOff, + + HeapUsage(..), VirtualHpOffset, initHpUsage, + getHpUsage, setHpUsage, heapHWM, + setVirtHp, getVirtHp, setRealHp, + + getModuleName, + + -- ideally we wouldn't export these, but some other modules access internal state + getState, setState, getSelfLoop, withSelfLoop, getStgToCmmConfig, + + -- more localised access to monad state + CgIdInfo(..), + getBinds, setBinds, + -- out of general friendliness, we also export ... + StgToCmmConfig(..), CgState(..) -- non-abstract + ) where + +import GHC.Prelude hiding( sequence, succ ) + +import GHC.Platform +import GHC.Platform.Profile +import GHC.Cmm +import GHC.StgToCmm.Config +import GHC.StgToCmm.Closure +import GHC.StgToCmm.Sequel +import GHC.Cmm.Graph as CmmGraph +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Runtime.Heap.Layout +import GHC.Unit +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Data.OrdList +import GHC.Types.Basic( ConTagZ ) +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import qualified GHC.Types.Unique.DSM as DSM ( MonadGetUnique, getUniqueM ) +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Exts (oneShot) + +import Control.Monad +import Data.List (mapAccumL) + + +-------------------------------------------------------- +-- The FCode monad and its types +-- +-- FCode is the monad plumbed through the Stg->Cmm code generator, and +-- the Cmm parser. It contains the following things: +-- +-- - A writer monad, collecting: +-- - code for the current function, in the form of a CmmAGraph. +-- The function "emit" appends more code to this. +-- - the top-level CmmDecls accumulated so far +-- +-- - A state monad with: +-- - the local bindings in scope +-- - the current heap usage +-- - a UniqSupply +-- +-- - A reader monad, for StgToCmmConfig, containing +-- - the profile, +-- - the current Module +-- - the debug level +-- - a bunch of flags see StgToCmm.Config for full details + +-- - A second reader monad with: +-- - the update-frame offset +-- - the ticky counter label +-- - the Sequel (the continuation to return to) +-- - the self-recursive tail call information +-- - The tick scope for new blocks and ticks +-- + +-------------------------------------------------------- + +newtype FCode a = FCode' { doFCode :: StgToCmmConfig -> FCodeState -> CgState -> (a, CgState) } + +-- Not derived because of #18202. +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +instance Functor FCode where + fmap f (FCode m) = + FCode $ \cfg fst state -> + case m cfg fst state of + (x, state') -> (f x, state') + +-- This pattern synonym makes the simplifier monad eta-expand, +-- which as a very beneficial effect on compiler performance +-- See #18202. +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +{-# COMPLETE FCode #-} +pattern FCode :: (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)) + -> FCode a +pattern FCode m <- FCode' m + where + FCode m = FCode' $ oneShot (\cfg -> oneShot + (\fstate -> oneShot + (\state -> m cfg fstate state))) + +instance Applicative FCode where + pure val = FCode (\_cfg _fstate state -> (val, state)) + {-# INLINE pure #-} + (<*>) = ap + +instance Monad FCode where + FCode m >>= k = FCode $ + \cfg fstate state -> + case m cfg fstate state of + (m_result, new_state) -> + case k m_result of + FCode kcode -> kcode cfg fstate new_state + {-# INLINE (>>=) #-} + +instance MonadUnique FCode where + getUniqueSupplyM = cgs_uniqs <$> getState + getUniqueM = FCode $ \_ _ st -> + let (u, us') = takeUniqFromSupply (cgs_uniqs st) + in (u, st { cgs_uniqs = us' }) + +instance DSM.MonadGetUnique FCode where + getUniqueM = GHC.Types.Unique.Supply.getUniqueM + +initC :: IO CgState +initC = do { uniqs <- mkSplitUniqSupply 'c' + ; return (initCgState uniqs) } + +runC :: StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState) +runC cfg fst st fcode = doFCode fcode cfg fst st + +fixC :: (a -> FCode a) -> FCode a +fixC fcode = FCode $ + \cfg fstate state -> + let (v, s) = doFCode (fcode v) cfg fstate state + in (v, s) + +-------------------------------------------------------- +-- The code generator environment +-------------------------------------------------------- +type CgBindings = IdEnv CgIdInfo + +data CgIdInfo + = CgIdInfo + { cg_id :: Id + -- ^ Id that this is the info for + , cg_lf :: LambdaFormInfo + , cg_loc :: CgLoc + -- ^ 'CmmExpr' for the *tagged* value + } + +instance OutputableP Platform CgIdInfo where + pdoc env (CgIdInfo { cg_id = id, cg_loc = loc }) + = ppr id <+> text "-->" <+> pdoc env loc + +-- See Note [sharing continuations] below +data ReturnKind + = AssignedDirectly + | ReturnedTo BlockId ByteOff + +-- Note [sharing continuations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- ReturnKind says how the expression being compiled returned its +-- results: either by assigning directly to the registers specified +-- by the Sequel, or by returning to a continuation that does the +-- assignments. The point of this is we might be able to re-use the +-- continuation in a subsequent heap-check. Consider: +-- +-- case f x of z +-- True -> +-- False -> +-- +-- Naively we would generate +-- +-- R2 = x -- argument to f +-- Sp[young(L1)] = L1 +-- call f returns to L1 +-- L1: +-- z = R1 +-- if (z & 1) then Ltrue else Lfalse +-- Ltrue: +-- Hp = Hp + 24 +-- if (Hp > HpLim) then L4 else L7 +-- L4: +-- HpAlloc = 24 +-- goto L5 +-- L5: +-- R1 = z +-- Sp[young(L6)] = L6 +-- call stg_gc_unpt_r1 returns to L6 +-- L6: +-- z = R1 +-- goto L1 +-- L7: +-- +-- Lfalse: +-- +-- +-- We want the gc call in L4 to return to L1, and discard L6. Note +-- that not only can we share L1 and L6, but the assignment of the +-- return address in L4 is unnecessary because the return address for +-- L1 is already on the stack. We used to catch the sharing of L1 and +-- L6 in the common-block-eliminator, but not the unnecessary return +-- address assignment. +-- +-- Since this case is so common I decided to make it more explicit and +-- robust by programming the sharing directly, rather than relying on +-- the common-block eliminator to catch it. This makes +-- common-block-elimination an optional optimisation, and furthermore +-- generates less code in the first place that we have to subsequently +-- clean up. +-- +-- There are some rarer cases of common blocks that we don't catch +-- this way, but that's ok. Common-block-elimination is still available +-- to catch them when optimisation is enabled. Some examples are: +-- +-- - when both the True and False branches do a heap check, we +-- can share the heap-check failure code L4a and maybe L4 +-- +-- - in a case-of-case, there might be multiple continuations that +-- we can common up. +-- +-- It is always safe to use AssignedDirectly. Expressions that jump +-- to the continuation from multiple places (e.g. case expressions) +-- fall back to AssignedDirectly. +-- + +-------------------------------------------------------- +-- The code generator state +-------------------------------------------------------- + +data CgState + = MkCgState { + cgs_stmts :: CmmAGraph, -- Current procedure + + cgs_tops :: OrdList DCmmDecl, + -- Other procedures and data blocks in this compilation unit + -- Both are ordered only so that we can + -- reduce forward references, when it's easy to do so + + cgs_binds :: CgBindings, + + cgs_hp_usg :: HeapUsage, + + cgs_uniqs :: UniqSupply } +-- If you are wondering why you have to be careful forcing CgState then +-- the reason is the knot-tying in 'getHeapUsage'. This problem is tracked +-- in #19245 + +data FCodeState = + MkFCodeState { fcs_upframeoffset :: UpdFrameOffset -- ^ Size of current update frame UpdFrameOffset must be kept lazy or + -- else the RTS will deadlock _and_ also experience a severe + -- performance degradation + , fcs_sequel :: !Sequel -- ^ What to do at end of basic block + , fcs_selfloop :: !(Maybe SelfLoopInfo) -- ^ Which tail calls can be compiled as local jumps? + -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr + , fcs_ticky :: !CLabel -- ^ Destination for ticky counts + , fcs_tickscope :: !CmmTickScope -- ^ Tick scope for new blocks & ticks + } + +data HeapUsage -- See Note [Virtual and real heap pointers] + = HeapUsage { + virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word + -- Incremented whenever we allocate + realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr + -- Used in instruction addressing modes + } + +type VirtualHpOffset = WordOff + + +{- Note [Virtual and real heap pointers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The code generator can allocate one or more objects contiguously, performing +one heap check to cover allocation of all the objects at once. Let's call +this little chunk of heap space an "allocation chunk". The code generator +will emit code to + * Perform a heap-exhaustion check + * Move the heap pointer to the end of the allocation chunk + * Allocate multiple objects within the chunk + +The code generator uses VirtualHpOffsets to address words within a +single allocation chunk; these start at one and increase positively. +The first word of the chunk has VirtualHpOffset=1, the second has +VirtualHpOffset=2, and so on. + + * The field realHp tracks (the VirtualHpOffset) where the real Hp + register is pointing. Typically it'll be pointing to the end of the + allocation chunk. + + * The field virtHp gives the VirtualHpOffset of the highest-allocated + word so far. It starts at zero (meaning no word has been allocated), + and increases whenever an object is allocated. + +The difference between realHp and virtHp gives the offset from the +real Hp register of a particular word in the allocation chunk. This +is what getHpRelOffset does. Since the returned offset is relative +to the real Hp register, it is valid only until you change the real +Hp register. (Changing virtHp doesn't matter.) +-} + + +initCgState :: UniqSupply -> CgState +initCgState uniqs + = MkCgState { cgs_stmts = mkNop + , cgs_tops = nilOL + , cgs_binds = emptyVarEnv + , cgs_hp_usg = initHpUsage + , cgs_uniqs = uniqs } + +stateIncUsage :: CgState -> CgState -> CgState +-- stateIncUsage@ e1 e2 incorporates in e1 +-- the heap high water mark found in e2. +stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg }) + = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg } + `addCodeBlocksFrom` s2 + +addCodeBlocksFrom :: CgState -> CgState -> CgState +-- Add code blocks from the latter to the former +-- (The cgs_stmts will often be empty, but not always; see codeOnly) +s1 `addCodeBlocksFrom` s2 + = s1 { cgs_stmts = cgs_stmts s1 CmmGraph.<*> cgs_stmts s2, + cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 } + +-- The heap high water mark is the larger of virtHp and hwHp. The latter is +-- only records the high water marks of forked-off branches, so to find the +-- heap high water mark you have to take the max of virtHp and hwHp. Remember, +-- virtHp never retreats! +-- +-- Note Jan 04: ok, so why do we only look at the virtual Hp?? + +heapHWM :: HeapUsage -> VirtualHpOffset +heapHWM = virtHp + +initHpUsage :: HeapUsage +initHpUsage = HeapUsage { virtHp = 0, realHp = 0 } + +maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage +hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw } + +-------------------------------------------------------- +-- Operators for getting and setting the state and "stgToCmmConfig". +-------------------------------------------------------- + +getState :: FCode CgState +getState = FCode $ \_cfg _fstate state -> (state, state) + +setState :: CgState -> FCode () +setState state = FCode $ \_cfg _fstate _ -> ((), state) + +getHpUsage :: FCode HeapUsage +getHpUsage = do + state <- getState + return $ cgs_hp_usg state + +setHpUsage :: HeapUsage -> FCode () +setHpUsage new_hp_usg = do + state <- getState + setState $ state {cgs_hp_usg = new_hp_usg} + +setVirtHp :: VirtualHpOffset -> FCode () +setVirtHp new_virtHp + = do { hp_usage <- getHpUsage + ; setHpUsage (hp_usage {virtHp = new_virtHp}) } + +getVirtHp :: FCode VirtualHpOffset +getVirtHp + = do { hp_usage <- getHpUsage + ; return (virtHp hp_usage) } + +setRealHp :: VirtualHpOffset -> FCode () +setRealHp new_realHp + = do { hp_usage <- getHpUsage + ; setHpUsage (hp_usage {realHp = new_realHp}) } + +getBinds :: FCode CgBindings +getBinds = do + state <- getState + return $ cgs_binds state + +setBinds :: CgBindings -> FCode () +setBinds new_binds = do + state <- getState + setState $ state {cgs_binds = new_binds} + +withCgState :: FCode a -> CgState -> FCode (a,CgState) +withCgState (FCode fcode) newstate = FCode $ \cfg fstate state -> + case fcode cfg fstate newstate of + (retval, state2) -> ((retval,state2), state) + +newUniqSupply :: FCode UniqSupply +newUniqSupply = do + state <- getState + let (us1, us2) = splitUniqSupply (cgs_uniqs state) + setState $ state { cgs_uniqs = us1 } + return us2 + +newUnique :: FCode Unique +newUnique = do + state <- getState + let (u,us') = takeUniqFromSupply (cgs_uniqs state) + setState $ state { cgs_uniqs = us' } + return u + +newTemp :: DSM.MonadGetUnique m => CmmType -> m LocalReg +newTemp rep = do { uniq <- DSM.getUniqueM + ; return (LocalReg uniq rep) } + +------------------ +initFCodeState :: Platform -> FCodeState +initFCodeState p = + MkFCodeState { fcs_upframeoffset = platformWordSizeInBytes p + , fcs_sequel = Return + , fcs_selfloop = Nothing + , fcs_ticky = mkTopTickyCtrLabel + , fcs_tickscope = GlobalScope + } + +getFCodeState :: FCode FCodeState +getFCodeState = FCode $ \_ fstate state -> (fstate,state) + +-- basically local for the reader monad +withFCodeState :: FCode a -> FCodeState -> FCode a +withFCodeState (FCode fcode) fst = FCode $ \cfg _ state -> fcode cfg fst state + +getSelfLoop :: FCode (Maybe SelfLoopInfo) +getSelfLoop = fcs_selfloop <$> getFCodeState + +withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a +withSelfLoop self_loop code = do + fstate <- getFCodeState + withFCodeState code (fstate {fcs_selfloop = Just self_loop}) + +-- ---------------------------------------------------------------------------- +-- Get/set the end-of-block info + +withSequel :: Sequel -> FCode a -> FCode a +withSequel sequel code + = do { fstate <- getFCodeState + ; withFCodeState code (fstate { fcs_sequel = sequel + , fcs_selfloop = Nothing }) } + +getSequel :: FCode Sequel +getSequel = fcs_sequel <$> getFCodeState + +-- ---------------------------------------------------------------------------- +-- Get/set the size of the update frame + +-- We keep track of the size of the update frame so that we +-- can set the stack pointer to the proper address on return +-- (or tail call) from the closure. +-- There should be at most one update frame for each closure. +-- Note: I'm including the size of the original return address +-- in the size of the update frame -- hence the default case on `get'. + +withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a +withUpdFrameOff size code + = do { fstate <- getFCodeState + ; withFCodeState code (fstate {fcs_upframeoffset = size }) } + +getUpdFrameOff :: FCode UpdFrameOffset +getUpdFrameOff = fcs_upframeoffset <$> getFCodeState + +-- ---------------------------------------------------------------------------- +-- Get/set the current ticky counter label + +getTickyCtrLabel :: FCode CLabel +getTickyCtrLabel = fcs_ticky <$> getFCodeState + +setTickyCtrLabel :: CLabel -> FCode a -> FCode a +setTickyCtrLabel ticky code = do + fstate <- getFCodeState + withFCodeState code (fstate {fcs_ticky = ticky}) + +-- ---------------------------------------------------------------------------- +-- Manage tick scopes + +-- | The current tick scope. We will assign this to generated blocks. +getTickScope :: FCode CmmTickScope +getTickScope = fcs_tickscope <$> getFCodeState + +-- | Places blocks generated by the given code into a fresh +-- (sub-)scope. This will make sure that Cmm annotations in our scope +-- will apply to the Cmm blocks generated therein - but not the other +-- way around. +tickScope :: FCode a -> FCode a +tickScope code = do + cfg <- getStgToCmmConfig + fstate <- getFCodeState + if not $ stgToCmmEmitDebugInfo cfg then code else do + u <- newUnique + let scope' = SubScope u (fcs_tickscope fstate) + withFCodeState code fstate{ fcs_tickscope = scope' } + +-- ---------------------------------------------------------------------------- +-- Config related helpers + +getStgToCmmConfig :: FCode StgToCmmConfig +getStgToCmmConfig = FCode $ \cfg _ state -> (cfg,state) + +getProfile :: FCode Profile +getProfile = stgToCmmProfile <$> getStgToCmmConfig + +getPlatform :: FCode Platform +getPlatform = profilePlatform <$> getProfile + +getContext :: FCode SDocContext +getContext = stgToCmmContext <$> getStgToCmmConfig + +-- ---------------------------------------------------------------------------- +-- Get the current module name + +getModuleName :: FCode Module +getModuleName = stgToCmmThisModule <$> getStgToCmmConfig + + +-------------------------------------------------------- +-- Forking +-------------------------------------------------------- + +forkClosureBody :: FCode () -> FCode () +-- forkClosureBody compiles body_code in environment where: +-- - sequel, update stack frame and self loop info are +-- set to fresh values +-- - state is set to a fresh value, except for local bindings +-- that are passed in unchanged. It's up to the enclosed code to +-- re-bind the free variables to a field of the closure. + +forkClosureBody body_code + = do { platform <- getPlatform + ; cfg <- getStgToCmmConfig + ; fstate <- getFCodeState + ; us <- newUniqSupply + ; state <- getState + ; let fcs = fstate { fcs_sequel = Return + , fcs_upframeoffset = platformWordSizeInBytes platform + , fcs_selfloop = Nothing + } + fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + ((),fork_state_out) = doFCode body_code cfg fcs fork_state_in + ; setState $ state `addCodeBlocksFrom` fork_state_out } + +forkLneBody :: FCode a -> FCode a +-- 'forkLneBody' takes a body of let-no-escape binding and compiles +-- it in the *current* environment, returning the graph thus constructed. +-- +-- The current environment is passed on completely unchanged to +-- the successor. In particular, any heap usage from the enclosed +-- code is discarded; it should deal with its own heap consumption. +forkLneBody body_code + = do { cfg <- getStgToCmmConfig + ; us <- newUniqSupply + ; state <- getState + ; fstate <- getFCodeState + ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + (result, fork_state_out) = doFCode body_code cfg fstate fork_state_in + ; setState $ state `addCodeBlocksFrom` fork_state_out + ; return result } + +codeOnly :: FCode () -> FCode () +-- Emit any code from the inner thing into the outer thing +-- Do not affect anything else in the outer state +-- Used in almost-circular code to prevent false loop dependencies +codeOnly body_code + = do { cfg <- getStgToCmmConfig + ; us <- newUniqSupply + ; state <- getState + ; fstate <- getFCodeState + ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state + , cgs_hp_usg = cgs_hp_usg state } + ((), fork_state_out) = doFCode body_code cfg fstate fork_state_in + ; setState $ state `addCodeBlocksFrom` fork_state_out } + +forkAlts :: [FCode a] -> FCode [a] +-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and +-- an fcode for the default case 'd', and compiles each in the current +-- environment. The current environment is passed on unmodified, except +-- that the virtual Hp is moved on to the worst virtual Hp for the branches + +forkAlts branch_fcodes + = do { cfg <- getStgToCmmConfig + ; us <- newUniqSupply + ; state <- getState + ; fstate <- getFCodeState + ; let compile us branch + = (us2, doFCode branch cfg fstate branch_state) + where + (us1,us2) = splitUniqSupply us + branch_state = (initCgState us1) { + cgs_binds = cgs_binds state + , cgs_hp_usg = cgs_hp_usg state } + (_us, results) = mapAccumL compile us branch_fcodes + (branch_results, branch_out_states) = unzip results + ; setState $ foldl' stateIncUsage state branch_out_states + -- NB foldl. state is the *left* argument to stateIncUsage + ; return branch_results } + +forkAltPair :: FCode a -> FCode a -> FCode (a,a) +-- Most common use of 'forkAlts'; having this helper function avoids +-- accidental use of failible pattern-matches in @do@-notation +forkAltPair x y = do + xy' <- forkAlts [x,y] + case xy' of + [x',y'] -> return (x',y') + _ -> panic "forkAltPair" + +-- collect the code emitted by an FCode computation +getCodeR :: FCode a -> FCode (a, CmmAGraph) +getCodeR fcode + = do { state1 <- getState + ; (a, state2) <- withCgState fcode (state1 { cgs_stmts = mkNop }) + ; setState $ state2 { cgs_stmts = cgs_stmts state1 } + ; return (a, cgs_stmts state2) } + +getCode :: FCode a -> FCode CmmAGraph +getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts } + +-- | Generate code into a fresh tick (sub-)scope and gather generated code +getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped) +getCodeScoped fcode + = do { state1 <- getState + ; ((a, tscope), state2) <- + tickScope $ + flip withCgState state1 { cgs_stmts = mkNop } $ + do { a <- fcode + ; scp <- getTickScope + ; return (a, scp) } + ; setState $ state2 { cgs_stmts = cgs_stmts state1 } + ; return (a, (cgs_stmts state2, tscope)) } + + +-- 'getHeapUsage' applies a function to the amount of heap that it uses. +-- It initialises the heap usage to zeros, and passes on an unchanged +-- heap usage. +-- +-- It is usually a prelude to performing a GC check, so everything must +-- be in a tidy and consistent state. +-- +-- Note the slightly subtle fixed point behaviour needed here + +getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a +getHeapUsage fcode + = do { cfg <- getStgToCmmConfig + ; state <- getState + ; fcstate <- getFCodeState + ; let fstate_in = state { cgs_hp_usg = initHpUsage } + (r, fstate_out) = doFCode (fcode hp_hw) cfg fcstate fstate_in + hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here! + + ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state } + ; return r } + +-- ---------------------------------------------------------------------------- +-- Combinators for emitting code + +emitCgStmt :: CgStmt -> FCode () +emitCgStmt stmt + = do { state <- getState + ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } + } + +emitLabel :: BlockId -> FCode () +emitLabel id = do tscope <- getTickScope + emitCgStmt (CgLabel id tscope) + +emitComment :: FastString -> FCode () +emitComment s + | debugIsOn = emitCgStmt (CgStmt (CmmComment s)) + | otherwise = return () + +emitTick :: CmmTickish -> FCode () +emitTick = emitCgStmt . CgStmt . CmmTick + +emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode () +emitUnwind regs = do + debug <- stgToCmmEmitDebugInfo <$> getStgToCmmConfig + when debug $ + emitCgStmt $ CgStmt $ CmmUnwind regs + +emitAssign :: CmmReg -> CmmExpr -> FCode () +emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r)) + +-- | Assumes natural alignment. +emitStore :: CmmExpr -> CmmExpr -> FCode () +emitStore = emitStore' NaturallyAligned + +emitStore' :: AlignmentSpec -> CmmExpr -> CmmExpr -> FCode () +emitStore' alignment l r = emitCgStmt (CgStmt (CmmStore l r alignment)) + +emit :: CmmAGraph -> FCode () +emit ag + = do { state <- getState + ; setState $ state { cgs_stmts = cgs_stmts state CmmGraph.<*> ag } } + +emitDecl :: DCmmDecl -> FCode () +emitDecl decl + = do { state <- getState + ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } } + +emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode () +emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope) + +emitProcWithStackFrame + :: Convention -- entry convention + -> Maybe CmmInfoTable -- info table? + -> CLabel -- label for the proc + -> [CmmFormal] -- stack frame + -> [CmmFormal] -- arguments + -> CmmAGraphScoped -- code + -> Bool -- do stack layout? + -> FCode () + +emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False + = do { platform <- getPlatform + ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth platform)) False + } +emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True + -- do layout + = do { profile <- getProfile + ; let (offset, live, entry) = mkCallEntry profile conv args stk_args + graph' = entry CmmGraph.<*> graph + ; emitProc mb_info lbl live (graph', tscope) offset True + } +emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame" + +emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel + -> [CmmFormal] + -> CmmAGraphScoped + -> FCode () +emitProcWithConvention conv mb_info lbl args blocks + = emitProcWithStackFrame conv mb_info lbl [] args blocks True + +emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalRegUse] -> CmmAGraphScoped + -> Int -> Bool -> FCode () +emitProc mb_info lbl live blocks offset do_layout + = do { l <- newBlockId + ; let + blks :: DCmmGraph + blks = labelAGraph l blocks + + infos | Just info <- mb_info = [((g_entry blks), info)] + | otherwise = [] + + sinfo = StackInfo { arg_space = offset + , do_layout = do_layout } + + tinfo = TopInfo { info_tbls = DWrap infos + , stack_info=sinfo} + + -- we must be careful to: + -- 1. not emit a proc label twice (#22792) + -- 2. emit it at least once! (#25565) + -- + -- (2) happened because the entry label was the label of a basic + -- block that got dropped (empty basic block...), hence we never + -- generated a label for it after we fixed (1) where we were + -- always emitting entry label. + proc_lbl = toProcDelimiterLbl lbl + + proc_block = CmmProc tinfo proc_lbl live blks + + ; state <- getState + ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } + +getCmm :: FCode a -> FCode (a, DCmmGroup) +-- Get all the CmmTops (there should be no stmts) +-- Return a single Cmm which may be split from other Cmms by +-- object splitting (at a later stage) +getCmm code + = do { state1 <- getState + ; (a, state2) <- withCgState code (state1 { cgs_tops = nilOL }) + ; setState $ state2 { cgs_tops = cgs_tops state1 } + ; return (a, fromOL (cgs_tops state2)) } + + +mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph +mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing + +mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph + -> Maybe Bool -> FCode CmmAGraph +mkCmmIfThenElse' e tbranch fbranch likely = do + tscp <- getTickScope + endif <- newBlockId + tid <- newBlockId + fid <- newBlockId + + let + (test, then_, else_, likely') = case likely of + Just False | Just e' <- maybeInvertCmmExpr e + -- currently NCG doesn't know about likely + -- annotations. We manually switch then and + -- else branch so the likely false branch + -- becomes a fallthrough. + -> (e', fbranch, tbranch, Just True) + _ -> (e, tbranch, fbranch, likely) + + return $ catAGraphs [ mkCbranch test tid fid likely' + , mkLabel tid tscp, then_, mkBranch endif + , mkLabel fid tscp, else_, mkLabel endif tscp ] + +mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph +mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing + +mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph +mkCmmIfGoto' e tid l = do + endif <- newBlockId + tscp <- getTickScope + return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ] + +mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph +mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing + +mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph +mkCmmIfThen' e tbranch l = do + endif <- newBlockId + tid <- newBlockId + tscp <- getTickScope + return $ catAGraphs [ mkCbranch e tid endif l + , mkLabel tid tscp, tbranch, mkLabel endif tscp ] + +mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr] + -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph +mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do + profile <- getProfile + k <- newBlockId + tscp <- getTickScope + let area = Young k + (off, _, copyin) = copyInOflow profile retConv area results [] + copyout = mkCallReturnsTo profile f callConv actuals k off updfr_off extra_stack + return $ catAGraphs [copyout, mkLabel k tscp, copyin] + +mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset + -> FCode CmmAGraph +mkCmmCall f results actuals updfr_off + = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off [] + + +-- ---------------------------------------------------------------------------- +-- turn CmmAGraph into CmmGraph, for making a new proc. + +aGraphToGraph :: CmmAGraphScoped -> FCode DCmmGraph +aGraphToGraph stmts + = do { l <- newBlockId + ; return (labelAGraph l stmts) } diff --git a/GHC/StgToCmm/Prim.hs b/GHC/StgToCmm/Prim.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Prim.hs @@ -0,0 +1,3755 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +---------------------------------------------------------------------------- +-- +-- Stg to C--: primitive operations +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Prim ( + cgOpApp, + shouldInlinePrimOp + ) where + +import GHC.Prelude hiding ((<*>)) + +import GHC.Platform +import GHC.Platform.Profile + +import GHC.StgToCmm.Config +import GHC.StgToCmm.Layout +import GHC.StgToCmm.Foreign +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Ticky +import GHC.StgToCmm.Heap +import GHC.StgToCmm.Prof ( costCentreFrom ) + +import GHC.Types.Basic +import GHC.Cmm.BlockId +import GHC.Cmm.Graph +import GHC.Stg.Syntax +import GHC.Cmm +import GHC.Unit ( rtsUnit ) +import GHC.Core.Type ( Type, tyConAppTyCon_maybe ) +import GHC.Core.TyCon +import GHC.Cmm.CLabel +import GHC.Cmm.Info ( closureInfoPtr ) +import GHC.Cmm.Utils +import GHC.Builtin.PrimOps +import GHC.Runtime.Heap.Layout +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Utils.Panic +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe + +import Control.Monad (liftM, when, unless, zipWithM_) +import GHC.Utils.Outputable + +------------------------------------------------------------------------ +-- Primitive operations and foreign calls +------------------------------------------------------------------------ + +{- Note [Foreign call results] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A foreign call always returns an unboxed tuple of results, one +of which is the state token. This seems to happen even for pure +calls. + +Even if we returned a single result for pure calls, it'd still be +right to wrap it in a singleton unboxed tuple, because the result +might be a Haskell closure pointer, we don't want to evaluate it. -} + +---------------------------------- +cgOpApp :: StgOp -- The op + -> [StgArg] -- Arguments + -> Type -- Result type (always an unboxed tuple) + -> FCode ReturnKind + +-- Foreign calls +cgOpApp (StgFCallOp fcall ty) stg_args res_ty + = cgForeignCall fcall ty stg_args res_ty + -- See Note [Foreign call results] + +cgOpApp (StgPrimOp primop) args res_ty = do + cfg <- getStgToCmmConfig + cmm_args <- getNonVoidArgAmodes args + cmmPrimOpApp cfg primop cmm_args (Just res_ty) + +cgOpApp (StgPrimCallOp primcall) args _res_ty + = do { cmm_args <- getNonVoidArgAmodes args + ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) + ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } + +cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind +cmmPrimOpApp cfg primop cmm_args mres_ty = + case emitPrimOp cfg primop cmm_args of + PrimopCmmEmit_Internal f -> + let + -- if the result type isn't explicitly given, we directly use the + -- result type of the primop. + res_ty = fromMaybe (primOpResultType primop) mres_ty + in emitReturn =<< f res_ty + PrimopCmmEmit_External -> do + let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) + emitCall (NativeNodeCall, NativeReturn) fun cmm_args + + +-- | Interpret the argument as an unsigned value, assuming the value +-- is given in two-complement form in the given width. +-- +-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615. +-- +-- This function is used to work around the fact that many array +-- primops take Int# arguments, but we interpret them as unsigned +-- quantities in the code gen. This means that we have to be careful +-- every time we work on e.g. a CmmInt literal that corresponds to the +-- array size, as it might contain a negative Integer value if the +-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int# +-- literal. +asUnsigned :: Width -> Integer -> Integer +asUnsigned w n = n .&. (bit (widthInBits w) - 1) + +------------------------------------------------------------------------ +-- Emitting code for a primop +------------------------------------------------------------------------ + +shouldInlinePrimOp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Bool +shouldInlinePrimOp cfg op args = case emitPrimOp cfg op args of + PrimopCmmEmit_External -> False + PrimopCmmEmit_Internal _ -> True + +-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use +-- ByteOff (or some other fixed width signed type) to represent +-- array sizes or indices. This means that these will overflow for +-- large enough sizes. + +-- TODO: Several primops, such as 'copyArray#', only have an inline +-- implementation (below) but could possibly have both an inline +-- implementation and an out-of-line implementation, just like +-- 'newArray#'. This would lower the amount of code generated, +-- hopefully without a performance impact (needs to be measured). + +-- | The big function handling all the primops. +-- +-- In the simple case, there is just one implementation, and we emit that. +-- +-- In more complex cases, there is a foreign call (out of line) fallback. This +-- might happen e.g. if there's enough static information, such as statically +-- known arguments. +emitPrimOp + :: StgToCmmConfig + -> PrimOp -- ^ The primop + -> [CmmExpr] -- ^ The primop arguments + -> PrimopCmmEmit +emitPrimOp cfg primop = + let max_inl_alloc_size = fromIntegral (stgToCmmMaxInlAllocSize cfg) + in case primop of + NewByteArrayOp_Char -> \case + [(CmmLit (CmmInt n w))] + | asUnsigned w n <= max_inl_alloc_size + -> opIntoRegs $ \ [res] -> doNewByteArrayOp res (fromInteger n) + _ -> PrimopCmmEmit_External + + NewArrayOp -> \case + [(CmmLit (CmmInt n w)), init] + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size + -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel + [ (mkIntExpr platform (fromInteger n), + fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)) + , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))), + fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform)) + ] + (fromInteger n) init + _ -> PrimopCmmEmit_External + + CopyArrayOp -> \case + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> + opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CopyMutableArrayOp -> \case + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> + opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CloneArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size + -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CloneMutableArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size + -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + FreezeArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size + -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + ThawArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size + -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + NewSmallArrayOp -> \case + [(CmmLit (CmmInt n w)), init] + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size + -> opIntoRegs $ \ [res] -> + doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel + [ (mkIntExpr platform (fromInteger n), + fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) + ] + (fromInteger n) init + _ -> PrimopCmmEmit_External + + CopySmallArrayOp -> \case + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> + opIntoRegs $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CopySmallMutableArrayOp -> \case + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> + opIntoRegs $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CloneSmallArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size + -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CloneSmallMutableArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size + -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + FreezeSmallArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size + -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + ThawSmallArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size + -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + +-- First we handle various awkward cases specially. + + ParOp -> \[arg] -> opIntoRegs $ \[res] -> + -- for now, just implement this in a C function + -- later, we might want to inline it. + emitCCall + [(res,NoHint)] + (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") ForeignLabelInExternalPackage IsFunction))) + [(baseExpr platform, AddrHint), (arg,AddrHint)] + + SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do + -- returns the value of arg in res. We're going to therefore + -- refer to arg twice (once to pass to newSpark(), and once to + -- assign to res), so put it in a temporary. + tmp <- assignTemp arg + tmp2 <- newTemp (bWord platform) + emitCCall + [(tmp2,NoHint)] + (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") ForeignLabelInExternalPackage IsFunction))) + [(baseExpr platform, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] + emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) + + GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do + let + val + | profileIsProfiling profile = costCentreFrom platform (cmmUntag platform arg) + | otherwise = CmmLit (zeroCLit platform) + emitAssign (CmmLocal res) val + + GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) (cccsExpr platform) + + MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) (currentTSOExpr platform) + + ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_AtomicRead (wordWidth platform) MemOrderAcquire) + [ cmmOffsetW platform mutv (fixedHdrSizeW profile) ] + + WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \[] -> do + old_val <- CmmLocal <$> newTemp (cmmExprType platform var) + emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) + + -- Without this write barrier, other CPUs may see this pointer before + -- the writes for the closure it points to have occurred. + -- Note that this also must come after we read the old value to ensure + -- that the read of old_val comes before another core's write to the + -- MutVar's value. + emitPrimCall [] (MO_AtomicWrite (wordWidth platform) MemOrderRelease) + [ cmmOffsetW platform mutv (fixedHdrSizeW profile), var ] + emitDirtyMutVar mutv (CmmReg old_val) + + AtomicSwapMutVarOp -> \[mutv, val] -> opIntoRegs $ \[res] -> do + let dst = cmmOffsetW platform mutv (fixedHdrSizeW profile) + emitPrimCall [res] (MO_Xchg (wordWidth platform)) [dst, val] + emitDirtyMutVar mutv (CmmReg (CmmLocal res)) + +-- #define sizzeofByteArrayzh(r,a) \ +-- r = ((StgArrBytes *)(a))->bytes + SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) (byteArraySize platform profile arg) + +-- #define sizzeofMutableByteArrayzh(r,a) \ +-- r = ((StgArrBytes *)(a))->bytes + SizeofMutableByteArrayOp -> emitPrimOp cfg SizeofByteArrayOp + +-- #define getSizzeofMutableByteArrayzh(r,a) \ +-- r = ((StgArrBytes *)(a))->bytes + GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) (byteArraySize platform profile arg) + + +-- #define touchzh(o) /* nothing */ + TouchOp -> \args@[_] -> opIntoRegs $ \res@[] -> + emitPrimCall res MO_Touch args + +-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) + ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile)) + +-- #define mutableByteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) + MutableByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile)) + +-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) + StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) + + EqStablePtrOp -> opTranslate (mo_wordEq platform) + + ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) + +-- #define addrToHValuezh(r,a) r=(P_)a + AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) arg + +-- #define hvalueToAddrzh(r, a) r=(W_)a + AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) arg + +{- Freezing arrays-of-ptrs requires changing an info table, for the + benefit of the generational collector. It needs to scavenge mutable + objects, even if they are in old space. When they become immutable, + they can be removed from this scavenge list. -} + +-- #define unsafeFreezzeArrayzh(r,a) +-- { +-- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info); +-- r = a; +-- } + UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + emit $ catAGraphs + [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), + mkAssign (CmmLocal res) arg ] + UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + emit $ catAGraphs + [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)), + mkAssign (CmmLocal res) arg ] + +-- #define unsafeFreezzeByteArrayzh(r,a) r=(a) + UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) arg + +-- #define unsafeThawByteArrayzh(r,a) r=(a) + UnsafeThawByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) arg + +-- Reading/writing pointer arrays + + ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + doReadPtrArrayOp res obj ix + IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + doReadPtrArrayOp res obj ix + WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> + doWritePtrArrayOp obj ix v + + ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + doReadSmallPtrArrayOp res obj ix + IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + doReadSmallPtrArrayOp res obj ix + WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] -> + doWriteSmallPtrArrayOp obj ix v + +-- Getting the size of pointer arrays + + SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) (ptrArraySize platform profile arg) + SizeofMutableArrayOp -> emitPrimOp cfg SizeofArrayOp + SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> + emitAssign (CmmLocal res) (smallPtrArraySize platform profile arg) + + SizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp + GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp + +-- IndexXXXoffAddr + + IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args + IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args + IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing (bWord platform) res args + IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing (bWord platform) res args + IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing (bWord platform) res args + IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing f32 res args + IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing f64 res args + IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing (bWord platform) res args + IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b8 res args + IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b16 res args + IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b32 res args + IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b64 res args + IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b8 res args + IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b16 res args + IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b32 res args + IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b64 res args + +-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. + + ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args + ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args + ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing (bWord platform) res args + ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing (bWord platform) res args + ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing (bWord platform) res args + ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing f32 res args + ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing f64 res args + ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing (bWord platform) res args + ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b8 res args + ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b16 res args + ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b32 res args + ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b64 res args + ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b8 res args + ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b16 res args + ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b32 res args + ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOp Nothing b64 res args + +-- IndexWord8OffAddrAsXXX + + IndexOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args + IndexOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args + IndexOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + IndexOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + IndexOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + IndexOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing f32 b8 res args + IndexOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing f64 b8 res args + IndexOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + IndexOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b16 b8 res args + IndexOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b32 b8 res args + IndexOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b64 b8 res args + IndexOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b16 b8 res args + IndexOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b32 b8 res args + IndexOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b64 b8 res args + +-- ReadWord8OffAddrAsXXX, identical to IndexWord8OffAddrAsXXX + + ReadOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args + ReadOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args + ReadOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + ReadOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + ReadOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + ReadOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing f32 b8 res args + ReadOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing f64 b8 res args + ReadOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + ReadOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b16 b8 res args + ReadOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b32 b8 res args + ReadOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b64 b8 res args + ReadOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b16 b8 res args + ReadOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b32 b8 res args + ReadOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b64 b8 res args + +-- WriteWord8ArrayAsXXX + WriteOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args + WriteOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp (Just (mo_WordTo32 platform)) b8 res args + WriteOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + +-- IndexXXXArray + + IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args + IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args + IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing (bWord platform) res args + IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing (bWord platform) res args + IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing (bWord platform) res args + IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing f32 res args + IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing f64 res args + IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing (bWord platform) res args + IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b8 res args + IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b16 res args + IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b32 res args + IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b64 res args + IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b8 res args + IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b16 res args + IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b32 res args + IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b64 res args + +-- ReadXXXArray, identical to IndexXXXArray. + + ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args + ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args + ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing (bWord platform) res args + ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing (bWord platform) res args + ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing (bWord platform) res args + ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing f32 res args + ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing f64 res args + ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing (bWord platform) res args + ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b8 res args + ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b16 res args + ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b32 res args + ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b64 res args + ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b8 res args + ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b16 res args + ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b32 res args + ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOp Nothing b64 res args + +-- IndexWord8ArrayAsXXX + + IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args + IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args + IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing f32 b8 res args + IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing f64 b8 res args + IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b16 b8 res args + IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b32 b8 res args + IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b64 b8 res args + IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b16 b8 res args + IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b32 b8 res args + IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b64 b8 res args + +-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX + + ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args + ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args + ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing f32 b8 res args + ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing f64 b8 res args + ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b16 b8 res args + ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b32 b8 res args + ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b64 b8 res args + ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b16 b8 res args + ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b32 b8 res args + ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + doIndexByteArrayOpAs Nothing b64 b8 res args + +-- WriteXXXoffAddr + + WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args + WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args + WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing (bWord platform) res args + WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing (bWord platform) res args + WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing (bWord platform) res args + WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing f32 res args + WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing f64 res args + WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing (bWord platform) res args + WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b16 res args + WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b32 res args + WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b64 res args + WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b16 res args + WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b32 res args + WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b64 res args + +-- WriteXXXArray + + WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args + WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args + WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing (bWord platform) res args + WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing (bWord platform) res args + WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing (bWord platform) res args + WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing f32 res args + WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing f64 res args + WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing (bWord platform) res args + WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b16 res args + WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b32 res args + WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b64 res args + WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b16 res args + WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b32 res args + WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b64 res args + +-- WriteInt8ArrayAsXXX + + WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args + WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args + WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + doWriteByteArrayOp Nothing b8 res args + +-- Copying and setting byte arrays + CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> + doCopyByteArrayOp src src_off dst dst_off n + CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> + doCopyMutableByteArrayOp src src_off dst dst_off n + CopyMutableByteArrayNonOverlappingOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> + doCopyMutableByteArrayNonOverlappingOp src src_off dst dst_off n + CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> + doCopyByteArrayToAddrOp src src_off dst n + CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> + doCopyMutableByteArrayToAddrOp src src_off dst n + CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] -> + doCopyAddrToByteArrayOp src dst dst_off n + CopyAddrToAddrOp -> \[src,dst,n] -> opIntoRegs $ \[] -> + doCopyAddrToAddrOp src dst n + CopyAddrToAddrNonOverlappingOp -> \[src,dst,n] -> opIntoRegs $ \[] -> + doCopyAddrToAddrNonOverlappingOp src dst n + SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] -> + doSetByteArrayOp ba off len c + SetAddrRangeOp -> \[dst,len,c] -> opIntoRegs $ \[] -> + doSetAddrRangeOp dst len c + +-- Comparing byte arrays + CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] -> + doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n + + BSwap16Op -> \[w] -> opIntoRegs $ \[res] -> + emitBSwapCall res w W16 + BSwap32Op -> \[w] -> opIntoRegs $ \[res] -> + emitBSwapCall res w W32 + BSwap64Op -> \[w] -> opIntoRegs $ \[res] -> + emitBSwapCall res w W64 + BSwapOp -> \[w] -> opIntoRegs $ \[res] -> + emitBSwapCall res w (wordWidth platform) + + BRev8Op -> \[w] -> opIntoRegs $ \[res] -> + emitBRevCall res w W8 + BRev16Op -> \[w] -> opIntoRegs $ \[res] -> + emitBRevCall res w W16 + BRev32Op -> \[w] -> opIntoRegs $ \[res] -> + emitBRevCall res w W32 + BRev64Op -> \[w] -> opIntoRegs $ \[res] -> + emitBRevCall res w W64 + BRevOp -> \[w] -> opIntoRegs $ \[res] -> + emitBRevCall res w (wordWidth platform) + +-- Population count + PopCnt8Op -> \[w] -> opIntoRegs $ \[res] -> + emitPopCntCall res w W8 + PopCnt16Op -> \[w] -> opIntoRegs $ \[res] -> + emitPopCntCall res w W16 + PopCnt32Op -> \[w] -> opIntoRegs $ \[res] -> + emitPopCntCall res w W32 + PopCnt64Op -> \[w] -> opIntoRegs $ \[res] -> + emitPopCntCall res w W64 + PopCntOp -> \[w] -> opIntoRegs $ \[res] -> + emitPopCntCall res w (wordWidth platform) + +-- Parallel bit deposit + Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] -> + emitPdepCall res src mask W8 + Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] -> + emitPdepCall res src mask W16 + Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] -> + emitPdepCall res src mask W32 + Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] -> + emitPdepCall res src mask W64 + PdepOp -> \[src, mask] -> opIntoRegs $ \[res] -> + emitPdepCall res src mask (wordWidth platform) + +-- Parallel bit extract + Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] -> + emitPextCall res src mask W8 + Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] -> + emitPextCall res src mask W16 + Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] -> + emitPextCall res src mask W32 + Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] -> + emitPextCall res src mask W64 + PextOp -> \[src, mask] -> opIntoRegs $ \[res] -> + emitPextCall res src mask (wordWidth platform) + +-- count leading zeros + Clz8Op -> \[w] -> opIntoRegs $ \[res] -> + emitClzCall res w W8 + Clz16Op -> \[w] -> opIntoRegs $ \[res] -> + emitClzCall res w W16 + Clz32Op -> \[w] -> opIntoRegs $ \[res] -> + emitClzCall res w W32 + Clz64Op -> \[w] -> opIntoRegs $ \[res] -> + emitClzCall res w W64 + ClzOp -> \[w] -> opIntoRegs $ \[res] -> + emitClzCall res w (wordWidth platform) + +-- count trailing zeros + Ctz8Op -> \[w] -> opIntoRegs $ \[res] -> + emitCtzCall res w W8 + Ctz16Op -> \[w] -> opIntoRegs $ \[res] -> + emitCtzCall res w W16 + Ctz32Op -> \[w] -> opIntoRegs $ \[res] -> + emitCtzCall res w W32 + Ctz64Op -> \[w] -> opIntoRegs $ \[res] -> + emitCtzCall res w W64 + CtzOp -> \[w] -> opIntoRegs $ \[res] -> + emitCtzCall res w (wordWidth platform) + +-- Unsigned int to floating point conversions + WordToFloatOp -> \[w] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_UF_Conv W32) [w] + WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_UF_Conv W64) [w] + +-- Atomic operations + InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value] + InterlockedExchange_Word -> \[src, value] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value] + + FetchAddAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + doAtomicAddrRMW res AMO_Add addr (bWord platform) n + FetchSubAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + doAtomicAddrRMW res AMO_Sub addr (bWord platform) n + FetchAndAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + doAtomicAddrRMW res AMO_And addr (bWord platform) n + FetchNandAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + doAtomicAddrRMW res AMO_Nand addr (bWord platform) n + FetchOrAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + doAtomicAddrRMW res AMO_Or addr (bWord platform) n + FetchXorAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] -> + doAtomicAddrRMW res AMO_Xor addr (bWord platform) n + + AtomicReadAddrOp_Word -> \[addr] -> opIntoRegs $ \[res] -> + doAtomicReadAddr res addr (bWord platform) + AtomicWriteAddrOp_Word -> \[addr, val] -> opIntoRegs $ \[] -> + doAtomicWriteAddr addr (bWord platform) val + + CasAddrOp_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new] + CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new] + CasAddrOp_Word8 -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Cmpxchg W8) [dst, expected, new] + CasAddrOp_Word16 -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Cmpxchg W16) [dst, expected, new] + CasAddrOp_Word32 -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Cmpxchg W32) [dst, expected, new] + CasAddrOp_Word64 -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Cmpxchg W64) [dst, expected, new] + +-- SIMD primops + (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do + checkVecCompatibility cfg vcat n w + doVecBroadcastOp ty e res + where + + ty :: CmmType + ty = vecCmmType vcat n w + + (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do + checkVecCompatibility cfg vcat n w + when (es `lengthIsNot` n) $ + panic "emitPrimOp: VecPackOp has wrong number of arguments" + doVecPackOp ty es res + where + ty :: CmmType + ty = vecCmmType vcat n w + + (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do + checkVecCompatibility cfg vcat n w + when (res `lengthIsNot` n) $ + panic "emitPrimOp: VecUnpackOp has wrong number of results" + doVecUnpackOp ty arg res + where + ty :: CmmType + ty = vecCmmType vcat n w + + (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do + checkVecCompatibility cfg vcat n w + doVecInsertOp ty v e i res + where + ty :: CmmType + ty = vecCmmType vcat n w + + (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doIndexByteArrayOp Nothing ty res0 args + where + ty :: CmmType + ty = vecCmmType vcat n w + + (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doIndexByteArrayOp Nothing ty res0 args + where + ty :: CmmType + ty = vecCmmType vcat n w + + (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doWriteByteArrayOp Nothing ty res0 args + where + ty :: CmmType + ty = vecCmmType vcat n w + + (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doIndexOffAddrOp Nothing ty res0 args + where + ty :: CmmType + ty = vecCmmType vcat n w + + (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doIndexOffAddrOp Nothing ty res0 args + where + ty :: CmmType + ty = vecCmmType vcat n w + + (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doWriteOffAddrOp Nothing ty res0 args + where + ty :: CmmType + ty = vecCmmType vcat n w + + (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doIndexByteArrayOpAs Nothing vecty ty res0 args + where + vecty :: CmmType + vecty = vecCmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + + (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doIndexByteArrayOpAs Nothing vecty ty res0 args + where + vecty :: CmmType + vecty = vecCmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + + (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doWriteByteArrayOp Nothing ty res0 args + where + ty :: CmmType + ty = vecCmmCat vcat w + + (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doIndexOffAddrOpAs Nothing vecty ty res0 args + where + vecty :: CmmType + vecty = vecCmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + + (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doIndexOffAddrOpAs Nothing vecty ty res0 args + where + vecty :: CmmType + vecty = vecCmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + + (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility cfg vcat n w + doWriteOffAddrOp Nothing ty res0 args + where + ty :: CmmType + ty = vecCmmCat vcat w + + VecShuffleOp vcat n w -> \ args -> opIntoRegs $ \ [res] -> do + checkVecCompatibility cfg vcat n w + doShuffleOp (vecCmmType vcat n w) args res + +-- Prefetch + PrefetchByteArrayOp3 -> \args -> opIntoRegs $ \[] -> + doPrefetchByteArrayOp 3 args + PrefetchMutableByteArrayOp3 -> \args -> opIntoRegs $ \[] -> + doPrefetchMutableByteArrayOp 3 args + PrefetchAddrOp3 -> \args -> opIntoRegs $ \[] -> + doPrefetchAddrOp 3 args + PrefetchValueOp3 -> \args -> opIntoRegs $ \[] -> + doPrefetchValueOp 3 args + + PrefetchByteArrayOp2 -> \args -> opIntoRegs $ \[] -> + doPrefetchByteArrayOp 2 args + PrefetchMutableByteArrayOp2 -> \args -> opIntoRegs $ \[] -> + doPrefetchMutableByteArrayOp 2 args + PrefetchAddrOp2 -> \args -> opIntoRegs $ \[] -> + doPrefetchAddrOp 2 args + PrefetchValueOp2 -> \args -> opIntoRegs $ \[] -> + doPrefetchValueOp 2 args + PrefetchByteArrayOp1 -> \args -> opIntoRegs $ \[] -> + doPrefetchByteArrayOp 1 args + PrefetchMutableByteArrayOp1 -> \args -> opIntoRegs $ \[] -> + doPrefetchMutableByteArrayOp 1 args + PrefetchAddrOp1 -> \args -> opIntoRegs $ \[] -> + doPrefetchAddrOp 1 args + PrefetchValueOp1 -> \args -> opIntoRegs $ \[] -> + doPrefetchValueOp 1 args + + PrefetchByteArrayOp0 -> \args -> opIntoRegs $ \[] -> + doPrefetchByteArrayOp 0 args + PrefetchMutableByteArrayOp0 -> \args -> opIntoRegs $ \[] -> + doPrefetchMutableByteArrayOp 0 args + PrefetchAddrOp0 -> \args -> opIntoRegs $ \[] -> + doPrefetchAddrOp 0 args + PrefetchValueOp0 -> \args -> opIntoRegs $ \[] -> + doPrefetchValueOp 0 args + +-- Atomic read-modify-write + FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + doAtomicByteArrayRMW res AMO_Add mba ix (bWord platform) n + FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + doAtomicByteArrayRMW res AMO_Sub mba ix (bWord platform) n + FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + doAtomicByteArrayRMW res AMO_And mba ix (bWord platform) n + FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + doAtomicByteArrayRMW res AMO_Nand mba ix (bWord platform) n + FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + doAtomicByteArrayRMW res AMO_Or mba ix (bWord platform) n + FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> + doAtomicByteArrayRMW res AMO_Xor mba ix (bWord platform) n + AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] -> + doAtomicReadByteArray res mba ix (bWord platform) + AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] -> + doAtomicWriteByteArray mba ix (bWord platform) val + CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> + doCasByteArray res mba ix (bWord platform) old new + CasByteArrayOp_Int8 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> + doCasByteArray res mba ix b8 old new + CasByteArrayOp_Int16 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> + doCasByteArray res mba ix b16 old new + CasByteArrayOp_Int32 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> + doCasByteArray res mba ix b32 old new + CasByteArrayOp_Int64 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> + doCasByteArray res mba ix b64 old new + +-- The rest just translate straightforwardly + + Int8ToWord8Op -> \args -> opNop args + Word8ToInt8Op -> \args -> opNop args + Int16ToWord16Op -> \args -> opNop args + Word16ToInt16Op -> \args -> opNop args + Int32ToWord32Op -> \args -> opNop args + Word32ToInt32Op -> \args -> opNop args + Int64ToWord64Op -> \args -> opNop args + Word64ToInt64Op -> \args -> opNop args + IntToWordOp -> \args -> opNop args + WordToIntOp -> \args -> opNop args + IntToAddrOp -> \args -> opNop args + AddrToIntOp -> \args -> opNop args + ChrOp -> \args -> opNop args -- Int# and Char# are rep'd the same + OrdOp -> \args -> opNop args + + Narrow8IntOp -> \args -> opNarrow args (MO_SS_Conv, W8) + Narrow16IntOp -> \args -> opNarrow args (MO_SS_Conv, W16) + Narrow32IntOp -> \args -> opNarrow args (MO_SS_Conv, W32) + Narrow8WordOp -> \args -> opNarrow args (MO_UU_Conv, W8) + Narrow16WordOp -> \args -> opNarrow args (MO_UU_Conv, W16) + Narrow32WordOp -> \args -> opNarrow args (MO_UU_Conv, W32) + + DoublePowerOp -> opCallish MO_F64_Pwr + DoubleSinOp -> opCallish MO_F64_Sin + DoubleCosOp -> opCallish MO_F64_Cos + DoubleTanOp -> opCallish MO_F64_Tan + DoubleSinhOp -> opCallish MO_F64_Sinh + DoubleCoshOp -> opCallish MO_F64_Cosh + DoubleTanhOp -> opCallish MO_F64_Tanh + DoubleAsinOp -> opCallish MO_F64_Asin + DoubleAcosOp -> opCallish MO_F64_Acos + DoubleAtanOp -> opCallish MO_F64_Atan + DoubleAsinhOp -> opCallish MO_F64_Asinh + DoubleAcoshOp -> opCallish MO_F64_Acosh + DoubleAtanhOp -> opCallish MO_F64_Atanh + DoubleLogOp -> opCallish MO_F64_Log + DoubleLog1POp -> opCallish MO_F64_Log1P + DoubleExpOp -> opCallish MO_F64_Exp + DoubleExpM1Op -> opCallish MO_F64_ExpM1 + DoubleSqrtOp -> opCallish MO_F64_Sqrt + DoubleFabsOp -> opCallish MO_F64_Fabs + + FloatPowerOp -> opCallish MO_F32_Pwr + FloatSinOp -> opCallish MO_F32_Sin + FloatCosOp -> opCallish MO_F32_Cos + FloatTanOp -> opCallish MO_F32_Tan + FloatSinhOp -> opCallish MO_F32_Sinh + FloatCoshOp -> opCallish MO_F32_Cosh + FloatTanhOp -> opCallish MO_F32_Tanh + FloatAsinOp -> opCallish MO_F32_Asin + FloatAcosOp -> opCallish MO_F32_Acos + FloatAtanOp -> opCallish MO_F32_Atan + FloatAsinhOp -> opCallish MO_F32_Asinh + FloatAcoshOp -> opCallish MO_F32_Acosh + FloatAtanhOp -> opCallish MO_F32_Atanh + FloatLogOp -> opCallish MO_F32_Log + FloatLog1POp -> opCallish MO_F32_Log1P + FloatExpOp -> opCallish MO_F32_Exp + FloatExpM1Op -> opCallish MO_F32_ExpM1 + FloatSqrtOp -> opCallish MO_F32_Sqrt + FloatFabsOp -> opCallish MO_F32_Fabs + +-- Native word signless ops + + IntAddOp -> opTranslate (mo_wordAdd platform) + IntSubOp -> opTranslate (mo_wordSub platform) + WordAddOp -> opTranslate (mo_wordAdd platform) + WordSubOp -> opTranslate (mo_wordSub platform) + AddrAddOp -> opTranslate (mo_wordAdd platform) + AddrSubOp -> opTranslate (mo_wordSub platform) + + IntEqOp -> opTranslate (mo_wordEq platform) + IntNeOp -> opTranslate (mo_wordNe platform) + WordEqOp -> opTranslate (mo_wordEq platform) + WordNeOp -> opTranslate (mo_wordNe platform) + AddrEqOp -> opTranslate (mo_wordEq platform) + AddrNeOp -> opTranslate (mo_wordNe platform) + + WordAndOp -> opTranslate (mo_wordAnd platform) + WordOrOp -> opTranslate (mo_wordOr platform) + WordXorOp -> opTranslate (mo_wordXor platform) + WordNotOp -> opTranslate (mo_wordNot platform) + WordSllOp -> opTranslate (mo_wordShl platform) + WordSrlOp -> opTranslate (mo_wordUShr platform) + + AddrRemOp -> opTranslate (mo_wordURem platform) + +-- Native word signed ops + + IntMulOp -> opTranslate (mo_wordMul platform) + IntMulMayOfloOp -> opTranslate (MO_S_MulMayOflo (wordWidth platform)) + IntQuotOp -> opTranslate (mo_wordSQuot platform) + IntRemOp -> opTranslate (mo_wordSRem platform) + IntNegOp -> opTranslate (mo_wordSNeg platform) + + IntGeOp -> opTranslate (mo_wordSGe platform) + IntLeOp -> opTranslate (mo_wordSLe platform) + IntGtOp -> opTranslate (mo_wordSGt platform) + IntLtOp -> opTranslate (mo_wordSLt platform) + + IntAndOp -> opTranslate (mo_wordAnd platform) + IntOrOp -> opTranslate (mo_wordOr platform) + IntXorOp -> opTranslate (mo_wordXor platform) + IntNotOp -> opTranslate (mo_wordNot platform) + IntSllOp -> opTranslate (mo_wordShl platform) + IntSraOp -> opTranslate (mo_wordSShr platform) + IntSrlOp -> opTranslate (mo_wordUShr platform) + +-- Native word unsigned ops + + WordGeOp -> opTranslate (mo_wordUGe platform) + WordLeOp -> opTranslate (mo_wordULe platform) + WordGtOp -> opTranslate (mo_wordUGt platform) + WordLtOp -> opTranslate (mo_wordULt platform) + + WordMulOp -> opTranslate (mo_wordMul platform) + WordQuotOp -> opTranslate (mo_wordUQuot platform) + WordRemOp -> opTranslate (mo_wordURem platform) + + AddrGeOp -> opTranslate (mo_wordUGe platform) + AddrLeOp -> opTranslate (mo_wordULe platform) + AddrGtOp -> opTranslate (mo_wordUGt platform) + AddrLtOp -> opTranslate (mo_wordULt platform) + +-- Int8# signed ops + + Int8ToIntOp -> opTranslate (MO_SS_Conv W8 (wordWidth platform)) + IntToInt8Op -> opTranslate (MO_SS_Conv (wordWidth platform) W8) + Int8NegOp -> opTranslate (MO_S_Neg W8) + Int8AddOp -> opTranslate (MO_Add W8) + Int8SubOp -> opTranslate (MO_Sub W8) + Int8MulOp -> opTranslate (MO_Mul W8) + Int8QuotOp -> opTranslate (MO_S_Quot W8) + Int8RemOp -> opTranslate (MO_S_Rem W8) + + Int8SllOp -> opTranslate (MO_Shl W8) + Int8SraOp -> opTranslate (MO_S_Shr W8) + Int8SrlOp -> opTranslate (MO_U_Shr W8) + + Int8EqOp -> opTranslate (MO_Eq W8) + Int8GeOp -> opTranslate (MO_S_Ge W8) + Int8GtOp -> opTranslate (MO_S_Gt W8) + Int8LeOp -> opTranslate (MO_S_Le W8) + Int8LtOp -> opTranslate (MO_S_Lt W8) + Int8NeOp -> opTranslate (MO_Ne W8) + +-- Word8# unsigned ops + + Word8ToWordOp -> opTranslate (MO_UU_Conv W8 (wordWidth platform)) + WordToWord8Op -> opTranslate (MO_UU_Conv (wordWidth platform) W8) + Word8AddOp -> opTranslate (MO_Add W8) + Word8SubOp -> opTranslate (MO_Sub W8) + Word8MulOp -> opTranslate (MO_Mul W8) + Word8QuotOp -> opTranslate (MO_U_Quot W8) + Word8RemOp -> opTranslate (MO_U_Rem W8) + + Word8AndOp -> opTranslate (MO_And W8) + Word8OrOp -> opTranslate (MO_Or W8) + Word8XorOp -> opTranslate (MO_Xor W8) + Word8NotOp -> opTranslate (MO_Not W8) + Word8SllOp -> opTranslate (MO_Shl W8) + Word8SrlOp -> opTranslate (MO_U_Shr W8) + + Word8EqOp -> opTranslate (MO_Eq W8) + Word8GeOp -> opTranslate (MO_U_Ge W8) + Word8GtOp -> opTranslate (MO_U_Gt W8) + Word8LeOp -> opTranslate (MO_U_Le W8) + Word8LtOp -> opTranslate (MO_U_Lt W8) + Word8NeOp -> opTranslate (MO_Ne W8) + +-- Int16# signed ops + + Int16ToIntOp -> opTranslate (MO_SS_Conv W16 (wordWidth platform)) + IntToInt16Op -> opTranslate (MO_SS_Conv (wordWidth platform) W16) + Int16NegOp -> opTranslate (MO_S_Neg W16) + Int16AddOp -> opTranslate (MO_Add W16) + Int16SubOp -> opTranslate (MO_Sub W16) + Int16MulOp -> opTranslate (MO_Mul W16) + Int16QuotOp -> opTranslate (MO_S_Quot W16) + Int16RemOp -> opTranslate (MO_S_Rem W16) + + Int16SllOp -> opTranslate (MO_Shl W16) + Int16SraOp -> opTranslate (MO_S_Shr W16) + Int16SrlOp -> opTranslate (MO_U_Shr W16) + + Int16EqOp -> opTranslate (MO_Eq W16) + Int16GeOp -> opTranslate (MO_S_Ge W16) + Int16GtOp -> opTranslate (MO_S_Gt W16) + Int16LeOp -> opTranslate (MO_S_Le W16) + Int16LtOp -> opTranslate (MO_S_Lt W16) + Int16NeOp -> opTranslate (MO_Ne W16) + +-- Word16# unsigned ops + + Word16ToWordOp -> opTranslate (MO_UU_Conv W16 (wordWidth platform)) + WordToWord16Op -> opTranslate (MO_UU_Conv (wordWidth platform) W16) + Word16AddOp -> opTranslate (MO_Add W16) + Word16SubOp -> opTranslate (MO_Sub W16) + Word16MulOp -> opTranslate (MO_Mul W16) + Word16QuotOp -> opTranslate (MO_U_Quot W16) + Word16RemOp -> opTranslate (MO_U_Rem W16) + + Word16AndOp -> opTranslate (MO_And W16) + Word16OrOp -> opTranslate (MO_Or W16) + Word16XorOp -> opTranslate (MO_Xor W16) + Word16NotOp -> opTranslate (MO_Not W16) + Word16SllOp -> opTranslate (MO_Shl W16) + Word16SrlOp -> opTranslate (MO_U_Shr W16) + + Word16EqOp -> opTranslate (MO_Eq W16) + Word16GeOp -> opTranslate (MO_U_Ge W16) + Word16GtOp -> opTranslate (MO_U_Gt W16) + Word16LeOp -> opTranslate (MO_U_Le W16) + Word16LtOp -> opTranslate (MO_U_Lt W16) + Word16NeOp -> opTranslate (MO_Ne W16) + +-- Int32# signed ops + + Int32ToIntOp -> opTranslate (MO_SS_Conv W32 (wordWidth platform)) + IntToInt32Op -> opTranslate (MO_SS_Conv (wordWidth platform) W32) + Int32NegOp -> opTranslate (MO_S_Neg W32) + Int32AddOp -> opTranslate (MO_Add W32) + Int32SubOp -> opTranslate (MO_Sub W32) + Int32MulOp -> opTranslate (MO_Mul W32) + Int32QuotOp -> opTranslate (MO_S_Quot W32) + Int32RemOp -> opTranslate (MO_S_Rem W32) + + Int32SllOp -> opTranslate (MO_Shl W32) + Int32SraOp -> opTranslate (MO_S_Shr W32) + Int32SrlOp -> opTranslate (MO_U_Shr W32) + + Int32EqOp -> opTranslate (MO_Eq W32) + Int32GeOp -> opTranslate (MO_S_Ge W32) + Int32GtOp -> opTranslate (MO_S_Gt W32) + Int32LeOp -> opTranslate (MO_S_Le W32) + Int32LtOp -> opTranslate (MO_S_Lt W32) + Int32NeOp -> opTranslate (MO_Ne W32) + +-- Word32# unsigned ops + + Word32ToWordOp -> opTranslate (MO_UU_Conv W32 (wordWidth platform)) + WordToWord32Op -> opTranslate (MO_UU_Conv (wordWidth platform) W32) + Word32AddOp -> opTranslate (MO_Add W32) + Word32SubOp -> opTranslate (MO_Sub W32) + Word32MulOp -> opTranslate (MO_Mul W32) + Word32QuotOp -> opTranslate (MO_U_Quot W32) + Word32RemOp -> opTranslate (MO_U_Rem W32) + + Word32AndOp -> opTranslate (MO_And W32) + Word32OrOp -> opTranslate (MO_Or W32) + Word32XorOp -> opTranslate (MO_Xor W32) + Word32NotOp -> opTranslate (MO_Not W32) + Word32SllOp -> opTranslate (MO_Shl W32) + Word32SrlOp -> opTranslate (MO_U_Shr W32) + + Word32EqOp -> opTranslate (MO_Eq W32) + Word32GeOp -> opTranslate (MO_U_Ge W32) + Word32GtOp -> opTranslate (MO_U_Gt W32) + Word32LeOp -> opTranslate (MO_U_Le W32) + Word32LtOp -> opTranslate (MO_U_Lt W32) + Word32NeOp -> opTranslate (MO_Ne W32) + +-- Int64# signed ops + + Int64ToIntOp -> opTranslate64 (MO_SS_Conv W64 (wordWidth platform)) MO_I64_ToI + IntToInt64Op -> opTranslate64 (MO_SS_Conv (wordWidth platform) W64) MO_I64_FromI + Int64NegOp -> opTranslate64 (MO_S_Neg W64) MO_x64_Neg + Int64AddOp -> opTranslate64 (MO_Add W64) MO_x64_Add + Int64SubOp -> opTranslate64 (MO_Sub W64) MO_x64_Sub + Int64MulOp -> opTranslate64 (MO_Mul W64) MO_x64_Mul + Int64QuotOp + | allowQuot64 -> opTranslate (MO_S_Quot W64) + | otherwise -> opCallish MO_I64_Quot + Int64RemOp + | allowQuot64 -> opTranslate (MO_S_Rem W64) + | otherwise -> opCallish MO_I64_Rem + + Int64SllOp -> opTranslate64 (MO_Shl W64) MO_x64_Shl + Int64SraOp -> opTranslate64 (MO_S_Shr W64) MO_I64_Shr + Int64SrlOp -> opTranslate64 (MO_U_Shr W64) MO_W64_Shr + + Int64EqOp -> opTranslate64 (MO_Eq W64) MO_x64_Eq + Int64GeOp -> opTranslate64 (MO_S_Ge W64) MO_I64_Ge + Int64GtOp -> opTranslate64 (MO_S_Gt W64) MO_I64_Gt + Int64LeOp -> opTranslate64 (MO_S_Le W64) MO_I64_Le + Int64LtOp -> opTranslate64 (MO_S_Lt W64) MO_I64_Lt + Int64NeOp -> opTranslate64 (MO_Ne W64) MO_x64_Ne + +-- Word64# unsigned ops + + Word64ToWordOp -> opTranslate64 (MO_UU_Conv W64 (wordWidth platform)) MO_W64_ToW + WordToWord64Op -> opTranslate64 (MO_UU_Conv (wordWidth platform) W64) MO_W64_FromW + Word64AddOp -> opTranslate64 (MO_Add W64) MO_x64_Add + Word64SubOp -> opTranslate64 (MO_Sub W64) MO_x64_Sub + Word64MulOp -> opTranslate64 (MO_Mul W64) MO_x64_Mul + Word64QuotOp + | allowQuot64 -> opTranslate (MO_U_Quot W64) + | otherwise -> opCallish MO_W64_Quot + Word64RemOp + | allowQuot64 -> opTranslate (MO_U_Rem W64) + | otherwise -> opCallish MO_W64_Rem + + Word64AndOp -> opTranslate64 (MO_And W64) MO_x64_And + Word64OrOp -> opTranslate64 (MO_Or W64) MO_x64_Or + Word64XorOp -> opTranslate64 (MO_Xor W64) MO_x64_Xor + Word64NotOp -> opTranslate64 (MO_Not W64) MO_x64_Not + Word64SllOp -> opTranslate64 (MO_Shl W64) MO_x64_Shl + Word64SrlOp -> opTranslate64 (MO_U_Shr W64) MO_W64_Shr + + Word64EqOp -> opTranslate64 (MO_Eq W64) MO_x64_Eq + Word64GeOp -> opTranslate64 (MO_U_Ge W64) MO_W64_Ge + Word64GtOp -> opTranslate64 (MO_U_Gt W64) MO_W64_Gt + Word64LeOp -> opTranslate64 (MO_U_Le W64) MO_W64_Le + Word64LtOp -> opTranslate64 (MO_U_Lt W64) MO_W64_Lt + Word64NeOp -> opTranslate64 (MO_Ne W64) MO_x64_Ne + +-- Char# ops + + CharEqOp -> opTranslate (MO_Eq (wordWidth platform)) + CharNeOp -> opTranslate (MO_Ne (wordWidth platform)) + CharGeOp -> opTranslate (MO_U_Ge (wordWidth platform)) + CharLeOp -> opTranslate (MO_U_Le (wordWidth platform)) + CharGtOp -> opTranslate (MO_U_Gt (wordWidth platform)) + CharLtOp -> opTranslate (MO_U_Lt (wordWidth platform)) + +-- Double ops + + DoubleEqOp -> opTranslate (MO_F_Eq W64) + DoubleNeOp -> opTranslate (MO_F_Ne W64) + DoubleGeOp -> opTranslate (MO_F_Ge W64) + DoubleLeOp -> opTranslate (MO_F_Le W64) + DoubleGtOp -> opTranslate (MO_F_Gt W64) + DoubleLtOp -> opTranslate (MO_F_Lt W64) + + DoubleMinOp -> opTranslate (MO_F_Min W64) + DoubleMaxOp -> opTranslate (MO_F_Max W64) + + DoubleAddOp -> opTranslate (MO_F_Add W64) + DoubleSubOp -> opTranslate (MO_F_Sub W64) + DoubleMulOp -> opTranslate (MO_F_Mul W64) + DoubleDivOp -> opTranslate (MO_F_Quot W64) + DoubleNegOp -> opTranslate (MO_F_Neg W64) + + DoubleFMAdd -> fmaOp FMAdd 1 W64 + DoubleFMSub -> fmaOp FMSub 1 W64 + DoubleFNMAdd -> fmaOp FNMAdd 1 W64 + DoubleFNMSub -> fmaOp FNMSub 1 W64 + +-- Float ops + + FloatEqOp -> opTranslate (MO_F_Eq W32) + FloatNeOp -> opTranslate (MO_F_Ne W32) + FloatGeOp -> opTranslate (MO_F_Ge W32) + FloatLeOp -> opTranslate (MO_F_Le W32) + FloatGtOp -> opTranslate (MO_F_Gt W32) + FloatLtOp -> opTranslate (MO_F_Lt W32) + + FloatAddOp -> opTranslate (MO_F_Add W32) + FloatSubOp -> opTranslate (MO_F_Sub W32) + FloatMulOp -> opTranslate (MO_F_Mul W32) + FloatDivOp -> opTranslate (MO_F_Quot W32) + FloatNegOp -> opTranslate (MO_F_Neg W32) + + FloatFMAdd -> fmaOp FMAdd 1 W32 + FloatFMSub -> fmaOp FMSub 1 W32 + FloatFNMAdd -> fmaOp FNMAdd 1 W32 + FloatFNMSub -> fmaOp FNMSub 1 W32 + + FloatMinOp -> opTranslate (MO_F_Min W32) + FloatMaxOp -> opTranslate (MO_F_Max W32) + +-- Vector ops + + (VecAddOp FloatVec n w) -> opTranslate (MO_VF_Add n w) + (VecSubOp FloatVec n w) -> opTranslate (MO_VF_Sub n w) + (VecMulOp FloatVec n w) -> opTranslate (MO_VF_Mul n w) + (VecDivOp FloatVec n w) -> opTranslate (MO_VF_Quot n w) + (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop" + (VecRemOp FloatVec _ _) -> \_ -> panic "unsupported primop" + (VecNegOp FloatVec n w) -> opTranslate (MO_VF_Neg n w) + (VecMinOp FloatVec n w) -> opTranslate (MO_VF_Min n w) + (VecMaxOp FloatVec n w) -> opTranslate (MO_VF_Max n w) + + (VecAddOp IntVec n w) -> opTranslate (MO_V_Add n w) + (VecSubOp IntVec n w) -> opTranslate (MO_V_Sub n w) + (VecMulOp IntVec n w) -> opTranslate (MO_V_Mul n w) + (VecDivOp IntVec _ _) -> \_ -> panic "unsupported primop" + (VecQuotOp IntVec n w) -> opCallish (MO_VS_Quot n w) + (VecRemOp IntVec n w) -> opCallish (MO_VS_Rem n w) + (VecNegOp IntVec n w) -> opTranslate (MO_VS_Neg n w) + (VecMinOp IntVec 2 W64) + | not allowIntWord64X2MinMax -> opCallish MO_I64X2_Min + (VecMinOp IntVec n w) -> opTranslate (MO_VS_Min n w) + (VecMaxOp IntVec 2 W64) + | not allowIntWord64X2MinMax -> opCallish MO_I64X2_Max + (VecMaxOp IntVec n w) -> opTranslate (MO_VS_Max n w) + + (VecAddOp WordVec n w) -> opTranslate (MO_V_Add n w) + (VecSubOp WordVec n w) -> opTranslate (MO_V_Sub n w) + (VecMulOp WordVec n w) -> opTranslate (MO_V_Mul n w) + (VecDivOp WordVec _ _) -> \_ -> panic "unsupported primop" + (VecQuotOp WordVec n w) -> opCallish (MO_VU_Quot n w) + (VecRemOp WordVec n w) -> opCallish (MO_VU_Rem n w) + (VecNegOp WordVec _ _) -> \_ -> panic "unsupported primop" + (VecMinOp WordVec 2 W64) + | not allowIntWord64X2MinMax -> opCallish MO_W64X2_Min + (VecMinOp WordVec n w) -> opTranslate (MO_VU_Min n w) + (VecMaxOp WordVec 2 W64) + | not allowIntWord64X2MinMax -> opCallish MO_W64X2_Max + (VecMaxOp WordVec n w) -> opTranslate (MO_VU_Max n w) + + -- Vector FMA instructions + VecFMAdd _ n w -> fmaOp FMAdd n w + VecFMSub _ n w -> fmaOp FMSub n w + VecFNMAdd _ n w -> fmaOp FNMAdd n w + VecFNMSub _ n w -> fmaOp FNMSub n w + +-- Conversions + + IntToDoubleOp -> opTranslate (MO_SF_Round (wordWidth platform) W64) + DoubleToIntOp -> opTranslate (MO_FS_Truncate W64 (wordWidth platform)) + + IntToFloatOp -> opTranslate (MO_SF_Round (wordWidth platform) W32) + FloatToIntOp -> opTranslate (MO_FS_Truncate W32 (wordWidth platform)) + + FloatToDoubleOp -> opTranslate (MO_FF_Conv W32 W64) + DoubleToFloatOp -> opTranslate (MO_FF_Conv W64 W32) + + CastFloatToWord32Op -> translateBitcasts (MO_FW_Bitcast W32) + CastWord32ToFloatOp -> translateBitcasts (MO_WF_Bitcast W32) + CastDoubleToWord64Op -> translateBitcasts (MO_FW_Bitcast W64) + CastWord64ToDoubleOp -> translateBitcasts (MO_WF_Bitcast W64) + + IntQuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem (wordWidth platform)) + else Right (genericIntQuotRemOp (wordWidth platform)) + + Int8QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem W8) + else Right (genericIntQuotRemOp W8) + + Int16QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem W16) + else Right (genericIntQuotRemOp W16) + + Int32QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem W32) + else Right (genericIntQuotRemOp W32) + + WordQuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_U_QuotRem (wordWidth platform)) + else Right (genericWordQuotRemOp (wordWidth platform)) + + WordQuotRem2Op -> opCallishHandledLater $ + if allowQuotRem2 + then Left (MO_U_QuotRem2 (wordWidth platform)) + else Right (genericWordQuotRem2Op platform) + + Word8QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_U_QuotRem W8) + else Right (genericWordQuotRemOp W8) + + Word16QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_U_QuotRem W16) + else Right (genericWordQuotRemOp W16) + + Word32QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_U_QuotRem W32) + else Right (genericWordQuotRemOp W32) + + WordAdd2Op -> opCallishHandledLater $ + if allowExtAdd + then Left (MO_Add2 (wordWidth platform)) + else Right genericWordAdd2Op + + WordAddCOp -> opCallishHandledLater $ + if allowExtAdd + then Left (MO_AddWordC (wordWidth platform)) + else Right genericWordAddCOp + + WordSubCOp -> opCallishHandledLater $ + if allowExtAdd + then Left (MO_SubWordC (wordWidth platform)) + else Right genericWordSubCOp + + IntAddCOp -> opCallishHandledLater $ + if allowExtAdd + then Left (MO_AddIntC (wordWidth platform)) + else Right genericIntAddCOp + + IntSubCOp -> opCallishHandledLater $ + if allowExtAdd + then Left (MO_SubIntC (wordWidth platform)) + else Right genericIntSubCOp + + WordMul2Op -> opCallishHandledLater $ + if allowWord2Mul + then Left (MO_U_Mul2 (wordWidth platform)) + else Right genericWordMul2Op + + IntMul2Op -> opCallishHandledLater $ + if allowInt2Mul + then Left (MO_S_Mul2 (wordWidth platform)) + else Right genericIntMul2Op + + -- tagToEnum# is special: we need to pull the constructor + -- out of the table, and perform an appropriate return. + TagToEnumOp -> \[amode] -> PrimopCmmEmit_Internal $ \res_ty -> do + -- If you're reading this code in the attempt to figure + -- out why the compiler panic'ed here, it is probably because + -- you used tagToEnum# in a non-monomorphic setting, e.g., + -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# + -- That won't work. + let tycon = fromMaybe (pprPanic "tagToEnum#: Applied to non-concrete type" (ppr res_ty)) (tyConAppTyCon_maybe res_ty) + massert (isEnumerationTyCon tycon) + platform <- getPlatform + pure [tagToClosure platform tycon amode] + +-- Out of line primops. +-- TODO compiler need not know about these + + UnsafeThawArrayOp -> alwaysExternal + CasArrayOp -> alwaysExternal + UnsafeThawSmallArrayOp -> alwaysExternal + CasSmallArrayOp -> alwaysExternal + NewPinnedByteArrayOp_Char -> alwaysExternal + NewAlignedPinnedByteArrayOp_Char -> alwaysExternal + MutableByteArrayIsPinnedOp -> alwaysExternal + MutableByteArrayIsWeaklyPinnedOp -> alwaysExternal + DoubleDecode_2IntOp -> alwaysExternal + DoubleDecode_Int64Op -> alwaysExternal + FloatDecode_IntOp -> alwaysExternal + ByteArrayIsPinnedOp -> alwaysExternal + ByteArrayIsWeaklyPinnedOp -> alwaysExternal + ShrinkMutableByteArrayOp_Char -> alwaysExternal + ResizeMutableByteArrayOp_Char -> alwaysExternal + ShrinkSmallMutableArrayOp_Char -> alwaysExternal + NewMutVarOp -> alwaysExternal + AtomicModifyMutVar2Op -> alwaysExternal + AtomicModifyMutVar_Op -> alwaysExternal + CasMutVarOp -> alwaysExternal + CatchOp -> alwaysExternal + RaiseOp -> alwaysExternal + RaiseUnderflowOp -> alwaysExternal + RaiseOverflowOp -> alwaysExternal + RaiseDivZeroOp -> alwaysExternal + RaiseIOOp -> alwaysExternal + MaskAsyncExceptionsOp -> alwaysExternal + MaskUninterruptibleOp -> alwaysExternal + UnmaskAsyncExceptionsOp -> alwaysExternal + MaskStatus -> alwaysExternal + NewPromptTagOp -> alwaysExternal + PromptOp -> alwaysExternal + Control0Op -> alwaysExternal + AtomicallyOp -> alwaysExternal + RetryOp -> alwaysExternal + CatchRetryOp -> alwaysExternal + CatchSTMOp -> alwaysExternal + NewTVarOp -> alwaysExternal + ReadTVarOp -> alwaysExternal + ReadTVarIOOp -> alwaysExternal + WriteTVarOp -> alwaysExternal + NewMVarOp -> alwaysExternal + TakeMVarOp -> alwaysExternal + TryTakeMVarOp -> alwaysExternal + PutMVarOp -> alwaysExternal + TryPutMVarOp -> alwaysExternal + ReadMVarOp -> alwaysExternal + TryReadMVarOp -> alwaysExternal + IsEmptyMVarOp -> alwaysExternal + DelayOp -> alwaysExternal + WaitReadOp -> alwaysExternal + WaitWriteOp -> alwaysExternal + ForkOp -> alwaysExternal + ForkOnOp -> alwaysExternal + KillThreadOp -> alwaysExternal + YieldOp -> alwaysExternal + LabelThreadOp -> alwaysExternal + IsCurrentThreadBoundOp -> alwaysExternal + NoDuplicateOp -> alwaysExternal + GetThreadLabelOp -> alwaysExternal + ThreadStatusOp -> alwaysExternal + MkWeakOp -> alwaysExternal + MkWeakNoFinalizerOp -> alwaysExternal + AddCFinalizerToWeakOp -> alwaysExternal + DeRefWeakOp -> alwaysExternal + FinalizeWeakOp -> alwaysExternal + MakeStablePtrOp -> alwaysExternal + DeRefStablePtrOp -> alwaysExternal + MakeStableNameOp -> alwaysExternal + CompactNewOp -> alwaysExternal + CompactResizeOp -> alwaysExternal + CompactContainsOp -> alwaysExternal + CompactContainsAnyOp -> alwaysExternal + CompactGetFirstBlockOp -> alwaysExternal + CompactGetNextBlockOp -> alwaysExternal + CompactAllocateBlockOp -> alwaysExternal + CompactFixupPointersOp -> alwaysExternal + CompactAdd -> alwaysExternal + CompactAddWithSharing -> alwaysExternal + CompactSize -> alwaysExternal + GetSparkOp -> alwaysExternal + NumSparks -> alwaysExternal + DataToTagSmallOp -> alwaysExternal + DataToTagLargeOp -> alwaysExternal + MkApUpd0_Op -> alwaysExternal + NewBCOOp -> alwaysExternal + UnpackClosureOp -> alwaysExternal + ListThreadsOp -> alwaysExternal + ClosureSizeOp -> alwaysExternal + WhereFromOp -> alwaysExternal + GetApStackValOp -> alwaysExternal + ClearCCSOp -> alwaysExternal + AnnotateStackOp -> alwaysExternal + TraceEventOp -> alwaysExternal + TraceEventBinaryOp -> alwaysExternal + TraceMarkerOp -> alwaysExternal + SetThreadAllocationCounter -> alwaysExternal + SetOtherThreadAllocationCounter -> alwaysExternal + KeepAliveOp -> alwaysExternal + + where + profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg + result_info = getPrimOpResultInfo primop + + opNop :: [CmmExpr] -> PrimopCmmEmit + opNop args = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg + where [arg] = args + + opNarrow + :: [CmmExpr] + -> (Width -> Width -> MachOp, Width) + -> PrimopCmmEmit + opNarrow args (mop, rep) = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) $ + CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]] + where [arg] = args + + -- These primops are implemented by CallishMachOps, because they sometimes + -- turn into foreign calls depending on the backend. + opCallish :: CallishMachOp -> [CmmExpr] -> PrimopCmmEmit + opCallish prim args = opIntoRegs $ \[res] -> emitPrimCall [res] prim args + + opTranslate :: MachOp -> [CmmExpr] -> PrimopCmmEmit + opTranslate mop args = opIntoRegs $ \[res] -> do + let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) + emit stmt + + opTranslate64 + :: MachOp + -> CallishMachOp + -> [CmmExpr] + -> PrimopCmmEmit + opTranslate64 mop callish + | allowArith64 = opTranslate mop + | otherwise = opCallish callish + -- backends not supporting 64-bit arithmetic primops: use callish machine + -- ops + + -- 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 + :: Either CallishMachOp GenericOp + -> [CmmExpr] + -> PrimopCmmEmit + opCallishHandledLater callOrNot args = opIntoRegs $ \res0 -> case callOrNot of + Left op -> emit $ mkUnsafeCall (PrimTarget op) res0 args + Right gen -> gen res0 args + + opIntoRegs + :: ([LocalReg] -- where to put the results + -> FCode ()) + -> PrimopCmmEmit + opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do + regs <- case result_info of + ReturnsVoid -> pure [] + ReturnsPrim rep + -> do reg <- newTemp (primRepCmmType platform rep) + pure [reg] + + ReturnsTuple + -> do (regs, _hints) <- newUnboxedTupleRegs res_ty + pure regs + f regs + pure $ map (CmmReg . CmmLocal) regs + + alwaysExternal = \_ -> PrimopCmmEmit_External + -- Note [QuotRem optimization] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops + -- (shift, .&.). + -- + -- Currently we only support optimization (performed in GHC.Cmm.Opt) when the + -- constant is a power of 2. #9041 tracks the implementation of the general + -- optimization. + -- + -- `quotRem` can be optimized in the same way. However as it returns two values, + -- it is implemented as a "callish" primop which is harder to match and + -- to transform later on. For simplicity, the current implementation detects cases + -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem + -- primop into two CMM quot and rem primops. + quotRemCanBeOptimized = \case + [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n) + _ -> False + + allowQuotRem = stgToCmmAllowQuotRemInstr cfg + allowQuotRem2 = stgToCmmAllowQuotRem2 cfg + allowExtAdd = stgToCmmAllowExtendedAddSubInstrs cfg + allowInt2Mul = stgToCmmAllowIntMul2Instr cfg + allowWord2Mul = stgToCmmAllowWordMul2Instr cfg + allowArith64 = stgToCmmAllowArith64 cfg + allowQuot64 = stgToCmmAllowQuot64 cfg + allowIntWord64X2MinMax = stgToCmmAllowIntWord64X2MinMax cfg + + -- a bit of a hack, for certain code generaters, e.g. PPC, and i386 we + -- continue to use the cmm versions of these functions instead of inline + -- assembly. Tracked in #24841. + ppc = isPPC $ platformArch platform + i386 = target32Bit platform + translateBitcasts mop | ppc || i386 = alwaysExternal + | otherwise = opTranslate mop + + allowFMA = stgToCmmAllowFMAInstr cfg + + fmaOp :: FMASign -> Length -> Width -> [CmmActual] -> PrimopCmmEmit + fmaOp signs l w args@[arg_x, arg_y, arg_z] + | allowFMA signs + || l > 1 -- (always use the MachOp for vector FMA) + = opTranslate (MO_FMA signs l w) args + | otherwise + = case signs of + + -- For fused multiply-add x * y + z, we fall back to the C implementation. + FMAdd -> opIntoRegs $ \ [res] -> fmaCCall w res arg_x arg_y arg_z + + -- Other fused multiply-add operations are implemented in terms of fmadd + -- This is sound: it does not lose any precision. + FMSub -> fmaOp FMAdd l w [arg_x, arg_y, neg arg_z] + FNMAdd -> fmaOp FMAdd l w [neg arg_x, arg_y, arg_z] + FNMSub -> fmaOp FMAdd l w [neg arg_x, arg_y, neg arg_z] + where + neg x + | l == 1 + = CmmMachOp (MO_F_Neg w) [x] + | otherwise + = CmmMachOp (MO_VF_Neg l w) [x] + fmaOp _ _ _ _ = panic "fmaOp: wrong number of arguments (expected 3)" + +data PrimopCmmEmit + -- | Out of line fake primop that's actually just a foreign call to other + -- (presumably) C--. + = PrimopCmmEmit_External + -- | Real primop turned into inline C--. + | PrimopCmmEmit_Internal (Type -- the return type, some primops are specialized to it + -> FCode [CmmExpr]) -- just for TagToEnum for now + +type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () + +genericIntQuotRemOp :: Width -> GenericOp +genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y] + = emit $ mkAssign (CmmLocal res_q) + (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*> + mkAssign (CmmLocal res_r) + (CmmMachOp (MO_S_Rem width) [arg_x, arg_y]) +genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp" + +genericWordQuotRemOp :: Width -> GenericOp +genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y] + = emit $ mkAssign (CmmLocal res_q) + (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*> + mkAssign (CmmLocal res_r) + (CmmMachOp (MO_U_Rem width) [arg_x, arg_y]) +genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp" + +-- Based on the algorithm from LLVM's compiler-rt: +-- https://github.com/llvm/llvm-project/blob/7339f7ba3053db7595ece1ca5f49bd2e4c3c8305/compiler-rt/lib/builtins/udivmodti4.c#L23 +-- See that file for licensing and copyright. +genericWordQuotRem2Op :: Platform -> GenericOp +genericWordQuotRem2Op platform [res_q, res_r] [arg_u1, arg_u0, arg_v] + = do + -- v gets modified below based on clz v + v <- newTemp ty + emit $ mkAssign (CmmLocal v) arg_v + go arg_u1 arg_u0 v + where ty = cmmExprType platform arg_u1 + shl x i = CmmMachOp (MO_Shl (wordWidth platform)) [x, i] + shr x i = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, i] + or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y] + ge x y = CmmMachOp (MO_U_Ge (wordWidth platform)) [x, y] + le x y = CmmMachOp (MO_U_Le (wordWidth platform)) [x, y] + eq x y = CmmMachOp (MO_Eq (wordWidth platform)) [x, y] + plus x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y] + minus x y = CmmMachOp (MO_Sub (wordWidth platform)) [x, y] + times x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y] + udiv x y = CmmMachOp (MO_U_Quot (wordWidth platform)) [x, y] + and x y = CmmMachOp (MO_And (wordWidth platform)) [x, y] + lit i = CmmLit (CmmInt i (wordWidth platform)) + one = lit 1 + zero = lit 0 + masklow = lit ((1 `shiftL` (platformWordSizeInBits platform `div` 2)) - 1) + gotoIf pred target = emit =<< mkCmmIfGoto pred target + mkTmp ty = do + t <- newTemp ty + pure (t, CmmReg (CmmLocal t)) + infixr 8 .= + r .= e = emit $ mkAssign (CmmLocal r) e + + go :: CmmActual -> CmmActual -> LocalReg -> FCode () + go u1 u0 v = do + -- Computes (ret,r) = (u1< 0) { + -- actually if (s > 0 && s /= wordSizeInBits) { + gotoIf (s' `eq` zero) if_else + gotoIf (s' `eq` lit n_udword_bits) if_else + do + -- // Normalize the divisor. + -- v = v << s; + v .= shl v' s' + -- un64 = (u1 << s) | (u0 >> (n_udword_bits - s)); + un64 .= (u1 `shl` s') `or` (u0 `shr` (lit n_udword_bits `minus` s')) + -- un10 = u0 << s; // Shift dividend left + un10 .= shl u0 s' + emit $ mkBranch if_done + -- } else { + do + -- // Avoid undefined behavior of (u0 >> 64). + emitLabel if_else + -- un64 = u1; + un64 .= u1 + -- un10 = u0; + un10 .= u0 + s .= lit 0 -- Otherwise leads to >>/<< 64 + -- } + emitLabel if_done + + -- // Break divisor up into two 32-bit digits. + -- vn1 = v >> (n_udword_bits / 2); + vn1 .= v' `shr` lit (n_udword_bits `div` 2) + -- vn0 = v & 0xFFFFFFFF; + vn0 .= v' `and` masklow + + -- // Break right half of dividend into two digits. + -- un1 = un10 >> (n_udword_bits / 2); + un1 .= un10' `shr` lit (n_udword_bits `div` 2) + -- un0 = un10 & 0xFFFFFFFF; + un0 .= un10' `and` masklow + + -- // Compute the first quotient digit, q1. + -- q1 = un64 / vn1; + q1 .= un64' `udiv` vn1' + -- rhat = un64 - q1 * vn1; + rhat .= un64' `minus` times q1' vn1' + + while_1_entry <- newBlockId + while_1_body <- newBlockId + while_1_done <- newBlockId + -- // q1 has at most error 2. No more than 2 iterations. + -- while (q1 >= b || q1 * vn0 > b * rhat + un1) { + emitLabel while_1_entry + gotoIf (q1' `ge` lit b) while_1_body + gotoIf (le (times q1' vn0') + (times (lit b) rhat' `plus` un1')) + while_1_done + do + emitLabel while_1_body + -- q1 = q1 - 1; + q1 .= q1' `minus` one + -- rhat = rhat + vn1; + rhat .= rhat' `plus` vn1' + -- if (rhat >= b) + -- break; + gotoIf (rhat' `ge` lit b) + while_1_done + emit $ mkBranch while_1_entry + -- } + emitLabel while_1_done + + -- un21 = un64 * b + un1 - q1 * v; + un21 .= (times un64' (lit b) `plus` un1') `minus` times q1' v' + + -- // Compute the second quotient digit. + -- q0 = un21 / vn1; + q0 .= un21' `udiv` vn1' + -- rhat = un21 - q0 * vn1; + rhat .= un21' `minus` times q0' vn1' + + -- // q0 has at most error 2. No more than 2 iterations. + while_2_entry <- newBlockId + while_2_body <- newBlockId + while_2_done <- newBlockId + emitLabel while_2_entry + -- while (q0 >= b || q0 * vn0 > b * rhat + un0) { + gotoIf (q0' `ge` lit b) + while_2_body + gotoIf (le (times q0' vn0') + (times (lit b) rhat' `plus` un0')) + while_2_done + do + emitLabel while_2_body + -- q0 = q0 - 1; + q0 .= q0' `minus` one + -- rhat = rhat + vn1; + rhat .= rhat' `plus` vn1' + -- if (rhat >= b) + -- break; + gotoIf (rhat' `ge` lit b) while_2_done + emit $ mkBranch while_2_entry + -- } + emitLabel while_2_done + + -- r = (un21 * b + un0 - q0 * v) >> s; + res_r .= ((times un21' (lit b) `plus` un0') `minus` times q0' v') `shr` s' + -- return q1 * b + q0; + res_q .= times q1' (lit b) `plus` q0' +genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op" + +genericWordAdd2Op :: GenericOp +genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] + = do platform <- getPlatform + r1 <- newTemp (cmmExprType platform arg_x) + r2 <- newTemp (cmmExprType platform arg_x) + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform))) + (wordWidth platform)) + hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform)) + emit $ catAGraphs + [mkAssign (CmmLocal r1) + (add (bottomHalf arg_x) (bottomHalf arg_y)), + mkAssign (CmmLocal r2) + (add (topHalf (CmmReg (CmmLocal r1))) + (add (topHalf arg_x) (topHalf arg_y))), + mkAssign (CmmLocal res_h) + (topHalf (CmmReg (CmmLocal r2))), + mkAssign (CmmLocal res_l) + (or (toTopHalf (CmmReg (CmmLocal r2))) + (bottomHalf (CmmReg (CmmLocal r1))))] +genericWordAdd2Op _ _ = panic "genericWordAdd2Op" + +-- | Implements branchless recovery of the carry flag @c@ by checking the +-- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@: +-- +-- @ +-- c = a&b | (a|b)&~r +-- @ +-- +-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/ +genericWordAddCOp :: GenericOp +genericWordAddCOp [res_r, res_c] [aa, bb] + = do platform <- getPlatform + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr platform) [ + CmmMachOp (mo_wordOr platform) [ + CmmMachOp (mo_wordAnd platform) [aa,bb], + CmmMachOp (mo_wordAnd platform) [ + CmmMachOp (mo_wordOr platform) [aa,bb], + CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)] + ] + ], + mkIntExpr platform (platformWordSizeInBits platform - 1) + ] + ] +genericWordAddCOp _ _ = panic "genericWordAddCOp" + +-- | Implements branchless recovery of the carry flag @c@ by checking the +-- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@: +-- +-- @ +-- c = ~a&b | (~a|b)&r +-- @ +-- +-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/ +genericWordSubCOp :: GenericOp +genericWordSubCOp [res_r, res_c] [aa, bb] + = do platform <- getPlatform + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr platform) [ + CmmMachOp (mo_wordOr platform) [ + CmmMachOp (mo_wordAnd platform) [ + CmmMachOp (mo_wordNot platform) [aa], + bb + ], + CmmMachOp (mo_wordAnd platform) [ + CmmMachOp (mo_wordOr platform) [ + CmmMachOp (mo_wordNot platform) [aa], + bb + ], + CmmReg (CmmLocal res_r) + ] + ], + mkIntExpr platform (platformWordSizeInBits platform - 1) + ] + ] +genericWordSubCOp _ _ = panic "genericWordSubCOp" + +genericIntAddCOp :: GenericOp +genericIntAddCOp [res_r, res_c] [aa, bb] +{- + With some bit-twiddling, we can define int{Add,Sub}Czh portably in + C, and without needing any comparisons. This may not be the + fastest way to do it - if you have better code, please send it! --SDM + + Return : r = a + b, c = 0 if no overflow, 1 on overflow. + + We currently don't make use of the r value if c is != 0 (i.e. + overflow), we just convert to big integers and try again. This + could be improved by making r and c the correct values for + plugging into a new J#. + + { r = ((I_)(a)) + ((I_)(b)); \ + c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + Wading through the mass of bracketry, it seems to reduce to: + c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) + +-} + = do platform <- getPlatform + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr platform) [ + CmmMachOp (mo_wordAnd platform) [ + CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]], + CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)] + ], + mkIntExpr platform (platformWordSizeInBits platform - 1) + ] + ] +genericIntAddCOp _ _ = panic "genericIntAddCOp" + +genericIntSubCOp :: GenericOp +genericIntSubCOp [res_r, res_c] [aa, bb] +{- Similarly: + #define subIntCzh(r,c,a,b) \ + { r = ((I_)(a)) - ((I_)(b)); \ + c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + + c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) +-} + = do platform <- getPlatform + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr platform) [ + CmmMachOp (mo_wordAnd platform) [ + CmmMachOp (mo_wordXor platform) [aa,bb], + CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)] + ], + mkIntExpr platform (platformWordSizeInBits platform - 1) + ] + ] +genericIntSubCOp _ _ = panic "genericIntSubCOp" + +genericWordMul2Op :: GenericOp +genericWordMul2Op [res_h, res_l] [arg_x, arg_y] + = do platform <- getPlatform + let t = cmmExprType platform arg_x + xlyl <- liftM CmmLocal $ newTemp t + xlyh <- liftM CmmLocal $ newTemp t + xhyl <- liftM CmmLocal $ newTemp t + r <- liftM CmmLocal $ newTemp t + -- This generic implementation is very simple and slow. We might + -- well be able to do better, but for now this at least works. + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y] + sum = foldl1 add + mul x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform))) + (wordWidth platform)) + hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform)) + emit $ catAGraphs + [mkAssign xlyl + (mul (bottomHalf arg_x) (bottomHalf arg_y)), + mkAssign xlyh + (mul (bottomHalf arg_x) (topHalf arg_y)), + mkAssign xhyl + (mul (topHalf arg_x) (bottomHalf arg_y)), + mkAssign r + (sum $ + topHalf (CmmReg xlyl) :| + bottomHalf (CmmReg xhyl) : + bottomHalf (CmmReg xlyh) : + []), + mkAssign (CmmLocal res_l) + (or (bottomHalf (CmmReg xlyl)) + (toTopHalf (CmmReg r))), + mkAssign (CmmLocal res_h) + (sum $ + mul (topHalf arg_x) (topHalf arg_y) :| + topHalf (CmmReg xhyl) : + topHalf (CmmReg xlyh) : + topHalf (CmmReg r) : + [])] +genericWordMul2Op _ _ = panic "genericWordMul2Op" + +genericIntMul2Op :: GenericOp +genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y] + = do cfg <- getStgToCmmConfig + -- Implement algorithm from Hacker's Delight, 2nd edition, p.174 + let t = cmmExprType platform arg_x + platform = stgToCmmPlatform cfg + p <- newTemp t + -- 1) compute the multiplication as if numbers were unsigned + _ <- withSequel (AssignTo [p, res_l] False) $ + cmmPrimOpApp cfg WordMul2Op both_args Nothing + -- 2) correct the high bits of the unsigned result + let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1] + sub x y = CmmMachOp (MO_Sub ww) [x, y] + and x y = CmmMachOp (MO_And ww) [x, y] + neq x y = CmmMachOp (MO_Ne ww) [x, y] + f x y = (carryFill x) `and` y + wwm1 = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww) + rl x = CmmReg (CmmLocal x) + ww = wordWidth platform + emit $ catAGraphs + [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x) + , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l)) + ] +genericIntMul2Op _ _ = panic "genericIntMul2Op" + +fmaCCall :: Width -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> FCode () +fmaCCall width res arg_x arg_y arg_z = + emitCCall + [(res,NoHint)] + (CmmLit (CmmLabel fma_lbl)) + [(arg_x,NoHint), (arg_y,NoHint), (arg_z,NoHint)] + where + fma_lbl = mkForeignLabel fma_op ForeignLabelInExternalPackage IsFunction + fma_op = case width of + W32 -> fsLit "fmaf" + W64 -> fsLit "fma" + _ -> panic ("fmaCall: " ++ show width) + +------------------------------------------------------------------------------ +-- Helpers for translating various minor variants of array indexing. + +alignmentFromTypes :: CmmType -- ^ element type + -> CmmType -- ^ index type + -> AlignmentSpec +alignmentFromTypes ty idx_ty + | typeWidth ty <= typeWidth idx_ty = NaturallyAligned + | otherwise = Unaligned + +doIndexOffAddrOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx] + = mkBasicIndexedRead False NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx +doIndexOffAddrOp _ _ _ _ + = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp" + +doIndexOffAddrOpAs :: Maybe MachOp + -> CmmType + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] + = let alignment = alignmentFromTypes rep idx_rep + in mkBasicIndexedRead False alignment 0 maybe_post_read_cast rep res addr idx_rep idx +doIndexOffAddrOpAs _ _ _ _ _ + = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs" + +doIndexByteArrayOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] + = do profile <- getProfile + doByteArrayBoundsCheck idx addr rep rep + mkBasicIndexedRead False NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx +doIndexByteArrayOp _ _ _ _ + = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" + +doIndexByteArrayOpAs :: Maybe MachOp + -> CmmType + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] + = do profile <- getProfile + doByteArrayBoundsCheck idx addr idx_rep rep + let alignment = alignmentFromTypes rep idx_rep + mkBasicIndexedRead False alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx +doIndexByteArrayOpAs _ _ _ _ _ + = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" + +doReadPtrArrayOp :: LocalReg + -> CmmExpr + -> CmmExpr + -> FCode () +doReadPtrArrayOp res addr idx + = do profile <- getProfile + platform <- getPlatform + doPtrArrayBoundsCheck idx addr + mkBasicIndexedRead True NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx + +doWriteOffAddrOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doWriteOffAddrOp castOp idx_ty [] [addr,idx, val] + = mkBasicIndexedWrite False 0 addr idx_ty idx (maybeCast castOp val) +doWriteOffAddrOp _ _ _ _ + = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp" + +doWriteByteArrayOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doWriteByteArrayOp castOp idx_ty [] [addr,idx, rawVal] + = do profile <- getProfile + platform <- getPlatform + let val = maybeCast castOp rawVal + doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val) + mkBasicIndexedWrite False (arrWordsHdrSize profile) addr idx_ty idx val +doWriteByteArrayOp _ _ _ _ + = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp" + +doWritePtrArrayOp :: CmmExpr + -> CmmExpr + -> CmmExpr + -> FCode () +doWritePtrArrayOp addr idx val + = do profile <- getProfile + platform <- getPlatform + let ty = cmmExprType platform val + hdr_size = arrPtrsHdrSize profile + + doPtrArrayBoundsCheck idx addr + + -- Update remembered set for non-moving collector + whenUpdRemSetEnabled + $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform NaturallyAligned hdr_size ty addr ty idx) + -- This write barrier is to ensure that the heap writes to the object + -- referred to by val have happened before we write val into the array. + -- See #12469 for details. + mkBasicIndexedWrite True hdr_size addr ty idx val + + emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + -- the write barrier. We must write a byte into the mark table: + -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] + emit $ mkStore ( + cmmOffsetExpr platform + (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size) + (ptrArraySize platform profile addr)) + (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))]) + ) (CmmLit (CmmInt 1 W8)) + +mkBasicIndexedRead :: Bool -- Should this imply an acquire barrier + -> AlignmentSpec + -> ByteOff -- Initial offset in bytes + -> Maybe MachOp -- Optional result cast + -> CmmType -- Type of element we are accessing + -> LocalReg -- Destination + -> CmmExpr -- Base address + -> CmmType -- Type of element by which we are indexing + -> CmmExpr -- Index + -> FCode () +mkBasicIndexedRead barrier alignment off mb_cast ty res base idx_ty idx + = do platform <- getPlatform + let addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx + result <- + if barrier + then do + res <- newTemp ty + emitPrimCall [res] (MO_AtomicRead (typeWidth ty) MemOrderAcquire) [addr] + return $ CmmReg (CmmLocal res) + else + return $ CmmLoad addr ty alignment + + let casted = + case mb_cast of + Just cast -> CmmMachOp cast [result] + Nothing -> result + emitAssign (CmmLocal res) casted + +mkBasicIndexedWrite :: Bool -- Should this imply a release barrier + -> ByteOff -- Initial offset in bytes + -> CmmExpr -- Base address + -> CmmType -- Type of element by which we are indexing + -> CmmExpr -- Index + -> CmmExpr -- Value to write + -> FCode () +mkBasicIndexedWrite barrier off base idx_ty idx val + = do platform <- getPlatform + let alignment = alignmentFromTypes (cmmExprType platform val) idx_ty + addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx + if barrier + then let w = typeWidth idx_ty + op = MO_AtomicWrite w MemOrderRelease + in emitPrimCall [] op [addr, val] + else emitStore' alignment addr val + +-- ---------------------------------------------------------------------------- +-- Misc utils + +cmmIndexOffExpr :: Platform + -> ByteOff -- Initial offset in bytes + -> Width -- Width of element by which we are indexing + -> CmmExpr -- Base address + -> CmmExpr -- Index + -> CmmExpr +cmmIndexOffExpr platform off width base idx + = cmmIndexExpr platform width (cmmOffsetB platform base off) idx + +cmmLoadIndexOffExpr :: Platform + -> AlignmentSpec + -> ByteOff -- Initial offset in bytes + -> CmmType -- Type of element we are accessing + -> CmmExpr -- Base address + -> CmmType -- Type of element by which we are indexing + -> CmmExpr -- Index + -> CmmExpr +cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx + = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty alignment + +setInfo :: CmmExpr -> CmmExpr -> CmmAGraph +setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr + +maybeCast :: Maybe MachOp -> CmmExpr -> CmmExpr +maybeCast Nothing val = val +maybeCast (Just cast) val = CmmMachOp cast [val] + +ptrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr +ptrArraySize platform profile arr = + cmmLoadBWord platform (cmmOffsetB platform arr sz_off) + where sz_off = fixedHdrSize profile + + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform) + +smallPtrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr +smallPtrArraySize platform profile arr = + cmmLoadBWord platform (cmmOffsetB platform arr sz_off) + where sz_off = fixedHdrSize profile + + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform) + +byteArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr +byteArraySize platform profile arr = + cmmLoadBWord platform (cmmOffsetB platform arr sz_off) + where sz_off = fixedHdrSize profile + + pc_OFFSET_StgArrBytes_bytes (platformConstants platform) + + + +------------------------------------------------------------------------------ +-- Helpers for translating vector primops. + +vecCmmType :: PrimOpVecCat -> Length -> Width -> CmmType +vecCmmType pocat n w = vec n (vecCmmCat pocat w) + +vecCmmCat :: PrimOpVecCat -> Width -> CmmType +vecCmmCat IntVec = cmmBits +vecCmmCat WordVec = cmmBits +vecCmmCat FloatVec = cmmFloat + +-- Note [SIMD Design for the future] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Check to make sure that we can generate code for the specified vector type +-- given the current set of dynamic flags. +-- Currently these checks are specific to x86, x86_64 and AArch64 architectures. +-- This should be fixed! +-- In particular, +-- 1) Add better support for other architectures! (this may require a redesign) +-- 2) Decouple design choices from LLVM's pseudo SIMD model! +-- The high level LLVM naive rep makes per CPU family SIMD generation is own +-- optimization problem, and hides important differences in eg ARM vs x86_64 simd +-- 3) Depending on the architecture, the SIMD registers may also support general +-- computations on Float/Double/Word/Int scalars, but currently on +-- for example x86_64, we always put Word/Int (or sized) in GPR +-- (general purpose) registers. Would relaxing that allow for +-- useful optimization opportunities? +-- Phrased differently, it is worth experimenting with supporting +-- different register mapping strategies than we currently have, especially if +-- someday we want SIMD to be a first class denizen in GHC along with scalar +-- values! +-- The current design with respect to register mapping of scalars could +-- very well be the best,but exploring the design space and doing careful +-- measurements is the only way to validate that. +-- In some next generation CPU ISAs, notably RISC V, the SIMD extension +-- includes support for a sort of run time CPU dependent vectorization parameter, +-- where a loop may act upon a single scalar each iteration OR some 2,4,8 ... +-- element chunk! Time will tell if that direction sees wide adoption, +-- but it is from that context that unifying our handling of simd and scalars +-- may benefit. It is not likely to benefit current architectures, though +-- it may very well be a design perspective that helps guide improving the NCG. + + +checkVecCompatibility :: StgToCmmConfig -> PrimOpVecCat -> Length -> Width -> FCode () +checkVecCompatibility cfg vcat l w = + case stgToCmmVecInstrsErr cfg of + Nothing | isX86 -> checkX86 vecWidth vcat l w + | platformArch platform == ArchAArch64 -> checkAArch64 vecWidth + | otherwise -> sorry "SIMD vector instructions are not supported on this architecture." + Just err -> sorry err -- incompatible backend, do panic + where + platform = stgToCmmPlatform cfg + isX86 = case platformArch platform of + ArchX86_64 -> True + ArchX86 -> True + _ -> False + checkX86 :: Width -> PrimOpVecCat -> Length -> Width -> FCode () + checkX86 W128 FloatVec 4 W32 | isSseEnabled platform = return () + | otherwise = + sorry $ "128-bit wide single-precision floating point " ++ + "SIMD vector instructions require at least -msse." + checkX86 W128 _ _ _ | not (isSse2Enabled platform) = + sorry $ "128-bit wide integer and double precision " ++ + "SIMD vector instructions require at least -msse2." + checkX86 W256 FloatVec _ _ | stgToCmmAvx cfg = return () + | otherwise = + sorry $ "256-bit wide floating point " ++ + "SIMD vector instructions require at least -mavx." + checkX86 W256 _ _ _ | not (stgToCmmAvx2 cfg) = + sorry $ "256-bit wide integer " ++ + "SIMD vector instructions require at least -mavx2." + checkX86 W512 _ _ _ | not (stgToCmmAvx512f cfg) = + sorry $ "512-bit wide " ++ + "SIMD vector instructions require -mavx512f." + checkX86 _ _ _ _ = return () + + checkAArch64 :: Width -> FCode () + checkAArch64 W256 = sorry $ "256-bit wide SIMD vector instructions are not supported." + checkAArch64 W512 = sorry $ "512-bit wide SIMD vector instructions are not supported." + checkAArch64 _ = return () + + vecWidth = typeWidth (vecCmmType vcat l w) + +------------------------------------------------------------------------------ +-- Helpers for translating vector packing and unpacking. + +doVecBroadcastOp :: CmmType -- Type of vector + -> CmmExpr -- Element + -> CmmFormal -- Destination for result + -> FCode () +doVecBroadcastOp ty e dst + | isFloatType (vecElemType ty) + = emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Broadcast len wid) [e]) + | otherwise + = emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Broadcast len wid) [e]) + where + len :: Length + len = vecLength ty + wid :: Width + wid = typeWidth (vecElemType ty) + +doVecPackOp :: CmmType -- Type of vector + -> [CmmExpr] -- Elements + -> CmmFormal -- Destination for result + -> FCode () +doVecPackOp ty es dst = do + emitAssign (CmmLocal dst) (CmmLit $ CmmVec (replicate l zero)) + zipWithM_ vecPack es [0..] + where + -- SIMD NCG TODO: it should be possible to emit better code + -- for "pack" than doing a bunch of vector insertions in a row. + vecPack :: CmmExpr -> Int -> FCode () + vecPack e i + | isFloatType (vecElemType ty) + = emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert l w) + [CmmReg (CmmLocal dst), e, iLit]) + | otherwise + = emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert l w) + [CmmReg (CmmLocal dst), e, iLit]) + where + -- vector indices are always 32-bits + iLit = CmmLit (CmmInt (toInteger i) W32) + + l :: Length + l = vecLength ty + w :: Width + w = typeWidth (vecElemType ty) + + zero :: CmmLit + zero + | isFloatType (vecElemType ty) + = CmmFloat 0 w + | otherwise + = CmmInt 0 w + +doVecUnpackOp :: CmmType -- Type of vector + -> CmmExpr -- Vector + -> [CmmFormal] -- Element results + -> FCode () +doVecUnpackOp ty e res = zipWithM_ vecUnpack res [0..] + where + vecUnpack :: CmmFormal -> Int -> FCode () + vecUnpack r i + | isFloatType (vecElemType ty) + = emitAssign (CmmLocal r) (CmmMachOp (MO_VF_Extract len wid) [e, iLit]) + | otherwise + = emitAssign (CmmLocal r) (CmmMachOp (MO_V_Extract len wid) [e, iLit]) + where + -- vector indices are always 32-bits + iLit = CmmLit (CmmInt (toInteger i) W32) + + len :: Length + len = vecLength ty + + wid :: Width + wid = typeWidth (vecElemType ty) + +doVecInsertOp :: CmmType -- Vector type + -> CmmExpr -- Source vector + -> CmmExpr -- Element + -> CmmExpr -- Index at which to insert element + -> CmmFormal -- Destination for result + -> FCode () +doVecInsertOp ty src e idx res = do + platform <- getPlatform + -- vector indices are always 32-bits + let idx' :: CmmExpr + idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx] + if isFloatType (vecElemType ty) + then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, e, idx']) + else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, e, idx']) + where + + len :: Length + len = vecLength ty + + wid :: Width + wid = typeWidth (vecElemType ty) + +------------------------------------------------------------------------------ +-- Shuffles + +doShuffleOp :: CmmType -> [CmmExpr] -> LocalReg -> FCode () +doShuffleOp ty (v1:v2:idxs) res + | isVecType ty + -- The type checker ensures that the indices have the correct length, + -- so we only need to check whether the indices are constants and within the valid range. + = case mapMaybe idx_maybe idxs of + is + | length is == len + -> emitAssign (CmmLocal res) (CmmMachOp (mo is) [v1,v2]) + | otherwise + -> pgmErrorDoc "Vector shuffle:" $ + vcat [ text "shuffle indices must be literals, 0 <= i <" <+> ppr (2 * len) ] + | otherwise + = pprPanic "doShuffleOp" $ + vcat [ text "non-vector argument type:" <+> ppr ty ] + where + len = vecLength ty + wid = typeWidth $ vecElemType ty + mo = if isFloatType (vecElemType ty) + then MO_VF_Shuffle len wid + else MO_V_Shuffle len wid + idx_maybe (CmmLit (CmmInt i _)) + | let j :: Int; j = fromInteger i + , j >= 0, j < 2 * len + = Just j + idx_maybe _ = Nothing +doShuffleOp _ _ _ = + panic "doShuffleOp: wrong number of arguments" + +------------------------------------------------------------------------------ +-- Helpers for translating prefetching. + + +-- | Translate byte array prefetch operations into proper primcalls. +doPrefetchByteArrayOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchByteArrayOp locality [addr,idx] + = do profile <- getProfile + mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx +doPrefetchByteArrayOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" + +-- | Translate mutable byte array prefetch operations into proper primcalls. +doPrefetchMutableByteArrayOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchMutableByteArrayOp locality [addr,idx] + = do profile <- getProfile + mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx +doPrefetchMutableByteArrayOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" + +-- | Translate address prefetch operations into proper primcalls. +doPrefetchAddrOp ::Int + -> [CmmExpr] + -> FCode () +doPrefetchAddrOp locality [addr,idx] + = mkBasicPrefetch locality 0 addr idx +doPrefetchAddrOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchAddrOp" + +-- | Translate value prefetch operations into proper primcalls. +doPrefetchValueOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchValueOp locality [addr] + = do platform <- getPlatform + mkBasicPrefetch locality 0 addr (CmmLit (CmmInt 0 (wordWidth platform))) +doPrefetchValueOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchValueOp" + +-- | helper to generate prefetch primcalls +mkBasicPrefetch :: Int -- Locality level 0-3 + -> ByteOff -- Initial offset in bytes + -> CmmExpr -- Base address + -> CmmExpr -- Index + -> FCode () +mkBasicPrefetch locality off base idx + = do platform <- getPlatform + emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr platform W8 (cmmOffsetB platform base off) idx] + return () + +-- ---------------------------------------------------------------------------- +-- Allocating byte arrays + +-- | Takes a register to return the newly allocated array in and the +-- size of the new array in bytes. Allocates a new +-- 'MutableByteArray#'. +doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode () +doNewByteArrayOp res_r n = do + profile <- getProfile + platform <- getPlatform + + let info_ptr = mkLblExpr mkArrWords_infoLabel + rep = arrWordsRep platform n + + tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize profile)) + (mkIntExpr platform (nonHdrSize platform rep)) + (zeroExpr platform) + + let hdr_size = fixedHdrSize profile + + base <- allocHeapClosure rep info_ptr (cccsExpr platform) + [ (mkIntExpr platform n, + hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)) + ] + + emit $ mkAssign (CmmLocal res_r) base + +-- ---------------------------------------------------------------------------- +-- Comparing byte arrays + +doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do + profile <- getProfile + platform <- getPlatform + + whenCheckBounds $ ifNonZero n $ do + emitRangeBoundsCheck ba1_off n (byteArraySize platform profile ba1) + emitRangeBoundsCheck ba2_off n (byteArraySize platform profile ba2) + + ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off + ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off + + -- short-cut in case of equal pointers avoiding a costly + -- subroutine call to the memcmp(3) routine; the Cmm logic below + -- results in assembly code being generated for + -- + -- cmpPrefix10 :: ByteArray# -> ByteArray# -> Int# + -- cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10# + -- + -- that looks like + -- + -- leaq 16(%r14),%rax + -- leaq 16(%rsi),%rbx + -- xorl %ecx,%ecx + -- cmpq %rbx,%rax + -- je l_ptr_eq + -- + -- ; NB: the common case (unequal pointers) falls-through + -- ; the conditional jump, and therefore matches the + -- ; usual static branch prediction convention of modern cpus + -- + -- subq $8,%rsp + -- movq %rbx,%rsi + -- movq %rax,%rdi + -- movl $10,%edx + -- xorl %eax,%eax + -- call memcmp + -- addq $8,%rsp + -- movslq %eax,%rax + -- movq %rax,%rcx + -- l_ptr_eq: + -- movq %rcx,%rbx + -- jmp *(%rbp) + + l_ptr_eq <- newBlockId + l_ptr_ne <- newBlockId + + emit (mkAssign (CmmLocal res) (zeroExpr platform)) + emit (mkCbranch (cmmEqWord platform ba1_p ba2_p) + l_ptr_eq l_ptr_ne (Just False)) + + emitLabel l_ptr_ne + emitMemcmpCall res ba1_p ba2_p n 1 + + emitLabel l_ptr_eq + +-- ---------------------------------------------------------------------------- +-- Copying byte arrays + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'MutableByteArray#', an offset into the destination +-- array, and the number of bytes to copy. Copies the given number of +-- bytes from the source array to the destination array. +doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyByteArrayOp = emitCopyByteArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes align = + emitCheckedMemcpyCall dst_p src_p bytes align + +-- | Takes a source 'MutableByteArray#', an offset in the source +-- array, a destination 'MutableByteArray#', an offset into the +-- destination array, and the number of bytes to copy. Copies the +-- given number of bytes from the source array to the destination +-- array. +doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayOp = emitCopyByteArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes align = do + platform <- getPlatform + (moveCall, cpyCall) <- forkAltPair + (getCode $ emitMemmoveCall dst_p src_p bytes align) + (getCode $ emitMemcpyCall dst_p src_p bytes align) + emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall + +-- | Takes a source 'MutableByteArray#', an offset in the source +-- array, a destination 'MutableByteArray#', an offset into the +-- destination array, and the number of bytes to copy. Copies the +-- given number of bytes from the source array to the destination +-- array. Assumes the two ranges are disjoint +doCopyMutableByteArrayNonOverlappingOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayNonOverlappingOp = emitCopyByteArray copy + where + copy _src _dst dst_p src_p bytes align = do + emitCheckedMemcpyCall dst_p src_p bytes align + + +emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> Alignment -> FCode ()) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +emitCopyByteArray copy src src_off dst dst_off n = do + profile <- getProfile + platform <- getPlatform + + whenCheckBounds $ ifNonZero n $ do + emitRangeBoundsCheck src_off n (byteArraySize platform profile src) + emitRangeBoundsCheck dst_off n (byteArraySize platform profile dst) + + let byteArrayAlignment = wordAlignment platform + srcOffAlignment = cmmExprAlignment src_off + dstOffAlignment = cmmExprAlignment dst_off + align = minimum (byteArrayAlignment :| srcOffAlignment : dstOffAlignment : []) + dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off + src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off + copy src dst dst_p src_p n align + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'Addr#', and the number of bytes to copy. Copies the given +-- number of bytes from the source array to the destination memory region. +doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyByteArrayToAddrOp src src_off dst_p bytes = do + -- Use memcpy (we are allowed to assume the arrays aren't overlapping) + profile <- getProfile + platform <- getPlatform + whenCheckBounds $ ifNonZero bytes $ do + emitRangeBoundsCheck src_off bytes (byteArraySize platform profile src) + src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off + emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) + +-- | Takes a source 'MutableByteArray#', an offset in the source array, a +-- destination 'Addr#', and the number of bytes to copy. Copies the given +-- number of bytes from the source array to the destination memory region. +doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp + +-- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into +-- the destination array, and the number of bytes to copy. Copies the given +-- number of bytes from the source memory region to the destination array. +doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyAddrToByteArrayOp src_p dst dst_off bytes = do + -- Use memcpy (we are allowed to assume the arrays aren't overlapping) + profile <- getProfile + platform <- getPlatform + whenCheckBounds $ ifNonZero bytes $ do + emitRangeBoundsCheck dst_off bytes (byteArraySize platform profile dst) + dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off + emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) + +-- | Takes a source 'Addr#', a destination 'Addr#', and the number of +-- bytes to copy. Copies the given number of bytes from the source +-- memory region to the destination array. +doCopyAddrToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyAddrToAddrOp src_p dst_p bytes = do + -- Use memmove; the ranges may overlap + emitMemmoveCall dst_p src_p bytes (mkAlignment 1) + +-- | Takes a source 'Addr#', a destination 'Addr#', and the number of +-- bytes to copy. Copies the given number of bytes from the source +-- memory region to the destination region. The regions may not overlap. +doCopyAddrToAddrNonOverlappingOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyAddrToAddrNonOverlappingOp src_p dst_p bytes = do + -- Use memcpy; the ranges may not overlap + emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) + +ifNonZero :: CmmExpr -> FCode () -> FCode () +ifNonZero e it = do + platform <- getPlatform + let pred = cmmNeWord platform e (zeroExpr platform) + code <- getCode it + emit =<< mkCmmIfThen' pred code (Just True) + -- This function is used for range operation bounds-checks; + -- Most calls to those ops will not have range length zero. + + +-- ---------------------------------------------------------------------------- +-- Setting byte arrays + +-- | Takes a 'MutableByteArray#', an offset into the array, a length, +-- and a byte, and sets each of the selected bytes in the array to the +-- given byte. +doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doSetByteArrayOp ba off len c = do + profile <- getProfile + platform <- getPlatform + + whenCheckBounds $ ifNonZero len $ + emitRangeBoundsCheck off len (byteArraySize platform profile ba) + + let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap + offsetAlignment = cmmExprAlignment off + align = min byteArrayAlignment offsetAlignment + + p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize profile)) off + emitMemsetCall p c len align + +-- | Takes an 'Addr#', a length, and a byte, and sets each of the +-- selected bytes in memory to the given byte. +doSetAddrRangeOp :: CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doSetAddrRangeOp dst len c = do + emitMemsetCall dst c len (mkAlignment 1) + + +-- ---------------------------------------------------------------------------- +-- Allocating arrays + +-- | Allocate a new array. +doNewArrayOp :: CmmFormal -- ^ return register + -> SMRep -- ^ representation of the array + -> CLabel -- ^ info pointer + -> [(CmmExpr, ByteOff)] -- ^ header payload + -> WordOff -- ^ array size + -> CmmExpr -- ^ initial element + -> FCode () +doNewArrayOp res_r rep info payload n init = do + profile <- getProfile + platform <- getPlatform + + let info_ptr = mkLblExpr info + + tickyAllocPrim (mkIntExpr platform (hdrSize profile rep)) + (mkIntExpr platform (nonHdrSize platform rep)) + (zeroExpr platform) + + base <- allocHeapClosure rep info_ptr (cccsExpr platform) payload + + arr <- CmmLocal `fmap` newTemp (bWord platform) + emit $ mkAssign arr base + + -- Initialise all elements of the array + let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW profile rep + off) + initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ] + emit (catAGraphs initialization) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- ---------------------------------------------------------------------------- +-- Copying pointer arrays + +-- EZY: This code has an unusually high amount of assignTemp calls, seen +-- nowhere else in the code generator. This is mostly because these +-- "primitive" ops result in a surprisingly large amount of code. It +-- will likely be worthwhile to optimize what is emitted here, so that +-- our optimization passes don't waste time repeatedly optimizing the +-- same bits of code. + +-- More closely imitates 'assignTemp' from the old code generator, which +-- returns a CmmExpr rather than a LocalReg. +assignTempE :: CmmExpr -> FCode CmmExpr +assignTempE e = do + t <- assignTemp e + return (CmmReg (CmmLocal t)) + +-- | Takes a source 'Array#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopyArrayOp = emitCopyArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes = + do platform <- getPlatform + emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform) + + +-- | Takes a source 'MutableArray#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopyMutableArrayOp = emitCopyArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes = do + platform <- getPlatform + (moveCall, cpyCall) <- forkAltPair + (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall + +emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff + -> FCode ()) -- ^ copy function + -> CmmExpr -- ^ source array + -> CmmExpr -- ^ offset in source array + -> CmmExpr -- ^ destination array + -> CmmExpr -- ^ offset in destination array + -> WordOff -- ^ number of elements to copy + -> FCode () +emitCopyArray copy src0 src_off dst0 dst_off0 n = + when (n /= 0) $ do + profile <- getProfile + platform <- getPlatform + + -- Passed as arguments (be careful) + src <- assignTempE src0 + dst <- assignTempE dst0 + dst_off <- assignTempE dst_off0 + + whenCheckBounds $ do + emitRangeBoundsCheck src_off (mkIntExpr platform n) + (ptrArraySize platform profile src) + emitRangeBoundsCheck dst_off (mkIntExpr platform n) + (ptrArraySize platform profile dst) + + -- Nonmoving collector write barrier + emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n + + -- Set the dirty bit in the header. + emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + + dst_elems_p <- assignTempE $ cmmOffsetB platform dst + (arrPtrsHdrSize profile) + dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off + src_p <- assignTempE $ cmmOffsetExprW platform + (cmmOffsetB platform src (arrPtrsHdrSize profile)) src_off + let bytes = wordsToBytes platform n + + copy src dst dst_p src_p bytes + + -- The base address of the destination card table + dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p + (ptrArraySize platform profile dst) + + emitSetCards dst_off dst_cards_p n + +doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopySmallArrayOp = emitCopySmallArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes = + do platform <- getPlatform + emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform) + + +doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopySmallMutableArrayOp = emitCopySmallArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes = do + platform <- getPlatform + (moveCall, cpyCall) <- forkAltPair + (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall + +emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff + -> FCode ()) -- ^ copy function + -> CmmExpr -- ^ source array + -> CmmExpr -- ^ offset in source array + -> CmmExpr -- ^ destination array + -> CmmExpr -- ^ offset in destination array + -> WordOff -- ^ number of elements to copy + -> FCode () +emitCopySmallArray copy src0 src_off dst0 dst_off n = + when (n /= 0) $ do + profile <- getProfile + platform <- getPlatform + + -- Passed as arguments (be careful) + src <- assignTempE src0 + dst <- assignTempE dst0 + + whenCheckBounds $ do + emitRangeBoundsCheck src_off (mkIntExpr platform n) + (smallPtrArraySize platform profile src) + emitRangeBoundsCheck dst_off (mkIntExpr platform n) + (smallPtrArraySize platform profile dst) + + -- Nonmoving collector write barrier + emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n + + -- Set the dirty bit in the header. + emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) + + dst_p <- assignTempE $ cmmOffsetExprW platform + (cmmOffsetB platform dst (smallArrPtrsHdrSize profile)) dst_off + src_p <- assignTempE $ cmmOffsetExprW platform + (cmmOffsetB platform src (smallArrPtrsHdrSize profile)) src_off + let bytes = wordsToBytes platform n + + copy src dst dst_p src_p bytes + +-- | Takes an info table label, a register to return the newly +-- allocated array in, a source array, an offset in the source array, +-- and the number of elements to copy. Allocates a new array and +-- initializes it from the source array. +emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +emitCloneArray info_p res_r src src_off n = do + profile <- getProfile + platform <- getPlatform + + let info_ptr = mkLblExpr info_p + rep = arrPtrsRep platform n + + tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize profile)) + (mkIntExpr platform (nonHdrSize platform rep)) + (zeroExpr platform) + + let hdr_size = fixedHdrSize profile + constants = platformConstants platform + + base <- allocHeapClosure rep info_ptr (cccsExpr platform) + [ (mkIntExpr platform n, + hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants) + , (mkIntExpr platform (nonHdrSizeW rep), + hdr_size + pc_OFFSET_StgMutArrPtrs_size constants) + ] + + arr <- CmmLocal `fmap` newTemp (bWord platform) + emit $ mkAssign arr base + + dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) + (arrPtrsHdrSize profile) + src_p <- assignTempE $ cmmOffsetExprW platform src + (cmmAddWord platform + (mkIntExpr platform (arrPtrsHdrSizeW profile)) src_off) + + emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) + (wordAlignment platform) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- | Takes an info table label, a register to return the newly +-- allocated array in, a source array, an offset in the source array, +-- and the number of elements to copy. Allocates a new array and +-- initializes it from the source array. +emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +emitCloneSmallArray info_p res_r src src_off n = do + profile <- getProfile + platform <- getPlatform + + let info_ptr = mkLblExpr info_p + rep = smallArrPtrsRep n + + tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize profile)) + (mkIntExpr platform (nonHdrSize platform rep)) + (zeroExpr platform) + + let hdr_size = fixedHdrSize profile + + base <- allocHeapClosure rep info_ptr (cccsExpr platform) + [ (mkIntExpr platform n, + hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) + ] + + arr <- CmmLocal `fmap` newTemp (bWord platform) + emit $ mkAssign arr base + + dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) + (smallArrPtrsHdrSize profile) + src_p <- assignTempE $ cmmOffsetExprW platform src + (cmmAddWord platform + (mkIntExpr platform (smallArrPtrsHdrSizeW profile)) src_off) + + emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) + (wordAlignment platform) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- | Takes an offset in the destination array, the base address of +-- the card table, and the number of elements affected (*not* the +-- number of cards). The number of elements may not be zero. +-- Marks the relevant cards as dirty. +emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode () +emitSetCards dst_start dst_cards_start n = do + platform <- getPlatform + start_card <- assignTempE $ cardCmm platform dst_start + let end_card = cardCmm platform + (cmmSubWord platform + (cmmAddWord platform dst_start (mkIntExpr platform n)) + (mkIntExpr platform 1)) + emitMemsetCall (cmmAddWord platform dst_cards_start start_card) + (mkIntExpr platform 1) + (cmmAddWord platform (cmmSubWord platform end_card start_card) (mkIntExpr platform 1)) + (mkAlignment 1) -- no alignment (1 byte) + +-- Convert an element index to a card index +cardCmm :: Platform -> CmmExpr -> CmmExpr +cardCmm platform i = + cmmUShrWord platform i (mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))) + +------------------------------------------------------------------------------ +-- SmallArray PrimOp implementations + +doReadSmallPtrArrayOp :: LocalReg + -> CmmExpr + -> CmmExpr + -> FCode () +doReadSmallPtrArrayOp res addr idx = do + profile <- getProfile + platform <- getPlatform + doSmallPtrArrayBoundsCheck idx addr + mkBasicIndexedRead True NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr + (gcWord platform) idx + +doWriteSmallPtrArrayOp :: CmmExpr + -> CmmExpr + -> CmmExpr + -> FCode () +doWriteSmallPtrArrayOp addr idx val = do + profile <- getProfile + platform <- getPlatform + let ty = cmmExprType platform val + + doSmallPtrArrayBoundsCheck idx addr + + -- Update remembered set for non-moving collector + tmp <- newTemp ty + mkBasicIndexedRead False NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx + whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) + + -- Write barrier needed due to #12469 + mkBasicIndexedWrite True (smallArrPtrsHdrSize profile) addr ty idx val + emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) + +------------------------------------------------------------------------------ +-- Atomic read-modify-write + +-- | Emit an atomic modification to a byte array element. The result +-- reg contains that previous value of the element. Implies a full +-- memory barrier. +doAtomicByteArrayRMW + :: LocalReg -- ^ Result reg + -> AtomicMachOp -- ^ Atomic op (e.g. add) + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Op argument (e.g. amount to add) + -> FCode () +doAtomicByteArrayRMW res amop mba idx idx_ty n = do + profile <- getProfile + platform <- getPlatform + doByteArrayBoundsCheck idx mba idx_ty idx_ty + let width = typeWidth idx_ty + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) + width mba idx + doAtomicAddrRMW res amop addr idx_ty n + +doAtomicAddrRMW + :: LocalReg -- ^ Result reg + -> AtomicMachOp -- ^ Atomic op (e.g. add) + -> CmmExpr -- ^ Addr# + -> CmmType -- ^ Pointed value type + -> CmmExpr -- ^ Op argument (e.g. amount to add) + -> FCode () +doAtomicAddrRMW res amop addr ty n = + emitPrimCall + [ res ] + (MO_AtomicRMW (typeWidth ty) amop) + [ addr, n ] + +-- | Emit an atomic read to a byte array that acts as a memory barrier. +doAtomicReadByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> FCode () +doAtomicReadByteArray res mba idx idx_ty = do + profile <- getProfile + platform <- getPlatform + doByteArrayBoundsCheck idx mba idx_ty idx_ty + let width = typeWidth idx_ty + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) + width mba idx + doAtomicReadAddr res addr idx_ty + +-- | Emit an atomic read to an address that acts as a memory barrier. +doAtomicReadAddr + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ Addr# + -> CmmType -- ^ Type of element by which we are indexing + -> FCode () +doAtomicReadAddr res addr ty = + emitPrimCall + [ res ] + (MO_AtomicRead (typeWidth ty) MemOrderSeqCst) + [ addr ] + +-- | Emit an atomic write to a byte array that acts as a memory barrier. +doAtomicWriteByteArray + :: CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Value to write + -> FCode () +doAtomicWriteByteArray mba idx idx_ty val = do + profile <- getProfile + platform <- getPlatform + doByteArrayBoundsCheck idx mba idx_ty idx_ty + let width = typeWidth idx_ty + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) + width mba idx + doAtomicWriteAddr addr idx_ty val + +-- | Emit an atomic write to an address that acts as a memory barrier. +doAtomicWriteAddr + :: CmmExpr -- ^ Addr# + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Value to write + -> FCode () +doAtomicWriteAddr addr ty val = + emitPrimCall + [ {- no results -} ] + (MO_AtomicWrite (typeWidth ty) MemOrderSeqCst) + [ addr, val ] + +doCasByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Old value + -> CmmExpr -- ^ New value + -> FCode () +doCasByteArray res mba idx idx_ty old new = do + profile <- getProfile + platform <- getPlatform + doByteArrayBoundsCheck idx mba idx_ty idx_ty + let width = typeWidth idx_ty + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) + width mba idx + emitPrimCall + [ res ] + (MO_Cmpxchg width) + [ addr, old, new ] + +------------------------------------------------------------------------------ +-- Helpers for emitting function calls + +-- | Emit a call to @memcpy@. +emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitMemcpyCall dst src n align = + emitPrimCall + [ {-no results-} ] + (MO_Memcpy (alignmentBytes align)) + [ dst, src, n ] + +-- | Emit a call to @memcpy@, but check for range +-- overlap when -fcheck-prim-bounds is on. +emitCheckedMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitCheckedMemcpyCall dst src n align = do + whenCheckBounds (getPlatform >>= doCheck) + emitMemcpyCall dst src n align + where + doCheck platform = do + overlapCheckFailed <- getCode $ + emitCCallNeverReturns [] (mkLblExpr mkMemcpyRangeOverlapLabel) [] + emit =<< mkCmmIfThen' rangesOverlap overlapCheckFailed (Just False) + where + rangesOverlap = (checkDiff dst src `or` checkDiff src dst) `ne` zero + checkDiff p q = (p `minus` q) `uLT` n + or = cmmOrWord platform + minus = cmmSubWord platform + uLT = cmmULtWord platform + ne = cmmNeWord platform + zero = zeroExpr platform + +-- | Emit a call to @memmove@. +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitMemmoveCall dst src n align = + emitPrimCall + [ {- no results -} ] + (MO_Memmove (alignmentBytes align)) + [ dst, src, n ] + +-- | Emit a call to @memset@. The second argument must fit inside an +-- unsigned char. +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitMemsetCall dst c n align = + emitPrimCall + [ {- no results -} ] + (MO_Memset (alignmentBytes align)) + [ dst, c, n ] + +emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode () +emitMemcmpCall res ptr1 ptr2 n align = do + -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all + -- code-gens currently call out to the @memcmp(3)@ C function. + -- This was easier than moving the sign-extensions into + -- all the code-gens. + platform <- getPlatform + let is32Bit = typeWidth (localRegType res) == W32 + + cres <- if is32Bit + then return res + else newTemp b32 + + emitPrimCall + [ cres ] + (MO_Memcmp align) + [ ptr1, ptr2, n ] + + unless is32Bit $ + emit $ mkAssign (CmmLocal res) + (CmmMachOp + (mo_s_32ToWord platform) + [(CmmReg (CmmLocal cres))]) + +emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitBSwapCall res x width = + emitPrimCall + [ res ] + (MO_BSwap width) + [ x ] + +emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitBRevCall res x width = + emitPrimCall + [ res ] + (MO_BRev width) + [ x ] + +emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitPopCntCall res x width = + emitPrimCall + [ res ] + (MO_PopCnt width) + [ x ] + +emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () +emitPdepCall res x y width = + emitPrimCall + [ res ] + (MO_Pdep width) + [ x, y ] + +emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () +emitPextCall res x y width = + emitPrimCall + [ res ] + (MO_Pext width) + [ x, y ] + +emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitClzCall res x width = + emitPrimCall + [ res ] + (MO_Clz width) + [ x ] + +emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitCtzCall res x width = + emitPrimCall + [ res ] + (MO_Ctz width) + [ x ] + +--------------------------------------------------------------------------- +-- Array bounds checking +--------------------------------------------------------------------------- + +whenCheckBounds :: FCode () -> FCode () +whenCheckBounds a = do + config <- getStgToCmmConfig + case stgToCmmDoBoundsCheck config of + False -> pure () + True -> a + +emitBoundsCheck :: CmmExpr -- ^ accessed index + -> CmmExpr -- ^ array size (in elements) + -> FCode () +emitBoundsCheck idx sz = do + assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig) + platform <- getPlatform + boundsCheckFailed <- getCode $ + emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) [] + let isOutOfBounds = cmmUGeWord platform idx sz + emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) + +emitRangeBoundsCheck :: CmmExpr -- ^ first accessed index + -> CmmExpr -- ^ number of accessed indices (non-zero) + -> CmmExpr -- ^ array size (in elements) + -> FCode () +emitRangeBoundsCheck idx len arrSizeExpr = do + assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig) + config <- getStgToCmmConfig + platform <- getPlatform + arrSize <- assignTempE arrSizeExpr + -- arrSizeExpr is probably a load we don't want to duplicate + rangeTooLargeReg <- newTemp (bWord platform) + lastSafeIndexReg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [lastSafeIndexReg, rangeTooLargeReg] False) $ + cmmPrimOpApp config WordSubCOp [arrSize, len] Nothing + boundsCheckFailed <- getCode $ + emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) [] + let + rangeTooLarge = CmmReg (CmmLocal rangeTooLargeReg) + lastSafeIndex = CmmReg (CmmLocal lastSafeIndexReg) + badStartIndex = (idx `uGT` lastSafeIndex) + isOutOfBounds = (rangeTooLarge `or` badStartIndex) `neq` zero + uGT = cmmUGtWord platform + or = cmmOrWord platform + neq = cmmNeWord platform + zero = zeroExpr platform + emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) + +doPtrArrayBoundsCheck + :: CmmExpr -- ^ accessed index (in bytes) + -> CmmExpr -- ^ pointer to @StgMutArrPtrs@ + -> FCode () +doPtrArrayBoundsCheck idx arr = whenCheckBounds $ do + profile <- getProfile + platform <- getPlatform + emitBoundsCheck idx (ptrArraySize platform profile arr) + +doSmallPtrArrayBoundsCheck + :: CmmExpr -- ^ accessed index (in bytes) + -> CmmExpr -- ^ pointer to @StgMutArrPtrs@ + -> FCode () +doSmallPtrArrayBoundsCheck idx arr = whenCheckBounds $ do + profile <- getProfile + platform <- getPlatform + emitBoundsCheck idx (smallPtrArraySize platform profile arr) + +doByteArrayBoundsCheck + :: CmmExpr -- ^ accessed index (in elements) + -> CmmExpr -- ^ pointer to @StgArrBytes@ + -> CmmType -- ^ indexing type + -> CmmType -- ^ element type + -> FCode () +doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do + profile <- getProfile + platform <- getPlatform + let elem_w = typeWidth elem_ty + idx_w = typeWidth idx_ty + elem_sz = mkIntExpr platform $ widthInBytes elem_w + arr_sz = byteArraySize platform profile arr + effective_arr_sz = + cmmUShrWord platform arr_sz (mkIntExpr platform (widthInLog idx_w)) + if elem_w == idx_w + then emitBoundsCheck idx effective_arr_sz -- aligned => simpler check + else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz) + +-- | Write barrier for @MUT_VAR@ modification. +emitDirtyMutVar :: CmmExpr -> CmmExpr -> FCode () +emitDirtyMutVar mutvar old_val = do + cfg <- getStgToCmmConfig + platform <- getPlatform + mkdirtyMutVarCCall <- getCode $! emitCCall + [{-no results-}] + (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + [(baseExpr platform, AddrHint), (mutvar, AddrHint), (old_val, AddrHint)] + + emit =<< mkCmmIfThen + (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) + (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutvar)) + mkdirtyMutVarCCall + +--------------------------------------------------------------------------- +-- Pushing to the update remembered set +--------------------------------------------------------------------------- + +-- | Push a range of pointer-array elements that are about to be copied over to +-- the update remembered set. +emitCopyUpdRemSetPush :: Platform + -> ByteOff -- ^ array header size (in bytes) + -> CmmExpr -- ^ destination array + -> CmmExpr -- ^ offset in destination array (in words) + -> Int -- ^ number of elements to copy + -> FCode () +emitCopyUpdRemSetPush _platform _hdr_size _dst _dst_off 0 = return () +emitCopyUpdRemSetPush platform hdr_size dst dst_off n = + whenUpdRemSetEnabled $ do + updfr_off <- getUpdFrameOff + graph <- mkCall lbl (NativeNodeCall,NativeReturn) [] args updfr_off [] + emit graph + where + lbl = mkLblExpr $ mkPrimCallLabel + $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnit + args = + [ mkIntExpr platform hdr_size + , dst + , dst_off + , mkIntExpr platform n + ] diff --git a/GHC/StgToCmm/Prof.hs b/GHC/StgToCmm/Prof.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Prof.hs @@ -0,0 +1,432 @@ +----------------------------------------------------------------------------- +-- +-- Code generation for profiling +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Prof ( + initCostCentres, ccType, ccsType, + mkCCostCentre, mkCCostCentreStack, + + -- infoTablePRov + initInfoTableProv, + + -- Cost-centre Profiling + dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, + enterCostCentreThunk, enterCostCentreFun, + costCentreFrom, + storeCurCCS, + emitSetCCC, + + saveCurrentCostCentre, restoreCurrentCostCentre, + + -- Lag/drag/void stuff + ldvEnter, ldvEnterClosure, profHeaderCreate + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Profile +import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config +import GHC.StgToCmm.InfoTableProv +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Lit +import GHC.Runtime.Heap.Layout + +import GHC.Cmm.Graph +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.CLabel + +import GHC.Types.Unique.DSM +import GHC.Types.CostCentre +import GHC.Types.IPE +import GHC.Types.ForeignStubs +import GHC.Data.FastString +import GHC.Unit.Module as Module +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Driver.CodeOutput ( ipInitCode ) + +import GHC.Utils.Encoding + +import Control.Monad +import Data.Char (ord) +import GHC.Utils.Monad (whenM) + +----------------------------------------------------------------------------- +-- +-- Cost-centre-stack Profiling +-- +----------------------------------------------------------------------------- + +-- Expression representing the current cost centre stack +ccsType :: Platform -> CmmType -- Type of a cost-centre stack +ccsType = bWord + +ccType :: Platform -> CmmType -- Type of a cost centre +ccType = bWord + +storeCurCCS :: Platform -> CmmExpr -> CmmAGraph +storeCurCCS platform = mkAssign (cccsReg platform) + +mkCCostCentre :: CostCentre -> CmmLit +mkCCostCentre cc = CmmLabel (mkCCLabel cc) + +mkCCostCentreStack :: CostCentreStack -> CmmLit +mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) + +costCentreFrom :: Platform + -> CmmExpr -- A closure pointer + -> CmmExpr -- The cost centre from that closure +costCentreFrom platform cl = CmmLoad (cmmOffsetB platform cl (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (ccsType platform) NaturallyAligned + +-- | The profiling header words in a static closure +staticProfHdr :: Profile -> CostCentreStack -> [CmmLit] +staticProfHdr profile ccs + | profileIsProfiling profile = [mkCCostCentreStack ccs, staticProfHeaderInit platform] + | otherwise = [] + where platform = profilePlatform profile + +-- | Profiling header words in a dynamic closure +dynProfHdr :: Profile -> CmmExpr -> [CmmExpr] +dynProfHdr profile ccs + | profileIsProfiling profile = [ccs, dynProfInit (profilePlatform profile)] + | otherwise = [] + +-- | Initialise the profiling field of an update frame +initUpdFrameProf :: CmmExpr -> FCode () +initUpdFrameProf frame + = ifProfiling $ -- frame->header.prof.ccs = CCCS + do platform <- getPlatform + emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (cccsExpr platform) + -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) + -- is unnecessary because it is not used anyhow. + +--------------------------------------------------------------------------- +-- Saving and restoring the current cost centre +--------------------------------------------------------------------------- + +{- Note [Saving the current cost centre] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The current cost centre is like a global register. Like other +global registers, it's a caller-saves one. But consider + case (f x) of (p,q) -> rhs +Since 'f' may set the cost centre, we must restore it +before resuming rhs. So we want code like this: + local_cc = CCC -- save + r = f( x ) + CCC = local_cc -- restore +That is, we explicitly "save" the current cost centre in +a LocalReg, local_cc; and restore it after the call. The +C-- infrastructure will arrange to save local_cc across the +call. + +The same goes for join points; + let j x = join-stuff + in blah-blah +We want this kind of code: + local_cc = CCC -- save + blah-blah + J: + CCC = local_cc -- restore +-} + +saveCurrentCostCentre :: FCode (Maybe LocalReg) + -- Returns Nothing if profiling is off +saveCurrentCostCentre + = do sccProfilingEnabled <- stgToCmmSCCProfiling <$> getStgToCmmConfig + platform <- getPlatform + if not sccProfilingEnabled + then return Nothing + else do local_cc <- newTemp (ccType platform) + emitAssign (CmmLocal local_cc) (cccsExpr platform) + return (Just local_cc) + +restoreCurrentCostCentre :: Platform -> Maybe LocalReg -> FCode () +restoreCurrentCostCentre _ Nothing + = return () +restoreCurrentCostCentre platform (Just local_cc) + = emit (storeCurCCS platform (CmmReg (CmmLocal local_cc))) + + +------------------------------------------------------------------------------- +-- Recording allocation in a cost centre +------------------------------------------------------------------------------- + +-- | Record the allocation of a closure. The CmmExpr is the cost +-- centre stack to which to attribute the allocation. +profDynAlloc :: SMRep -> CmmExpr -> FCode () +profDynAlloc rep ccs + = ifProfiling $ + do profile <- getProfile + let platform = profilePlatform profile + profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs + +-- | Record the allocation of a closure (size is given by a CmmExpr) +-- The size must be in words, because the allocation counter in a CCS counts +-- in words. +profAlloc :: CmmExpr -> CmmExpr -> FCode () +profAlloc words ccs + = ifProfiling $ + do profile <- getProfile + let platform = profilePlatform profile + let alloc_rep = rEP_CostCentreStack_mem_alloc platform + emit $ addToMemE alloc_rep + (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_mem_alloc (platformConstants platform))) + (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) + -- subtract the "profiling overhead", which is the + -- profiling header in a closure. + [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]] + ) + +-- ----------------------------------------------------------------------- +-- Setting the current cost centre on entry to a closure + +enterCostCentreThunk :: CmmExpr -> FCode () +enterCostCentreThunk closure = + ifProfiling $ do + platform <- getPlatform + emit $ storeCurCCS platform (costCentreFrom platform closure) + +enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () +enterCostCentreFun ccs closure = ifProfiling $ + when (isCurrentCCS ccs) $ + do platform <- getPlatform + emitRtsCall + rtsUnitId + (fsLit "enterFunCCS") + [(baseExpr platform, AddrHint), (costCentreFrom platform closure, AddrHint)] + False + -- otherwise we have a top-level function, nothing to do + +ifProfiling :: FCode () -> FCode () +ifProfiling = whenM (stgToCmmSCCProfiling <$> getStgToCmmConfig) + +--------------------------------------------------------------- +-- Initialising Cost Centres & CCSs +--------------------------------------------------------------- + +initCostCentres :: CollectedCCs -> FCode () +-- Emit the declarations +initCostCentres (local_CCs, singleton_CCSs) + = ifProfiling $ do + mapM_ emitCostCentreDecl local_CCs + mapM_ emitCostCentreStackDecl singleton_CCSs + + +emitCostCentreDecl :: CostCentre -> FCode () +emitCostCentreDecl cc = do + { ctx <- stgToCmmContext <$> getStgToCmmConfig + ; platform <- getPlatform + ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF + | otherwise = zero platform + -- NB. bytesFS: we want the UTF-8 bytes here (#5559) + ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) + ; modl <- newByteStringCLit (bytesFS $ moduleNameFS + $ moduleName + $ cc_mod cc) + ; loc <- newByteStringCLit $ utf8EncodeByteString $ + renderWithContext ctx (ppr $! costCentreSrcSpan cc) + ; let + lits = [ zero platform, -- StgInt ccID, + label, -- char *label, + modl, -- char *module, + loc, -- char *srcloc, + zero64, -- StgWord64 mem_alloc + zero platform, -- StgWord time_ticks + is_caf, -- StgInt is_caf + zero platform -- struct _CostCentre *link + ] + ; emitDataLits (mkCCLabel cc) lits + } + +emitCostCentreStackDecl :: CostCentreStack -> FCode () +emitCostCentreStackDecl ccs + = case maybeSingletonCCS ccs of + Just cc -> + do platform <- getPlatform + let mk_lits cc = zero platform : + mkCCostCentre cc : + replicate (sizeof_ccs_words platform - 2) (zero platform) + -- Note: to avoid making any assumptions about how the + -- C compiler (that compiles the RTS, in particular) does + -- layouts of structs containing long-longs, simply + -- pad out the struct with zero words until we hit the + -- size of the overall struct (which we get via DerivedConstants.h) + emitDataLits (mkCCSLabel ccs) (mk_lits cc) + Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) + +zero :: Platform -> CmmLit +zero platform = mkIntCLit platform 0 +zero64 :: CmmLit +zero64 = CmmInt 0 W64 + +sizeof_ccs_words :: Platform -> Int +sizeof_ccs_words platform + -- round up to the next word. + | ms == 0 = ws + | otherwise = ws + 1 + where + (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform + +-- | Emit info-table provenance declarations and track IPE stats. +-- +-- Note that the stats passed to this function will (rather, should) only ever +-- contain stats for skipped STACK info tables accumulated in +-- 'generateCgIPEStub'. +initInfoTableProv :: IPEStats -> [CmmInfoTable] -> InfoTableProvMap -> DUniqSupply -> FCode (Maybe (IPEStats, CStub), DUniqSupply) +initInfoTableProv stats infos itmap dus + = do + cfg <- getStgToCmmConfig + let (stats', ents) = convertInfoProvMap cfg this_mod itmap stats infos + info_table = stgToCmmInfoTableMap cfg + platform = stgToCmmPlatform cfg + this_mod = stgToCmmThisModule cfg + case ents of + [] -> return (Nothing, dus) + _ -> do + -- Emit IPE buffer + dus' <- emitIpeBufferListNode this_mod ents dus + + -- Create the C stub which initialises the IPE map + return (Just (stats', ipInitCode info_table platform this_mod), dus') + +-- --------------------------------------------------------------------------- +-- Set the current cost centre stack + +emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () +emitSetCCC cc tick push = ifProfiling $ + do platform <- getPlatform + tmp <- newTemp (ccsType platform) + pushCostCentre tmp (cccsExpr platform) cc + when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp))) + when push $ emit (storeCurCCS platform (CmmReg (CmmLocal tmp))) + +pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () +pushCostCentre result ccs cc + = emitRtsCallWithResult result AddrHint + rtsUnitId + (fsLit "pushCostCentre") [(ccs,AddrHint), + (CmmLit (mkCCostCentre cc), AddrHint)] + False + +bumpSccCount :: Platform -> CmmExpr -> CmmAGraph +bumpSccCount platform ccs + = addToMem (rEP_CostCentreStack_scc_count platform) + (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_scc_count (platformConstants platform))) 1 + +----------------------------------------------------------------------------- +-- +-- Profiling header stuff +-- +----------------------------------------------------------------------------- + + +-- Header initialisation for static objects happens to coicincide for the +-- three uses of the header +-- * LDV profiling = 0 (era = 0, LDV_STATE_CREATE) +-- * Eras profiling = 0 (user_era = 0, ignored by profiler) +-- * Retainer profiling = 0 + +staticProfHeaderInit :: Platform -> CmmLit +staticProfHeaderInit plat = zeroCLit plat + + +-- Dynamic initialisation + +dynErasInit :: Platform -> CmmExpr +dynErasInit platform = loadUserEra platform + +dynLdvInit :: Platform -> CmmExpr +dynLdvInit platform = +-- (era << LDV_SHIFT) | LDV_STATE_CREATE + CmmMachOp (mo_wordOr platform) [ + CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (pc_LDV_SHIFT (platformConstants platform))], + CmmLit (mkWordCLit platform (pc_ILDV_STATE_CREATE (platformConstants platform))) + ] + + +-- | If LDV profiling the user_era = 0 +-- , if eras profiling then (ldv)era = 0, so we can initialise correctly by OR the two expressions. +dynProfInit :: Platform -> CmmExpr +dynProfInit platform = CmmMachOp (mo_wordOr platform) [(dynLdvInit platform), dynErasInit platform] + + +-- | Initialise the profiling word of a new dynamic closure +-- * When LDV profiling is enabled (era > 0) - Initialise to the LDV word +-- * When eras profiling is enabled (user_era > 0) - Initialise to current user_era +profHeaderCreate :: CmmExpr -> FCode () +profHeaderCreate closure = do + platform <- getPlatform + let prof_header_wd = profHeaderWord platform closure + + let check_ldv = mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra platform, CmmLit (zeroCLit platform)]) + let check_eras = mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadUserEra platform, CmmLit (zeroCLit platform)]) + -- Case 2: user_era > 0, eras profiling is enabled + check_1 <- check_eras (mkStore prof_header_wd (dynErasInit platform)) mkNop + -- Case 1: era > 0, LDV profiling is enabled + check_2 <- check_ldv (mkStore prof_header_wd (dynLdvInit platform)) check_1 + emit check_2 + + + + + + + +-- +-- | Called when a closure is entered, marks the closure as having +-- been "used". The closure is not an "inherently used" one. The +-- closure is not @IND@ because that is not considered for LDV profiling. +-- +ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode () +ldvEnterClosure closure_info node_reg = do + platform <- getPlatform + let tag = funTag platform closure_info + -- don't forget to subtract node's tag + ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag)) + +ldvEnter :: CmmExpr -> FCode () +-- Argument is a closure pointer +ldvEnter cl_ptr = do + platform <- getPlatform + let constants = platformConstants platform + -- don't forget to subtract node's tag + ldv_wd = profHeaderWord platform cl_ptr + new_ldv_wd = cmmOrWord platform + (cmmAndWord platform (cmmLoadBWord platform ldv_wd) + (CmmLit (mkWordCLit platform (pc_ILDV_CREATE_MASK constants)))) + (cmmOrWord platform (loadEra platform) (CmmLit (mkWordCLit platform (pc_ILDV_STATE_USE constants)))) + ifProfiling $ do + -- if (era > 0) { + -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | + -- era | LDV_STATE_USE } + emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra platform, CmmLit (zeroCLit platform)]) + (mkStore ldv_wd new_ldv_wd) + mkNop + + + +loadEra :: Platform -> CmmExpr +loadEra platform = CmmMachOp (MO_UU_Conv (cIntWidth platform) (wordWidth platform)) + [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era"))) + (cInt platform) + NaturallyAligned] + +loadUserEra :: Platform -> CmmExpr +loadUserEra platform = CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "user_era"))) + (bWord platform) + NaturallyAligned + +-- | Takes the address of a closure, and returns +-- the address of the prof header word in the closure (this is used to store LDV info, +-- retainer profiling info and eras profiling info). +profHeaderWord :: Platform -> CmmExpr -> CmmExpr +profHeaderWord platform closure_ptr + = cmmOffsetB platform closure_ptr (pc_OFFSET_StgHeader_ldvw (platformConstants platform)) diff --git a/GHC/StgToCmm/Sequel.hs b/GHC/StgToCmm/Sequel.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Sequel.hs @@ -0,0 +1,55 @@ +----------------------------------------------------------------------------- +-- +-- Sequel type for Stg to C-- code generation +-- +-- (c) The University of Glasgow 2004-2006 +-- +-- This module is just a bucket of types used in StgToCmm.Monad and +-- StgToCmm.Closure. Its sole purpose is to break a cyclic dependency between +-- StgToCmm.Monad and StgToCmm.Closure which derives from coupling around +-- the BlockId and LocalReg types +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Sequel + ( Sequel(..) + , SelfLoopInfo(..) + ) where + +import GHC.Cmm.BlockId +import GHC.Cmm + +import GHC.Types.Id +import GHC.Types.Basic (RepArity) +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 + +data SelfLoopInfo = MkSelfLoopInfo + { sli_id :: !Id + , sli_arity :: !RepArity + -- ^ always equal to 'idFunRepArity' of sli_id, + -- i.e. unarised arity, including void arguments + , sli_registers :: ![LocalReg] + -- ^ Excludes void arguments (LocalReg is never void) + , sli_header_block :: !BlockId + } + +-------------------------------------------------------------------------------- diff --git a/GHC/StgToCmm/TagCheck.hs b/GHC/StgToCmm/TagCheck.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/TagCheck.hs @@ -0,0 +1,177 @@ +{-# 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, panic) +import GHC.Stg.Syntax +import GHC.StgToCmm.Closure +import GHC.Cmm.Switch (mkSwitchTargets) +import GHC.Cmm.Info (cmmGetClosureType) +import GHC.Types.RepType (dataConRuntimeRepStrictness) +import GHC.Types.Basic +import GHC.Data.FastString (mkFastString) + +import qualified Data.Map as M + +-- | Check all arguments marked as cbv for the presence of a tag *at runtime*. +checkFunctionArgTags :: SDoc -> Id -> [Id] -> FCode () +checkFunctionArgTags msg f args = whenCheckTags $ do + onJust (return ()) (idCbvMarks_maybe f) $ \marks -> do + -- Only check args marked as strict, and only lifted ones. + let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args + -- Get their (cmm) address + arg_infos <- mapM getCgIdInfo cbv_args + let arg_cmms = map idInfoToAmode arg_infos + mapM_ (\(cmm,arg) -> emitTagAssertion (showPprUnsafe $ msg <+> ppr arg) cmm) (zip arg_cmms cbv_args) + +-- | Check all required-tagged arguments of a constructor are tagged *at compile time*. +checkConArgsStatic :: SDoc -> DataCon -> [StgArg] -> FCode () +checkConArgsStatic msg con args = whenCheckTags $ do + let marks = dataConRuntimeRepStrictness con + zipWithM_ (checkArgStatic msg) marks args + +-- Check all required arguments of a constructor are tagged. +-- Possible by emitting checks at runtime. +checkConArgsDyn :: SDoc -> DataCon -> [StgArg] -> FCode () +checkConArgsDyn msg con args = whenCheckTags $ do + let marks = dataConRuntimeRepStrictness con + zipWithM_ (checkArg msg) (map cbvFromStrictMark marks) args + +whenCheckTags :: FCode () -> FCode () +whenCheckTags act = do + check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig + when check_tags act + +-- | Call barf if we failed to predict a tag correctly. +-- This is immensely useful when debugging issues in tag inference +-- as it will result in a program abort when we encounter an invalid +-- call/heap object, rather than leaving it be and segfaulting arbitrary +-- or producing invalid results. +-- We check if either: +-- * A tag is present +-- * Or the object is a PAP (for which zero is the proper tag) +emitTagAssertion :: String -> CmmExpr -> FCode () +emitTagAssertion onWhat fun = do + { platform <- getPlatform + ; lret <- newBlockId + ; lno_tag <- newBlockId + ; lbarf <- newBlockId + -- Check for presence of any tag. + ; emit $ mkCbranch (cmmIsTagged platform fun) + lret lno_tag (Just True) + -- If there is no tag check if we are dealing with a PAP + ; emitLabel lno_tag + ; emitComment (mkFastString "closereTypeCheck") + ; needsArgTag fun lbarf lret + + ; emitLabel lbarf + ; emitBarf ("Tag inference failed on:" ++ onWhat) + ; emitLabel lret + } + +-- | Jump to the first block if the argument closure is subject +-- to tagging requirements. Otherwise jump to the 2nd one. +needsArgTag :: CmmExpr -> BlockId -> BlockId -> FCode () +needsArgTag closure fail lpass = do + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + let clo_ty_e = cmmGetClosureType profile align_check closure + -- The ENTER macro doesn't evaluate FUN/PAP/BCO objects. So we + -- have to accept them not being tagged. See #21193 + -- See Note [TagInfo of functions] + let targets = mkSwitchTargets + False + (INVALID_OBJECT, N_CLOSURE_TYPES) + (Just fail) + (M.fromList [(PAP,lpass) + ,(BCO,lpass) + ,(FUN,lpass) + ,(FUN_1_0,lpass) + ,(FUN_0_1,lpass) + ,(FUN_2_0,lpass) + ,(FUN_1_1,lpass) + ,(FUN_0_2,lpass) + ,(FUN_STATIC,lpass) + ]) + + emit $ mkSwitch clo_ty_e targets + + emit $ mkBranch lpass + + +emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode () +emitArgTagCheck info marks args = whenCheckTags $ do + mod <- getModuleName + let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args + forM_ cbv_args $ \arg -> do + cginfo <- getCgIdInfo arg + let msg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg) + emitTagAssertion msg (idInfoToAmode cginfo) + +taggedCgInfo :: CgIdInfo -> Bool +taggedCgInfo cg_info + = case lf of + LFCon {} -> True + LFReEntrant {} -> True + LFUnlifted {} -> True + LFThunk {} -> False + LFUnknown {} -> False + LFLetNoEscape -> panic "Let no escape binding passed to top level con" + where + lf = cg_lf cg_info + +-- Check that one argument is properly tagged. +checkArg :: SDoc -> CbvMark -> StgArg -> FCode () +checkArg _ NotMarkedCbv _ = return () +checkArg msg MarkedCbv arg = whenCheckTags $ + case arg of + StgLitArg _ -> return () + StgVarArg v -> do + info <- getCgIdInfo v + if taggedCgInfo info + then return () + else case (cg_loc info) of + CmmLoc loc -> emitTagAssertion (showPprUnsafe $ msg <+> text "arg:" <> ppr arg) loc + LneLoc {} -> panic "LNE-arg" + +-- Check that argument is properly tagged. +checkArgStatic :: SDoc -> StrictnessMark -> StgArg -> FCode () +checkArgStatic _ NotMarkedStrict _ = return () +checkArgStatic msg MarkedStrict arg = whenCheckTags $ + case arg of + StgLitArg _ -> return () + StgVarArg v -> do + info <- getCgIdInfo v + if taggedCgInfo info + then return () + else pprPanic "Arg not tagged as expected" (ppr msg <+> ppr arg) + diff --git a/GHC/StgToCmm/Ticky.hs b/GHC/StgToCmm/Ticky.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Ticky.hs @@ -0,0 +1,914 @@ +{-# LANGUAGE MultiWayIf #-} + +----------------------------------------------------------------------------- +-- +-- Code generation for ticky-ticky profiling +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +{- OVERVIEW: ticky ticky profiling + +Please see +https://gitlab.haskell.org/ghc/ghc/wikis/debugging/ticky-ticky and also +edit it and the rest of this comment to keep them up-to-date if you +change ticky-ticky. Thanks! + + *** All allocation ticky numbers are in bytes. *** + +Some of the relevant source files: + + ***not necessarily an exhaustive list*** + + * some codeGen/ modules import this one + + * this module imports GHC.Cmm.CLabel to manage labels + + * GHC.Cmm.Parser expands some macros using generators defined in + this module + + * rts/include/stg/Ticky.h declares all of the global counters + + * rts/include/rts/Ticky.h declares the C data type for an + STG-declaration's counters + + * some macros defined in rts/include/Cmm.h (and used within the RTS's + CMM code) update the global ticky counters + + * at the end of execution rts/Ticky.c generates the final report + +RTS -r -RTS + +The rts/Ticky.c function that generates the report includes an +STG-declaration's ticky counters if + + * that declaration was entered, or + + * it was allocated (if -ticky-allocd) + +On either of those events, the counter is "registered" by adding it to +a linked list; cf the CMM generated by registerTickyCtr. + +Ticky-ticky profiling has evolved over many years. Many of the +counters from its most sophisticated days are no longer +active/accurate. As the RTS has changed, sometimes the ticky code for +relevant counters was not accordingly updated. Unfortunately, neither +were the comments. + +As of March 2013, there still exist deprecated code and comments in +the code generator as well as the RTS because: + + * I don't know what is out-of-date versus merely commented out for + momentary convenience, and + + * someone else might know how to repair it! + + +Note [Ticky counters are static] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently GHC only supports static ticky events. That is -ticky emits +code containing labels containing counters which then get bumped at runtime. + +There are currently only *static* ticky counters. Either we bump one of the +static counters included in the RTS. Or we emit StgEntCounter structures in +the object code and bump these. +-} + +module GHC.StgToCmm.Ticky ( + withNewTickyCounterFun, + withNewTickyCounterLNE, + withNewTickyCounterThunk, + withNewTickyCounterStdThunk, + withNewTickyCounterCon, + emitTickyCounterTag, + + tickyDynAlloc, + tickyAllocHeap, + + tickyAllocPrim, + tickyAllocThunk, + tickyAllocPAP, + tickyHeapCheck, + tickyStackCheck, + + tickyDirectCall, + + tickyPushUpdateFrame, + tickyUpdateFrameOmitted, + + tickyEnterDynCon, + + tickyEnterFun, + tickyEnterThunk, + tickyEnterLNE, + + tickyUpdateBhCaf, + tickyUnboxedTupleReturn, + tickyReturnOldCon, tickyReturnNewCon, + + tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs, + tickySlowCall, tickySlowCallPat, + + tickyTagged, tickyUntagged, tickyTagSkip + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Profile + +import GHC.StgToCmm.ArgRep ( slowCallPattern, toArgRepOrV, argRepString ) +import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config +import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall ) +import GHC.StgToCmm.Lit ( newStringCLit ) +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Utils + +import GHC.Stg.Syntax +import GHC.Cmm.Expr +import GHC.Cmm.Graph +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.Runtime.Heap.Layout + + +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.Basic +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Monad (whenM) + +-- Turgid imports for showTypeCategory +import GHC.Builtin.Names +import GHC.Tc.Utils.TcType +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Predicate + +import Data.Maybe +import qualified Data.Char +import Control.Monad ( when, unless ) +import GHC.Types.Id.Info +import GHC.StgToCmm.Env (getCgInfo_maybe) +import Data.Coerce (coerce) +import GHC.Utils.Json +import GHC.Utils.Unique (anyOfUnique) + +----------------------------------------------------------------------------- +-- +-- Ticky-ticky profiling +-- +----------------------------------------------------------------------------- + +-- | Number of arguments for a ticky counter. +-- +-- Ticky currently treats args to constructor allocations differently than those for functions/LNE bindings. +tickyArgArity :: TickyClosureType -> Int +tickyArgArity (TickyFun _ _fvs args) = length args +tickyArgArity (TickyLNE args) = length args +tickyArgArity (TickyCon{}) = 0 +tickyArgArity (TickyThunk{}) = 0 + +tickyArgDesc :: TickyClosureType -> String +tickyArgDesc arg_info = + case arg_info of + TickyFun _ _fvs args -> map (showTypeCategory . idType . fromNonVoid) args + TickyLNE args -> map (showTypeCategory . idType . fromNonVoid) args + TickyThunk{} -> "" + TickyCon{} -> "" + +tickyFvDesc :: TickyClosureType -> String +tickyFvDesc arg_info = + case arg_info of + TickyFun _ fvs _args -> map (showTypeCategory . idType . fromNonVoid) fvs + TickyLNE{} -> "" + TickyThunk _ _ fvs -> map (showTypeCategory . stgArgType) fvs + TickyCon{} -> "" + +instance ToJson TickyClosureType where + json info = case info of + (TickyFun {}) -> mkInfo (tickyFvDesc info) (tickyArgDesc info) "fun" + (TickyLNE {}) -> mkInfo [] (tickyArgDesc info) "lne" + (TickyThunk uf _ _) -> mkInfo (tickyFvDesc info) [] ("thk" ++ if uf then "_u" else "") + (TickyCon{}) -> mkInfo [] [] "con" + where + mkInfo :: String -> String -> String -> JsonDoc + mkInfo fvs args ty = + JSObject + [("type", json "entCntr") + ,("subTy", json ty) + ,("fvs_c", json (length fvs)) + ,("fvs" , json fvs) + ,("args", json args) + ] + +tickyEntryDescJson :: (SDocContext -> TickyClosureType -> String) +tickyEntryDescJson ctxt = renderWithContext ctxt . renderJSON . json + +data TickyClosureType + = TickyFun + Bool -- True <-> single entry + [NonVoid Id] -- ^ FVs + [NonVoid Id] -- ^ Args + | TickyCon + DataCon -- the allocated constructor + ConstructorNumber + | TickyThunk + Bool -- True <-> updateable + Bool -- True <-> standard thunk (AP or selector), has no entry counter + [StgArg] -- ^ FVS, StgArg because for thunks these can also be literals. + | TickyLNE + [NonVoid Id] -- ^ Args + +withNewTickyCounterFun :: Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a +withNewTickyCounterFun single_entry f fvs args = withNewTickyCounter (TickyFun single_entry fvs args) f + +withNewTickyCounterLNE :: Id -> [NonVoid Id] -> FCode a -> FCode a +withNewTickyCounterLNE nm args code = do + b <- isEnabled stgToCmmTickyLNE + if not b then code else withNewTickyCounter (TickyLNE args) nm code + +thunkHasCounter :: Bool -> FCode Bool +thunkHasCounter isStatic = (not isStatic &&) <$> isEnabled stgToCmmTickyDynThunk + +withNewTickyCounterThunk + :: Bool -- ^ static + -> Bool -- ^ updateable + -> Id + -> [NonVoid Id] -- ^ Free vars + -> FCode a + -> FCode a +withNewTickyCounterThunk isStatic isUpdatable name fvs code = do + has_ctr <- thunkHasCounter isStatic + if not has_ctr + then code + else withNewTickyCounter (TickyThunk isUpdatable False (map StgVarArg $ coerce fvs)) name code + +withNewTickyCounterStdThunk + :: Bool -- ^ updateable + -> Id + -> [StgArg] -- ^ Free vars + function + -> FCode a + -> FCode a +withNewTickyCounterStdThunk isUpdatable name fvs code = do + has_ctr <- thunkHasCounter False + if not has_ctr + then code + else withNewTickyCounter (TickyThunk isUpdatable True fvs) name code + +withNewTickyCounterCon + :: Id + -> DataCon + -> ConstructorNumber + -> FCode a + -> FCode a +withNewTickyCounterCon name datacon info code = do + has_ctr <- thunkHasCounter False + if not has_ctr + then code + else withNewTickyCounter (TickyCon datacon info) name code + +-- args does not include the void arguments +withNewTickyCounter :: TickyClosureType -> Id -> FCode a -> FCode a +withNewTickyCounter cloType name m = do + lbl <- emitTickyCounter cloType name + setTickyCtrLabel lbl m + +emitTickyData :: Platform + -> CLabel -- ^ lbl for the counter + -> Arity -- ^ arity + -> CmmLit -- ^ fun desc + -> CmmLit -- ^ arg desc + -> CmmLit -- ^ json desc + -> CmmLit -- ^ info table lbl + -> FCode () +emitTickyData platform ctr_lbl arity fun_desc arg_desc json_desc info_tbl = + emitDataLits ctr_lbl + -- Must match layout of rts/include/rts/Ticky.h's StgEntCounter + -- + -- krc: note that all the fields are I32 now; some were I16 + -- before, but the code generator wasn't handling that + -- properly and it led to chaos, panic and disorder. + [ zeroCLit platform, -- registered? + mkIntCLit platform arity, -- Arity + zeroCLit platform, -- Heap allocated for this thing + fun_desc, + arg_desc, + json_desc, + info_tbl, + zeroCLit platform, -- Entries into this thing + zeroCLit platform, -- Heap allocated by this thing + zeroCLit platform -- Link to next StgEntCounter + ] + + +emitTickyCounter :: TickyClosureType -> Id -> FCode CLabel +emitTickyCounter cloType tickee + = let name = idName tickee in + let ctr_lbl = mkRednCountsLabel name in + (>> return ctr_lbl) $ + ifTicky $ do + { cfg <- getStgToCmmConfig + ; parent <- getTickyCtrLabel + ; mod_name <- getModuleName + + -- When printing the name of a thing in a ticky file, we + -- want to give the module name even for *local* things. We + -- print just "x (M)" rather that "M.x" to distinguish them + -- from the global kind by calling to @pprTickyName@ + ; let platform = stgToCmmPlatform cfg + ppr_for_ticky_name :: SDoc + ppr_for_ticky_name = + let ext = case cloType of + TickyFun single_entry _ _-> parens $ hcat $ punctuate comma $ + [text "fun"] ++ [text "se"|single_entry] + TickyCon datacon _cn -> parens (text "con:" <+> ppr (dataConName datacon)) + TickyThunk upd std _-> parens $ hcat $ punctuate comma $ + [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std] + TickyLNE _ | isInternalName name -> parens (text "LNE") + | otherwise -> panic "emitTickyCounter: how is this an external LNE?" + p = case hasHaskellName parent of + -- NB the default "top" ticky ctr does not + -- have a Haskell name + Just pname -> text "in" <+> ppr (nameUnique pname) + _ -> empty + in pprTickyName mod_name name <+> ext <+> p + ; this_mod <- getModuleName + ; let t = case cloType of + TickyCon {} -> "C" + TickyFun {} -> "F" + TickyThunk {} -> "T" + TickyLNE {} -> "L" + ; info_lbl <- case cloType of + TickyCon dc mn -> case mn of + NoNumber -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) DefinitionSite + (Numbered n) -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) (UsageSite this_mod n) + TickyFun {} -> + return $! CmmLabel $ mkInfoTableLabel name NoCafRefs + + TickyThunk _ std_thunk _fvs + | not std_thunk + -> return $! CmmLabel $ mkInfoTableLabel name NoCafRefs + -- IPE Maps have no entry for std thunks. + | otherwise + -> do + lf_info <- getCgInfo_maybe name + profile <- getProfile + case lf_info of + Just (CgIdInfo { cg_lf = cg_lf }) + | isLFThunk cg_lf + -> return $! CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf + _ -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> pprDebugCLabel (profilePlatform profile) (mkInfoTableLabel name NoCafRefs)) + return $! zeroCLit platform + + TickyLNE {} -> return $! zeroCLit platform + + ; let ctx = defaultSDocContext {sdocPprDebug = True} + ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name + ; arg_descr_lit <- newStringCLit $ tickyArgDesc cloType + ; json_descr_lit <- newStringCLit $ tickyEntryDescJson ctx cloType + ; emitTickyData platform ctr_lbl (tickyArgArity cloType) fun_descr_lit arg_descr_lit json_descr_lit info_lbl + } + +{- Note [TagSkip ticky counters] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These counters keep track how often we execute code where we +would have performed a tag check if we hadn't run tag inference. + +If we have some code of the form: + case v[tagged] of ... +and we want to record how often we avoid a tag check on v +through tag inference we have to emit a new StgEntCounter for +each such case statement in order to record how often it's executed. + +In theory we could emit one per *binding*. But then we +would have to either keep track of the bindings which +already have a StgEntCounter associated with them in the +code gen state or preallocate such a structure for each binding +in the code unconditionally (since ticky-code can call non-ticky code) + +The first makes the compiler slower, even when ticky is not +used (a big no no). The later is fairly complex but increases code size +unconditionally. See also Note [Ticky counters are static]. + +So instead we emit a new StgEntCounter for each use site of a binding +where we infered a tag to be present. And increment the counter whenever +this use site is executed. + +We use the fields as follows: + +entry_count: Entries avoided. +str: : Name of the id. + +We use emitTickyCounterTag to emit the counter. + +Unlike the closure counters each *use* site of v has it's own +counter. So there is no need to keep track of the closure/case we are +in. + +We also have to pass a unique for the counter. An Id might be +scrutinized in more than one place, so the ID alone isn't enough +to distinguish between use sites. +-} + +emitTickyCounterTag :: Unique -> NonVoid Id -> FCode CLabel +emitTickyCounterTag unique (NonVoid id) = + let name = idName id + ctr_lbl = mkTagHitLabel name unique in + (>> return ctr_lbl) $ + ifTickyTag $ do + { platform <- getPlatform + ; parent <- getTickyCtrLabel + ; mod_name <- getModuleName + + -- When printing the name of a thing in a ticky file, we + -- want to give the module name even for *local* things. We + -- print just "x (M)" rather that "M.x" to distinguish them + -- from the global kind. + ; let ppr_for_ticky_name :: SDoc + ppr_for_ticky_name = + let n = ppr name + ext = empty -- parens (text "tagged") + p = case hasHaskellName parent of + -- NB the default "top" ticky ctr does not + -- have a Haskell name + Just pname -> text "at" <+> ppr (nameSrcLoc pname) <+> + text "in" <+> pprNameUnqualified name + _ -> empty + in if isInternalName name + then n <+> parens (ppr mod_name) <+> ext <+> p + else n <+> ext <+> p + ; sdoc_context <- stgToCmmContext <$> getStgToCmmConfig + ; fun_descr_lit <- newStringCLit $ renderWithContext sdoc_context ppr_for_ticky_name + ; arg_descr_lit <- newStringCLit $ "infer" + ; json_descr_lit <- newStringCLit $ "infer" + ; emitTickyData platform ctr_lbl 0 fun_descr_lit arg_descr_lit json_descr_lit (zeroCLit platform) + } +-- ----------------------------------------------------------------------------- +-- Ticky stack frames + +tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode () +tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr") +tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr") + +-- ----------------------------------------------------------------------------- +-- Ticky entries + +-- NB the name-specific entries are only available for names that have +-- dedicated Cmm code. As far as I know, this just rules out +-- constructor thunks. For them, there is no CMM code block to put the +-- bump of name-specific ticky counter into. On the other hand, we can +-- still track allocation their allocation. + +tickyEnterDynCon :: FCode () +tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") + +tickyEnterThunk :: ClosureInfo -> FCode () +tickyEnterThunk cl_info + = ifTicky $ do + { bumpTickyCounter ctr + ; has_ctr <- thunkHasCounter static + ; when has_ctr $ do + ticky_ctr_lbl <- getTickyCtrLabel + registerTickyCtrAtEntryDyn ticky_ctr_lbl + bumpTickyEntryCount ticky_ctr_lbl } + where + updatable = not (closureUpdReqd cl_info) + static = isStaticClosure cl_info + + ctr | static = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr" + else fsLit "ENT_STATIC_THK_MANY_ctr" + | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr" + else fsLit "ENT_DYN_THK_MANY_ctr" + +tickyUpdateBhCaf :: ClosureInfo -> FCode () +tickyUpdateBhCaf cl_info + = ifTicky (bumpTickyCounter ctr) + where + ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr") + | otherwise = (fsLit "UPD_CAF_BH_UPDATABLE_ctr") + +tickyEnterFun :: ClosureInfo -> FCode () +tickyEnterFun cl_info = ifTicky $ do + ctr_lbl <- getTickyCtrLabel + + if isStaticClosure cl_info + then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr") + registerTickyCtr ctr_lbl + else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr") + registerTickyCtrAtEntryDyn ctr_lbl + + bumpTickyEntryCount ctr_lbl + +tickyEnterLNE :: FCode () +tickyEnterLNE = ifTicky $ do + bumpTickyCounter (fsLit "ENT_LNE_ctr") + ifTickyLNE $ do + ctr_lbl <- getTickyCtrLabel + registerTickyCtr ctr_lbl + bumpTickyEntryCount ctr_lbl + +-- needn't register a counter upon entry if +-- +-- 1) it's for a dynamic closure, and +-- +-- 2) -ticky-allocd is on +-- +-- since the counter was registered already upon being alloc'd +registerTickyCtrAtEntryDyn :: CLabel -> FCode () +registerTickyCtrAtEntryDyn ctr_lbl = do + already_registered <- isEnabled stgToCmmTickyAllocd + unless already_registered $ registerTickyCtr ctr_lbl + +-- | Register a ticky counter. +-- +-- It's important that this does not race with other entries of the same +-- closure, lest the ticky_entry_ctrs list may become cyclic. However, we also +-- need to make sure that this is reasonably efficient. Consequently, we first +-- perform a normal load of the counter's "registered" flag to check whether +-- registration is necessary. If so, then we do a compare-and-swap to lock the +-- counter for registration and use an atomic-exchange to add the counter to the list. +-- +-- @ +-- if ( f_ct.registeredp == 0 ) { +-- if (cas(f_ct.registeredp, 0, 1) == 0) { +-- old_head = xchg(ticky_entry_ctrs, f_ct); +-- f_ct.link = old_head; +-- } +-- } +-- @ +registerTickyCtr :: CLabel -> FCode () +registerTickyCtr ctr_lbl = do + platform <- getPlatform + let constants = platformConstants platform + word_width = wordWidth platform + registeredp = CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_registeredp constants)) + + register_stmts <- getCode $ do + old_head <- newTemp (bWord platform) + let ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs")) + link = CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_link constants)) + emitPrimCall [old_head] (MO_Xchg word_width) [ticky_entry_ctrs, mkLblExpr ctr_lbl] + emitStore link (CmmReg $ CmmLocal old_head) + + cas_test <- getCode $ do + old <- newTemp (bWord platform) + emitPrimCall [old] (MO_Cmpxchg word_width) + [registeredp, zeroExpr platform, mkIntExpr platform 1] + let locked = cmmEqWord platform (CmmReg $ CmmLocal old) (zeroExpr platform) + emit =<< mkCmmIfThen locked register_stmts + + let test = cmmEqWord platform (cmmLoadBWord platform registeredp) (zeroExpr platform) + emit =<< mkCmmIfThen test cas_test + +tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () +tickyReturnOldCon arity + = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") + ; bumpHistogram (fsLit "RET_OLD_hst") arity } +tickyReturnNewCon arity + = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") + ; bumpHistogram (fsLit "RET_NEW_hst") arity } + +tickyUnboxedTupleReturn :: RepArity -> FCode () +tickyUnboxedTupleReturn arity + = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") + ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } + +-- ----------------------------------------------------------------------------- +-- Ticky calls + +-- Ticks at a *call site*: +tickyDirectCall :: RepArity -> [StgArg] -> FCode () +tickyDirectCall arity args + | args `lengthIs` arity = tickyKnownCallExact + | otherwise = do tickyKnownCallExtraArgs + tickySlowCallPat (drop arity args) + +tickyKnownCallTooFewArgs :: FCode () +tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") + +tickyKnownCallExact :: FCode () +tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr") + +tickyKnownCallExtraArgs :: FCode () +tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr") + +tickyUnknownCall :: FCode () +tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr") + +-- Tick for the call pattern at slow call site (i.e. in addition to +-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.) +tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode () +tickySlowCall _ [] = return () +tickySlowCall lf_info args = do + -- see Note [Ticky for slow calls] + if isKnownFun lf_info + then tickyKnownCallTooFewArgs + else tickyUnknownCall + tickySlowCallPat args + +tickySlowCallPat :: [StgArg] -> FCode () +tickySlowCallPat args = ifTicky $ do + platform <- profilePlatform <$> getProfile + let argReps = map (toArgRepOrV platform . stgArgRep1) args + (_, n_matched) = slowCallPattern argReps + if n_matched > 0 && args `lengthIs` n_matched + then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps + else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr" + +{- + +Note [Ticky for slow calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Terminology is unfortunately a bit mixed up for these calls. codeGen +uses "slow call" to refer to unknown calls and under-saturated known +calls. + +Nowadays, though (ie as of the eval/apply paper), the significantly +slower calls are actually just a subset of these: the ones with no +built-in argument pattern (cf GHC.StgToCmm.ArgRep.slowCallPattern) + +So for ticky profiling, we split slow calls into +"SLOW_CALL_fast__ctr" (those matching a built-in pattern) and +VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very +bad for both space and time). + +-} + +-- ----------------------------------------------------------------------------- +-- Ticky allocation + +tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode () +-- Called when doing a dynamic heap allocation; the LambdaFormInfo +-- used to distinguish between closure types +-- +-- TODO what else to count while we're here? +tickyDynAlloc mb_id rep lf = ifTicky $ do + profile <- getProfile + let platform = profilePlatform profile + bytes = platformWordSizeInBytes platform * heapClosureSizeW profile rep + + countGlobal tot ctr = do + bumpTickyCounterBy tot bytes + bumpTickyCounter ctr + countSpecific = ifTickyAllocd $ case mb_id of + Nothing -> return () + Just id -> do + let ctr_lbl = mkRednCountsLabel (idName id) + registerTickyCtr ctr_lbl + bumpTickyAllocd ctr_lbl bytes + + -- TODO are we still tracking "good stuff" (_gds) versus + -- administrative (_adm) versus slop (_slp)? I'm going with all _gds + -- for now, since I don't currently know neither if we do nor how to + -- distinguish. NSF Mar 2013 + + if | isConRep rep -> + ifTickyDynThunk countSpecific >> + countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr") + | isThunkRep rep -> + ifTickyDynThunk countSpecific >> + if lfUpdatable lf + then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr") + else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr") + | isFunRep rep -> + countSpecific >> + countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr") + | otherwise -> panic "How is this heap object not a con, thunk, or fun?" + + + +tickyAllocHeap :: + Bool -> -- is this a genuine allocation? As opposed to + -- GHC.StgToCmm.Layout.adjustHpBackwards + VirtualHpOffset -> FCode () +-- Called when doing a heap check [TICK_ALLOC_HEAP] +-- Must be lazy in the amount of allocation! +tickyAllocHeap genuine hp + = ifTicky $ + do { platform <- getPlatform + ; ticky_ctr <- getTickyCtrLabel + ; emit $ catAGraphs $ + -- only test hp from within the emit so that the monadic + -- computation itself is not strict in hp (cf knot in + -- GHC.StgToCmm.Monad.getHeapUsage) + if hp == 0 then [] + else let !bytes = platformWordSizeInBytes platform * hp in [ + -- Bump the allocation total in the closure's StgEntCounter + addToMem (rEP_StgEntCounter_allocs platform) + (CmmLit (cmmLabelOffB ticky_ctr (pc_OFFSET_StgEntCounter_allocs (platformConstants platform)))) + bytes, + -- Bump the global allocation total ALLOC_HEAP_tot + addToMemLbl (bWord platform) + (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_tot")) + bytes, + -- Bump the global allocation counter ALLOC_HEAP_ctr + if not genuine then mkNop + else addToMemLbl (bWord platform) + (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_ctr")) + 1 + ]} + + +-------------------------------------------------------------------------------- +-- these three are only called from GHC.Cmm.Parser (ie ultimately from the RTS) + +-- the units are bytes + +tickyAllocPrim :: CmmExpr -- ^ size of the full header, in bytes + -> CmmExpr -- ^ size of the payload, in bytes + -> CmmExpr -> FCode () +tickyAllocPrim _hdr _goods _slop = ifTicky $ do + bumpTickyCounter (fsLit "ALLOC_PRIM_ctr") + bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr + bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods + bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop + +tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode () +tickyAllocThunk _goods _slop = ifTicky $ do + -- TODO is it ever called with a Single-Entry thunk? + bumpTickyCounter (fsLit "ALLOC_UP_THK_ctr") + bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods + bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop + +tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode () +tickyAllocPAP _goods _slop = ifTicky $ do + bumpTickyCounter (fsLit "ALLOC_PAP_ctr") + bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods + bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop + +tickyHeapCheck :: FCode () +tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr") + +tickyStackCheck :: FCode () +tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr") + +-- ----------------------------------------------------------------------------- +-- Ticky for tag inference characterisation + +-- | Predicted a pointer would be tagged correctly (GHC will crash if not so no miss case) +tickyTagged :: FCode () +tickyTagged = ifTickyTag $ bumpTickyCounter (fsLit "TAG_TAGGED_pred") + +-- | Pass a boolean expr indicating if tag was present. +tickyUntagged :: CmmExpr -> FCode () +tickyUntagged e = do + ifTickyTag $ bumpTickyCounter (fsLit "TAG_UNTAGGED_pred") + ifTickyTag $ bumpTickyCounterByE (fsLit "TAG_UNTAGGED_miss") e + +-- | Called when for `case v of ...` we can avoid entering v based on +-- tag inference information. +tickyTagSkip :: Unique -> Id -> FCode () +tickyTagSkip unique id = ifTickyTag $ do + let ctr_lbl = mkTagHitLabel (idName id) unique + registerTickyCtr ctr_lbl + bumpTickyTagSkip ctr_lbl + +-- ----------------------------------------------------------------------------- +-- Ticky utils + +isEnabled :: (StgToCmmConfig -> Bool) -> FCode Bool +isEnabled = flip fmap getStgToCmmConfig + +runIfFlag :: (StgToCmmConfig -> Bool) -> FCode () -> FCode () +runIfFlag f = whenM (f <$> getStgToCmmConfig) + +ifTicky :: FCode () -> FCode () +ifTicky = runIfFlag stgToCmmDoTicky + +ifTickyTag :: FCode () -> FCode () +ifTickyTag = runIfFlag stgToCmmTickyTag + +ifTickyAllocd :: FCode () -> FCode () +ifTickyAllocd = runIfFlag stgToCmmTickyAllocd + +ifTickyLNE :: FCode () -> FCode () +ifTickyLNE = runIfFlag stgToCmmTickyLNE + +ifTickyDynThunk :: FCode () -> FCode () +ifTickyDynThunk = runIfFlag stgToCmmTickyDynThunk + +bumpTickyCounter :: FastString -> FCode () +bumpTickyCounter = bumpTickyLbl . mkRtsCmmDataLabel + +bumpTickyCounterBy :: FastString -> Int -> FCode () +bumpTickyCounterBy = bumpTickyLblBy . mkRtsCmmDataLabel + +bumpTickyCounterByE :: FastString -> CmmExpr -> FCode () +bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl) + +bumpTickyEntryCount :: CLabel -> FCode () +bumpTickyEntryCount lbl = do + platform <- getPlatform + bumpTickyLit (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) + +bumpTickyAllocd :: CLabel -> Int -> FCode () +bumpTickyAllocd lbl bytes = do + platform <- getPlatform + bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes + +bumpTickyTagSkip :: CLabel -> FCode () +bumpTickyTagSkip lbl = do + platform <- getPlatform + bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) 1 + +bumpTickyLbl :: CLabel -> FCode () +bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1 + +bumpTickyLblBy :: CLabel -> Int -> FCode () +bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) + +bumpTickyLblByE :: CLabel -> CmmExpr -> FCode () +bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0) + +bumpTickyLit :: CmmLit -> FCode () +bumpTickyLit lhs = bumpTickyLitBy lhs 1 + +bumpTickyLitBy :: CmmLit -> Int -> FCode () +bumpTickyLitBy lhs n = emitAddToMem (CmmLit lhs) n + +bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode () +bumpTickyLitByE lhs e = emitAddToMemE (CmmLit lhs) e + +bumpHistogram :: FastString -> Int -> FCode () +bumpHistogram lbl n = do + platform <- getPlatform + let offset = n `min` (pc_TICKY_BIN_COUNT (platformConstants platform) - 1) + let addr = + cmmIndexExpr platform + (wordWidth platform) + (CmmLit (CmmLabel (mkRtsCmmDataLabel lbl))) + (CmmLit (CmmInt (fromIntegral offset) (wordWidth platform))) + emitAddToMem addr 1 + +emitAddToMem :: CmmExpr -> Int -> FCode () +emitAddToMem lhs n = do + platform <- getPlatform + emitAddToMemE lhs (mkIntExpr platform n) + +emitAddToMemE :: CmmExpr -> CmmExpr -> FCode () +emitAddToMemE lhs n = do + platform <- getPlatform + val <- newTemp (bWord platform) + emitAtomicRead MemOrderRelaxed val lhs + let val' = cmmOffsetExpr platform (CmmReg (CmmLocal val)) n + emitAtomicWrite MemOrderRelaxed lhs val' + +------------------------------------------------------------------ +-- Showing the "type category" for ticky-ticky profiling + +showTypeCategory :: Type -> Char + {- + + dictionary + + > function + + {C,I,F,D,W} char, int, float, double, word + {c,i,f,d,w} unboxed ditto + + T tuple + + P other primitive type + p unboxed ditto + + L list + E enumeration type + S other single-constructor type + M other multi-constructor data-con type + + . other type + + - reserved for others to mark as "uninteresting" + + Accurate as of Mar 2013, but I eliminated the Array category instead + of updating it, for simplicity. It's in P/p, I think --NSF + + -} +showTypeCategory ty + | isDictTy ty = '+' + | otherwise = case tcSplitTyConApp_maybe ty of + Nothing -> '.' + Just (tycon, _) -> + case () of + _ | anyOfUnique tycon [fUNTyConKey] -> '>' + | anyOfUnique tycon [charTyConKey] -> 'C' + | anyOfUnique tycon [charPrimTyConKey] -> 'c' + | anyOfUnique tycon [doubleTyConKey] -> 'D' + | anyOfUnique tycon [doublePrimTyConKey] -> 'd' + | anyOfUnique tycon [floatTyConKey] -> 'F' + | anyOfUnique tycon [floatPrimTyConKey] -> 'f' + | anyOfUnique tycon [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I' + | anyOfUnique tycon [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i' + | anyOfUnique tycon [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W' + | anyOfUnique tycon [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w' + | anyOfUnique tycon [listTyConKey] -> 'L' + | isUnboxedTupleTyCon tycon -> 't' + | isTupleTyCon tycon -> 'T' + | isPrimTyCon tycon -> 'P' + | isEnumerationTyCon tycon -> 'E' + | isJust (tyConSingleDataCon_maybe tycon) -> 'S' + | otherwise -> 'M' -- oh, well... diff --git a/GHC/StgToCmm/Types.hs b/GHC/StgToCmm/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Types.hs @@ -0,0 +1,263 @@ + + +module GHC.StgToCmm.Types + ( CmmCgInfos (..) + , LambdaFormInfo (..) + , ModuleLFInfos + , StandardFormInfo (..) + , DoSCCProfiling + , DoExtDynRefs + ) where + +import GHC.Prelude + +import GHC.Core.DataCon + +import GHC.Runtime.Heap.Layout + +import GHC.Types.Basic +import GHC.Types.ForeignStubs +import GHC.Types.Name.Env +import GHC.Types.Name.Set + +import GHC.Utils.Outputable + +{- +Note [Conveying CAF-info and LFInfo between modules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some information about an Id is generated in the code generator, and is not +available earlier. Namely: + +* CAF info. Code motion in Cmm or earlier phases may move references around so + we compute information about which bits of code refer to which CAF late in the + Cmm pipeline. + +* LambdaFormInfo. This records the details of a closure representation, + including + - the final arity (for functions) + - whether it is a data constructor, and if so its tag + +Collectively we call this CgInfo (see GHC.StgToCmm.Types). + +It's very useful for importing modules to have this information. We can always +make a conservative assumption, but that is bad: e.g. + +* For CAF info, if we know nothing we have to assume it is a CAF which bloats + the SRTs of the importing module. + + Conservative assumption here is made when creating new Ids. + +* For data constructors, we really like having well-tagged pointers. See #14677, + #16559, #15155, and wiki: commentary/rts/haskell-execution/pointer-tagging + + Conservative assumption here is made when we import an Id without a + LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.importedIdLFInfo. + +So we arrange to always serialise this information into the interface file. The +moving parts are: + +* We record the CgInfo in the IdInfo of the Id. + +* GHC.Driver.Pipeline: the call to updateModDetailsIdInfos augments the + ModDetails constructed at the end of the Core pipeline, with CgInfo + gleaned from the back end. The hard work is done in GHC.Iface.UpdateIdInfos. + +* For ModIface we generate the final ModIface with CgInfo in + GHC.Iface.Make.mkFullIface. + +* We don't absolutely guarantee to serialise the CgInfo: we won't if you have + -fomit-interface-pragmas or -fno-code; and we won't read it in if you have + -fignore-interface-pragmas. (We could revisit this decision.) + +Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in `Note [Conveying CAF-info and LFInfo between modules]`, +imported unlifted nullary datacons must have their LambdaFormInfo set to +reflect the fact that they are evaluated. This is necessary as otherwise +references to them may be passed untagged to code that expects tagged +references because of the unlifted nature of the argument. + +For example, in + + type T :: UnliftedType + data T = T1 + | T2 + + f :: T -> Int + f x = case x of T1 -> 1; T2 -> 2 + +`f` expects `x` to be evaluated and properly tagged due to its unliftedness. +We can guarantee all occurrences of `T1` and `T2` are considered evaluated and +are properly tagged by giving them the `LFCon` LambdaFormInfo which indicates +they are fully saturated constructor applications. +(The LambdaFormInfo is used to tag the pointer with the tag of the +constructor, in `litIdInfo`) + +What may be less obvious is that this must be done for not only datacon +workers but also *wrappers*. The reason is found in this program +from #23146: + + module B where + + type NP :: [UnliftedType] -> UnliftedType + data NP xs where + UNil :: NP '[] + + + module A where + import B + + fieldsSam :: NP xs -> NP xs -> Bool + fieldsSam UNil UNil = True + + x = fieldsSam UNil UNil + +Due to its GADT nature, `B.UNil` produces a trivial wrapper + + $WUNil :: NP '[] + $WUNil = UNil @'[] @~() + +which is referenced in the RHS of `A.x`. If we fail to give `$WUNil` the +correct `LFCon 0` `LambdaFormInfo` then we will end up passing an untagged +pointer to `fieldsSam`. This is problematic as `fieldsSam` may take advantage +of the unlifted nature of its arguments by omitting handling of the zero +tag when scrutinising them. + +The fix is straightforward: ensure we always construct a /correct/ LFInfo for +datacon workers and wrappers, and populate the `lfInfo` with it. See +Note [LFInfo of DataCon workers and wrappers]. This fixed #23146. + +See also Note [The LFInfo of Imported Ids] +-} + +-- | Codegen-generated Id infos, to be passed to downstream via interfaces. +-- +-- This stuff is for optimization purposes only, they're not compulsory. +-- +-- * When CafInfo of an imported Id is not known it's safe to treat it as CAFFY. +-- * When LambdaFormInfo of an imported Id is not known it's safe to treat it as +-- `LFUnknown True` (which just says "it could be anything" and we do slow +-- entry). +-- +-- See also Note [Conveying CAF-info and LFInfo between modules] above. +-- +data CmmCgInfos = CmmCgInfos + { cgNonCafs :: !NonCaffySet + -- ^ Exported Non-CAFFY closures in the current module. Everything else is + -- either not exported of CAFFY. + , cgLFInfos :: !ModuleLFInfos + -- ^ LambdaFormInfos of exported closures in the current module. + , cgIPEStub :: !CStub + -- ^ The C stub which is used for IPE information + } + +-------------------------------------------------------------------------------- +-- LambdaFormInfo +-------------------------------------------------------------------------------- + +-- | Maps names in the current module to their LambdaFormInfos +type ModuleLFInfos = NameEnv LambdaFormInfo + +-- | Information about an identifier, from the code generator's point of view. +-- Every identifier is bound to a LambdaFormInfo in the environment, which gives +-- the code generator enough info to be able to tail call or return that +-- identifier. +data LambdaFormInfo + = LFReEntrant -- Reentrant closure (a function) + !TopLevelFlag -- True if top level + !RepArity -- Arity. Invariant: always > 0 + !Bool -- True <=> no fvs + !ArgDescr -- Argument descriptor (should really be in ClosureInfo) + + | LFThunk -- Thunk (zero arity) + !TopLevelFlag + !Bool -- True <=> no free vars + !Bool -- True <=> updatable (i.e., *not* single-entry) + !StandardFormInfo + !Bool -- True <=> *might* be a function type + + | LFCon -- A saturated data constructor application + !DataCon -- The constructor + + | LFUnknown -- Used for function arguments and imported things. + -- We know nothing about this closure. + -- Treat like updatable "LFThunk"... + -- Imported things which we *do* know something about use + -- one of the other LF constructors (eg LFReEntrant for + -- known functions) + !Bool -- True <=> *might* be a function type + -- The False case is good when we want to enter it, + -- because then we know the entry code will do + -- For a function, the entry code is the fast entry point + + | LFUnlifted -- A value of unboxed type; + -- always a value, needs evaluation + + | LFLetNoEscape -- See LetNoEscape module for precise description + +instance Outputable LambdaFormInfo where + ppr (LFReEntrant top rep fvs argdesc) = + text "LFReEntrant" <> brackets + (ppr top <+> ppr rep <+> pprFvs fvs <+> ppr argdesc) + ppr (LFThunk top hasfv updateable sfi m_function) = + text "LFThunk" <> brackets + (ppr top <+> pprFvs hasfv <+> pprUpdateable updateable <+> + ppr sfi <+> pprFuncFlag m_function) + ppr (LFCon con) = + text "LFCon" <> brackets (ppr con) + ppr (LFUnknown m_func) = + text "LFUnknown" <> brackets (pprFuncFlag m_func) + ppr LFUnlifted = + text "LFUnlifted" + ppr LFLetNoEscape = + text "LFLetNoEscape" + +pprFvs :: Bool -> SDoc +pprFvs True = text "no-fvs" +pprFvs False = text "fvs" + +pprFuncFlag :: Bool -> SDoc +pprFuncFlag True = text "mFunc" +pprFuncFlag False = text "value" + +pprUpdateable :: Bool -> SDoc +pprUpdateable True = text "updateable" +pprUpdateable False = text "oneshot" + +-------------------------------------------------------------------------------- +-- | StandardFormInfo tells whether this thunk has one of a small number of +-- standard forms + +data StandardFormInfo + = NonStandardThunk + -- The usual case: not of the standard forms + + | SelectorThunk + -- A SelectorThunk is of form + -- case x of + -- con a1,..,an -> ak + -- and the constructor is from a single-constr type. + !WordOff -- 0-origin offset of ak within the "goods" of + -- constructor (Recall that the a1,...,an may be laid + -- out in the heap in a non-obvious order.) + + | ApThunk + -- An ApThunk is of form + -- x1 ... xn + -- The code for the thunk just pushes x2..xn on the stack and enters x1. + -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled + -- in the RTS to save space. + !RepArity -- Arity, n + deriving (Eq) + +instance Outputable StandardFormInfo where + ppr NonStandardThunk = text "RegThunk" + ppr (SelectorThunk w) = text "SelThunk:" <> ppr w + ppr (ApThunk n) = text "ApThunk:" <> ppr n + +-------------------------------------------------------------------------------- +-- Gaining sight in a sea of blindness +-------------------------------------------------------------------------------- +type DoSCCProfiling = Bool +type DoExtDynRefs = Bool diff --git a/GHC/StgToCmm/Utils.hs b/GHC/StgToCmm/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Utils.hs @@ -0,0 +1,731 @@ + + +----------------------------------------------------------------------------- +-- +-- Code generator utilities; mostly monadic +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module GHC.StgToCmm.Utils ( + emitDataLits, emitRODataLits, + emitDataCon, + emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, + emitBarf, + assignTemp, newTemp, + + newUnboxedTupleRegs, + + emitMultiAssign, emitCmmLitSwitch, emitSwitch, + + tagToClosure, mkTaggedObjectLoad, + + callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr, + callerSaveGlobalReg, callerRestoreGlobalReg, + + cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, + cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord, + cmmOffsetExprW, cmmOffsetExprB, + cmmRegOffW, cmmRegOffB, + cmmLabelOffW, cmmLabelOffB, + cmmOffsetW, cmmOffsetB, + cmmOffsetLitW, cmmOffsetLitB, + cmmLoadIndexW, + cmmConstrTag1, + + cmmUntag, cmmIsTagged, + + addToMem, addToMemE, addToMemLblE, addToMemLbl, + emitAtomicRead, emitAtomicWrite, + + -- * Update remembered set operations + whenUpdRemSetEnabled, + emitUpdRemSetPush, + emitUpdRemSetPushThunk, + + convertInfoProvMap, cmmInfoTableToInfoProvEnt, IPEStats(..), + closureIpeStats, fallbackIpeStats, skippedIpeStats, + ) where + +import GHC.Prelude hiding ( head, init, last, tail ) + +import GHC.Platform +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Closure +import GHC.StgToCmm.Lit (mkSimpleLit, newStringCLit) +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.Graph as CmmGraph +import GHC.Platform.Regs +import GHC.Cmm.CLabel +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import {-# SOURCE #-} GHC.StgToCmm.Foreign (emitPrimCall) +import GHC.StgToCmm.CgUtils + +import GHC.Types.ForeignCall +import GHC.Types.Id.Info +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Runtime.Heap.Layout +import GHC.Unit +import GHC.Types.Literal +import GHC.Data.Graph.Directed +import GHC.Utils.Misc +import GHC.Types.Unique +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.RepType +import GHC.Types.CostCentre +import GHC.Types.IPE + +import qualified Data.Map as M +import Data.List (sortBy) +import Data.Ord +import Data.Maybe +import qualified Data.List.NonEmpty as NE +import GHC.Core.DataCon +import GHC.Types.Unique.DFM +import GHC.Data.Maybe +import Control.Monad +import qualified Data.Map.Strict as Map +import qualified Data.IntMap.Strict as I +import qualified Data.Semigroup (Semigroup(..)) + +-------------------------------------------------------------------------- +-- +-- Incrementing a memory location +-- +-------------------------------------------------------------------------- + +addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph +addToMemLbl rep lbl = addToMem rep (CmmLit (CmmLabel lbl)) + +addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph +addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl)) + +-- | @addToMem rep ptr n@ adds @n@ to the integer pointed-to by @ptr@. +addToMem :: CmmType -- rep of the counter + -> CmmExpr -- Naturally-aligned address + -> Int -- What to add (a word) + -> CmmAGraph +addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep))) + +-- | @addToMemE rep ptr n@ adds @n@ to the integer pointed-to by @ptr@. +addToMemE :: CmmType -- rep of the counter + -> CmmExpr -- Naturally-aligned address + -> CmmExpr -- What to add (a word-typed expression) + -> CmmAGraph +addToMemE rep ptr n + = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep NaturallyAligned, n]) + +------------------------------------------------------------------------- +-- Atomic loads and stores +------------------------------------------------------------------------- + +emitAtomicRead + :: MemoryOrdering + -> LocalReg -- ^ result register + -> CmmExpr -- ^ address + -> FCode () +emitAtomicRead mord res addr + = void $ emitPrimCall [res] (MO_AtomicRead w mord) [addr] + where + w = typeWidth $ localRegType res + +emitAtomicWrite + :: MemoryOrdering + -> CmmExpr -- ^ address + -> CmmExpr -- ^ value + -> FCode () +emitAtomicWrite mord addr val + = do platform <- getPlatform + let w = typeWidth $ cmmExprType platform val + void $ emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + +------------------------------------------------------------------------- +-- +-- Loading a field from an object, +-- where the object pointer is itself tagged +-- +------------------------------------------------------------------------- + +mkTaggedObjectLoad + :: Platform -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph +-- (loadTaggedObjectField reg base off tag) generates assignment +-- reg = bitsK[ base + off - tag ] +-- where K is fixed by 'reg' +mkTaggedObjectLoad platform reg base offset tag + = mkAssign (CmmLocal reg) + (CmmLoad (cmmOffsetB platform + (CmmReg (CmmLocal base)) + (offset - tag)) + (localRegType reg) + NaturallyAligned) + +------------------------------------------------------------------------- +-- +-- Converting a closure tag to a closure for enumeration types +-- (this is the implementation of tagToEnum#). +-- +------------------------------------------------------------------------- + +tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr +tagToClosure platform tycon tag + = cmmLoadBWord platform (cmmOffsetExprW platform closure_tbl tag) + where closure_tbl = CmmLit (CmmLabel lbl) + lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs + +------------------------------------------------------------------------- +-- +-- Conditionals and rts calls +-- +------------------------------------------------------------------------- + +emitBarf :: String -> FCode () +emitBarf msg = do + strLbl <- newStringCLit msg + emitRtsCall rtsUnitId (fsLit "barf") [(CmmLit strLbl,AddrHint)] False + +emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) + +emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString + -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCallWithResult res hint pkg = emitRtsCallGen [(res,hint)] . mkCmmCodeLabel pkg + +-- Make a call to an RTS C procedure +emitRtsCallGen + :: [(LocalReg,ForeignHint)] + -> CLabel + -> [(CmmExpr,ForeignHint)] + -> Bool -- True <=> CmmSafe call + -> FCode () +emitRtsCallGen res lbl args safe + = do { platform <- getPlatform + ; updfr_off <- getUpdFrameOff + ; let (caller_save, caller_load) = callerSaveVolatileRegs platform + ; emit caller_save + ; call updfr_off + ; emit caller_load } + where + call updfr_off = + if safe then + emit =<< mkCmmCall fun_expr res' args' updfr_off + else do + let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn + emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args' + (args', arg_hints) = unzip args + (res', res_hints) = unzip res + fun_expr = mkLblExpr lbl + + +----------------------------------------------------------------------------- +-- +-- Caller-Save Registers +-- +----------------------------------------------------------------------------- + +-- Here we generate the sequence of saves/restores required around a +-- foreign call instruction. + +-- TODO: reconcile with rts/include/Regs.h +-- * Regs.h claims that BaseReg should be saved last and loaded first +-- * This might not have been tickled before since BaseReg is callee save +-- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim +-- +-- This code isn't actually used right now, because callerSaves +-- only ever returns true in the current universe for registers NOT in +-- system_regs (just do a grep for CALLER_SAVES in +-- rts/include/stg/MachRegs.h). It's all one giant no-op, and for +-- good reason: having to save system registers on every foreign call +-- would be very expensive, so we avoid assigning them to those +-- registers when we add support for an architecture. +-- +-- Note that the old code generator actually does more work here: it +-- also saves other global registers. We can't (nor want) to do that +-- here, as we don't have liveness information. And really, we +-- shouldn't be doing the workaround at this point in the pipeline, see +-- Note [Register parameter passing] and the ToDo on CmmCall in +-- "GHC.Cmm.Node". Right now the workaround is to avoid inlining across +-- unsafe foreign calls in GHC.Cmm.Sink, but this is strictly +-- temporary. +callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph) +callerSaveVolatileRegs platform = (caller_save, caller_load) + where + caller_save = catAGraphs (map (callerSaveGlobalReg platform) regs_to_save) + caller_load = catAGraphs (map (callerRestoreGlobalReg platform) regs_to_save) + + system_regs = + [ Sp, SpLim + , Hp, HpLim + , CCCS, CurrentTSO, CurrentNursery + , BaseReg ] + + regs_to_save = filter (callerSaves platform) system_regs + +callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph +callerSaveGlobalReg platform reg + = let ru = GlobalRegUse reg (globalRegSpillType platform reg) + in mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal ru)) + +callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph +callerRestoreGlobalReg platform reg + = let reg_ty = globalRegSpillType platform reg + ru = GlobalRegUse reg reg_ty + in mkAssign (CmmGlobal ru) + (CmmLoad (get_GlobalReg_addr platform reg) + reg_ty NaturallyAligned) + +------------------------------------------------------------------------- +-- +-- Strings generate a top-level data block +-- +------------------------------------------------------------------------- + +-- | Emit a data-segment data block +emitDataLits :: CLabel -> [CmmLit] -> FCode () +emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits) + +-- | Emit a read-only data block +emitRODataLits :: CLabel -> [CmmLit] -> FCode () +emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits) + +emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode () +emitDataCon lbl itbl ccs payload = + emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload [])) + +------------------------------------------------------------------------- +-- +-- Assigning expressions to temporaries +-- +------------------------------------------------------------------------- + +assignTemp :: CmmExpr -> FCode LocalReg +-- Make sure the argument is in a local register. +-- We don't bother being particularly aggressive with avoiding +-- unnecessary local registers, since we can rely on a later +-- optimization pass to inline as necessary (and skipping out +-- on things like global registers can be a little dangerous +-- due to them being trashed on foreign calls--though it means +-- the optimization pass doesn't have to do as much work) +assignTemp (CmmReg (CmmLocal reg)) = return reg +assignTemp e = do { platform <- getPlatform + ; reg <- newTemp (cmmExprType platform e) + ; emitAssign (CmmLocal reg) e + ; return reg } + +newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint]) +-- Choose suitable local regs to use for the components +-- of an unboxed tuple that we are about to return to +-- the Sequel. If the Sequel is a join point, using the +-- regs it wants will save later assignments. +newUnboxedTupleRegs res_ty + = assert (isUnboxedTupleType res_ty) $ + do { platform <- getPlatform + ; sequel <- getSequel + ; regs <- choose_regs platform sequel + ; massert (regs `equalLength` reps) + ; return (regs, map primRepForeignHint reps) } + where + reps = typePrimRep res_ty + choose_regs _ (AssignTo regs _) = return regs + choose_regs platform _ = mapM (newTemp . primRepCmmType platform) reps + +------------------------------------------------------------------------- +-- emitMultiAssign +------------------------------------------------------------------------- + +emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode () +-- Emit code to perform the assignments in the +-- input simultaneously, using temporary variables when necessary. + +type Key = Int +type Vrtx = (Key, Stmt) -- Give each vertex a unique number, + -- for fast comparison +type Stmt = (LocalReg, CmmExpr) -- r := e + +-- We use the strongly-connected component algorithm, in which +-- * the vertices are the statements +-- * an edge goes from s1 to s2 iff +-- s1 assigns to something s2 uses +-- that is, if s1 should *follow* s2 in the final order + +emitMultiAssign [] [] = return () +emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs +emitMultiAssign regs rhss = do + platform <- getPlatform + assertPpr (equalLength regs rhss) (ppr regs $$ pdoc platform rhss) $ + unscramble platform ([1..] `zip` (regs `zip` rhss)) + +unscramble :: Platform -> [Vrtx] -> FCode () +unscramble platform vertices = mapM_ do_component components + where + edges :: [ Node Key Vrtx ] + edges = [ DigraphNode vertex key1 (edges_from stmt1) + | vertex@(key1, stmt1) <- vertices ] + + edges_from :: Stmt -> [Key] + edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, + stmt1 `mustFollow` stmt2 ] + + components :: [SCC Vrtx] + components = stronglyConnCompFromEdgedVerticesUniq edges + + -- do_components deal with one strongly-connected component + -- Not cyclic, or singleton? Just do it + do_component :: SCC Vrtx -> FCode () + do_component (AcyclicSCC (_,stmt)) = mk_graph stmt + do_component (CyclicSCC []) = panic "do_component" + do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt + + -- Cyclic? Then go via temporaries. Pick one to + -- break the loop and try again with the rest. + do_component (CyclicSCC ((_,first_stmt) : rest)) = do + u <- newUnique + let (to_tmp, from_tmp) = split u first_stmt + mk_graph to_tmp + unscramble platform rest + mk_graph from_tmp + + split :: Unique -> Stmt -> (Stmt, Stmt) + split uniq (reg, rhs) + = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp))) + where + rep = cmmExprType platform rhs + tmp = LocalReg uniq rep + + mk_graph :: Stmt -> FCode () + mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs + + mustFollow :: Stmt -> Stmt -> Bool + (reg, _) `mustFollow` (_, rhs) = regUsedIn platform (CmmLocal reg) rhs + +------------------------------------------------------------------------- +-- mkSwitch +------------------------------------------------------------------------- + + +emitSwitch :: CmmExpr -- Tag to switch on + -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches + -> Maybe CmmAGraphScoped -- Default branch (if any) + -> ConTagZ -> ConTagZ -- Min and Max possible values; + -- behaviour outside this range is + -- undefined + -> FCode () + +-- First, two rather common cases in which there is no work to do +emitSwitch _ [] (Just code) _ _ = emit (fst code) +emitSwitch _ [(_,code)] Nothing _ _ = emit (fst code) + +-- Right, off we go +emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do + join_lbl <- newBlockId + mb_deflt_lbl <- label_default join_lbl mb_deflt + branches_lbls <- label_branches join_lbl branches + tag_expr' <- assignTemp' tag_expr + + -- Sort the branches before calling mk_discrete_switch + let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ] + let range = (fromIntegral lo_tag, fromIntegral hi_tag) + + emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range + + emitLabel join_lbl + +mk_discrete_switch :: Bool -- ^ Use signed comparisons + -> CmmExpr + -> [(Integer, BlockId)] + -> Maybe BlockId + -> (Integer, Integer) + -> CmmAGraph + +-- SINGLETON TAG RANGE: no case analysis to do +mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag) + | lo_tag == hi_tag + = assert (tag == lo_tag) $ + mkBranch lbl + +-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do +mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _ + = mkBranch lbl + -- The simplifier might have eliminated a case + -- so we may have e.g. case xs of + -- [] -> e + -- In that situation we can be sure the (:) case + -- can't happen, so no need to test + +-- SOMETHING MORE COMPLICATED: defer to GHC.Cmm.Switch.Implement +-- See Note [Cmm Switches, the general plan] in GHC.Cmm.Switch +mk_discrete_switch signed tag_expr branches mb_deflt range + = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches) + +divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)]) +divideBranches branches = (lo_branches, mid, hi_branches) + where + -- 2 branches => n_branches `div` 2 = 1 + -- => branches !! 1 give the *second* tag + -- There are always at least 2 branches here + (mid,_) = branches !! (length branches `div` 2) + (lo_branches, hi_branches) = span is_lo branches + is_lo (t,_) = t < mid + +-------------- +emitCmmLitSwitch :: CmmExpr -- Tag to switch on + -> [(Literal, CmmAGraphScoped)] -- Tagged branches + -> CmmAGraphScoped -- Default branch (always) + -> FCode () -- Emit the code +emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt +emitCmmLitSwitch scrut branches@(branch:_) deflt = do + scrut' <- assignTemp' scrut + join_lbl <- newBlockId + deflt_lbl <- label_code join_lbl deflt + branches_lbls <- label_branches join_lbl branches + + platform <- getPlatform + let cmm_ty = cmmExprType platform scrut + rep = typeWidth cmm_ty + + -- We find the necessary type information in the literals in the branches + let (signed,range) = case branch of + (LitNumber nt _, _) -> (signed,range) + where + signed = litNumIsSigned nt + range = case litNumRange platform nt of + (Just mi, Just ma) -> (mi,ma) + -- unbounded literals (Natural and + -- Integer) must have been + -- lowered at this point + partial_bounds -> pprPanic "Unexpected unbounded literal range" + (ppr partial_bounds) + -- assuming native word range + _ -> (False, (0, platformMaxWord platform)) + + if isFloatType cmm_ty + then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls + else emit $ mk_discrete_switch + signed + scrut' + [(litValue lit,l) | (lit,l) <- branches_lbls] + (Just deflt_lbl) + range + emitLabel join_lbl + +-- | lower bound (inclusive), upper bound (exclusive) +type LitBound = (Maybe Literal, Maybe Literal) + +noBound :: LitBound +noBound = (Nothing, Nothing) + +mk_float_switch :: Width -> CmmExpr -> BlockId + -> LitBound + -> [(Literal,BlockId)] + -> FCode CmmAGraph +mk_float_switch rep scrut deflt _bounds [(lit,blk)] + = do platform <- getPlatform + return $ mkCbranch (cond platform) deflt blk Nothing + where + cond platform = CmmMachOp ne [scrut, CmmLit cmm_lit] + where + cmm_lit = mkSimpleLit platform lit + ne = MO_F_Ne rep + +mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches + = do platform <- getPlatform + lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches + hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches + mkCmmIfThenElse (cond platform) lo_blk hi_blk + where + (lo_branches, mid_lit, hi_branches) = divideBranches branches + + bounds_lo = (lo_bound, Just mid_lit) + bounds_hi = (Just mid_lit, hi_bound) + + cond platform = CmmMachOp lt [scrut, CmmLit cmm_lit] + where + cmm_lit = mkSimpleLit platform mid_lit + lt = MO_F_Lt rep + + +-------------- +label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId) +label_default _ Nothing + = return Nothing +label_default join_lbl (Just code) + = do lbl <- label_code join_lbl code + return (Just lbl) + +-------------- +label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)] +label_branches _join_lbl [] + = return [] +label_branches join_lbl ((tag,code):branches) + = do lbl <- label_code join_lbl code + branches' <- label_branches join_lbl branches + return ((tag,lbl):branches') + +-------------- +label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId +-- label_code J code +-- generates +-- [L: code; goto J] +-- and returns L +label_code join_lbl (code,tsc) = do + lbl <- newBlockId + emitOutOfLine lbl (code CmmGraph.<*> mkBranch join_lbl, tsc) + return lbl + +-------------- +assignTemp' :: CmmExpr -> FCode CmmExpr +assignTemp' e + | isTrivialCmmExpr e = return e + | otherwise = do + platform <- getPlatform + lreg <- newTemp (cmmExprType platform e) + let reg = CmmLocal lreg + emitAssign reg e + return (CmmReg reg) + +--------------------------------------------------------------------------- +-- Pushing to the update remembered set +--------------------------------------------------------------------------- + +whenUpdRemSetEnabled :: FCode a -> FCode () +whenUpdRemSetEnabled code = do + platform <- getPlatform + do_it <- getCode code + let + enabled = cmmLoadBWord platform (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) + zero = zeroExpr platform + is_enabled = cmmNeWord platform enabled zero + the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False) + emit the_if + +-- | Emit code to add an entry to a now-overwritten pointer to the update +-- remembered set. +emitUpdRemSetPush :: CmmExpr -- ^ value of pointer which was overwritten + -> FCode () +emitUpdRemSetPush ptr = do + platform <- getPlatform + emitRtsCall + rtsUnitId + (fsLit "updateRemembSetPushClosure_") + [(CmmReg $ baseReg platform, AddrHint), + (ptr, AddrHint)] + False + +emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk + -> FCode () +emitUpdRemSetPushThunk ptr = do + platform <- getPlatform + emitRtsCall + rtsUnitId + (fsLit "updateRemembSetPushThunk_") + [(CmmReg $ baseReg platform, AddrHint), + (ptr, AddrHint)] + False + +-- | A bare bones InfoProvEnt for things which don't have a good source location +cmmInfoTableToInfoProvEnt :: Module -> CmmInfoTable -> InfoProvEnt +cmmInfoTableToInfoProvEnt this_mod cmit = + let cl = cit_lbl cmit + cn = rtsClosureType (cit_rep cmit) + in InfoProvEnt cl cn "" this_mod Nothing + +data IPEStats = IPEStats { ipe_total :: !Int + , ipe_closure_types :: !(I.IntMap Int) + , ipe_fallback :: !Int + , ipe_skipped :: !Int } + +instance Semigroup IPEStats where + (IPEStats a1 a2 a3 a4) <> (IPEStats b1 b2 b3 b4) = IPEStats (a1 + b1) (I.unionWith (+) a2 b2) (a3 + b3) (a4 + b4) + +instance Monoid IPEStats where + mempty = IPEStats 0 I.empty 0 0 + +fallbackIpeStats :: IPEStats +fallbackIpeStats = mempty { ipe_total = 1, ipe_fallback = 1 } + +closureIpeStats :: Int -> IPEStats +closureIpeStats t = mempty { ipe_total = 1, ipe_closure_types = I.singleton t 1 } + +skippedIpeStats :: IPEStats +skippedIpeStats = mempty { ipe_skipped = 1 } + +instance Outputable IPEStats where + ppr = pprIPEStats + +pprIPEStats :: IPEStats -> SDoc +pprIPEStats (IPEStats{..}) = + vcat $ [ text "Tables with info:" <+> ppr ipe_total + , text "Tables with fallback:" <+> ppr ipe_fallback + , text "Tables skipped:" <+> ppr ipe_skipped + ] ++ [ text "Info(" <> ppr k <> text "):" <+> ppr n | (k, n) <- I.assocs ipe_closure_types ] + +-- | Convert source information collected about identifiers in 'GHC.STG.Debug' +-- to entries suitable for placing into the info table provenance table. +-- +-- The initial stats given to this function will (or should) only contain stats +-- for stack info tables skipped during 'generateCgIPEStub'. As the fold +-- progresses, counts of tables per closure type will be accumulated. +convertInfoProvMap :: StgToCmmConfig -> Module -> InfoTableProvMap -> IPEStats -> [CmmInfoTable] -> (IPEStats, [InfoProvEnt]) +convertInfoProvMap cfg this_mod (InfoTableProvMap dcenv denv infoTableToSourceLocationMap) initStats cmits = + foldl' convertInfoProvMap' (initStats, []) cmits + where + convertInfoProvMap' :: (IPEStats, [InfoProvEnt]) -> CmmInfoTable -> (IPEStats, [InfoProvEnt]) + convertInfoProvMap' (!stats, acc) cmit = do + let + cl = cit_lbl cmit + cn = rtsClosureType (cit_rep cmit) + + tyString :: Outputable a => a -> String + tyString = renderWithContext defaultSDocContext . ppr + + lookupClosureMap :: Maybe (IPEStats, InfoProvEnt) + lookupClosureMap = case hasHaskellName cl >>= fmap snd . lookupUDFM denv of + Just (ty, mbspan) -> Just (closureIpeStats cn, (InfoProvEnt cl cn (tyString ty) this_mod mbspan)) + Nothing -> Nothing + + lookupDataConMap :: Maybe (IPEStats, InfoProvEnt) + lookupDataConMap = (closureIpeStats cn,) <$> 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 >>= lookupUDFM_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 :: Maybe (IPEStats, InfoProvEnt) + lookupInfoTableToSourceLocation = do + sourceNote <- Map.lookup (cit_lbl cmit) infoTableToSourceLocationMap + return $ (closureIpeStats cn, (InfoProvEnt cl cn "" this_mod sourceNote)) + + -- This catches things like prim closure types and anything else which doesn't have a + -- source location + simpleFallback = + if stgToCmmInfoTableMapWithFallback cfg then + -- Create a default entry with fallback IPE data + Just (fallbackIpeStats, cmmInfoTableToInfoProvEnt this_mod cmit) + else + -- If we are omitting tables with fallback info + -- (-fno-info-table-map-with-fallback was given), do not create an + -- entry + Nothing + + trackSkipped :: Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt]) + trackSkipped Nothing = + (stats Data.Semigroup.<> skippedIpeStats, acc) + trackSkipped (Just (s, !c)) = + (stats Data.Semigroup.<> s, c:acc) + + trackSkipped $ + if (isStackRep . cit_rep) cmit then + -- Note that we should have already skipped STACK info tables if + -- necessary in 'generateCgIPEStub', so we should not need to worry + -- about doing that here. + fromMaybe simpleFallback (Just <$> lookupInfoTableToSourceLocation) + else + fromMaybe simpleFallback (Just <$> firstJust lookupDataConMap lookupClosureMap) diff --git a/GHC/StgToJS.hs b/GHC/StgToJS.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS.hs @@ -0,0 +1,233 @@ +module GHC.StgToJS + ( stgToJS + ) +where + +import GHC.StgToJS.CodeGen + + +-- Note [StgToJS design] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- +-- StgToJS ("JS backend") is adapted from GHCJS [GHCJS2013]. +-- +-- Implementation Big Picture +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The big picture of the JS backend is roughly: +-- +-- JS Backend --> JStgExpr ----> JExpr +-- | +-- V +-- STG -------------------------> JExpr --> Optimizations --> Code Gen +-- +-- Why this design? Because we generate the RTS via an eDSL, if we accidentally +-- create a bug in the RTS we will not find out until we have completely +-- finished compiling and are running the testsuite. Thus having a typed eDSL +-- with which we can write the RTS is beneficial because a type error will have +-- a much faster turn around than building and then trying to debug a bunch of +-- generated, z-encoded code. +-- +-- Haskell to JavaScript +-- ~~~~~~~~~~~~~~~~~~~~~ +-- StgToJS converts STG into a JavaScript AST (in GHC.JS) that has been adapted +-- from JMacro [JMacro]. +-- +-- Tail calls: translated code is tail call optimized through a trampoline, +-- since JavaScript implementations don't always support tail calls. +-- +-- JavaScript ASTs are then optimized. A dataflow analysis is performed and then +-- dead code and redundant assignments are removed. +-- +-- Primitives +-- ~~~~~~~~~~ +-- Haskell primitives have to be represented as JavaScript values. This is done +-- as follows: +-- +-- - Int#/Int32# -> number in Int32 range +-- - Int16# -> number in Int16 range +-- - Int8# -> number in Int8 range +-- - Word#/Word32# -> number in Word32 range +-- - Word16# -> number in Word16 range +-- - Word8# -> number in Word8 range +-- +-- - Float#/Double# -> both represented as Javascript Double (no Float!) +-- +-- - Int64# -> represented with two fields: +-- high -> number in Int32 range +-- low -> number in Word32 range +-- - Word64# -> represented with two fields: high, low +-- high -> number in Word32 range +-- low -> number in Word32 range +-- +-- - Addr# -> represented with two fields: array (used as a namespace) and index +-- - StablePtr# -> similar to Addr# with array fixed to h$stablePtrBuf +-- +-- - JSVal# -> any Javascript object (used to pass JS objects via FFI) +-- +-- - TVar#, MVar#, etc. are represented with JS objects +-- +-- Foreign JavaScript imports +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- StgToJS supports inline JavaScript code. Example: +-- +-- > foreign import javascript unsafe +-- > "((x,y) => x + y)" +-- > plus :: Int -> Int -> Int +-- +-- Currently the JS backend only supports functions as JS imports. +-- +-- In comparison, GHCJS supports JavaScript snippets with $1, $2... variables +-- as placeholders for the arguments. It requires a JavaScript parser that the +-- JS backend lacks. In GHCJS, the parser is inherited from JMacro and supports +-- local variable declarations, loops, etc. Local variables are converted to +-- hygienic names to avoid capture. +-- +-- Primitives that are represented as multiple values (Int64#, Word64#, Addr#) +-- are passed to FFI functions with multiple arguments. +-- +-- Interruptible convention: FFI imports with the "interruptible" calling +-- convention are passed an extra argument (usually named "$c") that is a +-- continuation function. The FFI function must call this function to return to +-- Haskell code. +-- +-- Unboxed tuples: returning an unboxed tuple can be done with the predefined +-- macros RETURN_UBX_TUPn where n is the size of the tuples. Internally it uses +-- predefined "h$retN" global variables to pass additional values; the first +-- element of the tuple is returned normally. +-- +-- Memory management +-- ~~~~~~~~~~~~~~~~~ +-- Heap objects are represented as JavaScript values. +-- +-- Most heap objects are represented generically as JavaScript "objects" (hash +-- maps). However, some Haskell heap objects can use use a more memory efficient +-- JavaScript representation: number, string... An example of a consequence of +-- this is that both Int# and Int are represented the same as a JavaScript +-- number. JavaScript introspection (e.g. typeof) is used to differentiate +-- heap object representations when necessary. +-- +-- Generic representation: objects on the heap ("closures") are represented as +-- JavaScript objects with the following fields: +-- +-- { f -- (function) entry function + info table +-- , d1 -- two fields of payload +-- , d2 +-- , m -- GC mark +-- , cc -- optional cost-center +-- } +-- +-- Payload: payload only consists of two fields (d1, d2). When more than two +-- fields of payload are required, the second field is itself an object. +-- payload [] ==> { d1 = null, d2 = null } +-- payload [a] ==> { d1 = a , d2 = null } +-- payload [a,b] ==> { d1 = a , d2 = b } +-- payload [a,b,c] ==> { d1 = a , d2 = { d1 = b, d2 = c} } +-- payload [a,b,c...] ==> { d1 = a , d2 = { d1 = b, d2 = c, ...} } +-- +-- Entry function/ info tables: JavaScript functions are JavaScript objects. If +-- "f" is a function, we can: +-- - call it, e.g. "f(arg0,arg1...)" +-- - get/set its fields, e.g. "f.xyz = abc" +-- This is used to implement the equivalent of tables-next-to-code in +-- JavaScript: every heap object has an entry function "f" that also contains +-- some metadata (info table) about the Haskell object: +-- { t -- object type +-- , size -- number of fields in the payload (-1 if variable layout) +-- , i -- (array) fields layout (empty if variable layout) +-- , n -- (string) object name for easier dubugging +-- , a -- constructor tag / fun arity +-- , r -- ?? +-- , s -- static references? +-- , m -- GC mark? +-- } +-- +-- Payloads for each kind of heap object: +-- +-- THUNK = +-- { f = returns the object reduced to WHNF +-- , m = ? +-- , d1 = ? +-- , d2 = ? +-- } +-- +-- FUN = +-- { f = function itself +-- , m = ? +-- , d1 = free variable 1 +-- , d2 = free variable 2 +-- } +-- +-- There are two different kinds of partial application: +-- - pap_r : pre-generated PAP that contains r registers +-- - pap_gen : generic PAP, contains any number of registers +-- +-- PAP = +-- { f = ? +-- , m = ? +-- , d1 = function +-- , d2 = +-- { d1 & 0xff = number of args (PAP arity) +-- , d1 >> 8 = number of registers (r for h$pap_r) +-- , d2, d3... = args (r) +-- } +-- } +-- +-- CON = +-- { f = entry function of the datacon worker +-- , m = 0 +-- , d1 = first arg +-- , d2 = arity = 2: second arg +-- arity > 2: { d1, d2, ...} object with remaining args (starts with "d1 = x2"!) +-- } +-- +-- BLACKHOLE = +-- { f = h$blackhole +-- , m = ? +-- , d1 = owning TSO +-- , d2 = waiters array +-- } +-- +-- StackFrame closures are *not* represented as JS objects. Instead they are +-- "unpacked" in the stack, i.e. a stack frame occupies a few slots in the JS +-- array representing the stack ("h$stack"). +-- +-- When a shared thunk is entered, it is overriden with a black hole ("eager +-- blackholing") and an update frame is pushed on the stack. +-- +-- Stack: the Haskell stack is implemented with a dynamically growing JavaScript +-- array ("h$stack"). +-- TODO: does it shrink sometimes? +-- TODO: what are the elements of the stack? one JS object per stack frame? +-- +-- +-- Interaction with JavaScript's garbage collector +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Using JS objects to represent Haskell heap objects means that JS's GC does +-- most of the memory management work. +-- +-- However, GHC extends Haskell with features that rely on GC layer violation +-- (weak references, finalizers, etc.). To support these features, a heap scan +-- is can be performed (using TSOs, StablePtr, etc. as roots) to mark reachable +-- objects. Scanning the heap is an expensive operation, but fortunately it +-- doesn't need to happen too often and it can be disabled. +-- +-- TODO: importance of eager blackholing +-- +-- Concurrency +-- ~~~~~~~~~~~ +-- The scheduler is implemented in JS and runs in a single JavaScript thread +-- (similarly to the C RTS not using `-threaded`). +-- +-- The scheduler relies on callbacks/continuations to interact with other JS +-- codes (user interface, etc.). In particular, safe foreign import can use "$c" +-- as a continuation function to return to Haskell code. +-- +-- TODO: is this still true since 2013 or are we using more recent JS features now? +-- TODO: synchronous threads +-- +-- +-- REFERENCES +-- * [GHCJS2013] "Demo Proposal: GHCJS, Concurrent Haskell in the Browser", Luite Stegeman, +-- 2013 (https://www.haskell.org/haskell-symposium/2013/ghcjs.pdf) +-- * [JMacro] https://hackage.haskell.org/package/jmacro diff --git a/GHC/StgToJS/Apply.hs b/GHC/StgToJS/Apply.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Apply.hs @@ -0,0 +1,1334 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Apply +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- Module that deals with expression application in JavaScript. In some cases we +-- rely on pre-generated functions that are bundled with the RTS (see rtsApply). +----------------------------------------------------------------------------- + +module GHC.StgToJS.Apply + ( genApp + , rtsApply + ) +where + +import GHC.Prelude hiding ((.|.)) + +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import GHC.JS.Ident +import GHC.JS.Make + +import GHC.StgToJS.Arg +import GHC.StgToJS.Closure +import GHC.StgToJS.DataCon +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Heap +import GHC.StgToJS.Ids +import GHC.StgToJS.Monad +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.Rts.Types +import GHC.StgToJS.Stack +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types +import GHC.StgToJS.Utils +import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8) + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.CostCentre +import GHC.Types.RepType (mightBeFunTy) +import GHC.Types.Literal + +import GHC.Stg.Syntax + +import GHC.Builtin.Names + +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Type hiding (typeSize) + +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Outputable (vcat, ppr) +import GHC.Data.FastString + +import qualified Data.Bits as Bits +import Data.Monoid +import Data.Array + +-- | Pre-generated functions for fast Apply. +-- These are bundled with the RTS. +rtsApply :: StgToJSConfig -> JSM JStgStat +rtsApply cfg = jBlock + [ mconcat <$> mapM (specApply cfg) applySpec + , mconcat <$> mapM (pap cfg) specPap + , mkApplyArr + , genericStackApply cfg + , genericFastApply cfg + , zeroApply cfg + , updates cfg + , papGen cfg + , selectors cfg + , moveRegs2 + ] + +-- | Generate an application of some args to an Id. +-- +-- The case where args is null is common as it's used to generate the evaluation +-- code for an Id. +genApp + :: HasDebugCallStack + => ExprCtx + -> Id + -> [StgArg] + -> G (JStgStat, ExprResult) +genApp ctx i args + -- Test case moved to T24744 + -- See: https://github.com/ghcjs/ghcjs/blob/b7711fbca7c3f43a61f1dba526e6f2a2656ef44c/src/Gen2/Generator.hs#L876 + -- Comment by Luite Stegeman + -- Special cases for JSString literals. + -- We could handle unpackNBytes# here, but that's probably not common + -- enough to warrant a special case. + -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588/#note_503978 + -- Comment by Jeffrey Young + -- We detect if the Id is unsafeUnpackJSStringUtf8## applied to a string literal, + -- if so then we convert the unsafeUnpack to a call to h$decode. + | [StgVarArg v] <- args + , idName i == unsafeUnpackJSStringUtf8ShShName + -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588 + -- Comment by Josh Meredith + -- `typex_expr` can throw an error for certain bindings so it's important + -- that this condition comes after matching on the function name + , [top] <- concatMap typex_expr (ctxTarget ctx) + = (,ExprInline) . (|=) top . app hdDecodeUtf8Z <$> varsForId v + + -- Test case T23479 + | [StgLitArg (LitString bs)] <- args + , Just d <- decodeModifiedUTF8 bs + , idName i == unsafeUnpackJSStringUtf8ShShName + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return . (,ExprInline) $ top |= toJExpr d + + -- Test case T24495 with single occurrence at -02 and third occurrence at -01 + -- Moved back from removal at https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12308 + -- See commit hash b36ee57bfbecc628b7f0919e1e59b7066495034f + -- + -- Case: unpackCStringAppend# "some string"# str + -- + -- Generates h$appendToHsStringA(str, "some string"), which has a faster + -- decoding loop. + | [StgLitArg (LitString bs), x] <- args + , Just d <- decodeModifiedUTF8 bs + , getUnique i == unpackCStringAppendIdKey + , [top] <- concatMap typex_expr (ctxTarget ctx) + = do + prof <- csProf <$> getSettings + let profArg = if prof then [jCafCCS] else [] + a <- genArg x + return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg) + , ExprInline + ) + | [StgLitArg (LitString bs), x] <- args + , Just d <- decodeModifiedUTF8 bs + , getUnique i == unpackCStringAppendUtf8IdKey + , [top] <- concatMap typex_expr (ctxTarget ctx) + = do + prof <- csProf <$> getSettings + let profArg = if prof then [jCafCCS] else [] + a <- genArg x + return ( top |= app "h$appendToHsString" (toJExpr d : a ++ profArg) + , ExprInline + ) + + -- Case: unpackCString# "some string"# + -- + -- Generates h$toHsString("some string"), which has a faster + -- decoding loop. + -- + Utf8 version below + | [StgLitArg (LitString bs)] <- args + , Just d <- decodeModifiedUTF8 bs + , idName i == unpackCStringName + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return + ( top |= app "h$toHsStringA" [toJExpr d] + , ExprInline + ) + | [StgLitArg (LitString bs)] <- args + , Just d <- decodeModifiedUTF8 bs + , idName i == unpackCStringUtf8Name + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return + ( top |= app "h$toHsString" [toJExpr d] + , ExprInline + ) + + -- let-no-escape + | Just n <- ctxLneBindingStackSize ctx i + = do + as' <- concatMapM genArg args + ei <- varForEntryId i + let ra = mconcat . reverse $ + zipWith (\r a -> toJExpr r |= a) [R1 ..] as' + p <- pushLneFrame n ctx + a <- adjSp 1 -- for the header (which will only be written when the thread is suspended) + return (ra <> p <> a <> returnS ei, ExprCont) + + -- proxy# + | [] <- args + , getUnique i == proxyHashKey + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return (top |= null_, ExprInline) + + -- unboxed tuple or strict type: return fields individually + | [] <- args + , isUnboxedTupleType (idType i) || isStrictType (idType i) + = do + a <- storeIdFields i (ctxTarget ctx) + return (a, ExprInline) + + -- Handle alternative heap object representation: in some cases, a heap + -- object is not represented as a JS object but directly as a number or a + -- string. I.e. only the payload is stored because the box isn't useful. + -- It happens for "Int Int#" for example: no need to box the Int# in JS. + -- + -- We must check that: + -- - the object is subject to the optimization (cf isUnboxable predicate) + -- - we know that it is already evaluated (cf ctxIsEvaluated), otherwise we + -- need to evaluate it properly first. + -- + -- In which case we generate a dynamic check (using isObject) that either: + -- - returns the payload of the heap object, if it uses the generic heap + -- object representation + -- - returns the object directly, otherwise + | [] <- args + , [vt] <- idJSRep i + , isUnboxable vt + , ctxIsEvaluated i + = do + let c = head (concatMap typex_expr $ ctxTarget ctx) + is <- varsForId i + case is of + [i'] -> + return ( c |= if_ (isObject i') (closureField1 i') i' + , ExprInline + ) + _ -> panic "genApp: invalid size" + + -- case of Id without args and known to be already evaluated: return fields + -- individually + | [] <- args + , ctxIsEvaluated i || isStrictType (idType i) + = do + a <- storeIdFields i (ctxTarget ctx) + -- optional runtime assert for detecting unexpected thunks (unevaluated) + settings <- getSettings + let ww = case concatMap typex_expr (ctxTarget ctx) of + [t] | csAssertRts settings -> + ifS (isObject t .&&. isThunk t) + (appS throwStr [String "unexpected thunk"]) -- yuck + mempty + _ -> mempty + return (a `mappend` ww, ExprInline) + + + -- Case: "newtype" datacon wrapper + -- + -- If the wrapped argument is known to be already evaluated, then we don't + -- need to enter it. + | DataConWrapId dc <- idDetails i + , isNewTyCon (dataConTyCon dc) + = do + as <- concatMapM genArg args + case as of + [ai] -> do + let t = head (concatMap typex_expr (ctxTarget ctx)) + a' = case args of + [StgVarArg a'] -> a' + _ -> panic "genApp: unexpected arg" + if isStrictId a' || ctxIsEvaluated a' + then return (t |= ai, ExprInline) + else return (returnS (app (identFS hdEntry) [ai]), ExprCont) + _ -> panic "genApp: invalid size" + + -- no args and Id can't be a function: just enter it + | [] <- args + , idFunRepArity i == 0 + , not (mightBeFunTy (idType i)) + = do + enter_id <- genIdArg i >>= + \case + [x] -> return x + xs -> pprPanic "genApp: unexpected multi-var argument" + (vcat [ppr (length xs), ppr i]) + return (returnS (app (identFS hdEntry) [enter_id]), ExprCont) + + -- fully saturated global function: + -- - deals with arguments + -- - jumps into the function + | n <- length args + , n /= 0 + , idFunRepArity i == n + , not (isLocalId i) + , isStrictId i + = do + as' <- concatMapM genArg args + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToII i as' is + return (jmp, ExprCont) + + -- oversaturated function: + -- - push continuation with extra args + -- - deals with arguments + -- - jumps into the function + | idFunRepArity i < length args + , isStrictId i + , idFunRepArity i > 0 + = do + let (reg,over) = splitAt (idFunRepArity i) args + reg' <- concatMapM genArg reg + pc <- pushCont over + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToII i reg' is + return (pc <> jmp, ExprCont) + + -- generic apply: + -- - try to find a pre-generated apply function that matches + -- - use it if any + -- - otherwise use generic apply function h$ap_gen_fast + | otherwise + = do + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToFast args is + return (jmp, ExprCont) + +-- avoid one indirection for global ids +-- fixme in many cases we can also jump directly to the entry for local? +jumpToII :: Id -> [JStgExpr] -> JStgStat -> G JStgStat +jumpToII i vars load_app_in_r1 + | isLocalId i = do + ii <- varForId i + return $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , returnS (closureInfo ii) + ] + | otherwise = do + ei <- varForEntryId i + return $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , returnS ei + ] + +-- | Try to use a specialized pre-generated application function. +-- If there is none, use h$ap_gen_fast instead +jumpToFast :: HasDebugCallStack => [StgArg] -> JStgStat -> G JStgStat +jumpToFast args load_app_in_r1 = do + -- get JS expressions for every argument + -- Arguments may have more than one expression (e.g. Word64#) + vars <- concatMapM genArg args + -- try to find a specialized apply function + let spec = mkApplySpec RegsConv args vars + ap_fun <- selectApply spec + pure $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , case ap_fun of + -- specialized apply: no tag + Right fun -> returnS (ApplExpr fun []) + -- generic apply: pass a tag indicating number of args/slots + Left fun -> returnS (ApplExpr fun [specTagExpr spec]) + ] + +-- | Calling convention for an apply function +data ApplyConv + = RegsConv -- ^ Fast calling convention: use registers + | StackConv -- ^ Slow calling convention: use the stack + deriving (Show,Eq,Ord) + +-- | Name of the generic apply function +genericApplyName :: ApplyConv -> FastString +genericApplyName = \case + RegsConv -> identFS hdApGenFastStr + StackConv -> identFS hdApGenStr + +-- | Expr of the generic apply function +genericApplyExpr :: ApplyConv -> JStgExpr +genericApplyExpr conv = global (genericApplyName conv) + + +-- | Return the name of the specialized apply function for the given number of +-- args, number of arg variables, and calling convention. +specApplyName :: ApplySpec -> FastString +specApplyName = \case + -- specialize a few for compiler performance (avoid building FastStrings over + -- and over for common cases) + ApplySpec RegsConv 0 0 -> "h$ap_0_0_fast" + ApplySpec StackConv 0 0 -> "h$ap_0_0" + ApplySpec RegsConv 1 0 -> "h$ap_1_0_fast" + ApplySpec StackConv 1 0 -> "h$ap_1_0" + ApplySpec RegsConv 1 1 -> "h$ap_1_1_fast" + ApplySpec StackConv 1 1 -> "h$ap_1_1" + ApplySpec RegsConv 1 2 -> "h$ap_1_2_fast" + ApplySpec StackConv 1 2 -> "h$ap_1_2" + ApplySpec RegsConv 2 1 -> "h$ap_2_1_fast" + ApplySpec StackConv 2 1 -> "h$ap_2_1" + ApplySpec RegsConv 2 2 -> "h$ap_2_2_fast" + ApplySpec StackConv 2 2 -> "h$ap_2_2" + ApplySpec RegsConv 2 3 -> "h$ap_2_3_fast" + ApplySpec StackConv 2 3 -> "h$ap_2_3" + ApplySpec conv nargs nvars -> mkFastString $ mconcat + [ "h$ap_", show nargs + , "_" , show nvars + , case conv of + RegsConv -> "_fast" + StackConv -> "" + ] + +-- | Return the expression of the specialized apply function for the given +-- number of args, number of arg variables, and calling convention. +-- +-- Warning: the returned function may not be generated! Use specApplyExprMaybe +-- if you want to ensure that it exists. +specApplyExpr :: ApplySpec -> JStgExpr +specApplyExpr spec = global (specApplyName spec) + +-- | Return the expression of the specialized apply function for the given +-- number of args, number of arg variables, and calling convention. +-- Return Nothing if it isn't generated. +specApplyExprMaybe :: ApplySpec -> Maybe JStgExpr +specApplyExprMaybe spec = + if spec `elem` applySpec + then Just (specApplyExpr spec) + else Nothing + +-- | Make an ApplySpec from a calling convention, a list of Haskell args, and a +-- list of corresponding JS variables +mkApplySpec :: ApplyConv -> [StgArg] -> [JStgExpr] -> ApplySpec +mkApplySpec conv args vars = ApplySpec + { specConv = conv + , specArgs = length args + , specVars = length vars + } + +-- | Find a specialized application function if there is one +selectApply + :: ApplySpec + -> G (Either JStgExpr JStgExpr) -- ^ the function to call (Left for generic, Right for specialized) +selectApply spec = + case specApplyExprMaybe spec of + Just e -> return (Right e) + Nothing -> return (Left (genericApplyExpr (specConv spec))) + + +-- | Apply specification +data ApplySpec = ApplySpec + { specConv :: !ApplyConv -- ^ Calling convention + , specArgs :: !Int -- ^ number of Haskell arguments + , specVars :: !Int -- ^ number of JavaScript variables for the arguments + } + deriving (Show,Eq,Ord) + +-- | List of specialized apply function templates +applySpec :: [ApplySpec] +applySpec = [ ApplySpec conv nargs nvars + | conv <- [RegsConv, StackConv] + , nargs <- [0..4] + , nvars <- [max 0 (nargs-1)..(nargs*2)] + ] + +-- | Generate a tag for the given ApplySpec +-- +-- Warning: tag doesn't take into account the calling convention +specTag :: ApplySpec -> Int +specTag spec = Bits.shiftL (specVars spec) 8 Bits..|. specArgs spec + +-- | Generate a tag expression for the given ApplySpec +specTagExpr :: ApplySpec -> JStgExpr +specTagExpr = toJExpr . specTag + +-- | Build arrays to quickly lookup apply functions +-- +-- h$apply[r << 8 | n] = function application for r regs, n args +-- h$paps[r] = partial application for r registers (number of args is in the object) +mkApplyArr :: JSM JStgStat +mkApplyArr = + do mk_ap_gens <- jFor (|= zero_) (.<. Int 65536) preIncrS + \j -> hdApply .! j |= hdApGen + mk_pap_gens <- jFor (|= zero_) (.<. Int 128) preIncrS + \j -> hdPaps .! j |= hdPapGen + return $ mconcat + [ name hdApplyStr ||= toJExpr (JList []) + , name hdPapsStr ||= toJExpr (JList []) + , ApplStat (hdInitStatic .^ "push") + [ jLam' $ + mconcat + [ mk_ap_gens + , mk_pap_gens + , mconcat (map assignSpec applySpec) + , mconcat (map assignPap specPap) + ] + ] + ] + where + assignSpec :: ApplySpec -> JStgStat + assignSpec spec = case specConv spec of + -- both fast/slow (regs/stack) specialized apply functions have the same + -- tags. We store the stack ones in the array because they are used as + -- continuation stack frames. + StackConv -> hdApply .! specTagExpr spec |= specApplyExpr spec + RegsConv -> mempty + + hdPap_ = unpackFS hdPapStr_ + + assignPap :: Int -> JStgStat + assignPap p = hdPaps .! toJExpr p |= global (mkFastString (hdPap_ ++ show p)) + +-- | Push a continuation on the stack +-- +-- First push the given args, then push an apply function (specialized if +-- possible, otherwise the generic h$ap_gen function). +pushCont :: HasDebugCallStack + => [StgArg] + -> G JStgStat +pushCont args = do + vars <- concatMapM genArg args + let spec = mkApplySpec StackConv args vars + selectApply spec >>= \case + Right app -> push $ reverse $ app : vars + Left app -> push $ reverse $ app : specTagExpr spec : vars + +-- | Generic stack apply function (h$ap_gen) that can do everything, but less +-- efficiently than other more specialized functions. +-- +-- Stack layout: +-- -3: ... +-- -2: args +-- -1: tag (number of arg slots << 8 | number of args) +-- +-- Regs: +-- R1 = applied closure +-- +genericStackApply :: StgToJSConfig -> JSM JStgStat +genericStackApply cfg = closure info body + where + -- h$ap_gen body + body = jVar $ \cf -> + do fun <- fun_case cf (infoFunArity cf) + pap <- fun_case cf (papArity r1) + return $ + mconcat $ + [ traceRts cfg (jString $ identFS hdApGenStr) + , cf |= closureInfo r1 + -- switch on closure type + , SwitchStat (infoClosureType cf) + [ (toJExpr Thunk , thunk_case cfg cf) + , (toJExpr Fun , fun) + , (toJExpr Pap , pap) + , (toJExpr Blackhole, blackhole_case cfg) + ] + (default_case cf) + ] + + -- info table for h$ap_gen + info = ClosureInfo + { ciVar = hdApGenStr + , ciRegs = CIRegs 0 [PtrV] -- closure to apply to + , ciName = identFS hdApGenStr + , ciLayout = CILayoutVariable + , ciType = CIStackFrame + , ciStatic = mempty + } + + default_case cf = appS throwStr [jString "h$ap_gen: unexpected closure type " + + (infoClosureType cf)] + + thunk_case cfg cf = mconcat + [ profStat cfg pushRestoreCCS + , returnS cf + ] + + blackhole_case cfg = mconcat + [ push' cfg [r1, hdReturn] + , returnS (app hdBlockOnBlackHoleStr [r1]) + ] + + fun_case c arity = jVars \(tag, needed_args, needed_regs, given_args, given_regs, newTag, newAp, p, dat) -> + do build_pap_payload <- loop 0 (.<. given_regs) + \i -> return $ mconcat [ (dat .^ "push") `ApplStat` [stack .! (sp - i - 2)] + , postIncrS i + ] + load_reg_values <- loop 0 (.<. needed_regs) + \i -> return $ + mconcat [ traceRts cfg (jString "h$ap_gen: loading register: " + i) + , appS hdSetRegStr [ i+2 , stack .! (sp-2-i)] + , postIncrS i + ] + set_reg_values <- loop 0 (.<. given_regs) + \i -> return $ + mconcat [ appS hdSetRegStr [ i+2, stack .! (sp-2-i)] + , postIncrS i + ] + return $ + mconcat $ [ tag |= stack .! (sp - 1) -- tag on the stack + , given_args |= mask8 tag -- indicates the number of passed args + , given_regs |= tag .>>. 8 -- and the number of passed values for registers + , needed_args |= mask8 arity + , needed_regs |= arity .>>. 8 + , traceRts cfg (jString "h$ap_gen: args: " + given_args + + jString " regs: " + given_regs) + , ifBlockS (given_args .===. needed_args) + -------------------------------- + -- exactly saturated application + -------------------------------- + [ traceRts cfg (jString "h$ap_gen: exact") + -- Set registers to register values on the stack + , set_reg_values + -- drop register values from the stack + , sp |= sp - given_regs - 2 + -- enter closure in R1 + , returnS c + ] + [ ifBlockS (given_args .>. needed_args) + ---------------------------- + -- oversaturated application + ---------------------------- + [ traceRts cfg (jString "h$ap_gen: oversat: arity: " + needed_args + + jString " regs: " + needed_regs) + + -- load needed register values + , load_reg_values + + -- compute new tag with consumed register values and args removed + , newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args) + -- find application function for the remaining regs/args + , newAp |= hdApply .! newTag + , traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n")) + + -- Drop used registers from the stack. + -- Test if the application function needs a tag and push it. + , ifS (newAp .===. hdApGen ) + ((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag)) + (sp |= sp - needed_regs - 1) + + -- Push generic application function as continuation + , stack .! sp |= newAp + + -- Push "current thread CCS restore" function as continuation + , profStat cfg pushRestoreCCS + + -- enter closure in R1 + , returnS c + ] + + ----------------------------- + -- undersaturated application + ----------------------------- + [ traceRts cfg (jString "h$ap_gen: undersat") + -- find PAP entry function corresponding to given_regs count + , p |= hdPaps .! given_regs + + -- build PAP payload: R1 + tag + given register values + , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args) + , dat |= toJExpr [r1, newTag] + , build_pap_payload + + -- remove register values from the stack. + , sp |= sp - given_regs - 2 + + -- alloc PAP closure, store reference to it in R1. + , r1 |= initClosure cfg p dat jCurrentCCS + + -- return to the continuation on the stack + , returnStack + ] + ] + ] + +-- | Generic fast apply function (h$ap_gen_fast) that can do everything, but less +-- efficiently than other more specialized functions. +-- +-- Signature tag in argument. Tag: (regs << 8 | arity) +-- +-- Regs: +-- R1 = closure to apply to +-- +genericFastApply :: StgToJSConfig -> JSM JStgStat +genericFastApply s = + jFunction (name "h$ap_gen_fast") + \(MkSolo tag) -> jVar $ \c -> + do push_stk_app <- pushStackApply c tag + fast_fun <- jVar \farity -> + do fast_fun <- funCase c tag farity + return $ mconcat $ + [ farity |= infoFunArity c + , traceRts s (jString "h$ap_gen_fast: fun " + farity) + , fast_fun] + fast_pap <- jVar \parity -> + do fast_pap <- funCase c tag parity + return $ mconcat $ + [ parity |= papArity r1 + , traceRts s (jString "h$ap_gen_fast: pap " + parity) + , fast_pap + ] + return $ mconcat $ + [traceRts s (jString "h$ap_gen_fast: " + tag) + , c |= closureInfo r1 + , SwitchStat (infoClosureType c) + [ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk") + <> push_stk_app + <> returnS c) + , (toJExpr Fun, fast_fun) + , (toJExpr Pap, fast_pap) + , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con") + <> jwhenS (tag .!=. 0) + (appS throwStr [jString "h$ap_gen_fast: invalid apply"]) + <> returnS c) + , (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole") + <> push_stk_app + <> push' s [r1, hdReturn] + <> returnS (app hdBlockOnBlackHoleStr [r1])) + ] $ appS throwStr [jString "h$ap_gen_fast: unexpected closure type: " + infoClosureType c] + ] + + where + -- thunk: push everything to stack frame, enter thunk first + pushStackApply :: JStgExpr -> JStgExpr -> JSM JStgStat + pushStackApply _c tag = + jVar \ap -> + do push_all_regs <- pushAllRegs tag + return $ mconcat $ + [ push_all_regs + , ap |= hdApply .! tag + , ifS (ap .===. hdApGen) + ((sp |= sp + 2) <> (stack .! (sp-1) |= tag)) + (sp |= sp + 1) + , stack .! sp |= ap + , profStat s pushRestoreCCS + ] + + funCase :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat + funCase c tag arity = jVars $ + \(ar, myAr, myRegs, regsStart, newTag, newAp, dat, p) -> + + do get_regs <- loop 0 (.<. myRegs) $ + \i -> return $ + (dat .^ "push") `ApplStat` [app hdGetRegStr [i+2]] <> postIncrS i + push_args <- pushArgs regsStart myRegs + + return $ mconcat $ + [ ar |= mask8 arity + , myAr |= mask8 tag + , myRegs |= tag .>>. 8 + , traceRts s (jString "h$ap_gen_fast: args: " + myAr + + jString " regs: " + myRegs) + , ifS (myAr .===. ar) + -- call the function directly + (traceRts s (jString "h$ap_gen_fast: exact") <> returnS c) + (ifBlockS (myAr .>. ar) + -- push stack frame with remaining args, then call fun + [ traceRts s (jString "h$ap_gen_fast: oversat " + sp) + , regsStart |= (arity .>>. 8) + 1 + , sp |= sp + myRegs - regsStart + 1 + , traceRts s (jString "h$ap_gen_fast: oversat " + sp) + , push_args + , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar + , newAp |= hdApply .! newTag + , ifS (newAp .===. hdApGen) + ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag)) + (sp |= sp + 1) + , stack .! sp |= newAp + , profStat s pushRestoreCCS + , returnS c + ] + -- else + [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag) + , jwhenS (tag .!=. 0) $ mconcat + [ p |= hdPaps .! myRegs + , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr] + , get_regs + , r1 |= initClosure s p dat jCurrentCCS + ] + , returnStack + ]) + ] + + pushAllRegs :: JStgExpr -> JSM JStgStat + pushAllRegs tag = + jVar \regs -> + return $ mconcat $ + [ regs |= tag .>>. 8 + , sp |= sp + regs + , SwitchStat regs (map pushReg [65,64..2]) mempty + ] + where + pushReg :: Int -> (JStgExpr, JStgStat) + pushReg r = (toJExpr (r-1), stack .! (sp - toJExpr (r - 2)) |= jsReg r) + + pushArgs :: JStgExpr -> JStgExpr -> JSM JStgStat + pushArgs start end = + loop end (.>=.start) + \i -> return $ + traceRts s (jString "pushing register: " + i) + <> (stack .! (sp + start - i) |= app hdGetRegStr [i+1]) + <> postDecrS i + +-- | Make specialized apply function for the given ApplySpec +specApply :: StgToJSConfig -> ApplySpec -> JSM JStgStat +specApply cfg spec@(ApplySpec conv nargs nvars) = + let fun_name = specApplyName spec + in case conv of + RegsConv -> fastApply cfg fun_name nargs nvars + StackConv -> stackApply cfg fun_name nargs nvars + +-- | Make specialized apply function with Stack calling convention +stackApply + :: StgToJSConfig + -> FastString + -> Int + -> Int + -> JSM JStgStat +stackApply s fun_name nargs nvars = + -- special case for h$ap_0_0 + if nargs == 0 && nvars == 0 + then closure info0 body0 + else closure info body + where + info = ClosureInfo + { ciVar = name fun_name + , ciRegs = CIRegs 0 [PtrV] + , ciName = fun_name + , ciLayout = CILayoutUnknown nvars + , ciType = CIStackFrame + , ciStatic = mempty + } + info0 = ClosureInfo + { ciVar = name fun_name + , ciRegs = CIRegs 0 [PtrV] + , ciName = fun_name + , ciLayout = CILayoutFixed 0 [] + , ciType = CIStackFrame + , ciStatic = mempty + } + + body0 = (adjSpN' 1 <>) <$> enter s r1 + + body = jVar $ \c -> + do fun_case <- funCase c + pap_case <- papCase c + return $ mconcat + [ c |= closureInfo r1 + , traceRts s (toJExpr fun_name + + jString " " + + (c .^ "n") + + jString " sp: " + sp + + jString " a: " + (c .^ "a")) + , SwitchStat (infoClosureType c) + [ (toJExpr Thunk, traceRts s (toJExpr $ fun_name <> ": thunk") <> profStat s pushRestoreCCS <> returnS c) + , (toJExpr Fun, traceRts s (toJExpr $ fun_name <> ": fun") <> fun_case) + , (toJExpr Pap, traceRts s (toJExpr $ fun_name <> ": pap") <> pap_case) + , (toJExpr Blackhole, push' s [r1, hdReturn] <> returnS (app hdBlockOnBlackHoleStr [r1])) + ] (appS throwStr [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (infoClosureType c)]) + ] + + funExact c = popSkip 1 (reverse $ take nvars jsRegsFromR2) <> returnS c + stackArgs = map (\x -> stack .! (sp - toJExpr x)) [1..nvars] + + papCase :: JStgExpr -> JSM JStgStat + papCase c = jVars \(expr, arity0, arity) -> + do oversat_case <- oversatCase c arity0 arity + return $ mconcat $ + case expr of + ValExpr (JVar pap) -> [ arity0 |= papArity r1 + , arity |= mask8 arity0 + , traceRts s (toJExpr (fun_name <> ": found pap, arity: ") + arity) + , ifS (toJExpr nargs .===. arity) + --then + (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c) + -- else + (ifS (toJExpr nargs .>. arity) + (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversat_case) + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap r1 (toJExpr nargs) stackArgs + <> (sp |= sp - toJExpr (nvars + 1)) + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + + funCase :: JStgExpr -> JSM JStgStat + funCase c = jVars \(expr, ar0, ar) -> + do oversat_case <- oversatCase c ar0 ar + return $ mconcat $ + case expr of + ValExpr (JVar pap) -> [ ar0 |= infoFunArity c + , ar |= mask8 ar0 + , ifS (toJExpr nargs .===. ar) + (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c) + (ifS (toJExpr nargs .>. ar) + (traceRts s (toJExpr (fun_name <> ": oversat")) + <> oversat_case) + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap (toJExpr R1) (toJExpr nargs) stackArgs + <> (sp |= sp - toJExpr (nvars+1)) + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + + -- oversat: call the function but keep enough on the stack for the next + oversatCase :: JStgExpr -- function + -> JStgExpr -- the arity tag + -> JStgExpr -- real arity (arity & 0xff) + -> JSM JStgStat + oversatCase c arity arity0 = + jVars \(rs, newAp) -> + return $ mconcat $ + [ rs |= (arity .>>. 8) + , loadRegs rs + , sp |= sp - rs + , newAp |= (hdApply .! ((toJExpr nargs-arity0).|.((toJExpr nvars-rs).<<.8))) + , stack .! sp |= newAp + , profStat s pushRestoreCCS + , traceRts s (toJExpr (fun_name <> ": new stack frame: ") + (newAp .^ "n")) + , returnS c + ] + where + loadRegs rs = SwitchStat rs switchAlts mempty + where + switchAlts = map (\x -> (toJExpr x, jsReg (x+1) |= stack .! (sp - toJExpr x))) [nvars,nvars-1..1] + +-- | Make specialized apply function with Regs calling convention +-- +-- h$ap_n_r_fast is entered if a function of unknown arity is called, n +-- arguments are already in r registers +fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat +fastApply s fun_name nargs nvars = if nargs == 0 && nvars == 0 + -- special case for h$ap_0_0_fast + then jFunction' func ap_fast + -- general case + else jFunction' func body + where + func = name fun_name + ap_fast :: JSM JStgStat + ap_fast = enter s r1 + + regArgs = take nvars jsRegsFromR2 + + mkAp :: Int -> Int -> [JStgExpr] + mkAp n' r' = [ specApplyExpr (ApplySpec StackConv n' r') ] + + body = jVars $ \(c, farity, arity) -> + do fun_case_fun <- funCase c farity + fun_case_pap <- funCase c arity + return $ mconcat $ + [ c |= closureInfo r1 + , traceRts s (toJExpr (fun_name <> ": sp ") + sp) + , SwitchStat (infoClosureType c) + [(toJExpr Fun, traceRts s (toJExpr (fun_name <> ": ") + + clName c + + jString " (arity: " + (c .^ "a") + jString ")") + <> (farity |= infoFunArity c) + <> fun_case_fun) + ,(toJExpr Pap, traceRts s (toJExpr (fun_name <> ": pap")) <> (arity |= papArity r1) <> fun_case_pap) + ,(toJExpr Thunk, traceRts s (toJExpr (fun_name <> ": thunk")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> profStat s pushRestoreCCS <> returnS c) + ,(toJExpr Blackhole, traceRts s (toJExpr (fun_name <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> push' s [r1, global "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))] + (appS throwStr [toJExpr (fun_name <> ": unexpected closure type: ") + infoClosureType c]) + ] + + funCase :: JStgExpr -> JStgExpr -> JSM JStgStat + funCase c arity = jVars \(arg, ar) -> + do oversat_case <- oversatCase c arity + return $ mconcat $ + case arg of + ValExpr (JVar pap) -> [ ar |= mask8 arity + , ifS (toJExpr nargs .===. ar) + -- then + (traceRts s (toJExpr (fun_name <> ": exact")) <> returnS c) + -- else + (ifS (toJExpr nargs .>. ar) + --then + (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversat_case) + -- else + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap r1 (toJExpr nargs) regArgs + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + oversatCase :: JStgExpr -> JStgExpr -> JSM JStgStat + oversatCase c arity = + jVars \(rs, rsRemain) -> + return $ mconcat $ + [ rs |= arity .>>. 8 + , rsRemain |= toJExpr nvars - rs + , traceRts s (toJExpr + (fun_name <> " regs oversat ") + + rs + + jString " remain: " + + rsRemain) + , saveRegs rs + , sp |= sp + rsRemain + 1 + , stack .! sp |= hdApply .! ((rsRemain.<<.8).|. (toJExpr nargs - mask8 arity)) + , profStat s pushRestoreCCS + , returnS c + ] + where + saveRegs n = SwitchStat n switchAlts mempty + where + switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (nvars-x)) |= jsReg (x+2))) [0..nvars-1] + +zeroApply :: StgToJSConfig -> JSM JStgStat +zeroApply s = jFunction hdEntry + $ \(MkSolo c) -> fmap ((r1 |= c) <>) $ enter s c + +-- carefully enter a closure that might be a thunk or a function + +-- ex may be a local var, but must've been copied to R1 before calling this +enter :: StgToJSConfig -> JStgExpr -> JSM JStgStat +enter s ex = jVar \c -> + return $ mconcat $ + [ jwhenS (app typeof [ex] .!==. jTyObject) returnStack + , c |= closureInfo ex + , jwhenS (c .===. hdUnboxEntry) ((r1 |= closureField1 ex) <> returnStack) + , SwitchStat (infoClosureType c) + [ (toJExpr Con, mempty) + , (toJExpr Fun, mempty) + , (toJExpr Pap, returnStack) + , (toJExpr Blackhole, push' s [hdAp00, ex, hdReturn] + <> returnS (app hdBlockOnBlackHoleStr [ex])) + ] (returnS c) + ] + +updates :: StgToJSConfig -> JSM JStgStat +updates s = do + upd_frm <- update_frame + upd_frm_lne <- update_frame_lne + return $ BlockStat [upd_frm, upd_frm_lne] + where + unbox_closure f1 = Closure { clInfo = hdUnboxEntry -- global "h$unbox_e" + , clField1 = f1 + , clField2 = null_ + , clMeta = 0 + , clCC = Nothing + } + upd_loop' ss' si' sir' = loop zero_ (.<. ss' .^ "length") + $ \i -> return $ mconcat + [ si' |= ss' .! i + , sir' |= (closureField2 si') `ApplExpr` [r1] + , ifS (app "typeof" [sir'] .===. jTyObject) + (copyClosure DontCopyCC si' sir') + (assignClosure si' $ unbox_closure sir') + , postIncrS i + ] + update_frame = closure + (ClosureInfo + { ciVar = hdUpdFrameStr + , ciRegs = CIRegs 0 [PtrV] + , ciName = identFS hdUpdFrameStr + , ciLayout = CILayoutFixed 1 [PtrV] + , ciType = CIStackFrame + , ciStatic = mempty + }) + $ jVars \(updatee, waiters, ss, si, sir) -> + do upd_loop <- upd_loop' ss si sir + wake_thread_loop <- loop zero_ (.<. waiters .^ "length") + \i -> return $ + appS hdWakeupThread [waiters .! i] + <> postIncrS i + let updateCC updatee = closureCC updatee |= jCurrentCCS + + return $ mconcat $ + [ updatee |= stack .! (sp - 1) + , traceRts s (jString "h$upd_frame updatee alloc: " + updatee .^ "alloc") + , -- wake up threads blocked on blackhole + waiters |= closureField2 updatee + , jwhenS (waiters .!==. null_) wake_thread_loop + , -- update selectors + jwhenS ((app typeof [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel")) + ((ss |= closureMeta updatee .^ "sel") + <> upd_loop) + , -- overwrite the object + ifS (app typeof [r1] .===. jTyObject) + (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureInfo r1) .^ "n")) + , copyClosure DontCopyCC updatee r1 + ]) + -- the heap object is represented by another type of value + -- (e.g. a JS number or string) so the unboxing closure + -- will simply return it. + (assignClosure updatee (unbox_closure r1)) + , profStat s (updateCC updatee) + , adjSpN' 2 + , traceRts s (jString "h$upd_frame: updating: " + + updatee + + jString " -> " + + r1) + , returnStack + ] + + update_frame_lne = closure + (ClosureInfo + { ciVar = name $ fsLit "h$upd_frame_lne" + , ciRegs = CIRegs 0 [PtrV] + , ciName = "h$upd_frame_lne" + , ciLayout = CILayoutFixed 1 [PtrV] + , ciType = CIStackFrame + , ciStatic = mempty + }) + $ jVar \updateePos -> + return $ mconcat $ + [ updateePos |= stack .! (sp - 1) + , stack .! updateePos |= r1 + , adjSpN' 2 + , traceRts s (jString "h$upd_frame_lne: updating: " + + updateePos + + jString " -> " + + r1) + , returnStack + ] + +selectors :: StgToJSConfig -> JSM JStgStat +selectors s = + do + sel_one <- mkSel "1" closureField1 + sel_twoA <- mkSel "2a" closureField2 + sel_twoB <- mkSel "2b" (closureField1 . closureField2) + rest <- mconcat <$> mapM mkSelN [3..16] + return $ + sel_one <> sel_twoA <> sel_twoB <> rest + where + mkSelN :: Int -> JSM JStgStat + mkSelN x = mkSel (mkFastString $ show x) + (\e -> SelExpr (closureField2 (toJExpr e)) + (name $ mkFastString ("d" ++ show (x-1)))) + + + mkSel :: FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat + mkSel name_ sel = mconcat <$> sequence + [jFunction (name createName) $ + \(MkSolo r) -> return $ mconcat + [ traceRts s (toJExpr ("selector create: " <> name_ <> " for ") + (r .^ "alloc")) + , ifS (isThunk r .||. isBlackhole r) + (returnS (app "h$mkSelThunk" [r, toJExpr (v entryName), toJExpr (v resName)])) + (returnS (sel r)) + ] + , jFunction (name resName) $ + \(MkSolo r) -> return $ mconcat + [ traceRts s (toJExpr ("selector result: " <> name_ <> " for ") + (r .^ "alloc")) + , returnS (sel r) + ] + , closure + (ClosureInfo + { ciVar = name entryName + , ciRegs = CIRegs 0 [PtrV] + , ciName = "select " <> name_ + , ciLayout = CILayoutFixed 1 [PtrV] + , ciType = CIThunk + , ciStatic = mempty + }) + (jVar $ \tgt -> + return $ mconcat $ + [ tgt |= closureField1 r1 + , traceRts s (toJExpr ("selector entry: " <> name_ <> " for ") + (tgt .^ "alloc")) + , ifS (isThunk tgt .||. isBlackhole tgt) + (preIncrS sp + <> (stack .! sp |= global frameName) + <> returnS (app "h$e" [tgt])) + (returnS (app "h$e" [sel tgt])) + ]) + , closure + (ClosureInfo + { ciVar = name frameName + , ciRegs = CIRegs 0 [PtrV] + , ciName = "select " <> name_ <> " frame" + , ciLayout = CILayoutFixed 0 [] + , ciType = CIStackFrame + , ciStatic = mempty + }) + $ return $ + mconcat [ traceRts s (toJExpr ("selector frame: " <> name_)) + , postDecrS sp + , returnS (app "h$e" [sel r1]) + ] + ] + + where + v x = JVar (name x) + n ext = "h$c_sel_" <> name_ <> ext + createName = n "" + resName = n "_res" + entryName = n "_e" + frameName = n "_frame_e" + + +-- arity is the remaining arity after our supplied arguments are applied +mkPap :: StgToJSConfig + -> Ident -- ^ id of the pap object + -> JStgExpr -- ^ the function that's called (can be a second pap) + -> JStgExpr -- ^ number of arguments in pap + -> [JStgExpr] -- ^ values for the supplied arguments + -> JStgStat +mkPap s tgt fun n values = + traceRts s (toJExpr $ "making pap with: " ++ show (length values) ++ " items") + `mappend` + allocDynamic s True tgt (toJExpr entry) (fun:papAr:map toJExpr values') + (if csProf s then Just jCurrentCCS else Nothing) + where + papAr = funOrPapArity fun Nothing - toJExpr (length values * 256) - n + + values' | GHC.Prelude.null values = [null_] + | otherwise = values + entry | length values > numSpecPap = name "h$pap_gen" + | otherwise = specPapIdents ! length values + +-- | Number of specialized PAPs (pre-generated for a given number of args) +numSpecPap :: Int +numSpecPap = 6 + +-- specialized (faster) pap generated for [0..numSpecPap] +-- others use h$pap_gen +specPap :: [Int] +specPap = [0..numSpecPap] + +-- | Cache of specialized PAP idents +specPapIdents :: Array Int Ident +specPapIdents = listArray (0,numSpecPap) $ map (name . mkFastString . ("h$pap_"++) . show) specPap + +pap :: StgToJSConfig + -> Int + -> JSM JStgStat +pap s r = closure (ClosureInfo + { ciVar = funcIdent + , ciRegs = CIRegsUnknown + , ciName = funcName + , ciLayout = CILayoutUnknown (r+2) + , ciType = CIPap + , ciStatic = mempty + }) body + where + funcIdent = name funcName + funcName = mkFastString ("h$pap_" ++ show r) + + body = jVars $ \(c, d, f, extra) -> + return $ mconcat $ + [ c |= closureField1 r1 + , d |= closureField2 r1 + , f |= closureInfo c + , assertRts s (isFun' f .||. isPap' f) (funcName <> ": expected function or pap") + , profStat s (enterCostCentreFun currentCCS) + , extra |= (funOrPapArity c (Just f) .>>. 8) - toJExpr r + , traceRts s (toJExpr (funcName <> ": pap extra args moving: ") + extra) + , moveBy extra + , loadOwnArgs d + , r1 |= c + , returnS f + ] + moveBy extra = SwitchStat extra + (reverse $ map moveCase [1..maxReg-r-1]) mempty + moveCase m = (toJExpr m, jsReg (m+r+1) |= jsReg (m+1)) + loadOwnArgs d = mconcat $ map (\r -> + jsReg (r+1) |= dField d (r+2)) [1..r] + dField d n = SelExpr d (name . mkFastString $ ('d':show (n-1))) + +-- Construct a generic PAP +papGen :: StgToJSConfig -> JSM JStgStat +papGen cfg = + closure (ClosureInfo + { ciVar = funcIdent + , ciRegs = CIRegsUnknown + , ciName = funcName + , ciLayout = CILayoutVariable + , ciType = CIPap + , ciStatic = mempty + }) + (jVars $ \(c, f, d, pr, or, r) -> + return $ mconcat + [ c |= closureField1 r1 + , d |= closureField2 r1 + , f |= closureInfo c + , pr |= funOrPapArity c (Just f) .>>. 8 + , or |= papArity r1 .>>. 8 + , r |= pr - or + , assertRts cfg + (isFun' f .||. isPap' f) + (jString "h$pap_gen: expected function or pap") + , profStat cfg (enterCostCentreFun currentCCS) + , traceRts cfg (jString "h$pap_gen: generic pap extra args moving: " + or) + , appS hdMoveRegs2 [or, r] + , loadOwnArgs d r + , r1 |= c + , returnS f + ]) + + + where + funcIdent = name funcName + funcName = hdPapGenStr + loadOwnArgs d r = + let prop n = d .^ ("d" <> mkFastString (show $ n+1)) + loadOwnArg n = (toJExpr n, jsReg (n+1) |= prop n) + in SwitchStat r (map loadOwnArg [127,126..1]) mempty + +-- general utilities +-- move the first n registers, starting at R2, m places up (do not use with negative m) +moveRegs2 :: JSM JStgStat +moveRegs2 = jFunction (name hdMoveRegs2) moveSwitch + where + moveSwitch (n,m) = defaultCase n m >>= return . SwitchStat ((n .<<. 8) .|. m) switchCases + -- fast cases + switchCases = [switchCase n m | n <- [1..5], m <- [1..4]] + switchCase :: Int -> Int -> (JStgExpr, JStgStat) + switchCase n m = (toJExpr $ + (n `Bits.shiftL` 8) Bits..|. m + , mconcat (map (`moveRegFast` m) [n+1,n..2]) + <> BreakStat Nothing {-[j| break; |]-}) + moveRegFast n m = jsReg (n+m) |= jsReg n + -- fallback + defaultCase n m = + loop n (.>.0) (\i -> return $ + appS hdSetRegStr [i+1+m, app hdGetRegStr [i+1]] + <> postDecrS i) + + +-- Initalize a variable sized object from an array of values +initClosure :: StgToJSConfig -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr +initClosure cfg info values ccs = app hdInitClosure + [ newClosure $ Closure + { clInfo = info + , clField1 = null_ + , clField2 = null_ + , clMeta = 0 + , clCC = if csProf cfg then Just ccs else Nothing + } + , values + ] + +-- | Return an expression for every field of the given Id +getIdFields :: Id -> G [TypedExpr] +getIdFields i = assocIdExprs i <$> varsForId i + +-- | Store fields of Id into the given target expressions +storeIdFields :: Id -> [TypedExpr] -> G JStgStat +storeIdFields i dst = do + fields <- getIdFields i + pure (assignCoerce1 dst fields) diff --git a/GHC/StgToJS/Arg.hs b/GHC/StgToJS/Arg.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Arg.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Args +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- Code generation of application arguments +----------------------------------------------------------------------------- + +module GHC.StgToJS.Arg + ( genArg + , genIdArg + , genIdArgI + , genIdStackArgI + , allocConStatic + , jsStaticArgs + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.Ident +import GHC.JS.Make + +import GHC.StgToJS.DataCon +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Literal +import GHC.StgToJS.Utils +import GHC.StgToJS.Profiling +import GHC.StgToJS.Ids + +import GHC.Builtin.Types +import GHC.Stg.Syntax +import GHC.Core.DataCon + +import GHC.Types.CostCentre +import GHC.Types.Unique.FM +import GHC.Types.Id + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Control.Monad.Trans.State.Strict as State + +{- +Note [ Unboxable Literals Optimization ] +~~~~~~~~~~~~~~~~~~ + +Boxable types in the JS backend are represented as heap objects. See Note +[StgToJS design] in GHC.StgToJS.hs for more details. Some types, such as Int8 +do not benefit from not being wrapped in an object in the JS runtime. This optimization +detects such types and changes the code generator to generate a more efficient +representation. The change is minor and saves one level on indirection. Instead +of generating a wrapper object with a field for the value's payload, such as: + +// a JS object for an Int8 +var anInt8 = { d1 = + , f : info table / entry function which would scrutinize the payload + } + +we instead generate: + +// notice, no wrapper object. This representation is essentially an Int8# in the JS backend +var anInt8 = + +This optimization fires when the follow invariants hold: + 1. The value in question has a Type which has a single data constructor + 2. The data constructor holds a single field that is monomorphic + 3. The value in question is distinguishable from a THUNK using the JavaScript typeof operator. + +From the haskell perspective this means that: + 1. An Int8# is always a JavaScript 'number', never a JavaScript object. + 2. An Int8 is either a JavaScript 'number' _or_ a JavaScript object depending on + its use case and this optimization. + +How is this sound? +~~~~~~~~~~~~~~~~~~ + +Normally this optimization would violate the guarantees of call-by-need, however +we are able to statically detect whether the type in question will be a THUNK or +not during code gen because the JS backend is consuming STG and we can check +during runtime with the typeof operator. Similarly we can check at runtime using +JavaScript's introspection operator `typeof`. Thus, when we know the value in +question will not be a THUNK we can safely elide the wrapping object, which +unboxes the value in the JS runtime. For example, an Int8 contains an Int8# +which has the JavaScript type 'number'. A THUNK of type Int8 would have a +JavaScript type 'object', so using 'typeof' allows us to check if we have +something that is definitely evaluated (i.e., a 'number') or something else. If +it is an 'object' then we may need to enter it to begin its evaluation. Consider +a type which has a 'ThreadId#' field; such as type would not be subject to this +optimization because it has to be represented as a JavaScript 'object' and thus +cannot be unboxed in this way. Another (edge) case is Int64#. Int64# is +similarly not unboxable in this way because Int64# does not fit in one +JavaScript variable and thus requires an 'object' for its representation in the +JavaScript runtime. + +-} + +-- | Generate JS code for static arguments +genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg] +genStaticArg a = case a of + StgLitArg l -> map StaticLitArg <$> genStaticLit l + StgVarArg i -> do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Nothing -> reg + Just expr -> unfloated expr + where + r = primOrVoidRepToJSRep $ stgArgRep1 a + reg + | isVoid r = + return [] + | i == trueDataConId = + return [StaticLitArg (BoolLit True)] + | i == falseDataConId = + return [StaticLitArg (BoolLit False)] + | isMultiVar r = + map (\(identFS -> t) -> StaticObjArg t) <$> mapM (identForIdN i) [1..varSize r] -- this seems wrong, not an obj? + | otherwise = (\(identFS -> it) -> [StaticObjArg it]) <$> identForId i + + unfloated :: CgStgExpr -> G [StaticArg] + unfloated (StgLit l) = map StaticLitArg <$> genStaticLit l + unfloated (StgConApp dc _n args _) + | isBoolDataCon dc || isUnboxableCon dc = + (:[]) . allocUnboxedConStatic dc . concat <$> mapM genStaticArg args -- fixme what is allocunboxedcon? + | null args = (\(identFS -> t) -> [StaticObjArg t]) <$> identForId (dataConWorkId dc) + | otherwise = do + as <- concat <$> mapM genStaticArg args + e <- identFS <$> identForDataConWorker dc + return [StaticConArg e as] + unfloated x = pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x) + +-- | Generate JS code for an StgArg +genArg :: HasDebugCallStack => StgArg -> G [JStgExpr] +genArg a = case a of + StgLitArg l -> genLit l + StgVarArg i -> do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Just expr -> unfloated expr + Nothing + | isVoid r -> return [] + | i == trueDataConId -> return [true_] + | i == falseDataConId -> return [false_] + | isMultiVar r -> mapM (varForIdN i) [1..varSize r] + | otherwise -> (:[]) <$> varForId i + + where + -- if our argument is a joinid, it can be an unboxed tuple + r :: HasDebugCallStack => JSRep + r = primOrVoidRepToJSRep $ stgArgRep1 a + + unfloated :: HasDebugCallStack => CgStgExpr -> G [JStgExpr] + unfloated = \case + StgLit l -> genLit l + StgConApp dc _n args _ + | isBoolDataCon dc || isUnboxableCon dc + -> (:[]) . allocUnboxedCon dc . concat <$> mapM genArg args + | null args -> (:[]) <$> varForId (dataConWorkId dc) + | otherwise -> do + as <- concat <$> mapM genArg args + e <- varForDataConWorker dc + inl_alloc <- csInlineAlloc <$> getSettings + return [allocDynamicE inl_alloc e as Nothing] + x -> pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x) + +-- | Generate a Var as JStgExpr +genIdArg :: HasDebugCallStack => Id -> G [JStgExpr] +genIdArg i = genArg (StgVarArg i) + +-- | Generate an Id as an Ident +genIdArgI :: HasDebugCallStack => Id -> G [Ident] +genIdArgI i + | isVoid r = return [] + | isMultiVar r = mapM (identForIdN i) [1..varSize r] + | otherwise = (:[]) <$> identForId i + where + r = unaryTypeJSRep . idType $ i + +-- | Generate IDs for stack arguments. See 'StgToJS.Expr.loadRetArgs' for use case +genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident,StackSlot)] +genIdStackArgI i = zipWith f [1..] <$> genIdArgI i + where + f :: Int -> Ident -> (Ident,StackSlot) + f n ident = (ident, SlotId i n) + +-- | Allocate Static Constructors +allocConStatic :: HasDebugCallStack => Ident -> CostCentreStack -> DataCon -> [StgArg] -> G () +allocConStatic (identFS -> to) cc con args = do + as <- mapM genStaticArg args + cc' <- costCentreStackLbl cc + allocConStatic' cc' (concat as) + where + -- see Note [ Unboxable Literals Optimization ] for the purpose of these + -- checks + allocConStatic' :: HasDebugCallStack => Maybe Ident -> [StaticArg] -> G () + allocConStatic' cc' [] + | isBoolDataCon con && dataConTag con == 1 = + emitStatic to (StaticUnboxed $ StaticUnboxedBool False) cc' + | isBoolDataCon con && dataConTag con == 2 = + emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc' + | otherwise = do + e <- identFS <$> identForDataConWorker con + emitStatic to (StaticApp SAKData e []) cc' + allocConStatic' cc' [x] + | isUnboxableCon con = + case x of + StaticLitArg (IntLit i) -> + emitStatic to (StaticUnboxed $ StaticUnboxedInt i) cc' + StaticLitArg (BoolLit b) -> + emitStatic to (StaticUnboxed $ StaticUnboxedBool b) cc' + StaticLitArg (DoubleLit d) -> + emitStatic to (StaticUnboxed $ StaticUnboxedDouble d) cc' + _ -> + pprPanic "allocConStatic: invalid unboxed literal" (ppr x) + allocConStatic' cc' xs = + if con == consDataCon + then case args of + (a0:a1:_) -> flip (emitStatic to) cc' =<< allocateStaticList [a0] a1 + _ -> panic "allocConStatic: invalid args for consDataCon" + else do + e <- identFS <$> identForDataConWorker con + emitStatic to (StaticApp SAKData e xs) cc' + +-- | Allocate unboxed constructors +allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg +allocUnboxedConStatic con = \case + [] + | isBoolDataCon con && dataConTag con == 1 + -> StaticLitArg (BoolLit False) + | isBoolDataCon con && dataConTag con == 2 + -> StaticLitArg (BoolLit True) + [a@(StaticLitArg (IntLit _i))] -> a + [a@(StaticLitArg (DoubleLit _d))] -> a + _ -> pprPanic "allocUnboxedConStatic: not an unboxed constructor" (ppr con) + + +-- | Allocate Static list +allocateStaticList :: [StgArg] -> StgArg -> G StaticVal +allocateStaticList xs a@(StgVarArg i) + | isDataConId_maybe i == Just nilDataCon = listAlloc xs Nothing + | otherwise = do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Just (StgConApp dc _n [h,t] _) + | dc == consDataCon -> allocateStaticList (h:xs) t + _ -> listAlloc xs (Just a) + where + listAlloc :: [StgArg] -> Maybe StgArg -> G StaticVal + listAlloc xs Nothing = do + as <- concat . reverse <$> mapM genStaticArg xs + return (StaticList as Nothing) + listAlloc xs (Just r) = do + as <- concat . reverse <$> mapM genStaticArg xs + r' <- genStaticArg r + case r' of + [StaticObjArg ri] -> return (StaticList as (Just ri)) + _ -> + pprPanic "allocateStaticList: invalid argument (tail)" (ppr (xs, r)) +allocateStaticList _ _ = panic "allocateStaticList: unexpected literal in list" + +-- | Generate JS code corresponding to a static arg +jsStaticArg :: StaticArg -> JStgExpr +jsStaticArg = \case + StaticLitArg l -> toJExpr l + StaticObjArg t -> global t + StaticConArg c args -> + allocDynamicE False (global c) (map jsStaticArg args) Nothing + +-- | Generate JS code corresponding to a list of static args +jsStaticArgs :: [StaticArg] -> JStgExpr +jsStaticArgs = ValExpr . JList . map jsStaticArg + diff --git a/GHC/StgToJS/Closure.hs b/GHC/StgToJS/Closure.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Closure.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module GHC.StgToJS.Closure + ( closureInfoStat + , closure + , conClosure + , Closure (..) + , newClosure + , assignClosure + , CopyCC (..) + , copyClosure + , mkClosure + -- $names + , allocData + , allocClsA + , dataName + , clsName + , dataFieldName + , varName + , jsClosureCount + ) +where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.StgToJS.Heap +import GHC.StgToJS.Types +import GHC.StgToJS.Utils + +import GHC.JS.Make +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import GHC.JS.Ident + +import GHC.Types.Unique.Map + +import Data.Array +import Data.Monoid +import qualified Data.Bits as Bits + +-- | Generate statements to set infotable field values for the given ClosureInfo +-- +-- Depending on debug flag, it generates h$setObjInfo(...) or h$o(...). The +-- latter form doesn't store the pretty-printed name in the closure to save +-- space. +closureInfoStat :: Bool -> ClosureInfo -> JStgStat +closureInfoStat debug ci + = setObjInfoL debug (ciVar ci) (ciRegs ci) (ciLayout ci) ty (ciName ci) tag (ciStatic ci) + where + !ty = case ciType ci of + CIThunk -> Thunk + CIFun {} -> Fun + CICon {} -> Con + CIBlackhole -> Blackhole + CIPap -> Pap + CIStackFrame -> StackFrame + !tag = case ciType ci of + CIThunk -> 0 + CIFun arity nregs -> mkArityTag arity nregs + CICon con -> con + CIBlackhole -> 0 + CIPap -> 0 + CIStackFrame -> 0 + + +setObjInfoL :: Bool -- ^ debug: output symbol names + -> Ident -- ^ the object name + -> CIRegs -- ^ things in registers + -> CILayout -- ^ layout of the object + -> ClosureType -- ^ closure type + -> FastString -- ^ object name, for printing + -> Int -- ^ `a' argument, depends on type (arity, conid) + -> CIStatic -- ^ static refs + -> JStgStat +setObjInfoL debug obj rs layout t n a + = setObjInfo debug obj t n field_types a size rs + where + size = case layout of + CILayoutVariable -> (-1) + CILayoutUnknown sz -> sz + CILayoutFixed sz _ -> sz + field_types = case layout of + CILayoutVariable -> [] + CILayoutUnknown size -> to_type_list (replicate size ObjV) + CILayoutFixed _ fs -> to_type_list fs + to_type_list = concatMap (\x -> replicate (varSize x) (fromEnum x)) + +setObjInfo :: Bool -- ^ debug: output all symbol names + -> Ident -- ^ the thing to modify + -> ClosureType -- ^ closure type + -> FastString -- ^ object name, for printing + -> [Int] -- ^ list of item types in the object, if known (free variables, datacon fields) + -> Int -- ^ extra 'a' parameter, for constructor tag or arity + -> Int -- ^ object size, -1 (number of vars) for unknown + -> CIRegs -- ^ things in registers + -> CIStatic -- ^ static refs + -> JStgStat +setObjInfo debug obj t name fields a size regs static + | debug = appS "h$setObjInfo" [ toJExpr obj + , toJExpr t + , toJExpr name + , toJExpr fields + , toJExpr a + , toJExpr size + , toJExpr (regTag regs) + , toJExpr static + ] + | otherwise = appS "h$o" [ toJExpr obj + , toJExpr t + , toJExpr a + , toJExpr size + , toJExpr (regTag regs) + , toJExpr static + ] + where + regTag CIRegsUnknown = -1 + regTag (CIRegs skip types) = + let nregs = sum $ fmap varSize types + in skip + (nregs `Bits.shiftL` 8) + +-- | Special case of closures that do not need to generate any @fresh@ names +closure :: ClosureInfo -- ^ object being info'd see @ciVar@ + -> JSM JStgStat -- ^ rhs + -> JSM JStgStat +closure ci body = do + f <- jFunction' (ciVar ci) body + return $ f `mappend` closureInfoStat False ci + +conClosure :: Ident -> FastString -> CILayout -> Int -> JSM JStgStat +conClosure symbol name layout constr = closure ci body + where + ci = ClosureInfo + { ciVar = symbol + , ciRegs = CIRegs 0 [PtrV] + , ciName = name + , ciLayout = layout + , ciType = CICon constr + , ciStatic = mempty + } + body = pure returnStack + +-- | Used to pass arguments to newClosure with some safety +data Closure = Closure + { clInfo :: JStgExpr -- ^ InfoTable object + , clField1 :: JStgExpr -- ^ Payload field 1 + , clField2 :: JStgExpr -- ^ Payload field 2 + , clMeta :: JStgExpr + , clCC :: Maybe JStgExpr + } + +newClosure :: Closure -> JStgExpr +newClosure Closure{..} = + let xs = [ (closureInfo_ , clInfo) + , (closureField1_, clField1) + , (closureField2_, clField2) + , (closureMeta_ , clMeta) + ] + in case clCC of + -- CC field is optional (probably to minimize code size as we could assign + -- null_, but we get the same effect implicitly) + Nothing -> ValExpr (jhFromList xs) + Just cc -> ValExpr (jhFromList $ (closureCC_,cc) : xs) + +assignClosure :: JStgExpr -> Closure -> JStgStat +assignClosure t Closure{..} = BlockStat + [ closureInfo t |= clInfo + , closureField1 t |= clField1 + , closureField2 t |= clField2 + , closureMeta t |= clMeta + ] <> case clCC of + Nothing -> mempty + Just cc -> closureCC t |= cc + +data CopyCC = CopyCC | DontCopyCC + +copyClosure :: CopyCC -> JStgExpr -> JStgExpr -> JStgStat +copyClosure copy_cc t s = BlockStat + [ closureInfo t |= closureInfo s + , closureField1 t |= closureField1 s + , closureField2 t |= closureField2 s + , closureMeta t |= closureMeta s + ] <> case copy_cc of + DontCopyCC -> mempty + CopyCC -> closureCC t |= closureCC s + +mkClosure :: JStgExpr -> [JStgExpr] -> JStgExpr -> Maybe JStgExpr -> Closure +mkClosure info fields meta cc = Closure + { clInfo = info + , clField1 = x1 + , clField2 = x2 + , clMeta = meta + , clCC = cc + } + where + x1 = case fields of + [] -> null_ + x:_ -> x + x2 = case fields of + [] -> null_ + [_] -> null_ + [_,x] -> x + _:x:xs -> ValExpr . JHash . listToUniqMap $ zip (fmap dataFieldName [1..]) (x:xs) + + +------------------------------------------------------------------------------- +-- Name Caches +------------------------------------------------------------------------------- +-- $names + +-- | Cache "dXXX" field names +dataFieldCache :: Array Int FastString +dataFieldCache = listArray (0,nFieldCache) (fmap (mkFastString . ('d':) . show) [(0::Int)..nFieldCache]) + +-- | Data names are used in the AST, and logging has determined that 255 is the maximum number we see. +nFieldCache :: Int +nFieldCache = 255 + +-- | We use this in the RTS to determine the number of generated closures. These closures use the names +-- cached here, so we bind them to the same number. +jsClosureCount :: Int +jsClosureCount = 24 + +dataFieldName :: Int -> FastString +dataFieldName i + | i < 0 || i > nFieldCache = mkFastString ('d' : show i) + | otherwise = dataFieldCache ! i + +-- | Cache "h$dXXX" names +dataCache :: Array Int FastString +dataCache = listArray (0,jsClosureCount) (fmap (mkFastString . ("h$d"++) . show) [(0::Int)..jsClosureCount]) + +dataName :: Int -> FastString +dataName i + | i < 0 || i > nFieldCache = mkFastString ("h$d" ++ show i) + | otherwise = dataCache ! i + +allocData :: Int -> JStgExpr +allocData i = toJExpr (global (dataName i)) + +-- | Cache "h$cXXX" names +clsCache :: Array Int FastString +clsCache = listArray (0,jsClosureCount) (fmap (mkFastString . ("h$c"++) . show) [(0::Int)..jsClosureCount]) + +clsName :: Int -> FastString +clsName i + | i < 0 || i > jsClosureCount = mkFastString ("h$c" ++ show i) + | otherwise = clsCache ! i + +allocClsA :: Int -> JStgExpr +allocClsA i = toJExpr (global (clsName i)) + +-- | Cache "xXXX" names +varCache :: Array Int Ident +varCache = listArray (0,jsClosureCount) (fmap (name . mkFastString . ('x':) . show) [(0::Int)..jsClosureCount]) + +varName :: Int -> Ident +varName i + | i < 0 || i > jsClosureCount = name $ mkFastString ('x' : show i) + | otherwise = varCache ! i + diff --git a/GHC/StgToJS/CodeGen.hs b/GHC/StgToJS/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/CodeGen.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +-- | JavaScript code generator +module GHC.StgToJS.CodeGen + ( stgToJS + ) +where + +import GHC.Prelude + +import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js, Opt_D_dump_stg_from_js_sinker)) + +import GHC.JS.Ppr +import GHC.JS.JStg.Syntax +import GHC.JS.Ident +import GHC.JS.Make +import GHC.JS.Transform +import GHC.JS.Optimizer + +import GHC.StgToJS.Arg +import GHC.StgToJS.Sinker.Sinker +import GHC.StgToJS.Types +import qualified GHC.StgToJS.Object as Object +import GHC.StgToJS.Utils +import GHC.StgToJS.Deps +import GHC.StgToJS.Expr +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Monad +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.StaticPtr +import GHC.StgToJS.Symbols +import GHC.StgToJS.Stack +import GHC.StgToJS.Ids + +import GHC.Stg.Syntax +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep (scaledThing) + +import GHC.Unit.Module +import GHC.Linker.Types (SptEntry (..)) + +import GHC.Types.CostCentre +import GHC.Types.ForeignStubs (ForeignStubs (..), getCHeader, getCStub) +import GHC.Types.RepType +import GHC.Types.Id +import GHC.Types.Unique +import GHC.Types.Unique.FM (nonDetEltsUFM) + +import GHC.Data.FastString +import GHC.Utils.Encoding +import GHC.Utils.Logger +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Binary +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Utils.Outputable hiding ((<>)) + +import qualified Data.Set as S +import Data.Monoid +import Data.List (sortBy) +import Control.Monad +import System.Directory +import System.FilePath + +-- | Code generator for JavaScript +stgToJS + :: Logger + -> StgToJSConfig + -> [CgStgTopBinding] + -> Module + -> [SptEntry] + -> ForeignStubs + -> CollectedCCs + -> FilePath -- ^ Output file name + -> IO () +stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_fn = do + + let (unfloated_binds, stg_binds) = sinkPgm this_mod stg_binds0 + -- TODO: avoid top level lifting in core-2-core when the JS backend is + -- enabled instead of undoing it here + + putDumpFileMaybe logger Opt_D_dump_stg_from_js_sinker "STG Optimized JS Sinker:" FormatSTG + (pprGenStgTopBindings (StgPprOpts False) stg_binds) + + (deps,lus) <- runG config this_mod unfloated_binds $ do + ifProfilingM $ initCostCentres cccs + lus <- genUnits this_mod stg_binds spt_entries foreign_stubs + deps <- genDependencyData this_mod lus + pure (deps,lus) + + -- Doc to dump when -ddump-js is enabled + when (logHasDumpFlag logger Opt_D_dump_js) $ do + putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS + $ vcat (fmap (jsToDoc . oiStat . luObjBlock) lus) + + -- Write the object file + bh <- openBinMem (4 * 1000) -- a bit less than 4kB + Object.putObject bh (moduleName this_mod) deps (map luObjBlock lus) + + createDirectoryIfMissing True (takeDirectory output_fn) + writeBinMem bh output_fn + + + +-- | Generate the ingredients for the linkable units for this module +genUnits :: HasDebugCallStack + => Module + -> [CgStgTopBinding] + -> [SptEntry] + -> ForeignStubs + -> G [LinkableUnit] -- ^ the linkable units +genUnits m ss spt_entries foreign_stubs = do + gbl <- generateGlobalBlock + exports <- generateExportsBlock + others <- go 2 ss + pure (gbl:exports:others) + where + go :: HasDebugCallStack + => Int -- the block we're generating (block 0 is the global unit for the module) + -> [CgStgTopBinding] + -> G [LinkableUnit] + go !n = \case + [] -> pure [] + (x:xs) -> do + mlu <- generateBlock x n + lus <- go (n+1) xs + return (maybe lus (:lus) mlu) + + -- Generate the global unit that all other blocks in the module depend on + -- used for cost centres and static initializers + -- the global unit has no dependencies, exports the moduleGlobalSymbol + generateGlobalBlock :: HasDebugCallStack => G LinkableUnit + generateGlobalBlock = do + glbl <- State.gets gsGlobal + staticInit <- + initStaticPtrs spt_entries + let stat = ( jStgStatToJS + $ mconcat (reverse glbl) <> staticInit) + let opt_stat = jsOptimize stat + let syms = [moduleGlobalSymbol m] + let oi = ObjBlock + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = [] + , oiStat = opt_stat + , oiRaw = mempty + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjBlock = oi + , luIdExports = [] + , luOtherExports = syms + , luIdDeps = [] + , luPseudoIdDeps = [] + , luOtherDeps = [] + , luRequired = False + , luForeignRefs = [] + } + pure lu + + generateExportsBlock :: HasDebugCallStack => G LinkableUnit + generateExportsBlock = do + let (f_hdr, f_c) = case foreign_stubs of + NoStubs -> (empty, empty) + ForeignStubs hdr c -> (getCHeader hdr, getCStub c) + unique_deps = map mkUniqueDep (lines $ renderWithContext defaultSDocContext f_hdr) + mkUniqueDep (tag:xs) = mkUnique tag (read xs) + mkUniqueDep [] = panic "mkUniqueDep" + + let syms = [moduleExportsSymbol m] + let raw = utf8EncodeByteString $ renderWithContext defaultSDocContext f_c + let oi = ObjBlock + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = [] + , oiStat = mempty + , oiRaw = raw + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjBlock = oi + , luIdExports = [] + , luOtherExports = syms + , luIdDeps = [] + , luPseudoIdDeps = unique_deps + , luOtherDeps = [] + , luRequired = True + , luForeignRefs = [] + } + pure lu + + -- Generate the linkable unit for one binding or group of + -- mutually recursive bindings + generateBlock :: HasDebugCallStack + => CgStgTopBinding + -> Int + -> G (Maybe LinkableUnit) + generateBlock top_bind _n = case top_bind of + StgTopStringLit bnd str -> do + bids <- identsForId bnd + case bids of + [(identFS -> b1t),(identFS -> b2t)] -> do + emitStatic b1t (StaticUnboxed (StaticUnboxedString str)) Nothing + emitStatic b2t (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing + si <- State.gets (ggsStatic . gsGroup) + let ids = [bnd] + syms <- (\(identFS -> i) -> [i]) <$> identForId bnd + let oi = ObjBlock + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = si + , oiStat = mempty + , oiRaw = "" + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjBlock = oi + , luIdExports = ids + , luOtherExports = [] + , luIdDeps = [] + , luPseudoIdDeps = [] + , luOtherDeps = [] + , luRequired = False + , luForeignRefs = [] + } + pure (Just lu) + _ -> panic "generateBlock: invalid size" + + StgTopLifted decl -> do + tl <- genToplevel decl + extraTl <- State.gets (ggsToplevelStats . gsGroup) + ci <- State.gets (ggsClosureInfo . gsGroup) + si <- State.gets (ggsStatic . gsGroup) + unf <- State.gets gsUnfloated + extraDeps <- State.gets (ggsExtraDeps . gsGroup) + fRefs <- State.gets (ggsForeignRefs . gsGroup) + resetGroup + let allDeps = collectIds unf decl + topDeps = collectTopIds decl + required = hasExport decl + stat = jStgStatToJS + $ mconcat (reverse extraTl) <> tl + let opt_stat = jsOptimize stat + syms <- mapM (fmap (\(identFS -> i) -> i) . identForId) topDeps + let oi = ObjBlock + { oiSymbols = syms + , oiClInfo = ci + , oiStatic = si + , oiStat = opt_stat + , oiRaw = "" + , oiFExports = [] + , oiFImports = fRefs + } + let lu = LinkableUnit + { luObjBlock = oi + , luIdExports = topDeps + , luOtherExports = [] + , luIdDeps = allDeps + , luPseudoIdDeps = [] + , luOtherDeps = S.toList extraDeps + , luRequired = required + , luForeignRefs = fRefs + } + pure $! seqList topDeps `seq` seqList allDeps `seq` Just lu + +-- | variable prefix for the nth block in module + +genToplevel :: CgStgBinding -> G JStgStat +genToplevel (StgNonRec bndr rhs) = genToplevelDecl bndr rhs +genToplevel (StgRec bs) = + mconcat <$> mapM (\(bndr, rhs) -> genToplevelDecl bndr rhs) bs + +genToplevelDecl :: Id -> CgStgRhs -> G JStgStat +genToplevelDecl i rhs = do + resetSlots (genToplevelConEntry i rhs) + resetSlots (genToplevelRhs i rhs) + +genToplevelConEntry :: Id -> CgStgRhs -> G () +genToplevelConEntry i rhs = case rhs of + StgRhsCon _cc con _mu _ts _args _typ + | isDataConWorkId i + -> genSetConInfo i con (stgRhsLive rhs) -- NoSRT + StgRhsClosure _ _cc _upd_flag _args _body _typ + | Just dc <- isDataConWorkId_maybe i + -> genSetConInfo i dc (stgRhsLive rhs) -- srt + _ -> pure () + +genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G () +genSetConInfo i d l {- srt -} = do + ei <- identForDataConEntryId i + sr <- genStaticRefs l + let fields = concatMap (typeJSRep . unwrapType . scaledThing) + (dataConRepArgTys d) + emitClosureInfo $ ClosureInfo + { ciVar = ei + , ciRegs = CIRegs 0 [PtrV] + , ciName = mkFastString $ renderWithContext defaultSDocContext (ppr d) + , ciLayout = fixedLayout fields + , ciType = CICon $ dataConTag d + , ciStatic = sr + } + emitToplevel (mkDataEntry ei) + +mkDataEntry :: Ident -> JStgStat +mkDataEntry i = FuncStat i [] returnStack + +genToplevelRhs :: Id -> CgStgRhs -> G JStgStat +-- general cases: +genToplevelRhs i rhs = case rhs of + StgRhsCon cc con _mu _tys args _typ -> do + ii <- identForId i + allocConStatic ii cc con args + return mempty + StgRhsClosure _ext cc _upd_flag {- srt -} args body typ -> do + {- + algorithm: + - collect all Id refs that are in the global id cache + - count usage in body for each ref + - order by increasing use + - prepend loading lives var to body: body can stay the same + -} + eid <- identForEntryId i + idt <- identFS <$> identForId i + body <- genBody (initExprCtx i) R2 args body typ + occs <- globalOccs body + let lids = global_id <$> (sortBy cmp_cnt $ nonDetEltsUFM occs) + -- Regenerate idents from lids to restore right order of representatives. + -- Representatives have occurrence order which can be mixed. + lidents <- concat <$> traverse identsForId lids + let eidt = identFS eid + let lidents' = map identFS lidents + CIStaticRefs sr0 <- genStaticRefsRhs rhs + let sri = filter (`notElem` lidents') sr0 + sr = CIStaticRefs sri + et <- genEntryType args + ll <- loadLiveFun lids + (appK, regs, upd) <- + if et == CIThunk + then do + r <- updateThunk + pure (SAKThunk, CIRegs 0 [PtrV], r) + else + let regs = if null lidents then CIRegs 1 (concatMap idJSRep args) + else CIRegs 0 (PtrV : concatMap idJSRep args) + in pure (SAKFun, regs, mempty) + setcc <- ifProfiling $ + if et == CIThunk + then enterCostCentreThunk + else enterCostCentreFun cc + emitClosureInfo $ ClosureInfo + { ciVar = eid + , ciRegs = regs + , ciName = idt + , ciLayout = fixedLayout $ map (unaryTypeJSRep . idType) lids + , ciType = et + , ciStatic = sr + } + ccId <- costCentreStackLbl cc + emitStatic idt (StaticApp appK eidt $ map StaticObjArg lidents') ccId + return $ (FuncStat eid [] (ll <> upd <> setcc <> body)) + where + cmp_cnt :: GlobalOcc -> GlobalOcc -> Ordering + cmp_cnt g1 g2 = compare (global_count g1) (global_count g2) diff --git a/GHC/StgToJS/DataCon.hs b/GHC/StgToJS/DataCon.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/DataCon.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.DataCon +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- Code generation of data constructors +----------------------------------------------------------------------------- + +module GHC.StgToJS.DataCon + ( genCon + , allocCon + , allocUnboxedCon + , allocDynamicE + , allocDynamic + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.Ident +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.StgToJS.Closure +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Profiling +import GHC.StgToJS.Utils +import GHC.StgToJS.Ids + +import GHC.Core.DataCon + +import GHC.Types.CostCentre + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Maybe + +-- | Generate a data constructor. Special handling for unboxed tuples +genCon :: ExprCtx -> DataCon -> [JStgExpr] -> G JStgStat +genCon ctx con args + | isUnboxedTupleDataCon con + = return $ assignToExprCtx ctx args + + | [Var ctxi] <- concatMap (typex_expr) (ctxTarget ctx) + = allocCon ctxi con currentCCS args + + | xs <- concatMap typex_expr (ctxTarget ctx) + = pprPanic "genCon: unhandled DataCon" (ppr (con + , map jStgExprToJS args + , map jStgExprToJS xs + )) + +-- | Allocate a data constructor. Allocate in this context means bind the data +-- constructor to 'to' +allocCon :: Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat +allocCon to con cc xs + | isBoolDataCon con || isUnboxableCon con = + return $ AssignStat (Var to) AssignOp (allocUnboxedCon con xs) +{- | null xs = do + i <- varForId (dataConWorkId con) + return (assignj to i) -} + | otherwise = do + e <- varForDataConWorker con + cs <- getSettings + prof <- profiling + ccsJ <- if prof then ccsVarJ cc else return Nothing + return $ allocDynamic cs False to e xs ccsJ + +-- | Allocate an unboxed data constructor. If we have a bool we calculate the +-- right value. If not then we expect a singleton list and unbox by converting +-- ''C x' to 'x'. NB. This function may panic. +allocUnboxedCon :: DataCon -> [JStgExpr] -> JStgExpr +allocUnboxedCon con = \case + [] + | isBoolDataCon con && dataConTag con == 1 -> false_ + | isBoolDataCon con && dataConTag con == 2 -> true_ + [x] + | isUnboxableCon con -> x + xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, map jStgExprToJS xs)) + +-- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout. +allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig + -> JStgExpr + -> [JStgExpr] + -> Maybe JStgExpr + -> JStgExpr +allocDynamicE inline_alloc entry free cc + | inline_alloc || length free > jsClosureCount + = newClosure $ mkClosure entry free zero_ cc + | otherwise = ApplExpr allocFun (entry : free ++ maybeToList cc) + where + allocFun = allocClsA (length free) + +-- | Allocate a dynamic object +allocDynamic :: StgToJSConfig -> Bool -> Ident -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgStat +allocDynamic s need_decl to entry free cc + | need_decl = DeclStat to (Just value) + | otherwise = AssignStat (Var to) AssignOp value + where + value = allocDynamicE (csInlineAlloc s) entry free cc diff --git a/GHC/StgToJS/Deps.hs b/GHC/StgToJS/Deps.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Deps.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Deps +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- Module to calculate the transitive dependencies of a module +----------------------------------------------------------------------------- + +module GHC.StgToJS.Deps + ( genDependencyData + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Object +import GHC.StgToJS.Types +import GHC.StgToJS.Ids + +import GHC.JS.Ident + +import GHC.Types.Id +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Name + +import GHC.Unit.Module + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.FastString + +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified GHC.Data.Word64Map as WM +import GHC.Data.Word64Map (Word64Map) +import Data.Array +import Data.Word +import Control.Monad + +import Control.Monad.Trans.Class +import Control.Monad.Trans.State + +data DependencyDataCache = DDC + { ddcModule :: !(Word64Map Unit) -- ^ Unique Module -> Unit + , ddcId :: !(Word64Map ExportedFun) -- ^ Unique Id -> ExportedFun (only to other modules) + , ddcOther :: !(Map OtherSymb ExportedFun) + } + +-- | Generate module dependency data +-- +-- Generate the object's dependency data, taking care that package and module names +-- are only stored once +genDependencyData + :: HasDebugCallStack + => Module + -> [LinkableUnit] + -> G BlockInfo +genDependencyData mod units = do + ds <- evalStateT (mapM (uncurry oneDep) blocks) + (DDC WM.empty WM.empty M.empty) + return $ BlockInfo + { bi_module = mod + , bi_must_link = IS.fromList [ n | (n, _, True, _) <- ds ] + , bi_exports = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds + , bi_block_deps = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds) + } + where + -- Id -> Block + unitIdExports :: UniqFM Id Int + unitIdExports = listToUFM $ + concatMap (\(u,n) -> map (,n) (luIdExports u)) blocks + + -- OtherSymb -> Block + unitOtherExports :: Map OtherSymb Int + unitOtherExports = M.fromList $ + concatMap (\(u,n) -> map (,n) + (map (OtherSymb mod) + (luOtherExports u))) + blocks + + blocks :: [(LinkableUnit, Int)] + blocks = zip units [0..] + + -- generate the list of exports and set of dependencies for one unit + oneDep :: LinkableUnit + -> Int + -> StateT DependencyDataCache G (Int, BlockDeps, Bool, [ExportedFun]) + oneDep (LinkableUnit _ idExports otherExports idDeps pseudoIdDeps otherDeps req _frefs) n = do + (edi, bdi) <- partitionWithM (lookupIdFun n) idDeps + (edo, bdo) <- partitionWithM lookupOtherFun otherDeps + (edp, bdp) <- partitionWithM (lookupPseudoIdFun n) pseudoIdDeps + expi <- mapM lookupExportedId (filter isExportedId idExports) + expo <- mapM lookupExportedOther otherExports + -- fixme thin deps, remove all transitive dependencies! + let bdeps = BlockDeps + { blockBlockDeps = IS.toList . IS.fromList . filter (/=n) $ bdi++bdo++bdp + , blockFunDeps = S.toList . S.fromList $ edi++edo++edp + } + return (n, bdeps, req, expi++expo) + + idModule :: Id -> Maybe Module + idModule i = nameModule_maybe (getName i) >>= \m -> + guard (m /= mod) >> return m + + lookupPseudoIdFun :: Int -> Unique + -> StateT DependencyDataCache G (Either ExportedFun Int) + lookupPseudoIdFun _n u = + case lookupUFM_Directly unitIdExports u of + Just k -> return (Right k) + _ -> panic "lookupPseudoIdFun" + + -- get the function for an Id from the cache, add it if necessary + -- result: Left Object.ExportedFun if function refers to another module + -- Right blockNumber if function refers to current module + -- + -- assumes function is internal to the current block if it's + -- from teh current module and not in the unitIdExports map. + lookupIdFun :: Int -> Id + -> StateT DependencyDataCache G (Either ExportedFun Int) + lookupIdFun n i = case lookupUFM unitIdExports i of + Just k -> return (Right k) + Nothing -> case idModule i of + Nothing -> return (Right n) + Just m -> + let k = getKey . getUnique $ i + addEntry :: StateT DependencyDataCache G ExportedFun + addEntry = do + idTxt <- identFS <$> lift (identForId i) + lookupExternalFun (Just k) (OtherSymb m idTxt) + in if m == mod + then pprPanic "local id not found" (ppr m) + else Left <$> do + mr <- gets (WM.lookup k . ddcId) + maybe addEntry return mr + + -- get the function for an OtherSymb from the cache, add it if necessary + lookupOtherFun :: OtherSymb + -> StateT DependencyDataCache G (Either ExportedFun Int) + lookupOtherFun od@(OtherSymb m idTxt) = + case M.lookup od unitOtherExports of + Just n -> return (Right n) + Nothing | m == mod -> pprPanic "genDependencyData.lookupOtherFun: unknown local other id:" (ftext idTxt) + Nothing -> Left <$> (maybe (lookupExternalFun Nothing od) return =<< + gets (M.lookup od . ddcOther)) + + lookupExportedId :: Id -> StateT DependencyDataCache G ExportedFun + lookupExportedId i = do + idTxt <- identFS <$> lift (identForId i) + lookupExternalFun (Just . getKey . getUnique $ i) (OtherSymb mod idTxt) + + lookupExportedOther :: FastString -> StateT DependencyDataCache G ExportedFun + lookupExportedOther = lookupExternalFun Nothing . OtherSymb mod + + -- lookup a dependency to another module, add to the id cache if there's + -- an id key, otherwise add to other cache + lookupExternalFun :: Maybe Word64 + -> OtherSymb -> StateT DependencyDataCache G ExportedFun + lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do + let mk = getKey . getUnique $ m + mpk = moduleUnit m + exp_fun = ExportedFun m (LexicalFastString idTxt) + addCache = do + ms <- gets ddcModule + let !cache' = WM.insert mk mpk ms + modify (\s -> s { ddcModule = cache'}) + pure exp_fun + f <- do + mbm <- gets (WM.member mk . ddcModule) + case mbm of + False -> addCache + True -> pure exp_fun + + case mbIdKey of + Nothing -> modify (\s -> s { ddcOther = M.insert od f (ddcOther s) }) + Just k -> modify (\s -> s { ddcId = WM.insert k f (ddcId s) }) + + return f diff --git a/GHC/StgToJS/Expr.hs b/GHC/StgToJS/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Expr.hs @@ -0,0 +1,1119 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Expr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- Code generation of Expressions +----------------------------------------------------------------------------- + +module GHC.StgToJS.Expr + ( genExpr + , genEntryType + , loadLiveFun + , genStaticRefsRhs + , genStaticRefs + , genBody + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import GHC.JS.Transform +import GHC.JS.Make +import GHC.JS.Ident + +import GHC.StgToJS.Apply +import GHC.StgToJS.Arg +import GHC.StgToJS.Closure +import GHC.StgToJS.DataCon +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.FFI +import GHC.StgToJS.Heap +import GHC.StgToJS.Ids +import GHC.StgToJS.Literal +import GHC.StgToJS.Monad +import GHC.StgToJS.Prim +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.Stack +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types +import GHC.StgToJS.Utils +import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8) + +import GHC.Types.CostCentre +import GHC.Types.Tickish +import GHC.Types.Var.Set +import GHC.Types.Id +import GHC.Types.Unique.FM +import GHC.Types.RepType +import GHC.Types.Literal + +import GHC.Stg.Syntax +import GHC.Stg.Utils + +import GHC.Builtin.PrimOps +import GHC.Builtin.Names + +import GHC.Core hiding (Var) +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Opt.Arity (isOneShotBndr) +import GHC.Core.Type hiding (typeSize) + +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext) +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Data.FastString +import qualified GHC.Types.Unique.Map as UM + +import qualified GHC.Data.List.SetOps as ListSetOps + +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Monoid +import Data.Maybe +import Data.Function +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Map as M +import Control.Monad +import Control.Arrow ((&&&)) + +-- | Evaluate an expression in the given expression context (continuation) +genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult) +genExpr ctx stg = case stg of + StgApp f args -> genApp ctx f args + StgLit l -> do + ls <- genLit l + let r = assignToExprCtx ctx ls + pure (r,ExprInline) + StgConApp con _n args _ -> do + as <- concatMapM genArg args + c <- genCon ctx con as + return (c, ExprInline) + StgOpApp (StgFCallOp f _) args t + -> genForeignCall ctx f t (concatMap typex_expr $ ctxTarget ctx) args + StgOpApp (StgPrimOp op) args t + -> genPrimOp ctx op args t + StgOpApp (StgPrimCallOp c) args t + -> genPrimCall ctx c args t + StgCase e b at alts + -> genCase ctx b e at alts (liveVars $ stgExprLive False stg) + StgLet _ b e -> do + (b',ctx') <- genBind ctx b + (s,r) <- genExpr ctx' e + return (b' <> s, r) + StgLetNoEscape _ b e -> do + (b', ctx') <- genBindLne ctx b + (s, r) <- genExpr ctx' e + return (b' <> s, r) + StgTick (ProfNote cc count scope) e -> do + setSCCstats <- ifProfilingM $ setCC cc count scope + (stats, result) <- genExpr ctx e + return (setSCCstats <> stats, result) + StgTick (SourceNote span _sname) e + -> genExpr (ctxSetSrcSpan span ctx) e + StgTick _m e + -> genExpr ctx e + +-- | regular let binding: allocate heap object +genBind :: HasDebugCallStack + => ExprCtx + -> CgStgBinding + -> G (JStgStat, ExprCtx) +genBind ctx bndr = + case bndr of + StgNonRec b r -> do + j <- assign b r >>= \case + Just ja -> return ja + Nothing -> allocCls Nothing [(b,r)] + return (j, ctx) + StgRec bs -> do + jas <- mapM (uncurry assign) bs -- fixme these might depend on parts initialized by allocCls + let m = if null jas then Nothing else Just (mconcat $ catMaybes jas) + j <- allocCls m . map snd . filter (isNothing . fst) $ zip jas bs + return (j, ctx) + where + ctx' = ctxClearLneFrame ctx + + assign :: Id -> CgStgRhs -> G (Maybe JStgStat) + assign b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr _typ) + | let strip = snd . stripStgTicksTop (not . tickishIsCode) + , StgCase (StgApp scrutinee []) _ (AlgAlt _) [GenStgAlt (DataAlt _) params sel_expr] <- strip expr + , StgApp selectee [] <- strip sel_expr + , let params_w_offsets = zip params (L.scanl' (+) 1 $ map (typeSize . idType) params) + , let total_size = sum (map (typeSize . idType) params) + -- , the_fv == scrutinee -- fixme check + , Just the_offset <- ListSetOps.assocMaybe params_w_offsets selectee + , the_offset <= 16 -- fixme make this some configurable constant + = do + let the_fv = scrutinee -- error "the_fv" -- fixme + let sel_tag | the_offset == 2 = if total_size == 2 then "2a" + else "2b" + | otherwise = show the_offset + tgts <- identsForId b + the_fvjs <- varsForId the_fv + case (tgts, the_fvjs) of + ([tgt], [the_fvj]) -> return $ Just + (tgt ||= ApplExpr (global (hdCSelStr <> mkFastString sel_tag)) [the_fvj]) + _ -> panic "genBind.assign: invalid size" + assign b (StgRhsClosure _ext _ccs _upd [] expr _typ) + | isInlineExpr expr = do + d <- declVarsForId b + tgt <- varsForId b + let ctx' = ctx { ctxTarget = assocIdExprs b tgt } + (j, _) <- genExpr ctx' expr + return (Just (d <> j)) + assign _b StgRhsCon{} = return Nothing + assign b r = genEntry ctx' b r >> return Nothing + +genBindLne :: HasDebugCallStack + => ExprCtx + -> CgStgBinding + -> G (JStgStat, ExprCtx) +genBindLne ctx bndr = do + -- compute live variables and the offsets where they will be stored in the + -- stack + vis <- map (\(x,y,_) -> (x,y)) <$> + optimizeFree oldFrameSize (newLvs++map fst updBinds) + -- initialize updatable bindings to null_ + declUpds <- mconcat <$> mapM (fmap (||= null_) . identForId . fst) updBinds + -- update expression context to include the updated LNE frame + let ctx' = ctxUpdateLneFrame vis bound ctx + mapM_ (uncurry $ genEntryLne ctx') binds + return (declUpds, ctx') + where + oldFrameSize = ctxLneFrameSize ctx + isOldLv i = ctxIsLneBinding ctx i || + ctxIsLneLiveVar ctx i + live = liveVars $ mkDVarSet $ stgLneLive' bndr + newLvs = filter (not . isOldLv) (dVarSetElems live) + binds = case bndr of + StgNonRec b e -> [(b,e)] + StgRec bs -> bs + bound = map fst binds + (updBinds, _nonUpdBinds) = L.partition (isUpdatableRhs . snd) binds + +-- | Generate let-no-escape entry +-- +-- Let-no-escape entries live on the stack. There is no heap object associated with them. +-- +-- A let-no-escape entry is called like a normal stack frame, although as an optimization, +-- `Stack`[`Sp`] is not set when making the call. This is done later if the +-- thread needs to be suspended. +-- +-- Updatable let-no-escape binders have one 'private' slot in the stack frame. This slot +-- is initially set to null, changed to h$blackhole when the thunk is being evaluated. +-- +genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () +genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) = + resetSlots $ do + let payloadSize = ctxLneFrameSize ctx + vars = ctxLneFrameVars ctx + myOffset = + maybe (panic "genEntryLne: updatable binder not found in let-no-escape frame") + ((payloadSize-) . fst) + (L.find ((==i) . fst . snd) (zip [0..] vars)) + mk_bh :: G JStgStat + mk_bh | isUpdatable update = + do x <- freshIdent + return $ mconcat + [ x ||= ApplExpr hdBlackHoleLNE [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)] + , IfStat (Var x) (ReturnStat (Var x)) mempty + ] + | otherwise = pure mempty + blk_hl <- mk_bh + locals <- popLneFrame True payloadSize ctx + body <- genBody ctx R1 args body typ + ei@(identFS -> eii) <- identForEntryId i + sr <- genStaticRefsRhs rhs + let f = blk_hl <> locals <> body + emitClosureInfo $ ClosureInfo + { ciVar = ei + , ciRegs = CIRegs 0 $ concatMap idJSRep args + , ciName = eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)) + , ciLayout = fixedLayout . reverse $ map (stackSlotType . fst) (ctxLneFrameVars ctx) + , ciType = CIStackFrame + , ciStatic = sr + } + emitToplevel (FuncStat ei [] f) +genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do + let payloadSize = ctxLneFrameSize ctx + ei <- identForEntryId i + -- di <- varForDataConWorker con + ii <- freshIdent + p <- popLneFrame True payloadSize ctx + args' <- concatMapM genArg args + ac <- allocCon ii con cc args' + emitToplevel (FuncStat ei [] (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack])) + +-- | Generate the entry function for a local closure +genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () +genEntry _ _i StgRhsCon {} = return () +genEntry ctx i rhs@(StgRhsClosure _ext cc upd_flag args body typ) = resetSlots $ do + let live = stgLneLiveExpr rhs + ll <- loadLiveFun live + llv <- verifyRuntimeReps live + upd <- genUpdFrame upd_flag i + let entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) + body <- genBody entryCtx R2 args body typ + et <- genEntryType args + setcc <- ifProfiling $ + if et == CIThunk + then enterCostCentreThunk + else enterCostCentreFun cc + sr <- genStaticRefsRhs rhs + + ei <- identForEntryId i + emitClosureInfo $ ClosureInfo + { ciVar = ei + , ciRegs = CIRegs 0 $ PtrV : concatMap idJSRep args + , ciName = identFS ei <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)) + , ciLayout = fixedLayout $ map (unaryTypeJSRep . idType) live + , ciType = et + , ciStatic = sr + } + emitToplevel (FuncStat ei [] (mconcat [ll, llv, upd, setcc, body])) + +-- | Generate the entry function types for identifiers. Note that this only +-- returns either 'CIThunk' or 'CIFun'. +genEntryType :: HasDebugCallStack => [Id] -> G CIType +genEntryType [] = return CIThunk +genEntryType args = do + args' <- mapM genIdArg args + return $ CIFun (length args) (length $ concat args') + +-- | Generate the body of an object +genBody :: HasDebugCallStack + => ExprCtx + -> StgReg + -> [Id] + -> CgStgExpr + -> Type + -> G JStgStat +genBody ctx startReg args e typ = do + -- load arguments into local variables + la <- do + args' <- concatMapM genIdArgI args + return (declAssignAll args' (fmap toJExpr [startReg..])) + + -- assert that arguments have valid runtime reps + lav <- verifyRuntimeReps args + + -- compute PrimReps and their number of slots required to return the result of + -- i applied to args. + let res_vars = resultSize typ + + -- compute typed expressions for each slot and assign registers + let go_var regs = \case + [] -> [] + ((rep,size):rs) -> + let !(regs0,regs1) = splitAt size regs + !ts = go_var regs1 rs + in TypedExpr rep regs0 : ts + + let tgt = go_var jsRegsFromR1 res_vars + let !ctx' = ctx { ctxTarget = tgt } + + -- generate code for the expression + (e, _r) <- genExpr ctx' e + + return $ la <> lav <> e <> returnStack + +-- | Find the result type after applying the function to the arguments +-- +-- It's trickier than it looks because: +-- +-- 1. we don't have the Arity of the Id. The following functions return +-- different values in some cases: +-- - idArity +-- - typeArity . idType +-- - idFunRepArity +-- - typeArity . unwrapType . idType +-- Moreover the number of args may be different than all of these arities +-- +-- 2. sometimes the type is Any, perhaps after some unwrapping. For example +-- HappyAbsSyn is a newtype around HappyAny which is Any or (forall a. a). +-- +-- Se we're left to use the applied arguments to peel the type (unwrapped) one +-- arg at a time. But passed args are args after unarisation so we need to +-- unarise every argument type that we peel (using typePrimRep) to get the +-- number of passed args consumed by each type arg. +-- +-- In case of failure to determine the type, we default to LiftedRep as it's +-- probably what it is. +-- +resultSize :: HasDebugCallStack => Type -> [(PrimRep, Int)] +resultSize ty = result + where + result = result_reps `zip` result_slots + result_slots = fmap (slotCount . primRepSize) result_reps + result_reps = typePrimRep ty + +-- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function +-- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False. +verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStgStat +verifyRuntimeReps xs = do + runtime_assert <- csRuntimeAssert <$> getSettings + if not runtime_assert + then pure mempty + else mconcat <$> mapM verifyRuntimeRep xs + where + verifyRuntimeRep i = do + i' <- varsForId i + pure $ go i' (idJSRep i) + go js (VoidV:vs) = go js vs + go (j1:j2:js) (LongV:vs) = v "h$verify_rep_long" [j1,j2] <> go js vs + go (j1:j2:js) (AddrV:vs) = v "h$verify_rep_addr" [j1,j2] <> go js vs + go (j:js) (v:vs) = ver j v <> go js vs + go [] [] = mempty + go _ _ = pprPanic "verifyRuntimeReps: inconsistent sizes" (ppr xs) + ver j PtrV = v "h$verify_rep_heapobj" [j] + ver j IntV = v "h$verify_rep_int" [j] + ver j DoubleV = v "h$verify_rep_double" [j] + ver j ArrV = v "h$verify_rep_arr" [j] + ver _ _ = mempty + v f as = ApplStat (global f) as + +-- | Given a set of 'Id's, bind each 'Id' to the appropriate data fields in N +-- registers. This assumes these data fields have already been populated in the +-- registers. For the empty, singleton, and binary case use register 1, for any +-- more use as many registers as necessary. +loadLiveFun :: [Id] -> G JStgStat +loadLiveFun l = do + l' <- concat <$> mapM identsForId l + case l' of + [] -> return mempty + -- set the ident to d1 field of register 1 + [v] -> return (v ||= r1 .^ closureField1_) + -- set the idents to d1 and d2 fields of register 1 + [v1,v2] -> return $ mconcat + [ v1 ||= r1 .^ closureField1_ + , v2 ||= r1 .^ closureField2_ + ] + -- and so on + (v:vs) -> do + d <- freshIdent + let l'' = mconcat . zipWith (loadLiveVar $ toJExpr d) [(1::Int)..] $ vs + return $ mconcat + [ v ||= r1 .^ closureField1_ + , d ||= r1 .^ closureField2_ + , l'' + ] + where + loadLiveVar d n v = let ident = name (dataFieldName n) + in v ||= SelExpr d ident + +-- | Pop a let-no-escape frame off the stack +popLneFrame :: Bool -> Int -> ExprCtx -> G JStgStat +popLneFrame inEntry size ctx = do + -- calculate the new stack size + let ctx' = ctxLneShrinkStack ctx size + + let gen_id_slot (i,n) = do + ids <- identsForId i + let !id_n = ids !! (n-1) + pure (id_n, SlotId i n) + + is <- mapM gen_id_slot (ctxLneFrameVars ctx') + + let skip = if inEntry then 1 else 0 -- pop the frame header + popSkipI skip is + +-- | Generate an updated given an 'Id' +genUpdFrame :: UpdateFlag -> Id -> G JStgStat +genUpdFrame u i + | isReEntrant u = pure mempty + | isOneShotBndr i = maybeBh + | isUpdatable u = updateThunk + | otherwise = maybeBh + where + isReEntrant ReEntrant = True + isReEntrant _ = False + maybeBh = do + settings <- getSettings + assertRtsStat (return $ bhSingleEntry settings) + +-- | Blackhole single entry +-- +-- Overwrite a single entry object with a special thunk that behaves like a +-- black hole (throws a JS exception when entered) but pretends to be a thunk. +-- Useful for making sure that the object is not accidentally entered multiple +-- times +-- +bhSingleEntry :: StgToJSConfig -> JStgStat +bhSingleEntry _settings = mconcat + [ closureInfo r1 |= hdBlackHoleTrap + , closureField1 r1 |= undefined_ + , closureField2 r1 |= undefined_ + ] + +genStaticRefsRhs :: CgStgRhs -> G CIStatic +genStaticRefsRhs lv = genStaticRefs (stgRhsLive lv) + +-- fixme, update to new way to compute static refs dynamically +genStaticRefs :: LiveVars -> G CIStatic +genStaticRefs lv + | isEmptyDVarSet sv = return (CIStaticRefs []) + | otherwise = do + unfloated <- State.gets gsUnfloated + let xs = filter (\x -> not (elemUFM x unfloated || + definitelyUnliftedType (idType x))) + (dVarSetElems sv) + CIStaticRefs . catMaybes <$> mapM getStaticRef xs + where + sv = liveStatic lv + + getStaticRef :: Id -> G (Maybe FastString) + getStaticRef = fmap (fmap identFS . listToMaybe) . identsForId + +-- | Reorder the things we need to push to reuse existing stack values as much +-- as possible True if already on the stack at that location +optimizeFree + :: HasDebugCallStack + => Int + -> [Id] + -> G [(Id,Int,Bool)] -- ^ A list of stack slots. + -- -- Id: stored on the slot + -- -- Int: the part of the value that is stored + -- -- Bool: True when the slot already contains a value +optimizeFree offset ids = do + -- this line goes wrong vvvvvvv + let -- ids' = concat $ map (\i -> map (i,) [1..varSize . unaryTypeJSRep . idType $ i]) ids + idSize :: Id -> Int + idSize i = typeSize $ idType i + ids' = concatMap (\i -> map (i,) [1..idSize i]) ids + -- 1..varSize] . unaryTypeJSRep . idType $ i]) (typeJSRep ids) + l = length ids' + slots <- drop offset . take l . (++repeat SlotUnknown) <$> getSlots + let slm = M.fromList (zip slots [0..]) + (remaining, fixed) = partitionWith (\inp@(i,n) -> maybe (Left inp) + (\j -> Right (i,n,j,True)) + (M.lookup (SlotId i n) slm)) + ids' + takenSlots = S.fromList (fmap (\(_,_,x,_) -> x) fixed) + freeSlots = filter (`S.notMember` takenSlots) [0..l-1] + remaining' = zipWith (\(i,n) j -> (i,n,j,False)) remaining freeSlots + allSlots = L.sortBy (compare `on` \(_,_,x,_) -> x) (fixed ++ remaining') + return $ map (\(i,n,_,b) -> (i,n,b)) allSlots + +-- | Allocate local closures +allocCls :: Maybe JStgStat -> [(Id, CgStgRhs)] -> G JStgStat +allocCls dynMiddle xs = do + (stat, dyn) <- partitionWithM toCl xs + ac <- allocDynAll False dynMiddle dyn + pure (mconcat stat <> ac) + where + -- left = static, right = dynamic + toCl :: (Id, CgStgRhs) + -> G (Either JStgStat (Ident,JStgExpr,[JStgExpr],CostCentreStack)) + -- statics + {- making zero-arg constructors static is problematic, see #646 + proper candidates for this optimization should have been floated + already + toCl (i, StgRhsCon cc con []) = do + ii <- identForId i + Left <$> (return (decl ii) <> allocCon ii con cc []) -} + toCl (i, StgRhsCon cc con _mui _ticjs [a] _typ) | isUnboxableCon con = do + ii <- identForId i + ac <- allocCon ii con cc =<< genArg a + pure (Left (decl ii <> ac)) + + -- dynamics + toCl (i, StgRhsCon cc con _mu _ticks ar _typ) = + -- fixme do we need to handle unboxed? + Right <$> ((,,,) <$> identForId i + <*> varForDataConWorker con + <*> concatMapM genArg ar + <*> pure cc) + toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body _typ)) = + let live = stgLneLiveExpr cl + in Right <$> ((,,,) <$> identForId i + <*> varForEntryId i + <*> concatMapM varsForId live + <*> pure cc) + +-- fixme CgCase has a reps_compatible check here +-- | Consume Stg case statement and generate a case statement. See also +-- 'genAlts' +genCase :: HasDebugCallStack + => ExprCtx + -> Id + -> CgStgExpr + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G (JStgStat, ExprResult) +genCase ctx bnd e at alts l + -- For: unpackCStringAppend# "some string"# str + -- Generate: h$appendToHsStringA(str, "some string") + -- + -- The latter has a faster decoding loop. + -- + -- Since #23270 and 7e0c8b3bab30, literals strings aren't STG atoms and we + -- need to match the following instead: + -- + -- case "some string"# of b { + -- DEFAULT -> unpackCStringAppend# b str + -- } + -- + -- Wrinkle: it doesn't kick in when literals are floated out to the top level. + -- + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , getUnique i == unpackCStringAppendIdKey + , [StgVarArg b',x] <- args + , bnd == b' + , Just d <- decodeModifiedUTF8 bs + , [top] <- concatMap typex_expr (ctxTarget ctx) + = do + prof <- csProf <$> getSettings + let profArg = if prof then [jCafCCS] else [] + a <- genArg x + return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg) + , ExprInline + ) + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , getUnique i == unpackCStringAppendUtf8IdKey + , [StgVarArg b',x] <- args + , bnd == b' + , Just d <- decodeModifiedUTF8 bs + , [top] <- concatMap typex_expr (ctxTarget ctx) + = do + prof <- csProf <$> getSettings + let profArg = if prof then [jCafCCS] else [] + a <- genArg x + return ( top |= app "h$appendToHsString" (toJExpr d : a ++ profArg) + , ExprInline + ) + + -- The latter has a faster decoding loop. + -- + -- case "some string"# of b { + -- DEFAULT -> unpackCString# b + -- } + -- + -- + Utf8 version below + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , idName i == unpackCStringName + , [StgVarArg b'] <- args + , bnd == b' + , Just d <- decodeModifiedUTF8 bs + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return + ( top |= app "h$toHsStringA" [toJExpr d] + , ExprInline + ) + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , idName i == unpackCStringUtf8Name + , [StgVarArg b'] <- args + , bnd == b' + , Just d <- decodeModifiedUTF8 bs + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return + ( top |= app "h$toHsString" [toJExpr d] + , ExprInline + ) + + | isInlineExpr e = do + bndi <- identsForId bnd + let ctx' = ctxSetTop bnd + $ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi)) + $ ctx + (ej, r) <- genExpr ctx' e + massert (r == ExprInline) + + (aj, ar) <- genAlts ctx bnd at alts + (saveCCS,restoreCCS) <- ifProfilingM $ do + ccsVar <- freshIdent + pure ( ccsVar ||= toJExpr jCurrentCCS + , toJExpr jCurrentCCS |= toJExpr ccsVar + ) + return ( mconcat + [ mconcat (map decl bndi) + , saveCCS + , ej + , restoreCCS + , aj + ] + , ar + ) + | otherwise = do + rj <- genRet ctx bnd at alts l + let ctx' = ctxSetTop bnd + $ ctxSetTarget (assocIdExprs bnd (map toJExpr [R1 ..])) + $ ctx + (ej, _r) <- genExpr ctx' e + return (rj <> ej, ExprCont) + +genRet :: HasDebugCallStack + => ExprCtx + -> Id + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G JStgStat +genRet ctx e at as l = freshIdent >>= f + where + allRefs :: [Id] + allRefs = S.toList . S.unions $ fmap (exprRefs emptyUFM . alt_rhs) as + lneLive :: Int + lneLive = maximum $ 0 :| catMaybes (map (ctxLneBindingStackSize ctx) allRefs) + ctx' = ctxLneShrinkStack ctx lneLive + lneVars = map fst $ ctxLneFrameVars ctx' + isLne i = ctxIsLneBinding ctx i || ctxIsLneLiveVar ctx' i + nonLne = filter (not . isLne) (dVarSetElems l) + + f :: Ident -> G JStgStat + f r@(identFS -> ri) = do + pushLne <- pushLneFrame lneLive ctx + saveCCS <- ifProfilingM $ push [jCurrentCCS] + free <- optimizeFree 0 nonLne + pushRet <- pushRetArgs free (toJExpr r) + fun' <- fun free + sr <- genStaticRefs l -- srt + prof <- profiling + emitClosureInfo $ ClosureInfo + { ciVar = r + , ciRegs = CIRegs 0 altRegs + , ciName = ri + , ciLayout = fixedLayout . reverse $ + map (stackSlotType . fst3) free + ++ if prof then [ObjV] else map stackSlotType lneVars + , ciType = CIStackFrame + , ciStatic = sr + } + emitToplevel $ FuncStat r [] fun' + return (pushLne <> saveCCS <> pushRet) + fst3 ~(x,_,_) = x + + altRegs :: HasDebugCallStack => [JSRep] + altRegs = case at of + PrimAlt ptc -> [primRepToJSRep ptc] + MultiValAlt _n -> idJSRep e + _ -> [PtrV] + + -- special case for popping CCS but preserving stack size + pop_handle_CCS :: [(JStgExpr, StackSlot)] -> G JStgStat + pop_handle_CCS [] = return mempty + pop_handle_CCS xs = do + -- grab the slots from 'xs' and push + addSlots (map snd xs) + -- move the stack pointer into the stack by ''length xs + n' + a <- adjSpN (length xs) + -- now load from the top of the stack + return (loadSkip 0 (map fst xs) <> a) + + fun free = resetSlots $ do + decs <- declVarsForId e + load <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> identsForId e + loadv <- verifyRuntimeReps [e] + ras <- loadRetArgs free + rasv <- verifyRuntimeReps (map (\(x,_,_)->x) free) + restoreCCS <- ifProfilingM . pop_handle_CCS $ pure (jCurrentCCS, SlotUnknown) + rlne <- popLneFrame False lneLive ctx' + rlnev <- verifyRuntimeReps lneVars + (alts, _altr) <- genAlts ctx' e at as + return $ decs <> load <> loadv <> ras <> rasv <> restoreCCS <> rlne <> rlnev <> alts <> + returnStack + +-- | Consume an Stg case alternative and generate the corresponding alternative +-- in JS land. If one alternative is a continuation then we must normalize the +-- other alternatives. See 'Branch' and 'normalizeBranches'. +genAlts :: HasDebugCallStack + => ExprCtx -- ^ lhs to assign expression result to + -> Id -- ^ id being matched + -> AltType -- ^ type + -> [CgStgAlt] -- ^ the alternatives + -> G (JStgStat, ExprResult) +genAlts ctx e at alts = do + (st, er) <- case at of + + PolyAlt -> case alts of + [alt] -> (branch_stat &&& branch_result) <$> mkAlgBranch ctx e alt + _ -> panic "genAlts: multiple polyalt" + + PrimAlt _tc + | [GenStgAlt _ bs expr] <- alts + -> do + ie <- varsForId e + dids <- mconcat <$> mapM declVarsForId bs + bss <- concatMapM varsForId bs + (ej, er) <- genExpr ctx expr + return (dids <> assignAll bss ie <> ej, er) + + PrimAlt tc + -> do + ie <- varsForId e + (r, bss) <- normalizeBranches ctx <$> + mapM (isolateSlots . mkPrimIfBranch ctx [primRepToJSRep tc]) alts + setSlots [] + return (mkSw ie bss, r) + + MultiValAlt n + | [GenStgAlt _ bs expr] <- alts + -> do + eids <- varsForId e + l <- loadUbxTup eids bs n + (ej, er) <- genExpr ctx expr + return (l <> ej, er) + + AlgAlt tc + | [_alt] <- alts + , isUnboxedTupleTyCon tc + -> panic "genAlts: unexpected unboxed tuple" + + AlgAlt _tc + | [alt] <- alts + -> do + Branch _ s r <- mkAlgBranch ctx e alt + return (s, r) + + AlgAlt _tc + | [alt,_] <- alts + , DataAlt dc <- alt_con alt + , isBoolDataCon dc + -> do + i <- varForId e + nbs <- normalizeBranches ctx <$> + mapM (isolateSlots . mkAlgBranch ctx e) alts + case nbs of + (r, [Branch _ s1 _, Branch _ s2 _]) -> do + let s = if dataConTag dc == 2 + then IfStat i s1 s2 + else IfStat i s2 s1 + setSlots [] + return (s, r) + _ -> error "genAlts: invalid branches for Bool" + + AlgAlt _tc -> do + ei <- varForId e + (r, brs) <- normalizeBranches ctx <$> + mapM (isolateSlots . mkAlgBranch ctx e) alts + setSlots [] + return (mkSwitch (ei .^ "f" .^ "a") brs, r) + + _ -> pprPanic "genAlts: unhandled case variant" (ppr (at, length alts)) + + ver <- verifyMatchRep e at + pure (ver <> st, er) + +-- | If 'StgToJSConfig.csRuntimeAssert' is set, then generate an assertion that +-- asserts the pattern match is valid, e.g., the match is attempted on a +-- Boolean, a Data Constructor, or some number. +verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStgStat +verifyMatchRep x alt = do + runtime_assert <- csRuntimeAssert <$> getSettings + if not runtime_assert + then pure mempty + else case alt of + AlgAlt tc -> do + ix <- varsForId x + pure $ ApplStat (global "h$verify_match_alg") (ValExpr (JStr (mkFastString (renderWithContext defaultSDocContext (ppr tc)))):ix) + _ -> pure mempty + +-- | A 'Branch' represents a possible branching path of an Stg case statement, +-- i.e., a possible code path from an 'StgAlt' +data Branch a = Branch + { branch_expr :: a + , branch_stat :: JStgStat + , branch_result :: ExprResult + } + deriving (Eq,Functor) + +-- | If one branch ends in a continuation but another is inline, we need to +-- adjust the inline branch to use the continuation convention +normalizeBranches :: ExprCtx + -> [Branch a] + -> (ExprResult, [Branch a]) +normalizeBranches ctx brs + | all (==ExprCont) (fmap branch_result brs) = + (ExprCont, brs) + | branchResult (fmap branch_result brs) == ExprCont = + (ExprCont, map mkCont brs) + | otherwise = + (ExprInline, brs) + where + mkCont b = case branch_result b of + ExprInline -> b { branch_stat = branch_stat b <> assignAll jsRegsFromR1 + (concatMap typex_expr $ ctxTarget ctx) + , branch_result = ExprCont + } + _ -> b + +-- | Load an unboxed tuple. "Loading" means getting all 'Idents' from the input +-- ID's, declaring them as variables in JS land and binding them, in order, to +-- 'es'. +loadUbxTup :: [JStgExpr] -> [Id] -> Int -> G JStgStat +loadUbxTup es bs _n = do + bs' <- concatMapM identsForId bs + return $ declAssignAll bs' es + +mkSw :: [JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat +mkSw [e] cases = mkSwitch e (fmap (fmap (fmap head)) cases) +mkSw es cases = mkIfElse es cases + +-- | Switch for pattern matching on constructors or prims +mkSwitch :: JStgExpr -> [Branch (Maybe JStgExpr)] -> JStgStat +mkSwitch e cases + | [Branch (Just c1) s1 _] <- n + , [Branch _ s2 _] <- d + = IfStat (InfixExpr StrictEqOp e c1) s1 s2 + + | [Branch (Just c1) s1 _, Branch _ s2 _] <- n + , null d + = IfStat (InfixExpr StrictEqOp e c1) s1 s2 + + | null d + = SwitchStat e (map addBreak (init n)) (branch_stat (last n)) + + | [Branch _ d0 _] <- d + = SwitchStat e (map addBreak n) d0 + + | otherwise = panic "mkSwitch: multiple default cases" + where + addBreak (Branch (Just c) s _) = (c, mconcat [s, BreakStat Nothing]) + addBreak _ = panic "mkSwitch: addBreak" + (n,d) = L.partition (isJust . branch_expr) cases + +-- | if/else for pattern matching on things that js cannot switch on +-- the list of branches is expected to have the default alternative +-- first, if it exists +mkIfElse :: [JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat +mkIfElse e s = go (L.reverse s) + where + go = \case + [Branch _ s _] -> s -- only one 'nothing' allowed + (Branch (Just e0) s _ : xs) -> IfStat (mkEq e e0) s (go xs) + [] -> panic "mkIfElse: empty expression list" + _ -> panic "mkIfElse: multiple DEFAULT cases" + +-- | Wrapper to construct sequences of (===), e.g., +-- +-- > mkEq [l0,l1,l2] [r0,r1,r2] = (l0 === r0) && (l1 === r1) && (l2 === r2) +-- +mkEq :: [JStgExpr] -> [JStgExpr] -> JStgExpr +mkEq es1 es2 + | length es1 == length es2 = L.foldl1 (InfixExpr LAndOp) (zipWith (InfixExpr StrictEqOp) es1 es2) + | otherwise = panic "mkEq: incompatible expressions" + +mkAlgBranch :: ExprCtx -- ^ toplevel id for the result + -> Id -- ^ datacon to match + -> CgStgAlt -- ^ match alternative with binders + -> G (Branch (Maybe JStgExpr)) +mkAlgBranch top d alt + | DataAlt dc <- alt_con alt + , isUnboxableCon dc + , [b] <- alt_bndrs alt + = do + idd <- varForId d + fldx <- identsForId b + case fldx of + [fld] -> do + (ej, er) <- genExpr top (alt_rhs alt) + return (Branch Nothing (mconcat [fld ||= idd, ej]) er) + _ -> panic "mkAlgBranch: invalid size" + + | otherwise + = do + cc <- caseCond (alt_con alt) + idd <- varForId d + b <- loadParams idd (alt_bndrs alt) + (ej, er) <- genExpr top (alt_rhs alt) + return (Branch cc (b <> ej) er) + +-- | Generate a primitive If-expression +mkPrimIfBranch :: ExprCtx + -> [JSRep] + -> CgStgAlt + -> G (Branch (Maybe [JStgExpr])) +mkPrimIfBranch top _vt alt = + (\ic (ej,er) -> Branch ic ej er) <$> ifCond (alt_con alt) <*> genExpr top (alt_rhs alt) + +-- fixme are bool things always checked correctly here? +ifCond :: AltCon -> G (Maybe [JStgExpr]) +ifCond = \case + DataAlt da -> return $ Just [toJExpr (dataConTag da)] + LitAlt l -> Just <$> genLit l + DEFAULT -> return Nothing + +caseCond :: AltCon -> G (Maybe JStgExpr) +caseCond = \case +-- fixme use single tmp var for all branches + DEFAULT -> return Nothing + DataAlt da -> return $ Just (toJExpr $ dataConTag da) + LitAlt l -> genLit l >>= \case + [e] -> pure (Just e) + es -> pprPanic "caseCond: expected single-variable literal" (ppr $ jStgExprToJS <$> es) + +-- | Load parameters from constructor +loadParams :: JStgExpr -> [Id] -> G JStgStat +loadParams from args = do + as <- concat <$> zipWithM (\a u -> map (,u) <$> identsForId a) args use + case as of + [] -> return mempty + [(x,u)] -> return $ loadIfUsed (from .^ closureField1_) x u + [(x1,u1),(x2,u2)] -> return $ mconcat + [ loadIfUsed (from .^ closureField1_) x1 u1 + , loadIfUsed (from .^ closureField2_) x2 u2 + ] + ((x,u):xs) -> do d <- freshIdent + return $ mconcat + [ loadIfUsed (from .^ closureField1_) x u + , mconcat [ d ||= from .^ closureField2_ + , loadConVarsIfUsed (Var d) xs + ] + ] + where + use = repeat True -- fixme clean up + + loadIfUsed fr tgt True = tgt ||= fr + loadIfUsed _ _ _ = mempty + + loadConVarsIfUsed fr cs = mconcat $ zipWith f cs [(1::Int)..] + where f (x,u) n = loadIfUsed (SelExpr fr (name (dataFieldName n))) x u + +-- | Determine if a branch will end in a continuation or not. If not the inline +-- branch must be normalized. See 'normalizeBranches' +-- NB. not a Monoid +branchResult :: HasDebugCallStack => [ExprResult] -> ExprResult +branchResult = \case + [] -> panic "branchResult: empty list" + [e] -> e + (ExprCont:_) -> ExprCont + (_:es) + | elem ExprCont es -> ExprCont + | otherwise -> ExprInline + +-- | Push return arguments onto the stack. The 'Bool' tracks whether the value +-- is already on the stack or not, used in 'StgToJS.Stack.pushOptimized'. +pushRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> JStgExpr -> G JStgStat +pushRetArgs free fun = do + rs <- mapM (\(i,n,b) -> (\es->(es!!(n-1),b)) <$> genIdArg i) free + pushOptimized (rs++[(fun,False)]) + +-- | Load the return arguments then pop the stack frame +loadRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> G JStgStat +loadRetArgs free = do + ids <- mapM (\(i,n,_b) -> (!! (n-1)) <$> genIdStackArgI i) free + popSkipI 1 ids + +-- All identifiers referenced by the expression (does not traverse into nested functions) +allVars :: JStgExpr -> [Ident] +allVars (ValExpr v) = case v of + (JVar i) -> [i] + (JList xs) -> concatMap allVars xs + (JHash xs) -> concatMap (allVars . snd) (UM.nonDetUniqMapToList xs) + (JInt {}) -> [] + (JDouble {}) -> [] + (JStr {}) -> [] + (JRegEx {}) -> [] + (JBool {}) -> [] + (JFunc is _s) -> is +allVars (InfixExpr _op lh rh) = allVars lh ++ allVars rh +allVars (ApplExpr f xs) = allVars f ++ concatMap allVars xs +allVars (IfExpr c t e) = allVars c ++ allVars t ++ allVars e +allVars (UOpExpr _op x) = allVars x +allVars (SelExpr e _) = allVars e +allVars (IdxExpr e i) = allVars e ++ allVars i + +-- | allocate multiple, possibly mutually recursive, closures +allocDynAll :: Bool -> Maybe JStgStat -> [(Ident,JStgExpr,[JStgExpr],CostCentreStack)] -> G JStgStat +allocDynAll haveDecl middle [(to,entry,free,cc)] + | isNothing middle && to `notElem` concatMap allVars free = do + ccs <- ccsVarJ cc + s <- getSettings + return $ allocDynamic s (not haveDecl) to entry free ccs +allocDynAll haveDecl middle cls = do + settings <- getSettings + let + middle' :: JStgStat + middle' = fromMaybe mempty middle + + decl_maybe i e + | haveDecl = toJExpr i |= e + | otherwise = i ||= e + + makeObjs :: G JStgStat + makeObjs = + fmap mconcat $ forM cls $ \(i,f,_,cc) -> do + ccs <- maybeToList <$> costCentreStackLbl cc + pure $ mconcat + [ decl_maybe i $ if csInlineAlloc settings + then ValExpr (jhFromList $ [ (closureInfo_ , f) + , (closureField1_, null_) + , (closureField2_, null_) + , (closureMeta_ , zero_) + ] + ++ fmap (\cid -> ("cc", ValExpr (JVar cid))) ccs) + else ApplExpr hdC (f : fmap (ValExpr . JVar) ccs) + ] + + fillObjs :: [JStgStat] + fillObjs = map fillObj cls + fillObj (ident,_,es,_) = + let i = toJExpr ident + in case es of + [] -> mempty + [ex] -> closureField1 i |= ex + [e1,e2] -> mconcat + [ closureField1 i |= e1 + , closureField2 i |= e2 + ] + (ex:es) + | csInlineAlloc settings || length es > 24 + -> mconcat [ closureField1 i |= ex + , closureField2 i |= ValExpr (jhFromList (zip (map dataFieldName [1..]) es)) + ] + + | otherwise + -> mconcat [ closureField1 i |= ex + , closureField2 i |= ApplExpr (allocData (length es)) es + ] + + checkObjs :: [JStgStat] + checkObjs | csAssertRts settings = + map (\(i,_,_,_) -> ApplStat hdCheckObj [Var i]) cls + | otherwise = mempty + + objs <- makeObjs + return $ mconcat [objs, middle', mconcat fillObjs, mconcat checkObjs] + +-- | Generate a primop. This function wraps around the real generator +-- 'GHC.StgToJS.genPrim', handling the 'ExprCtx' and all arguments before +-- generating the primop. +genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStgStat, ExprResult) +genPrimOp ctx op args t = do + as <- concatMapM genArg args + prof <- csProf <$> getSettings + bound <- csBoundsCheck <$> getSettings + let prim_gen = withTag "h$PRM" $ genPrim prof bound t op (concatMap typex_expr $ ctxTarget ctx) as + -- fixme: should we preserve/check the primreps? + jsm <- liftIO initJSM + return $ case runJSM jsm prim_gen of + PrimInline s -> (s, ExprInline) + PRPrimCall s -> (s, ExprCont) diff --git a/GHC/StgToJS/ExprCtx.hs b/GHC/StgToJS/ExprCtx.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/ExprCtx.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.ExprCtx +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- TODO: Write my description! +----------------------------------------------------------------------------- + +module GHC.StgToJS.ExprCtx + ( ExprCtx + , initExprCtx + , ctxIsEvaluated + , ctxSetSrcSpan + , ctxSrcSpan + , ctxSetTop + , ctxTarget + , ctxSetTarget + -- * Let-no-escape + , ctxClearLneFrame + , ctxUpdateLneFrame + , ctxLneFrameVars + , ctxLneFrameSize + , ctxIsLneBinding + , ctxIsLneLiveVar + , ctxLneBindingStackSize + , ctxLneShrinkStack + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types + +import GHC.Types.Unique.FM +import GHC.Types.Var +import GHC.Types.SrcLoc +import GHC.Types.Id +import GHC.Types.Id.Info + +import GHC.Stg.EnforceEpt.TagSig + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Maybe + + +-- | Context into which an expression is evaluated +data ExprCtx = ExprCtx + { ctxTop :: Id + -- ^ Top-level binding Id + + , ctxTarget :: [TypedExpr] + -- ^ Target variables for the evaluated expression + + , ctxSrcSpan :: Maybe RealSrcSpan + -- ^ Source location + + ---------------------------- + -- Handling of let-no-escape + + , ctxLneFrameBs :: UniqFM Id Int + -- ^ LNE bindings with their expected stack size. + -- + -- The Int is the size of the stack when the LNE binding was defined. + -- We need to shrink the stack back to this size when we enter one of the + -- associated binder rhs: it expects its free variables at certain offsets + -- in the stack. + + , ctxLneFrameVars :: [(Id,Int)] + -- ^ Contents of current LNE frame + -- + -- Variables and their index on the stack + + , ctxLneFrameSize :: {-# UNPACK #-} !Int + -- ^ Cache the length of `ctxLneFrameVars` + + } + +instance Outputable ExprCtx where + ppr g = hang (text "ExprCtx") 2 $ vcat + [ hcat [text "ctxTop: ", ppr (ctxTop g)] + , hcat [text "ctxTarget:", ppr (ctxTarget g)] + , hcat [text "ctxSrcSpan:", ppr (ctxSrcSpan g)] + , hcat [text "ctxLneFrameBs:", ppr (ctxLneFrameBs g)] + , hcat [text "ctxLneFrameVars:", ppr (ctxLneFrameVars g)] + , hcat [text "ctxLneFrameSize:", ppr (ctxLneFrameSize g)] + ] + +-- | Initialize an expression context in the context of the given top-level +-- binding Id +initExprCtx :: Id -> ExprCtx +initExprCtx i = ExprCtx + { ctxTop = i + , ctxTarget = [] + , ctxLneFrameBs = emptyUFM + , ctxLneFrameVars = [] + , ctxLneFrameSize = 0 + , ctxSrcSpan = Nothing + } + +-- | Set target +ctxSetTarget :: [TypedExpr] -> ExprCtx -> ExprCtx +ctxSetTarget t ctx = ctx { ctxTarget = t } + +-- | Set top-level binding Id +ctxSetTop :: Id -> ExprCtx -> ExprCtx +ctxSetTop i ctx = ctx { ctxTop = i } + +-- | Set source location +ctxSetSrcSpan :: RealSrcSpan -> ExprCtx -> ExprCtx +ctxSetSrcSpan span ctx = ctx { ctxSrcSpan = Just span } + +-- | Update let-no-escape frame +ctxUpdateLneFrame :: [(Id,Int)] -> [Id] -> ExprCtx -> ExprCtx +ctxUpdateLneFrame new_spilled_vars new_lne_ids ctx = + let old_frame_size = ctxLneFrameSize ctx + new_frame_size = old_frame_size + length new_spilled_vars + in ctx + { ctxLneFrameBs = addListToUFM (ctxLneFrameBs ctx) (map (,new_frame_size) new_lne_ids) + , ctxLneFrameSize = new_frame_size + , ctxLneFrameVars = ctxLneFrameVars ctx ++ new_spilled_vars + } + +-- | Remove information about the current LNE frame +ctxClearLneFrame :: ExprCtx -> ExprCtx +ctxClearLneFrame ctx = + ctx + { ctxLneFrameBs = emptyUFM + , ctxLneFrameVars = [] + , ctxLneFrameSize = 0 + } + +-- | Predicate: do we know for sure that the given Id is evaluated? +ctxIsEvaluated :: Id -> Bool +ctxIsEvaluated i = + maybe False isTaggedSig (idTagSig_maybe i) + && go (idDetails i) + where + go JoinId{} = False + go _ = True + + + -- DFunId new_type -> not new_type + -- -- DFuns terminate, unless the dict is implemented + -- -- with a newtype in which case they may not + + -- DataConWorkId {} -> True + + -- ClassOpId {} -> False + -- -- suppose an argument, and we don't have one + + -- PrimOpId op _ -> primop_ok op + -- -- probably already handled by StgOpApp + + -- JoinId {} -> False + -- -- Don't speculate join points + + -- TickBoxOpId {} -> False + -- -- Don't speculate box ticking + + -- -- Tagged (evaluated) ids + -- _ | Just sig <- idTagSig_maybe i + -- , isTaggedSig sig + -- -> True + + -- _ -> False + +-- | Does the given Id correspond to a LNE binding +ctxIsLneBinding :: ExprCtx -> Id -> Bool +ctxIsLneBinding ctx i = isJust (ctxLneBindingStackSize ctx i) + +-- | Does the given Id correspond to a LNE live var on the stack +ctxIsLneLiveVar :: ExprCtx -> Id -> Bool +ctxIsLneLiveVar ctx i = i `elem` map fst (ctxLneFrameVars ctx) + +-- | Return the LNE stack size associated to the given Id. +-- Return Nothing when the Id doesn't correspond to a LNE binding. +ctxLneBindingStackSize :: ExprCtx -> Id -> Maybe Int +ctxLneBindingStackSize ctx i = lookupUFM (ctxLneFrameBs ctx) i + +-- | Shrink the LNE stack to the given size +ctxLneShrinkStack :: ExprCtx -> Int -> ExprCtx +ctxLneShrinkStack ctx n = + let l = ctxLneFrameSize ctx + in assertPpr + (l >= n) + (vcat [ text "ctxLneShrinkStack: let-no-escape stack too short:" + , ppr l + , text " < " + , ppr n + ]) + (ctx { ctxLneFrameVars = take n (ctxLneFrameVars ctx) + , ctxLneFrameSize = n + } + ) diff --git a/GHC/StgToJS/FFI.hs b/GHC/StgToJS/FFI.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/FFI.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.FFI + ( genPrimCall + , genForeignCall + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Arg +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Ids +import GHC.StgToJS.Literal +import GHC.StgToJS.Monad +import GHC.StgToJS.Regs +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types +import GHC.StgToJS.Utils + +import GHC.Types.RepType +import GHC.Types.ForeignCall +import GHC.Types.Unique.Map + +import GHC.Stg.Syntax + +import GHC.Builtin.PrimOps +import GHC.Builtin.Types.Prim + +import GHC.Core.Type hiding (typeSize) + +import GHC.Utils.Misc +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) +import GHC.Data.FastString + +import Data.Char +import Data.Monoid +import qualified Data.List as L + +genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStgStat, ExprResult) +genPrimCall ctx (PrimCall lbl _) args t = do + j <- parseFFIPattern False False False (unpackFS hdStr ++ unpackFS lbl) t (concatMap typex_expr $ ctxTarget ctx) args + return (j, ExprInline) + +-- | generate the actual call +{- + parse FFI patterns: + "&value -> value + 1. "function" -> ret = function(...) + 2. "$r = $1.f($2) -> r1 = a1.f(a2) + + arguments, $1, $2, $3 unary arguments + $1_1, $1_2, for a binary argument + + return type examples + 1. $r unary return + 2. $r1, $r2 binary return + 3. $r1, $r2, $r3_1, $r3_2 unboxed tuple return + -} +parseFFIPattern :: Bool -- ^ catch exception and convert them to haskell exceptions + -> Bool -- ^ async (only valid with javascript calling conv) + -> Bool -- ^ using javascript calling convention + -> String + -> Type + -> [JStgExpr] + -> [StgArg] + -> G JStgStat +parseFFIPattern catchExcep async jscc pat t es as + | catchExcep = do + c <- parseFFIPatternA async jscc pat t es as + -- Generate: + -- try { + -- `c`; + -- } catch(except) { + -- return h$throwJSException(except); + -- } + return (TryStat c exceptStr (ReturnStat (ApplExpr hdThrowJSException [except])) mempty) + | otherwise = parseFFIPatternA async jscc pat t es as + +parseFFIPatternA :: Bool -- ^ async + -> Bool -- ^ using JavaScript calling conv + -> String + -> Type + -> [JStgExpr] + -> [StgArg] + -> G JStgStat +-- async calls get an extra callback argument +-- call it with the result +parseFFIPatternA True True pat t es as = do + cb <- freshIdent + x <- freshIdent + d <- freshIdent + stat <- parseFFIPattern' (Just (toJExpr cb)) True pat t es as + return $ mconcat + [ x ||= (toJExpr (jhFromList [(mv, null_)])) + , cb ||= ApplExpr hdMkForeignCallback [toJExpr x] + , stat + , IfStat (InfixExpr StrictEqOp (toJExpr x .^ mv) null_) + (mconcat + [ toJExpr x .^ mv |= UOpExpr NewOp (ApplExpr hdMVar []) + , sp |= Add sp one_ + , (IdxExpr stack sp) |= hdUnboxFFIResult + , ReturnStat $ ApplExpr hdTakeMVar [toJExpr x .^ mv] + ]) + (mconcat + [ d ||= toJExpr x .^ mv + , copyResult (toJExpr d) + ]) + ] + where nrst = typeSize t + copyResult d = assignAllEqual es (map (IdxExpr d . toJExpr) [0..nrst-1]) +parseFFIPatternA _async javascriptCc pat t es as = + parseFFIPattern' Nothing javascriptCc pat t es as + +-- parseFFIPatternA _ _ _ _ _ _ = error "parseFFIPattern: non-JavaScript pattern must be synchronous" + +parseFFIPattern' :: Maybe JStgExpr -- ^ Nothing for sync, Just callback for async + -> Bool -- ^ javascript calling convention used + -> String -- ^ pattern called + -> Type -- ^ return type + -> [JStgExpr] -- ^ expressions to return in (may be more than necessary) + -> [StgArg] -- ^ arguments + -> G JStgStat +parseFFIPattern' callback javascriptCc pat t ret args + | not javascriptCc = mkApply pat + | otherwise = mkApply pat + where + tgt = take (typeSize t) ret + -- automatic apply, build call and result copy + mkApply f + | Just cb <- callback = do + (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args + cs <- getSettings + return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as++[cb]) + | {-ts@-} + (t:ts') <- tgt = do + (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args + cs <- getSettings + return $ traceCall cs as + <> mconcat stats + <> (t |= ApplExpr f' (concat as) ) + <> copyResult ts' + -- _ -> error "mkApply: empty list" + | otherwise = do + (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args + cs <- getSettings + return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as) + where f' = toJExpr (global $ mkFastString f) + copyResult rs = mconcat $ zipWith (\t r -> toJExpr r |= toJExpr t) (enumFrom Ret1) rs + + traceCall cs as + | csTraceForeign cs = ApplStat hdTraceForeign [toJExpr pat, toJExpr as] + | otherwise = mempty + +-- generate arg to be passed to FFI call, with marshalling JStgStat to be run +-- before the call +genFFIArg :: Bool -> StgArg -> G (JStgStat, [JStgExpr]) +genFFIArg _isJavaScriptCc (StgLitArg l) = (mempty,) <$> genLit l +genFFIArg isJavaScriptCc a@(StgVarArg i) + | not isJavaScriptCc && + (tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon) = + (\x -> (mempty,[x, zero_])) <$> varForId i + | isVoid r = return (mempty, []) +-- | Just x <- marshalFFIArg a = x + | isMultiVar r = (mempty,) <$> mapM (varForIdN i) [1..varSize r] + | otherwise = (\x -> (mempty,[x])) <$> varForId i + where + tycon = tyConAppTyCon (unwrapType arg_ty) + arg_ty = stgArgType a + r = unaryTypeJSRep arg_ty + +genForeignCall :: HasDebugCallStack + => ExprCtx + -> ForeignCall + -> Type + -> [JStgExpr] + -> [StgArg] + -> G (JStgStat, ExprResult) +genForeignCall _ctx + (CCall (CCallSpec (StaticTarget _ tgt Nothing True) + JavaScriptCallConv + PlayRisky)) + _t + [obj] + args + | tgt == hdBuildObjectStr + , Just pairs <- getObjectKeyValuePairs args = do + pairs' <- mapM (\(k,v) -> genArg v >>= \vs -> return (k, head vs)) pairs + return ( (|=) obj (ValExpr (JHash $ listToUniqMap pairs')) + , ExprInline + ) + +genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do + emitForeign (ctxSrcSpan ctx) lbl safety cconv (map showArgType args) (showType t) + (,exprResult) <$> parseFFIPattern catchExcep async isJsCc (unpackFS lbl) t tgt' args + where + isJsCc = cconv == JavaScriptCallConv + + lbl | (StaticTarget _ clbl _mpkg _isFunPtr) <- ccTarget + = let clbl' = unpackFS clbl + hDollarS = unpackFS hdStr + in if | isJsCc -> clbl + | wrapperPrefix `L.isPrefixOf` clbl' -> + mkFastString (hDollarS ++ (drop 2 $ dropWhile isDigit $ drop (length wrapperPrefix) clbl')) + | otherwise -> mkFastString $ hDollarS ++ clbl' + | otherwise = hdCallDynamicStr + + exprResult | async = ExprCont + | otherwise = ExprInline + + catchExcep = (cconv == JavaScriptCallConv) && + playSafe safety || playInterruptible safety + + async | isJsCc = playInterruptible safety + | otherwise = playInterruptible safety || playSafe safety + + tgt' | async = take (length tgt) jsRegsFromR1 + | otherwise = tgt + + wrapperPrefix = unpackFS wrapperColonStr + +getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)] +getObjectKeyValuePairs [] = Just [] +getObjectKeyValuePairs (k:v:xs) + | Just t <- argJSStringLitUnfolding k = + fmap ((t,v):) (getObjectKeyValuePairs xs) +getObjectKeyValuePairs _ = Nothing + +argJSStringLitUnfolding :: StgArg -> Maybe FastString +argJSStringLitUnfolding (StgVarArg _v) = Nothing -- fixme +argJSStringLitUnfolding _ = Nothing + +showArgType :: StgArg -> FastString +showArgType a = showType (stgArgType a) + +showType :: Type -> FastString +showType t + | Just tc <- tyConAppTyCon_maybe (unwrapType t) = + mkFastString (renderWithContext defaultSDocContext (ppr tc)) + | otherwise = unknown diff --git a/GHC/StgToJS/Heap.hs b/GHC/StgToJS/Heap.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Heap.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Heap + ( closureType + , infoClosureType + , infoFunArity + , isObject + , isThunk + , isThunk' + , isBlackhole + , isFun + , isFun' + , isPap + , isPap' + , isCon + , isCon' + , conTag + , conTag' + , closureInfo + , closureMeta + , closureField1 + , closureField2 + , closureCC + , funArity + , papArity + , funOrPapArity + -- * Field names + , closureInfo_ + , closureMeta_ + , closureCC_ + , closureField1_ + , closureField2_ + -- * Javascript Type literals + , jTyObject + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.Make +import GHC.StgToJS.Types +import GHC.Data.FastString + +-- | Closure infotable field name +closureInfo_ :: FastString +closureInfo_ = "f" + +-- | Closure first payload field name +closureField1_ :: FastString +closureField1_ = "d1" + +-- | Closure second payload field name +closureField2_ :: FastString +closureField2_ = "d2" + +-- | Closure meta field name +closureMeta_ :: FastString +closureMeta_ = "m" + +-- | Closure cost-center field name +closureCC_ :: FastString +closureCC_ = "cc" + +-- | Infotable type field name +infoClosureType_ :: FastString +infoClosureType_ = "t" + +-- | Infotable tag field name +infoConTag_ :: FastString +infoConTag_ = "a" + +-- | Infotable arity field name +infoFunArity_ :: FastString +infoFunArity_ = "a" + +jTyObject :: JStgExpr +jTyObject = jString "object" + +-- | Closure type from infotable +infoClosureType :: JStgExpr -> JStgExpr +infoClosureType f = f .^ infoClosureType_ + +-- | Function arity from infotable +infoFunArity :: JStgExpr -> JStgExpr +infoFunArity f = f .^ infoFunArity_ + +closureType :: JStgExpr -> JStgExpr +closureType = infoClosureType . closureInfo + +isObject :: JStgExpr -> JStgExpr +isObject c = typeOf c .===. String "object" + +isThunk :: JStgExpr -> JStgExpr +isThunk c = closureType c .===. toJExpr Thunk + +isThunk' :: JStgExpr -> JStgExpr +isThunk' f = infoClosureType f .===. toJExpr Thunk + +isBlackhole :: JStgExpr -> JStgExpr +isBlackhole c = closureType c .===. toJExpr Blackhole + +isFun :: JStgExpr -> JStgExpr +isFun c = closureType c .===. toJExpr Fun + +isFun' :: JStgExpr -> JStgExpr +isFun' f = infoClosureType f .===. toJExpr Fun + +isPap :: JStgExpr -> JStgExpr +isPap c = closureType c .===. toJExpr Pap + +isPap' :: JStgExpr -> JStgExpr +isPap' f = infoClosureType f .===. toJExpr Pap + +isCon :: JStgExpr -> JStgExpr +isCon c = closureType c .===. toJExpr Con + +isCon' :: JStgExpr -> JStgExpr +isCon' f = infoClosureType f .===. toJExpr Con + +conTag :: JStgExpr -> JStgExpr +conTag = conTag' . closureInfo + +conTag' :: JStgExpr -> JStgExpr +conTag' f = f .^ infoConTag_ + +-- | Get closure infotable +closureInfo :: JStgExpr -> JStgExpr +closureInfo p = p .^ closureInfo_ + +-- | Get closure metadata +closureMeta :: JStgExpr -> JStgExpr +closureMeta p = p .^ closureMeta_ + +-- | Get closure cost-center +closureCC :: JStgExpr -> JStgExpr +closureCC p = p .^ closureCC_ + +-- | Get closure extra field 1 +closureField1 :: JStgExpr -> JStgExpr +closureField1 p = p .^ closureField1_ + +-- | Get closure extra field 2 +closureField2 :: JStgExpr -> JStgExpr +closureField2 p = p .^ closureField2_ + +-- | Number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers) +funArity :: JStgExpr -> JStgExpr +funArity = infoFunArity . closureInfo + +-- arity of a partial application +papArity :: JStgExpr -> JStgExpr +papArity cp = closureField1 (closureField2 cp) + +funOrPapArity + :: JStgExpr -- ^ heap object + -> Maybe JStgExpr -- ^ reference to infotable, if you have one already (saves a c.f lookup twice) + -> JStgExpr -- ^ arity tag (tag >> 8 = registers, tag & 0xff = arguments) +funOrPapArity c = \case + Nothing -> ((IfExpr (toJExpr (isFun c))) (toJExpr (funArity c))) + (toJExpr (papArity c)) + Just f -> ((IfExpr (toJExpr (isFun' f))) (toJExpr (infoFunArity f))) + (toJExpr (papArity c)) diff --git a/GHC/StgToJS/Ids.hs b/GHC/StgToJS/Ids.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Ids.hs @@ -0,0 +1,238 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Ids +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- Module to deal with JS identifiers +----------------------------------------------------------------------------- + +module GHC.StgToJS.Ids + ( freshUnique + , freshIdent + , makeIdentForId + , cachedIdentForId + -- * Helpers for Idents + , identForId + , identForIdN + , identsForId + , identForEntryId + , identForDataConEntryId + , identForDataConWorker + -- * Helpers for variables + , varForId + , varForIdN + , varsForId + , varForEntryId + , varForDataConEntryId + , varForDataConWorker + , declVarsForId + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Utils +import GHC.StgToJS.Symbols + +import GHC.JS.JStg.Syntax +import GHC.JS.Ident +import GHC.JS.Make + +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import Control.Monad +import Control.Monad.IO.Class +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.Map as M +import Data.Maybe +import qualified Data.ByteString.Char8 as BSC + +-- | Get fresh unique number +freshUnique :: G Int +freshUnique = do + id_gen <- State.gets gsId + liftIO $ do + -- no need for atomicFetchAdd as we don't use threads in G + v <- readFastMutInt id_gen + writeFastMutInt id_gen (v+1) + pure v + +-- | Get fresh module-local Ident of the form: h$$unit:module_uniq +freshIdent :: G Ident +freshIdent = do + i <- freshUnique + mod <- State.gets gsModule + let !sym_name = mkFreshJsSymbol mod i + return (name sym_name) + +-- | Generate unique Ident for the given ID (uncached!) +-- +-- The ident has the following forms: +-- +-- global Id: h$unit:module.name[_num][_type_suffix] +-- local Id: h$$unit:module.name[_num][_type_suffix]_uniq +-- +-- Note that the string is z-encoded except for "_" delimiters. +-- +-- Optional "_type_suffix" can be: +-- - "_e" for IdEntry +-- - "_con_e" for IdConEntry +-- +-- Optional "_num" is passed as an argument to this function. It is used for +-- Haskell Ids that require several JS variables: e.g. 64-bit numbers (Word64#, +-- Int64#), Addr#, StablePtr#, unboxed tuples, etc. +-- +makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident +makeIdentForId i num id_type current_module = name ident + where + exported = isExportedId i + name' = getName i + mod + | exported + , Just m <- nameModule_maybe name' + = m + | otherwise + = current_module + + !ident = mkFastStringByteString $ mconcat + [ mkJsSymbolBS exported mod (occNameMangledFS (nameOccName name')) + + ------------- + -- suffixes + + -- suffix for Ids represented with more than one JS var ("_0", "_1", etc.) + , case num of + Nothing -> mempty + Just v -> mconcat [BSC.pack "_", intBS v] + + -- suffix for entry and constructor entry + , case id_type of + IdPlain -> mempty + IdEntry -> BSC.pack "_e" + IdConEntry -> BSC.pack "_con_e" + + -- unique suffix for non-exported Ids + , if exported + then mempty + else let (c,u) = unpkUnique (getUnique i) + in mconcat [BSC.pack ['_',c,'_'], word64BS u] + ] + +-- | Retrieve the cached Ident for the given Id if there is one. Otherwise make +-- a new one with 'makeIdentForId' and cache it. +cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident +cachedIdentForId i mi id_type = do + + -- compute key + let !key = IdKey (getKey . getUnique $ i) (fromMaybe 0 mi) id_type + + -- lookup Ident in the Ident cache + IdCache cache <- State.gets gsIdents + ident <- case M.lookup key cache of + Just ident -> pure ident + Nothing -> do + mod <- State.gets gsModule + let !ident = makeIdentForId i mi id_type mod + let !cache' = IdCache (M.insert key ident cache) + State.modify (\s -> s { gsIdents = cache' }) + pure ident + + -- Now update the GlobalId cache, if required + + let update_global_cache = isGlobalId i && id_type == IdPlain + -- fixme also allow caching entries for lifting? + + when (update_global_cache) $ do + GlobalIdCache gidc <- getGlobalIdCache + case elemUFM ident gidc of + False -> setGlobalIdCache $ GlobalIdCache (addToUFM gidc ident (key, i)) + True -> pure () + + pure ident + +-- | Retrieve default Ident for the given Id +identForId :: Id -> G Ident +identForId i = cachedIdentForId i Nothing IdPlain + +-- | Retrieve default Ident for the given Id with sub index +-- +-- Some types, Word64, Addr#, unboxed tuple have more than one corresponding JS +-- var, hence we use the sub index to identify each subpart / JS variable. +identForIdN :: Id -> Int -> G Ident +identForIdN i n = cachedIdentForId i (Just n) IdPlain + +-- | Retrieve all the idents for the given Id. +identsForId :: Id -> G [Ident] +identsForId i = case typeSize (idType i) of + 0 -> pure mempty + 1 -> (:[]) <$> identForId i + s -> mapM (identForIdN i) [1..s] + + +-- | Retrieve entry Ident for the given Id +identForEntryId :: Id -> G Ident +identForEntryId i = cachedIdentForId i Nothing IdEntry + +-- | Retrieve datacon entry Ident for the given Id +-- +-- Different name than the datacon wrapper. +identForDataConEntryId :: Id -> G Ident +identForDataConEntryId i = cachedIdentForId i Nothing IdConEntry + + +-- | Retrieve default variable name for the given Id +varForId :: Id -> G JStgExpr +varForId i = toJExpr <$> identForId i + +-- | Retrieve default variable name for the given Id with sub index +varForIdN :: Id -> Int -> G JStgExpr +varForIdN i n = toJExpr <$> identForIdN i n + +-- | Retrieve all the JS vars for the given Id +varsForId :: Id -> G [JStgExpr] +varsForId i = case typeSize (idType i) of + 0 -> pure mempty + 1 -> (:[]) <$> varForId i + s -> mapM (varForIdN i) [1..s] + + +-- | Retrieve entry variable name for the given Id +varForEntryId :: Id -> G JStgExpr +varForEntryId i = toJExpr <$> identForEntryId i + +-- | Retrieve datacon entry variable name for the given Id +varForDataConEntryId :: Id -> G JStgExpr +varForDataConEntryId i = ValExpr . JVar <$> identForDataConEntryId i + + +-- | Retrieve datacon worker entry variable name for the given datacon +identForDataConWorker :: DataCon -> G Ident +identForDataConWorker d = identForDataConEntryId (dataConWorkId d) + +-- | Retrieve datacon worker entry variable name for the given datacon +varForDataConWorker :: DataCon -> G JStgExpr +varForDataConWorker d = varForDataConEntryId (dataConWorkId d) + +-- | Declare all js vars for the id +declVarsForId :: Id -> G JStgStat +declVarsForId i = case typeSize (idType i) of + 0 -> return mempty + 1 -> decl <$> identForId i + s -> mconcat <$> mapM (\n -> decl <$> identForIdN i n) [1..s] + diff --git a/GHC/StgToJS/Linker/Linker.hs b/GHC/StgToJS/Linker/Linker.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Linker/Linker.hs @@ -0,0 +1,1294 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Linker +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- GHCJS linker, collects dependencies from the object files +-- which contain linkable units with dependency information +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Linker.Linker + ( jsLinkBinary + , jsLink + , embedJsFile + , mkExportedFuns + , mkExportedModFuns + , computeLinkDependencies + , LinkSpec (..) + , LinkPlan (..) + , emptyLinkPlan + , incrementLinkPlan + , ArchiveCache + , newArchiveCache + ) +where + +import GHC.Prelude + +import GHC.Platform.Host (hostPlatformArchOS) + +import GHC.JS.Make +import GHC.JS.Optimizer +import GHC.JS.Ident +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import qualified GHC.JS.Syntax as JS +import GHC.JS.Transform + +import GHC.Driver.DynFlags (DynFlags(..)) +import Language.Haskell.Syntax.Module.Name +import GHC.SysTools.Cpp +import GHC.SysTools + +import GHC.Linker.Static.Utils (exeFileName) +import GHC.Linker.Types (linkableObjs) +import GHC.Linker.External + +import GHC.StgToJS.Linker.Types +import GHC.StgToJS.Linker.Utils +import GHC.StgToJS.Linker.Opt +import GHC.StgToJS.Rts.Rts +import GHC.StgToJS.Object +import GHC.StgToJS.Types hiding (LinkableUnit) +import GHC.StgToJS.Symbols +import GHC.StgToJS.Arg +import GHC.StgToJS.Closure + +import GHC.Unit.State +import GHC.Unit.Env +import GHC.Unit.Home.ModInfo +import GHC.Unit.Types +import GHC.Unit.Module (moduleStableString) + +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.BufHandle +import GHC.Utils.Panic +import GHC.Utils.Error +import GHC.Utils.Logger (Logger, logVerbAtLeast) +import GHC.Utils.Binary +import qualified GHC.Utils.Ppr as Ppr +import GHC.Utils.TmpFs + +import GHC.Types.Unique.Set + +import qualified GHC.SysTools.Ar as Ar + +import qualified GHC.Data.ShortText as ST +import GHC.Data.FastString + +import Control.Monad + +import Data.Array +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as BS +import Data.Function (on) +import qualified Data.IntSet as IS +import Data.IORef +import Data.List ( nub, intercalate, groupBy, intersperse ) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S +import Data.Word +import Data.Monoid + +import System.IO +import System.FilePath ((<.>), (), dropExtension, takeDirectory) +import System.Directory ( createDirectoryIfMissing + , doesFileExist + , getCurrentDirectory + , Permissions(..) + , setPermissions + , getPermissions + ) + +import GHC.Unit.Finder.Types +import GHC.Unit.Finder (findObjectLinkableMaybe, findHomeModule) +import GHC.Driver.Config.Finder (initFinderOpts) +import qualified GHC.Unit.Home.Graph as HUG + +data LinkerStats = LinkerStats + { bytesPerModule :: !(Map Module Word64) -- ^ number of bytes linked per module + , packedMetaDataSize :: !Word64 -- ^ number of bytes for metadata + } + +newtype ArchiveCache = ArchiveCache { loadedArchives :: IORef (Map FilePath Ar.Archive) } + +newArchiveCache :: IO ArchiveCache +newArchiveCache = ArchiveCache <$> newIORef M.empty + +defaultJsContext :: SDocContext +defaultJsContext = defaultSDocContext{sdocStyle = PprCode} + +jsLinkBinary + :: FinderCache + -> JSLinkConfig + -> StgToJSConfig + -> Logger + -> TmpFs + -> DynFlags + -> UnitEnv + -> [FilePath] + -> [UnitId] + -> IO () +jsLinkBinary finder_cache lc_cfg cfg logger tmpfs dflags unit_env hs_objs dep_units + | lcNoJSExecutables lc_cfg = return () + | otherwise = do + + -- additional objects to link are passed as FileOption ldInputs... + let cmdline_objs = [ f | FileOption _ f <- ldInputs dflags ] + + -- cmdline objects: discriminate between the 3 kinds of objects we have + let disc hss jss ccs = \case + [] -> pure (hss, jss, ccs) + (o:os) -> getObjectKind o >>= \case + Just ObjHs -> disc (o:hss) jss ccs os + Just ObjJs -> disc hss (o:jss) ccs os + Just ObjCc -> disc hss jss (o:ccs) os + Nothing -> do + logInfo logger (vcat [text "Ignoring unexpected command-line object: ", text o]) + disc hss jss ccs os + (cmdline_hs_objs, cmdline_js_objs, cmdline_cc_objs) <- disc [] [] [] cmdline_objs + + let + exe = jsExeFileName dflags + all_hs_objs = hs_objs ++ cmdline_hs_objs + all_js_objs = cmdline_js_objs + all_cc_objs = cmdline_cc_objs + is_root _ = True + -- FIXME: we shouldn't consider every function as a root, + -- but only the program entry point (main), either the + -- generated one or coming from an object + + -- compute dependencies + let link_spec = LinkSpec + { lks_unit_ids = dep_units + , lks_obj_root_filter = is_root + , lks_extra_roots = mempty + , lks_objs_hs = all_hs_objs + , lks_objs_js = all_js_objs + , lks_objs_cc = all_cc_objs + } + + let finder_opts = initFinderOpts dflags + ar_cache <- newArchiveCache + + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache + + void $ jsLink lc_cfg cfg logger tmpfs ar_cache exe link_plan + +-- | link and write result to disk (jsexe directory) +jsLink + :: JSLinkConfig + -> StgToJSConfig + -> Logger + -> TmpFs + -> ArchiveCache + -> FilePath -- ^ output file/directory + -> LinkPlan + -> IO () +jsLink lc_cfg cfg logger tmpfs ar_cache out link_plan = do + + -- create output directory + createDirectoryIfMissing False out + + when (logVerbAtLeast logger 2) $ + logInfo logger $ hang (text "jsLink:") 2 (ppr link_plan) + + ------------------------------------------------------------- + -- link all Haskell code (program + dependencies) into out.js + + -- retrieve code for Haskell dependencies + mods <- collectModuleCodes ar_cache link_plan + + -- LTO + rendering of JS code + link_stats <- withBinaryFile (out "out.js") WriteMode $ \h -> + renderModules h (csPrettyRender cfg) mods + + ------------------------------------------------------------- + + -- dump foreign references file (.frefs) + when (lcForeignRefs lc_cfg) $ do + let frefsFile = "out.frefs" + -- frefs = concatMap mc_frefs mods + jsonFrefs = mempty -- FIXME: toJson frefs + + BL.writeFile (out frefsFile <.> "json") jsonFrefs + BL.writeFile (out frefsFile <.> "js") + ("h$checkForeignRefs(" <> jsonFrefs <> ");") + + -- dump stats + unless (lcNoStats lc_cfg) $ do + let statsFile = "out.stats" + writeFile (out statsFile) (renderLinkerStats link_stats) + + -- link generated RTS parts into rts.js + unless (lcNoRts lc_cfg) $ do + jsm <- initJSM + withFile (out "rts.js") WriteMode $ \h -> do + let opt = jsOptimize (runJSM jsm $ jStgStatToJS <$> rts cfg) + void $ + hPutJS (csPrettyRender cfg) h opt + + + -- link user-provided JS files into lib.js + (emcc_opts,lib_cc_objs) <- withBinaryFile (out "lib.js") WriteMode $ \h -> do + + let + tmp_dir = linkerTempDir (csLinkerConfig cfg) + + -- JS objects from dependencies' archives (.a) + go_archives emcc_opts cc_objs = \case + [] -> pure (emcc_opts, cc_objs) + (a:as) -> do + Ar.Archive entries <- loadArchive ar_cache a + (emcc_opts', cc_objs') <- go_entries emcc_opts cc_objs entries + go_archives emcc_opts' cc_objs' as + + -- archive's entries + go_entries emcc_opts cc_objs = \case + [] -> pure (emcc_opts, cc_objs) + (e:es) -> case getObjectKindBS (Ar.filedata e) of + Just ObjHs -> do + -- Nothing to do. HS objects are collected in + -- collectModuleCodes + go_entries emcc_opts cc_objs es + Just ObjCc -> do + -- extract the object file from the archive in a temporary + -- file and return its path + cc_obj_fn <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "o" + B.writeFile cc_obj_fn (Ar.filedata e) + let cc_objs' = cc_obj_fn:cc_objs + go_entries emcc_opts cc_objs' es + Just ObjJs -> do + -- extract the JS code and append it to the `lib.js` file + (opts,bs) <- parseJSObjectBS (Ar.filedata e) + B.hPut h bs + hPutChar h '\n' + let emcc_opts' = emcc_opts <> opts + go_entries emcc_opts' cc_objs es + Nothing -> case Ar.filename e of + -- JavaScript code linker does not support symbol table processing. + -- Currently the linker does nothing when the symbol table is met. + -- Ar/Ranlib usually do not create a record for the symbol table + -- in the object archive when the table has no entries. + -- For JavaScript code it should not be created by default. + + "__.SYMDEF" -> + -- GNU Ar added the symbol table. + + -- Emscripten Ar (at least 3.1.24 version) + -- adds it even when the symbol table is empty. + go_entries emcc_opts cc_objs es + "__.SYMDEF SORTED" -> + -- BSD-like Ar added the symbol table. + + -- By default, Clang Ar does not add it when the + -- symbol table is empty (and it should be empty) but we left + -- it here to handle the case with symbol table completely + -- for GNU and BSD tools. + go_entries emcc_opts cc_objs es + unknown_name -> do + logInfo logger (vcat [text "Ignoring unexpected archive entry: ", text unknown_name]) + go_entries emcc_opts cc_objs es + + -- additional JS objects (e.g. from the command-line) + go_extra emcc_opts = \case + [] -> pure emcc_opts + (e:es) -> do + (opts,bs) <- readJSObject e + B.hPut h bs + hPutChar h '\n' + let emcc_opts' = emcc_opts <> opts + go_extra emcc_opts' es + + -- archives + (emcc_opts0, cc_objs) <- go_archives defaultJSOptions [] (S.toList (lkp_archives link_plan)) + -- extra object files + emcc_opts1 <- go_extra emcc_opts0 (S.toList (lkp_objs_js link_plan)) + pure (emcc_opts1,cc_objs) + + + -- Link Cc objects using emcc's linker + -- + -- Cc objects have been extracted from archives (see above) and are listed + -- in lib_cc_objs. + -- + -- We don't link C sources if there are none (obviously) or if asked + -- explicitly by the user with -ddisable-js-c-sources (mostly used for + -- debugging purpose). + let emcc_objs = lib_cc_objs ++ S.toList (lkp_objs_cc link_plan) + let has_emcc_objs = not (null emcc_objs) + let link_c_sources = lcLinkCsources lc_cfg && has_emcc_objs + + when link_c_sources $ do + + runLink logger tmpfs (csLinkerConfig cfg) $ + [ Option "-o" + , FileOption "" (out "clibs.js") + -- Embed wasm files into a single .js file + , Option "-sSINGLE_FILE=1" + -- Enable support for addFunction (callbacks) + , Option "-sALLOW_TABLE_GROWTH" + -- keep some RTS methods and functions (otherwise removed as dead + -- code) + , Option ("-sEXPORTED_RUNTIME_METHODS=" ++ concat (intersperse "," (emccExportedRuntimeMethods emcc_opts))) + , Option ("-sEXPORTED_FUNCTIONS=" ++ concat (intersperse "," (emccExportedFunctions emcc_opts))) + ] + -- pass extra options from JS files' pragmas + ++ map Option (emccExtraOptions emcc_opts) + -- link objects + ++ map (FileOption "") emcc_objs + + -- Don't enable the Emcc rts when not needed (i.e. no Wasm module to link + -- with) and not forced by the caller (e.g. in the future iserv may require + -- incremental linking of Wasm modules, hence the emcc rts even building + -- iserv itself doesn't require the emcc rts) + let use_emcc_rts = UseEmccRts $ link_c_sources || lcForceEmccRts lc_cfg + + + -- link everything together into a runnable all.js + -- only if we link a complete application, + -- no incremental linking and no skipped parts + when (lcCombineAll lc_cfg && not (lcNoRts lc_cfg)) $ do + writeRunMain out use_emcc_rts + _ <- combineFiles lc_cfg link_c_sources out + writeHtml out + writeRunner lc_cfg out + writeExterns out + +data LinkSpec = LinkSpec + { lks_unit_ids :: [UnitId] + , lks_obj_root_filter :: ExportedFun -> Bool -- ^ Predicate for exported functions in objects to declare as root + , lks_extra_roots :: Set ExportedFun -- ^ Extra root functions from loaded units + , lks_objs_hs :: [FilePath] -- ^ HS objects to link + , lks_objs_js :: [FilePath] -- ^ JS objects to link + , lks_objs_cc :: [FilePath] -- ^ Cc objects to link + } + +instance Outputable LinkSpec where + ppr s = hang (text "LinkSpec") 2 $ vcat + [ hcat [text "Unit ids: ", ppr (lks_unit_ids s)] + , hcat [text "HS objects:", vcat (fmap text (lks_objs_hs s))] + , hang (text "JS objects::") 2 (vcat (fmap text (lks_objs_js s))) + , hang (text "Cc objects::") 2 (vcat (fmap text (lks_objs_cc s))) + , text "Object root filter: " + , hcat [text "Extra roots: ", ppr (lks_extra_roots s)] + ] + +emptyLinkPlan :: LinkPlan +emptyLinkPlan = LinkPlan + { lkp_block_info = mempty + , lkp_dep_blocks = mempty + , lkp_archives = mempty + , lkp_objs_js = mempty + , lkp_objs_cc = mempty + } + +-- | Given a `base` link plan (assumed to be already linked) and a `new` link +-- plan, compute `(diff, total)` link plans. +-- +-- - `diff` is the incremental link plan to get from `base` to `total` +-- - `total` is the total link plan as if `base` and `new` were linked at once +incrementLinkPlan :: LinkPlan -> LinkPlan -> (LinkPlan, LinkPlan) +incrementLinkPlan base new = (diff,total) + where + total = LinkPlan + { lkp_block_info = M.union (lkp_block_info base) (lkp_block_info new) + , lkp_dep_blocks = S.union (lkp_dep_blocks base) (lkp_dep_blocks new) + , lkp_archives = S.union (lkp_archives base) (lkp_archives new) + , lkp_objs_js = S.union (lkp_objs_js base) (lkp_objs_js new) + , lkp_objs_cc = S.union (lkp_objs_cc base) (lkp_objs_cc new) + } + diff = LinkPlan + { lkp_block_info = lkp_block_info new -- block info from "new" contains all we need to load new blocks + , lkp_dep_blocks = S.difference (lkp_dep_blocks new) (lkp_dep_blocks base) + , lkp_archives = S.difference (lkp_archives new) (lkp_archives base) + , lkp_objs_js = S.difference (lkp_objs_js new) (lkp_objs_js base) + , lkp_objs_cc = S.difference (lkp_objs_cc new) (lkp_objs_cc base) + } + + +computeLinkDependencies + :: StgToJSConfig + -> UnitEnv + -> LinkSpec + -> FinderOpts + -> FinderCache + -> ArchiveCache + -> IO LinkPlan +computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache = do + + let units = lks_unit_ids link_spec + let hs_objs = lks_objs_hs link_spec + let js_objs = lks_objs_js link_spec + let cc_objs = lks_objs_cc link_spec + let extra_roots = lks_extra_roots link_spec + let obj_is_root = lks_obj_root_filter link_spec + + -- Process: + -- 1) Find new required linkables (object files, libraries, etc.) for all + -- transitive dependencies + -- 2) Load ObjBlockInfo from them and cache them + -- 3) Compute ObjBlock dependencies and return the link plan + + -- TODO (#23013): currently we directly compute the ObjBlock dependencies and + -- find/load linkable on-demand when a module is missing. + + + (objs_block_info, objs_required_blocks) <- loadObjBlockInfo hs_objs + + let obj_roots = S.fromList . filter obj_is_root $ concatMap (M.keys . bi_exports . lbi_info) (M.elems objs_block_info) + obj_units = map moduleUnitId $ nub (M.keys objs_block_info) + + let (rts_wired_units, rts_wired_functions) = rtsDeps + + -- all the units we want to link together, without their dependencies + let root_units = filter (/= ue_currentUnit unit_env) + -- fendor: GHCi uses more 'UnidIds' than just 'interactiveUnitId'. + -- If this breaks for some reason, + -- see Note [Multiple Home Units aware GHCi] for GHCi session setup. + $ filter (/= interactiveUnitId) + $ nub + $ rts_wired_units ++ reverse obj_units ++ reverse units + + -- all the units we want to link together, including their dependencies, + -- preload units, and backpack instantiations + all_units_infos <- mayThrowUnitErr (preloadUnitsInfo' unit_env root_units) + + let all_units = fmap unitId all_units_infos + + dep_archives <- getPackageArchives cfg unit_env all_units + (archives_block_info, archives_required_blocks) <- loadArchiveBlockInfo ar_cache dep_archives + + -- compute dependencies + let block_info = objs_block_info `M.union` archives_block_info + dep_fun_roots = obj_roots `S.union` rts_wired_functions `S.union` extra_roots + + -- read transitive dependencies + new_required_blocks_var <- newIORef [] + let load_info mod = do + -- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps. + linkable <- HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case + Nothing -> + -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + case ue_homeUnit unit_env of + Nothing -> pprPanic "getDeps: No home-unit: " (pprModule mod) + Just home_unit -> do + mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod) + case mb_stuff of + Found loc mod -> found loc mod + _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod) + where + found loc mod = do { + mb_lnk <- findObjectLinkableMaybe mod loc ; + case mb_lnk of { + Nothing -> pprPanic "getDeps: Couldn't find linkable for module: " (pprModule mod) ; + Just lnk -> pure lnk + }} + + Just mod_info -> case homeModInfoObject mod_info of + Nothing -> pprPanic "getDeps: Couldn't find object file for home-module: " (pprModule mod) + Just lnk -> pure lnk + + -- load block infos from the object files + (bis, req_b) <- loadObjBlockInfo (linkableObjs linkable) + -- Store new required blocks in IORef + modifyIORef new_required_blocks_var ((++) req_b) + case M.lookup mod bis of + Nothing -> pprPanic "getDeps: Didn't load any block info for home-module: " (pprModule mod) + Just bi -> pure bi + + -- required blocks have no dependencies, so don't have to use them as roots in + -- the traversal + (updated_block_info, transitive_deps) <- getDeps block_info load_info dep_fun_roots mempty + + new_required_blocks <- readIORef new_required_blocks_var + let required_blocks = S.fromList $ mconcat + [ archives_required_blocks + , objs_required_blocks + , new_required_blocks + ] + + let all_deps = S.union transitive_deps required_blocks + + let plan = LinkPlan + { lkp_block_info = updated_block_info + , lkp_dep_blocks = all_deps + , lkp_archives = S.fromList dep_archives + , lkp_objs_js = S.fromList js_objs + , lkp_objs_cc = S.fromList cc_objs + } + + return plan + + +-- | Compiled module +data ModuleCode = ModuleCode + { mc_module :: !Module + , mc_js_code :: !JS.JStat + , mc_exports :: !B.ByteString -- ^ rendered exports + , mc_closures :: ![ClosureInfo] + , mc_statics :: ![StaticInfo] + , mc_frefs :: ![ForeignJSRef] + } + +instance Outputable ModuleCode where + ppr m = hang (text "ModuleCode") 2 $ vcat + [ hcat [text "Module: ", ppr (mc_module m)] + , hcat [text "JS Code:", pretty True (mc_js_code m)] + , hcat [text "JS Exports:", pprHsBytes (mc_exports m)] + , hang (text "JS Closures::") 2 (vcat (fmap (text . show) (mc_closures m))) + , hang (text "JS Statics::") 2 (vcat (fmap (text . show) (mc_statics m))) + , hang (text "JS ForeignRefs::") 2 (vcat (fmap (text . show) (mc_frefs m))) + ] + +-- | ModuleCode after link with other modules. +-- +-- It contains less information than ModuleCode because they have been commoned +-- up into global "metadata" for the whole link. +data CompactedModuleCode = CompactedModuleCode + { cmc_module :: !Module + , cmc_js_code :: !JS.JStat + , cmc_exports :: !B.ByteString -- ^ rendered exports + } + +-- | Output JS statements and return the output size in bytes. +hPutJS :: Bool -> Handle -> JS.JStat -> IO Integer +hPutJS render_pretty h = \case + JS.BlockStat [] -> pure 0 + x -> do + before <- hTell h + if render_pretty + then do + printSDoc defaultJsContext (Ppr.PageMode True) h (pretty render_pretty x) + else do + bh <- newBufHandle h + bPutHDoc bh defaultJsContext (line $ pretty render_pretty x) + bFlush bh + -- Append an empty line to correctly end the file in a newline + hPutChar h '\n' + after <- hTell h + pure $! (after - before) + +-- | Link modules and pretty-print them into the given Handle +renderModules + :: Handle + -> Bool -- ^ should we render readable JS for debugging? + -> [ModuleCode] -- ^ linked code per module + -> IO LinkerStats +renderModules h render_pretty mods = do + + -- link modules + let (compacted_mods, meta) = linkModules mods + + let + putJS = hPutJS render_pretty h + + --------------------------------------------------------- + -- Pretty-print JavaScript code for all the dependencies. + -- + -- We have to pretty-print at link time because we want to be able to perform + -- global link-time optimisations (e.g. renamings) on the whole generated JS + -- file. + + -- modules themselves + mod_sizes <- forM compacted_mods $ \m -> do + + !mod_size <- fromIntegral <$> (putJS $ cmc_js_code m) + let !mod_mod = cmc_module m + pure (mod_mod, mod_size) + + -- commoned up metadata + let meta_opt = jsOptimize meta + !meta_length <- fromIntegral <$> putJS meta_opt + + -- module exports + mapM_ (B.hPut h . cmc_exports) compacted_mods + + -- stats + let !link_stats = LinkerStats + { bytesPerModule = M.fromList mod_sizes + , packedMetaDataSize = meta_length + } + + pure link_stats + +-- | Render linker stats +renderLinkerStats :: LinkerStats -> String +renderLinkerStats s = + intercalate "\n\n" [meta_stats, package_stats, module_stats] <> "\n\n" + where + meta = packedMetaDataSize s + meta_stats = "number of modules: " <> show (length bytes_per_mod) + <> "\npacked metadata: " <> show meta + + bytes_per_mod = M.toList $ bytesPerModule s + + show_unit (UnitId fs) = unpackFS fs + + ps :: Map UnitId Word64 + ps = M.fromListWith (+) . map (\(m,s) -> (moduleUnitId m,s)) $ bytes_per_mod + + pad :: Int -> String -> String + pad n t = let l = length t + in if l < n then t <> replicate (n-l) ' ' else t + + pkgMods :: [[(Module,Word64)]] + pkgMods = groupBy ((==) `on` (moduleUnitId . fst)) bytes_per_mod + + showMod :: (Module, Word64) -> String + showMod (m,s) = pad 40 (" " <> moduleStableString m <> ":") <> show s <> "\n" + + package_stats :: String + package_stats = "code size summary per package (in bytes):\n\n" + <> concatMap (\(p,s) -> pad 25 (show_unit p <> ":") <> show s <> "\n") (M.toList ps) + + module_stats :: String + module_stats = "code size per module (in bytes):\n\n" <> unlines (map (concatMap showMod) pkgMods) + + +getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath] +getPackageArchives cfg unit_env units = do + fmap concat $ forM units $ \u -> do + let archives = [ ST.unpack p "lib" ++ ST.unpack l ++ profSuff <.> "a" + | p <- getInstalledPackageLibDirs ue_state u + , l <- getInstalledPackageHsLibs ue_state u + ] + foundArchives <- filterM doesFileExist archives + if | not (null archives) + , null foundArchives + -> do + throwGhcExceptionIO (InstallationError $ "Could not find any library archives for unit-id: " <> (renderWithContext (csContext cfg) $ ppr u)) + | otherwise + -> pure foundArchives + where + ue_state = ue_homeUnitState unit_env + + -- XXX the profiling library name is probably wrong now + profSuff | csProf cfg = "_p" + | otherwise = "" + + +-- | Combine rts.js, lib.js, out.js to all.js that can be run +-- directly with node.js or SpiderMonkey jsshell +combineFiles :: JSLinkConfig + -> Bool -- has clibs.js + -> FilePath + -> IO () +combineFiles cfg has_clibs fp = do + let files = map (fp ) $ catMaybes + [ Just "rts.js" + , Just "lib.js" + , Just "out.js" + , if has_clibs then Just "clibs.js" else Nothing + , if lcNoHsMain cfg then Nothing else Just "runmain.js" + ] + withBinaryFile (fp "all.js") WriteMode $ \h -> + forM_ files $ \i -> + B.readFile i >>= B.hPut h + +-- | write the index.html file that loads the program if it does not exit +writeHtml + :: FilePath -- ^ output directory + -> IO () +writeHtml out = do + let htmlFile = out "index.html" + e <- doesFileExist htmlFile + unless e $ + B.writeFile htmlFile templateHtml + + +templateHtml :: B.ByteString +templateHtml = + "\n\ + \\n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \" + +-- | write the runmain.js file that will be run with defer so that it runs after +-- index.html is loaded +writeRunMain + :: FilePath -- ^ output directory + -> UseEmccRts + -> IO () +writeRunMain out use_emcc_rts = do + let runMainFile = out "runmain.js" + B.writeFile runMainFile (runMainJS use_emcc_rts) + +newtype UseEmccRts = UseEmccRts Bool + +runMainJS :: UseEmccRts -> B.ByteString +runMainJS (UseEmccRts use_emcc_rts) = if use_emcc_rts + then "Module['onRuntimeInitialized'] = function() {\n\ + \h$initEmscriptenHeap();\n\ + \h$main(h$mainZCZCMainzimain);\n\ + \}\n" + else "h$main(h$mainZCZCMainzimain);\n" + +writeRunner :: JSLinkConfig -- ^ Settings + -> FilePath -- ^ Output directory + -> IO () +writeRunner _settings out = do + cd <- getCurrentDirectory + let arch_os = hostPlatformArchOS + let runner = cd exeFileName arch_os False (Just (dropExtension out)) + srcFile = out "all" <.> "js" + nodePgm :: B.ByteString + nodePgm = "node" + src <- B.readFile (cd srcFile) + B.writeFile runner ("#!/usr/bin/env " <> nodePgm <> "\n" <> src) + perms <- getPermissions runner + setPermissions runner (perms {executable = True}) + +rtsExterns :: FastString +rtsExterns = + -- Google Closure Compiler --externs option is deprecated. + -- Need pass them as a js file with @externs module-level jsdoc. + "/** @externs @suppress {duplicate} */\n" <> + "// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" <> + mconcat + -- See GHC.StgToJS + -- We connect all payload fields "dXX" on JavaScript Object. + -- That's most simple way to make Google Closure Compiler prevent + -- property names mangling. + (map (\x -> "/** @type {*} */\nObject.d" <> mkFastString (show x) <> ";\n") + [(1::Int)..16384]) <> + mconcat + (map (\x -> "/** @type {*} */\nObject." <> x <> ";\n") + -- We do same for special STG properties as well. + ["m", "f", "cc", "t", "size", "i", "n", "a", "r", "s"]) <> + mconcat + [ -- Used at h$mkForeignCallback + "/** @type {*} */\nObject.mv;\n" + ] <> + mconcat + (map (\x -> x <> ";\n") + [ -- Externs needed by node environment + "/** @type {string} */ var __dirname" + -- Copied minimally from https://github.com/externs/nodejs/blob/6c6882c73efcdceecf42e7ba11f1e3e5c9c041f0/v8/nodejs.js#L8 + , "/** @const */ var NodeJS = {}" + -- NodeJS Stream interface + , "/** @interface */ NodeJS.Stream = function () {}" + , "/** @template THIS @this {THIS} @return {THIS} */ NodeJS.Stream.prototype.on = function() {}" + , "/** @return {boolean} */ NodeJS.Stream.prototype.write = function() {}" + -- NodeJS versions property contains actual versions of the environment + , "/** @interface */ NodeJS.ProcessVersions = function() {}" + , "/** @type {string} */ NodeJS.ProcessVersions.prototype.node" + -- NodeJS Process interface + , "/** @interface */ NodeJS.Process = function() {}" + , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stderr" + , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stdin" + , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stdout" + , "/** @type {!NodeJS.ProcessVersions} */ NodeJS.Process.prototype.versions" + , "/** @return {?} */ NodeJS.Process.prototype.exit = function() {}" + , "/** @type {!Array} */ NodeJS.Process.prototype.argv" + -- NodeJS Process definition + , "/** @type {!NodeJS.Process} */ var process" + -- NodeJS Buffer class + , "/** @extends {Uint8Array} @constructor */ function Buffer(arg1, encoding) {}" + , "/** @return {!Buffer} */ Buffer.alloc = function() {}" + -- Emscripten Module + -- Emscripten RTS's definitions we use in mem.js to support C sources. + -- When we link with emcc the actual definitions are linked, but when we + -- don't use C sources we don't use emcc and these variables are detected + -- as undefined. + , "/** @type {*} */ var Module" + , "/** @type {!Int8Array} */ Module.HEAP8" + , "/** @type {!Uint8Array} */ Module.HEAPU8" + , "/** @return {number} */ Module.getEmptyTableSlot = function() {}" + , "/** @return {*} */ Module._free = function() {}" + , "/** @return {*} */ Module._malloc = function() {}" + -- Mozilla's Narcissus (JS in JS interpreter implemented on top of SpiderMonkey) environment + , "/** @type {*} */ var putstr" + , "/** @type {*} */ var printErr" + -- Apples's JavaScriptCore environment + , "/** @type {*} */ var debug" + ]) + +writeExterns :: FilePath -> IO () +writeExterns out = writeFile (out "all.externs.js") + $ unpackFS rtsExterns + +-- | Get all block dependencies for a given set of roots +-- +-- Returns the updated block info map and the blocks. +getDeps :: Map Module LocatedBlockInfo -- ^ Block info per module + -> (Module -> IO LocatedBlockInfo) -- ^ Used to load block info if missing + -> Set ExportedFun -- ^ start here + -> Set BlockRef -- ^ and also link these + -> IO (Map Module LocatedBlockInfo, Set BlockRef) +getDeps init_infos load_info root_funs root_blocks = traverse_funs init_infos S.empty root_blocks (S.toList root_funs) + where + -- A block may depend on: + -- 1. other blocks from the same module + -- 2. exported functions from another module + -- + -- Process: + -- 1. We use the BlockInfos to find the block corresponding to every + -- exported root functions. + -- + -- 2. We add these blocks to the set of root_blocks if they aren't already + -- added to the result. + -- + -- 3. Then we traverse the root_blocks to find their dependencies and we + -- add them to root_blocks (if they aren't already added to the result) and + -- to root_funs. + -- + -- 4. back to 1 + + lookup_info infos mod = case M.lookup mod infos of + Just info -> pure (infos, lbi_info info) + Nothing -> do + -- load info and update cache with it + info <- load_info mod + pure (M.insert mod info infos, lbi_info info) + + traverse_blocks + :: Map Module LocatedBlockInfo + -> Set BlockRef + -> Set BlockRef + -> IO (Map Module LocatedBlockInfo, Set BlockRef) + traverse_blocks infos result open = case S.minView open of + Nothing -> return (infos, result) + Just (ref, open') -> do + let mod = block_ref_mod ref + !(infos',info) <- lookup_info infos mod + let block = bi_block_deps info ! block_ref_idx ref + result' = S.insert ref result + to_block_ref i = BlockRef + { block_ref_mod = mod + , block_ref_idx = i + } + traverse_funs infos' result' + (addOpen result' open' $ + map to_block_ref (blockBlockDeps block)) (blockFunDeps block) + + traverse_funs + :: Map Module LocatedBlockInfo + -> Set BlockRef + -> Set BlockRef + -> [ExportedFun] + -> IO (Map Module LocatedBlockInfo, Set BlockRef) + traverse_funs infos result open = \case + [] -> traverse_blocks infos result open + (f:fs) -> do + let mod = funModule f + -- lookup module block info for the module that exports the function + !(infos',info) <- lookup_info infos mod + -- lookup block index associated to the function in the block info + case M.lookup f (bi_exports info) of + Nothing -> pprPanic "exported function not found: " $ ppr f + Just idx -> do + let fun_block_ref = BlockRef + { block_ref_mod = mod + , block_ref_idx = idx + } + -- always add the module "global block" when we link a module + let global_block_ref = BlockRef + { block_ref_mod = mod + , block_ref_idx = 0 + } + traverse_funs infos' result (addOpen result open [fun_block_ref,global_block_ref]) fs + + -- extend the open block set with new blocks that are not already in the + -- result block set nor in the open block set. + addOpen + :: Set BlockRef + -> Set BlockRef + -> [BlockRef] + -> Set BlockRef + addOpen result open new_blocks = + let alreadyLinked s = S.member s result || S.member s open + in open `S.union` S.fromList (filter (not . alreadyLinked) new_blocks) + +-- | collect dependencies for a set of roots +collectModuleCodes :: ArchiveCache -> LinkPlan -> IO [ModuleCode] +collectModuleCodes ar_cache link_plan = do + + let block_info = lkp_block_info link_plan + let blocks = lkp_dep_blocks link_plan + + -- we're going to load all the blocks. Instead of doing this randomly, we + -- group them by module first. + let module_blocks :: Map Module BlockIds + module_blocks = M.fromListWith IS.union $ + map (\ref -> (block_ref_mod ref, IS.singleton (block_ref_idx ref))) (S.toList blocks) + + -- load blocks + forM (M.toList module_blocks) $ \(mod,bids) -> do + case M.lookup mod block_info of + Nothing -> pprPanic "collectModuleCodes: couldn't find block info for module" (ppr mod) + Just lbi -> extractBlocks ar_cache lbi bids + +extractBlocks :: ArchiveCache -> LocatedBlockInfo -> BlockIds -> IO ModuleCode +extractBlocks ar_state lbi blocks = do + case lbi_loc lbi of + ObjectFile fp -> do + us <- readObjectBlocks fp blocks + pure (collectCode us) + ArchiveFile a -> do + obj <- readArObject ar_state mod a + us <- getObjectBlocks obj blocks + pure (collectCode us) + InMemory _n obj -> do + us <- getObjectBlocks obj blocks + pure (collectCode us) + where + mod = bi_module (lbi_info lbi) + newline = BC.pack "\n" + mk_exports = mconcat . intersperse newline . filter (not . BS.null) . map oiRaw + mk_js_code = mconcat . map oiStat + collectCode l = ModuleCode + { mc_module = mod + , mc_js_code = mk_js_code l + , mc_exports = mk_exports l + , mc_closures = concatMap oiClInfo l + , mc_statics = concatMap oiStatic l + , mc_frefs = concatMap oiFImports l + } + +-- | Load an archive in memory and store it in the cache for future loads. +loadArchive :: ArchiveCache -> FilePath -> IO Ar.Archive +loadArchive ar_cache ar_file = do + loaded_ars <- readIORef (loadedArchives ar_cache) + case M.lookup ar_file loaded_ars of + Just a -> pure a + Nothing -> do + a <- Ar.loadAr ar_file + modifyIORef (loadedArchives ar_cache) (M.insert ar_file a) + pure a + + +readArObject :: ArchiveCache -> Module -> FilePath -> IO Object +readArObject ar_cache mod ar_file = do + Ar.Archive entries <- loadArchive ar_cache ar_file + + -- look for the right object in archive + let go_entries = \case + -- XXX this shouldn't be an exception probably + [] -> panic $ "could not find object for module " + ++ moduleNameString (moduleName mod) + ++ " in " + ++ ar_file + + (e:es) -> do + let bs = Ar.filedata e + bh <- unsafeUnpackBinBuffer bs + getObjectHeader bh >>= \case + Left _ -> go_entries es -- not a valid object entry + Right mod_name + | mod_name /= moduleName mod + -> go_entries es -- not the module we're looking for + | otherwise + -> getObjectBody bh mod_name -- found it + + go_entries entries + +-- | dependencies for the RTS, these need to be always linked +rtsDeps :: ([UnitId], Set ExportedFun) +rtsDeps = + ( [ghcInternalUnitId] + , S.fromList $ concat + [ mkInternalFuns "GHC.Internal.Conc.Sync" + ["reportError"] + , mkInternalFuns "GHC.Internal.Control.Exception.Base" + ["nonTermination"] + , mkInternalFuns "GHC.Internal.Exception.Type" + [ "SomeException" + , "underflowException" + , "overflowException" + , "divZeroException" + ] + , mkInternalFuns "GHC.Internal.TopHandler" + [ "runMainIO" + , "topHandler" + ] + , mkInternalFuns "GHC.Internal.Base" + ["$fMonadIO"] + , mkInternalFuns "GHC.Internal.Maybe" + [ "Nothing" + , "Just" + ] + , mkInternalFuns "GHC.Internal.Ptr" + ["Ptr"] + , mkInternalFuns "GHC.Internal.JS.Prim" + [ "JSVal" + , "JSException" + , "$fShowJSException" + , "$fExceptionJSException" + , "resolve" + , "resolveIO" + , "toIO" + ] + , mkInternalFuns "GHC.Internal.JS.Prim.Internal" + [ "wouldBlock" + , "blockedIndefinitelyOnMVar" + , "blockedIndefinitelyOnSTM" + , "ignoreException" + , "setCurrentThreadResultException" + , "setCurrentThreadResultValue" + ] + , mkInternalFuns "GHC.Internal.Types" + [ ":" + , "[]" + ] + , mkInternalFuns "GHC.Internal.Tuple" + [ "(,)" + , "(,,)" + , "(,,,)" + , "(,,,,)" + , "(,,,,,)" + , "(,,,,,,)" + , "(,,,,,,,)" + , "(,,,,,,,,)" + , "(,,,,,,,,,)" + ] + ] + ) + +-- | Export the functions in @ghc-internal@ +mkInternalFuns :: FastString -> [FastString] -> [ExportedFun] +mkInternalFuns = mkExportedFuns ghcInternalUnitId + +-- | Given a @UnitId@, a module name, and a set of symbols in the module, +-- package these into an @ExportedFun@. +mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun] +mkExportedFuns uid mod_name symbols = mkExportedModFuns mod names + where + mod = mkModule (RealUnit (Definite uid)) (mkModuleNameFS mod_name) + names = map (mkJsSymbol True mod) symbols + +-- | Given a @Module@ and a set of symbols in the module, package these into an +-- @ExportedFun@. +mkExportedModFuns :: Module -> [FastString] -> [ExportedFun] +mkExportedModFuns mod symbols = map mk_fun symbols + where + mk_fun sym = ExportedFun mod (LexicalFastString sym) + +-- | read all dependency data from the to-be-linked files +loadObjBlockInfo + :: [FilePath] -- ^ object files to link + -> IO (Map Module LocatedBlockInfo, [BlockRef]) +loadObjBlockInfo objs = (prepareLoadedDeps . catMaybes) <$> mapM readBlockInfoFromObj objs + +-- | Load dependencies for the Linker from Ar +loadArchiveBlockInfo :: ArchiveCache -> [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef]) +loadArchiveBlockInfo ar_cache archives = do + archDeps <- forM archives $ \file -> do + (Ar.Archive entries) <- loadArchive ar_cache file + catMaybes <$> mapM (readEntry file) entries + return (prepareLoadedDeps $ concat archDeps) + where + readEntry :: FilePath -> Ar.ArchiveEntry -> IO (Maybe LocatedBlockInfo) + readEntry ar_file ar_entry = do + let bs = Ar.filedata ar_entry + bh <- unsafeUnpackBinBuffer bs + getObjectHeader bh >>= \case + Left _ -> pure Nothing -- not a valid object entry + Right mod_name -> do + obj <- getObjectBody bh mod_name + let !info = objBlockInfo obj + pure $ Just (LocatedBlockInfo (ArchiveFile ar_file) info) + +prepareLoadedDeps :: [LocatedBlockInfo] + -> (Map Module LocatedBlockInfo, [BlockRef]) +prepareLoadedDeps lbis = (module_blocks, must_link) + where + must_link = concatMap (requiredBlocks . lbi_info) lbis + module_blocks = M.fromList $ map (\d -> (bi_module (lbi_info d), d)) lbis + +requiredBlocks :: BlockInfo -> [BlockRef] +requiredBlocks d = map mk_block_ref (IS.toList $ bi_must_link d) + where + mk_block_ref i = BlockRef + { block_ref_mod = bi_module d + , block_ref_idx = i + } + +-- | read block info from an object that might have already been into memory +-- pulls in all Deps from an archive +readBlockInfoFromObj :: FilePath -> IO (Maybe LocatedBlockInfo) +readBlockInfoFromObj file = do + readObjectBlockInfo file >>= \case + Nothing -> pure Nothing + Just info -> pure $ Just (LocatedBlockInfo (ObjectFile file) info) + + +-- | Embed a JS file into a JS object .o file +-- +-- JS files may contain option pragmas of the form: //#OPTIONS: +-- One of those is //#OPTIONS:CPP. When it is set, we append some common CPP +-- definitions to the file and call cpp on it. +-- +-- Other options (e.g. EMCC additional flags for link time) are stored in the +-- JS object header. See JSOptions. +embedJsFile :: Logger -> DynFlags -> TmpFs -> UnitEnv -> FilePath -> FilePath -> IO () +embedJsFile logger dflags tmpfs unit_env input_fn output_fn = do + let profiling = False -- FIXME: add support for profiling way + + createDirectoryIfMissing True (takeDirectory output_fn) + + -- the header lets the linker recognize processed JavaScript files + -- But don't add JavaScript header to object files! + + -- read pragmas from JS file + -- we need to store them explicitly as they can be removed by CPP. + opts <- getOptionsFromJsFile input_fn + + -- run CPP if needed + cpp_fn <- case enableCPP opts of + False -> pure input_fn + True -> do + -- append common CPP definitions to the .js file. + -- They define macros that avoid directly wiring zencoded names + -- in RTS JS files + pp_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" + payload <- B.readFile input_fn + B.writeFile pp_fn (commonCppDefs profiling <> payload) + + -- run CPP on the input JS file + js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" + let + cpp_opts = CppOpts + { sourceCodePreprocessor = SCPJsCpp + -- JS code requires keeping JSDoc comments for third party minification tooling + , cppLinePragmas = False -- LINE pragmas aren't JS compatible + } + doCpp logger + tmpfs + dflags + unit_env + cpp_opts + pp_fn + js_fn + pure js_fn + + -- write JS object + cpp_bs <- B.readFile cpp_fn + writeJSObject opts cpp_bs output_fn + +-- | Link module codes. +-- +-- Performs link time optimizations and produces one JStat per module plus some +-- commoned up initialization code. +linkModules :: [ModuleCode] -> ([CompactedModuleCode], JS.JStat) +linkModules mods = (compact_mods, meta) + where + compact_mods = map compact mods + + -- here GHCJS used to: + -- - deduplicate declarations + -- - rename local variables into shorter ones + -- - compress initialization data + -- but we haven't ported it (yet). + compact m = CompactedModuleCode + { cmc_js_code = mc_js_code m + , cmc_module = mc_module m + , cmc_exports = mc_exports m + } + + -- common up statics: different bindings may reference the same statics, we + -- filter them here to initialize them once + statics = nubStaticInfo (concatMap mc_statics mods) + + infos = concatMap mc_closures mods + debug = False -- TODO: this could be enabled in a debug build. + -- It adds debug info to heap objects + meta = mconcat + -- render metadata as individual statements + [ mconcat (map staticDeclStat statics) + , mconcat (map staticInitStat statics) + , jStgStatToJS $ mconcat (map (closureInfoStat debug) infos) + ] + +-- | Only keep a single StaticInfo with a given name +nubStaticInfo :: [StaticInfo] -> [StaticInfo] +nubStaticInfo = go emptyUniqSet + where + go us = \case + [] -> [] + (x:xs) -> + -- only match on siVar. There is no reason for the initializing value to + -- be different for the same global name. + let name = siVar x + in if elementOfUniqSet name us + then go us xs + else x : go (addOneToUniqSet us name) xs + +-- | Initialize a global object. +-- +-- All global objects have to be declared (staticInfoDecl) first. +staticInitStat :: StaticInfo -> JS.JStat +staticInitStat (StaticInfo i sv mcc) = + jStgStatToJS $ + case sv of + (StaticApp k app args) -> appS + (if k == SAKThunk then hdStcStr else hdStiStr) + $ add_cc_arg + [ global i + , global app + , jsStaticArgs args + ] + + StaticList args mt -> appS hdStlStr + $ add_cc_arg + [ global i + , jsStaticArgs args + , toJExpr $ maybe null_ (toJExpr . TxtI) mt + ] + + StaticUnboxed _ -> mempty + where + -- add optional cost-center argument + add_cc_arg as = case mcc of + Nothing -> as + Just cc -> as ++ [toJExpr cc] + +-- | declare and do first-pass init of a global object (create JS object for heap objects) +staticDeclStat :: StaticInfo -> JS.JStat +staticDeclStat (StaticInfo global_name static_value _) = jStgStatToJS decl + where + global_ident = name global_name + decl_init v = global_ident ||= v + + decl = case static_value of + StaticUnboxed u -> decl_init (unboxed_expr u) + _ -> decl_init (app hdDStr []) + + unboxed_expr = \case + StaticUnboxedBool b -> app hdPStr [toJExpr b] + StaticUnboxedInt i -> app hdPStr [toJExpr i] + StaticUnboxedDouble d -> app hdPStr [toJExpr (unSaneDouble d)] + StaticUnboxedString str -> initStr str + StaticUnboxedStringOffset {} -> 0 + + to_byte_list = JList . map (Int . fromIntegral) . BS.unpack + + initStr :: BS.ByteString -> JStgExpr + initStr str = + case decodeModifiedUTF8 str of + Just t -> app hdEncodeModifiedUtf8Str [ValExpr (JStr t)] + Nothing -> app hdRawStringDataStr [ValExpr $ to_byte_list str] diff --git a/GHC/StgToJS/Linker/Opt.hs b/GHC/StgToJS/Linker/Opt.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Linker/Opt.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Opt +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Stability : experimental +-- +-- Optimization pass at link time +-- +-- +-- +----------------------------------------------------------------------------- +module GHC.StgToJS.Linker.Opt + ( pretty + , optRenderJs + ) +where + +import GHC.Prelude +import GHC.Int +import GHC.Exts + +import GHC.JS.Syntax +import GHC.JS.Ppr + +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Unique.Map + +import Data.List (sortOn) +import Data.Char (isAlpha,isDigit,ord) +import qualified Data.ByteString.Short as SBS + +pretty :: JsRender doc => Bool -> JStat -> doc +pretty render_pretty = \case + BlockStat [] -> empty + s | render_pretty -> jsToDocR defaultRenderJs [s] + | otherwise -> jsToDocR optRenderJs [s] + -- render as a list of statements to ensure that + -- semicolons are added. + +-- | Render JS with code size minimization enabled +optRenderJs :: RenderJs doc +optRenderJs = defaultRenderJs + { renderJsV = ghcjsRenderJsV + , renderJsS = ghcjsRenderJsS + , renderJsI = ghcjsRenderJsI + } + +hdd :: SBS.ShortByteString +hdd = SBS.pack (map (fromIntegral . ord) "h$$") + +ghcjsRenderJsI :: IsLine doc => RenderJs doc -> Ident -> doc +ghcjsRenderJsI _ (identFS -> fs) + -- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by + -- name in user code, only in compiled code. Hence we can rename them if we do + -- it consistently in all the linked code. + -- + -- These symbols are usually very large because their name includes the + -- unit-id, the module name, and some unique number. So we rename these + -- symbols with a much shorter globally unique number. + -- + -- Here we reuse their FastString unique for this purpose! Note that it only + -- works if we pretty-print all the JS code linked together at once, which we + -- currently do. GHCJS used to maintain a CompactorState to support + -- incremental linking: it contained the mapping between original symbols and + -- their renaming. + | hdd `SBS.isPrefixOf` fastStringToShortByteString fs + , u <- uniqueOfFS fs + = text "h$$" <> hexDoc (fromIntegral u) + | otherwise + = ftext fs + +-- | Render as an hexadecimal number in reversed order (because it's faster and we +-- don't care about the actual value). +hexDoc :: IsLine doc => Word -> doc +hexDoc 0 = char '0' +hexDoc v = text $ go v + where + sym (I# i) = C# (indexCharOffAddr# chars i) + chars = "0123456789abcdef"# + go = \case + 0 -> [] + n -> sym (fromIntegral (n .&. 0x0F)) + : sym (fromIntegral ((n .&. 0xF0) `shiftR` 4)) + : go (n `shiftR` 8) + + + + +-- attempt to resugar some of the common constructs +ghcjsRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc +ghcjsRenderJsS r s = renderJsS defaultRenderJs r s + +-- don't quote keys in our object literals, so closure compiler works +ghcjsRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc +ghcjsRenderJsV r (JHash m) + | isNullUniqMap m = text "{}" + | otherwise = braceNest . fsep . punctuate comma . + map (\(x,y) -> quoteIfRequired x <> colon <+> jsToDocR r y) + -- nonDetEltsUniqMap doesn't introduce non-determinism here because + -- we sort the elements lexically + . sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m + where + quoteIfRequired :: IsLine doc => FastString -> doc + quoteIfRequired x + | isUnquotedKey x = ftext x + | otherwise = char '\'' <> ftext x <> char '\'' + + isUnquotedKey :: FastString -> Bool + isUnquotedKey fs = case unpackFS fs of + [] -> False + s@(c:cs) -> all isDigit s || (validFirstIdent c && all validOtherIdent cs) + + validFirstIdent c = c == '_' || c == '$' || isAlpha c + validOtherIdent c = isAlpha c || isDigit c + +ghcjsRenderJsV r v = renderJsV defaultRenderJs r v diff --git a/GHC/StgToJS/Linker/Types.hs b/GHC/StgToJS/Linker/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Linker/Types.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Types +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Linker.Types + ( JSLinkConfig (..) + , LinkPlan (..) + ) +where + +import GHC.StgToJS.Object + +import GHC.Unit.Types +import GHC.Utils.Outputable (Outputable(..),text,ppr, hang, IsDoc (vcat), IsLine (hcat)) + +import Data.Map.Strict (Map) +import Data.Set (Set) +import qualified Data.Set as S + +import System.IO + +import Prelude + +-------------------------------------------------------------------------------- +-- Linker Config +-------------------------------------------------------------------------------- + +data JSLinkConfig = JSLinkConfig + { lcNoJSExecutables :: !Bool -- ^ Dont' build JS executables + , lcNoHsMain :: !Bool -- ^ Don't generate Haskell main entry + , lcNoRts :: !Bool -- ^ Don't dump the generated RTS + , lcNoStats :: !Bool -- ^ Disable .stats file generation + , lcForeignRefs :: !Bool -- ^ Dump .frefs (foreign references) files + , lcCombineAll :: !Bool -- ^ Generate all.js (combined js) + wrappers + , lcForceEmccRts :: !Bool + -- ^ Force the link with the emcc rts. Use this if you plan to dynamically + -- load wasm modules made from C files (e.g. in iserv). + , lcLinkCsources :: !Bool + -- ^ Link C sources (compiled to JS/Wasm) with Haskell code compiled to + -- JS. This implies the use of the Emscripten RTS to load this code. + } + +data LinkPlan = LinkPlan + { lkp_block_info :: Map Module LocatedBlockInfo + -- ^ Block information + + , lkp_dep_blocks :: Set BlockRef + -- ^ Blocks to link + + , lkp_archives :: !(Set FilePath) + -- ^ Archives to load JS and Cc sources from (JS code corresponding to + -- Haskell code is handled with blocks above) + + , lkp_objs_js :: !(Set FilePath) + -- ^ JS objects to link + + , lkp_objs_cc :: !(Set FilePath) + -- ^ Cc objects to link + } + +instance Outputable LinkPlan where + ppr s = hang (text "LinkPlan") 2 $ vcat + -- Hidden because it's too verbose and it's not really part of the + -- plan, just meta info used to retrieve actual block contents + -- [ hcat [ text "Block info: ", ppr (lkp_block_info s)] + [ hcat [ text "Blocks: ", ppr (S.size (lkp_dep_blocks s))] + , hang (text "Archives:") 2 (vcat (fmap text (S.toList (lkp_archives s)))) + , hang (text "Extra JS objects:") 2 (vcat (fmap text (S.toList (lkp_objs_js s)))) + , hang (text "Extra Cc objects:") 2 (vcat (fmap text (S.toList (lkp_objs_cc s)))) + ] diff --git a/GHC/StgToJS/Linker/Utils.hs b/GHC/StgToJS/Linker/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Linker/Utils.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Utils +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- Various utilies used in the JS Linker +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Linker.Utils + ( jsExeFileName + , getInstalledPackageLibDirs + , getInstalledPackageHsLibs + , commonCppDefs + , decodeModifiedUTF8 + ) +where + +import System.FilePath +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Char8 +import Data.ByteString (ByteString) + +import GHC.Driver.Session + +import GHC.Data.ShortText +import GHC.Unit.State +import GHC.Unit.Types + +import GHC.StgToJS.Types + +import Prelude +import GHC.Platform +import Data.List (isPrefixOf) + +import GHC.Builtin.Types +import Language.Haskell.Syntax.Basic +import GHC.Types.Name +import GHC.StgToJS.Ids +import GHC.JS.Ident +import GHC.Core.DataCon +import GHC.Data.FastString + +-- | Retrieve library directories provided by the @UnitId@ in @UnitState@ +getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText] +getInstalledPackageLibDirs us = maybe mempty unitLibraryDirs . lookupUnitId us + +-- | Retrieve the names of the libraries provided by @UnitId@ +getInstalledPackageHsLibs :: UnitState -> UnitId -> [ShortText] +getInstalledPackageHsLibs us = maybe mempty unitLibraries . lookupUnitId us + +-- | A constant holding the JavaScript executable Filename extension +jsexeExtension :: String +jsexeExtension = "jsexe" + +-- | CPP definitions that are inserted into every .pp file +commonCppDefs :: Bool -> ByteString +commonCppDefs profiling = case profiling of + True -> commonCppDefs_profiled + False -> commonCppDefs_vanilla + +-- | CPP definitions for normal operation and profiling. Use CAFs for +-- commonCppDefs_* so that they are shared for every CPP file +commonCppDefs_vanilla, commonCppDefs_profiled :: ByteString +commonCppDefs_vanilla = genCommonCppDefs False +commonCppDefs_profiled = genCommonCppDefs True + +-- | Generate macros MK_TUP* for tuples sized 2+. +genMkTup :: Bool -> Int -> ByteString +genMkTup profiling n = mconcat + [ "#define MK_TUP", sn -- #define MK_TUPn + , "(", B.intercalate "," xs, ")" -- (x1,x2,...) + , "(h$c", sn, "(" -- (h$cn( + , bytesFS symbol, "," -- h$ghczminternalZCGHCziInternalziTupleziZnT_con_e, + , B.intercalate "," $ map (\x -> "(" <> x <> ")") xs -- (x1),(x2),(...) + , if profiling -- ,h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM + then ",h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM" + else "" + , "))\n" -- ))\n + ] + where + xs = take n $ map (("x" <>) . Char8.pack . show) ([1..] :: [Int]) + sn = Char8.pack $ show n + symbol = identFS $ makeIdentForId (dataConWorkId $ tupleDataCon Boxed n) Nothing IdConEntry mod + name = tupleDataConName Boxed n + mod = case nameModule_maybe name of + Just m -> m + Nothing -> error "Tuple constructor is missing a module" + +-- | Generate CPP Definitions depending on a profiled or normal build. This +-- occurs at link time. +genCommonCppDefs :: Bool -> ByteString +genCommonCppDefs profiling = mconcat + [ + -- constants + let mk_int_def n v = "#define " <> Char8.pack n <> " (" <> Char8.pack (show v) <> ")\n" + -- generate "#define CLOSURE_TYPE_xyz (num)" defines + mk_closure_def t = mk_int_def (ctJsName t) (ctNum t) + closure_defs = map mk_closure_def [minBound..maxBound] + -- generate "#define THREAD_xyz_xyz (num)" defines + mk_thread_def t = mk_int_def (threadStatusJsName t) (threadStatusNum t) + thread_defs = map mk_thread_def [minBound..maxBound] + in mconcat (closure_defs ++ thread_defs) + + -- low-level heap object manipulation macros + , mconcat (map (genMkTup profiling) [2..10]) + + , "#define TUP2_1(x) ((x).d1)\n" + , "#define TUP2_2(x) ((x).d2)\n" + + -- GHCJS.Prim.JSVal + , if profiling + then "#define MK_JSVAL(x) (h$c1(h$ghczminternalZCGHCziInternalziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM))\n" + else "#define MK_JSVAL(x) (h$c1(h$ghczminternalZCGHCziInternalziJSziPrimziJSVal_con_e, (x)))\n" + , "#define JSVAL_VAL(x) ((x).d1)\n" + + -- GHCJS.Prim.JSException + , if profiling + then "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$ghczminternalZCGHCziInternalziJSziPrimziJSException_con_e,(msg),(hsMsg),h$CCS_SYSTEM))\n" + else "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$ghczminternalZCGHCziInternalziJSziPrimziJSException_con_e,(msg),(hsMsg)))\n" + + -- Exception dictionary for JSException + , "#define HS_JSEXCEPTION_EXCEPTION h$ghczminternalZCGHCziInternalziJSziPrimzizdfExceptionJSException\n" + + -- SomeException + , if profiling + then "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$ghczminternalZCGHCziInternalziExceptionziTypeziSomeException_con_e,(dict),(except),h$CCS_SYSTEM))\n" + else "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$ghczminternalZCGHCziInternalziExceptionziTypeziSomeException_con_e,(dict),(except)))\n" + + -- GHC.Ptr.Ptr + , if profiling + then "#define MK_PTR(val,offset) (h$c2(h$ghczminternalZCGHCziInternalziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" + else "#define MK_PTR(val,offset) (h$c2(h$ghczminternalZCGHCziInternalziPtrziPtr_con_e, (val), (offset)))\n" + + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null); var ro = (a).dv.getInt32(o,true);\n" + + -- Data.Maybe.Maybe + , "#define HS_NOTHING h$ghczminternalZCGHCziInternalziMaybeziNothing\n" + , "#define IS_NOTHING(cl) ((cl).f === h$ghczminternalZCGHCziInternalziMaybeziNothing_con_e)\n" + , "#define IS_JUST(cl) ((cl).f === h$ghczminternalZCGHCziInternalziMaybeziJust_con_e)\n" + , "#define JUST_VAL(jj) ((jj).d1)\n" + -- "#define HS_NOTHING h$nothing\n" + , if profiling + then "#define MK_JUST(val) (h$c1(h$ghczminternalZCGHCziInternalziMaybeziJust_con_e, (val), h$CCS_SYSTEM))\n" + else "#define MK_JUST(val) (h$c1(h$ghczminternalZCGHCziInternalziMaybeziJust_con_e, (val)))\n" + + -- Data.List + , "#define HS_NIL h$ghczminternalZCGHCziInternalziTypesziZMZN\n" + , "#define HS_NIL_CON h$ghczminternalZCGHCziInternalziTypesziZMZN_con_e\n" + , "#define IS_CONS(cl) ((cl).f === h$ghczminternalZCGHCziInternalziTypesziZC_con_e)\n" + , "#define IS_NIL(cl) ((cl).f === h$ghczminternalZCGHCziInternalziTypesziZMZN_con_e)\n" + , "#define CONS_HEAD(cl) ((cl).d1)\n" + , "#define CONS_TAIL(cl) ((cl).d2)\n" + , if profiling + then mconcat + [ "#define MK_CONS(head,tail) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail), h$CCS_SYSTEM))\n" + , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail), (cc)))\n" + ] + else mconcat + [ "#define MK_CONS(head,tail) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail)))\n" + , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail)))\n" + ] + + -- Data.Text + , "#define DATA_TEXT_ARRAY(x) ((x).d1)\n" + , "#define DATA_TEXT_OFFSET(x) ((x).d2.d1)\n" + , "#define DATA_TEXT_LENGTH(x) ((x).d2.d2)\n" + + -- Data.Text.Lazy + , "#define LAZY_TEXT_IS_CHUNK(x) ((x).f.a === 2)\n" + , "#define LAZY_TEXT_IS_NIL(x) ((x).f.a === 1)\n" + , "#define LAZY_TEXT_CHUNK_HEAD(x) ((x))\n" + , "#define LAZY_TEXT_CHUNK_TAIL(x) ((x).d2.d3)\n" + + -- black holes + -- can we skip the indirection for black holes? + , "#define IS_BLACKHOLE(x) (typeof (x) === 'object' && (x) && (x).f && (x).f.t === CLOSURE_TYPE_BLACKHOLE)\n" + , "#define BLACKHOLE_TID(bh) ((bh).d1)\n" + , "#define SET_BLACKHOLE_TID(bh,tid) ((bh).d1 = (tid))\n" + , "#define BLACKHOLE_QUEUE(bh) ((bh).d2)\n" + , "#define SET_BLACKHOLE_QUEUE(bh,val) ((bh).d2 = (val))\n" + + -- resumable thunks + , "#define MAKE_RESUMABLE(closure,stack) { (closure).f = h$resume_e; (closure).d1 = (stack), (closure).d2 = null; }\n" + + -- making a thunk + , "#define MK_UPD_THUNK(closure) h$c1(h$upd_thunk_e,(closure))\n" + + -- general deconstruction + , "#define IS_THUNK(x) ((x).f.t === CLOSURE_TYPE_THUNK)\n" + , "#define CONSTR_TAG(x) ((x).f.a)\n" + + -- retrieve a numeric value that's possibly stored as an indirection + , "#define IS_WRAPPED_NUMBER(val) ((typeof(val)==='object')&&(val).f === h$unbox_e)\n" + , "#define UNWRAP_NUMBER(val) ((typeof(val) === 'number')?(val):(val).d1)\n" + + -- generic lazy values + , if profiling + then mconcat + [ "#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun), h$CCS_SYSTEM))\n" + , "#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun), (cc)))\n" + ] + else mconcat + [ "#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun)))\n" + , "#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun)))\n" + ] + + -- generic data constructors and selectors + , if profiling + then mconcat + [ "#define MK_DATA1_1(val) (h$c1(h$data1_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_DATA2_1(val) (h$c1(h$data2_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_DATA2_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_SELECT1(val) (h$c1(h$select1_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_SELECT2(val) (h$c1(h$select2_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_AP1(fun,val) (h$c2(h$ap1_e, (fun), (val), h$CCS_SYSTEM))\n" + , "#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e, (fun), (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3), h$CCS_SYSTEM))\n" + ] + else mconcat + [ "#define MK_DATA1_1(val) (h$c1(h$data1_e, (val)))\n" + , "#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2)))\n" + , "#define MK_DATA2_1(val) (h$c1(h$data2_e, (val)))\n" + , "#define MK_DATA2_2(val1,val2) (h$c2(h$data2_e, (val1), (val2)))\n" + , "#define MK_SELECT1(val) (h$c1(h$select1_e, (val)))\n" + , "#define MK_SELECT2(val) (h$c1(h$select2_e, (val)))\n" + , "#define MK_AP1(fun,val) (h$c2(h$ap1_e,(fun),(val)))\n" + , "#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e,(fun),(val1),(val2)))\n" + , "#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3)))\n" + ] + + -- unboxed tuple returns + -- , "#define RETURN_UBX_TUP1(x) return x;\n" + , "#define RETURN_UBX_TUP2(x1,x2) { h$ret1 = (x2); return (x1); }\n" + , "#define RETURN_UBX_TUP3(x1,x2,x3) { h$ret1 = (x2); h$ret2 = (x3); return (x1); }\n" + , "#define RETURN_UBX_TUP4(x1,x2,x3,x4) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); return (x1); }\n" + , "#define RETURN_UBX_TUP5(x1,x2,x3,x4,x5) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); return (x1); }\n" + , "#define RETURN_UBX_TUP6(x1,x2,x3,x4,x5,x6) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); return (x1); }\n" + , "#define RETURN_UBX_TUP7(x1,x2,x3,x4,x5,x6,x7) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); return (x1); }\n" + , "#define RETURN_UBX_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); return (x1); }\n" + , "#define RETURN_UBX_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); return (x1); }\n" + , "#define RETURN_UBX_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); h$ret9 = (x10); return (x1); }\n" + + , "#define RETURN_INT64(h,l) RETURN_UBX_TUP2((h)|0,(l)>>>0)\n" + , "#define RETURN_WORD64(h,l) RETURN_UBX_TUP2((h)>>>0,(l)>>>0)\n" + , "#define RETURN_ADDR(a,o) RETURN_UBX_TUP2(a,o)\n" + + , "#define CALL_UBX_TUP2(r1,r2,c) { (r1) = (c); (r2) = h$ret1; }\n" + , "#define CALL_UBX_TUP3(r1,r2,r3,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; }\n" + , "#define CALL_UBX_TUP4(r1,r2,r3,r4,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; }\n" + , "#define CALL_UBX_TUP5(r1,r2,r3,r4,r5,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; }\n" + , "#define CALL_UBX_TUP6(r1,r2,r3,r4,r5,r6,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; }\n" + , "#define CALL_UBX_TUP7(r1,r2,r3,r4,r5,r6,r7,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; }\n" + , "#define CALL_UBX_TUP8(r1,r2,r3,r4,r5,r6,r7,r8,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; }\n" + , "#define CALL_UBX_TUP9(r1,r2,r3,r4,r5,r6,r7,r8,r9,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; }\n" + , "#define CALL_UBX_TUP10(r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; (r10) = h$ret9; }\n" + ] + +-- | Construct the Filename for the "binary" of Haskell code compiled to +-- JavaScript. +jsExeFileName :: DynFlags -> FilePath +jsExeFileName dflags + | Just s <- outputFile_ dflags = + -- unmunge the extension + let s' = dropPrefix "js_" (drop 1 $ takeExtension s) + in if Prelude.null s' + then dropExtension s <.> jsexeExtension + else dropExtension s <.> s' + | otherwise = + if platformOS (targetPlatform dflags) == OSMinGW32 + then "main.jsexe" + else "a.jsexe" + where + dropPrefix prefix xs + | prefix `isPrefixOf` xs = drop (length prefix) xs + | otherwise = xs + +-- GHC produces string literals in ByteString. +-- When ByteString has all bytes UTF-8 compatbile we make attempt to +-- represent it as FastString. +-- Otherwise (for example when string literal encodes long integers or zero bytes) we +-- leave it as is. +-- Having zero bytes points that this literal never was assumed to be a Modified UTF8 compatible. +decodeModifiedUTF8 :: B.ByteString -> Maybe FastString +decodeModifiedUTF8 bs + | B.any (==0) bs = Nothing + | not $ B.isValidUtf8 bs = Nothing + | otherwise = Just . mkFastStringByteString $ bs diff --git a/GHC/StgToJS/Literal.hs b/GHC/StgToJS/Literal.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Literal.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.StgToJS.Literal + ( genLit + , genStaticLit + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.Make +import GHC.JS.Ident + +import GHC.StgToJS.Ids +import GHC.StgToJS.Monad +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types +import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8) + +import GHC.Types.Literal +import GHC.Types.Basic +import GHC.Types.RepType +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Float + +import Data.Bits as Bits +import Data.Char (ord) + +-- | Generate JS expressions for a Literal +-- +-- Literals represented with 2 values: +-- * Addr# (Null and Strings): array and offset +-- * 64-bit values: high 32-bit, low 32-bit +-- * labels: call to h$mkFunctionPtr and 0, or function name and 0 +genLit :: HasDebugCallStack => Literal -> G [JStgExpr] +genLit = \case + LitChar c -> return [ toJExpr (ord c) ] + LitString str -> + freshIdent >>= \strLit@(identFS -> strLitT) -> + freshIdent >>= \strOff@(identFS -> strOffT) -> do + emitStatic strLitT (StaticUnboxed (StaticUnboxedString str)) Nothing + emitStatic strOffT (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing + return [ Var strLit, Var strOff ] + LitNullAddr -> return [ null_, ValExpr (JInt 0) ] + LitNumber nt v -> case nt of + LitNumInt -> return [ toJExpr v ] + LitNumInt8 -> return [ toJExpr v ] + LitNumInt16 -> return [ toJExpr v ] + LitNumInt32 -> return [ toJExpr v ] + LitNumInt64 -> return [ toJExpr (Bits.shiftR v 32), toU32Expr v ] + LitNumWord -> return [ toU32Expr v ] + LitNumWord8 -> return [ toU32Expr v ] + LitNumWord16 -> return [ toU32Expr v ] + LitNumWord32 -> return [ toU32Expr v ] + LitNumWord64 -> return [ toU32Expr (Bits.shiftR v 32), toU32Expr v ] + LitNumBigNat -> panic "genLit: unexpected BigNat that should have been removed in CorePrep" + LitFloat r -> return [ toJExpr (r2f r) ] + LitDouble r -> return [ toJExpr (r2d r) ] + LitLabel name fod + | fod == IsFunction -> return [ ApplExpr hdMkFunctionPtr + [global (mkRawSymbol True name)] + , ValExpr (JInt 0) + ] + | otherwise -> return [ toJExpr (global (mkRawSymbol True name)) + , ValExpr (JInt 0) + ] + LitRubbish _ rr_ty -> + -- Generate appropriate rubbish literals, otherwise it might trip up the + -- code generator when a primop is applied to a rubbish literal (see #24664) + let reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genLit") rr_ty + rub = \case + BoxedRep _ -> [ null_ ] + AddrRep -> [ null_, ValExpr (JInt 0) ] + WordRep -> [ ValExpr (JInt 0) ] + Word8Rep -> [ ValExpr (JInt 0) ] + Word16Rep -> [ ValExpr (JInt 0) ] + Word32Rep -> [ ValExpr (JInt 0) ] + Word64Rep -> [ ValExpr (JInt 0), ValExpr (JInt 0) ] + IntRep -> [ ValExpr (JInt 0) ] + Int8Rep -> [ ValExpr (JInt 0) ] + Int16Rep -> [ ValExpr (JInt 0) ] + Int32Rep -> [ ValExpr (JInt 0) ] + Int64Rep -> [ ValExpr (JInt 0), ValExpr (JInt 0) ] + DoubleRep -> [ ValExpr (JInt 0) ] + FloatRep -> [ ValExpr (JInt 0) ] + VecRep _ _ -> panic "GHC.StgToJS.Literal.genLit: VecRep unsupported" + in return (concatMap rub reps) + +-- | generate a literal for the static init tables +genStaticLit :: Literal -> G [StaticLit] +genStaticLit = \case + LitChar c -> return [ IntLit (fromIntegral $ ord c) ] + LitString str -> case decodeModifiedUTF8 str of + Just t -> return [ StringLit t, IntLit 0] + -- invalid UTF8 + Nothing -> return [ BinLit str, IntLit 0] + LitNullAddr -> return [ NullLit, IntLit 0 ] + LitNumber nt v -> case nt of + LitNumInt -> return [ IntLit v ] + LitNumInt8 -> return [ IntLit v ] + LitNumInt16 -> return [ IntLit v ] + LitNumInt32 -> return [ IntLit v ] + LitNumInt64 -> return [ IntLit (v `Bits.shiftR` 32), toU32Lit v ] + LitNumWord -> return [ toU32Lit v ] + LitNumWord8 -> return [ toU32Lit v ] + LitNumWord16 -> return [ toU32Lit v ] + LitNumWord32 -> return [ toU32Lit v ] + LitNumWord64 -> return [ toU32Lit (v `Bits.shiftR` 32), toU32Lit v ] + LitNumBigNat -> panic "genStaticLit: unexpected BigNat that should have been removed in CorePrep" + LitFloat r -> return [ DoubleLit . SaneDouble . r2f $ r ] + LitDouble r -> return [ DoubleLit . SaneDouble . r2d $ r ] + LitLabel name fod -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name) + , IntLit 0 ] + LitRubbish _ rep -> + let prim_reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genStaticLit") rep + in case expectOnly prim_reps of -- Note [Post-unarisation invariants] + BoxedRep _ -> pure [ NullLit ] + AddrRep -> pure [ NullLit, IntLit 0 ] + IntRep -> pure [ IntLit 0 ] + Int8Rep -> pure [ IntLit 0 ] + Int16Rep -> pure [ IntLit 0 ] + Int32Rep -> pure [ IntLit 0 ] + Int64Rep -> pure [ IntLit 0, IntLit 0 ] + WordRep -> pure [ IntLit 0 ] + Word8Rep -> pure [ IntLit 0 ] + Word16Rep -> pure [ IntLit 0 ] + Word32Rep -> pure [ IntLit 0 ] + Word64Rep -> pure [ IntLit 0, IntLit 0 ] + FloatRep -> pure [ DoubleLit (SaneDouble 0) ] + DoubleRep -> pure [ DoubleLit (SaneDouble 0) ] + VecRep {} -> pprPanic "GHC.StgToJS.Literal.genStaticLit: LitRubbish(VecRep) isn't supported" (ppr rep) + +-- make an unsigned 32 bit number from this unsigned one, lower 32 bits +toU32Expr :: Integer -> JStgExpr +toU32Expr i = Int (i Bits..&. 0xFFFFFFFF) .>>>. 0 + +-- make an unsigned 32 bit number from this unsigned one, lower 32 bits +toU32Lit :: Integer -> StaticLit +toU32Lit i = IntLit (i Bits..&. 0xFFFFFFFF) + +r2d :: Rational -> Double +r2d = realToFrac + +r2f :: Rational -> Double +r2f = float2Double . realToFrac diff --git a/GHC/StgToJS/Monad.hs b/GHC/StgToJS/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Monad.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | JS codegen state monad +module GHC.StgToJS.Monad + ( runG + , emitGlobal + , addDependency + , emitToplevel + , emitStatic + , emitClosureInfo + , emitForeign + , assertRtsStat + , getSettings + , globalOccs + , setGlobalIdCache + , getGlobalIdCache + , GlobalOcc(..) + -- * Group + , modifyGroup + , resetGroup + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.Ident +import GHC.JS.Transform + +import GHC.StgToJS.Types + +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Stg.Syntax + +import GHC.Types.SrcLoc +import GHC.Types.Id +import GHC.Types.Unique.FM +import GHC.Types.ForeignCall + +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import qualified Data.Map as M +import qualified Data.Set as S + +runG :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> IO a +runG config m unfloat action = State.evalStateT action =<< initState config m unfloat + +initState :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> IO GenState +initState config m unfloat = do + id_gen <- newFastMutInt 1 + pure $ GenState + { gsSettings = config + , gsModule = m + , gsId = id_gen + , gsIdents = emptyIdCache + , gsUnfloated = unfloat + , gsGroup = defaultGenGroupState + , gsGlobal = [] + } + + +modifyGroup :: (GenGroupState -> GenGroupState) -> G () +modifyGroup f = State.modify mod_state + where + mod_state s = s { gsGroup = f (gsGroup s) } + +-- | emit a global (for the current module) toplevel statement +emitGlobal :: JStgStat -> G () +emitGlobal stat = State.modify (\s -> s { gsGlobal = stat : gsGlobal s }) + +-- | add a dependency on a particular symbol to the current group +addDependency :: OtherSymb -> G () +addDependency symbol = modifyGroup mod_group + where + mod_group g = g { ggsExtraDeps = S.insert symbol (ggsExtraDeps g) } + +-- | emit a top-level statement for the current binding group +emitToplevel :: JStgStat -> G () +emitToplevel s = modifyGroup mod_group + where + mod_group g = g { ggsToplevelStats = s : ggsToplevelStats g} + +-- | emit static data for the binding group +emitStatic :: FastString -> StaticVal -> Maybe Ident -> G () +emitStatic ident val cc = modifyGroup mod_group + where + mod_group g = g { ggsStatic = mod_static (ggsStatic g) } + mod_static s = StaticInfo ident val cc : s + +-- | add closure info in our binding group. all heap objects must have closure info +emitClosureInfo :: ClosureInfo -> G () +emitClosureInfo ci = modifyGroup mod_group + where + mod_group g = g { ggsClosureInfo = ci : ggsClosureInfo g} + +emitForeign :: Maybe RealSrcSpan + -> FastString + -> Safety + -> CCallConv + -> [FastString] + -> FastString + -> G () +emitForeign mbSpan pat safety cconv arg_tys res_ty = modifyGroup mod_group + where + mod_group g = g { ggsForeignRefs = new_ref : ggsForeignRefs g } + new_ref = ForeignJSRef spanTxt pat safety cconv arg_tys res_ty + spanTxt = case mbSpan of + -- TODO: Is there a better way to concatenate FastStrings? + Just sp -> mkFastString $ + unpackFS (srcSpanFile sp) ++ + " " ++ + show (srcSpanStartLine sp, srcSpanStartCol sp) ++ + "-" ++ + show (srcSpanEndLine sp, srcSpanEndCol sp) + Nothing -> "" + + + + + + +-- | start with a new binding group +resetGroup :: G () +resetGroup = State.modify (\s -> s { gsGroup = defaultGenGroupState }) + +defaultGenGroupState :: GenGroupState +defaultGenGroupState = GenGroupState [] [] [] [] 0 S.empty emptyGlobalIdCache [] + +emptyGlobalIdCache :: GlobalIdCache +emptyGlobalIdCache = GlobalIdCache emptyUFM + +emptyIdCache :: IdCache +emptyIdCache = IdCache M.empty + + + +assertRtsStat :: G JStgStat -> G JStgStat +assertRtsStat stat = do + s <- State.gets gsSettings + if csAssertRts s then stat else pure mempty + +getSettings :: G StgToJSConfig +getSettings = State.gets gsSettings + +getGlobalIdCache :: G GlobalIdCache +getGlobalIdCache = State.gets (ggsGlobalIdCache . gsGroup) + +setGlobalIdCache :: GlobalIdCache -> G () +setGlobalIdCache v = State.modify (\s -> s { gsGroup = (gsGroup s) { ggsGlobalIdCache = v}}) + +data GlobalOcc = GlobalOcc + { global_id :: !Id + , global_count :: !Word + } + +instance Outputable GlobalOcc where + ppr g = hang (text "GlobalOcc") 2 $ vcat + [ hcat [text "Id:", ppr (global_id g)] + , hcat [text "Count:", ppr (global_count g)] + ] + +-- | Return occurrences of every global id used in the given JStgStat. +-- Sort by increasing occurrence count. +globalOccs :: JStgStat -> G (UniqFM Id GlobalOcc) +globalOccs jst = do + GlobalIdCache gidc <- getGlobalIdCache + -- build a map form Ident Unique to (Id, Count) + -- Note that different Idents can map to the same Id (e.g. string payload and string offset idents) + let + inc g1 g2 = g1 { global_count = global_count g1 + global_count g2 } + + go :: UniqFM Id GlobalOcc -> [Ident] -> UniqFM Id GlobalOcc + go gids = \case + [] -> gids + (i:is) -> + -- check if the Id is global + case lookupUFM gidc i of + Nothing -> go gids is + Just (_k,gid) -> + -- add it to the list of already found global ids. Increasing + -- count by 1 + let g = GlobalOcc gid 1 + in go (addToUFM_C inc gids gid g) is + + pure $ go emptyUFM $ identsS jst diff --git a/GHC/StgToJS/Object.hs b/GHC/StgToJS/Object.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Object.hs @@ -0,0 +1,802 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} + +-- only for DB.Binary instances on Module +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Object +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Sylvain Henry +-- Jeffrey Young +-- Luite Stegeman +-- Josh Meredith +-- Stability : experimental +-- +-- Serialization/deserialization of binary .o files for the JavaScript backend +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Object + ( ObjectKind(..) + , getObjectKind + , getObjectKindBS + -- * JS object + , JSOptions(..) + , defaultJSOptions + , getOptionsFromJsFile + , writeJSObject + , readJSObject + , parseJSObject + , parseJSObjectBS + -- * HS object + , putObject + , getObjectHeader + , getObjectBody + , getObject + , readObject + , getObjectBlocks + , readObjectBlocks + , readObjectBlockInfo + , isGlobalBlock + , Object(..) + , IndexEntry(..) + , LocatedBlockInfo (..) + , BlockInfo (..) + , BlockDeps (..) + , BlockLocation (..) + , BlockId + , BlockIds + , BlockRef (..) + , ExportedFun (..) + ) +where + +import GHC.Prelude + +import Control.Monad + +import Data.Array +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import Data.Char (isSpace) +import Data.Int +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.List (sortOn) +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as M +import Data.Word +import Data.Semigroup +import System.IO + +import GHC.Settings.Constants (hiVersion) + +import GHC.JS.Ident +import qualified GHC.JS.Syntax as Sat +import GHC.StgToJS.Types + +import GHC.Unit.Module + +import GHC.Data.FastString + +import GHC.Types.Unique.Map + +import GHC.Utils.Binary hiding (SymbolTable) +import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text, hsep) +import GHC.Utils.Monad (mapMaybeM) +import GHC.Utils.Panic +import GHC.Utils.Misc (dropWhileEndLE) +import System.IO.Unsafe +import qualified Control.Exception as Exception + +---------------------------------------------- +-- The JS backend supports 3 kinds of objects: +-- 1. HS objects: produced from Haskell sources +-- 2. JS objects: produced from JS sources +-- 3. Cc objects: produced by emcc (e.g. from C sources) +-- +-- They all have a different header that allows them to be distinguished. +-- See ObjectKind type. +---------------------------------------------- + +-- | Different kinds of object (.o) supported by the JS backend +data ObjectKind + = ObjJs -- ^ JavaScript source embedded in a .o + | ObjHs -- ^ JS backend object for Haskell code + | ObjCc -- ^ Wasm module object as produced by emcc + deriving (Show,Eq,Ord) + +-- | Get the kind of a file object, if any +getObjectKind :: FilePath -> IO (Maybe ObjectKind) +getObjectKind fp = withBinaryFile fp ReadMode $ \h -> do + let !max_header_length = max (B.length jsHeader) + $ max (B.length wasmHeader) + (B.length hsHeader) + + bs <- B.hGet h max_header_length + pure $! getObjectKindBS bs + +-- | Get the kind of an object stored in a bytestring, if any +getObjectKindBS :: B.ByteString -> Maybe ObjectKind +getObjectKindBS bs + | jsHeader `B.isPrefixOf` bs = Just ObjJs + | hsHeader `B.isPrefixOf` bs = Just ObjHs + | wasmHeader `B.isPrefixOf` bs = Just ObjCc + | otherwise = Nothing + +-- Header added to JS sources to discriminate them from other object files. +-- They all have .o extension but JS sources have this header. +jsHeader :: B.ByteString +jsHeader = unsafePerformIO $ B.unsafePackAddressLen 8 "GHCJS_JS"# + +hsHeader :: B.ByteString +hsHeader = unsafePerformIO $ B.unsafePackAddressLen 8 "GHCJS_HS"# + +wasmHeader :: B.ByteString +wasmHeader = unsafePerformIO $ B.unsafePackAddressLen 4 "\0asm"# + + + +------------------------------------------------ +-- HS objects +-- +-- file layout: +-- - magic "GHCJS_HS" +-- - compiler version tag +-- - module name +-- - offsets of string table +-- - dependencies +-- - offset of the index +-- - unit infos +-- - index +-- - string table +-- +------------------------------------------------ + +-- | A HS object file +data Object = Object + { objModuleName :: !ModuleName + -- ^ name of the module + , objHandle :: !ReadBinHandle + -- ^ BinHandle that can be used to read the ObjBlocks + , objPayloadOffset :: !(Bin ObjBlock) + -- ^ Offset of the payload (units) + , objBlockInfo :: !BlockInfo + -- ^ Information about blocks + , objIndex :: !Index + -- ^ Block index: symbols per block and block offset in the object file + } + +type BlockId = Int +type BlockIds = IntSet + +-- | Information about blocks (linkable units) +data BlockInfo = BlockInfo + { bi_module :: !Module + -- ^ Module they were generated from + , bi_must_link :: !BlockIds + -- ^ blocks that always need to be linked when this object is loaded (e.g. + -- everything that contains initializer code or foreign exports) + , bi_exports :: !(Map ExportedFun BlockId) + -- ^ exported Haskell functions -> block + , bi_block_deps :: !(Array BlockId BlockDeps) + -- ^ dependencies of each block + } + +data LocatedBlockInfo = LocatedBlockInfo + { lbi_loc :: !BlockLocation -- ^ Where to find the blocks + , lbi_info :: !BlockInfo -- ^ Block information + } + +instance Outputable BlockInfo where + ppr d = vcat + [ hcat [ text "module: ", pprModule (bi_module d) ] + , hcat [ text "exports: ", ppr (M.keys (bi_exports d)) ] + ] + +-- | Where are the blocks +data BlockLocation + = ObjectFile FilePath -- ^ In an object file at path + | ArchiveFile FilePath -- ^ In a Ar file at path + | InMemory String Object -- ^ In memory + +instance Outputable BlockLocation where + ppr = \case + ObjectFile fp -> hsep [text "ObjectFile", text fp] + ArchiveFile fp -> hsep [text "ArchiveFile", text fp] + InMemory s o -> hsep [text "InMemory", text s, ppr (objModuleName o)] + +-- | A @BlockRef@ is a pair of a module and the index of the block in the +-- object file +data BlockRef = BlockRef + { block_ref_mod :: !Module -- ^ Module + , block_ref_idx :: !BlockId -- ^ Block index in the object file + } + deriving (Eq,Ord) + +data BlockDeps = BlockDeps + { blockBlockDeps :: [BlockId] -- ^ dependencies on blocks in this object + , blockFunDeps :: [ExportedFun] -- ^ dependencies on exported symbols in other objects + -- , blockForeignExported :: [ExpFun] + -- , blockForeignImported :: [ForeignRef] + } + +-- | we use the convention that the first block (0) is a module-global block +-- that's always included when something from the module is loaded. everything +-- in a module implicitly depends on the global block. The global block itself +-- can't have dependencies +isGlobalBlock :: BlockId -> Bool +isGlobalBlock n = n == 0 + +-- | Exported Functions +data ExportedFun = ExportedFun + { funModule :: !Module -- ^ The module containing the function + , funSymbol :: !LexicalFastString -- ^ The function + } deriving (Eq, Ord) + +instance Outputable ExportedFun where + ppr (ExportedFun m f) = vcat + [ hcat [ text "module: ", pprModule m ] + , hcat [ text "symbol: ", ppr f ] + ] + +-- | Write an ObjBlock, except for the top level symbols which are stored in the +-- index +putObjBlock :: WriteBinHandle -> ObjBlock -> IO () +putObjBlock bh (ObjBlock _syms b c d e f g) = do + lazyPut bh b + lazyPut bh c + lazyPut bh d + lazyPut bh e + lazyPut bh f + lazyPut bh g + +-- | Read an ObjBlock and associate it to the given symbols (that must have been +-- read from the index) +getObjBlock :: [FastString] -> ReadBinHandle -> IO ObjBlock +getObjBlock syms bh = do + b <- lazyGet bh + c <- lazyGet bh + d <- lazyGet bh + e <- lazyGet bh + f <- lazyGet bh + g <- lazyGet bh + pure $ ObjBlock + { oiSymbols = syms + , oiClInfo = b + , oiStatic = c + , oiStat = d + , oiRaw = e + , oiFExports = f + , oiFImports = g + } + + +-- | Serialized block indexes and their exported symbols +-- (the first block is module-global) +type Index = [IndexEntry] +data IndexEntry = IndexEntry + { idxSymbols :: ![FastString] -- ^ Symbols exported by a block + , idxOffset :: !(Bin ObjBlock) -- ^ Offset of the block in the object file + } + + +-------------------------------------------------------------------------------- +-- Essential operations on Objects +-------------------------------------------------------------------------------- + +-- | Given a handle to a Binary payload, add the module, 'mod_name', its +-- dependencies, 'deps', and its linkable units to the payload. +putObject + :: WriteBinHandle + -> ModuleName -- ^ module + -> BlockInfo -- ^ block infos + -> [ObjBlock] -- ^ linkable units and their symbols + -> IO () +putObject bh mod_name deps os = do + putByteString bh hsHeader + put_ bh (show hiVersion) + + -- we store the module name as a String because we don't want to have to + -- decode the FastString table just to decode it when we're looking for an + -- object in an archive. + put_ bh (moduleNameString mod_name) + + (fs_tbl, fs_writer) <- initFastStringWriterTable + let bh_fs = addWriterToUserData fs_writer bh + + forwardPut_ bh (const (putTable fs_tbl bh_fs)) $ do + put_ bh_fs deps + + -- forward put the index + forwardPut_ bh_fs (put_ bh_fs) $ do + idx <- forM os $ \o -> do + p <- tellBinWriter bh_fs + -- write units without their symbols + putObjBlock bh_fs o + -- return symbols and offset to store in the index + pure (oiSymbols o,p) + pure idx + +-- | Parse object header +getObjectHeader :: ReadBinHandle -> IO (Either String ModuleName) +getObjectHeader bh = do + magic <- getByteString bh (B.length hsHeader) + case magic == hsHeader of + False -> pure (Left "invalid magic header for HS object") + True -> do + is_correct_version <- ((== hiVersion) . read) <$> get bh + case is_correct_version of + False -> pure (Left "invalid header version") + True -> do + mod_name <- get bh + pure (Right (mkModuleName (mod_name))) + + +-- | Parse object body. Must be called after a successful getObjectHeader +getObjectBody :: ReadBinHandle -> ModuleName -> IO Object +getObjectBody bh0 mod_name = do + -- Read the string table + dict <- forwardGet bh0 (getDictionary bh0) + let bh = setReaderUserData bh0 $ newReadState (panic "No name allowed") (getDictFastString dict) + + block_info <- get bh + idx <- forwardGet bh (get bh) + payload_pos <- tellBinReader bh + + pure $ Object + { objModuleName = mod_name + , objHandle = bh + , objPayloadOffset = payload_pos + , objBlockInfo = block_info + , objIndex = idx + } + +-- | Parse object +getObject :: ReadBinHandle -> IO (Maybe Object) +getObject bh = do + getObjectHeader bh >>= \case + Left _err -> pure Nothing + Right mod_name -> Just <$> getObjectBody bh mod_name + +-- | Read object from file +-- +-- The object is still in memory after this (see objHandle). +readObject :: FilePath -> IO (Maybe Object) +readObject file = do + bh <- readBinMem file + getObject bh + +-- | Reads only the part necessary to get the block info +readObjectBlockInfo :: FilePath -> IO (Maybe BlockInfo) +readObjectBlockInfo file = do + bh <- readBinMem file + getObject bh >>= \case + Just obj -> pure $! Just $! objBlockInfo obj + Nothing -> pure Nothing + +-- | Get blocks in the object file, using the given filtering function +getObjectBlocks :: Object -> BlockIds -> IO [ObjBlock] +getObjectBlocks obj bids = mapMaybeM read_entry (zip (objIndex obj) [0..]) + where + bh = objHandle obj + read_entry (IndexEntry syms offset,i) + | IS.member i bids = do + seekBinReader bh offset + Just <$> getObjBlock syms bh + | otherwise = pure Nothing + +-- | Read blocks in the object file, using the given filtering function +readObjectBlocks :: FilePath -> BlockIds -> IO [ObjBlock] +readObjectBlocks file bids = do + readObject file >>= \case + Nothing -> pure [] + Just obj -> getObjectBlocks obj bids + + +-------------------------------------------------------------------------------- +-- Helper functions +-------------------------------------------------------------------------------- + +putEnum :: Enum a => WriteBinHandle -> a -> IO () +putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n) + | otherwise = put_ bh n + where n = fromIntegral $ fromEnum x :: Word16 + +getEnum :: Enum a => ReadBinHandle -> IO a +getEnum bh = toEnum . fromIntegral <$> (get bh :: IO Word16) + +-- | Helper to convert Int to Int32 +toI32 :: Int -> Int32 +toI32 = fromIntegral + +-- | Helper to convert Int32 to Int +fromI32 :: Int32 -> Int +fromI32 = fromIntegral + + +-------------------------------------------------------------------------------- +-- Binary Instances +-------------------------------------------------------------------------------- + +instance Binary IndexEntry where + put_ bh (IndexEntry a b) = put_ bh a >> put_ bh b + get bh = IndexEntry <$> get bh <*> get bh + +instance Binary BlockInfo where + put_ bh (BlockInfo m r e b) = do + put_ bh m + put_ bh (map toI32 $ IS.toList r) + put_ bh (map (\(x,y) -> (x, toI32 y)) $ M.toList e) + put_ bh (elems b) + get bh = BlockInfo <$> get bh + <*> (IS.fromList . map fromI32 <$> get bh) + <*> (M.fromList . map (\(x,y) -> (x, fromI32 y)) <$> get bh) + <*> ((\xs -> listArray (0, length xs - 1) xs) <$> get bh) + +instance Binary BlockDeps where + put_ bh (BlockDeps bbd bfd) = put_ bh bbd >> put_ bh bfd + get bh = BlockDeps <$> get bh <*> get bh + +instance Binary ForeignJSRef where + put_ bh (ForeignJSRef span pat safety cconv arg_tys res_ty) = + put_ bh span >> put_ bh pat >> putEnum bh safety >> putEnum bh cconv >> put_ bh arg_tys >> put_ bh res_ty + get bh = ForeignJSRef <$> get bh <*> get bh <*> getEnum bh <*> getEnum bh <*> get bh <*> get bh + +instance Binary ExpFun where + put_ bh (ExpFun isIO args res) = put_ bh isIO >> put_ bh args >> put_ bh res + get bh = ExpFun <$> get bh <*> get bh <*> get bh + +instance Binary Sat.JStat where + put_ bh (Sat.DeclStat i e) = putByte bh 1 >> put_ bh i >> put_ bh e + put_ bh (Sat.ReturnStat e) = putByte bh 2 >> put_ bh e + put_ bh (Sat.IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 + put_ bh (Sat.WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s + put_ bh (Sat.ForStat is c s bd) = putByte bh 5 >> put_ bh is >> put_ bh c >> put_ bh s >> put_ bh bd + put_ bh (Sat.ForInStat b i e s) = putByte bh 6 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s + put_ bh (Sat.SwitchStat e ss s) = putByte bh 7 >> put_ bh e >> put_ bh ss >> put_ bh s + put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 8 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 + put_ bh (Sat.BlockStat xs) = putByte bh 9 >> put_ bh xs + put_ bh (Sat.ApplStat e es) = putByte bh 10 >> put_ bh e >> put_ bh es + put_ bh (Sat.UOpStat o e) = putByte bh 11 >> put_ bh o >> put_ bh e + put_ bh (Sat.AssignStat e1 op e2) = putByte bh 12 >> put_ bh e1 >> put_ bh op >> put_ bh e2 + put_ bh (Sat.LabelStat l s) = putByte bh 13 >> put_ bh l >> put_ bh s + put_ bh (Sat.BreakStat ml) = putByte bh 14 >> put_ bh ml + put_ bh (Sat.ContinueStat ml) = putByte bh 15 >> put_ bh ml + put_ bh (Sat.FuncStat i is b) = putByte bh 16 >> put_ bh i >> put_ bh is >> put_ bh b + get bh = getByte bh >>= \case + 1 -> Sat.DeclStat <$> get bh <*> get bh + 2 -> Sat.ReturnStat <$> get bh + 3 -> Sat.IfStat <$> get bh <*> get bh <*> get bh + 4 -> Sat.WhileStat <$> get bh <*> get bh <*> get bh + 5 -> Sat.ForStat <$> get bh <*> get bh <*> get bh <*> get bh + 6 -> Sat.ForInStat <$> get bh <*> get bh <*> get bh <*> get bh + 7 -> Sat.SwitchStat <$> get bh <*> get bh <*> get bh + 8 -> Sat.TryStat <$> get bh <*> get bh <*> get bh <*> get bh + 9 -> Sat.BlockStat <$> get bh + 10 -> Sat.ApplStat <$> get bh <*> get bh + 11 -> Sat.UOpStat <$> get bh <*> get bh + 12 -> Sat.AssignStat <$> get bh <*> get bh <*> get bh + 13 -> Sat.LabelStat <$> get bh <*> get bh + 14 -> Sat.BreakStat <$> get bh + 15 -> Sat.ContinueStat <$> get bh + 16 -> Sat.FuncStat <$> get bh <*> get bh <*> get bh + n -> error ("Binary get bh JStat: invalid tag: " ++ show n) + + +instance Binary Sat.JExpr where + put_ bh (Sat.ValExpr v) = putByte bh 1 >> put_ bh v + put_ bh (Sat.SelExpr e i) = putByte bh 2 >> put_ bh e >> put_ bh i + put_ bh (Sat.IdxExpr e1 e2) = putByte bh 3 >> put_ bh e1 >> put_ bh e2 + put_ bh (Sat.InfixExpr o e1 e2) = putByte bh 4 >> put_ bh o >> put_ bh e1 >> put_ bh e2 + put_ bh (Sat.UOpExpr o e) = putByte bh 5 >> put_ bh o >> put_ bh e + put_ bh (Sat.IfExpr e1 e2 e3) = putByte bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3 + put_ bh (Sat.ApplExpr e es) = putByte bh 7 >> put_ bh e >> put_ bh es + get bh = getByte bh >>= \case + 1 -> Sat.ValExpr <$> get bh + 2 -> Sat.SelExpr <$> get bh <*> get bh + 3 -> Sat.IdxExpr <$> get bh <*> get bh + 4 -> Sat.InfixExpr <$> get bh <*> get bh <*> get bh + 5 -> Sat.UOpExpr <$> get bh <*> get bh + 6 -> Sat.IfExpr <$> get bh <*> get bh <*> get bh + 7 -> Sat.ApplExpr <$> get bh <*> get bh + n -> error ("Binary get bh UnsatExpr: invalid tag: " ++ show n) + + +instance Binary Sat.JVal where + put_ bh (Sat.JVar i) = putByte bh 1 >> put_ bh i + put_ bh (Sat.JList es) = putByte bh 2 >> put_ bh es + put_ bh (Sat.JDouble d) = putByte bh 3 >> put_ bh d + put_ bh (Sat.JInt i) = putByte bh 4 >> put_ bh i + put_ bh (Sat.JStr xs) = putByte bh 5 >> put_ bh xs + put_ bh (Sat.JRegEx xs) = putByte bh 6 >> put_ bh xs + put_ bh (Sat.JBool b) = putByte bh 7 >> put_ bh b + put_ bh (Sat.JHash m) = putByte bh 8 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m) + put_ bh (Sat.JFunc is s) = putByte bh 9 >> put_ bh is >> put_ bh s + get bh = getByte bh >>= \case + 1 -> Sat.JVar <$> get bh + 2 -> Sat.JList <$> get bh + 3 -> Sat.JDouble <$> get bh + 4 -> Sat.JInt <$> get bh + 5 -> Sat.JStr <$> get bh + 6 -> Sat.JRegEx <$> get bh + 7 -> Sat.JBool <$> get bh + 8 -> Sat.JHash . listToUniqMap <$> get bh + 9 -> Sat.JFunc <$> get bh <*> get bh + n -> error ("Binary get bh Sat.JVal: invalid tag: " ++ show n) + +instance Binary Ident where + put_ bh (identFS -> xs) = put_ bh xs + get bh = name <$> get bh + +instance Binary ClosureInfo where + put_ bh (ClosureInfo v regs name layo typ static) = do + put_ bh v >> put_ bh regs >> put_ bh name >> put_ bh layo >> put_ bh typ >> put_ bh static + get bh = ClosureInfo <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh + +instance Binary JSFFIType where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary JSRep where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary CIRegs where + put_ bh CIRegsUnknown = putByte bh 1 + put_ bh (CIRegs skip types) = putByte bh 2 >> put_ bh skip >> put_ bh types + get bh = getByte bh >>= \case + 1 -> pure CIRegsUnknown + 2 -> CIRegs <$> get bh <*> get bh + n -> error ("Binary get bh CIRegs: invalid tag: " ++ show n) + +instance Binary Sat.Op where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary Sat.UOp where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary Sat.AOp where + put_ bh = putEnum bh + get bh = getEnum bh + +-- 16 bit sizes should be enough... +instance Binary CILayout where + put_ bh CILayoutVariable = putByte bh 1 + put_ bh (CILayoutUnknown size) = putByte bh 2 >> put_ bh size + put_ bh (CILayoutFixed size types) = putByte bh 3 >> put_ bh size >> put_ bh types + get bh = getByte bh >>= \case + 1 -> pure CILayoutVariable + 2 -> CILayoutUnknown <$> get bh + 3 -> CILayoutFixed <$> get bh <*> get bh + n -> error ("Binary get bh CILayout: invalid tag: " ++ show n) + +instance Binary CIStatic where + put_ bh (CIStaticRefs refs) = putByte bh 1 >> put_ bh refs + get bh = getByte bh >>= \case + 1 -> CIStaticRefs <$> get bh + n -> error ("Binary get bh CIStatic: invalid tag: " ++ show n) + +instance Binary CIType where + put_ bh (CIFun arity regs) = putByte bh 1 >> put_ bh arity >> put_ bh regs + put_ bh CIThunk = putByte bh 2 + put_ bh (CICon conTag) = putByte bh 3 >> put_ bh conTag + put_ bh CIPap = putByte bh 4 + put_ bh CIBlackhole = putByte bh 5 + put_ bh CIStackFrame = putByte bh 6 + get bh = getByte bh >>= \case + 1 -> CIFun <$> get bh <*> get bh + 2 -> pure CIThunk + 3 -> CICon <$> get bh + 4 -> pure CIPap + 5 -> pure CIBlackhole + 6 -> pure CIStackFrame + n -> error ("Binary get bh CIType: invalid tag: " ++ show n) + +instance Binary ExportedFun where + put_ bh (ExportedFun modu symb) = put_ bh modu >> put_ bh symb + get bh = ExportedFun <$> get bh <*> get bh + +instance Binary StaticInfo where + put_ bh (StaticInfo ident val cc) = put_ bh ident >> put_ bh val >> put_ bh cc + get bh = StaticInfo <$> get bh <*> get bh <*> get bh + +instance Binary StaticVal where + put_ bh (StaticApp SAKFun f args) = putByte bh 1 >> put_ bh f >> put_ bh args + put_ bh (StaticApp SAKThunk f args) = putByte bh 2 >> put_ bh f >> put_ bh args + put_ bh (StaticUnboxed u) = putByte bh 3 >> put_ bh u + put_ bh (StaticApp SAKData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args + put_ bh (StaticList xs t) = putByte bh 5 >> put_ bh xs >> put_ bh t + get bh = getByte bh >>= \case + 1 -> StaticApp SAKFun <$> get bh <*> get bh + 2 -> StaticApp SAKThunk <$> get bh <*> get bh + 3 -> StaticUnboxed <$> get bh + 4 -> StaticApp SAKData <$> get bh <*> get bh + 5 -> StaticList <$> get bh <*> get bh + n -> error ("Binary get bh StaticVal: invalid tag " ++ show n) + +instance Binary StaticUnboxed where + put_ bh (StaticUnboxedBool b) = putByte bh 1 >> put_ bh b + put_ bh (StaticUnboxedInt i) = putByte bh 2 >> put_ bh i + put_ bh (StaticUnboxedDouble d) = putByte bh 3 >> put_ bh d + put_ bh (StaticUnboxedString str) = putByte bh 4 >> put_ bh str + put_ bh (StaticUnboxedStringOffset str) = putByte bh 5 >> put_ bh str + get bh = getByte bh >>= \case + 1 -> StaticUnboxedBool <$> get bh + 2 -> StaticUnboxedInt <$> get bh + 3 -> StaticUnboxedDouble <$> get bh + 4 -> StaticUnboxedString <$> get bh + 5 -> StaticUnboxedStringOffset <$> get bh + n -> error ("Binary get bh StaticUnboxed: invalid tag " ++ show n) + +instance Binary StaticArg where + put_ bh (StaticObjArg i) = putByte bh 1 >> put_ bh i + put_ bh (StaticLitArg p) = putByte bh 2 >> put_ bh p + put_ bh (StaticConArg c args) = putByte bh 3 >> put_ bh c >> put_ bh args + get bh = getByte bh >>= \case + 1 -> StaticObjArg <$> get bh + 2 -> StaticLitArg <$> get bh + 3 -> StaticConArg <$> get bh <*> get bh + n -> error ("Binary get bh StaticArg: invalid tag " ++ show n) + +instance Binary StaticLit where + put_ bh (BoolLit b) = putByte bh 1 >> put_ bh b + put_ bh (IntLit i) = putByte bh 2 >> put_ bh i + put_ bh NullLit = putByte bh 3 + put_ bh (DoubleLit d) = putByte bh 4 >> put_ bh d + put_ bh (StringLit t) = putByte bh 5 >> put_ bh t + put_ bh (BinLit b) = putByte bh 6 >> put_ bh b + put_ bh (LabelLit b t) = putByte bh 7 >> put_ bh b >> put_ bh t + get bh = getByte bh >>= \case + 1 -> BoolLit <$> get bh + 2 -> IntLit <$> get bh + 3 -> pure NullLit + 4 -> DoubleLit <$> get bh + 5 -> StringLit <$> get bh + 6 -> BinLit <$> get bh + 7 -> LabelLit <$> get bh <*> get bh + n -> error ("Binary get bh StaticLit: invalid tag " ++ show n) + + +------------------------------------------------ +-- JS objects +------------------------------------------------ + +-- | Options obtained from pragmas in JS files +data JSOptions = JSOptions + { enableCPP :: !Bool -- ^ Enable CPP on the JS file + , emccExtraOptions :: ![String] -- ^ Pass additional options to emcc at link time + , emccExportedFunctions :: ![String] -- ^ Arguments for `-sEXPORTED_FUNCTIONS` + , emccExportedRuntimeMethods :: ![String] -- ^ Arguments for `-sEXPORTED_RUNTIME_METHODS` + } + deriving (Eq, Ord) + + +instance Binary JSOptions where + put_ bh (JSOptions a b c d) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh d + get bh = JSOptions <$> get bh <*> get bh <*> get bh <*> get bh + +instance Semigroup JSOptions where + a <> b = JSOptions + { enableCPP = enableCPP a || enableCPP b + , emccExtraOptions = emccExtraOptions a ++ emccExtraOptions b + , emccExportedFunctions = List.nub (List.sort (emccExportedFunctions a ++ emccExportedFunctions b)) + , emccExportedRuntimeMethods = List.nub (List.sort (emccExportedRuntimeMethods a ++ emccExportedRuntimeMethods b)) + } + +defaultJSOptions :: JSOptions +defaultJSOptions = JSOptions + { enableCPP = False + , emccExtraOptions = [] + , emccExportedRuntimeMethods = [] + , emccExportedFunctions = [] + } + +-- mimics `lines` implementation +splitOnComma :: String -> [String] +splitOnComma s = cons $ case break (== ',') s of + (l, s') -> (l, case s' of + [] -> [] + _:s'' -> splitOnComma s'') + where + cons ~(h, t) = h : t + + + +-- | Get the JS option pragmas from .js files +getJsOptions :: Handle -> IO JSOptions +getJsOptions handle = do + hSetEncoding handle utf8 + let trim = dropWhileEndLE isSpace . dropWhile isSpace + let go opts = do + hIsEOF handle >>= \case + True -> pure opts + False -> do + xs <- hGetLine handle + if not ("//#OPTIONS:" `List.isPrefixOf` xs) + then pure opts + else do + -- drop prefix and spaces + let ys = trim (drop 11 xs) + let opts' = if + | ys == "CPP" + -> opts {enableCPP = True} + + | Just s <- List.stripPrefix "EMCC:EXPORTED_FUNCTIONS=" ys + , fns <- fmap trim (splitOnComma s) + -> opts { emccExportedFunctions = emccExportedFunctions opts ++ fns } + + | Just s <- List.stripPrefix "EMCC:EXPORTED_RUNTIME_METHODS=" ys + , fns <- fmap trim (splitOnComma s) + -> opts { emccExportedRuntimeMethods = emccExportedRuntimeMethods opts ++ fns } + + | Just s <- List.stripPrefix "EMCC:EXTRA=" ys + -> opts { emccExtraOptions = emccExtraOptions opts ++ [s] } + + | otherwise + -> panic ("Unrecognized JS pragma: " ++ ys) + + go opts' + go defaultJSOptions + +-- | Parse option pragma in JS file +getOptionsFromJsFile :: FilePath -- ^ Input file + -> IO JSOptions -- ^ Parsed options. +getOptionsFromJsFile filename + = Exception.bracket + (openBinaryFile filename ReadMode) + hClose + getJsOptions + + +-- | Write a JS object (embed some handwritten JS code) +writeJSObject :: JSOptions -> B.ByteString -> FilePath -> IO () +writeJSObject opts contents output_fn = do + bh <- openBinMem (B.length contents + 1000) + + putByteString bh jsHeader + put_ bh opts + put_ bh contents + + writeBinMem bh output_fn + + +-- | Read a JS object from BinHandle +parseJSObject :: ReadBinHandle -> IO (JSOptions, B.ByteString) +parseJSObject bh = do + magic <- getByteString bh (B.length jsHeader) + case magic == jsHeader of + False -> panic "invalid magic header for JS object" + True -> do + opts <- get bh + contents <- get bh + pure (opts,contents) + +-- | Read a JS object from ByteString +parseJSObjectBS :: B.ByteString -> IO (JSOptions, B.ByteString) +parseJSObjectBS bs = do + bh <- unsafeUnpackBinBuffer bs + parseJSObject bh + +-- | Read a JS object from file +readJSObject :: FilePath -> IO (JSOptions, B.ByteString) +readJSObject input_fn = do + bh <- readBinMem input_fn + parseJSObject bh diff --git a/GHC/StgToJS/Prim.hs b/GHC/StgToJS/Prim.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Prim.hs @@ -0,0 +1,1697 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} + +-- disable this warning because of all the lambdas matching on primops' +-- arguments. +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.StgToJS.Prim + ( genPrim + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax hiding (YieldOp) +import GHC.JS.JStg.Monad +import GHC.JS.Make +import GHC.JS.Ident + +import GHC.StgToJS.Heap +import GHC.StgToJS.Types +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.Symbols + +import GHC.Core.Type + +import GHC.Builtin.PrimOps +import GHC.Tc.Utils.TcType (isBoolTy) +import GHC.Utils.Encoding (zEncodeString) + +import GHC.Data.FastString +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) + +genPrim :: Bool -- ^ Profiling (cost-centres) enabled + -> Bool -- ^ Array bounds-checking enabled + -> Type + -> PrimOp -- ^ the primitive operation + -> [JStgExpr] -- ^ where to store the result + -> [JStgExpr] -- ^ arguments + -> JSM PrimRes +genPrim prof bound ty op = case op of + CharGtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + CharGeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + CharEqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + CharNeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + CharLtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + CharLeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + OrdOp -> \[r] [x] -> pure $ PrimInline $ r |= x + + Int8ToWord8Op -> \[r] [x] -> pure $ PrimInline $ r |= mask8 x + Word8ToInt8Op -> \[r] [x] -> pure $ PrimInline $ r |= signExtend8 x + Int16ToWord16Op -> \[r] [x] -> pure $ PrimInline $ r |= mask16 x + Word16ToInt16Op -> \[r] [x] -> pure $ PrimInline $ r |= signExtend16 x + Int32ToWord32Op -> \[r] [x] -> pure $ PrimInline $ r |= x .>>>. zero_ + Word32ToInt32Op -> \[r] [x] -> pure $ PrimInline $ r |= toI32 x + +------------------------------ Int ---------------------------------------------- + + IntAddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= toI32 (Add x y) + IntSubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= toI32 (Sub x y) + IntMulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= app hdMulImulStr [x, y] + IntMul2Op -> \[c,hr,lr] [x,y] -> pure $ PrimInline $ appT [c,hr,lr] hdHsTimesInt2Str [x, y] + IntMulMayOfloOp -> \[r] [x,y] -> do + PrimInline <$> + jVar \tmp -> + pure $ mconcat + [ tmp |= Mul x y + , r |= if01 (tmp .===. toI32 tmp) + ] + IntQuotOp -> \[r] [x,y] -> pure $ PrimInline $ r |= toI32 (Div x y) + IntRemOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Mod x y + IntQuotRemOp -> \[q,r] [x,y] -> pure $ PrimInline $ mconcat + [ q |= toI32 (Div x y) + , r |= x `Sub` (Mul y q) + ] + IntAndOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BAnd x y + IntOrOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BOr x y + IntXorOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BXor x y + IntNotOp -> \[r] [x] -> pure $ PrimInline $ r |= BNot x + + IntNegOp -> \[r] [x] -> pure $ PrimInline $ r |= toI32 (Negate x) +-- add with carry: overflow == 0 iff no overflow + IntAddCOp -> \[r,overf] [x,y] -> + PrimInline <$> + jVar \tmp -> + pure $ mconcat + [ tmp |= Add x y + , r |= toI32 tmp + , overf |= if10 (r .!=. tmp) + ] + IntSubCOp -> \[r,overf] [x,y] -> + PrimInline <$> + jVar \tmp -> + pure $ mconcat + [ tmp |= Sub x y + , r |= toI32 tmp + , overf |= if10 (r .!=. tmp) + ] + IntGtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + IntGeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + IntEqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + IntNeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + IntLtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + IntLeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + ChrOp -> \[r] [x] -> pure $ PrimInline $ r |= x + IntToWordOp -> \[r] [x] -> pure $ PrimInline $ r |= x .>>>. zero_ + IntToFloatOp -> \[r] [x] -> pure $ PrimInline $ r |= x + IntToDoubleOp -> \[r] [x] -> pure $ PrimInline $ r |= x + IntSllOp -> \[r] [x,y] -> pure $ PrimInline $ r |= x .<<. y + IntSraOp -> \[r] [x,y] -> pure $ PrimInline $ r |= x .>>. y + IntSrlOp -> \[r] [x,y] -> pure $ PrimInline $ r |= toI32 (x .>>>. y) + +------------------------------ Int8 --------------------------------------------- + + Int8ToIntOp -> \[r] [x] -> pure $ PrimInline $ r |= x + IntToInt8Op -> \[r] [x] -> pure $ PrimInline $ r |= signExtend8 x + Int8NegOp -> \[r] [x] -> pure $ PrimInline $ r |= signExtend8 (Negate x) + Int8AddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend8 (Add x y) + Int8SubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend8 (Sub x y) + Int8MulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend8 (Mul x y) + Int8QuotOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend8 (quotShortInt 8 x y) + Int8RemOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend8 (remShortInt 8 x y) + Int8QuotRemOp -> \[r1,r2] [x,y] -> pure $ PrimInline $ mconcat + [ r1 |= signExtend8 (quotShortInt 8 x y) + , r2 |= signExtend8 (remShortInt 8 x y) + ] + Int8EqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + Int8GeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 24)) .>=. (y .<<. (Int 24))) + Int8GtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 24)) .>. (y .<<. (Int 24))) + Int8LeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 24)) .<=. (y .<<. (Int 24))) + Int8LtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 24)) .<. (y .<<. (Int 24))) + Int8NeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + + Int8SraOp -> \[r] [x,i] -> pure $ PrimInline $ r |= x .>>. i + Int8SrlOp -> \[r] [x,i] -> pure $ PrimInline $ r |= signExtend8 (mask8 x .>>>. i) + Int8SllOp -> \[r] [x,i] -> pure $ PrimInline $ r |= signExtend8 (mask8 (x .<<. i)) + +------------------------------ Word8 -------------------------------------------- + + Word8ToWordOp -> \[r] [x] -> pure $ PrimInline $ r |= mask8 x + WordToWord8Op -> \[r] [x] -> pure $ PrimInline $ r |= mask8 x + + Word8AddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask8 (Add x y) + Word8SubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask8 (Sub x y) + Word8MulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask8 (Mul x y) + Word8QuotOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask8 (Div x y) + Word8RemOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Mod x y + Word8QuotRemOp -> \[r1,r2] [x,y] -> pure $ PrimInline $ mconcat + [ r1 |= toI32 (Div x y) + , r2 |= Mod x y + ] + Word8EqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + Word8GeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + Word8GtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + Word8LeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + Word8LtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + Word8NeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + + Word8AndOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BAnd x y + Word8OrOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BOr x y + Word8XorOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BXor x y + Word8NotOp -> \[r] [x] -> pure $ PrimInline $ r |= BXor x (Int 0xff) + + Word8SllOp -> \[r] [x,i] -> pure $ PrimInline $ r |= mask8 (x .<<. i) + Word8SrlOp -> \[r] [x,i] -> pure $ PrimInline $ r |= x .>>>. i + +------------------------------ Int16 ------------------------------------------- + + Int16ToIntOp -> \[r] [x] -> pure $ PrimInline $ r |= x + IntToInt16Op -> \[r] [x] -> pure $ PrimInline $ r |= signExtend16 x + + Int16NegOp -> \[r] [x] -> pure $ PrimInline $ r |= signExtend16 (Negate x) + Int16AddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend16 (Add x y) + Int16SubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend16 (Sub x y) + Int16MulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend16 (Mul x y) + Int16QuotOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend16 (quotShortInt 16 x y) + Int16RemOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend16 (remShortInt 16 x y) + Int16QuotRemOp -> \[r1,r2] [x,y] -> pure $ PrimInline $ mconcat + [ r1 |= signExtend16 (quotShortInt 16 x y) + , r2 |= signExtend16 (remShortInt 16 x y) + ] + Int16EqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + Int16GeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 16)) .>=. (y .<<. (Int 16))) + Int16GtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 16)) .>. (y .<<. (Int 16))) + Int16LeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 16)) .<=. (y .<<. (Int 16))) + Int16LtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 16)) .<. (y .<<. (Int 16))) + Int16NeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + + Int16SraOp -> \[r] [x,i] -> pure $ PrimInline $ r |= x .>>. i + Int16SrlOp -> \[r] [x,i] -> pure $ PrimInline $ r |= signExtend16 (mask16 x .>>>. i) + Int16SllOp -> \[r] [x,i] -> pure $ PrimInline $ r |= signExtend16 (x .<<. i) + +------------------------------ Word16 ------------------------------------------ + + Word16ToWordOp -> \[r] [x] -> pure $ PrimInline $ r |= x + WordToWord16Op -> \[r] [x] -> pure $ PrimInline $ r |= mask16 x + + Word16AddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask16 (Add x y) + Word16SubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask16 (Sub x y) + Word16MulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask16 (Mul x y) + Word16QuotOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask16 (Div x y) + Word16RemOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Mod x y + Word16QuotRemOp -> \[r1,r2] [x,y] -> pure $ PrimInline $ mconcat + [ r1 |= toI32 (Div x y) + , r2 |= Mod x y + ] + Word16EqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + Word16GeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + Word16GtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + Word16LeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + Word16LtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + Word16NeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + + Word16AndOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BAnd x y + Word16OrOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BOr x y + Word16XorOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BXor x y + Word16NotOp -> \[r] [x] -> pure $ PrimInline $ r |= BXor x (Int 0xffff) + + Word16SllOp -> \[r] [x,i] -> pure $ PrimInline $ r |= mask16 (x .<<. i) + Word16SrlOp -> \[r] [x,i] -> pure $ PrimInline $ r |= x .>>>. i + +------------------------------ Int32 -------------------------------------------- + + Int32ToIntOp -> \[r] [x] -> pure $ PrimInline $ r |= x + IntToInt32Op -> \[r] [x] -> pure $ PrimInline $ r |= x + + Int32NegOp -> \rs xs -> genPrim prof bound ty IntNegOp rs xs + Int32AddOp -> \rs xs -> genPrim prof bound ty IntAddOp rs xs + Int32SubOp -> \rs xs -> genPrim prof bound ty IntSubOp rs xs + Int32MulOp -> \rs xs -> genPrim prof bound ty IntMulOp rs xs + Int32QuotOp -> \rs xs -> genPrim prof bound ty IntQuotOp rs xs + Int32RemOp -> \rs xs -> genPrim prof bound ty IntRemOp rs xs + Int32QuotRemOp -> \rs xs -> genPrim prof bound ty IntQuotRemOp rs xs + + Int32EqOp -> \rs xs -> genPrim prof bound ty IntEqOp rs xs + Int32GeOp -> \rs xs -> genPrim prof bound ty IntGeOp rs xs + Int32GtOp -> \rs xs -> genPrim prof bound ty IntGtOp rs xs + Int32LeOp -> \rs xs -> genPrim prof bound ty IntLeOp rs xs + Int32LtOp -> \rs xs -> genPrim prof bound ty IntLtOp rs xs + Int32NeOp -> \rs xs -> genPrim prof bound ty IntNeOp rs xs + + Int32SraOp -> \rs xs -> genPrim prof bound ty IntSraOp rs xs + Int32SrlOp -> \rs xs -> genPrim prof bound ty IntSrlOp rs xs + Int32SllOp -> \rs xs -> genPrim prof bound ty IntSllOp rs xs + +------------------------------ Word32 ------------------------------------------- + + Word32ToWordOp -> \[r] [x] -> pure $ PrimInline $ r |= x + WordToWord32Op -> \[r] [x] -> pure $ PrimInline $ r |= x + + Word32AddOp -> \rs xs -> genPrim prof bound ty WordAddOp rs xs + Word32SubOp -> \rs xs -> genPrim prof bound ty WordSubOp rs xs + Word32MulOp -> \rs xs -> genPrim prof bound ty WordMulOp rs xs + Word32QuotOp -> \rs xs -> genPrim prof bound ty WordQuotOp rs xs + Word32RemOp -> \rs xs -> genPrim prof bound ty WordRemOp rs xs + Word32QuotRemOp -> \rs xs -> genPrim prof bound ty WordQuotRemOp rs xs + + Word32EqOp -> \rs xs -> genPrim prof bound ty WordEqOp rs xs + Word32GeOp -> \rs xs -> genPrim prof bound ty WordGeOp rs xs + Word32GtOp -> \rs xs -> genPrim prof bound ty WordGtOp rs xs + Word32LeOp -> \rs xs -> genPrim prof bound ty WordLeOp rs xs + Word32LtOp -> \rs xs -> genPrim prof bound ty WordLtOp rs xs + Word32NeOp -> \rs xs -> genPrim prof bound ty WordNeOp rs xs + + Word32AndOp -> \rs xs -> genPrim prof bound ty WordAndOp rs xs + Word32OrOp -> \rs xs -> genPrim prof bound ty WordOrOp rs xs + Word32XorOp -> \rs xs -> genPrim prof bound ty WordXorOp rs xs + Word32NotOp -> \rs xs -> genPrim prof bound ty WordNotOp rs xs + + Word32SllOp -> \rs xs -> genPrim prof bound ty WordSllOp rs xs + Word32SrlOp -> \rs xs -> genPrim prof bound ty WordSrlOp rs xs + +------------------------------ Int64 -------------------------------------------- + + Int64ToIntOp -> \[r] [_h,l] -> pure $ PrimInline $ r |= toI32 l + + Int64NegOp -> \[r_h,r_l] [h,l] -> + pure $ PrimInline $ mconcat + [ r_l |= toU32 (Add (BNot l) one_) + , r_h |= toI32 (Add (BNot h) (Not r_l)) + ] + + Int64AddOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsPlusInt64Str [h0,l0,h1,l1] + Int64SubOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsMinusInt64Str [h0,l0,h1,l1] + Int64MulOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsTimesInt64Str [h0,l0,h1,l1] + Int64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsQuotInt64Str [h0,l0,h1,l1] + Int64RemOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsRemInt64Str [h0,l0,h1,l1] + + Int64SllOp -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] hdHsUncheckedShiftLLInt64Str [h,l,n] + Int64SraOp -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] hdHsUncheckedShiftRAInt64Str [h,l,n] + Int64SrlOp -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] hdHsUncheckedShiftRLInt64Str [h,l,n] + + Int64ToWord64Op -> \[r1,r2] [x1,x2] -> + pure $ PrimInline $ mconcat + [ r1 |= toU32 x1 + , r2 |= x2 + ] + IntToInt64Op -> \[r1,r2] [x] -> + pure $ PrimInline $ mconcat + [ r1 |= if_ (x .<. zero_) (Negate one_) zero_ -- sign-extension + , r2 |= toU32 x + ] + + Int64EqOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1)) + Int64NeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1)) + Int64GeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1))) + Int64GtOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1))) + Int64LeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1))) + Int64LtOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1))) + +------------------------------ Word64 ------------------------------------------- + + Word64ToWordOp -> \[r] [_x1,x2] -> pure $ PrimInline $ r |= x2 + + WordToWord64Op -> \[rh,rl] [x] -> + pure $ PrimInline $ mconcat + [ rh |= zero_ + , rl |= x + ] + + Word64ToInt64Op -> \[r1,r2] [x1,x2] -> + pure $ PrimInline $ mconcat + [ r1 |= toI32 x1 + , r2 |= x2 + ] + + Word64EqOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1)) + Word64NeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1)) + Word64GeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1))) + Word64GtOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1))) + Word64LeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1))) + Word64LtOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1))) + + Word64SllOp -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] hdHsUncheckedShiftLWord64Str [h,l,n] + Word64SrlOp -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] hdHsUncheckedShiftRWord64Str [h,l,n] + + Word64OrOp -> \[hr,hl] [h0, l0, h1, l1] -> + pure $ PrimInline $ mconcat + [ hr |= toU32 (BOr h0 h1) + , hl |= toU32 (BOr l0 l1) + ] + + Word64AndOp -> \[hr,hl] [h0, l0, h1, l1] -> + pure $ PrimInline $ mconcat + [ hr |= toU32 (BAnd h0 h1) + , hl |= toU32 (BAnd l0 l1) + ] + + Word64XorOp -> \[hr,hl] [h0, l0, h1, l1] -> + pure $ PrimInline $ mconcat + [ hr |= toU32 (BXor h0 h1) + , hl |= toU32 (BXor l0 l1) + ] + + Word64NotOp -> \[hr,hl] [h, l] -> + pure $ PrimInline $ mconcat + [ hr |= toU32 (BNot h) + , hl |= toU32 (BNot l) + ] + + Word64AddOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsPlusWord64Str [h0,l0,h1,l1] + Word64SubOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsMinusWord64Str [h0,l0,h1,l1] + Word64MulOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsTimesWord64Str [h0,l0,h1,l1] + Word64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsQuotWord64Str [h0,l0,h1,l1] + Word64RemOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsRemWord64Str [h0,l0,h1,l1] + +------------------------------ Word --------------------------------------------- + + WordAddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= (x `Add` y) .>>>. zero_ + WordAddCOp -> \[r,c] [x,y] -> + PrimInline <$> + jVar \tmp -> + pure $ mconcat + [ tmp |= x `Add` y + , r |= toU32 tmp + , c |= if10 (tmp .!==. r) + ] + WordSubCOp -> \[r,c] [x,y] -> + pure $ PrimInline $ mconcat + [ r |= toU32 (Sub x y) + , c |= if10 (y .>. x) + ] + WordAdd2Op -> \[h,l] [x,y] -> pure $ PrimInline $ appT [h,l] hdWordAdd2 [x,y] + WordSubOp -> \ [r] [x,y] -> pure $ PrimInline $ r |= toU32 (Sub x y) + WordMulOp -> \ [r] [x,y] -> pure $ PrimInline $ r |= toU32 (app hdMulImulStr [x, y]) + WordMul2Op -> \[h,l] [x,y] -> pure $ PrimInline $ appT [h,l] hdMul2Word32Str [x,y] + WordQuotOp -> \ [q] [x,y] -> pure $ PrimInline $ q |= app hdQuotWord32Str [x,y] + WordRemOp -> \ [r] [x,y] -> pure $ PrimInline $ r |= app hdRemWord32Str [x,y] + WordQuotRemOp -> \[q,r] [x,y] -> pure $ PrimInline $ appT [q,r] hdQuotRemWord32Str [x,y] + WordQuotRem2Op -> \[q,r] [xh,xl,y] -> pure $ PrimInline $ appT [q,r] hdQuotRem2Word32Str [xh,xl,y] + WordAndOp -> \[r] [x,y] -> pure $ PrimInline $ r |= toU32 (BAnd x y) + WordOrOp -> \[r] [x,y] -> pure $ PrimInline $ r |= toU32 (BOr x y) + WordXorOp -> \[r] [x,y] -> pure $ PrimInline $ r |= toU32 (BXor x y) + WordNotOp -> \[r] [x] -> pure $ PrimInline $ r |= toU32 (BNot x) + WordSllOp -> \[r] [x,y] -> pure $ PrimInline $ r |= toU32 (x .<<. y) + WordSrlOp -> \[r] [x,y] -> pure $ PrimInline $ r |= x .>>>. y + WordToIntOp -> \[r] [x] -> pure $ PrimInline $ r |= toI32 x + WordGtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + WordGeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + WordEqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + WordNeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + WordLtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + WordLeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + WordToDoubleOp -> \[r] [x] -> pure $ PrimInline $ r |= x + WordToFloatOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [x] + PopCnt8Op -> \[r] [x] -> pure $ PrimInline $ r |= hdPopCntTab .! (mask8 x) + PopCnt16Op -> \[r] [x] -> pure $ PrimInline $ r |= Add (hdPopCntTab .! (mask8 x)) + (hdPopCntTab .! (mask8 (x .>>>. Int 8))) + + PopCnt32Op -> \[r] [x] -> pure $ PrimInline $ r |= app hdPopCnt32Str [x] + PopCnt64Op -> \[r] [x1,x2] -> pure $ PrimInline $ r |= app hdPopCnt64Str [x1,x2] + PopCntOp -> \[r] [x] -> genPrim prof bound ty PopCnt32Op [r] [x] + Pdep8Op -> \[r] [s,m] -> pure $ PrimInline $ r |= app hdPDep8Str [s,m] + Pdep16Op -> \[r] [s,m] -> pure $ PrimInline $ r |= app hdPDep16Str [s,m] + Pdep32Op -> \[r] [s,m] -> pure $ PrimInline $ r |= app hdPDep32Str [s,m] + Pdep64Op -> \[ra,rb] [sa,sb,ma,mb] -> pure $ PrimInline $ appT [ra,rb] hdPDep64Str [sa,sb,ma,mb] + PdepOp -> \rs xs -> genPrim prof bound ty Pdep32Op rs xs + Pext8Op -> \[r] [s,m] -> pure $ PrimInline $ r |= app hdPExit8Str [s,m] + Pext16Op -> \[r] [s,m] -> pure $ PrimInline $ r |= app hdPExit16Str [s,m] + Pext32Op -> \[r] [s,m] -> pure $ PrimInline $ r |= app hdPExit32Str [s,m] + Pext64Op -> \[ra,rb] [sa,sb,ma,mb] -> pure $ PrimInline $ appT [ra,rb] hdPExit64Str [sa,sb,ma,mb] + PextOp -> \rs xs -> genPrim prof bound ty Pext32Op rs xs + + ClzOp -> \[r] [x] -> pure $ PrimInline $ r |= app hdClz32Str [x] + Clz8Op -> \[r] [x] -> pure $ PrimInline $ r |= app hdClz8Str [x] + Clz16Op -> \[r] [x] -> pure $ PrimInline $ r |= app hdClz16Str [x] + Clz32Op -> \[r] [x] -> pure $ PrimInline $ r |= app hdClz32Str [x] + Clz64Op -> \[r] [x1,x2] -> pure $ PrimInline $ r |= app hdClz64Str [x1,x2] + CtzOp -> \[r] [x] -> pure $ PrimInline $ r |= app hdCtz32Str [x] + Ctz8Op -> \[r] [x] -> pure $ PrimInline $ r |= app hdCtz8Str [x] + Ctz16Op -> \[r] [x] -> pure $ PrimInline $ r |= app hdCtz16Str [x] + Ctz32Op -> \[r] [x] -> pure $ PrimInline $ r |= app hdCtz32Str [x] + Ctz64Op -> \[r] [x1,x2] -> pure $ PrimInline $ r |= app hdCtz64Str [x1,x2] + + BSwap16Op -> \[r] [x] -> pure $ PrimInline $ + r |= BOr ((mask8 x) .<<. (Int 8)) + (mask8 (x .>>>. (Int 8))) + BSwap32Op -> \[r] [x] -> pure $ PrimInline $ + r |= toU32 ((x .<<. (Int 24)) + `BOr` ((BAnd x (Int 0xFF00)) .<<. (Int 8)) + `BOr` ((BAnd x (Int 0xFF0000)) .>>. (Int 8)) + `BOr` (x .>>>. (Int 24))) + BSwap64Op -> \[r1,r2] [x,y] -> pure $ PrimInline $ appT [r1,r2] hdBSwap64Str [x,y] + BSwapOp -> \[r] [x] -> genPrim prof bound ty BSwap32Op [r] [x] + + BRevOp -> \[r] [w] -> genPrim prof bound ty BRev32Op [r] [w] + BRev8Op -> \[r] [w] -> pure $ PrimInline $ r |= (app hdReverseWordStr [w] .>>>. Int 24) + BRev16Op -> \[r] [w] -> pure $ PrimInline $ r |= (app hdReverseWordStr [w] .>>>. Int 16) + BRev32Op -> \[r] [w] -> pure $ PrimInline $ r |= app hdReverseWordStr [w] + BRev64Op -> \[rh,rl] [h,l] -> pure $ PrimInline $ mconcat + [ rl |= app hdReverseWordStr [h] + , rh |= app hdReverseWordStr [l] + ] + +------------------------------ Narrow ------------------------------------------- + + Narrow8IntOp -> \[r] [x] -> pure $ PrimInline $ r |= signExtend8 x + Narrow16IntOp -> \[r] [x] -> pure $ PrimInline $ r |= signExtend16 x + Narrow32IntOp -> \[r] [x] -> pure $ PrimInline $ r |= toI32 x + Narrow8WordOp -> \[r] [x] -> pure $ PrimInline $ r |= mask8 x + Narrow16WordOp -> \[r] [x] -> pure $ PrimInline $ r |= mask16 x + Narrow32WordOp -> \[r] [x] -> pure $ PrimInline $ r |= toU32 x + +------------------------------ Double ------------------------------------------- + + DoubleGtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + DoubleGeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + DoubleEqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + DoubleNeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + DoubleLtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + DoubleLeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + DoubleAddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Add x y + DoubleSubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Sub x y + DoubleMulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Mul x y + DoubleDivOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Div x y + DoubleNegOp -> \[r] [x] -> pure $ PrimInline $ r |= Negate x + DoubleFabsOp -> \[r] [x] -> pure $ PrimInline $ r |= math_abs [x] + DoubleMinOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_min [x,y] + DoubleMaxOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_max [x,y] + DoubleToIntOp -> \[r] [x] -> pure $ PrimInline $ r |= toI32 x + DoubleToFloatOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [x] + DoubleExpOp -> \[r] [x] -> pure $ PrimInline $ r |= math_exp [x] + DoubleExpM1Op -> \[r] [x] -> pure $ PrimInline $ r |= math_expm1 [x] + DoubleLogOp -> \[r] [x] -> pure $ PrimInline $ r |= math_log [x] + DoubleLog1POp -> \[r] [x] -> pure $ PrimInline $ r |= math_log1p [x] + DoubleSqrtOp -> \[r] [x] -> pure $ PrimInline $ r |= math_sqrt [x] + DoubleSinOp -> \[r] [x] -> pure $ PrimInline $ r |= math_sin [x] + DoubleCosOp -> \[r] [x] -> pure $ PrimInline $ r |= math_cos [x] + DoubleTanOp -> \[r] [x] -> pure $ PrimInline $ r |= math_tan [x] + DoubleAsinOp -> \[r] [x] -> pure $ PrimInline $ r |= math_asin [x] + DoubleAcosOp -> \[r] [x] -> pure $ PrimInline $ r |= math_acos [x] + DoubleAtanOp -> \[r] [x] -> pure $ PrimInline $ r |= math_atan [x] + DoubleSinhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_sinh [x] + DoubleCoshOp -> \[r] [x] -> pure $ PrimInline $ r |= math_cosh [x] + DoubleTanhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_tanh [x] + DoubleAsinhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_asinh [x] + DoubleAcoshOp -> \[r] [x] -> pure $ PrimInline $ r |= math_acosh [x] + DoubleAtanhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_atanh [x] + DoublePowerOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_pow [x,y] + DoubleDecode_2IntOp -> \[s,h,l,e] [x] -> pure $ PrimInline $ appT [s,h,l,e] hdDecodeDouble2IntStr [x] + DoubleDecode_Int64Op -> \[s1,s2,e] [d] -> pure $ PrimInline $ appT [e,s1,s2] hdDecodeDoubleInt64Str [d] + CastDoubleToWord64Op -> \[rh,rl] [x] -> pure $ PrimInline $ appT [rh,rl] hdCastDoubleToWord64Str [x] + CastWord64ToDoubleOp -> \[r] [h,l] -> pure $ PrimInline $ appT [r] hdCastWord64ToDoubleStr [h,l] + + DoubleFMAdd -> unhandledPrimop op + DoubleFMSub -> unhandledPrimop op + DoubleFNMAdd -> unhandledPrimop op + DoubleFNMSub -> unhandledPrimop op + +------------------------------ Float -------------------------------------------- + + FloatGtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + FloatGeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + FloatEqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + FloatNeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + FloatLtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + FloatLeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + FloatAddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_fround [Add x y] + FloatSubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_fround [Sub x y] + FloatMulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_fround [Mul x y] + FloatDivOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_fround [Div x y] + FloatNegOp -> \[r] [x] -> pure $ PrimInline $ r |= Negate x + FloatMinOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_min [x,y] + FloatMaxOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_max [x,y] + FloatFabsOp -> \[r] [x] -> pure $ PrimInline $ r |= math_abs [x] + FloatToIntOp -> \[r] [x] -> pure $ PrimInline $ r |= toI32 x + FloatExpOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_exp [x]] + FloatExpM1Op -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_expm1 [x]] + FloatLogOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_log [x]] + FloatLog1POp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_log1p [x]] + FloatSqrtOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_sqrt [x]] + FloatSinOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_sin [x]] + FloatCosOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_cos [x]] + FloatTanOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_tan [x]] + FloatAsinOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_asin [x]] + FloatAcosOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_acos [x]] + FloatAtanOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_atan [x]] + FloatSinhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_sinh [x]] + FloatCoshOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_cosh [x]] + FloatTanhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_tanh [x]] + FloatAsinhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_asinh [x]] + FloatAcoshOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_acosh [x]] + FloatAtanhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_atanh [x]] + FloatPowerOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_fround [math_pow [x,y]] + FloatToDoubleOp -> \[r] [x] -> pure $ PrimInline $ r |= x + FloatDecode_IntOp -> \[s,e] [x] -> pure $ PrimInline $ appT [s,e] hdDecodeFloatIntStr [x] + CastFloatToWord32Op -> \[r] [x] -> pure $ PrimInline $ appT [r] hdCastFloatToWord32Str [x] + CastWord32ToFloatOp -> \[r] [x] -> pure $ PrimInline $ appT [r] hdCastWord32ToFloatStr [x] + + + FloatFMAdd -> unhandledPrimop op + FloatFMSub -> unhandledPrimop op + FloatFNMAdd -> unhandledPrimop op + FloatFNMSub -> unhandledPrimop op + +------------------------------ Arrays ------------------------------------------- + + NewArrayOp -> \[r] [l,e] -> pure $ PrimInline $ r |= app hdNewArrayStr [l,e] + ReadArrayOp -> \[r] [a,i] -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> pure $ PrimInline $ bnd_arr bound a i (a .! i |= v) + SizeofArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ lngth + SizeofMutableArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ lngth + IndexArrayOp -> \[r] [a,i] -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i) + UnsafeFreezeArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a + UnsafeThawArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a + CopyArrayOp -> \[] [a,o1,ma,o2,n] -> + PrimInline <$> + jVar \tmp -> + pure $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ mconcat [ tmp |= Int 0 + , WhileStat False (tmp .<. n) $ + mconcat [ ma .! (Add tmp o2) |= a .! (Add tmp o1) + , preIncrS tmp + ] + + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + pure $ PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS hdCopyMutableArrayStr [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + pure $ PrimInline + $ bnd_arr_range bound a start n + $ r |= app hdSliceArrayStr [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + pure $ PrimInline + $ bnd_arr_range bound a start n + $ r |= app hdSliceArrayStr [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + pure $ PrimInline + $ bnd_arr_range bound a start n + $ r |= app hdSliceArrayStr [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + pure $ PrimInline + $ bnd_arr_range bound a start n + $ r |= app hdSliceArrayStr [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline <$> + jVar \tmp -> + pure $ bnd_arr bound a i + $ mconcat + [ tmp |= a .! i + , ifBlockS (tmp .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= tmp + ] + ] + +------------------------------ Small Arrays ------------------------------------- + + NewSmallArrayOp -> \[a] [n,e] -> pure $ PrimInline $ a |= app hdNewArrayStr [n,e] + ReadSmallArrayOp -> \[r] [a,i] -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> pure $ PrimInline $ bnd_arr bound a i (a .! i |= e) + SizeofSmallArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ lngth + SizeofSmallMutableArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ lngth + IndexSmallArrayOp -> \[r] [a,i] -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i) + UnsafeFreezeSmallArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a + UnsafeThawSmallArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline <$> + jVar \tmp -> + pure $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ mconcat [ tmp |= Sub n one_ + , WhileStat False (tmp .>=. zero_) + $ mconcat [ d .! (Add di tmp) |= s .! (Add si tmp) + , postDecrS tmp + ] + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + pure $ PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS hdCopyMutableArrayStr [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> pure $ PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> pure $ PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> pure $ PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> pure $ PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline <$> + jVar \tmp -> + pure $ bnd_arr bound a i + $ mconcat + [ tmp |= a .! i + , ifBlockS (tmp .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= tmp + ] + ] + +------------------------------- Byte Arrays ------------------------------------- + + NewByteArrayOp_Char -> \[r] [l] -> pure $ PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> pure $ PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> pure $ PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> pure $ PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> pure $ PrimInline $ r |= one_ + ByteArrayIsWeaklyPinnedOp -> \[r] [_] -> pure $ PrimInline $ r |= one_ + MutableByteArrayIsWeaklyPinnedOp -> \[r] [_] -> pure $ PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> pure $ PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> pure $ PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> pure $ PrimInline $ appS hdShrinkMutableByteArrayStr [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> pure $ PrimInline $ r |= app hdResizeMutableByteArrayStr [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> pure $ PrimInline $ a |= b + UnsafeThawByteArrayOp -> \[a] [b] -> pure $ PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ len + SizeofMutableByteArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ len + GetSizeofMutableByteArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ len + + IndexByteArrayOp_Char -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> pure $ PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> pure $ PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l + + CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> + pure . PrimInline + . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + $ r |= app hdCompareByteArraysStr [a1,o1,a2,o2,n] + + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray True bound a1 o1 a2 o2 n + + SetByteArrayOp -> \[] [a,o,n,v] -> + PrimInline <$> jVar \tmpIdent -> + do + let tmp = global $ identFS tmpIdent + pure . bnd_ba_range bound a o n $ + mconcat [ tmpIdent ||= zero_ + , WhileStat False (tmp .<. n) $ + mconcat [ write_u8 a (Add o tmp) v + , postIncrS tmp + ] + ] + SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs + + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v + +------------------------------- Addr# ------------------------------------------ + + AddrAddOp -> \[a',o'] [a,o,i] -> pure $ PrimInline $ mconcat [a' |= a, o' |= Add o i] + AddrSubOp -> \[i] [_a1,o1,_a2,o2] -> pure $ PrimInline $ i |= Sub o1 o2 + AddrRemOp -> \[r] [_a,o,i] -> pure $ PrimInline $ r |= Mod o i + AddrToIntOp -> \[i] [_a,o] -> pure $ PrimInline $ i |= o -- only usable for comparisons within one range + IntToAddrOp -> \[a,o] [i] -> pure $ PrimInline $ mconcat [a |= null_, o |= i] + AddrGtOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .>. zero_) + AddrGeOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .>=. zero_) + AddrEqOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .===. zero_) + AddrNeOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .!==. zero_) + AddrLtOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .<. zero_) + AddrLeOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .<=. zero_) + +------------------------------- Addr Indexing: Unboxed Arrays ------------------- + + IndexOffAddrOp_Char -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> pure $ PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> pure $ PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> pure $ PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> pure $ PrimInline $ write_boff_u64 a (off64 o i) h l + + IndexOffAddrOp_Word8AsChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word8AsWideChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + IndexOffAddrOp_Word8AsInt -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + IndexOffAddrOp_Word8AsWord -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + IndexOffAddrOp_Word8AsAddr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_addr a (off8 o i) ra ro + IndexOffAddrOp_Word8AsFloat -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f32 a (off8 o i) + IndexOffAddrOp_Word8AsDouble -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f64 a (off8 o i) + IndexOffAddrOp_Word8AsStablePtr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_stableptr a (off8 o i) ra ro + IndexOffAddrOp_Word8AsInt16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i16 a (off8 o i) + IndexOffAddrOp_Word8AsInt32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + IndexOffAddrOp_Word8AsInt64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_i64 a (off8 o i) h l + IndexOffAddrOp_Word8AsWord16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u16 a (off8 o i) + IndexOffAddrOp_Word8AsWord32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + IndexOffAddrOp_Word8AsWord64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_u64 a (off8 o i) h l + + ReadOffAddrOp_Word8AsChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word8AsWideChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + ReadOffAddrOp_Word8AsInt -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + ReadOffAddrOp_Word8AsWord -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + ReadOffAddrOp_Word8AsAddr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_addr a (off8 o i) ra ro + ReadOffAddrOp_Word8AsFloat -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f32 a (off8 o i) + ReadOffAddrOp_Word8AsDouble -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f64 a (off8 o i) + ReadOffAddrOp_Word8AsStablePtr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_stableptr a (off8 o i) ra ro + ReadOffAddrOp_Word8AsInt16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i16 a (off8 o i) + ReadOffAddrOp_Word8AsInt32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + ReadOffAddrOp_Word8AsInt64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_i64 a (off8 o i) h l + ReadOffAddrOp_Word8AsWord16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u16 a (off8 o i) + ReadOffAddrOp_Word8AsWord32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + ReadOffAddrOp_Word8AsWord64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_u64 a (off8 o i) h l + + WriteOffAddrOp_Word8AsChar -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word8AsWideChar -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off8 o i) v + WriteOffAddrOp_Word8AsInt -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off8 o i) v + WriteOffAddrOp_Word8AsWord -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u32 a (off8 o i) v + WriteOffAddrOp_Word8AsAddr -> \[] [a,o,i,va,vo] -> pure $ PrimInline $ write_boff_addr a (off8 o i) va vo + WriteOffAddrOp_Word8AsFloat -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_f32 a (off8 o i) v + WriteOffAddrOp_Word8AsDouble -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_f64 a (off8 o i) v + WriteOffAddrOp_Word8AsStablePtr -> \[] [a,o,i,va,vo] -> pure $ PrimInline $ write_boff_stableptr a (off8 o i) va vo + WriteOffAddrOp_Word8AsInt16 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i16 a (off8 o i) v + WriteOffAddrOp_Word8AsInt32 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off8 o i) v + WriteOffAddrOp_Word8AsInt64 -> \[] [a,o,i,h,l] -> pure $ PrimInline $ write_boff_i64 a (off8 o i) h l + WriteOffAddrOp_Word8AsWord16 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u16 a (off8 o i) v + WriteOffAddrOp_Word8AsWord32 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u32 a (off8 o i) v + WriteOffAddrOp_Word8AsWord64 -> \[] [a,o,i,h,l] -> pure $ PrimInline $ write_boff_u64 a (off8 o i) h l + +------------------------------- Mutable variables -------------------------------------- + NewMutVarOp -> \[r] [x] -> pure $ PrimInline $ r |= New (app hdMutVarStr [x]) + ReadMutVarOp -> \[r] [m] -> pure $ PrimInline $ r |= m .^ val + WriteMutVarOp -> \[] [m,x] -> pure $ PrimInline $ m .^ val |= x + AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> pure $ PrimInline $ appT [r1,r2] hdAtomicModifyMutVar2Str [m,f] + AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> pure $ PrimInline $ appT [r1,r2] hdAtomicModifyMutVarStr [m,f] + + AtomicSwapMutVarOp -> \[r] [mv,v] -> pure $ PrimInline $ mconcat + [ r |= mv .^ val, mv .^ val |= v ] + CasMutVarOp -> \[status,r] [mv,o,n] -> pure $ PrimInline $ ifS (mv .^ val .===. o) + (mconcat [status |= zero_, r |= n, mv .^ val |= n]) + (mconcat [status |= one_ , r |= mv .^ val]) + +------------------------------- Exceptions -------------------------------------- + + CatchOp -> \[_r] [a,handler] -> pure $ PRPrimCall $ returnS (app hdCatchStr [a, handler]) + + -- fully ignore the result arity as it can use 1 or 2 + -- slots, depending on the return type. + RaiseOp -> \_r [a] -> pure $ PRPrimCall $ returnS (app hdThrowStr [a, false_]) + RaiseIOOp -> \_r [a] -> pure $ PRPrimCall $ returnS (app hdThrowStr [a, false_]) + RaiseUnderflowOp -> \_r [] -> pure $ PRPrimCall $ returnS (app hdThrowStr [hdInternalExceptionTypeUnderflow, false_]) + RaiseOverflowOp -> \_r [] -> pure $ PRPrimCall $ returnS (app hdThrowStr [hdInternalExceptionTypeOverflow, false_]) + RaiseDivZeroOp -> \_r [] -> pure $ PRPrimCall $ returnS (app hdThrowStr [hdInternalExceptionTypeDivZero, false_]) + MaskAsyncExceptionsOp -> \_r [a] -> pure $ PRPrimCall $ returnS (app hdMaskAsyncStr [a]) + MaskUninterruptibleOp -> \_r [a] -> pure $ PRPrimCall $ returnS (app hdMaskUnintAsyncStr [a]) + UnmaskAsyncExceptionsOp -> \_r [a] -> pure $ PRPrimCall $ returnS (app hdUnmaskAsyncStr [a]) + + MaskStatus -> \[r] [] -> pure $ PrimInline $ r |= app "h$maskStatus" [] + +------------------------------- STM-accessible Mutable Variables -------------- + + AtomicallyOp -> \[_r] [a] -> pure $ PRPrimCall $ returnS (app hdAtomicallyStr [a]) + RetryOp -> \_r [] -> pure $ PRPrimCall $ returnS (app hdStmRetryStr []) + CatchRetryOp -> \[_r] [a,b] -> pure $ PRPrimCall $ returnS (app hdStmCatchRetryStr [a,b]) + CatchSTMOp -> \[_r] [a,h] -> pure $ PRPrimCall $ returnS (app hdCatchStmStr [a,h]) + NewTVarOp -> \[tv] [v] -> pure $ PrimInline $ tv |= app hdNewTVar [v] + ReadTVarOp -> \[r] [tv] -> pure $ PrimInline $ r |= app hdReadTVar [tv] + ReadTVarIOOp -> \[r] [tv] -> pure $ PrimInline $ r |= app hdReadTVarIO [tv] + WriteTVarOp -> \[] [tv,v] -> pure $ PrimInline $ appS hdWriteTVar [tv,v] + +------------------------------- Synchronized Mutable Variables ------------------ + + NewMVarOp -> \[r] [] -> pure $ PrimInline $ r |= New (app hdMVarStr []) + TakeMVarOp -> \[_r] [m] -> pure $ PRPrimCall $ returnS (app hdTakeMVarStr [m]) + TryTakeMVarOp -> \[r,v] [m] -> pure $ PrimInline $ appT [r,v] hdTryTakeMVarStr [m] + PutMVarOp -> \[] [m,v] -> pure $ PRPrimCall $ returnS (app hdPutMVarStr [m,v]) + TryPutMVarOp -> \[r] [m,v] -> pure $ PrimInline $ r |= app hdTryPutMVarStr [m,v] + ReadMVarOp -> \[_r] [m] -> pure $ PRPrimCall $ returnS (app hdReadMVarStr [m]) + TryReadMVarOp -> \[r,v] [m] -> pure $ PrimInline $ mconcat + [ v |= m .^ val + , r |= if01 (v .===. null_) + ] + IsEmptyMVarOp -> \[r] [m] -> pure $ PrimInline $ r |= if10 (m .^ val .===. null_) + +------------------------------- Delay/Wait Ops --------------------------------- + + DelayOp -> \[] [t] -> pure $ PRPrimCall $ returnS (app hdDelayThread [t]) + WaitReadOp -> \[] [fd] -> pure $ PRPrimCall $ returnS (app hdWaitRead [fd]) + WaitWriteOp -> \[] [fd] -> pure $ PRPrimCall $ returnS (app hdWaitWrite [fd]) + +------------------------------- Concurrency Primitives ------------------------- + + ForkOp -> \[_tid] [x] -> pure $ PRPrimCall $ returnS (app hdFork [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> pure $ PRPrimCall $ returnS (app hdFork [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> pure $ PRPrimCall $ returnS (app hdKillThread [tid,ex]) + YieldOp -> \[] [] -> pure $ PRPrimCall $ returnS (app hdYield []) + MyThreadIdOp -> \[r] [] -> pure $ PrimInline $ r |= hdCurrentThread + IsCurrentThreadBoundOp -> \[r] [] -> pure $ PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> pure $ PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> pure $ PrimInline $ appT [stat, cap, locked] hdThreadStatus [tid] + ListThreadsOp -> \[r] [] -> pure $ PrimInline $ appT [r] hdListThreads [] + GetThreadLabelOp -> \[r1, r2] [t] -> pure $ PrimInline $ appT [r1, r2] hdGetThreadLabel [t] + LabelThreadOp -> \[] [t,l] -> pure $ PrimInline $ t .^ label |= l + +------------------------------- Weak Pointers ----------------------------------- + + MkWeakOp -> \[r] [o,b,c] -> pure $ PrimInline $ r |= app hdMakeWeak [o,b,c] + MkWeakNoFinalizerOp -> \[r] [o,b] -> pure $ PrimInline $ r |= app hdMakeWeakNoFinalizer [o,b] + AddCFinalizerToWeakOp -> \[r] [_a1,_a1o,_a2,_a2o,_i,_a3,_a3o,_w] -> pure $ PrimInline $ r |= one_ + DeRefWeakOp -> \[f,v] [w] -> pure $ PrimInline $ mconcat + [ v |= w .^ val + , f |= if01 (v .===. null_) + ] + FinalizeWeakOp -> \[fl,fin] [w] -> pure $ PrimInline $ appT [fin, fl] hdFinalizeWeak [w] + TouchOp -> \[] [_e] -> pure $ PrimInline mempty + KeepAliveOp -> \[_r] [x, f] -> pure $ PRPrimCall $ ReturnStat (app hdKeepAlive [x, f]) + + +------------------------------ Stable pointers and names ------------------------ + + MakeStablePtrOp -> \[s1,s2] [a] -> pure $ PrimInline $ mconcat + [ s1 |= hdStablePtrBuf + , s2 |= app hdMakeStablePtrStr [a] + ] + DeRefStablePtrOp -> \[r] [_s1,s2] -> pure $ PrimInline $ r |= app hdDeRefStablePtr [s2] + EqStablePtrOp -> \[r] [_sa1,sa2,_sb1,sb2] -> pure $ PrimInline $ r |= if10 (sa2 .===. sb2) + + MakeStableNameOp -> \[r] [a] -> pure $ PrimInline $ r |= app hdMakeStableName [a] + StableNameToIntOp -> \[r] [s] -> pure $ PrimInline $ r |= app hdStableNameInt [s] + +------------------------------ Compact normal form ----------------------------- + + CompactNewOp -> \[c] [s] -> pure $ PrimInline $ c |= app hdCompactNew [s] + CompactResizeOp -> \[] [c,s] -> pure $ PrimInline $ appS hdCompactResize [c,s] + CompactContainsOp -> \[r] [c,v] -> pure $ PrimInline $ r |= app hdCompactContains [c,v] + CompactContainsAnyOp -> \[r] [v] -> pure $ PrimInline $ r |= app hdCompactContainsAny [v] + CompactGetFirstBlockOp -> \[ra,ro,s] [c] -> + pure $ PrimInline $ appT [ra,ro,s] hdCompactGetFirstBlock [c] + CompactGetNextBlockOp -> \[ra,ro,s] [c,a,o] -> + pure $ PrimInline $ appT [ra,ro,s] hdCompactGetNextBlock [c,a,o] + CompactAllocateBlockOp -> \[ra,ro] [size,sa,so] -> + pure $ PrimInline $ appT [ra,ro] hdCompactAllocateBlock [size,sa,so] + CompactFixupPointersOp -> \[c,newroota, newrooto] [blocka,blocko,roota,rooto] -> + pure $ PrimInline $ appT [c,newroota,newrooto] hdCompactFixupPointers [blocka,blocko,roota,rooto] + CompactAdd -> \[_r] [c,o] -> + pure $ PRPrimCall $ returnS (app hdCompactAdd [c,o]) + CompactAddWithSharing -> \[_r] [c,o] -> + pure $ PRPrimCall $ returnS (app hdCompactAddWithSharing [c,o]) + CompactSize -> \[s] [c] -> + pure $ PrimInline $ s |= app hdCompactSize [c] + +------------------------------ Unsafe pointer equality -------------------------- + + ReallyUnsafePtrEqualityOp -> \[r] [p1,p2] -> pure $ PrimInline $ r |= if10 (p1 .===. p2) + +------------------------------ Parallelism -------------------------------------- + + ParOp -> \[r] [_a] -> pure $ PrimInline $ r |= zero_ + SparkOp -> \[r] [a] -> pure $ PrimInline $ r |= a + NumSparks -> \[r] [] -> pure $ PrimInline $ r |= zero_ + +------------------------------ Tag to enum stuff -------------------------------- + + DataToTagSmallOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + [ stack .! PreInc sp |= global (identFS hdDataToTagEntryStr) + , returnS (app hdEntryStr [d]) + ] + DataToTagLargeOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + [ stack .! PreInc sp |= global (identFS hdDataToTagEntryStr) + , returnS (app hdEntryStr [d]) + ] + TagToEnumOp -> \[r] [tag] -> pure $ PrimInline $ + if isBoolTy ty + then r |= IfExpr tag true_ false_ + else r |= app hdTagToEnum [tag] + +------------------------------ Bytecode operations ------------------------------ + + AddrToAnyOp -> \[r] [d,_o] -> pure $ PrimInline $ r |= d + +------------------------------ Profiling (CCS) ------------------------------ + + GetCCSOfOp -> \[a, o] [obj] -> pure $ PrimInline $ mconcat + if prof + then [ a |= if_ (isObject obj) + (app hdBuildCCSPtrStr [obj .^ ccStr]) + null_ + , o |= zero_ + ] + else [ a |= null_ + , o |= zero_ + ] + + GetCurrentCCSOp -> \[a, o] [_dummy_arg] -> + let ptr = if prof then app hdBuildCCSPtrStr [jCurrentCCS] + else null_ + in pure $ PrimInline $ mconcat + [ a |= ptr + , o |= zero_ + ] + + ClearCCSOp -> \[_r] [x] -> pure $ PRPrimCall $ ReturnStat (app hdClearCCSStr [x]) + +------------------------------ Eventlog ------------------- + + TraceEventOp -> \[] [ed,eo] -> pure $ PrimInline $ appS hdTraceEventStr [ed,eo] + TraceEventBinaryOp -> \[] [ed,eo,len] -> pure $ PrimInline $ appS hdTraceEventBinaryStr [ed,eo,len] + TraceMarkerOp -> \[] [ed,eo] -> pure $ PrimInline $ appS hdTraceMarkerStr [ed,eo] + +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> pure $ PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> pure $ PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> pure $ PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> pure $ PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> pure $ PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> pure $ PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> pure $ PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> pure $ PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) + CasAddrOp_Word -> \[r] [a,o,old,new] -> pure $ PrimInline $ casOp read_u32 write_u32 r a o old new + CasAddrOp_Word8 -> \[r] [a,o,old,new] -> pure $ PrimInline $ casOp read_u8 write_u8 r a o old new + CasAddrOp_Word16 -> \[r] [a,o,old,new] -> pure $ PrimInline $ casOp read_u16 write_u16 r a o old new + CasAddrOp_Word32 -> \[r] [a,o,old,new] -> pure $ PrimInline $ casOp read_u32 write_u32 r a o old new + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> pure $ PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr Sub r a o v + FetchAndAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr BAnd r a o v + FetchNandAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v + FetchOrAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr BOr r a o v + FetchXorAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr BXor r a o v + + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> pure $ PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> pure $ PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] + + ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> pure $ PrimInline $ appS hdShrinkMutableCharArrayStr [a,n] + GetSizeofSmallMutableArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ lngth + + AtomicReadAddrOp_Word -> \[r] [a,o] -> pure $ PrimInline $ r |= read_boff_u32 a o + AtomicWriteAddrOp_Word -> \[] [a,o,w] -> pure $ PrimInline $ write_boff_u32 a o w + + +------------------------------ Unhandled primops ------------------- + + AnnotateStackOp -> unhandledPrimop op + + NewPromptTagOp -> unhandledPrimop op + PromptOp -> unhandledPrimop op + Control0Op -> unhandledPrimop op + + GetSparkOp -> unhandledPrimop op + AnyToAddrOp -> unhandledPrimop op + MkApUpd0_Op -> unhandledPrimop op + NewBCOOp -> unhandledPrimop op + UnpackClosureOp -> unhandledPrimop op + ClosureSizeOp -> unhandledPrimop op + GetApStackValOp -> unhandledPrimop op + WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n + + SetThreadAllocationCounter -> unhandledPrimop op + SetOtherThreadAllocationCounter -> unhandledPrimop op + +------------------------------- Vector ----------------------------------------- +-- For now, vectors are unsupported on the JS backend. Simply put, they do not +-- make much sense to support given support for arrays and lack of SIMD support +-- in JS. We could try to roll something special but we would not be able to +-- give any performance guarentees to the user and so we leave these has +-- unhandled for now. + VecBroadcastOp _ _ _ -> unhandledPrimop op + VecPackOp _ _ _ -> unhandledPrimop op + VecUnpackOp _ _ _ -> unhandledPrimop op + VecInsertOp _ _ _ -> unhandledPrimop op + VecAddOp _ _ _ -> unhandledPrimop op + VecSubOp _ _ _ -> unhandledPrimop op + VecMulOp _ _ _ -> unhandledPrimop op + VecDivOp _ _ _ -> unhandledPrimop op + VecQuotOp _ _ _ -> unhandledPrimop op + VecRemOp _ _ _ -> unhandledPrimop op + VecNegOp _ _ _ -> unhandledPrimop op + VecIndexByteArrayOp _ _ _ -> unhandledPrimop op + VecReadByteArrayOp _ _ _ -> unhandledPrimop op + VecWriteByteArrayOp _ _ _ -> unhandledPrimop op + VecIndexOffAddrOp _ _ _ -> unhandledPrimop op + VecReadOffAddrOp _ _ _ -> unhandledPrimop op + VecWriteOffAddrOp _ _ _ -> unhandledPrimop op + + VecFMAdd {} -> unhandledPrimop op + VecFMSub {} -> unhandledPrimop op + VecFNMAdd {} -> unhandledPrimop op + VecFNMSub {} -> unhandledPrimop op + + VecIndexScalarByteArrayOp _ _ _ -> unhandledPrimop op + VecReadScalarByteArrayOp _ _ _ -> unhandledPrimop op + VecWriteScalarByteArrayOp _ _ _ -> unhandledPrimop op + VecIndexScalarOffAddrOp _ _ _ -> unhandledPrimop op + VecReadScalarOffAddrOp _ _ _ -> unhandledPrimop op + VecWriteScalarOffAddrOp _ _ _ -> unhandledPrimop op + VecShuffleOp _ _ _ -> unhandledPrimop op + VecMinOp {} -> unhandledPrimop op + VecMaxOp {} -> unhandledPrimop op + + PrefetchByteArrayOp3 -> noOp + PrefetchMutableByteArrayOp3 -> noOp + PrefetchAddrOp3 -> noOp + PrefetchValueOp3 -> noOp + PrefetchByteArrayOp2 -> noOp + PrefetchMutableByteArrayOp2 -> noOp + PrefetchAddrOp2 -> noOp + PrefetchValueOp2 -> noOp + PrefetchByteArrayOp1 -> noOp + PrefetchMutableByteArrayOp1 -> noOp + PrefetchAddrOp1 -> noOp + PrefetchValueOp1 -> noOp + PrefetchByteArrayOp0 -> noOp + PrefetchMutableByteArrayOp0 -> noOp + PrefetchAddrOp0 -> noOp + PrefetchValueOp0 -> noOp + +unhandledPrimop :: PrimOp -> [JStgExpr] -> [JStgExpr] -> JSM PrimRes +unhandledPrimop op rs as = pure $ PrimInline $ mconcat + [ appS "h$log" $ pure $ String $ + fsLit $ mconcat + [ "warning, unhandled primop: " + , renderWithContext defaultSDocContext (ppr op) + , " " + , show (length rs, length as) + ] + , appS (mkFastString $ unpackFS hdPrimOpStr ++ zEncodeString (renderWithContext defaultSDocContext (ppr op))) as + -- copyRes + , mconcat $ zipWith (\r reg -> r |= foreignRegister reg) rs (enumFrom Ret1) + ] + +-- | A No Op, used for primops the JS platform cannot or do not support. For +-- example, the prefetching primops do not make sense on the JS platform because +-- we do not have enough control over memory to provide any kind of prefetching +-- mechanism. Hence, these are NoOps. +noOp :: Foldable f => f a -> f a -> JSM PrimRes +noOp = const . const . pure $ PrimInline mempty + +-- tuple returns +appT :: [JStgExpr] -> FastString -> [JStgExpr] -> JStgStat +appT [] f xs = appS f xs +appT (r:rs) f xs = mconcat + [ r |= app f xs + , mconcat (zipWith (\r ret -> r |= (foreignRegister ret)) rs (enumFrom Ret1)) + ] + +-------------------------------------------- +-- ByteArray indexing +-------------------------------------------- + +-- For every ByteArray, the RTS creates the following views: +-- i3: Int32 view +-- u8: Word8 view +-- u1: Word16 view +-- f3: Float32 view +-- f6: Float64 view +-- dv: generic DataView +-- It seems a bit weird to mix Int and Word views like this, but perhaps they +-- are the more common. +-- +-- See 'h$newByteArray' in 'ghc/rts/js/mem.js' for details. +-- +-- Note that *byte* indexing can only be done with the generic DataView. Use +-- read_boff_* and write_boff_* for this. +-- +-- Other read_* and write_* helpers directly use the more specific views. +-- Prefer using them over idx_* to make your intent clearer. + +idx_i32, idx_u8, idx_u16, idx_f64, idx_f32 :: JStgExpr -> JStgExpr -> JStgExpr +idx_i32 a i = IdxExpr (a .^ i3) i +idx_u8 a i = IdxExpr (a .^ u8) i +idx_u16 a i = IdxExpr (a .^ u1) i +idx_f64 a i = IdxExpr (a .^ f6) i +idx_f32 a i = IdxExpr (a .^ f3) i + +read_u8 :: JStgExpr -> JStgExpr -> JStgExpr +read_u8 a i = idx_u8 a i + +read_u16 :: JStgExpr -> JStgExpr -> JStgExpr +read_u16 a i = idx_u16 a i + +read_u32 :: JStgExpr -> JStgExpr -> JStgExpr +read_u32 a i = toU32 (idx_i32 a i) + +read_i8 :: JStgExpr -> JStgExpr -> JStgExpr +read_i8 a i = signExtend8 (idx_u8 a i) + +read_i16 :: JStgExpr -> JStgExpr -> JStgExpr +read_i16 a i = signExtend16 (idx_u16 a i) + +read_i32 :: JStgExpr -> JStgExpr -> JStgExpr +read_i32 a i = idx_i32 a i + +read_f32 :: JStgExpr -> JStgExpr -> JStgExpr +read_f32 a i = idx_f32 a i + +read_f64 :: JStgExpr -> JStgExpr -> JStgExpr +read_f64 a i = idx_f64 a i + +read_u64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. one_) + , rh |= read_u32 a (Add one_ (i .<<. one_)) + ] + +read_i64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. one_) + , rh |= read_i32 a (Add one_ (i .<<. one_)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ arr)) (a .^ arr |= ValExpr (JList [])) mempty + , a .^ arr .! (i .<<. two_) |= r + ] + +read_addr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ arr) .&&. (a .^ arr .! (i .<<. two_))) + (a .^ arr .! (i .<<. two_)) + null_ + ] + +read_boff_addr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ arr) .&&. (a .^ arr .! i)) + (a .^ arr .! i) + null_ + ] + +write_boff_addr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ arr)) (a .^ arr |= ValExpr (JList [])) mempty + , a .^ arr .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_stableptr a i r o = mconcat + [ o |= read_i32 a i + , ifS (o .===. zero_) + (r |= null_) + (r |= hdStablePtrBuf) + ] + +read_boff_stableptr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_boff_stableptr a i r o = mconcat + [ o |= read_boff_i32 a i + , ifS (o .===. zero_) + (r |= null_) + (r |= hdStablePtrBuf) + ] + +write_stableptr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf or null + +write_boff_stableptr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf or null + +write_u8 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_u8 a i v = idx_u8 a i |= v + +write_u16 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_u16 a i v = idx_u16 a i |= v + +write_u32 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_u32 a i v = idx_i32 a i |= v + +write_i8 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_i8 a i v = idx_u8 a i |= v + +write_i16 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_i16 a i v = idx_u16 a i |= v + +write_i32 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_i32 a i v = idx_i32 a i |= v + +write_f32 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_f32 a i v = idx_f32 a i |= v + +write_f64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_f64 a i v = idx_f64 a i |= v + +write_u64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. one_) l + , write_u32 a (Add one_ (i .<<. one_)) h + ] + +write_i64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. one_) l + , write_i32 a (Add one_ (i .<<. one_)) h + ] + +-- Data View helper functions: byte indexed! +-- +-- The argument list consists of the array @a@, the index @i@, and the new value +-- to set (in the case of a setter) @v@. + +write_boff_i8, write_boff_u8, write_boff_i16, write_boff_u16, write_boff_i32, write_boff_u32, write_boff_f32, write_boff_f64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_boff_i8 a i v = write_i8 a i v +write_boff_u8 a i v = write_u8 a i v +write_boff_i16 a i v = ApplStat (a .^ dv .^ setInt16 ) [i, v, true_] +write_boff_u16 a i v = ApplStat (a .^ dv .^ setUint16 ) [i, v, true_] +write_boff_i32 a i v = ApplStat (a .^ dv .^ setInt32 ) [i, v, true_] +write_boff_u32 a i v = ApplStat (a .^ dv .^ setUint32 ) [i, v, true_] +write_boff_f32 a i v = ApplStat (a .^ dv .^ setFloat32) [i, v, true_] +write_boff_f64 a i v = ApplStat (a .^ dv .^ setFloat64) [i, v, true_] + +write_boff_i64, write_boff_u64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + +read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JStgExpr -> JStgExpr -> JStgExpr +read_boff_i8 a i = read_i8 a i +read_boff_u8 a i = read_u8 a i +read_boff_i16 a i = ApplExpr (a .^ dv .^ getInt16 ) [i, true_] +read_boff_u16 a i = ApplExpr (a .^ dv .^ getUint16 ) [i, true_] +read_boff_i32 a i = ApplExpr (a .^ dv .^ getInt32 ) [i, true_] +read_boff_u32 a i = ApplExpr (a .^ dv .^ getUint32 ) [i, true_] +read_boff_f32 a i = ApplExpr (a .^ dv .^ getFloat32) [i, true_] +read_boff_f64 a i = ApplExpr (a .^ dv .^ getFloat64) [i, true_] + +read_boff_i64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +fetchOpByteArray :: (JStgExpr -> JStgExpr -> JStgExpr) -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +fetchOpByteArray op tgt src i v = mconcat + [ tgt |= read_i32 src i + , write_i32 src i (op tgt v) + ] + +fetchOpAddr :: (JStgExpr -> JStgExpr -> JStgExpr) -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +fetchOpAddr op tgt src i v = mconcat + [ tgt |= read_boff_u32 src i + , write_boff_u32 src i (op tgt v) + ] + +casOp + :: (JStgExpr -> JStgExpr -> JStgExpr) -- read + -> (JStgExpr -> JStgExpr -> JStgExpr -> JStgStat) -- write + -> JStgExpr -- target register to store result + -> JStgExpr -- source array + -> JStgExpr -- index + -> JStgExpr -- old value to compare + -> JStgExpr -- new value to write + -> JStgStat +casOp read write tgt src i old new = mconcat + [ tgt |= read src i + , ifS (tgt .===. old) + (write src i new) + mempty + ] + +casOp2 + :: (JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat) -- read + -> (JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat) -- write + -> (JStgExpr,JStgExpr) -- target registers to store result + -> JStgExpr -- source array + -> JStgExpr -- index + -> (JStgExpr,JStgExpr) -- old value to compare + -> (JStgExpr,JStgExpr) -- new value to write + -> JStgStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + +-------------------------------------------------------------------------------- +-- Lifted Arrays +-------------------------------------------------------------------------------- +-- | lifted arrays +cloneArray :: Bool -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ slice) [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ ghcjsArray |= true_ + ] + +newByteArray :: JStgExpr -> JStgExpr -> JStgStat +newByteArray tgt len = + tgt |= app hdNewByteArrayStr [len] + +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JStgExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ Index + -> JStgStat -- ^ Result + -> JStgStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app hdExitProcess [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ Array + -> JStgExpr -- ^ Index + -> JStgStat -- ^ Result + -> JStgStat +bnd_arr do_check arr = check_bound (arr .^ lngth) do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ Array + -> JStgExpr -- ^ Index + -> JStgExpr -- ^ Range size + -> JStgStat -- ^ Result + -> JStgStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app hdExitProcess [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n one_)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ Array + -> JStgExpr -- ^ Index + -> JStgStat -- ^ Result + -> JStgStat +bnd_ba do_check arr = check_bound (arr .^ len) do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx one_) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx three_) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx (Int 7)) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. one_) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. two_) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. three_) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ Array + -> JStgExpr -- ^ Index + -> JStgExpr -- ^ Range size + -> JStgStat -- ^ Result + -> JStgStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app hdExitProcess [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n one_)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ First array + -> JStgExpr -- ^ First offset + -> JStgExpr -- ^ Second array + -> JStgExpr -- ^ Second offset + -> JStgExpr -- ^ Range size + -> JStgStat -- ^ Result + -> JStgStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app hdCheckOverlapByteArrayStr [a1, o1, a2, o2, n]) + r + (returnS $ app hdExitProcess [Int 134]) + +copyByteArray :: Bool -> Bool -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ + check $ appS hdCopyMutableByteArrayStr [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + +-- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 +-- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. +-- So (x|0) * (y|0) can still return values outside of the Int32 range. You have +-- been warned! +toI32 :: JStgExpr -> JStgExpr +toI32 e = BOr e zero_ + +-- e>>>0 (32 bit unsigned integer truncation) +-- required because of JS numbers. e>>>0 converts e to a Word32 +-- so (-2147483648) >>> 0 = 2147483648 +-- and ((-2147483648) >>>0) | 0 = -2147483648 +toU32 :: JStgExpr -> JStgExpr +toU32 e = e .>>>. zero_ + +quotShortInt :: Int -> JStgExpr -> JStgExpr -> JStgExpr +quotShortInt bits x y = BAnd (signed x `Div` signed y) mask + where + signed z = (z .<<. shift) .>>. shift + shift = Int (32 - toInteger bits) + mask = Int (((2::Integer) ^ toInteger bits) - 1) + +remShortInt :: Int -> JStgExpr -> JStgExpr -> JStgExpr +remShortInt bits x y = BAnd (signed x `Mod` signed y) mask + where + signed z = (z .<<. shift) .>>. shift + shift = Int (32 - toInteger bits) + mask = Int (((2::Integer) ^ toInteger bits) - 1) diff --git a/GHC/StgToJS/Profiling.hs b/GHC/StgToJS/Profiling.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Profiling.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.StgToJS.Profiling + ( initCostCentres + , emitCostCentreDecl + , emitCostCentreStackDecl + , enterCostCentreFun + , enterCostCentreThunk + , setCC + , pushRestoreCCS + , jCurrentCCS + , jCafCCS + , jSystemCCS + , costCentreLbl + , costCentreStackLbl + , singletonCCSLbl + , ccsVarJ + -- * Predicates + , profiling + , ifProfiling + , ifProfilingM + -- * helpers + , profStat + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.JStg.Syntax (JStgExpr) +import qualified GHC.JS.JStg.Syntax as JStg +import GHC.JS.Make +import GHC.JS.Ident + +import GHC.StgToJS.Monad +import GHC.StgToJS.Regs +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types + +import GHC.Types.CostCentre + +import GHC.Data.FastString +import GHC.Unit.Module +import GHC.Utils.Encoding +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Control.Monad.Trans.State.Strict as State + +-------------------------------------------------------------------------------- +-- Symbols + +hdCC :: JStgExpr +hdCC = JStg.global "h$CC" + +hdCCS :: JStgExpr +hdCCS = JStg.global "h$CCS" + +hdEnterFunCCS :: JStgExpr +hdEnterFunCCS = JStg.global "h$enterFunCCS" + +cc :: Ident +cc = name "cc" + +ccs :: Ident +ccs = name "ccs" + +hdPushCostCentre :: JStgExpr +hdPushCostCentre = JStg.global "h$pushCostCentre" + +hdPushRestoreCCS :: JStgExpr +hdPushRestoreCCS = JStg.global "h$pushRestoreCCS" + +hdEnterThunkCCS :: JStgExpr +hdEnterThunkCCS = JStg.global "h$enterThunkCCS" + +-------------------------------------------------------------------------------- +-- Initialization + +initCostCentres :: CollectedCCs -> G () +initCostCentres (local_CCs, singleton_CCSs) = do + mapM_ emitCostCentreDecl local_CCs + mapM_ emitCostCentreStackDecl singleton_CCSs + +emitCostCentreDecl :: CostCentre -> G () +emitCostCentreDecl cc = do + ccsLbl <- costCentreLbl cc + let is_caf = isCafCC cc + label = costCentreUserName cc + modl = moduleNameString $ moduleName $ cc_mod cc + loc = renderWithContext defaultSDocContext (ppr (costCentreSrcSpan cc)) + js = JStg.DeclStat ccsLbl + (Just (JStg.UOpExpr JStg.NewOp (JStg.ApplExpr hdCC + [ toJExpr label + , toJExpr modl + , toJExpr loc + , toJExpr is_caf + ]))) + emitGlobal js + +emitCostCentreStackDecl :: CostCentreStack -> G () +emitCostCentreStackDecl ccs = + case maybeSingletonCCS ccs of + Just cc -> do + ccsLbl <- singletonCCSLbl cc + ccLbl <- costCentreLbl cc + let js = + JStg.DeclStat ccsLbl + (Just (JStg.UOpExpr JStg.NewOp + (JStg.ApplExpr hdCCS [null_, toJExpr ccLbl]))) + emitGlobal js + Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) + +-------------------------------------------------------------------------------- +-- Entering to cost-centres + +enterCostCentreFun :: CostCentreStack -> JStg.JStgStat +enterCostCentreFun ccs + | isCurrentCCS ccs = JStg.ApplStat hdEnterFunCCS [jCurrentCCS, JStg.SelExpr r1 cc] + | otherwise = mempty -- top-level function, nothing to do + +enterCostCentreThunk :: JStg.JStgStat +enterCostCentreThunk = JStg.ApplStat hdEnterThunkCCS [JStg.SelExpr r1 cc] + +setCC :: CostCentre -> Bool -> Bool -> G JStg.JStgStat +setCC cc _tick True = do + ccI@(identFS -> _ccLbl) <- costCentreLbl cc + addDependency $ OtherSymb (cc_mod cc) + (moduleGlobalSymbol $ cc_mod cc) + return $ jCurrentCCS |= JStg.ApplExpr hdPushCostCentre [ jCurrentCCS + , JStg.Var ccI + ] +setCC _cc _tick _push = return mempty + +pushRestoreCCS :: JStg.JStgStat +pushRestoreCCS = JStg.ApplStat hdPushRestoreCCS [] + +-------------------------------------------------------------------------------- +-- Some cost-centre stacks to be used in generator + +jCurrentCCS :: JStg.JStgExpr +jCurrentCCS = JStg.SelExpr hdCurrentThread ccs + +jCafCCS :: JStg.JStgExpr +jCafCCS = JStg.global "h$CAF" + +jSystemCCS :: JStg.JStgExpr +jSystemCCS = JStg.global "h$CCS_SYSTEM" +-------------------------------------------------------------------------------- +-- Helpers for generating profiling related things + +profiling :: G Bool +profiling = csProf <$> getSettings + +ifProfiling :: Monoid m => m -> G m +ifProfiling m = do + prof <- profiling + return $ if prof then m else mempty + +ifProfilingM :: Monoid m => G m -> G m +ifProfilingM m = do + prof <- profiling + if prof then m else return mempty + +-- | If profiling is enabled, then use input JStgStat, else ignore +profStat :: StgToJSConfig -> JStg.JStgStat -> JStg.JStgStat +profStat cfg e = if csProf cfg then e else mempty + +-------------------------------------------------------------------------------- +-- Generating cost-centre and cost-centre stack variables + +costCentreLbl' :: CostCentre -> G String +costCentreLbl' cc = do + curModl <- State.gets gsModule + let lbl = renderWithContext defaultSDocContext + $ withPprStyle PprCode (ppr cc) + return . ("h$"++) . zEncodeString $ + moduleNameColons (moduleName curModl) ++ "_" ++ if isCafCC cc then "CAF_ccs" else lbl + +costCentreLbl :: CostCentre -> G Ident +costCentreLbl cc = name . mkFastString <$> costCentreLbl' cc + +costCentreStackLbl' :: CostCentreStack -> G (Maybe String) +costCentreStackLbl' ccs = do + ifProfilingM f + where + f | isCurrentCCS ccs = return $ Just "h$currentThread.ccs" + | dontCareCCS == ccs = return $ Just "h$CCS_DONT_CARE" + | otherwise = + case maybeSingletonCCS ccs of + Just cc -> Just <$> singletonCCSLbl' cc + Nothing -> pure Nothing + +costCentreStackLbl :: CostCentreStack -> G (Maybe Ident) +costCentreStackLbl ccs = fmap (name . mkFastString) <$> costCentreStackLbl' ccs + +singletonCCSLbl' :: CostCentre -> G String +singletonCCSLbl' cc = do + curModl <- State.gets gsModule + ccLbl <- costCentreLbl' cc + let ccsLbl = ccLbl ++ "_ccs" + return . zEncodeString $ mconcat + [ moduleNameColons (moduleName curModl) + , "_" + , ccsLbl + ] + +singletonCCSLbl :: CostCentre -> G Ident +singletonCCSLbl cc = name . mkFastString <$> singletonCCSLbl' cc + +ccsVarJ :: CostCentreStack -> G (Maybe JStg.JStgExpr) +ccsVarJ ccs = do + prof <- profiling + if prof + then fmap (JStg.ValExpr . JStg.JVar) <$> costCentreStackLbl ccs + else pure Nothing diff --git a/GHC/StgToJS/Regs.hs b/GHC/StgToJS/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Regs.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Regs + ( StgReg (..) + , Special(..) + , sp + , stack + , r1, r2, r3, r4 + , regsFromR1 + , regsFromR2 + , jsRegsFromR1 + , jsRegsFromR2 + , StgRet (..) + , jsRegToInt + , intToJSReg + , jsReg + , maxReg + , minReg + , lowRegs + , retRegs + , register + , foreignRegister + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.Ident +import GHC.JS.Make + +import GHC.StgToJS.Symbols + +import GHC.Data.FastString + +import Data.Array +import qualified Data.ByteString.Char8 as BSC +import Data.Char +import Data.Semigroup ((<>)) + +-- | General purpose "registers" +-- +-- The JS backend arbitrarily supports 128 registers +data StgReg + = R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 + | R9 | R10 | R11 | R12 | R13 | R14 | R15 | R16 + | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 + | R25 | R26 | R27 | R28 | R29 | R30 | R31 | R32 + | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40 + | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 + | R49 | R50 | R51 | R52 | R53 | R54 | R55 | R56 + | R57 | R58 | R59 | R60 | R61 | R62 | R63 | R64 + | R65 | R66 | R67 | R68 | R69 | R70 | R71 | R72 + | R73 | R74 | R75 | R76 | R77 | R78 | R79 | R80 + | R81 | R82 | R83 | R84 | R85 | R86 | R87 | R88 + | R89 | R90 | R91 | R92 | R93 | R94 | R95 | R96 + | R97 | R98 | R99 | R100 | R101 | R102 | R103 | R104 + | R105 | R106 | R107 | R108 | R109 | R110 | R111 | R112 + | R113 | R114 | R115 | R116 | R117 | R118 | R119 | R120 + | R121 | R122 | R123 | R124 | R125 | R126 | R127 | R128 + deriving (Eq, Ord, Show, Enum, Bounded, Ix) + +-- | Stack registers +data Special + = Stack + | Sp + deriving (Show, Eq) + +-- | Return registers +-- +-- Extra results from foreign calls can be stored here (while first result is +-- directly returned) +data StgRet = Ret1 | Ret2 | Ret3 | Ret4 | Ret5 | Ret6 | Ret7 | Ret8 | Ret9 | Ret10 + deriving (Eq, Ord, Show, Enum, Bounded, Ix) + +instance ToJExpr Special where + toJExpr Stack = hdStack + toJExpr Sp = hdStackPtr + +instance ToJExpr StgReg where + toJExpr r = registers ! r + +instance ToJExpr StgRet where + toJExpr r = rets ! r + +--------------------------------------------------- +-- helpers +--------------------------------------------------- + +sp :: JStgExpr +sp = toJExpr Sp + +stack :: JStgExpr +stack = toJExpr Stack + +r1, r2, r3, r4 :: JStgExpr +r1 = toJExpr R1 +r2 = toJExpr R2 +r3 = toJExpr R3 +r4 = toJExpr R4 + + +jsRegToInt :: StgReg -> Int +jsRegToInt = (+1) . fromEnum + +intToJSReg :: Int -> StgReg +intToJSReg r = toEnum (r - 1) + +jsReg :: Int -> JStgExpr +jsReg r = toJExpr (intToJSReg r) + +maxReg :: Int +maxReg = jsRegToInt maxBound + +minReg :: Int +minReg = jsRegToInt minBound + +-- | List of registers, starting from R1 +regsFromR1 :: [StgReg] +regsFromR1 = enumFrom R1 + +-- | List of registers, starting from R2 +regsFromR2 :: [StgReg] +regsFromR2 = tail regsFromR1 + +-- | List of registers, starting from R1 as JStgExpr +jsRegsFromR1 :: [JStgExpr] +jsRegsFromR1 = fmap toJExpr regsFromR1 + +-- | List of registers, starting from R2 as JExpr +jsRegsFromR2 :: [JStgExpr] +jsRegsFromR2 = tail jsRegsFromR1 + +--------------------------------------------------- +-- caches +--------------------------------------------------- + +lowRegs :: [Ident] +lowRegs = map reg_to_ident [R1 .. R31] + where reg_to_ident = name . mkFastString . (unpackFS hdStr ++) . map toLower . show + +retRegs :: [Ident] +retRegs = [name . mkFastStringByteString + $ hdB <> BSC.pack (map toLower $ show n) | n <- enumFrom Ret1] + +-- cache JExpr representing StgReg +registers :: Array StgReg JStgExpr +registers = listArray (minBound, maxBound) (map (global . identFS) lowRegs ++ map regN [R32 .. R128]) + where + regN :: StgReg -> JStgExpr + regN r = IdxExpr hdRegs (toJExpr (fromEnum r - 32)) + +-- cache JExpr representing StgRet +rets :: Array StgRet JStgExpr +rets = listArray (minBound, maxBound) (map retN (enumFrom Ret1)) + where + retN = global . mkFastString . (unpackFS hdStr ++) . map toLower . show + +-- | Given a register, return the JS syntax object representing that register +register :: StgReg -> JStgExpr +register i = registers ! i + +-- | Given a register, return the JS syntax object representing that register +foreignRegister :: StgRet -> JStgExpr +foreignRegister i = rets ! i diff --git a/GHC/StgToJS/Rts/Rts.hs b/GHC/StgToJS/Rts/Rts.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Rts/Rts.hs @@ -0,0 +1,680 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Rts.Rts +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- Top level driver of the JavaScript Backend RTS. This file is an +-- implementation of the JS RTS for the JS backend written as an EDSL in +-- Haskell. It assumes the existence of pre-generated JS functions, included as +-- js-sources in base. These functions are similarly assumed for non-inline +-- Primops, See 'GHC.StgToJS.Prim'. Most of the elements in this module are +-- constants in Haskell Land which define pieces of the JS RTS. +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Rts.Rts + ( rts + , assignRegs + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import GHC.JS.Make +import GHC.JS.Ident + +import GHC.StgToJS.Apply +import GHC.StgToJS.Closure +import GHC.StgToJS.Heap +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.Stack +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types + +import GHC.Types.Unique.Map + +import Data.Array +import Data.Monoid +import qualified Data.Bits as Bits + +-- | The garbageCollector resets registers and result variables. +garbageCollector :: JSM JStgStat +garbageCollector = jBlock + [ jFunction' hdResetRegisters (return $ mconcat $ map resetRegister [minBound..maxBound]) + , jFunction' hdResetResultVars (return $ mconcat $ map resetResultVar [minBound..maxBound]) + ] + +-- | Reset the register 'r' in JS Land. Note that this "resets" by setting the +-- register to a dummy variable called "null", /not/ by setting to JS's nil +-- value. +resetRegister :: StgReg -> JStgStat +resetRegister r = toJExpr r |= null_ + +-- | Reset the return variable 'r' in JS Land. Note that this "resets" by +-- setting the register to a dummy variable called "null", /not/ by setting to +-- JS's nil value. +resetResultVar :: StgRet -> JStgStat +resetResultVar r = toJExpr r |= null_ + +-- | Define closures based on size, these functions are syntactic sugar. Each +-- Closure constructor follows the naming convention h$cN, where N is a natural +-- number. For example, h$c (with the nat omitted) is a JS Land Constructor for +-- a closure which has a single entry function 'f', and no fields; identical to +-- h$c0. h$c1 is a for a closure with an entry function 'f', and a /single/ +-- field 'x1', 'Just foo' is an example of this kind of closure. h$c2 is a +-- constructor for a closure with an entry function and two data fields: 'x1' +-- and 'x2'. And so on. Note that this has JIT performance implications; you +-- should use h$c1, h$c2, h$c3, ... h$c24 instead of making objects manually so +-- layouts and fields can be changed more easily and so the JIT can optimize +-- better. +closureConstructors :: StgToJSConfig -> JSM JStgStat +closureConstructors s = do + closures <- mapM mkClosureCon (Nothing : map Just [0..jsClosureCount]) + fillers <- mapM mkDataFill [1..jsClosureCount] + return $ BlockStat $ closures ++ fillers + + where + prof = csProf s + (ccArg,ccVal) + -- the cc argument happens to be named just like the cc field... + | prof = ([Var $ name closureCC_], Just (global closureCC_)) + | otherwise = ([], Nothing) + + addCCArg' as = as ++ ccArg + + traceAlloc x | csTraceRts s = appS hdTraceAlloc [x] + | otherwise = mempty + + notifyAlloc x | csDebugAlloc s = appS hdDebugAllocNotifyAlloc [x] + | otherwise = mempty + + -- only JSVal can typically contain undefined or null + -- although it's possible (and legal) to make other Haskell types + -- to contain JS refs directly + -- this can cause false positives here + checkC :: JSM JStgStat + checkC | csAssertRts s = + jVar $ \msg -> + jwhenS (arguments .! 0 .!==. jString hdGhcInternalJSPrimValConEntryStr) + <$> + (loop 1 (.<. arguments .^ lngth) + (\i -> + return $ + mconcat [msg |= jString "warning: undefined or null in argument: " + + i + + jString " allocating closure: " + (arguments .! 0 .^ n) + , appS hdLogStr [msg] + , jwhenS (console .&&. (console .^ trace)) ((console .^ trace) `ApplStat` [msg]) + , postIncrS i + ])) + | otherwise = pure mempty + + -- h$d is never used for JSVal (since it's only for constructors with + -- at least three fields, so we always warn here + checkD | csAssertRts s = + loop 0 (.<. arguments .^ lngth) + (\i -> jwhenS ((arguments .! i .===. null_) + .||. (arguments .! i .===. undefined_)) + <$> + (jVar \msg-> + return $ + mconcat [ msg |= jString "warning: undefined or null in argument: " + i + jString " allocating fields" + , jwhenS (console .&&. (console .^ trace)) + ((console .^ trace) `ApplStat` [msg]) + ])) + + | otherwise = pure mempty + + -- special case handler, the key difference is a call to @jFunction@ instead + -- of @jFunctionSized@ + singleton_closure_con nm = jFunction nm $ + \(MkSolo f) -> do + chk_c <- checkC + jVar $ \x -> + return $ mconcat $ + [ chk_c + , x |= newClosure (mkClosure f mempty 0 ccVal) + , notifyAlloc x + , traceAlloc x + , returnS x + ] + + mkClosureCon :: Maybe Int -> JSM JStgStat + -- the h$c special case + mkClosureCon Nothing = singleton_closure_con hdCStr + -- the h$c0 special case + mkClosureCon (Just 0) = singleton_closure_con hdC0Str + -- the rest h$c1 .. h$c24. Note that h$c1 takes 2 arguments, one for the + -- entry function 'f' and another for the data field 'd1'. Thus the 1 in + -- h$c1 means 1 data field argument, not just one argument + mkClosureCon (Just n) = jFunctionSized funName (n + 1) funBod + where + funName = name $ clsName n + + funBod [] = pure mempty -- impossible + funBod (f:vars') = do + let vars = addCCArg' vars' + chk_c <- checkC + jVar $ \x -> + return $ mconcat $ + [ chk_c + , x |= newClosure (mkClosure f vars 0 ccVal) + , notifyAlloc x + , traceAlloc x + , returnS x + ] + + mkDataFill :: Int -> JSM JStgStat + mkDataFill n = jFunctionSized funName n body + where + funName = name $ dataName n + ds = map dataFieldName [1..n] + extra_args as = ValExpr . JHash + . listToUniqMap + $ zip ds as + body :: [JStgExpr] -> JSM JStgStat + body ids = do + c <- checkD + return (c <> returnS (extra_args ids)) + +-- | JS Payload to perform stack manipulation in the RTS +stackManip :: JSM JStgStat +stackManip = do + pushes <- mapM mkPush [1..32] + ppushes <- mapM mkPpush [1..255] + return $ mconcat $ pushes ++ ppushes + where + mkPush :: Int -> JSM JStgStat + mkPush n = let funName = pushN ! n + body as = return $ + ((sp |= sp + toJExpr n) + <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= a) + [1..] as)) + in jFunctionSized funName n body + + -- partial pushes, based on bitmap, increases Sp by highest bit + mkPpush :: Integer -> JSM JStgStat + mkPpush sig | sig Bits..&. (sig+1) == 0 = pure mempty -- already handled by h$p + mkPpush sig = let funName = pushNN ! sig + bits = bitsIdx sig + h = last bits + body args = return $ + mconcat [ sp |= sp + toJExpr (h+1) + , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= a) bits args) + ] + in jFunctionSized funName (length bits) body + +bitsIdx :: Integer -> [Int] +bitsIdx n | n < 0 = error "bitsIdx: negative" + | otherwise = go n 0 + where + go 0 _ = [] + go m b | Bits.testBit m b = b : go (Bits.clearBit m b) (b+1) + | otherwise = go (Bits.clearBit m b) (b+1) + +bhLneStats :: StgToJSConfig -> JStgExpr -> JStgExpr -> JSM JStgStat +bhLneStats _s p frameSize = jVar $ \v -> + return $ mconcat + [ v |= stack .! p + , ifS v + ((sp |= sp - frameSize) + <> ifS (v .===. hdBlackHole) + (returnS $ app hdThrowStr [hdInternalExceptionControlExceptionBaseNonTermination, false_]) + (mconcat [r1 |= v + , sp |= sp - frameSize + , returnStack + ])) + ((stack .! p |= hdBlackHole) <> returnS null_) + ] + + +-- | JS payload to declare the registers +declRegs :: JSM JStgStat +declRegs = do + getters_setters <- regGettersSetters + loaders <- loadRegs + return $ + mconcat [ hdRegsStr ||= toJExpr (JList []) + , mconcat (map declReg lowRegs) + , getters_setters + , loaders + ] + where + declReg r = decl r <> BlockStat [toJExpr r |= zero_] + +-- | JS payload to define getters and setters on the registers. +regGettersSetters :: JSM JStgStat +regGettersSetters = + do setters <- jFunction (name hdGetRegStr) (\(MkSolo n) -> return $ SwitchStat n getRegCases mempty) + getters <- jFunction (name hdSetRegStr) (\(n,v) -> return $ SwitchStat n (setRegCases v) mempty) + return $ setters <> getters + where + getRegCases = + map (\r -> (toJExpr (jsRegToInt r) , returnS (toJExpr r))) regsFromR1 + setRegCases :: JStgExpr -> [(JStgExpr,JStgStat)] + setRegCases v = + map (\r -> (toJExpr (jsRegToInt r), (toJExpr r |= toJExpr v) <> returnS undefined_)) regsFromR1 + +-- | JS payload that defines the functions to load each register +loadRegs :: JSM JStgStat +loadRegs = mconcat <$> mapM mkLoad [1..32] + where + mkLoad :: Int -> JSM JStgStat + mkLoad n = let body = \args -> return $ mconcat $ + zipWith (\a r -> toJExpr r |= a) + args (reverse $ take n regsFromR1) + fname = hdLoads ! n + in jFunctionSized fname n body + +-- | Assign registers R1 ... Rn in descending order, that is assign Rn first. +-- This function uses the 'hdLoads' array to construct functions which set +-- the registers. + +-- | JS payload which defines an array of function symbols that set N registers +-- from M parameters. For example, h$l4 compiles to: +-- @ +-- function h$l4(x1, x2, x3, x4) { +-- h$r4 = x1; +-- h$r3 = x2; +-- h$r2 = x3; +-- h$r1 = x4; +-- }; +-- @ +assignRegs :: StgToJSConfig -> [JStgExpr] -> JStgStat +assignRegs _ [] = mempty +assignRegs s xs + | l <= 32 && not (csInlineLoadRegs s) + = ApplStat (ValExpr (JVar $ hdLoads ! l)) (reverse xs) + | otherwise = mconcat . reverse $ + zipWith (\r ex -> toJExpr r |= ex) (take l regsFromR1) xs + where + l = length xs + + +-- | JS payload to declare return variables. +declRets :: JStgStat +declRets = mconcat $ map decl retRegs + +-- | JS payload defining the types closures. +closureTypes :: JSM JStgStat +closureTypes = do + cls_typ_nm <- closureTypeName + return $ + mconcat (map mkClosureType (enumFromTo minBound maxBound)) + <> cls_typ_nm + where + mkClosureType :: ClosureType -> JStgStat + mkClosureType c = let s = closureNames ! c + in s ||= toJExpr c + closureTypeName :: JSM JStgStat + closureTypeName = jFunction hdClosureTypeNameStr + \(MkSolo c) -> return $ + mconcat (map (ifCT c) [minBound..maxBound]) + <> returnS (jString "InvalidClosureType") + + ifCT :: JStgExpr -> ClosureType -> JStgStat + ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) + +-- | JS payload declaring the RTS functions. +rtsDecls :: JSM JStgStat +rtsDecls = do + decl_stg_regs <- declRegs + return $ + mconcat [ hdCurrentThreadStr ||= null_ -- thread state object for current thread + , hdStackStr ||= null_ -- stack for the current thread + , hdStackPtrStr ||= 0 -- stack pointer for the current thread + , hdInitStaticStr ||= toJExpr (JList []) -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs + , hdStaticThunksStr ||= toJExpr (jhFromList []) -- funcName -> heapidx map for srefs + , hdStaticThunksArrStr ||= toJExpr (JList []) -- indices of updatable thunks in static heap + , hdCAFsStr ||= toJExpr (JList []) + , hdCAFsResetStr ||= toJExpr (JList []) + -- stg registers + , decl_stg_regs + , declRets + ] + +-- | Generated RTS code +rts :: StgToJSConfig -> JSM JStgStat +rts cfg = withTag "h$RTS" $ + do + rts_ <- rts_gen cfg + rts_decls <- rtsDecls + return $ rts_decls <> rts_ + +-- | JS Payload which defines the embedded RTS. +rts_gen :: StgToJSConfig -> JSM JStgStat +rts_gen s = do + let decls = [ hdRtsTraceForeign ||= toJExpr (csTraceForeign s) + , hdRtsProfiling ||= toJExpr (csProf s) + , hdCtFun ||= toJExpr Fun + , hdCtCon ||= toJExpr Con + , hdCtThunk ||= toJExpr Thunk + , hdCtPap ||= toJExpr Pap + , hdCtBlackhole ||= toJExpr Blackhole + , hdCtStackFrame ||= toJExpr StackFrame + , hdCtVtPtr ||= toJExpr PtrV + , hdVtVoid ||= toJExpr VoidV + , hdVtInt ||= toJExpr IntV + , hdVtDouble ||= toJExpr DoubleV + , hdVtLong ||= toJExpr LongV + , hdVtAddr ||= toJExpr AddrV + , hdVtObj ||= toJExpr ObjV + , hdVtArr ||= toJExpr ArrV + ] + gc <- garbageCollector + closure_cons <- closureConstructors s + stk_manip <- stackManip + rest <- impure + return $ mconcat $ pure gc <> decls <> [closure_cons, stk_manip] <> rest + where + impure = sequence + [ jFunction' (name hdBhStr) (return $ bhStats s True) + , jFunction hdBlackHoleLNEStr (\(x, frameSize) -> bhLneStats s x frameSize) + , closure (ClosureInfo hdBlackHoleStr (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty) + (return $ appS throwStr [jString "oops: entered black hole"]) + , closure (ClosureInfo hdBlackHoleTrapStr (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty) + (return $ appS throwStr [jString "oops: entered multiple times"]) + , closure (ClosureInfo hdDone (CIRegs 0 [PtrV]) "done" (CILayoutUnknown 0) CIStackFrame mempty) + (return $ appS hdFinishedThread [hdCurrentThread] <> returnS hdReschedule) + , closure (ClosureInfo hdDoneMainEntryStr (CIRegs 0 [PtrV]) "doneMain" (CILayoutUnknown 0) CIStackFrame mempty) + (return $ returnS hdDoneMain) + , conClosure hdFalseEntry "GHC.Types.False" (CILayoutFixed 0 []) 1 + , conClosure hdTrueEntry "GHC.Types.True" (CILayoutFixed 0 []) 2 + -- generic data constructor with 1 non-heapobj field + , conClosure hdData1Entry "data1" (CILayoutFixed 1 [ObjV]) 1 + -- generic data constructor with 2 non-heapobj fields + , conClosure hdData2Entry "data2" (CILayoutFixed 2 [ObjV,ObjV]) 1 + , closure (ClosureInfo hdNoopEntryStr (CIRegs 1 [PtrV]) "no-op IO ()" (CILayoutFixed 0 []) (CIFun 1 0) mempty) + $ return (returnS (stack .! sp)) + , pure (hdNoopStr ||= ApplExpr hdC0 (hdNoopEntry : [jSystemCCS | csProf s])) + , closure (ClosureInfo hdCatchEntryStr (CIRegs 0 [PtrV]) "exception handler" (CILayoutFixed 2 [PtrV,IntV]) CIStackFrame mempty) + (return $ adjSpN' 3 <> returnS (stack .! sp)) + , closure (ClosureInfo hdDataToTagEntryStr (CIRegs 0 [PtrV]) "data to tag" (CILayoutFixed 0 []) CIStackFrame mempty) + $ return $ mconcat [ r1 |= if_ (r1 .===. true_) 1 (if_ (typeOf r1 .===. jTyObject) (r1 .^ "f" .^ "a" - 1) 0) + , adjSpN' 1 + , returnS (stack .! sp) + ] + -- function application to one argument + , closure (ClosureInfo hdAp1EntryStr (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty) + (jVars \(d1, d2) -> return $ + mconcat [ d1 |= closureField1 r1 + , d2 |= closureField2 r1 + , appS hdBhStr [] + , profStat s enterCostCentreThunk + , r1 |= d1 + , r2 |= d2 + , returnS (app hdAp11Fast []) + ]) + -- function application to two arguments + , closure (ClosureInfo hdAp2EntryStr (CIRegs 0 [PtrV]) "apply2" (CILayoutFixed 3 [PtrV, PtrV, PtrV]) CIThunk mempty) + (jVars \(d1, d2, d3) -> return $ + mconcat [ d1 |= closureField1 r1 + , d2 |= closureField2 r1 .^ d1Str + , d3 |= closureField2 r1 .^ d2Str + , appS hdBhStr [] + , profStat s enterCostCentreThunk + , r1 |= d1 + , r2 |= d2 + , r3 |= d3 + , returnS (app hdAp22FastStr []) + ]) + -- function application to three arguments + , closure (ClosureInfo hdAp3EntryStr (CIRegs 0 [PtrV]) "apply3" (CILayoutFixed 4 [PtrV, PtrV, PtrV, PtrV]) CIThunk mempty) + (jVars \(d1, d2, d3, d4) -> return $ + mconcat [ d1 |= closureField1 r1 + , d2 |= closureField2 r1 .^ d1Str + , d3 |= closureField2 r1 .^ d2Str + , d4 |= closureField2 r1 .^ d3Str + , appS hdBhStr [] + , r1 |= d1 + , r2 |= d2 + , r3 |= d3 + , r4 |= d4 + , returnS (app hdAp33FastStr []) + ]) + , closure (ClosureInfo hdUpdThunkEntryStr (CIRegs 0 [PtrV]) "updatable thunk" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar $ \t -> return $ + mconcat [t |= closureField1 r1 + , adjSp' 2 + , stack .! (sp - 1) |= r1 + , stack .! sp |= hdUpdFrame + , closureInfo r1 |= hdBlackHole + , closureField1 r1 |= hdCurrentThread + , closureField2 r1 |= null_ + , r1 |= t + , returnS (app hdAp00FastStr []) + ] + ) + -- select first field + , closure (ClosureInfo hdSelect1EntryStr (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar \t -> return $ + mconcat [ t |= closureField1 r1 + , adjSp' 3 + , stack .! (sp - 2) |= r1 + , stack .! (sp - 1) |= hdUpdFrame + , stack .! sp |= hdSelect1Ret + , closureInfo r1 |= hdBlackHole + , closureField1 r1 |= hdCurrentThread + , closureField2 r1 |= null_ + , r1 |= t + , returnS (app hdAp00FastStr []) + ]) + , closure (ClosureInfo hdSelect1RetStr (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + (r1 |= closureField1 r1) + <> adjSpN' 1 + <> returnS (app hdAp00FastStr []) + ) + -- select second field of a two-field constructor + , closure (ClosureInfo hdSelect2EntryStr (CIRegs 0 [PtrV]) "select2" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar \t -> return $ + mconcat [t |= closureField1 r1 + , adjSp' 3 + , stack .! (sp - 2) |= r1 + , stack .! (sp - 1) |= hdUpdFrame + , stack .! sp |= hdSelect2Return + , closureInfo r1 |= hdBlackHole + , closureField1 r1 |= hdCurrentThread + , closureField2 r1 |= null_ + , r1 |= t + , returnS (app hdAp00FastStr []) + ] + ) + , closure (ClosureInfo hdSelect2ReturnStr (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty) + $ return $ mconcat [ r1 |= closureField2 r1 + , adjSpN' 1 + , returnS (app hdAp00FastStr []) + ] + , closure (ClosureInfo hdKeepAliveEntryStr (CIRegs 0 [PtrV]) "keepAlive" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (return $ mconcat [ adjSpN' 2 + , returnS (stack .! sp) + ] + ) + -- a thunk that just raises a synchronous exception + , closure (ClosureInfo hdRaiseEntryStr (CIRegs 0 [PtrV]) (identFS hdRaiseEntryStr) (CILayoutFixed 0 []) CIThunk mempty) + (return $ returnS (app hdThrowStr [closureField1 r1, false_])) + , closure (ClosureInfo hdRaiseAsyncEntryStr (CIRegs 0 [PtrV]) (identFS hdRaiseAsyncEntryStr) (CILayoutFixed 0 []) CIThunk mempty) + (return $ returnS (app hdThrowStr [closureField1 r1, true_])) + , closure (ClosureInfo hdRaiseAsyncFrameStr (CIRegs 0 []) (identFS hdRaiseAsyncFrameStr) (CILayoutFixed 1 []) CIStackFrame mempty) + (jVar \ex -> return $ mconcat [ ex |= stack .! (sp - 1) + , adjSpN' 2 + , returnS (app hdThrowStr [ex, true_]) + ]) + {- reduce result if it's a thunk, follow if it's an ind + add this to the stack if you want the outermost result + to always be reduced to whnf, and not an ind + -} + , closure (ClosureInfo hdReduceStr (CIRegs 0 [PtrV]) (identFS hdReduceStr) (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + ifS (isThunk r1) + (returnS (r1 .^ "f")) + (adjSpN' 1 <> returnS (stack .! sp)) + ) + , rtsApply s + , closureTypes + , closure (ClosureInfo hdRunIOEntryStr (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + $ return $ mconcat [ r1 |= closureField1 r1 + , stack .! PreInc sp |= hdAp10 + , returnS hdAp10 + ] + , closure (ClosureInfo hdFlushStdoutEntryStr (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty) + $ return $ mconcat [ r1 |= hdGhcInternalIOHandleFlush + , r2 |= hdGhcInternalIOHandleFDStdout + , returnS (app hdAp11Fast []) + ] + , pure $ hdFlushStdoutStr ||= app hdStaticThunkStr [hdFlushStdoutEntry] + -- the scheduler pushes this frame when suspending a thread that + -- has not called h$reschedule explicitly + , closure (ClosureInfo hdRestoreThreadStr (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty) + (jVars \(f,frameSize,nregs) -> + do set_regs <- loop 1 (.<=. nregs) + (\i -> return $ appS hdSetRegStr [i, stack .! (sp - 2 - i)] <> postIncrS i) + return $ mconcat [f |= stack .! (sp - 2) + , frameSize |= stack .! (sp - 1) + , nregs |= frameSize - 3 + , set_regs + , sp |= sp - frameSize + , returnS f + ]) + -- return a closure in the stack frame to the next thing on the stack + , closure (ClosureInfo hdReturnStr (CIRegs 0 []) "return" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (return $ + (r1 |= stack .! (sp - 1)) + <> adjSpN' 2 + <> returnS (stack .! sp)) + -- return a function in the stack frame for the next call + , closure (ClosureInfo hdReturnFStr (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (jVar \r -> return $ + mconcat [ r |= stack .! (sp - 1) + , adjSpN' 2 + , returnS r + ]) + -- return this function when the scheduler needs to come into action + -- (yield, delay etc), returning thread needs to push all relevant + -- registers to stack frame, thread will be resumed by calling the stack top + , closure (ClosureInfo hdRescheduleStr (CIRegs 0 []) "reschedule" (CILayoutFixed 0 []) CIThunk mempty) + (return $ returnS $ hdReschedule) + -- debug thing, insert on stack to dump current result, should be boxed + , closure (ClosureInfo hdDumpResStr (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty) + (jVar \re -> return $ + mconcat [ appS hdLogStr [jString "h$dumpRes result: " + stack .! (sp-1)] + , appS hdLogStr [r1] + , appS hdLogStr [app hdCollectProps [r1]] + , jwhenS ((r1 .^ f) .&&. (r1 .^ f .^ n)) + (appS hdLogStr [jString "name: " + r1 .^ f .^ n]) + , jwhenS (ApplExpr (r1 .^ hasOwnProperty) [jString closureField1_]) + (appS hdLogStr [jString "d1: " + closureField1 r1]) + , jwhenS (ApplExpr (r1 .^ hasOwnProperty) [jString closureField2_]) + (appS hdLogStr [jString "d2: " + closureField2 r1]) + , jwhenS (r1 .^ f) $ mconcat + [ re |= New (app "RegExp" [jString "([^\\n]+)\\n(.|\\n)*"]) + , appS hdLogStr [jString "function" + + ApplExpr (ApplExpr ((jString "" + r1 .^ f) .^ substring) [0, 50] .^ replace) [r1, jString "$1"]] + ] + , adjSpN' 2 + , r1 |= null_ + , returnS (stack .! sp) + ]) + , closure (ClosureInfo hdResumeEntryStr (CIRegs 0 [PtrV]) resume (CILayoutFixed 0 []) CIThunk mempty) + (jVar \ss -> + do update_stk <- loop 0 (.<. ss .^ lngth) (\i -> return $ (stack .! (sp+1+i) |= ss .! i) <> postIncrS i) + return $ mconcat [ss |= closureField1 r1 + , updateThunk' s + , update_stk + , sp |= sp + ss .^ lngth + , r1 |= null_ + , returnS (stack .! sp) + ]) + , closure (ClosureInfo hdUnMaskFrameStr (CIRegs 0 [PtrV]) unMask (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + (hdCurrentThread .^ mask |= 0) + <> adjSpN' 1 + -- back to scheduler to give us async exception if pending + <> ifS (hdCurrentThread .^ excepStr .^ lngth .>. 0) + (push' s [r1, hdReturn] <> returnS hdReschedule) + (returnS (stack .! sp))) + , closure (ClosureInfo hdMaskFrameStr (CIRegs 0 [PtrV]) mask (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + (hdCurrentThread .^ mask |= 2) + <> adjSpN' 1 + <> returnS (stack .! sp)) + , closure (ClosureInfo hdMaskUnintFrameStr (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + (hdCurrentThread .^ mask |= 1) + <> adjSpN' 1 + <> returnS (stack .! sp)) + , closure (ClosureInfo hdUnboxFFIResultStr (CIRegs 0 [PtrV]) "unboxFFI" (CILayoutFixed 0 []) CIStackFrame mempty) + (jVar \d -> do set_regs <- loop 0 (.<. d .^ lngth) (\i -> return $ appS hdSetRegStr [i + 1, d .! i] <> postIncrS i) + return $ mconcat [ d |= closureField1 r1 + , set_regs + , adjSpN' 1 + , returnS (stack .! sp) + ]) + , closure (ClosureInfo hdUnboxEntryStr (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty) + (return $ (r1 |= closureField1 r1) <> returnS (stack .! sp)) + , closure (ClosureInfo hdRetryInterruptedStr (CIRegs 0 [ObjV]) "retry interrupted operation" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (jVar \a -> return $ mconcat [ a |= stack .! (sp - 1) + , adjSpN' 2 + , returnS (ApplExpr (a .! 0 .^ apply) [this, ApplExpr (a .^ slice) [1]]) + ]) + , closure (ClosureInfo hdAtomicallyEntryStr (CIRegs 0 [PtrV]) "atomic operation" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (return $ ifS (app hdStmValidateTransactionStr []) + (appS hdStmCommitTransactionStr [] + <> adjSpN' 2 + <> returnS (stack .! sp)) + (returnS (app hdStmStartTransactionStr [stack .! (sp - 1)]))) + + , closure (ClosureInfo hdStmCatchRetryEntryStr (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (return $ + adjSpN' 2 + <> appS hdStmCommitTransactionStr [] + <> returnS (stack .! sp)) + , closure (ClosureInfo hdStmCatchEntryStr (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty) + (return $ + adjSpN' 4 + <> appS hdStmCommitTransactionStr [] + <> returnS (stack .! sp)) + , closure (ClosureInfo hdStgResumeRetryEntryStr (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty) + (jVar \blocked -> + return $ + mconcat [ jwhenS (stack .! (sp - 2) .!==. hdAtomicallyEntry) + (appS throwStr [jString "h$stmResumeRetry_e: unexpected value on stack"]) + , blocked |= stack .! (sp - 1) + , adjSpN' 2 + , appS hdStmRemoveBlockedThreadStr [blocked, hdCurrentThread] + , returnS (app hdStmStartTransactionStr [stack .! (sp - 1)]) + ]) + , closure (ClosureInfo hdLazyEntryStr (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty) + (jVar \x -> + return $ + mconcat [x |= ApplExpr (closureField1 r1) [] + , appS hdBhStr [] + , profStat s enterCostCentreThunk + , r1 |= x + , returnS (stack .! sp) + ]) + , closure (ClosureInfo hdReportHeapOverflowStr (CIRegs 0 [PtrV]) (identFS hdReportHeapOverflowStr) (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ (appS throwStr [jString "h$reportHeapOverflow: Heap Overflow!"])) + , closure (ClosureInfo hdReportStackOverflowStr (CIRegs 0 [PtrV]) "h$reportStackOverflow" (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ (appS throwStr [jString "h$reportStackOverflow: Stack Overflow!"])) + -- Top-level statements to generate only in profiling mode + , fmap (profStat s) $ (closure (ClosureInfo hdSetCcsEntryStr (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (return $ + appS hdRestoreCCSStr [ stack .! (sp - 1)] + <> adjSpN' 2 + <> returnS (stack .! sp))) + ] diff --git a/GHC/StgToJS/Rts/Types.hs b/GHC/StgToJS/Rts/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Rts/Types.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP, + FlexibleInstances, + OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Rts.Apply +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- Types and utility functions used in the JS RTS. +----------------------------------------------------------------------------- + +module GHC.StgToJS.Rts.Types where + +import GHC.Prelude + +import GHC.JS.Make +import GHC.JS.JStg.Monad +import GHC.JS.JStg.Syntax + +import GHC.StgToJS.Regs +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types + +-------------------------------------------------------------------------------- +-- Syntactic Sugar for some Utilities we want in JS land +-------------------------------------------------------------------------------- + +-- | Given a @JStgExpr@, 'ex', inject a trace statement on 'ex' in the compiled +-- JS program +traceRts :: StgToJSConfig -> JStgExpr -> JStgStat +traceRts s ex | (csTraceRts s) = appS "h$log" [ex] + | otherwise = mempty + +-- | Syntactic sugar. Given a @JStgExpr@, 'ex' which is assumed to be a predicate, +-- and a message 'm', assert that 'not ex' is True, if not throw an exception in +-- JS land with message 'm'. +assertRts :: ToJExpr a => StgToJSConfig -> JStgExpr -> a -> JStgStat +assertRts s ex m | csAssertRts s = jwhenS (UOpExpr NotOp ex) (appS "throw" [toJExpr m]) + | otherwise = mempty + +-- | name of the closure 'c' +clName :: JStgExpr -> JStgExpr +clName c = c .^ "n" + +-- | Type name of the closure 'c' +clTypeName :: JStgExpr -> JStgExpr +clTypeName c = app "h$closureTypeName" [c .^ "t"] + +-- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers) +stackFrameSize :: JStgExpr -- ^ assign frame size to this + -> JStgExpr -- ^ stack frame header function + -> JSM JStgStat -- ^ size of the frame, including header +stackFrameSize tgt f = + jIf (f .===. hdApGen) -- h$ap_gen is special + (pure $ tgt |= (stack .! (sp - 1) .>>. 8) + 2) + (jVar (\tag -> + return $ mconcat + [tag |= f .^ "size" + , ifS (tag .<. 0) -- if tag is less than 0 + (tgt |= stack .! (sp - 1)) -- set target to stack pointer - 1 + (tgt |= mask8 tag + 1) -- else set to mask'd tag + 1 + ] + )) + + -------------------------------------------------------------------------------- +-- Register utilities +-------------------------------------------------------------------------------- + +-- | Perform the computation 'f', on the range of registers bounded by 'start' +-- and 'end'. +withRegs :: StgReg -> StgReg -> (StgReg -> JStgStat) -> JStgStat +withRegs start end f = mconcat $ fmap f [start..end] diff --git a/GHC/StgToJS/Sinker/Collect.hs b/GHC/StgToJS/Sinker/Collect.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Sinker/Collect.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Sinker.Collect + ( collectArgsTop + , collectArgs + , selectUsedOnce + ) + where + +import GHC.Prelude +import GHC.Types.Unique.Set +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Types.Unique + +-- | fold over all id in StgArg used at the top level in an StgRhsCon +collectArgsTop :: CgStgBinding -> [Id] +collectArgsTop = \case + StgNonRec _b r -> collectArgsTopRhs r + StgRec bs -> concatMap (collectArgsTopRhs . snd) bs + where + collectArgsTopRhs :: CgStgRhs -> [Id] + collectArgsTopRhs = \case + StgRhsCon _ccs _dc _mu _ticks args _typ -> concatMap collectArgsA args + StgRhsClosure {} -> [] + +-- | fold over all Id in StgArg in the AST +collectArgs :: CgStgBinding -> [Id] +collectArgs = \case + StgNonRec _b r -> collectArgsR r + StgRec bs -> concatMap (collectArgsR . snd) bs + where + collectArgsR :: CgStgRhs -> [Id] + collectArgsR = \case + StgRhsClosure _x0 _x1 _x2 _x3 e _typ -> collectArgsE e + StgRhsCon _ccs _con _mu _ticks args _typ -> concatMap collectArgsA args + + collectArgsAlt :: CgStgAlt -> [Id] + collectArgsAlt alt = collectArgsE (alt_rhs alt) + + collectArgsE :: CgStgExpr -> [Id] + collectArgsE = \case + StgApp x args + -> x : concatMap collectArgsA args + StgConApp _con _mn args _ts + -> concatMap collectArgsA args + StgOpApp _x args _t + -> concatMap collectArgsA args + StgCase e _b _a alts + -> collectArgsE e ++ concatMap collectArgsAlt alts + StgLet _x b e + -> collectArgs b ++ collectArgsE e + StgLetNoEscape _x b e + -> collectArgs b ++ collectArgsE e + StgTick _i e + -> collectArgsE e + StgLit _ + -> [] + +collectArgsA :: StgArg -> [Id] +collectArgsA = \case + StgVarArg i -> [i] + StgLitArg _ -> [] + +selectUsedOnce :: (Foldable t, Uniquable a) => t a -> UniqSet a +selectUsedOnce = fst . foldr g (emptyUniqSet, emptyUniqSet) + where + g i t@(once, mult) + | i `elementOfUniqSet` mult = t + | i `elementOfUniqSet` once + = (delOneFromUniqSet once i, addOneToUniqSet mult i) + | otherwise = (addOneToUniqSet once i, mult) diff --git a/GHC/StgToJS/Sinker/Sinker.hs b/GHC/StgToJS/Sinker/Sinker.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Sinker/Sinker.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Sinker.Sinker (sinkPgm) where + +import GHC.Prelude +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Var.Set +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Types.Literal +import GHC.Data.Graph.Directed +import GHC.StgToJS.Sinker.Collect +import GHC.StgToJS.Sinker.StringsUnfloat + +import GHC.Utils.Misc (partitionWith) +import GHC.StgToJS.Utils + +import Data.Char +import Data.List (partition) +import Data.Maybe +import Data.ByteString (ByteString) + +-- | Unfloat some top-level unexported things +-- +-- GHC floats constants to the top level. This is fine in native code, but with JS +-- they occupy some global variable name. We can unfloat some unexported things: +-- +-- - global constructors, as long as they're referenced only once by another global +-- constructor and are not in a recursive binding group +-- - literals (small literals may also be sunk if they are used more than once) +sinkPgm :: Module + -> [CgStgTopBinding] + -> (UniqFM Id CgStgExpr, [CgStgTopBinding]) +sinkPgm m pgm + = (sunk, map StgTopLifted pgm''' ++ stringLits) + where + selectLifted :: CgStgTopBinding -> Either CgStgBinding (Id, ByteString) + selectLifted (StgTopLifted b) = Left b + selectLifted (StgTopStringLit i b) = Right (i, b) + + (pgm', allStringLits) = partitionWith selectLifted pgm + usedOnceIds = selectUsedOnce $ concatMap collectArgs pgm' + + stringLitsUFM = listToUFM $ (\(i, b) -> (idName i, (i, b))) <$> allStringLits + (pgm'', _actuallyUnfloatedStringLitNames) = + unfloatStringLits + (idName `mapUniqSet` usedOnceIds) + (snd `mapUFM` stringLitsUFM) + pgm' + + stringLits = uncurry StgTopStringLit <$> allStringLits + + (sunk, pgm''') = sinkPgm' m usedOnceIds pgm'' + +sinkPgm' + :: Module + -- ^ the module, since we treat definitions from the current module + -- differently + -> IdSet + -- ^ the set of used once ids + -> [CgStgBinding] + -- ^ the bindings + -> (UniqFM Id CgStgExpr, [CgStgBinding]) + -- ^ a map with sunken replacements for nodes, for where the replacement + -- does not fit in the 'StgBinding' AST and the new bindings +sinkPgm' m usedOnceIds pgm = + let usedOnce = collectTopLevelUsedOnce usedOnceIds pgm + sinkables = listToUFM $ + concatMap alwaysSinkable pgm ++ + concatMap (filter ((`elementOfUniqSet` usedOnce) . fst) . onceSinkable m) pgm + isSunkBind (StgNonRec b _e) | elemUFM b sinkables = True + isSunkBind _ = False + in (sinkables, filter (not . isSunkBind) $ topSortDecls m pgm) + +-- | always sinkable, values that may be duplicated in the generated code (e.g. +-- small literals) +alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)] +alwaysSinkable (StgRec {}) = [] +alwaysSinkable (StgNonRec b rhs) = case rhs of + StgRhsClosure _ _ _ _ e@(StgLit l) _ + | isSmallSinkableLit l + , isLocal b + -> [(b,e)] + StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l] _typ + | isSmallSinkableLit l + , isLocal b + , isUnboxableCon dc + -> [(b,StgConApp dc cnum as [])] + _ -> [] + +isSmallSinkableLit :: Literal -> Bool +isSmallSinkableLit (LitChar c) = ord c < 100000 +isSmallSinkableLit (LitNumber _ i) = abs i < 100000 +isSmallSinkableLit _ = False + + +-- | once sinkable: may be sunk, but duplication is not ok +onceSinkable :: Module -> CgStgBinding -> [(Id, CgStgExpr)] +onceSinkable _m (StgNonRec b rhs) + | Just e <- getSinkable rhs + , isLocal b = [(b,e)] + where + getSinkable = \case + StgRhsCon _ccs dc cnum _ticks args _typ -> Just (StgConApp dc cnum args []) + StgRhsClosure _ _ _ _ e@(StgLit{}) _typ -> Just e + _ -> Nothing +onceSinkable _ _ = [] + +-- | collect all idents used only once in an argument at the top level +-- and never anywhere else +collectTopLevelUsedOnce :: IdSet -> [CgStgBinding] -> IdSet +collectTopLevelUsedOnce usedOnceIds binds = intersectUniqSets usedOnceIds (selectUsedOnce top_args) + where + top_args = concatMap collectArgsTop binds + +isLocal :: Id -> Bool +isLocal i = isNothing (nameModule_maybe . idName $ i) && not (isExportedId i) + +-- | since we have sequential initialization, topsort the non-recursive +-- constructor bindings +topSortDecls :: Module -> [CgStgBinding] -> [CgStgBinding] +topSortDecls _m binds = rest ++ nr' + where + (nr, rest) = partition isNonRec binds + isNonRec StgNonRec{} = True + isNonRec _ = False + vs = map getV nr + keys = mkUniqSet (map node_key vs) + getV e@(StgNonRec b _) = DigraphNode e b [] + getV _ = error "topSortDecls: getV, unexpected binding" + collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args _typ)) = + [ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ] + collectDeps _ = [] + g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr) + nr' | (not . null) [()| CyclicSCC _ <- stronglyConnCompG g] + = error "topSortDecls: unexpected cycle" + | otherwise = map node_payload (topologicalSortG g) diff --git a/GHC/StgToJS/Sinker/StringsUnfloat.hs b/GHC/StgToJS/Sinker/StringsUnfloat.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Sinker/StringsUnfloat.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +module GHC.StgToJS.Sinker.StringsUnfloat + ( unfloatStringLits + ) + where + +import GHC.Prelude +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Literal +import GHC.Utils.Misc (partitionWith) + +import Data.ByteString qualified as BS +import Data.ByteString (ByteString) +import Data.Bifunctor (Bifunctor (..)) + +-- | We suppose that every string shorter than 80 symbols is safe for sink. +-- Sinker is working on per module. It means that ALL locally defined strings +-- in a module shorter 80 symbols will be unfloated back. +pattern STRING_LIT_MAX_LENGTH :: Int +pattern STRING_LIT_MAX_LENGTH = 80 + +unfloatStringLits + :: UniqSet Name + -> UniqFM Name ByteString + -> [CgStgBinding] + -> ([CgStgBinding], UniqSet Name) +unfloatStringLits usedOnceStringLits stringLits = + unfloatStringLits' (selectStringLitsForUnfloat usedOnceStringLits stringLits) + +-- | We are doing attempts to unfloat string literals back to +-- the call site. Further special JS optimizations +-- can generate more performant operations over them. +unfloatStringLits' :: UniqFM Name ByteString -> [CgStgBinding] -> ([CgStgBinding], UniqSet Name) +unfloatStringLits' stringLits allBindings = (binderWithoutChanges ++ binderWithUnfloatedStringLit, actuallyUsedStringLitNames) + where + (binderWithoutChanges, binderWithUnfloatedStringLitPairs) = partitionWith substituteStringLit allBindings + + binderWithUnfloatedStringLit = fst <$> binderWithUnfloatedStringLitPairs + actuallyUsedStringLitNames = unionManyUniqSets (snd <$> binderWithUnfloatedStringLitPairs) + + substituteStringLit :: CgStgBinding -> Either CgStgBinding (CgStgBinding, UniqSet Name) + substituteStringLit x@(StgRec bnds) + | isEmptyUniqSet names = Left x + | otherwise = Right (StgRec bnds', names) + where + (bnds', names) = extractNames id $ do + (i, rhs) <- bnds + pure $ case processStgRhs rhs of + Nothing -> Left (i, rhs) + Just (rhs', names) -> Right ((i, rhs'), names) + substituteStringLit x@(StgNonRec binder rhs) + = maybe (Left x) + (\(body', names) -> Right (StgNonRec binder body', names)) + (processStgRhs rhs) + + processStgRhs :: CgStgRhs -> Maybe (CgStgRhs, UniqSet Name) + processStgRhs (StgRhsCon ccs dataCon mu ticks args typ) + | isEmptyUniqSet names = Nothing + | otherwise = Just (StgRhsCon ccs dataCon mu ticks unified typ, names) + where + (unified, names) = substituteArgWithNames args + processStgRhs (StgRhsClosure fvs ccs upd bndrs body typ) + = (\(body', names) -> (StgRhsClosure fvs ccs upd bndrs body' typ, names)) <$> + processStgExpr body + + -- Recursive expressions + processStgExpr :: CgStgExpr -> Maybe (CgStgExpr, UniqSet Name) + processStgExpr (StgLit _) = Nothing + processStgExpr (StgTick _ _) = Nothing + processStgExpr (StgLet n b e) = + case (substituteStringLit b, processStgExpr e) of + (Left _, Nothing) -> Nothing + (Right (b', names), Nothing) -> Just (StgLet n b' e, names) + (Left _, Just (e', names)) -> Just (StgLet n b e', names) + (Right (b', names), Just (e', names')) -> Just (StgLet n b' e', names `unionUniqSets` names') + processStgExpr (StgLetNoEscape n b e) = + case (substituteStringLit b, processStgExpr e) of + (Left _, Nothing) -> Nothing + (Right (b', names), Nothing) -> Just (StgLetNoEscape n b' e, names) + (Left _, Just (e', names)) -> Just (StgLetNoEscape n b e', names) + (Right (b', names), Just (e', names')) -> Just (StgLetNoEscape n b' e', names `unionUniqSets` names') + -- We should keep the order: See Note [Case expression invariants] + processStgExpr (StgCase e bndr alt_type alts) = + case (isEmptyUniqSet names, processStgExpr e) of + (True, Nothing) -> Nothing + (True, Just (e', names')) -> Just (StgCase e' bndr alt_type alts, names') + (False, Nothing) -> Just (StgCase e bndr alt_type unified, names) + (False, Just (e', names')) -> Just (StgCase e' bndr alt_type unified, names `unionUniqSets` names') + where + (unified, names) = extractNames splitAlts alts + + splitAlts :: CgStgAlt -> Either CgStgAlt (CgStgAlt, UniqSet Name) + splitAlts alt@(GenStgAlt con bndrs rhs) = + case processStgExpr rhs of + Nothing -> Left alt + Just (alt', names) -> Right (GenStgAlt con bndrs alt', names) + + -- No args + processStgExpr (StgApp _ []) = Nothing + processStgExpr (StgConApp _ _ [] _) = Nothing + processStgExpr (StgOpApp _ [] _) = Nothing + + -- Main targets. Preserving the order of args is important + processStgExpr (StgApp fn args@(_:_)) + | isEmptyUniqSet names = Nothing + | otherwise = Just (StgApp fn unified, names) + where + (unified, names) = substituteArgWithNames args + processStgExpr (StgConApp dc n args@(_:_) tys) + | isEmptyUniqSet names = Nothing + | otherwise = Just (StgConApp dc n unified tys, names) + where + (unified, names) = substituteArgWithNames args + processStgExpr (StgOpApp op args@(_:_) tys) + | isEmptyUniqSet names = Nothing + | otherwise = Just (StgOpApp op unified tys, names) + where + (unified, names) = substituteArgWithNames args + + substituteArg :: StgArg -> Either StgArg (StgArg, Name) + substituteArg a@(StgLitArg _) = Left a + substituteArg a@(StgVarArg i) = + let name = idName i + in case lookupUFM stringLits name of + Nothing -> Left a + Just b -> Right (StgLitArg $ LitString b, name) + + substituteArgWithNames = extractNames (second (second unitUniqSet) . substituteArg) + + extractNames :: (a -> Either x (x, UniqSet Name)) -> [a] -> ([x], UniqSet Name) + extractNames splitter target = + let + splitted = splitter <$> target + combined = either (, emptyUniqSet) id <$> splitted + unified = fst <$> combined + names = unionManyUniqSets (snd <$> combined) + in (unified, names) + +selectStringLitsForUnfloat :: UniqSet Name -> UniqFM Name ByteString -> UniqFM Name ByteString +selectStringLitsForUnfloat usedOnceStringLits stringLits = alwaysUnfloat `plusUFM` usedOnceUnfloat + where + alwaysUnfloat = alwaysUnfloatStringLits stringLits + usedOnceUnfloat = selectUsedOnceStringLits usedOnceStringLits stringLits + + alwaysUnfloatStringLits :: UniqFM Name ByteString -> UniqFM Name ByteString + alwaysUnfloatStringLits = filterUFM $ \b -> BS.length b < STRING_LIT_MAX_LENGTH + + selectUsedOnceStringLits :: UniqSet Name -> UniqFM Name ByteString -> UniqFM Name ByteString + selectUsedOnceStringLits usedOnceStringLits stringLits = + stringLits `intersectUFM` getUniqSet usedOnceStringLits diff --git a/GHC/StgToJS/Stack.hs b/GHC/StgToJS/Stack.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Stack.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Stack +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- Utilities and wrappers for Stack manipulation in JS Land. +-- +-- In general, functions suffixed with a tick do the actual work, functions +-- suffixed with an "I" are identical to the non-I versions but work on 'Ident's +-- +-- The stack in JS land is held in the special JS array 'h$stack' and the stack +-- pointer is held in 'h$sp'. The top of the stack thus exists at +-- 'h$stack[h$sp]'. h$stack[h$sp + i] where i > 0, moves deeper into the stack +-- into older entries, whereas h$stack[h$sp - i] moves towards the top of the +-- stack. +-- +-- The stack layout algorithm is slightly peculiar. It makes an effort to +-- remember recently popped things so that if these values need to be pushed +-- then they can be quickly. The implementation for this is storing these values +-- above the stack pointer, and the pushing will skip slots that we know we will +-- use and fill in slots marked as unknown. Thus, you may find that our push and +-- pop functions do some non-traditional stack manipulation such as adding slots +-- in pop or removing slots in push. +----------------------------------------------------------------------------- + +module GHC.StgToJS.Stack + ( resetSlots + , isolateSlots + , setSlots + , getSlots + , addSlots + , dropSlots + , addUnknownSlots + , push + , push' + , adjSpN + , adjSpN' + , adjSp' + , adjSp + , pushNN + , pushNN' + , pushN' + , pushN + , pushOptimized' + , pushOptimized + , pushLneFrame + , popN + , popSkip + , popSkipI + , loadSkip + -- * Thunk update + , updateThunk + , updateThunk' + , bhStats + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.Make +import GHC.JS.Ident + +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Heap +import GHC.StgToJS.Ids +import GHC.StgToJS.Monad +import GHC.StgToJS.Regs +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types + +import GHC.Types.Id +import GHC.Utils.Misc +import GHC.Data.FastString + +import qualified Data.Bits as Bits +import qualified Data.List as L +import qualified Control.Monad.Trans.State.Strict as State +import Data.Array +import Data.Monoid +import Control.Monad + +-- | Run the action, 'm', with no stack info +resetSlots :: G a -> G a +resetSlots m = do + s <- getSlots + d <- getStackDepth + setSlots [] + a <- m + setSlots s + setStackDepth d + return a + +-- | run the action, 'm', with current stack info, but don't let modifications +-- propagate +isolateSlots :: G a -> G a +isolateSlots m = do + s <- getSlots + d <- getStackDepth + a <- m + setSlots s + setStackDepth d + pure a + +-- | Set stack depth +setStackDepth :: Int -> G () +setStackDepth d = modifyGroup (\s -> s { ggsStackDepth = d}) + +-- | Get stack depth +getStackDepth :: G Int +getStackDepth = State.gets (ggsStackDepth . gsGroup) + +-- | Modify stack depth +modifyStackDepth :: (Int -> Int) -> G () +modifyStackDepth f = modifyGroup (\s -> s { ggsStackDepth = f (ggsStackDepth s) }) + +-- | overwrite our stack knowledge +setSlots :: [StackSlot] -> G () +setSlots xs = modifyGroup (\g -> g { ggsStack = xs}) + +-- | retrieve our current stack knowledge +getSlots :: G [StackSlot] +getSlots = State.gets (ggsStack . gsGroup) + +-- | Modify stack slots +modifySlots :: ([StackSlot] -> [StackSlot]) -> G () +modifySlots f = modifyGroup (\g -> g { ggsStack = f (ggsStack g)}) + +-- | add `n` unknown slots to our stack knowledge +addUnknownSlots :: Int -> G () +addUnknownSlots n = addSlots (replicate n SlotUnknown) + +-- | add knowledge about the stack slots +addSlots :: [StackSlot] -> G () +addSlots xs = do + s <- getSlots + setSlots (xs ++ s) + +-- | drop 'n' slots from our stack knowledge +dropSlots :: Int -> G () +dropSlots n = modifySlots (drop n) + +push :: [JStgExpr] -> G JStgStat +push xs = do + dropSlots (length xs) + modifyStackDepth (+ (length xs)) + flip push' xs <$> getSettings + +push' :: StgToJSConfig -> [JStgExpr] -> JStgStat +push' _ [] = mempty +push' cs xs + | csInlinePush cs || l > 32 || l < 2 = adjSp' l <> mconcat items + | otherwise = ApplStat (toJExpr $ pushN ! l) xs + where + items = zipWith f [(1::Int)..] xs + offset i | i == l = sp + | otherwise = InfixExpr SubOp sp (toJExpr (l - i)) + l = length xs + f i e = AssignStat ((IdxExpr stack) (toJExpr (offset i))) AssignOp (toJExpr e) + + +-- | Grow the stack pointer by 'n' without modifying the stack depth. The stack +-- is just a JS array so we add to grow (instead of the traditional subtract) +adjSp' :: Int -> JStgStat +adjSp' 0 = mempty +adjSp' n = sp |= InfixExpr AddOp sp (toJExpr n) + +-- | Shrink the stack pointer by 'n'. The stack grows downward so substract +adjSpN' :: Int -> JStgStat +adjSpN' 0 = mempty +adjSpN' n = sp |= InfixExpr SubOp sp (toJExpr n) + +-- | Wrapper which adjusts the stack pointer /and/ modifies the stack depth +-- tracked in 'G'. See also 'adjSp'' which actually does the stack pointer +-- manipulation. +adjSp :: Int -> G JStgStat +adjSp 0 = return mempty +adjSp n = do + -- grow depth by n + modifyStackDepth (+n) + return (adjSp' n) + +-- | Shrink the stack and stack pointer. NB: This function is unsafe when the +-- input 'n', is negative. This function wraps around 'adjSpN' which actually +-- performs the work. +adjSpN :: Int -> G JStgStat +adjSpN 0 = return mempty +adjSpN n = do + modifyStackDepth (\x -> x - n) + return (adjSpN' n) + +-- | A constant array that holds global function symbols which do N pushes onto +-- the stack. For example: +-- @ +-- function h$p1(x1) { +-- ++h$sp; +-- h$stack[(h$sp - 0)] = x1; +-- }; +-- function h$p2(x1, x2) { +-- h$sp += 2; +-- h$stack[(h$sp - 1)] = x1; +-- h$stack[(h$sp - 0)] = x2; +-- }; +-- @ +-- +-- and so on up to 32. +pushN :: Array Int Ident +pushN = listArray (1,32) $ map (name . mkFastString . ("h$p"++) . show) [(1::Int)..32] + +-- | Convert all function symbols in 'pushN' to global top-level functions. This +-- is a hack which converts the function symbols to variables. This hack is +-- caught in 'GHC.StgToJS.Printer.prettyBlock'' to turn these into global +-- functions. +pushN' :: Array Int JStgExpr +pushN' = fmap (ValExpr . JVar) pushN + +-- | Partial Push functions. Like 'pushN' except these push functions skip +-- slots. For example, +-- @ +-- function h$pp33(x1, x2) { +-- h$sp += 6; +-- h$stack[(h$sp - 5)] = x1; +-- h$stack[(h$sp - 0)] = x2; +-- }; +-- @ +-- +-- The 33rd entry skips slots 1-4 to bind the top of the stack and the 6th +-- slot. See 'pushOptimized' and 'pushOptimized'' for use cases. +pushNN :: Array Integer Ident +pushNN = listArray (1,255) $ map (name . mkFastString . ("h$pp"++) . show) [(1::Int)..255] + +-- | Like 'pushN'' but for the partial push functions +pushNN' :: Array Integer JStgExpr +pushNN' = fmap (ValExpr . JVar) pushNN + +pushOptimized' :: [(Id,Int)] -> G JStgStat +pushOptimized' xs = do + slots <- getSlots + pushOptimized =<< (zipWithM f xs (slots++repeat SlotUnknown)) + where + f (i1,n1) xs2 = do + xs <- varsForId i1 + let !id_n1 = xs !! (n1-1) + + case xs2 of + SlotId i2 n2 -> pure (id_n1,i1==i2&&n1==n2) + _ -> pure (id_n1,False) + +-- | optimized push that reuses existing values on stack automatically chooses +-- an optimized partial push (h$ppN) function when possible. +pushOptimized :: [(JStgExpr,Bool)] -- ^ contents of the slots, True if same value is already there + -> G JStgStat +pushOptimized [] = return mempty +pushOptimized xs = do + dropSlots l + modifyStackDepth (+ length xs) + go . csInlinePush <$> getSettings + where + go True = inlinePush + go _ + | all snd xs = adjSp' l + | all (not.snd) xs && l <= 32 = + ApplStat (pushN' ! l) (map fst xs) + | l <= 8 && not (snd $ last xs) = + ApplStat (pushNN' ! sig) [ e | (e,False) <- xs ] + | otherwise = inlinePush + l = length xs + sig :: Integer + sig = L.foldl1' (Bits..|.) $ zipWith (\(_e,b) i -> if not b then Bits.bit i else 0) xs [0..] + inlinePush = adjSp' l <> mconcat (zipWith pushSlot [1..] xs) + pushSlot i (ex, False) = IdxExpr stack (offset i) |= ex + pushSlot _ _ = mempty + offset i | i == l = sp + | otherwise = InfixExpr SubOp sp (toJExpr (l - i)) + +-- | push a let-no-escape frame onto the stack +pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStgStat +pushLneFrame size ctx = + let ctx' = ctxLneShrinkStack ctx size + in pushOptimized' (ctxLneFrameVars ctx') + +-- | Pop things, don't update the stack knowledge in 'G' +popSkip :: Int -- ^ number of slots to skip + -> [JStgExpr] -- ^ assign stack slot values to these + -> JStgStat +popSkip 0 [] = mempty +popSkip n [] = adjSpN' n +popSkip n tgt = loadSkip n tgt <> adjSpN' (length tgt + n) + +-- | Load 'length (xs :: [JStgExpr])' things from the stack at offset 'n :: Int'. +-- This function does no stack pointer manipulation, it merely indexes into the +-- stack and loads payloads into 'xs'. +loadSkip :: Int -> [JStgExpr] -> JStgStat +loadSkip = loadSkipFrom sp + where + loadSkipFrom :: JStgExpr -> Int -> [JStgExpr] -> JStgStat + loadSkipFrom fr n xs = mconcat items + where + items = reverse $ zipWith f [(0::Int)..] (reverse xs) + -- helper to generate sp - n offset to index with + offset 0 = fr + offset n = InfixExpr SubOp fr (toJExpr n) + -- helper to load stack .! i into ex, e.g., ex = stack[i] + f i ex = ex |= IdxExpr stack (toJExpr (offset (i+n))) + + +-- | Pop but preserve the first N slots +popSkipI :: Int -> [(Ident,StackSlot)] -> G JStgStat +popSkipI 0 [] = pure mempty +popSkipI n [] = popN n +popSkipI n xs = do + -- add N unknown slots + addUnknownSlots n + -- now add the slots from xs, after this line the stack should look like + -- [xs] ++ [Unknown...] ++ old_stack + addSlots (map snd xs) + -- move stack pointer into the stack by (length xs + n), basically resetting + -- the stack pointer + a <- adjSpN (length xs + n) + -- now load skipping first N slots + return (loadSkipI n (map fst xs) <> a) + +-- | Just like 'loadSkip' but operate on 'Ident's rather than 'JStgExpr' +loadSkipI :: Int -> [Ident] -> JStgStat +loadSkipI = loadSkipIFrom sp + where loadSkipIFrom :: JStgExpr -> Int -> [Ident] -> JStgStat + loadSkipIFrom fr n xs = mconcat items + where + items = reverse $ zipWith f [(0::Int)..] (reverse xs) + offset 0 = fr + offset n = InfixExpr SubOp fr (toJExpr n) + f i ex = ex ||= IdxExpr stack (toJExpr (offset (i+n))) + +-- | Blindly pop N slots +popN :: Int -> G JStgStat +popN n = addUnknownSlots n >> adjSpN n + +-- | Generate statements to update the current node with a blackhole +bhStats :: StgToJSConfig -> Bool -> JStgStat +bhStats s pushUpd = mconcat + [ if pushUpd then push' s [r1, hdUpdFrame] else mempty + , toJExpr R1 .^ closureInfo_ |= hdBlackHole + , toJExpr R1 .^ closureField1_ |= hdCurrentThread + , toJExpr R1 .^ closureField2_ |= null_ -- will be filled with waiters array + ] + +-- | Wrapper around 'updateThunk'', performs the stack manipulation before +-- updating the Thunk. +updateThunk :: G JStgStat +updateThunk = do + settings <- getSettings + -- update frame size + let adjPushStack :: Int -> G () + adjPushStack n = do modifyStackDepth (+n) + dropSlots n + adjPushStack 2 + return $ updateThunk' settings + +-- | Update a thunk by checking 'StgToJSConfig'. If the config inlines black +-- holes then update inline, else make an explicit call to the black hole +-- handler. +updateThunk' :: StgToJSConfig -> JStgStat +updateThunk' settings = + if csInlineBlackhole settings + then bhStats settings True + else ApplStat hdBh [] diff --git a/GHC/StgToJS/StaticPtr.hs b/GHC/StgToJS/StaticPtr.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/StaticPtr.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.StaticPtr + ( initStaticPtrs + ) +where + +import GHC.Prelude +import GHC.Linker.Types (SptEntry(..)) +import GHC.Fingerprint.Type +import GHC.Types.Literal + +import GHC.JS.JStg.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Symbols +import GHC.StgToJS.Ids +import GHC.StgToJS.Literal +import GHC.StgToJS.Types + +initStaticPtrs :: [SptEntry] -> G JStgStat +initStaticPtrs ptrs = mconcat <$> mapM initStatic ptrs + where + initStatic (SptEntry sp_id (Fingerprint w1 w2)) = do + i <- varForId sp_id + fpa <- concat <$> mapM (genLit . mkLitWord64 . fromIntegral) [w1,w2] + let sptInsert = ApplStat hdHsSptInsert (fpa ++ [i]) + return $ (hdInitStatic .^ "push") `ApplStat` [Func [] sptInsert] diff --git a/GHC/StgToJS/Symbols.hs b/GHC/StgToJS/Symbols.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Symbols.hs @@ -0,0 +1,1216 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | JS symbol generation +module GHC.StgToJS.Symbols where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.Ident + +import GHC.Data.FastString +import GHC.Unit.Module +import GHC.Utils.Word64 (intToWord64) +import Data.ByteString (ByteString) +import Data.Word (Word64) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as BSL + +import Data.Array +import Data.Semigroup ((<>)) + +-- | Hexadecimal representation of an int +-- +-- Used for the sub indices. +intBS :: Int -> ByteString +intBS = word64BS . intToWord64 + +-- | Hexadecimal representation of a 64-bit word +-- +-- Used for uniques. We could use base-62 as GHC usually does but this is likely +-- faster. +word64BS :: Word64 -> ByteString +word64BS = BSL.toStrict . BSB.toLazyByteString . BSB.word64Hex + +-- | Return z-encoded unit:module +unitModuleStringZ :: Module -> ByteString +unitModuleStringZ mod = mconcat + [ fastZStringToByteString (zEncodeFS (unitIdFS (moduleUnitId mod))) + , BSC.pack "ZC" -- z-encoding for ":" + , fastZStringToByteString (zEncodeFS (moduleNameFS (moduleName mod))) + ] + +-- | the global linkable unit of a module exports this symbol, depend on it to +-- include that unit (used for cost centres) +moduleGlobalSymbol :: Module -> FastString +moduleGlobalSymbol m = mkFastStringByteString $ mconcat + [ hdB + , unitModuleStringZ m + , BSC.pack "_" + ] + +moduleExportsSymbol :: Module -> FastString +moduleExportsSymbol m = mkFastStringByteString $ mconcat + [ hdB + , unitModuleStringZ m + , BSC.pack "_" + ] + +-- | Make JS symbol corresponding to the given Haskell symbol in the given +-- module +mkJsSymbolBS :: Bool -> Module -> FastString -> ByteString +mkJsSymbolBS exported mod s = mconcat + [ if exported then hdB else hddB + , unitModuleStringZ mod + , BSC.pack "zi" -- z-encoding of "." + , fastZStringToByteString (zEncodeFS s) + ] + +-- | Make JS symbol corresponding to the given Haskell symbol in the given +-- module +mkJsSymbol :: Bool -> Module -> FastString -> FastString +mkJsSymbol exported mod s = mkFastStringByteString (mkJsSymbolBS exported mod s) + +-- | Make JS symbol for given module and unique. +mkFreshJsSymbol :: Module -> Int -> FastString +mkFreshJsSymbol mod i = mkFastStringByteString $ mconcat + [ hddB + , unitModuleStringZ mod + , BSC.pack "_" + , intBS i + ] + +-- | Make symbol "h$XYZ" or "h$$XYZ" +mkRawSymbol :: Bool -> FastString -> FastString +mkRawSymbol exported fs + | exported = mkFastStringByteString $ mconcat [ hdB, bytesFS fs ] + | otherwise = mkFastStringByteString $ mconcat [ hddB, bytesFS fs ] + +-- | "h$$" constant string +hddB :: ByteString +hddB = BSC.pack "h$$" + +-- | "h$" constant string +hdB :: ByteString +hdB = BSC.take 2 hddB + +hd :: JStgExpr +hd = global hdStr + +hdStr :: FastString +hdStr = mkFastStringByteString hdB + +hdlB :: ByteString +hdlB = BSC.pack "h$l" + +----------------------------------------- Runtime ------------------------------- +hdApply :: JStgExpr +hdApply = global hdApplyStr + +hdApplyStr :: FastString +hdApplyStr = fsLit "h$apply" + +hdMoveRegs2 :: FastString +hdMoveRegs2 = fsLit "h$moveRegs2" + +hdPapGen :: JStgExpr +hdPapGen = global hdPapGenStr + +hdPapGenStr :: FastString +hdPapGenStr = fsLit "h$pap_gen" + +hdSetReg :: JStgExpr +hdSetReg = global hdSetRegStr + +hdSetRegStr :: FastString +hdSetRegStr = fsLit "h$setReg" + +hdGetReg :: JStgExpr +hdGetReg = global hdGetRegStr + +hdGetRegStr :: FastString +hdGetRegStr = fsLit "h$getReg" + +hdResetRegisters :: Ident +hdResetRegisters = name "h$resetRegisters" + +hdResetResultVars :: Ident +hdResetResultVars = name "h$resetResultVars" + +hdInitClosure :: FastString +hdInitClosure = fsLit "h$init_closure" + +hdRegs :: JStgExpr +hdRegs = global (identFS hdRegsStr) + +hdRegsStr :: Ident +hdRegsStr = name "h$regs" + +hdReturn :: JStgExpr +hdReturn = global (identFS hdReturnStr) + +hdReturnStr :: Ident +hdReturnStr = name "h$return" + +hdStack :: JStgExpr +hdStack = global (identFS hdStackStr) + +hdStackStr :: Ident +hdStackStr = name "h$stack" + +hdStackPtr :: JStgExpr +hdStackPtr = global (identFS hdStackPtrStr) + +hdStackPtrStr :: Ident +hdStackPtrStr = name "h$sp" + +hdBlackHoleTrap :: JStgExpr +hdBlackHoleTrap = global (identFS hdBlackHoleTrapStr) + +hdBlackHoleTrapStr :: Ident +hdBlackHoleTrapStr = name "h$blackholeTrap" + +hdBlockOnBlackHoleStr :: FastString +hdBlockOnBlackHoleStr = "h$blockOnBlackhole" + +hdBlackHoleLNE :: JStgExpr +hdBlackHoleLNE = global (identFS hdBlackHoleLNEStr) + +hdBlackHoleLNEStr :: Ident +hdBlackHoleLNEStr = name "h$bh_lne" + +hdClosureTypeName :: JStgExpr +hdClosureTypeName = global (identFS hdClosureTypeNameStr) + +hdClosureTypeNameStr :: Ident +hdClosureTypeNameStr = name "h$closureTypeName" + +hdBh :: JStgExpr +hdBh = global hdBhStr + +hdBhStr :: FastString +hdBhStr = fsLit "h$bh" + +hdBlackHole :: JStgExpr +hdBlackHole = global (identFS hdBlackHoleStr) + +hdBlackHoleStr :: Ident +hdBlackHoleStr = name "h$blackhole" + +hdUpdFrame :: JStgExpr +hdUpdFrame = global (identFS hdUpdFrameStr) + +hdUpdFrameStr :: Ident +hdUpdFrameStr = name $ fsLit "h$upd_frame" + +hdCSel :: JStgExpr +hdCSel = global hdCSelStr + +hdCSelStr :: FastString +hdCSelStr = "h$c_sel_" + +hdEntry :: Ident +hdEntry = name hdEntryStr + +hdEntryStr :: FastString +hdEntryStr = fsLit "h$e" + +hdApGen :: JStgExpr +hdApGen = global (identFS hdApGenStr) + +hdApGenStr :: Ident +hdApGenStr = name "h$ap_gen" + +hdApGenFastStr :: Ident +hdApGenFastStr = name $ fsLit $ unpackFS (identFS hdApGenStr) ++ "_fast" + +hdLog :: JStgExpr +hdLog = global hdLogStr + +hdLogStr :: FastString +hdLogStr = fsLit "h$log" + +hdMkFunctionPtr :: JStgExpr +hdMkFunctionPtr = global "h$mkFunctionPtr" + +hdInitStatic :: JStgExpr +hdInitStatic = global (identFS hdInitStaticStr) + +hdInitStaticStr :: Ident +hdInitStaticStr = name "h$initStatic" + +hdHsSptInsert :: JStgExpr +hdHsSptInsert = global "h$hs_spt_insert" + +hdCurrentThread :: JStgExpr +hdCurrentThread = global (identFS hdCurrentThreadStr) + +hdCurrentThreadStr :: Ident +hdCurrentThreadStr = name "h$currentThread" + +hdWakeupThread :: FastString +hdWakeupThread = fsLit "h$wakeupThread" + +hdPaps :: JStgExpr +hdPaps = global hdPapsStr + +hdPapsStr :: FastString +hdPapsStr = fsLit "h$paps" + +hdPapStr_ :: FastString +hdPapStr_ = fsLit "h$pap_" + +hdLazyEntryStr :: Ident +hdLazyEntryStr = name "h$lazy_e" + +hdUnboxEntry :: JStgExpr +hdUnboxEntry = global (identFS hdUnboxEntryStr) + +hdUnboxEntryStr :: Ident +hdUnboxEntryStr = name "h$unbox_e" + +hdMaskFrame :: JStgExpr +hdMaskFrame = global (identFS hdMaskFrameStr) + +hdMaskFrameStr :: Ident +hdMaskFrameStr = name "h$maskFrame" + +hdUnMaskFrameStr :: Ident +hdUnMaskFrameStr = name "h$unmaskFrame" + +hdReturnF :: JStgExpr +hdReturnF = global (identFS hdReturnFStr) + +hdReturnFStr :: Ident +hdReturnFStr = name "h$returnf" + +hdResumeEntryStr :: Ident +hdResumeEntryStr = name "h$resume_e" + +hdFlushStdout :: JStgExpr +hdFlushStdout = global (identFS hdFlushStdoutStr) + +hdFlushStdoutStr :: Ident +hdFlushStdoutStr = name "h$flushStdout" + +hdFlushStdoutEntry :: JStgExpr +hdFlushStdoutEntry = global (identFS hdFlushStdoutEntryStr) + +hdFlushStdoutEntryStr :: Ident +hdFlushStdoutEntryStr = name "h$flushStdout_e" + +hdRunIOEntry :: JStgExpr +hdRunIOEntry = global (identFS hdRunIOEntryStr) + +hdRunIOEntryStr :: Ident +hdRunIOEntryStr = name "h$runio_e" + +hdReduce :: JStgExpr +hdReduce = global (identFS hdReduceStr) + +hdReduceStr :: Ident +hdReduceStr = name "h$reduce" + +hdThrowStr :: FastString +hdThrowStr = fsLit "h$throw" + +hdRaiseAsyncFrame :: JStgExpr +hdRaiseAsyncFrame = global (identFS hdRaiseAsyncFrameStr) + +hdRaiseAsyncFrameStr :: Ident +hdRaiseAsyncFrameStr = name "h$raiseAsync_frame" + +hdRaiseAsyncEntry :: JStgExpr +hdRaiseAsyncEntry = global (identFS hdRaiseAsyncEntryStr) + +hdRaiseAsyncEntryStr :: Ident +hdRaiseAsyncEntryStr = name "h$raiseAsync_e" + +hdRaiseEntry :: JStgExpr +hdRaiseEntry = global (identFS hdRaiseEntryStr) + +hdRaiseEntryStr :: Ident +hdRaiseEntryStr = name "h$raise_e" + +hdKeepAliveEntry :: JStgExpr +hdKeepAliveEntry = global (identFS hdKeepAliveEntryStr) + +hdKeepAliveEntryStr :: Ident +hdKeepAliveEntryStr = name "h$keepAlive_e" + +hdSelect2Return :: JStgExpr +hdSelect2Return = global (identFS hdSelect2ReturnStr) + +hdSelect2ReturnStr :: Ident +hdSelect2ReturnStr = name "h$select2_ret" + +hdSelect2Entry :: JStgExpr +hdSelect2Entry = global (identFS hdSelect2EntryStr) + +hdSelect2EntryStr :: Ident +hdSelect2EntryStr = name "h$select2_e" + +hdSelect1Ret :: JStgExpr +hdSelect1Ret = global (identFS hdSelect1RetStr) + +hdSelect1RetStr :: Ident +hdSelect1RetStr = name "h$select1_ret" + +hdSelect1EntryStr :: Ident +hdSelect1EntryStr = name "h$select1_e" + +hdStaticThunkStr :: FastString +hdStaticThunkStr = fsLit "h$static_thunk" + +hdStaticThunksStr + , hdStaticThunksArrStr + , hdCAFsStr + , hdCAFsResetStr :: Ident +hdStaticThunksStr = name "h$staticThunks" +hdStaticThunksArrStr = name "h$staticThunksArr" +hdCAFsStr = name "h$CAFs" +hdCAFsResetStr = name "h$CAFsReset" + +hdUpdThunkEntryStr :: Ident +hdUpdThunkEntryStr = name "h$upd_thunk_e" + +hdAp3EntryStr :: Ident +hdAp3EntryStr = name "h$ap3_e" + +hdAp2EntryStr :: Ident +hdAp2EntryStr = name "h$ap2_e" + +hdAp1EntryStr :: Ident +hdAp1EntryStr = name "h$ap1_e" + +hdDataToTagEntryStr :: Ident +hdDataToTagEntryStr = name "h$dataToTag_e" + +hdTagToEnum :: FastString +hdTagToEnum = fsLit "h$tagToEnum" + +hdCatchEntryStr :: Ident +hdCatchEntryStr = name "h$catch_e" + +hdNoopStr :: Ident +hdNoopStr = name "h$noop" + +hdNoopEntry :: JStgExpr +hdNoopEntry = global (identFS hdNoopEntryStr) + +hdNoopEntryStr :: Ident +hdNoopEntryStr = name "h$noop_e" + +hdC0 :: JStgExpr +hdC0 = global (identFS hdC0Str) + +hdC :: JStgExpr +hdC = global (identFS hdCStr) + +hdC0Str :: Ident +hdC0Str = name "h$c0" + +hdCStr :: Ident +hdCStr = name "h$c" + +hdData2Entry :: Ident +hdData2Entry = name "h$data2_e" + +hdData1Entry :: Ident +hdData1Entry = name "h$data1_e" + +hdTrueEntry :: Ident +hdTrueEntry = name "h$true_e" + +hdFalseEntry :: Ident +hdFalseEntry = name "h$false_e" + +hdDoneMainEntry :: JStgExpr +hdDoneMainEntry = global (identFS hdDoneMainEntryStr) + +hdDoneMainEntryStr :: Ident +hdDoneMainEntryStr = name "h$doneMain_e" + +hdDoneMain :: JStgExpr +hdDoneMain = global "h$doneMain" + +hdDone :: Ident +hdDone = name "h$done" + +hdExitProcess :: FastString +hdExitProcess = "h$exitProcess" + +hdTraceAlloc :: FastString +hdTraceAlloc = fsLit "h$traceAlloc" + +hdDebugAllocNotifyAlloc :: FastString +hdDebugAllocNotifyAlloc = fsLit "h$debugAlloc_notifyAlloc" + +hdRtsTraceForeign + , hdRtsProfiling + , hdCtFun + , hdCtCon + , hdCtThunk + , hdCtPap + , hdCtBlackhole + , hdCtStackFrame + , hdCtVtPtr + , hdVtVoid + , hdVtInt + , hdVtDouble + , hdVtLong + , hdVtAddr + , hdVtObj + , hdVtArr :: Ident +hdRtsTraceForeign = name "h$rts_traceForeign" +hdRtsProfiling = name "h$rts_profiling" +hdCtFun = name "h$ct_fun" +hdCtCon = name "h$ct_con" +hdCtThunk = name "h$ct_thunk" +hdCtPap = name "h$ct_pap" +hdCtBlackhole = name "h$ct_blackhole" +hdCtStackFrame = name "h$ct_stackframe" +hdCtVtPtr = name "h$vt_ptr" +hdVtVoid = name "h$vt_void" +hdVtInt = name "h$vt_int" +hdVtDouble = name "h$vt_double" +hdVtLong = name "h$vt_long" +hdVtAddr = name "h$vt_addr" +hdVtObj = name "h$vt_obj" +hdVtArr = name "h$vt_arr" + + +hdLoads :: Array Int Ident +hdLoads = listArray (1,32) [ name . mkFastStringByteString $ hdlB <> BSC.pack (show n) + | n <- [1..32::Int] + ] + +----------------------------------------- Precompiled Aps ---------------------- +hdAp00 :: JStgExpr +hdAp00 = global (identFS hdAp00Str) + +hdAp00Str :: Ident +hdAp00Str = name "h$ap_0_0" + +hdAp00FastStr :: FastString +hdAp00FastStr = fsLit "h$ap_0_0_fast" + +hdAp11Fast :: FastString +hdAp11Fast = fsLit "h$ap_1_1_fast" + +hdAp10 :: JStgExpr +hdAp10 = global "h$ap_1_0" + +hdAp33FastStr :: FastString +hdAp33FastStr = fsLit "h$ap_3_3_fast" + +hdAp22FastStr :: FastString +hdAp22FastStr = fsLit "h$ap_2_2_fast" + +----------------------------------------- ByteArray ----------------------------- +hdNewByteArrayStr :: FastString +hdNewByteArrayStr = "h$newByteArray" + +hdCopyMutableByteArrayStr :: FastString +hdCopyMutableByteArrayStr = "h$copyMutableByteArray" + +hdCheckOverlapByteArrayStr :: FastString +hdCheckOverlapByteArrayStr = "h$checkOverlapByteArray" + +hdShrinkMutableCharArrayStr :: FastString +hdShrinkMutableCharArrayStr = "h$shrinkMutableCharArray" + +----------------------------------------- EventLog ----------------------------- +hdTraceEventStr :: FastString +hdTraceEventStr = "h$traceEvent" + +hdTraceEventBinaryStr :: FastString +hdTraceEventBinaryStr = "h$traceEventBinary" + +hdTraceMarkerStr :: FastString +hdTraceMarkerStr = "h$traceMarker" + +----------------------------------------- FFI ---------------------------------- +hdThrowJSException :: JStgExpr +hdThrowJSException = global $ fsLit "h$throwJSException" + +hdUnboxFFIResult :: JStgExpr +hdUnboxFFIResult = global (identFS hdUnboxFFIResultStr) + +hdUnboxFFIResultStr :: Ident +hdUnboxFFIResultStr = name "h$unboxFFIResult" + +hdMkForeignCallback :: JStgExpr +hdMkForeignCallback = global $ fsLit "h$mkForeignCallback" + +hdTraceForeign :: JStgExpr +hdTraceForeign = global $ fsLit "h$traceForeign" + +hdBuildObject :: JStgExpr +hdBuildObject = global hdBuildObjectStr + +hdBuildObjectStr :: FastString +hdBuildObjectStr = fsLit "h$buildObject" + +hdCallDynamicStr :: FastString +hdCallDynamicStr = fsLit "h$callDynamic" + +except :: JStgExpr +except = global $ identFS exceptStr + +exceptStr :: Ident +exceptStr = name $ fsLit "except" + +excepStr :: FastString +excepStr = fsLit "excep" + +----------------------------------------- Accessors ----------------------------- + +-- for almost all other symbols that are faststrings we turn 'foo' into 'fooStr' +-- because these are overloaded with JStgExpr's. But for accessors we leave +-- these as FastStrings because they will become Idents after the refactor. +mv :: FastString +mv = fsLit "mv" + +lngth :: FastString +lngth = fsLit "length" + +-- | only for byte arrays. This is a JS byte array method +len :: FastString +len = fsLit "len" + +slice :: FastString +slice = fsLit "slice" + +this :: JStgExpr +this = global "this" + +arr :: FastString +arr = fsLit "arr" + +dv :: FastString +dv = fsLit "dv" + +d1, d2, d3 :: JStgExpr +d1 = global d1Str +d2 = global d2Str +d3 = global d3Str + +d1Str, d2Str, d3Str :: FastString +d1Str = fsLit "d1" +d2Str = fsLit "d2" +d3Str = fsLit "d3" + +getInt16 :: FastString +getInt16 = "getInt16" + +getUint16 :: FastString +getUint16 = "getUint16" + +getInt32 :: FastString +getInt32 = "getInt32" + +getUint32 :: FastString +getUint32 = "getUint32" + +getFloat32 :: FastString +getFloat32 = "getFloat32" + +getFloat64 :: FastString +getFloat64 = "getFloat64" + +setInt16 :: FastString +setInt16 = "setInt16" + +setUint16 :: FastString +setUint16 = "setUint16" + +setInt32 :: FastString +setInt32 = "setInt32" + +setUint32 :: FastString +setUint32 = "setUint32" + +setFloat32 :: FastString +setFloat32 = "setFloat32" + +setFloat64 :: FastString +setFloat64 = "setFloat64" + +i3, u8, u1, f6, f3 :: FastString +i3 = "i3" +u8 = "u8" +u1 = "u1" +f6 = "f6" +f3 = "f3" + +val :: FastString +val = fsLit "val" + +label :: FastString +label = fsLit "label" + +mask :: FastString +mask = fsLit "mask" + +unMask :: FastString +unMask = fsLit "unmask" + +resume :: FastString +resume = "resume" + +f :: FastString +f = fsLit "f" + +n :: FastString +n = fsLit "n" + +hasOwnProperty :: FastString +hasOwnProperty = fsLit "hasOwnProperty" + +hdCollectProps :: FastString +hdCollectProps = fsLit "h$collectProps" + +replace :: FastString +replace = fsLit "replace" + +substring :: FastString +substring = fsLit "substring" + +trace :: FastString +trace = fsLit "trace" + +apply :: FastString +apply = fsLit "apply" + +----------------------------------------- STM ---------------------------------- +hdMVar :: JStgExpr +hdMVar = global hdMVarStr + +hdMVarStr :: FastString +hdMVarStr = fsLit "h$MVar" + +hdTakeMVar :: JStgExpr +hdTakeMVar = global hdTakeMVarStr + +hdTakeMVarStr :: FastString +hdTakeMVarStr = fsLit "h$takeMVar" + +hdTryTakeMVarStr :: FastString +hdTryTakeMVarStr = fsLit "h$tryTakeMVar" + +hdPutMVarStr :: FastString +hdPutMVarStr = fsLit "h$putMVar" + +hdTryPutMVarStr :: FastString +hdTryPutMVarStr = fsLit "h$tryPutMVar" + +hdNewTVar :: FastString +hdNewTVar = fsLit "h$newTVar" + +hdReadTVar :: FastString +hdReadTVar = fsLit "h$readTVar" + +hdReadTVarIO :: FastString +hdReadTVarIO = fsLit "h$readTVarIO" + +hdWriteTVar :: FastString +hdWriteTVar = fsLit "h$writeTVar" + +hdReadMVarStr :: FastString +hdReadMVarStr = fsLit "h$readMVar" + +hdStmRemoveBlockedThreadStr :: FastString +hdStmRemoveBlockedThreadStr = fsLit "h$stmRemoveBlockedThread" + +hdStmStartTransactionStr :: FastString +hdStmStartTransactionStr = fsLit "h$stmStartTransaction" + +hdAtomicallyEntry :: JStgExpr +hdAtomicallyEntry = global (identFS hdAtomicallyEntryStr) + +hdAtomicallyEntryStr :: Ident +hdAtomicallyEntryStr = name $ fsLit "h$atomically_e" + +hdAtomicallyStr :: FastString +hdAtomicallyStr = "h$atomically" + +hdStgResumeRetryEntry :: JStgExpr +hdStgResumeRetryEntry = global (identFS hdStgResumeRetryEntryStr) + +hdStgResumeRetryEntryStr :: Ident +hdStgResumeRetryEntryStr = name $ fsLit "h$stmResumeRetry_e" + +hdStmCommitTransactionStr :: FastString +hdStmCommitTransactionStr = fsLit "h$stmCommitTransaction" + +hdStmValidateTransactionStr :: FastString +hdStmValidateTransactionStr = "h$stmValidateTransaction" + +hdStmCatchRetryEntry :: JStgExpr +hdStmCatchRetryEntry = global (identFS hdStmCatchRetryEntryStr) + +hdStmCatchRetryEntryStr :: Ident +hdStmCatchRetryEntryStr = name $ fsLit "h$stmCatchRetry_e" + +hdStmRetryStr :: FastString +hdStmRetryStr = fsLit "h$stmRetry" + +hdStmCatchRetryStr :: FastString +hdStmCatchRetryStr = fsLit "h$stmCatchRetry" + +hdStmCatchEntry :: JStgExpr +hdStmCatchEntry = global (identFS hdStmCatchEntryStr) + +hdCatchStmStr :: FastString +hdCatchStmStr = fsLit "h$catchStm" + +hdStmCatchEntryStr :: Ident +hdStmCatchEntryStr = name $ fsLit "h$catchStm_e" + +hdRetryInterrupted :: JStgExpr +hdRetryInterrupted = global (identFS hdRetryInterruptedStr) + +hdRetryInterruptedStr :: Ident +hdRetryInterruptedStr = name $ fsLit "h$retryInterrupted" + +hdMaskUnintFrame :: JStgExpr +hdMaskUnintFrame = global (identFS hdMaskUnintFrameStr) + +hdMaskUnintFrameStr :: Ident +hdMaskUnintFrameStr = name $ fsLit "h$maskUnintFrame" + +hdReschedule :: JStgExpr +hdReschedule = global (identFS hdRescheduleStr) + +hdRescheduleStr :: Ident +hdRescheduleStr = name $ fsLit "h$reschedule" + +hdRestoreThread :: JStgExpr +hdRestoreThread = global (identFS hdRestoreThreadStr) + +hdRestoreThreadStr :: Ident +hdRestoreThreadStr = name $ fsLit "h$restoreThread" + +hdFinishedThread :: FastString +hdFinishedThread = fsLit "h$finishThread" + +----------------------------------------- Z-Encodings --------------------------- +hdPrimOpStr :: FastString +hdPrimOpStr = fsLit "h$primop_" + +wrapperColonStr :: FastString +wrapperColonStr = fsLit "ghczuwrapperZC" -- equivalent non-z-encoding => ghc_wrapper: + +hdInternalExceptionTypeDivZero :: JStgExpr +hdInternalExceptionTypeDivZero = global "h$ghczminternalZCGHCziInternalziExceptionziTypezidivZZeroException" + +hdInternalExceptionTypeOverflow :: JStgExpr +hdInternalExceptionTypeOverflow = global "h$ghczminternalZCGHCziInternalziExceptionziTypezioverflowException" + +hdInternalExceptionTypeUnderflow :: JStgExpr +hdInternalExceptionTypeUnderflow = global "h$ghczminternalZCGHCziInternalziExceptionziTypeziunderflowException" + +hdInternalExceptionControlExceptionBaseNonTermination :: JStgExpr +hdInternalExceptionControlExceptionBaseNonTermination = global "h$ghczminternalZCGHCziInternalziControlziExceptionziBasezinonTermination" + +hdGhcInternalIOHandleFlush :: JStgExpr +hdGhcInternalIOHandleFlush = global "h$ghczminternalZCGHCziInternalziIOziHandlezihFlush" + +hdGhcInternalIOHandleFDStdout :: JStgExpr +hdGhcInternalIOHandleFDStdout = global "h$ghczminternalZCGHCziInternalziIOziHandleziFDzistdout" + +hdGhcInternalJSPrimValConEntryStr :: FastString +hdGhcInternalJSPrimValConEntryStr = fsLit "h$ghczminternalZCGHCziInternalziJSziPrimziJSVal_con_e" + +----------------------------------------- Profiling ----------------------------- +hdBuildCCSPtrStr :: FastString +hdBuildCCSPtrStr = "h$buildCCSPtr" + +hdClearCCSStr :: FastString +hdClearCCSStr = "h$clearCCS" + +hdRestoreCCSStr :: FastString +hdRestoreCCSStr = fsLit "h$restoreCCS" + +hdSetCcsEntry :: JStgExpr +hdSetCcsEntry = global (identFS hdSetCcsEntryStr) + +hdSetCcsEntryStr :: Ident +hdSetCcsEntryStr = name $ fsLit "h$setCcs_e" + +ccStr :: FastString +ccStr = fsLit "cc" +----------------------------------------- Others ------------------------------- +unknown :: FastString +unknown = fsLit "" + +typeof :: FastString +typeof = fsLit "typeof" + +throwStr :: FastString +throwStr = fsLit "throw" + +hdCheckObj :: JStgExpr +hdCheckObj = global $ fsLit "h$checkObj" + +console :: JStgExpr +console = global consoleStr + +consoleStr :: FastString +consoleStr = fsLit "console" + +arguments :: JStgExpr +arguments = global argumentsStr + +argumentsStr :: FastString +argumentsStr = fsLit "arguments" + +hdReportHeapOverflow :: JStgExpr +hdReportHeapOverflow = global (identFS hdReportHeapOverflowStr) + +hdReportHeapOverflowStr :: Ident +hdReportHeapOverflowStr = name $ fsLit "h$reportHeapOverflow" + +hdReportStackOverflow :: JStgExpr +hdReportStackOverflow = global (identFS hdReportStackOverflowStr) + +hdReportStackOverflowStr :: Ident +hdReportStackOverflowStr = name $ fsLit "h$reportStackOverflow" + +hdDumpRes :: JStgExpr +hdDumpRes = global (identFS hdDumpResStr) + +hdDumpResStr :: Ident +hdDumpResStr = name $ fsLit "h$dumpRes" + +ghcjsArray :: FastString +ghcjsArray = fsLit "__ghcjsArray" + +----------------------------------------- Compact ------------------------------- + +hdCompactSize :: FastString +hdCompactSize = fsLit "h$compactSize" + +hdCompactAddWithSharing :: FastString +hdCompactAddWithSharing = fsLit "h$compactAddWithSharing" + +hdCompactAdd :: FastString +hdCompactAdd = fsLit "h$compactAdd" + +hdCompactFixupPointers :: FastString +hdCompactFixupPointers = fsLit "h$compactFixupPointers" + +hdCompactAllocateBlock :: FastString +hdCompactAllocateBlock = fsLit "h$compactAllocateBlock" + +hdCompactGetNextBlock :: FastString +hdCompactGetNextBlock = fsLit "h$compactGetNextBlock" + +hdCompactGetFirstBlock :: FastString +hdCompactGetFirstBlock = fsLit "h$compactGetFirstBlock" + +hdCompactContainsAny :: FastString +hdCompactContainsAny = fsLit "h$compactContainsAny" + +hdCompactContains :: FastString +hdCompactContains = fsLit "h$compactContains" + +hdCompactResize :: FastString +hdCompactResize = fsLit "h$compactResize" + +hdCompactNew :: FastString +hdCompactNew = fsLit "h$compactNew" + +----------------------------------------- Stable Pointers ----------------------- + +hdStableNameInt :: FastString +hdStableNameInt = fsLit "h$stableNameInt" + +hdMakeStableName :: FastString +hdMakeStableName = fsLit "h$makeStableName" + +hdDeRefStablePtr :: FastString +hdDeRefStablePtr = fsLit "h$deRefStablePtr" + +hdStablePtrBuf :: JStgExpr +hdStablePtrBuf = global "h$stablePtrBuf" + +hdMakeStablePtrStr :: FastString +hdMakeStablePtrStr = fsLit "h$makeStablePtr" + +------------------------------- Weak Pointers ----------------------------------- + +hdKeepAlive :: FastString +hdKeepAlive = fsLit "h$keepAlive" + +hdFinalizeWeak :: FastString +hdFinalizeWeak = fsLit "h$finalizeWeak" + +hdMakeWeakNoFinalizer :: FastString +hdMakeWeakNoFinalizer = fsLit "h$makeWeakNoFinalizer" + +hdMakeWeak :: FastString +hdMakeWeak = fsLit "h$makeWeak" + +------------------------------- Concurrency Primitives ------------------------- + +hdGetThreadLabel :: FastString +hdGetThreadLabel = fsLit "h$getThreadLabel" + +hdListThreads :: FastString +hdListThreads = fsLit "h$listThreads" + +hdThreadStatus :: FastString +hdThreadStatus = fsLit "h$threadStatus" + +hdYield :: FastString +hdYield = fsLit "h$yield" + +hdKillThread :: FastString +hdKillThread = fsLit "h$killThread" + +hdFork :: FastString +hdFork = fsLit "h$fork" + +------------------------------- Delay/Wait Ops --------------------------------- + +hdWaitWrite :: FastString +hdWaitWrite = fsLit "h$waitWrite" + +hdWaitRead :: FastString +hdWaitRead = fsLit "h$waitRead" + +hdDelayThread :: FastString +hdDelayThread = fsLit "h$delayThread" + +------------------------------- Exceptions -------------------------------------- + +hdCatchStr :: FastString +hdCatchStr = fsLit "h$catch" + +hdMaskAsyncStr :: FastString +hdMaskAsyncStr = fsLit "h$maskAsync" + +hdMaskUnintAsyncStr :: FastString +hdMaskUnintAsyncStr = fsLit "h$maskUnintAsync" + +hdUnmaskAsyncStr :: FastString +hdUnmaskAsyncStr = fsLit "h$unmaskAsync" + +------------------------------- Mutable variables -------------------------------------- + +hdMutVarStr :: FastString +hdMutVarStr = fsLit "h$MutVar" + +hdAtomicModifyMutVar2Str :: FastString +hdAtomicModifyMutVar2Str = fsLit "h$atomicModifyMutVar2" + +hdAtomicModifyMutVarStr :: FastString +hdAtomicModifyMutVarStr = fsLit "h$atomicModifyMutVar" + +------------------------------- Addr# ------------------------------------------ + +hdComparePointerStr :: FastString +hdComparePointerStr = fsLit "h$comparePointer" + +------------------------------- Byte Arrays ------------------------------------- + +hdCompareByteArraysStr :: FastString +hdCompareByteArraysStr = fsLit "h$compareByteArrays" + +hdResizeMutableByteArrayStr :: FastString +hdResizeMutableByteArrayStr = fsLit "h$resizeMutableByteArray" + +hdShrinkMutableByteArrayStr :: FastString +hdShrinkMutableByteArrayStr = fsLit "h$shrinkMutableByteArray" + +------------------------------- Arrays ------------------------------------------ + +hdCopyMutableArrayStr :: FastString +hdCopyMutableArrayStr = fsLit "h$copyMutableArray" + +hdNewArrayStr :: FastString +hdNewArrayStr = fsLit "h$newArray" + +hdSliceArrayStr :: FastString +hdSliceArrayStr = fsLit "h$sliceArray" + +------------------------------ Float -------------------------------------------- + +hdDecodeFloatIntStr :: FastString +hdDecodeFloatIntStr = fsLit "h$decodeFloatInt" + +hdCastFloatToWord32Str :: FastString +hdCastFloatToWord32Str = fsLit "h$castFloatToWord32" + +hdCastWord32ToFloatStr :: FastString +hdCastWord32ToFloatStr = fsLit "h$castWord32ToFloat" + +------------------------------ Double ------------------------------------------- + +hdDecodeDouble2IntStr :: FastString +hdDecodeDouble2IntStr = fsLit "h$decodeDouble2Int" + +hdDecodeDoubleInt64Str :: FastString +hdDecodeDoubleInt64Str = fsLit "h$decodeDoubleInt64" + +hdCastDoubleToWord64Str :: FastString +hdCastDoubleToWord64Str = fsLit "h$castDoubleToWord64" + +hdCastWord64ToDoubleStr :: FastString +hdCastWord64ToDoubleStr = fsLit "h$castWord64ToDouble" + +------------------------------ Word ------------------------------------------- + +hdReverseWordStr :: FastString +hdReverseWordStr = fsLit "h$reverseWord" + +hdClz8Str + , hdClz16Str + , hdClz32Str + , hdClz64Str + , hdCtz8Str + , hdCtz16Str + , hdCtz32Str + , hdCtz64Str :: FastString + +hdClz8Str = fsLit "h$clz8" +hdClz16Str = fsLit "h$clz16" +hdClz32Str = fsLit "h$clz32" +hdClz64Str = fsLit "h$clz64" +hdCtz8Str = fsLit "h$ctz8" +hdCtz16Str = fsLit "h$ctz16" +hdCtz32Str = fsLit "h$ctz32" +hdCtz64Str = fsLit "h$ctz64" + +hdBSwap64Str :: FastString +hdBSwap64Str = "h$bswap64" + +hdPExit8Str + , hdPExit16Str + , hdPExit32Str + , hdPExit64Str + , hdPDep8Str + , hdPDep16Str + , hdPDep32Str + , hdPDep64Str :: FastString + +hdPExit8Str = fsLit "h$pext8" +hdPExit16Str = fsLit "h$pext16" +hdPExit32Str = fsLit "h$pext32" +hdPExit64Str = fsLit "h$pext64" +hdPDep8Str = fsLit "h$pdep8" +hdPDep16Str = fsLit "h$pdep16" +hdPDep32Str = fsLit "h$pdep32" +hdPDep64Str = fsLit "h$pdep64" + +hdPopCntTab :: JStgExpr +hdPopCntTab = global "h$popCntTab" + +hdPopCnt32Str :: FastString +hdPopCnt32Str = fsLit "h$popCnt32" + +hdPopCnt64Str :: FastString +hdPopCnt64Str = fsLit "h$popCnt64" + +hdQuotRem2Word32Str :: FastString +hdQuotRem2Word32Str = fsLit "h$quotRem2Word32" + +hdQuotRemWord32Str :: FastString +hdQuotRemWord32Str = fsLit "h$quotRemWord32" + +hdRemWord32Str :: FastString +hdRemWord32Str = fsLit "h$remWord32" + +hdQuotWord32Str :: FastString +hdQuotWord32Str = fsLit "h$quotWord32" + +hdMul2Word32Str :: FastString +hdMul2Word32Str = fsLit "h$mul2Word32" + +hdMulImulStr :: FastString +hdMulImulStr = fsLit "Math.imul" + +hdWordAdd2 :: FastString +hdWordAdd2 = fsLit "h$wordAdd2" + +hdHsPlusWord64Str :: FastString +hdHsPlusWord64Str = fsLit "h$hs_plusWord64" + +hdHsMinusWord64Str :: FastString +hdHsMinusWord64Str = fsLit "h$hs_minusWord64" + +hdHsTimesWord64Str :: FastString +hdHsTimesWord64Str = fsLit "h$hs_timesWord64" + +hdHsQuotWord64Str :: FastString +hdHsQuotWord64Str = fsLit "h$hs_quotWord64" + +hdHsRemWord64Str :: FastString +hdHsRemWord64Str = fsLit "h$hs_remWord64" + +hdHsUncheckedShiftRWord64Str :: FastString +hdHsUncheckedShiftRWord64Str = fsLit "h$hs_uncheckedShiftRWord64" + +hdHsUncheckedShiftLWord64Str :: FastString +hdHsUncheckedShiftLWord64Str = fsLit "h$hs_uncheckedShiftLWord64" + +hdHsPlusInt64Str :: FastString +hdHsPlusInt64Str = fsLit "h$hs_plusInt64" + +hdHsMinusInt64Str :: FastString +hdHsMinusInt64Str = fsLit "h$hs_minusInt64" + +hdHsTimesInt64Str :: FastString +hdHsTimesInt64Str = fsLit "h$hs_timesInt64" + +hdHsQuotInt64Str :: FastString +hdHsQuotInt64Str = fsLit "h$hs_quotInt64" + +hdHsRemInt64Str :: FastString +hdHsRemInt64Str = fsLit "h$hs_remInt64" + +hdHsUncheckedShiftLLInt64Str :: FastString +hdHsUncheckedShiftLLInt64Str = fsLit "h$hs_uncheckedShiftLLInt64" + +hdHsUncheckedShiftRAInt64Str :: FastString +hdHsUncheckedShiftRAInt64Str = fsLit "h$hs_uncheckedShiftRAInt64" + +hdHsUncheckedShiftRLInt64Str :: FastString +hdHsUncheckedShiftRLInt64Str = fsLit "h$hs_uncheckedShiftRLInt64" + +hdHsTimesInt2Str :: FastString +hdHsTimesInt2Str = fsLit "h$hs_timesInt2" + +------------------------------ Linker ------------------------------------------- + +hdEncodeModifiedUtf8Str :: FastString +hdEncodeModifiedUtf8Str = fsLit "h$encodeModifiedUtf8" + +hdRawStringDataStr :: FastString +hdRawStringDataStr = fsLit "h$rawStringData" + +hdPStr :: FastString +hdPStr = fsLit "h$p" + +hdDStr :: FastString +hdDStr = fsLit "h$d" + +hdDiStr :: FastString +hdDiStr = fsLit "h$di" + +hdStcStr :: FastString +hdStcStr = fsLit "h$stc" + +hdStlStr :: FastString +hdStlStr = fsLit "h$stl" + +hdStiStr :: FastString +hdStiStr = fsLit "h$sti" + +------------------------------ Pack/Unpack -------------------------------------------- + +hdDecodeUtf8Z :: FastString +hdDecodeUtf8Z = fsLit "h$decodeUtf8z" diff --git a/GHC/StgToJS/Types.hs b/GHC/StgToJS/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Types.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Types +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- Module that holds the Types required for the StgToJS pass +----------------------------------------------------------------------------- + +module GHC.StgToJS.Types where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.Ident +import qualified GHC.JS.Syntax as Sat +import GHC.JS.Make +import GHC.JS.Ppr () -- expose Outputable instances to downstream modules + +import GHC.StgToJS.Symbols + +import GHC.Stg.Syntax +import GHC.Core.TyCon +import GHC.Linker.Config + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Var +import GHC.Types.ForeignCall + +import Control.Monad.Trans.State.Strict +import GHC.Utils.Outputable (Outputable (..), text, SDocContext) + +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import GHC.Unit.Module + +import Data.Array +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Char (toUpper) +import qualified Data.Map as M +import Data.Monoid +import Data.Set (Set) +import Data.Word + +-- | A State monad over IO holding the generator state. +type G = StateT GenState IO + +-- | The JS code generator state +data GenState = GenState + { gsSettings :: !StgToJSConfig -- ^ codegen settings, read-only + , gsModule :: !Module -- ^ current module + , gsId :: {-# UNPACK #-} !FastMutInt -- ^ unique number for the id generator + , gsIdents :: !IdCache -- ^ hash consing for identifiers from a Unique + , gsUnfloated :: !(UniqFM Id CgStgExpr) -- ^ unfloated arguments + , gsGroup :: GenGroupState -- ^ state for the current binding group + , gsGlobal :: [JStgStat] -- ^ global (per module) statements (gets included when anything else from the module is used) + } + +-- | The JS code generator state relevant for the current binding group +data GenGroupState = GenGroupState + { ggsToplevelStats :: [JStgStat] -- ^ extra toplevel statements for the binding group + , ggsClosureInfo :: [ClosureInfo] -- ^ closure metadata (info tables) for the binding group + , ggsStatic :: [StaticInfo] -- ^ static (CAF) data in our binding group + , ggsStack :: [StackSlot] -- ^ stack info for the current expression + , ggsStackDepth :: Int -- ^ current stack depth + , ggsExtraDeps :: Set OtherSymb -- ^ extra dependencies for the linkable unit that contains this group + , ggsGlobalIdCache :: GlobalIdCache + , ggsForeignRefs :: [ForeignJSRef] + } + +-- | The Configuration record for the StgToJS pass +data StgToJSConfig = StgToJSConfig + -- flags + { csInlinePush :: !Bool + , csInlineBlackhole :: !Bool + , csInlineLoadRegs :: !Bool + , csInlineEnter :: !Bool + , csInlineAlloc :: !Bool + , csPrettyRender :: !Bool + , csTraceRts :: !Bool + , csAssertRts :: !Bool + , csBoundsCheck :: !Bool + , csDebugAlloc :: !Bool + , csTraceForeign :: !Bool + , csProf :: !Bool -- ^ Profiling enabled + , csRuntimeAssert :: !Bool -- ^ Enable runtime assertions + -- settings + , csContext :: !SDocContext + , csLinkerConfig :: !LinkerConfig -- ^ Emscripten linker + } + +-- | Closure info table +data ClosureInfo = ClosureInfo + { ciVar :: Ident -- ^ entry code identifier: infotable fields are stored as properties of this function + , ciRegs :: CIRegs -- ^ size of the payload (in number of JS values) + , ciName :: FastString -- ^ friendly name for printing + , ciLayout :: CILayout -- ^ heap/stack layout of the object + , ciType :: CIType -- ^ type of the object, with extra info where required + , ciStatic :: CIStatic -- ^ static references of this object + } + deriving stock (Eq, Show) + +-- | Closure information, 'ClosureInfo', registers +data CIRegs + = CIRegsUnknown -- ^ A value witnessing a state of unknown registers + | CIRegs { ciRegsSkip :: Int -- ^ unused registers before actual args start + , ciRegsTypes :: [JSRep] -- ^ args + } + deriving stock (Eq, Ord, Show) + +-- | Closure Information, 'ClosureInfo', layout +data CILayout + = CILayoutVariable -- ^ layout stored in object itself, first position from the start + | CILayoutUnknown -- ^ fixed size, but content unknown (for example stack apply frame) + { layoutSize :: !Int + } + | CILayoutFixed -- ^ whole layout known + { layoutSize :: !Int -- ^ closure size in array positions, including entry + , layout :: [JSRep] -- ^ The list of JSReps to layout + } + deriving stock (Eq, Ord, Show) + +-- | The type of 'ClosureInfo' +data CIType + = CIFun { citArity :: !Int -- ^ function arity + , citRegs :: !Int -- ^ number of registers for the args + } + | CIThunk -- ^ The closure is a THUNK + | CICon { citConstructor :: !Int } -- ^ The closure is a Constructor + | CIPap -- ^ The closure is a Partial Application + | CIBlackhole -- ^ The closure is a black hole + | CIStackFrame -- ^ The closure is a stack frame + deriving stock (Eq, Ord, Show) + +-- | Static references that must be kept alive +newtype CIStatic = CIStaticRefs { staticRefs :: [FastString] } + deriving stock (Eq) + deriving newtype (Semigroup, Monoid, Show) + +-- | static refs: array = references, null = nothing to report +-- note: only works after all top-level objects have been created +instance ToJExpr CIStatic where + toJExpr (CIStaticRefs []) = null_ -- [je| null |] + toJExpr (CIStaticRefs rs) = toJExpr (map global rs) + +-- | JS primitive representations +data JSRep + = PtrV -- ^ pointer = reference to heap object (closure object), lifted or not. + -- Can also be some RTS object (e.g. TVar#, MVar#, MutVar#, Weak#) + | VoidV -- ^ no fields + | DoubleV -- ^ A Double: one field + | IntV -- ^ An Int (32bit because JS): one field + | LongV -- ^ A Long: two fields one for the upper 32bits, one for the lower (NB: JS is little endian) + | AddrV -- ^ a pointer not to the heap: two fields, array + index + | ObjV -- ^ some JS object, user supplied, be careful around these, can be anything + | ArrV -- ^ boxed array + deriving stock (Eq, Ord, Enum, Bounded, Show) + +instance ToJExpr JSRep where + toJExpr = toJExpr . fromEnum + +-- | The type of identifiers. These determine the suffix of generated functions +-- in JS Land. For example, the entry function for the 'Just' constructor is a +-- 'IdConEntry' which compiles to: +-- @ +-- function h$ghczminternalZCGHCziInternalziMaybeziJust_con_e() { return h$rs() }; +-- @ +-- which just returns whatever the stack point is pointing to. Whereas the entry +-- function to 'Just' is an 'IdEntry' and does the work. It compiles to: +-- @ +-- function h$ghczminternalZCGHCziInternalziMaybeziJust_e() { +-- var h$$baseZCGHCziMaybezieta_8KXnScrCjF5 = h$r2; +-- h$r1 = h$c1(h$ghczminternalZCGHCziInternalziMaybeziJust_con_e, h$$ghczminternalZCGHCziInternalziMaybezieta_8KXnScrCjF5); +-- return h$rs(); +-- }; +-- @ +-- Which loads some payload from register 2, and applies the Constructor Entry +-- function for the Just to the payload, returns the result in register 1 and +-- returns whatever is on top of the stack +data IdType + = IdPlain -- ^ A plain identifier for values, no suffix added + | IdEntry -- ^ An entry function, suffix = "_e" in 'GHC.StgToJS.Ids.makeIdentForId' + | IdConEntry -- ^ A Constructor entry function, suffix = "_con_e" in 'GHC.StgToJS.Ids.makeIdentForId' + deriving (Enum, Eq, Ord) + +-- | Keys to differentiate Ident's in the ID Cache +data IdKey + = IdKey !Word64 !Int !IdType + deriving (Eq, Ord) + +-- | Some other symbol +data OtherSymb + = OtherSymb !Module !FastString + deriving Eq + +instance Ord OtherSymb where + compare (OtherSymb m1 t1) (OtherSymb m2 t2) + = stableModuleCmp m1 m2 <> lexicalCompareFS t1 t2 + +-- | The identifier cache indexed on 'IdKey' local to a module +newtype IdCache = IdCache (M.Map IdKey Ident) + +-- | The global Identifier Cache +newtype GlobalIdCache = GlobalIdCache (UniqFM Ident (IdKey, Id)) + +-- | A Stack Slot is either known or unknown. We avoid maybe here for more +-- strictness. +data StackSlot + = SlotId !Id !Int + | SlotUnknown + deriving (Eq, Ord) + +data StaticInfo = StaticInfo + { siVar :: !FastString -- ^ global object + , siVal :: !StaticVal -- ^ static initialization + , siCC :: !(Maybe Ident) -- ^ optional CCS name + } deriving stock (Eq, Show) + +data StaticAppKind + = SAKFun + -- ^ heap object for function + | SAKThunk + -- ^ heap object for CAF + | SAKData + -- ^ regular datacon app + deriving stock (Eq, Show) + +data StaticVal + = StaticUnboxed !StaticUnboxed + -- ^ unboxed constructor (Bool, Int, Double etc) + | StaticList [StaticArg] (Maybe FastString) + -- ^ list initializer (with optional tail) + | StaticApp StaticAppKind !FastString [StaticArg] + -- ^ static application of static args. Can be a CAF, a FUN, or a CON app. + deriving stock (Eq, Show) + +data StaticUnboxed + = StaticUnboxedBool !Bool + | StaticUnboxedInt !Integer + | StaticUnboxedDouble !SaneDouble + | StaticUnboxedString !BS.ByteString + | StaticUnboxedStringOffset !BS.ByteString + deriving stock (Eq, Ord, Show) + +-- | Static Arguments. Static Arguments are things that are statically +-- allocated, i.e., they exist at program startup. These are static heap objects +-- or literals or things that have been floated to the top level binding by ghc. +data StaticArg + = StaticObjArg !FastString -- ^ reference to a heap object + | StaticLitArg !StaticLit -- ^ literal + | StaticConArg !FastString [StaticArg] -- ^ unfloated constructor + deriving stock (Eq, Show) + +instance Outputable StaticArg where + ppr x = text (show x) + +-- | A Static literal value +data StaticLit + = BoolLit !Bool + | IntLit !Integer + | NullLit + | DoubleLit !SaneDouble -- should we actually use double here? + | StringLit !FastString + | BinLit !BS.ByteString + | LabelLit !Bool !FastString -- ^ is function pointer, label (also used for string / binary init) + deriving (Eq, Show) + +instance Outputable StaticLit where + ppr x = text (show x) + +instance ToJExpr StaticLit where + toJExpr (BoolLit b) = toJExpr b + toJExpr (IntLit i) = toJExpr i + toJExpr NullLit = null_ + toJExpr (DoubleLit d) = toJExpr (unSaneDouble d) + toJExpr (StringLit t) = app hdEncodeModifiedUtf8Str [toJExpr t] + toJExpr (BinLit b) = app hdRawStringDataStr [toJExpr (map toInteger (BS.unpack b))] + toJExpr (LabelLit _isFun lbl) = global lbl + +-- | A foreign reference to some JS code +data ForeignJSRef = ForeignJSRef + { foreignRefSrcSpan :: !FastString + , foreignRefPattern :: !FastString + , foreignRefSafety :: !Safety + , foreignRefCConv :: !CCallConv + , foreignRefArgs :: ![FastString] + , foreignRefResult :: !FastString + } + deriving (Show) + +-- | data used to generate one ObjBlock in our object file +data LinkableUnit = LinkableUnit + { luObjBlock :: ObjBlock -- ^ serializable unit info + , luIdExports :: [Id] -- ^ exported names from haskell identifiers + , luOtherExports :: [FastString] -- ^ other exports + , luIdDeps :: [Id] -- ^ identifiers this unit depends on + , luPseudoIdDeps :: [Unique] -- ^ pseudo-id identifiers this unit depends on (fixme) + , luOtherDeps :: [OtherSymb] -- ^ symbols not from a haskell id that this unit depends on + , luRequired :: Bool -- ^ always link this unit + , luForeignRefs :: [ForeignJSRef] + } + +-- | one toplevel block in the object file +data ObjBlock = ObjBlock + { oiSymbols :: [FastString] -- ^ toplevel symbols (stored in index) + , oiClInfo :: [ClosureInfo] -- ^ closure information of all closures in block + , oiStatic :: [StaticInfo] -- ^ static closure data + , oiStat :: Sat.JStat -- ^ the code + , oiRaw :: BS.ByteString -- ^ raw JS code + , oiFExports :: [ExpFun] + , oiFImports :: [ForeignJSRef] + } + +data ExpFun = ExpFun + { isIO :: !Bool + , args :: [JSFFIType] + , result :: !JSFFIType + } deriving (Eq, Ord, Show) + +-- | Types of FFI values +data JSFFIType + = Int8Type + | Int16Type + | Int32Type + | Int64Type + | Word8Type + | Word16Type + | Word32Type + | Word64Type + | DoubleType + | ByteArrayType + | PtrType + | RefType + deriving (Show, Ord, Eq, Enum) + + +-- | Typed expression +data TypedExpr = TypedExpr + { typex_typ :: !PrimRep + , typex_expr :: [JStgExpr] + } + +instance Outputable TypedExpr where + ppr (TypedExpr typ x) = ppr (typ, x) + +-- | A Primop result is either an inlining of some JS payload, or a primitive +-- call to a JS function defined in Shim files in base. +data PrimRes + = PrimInline JStgStat -- ^ primop is inline, result is assigned directly + | PRPrimCall JStgStat -- ^ primop is async call, primop returns the next + -- function to run. result returned to stack top in + -- registers + +data ExprResult + = ExprCont + | ExprInline + deriving (Eq) + +newtype ExprValData = ExprValData [JStgExpr] + deriving newtype (Eq) + +-- | A Closure is one of six types +data ClosureType + = Thunk -- ^ The closure is a THUNK + | Fun -- ^ The closure is a Function + | Pap -- ^ The closure is a Partial Application + | Con -- ^ The closure is a Constructor + | Blackhole -- ^ The closure is a Blackhole + | StackFrame -- ^ The closure is a stack frame + deriving (Show, Eq, Ord, Enum, Bounded, Ix) + +-- | Convert 'ClosureType' to an Int +ctNum :: ClosureType -> Int +ctNum Fun = 1 +ctNum Con = 2 +ctNum Thunk = 0 +ctNum Pap = 3 +ctNum Blackhole = 5 +ctNum StackFrame = -1 + +closureB :: ByteString +closureB = BSC.pack "_CLOSURE" + +closureNames :: Array ClosureType Ident +closureNames = listArray (minBound, maxBound) [ name $ mk_names n + | n <- enumFromTo minBound maxBound + ] + where + mk_names :: ClosureType -> FastString + mk_names nm = mkFastStringByteString + $ hdB + <> BSC.pack (map toUpper (show nm)) + <> closureB + +-- | Convert 'ClosureType' to a String +ctJsName :: ClosureType -> String +ctJsName = \case + Thunk -> "CLOSURE_TYPE_THUNK" + Fun -> "CLOSURE_TYPE_FUN" + Pap -> "CLOSURE_TYPE_PAP" + Con -> "CLOSURE_TYPE_CON" + Blackhole -> "CLOSURE_TYPE_BLACKHOLE" + StackFrame -> "CLOSURE_TYPE_STACKFRAME" + +instance ToJExpr ClosureType where + toJExpr e = toJExpr (ctNum e) + + +-- | A thread is in one of 4 states +data ThreadStatus + = Running -- ^ The thread is running + | Blocked -- ^ The thread is blocked + | Finished -- ^ The thread is done + | Died -- ^ The thread has died + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | Convert the status of a thread in JS land to an Int +threadStatusNum :: ThreadStatus -> Int +threadStatusNum = \case + Running -> 0 + Blocked -> 1 + Finished -> 16 + Died -> 17 + +-- | convert the status of a thread in JS land to a string +threadStatusJsName :: ThreadStatus -> String +threadStatusJsName = \case + Running -> "THREAD_RUNNING" + Blocked -> "THREAD_BLOCKED" + Finished -> "THREAD_FINISHED" + Died -> "THREAD_DIED" diff --git a/GHC/StgToJS/Utils.hs b/GHC/StgToJS/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Utils.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Utils + ( assignCoerce1 + , assignToExprCtx + , fixedLayout + , assocIdExprs + -- * Unboxable datacon + , isUnboxableCon + , isUnboxable + , isBoolDataCon + -- * JSRep + , slotCount + , varSize + , typeSize + , isVoid + , isMultiVar + , idJSRep + , typeJSRep + , unaryTypeJSRep + , primRepToJSRep + , primOrVoidRepToJSRep + , stackSlotType + , primRepSize + , mkArityTag + -- * References and Ids + , exprRefs + , hasExport + , collectTopIds + , collectIds + -- * Live variables + , LiveVars + , liveStatic + , liveVars + , stgRhsLive + , stgExprLive + , isUpdatableRhs + , stgLneLive' + , stgLneLiveExpr + , isInlineExpr + ) +where + +import GHC.Prelude + +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types + +import GHC.JS.JStg.Syntax +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep hiding (typeSize) +import GHC.Core.TyCon +import GHC.Core.Type hiding (typeSize) + +import GHC.Stg.Syntax + +import GHC.Tc.Utils.TcType + +import GHC.Builtin.Names +import GHC.Builtin.PrimOps (primOpIsReallyInline) + +import GHC.Types.RepType +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Unique.FM +import GHC.Types.ForeignCall +import GHC.Types.TyThing +import GHC.Types.Name + +import GHC.Utils.Misc +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.Panic + +import qualified Data.Bits as Bits +import qualified Data.Foldable as F +import qualified Data.Set as S +import qualified Data.List as L +import Data.Set (Set) +import Data.Monoid + + +assignToTypedExprs :: [TypedExpr] -> [JStgExpr] -> JStgStat +assignToTypedExprs tes es = + assignAllEqual (concatMap typex_expr tes) es + +assignTypedExprs :: [TypedExpr] -> [TypedExpr] -> JStgStat +assignTypedExprs tes es = + let prim_tes = concatMap typex_expr tes + prim_es = concatMap typex_expr es + -- extract the JExprs, effectively unarising a RuntimeRep thing to + -- multiple VarType-repped things (e.g., AddrRep takes two VarType-regs) + in assertPpr (equalLength prim_tes prim_es) + (ppr (map typex_typ tes) $$ ppr (map typex_typ es)) + (assignAllEqual prim_tes prim_es) + +assignToExprCtx :: ExprCtx -> [JStgExpr] -> JStgStat +assignToExprCtx ctx es = assignToTypedExprs (ctxTarget ctx) es + +-- | Assign first expr only (if it exists), performing coercions between some +-- PrimReps (e.g. StablePtr# and Addr#). +assignCoerce1 :: [TypedExpr] -> [TypedExpr] -> JStgStat +assignCoerce1 [x] [y] = assignCoerce x y +assignCoerce1 [] [] = mempty +-- We silently ignore the case of an empty list on the first argument. It denotes +-- "assign nothing to n empty slots on the right". Usually this case shouldn't come +-- up, but rare cases where the earlier code can't correctly guess the size of type +-- classes causes slots to be allocated when they aren't needed. +assignCoerce1 [] _ = mempty +assignCoerce1 x y = pprPanic "assignCoerce1" + (vcat [ text "lengths do not match" + -- FIXME: Outputable instance removed until JStg replaces JStat + , ppr x + , ppr y + ]) + +-- | Assign p2 to p1 with optional coercion +assignCoerce :: TypedExpr -> TypedExpr -> JStgStat +-- Coercion between StablePtr# and Addr# +assignCoerce (TypedExpr AddrRep [a_val, a_off]) (TypedExpr (BoxedRep (Just Unlifted)) [sptr]) = mconcat + [ a_val |= hdStablePtrBuf + , a_off |= sptr + ] +assignCoerce (TypedExpr (BoxedRep (Just Unlifted)) [sptr]) (TypedExpr AddrRep [_a_val, a_off]) = + sptr |= a_off +assignCoerce p1 p2 = assignTypedExprs [p1] [p2] + + +-------------------------------------------------------------------------------- +-- Core Utils +-------------------------------------------------------------------------------- + +-- | can we unbox C x to x, only if x is represented as a Number +isUnboxableCon :: DataCon -> Bool +isUnboxableCon dc + | [t] <- dataConRepArgTys dc + , [t1] <- typeJSRep (scaledThing t) + = isUnboxable t1 && + dataConTag dc == 1 && + length (tyConDataCons $ dataConTyCon dc) == 1 + | otherwise = False + +-- | one-constructor types with one primitive field represented as a JS Number +-- can be unboxed +isUnboxable :: JSRep -> Bool +isUnboxable DoubleV = True +isUnboxable IntV = True -- includes Char# +isUnboxable _ = False + +-- | Number of slots occupied by a PrimRep +data SlotCount + = NoSlot + | OneSlot + | TwoSlots + deriving (Show,Eq,Ord) + +instance Outputable SlotCount where + ppr = text . show + +-- | Return SlotCount as an Int +slotCount :: SlotCount -> Int +slotCount = \case + NoSlot -> 0 + OneSlot -> 1 + TwoSlots -> 2 + + +-- | Number of slots occupied by a value with the given JSRep +varSize :: JSRep -> Int +varSize = slotCount . jsRepSlots + +jsRepSlots :: JSRep -> SlotCount +jsRepSlots VoidV = NoSlot +jsRepSlots LongV = TwoSlots -- hi, low +jsRepSlots AddrV = TwoSlots -- obj/array, offset +jsRepSlots _ = OneSlot + +typeSize :: Type -> Int +typeSize t = sum . map varSize . typeJSRep $ t + +isVoid :: JSRep -> Bool +isVoid VoidV = True +isVoid _ = False + +isMultiVar :: JSRep -> Bool +isMultiVar v = case jsRepSlots v of + NoSlot -> False + OneSlot -> False + TwoSlots -> True + +idJSRep :: HasDebugCallStack => Id -> [JSRep] +idJSRep = typeJSRep . idType + +typeJSRep :: HasDebugCallStack => Type -> [JSRep] +typeJSRep t = map primRepToJSRep (typePrimRep t) + +-- only use if you know it's not an unboxed tuple +unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep +unaryTypeJSRep ut = primOrVoidRepToJSRep (typePrimRep1 ut) + +primRepToJSRep :: HasDebugCallStack => PrimRep -> JSRep +primRepToJSRep (BoxedRep _) = PtrV +primRepToJSRep IntRep = IntV +primRepToJSRep Int8Rep = IntV +primRepToJSRep Int16Rep = IntV +primRepToJSRep Int32Rep = IntV +primRepToJSRep WordRep = IntV +primRepToJSRep Word8Rep = IntV +primRepToJSRep Word16Rep = IntV +primRepToJSRep Word32Rep = IntV +primRepToJSRep Int64Rep = LongV +primRepToJSRep Word64Rep = LongV +primRepToJSRep AddrRep = AddrV +primRepToJSRep FloatRep = DoubleV +primRepToJSRep DoubleRep = DoubleV +primRepToJSRep (VecRep{}) = error "primRepToJSRep: vector types are unsupported" + +primOrVoidRepToJSRep :: HasDebugCallStack => PrimOrVoidRep -> JSRep +primOrVoidRepToJSRep VoidRep = VoidV +primOrVoidRepToJSRep (NVRep rep) = primRepToJSRep rep + +dataConType :: DataCon -> Type +dataConType dc = idType (dataConWrapId dc) + +isBoolDataCon :: DataCon -> Bool +isBoolDataCon dc = isBoolTy (dataConType dc) + +-- standard fixed layout: payload types +-- payload starts at .d1 for heap objects, entry closest to Sp for stack frames +fixedLayout :: [JSRep] -> CILayout +fixedLayout vts = CILayoutFixed (sum (map varSize vts)) vts + +-- 2-var values might have been moved around separately, use DoubleV as substitute +-- ObjV is 1 var, so this is no problem for implicit metadata +stackSlotType :: Id -> JSRep +stackSlotType i + | OneSlot <- jsRepSlots otype = otype + | otherwise = DoubleV + where otype = unaryTypeJSRep (idType i) + +idPrimReps :: Id -> [PrimRep] +idPrimReps = typePrimReps . idType + +typePrimReps :: Type -> [PrimRep] +typePrimReps = typePrimRep . unwrapType + +primRepSize :: PrimRep -> SlotCount +primRepSize p = jsRepSlots (primRepToJSRep p) + +-- | Associate the given values to each RrimRep in the given order, taking into +-- account the number of slots per PrimRep +assocPrimReps :: [PrimRep] -> [JStgExpr] -> [(PrimRep, [JStgExpr])] +assocPrimReps [] _ = [] +assocPrimReps (r:rs) vs = case (primRepSize r,vs) of + (NoSlot, xs) -> (r,[]) : assocPrimReps rs xs + (OneSlot, x:xs) -> (r,[x]) : assocPrimReps rs xs + (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs + err -> pprPanic "assocPrimReps" (ppr $ map jStgExprToJS <$> err) + +-- | Associate the given values to the Id's PrimReps, taking into account the +-- number of slots per PrimRep +assocIdPrimReps :: Id -> [JStgExpr] -> [(PrimRep, [JStgExpr])] +assocIdPrimReps i = assocPrimReps (idPrimReps i) + +-- | Associate the given JExpr to the Id's PrimReps, taking into account the +-- number of slots per PrimRep +assocIdExprs :: Id -> [JStgExpr] -> [TypedExpr] +assocIdExprs i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es) + +mkArityTag :: Int -> Int -> Int +mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8) + +-------------------------------------------------------------------------------- +-- Stg Utils +-------------------------------------------------------------------------------- + +s :: a -> Set a +s = S.singleton + +l :: (a -> Set Id) -> [a] -> Set Id +l = F.foldMap + +-- | collect Ids that this binding refers to +-- (does not include the bindees themselves) +-- first argument is Id -> StgExpr map for unfloated arguments +bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id +bindingRefs u = \case + StgNonRec _ rhs -> rhsRefs u rhs + StgRec bs -> l (rhsRefs u . snd) bs + +rhsRefs :: UniqFM Id CgStgExpr -> CgStgRhs -> Set Id +rhsRefs u = \case + StgRhsClosure _ _ _ _ body _ -> exprRefs u body + StgRhsCon _ccs d _mu _ticks args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args + +exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id +exprRefs u = \case + StgApp f args -> s f <> l (argRefs u) args + StgConApp d _n args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args + StgOpApp _ args _ -> l (argRefs u) args + StgLit {} -> mempty + StgCase expr _ _ alts -> exprRefs u expr <> mconcat (fmap (altRefs u) alts) + StgLet _ bnd expr -> bindingRefs u bnd <> exprRefs u expr + StgLetNoEscape _ bnd expr -> bindingRefs u bnd <> exprRefs u expr + StgTick _ expr -> exprRefs u expr + +altRefs :: UniqFM Id CgStgExpr -> CgStgAlt -> Set Id +altRefs u alt = exprRefs u (alt_rhs alt) + +argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id +argRefs u = \case + StgVarArg id + | Just e <- lookupUFM u id -> exprRefs u e + | otherwise -> s id + _ -> mempty + +hasExport :: CgStgBinding -> Bool +hasExport bnd = + case bnd of + StgNonRec b e -> isExportedBind b e + StgRec bs -> any (uncurry isExportedBind) bs + where + isExportedBind _i (StgRhsCon _cc con _ _ _ _) = + getUnique con == staticPtrDataConKey + isExportedBind _ _ = False + +collectTopIds :: CgStgBinding -> [Id] +collectTopIds (StgNonRec b _) = [b] +collectTopIds (StgRec bs) = let xs = map (zapFragileIdInfo . fst) bs + in seqList xs `seq` xs + +collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id] +collectIds unfloated b = + let xs = map zapFragileIdInfo . + filter acceptId $ S.toList (bindingRefs unfloated b) + in seqList xs `seq` xs + where + acceptId i = all ($ i) [not . isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden] + isForbidden i + -- the GHC.Prim module has no js source file + | Just m <- nameModule_maybe (getName i) + , m == gHC_PRIM + = True + -- unboxed tuples have no definition + | isUnboxedTupleDataConLikeName (getName i) + = True + | otherwise + = False + +----------------------------------------------------- +-- Live vars +-- +-- TODO: should probably be moved into GHC.Stg.LiveVars + +type LiveVars = DVarSet + +liveStatic :: LiveVars -> LiveVars +liveStatic = filterDVarSet isGlobalId + +liveVars :: LiveVars -> LiveVars +liveVars = filterDVarSet (not . isGlobalId) + +stgBindLive :: CgStgBinding -> [(Id, LiveVars)] +stgBindLive = \case + StgNonRec b rhs -> [(b, stgRhsLive rhs)] + StgRec bs -> map (\(b,rhs) -> (b, stgRhsLive rhs)) bs + +stgBindRhsLive :: CgStgBinding -> LiveVars +stgBindRhsLive b = + let (bs, ls) = unzip (stgBindLive b) + in delDVarSetList (unionDVarSets ls) bs + +stgRhsLive :: CgStgRhs -> LiveVars +stgRhsLive = \case + StgRhsClosure _ _ _ args e _ -> delDVarSetList (stgExprLive True e) args + StgRhsCon _ _ _ _ args _ -> unionDVarSets (map stgArgLive args) + +stgArgLive :: StgArg -> LiveVars +stgArgLive = \case + StgVarArg occ -> unitDVarSet occ + StgLitArg {} -> emptyDVarSet + +stgExprLive :: Bool -> CgStgExpr -> LiveVars +stgExprLive includeLHS = \case + StgApp occ args -> unionDVarSets (unitDVarSet occ : map stgArgLive args) + StgLit {} -> emptyDVarSet + StgConApp _dc _n args _tys -> unionDVarSets (map stgArgLive args) + StgOpApp _op args _ty -> unionDVarSets (map stgArgLive args) + StgCase e b _at alts + | includeLHS -> el `unionDVarSet` delDVarSet al b + | otherwise -> delDVarSet al b + where + al = unionDVarSets (map stgAltLive alts) + el = stgExprLive True e + StgLet _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) + StgLetNoEscape _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) + StgTick _ti e -> stgExprLive True e + +stgAltLive :: CgStgAlt -> LiveVars +stgAltLive alt = + delDVarSetList (stgExprLive True (alt_rhs alt)) (alt_bndrs alt) + +bindees :: CgStgBinding -> [Id] +bindees = \case + StgNonRec b _e -> [b] + StgRec bs -> map fst bs + +isUpdatableRhs :: CgStgRhs -> Bool +isUpdatableRhs (StgRhsClosure _ _ u _ _ _) = isUpdatable u +isUpdatableRhs _ = False + +stgLneLive' :: CgStgBinding -> [Id] +stgLneLive' b = filter (`notElem` bindees b) (stgLneLive b) + +stgLneLive :: CgStgBinding -> [Id] +stgLneLive (StgNonRec _b e) = stgLneLiveExpr e +stgLneLive (StgRec bs) = L.nub $ concatMap (stgLneLiveExpr . snd) bs + +stgLneLiveExpr :: CgStgRhs -> [Id] +stgLneLiveExpr rhs = dVarSetElems (liveVars $ stgRhsLive rhs) +-- stgLneLiveExpr (StgRhsClosure _ _ _ _ e) = dVarSetElems (liveVars (stgExprLive e)) +-- stgLneLiveExpr StgRhsCon {} = [] + +-- | returns True if the expression is definitely inline +isInlineExpr :: CgStgExpr -> Bool +isInlineExpr = \case + StgApp i args + -> isInlineApp i args + StgLit{} + -> True + StgConApp{} + -> True + StgOpApp (StgFCallOp f _) _ _ + -> isInlineForeignCall f + StgOpApp (StgPrimOp op) _ _ + -> primOpIsReallyInline op + StgOpApp (StgPrimCallOp _c) _ _ + -> True + StgCase e _ _ alts + ->let ie = isInlineExpr e + ias = map isInlineExpr (fmap alt_rhs alts) + in ie && and ias + StgLet _ _ e + -> isInlineExpr e + StgLetNoEscape _ _ e + -> isInlineExpr e + StgTick _ e + -> isInlineExpr e + +isInlineForeignCall :: ForeignCall -> Bool +isInlineForeignCall (CCall (CCallSpec _ cconv safety)) = + not (playInterruptible safety) && + not (cconv /= JavaScriptCallConv && playSafe safety) + +isInlineApp :: Id -> [StgArg] -> Bool +isInlineApp i = \case + _ | isJoinId i -> False + [] -> isUnboxedTupleType (idType i) || + isStrictType (idType i) || + ctxIsEvaluated i + + [StgVarArg a] + | DataConWrapId dc <- idDetails i + , isNewTyCon (dataConTyCon dc) + , isStrictType (idType a) || ctxIsEvaluated a || isStrictId a + -> True + _ -> False diff --git a/GHC/SysTools.hs b/GHC/SysTools.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools.hs @@ -0,0 +1,163 @@ + +{-# LANGUAGE ScopedTypeVariables #-} + +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2001-2003 +-- +-- Access to system tools: gcc, cp, rm etc +-- +----------------------------------------------------------------------------- +-} + +module GHC.SysTools ( + -- * Initialisation + initSysTools, + + -- * Interface to system tools + module GHC.SysTools.Tasks, + + -- * Fast file copy + copyFile, + copyHandle, + copyWithHeader, + + -- * General utilities + Option(..), + expandTopDir, + ) where + +import GHC.Prelude + + +import GHC.Utils.Panic +import GHC.Driver.Session + +import GHC.SysTools.Tasks +import GHC.SysTools.BaseDir +import GHC.Settings.IO + +import Control.Monad.Trans.Except (runExceptT) +import System.IO +import Foreign.Marshal.Alloc (allocaBytes) +import System.Directory (copyFile) + +{- +Note [How GHC finds toolchain utilities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC.SysTools.initSysProgs figures out exactly where all the auxiliary programs +are, and initialises mutable variables to make it easy to call them. +To do this, it makes use of definitions in Config.hs, which is a Haskell +file containing variables whose value is figured out by the build system. + +Config.hs contains two sorts of things + + cGCC, The *names* of the programs + cCPP e.g. cGCC = gcc + cUNLIT cCPP = gcc -E + etc They do *not* include paths + + + cUNLIT_DIR The *path* to the directory containing unlit, split etc + cSPLIT_DIR *relative* to the root of the build tree, + for use when running *in-place* in a build tree (only) + + +--------------------------------------------- +NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): + +Another hair-brained scheme for simplifying the current tool location +nightmare in GHC: Simon originally suggested using another +configuration file along the lines of GCC's specs file - which is fine +except that it means adding code to read yet another configuration +file. What I didn't notice is that the current package.conf is +general enough to do this: + +Package + {name = "tools", import_dirs = [], source_dirs = [], + library_dirs = [], hs_libraries = [], extra_libraries = [], + include_dirs = [], c_includes = [], package_deps = [], + extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.], + extra_cc_opts = [], extra_ld_opts = []} + +Which would have the advantage that we get to collect together in one +place the path-specific package stuff with the path-specific tool +stuff. + End of NOTES +--------------------------------------------- + +************************************************************************ +* * +\subsection{Initialisation} +* * +************************************************************************ +-} + + +initSysTools :: String -- TopDir path + -> IO Settings -- Set all the mutable variables above, holding + -- (a) the system programs + -- (b) the package-config file + -- (c) the GHC usage message +initSysTools top_dir = do + res <- runExceptT $ initSettings top_dir + case res of + Right a -> pure a + Left (SettingsError_MissingData msg) -> pgmError msg + Left (SettingsError_BadData msg) -> pgmError msg + +{- Note [Windows stack allocations] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See: #8870 (and #8834 for related info) and #12186 + +On Windows, occasionally we need to grow the stack. In order to do +this, we would normally just bump the stack pointer - but there's a +catch on Windows. + +If the stack pointer is bumped by more than a single page, then the +pages between the initial pointer and the resulting location must be +properly committed by the Windows virtual memory subsystem. This is +only needed in the event we bump by more than one page (i.e 4097 bytes +or more). + +Windows compilers solve this by emitting a call to a special function +called _chkstk, which does this committing of the pages for you. + +The reason this was causing a segfault was because due to the fact the +new code generator tends to generate larger functions, we needed more +stack space in GHC itself. In the x86 codegen, we needed approximately +~12kb of stack space in one go, which caused the process to segfault, +as the intervening pages were not committed. + +GCC can emit such a check for us automatically but only when the flag +-fstack-check is used. + +See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html +for more information. + +-} + +-- | Copy remaining bytes from the first Handle to the second one +copyHandle :: Handle -> Handle -> IO () +copyHandle hin hout = do + let buf_size = 8192 + allocaBytes buf_size $ \ptr -> do + let go = do + c <- hGetBuf hin ptr buf_size + hPutBuf hout ptr c + if c == 0 then return () else go + go + +-- | Copy file after printing the given header +copyWithHeader :: String -> FilePath -> FilePath -> IO () +copyWithHeader header from to = + withBinaryFile to WriteMode $ \hout -> do + -- write the header string in UTF-8. The header is something like + -- {-# LINE "foo.hs" #-} + -- and we want to make sure a Unicode filename isn't mangled. + hSetEncoding hout utf8 + hPutStr hout header + withBinaryFile from ReadMode $ \hin -> + copyHandle hin hout diff --git a/GHC/SysTools/Ar.hs b/GHC/SysTools/Ar.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Ar.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +{- Note [The need for Ar.hs] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +Building `-staticlib` previously required the presence of libtool, and was a +such restricted to mach-o only. As libtool on macOS and gnu libtool are very +different, there was no simple portable way to support this. + +libtool for static archives does essentially: concatenate the input archives, +add the input objects, and create a symbol index. Using `ar` for this task +fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same +features across platforms (e.g. index prefixed retrieval of objects with +the same name.) + +As archives are rather simple structurally, we can just build the archives +with Haskell directly and use ranlib on the final result to get the symbol +index. This should allow us to work around with the differences/availability +of libtool across different platforms. +-} +module GHC.SysTools.Ar + (ArchiveEntry(..) + ,Archive(..) + ,afilter + + ,parseAr + + ,loadAr + ,loadObj + ,writeBSDAr + ,writeGNUAr + + ,isBSDSymdef + ,isGNUSymdef + ) + where + +import GHC.Prelude + +import Data.List (mapAccumL, isPrefixOf) +import Data.Monoid ((<>)) +import Data.Binary.Get +import Data.Binary.Put +import Control.Monad +import Control.Applicative +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +#if !defined(mingw32_HOST_OS) +import qualified System.Posix.Files as POSIX +#endif +import System.FilePath (takeFileName) + +data ArchiveEntry = ArchiveEntry + { filename :: String -- ^ File name. + , filetime :: Int -- ^ File modification time. + , fileown :: Int -- ^ File owner. + , filegrp :: Int -- ^ File group. + , filemode :: Int -- ^ File mode. + , filesize :: Int -- ^ File size. + , filedata :: B.ByteString -- ^ File bytes. + } deriving (Eq, Show) + +newtype Archive = Archive [ArchiveEntry] + deriving (Eq, Show, Semigroup, Monoid) + +afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive +afilter f (Archive xs) = Archive (filter f xs) + +isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool +isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a) +isGNUSymdef a = "/" == (filename a) + +-- | Archives have numeric values padded with '\x20' to the right. +getPaddedInt :: B.ByteString -> Int +getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20') + +putPaddedInt :: Int -> Int -> Put +putPaddedInt padding i = putPaddedString '\x20' padding (show i) + +putPaddedString :: Char -> Int -> String -> Put +putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad) + +getBSDArchEntries :: Get [ArchiveEntry] +getBSDArchEntries = do + empty <- isEmpty + if empty then + return [] + else do + name <- getByteString 16 + when ('/' `C.elem` name && C.take 3 name /= "#1/") $ + fail "Looks like GNU Archive" + time <- getPaddedInt <$> getByteString 12 + own <- getPaddedInt <$> getByteString 6 + grp <- getPaddedInt <$> getByteString 6 + mode <- getPaddedInt <$> getByteString 8 + st_size <- getPaddedInt <$> getByteString 10 + end <- getByteString 2 + when (end /= "\x60\x0a") $ + fail ("[BSD Archive] Invalid archive header end marker for name: " ++ + C.unpack name) + off1 <- liftM fromIntegral bytesRead :: Get Int + -- BSD stores extended filenames, by writing #1/ into the + -- name field, the first @length@ bytes then represent the file name + -- thus the payload size is filesize + file name length. + name <- if C.unpack (C.take 3 name) == "#1/" then + liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name) + else + return $ C.unpack $ C.takeWhile (/= ' ') name + off2 <- liftM fromIntegral bytesRead :: Get Int + file <- getByteString (st_size - (off2 - off1)) + -- data sections are two byte aligned (see #15396) + when (odd st_size) $ + void (getByteString 1) + + rest <- getBSDArchEntries + return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest + +-- | GNU Archives feature a special '//' entry that contains the +-- extended names. Those are referred to as /, where num is the +-- offset into the '//' entry. +-- In addition, filenames are terminated with '/' in the archive. +getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry] +getGNUArchEntries extInfo = do + empty <- isEmpty + if empty + then return [] + else + do + name <- getByteString 16 + time <- getPaddedInt <$> getByteString 12 + own <- getPaddedInt <$> getByteString 6 + grp <- getPaddedInt <$> getByteString 6 + mode <- getPaddedInt <$> getByteString 8 + st_size <- getPaddedInt <$> getByteString 10 + end <- getByteString 2 + when (end /= "\x60\x0a") $ + fail ("[BSD Archive] Invalid archive header end marker for name: " ++ + C.unpack name) + file <- getByteString st_size + -- data sections are two byte aligned (see #15396) + when (odd st_size) $ + void (getByteString 1) + name <- return . C.unpack $ + if C.unpack (C.take 1 name) == "/" + then case C.takeWhile (/= ' ') name of + name@"/" -> name -- symbol table + name@"//" -> name -- extended file names table + name -> getExtName extInfo (read . C.unpack $ C.drop 1 name) + else C.takeWhile (/= '/') name + case name of + "/" -> getGNUArchEntries extInfo + "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file)) + _ -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo + + where + getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString + getExtName Nothing _ = error "Invalid extended filename reference." + getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info + +-- | put an Archive Entry. This assumes that the entries +-- have been preprocessed to account for the extended file name +-- table section "//" e.g. for GNU Archives. Or that the names +-- have been move into the payload for BSD Archives. +putArchEntry :: ArchiveEntry -> PutM () +putArchEntry (ArchiveEntry name time own grp mode st_size file) = do + putPaddedString ' ' 16 name + putPaddedInt 12 time + putPaddedInt 6 own + putPaddedInt 6 grp + putPaddedInt 8 mode + putPaddedInt 10 st_size + putByteString "\x60\x0a" + putByteString file + when (pad == 1) $ + putWord8 0x0a + where + pad = st_size `mod` 2 + +getArchMagic :: Get () +getArchMagic = do + magic <- liftM C.unpack $ getByteString 8 + if magic /= "!\n" + then fail $ "Invalid magic number " ++ show magic + else return () + +putArchMagic :: Put +putArchMagic = putByteString $ C.pack "!\n" + +getArch :: Get Archive +getArch = Archive <$> do + getArchMagic + getBSDArchEntries <|> getGNUArchEntries Nothing + +putBSDArch :: Archive -> PutM () +putBSDArch (Archive as) = do + putArchMagic + mapM_ putArchEntry (processEntries as) + + where + padStr pad size str = take size $ str <> repeat pad + nameSize name = case length name `divMod` 4 of + (n, 0) -> 4 * n + (n, _) -> 4 * (n + 1) + needExt name = length name > 16 || ' ' `elem` name + processEntry :: ArchiveEntry -> ArchiveEntry + processEntry archive@(ArchiveEntry name _ _ _ _ st_size _) + | needExt name = archive { filename = "#1/" <> show sz + , filedata = C.pack (padStr '\0' sz name) <> filedata archive + , filesize = st_size + sz } + | otherwise = archive + + where sz = nameSize name + + processEntries = map processEntry + +putGNUArch :: Archive -> PutM () +putGNUArch (Archive as) = do + putArchMagic + mapM_ putArchEntry (processEntries as) + + where + processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry) + processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _) + | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2 + , filedata = filedata extInfo <> C.pack name <> "/\n" } + , archive { filename = "/" <> show (filesize extInfo) } ) + | otherwise = ( extInfo, archive { filename = name <> "/" } ) + + processEntries :: [ArchiveEntry] -> [ArchiveEntry] + processEntries = + uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty) + +parseAr :: B.ByteString -> Archive +parseAr = runGet getArch . L.fromChunks . pure + +writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO () +writeBSDAr fp = L.writeFile fp . runPut . putBSDArch +writeGNUAr fp = L.writeFile fp . runPut . putGNUArch + +loadAr :: FilePath -> IO Archive +loadAr fp = parseAr <$> B.readFile fp + +loadObj :: FilePath -> IO ArchiveEntry +loadObj fp = do + payload <- B.readFile fp + (modt, own, grp, mode) <- fileInfo fp + return $ ArchiveEntry + (takeFileName fp) modt own grp mode + (B.length payload) payload + +-- | Take a filePath and return (mod time, own, grp, mode in decimal) +fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal) +#if defined(mingw32_HOST_OS) +-- on windows mod time, owner group and mode are zero. +fileInfo _ = pure (0,0,0,0) +#else +fileInfo fp = go <$> POSIX.getFileStatus fp + where go status = ( fromEnum $ POSIX.modificationTime status + , fromIntegral $ POSIX.fileOwner status + , fromIntegral $ POSIX.fileGroup status + , oct2dec . fromIntegral $ POSIX.fileMode status + ) + +oct2dec :: Int -> Int +oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8 + where dec _ 0 = [] + dec b i = let (rest, last) = i `quotRem` b + in last:dec b rest + +#endif diff --git a/GHC/SysTools/BaseDir.hs b/GHC/SysTools/BaseDir.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/BaseDir.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2001-2017 +-- +-- Finding the compiler's base directory. +-- +----------------------------------------------------------------------------- +-} + +module GHC.SysTools.BaseDir + ( expandTopDir, expandToolDir + , findTopDir, findToolDir + , tryFindTopDir + ) where + +import GHC.Prelude + +-- See Note [Base Dir] for why some of this logic is shared with ghc-pkg. +import GHC.BaseDir + +import GHC.Utils.Panic + +import System.Environment (lookupEnv) +import System.FilePath + +-- Windows +#if defined(mingw32_HOST_OS) +import System.Directory (doesDirectoryExist) +#endif + +{- +Note [topdir: How GHC finds its files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC needs various support files (library packages, RTS etc), plus +various auxiliary programs (cp, gcc, etc). It starts by finding topdir, +the root of GHC's support files + +On Unix: + - ghc always has a shell wrapper that passes a -B option + +On Windows: + - ghc never has a shell wrapper. + - we can find the location of the ghc binary, which is + $topdir//.exe + where may be "ghc", "ghc-stage2", or similar + - we strip off the "/.exe" to leave $topdir. + +from topdir we can find package.conf, ghc-asm, etc. + + +Note [tooldir: How GHC finds mingw on Windows] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has some custom logic on Windows for finding the mingw +toolchain. In general we will find the mingw toolchain +in $topdir/../../mingw/. + +This story is long and with lots of twist and turns.. But let's talk about how +the build system finds and wires through the toolchain information. + +1) It all starts in configure.ac which has two modes it operates on: + a) The default is where `EnableDistroToolchain` is false. This indicates + that we want to use the in-tree bundled toolchains. In this mode we will + download and unpack some custom toolchains into the `inplace/mingw` folder + and everything is pointed to that folder. + b) The second path is when `EnableDistroToolchain` is true. This makes the + toolchain behave a lot like Linux, in that the environment is queried for + information on the tools we require. + + From configure.ac we export the standard variables to set the paths to the + tools for the build system to use. + +2) After we have the path to the tools we have to generate the right paths to + store in the settings file for ghc to use. This is done in aclocal.m4. + Again we have two modes of operation: + a) If not `EnableDistroToolchain` the paths are rewritten to paths using a + variable `$tooldir` as we need an absolute path. $tooldir is filled in by + the `expandToolDir` function in this module at GHC startup. + b) When `EnableDistroToolchain` then instead of filling in a absolute path + we fill in just the program name. The assumption here is that at runtime + the environment GHC is operating on will be the same as the one configure + was run in. This means we expect `gcc, ld, as` etc to be on the PATH. + + From `aclocal.m4` we export a couple of variables starting with `Settings` + which will be used to generate the settings file. + +3) The next step is to generate the settings file: The file + `cfg/system.config.in` is preprocessed by configure and the output written to + `system.config`. This serves the same purpose as `config.mk` but it rewrites + the values that were exported. As an example `SettingsCCompilerCommand` is + rewritten to `settings-c-compiler-command`. + + Next up is `src/Oracles/Settings.hs` which makes from some Haskell ADT to + the settings `keys` in the `system.config`. As an example, + `settings-c-compiler-command` is mapped to + `SettingsFileSetting_CCompilerCommand`. + + The last part of this is the `generateSettings` in `src/Rules/Generate.hs` + which produces the desired settings file out of Hadrian. This is the + equivalent to `rts/include/ghc.mk`. + +-- + +So why do we have these? On Windows there's no such thing as a platform compiler +and as such we need to provide GCC and binutils. The easiest way is to bundle +these with the compiler and wire them up. This gives you a relocatable +binball. This works fine for most users. However mingw-w64 have a different +requirement. They require all packages in the repo to be compiled using the +same version of the compiler. So it means when they are rebuilding the world to +add support for GCC X, they expect all packages to have been compiled with GCC X +which is a problem since we ship an older GCC version. + +GHC is a package in mingw-w64 because there are Haskell packages in the +repository which of course requires a Haskell compiler. To help them we +provide the override which allows GHC to instead of using an inplace compiler to +play nice with the system compiler instead. +-} + +-- | Expand occurrences of the @$tooldir@ interpolation in a string +-- on Windows, leave the string untouched otherwise. +expandToolDir + :: Bool -- ^ whether we use the ambient mingw toolchain + -> Maybe FilePath -- ^ tooldir + -> String -> String +#if defined(mingw32_HOST_OS) +expandToolDir False (Just tool_dir) s = expandPathVar "tooldir" tool_dir s +expandToolDir False Nothing _ = panic "Could not determine $tooldir" +expandToolDir True _ s = s +#else +expandToolDir _ _ s = s +#endif + +-- | Returns a Unix-format path pointing to TopDir. +findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). + -> IO String -- TopDir (in Unix format '/' separated) +findTopDir m_minusb = do + maybe_exec_dir <- tryFindTopDir m_minusb + case maybe_exec_dir of + -- "Just" on Windows, "Nothing" on unix + Nothing -> throwGhcExceptionIO $ + InstallationError "missing -B option" + Just dir -> return dir + +tryFindTopDir + :: Maybe String -- ^ Maybe TopDir path (without the '-B' prefix). + -> IO (Maybe String) -- ^ TopDir (in Unix format '/' separated) +tryFindTopDir (Just minusb) = return $ Just $ normalise minusb +tryFindTopDir Nothing + = do -- The _GHC_TOP_DIR environment variable can be used to specify + -- the top dir when the -B argument is not specified. It is not + -- intended for use by users, it was added specifically for the + -- purpose of running GHC within GHCi. + maybe_env_top_dir <- lookupEnv "_GHC_TOP_DIR" + case maybe_env_top_dir of + Just env_top_dir -> return $ Just env_top_dir + -- Try directory of executable + Nothing -> getBaseDir + + +-- See Note [tooldir: How GHC finds mingw on Windows] +-- Returns @Nothing@ when not on Windows. +-- When called on Windows, it either throws an error when the +-- tooldir can't be located, or returns @Just tooldirpath@. +-- If the distro toolchain is being used we treat Windows the same as Linux +findToolDir + :: Bool -- ^ whether we use the ambient mingw toolchain + -> FilePath -- ^ topdir + -> IO (Maybe FilePath) +#if defined(mingw32_HOST_OS) +findToolDir False top_dir = go 0 (top_dir "..") [] + where maxDepth = 3 + go :: Int -> FilePath -> [FilePath] -> IO (Maybe FilePath) + go k path tried + | k == maxDepth = throwGhcExceptionIO $ + InstallationError $ "could not detect mingw toolchain in the following paths: " ++ show tried + | otherwise = do + let try = path "mingw" + let tried' = tried ++ [try] + oneLevel <- doesDirectoryExist try + if oneLevel + then return (Just path) + else go (k+1) (path "..") tried' +findToolDir True _ = return Nothing +#else +findToolDir _ _ = return Nothing +#endif diff --git a/GHC/SysTools/Cpp.hs b/GHC/SysTools/Cpp.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Cpp.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +#include + +module GHC.SysTools.Cpp + ( doCpp + , CppOpts(..) + , getGhcVersionPathName + , getGhcVersionIncludeFlags + , applyCDefs + , offsetIncludePaths + ) +where + +import GHC.Prelude +import GHC.Driver.Session +import GHC.Driver.Backend +import GHC.CmmToLlvm.Version +import GHC.Platform +import GHC.Platform.ArchOS + +import GHC.SysTools + +import GHC.Unit.Env as UnitEnv +import GHC.Unit.Info +import GHC.Unit.State +import GHC.Unit.Types + +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Utils.Panic + +import Data.Version +import Data.Maybe + +import Control.Monad + +import System.Directory +import System.FilePath + +data CppOpts = CppOpts + { sourceCodePreprocessor :: !SourceCodePreprocessor + , cppLinePragmas :: !Bool + -- ^ Enable generation of LINE pragmas + } + +{- +Note [Preprocessing invocations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must consider four distinct preprocessors when preprocessing Haskell. +These are: + +(1) The Haskell C preprocessor (HsCpp), which preprocesses Haskell files that make use + of the CPP language extension + +(2) The C preprocessor (Cpp), which is used to preprocess C files + +(3) The JavaScript preprocessor (JsCpp), which preprocesses JavaScript files + +(4) The C-- preprocessor (CmmCpp), which preprocesses C-- files + +These preprocessors are indeed different. Despite often sharing the same +underlying program (the C compiler), the set of flags passed determines the +behaviour of the preprocessor, and Cpp and HsCpp behave differently. +Specifically, we rely on "traditional" (pre-standard) preprocessing semantics +(which most compilers expose via the `-traditional` flag) when preprocessing +Haskell source. This avoids the following situations: + + * Removal of C-style comments, which are not comments in Haskell but valid + operators; + + * Errors due to an ANSI C preprocessor lexing the source and failing on + names with single quotes (TH quotes, ticked promoted constructors, + names with primes in them). + + Both of those cases may be subtle: gcc and clang permit C++-style // + comments in C code, and Data.Array and Data.Vector both export a // + operator whose type is such that a removed "comment" may leave code that + typechecks but does the wrong thing. Another example is that, since ANSI + C permits long character constants, an expression involving multiple + functions with primes in their names may not expand macros properly when + they occur between the primed functions. + +Third special type of preprocessor for JavaScript was added laterly due to +needing to keep JSDoc comments and multiline comments. Various third party +minifying software (for example, Google Closure Compiler) uses JSDoc +information to apply more strict rules to code reduction which results in +better but more dangerous minification. JSDoc comments are usually used to +instruct minifiers where dangerous optimizations could be applied. + +The fourth, the C-- preprocessor, is needed as modern compilers emit defines +for debug info generation when preprocessing. The C-- preprocessor avoids this +by suppressing debug info generation. The C-- preprocessor also inherits flags +passed to the C compiler. This is done for compatibility. Following those, +the C-- compiler receives -g0, if it was detected as supported, and flags +passed via -optCmmP specifically for the C-- preprocessor. The combined +command line looks like: + + $pgmCmmP $optCs_without_g3s $g0_if_supported $optCmmP + +-} + +-- | Run either the Haskell preprocessor, JavaScript preprocessor +-- or the C preprocessor, as per the 'CppOpts' passed. +-- See Note [Preprocessing invocations]. +-- +-- UnitEnv is needed to compute MIN_VERSION macros +-- +-- If you change the macros defined by this function make sure to update the +-- user guide. +doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> CppOpts -> FilePath -> FilePath -> IO () +doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do + let hscpp_opts = picPOpts dflags + let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags) + let unit_state = ue_homeUnitState 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 = map ("-I" ++) + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs + ++ concatMap includePathsGlobal dep_pkg_extra_inputs) + let include_paths_quote = map ("-iquote" ++) + (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 = runSourceCodePreprocessor logger tmpfs dflags (sourceCodePreprocessor opts) 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__SSE3__" | isSse3Enabled dflags ] ++ + [ "-D__SSSE3__" | isSsse3Enabled dflags ] ++ + [ "-D__SSE4_1__" | isSse4_1Enabled dflags ] ++ + [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] + + let fma_def = + [ "-D__FMA__" | isFmaEnabled dflags ] + + let avx_defs = + [ "-D__AVX__" | isAvxEnabled dflags ] ++ + [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ + [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ + [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ + [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ + [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] + + backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags + + let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] + + let asserts_def = [ "-D__GLASGOW_HASKELL_ASSERTS_IGNORED__" | gopt Opt_IgnoreAsserts dflags] + + -- Default CPP defines in Haskell source + ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env + + -- MIN_VERSION macros + let uids = explicitUnits unit_state + pkgs = mapMaybe (lookupUnit unit_state . fst) uids + mb_macro_include <- + if not (null pkgs) && gopt Opt_VersionMacros dflags + then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h" + writeFile macro_stub (generatePackageVersionMacros pkgs) + -- Include version macros for every *exposed* package. + -- Without -hide-all-packages and with a package database + -- size of 1000 packages, it takes cpp an estimated 2 + -- milliseconds to process this file. See #10970 + -- comment 8. + return [GHC.SysTools.FileOption "-include" macro_stub] + else return [] + + let line_pragmas + | cppLinePragmas opts = [] -- on by default + | otherwise = [GHC.SysTools.Option "-P"] -- disable LINE markers + + cpp_prog ( map GHC.SysTools.Option verbFlags + ++ map GHC.SysTools.Option include_paths + ++ map GHC.SysTools.Option ghcVersionH + ++ map GHC.SysTools.Option target_defs + ++ map GHC.SysTools.Option backend_defs + ++ map GHC.SysTools.Option th_defs + ++ map GHC.SysTools.Option asserts_def + ++ map GHC.SysTools.Option hscpp_opts + ++ map GHC.SysTools.Option sse_defs + ++ map GHC.SysTools.Option fma_def + ++ map GHC.SysTools.Option avx_defs + ++ map GHC.SysTools.Option io_manager_defs + ++ mb_macro_include + ++ line_pragmas + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. + ++ [ GHC.SysTools.Option "-x" + , GHC.SysTools.Option "assembler-with-cpp" + , GHC.SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ]) + +-- --------------------------------------------------------------------------- +-- Macros (cribbed from Cabal) + +generatePackageVersionMacros :: [UnitInfo] -> String +generatePackageVersionMacros pkgs = concat + -- Do not add any C-style comments. See #3389. + [ generateMacros "" pkgname version + | pkg <- pkgs + , let version = unitPackageVersion pkg + pkgname = map fixchar (unitPackageNameString pkg) + ] + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c + +generateMacros :: String -> String -> Version -> String +generateMacros prefix name version = + concat + ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" + ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + take3 = \case + (a:b:c:_) -> (a,b,c) + _ -> error "take3" + (major1,major2,minor) = take3 $ map show (versionBranch version) ++ repeat "0" + +getGhcVersionIncludeFlags :: DynFlags -> UnitEnv -> IO [String] +getGhcVersionIncludeFlags dflags unit_env = + getGhcVersionPathName dflags unit_env >>= \case + Nothing -> pure [] + Just path -> pure [ "-include", path ] + +-- | Find out path to @ghcversion.h@ file +getGhcVersionPathName :: DynFlags -> UnitEnv -> IO (Maybe FilePath) +getGhcVersionPathName dflags unit_env = case ghcVersionFile dflags of + -- the user has provided an explicit `ghcversion.h` file to use. + Just path -> doesFileExist path >>= \case + True -> return (Just path) + False -> throwGhcExceptionIO (InstallationError ("ghcversion.h not found in: " ++ path)) + -- otherwise, try to find it in the rts' include-dirs. + -- Note: only in the RTS include-dirs! not all preload units less we may + -- use a wrong file. See #25106 where a globally installed + -- /usr/include/ghcversion.h file was used instead of the one provided + -- by the rts. + Nothing -> case lookupUnitId (ue_homeUnitState unit_env) rtsUnitId of + Nothing -> pure Nothing + Just info -> do + let candidates = ( "ghcversion.h") <$> collectIncludeDirs [info] + found <- filterM doesFileExist candidates + case found of + [] -> pure Nothing + (x:_) -> pure (Just x) + +applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] +applyCDefs NoCDefs _ _ = return [] +applyCDefs LlvmCDefs logger dflags = do + llvmVer <- figureLlvmVersion logger dflags + return $ case fmap llvmVersionList llvmVer of + Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] + Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] + _ -> [] + where + format (major, minor) + | minor >= 100 = error "backendCDefs: Unsupported minor version" + | otherwise = show (100 * major + minor :: Int) -- Contract is Int + + +-- Note [Filepaths and Multiple Home Units] +offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs +offsetIncludePaths dflags (IncludeSpecs incs quotes impl) = + let go = map (augmentByWorkingDirectory dflags) + in IncludeSpecs (go incs) (go quotes) (go impl) diff --git a/GHC/SysTools/Elf.hs b/GHC/SysTools/Elf.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Elf.hs @@ -0,0 +1,460 @@ +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2015 +-- +-- ELF format tools +-- +----------------------------------------------------------------------------- +-} + +module GHC.SysTools.Elf ( + readElfSectionByName, + readElfNoteAsString, + makeElfNote + ) where + +import GHC.Prelude + +import GHC.Utils.Asm +import GHC.Utils.Exception +import GHC.Platform +import GHC.Utils.Error +import GHC.Data.Maybe (MaybeT(..),runMaybeT) +import GHC.Utils.Misc (charToC) +import GHC.Utils.Outputable (text,hcat) +import GHC.Utils.Logger + +import Control.Monad (when) +import Data.Binary.Get +import Data.Word +import Data.Char (ord) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as B8 + +{- Note [ELF specification] + ~~~~~~~~~~~~~~~~~~~~~~~~ + + ELF (Executable and Linking Format) is described in the System V Application + Binary Interface (or ABI). The latter is composed of two parts: a generic + part and a processor specific part. The generic ABI describes the parts of + the interface that remain constant across all hardware implementations of + System V. + + The latest release of the specification of the generic ABI is the version + 4.1 from March 18, 1997: + + - http://www.sco.com/developers/devspecs/gabi41.pdf + + Since 1997, snapshots of the draft for the "next" version are published: + + - http://www.sco.com/developers/gabi/ + + Quoting the notice on the website: "There is more than one instance of these + chapters to permit references to older instances to remain valid. All + modifications to these chapters are forward-compatible, so that correct use + of an older specification will not be invalidated by a newer instance. + Approximately on a yearly basis, a new instance will be saved, as it reaches + what appears to be a stable state." + + Nevertheless we will see that since 1998 it is not true for Note sections. + + Many ELF sections + ----------------- + + ELF-4.1: the normal section number fields in ELF are limited to 16 bits, + which runs out of bits when you try to cram in more sections than that. Two + fields are concerned: the one containing the number of the sections and the + one containing the index of the section that contains section's names. (The + same thing applies to the field containing the number of segments, but we + don't care about it here). + + ELF-next: to solve this, these fields in the ELF header have an escape + value (different for each case), and the actual section number is stashed + into unused fields in the first section header. + + We support this extension as it is forward-compatible with ELF-4.1. + Moreover, GHC may generate objects with a lot of sections with the + "function-sections" feature (one section per function). + + Note sections + ------------- + + Sections with type "note" (SHT_NOTE in the specification) are used to add + arbitrary data into an ELF file. An entry in a note section is composed of a + name, a type and a value. + + ELF-4.1: "The note information in sections and program header elements holds + any number of entries, each of which is an array of 4-byte words in the + format of the target processor." Each entry has the following format: + | namesz | Word32: size of the name string (including the ending \0) + | descsz | Word32: size of the value + | type | Word32: type of the note + | name | Name string (with \0 padding to ensure 4-byte alignment) + | ... | + | desc | Value (with \0 padding to ensure 4-byte alignment) + | ... | + + ELF-next: "The note information in sections and program header elements + holds a variable amount of entries. In 64-bit objects (files with + e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte + words in the format of the target processor. In 32-bit objects (files with + e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte + words in the format of the target processor." (from 1998-2015 snapshots) + + This is not forward-compatible with ELF-4.1. In practice, for almost all + platforms namesz, descz and type fields are 4-byte words for both 32-bit and + 64-bit objects (see elf.h and readelf source code). + + The only exception in readelf source code is for IA_64 machines with OpenVMS + OS: "This OS has so many departures from the ELF standard that we test it at + many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz, + descsz and type fields are 8-byte words and name and value fields are padded + to ensure 8-byte alignment. + + We don't support this platform in the following code. Reading a note section + could be done easily (by testing Machine and OS fields in the ELF header). + Writing a note section, however, requires that we generate a different + assembly code for GAS depending on the target platform and this is a little + bit more involved. + +-} + + +-- | ELF header +-- +-- The ELF header indicates the native word size (32-bit or 64-bit) and the +-- endianness of the target machine. We directly store getters for words of +-- different sizes as it is more convenient to use. We also store the word size +-- as it is useful to skip some uninteresting fields. +-- +-- Other information such as the target machine and OS are left out as we don't +-- use them yet. We could add them in the future if we ever need them. +data ElfHeader = ElfHeader + { gw16 :: Get Word16 -- ^ Get a Word16 with the correct endianness + , gw32 :: Get Word32 -- ^ Get a Word32 with the correct endianness + , gwN :: Get Word64 -- ^ Get a Word with the correct word size + -- and endianness + , wordSize :: Int -- ^ Word size in bytes + } + + +-- | Read the ELF header +readElfHeader :: Logger -> ByteString -> IO (Maybe ElfHeader) +readElfHeader logger bs = runGetOrThrow getHeader bs `catchIO` \_ -> do + debugTraceMsg logger 3 $ + text ("Unable to read ELF header") + return Nothing + where + getHeader = do + magic <- getWord32be + ws <- getWord8 + endian <- getWord8 + version <- getWord8 + skip 9 -- skip OSABI, ABI version and padding + when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header" + + case (ws, endian) of + -- ELF 32, little endian + (1,1) -> return . Just $ ElfHeader + getWord16le + getWord32le + (fmap fromIntegral getWord32le) 4 + -- ELF 32, big endian + (1,2) -> return . Just $ ElfHeader + getWord16be + getWord32be + (fmap fromIntegral getWord32be) 4 + -- ELF 64, little endian + (2,1) -> return . Just $ ElfHeader + getWord16le + getWord32le + (fmap fromIntegral getWord64le) 8 + -- ELF 64, big endian + (2,2) -> return . Just $ ElfHeader + getWord16be + getWord32be + (fmap fromIntegral getWord64be) 8 + _ -> fail "Invalid ELF header" + + +------------------ +-- SECTIONS +------------------ + + +-- | Description of the section table +data SectionTable = SectionTable + { sectionTableOffset :: Word64 -- ^ offset of the table describing sections + , sectionEntrySize :: Word16 -- ^ size of an entry in the section table + , sectionEntryCount :: Word64 -- ^ number of sections + , sectionNameIndex :: Word32 -- ^ index of a special section which + -- contains section's names + } + +-- | Read the ELF section table +readElfSectionTable :: Logger + -> ElfHeader + -> ByteString + -> IO (Maybe SectionTable) + +readElfSectionTable logger hdr bs = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ + text ("Unable to read ELF section table") + return Nothing + where + getSectionTable :: Get SectionTable + getSectionTable = do + skip (24 + 2*wordSize hdr) -- skip header and some other fields + secTableOffset <- gwN hdr + skip 10 + entrySize <- gw16 hdr + entryCount <- gw16 hdr + secNameIndex <- gw16 hdr + return (SectionTable secTableOffset entrySize + (fromIntegral entryCount) + (fromIntegral secNameIndex)) + + action = do + secTable <- runGetOrThrow getSectionTable bs + -- In some cases, the number of entries and the index of the section + -- containing section's names must be found in unused fields of the first + -- section entry (see Note [ELF specification]) + let + offSize0 = fromIntegral $ sectionTableOffset secTable + 8 + + 3 * fromIntegral (wordSize hdr) + offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr) + + entryCount' <- if sectionEntryCount secTable /= 0 + then return (sectionEntryCount secTable) + else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs) + entryNameIndex' <- if sectionNameIndex secTable /= 0xffff + then return (sectionNameIndex secTable) + else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs) + return (Just $ secTable + { sectionEntryCount = entryCount' + , sectionNameIndex = entryNameIndex' + }) + + +-- | A section +data Section = Section + { entryName :: ByteString -- ^ Name of the section + , entryBS :: ByteString -- ^ Content of the section + } + +-- | Read a ELF section +readElfSectionByIndex :: Logger + -> ElfHeader + -> SectionTable + -> Word64 + -> ByteString + -> IO (Maybe Section) + +readElfSectionByIndex logger hdr secTable i bs = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ + text ("Unable to read ELF section") + return Nothing + where + -- read an entry from the section table + getEntry = do + nameIndex <- gw32 hdr + skip (4+2*wordSize hdr) + offset <- fmap fromIntegral $ gwN hdr + size <- fmap fromIntegral $ gwN hdr + let bs' = LBS.take size (LBS.drop offset bs) + return (nameIndex,bs') + + -- read the entry with the given index in the section table + getEntryByIndex x = runGetOrThrow getEntry bs' + where + bs' = LBS.drop off bs + off = fromIntegral $ sectionTableOffset secTable + + x * fromIntegral (sectionEntrySize secTable) + + -- Get the name of a section + getEntryName nameIndex = do + let idx = fromIntegral (sectionNameIndex secTable) + (_,nameTable) <- getEntryByIndex idx + let bs' = LBS.drop nameIndex nameTable + runGetOrThrow getLazyByteStringNul bs' + + action = do + (nameIndex,bs') <- getEntryByIndex (fromIntegral i) + name <- getEntryName (fromIntegral nameIndex) + return (Just $ Section name bs') + + +-- | Find a section from its name. Return the section contents. +-- +-- We do not perform any check on the section type. +findSectionFromName :: Logger + -> ElfHeader + -> SectionTable + -> String + -> ByteString + -> IO (Maybe ByteString) +findSectionFromName logger hdr secTable name bs = + rec [0..sectionEntryCount secTable - 1] + where + -- convert the required section name into a ByteString to perform + -- ByteString comparison instead of String comparison + name' = B8.pack name + + -- compare recursively each section name and return the contents of + -- the matching one, if any + rec [] = return Nothing + rec (x:xs) = do + me <- readElfSectionByIndex logger hdr secTable x bs + case me of + Just e | entryName e == name' -> return (Just (entryBS e)) + _ -> rec xs + + +-- | Given a section name, read its contents as a ByteString. +-- +-- If the section isn't found or if there is any parsing error, we return +-- Nothing +readElfSectionByName :: Logger + -> ByteString + -> String + -> IO (Maybe LBS.ByteString) + +readElfSectionByName logger bs name = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ + text ("Unable to read ELF section \"" ++ name ++ "\"") + return Nothing + where + action = runMaybeT $ do + hdr <- MaybeT $ readElfHeader logger bs + secTable <- MaybeT $ readElfSectionTable logger hdr bs + MaybeT $ findSectionFromName logger hdr secTable name bs + +------------------ +-- NOTE SECTIONS +------------------ + +-- | read a Note as a ByteString +-- +-- If you try to read a note from a section which does not support the Note +-- format, the parsing is likely to fail and Nothing will be returned +readElfNoteBS :: Logger + -> ByteString + -> String + -> String + -> IO (Maybe LBS.ByteString) + +readElfNoteBS logger bs sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ + text ("Unable to read ELF note \"" ++ noteId ++ + "\" in section \"" ++ sectionName ++ "\"") + return Nothing + where + -- align the getter on n bytes + align n = do + m <- bytesRead + if m `mod` n == 0 + then return () + else skip 1 >> align n + + -- noteId as a bytestring + noteId' = B8.pack noteId + + -- read notes recursively until the one with a valid identifier is found + findNote hdr = do + align 4 + namesz <- gw32 hdr + descsz <- gw32 hdr + _ <- gw32 hdr -- we don't use the note type + name <- if namesz == 0 + then return LBS.empty + else getLazyByteStringNul + align 4 + desc <- if descsz == 0 + then return LBS.empty + else getLazyByteString (fromIntegral descsz) + if name == noteId' + then return $ Just desc + else findNote hdr + + + action = runMaybeT $ do + hdr <- MaybeT $ readElfHeader logger bs + sec <- MaybeT $ readElfSectionByName logger bs sectionName + MaybeT $ runGetOrThrow (findNote hdr) sec + +-- | read a Note as a String +-- +-- If you try to read a note from a section which does not support the Note +-- format, the parsing is likely to fail and Nothing will be returned +readElfNoteAsString :: Logger + -> FilePath + -> String + -> String + -> IO (Maybe String) + +readElfNoteAsString logger path sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ + text ("Unable to read ELF note \"" ++ noteId ++ + "\" in section \"" ++ sectionName ++ "\"") + return Nothing + where + action = do + bs <- LBS.readFile path + note <- readElfNoteBS logger bs sectionName noteId + return (fmap B8.unpack note) + + +-- | Generate the GAS code to create a Note section +-- +-- Header fields for notes are 32-bit long (see Note [ELF specification]). +makeElfNote :: Platform -> String -> String -> Word32 -> String -> SDoc +makeElfNote platform sectionName noteName typ contents = hcat [ + text "\t.section ", + text sectionName, + text ",\"\",", + sectionType platform "note", + text "\n", + text "\t.balign 4\n", + + -- note name length (+ 1 for ending \0) + asWord32 (length noteName + 1), + + -- note contents size + asWord32 (length contents), + + -- note type + asWord32 typ, + + -- note name (.asciz for \0 ending string) + padding + text "\t.asciz \"", + text noteName, + text "\"\n", + text "\t.balign 4\n", + + -- note contents (.ascii to avoid ending \0) + padding + text "\t.ascii \"", + text (escape contents), + text "\"\n", + text "\t.balign 4\n"] + where + escape :: String -> String + escape = concatMap (charToC.fromIntegral.ord) + + asWord32 :: Show a => a -> SDoc + asWord32 x = hcat [ + text "\t.4byte ", + text (show x), + text "\n"] + + +------------------ +-- Helpers +------------------ + +-- | runGet in IO monad that throws an IOException on failure +runGetOrThrow :: Get a -> LBS.ByteString -> IO a +runGetOrThrow g bs = case runGetOrFail g bs of + Left _ -> fail "Error while reading file" + Right (_,_,a) -> return a diff --git a/GHC/SysTools/Process.hs b/GHC/SysTools/Process.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Process.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- +-- Misc process handling code for SysTools +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- +module GHC.SysTools.Process + ( readCreateProcessWithExitCode' + , getGccEnv + , runSomething + , runSomethingResponseFile + , runSomethingFiltered + , runSomethingWith + ) where + +import GHC.Prelude + +import GHC.Utils.Exception +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Utils.CliOption + +import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan ) +import GHC.Data.FastString + +import GHC.IO.Encoding + +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem (()) +import GHC.IO.Handle.Windows (handleToHANDLE) +import GHC.Event.Windows (associateHandle') +#endif + +import Control.Concurrent +import Data.Char + +import System.Exit +import System.Environment +import System.FilePath +import System.IO +import System.IO.Error as IO +import System.Process + + +-- | Enable process jobs support on Windows if it can be expected to work (e.g. +-- @process >= 1.6.9.0@). +enableProcessJobs :: CreateProcess -> CreateProcess +enableProcessJobs opts = opts { use_process_jobs = True } + + +-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is +-- inherited from the parent process, and output to stderr is not captured. +readCreateProcessWithExitCode' + :: CreateProcess + -> IO (ExitCode, String) -- ^ stdout +readCreateProcessWithExitCode' proc = do + (_, Just outh, _, pid) <- + createProcess $ enableProcessJobs $ proc{ std_out = CreatePipe } + + -- fork off a thread to start consuming the output + outMVar <- newEmptyMVar + let onError :: SomeException -> IO () + onError exc = putMVar outMVar (Left exc) + _ <- forkIO $ handle onError $ do + output <- hGetContents' outh + putMVar outMVar $ Right output + + -- wait on the output + result <- takeMVar outMVar + hClose outh + output <- case result of + Left exc -> throwIO exc + Right output -> return output + + -- wait on the process + ex <- waitForProcess pid + + return (ex, output) + +-- If the -B option is set, add to PATH. This works around +-- a bug in gcc on Windows Vista where it can't find its auxiliary +-- binaries (see bug #1110). +getGccEnv :: [Option] -> IO (Maybe [(String,String)]) +getGccEnv opts = + if null b_dirs + then return Nothing + else do env <- getEnvironment + return (Just (mangle_paths env)) + where + (b_dirs, _) = partitionWith get_b_opt opts + + get_b_opt (Option ('-':'B':dir)) = Left dir + get_b_opt other = Right other + + -- Work around #1110 on Windows only (lest we stumble into #17266). +#if defined(mingw32_HOST_OS) + mangle_paths = map mangle_path + mangle_path (path,paths) | map toUpper path == "PATH" + = (path, '\"' : head b_dirs ++ "\";" ++ paths) + mangle_path other = other +#else + mangle_paths = id +#endif + + +----------------------------------------------------------------------------- +-- Running an external program + +runSomething :: Logger + -> String -- For -v message + -> String -- Command name (possibly a full path) + -- assumed already dos-ified + -> [Option] -- Arguments + -- runSomething will dos-ify them + -> IO () + +runSomething logger phase_name pgm args = + runSomethingFiltered logger id phase_name pgm args Nothing Nothing + +-- | Run a command, placing the arguments in an external response file. +-- +-- This command is used in order to avoid overlong command line arguments on +-- Windows. The command line arguments are first written to an external, +-- temporary response file, and then passed to the linker via @filepath. +-- response files for passing them in. See: +-- +-- https://gcc.gnu.org/wiki/Response_Files +-- https://gitlab.haskell.org/ghc/ghc/issues/10777 +runSomethingResponseFile + :: Logger + -> TmpFs + -> TempDir + -> ([String] -> [String]) + -> String + -> String + -> [Option] + -> Maybe [(String,String)] + -> IO () +runSomethingResponseFile logger tmpfs tmp_dir filter_fn phase_name pgm args mb_env = + runSomethingWith logger phase_name pgm args $ \real_args -> do + fp <- getResponseFile real_args + let args = ['@':fp] + r <- builderMainLoop logger filter_fn pgm args Nothing mb_env + return (r,()) + where + getResponseFile args = do + fp <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "rsp" + withFile fp WriteMode $ \h -> do + hSetEncoding h utf8 + hPutStr h $ unlines $ map escape args + return fp + + -- Note: Response files have backslash-escaping, double quoting, and are + -- whitespace separated (some implementations use newline, others any + -- whitespace character). Therefore, escape any backslashes, newlines, and + -- double quotes in the argument, and surround the content with double + -- quotes. + -- + -- Another possibility that could be considered would be to convert + -- backslashes in the argument to forward slashes. This would generally do + -- the right thing, since backslashes in general only appear in arguments + -- as part of file paths on Windows, and the forward slash is accepted for + -- those. However, escaping is more reliable, in case somehow a backslash + -- appears in a non-file. + escape x = concat + [ "\"" + , concatMap + (\c -> + case c of + '\\' -> "\\\\" + '\n' -> "\\n" + '\"' -> "\\\"" + _ -> [c]) + x + , "\"" + ] + +runSomethingFiltered + :: Logger -> ([String] -> [String]) -> String -> String -> [Option] + -> Maybe FilePath -> Maybe [(String,String)] -> IO () + +runSomethingFiltered logger filter_fn phase_name pgm args mb_cwd mb_env = + runSomethingWith logger phase_name pgm args $ \real_args -> do + r <- builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env + return (r,()) + +runSomethingWith + :: Logger -> String -> String -> [Option] + -> ([String] -> IO (ExitCode, a)) + -> IO a + +runSomethingWith logger phase_name pgm args io = do + let real_args = filter notNull (map showOpt args) + cmdLine = showCommandForUser pgm real_args + traceCmd logger phase_name cmdLine $ handleProc pgm phase_name $ io real_args + +handleProc :: String -> String -> IO (ExitCode, r) -> IO r +handleProc pgm phase_name proc = do + (rc, r) <- proc `catchIO` handler + case rc of + ExitSuccess{} -> return r + ExitFailure n -> throwGhcExceptionIO ( + ProgramError ("`" ++ takeFileName pgm ++ "'" ++ + " failed in phase `" ++ phase_name ++ "'." ++ + " (Exit code: " ++ show n ++ ")")) + where + handler err = + if IO.isDoesNotExistError err + then does_not_exist + else throwGhcExceptionIO (ProgramError $ show err) + + does_not_exist = + throwGhcExceptionIO $ + InstallationError (phase_name ++ ": could not execute: " ++ pgm) + +withPipe :: ((Handle, Handle) -> IO a) -> IO a +withPipe = bracket createPipe $ \ (readEnd, writeEnd) -> do + hClose readEnd + hClose writeEnd + +builderMainLoop :: Logger -> ([String] -> [String]) -> FilePath + -> [String] -> Maybe FilePath -> Maybe [(String, String)] + -> IO ExitCode +builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (readEnd, writeEnd) -> do + +#if defined(__IO_MANAGER_WINIO__) + return () do + associateHandle' =<< handleToHANDLE readEnd +#endif + + -- We use a mask here rather than a bracket because we want + -- to distinguish between cleaning up with and without an + -- exception. This is to avoid calling terminateProcess + -- unless an exception was raised. + mask $ \restore -> do + -- acquire + -- On Windows due to how exec is emulated the old process will exit and + -- a new process will be created. This means waiting for termination of + -- the parent process will get you in a race condition as the child may + -- not have finished yet. This caused #16450. To fix this use a + -- process job to track all child processes and wait for each one to + -- finish. + let procdata = + enableProcessJobs + $ (proc pgm real_args) { + cwd = mb_cwd + , env = mb_env + , std_in = CreatePipe + + -- We used to treat stdout/stderr as separate streams, but this + -- was racy (see #25517). We now treat them as one stream and + -- that is fine for our use-case. We rely on upstream programs + -- to serialize writes to the two streams appropriately (note + -- that they already need to do that to produce deterministic + -- output when used interactively / on the command-line). + , std_out = UseHandle writeEnd + , std_err = UseHandle writeEnd + } + (Just hStdIn, Nothing, Nothing, hProcess) <- restore $ + createProcess_ "builderMainLoop" procdata + hClose writeEnd + r <- try $ restore $ do + getLocaleEncoding >>= hSetEncoding readEnd + hSetNewlineMode readEnd nativeNewlineMode + hSetBuffering readEnd LineBuffering + messages <- parseBuildMessages . filter_fn . lines <$> hGetContents readEnd + mapM_ processBuildMessage messages + waitForProcess hProcess + hClose hStdIn + case r of + Left (SomeException e) -> do + terminateProcess hProcess + throw e + Right s -> do + return s + where + processBuildMessage :: BuildMessage -> IO () + processBuildMessage msg = do + case msg of + BuildMsg msg -> do + logInfo logger $ withPprStyle defaultUserStyle msg + BuildError loc msg -> do + logMsg logger errorDiagnostic (mkSrcSpan loc loc) + $ withPprStyle defaultUserStyle msg + +parseBuildMessages :: [String] -> [BuildMessage] +parseBuildMessages str = loop str Nothing + where + loop :: [String] -> Maybe BuildMessage -> [BuildMessage] + loop [] Nothing = [] + loop [] (Just err) = [err] + loop (l:ls) in_err = + case in_err of + Just err@(BuildError srcLoc msg) + | leading_whitespace l -> + loop ls (Just (BuildError srcLoc (msg $$ text l))) + | otherwise -> + err : checkError l ls + Nothing -> + checkError l ls + _ -> panic "parseBuildMessages/loop" + + checkError :: String -> [String] -> [BuildMessage] + checkError l ls + = case parseError l of + Nothing -> + BuildMsg (text l) : loop ls Nothing + Just (srcLoc, msg) -> do + loop ls (Just (BuildError srcLoc (text msg))) + + leading_whitespace :: String -> Bool + leading_whitespace [] = False + leading_whitespace (x:_) = isSpace x + +parseError :: String -> Maybe (SrcLoc, String) +parseError s0 = case breakColon s0 of + Just (filename, s1) -> + case breakIntColon s1 of + Just (lineNum, s2) -> + case breakIntColon s2 of + Just (columnNum, s3) -> + Just (mkSrcLoc (mkFastString filename) lineNum columnNum, s3) + Nothing -> + Just (mkSrcLoc (mkFastString filename) lineNum 0, s2) + Nothing -> Nothing + Nothing -> Nothing + +-- | Break a line of an error message into a filename and the rest of the line, +-- taking care to ignore colons in Windows drive letters (as noted in #17786). +-- For instance, +-- +-- * @"hi.c: ABCD"@ is mapped to @Just ("hi.c", \"ABCD\")@ +-- * @"C:\\hi.c: ABCD"@ is mapped to @Just ("C:\\hi.c", \"ABCD\")@ +breakColon :: String -> Maybe (String, String) +breakColon = go [] + where + -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@) + go accum (':':'\\':rest) = go ('\\':':':accum) rest + go accum (':':'/':rest) = go ('/':':':accum) rest + go accum (':':rest) = Just (reverse accum, rest) + go accum (c:rest) = go (c:accum) rest + go _accum [] = Nothing + +breakIntColon :: String -> Maybe (Int, String) +breakIntColon xs = case break (':' ==) xs of + (ys, _:zs) + | not (null ys) && all isAscii ys && all isDigit ys -> + Just (read ys, zs) + _ -> Nothing + +data BuildMessage + = BuildMsg !SDoc + | BuildError !SrcLoc !SDoc diff --git a/GHC/SysTools/Tasks.hs b/GHC/SysTools/Tasks.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Tasks.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- +-- Tasks running external programs for SysTools +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- +module GHC.SysTools.Tasks + ( runUnlit + , SourceCodePreprocessor(..) + , runSourceCodePreprocessor + , runPp + , runCc + , askLd + , runAs + , runLlvmOpt + , runLlvmLlc + , runLlvmAs + , runEmscripten + , figureLlvmVersion + , runMergeObjects + , runAr + , askOtool + , runInstallNameTool + , runRanlib + , runWindres + ) where + +import GHC.Prelude +import GHC.ForeignSrcLang + +import GHC.CmmToLlvm.Version (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound) + +import GHC.Settings + +import GHC.SysTools.Process + +import GHC.Driver.Session +import GHC.Utils.Exception as Exception +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Utils.Panic + +import Control.Monad +import Data.List (tails, isPrefixOf) +import Data.Maybe (fromMaybe) +import System.IO +import System.Process +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Errors +import GHC.Driver.Errors.Types (GhcMessage(..), DriverMessage (DriverNoConfiguredLLVMToolchain)) +import GHC.Driver.CmdLine (warnsToMessages) +import GHC.Types.SrcLoc (noLoc) + +{- +************************************************************************ +* * +\subsection{Running an external program} +* * +************************************************************************ +-} + +runUnlit :: Logger -> DynFlags -> [Option] -> IO () +runUnlit logger dflags args = traceSystoolCommand logger "unlit" $ do + let prog = pgm_L dflags + opts = getOpts dflags opt_L + runSomething logger "Literate pre-processor" prog + (map Option opts ++ args) + +-- | Prepend the working directory to the search path. +-- Note [Filepaths and Multiple Home Units] +augmentImports :: DynFlags -> [FilePath] -> [FilePath] +augmentImports dflags fps | Nothing <- workingDirectory dflags = fps +augmentImports _ [] = [] +augmentImports _ [x] = [x] +augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirectory dflags fp : augmentImports dflags fps +augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps) + +-- | Discard some harmless warnings from gcc that we can't turn off +cc_filter :: [String] -> [String] +cc_filter = doFilter where + {- + gcc gives warnings in chunks like so: + In file included from /foo/bar/baz.h:11, + from /foo/bar/baz2.h:22, + from wibble.c:33: + /foo/flibble:14: global register variable ... + /foo/flibble:15: warning: call-clobbered r... + We break it up into its chunks, remove any call-clobbered register + warnings from each chunk, and then delete any chunks that we have + emptied of warnings. + -} + doFilter = unChunkWarnings . filterWarnings . chunkWarnings [] + -- We can't assume that the output will start with an "In file inc..." + -- line, so we start off expecting a list of warnings rather than a + -- location stack. + chunkWarnings :: [String] -- The location stack to use for the next + -- list of warnings + -> [String] -- The remaining lines to look at + -> [([String], [String])] + chunkWarnings loc_stack [] = [(loc_stack, [])] + chunkWarnings loc_stack xs + = case break loc_stack_start xs of + (warnings, lss:xs') -> + case span loc_start_continuation xs' of + (lsc, xs'') -> + (loc_stack, warnings) : chunkWarnings (lss : lsc) xs'' + _ -> [(loc_stack, xs)] + + filterWarnings :: [([String], [String])] -> [([String], [String])] + filterWarnings [] = [] + -- If the warnings are already empty then we are probably doing + -- something wrong, so don't delete anything + filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs + filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of + [] -> filterWarnings zs + ys' -> (xs, ys') : filterWarnings zs + + unChunkWarnings :: [([String], [String])] -> [String] + unChunkWarnings [] = [] + unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs + + loc_stack_start s = "In file included from " `isPrefixOf` s + loc_start_continuation s = " from " `isPrefixOf` s + wantedWarning w + | "warning: call-clobbered register used" `isContainedIn` w = False + | otherwise = True + +-- | See the Note [Preprocessing invocations] +data SourceCodePreprocessor + = SCPCpp + -- ^ Use the ordinary C preprocessor + | SCPHsCpp + -- ^ Use the Haskell C preprocessor (don't remove C comments, don't break on names including single quotes) + | SCPJsCpp + -- ^ Use the JavaScript preprocessor (don't remove jsdoc and multiline comments) + | SCPCmmCpp + -- ^ Use the C-- preprocessor (don't emit debug information) + deriving (Eq) + +-- | Run source code preprocessor. +-- See also Note [Preprocessing invocations] in GHC.SysTools.Cpp +runSourceCodePreprocessor + :: Logger + -> TmpFs + -> DynFlags + -> SourceCodePreprocessor + -> [Option] + -> IO () +runSourceCodePreprocessor logger tmpfs dflags preprocessor args = + traceSystoolCommand logger logger_name $ do + let + (program, configured_args) = pgm_getter dflags + runtime_args = Option <$> (augmentImports dflags $ getOpts dflags opt_getter) + extra_warns = [Option "-Werror" | gopt Opt_WarnIsError dflags] + ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] + all_args = configured_args ++ runtime_args ++ extra_warns ++ args + + mb_env <- getGccEnv (configured_args ++ runtime_args) + + runSomething readable_name program all_args mb_env + + where + toolSettings' = toolSettings dflags + cmmG0 = ["-g0" | toolSettings_cmmCppSupportsG0 toolSettings'] + -- GCC <=10 (pre commit r11-5596-g934a54180541d2) implied -dD for debug + -- flags by the spec snippet %{g3|ggdb3|gstabs3|gxcoff3|gvms3:-dD}. This + -- means that a g0 will not override a previously-specified -g3 causing + -- debug info emission (see https://gcc.gnu.org/PR97989). We're filtering + -- -optc here, rather than the combined command line, in order to avoid an + -- issue where a user has to, for some reason, override our decision. If + -- they see the need to do that, they can pass -optCmmP. + g3Flags = ["-g3", "-ggdb3", "-gstabs3", "-gxcoff3", "-gvms3"] + optCFiltered = filter (`notElem` g3Flags) . opt_c + -- In the wild (and GHC), there is lots of code assuming that -optc gets + -- passed to the C-- preprocessor too. Note that the arguments are + -- reversed by getOpts. That is, in the invocation, first come the runtime + -- C opts, then -g0, then the runtime CmmP opts. + cAndCmmOpt dflags = opt_CmmP dflags ++ cmmG0 ++ optCFiltered dflags + (logger_name, pgm_getter, opt_getter, readable_name) + = case preprocessor of + SCPCpp -> ("cpp", pgm_cpp, opt_c, "C pre-processor") + SCPHsCpp -> ("hs-cpp", pgm_P, opt_P, "Haskell C pre-processor") + SCPJsCpp -> ("js-cpp", pgm_JSP, opt_JSP, "JavaScript C pre-processor") + SCPCmmCpp -> ("cmm-cpp", pgm_CmmP, cAndCmmOpt, "C-- C pre-processor") + + runSomethingResponseFileCpp + = runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter + runSomethingFilteredOther phase_name pgm args mb_env + = runSomethingFiltered logger id phase_name pgm args Nothing mb_env + + runSomething + = case preprocessor of + SCPCpp -> runSomethingResponseFileCpp + SCPHsCpp -> runSomethingFilteredOther + SCPJsCpp -> runSomethingFilteredOther + SCPCmmCpp -> runSomethingResponseFileCpp + +runPp :: Logger -> DynFlags -> [Option] -> IO () +runPp logger dflags args = traceSystoolCommand logger "pp" $ do + let prog = pgm_F dflags + opts = map Option (getOpts dflags opt_F) + runSomething logger "Haskell pre-processor" prog (args ++ opts) + +-- | Run compiler of C-like languages and raw objects (such as gcc or clang). +runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO () +runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do + let args1 = map Option userOpts + args2 = languageOptions ++ args ++ args1 + -- We take care to pass -optc flags in args1 last to ensure that the + -- user can override flags passed by GHC. See #14452. + mb_env <- getGccEnv args2 + runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter dbgstring prog args2 + mb_env + where + -- force the C compiler to interpret this file as C when + -- compiling .hc files, by adding the -x c option. + -- Also useful for plain .c files, just in case GHC saw a + -- -x c option. + (languageOptions, userOpts, prog, dbgstring) = case mLanguage of + Nothing -> ([], userOpts_c, pgm_c dflags, "C Compiler") + Just language -> ([Option "-x", Option languageName], opts, prog, dbgstr) + where + (languageName, opts, prog, dbgstr) = case language of + LangC -> ("c", userOpts_c + ,pgm_c dflags, "C Compiler") + LangCxx -> ("c++", userOpts_cxx + ,pgm_cxx dflags , "C++ Compiler") + LangObjc -> ("objective-c", userOpts_c + ,pgm_c dflags , "Objective C Compiler") + LangObjcxx -> ("objective-c++", userOpts_cxx + ,pgm_cxx dflags, "Objective C++ Compiler") + LangAsm -> ("assembler", [] + ,pgm_c dflags, "Asm Compiler") + RawObject -> ("c", [] + ,pgm_c dflags, "C Compiler") -- claim C for lack of a better idea + --JS backend shouldn't reach here, so we just pass + -- strings to satisfy the totality checker + LangJs -> ("js", [] + ,pgm_c dflags, "JS Backend Compiler") + userOpts_c = getOpts dflags opt_c + userOpts_cxx = getOpts dflags opt_cxx + +isContainedIn :: String -> String -> Bool +xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) + +-- | Run the linker with some arguments and return the output +askLd :: Logger -> DynFlags -> [Option] -> IO String +askLd logger dflags args = traceSystoolCommand logger "linker" $ do + let (p,args0) = pgm_l dflags + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingWith logger "gcc" p args2 $ \real_args -> + readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } + +runAs :: Logger -> DynFlags -> [Option] -> IO () +runAs logger dflags args = traceSystoolCommand logger "as" $ do + let (p,args0) = pgm_a dflags + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingFiltered logger id "Assembler" p args2 Nothing mb_env + +-- | Run the LLVM Optimiser +runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO () +runLlvmOpt logger dflags args = traceSystoolCommand logger "opt" $ do + let (p,args0) = pgm_lo dflags + args1 = map Option (getOpts dflags opt_lo) + -- We take care to pass -optlo flags (e.g. args0) last to ensure that the + -- user can override flags passed by GHC. See #14821. + runSomething logger "LLVM Optimiser" p (args1 ++ args ++ args0) + +-- | Run the LLVM Compiler +runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO () +runLlvmLlc logger dflags args = traceSystoolCommand logger "llc" $ do + let (p,args0) = pgm_lc dflags + args1 = map Option (getOpts dflags opt_lc) + runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args) + +-- | Run the LLVM Assembler +runLlvmAs :: Logger -> DynFlags -> [Option] -> IO () +runLlvmAs logger dflags args = traceSystoolCommand logger "llvm-as" $ do + let (p,args0) = pgm_las dflags + args1 = map Option (getOpts dflags opt_las) + runSomething logger "LLVM assembler" p (args0 ++ args1 ++ args) + + +runEmscripten :: Logger -> DynFlags -> [Option] -> IO () +runEmscripten logger dflags args = traceSystoolCommand logger "emcc" $ do + let (p,args0) = pgm_a dflags + args1 = args0 ++ args + runSomething logger "Emscripten" p args1 + +-- | Figure out which version of LLVM we are running this session +figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion) +figureLlvmVersion logger dflags = traceSystoolCommand logger "llc" $ do + let (pgm,opts) = pgm_lc dflags + diag_opts = initDiagOpts dflags + args = filter notNull (map showOpt opts) + -- we grab the args even though they should be useless just in + -- case the user is using a customised 'llc' that requires some + -- of the options they've specified. llc doesn't care what other + -- options are specified when '-version' is used. + args' = args ++ ["-version"] + -- Since !12001, when GHC is not configured with llc/opt with + -- supported version range, configure script will leave llc/opt + -- commands as blank in settings. In this case, we should bail out + -- with a proper error, see #25011. + -- + -- Note that this does not make the -Wunsupported-llvm-version + -- warning logic redundant! Power users might want to use + -- -pgmlc/-pgmlo to override llc/opt locations to test LLVM outside + -- officially supported version range, and the driver will produce + -- the warning and carry on code generation. + when (null pgm) $ + printOrThrowDiagnostics logger (initPrintConfig dflags) diag_opts + (GhcDriverMessage <$> warnsToMessages diag_opts [noLoc DriverNoConfiguredLLVMToolchain]) + catchIO (do + (pin, pout, perr, p) <- runInteractiveProcess pgm args' + Nothing Nothing + {- > llc -version + LLVM version 15.0.7 + ... + OR + LLVM (http://llvm.org/): + LLVM version 14.0.6 + -} + hSetBinaryMode pout False + line1 <- hGetLine pout + mb_ver <- case parseLlvmVersion line1 of + mb_ver@(Just _) -> return mb_ver + Nothing -> parseLlvmVersion <$> hGetLine pout -- Try the second line + hClose pin + hClose pout + hClose perr + _ <- waitForProcess p + return mb_ver + ) + (\err -> do + debugTraceMsg logger 2 + (text "Error (figuring out LLVM version):" <+> + text (show err)) + errorMsg logger $ vcat + [ text "Warning:", nest 9 $ + text "Couldn't figure out LLVM version!" $$ + text ("Make sure you have installed LLVM between [" + ++ llvmVersionStr supportedLlvmVersionLowerBound + ++ " and " + ++ llvmVersionStr supportedLlvmVersionUpperBound + ++ ")") ] + return Nothing) + +-- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. +runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () +runMergeObjects logger tmpfs dflags args = + traceSystoolCommand logger "merge-objects" $ do + let (p,args0) = fromMaybe err (pgm_lm dflags) + err = throwGhcException $ UsageError $ unwords + [ "Attempted to merge object files but the configured linker" + , "does not support object merging." ] + optl_args = map Option (getOpts dflags opt_lm) + args2 = args0 ++ args ++ optl_args + if toolSettings_mergeObjsSupportsResponseFiles (toolSettings dflags) + then do + mb_env <- getGccEnv args2 + runSomethingResponseFile logger tmpfs (tmpDir dflags) id "Merge objects" p args2 mb_env + else do + runSomething logger "Merge objects" p args2 + +runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO () +runAr logger dflags cwd args = traceSystoolCommand logger "ar" $ do + let ar = pgm_ar dflags + runSomethingFiltered logger id "Ar" ar args cwd Nothing + +askOtool :: Logger -> ToolSettings -> Maybe FilePath -> [Option] -> IO String +askOtool logger toolSettings mb_cwd args = do + let otool = toolSettings_pgm_otool toolSettings + runSomethingWith logger "otool" otool args $ \real_args -> + readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } + +runInstallNameTool :: Logger -> ToolSettings -> [Option] -> IO () +runInstallNameTool logger toolSettings args = do + let tool = toolSettings_pgm_install_name_tool toolSettings + runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing + +runRanlib :: Logger -> DynFlags -> [Option] -> IO () +runRanlib logger dflags args = traceSystoolCommand logger "ranlib" $ do + let ranlib = pgm_ranlib dflags + runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing + +runWindres :: Logger -> DynFlags -> [Option] -> IO () +runWindres logger dflags args = traceSystoolCommand logger "windres" $ do + let cc_args = map Option (sOpt_c (settings dflags)) + windres = pgm_windres dflags + opts = map Option (getOpts dflags opt_windres) + mb_env <- getGccEnv cc_args + runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env diff --git a/GHC/SysTools/Terminal.hs b/GHC/SysTools/Terminal.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Terminal.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +module GHC.SysTools.Terminal (stderrSupportsAnsiColors) where + +import GHC.Prelude + +#if !defined(mingw32_HOST_OS) +import System.Environment (lookupEnv) +import System.IO (hIsTerminalDevice, stderr) +#else +import GHC.IO (catchException) +import GHC.Utils.Exception (try) +import Foreign (Ptr, peek, with) +import qualified Graphics.Win32 as Win32 +import qualified System.Win32 as Win32 +#endif + +import System.IO.Unsafe + +-- | Does the controlling terminal support ANSI color sequences? +-- This memoized to avoid thread-safety issues in ncurses (see #17922). +stderrSupportsAnsiColors :: Bool +stderrSupportsAnsiColors = unsafePerformIO stderrSupportsAnsiColors' +{-# NOINLINE stderrSupportsAnsiColors #-} + +-- | Check if ANSI escape sequences can be used to control color in stderr. +stderrSupportsAnsiColors' :: IO Bool +stderrSupportsAnsiColors' = do +#if !defined(mingw32_HOST_OS) + -- Equivalent of https://hackage.haskell.org/package/ansi-terminal/docs/System-Console-ANSI.html#v:hSupportsANSI + isTerminal <- hIsTerminalDevice stderr + term <- lookupEnv "TERM" + pure $ isTerminal && term /= Just "dumb" +#else + h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE + `catchException` \ (_ :: IOError) -> + pure Win32.nullHANDLE + if h == Win32.nullHANDLE + then pure False + else do + eMode <- try (getConsoleMode h) + case eMode of + Left (_ :: IOError) -> Win32.isMinTTYHandle h + -- Check if the we're in a MinTTY terminal + -- (e.g., Cygwin or MSYS2) + Right mode + | modeHasVTP mode -> pure True + | otherwise -> enableVTP h mode + + where + + enableVTP :: Win32.HANDLE -> Win32.DWORD -> IO Bool + enableVTP h mode = do + setConsoleMode h (modeAddVTP mode) + modeHasVTP <$> getConsoleMode h + `catchException` \ (_ :: IOError) -> + pure False + + modeHasVTP :: Win32.DWORD -> Bool + modeHasVTP mode = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 + + modeAddVTP :: Win32.DWORD -> Win32.DWORD + modeAddVTP mode = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING + +eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD +eNABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 + +getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD +getConsoleMode h = with 64 $ \ mode -> do + Win32.failIfFalse_ "GetConsoleMode" (c_GetConsoleMode h mode) + peek mode + +setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO () +setConsoleMode h mode = do + Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode) + +foreign import ccall unsafe "windows.h GetConsoleMode" c_GetConsoleMode + :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL + +foreign import ccall unsafe "windows.h SetConsoleMode" c_SetConsoleMode + :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL + +#endif diff --git a/GHC/Tc/Deriv.hs b/GHC/Tc/Deriv.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv.hs @@ -0,0 +1,2355 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handles @deriving@ clauses on @data@ declarations. +module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Driver.Session + +import GHC.Tc.Errors.Types +import GHC.Tc.Instance.Family +import GHC.Tc.Types.Origin +import GHC.Tc.Deriv.Infer +import GHC.Tc.Deriv.Utils +import GHC.Tc.Deriv.Generate +import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) +import GHC.Tc.Validity( checkValidInstHead ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Env + +import GHC.Rename.Bind +import GHC.Rename.Env +import GHC.Rename.Module ( addTcgDUs ) +import GHC.Rename.Utils + +import GHC.Core.TyCo.Ppr ( pprTyVars ) +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv +import GHC.Core.Unify( tcUnifyTy ) +import GHC.Core.Class +import GHC.Core.Type +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Predicate( tyCoVarsOfTypesWellScoped ) + +import GHC.Types.Hint (AssumedDerivingStrategy(..)) +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Name.Set as NameSet +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.SrcLoc + +import GHC.Unit.Module.Warnings +import GHC.Builtin.Names + +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Logger +import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.Bag +import GHC.Data.Maybe +import GHC.Data.BooleanFormula ( isUnsatisfied ) + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Data.List (partition, find) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +{- +************************************************************************ +* * + Overview +* * +************************************************************************ + +Overall plan +~~~~~~~~~~~~ +1. Convert the decls (i.e. data/newtype deriving clauses, + plus standalone deriving) to [EarlyDerivSpec] + +2. Infer the missing contexts for the InferTheta's + +3. Add the derived bindings, generating InstInfos +-} + +data EarlyDerivSpec = InferTheta (DerivSpec ThetaSpec) + | GivenTheta (DerivSpec ThetaType) + -- InferTheta ds => the context for the instance should be inferred + -- In this case ds_theta is the list of all the sets of + -- constraints needed, such as (Eq [a], Eq a), together with a + -- suitable CtLoc to get good error messages. + -- The inference process is to reduce this to a + -- simpler form (e.g. Eq a) + -- + -- GivenTheta ds => the exact context for the instance is supplied + -- by the programmer; it is ds_theta + -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer + +splitEarlyDerivSpec :: [EarlyDerivSpec] + -> ([DerivSpec ThetaSpec], [DerivSpec ThetaType]) +splitEarlyDerivSpec [] = ([],[]) +splitEarlyDerivSpec (InferTheta spec : specs) = + case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs) +splitEarlyDerivSpec (GivenTheta spec : specs) = + case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs) + +instance Outputable EarlyDerivSpec where + ppr (InferTheta spec) = ppr spec <+> text "(Infer)" + ppr (GivenTheta spec) = ppr spec <+> text "(Given)" + +{- +Note [Data decl contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data (RealFloat a) => Complex a = !a :+ !a deriving( Read ) + +We will need an instance decl like: + + instance (Read a, RealFloat a) => Read (Complex a) where + ... + +The RealFloat in the context is because the read method for Complex is bound +to construct a Complex, and doing that requires that the argument type is +in RealFloat. + +But this ain't true for Show, Eq, Ord, etc, since they don't construct +a Complex; they only take them apart. + +Our approach: identify the offending classes, and add the data type +context to the instance decl. The "offending classes" are + + Read, Enum? + +FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that +pattern matching against a constructor from a data type with a context +gives rise to the constraints for that context -- or at least the thinned +version. So now all classes are "offending". + +Note [Newtype deriving] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + class C a b + instance C [a] Char + newtype T = T Char deriving( C [a] ) + +Notice the free 'a' in the deriving. We have to fill this out to + newtype T = T Char deriving( forall a. C [a] ) + +And then translate it to: + instance C [a] Char => C [a] T where ... + +Note [Unused constructors and deriving clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #3221. Consider + data T = T1 | T2 deriving( Show ) +Are T1 and T2 unused? Well, no: the deriving clause expands to mention +both of them. So we gather defs/uses from deriving just like anything else. + +-} + +-- | Stuff needed to process a datatype's `deriving` clauses +data DerivInfo = DerivInfo { di_rep_tc :: TyCon + -- ^ The data tycon for normal datatypes, + -- or the *representation* tycon for data families + , di_scoped_tvs :: ![(Name,TyVar)] + -- ^ Variables that scope over the deriving clause. + -- See @Note [Scoped tyvars in a TcTyCon]@ in + -- "GHC.Core.TyCon". + , di_clauses :: [LHsDerivingClause GhcRn] + , di_ctxt :: ErrCtxtMsg -- ^ error context + } + +{- + +************************************************************************ +* * +Top-level function for \tr{derivings} +* * +************************************************************************ +-} + +tcDeriving :: [DerivInfo] -- All `deriving` clauses + -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations + -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn) +tcDeriving deriv_infos deriv_decls + = recoverM (do { g <- getGblEnv + ; return (g, emptyBag, emptyValBindsOut)}) $ + do { -- Fish the "deriving"-related information out of the GHC.Tc.Utils.Env + -- And make the necessary "equations". + early_specs <- makeDerivSpecs deriv_infos deriv_decls + ; traceTc "tcDeriving" (ppr early_specs) + + ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs + ; famInsts1 <- concatMapM genFamInsts given_specs + ; famInsts2 <- concatMapM genFamInsts infer_specs + ; let famInsts = famInsts1 ++ famInsts2 + + ; logger <- getLogger + + -- We must put all the derived type family instances (from both + -- infer_specs and given_specs) in the local instance environment + -- before proceeding, or else simplifyInstanceContexts might + -- get stuck if it has to reason about any of those family instances. + -- See Note [Staging of tcDeriving] + ; tcExtendLocalFamInstEnv famInsts $ + -- NB: only call tcExtendLocalFamInstEnv once, as it performs + -- validity checking for all of the family instances you give it. + -- If the family instances have errors, calling it twice will result + -- in duplicate error messages! + + do { given_inst_binds <- mapM genInstBinds given_specs + + ; let given_inst_infos = map fstOf3 given_inst_binds + + -- the stand-alone derived instances (@given_inst_infos@) are used when + -- inferring the contexts for "deriving" clauses' instances + -- (@infer_specs@) + ; final_infer_specs <- + extendLocalInstEnv (map iSpec given_inst_infos) $ + simplifyInstanceContexts infer_specs + ; infer_inst_binds <- mapM genInstBinds final_infer_specs + + ; let (_, aux_specs, fvs) = unzip3 (given_inst_binds ++ infer_inst_binds) + ; loc <- getSrcSpanM + ; let aux_binds = genAuxBinds loc (unionManyBags aux_specs) + + ; let infer_inst_infos = map fstOf3 infer_inst_binds + ; let inst_infos = given_inst_infos ++ infer_inst_infos + + ; (inst_info, rn_aux_binds, rn_dus) <- renameDeriv inst_infos aux_binds + + ; unless (isEmptyBag inst_info) $ + liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Derived instances" + FormatHaskell + (ddump_deriving inst_info rn_aux_binds famInsts)) + + ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) + getGblEnv + ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs) + ; return (addTcgDUs gbl_env all_dus, inst_info, rn_aux_binds) } } + where + ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn + -> [FamInst] -- Associated type family instances + -> SDoc + ddump_deriving inst_infos extra_binds famInsts + = hang (text "Derived class instances:") + 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) + $$ ppr extra_binds) + $$ hangP (text "Derived type family instances:") + (vcat (map pprRepTy famInsts)) + + hangP s x = text "" $$ hang s 2 x + +-- Prints the representable type family instance +pprRepTy :: FamInst -> SDoc +pprRepTy fi@(FamInst { fi_tys = lhs }) + = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> + equals <+> ppr rhs + where rhs = famInstRHS fi + +renameDeriv :: [InstInfo GhcPs] + -> Bag (LHsBind GhcPs, LSig GhcPs) + -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses) +renameDeriv inst_infos bagBinds + = discardWarnings $ + -- Discard warnings about unused bindings etc + setXOptM LangExt.EmptyCase $ + -- Derived decls (for empty types) can have + -- case x of {} + setXOptM LangExt.ScopedTypeVariables $ + setXOptM LangExt.KindSignatures $ + -- Derived decls (for newtype-deriving) can use ScopedTypeVariables & + -- KindSignatures + setXOptM LangExt.TypeAbstractions $ + setXOptM LangExt.TypeApplications $ + -- GND/DerivingVia uses TypeAbstractions & TypeApplications in generated code + -- (See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate) + unsetXOptM LangExt.RebindableSyntax $ + -- See Note [Avoid RebindableSyntax when deriving] + setXOptM LangExt.TemplateHaskellQuotes $ + -- DeriveLift makes uses of quotes + do { + -- Bring the extra deriving stuff into scope + -- before renaming the instances themselves + ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) + ; let (aux_binds, aux_sigs) = unzipBag bagBinds + aux_val_binds = ValBinds NoAnnSortKey (bagToList aux_binds) (bagToList aux_sigs) + -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename + -- auxiliary bindings as if they were defined locally. + -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. + ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyMiniFixityEnv aux_val_binds + ; bindLocalNames bndrs $ + do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs + ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos + ; return (listToBag rn_inst_infos, rn_aux, + dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } + + where + rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars) + rn_inst_info + inst_info@(InstInfo { iSpec = inst + , iBinds = InstBindings + { ib_binds = binds + , ib_tyvars = tyvars + , ib_pragmas = sigs + , ib_extensions = exts -- Only for type-checking + , ib_derived = sa } }) + = do { (rn_binds, rn_sigs, fvs) <- rnMethodBinds False (is_cls_nm inst) + tyvars binds sigs + ; let binds' = InstBindings { ib_binds = rn_binds + , ib_tyvars = tyvars + , ib_pragmas = rn_sigs + , ib_extensions = exts + , ib_derived = sa } + ; return (inst_info { iBinds = binds' }, fvs) } + +{- +Note [Staging of tcDeriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's a tricky corner case for deriving (adapted from #2721): + + class C a where + type T a + foo :: a -> T a + + instance C Int where + type T Int = Int + foo = id + + newtype N = N Int deriving C + +This will produce an instance something like this: + + instance C N where + type T N = T Int + foo = coerce (foo :: Int -> T Int) :: N -> T N + +We must be careful in order to typecheck this code. When determining the +context for the instance (in simplifyInstanceContexts), we need to determine +that T N and T Int have the same representation, but to do that, the T N +instance must be in the local family instance environment. Otherwise, GHC +would be unable to conclude that T Int is representationally equivalent to +T Int, and simplifyInstanceContexts would get stuck. + +Previously, tcDeriving would defer adding any derived type family instances to +the instance environment until the very end, which meant that +simplifyInstanceContexts would get called without all the type family instances +it needed in the environment in order to properly simplify instance like +the C N instance above. + +To avoid this scenario, we generate things in tcDeriving in a specific order: + +1. First, we generate all of the associated type family instances for derived + instances (using `genFamInsts`). +2. Next, we extend the local instance environment with these type family + instances. +3. Then, we generate the instance bindings for derived instances + (using `genInstBinds`). +4. Finally, for instances generated with `deriving` clauses, we infer the + instance contexts (using `simplifyInstanceContexts`). At this point, we + already have the necessary type family instances in scope (from step (2)), + so this is safe to do. + +Note [Why we don't pass rep_tc into deriveTyData] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc +back into the rep_tc by means of a lookup. And yet we have the rep_tc right +here! Why look it up again? Answer: it's just easier this way. +We drop some number of arguments from the end of the datatype definition +in deriveTyData. The arguments are dropped from the fam_tc. +This action may drop a *different* number of arguments +passed to the rep_tc, depending on how many free variables, etc., the +dropped patterns have. + +Also, this technique carries over the kind substitution from deriveTyData +nicely. + +Note [Avoid RebindableSyntax when deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RebindableSyntax extension interacts awkwardly with the derivation of +any stock class whose methods require the use of string literals. The Show +class is a simple example (see #12688): + + {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} + newtype Text = Text String + fromString :: String -> Text + fromString = Text + + data Foo = Foo deriving Show + +This will generate code to the effect of: + + instance Show Foo where + showsPrec _ Foo = showString "Foo" + +But because RebindableSyntax and OverloadedStrings are enabled, the "Foo" +string literal is now of type Text, not String, which showString doesn't +accept! This causes the generated Show instance to fail to typecheck. + +To avoid this kind of scenario, we simply turn off RebindableSyntax entirely +in derived code. + +************************************************************************ +* * + From HsSyn to DerivSpec +* * +************************************************************************ + +@makeDerivSpecs@ fishes around to find the info about needed derived instances. +-} + +mechanismToAssumedStrategy :: DerivSpecMechanism -> Maybe AssumedDerivingStrategy +mechanismToAssumedStrategy = \case + DerivSpecStock{} -> Just AssumedStockStrategy + DerivSpecAnyClass{} -> Just AssumedAnyclassStrategy + DerivSpecNewtype{} -> Just AssumedNewtypeStrategy + DerivSpecVia{} -> Nothing -- `via` is never assumed, it is always explicit + +warnNoDerivingClauseStrategy + :: Maybe (LDerivStrategy GhcTc) + -- ^ The given deriving strategy, if any. + -> [(LHsSigType GhcRn, EarlyDerivSpec)] + -- ^ The given deriving predicates of a deriving clause (for example 'Show' & + -- 'Eq' in @deriving (Show, Eq)@) along with the 'EarlyDerivSpec' which we + -- use to find out what deriving strategy was actually used. + -- See comments of 'TcRnNoDerivingClauseStrategySpecified'. + -> TcM () +warnNoDerivingClauseStrategy Just{} _early_deriv_specs = pure () +warnNoDerivingClauseStrategy Nothing early_deriv_specs = do + let all_assumed_strategies :: Map AssumedDerivingStrategy [LHsSigType GhcRn] + all_assumed_strategies = + Map.unionsWith (++) (map early_deriv_spec_to_assumed_strategies early_deriv_specs) + + dyn_flags <- getDynFlags + addDiagnosticTc $ + TcRnNoDerivStratSpecified (xopt LangExt.DerivingStrategies dyn_flags) $ + TcRnNoDerivingClauseStrategySpecified all_assumed_strategies + + where + deriv_spec_to_assumed_strategy :: LHsSigType GhcRn + -> DerivSpec theta + -> Map AssumedDerivingStrategy [LHsSigType GhcRn] + deriv_spec_to_assumed_strategy deriv_head deriv_spec = + Map.fromList + [ (strat, [deriv_head]) + | strat <- maybeToList $ mechanismToAssumedStrategy (ds_mechanism deriv_spec) + ] + + early_deriv_spec_to_assumed_strategies :: (LHsSigType GhcRn, EarlyDerivSpec) + -> Map AssumedDerivingStrategy [LHsSigType GhcRn] + early_deriv_spec_to_assumed_strategies (deriv_head, InferTheta deriv_spec) = + deriv_spec_to_assumed_strategy deriv_head deriv_spec + early_deriv_spec_to_assumed_strategies (deriv_head, GivenTheta deriv_spec) = + deriv_spec_to_assumed_strategy deriv_head deriv_spec + +warnNoStandaloneDerivingStrategy + :: Maybe (LDerivStrategy GhcTc) + -- ^ The given deriving strategy, if any. + -> LHsSigWcType GhcRn + -- ^ The standalone deriving declaration's signature for example, the: + -- C a => C (T a) + -- part of the standalone deriving instance: + -- deriving instance C a => C (T a) + -> EarlyDerivSpec + -- ^ We extract the assumed deriving strategy from this. + -> TcM () +warnNoStandaloneDerivingStrategy Just{} _deriv_ty _early_deriv_spec = pure () +warnNoStandaloneDerivingStrategy Nothing deriv_ty early_deriv_spec = + case mechanismToAssumedStrategy $ early_deriv_spec_mechanism early_deriv_spec of + Nothing -> pure () + Just assumed_strategy -> do + dyn_flags <- getDynFlags + addDiagnosticTc $ + TcRnNoDerivStratSpecified (xopt LangExt.DerivingStrategies dyn_flags) $ + TcRnNoStandaloneDerivingStrategySpecified assumed_strategy deriv_ty + + where + early_deriv_spec_mechanism :: EarlyDerivSpec -> DerivSpecMechanism + early_deriv_spec_mechanism (InferTheta deriv_spec) = ds_mechanism deriv_spec + early_deriv_spec_mechanism (GivenTheta deriv_spec) = ds_mechanism deriv_spec + +makeDerivSpecs :: [DerivInfo] + -> [LDerivDecl GhcRn] + -> TcM [EarlyDerivSpec] +makeDerivSpecs deriv_infos deriv_decls + = do { eqns1 <- sequenceA + -- MP: scoped_tvs here magically converts TyVar into TcTyVar + [ deriveClause rep_tc scoped_tvs dcs (deriv_clause_preds dct) err_ctxt + | DerivInfo { di_rep_tc = rep_tc + , di_scoped_tvs = scoped_tvs + , di_clauses = clauses + , di_ctxt = err_ctxt } <- deriv_infos + , L _ (HsDerivingClause { deriv_clause_strategy = dcs + , deriv_clause_tys = dct }) + <- clauses + ] + ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls + ; return $ concat eqns1 ++ catMaybes eqns2 } + where + deriv_clause_preds :: LDerivClauseTys GhcRn -> LocatedC [LHsSigType GhcRn] + deriv_clause_preds (L loc dct) = case dct of + DctSingle _ ty -> L loc [ty] + DctMulti _ tys -> L loc tys + +------------------------------------------------------------------ +-- | Process the derived classes in a single @deriving@ clause. +deriveClause :: TyCon + -> [(Name, TcTyVar)] -- Scoped type variables taken from tcTyConScopedTyVars + -- See Note [Scoped tyvars in a TcTyCon] in "GHC.Core.TyCon" + -> Maybe (LDerivStrategy GhcRn) + -> LocatedC [LHsSigType GhcRn] + -- ^ The location refers to the @(Show, Eq)@ part of @deriving (Show, Eq)@. + -> ErrCtxtMsg + -> TcM [EarlyDerivSpec] +deriveClause rep_tc scoped_tvs mb_lderiv_strat (L loc deriv_preds) err_ctxt + = setSrcSpanA loc $ + addErrCtxt err_ctxt $ do + traceTc "deriveClause" $ vcat + [ text "tvs" <+> ppr tvs + , text "scoped_tvs" <+> ppr scoped_tvs + , text "tc" <+> ppr tc + , text "tys" <+> ppr tys + , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ] + tcExtendNameTyVarEnv scoped_tvs $ do + (mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat + earlyDerivSpecs <- tcExtendTyVarEnv via_tvs $ + -- Moreover, when using DerivingVia one can bind type variables in + -- the `via` type as well, so these type variables must also be + -- brought into scope. + mapMaybeM + (\deriv_pred -> + do maybe_early_deriv_spec <- derivePred tc tys mb_lderiv_strat' via_tvs deriv_pred + pure $ fmap (deriv_pred,) maybe_early_deriv_spec) + deriv_preds + -- After typechecking the `via` type once, we then typecheck all + -- of the classes associated with that `via` type in the + -- `deriving` clause. + -- See also Note [Don't typecheck too much in DerivingVia]. + warnNoDerivingClauseStrategy mb_lderiv_strat' earlyDerivSpecs + return (snd <$> earlyDerivSpecs) + where + tvs = tyConTyVars rep_tc + (tc, tys) = case tyConFamInstSig_maybe rep_tc of + -- data family: + Just (fam_tc, pats, _) -> (fam_tc, pats) + -- NB: deriveTyData wants the *user-specified* + -- name. See Note [Why we don't pass rep_tc into deriveTyData] + + _ -> (rep_tc, mkTyVarTys tvs) -- datatype + +-- | Process a single predicate in a @deriving@ clause. +-- +-- This returns a 'Maybe' because the user might try to derive 'Typeable', +-- which is a no-op nowadays. +derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar] + -> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec) +derivePred tc tys mb_lderiv_strat via_tvs deriv_pred = + -- We carefully set up uses of recoverM to minimize error message + -- cascades. See Note [Recovering from failures in deriving clauses]. + recoverM (pure Nothing) $ + setSrcSpan (getLocA deriv_pred) $ do + traceTc "derivePred" $ vcat + [ text "tc" <+> ppr tc + , text "tys" <+> ppr tys + , text "deriv_pred" <+> ppr deriv_pred + , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat + , text "via_tvs" <+> ppr via_tvs ] + mb_cls_minus1 <- tcHsDeriv deriv_pred + case mb_cls_minus1 of + Nothing -> return Nothing + Just (cls, cls_tvs, arg_tys, arg_kind) -> + do let mb_deriv_strat = fmap unLoc mb_lderiv_strat + if className cls == typeableClassName + then do warnUselessTypeable + return Nothing + else let deriv_tvs = via_tvs ++ cls_tvs in + Just <$> deriveTyData tc tys mb_deriv_strat + deriv_tvs cls arg_tys arg_kind + +{- Note [Don't typecheck too much in DerivingVia] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example: + + data D = ... + deriving (A1 t, ..., A20 t) via T t + +GHC used to be engineered such that it would typecheck the `deriving` +clause like so: + +1. Take the first class in the clause (`A1`). +2. Typecheck the `via` type (`T t`) and bring its bound type variables + into scope (`t`). +3. Typecheck the class (`A1`). +4. Move on to the next class (`A2`) and repeat the process until all + classes have been typechecked. + +This algorithm gets the job done most of the time, but it has two notable +flaws. One flaw is that it is wasteful: it requires that `T t` be typechecked +20 different times, once for each class in the `deriving` clause. This is +unnecessary because we only need to typecheck `T t` once in order to get +access to its bound type variable. + +The other issue with this algorithm arises when there are no classes in the +`deriving` clause, like in the following example: + + data D2 = ... + deriving () via Maybe Maybe + +Because there are no classes, the algorithm above will simply do nothing. +As a consequence, GHC will completely miss the fact that `Maybe Maybe` +is ill-kinded nonsense (#16923). + +To address both of these problems, GHC now uses this algorithm instead: + +1. Typecheck the `via` type and bring its bound type variables into scope. +2. Take the first class in the `deriving` clause. +3. Typecheck the class. +4. Move on to the next class and repeat the process until all classes have been + typechecked. + +This algorithm ensures that the `via` type is always typechecked, even if there +are no classes in the `deriving` clause. Moreover, it typecheck the `via` type +/exactly/ once and no more, even if there are multiple classes in the clause. + +Note [Recovering from failures in deriving clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider what happens if you run this program (from #10684) without +DeriveGeneric enabled: + + data A = A deriving (Show, Generic) + data B = B A deriving (Show) + +Naturally, you'd expect GHC to give an error to the effect of: + + Can't make a derived instance of `Generic A': + You need -XDeriveGeneric to derive an instance for this class + +And *only* that error, since the other two derived Show instances appear to be +independent of this derived Generic instance. Yet GHC also used to give this +additional error on the program above: + + No instance for (Show A) + arising from the 'deriving' clause of a data type declaration + When deriving the instance for (Show B) + +This was happening because when GHC encountered any error within a single +data type's set of deriving clauses, it would call recoverM and move on +to the next data type's deriving clauses. One unfortunate consequence of +this design is that if A's derived Generic instance failed, its derived +Show instance would be skipped entirely, leading to the "No instance for +(Show A)" error cascade. + +The solution to this problem is to push through uses of recoverM to the +level of the individual derived classes in a particular data type's set of +deriving clauses. That is, if you have: + + newtype C = C D + deriving (E, F, G) + +Then instead of processing instances E through M under the scope of a single +recoverM, as in the following pseudocode: + + recoverM (pure Nothing) $ mapM derivePred [E, F, G] + +We instead use recoverM in each iteration of the loop: + + mapM (recoverM (pure Nothing) . derivePred) [E, F, G] + +And then process each class individually, under its own recoverM scope. That +way, failure to derive one class doesn't cancel out other classes in the +same set of clause-derived classes. +-} + +------------------------------------------------------------------ +deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec) +-- Process a single standalone deriving declaration +-- e.g. deriving instance Show a => Show (T a) +-- Rather like tcLocalInstDecl +-- +-- This returns a Maybe because the user might try to derive Typeable, which is +-- a no-op nowadays. +deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mode)) + = setSrcSpanA loc $ + addErrCtxt (StandaloneDerivCtxt deriv_ty) $ + do { traceTc "Standalone deriving decl for" (ppr deriv_ty) + ; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True + ; traceTc "Deriving strategy (standalone deriving)" $ + vcat [ppr mb_lderiv_strat, ppr deriv_ty] + ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat + ; traceTc "Deriving strategy (standalone deriving) 2" $ + vcat [ppr mb_lderiv_strat, ppr via_tvs] + ; (cls_tvs, deriv_ctxt, cls, inst_tys) + <- tcExtendTyVarEnv via_tvs $ + tcStandaloneDerivInstType ctxt deriv_ty + ; let mb_deriv_strat = fmap unLoc mb_lderiv_strat + tvs = via_tvs ++ cls_tvs + -- See Note [Unify kinds in deriving] + ; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <- + case mb_deriv_strat of + -- Perform an additional unification with the kind of the `via` + -- type and the result of the previous kind unification. + Just (ViaStrategy via_ty) + -- This unification must be performed on the last element of + -- inst_tys, but we have not yet checked for this property. + -- (This is done later in expectNonNullaryClsArgs). For now, + -- simply do nothing if inst_tys is empty, since + -- expectNonNullaryClsArgs will error later if this + -- is the case. + | Just inst_ty <- lastMaybe inst_tys + -> do + let via_kind = typeKind via_ty + inst_ty_kind = typeKind inst_ty + mb_match = tcUnifyTy inst_ty_kind via_kind + + kind_subst <- checkJustTc + ( TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $ + DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind ) + mb_match + + let ki_subst_range = getSubstRangeTyCoFVs kind_subst + -- See Note [Unification of two kind variables in deriving] + unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst + && not (v `elemVarSet` ki_subst_range)) + tvs + (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs + (final_deriv_ctxt, final_deriv_ctxt_tys) + = case deriv_ctxt of + InferContext wc -> (InferContext wc, []) + SupplyContext theta -> + let final_theta = substTheta subst theta + in (SupplyContext final_theta, final_theta) + final_inst_tys = substTys subst inst_tys + final_via_ty = substTy subst via_ty + -- See Note [Floating `via` type variables] + final_tvs = tyCoVarsOfTypesWellScoped $ + final_deriv_ctxt_tys ++ final_inst_tys + ++ [final_via_ty] + pure ( final_tvs, final_deriv_ctxt, final_inst_tys + , Just (ViaStrategy final_via_ty) ) + + _ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat) + ; traceTc "Standalone deriving;" $ vcat + [ text "tvs':" <+> ppr tvs' + , text "mb_deriv_strat':" <+> ppr mb_deriv_strat' + , text "deriv_ctxt':" <+> ppr deriv_ctxt' + , text "cls:" <+> ppr cls + , text "inst_tys':" <+> ppr inst_tys' ] + -- C.f. GHC.Tc.TyCl.Instance.tcLocalInstDecl1 + + ; if className cls == typeableClassName + then do warnUselessTypeable + return Nothing + else do early_deriv_spec <- + mkEqnHelp (fmap unLoc overlap_mode) + tvs' cls inst_tys' + deriv_ctxt' mb_deriv_strat' + (fmap unLoc warn) + warnNoStandaloneDerivingStrategy + mb_lderiv_strat + deriv_ty + early_deriv_spec + pure (Just early_deriv_spec) } + +-- Typecheck the type in a standalone deriving declaration. +-- +-- This may appear dense, but it's mostly huffing and puffing to recognize +-- the special case of a type with an extra-constraints wildcard context, e.g., +-- +-- deriving instance _ => Eq (Foo a) +-- +-- If there is such a wildcard, we typecheck this as if we had written +-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@, +-- as the 'DerivContext', where loc is the location of the wildcard used for +-- error reporting. This indicates that we should infer the context as if we +-- were deriving Eq via a deriving clause +-- (see Note [Inferring the instance context] in GHC.Tc.Deriv.Infer). +-- +-- If there is no wildcard, then proceed as normal, and instead return +-- @'SupplyContext' theta@, where theta is the typechecked context. +-- +-- Note that this will never return @'InferContext' 'Nothing'@, as that can +-- only happen with @deriving@ clauses. +tcStandaloneDerivInstType + :: UserTypeCtxt -> LHsSigWcType GhcRn + -> TcM ([TyVar], DerivContext, Class, [Type]) +tcStandaloneDerivInstType ctxt + (HsWC { hswc_body = deriv_ty@(L loc (HsSig { sig_bndrs = outer_bndrs + , sig_body = deriv_ty_body }))}) + | (theta, rho) <- splitLHsQualTy deriv_ty_body + , [wc_pred] <- fromMaybeContext theta + , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred + = do dfun_ty <- tcHsClsInstType ctxt $ L loc $ + HsSig { sig_ext = noExtField + , sig_bndrs = outer_bndrs + , sig_body = rho } + let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty + pure (tvs, InferContext (Just (locA wc_span)), cls, inst_tys) + | otherwise + = do dfun_ty <- tcHsClsInstType ctxt deriv_ty + let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty + pure (tvs, SupplyContext theta, cls, inst_tys) + +warnUselessTypeable :: TcM () +warnUselessTypeable = addDiagnosticTc TcRnUselessTypeable + +------------------------------------------------------------------ +deriveTyData :: TyCon -> [Type] -- LHS of data or data instance + -- Can be a data instance, hence [Type] args + -- and in that case the TyCon is the /family/ tycon + -> Maybe (DerivStrategy GhcTc) -- The optional deriving strategy + -> [TyVar] -- The type variables bound by the derived class + -> Class -- The derived class + -> [Type] -- The derived class's arguments + -> Kind -- The function argument in the derived class's kind. + -- (e.g., if `deriving Functor`, this would be + -- `Type -> Type` since + -- `Functor :: (Type -> Type) -> Constraint`) + -> TcM EarlyDerivSpec +-- The deriving clause of a data or newtype declaration +-- I.e. not standalone deriving +deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind + = do { -- Given data T a b c = ... deriving( C d ), + -- we want to drop type variables from T so that (C d (T a)) is well-kinded + let (arg_kinds, _) = splitFunTys cls_arg_kind + n_args_to_drop = length arg_kinds + n_args_to_keep = length tc_args - n_args_to_drop + -- See Note [tc_args and tycon arity] + (tc_args_to_keep, args_to_drop) + = splitAt n_args_to_keep tc_args + inst_ty_kind = typeKind (mkTyConApp tc tc_args_to_keep) + + -- Match up the kinds, and apply the resulting kind substitution + -- to the types. See Note [Unify kinds in deriving] + -- We are assuming the tycon tyvars and the class tyvars are distinct + mb_match = tcUnifyTy inst_ty_kind cls_arg_kind + enough_args = n_args_to_keep >= 0 + + -- Check that the result really is well-kinded + ; traceTc "deriveTyData" $ + vcat [ text "class:" <+> ppr cls <+> dcolon <+> ppr (tyConKind (classTyCon cls)) + , text "cls_tys:" <+> ppr cls_tys + , text "tycon:" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) + , text "cls_arg:" <+> ppr (mkTyConApp tc tc_args_to_keep) <+> dcolon <+> ppr inst_ty_kind + , text "cls_arg_kind:" <+> ppr cls_arg_kind ] + ; kind_subst <- checkJustTc + ( TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $ + DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep ) + ( guard enough_args *> mb_match ) + + ; let -- Returns a singleton-element list if using ViaStrategy and an + -- empty list otherwise. Useful for free-variable calculations. + deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type] + deriv_strat_tys = foldMap (foldDerivStrategy [] (:[])) + + propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat' + = (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) + where + ki_subst_range = getSubstRangeTyCoFVs kind_subst + -- See Note [Unification of two kind variables in deriving] + unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst + && not (v `elemVarSet` ki_subst_range)) + tkvs' + (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs + final_tc_args = substTys subst tc_args' + final_cls_tys = substTys subst cls_tys' + final_mb_deriv_strat = fmap (mapDerivStrategy (substTy subst)) + mb_deriv_strat' + -- See Note [Floating `via` type variables] + final_tkvs = tyCoVarsOfTypesWellScoped $ + final_cls_tys ++ final_tc_args + ++ deriv_strat_tys final_mb_deriv_strat + + ; let tkvs = scopedSort $ fvVarList $ + unionFV (tyCoFVsOfTypes tc_args_to_keep) + (FV.mkFVs deriv_tvs) + (tkvs', cls_tys', tc_args', mb_deriv_strat') + = propagate_subst kind_subst tkvs cls_tys + tc_args_to_keep mb_deriv_strat + + -- See Note [Unify kinds in deriving] + ; (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <- + case mb_deriv_strat' of + -- Perform an additional unification with the kind of the `via` + -- type and the result of the previous kind unification. + Just (ViaStrategy via_ty) -> do + let via_kind = typeKind via_ty + inst_ty_kind + = typeKind (mkTyConApp tc tc_args') + via_match = tcUnifyTy inst_ty_kind via_kind + + via_subst <- checkJustTc + ( TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $ + DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind ) + via_match + + pure $ propagate_subst via_subst tkvs' cls_tys' + tc_args' mb_deriv_strat' + + _ -> pure (tkvs', cls_tys', tc_args', mb_deriv_strat') + + ; traceTc "deriveTyData 1" $ vcat + [ ppr final_mb_deriv_strat, pprTyVars deriv_tvs, ppr tc, ppr tc_args + , pprTyVars (tyCoVarsOfTypesList tc_args) + , ppr n_args_to_keep, ppr n_args_to_drop + , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match + , ppr final_tc_args, ppr final_cls_tys ] + + ; traceTc "deriveTyData 2" $ vcat + [ ppr final_tkvs ] + + ; let final_tc_app = mkTyConApp tc final_tc_args + final_cls_args = final_cls_tys ++ [final_tc_app] + ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c) + (TcRnCannotDeriveInstance cls final_cls_tys Nothing NoGeneralizedNewtypeDeriving $ + DerivErrNoEtaReduce final_tc_app) + -- Check that + -- (a) The args to drop are all type variables; eg reject: + -- data instance T a Int = .... deriving( Monad ) + -- (b) The args to drop are all *distinct* type variables; eg reject: + -- class C (a :: * -> * -> *) where ... + -- data instance T a a = ... deriving( C ) + -- (c) The type class args, or remaining tycon args, + -- do not mention any of the dropped type variables + -- newtype T a s = ... deriving( ST s ) + -- newtype instance K a a = ... deriving( Monad ) + -- + -- It is vital that the implementation of allDistinctTyVars + -- expand any type synonyms. + -- See Note [Eta-reducing type synonyms] + + ; checkValidInstHead DerivClauseCtxt cls final_cls_args + -- Check that we aren't deriving an instance of a magical + -- type like (~) or Coercible (#14916). + + ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args + (InferContext Nothing) final_mb_deriv_strat + Nothing + ; traceTc "deriveTyData 3" (ppr spec) + ; return spec } + + +{- Note [tc_args and tycon arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might wonder if we could use (tyConArity tc) at this point, rather +than (length tc_args). But for data families the two can differ! The +tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which +in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them +from DataFamInstTyCon: + +| DataFamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- No shorter in length than the tyConTyVars of the family TyCon + -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv + +Notice that the arg tys might not be the same as the family tycon arity +(= length tyConTyVars). + +Note [Unify kinds in deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#8534) + data T a b = MkT a deriving( Functor ) + -- where Functor :: (*->*) -> Constraint + +So T :: forall k. * -> k -> *. We want to get + instance Functor (T * (a:*)) where ... +Notice the '*' argument to T. + +Moreover, as well as instantiating T's kind arguments, we may need to instantiate +C's kind args. Consider (#8865): + newtype T a b = MkT (Either a b) deriving( Category ) +where + Category :: forall k. (k -> k -> *) -> Constraint +We need to generate the instance + instance Category * (Either a) where ... +Notice the '*' argument to Category. + +So we need to + * drop arguments from (T a b) to match the number of + arrows in the (last argument of the) class; + * and then *unify* kind of the remaining type against the + expected kind, to figure out how to instantiate C's and T's + kind arguments. + +In the two examples, + * we unify kind-of( T k (a:k) ) ~ kind-of( Functor ) + i.e. (k -> *) ~ (* -> *) to find k:=*. + yielding k:=* + + * we unify kind-of( Either ) ~ kind-of( Category ) + i.e. (* -> * -> *) ~ (k -> k -> k) + yielding k:=* + +Now we get a kind substitution. We then need to: + + 1. Remove the substituted-out kind variables from the quantified kind vars + + 2. Apply the substitution to the kinds of quantified *type* vars + (and extend the substitution to reflect this change) + + 3. Apply that extended substitution to the non-dropped args (types and + kinds) of the type and class + +Forgetting step (2) caused #8893: + data V a = V [a] deriving Functor + data P (x::k->*) (a:k) = P (x a) deriving Functor + data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor + +When deriving Functor for P, we unify k to *, but we then want +an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*)) +and similarly for C. Notice the modified kind of x, both at binding +and occurrence sites. + +This can lead to some surprising results when *visible* kind binder is +unified (in contrast to the above examples, in which only non-visible kind +binders were considered). Consider this example from #11732: + + data T k (a :: k) = MkT deriving Functor + +Since unification yields k:=*, this results in a generated instance of: + + instance Functor (T *) where ... + +which looks odd at first glance, since one might expect the instance head +to be of the form Functor (T k). Indeed, one could envision an alternative +generated instance of: + + instance (k ~ *) => Functor (T k) where + +But this does not typecheck by design: kind equalities are not allowed to be +bound in types, only terms. But in essence, the two instance declarations are +entirely equivalent, since even though (T k) matches any kind k, the only +possibly value for k is *, since anything else is ill-typed. As a result, we can +just as comfortably use (T *). + +Another way of thinking about is: deriving clauses often infer constraints. +For example: + + data S a = S a deriving Eq + +infers an (Eq a) constraint in the derived instance. By analogy, when we +are deriving Functor, we might infer an equality constraint (e.g., k ~ *). +The only distinction is that GHC instantiates equality constraints directly +during the deriving process. + +Another quirk of this design choice manifests when typeclasses have visible +kind parameters. Consider this code (also from #11732): + + class Cat k (cat :: k -> k -> *) where + catId :: cat a a + catComp :: cat b c -> cat a b -> cat a c + + instance Cat * (->) where + catId = id + catComp = (.) + + newtype Fun a b = Fun (a -> b) deriving (Cat k) + +Even though we requested a derived instance of the form (Cat k Fun), the +kind unification will actually generate (Cat * Fun) (i.e., the same thing as if +the user wrote deriving (Cat *)). + +What happens with DerivingVia, when you have yet another type? Consider: + + newtype Foo (a :: Type) = MkFoo (Proxy a) + deriving Functor via Proxy + +As before, we unify the kind of Foo (* -> *) with the kind of the argument to +Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind +(k -> *), which is more general than what we want. So we must additionally +unify (k -> *) with (* -> *). + +Currently, all of this unification is implemented kludgily with the pure +unifier, which is rather tiresome. #14331 lays out a plan for how this +might be made cleaner. + +Note [Unification of two kind variables in deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As a special case of the Note above, it is possible to derive an instance of +a poly-kinded typeclass for a poly-kinded datatype. For example: + + class Category (cat :: k -> k -> *) where + newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category + +This case is surprisingly tricky. To see why, let's write out what instance GHC +will attempt to derive (using -fprint-explicit-kinds syntax): + + instance Category k1 (T k2 c) where ... + +GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst) +that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to +the type variable binder for c, since its kind is (k2 -> k2 -> *). + +We used to accomplish this by doing the following: + + unmapped_tkvs = filter (`notElemSubst` kind_subst) all_tkvs + (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs + +Where all_tkvs contains all kind variables in the class and instance types (in +this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping, +this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped +to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new]. +This is bad, because applying that substitution yields the following instance: + + instance Category k_new (T k1 c) where ... + +In other words, keeping k1 in unmapped_tvks taints the substitution, resulting +in an ill-kinded instance (this caused #11837). + +To prevent this, we need to filter out any variable from all_tkvs which either + +1. Appears in the domain of kind_subst. notElemSubst checks this. +2. Appears in the range of kind_subst. To do this, we compute the free + variable set of the range of kind_subst with getSubstRangeTyCoFVs, and check + if a kind variable appears in that set. + +Note [Eta-reducing type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One can instantiate a type in a data family instance with a type synonym that +mentions other type variables: + + type Const a b = a + data family Fam (f :: * -> *) (a :: *) + newtype instance Fam f (Const a f) = Fam (f a) deriving Functor + +It is also possible to define kind synonyms, and they can mention other types in +a datatype declaration. For example, + + type Const a b = a + newtype T f (a :: Const * f) = T (f a) deriving Functor + +When deriving, we need to perform eta-reduction analysis to ensure that none of +the eta-reduced type variables are mentioned elsewhere in the declaration. But +we need to be careful, because if we don't expand through the Const type +synonym, we will mistakenly believe that f is an eta-reduced type variable and +fail to derive Functor, even though the code above is correct (see #11416, +where this was first noticed). For this reason, we expand the type synonyms in +the eta-reduced types before doing any analysis. + +Note [Floating `via` type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When generating a derived instance, it will be of the form: + + instance forall ???. C c_args (D d_args) where ... + +To fill in ???, GHC computes the free variables of `c_args` and `d_args`. +`DerivingVia` adds an extra wrinkle to this formula, since we must also +include the variables bound by the `via` type when computing the binders +used to fill in ???. This might seem strange, since if a `via` type binds +any type variables, then in almost all scenarios it will appear free in +`c_args` or `d_args`. There are certain corner cases where this does not hold, +however, such as in the following example (adapted from #15831): + + newtype Age = MkAge Int + deriving Eq via Const Int a + +In this example, the `via` type binds the type variable `a`, but `a` appears +nowhere in `Eq Age`. Nevertheless, we include it in the generated instance: + + instance forall a. Eq Age where + (==) = coerce @(Const Int a -> Const Int a -> Bool) + @(Age -> Age -> Bool) + (==) + +The use of `forall a` is certainly required here, since the `a` in +`Const Int a` would not be in scope otherwise. This instance is somewhat +strange in that nothing in the instance head `Eq Age` ever determines what `a` +will be, so any code that uses this instance will invariably instantiate `a` +to be `Any`. We refer to this property of `a` as being a "floating" `via` +type variable. Programs with floating `via` type variables are the only known +class of program in which the `via` type quantifies type variables that aren't +mentioned in the instance head in the generated instance. + +Fortunately, the choice to instantiate floating `via` type variables to `Any` +is one that is completely transparent to the user (since the instance will +work as expected regardless of what `a` is instantiated to), so we decide to +permit them. An alternative design would make programs with floating `via` +variables illegal, by requiring that every variable mentioned in the `via` type +is also mentioned in the data header or the derived class. That restriction +would require the user to pick a particular type (the choice does not matter); +for example: + + newtype Age = MkAge Int + -- deriving Eq via Const Int a -- Floating 'a' + deriving Eq via Const Int () -- Choose a=() + deriving Eq via Const Int Any -- Choose a=Any + +No expressiveness would be lost thereby, but stylistically it seems preferable +to allow a type variable to indicate "it doesn't matter". + +Note that by quantifying the `a` in `forall a. Eq Age`, we are deferring the +work of instantiating `a` to `Any` at every use site of the instance. An +alternative approach would be to generate an instance that directly defaulted +to `Any`: + + instance Eq Age where + (==) = coerce @(Const Int Any -> Const Int Any -> Bool) + @(Age -> Age -> Bool) + (==) + +We do not implement this approach since it would require a nontrivial amount +of implementation effort to substitute `Any` for the floating `via` type +variables, and since the end result isn't distinguishable from the former +instance (at least from the user's perspective), the amount of engineering +required to obtain the latter instance just isn't worth it. +-} + +mkEqnHelp :: Maybe OverlapMode + -> [TyVar] + -> Class -> [Type] + -> DerivContext + -- SupplyContext => context supplied (standalone deriving) + -- InferContext => context inferred (deriving on data decl, or + -- standalone deriving decl with a wildcard) + -> Maybe (DerivStrategy GhcTc) + -> Maybe (WarningTxt GhcRn) + -> TcRn EarlyDerivSpec +-- Make the EarlyDerivSpec for an instance +-- forall tvs. theta => cls (tys ++ [ty]) +-- where the 'theta' is optional (that's the Maybe part) +-- Assumes that this declaration is well-kinded + +mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat warn = do + is_boot <- tcIsHsBootOrSig + when is_boot $ bale_out DerivErrBootFileFound + + let pred = mkClassPred cls cls_args + skol_info <- mkSkolemInfo (DerivSkol pred) + (tvs', cls_args', deriv_strat') <- + skolemise_when_inferring_context skol_info deriv_ctxt + let deriv_env = DerivEnv + { denv_overlap_mode = overlap_mode + , denv_tvs = tvs' + , denv_cls = cls + , denv_inst_tys = cls_args' + , denv_ctxt = deriv_ctxt + , denv_skol_info = skol_info + , denv_strat = deriv_strat' + , denv_warn = warn } + runReaderT mk_eqn deriv_env + where + skolemise_when_inferring_context :: + SkolemInfo -> DerivContext + -> TcM ([TcTyVar], [TcType], Maybe (DerivStrategy GhcTc)) + skolemise_when_inferring_context skol_info deriv_ctxt = + case deriv_ctxt of + -- In order to infer an instance context, we must later make use of + -- the constraint solving machinery, which expects TcTyVars rather + -- than TyVars. We skolemise the type variables with non-overlappable + -- (vanilla) skolems. + -- See Note [Overlap and deriving] in GHC.Tc.Deriv.Infer. + InferContext{} -> do + (skol_subst, tvs') <- tcInstSkolTyVars skol_info tvs + let cls_args' = substTys skol_subst cls_args + deriv_strat' = fmap (mapDerivStrategy (substTy skol_subst)) + deriv_strat + pure (tvs', cls_args', deriv_strat') + -- If the instance context is supplied, we don't need to skolemise + -- at all. + SupplyContext{} -> pure (tvs, cls_args, deriv_strat) + + bale_out = + failWithTc . TcRnCannotDeriveInstance cls cls_args deriv_strat NoGeneralizedNewtypeDeriving + + mk_eqn :: DerivM EarlyDerivSpec + mk_eqn = do + DerivEnv { denv_inst_tys = cls_args + , denv_strat = mb_strat } <- ask + case mb_strat of + Just (StockStrategy _) -> do + (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args + dit <- expectAlgTyConApp cls_tys inst_ty + mk_eqn_stock dit + + Just (AnyclassStrategy _) -> mk_eqn_anyclass + + Just (ViaStrategy via_ty) -> do + (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args + mk_eqn_via cls_tys inst_ty via_ty + + Just (NewtypeStrategy _) -> do + (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args + dit <- expectAlgTyConApp cls_tys inst_ty + unless (isNewTyCon (dit_rep_tc dit)) $ + derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrGNDUsedOnData + mkNewTypeEqn True dit + + Nothing -> mk_eqn_no_strategy + +-- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty. +-- If so, return @(init inst_tys, last inst_tys)@. +-- Otherwise, throw an error message. +-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this +-- property is important. +expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type) +expectNonNullaryClsArgs inst_tys = + maybe (derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrNullaryClasses) pure $ + snocView inst_tys + +-- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application +-- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting +-- of @cls_tys@ and the constituent pars of @inst_ty@. +-- Otherwise, throw an error message. +-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this +-- property is important. +expectAlgTyConApp :: [Type] -- All but the last argument to the class in a + -- derived instance + -> Type -- The last argument to the class in a + -- derived instance + -> DerivM DerivInstTys +expectAlgTyConApp cls_tys inst_ty = do + fam_envs <- lift tcGetFamInstEnvs + case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of + Nothing -> derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrLastArgMustBeApp + Just dit -> do expectNonDataFamTyCon dit + pure dit + +-- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation +-- type constructor for a data family instance, and if not, +-- throws an error message. +-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this +-- property is important. +expectNonDataFamTyCon :: DerivInstTys -> DerivM () +expectNonDataFamTyCon (DerivInstTys { dit_tc = tc + , dit_tc_args = tc_args + , dit_rep_tc = rep_tc }) = + -- If it's still a data family, the lookup failed; i.e no instance exists + when (isDataFamilyTyCon rep_tc) $ + derivingThingFailWith NoGeneralizedNewtypeDeriving $ + DerivErrNoFamilyInstance tc tc_args + +mk_deriv_inst_tys_maybe :: FamInstEnvs + -> [Type] -> Type -> Maybe DerivInstTys +mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty = + fmap lookup $ tcSplitTyConApp_maybe inst_ty + where + lookup :: (TyCon, [Type]) -> DerivInstTys + lookup (tc, tc_args) = + -- Find the instance of a data family + -- Note [Looking up family instances for deriving] + let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args + dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args + in DerivInstTys { dit_cls_tys = cls_tys + , dit_tc = tc + , dit_tc_args = tc_args + , dit_rep_tc = rep_tc + , dit_rep_tc_args = rep_tc_args + , dit_dc_inst_arg_env = dc_inst_arg_env } + +{- +Note [Looking up family instances for deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcLookupFamInstExact is an auxiliary lookup wrapper which requires +that looked-up family instances exist. If called with a vanilla +tycon, the old type application is simply returned. + +If we have + data instance F () = ... deriving Eq + data instance F () = ... deriving Eq +then tcLookupFamInstExact will be confused by the two matches; +but that can't happen because tcInstDecls1 doesn't call tcDeriving +if there are any overlaps. + +There are two other things that might go wrong with the lookup. +First, we might see a standalone deriving clause + deriving Eq (F ()) +when there is no data instance F () in scope. + +Note that it's OK to have + data instance F [a] = ... + deriving Eq (F [(a,b)]) +where the match is not exact; the same holds for ordinary data types +with standalone deriving declarations. + +Note [Deriving, type families, and partial applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When there are no type families, it's quite easy: + + newtype S a = MkS [a] + -- :CoS :: S ~ [] -- Eta-reduced + + instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) + instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S + +When type families are involved it's trickier: + + data family T a b + newtype instance T Int a = MkT [a] deriving( Eq, Monad ) + -- :RT is the representation type for (T Int a) + -- :Co:RT :: :RT ~ [] -- Eta-reduced! + -- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced! + + instance Eq [a] => Eq (T Int a) -- easy by coercion + -- d1 :: Eq [a] + -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a)) + + instance Monad [] => Monad (T Int) -- only if we can eta reduce??? + -- d1 :: Monad [] + -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) + +Note the need for the eta-reduced rule axioms. After all, we can +write it out + instance Monad [] => Monad (T Int) -- only if we can eta reduce??? + return x = MkT [x] + ... etc ... + +See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + +%************************************************************************ +%* * + Deriving data types +* * +************************************************************************ +-} + +-- Once the DerivSpecMechanism is known, we can finally produce an +-- EarlyDerivSpec from it. +mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec +mk_eqn_from_mechanism mechanism + = do env@(DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys + , denv_ctxt = deriv_ctxt + , denv_skol_info = skol_info + , denv_warn = warn }) <- ask + user_ctxt <- askDerivUserTypeCtxt + doDerivInstErrorChecks1 mechanism + loc <- lift getSrcSpanM + dfun_name <- lift $ newDFunName cls inst_tys loc + case deriv_ctxt of + InferContext wildcard -> + do { (inferred_constraints, tvs', inst_tys', mechanism') + <- inferConstraints mechanism env + ; 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_warn = warn } } + + SupplyContext theta -> + return $ GivenTheta $ DS + { ds_loc = loc + , ds_name = dfun_name, ds_tvs = tvs + , ds_cls = cls, ds_tys = inst_tys + , ds_theta = theta + , ds_skol_info = skol_info + , ds_user_ctxt = user_ctxt + , ds_overlap = overlap_mode + , ds_standalone_wildcard = Nothing + , ds_mechanism = mechanism + , ds_warn = warn } + +mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class + -> DerivM EarlyDerivSpec +mk_eqn_stock dit + = do dflags <- getDynFlags + let isDeriveAnyClassEnabled = + deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) + checkOriginativeSideConditions dit >>= \case + CanDeriveStock gen_fns -> mk_eqn_from_mechanism $ + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fns = gen_fns } + StockClassError why -> derivingThingFailWith NoGeneralizedNewtypeDeriving why + CanDeriveAnyClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving + (DerivErrNotStockDeriveable isDeriveAnyClassEnabled) + -- In the 'NonDerivableClass' case we can't derive with either stock or anyclass + -- so we /don't want/ to suggest the user to enabled 'DeriveAnyClass', that's + -- why we pass 'YesDeriveAnyClassEnabled', so that GHC won't attempt to suggest it. + NonDerivableClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving + (DerivErrNotStockDeriveable YesDeriveAnyClassEnabled) + +mk_eqn_anyclass :: DerivM EarlyDerivSpec +mk_eqn_anyclass + = do dflags <- getDynFlags + let isDeriveAnyClassEnabled = + deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) + case xopt LangExt.DeriveAnyClass dflags of + True -> mk_eqn_from_mechanism DerivSpecAnyClass + False -> derivingThingFailWith NoGeneralizedNewtypeDeriving + (DerivErrNotDeriveable isDeriveAnyClassEnabled) + +mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class + -> Type -- The newtype's representation type + -> DerivM EarlyDerivSpec +mk_eqn_newtype dit rep_ty = + mk_eqn_from_mechanism $ DerivSpecNewtype { dsm_newtype_dit = dit + , dsm_newtype_rep_ty = rep_ty } + +mk_eqn_via :: [Type] -- All arguments to the class besides the last + -> Type -- The last argument to the class + -> Type -- The @via@ type + -> DerivM EarlyDerivSpec +mk_eqn_via cls_tys inst_ty via_ty = + mk_eqn_from_mechanism $ DerivSpecVia { dsm_via_cls_tys = cls_tys + , dsm_via_inst_ty = inst_ty + , dsm_via_ty = via_ty } + +-- Derive an instance without a user-requested deriving strategy. This uses +-- heuristics to determine which deriving strategy to use. +-- See Note [Deriving strategies]. +mk_eqn_no_strategy :: DerivM EarlyDerivSpec +mk_eqn_no_strategy = do + DerivEnv { denv_cls = cls + , denv_inst_tys = cls_args } <- ask + fam_envs <- lift tcGetFamInstEnvs + + -- First, check if the last argument is an application of a type constructor. + -- If not, fall back to DeriveAnyClass. + if | Just (cls_tys, inst_ty) <- snocView cls_args + , Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty + -> if | isNewTyCon (dit_rep_tc dit) + -- We have a dedicated code path for newtypes (see the + -- documentation for mkNewTypeEqn as to why this is the case) + -> mkNewTypeEqn False dit + + | otherwise + -> do -- Otherwise, our only other options are stock or anyclass. + -- If it is stock, we must confirm that the last argument's + -- type constructor is algebraic. + -- See Note [DerivEnv and DerivSpecMechanism] in GHC.Tc.Deriv.Utils + whenIsJust (hasStockDeriving cls) $ \_ -> + expectNonDataFamTyCon dit + mk_eqn_originative cls dit + + | otherwise + -> mk_eqn_anyclass + where + -- Use heuristics (checkOriginativeSideConditions) to determine whether + -- stock or anyclass deriving should be used. + mk_eqn_originative :: Class -> DerivInstTys -> DerivM EarlyDerivSpec + mk_eqn_originative cls dit@(DerivInstTys { dit_tc = tc + , dit_rep_tc = rep_tc }) = do + dflags <- getDynFlags + let isDeriveAnyClassEnabled + | canSafelyDeriveAnyClass cls + = deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) + | otherwise + -- Pretend that the extension is enabled so that we won't suggest + -- enabling it. + = YesDeriveAnyClassEnabled + + -- See Note [Deriving instances for classes themselves] + let dac_error + | isClassTyCon rep_tc + = DerivErrOnlyAnyClassDeriveable tc isDeriveAnyClassEnabled + | otherwise + = DerivErrNotStockDeriveable isDeriveAnyClassEnabled + + checkOriginativeSideConditions dit >>= \case + NonDerivableClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving dac_error + StockClassError why -> derivingThingFailWith NoGeneralizedNewtypeDeriving why + CanDeriveStock gen_fns -> mk_eqn_from_mechanism $ + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fns = gen_fns } + CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass + + canSafelyDeriveAnyClass cls = + -- If the set of minimal required definitions is nonempty, + -- `DeriveAnyClass` will generate an instance with undefined methods or + -- associated types, so don't suggest enabling it. + isNothing $ isUnsatisfied (const False) (classMinimalDef cls) + +{- +************************************************************************ +* * + Deriving instances for newtypes +* * +************************************************************************ +-} + +-- Derive an instance for a newtype. We put this logic into its own function +-- because +-- +-- (a) When no explicit deriving strategy is requested, we have special +-- heuristics for newtypes to determine which deriving strategy should +-- actually be used. See Note [Deriving strategies]. +-- (b) We make an effort to give error messages specifically tailored to +-- newtypes. +mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@ + -- deriving strategy? + -> DerivInstTys -> DerivM EarlyDerivSpec +mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys + , dit_rep_tc = rep_tycon + , dit_rep_tc_args = rep_tc_args }) +-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... + = do DerivEnv{denv_cls = cls} <- ask + dflags <- getDynFlags + + let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags + deriveAnyClass = xopt LangExt.DeriveAnyClass dflags + + bale_out = derivingThingFailWith (usingGeneralizedNewtypeDeriving newtype_deriving) + + -- Here is the plan for newtype derivings. We see + -- newtype T a1...an = MkT (t ak+1...an) + -- deriving (.., C s1 .. sm, ...) + -- where t is a type, + -- ak+1...an is a suffix of a1..an, and are all tyvars + -- ak+1...an do not occur free in t, nor in the s1..sm + -- (C s1 ... sm) is a *partial applications* of class C + -- with the last parameter missing + -- (T a1 .. ak) matches the kind of C's last argument + -- (and hence so does t) + -- The latter kind-check has been done by deriveTyData already, + -- and tc_args are already trimmed + -- + -- We generate the instance + -- instance forall ({a1..ak} u fvs(s1..sm)). + -- C s1 .. sm t => C s1 .. sm (T a1...ak) + -- where T a1...ap is the partial application of + -- the LHS of the correct kind and p >= k + -- + -- NB: the variables below are: + -- tc_tvs = [a1, ..., an] + -- tyvars_to_keep = [a1, ..., ak] + -- rep_ty = t ak .. an + -- deriv_tvs = fvs(s1..sm) \ tc_tvs + -- tys = [s1, ..., sm] + -- rep_fn' = t + -- + -- Running example: newtype T s a = MkT (ST s a) deriving( Monad ) + -- We generate the instance + -- instance Monad (ST s) => Monad (T s) where + + nt_eta_arity = newTyConEtadArity rep_tycon + -- For newtype T a b = MkT (S a a b), the TyCon + -- machinery already eta-reduces the representation type, so + -- we know that + -- T a ~ S a a + -- That's convenient here, because we may have to apply + -- it to fewer than its original complement of arguments + + -- Note [Newtype representation] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Need newTyConRhs (*not* a recursive representation finder) + -- to get the representation type. For example + -- newtype B = MkB Int + -- newtype A = MkA B deriving( Num ) + -- We want the Num instance of B, *not* the Num instance of Int, + -- when making the Num instance of A! + rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args + + ------------------------------------------------------------------- + -- Figuring out whether we can only do this newtype-deriving thing + + -- See Note [Determining whether newtype-deriving is appropriate] + might_be_newtype_derivable + = not (non_coercible_class cls) + && eta_ok +-- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] + + -- Check that eta reduction is OK + eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity + -- The newtype can be eta-reduced to match the number + -- of type argument actually supplied + -- newtype T a b = MkT (S [a] b) deriving( Monad ) + -- Here the 'b' must be the same in the rep type (S [a] b) + -- And the [a] must not mention 'b'. That's all handled + -- by nt_eta_rity. + + massert (cls_tys `lengthIs` (classArity cls - 1)) + if newtype_strat + then + -- Since the user explicitly asked for GeneralizedNewtypeDeriving, + -- we don't need to perform all of the checks we normally would, + -- such as if the class being derived is known to produce ill-roled + -- coercions (e.g., Traversable), since we can just derive the + -- instance and let it error if need be. + -- See Note [Determining whether newtype-deriving is appropriate] + if eta_ok && newtype_deriving + then mk_eqn_newtype dit rep_inst_ty + else bale_out (DerivErrCannotEtaReduceEnough eta_ok) + else + if might_be_newtype_derivable + && ((newtype_deriving && not deriveAnyClass) + || std_class_via_coercible cls) + then mk_eqn_newtype dit rep_inst_ty + else checkOriginativeSideConditions dit >>= \case + StockClassError why + -- There's a particular corner case where + -- + -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are + -- both enabled at the same time + -- 2. We're deriving a particular stock derivable class + -- (such as Functor) + -- + -- and the previous cases won't catch it. This fixes the bug + -- reported in #10598. + | might_be_newtype_derivable && newtype_deriving + -> mk_eqn_newtype dit rep_inst_ty + -- Otherwise, throw an error for a stock class + | might_be_newtype_derivable && not newtype_deriving + -> bale_out why + | otherwise + -> bale_out why + + -- Must use newtype deriving or DeriveAnyClass + NonDerivableClass + -- Too hard, even with newtype deriving + | newtype_deriving -> bale_out (DerivErrCannotEtaReduceEnough eta_ok) + -- Try newtype deriving! + -- Here we suggest GeneralizedNewtypeDeriving even in cases + -- where it may not be applicable. See #9600. + | otherwise -> bale_out DerivErrNewtypeNonDeriveableClass + + -- DeriveAnyClass + CanDeriveAnyClass -> do + -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are + -- enabled, we take the diplomatic approach of defaulting to + -- DeriveAnyClass, but emitting a warning about the choice. + -- See Note [Deriving strategies] + when (newtype_deriving && deriveAnyClass) $ + lift $ addDiagnosticTc + $ TcRnDerivingDefaults cls + mk_eqn_from_mechanism DerivSpecAnyClass + -- CanDeriveStock + CanDeriveStock gen_fns -> mk_eqn_from_mechanism $ + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fns = gen_fns } + +{- +Note [Recursive newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Newtype deriving works fine, even if the newtype is recursive. +e.g. newtype S1 = S1 [T1 ()] + newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad ) +Remember, too, that type families are currently (conservatively) given +a recursive flag, so this also allows newtype deriving to work +for type families. + +We used to exclude recursive types, because we had a rather simple +minded way of generating the instance decl: + newtype A = MkA [A] + instance Eq [A] => Eq A -- Makes typechecker loop! +But now we require a simple context, so it's ok. + +Note [Determining whether newtype-deriving is appropriate] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see + newtype NT = MkNT Foo + deriving C +we have to decide how to perform the deriving. Do we do newtype deriving, +or do we do normal deriving? In general, we prefer to do newtype deriving +wherever possible. So, we try newtype deriving unless there's a glaring +reason not to. + +"Glaring reasons not to" include trying to derive a class for which a +coercion-based instance doesn't make sense. These classes are listed in +the definition of non_coercible_class. They include Show (since it must +show the name of the datatype) and Traversable (since a coercion-based +Traversable instance is ill-roled). + +However, non_coercible_class is ignored if the user explicitly requests +to derive an instance with GeneralizedNewtypeDeriving using the newtype +deriving strategy. In such a scenario, GHC will unquestioningly try to +derive the instance via coercions (even if the final generated code is +ill-roled!). See Note [Deriving strategies]. + +Note that newtype deriving might fail, even after we commit to it. This +is because the derived instance uses `coerce`, which must satisfy its +`Coercible` constraint. This is different than other deriving scenarios, +where we're sure that the resulting instance will type-check. + +Note [GND and associated type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for +classes with associated type families. A general recipe is: + + class C x y z where + type T y z x + op :: x -> [y] -> z + + newtype N a = MkN deriving( C ) + + =====> + + instance C x y => C x y (N a) where + type T y (N a) x = T y x + op = coerce (op :: x -> [y] -> ) + +However, we must watch out for three things: + +(a) The class must not contain any data families. If it did, we'd have to + generate a fresh data constructor name for the derived data family + instance, and it's not clear how to do this. + +(b) Each associated type family's type variables must mention the last type + variable of the class. As an example, you wouldn't be able to use GND to + derive an instance of this class: + + class C a b where + type T a + + But you would be able to derive an instance of this class: + + class C a b where + type T b + + The difference is that in the latter T mentions the last parameter of C + (i.e., it mentions b), but the former T does not. If you tried, e.g., + + newtype Foo x = Foo x deriving (C a) + + with the former definition of C, you'd end up with something like this: + + instance C a (Foo x) where + type T a = T ??? + + This T family instance doesn't mention the newtype (or its representation + type) at all, so we disallow such constructions with GND. + +(c) UndecidableInstances might need to be enabled. Here's a case where it is + most definitely necessary: + + class C a where + type T a + newtype Loop = Loop MkLoop deriving C + + =====> + + instance C Loop where + type T Loop = T Loop + + Obviously, T Loop would send the typechecker into a loop. Unfortunately, + you might even need UndecidableInstances even in cases where the + typechecker would be guaranteed to terminate. For example: + + instance C Int where + type C Int = Int + newtype MyInt = MyInt Int deriving C + + =====> + + instance C MyInt where + type T MyInt = T Int + + GHC's termination checker isn't sophisticated enough to conclude that the + definition of T MyInt terminates, so UndecidableInstances is required. + +(d) For the time being, we do not allow the last type variable of the class to + appear in a /kind/ of an associated type family definition. For instance: + + class C a where + type T1 a -- OK + type T2 (x :: a) -- Illegal: a appears in the kind of x + type T3 y :: a -- Illegal: a appears in the kind of (T3 y) + + The reason we disallow this is because our current approach to deriving + associated type family instances—i.e., by unwrapping the newtype's type + constructor as shown above—is ill-equipped to handle the scenario when + the last type variable appears as an implicit argument. In the worst case, + allowing the last variable to appear in a kind can result in improper Core + being generated (see #14728). + + There is hope for this feature being added some day, as one could + conceivably take a newtype axiom (which witnesses a coercion between a + newtype and its representation type) at lift that through each associated + type at the Core level. See #14728, comment:3 for a sketch of how this + might work. Until then, we disallow this featurette wholesale. + +The same criteria apply to DerivingVia. + +************************************************************************ +* * +Bindings for the various classes +* * +************************************************************************ + +After all the trouble to figure out the required context for the +derived instance declarations, all that's left is to chug along to +produce them. They will then be shoved into @tcInstDecls2@, which +will do all its usual business. + +There are lots of possibilities for code to generate. Here are +various general remarks. + +PRINCIPLES: +\begin{itemize} +\item +We want derived instances of @Eq@ and @Ord@ (both v common) to be +``you-couldn't-do-better-by-hand'' efficient. + +\item +Deriving @Show@---also pretty common--- should also be reasonable good code. + +\item +Deriving for the other classes isn't that common or that big a deal. +\end{itemize} + +PRAGMATICS: + +\begin{itemize} +\item +Deriving @Ord@ is done mostly with the 1.3 @compare@ method. + +\item +Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too. + +\item +We {\em normally} generate code only for the non-defaulted methods; +there are some exceptions for @Eq@ and (especially) @Ord@... + +\item +Sometimes we use a @_con2tag_@ function, which returns a data +constructor's numeric (@Int#@) tag. These are generated by +@gen_tag_n_con_binds@, and the heuristic for deciding if one of +these is around is given by @hasCon2TagFun@. + +The examples under the different sections below will make this +clearer. + +\item +Much less often (really just for deriving @Ix@), we use a +@_tag2con_@ function. See the examples. + +\item +We use the renamer!!! Reason: we're supposed to be +producing @LHsBinds Name@ for the methods, but that means +producing correctly-uniquified code on the fly. This is entirely +possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. +So, instead, we produce @MonoBinds RdrName@ then heave 'em through +the renamer. What a great hack! +\end{itemize} +-} + +-- | Generate the 'InstInfo' for the required instance, +-- plus any auxiliary bindings required (see @Note [Auxiliary binders]@ in +-- "GHC.Tc.Deriv.Generate") and any additional free variables +-- that should be marked (see @Note [Deriving and unused record selectors]@ +-- in "GHC.Tc.Deriv.Utils"). +genInstBinds :: DerivSpec ThetaType + -> TcM (InstInfo GhcPs, Bag AuxBindSpec, [Name]) +genInstBinds spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism + , ds_tys = inst_tys, ds_theta = theta, ds_cls = clas + , ds_loc = loc, ds_standalone_wildcard = wildcard }) + = set_spec_span_and_ctxt spec $ + do (meth_binds, meth_sigs, aux_specs, unusedNames) <- gen_inst_binds + inst_spec <- newDerivClsInst spec + doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism + traceTc "newder" (ppr inst_spec) + let inst_info = + InstInfo + { iSpec = inst_spec + , iBinds = InstBindings + { ib_binds = meth_binds + , ib_tyvars = map Var.varName tyvars + , ib_pragmas = meth_sigs + , ib_extensions = extensions + , ib_derived = True } } + return (inst_info, aux_specs, unusedNames) + where + extensions :: [LangExt.Extension] + extensions + | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism + = [ + -- Both these flags are needed for higher-rank uses of coerce + -- See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate + LangExt.ImpredicativeTypes, LangExt.RankNTypes + -- Skip unboxed tuples checking for derived instances when imported + -- in a different module, see #20524 + , LangExt.UnboxedTuples + ] + | otherwise + = [] + + gen_inst_binds :: TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name]) + gen_inst_binds + = case mechanism of + -- See Note [Bindings for Generalised Newtype Deriving] + DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty} + -> gen_newtype_or_via rhs_ty + + -- Try a stock deriver + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fns = + StockGenFns { stock_gen_binds = gen_fn } } + -> gen_fn loc dit + + -- Try DeriveAnyClass + DerivSpecAnyClass + -> return ([], [], emptyBag, []) + -- 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 = gen_Newtype_binds loc clas tyvars inst_tys ty + return (binds, [], emptyBag, []) + +-- | Generate the associated type family instances for a derived instance. +genFamInsts :: DerivSpec theta -> TcM [FamInst] +genFamInsts spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism + , ds_tys = inst_tys, ds_cls = clas, ds_loc = loc }) + = set_spec_span_and_ctxt spec $ + case mechanism of + -- See Note [GND and associated type families] + DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty} + -> gen_newtype_or_via rhs_ty + + -- Try a stock deriver + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fns = + StockGenFns { stock_gen_fam_insts = gen_fn } } + -> gen_fn loc dit + + -- See Note [DeriveAnyClass and default family instances] + DerivSpecAnyClass -> do + let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) + mini_subst = mkTvSubst (mkInScopeSetList tyvars) mini_env + dflags <- getDynFlags + tyfam_insts <- + -- canDeriveAnyClass should ensure that this code can't be reached + -- unless -XDeriveAnyClass is enabled. + assertPpr (xopt LangExt.DeriveAnyClass dflags) + (text "genFamInsts: bad derived class" <+> ppr clas) $ + mapM (tcATDefault loc mini_subst emptyNameSet) + (classATItems clas) + pure $ concat tyfam_insts + + -- Try DerivingVia + DerivSpecVia{dsm_via_ty = via_ty} + -> gen_newtype_or_via via_ty + where + gen_newtype_or_via ty = gen_Newtype_fam_insts loc clas tyvars inst_tys ty + +-- Set the SrcSpan and error context for an action that uses a DerivSpec. +set_spec_span_and_ctxt :: DerivSpec theta -> TcM a -> TcM a +set_spec_span_and_ctxt (DS{ ds_loc = loc, ds_cls = clas, ds_tys = tys }) = + setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys) + +-- Checks: +-- +-- * All of the data constructors for a data type are in scope for a +-- standalone-derived instance (for `stock` and `newtype` deriving). +-- +-- * All of the associated type families of a class are suitable for +-- GeneralizedNewtypeDeriving or DerivingVia (for `newtype` and `via` +-- deriving). +doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM () +doDerivInstErrorChecks1 mechanism = + case mechanism of + DerivSpecStock{dsm_stock_dit = dit} + -> data_cons_in_scope_check dit + -- No need to 'data_cons_in_scope_check' for newtype deriving. + -- Additionally, we also don't need to mark the constructors as + -- used because newtypes are handled separately elsewhere. + -- See Note [Tracking unused binding and imports] in GHC.Tc.Types + -- or #17328 for more. + DerivSpecNewtype{} + -> atf_coerce_based_error_checks + DerivSpecAnyClass{} + -> pure () + DerivSpecVia{} + -> atf_coerce_based_error_checks + where + -- When processing a standalone deriving declaration, check that all of the + -- constructors for the data type are in scope. For instance: + -- + -- import M (T) + -- deriving stock instance Eq T + -- + -- This should be rejected, as the derived Eq instance would need to refer + -- to the constructors for T, which are not in scope. + -- + -- Note that the only strategies that require this check are `stock` and + -- `newtype`. Neither `anyclass` nor `via` require it as the code that they + -- generate does not require using data constructors. + data_cons_in_scope_check :: DerivInstTys -> DerivM () + data_cons_in_scope_check (DerivInstTys { dit_tc = tc + , dit_rep_tc = rep_tc }) = do + standalone <- isStandaloneDeriv + when standalone $ do + let bale_out msg = do err <- derivingThingErrMechanism mechanism msg + lift $ failWithTc err + + rdr_env <- lift getGlobalRdrEnv + let data_con_names = map dataConName (tyConDataCons rep_tc) + hidden_data_cons = not (isWiredIn rep_tc) && + (isAbstractTyCon rep_tc || + any not_in_scope data_con_names) + not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc) + + -- Make sure to also mark the data constructors as used so that GHC won't + -- mistakenly emit -Wunused-imports warnings about them. + lift $ addUsedDataCons rdr_env rep_tc + + unless (not hidden_data_cons) $ + bale_out $ DerivErrDataConsNotAllInScope tc + + -- Ensure that a class's associated type variables are suitable for + -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is + -- only required for the `newtype` and `via` strategies. + -- + -- See Note [GND and associated type families] + atf_coerce_based_error_checks :: DerivM () + atf_coerce_based_error_checks = do + cls <- asks denv_cls + let bale_out msg = do err <- derivingThingErrMechanism mechanism msg + lift $ failWithTc err + + cls_tyvars = classTyVars cls + + ats_look_sensible + = -- Check (a) from Note [GND and associated type families] + no_adfs + -- Check (b) from Note [GND and associated type families] + && isNothing at_without_last_cls_tv + -- Check (d) from Note [GND and associated type families] + && isNothing at_last_cls_tv_in_kinds + + (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs + no_adfs = null adf_tcs + -- We cannot newtype-derive data family instances + + at_without_last_cls_tv + = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs + at_last_cls_tv_in_kinds + = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind) + (tyConTyVars tc) + || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs + at_last_cls_tv_in_kind kind + = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind + at_tcs = classATs cls + last_cls_tv = assert (notNull cls_tyvars ) + last cls_tyvars + + unless ats_look_sensible $ + bale_out (DerivErrHasAssociatedDatatypes + (hasAssociatedDataFamInsts (not no_adfs)) + (associatedTyLastVarInKind at_last_cls_tv_in_kinds) + (associatedTyNotParamOverLastTyVar at_without_last_cls_tv) + ) + +doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan + -> DerivSpecMechanism -> TcM () +doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism + = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst) + ; dflags <- getDynFlags + ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures + ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures + + -- Error if PartialTypeSignatures isn't enabled when a user tries + -- to write @deriving instance _ => Eq (Foo a)@. Or, if that + -- extension is enabled, give a warning if -Wpartial-type-signatures + -- is enabled. + ; case wildcard of + Nothing -> pure () + Just span -> setSrcSpan span $ do + let suggParSigs = suggestPartialTypeSignatures xpartial_sigs + let dia = TcRnPartialTypeSignatures suggParSigs theta + checkTc xpartial_sigs dia + diagnosticTc wpartial_sigs dia + + -- Check for Generic instances that are derived with an exotic + -- deriving strategy like DAC + -- See Note [Deriving strategies] + ; when (exotic_mechanism && className clas `elem` genericClassNames) $ + do { failIfTc (safeLanguageOn dflags) + (TcRnCannotDeriveInstance clas mempty Nothing NoGeneralizedNewtypeDeriving $ + DerivErrSafeHaskellGenericInst) + ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } } + where + exotic_mechanism = not $ isDerivSpecStock mechanism + +derivingThingFailWith :: UsingGeneralizedNewtypeDeriving + -- ^ If 'YesGeneralizedNewtypeDeriving', add a snippet about + -- how not even GeneralizedNewtypeDeriving would make this + -- declaration work. This only kicks in when + -- an explicit deriving strategy is not given. + -> DeriveInstanceErrReason -- The reason the derivation failed + -> DerivM a +derivingThingFailWith newtype_deriving msg = do + err <- derivingThingErrM newtype_deriving msg + lift $ failWithTc err + +{- +Note [Bindings for Generalised Newtype Deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class Eq a => C a where + f :: a -> a + newtype N a = MkN [a] deriving( C ) + instance Eq (N a) where ... + +The 'deriving C' clause generates, in effect + instance (C [a], Eq a) => C (N a) where + f = coerce (f :: [a] -> [a]) + +This generates a cast for each method, but allows the superclasses to +be worked out in the usual way. In this case the superclass (Eq (N +a)) will be solved by the explicit Eq (N a) instance. We do *not* +create the superclasses by casting the superclass dictionaries for the +representation type. + +See the paper "Safe zero-cost coercions for Haskell". + +Note [DeriveAnyClass and default family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When a class has a associated type family with a default instance, e.g.: + + class C a where + type T a + type T a = Char + +then there are a couple of scenarios in which a user would expect T a to +default to Char. One is when an instance declaration for C is given without +an implementation for T: + + instance C Int + +Another scenario in which this can occur is when the -XDeriveAnyClass extension +is used: + + data Example = Example deriving (C, Generic) + +In the latter case, we must take care to check if C has any associated type +families with default instances, because -XDeriveAnyClass will never provide +an implementation for them. We "fill in" the default instances using the +tcATDefault function from GHC.Tc.TyCl.Class (which is also used in GHC.Tc.TyCl.Instance to +handle the empty instance declaration case). + +Note [Deriving strategies] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has a notion of deriving strategies, which allow the user to explicitly +request which approach to use when deriving an instance (enabled with the +-XDerivingStrategies language extension). For more information, refer to the +original issue (#10598) or the associated wiki page: +https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies + +A deriving strategy can be specified in a deriving clause: + + newtype Foo = MkFoo Bar + deriving newtype C + +Or in a standalone deriving declaration: + + deriving anyclass instance C Foo + +-XDerivingStrategies also allows the use of multiple deriving clauses per data +declaration so that a user can derive some instance with one deriving strategy +and other instances with another deriving strategy. For example: + + newtype Baz = Baz Quux + deriving (Eq, Ord) + deriving stock (Read, Show) + deriving newtype (Num, Floating) + deriving anyclass C + +Currently, the deriving strategies are: + +* stock: Have GHC implement a "standard" instance for a data type, if possible + (e.g., Eq, Ord, Generic, Data, Functor, etc.) + +* anyclass: Use -XDeriveAnyClass + +* newtype: Use -XGeneralizedNewtypeDeriving + +* via: Use -XDerivingVia + +The latter two strategies (newtype and via) are referred to as the +"coerce-based" strategies, since they generate code that relies on the `coerce` +function. See, for instance, GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased. + +The former two strategies (stock and anyclass), in contrast, are +referred to as the "originative" strategies, since they create "original" +instances instead of "reusing" old instances (by way of `coerce`). +See, for instance, GHC.Tc.Deriv.Utils.checkOriginativeSideConditions. + +If an explicit deriving strategy is not given, GHC has an algorithm it uses to +determine which strategy it will actually use. The algorithm is quite long, +so it lives in the Haskell wiki at +https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies +("The deriving strategy resolution algorithm" section). + +Internally, GHC uses the DerivStrategy datatype to denote a user-requested +deriving strategy, and it uses the DerivSpecMechanism datatype to denote what +GHC will use to derive the instance after taking the above steps. In other +words, GHC will always settle on a DerivSpecMechnism, even if the user did not +ask for a particular DerivStrategy (using the algorithm linked to above). + +Note [Deriving instances for classes themselves] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Much of the code in GHC.Tc.Deriv assumes that deriving only works on data types. +But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly +reasonable to do something like this: + + {-# LANGUAGE DeriveAnyClass #-} + class C1 (a :: Constraint) where + class C2 where + deriving instance C1 C2 + -- This is equivalent to `instance C1 C2` + +If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock +deriving), we throw a special error message indicating that DeriveAnyClass is +the only way to go. We don't bother throwing this error if an explicit 'stock' +or 'newtype' keyword is used, since both options have their own perfectly +sensible error messages in the case of the above code (as C1 isn't a stock +derivable class, and C2 isn't a newtype). + +************************************************************************ +* * +What con2tag/tag2con functions are available? +* * +************************************************************************ +-} + +derivingThingErrM :: UsingGeneralizedNewtypeDeriving + -> DeriveInstanceErrReason + -> DerivM TcRnMessage +derivingThingErrM newtype_deriving why + = do DerivEnv { denv_cls = cls + , denv_inst_tys = cls_args + , denv_strat = mb_strat } <- ask + pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why + +derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage +derivingThingErrMechanism mechanism why + = do DerivEnv { denv_cls = cls + , denv_inst_tys = cls_args + , denv_strat = mb_strat } <- ask + pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why + where + newtype_deriving :: UsingGeneralizedNewtypeDeriving + newtype_deriving + = if isDerivSpecNewtype mechanism then YesGeneralizedNewtypeDeriving + else NoGeneralizedNewtypeDeriving + diff --git a/GHC/Tc/Deriv/Functor.hs b/GHC/Tc/Deriv/Functor.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv/Functor.hs @@ -0,0 +1,1481 @@ +{- +(c) The University of Glasgow 2011 + +-} + + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} + +-- | The deriving code for the Functor, Foldable, and Traversable classes +module GHC.Tc.Deriv.Functor + ( FFoldType(..) + , functorLikeTraverse + , deepSubtypesContaining + , foldDataConArgs + + , gen_Functor_binds + , gen_Foldable_binds + , gen_Traversable_binds + ) +where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Core.DataCon +import GHC.Data.FastString +import GHC.Hs +import GHC.Utils.Panic +import GHC.Builtin.Names +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import GHC.Utils.Monad.State.Strict +import GHC.Tc.Deriv.Generate +import GHC.Tc.Utils.TcType +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Id.Make (coerceId) +import GHC.Builtin.Types (true_RDR, false_RDR) +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf + +import Data.Foldable +import Data.Maybe (catMaybes, isJust) + +{- +************************************************************************ +* * + Functor instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + +* * +************************************************************************ + +For the data type: + + data T a = T1 Int a | T2 (T a) + +We generate the instance: + + instance Functor T where + fmap f (T1 b1 a) = T1 b1 (f a) + fmap f (T2 ta) = T2 (fmap f ta) + +Notice that we don't simply apply 'fmap' to the constructor arguments. +Rather + - Do nothing to an argument whose type doesn't mention 'a' + - Apply 'f' to an argument of type 'a' + - Apply 'fmap f' to other arguments +That's why we have to recurse deeply into the constructor argument types, +rather than just one level, as we typically do. + +What about types with more than one type parameter? In general, we only +derive Functor for the last position: + + data S a b = S1 [b] | S2 (a, T a b) + instance Functor (S a) where + fmap f (S1 bs) = S1 (fmap f bs) + fmap f (S2 (p,q)) = S2 (a, fmap f q) + +However, we have special cases for + - tuples + - functions + +More formally, we write the derivation of fmap code over type variable +'a for type 'b as ($fmap 'a 'b x). In this general notation the derived +instance for T is: + + instance Functor T where + fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2) + fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1) + + $(fmap 'a 'b x) = x -- when b does not contain a + $(fmap 'a 'a x) = f x + $(fmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(fmap 'a 'b1 x1), $(fmap 'a 'b2 x2)) + $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(fmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(fmap 'a' 'tc' (x $(cofmap 'a 'tb y))) + +For functions, the type parameter 'a can occur in a contravariant position, +which means we need to derive a function like: + + cofmap :: (a -> b) -> (f b -> f a) + +This is pretty much the same as $fmap, only without the $(cofmap 'a 'a x) and +$(cofmap 'a '(T b1 a) x) cases: + + $(cofmap 'a 'b x) = x -- when b does not contain a + $(cofmap 'a 'a x) = error "type variable in contravariant position" + $(cofmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2) + $(cofmap 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T + $(cofmap 'a '(T b1 b2) x) = fmap (\y. $(cofmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(cofmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(cofmap 'a' 'tc' (x $(fmap 'a 'tb y))) + +Note that the code produced by $(fmap _ _ _) is always a higher order function, +with type `(a -> b) -> (g a -> g b)` for some g. + +Note that there are two distinct cases in $fmap (and $cofmap) that match on an +application of some type constructor T (where T is not a tuple type +constructor): + + $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + +While the latter case technically subsumes the former case, it is important to +give special treatment to the former case to avoid unnecessary eta expansion. +See Note [Avoid unnecessary eta expansion in derived fmap implementations]. + +We also generate code for (<$) in addition to fmap—see Note [Deriving <$] for +an explanation of why this is important. Just like $fmap/$cofmap above, there +is a similar algorithm for generating `p <$ x` (for some constant `p`): + + $(replace 'a 'b x) = x -- when b does not contain a + $(replace 'a 'a x) = p + $(replace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(replace 'a 'b1 x1), $(replace 'a 'b2 x2)) + $(replace 'a '(T b1 a) x) = p <$ x -- when a only occurs directly as the last argument of T + $(replace 'a '(T b1 b2) x) = fmap (\y. $(replace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(replace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(replace 'a' 'tc' (x $(coreplace 'a 'tb y))) + + $(coreplace 'a 'b x) = x -- when b does not contain a + $(coreplace 'a 'a x) = error "type variable in contravariant position" + $(coreplace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(coreplace 'a 'b1 x1), $(coreplace 'a 'b2 x2)) + $(coreplace 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T + $(coreplace 'a '(T b1 b2) x) = fmap (\y. $(coreplace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) +-} + +gen_Functor_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) +-- When the argument is phantom, we can use fmap _ = coerce +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Functor_binds loc (DerivInstTys{dit_rep_tc = tycon}) + | Phantom <- last (tyConRoles tycon) + = ([fmap_bind], emptyBag) + where + fmap_name = L (noAnnSrcSpan loc) fmap_RDR + fmap_bind = mkRdrFunBind fmap_name fmap_eqns + fmap_eqns = [mkSimpleMatch fmap_match_ctxt + (noLocA [nlWildPat]) + coerce_Expr] + fmap_match_ctxt = mkPrefixFunRhs fmap_name noAnn + +gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon + , dit_rep_tc_args = tycon_args }) + = ([fmap_bind, replace_bind], emptyBag) + where + data_cons = getPossibleDataCons tycon tycon_args + fmap_name = L (noAnnSrcSpan loc) fmap_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns + fmap_match_ctxt = mkPrefixFunRhs fmap_name noAnn + + fmap_eqn con = flip evalState bs_RDRs $ + match_for_con fmap_match_ctxt [f_Pat] con parts + where + parts = foldDataConArgs ft_fmap con dit + + fmap_eqns = map fmap_eqn data_cons + + ft_fmap :: FFoldType (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs)) + ft_fmap = FT { ft_triv = \x -> pure x + -- fmap f x = x + , ft_var = \x -> pure $ nlHsApp f_Expr x + -- fmap f x = f x + , ft_fun = \g h x -> mkSimpleLam $ \b -> do + gg <- g b + h $ nlHsApp x gg + -- fmap f x = \b -> h (x (g b)) + , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt) + -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) + , ft_ty_app = \_ arg_ty g x -> + -- If the argument type is a bare occurrence of the + -- data type's last type variable, then we can generate + -- more efficient code. + -- See Note [Avoid unnecessary eta expansion in derived fmap implementations] + if tcIsTyVarTy arg_ty + then pure $ nlHsApps fmap_RDR [f_Expr,x] + else do gg <- mkSimpleLam g + pure $ nlHsApps fmap_RDR [gg,x] + -- fmap f x = fmap g x + , ft_forall = \_ g x -> g x + , ft_bad_app = panic "in other argument in ft_fmap" + , ft_co_var = panic "contravariant in ft_fmap" } + + -- See Note [Deriving <$] + replace_name = L (noAnnSrcSpan loc) replace_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns + replace_match_ctxt = mkPrefixFunRhs replace_name noAnn + + replace_eqn con = flip evalState bs_RDRs $ + match_for_con replace_match_ctxt [z_Pat] con parts + where + parts = foldDataConArgs ft_replace con dit + + replace_eqns = map replace_eqn data_cons + + ft_replace :: FFoldType (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs)) + ft_replace = FT { ft_triv = \x -> pure x + -- p <$ x = x + , ft_var = \_ -> pure z_Expr + -- p <$ _ = p + , ft_fun = \g h x -> mkSimpleLam $ \b -> do + gg <- g b + h $ nlHsApp x gg + -- p <$ x = \b -> h (x (g b)) + , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt) + -- p <$ x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) + , ft_ty_app = \_ arg_ty g x -> + -- If the argument type is a bare occurrence of the + -- data type's last type variable, then we can generate + -- more efficient code. + -- See [Deriving <$] + if tcIsTyVarTy arg_ty + then pure $ nlHsApps replace_RDR [z_Expr,x] + else do gg <- mkSimpleLam g + pure $ nlHsApps fmap_RDR [gg,x] + -- p <$ x = fmap (p <$) x + , ft_forall = \_ g x -> g x + , ft_bad_app = panic "in other argument in ft_replace" + , ft_co_var = panic "contravariant in ft_replace" } + + -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... + match_for_con :: Monad m + => HsMatchContextPs + -> [LPat GhcPs] -> DataCon + -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_for_con ctxt = mkSimpleConMatch ctxt $ + \con_name xsM -> do xs <- sequence xsM + pure $ nlHsApps con_name xs -- Con x1 x2 .. + +{- +Note [Avoid unnecessary eta expansion in derived fmap implementations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the sake of simplicity, the algorithm that derived implementations of +fmap used to have a single case that dealt with applications of some type +constructor T (where T is not a tuple type constructor): + + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + +This generated less than optimal code in certain situations, however. Consider +this example: + + data List a = Nil | Cons a (List a) deriving Functor + +This would generate the following Functor instance: + + instance Functor List where + fmap f Nil = Nil + fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs) + +The code `fmap (\y -> f y) xs` is peculiar, since it eta expands an application +of `f`. What's worse, this eta expansion actually degrades performance! To see +why, we can trace an invocation of fmap on a small List: + + fmap id $ Cons 0 $ Cons 0 $ Cons 0 $ Cons 0 Nil + + Cons (id 0) $ fmap (\y -> id y) + $ Cons 0 $ Cons 0 $ Cons 0 Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ fmap (\y' -> (\y -> id y) y') + $ Cons 0 $ Cons 0 Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ Cons ((\y' -> (\y -> id y) y') 0) + $ fmap (\y'' -> (\y' -> (\y -> id y) y') y'') + $ Cons 0 Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ Cons ((\y' -> (\y -> id y) y') 0) + $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) + $ fmap (\y''' -> (\y'' -> (\y' -> (\y -> id y) y') y'') y''') + $ Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ Cons ((\y' -> (\y -> id y) y') 0) + $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) + $ Nil + +Notice how the number of lambdas—and hence, the number of closures—one +needs to evaluate grows very quickly. In general, a List with N cons cells will +require (1 + 2 + ... (N-1)) beta reductions, which takes O(N^2) time! This is +what caused the performance issues observed in #7436. + +But hold on a second: shouldn't GHC's optimizer be able to eta reduce +`\y -> f y` to `f` and avoid these beta reductions? Unfortunately, this is not +the case. In general, eta reduction can change the semantics of a program. For +instance, (\x -> ⊥) `seq` () converges, but ⊥ `seq` () diverges. It just so +happens that the fmap implementation above would have the same semantics +regardless of whether or not `\y -> f y` or `f` is used, but GHC's optimizer is +not yet smart enough to realize this (see #17881). + +To avoid this quadratic blowup, we add a special case to $fmap that applies +`fmap f` directly: + + $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + +With this modified algorithm, the derived Functor List instance becomes: + + instance Functor List where + fmap f Nil = Nil + fmap f (Cons x xs) = Cons (f x) (fmap f xs) + +No lambdas in sight, just the way we like it. + +This special case does not prevent all sources quadratic closure buildup, +however. In this example: + + data PolyList a = PLNil | PLCons a (PolyList (PolyList a)) + deriving Functor + +We would derive the following code: + + instance Functor PolyList where + fmap f PLNil = PLNil + fmap f (PLCons x xs) = PLCons (f x) (fmap (\y -> fmap f y) xs) + +The use of `fmap (\y -> fmap f y) xs` builds up closures in much the same way +as `fmap (\y -> f y) xs`. The difference here is that even if we eta reduced +to `fmap (fmap f) xs`, GHC would /still/ build up a closure, since we are +recursively invoking fmap with a different argument (fmap f). Since we end up +paying the price of building a closure either way, we do not extend the special +case in $fmap any further, since it wouldn't buy us anything. + +The ft_ty_app field of FFoldType distinguishes between these two $fmap cases by +inspecting the argument type. If the argument type is a bare type variable, +then we can conclude the type variable /must/ be the same as the data type's +last type parameter. We know that this must be the case since there is an +invariant that the argument type in ft_ty_app will always contain the last +type parameter somewhere (see Note [FFoldType and functorLikeTraverse]), so +if the argument type is a bare variable, then that must be exactly the last +type parameter. + +Note that the ft_ty_app case of ft_replace (which derives implementations of +(<$)) also inspects the argument type to generate more efficient code. +See Note [Deriving <$]. + +Note [Deriving <$] +~~~~~~~~~~~~~~~~~~ + +We derive the definition of <$. Allowing this to take the default definition +can lead to memory leaks: mapping over a structure with a constant function can +fill the result structure with trivial thunks that retain the values from the +original structure. The simplifier seems to handle this all right for simple +types, but not for recursive ones. Consider + +data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor + +-- fmap _ Tip = Tip +-- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r) + +Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that +simplifies no further. Why is that? `fmap` is defined recursively, so GHC +cannot inline it. The static argument transformation would turn the definition +into a non-recursive one + +-- fmap f = go where +-- go Tip = Tip +-- go (Bin l v r) = Bin (go l) (f v) (go r) + +which GHC could inline, producing an efficient definion of `<$`. But there are +several problems. First, GHC does not perform the static argument transformation +by default, even with -O2. Second, even when it does perform the static argument +transformation, it does so only when there are at least two static arguments, +which is not the case for fmap. Finally, when the type in question is +non-regular, such as + +data Nesty a = Z a | S (Nesty a) (Nest (a, a)) + +the function argument is no longer (entirely) static, so the static argument +transformation will do nothing for us. + +Applying the default definition of `<$` will produce a tree full of thunks that +look like ((\_ -> x) x0), which represents unnecessary thunk allocation and +also retention of the previous value, potentially leaking memory. Instead, we +derive <$ separately. Two aspects are different from fmap: the case of the +sought type variable (ft_var) and the case of a type application (ft_ty_app). +The interesting one is ft_ty_app. We have to distinguish two cases: the +"immediate" case where the type argument *is* the sought type variable, and +the "nested" case where the type argument *contains* the sought type variable. + +The immediate case: + +Suppose we have + +data Imm a = Imm (F ... a) + +Then we want to define + +x <$ Imm q = Imm (x <$ q) + +The nested case: + +Suppose we have + +data Nes a = Nes (F ... (G a)) + +Then we want to define + +x <$ Nes q = Nes (fmap (x <$) q) + +We inspect the argument type in ft_ty_app +(see Note [FFoldType and functorLikeTraverse]) to distinguish between these +two cases. If the argument type is a bare type variable, then we know that it +must be the same variable as the data type's last type parameter. +This is very similar to a trick that derived fmap implementations +use in their own ft_ty_app case. +See Note [Avoid unnecessary eta expansion in derived fmap implementations], +which explains why checking if the argument type is a bare variable is +the right thing to do. + +We could, but do not, give tuples special treatment to improve efficiency +in some cases. Suppose we have + +data Nest a = Z a | S (Nest (a,a)) + +The optimal definition would be + +x <$ Z _ = Z x +x <$ S t = S ((x, x) <$ t) + +which produces a result with maximal internal sharing. The reason we do not +attempt to treat this case specially is that we have no way to give +user-provided tuple-like types similar treatment. If the user changed the +definition to + +data Pair a = Pair a a +data Nest a = Z a | S (Nest (Pair a)) + +they would experience a surprising degradation in performance. -} + + +{- +Utility functions related to Functor deriving. + +Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse. +This function works like a fold: it makes a value of type 'a' in a bottom up way. +-} + +-- Generic traversal for Functor deriving +-- See Note [FFoldType and functorLikeTraverse] +data FFoldType a -- Describes how to fold over a Type in a functor like way + = FT { ft_triv :: a + -- ^ Does not contain variable + , ft_var :: a + -- ^ The variable itself + , ft_co_var :: a + -- ^ The variable itself, contravariantly + , ft_fun :: a -> a -> a + -- ^ Function type + , ft_tup :: TyCon -> [a] -> a + -- ^ Tuple type. The @[a]@ is the result of folding over the + -- arguments of the tuple. + , ft_ty_app :: Type -> Type -> a -> a + -- ^ Type app, variable only in last argument. The two 'Type's are + -- the function and argument parts of @fun_ty arg_ty@, + -- respectively. + , ft_bad_app :: a + -- ^ Type app, variable other than in last argument + , ft_forall :: TcTyVar -> a -> a + -- ^ Forall type + } + +functorLikeTraverse :: forall a. + TyVar -- ^ Variable to look for + -> FFoldType a -- ^ How to fold + -> Type -- ^ Type to process + -> a +functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar + , ft_co_var = caseCoVar, ft_fun = caseFun + , ft_tup = caseTuple, ft_ty_app = caseTyApp + , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) + ty + = fst (go False ty) + where + go :: Bool -- Covariant or contravariant context + -> Type + -> (a, Bool) -- (result of type a, does type contain var) + + go co ty | Just ty' <- coreView ty = go co ty' + go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) + go co (FunTy { ft_arg = x, ft_res = y, ft_af = af }) + | isInvisibleFunArg af = go co y + | xc || yc = (caseFun xr yr,True) + where (xr,xc) = go (not co) x + (yr,yc) = go co y + go co (AppTy x y) | xc = (caseWrongArg, True) + | yc = (caseTyApp x y yr, True) + where (_, xc) = go co x + (yr,yc) = go co y + go co ty@(TyConApp con args) + | not (or xcs) = (caseTrivial, False) -- Variable does not occur + -- At this point we know that xrs, xcs is not empty, + -- and at least one xr is True + | isTupleTyCon con = (caseTuple con xrs, True) + | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty + | Just (fun_ty, arg_ty) <- splitAppTy_maybe ty -- T (..no var..) ty + = (caseTyApp fun_ty arg_ty (last xrs), True) + | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function) + where + -- When folding over an unboxed tuple, we must explicitly drop the + -- runtime rep arguments, or else GHC will generate twice as many + -- variables in a unboxed tuple pattern match and expression as it + -- actually needs. See #12399 + (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args)) + go co (ForAllTy (Bndr v vis) x) + | isVisibleForAllTyFlag vis = panic "unexpected visible binder" + | v /= var && xc = (caseForAll v xr,True) + where (xr,xc) = go co x + + go _ _ = (caseTrivial,False) + +-- | Return all syntactic subterms of a 'Type' that are applied to the 'TyVar' +-- argument. This determines what constraints should be inferred for derived +-- 'Functor', 'Foldable', and 'Traversable' instances in "GHC.Tc.Deriv.Infer". +-- For instance, if we have: +-- +-- @ +-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a)) +-- @ +-- +-- Then the following would hold: +-- +-- * @'deepSubtypesContaining' a Int@ would return @[]@, since @Int@ does not +-- contain the type variable @a@ at all. +-- +-- * @'deepSubtypesContaining' a a@ would return @[]@. Although the type @a@ +-- contains the type variable @a@, it is not /applied/ to @a@, which is the +-- criterion that 'deepSubtypesContaining' checks for. +-- +-- * @'deepSubtypesContaining' a (Maybe a)@ would return @[Maybe]@, as @Maybe@ +-- is applied to @a@. +-- +-- * @'deepSubtypesContaining' a (Either Int (Maybe a))@ would return +-- @[Either Int, Maybe]@. Both of these types are applied to @a@ through +-- composition. +-- +-- As used in "GHC.Tc.Deriv.Infer", the 'Type' argument will always come from +-- 'derivDataConInstArgTys', so it is important that the 'TyVar' comes from +-- 'dataConUnivTyVars' to match. Make sure /not/ to take the 'TyVar' from +-- 'tyConTyVars', as these differ from the 'dataConUnivTyVars' when the data +-- type is a GADT. (See #22167 for what goes wrong if 'tyConTyVars' is used.) +deepSubtypesContaining :: TyVar -> Type -> [TcType] +deepSubtypesContaining tv + = functorLikeTraverse tv + (FT { ft_triv = [] + , ft_var = [] + , ft_fun = (++) + , ft_tup = \_ xs -> concat xs + , ft_ty_app = \t _ ts -> t:ts + , ft_bad_app = panic "in other argument in deepSubtypesContaining" + , ft_co_var = panic "contravariant in deepSubtypesContaining" + , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs }) + + +foldDataConArgs :: FFoldType a -> DataCon -> DerivInstTys -> [a] +-- Fold over the arguments of the datacon +foldDataConArgs ft con dit + = map foldArg (derivDataConInstArgTys con dit) + where + foldArg + = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of + Just tv -> functorLikeTraverse tv ft + Nothing -> const (ft_triv ft) + -- If we are deriving Foldable for a GADT, there is a chance that the last + -- type variable in the data type isn't actually a type variable at all. + -- (for example, this can happen if the last type variable is refined to + -- be a concrete type such as Int). If the last type variable is refined + -- to be a specific type, then getTyVar_maybe will return Nothing. + -- See Note [DeriveFoldable with ExistentialQuantification] + -- + -- The kind checks have ensured the last type parameter is of kind *. + +-- Make a HsLam using a fresh variable from a State monad +mkSimpleLam :: (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs)) + -> State (Infinite RdrName) (LHsExpr GhcPs) +-- (mkSimpleLam fn) returns (\x. fn(x)) +mkSimpleLam lam = + get >>= \ (Inf n names) -> do + put names + body <- lam (nlHsVar n) + return (mkHsLam (noLocA [nlVarPat n]) body) + +mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs + -> State (Infinite RdrName) (LHsExpr GhcPs)) + -> State (Infinite RdrName) (LHsExpr GhcPs) +mkSimpleLam2 lam = + get >>= \ (n1 `Inf` n2 `Inf` names) -> do + put names + body <- lam (nlHsVar n1) (nlHsVar n2) + return (mkHsLam (noLocA [nlVarPat n1,nlVarPat n2]) body) + +-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" +-- +-- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in +-- which the LHS pattern-matches on @extra_pats@, followed by a match on the +-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ +-- and its arguments, applying an expression (from @insides@) to each of the +-- respective arguments of @con@. +mkSimpleConMatch :: Monad m => HsMatchContextPs + -> (RdrName -> [a] -> m (LHsExpr GhcPs)) + -> [LPat GhcPs] + -> DataCon + -> [LHsExpr GhcPs -> a] + -> m (LMatch GhcPs (LHsExpr GhcPs)) +mkSimpleConMatch ctxt fold extra_pats con insides = do + let con_name = getRdrName con + let vars_needed = takeList insides as_RDRList + let bare_pat = nlConVarPat con_name vars_needed + let pat = if null vars_needed + then bare_pat + else nlParPat bare_pat + rhs <- fold con_name + (zipWith (\i v -> i $ nlHsVar v) insides vars_needed) + return $ mkMatch ctxt (noLocA (extra_pats ++ [pat])) rhs emptyLocalBinds + +-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" +-- +-- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to +-- 'mkSimpleConMatch', with two key differences: +-- +-- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a +-- @[LHsExpr RdrName]@. This is because it filters out the expressions +-- corresponding to arguments whose types do not mention the last type +-- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the +-- 'Nothing' elements of @insides@). +-- +-- 2. @fold@ takes an expression as its first argument instead of a +-- constructor name. This is because it uses a specialized +-- constructor function expression that only takes as many parameters as +-- there are argument types that mention the last type variable. +-- +-- See Note [Generated code for DeriveFoldable and DeriveTraversable] +mkSimpleConMatch2 :: Monad m + => HsMatchContextPs + -> (LHsExpr GhcPs -> [LHsExpr GhcPs] + -> m (LHsExpr GhcPs)) + -> [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) +mkSimpleConMatch2 ctxt fold extra_pats con insides = do + let con_name = getRdrName con + vars_needed = takeList insides (toList as_RDRs) + pat = nlConVarPat con_name vars_needed + -- Make sure to zip BEFORE invoking catMaybes. We want the variable + -- indices in each expression to match up with the argument indices + -- in con_expr (defined below). + exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i) + insides vars_needed + -- An element of argTysTyVarInfo is True if the constructor argument + -- with the same index has a type which mentions the last type + -- variable. + argTysTyVarInfo = map isJust insides + (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo (toList as_Vars) + + con_expr + | null asWithTyVar = nlHsApps con_name asWithoutTyVar + | otherwise = + let bs = filterByList argTysTyVarInfo bs_RDRList + vars = filterByLists argTysTyVarInfo bs_VarList as_VarList + in mkHsLam (noLocA (map nlVarPat bs)) (nlHsApps con_name vars) + + rhs <- fold con_expr exps + return $ mkMatch ctxt (noLocA (extra_pats ++ [pat])) rhs emptyLocalBinds + +-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" +mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a] + -> m (LMatch GhcPs (LHsExpr GhcPs))) + -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs) +mkSimpleTupleCase match_for_con tc insides x + = do { let data_con = tyConSingleDataCon tc + ; match <- match_for_con [] data_con insides + ; return $ nlHsCase x [match] } + +{- +************************************************************************ +* * + Foldable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + +* * +************************************************************************ + +Deriving Foldable instances works the same way as Functor instances, +only Foldable instances are not possible for function types at all. +Given (data T a = T a a (T a) deriving Foldable), we get: + + instance Foldable T where + foldr f z (T x1 x2 x3) = + $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) ) + +-XDeriveFoldable is different from -XDeriveFunctor in that it filters out +arguments to the constructor that would produce useless code in a Foldable +instance. For example, the following datatype: + + data Foo a = Foo Int a Int deriving Foldable + +would have the following generated Foldable instance: + + instance Foldable Foo where + foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2 + +since neither of the two Int arguments are folded over. + +The cases are: + + $(foldr 'a 'a) = f + $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z ) + $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2 + +Note that the arguments to the real foldr function are the wrong way around, +since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). + +One can envision a case for types that don't contain the last type variable: + + $(foldr 'a 'b) = \x z -> z -- when b does not contain a + +But this case will never materialize, since the aforementioned filtering +removes all such types from consideration. +See Note [Generated code for DeriveFoldable and DeriveTraversable]. + +Foldable instances differ from Functor and Traversable instances in that +Foldable instances can be derived for data types in which the last type +variable is existentially quantified. In particular, if the last type variable +is refined to a more specific type in a GADT: + + data GADT a where + G :: a ~ Int => a -> G Int + +then the deriving machinery does not attempt to check that the type a contains +Int, since it is not syntactically equal to a type variable. That is, the +derived Foldable instance for GADT is: + + instance Foldable GADT where + foldr _ z (GADT _) = z + +See Note [DeriveFoldable with ExistentialQuantification]. + +Note [Deriving null] +~~~~~~~~~~~~~~~~~~~~ + +In some cases, deriving the definition of 'null' can produce much better +results than the default definition. For example, with + + data SnocList a = Nil | Snoc (SnocList a) a + +the default definition of 'null' would walk the entire spine of a +nonempty snoc-list before concluding that it is not null. But looking at +the Snoc constructor, we can immediately see that it contains an 'a', and +so 'null' can return False immediately if it matches on Snoc. When we +derive 'null', we keep track of things that cannot be null. The interesting +case is type application. Given + + data Wrap a = Wrap (Foo (Bar a)) + +we use + + null (Wrap fba) = all null fba + +but if we see + + data Wrap a = Wrap (Foo a) + +we can just use + + null (Wrap fa) = null fa + +Indeed, we allow this to happen even for tuples: + + data Wrap a = Wrap (Foo (a, Int)) + +produces + + null (Wrap fa) = null fa + +As explained in Note [Deriving <$], giving tuples special performance treatment +could surprise users if they switch to other types, but Ryan Scott seems to +think it's okay to do it for now. +-} + +gen_Foldable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) +-- When the parameter is phantom, we can use foldMap _ _ = mempty +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Foldable_binds loc (DerivInstTys{dit_rep_tc = tycon}) + | Phantom <- last (tyConRoles tycon) + = ([foldMap_bind], emptyBag) + where + foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR + foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns + foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt + (noLocA [nlWildPat, nlWildPat]) + mempty_Expr] + foldMap_match_ctxt = mkPrefixFunRhs foldMap_name noAnn + +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. + = ([foldMap_bind], emptyBag) + + | otherwise + = ([foldr_bind, foldMap_bind, null_bind], emptyBag) + where + data_cons = getPossibleDataCons tycon tycon_args + + foldr_name = L (noAnnSrcSpan loc) foldable_foldr_RDR + + foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns + eqns = map foldr_eqn data_cons + foldr_eqn con + = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_foldr con dit + foldr_match_ctxt = mkPrefixFunRhs foldr_name noAnn + + foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr) + foldMap_name foldMap_eqns + + foldMap_eqns = map foldMap_eqn data_cons + + foldMap_eqn con + = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_foldMap con dit + foldMap_match_ctxt = mkPrefixFunRhs foldMap_name noAnn + + -- Given a list of NullM results, produce Nothing if any of + -- them is NotNull, and otherwise produce a list of Maybes + -- with Justs representing unknowns and Nothings representing + -- things that are definitely null. + convert :: [NullM a] -> Maybe [Maybe a] + convert = traverse go where + go IsNull = Just Nothing + go NotNull = Nothing + go (NullM a) = Just (Just a) + + null_name = L (noAnnSrcSpan loc) null_RDR + null_match_ctxt = mkPrefixFunRhs null_name noAnn + null_bind = mkRdrFunBind null_name null_eqns + null_eqns = map null_eqn data_cons + null_eqn con + = flip evalState bs_RDRs $ do + parts <- sequence $ foldDataConArgs ft_null con dit + case convert parts of + Nothing -> return $ + mkMatch null_match_ctxt (noLocA [nlParPat (nlWildConPat con)]) + false_Expr emptyLocalBinds + Just cp -> match_null [] con cp + + -- Yields 'Just' an expression if we're folding over a type that mentions + -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. + -- See Note [FFoldType and functorLikeTraverse] + ft_foldr :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs))) + ft_foldr + = FT { ft_triv = return Nothing + -- foldr f = \x z -> z + , ft_var = return $ Just f_Expr + -- foldr f = f + , ft_tup = \t g -> do + gg <- sequence g + lam <- mkSimpleLam2 $ \x z -> + mkSimpleTupleCase (match_foldr z) t gg x + return (Just lam) + -- foldr f = (\x z -> case x of ...) + , ft_ty_app = \_ _ g -> do + gg <- g + mapM (\gg' -> mkSimpleLam2 $ \x z -> return $ + nlHsApps foldable_foldr_RDR [gg',z,x]) gg + -- foldr f = (\x z -> foldr g z x) + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_foldr" + , ft_fun = panic "function in ft_foldr" + , ft_bad_app = panic "in other argument in ft_foldr" } + + match_foldr :: Monad m + => LHsExpr GhcPs + -> [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_foldr z = mkSimpleConMatch2 foldr_match_ctxt $ \_ xs -> return (mkFoldr xs) + where + -- g1 v1 (g2 v2 (.. z)) + mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs + mkFoldr = foldr nlHsApp z + + -- See Note [FFoldType and functorLikeTraverse] + ft_foldMap :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs))) + ft_foldMap + = FT { ft_triv = return Nothing + -- foldMap f = \x -> mempty + , ft_var = return (Just f_Expr) + -- foldMap f = f + , ft_tup = \t g -> do + gg <- sequence g + lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg + return (Just lam) + -- foldMap f = \x -> case x of (..,) + , ft_ty_app = \_ _ g -> fmap (nlHsApp foldMap_Expr) <$> g + -- foldMap f = foldMap g + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_foldMap" + , ft_fun = panic "function in ft_foldMap" + , ft_bad_app = panic "in other argument in ft_foldMap" } + + match_foldMap :: Monad m + => [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_foldMap = mkSimpleConMatch2 foldMap_match_ctxt $ \_ xs -> return (mkFoldMap xs) + where + -- mappend v1 (mappend v2 ..) + mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs + mkFoldMap = foldr1WithDefault mempty_Expr (\x y -> nlHsApps mappend_RDR [x,y]) + + -- See Note [FFoldType and functorLikeTraverse] + -- Yields NullM an expression if we're folding over an expression + -- that may or may not be null. Yields IsNull if it's certainly + -- null, and yields NotNull if it's certainly not null. + -- See Note [Deriving null] + ft_null :: FFoldType (State (Infinite RdrName) (NullM (LHsExpr GhcPs))) + ft_null + = FT { ft_triv = return IsNull + -- null = \_ -> True + , ft_var = return NotNull + -- null = \_ -> False + , ft_tup = \t g -> do + gg <- sequence g + case convert gg of + Nothing -> pure NotNull + Just ggg -> + NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg) + -- null = \x -> case x of (..,) + , ft_ty_app = \_ _ g -> flip fmap g $ \nestedResult -> + case nestedResult of + -- If e definitely contains the parameter, + -- then we can test if (G e) contains it by + -- simply checking if (G e) is null + NotNull -> NullM null_Expr + -- This case is unreachable--it will actually be + -- caught by ft_triv + IsNull -> IsNull + -- The general case uses (all null), + -- (all (all null)), etc. + NullM nestedTest -> NullM $ + nlHsApp all_Expr nestedTest + -- null fa = null fa, or null fa = all null fa, or null fa = True + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_null" + , ft_fun = panic "function in ft_null" + , ft_bad_app = panic "in other argument in ft_null" } + + match_null :: Monad m + => [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs) + where + -- v1 && v2 && .. + mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs + mkNull = foldr1WithDefault true_Expr (\x y -> nlHsApps and_RDR [x,y]) + +data NullM a = + IsNull -- Definitely null + | NotNull -- Definitely not null + | NullM a -- Unknown + +{- +************************************************************************ +* * + Traversable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html +* * +************************************************************************ + +Again, Traversable is much like Functor and Foldable. + +The cases are: + + $(traverse 'a 'a) = f + $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> + liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2) + $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2 + +Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types +do not mention the last type parameter. Therefore, the following datatype: + + data Foo a = Foo Int a Int + +would have the following derived Traversable instance: + + instance Traversable Foo where + traverse f (Foo x1 x2 x3) = + fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 ) + +since the two Int arguments do not produce any effects in a traversal. + +One can envision a case for types that do not mention the last type parameter: + + $(traverse 'a 'b) = pure -- when b does not contain a + +But this case will never materialize, since the aforementioned filtering +removes all such types from consideration. +See Note [Generated code for DeriveFoldable and DeriveTraversable]. +-} + +gen_Traversable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) +-- When the argument is phantom, we can use traverse = pure . coerce +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Traversable_binds loc (DerivInstTys{dit_rep_tc = tycon}) + | Phantom <- last (tyConRoles tycon) + = ([traverse_bind], emptyBag) + where + traverse_name = L (noAnnSrcSpan loc) traverse_RDR + traverse_bind = mkRdrFunBind traverse_name traverse_eqns + traverse_eqns = + [mkSimpleMatch traverse_match_ctxt + (noLocA [nlWildPat, z_Pat]) + (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])] + traverse_match_ctxt = mkPrefixFunRhs traverse_name noAnn + +gen_Traversable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon + , dit_rep_tc_args = tycon_args }) + = ([traverse_bind], emptyBag) + where + data_cons = getPossibleDataCons tycon tycon_args + + traverse_name = L (noAnnSrcSpan loc) traverse_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr) + traverse_name traverse_eqns + traverse_eqns = map traverse_eqn data_cons + traverse_eqn con + = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_trav con dit + traverse_match_ctxt = mkPrefixFunRhs traverse_name noAnn + + -- Yields 'Just' an expression if we're folding over a type that mentions + -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. + -- See Note [FFoldType and functorLikeTraverse] + ft_trav :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs))) + ft_trav + = FT { ft_triv = return Nothing + -- traverse f = pure x + , ft_var = return (Just f_Expr) + -- traverse f = f x + , ft_tup = \t gs -> do + gg <- sequence gs + lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg + return (Just lam) + -- traverse f = \x -> case x of (a1,a2,..) -> + -- liftA2 (,,) (g1 a1) (g2 a2) <*> .. + , ft_ty_app = \_ _ g -> fmap (nlHsApp traverse_Expr) <$> g + -- traverse f = traverse g + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_trav" + , ft_fun = panic "function in ft_trav" + , ft_bad_app = panic "in other argument in ft_trav" } + + -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) + -- (g2 a2) <*> ... + match_for_con :: Monad m + => [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_for_con = mkSimpleConMatch2 traverse_match_ctxt $ + \con xs -> return (mkApCon con xs) + where + -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. + mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs + mkApCon con [] = nlHsApps pure_RDR [con] + mkApCon con [x] = nlHsApps fmap_RDR [con,x] + mkApCon con (x1:x2:xs) = + foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs + where appAp x y = nlHsApps ap_RDR [x,y] + +----------------------------------------------------------------------- + +f_Expr, z_Expr, mempty_Expr, foldMap_Expr, + traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr, + all_Expr, null_Expr :: LHsExpr GhcPs +f_Expr = nlHsVar f_RDR +z_Expr = nlHsVar z_RDR +mempty_Expr = nlHsVar mempty_RDR +foldMap_Expr = nlHsVar foldMap_RDR +traverse_Expr = nlHsVar traverse_RDR +coerce_Expr = nlHsVar (getRdrName coerceId) +pure_Expr = nlHsVar pure_RDR +true_Expr = nlHsVar true_RDR +false_Expr = nlHsVar false_RDR +all_Expr = nlHsVar all_RDR +null_Expr = nlHsVar null_RDR + +f_RDR, z_RDR :: RdrName +f_RDR = mkVarUnqual (fsLit "f") +z_RDR = mkVarUnqual (fsLit "z") + +as_RDRs, bs_RDRs :: Infinite RdrName +as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- Inf.enumFrom (1::Int) ] +bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- Inf.enumFrom (1::Int) ] + +as_Vars, bs_Vars :: Infinite (LHsExpr GhcPs) +as_Vars = fmap nlHsVar as_RDRs +bs_Vars = fmap nlHsVar bs_RDRs + +as_RDRList, bs_RDRList :: [RdrName] +as_RDRList = Inf.toList as_RDRs +bs_RDRList = Inf.toList bs_RDRs + +as_VarList, bs_VarList :: [LHsExpr GhcPs] +as_VarList = Inf.toList as_Vars +bs_VarList = Inf.toList bs_Vars + +f_Pat, z_Pat :: LPat GhcPs +f_Pat = nlVarPat f_RDR +z_Pat = nlVarPat z_RDR + +{- +Note [DeriveFoldable with ExistentialQuantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Functor and Traversable instances can only be derived for data types whose +last type parameter is truly universally polymorphic. For example: + + data T a b where + T1 :: b -> T a b -- YES, b is unconstrained + T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b) + T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int) + T4 :: Int -> T a Int -- NO, this is just like T3 + T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even + -- though a is existential + T6 :: Int -> T Int b -- YES, b is unconstrained + +For Foldable instances, however, we can completely lift the constraint that +the last type parameter be truly universally polymorphic. This means that T +(as defined above) can have a derived Foldable instance: + + instance Foldable (T a) where + foldr f z (T1 b) = f b z + foldr f z (T2 b) = f b z + foldr f z (T3 b) = f b z + foldr f z (T4 b) = z + foldr f z (T5 a b) = f b z + foldr f z (T6 a) = z + + foldMap f (T1 b) = f b + foldMap f (T2 b) = f b + foldMap f (T3 b) = f b + foldMap f (T4 b) = mempty + foldMap f (T5 a b) = f b + foldMap f (T6 a) = mempty + +In a Foldable instance, it is safe to fold over an occurrence of the last type +parameter that is not truly universally polymorphic. However, there is a bit +of subtlety in determining what is actually an occurrence of a type parameter. +T3 and T4, as defined above, provide one example: + + data T a b where + ... + T3 :: b ~ Int => b -> T a b + T4 :: Int -> T a Int + ... + + instance Foldable (T a) where + ... + foldr f z (T3 b) = f b z + foldr f z (T4 b) = z + ... + foldMap f (T3 b) = f b + foldMap f (T4 b) = mempty + ... + +Notice that the argument of T3 is folded over, whereas the argument of T4 is +not. This is because we only fold over constructor arguments that +syntactically mention the universally quantified type parameter of that +particular data constructor. See foldDataConArgs for how this is implemented. + +As another example, consider the following data type. The argument of each +constructor has the same type as the last type parameter: + + data E a where + E1 :: (a ~ Int) => a -> E a + E2 :: Int -> E Int + E3 :: (a ~ Int) => a -> E Int + E4 :: (a ~ Int) => Int -> E a + +Only E1's argument is an occurrence of a universally quantified type variable +that is syntactically equivalent to the last type parameter, so only E1's +argument will be folded over in a derived Foldable instance. + +See #10447 for the original discussion on this feature. Also see +https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor +for a more in-depth explanation. + +Note [FFoldType and functorLikeTraverse] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deriving Functor, Foldable, and Traversable all require generating expressions +which perform an operation on each argument of a data constructor depending +on the argument's type. In particular, a generated operation can be different +depending on whether the type mentions the last type variable of the datatype +(e.g., if you have data T a = MkT a Int, then a generated foldr expression would +fold over the first argument of MkT, but not the second). + +This pattern is abstracted with the FFoldType datatype, which provides hooks +for the user to specify how a constructor argument should be folded when it +has a type with a particular "shape". The shapes are as follows (assume that +a is the last type variable in a given datatype): + +* ft_triv: The type does not mention the last type variable at all. + Examples: Int, b + +* ft_var: The type is syntactically equal to the last type variable. + Moreover, the type appears in a covariant position (see + the Deriving Functor instances section of the user's guide + for an in-depth explanation of covariance vs. contravariance). + Example: a (covariantly) + +* ft_co_var: The type is syntactically equal to the last type variable. + Moreover, the type appears in a contravariant position. + Example: a (contravariantly) + +* ft_fun: A function type which mentions the last type variable in + the argument position, result position or both. + Examples: a -> Int, Int -> a, Maybe a -> [a] + +* ft_tup: A tuple type which mentions the last type variable in at least + one of its fields. The TyCon argument of ft_tup represents the + particular tuple's type constructor. + Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #) + +* ft_ty_app: A type is being applied to the last type parameter, where the + applied type does not mention the last type parameter (if it + did, it would fall under ft_bad_app) and the argument type + mentions the last type parameter (if it did not, it would fall + under ft_triv). The first two Type arguments to + ft_ty_app represent the applied type and argument type, + respectively. + + Currently, only DeriveFunctor makes use of the argument type. + It inspects the argument type so that it can generate more + efficient implementations of fmap + (see Note [Avoid unnecessary eta expansion in derived fmap implementations]) + and (<$) (see Note [Deriving <$]) in certain cases. + + Note that functions, tuples, and foralls are distinct cases + and take precedence over ft_ty_app. (For example, (Int -> a) would + fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a). + Examples: Maybe a, Either b a + +* ft_bad_app: A type application uses the last type parameter in a position + other than the last argument. This case is singled out because + Functor, Foldable, and Traversable instances cannot be derived + for datatypes containing arguments with such types. + Examples: Either a Int, Const a b + +* ft_forall: A forall'd type mentions the last type parameter on its right- + hand side (and is not quantified on the left-hand side). This + case is present mostly for plumbing purposes. + Example: forall b. Either b a + +If FFoldType describes a strategy for folding subcomponents of a Type, then +functorLikeTraverse is the function that applies that strategy to the entirety +of a Type, returning the final folded-up result. + +foldDataConArgs applies functorLikeTraverse to every argument type of a +constructor, returning a list of the fold results. This makes foldDataConArgs +a natural way to generate the subexpressions in a generated fmap, foldr, +foldMap, or traverse definition (the subexpressions must then be combined in +a method-specific fashion to form the final generated expression). + +Deriving Generic1 also does validity checking by looking for the last type +variable in certain positions of a constructor's argument types, so it also +uses foldDataConArgs. See Note [degenerate use of FFoldType] in GHC.Tc.Deriv.Generics. + +Note [Generated code for DeriveFoldable and DeriveTraversable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on +that of -XDeriveFunctor. However, there an important difference between deriving +the former two typeclasses and the latter one, which is best illustrated by the +following scenario: + + data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable) + +The generated code for the Functor instance is straightforward: + + instance Functor WithInt where + fmap f (WithInt a i) = WithInt (f a) i + +But if we use too similar of a strategy for deriving the Foldable and +Traversable instances, we end up with this code: + + instance Foldable WithInt where + foldMap f (WithInt a i) = f a <> mempty + + instance Traversable WithInt where + traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i + +This is unsatisfying for two reasons: + +1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure + expects an argument whose type is of kind *. This effectively prevents + Traversable from being derived for any datatype with an unlifted argument + type (#11174). + +2. The generated code contains superfluous expressions. By the Monoid laws, + we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can + reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)). + +We can fix both of these issues by incorporating a slight twist to the usual +algorithm that we use for -XDeriveFunctor. The differences can be summarized +as follows: + +1. In the generated expression, we only fold over arguments whose types + mention the last type parameter. Any other argument types will simply + produce useless 'mempty's or 'pure's, so they can be safely ignored. + +2. In the case of -XDeriveTraversable, instead of applying ConName, + we apply (\b_i ... b_k -> ConName a_1 ... a_n), where + + * ConName has n arguments + * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond + to the arguments whose types mention the last type parameter. As a + consequence, taking the difference of {a_1, ..., a_n} and + {b_i, ..., b_k} yields the all the argument values of ConName whose types + do not mention the last type parameter. Note that [i, ..., k] is a + strictly increasing—but not necessarily consecutive—integer sequence. + + For example, the datatype + + data Foo a = Foo Int a Int a + + would generate the following Traversable instance: + + instance Traversable Foo where + traverse f (Foo a1 a2 a3 a4) = + fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4 + +Technically, this approach would also work for -XDeriveFunctor as well, but we +decide not to do so because: + +1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a)) + instead of (WithInt (f a) i). + +2. There would be certain datatypes for which the above strategy would + generate Functor code that would fail to typecheck. For example: + + data Bar f a = Bar (forall f. Functor f => f a) deriving Functor + + With the conventional algorithm, it would generate something like: + + fmap f (Bar a) = Bar (fmap f a) + + which typechecks. But with the strategy mentioned above, it would generate: + + fmap f (Bar a) = (\b -> Bar b) (fmap f a) + + which does not typecheck, since GHC cannot unify the rank-2 type variables + in the types of b and (fmap f a). + +Note [Phantom types with Functor, Foldable, and Traversable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Given a type F :: * -> * whose type argument has a phantom role, we can always +produce lawful Functor and Traversable instances using + + fmap _ = coerce + traverse _ = pure . coerce + +Indeed, these are equivalent to any *strictly lawful* instances one could +write, except that this definition of 'traverse' may be lazier. That is, if +instances obey the laws under true equality (rather than up to some equivalence +relation), then they will be essentially equivalent to these. These definitions +are incredibly cheap, so we want to use them even if it means ignoring some +non-strictly-lawful instance in an embedded type. + +Foldable has far fewer laws to work with, which leaves us unwelcome +freedom in implementing it. At a minimum, we would like to ensure that +a derived foldMap is always at least as good as foldMapDefault with a +derived traverse. To accomplish that, we must define + + foldMap _ _ = mempty + +in these cases. + +This may have different strictness properties from a standard derivation. +Consider + + data NotAList a = Nil | Cons (NotAList a) deriving Foldable + +The usual deriving mechanism would produce + + foldMap _ Nil = mempty + foldMap f (Cons x) = foldMap f x + +which is strict in the entire spine of the NotAList. + +Final point: why do we even care about such types? Users will rarely if ever +map, fold, or traverse over such things themselves, but other derived +instances may: + + data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable + +Note [EmptyDataDecls with Functor, Foldable, and Traversable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are some slightly tricky decisions to make about how to handle +Functor, Foldable, and Traversable instances for types with no constructors. +For fmap, the two basic options are + + fmap _ _ = error "Sorry, no constructors" + +or + + fmap _ z = case z of + +In most cases, the latter is more helpful: if the thunk passed to fmap +throws an exception, we're generally going to be much more interested in +that exception than in the fact that there aren't any constructors. + +In order to match the semantics for phantoms (see note above), we need to +be a bit careful about 'traverse'. The obvious definition would be + + traverse _ z = case z of + +but this is stricter than the one for phantoms. We instead use + + traverse _ z = pure $ case z of + +For foldMap, the obvious choices are + + foldMap _ _ = mempty + +or + + foldMap _ z = case z of + +We choose the first one to be consistent with what foldMapDefault does for +a derived Traversable instance. +-} diff --git a/GHC/Tc/Deriv/Generate.hs b/GHC/Tc/Deriv/Generate.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv/Generate.hs @@ -0,0 +1,3104 @@ +{- + % +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Generating derived instance declarations +-- +-- This module is nominally ``subordinate'' to "GHC.Tc.Deriv", which is the +-- ``official'' interface to deriving-related things. +-- +-- This is where we do all the grimy bindings' generation. +module GHC.Tc.Deriv.Generate ( + AuxBindSpec(..), + + gen_Eq_binds, + gen_Ord_binds, + gen_Enum_binds, + gen_Bounded_binds, + gen_Ix_binds, + gen_Show_binds, + gen_Read_binds, + gen_Data_binds, + gen_Lift_binds, + gen_Newtype_binds, + gen_Newtype_fam_insts, + mkCoerceClassMethEqn, + genAuxBinds, + ordOpTbl, boxConTbl, + mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr, + + getPossibleDataCons, + DerivInstTys(..), buildDataConInstArgEnv, + derivDataConInstArgTys, substDerivInstTys, zonkDerivInstTys + ) where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Tc.TyCl.Class ( substATBndrs ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate( newFamInst ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.Type +import GHC.Tc.Validity + +import GHC.Core.DataCon +import GHC.Core.FamInstEnv +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) +import GHC.Core.Type +import GHC.Core.Class + +import GHC.Types.Name.Reader +import GHC.Types.Basic +import GHC.Types.Fixity +import GHC.Types.Name +import GHC.Types.SourceText +import GHC.Types.Id.Make ( coerceId ) +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) +import GHC.Types.Var.Env +import GHC.Types.Var +import GHC.Types.Var.Set + +import GHC.Builtin.Names +import GHC.Builtin.Names.TH +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids (primOpId) +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Lexeme + +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Data.Bag +import GHC.Data.Maybe ( expectJust ) +import GHC.Unit.Module + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Data.List ( find, partition, intersperse ) + +-- | A declarative description of an auxiliary binding that should be +-- generated. See @Note [Auxiliary binders]@ for a more detailed description +-- of how these are used. +data AuxBindSpec + -- DerivTag2Con, and DerivMaxTag are used in derived Eq, Ord, + -- Enum, and Ix instances. + -- All these generate ZERO-BASED tag operations + -- I.e first constructor has tag 0 + + -- | @$tag2con@: Given a tag, computes the corresponding data constructor + = DerivTag2Con + TyCon -- The type constructor of the data type to which the + -- constructors belong + RdrName -- The to-be-generated $tag2con binding's RdrName + + -- | @$maxtag@: The maximum possible tag value among a data type's + -- constructors + | DerivMaxTag + TyCon -- The type constructor of the data type to which the + -- constructors belong + RdrName -- The to-be-generated $maxtag binding's RdrName + + -- DerivDataDataType and DerivDataConstr are only used in derived Data + -- instances + + -- | @$t@: The @DataType@ representation for a @Data@ instance + | DerivDataDataType + TyCon -- The type constructor of the data type to be represented + RdrName -- The to-be-generated $t binding's RdrName + [RdrName] -- The RdrNames of the to-be-generated $c bindings for each + -- data constructor. These are only used on the RHS of the + -- to-be-generated $t binding. + + -- | @$c@: The @Constr@ representation for a @Data@ instance + | DerivDataConstr + DataCon -- The data constructor to be represented + RdrName -- The to-be-generated $c binding's RdrName + RdrName -- The RdrName of the to-be-generated $t binding for the parent + -- data type. This is only used on the RHS of the + -- to-be-generated $c binding. + +-- | Retrieve the 'RdrName' of the binding that the supplied 'AuxBindSpec' +-- describes. +auxBindSpecRdrName :: AuxBindSpec -> RdrName +auxBindSpecRdrName (DerivTag2Con _ tag2con_RDR) = tag2con_RDR +auxBindSpecRdrName (DerivMaxTag _ maxtag_RDR) = maxtag_RDR +auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR +auxBindSpecRdrName (DerivDataConstr _ dataC_RDR _) = dataC_RDR + +{- +************************************************************************ +* * + Eq instances +* * +************************************************************************ + +Here are the heuristics for the code we generate for @Eq@. Let's +assume we have a data type with some (possibly zero) nullary data +constructors and some ordinary, non-nullary ones (the rest, also +possibly zero of them). Here's an example, with both \tr{N}ullary and +\tr{O}rdinary data cons. + + data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... + +* We first attempt to compare the constructor tags. If tags don't + match - we immediately bail out. Otherwise, we then generate one + branch per constructor comparing only the fields as we already + know that the tags match. Note that it only makes sense to check + the tag if there is more than one data constructor. + +* For the ordinary constructors (if any), we emit clauses to do The + Usual Thing, e.g.,: + + (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2 + (==) (O2 a1) (O2 a2) = a1 == a2 + (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 + + Note: if we're comparing unlifted things, e.g., if 'a1' and + 'a2' are Float#s, then we have to generate + case (a1 `eqFloat#` a2) of r -> r + for that particular test. + +* For nullary constructors, we emit a catch-all clause that always + returns True since we already know that the tags match. + +* So, given this data type: + + data T = A | B Int | C Char + + We roughly get: + + (==) a b = + case dataToTag# a /= dataToTag# b of + True -> False + False -> case a of -- Here we already know that tags match + B a1 -> case b of + B b1 -> a1 == b1 -- Only one branch + C a1 -> case b of + C b1 -> a1 == b1 -- Only one branch + _ -> True -- catch-all to match all nullary ctors + + An older approach preferred regular pattern matches in some cases + but with dataToTag# forcing it's argument, and work on improving + join points, this seems no longer necessary. + +* For the @(/=)@ method, we normally just use the default method. + If the type is an enumeration type, we could/may/should? generate + special code that calls @dataToTag#@, much like for @(==)@ shown + above. + +We thought about doing this: If we're also deriving 'Ord' for this +tycon, we generate: + instance ... Eq (Foo ...) where + (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False} + (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True } +However, that requires that (Ord ) was put in the context +for the instance decl, which it probably wasn't, so the decls +produced don't get through the typechecker. +-} + +gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) +gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon + , dit_rep_tc_args = tycon_args }) = do + return (method_binds, emptyBag) + where + all_cons = getPossibleDataCons tycon tycon_args + non_nullary_cons = filter (not . isNullarySrcDataCon) all_cons + + -- Generate tag check. See #17240 + eq_expr_with_tag_check = nlHsCase + (nlHsPar (untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (nlHsOpApp (nlHsVar ah_RDR) neInt_RDR (nlHsVar bh_RDR)))) + [ mkHsCaseAlt (nlLitPat (HsIntPrim NoSourceText 1)) false_Expr + , mkHsCaseAlt nlWildPat ( + nlHsCase + (nlHsVar a_RDR) + -- Only one branch to match all nullary constructors + -- as we already know the tags match but do not emit + -- the branch if there are no nullary constructors + (let non_nullary_pats = map pats_etc non_nullary_cons + in if null non_nullary_cons + then non_nullary_pats + else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr])) + ] + + method_binds = [eq_bind] + eq_bind = mkFunBindEC 2 loc eq_RDR (const true_Expr) binds + where + binds + | null all_cons = [] + -- Tag checking is redundant when there is only one data constructor + | [data_con] <- all_cons + , (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con + , data_con_RDR <- getRdrName data_con + , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed + , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed + , eq_expr <- nested_eq_expr tys_needed as_needed bs_needed + = [([con1_pat, con2_pat], eq_expr)] + -- This is an enum (all constructors are nullary) - just do a simple tag check + | all isNullarySrcDataCon all_cons + = [([a_Pat, b_Pat], untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] + | otherwise + = [([a_Pat, b_Pat], eq_expr_with_tag_check)] + + ------------------------------------------------------------------ + nested_eq_expr [] [] [] = true_Expr + nested_eq_expr tys as bs + = foldr1 and_Expr $ expectNonEmpty $ zipWith3Equal nested_eq tys as bs + -- Using 'foldr1' here ensures that the derived code is correctly + -- associated. See #10859. + where + nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) + + gen_con_fields_and_tys data_con + | tys_needed <- derivDataConInstArgTys data_con dit + , con_arity <- length tys_needed + , as_needed <- take con_arity as_RDRs + , bs_needed <- take con_arity bs_RDRs + = (as_needed, bs_needed, tys_needed) + + pats_etc data_con + | (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con + , data_con_RDR <- getRdrName data_con + , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed + , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed + , fields_eq_expr <- nested_eq_expr tys_needed as_needed bs_needed + = mkHsCaseAlt con1_pat (nlHsCase (nlHsVar b_RDR) [mkHsCaseAlt con2_pat fields_eq_expr]) + +{- +************************************************************************ +* * + Ord instances +* * +************************************************************************ + +Note [Generating Ord instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose constructors are K1..Kn, and some are nullary. +The general form we generate is: + +* Do case on first argument + case a of + K1 ... -> rhs_1 + K2 ... -> rhs_2 + ... + Kn ... -> rhs_n + _ -> nullary_rhs + +* To make rhs_i + If i = 1, 2, n-1, n, generate a single case. + rhs_2 case b of + K1 {} -> LT + K2 ... -> ...eq_rhs(K2)... + _ -> GT + + Otherwise do a tag compare against the bigger range + (because this is the one most likely to succeed) + rhs_3 case tag b of tb -> + if 3 <# tg then GT + else case b of + K3 ... -> ...eq_rhs(K3).... + _ -> LT + +* To make eq_rhs(K), which knows that + a = K a1 .. av + b = K b1 .. bv + we just want to compare (a1,b1) then (a2,b2) etc. + Take care on the last field to tail-call into comparing av,bv + +* To make nullary_rhs generate this + case dataToTag# a of a# -> + case dataToTag# b of -> + a# `compare` b# + +Several special cases: + +* Two or fewer nullary constructors: don't generate nullary_rhs + +* Be careful about unlifted comparisons. When comparing unboxed + values we can't call the overloaded functions. + See function unliftedOrdOp + +Note [Game plan for deriving Ord] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's a bad idea to define only 'compare', and build the other binary +comparisons on top of it; see #2130, #4019. Reason: we don't +want to laboriously make a three-way comparison, only to extract a +binary result, something like this: + (>) (I# x) (I# y) = case <# x y of + True -> False + False -> case ==# x y of + True -> False + False -> True + +This being said, we can get away with generating full code only for +'compare' and '<' thus saving us generation of other three operators. +Other operators can be cheaply expressed through '<': +a <= b = not $ b < a +a > b = b < a +a >= b = not $ a < b + +So for sufficiently small types (few constructors, or all nullary) +we generate all methods; for large ones we just use 'compare'. + +-} + +data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT + +------------ +ordMethRdr :: OrdOp -> RdrName +ordMethRdr op + = case op of + OrdCompare -> compare_RDR + OrdLT -> lt_RDR + OrdLE -> le_RDR + OrdGE -> ge_RDR + OrdGT -> gt_RDR + +------------ +ltResult :: OrdOp -> LHsExpr GhcPs +-- Knowing a LHsExpr GhcPs +-- Knowing a=b, what is the result for a `op` b? +eqResult OrdCompare = eqTag_Expr +eqResult OrdLT = false_Expr +eqResult OrdLE = true_Expr +eqResult OrdGE = true_Expr +eqResult OrdGT = false_Expr + +------------ +gtResult :: OrdOp -> LHsExpr GhcPs +-- Knowing a>b, what is the result for a `op` b? +gtResult OrdCompare = gtTag_Expr +gtResult OrdLT = false_Expr +gtResult OrdLE = false_Expr +gtResult OrdGE = true_Expr +gtResult OrdGT = true_Expr + +------------ +gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) +gen_Ord_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon + , dit_rep_tc_args = tycon_args }) = do + return $ if null tycon_data_cons -- No data-cons => invoke bale-out case + then ( [mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []] + , emptyBag) + else ( [mkOrdOp OrdCompare] ++ other_ops + , aux_binds) + where + aux_binds = emptyBag + + -- Note [Game plan for deriving Ord] + other_ops + | (last_tag - first_tag) <= 2 -- 1-3 constructors + || null non_nullary_cons -- Or it's an enumeration + = [mkOrdOp OrdLT, lE, gT, gE] + | otherwise + = [] + + negate_expr = nlHsApp (nlHsVar not_RDR) + pats = noLocA [a_Pat, b_Pat] + lE = mkSimpleGeneratedFunBind loc le_RDR pats $ + negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr) + gT = mkSimpleGeneratedFunBind loc gt_RDR pats $ + nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr + gE = mkSimpleGeneratedFunBind loc ge_RDR pats $ + negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) + + get_tag con = dataConTag con - fIRST_TAG + -- We want *zero-based* tags, because that's what + -- con2Tag returns (generated by untag_Expr)! + + tycon_data_cons = getPossibleDataCons tycon tycon_args + single_con_type = isSingleton tycon_data_cons + (first_con : _) = tycon_data_cons + (last_con : _) = reverse tycon_data_cons + first_tag = get_tag first_con + last_tag = get_tag last_con + + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons + + + mkOrdOp :: OrdOp -> LHsBind GhcPs + -- Returns a binding op a b = ... compares a and b according to op .... + mkOrdOp op + = mkSimpleGeneratedFunBind loc (ordMethRdr op) (noLocA [a_Pat, b_Pat]) + (mkOrdOpRhs op) + + mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs + mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op + | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases + = nlHsCase (nlHsVar a_RDR) $ + map (mkOrdOpAlt op) tycon_data_cons + -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... + -- C2 x -> case b of C2 x -> ....compare x.... } + + | null non_nullary_cons -- All nullary, so go straight to comparing tags + = mkTagCmp op + + | otherwise -- Mixed nullary and non-nullary + = nlHsCase (nlHsVar a_RDR) $ + (map (mkOrdOpAlt op) non_nullary_cons + ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)]) + + + mkOrdOpAlt :: OrdOp -> DataCon + -> LMatch GhcPs (LHsExpr GhcPs) + -- Make the alternative (Ki a1 a2 .. av -> + mkOrdOpAlt op data_con + = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) + (mkInnerRhs op data_con) + where + as_needed = take (dataConSourceArity data_con) as_RDRs + data_con_RDR = getRdrName data_con + + mkInnerRhs op data_con + | single_con_type + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] + + | tag == first_tag + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (ltResult op) ] + | tag == last_tag + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (gtResult op) ] + + | tag == first_tag + 1 + = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con) + (gtResult op) + , mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (ltResult op) ] + | tag == last_tag - 1 + = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con) + (ltResult op) + , mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (gtResult op) ] + + | tag > last_tag `div` 2 -- lower range is larger + = untag_Expr [(b_RDR, bh_RDR)] $ + nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) + (gtResult op) $ -- Definitely GT + nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (ltResult op) ] + + | otherwise -- upper range is larger + = untag_Expr [(b_RDR, bh_RDR)] $ + nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) + (ltResult op) $ -- Definitely LT + nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (gtResult op) ] + where + tag = get_tag data_con + tag_lit + = noLocA (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) + + mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) + -- First argument 'a' known to be built with K + -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) + mkInnerEqAlt op data_con + = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $ + mkCompareFields op (derivDataConInstArgTys data_con dit) + where + data_con_RDR = getRdrName data_con + bs_needed = take (dataConSourceArity data_con) bs_RDRs + + mkTagCmp :: OrdOp -> LHsExpr GhcPs + -- Both constructors known to be nullary + -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# + mkTagCmp op = + untag_Expr [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ + unliftedOrdOp intPrimTy op ah_RDR bh_RDR + +mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs +-- Generates nested comparisons for (a1,a2...) against (b1,b2,...) +-- where the ai,bi have the given types +mkCompareFields op tys + = go tys as_RDRs bs_RDRs + where + go [] _ _ = eqResult op + go [ty] (a:_) (b:_) + | isUnliftedType ty = unliftedOrdOp ty op a b + | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b) + go (ty:tys) (a:as) (b:bs) = mk_compare ty a b + (ltResult op) + (go tys as bs) + (gtResult op) + go _ _ _ = panic "mkCompareFields" + + -- (mk_compare ty a b) generates + -- (case (compare a b) of { LT -> ; EQ -> ; GT -> }) + -- but with suitable special cases for + mk_compare ty a b lt eq gt + | isUnliftedType ty + = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt + | otherwise + = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr)) + [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt, + mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq, + mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt] + where + a_expr = nlHsVar a + b_expr = nlHsVar b + (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty + +unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs +unliftedOrdOp ty op a b + = case op of + OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr + ltTag_Expr eqTag_Expr gtTag_Expr + OrdLT -> wrap lt_op + OrdLE -> wrap le_op + OrdGE -> wrap ge_op + OrdGT -> wrap gt_op + where + (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty + wrap prim_op = genPrimOpApp a_expr prim_op b_expr + a_expr = nlHsVar a + b_expr = nlHsVar b + +unliftedCompare :: RdrName -> RdrName + -> LHsExpr GhcPs -> LHsExpr GhcPs -- What to compare + -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs + -- Three results + -> LHsExpr GhcPs +-- Return (if a < b then lt else if a == b then eq else gt) +unliftedCompare lt_op eq_op a_expr b_expr lt eq gt + = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $ + -- Test (<) first, not (==), because the latter + -- is true less often, so putting it first would + -- mean more tests (dynamically) + nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt + where + ascribeBool = nlAscribe boolTyCon_RDR + +nlConWildPat :: DataCon -> LPat GhcPs +-- The pattern (K {}) +nlConWildPat con = noLocA $ ConPat + { pat_con_ext = noAnn + , pat_con = noLocA $ getRdrName con + , pat_args = RecCon $ HsRecFields + { rec_ext = noExtField + , rec_flds = [] + , rec_dotdot = Nothing } + } + +{- +************************************************************************ +* * + Enum instances +* * +************************************************************************ + +@Enum@ can only be derived for enumeration types. For a type +\begin{verbatim} +data Foo ... = N1 | N2 | ... | Nn +\end{verbatim} + +we use both dataToTag# and @tag2con_Foo@ functions, as well as a +@maxtag_Foo@ variable, the later generated by @gen_tag_n_con_binds. + +\begin{verbatim} +instance ... Enum (Foo ...) where + succ x = toEnum (1 + fromEnum x) + pred x = toEnum (fromEnum x - 1) + + toEnum i = tag2con_Foo i + + enumFrom a = map tag2con_Foo [dataToTag# a .. maxtag_Foo] + + -- or, really... + enumFrom a + = case dataToTag# a of + a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo) + + enumFromThen a b + = map tag2con_Foo [dataToTag# a, dataToTag# b .. maxtag_Foo] + + -- or, really... + enumFromThen a b + = case dataToTag# a of { a# -> + case dataToTag# b of { b# -> + map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo) + }} +\end{verbatim} + +For @enumFromTo@ and @enumFromThenTo@, we use the default methods. +-} + +gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) +gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do + -- See Note [Auxiliary binders] + tag2con_RDR <- new_tag2con_rdr_name loc tycon + maxtag_RDR <- new_maxtag_rdr_name loc tycon + + return ( method_binds tag2con_RDR maxtag_RDR + , aux_binds tag2con_RDR maxtag_RDR ) + where + method_binds tag2con_RDR maxtag_RDR = + [ succ_enum tag2con_RDR maxtag_RDR + , pred_enum tag2con_RDR + , to_enum tag2con_RDR maxtag_RDR + , enum_from tag2con_RDR maxtag_RDR -- [0 ..] + , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..] + , from_enum + ] + aux_binds tag2con_RDR maxtag_RDR = listToBag + [ DerivTag2Con tycon tag2con_RDR + , DerivMaxTag tycon maxtag_RDR + ] + + occ_nm = getOccString tycon + + succ_enum tag2con_RDR maxtag_RDR + = mkSimpleGeneratedFunBind loc succ_RDR (noLocA [a_Pat]) $ + untag_Expr [(a_RDR, ah_RDR)] $ + nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR, + nlHsVarApps intDataCon_RDR [ah_RDR]]) + (nlHsApp (nlHsVar succError_RDR) (nlHsLit (mkHsString occ_nm))) + (nlHsApp (nlHsVar tag2con_RDR) + (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsIntLit 1])) + + pred_enum tag2con_RDR + = mkSimpleGeneratedFunBind loc pred_RDR (noLocA [a_Pat]) $ + untag_Expr [(a_RDR, ah_RDR)] $ + nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, + nlHsVarApps intDataCon_RDR [ah_RDR]]) + (nlHsApp (nlHsVar predError_RDR) (nlHsLit (mkHsString occ_nm))) + (nlHsApp (nlHsVar tag2con_RDR) + (nlHsApps plus_RDR + [ nlHsVarApps intDataCon_RDR [ah_RDR] + , nlHsLit (HsInt noExtField + (mkIntegralLit (-1 :: Int)))])) + + to_enum tag2con_RDR maxtag_RDR + = mkSimpleGeneratedFunBind loc toEnum_RDR (noLocA [a_Pat]) $ + let to_word = nlHsApp (nlHsVar enumIntToWord_RDR) + -- cast to Word to check both bounds (0,maxtag) with one comparison + in nlHsIf (nlHsApps le_RDR [ to_word (nlHsVar a_RDR), to_word (nlHsVar maxtag_RDR)]) + (nlHsVarApps tag2con_RDR [a_RDR]) + (nlHsApps toEnumError_RDR + [ nlHsLit (mkHsString occ_nm) + , nlHsVar a_RDR + , mkLHsTupleExpr [nlHsIntLit 0, nlHsVar maxtag_RDR] noAnn + ]) + + + enum_from tag2con_RDR maxtag_RDR + = mkSimpleGeneratedFunBind loc enumFrom_RDR (noLocA [a_Pat]) $ + untag_Expr [(a_RDR, ah_RDR)] $ + nlHsApps map_RDR + [nlHsVar tag2con_RDR, + nlHsPar (enum_from_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVar maxtag_RDR))] + + enum_from_then tag2con_RDR maxtag_RDR + = mkSimpleGeneratedFunBind loc enumFromThen_RDR (noLocA [a_Pat, b_Pat]) $ + untag_Expr [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $ + nlHsPar (enum_from_then_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVarApps intDataCon_RDR [bh_RDR]) + (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsVarApps intDataCon_RDR [bh_RDR]]) + (nlHsIntLit 0) + (nlHsVar maxtag_RDR) + )) + + from_enum + = mkSimpleGeneratedFunBind loc fromEnum_RDR (noLocA [a_Pat]) $ + untag_Expr [(a_RDR, ah_RDR)] $ + (nlHsVarApps intDataCon_RDR [ah_RDR]) + +{- +************************************************************************ +* * + Bounded instances +* * +************************************************************************ +-} + +gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) +gen_Bounded_binds loc (DerivInstTys{dit_rep_tc = tycon}) + | isEnumerationTyCon tycon + = ([ min_bound_enum, max_bound_enum ], emptyBag) + | otherwise + = assert (isSingleton data_cons) + ([ min_bound_1con, max_bound_1con ], emptyBag) + where + data_cons = tyConDataCons tycon + + ----- enum-flavored: --------------------------- + min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) + + data_con_1 = head data_cons + data_con_N = last data_cons + data_con_1_RDR = getRdrName data_con_1 + data_con_N_RDR = getRdrName data_con_N + + ----- single-constructor-flavored: ------------- + arity = dataConSourceArity data_con_1 + + min_bound_1con = mkHsVarBind loc minBound_RDR $ + nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR) + max_bound_1con = mkHsVarBind loc maxBound_RDR $ + nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR) + +{- +************************************************************************ +* * + Ix instances +* * +************************************************************************ + +Deriving @Ix@ is only possible for enumeration types and +single-constructor types. We deal with them in turn. + +For an enumeration type, e.g., +\begin{verbatim} + data Foo ... = N1 | N2 | ... | Nn +\end{verbatim} +things go not too differently from @Enum@: +\begin{verbatim} +instance ... Ix (Foo ...) where + range (a, b) + = map tag2con_Foo [dataToTag# a .. dataToTag# b] + + -- or, really... + range (a, b) + = case (dataToTag# a) of { a# -> + case (dataToTag# b) of { b# -> + map tag2con_Foo (enumFromTo (I# a#) (I# b#)) + }} + + -- Generate code for unsafeIndex, because using index leads + -- to lots of redundant range tests + unsafeIndex c@(a, b) d + = case (dataToTag# d -# dataToTag# a) of + r# -> I# r# + + inRange (a, b) c + = let + p_tag = dataToTag# c + in + p_tag >= dataToTag# a && p_tag <= dataToTag# b + + -- or, really... + inRange (a, b) c + = case (dataToTag# a) of { a_tag -> + case (dataToTag# b) of { b_tag -> + case (dataToTag# c) of { c_tag -> + if (c_tag >=# a_tag) then + c_tag <=# b_tag + else + False + }}} +\end{verbatim} +(modulo suitable case-ification to handle the unlifted tags) + +For a single-constructor type (NB: this includes all tuples), e.g., +\begin{verbatim} + data Foo ... = MkFoo a b Int Double c c +\end{verbatim} +we follow the scheme given in Figure~19 of the Haskell~1.2 report +(p.~147). +-} + +gen_Ix_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) + +gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do + -- See Note [Auxiliary binders] + tag2con_RDR <- new_tag2con_rdr_name loc tycon + + return $ if isEnumerationTyCon tycon + then (enum_ixes tag2con_RDR, listToBag + [ DerivTag2Con tycon tag2con_RDR + ]) + else (single_con_ixes, emptyBag) + where + -------------------------------------------------------------- + enum_ixes tag2con_RDR = + [ enum_range tag2con_RDR + , enum_index + , enum_inRange + ] + + enum_range tag2con_RDR + = mkSimpleGeneratedFunBind loc range_RDR (noLocA [nlTuplePat [a_Pat, b_Pat] Boxed]) $ + untag_Expr [(a_RDR, ah_RDR)] $ + untag_Expr [(b_RDR, bh_RDR)] $ + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $ + nlHsPar (enum_from_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVarApps intDataCon_RDR [bh_RDR])) + + enum_index + = mkSimpleGeneratedFunBind loc unsafeIndex_RDR + (noLocA [noLocA (AsPat noAnn (noLocA c_RDR) + (nlTuplePat [a_Pat, nlWildPat] Boxed)), + d_Pat]) ( + untag_Expr [(a_RDR, ah_RDR)] ( + untag_Expr [(d_RDR, dh_RDR)] ( + let + rhs = nlHsVarApps intDataCon_RDR [c_RDR] + in + nlHsCase + (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR)) + [mkHsCaseAlt (nlVarPat c_RDR) rhs] + )) + ) + + -- This produces something like `(ch >= ah) && (ch <= bh)` + enum_inRange + = mkSimpleGeneratedFunBind loc inRange_RDR (noLocA [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat]) $ + untag_Expr [(a_RDR, ah_RDR)] ( + untag_Expr [(b_RDR, bh_RDR)] ( + untag_Expr [(c_RDR, ch_RDR)] ( + -- This used to use `if`, which interacts badly with RebindableSyntax. + -- See #11396. + nlHsApps and_RDR + [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR) + , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR) + ] + ))) + + -------------------------------------------------------------- + single_con_ixes + = [single_con_range, single_con_index, single_con_inRange] + + data_con + = case tyConSingleDataCon_maybe tycon of -- just checking... + Nothing -> panic "get_Ix_binds" + Just dc -> dc + + con_arity = dataConSourceArity data_con + data_con_RDR = getRdrName data_con + + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + cs_needed = take con_arity cs_RDRs + + con_pat xs = nlConVarPat data_con_RDR xs + con_expr = nlHsVarApps data_con_RDR cs_needed + + -------------------------------------------------------------- + single_con_range + = mkSimpleGeneratedFunBind loc range_RDR + (noLocA [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed]) $ + noLocA (mkHsComp ListComp stmts con_expr) + where + stmts = zipWith3Equal mk_qual as_needed bs_needed cs_needed + + mk_qual a b c = noLocA $ mkPsBindStmt noAnn (nlVarPat c) + (nlHsApp (nlHsVar range_RDR) + (mkLHsVarTuple [a,b] noAnn)) + + ---------------- + single_con_index + = mkSimpleGeneratedFunBind loc unsafeIndex_RDR + (noLocA [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, + con_pat cs_needed]) + -- We need to reverse the order we consider the components in + -- so that + -- range (l,u) !! index (l,u) i == i -- when i is in range + -- (from http://haskell.org/onlinereport/ix.html) holds. + (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) + where + -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) + mk_index [] = nlHsIntLit 0 + mk_index [(l,u,i)] = mk_one l u i + mk_index ((l,u,i) : rest) + = genOpApp ( + mk_one l u i + ) plus_RDR ( + genOpApp ( + (nlHsApp (nlHsVar unsafeRangeSize_RDR) + (mkLHsVarTuple [l,u] noAnn)) + ) times_RDR (mk_index rest) + ) + mk_one l u i + = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u] noAnn, nlHsVar i] + + ------------------ + single_con_inRange + = mkSimpleGeneratedFunBind loc inRange_RDR + (noLocA [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, + con_pat cs_needed]) $ + if con_arity == 0 + -- If the product type has no fields, inRange is trivially true + -- (see #12853). + then true_Expr + else foldl1 and_Expr $ expectNonEmpty $ + zipWith3Equal in_range as_needed bs_needed cs_needed + where + in_range a b c + = nlHsApps inRange_RDR [mkLHsVarTuple [a,b] noAnn, nlHsVar c] + +{- +************************************************************************ +* * + Read instances +* * +************************************************************************ + +Example + + infix 4 %% + data T = Int %% Int + | T1 { f1 :: Int } + | T2 T + +instance Read T where + readPrec = + parens + ( prec 4 ( + do x <- ReadP.step Read.readPrec + expectP (Symbol "%%") + y <- ReadP.step Read.readPrec + return (x %% y)) + +++ + prec (appPrec+1) ( + -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok + -- Record construction binds even more tightly than application + do expectP (Ident "T1") + expectP (Punc '{') + x <- Read.readField "f1" (ReadP.reset readPrec) + expectP (Punc '}') + return (T1 { f1 = x })) + +++ + prec appPrec ( + do expectP (Ident "T2") + x <- ReadP.step Read.readPrec + return (T2 x)) + ) + + readListPrec = readListPrecDefault + readList = readListDefault + + +Note [Use expectP] +~~~~~~~~~~~~~~~~~~ +Note that we use + expectP (Ident "T1") +rather than + Ident "T1" <- lexP +The latter desugares to inline code for matching the Ident and the +string, and this can be very voluminous. The former is much more +compact. Cf #7258, although that also concerned non-linearity in +the occurrence analyser, a separate issue. + +Note [Read for empty data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we get for this? (#7931) + data Emp deriving( Read ) -- No data constructors + +Here we want + read "[]" :: [Emp] to succeed, returning [] +So we do NOT want + instance Read Emp where + readPrec = error "urk" +Rather we want + instance Read Emp where + readPred = pfail -- Same as choose [] + +Because 'pfail' allows the parser to backtrack, but 'error' doesn't. +These instances are also useful for Read (Either Int Emp), where +we want to be able to parse (Left 3) just fine. +-} + +gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys + -> (LHsBinds GhcPs, Bag AuxBindSpec) + +gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = tycon}) + = ([read_prec, default_readlist, default_readlistprec], emptyBag) + where + ----------------------------------------------------------------------- + default_readlist + = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) + + default_readlistprec + = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) + ----------------------------------------------------------------------- + + data_cons = tyConDataCons tycon + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons + + read_prec = mkHsVarBind loc readPrec_RDR rhs + where + rhs | null data_cons -- See Note [Read for empty data types] + = nlHsVar pfail_RDR + | otherwise + = nlHsApp (nlHsVar parens_RDR) $ + foldr1 mk_alt $ expectNonEmpty $ + read_nullary_cons ++ read_non_nullary_cons + + read_non_nullary_cons = map read_non_nullary_con non_nullary_cons + + read_nullary_cons + = case nullary_cons of + [] -> [] + [con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLocA $ mkLastStmt (result_expr con [])])] + _ -> [nlHsApp (nlHsVar choose_RDR) + (nlList (map mk_pair nullary_cons))] + -- NB For operators the parens around (:=:) are matched by the + -- enclosing "parens" call, so here we must match the naked + -- data_con_str con + + match_con con | isSym con_str = [symbol_pat con_str] + | otherwise = ident_h_pat con_str + where + con_str = data_con_str con + -- For nullary constructors we must match Ident s for normal constrs + -- and Symbol s for operators + + mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), + result_expr con []] noAnn + + read_non_nullary_con data_con + | is_infix = mk_parser infix_prec infix_stmts body + | is_record = mk_parser record_prec record_stmts body +-- Using these two lines instead allows the derived +-- read for infix and record bindings to read the prefix form +-- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) +-- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) + | otherwise = prefix_parser + where + body = result_expr data_con as_needed + con_str = data_con_str data_con + + prefix_parser = mk_parser prefix_prec prefix_stmts body + + read_prefix_con + | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] + | otherwise = ident_h_pat con_str + + read_infix_con + | isSym con_str = [symbol_pat con_str] + | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] + + prefix_stmts -- T a b c + = read_prefix_con ++ read_args + + infix_stmts -- a %% b, or a `T` b + = [read_a1] + ++ read_infix_con + ++ [read_a2] + + record_stmts -- T { f1 = a, f2 = b } + = read_prefix_con + ++ [read_punc "{"] + ++ concat (intersperse [read_punc ","] field_stmts) + ++ [read_punc "}"] + + field_stmts = zipWithEqual read_field labels as_needed + + con_arity = dataConSourceArity data_con + labels = map (field_label . flLabel) $ dataConFieldLabels data_con + dc_nm = getName data_con + is_infix = dataConIsInfix data_con + is_record = labels `lengthExceeds` 0 + as_needed = take con_arity as_RDRs + read_args = zipWithEqual read_arg as_needed (derivDataConInstArgTys data_con dit) + (read_a1:read_a2:_) = read_args + + prefix_prec = appPrecedence + infix_prec = getPrecedence get_fixity dc_nm + record_prec = appPrecedence + 1 -- Record construction binds even more tightly + -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) + + ------------------------------------------------------------------------ + -- Helpers + ------------------------------------------------------------------------ + mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 + mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) + , nlHsDo (DoExpr Nothing) (ss ++ [noLocA $ mkLastStmt b])] + con_app con as = nlHsVarApps (getRdrName con) as -- con as + result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) + + -- For constructors and field labels ending in '#', we hackily + -- let the lexer generate two tokens, and look for both in sequence + -- Thus [Ident "I"; Symbol "#"]. See #5041 + ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] + | otherwise = [ ident_pat s ] + + bindLex pat = noLocA (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p + -- See Note [Use expectP] + ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo") + symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>") + read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<") + + data_con_str con = occNameString (getOccName con) + + read_arg a ty = assert (not (isUnliftedType ty)) $ + noLocA (mkPsBindStmt noAnn (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) + + -- When reading field labels we might encounter + -- a = 3 + -- _a = 3 + -- or (#) = 4 + -- Note the parens! + read_field lbl a = + [noLocA + (mkPsBindStmt noAnn + (nlVarPat a) + (nlHsApp + read_field + (nlHsVarApps reset_RDR [readPrec_RDR]) + ) + ) + ] + where + lbl_str = unpackFS lbl + mk_read_field read_field_rdr lbl + = nlHsApps read_field_rdr [nlHsLit (mkHsStringFS lbl)] + read_field + | isSym lbl_str + = mk_read_field readSymField_RDR lbl + | Just (ss, '#') <- snocView lbl_str -- #14918 + = mk_read_field readFieldHash_RDR (mkFastString ss) + | otherwise + = mk_read_field readField_RDR lbl + +{- +************************************************************************ +* * + Show instances +* * +************************************************************************ + +Example + + infixr 5 :^: + + data Tree a = Leaf a | Tree a :^: Tree a + + instance (Show a) => Show (Tree a) where + + showsPrec d (Leaf m) = showParen (d > app_prec) showStr + where + showStr = showString "Leaf " . showsPrec (app_prec+1) m + + showsPrec d (u :^: v) = showParen (d > up_prec) showStr + where + showStr = showsPrec (up_prec+1) u . + showString " :^: " . + showsPrec (up_prec+1) v + -- Note: right-associativity of :^: ignored + + up_prec = 5 -- Precedence of :^: + app_prec = 10 -- Application has precedence one more than + -- the most tightly-binding operator +-} + +gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys + -> (LHsBinds GhcPs, Bag AuxBindSpec) + +gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon + , dit_rep_tc_args = tycon_args }) + = ([shows_prec], emptyBag) + where + data_cons = getPossibleDataCons tycon tycon_args + shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons) + comma_space = nlHsVar showCommaSpace_RDR + + pats_etc data_con + | nullary_con = -- skip the showParen junk... + assert (null bs_needed) + ([nlWildPat, con_pat], mk_showString_app op_con_str) + | otherwise = + ([a_Pat, con_pat], + showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit + (HsInt noExtField (mkIntegralLit con_prec_plus_one)))) + (nlHsPar (nested_compose_Expr show_thingies))) + where + data_con_RDR = getRdrName data_con + con_arity = dataConSourceArity data_con + bs_needed = take con_arity bs_RDRs + arg_tys = derivDataConInstArgTys data_con dit -- Correspond 1-1 with bs_needed + con_pat = nlConVarPat data_con_RDR bs_needed + nullary_con = con_arity == 0 + labels = map (field_label . flLabel) $ dataConFieldLabels data_con + lab_fields = length labels + record_syntax = lab_fields > 0 + + dc_nm = getName data_con + dc_occ_nm = getOccName data_con + con_str = occNameString dc_occ_nm + op_con_str = wrapOpParens con_str + backquote_str = wrapOpBackquotes con_str + + show_thingies + | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2] + | record_syntax = mk_showString_app (op_con_str ++ " {") : + show_record_args ++ [mk_showString_app "}"] + | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args + + show_label l = mk_showString_app (nm ++ " = ") + -- Note the spaces around the "=" sign. If we + -- don't have them then we get Foo { x=-1 } and + -- the "=-" parses as a single lexeme. Only the + -- space after the '=' is necessary, but it + -- seems tidier to have them both sides. + where + nm = wrapOpParens (unpackFS l) + + show_args = zipWithEqual show_arg bs_needed arg_tys + (show_arg1:show_arg2:_) = show_args + show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args + + -- Assumption for record syntax: no of fields == no of + -- labelled fields (and in same order) + show_record_args = concat $ + intersperse [comma_space] $ + [ [show_label lbl, arg] + | (lbl,arg) <- zipEqual labels show_args ] + + show_arg :: RdrName -> Type -> LHsExpr GhcPs + show_arg b arg_ty + | isUnliftedType arg_ty + -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer + = nlHsApps compose_RDR + [mk_shows_app boxed_arg, mk_showString_app postfixMod] + | otherwise + = mk_showsPrec_app arg_prec arg + where + arg = nlHsVar b + boxed_arg = box "Show" arg arg_ty + postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty + + -- Fixity stuff + is_infix = dataConIsInfix data_con + con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm + arg_prec | record_syntax = 0 -- Record fields don't need parens + | otherwise = con_prec_plus_one + +wrapOpParens :: String -> String +wrapOpParens s | isSym s = '(' : s ++ ")" + | otherwise = s + +wrapOpBackquotes :: String -> String +wrapOpBackquotes s | isSym s = s + | otherwise = '`' : s ++ "`" + +isSym :: String -> Bool +isSym "" = False +isSym (c : _) = startsVarSym c || startsConSym c + +-- | showString :: String -> ShowS +mk_showString_app :: String -> LHsExpr GhcPs +mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) + +-- | showsPrec :: Show a => Int -> a -> ShowS +mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs +mk_showsPrec_app p x + = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x] + +-- | shows :: Show a => a -> ShowS +mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs +mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x + +getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer +getPrec is_infix get_fixity nm + | not is_infix = appPrecedence + | otherwise = getPrecedence get_fixity nm + +appPrecedence :: Integer +appPrecedence = fromIntegral maxPrecedence + 1 + -- One more than the precedence of the most + -- tightly-binding operator + +getPrecedence :: (Name -> Fixity) -> Name -> Integer +getPrecedence get_fixity nm + = case get_fixity nm of + Fixity x _assoc -> fromIntegral x + -- NB: the Report says that associativity is not taken + -- into account for either Read or Show; hence we + -- ignore associativity here + +{- +************************************************************************ +* * + Data instances +* * +************************************************************************ + +From the data type + + data T a b = T1 a b | T2 + +we generate + + $cT1 = mkDataCon $dT "T1" Prefix + $cT2 = mkDataCon $dT "T2" Prefix + $dT = mkDataType "Module.T" [] [$con_T1, $con_T2] + -- the [] is for field labels. + + instance (Data a, Data b) => Data (T a b) where + gfoldl k z (T1 a b) = z T `k` a `k` b + gfoldl k z T2 = z T2 + -- ToDo: add gmapT,Q,M, gfoldr + + gunfold k z c = case conIndex c of + I# 1# -> k (k (z T1)) + I# 2# -> z T2 + + toConstr (T1 _ _) = $cT1 + toConstr T2 = $cT2 + + dataTypeOf _ = $dT + + dataCast1 = gcast1 -- If T :: * -> * + dataCast2 = gcast2 -- if T :: * -> * -> * +-} + +gen_Data_binds :: SrcSpan + -> DerivInstTys + -> TcM (LHsBinds GhcPs, -- The method bindings + Bag AuxBindSpec) -- Auxiliary bindings +gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc}) + = do { -- See Note [Auxiliary binders] + dataT_RDR <- new_dataT_rdr_name loc rep_tc + ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons + + ; pure ( [ gfoldl_bind, gunfold_bind + , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ] + ++ gcast_binds + -- Auxiliary definitions: the data type and constructors + , listToBag + ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs + : zipWith (\data_con dataC_RDR -> + DerivDataConstr data_con dataC_RDR dataT_RDR) + data_cons dataC_RDRs ) + ) } + where + data_cons = tyConDataCons rep_tc + n_cons = length data_cons + + ------------ gfoldl + gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons) + + gfoldl_eqn con + = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed], + foldl' mk_k_app (z_Expr `nlHsApp` (nlHsVar (getRdrName con))) as_needed) + where + con_name :: RdrName + con_name = getRdrName con + as_needed = take (dataConSourceArity con) as_RDRs + mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) + + ------------ gunfold + gunfold_bind = mkSimpleGeneratedFunBind loc + gunfold_RDR + (noLocA [k_Pat, z_Pat, if n_cons == 1 then nlWildPat else c_Pat]) + gunfold_rhs + + gunfold_rhs + | [con] <- data_cons = mk_unfold_rhs con -- No need for case + | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) + (map gunfold_alt data_cons) + + gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) + mk_unfold_rhs dc = foldr nlHsApp + (z_Expr `nlHsApp` (nlHsVar (getRdrName dc))) + (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) + + mk_unfold_pat dc -- Last one is a wild-pat, to avoid + -- redundant test, and annoying warning + | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor + | otherwise = nlConPat intDataCon_RDR + [nlLitPat (HsIntPrim NoSourceText (toInteger tag))] + where + tag = dataConTag dc + + ------------ toConstr + toCon_bind dataC_RDRs + = mkFunBindEC 1 loc toConstr_RDR id + (zipWith to_con_eqn data_cons dataC_RDRs) + to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) + + ------------ dataTypeOf + dataTypeOf_bind dataT_RDR + = mkSimpleGeneratedFunBind + loc + dataTypeOf_RDR + (noLocA [nlWildPat]) + (nlHsVar dataT_RDR) + + ------------ gcast1/2 + -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> * + -- or dataCast2 x = gcast2 s -- if T :: * -> * -> * + -- (or nothing if T has neither of these two types) + + -- But care is needed for data families: + -- If we have data family D a + -- data instance D (a,b,c) = A | B deriving( Data ) + -- and we want instance ... => Data (D [(a,b,c)]) where ... + -- then we need dataCast1 x = gcast1 x + -- because D :: * -> * + -- even though rep_tc has kind * -> * -> * -> * + -- Hence looking for the kind of fam_tc not rep_tc + -- See #4896 + tycon_kind = case tyConFamInst_maybe rep_tc of + Just (fam_tc, _) -> tyConKind fam_tc + Nothing -> tyConKind rep_tc + gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR + | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR + | otherwise = [] + mk_gcast dataCast_RDR gcast_RDR + = [mkSimpleGeneratedFunBind loc dataCast_RDR (noLocA [nlVarPat f_RDR]) + (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)] + + +kind1, kind2 :: Kind +kind1 = typeToTypeKind +kind2 = liftedTypeKind `mkVisFunTyMany` kind1 + +gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR, + mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, + dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, + constr_RDR, dataType_RDR, + eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR , + eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , neInt_RDR , + eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR , + eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR , + eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR , + eqInt64_RDR , ltInt64_RDR , geInt64_RDR , gtInt64_RDR , leInt64_RDR , + eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , + eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR , + eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR, + eqWord32_RDR, ltWord32_RDR, geWord32_RDR, gtWord32_RDR, leWord32_RDR, + eqWord64_RDR, ltWord64_RDR, geWord64_RDR, gtWord64_RDR, leWord64_RDR, + eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , + eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , + eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR, + int8DataCon_RDR, int16DataCon_RDR, int32DataCon_RDR, int64DataCon_RDR, + word8DataCon_RDR, word16DataCon_RDR, word32DataCon_RDR, word64DataCon_RDR + :: RdrName +gfoldl_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "gfoldl") +gunfold_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "gunfold") +toConstr_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "toConstr") +dataTypeOf_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "dataTypeOf") +dataCast1_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "dataCast1") +dataCast2_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "dataCast2") +gcast1_RDR = varQual_RDR gHC_INTERNAL_TYPEABLE (fsLit "gcast1") +gcast2_RDR = varQual_RDR gHC_INTERNAL_TYPEABLE (fsLit "gcast2") +mkConstrTag_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "mkConstrTag") +constr_RDR = tcQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "Constr") +mkDataType_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "mkDataType") +dataType_RDR = tcQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "DataType") +conIndex_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "constrIndex") +prefix_RDR = dataQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "Prefix") +infix_RDR = dataQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "Infix") + +eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#") +ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#") +leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#") +gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#") +geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#") + +eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#") +neInt_RDR = varQual_RDR gHC_PRIM (fsLit "/=#") +ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" ) +leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#") +gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" ) +geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#") + +eqInt8_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt8#") +ltInt8_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt8#" ) +leInt8_RDR = varQual_RDR gHC_PRIM (fsLit "leInt8#") +gtInt8_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt8#" ) +geInt8_RDR = varQual_RDR gHC_PRIM (fsLit "geInt8#") + +eqInt16_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt16#") +ltInt16_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt16#" ) +leInt16_RDR = varQual_RDR gHC_PRIM (fsLit "leInt16#") +gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" ) +geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#") + +eqInt32_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt32#") +ltInt32_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt32#" ) +leInt32_RDR = varQual_RDR gHC_PRIM (fsLit "leInt32#") +gtInt32_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt32#" ) +geInt32_RDR = varQual_RDR gHC_PRIM (fsLit "geInt32#") + +eqInt64_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt64#") +ltInt64_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt64#" ) +leInt64_RDR = varQual_RDR gHC_PRIM (fsLit "leInt64#") +gtInt64_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt64#" ) +geInt64_RDR = varQual_RDR gHC_PRIM (fsLit "geInt64#") + +eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") +ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") +leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") +gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#") +geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#") + +eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#") +ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" ) +leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#") +gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" ) +geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#") + +eqWord16_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord16#") +ltWord16_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord16#" ) +leWord16_RDR = varQual_RDR gHC_PRIM (fsLit "leWord16#") +gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" ) +geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#") + +eqWord32_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord32#") +ltWord32_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord32#" ) +leWord32_RDR = varQual_RDR gHC_PRIM (fsLit "leWord32#") +gtWord32_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord32#" ) +geWord32_RDR = varQual_RDR gHC_PRIM (fsLit "geWord32#") + +eqWord64_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord64#") +ltWord64_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord64#" ) +leWord64_RDR = varQual_RDR gHC_PRIM (fsLit "leWord64#") +gtWord64_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord64#" ) +geWord64_RDR = varQual_RDR gHC_PRIM (fsLit "geWord64#") + +eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") +ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") +leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") +gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#") +geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#") + +eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#") +ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#") +leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#") +gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#") +geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#") + +eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##") +ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" ) +leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##") +gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) +geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") + +int8DataCon_RDR = dataQual_RDR gHC_INTERNAL_INT (fsLit "I8#") +int16DataCon_RDR = dataQual_RDR gHC_INTERNAL_INT (fsLit "I16#") +int32DataCon_RDR = dataQual_RDR gHC_INTERNAL_INT (fsLit "I32#") +int64DataCon_RDR = dataQual_RDR gHC_INTERNAL_INT (fsLit "I64#") +word8DataCon_RDR = dataQual_RDR gHC_INTERNAL_WORD (fsLit "W8#") +word16DataCon_RDR = dataQual_RDR gHC_INTERNAL_WORD (fsLit "W16#") +word32DataCon_RDR = dataQual_RDR gHC_INTERNAL_WORD (fsLit "W32#") +word64DataCon_RDR = dataQual_RDR gHC_INTERNAL_WORD (fsLit "W64#") +{- +************************************************************************ +* * + Lift instances +* * +************************************************************************ + +Example: + + data Foo a = Foo a | a :^: a deriving Lift + + ==> + + instance (Lift a) => Lift (Foo a) where + lift (Foo a) = ConE 'Foo `appE` (lift a) + lift ((:^:) u v) = ConE '(:^:) `appE` (lift u) `appE` (lift v) + + liftTyped (Foo a) = unsafeCodeCoerce (ConE 'Foo `appE` (lift a)) + liftTyped ((:^:) u v) = unsafeCodeCoerce (ConE '(:^:) `appE` (lift u) `appE` (lift v)) + +Note that we use variable quotes, in order to avoid the constructor being +lifted by implicit cross-stage lifting when `-XNoImplicitStagePersistence` is enabled. +-} + + +gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) +gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon + , dit_rep_tc_args = tycon_args }) = + ([lift_bind, liftTyped_bind], emptyBag) + where + lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) + (map (pats_etc mk_untyped_bracket ) data_cons) + liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr) + (map (pats_etc mk_typed_bracket ) data_cons) + + mk_untyped_bracket = id + mk_typed_bracket = nlHsApp unsafeCodeCoerce_Expr + + data_cons = getPossibleDataCons tycon tycon_args + + + pats_etc :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> DataCon -> ([LPat GhcPs], LHsExpr GhcPs) + pats_etc mk_bracket data_con + = ([con_pat], lift_Expr) + where + con_pat = nlConVarPat data_con_RDR as_needed + data_con_RDR = getRdrName data_con + con_arity = dataConSourceArity data_con + as_needed = take con_arity as_RDRs + lift_Expr = mk_bracket finish + con_brack :: LHsExpr GhcPs + con_brack = nlHsApps (Exact conEName) + [noLocA $ HsUntypedBracket noExtField + $ VarBr noSrcSpanA True (noLocA (Exact (dataConName data_con)))] + + finish = foldl' (\b1 b2 -> nlHsApps (Exact appEName) [b1, b2]) con_brack (map lift_var as_needed) + + lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed) + lift_var x = nlHsPar (mk_lift_expr x) + + mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed) + mk_lift_expr x = nlHsApps (Exact liftName) [nlHsVar x] + +{- +************************************************************************ +* * + Newtype-deriving instances +* * +************************************************************************ + +Note [Newtype-deriving instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We take every method in the original instance and `coerce` it to fit +into the derived instance. We need type applications on the argument +to `coerce` to make it obvious what instantiation of the method we're +coercing from. So from, say, + + class C a b where + op :: forall c. a -> [b] -> c -> Int + + newtype T x = MkT + + instance C a => C a (T x) where + op @c = coerce @(a -> [] -> c -> Int) + @(a -> [T x] -> c -> Int) + (op @c) + +In addition to the type applications, we also use a type abstraction to bring +the method-bound variable `c` into scope. We do this for two reasons: + +* We need to bring `c` into scope over the two type applications to `coerce`. + See Note [GND and QuantifiedConstraints] for more information on why this + is important. +* We need to bring `c` into scope over the type application to `op`. See + Note [GND and ambiguity] for more information on why this is important. + +(In the surface syntax, only specified type variables can be used in type +abstractions. Since a method signature could contain both specified and +inferred type variables, we need an internal-only way to represent the inferred +case. We handle this by smuggling a Specificity field in XInvisPat. See +Note [Inferred invisible patterns].) + +Giving 'coerce' two explicitly-visible type arguments grants us finer control +over how it should be instantiated. Recall + + coerce :: Coercible a b => a -> b + +By giving it explicit type arguments we deal with the case where +'op' has a higher rank type, and so we must instantiate 'coerce' with +a polytype. E.g. + + class C a where op :: a -> forall b. b -> b + newtype T x = MkT + instance C => C (T x) where + op = coerce @( -> forall b. b -> b) + @(T x -> forall b. b -> b) + op + +The use of type applications is crucial here. We have to instantiate +both type args of (coerce :: Coercible a b => a -> b) to polytypes, +and we can only do that with VTA or Quick Look. Here VTA seems more +appropriate for machine generated code: it's simple and robust. + +However, to allow VTA with polytypes we must switch on +-XImpredicativeTypes locally in GHC.Tc.Deriv.genInst. +See #8503 for more discussion. + +The following Notes describe further nuances of GeneralizedNewtypeDeriving: + +----- +-- In GHC.Tc.Deriv +----- + +* Note [Newtype deriving] +* Note [Newtype representation] +* Note [Recursive newtypes] +* Note [Determining whether newtype-deriving is appropriate] +* Note [GND and associated type families] +* Note [Bindings for Generalised Newtype Deriving] + +----- +-- In GHC.Tc.Deriv.Generate +----- + +* Note [Newtype-deriving trickiness] +* Note [GND and QuantifiedConstraints] +* Note [GND and ambiguity] + +Note [Inferred invisible patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following: + + class R a where + r :: forall b. Proxy b -> a + +When newtype-deriving an instance of `R`, following +Note [GND and QuantifiedConstraints], we might generate the following code: + + instance R => R where + r = \ @b -> coerce @(Proxy b -> ) + @(Proxy b -> ) + r + +The code being generated is an HsSyn AST, except for the arguments to coerce, +which are XHsTypes carrying Core types. As Core types, they must be fully +elaborated, so we actually want something more like the following: + + instance R => R where + r = \ @b -> coerce @(Proxy @{k} b -> ) + @(Proxy @{k} b -> ) + r + +where the `k` corresponds to the `k` in the elaborated type of `r`: + + class R (a :: Type) where + r :: forall {k :: Type} (b :: k). Proxy @{k} b -> a + +However, `k` is not bound in the definition of `r` in the derived instance, and +binding it requires a way to create an inferred (because `k` is inferred in the +signature of `r`) invisible pattern. + +So we actually generate the following for `R`: + + instance R => R where + r = \ @{k :: Type} -> \ @(b :: k) -> + coerce @(Proxy @{k} b -> ) + @(Proxy @{k} b -> ) + r + +The `\ @{k :: Type} ->` (note the braces!) is the big lambda that binds `k`, and +represents an inferred invisible pattern. Inferred invisible patterns aren't +allowed in the surface syntax of Haskell, for the reason that the order in +which inferred foralls are added to a signature is not specified, so it is +ambiguous which pattern would bind to which forall. But when deriving an +instance, the patterns are being created after the type of the method has been +elaborated, so an order for the inferred foralls has already been determined. +This makes inferred invisible patterns safe for internal use. + +(You might wonder if you could bring `k` into scope via the pattern signature +in `\ @(b :: k)`, but that does not work in general; e.g. if +`r :: Proxy Any -> a`; see `C5` in test `deriving-inferred-ty-arg`.) + +The implementation is straightforward: we have a Specificity field in +XInvisPat, which is always SpecifiedSpec when coming from the parser or +Template Haskell, but takes the specificity of the corresponding forall from +the method type during instance deriving. When type checking an invisible +pattern, we allow inferred patterns to bind inferred foralls just like we allow +specified patterns to bind specified foralls. + +More discussion of this scenario and some rejected alternatives at +https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13190 + +See also https://github.com/ghc-proposals/ghc-proposals/pull/675, which +was triggered by this ticket, and explores source-language syntax in this +space. + +Note [Newtype-deriving trickiness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12768): + class C a where { op :: D a => a -> a } + + instance C a => C [a] where { op = opList } + + opList :: (C a, D [a]) => [a] -> [a] + opList = ... + +Now suppose we try GND on this: + newtype N a = MkN [a] deriving( C ) + +The GND is expecting to get an implementation of op for N by +coercing opList, thus: + + instance C a => C (N a) where { op = opN } + + opN :: (C a, D (N a)) => N a -> N a + opN = coerce @([a] -> [a]) + @([N a] -> [N a] + opList :: D (N a) => [N a] -> [N a] + +But there is no reason to suppose that (D [a]) and (D (N a)) +are inter-coercible; these instances might completely different. +So GHC rightly rejects this code. + +Note [GND and QuantifiedConstraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example from #15290: + + class C m where + join :: m (m a) -> m a + + newtype T m a = MkT (m a) + + deriving instance + (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) + +The code that GHC used to generate for this was: + + instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) where + join = coerce @(forall a. m (m a) -> m a) + @(forall a. T m (T m a) -> T m a) + join + +This instantiates `coerce` at a polymorphic type, a form of impredicative +polymorphism, so we're already on thin ice. And in fact the ice breaks, +as we'll explain: + +The call to `coerce` gives rise to: + + Coercible (forall a. m (m a) -> m a) + (forall a. T m (T m a) -> T m a) + +And that simplified to the following implication constraint: + + forall a . m (T m a) ~R# m (m a) + +But because this constraint is under a `forall`, inside a type, we have to +prove it *without computing any term evidence* (hence the ). Alas, we +*must* generate a term-level evidence binding in order to instantiate the +quantified constraint! In response, GHC currently chooses not to use such +a quantified constraint. +See Note [Instances in no-evidence implications] in GHC.Tc.Solver.Equality. + +But this isn't the death knell for combining QuantifiedConstraints with GND. +On the contrary, if we generate GND bindings in a slightly different way, then +we can avoid this situation altogether. Instead of applying `coerce` to two +polymorphic types, we instead use a type abstraction to bind the type +variables, and omit the `forall`s in the type applications. More concretely, we +generate the following code instead: + + instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) where + join @a = coerce @( m (m a) -> m a) + @(T m (T m a) -> T m a) + join + +Now the visible type arguments are both monotypes, so we don't need any of this +funny quantified constraint instantiation business. While this particular +example no longer uses impredicative instantiation, we still need to enable +ImpredicativeTypes to typecheck GND-generated code for class methods with +higher-rank types. See Note [Newtype-deriving instances]. + +You might think that that second @(T m (T m a) -> T m a) argument is redundant +with the type information provided by the class, but in fact leaving it off +will break the following example (from the T12616 test case): + + type m ~> n = forall a. m a -> n a + data StateT s m a = ... + newtype OtherStateT s m a = OtherStateT (StateT s m a) + + class MonadTrans t where + lift :: (Monad m) => m ~> t m + + instance MonadTrans (StateT s) + + instance MonadTrans (OtherStateT s) where + lift @m = coerce @(m ~> StateT s m) + lift + +That is because we still need to instantiate the second argument of +coerce with a polytype, and we can only do that with VTA or QuickLook. + +Note [GND and ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~ +We make an effort to make the code generated through GND be robust w.r.t. +ambiguous type variables. Here are a couple of examples to illustrate this: + +* In this example (from #15637), the class-bound type variable `a` is ambiguous + in the type of `f`: + + class C a where + f :: String -- f :: forall a. C a => String + instance C () + where f = "foo" + newtype T = T () + deriving C + + A naïve attempt and generating a C T instance would be: + + instance C T where + f = coerce @String @String f + + This isn't going to typecheck, however, since GHC doesn't know what to + instantiate the type variable `a` with in the call to `f` in the method body. + (Note that `f :: forall a. String`!) To compensate for the possibility of + ambiguity here, we explicitly instantiate `a` like so: + + instance C T where + f = coerce @String @String (f @()) + + All better now. + +* In this example (adapted from #25148), the ambiguity arises from the `n` + type variable bound by the type signature for `fact1`: + + class Facts a where + fact1 :: forall n. Proxy a -> Dict (0 <= n) + newtype T a = MkT a + deriving newtype Facts + + When generating code for the derived `Facts` instance, we must use a type + abstraction to bring `n` into scope over the type applications to `coerce` + (see Note [Newtype-deriving instances] for more why this is needed). A first + attempt at generating the instance would be: + + instance Facts a => Facts (T a) where + fact1 @n = coerce @(Proxy a -> Dict (0 <= n)) + @(Proxy (T a) -> Dict (0 <= n)) + (fact1 @a) + + This still won't typecheck, however, as GHC doesn't know how to instantiate + `n` in the call to `fact1 @a`. To compensate for the possibility of ambiguity + here, we also visibly apply `n` in the call to `fact1` on the RHS: + + instance Facts a => Facts (T a) where + fact1 @n = coerce @(Proxy a -> Dict (0 <= n)) + @(Proxy (T a) -> Dict (0 <= n)) + (fact1 @a @n) -- Note the @n here! + + This takes advantage of the fact that we *already* need to bring `n` into + scope using a type abstraction, and so we are able to use it both for + instantiating the call to `coerce` and instantiating the call to `fact1`. + + Note that we use this same type abstractions-based approach for resolving + ambiguity in default methods, as described in Note [Default methods in + instances] (Wrinkle: Ambiguous types from vanilla method type signatures) in + GHC.Tc.TyCl.Instance. +-} + +gen_Newtype_binds :: SrcSpan + -> Class -- the class being derived + -> [TyVar] -- the tvs in the instance head (this includes + -- the tvs from both the class types and the + -- newtype itself) + -> [Type] -- instance head parameters (incl. newtype) + -> Type -- the representation type + -> LHsBinds GhcPs +-- See Note [Newtype-deriving instances] +gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty + = map mk_bind (classMethods cls) + 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 + + locn = noAnnSrcSpan loc' + -- For each class method, generate its derived binding. Using the first + -- example from + -- Note [Newtype-deriving instances]: + -- + -- class C a b where + -- op :: forall c. a -> [b] -> c -> Int + -- + -- newtype T x = MkT + -- + -- Then we would generate below: + -- + -- instance C a => C a (T x) where + -- + mk_bind :: Id -> LHsBind GhcPs + mk_bind meth_id + = -- The derived binding, e.g., + -- + -- op @c = coerce @(a -> [] -> c -> Int) + -- @(a -> [T x] -> c -> Int) + -- op + mkRdrFunBind loc_meth_RDR [mkSimpleMatch + (mkPrefixFunRhs loc_meth_RDR noAnn) + (noLocA (map mk_ty_pat to_tvbs)) rhs_expr] + + where + Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id + (_, _, from_tau) = tcSplitSigmaTy from_ty + (to_tvbs, to_rho) = tcSplitForAllInvisTVBinders to_ty + (_, to_tau) = tcSplitPhiTy to_rho + -- The `to_tvbs` bind variables that are mentioned in `to_rho` and + -- hence in `to_tau`. So we bring `to_tvbs` into scope via the + -- `mkSimpleMatch` above, so that their use in `to_tau` in `rhs_expr` + -- is well-scoped. + + mk_ty_pat :: VarBndr TyVar Specificity -> LPat GhcPs + mk_ty_pat (Bndr tv spec) = noLocA $ InvisPat (noAnn, spec) $ mkHsTyPat $ + nlHsTyVar NotPromoted $ getRdrName tv + + meth_RDR = getRdrName meth_id + loc_meth_RDR = L locn meth_RDR + + rhs_expr = nlHsVar (getRdrName coerceId) + `nlHsAppType` from_tau + `nlHsAppType` to_tau + `nlHsApp` meth_app + + -- The class method, applied to the following types to avoid potential + -- ambiguity: + -- + -- 1. All of the class instance types (including the representation type) + -- 2. All of `to_tvbs` + -- + -- See Note [GND and ambiguity]. + meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $ + filterOutInferredTypes (classTyCon cls) underlying_inst_tys ++ -- (1) + [mkTyVarTy tv | Bndr tv spec <- to_tvbs, spec /= InferredSpec] -- (2) + -- Filter out any inferred arguments, since they can't be + -- applied with visible type application. + +gen_Newtype_fam_insts :: SrcSpan + -> Class -- the class being derived + -> [TyVar] -- the tvs in the instance head (this includes + -- the tvs from both the class types and the + -- newtype itself) + -> [Type] -- instance head parameters (incl. newtype) + -> Type -- the representation type + -> TcM [FamInst] +-- See Note [GND and associated type families] in GHC.Tc.Deriv +gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty + = assert (all (not . isDataFamilyTyCon) ats) $ + mapM mk_atf_inst ats + where + -- Same as inst_tys, but with the last argument type replaced by the + -- representation type. + underlying_inst_tys :: [Type] + underlying_inst_tys = changeLast inst_tys rhs_ty + + ats = classATs cls + locn = noAnnSrcSpan loc' + cls_tvs = classTyVars cls + in_scope = mkInScopeSetList inst_tvs + lhs_env = zipTyEnv cls_tvs inst_tys + lhs_subst = mkTvSubst in_scope lhs_env + rhs_env = zipTyEnv cls_tvs underlying_inst_tys + rhs_subst = mkTvSubst in_scope rhs_env + + mk_atf_inst :: TyCon -> TcM FamInst + mk_atf_inst fam_tc = do + rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc)) + rep_lhs_tys + let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' + fam_tc rep_lhs_tys rep_rhs_ty + checkFamPatBinders fam_tc (rep_tvs' ++ rep_cvs') emptyVarSet rep_lhs_tys rep_rhs_ty + -- Check (c) from Note [GND and associated type families] in GHC.Tc.Deriv + checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom) + newFamInst SynFamilyInst axiom + where + fam_tvs = tyConTyVars fam_tc + (_, rep_lhs_tys) = substATBndrs lhs_subst fam_tvs + (_, rep_rhs_tys) = substATBndrs rhs_subst fam_tvs + rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys + rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys + (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs + rep_tvs' = scopedSort rep_tvs + rep_cvs' = scopedSort rep_cvs + +nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs +nlHsAppType e s = noLocA (HsAppType noAnn e hs_ty) + where + hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s + +nlHsCoreTy :: HsCoreTy -> LHsType GhcPs +nlHsCoreTy = noLocA . XHsType . HsCoreTy + +mkCoerceClassMethEqn :: Class -- the class being derived + -> [TyVar] -- the tvs in the instance head (this includes + -- the tvs from both the class types and the + -- newtype itself) + -> [Type] -- instance head parameters (incl. newtype) + -> Type -- the representation type + -> Id -- the method to look at + -> Pair Type +-- See Note [Newtype-deriving instances] +-- See also Note [Newtype-deriving trickiness] +-- The pair is the (from_type, to_type), where to_type is +-- the type of the method we are trying to get +mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id + = Pair (substTy rhs_subst user_meth_ty) + (substTy lhs_subst user_meth_ty) + where + cls_tvs = classTyVars cls + in_scope = mkInScopeSetList inst_tvs + lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys) + rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty)) + (_class_tvs, _class_constraint, user_meth_ty) + = tcSplitMethodTy (varType id) + +{- +************************************************************************ +* * +\subsection{Generating extra binds (@tag2con@, etc.)} +* * +************************************************************************ + +\begin{verbatim} +data Foo ... = ... + +tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# +maxtag_Foo :: Int -- ditto (NB: not unlifted) +\end{verbatim} + +The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) +fiddling around. +-} + +-- | Generate the full code for an auxiliary binding. +-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@. +genAuxBindSpecOriginal :: SrcSpan -> AuxBindSpec + -> (LHsBind GhcPs, LSig GhcPs) +genAuxBindSpecOriginal loc spec + = (gen_bind spec, + L loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)] + (genAuxBindSpecSig loc spec))) + where + loca = noAnnSrcSpan loc + locn = noAnnSrcSpan loc + gen_bind :: AuxBindSpec -> LHsBind GhcPs + gen_bind (DerivTag2Con _ tag2con_RDR) + = mkFunBindSE 0 loc tag2con_RDR + [([nlConVarPat intDataCon_RDR [a_RDR]], + nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)] + + gen_bind (DerivMaxTag tycon maxtag_RDR) + = mkHsVarBind loc maxtag_RDR rhs + where + rhs = nlHsApp (nlHsVar intDataCon_RDR) + (nlHsLit (HsIntPrim NoSourceText max_tag)) + max_tag = case (tyConDataCons tycon) of + data_cons -> toInteger ((length data_cons) - fIRST_TAG) + + gen_bind (DerivDataDataType tycon dataT_RDR dataC_RDRs) + = mkHsVarBind loc dataT_RDR rhs + where + tc_name = tyConName tycon + tc_name_string = occNameFS (getOccName tc_name) + definition_mod_name = moduleNameFS (moduleName (expectJust $ nameModule_maybe tc_name)) + rhs = nlHsVar mkDataType_RDR + `nlHsApp` nlHsLit (mkHsStringFS (concatFS [definition_mod_name, fsLit ".", tc_name_string])) + `nlHsApp` nlList (map nlHsVar dataC_RDRs) + + gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR) + = mkHsVarBind loc dataC_RDR rhs + where + rhs = nlHsApps mkConstrTag_RDR constr_args + + constr_args + = [ nlHsVar dataT_RDR -- DataType + , nlHsLit (mkHsStringFS (occNameFS dc_occ)) -- Constructor name + , nlHsIntLit (toInteger (dataConTag dc)) -- Constructor tag + , nlList labels -- Field labels + , nlHsVar fixity ] -- Fixity + + labels = map (nlHsLit . mkHsStringFS . field_label . flLabel) + (dataConFieldLabels dc) + dc_occ = getOccName dc + is_infix = isDataSymOcc dc_occ + fixity | is_infix = infix_RDR + | otherwise = prefix_RDR + +-- | Generate the code for an auxiliary binding that is a duplicate of another +-- auxiliary binding. +-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@. +genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec + -> (LHsBind GhcPs, LSig GhcPs) +genAuxBindSpecDup loc original_rdr_name dup_spec + = (mkHsVarBind loc dup_rdr_name (nlHsVar original_rdr_name), + L loca (TypeSig noAnn [L locn dup_rdr_name] + (genAuxBindSpecSig loc dup_spec))) + where + loca = noAnnSrcSpan loc + locn = noAnnSrcSpan loc + dup_rdr_name = auxBindSpecRdrName dup_spec + +-- | Generate the type signature of an auxiliary binding. +-- See @Note [Auxiliary binders]@. +genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs +genAuxBindSpecSig loc spec = case spec of + DerivTag2Con tycon _ + -> mk_sig $ L (noAnnSrcSpan loc) $ + XHsType $ HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ + intTy `mkVisFunTyMany` mkParentType tycon + DerivMaxTag _ _ + -> mk_sig (L (noAnnSrcSpan loc) (XHsType (HsCoreTy intTy))) + DerivDataDataType _ _ _ + -> mk_sig (nlHsTyVar NotPromoted dataType_RDR) + DerivDataConstr _ _ _ + -> mk_sig (nlHsTyVar NotPromoted constr_RDR) + where + mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType + +-- | Take a 'Bag' of 'AuxBindSpec's and generate the code for auxiliary +-- bindings based on the declarative descriptions in the supplied +-- 'AuxBindSpec's. See @Note [Auxiliary binders]@. +genAuxBinds :: SrcSpan -> Bag AuxBindSpec + -> Bag (LHsBind GhcPs, LSig GhcPs) +genAuxBinds loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag) + where + -- Perform a CSE-like pass over the generated auxiliary bindings to avoid + -- code duplication, as described in + -- Note [Auxiliary binders] (Wrinkle: Reducing code duplication). + -- The OccEnv remembers the first occurrence of each sort of auxiliary + -- binding and maps it to the unique RdrName for that binding. + gen_aux_bind_spec :: AuxBindSpec + -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs)) + -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs)) + gen_aux_bind_spec spec (original_rdr_name_env, spec_bag) = + case lookupOccEnv original_rdr_name_env spec_occ of + Nothing + -> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name + , genAuxBindSpecOriginal loc spec `consBag` spec_bag ) + Just original_rdr_name + -> ( original_rdr_name_env + , genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag ) + where + spec_rdr_name = auxBindSpecRdrName spec + spec_occ = rdrNameOcc spec_rdr_name + +mkParentType :: TyCon -> Type +-- Turn the representation tycon of a family into +-- a use of its family constructor +mkParentType tc + = case tyConFamInst_maybe tc of + Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc)) + Just (fam_tc,tys) -> mkTyConApp fam_tc tys + +{- +************************************************************************ +* * +\subsection{Utility bits for generating bindings} +* * +************************************************************************ +-} + +-- | Make a function binding. If no equations are given, produce a function +-- with the given arity that produces a stock error. +mkFunBindSE :: Arity -> SrcSpan -> RdrName + -> [([LPat GhcPs], LHsExpr GhcPs)] + -> LHsBind GhcPs +mkFunBindSE arity loc fun pats_and_exprs + = mkRdrFunBindSE arity (L (noAnnSrcSpan loc) fun) matches + where + matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun) noAnn) + (noLocA (map (parenthesizePat appPrec) p)) e + emptyLocalBinds + | (p,e) <-pats_and_exprs] + +mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsBind GhcPs +mkRdrFunBind fun@(L loc _fun_rdr) matches + = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches) + +-- | Make a function binding. If no equations are given, produce a function +-- with the given arity that uses an empty case expression for the last +-- argument that is passes to the given function to produce the right-hand +-- side. +mkFunBindEC :: Arity -> SrcSpan -> RdrName + -> (LHsExpr GhcPs -> LHsExpr GhcPs) + -> [([LPat GhcPs], LHsExpr GhcPs)] + -> LHsBind GhcPs +mkFunBindEC arity loc fun catch_all pats_and_exprs + = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpan loc) fun) matches + where + matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun) noAnn) + (noLocA (map (parenthesizePat appPrec) p)) e + emptyLocalBinds + | (p,e) <- pats_and_exprs ] + +-- | Produces a function binding. When no equations are given, it generates +-- a binding of the given arity and an empty case expression +-- for the last argument that it passes to the given function to produce +-- the right-hand side. +mkRdrFunBindEC :: Arity + -> (LHsExpr GhcPs -> LHsExpr GhcPs) + -> LocatedN RdrName + -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsBind GhcPs +mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches + = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches') + where + -- Catch-all eqn looks like + -- fmap _ z = case z of {} + -- or + -- traverse _ z = pure (case z of) + -- or + -- foldMap _ z = mempty + -- It's needed if there no data cons at all, + -- which can happen with -XEmptyDataDecls + -- See #4302 + matches' = if null matches + then [mkMatch (mkPrefixFunRhs fun noAnn) + (noLocA (replicate (arity - 1) (nlWildPat) ++ [z_Pat])) + (catch_all $ nlHsCase z_Expr []) + emptyLocalBinds] + else matches + +-- | Produces a function binding. When there are no equations, it generates +-- a binding with the given arity that produces an error based on the name of +-- the type of the last argument. +mkRdrFunBindSE :: Arity -> LocatedN RdrName -> + [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs +mkRdrFunBindSE arity fun@(L loc fun_rdr) matches + = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches') + where + -- Catch-all eqn looks like + -- compare _ _ = error "Void compare" + -- It's needed if there no data cons at all, + -- which can happen with -XEmptyDataDecls + -- See #4302 + matches' = if null matches + then [mkMatch (mkPrefixFunRhs fun noAnn) + (noLocA (replicate arity nlWildPat)) + (error_Expr str) emptyLocalBinds] + else matches + str = fsLit "Void " `appendFS` occNameFS (rdrNameOcc fun_rdr) + + +box :: String -- The class involved + -> LHsExpr GhcPs -- The argument + -> Type -- The argument type + -> LHsExpr GhcPs -- Boxed version of the arg +-- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer +box cls_str arg arg_ty = nlHsApp (assoc_ty_id cls_str boxConTbl arg_ty) arg + +--------------------- +primOrdOps :: String -- The class involved + -> Type -- The type + -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt) +-- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer +primOrdOps str ty = assoc_ty_id str ordOpTbl ty + +ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] +ordOpTbl + = [(charPrimTy , (ltChar_RDR , leChar_RDR + , eqChar_RDR , geChar_RDR , gtChar_RDR )) + ,(intPrimTy , (ltInt_RDR , leInt_RDR + , eqInt_RDR , geInt_RDR , gtInt_RDR )) + ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR + , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) + ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR + , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) + ,(int32PrimTy , (ltInt32_RDR , leInt32_RDR + , eqInt32_RDR , geInt32_RDR , gtInt32_RDR )) + ,(int64PrimTy , (ltInt64_RDR , leInt64_RDR + , eqInt64_RDR , geInt64_RDR , gtInt64_RDR )) + ,(wordPrimTy , (ltWord_RDR , leWord_RDR + , eqWord_RDR , geWord_RDR , gtWord_RDR )) + ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR + , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) + ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR + , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) + ,(word32PrimTy, (ltWord32_RDR, leWord32_RDR + , eqWord32_RDR, geWord32_RDR, gtWord32_RDR )) + ,(word64PrimTy, (ltWord64_RDR, leWord64_RDR + , eqWord64_RDR, geWord64_RDR, gtWord64_RDR )) + ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR + , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) + ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR + , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) + ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR + , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] + +-- A mapping from a primitive type to a DataCon of its boxed version. +boxConTbl :: [(Type, LHsExpr GhcPs)] +boxConTbl = + [ (charPrimTy , nlHsVar $ getRdrName charDataCon) + , (intPrimTy , nlHsVar $ getRdrName intDataCon) + , (wordPrimTy , nlHsVar $ getRdrName wordDataCon) + , (floatPrimTy , nlHsVar $ getRdrName floatDataCon) + , (doublePrimTy, nlHsVar $ getRdrName doubleDataCon) + , (int8PrimTy, nlHsVar int8DataCon_RDR) + , (word8PrimTy, nlHsVar word8DataCon_RDR) + , (int16PrimTy, nlHsVar int16DataCon_RDR) + , (word16PrimTy, nlHsVar word16DataCon_RDR) + , (int32PrimTy, nlHsVar int32DataCon_RDR) + , (word32PrimTy, nlHsVar word32DataCon_RDR) + , (int64PrimTy, nlHsVar int64DataCon_RDR) + , (word64PrimTy, nlHsVar word64DataCon_RDR) + ] + + +-- | A table of postfix modifiers for unboxed values. +-- Following https://github.com/ghc-proposals/ghc-proposals/pull/596, +-- we use the ExtendedLiterals syntax for sized literals. +postfixModTbl :: [(Type, String)] +postfixModTbl + = [(charPrimTy , "#" ) + ,(intPrimTy , "#" ) + ,(wordPrimTy , "##") + ,(floatPrimTy , "#" ) + ,(doublePrimTy, "##") + ,(int8PrimTy , "#Int8") + ,(word8PrimTy , "#Word8") + ,(int16PrimTy , "#Int16") + ,(word16PrimTy, "#Word16") + ,(int32PrimTy , "#Int32") + ,(word32PrimTy, "#Word32") + ,(int64PrimTy , "#Int64") + ,(word64PrimTy, "#Word64") + ] + +-- | Lookup `Type` in an association list. +assoc_ty_id :: HasDebugCallStack => String -- The class involved + -> [(Type,a)] -- The table + -> Type -- The type + -> a -- The result of the lookup +assoc_ty_id cls_str tbl ty + | Just a <- assoc_ty_id_maybe tbl ty = a + | otherwise = + pprPanic "Error in deriving:" + (text "Can't derive" <+> text cls_str <+> + text "for primitive type" <+> ppr ty) + +-- | Lookup `Type` in an association list. +assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a +assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl + +----------------------------------------------------------------------- + +and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +and_Expr a b = genOpApp a and_RDR b + +----------------------------------------------------------------------- + +eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +eq_Expr ty a b + | not (isUnliftedType ty) = genOpApp a eq_RDR b + | otherwise = genPrimOpApp a prim_eq b + where + (_, _, prim_eq, _, _) = primOrdOps "Eq" ty + +untag_Expr :: [(RdrName, RdrName)] + -> LHsExpr GhcPs -> LHsExpr GhcPs +untag_Expr [] expr = expr +untag_Expr ((untag_this, put_tag_here) : more) expr + = nlHsCase (nlHsPar (nlHsVarApps dataToTag_RDR [untag_this])) {-of-} + [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr more expr)] + +enum_from_to_Expr + :: LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs +enum_from_then_to_Expr + :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs + +enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2 +enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2 + +showParen_Expr + :: LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs + +showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 + +nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs +nested_compose_Expr = + nlHsLam . mkSimpleMatch (LamAlt LamSingle) (noLocA [z_Pat]) . go + where + -- Previously we used (`.`), but inlining its definition improves compiler + -- performance significantly since we no longer need to typecheck lots of + -- (.) applications (each which needed three type applications, all @String) + -- (See #25453 for why this is especially slow currently) + go [] = panic "nested_compose_expr" -- Arg is always non-empty + go [e] = nlHsApp e z_Expr + go (e:es) = nlHsApp e (go es) + +-- impossible_Expr is used in case RHSs that should never happen. +-- We generate these to keep the desugarer from complaining that they *might* happen! +error_Expr :: FastString -> LHsExpr GhcPs +error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsStringFS string)) + +-- genOpApp wraps brackets round the operator application, so that the +-- renamer won't subsequently try to re-associate it. +genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs +genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) + +genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs +genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2)) + +a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR + :: RdrName +a_RDR = mkVarUnqual (fsLit "a") +b_RDR = mkVarUnqual (fsLit "b") +c_RDR = mkVarUnqual (fsLit "c") +d_RDR = mkVarUnqual (fsLit "d") +f_RDR = mkVarUnqual (fsLit "f") +k_RDR = mkVarUnqual (fsLit "k") +z_RDR = mkVarUnqual (fsLit "z") +ah_RDR = mkVarUnqual (fsLit "a#") +bh_RDR = mkVarUnqual (fsLit "b#") +ch_RDR = mkVarUnqual (fsLit "c#") +dh_RDR = mkVarUnqual (fsLit "d#") + +as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] +as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] +cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] + +a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, + true_Expr, pure_Expr, unsafeCodeCoerce_Expr :: LHsExpr GhcPs +a_Expr = nlHsVar a_RDR +b_Expr = nlHsVar b_RDR +c_Expr = nlHsVar c_RDR +z_Expr = nlHsVar z_RDR +ltTag_Expr = nlHsVar ltTag_RDR +eqTag_Expr = nlHsVar eqTag_RDR +gtTag_Expr = nlHsVar gtTag_RDR +false_Expr = nlHsVar false_RDR +true_Expr = nlHsVar true_RDR +pure_Expr = nlHsVar pure_RDR +unsafeCodeCoerce_Expr = nlHsVar unsafeCodeCoerce_RDR + +a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs +a_Pat = nlVarPat a_RDR +b_Pat = nlVarPat b_RDR +c_Pat = nlVarPat c_RDR +d_Pat = nlVarPat d_RDR +k_Pat = nlVarPat k_RDR +z_Pat = nlVarPat z_RDR + +minusInt_RDR, tagToEnum_RDR :: RdrName +minusInt_RDR = getRdrName (primOpId IntSubOp ) +tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) + +new_tag2con_rdr_name, new_maxtag_rdr_name + :: SrcSpan -> TyCon -> TcM RdrName +-- Generates Exact RdrNames, for the binding positions +new_tag2con_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkTag2ConOcc +new_maxtag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkMaxTagOcc + +new_dataT_rdr_name :: SrcSpan -> TyCon -> TcM RdrName +new_dataT_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkDataTOcc + +new_dataC_rdr_name :: SrcSpan -> DataCon -> TcM RdrName +new_dataC_rdr_name dflags dc = new_dc_deriv_rdr_name dflags dc mkDataCOcc + +new_tc_deriv_rdr_name :: SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName +new_tc_deriv_rdr_name loc tycon occ_fun + = newAuxBinderRdrName loc (tyConName tycon) occ_fun + +new_dc_deriv_rdr_name :: SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName +new_dc_deriv_rdr_name loc dc occ_fun + = newAuxBinderRdrName loc (dataConName dc) occ_fun + +-- | Generate the name for an auxiliary binding, giving it a fresh 'Unique'. +-- Returns an 'Exact' 'RdrName' with an underlying 'System' 'Name'. +-- See @Note [Auxiliary binders]@. +newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName +newAuxBinderRdrName loc parent occ_fun = do + uniq <- newUnique + pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc + +-- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@ +-- whose return types match when checked against @tycon_args@. +-- +-- See Note [Filter out impossible GADT data constructors] +getPossibleDataCons :: TyCon -> [Type] -> [DataCon] +getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon + where + isPossible dc = not $ dataConCannotMatch (dataConInstUnivs dc tycon_args) dc + +-- | Information about the arguments to the class in a stock- or +-- newtype-derived instance. For a @deriving@-generated instance declaration +-- such as this one: +-- +-- @ +-- instance Ctx => Cls cls_ty_1 ... cls_ty_m (TC tc_arg_1 ... tc_arg_n) where ... +-- @ +-- +-- * 'dit_cls_tys' corresponds to @cls_ty_1 ... cls_ty_m@. +-- +-- * 'dit_tc' corresponds to @TC@. +-- +-- * 'dit_tc_args' corresponds to @tc_arg_1 ... tc_arg_n@. +-- +-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for a +-- more in-depth explanation, including the relationship between +-- 'dit_tc'/'dit_rep_tc' and 'dit_tc_args'/'dit_rep_tc_args'. +-- +-- A 'DerivInstTys' value can be seen as a more structured representation of +-- the 'denv_inst_tys' in a 'DerivEnv', as the 'denv_inst_tys' is equal to +-- @dit_cls_tys ++ ['mkTyConApp' dit_tc dit_tc_args]@. Other parts of the +-- instance declaration can be found in the 'DerivEnv'. For example, the @Cls@ +-- in the example above corresponds to the 'denv_cls' field of 'DerivEnv'. +-- +-- Similarly, the type variables that appear in a 'DerivInstTys' value are the +-- same type variables as the 'denv_tvs' in the parent 'DerivEnv'. Accordingly, +-- if we are inferring an instance context, the type variables will be 'TcTyVar' +-- skolems. Otherwise, they will be ordinary 'TyVar's. +-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer". +data DerivInstTys = DerivInstTys + { dit_cls_tys :: [Type] + -- ^ Other arguments to the class except the last + , dit_tc :: TyCon + -- ^ Type constructor for which the instance is requested + -- (last arguments to the type class) + , dit_tc_args :: [Type] + -- ^ Arguments to the type constructor + , dit_rep_tc :: TyCon + -- ^ The representation tycon for 'dit_tc' + -- (for data family instances). Otherwise the same as 'dit_tc'. + , dit_rep_tc_args :: [Type] + -- ^ The representation types for 'dit_tc_args' + -- (for data family instances). Otherwise the same as 'dit_tc_args'. + , dit_dc_inst_arg_env :: DataConEnv [Type] + -- ^ The cached results of instantiating each data constructor's field + -- types using @'dataConInstUnivs' data_con 'dit_rep_tc_args'@. + -- See @Note [Instantiating field types in stock deriving]@. + -- + -- This field is only used for stock-derived instances and goes unused + -- for newtype-derived instances. It is put here mainly for the sake of + -- convenience. + } + +instance Outputable DerivInstTys where + ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args + , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args + , dit_dc_inst_arg_env = dc_inst_arg_env }) + = hang (text "DerivInstTys") + 2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys + , text "dit_tc" <+> ppr tc + , text "dit_tc_args" <+> ppr tc_args + , text "dit_rep_tc" <+> ppr rep_tc + , text "dit_rep_tc_args" <+> ppr rep_tc_args + , text "dit_dc_inst_arg_env" <+> ppr dc_inst_arg_env ]) + +-- | Look up a data constructor's instantiated field types in a 'DerivInstTys'. +-- See @Note [Instantiating field types in stock deriving]@. +derivDataConInstArgTys :: DataCon -> DerivInstTys -> [Type] +derivDataConInstArgTys dc dit = + case lookupUFM (dit_dc_inst_arg_env dit) dc of + Just inst_arg_tys -> inst_arg_tys + Nothing -> pprPanic "derivDataConInstArgTys" (ppr dc) + +-- | @'buildDataConInstArgEnv' tycon arg_tys@ constructs a cache that maps +-- each of @tycon@'s data constructors to their field types, with are to be +-- instantiated with @arg_tys@. +-- See @Note [Instantiating field types in stock deriving]@. +buildDataConInstArgEnv :: TyCon -> [Type] -> DataConEnv [Type] +buildDataConInstArgEnv rep_tc rep_tc_args = + listToUFM [ (dc, inst_arg_tys) + | dc <- tyConDataCons rep_tc + , let (_, _, inst_arg_tys) = + dataConInstSig dc $ dataConInstUnivs dc rep_tc_args + ] + +-- | Apply a substitution to all of the 'Type's contained in a 'DerivInstTys'. +-- See @Note [Instantiating field types in stock deriving]@ for why we need to +-- substitute into a 'DerivInstTys' in the first place. +substDerivInstTys :: Subst -> DerivInstTys -> DerivInstTys +substDerivInstTys subst + dit@(DerivInstTys { dit_cls_tys = cls_tys, dit_tc_args = tc_args + , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args }) + + | isEmptyTCvSubst subst + = dit + | otherwise + = dit{ dit_cls_tys = cls_tys' + , dit_tc_args = tc_args' + , dit_rep_tc_args = rep_tc_args' + , dit_dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args' + } + where + cls_tys' = substTys subst cls_tys + tc_args' = substTys subst tc_args + rep_tc_args' = substTys subst rep_tc_args + +-- | Zonk the 'TcTyVar's in a 'DerivInstTys' value to 'TyVar's. +-- See @Note [What is zonking?]@ in "GHC.Tc.Zonk.Type". +-- +-- 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 :: DerivInstTys -> ZonkT TcM DerivInstTys +zonkDerivInstTys 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 cls_tys + tc_args' <- zonkTcTypesToTypesX tc_args + rep_tc_args' <- zonkTcTypesToTypesX rep_tc_args + pure dit{ dit_cls_tys = cls_tys' + , dit_tc_args = tc_args' + , dit_rep_tc_args = rep_tc_args' + , dit_dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args' + } + +{- +Note [Auxiliary binders] +~~~~~~~~~~~~~~~~~~~~~~~~ +We often want to make top-level auxiliary bindings in derived instances. +For example, derived Ix instances sometimes generate code like this: + + data T = ... + deriving instance Ix T + + ==> + + instance Ix T where + range (a, b) = map tag2con_T [dataToTag# a .. dataToTag# b] + + $tag2con_T :: Int -> T + $tag2con_T = ...code.... + +Note that multiple instances of the same type might need to use the same sort +of auxiliary binding. For example, $tag2con is used not only in derived Ix +instances, but also in derived Enum instances: + + deriving instance Enum T + + ==> + + instance Enum T where + toEnum i = tag2con_T i + + $tag2con_T :: Int -> T + $tag2con_T = ...code.... + +How do we ensure that the two usages of $tag2con_T do not conflict with each +other? We do so by generating a separate $tag2con_T definition for each +instance, giving each definition an Exact RdrName with a separate Unique to +avoid name clashes: + + instance Ix T where + range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b] + + instance Enum T where + toEnum a = $tag2con_T{Uniq2} a + + -- $tag2con_T{Uniq1} and $tag2con_T{Uniq2} are Exact RdrNames with + -- underlying System Names + + $tag2con_T{Uniq1} :: Int -> T + $tag2con_T{Uniq1} = ...code.... + + $tag2con_T{Uniq2} :: Int -> T + $tag2con_T{Uniq2} = ...code.... + +Note that: + +* This is /precisely/ the same mechanism that we use for + Template Haskell–generated code. + See Note [Binders in Template Haskell] in GHC.ThToHs. + There we explain why we use a 'System' flavour of the Name we generate. + +* See "Wrinkle: Reducing code duplication" for how we can avoid generating + lots of duplicated code in common situations. + +* See "Wrinkle: Why we sometimes do generated duplicate code" for why this + de-duplication mechanism isn't perfect, so we fall back to CSE + (which is very effective within a single module). + +* Note that the "_T" part of "$tag2con_T" is just for debug-printing + purposes. We could call them all "$tag2con", or even just "aux". + The Unique is enough to keep them separate. + + This is important: we might be generating an Eq instance for two + completely-distinct imported type constructors T. + +At first glance, it might appear that this plan is infeasible, as it would +require generating multiple top-level declarations with the same OccName. But +what if auxiliary bindings /weren't/ top-level? Conceptually, we could imagine +that auxiliary bindings are /local/ to the instance declarations in which they +are used. Using some hypothetical Haskell syntax, it might look like this: + + let { + $tag2con_T{Uniq1} :: Int -> T + $tag2con_T{Uniq1} = ...code.... + + $tag2con_T{Uniq2} :: Int -> T + $tag2con_T{Uniq2} = ...code.... + } in { + instance Ix T where + range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b] + + instance Enum T where + toEnum a = $tag2con_T{Uniq2} a + } + +Making auxiliary bindings local is key to making this work, since GHC will +not reject local bindings with duplicate names provided that: + +* Each binding has a distinct unique, and +* Each binding has an Exact RdrName with a System Name. + +Even though the hypothetical Haskell syntax above does not exist, we can +accomplish the same end result through some sleight of hand in renameDeriv: +we rename auxiliary bindings with rnLocalValBindsLHS. (If we had used +rnTopBindsLHS instead, then GHC would spuriously reject auxiliary bindings +with the same OccName as duplicates.) Luckily, no special treatment is needed +to typecheck them; we can typecheck them as normal top-level bindings +(using tcTopBinds) without danger. + +----- +-- Wrinkle: Reducing code duplication +----- + +While the approach of generating copies of each sort of auxiliary binder per +derived instance is simpler, it can lead to code bloat if done naïvely. +Consider this example: + + data T = ... + deriving instance Eq T + deriving instance Ord T + + ==> + + instance Ix T where + range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b] + + instance Enum T where + toEnum a = $tag2con_T{Uniq2} a + + $tag2con_T{Uniq1} :: Int -> T + $tag2con_T{Uniq1} = ...code.... + + $tag2con_T{Uniq2} :: Int -> T + $tag2con_T{Uniq2} = ...code.... + +$tag2con_T{Uniq1} and $tag2con_T{Uniq2} are blatant duplicates of each other, +which is not ideal. Surely GHC can do better than that at the very least! And +indeed it does. Within the genAuxBinds function, GHC performs a small CSE-like +pass to define duplicate auxiliary binders in terms of the original one. On +the example above, that would look like this: + + $tag2con_T{Uniq1} :: Int -> T + $tag2con_T{Uniq1} = ...code.... + + $tag2con_T{Uniq2} :: Int -> T + $tag2con_T{Uniq2} = $tag2con_T{Uniq1} + +(Note that this pass does not cover all possible forms of code duplication. +See "Wrinkle: Why we sometimes do generate duplicate code" for situations +where genAuxBinds does not deduplicate code.) + +To start, genAuxBinds is given a list of AuxBindSpecs, which describe the sort +of auxiliary bindings that must be generates along with their RdrNames. As +genAuxBinds processes this list, it marks the first occurrence of each sort of +auxiliary binding as the "original". For example, if genAuxBinds sees a +DerivCon2Tag for the first time (with the RdrName $tag2con_T{Uniq1}), then it +will generate the full code for a $tag2con binding: + + $tag2con_T{Uniq1} :: Int -> T + $tag2con_T{Uniq1} = ...code.... + +Later, if genAuxBinds sees any additional DerivCon2Tag values, it will treat +them as duplicates. For example, if genAuxBinds later sees a DerivCon2Tag with +the RdrName $tag2con_T{Uniq2}, it will generate this code, which is much more +compact: + + $tag2con_T{Uniq2} :: Int -> T + $tag2con_T{Uniq2} = $tag2con_T{Uniq1} + +An alternative approach would be /not/ performing any kind of deduplication in +genAuxBinds at all and simply relying on GHC's simplifier to perform this kind +of CSE. But this is a more expensive analysis in general, while genAuxBinds can +accomplish the same result with a simple check. + +----- +-- Wrinkle: Why we sometimes do generate duplicate code +----- + +It is worth noting that deduplicating auxiliary binders is difficult in the +general case. Here are two particular examples where GHC cannot easily remove +duplicate copies of an auxiliary binding: + +1. When derived instances are contained in different modules, as in the + following example: + + module A where + data T = ... + module B where + import A + deriving instance Ix T + module C where + import B + deriving instance Enum T + + The derived Eq and Enum instances for T make use of $tag2con_T, and since + they are defined in separate modules, each module must produce its own copy + of $tag2con_T. + +2. When derived instances are separated by TH splices (#18321), as in the + following example: + + module M where + + data T = ... + deriving instance Ix T + $(pure []) + deriving instance Enum T + + Due to the way that GHC typechecks TyClGroups, genAuxBinds will run twice + in this program: once for all the declarations before the TH splice, and + once again for all the declarations after the TH splice. As a result, + $tag2con_T will be generated twice, since genAuxBinds will be unable to + recognize the presence of duplicates. + +These situations are much rarer, so we do not spend any effort to deduplicate +auxiliary bindings there. Instead, we focus on the common case of multiple +derived instances within the same module, not separated by any TH splices. +(This is the case described in "Wrinkle: Reducing code duplication".) In +situation (1), we can at least fall back on GHC's simplifier to pick up +genAuxBinds' slack. + +Note [Filter out impossible GADT data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some stock-derivable classes will filter out impossible GADT data constructors, +to rule out problematic constructors when deriving instances. e.g. + +``` +data Foo a where + X :: Foo Int + Y :: (Bool -> Bool) -> Foo Bool +``` + +when deriving an instance on `Foo Int`, `Y` should be treated as if it didn't +exist in the first place. For instance, if we write + +``` +deriving instance Eq (Foo Int) +``` + +it should generate: + +``` +instance Eq (Foo Int) where + X == X = True +``` + +Classes that filter constructors: + +* Eq +* Ord +* Show +* Lift +* Functor +* Foldable +* Traversable + +Classes that do not filter constructors: + +* Enum: doesn't make sense for GADTs in the first place +* Bounded: only makes sense for GADTs with a single constructor +* Ix: only makes sense for GADTs with a single constructor +* Read: `Read a` returns `a` instead of consumes `a`, so filtering data + constructors would make this function _more_ partial instead of less +* Data: derived implementations of gunfold rely on a constructor-indexing + scheme that wouldn't work if certain constructors were filtered out +* Generic/Generic1: doesn't make sense for GADTs + +Classes that do not currently filter constructors may do so in the future, if +there is a valid use-case and we have requirements for how they should work. + +See #16341 and the T16341.hs test case. + +Note [Instantiating field types in stock deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Figuring out what the types of data constructor fields are in `deriving` can +be surprisingly tricky. Here are some examples (adapted from #20375) to set +the scene: + + data Ta = MkTa Int# + data Tb (x :: TYPE IntRep) = MkTb x + + deriving instance Eq Ta -- 1. + deriving instance Eq (Tb a) -- 2. + deriving instance Eq (Tb Int#) -- 3. + +Example (1) is accepted, as `deriving Eq` has a special case for fields of type +Int#. Example (2) is rejected, however, as the special case for Int# does not +extend to all types of kind (TYPE IntRep). + +Example (3) ought to typecheck. If you instantiate the field of type `x` in +MkTb to be Int#, then `deriving Eq` is capable of handling that. We must be +careful, however. If we naïvely use, say, `dataConOrigArgTys` to retrieve the +field types, then we would get `b`, which `deriving Eq` would reject. In +order to handle `deriving Eq` (and, more generally, any stock deriving +strategy) correctly, we /must/ instantiate the field types as needed. +Not doing so led to #20375 and #20387. + +In fact, we end up needing to instantiate the field types in quite a few +places: + +* When performing validity checks for stock deriving strategies (e.g., in + GHC.Tc.Deriv.Utils.cond_stdOK) + +* When inferring the instance context in + GHC.Tc.Deriv.Infer.inferConstraintStock + +* When generating code for stock-derived instances in + GHC.Tc.Deriv.{Functor,Generate,Generics} + +Repeatedly performing these instantiations in multiple places would be +wasteful, so we build a cache of data constructor field instantiations in +the `dit_dc_inst_arg_env` field of DerivInstTys. Specifically: + +1. When beginning to generate code for a stock-derived instance + `T arg_1 ... arg_n`, the `dit_dc_inst_arg_env` field is created by taking + each data constructor `dc`, instantiating its field types with + `dataConInstUnivs dc [arg_1, ..., arg_n]`, and mapping `dc` to the + instantiated field types in the cache. The `buildDataConInstArgEnv` function + is responsible for orchestrating this. + +2. When a part of the code in GHC.Tc.Deriv.* needs to look up the field + types, we deliberately avoid using `dataConOrigArgTys`. Instead, we use + `derivDataConInstArgTys`, which looks up a DataCon's instantiated field + types in the cache. + +StandaloneDeriving is one way for the field types to become instantiated. +Another way is by deriving Functor and related classes, as chronicled in +Note [Inferring the instance context] in GHC.Tc.Deriv.Infer. Here is one such +example: + + newtype Compose (f :: k -> Type) (g :: j -> k) (a :: j) = Compose (f (g a)) + deriving Generic1 + +This ultimately generates the following instance: + + instance forall (f :: Type -> Type) (g :: j -> Type). + Functor f => Generic1 (Compose f g) where ... + +Note that because of the inferred `Functor f` constraint, `k` was instantiated +to be `Type`. GHC's deriving machinery doesn't realize this until it performs +constraint inference (in GHC.Tc.Deriv.Infer.inferConstraintsStock), however, +which is *after* the initial DerivInstTys has been created. As a result, the +`dit_dc_inst_arg_env` field might need to be updated after constraint inference, +as the inferred constraints might instantiate the field types further. + +This is accomplished by way of `substDerivInstTys`, which substitutes all of +the fields in a `DerivInstTys`, including the `dit_dc_inst_arg_env`. +It is important to do this in inferConstraintsStock, as the +deriving/should_compile/T20387 test case will not compile otherwise. +-} diff --git a/GHC/Tc/Deriv/Generics.hs b/GHC/Tc/Deriv/Generics.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv/Generics.hs @@ -0,0 +1,1115 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- +(c) The University of Glasgow 2011 + +-} + +-- | The deriving code for the Generic class +module GHC.Tc.Deriv.Generics + ( canDoGenerics + , canDoGenerics1 + , GenericKind(..) + , gen_Generic_binds + , gen_Generic_fam_inst + , get_gen1_constrained_tys + ) +where + +import GHC.Prelude hiding (head, init, last, tail) + +import GHC.Hs +import GHC.Tc.Utils.TcType +import GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Instantiate( newFamInst ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad + +import GHC.Core.Type +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) + +import GHC.Unit.Module ( moduleName, moduleUnit + , unitFS, getModule ) + +import GHC.Iface.Env ( newGlobalBinder ) + +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Name.Reader +import GHC.Types.SourceText +import GHC.Types.Fixity +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Var.Env +import GHC.Types.Var.Set (elemVarSet) + +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Builtin.Names + +import GHC.Utils.Error( Validity'(..), andValid ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Driver.DynFlags +import GHC.Data.FastString + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.Monad (mplus) +import Data.List (zip4, partition) +import Data.List.NonEmpty (NonEmpty (..), last, nonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (isJust) + +{- +************************************************************************ +* * +\subsection{Bindings for the new generic deriving mechanism} +* * +************************************************************************ + +For the generic representation we need to generate: +\begin{itemize} +\item A Generic instance +\item A Rep type instance +\item Many auxiliary datatypes and instances for them (for the meta-information) +\end{itemize} +-} + +gen_Generic_binds :: GenericKind -> SrcSpan -> DerivInstTys + -> TcM (LHsBinds GhcPs, [LSig GhcPs]) +gen_Generic_binds gk loc dit = do + dflags <- getDynFlags + return $ mkBindsRep dflags gk loc dit + +{- +************************************************************************ +* * +\subsection{Generating representation types} +* * +************************************************************************ +-} + +-- | Called by 'GHC.Tc.Deriv.Infer.inferConstraints'; generates a list of +-- types, each of which must be a 'Functor' in order for the 'Generic1' +-- instance to work. For instance, if we have: +-- +-- @ +-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a)) +-- @ +-- +-- Then @'get_gen1_constrained_tys' a (f (g a))@ would return @[Either Int]@, +-- as a derived 'Generic1' instance would need to call 'fmap' at that type. +-- Invoking @'get_gen1_constrained_tys' a@ on any of the other fields would +-- return @[]@. +-- +-- 'get_gen1_constrained_tys' is very similar in spirit to +-- 'deepSubtypesContaining' in "GHC.Tc.Deriv.Functor". Just like with +-- 'deepSubtypesContaining', it is important that the 'TyVar' argument come +-- from 'dataConUnivTyVars'. (See #22167 for what goes wrong if 'tyConTyVars' +-- is used.) +get_gen1_constrained_tys :: TyVar -> Type -> [Type] +get_gen1_constrained_tys argVar + = argTyFold argVar $ ArgTyAlg { ata_rec0 = const [] + , ata_par1 = [], ata_rec1 = const [] + , ata_comp = (:) } + +{- + +Note [Requirements for deriving Generic and Rep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the following, T, Tfun, and Targ are "meta-variables" ranging over type +expressions. + +(Generic T) and (Rep T) are derivable for some type expression T if the +following constraints are satisfied. + + (a) D is a type constructor *value*. In other words, D is either a type + constructor or it is equivalent to the head of a data family instance (up to + alpha-renaming). + + (b) D cannot have a "stupid context". + See Note [The stupid context] in GHC.Core.DataCon. + + (c) The right-hand side of D cannot include existential types, universally + quantified types, or "exotic" unlifted types. An exotic unlifted type + is one which is not listed in the definition of allowedUnliftedTy + (i.e., one for which we have no representation type). + See Note [Generics and unlifted types] + + (d) T :: *. + +(Generic1 T) and (Rep1 T) are derivable for some type expression T if the +following constraints are satisfied. + + (a),(b),(c) As above. + + (d) T must expect arguments, and its last parameter must have kind *. + + We use `a' to denote the parameter of D that corresponds to the last + parameter of T. + + (e) For any type-level application (Tfun Targ) in the right-hand side of D + where the head of Tfun is not a tuple constructor: + + (b1) `a' must not occur in Tfun. + + (b2) If `a' occurs in Targ, then Tfun :: * -> *. + +-} + +canDoGenerics :: DerivInstTys -> Validity' [DeriveGenericsErrReason] +-- canDoGenerics determines if Generic/Rep can be derived. +-- +-- Check (a) from Note [Requirements for deriving Generic and Rep] is taken +-- care of because canDoGenerics is applied to rep tycons. +-- +-- It returns IsValid if deriving is possible. It returns (NotValid reason) +-- if not. +canDoGenerics dit@(DerivInstTys{dit_rep_tc = tc}) + = mergeErrors ( + -- Check (b) from Note [Requirements for deriving Generic and Rep]. + (if (not (null (tyConStupidTheta tc))) + then (NotValid $ DerivErrGenericsMustNotHaveDatatypeContext tc_name) + else IsValid) + -- See comment below + : (map bad_con (tyConDataCons tc))) + where + -- The tc can be a representation tycon. When we want to display it to the + -- user (in an error message) we should print its parent + tc_name = case tyConFamInst_maybe tc of + Just (ptc, _) -> ptc + _ -> tc + + -- Check (c) from Note [Requirements for deriving Generic and Rep]. + -- + -- If any of the constructors has an exotic unlifted type as argument, + -- then we can't build the embedding-projection pair, because + -- it relies on instantiating *polymorphic* sum and product types + -- at the argument types of the constructors + bad_con :: DataCon -> Validity' DeriveGenericsErrReason + bad_con dc = if any bad_arg_type (derivDataConInstArgTys dc dit) + then NotValid $ DerivErrGenericsMustNotHaveExoticArgs dc + else if not (isVanillaDataCon dc) + then NotValid $ DerivErrGenericsMustBeVanillaDataCon dc + else IsValid + + -- Nor can we do the job if it's an existential data constructor, + -- Nor if the args are polymorphic types (I don't think) + bad_arg_type ty = (mightBeUnliftedType ty && not (allowedUnliftedTy ty)) + || not (isTauTy ty) + +-- Returns True the Type argument is an unlifted type which has a +-- corresponding generic representation type. For example, +-- (allowedUnliftedTy Int#) would return True since there is the UInt +-- representation type. +allowedUnliftedTy :: Type -> Bool +allowedUnliftedTy = isJust . unboxedRepRDRs + +mergeErrors :: [Validity' a] -> Validity' [a] +mergeErrors [] = IsValid +mergeErrors (NotValid s:t) = case mergeErrors t of + IsValid -> NotValid [s] + NotValid s' -> NotValid (s : s') +mergeErrors (IsValid : t) = mergeErrors t + -- NotValid s' -> NotValid (s <> text ", and" $$ s') + +-- A datatype used only inside of canDoGenerics1. It's the result of analysing +-- a type term. +data Check_for_CanDoGenerics1 = CCDG1 + { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in + -- this type? + , _ccdg1_errors :: Validity' DeriveGenericsErrReason -- errors generated by this type + } + +{- + +Note [degenerate use of FFoldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We use foldDataConArgs here only for its ability to treat tuples +specially. foldDataConArgs also tracks covariance (though it assumes all +higher-order type parameters are covariant) and has hooks for special handling +of functions and polytypes, but we do *not* use those. + +The key issue is that Generic1 deriving currently offers no sophisticated +support for functions. For example, we cannot handle + + data F a = F ((a -> Int) -> Int) + +even though a is occurring covariantly. + +In fact, our rule is harsh: a is simply not allowed to occur within the first +argument of (->). We treat (->) the same as any other non-tuple tycon. + +Unfortunately, this means we have to track "the parameter occurs in this type" +explicitly, even though foldDataConArgs is also doing this internally. + +-} + +-- canDoGenerics1 determines if a Generic1/Rep1 can be derived. +-- +-- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep] +-- are taken care of by the call to canDoGenerics. +-- +-- It returns IsValid if deriving is possible. It returns (NotValid reason) +-- if not. +canDoGenerics1 :: DerivInstTys -> Validity' [DeriveGenericsErrReason] +canDoGenerics1 dit@(DerivInstTys{dit_rep_tc = rep_tc}) = + canDoGenerics dit `andValid` additionalChecks + where + additionalChecks + -- check (d) from Note [Requirements for deriving Generic and Rep] + | null (tyConTyVars rep_tc) = NotValid [ + DerivErrGenericsMustHaveSomeTypeParams rep_tc] + + | otherwise = mergeErrors $ concatMap check_con data_cons + + data_cons = tyConDataCons rep_tc + check_con con = case check_vanilla con of + j@(NotValid {}) -> [j] + IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con dit + + check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason + check_vanilla con | isVanillaDataCon con = IsValid + | otherwise = NotValid $ DerivErrGenericsMustNotHaveExistentials con + + bmzero = CCDG1 False IsValid + bmbad con = CCDG1 True $ NotValid (DerivErrGenericsWrongArgKind con) + bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) + + -- check (e) from Note [Requirements for deriving Generic and Rep] + -- See also Note [degenerate use of FFoldType] + ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1 + ft_check con = FT + { ft_triv = bmzero + + , ft_var = caseVar, ft_co_var = caseVar + + -- (component_0,component_1,...,component_n) + , ft_tup = \_ components -> case nonEmpty components of + Just components' | any _ccdg1_hasParam (NE.init components') -> bmbad con + _ -> foldr bmplus bmzero components + + -- (dom -> rng), where the head of ty is not a tuple tycon + , ft_fun = \dom rng -> -- cf #8516 + if _ccdg1_hasParam dom + then bmbad con + else bmplus dom rng + + -- (ty arg), where head of ty is neither (->) nor a tuple constructor and + -- the parameter of interest does not occur in ty + , ft_ty_app = \_ _ arg -> arg + + , ft_bad_app = bmbad con + , ft_forall = \_ body -> body -- polytypes are handled elsewhere + } + where + caseVar = CCDG1 True IsValid + +{- +************************************************************************ +* * +\subsection{Generating the RHS of a generic default method} +* * +************************************************************************ +-} + +type US = Int -- Local unique supply, just a plain Int +type Alt = (LPat GhcPs, LHsExpr GhcPs) + +-- GenericKind serves to mark if a datatype derives Generic (Gen0) or +-- Generic1 (Gen1). +data GenericKind = Gen0 | Gen1 + +-- Like 'GenericKind', but with a payload of a datacon's last universally +-- quantified 'TyVar' in the 'Generic1' case. +-- +-- Note that for GADTs, the last TyVar's Name will be different in each data +-- constructor, so it is not correct to simply use the last TyVar in +-- 'tyConTyVars' in 'Gen1_DC'. (See #21185 for an example of what would happen +-- if you tried.) +data GenericKind_DC = Gen0_DC | Gen1_DC TyVar + +-- Construct a 'GenericKind_DC', retrieving the last universally quantified +-- type variable of a 'DataCon' in the 'Generic1' case. +gk2gkDC :: GenericKind -> DataCon -> [Type] -> GenericKind_DC +gk2gkDC Gen0 _ _ = Gen0_DC +gk2gkDC Gen1 dc tc_args = Gen1_DC $ assert (isTyVarTy last_dc_inst_univ) + $ getTyVar last_dc_inst_univ + where + dc_inst_univs = dataConInstUnivs dc tc_args + last_dc_inst_univ = last $ expectNonEmpty dc_inst_univs + + +-- Bindings for the Generic instance +mkBindsRep :: DynFlags -> GenericKind -> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs]) +mkBindsRep dflags gk loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs) + where + binds = [mkRdrFunBind (L loc' from01_RDR) [from_eqn]] + ++ + [mkRdrFunBind (L loc' to01_RDR) [to_eqn]] + + -- See Note [Generics performance tricks] + sigs = if gopt Opt_InlineGenericsAggressively dflags + || (gopt Opt_InlineGenerics dflags && inlining_useful) + then [inline1 from01_RDR, inline1 to01_RDR] + else [] + where + inlining_useful + | cons <= 1 = True + | cons <= 4 = max_fields <= 5 + | cons <= 8 = max_fields <= 2 + | cons <= 16 = max_fields <= 1 + | cons <= 24 = max_fields == 0 + | otherwise = False + where + cons = length datacons + max_fields = maximum $ 0 :| map dataConSourceArity datacons + + inline1 f = L loc'' . InlineSig noAnn (L loc' f) + $ alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 } + + -- The topmost M1 (the datatype metadata) has the exact same type + -- across all cases of a from/to definition, and can be factored out + -- to save some allocations during typechecking. + -- See Note [Generics compilation speed tricks] + from_eqn = mkHsCaseAlt x_Pat $ mkM1_E + $ nlHsPar $ nlHsCase x_Expr from_matches + to_eqn = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches + + from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] + to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] + loc' = noAnnSrcSpan loc + loc'' = noAnnSrcSpan loc + datacons = tyConDataCons tycon + + (from01_RDR, to01_RDR) = case gk of + Gen0 -> (from_RDR, to_RDR) + Gen1 -> (from1_RDR, to1_RDR) + + -- Recurse over the sum first + from_alts, to_alts :: [Alt] + (from_alts, to_alts) = mkSum gk (1 :: US) dit datacons + +-------------------------------------------------------------------------------- +-- The type synonym instance and synonym +-- type instance Rep (D a b) = Rep_D a b +-- type Rep_D a b = ...representation type for D ... +-------------------------------------------------------------------------------- + +gen_Generic_fam_inst :: GenericKind -- Gen0 or Gen1 + -> (Name -> Fixity) -- Get the Fixity for a data constructor Name + -> SrcSpan -- The current source location + -> DerivInstTys -- Information about the type(s) to which + -- Generic(1) is applied in the generated + -- instance, including the data type's TyCon + -> TcM FamInst -- Generated representation0 coercion +gen_Generic_fam_inst gk get_fixity loc + dit@(DerivInstTys{ dit_cls_tys = cls_tys + , dit_tc = tc, dit_tc_args = tc_args + , dit_rep_tc = tycon }) = + -- Consider the example input tycon `D`, where data D a b = D_ a + -- Also consider `R:DInt`, where { data family D x y :: * -> * + -- ; data instance D Int a b = D_ a } + do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family) + fam_tc <- case gk of + Gen0 -> tcLookupTyCon repTyConName + Gen1 -> tcLookupTyCon rep1TyConName + + ; let -- If the derived instance is + -- instance Generic (Foo x) + -- then: + -- `arg_ki` = *, `inst_ty` = Foo x :: * + -- + -- If the derived instance is + -- instance Generic1 (Bar x :: k -> *) + -- then: + -- `arg_k` = k, `inst_ty` = Bar x :: k -> * + arg_ki = case (gk, cls_tys) of + (Gen0, []) -> liftedTypeKind + (Gen1, [arg_k]) -> arg_k + _ -> pprPanic "gen_Generic_fam_insts" (ppr cls_tys) + inst_ty = mkTyConApp tc tc_args + inst_tys = cls_tys ++ [inst_ty] + + -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * + ; repTy <- tc_mkRepTy gk get_fixity dit arg_ki + + -- `rep_name` is a name we generate for the synonym + ; mod <- getModule + ; let tc_occ = nameOccName (tyConName tycon) + rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ + ; rep_name <- newGlobalBinder mod rep_occ loc + + ; let tcv = tyCoVarsOfTypeList inst_ty + (tv, cv) = partition isTyVar tcv + tvs = scopedSort tv + cvs = scopedSort cv + axiom = mkSingleCoAxiom Nominal rep_name tvs [] cvs + fam_tc inst_tys repTy + + ; newFamInst SynFamilyInst axiom } + +-------------------------------------------------------------------------------- +-- Type representation +-------------------------------------------------------------------------------- + +-- | See documentation of 'argTyFold'; that function uses the fields of this +-- type to interpret the structure of a type when that type is considered as an +-- argument to a constructor that is being represented with 'Rep1'. +data ArgTyAlg a = ArgTyAlg + { ata_rec0 :: (Type -> a) + , ata_par1 :: a, ata_rec1 :: (Type -> a) + , ata_comp :: (Type -> a -> a) + } + +-- | @argTyFold@ implements a generalised and safer variant of the @arg@ +-- function from Figure 3 in . @arg@ +-- is conceptually equivalent to: +-- +-- > arg t = case t of +-- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t +-- > App f [t'] | +-- > representable1 f && +-- > t' == argVar -> Rec1 f +-- > App f [t'] | +-- > representable1 f && +-- > t' has tyvars -> f :.: (arg t') +-- > _ -> Rec0 t +-- +-- where @argVar@ is the last type variable in the data type declaration we are +-- finding the representation for. +-- +-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to +-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and +-- @:.:@. +-- +-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for +-- some data types. The problematic case is when @t@ is an application of a +-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the +-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in +-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some +-- representable1 checks have been relaxed, and others were moved to +-- @canDoGenerics1@. +argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a +argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, + ata_par1 = mkPar1, ata_rec1 = mkRec1, + ata_comp = mkComp}) = + -- mkRec0 is the default; use it if there is no interesting structure + -- (e.g. occurrences of parameters or recursive occurrences) + \t -> maybe (mkRec0 t) id $ go t where + go :: Type -> -- type to fold through + Maybe a -- the result (e.g. representation type), unless it's trivial + go t = isParam `mplus` isApp where + + isParam = do -- handles parameters + t' <- getTyVar_maybe t + Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter + else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0 + + isApp = do -- handles applications + (phi, beta) <- tcSplitAppTy_maybe t + + let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta + + -- Does it have no interesting structure to represent? + if not interesting then Nothing + else -- Is the argument the parameter? Special case for mkRec1. + if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi + else mkComp phi `fmap` go beta -- It must be a composition. + + +tc_mkRepTy :: -- Gen0 or Gen1, for Rep or Rep1 + GenericKind + -- Get the Fixity for a data constructor Name + -> (Name -> Fixity) + -- Information about the last type argument to Generic(1) + -> DerivInstTys + -- The kind of the representation type's argument + -- See Note [Handling kinds in a Rep instance] + -> Kind + -- Generated representation0 type + -> TcM Type +tc_mkRepTy gk get_fixity dit@(DerivInstTys{ dit_rep_tc = tycon + , dit_rep_tc_args = tycon_args }) k = + do + d1 <- tcLookupTyCon d1TyConName + c1 <- tcLookupTyCon c1TyConName + s1 <- tcLookupTyCon s1TyConName + rec0 <- tcLookupTyCon rec0TyConName + rec1 <- tcLookupTyCon rec1TyConName + par1 <- tcLookupTyCon par1TyConName + u1 <- tcLookupTyCon u1TyConName + v1 <- tcLookupTyCon v1TyConName + plus <- tcLookupTyCon sumTyConName + times <- tcLookupTyCon prodTyConName + comp <- tcLookupTyCon compTyConName + uAddr <- tcLookupTyCon uAddrTyConName + uChar <- tcLookupTyCon uCharTyConName + uDouble <- tcLookupTyCon uDoubleTyConName + uFloat <- tcLookupTyCon uFloatTyConName + uInt <- tcLookupTyCon uIntTyConName + uWord <- tcLookupTyCon uWordTyConName + + let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon + + md <- tcLookupPromDataCon metaDataDataConName + mc <- tcLookupPromDataCon metaConsDataConName + ms <- tcLookupPromDataCon metaSelDataConName + pPrefix <- tcLookupPromDataCon prefixIDataConName + pInfix <- tcLookupPromDataCon infixIDataConName + pLA <- tcLookupPromDataCon leftAssociativeDataConName + pRA <- tcLookupPromDataCon rightAssociativeDataConName + pNA <- tcLookupPromDataCon notAssociativeDataConName + pSUpk <- tcLookupPromDataCon sourceUnpackDataConName + pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName + pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName + pSLzy <- tcLookupPromDataCon sourceLazyDataConName + pSStr <- tcLookupPromDataCon sourceStrictDataConName + pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName + pDLzy <- tcLookupPromDataCon decidedLazyDataConName + pDStr <- tcLookupPromDataCon decidedStrictDataConName + pDUpk <- tcLookupPromDataCon decidedUnpackDataConName + + let mkSum' a b = mkTyConApp plus [k,a,b] + mkProd a b = mkTyConApp times [k,a,b] + mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a + mkRec1 a = mkTyConApp rec1 [k,a] + mkPar1 = mkTyConTy par1 + mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ] + mkC a = mkTyConApp c1 [ k + , metaConsTy a + , prod (gk2gkDC gk a tycon_args) + (derivDataConInstArgTys a dit) + (dataConSrcBangs a) + (dataConImplBangs a) + (dataConFieldLabels a)] + mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a] + + -- Sums and products are done in the same way for both Rep and Rep1 + sumP l = foldBal mkSum' (mkTyConApp v1 [k]) . map mkC $ l + -- The Bool is True if this constructor has labelled fields + prod :: GenericKind_DC -> [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type + prod gk_ l sb ib fl = foldBal mkProd (mkTyConApp u1 [k]) + [ assert (null fl || lengthExceeds fl j) $ + arg gk_ t sb' ib' (if null fl + then Nothing + else Just (fl !! j)) + | (t,sb',ib',j) <- zip4 l sb ib [0..] ] + + arg :: GenericKind_DC -> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type + arg gk_ t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of + -- Here we previously used Par0 if t was a type variable, but we + -- realized that we can't always guarantee that we are wrapping-up + -- all type variables in Par0. So we decided to stop using Par0 + -- altogether, and use Rec0 all the time. + Gen0_DC -> mkRec0 t + Gen1_DC argVar -> argPar argVar t + where + -- Builds argument representation for Rep1 (more complicated due to + -- the presence of composition). + argPar argVar = + let -- If deriving Generic1, make sure to substitute the last + -- type variable with Any in the generated Rep1 instance. + -- This avoids issues like what is documented in the + -- "wrinkle" section of + -- Note [Generating a correctly typed Rep instance]. + env = zipTyEnv [argVar] [anyTypeOfKind (tyVarKind argVar)] + in_scope = mkInScopeSet (tyCoVarsOfTypes tycon_args) + subst = mkTvSubst in_scope env in + + substTy subst . argTyFold argVar (ArgTyAlg + {ata_rec0 = mkRec0, ata_par1 = mkPar1, + ata_rec1 = mkRec1, ata_comp = mkComp comp k}) + + tyConName_user = case tyConFamInst_maybe tycon of + Just (ptycon, _) -> tyConName ptycon + Nothing -> tyConName tycon + + dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user + mdName = mkStrLitTy . moduleNameFS . moduleName + . nameModule . tyConName $ tycon + pkgName = mkStrLitTy . unitFS . moduleUnit + . nameModule . tyConName $ tycon + isNT = mkTyConTy $ if isNewTyCon tycon + then promotedTrueDataCon + else promotedFalseDataCon + + ctName = mkStrLitTy . occNameFS . nameOccName . dataConName + ctFix c + | dataConIsInfix c + = case get_fixity (dataConName c) of + Fixity n InfixL -> buildFix n pLA + Fixity n InfixR -> buildFix n pRA + Fixity n InfixN -> buildFix n pNA + | otherwise = mkTyConTy pPrefix + buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc + , mkNumLitTy (fromIntegral n)] + + isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0 + then promotedTrueDataCon + else promotedFalseDataCon + + selName = mkStrLitTy . field_label . flLabel + + mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind] + mbSel (Just s) = mkTyConApp promotedJustDataCon + [typeSymbolKind, selName s] + + metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT] + metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c] + metaSelTy mlbl su ss ib = + mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness] + where + pSUpkness = mkTyConTy $ case su of + SrcUnpack -> pSUpk + SrcNoUnpack -> pSNUpk + NoSrcUnpack -> pNSUpkness + + pSStrness = mkTyConTy $ case ss of + SrcLazy -> pSLzy + SrcStrict -> pSStr + NoSrcStrict -> pNSStrness + + pDStrness = mkTyConTy $ case ib of + HsLazy -> pDLzy + HsStrict _ -> pDStr + HsUnpack{} -> pDUpk + + return (mkD tycon) + +mkComp :: TyCon -> Kind -> Type -> Type -> Type +mkComp comp k f g + | k1_first = mkTyConApp comp [k,liftedTypeKind,f,g] + | otherwise = mkTyConApp comp [liftedTypeKind,k,f,g] + where + -- Which of these is the case? + -- newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... + -- or newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... + -- We want to instantiate with k1=k, and k2=* + -- Reason for k2=*: see Note [Handling kinds in a Rep instance] + -- But we need to know which way round! + k1_first = k_first == p_kind_var + [k_first,_,_,_,p] = tyConTyVars comp + Just p_kind_var = getTyVar_maybe (tyVarKind p) + +-- Given the TyCons for each URec-related type synonym, check to see if the +-- given type is an unlifted type that generics understands. If so, return +-- its representation type. Otherwise, return Rec0. +-- See Note [Generics and unlifted types] +mkBoxTy :: TyCon -- UAddr + -> TyCon -- UChar + -> TyCon -- UDouble + -> TyCon -- UFloat + -> TyCon -- UInt + -> TyCon -- UWord + -> TyCon -- Rec0 + -> Kind -- What to instantiate Rec0's kind variable with + -> Type + -> Type +mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty + | ty `eqType` addrPrimTy = mkTyConApp uAddr [k] + | ty `eqType` charPrimTy = mkTyConApp uChar [k] + | ty `eqType` doublePrimTy = mkTyConApp uDouble [k] + | ty `eqType` floatPrimTy = mkTyConApp uFloat [k] + | ty `eqType` intPrimTy = mkTyConApp uInt [k] + | ty `eqType` wordPrimTy = mkTyConApp uWord [k] + | otherwise = mkTyConApp rec0 [k,ty] + +-------------------------------------------------------------------------------- +-- Dealing with sums +-------------------------------------------------------------------------------- + +mkSum :: GenericKind -- Generic or Generic1? + -> US -- Base for generating unique names + -> DerivInstTys -- Information about the last type argument to Generic(1) + -> [DataCon] -- The data constructors + -> ([Alt], -- Alternatives for the T->Trep "from" function + [Alt]) -- Alternatives for the Trep->T "to" function + +-- Datatype without any constructors +mkSum _ _ _ [] = ([from_alt], [to_alt]) + where + from_alt = (x_Pat, nlHsCase x_Expr []) + to_alt = (x_Pat, nlHsCase x_Expr []) + -- These M1s are meta-information for the datatype + +-- Datatype with at least one constructor +mkSum gk us dit datacons = + -- switch the payload of gk_ to be datacon-centric instead of tycon-centric + unzip [ mk1Sum gk us i (length datacons) dit d + | (d,i) <- zip datacons [1..] ] + +-- Build the sum for a particular constructor +mk1Sum :: GenericKind -- Generic or Generic1? + -> US -- Base for generating unique names + -> Int -- The index of this constructor + -> Int -- Total number of constructors + -> DerivInstTys -- Information about the last type argument to Generic(1) + -> DataCon -- The data constructor + -> (Alt, -- Alternative for the T->Trep "from" function + Alt) -- Alternative for the Trep->T "to" function +mk1Sum gk us i n dit@(DerivInstTys{dit_rep_tc_args = tc_args}) datacon + = (from_alt, to_alt) + where + gk_ = gk2gkDC gk datacon tc_args + + -- Existentials already excluded + argTys = derivDataConInstArgTys datacon dit + n_args = dataConSourceArity datacon + + datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys + datacon_vars = map fst datacon_varTys + + datacon_rdr = getRdrName datacon + + from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) + from_alt_rhs = genLR_E i n (mkProd_E gk_ datacon_varTys) + + to_alt = ( genLR_P i n (mkProd_P gk datacon_varTys) + , to_alt_rhs + ) -- These M1s are meta-information for the datatype + to_alt_rhs = case gk_ of + Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars + Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys + where + argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where + converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = nlHsVar . unboxRepRDR, + ata_par1 = nlHsVar unPar1_RDR, + ata_rec1 = const $ nlHsVar unRec1_RDR, + ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv) + `nlHsCompose` nlHsVar unComp1_RDR} + + +-- Generates the L1/R1 sum pattern +genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs +genLR_P i n p + | n == 0 = error "impossible" + | n == 1 = p + | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] + | otherwise = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] + where m = div n 2 + +-- Generates the L1/R1 sum expression +genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs +genLR_E i n e + | n == 0 = error "impossible" + | n == 1 = e + | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` + nlHsPar (genLR_E i (div n 2) e) + | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` + nlHsPar (genLR_E (i-m) (n-m) e) + where m = div n 2 + +-------------------------------------------------------------------------------- +-- Dealing with products +-------------------------------------------------------------------------------- + +-- Build a product expression +mkProd_E :: GenericKind_DC -- Generic or Generic1? + -> [(RdrName, Type)] + -- List of variables matched on the lhs and their types + -> LHsExpr GhcPs -- Resulting product expression +mkProd_E gk_ varTys = mkM1_E (foldBal prod (nlHsVar u1DataCon_RDR) appVars) + -- These M1s are meta-information for the constructor + where + appVars = map (wrapArg_E gk_) varTys + prod a b = prodDataCon_RDR `nlHsApps` [a,b] + +wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs +wrapArg_E Gen0_DC (var, ty) = mkM1_E $ + boxRepRDR ty `nlHsVarApps` [var] + -- This M1 is meta-information for the selector +wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ + converter ty `nlHsApp` nlHsVar var + -- This M1 is meta-information for the selector + where converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = nlHsVar . boxRepRDR, + ata_par1 = nlHsVar par1DataCon_RDR, + ata_rec1 = const $ nlHsVar rec1DataCon_RDR, + ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` + (nlHsVar fmap_RDR `nlHsApp` cnv)} + +boxRepRDR :: Type -> RdrName +boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs + +unboxRepRDR :: Type -> RdrName +unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs + +-- Retrieve the RDRs associated with each URec data family instance +-- constructor. See Note [Generics and unlifted types] +unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName) +unboxedRepRDRs ty + | ty `eqType` addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR) + | ty `eqType` charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR) + | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR) + | ty `eqType` floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR) + | ty `eqType` intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR) + | ty `eqType` wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR) + | otherwise = Nothing + +-- Build a product pattern +mkProd_P :: GenericKind -- Gen0 or Gen1 + -> [(RdrName, Type)] -- List of variables to match, + -- along with their types + -> LPat GhcPs -- Resulting product pattern +mkProd_P gk varTys = mkM1_P (foldBal prod (nlNullaryConPat u1DataCon_RDR) appVars) + -- These M1s are meta-information for the constructor + where + appVars = unzipWith (wrapArg_P gk) varTys + prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b] + +wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs +wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v]) + -- This M1 is meta-information for the selector +wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v] + +mkGenericLocal :: US -> RdrName +mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) + +x_RDR :: RdrName +x_RDR = mkVarUnqual (fsLit "x") + +x_Expr :: LHsExpr GhcPs +x_Expr = nlHsVar x_RDR + +x_Pat :: LPat GhcPs +x_Pat = nlVarPat x_RDR + +mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs +mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e + +mkM1_P :: LPat GhcPs -> LPat GhcPs +mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p] + +nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +nlHsCompose x y = compose_RDR `nlHsApps` [x, y] + +-- | Variant of foldr for producing balanced lists +foldBal :: (a -> a -> a) -> a -> [a] -> a +{-# INLINE foldBal #-} -- inlined to produce specialised code for each op +foldBal op0 x0 xs0 = fold_bal op0 x0 (length xs0) xs0 + where + fold_bal op x !n xs = case xs of + [] -> x + [a] -> a + _ -> let !nl = n `div` 2 + !nr = n - nl + (l,r) = splitAt nl xs + in fold_bal op x nl l + `op` fold_bal op x nr r + +{- +Note [Generics and unlifted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally, all constants are marked with K1/Rec0. The exception to this rule is +when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In +that case, we must use a data family instance of URec (from GHC.Generics) to +mark it. As a result, before we can generate K1 or unK1, we must first check +to see if the type is actually one of the unlifted types for which URec has a +data family instance; if so, we generate that instead. + +See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more +details on why URec is implemented the way it is. + +Note [Generating a correctly typed Rep instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving +Generic(1). For example, given the following data declaration: + + data Foo a = MkFoo a + deriving stock Generic + +tc_mkRepTy would generate the `Rec0 a` portion of this instance: + + instance Generic (Foo a) where + type Rep (Foo a) = Rec0 a + ... + +(The full `Rep` instance is more complicated than this, but we have simplified +it for presentation purposes.) + +`tc_mkRepTy` figures out the field types to use in the RHS by inspecting a +DerivInstTys, which contains the instantiated field types for each data +constructor. (See Note [Instantiating field types in stock deriving] for a +description of how this works.) As a result, `tc_mkRepTy` "just works" even +when dealing with StandaloneDeriving, such as in this example: + + deriving stock instance Generic (Foo Int) + ===> + instance Generic (Foo Int) where + type Rep (Foo Int) = Rec0 Int -- The `a` has been instantiated here + +A wrinkle in all of this: what happens when deriving a Generic1 instance where +the last type variable appears in a type synonym that discards it? That is, +what should happen in this example (taken from #15012)? + + type FakeOut a = Int + data T a = MkT (FakeOut a) + deriving Generic1 + +MkT is a particularly wily data constructor. Although the last type variable +`a` technically appears in `FakeOut a`, it's just a smokescreen, as `FakeOut a` +simply expands to `Int`. As a result, `MkT` doesn't really *use* the last type +variable. Therefore, T's `Rep` instance would use Rec0 to represent MkT's +field. But we must be careful not to produce code like this: + + instance Generic1 T where + type Rep1 T = Rec0 (FakeOut a) + ... + +Oh no! Now we have `a` on the RHS, but it's completely unbound. This can cause +issues like what was observed in #15012. To avoid this, we ensure that `a` is +instantiated to Any: + + instance Generic1 T where + type Rep1 T = Rec0 (FakeOut Any) + ... + +And now all is good. + +Alternatively, we could have avoided this problem by expanding all type +synonyms on the RHSes of Rep1 instances. But we might blow up the size of +these types even further by doing this, so we choose not to do so. + +Note [Handling kinds in a Rep instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because Generic1 is poly-kinded, the representation types were generalized to +be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply +the kind of the instance being derived to all the representation type +constructors. For instance, if you have + + data Empty (a :: k) = Empty deriving Generic1 + +Then the generated code is now approximately (with -fprint-explicit-kinds +syntax): + + instance Generic1 k (Empty k) where + type Rep1 k (Empty k) = U1 k + +Most representation types have only one kind variable, making them easy to deal +with. The only non-trivial case is (:.:), which is only used in Generic1 +instances: + + newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) = + Comp1 { unComp1 :: f (g p) } + +Here, we do something a bit counter-intuitive: we make k1 be the kind of the +instance being derived, and we always make k2 be *. Why *? It's because +the code that GHC generates using (:.:) is always of the form x :.: Rec1 y +for some types x and y. In other words, the second type to which (:.:) is +applied always has kind k -> *, for some kind k, so k2 cannot possibly be +anything other than * in a generated Generic1 instance. + +Note [Generics compilation speed tricks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deriving Generic(1) is known to have a large constant factor during +compilation, which contributes to noticeable compilation slowdowns when +deriving Generic(1) for large datatypes (see #5642). + +To ease the pain, there is a trick one can play when generating definitions for +to(1) and from(1). If you have a datatype like: + + data Letter = A | B | C | D + +then a naïve Generic instance for Letter would be: + + instance Generic Letter where + type Rep Letter = D1 ('MetaData ...) ... + + to (M1 (L1 (L1 (M1 U1)))) = A + to (M1 (L1 (R1 (M1 U1)))) = B + to (M1 (R1 (L1 (M1 U1)))) = C + to (M1 (R1 (R1 (M1 U1)))) = D + + from A = M1 (L1 (L1 (M1 U1))) + from B = M1 (L1 (R1 (M1 U1))) + from C = M1 (R1 (L1 (M1 U1))) + from D = M1 (R1 (R1 (M1 U1))) + +Notice that in every LHS pattern-match of the 'to' definition, and in every RHS +expression in the 'from' definition, the topmost constructor is M1. This +corresponds to the datatype-specific metadata (the D1 in the Rep Letter +instance). But this is wasteful from a typechecking perspective, since this +definition requires GHC to typecheck an application of M1 in every single case, +leading to an O(n) increase in the number of coercions the typechecker has to +solve, which in turn increases allocations and degrades compilation speed. + +Luckily, since the topmost M1 has the exact same type across every case, we can +factor it out reduce the typechecker's burden: + + instance Generic Letter where + type Rep Letter = D1 ('MetaData ...) ... + + to (M1 x) = case x of + L1 (L1 (M1 U1)) -> A + L1 (R1 (M1 U1)) -> B + R1 (L1 (M1 U1)) -> C + R1 (R1 (M1 U1)) -> D + + from x = M1 (case x of + A -> L1 (L1 (M1 U1)) + B -> L1 (R1 (M1 U1)) + C -> R1 (L1 (M1 U1)) + D -> R1 (R1 (M1 U1))) + +A simple change, but one that pays off, since it goes turns an O(n) amount of +coercions to an O(1) amount. + +Note [Generics performance tricks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generics-based algorithms tend to rely on GHC optimizing away the intermediate +representation for optimal performance. However, the default unfolding threshold +is usually too small for GHC to do that. + +The recommended approach thus far was to increase unfolding threshold, but this +makes GHC inline more aggressively in general, whereas it should only be more +aggressive with generics-based code. + +The solution is to use a heuristic that'll annotate Generic class methods with +INLINE[1] pragmas (the explicit phase is used to give users phase control as +they can annotate their functions with INLINE[2] or INLINE[0] if appropriate). + +The current heuristic was chosen by looking at how annotating Generic methods +INLINE[1] helps with optimal code generation for several types of generic +algorithms: + +* Round trip through the generic representation. + +* Generation of NFData instances. + +* Generation of field lenses. + +The experimentation was done by picking data types having N constructors with M +fields each and using their derived Generic instances to generate code with the +above algorithms. + +The results are threshold values for N and M (contained in +`mkBindsRep.inlining_useful`) for which inlining is beneficial, i.e. it usually +leads to performance improvements at both compile time (the simplifier has to do +more work, but then there's much less code left for subsequent phases to work +with) and run time (the generic representation of a data type is optimized +away). + +The T11068 test case, which includes the algorithms mentioned above, tests that +the generic representations of several data types optimize away using the +threshold values in `mkBindsRep.inlining_useful`. + +If one uses threshold values higher what is found in +`mkBindsRep.inlining_useful`, then annotating Generic class methods with INLINE +pragmas tends to be at best useless and at worst lead to code size blowup +without runtime performance improvements. +-} diff --git a/GHC/Tc/Deriv/Infer.hs b/GHC/Tc/Deriv/Infer.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv/Infer.hs @@ -0,0 +1,1118 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + + +{-# LANGUAGE MultiWayIf #-} + +-- | Functions for inferring (and simplifying) the context for derived instances. +module GHC.Tc.Deriv.Infer + ( inferConstraints + , simplifyInstanceContexts + ) +where + +import GHC.Prelude + +import GHC.Tc.Deriv.Utils +import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) ) +import GHC.Tc.Utils.Env +import GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Tc.Deriv.Generics +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.TcType +import GHC.Tc.Solver( simplifyTopImplic ) +import GHC.Tc.Solver.Solve( solveWanteds ) +import GHC.Tc.Solver.Monad ( runTcS ) +import GHC.Tc.Validity (validDerivPred) +import GHC.Tc.Utils.Unify (buildImplicationFor) +import GHC.Tc.Zonk.TcType ( zonkWC ) +import GHC.Tc.Zonk.Env ( ZonkFlexi(..), initZonkEnv ) + +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr (pprTyVars) +import GHC.Core.Type +import GHC.Core.Predicate +import GHC.Core.Unify (tcUnifyTy) + +import GHC.Data.Pair +import GHC.Builtin.Names +import GHC.Builtin.Types (mkConstraintTupleTy, typeToTypeKind) + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Types.Basic +import GHC.Types.Var + +import GHC.Data.Bag + +import Control.Monad +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ask) +import Data.Function (on) +import Data.Functor.Classes (liftEq) +import Data.List (sortBy) +import Data.Maybe + +---------------------- + +inferConstraints :: DerivSpecMechanism -> DerivEnv + -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) +-- inferConstraints figures out the constraints needed for the +-- instance declaration generated by a 'deriving' clause on a +-- data type declaration. It also returns the new in-scope type +-- variables and instance types, in case they were changed due to +-- the presence of functor-like constraints. +-- See Note [Inferring the instance context] + +-- e.g. inferConstraints +-- C Int (T [a]) -- Class and inst_tys +-- :RTList a -- Rep tycon and its arg tys +-- where T [a] ~R :RTList a +-- +-- Generate a sufficiently large set of constraints that typechecking the +-- generated method definitions should succeed. This set will be simplified +-- before being used in the instance declaration +inferConstraints mechanism (DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs + , denv_cls = main_cls + , denv_inst_tys = inst_tys }) + = do { let wildcard = isStandaloneWildcardDeriv ctxt + infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) + infer_constraints = + case mechanism of + DerivSpecStock{dsm_stock_dit = dit} + -> do (thetas, tvs, inst_tys, dit') <- inferConstraintsStock dit + pure ( thetas, tvs, inst_tys + , mechanism{dsm_stock_dit = dit'} ) + DerivSpecAnyClass + -> infer_constraints_simple inferConstraintsAnyclass + DerivSpecNewtype { dsm_newtype_dit = + DerivInstTys{dit_cls_tys = cls_tys} + , dsm_newtype_rep_ty = rep_ty } + -> infer_constraints_simple $ + inferConstraintsCoerceBased cls_tys rep_ty + DerivSpecVia { dsm_via_cls_tys = cls_tys + , dsm_via_ty = via_ty } + -> infer_constraints_simple $ + inferConstraintsCoerceBased cls_tys via_ty + + -- Most deriving strategies do not need to do anything special to + -- the type variables and arguments to the class in the derived + -- instance, so they can pass through unchanged. The exception to + -- this rule is stock deriving. See + -- Note [Inferring the instance context]. + infer_constraints_simple + :: DerivM ThetaSpec + -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) + infer_constraints_simple infer_thetas = do + thetas <- infer_thetas + pure (thetas, tvs, inst_tys, mechanism) + + -- Constraints arising from superclasses + -- See Note [Superclasses of derived instance] + cls_tvs = classTyVars main_cls + sc_constraints = assertPpr (equalLength cls_tvs inst_tys) + (ppr main_cls <+> ppr inst_tys) $ + mkDirectThetaSpec + (mkDerivOrigin wildcard) TypeLevel + (substTheta cls_subst (classSCTheta main_cls)) + cls_subst = assert (equalLength cls_tvs inst_tys) $ + zipTvSubst cls_tvs inst_tys + + ; (inferred_constraints, tvs', inst_tys', mechanism') + <- infer_constraints + ; lift $ traceTc "inferConstraints" $ vcat + [ ppr main_cls <+> ppr inst_tys' + , ppr inferred_constraints + ] + ; return ( sc_constraints ++ inferred_constraints + , tvs', inst_tys', mechanism' ) } + +-- | Like 'inferConstraints', but used only in the case of the @stock@ deriving +-- strategy. The constraints are inferred by inspecting the fields of each data +-- constructor. In this example: +-- +-- > data Foo = MkFoo Int Char deriving Show +-- +-- We would infer the following constraints ('ThetaSpec's): +-- +-- > (Show Int, Show Char) +-- +-- Note that this function also returns the type variables ('TyVar's) and +-- class arguments ('TcType's) for the resulting instance. This is because +-- when deriving 'Functor'-like classes, we must sometimes perform kind +-- substitutions to ensure the resulting instance is well kinded, which may +-- affect the type variables and class arguments. In this example: +-- +-- > newtype Compose (f :: k -> Type) (g :: Type -> k) (a :: Type) = +-- > Compose (f (g a)) deriving stock Functor +-- +-- We must unify @k@ with @Type@ in order for the resulting 'Functor' instance +-- to be well kinded, so we return @[]@/@[Type, f, g]@ for the +-- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@. +-- See Note [Inferring the instance context]. +inferConstraintsStock :: DerivInstTys + -> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys) +inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys + , dit_tc = tc + , dit_tc_args = tc_args + , dit_rep_tc = rep_tc + , dit_rep_tc_args = rep_tc_args }) + = do DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs + , denv_cls = main_cls + , denv_inst_tys = inst_tys } <- ask + let wildcard = isStandaloneWildcardDeriv ctxt + inst_ty = mkTyConApp tc tc_args + tc_binders = tyConBinders rep_tc + choose_level bndr + | isNamedTyConBinder bndr = KindLevel + | otherwise = TypeLevel + t_or_ks = map choose_level tc_binders ++ repeat TypeLevel + -- want to report *kind* errors when possible + + -- Constraints arising from the arguments of each constructor + con_arg_constraints + :: ([TyVar] -> CtOrigin + -> TypeOrKind + -> Type + -> [(ThetaSpec, Maybe Subst)]) + -> (ThetaSpec, [TyVar], [TcType], DerivInstTys) + con_arg_constraints get_arg_constraints + = let -- Constraints from the fields of each data constructor. + (predss, mbSubsts) = unzip + [ preds_and_mbSubst + | data_con <- tyConDataCons rep_tc + , (arg_n, arg_t_or_k, arg_ty) + <- zip3 [1..] t_or_ks $ + derivDataConInstArgTys data_con dit + -- No constraints for unlifted types + -- See Note [Deriving and unboxed types] + , not (isUnliftedType arg_ty) + , let orig = DerivOriginDC data_con arg_n wildcard + , preds_and_mbSubst + <- get_arg_constraints (dataConUnivTyVars data_con) + orig arg_t_or_k arg_ty + ] + -- Stupid constraints from DatatypeContexts. Note that we + -- must gather these constraints from the data constructors, + -- not from the parent type constructor, as the latter could + -- lead to redundant constraints due to thinning. + -- See Note [The stupid context] in GHC.Core.DataCon. + stupid_theta = + [ substTyWith (dataConUnivTyVars data_con) + (dataConInstUnivs data_con rep_tc_args) + stupid_pred + | data_con <- tyConDataCons rep_tc + , stupid_pred <- dataConStupidTheta data_con + ] + + preds = concat predss + -- If the constraints require a subtype to be of kind + -- (* -> *) (which is the case for functor-like + -- constraints), then we explicitly unify the subtype's + -- kinds with (* -> *). + -- See Note [Inferring the instance context] + subst = foldl' composeTCvSubst + emptySubst (catMaybes mbSubsts) + unmapped_tvs = filter (\v -> v `notElemSubst` subst + && not (v `isInScope` subst)) tvs + (subst', _) = substTyVarBndrs subst unmapped_tvs + stupid_theta_origin = mkDirectThetaSpec + deriv_origin TypeLevel + (substTheta subst' stupid_theta) + preds' = map (substPredSpec subst') preds + inst_tys' = substTys subst' inst_tys + dit' = substDerivInstTys subst' dit + tvs' = tyCoVarsOfTypesWellScoped inst_tys' + in ( stupid_theta_origin ++ preds' + , tvs', inst_tys', dit' ) + + is_generic = main_cls `hasKey` genClassKey + is_generic1 = main_cls `hasKey` gen1ClassKey + -- is_functor_like: see Note [Inferring the instance context] + is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind + || is_generic1 + + get_gen1_constraints :: + Class + -> [TyVar] -- The universally quantified type variables for the + -- data constructor + -> CtOrigin -> TypeOrKind -> Type + -> [(ThetaSpec, Maybe Subst)] + get_gen1_constraints functor_cls dc_univs orig t_or_k ty + = mk_functor_like_constraints orig t_or_k functor_cls $ + get_gen1_constrained_tys last_dc_univ ty + where + -- If we are deriving an instance of 'Generic1' and have made + -- it this far, then there should be at least one universal type + -- variable, making this use of 'last' safe. + last_dc_univ = assert (not (null dc_univs)) $ + last dc_univs + + get_std_constrained_tys :: + [TyVar] -- The universally quantified type variables for the + -- data constructor + -> CtOrigin -> TypeOrKind -> Type + -> [(ThetaSpec, Maybe Subst)] + get_std_constrained_tys dc_univs orig t_or_k ty + | is_functor_like + = mk_functor_like_constraints orig t_or_k main_cls $ + deepSubtypesContaining last_dc_univ ty + | otherwise + = [( [mk_cls_pred orig t_or_k main_cls ty] + , Nothing )] + where + -- If 'is_functor_like' holds, then there should be at least one + -- universal type variable, making this use of 'last' safe. + last_dc_univ = assert (not (null dc_univs)) $ + last dc_univs + + mk_functor_like_constraints :: CtOrigin -> TypeOrKind + -> Class -> [Type] + -> [(ThetaSpec, Maybe Subst)] + -- 'cls' is usually main_cls (Functor or Traversable etc), but if + -- main_cls = Generic1, then 'cls' can be Functor; see + -- get_gen1_constraints + -- + -- For each type, generate two constraints, + -- [cls ty, kind(ty) ~ (*->*)], and a kind substitution that results + -- from unifying kind(ty) with * -> *. If the unification is + -- successful, it will ensure that the resulting instance is well + -- kinded. If not, the second constraint will result in an error + -- message which points out the kind mismatch. + -- See Note [Inferring the instance context] + mk_functor_like_constraints orig t_or_k cls + = map $ \ty -> let ki = typeKind ty in + ( [ mk_cls_pred orig t_or_k cls ty + , SimplePredSpec + { sps_pred = mkNomEqPred ki typeToTypeKind + , sps_origin = orig + , sps_type_or_kind = KindLevel + } + ] + , tcUnifyTy ki typeToTypeKind + ) + + -- Extra Data constraints + -- The Data class (only) requires that for + -- instance (...) => Data (T t1 t2) + -- IF t1:*, t2:* + -- THEN (Data t1, Data t2) are among the (...) constraints + -- Reason: when the IF holds, we generate a method + -- dataCast2 f = gcast2 f + -- and we need the Data constraints to typecheck the method + extra_constraints + | main_cls `hasKey` dataClassKey + , all (isLiftedTypeKind . typeKind) rep_tc_args + = [ mk_cls_pred deriv_origin t_or_k main_cls ty + | (t_or_k, ty) <- zip t_or_ks rep_tc_args] + | otherwise + = [] + + mk_cls_pred orig t_or_k cls ty + -- Don't forget to apply to cls_tys' too + = SimplePredSpec + { sps_pred = mkClassPred cls (cls_tys' ++ [ty]) + , sps_origin = orig + , sps_type_or_kind = t_or_k + } + cls_tys' | is_generic1 = [] + -- In the awkward Generic1 case, cls_tys' should be + -- empty, since we are applying the class Functor. + + | otherwise = cls_tys + + deriv_origin = mkDerivOrigin wildcard + + if -- Generic constraints are easy + | is_generic + -> return ([], tvs, inst_tys, dit) + + -- Generic1 needs Functor + -- See Note [Getting base classes] + | is_generic1 + -> assert (tyConTyVars rep_tc `lengthExceeds` 0) $ + -- Generic1 has a single kind variable + assert (cls_tys `lengthIs` 1) $ + do { functorClass <- lift $ tcLookupClass functorClassName + ; pure $ con_arg_constraints + $ get_gen1_constraints functorClass } + + -- The others are a bit more complicated + | otherwise + -> do { let (arg_constraints, tvs', inst_tys', dit') + = con_arg_constraints get_std_constrained_tys + ; lift $ traceTc "inferConstraintsStock" $ vcat + [ ppr main_cls <+> ppr inst_tys' + , ppr arg_constraints + ] + ; return ( extra_constraints ++ arg_constraints + , tvs', inst_tys', dit' ) } + +-- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@, +-- which gathers its constraints based on the type signatures of the class's +-- methods instead of the types of the data constructor's field. +-- +-- See Note [Gathering and simplifying constraints for DeriveAnyClass] +-- for an explanation of how these constraints are used to determine the +-- derived instance context. +inferConstraintsAnyclass :: DerivM ThetaSpec +inferConstraintsAnyclass + = do { DerivEnv { denv_ctxt = ctxt + , denv_cls = cls + , denv_inst_tys = inst_tys } <- ask + ; let gen_dms = [ (sel_id, dm_ty) + | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] + + ; let wildcard = isStandaloneWildcardDeriv ctxt + meth_pred :: (Id, Type) -> PredSpec + -- (Id,Type) are the selector Id and the generic default method type + -- NB: the latter is /not/ quantified over the class variables + -- See Note [Gathering and simplifying constraints for DeriveAnyClass] + meth_pred (sel_id, gen_dm_ty) + = let (sel_tvs, _cls_pred, meth_ty) = tcSplitMethodTy (varType sel_id) + meth_ty' = substTyWith sel_tvs inst_tys meth_ty + gen_dm_ty' = substTyWith sel_tvs inst_tys gen_dm_ty in + -- This is the only place where a SubTypePredSpec is + -- constructed instead of a SimplePredSpec. See + -- Note [Gathering and simplifying constraints for DeriveAnyClass] + -- for a more in-depth explanation. + SubTypePredSpec { stps_ty_actual = gen_dm_ty' + , stps_ty_expected = meth_ty' + , stps_origin = mkDerivOrigin wildcard + } + + ; pure $ map meth_pred gen_dms } + +-- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and +-- @DerivingVia@. Since both strategies generate code involving 'coerce', the +-- inferred constraints set up the scaffolding needed to typecheck those uses +-- of 'coerce'. In this example: +-- +-- > newtype Age = MkAge Int deriving newtype Num +-- +-- We would infer the following constraints ('ThetaSpec'): +-- +-- > (Num Int, Coercible Age Int) +inferConstraintsCoerceBased :: [Type] -> Type + -> DerivM ThetaSpec +inferConstraintsCoerceBased cls_tys rep_ty = do + DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys } <- ask + let -- rep_ty might come from: + -- GeneralizedNewtypeDeriving / DerivSpecNewtype: + -- the underlying type of the newtype () + -- DerivingVia / DerivSpecVia + -- the `via` type + + rep_pred_o = SimplePredSpec { sps_pred = mkClassPred cls (cls_tys ++ [rep_ty]) + , sps_origin = deriv_origin + , sps_type_or_kind = TypeLevel + } + -- rep_pred is the representation dictionary, from where + -- we are going to get all the methods for the final + -- dictionary + deriv_origin = mkDerivOrigin sa_wildcard + sa_wildcard = isStandaloneWildcardDeriv ctxt + + -- Next we collect constraints for the class methods + -- If there are no methods, we don't need any constraints + -- Otherwise we need (C rep_ty), for the representation methods, + -- and constraints to coerce each individual method + meth_preds :: ThetaSpec + meth_preds | null meths = [] -- No methods => no constraints (#12814) + | otherwise = rep_pred_o : coercible_constraints + meths = classMethods cls + + coercible_constraints + = [ SimplePredSpec + { sps_pred = + assertPpr (tvs1 == tvs2) (ppr t1 $$ ppr t2) $ + -- assert: mkCoerceClassMethEqn returns two + -- foralls with the very same forall-binders + tcMkDFunSigmaTy tvs2 theta2 $ + mkConstraintTupleTy $ mkReprEqPred tau1 tau2 : theta1 + -- The two method types (tau1, tau2) must be coercible. + -- Also, if there are constraints, the constraints + -- provided to the derived method (theta2) must be + -- sufficient to solve the constraints required by the + -- method being coerced (theta1). + -- See Note [Inferred contexts from method constraints] + , sps_origin = DerivOriginCoerce meth t1 t2 sa_wildcard + , sps_type_or_kind = TypeLevel + } + | meth <- meths + , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs + inst_tys rep_ty meth + -- If we have class C a b c where { op :: op_ty } + -- and inst_tys = [t1, t2, t3] + -- then t1 = op_ty{t1,t2,rep_ty/a,b,c] + -- t2 = op_ty{t1,t2,t3/a,b,c] + , let (tvs1, theta1, tau1) = tcSplitSigmaTy t1 + , let (tvs2, theta2, tau2) = tcSplitSigmaTy t2 + ] + + pure meth_preds + +{- Note [Inferring the instance context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are two sorts of 'deriving', as represented by the two constructors +for DerivContext: + + * InferContext mb_wildcard: This can either be: + - The deriving clause for a data type. + (e.g, data T a = T1 a deriving( Eq )) + In this case, mb_wildcard = Nothing. + - A standalone declaration with an extra-constraints wildcard + (e.g., deriving instance _ => Eq (Foo a)) + In this case, mb_wildcard = Just loc, where loc is the location + of the extra-constraints wildcard. + + Here we must infer an instance context, + and generate instance declaration + instance Eq a => Eq (T a) where ... + + * SupplyContext theta: standalone deriving + deriving instance Eq a => Eq (T a) + Here we only need to fill in the bindings; + the instance context (theta) is user-supplied + +For the InferContext case, we must figure out the +instance context (inferConstraintsStock). Suppose we are inferring +the instance context for + C t1 .. tn (T s1 .. sm) +There are two cases + + * (T s1 .. sm) :: * (the normal case) + Then we behave like Eq and guess (C t1 .. tn t) + for each data constructor arg of type t. More + details below. + + * (T s1 .. sm) :: * -> * (the functor-like case) + Then we behave like Functor. + +In both cases we produce a bunch of un-simplified constraints +and them simplify them in simplifyInstanceContexts; see +Note [Simplifying the instance context]. + +In the functor-like case, we may need to unify some kind variables with * in +order for the generated instance to be well-kinded. An example from #10524: + + newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) + = Compose (f (g a)) deriving Functor + +Earlier in the deriving pipeline, GHC unifies the kind of Compose f g +(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this +alone isn't enough, since k2 wasn't unified with *: + + instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) => + Functor (Compose f g) where ... + +The two Functor constraints are ill-kinded. To ensure this doesn't happen, we: + + 1. Collect all of a datatype's subtypes which require functor-like + constraints. + 2. For each subtype, create a substitution by unifying the subtype's kind + with (* -> *). + 3. Compose all the substitutions into one, then apply that substitution to + all of the in-scope type variables and the instance types. + +Note [Getting base classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Functor and Typeable are defined in package 'base', and that is not available +when compiling 'ghc-prim'. So we must be careful that 'deriving' for stuff in +ghc-prim does not use Functor or Typeable implicitly via these lookups. + +Note [Deriving and unboxed types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have some special hacks to support things like + data T = MkT Int# deriving ( Show ) + +Specifically, we use GHC.Tc.Deriv.Generate.box to box the Int# into an Int +(which we know how to show), and append a '#'. Parentheses are not required +for unboxed values (`MkT -3#` is a valid expression). + +Note [Superclasses of derived instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, a derived instance decl needs the superclasses of the derived +class too. So if we have + data T a = ...deriving( Ord ) +then the initial context for Ord (T a) should include Eq (T a). Often this is +redundant; we'll also generate an Ord constraint for each constructor argument, +and that will probably generate enough constraints to make the Eq (T a) constraint +be satisfied too. But not always; consider: + + data S a = S + instance Eq (S a) + instance Ord (S a) + + data T a = MkT (S a) deriving( Ord ) + instance Num a => Eq (T a) + +The derived instance for (Ord (T a)) must have a (Num a) constraint! +Similarly consider: + data T a = MkT deriving( Data ) +Here there *is* no argument field, but we must nevertheless generate +a context for the Data instances: + instance Typeable a => Data (T a) where ... + +Note [Inferred contexts from method constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the `deriving Alt` part of this example (from the passing part of +T20815a): + + class Alt f where + some :: forall a. Applicative f => f a -> f [a] + + newtype T f a = T (f a) deriving Alt + +We will produce this derived instance declaration: + + instance (Alt f, ???) => Alt (T f) where + some :: forall a. Applicative (T f) => T f a -> T f [a] + some @a (d1 :: Applicative (T f)) + = coerce @(f a -> f [a]) + @(T f a -> T f [a]) + (d2 :: Coercible (f a -> f [a]) (T f a -> T f [a])) + (some @f (d3 :: Alt f) @a (d4 :: Applicative f)) + +(Dictionary abstractions and applications are added here even though they are +not usually visible, or even emitted in the code generated by `deriving`.) + +The task of `inferConstraints` is to determine the `???` such that it will be +sufficient to solve the constraints arising from that definition of `some`. We +can write out what the type checker sees as follows: + + forall f + [G] Alt f -- Given + [G] ??? -- Given + => + forall a. + [G] Applicative (T f) -- Also given (as d1) + => + [W] Coercible (f a -> f [a]) (T f a -> T f [a]) -- Wanted (as d2) + [W] Alt f -- Wanted (as d3) + [W] Applicative f -- Wanted (as d4) + +`d3` is trivially provided by the given `Alt f`. The simplest way to ensure that +`d4` and `d2` can be solved is to: + +* Generate this "target constraint" (in `inferConstraintsCoerceBased`): + + forall a. Applicative (T f) + => ( Coercible (f a -> f [a]) (T f a -> T f [a]) + , Applicative f + ) + +* Simplify the target constraint (in `simplifyInstanceContexts`, which in turn + calls `simplifyDeriv`). This solves the `Coercible` constraint outright, but + cannot solve the `Applicative f` constraint. + See Note [Simplifying the instance context] + +* The leftover, unsolved constraint (here `Applicative f`) becomes the `???` in + the derived instance decl. + +The target constraint for GND is created in `inferConstraintsCoerceBased`. + +In general, the point here is that the inferred context for a derived instance +must include, for each class method with constraints, a quantified constraint +mapping the provided context for the derived method to both: + - the `Coercible` corresponding to the monotypes of the base and derived + methods, and + - the needed context for the base method. + + +************************************************************************ +* * + Finding the fixed point of deriving equations +* * +************************************************************************ + +Note [Simplifying the instance context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T a b = C1 (Foo a) (Bar b) + | C2 Int (T b a) + | C3 (T a a) + deriving (Eq) + +We want to come up with an instance declaration of the form + + instance (Ping a, Pong b, ...) => Eq (T a b) where + x == y = ... + +It is pretty easy, albeit tedious, to fill in the code "...". The +trick is to figure out what the context for the instance decl is, +namely Ping, Pong and friends. + +Let's call the context reqd for the T instance of class C at types +(a,b, ...) C (T a b). Thus: + + Eq (T a b) = (Ping a, Pong b, ...) + +Now we can get a (recursive) equation from the data decl. This part +is done by inferConstraintsStock. + + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + +Foo and Bar may have explicit instances for Eq, in which case we can +just substitute for them. Alternatively, either or both may have +their Eq instances given by deriving clauses, in which case they +form part of the system of equations. + +Now all we need do is simplify and solve the equations, iterating to +find the least fixpoint. This is done by simplifyInstanceConstraints. +Notice that the order of the arguments can +switch around, as here in the recursive calls to T. + +Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b. + +We start with: + + Eq (T a b) = {} -- The empty set + +Next iteration: + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + After simplification: + = Eq a u Ping b u {} u {} u {} + = Eq a u Ping b + +Next iteration: + + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + After simplification: + = Eq a u Ping b + u (Eq b u Ping a) + u (Eq a u Ping a) + + = Eq a u Ping b u Eq b u Ping a + +The next iteration gives the same result, so this is the fixpoint. We +need to make a canonical form of the RHS to ensure convergence. We do +this by simplifying the RHS to a form in which + + - the classes constrain only tyvars + - the list is sorted by tyvar (major key) and then class (minor key) + - no duplicates, of course + +Note [Deterministic simplifyInstanceContexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting +with nonDetCmpType puts the returned lists in a nondeterministic order. +If we were to return them, we'd get class constraints in +nondeterministic order. + +Consider: + + data ADT a b = Z a b deriving Eq + +The generated code could be either: + + instance (Eq a, Eq b) => Eq (Z a b) where + +Or: + + instance (Eq b, Eq a) => Eq (Z a b) where + +To prevent the order from being nondeterministic we only +canonicalize when comparing and return them in the same order as +simplifyDeriv returned them. +See also Note [nonDetCmpType nondeterminism] +-} + + +simplifyInstanceContexts :: [DerivSpec ThetaSpec] + -> TcM [DerivSpec ThetaType] +-- Used only for deriving clauses or standalone deriving with an +-- extra-constraints wildcard (InferContext) +-- See Note [Simplifying the instance context] + +simplifyInstanceContexts [] = return [] + +simplifyInstanceContexts infer_specs + = do { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs) + ; final_specs <- iterate_deriv 1 initial_solutions + -- After simplification finishes, zonk the TcTyVars as described + -- in Note [Overlap and deriving]. + ; initZonkEnv DefaultFlexi $ traverse zonkDerivSpec final_specs } + where + ------------------------------------------------------------------ + -- The initial solutions for the equations claim that each + -- instance has an empty context; this solution is certainly + -- in canonical form. + initial_solutions :: [ThetaType] + initial_solutions = [ [] | _ <- infer_specs ] + + ------------------------------------------------------------------ + -- iterate_deriv calculates the next batch of solutions, + -- compares it with the current one; finishes if they are the + -- same, otherwise recurses with the new solutions. + -- It fails if any iteration fails + iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType] + iterate_deriv n current_solns + | n > 20 -- Looks as if we are in an infinite loop + -- This can happen if we have -XUndecidableInstances + -- (See GHC.Tc.Solver.tcSimplifyDeriv.) + = pprPanic "solveDerivEqns: probable loop" + (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns) + | otherwise + = do { -- Extend the inst info from the explicit instance decls + -- with the current set of solutions, and simplify each RHS + inst_specs <- zipWithM (\soln -> newDerivClsInst . setDerivSpecTheta soln) + current_solns infer_specs + ; new_solns <- checkNoErrs $ + extendLocalInstEnv inst_specs $ + mapM simplifyDeriv infer_specs + + ; if (current_solns `eqSolution` new_solns) then + return [ setDerivSpecTheta soln spec + | (spec, soln) <- zip infer_specs current_solns ] + else + iterate_deriv (n+1) new_solns } + + eqSolution = (liftEq . liftEq) eqType `on` canSolution + -- Canonicalise for comparison + -- See Note [Deterministic simplifyInstanceContexts] + canSolution = map (sortBy nonDetCmpType) + +{- +*********************************************************************************** +* * +* Simplify derived constraints +* * +*********************************************************************************** +-} + + +-- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much +-- as possible. Fail if not possible. +simplifyDeriv :: DerivSpec ThetaSpec + -> TcM ThetaType -- ^ Needed constraints (after simplification), + -- i.e. @['PredType']@. +simplifyDeriv (DS { ds_loc = loc, ds_tvs = tvs + , 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 (mkClassPred clas inst_tys)) $ + do { + -- See [STEP DAC BUILD] + -- Generate the implication constraints, one for each method, to solve + -- with the skolemized variables. Start "one level down" because + -- we are going to wrap the result in an implication with tvs, + -- in step [DAC RESIDUAL] + ; (tc_lvl, wanteds) <- captureThetaSpecConstraints user_ctxt deriv_rhs + + ; traceTc "simplifyDeriv inputs" $ + vcat [ pprTyVars tvs $$ ppr deriv_rhs $$ ppr wanteds, ppr skol_info ] + + -- See [STEP DAC SOLVE] + -- Simplify the constraints, starting at the same level at which + -- they are generated (c.f. the call to runTcSWithEvBinds in + -- simplifyInfer) + ; (solved_wanteds, _) <- setTcLevel tc_lvl $ + runTcS $ + solveWanteds wanteds + + -- It's not yet zonked! Obviously zonk it before peering at it + ; solved_wanteds <- liftZonkM $ zonkWC solved_wanteds + + -- See [STEP DAC HOIST] + -- From the simplified constraints extract a subset 'good' that will + -- become the context 'min_theta' for the derived instance. + ; let residual_simple = approximateWC False solved_wanteds + -- False: ignore any non-quantifiable constraints, + -- including equalities hidden under Given equalities + head_size = pSizeClassPred clas inst_tys + good = mapMaybeBag get_good residual_simple + + -- Returns @Just p@ (where @p@ is the type of the Ct) if a Ct is + -- suitable to be inferred in the context of a derived instance. + -- Returns @Nothing@ if the Ct is too exotic. + -- See (VD2) in Note [Valid 'deriving' predicate] in + -- GHC.Tc.Validity for what constitutes an exotic constraint. + get_good :: Ct -> Maybe PredType + get_good ct | validDerivPred head_size p = Just p + | otherwise = Nothing + where p = ctPred ct + + ; traceTc "simplifyDeriv outputs" $ + vcat [ ppr tvs, ppr residual_simple, ppr good ] + + -- Return the good unsolved constraints (unskolemizing on the way out.) + ; let min_theta = mkMinimalBySCs id (bagToList good) + -- An important property of mkMinimalBySCs (used above) is that in + -- addition to removing constraints that are made redundant by + -- superclass relationships, it also removes _duplicate_ + -- constraints. + -- See Note [Gathering and simplifying constraints for + -- DeriveAnyClass] + + -- See [STEP DAC RESIDUAL] + -- Ensure that min_theta is enough to solve /all/ the constraints in + -- solved_wanteds, by solving the implication constraint + -- + -- forall tvs. min_theta => solved_wanteds + ; min_theta_vars <- mapM newEvVar min_theta + ; (leftover_implic, _) + <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) tvs + min_theta_vars solved_wanteds + -- This call to simplifyTop is purely for error reporting + -- See Note [Error reporting for deriving clauses] + -- See also Note [Valid 'deriving' predicate] in GHC.Tc.Validity, as this + -- line of code catches "exotic" constraints like the ones described in + -- (VD2) of that Note. + ; simplifyTopImplic leftover_implic + + ; traceTc "GHC.Tc.Deriv" (ppr deriv_rhs $$ ppr min_theta) + + -- Claim: the result instance declaration is guaranteed valid + -- Hence no need to call: + -- checkValidInstance tyvars theta clas inst_tys + -- See Note [Valid 'deriving' predicate] in GHC.Tc.Validity + + ; return min_theta } + +{- +Note [Overlap and deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider some overlapping instances: + instance Show a => Show [a] where .. + instance Show [Char] where ... + +Now a data type with deriving: + data T a = MkT [a] deriving( Show ) + +We want to get the derived instance + instance Show [a] => Show (T a) where... +and NOT + instance Show a => Show (T a) where... +so that the (Show (T Char)) instance does the Right Thing + +It's very like the situation when we're inferring the type +of a function + f x = show [x] +and we want to infer + f :: Show [a] => a -> String + +As a result, we use vanilla, non-overlappable skolems when inferring the +context for the derived instances. Hence, we instantiate the type variables +using tcInstSkolTyVars, not tcInstSuperSkolTyVars. + +We do this skolemisation in GHC.Tc.Deriv.mkEqnHelp, a function which occurs +very early in the deriving pipeline, so that by the time GHC needs to infer the +instance context, all of the types in the computed DerivSpec have been +skolemised appropriately. After the instance context inference has completed, +GHC zonks the TcTyVars in the DerivSpec to ensure that types like +a[sk:1] do not appear in -ddump-deriv output. + +All of this is only needed when inferring an instance context, i.e., the +InferContext case. For the SupplyContext case, we don't bother skolemising +at all. + +Note [Gathering and simplifying constraints for DeriveAnyClass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DeriveAnyClass works quite differently from stock and newtype deriving in +the way it gathers and simplifies constraints to be used in a derived +instance's context. Stock and newtype deriving gather constraints by looking +at the data constructors of the data type for which we are deriving an +instance. But DeriveAnyClass doesn't need to know about a data type's +definition at all! + +To see why, consider this example of DeriveAnyClass: + + class Foo a where + bar :: forall b. Ix b => a -> b -> String + default bar :: (Show a, Ix c) => a -> c -> String + bar x y = show x ++ show (range (y,y)) + + baz :: Eq a => a -> a -> Bool + default baz :: (Ord a, Show a) => a -> a -> Bool + baz x y = compare x y == EQ + +Because 'bar' and 'baz' have default signatures, this generates a top-level +definition for these generic default methods + + $gdm_bar :: forall a. Foo a + => forall c. (Show a, Ix c) + => a -> c -> String + $gdm_bar x y = show x ++ show (range (y,y)) + +(and similarly for baz). Now consider a 'deriving' clause + data Maybe s = ... deriving anyclass Foo + +This derives an instance of the form: + instance (CX) => Foo (Maybe s) where + bar = $gdm_bar + baz = $gdm_baz + +Now it is GHC's job to fill in a suitable instance context (CX). If +GHC were typechecking the binding + bar = $gdm_bar +it would + * skolemise the expected type of bar + * instantiate the type of $gdm_bar with meta-type variables + * build an implication constraint + +[STEP DAC BUILD] +So that's what we do. Fortunately, there is already functionality within GHC +to that does all of the above—namely, tcSubTypeSigma. In the example above, +we want to use tcSubTypeSigma to check the following subtyping relation: + + forall c. (Show a, Ix c) => Maybe s -> c -> String -- actual type + <= forall b. (Ix b) => Maybe s -> b -> String -- expected type + +That is, we check that the type of $gdm_bar (the actual type) is more +polymorphic than the type of bar (the expected type). We use SubTypePredSpec, +a special form of PredSpec that is only used by DeriveAnyClass, to store +the actual and expected types. + +(Aside: having a separate SubTypePredSpec is not strictly necessary, as we +could theoretically construct this implication constraint by hand and store it +in a SimplePredSpec. In fact, GHC used to do this. However, this is easier +said than done, and there were numerous subtle bugs that resulted from getting +this step wrong, such as #20719. Ultimately, we decided that special-casing a +PredSpec specifically for DeriveAnyClass was worth it.) + +tcSubTypeSigma will ultimately spit out an implication constraint, which will +look something like this (call it C1): + + forall[2] b. Ix b => (Show (Maybe s), Ix cc, + Maybe s -> b -> String + ~ Maybe s -> cc -> String) + +Here: +* The level of this forall constraint is forall[2], because we are later + going to wrap it in a forall[1] in [STEP DAC RESIDUAL] + +* The 'b' comes from the quantified type variable in the expected type + of bar. The 'cc' is a unification variable that comes from instantiating the + quantified type variable 'c' in $gdm_bar's type. The finer details of + skolemisation and metavariable instantiation are handled behind the scenes + by tcSubTypeSigma. + +* It is important that `b` be distinct from `cc`. In this example, this is + clearly the case, but it is not always so obvious when the type variables are + hidden behind type synonyms. Suppose the example were written like this, + for example: + + type Method a = forall b. Ix b => a -> b -> String + class Foo a where + bar :: Method a + default bar :: Show a => Method a + bar = ... + + Both method signatures quantify a `b` once the `Method` type synonym is + expanded. To ensure that GHC doesn't confuse the two `b`s during + typechecking, tcSubTypeSigma instantiates the `b` in the original signature + with a fresh skolem and the `b` in the default signature with a fresh + unification variable. Doing so prevents #20719 from happening. + +* The (Ix b) constraint comes from the context of bar's type. The + (Show (Maybe s)) and (Ix cc) constraints come from the context of $gdm_bar's + type. + +* The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String) + comes from marrying up the instantiated type of $gdm_bar with the specified + type of bar. Notice that the type variables from the instance, 's' in this + case, are global to this constraint. + +Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new +unification variable for each iteration of simplifyDeriv. If we re-use the same +unification variable across multiple iterations, then bad things can happen, +such as #14933. + +Similarly for 'baz', tcSubTypeSigma gives the constraint C2 + + forall[2]. Eq (Maybe s) => (Ord a, Show a, + Maybe s -> Maybe s -> Bool + ~ Maybe s -> Maybe s -> Bool) + +In this case baz has no local quantification, so the implication +constraint has no local skolems and there are no unification +variables. + +[STEP DAC SOLVE] +We can combine these two implication constraints into a single +constraint (C1, C2), and simplify, unifying cc:=b, to get: + + forall[2] b. Ix b => Show a + /\ + forall[2]. Eq (Maybe s) => (Ord a, Show a) + +[STEP DAC HOIST] +Let's call that (C1', C2'). Now we need to hoist the unsolved +constraints out of the implications to become our candidate for +(CX). That is done by approximateWC, which will return: + + (Show a, Ord a, Show a) + +Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving + + (Show a, Ord a) + +And that's what GHC uses for CX. + +[STEP DAC RESIDUAL] +In this case we have solved all the leftover constraints, but what if +we don't? Simple! We just form the final residual constraint + + forall[1] s. CX => (C1',C2') + +and simplify that. In simple cases it'll succeed easily, because CX +literally contains the constraints in C1', C2', but if there is anything +more complicated it will be reported in a civilised way. + +Note [Error reporting for deriving clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A surprisingly tricky aspect of deriving to get right is reporting sensible +error messages. In particular, if simplifyDeriv reaches a constraint that it +cannot solve, which might include: + +1. Insoluble constraints +2. "Exotic" constraints (See Note [Valid 'deriving' predicate] in + GHC.Tc.Validity) + +Then we report an error immediately in simplifyDeriv. + +Another possible choice is to punt and let another part of the typechecker +(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead +to worse error messages, so we do it directly in simplifyDeriv. + +simplifyDeriv checks for errors in a clever way. If the deriving machinery +infers the context (Foo a)--that is, if this instance is to be generated: + + instance Foo a => ... + +Then we form an implication of the form: + + forall a. Foo a => + +And pass it to the simplifier. If the context (Foo a) is enough to discharge +all the constraints in , then everything is +hunky-dory. But if contains, say, an insoluble +constraint, then (Foo a) won't be able to solve it, causing GHC to error. +-} diff --git a/GHC/Tc/Deriv/Utils.hs b/GHC/Tc/Deriv/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv/Utils.hs @@ -0,0 +1,1279 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Error-checking and other utilities for @deriving@ clauses or declarations. +module GHC.Tc.Deriv.Utils ( + DerivM, DerivEnv(..), + DerivSpec(..), pprDerivSpec, setDerivSpecTheta, zonkDerivSpec, + DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock, + isDerivSpecNewtype, isDerivSpecAnyClass, + isDerivSpecVia, zonkDerivSpecMechanism, + DerivContext(..), OriginativeDerivStatus(..), StockGenFns(..), + isStandaloneDeriv, isStandaloneWildcardDeriv, + askDerivUserTypeCtxt, mkDerivOrigin, + PredSpec(..), ThetaSpec, + mkDirectThetaSpec, substPredSpec, captureThetaSpecConstraints, + checkOriginativeSideConditions, hasStockDeriving, + std_class_via_coercible, non_coercible_class, + newDerivClsInst, extendLocalInstEnv + ) where + +import GHC.Prelude + +import GHC.Hs.Extension +import GHC.Data.Bag +import GHC.Types.Basic + +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Tc.Deriv.Generics +import GHC.Tc.Errors.Types +import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical) +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Unify (tcSubTypeSigma) +import GHC.Tc.Zonk.Type + +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv +import GHC.Core.TyCon +import GHC.Core.Type + +import GHC.Hs +import GHC.Driver.Session +import GHC.Unit.Module (getModule) +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModIface (mi_fix) + +import GHC.Iface.Load (loadInterfaceForName) + +import GHC.Types.Fixity.Env (lookupFixity) +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Var.Set + +import GHC.Builtin.Names +import GHC.Builtin.Names.TH (liftClassKey) + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Error +import GHC.Utils.Unique (sameUnique) + +import Control.Monad.Trans.Reader +import Data.Maybe +import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.List.SetOps (assocMaybe) + +-- | To avoid having to manually plumb everything in 'DerivEnv' throughout +-- various functions in "GHC.Tc.Deriv" and "GHC.Tc.Deriv.Infer", we use 'DerivM', which +-- is a simple reader around 'TcRn'. +type DerivM = ReaderT DerivEnv TcRn + +-- | Is GHC processing a standalone deriving declaration? +isStandaloneDeriv :: DerivM Bool +isStandaloneDeriv = asks (go . denv_ctxt) + where + go :: DerivContext -> Bool + go (InferContext wildcard) = isJust wildcard + go (SupplyContext {}) = True + +-- | Is GHC processing a standalone deriving declaration with an +-- extra-constraints wildcard as the context? +-- (e.g., @deriving instance _ => Eq (Foo a)@) +isStandaloneWildcardDeriv :: DerivContext -> Bool +isStandaloneWildcardDeriv (InferContext wildcard) = isJust wildcard +isStandaloneWildcardDeriv (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 :: Bool -> CtOrigin +mkDerivOrigin standalone = DerivOrigin standalone + +-- | Contains all of the information known about a derived instance when +-- determining what its @EarlyDerivSpec@ should be. +-- See @Note [DerivEnv and DerivSpecMechanism]@. +data DerivEnv = DerivEnv + { denv_overlap_mode :: Maybe OverlapMode + -- ^ Is this an overlapping instance? + , denv_tvs :: [TyVar] + -- ^ Universally quantified type variables in the instance. If the + -- @denv_ctxt@ is 'InferContext', these will be 'TcTyVar' skolems. + -- If the @denv_ctxt@ is 'SupplyContext', these will be ordinary 'TyVar's. + -- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer". + -- + -- All type variables that appear in the 'denv_inst_tys', 'denv_ctxt', + -- 'denv_skol_info', and 'denv_strat' should come from 'denv_tvs'. + , denv_cls :: Class + -- ^ Class for which we need to derive an instance + , denv_inst_tys :: [Type] + -- ^ All arguments to 'denv_cls' in the derived instance. + , denv_ctxt :: DerivContext + -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the + -- context of the instance). + -- 'InferContext' for @deriving@ clauses, or for standalone deriving that + -- uses a wildcard constraint. + -- See @Note [Inferring the instance context]@. + , denv_skol_info :: SkolemInfo + -- ^ The 'SkolemInfo' used to skolemise the @denv_tvs@ in the case where + -- the 'denv_ctxt' is 'InferContext'. + , denv_strat :: Maybe (DerivStrategy GhcTc) + -- ^ 'Just' if user requests a particular deriving strategy. + -- Otherwise, 'Nothing'. + , denv_warn :: Maybe (WarningTxt GhcRn) + -- ^ A warning to emit whenever the derived instance is used + } + +instance Outputable DerivEnv where + ppr (DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys + , denv_ctxt = ctxt + , denv_skol_info = skol_info + , denv_strat = mb_strat }) + = hang (text "DerivEnv") + 2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode + , text "denv_tvs" <+> ppr tvs + , text "denv_cls" <+> ppr cls + , text "denv_inst_tys" <+> ppr inst_tys + , text "denv_ctxt" <+> ppr ctxt + , text "denv_skol_info" <+> ppr skol_info + , text "denv_strat" <+> ppr mb_strat ]) + +data DerivSpec theta = DS { ds_loc :: SrcSpan + , ds_name :: Name -- DFun name + , ds_tvs :: [TyVar] + , ds_theta :: theta + , ds_cls :: Class + , ds_tys :: [Type] + , ds_skol_info :: SkolemInfo + , ds_user_ctxt :: UserTypeCtxt + , ds_overlap :: Maybe OverlapMode + , ds_standalone_wildcard :: Maybe SrcSpan + -- See Note [Inferring the instance context] + -- in GHC.Tc.Deriv.Infer + , ds_mechanism :: DerivSpecMechanism + , ds_warn :: Maybe (WarningTxt GhcRn)} + -- This spec implies a dfun declaration of the form + -- df :: forall tvs. theta => C tys + -- The Name is the name for the DFun we'll build + -- The tyvars bind all the variables in the rest of the DerivSpec. + -- If we are inferring an instance context, the tyvars will be TcTyVar + -- skolems. After the instance context inference is over, the tyvars + -- will be zonked to TyVars. See + -- Note [Overlap and deriving] in GHC.Tc.Deriv.Infer. + + -- the theta is either the given and final theta, in standalone deriving, + -- or the not-yet-simplified list of constraints together with their origin + + -- The ds_skol_info is the SkolemInfo that was used to skolemise the + -- TcTyVars (if we are inferring an instance context). The ds_user_ctxt + -- is the UserTypeCtxt that allows error messages to know if we are in + -- a deriving clause or a standalone deriving declaration. + + -- ds_mechanism specifies the means by which GHC derives the instance. + -- See Note [Deriving strategies] in GHC.Tc.Deriv + +{- +Example: + + newtype instance T [a] = MkT (Tree a) deriving( C s ) +==> + axiom T [a] = :RTList a + axiom :RTList a = Tree a + + DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]] + , ds_mechanism = DerivSpecNewtype (Tree a) } +-} + +pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc +pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c, + ds_tys = tys, ds_theta = rhs, ds_skol_info = skol_info, + ds_standalone_wildcard = wildcard, ds_mechanism = mech }) + = hang (text "DerivSpec") + 2 (vcat [ text "ds_loc =" <+> ppr l + , text "ds_name =" <+> ppr n + , text "ds_tvs =" <+> ppr tvs + , text "ds_cls =" <+> ppr c + , text "ds_tys =" <+> ppr tys + , text "ds_theta =" <+> ppr rhs + , text "ds_skol_info =" <+> ppr skol_info + , text "ds_standalone_wildcard =" <+> ppr wildcard + , text "ds_mechanism =" <+> ppr mech ]) + +instance Outputable theta => Outputable (DerivSpec theta) where + ppr = pprDerivSpec + +-- | Set the 'ds_theta' in a 'DerivSpec'. +setDerivSpecTheta :: theta' -> DerivSpec theta -> DerivSpec theta' +setDerivSpecTheta theta ds = ds{ds_theta = theta} + +-- | Zonk the 'TcTyVar's in a 'DerivSpec' to 'TyVar's. +-- See @Note [What is zonking?]@ in "GHC.Tc.Zonk.Type". +-- +-- 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 -> ZonkTcM (DerivSpec ThetaType) +zonkDerivSpec ds@(DS { ds_tvs = tvs, ds_theta = theta + , ds_tys = tys, ds_mechanism = mechanism + }) = + runZonkBndrT (zonkTyBndrsX tvs) $ \ tvs' -> do + theta' <- zonkTcTypesToTypesX theta + tys' <- zonkTcTypesToTypesX tys + mechanism' <- zonkDerivSpecMechanism mechanism + pure ds{ ds_tvs = tvs', ds_theta = theta' + , ds_tys = tys', ds_mechanism = mechanism' + } + +-- | What action to take in order to derive a class instance. +-- See @Note [DerivEnv and DerivSpecMechanism]@, as well as +-- @Note [Deriving strategies]@ in "GHC.Tc.Deriv". +data DerivSpecMechanism + -- | \"Standard\" classes + = DerivSpecStock + { dsm_stock_dit :: DerivInstTys + -- ^ Information about the arguments to the class in the derived + -- instance, including what type constructor the last argument is + -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. + , dsm_stock_gen_fns :: StockGenFns + -- ^ How to generate the instance bindings and associated type family + -- instances. + } + + -- | @GeneralizedNewtypeDeriving@ + | DerivSpecNewtype + { dsm_newtype_dit :: DerivInstTys + -- ^ Information about the arguments to the class in the derived + -- instance, including what type constructor the last argument is + -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. + , dsm_newtype_rep_ty :: Type + -- ^ The newtype rep type. + } + + -- | @DeriveAnyClass@ + | DerivSpecAnyClass + + -- | @DerivingVia@ + | DerivSpecVia + { dsm_via_cls_tys :: [Type] + -- ^ All arguments to the class besides the last one. + , dsm_via_inst_ty :: Type + -- ^ The last argument to the class. + , dsm_via_ty :: Type + -- ^ The @via@ type + } + +-- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. +derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc +derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy noExtField +derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy noExtField +derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy noExtField +derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t + +isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia + :: DerivSpecMechanism -> Bool +isDerivSpecStock (DerivSpecStock{}) = True +isDerivSpecStock _ = False + +isDerivSpecNewtype (DerivSpecNewtype{}) = True +isDerivSpecNewtype _ = False + +isDerivSpecAnyClass DerivSpecAnyClass = True +isDerivSpecAnyClass _ = False + +isDerivSpecVia (DerivSpecVia{}) = True +isDerivSpecVia _ = False + +-- | Zonk the 'TcTyVar's in a 'DerivSpecMechanism' to 'TyVar's. +-- See @Note [What is zonking?]@ in "GHC.Tc.Zonk.Type". +-- +-- 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 :: DerivSpecMechanism -> ZonkTcM DerivSpecMechanism +zonkDerivSpecMechanism mechanism = + case mechanism of + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fns = gen_fns + } -> do + dit' <- zonkDerivInstTys 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 dit + rep_ty' <- zonkTcTypeToTypeX 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 cls_tys + inst_ty' <- zonkTcTypeToTypeX inst_ty + via_ty' <- zonkTcTypeToTypeX via_ty + pure $ DerivSpecVia { dsm_via_cls_tys = cls_tys' + , dsm_via_inst_ty = inst_ty' + , dsm_via_ty = via_ty' + } + +instance Outputable DerivSpecMechanism where + ppr (DerivSpecStock{dsm_stock_dit = dit}) + = hang (text "DerivSpecStock") + 2 (vcat [ text "dsm_stock_dit" <+> ppr dit ]) + ppr (DerivSpecNewtype { dsm_newtype_dit = dit, dsm_newtype_rep_ty = rep_ty }) + = hang (text "DerivSpecNewtype") + 2 (vcat [ text "dsm_newtype_dit" <+> ppr dit + , text "dsm_newtype_rep_ty" <+> ppr rep_ty ]) + ppr DerivSpecAnyClass = text "DerivSpecAnyClass" + ppr (DerivSpecVia { dsm_via_cls_tys = cls_tys, dsm_via_inst_ty = inst_ty + , dsm_via_ty = via_ty }) + = hang (text "DerivSpecVia") + 2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys + , text "dsm_via_inst_ty" <+> ppr inst_ty + , text "dsm_via_ty" <+> ppr via_ty ]) + +{- +Note [DerivEnv and DerivSpecMechanism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DerivEnv contains all of the bits and pieces that are common to every +deriving strategy. (See Note [Deriving strategies] in GHC.Tc.Deriv.) Some deriving +strategies impose stricter requirements on the types involved in the derived +instance than others, and these differences are factored out into the +DerivSpecMechanism type. Suppose that the derived instance looks like this: + + instance ... => C arg_1 ... arg_n + +Each deriving strategy imposes restrictions on arg_1 through arg_n as follows: + +* stock (DerivSpecStock): + + Stock deriving requires that: + + - n must be a positive number. This is checked by + GHC.Tc.Deriv.expectNonNullaryClsArgs + - arg_n must be an application of an algebraic type constructor. Here, + "algebraic type constructor" means: + + + An ordinary data type constructor, or + + A data family type constructor such that the arguments it is applied to + give rise to a data family instance. + + This is checked by GHC.Tc.Deriv.expectAlgTyConApp. + + This extra structure is witnessed by the DerivInstTys data type, which stores + arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor + (dit_tc), and its arguments (dit_tc_args). A DerivInstTys value can be seen + as a more structured representation of the denv_inst_tys field of DerivEnv. + + If dit_tc is an ordinary data type constructor, then + dit_rep_tc/dit_rep_tc_args are the same as dit_tc/dit_tc_args. If dit_tc is a + data family type constructor, then dit_rep_tc is the representation type + constructor for the data family instance, and dit_rep_tc_args are the + arguments to the representation type constructor in the corresponding + instance. + +* newtype (DerivSpecNewtype): + + Newtype deriving imposes the same DerivInstTys requirements as stock + deriving. This is necessary because we need to know what the underlying type + that the newtype wraps is, and this information can only be learned by + knowing dit_rep_tc. + +* anyclass (DerivSpecAnyclass): + + DeriveAnyClass is the most permissive deriving strategy of all, as it + essentially imposes no requirements on the derived instance. This is because + DeriveAnyClass simply derives an empty instance, so it does not need any + particular knowledge about the types involved. It can do several things + that stock/newtype deriving cannot do (#13154): + + - n can be 0. That is, one is allowed to anyclass-derive an instance with + no arguments to the class, such as in this example: + + class C + deriving anyclass instance C + + - One can derive an instance for a type that is not headed by a type + constructor, such as in the following example: + + class C (n :: Nat) + deriving instance C 0 + deriving instance C 1 + ... + + - One can derive an instance for a data family with no data family instances, + such as in the following example: + + data family Foo a + class C a + deriving anyclass instance C (Foo a) + +* via (DerivSpecVia): + + Like newtype deriving, DerivingVia requires that n must be a positive number. + This is because when one derives something like this: + + deriving via Foo instance C Bar + + Then the generated code must specifically mention Bar. However, in + contrast with newtype deriving, DerivingVia does *not* require Bar to be + an application of an algebraic type constructor. This is because the + generated code simply defers to invoking `coerce`, which does not need to + know anything in particular about Bar (besides that it is representationally + equal to Foo). This allows DerivingVia to do some things that are not + possible with newtype deriving, such as deriving instances for data families + without data instances (#13154): + + data family Foo a + newtype ByBar a = ByBar a + class Baz a where ... + instance Baz (ByBar a) where ... + deriving via ByBar (Foo a) instance Baz (Foo a) +-} + +-- | Whether GHC is processing a @deriving@ clause or a standalone deriving +-- declaration. +data DerivContext + = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either: + -- + -- * A @deriving@ clause (in which case + -- @mb_wildcard@ is 'Nothing'). + -- + -- * A standalone deriving declaration with + -- an extra-constraints wildcard as the + -- context (in which case @mb_wildcard@ is + -- @'Just' loc@, where @loc@ is the location + -- of the wildcard. + -- + -- GHC should infer the context. + + | SupplyContext ThetaType -- ^ @'SupplyContext' theta@ is a standalone + -- deriving declaration, where @theta@ is the + -- context supplied by the user. + +instance Outputable DerivContext where + ppr (InferContext standalone) = text "InferContext" <+> ppr standalone + ppr (SupplyContext theta) = text "SupplyContext" <+> ppr theta + +-- | Records whether a particular class can be derived by way of an +-- /originative/ deriving strategy (i.e., @stock@ or @anyclass@). +-- +-- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv". +data OriginativeDerivStatus + = CanDeriveStock StockGenFns -- Stock class, can derive + | StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it + | CanDeriveAnyClass -- See Note [Deriving any class] + | NonDerivableClass -- Cannot derive with either stock or anyclass + +-- | Describes how to generate instance bindings ('stock_gen_binds') and +-- associated type family instances ('stock_gen_fam_insts') for a particular +-- stock-derived instance. +data StockGenFns = StockGenFns + { stock_gen_binds :: + SrcSpan -> DerivInstTys + -> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name]) + -- ^ Describes how to generate instance bindings for a stock-derived + -- instance. + -- + -- This function takes two arguments: + -- + -- 1. 'SrcSpan': the source location where the instance is being derived. + -- This will eventually be instantiated with the 'ds_loc' field of a + -- 'DerivSpec'. + -- + -- 2. 'DerivInstTys': information about the argument types to which a + -- class is applied in a derived instance. This will eventually be + -- instantiated with the 'dsm_stock_dit' field of a + -- 'DerivSpecMechanism'. + -- + -- This function returns four things: + -- + -- 1. @'LHsBinds' 'GhcPs'@: The derived instance's function bindings + -- (e.g., @compare (T x) (T y) = compare x y@) + -- + -- 2. @['LSig' 'GhcPs']@: A list of instance specific signatures/pragmas. + -- Most likely @INLINE@ pragmas for class methods. + -- + -- 3. @'Bag' 'AuxBindSpec'@: Auxiliary bindings needed to support the + -- derived instance. As examples, derived 'Eq' and 'Ord' instances + -- sometimes require top-level @con2tag@ functions. + -- See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate". + -- + -- 4. @['Name']@: A list of Names for which @-Wunused-binds@ should be + -- suppressed. This is used to suppress unused warnings for record + -- selectors when deriving 'Read', 'Show', or 'Generic'. + -- See @Note [Deriving and unused record selectors]@. + , stock_gen_fam_insts :: + SrcSpan -> DerivInstTys + -> TcM [FamInst] + -- ^ Describes how to generate associated type family instances for a + -- stock-derived instance. This function takes the same arguments as the + -- 'stock_gen_binds' function but returns a list of 'FamInst's instead. + -- Generating type family instances is done separately from + -- 'stock_gen_binds' since the type family instances must be generated + -- before the instance bindings can be typechecked. See + -- @Note [Staging of tcDeriving]@ in "GHC.Tc.Deriv". + } + +-- A stock class is one either defined in the Haskell report or for which GHC +-- otherwise knows how to generate code for (possibly requiring the use of a +-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.) + +-- | A 'PredSpec' specifies a constraint to emitted when inferring the +-- instance context for a derived instance in 'GHC.Tc.Deriv.simplifyInfer'. +data PredSpec + = -- | An ordinary 'PredSpec' that directly stores a 'PredType', which + -- will be emitted as a wanted constraint in the constraint solving + -- machinery. This is the simple case, as there are no skolems, + -- metavariables, or given constraints involved. + SimplePredSpec + { sps_pred :: TcPredType + -- ^ The constraint to emit as a wanted + -- Usually just a simple predicate like (Eq a) or (ki ~# Type), + -- but can be a forall-constraint: + -- * in the case of GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased + -- * if a class has quantified-constraint superclasses, + -- via `mkDirectThetaSpec` in `inferConstraints` + + , sps_origin :: CtOrigin + -- ^ The origin of the constraint + + , sps_type_or_kind :: TypeOrKind + -- ^ Whether the constraint is a type or kind + } + + | -- | A special 'PredSpec' that is only used by @DeriveAnyClass@. This + -- will check if @stps_ty_actual@ is a subtype of (i.e., more polymorphic + -- than) @stps_ty_expected@ in the constraint solving machinery, emitting an + -- implication constraint as a side effect. For more details on how this + -- works, see @Note [Gathering and simplifying constraints for DeriveAnyClass]@ + -- in "GHC.Tc.Deriv.Infer". + SubTypePredSpec + { stps_ty_actual :: TcSigmaType + -- ^ The actual type. In the context of @DeriveAnyClass@, this is the + -- default method type signature. + , stps_ty_expected :: TcSigmaType + -- ^ The expected type. In the context of @DeriveAnyClass@, this is the + -- original method type signature. + , stps_origin :: CtOrigin + -- ^ The origin of the constraint + } + +-- | A list of 'PredSpec' constraints to simplify when inferring a +-- derived instance's context. For the @stock@, @newtype@, and @via@ deriving +-- strategies, these will consist of 'SimplePredSpec's, and for +-- @DeriveAnyClass@, these will consist of 'SubTypePredSpec's. Here is an +-- example to illustrate the latter: +-- +-- @ +-- class Foo a where +-- bar :: forall b. Ix b => a -> b -> String +-- default bar :: forall y. (Show a, Ix y) => a -> y -> String +-- bar x y = show x ++ show (range (y, y)) +-- +-- baz :: Eq a => a -> a -> Bool +-- default baz :: Ord a => a -> a -> Bool +-- baz x y = compare x y == EQ +-- +-- data Quux q = Quux deriving anyclass Foo +-- @ +-- +-- Then it would generate two 'SubTypePredSpec's, one for each method: +-- +-- @ +-- [ SubTypePredSpec +-- { stps_ty_actual = forall y. (Show (Quux q), Ix y) => Quux q -> y -> String +-- , stps_ty_expected = forall b. (Ix b) => Quux q -> b -> String +-- , stps_ty_origin = DerivClauseCtxt +-- } +-- , SubTypePredSpec +-- { stps_ty_actual = Ord (Quux q) => Quux q -> Quux q -> Bool +-- , stps_ty_expected = Eq (Quux q) => Quux q -> Quux q -> Bool +-- , stps_ty_origin = DerivClauseCtxt +-- } +-- ] +-- @ +-- +-- (Note that the type variable @q@ is bound by the data type @Quux@, and thus +-- appears free in the 'stps_ty_actual's and 'stps_ty_expected's.) +-- +-- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@ +-- in "GHC.Tc.Deriv.Infer" for an explanation of how these 'SubTypePredSpec's +-- are used to compute implication constraints. +type ThetaSpec = [PredSpec] + +instance Outputable PredSpec where + ppr (SimplePredSpec{sps_pred = ty}) = + hang (text "SimplePredSpec") + 2 (vcat [ text "sps_pred" <+> ppr ty ]) + ppr (SubTypePredSpec { stps_ty_actual = ty_actual + , stps_ty_expected = ty_expected }) = + hang (text "SubTypePredSpec") + 2 (vcat [ text "stps_ty_actual" <+> ppr ty_actual + , text "stps_ty_expected" <+> ppr ty_expected + ]) + +-- | Build a list of 'SimplePredSpec's, using the supplied 'CtOrigin' and +-- 'TypeOrKind' values for each 'PredType'. +mkDirectThetaSpec :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaSpec +mkDirectThetaSpec origin t_or_k = + map (\p -> SimplePredSpec + { sps_pred = p + , sps_origin = origin + , sps_type_or_kind = t_or_k + }) + +substPredSpec :: HasDebugCallStack => Subst -> PredSpec -> PredSpec +substPredSpec subst ps = + case ps of + SimplePredSpec { sps_pred = pred + , sps_origin = origin + , sps_type_or_kind = t_or_k + } + -> SimplePredSpec { sps_pred = substTy subst pred + , sps_origin = origin + , sps_type_or_kind = t_or_k + } + + SubTypePredSpec { stps_ty_actual = ty_actual + , stps_ty_expected = ty_expected + , stps_origin = origin + } + -> SubTypePredSpec { stps_ty_actual = substTy subst ty_actual + , stps_ty_expected = substTy subst ty_expected + , stps_origin = origin + } + +-- | Capture wanted constraints from a 'ThetaSpec'. +captureThetaSpecConstraints :: + UserTypeCtxt -- ^ Used to inform error messages as to whether + -- we are in a @deriving@ clause or a standalone + -- @deriving@ declaration + -> ThetaSpec -- ^ The specs from which constraints will be created + -> TcM (TcLevel, WantedConstraints) +captureThetaSpecConstraints user_ctxt theta + = pushTcLevelM $ mk_wanteds theta + where + -- Create the constraints we need to solve. For stock and newtype + -- deriving, these constraints will be simple wanted constraints + -- like (C a, Ord b). + -- But with DeriveAnyClass, we make an implication constraint. + -- See Note [Gathering and simplifying constraints for DeriveAnyClass] + -- in GHC.Tc.Deriv.Infer. + mk_wanteds :: ThetaSpec -> TcM WantedConstraints + mk_wanteds preds + = do { (_, wanteds) <- captureConstraints $ + mapM_ (emitPredSpecConstraints user_ctxt) preds + ; pure wanteds } + +emitPredSpecConstraints :: UserTypeCtxt -> PredSpec -> TcM () +--- Emit the appropriate constraints depending on what sort of +-- PredSpec we are dealing with. +emitPredSpecConstraints _ (SimplePredSpec { sps_pred = wanted_pred + , sps_origin = orig + , sps_type_or_kind = t_or_k }) + = do { ev <- newWanted orig (Just t_or_k) wanted_pred + ; emitSimple (mkNonCanonical ev) } + +emitPredSpecConstraints user_ctxt + (SubTypePredSpec { stps_ty_actual = ty_actual + , stps_ty_expected = ty_expected + , stps_origin = orig }) +-- 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. + = do { _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected + ; return () } + +{- +************************************************************************ +* * + Class deriving diagnostics +* * +************************************************************************ + +Only certain blessed classes can be used in a deriving clause (without the +assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes +are listed below in the definition of hasStockDeriving. The stockSideConditions +function determines the criteria that needs to be met in order for a particular +stock class to be able to be derived successfully. + +A class might be able to be used in a deriving clause if -XDeriveAnyClass +is willing to support it. +-} + +hasStockDeriving + :: Class -> Maybe StockGenFns +hasStockDeriving clas + = assocMaybe gen_list (getUnique clas) + where + gen_list :: [(Unique, StockGenFns)] + gen_list = + [ (eqClassKey, mk (simple_bindsM gen_Eq_binds) no_fam_insts) + , (ordClassKey, mk (simple_bindsM gen_Ord_binds) no_fam_insts) + , (enumClassKey, mk (simple_bindsM gen_Enum_binds) no_fam_insts) + , (boundedClassKey, mk (simple_binds gen_Bounded_binds) no_fam_insts) + , (ixClassKey, mk (simple_bindsM gen_Ix_binds) no_fam_insts) + , (showClassKey, mk (read_or_show_binds gen_Show_binds) no_fam_insts) + , (readClassKey, mk (read_or_show_binds gen_Read_binds) no_fam_insts) + , (dataClassKey, mk (simple_bindsM gen_Data_binds) no_fam_insts) + , (functorClassKey, mk (simple_binds gen_Functor_binds) no_fam_insts) + , (foldableClassKey, mk (simple_binds gen_Foldable_binds) no_fam_insts) + , (traversableClassKey, mk (simple_binds gen_Traversable_binds) no_fam_insts) + , (liftClassKey, mk (simple_binds gen_Lift_binds) no_fam_insts) + , (genClassKey, mk (generic_binds Gen0) (generic_fam_inst Gen0)) + , (gen1ClassKey, mk (generic_binds Gen1) (generic_fam_inst Gen1)) + ] + + mk gen_binds_fn gen_fam_insts_fn = StockGenFns + { stock_gen_binds = gen_binds_fn + , stock_gen_fam_insts = gen_fam_insts_fn + } + + simple_binds gen_fn loc dit + = let (binds, aux_specs) = gen_fn loc dit + in return (binds, [], aux_specs, []) + + -- Like `simple`, but monadic. The only monadic thing that these functions + -- do is allocate new Uniques, which are used for generating the names of + -- auxiliary bindings. + -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. + simple_bindsM gen_fn loc dit + = do { (binds, aux_specs) <- gen_fn loc dit + ; return (binds, [], aux_specs, []) } + + read_or_show_binds gen_fn loc dit + = do { let tc = dit_rep_tc dit + ; fix_env <- getDataConFixityFun tc + ; let (binds, aux_specs) = gen_fn fix_env loc dit + field_names = all_field_names tc + ; return (binds, [], aux_specs, field_names) } + + generic_binds gk loc dit + = do { let tc = dit_rep_tc dit + ; (binds, sigs) <- gen_Generic_binds gk loc dit + ; let field_names = all_field_names tc + ; return (binds, sigs, emptyBag, field_names) } + + generic_fam_inst gk loc dit + = do { let tc = dit_rep_tc dit + ; fix_env <- getDataConFixityFun tc + ; faminst <- gen_Generic_fam_inst gk fix_env loc dit + ; return [faminst] } + + no_fam_insts _ _ = pure [] + + -- See Note [Deriving and unused record selectors] + all_field_names = map flSelector . concatMap dataConFieldLabels + . tyConDataCons + +{- +Note [Deriving and unused record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (see #13919): + + module Main (main) where + + data Foo = MkFoo {bar :: String} deriving Show + + main :: IO () + main = print (Foo "hello") + +Strictly speaking, the record selector `bar` is unused in this module, since +neither `main` nor the derived `Show` instance for `Foo` mention `bar`. +However, the behavior of `main` is affected by the presence of `bar`, since +it will print different output depending on whether `MkFoo` is defined using +record selectors or not. Therefore, we do not to issue a +"Defined but not used: ‘bar’" warning for this module, since removing `bar` +changes the program's behavior. This is the reason behind the [Name] part of +the return type of `hasStockDeriving`—it tracks all of the record selector +`Name`s for which -Wunused-binds should be suppressed. + +Currently, the only three stock derived classes that require this are Read, +Show, and Generic, as their derived code all depend on the record selectors +of the derived data type's constructors. + +See also Note [Unused constructors and deriving clauses] in GHC.Tc.Deriv for +another example of a similar trick. +-} + +getDataConFixityFun :: TyCon -> TcM (Name -> Fixity) +-- If the TyCon is locally defined, we want the local fixity env; +-- but if it is imported (which happens for standalone deriving) +-- we need to get the fixity env from the interface file +-- c.f. GHC.Rename.Env.lookupFixity, #9830, and #20994 +getDataConFixityFun tc + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name + then do { fix_env <- getFixityEnv + ; return (lookupFixity fix_env) } + else do { iface <- loadInterfaceForName doc name + -- Should already be loaded! + ; return (mi_fix iface . nameOccName) } } + where + name = tyConName tc + doc = text "Data con fixities for" <+> ppr name + +------------------------------------------------------------------ +-- Check side conditions that dis-allow derivability for the originative +-- deriving strategies (stock and anyclass). +-- See Note [Deriving strategies] in GHC.Tc.Deriv for an explanation of what +-- "originative" means. +-- +-- This is *apart* from the coerce-based strategies, newtype and via. +-- +-- Here we get the representation tycon in case of family instances as it has +-- the data constructors - but we need to be careful to fall back to the +-- family tycon (with indexes) in error messages. + +checkOriginativeSideConditions :: DerivInstTys -> DerivM OriginativeDerivStatus +checkOriginativeSideConditions dit@(DerivInstTys{dit_cls_tys = cls_tys}) = + do DerivEnv { denv_cls = cls + , denv_ctxt = deriv_ctxt } <- ask + dflags <- getDynFlags + + if -- First, check if stock deriving is possible... + | Just cond <- stockSideConditions deriv_ctxt cls + -> case cond dflags dit of + NotValid err -> pure $ StockClassError err -- Class-specific error + IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys) + -- All stock derivable classes are unary in the sense that + -- there should be not types in cls_tys (i.e., no type args + -- other than last). Note that cls_types can contain + -- invisible types as well (e.g., for Generic1, which is + -- poly-kinded), so make sure those are not counted. + , Just gen_fn <- hasStockDeriving cls + -> pure $ CanDeriveStock gen_fn + | otherwise + -> pure $ StockClassError $ classArgsErr cls cls_tys + -- e.g. deriving( Eq s ) + + -- ...if not, try falling back on DeriveAnyClass. + | xopt LangExt.DeriveAnyClass dflags + -> pure CanDeriveAnyClass -- DeriveAnyClass should work + + | otherwise + -> pure NonDerivableClass -- Neither anyclass nor stock work + + +classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason +classArgsErr cls cls_tys = DerivErrNotAClass (mkClassPred cls cls_tys) + +-- Side conditions (whether the datatype must have at least one constructor, +-- required language extensions, etc.) for using GHC's stock deriving +-- mechanism on certain classes (as opposed to classes that require +-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a +-- class for which stock deriving isn't possible. +stockSideConditions :: DerivContext -> Class -> Maybe Condition +stockSideConditions deriv_ctxt cls + | sameUnique cls_key eqClassKey = Just (cond_std `andCond` cond_args cls) + | sameUnique cls_key ordClassKey = Just (cond_std `andCond` cond_args cls) + | sameUnique cls_key showClassKey = Just (cond_std `andCond` cond_args cls) + | sameUnique cls_key readClassKey = Just (cond_std `andCond` cond_args cls) + | sameUnique cls_key enumClassKey = Just (cond_std `andCond` cond_isEnumeration) + | sameUnique cls_key ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) + | sameUnique cls_key boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) + | sameUnique cls_key dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond` + cond_vanilla `andCond` + cond_args cls) + | sameUnique cls_key functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond` + cond_vanilla `andCond` + cond_functorOK True False) + | sameUnique cls_key foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond` + cond_vanilla `andCond` + cond_functorOK False True) + -- Functor/Fold/Trav works ok + -- for rank-n types + | sameUnique cls_key traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond` + cond_vanilla `andCond` + cond_functorOK False False) + | sameUnique cls_key genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` + cond_vanilla `andCond` + cond_RepresentableOk) + | sameUnique cls_key gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` + cond_vanilla `andCond` + cond_Representable1Ok) + | sameUnique cls_key liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond` + checkFlag LangExt.ImplicitStagePersistence `andCond` + cond_vanilla `andCond` + cond_args cls) + | otherwise = Nothing + where + cls_key = getUnique cls + cond_std = cond_stdOK deriv_ctxt False + -- Vanilla data constructors, at least one, and monotype arguments + cond_vanilla = cond_stdOK deriv_ctxt True + -- Vanilla data constructors but allow no data cons or polytype arguments + +type Condition + = DynFlags + + -> DerivInstTys -- ^ Information about the type arguments to the class. + + -> Validity' DeriveInstanceErrReason + -- ^ 'IsValid' if deriving an instance for this type is + -- possible. Otherwise, it's @'NotValid' err@, where @err@ + -- explains what went wrong. + +andCond :: Condition -> Condition -> Condition +andCond c1 c2 dflags dit + = c1 dflags dit `andValid` c2 dflags dit + +-- | Some common validity checks shared among stock derivable classes. One +-- check that absolutely must hold is that if an instance @C (T a)@ is being +-- derived, then @T@ must be a tycon for a data type or a newtype. The +-- remaining checks are only performed if using a @deriving@ clause (i.e., +-- they're ignored if using @StandaloneDeriving@): +-- +-- 1. The data type must have at least one constructor (this check is ignored +-- if using @EmptyDataDeriving@). +-- +-- 2. The data type cannot have any GADT constructors. +-- +-- 3. The data type cannot have any constructors with existentially quantified +-- type variables. +-- +-- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@). +-- +-- 5. The data type cannot have fields with higher-rank types. +cond_stdOK + :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a + -- user-supplied context, 'InferContext' if not. + -- If it is the former, we relax some of the validity checks + -- we would otherwise perform (i.e., "just go for it"). + + -> Bool -- ^ 'True' <=> allow higher rank arguments and empty data + -- types (with no data constructors) even in the absence of + -- the -XEmptyDataDeriving extension. + + -> Condition +cond_stdOK deriv_ctxt permissive dflags + dit@(DerivInstTys{dit_tc = tc, dit_rep_tc = rep_tc}) + = valid_ADT `andValid` valid_misc + where + valid_ADT, valid_misc :: Validity' DeriveInstanceErrReason + valid_ADT + | isAlgTyCon tc || isDataFamilyTyCon tc + = IsValid + | otherwise + -- Complain about functions, primitive types, and other tycons that + -- stock deriving can't handle. + = NotValid DerivErrLastArgMustBeApp + + valid_misc + = case deriv_ctxt of + SupplyContext _ -> IsValid + -- Don't check these conservative conditions for + -- standalone deriving; just generate the code + -- and let the typechecker handle the result + InferContext wildcard + | null data_cons -- 1. + , not permissive + , not (xopt LangExt.EmptyDataDeriving dflags) + -> NotValid (no_cons_why rep_tc) + | not (null con_whys) + -> NotValid $ DerivErrBadConstructor (Just $ has_wildcard wildcard) con_whys + | otherwise + -> IsValid + + has_wildcard wildcard + = case wildcard of + Just _ -> YesHasWildcard + Nothing -> NoHasWildcard + data_cons = tyConDataCons rep_tc + con_whys = getInvalids (map check_con data_cons) + + check_con :: DataCon -> Validity' DeriveInstanceBadConstructor + check_con con + | not (null eq_spec) -- 2. + = bad DerivErrBadConIsGADT + | not (null ex_tvs) -- 3. + = bad DerivErrBadConHasExistentials + | not (null theta) -- 4. + = bad DerivErrBadConHasConstraints + | not (permissive || all isTauTy (derivDataConInstArgTys con dit)) -- 5. + = bad DerivErrBadConHasHigherRankType + | otherwise + = IsValid + where + (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con + bad mkErr = NotValid $ mkErr con + +no_cons_why :: TyCon -> DeriveInstanceErrReason +no_cons_why = DerivErrNoConstructors + +cond_RepresentableOk :: Condition +cond_RepresentableOk _ dit = + case canDoGenerics dit of + IsValid -> IsValid + NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs + +cond_Representable1Ok :: Condition +cond_Representable1Ok _ dit = + case canDoGenerics1 dit of + IsValid -> IsValid + NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs + +cond_enumOrProduct :: Class -> Condition +cond_enumOrProduct cls = cond_isEnumeration `orCond` + (cond_isProduct `andCond` cond_args cls) + where + orCond :: Condition -> Condition -> Condition + orCond c1 c2 dflags dit + = case (c1 dflags dit, c2 dflags dit) of + (IsValid, _) -> IsValid -- c1 succeeds + (_, IsValid) -> IsValid -- c21 succeeds + (NotValid x, NotValid y) -> NotValid $ DerivErrEnumOrProduct x y + -- Both fail + + +cond_args :: Class -> Condition +-- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types +-- by generating specialised code. For others (eg 'Data') we don't. +-- For even others (eg 'Lift'), unlifted types aren't even a special +-- consideration! +cond_args cls _ dit@(DerivInstTys{dit_rep_tc = rep_tc}) + = case bad_args of + [] -> IsValid + (ty:_) -> NotValid $ DerivErrDunnoHowToDeriveForType ty + where + bad_args = [ arg_ty | con <- tyConDataCons rep_tc + , arg_ty <- derivDataConInstArgTys con dit + , mightBeUnliftedType arg_ty + , not (ok_ty arg_ty) ] + + cls_key = classKey cls + ok_ty arg_ty + | cls_key == eqClassKey = check_in arg_ty ordOpTbl + | cls_key == ordClassKey = check_in arg_ty ordOpTbl + | cls_key == showClassKey = check_in arg_ty boxConTbl + | cls_key == liftClassKey = True -- Lift is representation-polymorphic + | otherwise = False -- Read, Ix etc + + check_in :: Type -> [(Type,a)] -> Bool + check_in arg_ty tbl = any (eqType arg_ty . fst) tbl + + +cond_isEnumeration :: Condition +cond_isEnumeration _ (DerivInstTys{dit_rep_tc = rep_tc}) + | isEnumerationTyCon rep_tc = IsValid + | otherwise = NotValid $ DerivErrMustBeEnumType rep_tc + +cond_isProduct :: Condition +cond_isProduct _ (DerivInstTys{dit_rep_tc = rep_tc}) + | Just _ <- tyConSingleDataCon_maybe rep_tc + = IsValid + | otherwise + = NotValid $ DerivErrMustHaveExactlyOneConstructor rep_tc + +cond_functorOK :: Bool -> Bool -> Condition +-- OK for Functor/Foldable/Traversable class +-- Currently: (a) at least one argument +-- (b) don't use argument contravariantly +-- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) +-- (d) optionally: don't use function types +-- (e) no "stupid context" on data type +cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ + dit@(DerivInstTys{dit_rep_tc = rep_tc}) + | null tc_tvs + = NotValid $ DerivErrMustHaveSomeParameters rep_tc + + -- We can't handle stupid contexts that mention the last type argument, + -- so error out if we encounter one. + -- See Note [The stupid context] in GHC.Core.DataCon. + | not (null bad_stupid_theta) + = NotValid $ DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta + + | otherwise + = allValid (map check_con data_cons) + where + tc_tvs = tyConTyVars rep_tc + last_tv = last tc_tvs + bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) + is_bad pred = last_tv `elemVarSet` exactTyCoVarsOfType pred + -- See Note [Check that the type variable is truly universal] + + data_cons = tyConDataCons rep_tc + check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con dit) + + check_universal :: DataCon -> Validity' DeriveInstanceErrReason + check_universal con + | allowExQuantifiedLastTyVar + = IsValid -- See Note [DeriveFoldable with ExistentialQuantification] + -- in GHC.Tc.Deriv.Functor + | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) + , tv `elem` dataConUnivTyVars con + , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con)) + = IsValid -- See Note [Check that the type variable is truly universal] + | otherwise + = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConExistential con] + + ft_check :: DataCon -> FFoldType (Validity' DeriveInstanceErrReason) + ft_check con = FT { ft_triv = IsValid, ft_var = IsValid + , ft_co_var = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConCovariant con] + , ft_fun = \x y -> if allowFunctions then x `andValid` y + else NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConFunTypes con] + , ft_tup = \_ xs -> allValid xs + , ft_ty_app = \_ _ x -> x + , ft_bad_app = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConWrongArg con] + , ft_forall = \_ x -> x } + + +checkFlag :: LangExt.Extension -> Condition +checkFlag flag dflags _ + | xopt flag dflags = IsValid + | otherwise = NotValid why + where + why = DerivErrLangExtRequired the_flag + the_flag = case [ flagSpecFlag f | f <- xFlags , flagSpecFlag f == flag ] of + [s] -> s + other -> pprPanic "checkFlag" (ppr other) + +std_class_via_coercible :: Class -> Bool +-- These standard classes can be derived for a newtype +-- using the coercible trick *even if no -XGeneralizedNewtypeDeriving +-- because giving so gives the same results as generating the boilerplate +std_class_via_coercible clas + = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] + -- Not Read/Show because they respect the type + -- Not Enum, because newtypes are never in Enum + + +non_coercible_class :: Class -> Bool +-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift +-- by Coercible, even with -XGeneralizedNewtypeDeriving +-- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived +-- instance behave differently if there's a non-lawful Applicative out there. +-- Besides, with roles, Coercible-deriving Traversable is ill-roled. +non_coercible_class cls + = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey + , genClassKey, gen1ClassKey, typeableClassKey + , traversableClassKey, liftClassKey ]) + +------------------------------------------------------------------ + +newDerivClsInst :: DerivSpec ThetaType -> TcM ClsInst +newDerivClsInst (DS { ds_name = dfun_name, ds_overlap = overlap_mode + , ds_tvs = tvs, ds_theta = theta + , ds_cls = clas, ds_tys = tys + , ds_warn = warn }) + = newClsInst overlap_mode dfun_name tvs theta clas tys warn + +extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a +-- Add new locally-defined instances; don't bother to check +-- for functional dependency errors -- that'll happen in GHC.Tc.TyCl.Instance +extendLocalInstEnv dfuns thing_inside + = do { env <- getGblEnv + ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns + env' = env { tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } + +{- +Note [Deriving any class] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Classic uses of a deriving clause, or a standalone-deriving declaration, are +for: + * a stock class like Eq or Show, for which GHC knows how to generate + the instance code + * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving + +The DeriveAnyClass extension adds a third way to derive instances, based on +empty instance declarations. + +The canonical use case is in combination with GHC.Generics and default method +signatures. These allow us to have instance declarations being empty, but still +useful, e.g. + + data T a = ...blah..blah... deriving( Generic ) + instance C a => C (T a) -- No 'where' clause + +where C is some "random" user-defined class. + +This boilerplate code can be replaced by the more compact + + data T a = ...blah..blah... deriving( Generic, C ) + +if DeriveAnyClass is enabled. + +This is not restricted to Generics; any class can be derived, simply giving +rise to an empty instance. + +See Note [Gathering and simplifying constraints for DeriveAnyClass] in +GHC.Tc.Deriv.Infer for an explanation hof how the instance context is inferred for +DeriveAnyClass. + +Note [Check that the type variable is truly universal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Functor and Traversable instances, we must check that the *last argument* +of the type constructor is used truly universally quantified. Example + + data T a b where + T1 :: a -> b -> T a b -- Fine! Vanilla H-98 + T2 :: b -> c -> T a b -- Fine! Existential c, but we can still map over 'b' + T3 :: b -> T Int b -- Fine! Constraint 'a', but 'b' is still polymorphic + T4 :: Ord b => b -> T a b -- No! 'b' is constrained + T5 :: b -> T b b -- No! 'b' is constrained + T6 :: T a (b,b) -- No! 'b' is constrained + +Notice that only the first of these constructors is vanilla H-98. We only +need to take care about the last argument (b in this case). See #8678. +Eg. for T1-T3 we can write + + fmap f (T1 a b) = T1 a (f b) + fmap f (T2 b c) = T2 (f b) c + fmap f (T3 x) = T3 (f x) + +We need not perform these checks for Foldable instances, however, since +functions in Foldable can only consume existentially quantified type variables, +rather than produce them (as is the case in Functor and Traversable functions.) +As a result, T can have a derived Foldable instance: + + foldr f z (T1 a b) = f b z + foldr f z (T2 b c) = f b z + foldr f z (T3 x) = f x z + foldr f z (T4 x) = f x z + foldr f z (T5 x) = f x z + foldr _ z T6 = z + +See Note [DeriveFoldable with ExistentialQuantification] in GHC.Tc.Deriv.Functor. + +For Functor and Traversable, we must take care not to let type synonyms +unfairly reject a type for not being truly universally quantified. An +example of this is: + + type C (a :: Constraint) b = a + data T a b = C (Show a) b => MkT b + +Here, the existential context (C (Show a) b) does technically mention the last +type variable b. But this is OK, because expanding the type synonym C would give +us the context (Show a), which doesn't mention b. Therefore, we must make sure +to expand type synonyms before performing this check. Not doing so led to #13813. +-} diff --git a/GHC/Tc/Errors.hs b/GHC/Tc/Errors.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors.hs @@ -0,0 +1,2632 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module GHC.Tc.Errors( + reportUnsolved, reportAllUnsolved, warnAllUnsolved, + warnDefaulting, + + -- * GHC API helper functions + solverReportMsg_ExpectedActuals, mismatchMsg_ExpectedActuals + ) where + +import GHC.Prelude + +import GHC.Driver.Env (hsc_units) +import GHC.Driver.DynFlags +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.Types.CtLoc +import GHC.Tc.Utils.TcMType +import GHC.Tc.Zonk.Type +import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.TcType +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Tc.Instance.Family +import GHC.Tc.Utils.Instantiate +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig ) + +import GHC.Types.Name +import GHC.Types.Name.Reader +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.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.TyCo.Tidy +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.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, union, sort, sortBy ) +import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) +import qualified Data.List.NonEmpty as NE +import Data.Ord ( comparing ) + +{- +************************************************************************ +* * +\section{Errors and contexts} +* * +************************************************************************ + +ToDo: for these error messages, should we note the location as coming +from the insts, or just whatever seems to be around in the monad just +now? + +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: + + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co + +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors +and does not fail if -fdefer-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. +-} + +-- | Report unsolved goals as errors or warnings. We may also turn some into +-- deferred run-time errors if `-fdefer-type-errors` is on. +reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) +reportUnsolved wanted + = do { binds_var <- newTcEvBinds + ; defer_errors <- goptM Opt_DeferTypeErrors + ; let type_errors | not defer_errors = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnDeferredTypeErrors + + ; defer_holes <- goptM Opt_DeferTypedHoles + ; let expr_holes | not defer_holes = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnTypedHoles + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; let type_holes | not partial_sigs + = ErrorWithoutFlag + | otherwise + = WarningWithFlag Opt_WarnPartialTypeSignatures + + ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables + ; let out_of_scope_holes | not defer_out_of_scope + = ErrorWithoutFlag + | otherwise + = WarningWithFlag Opt_WarnDeferredOutOfScopeVariables + + ; report_unsolved type_errors expr_holes + type_holes out_of_scope_holes + binds_var wanted + + ; ev_binds <- getTcEvBindsMap binds_var + ; return (evBindMapBinds ev_binds)} + +-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on +-- However, do not make any evidence bindings, because we don't +-- have any convenient place to put them. +-- NB: Type-level holes are OK, because there are no bindings. +-- See Note [Deferring coercion errors to runtime] +-- Used by solveEqualities for kind equalities +-- (see Note [Failure in local type signatures] in GHC.Tc.Solver) +reportAllUnsolved :: WantedConstraints -> TcM () +reportAllUnsolved wanted + = do { ev_binds <- newNoTcEvBinds + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; let type_holes | not partial_sigs = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnPartialTypeSignatures + + ; report_unsolved ErrorWithoutFlag + ErrorWithoutFlag type_holes ErrorWithoutFlag + ev_binds wanted } + +-- | Report all unsolved goals as warnings (but without deferring any errors to +-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in +-- "GHC.Tc.Solver" +warnAllUnsolved :: WantedConstraints -> TcM () +warnAllUnsolved wanted + = do { ev_binds <- newTcEvBinds + ; report_unsolved WarningWithoutFlag + WarningWithoutFlag + WarningWithoutFlag + WarningWithoutFlag + ev_binds wanted } + +-- | Report unsolved goals as errors or warnings. +report_unsolved :: DiagnosticReason -- Deferred type errors + -> DiagnosticReason -- Expression holes + -> DiagnosticReason -- Type holes + -> DiagnosticReason -- Out of scope holes + -> EvBindsVar -- cec_binds + -> WantedConstraints -> TcM () +report_unsolved type_errors expr_holes + type_holes out_of_scope_holes binds_var wanted + | isEmptyWC wanted + = return () + | otherwise + = do { traceTc "reportUnsolved {" $ + vcat [ text "type errors:" <+> ppr type_errors + , text "expr holes:" <+> ppr expr_holes + , text "type holes:" <+> ppr type_holes + , text "scope holes:" <+> ppr out_of_scope_holes ] + ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) + + ; wanted <- liftZonkM $ zonkWC wanted -- Zonk to reveal all information + + ; let tidy_env = tidyAvoiding bound_occs tidyFreeTyCoVars free_tvs + -- See Note [tidyAvoiding] in GHC.Core.TyCo.Tidy + 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. + + bound_occs :: [OccName] + bound_occs = boundOccNamesOfWC wanted + + ; traceTc "reportUnsolved (after zonking):" $ + vcat [ text "Free tyvars:" <+> pprTyVars free_tvs + , text "Bound occs:" <+> ppr bound_occs + , text "Tidy env:" <+> ppr tidy_env + , text "Wanted:" <+> ppr wanted ] + + ; warn_redundant <- woptM Opt_WarnRedundantConstraints + ; exp_syns <- goptM Opt_PrintExpandedSynonyms + ; let err_ctxt = CEC { cec_encl = [] + , cec_tidy = tidy_env + , cec_defer_type_errors = type_errors + , cec_expr_holes = expr_holes + , cec_type_holes = type_holes + , cec_out_of_scope_holes = out_of_scope_holes + , cec_suppress = insolubleWC wanted + -- See Note [Suppressing error messages] + -- Suppress low-priority errors if there + -- are insoluble errors anywhere; + -- See #15539 and c.f. setting ic_status + -- in GHC.Tc.Solver.setImplicationStatus + , cec_warn_redundant = warn_redundant + , cec_expand_syns = exp_syns + , cec_binds = binds_var } + + ; tc_lvl <- getTcLevel + ; reportWanteds err_ctxt tc_lvl wanted + ; traceTc "reportUnsolved }" empty } + +-------------------------------------------- +-- Internal functions +-------------------------------------------- + +-- | Make a report from a single 'TcSolverReportMsg'. +important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport +important ctxt doc + = SolverReport { sr_important_msg = SolverReportWithCtxt ctxt doc + , sr_supplementary = [] + , sr_hints = noHints + } + +add_relevant_bindings :: RelevantBindings -> SolverReport -> SolverReport +add_relevant_bindings binds report@(SolverReport { sr_supplementary = supp }) + = report { sr_supplementary = SupplementaryBindings binds : supp } + +-- | 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 = ct_loc_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 ct_loc_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 + + -- Report redundant (unused) constraints + ; warnRedundantConstraints ctxt' ct_loc_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 -> CtLocEnv -> SkolemInfoAnon -> [EvVar] -> TcM () +-- See Note [Tracking redundant constraints] in GHC.Tc.Solver +warnRedundantConstraints ctxt env info redundant_evs + | not (cec_warn_redundant ctxt) + = return () + + | 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". + = report_redundant_msg True (setCtLocEnvLoc env (redundantConstraintsSpan user_ctxt)) + -- ^^^^ 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 + = report_redundant_msg False env + -- ^^^^^ don't add "In the type signature..." + where + report_redundant_msg :: Bool -- whether to add "In the type signature..." to the diagnostic + -> CtLocEnv + -> TcRn () + report_redundant_msg show_info lcl_env + = do { msg <- + mkErrorReport lcl_env + (TcRnRedundantConstraints redundant_evs (info, show_info)) + (Just ctxt) [] [] + ; reportDiagnostic msg } + +reportBadTelescope :: SolverReportErrCtxt -> CtLocEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () +reportBadTelescope ctxt env (ForAllSkol telescope) skols + = do { msg <- mkErrorReport env + (TcRnSolverReport report ErrorWithoutFlag) + (Just ctxt) [] [] + ; reportDiagnostic msg } + where + report = SolverReportWithCtxt ctxt $ BadTelescope telescope skols + +reportBadTelescope _ _ skol_info skols + = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) + +-- | 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 + = case ctOrigin ct of + AssocFamPatOrigin -> True -- See (CIG1) + _ -> 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 + -- For this `suppress` stuff + -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint + CtGiven {} -> (False, Nothing) + CtWanted (WantedCt { ctev_rewriters = rws, ctev_dest = dest }) + -> (not (isEmptyRewriterSet rws), Just dest) + + ; let m_reason = case ct of + CIrredCan (IrredCt { ir_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 }} + +-- | Actually report this 'ErrorItem'. +unsuppressErrorItem :: ErrorItem -> ErrorItem +unsuppressErrorItem ei = ei { ei_suppress = False } + +---------------------------------------------------------------- +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_items1 <- 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_items1 =" <+> ppr tidy_items1 + , text "tidy_errs =" <+> ppr tidy_errs ]) + + -- Catch an awkward (and probably rare) case in which /all/ errors are + -- suppressed: see Wrinkle (PER2) in Note [Prioritise Wanteds with empty + -- RewriterSet] in GHC.Tc.Types.Constraint. + -- + -- Unless we are sure that an error will be reported some other way + -- (details in the defn of tidy_items) un-suppress the lot. This makes + -- sure we don't forget to report an error at all, which is + -- catastrophic: GHC proceeds to desguar and optimise the program, even + -- though it is full of type errors (#22702, #22793) + ; errs_already <- ifErrsM (return True) (return False) + ; let tidy_items + | not errs_already -- Have not already reported an error (perhaps + -- from an outer implication); see #21405 + , not (any ignoreConstraint simples) -- No error is ignorable (is reported elsewhere) + , all ei_suppress tidy_items1 -- All errors are suppressed + = map unsuppressErrorItem tidy_items1 + | otherwise + = tidy_items1 + + -- First, deal with any out-of-scope errors: + ; let (out_of_scope, other_holes, not_conc_errs, mult_co_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 + + -- We only want to report multiplicity coercion errors for multiplicity + -- constraints which are /solved/ with a non-reflexivity coercion. We + -- over approximate here: we only report multiplicity coercion errors + -- when /all/ constraints are solved. + -- See wrinkle (DME1) in Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify. + ; when (null simples) $ reportMultiplicityCoercionErrs ctxt_for_insols mult_co_errs + + -- See Note [Suppressing confusing errors] + ; let (suppressed_items, reportable_items) = partition suppressItem tidy_items + ; traceTc "reportWanteds suppressed:" (ppr suppressed_items) + ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 reportable_items + + -- 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 } + ; (_, 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) + + -- If there are no other errors to report, report suppressed errors. + -- See Note [Suppressing confusing errors]. NB: with -fdefer-type-errors + -- we might have reported warnings only from `reportable_items`, but we + -- still want to suppress the `suppressed_items`. + ; when (null reportable_items) $ + do { (_, more_leftovers) <- tryReporters ctxt_for_insols (report1++report2) + suppressed_items + -- ctxt_for_insols: the suppressed errors can be Int~Bool, which + -- will have made the incoming `ctxt` be True; don't make that + -- suppress the Int~Bool error! + ; 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], [(TcCoercion, CtLoc)]) + partition_errors [] + = ([], [], [], []) + partition_errors (err:errs) + | (es1, es2, es3, es4) <- partition_errors errs + = case err of + DE_Hole hole + | isOutOfScopeHole hole + -> (hole : es1, es2, es3, es4) + | otherwise + -> (es1, hole : es2, es3, es4) + DE_NotConcrete err + -> (es1, es2, err : es3, es4) + DE_Multiplicity mult_co loc + -> (es1, es2, es3, (mult_co, loc):es4) + + -- 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 = [ -- We put implicit lifting errors first, because are solid errors + -- See "Implicit lifting" in GHC.Tc.Gen.Splice + -- Note [Lifecycle of an untyped splice, and PendingRnSplice] + ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter) + + -- Next, solid equality errors + , 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) + + -- Next, custom type errors + -- See Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint + -- + -- Put custom type errors /after/ solid equality errors. In #26255 we + -- had a custom error (T <= F alpha) which was suppressing a far more + -- informative (K Int ~ [K alpha]). That mismatch between K and [] is + -- definitely wrong; and if it was fixed we'd know alpha:=Int, and hence + -- perhaps be able to solve T <= F alpha, by reducing F Int. + -- + -- But put custom type errors /before/ "non-tv eq", because if we have + -- () ~ TypeError blah + -- we want to report it as a custom error, /not/ as a mis-match + -- between TypeError and ()! Also see the Assert example + -- in Note [Custom type errors in constraints] + , ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) + -- (Handles TypeError and Unsatisfiable) + + -- "non-tv-eq": equalities (ty1 ~ ty2) where ty1 is not a tyvar + , ("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 heterogeneous kinds] in GHC.Tc.Solver.Equality + , ("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) + , ("Quantified", is_qc, False, mkGroupReporter mkQCErr) ] + + -- 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 + + -- Catch TypeError and Unsatisfiable. + -- Here, we want any nested TypeErrors to bubble up, so we use + -- 'containsUserTypeError' and not 'isTopLevelUserTypeError'. + -- + -- See also Note [Implementation of Unsatisfiable constraints], point (F). + is_user_type_error item _ = containsUserTypeError (errorItemPred item) + + is_implicit_lifting item _ = + case (errorItemOrigin item) of + ImplicitLiftOrigin {} -> True + _ -> False + + is_homo_equality _ (EqPred _ ty1 ty2) + = typeKind ty1 `tcEqType` typeKind ty2 + is_homo_equality _ _ + = False + + is_equality _(EqPred {}) = True + is_equality _ _ = False + + is_dict _ (ClassPred {}) = True + is_dict _ _ = False + + is_ip _ (ClassPred cls _) = isIPClass cls + is_ip _ _ = False + + is_irred _ (IrredPred {}) = True + is_irred _ _ = False + + is_qc _ (ForAllPred {}) = True + is_qc _ _ = False + + 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 + +--------------- +suppressItem :: ErrorItem -> Bool + -- See Note [Suppressing confusing errors] +suppressItem item + | Wanted <- ei_flavour item + , let orig = errorItemOrigin item + = isWantedSuperclassOrigin orig -- See (SCE1) + || isWantedWantedFunDepOrigin orig -- See (SCE2) + | otherwise + = False + +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 are suppressed? + +(SCE1) Superclasses of Wanteds. These are generated only in case they trigger functional + dependencies. If such a constraint is unsolved, then its "parent" constraint must + also be unsolved, and is much more informative to the user. Example (#26255): + class (MinVersion <= F era) => Era era where { ... } + f :: forall era. EraFamily era -> IO () + f = ..blah... -- [W] Era era + Here we have simply omitted "Era era =>" from f's type. But we'll end up with + /two/ Wanted constraints: + [W] d1 : Era era + [W] d2 : MinVersion <= F era -- Superclass of d1 + We definitely want to report d1 and not d2! Happily it's easy to filter out those + superclass-Wanteds, becuase their Origin betrays them. + + See test T18851 for an example of how it is (just, barely) possible for the /only/ + errors to be superclass-of-Wanted constraints. + +(SCE2) 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: + +(CIG1) 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. + +(Note: Aug 25: this seems a rather tricky corner; + c.f. Note [Suppressing confusing errors]) + +Note [Implementation of Unsatisfiable constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Unsatisfiable constraint was introduced in GHC proposal #433 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst). +See Note [The Unsatisfiable constraint] in GHC.TypeError. + +Its implementation consists of the following: + + A. The definitions. + + The Unsatisfiable class is defined in GHC.TypeError, in base. + It consists of the following definitions: + + type Unsatisfiable :: ErrorMessage -> Constraint + class Unsatisfiable msg where + unsatisfiableLifted :: a + + unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a + unsatisfiable = unsatisfiableLifted @msg @((##) -> a) (##) + + The class TyCon as well as the unsatisfiable Id have known-key Names + in GHC; they are not wired-in. + + B. Unsatisfiable instances. + + The Unsatisfiable typeclass has no instances (see GHC.Tc.Instance.Class.matchGlobalInst). + + Users are prevented from writing instances in GHC.Tc.Validity.check_special_inst_head. + This is done using the same mechanism as for, say, Coercible or WithDict. + + C. Using [G] Unsatisfiable msg to solve any Wanted. + + In GHC.Tc.Solver.simplifyTopWanteds, after defaulting happens, when an + implication contains Givens of the form [G] Unsatisfiable msg, and the + implication supports term-level evidence (as per Note [Coercion evidence only] + in GHC.Tc.Types.Evidence), we use any such Given to solve all the Wanteds + in that implication. See GHC.Tc.Solver.useUnsatisfiableGivens. + + The way we construct the evidence terms is slightly complicated by + Type vs Constraint considerations; see Note [Evidence terms from Unsatisfiable Givens] + in GHC.Tc.Solver. + + The proposal explains why this happens after defaulting: if there are other + ways to solve the Wanteds, we would prefer to use that, as that will make + user programs "as defined as possible". + + Wrinkle [Ambiguity] + + We also use an Unsatisfiable Given to solve Wanteds when performing an + ambiguity check. See the call to "useUnsatisfiableGivens" in + GHC.Tc.Solver.simplifyAmbiguityCheck. + + This is, for example, required to typecheck the definition + of "unsatisfiable" itself: + + unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a + + The ambiguity check on this type signature will produce + + [G] Unsatisfiable msg1, [W] Unsatisfiable msg2 + + and we want to ensure the Given solves the Wanted, to accept the definition. + + NB: + + An alternative would be to add a functional dependency on Unsatisfiable: + + class Unsatisfiable msg | -> msg + + Then we would unify msg1 and msg2 in the above constraint solving problem, + and would be able to solve the Wanted using the Given in the normal way. + However, adding such a functional dependency solely for this purpose + could have undesirable consequences. For example, one might have + + [W] Unsatisfiable (Text "msg1"), [W] Unsatisfiable (Text "msg2") + + and W-W fundep interaction would produce the insoluble constraint + + [W] "msg1" ~ "msg2" + + which we definitely wouldn't want to report to the user. + + D. Adding "meth = unsatisfiable @msg" method bindings. + + When a class instance has an "Unsatisfiable msg" constraint in its context, + and the user has omitted methods, we add method bindings of the form + "meth = unsatisfiable @msg". + See GHC.Tc.TyCl.Instance.tcMethods, in particular "tc_default". + + Example: + + class C a where { op :: a -> a } + instance Unsatisfiable Msg => C [a] where {} + + elaborates to + + instance Unsatisfiable Msg => C [a] where { op = unsatisfiable @Msg } + + due to the (Unsatisfiable Msg) constraint in the instance context. + + We also switch off the "missing methods" warning in this situation. + See "checkMinimalDefinition" in GHC.Tc.TyCl.Instance.tcMethods. + + Note that we do this even when there is a default method available. This + ensures we run into the unsatisfiable error message when deferring type + errors; otherwise we could end up with a runtime loop as seen in #23816. + + E. Switching off functional dependency coverage checks when there is + an "Unsatisfiable msg" context. + + This is because we want to allow users to rule out certain instances with + an "unsatisfiable" error, even when that would violate a functional + dependency. For example: + + class C a b | a -> b + instance Unsatisfiable (Text "No") => C a b + + See GHC.Tc.Instance.FunDeps.checkInstCoverage. + + F. Error reporting of "Unsatisfiable msg" constraints. + + This is done in GHC.Tc.Errors.reportWanteds: we detect when a constraint + is of the form "Unsatisfiable msg" and just emit the custom message + as an error to the user. + + This is the only way that "Unsatisfiable msg" constraints are reported, + which makes their behaviour much more predictable than TypeError. +-} + + +-------------------------------------------- +-- Reporters +-------------------------------------------- + +type Reporter + = SolverReportErrCtxt -> NonEmpty 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) ctxt) (group (toList 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) <- liftZonkM $ + 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 'CtLocEnv'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 'CtLocEnv'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 -> [CtLocEnv] -> ZonkM (TidyEnv, NameEnv Type) +zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap ctl_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 <- liftIO $ 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 + + -- 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 } -> + FRR_Info + { frr_info_origin = frr_orig + , frr_info_not_concrete = Nothing + , frr_info_other_origin = Nothing } + : frr_errs + +reportMultiplicityCoercionErrs :: SolverReportErrCtxt -> [(TcCoercion, CtLoc)] -> TcM () +reportMultiplicityCoercionErrs ctxt errs = mapM_ reportOne errs + where + reportOne :: (TcCoercion, CtLoc) -> TcM () + reportOne (_co, loc) + = do { msg <- mkErrorReport (ctLocEnv loc) diag (Just ctxt) [] [] + ; reportDiagnostic msg } + + diag = TcRnSolverReport + (SolverReportWithCtxt ctxt MultiplicityCoercionsNotSupported) + ErrorWithoutFlag + +{- 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 + ; addSolverDeferredBinding err item } + +mkUserTypeError :: ErrorItem -> TcSolverReportMsg +mkUserTypeError item + | Just msg <- getUserTypeErrorMsg pty + = UserTypeError msg + | Just msg <- isUnsatisfiableCt_maybe pty + = UnsatisfiableError msg + | otherwise + = pprPanic "mkUserTypeError" (ppr item) + where + pty = errorItemPred item + +mkImplicitLiftingReporter :: Reporter +mkImplicitLiftingReporter ctxt + = mapM_ $ \item -> do { let err = mkImplicitLiftingError item + ; msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item)) err (Just ctxt) [] [] + ; reportDiagnostic msg + ; addDeferredBinding ctxt [] [] err item + } + + where + mkImplicitLiftingError :: ErrorItem -> TcRnMessage + mkImplicitLiftingError item = + case errorItemOrigin item of + ImplicitLiftOrigin (HsImplicitLiftSplice bound used gre name) -> + TcRnBadlyLevelled (LevelCheckSplice (getName name) gre) bound used (Just item) (cec_defer_type_errors ctxt) + _ -> pprPanic "mkImplicitLiftingError" (ppr item) + +mkGivenErrorReporter :: Reporter +-- See Note [Given errors] +mkGivenErrorReporter ctxt (item:|_) + = do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item + ; let implic = + case cec_encl ctxt of + -- cec_encl is always non-empty when mkGivenErrorReporter is called + outer_implic:_ -> outer_implic + _ -> pprPanic "mkGivenErrorReporter" (ppr item) + + loc' = setCtLocEnv (ei_loc item) (ic_env implic) + item' = item { ei_loc = loc' } + -- For given constraints we overwrite the env (and hence src-loc) + -- with one from the immediately-enclosing implication. + -- See Note [Inaccessible code] + + ; eq_err_msg <- mkEqErr_help ctxt item' ty1 ty2 + ; let msg = TcRnInaccessibleCode implic (SolverReportWithCtxt ctxt eq_err_msg) + ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) [SupplementaryBindings relevant_binds] [] + ; reportDiagnostic msg } + where + (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 -> NonEmpty 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) ctxt) (equivClasses cmp_loc (toList 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 :: (NonEmpty ErrorItem -> TcM SolverReport) -> Reporter +reportGroup mk_err ctxt items + = do { err <- mk_err 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_ (addSolverDeferredBinding 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 (OmittedFieldOrigin {}) = True +nonDeferrableOrigin (UsageEnvironmentOf {}) = True +nonDeferrableOrigin (FRROrigin {}) = True +nonDeferrableOrigin _ = False + +maybeReportError :: SolverReportErrCtxt + -> NonEmpty ErrorItem -- items covered by the Report + -> SolverReport -> TcM () +maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = important + , sr_supplementary = supp + , sr_hints = hints }) + = unless (cec_suppress ctxt -- Some worse error has occurred, so suppress this diagnostic + || all ei_suppress items) $ + -- if they're all to be suppressed, report nothing + -- if at least one is not suppressed, do report: + -- the function that generates the error message + -- should look for an unsuppressed error item + do let reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag + | otherwise = cec_defer_type_errors ctxt + -- See Note [No deferring for multiplicity errors] + diag = TcRnSolverReport important reason + msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp hints + reportDiagnostic msg + +addSolverDeferredBinding :: SolverReport -> ErrorItem -> TcM () +addSolverDeferredBinding err item = + let ctxt = reportContext . sr_important_msg $ err + supp = sr_supplementary err + hints = sr_hints err + important = sr_important_msg err + in addDeferredBinding ctxt supp hints (TcRnSolverReport important ErrorWithoutFlag) item + + +addDeferredBinding :: SolverReportErrCtxt -> [SupplementaryInfo] -> [GhcHint] -> TcRnMessage -> ErrorItem -> TcM () +-- See Note [Deferring coercion errors to runtime] +addDeferredBinding ctxt supp hints msg (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 loc item_ty ctxt msg supp hints + ; let ev_binds_var = cec_binds ctxt + + ; case dest of + EvVarDest evar + -> addTcEvBind ev_binds_var $ mkWantedEvBind evar EvNonCanonical err_tm + HoleDest hole + -> do { -- See Note [Deferred errors for coercion holes] + let co_var = coHoleCoVar hole + ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvNonCanonical err_tm + ; fillCoercionHole hole (mkCoVarCo co_var) } } +addDeferredBinding _ _ _ _ _ = return () -- Do not set any evidence for Given + +mkSolverErrorTerm :: CtLoc -> Type -- of the error term + -> SolverReport -> TcM EvTerm +mkSolverErrorTerm ct_loc ty err + = mkErrorTerm ct_loc ty (reportContext . sr_important_msg $ err) + (TcRnSolverReport (sr_important_msg err) ErrorWithoutFlag) + (sr_supplementary err) + (sr_hints err) + +mkErrorTerm :: CtLoc -> Type -- of the error term + -> SolverReportErrCtxt -> TcRnMessage + -> [SupplementaryInfo] -> [GhcHint] -> TcM EvTerm +mkErrorTerm ct_loc ty ctxt msg supp hints + = do { msg <- mkErrorReport + (ctLocEnv ct_loc) + msg + (Just $ ctxt) + supp + hints + -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" + ; dflags <- getDynFlags + ; let err_msg = pprLocMsgEnvelope (initTcMessageOpts dflags) msg + err_str = showSDoc dflags $ + err_msg $$ text "(deferred type error)" + + ; return $ evDelayedError ty err_str } + +tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) +-- Use the first reporter in the list whose predicate says True +tryReporters ctxt reporters items + = do { let (vis_items, invis_items) + = partition (isVisibleOrigin . errorItemOrigin) items + ; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items) + ; (ctxt', items') <- go ctxt reporters vis_items invis_items + ; traceTc "tryReporters }" (ppr items') + ; return (ctxt', items') } + where + go ctxt [] vis_items invis_items + = return (ctxt, vis_items ++ invis_items) + + go ctxt (r : rs) vis_items invis_items + -- always look at *visible* Origins before invisible ones + -- this is the whole point of isVisibleOrigin + = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items + ; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items + ; go ctxt'' rs vis_items' invis_items' } + -- Carry on with the rest, because we must make + -- deferred bindings for them if we have -fdefer-type-errors + -- But suppress their error messages + +tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) +tryReporter ctxt (str, keep_me, suppress_after, reporter) items = case nonEmpty yeses of + Nothing -> pure (ctxt, items) + Just yeses -> 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 :: CtLocEnv + -> 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. + -> [SupplementaryInfo] + -- ^ Supplementary information, to be added at the end of the message. + -> [GhcHint] + -- ^ Suggested fixes + -> TcM (MsgEnvelope TcRnMessage) +mkErrorReport tcl_env msg mb_ctxt supp hints + = do { mb_context <- traverse (\ ctxt -> mkErrCtxt (cec_tidy ctxt) (ctl_ctxt tcl_env)) mb_ctxt + ; unit_state <- hsc_units <$> getTopEnv + ; hfdc <- getHoleFitDispConfig + ; let + err_info = ErrInfo (fromMaybe [] mb_context) (Just (hfdc, supp)) hints + detailed_msg = mkDetailedMessage err_info msg + ; mkTcRnMessage + (RealSrcSpan (ctl_loc tcl_env) Strict.Nothing) + (TcRnMessageWithInfo unit_state $ detailed_msg) } + +{- 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 [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify, +linear types do not support casts and any nontrivial coercion will raise +an error at the end of typechecking (a delayed error). + +This means that even if we defer a multiplicity mismatch during typechecking, +the desugarer will refuse to compile anyway. Worse: the delayed error 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 origins which are not +used outside of linear types. + +In the future, we should compile unsolved multiplicity constraints to a runtime error with +-fdefer-type-errors, but there's currently no good way to insert this type error +in the desugared program. Especially in a way that would pass the linter. +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 -> NonEmpty ErrorItem -> TcM SolverReport +mkIrredErr ctxt items + = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 + ; let msg = important ctxt $ mkPlainMismatchMsg $ + CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing + ; return $ add_relevant_bindings binds msg } + where + item1:|others = tryFilter (not . ei_suppress) 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_sort = sort, hole_occ = occ, hole_loc = ct_loc }) + | isOutOfScopeHole hole + = do { (imp_errs, hints) + <- unknownNameSuggestions (ctl_rdr lcl_env) what_look occ + ; let + err = SolverReportWithCtxt ctxt + $ ReportHoleError hole OutOfScopeHole + supp = [ SupplementaryImportErrors imps | imps <- maybeToList (NE.nonEmpty imp_errs) ] + + ; maybeAddDeferredBindings hole $ SolverReport err supp hints + ; mkErrorReport lcl_env + ( TcRnSolverReport err (cec_out_of_scope_holes ctxt) + ) + Nothing supp hints + -- Pass the value 'Nothing' for the context, as it's generally not helpful + -- to include the context here. + } + where + what_look = case sort of + ExprHole {} -> WL_Term + TypeHole {} -> WL_Type + ConstraintHole {} -> WL_Type + lcl_env = ctLocEnv ct_loc + + -- general case: not an out-of-scope error +mkHoleError lcl_name_cache tidy_simples ctxt + hole@(Hole { hole_ty = hole_ty + , hole_sort = sort + , hole_loc = ct_loc }) + = do { rel_binds + <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty) + -- The 'False' means "don't filter the bindings"; see #8191 + + ; show_hole_constraints <- goptM Opt_ShowHoleConstraints + ; let relevant_cts + | ExprHole _ <- sort, show_hole_constraints + = givenConstraints ctxt + | otherwise + = [] + + ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits + ; (ctxt, hole_fits) <- if show_valid_hole_fits + then validHoleFits ctxt tidy_simples hole + else return (ctxt, noValidHoleFits) + ; (grouped_skvs, other_tvs) <- liftZonkM $ zonkAndGroupSkolTvs hole_ty + ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt + | otherwise = cec_type_holes ctxt + err = SolverReportWithCtxt ctxt + $ ReportHoleError hole + $ HoleError sort other_tvs grouped_skvs + supp = [ SupplementaryBindings rel_binds ] + ++ [ SupplementaryCts cts | cts <- maybeToList (NE.nonEmpty relevant_cts) ] + ++ [ SupplementaryHoleFits hole_fits ] + + ; maybeAddDeferredBindings hole (SolverReport err supp noHints) + ; let msg = TcRnSolverReport err reason + ; mkErrorReport lcl_env msg (Just ctxt) supp noHints + } + + 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 -> ZonkM ([(SkolemInfoAnon, [TcTyVar])], [TcTyVar]) +zonkAndGroupSkolTvs hole_ty = do + zonked_info <- mapM zonk_skolem_info skolem_list + return (zonked_info, other_tvs) + where + zonk_skolem_info (sk, tv) = + do { sk <- zonkSkolemInfoAnon $ getSkolemInfo sk + ; return (sk, fst <$> tv) } + tvs = tyCoVarsOfTypeList hole_ty + (skol_tvs, other_tvs) = partition (isTcTyVar <&&> isSkolemTyVar) 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.nonDetUniqMapToList 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 :: Hole + -> SolverReport + -> TcM () +maybeAddDeferredBindings 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 <- mkSolverErrorTerm (hole_loc hole) ref_ty report + -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. + -- See Note [Holes in expressions] in GHC.Hs.Expr + writeMutVar ref err_tm + _ -> pure () + where + ctxt = reportContext $ sr_important_msg $ report + +-- 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 (mapMaybe mk_wanted simps) hole + ; return (ctxt {cec_tidy = tidy_env}, fits) } + where + mk_wanted :: ErrorItem -> Maybe CtEvidence + mk_wanted (EI { ei_pred = pred, ei_evdest = m_dest, ei_loc = loc }) + | Just dest <- m_dest + = Just $ CtWanted $ + WantedCt { ctev_pred = pred + , ctev_dest = dest + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + | otherwise + = Nothing -- The ErrorItem was a Given + + +-- See Note [Constraints include ...] +givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)] +givenConstraints ctxt + = do { implic@Implic{ ic_given = given } <- cec_encl ctxt + ; constraint <- given + ; return (varType constraint, getCtLocEnvLoc (ic_env implic)) } + +---------------- + +mkIPErr :: SolverReportErrCtxt -> NonEmpty 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 (item1:|others) + = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 + ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others) + ; return $ add_relevant_bindings binds msg } + +---------------- + +-- | Report a representation-polymorphism error to the user: +-- a type is required to have a fixed runtime representation, +-- but doesn't. +-- +-- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin. +mkFRRErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport +mkFRRErr ctxt items + = do { -- Process the error items. + ; (_tidy_env, frr_infos) <- + liftZonkM $ 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 . fixedRuntimeRepOrigin_maybe) $ + toList 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 <- orig + = Just $ FRR_Info { frr_info_origin = frr_orig + , frr_info_not_concrete = Nothing + , frr_info_other_origin = Nothing + } + -- A nominal equality involving a concrete type variable, + -- such as @alpha[conc] ~# rr[sk]@ or @beta[conc] ~# RR@ for a + -- type family application @RR@. + | EqPred NomEq ty1 ty2 <- classifyPredType (errorItemPred item) + = if | Just (tv1, ConcreteFRR frr1) <- isConcreteTyVarTy_maybe ty1 + -> Just $ FRR_Info frr1 (Just (tv1, ty2)) (Just orig) + | Just (tv2, ConcreteFRR frr2) <- isConcreteTyVarTy_maybe ty2 + -> Just $ FRR_Info frr2 (Just (tv2, ty1)) (Just orig) + | otherwise + -> Nothing + | otherwise + = Nothing + where + orig = errorItemOrigin item + +{- +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 -> NonEmpty ErrorItem -> TcM SolverReport +mkEqErr ctxt items + | item1 :| _ <- tryFilter (not . ei_suppress) items + = mkEqErr1 ctxt item1 + +mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport +mkEqErr1 ctxt item -- Wanted only + -- givens handled in mkGivenErrorReporter + = do { (ctxt, binds, item) <- relevantBindings True ctxt item + ; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item)) + ; err_msg <- mkEqErr_help ctxt item ty1 ty2 + ; let + report = add_relevant_bindings binds + $ important ctxt err_msg + ; return report } + where + (ty1, ty2) = getEqPredTys (errorItemPred item) + +-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint +-- is left over. +mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs + -> TcType -> TcType -> Maybe CoercibleMsg +mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = Just msg + | Just (tc, tys) <- splitTyConApp_maybe ty2 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = Just msg + | Just (s1, _) <- tcSplitAppTy_maybe ty1 + , Just (s2, _) <- tcSplitAppTy_maybe ty2 + , s1 `eqType` s2 + , has_unknown_roles s1 + = Just $ UnknownRoles s1 + | otherwise + = Nothing + where + coercible_msg_for_tycon tc + | isAbstractTyCon tc + = Just $ TyConIsAbstract tc + | isNewTyCon tc + , [data_con] <- tyConDataCons tc + , let dc_name = dataConName data_con + , isNothing (lookupGRE_Name rdr_env dc_name) + = Just $ OutOfScopeNewtypeConstructor tc data_con + | otherwise = Nothing + + has_unknown_roles ty + | Just (tc, tys) <- tcSplitTyConApp_maybe ty + = tys `lengthAtLeast` tyConArity tc -- oversaturated tycon + | Just (s, _) <- tcSplitAppTy_maybe ty + = has_unknown_roles s + | isTyVarTy ty + = True + | otherwise + = False + +mkEqErr_help :: SolverReportErrCtxt + -> ErrorItem + -> TcType -> TcType -> TcM TcSolverReportMsg +mkEqErr_help ctxt item ty1 ty2 + | Just (tv1, _co) <- getCastedTyVar_maybe ty1 + = mkTyVarEqErr ctxt item tv1 ty2 + + -- ToDo: explain.. Cf T2627b Dual (Dual a) ~ a + | Just (tv2, _co) <- getCastedTyVar_maybe ty2 + = mkTyVarEqErr ctxt item tv2 ty1 + + | otherwise + = reportEqErr ctxt item ty1 ty2 + +reportEqErr :: SolverReportErrCtxt + -> ErrorItem + -> TcType -> TcType + -> TcM TcSolverReportMsg +reportEqErr ctxt item ty1 ty2 + = do + mb_coercible_info <- if errorItemEqRel item == ReprEq + then coercible_msg ty1 ty2 + else return Nothing + tv_info <- case getTyVar_maybe ty2 of + Nothing -> return Nothing + Just tv2 -> Just <$> extraTyVarEqInfo (tv2, Nothing) ty1 + return $ Mismatch { mismatchMsg = mismatch + , mismatchTyVarInfo = tv_info + , mismatchAmbiguityInfo = eqInfos + , mismatchCoercibleInfo = mb_coercible_info } + where + mismatch = misMatchOrCND ctxt item ty1 ty2 + eqInfos = eqInfoMsgs ty1 ty2 + +coercible_msg :: TcType -> TcType -> TcM (Maybe CoercibleMsg) +coercible_msg ty1 ty2 + = do + rdr_env <- getGlobalRdrEnv + fam_envs <- tcGetFamInstEnvs + return $ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + +mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem + -> TcTyVar -> TcType -> TcM TcSolverReportMsg +-- tv1 and ty2 are already tidied +mkTyVarEqErr ctxt item tv1 ty2 + = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr tv1 $$ ppr ty2) + ; mkTyVarEqErr' ctxt item tv1 ty2 } + +mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem + -> TcTyVar -> TcType -> TcM TcSolverReportMsg +mkTyVarEqErr' ctxt item tv1 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) <- liftZonkM $ zonkTidyFRRInfos (cec_tidy ctxt) [frr_info] + return $ FixedRuntimeRepError infos + + -- Impredicativity is a simple error to understand; + -- try it before anything more complicated. + | check_eq_result `cterHasProblem` cteImpredicative + = do + tyvar_eq_info <- extraTyVarEqInfo (tv1, Nothing) ty2 + let + poly_msg = CannotUnifyWithPolytype item tv1 ty2 mb_tv_info + mb_tv_info + | isSkolemTyVar tv1 + = Just tyvar_eq_info + | otherwise + = Nothing + main_msg = + CannotUnifyVariable + { mismatchMsg = headline_msg + , cannotUnifyReason = poly_msg } + -- Unlike the other reports, this discards the old 'report_important' + -- instead of augmenting it. This is because the details are not likely + -- to be helpful since this is just an unimplemented feature. + return main_msg + + | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have + -- swapped in Solver.Equality.canEqTyVarHomo + || isTyVarTyVar tv1 && not (isTyVarTy ty2) + || errorItemEqRel item == ReprEq + -- The cases below don't really apply to ReprEq (except occurs check) + = do + tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2 + reason <- if errorItemEqRel item == ReprEq + then RepresentationalEq tv_extra <$> coercible_msg ty1 ty2 + else return $ DifferentTyVars tv_extra + let main_msg = CannotUnifyVariable + { mismatchMsg = headline_msg + , cannotUnifyReason = reason } + return main_msg + + | tv1 `elemVarSet` tyCoVarsOfType ty2 + -- 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 + -- + -- Use tyCoVarsOfType because it might have begun as the canonical + -- constraint (Dual (Dual a)) ~ a, and been swizzled by mkEqnErr_help + = let ambiguity_infos = eqInfoMsgs ty1 ty2 + + interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ + filter isTyVar $ + fvVarList $ + tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 + + occurs_err = + OccursCheck + { occursCheckInterestingTyVars = interesting_tyvars + , occursCheckAmbiguityInfos = ambiguity_infos } + main_msg = + CannotUnifyVariable + { mismatchMsg = headline_msg + , cannotUnifyReason = occurs_err } + + in return main_msg + + -- If the immediately-enclosing implication has 'tv' a skolem, and + -- we know by now its an InferSkol kind of skolem, then presumably + -- it started life as a TyVarTv, else it'd have been unified, given + -- that there's no occurs-check or forall problem + | (implic:_) <- cec_encl ctxt + , Implic { ic_skols = skols } <- implic + , tv1 `elem` skols + = do + tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2 + let msg = Mismatch + { mismatchMsg = mismatch_msg + , mismatchTyVarInfo = Just tv_extra + , mismatchAmbiguityInfo = [] + , mismatchCoercibleInfo = Nothing } + return msg + + -- Check for skolem escape + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_skols = skols } <- implic + , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols + , not (null esc_skols) + = let main_msg = + CannotUnifyVariable + { mismatchMsg = mismatch_msg + , cannotUnifyReason = SkolemEscape item implic esc_skols } + + in return main_msg + + -- Nastiest case: attempt to unify an untouchable variable + -- So tv is a meta tyvar (or started that way before we + -- generalised it). So presumably it is an *untouchable* + -- meta tyvar or a TyVarTv, else it'd have been unified + -- See Note [Error messages for untouchables] + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_tclvl = lvl } <- implic + = assertPpr (not (isTouchableMetaTyVar lvl tv1) || hasCoercionHole ty2) + (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables] + -- We can still get touchable meta-tyvars on the LHS if there is an + -- unsolved coercion hole, e.g. (alpha::Type) ~ Int# |> co_hole + tv_extra <- extraTyVarEqInfo (tv1, Just implic) ty2 + let tv_extra' = tv_extra { thisTyVarIsUntouchable = Just implic } + msg = Mismatch + { mismatchMsg = mismatch_msg + , mismatchTyVarInfo = Just tv_extra' + , mismatchAmbiguityInfo = [] + , mismatchCoercibleInfo = Nothing } + return msg + + | otherwise + = 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 ctxt item ty1 ty2 + mismatch_msg = mkMismatchMsg item 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 (isConcreteType 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) + , frr_info_other_origin = Just (errorItemOrigin item) } + + ty1 = mkTyVarTy tv1 + + check_eq_result = case ei_m_reason item of + Just (NonCanonicalReason result) -> result + _ -> cteOK + +eqInfoMsgs :: TcType -> TcType -> [AmbiguityInfo] +-- Report (a) ambiguity if either side is a type function application +-- e.g. F a0 ~ Int +-- (b) warning about injectivity if both sides are the same +-- type function application F a ~ F b +-- See Note [Non-injective type functions] +eqInfoMsgs ty1 ty2 + = catMaybes [tyfun_msg, ambig_msg] + where + mb_fun1 = isTyFun_maybe ty1 + mb_fun2 = isTyFun_maybe ty2 + + ambig_tkvs1@(kvs1, tvs1) = ambigTkvsOfTy ty1 + ambig_tkvs2@(kvs2, tvs2) = ambigTkvsOfTy 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_tkvs@(ambig_kvs, ambig_tvs) + = case (mb_fun1, mb_fun2) of + (Nothing, Nothing) -> ([], []) + (Just {}, Nothing) -> ambig_tkvs1 + (Nothing, Just {}) -> ambig_tkvs2 + (Just{},Just{}) -> (kvs1 `union` kvs2, tvs1 `union` tvs2) -- Avoid dups + + 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 :: SolverReportErrCtxt -> ErrorItem + -> TcType -> TcType -> MismatchMsg +-- If oriented then ty1 is actual, ty2 is expected +misMatchOrCND ctxt item ty1 ty2 + | insoluble_item -- See Note [Insoluble mis-match] + || (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 + insoluble_item = case ei_m_reason item of + Nothing -> False + Just r -> isInsolubleReason r + + 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] + +{- +Note [Suppress redundant givens during error reporting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When GHC is unable to solve a constraint and prints out an error message, it +will print out what given constraints are in scope to provide some context to +the programmer. But we shouldn't print out /every/ given, since some of them +are not terribly helpful to diagnose type errors. Consider this example: + + foo :: Int :~: Int -> a :~: b -> a :~: c + foo Refl Refl = Refl + +When reporting that GHC can't solve (a ~ c), there are two givens in scope: +(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e., +redundant), so it's not terribly useful to report it in an error message. +To accomplish this, we discard any Implications that do not bind any +equalities by filtering the `givens` selected in `misMatchOrCND` (based on +the `ic_given_eqs` field of the Implication). Note that we discard givens +that have no equalities whatsoever, but we want to keep ones with only *local* +equalities, as these may be helpful to the user in understanding what went +wrong. + +But this is not enough to avoid all redundant givens! Consider this example, +from #15361: + + goo :: forall (a :: Type) (b :: Type) (c :: Type). + a :~~: b -> a :~~: c + goo HRefl = HRefl + +Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope. +The (* ~ *) part arises due the kinds of (:~~:) being unified. More +importantly, (* ~ *) is redundant, so we'd like not to report it. However, +the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its +ic_given_eqs field), so the test above will keep it wholesale. + +To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) +part. This works because mkMinimalBySCs eliminates reflexive equalities in +addition to superclasses (see Note [Remove redundant provided dicts] +in GHC.Tc.TyCl.PatSyn). +-} + +extraTyVarEqInfo :: (TcTyVar, Maybe Implication) -> TcType -> TcM TyVarInfo +-- Add on extra info about skolem constants +-- NB: The types themselves are already tidied +extraTyVarEqInfo (tv1, mb_implic) ty2 + = do + tv1_info <- extraTyVarInfo tv1 + ty2_info <- ty_extra ty2 + return $ + TyVarInfo + { thisTyVar = tv1_info + , thisTyVarIsUntouchable = mb_implic + , otherTy = ty2_info } + where + ty_extra ty = case getCastedTyVar_maybe ty of + Just (tv, _) -> Just <$> extraTyVarInfo tv + Nothing -> return Nothing + +extraTyVarInfo :: TcTyVar -> TcM TyVar +extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ + case tcTyVarDetails tv of + SkolemTv skol_info lvl overlaps -> do + new_skol_info <- liftZonkM $ zonkSkolemInfo skol_info + return $ mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps) + _ -> return tv + +-------------------- +mkMismatchMsg :: ErrorItem -> Type -> Type -> MismatchMsg +mkMismatchMsg item ty1 ty2 = + case orig of + TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> + (TypeEqMismatch + { teq_mismatch_item = item + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 + , teq_mismatch_actual = uo_actual + , teq_mismatch_expected = uo_expected + , teq_mismatch_what = mb_thing + , teq_mb_same_occ = sameOccExtras ty2 ty1 }) + KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k -> BasicMismatch + { mismatch_ea = NoEA + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 + , mismatch_whenMatching = Just $ WhenMatching cty1 cty2 sub_o mb_sub_t_or_k + , mismatch_mb_same_occ = mb_same_occ + } + _ -> BasicMismatch + { mismatch_ea = NoEA + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 + , mismatch_whenMatching = Nothing + , mismatch_mb_same_occ = mb_same_occ + } + where + orig = errorItemOrigin item + mb_same_occ = sameOccExtras ty2 ty1 + +{- Note [Insoluble mis-match] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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. + +Exactly the same is true if we have [G] Int ~ Bool, [W] Int ~ Bool. + +Conclusion: if there's an insoluble constraint (isInsolubleReason), +then report it directly, not in the "cannot deduce X from Y" form. +This is done in misMatchOrCND (via the insoluble_occurs_check arg) + +(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't +want to be as draconian with them.) +-} + +sameOccExtras :: TcType -> TcType -> Maybe SameOccInfo +-- See Note [Disambiguating (X ~ X) errors] +sameOccExtras ty1 ty2 + | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 + , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 + , let n1 = tyConName tc1 + n2 = tyConName tc2 + same_occ = nameOccName n1 == nameOccName n2 + same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) + , n1 /= n2 -- Different Names + , same_occ -- but same OccName + = Just $ SameOcc same_pkg n1 n2 + | otherwise + = Nothing + +{- Note [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 +* * +************************************************************************ +-} + +mkQCErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport +mkQCErr ctxt items + | item1 :| _ <- tryFilter (not . ei_suppress) items + -- Ignore multiple qc-errors on the same line + = do { let msg = mkPlainMismatchMsg $ + CouldNotDeduce (getUserGivens ctxt) (item1 :| []) Nothing + ; return $ important ctxt msg } + + +mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport +mkDictErr ctxt orig_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, (imp_errs, hints) ) <- + mk_dict_err ctxt (head (no_inst_items ++ overlap_items)) + ; return $ + SolverReport + { sr_important_msg = SolverReportWithCtxt ctxt err + , sr_supplementary = [ SupplementaryImportErrors imps + | imps <- maybeToList (NE.nonEmpty imp_errs) ] + , sr_hints = hints + } + } + where + items = tryFilter (not . ei_suppress) orig_items + + 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 = mkMinimalBySCs errorItemPred . toList + +-- 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, ([ImportError], [GhcHint]) ) +mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped)) + = case (NE.nonEmpty matches, NE.nonEmpty unsafe_overlapped) of + (Nothing, _) -> do -- No matches but perhaps several unifiers + { (_, rel_binds, item) <- relevantBindings True ctxt item + ; candidate_insts <- get_candidate_instances + ; (imp_errs, field_suggestions) <- record_field_suggestions item + ; return (CannotResolveInstance item unifiers candidate_insts rel_binds, (imp_errs, field_suggestions)) } + + -- Some matches => overlap errors + (Just matchesNE, Nothing) -> return $ + ( OverlappingInstances item (NE.map fst matchesNE) unifiers, ([], [])) + + (Just (match :| []), Just unsafe_overlappedNE) -> return $ + ( UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE), ([], [])) + (Just matches@(_ :| _), Just overlaps) -> + pprPanic "mk_dict_err: multiple matches with overlap" $ + vcat [ text "matches:" <+> ppr matches + , text "overlaps:" <+> ppr overlaps + ] + where + orig = errorItemOrigin item + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + unifiers = getCoherentUnifiers pot_unifiers + + 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 :: ErrorItem -> TcM ([ImportError], [GhcHint]) + record_field_suggestions item = flip (maybe $ return ([], noHints)) record_field $ \name -> + do { glb_env <- getGlobalRdrEnv + ; lcl_env <- getLocalRdrEnv + ; let field_name_hints = report_no_fieldnames item + ; (errs, hints) <- if occ_name_in_scope glb_env lcl_env name + then return ([], noHints) + else unknownNameSuggestions emptyLocalRdrEnv WL_RecField (mkRdrUnqual name) + ; pure (errs, hints ++ field_name_hints) + } + + -- get type names from instance + -- resolve the type - if it's in scope is it a record? + -- if it's a record, report an error - the record name + the field that could not be found + report_no_fieldnames :: ErrorItem -> [GhcHint] + report_no_fieldnames item + | Just (EvVarDest evvar) <- ei_evdest item + -- we can assume that here we have a `HasField @Symbol x r a` instance + -- because of GetFieldOrigin in record_field + , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar) + , Just (r_tycon, _) <- tcSplitTyConApp_maybe r + , Just x_name <- isStrLitTy x + -- we check that this is a record type by checking whether it has any + -- fields (in scope) + , not . null $ tyConFieldLabels r_tycon + = [RemindRecordMissingField x_name r a] + | otherwise = [] + + occ_name_in_scope glb_env lcl_env occ_name = not $ + null (lookupGRE glb_env (LookupOccName occ_name (RelevantGREsFOS WantNormal))) && + isNothing (lookupLocalRdrOcc lcl_env occ_name) + + record_field = case orig of + GetFieldOrigin name -> Just (mkVarOccFS name) + _ -> Nothing + +{- 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 "" ...). + +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’ +-} + +----------------------- +-- 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) <- liftZonkM $ 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) <- liftZonkM $ 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 + -> CtLocEnv + -> 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 _ <- ctl_bndrs lcl_env ] + , pprWithCommas id + [ ppr id | TcIdBndr_ExpType id _ _ <- ctl_bndrs lcl_env ] ] + + ; go dflags (maxRelevantBinds dflags) + emptyVarSet (RelevantBindings [] False) + (removeBindingShadowing $ ctl_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 <- liftIO $ 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 :: [Ct] -> TcTyVar -> Type -> TcM () +warnDefaulting [] _ _ + = panic "warnDefaulting: empty Wanteds" +warnDefaulting wanteds@(ct:_) the_tv default_ty + = do { warn_default <- woptM Opt_WarnTypeDefaults + ; env0 <- liftZonkM $ 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 -> Maybe (Type, Type) +solverReportMsg_ExpectedActuals + = \case + Mismatch { mismatchMsg = mismatch_msg } -> + mismatchMsg_ExpectedActuals mismatch_msg + _ -> Nothing + +-- | Filter the list by the given predicate, but if that would be empty, +-- just give back the original list. +-- We use this as we must report something for fdefer-type-errors. +tryFilter :: (a -> Bool) -> NonEmpty a -> NonEmpty a +tryFilter f as = fromMaybe as $ nonEmpty (filter f (toList as)) diff --git a/GHC/Tc/Errors/Hole.hs b/GHC/Tc/Errors/Hole.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Hole.hs @@ -0,0 +1,1042 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ExistentialQuantification #-} + +module GHC.Tc.Errors.Hole + ( findValidHoleFits + , tcCheckHoleFit + , withoutUnification + , tcSubsumes + , isFlexiTyVar + , tcFilterHoleFits + , getLocalBindings + , addHoleFitDocs + , getHoleFitSortingAlg + , getHoleFitDispConfig + , HoleFitDispConfig (..) + , HoleFitSortingAlg (..) + , relevantCtEvidence + , zonkSubs + + , sortHoleFitsByGraph + , sortHoleFitsBySize + + + -- Re-exported from GHC.Tc.Errors.Hole.Plugin + , HoleFitPlugin (..), HoleFitPluginR (..) + ) +where + +import GHC.Prelude + +import GHC.Tc.Errors.Types ( HoleFitDispConfig(..), FitsMbSuppressed(..) + , ValidHoleFits(..), noValidHoleFits ) +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.CtLoc +import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.TcType +import GHC.Core.TyCon( TyCon, isGenerativeTyCon ) +import GHC.Core.TyCo.Rep( Type(..) ) +import GHC.Core.DataCon +import GHC.Core.Predicate( Pred(..), classifyPredType, eqRelRole ) +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Builtin.Names ( gHC_INTERNAL_ERR, gHC_INTERNAL_UNSAFE_COERCE ) +import GHC.Builtin.Types ( tupleDataConName, unboxedSumDataConName ) +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.TyThing +import GHC.Data.Bag +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Utils.Misc +import GHC.Tc.Utils.Env (tcLookup) +import GHC.Utils.Outputable +import GHC.Driver.DynFlags +import GHC.Data.Maybe +import GHC.Utils.FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV ) + +import Control.Arrow ( (&&&) ) + +import Control.Monad ( filterM, replicateM, foldM ) +import Data.List ( partition, sort, sortOn, nubBy ) +import Data.Graph ( graphFromEdges, topSort ) + + +import GHC.Tc.Solver ( simplifyTopWanteds ) +import GHC.Tc.Solver.Monad ( runTcSEarlyAbort ) +import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) + +import GHC.HsToCore.Docs ( extractDocs ) +import GHC.Hs.Doc +import GHC.Unit.Module.ModIface ( mi_docs ) +import GHC.Iface.Load ( loadInterfaceForName ) + +import GHC.Builtin.Utils (knownKeyNames) + +import GHC.Tc.Errors.Hole.FitTypes +import GHC.Tc.Errors.Hole.Plugin +import qualified Data.Set as Set +import GHC.Types.SrcLoc +import GHC.Data.FastString (NonDetFastString(..)) +import GHC.Types.Unique.Map + +import GHC.Data.EnumSet (EnumSet) +import qualified GHC.Data.EnumSet as EnumSet +import qualified GHC.LanguageExtensions as LangExt + + +{- +Note [Valid hole fits include ...] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`findValidHoleFits` returns the "Valid hole fits include ..." message. +For example, look at the following definitions in a file called test.hs: + + import Data.List (inits) + + f :: [String] + f = _ "hello, world" + +The hole in `f` would generate the message: + + • Found hole: _ :: [Char] -> [String] + • In the expression: _ + In the expression: _ "hello, world" + In an equation for ‘f’: f = _ "hello, world" + • Relevant bindings include f :: [String] (bound at test.hs:6:1) + Valid hole fits include + lines :: String -> [String] + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘base-4.11.0.0:Data.OldList’)) + words :: String -> [String] + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘base-4.11.0.0:Data.OldList’)) + inits :: forall a. [a] -> [[a]] + with inits @Char + (imported from ‘Data.List’ at mpt.hs:4:19-23 + (and originally defined in ‘base-4.11.0.0:Data.OldList’)) + repeat :: forall a. a -> [a] + with repeat @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.List’)) + fail :: forall (m :: * -> *). Monad m => forall a. String -> m a + with fail @[] @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + return :: forall (m :: * -> *). Monad m => forall a. a -> m a + with return @[] @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a + with pure @[] @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + read :: forall a. Read a => String -> a + with read @[String] + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘Text.Read’)) + mempty :: forall a. Monoid a => a + with mempty @([Char] -> [String]) + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + +Valid hole fits are found by checking top level identifiers and local bindings +in scope for whether their type can be instantiated to the type of the hole. +Additionally, we also need to check whether all relevant constraints are solved +by choosing an identifier of that type as well, see Note [Relevant constraints] + +Since checking for subsumption results in the side-effect of type variables +being unified by the simplifier, we need to take care to restore them after +to being flexible type variables after we've checked for subsumption. +This is to avoid affecting the hole and later checks by prematurely having +unified one of the free unification variables. + +When outputting, we sort the hole fits by the size of the types we'd need to +apply by type application to the type of the fit to make it fit. This is done +in order to display "more relevant" suggestions first. Another option is to +sort by building a subsumption graph of fits, i.e. a graph of which fits subsume +what other fits, and then outputting those fits which are subsumed by other +fits (i.e. those more specific than other fits) first. This results in the ones +"closest" to the type of the hole to be displayed first. + +To help users understand how the suggested fit works, we also display the values +that the quantified type variables would take if that fit is used, like +`mempty @([Char] -> [String])` and `pure @[] @String` in the example above. +If -XTypeApplications is enabled, this can even be copied verbatim as a +replacement for the hole. + +Note [Checking hole fits] +~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a hole of type hole_ty, we want to know whether a variable +of type ty is a valid fit for the whole. This is a subsumption check: +we wish to know whether ty <: hole_ty. But, of course, the check +must take into account any givens and relevant constraints. +(See also Note [Relevant constraints]). + +For the simplifier to be able to use any givens present in the enclosing +implications to solve relevant constraints, we nest the wanted subsumption +constraints and relevant constraints within the enclosing implications. + +As an example, let's look at the following code: + + f :: Show a => a -> String + f x = show _ + +Suppose the hole is assigned type a0_a1pd[tau:2]. +Here the nested implications are just one level deep, namely: + + [Implic { + TcLevel = 2 + Skolems = a_a1pa[sk:2] + No-eqs = True + Status = Unsolved + Given = $dShow_a1pc :: Show a_a1pa[sk:2] + Wanted = + WC {wc_simple = + [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))} + Binds = EvBindsVar + Needed inner = [] + Needed outer = [] + the type signature for: + f :: forall a. Show a => a -> String }] + +As we can see, the givens say that the skolem +`a_a1pa[sk:2]` fulfills the Show constraint, and that we must prove +the [W] Show a0_a1pd[tau:2] constraint -- that is, whatever fills the +hole must have a Show instance. + +When we now check whether `x :: a_a1pa[sk:2]` fits the hole in +`tcCheckHoleFit`, the call to `tcSubType` will end up unifying the meta type +variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted constraints +needed by tcSubType_NC and the relevant constraints (see Note [Relevant +constraints] for more details) in the nested implications, we can pass the +information in the givens along to the simplifier. For our example, we end up +needing to check whether the following constraints are soluble. + + WC {wc_impl = + Implic { + TcLevel = 2 + Skolems = a_a1pa[sk:2] + No-eqs = True + Status = Unsolved + Given = $dShow_a1pc :: Show a_a1pa[sk:2] + Wanted = + WC {wc_simple = + [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)} + Binds = EvBindsVar + Needed inner = [] + Needed outer = [] + the type signature for: + f :: forall a. Show a => a -> String }} + +But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested +implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up +with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match. + +To avoid side-effects on the nested implications, we create a new EvBindsVar so +that any changes to the ev binds during a check remains localised to that check. +In addition, we call withoutUnification to reset any unified metavariables; this +call is actually done outside tcCheckHoleFit so that the results can be formatted +for the user before resetting variables. + +Note [Valid refinement hole fits include ...] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the `-frefinement-level-hole-fits=N` flag is given, we additionally look +for "valid refinement hole fits"", i.e. valid hole fits with up to N +additional holes in them. + +With `-frefinement-level-hole-fits=0` (the default), GHC will find all +identifiers 'f' (top-level or nested) that will fit in the hole. + +With `-frefinement-level-hole-fits=1`, GHC will additionally find all +applications 'f _' that will fit in the hole, where 'f' is an in-scope +identifier, applied to single argument. It will also report the type of the +needed argument (a new hole). + +And similarly as the number of arguments increases + +As an example, let's look at the following code: + + f :: [Integer] -> Integer + f = _ + +with `-frefinement-level-hole-fits=1`, we'd get: + + Valid refinement hole fits include + + foldl1 (_ :: Integer -> Integer -> Integer) + with foldl1 @[] @Integer + where foldl1 :: forall (t :: * -> *). + Foldable t => + forall a. (a -> a -> a) -> t a -> a + foldr1 (_ :: Integer -> Integer -> Integer) + with foldr1 @[] @Integer + where foldr1 :: forall (t :: * -> *). + Foldable t => + forall a. (a -> a -> a) -> t a -> a + const (_ :: Integer) + with const @Integer @[Integer] + where const :: forall a b. a -> b -> a + ($) (_ :: [Integer] -> Integer) + with ($) @'GHC.Types.LiftedRep @[Integer] @Integer + where ($) :: forall a b. (a -> b) -> a -> b + fail (_ :: String) + with fail @((->) [Integer]) @Integer + where fail :: forall (m :: * -> *). + Monad m => + forall a. String -> m a + return (_ :: Integer) + with return @((->) [Integer]) @Integer + where return :: forall (m :: * -> *). Monad m => forall a. a -> m a + (Some refinement hole fits suppressed; + use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits) + +Which are hole fits with holes in them. This allows e.g. beginners to +discover the fold functions and similar, but also allows for advanced users +to figure out the valid functions in the Free monad, e.g. + + instance Functor f => Monad (Free f) where + Pure a >>= f = f a + Free f >>= g = Free (fmap _a f) + +Will output (with -frefinment-level-hole-fits=1): + Found hole: _a :: Free f a -> Free f b + Where: ‘a’, ‘b’ are rigid type variables bound by + the type signature for: + (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b + at fms.hs:25:12-14 + ‘f’ is a rigid type variable bound by + ... + Relevant bindings include + g :: a -> Free f b (bound at fms.hs:27:16) + f :: f (Free f a) (bound at fms.hs:27:10) + (>>=) :: Free f a -> (a -> Free f b) -> Free f b + (bound at fms.hs:25:12) + ... + Valid refinement hole fits include + ... + (=<<) (_ :: a -> Free f b) + with (=<<) @(Free f) @a @b + where (=<<) :: forall (m :: * -> *) a b. + Monad m => + (a -> m b) -> m a -> m b + (imported from ‘Prelude’ at fms.hs:5:18-22 + (and originally defined in ‘GHC.Base’)) + ... + +Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`). + +We find these refinement suggestions by considering hole fits that don't +fit the type of the hole, but ones that would fit if given an additional +argument. We do this by creating a new type variable with `newOpenFlexiTyVar` +(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type +`t_a1/m[tau:1] -> v` where `v` is the type of the hole. + +Since the simplifier is free to unify this new type variable with any type, we +can discover any identifiers that would fit if given another identifier of a +suitable type. This is then generalized so that we can consider any number of +additional arguments by setting the `-frefinement-level-hole-fits` flag to any +number, and then considering hole fits like e.g. `foldl _ _` with two additional +arguments. + +To make sure that the refinement hole fits are useful, we check that the types +of the additional holes have a concrete value and not just an invented type +variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`, +and limits the number of less than useful refinement hole fits. + +Additionally, to further aid the user in their implementation, we show the +types of the holes the binding would have to be applied to in order to work. +In the free monad example above, this is demonstrated with +`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to +be applied to an expression of type `a -> Free f b` in order to match. +If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim. + +Note [Relevant constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As highlighted by #14273, we need to check any relevant constraints as well +as checking for subsumption. Relevant constraints are the simple constraints +whose free unification variables are mentioned in the type of the hole. + +In the simplest case, these are all non-hole constraints in the simples, such +as is the case in + + f :: String + f = show _ + +Here, the hole is given type a0_a1kv[tau:1]. Then, the emitted constraint is: + + [W] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical) + +However, when there are multiple holes, we need to be more careful. As an +example, Let's take a look at the following code: + + f :: Show a => a -> String + f x = show (_b (show _a)) + +Here there are two holes, `_a` and `_b`. Suppose _a :: a0_a1pd[tau:2] and +_b :: a1_a1po[tau:2]. Then, the simple constraints passed to +findValidHoleFits are: + + [[W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical), + [W] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)] + +When we are looking for a match for the hole `_a`, we filter the simple +constraints to the "Relevant constraints", by throwing out any constraints +which do not mention a variable mentioned in the type of the hole. For hole +`_a`, we will then only require that the `$dShow_a1pe` constraint is solved, +since that is the only constraint that mentions any free type variables +mentioned in the hole constraint for `_a`, namely `a_a1pd[tau:2]`, and +similarly for the hole `_b` we only require that the `$dShow_a1pe` constraint +is solved. + +Note [Leaking errors] +~~~~~~~~~~~~~~~~~~~~~ +When considering candidates, GHC believes that we're checking for validity in +actual source. However, As evidenced by #15321, #15007 and #15202, this can +cause bewildering error messages. The solution here is simple: if a candidate +would cause the type checker to error, it is not a valid hole fit, and thus it +is discarded. + +Note [Speeding up valid hole-fits] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To fix #16875 we noted that a lot of time was being spent on unnecessary work. + +When we'd call `tcCheckHoleFit hole hole_ty ty`, we would end up by generating +a constraint to show that `hole_ty ~ ty`, including any constraints in `ty`. For +example, if `hole_ty = Int` and `ty = Foldable t => (a -> Bool) -> t a -> Bool`, +we'd have `(a_a1pa[sk:1] -> Bool) -> t_t2jk[sk:1] a_a1pa[sk:1] -> Bool ~# Int` +from the coercion, as well as `Foldable t_t2jk[sk:1]`. By adding a flag to +`TcSEnv` and adding a `runTcSEarlyAbort`, we can fail as soon as we hit +an insoluble constraint. Since we don't need the result in the case that it +fails, a boolean `False` (i.e. "it didn't work" from `runTcSEarlyAbort`) +is sufficient. + +We also check whether the type of the hole is an immutable type variable (i.e. +a skolem). In that case, the only possible fits are fits of exactly that type, +which can only come from the locals. This speeds things up quite a bit when we +don't know anything about the type of the hole. This also helps with degenerate +fits like (`id (_ :: a)` and `head (_ :: [a])`) when looking for fits of type +`a`, where `a` is a skolem. +-} + +-- We read the various -no-show-*-of-hole-fits flags +-- and set the display config accordingly. +getHoleFitDispConfig :: TcM HoleFitDispConfig +getHoleFitDispConfig + = do { sWrap <- goptM Opt_ShowTypeAppOfHoleFits + ; sWrapVars <- goptM Opt_ShowTypeAppVarsOfHoleFits + ; sType <- goptM Opt_ShowTypeOfHoleFits + ; sProv <- goptM Opt_ShowProvOfHoleFits + ; sMatc <- goptM Opt_ShowMatchesOfHoleFits + ; return HFDC{ showWrap = sWrap, showWrapVars = sWrapVars + , showProv = sProv, showType = sType + , showMatches = sMatc } } + +-- Which sorting algorithm to use +data HoleFitSortingAlg = HFSNoSorting -- Do not sort the fits at all + | HFSBySize -- Sort them by the size of the match + | HFSBySubsumption -- Sort by full subsumption + deriving (Eq, Ord) + +getHoleFitSortingAlg :: TcM HoleFitSortingAlg +getHoleFitSortingAlg = + do { shouldSort <- goptM Opt_SortValidHoleFits + ; subsumSort <- goptM Opt_SortBySubsumHoleFits + ; sizeSort <- goptM Opt_SortBySizeHoleFits + -- We default to sizeSort unless it has been explicitly turned off + -- or subsumption sorting has been turned on. + ; return $ if not shouldSort + then HFSNoSorting + else if subsumSort + then HFSBySubsumption + else if sizeSort + then HFSBySize + else HFSNoSorting } + +-- If enabled, we go through the fits and add any associated documentation, +-- by looking it up in the module or the environment (for local fits) +addHoleFitDocs :: [HoleFit] -> TcM [HoleFit] +addHoleFitDocs fits = + do { showDocs <- goptM Opt_ShowDocsOfHoleFits + ; if showDocs + then do { dflags <- getDynFlags + ; mb_local_docs <- extractDocs dflags =<< getGblEnv + ; (mods_without_docs, fits') <- mapAccumLM (upd mb_local_docs) Set.empty fits + ; report mods_without_docs + ; return fits' } + else return fits } + where + msg = text "GHC.Tc.Errors.Hole addHoleFitDocs" + upd mb_local_docs mods_without_docs (TcHoleFit 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, TcHoleFit fit) + ; Just docs -> do + { let doc = lookupUniqMap (docs_decls docs) name + ; return $ (mods_without_docs, TcHoleFit (fit {hfDoc = map hsDocString <$> doc})) }}} + upd _ mods_without_docs fit@(RawHoleFit {}) = pure (mods_without_docs, fit) + nameOrigin name = case nameModule_maybe name of + Just m -> Right m + Nothing -> + Left $ case nameSrcLoc name of + -- Nondeterminism is fine, this is used only to display a warning + RealSrcLoc r _ -> NonDetFastString $ srcLocFile r + UnhelpfulLoc s -> NonDetFastString s + report mods = do + { let warning = + text "WARNING: Couldn't find any documentation for the following modules:" $+$ + nest 2 + (pprWithCommas (either ppr ppr) (Set.toList mods) $+$ + text "Make sure the modules are compiled with '-haddock'.") + ; warnPprTrace (not $ Set.null mods) "addHoleFitDocs" warning (pure ()) + } + +getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] +getLocalBindings tidy_orig ct_loc + = do { (env1, _) <- liftZonkM $ zonkTidyOrigin tidy_orig (ctLocOrigin ct_loc) + ; go env1 [] (removeBindingShadowing $ ctl_bndrs lcl_env) } + where + lcl_env = ctLocEnv ct_loc + + go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id] + go _ sofar [] = return (reverse sofar) + go env sofar (tc_bndr : tc_bndrs) = + case tc_bndr of + TcIdBndr id _ -> keep_it id + _ -> discard_it + where + discard_it = go env sofar tc_bndrs + keep_it id = go env (id:sofar) tc_bndrs + + + +-- See Note [Valid hole fits include ...] +findValidHoleFits :: TidyEnv -- ^ The tidy_env for zonking + -> [Implication] -- ^ Enclosing implications for givens + -> [CtEvidence] + -- ^ The unsolved simple constraints in the implication for + -- the hole. + -> Hole + -> TcM (TidyEnv, ValidHoleFits) +findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ + , hole_loc = ct_loc + , hole_ty = hole_ty }) = + do { rdr_env <- getGlobalRdrEnv + ; lclBinds <- getLocalBindings tidy_env ct_loc + ; maxVSubs <- maxValidHoleFits <$> getDynFlags + ; sortingAlg <- getHoleFitSortingAlg + ; dflags <- getDynFlags + ; let exts = extensionFlags dflags + ; hfPlugs <- tcg_hf_plugins <$> getGblEnv + ; let findVLimit = if sortingAlg > HFSNoSorting then Nothing else maxVSubs + refLevel = refLevelHoleFits dflags + hole = TypedHole { th_relevant_cts = + listToBag (relevantCtEvidence hole_ty simples) + , th_implics = implics + , th_hole = Just h } + (candidatePlugins, fitPlugins) = + unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs + ; traceTc "findingValidHoleFitsFor { " $ ppr hole + ; traceTc "hole_lvl is:" $ ppr hole_lvl + ; traceTc "simples are: " $ ppr simples + ; traceTc "locals are: " $ ppr lclBinds + ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env) + -- We remove binding shadowings here, but only for the local level. + -- this is so we e.g. suggest the global fmap from the Functor class + -- even though there is a local definition as well, such as in the + -- Free monad example. + locals = removeBindingShadowing $ + map IdHFCand lclBinds ++ map GreHFCand lcl + globals = map GreHFCand gbl + syntax = map NameHFCand (builtIns exts) + -- If the hole is a rigid type-variable, then we only check the + -- locals, since only they can match the type (in a meaningful way). + only_locals = any isImmutableTyVar $ getTyVar_maybe hole_ty + to_check = if only_locals then locals + else locals ++ syntax ++ globals + ; cands <- foldM (flip ($)) to_check candidatePlugins + ; traceTc "numPlugins are:" $ ppr (length candidatePlugins) + ; (searchDiscards, subs) <- + tcFilterHoleFits findVLimit hole (hole_ty, []) cands + ; (tidy_env, tidy_subs) <- liftZonkM $ zonkSubs tidy_env subs + ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs + ; let apply_plugin :: [HoleFit] -> ([HoleFit] -> TcM [HoleFit]) -> TcM [HoleFit] + apply_plugin fits plug = plug fits + ; plugin_handled_subs <- foldM apply_plugin (map TcHoleFit tidy_sorted_subs) fitPlugins + ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs + vDiscards = pVDisc || searchDiscards + ; subs_with_docs <- addHoleFitDocs limited_subs + ; let subs = Fits subs_with_docs vDiscards + -- Refinement hole fits. See Note [Valid refinement hole fits include ...] + ; (tidy_env, rsubs) <- + if refLevel >= Just 0 + then + do { maxRSubs <- maxRefHoleFits <$> getDynFlags + -- We can use from just, since we know that Nothing >= _ is False. + ; let refLvls = [1..(fromJust refLevel)] + -- We make a new refinement type for each level of refinement, where + -- the level of refinement indicates number of additional arguments + -- to allow. + ; ref_tys <- mapM mkRefTy refLvls + ; traceTc "ref_tys are" $ ppr ref_tys + ; let findRLimit = if sortingAlg > HFSNoSorting then Nothing + else maxRSubs + ; refDs :: [(Bool, [TcHoleFit])] + <- mapM (flip (tcFilterHoleFits findRLimit hole) cands) ref_tys + ; (tidy_env, tidy_rsubs :: [TcHoleFit]) + <- liftZonkM $ zonkSubs tidy_env $ concatMap snd refDs + ; tidy_sorted_rsubs :: [TcHoleFit] <- sortFits sortingAlg tidy_rsubs + -- For refinement substitutions we want matches + -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t), + -- and others in that vein to appear last, since these are + -- unlikely to be the most relevant fits. + ; (tidy_env, tidy_hole_ty) <- liftZonkM $ zonkTidyTcType tidy_env hole_ty + ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap + exact, not_exact :: [TcHoleFit] + (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs + fits :: [HoleFit] = map TcHoleFit (not_exact ++ exact) + ; plugin_handled_rsubs <- foldM apply_plugin fits fitPlugins + ; let (pRDisc, exact_last_rfits) = + possiblyDiscard maxRSubs $ plugin_handled_rsubs + rDiscards = pRDisc || any fst refDs + ; rsubs_with_docs <- addHoleFitDocs exact_last_rfits + ; return (tidy_env, Fits rsubs_with_docs rDiscards) } + else return (tidy_env, Fits [] False) + ; traceTc "findingValidHoleFitsFor }" empty + ; let hole_fits = ValidHoleFits subs rsubs + ; return (tidy_env, hole_fits) } + where + -- We extract the TcLevel from the constraint. + hole_lvl = ctLocLevel ct_loc + + -- BuiltInSyntax names like (:) and [] + builtIns :: EnumSet LangExt.Extension -> [Name] + builtIns exts = filter isBuiltInSyntax (knownKeyNames ++ infFamNames) + where + -- Tuples and sums of are not included in knownKeyName as there are infinitely many of them. + -- See Note [Infinite families of known-key names] in GHC.Builtin.Names. + infFamNames = + [tupleDataConName Boxed n | n <- [0..max_tup]] + ++ [tupleDataConName Unboxed n | unboxedTuples, n <- [0..max_tup]] + ++ [unboxedSumDataConName k n | unboxedSums, n <- [2..max_sum], k <- [1..n]] + + -- The upper limits on arity are small to avoid bloating the list with + -- too many names, which would incur a performance cost. + -- Users are unlikely to care about larger tuples/sums anyway. + max_tup = 7 + -- Tuples up to (,,,,,,). Common limit, e.g. this is the highest tuple + -- arity that has a Functor instance. + max_sum = 7 + -- Sums up to (#||||||#). Results in 27 sum constructors because there + -- are [1..n] data constructors at each arity. + + unboxedTuples = EnumSet.member LangExt.UnboxedTuples exts + unboxedSums = EnumSet.member LangExt.UnboxedSums exts + + -- We make a refinement type by adding a new type variable in front + -- of the type of t h hole, going from e.g. [Integer] -> Integer + -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier + -- to unify the new type variable with any type, allowing us + -- to suggest a "refinement hole fit", like `(foldl1 _)` instead + -- of only concrete hole fits like `sum`. + mkRefTy :: Int -> TcM (TcType, [TcTyVar]) + mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars + where newTyVars = replicateM refLvl $ setLvl <$> newOpenFlexiTyVar + setLvl = flip setMetaTyVarTcLevel hole_lvl + wrapWithVars vars = mkVisFunTysMany (map mkTyVarTy vars) hole_ty + + sortFits :: HoleFitSortingAlg -- How we should sort the hole fits + -> [TcHoleFit] -- The subs to sort + -> TcM [TcHoleFit] + sortFits HFSNoSorting subs = return subs + sortFits HFSBySize subs + = (++) <$> sortHoleFitsBySize (sort lclFits) + <*> sortHoleFitsBySize (sort gblFits) + where (lclFits, gblFits) = span hfIsLcl subs + -- To sort by subsumption, we invoke the sortByGraph function, which + -- builds the subsumption graph for the fits and then sorts them using a + -- graph sort. Since we want locals to come first anyway, we can sort + -- them separately. The substitutions are already checked in local then + -- global order, so we can get away with using span here. + -- We use (<*>) to expose the parallelism, in case it becomes useful later. + sortFits HFSBySubsumption subs + = (++) <$> sortHoleFitsByGraph (sort lclFits) + <*> sortHoleFitsByGraph (sort gblFits) + where (lclFits, gblFits) = span hfIsLcl subs + + -- Based on the flags, we might possibly discard some or all the + -- fits we've found. + possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit]) + possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits) + possiblyDiscard Nothing fits = (False, fits) + + +-- We don't (as of yet) handle holes in types, only in expressions. +findValidHoleFits env _ _ _ = return (env, noValidHoleFits) + +-- See Note [Relevant constraints] +relevantCtEvidence :: Type -> [CtEvidence] -> [CtEvidence] +relevantCtEvidence hole_ty simples + = if isEmptyVarSet (fvVarSet hole_fvs) + then [] + else filter isRelevant simples + where hole_fvs = tyCoFVsOfType hole_ty + hole_fv_set = fvVarSet hole_fvs + -- We filter out those constraints that have no variables (since + -- they won't be solved by finding a type for the type variable + -- representing the hole) and also other holes, since we're not + -- trying to find hole fits for many holes at once. + isRelevant ctev = not (isEmptyVarSet fvs) && + (fvs `intersectsVarSet` hole_fv_set) + where fvs = tyCoVarsOfCtEv ctev + +-- We zonk the hole fits so that the output aligns with the rest +-- of the typed hole error message output. +zonkSubs :: TidyEnv -> [TcHoleFit] -> ZonkM (TidyEnv, [TcHoleFit]) +zonkSubs = zonkSubs' [] + where zonkSubs' zs env [] = return (env, reverse zs) + zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf + ; zonkSubs' (z:zs) env' hfs } + + zonkSub :: TidyEnv -> TcHoleFit -> ZonkM (TidyEnv, TcHoleFit) + zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp} + = do { (env, ty') <- zonkTidyTcType env ty + ; (env, m') <- zonkTidyTcTypes env m + ; (env, wrp') <- zonkTidyTcTypes env wrp + ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'} + ; return (env, zFit ) } + +-- | Sort by size uses as a measure for relevance the sizes of the different +-- types needed to instantiate the fit to the type of the hole. +-- This is much quicker than sorting by subsumption, and gives reasonable +-- results in most cases. +sortHoleFitsBySize :: [TcHoleFit] -> TcM [TcHoleFit] +sortHoleFitsBySize = return . sortOn sizeOfFit + where sizeOfFit :: TcHoleFit -> TypeSize + sizeOfFit = sizeTypes . nubBy tcEqType . hfWrap + +-- Based on a suggestion by phadej on #ghc, we can sort the found fits +-- by constructing a subsumption graph, and then do a topological sort of +-- the graph. This makes the most specific types appear first, which are +-- probably those most relevant. This takes a lot of work (but results in +-- much more useful output), and can be disabled by +-- '-fno-sort-valid-hole-fits'. +sortHoleFitsByGraph :: [TcHoleFit] -> TcM [TcHoleFit] +sortHoleFitsByGraph fits = go [] fits + where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool + tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty) + where fvs = tyCoFVsOfTypes [ht,ty] + go :: [(TcHoleFit, [TcHoleFit])] -> [TcHoleFit] -> TcM [TcHoleFit] + go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar + ; return $ uncurry (++) $ partition hfIsLcl topSorted } + where toV (hf, adjs) = (hf, hfId hf, map hfId adjs) + (graph, fromV, _) = graphFromEdges $ map toV sofar + topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph + go sofar (hf:hfs) = + do { adjs <- filterM (tcSubsumesWCloning (hfType hf) . hfType) fits + ; go ((hf, adjs):sofar) hfs } + +-- | tcFilterHoleFits filters the candidates by whether, given the implications +-- and the relevant constraints, they can be made to match the type by +-- running the type checker. Stops after finding limit matches. +tcFilterHoleFits :: Maybe Int + -- ^ How many we should output, if limited + -> TypedHole -- ^ The hole to filter against + -> (TcType, [TcTyVar]) + -- ^ The type to check for fits and a list of refinement + -- variables (free type variables in the type) for emulating + -- additional holes. + -> [HoleFitCandidate] + -- ^ The candidates to check whether fit. + -> TcM (Bool, [TcHoleFit]) + -- ^ We return whether or not we stopped due to hitting the limit + -- and the fits we found. +tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0 +tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates = + do { traceTc "checkingFitsFor {" $ ppr hole_ty + ; (discards, subs) <- go [] emptyVarSet limit ht candidates + ; traceTc "checkingFitsFor }" empty + ; return (discards, subs) } + where + hole_fvs :: FV + hole_fvs = tyCoFVsOfType hole_ty + -- Kickoff the checking of the elements. + -- We iterate over the elements, checking each one in turn for whether + -- it fits, and adding it to the results if it does. + go :: [TcHoleFit] -- What we've found so far. + -> VarSet -- Ids we've already checked + -> Maybe Int -- How many we're allowed to find, if limited + -> (TcType, [TcTyVar]) -- The type, and its refinement variables. + -> [HoleFitCandidate] -- The elements we've yet to check. + -> TcM (Bool, [TcHoleFit]) + go subs _ _ _ [] = return (False, reverse subs) + go subs _ (Just 0) _ _ = return (True, reverse subs) + go subs seen maxleft ty (el:elts) = + -- See Note [Leaking errors] + tryTcDiscardingErrs discard_it $ + do { traceTc "lookingUp" $ ppr el + ; maybeThing <- lookup el + ; case maybeThing of + Just (id, id_ty) | not_trivial id -> + do { fits <- fitsHole ty id_ty + ; case fits of + Just (wrp, matches) -> keep_it id id_ty wrp matches + _ -> discard_it } + _ -> discard_it } + where + -- We want to filter out undefined and the likes from GHC.Err (#17940) + not_trivial id = nameModule_maybe (idName id) `notElem` [Just gHC_INTERNAL_ERR, Just gHC_INTERNAL_UNSAFE_COERCE] + + lookup :: HoleFitCandidate -> TcM (Maybe (Id, Type)) + lookup (IdHFCand id) = return (Just (id, idType id)) + lookup hfc = do { thing <- tcLookup name + ; return $ case thing of + ATcId {tct_id = id} -> Just (id, idType id) + AGlobal (AnId id) -> Just (id, idType id) + AGlobal (AConLike (RealDataCon con)) -> + Just (dataConWrapId con, dataConNonlinearType con) + _ -> Nothing } + where name = case hfc of + GreHFCand gre -> greName gre + NameHFCand name -> name + discard_it = go subs seen maxleft ty elts + keep_it eid eid_ty wrp ms = go (fit:subs) (extendVarSet seen eid) + ((\n -> n - 1) <$> maxleft) ty elts + where + fit = HoleFit { hfId = eid, hfCand = el, hfType = eid_ty + , hfRefLvl = length (snd ty) + , hfWrap = wrp, hfMatches = ms + , hfDoc = Nothing } + + + + + unfoldWrapper :: HsWrapper -> [Type] + unfoldWrapper = reverse . unfWrp' + where unfWrp' (WpTyApp ty) = [ty] + unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2 + unfWrp' _ = [] + + + -- The real work happens here, where we invoke the type checker using + -- tcCheckHoleFit to see whether the given type fits the hole. + fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the + -- refinement variables created to simulate + -- additional holes (if any), and the list + -- of those variables (possibly empty). + -- As an example: If the actual type of the + -- hole (as specified by the hole + -- constraint CHoleExpr passed to + -- findValidHoleFits) is t and we want to + -- simulate N additional holes, h_ty will + -- be r_1 -> ... -> r_N -> t, and + -- ref_vars will be [r_1, ... , r_N]. + -- In the base case with no additional + -- holes, h_ty will just be t and ref_vars + -- will be []. + -> TcType -- The type we're checking to whether it can be + -- instantiated to the type h_ty. + -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we + -- return Nothing. Otherwise, + -- we Just return the list of + -- types that quantified type + -- variables in ty would take + -- if used in place of h_ty, + -- and the list types of any + -- additional holes simulated + -- with the refinement + -- variables in ref_vars. + fitsHole (h_ty, ref_vars) ty = + -- We wrap this with the withoutUnification to avoid having side-effects + -- beyond the check, but we rely on the side-effects when looking for + -- refinement hole fits, so we can't wrap the side-effects deeper than this. + withoutUnification fvs $ + do { traceTc "checkingFitOf {" $ ppr ty + ; (fits, wrp) <- tcCheckHoleFit hole h_ty ty + ; traceTc "Did it fit?" $ ppr fits + ; traceTc "wrap is: " $ ppr wrp + ; traceTc "checkingFitOf }" empty + -- We'd like to avoid refinement suggestions like `id _ _` or + -- `head _ _`, and only suggest refinements where our all phantom + -- variables got unified during the checking. This can be disabled + -- with the `-fabstract-refinement-hole-fits` flag. + -- Here we do the additional handling when there are refinement + -- variables, i.e. zonk them to read their final value to check for + -- abstract refinements, and to report what the type of the simulated + -- holes must be for this to be a match. + ; if fits then do { + -- Zonking is expensive, so we only do it if required. + z_wrp_tys <- liftZonkM $ 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 <- liftZonkM $ zonkTcTyVars ref_vars + ; let z_mtvs = mapMaybe getTyVar_maybe z_vars + ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs + ; allowAbstract <- goptM Opt_AbstractRefHoleFits + ; if allowAbstract || (allFilled && allConcrete ) + then return $ Just (z_wrp_tys, z_vars) + else return Nothing }} + else return Nothing } + where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty + hole = typed_hole { th_hole = Nothing } + + + +-- | Checks whether a MetaTyVar is flexible or not. +isFlexiTyVar :: TcTyVar -> TcM Bool +isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv +isFlexiTyVar _ = return False + +-- | Takes a list of free variables and restores any Flexi type variables in +-- free_vars after the action is run. +withoutUnification :: FV -> TcM a -> TcM a +withoutUnification free_vars action = + do { flexis <- filterM isFlexiTyVar fuvs + ; result <- action + -- Reset any mutated free variables + ; mapM_ restore flexis + ; return result } + where restore tv = do { traceTc "withoutUnification: restore flexi" (ppr tv) + ; writeTcRef (metaTyVarRef tv) Flexi } + fuvs = fvVarList free_vars + +-- | Reports whether first type (ty_a) subsumes the second type (ty_b), +-- discarding any errors. Subsumption here means that the ty_b can fit into the +-- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a. +tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool +tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b + where dummyHole = TypedHole { th_relevant_cts = emptyBag + , th_implics = [] + , th_hole = Nothing } + +-- | A tcSubsumes which takes into account relevant constraints, to fix +-- #14273. This makes sure that when checking whether a type fits the hole, +-- the type has to be subsumed by type of the hole as well as fulfill all +-- constraints on the type of the hole. +tcCheckHoleFit :: TypedHole -- ^ The hole to check against + -> TcSigmaType + -- ^ The type of the hole to check against (possibly modified, + -- e.g. refined with additional holes for refinement hole-fits.) + -> TcSigmaType -- ^ The type to check whether fits. + -> TcM (Bool, HsWrapper) + -- ^ Whether it was a match, and the wrapper from hole_ty to ty. +tcCheckHoleFit _ hole_ty ty | hole_ty `eqType` ty + = return (True, idHsWrapper) +tcCheckHoleFit (TypedHole {..}) hole_ty ty = discardErrs $ + do { -- We wrap the subtype constraint in the implications to pass along the + -- givens, and so we must ensure that any nested implications and skolems + -- end up with the correct level. The implications are ordered so that + -- the innermost (the one with the highest level) is first, so it + -- suffices to get the level of the first one (or the current level, if + -- there are no implications involved). + innermost_lvl <- case th_implics of + [] -> getTcLevel + -- imp is the innermost implication + (imp:_) -> return (ic_tclvl imp) + ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $ + tcSubTypeSigma orig (ExprSigCtxt NoRRC) ty hole_ty + ; traceTc "Checking hole fit {" empty + ; traceTc "wanteds are: " $ ppr wanted + ; if | isEmptyWC wanted, isEmptyBag th_relevant_cts + -> do { traceTc "}" empty + ; return (True, wrap) } + + | checkInsoluble wanted -- See Note [Fast path for tcCheckHoleFit] + -> return (False, wrap) + + | otherwise + -> do { fresh_binds <- newTcEvBinds + -- The relevant constraints may contain HoleDests, so we must + -- take care to clone them as well (to avoid #15370). + ; cloned_relevants <- mapBagM cloneWantedCtEv th_relevant_cts + -- We wrap the WC in the nested implications, for details, see + -- Note [Checking hole fits] + ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics + final_wc = wrapInImpls $ addSimples wanted $ + mapBag mkNonCanonical cloned_relevants + -- We add the cloned relevants to the wanteds generated + -- by the call to tcSubType_NC, for details, see + -- Note [Relevant constraints]. There's no need to clone + -- the wanteds, because they are freshly generated by the + -- call to`tcSubtype_NC`. + ; traceTc "final_wc is: " $ ppr final_wc + -- See Note [Speeding up valid hole-fits] + ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc + ; traceTc "}" empty + ; return (any isSolvedWC rem, wrap) } } + where + orig = ExprHoleOrigin (hole_occ <$> th_hole) + + setWCAndBinds :: EvBindsVar -- Fresh ev binds var. + -> Implication -- The implication to put WC in. + -> WantedConstraints -- The WC constraints to put implic. + -> WantedConstraints -- The new constraints. + setWCAndBinds binds imp wc + = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds } + +{- Note [Fast path for tcCheckHoleFit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `tcCheckHoleFit` we compare (with `tcSubTypeSigma`) the type of the hole +with the type of zillions of in-scope functions, to see which would "fit". +Most of these checks fail! They generate obviously-insoluble constraints. +For these very-common cases we don't want to crank up the full constraint +solver. It's much more efficient to do a quick-and-dirty check for insolubility. + +Now, `tcSubTypeSigma` uses the on-the-fly unifier in GHC.Tc.Utils.Unify, +it has already done the dirt-simple unification. So our quick-and-dirty +check can simply look for constraints like (Int ~ Bool). We don't need +to worry about (Maybe Int ~ Maybe Bool). + +The quick-and-dirty check is in `checkInsoluble`. It can make a big +difference: For test hard_hole_fits, compile-time allocation goes down by 37%! +-} + + +checkInsoluble :: WantedConstraints -> Bool +-- See Note [Fast path for tcCheckHoleFit] +checkInsoluble (WC { wc_simple = simples }) + = any is_insol simples + where + is_insol ct = case classifyPredType (ctPred ct) of + EqPred r t1 t2 -> definitelyNotEqual (eqRelRole r) t1 t2 + _ -> False + +definitelyNotEqual :: Role -> TcType -> TcType -> Bool +-- See Note [Fast path for tcCheckHoleFit] +-- Specifically, does not need to recurse under type constructors +definitelyNotEqual r t1 t2 + = go t1 t2 + where + go t1 t2 + | Just t1' <- coreView t1 = go t1' t2 + | Just t2' <- coreView t2 = go t1 t2' + + go (TyConApp tc _) t2 | isGenerativeTyCon tc r = go_tc tc t2 + go t1 (TyConApp tc _) | isGenerativeTyCon tc r = go_tc tc t1 + go (FunTy {ft_af = af1}) (FunTy {ft_af = af2}) = af1 /= af2 + go _ _ = False + + go_tc :: TyCon -> TcType -> Bool + -- The TyCon is generative, and is not a saturated FunTy + go_tc tc1 (TyConApp tc2 _) | isGenerativeTyCon tc2 r = tc1 /= tc2 + go_tc _ (FunTy {}) = True + go_tc _ (ForAllTy {}) = True + go_tc _ _ = False diff --git a/GHC/Tc/Errors/Hole.hs-boot b/GHC/Tc/Errors/Hole.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Hole.hs-boot @@ -0,0 +1,16 @@ +-- This boot file is in place to break the loop where: +-- + GHC.Tc.Solver calls 'GHC.Tc.Errors.reportUnsolved', +-- + which calls 'GHC.Tc.Errors.Hole.findValidHoleFits` +-- + which calls 'GHC.Tc.Solver.simpl_top' +module GHC.Tc.Errors.Hole where + +import GHC.Tc.Errors.Types ( HoleFitDispConfig, ValidHoleFits ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Constraint ( CtEvidence, Hole, Implication ) +import GHC.Types.Var.Env ( TidyEnv ) + +findValidHoleFits :: TidyEnv -> [Implication] -> [CtEvidence] -> Hole + -> TcM (TidyEnv, ValidHoleFits) + +getHoleFitDispConfig :: TcM HoleFitDispConfig + diff --git a/GHC/Tc/Errors/Hole/FitTypes.hs b/GHC/Tc/Errors/Hole/FitTypes.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Hole/FitTypes.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE ExistentialQuantification #-} +module GHC.Tc.Errors.Hole.FitTypes ( + TypedHole (..), HoleFit (..), TcHoleFit(..), HoleFitCandidate (..), + hfIsLcl, pprHoleFitCand + ) where + +import GHC.Prelude + +import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.TcType + +import GHC.Types.Name.Reader + +import GHC.Hs.Doc +import GHC.Types.Id + +import GHC.Utils.Outputable +import GHC.Types.Name + +import GHC.Data.Bag + +import Data.Function ( on ) + +data TypedHole = TypedHole { th_relevant_cts :: Bag CtEvidence + -- ^ Any relevant Cts to the hole + , th_implics :: [Implication] + -- ^ The nested implications of the hole with the + -- innermost implication first. + , th_hole :: Maybe Hole + -- ^ The hole itself, if available. + } + +instance Outputable TypedHole where + ppr (TypedHole { th_relevant_cts = rels + , th_implics = implics + , th_hole = hole }) + = hang (text "TypedHole") 2 + (ppr rels $+$ ppr implics $+$ ppr hole) + +-- | HoleFitCandidates are passed to hole fit plugins and then +-- checked whether they fit a given typed-hole. +data HoleFitCandidate = IdHFCand Id -- An id, like locals. + | NameHFCand Name -- A name, like built-in syntax. + | GreHFCand GlobalRdrElt -- A global, like imported ids. + +instance Eq HoleFitCandidate where + IdHFCand i1 == IdHFCand i2 = i1 == i2 + NameHFCand n1 == NameHFCand n2 = n1 == n2 + GreHFCand gre1 == GreHFCand gre2 = greName gre1 == greName gre2 + _ == _ = False + +instance Outputable HoleFitCandidate where + ppr = pprHoleFitCand + +pprHoleFitCand :: HoleFitCandidate -> SDoc +pprHoleFitCand (IdHFCand cid) = text "Id HFC: " <> ppr cid +pprHoleFitCand (NameHFCand cname) = text "Name HFC: " <> ppr cname +pprHoleFitCand (GreHFCand cgre) = text "Gre HFC: " <> ppr cgre + +instance NamedThing HoleFitCandidate where + getName hfc = case hfc of + IdHFCand cid -> idName cid + NameHFCand cname -> cname + GreHFCand cgre -> greName cgre + getOccName hfc = case hfc of + IdHFCand cid -> occName cid + NameHFCand cname -> occName cname + GreHFCand cgre -> occName $ greName cgre + +instance HasOccName HoleFitCandidate where + occName = getOccName + +instance Ord HoleFitCandidate where + compare = compare `on` getName + +-- | HoleFit is the type we use for valid hole fits. It contains the +-- element that was checked, the Id of that element as found by `tcLookup`, +-- and the refinement level of the fit, which is the number of extra argument +-- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`). +data TcHoleFit = + HoleFit { hfId :: Id -- ^ The elements id in the TcM + , hfCand :: HoleFitCandidate -- ^ The candidate that was checked. + , hfType :: TcType -- ^ The type of the id, possibly zonked. + , hfRefLvl :: Int -- ^ The number of holes in this fit. + , hfWrap :: [TcType] -- ^ The wrapper for the match. + , hfMatches :: [TcType] + -- ^ What the refinement variables got matched with, if anything + , hfDoc :: Maybe [HsDocString] + -- ^ Documentation of this HoleFit, if available. + } + +data HoleFit + = TcHoleFit TcHoleFit + | RawHoleFit SDoc + -- ^ A fit that is just displayed as is. Here so that HoleFitPlugins + -- can inject any fit they want. + +-- We define an Eq and Ord instance to be able to build a graph. +instance Eq TcHoleFit where + (==) = (==) `on` hfId + +instance Outputable HoleFit where + ppr (TcHoleFit hf) = ppr hf + ppr (RawHoleFit sd) = sd + +instance Outputable TcHoleFit where + ppr (HoleFit _ cand ty _ _ mtchs _) = + hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty)) + where name = ppr $ getName cand + holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs + +-- We compare HoleFits by their name instead of their Id, since we don't +-- want our tests to be affected by the non-determinism of `nonDetCmpVar`, +-- which is used to compare Ids. When comparing, we want HoleFits with a lower +-- refinement level to come first. +instance Ord TcHoleFit where +-- compare (RawHoleFit _) (RawHoleFit _) = EQ +-- compare (RawHoleFit _) _ = LT +-- compare _ (RawHoleFit _) = GT + compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b + where cmp = if hfRefLvl a == hfRefLvl b + then compare `on` (getName . hfCand) + else compare `on` hfRefLvl + +hfIsLcl :: TcHoleFit -> Bool +hfIsLcl hf@(HoleFit {}) = case hfCand hf of + IdHFCand _ -> True + NameHFCand _ -> False + GreHFCand gre -> gre_lcl gre + diff --git a/GHC/Tc/Errors/Hole/Plugin.hs b/GHC/Tc/Errors/Hole/Plugin.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Hole/Plugin.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE ExistentialQuantification #-} +module GHC.Tc.Errors.Hole.Plugin(CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..)) where + +import GHC.Tc.Errors.Hole.FitTypes +import GHC.Tc.Types ( TcRef, TcM ) + + +-- | A plugin for modifying the candidate hole fits *before* they're checked. +type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate] + +-- | A plugin for modifying hole fits *after* they've been found. +type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit] + +-- | A HoleFitPlugin is a pair of candidate and fit plugins. +data HoleFitPlugin = HoleFitPlugin + { candPlugin :: CandPlugin + , fitPlugin :: FitPlugin } + +-- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can +-- track internal state. Note the existential quantification, ensuring that +-- the state cannot be modified from outside the plugin. +data HoleFitPluginR = forall s. HoleFitPluginR + { hfPluginInit :: TcM (TcRef s) + -- ^ Initializes the TcRef to be passed to the plugin + , hfPluginRun :: TcRef s -> HoleFitPlugin + -- ^ The function defining the plugin itself + , hfPluginStop :: TcRef s -> TcM () + -- ^ Cleanup of state, guaranteed to be called even on error + } diff --git a/GHC/Tc/Errors/Hole/Plugin.hs-boot b/GHC/Tc/Errors/Hole/Plugin.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Hole/Plugin.hs-boot @@ -0,0 +1,6 @@ +module GHC.Tc.Errors.Hole.Plugin where + +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + +data HoleFitPlugin diff --git a/GHC/Tc/Errors/Ppr.hs b/GHC/Tc/Errors/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Ppr.hs @@ -0,0 +1,7551 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage +{-# LANGUAGE InstanceSigs #-} + +module GHC.Tc.Errors.Ppr + ( pprTypeDoesNotHaveFixedRuntimeRep + , pprScopeError + , pprErrCtxtMsg + -- + , tidySkolemInfo + , tidySkolemInfoAnon + -- + , pprHsDocContext + , inHsDocContext + , TcRnMessageOpts(..) + , pprTyThingUsedWrong + , pprUntouchableVariable + + -- + , mismatchMsg_ExpectedActuals + + -- | Useful when overriding message printing. + , messageWithInfoDiagnosticMessage + , messageWithHsDocContext + ) + where + +import GHC.Prelude + +import qualified GHC.Boot.TH.Syntax as TH +-- In stage1: import "ghc-boot-th-next" qualified GHC.Boot.TH.Syntax as TH +-- In stage2: import "ghc-boot-th" qualified GHC.Boot.TH.Syntax as TH +-- which is a rexport of +-- import "ghc-internal" qualified GHC.Internal.TH.Syntax as TH +import qualified GHC.Boot.TH.Ppr as TH + +import GHC.Builtin.Names +import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon, pretendNameIsInScope ) + +import GHC.Types.Name.Reader +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Warnings + +import GHC.Core.Coercion +import GHC.Core.Unify ( tcMatchTys ) +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.Coercion.Axiom (CoAxBranch, coAxiomTyCon, coAxiomSingleBranch) +import GHC.Core.ConLike +import GHC.Core.FamInstEnv ( FamInst(..), famInstAxiom, pprFamInst ) +import GHC.Core.InstEnv +import GHC.Core.TyCo.Rep (Type(..)) +import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon, + pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType, pprForAll) +import GHC.Core.PatSyn ( patSynName, pprPatSynType ) +import GHC.Core.TyCo.Tidy +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.FVs( orphNamesOfTypes ) +import GHC.CoreToIface + +import GHC.Driver.Flags +import GHC.Driver.Backend +import GHC.Hs hiding (HoleError) + +import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Hole.FitTypes +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.ErrCtxt +import GHC.Tc.Types.Origin hiding ( Position(..) ) +import GHC.Tc.Types.CtLoc +import GHC.Tc.Types.Rank (Rank(..)) +import GHC.Tc.Types.TH +import GHC.Tc.Utils.TcType + +import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_provenance), DefaultProvenance (..)) +import GHC.Types.Error +import GHC.Types.Error.Codes +import GHC.Types.Hint +import GHC.Types.Hint.Ppr ( pprSigLike ) -- & Outputable GhcHint +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Id.Info ( RecSelParent(..) ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Types.TyThing +import GHC.Types.TyThing.Ppr ( pprTyThingInContext ) +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Fixity (defaultFixity) + +import GHC.Iface.Errors.Types +import GHC.Iface.Errors.Ppr +import GHC.Iface.Syntax + +import GHC.Unit.State +import GHC.Unit.Module + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.List.SetOps ( nubOrdBy ) +import GHC.Data.Maybe +import GHC.Data.Pair +import GHC.Settings.Constants (mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE) +import GHC.Utils.Lexeme +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.BooleanFormula (pprBooleanFormulaNice) + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import Data.Foldable ( fold ) +import Data.Function (on) +import Data.List ( groupBy, sortBy, tails + , partition, unfoldr ) +import Data.Ord ( comparing ) +import Data.Bifunctor +import GHC.Tc.Errors.Types.PromotionErr (pprTermLevelUseCtxt) + + +defaultTcRnMessageOpts :: TcRnMessageOpts +defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True + , tcOptsIfaceOpts = defaultDiagnosticOpts @IfaceMessage } + +instance HasDefaultDiagnosticOpts TcRnMessageOpts where + defaultOpts = defaultTcRnMessageOpts + +instance Diagnostic TcRnMessage where + type DiagnosticOpts TcRnMessage = TcRnMessageOpts + diagnosticMessage opts = \case + TcRnUnknownMessage (UnknownDiagnostic f _ m) + -> diagnosticMessage (f opts) m + TcRnMessageWithInfo unit_state msg_with_info + -> case msg_with_info of + TcRnMessageDetailed err_info msg + -> messageWithInfoDiagnosticMessage unit_state err_info + (tcOptsShowContext opts) + (diagnosticMessage opts msg) + TcRnWithHsDocContext ctxt msg + -> messageWithHsDocContext opts ctxt (diagnosticMessage opts msg) + TcRnSolverReport msg _reason + -> mkSimpleDecorated $ pprSolverReportWithCtxt msg + TcRnSolverDepthError ty depth -> mkSimpleDecorated msg + where + msg = + vcat [ text "Reduction stack overflow; size =" <+> ppr depth + , hang (text "When simplifying the following type:") + 2 (ppr ty) ] + TcRnRedundantConstraints redundants (info, show_info) + -> mkSimpleDecorated $ + text "Redundant constraint" <> plural redundants <> colon + <+> pprEvVarTheta redundants + $$ if show_info then text "In" <+> ppr info else empty + TcRnInaccessibleCode implic contra + -> mkSimpleDecorated $ + hang (text "Inaccessible code in") + 2 (ppr (ic_info implic)) + $$ pprSolverReportWithCtxt contra + TcRnInaccessibleCoAxBranch fam_tc cur_branch + -> mkSimpleDecorated $ + text "Type family instance equation is overlapped:" $$ + nest 2 (pprCoAxBranchUser fam_tc cur_branch) + TcRnTypeDoesNotHaveFixedRuntimeRep ty prov err_ctxt + -> mkDecorated $ + (pprTypeDoesNotHaveFixedRuntimeRep ty prov) + : map pprErrCtxtMsg err_ctxt + TcRnImplicitLift id_or_name err_ctxt + -> mkDecorated $ + ( text "The variable" <+> quotes (ppr id_or_name) <+> + text "is implicitly lifted in the TH quotation" + ) : map pprErrCtxtMsg err_ctxt + TcRnUnusedPatternBinds bind + -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)] + TcRnDodgyImports (DodgyImportsEmptyParent gre) + -> mkDecorated [dodgy_msg (text "import") gre (dodgy_msg_insert gre)] + TcRnDodgyImports (DodgyImportsHiding reason) + -> mkSimpleDecorated $ + pprImportLookup reason + TcRnDodgyExports gre + -> mkDecorated [dodgy_msg (text "export") gre (dodgy_msg_insert gre)] + TcRnMissingImportList ie + -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+> + text "does not have an explicit import list" + ] + TcRnUnsafeDueToPlugin + -> mkDecorated [text "Use of plugins makes the module unsafe"] + TcRnModMissingRealSrcSpan mod + -> mkDecorated [text "Module does not have a RealSrcSpan:" <+> ppr mod] + TcRnIdNotExportedFromModuleSig name mod + -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+> + text "does not exist in the signature for" <+> ppr mod + ] + TcRnIdNotExportedFromLocalSig name + -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+> + text "does not exist in the local signature." + ] + TcRnShadowedName occ provenance + -> let shadowed_locs = case provenance of + ShadowedNameProvenanceLocal n -> [text "bound at" <+> ppr n] + ShadowedNameProvenanceGlobal gres -> map pprNameProvenance gres + in mkSimpleDecorated $ + sep [text "This binding for" <+> quotes (ppr occ) + <+> text "shadows the existing binding" <> plural shadowed_locs, + nest 2 (vcat shadowed_locs)] + TcRnInvalidWarningCategory cat + -> mkSimpleDecorated $ + vcat [text "Warning category" <+> quotes (ppr cat) <+> text "is not valid", + text "(user-defined category names must begin with" <+> quotes (text "x-"), + text "and contain only letters, numbers, apostrophes and dashes)" ] + TcRnDuplicateWarningDecls d rdr_name + -> mkSimpleDecorated $ + vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr (getLocA d)] + TcRnSimplifierTooManyIterations simples limit wc + -> mkSimpleDecorated $ + hang (text "solveWanteds: too many iterations" + <+> parens (text "limit =" <+> ppr limit)) + 2 (vcat [ text "Unsolved:" <+> ppr wc + , text "Simples:" <+> ppr simples + ]) + TcRnIllegalPatSynDecl rdrname + -> mkSimpleDecorated $ + hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) + 2 (text "Pattern synonym declarations are only valid at top level") + TcRnLinearPatSyn ty + -> mkSimpleDecorated $ + hang (text "Pattern synonyms do not support linear fields (GHC #18806):") 2 (ppr ty) + TcRnEmptyRecordUpdate + -> mkSimpleDecorated $ text "Empty record update" + TcRnIllegalFieldPunning fld + -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld) + TcRnIllegalWildcardsInRecord fld_part + -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part + TcRnIllegalWildcardInType mb_name bad + -> mkSimpleDecorated $ case bad of + WildcardNotLastInConstraint -> + hang notAllowed 2 constraint_hint_msg + ExtraConstraintWildcardNotAllowed allow_sole -> + case allow_sole of + SoleExtraConstraintWildcardNotAllowed -> + notAllowed + SoleExtraConstraintWildcardAllowed -> + hang notAllowed 2 sole_msg + WildcardsNotAllowedAtAll -> + notAllowed + WildcardBndrInForallTelescope -> + notAllowed + WildcardBndrInTyFamResultVar -> + notAllowed + where + notAllowed, what, wildcard, how :: SDoc + notAllowed = what <+> quotes wildcard <+> how + wildcard = case mb_name of + Nothing -> pprAnonWildCard + Just name -> ppr name + what + | Just _ <- mb_name + = text "Named wildcard" + | ExtraConstraintWildcardNotAllowed {} <- bad + = text "Extra-constraint wildcard" + | WildcardBndrInForallTelescope {} <- bad + = text "Wildcard binder" + | WildcardBndrInTyFamResultVar {} <- bad + = text "Wildcard binder" + | otherwise + = text "Wildcard" + how = case bad of + WildcardNotLastInConstraint + -> text "not allowed in a constraint" + WildcardBndrInForallTelescope + -> text "not allowed in a forall telescope" + WildcardBndrInTyFamResultVar + -> text "not allowed in a type family result" + _ -> text "not allowed" + constraint_hint_msg :: SDoc + constraint_hint_msg + | Just _ <- mb_name + = vcat [ text "Extra-constraint wildcards must be anonymous" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + | otherwise + = vcat [ text "except as the last top-level constraint of a type signature" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + sole_msg :: SDoc + sole_msg = + vcat [ text "except as the sole constraint" + , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ] + TcRnIllegalNamedWildcardInTypeArgument rdr + -> mkSimpleDecorated $ + hang (text "Illegal named wildcard in a required type argument:") + 2 (quotes (ppr rdr)) + TcRnIllegalImplicitTyVarInTypeArgument rdr + -> mkSimpleDecorated $ + hang (text "Illegal implicitly quantified type variable in a required type argument:") + 2 (quotes (ppr rdr)) + TcRnIllegalPunnedVarOccInTypeArgument n1 n2 + -> mkSimpleDecorated $ hang msg 2 info + where + msg = vcat [ text "Illegal punned variable occurrence in a required type argument." + , text "The name" <+> quotes (ppr n1) <+> text "could refer to:" ] + info = vcat [ quotes (ppr n1) <+> pprResolvedNameProvenance n1 + , quotes (ppr n2) <+> pprResolvedNameProvenance n2 ] + TcRnDuplicateFieldName fld_part dups + -> mkSimpleDecorated $ + hsep [ text "Duplicate field name" + , quotes (ppr (rdrNameOcc $ NE.head dups)) + , text "in record", pprRecordFieldPart fld_part ] + TcRnIllegalViewPattern pat + -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat] + TcRnCharLiteralOutOfRange c + -> mkSimpleDecorated $ text "character literal out of range: '\\" <> char c <> char '\'' + TcRnIllegalWildcardsInConstructor con + -> mkSimpleDecorated $ + vcat [ text "Illegal `{..}' notation for constructor" <+> quotes (ppr con) + , nest 2 (text "Record wildcards may not be used for constructors with unlabelled fields.") + , nest 2 (text "Possible fix: Remove the `{..}' and add a match for each field of the constructor.") + ] + TcRnIgnoringAnnotations anns + -> mkSimpleDecorated $ + text "Ignoring ANN annotation" <> plural anns <> comma + <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi" + TcRnAnnotationInSafeHaskell + -> mkSimpleDecorated $ + vcat [ text "Annotations are not compatible with Safe Haskell." + , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] + TcRnInvalidTypeApplication fun_ty hs_ty + -> mkSimpleDecorated $ + text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$ + text "to a visible type argument" <+> quotes (ppr hs_ty) + TcRnTagToEnumMissingValArg + -> mkSimpleDecorated $ + text "tagToEnum# must appear applied to one value argument" + TcRnTagToEnumUnspecifiedResTy ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (vcat [ text "Specify the type by giving a type signature" + , text "e.g. (tagToEnum# x) :: Bool" ]) + TcRnTagToEnumResTyNotAnEnum ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (text "Result type must be an enumeration type") + TcRnTagToEnumResTyTypeData ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (text "Result type cannot be headed by a `type data` type") + TcRnArrowIfThenElsePredDependsOnResultTy + -> mkSimpleDecorated $ + text "Predicate type of `ifThenElse' depends on result type" + TcRnIllegalHsBootOrSigDecl boot_or_sig decls + -> mkSimpleDecorated $ + text "Illegal" <+> what <+> text "in" <+> whr <> dot + where + what = case decls of + BootBindsPs {} -> text "binding" + BootBindsRn {} -> text "binding" + BootInstanceSigs {} -> text "instance body" + BootFamInst {} -> text "family instance" + BootSpliceDecls {} -> text "splice" + BootForeignDecls {} -> text "foreign declaration" + BootDefaultDecls {} -> text "default declaration" + BootRuleDecls {} -> text "RULE pragma" + whr = case boot_or_sig of + HsBoot -> text "an hs-boot file" + Hsig -> text "a backpack signature file" + TcRnBootMismatch boot_or_sig err -> + mkSimpleDecorated $ pprBootMismatch boot_or_sig err + TcRnRecursivePatternSynonym binds + -> mkSimpleDecorated $ + hang (text "Recursive pattern synonym definition with following bindings:") + 2 (vcat $ map pprLBind binds) + where + pprLoc loc = parens (text "defined at" <+> ppr loc) + pprLBind :: CollectPass GhcRn => GenLocated (EpAnn a) (HsBindLR GhcRn idR) -> SDoc + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) + <+> pprLoc (locA loc) + TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty + -> mkSimpleDecorated $ + hang (text "Couldn't match" <+> quotes (ppr n1) + <+> text "with" <+> quotes (ppr n2)) + 2 (hang (text "both bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) + TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty + -> mkSimpleDecorated $ + hang (text "Can't quantify over" <+> quotes (ppr n)) + 2 (vcat [ hang (text "bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty) + , extra ]) + where + extra | Just rhs_ty <- m_unif_ty + = sep [ quotes (ppr n), text "should really be", quotes (ppr rhs_ty) ] + | otherwise + = empty + TcRnMissingSignature what _ -> + mkSimpleDecorated $ + case what of + MissingPatSynSig p -> + hang (text "Pattern synonym with no type signature:") + 2 (text "pattern" <+> pprPrefixName (patSynName p) <+> dcolon <+> pprPatSynType p) + MissingTopLevelBindingSig name ty -> + hang (text "Top-level binding with no type signature:") + 2 (pprPrefixName name <+> dcolon <+> pprSigmaType ty) + MissingTyConKindSig tc cusks_enabled -> + hang msg + 2 (text "type" <+> pprPrefixName (tyConName tc) <+> dcolon <+> pprKind (tyConKind tc)) + where + msg | cusks_enabled + = text "Top-level type constructor with no standalone kind signature or CUSK:" + | otherwise + = text "Top-level type constructor with no standalone kind signature:" + + TcRnPolymorphicBinderMissingSig n ty + -> mkSimpleDecorated $ + sep [ text "Polymorphic local binding with no type signature:" + , nest 2 $ pprPrefixName n <+> dcolon <+> ppr ty ] + TcRnOverloadedSig sig + -> mkSimpleDecorated $ + hang (text "Overloaded signature conflicts with monomorphism restriction") + 2 (ppr sig) + TcRnTupleConstraintInst _ + -> mkSimpleDecorated $ text "You can't specify an instance for a tuple constraint" + TcRnUserTypeError ty + -> mkSimpleDecorated (pprUserTypeErrorTy ty) + TcRnConstraintInKind ty + -> mkSimpleDecorated $ + text "Illegal constraint in a kind:" <+> pprType ty + TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum ty + -> mkSimpleDecorated $ + sep [ text "Illegal unboxed" <+> what <+> text "type as function argument:" + , pprType ty ] + where + what = case tuple_or_sum of + UnboxedTupleType -> text "tuple" + UnboxedSumType -> text "sum" + TcRnLinearFuncInKind ty + -> mkSimpleDecorated $ + text "Illegal linear function in a kind:" <+> pprType ty + TcRnForAllEscapeError ty kind + -> mkSimpleDecorated $ vcat + [ hang (text "Quantified type's kind mentions quantified type variable") + 2 (text "type:" <+> quotes (ppr ty)) + , hang (text "where the body of the forall has this kind:") + 2 (quotes (pprKind kind)) ] + TcRnSimplifiableConstraint pred what + -> mkSimpleDecorated $ vcat + [ hang (text "The constraint" <+> quotes (pprType pred) <+> text "matches") + 2 (ppr what) + , hang (text "This makes type inference for inner bindings fragile;") + 2 (text "either use MonoLocalBinds, or simplify it using the instance") ] + TcRnArityMismatch thing thing_arity nb_args + -> mkSimpleDecorated $ + hsep [ text "The" <+> what, quotes (ppr $ getName thing), text "should have" + , n_arguments <> comma, text "but has been given" + , if nb_args == 0 then text "none" else int nb_args + ] + where + what = case thing of + ATyCon tc -> ppr (tyConFlavour tc) + _ -> text (tyThingCategory thing) + n_arguments | thing_arity == 0 = text "no arguments" + | thing_arity == 1 = text "1 argument" + | True = hsep [int thing_arity, text "arguments"] + TcRnIllegalInstance reason -> + mkSimpleDecorated $ pprIllegalInstance reason + TcRnVDQInTermType mb_ty + -> mkSimpleDecorated $ + case mb_ty of + Nothing -> main_msg + Just ty -> hang (main_msg <> char ':') 2 (pprType ty) + where + main_msg = + text "Illegal visible, dependent quantification" <+> + text "in the type of a term" + TcRnBadQuantPredHead ty + -> mkSimpleDecorated $ + hang (text "Quantified predicate must have a class or type variable head:") + 2 (pprType ty) + TcRnIllegalTupleConstraint ty + -> mkSimpleDecorated $ + text "Illegal tuple constraint:" <+> pprType ty + TcRnNonTypeVarArgInConstraint ty + -> mkSimpleDecorated $ + hang (text "Non type-variable argument") + 2 (text "in the constraint:" <+> pprType ty) + TcRnIllegalImplicitParam ty + -> mkSimpleDecorated $ + text "Illegal implicit parameter" <+> quotes (pprType ty) + TcRnIllegalConstraintSynonymOfKind kind + -> mkSimpleDecorated $ + text "Illegal constraint synonym of kind:" <+> quotes (pprKind kind) + TcRnOversaturatedVisibleKindArg ty + -> mkSimpleDecorated $ + text "Illegal oversaturated visible kind argument:" <+> + quotes (char '@' <> pprParendType ty) + TcRnForAllRankErr rank ty + -> let herald = case tcSplitForAllTyVars ty of + ([], _) -> text "Illegal qualified type:" + _ -> text "Illegal polymorphic type:" + extra = case rank of + MonoTypeConstraint -> text "A constraint must be a monotype" + _ -> empty + in mkSimpleDecorated $ vcat [hang herald 2 (pprType ty), extra] + TcRnMonomorphicBindings bindings + -> let pp_bndrs = pprBindings bindings + in mkSimpleDecorated $ + sep [ text "The Monomorphism Restriction applies to the binding" + <> plural bindings + , text "for" <+> pp_bndrs ] + TcRnOrphanInstance (Left cls_inst) + -> mkSimpleDecorated $ + hang (text "Orphan class instance:") + 2 (pprInstanceHdr cls_inst) + TcRnOrphanInstance (Right fam_inst) + -> mkSimpleDecorated $ + hang (text "Orphan family instance:") + 2 (pprFamInst fam_inst) + TcRnFunDepConflict unit_state sorted + -> let herald = text "Functional dependencies conflict between instance declarations:" + in mkSimpleDecorated $ + pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted)) + TcRnDupInstanceDecls unit_state sorted + -> let herald = text "Duplicate instance declarations:" + in mkSimpleDecorated $ + pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted)) + TcRnConflictingFamInstDecls sortedNE + -> let sorted = NE.toList sortedNE + in mkSimpleDecorated $ + hang (text "Conflicting family instance declarations:") + 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) + | fi <- sorted + , let ax = famInstAxiom fi ]) + TcRnFamInstNotInjective rea fam_tc (eqn1 NE.:| rest_eqns) + -> let (herald, show_kinds) = case rea of + InjErrRhsBareTyVar tys -> + (injectivityErrorHerald $$ + text "RHS of injective type family equation is a bare" <+> + text "type variable" $$ + text "but these LHS type and kind patterns are not bare" <+> + text "variables:" <+> pprQuotedList tys, False) + InjErrRhsCannotBeATypeFam -> + (injectivityErrorHerald $$ + text "RHS of injective type family equation cannot" <+> + text "be a type family:", False) + InjErrRhsOverlap -> + (text "Type family equation right-hand sides overlap; this violates" $$ + text "the family's injectivity annotation:", False) + InjErrCannotInferFromRhs tvs has_kinds _ -> + let show_kinds = has_kinds == YesHasKinds + what = if show_kinds then text "Type/kind" else text "Type" + body = sep [ what <+> text "variable" <> + pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) + , text "cannot be inferred from the right-hand side." ] + in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds) + + in mkSimpleDecorated $ pprWithInvisibleBitsWhen show_kinds $ + hang herald + 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) + TcRnBangOnUnliftedType ty + -> mkSimpleDecorated $ + text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty) + TcRnLazyBangOnUnliftedType ty + -> mkSimpleDecorated $ + text "Lazy flag has no effect on unlifted type" <+> quotes (ppr ty) + TcRnMultipleDefaultDeclarations cls dup_things + -> mkSimpleDecorated $ + hang (text "Multiple default declarations for class" <+> quotes (ppr cls)) + 2 (pp dup_things) + where + pp :: ClassDefaults -> SDoc + pp (ClassDefaults { cd_provenance = prov }) + = case prov of + DP_Local { defaultDeclLoc = loc, defaultDeclH98 = isH98 } + -> let + what = + if isH98 + then text "default declaration" + else text "named default declaration" + in text "conflicting" <+> what <+> text "at:" <+> ppr loc + _ -> empty -- doesn't happen, as local defaults override imported and built-in defaults + TcRnBadDefaultType ty deflt_clss + -> mkSimpleDecorated $ + hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") + 2 (foldr1 (\a b -> a <+> text "or" <+> b) (NE.map (quotes. ppr) deflt_clss)) + TcRnPatSynBundledWithNonDataCon + -> mkSimpleDecorated $ + text "Pattern synonyms can be bundled only with datatypes." + TcRnPatSynBundledWithWrongType expected_res_ty res_ty + -> mkSimpleDecorated $ + text "Pattern synonyms can only be bundled with matching type constructors" + $$ text "Couldn't match expected type of" + <+> quotes (ppr expected_res_ty) + <+> text "with actual type of" + <+> quotes (ppr res_ty) + TcRnDupeModuleExport mod + -> mkSimpleDecorated $ + hsep [ text "Duplicate" + , quotes (text "Module" <+> ppr mod) + , text "in export list" ] + TcRnExportedModNotImported mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "is not imported" + TcRnNullExportedModule mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "exports nothing" + TcRnMissingExportList mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "is missing an export list" + TcRnExportHiddenComponents export_item + -> mkSimpleDecorated + $ formatExportItemError + (ppr export_item) + "attempts to export constructors or class methods that are not visible here" + TcRnExportHiddenDefault export_item + -> mkSimpleDecorated + $ formatExportItemError + (ppr export_item) + "attempts to export a default class declaration that is not visible here" + TcRnDuplicateExport gre ie1 ie2 + -> mkSimpleDecorated $ + hsep [ quotes (ppr $ greName gre) + , text "is exported by", quotes (ppr ie1) + , text "and", quotes (ppr ie2) ] + TcRnDuplicateNamedDefaultExport nm ie1 ie2 + -> mkSimpleDecorated $ + hsep [ text "The named default declaration for" <+> quotes (ppr nm) + , text "is exported by", quotes (ppr ie1) + , text "and", quotes (ppr ie2) ] + TcRnExportedParentChildMismatch parent_name ty_thing child parent_names + -> mkSimpleDecorated $ + text "The type constructor" <+> quotes (ppr parent_name) + <+> text "is not the parent of the" <+> text what_is + <+> quotes thing <> char '.' + $$ text (capitalise what_is) + <> text "s can only be exported with their parent type constructor." + $$ (case parents of + [] -> empty + [_] -> text "Parent:" + _ -> text "Parents:") <+> fsep (punctuate comma parents) + where + pp_category :: TyThing -> String + pp_category (AnId i) + | isRecordSelector i = "record selector" + pp_category i = tyThingCategory i + what_is = pp_category ty_thing + thing = ppr $ nameOccName child + parents = map ppr parent_names + TcRnConflictingExports occ child_gre1 ie1 child_gre2 ie2 + -> mkSimpleDecorated $ + vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon + , ppr_export child_gre1 ie1 + , ppr_export child_gre2 ie2 + ] + where + ppr_export gre ie = + nest 3 $ + hang (quotes (ppr ie) <+> text "exports" <+> quotes (ppr $ greName gre)) + 2 (pprNameProvenance gre) + TcRnDuplicateFieldExport (gre, ie1) gres_ies -> + mkSimpleDecorated $ + vcat ( hsep [ text "Duplicate record field" + , quotes (ppr $ greOccName gre) + , text "in export list" <> colon ] + : map ppr_export ((gre,ie1) : NE.toList gres_ies) + ) + where + ppr_export (gre,ie) = + nest 3 $ + hang (sep [ quotes (ppr ie) <+> text "exports the field" <+> quotes (ppr $ greName gre) + , text "belonging to the constructor" <> plural fld_cons <+> pprQuotedList fld_cons ]) + 2 (pprNameProvenance gre) + where + fld_cons :: [ConLikeName] + fld_cons = nonDetEltsUniqSet $ recFieldCons $ fieldGREInfo gre + TcRnAmbiguousFieldInUpdate (gre1, gre2, gres) + -> mkSimpleDecorated $ + vcat [ text "Ambiguous record field" <+> fld <> dot + , hang (text "It could refer to any of the following:") + 2 $ vcat (map pprSugg (gre1 : gre2 : gres)) + ] + where + fld = quotes $ ppr (occNameFS $ greOccName gre1) + pprSugg gre = vcat [ bullet <+> pprGRE gre <> comma + , nest 2 (pprNameProvenance gre) ] + pprGRE gre = case greInfo gre of + IAmRecField {} + | ParentIs { par_is = parent } <- greParent gre + -> text "record field" <+> fld <+> text "of" <+> quotes (ppr parent) + _ -> text "variable" <+> fld + TcRnAmbiguousRecordUpdate _rupd tc + -> mkSimpleDecorated $ + vcat [ text "Ambiguous record update with parent" <+> what <> dot + , hsep [ text "This type-directed disambiguation mechanism" + , text "will not be supported by -XDuplicateRecordFields in future releases of GHC." ] + , text "Consider disambiguating using module qualification instead." + ] + where + what :: SDoc + what = text "type constructor" <+> quotes (ppr $ RecSelData tc) + TcRnMissingFields con fields + -> mkSimpleDecorated $ vcat [header, nest 2 rest] + where + rest | null fields = empty + | otherwise = vcat (fmap pprField fields) + header = text "Fields of" <+> quotes (ppr con) <+> + text "not initialised" <> + if null fields then empty else colon + TcRnFieldUpdateInvalidType prs + -> mkSimpleDecorated $ + hang (text "Record update for insufficiently polymorphic field" + <> plural prs <> colon) + 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) + TcRnMissingStrictFields con fields + -> mkSimpleDecorated $ vcat [header, nest 2 rest] + where + rest | null fields = empty -- Happens for non-record constructors + -- with strict fields + | otherwise = vcat (fmap pprField fields) + + header = text "Constructor" <+> quotes (ppr con) <+> + text "does not have the required strict field(s)" <> + if null fields then empty else colon + TcRnBadRecordUpdate upd_flds reason + -> case reason of + NoConstructorHasAllFields { conflictingFields = conflicts } + | [fld] <- conflicts + -> mkSimpleDecorated $ + vcat [ header + , text "No constructor in scope has the field" <+> quotes (ppr fld) ] + | otherwise + -> + mkSimpleDecorated $ + vcat [ header + , hang (text "No constructor in scope has all of the following fields:") + 2 (pprQuotedList conflicts) ] + where + header :: SDoc + header = text "Invalid record update." + MultiplePossibleParents (par1, par2, pars) -> + mkSimpleDecorated $ + vcat [ hang (text "Ambiguous record update with field" <> plural upd_flds) + 2 ppr_flds + , hang (thisOrThese upd_flds <+> text "field" <> plural upd_flds <+> what_parent) + 2 (quotedListWithAnd (map ppr (par1:par2:pars))) ] + where + ppr_flds, what_parent, which :: SDoc + ppr_flds = quotedListWithAnd $ map ppr upd_flds + what_parent = case par1 of + RecSelData {} -> text "appear" <> singular upd_flds + <+> text "in" <+> which <+> text "datatypes" + RecSelPatSyn {} -> isOrAre upd_flds <+> text "associated with" + <+> which <+> text "pattern synonyms" + which = case pars of + [] -> text "both" + _ -> text "all of the" + InvalidTyConParent tc pars -> + mkSimpleDecorated $ + vcat [ hang (text "No data constructor of" <+> what $$ text "has all of the fields:") + 2 (pprQuotedList upd_flds) + , pat_syn_msg ] + where + what = text "type constructor" <+> quotes (ppr (RecSelData tc)) + pat_syn_msg + | any (\case { RecSelPatSyn {} -> True; _ -> False}) pars + = note "Type-directed disambiguation is not supported for pattern synonym record fields" + | otherwise + = empty + TcRnStaticFormNotClosed name reason + -> mkSimpleDecorated $ + quotes (ppr name) + <+> text "is used in a static form but it is not closed" + <+> text "because it" + $$ sep (causes reason) + where + causes :: NotClosedReason -> [SDoc] + causes NotLetBoundReason = [text "is not let-bound."] + causes (NotTypeClosed vs) = + [ text "has a non-closed type because it contains the" + , text "type variables:" <+> + pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) + ] + causes (NotClosed n reason) = + let msg = text "uses" <+> quotes (ppr n) <+> text "which" + in case reason of + NotClosed _ _ -> msg : causes reason + _ -> let (xs0, xs1) = splitAt 1 $ causes reason + in fmap (msg <+>) xs0 ++ xs1 + TcRnUselessTypeable + -> mkSimpleDecorated $ + text "Deriving" <+> quotes (ppr typeableClassName) <+> + text "has no effect: all types now auto-derive Typeable" + TcRnDerivingDefaults cls + -> mkSimpleDecorated $ sep + [ text "Both DeriveAnyClass and" + <+> text "GeneralizedNewtypeDeriving are enabled" + , text "Defaulting to the DeriveAnyClass strategy" + <+> text "for instantiating" <+> ppr cls + ] + TcRnNonUnaryTypeclassConstraint ctxt ct + -> mkSimpleDecorated $ + quotes (ppr ct) + <+> text "is not a unary constraint, as expected by" + <+> pprUserTypeCtxt ctxt + TcRnPartialTypeSignatures _ theta + -> mkSimpleDecorated $ + text "Found type wildcard" <+> quotes (char '_') + <+> text "standing for" <+> quotes (pprTheta theta) + TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason + -> mkSimpleDecorated $ + derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason + TcRnLookupInstance cls tys reason + -> mkSimpleDecorated $ + text "Couldn't match instance:" <+> + lookupInstanceErrDiagnosticMessage cls tys reason + TcRnLazyGADTPattern + -> mkSimpleDecorated $ + hang (text "An existential or GADT data constructor cannot be used") + 2 (text "inside a lazy (~) pattern") + TcRnArrowProcGADTPattern + -> mkSimpleDecorated $ + text "Proc patterns cannot use existential or GADT data constructors" + TcRnTypeEqualityOutOfScope + -> mkDecorated + [ text "The" <+> quotes (text "~") <+> text "operator is out of scope." $$ + text "Assuming it to stand for an equality constraint." + , note $ quotes "~" <+> "used to be built-in syntax but now is a regular type operator" $$ + "exported from Data.Type.Equality and Prelude." $$ + "If you are using a custom Prelude, consider re-exporting it" + , text "This will become an error in a future GHC release." ] + TcRnTypeEqualityRequiresOperators + -> mkSimpleDecorated $ + fsep [ text "The use of" <+> quotes (text "~") + <+> text "without TypeOperators", + text "will become an error in a future GHC release." ] + TcRnIllegalTypeOperator overall_ty op + -> mkSimpleDecorated $ + text "Illegal operator" <+> quotes (ppr op) <+> + text "in type" <+> quotes (ppr overall_ty) + TcRnIllegalTypeOperatorDecl name + -> mkSimpleDecorated $ + text "Illegal declaration of a type or class operator" <+> quotes (ppr name) + TcRnGADTMonoLocalBinds + -> mkSimpleDecorated $ + fsep [ text "Pattern matching on GADTs without MonoLocalBinds" + , text "is fragile." ] + TcRnIncorrectNameSpace name _in_th_tick + -> mkSimpleDecorated $ + text "The" <+> what <+> text "does not live in" <+> other_ns + where + -- the other (opposite) namespace + other_ns | isValNameSpace ns = text "the type-level namespace" + | otherwise = text "the term-level namespace" + ns = nameNameSpace name + what = pprNameSpace ns <+> quotes (ppr name) + TcRnNotInScope err name + -> mkSimpleDecorated $ pprScopeError name err + TcRnTermNameInType name + -> mkSimpleDecorated $ + quotes (ppr name) <+> + (text "is a term-level binding") $+$ + (text " and can not be used at the type level.") + TcRnUntickedPromotedThing thing + -> mkSimpleDecorated $ + text "Unticked promoted" <+> what + where + what :: SDoc + what = case thing of + UntickedExplicitList -> text "list" <> dot + UntickedConstructor fixity nm -> + let con = pprUntickedConstructor fixity nm + bare_sym = isBareSymbol fixity nm + in text "constructor:" <+> con <> if bare_sym then empty else dot + TcRnIllegalBuiltinSyntax sig rdr_name + -> mkSimpleDecorated $ + hsep [text "Illegal", pprSigLike sig, text "of built-in syntax:", ppr rdr_name] + TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty + -> mkSimpleDecorated $ + hang (hsep $ [ text "Defaulting" ] + ++ + (case tidy_tv of + Nothing -> [] + Just tv -> [text "the type variable" + , quotes (ppr tv)]) + ++ + [ text "to type" + , quotes (ppr default_ty) + , text "in the following constraint" <> plural tidy_wanteds ]) + 2 + (pprWithArising tidy_wanteds) + TcRnWarnClashingDefaultImports cls Nothing imports + -> mkSimpleDecorated $ + hang (text "Clashing imported defaults for class" <+> quotes (ppr cls) <> colon) + 2 (vcat $ defaultTypesAndImport <$> NE.toList imports) + TcRnWarnClashingDefaultImports cls (Just local) imports + -> mkSimpleDecorated $ + sep [ hang (text "Imported defaults for class" <+> quotes (ppr cls) <> colon) + 2 (vcat $ defaultTypesAndImport <$> NE.toList imports) + , hang (text "are not subsumed by the local `default` declaration") + 2 (parens $ pprWithCommas ppr local) + ] + + TcRnForeignImportPrimExtNotSet _decl + -> mkSimpleDecorated $ + text "`foreign import prim' requires GHCForeignImportPrim." + + TcRnForeignImportPrimSafeAnn _decl + -> mkSimpleDecorated $ + text "The safe/unsafe annotation should not be used with `foreign import prim'." + + TcRnForeignFunctionImportAsValue _decl + -> mkSimpleDecorated $ + text "`value' imports cannot have function types" + + TcRnFunPtrImportWithoutAmpersand _decl + -> mkSimpleDecorated $ + text "possible missing & in foreign import of FunPtr" + + TcRnIllegalForeignDeclBackend _decl _backend expectedBknds + -> mkSimpleDecorated $ + fsep (text "Illegal foreign declaration: requires one of these back ends:" : + commafyWith (text "or") (map (text . backendDescription) expectedBknds)) + + TcRnUnsupportedCallConv _decl unsupportedCC + -> mkSimpleDecorated $ + case unsupportedCC of + StdCallConvUnsupported -> + text "the 'stdcall' calling convention is unsupported on this platform," + $$ text "treating as ccall" + PrimCallConvUnsupported -> + text "The `prim' calling convention can only be used with `foreign import'" + JavaScriptCallConvUnsupported -> + text "The `javascript' calling convention is unsupported on this platform" + + TcRnIllegalForeignType mArgOrResult reason + -> mkSimpleDecorated $ hang msg 2 extra + where + arg_or_res = case mArgOrResult of + Nothing -> empty + Just Arg -> text "argument" + Just Result -> text "result" + msg = hsep [ text "Unacceptable", arg_or_res + , text "type in foreign declaration:"] + extra = + case reason of + TypeCannotBeMarshaled ty why -> + let innerMsg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" + in case why of + NotADataType -> + quotes (ppr ty) <+> text "is not a data type" + NewtypeDataConNotInScope _ [] -> + hang innerMsg 2 $ text "because its data constructor is not in scope" + NewtypeDataConNotInScope tc _ -> + hang innerMsg 2 $ + text "because the data constructor for" + <+> quotes (ppr tc) <+> text "is not in scope" + UnliftedFFITypesNeeded -> + innerMsg $$ text "UnliftedFFITypes is required to marshal unlifted types" + NotABoxedMarshalableTyCon -> innerMsg + ForeignLabelNotAPtr -> + innerMsg $$ text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)" + NotSimpleUnliftedType -> + innerMsg $$ text "foreign import prim only accepts simple unlifted types" + NotBoxedKindAny -> + text "Expected kind" <+> quotes (text "Type") <+> text "or" <+> quotes (text "UnliftedType") <> comma $$ + text "but" <+> quotes (ppr ty) <+> text "has kind" <+> quotes (ppr (typeKind ty)) + ForeignDynNotPtr expected ty -> + vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma, text " Actual:" <+> ppr ty ] + SafeHaskellMustBeInIO -> + text "Safe Haskell is on, all FFI imports must be in the IO monad" + IOResultExpected -> + text "IO result type expected" + UnexpectedNestedForall -> + text "Unexpected nested forall" + LinearTypesNotAllowed -> + text "Linear types are not supported in FFI declarations, see #18472" + OneArgExpected -> + text "One argument expected" + AtLeastOneArgExpected -> + text "At least one argument expected" + TcRnInvalidCIdentifier target + -> mkSimpleDecorated $ + sep [quotes (ppr target) <+> text "is not a valid C identifier"] + TcRnExpectedValueId thing + -> mkSimpleDecorated $ + ppr thing <+> text "used where a value identifier was expected" + TcRnRecSelectorEscapedTyVar lbl + -> mkSimpleDecorated $ + text "Cannot use record selector" <+> quotes (ppr lbl) <+> + text "as a function due to escaped type variables" + TcRnPatSynNotBidirectional name + -> mkSimpleDecorated $ + text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" + TcRnIllegalDerivingItem hs_ty + -> mkSimpleDecorated $ + text "Illegal deriving item" <+> quotes (ppr hs_ty) + TcRnIllegalDefaultClass nm + -> mkSimpleDecorated $ + text "Illegal named default declaration for non-class" <+> quotes (ppr nm) + TcRnIllegalNamedDefault hs_decl + -> mkSimpleDecorated $ text "Illegal named default declaration" <+> quotes (ppr hs_decl) + TcRnUnexpectedAnnotation ty bang + -> mkSimpleDecorated $ + let err = case bang of + HsSrcBang _ SrcUnpack _ -> "UNPACK" + HsSrcBang _ SrcNoUnpack _ -> "NOUNPACK" + HsSrcBang _ NoSrcUnpack SrcLazy -> "laziness (~)" + HsSrcBang _ _ _ -> "strictness (!)" + in text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ + text err <+> text "annotation can only appear on the arguments of a data constructor type" + TcRnIllegalRecordSyntax ty + -> mkSimpleDecorated $ + text "Record syntax is illegal here:" <+> ppr ty + + TcRnInvalidVisibleKindArgument arg ty + -> mkSimpleDecorated $ + text "Cannot apply function of kind" <+> quotes (ppr ty) + $$ text "to visible kind argument" <+> quotes (ppr arg) + TcRnTooManyBinders ki bndrs + -> mkSimpleDecorated $ + hang (text "Not a function kind:") + 4 (ppr ki) $$ + hang (text "but extra binders found:") + 4 (fsep (map ppr bndrs)) + TcRnDifferentNamesForTyVar n1 n2 + -> mkSimpleDecorated $ + 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) ] + + TcRnDisconnectedTyVar n + -> mkSimpleDecorated $ + hang (text "Scoped type variable only appears non-injectively in declaration header:") + 2 (quotes (ppr n) <+> text "bound at" <+> ppr (getSrcLoc n)) + + TcRnInvalidReturnKind data_sort allowed_kind kind _suggested_ext + -> mkSimpleDecorated $ + sep [ ppDataSort data_sort <+> + text "has non-" <> + allowed_kind_tycon + , (if is_data_family then text "and non-variable" else empty) <+> + text "return kind" <+> quotes (ppr kind) + ] + where + is_data_family = + case data_sort of + DataDeclSort{} -> False + DataInstanceSort{} -> False + DataFamilySort -> True + allowed_kind_tycon = + case allowed_kind of + AnyTYPEKind -> ppr tYPETyCon + AnyBoxedKind -> ppr boxedRepDataConTyCon + LiftedKind -> ppr liftedTypeKind + TcRnClassKindNotConstraint _kind + -> mkSimpleDecorated $ + text "Kind signature on a class must end with" <+> ppr constraintKind $$ + text "unobscured by type families" + TcRnUnpromotableThing name err + -> mkSimpleDecorated $ + (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") + 2 (parens reason)) + where + reason = case err of + ConstrainedDataConPE theta + -> text "it has an unpromotable context" + <+> quotes (pprTheta theta) + + FamDataConPE -> text "it comes from a data family instance" + PatSynPE -> text "pattern synonyms cannot be promoted" + RecDataConPE -> same_rec_group_msg + ClassPE -> same_rec_group_msg + TyConPE -> same_rec_group_msg + TermVariablePE -> text "term variables cannot be promoted" + TypeVariablePE -> text "type variables bound in a kind signature cannot be used in the type" + same_rec_group_msg = text "it is defined and used in the same recursive group" + TcRnIllegalTermLevelUse simple_msg rdr name err + -> mkSimpleDecorated $ + if simple_msg + then + vcat [ expecting_what <+> text "out of scope:" <+> quotes (ppr rdr) <> dot + , "NB: the" <+> text (teCategory err) <+> quotes (ppr qnm) <+> "cannot appear in this position." + ] + else + text "Illegal term-level use of the" <+> + text (teCategory err) <+> quotes (ppr qnm) + where + expecting_what = case err of + TyVarTE -> "Term variable" + ClassTE -> "Data constructor" + TyConTE -> "Data constructor" + qnm = WithUserRdr rdr name + TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches) + -> mkSimpleDecorated $ + (vcat [ pprMatchContextNouns argsContext <+> + text "have different numbers of arguments" + , nest 2 (ppr (getLocA match1)) + , nest 2 (ppr (getLocA (NE.head bad_matches)))]) + TcRnCannotBindScopedTyVarInPatSig sig_tvs + -> mkSimpleDecorated $ + hang (text "You cannot bind scoped type variable" + <> plural (NE.toList sig_tvs) + <+> pprQuotedList (map fst $ NE.toList sig_tvs)) + 2 (text "in a pattern binding signature") + TcRnCannotBindTyVarsInPatBind _offenders + -> mkSimpleDecorated $ + text "Binding type variables is not allowed in pattern bindings" + TcRnMultipleInlinePragmas poly_id fst_inl_prag inl_prags + -> mkSimpleDecorated $ + hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + 2 (vcat (text "Ignoring all but the first" + : map pp_inl (fst_inl_prag : NE.toList inl_prags))) + where + pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) + TcRnUnexpectedPragmas poly_id bad_sigs + -> mkSimpleDecorated $ + hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) + 2 (vcat (map (ppr . getLoc) $ NE.toList bad_sigs)) + TcRnNonOverloadedSpecialisePragma fun_name + -> mkSimpleDecorated $ + text "SPECIALISE pragma for non-overloaded function" + <+> quotes (ppr fun_name) + TcRnSpecialiseNotVisible name + -> mkSimpleDecorated $ + text "You cannot SPECIALISE" <+> quotes (ppr name) + <+> text "because its definition is not visible in this module" + TcRnPragmaWarning + { pragma_warning_info = PragmaWarningInstance{pwarn_dfunid, pwarn_ctorig} + , pragma_warning_msg } + -> mkSimpleDecorated $ + sep [ hang (text "In the use of") + 2 (pprDFunId pwarn_dfunid) + , ppr pwarn_ctorig + , pprWarningTxtForMsg pragma_warning_msg + ] + TcRnPragmaWarning + { pragma_warning_info = PragmaWarningDefault{pwarn_class, pwarn_impmod} + , pragma_warning_msg } + -> mkSimpleDecorated $ + sep [ sep [ text "In the use of class" + <+> ppr pwarn_class + <+> text "defaults imported from" + <+> ppr pwarn_impmod <> colon ] + , pprWarningTxtForMsg pragma_warning_msg + ] + TcRnPragmaWarning {pragma_warning_info, pragma_warning_msg} + -> mkSimpleDecorated $ + sep [ sep [ text "In the use of" + <+> pprNonVarNameSpace (occNameSpace occ_name) + <+> quotes (ppr occ_name) + , parens imp_msg <> colon ] + , pprWarningTxtForMsg pragma_warning_msg ] + where + occ_name = pwarn_occname pragma_warning_info + imp_mod = pwarn_impmod pragma_warning_info + imp_msg = text "imported from" <+> ppr imp_mod <> extra + extra | PragmaWarningName {pwarn_declmod = decl_mod} <- pragma_warning_info + , imp_mod /= decl_mod = text ", but defined in" <+> ppr decl_mod + | otherwise = empty + TcRnDifferentExportWarnings name locs + -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "exported with different error messages", + text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)] + TcRnIncompleteExportWarnings name locs + -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "will not have its export warned about", + text "missing export warning at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)] + TcRnIllegalHsigDefaultMethods name meths + -> mkSimpleDecorated $ + text "Illegal default method" <> plural (NE.toList meths) <+> text "in class definition of" <+> ppr name <+> text "in hsig file" + TcRnHsigFixityMismatch real_thing real_fixity sig_fixity + -> + let ppr_fix f = ppr f <+> if f == defaultFixity then parens (text "default") else empty + in mkSimpleDecorated $ + vcat [ppr real_thing <+> text "has conflicting fixities in the module", + text "and its hsig file", + text "Main module:" <+> ppr_fix real_fixity, + text "Hsig file:" <+> ppr_fix sig_fixity] + TcRnHsigShapeMismatch (HsigShapeSortMismatch info1 info2) + -> mkSimpleDecorated $ + text "While merging export lists, could not combine" + <+> ppr info1 <+> text "with" <+> ppr info2 + <+> parens (text "one is a type, the other is a plain identifier") + TcRnHsigShapeMismatch (HsigShapeNotUnifiable name1 name2 notHere) + -> + let extra = if notHere + then text "Neither name variable originates from the current signature." + else empty + in mkSimpleDecorated $ + text "While merging export lists, could not unify" + <+> ppr name1 <+> text "with" <+> ppr name2 $$ extra + TcRnHsigMissingModuleExport occ unit_state impl_mod + -> mkSimpleDecorated $ + quotes (ppr occ) + <+> text "is exported by the hsig file, but not exported by the implementing module" + <+> quotes (pprWithUnitState unit_state $ ppr impl_mod) + TcRnBadGenericMethod clas op + -> mkSimpleDecorated $ + hsep [text "Class", quotes (ppr clas), + text "has a generic-default signature without a binding", quotes (ppr op)] + TcRnWarningMinimalDefIncomplete mindef + -> mkSimpleDecorated $ + vcat [ text "The MINIMAL pragma does not require:" + , nest 2 (pprBooleanFormulaNice mindef) + , text "but there is no default implementation." ] + TcRnDefaultMethodForPragmaLacksBinding sel_id prag + -> mkSimpleDecorated $ + text "The" <+> hsSigDoc prag <+> text "for default method" + <+> quotes (ppr sel_id) + <+> text "lacks an accompanying binding" + TcRnIgnoreSpecialisePragmaOnDefMethod sel_name + -> mkSimpleDecorated $ + text "Ignoring SPECIALISE pragmas on default method" + <+> quotes (ppr sel_name) + TcRnBadMethodErr{badMethodErrClassName, badMethodErrMethodName} + -> mkSimpleDecorated $ + hsep [text "Class", quotes (ppr badMethodErrClassName), + text "does not have a method", quotes (ppr badMethodErrMethodName)] + TcRnIllegalTypeData + -> mkSimpleDecorated $ + text "Illegal type-level data declaration" + TcRnTypeDataForbids feature + -> mkSimpleDecorated $ + ppr feature <+> text "are not allowed in type data declarations." + + TcRnIllegalNewtype con show_linear_types reason + -> mkSimpleDecorated $ + vcat [msg, additional] + where + (msg,additional) = + case reason of + DoesNotHaveSingleField n_flds -> + (sep [ + text "A newtype constructor must have exactly one field", + nest 2 $ + text "but" <+> quotes (ppr con) <+> text "has" <+> speakN n_flds + ], + ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + IsNonLinear -> + (text "A newtype constructor must be linear", + ppr con <+> dcolon <+> ppr (dataConDisplayType True con)) + IsGADT -> + (text "A newtype must not be a GADT", + ppr con <+> dcolon <+> pprWithInvisibleBitsWhen sneaky_eq_spec + (ppr $ dataConDisplayType show_linear_types con)) + HasConstructorContext -> + (text "A newtype constructor must not have a context in its type", + ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + HasExistentialTyVar -> + (text "A newtype constructor must not have existential type variables", + ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + HasStrictnessAnnotation -> + (text "A newtype constructor must not have a strictness annotation", empty) + + -- Is the data con a "covert" GADT? See Note [isCovertGadtDataCon] + -- in GHC.Core.DataCon + sneaky_eq_spec = isCovertGadtDataCon con + TcRnOrPatBindsVariables bndrs -> mkSimpleDecorated $ + text "An or-pattern may not bind term or type variables such as" + <+> quotedListWithOr (map ppr (NE.toList bndrs)) + TcRnUnsatisfiedMinimalDef mindef + -> mkSimpleDecorated $ + vcat [text "No explicit implementation for" + ,nest 2 $ pprBooleanFormulaNice mindef + ] + TcRnMisplacedInstSig name hs_ty + -> mkSimpleDecorated $ + vcat [ hang (text "Illegal type signature in instance declaration:") + 2 (hang (pprPrefixName name) + 2 (dcolon <+> ppr hs_ty)) + ] + TcRnNoRebindableSyntaxRecordDot -> mkSimpleDecorated $ + text "RebindableSyntax is required if OverloadedRecordUpdate is enabled." + TcRnNoFieldPunsRecordDot -> mkSimpleDecorated $ + text "For this to work enable NamedFieldPuns" + TcRnIllegalStaticExpression e -> mkSimpleDecorated $ + text "Illegal static expression:" <+> ppr e + TcRnListComprehensionDuplicateBinding n -> mkSimpleDecorated $ + (text "Duplicate binding in parallel list comprehension for:" + <+> quotes (ppr n)) + TcRnEmptyStmtsGroup cause -> mkSimpleDecorated $ case cause of + EmptyStmtsGroupInParallelComp -> + text "Empty statement group in parallel comprehension" + EmptyStmtsGroupInTransformListComp -> + text "Empty statement group preceding 'group' or 'then'" + EmptyStmtsGroupInDoNotation ctxt -> + text "Empty" <+> pprHsDoFlavour ctxt + EmptyStmtsGroupInArrowNotation -> + text "Empty 'do' block in an arrow command" + TcRnLastStmtNotExpr ctxt (UnexpectedStatement stmt) -> + mkSimpleDecorated $ hang last_error 2 (ppr stmt) + where + last_error = + text "The last statement in" <+> pprAStmtContext ctxt + <+> text "must be an expression" + TcRnUnexpectedStatementInContext ctxt (UnexpectedStatement stmt) _ -> mkSimpleDecorated $ + sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement" + , text "in" <+> pprAStmtContext ctxt ] + TcRnIllegalTupleSection -> mkSimpleDecorated $ + text "Illegal tuple section" + TcRnIllegalImplicitParameterBindings eBinds -> mkSimpleDecorated $ + either msg msg eBinds + where + msg binds = hang + (text "Implicit-parameter bindings illegal in an mdo expression") + 2 (ppr binds) + TcRnSectionWithoutParentheses expr -> mkSimpleDecorated $ + hang (text "A section must be enclosed in parentheses") + 2 (text "thus:" <+> (parens (ppr expr))) + TcRnMissingRoleAnnotation name roles -> mkSimpleDecorated $ + hang (text "Missing role annotation" <> colon) + 2 (text "type role" <+> ppr name <+> hsep (map ppr roles)) + + TcRnIllformedTypePattern p + -> mkSimpleDecorated $ + hang (text "Ill-formed type pattern:") 2 (ppr p) + TcRnIllegalTypePattern + -> mkSimpleDecorated $ + text "Illegal type pattern." $$ + text "A type pattern must be checked against a visible forall." + TcRnIllformedTypeArgument e + -> mkSimpleDecorated $ + hang (text "Ill-formed type argument:") 2 (ppr e) + TcRnIllegalTypeExpr syntax -> mkSimpleDecorated $ + vcat [ text "Illegal" <+> pprTypeSyntaxName syntax + , text "Type syntax may only be used in a required type argument," + , text "i.e. to instantiate a visible forall." ] + + TcRnCapturedTermName tv_name shadowed_term_names + -> mkSimpleDecorated $ + text "The type variable" <+> quotes (ppr tv_name) <+> + text "is implicitly quantified," $+$ + text "even though another variable of the same name is in scope:" $+$ + nest 2 var_names $+$ + text "This is not compatible with the RequiredTypeArguments extension." + where + var_names = case shadowed_term_names of + Left gbl_names -> vcat (map (\name -> quotes (ppr $ greName name) <+> pprNameProvenance name) gbl_names) + Right lcl_name -> quotes (ppr lcl_name) <+> text "defined at" + <+> ppr (nameSrcLoc lcl_name) + TcRnBindingOfExistingName name -> mkSimpleDecorated $ + text "Illegal binding of an existing name:" <+> ppr name + TcRnMultipleFixityDecls loc rdr_name -> mkSimpleDecorated $ + vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr loc] + TcRnIllegalPatternSynonymDecl -> mkSimpleDecorated $ + text "Illegal pattern synonym declaration" + TcRnIllegalClassBinding dsort bind -> mkSimpleDecorated $ + vcat [ what <+> text "not allowed in" <+> decl_sort + , nest 2 (ppr bind) ] + where + decl_sort = case dsort of + ClassDeclSort -> text "class declaration:" + InstanceDeclSort -> text "instance declaration:" + what = case bind of + PatBind {} -> text "Pattern bindings (except simple variables)" + PatSynBind {} -> text "Pattern synonyms" + -- Associated pattern synonyms are not implemented yet + _ -> pprPanic "rnMethodBind" (ppr bind) + + TcRnOrphanCompletePragma -> mkSimpleDecorated $ + 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." + TcRnEmptyCase ctxt reason -> mkSimpleDecorated $ + case reason of + EmptyCaseWithoutFlag -> + text "Empty list of alternatives in" <+> pp_ctxt + EmptyCaseDisallowedCtxt -> + text "Empty list of alternatives is not allowed in" <+> pp_ctxt + EmptyCaseForall tvb -> + vcat [ text "Empty list of alternatives in" <+> pp_ctxt + , hang (text "checked against a forall-type:") + 2 (pprForAll [tvb] <+> text "...") + ] + where + pp_ctxt = case ctxt of + CaseAlt -> text "case expression" + LamAlt LamCase -> text "\\case expression" + LamAlt LamCases -> text "\\cases expression" + ArrowMatchCtxt (ArrowLamAlt LamSingle) -> text "kappa abstraction" + ArrowMatchCtxt (ArrowLamAlt LamCase) -> text "\\case command" + ArrowMatchCtxt (ArrowLamAlt LamCases) -> text "\\cases command" + ArrowMatchCtxt ArrowCaseAlt -> text "case command" + ctxt -> text "(unexpected)" <+> pprMatchContextNoun ctxt + TcRnNonStdGuards (NonStandardGuards guards) -> mkSimpleDecorated $ + text "accepting non-standard pattern guards" $$ + nest 4 (interpp'SP guards) + TcRnDuplicateSigDecl pairs@((L _ name, sig) :| _) -> mkSimpleDecorated $ + vcat [ text "Duplicate" <+> what_it_is + <> text "s for" <+> quotes (ppr name) + , text "at" <+> vcat (map ppr $ sortBy leftmost_smallest + $ map (getLocA . fst) + $ NE.toList pairs) + ] + where + what_it_is = hsSigDoc sig + TcRnMisplacedSigDecl sig -> mkSimpleDecorated $ + sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] + TcRnUnexpectedDefaultSig sig -> mkSimpleDecorated $ + hang (text "Unexpected default signature:") + 2 (ppr sig) + TcRnDuplicateMinimalSig sig1 sig2 otherSigs -> mkSimpleDecorated $ + vcat [ text "Multiple minimal complete definitions" + , text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ map getLocA sigs) + , text "Combine alternative minimal complete definitions with `|'" ] + where + sigs = sig1 : sig2 : otherSigs + TcRnSpecSigShape spec_e -> mkSimpleDecorated $ + hang (text "Illegal form of SPECIALISE pragma:") + 2 (ppr spec_e) + TcRnUnexpectedStandaloneDerivingDecl -> mkSimpleDecorated $ + text "Illegal standalone deriving declaration" + TcRnUnusedVariableInRuleDecl name var -> mkSimpleDecorated $ + sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, + text "Forall'd variable" <+> quotes (ppr var) <+> + text "does not appear on left hand side"] + TcRnUnexpectedStandaloneKindSig -> mkSimpleDecorated $ + text "Illegal standalone kind signature" + TcRnIllegalRuleLhs errReason name lhs bad_e -> mkSimpleDecorated $ + 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 errReason of + UnboundVariable uv nis -> pprScopeError uv nis + IllegalExpression -> text "Illegal expression:" <+> ppr bad_e + TcRnRuleLhsEqualities ruleName _lhs cts -> mkSimpleDecorated $ + text "Discarding RULE" <+> doubleQuotes (ftext ruleName) <> dot + $$ + hang + (sep [ text "The LHS of this rule gave rise to equality constraints" + , text "that GHC was unable to quantify over:" ] + ) + 4 (pprWithArising $ NE.toList cts) + $$ + text "NB: this warning will become an error starting from GHC 9.18" + TcRnDuplicateRoleAnnot list -> mkSimpleDecorated $ + hang (text "Duplicate role annotations for" <+> + quotes (ppr $ roleAnnotDeclName first_decl) <> colon) + 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) + where + sorted_list = NE.sortBy cmp_loc list + ((L _ first_decl) :| _) = sorted_list + + pp_role_annot (L loc decl) = hang (ppr decl) + 4 (text "-- written at" <+> ppr (locA loc)) + + cmp_loc = leftmost_smallest `on` getLocA + TcRnDuplicateKindSig list -> mkSimpleDecorated $ + hang (text "Duplicate standalone kind signatures for" <+> + quotes (ppr $ standaloneKindSigName first_decl) <> colon) + 2 (vcat $ map pp_kisig $ NE.toList sorted_list) + where + sorted_list = NE.sortBy cmp_loc list + ((L _ first_decl) :| _) = sorted_list + + pp_kisig (L loc decl) = + hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc)) + + cmp_loc = leftmost_smallest `on` getLocA + TcRnIllegalDerivStrategy ds -> mkSimpleDecorated $ + text "Illegal deriving strategy" <> colon <+> derivStrategyName ds + TcRnIllegalMultipleDerivClauses -> mkSimpleDecorated $ + text "Illegal use of multiple, consecutive deriving clauses" + TcRnNoDerivStratSpecified{} -> mkSimpleDecorated $ text + "No deriving strategy specified. Did you want stock, newtype, or anyclass?" + TcRnStupidThetaInGadt{} -> mkSimpleDecorated $ + vcat [text "No context is allowed on a GADT-style data declaration", + text "(You can put a context on each constructor, though.)"] + TcRnShadowedTyVarNameInFamResult resName -> mkSimpleDecorated $ + hsep [ text "Type variable", quotes (ppr resName) <> comma + , text "naming a type family result," + ] $$ + text "shadows an already bound type variable" + TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom -> mkSimpleDecorated $ + vcat [ text $ "Incorrect type variable on the LHS of " + ++ "injectivity condition" + , nest 5 + ( vcat [ text "Expected :" <+> ppr resName + , text "Actual :" <+> ppr injFrom ])] + TcRnUnknownTyVarsOnRhsOfInjCond errorVars -> mkSimpleDecorated $ + hsep [ text "Unknown type variable" <> plural errorVars + , text "on the RHS of injectivity condition:" + , interpp'SP errorVars ] + TcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt _reason + -> pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt + TcRnBadlyLevelledType name bind_lvls use_lvl + -> mkSimpleDecorated $ + text "Badly levelled type:" <+> ppr name <+> + fsep [text "is bound at" <+> pprThBindLevel bind_lvls, + text "but used at level" <+> ppr use_lvl] + TcRnTyThingUsedWrong sort thing name + -> mkSimpleDecorated $ + pprTyThingUsedWrong sort thing name + TcRnCannotDefaultKindVar var knd -> + mkSimpleDecorated $ + (vcat [ text "Cannot default kind variable" <+> quotes (ppr var) + , text "of kind:" <+> ppr knd + , text "Perhaps enable PolyKinds or add a kind signature" ]) + TcRnUninferrableTyVar tidied_tvs context -> + mkSimpleDecorated $ + pprWithInvisibleBitsWhen True $ + vcat [ text "Uninferrable type variable" + <> plural tidied_tvs + <+> pprWithCommas pprTyVar tidied_tvs + <+> text "in" + , pprUninferrableTyVarCtx context ] + TcRnSkolemEscape escapees tv orig_ty -> + mkSimpleDecorated $ + pprWithInvisibleBitsWhen True $ + vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees + , quotes $ pprTyVars escapees + , text "would escape" <+> itsOrTheir escapees <+> text "scope" + ] + , sep [ text "if I tried to quantify" + , pprTyVar tv + , text "in this type:" + ] + , nest 2 (pprTidiedType orig_ty) + , text "(Indeed, I sometimes struggle even printing this correctly," + , text " due to its ill-scoped nature.)" + ] + TcRnPatSynEscapedCoercion arg bad_co_ne -> mkSimpleDecorated $ + vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" + , hang (text "Pattern-bound variable") + 2 (ppr arg <+> dcolon <+> ppr (idType arg)) + , nest 2 $ + hang (text "has a type that mentions pattern-bound coercion" + <> plural bad_co_list <> colon) + 2 (pprWithCommas ppr bad_co_list) + , text "Hint: use -fprint-explicit-coercions to see the coercions" + , text "Probable fix: add a pattern signature" ] + where + bad_co_list = NE.toList bad_co_ne + TcRnPatSynExistentialInResult name pat_ty bad_tvs -> mkSimpleDecorated $ + hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma + , text "namely" <+> quotes (ppr pat_ty) ]) + 2 (text "mentions existential type variable" <> plural bad_tvs + <+> pprQuotedList bad_tvs) + TcRnPatSynArityMismatch name decl_arity missing -> mkSimpleDecorated $ + 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") + TcRnPatSynInvalidRhs ps_name lpat _ reason -> mkSimpleDecorated $ + vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" + <+> quotes (ppr ps_name) <> colon) + 2 (pprPatSynInvalidRhsReason reason) + , text "RHS pattern:" <+> ppr lpat ] + TcRnTyFamDepsDisabled -> mkSimpleDecorated $ + text "Illegal injectivity annotation" + TcRnAbstractClosedTyFamDecl -> mkSimpleDecorated $ + text "You may define an abstract closed type family" $$ + text "only in a .hs-boot file" + TcRnPartialFieldSelector fld -> mkSimpleDecorated $ + vcat [ sep [ text "Definition of partial record field" <> colon + , nest 2 $ quotes (ppr (occName fld)) ] + , text "Record selection and update using this field will be partial." ] + TcRnHasFieldResolvedIncomplete name cons maxCons -> mkSimpleDecorated $ + hang (text "Selecting the record field" <+> quotes (ppr name) + <+> text "may fail for the following constructors:") + 2 + (hsep $ punctuate comma $ + map ppr (take maxCons cons) ++ [ text "..." | lengthExceeds cons maxCons ]) + TcRnBadFieldAnnotation n con reason -> mkSimpleDecorated $ + hang (pprBadFieldAnnotationReason reason) + 2 (text "on the" <+> speakNth n + <+> text "argument of" <+> quotes (ppr con)) + TcRnSuperclassCycle (MkSuperclassCycle cls definite details) -> + let herald | definite = text "Superclass cycle for" + | otherwise = text "Potential superclass cycle for" + in mkSimpleDecorated $ + vcat [ herald <+> quotes (ppr cls), nest 2 (vcat (pprSuperclassCycleDetail <$> details))] + TcRnDefaultSigMismatch sel_id dm_ty -> mkSimpleDecorated $ + hang (text "The default type signature for" + <+> ppr sel_id <> colon) + 2 (ppr dm_ty) + $$ (text "does not match its corresponding" + <+> text "non-default type signature") + TcRnTyFamsDisabled reason -> mkSimpleDecorated $ + text "Illegal family" <+> text sort <+> text "for" <+> quotes name + where + (sort, name) = case reason of + TyFamsDisabledFamily n -> ("declaration", ppr n) + TyFamsDisabledInstance n -> ("instance", ppr n) + TcRnBadTyConTelescope tc -> mkSimpleDecorated $ + vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") + 2 pp_tc_kind + , extra + , hang (text "Perhaps try this order instead:") + 2 (pprTyVars sorted_tvs) ] + where + pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc) + ppr_untidy ty = pprIfaceType (toIfaceType ty) + -- We need ppr_untidy here because pprType will tidy the type, which + -- will turn the bogus kind we are trying to report + -- T :: forall (a::k) k (b::k) -> blah + -- into a misleadingly sanitised version + -- T :: forall (a::k) k1 (b::k1) -> blah + + tcbs = tyConBinders tc + tvs = binderVars tcbs + sorted_tvs = scopedSort tvs + + inferred_tvs = [ binderVar tcb + | tcb <- tcbs, Inferred == tyConBinderForAllTyFlag tcb ] + specified_tvs = [ binderVar tcb + | tcb <- tcbs, Specified == tyConBinderForAllTyFlag tcb ] + + extra + | null inferred_tvs && null specified_tvs + = empty + | null inferred_tvs + = note $ "Specified variables" <+> pp_spec <+> "always come first" + | null specified_tvs + = note inf_always_first + | otherwise + = note $ inf_always_first $$ + "then specified variables" <+> pp_spec + + inf_always_first = "Inferred variables" <+> pp_inf $$ "always come first" + + pp_inf = parens (text "namely:" <+> pprTyVars inferred_tvs) + pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) + TcRnTyFamResultDisabled tc_name tvb -> mkSimpleDecorated $ + text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name) + TcRnRoleValidationFailed role reason -> mkSimpleDecorated $ + vcat [text "Internal error in role inference:", + pprRoleValidationFailedReason role reason, + text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] + TcRnCommonFieldResultTypeMismatch con1 con2 field_name -> mkSimpleDecorated $ + 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"] + TcRnCommonFieldTypeMismatch con1 con2 field_name -> mkSimpleDecorated $ + sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + text "give different types for field", quotes (ppr field_name)] + TcRnClassExtensionDisabled cls reason -> mkSimpleDecorated $ + pprDisabledClassExtension cls reason + TcRnDataConParentTypeMismatch data_con res_ty_tmpl -> mkSimpleDecorated $ + 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 + TcRnGADTsDisabled tc_name -> mkSimpleDecorated $ + text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) + TcRnExistentialQuantificationDisabled con -> mkSimpleDecorated $ + 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 (ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))) + TcRnGADTDataContext tc_name -> mkSimpleDecorated $ + text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) + TcRnMultipleConForNewtype tycon n -> mkSimpleDecorated $ + sep [text "A newtype must have exactly one constructor,", + nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n] + TcRnKindSignaturesDisabled thing -> mkSimpleDecorated $ + text "Illegal kind signature" <+> quotes (either ppr with_sig thing) + where + with_sig (tc_name, ksig) = ppr tc_name <+> dcolon <+> ppr ksig + TcRnEmptyDataDeclsDisabled tycon -> mkSimpleDecorated $ + quotes (ppr tycon) <+> text "has no constructors" + TcRnRoleMismatch var annot inferred -> mkSimpleDecorated $ + hang (text "Role mismatch on variable" <+> ppr var <> colon) + 2 (sep [ text "Annotation says", ppr annot + , text "but role", ppr inferred + , text "is required" ]) + TcRnRoleCountMismatch tyvars d@(L _ (RoleAnnotDecl _ _ annots)) -> mkSimpleDecorated $ + hang (text "Wrong number of roles listed in role annotation;" $$ + text "Expected" <+> (ppr tyvars) <> comma <+> + text "got" <+> (ppr $ length annots) <> colon) + 2 (ppr d) + TcRnIllegalRoleAnnotation (RoleAnnotDecl _ tycon _) -> mkSimpleDecorated $ + (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ + text "they are allowed only for datatypes and classes.") + TcRnRoleAnnotationsDisabled tc -> mkSimpleDecorated $ + text "Illegal role annotation for" <+> ppr tc + TcRnIncoherentRoles _ -> mkSimpleDecorated $ + (text "Roles other than" <+> quotes (text "nominal") <+> + text "for class parameters can lead to incoherence.") + TcRnUnexpectedKindVar tv_name + -> mkSimpleDecorated $ text "Unexpected kind variable" <+> quotes (ppr tv_name) + + TcRnNegativeNumTypeLiteral tyLit + -> mkSimpleDecorated $ text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit + + TcRnIllegalKind ty_thing _ + -> mkSimpleDecorated $ text "Illegal kind:" <+> (ppr ty_thing) + + TcRnPrecedenceParsingError op1 op2 + -> mkSimpleDecorated $ + hang (text "Precedence parsing error") + 4 (hsep [text "cannot mix", ppr_opfix op1, text "and", + ppr_opfix op2, + text "in the same infix expression"]) + + TcRnSectionPrecedenceError op arg_op section + -> mkSimpleDecorated $ + 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))] + + TcRnUnexpectedPatSigType ty + -> mkSimpleDecorated $ + hang (text "Illegal type signature:" <+> quotes (ppr ty)) + 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") + + TcRnIllegalKindSignature ty + -> mkSimpleDecorated $ text "Illegal kind signature:" <+> quotes (ppr ty) + + TcRnUnusedQuantifiedTypeVar doc tyVar + -> mkSimpleDecorated $ + vcat [ text "Unused quantified type variable" <+> quotes (ppr tyVar) + , inHsDocContext doc ] + + TcRnDataKindsError typeOrKind thing + -> case thing of + Left renamer_thing -> + mkSimpleDecorated $ msg renamer_thing + Right typechecker_thing -> + mkSimpleDecorated $ msg typechecker_thing + where + msg :: Outputable a => a -> SDoc + msg thing = text "Illegal" <+> text (levelString typeOrKind) <> + colon <+> quotes (ppr thing) + + TcRnTypeSynonymCycle decl_or_tcs + -> mkSimpleDecorated $ + sep [ text "Cycle in type synonym declarations:" + , nest 2 (vcat (map ppr_decl decl_or_tcs)) ] + where + ppr_decl = \case + Right (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl + Left tc -> + let n = tyConName tc + in ppr (getSrcSpan n) <> colon <+> ppr (tyConName tc) + <+> text "from external module" + TcRnZonkerMessage err + -> mkSimpleDecorated $ pprZonkerMessage err + TcRnInterfaceError reason + -> diagnosticMessage (tcOptsIfaceOpts opts) reason + TcRnSelfImport imp_mod_name + -> mkSimpleDecorated $ + text "A module cannot import itself:" <+> ppr imp_mod_name + TcRnNoExplicitImportList mod + -> mkSimpleDecorated $ + text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" + TcRnSafeImportsDisabled _ + -> mkSimpleDecorated $ + text "safe import can't be used as Safe Haskell isn't on!" + TcRnDeprecatedModule mod txt + -> mkSimpleDecorated $ + sep [ text "Module" <+> quotes (ppr mod) <> text extra <> colon, + nest 2 (vcat (map (ppr . hsDocString . unLoc) msg)) ] + where + (extra, msg) = case txt of + WarningTxt _ _ msg -> ("", msg) + DeprecatedTxt _ msg -> (" is deprecated", msg) + TcRnRedundantSourceImport mod_name + -> mkSimpleDecorated $ + text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name) + TcRnImportLookup reason + -> mkSimpleDecorated $ + pprImportLookup reason + TcRnUnusedImport decl reason + -> mkSimpleDecorated $ + pprUnusedImport decl reason + TcRnDuplicateDecls name sorted_names + -> mkSimpleDecorated $ + vcat [text "Multiple declarations of" <+> + quotes (ppr name), + -- NB. print the OccName, not the Name, because the + -- latter might not be in scope in the RdrEnv and so will + -- be printed qualified. + text "Declared at:" <+> + vcat (NE.toList $ ppr . nameSrcLoc <$> sorted_names)] + TcRnPackageImportsDisabled + -> mkSimpleDecorated $ + text "Package-qualified imports are not enabled" + TcRnIllegalDataCon name + -> mkSimpleDecorated $ + hsep [text "Illegal data constructor name", quotes (ppr name)] + TcRnNestedForallsContexts entity + -> mkSimpleDecorated $ + what <+> text "cannot contain nested" + <+> quotes forAllLit <> text "s or contexts" + where + what = case entity of + NFC_Specialize -> text "SPECIALISE instance type" + NFC_ViaType -> quotes (text "via") <+> text "type" + NFC_GadtConSig -> text "GADT constructor type signature" + NFC_InstanceHead -> text "Instance head" + NFC_StandaloneDerivedInstanceHead -> text "Standalone-derived instance head" + NFC_DerivedClassType -> text "Derived class type" + TcRnRedundantRecordWildcard + -> mkSimpleDecorated $ + text "Record wildcard does not bind any new variables" + TcRnUnusedRecordWildcard _ + -> mkSimpleDecorated $ + text "No variables bound in the record wildcard match are used" + TcRnUnusedName name reason + -> mkSimpleDecorated $ + pprUnusedName name reason + TcRnQualifiedBinder rdr_name + -> mkSimpleDecorated $ + text "Qualified name in binding position:" <+> ppr rdr_name + TcRnTypeApplicationsDisabled ty ty_or_ki + -> mkSimpleDecorated $ + text "Illegal visible" <+> what <+> text "application" <> colon + <+> ppr arg + where + arg = char '@' <> ppr ty + what = case ty_or_ki of + TypeLevel -> text "type" + KindLevel -> text "kind" + TcRnInvalidRecordField con field + -> mkSimpleDecorated $ + hsep [text "Constructor" <+> quotes (ppr con), + text "does not have field", quotes (ppr field)] + TcRnTupleTooLarge tup_size + -> mkSimpleDecorated $ + 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")] + TcRnCTupleTooLarge tup_size + -> mkSimpleDecorated $ + 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") + TcRnIllegalInferredTyVars _ + -> mkSimpleDecorated $ + text "Inferred type variables are not allowed" + TcRnAmbiguousName gre_env name gres + -> mkSimpleDecorated $ + vcat [ text "Ambiguous occurrence" <+> quotes (ppr name) <> dot + , text "It could refer to" + , nest 3 (vcat msgs) ] + where + np1 NE.:| nps = gres + msgs = punctuateFinal comma dot $ + text "either" <+> ppr_gre np1 + : [text " or" <+> ppr_gre np | np <- nps] + + ppr_gre gre = pprAmbiguousGreName gre_env gre + + TcRnBindingNameConflict name locs + -> mkSimpleDecorated $ + vcat [text "Conflicting definitions for" <+> quotes (ppr name), + locations] + where + locations = + text "Bound at:" + <+> vcat (map ppr (sortBy leftmost_smallest (NE.toList locs))) + TcRnNonCanonicalDefinition reason inst_ty + -> mkSimpleDecorated $ + pprNonCanonicalDefinition inst_ty reason + TcRnDefaultedExceptionContext ct_loc -> + mkSimpleDecorated $ vcat [ header, warning, proposal ] + where + header, warning, proposal :: SDoc + header + = vcat [ text "Solving for an implicit ExceptionContext constraint" + , nest 2 $ pprCtOrigin (ctLocOrigin ct_loc) <> text "." ] + warning + = vcat [ text "Future versions of GHC will turn this warning into an error." ] + proposal + = vcat [ text "See GHC Proposal #330." ] + TcRnImplicitImportOfPrelude + -> mkSimpleDecorated $ + text "Module" <+> quotes (text "Prelude") <+> text "implicitly imported." + TcRnMissingMain explicit_export_list main_mod main_occ + -> mkSimpleDecorated $ + text "The" <+> ppMainFn main_occ + <+> text "is not" <+> defOrExp <+> text "module" + <+> quotes (ppr main_mod) + where + defOrExp :: SDoc + defOrExp | explicit_export_list = text "exported by" + | otherwise = text "defined in" + TcRnGhciUnliftedBind id + -> mkSimpleDecorated $ + sep [ text "GHCi can't bind a variable of unlifted type:" + , nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id)) ] + TcRnGhciMonadLookupFail ty lookups + -> mkSimpleDecorated $ + hang (text "Can't find type" <+> pp_ty <> dot $$ ambig_msg) + 2 (text "When checking that" <+> pp_ty <> + text "is a monad that can execute GHCi statements.") + where + pp_ty = quotes (text ty) + ambig_msg = case lookups of + Just (_:_:_) -> text "The type is ambiguous." + _ -> empty + TcRnIllegalQuasiQuotes -> mkSimpleDecorated $ + text "Quasi-quotes are not permitted without QuasiQuotes" + TcRnTHError err -> pprTHError err + TcRnPatersonCondFailure reason ctxt lhs rhs -> + mkSimpleDecorated $ pprPatersonCondFailure reason ctxt lhs rhs + TcRnIllegalInvisTyVarBndr bndr -> + mkSimpleDecorated $ + hang (text "Illegal invisible type variable binder:") + 2 (ppr bndr) + TcRnIllegalWildcardTyVarBndr bndr -> + mkSimpleDecorated $ + hang (text "Illegal wildcard binder:") + 2 (ppr bndr) + + TcRnInvalidInvisTyVarBndr name hs_bndr -> + mkSimpleDecorated $ + vcat [ hang (text "Invalid invisible type variable binder:") + 2 (ppr hs_bndr) + , text "There is no matching forall-bound variable" + , text "in the standalone kind signature for" <+> quotes (ppr name) <> dot + , note $ vcat [ + "Only" <+> quotes "forall a." <+> "-quantification matches invisible binders,", + "whereas" <+> quotes "forall {a}." <+> "and" <+> quotes "forall a ->" <+> "do not" + ]] + + TcRnInvisBndrWithoutSig _ hs_bndr -> + mkSimpleDecorated $ + vcat [ hang (text "Invalid invisible type variable binder:") + 2 (ppr hs_bndr) + , text "Either a standalone kind signature (SAKS)" + , text "or a complete user-supplied kind (CUSK, legacy feature)" + , text "is required to use invisible binders." ] + + TcRnImplicitRhsQuantification kv -> mkSimpleDecorated $ + vcat [ text "The variable" <+> quotes (ppr kv) <+> text "occurs free on the RHS of the type declaration" + , text "The next version of GHC will reject this program, no longer implicitly quantify over" <+> quotes (ppr kv) + ] + + TcRnInvalidDefaultedTyVar wanteds proposal bad_tvs -> + mkSimpleDecorated $ + pprWithInvisibleBitsWhen True $ + vcat [ text "Invalid defaulting proposal." + , hang (text "The following type variable" <> plural (NE.toList bad_tvs) <+> text "cannot be defaulted, as" <+> why <> colon) + 2 (pprQuotedList (NE.toList bad_tvs)) + , hang (text "Defaulting proposal:") + 2 (ppr proposal) + , hang (text "Wanted constraints:") + 2 (pprQuotedList (map ctPred wanteds)) + ] + where + why + | _ :| [] <- bad_tvs + = text "it is not an unfilled metavariable" + | otherwise + = text "they are not unfilled metavariables" + + TcRnNamespacedWarningPragmaWithoutFlag warning@(Warning (kw, _) _ txt) -> mkSimpleDecorated $ + vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:" + , nest 2 (ppr warning) + , text "in a" <+> pragma_type <+> text "pragma" + ] + where + pragma_type = case txt of + WarningTxt{} -> text "WARNING" + DeprecatedTxt{} -> text "DEPRECATED" + + TcRnIllegalInvisibleTypePattern tp reason -> mkSimpleDecorated $ + vcat [ hang (text "Illegal invisible type pattern:") + 2 (char '@' <> ppr tp) + , case reason of + InvisPatWithoutFlag -> empty + InvisPatNoForall -> text "An invisible type pattern must be checked against a forall." + InvisPatMisplaced -> text "An invisible type pattern must occur in an argument position." + ] + + TcRnNamespacedFixitySigWithoutFlag sig@(FixitySig kw _ _) -> mkSimpleDecorated $ + vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:" + , nest 2 (ppr sig) + , text "in a fixity signature" + ] + + TcRnOutOfArityTyVar ts_name tv_name -> mkDecorated + [ vcat [ text "The arity of" <+> quotes (ppr ts_name) <+> text "is insufficiently high to accommodate" + , text "an implicit binding for the" <+> quotes (ppr tv_name) <+> text "type variable." ] + , suggestion ] + where + suggestion = + text "Use" <+> quotes at_bndr <+> text "on the LHS" <+> + text "or" <+> quotes forall_bndr <+> text "on the RHS" <+> + text "to bring it into scope." + at_bndr = char '@' <> ppr tv_name + forall_bndr = text "forall" <+> ppr tv_name <> text "." + + TcRnUnexpectedTypeSyntaxInTerms syntax -> mkSimpleDecorated $ + text "Unexpected" <+> pprTypeSyntaxName syntax + + diagnosticReason :: TcRnMessage -> DiagnosticReason + diagnosticReason = \case + TcRnUnknownMessage m + -> diagnosticReason m + TcRnMessageWithInfo _ msg_with_info + -> case msg_with_info of + TcRnMessageDetailed _ m -> diagnosticReason m + TcRnWithHsDocContext _ msg + -> diagnosticReason msg + TcRnSolverReport _report reason + -> reason -- Error, or a Warning if we are deferring type errors + TcRnSolverDepthError {} + -> ErrorWithoutFlag + TcRnRedundantConstraints {} + -> WarningWithFlag Opt_WarnRedundantConstraints + TcRnInaccessibleCode {} + -> WarningWithFlag Opt_WarnInaccessibleCode + TcRnInaccessibleCoAxBranch {} + -> WarningWithFlag Opt_WarnInaccessibleCode + TcRnTypeDoesNotHaveFixedRuntimeRep{} + -> ErrorWithoutFlag + TcRnImplicitLift{} + -> WarningWithFlag Opt_WarnImplicitLift + TcRnUnusedPatternBinds{} + -> WarningWithFlag Opt_WarnUnusedPatternBinds + TcRnDodgyImports{} + -> WarningWithFlag Opt_WarnDodgyImports + TcRnDodgyExports{} + -> WarningWithFlag Opt_WarnDodgyExports + TcRnMissingImportList{} + -> WarningWithFlag Opt_WarnMissingImportList + TcRnUnsafeDueToPlugin{} + -> WarningWithoutFlag + TcRnModMissingRealSrcSpan{} + -> ErrorWithoutFlag + TcRnIdNotExportedFromModuleSig{} + -> ErrorWithoutFlag + TcRnIdNotExportedFromLocalSig{} + -> ErrorWithoutFlag + TcRnShadowedName{} + -> WarningWithFlag Opt_WarnNameShadowing + TcRnInvalidWarningCategory{} + -> ErrorWithoutFlag + TcRnDuplicateWarningDecls{} + -> ErrorWithoutFlag + TcRnSimplifierTooManyIterations{} + -> ErrorWithoutFlag + TcRnIllegalPatSynDecl{} + -> ErrorWithoutFlag + TcRnLinearPatSyn{} + -> ErrorWithoutFlag + TcRnEmptyRecordUpdate + -> ErrorWithoutFlag + TcRnIllegalFieldPunning{} + -> ErrorWithoutFlag + TcRnIllegalWildcardsInRecord{} + -> ErrorWithoutFlag + TcRnIllegalWildcardInType{} + -> ErrorWithoutFlag + TcRnIllegalNamedWildcardInTypeArgument{} + -> ErrorWithoutFlag + TcRnIllegalImplicitTyVarInTypeArgument{} + -> ErrorWithoutFlag + TcRnIllegalPunnedVarOccInTypeArgument{} + -> ErrorWithoutFlag + TcRnDuplicateFieldName{} + -> ErrorWithoutFlag + TcRnIllegalViewPattern{} + -> ErrorWithoutFlag + TcRnCharLiteralOutOfRange{} + -> ErrorWithoutFlag + TcRnIllegalWildcardsInConstructor{} + -> ErrorWithoutFlag + TcRnIgnoringAnnotations{} + -> WarningWithoutFlag + TcRnAnnotationInSafeHaskell + -> ErrorWithoutFlag + TcRnInvalidTypeApplication{} + -> ErrorWithoutFlag + TcRnTagToEnumMissingValArg + -> ErrorWithoutFlag + TcRnTagToEnumUnspecifiedResTy{} + -> ErrorWithoutFlag + TcRnTagToEnumResTyNotAnEnum{} + -> ErrorWithoutFlag + TcRnTagToEnumResTyTypeData{} + -> ErrorWithoutFlag + TcRnArrowIfThenElsePredDependsOnResultTy + -> ErrorWithoutFlag + TcRnIllegalHsBootOrSigDecl {} + -> ErrorWithoutFlag + TcRnBootMismatch {} + -> ErrorWithoutFlag + TcRnRecursivePatternSynonym{} + -> ErrorWithoutFlag + TcRnPartialTypeSigTyVarMismatch{} + -> ErrorWithoutFlag + TcRnPartialTypeSigBadQuantifier{} + -> ErrorWithoutFlag + TcRnMissingSignature what exported + -> WarningWithFlags $ missingSignatureWarningFlags what exported + TcRnPolymorphicBinderMissingSig{} + -> WarningWithFlag Opt_WarnMissingLocalSignatures + TcRnOverloadedSig{} + -> ErrorWithoutFlag + TcRnTupleConstraintInst{} + -> ErrorWithoutFlag + TcRnUserTypeError{} + -> ErrorWithoutFlag + TcRnConstraintInKind{} + -> ErrorWithoutFlag + TcRnUnboxedTupleOrSumTypeFuncArg{} + -> ErrorWithoutFlag + TcRnLinearFuncInKind{} + -> ErrorWithoutFlag + TcRnForAllEscapeError{} + -> ErrorWithoutFlag + TcRnSimplifiableConstraint{} + -> WarningWithFlag Opt_WarnSimplifiableClassConstraints + TcRnArityMismatch{} + -> ErrorWithoutFlag + TcRnIllegalInstance rea + -> illegalInstanceReason rea + TcRnVDQInTermType{} + -> ErrorWithoutFlag + TcRnBadQuantPredHead{} + -> ErrorWithoutFlag + TcRnIllegalTupleConstraint{} + -> ErrorWithoutFlag + TcRnNonTypeVarArgInConstraint{} + -> ErrorWithoutFlag + TcRnIllegalImplicitParam{} + -> ErrorWithoutFlag + TcRnIllegalConstraintSynonymOfKind{} + -> ErrorWithoutFlag + TcRnOversaturatedVisibleKindArg{} + -> ErrorWithoutFlag + TcRnForAllRankErr{} + -> ErrorWithoutFlag + TcRnMonomorphicBindings{} + -> WarningWithFlag Opt_WarnMonomorphism + TcRnOrphanInstance{} + -> WarningWithFlag Opt_WarnOrphans + TcRnFunDepConflict{} + -> ErrorWithoutFlag + TcRnDupInstanceDecls{} + -> ErrorWithoutFlag + TcRnConflictingFamInstDecls{} + -> ErrorWithoutFlag + TcRnFamInstNotInjective{} + -> ErrorWithoutFlag + TcRnBangOnUnliftedType{} + -> WarningWithFlag Opt_WarnRedundantStrictnessFlags + TcRnLazyBangOnUnliftedType{} + -> WarningWithFlag Opt_WarnRedundantStrictnessFlags + TcRnMultipleDefaultDeclarations{} + -> ErrorWithoutFlag + TcRnBadDefaultType{} + -> ErrorWithoutFlag + TcRnPatSynBundledWithNonDataCon{} + -> ErrorWithoutFlag + TcRnPatSynBundledWithWrongType{} + -> ErrorWithoutFlag + TcRnDupeModuleExport{} + -> WarningWithFlag Opt_WarnDuplicateExports + TcRnExportedModNotImported{} + -> ErrorWithoutFlag + TcRnNullExportedModule{} + -> WarningWithFlag Opt_WarnDodgyExports + TcRnMissingExportList{} + -> WarningWithFlag Opt_WarnMissingExportList + TcRnExportHiddenComponents{} + -> ErrorWithoutFlag + TcRnExportHiddenDefault{} + -> ErrorWithoutFlag + TcRnDuplicateExport{} + -> WarningWithFlag Opt_WarnDuplicateExports + TcRnDuplicateNamedDefaultExport{} + -> WarningWithFlag Opt_WarnDuplicateExports + TcRnExportedParentChildMismatch{} + -> ErrorWithoutFlag + TcRnConflictingExports{} + -> ErrorWithoutFlag + TcRnDuplicateFieldExport {} + -> ErrorWithoutFlag + TcRnAmbiguousFieldInUpdate {} + -> ErrorWithoutFlag + TcRnAmbiguousRecordUpdate{} + -> WarningWithFlag Opt_WarnAmbiguousFields + TcRnMissingFields{} + -> WarningWithFlag Opt_WarnMissingFields + TcRnFieldUpdateInvalidType{} + -> ErrorWithoutFlag + TcRnMissingStrictFields{} + -> ErrorWithoutFlag + TcRnBadRecordUpdate{} + -> ErrorWithoutFlag + TcRnIllegalStaticExpression {} + -> ErrorWithoutFlag + TcRnStaticFormNotClosed{} + -> ErrorWithoutFlag + TcRnUselessTypeable + -> WarningWithFlag Opt_WarnDerivingTypeable + TcRnDerivingDefaults{} + -> WarningWithFlag Opt_WarnDerivingDefaults + TcRnNonUnaryTypeclassConstraint{} + -> ErrorWithoutFlag + TcRnPartialTypeSignatures{} + -> WarningWithFlag Opt_WarnPartialTypeSignatures + TcRnCannotDeriveInstance _ _ _ _ rea + -> case rea of + DerivErrNotWellKinded{} -> ErrorWithoutFlag + DerivErrSafeHaskellGenericInst -> ErrorWithoutFlag + DerivErrDerivingViaWrongKind{} -> ErrorWithoutFlag + DerivErrNoEtaReduce{} -> ErrorWithoutFlag + DerivErrBootFileFound -> ErrorWithoutFlag + DerivErrDataConsNotAllInScope{} -> ErrorWithoutFlag + DerivErrGNDUsedOnData -> ErrorWithoutFlag + DerivErrNullaryClasses -> ErrorWithoutFlag + DerivErrLastArgMustBeApp -> ErrorWithoutFlag + DerivErrNoFamilyInstance{} -> ErrorWithoutFlag + DerivErrNotStockDeriveable{} -> ErrorWithoutFlag + DerivErrHasAssociatedDatatypes{} -> ErrorWithoutFlag + DerivErrNewtypeNonDeriveableClass -> ErrorWithoutFlag + DerivErrCannotEtaReduceEnough{} -> ErrorWithoutFlag + DerivErrOnlyAnyClassDeriveable{} -> ErrorWithoutFlag + DerivErrNotDeriveable{} -> ErrorWithoutFlag + DerivErrNotAClass{} -> ErrorWithoutFlag + DerivErrNoConstructors{} -> ErrorWithoutFlag + DerivErrLangExtRequired{} -> ErrorWithoutFlag + DerivErrDunnoHowToDeriveForType{} -> ErrorWithoutFlag + DerivErrMustBeEnumType{} -> ErrorWithoutFlag + DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag + DerivErrMustHaveSomeParameters{} -> ErrorWithoutFlag + DerivErrMustNotHaveClassContext{} -> ErrorWithoutFlag + DerivErrBadConstructor{} -> ErrorWithoutFlag + DerivErrGenerics{} -> ErrorWithoutFlag + DerivErrEnumOrProduct{} -> ErrorWithoutFlag + TcRnLookupInstance _ _ _ + -> ErrorWithoutFlag + TcRnLazyGADTPattern + -> ErrorWithoutFlag + TcRnArrowProcGADTPattern + -> ErrorWithoutFlag + TcRnTypeEqualityOutOfScope + -> WarningWithFlag Opt_WarnTypeEqualityOutOfScope + TcRnTypeEqualityRequiresOperators + -> WarningWithFlag Opt_WarnTypeEqualityRequiresOperators + TcRnIllegalTypeOperator {} + -> ErrorWithoutFlag + TcRnIllegalTypeOperatorDecl {} + -> ErrorWithoutFlag + TcRnGADTMonoLocalBinds {} + -> WarningWithFlag Opt_WarnGADTMonoLocalBinds + TcRnIncorrectNameSpace {} + -> ErrorWithoutFlag + TcRnNotInScope {} + -> ErrorWithoutFlag + TcRnTermNameInType {} + -> ErrorWithoutFlag + TcRnUntickedPromotedThing {} + -> WarningWithFlag Opt_WarnUntickedPromotedConstructors + TcRnIllegalBuiltinSyntax {} + -> ErrorWithoutFlag + TcRnWarnDefaulting {} + -> WarningWithFlag Opt_WarnTypeDefaults + TcRnWarnClashingDefaultImports {} + -> WarningWithFlag Opt_WarnTypeDefaults + TcRnForeignImportPrimExtNotSet{} + -> ErrorWithoutFlag + TcRnForeignImportPrimSafeAnn{} + -> ErrorWithoutFlag + TcRnForeignFunctionImportAsValue{} + -> ErrorWithoutFlag + TcRnFunPtrImportWithoutAmpersand{} + -> WarningWithFlag Opt_WarnDodgyForeignImports + TcRnIllegalForeignDeclBackend{} + -> ErrorWithoutFlag + TcRnUnsupportedCallConv _ unsupportedCC + -> case unsupportedCC of + StdCallConvUnsupported -> WarningWithFlag Opt_WarnUnsupportedCallingConventions + _ -> ErrorWithoutFlag + TcRnIllegalForeignType{} + -> ErrorWithoutFlag + TcRnInvalidCIdentifier{} + -> ErrorWithoutFlag + TcRnExpectedValueId{} + -> ErrorWithoutFlag + TcRnRecSelectorEscapedTyVar{} + -> ErrorWithoutFlag + TcRnPatSynNotBidirectional{} + -> ErrorWithoutFlag + TcRnIllegalDerivingItem{} + -> ErrorWithoutFlag + TcRnIllegalDefaultClass{} + -> ErrorWithoutFlag + TcRnIllegalNamedDefault{} + -> ErrorWithoutFlag + TcRnUnexpectedAnnotation{} + -> ErrorWithoutFlag + TcRnIllegalRecordSyntax{} + -> ErrorWithoutFlag + TcRnInvalidVisibleKindArgument{} + -> ErrorWithoutFlag + TcRnTooManyBinders{} + -> ErrorWithoutFlag + TcRnDifferentNamesForTyVar{} + -> ErrorWithoutFlag + TcRnDisconnectedTyVar{} + -> ErrorWithoutFlag + TcRnInvalidReturnKind{} + -> ErrorWithoutFlag + TcRnClassKindNotConstraint{} + -> ErrorWithoutFlag + TcRnUnpromotableThing{} + -> ErrorWithoutFlag + TcRnIllegalTermLevelUse{} + -> ErrorWithoutFlag + TcRnMatchesHaveDiffNumArgs{} + -> ErrorWithoutFlag + TcRnCannotBindScopedTyVarInPatSig{} + -> ErrorWithoutFlag + TcRnCannotBindTyVarsInPatBind{} + -> ErrorWithoutFlag + TcRnMultipleInlinePragmas{} + -> WarningWithoutFlag + TcRnUnexpectedPragmas{} + -> WarningWithoutFlag + TcRnNonOverloadedSpecialisePragma{} + -> WarningWithoutFlag + TcRnSpecialiseNotVisible{} + -> WarningWithoutFlag + TcRnPragmaWarning{pragma_warning_msg} + -> WarningWithCategory (warningTxtCategory pragma_warning_msg) + TcRnDifferentExportWarnings _ _ + -> ErrorWithoutFlag + TcRnIncompleteExportWarnings _ _ + -> WarningWithFlag Opt_WarnIncompleteExportWarnings + TcRnIllegalHsigDefaultMethods{} + -> ErrorWithoutFlag + TcRnHsigFixityMismatch{} + -> ErrorWithoutFlag + TcRnHsigShapeMismatch{} + -> ErrorWithoutFlag + TcRnHsigMissingModuleExport{} + -> ErrorWithoutFlag + TcRnBadGenericMethod{} + -> ErrorWithoutFlag + TcRnWarningMinimalDefIncomplete{} + -> WarningWithoutFlag + TcRnDefaultMethodForPragmaLacksBinding{} + -> ErrorWithoutFlag + TcRnIgnoreSpecialisePragmaOnDefMethod{} + -> WarningWithoutFlag + TcRnBadMethodErr{} + -> ErrorWithoutFlag + TcRnIllegalTypeData + -> ErrorWithoutFlag + TcRnIllegalQuasiQuotes{} + -> ErrorWithoutFlag + TcRnTHError err + -> thErrorReason err + TcRnTypeDataForbids{} + -> ErrorWithoutFlag + TcRnIllegalNewtype{} + -> ErrorWithoutFlag + TcRnOrPatBindsVariables{} + -> ErrorWithoutFlag + TcRnUnsatisfiedMinimalDef{} + -> WarningWithFlag (Opt_WarnMissingMethods) + TcRnMisplacedInstSig{} + -> ErrorWithoutFlag + TcRnNoRebindableSyntaxRecordDot{} + -> ErrorWithoutFlag + TcRnNoFieldPunsRecordDot{} + -> ErrorWithoutFlag + TcRnListComprehensionDuplicateBinding{} + -> ErrorWithoutFlag + TcRnEmptyStmtsGroup{} + -> ErrorWithoutFlag + TcRnLastStmtNotExpr{} + -> ErrorWithoutFlag + TcRnUnexpectedStatementInContext{} + -> ErrorWithoutFlag + TcRnSectionWithoutParentheses{} + -> ErrorWithoutFlag + TcRnIllegalImplicitParameterBindings{} + -> ErrorWithoutFlag + TcRnIllegalTupleSection{} + -> ErrorWithoutFlag + TcRnCapturedTermName{} + -> WarningWithFlag Opt_WarnTermVariableCapture + TcRnBindingOfExistingName{} + -> ErrorWithoutFlag + TcRnMultipleFixityDecls{} + -> ErrorWithoutFlag + TcRnIllegalPatternSynonymDecl{} + -> ErrorWithoutFlag + TcRnIllegalClassBinding{} + -> ErrorWithoutFlag + TcRnOrphanCompletePragma{} + -> ErrorWithoutFlag + TcRnSpecSigShape{} + -> ErrorWithoutFlag + TcRnEmptyCase{} + -> ErrorWithoutFlag + TcRnNonStdGuards{} + -> WarningWithoutFlag + TcRnDuplicateSigDecl{} + -> ErrorWithoutFlag + TcRnMisplacedSigDecl{} + -> ErrorWithoutFlag + TcRnUnexpectedDefaultSig{} + -> ErrorWithoutFlag + TcRnDuplicateMinimalSig{} + -> ErrorWithoutFlag + TcRnUnexpectedStandaloneDerivingDecl{} + -> ErrorWithoutFlag + TcRnUnusedVariableInRuleDecl{} + -> ErrorWithoutFlag + TcRnUnexpectedStandaloneKindSig{} + -> ErrorWithoutFlag + TcRnIllegalRuleLhs{} + -> ErrorWithoutFlag + TcRnRuleLhsEqualities{} + -> WarningWithFlag Opt_WarnRuleLhsEqualities + TcRnDuplicateRoleAnnot{} + -> ErrorWithoutFlag + TcRnDuplicateKindSig{} + -> ErrorWithoutFlag + TcRnIllegalDerivStrategy{} + -> ErrorWithoutFlag + TcRnIllegalMultipleDerivClauses{} + -> ErrorWithoutFlag + TcRnNoDerivStratSpecified{} + -> WarningWithFlag Opt_WarnMissingDerivingStrategies + TcRnStupidThetaInGadt{} + -> ErrorWithoutFlag + TcRnShadowedTyVarNameInFamResult{} + -> ErrorWithoutFlag + TcRnIncorrectTyVarOnLhsOfInjCond{} + -> ErrorWithoutFlag + TcRnUnknownTyVarsOnRhsOfInjCond{} + -> ErrorWithoutFlag + TcRnBadlyLevelled _ _ _ _ reason + -> reason + TcRnBadlyLevelledType{} + -> WarningWithFlag Opt_WarnBadlyLevelledTypes + TcRnTyThingUsedWrong{} + -> ErrorWithoutFlag + TcRnCannotDefaultKindVar{} + -> ErrorWithoutFlag + TcRnUninferrableTyVar{} + -> ErrorWithoutFlag + TcRnSkolemEscape{} + -> ErrorWithoutFlag + TcRnPatSynEscapedCoercion{} + -> ErrorWithoutFlag + TcRnPatSynExistentialInResult{} + -> ErrorWithoutFlag + TcRnPatSynArityMismatch{} + -> ErrorWithoutFlag + TcRnPatSynInvalidRhs{} + -> ErrorWithoutFlag + TcRnTyFamDepsDisabled{} + -> ErrorWithoutFlag + TcRnAbstractClosedTyFamDecl{} + -> ErrorWithoutFlag + TcRnPartialFieldSelector{} + -> WarningWithFlag Opt_WarnPartialFields + TcRnHasFieldResolvedIncomplete{} + -> WarningWithFlag Opt_WarnIncompleteRecordSelectors + TcRnBadFieldAnnotation _ _ LazyFieldsDisabled + -> ErrorWithoutFlag + TcRnBadFieldAnnotation _ _ UnusableUnpackPragma + -> WarningWithFlag Opt_WarnUnusableUnpackPragmas + TcRnBadFieldAnnotation{} + -> WarningWithoutFlag + TcRnSuperclassCycle{} + -> ErrorWithoutFlag + TcRnDefaultSigMismatch{} + -> ErrorWithoutFlag + TcRnTyFamsDisabled{} + -> ErrorWithoutFlag + TcRnBadTyConTelescope {} + -> ErrorWithoutFlag + TcRnTyFamResultDisabled{} + -> ErrorWithoutFlag + TcRnRoleValidationFailed{} + -> ErrorWithoutFlag + TcRnCommonFieldResultTypeMismatch{} + -> ErrorWithoutFlag + TcRnCommonFieldTypeMismatch{} + -> ErrorWithoutFlag + TcRnClassExtensionDisabled{} + -> ErrorWithoutFlag + TcRnDataConParentTypeMismatch{} + -> ErrorWithoutFlag + TcRnGADTsDisabled{} + -> ErrorWithoutFlag + TcRnExistentialQuantificationDisabled{} + -> ErrorWithoutFlag + TcRnGADTDataContext{} + -> ErrorWithoutFlag + TcRnMultipleConForNewtype{} + -> ErrorWithoutFlag + TcRnKindSignaturesDisabled{} + -> ErrorWithoutFlag + TcRnEmptyDataDeclsDisabled{} + -> ErrorWithoutFlag + TcRnRoleMismatch{} + -> ErrorWithoutFlag + TcRnRoleCountMismatch{} + -> ErrorWithoutFlag + TcRnIllegalRoleAnnotation{} + -> ErrorWithoutFlag + TcRnRoleAnnotationsDisabled{} + -> ErrorWithoutFlag + TcRnIncoherentRoles{} + -> ErrorWithoutFlag + TcRnUnexpectedKindVar{} + -> ErrorWithoutFlag + TcRnNegativeNumTypeLiteral{} + -> ErrorWithoutFlag + TcRnIllegalKind{} + -> ErrorWithoutFlag + TcRnPrecedenceParsingError{} + -> ErrorWithoutFlag + TcRnSectionPrecedenceError{} + -> ErrorWithoutFlag + TcRnUnexpectedPatSigType{} + -> ErrorWithoutFlag + TcRnIllegalKindSignature{} + -> ErrorWithoutFlag + TcRnUnusedQuantifiedTypeVar{} + -> WarningWithFlag Opt_WarnUnusedForalls + TcRnDataKindsError{} + -> ErrorWithoutFlag + TcRnTypeSynonymCycle{} + -> ErrorWithoutFlag + TcRnZonkerMessage msg + -> zonkerMessageReason msg + TcRnInterfaceError err + -> interfaceErrorReason err + TcRnSelfImport{} + -> ErrorWithoutFlag + TcRnNoExplicitImportList{} + -> WarningWithFlag Opt_WarnMissingImportList + TcRnSafeImportsDisabled{} + -> ErrorWithoutFlag + TcRnDeprecatedModule _ txt + -> WarningWithCategory (warningTxtCategory txt) + TcRnRedundantSourceImport{} + -> WarningWithoutFlag + TcRnImportLookup{} + -> ErrorWithoutFlag + TcRnUnusedImport{} + -> WarningWithFlag Opt_WarnUnusedImports + TcRnDuplicateDecls{} + -> ErrorWithoutFlag + TcRnPackageImportsDisabled + -> ErrorWithoutFlag + TcRnIllegalDataCon{} + -> ErrorWithoutFlag + TcRnNestedForallsContexts{} + -> ErrorWithoutFlag + TcRnRedundantRecordWildcard + -> WarningWithFlag Opt_WarnRedundantRecordWildcards + TcRnUnusedRecordWildcard{} + -> WarningWithFlag Opt_WarnUnusedRecordWildcards + TcRnUnusedName _ prov + -> WarningWithFlag $ case prov of + UnusedNameTopDecl -> Opt_WarnUnusedTopBinds + UnusedNameImported _ -> Opt_WarnUnusedTopBinds + UnusedNameTypePattern -> Opt_WarnUnusedTypePatterns + UnusedNameMatch -> Opt_WarnUnusedMatches + UnusedNameLocalBind -> Opt_WarnUnusedLocalBinds + TcRnQualifiedBinder{} + -> ErrorWithoutFlag + TcRnTypeApplicationsDisabled{} + -> ErrorWithoutFlag + TcRnInvalidRecordField{} + -> ErrorWithoutFlag + TcRnTupleTooLarge{} + -> ErrorWithoutFlag + TcRnCTupleTooLarge{} + -> ErrorWithoutFlag + TcRnIllegalInferredTyVars{} + -> ErrorWithoutFlag + TcRnAmbiguousName{} + -> ErrorWithoutFlag + TcRnBindingNameConflict{} + -> ErrorWithoutFlag + TcRnNonCanonicalDefinition (NonCanonicalMonoid _) _ + -> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances + TcRnNonCanonicalDefinition (NonCanonicalMonad _) _ + -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances + TcRnDefaultedExceptionContext{} + -> WarningWithFlag Opt_WarnDefaultedExceptionContext + TcRnImplicitImportOfPrelude {} + -> WarningWithFlag Opt_WarnImplicitPrelude + TcRnMissingMain {} + -> ErrorWithoutFlag + TcRnGhciUnliftedBind {} + -> ErrorWithoutFlag + TcRnGhciMonadLookupFail {} + -> ErrorWithoutFlag + TcRnMissingRoleAnnotation{} + -> WarningWithFlag Opt_WarnMissingRoleAnnotations + TcRnIllegalInvisTyVarBndr{} + -> ErrorWithoutFlag + TcRnIllegalWildcardTyVarBndr{} + -> ErrorWithoutFlag + TcRnInvalidInvisTyVarBndr{} + -> ErrorWithoutFlag + TcRnInvisBndrWithoutSig{} + -> ErrorWithoutFlag + TcRnImplicitRhsQuantification{} + -> WarningWithFlag Opt_WarnImplicitRhsQuantification + TcRnPatersonCondFailure{} + -> ErrorWithoutFlag + TcRnIllformedTypePattern{} + -> ErrorWithoutFlag + TcRnIllegalTypePattern{} + -> ErrorWithoutFlag + TcRnIllformedTypeArgument{} + -> ErrorWithoutFlag + TcRnIllegalTypeExpr{} + -> ErrorWithoutFlag + TcRnInvalidDefaultedTyVar{} + -> ErrorWithoutFlag + TcRnNamespacedWarningPragmaWithoutFlag{} + -> ErrorWithoutFlag + TcRnIllegalInvisibleTypePattern{} + -> ErrorWithoutFlag + TcRnNamespacedFixitySigWithoutFlag{} + -> ErrorWithoutFlag + TcRnOutOfArityTyVar{} + -> ErrorWithoutFlag + TcRnUnexpectedTypeSyntaxInTerms{} + -> ErrorWithoutFlag + + diagnosticHints = \case + TcRnUnknownMessage m + -> diagnosticHints m + TcRnMessageWithInfo _ msg_with_info + -> case msg_with_info of + TcRnMessageDetailed info m -> + errInfoHints info ++ diagnosticHints m + TcRnWithHsDocContext _ msg + -> diagnosticHints msg + TcRnSolverReport (SolverReportWithCtxt ctxt msg) _ + -> tcSolverReportMsgHints ctxt msg + TcRnSolverDepthError {} + -> [SuggestIncreaseReductionDepth] + TcRnRedundantConstraints{} + -> noHints + TcRnInaccessibleCode{} + -> noHints + TcRnInaccessibleCoAxBranch{} + -> noHints + TcRnTypeDoesNotHaveFixedRuntimeRep{} + -> noHints + TcRnImplicitLift{} + -> noHints + TcRnUnusedPatternBinds{} + -> noHints + TcRnDodgyImports{} + -> noHints + TcRnDodgyExports{} + -> noHints + TcRnMissingImportList{} + -> noHints + TcRnUnsafeDueToPlugin{} + -> noHints + TcRnModMissingRealSrcSpan{} + -> noHints + TcRnIdNotExportedFromModuleSig name mod + -> [SuggestAddToHSigExportList name $ Just mod] + TcRnIdNotExportedFromLocalSig name + -> [SuggestAddToHSigExportList name Nothing] + TcRnShadowedName{} + -> noHints + TcRnInvalidWarningCategory{} + -> noHints + TcRnDuplicateWarningDecls{} + -> noHints + TcRnSimplifierTooManyIterations{} + -> [SuggestIncreaseSimplifierIterations] + TcRnIllegalPatSynDecl{} + -> noHints + TcRnLinearPatSyn{} + -> noHints + TcRnEmptyRecordUpdate{} + -> noHints + TcRnIllegalFieldPunning{} + -> [suggestExtension LangExt.NamedFieldPuns] + TcRnIllegalWildcardsInRecord{} + -> [suggestExtension LangExt.RecordWildCards] + TcRnIllegalWildcardInType{} + -> noHints + TcRnIllegalNamedWildcardInTypeArgument{} + -> [SuggestAnonymousWildcard] + TcRnIllegalImplicitTyVarInTypeArgument tv + -> [SuggestExplicitQuantification tv] + TcRnIllegalPunnedVarOccInTypeArgument{} + -> [] + TcRnDuplicateFieldName{} + -> noHints + TcRnIllegalViewPattern{} + -> [suggestExtension LangExt.ViewPatterns] + TcRnCharLiteralOutOfRange{} + -> noHints + TcRnIllegalWildcardsInConstructor{} + -> noHints + TcRnIgnoringAnnotations{} + -> noHints + TcRnAnnotationInSafeHaskell + -> noHints + TcRnInvalidTypeApplication{} + -> noHints + TcRnTagToEnumMissingValArg + -> noHints + TcRnTagToEnumUnspecifiedResTy{} + -> noHints + TcRnTagToEnumResTyNotAnEnum{} + -> noHints + TcRnTagToEnumResTyTypeData{} + -> noHints + TcRnArrowIfThenElsePredDependsOnResultTy + -> noHints + TcRnIllegalHsBootOrSigDecl {} + -> noHints + TcRnBootMismatch boot_or_sig err + | Hsig <- boot_or_sig + , BootMismatch _ _ (BootMismatchedTyCons _boot_tc real_tc tc_errs) <- err + , any is_synAbsData_etaReduce (NE.toList tc_errs) + -> [SuggestEtaReduceAbsDataTySyn real_tc] + | otherwise + -> noHints + where + is_synAbsData_etaReduce (SynAbstractData SynAbsDataTySynNotNullary) = True + is_synAbsData_etaReduce _ = False + TcRnRecursivePatternSynonym{} + -> noHints + TcRnPartialTypeSigTyVarMismatch{} + -> noHints + TcRnPartialTypeSigBadQuantifier{} + -> noHints + TcRnMissingSignature {} + -> noHints + TcRnPolymorphicBinderMissingSig{} + -> noHints + TcRnOverloadedSig{} + -> noHints + TcRnTupleConstraintInst{} + -> noHints + TcRnUserTypeError{} + -> noHints + TcRnConstraintInKind{} + -> noHints + TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum _ + -> [suggestExtension $ unboxedTupleOrSumExtension tuple_or_sum] + TcRnLinearFuncInKind{} + -> noHints + TcRnForAllEscapeError{} + -> noHints + TcRnVDQInTermType mb_ty + | isJust mb_ty -> [suggestExtension LangExt.RequiredTypeArguments] + | otherwise -> [] + TcRnBadQuantPredHead{} + -> noHints + TcRnIllegalTupleConstraint{} + -> [suggestExtension LangExt.ConstraintKinds] + TcRnNonTypeVarArgInConstraint{} + -> [suggestExtension LangExt.FlexibleContexts] + TcRnIllegalImplicitParam{} + -> noHints + TcRnIllegalConstraintSynonymOfKind{} + -> [suggestExtension LangExt.ConstraintKinds] + TcRnOversaturatedVisibleKindArg{} + -> noHints + TcRnForAllRankErr rank _ + -> case rank of + LimitedRank{} -> [suggestExtension LangExt.RankNTypes] + MonoTypeRankZero -> [suggestExtension LangExt.RankNTypes] + MonoTypeTyConArg -> [suggestExtension LangExt.ImpredicativeTypes] + MonoTypeSynArg -> [suggestExtension LangExt.LiberalTypeSynonyms] + MonoTypeConstraint -> [suggestExtension LangExt.QuantifiedConstraints] + _ -> noHints + TcRnSimplifiableConstraint{} + -> noHints + TcRnArityMismatch{} + -> noHints + TcRnIllegalInstance rea + -> illegalInstanceHints rea + TcRnMonomorphicBindings bindings + -> case bindings of + [] -> noHints + (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)] + TcRnOrphanInstance clsOrFamInst + -> [SuggestFixOrphanInst { isFamilyInstance = isFam }] + where + isFam = case clsOrFamInst :: Either ClsInst FamInst of + Left _clsInst -> Nothing + Right famInst -> Just $ fi_flavor famInst + TcRnFunDepConflict{} + -> noHints + TcRnDupInstanceDecls{} + -> noHints + TcRnConflictingFamInstDecls{} + -> noHints + TcRnFamInstNotInjective rea _ _ + -> case rea of + InjErrRhsBareTyVar{} -> noHints + InjErrRhsCannotBeATypeFam -> noHints + InjErrRhsOverlap -> noHints + InjErrCannotInferFromRhs _ _ suggestUndInst + | YesSuggestUndecidableInstaces <- suggestUndInst + -> [suggestExtension LangExt.UndecidableInstances] + | otherwise + -> noHints + TcRnBangOnUnliftedType{} + -> noHints + TcRnLazyBangOnUnliftedType{} + -> noHints + TcRnMultipleDefaultDeclarations{} + -> noHints + TcRnBadDefaultType{} + -> noHints + TcRnPatSynBundledWithNonDataCon{} + -> noHints + TcRnPatSynBundledWithWrongType{} + -> noHints + TcRnDupeModuleExport{} + -> noHints + TcRnExportedModNotImported{} + -> noHints + TcRnNullExportedModule{} + -> noHints + TcRnMissingExportList{} + -> noHints + TcRnExportHiddenComponents{} + -> noHints + TcRnExportHiddenDefault{} + -> noHints + TcRnDuplicateExport{} + -> noHints + TcRnDuplicateNamedDefaultExport{} + -> noHints + TcRnExportedParentChildMismatch{} + -> noHints + TcRnConflictingExports{} + -> noHints + TcRnDuplicateFieldExport {} + -> [suggestExtension LangExt.DuplicateRecordFields] + TcRnAmbiguousFieldInUpdate {} + -> [suggestExtension LangExt.DisambiguateRecordFields] + TcRnAmbiguousRecordUpdate{} + -> noHints + TcRnMissingFields{} + -> noHints + TcRnFieldUpdateInvalidType{} + -> noHints + TcRnMissingStrictFields{} + -> noHints + TcRnBadRecordUpdate{} + -> noHints + TcRnIllegalStaticExpression {} + -> [suggestExtension LangExt.StaticPointers] + TcRnStaticFormNotClosed{} + -> noHints + TcRnUselessTypeable + -> noHints + TcRnDerivingDefaults{} + -> [useDerivingStrategies] + TcRnNonUnaryTypeclassConstraint{} + -> noHints + TcRnPartialTypeSignatures suggestParSig _ + -> case suggestParSig of + YesSuggestPartialTypeSignatures + -> let info = text "to use the inferred type" + in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures] + NoSuggestPartialTypeSignatures + -> noHints + TcRnCannotDeriveInstance cls _ _ newtype_deriving rea + -> deriveInstanceErrReasonHints cls newtype_deriving rea + TcRnLookupInstance _ _ _ + -> noHints + TcRnLazyGADTPattern + -> noHints + TcRnArrowProcGADTPattern + -> noHints + TcRnTypeEqualityOutOfScope + -> noHints + TcRnTypeEqualityRequiresOperators + -> [suggestExtension LangExt.TypeOperators] + TcRnIllegalTypeOperator {} + -> [suggestExtension LangExt.TypeOperators] + TcRnIllegalTypeOperatorDecl {} + -> [suggestExtension LangExt.TypeOperators] + TcRnGADTMonoLocalBinds {} + -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]] + TcRnIncorrectNameSpace nm is_th_use + | is_th_use + -> [SuggestAppropriateTHTick (nameNameSpace nm)] + | otherwise + -> noHints + TcRnNotInScope err _nm + -> scopeErrorHints err + TcRnTermNameInType {} + -> noHints + TcRnUntickedPromotedThing thing + -> [SuggestAddTick thing] + TcRnIllegalBuiltinSyntax {} + -> noHints + TcRnWarnDefaulting {} + -> noHints + TcRnWarnClashingDefaultImports cls local imports + -> suggestDefaultDeclaration cls (fold local) (cd_types <$> NE.toList imports) + TcRnForeignImportPrimExtNotSet{} + -> [suggestExtension LangExt.GHCForeignImportPrim] + TcRnForeignImportPrimSafeAnn{} + -> noHints + TcRnForeignFunctionImportAsValue{} + -> noHints + TcRnFunPtrImportWithoutAmpersand{} + -> noHints + TcRnIllegalForeignDeclBackend{} + -> noHints + TcRnUnsupportedCallConv{} + -> noHints + TcRnIllegalForeignType _ reason + -> case reason of + TypeCannotBeMarshaled _ why + | NewtypeDataConNotInScope tc _ <- why + -> let tc_nm = tyConName tc + dc = dataConName $ head $ tyConDataCons tc + in [ ImportSuggestion (occName dc) + $ ImportDataCon Nothing False False (nameOccName tc_nm) ] + | UnliftedFFITypesNeeded <- why + -> [suggestExtension LangExt.UnliftedFFITypes] + _ -> noHints + TcRnInvalidCIdentifier{} + -> noHints + TcRnExpectedValueId{} + -> noHints + TcRnRecSelectorEscapedTyVar{} + -> [SuggestPatternMatchingSyntax] + TcRnPatSynNotBidirectional{} + -> noHints + TcRnIllegalDerivingItem{} + -> noHints + TcRnIllegalDefaultClass{} + -> noHints + TcRnIllegalNamedDefault{} + -> [suggestExtension LangExt.NamedDefaults] + TcRnUnexpectedAnnotation{} + -> noHints + TcRnIllegalRecordSyntax{} + -> noHints + TcRnInvalidVisibleKindArgument{} + -> noHints + TcRnTooManyBinders{} + -> noHints + TcRnDifferentNamesForTyVar{} + -> noHints + TcRnDisconnectedTyVar n + -> [SuggestBindTyVarExplicitly n] + TcRnInvalidReturnKind _ _ _ mb_suggest_unlifted_ext + -> case mb_suggest_unlifted_ext of + Nothing -> noHints + Just SuggestUnliftedNewtypes -> [suggestExtension LangExt.UnliftedNewtypes] + Just SuggestUnliftedDatatypes -> [suggestExtension LangExt.UnliftedDatatypes] + TcRnClassKindNotConstraint{} + -> noHints + TcRnUnpromotableThing{} + -> noHints + TcRnIllegalTermLevelUse {} + -> noHints + TcRnMatchesHaveDiffNumArgs{} + -> noHints + TcRnCannotBindScopedTyVarInPatSig{} + -> noHints + TcRnCannotBindTyVarsInPatBind{} + -> noHints + TcRnMultipleInlinePragmas{} + -> noHints + TcRnUnexpectedPragmas{} + -> noHints + TcRnNonOverloadedSpecialisePragma{} + -> noHints + TcRnSpecialiseNotVisible name + -> [SuggestSpecialiseVisibilityHints name] + TcRnPragmaWarning{} + -> noHints + TcRnDifferentExportWarnings _ _ + -> noHints + TcRnIncompleteExportWarnings _ _ + -> noHints + TcRnIllegalHsigDefaultMethods{} + -> noHints + TcRnIllegalQuasiQuotes{} + -> [suggestExtension LangExt.QuasiQuotes] + TcRnTHError err + -> thErrorHints err + TcRnHsigFixityMismatch{} + -> noHints + TcRnHsigShapeMismatch{} + -> noHints + TcRnHsigMissingModuleExport{} + -> noHints + TcRnBadGenericMethod{} + -> noHints + TcRnWarningMinimalDefIncomplete{} + -> noHints + TcRnDefaultMethodForPragmaLacksBinding{} + -> noHints + TcRnIgnoreSpecialisePragmaOnDefMethod{} + -> noHints + TcRnBadMethodErr{} + -> noHints + TcRnIllegalTypeData + -> [suggestExtension LangExt.TypeData] + TcRnTypeDataForbids{} + -> noHints + TcRnIllegalNewtype{} + -> noHints + TcRnOrPatBindsVariables{} + -> noHints + TcRnUnsatisfiedMinimalDef{} + -> noHints + TcRnMisplacedInstSig{} + -> [suggestExtension LangExt.InstanceSigs] + TcRnNoRebindableSyntaxRecordDot{} + -> noHints + TcRnNoFieldPunsRecordDot{} + -> noHints + TcRnListComprehensionDuplicateBinding{} + -> noHints + TcRnEmptyStmtsGroup EmptyStmtsGroupInDoNotation{} + -> [suggestExtension LangExt.NondecreasingIndentation] + TcRnEmptyStmtsGroup{} + -> noHints + TcRnLastStmtNotExpr{} + -> noHints + TcRnUnexpectedStatementInContext _ _ mExt + | Nothing <- mExt -> noHints + | Just ext <- mExt -> [suggestExtension ext] + TcRnSectionWithoutParentheses{} + -> noHints + TcRnIllegalImplicitParameterBindings{} + -> noHints + TcRnIllegalTupleSection{} + -> [suggestExtension LangExt.TupleSections] + TcRnCapturedTermName{} + -> [SuggestRenameTypeVariable] + TcRnBindingOfExistingName{} + -> noHints + TcRnMultipleFixityDecls{} + -> noHints + TcRnIllegalPatternSynonymDecl{} + -> [suggestExtension LangExt.PatternSynonyms] + TcRnIllegalClassBinding{} + -> noHints + TcRnOrphanCompletePragma{} + -> noHints + TcRnEmptyCase _ reason -> + case reason of + EmptyCaseWithoutFlag{} -> [suggestExtension LangExt.EmptyCase] + EmptyCaseDisallowedCtxt{} -> noHints + EmptyCaseForall{} -> noHints + TcRnSpecSigShape{} + -> noHints + TcRnNonStdGuards{} + -> [suggestExtension LangExt.PatternGuards] + TcRnDuplicateSigDecl{} + -> noHints + TcRnMisplacedSigDecl{} + -> noHints + TcRnUnexpectedDefaultSig{} + -> [suggestExtension LangExt.DefaultSignatures] + TcRnDuplicateMinimalSig{} + -> noHints + TcRnUnexpectedStandaloneDerivingDecl{} + -> [suggestExtension LangExt.StandaloneDeriving] + TcRnUnusedVariableInRuleDecl{} + -> noHints + TcRnUnexpectedStandaloneKindSig{} + -> [suggestExtension LangExt.StandaloneKindSignatures] + TcRnIllegalRuleLhs{} + -> noHints + TcRnRuleLhsEqualities{} + -> noHints + TcRnDuplicateRoleAnnot{} + -> noHints + TcRnDuplicateKindSig{} + -> noHints + TcRnIllegalDerivStrategy ds -> case ds of + ViaStrategy{} -> [suggestExtension LangExt.DerivingVia] + _ -> [suggestExtension LangExt.DerivingStrategies] + TcRnIllegalMultipleDerivClauses{} + -> [suggestExtension LangExt.DerivingStrategies] + TcRnNoDerivStratSpecified is_ds_enabled info -> do + let explicit_strategy_hint = case info of + TcRnNoDerivingClauseStrategySpecified assumed_derivings -> + SuggestExplicitDerivingClauseStrategies assumed_derivings + TcRnNoStandaloneDerivingStrategySpecified assumed_strategy deriv_sig -> + SuggestExplicitStandaloneDerivingStrategy assumed_strategy deriv_sig + explicit_strategy_hint : [suggestExtension LangExt.DerivingStrategies | not is_ds_enabled] + TcRnStupidThetaInGadt{} + -> noHints + TcRnShadowedTyVarNameInFamResult{} + -> noHints + TcRnIncorrectTyVarOnLhsOfInjCond{} + -> noHints + TcRnUnknownTyVarsOnRhsOfInjCond{} + -> noHints + TcRnBadlyLevelled{} + -> noHints + TcRnBadlyLevelledType{} + -> noHints + TcRnTyThingUsedWrong{} + -> noHints + TcRnCannotDefaultKindVar{} + -> noHints + TcRnUninferrableTyVar{} + -> noHints + TcRnSkolemEscape{} + -> noHints + TcRnPatSynEscapedCoercion{} + -> noHints + TcRnPatSynExistentialInResult{} + -> noHints + TcRnPatSynArityMismatch{} + -> noHints + TcRnPatSynInvalidRhs name pat args (PatSynNotInvertible _) + -> [SuggestExplicitBidiPatSyn name pat args] + TcRnPatSynInvalidRhs{} + -> noHints + TcRnTyFamDepsDisabled{} + -> [suggestExtension LangExt.TypeFamilyDependencies] + TcRnAbstractClosedTyFamDecl{} + -> noHints + TcRnPartialFieldSelector{} + -> noHints + TcRnHasFieldResolvedIncomplete{} + -> noHints + TcRnBadFieldAnnotation _ _ LazyFieldsDisabled + -> [suggestExtension LangExt.StrictData] + TcRnBadFieldAnnotation{} + -> noHints + TcRnSuperclassCycle{} + -> [suggestExtension LangExt.UndecidableSuperClasses] + TcRnDefaultSigMismatch{} + -> noHints + TcRnTyFamsDisabled{} + -> [suggestExtension LangExt.TypeFamilies] + TcRnBadTyConTelescope{} + -> noHints + TcRnTyFamResultDisabled{} + -> [suggestExtension LangExt.TypeFamilyDependencies] + TcRnRoleValidationFailed{} + -> noHints + TcRnCommonFieldResultTypeMismatch{} + -> noHints + TcRnCommonFieldTypeMismatch{} + -> noHints + TcRnClassExtensionDisabled _ MultiParamDisabled{} + -> [suggestExtension LangExt.MultiParamTypeClasses] + TcRnClassExtensionDisabled _ FunDepsDisabled{} + -> [suggestExtension LangExt.FunctionalDependencies] + TcRnClassExtensionDisabled _ ConstrainedClassMethodsDisabled{} + -> [suggestExtension LangExt.ConstrainedClassMethods] + TcRnDataConParentTypeMismatch{} + -> noHints + TcRnGADTsDisabled{} + -> [suggestExtension LangExt.GADTs] + TcRnExistentialQuantificationDisabled{} + -> [suggestAnyExtension [LangExt.ExistentialQuantification, LangExt.GADTs]] + TcRnGADTDataContext{} + -> noHints + TcRnMultipleConForNewtype{} + -> noHints + TcRnKindSignaturesDisabled{} + -> [suggestExtension LangExt.KindSignatures] + TcRnEmptyDataDeclsDisabled{} + -> [suggestExtension LangExt.EmptyDataDecls] + TcRnRoleMismatch{} + -> noHints + TcRnRoleCountMismatch{} + -> noHints + TcRnIllegalRoleAnnotation{} + -> noHints + TcRnRoleAnnotationsDisabled{} + -> [suggestExtension LangExt.RoleAnnotations] + TcRnIncoherentRoles{} + -> [suggestExtension LangExt.IncoherentInstances] + TcRnUnexpectedKindVar{} + -> [suggestExtension LangExt.PolyKinds] + TcRnNegativeNumTypeLiteral{} + -> noHints + TcRnIllegalKind _ suggest_polyKinds + -> if suggest_polyKinds + then [suggestExtension LangExt.PolyKinds] + else noHints + TcRnPrecedenceParsingError{} + -> noHints + TcRnSectionPrecedenceError{} + -> noHints + TcRnUnexpectedPatSigType{} + -> [suggestExtension LangExt.ScopedTypeVariables] + TcRnIllegalKindSignature{} + -> [suggestExtension LangExt.KindSignatures] + TcRnUnusedQuantifiedTypeVar{} + -> noHints + TcRnDataKindsError{} + -> [suggestExtension LangExt.DataKinds] + TcRnTypeSynonymCycle{} + -> noHints + TcRnZonkerMessage msg + -> zonkerMessageHints msg + TcRnInterfaceError reason + -> interfaceErrorHints reason + TcRnSelfImport{} + -> noHints + TcRnNoExplicitImportList{} + -> noHints + TcRnSafeImportsDisabled{} + -> [SuggestSafeHaskell] + TcRnDeprecatedModule{} + -> noHints + TcRnRedundantSourceImport{} + -> noHints + TcRnImportLookup (ImportLookupBad k _ is ie exts) -> + let mod_name = moduleName $ is_mod is + occ = rdrNameOcc $ ieName ie + could_change_item item_suggestion = + [useExtensionInOrderTo empty LangExt.ExplicitNamespaces | suggest_ext] ++ + [ ImportSuggestion occ $ + CouldChangeImportItem mod_name item_suggestion ] + where + suggest_ext + | ile_explicit_namespaces exts = False -- extension already on + | otherwise = + case item_suggestion of + -- ImportItemRemove* -> False + ImportItemRemoveType{} -> False + ImportItemRemoveData{} -> False + ImportItemRemovePattern{} -> False + ImportItemRemoveSubordinateType{} -> False + ImportItemRemoveSubordinateData{} -> False + -- ImportItemAdd* -> True + ImportItemAddType{} -> True + in case k of + BadImportAvailVar -> could_change_item ImportItemRemoveType + BadImportNotExported suggs -> suggs + BadImportAvailTyCon + -- The three cases (TyOp, DataKw, PatternKw) are laid out + -- in Note [Reasons for BadImportAvailTyCon] in GHC.Tc.Errors.Types + | isSymOcc occ -> could_change_item ImportItemAddType -- Case (TyOp) + | otherwise -> -- Non-operator cases + case unLoc (ieLIEWrappedName ie) of + IEData{} -> could_change_item ImportItemRemoveData -- Case (DataKw) + IEPattern{} -> could_change_item ImportItemRemovePattern -- Case (PatternKw) + _ -> panic "diagnosticHints: unexpected BadImportAvailTyCon" + + BadImportAvailDataCon par -> + [ ImportSuggestion occ $ + ImportDataCon { ies_suggest_import_from = Just mod_name + , ies_suggest_pattern_keyword = ile_pattern_synonyms exts + && not (ile_explicit_namespaces exts) -- do not suggest 'pattern' when we can suggest 'data' + , ies_suggest_data_keyword = ile_explicit_namespaces exts + , ies_parent = par } ] + BadImportNotExportedSubordinates{} -> noHints + BadImportNonTypeSubordinates _ nontype1 -> + could_change_item (ImportItemRemoveSubordinateType (nameOccName . greName <$> nontype1)) + BadImportNonDataSubordinates _ nondata1 -> + could_change_item (ImportItemRemoveSubordinateData (nameOccName . greName <$> nondata1)) + TcRnImportLookup{} + -> noHints + TcRnUnusedImport{} + -> noHints + TcRnDuplicateDecls _ fs + -> [suggestExtension LangExt.DuplicateRecordFields | all isFieldName fs] + TcRnPackageImportsDisabled + -> [suggestExtension LangExt.PackageImports] + TcRnIllegalDataCon{} + -> noHints + TcRnNestedForallsContexts{} + -> noHints + TcRnRedundantRecordWildcard + -> [SuggestRemoveRecordWildcard] + TcRnUnusedRecordWildcard{} + -> [SuggestRemoveRecordWildcard] + TcRnUnusedName{} + -> noHints + TcRnQualifiedBinder{} + -> noHints + TcRnTypeApplicationsDisabled{} + -> [suggestExtension LangExt.TypeApplications] + TcRnInvalidRecordField{} + -> noHints + TcRnTupleTooLarge{} + -> noHints + TcRnCTupleTooLarge{} + -> noHints + TcRnIllegalInferredTyVars{} + -> noHints + TcRnAmbiguousName{} + -> noHints + TcRnBindingNameConflict{} + -> noHints + TcRnNonCanonicalDefinition reason _ + -> suggestNonCanonicalDefinition reason + TcRnDefaultedExceptionContext _ + -> noHints + TcRnImplicitImportOfPrelude {} + -> noHints + TcRnMissingMain {} + -> noHints + TcRnGhciUnliftedBind {} + -> noHints + TcRnGhciMonadLookupFail {} + -> noHints + TcRnMissingRoleAnnotation{} + -> noHints + TcRnIllegalInvisTyVarBndr{} + -> [suggestExtension LangExt.TypeAbstractions] + TcRnIllegalWildcardTyVarBndr{} + -> [suggestExtension LangExt.TypeAbstractions] + TcRnInvalidInvisTyVarBndr{} + -> noHints + TcRnInvisBndrWithoutSig name _ + -> [SuggestAddStandaloneKindSignature name] + TcRnImplicitRhsQuantification kv + -> [SuggestBindTyVarOnLhs (unLoc kv)] + TcRnPatersonCondFailure{} + -> [suggestExtension LangExt.UndecidableInstances] + TcRnIllformedTypePattern{} + -> noHints + TcRnIllegalTypePattern{} + -> noHints + TcRnIllformedTypeArgument{} + -> noHints + TcRnIllegalTypeExpr{} + -> noHints + TcRnInvalidDefaultedTyVar{} + -> noHints + TcRnNamespacedWarningPragmaWithoutFlag{} + -> [suggestExtension LangExt.ExplicitNamespaces] + TcRnIllegalInvisibleTypePattern _ reason + -> case reason of + InvisPatWithoutFlag -> [suggestExtension LangExt.TypeAbstractions] + InvisPatNoForall -> noHints + InvisPatMisplaced -> noHints + TcRnNamespacedFixitySigWithoutFlag{} + -> [suggestExtension LangExt.ExplicitNamespaces] + TcRnOutOfArityTyVar{} + -> noHints + TcRnUnexpectedTypeSyntaxInTerms syntax + -> [suggestExtension (typeSyntaxExtension syntax)] + + diagnosticCode = constructorCode @GHC + +pprTcRnBadlyLevelled :: LevelCheckReason -> Set.Set ThLevelIndex -> ThLevelIndex -> Maybe ErrorItem -> DecoratedSDoc +pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt = mkDecorated $ + [ fsep [ text "Level error:", pprLevelCheckReason reason + , text "is bound at" <+> pprThBindLevel bind_lvls + , text "but used at level" <+> ppr use_lvl] + ] ++ + [hang (text "Could not be resolved by implicit lifting due to the following error:") 2 + (text "No instance for:" <+> quotes (ppr (errorItemPred item))) + | Just item <- [lift_attempt] + ] ++ + [ vcat (text "Available from the imports:" : ppr_imports (gre_imp gre)) + | LevelCheckSplice _ (Just gre) <- [reason] + , not (isEmptyBag (gre_imp gre)) ] + where + ppr_imports :: Bag ImportSpec -> [SDoc] + ppr_imports = map ((bullet <+>) . ppr ) . bagToList + +note :: SDoc -> SDoc +note note = "Note" <> colon <+> note <> dot + +-- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z", +-- and so on. The `and` stands for any `conjunction`, which is passed in. +commafyWith :: SDoc -> [SDoc] -> [SDoc] +commafyWith _ [] = [] +commafyWith _ [x] = [x] +commafyWith conjunction [x, y] = [x <+> conjunction <+> y] +commafyWith conjunction xs = addConjunction $ punctuate comma xs + where addConjunction [x, y] = [x, conjunction, y] + addConjunction (x : xs) = x : addConjunction xs + addConjunction _ = panic "commafyWith expected 2 or more elements" + +deriveInstanceErrReasonHints :: Class + -> UsingGeneralizedNewtypeDeriving + -> DeriveInstanceErrReason + -> [GhcHint] +deriveInstanceErrReasonHints cls newtype_deriving = \case + DerivErrNotWellKinded _ _ n_args_to_keep + | cls `hasKey` gen1ClassKey && n_args_to_keep >= 0 + -> [suggestExtension LangExt.PolyKinds] + | otherwise + -> noHints + DerivErrSafeHaskellGenericInst -> noHints + DerivErrDerivingViaWrongKind{} -> noHints + DerivErrNoEtaReduce{} -> noHints + DerivErrBootFileFound -> noHints + DerivErrDataConsNotAllInScope{} -> noHints + DerivErrGNDUsedOnData -> noHints + DerivErrNullaryClasses -> noHints + DerivErrLastArgMustBeApp -> noHints + DerivErrNoFamilyInstance{} -> noHints + DerivErrNotStockDeriveable deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrHasAssociatedDatatypes{} + -> noHints + DerivErrNewtypeNonDeriveableClass + | newtype_deriving == NoGeneralizedNewtypeDeriving + -> [useGND] + | otherwise + -> noHints + DerivErrCannotEtaReduceEnough{} + | newtype_deriving == NoGeneralizedNewtypeDeriving + -> [useGND] + | otherwise + -> noHints + DerivErrOnlyAnyClassDeriveable _ deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrNotDeriveable deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrNotAClass{} + -> noHints + DerivErrNoConstructors{} + -> let info = text "to enable deriving for empty data types" + in [useExtensionInOrderTo info LangExt.EmptyDataDeriving] + DerivErrLangExtRequired{} + -- This is a slightly weird corner case of GHC: we are failing + -- to derive a typeclass instance because a particular 'Extension' + -- is not enabled (and so we report in the main error), but here + -- we don't want to /repeat/ to enable the extension in the hint. + -> noHints + DerivErrDunnoHowToDeriveForType{} + -> noHints + DerivErrMustBeEnumType rep_tc + -- We want to suggest GND only if this /is/ a newtype. + | newtype_deriving == NoGeneralizedNewtypeDeriving && isNewTyCon rep_tc + -> [useGND] + | otherwise + -> noHints + DerivErrMustHaveExactlyOneConstructor{} + -> noHints + DerivErrMustHaveSomeParameters{} + -> noHints + DerivErrMustNotHaveClassContext{} + -> noHints + DerivErrBadConstructor wcard _ + -> case wcard of + Nothing -> noHints + Just YesHasWildcard -> [SuggestFillInWildcardConstraint] + Just NoHasWildcard -> [SuggestAddStandaloneDerivation] + DerivErrGenerics{} + -> noHints + DerivErrEnumOrProduct{} + -> noHints + +-------------------------------------------------------------------------------- + +-- | Pretty-print supplementary information, to add to an error report. +pprSolverReportSupplementary :: HoleFitDispConfig -> SupplementaryInfo -> 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 + SupplementaryImportErrors errs -> vcat (map ppr $ NE.toList errs) + +-- | 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)" + +-- For pretty printing hole fits, we display the name and type of the fit, +-- with added '_' to represent any extra arguments in case of a non-zero +-- refinement level. +pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc +pprHoleFit _ (RawHoleFit sd) = sd +pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (TcHoleFit (HoleFit {..})) = + hang display 2 provenance + where tyApp = sep $ zipWithEqual pprArg vars hfWrap + where pprArg b arg = case binderFlag b of + Specified -> text "@" <> pprParendType arg + -- Do not print type application for inferred + -- variables (#16456) + Inferred -> empty + Required -> pprPanic "pprHoleFit: bad Required" + (ppr b <+> ppr arg) + tyAppVars = sep $ punctuate comma $ + zipWithEqual (\v t -> ppr (binderVar v) <+> text "~" <+> pprParendType t) + vars hfWrap + + vars = unwrapTypeVars hfType + where + -- Attempts to get all the quantified type variables in a type, + -- e.g. + -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) + -- into [m, a] + unwrapTypeVars :: Type -> [ForAllTyBinder] + unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of + Just (_, _, _, unfunned) -> unwrapTypeVars unfunned + _ -> [] + where (vars, unforalled) = splitForAllForAllTyBinders t + holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches + holeDisp = if sMs then holeVs + else sep $ replicate (length hfMatches) $ text "_" + occDisp = case hfCand of + GreHFCand gre -> pprPrefixOcc (greName gre) + NameHFCand name -> pprPrefixOcc name + IdHFCand id_ -> pprPrefixOcc id_ + tyDisp = ppWhen sTy $ dcolon <+> ppr hfType + has = not . null + wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars)) + $ text "with" <+> if sWrp || not sTy + then occDisp <+> tyApp + else tyAppVars + docs = case hfDoc of + Just d -> pprHsDocStrings d + _ -> empty + funcInfo = ppWhen (has hfMatches && sTy) $ + text "where" <+> occDisp <+> tyDisp + subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp + display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp) + provenance = ppWhen sProv $ parens $ + case hfCand of + GreHFCand gre -> pprNameProvenance gre + NameHFCand name -> text "bound at" <+> ppr (getSrcLoc name) + IdHFCand id_ -> text "bound at" <+> ppr (getSrcLoc id_) + +-- | Add a "Constraints include..." message. +-- +-- See Note [Constraints include ...] +pprConstraintsInclude :: NE.NonEmpty (PredType, RealSrcSpan) -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprConstraintsInclude cts + = hang (text "Constraints include") + 2 (vcat $ map pprConstraint $ NE.toList cts) + where + pprConstraint (constraint, loc) = + ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) + +messageWithInfoDiagnosticMessage :: UnitState + -> ErrInfo + -> Bool + -> DecoratedSDoc + -> DecoratedSDoc +messageWithInfoDiagnosticMessage unit_state (ErrInfo {..}) show_ctxt important = + let ctxt = pprWithUnitState unit_state + $ vcat $ map pprErrCtxtMsg [ ctx | ctx <- errInfoContext, show_ctxt ] + + supp = case errInfoSupplementary of + Nothing -> empty + Just (hfdc, supp_msgs) -> + pprWithUnitState unit_state $ + vcat $ map (pprSolverReportSupplementary hfdc) supp_msgs + in mapDecoratedSDoc (pprWithUnitState unit_state) important + `unionDecoratedSDoc` + mkDecorated [ctxt, supp] + +messageWithHsDocContext :: TcRnMessageOpts -> HsDocContext -> DecoratedSDoc -> DecoratedSDoc +messageWithHsDocContext opts ctxt main_msg = do + if tcOptsShowContext opts + then main_msg `unionDecoratedSDoc` ctxt_msg + else main_msg + where + ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt) + +-------------------------------------------------------------------------------- + +dodgy_msg :: Outputable ie => SDoc -> GlobalRdrElt -> ie -> SDoc +dodgy_msg kind tc ie + = vcat [ text "The" <+> kind <+> text "item" <+> quotes (ppr ie) <+> text "suggests that" + , quotes (ppr $ greName tc) <+> text "has" <+> sep rest ] + where + rest :: [SDoc] + rest = + case greInfo tc of + IAmTyCon ClassFlavour + -> [ text "(in-scope) class methods or associated types" <> comma + , text "but it has none" ] + IAmTyCon _ + -> [ text "(in-scope) constructors or record fields" <> comma + , text "but it has none" ] + _ -> [ text "children" <> comma + , text "but it is not a type constructor or a class" ] + +dodgy_msg_insert :: GlobalRdrElt -> IE GhcRn +dodgy_msg_insert tc_gre = IEThingAll (Nothing, noAnn) ii Nothing + where + ii = noLocA (IEName noExtField $ noLocA $ greName tc_gre) + +pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc +pprTypeDoesNotHaveFixedRuntimeRep ty prov = + let what = pprFixedRuntimeRepProvenance prov + in text "The" <+> what <+> text "does not have a fixed runtime representation:" + $$ format_frr_err ty + +format_frr_err :: Type -- ^ the type which doesn't have a fixed runtime representation + -> SDoc +format_frr_err ty + = (bullet <+> ppr tidy_ty <+> dcolon <+> ppr tidy_ki) + where + (tidy_env, tidy_ty) = tidyOpenTypeX emptyTidyEnv ty + tidy_ki = tidyType tidy_env (typeKind ty) + +pprField :: (FieldLabelString, TcType) -> SDoc +pprField (f,ty) = ppr f <+> dcolon <+> ppr ty + +pprRecordFieldPart :: RecordFieldPart -> SDoc +pprRecordFieldPart = \case + RecordFieldDecl {} -> text "declaration" + RecordFieldConstructor{} -> text "construction" + RecordFieldPattern{} -> text "pattern" + RecordFieldUpdate -> text "update" + +ppr_opfix :: (OpName, Fixity) -> SDoc +ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) + where + pp_op | NegateOp <- op = text "prefix `-'" + | otherwise = quotes (ppr op) + +pprBindings :: [Name] -> SDoc +pprBindings = pprWithCommas (quotes . ppr) + + +injectivityErrorHerald :: SDoc +injectivityErrorHerald = + text "Type family equation violates the family's injectivity annotation." + +formatExportItemError :: SDoc -> String -> SDoc +formatExportItemError exportedThing reason = + hsep [ text "The export item" + , quotes exportedThing + , text reason ] + +-- | What warning flags are associated with the given missing signature? +missingSignatureWarningFlags :: MissingSignature -> Exported -> NonEmpty WarningFlag +missingSignatureWarningFlags (MissingTopLevelBindingSig {}) exported + -- We prefer "bigger" warnings first: #14794 + -- + -- See Note [Warnings controlled by multiple flags] + = Opt_WarnMissingSignatures :| + [ Opt_WarnMissingExportedSignatures | IsExported == exported ] +missingSignatureWarningFlags (MissingPatSynSig {}) exported + = Opt_WarnMissingPatternSynonymSignatures :| + [ Opt_WarnMissingExportedPatternSynonymSignatures | IsExported == exported ] +missingSignatureWarningFlags (MissingTyConKindSig ty_con _) _ + = Opt_WarnMissingKindSignatures :| [Opt_WarnMissingPolyKindSignatures | isForAllTy_invis_ty (tyConKind ty_con) ] + +useDerivingStrategies :: GhcHint +useDerivingStrategies = + useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies + +useGND :: GhcHint +useGND = let info = text "for GHC's" <+> text "newtype-deriving extension" + in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving + +cannotMakeDerivedInstanceHerald :: Class + -> [Type] + -> Maybe (DerivStrategy GhcTc) + -> UsingGeneralizedNewtypeDeriving + -> Bool -- ^ If False, only prints the why. + -> SDoc + -> SDoc +cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why = + if pprHerald + then sep [(hang (text "Can't make a derived instance of") + 2 (quotes (ppr pred) <+> via_mechanism) + $$ nest 2 extra) <> colon, + nest 2 why] + else why + where + strat_used = isJust mb_strat + extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving) + = text "(even with cunning GeneralizedNewtypeDeriving)" + | otherwise = empty + pred = mkClassPred cls cls_args + via_mechanism | strat_used + , Just strat <- mb_strat + = text "with the" <+> (derivStrategyName strat) <+> text "strategy" + | otherwise + = empty + +badCon :: DataCon -> SDoc -> SDoc +badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg + +derivErrDiagnosticMessage :: Class + -> [Type] + -> Maybe (DerivStrategy GhcTc) + -> UsingGeneralizedNewtypeDeriving + -> Bool -- If True, includes the herald \"can't make a derived..\" + -> DeriveInstanceErrReason + -> SDoc +derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case + DerivErrNotWellKinded tc cls_kind _ + -> sep [ hang (text "Cannot derive well-kinded instance of form" + <+> quotes (pprClassPred cls cls_tys + <+> parens (ppr tc <+> text "..."))) + 2 empty + , nest 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind)) + ] + DerivErrSafeHaskellGenericInst + -> text "Generic instances can only be derived in" + <+> text "Safe Haskell using the stock strategy." + DerivErrDerivingViaWrongKind cls_kind via_ty via_kind + -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) + 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind) <> char ',' + $+$ text "but" <+> quotes (pprType via_ty) + <+> text "has kind" <+> quotes (pprKind via_kind)) + DerivErrNoEtaReduce inst_ty + -> sep [text "Cannot eta-reduce to an instance of form", + nest 2 (text "instance (...) =>" + <+> pprClassPred cls (cls_tys ++ [inst_ty]))] + DerivErrBootFileFound + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Cannot derive instances in hs-boot files" + $+$ text "Write an instance declaration instead") + DerivErrDataConsNotAllInScope tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope") + 2 (text "so you cannot derive an instance for it")) + DerivErrGNDUsedOnData + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes") + DerivErrNullaryClasses + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Cannot derive instances for nullary classes") + DerivErrLastArgMustBeApp + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + ( text "The last argument of the instance must be a" + <+> text "data or newtype application") + DerivErrNoFamilyInstance tc tc_args + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "No family instance for" <+> quotes (pprTypeApp tc tc_args)) + DerivErrNotStockDeriveable _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)") + DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg + , case at_without_last_cls_tv of + YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc + NoAssociatedTyNotParamOverLastTyVar -> empty + , case at_last_cls_tv_in_kinds of + YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc + NoAssocTyLastVarInKind -> empty + ] + where + + adfs_msg = text "the class has associated data types" + + at_without_last_cls_tv_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "is not parameterized over the last type variable") + 2 (text "of the class" <+> quotes (ppr cls)) + + at_last_cls_tv_in_kinds_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "contains the last type variable") + 2 (text "of the class" <+> quotes (ppr cls) + <+> text "in a kind, which is not (yet) allowed") + DerivErrNewtypeNonDeriveableClass + -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled) + DerivErrCannotEtaReduceEnough eta_ok + -> let cant_derive_err = ppUnless eta_ok eta_msg + eta_msg = text "cannot eta-reduce the representation type enough" + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + cant_derive_err + DerivErrOnlyAnyClassDeriveable tc _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr tc) <+> text "is a type class," + <+> text "and can only have a derived instance" + $+$ text "if DeriveAnyClass is enabled") + DerivErrNotDeriveable _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty + DerivErrNotAClass predType + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr predType) <+> text "is not a class") + DerivErrNoConstructors rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor") + DerivErrLangExtRequired ext + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "You need " <> ppr ext + <+> text "to derive an instance for this class") + DerivErrDunnoHowToDeriveForType ty + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (hang (text "Don't know how to derive" <+> quotes (ppr cls)) + 2 (text "for type" <+> quotes (ppr ty))) + DerivErrMustBeEnumType rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (sep [ quotes (pprSourceTyCon rep_tc) <+> + text "must be an enumeration type" + , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]) + + DerivErrMustHaveExactlyOneConstructor rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor") + DerivErrMustHaveSomeParameters rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters") + DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) + DerivErrBadConstructor _ reasons + -> let why = vcat $ map renderReason reasons + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why + where + renderReason = \case + DerivErrBadConExistential con + -> badCon con $ text "must be truly polymorphic in the last argument of the data type" + DerivErrBadConCovariant con + -> badCon con $ text "must not use the type variable in a function argument" + DerivErrBadConFunTypes con + -> badCon con $ text "must not contain function types" + DerivErrBadConWrongArg con + -> badCon con $ text "must use the type variable only as the last argument of a data type" + DerivErrBadConIsGADT con + -> badCon con $ text "is a GADT" + DerivErrBadConHasExistentials con + -> badCon con $ text "has existential type variables in its type" + DerivErrBadConHasConstraints con + -> badCon con $ text "has constraints in its type" + DerivErrBadConHasHigherRankType con + -> badCon con $ text "has a higher-rank type" + DerivErrGenerics reasons + -> let why = vcat $ map renderReason reasons + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why + where + renderReason = \case + DerivErrGenericsMustNotHaveDatatypeContext tc_name + -> ppr tc_name <+> text "must not have a datatype context" + DerivErrGenericsMustNotHaveExoticArgs dc + -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments" + DerivErrGenericsMustBeVanillaDataCon dc + -> ppr dc <+> text "must be a vanilla data constructor" + DerivErrGenericsMustHaveSomeTypeParams rep_tc + -> text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters" + DerivErrGenericsMustNotHaveExistentials con + -> badCon con $ text "must not have existential arguments" + DerivErrGenericsWrongArgKind con + -> badCon con $ + text "applies a type to an argument involving the last parameter" + $$ text "but the applied type is not of kind * -> *" + DerivErrEnumOrProduct this that + -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this + ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (ppr1 $$ text " or" $$ ppr2) + +lookupInstanceErrDiagnosticMessage :: Class + -> [Type] + -> LookupInstanceErrReason + -> SDoc +lookupInstanceErrDiagnosticMessage cls tys = \case + LookupInstErrNotExact + -> text "Not an exact match (i.e., some variables get instantiated)" + LookupInstErrFlexiVar + -> text "flexible type variable:" <+> (ppr $ mkTyConApp (classTyCon cls) tys) + LookupInstErrNotFound + -> text "instance not found" <+> (ppr $ mkTyConApp (classTyCon cls) tys) + +{- ********************************************************************* +* * + Outputable SolverReportErrCtxt (for debugging) +* * +**********************************************************************-} + +instance Outputable SolverReportErrCtxt where + ppr (CEC { cec_binds = bvar + , cec_defer_type_errors = dte + , cec_expr_holes = eh + , cec_type_holes = th + , cec_out_of_scope_holes = osh + , cec_warn_redundant = wr + , cec_expand_syns = es + , cec_suppress = sup }) + = text "CEC" <+> braces (vcat + [ text "cec_binds" <+> equals <+> ppr bvar + , text "cec_defer_type_errors" <+> equals <+> ppr dte + , text "cec_expr_holes" <+> equals <+> ppr eh + , text "cec_type_holes" <+> equals <+> ppr th + , text "cec_out_of_scope_holes" <+> equals <+> ppr osh + , text "cec_warn_redundant" <+> equals <+> ppr wr + , text "cec_expand_syns" <+> equals <+> ppr es + , text "cec_suppress" <+> equals <+> ppr sup ]) + +{- ********************************************************************* +* * + Outputting TcSolverReportMsg errors +* * +**********************************************************************-} + +-- | Pretty-print a 'SolverReportWithCtxt', containing a 'TcSolverReportMsg' +-- with its enclosing 'SolverReportErrCtxt'. +pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc +pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext = ctxt, reportContent = msg }) + = pprTcSolverReportMsg ctxt msg + +-- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'. +pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc +pprTcSolverReportMsg _ (BadTelescope telescope skols) = + hang (text "These kind and type variables:" <+> ppr telescope $$ + text "are out of dependency order. Perhaps try this ordering:") + 2 (pprTyVars sorted_tvs) + where + sorted_tvs = scopedSort skols +pprTcSolverReportMsg _ (UserTypeError ty) = + pprUserTypeErrorTy ty +pprTcSolverReportMsg _ (UnsatisfiableError ty) = + pprUserTypeErrorTy ty +pprTcSolverReportMsg ctxt (ReportHoleError hole err) = + pprHoleError ctxt hole err +pprTcSolverReportMsg ctxt + (CannotUnifyVariable + { mismatchMsg = msg + , cannotUnifyReason = reason }) + = pprMismatchMsg ctxt msg + $$ pprCannotUnifyVariableReason ctxt reason +pprTcSolverReportMsg ctxt + (Mismatch + { mismatchMsg = mismatch_msg + , mismatchTyVarInfo = tv_info + , mismatchAmbiguityInfo = ambig_infos + , mismatchCoercibleInfo = coercible_info }) + = vcat ([ pprMismatchMsg ctxt mismatch_msg + , maybe empty (pprTyVarInfo ctxt) tv_info + , maybe empty pprCoercibleMsg coercible_info ] + ++ (map pprAmbiguityInfo ambig_infos)) +pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) = + vcat (map make_msg frr_origs) + where + -- Assemble the error message: pair up each origin with the corresponding type, e.g. + -- • FixedRuntimeRep origin msg 1 ... + -- a :: TYPE r1 + -- • FixedRuntimeRep origin msg 2 ... + -- b :: TYPE r2 + make_msg :: FixedRuntimeRepErrorInfo -> SDoc + make_msg (FRR_Info { frr_info_origin = + FixedRuntimeRepOrigin + { frr_type = ty + , frr_context = frr_ctxt } + , frr_info_not_concrete = mb_not_conc + , frr_info_other_origin = mb_other_orig }) = + -- Add bullet points if there is more than one error. + (if length frr_origs > 1 then (bullet <+>) else id) $ + vcat [ sep [ pprFixedRuntimeRepContext frr_ctxt + , text "does not have a fixed runtime representation." ] + , type_printout ty + , case mb_other_orig of + Nothing -> empty + Just o -> other_context o + , case mb_not_conc of + Just (conc_tv, not_conc) + | conc_tv `elemVarSet` tyCoVarsOfType ty + -- Only show this message if 'conc_tv' appears somewhere + -- in the type, otherwise it's not helpful. + -> unsolved_concrete_eq_explanation conc_tv not_conc + _ -> empty + ] + + -- Don't print out the type (only the kind), if the type includes + -- a confusing cast, unless the user passed -fprint-explicit-coercions. + -- + -- Example: + -- + -- In T20363, we have a representation-polymorphism error with a type + -- of the form + -- + -- ( (# #) |> co ) :: TYPE NilRep + -- + -- where NilRep is a nullary type family application which reduces to TupleRep '[]. + -- We prefer avoiding showing the cast to the user, but we also don't want to + -- print the confusing: + -- + -- (# #) :: TYPE NilRep + -- + -- So in this case we simply don't print the type, only the kind. + confusing_cast :: Type -> Bool + confusing_cast ty = + case ty of + CastTy inner_ty _ + -- A confusing cast is one that is responsible + -- for a representation-polymorphism error. + -> isConcreteType (typeKind inner_ty) + _ -> False + + type_printout :: Type -> SDoc + type_printout ty = + sdocOption sdocPrintExplicitCoercions $ \ show_coercions -> + if confusing_cast ty && not show_coercions + then vcat [ text "Its kind is:" + , nest 2 $ pprWithTYPE (typeKind ty) + , text "(Use -fprint-explicit-coercions to see the full type.)" ] + else vcat [ text "Its type is:" + , nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty) ] + + other_context :: CtOrigin -> SDoc + other_context = \case + TypeEqOrigin { uo_actual = actual_ty, uo_expected = exp_ty } -> + -- TODO: use uo_thing in the error message as well? + hang (text "When unifying:") 2 $ + vcat [ bullet <+> ppr actual_ty + , bullet <+> ppr exp_ty + ] + KindEqOrigin _ _ orig' _ + -> other_context orig' + _ -> empty -- Don't think this ever happens + + unsolved_concrete_eq_explanation :: TcTyVar -> Type -> SDoc + unsolved_concrete_eq_explanation tv not_conc = + text "Cannot unify" <+> quotes (ppr not_conc) + <+> text "with the type variable" <+> quotes (ppr tv) + $$ text "because the former is not a concrete" <+> what <> dot + where + ki = tyVarKind tv + what :: SDoc + what + | isRuntimeRepTy ki + = quotes (text "RuntimeRep") + | isLevityTy ki + = quotes (text "Levity") + | otherwise + = text "type" +pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) = + text "Expecting" <+> speakN (abs n) <+> + more <+> quotes (ppr thing) + where + more + | n == 1 = text "more argument to" + | otherwise = text "more arguments to" -- n > 1 +pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) = + let givens = getUserGivens ctxt + in if null givens + then addArising (errorItemCtLoc item) $ + sep [ text "Unbound implicit parameter" <> plural preds + , nest 2 (pprParendTheta preds) ] + else pprMismatchMsg ctxt (CouldNotDeduce givens (item :| items) Nothing) + where + preds = map errorItemPred (item : items) +pprTcSolverReportMsg _ (AmbiguityPreventsSolvingCt item ambigs) = + pprAmbiguityInfo (Ambiguity True ambigs) <+> + pprArising (errorItemCtLoc item) $$ + text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item) + <+> text "from being solved." +pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) + (CannotResolveInstance item unifiers candidates rel_binds) + = + vcat + [ no_inst_msg + , extra_note + , mb_patsyn_prov `orElse` empty + , ppWhen (has_ambigs && not (null unifiers && null useful_givens)) + (vcat [ ppUnless lead_with_ambig $ + pprAmbiguityInfo (Ambiguity False (ambig_kvs, ambig_tvs)) + , pprRelevantBindings rel_binds + -- "Relevant bindings" can help explain to the user where an + -- ambiguous type variable comes from. + , 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 (ctxt_fixes ++ drv_fixes ++ naked_sc_fixes) + , ppWhen (not (null candidates)) + (hang (text "There are instances for similar types:") + 2 (vcat (map ppr candidates))) + -- See Note [Report candidate instances] + ] + where + orig = errorItemOrigin item + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + -- See Note [Highlighting ambiguous type variables] in GHC.Tc.Errors + (ambig_kvs, ambig_tvs) = ambigTkvsOfTy pred + ambigs = ambig_kvs ++ ambig_tvs + has_ambigs = not (null ambigs) + useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) + -- useful_givens are the enclosing implications with non-empty givens, + -- modulo the horrid discardProvCtxtGivens + lead_with_ambig = not (null ambigs) + && not (any isRuntimeUnkSkol ambigs) + && not (null unifiers) + && null useful_givens + + no_inst_msg :: SDoc + no_inst_msg + | lead_with_ambig + = pprTcSolverReportMsg ctxt $ AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs) + | otherwise + = pprMismatchMsg ctxt $ CouldNotDeduce useful_givens (item :| []) Nothing + + -- Report "potential instances" only when the constraint arises + -- directly from the user's use of an overloaded function + want_potential (TypeEqOrigin {}) = False + want_potential _ = True + + potential_msg + = ppWhen (not (null unifiers) && want_potential orig) $ + potential_hdr $$ + potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers }) + + potential_hdr + = ppWhen lead_with_ambig $ + text "Probable fix: use a type annotation to specify what" + <+> pprQuotedList ambig_tvs <+> text "should be." + + mb_patsyn_prov :: Maybe SDoc + mb_patsyn_prov + | not lead_with_ambig + , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig + = Just (vcat [ text "In other words, a successful match on the pattern" + , nest 2 $ ppr pat + , text "does not provide the constraint" <+> pprParendType pred ]) + | otherwise = Nothing + + extra_note + -- Flag up partially applied uses of (->) + | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) + = text "(maybe you haven't applied a function to enough arguments?)" + + -- Clarify the mysterious "No instance for (Typeable T) + | className clas == typeableClassName + , [_,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 (typeKind ty))) + + | otherwise + = empty + + ----------- Possible fixes ---------------- + ctxt_fixes = ctxtFixes has_ambigs pred implics + + drv_fixes = case orig of + DerivOrigin standalone -> [drv_fix standalone] + 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") + + -- naked_sc_fix: try to produce a helpful error message for + -- superclass constraints caught by the subtleties described by + -- Note [Recursive superclasses] in GHC.TyCl.Instance + naked_sc_fixes + | ScOrigin IsClsInst NakedSc <- orig -- A superclass wanted with no instance decls used yet + , any non_tyvar_preds useful_givens -- Some non-tyvar givens + = [vcat [ text "if the constraint looks soluble from a superclass of the instance context," + , text "read 'Undecidable instances and loopy superclasses' in the user manual" ]] + | otherwise = [] + + non_tyvar_preds :: UserGiven -> Bool + non_tyvar_preds = any non_tyvar_pred . ic_given + + non_tyvar_pred :: EvVar -> Bool + -- Tells if the Given is of form (C ty1 .. tyn), where the tys are not all tyvars + non_tyvar_pred given = case getClassPredTys_maybe (idType given) of + Just (_, tys) -> not (all isTyVarTy tys) + Nothing -> False + +pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) = + vcat + [ addArising ct_loc $ + (text "Overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , ppUnless (null matching_givens) $ + sep [text "Matching givens (or their superclasses):" + , nest 2 (vcat matching_givens)] + , potentialInstancesErrMsg + (PotentialInstances { matches = NE.toList matches, unifiers }) + , ppWhen (null matching_givens && null (NE.tail 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_from_givens useful_givens))] + + , ppWhen (null $ NE.tail 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 + ct_loc = errorItemCtLoc item + orig = ctLocOrigin ct_loc + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + tyCoVars = tyCoVarsOfTypesList tys + famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys + useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) + matching_givens = mapMaybe matchable useful_givens + matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) + = case ev_vars_matching of + [] -> Nothing + _ -> Just $ hang (pprTheta ev_vars_matching) + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> + ppr (getCtLocEnvLoc (ic_env implic)) ]) + where ev_vars_matching = [ pred + | ev_var <- evvars + , let pred = evVarPred ev_var + , any can_match (pred : transSuperClasses pred) ] + can_match pred + = case getClassPredTys_maybe pred of + Just (clas', tys') -> clas' == clas + && isJust (tcMatchTys tys tys') + Nothing -> False +pprTcSolverReportMsg _ (UnsafeOverlap item match unsafe_overlapped) = + vcat [ addArising ct_loc (text "Unsafe overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , sep [text "The matching instance is:", + nest 2 (pprInstance match)] + , 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 $ NE.toList unsafe_overlapped]) + ] + ] + where + ct_loc = errorItemCtLoc item + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + +pprTcSolverReportMsg _ MultiplicityCoercionsNotSupported = text "GHC bug #19517: GHC currently does not support programs using GADTs or type families to witness equality of multiplicities" + +pprCannotUnifyVariableReason :: SolverReportErrCtxt -> CannotUnifyVariableReason -> SDoc +pprCannotUnifyVariableReason ctxt (CannotUnifyWithPolytype item tv1 ty2 mb_tv_info) = + 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) + , maybe empty (pprTyVarInfo ctxt) mb_tv_info ] + where + what = text $ levelString $ + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel + +pprCannotUnifyVariableReason _ (SkolemEscape item implic esc_skols) = + let + esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols + <+> pprQuotedList esc_skols + , text "would escape" <+> + if isSingleton esc_skols then text "its scope" + else text "their scope" ] + in + vcat [ nest 2 $ esc_doc + , sep [ (if isSingleton esc_skols + then text "This (rigid, skolem)" <+> + what <+> text "variable is" + else text "These (rigid, skolem)" <+> + what <+> text "variables are") + <+> text "bound by" + , nest 2 $ ppr (ic_info implic) + , nest 2 $ text "at" <+> + ppr (getCtLocEnvLoc (ic_env implic)) ] ] + where + what = text $ levelString $ + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel + +pprCannotUnifyVariableReason ctxt + (OccursCheck + { occursCheckInterestingTyVars = interesting_tvs + , occursCheckAmbiguityInfos = ambig_infos }) + = ppr_interesting_tyVars interesting_tvs + $$ vcat (map pprAmbiguityInfo ambig_infos) + where + ppr_interesting_tyVars [] = empty + ppr_interesting_tyVars (tv:tvs) = + hang (text "Type variable kinds:") 2 $ + vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) + (tv:tvs)) + tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) +pprCannotUnifyVariableReason ctxt (DifferentTyVars tv_info) + = pprTyVarInfo ctxt tv_info +pprCannotUnifyVariableReason ctxt (RepresentationalEq tv_info mb_coercible_msg) + = pprTyVarInfo ctxt tv_info + $$ maybe empty pprCoercibleMsg mb_coercible_msg + +pprUntouchableVariable :: TcTyVar -> Implication -> SDoc +pprUntouchableVariable tv (Implic { ic_given = given, ic_info = skol_info, ic_env = env }) + = sep [ quotes (ppr tv) <+> text "is untouchable" + , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given + , nest 2 $ text "bound by" <+> ppr skol_info + , nest 2 $ text "at" <+> ppr (getCtLocEnvLoc env) ] + +pprMismatchMsg :: SolverReportErrCtxt -> MismatchMsg -> SDoc +pprMismatchMsg ctxt + (BasicMismatch { mismatch_ea = ea + , mismatch_item = item + , mismatch_ty1 = ty1 -- Expected + , mismatch_ty2 = ty2 -- Actual + , mismatch_whenMatching = mb_match_txt + , mismatch_mb_same_occ = same_occ_info }) + = vcat [ addArising (errorItemCtLoc item) msg + , pprQCOriginExtra item + , ea_extra + , maybe empty (pprWhenMatching ctxt) mb_match_txt + , maybe empty pprSameOccInfo same_occ_info ] + where + msg + | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || + (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) || + (isLiftedLevity ty1 && isUnliftedLevity ty2) || + (isLiftedLevity ty2 && isUnliftedLevity ty1) + = text "Couldn't match a lifted type with an unlifted type" + + | isAtomicTy ty1 || isAtomicTy ty2 + = -- Print with quotes + sep [ text herald1 <+> quotes (ppr ty1) + , nest padding $ + text herald2 <+> quotes (ppr ty2) ] + + | otherwise + = -- Print with vertical layout + vcat [ text herald1 <> colon <+> ppr ty1 + , nest padding $ + text herald2 <> colon <+> ppr ty2 ] + + herald1 = conc [ "Couldn't match" + , if is_repr then "representation of" else "" + , if want_ea then "expected" else "" + , what ] + herald2 = conc [ "with" + , if is_repr then "that of" else "" + , if want_ea then ("actual " ++ what) else "" ] + + padding = length herald1 - length herald2 + + (want_ea, ea_extra) + = case ea of + NoEA -> (False, empty) + EA mb_extra -> (True , maybe empty (pprExpectedActualInfo ctxt) mb_extra) + is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False } + + what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel) + + conc :: [String] -> String + conc = unwords . filter (not . null) + +pprMismatchMsg ctxt + (TypeEqMismatch { teq_mismatch_item = item + , teq_mismatch_ty1 = ty1 -- These types are the actual types + , teq_mismatch_ty2 = ty2 -- that don't match; may be swapped + , teq_mismatch_expected = exp -- These are the context of + , teq_mismatch_actual = act -- the mis-match + , teq_mismatch_what = mb_thing + , teq_mb_same_occ = mb_same_occ }) + = vcat [ addArising ct_loc $ + pprWithInvisibleBitsWhen ppr_invis_bits msg + $$ maybe empty pprSameOccInfo mb_same_occ + , pprQCOriginExtra item ] + where + + msg | Just (torc, rep) <- sORTKind_maybe exp + = msg_for_exp_sort torc rep + + | Just nargs_msg <- num_args_msg + , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig + = nargs_msg $$ ea_msg + + | ea_looks_same ty1 ty2 exp act + , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig + = ea_msg + + | otherwise + = bale_out_msg + + -- bale_out_msg: the mismatched types are /inside/ exp and act + bale_out_msg = vcat errs + where + errs = case mk_ea_msg ctxt Nothing level orig of + Left ea_info -> pprMismatchMsg ctxt mismatch_err + : map (pprExpectedActualInfo ctxt) ea_info + Right ea_err -> [ pprMismatchMsg ctxt mismatch_err + , ea_err ] + mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2 + + -- 'expected' is (TYPE rep) or (CONSTRAINT rep) + msg_for_exp_sort exp_torc exp_rep + | Just (act_torc, act_rep) <- sORTKind_maybe act + = -- (TYPE exp_rep) ~ (CONSTRAINT act_rep) etc + msg_torc_torc act_torc act_rep + | otherwise + = -- (TYPE _) ~ Bool, etc + maybe_num_args_msg $$ + sep [ text "Expected a" <+> ppr_torc exp_torc <> comma + , text "but" <+> case mb_thing of + Nothing -> text "found something with kind" + Just thing -> quotes (ppr thing) <+> text "has kind" + , quotes (pprWithTYPE act) ] + + where + msg_torc_torc act_torc act_rep + | exp_torc == act_torc + = msg_same_torc act_torc act_rep + | otherwise + = sep [ text "Expected a" <+> ppr_torc exp_torc <> comma + , text "but" <+> case mb_thing of + Nothing -> text "found a" + Just thing -> quotes (ppr thing) <+> text "is a" + <+> ppr_torc act_torc ] + + msg_same_torc act_torc act_rep + | Just exp_doc <- describe_rep exp_rep + , Just act_doc <- describe_rep act_rep + = sep [ text "Expected" <+> exp_doc <+> ppr_torc exp_torc <> comma + , text "but" <+> case mb_thing of + Just thing -> quotes (ppr thing) <+> text "is" + Nothing -> text "got" + <+> act_doc <+> ppr_torc act_torc ] + msg_same_torc _ _ = bale_out_msg + + ct_loc = errorItemCtLoc item + orig = errorItemOrigin item + level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel + ppr_invis_bits = shouldPprWithInvisibleBits ty1 ty2 orig + + num_args_msg = case level of + KindLevel + | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) + -- if one is a meta-tyvar, then it's possible that the user + -- has asked for something impredicative, and we couldn't unify. + -- Don't bother with counting arguments. + -> let n_act = count_args act + n_exp = count_args exp in + case n_act - n_exp of + n | n > 0 -- we don't know how many args there are, so don't + -- recommend removing args that aren't + , Just thing <- mb_thing + -> Just $ pprTcSolverReportMsg ctxt (ExpectingMoreArguments n thing) + _ -> Nothing + + _ -> Nothing + + maybe_num_args_msg = num_args_msg `orElse` empty + + count_args ty = count isVisiblePiTyBinder $ fst $ splitPiTys ty + + ppr_torc TypeLike = text "type"; + ppr_torc ConstraintLike = text "constraint" + + describe_rep :: RuntimeRepType -> Maybe SDoc + -- describe_rep IntRep = Just "an IntRep" + -- describe_rep (BoxedRep Lifted) = Just "a lifted" + -- etc + describe_rep rep + | Just (rr_tc, rr_args) <- splitRuntimeRep_maybe rep + = case rr_args of + [lev_ty] | rr_tc `hasKey` boxedRepDataConKey + , Just lev <- levityType_maybe lev_ty + -> case lev of + Lifted -> Just (text "a lifted") + Unlifted -> Just (text "a boxed unlifted") + [] | rr_tc `hasKey` tupleRepDataConTyConKey -> Just (text "a zero-bit") + | starts_with_vowel rr_occ -> Just (text "an" <+> text rr_occ) + | otherwise -> Just (text "a" <+> text rr_occ) + where + rr_occ = occNameString (getOccName rr_tc) + + _ -> Nothing -- Must be TupleRep [r1..rn] + | otherwise = Nothing + + starts_with_vowel (c:_) = c `elem` ("AEIOU" :: String) + starts_with_vowel [] = False + +pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) + = vcat [ main_msg + , pprQCOriginExtra item + , ea_supplementary ] + where + main_msg + | null useful_givens = addArising ct_loc no_instance_msg + | otherwise = vcat ( addArising ct_loc no_deduce_msg + : pp_from_givens useful_givens) + + ea_supplementary = case mb_extra of + Nothing -> empty + Just (CND_Extra level ty1 ty2) -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig + + ct_loc = errorItemCtLoc item + orig = ctLocOrigin ct_loc + wanteds = map errorItemPred (item:others) + + no_instance_msg = + case wanteds of + [wanted] | -- Guard: don't say "no instance" for a constraint + -- such as "c" for a type variable c. + Just (tc, _) <- splitTyConApp_maybe wanted + , isClassTyCon tc + -> text "No instance for" <+> quotes (ppr wanted) + _ -> text "Could not solve:" <+> pprTheta wanteds + + no_deduce_msg = + case wanteds of + [wanted] -> text "Could not deduce" <+> quotes (ppr wanted) + _ -> text "Could not deduce:" <+> pprTheta wanteds + +pprQCOriginExtra :: ErrorItem -> SDoc +-- When we were originally trying to solve a quantified constraint like +-- (forall a. Eq a => Eq (c a)) +-- add a note to say so, so the overall error looks like +-- Cannot deduce Eq (c a) +-- from (Eq a) +-- when trying to solve (forall a. Eq a => Eq (c a)) +-- Without this, the error is very inscrutable +-- See (WFA3) in Note [Solving a Wanted forall-constraint], +-- in GHC.Tc.Solver.Solve +pprQCOriginExtra item + | ScOrigin (IsQC pred orig) _ <- orig + = hang (text "When trying to solve the quantified constraint") + 2 (vcat [ ppr pred + , text "arising from" <+> pprCtOriginBriefly orig ]) + | otherwise + = empty + where + orig = ctLocOrigin (errorItemCtLoc item) + +pprKindMismatchMsg :: TypedThing -> Type -> Type -> SDoc +pprKindMismatchMsg thing exp act + = hang (text "Expected" <+> kind_desc <> comma) + 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> + quotes (ppr act)) + where + kind_desc | isConstraintLikeKind 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) + +-- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) +-- in an 'SDoc' when a type mismatch occurs to due invisible parts of the types. +-- See Note [Showing invisible bits of types in error messages] +-- +-- 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. +shouldPprWithInvisibleBits :: Type -> Type -> CtOrigin -> Bool +shouldPprWithInvisibleBits _ty1 _ty2 (TypeEqOrigin { uo_actual = act + , uo_expected = exp + , uo_visible = vis }) + | not vis = True -- See tests T15870, T16204c + | otherwise = mayLookIdentical act exp -- See tests T9171, T9144. +shouldPprWithInvisibleBits ty1 ty2 _ct + = mayLookIdentical ty1 ty2 + +{- Note [Showing invisible bits of types 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, when we find a type or kind mis-match: + +* See if normally-visible parts of the type would make the two types + look different. This check is made by + `GHC.Core.TyCo.Compare.mayLookIdentical` + +* If not, display the types with their normally-visible parts made visible, + by setting flags in the `SDocContext": + Specifically: + - Display kind arguments: sdocPrintExplicitKinds + - Don't default away runtime-reps: sdocPrintExplicitRuntimeReps, + which controls `GHC.Iface.Type.hideNonStandardTypes` + (NB: foralls are always printed by pprType, it turns out.) + +As a result 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`. + +Another example of what goes wrong without this: #24553. +-} + +{- ********************************************************************* +* * + Displaying potential instances +* * +**********************************************************************-} + +-- | Directly display the given matching and unifying instances, +-- with a header for each: `Matching instances`/`Potentially matching instances`. +pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc +pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) = + vcat + [ ppWhen (not $ null matches) $ + text "Matching instance" <> plural matches <> colon $$ + nest 2 (vcat (map ppr_inst matches)) + , ppWhen (not $ null unifiers) $ + (text "Potentially matching instance" <> plural unifiers <> colon) $$ + nest 2 (vcat (map ppr_inst unifiers)) + ] + +-- | Display a summary of available instances, omitting those involving +-- out-of-scope types, in order to explain why we couldn't solve a particular +-- constraint, e.g. due to instance overlap or out-of-scope types. +-- +-- To directly display a collection of matching/unifying instances, +-- use 'pprPotentialInstances'. +potentialInstancesErrMsg :: PotentialInstances -> SDoc +-- See Note [Displaying potential instances] +potentialInstancesErrMsg potentials = + sdocOption sdocPrintPotentialInstances $ \print_insts -> + getPprStyle $ \sty -> + potentials_msg_with_options potentials print_insts sty + +-- | Display a summary of available instances, omitting out-of-scope ones. +-- +-- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing +-- options. +potentials_msg_with_options :: PotentialInstances + -> Bool -- ^ Whether to print /all/ potential instances + -> PprStyle + -> SDoc +potentials_msg_with_options + (PotentialInstances { matches, unifiers }) + show_all_potentials sty + | null matches && null unifiers + = empty + + | null show_these_matches && null show_these_unifiers + = vcat [ not_in_scope_msg empty + , flag_hint ] + + | otherwise + = vcat [ pprPotentialInstances + pprInstance -- print instance + location info + (PotentialInstances + { matches = show_these_matches + , unifiers = show_these_unifiers }) + , overlapping_but_not_more_specific_msg sorted_matches + , nest 2 $ vcat + [ ppWhen (n_in_scope_hidden > 0) $ + text "...plus" + <+> speakNOf n_in_scope_hidden (text "other") + , ppWhen (not_in_scopes > 0) $ + not_in_scope_msg (text "...plus") + , flag_hint ] ] + where + n_show_matches, n_show_unifiers :: Int + n_show_matches = 3 + n_show_unifiers = 2 + + (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches + (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers + sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches + sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers + (show_these_matches, show_these_unifiers) + | show_all_potentials = (sorted_matches, sorted_unifiers) + | otherwise = (take n_show_matches sorted_matches + ,take n_show_unifiers sorted_unifiers) + n_in_scope_hidden + = length sorted_matches + length sorted_unifiers + - length show_these_matches - length show_these_unifiers + + -- "in scope" means that all the type constructors + -- are lexically in scope; these instances are likely + -- to be more useful + inst_in_scope :: ClsInst -> Bool + inst_in_scope cls_inst = nameSetAll name_in_scope $ + orphNamesOfTypes (is_tys cls_inst) + + name_in_scope name + | pretendNameIsInScope name + = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names + | Just mod <- nameModule_maybe name + = qual_in_scope (qualName sty mod Nothing (nameOccName name)) + | otherwise + = True + + qual_in_scope :: QualifyName -> Bool + qual_in_scope NameUnqual = True + qual_in_scope (NameQual {}) = True + qual_in_scope _ = False + + not_in_scopes :: Int + not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers + + not_in_scope_msg herald = + hang (herald <+> speakNOf not_in_scopes (text "instance") + <+> text "involving out-of-scope types") + 2 (ppWhen show_all_potentials $ + pprPotentialInstances + pprInstanceHdr -- only print the header, not the instance location info + (PotentialInstances + { matches = not_in_scope_matches + , unifiers = not_in_scope_unifiers + })) + + flag_hint = ppUnless (show_all_potentials + || (equalLength show_these_matches matches + && equalLength show_these_unifiers unifiers)) $ + text "(use -fprint-potential-instances to see them all)" + +-- | Compute a message informing the user of any instances that are overlapped +-- but were not discarded because the instance overlapping them wasn't +-- strictly more specific. +overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc +overlapping_but_not_more_specific_msg insts + -- Only print one example of "overlapping but not strictly more specific", + -- to avoid information overload. + | overlap : _ <- overlapping_but_not_more_specific + = overlap_header $$ ppr_overlapping overlap + | otherwise + = empty + where + overlap_header :: SDoc + overlap_header + | [_] <- overlapping_but_not_more_specific + = text "An overlapping instance can only be chosen when it is strictly more specific." + | otherwise + = text "Overlapping instances can only be chosen when they are strictly more specific." + overlapping_but_not_more_specific :: [(ClsInst, ClsInst)] + overlapping_but_not_more_specific + = nubOrdBy (comparing (is_dfun . fst)) + [ (overlapper, overlappee) + | these <- groupBy ((==) `on` is_cls_nm) insts + -- Take all pairs of distinct instances... + , one:others <- tails these -- if `these = [inst_1, inst_2, ...]` + , other <- others -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j` + -- ... such that one instance in the pair overlaps the other... + , let mb_overlapping + | hasOverlappingFlag (overlapMode $ is_flag one) + || hasOverlappableFlag (overlapMode $ is_flag other) + = [(one, other)] + | hasOverlappingFlag (overlapMode $ is_flag other) + || hasOverlappableFlag (overlapMode $ is_flag one) + = [(other, one)] + | otherwise + = [] + , (overlapper, overlappee) <- mb_overlapping + -- ... but the overlapper is not more specific than the overlappee. + , not (overlapper `more_specific_than` overlappee) + ] + more_specific_than :: ClsInst -> ClsInst -> Bool + is1 `more_specific_than` is2 + = isJust (tcMatchTys (is_tys is1) (is_tys is2)) + ppr_overlapping :: (ClsInst, ClsInst) -> SDoc + ppr_overlapping (overlapper, overlappee) + = text "The first instance that follows overlaps the second, but is not more specific than it:" + $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee]) + +{- Note [Displaying potential instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When showing a list of instances for + - overlapping instances (show ones that match) + - no such instance (show ones that could match) +we want to give it a bit of structure. Here's the plan + +* Say that an instance is "in scope" if all of the + type constructors it mentions are lexically in scope. + These are the ones most likely to be useful to the programmer. + +* Show at most n_show in-scope instances, + and summarise the rest ("plus N others") + +* Summarise the not-in-scope instances ("plus 4 not in scope") + +* Add the flag -fshow-potential-instances which replaces the + summary with the full list +-} + +{- ********************************************************************* +* * + Outputting additional solver report information +* * +**********************************************************************-} + +-- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'. +pprExpectedActualInfo :: SolverReportErrCtxt -> ExpectedActualInfo -> SDoc +pprExpectedActualInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) = + vcat + [ text "Expected:" <+> ppr exp + , text " Actual:" <+> ppr act ] +pprExpectedActualInfo _ + (ExpectedActualAfterTySynExpansion + { ea_expanded_expected = exp + , ea_expanded_actual = act } ) + = vcat + [ text "Type synonyms expanded:" + , text "Expected type:" <+> ppr exp + , text " Actual type:" <+> ppr act ] + +pprCoercibleMsg :: CoercibleMsg -> SDoc +pprCoercibleMsg (UnknownRoles ty) = + note $ "We cannot know what roles the parameters to" <+> quotes (ppr ty) <+> "have;" $$ + "we must assume that the role is nominal" +pprCoercibleMsg (TyConIsAbstract tc) = + note $ "The type constructor" <+> quotes (pprSourceTyCon tc) <+> "is abstract" +pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) = + hang (text "The data constructor" <+> quotes (ppr $ dataConName dc)) + 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) + , text "is not in scope" ]) + +pprWhenMatching :: SolverReportErrCtxt -> WhenMatching -> SDoc +pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = + sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> + if printExplicitCoercions + || not (cty1 `pickyEqType` cty2) + then vcat [ hang (text "When matching" <+> sub_whats) + 2 (vcat [ ppr cty1 <+> dcolon <+> + ppr (typeKind cty1) + , ppr cty2 <+> dcolon <+> + ppr (typeKind cty2) ]) + , supplementary ] + else text "When matching the kind of" <+> quotes (ppr cty1) + where + sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel + sub_whats = text (levelString sub_t_or_k) <> char 's' + supplementary = mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o + +pprTyVarInfo :: SolverReportErrCtxt -> TyVarInfo -> SDoc +pprTyVarInfo ctxt (TyVarInfo { thisTyVar = tv1, otherTy = mb_tv2, thisTyVarIsUntouchable = mb_implic }) + = vcat [ mk_msg tv1 + , maybe empty (pprUntouchableVariable tv1) mb_implic + , case mb_tv2 of { Nothing -> empty; Just tv2 -> mk_msg tv2 } ] + where + mk_msg tv = case tcTyVarDetails tv of + SkolemTv sk_info _ _ -> pprSkols ctxt [(getSkolemInfo sk_info, [tv])] + RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" + MetaTv {} -> empty + +pprAmbiguityInfo :: AmbiguityInfo -> SDoc +pprAmbiguityInfo (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg + where + + msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] + || any isRuntimeUnkSkol ambig_tvs + = vcat [ text "Cannot resolve unknown runtime type" + <> plural ambig_tvs <+> pprQuotedList ambig_tvs + , text "Use :print or :force to determine these types"] + + | not (null ambig_tvs) + = pp_ambig (text "type") ambig_tvs + + | otherwise + = pp_ambig (text "kind") ambig_kvs + + pp_ambig what tkvs + | prepend_msg -- "Ambiguous type variable 't0'" + = text "Ambiguous" <+> what <+> text "variable" + <> plural tkvs <+> pprQuotedList tkvs + + | otherwise -- "The type variable 't0' is ambiguous" + = text "The" <+> what <+> text "variable" <> plural tkvs + <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" +pprAmbiguityInfo (NonInjectiveTyFam tc) = + note $ quotes (ppr tc) <+> text "is a non-injective type family" + +pprSameOccInfo :: SameOccInfo -> SDoc +pprSameOccInfo (SameOcc same_pkg n1 n2) = + note (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) + where + ppr_from same_pkg nm + | isGoodSrcSpan loc + = hang (quotes (ppr nm) <+> text "is defined at") + 2 (ppr loc) + | otherwise -- Imported things have an UnhelpfulSrcSpan + = hang (quotes (ppr nm)) + 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) + , ppUnless (same_pkg || pkg == mainUnit) $ + nest 4 $ text "in package" <+> quotes (ppr pkg) ]) + where + pkg = moduleUnit mod + mod = nameModule nm + loc = nameSrcSpan nm + +{- ********************************************************************* +* * + Outputting HoleError messages +* * +**********************************************************************-} + +pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc +pprHoleError _ (Hole { hole_ty, hole_occ = rdr }) OutOfScopeHole + = out_of_scope_msg + where + herald | isDataOcc (rdrNameOcc rdr) = 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 rdr) + | otherwise = hang herald 2 (pp_rdr_with_type rdr hole_ty) + boring_type = isTyVarTy hole_ty +pprHoleError ctxt (Hole { hole_ty, hole_occ}) (HoleError sort other_tvs hole_skol_info) = + vcat [ hole_msg + , tyvars_msg + , case sort of { ExprHole {} -> expr_hole_hint; _ -> type_hole_hint } ] + + where + + hole_msg = case sort of + ExprHole {} -> + hang (text "Found hole:") + 2 (pp_rdr_with_type hole_occ hole_ty) + TypeHole -> + hang (text "Found type wildcard" <+> quotes (ppr hole_occ)) + 2 (text "standing for" <+> quotes pp_hole_type_with_kind) + ConstraintHole -> + hang (text "Found extra-constraints wildcard standing for") + 2 (quotes $ pprType hole_ty) -- always kind Constraint + + hole_kind = typeKind hole_ty + + pp_hole_type_with_kind + | isLiftedTypeKind hole_kind + || isEqPred hole_ty -- Don't print the kind of unlifted + -- equalities (#15039) + = pprType hole_ty + | otherwise + = pprType hole_ty <+> dcolon <+> pprKind hole_kind + + tyvars = tyCoVarsOfTypeList hole_ty + tyvars_msg = ppUnless (null tyvars) $ + text "Where:" <+> (vcat (map loc_msg other_tvs) + $$ pprSkols ctxt hole_skol_info) + -- Coercion variables can be free in the + -- hole, via kind casts + expr_hole_hint -- Give hint for, say, f x = _x + | lengthFS (occNameFS (rdrNameOcc hole_occ)) > 1 -- Don't give this hint for plain "_" + = text "Or perhaps" <+> quotes (ppr hole_occ) + <+> text "is mis-spelled, or not in scope" + | otherwise + = empty + + type_hole_hint + | ErrorWithoutFlag <- cec_type_holes ctxt + = text "To use the inferred type, enable PartialTypeSignatures" + | otherwise + = empty + + loc_msg tv + | isTyVar tv + = case tcTyVarDetails tv of + MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" + _ -> empty -- Skolems dealt with already + | otherwise -- A coercion variable can be free in the hole type + = ppWhenOption sdocPrintExplicitCoercions $ + quotes (ppr tv) <+> text "is a coercion variable" + +pp_rdr_with_type :: RdrName -> Type -> SDoc +pp_rdr_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) + +{- ********************************************************************* +* * + Outputting ScopeError messages +* * +**********************************************************************-} + +pprScopeError :: RdrName -> NotInScopeError -> SDoc +pprScopeError rdr_name scope_err = + case scope_err of + NotInScope -> + hang (text "Not in scope:") + 2 (what <+> quotes (ppr rdr_name)) + NotARecordField -> + hang (text "Not in scope:") + 2 (text "record field" <+> quotes (ppr rdr_name)) + NoExactName name -> + text "The Name" <+> quotes (ppr name) <+> text "is not in scope." + SameName gres -> + assertPpr (length gres >= 2) (text "pprScopeError SameName: fewer than 2 elements" $$ nest 2 (ppr gres)) + $ hang (text "Same Name in multiple name-spaces:") + 2 (vcat (map pp_one sorted_names)) + where + sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan) + $ map greName gres + pp_one name + = hang (pprNameSpace (occNameSpace (getOccName name)) + <+> quotes (ppr name) <> comma) + 2 (text "declared at:" <+> ppr (nameSrcLoc name)) + MissingBinding sig _ -> + sep [ text "The" <+> pprSigLike sig + <+> text "for" <+> quotes (ppr rdr_name) + , nest 2 $ text "lacks an accompanying binding" ] + NoTopLevelBinding -> + hang (text "No top-level binding for") + 2 (what <+> quotes (ppr rdr_name) <+> text "in this module") + UnknownSubordinate parent_nm sub -> + quotes (ppr rdr_name) <+> text "is not a (visible)" <+> pprSubordinate parent_nm sub + NotInScopeTc env -> + vcat[text "GHC internal error:" <+> quotes (ppr rdr_name) <+> + text "is not in scope during type checking, but it passed the renamer", + text "tcl_env of environment:" <+> ppr env] + where + what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + +scopeErrorHints :: NotInScopeError -> [GhcHint] +scopeErrorHints scope_err = + case scope_err of + NotInScope -> noHints + NotARecordField -> noHints + NoExactName {} -> [SuggestDumpSlices] + SameName {} -> [SuggestDumpSlices] + MissingBinding _ hints -> hints + NoTopLevelBinding -> noHints + UnknownSubordinate {} -> noHints + NotInScopeTc _ -> noHints + +tcSolverReportMsgHints :: SolverReportErrCtxt -> TcSolverReportMsg -> [GhcHint] +tcSolverReportMsgHints ctxt = \case + BadTelescope {} + -> noHints + UserTypeError {} + -> noHints + UnsatisfiableError {} + -> noHints + ReportHoleError {} + -> noHints + CannotUnifyVariable mismatch_msg rea + -> mismatchMsgHints ctxt mismatch_msg ++ cannotUnifyVariableHints rea + Mismatch { mismatchMsg = mismatch_msg } + -> mismatchMsgHints ctxt mismatch_msg + FixedRuntimeRepError {} + -> noHints + ExpectingMoreArguments {} + -> noHints + UnboundImplicitParams {} + -> noHints + AmbiguityPreventsSolvingCt {} + -> noHints + CannotResolveInstance {} + -> noHints + OverlappingInstances {} + -> noHints + UnsafeOverlap {} + -> noHints + MultiplicityCoercionsNotSupported {} + -> noHints + +mismatchMsgHints :: SolverReportErrCtxt -> MismatchMsg -> [GhcHint] +mismatchMsgHints ctxt msg = + maybeToList [ hint | (exp,act) <- mismatchMsg_ExpectedActuals msg + , hint <- suggestAddSig ctxt exp act ] + +mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type) +mismatchMsg_ExpectedActuals = \case + BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } -> + Just (exp, act) + TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } -> + Just (exp,act) + CouldNotDeduce { cnd_extra = cnd_extra } + | Just (CND_Extra _ exp act) <- cnd_extra + -> Just (exp, act) + | otherwise + -> Nothing + +cannotUnifyVariableHints :: CannotUnifyVariableReason -> [GhcHint] +cannotUnifyVariableHints = \case + CannotUnifyWithPolytype {} + -> noHints + OccursCheck {} + -> noHints + SkolemEscape {} + -> noHints + DifferentTyVars {} + -> noHints + RepresentationalEq {} + -> noHints + +suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint +-- See Note [Suggest adding a type signature] +suggestAddSig ctxt ty1 _ty2 + | bndr : bndrs <- inferred_bndrs + = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs) + | otherwise + = Nothing + where + inferred_bndrs = + case getTyVar_maybe ty1 of + Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv + _ -> [] + + -- 'find' returns the binders of an InferSkol for 'tv', + -- provided there is an intervening implication with + -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match) + find [] _ _ = [] + find (implic:implics) seen_eqs tv + | tv `elem` ic_skols implic + , InferSkol prs <- ic_info implic + , seen_eqs + = map fst prs + | otherwise + = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv + +{- 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. +-} + +{- ********************************************************************* +* * + Outputting ImportError messages +* * +**********************************************************************-} + +instance Outputable ImportError where + ppr err = note $ case err of + MissingModule mod_name -> "No module named" <+> quoted mod_name <+> "is imported" + ModulesDoNotExport mods what_look occ_name + | mod NE.:| [] <- mods -> "The module" <+> quoted mod <+> "does not export" <+> what <+> quoted occ_name + | otherwise -> "Neither" <+> quotedListWithNor (map ppr $ NE.toList mods) <+> "export" <+> what <+> quoted occ_name + where + what :: SDoc + what = case what_look of + WL_ConLike -> text "data constructor" + WL_RecField -> text "record field" + _ -> empty + where + quoted :: Outputable a => a -> SDoc + quoted = quotes . ppr + +{- ********************************************************************* +* * + Suggested fixes for implication constraints +* * +**********************************************************************-} + +-- TODO: these functions should use GhcHint instead. + +show_fixes :: [SDoc] -> SDoc +show_fixes [] = empty +show_fixes (f:fs) = sep [ text "Possible fix:" + , nest 2 (vcat (f : map (text "or" <+>) fs))] + +ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] +ctxtFixes has_ambig_tvs pred implics + | not has_ambig_tvs + , isTyVarClassPred pred -- Don't suggest adding (Eq T) to the context, say + , (skol:skols) <- usefulContext implics pred + , let what | null skols + , SigSkol (PatSynCtxt {}) _ _ <- skol + = text "\"required\"" + | otherwise + = empty + = [sep [ text "add" <+> pprParendType pred + <+> text "to the" <+> what <+> text "context of" + , nest 2 $ ppr_skol skol $$ + vcat [ text "or" <+> ppr_skol skol + | skol <- skols ] ] ] + | otherwise = [] + where + ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) + ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) + ppr_skol skol_info = ppr skol_info + +usefulContext :: [Implication] -> PredType -> [SkolemInfoAnon] +-- usefulContext picks out the implications whose context +-- the programmer might plausibly augment to solve 'pred' +usefulContext implics pred + = go implics + where + pred_tvs = tyCoVarsOfType pred + go [] = [] + go (ic : ics) + | implausible ic = rest + | otherwise = ic_info ic : rest + where + -- Stop when the context binds a variable free in the predicate + rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] + | otherwise = go ics + + implausible ic + | null (ic_skols ic) = True + | implausible_info (ic_info ic) = True + | otherwise = False + + implausible_info (SigSkol (InfSigCtxt {}) _ _) = True + implausible_info _ = False + -- Do not suggest adding constraints to an *inferred* type signature + +pp_from_givens :: [Implication] -> [SDoc] +pp_from_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 (getCtLocEnvLoc (ic_env implic)) ]) + +{- ********************************************************************* +* * + CtOrigin information +* * +**********************************************************************-} + +levelString :: TypeOrKind -> String +levelString TypeLevel = "type" +levelString KindLevel = "kind" + +pprArising :: CtLoc -> SDoc +-- Used for the main, top-level error message +-- We've done special processing for TypeEq, KindEq, givens +pprArising ct_loc + | in_generated_code = empty -- See Note ["Arising from" messages in generated code] + | suppress_origin = empty + | otherwise = pprCtOrigin orig + where + orig = ctLocOrigin ct_loc + in_generated_code = ctLocEnvInGeneratedCode (ctLocEnv ct_loc) + suppress_origin + | isGivenOrigin orig = True + | otherwise = case orig of + TypeEqOrigin {} -> True -- We've done special processing + KindEqOrigin {} -> True -- for TypeEq, KindEq, givens + AmbiguityCheckOrigin {} -> True -- The "In the ambiguity check" context + -- is sufficient; more would be repetitive + _ -> False + +-- Add the "arising from..." part to a message +addArising :: CtLoc -> SDoc -> SDoc +addArising ct_loc msg = hang msg 2 (pprArising ct_loc) + +pprWithArising :: [Ct] -> SDoc +-- Print something like +-- (Eq a) arising from a use of x at y +-- (Show a) arising from a use of p at q +-- Also return a location for the error message +-- Works for Wanted/Derived only +pprWithArising [] + = panic "pprWithArising" +pprWithArising (ct:cts) + | null cts + = addArising loc (pprTheta [ctPred ct]) + | otherwise + = vcat (map ppr_one (ct:cts)) + where + loc = ctLoc ct + ppr_one ct' = hang (parens (pprType (ctPred ct'))) + 2 (pprCtLoc (ctLoc ct')) + +{- Note ["Arising from" messages in generated code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider code generated when we desugar code before typechecking; +see Note [Rebindable syntax and XXExprGhcRn]. + +In this code, constraints may be generated, but we don't want to +say "arising from a call of foo" if 'foo' doesn't appear in the +users code. We leave the actual CtOrigin untouched (partly because +it is generated in many, many places), but suppress the "Arising from" +message for constraints that originate in generated code. +-} + + +{- ********************************************************************* +* * + SkolemInfo +* * +**********************************************************************-} + + +tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo +tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env sk_anon) + +---------------- +tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon +tidySkolemInfoAnon env (DerivSkol ty) = DerivSkol (tidyType env ty) +tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs +tidySkolemInfoAnon env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) +tidySkolemInfoAnon env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) +tidySkolemInfoAnon _ info = info + +tidySigSkol :: TidyEnv -> UserTypeCtxt + -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon +-- We need to take special care when tidying SigSkol +-- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" +tidySigSkol env cx ty tv_prs + = SigSkol cx (tidy_ty env ty) tv_prs' + where + tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs + inst_env = mkNameEnv tv_prs' + + tidy_ty env (ForAllTy (Bndr tv vis) ty) + = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) + where + (env', tv') = tidy_tv_bndr env tv + + tidy_ty env ty@(FunTy { ft_mult = w, ft_arg = arg, ft_res = res }) + = -- Look under c => t and t1 -> t2 + ty { ft_mult = tidy_ty env w + , ft_arg = tidyType env arg + , ft_res = tidy_ty env res } + + tidy_ty env ty = tidyType env ty + + tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) + tidy_tv_bndr env@(occ_env, subst) tv + | Just tv' <- lookupNameEnv inst_env (tyVarName tv) + = ((occ_env, extendVarEnv subst tv tv'), tv') + + | otherwise + = tidyVarBndr env tv + +pprSkols :: SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc +pprSkols ctxt zonked_ty_vars + = + let tidy_ty_vars = map (bimap (tidySkolemInfoAnon (cec_tidy ctxt)) id) zonked_ty_vars + in vcat (map pp_one tidy_ty_vars) + where + + no_msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr zonked_ty_vars + $$ text "This should not happen, please report it as a bug following the instructions at:" + $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" + + + pp_one (UnkSkol cs, tvs) + = vcat [ hang (pprQuotedList tvs) + 2 (is_or_are tvs "a" "(rigid, skolem)") + , nest 2 (text "of unknown origin") + , nest 2 (text "bound at" <+> ppr (skolsSpan tvs)) + , no_msg + , prettyCallStackDoc cs + ] + pp_one (RuntimeUnkSkol, tvs) + = hang (pprQuotedList tvs) + 2 (is_or_are tvs "an" "unknown runtime") + pp_one (skol_info, tvs) + = vcat [ hang (pprQuotedList tvs) + 2 (is_or_are tvs "a" "rigid" <+> text "bound by") + , nest 2 (pprSkolInfo skol_info) + , nest 2 (text "at" <+> ppr (skolsSpan tvs)) ] + + is_or_are [_] article adjective = text "is" <+> text article <+> text adjective + <+> text "type variable" + is_or_are _ _ adjective = text "are" <+> text adjective + <+> text "type variables" + +skolsSpan :: [TcTyVar] -> SrcSpan +skolsSpan skol_tvs = foldr1WithDefault noSrcSpan combineSrcSpans (map getSrcSpan skol_tvs) + +{- ********************************************************************* +* * + Utilities for expected/actual messages +* * +**********************************************************************-} + +mk_supplementary_ea_msg :: SolverReportErrCtxt -> 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) + = case mk_ea_msg ctxt Nothing level orig of + Left infos -> vcat $ map (pprExpectedActualInfo ctxt) infos + Right msg -> msg + | otherwise + = empty + +ea_looks_same :: Type -> Type -> Type -> Type -> Bool +-- True if the faulting types (ty1, ty2) look the same as +-- the expected/actual types (exp, act). +-- If so, we don't want to redundantly report the latter +ea_looks_same ty1 ty2 exp act + = (act `looks_same` ty1 && exp `looks_same` ty2) || + (exp `looks_same` ty1 && act `looks_same` ty2) + where + looks_same t1 t2 = t1 `pickyEqType` t2 + || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind + -- pickyEqType is sensitive to synonyms, so only replies True + -- when the types really look the same. However, + -- (TYPE 'LiftedRep) and Type both print the same way. + +mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind + -> CtOrigin -> Either [ExpectedActualInfo] SDoc +-- Constructs a "Couldn't match" message +-- The (Maybe ErrorItem) says whether this is the main top-level message (Just) +-- or a supplementary message (Nothing) +mk_ea_msg ctxt at_top level + (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) + | Just thing <- mb_thing + , KindLevel <- level + = Right $ pprKindMismatchMsg thing exp act + | Just item <- at_top + , let ea = EA $ if expanded_syns then Just ea_expanded else Nothing + mismatch = mkBasicMismatchMsg ea item exp act + = Right (pprMismatchMsg ctxt mismatch) + | otherwise + = Left $ + if expanded_syns + then [ea,ea_expanded] + else [ea] + + where + ea = ExpectedActual { ea_expected = exp, ea_actual = act } + ea_expanded = + ExpectedActualAfterTySynExpansion + { ea_expanded_expected = expTy1 + , ea_expanded_actual = expTy2 } + + expanded_syns = cec_expand_syns ctxt + && not (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) + (expTy1, expTy2) = expandSynonymsToMatch exp act +mk_ea_msg _ _ _ _ = Left [] + +{- Note [Expanding type synonyms to make types similar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In type error messages, if -fprint-expanded-types is used, we want to expand +type synonyms to make expected and found types as similar as possible, but we +shouldn't expand types too much to make type messages even more verbose and +harder to understand. The whole point here is to make the difference in expected +and found types clearer. + +`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms +only as much as necessary. Given two types t1 and t2: + + * If they're already same, it just returns the types. + + * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are + type constructors), it expands C1 and C2 if they're different type synonyms. + Then it recursively does the same thing on expanded types. If C1 and C2 are + same, then it applies the same procedure to arguments of C1 and arguments of + C2 to make them as similar as possible. + + Most important thing here is to keep number of synonym expansions at + minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, + Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and + `T (T3, T3, Bool)`. + + * Otherwise types don't have same shapes and so the difference is clearly + visible. It doesn't do any expansions and show these types. + +Note that we only expand top-layer type synonyms. Only when top-layer +constructors are the same we start expanding inner type synonyms. + +Suppose top-layer type synonyms of t1 and t2 can expand N and M times, +respectively. If their type-synonym-expanded forms will meet at some point (i.e. +will have same shapes according to `sameShapes` function), it's possible to find +where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) +comparisons. We first collect all the top-layer expansions of t1 and t2 in two +lists, then drop the prefix of the longer list so that they have same lengths. +Then we search through both lists in parallel, and return the first pair of +types that have same shapes. Inner types of these two types with same shapes +are then expanded using the same algorithm. + +In case they don't meet, we return the last pair of types in the lists, which +has top-layer type synonyms completely expanded. (in this case the inner types +are not expanded at all, as the current form already shows the type error) +-} + +-- | Expand type synonyms in given types only enough to make them as similar as +-- possible. Returned types are the same in terms of used type synonyms. +-- +-- To expand all synonyms, see 'Type.expandTypeSynonyms'. +-- +-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for +-- some examples of how this should work. +expandSynonymsToMatch :: Type -> Type -> (Type, Type) +expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) + where + (ty1_ret, ty2_ret) = go ty1 ty2 + + -- Returns (type synonym expanded version of first type, + -- type synonym expanded version of second type) + go :: Type -> Type -> (Type, Type) + go t1 t2 + | t1 `pickyEqType` t2 = + -- Types are same, nothing to do + (t1, t2) + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2 + , tys1 `equalLength` tys2 = + -- Type constructors are same. They may be synonyms, but we don't + -- expand further. The lengths of tys1 and tys2 must be equal; + -- for example, with type S a = a, we don't want + -- to zip (S Monad Int) and (S Bool). + let (tys1', tys2') = unzip (zipWithEqual 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 + (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` coreView t) + + -- Drop the type pairs until types in a pair look alike (i.e. the outer + -- constructors are the same). + followExpansions :: [(Type, Type)] -> (Type, Type) + followExpansions [] = pprPanic "followExpansions" empty + followExpansions [(t1, t2)] + | sameShapes t1 t2 = go t1 t2 -- expand subtrees + | otherwise = (t1, t2) -- the difference is already visible + followExpansions ((t1, t2) : tss) + -- Traverse subtrees when the outer shapes are the same + | sameShapes t1 t2 = go t1 t2 + -- Otherwise follow the expansions until they look alike + | otherwise = followExpansions tss + + sameShapes :: Type -> Type -> Bool + sameShapes AppTy{} AppTy{} = True + sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 + sameShapes (FunTy {}) (FunTy {}) = True + sameShapes (ForAllTy {}) (ForAllTy {}) = True + sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 + sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 + sameShapes _ _ = False + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +inHsDocContext :: HsDocContext -> SDoc +inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt + +pprHsDocContext :: HsDocContext -> SDoc +pprHsDocContext (GenericCtx doc) = doc +pprHsDocContext (TypeSigCtx vs) = text "the type signature for" <+> ppr_sig_bndrs vs +pprHsDocContext (StandaloneKindSigCtx v)= text "the standalone kind signature for" <+> quotes (ppr v) +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 (SpecECtx name) = text "the SPECIALISE pragma for" <+> quotes (ppr 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 ReifyInstancesCtx = text "GHC.Tc.Gen.Splice.reifyInstances" +pprHsDocContext (ClassInstanceCtx inst_ty) = + text "the instance declaration for" <+> quotes (ppr inst_ty) +pprHsDocContext (ClassMethodSigCtx name) = text "a class method signature for" <+> quotes (ppr name) +pprHsDocContext (SpecialiseSigCtx name) = text "a SPECIALISE signature for" <+> quotes (ppr name) +pprHsDocContext (PatSynSigCtx vs) = + text "a pattern synonym signature for" <+> ppr_sig_bndrs vs + +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 + +ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc +ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) + +pprConversionFailReason :: ConversionFailReason -> SDoc +pprConversionFailReason = \case + IllegalOccName ctxt_ns occ -> + text "Illegal" <+> pprNameSpace ctxt_ns + <+> text "name:" <+> quotes (text occ) + SumAltArityExceeded alt arity -> + text "Sum alternative" <+> int alt + <+> text "exceeds its arity," <+> int arity + IllegalSumAlt alt -> + vcat [ text "Illegal sum alternative:" <+> int alt + , nest 2 $ text "Sum alternatives must start from 1" ] + IllegalSumArity arity -> + vcat [ text "Illegal sum arity:" <+> int arity + , nest 2 $ text "Sums must have an arity of at least 2" ] + MalformedType typeOrKind ty -> + text "Malformed " <> text ty_str <+> text (show ty) + where ty_str = case typeOrKind of + TypeLevel -> "type" + KindLevel -> "kind" + IllegalLastStatement do_or_lc stmt -> + vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon + , nest 2 $ ppr stmt + , text "(It should be an expression.)" ] + KindSigsOnlyAllowedOnGADTs -> + text "Kind signatures are only allowed on GADTs" + IllegalDeclaration declDescr bad_decls -> + sep [ text "Illegal" <+> what <+> text "in" <+> descrDoc <> colon + , nest 2 bads ] + where + (what, bads) = case bad_decls of + IllegalDecls (NE.toList -> decls) -> + (text "declaration" <> plural decls, vcat $ map ppr decls) + IllegalFamDecls (NE.toList -> decls) -> + ( text "family declaration" <> plural decls, vcat $ map ppr decls) + descrDoc = text $ case declDescr of + InstanceDecl -> "an instance declaration" + WhereClause -> "a where clause" + LetBinding -> "a let expression" + LetExpression -> "a let expression" + ClssDecl -> "a class declaration" + CannotMixGADTConsWith98Cons -> + text "Cannot mix GADT constructors with Haskell 98" + <+> text "constructors" + EmptyStmtListInDoBlock -> + text "Empty stmt list in do-block" + NonVarInInfixExpr -> + text "Non-variable expression is not allowed in an infix expression" + MultiWayIfWithoutAlts -> + text "Multi-way if-expression with no alternatives" + CasesExprWithoutAlts -> + text "\\cases expression with no alternatives" + ImplicitParamsWithOtherBinds -> + text "Implicit parameters mixed with other bindings" + InvalidCCallImpent from -> + text (show from) <+> text "is not a valid ccall impent" + RecGadtNoCons -> + quotes (text "RecGadtC") <+> text "must have at least one constructor name" + GadtNoCons -> + quotes (text "GadtC") <+> text "must have at least one constructor name" + InvalidTypeInstanceHeader tys -> + text "Invalid type instance header:" + <+> text (show tys) + InvalidTyFamInstLHS lhs -> + text "Invalid type family instance LHS:" + <+> text (show lhs) + InvalidImplicitParamBinding -> + text "Implicit parameter binding only allowed in let or where" + DefaultDataInstDecl adts -> + (text "Default data instance declarations" + <+> text "are not allowed:") + $$ ppr adts + FunBindLacksEquations nm -> + text "Function binding for" + <+> quotes (text (TH.pprint nm)) + <+> text "has no equations" + EmptyGuard -> + text "Empty guard" + EmptyParStmt -> + text "Empty par stmt" + +pprTyThingUsedWrong :: WrongThingSort -> TcTyThing -> Name -> SDoc +pprTyThingUsedWrong sort thing name = + pprTcTyThingCategory thing <+> quotes (ppr name) <+> + text "used as a" <+> pprWrongThingSort sort + +pprWrongThingSort :: WrongThingSort -> SDoc +pprWrongThingSort = + text . \case + WrongThingType -> "type" + WrongThingDataCon -> "data constructor" + WrongThingPatSyn -> "pattern synonym" + WrongThingConLike -> "constructor-like thing" + WrongThingClass -> "class" + WrongThingTyCon -> "type constructor" + WrongThingAxiom -> "axiom" + +pprLevelCheckReason :: LevelCheckReason -> SDoc +pprLevelCheckReason = \case + LevelCheckInstance _ t -> + text "instance for" <+> quotes (ppr t) + LevelCheckSplice t _ -> + quotes (ppr t) + +pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc +pprUninferrableTyVarCtx = \case + UninfTyCtx_ClassContext theta -> + sep [ text "the class context:", pprTheta theta ] + UninfTyCtx_DataContext theta -> + sep [ text "the datatype context:", pprTheta theta ] + UninfTyCtx_ProvidedContext theta -> + sep [ text "the provided context:" , pprTheta theta ] + UninfTyCtx_TyFamRhs rhs_ty -> + sep [ text "the type family equation right-hand side:" , ppr rhs_ty ] + UninfTyCtx_TySynRhs rhs_ty -> + sep [ text "the type synonym right-hand side:" , ppr rhs_ty ] + UninfTyCtx_Sig exp_kind full_hs_ty -> + hang (text "the kind" <+> ppr exp_kind) 2 + (text "of the type signature:" <+> ppr full_hs_ty) + +pprPatSynInvalidRhsReason :: PatSynInvalidRhsReason -> SDoc +pprPatSynInvalidRhsReason = \case + PatSynNotInvertible p -> + text "Pattern" <+> quotes (ppr p) <+> text "is not invertible" + PatSynUnboundVar var -> + quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym" + +pprBadFieldAnnotationReason :: BadFieldAnnotationReason -> SDoc +pprBadFieldAnnotationReason = \case + LazyFieldsDisabled -> + text "Lazy field annotations (~) are disabled" + UnpackWithoutStrictness -> + text "UNPACK pragma lacks '!'" + UnusableUnpackPragma -> + text "Ignoring unusable UNPACK pragma" + +pprSuperclassCycleDetail :: SuperclassCycleDetail -> SDoc +pprSuperclassCycleDetail = \case + SCD_HeadTyVar pred -> + hang (text "one of whose superclass constraints is headed by a type variable:") + 2 (quotes (ppr pred)) + SCD_HeadTyFam pred -> + hang (text "one of whose superclass constraints is headed by a type family:") + 2 (quotes (ppr pred)) + SCD_Superclass cls -> + text "one of whose superclasses is" <+> quotes (ppr cls) + +pprRoleValidationFailedReason :: Role -> RoleValidationFailedReason -> SDoc +pprRoleValidationFailedReason role = \case + TyVarRoleMismatch tv role' -> + text "type variable" <+> quotes (ppr tv) <+> + text "cannot have role" <+> ppr role <+> + text "because it was assigned role" <+> ppr role' + TyVarMissingInEnv tv -> + text "type variable" <+> quotes (ppr tv) <+> text "missing in environment" + BadCoercionRole co -> + text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role + +pprDisabledClassExtension :: Class -> DisabledClassExtension -> SDoc +pprDisabledClassExtension cls = \case + MultiParamDisabled n -> + text howMany <+> text "parameters for class" <+> quotes (ppr cls) + where + howMany | n == 0 = "No" + | otherwise = "Too many" + FunDepsDisabled -> + text "Fundeps in class" <+> quotes (ppr cls) + ConstrainedClassMethodsDisabled sel_id pred -> + vcat [ hang (text "Constraint" <+> quotes (ppr pred) + <+> text "in the type of" <+> quotes (ppr sel_id)) + 2 (text "constrains only the class type variables")] + +pprImportLookup :: ImportLookupReason -> SDoc +pprImportLookup = \case + ImportLookupBad k iface decl_spec ie _exts -> + let + pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc + pprImpDeclSpec iface decl_spec = + quotes (ppr (moduleName $ is_mod decl_spec)) <+> case mi_boot iface of + IsBoot -> text "(hi-boot interface)" + NotBoot -> empty + withContext msgs = + hang (text "In the import of" <+> pprImpDeclSpec iface decl_spec <> colon) + 2 (vcat msgs) + in case k of + BadImportNotExported _ -> + vcat + [ text "Module" <+> pprImpDeclSpec iface decl_spec <+> + text "does not export" <+> quotes (ppr ie) <> dot + ] + BadImportAvailVar -> + withContext + [ text "an item called" + <+> quotes val <+> text "is exported, but it is not a type." + ] + where + val_occ = rdrNameOcc $ ieName ie + val = parenSymOcc val_occ (ppr val_occ) + BadImportAvailTyCon {} -> + withContext + [ text "an item called" + <+> quotes tycon <+> text "is exported, but it is a type." + ] + where + tycon_occ = rdrNameOcc $ ieName ie + tycon = parenSymOcc tycon_occ (ppr tycon_occ) + BadImportNotExportedSubordinates gre unavailable1 -> + withContext + [ what <+> text "called" <+> parent_name <+> text "is exported, but it does not export" + , text "any" <+> what_children <+> text "called" <+> unavailable_names <> dot + ] + where + unavailable = NE.toList unavailable1 + parent_name = (quotes . pprPrefixOcc . nameOccName . gre_name) gre + unavailable_names = pprWithCommas (quotes . ppr) unavailable + any_names p = any (p . unpackFS) unavailable + what = case greInfo gre of + IAmTyCon ClassFlavour -> text "a class" + IAmTyCon _ -> text "a data type" + _ -> text "an item" + what_children = unquotedListWith "or" $ case greInfo gre of + IAmTyCon ClassFlavour -> + [text "class methods" | any_names okVarOcc ] ++ + [text "associated types" | any_names okTcOcc ] + IAmTyCon _ -> + [text "constructors" | any_names okConOcc ] ++ + [text "record fields" | any_names okVarOcc ] + _ -> [text "children"] + BadImportNonTypeSubordinates gre nontype1 -> + withContext + [ what <+> text "called" <+> parent_name <+> text "is exported," + , sep [ text "but its subordinate item" <> plural nontype <+> nontype_names + , isOrAre nontype <+> "not in the type namespace." ] ] + where + nontype = NE.toList nontype1 + parent_name = (quotes . pprPrefixOcc . nameOccName . gre_name) gre + nontype_names = pprWithCommas (quotes . pprPrefixOcc . nameOccName . gre_name) nontype + what = case greInfo gre of + IAmTyCon ClassFlavour -> text "a class" + IAmTyCon _ -> text "a data type" + _ -> text "an item" + BadImportNonDataSubordinates gre nondata1 -> + withContext + [ what <+> text "called" <+> parent_name <+> text "is exported," + , sep [ text "but its subordinate item" <> plural nondata <+> nondata_names + , isOrAre nondata <+> "not in the data namespace." ] ] + where + nondata = NE.toList nondata1 + parent_name = (quotes . pprPrefixOcc . nameOccName . gre_name) gre + nondata_names = pprWithCommas (quotes . pprPrefixOcc . nameOccName . gre_name) nondata + what = case greInfo gre of + IAmTyCon ClassFlavour -> text "a class" + IAmTyCon _ -> text "a data type" + _ -> text "an item" + BadImportAvailDataCon dataType_occ -> + withContext + [ text "an item called" <+> quotes datacon + , text "is exported, but it is a data constructor of" + , quotes dataType <> dot + ] + where + datacon_occ = rdrNameOcc $ ieName ie + datacon = parenSymOcc datacon_occ (ppr datacon_occ) + dataType = parenSymOcc dataType_occ (ppr dataType_occ) + ImportLookupQualified rdr -> + hang (text "Illegal qualified name in import item:") + 2 (ppr rdr) + ImportLookupIllegal -> + text "Illegal import item" + ImportLookupAmbiguous rdr gres -> + hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:") + 2 (vcat (map (ppr . greOccName) gres)) + +pprUnusedImport :: ImportDecl GhcRn -> UnusedImportReason -> SDoc +pprUnusedImport decl = \case + UnusedImportNone -> + vcat [ pp_herald <+> quotes pp_mod <+> text "is redundant" + , nest 2 (text "except perhaps to import instances from" + <+> quotes pp_mod) + , text "To import instances alone, use:" + <+> text "import" <+> pp_mod <> parens empty ] + UnusedImportSome sort_unused -> + sep [ pp_herald <+> quotes (pprWithCommas pp_unused sort_unused) + , text "from module" <+> quotes pp_mod <+> text "is redundant"] + where + pp_mod = ppr (unLoc (ideclName decl)) + pp_herald = text "The" <+> pp_qual <+> text "import of" + pp_qual + | isImportDeclQualified (ideclQualified decl) = text "qualified" + | otherwise = empty + pp_unused = \case + UnusedImportNameRegular n -> + pprNameUnqualified n + UnusedImportNameRecField par fld_occ -> + case par of + ParentIs p -> pprNameUnqualified p <> parens (ppr fld_occ) + NoParent -> ppr fld_occ + +pprUnusedName :: OccName -> UnusedNameProv -> SDoc +pprUnusedName name reason = + sep [ msg <> colon + , nest 2 $ pprNonVarNameSpace (occNameSpace name) + <+> quotes (ppr name)] + where + msg = case reason of + UnusedNameTopDecl -> + defined + UnusedNameImported mod -> + text "Imported from" <+> quotes (ppr mod) <+> text "but not used" + UnusedNameTypePattern -> + defined <+> text "on the right hand side" + UnusedNameMatch -> + defined + UnusedNameLocalBind -> + defined + defined = text "Defined but not used" + +-- When printing the name, take care to qualify it in the same +-- way as the provenance reported by pprNameProvenance, namely +-- the head of 'gre_imp'. Otherwise we get confusing reports like +-- Ambiguous occurrence ‘null’ +-- It could refer to either ‘T15487a.null’, +-- imported from ‘Prelude’ at T15487.hs:1:8-13 +-- or ... +-- See #15487 +pprAmbiguousGreName :: GlobalRdrEnv -> GlobalRdrElt -> SDoc +pprAmbiguousGreName gre_env gre + | IAmRecField fld_info <- greInfo gre + = sep [ text "the field" <+> quotes (ppr occ) <+> parent_info fld_info <> comma + , pprNameProvenance gre ] + | otherwise + = sep [ quotes (pp_qual <> dot <> ppr occ) <> comma + , pprNameProvenance gre ] + + where + occ = greOccName gre + parent_info fld_info = + case first_con of + PatSynName ps -> text "of pattern synonym" <+> quotes (ppr ps) + DataConName {} -> + case greParent gre of + ParentIs par + -- For a data family, only reporting the family TyCon can be + -- unhelpful (see T23301). So we give a bit of additional + -- info in that case. + | Just par_gre <- lookupGRE_Name gre_env par + , IAmTyCon tc_flav <- greInfo par_gre + , OpenFamilyFlavour (IAmData {}) _ <- tc_flav + -> vcat [ ppr_cons + , text "in a data family instance of" <+> quotes (ppr par) ] + | otherwise + -> text "of record" <+> quotes (ppr par) + NoParent -> ppr_cons + where + cons :: [ConLikeName] + cons = nonDetEltsUniqSet $ recFieldCons fld_info + first_con :: ConLikeName + first_con = head cons + ppr_cons :: SDoc + ppr_cons = hsep [ text "belonging to data constructor" + , quotes (ppr $ nameOccName $ conLikeName_Name first_con) + , if length cons > 1 then parens (text "among others") else empty + ] + pp_qual + | gre_lcl gre + = ppr (nameModule $ greName gre) + | Just imp <- headMaybe $ gre_imp gre + -- This 'imp' is the one that + -- pprNameProvenance chooses + , ImpDeclSpec { is_as = mod } <- is_decl imp + = ppr mod + | otherwise + = pprPanic "addNameClassErrRn" (ppr gre) + -- Invariant: either 'lcl' is True or 'iss' is non-empty + +pprNonCanonicalDefinition :: LHsSigType GhcRn + -> NonCanonicalDefinition + -> SDoc +pprNonCanonicalDefinition inst_ty = \case + NonCanonicalMonoid sub -> case sub of + NonCanonical_Sappend -> + msg1 "(<>)" "mappend" + NonCanonical_Mappend -> + msg2 "mappend" "(<>)" + NonCanonicalMonad sub -> case sub of + NonCanonical_Pure -> + msg1 "pure" "return" + NonCanonical_ThenA -> + msg1 "(*>)" "(>>)" + NonCanonical_Return -> + msg2 "return" "pure" + NonCanonical_ThenM -> + msg2 "(>>)" "(*>)" + where + msg1 :: String -> String -> SDoc + msg1 lhs rhs = + vcat [ text "Noncanonical" <+> + quotes (text (lhs ++ " = " ++ rhs)) <+> + text "definition detected" + , inst + ] + + msg2 :: String -> String -> SDoc + msg2 lhs rhs = + vcat [ text "Noncanonical" <+> + quotes (text lhs) <+> + text "definition detected" + , inst + , quotes (text lhs) <+> + text "will eventually be removed in favour of" <+> + quotes (text rhs) + ] + + inst = instDeclCtxt1 inst_ty + + -- stolen from GHC.Tc.TyCl.Instance + instDeclCtxt1 :: LHsSigType GhcRn -> SDoc + instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + + inst_decl_ctxt :: SDoc -> SDoc + inst_decl_ctxt doc = hang (text "in the instance declaration for") + 2 (quotes doc <> text ".") + +suggestNonCanonicalDefinition :: NonCanonicalDefinition -> [GhcHint] +suggestNonCanonicalDefinition reason = + [action doc] + where + action = case reason of + NonCanonicalMonoid sub -> case sub of + NonCanonical_Sappend -> move sappendName mappendName + NonCanonical_Mappend -> remove mappendName sappendName + NonCanonicalMonad sub -> case sub of + NonCanonical_Pure -> move pureAName returnMName + NonCanonical_ThenA -> move thenAName thenMName + NonCanonical_Return -> remove returnMName pureAName + NonCanonical_ThenM -> remove thenMName thenAName + + move = SuggestMoveNonCanonicalDefinition + remove = SuggestRemoveNonCanonicalDefinition + + doc = case reason of + NonCanonicalMonoid _ -> doc_monoid + NonCanonicalMonad _ -> doc_monad + + doc_monoid = + "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid" + doc_monad = + "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return" + +suggestDefaultDeclaration :: Class-> [Type] -> [[Type]] -> [GhcHint] +suggestDefaultDeclaration cls prefix seqs = + [SuggestDefaultDeclaration cls $ supersequence (prefix : seqs)] + where + -- Not exactly the shortest possible supersequence, but it preserves + -- the head sequence as the prefix of the result which is a requirement. + supersequence :: [[Type]] -> [Type] + supersequence [] = [] + supersequence ([] : seqs) = supersequence seqs + supersequence ((x : xs) : seqs) = + x : supersequence (xs : (dropHead x <$> seqs)) + dropHead x ys@(y : ys') + | tcEqType x y = ys' + | otherwise = ys + dropHead _ [] = [] + +-------------------------------------------------------------------------------- +-- hs-boot mismatch errors + +pprBootMismatch :: HsBootOrSig -> BootMismatch -> SDoc +pprBootMismatch boot_or_sig = \case + MissingBootThing nm err -> + let def_or_exp = case err of + MissingBootDefinition -> text "defined in" + MissingBootExport -> text "exported by" + in quotes (ppr nm) <+> text "is exported by the" + <+> ppr_boot_or_sig <> comma + <+> text "but not" + <+> def_or_exp <+> text "the implementing module." + MissingBootInstance boot_dfun -> + hang (text "instance" <+> ppr (idType boot_dfun)) + 2 (text "is defined in the" <+> ppr ppr_boot_or_sig <> comma <+> + text "but not in the implementing module.") + BadReexportedBootThing name name' -> + withUserStyle alwaysQualify AllTheWay $ vcat + [ text "The" <+> ppr_boot_or_sig + <+> text "(re)exports" <+> quotes (ppr name) + , text "but the implementing module exports a different identifier" <+> quotes (ppr name') + ] + BootMismatch boot_thing real_thing err -> + vcat + [ ppr real_thing <+> + text "has conflicting definitions in the module" + , text "and its" <+> ppr_boot_or_sig <> dot, + text "Main module:" <+> real_doc + , (case boot_or_sig of + HsBoot -> text " Boot file:" + Hsig -> text " Hsig file:") <+> boot_doc + , pprBootMismatchWhat boot_or_sig err + ] + where + to_doc + = pprTyThingInContext $ + showToHeader + { ss_forall = + case boot_or_sig of + HsBoot -> ShowForAllMust + Hsig -> ShowForAllWhen } + + real_doc = to_doc real_thing + boot_doc = to_doc boot_thing + + where + ppr_boot_or_sig = case boot_or_sig of + HsBoot -> text "hs-boot file" + Hsig -> text "hsig file" + + +pprBootMismatchWhat :: HsBootOrSig -> BootMismatchWhat -> SDoc +pprBootMismatchWhat boot_or_sig = \case + BootMismatchedIdTypes {} -> + text "The two types are different." + BootMismatchedTyCons tc1 tc2 errs -> + vcat $ map (pprBootTyConMismatch boot_or_sig tc1 tc2) (NE.toList errs) + +pprBootTyConMismatch :: HsBootOrSig -> TyCon -> TyCon + -> BootTyConMismatch -> SDoc +pprBootTyConMismatch boot_or_sig tc1 tc2 = \case + TyConKindMismatch -> + text "The types have different kinds." + TyConRoleMismatch sub_type -> + if sub_type + then + text "The roles are not compatible:" $$ + text "Main module:" <+> ppr (tyConRoles tc1) $$ + text " Hsig file:" <+> ppr (tyConRoles tc2) + else + text "The roles do not match." $$ + if boot_or_sig == HsBoot + then note $ "Roles on abstract types default to" <+> quotes "representational" <+> "in hs-boot files" + else empty + TyConSynonymMismatch {} -> empty -- nothing interesting to say + TyConFlavourMismatch fam_flav1 fam_flav2 -> + whenPprDebug $ + text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+> + text "do not match" + TyConAxiomMismatch ax_errs -> + pprBootListMismatches (text "Type family equations do not match:") + pprTyConAxiomMismatch ax_errs + TyConInjectivityMismatch {} -> + text "Injectivity annotations do not match" + TyConMismatchedClasses _ _ err -> + pprBootClassMismatch boot_or_sig err + TyConMismatchedData _rhs1 _rhs2 err -> + pprBootDataMismatch err + SynAbstractData err -> + pprSynAbstractDataError err + TyConsVeryDifferent -> + empty -- should be obvious to the user what the problem is + +pprSynAbstractDataError :: SynAbstractDataError -> SDoc +pprSynAbstractDataError = \case + SynAbsDataTySynNotNullary -> + text "Illegal parameterized type synonym in implementation of abstract data." + SynAbstractDataInvalidRHS bad_sub_tys -> + let msgs = mapMaybe pprInvalidAbstractSubTy (NE.toList bad_sub_tys) + in case msgs of + [] -> herald <> dot + msg:[] -> hang (herald <> colon) + 2 msg + _ -> hang (herald <> colon) + 2 (vcat $ map (<+> bullet) msgs) + + where + herald = text "Illegal implementation of abstract data" + pprInvalidAbstractSubTy = \case + TyConApp tc _ + -> assertPpr (isTypeFamilyTyCon tc) (ppr tc) $ + Just $ text "Invalid type family" <+> quotes (ppr tc) <> dot + ty@(ForAllTy {}) + -> Just $ text "Invalid polymorphic type" <> colon <+> ppr ty <> dot + ty@(FunTy af _ _ _) + | not (af == FTF_T_T) + -> Just $ text "Invalid qualified type" <> colon <+> ppr ty <> dot + _ -> Nothing + +pprTyConAxiomMismatch :: BootListMismatch CoAxBranch BootAxiomBranchMismatch -> SDoc +pprTyConAxiomMismatch = \case + MismatchedLength -> + text "The number of equations differs." + MismatchedThing i br1 br2 err -> + hang (text "The" <+> speakNth (i+1) <+> text "equations do not match.") + 2 (pprCoAxBranchMismatch br1 br2 err) + +pprCoAxBranchMismatch :: CoAxBranch -> CoAxBranch -> BootAxiomBranchMismatch -> SDoc +pprCoAxBranchMismatch _br1 _br2 err = + text "The" <+> what <+> text "don't match." + where + what = case err of + MismatchedAxiomBinders -> text "variables bound in the equation" + MismatchedAxiomLHS -> text "equation left-hand sides" + MismatchedAxiomRHS -> text "equation right-hand sides" + +pprBootListMismatches :: SDoc -- ^ herald + -> (BootListMismatch item err -> SDoc) + -> BootListMismatches item err -> SDoc +pprBootListMismatches herald ppr_one errs = + hang herald 2 msgs + where + msgs = case errs of + err :| [] -> ppr_one err + _ -> vcat $ map ((bullet <+>) . ppr_one) $ NE.toList errs + +pprBootClassMismatch :: HsBootOrSig -> BootClassMismatch -> SDoc +pprBootClassMismatch boot_or_sig = \case + MismatchedMethods errs -> + pprBootListMismatches (text "The class methods do not match:") + pprBootClassMethodListMismatch errs + MismatchedATs at_errs -> + pprBootListMismatches (text "The associated types do not match:") + (pprATMismatch boot_or_sig) at_errs + MismatchedFunDeps -> + text "The functional dependencies do not match." + MismatchedSuperclasses -> + text "The superclass constraints do not match." + MismatchedMinimalPragmas -> + text "The MINIMAL pragmas are not compatible." + +pprATMismatch :: HsBootOrSig -> BootListMismatch ClassATItem BootATMismatch -> SDoc +pprATMismatch boot_or_sig = \case + MismatchedLength -> + text "The number of associated type defaults differs." + MismatchedThing i at1 at2 err -> + pprATMismatchErr boot_or_sig i at1 at2 err + +pprATMismatchErr :: HsBootOrSig -> Int -> ClassATItem -> ClassATItem -> BootATMismatch -> SDoc +pprATMismatchErr boot_or_sig i (ATI tc1 _) (ATI tc2 _) = \case + MismatchedTyConAT err -> + hang (text "The associated types differ:") + 2 $ pprBootTyConMismatch boot_or_sig tc1 tc2 err + MismatchedATDefaultType -> + text "The types of the" <+> speakNth (i+1) <+> + text "associated type default differ." + +pprBootClassMethodListMismatch :: BootListMismatch ClassOpItem BootMethodMismatch -> SDoc +pprBootClassMethodListMismatch = \case + MismatchedLength -> + text "The number of class methods differs." + MismatchedThing _ op1 op2 err -> + pprBootClassMethodMismatch op1 op2 err + +pprBootClassMethodMismatch :: ClassOpItem -> ClassOpItem -> BootMethodMismatch -> SDoc +pprBootClassMethodMismatch (op1, _) (op2, _) = \case + MismatchedMethodNames -> + text "The method names" <+> quotes pname1 <+> text "and" + <+> quotes pname2 <+> text "differ." + MismatchedMethodTypes {} -> + text "The types of" <+> pname1 <+> text "are different." + MismatchedDefaultMethods subtype_check -> + if subtype_check + then + text "The default methods associated with" <+> pname1 <+> + text "are not compatible." + else + text "The default methods associated with" <+> pname1 <+> + text "are different." + where + nm1 = idName op1 + nm2 = idName op2 + pname1 = quotes (ppr nm1) + pname2 = quotes (ppr nm2) + +pprBootDataMismatch :: BootDataMismatch -> SDoc +pprBootDataMismatch = \case + MismatchedNewtypeVsData -> + text "Cannot match a" <+> quotes (text "data") <+> + text "definition with a" <+> quotes (text "newtype") <+> + text "definition." + MismatchedConstructors dc_errs -> + pprBootListMismatches (text "The constructors do not match:") + pprBootDataConMismatch dc_errs + MismatchedDatatypeContexts {} -> + text "The datatype contexts do not match." + +pprBootDataConMismatch :: BootListMismatch DataCon BootDataConMismatch + -> SDoc +pprBootDataConMismatch = \case + MismatchedLength -> + text "The number of constructors differs." + MismatchedThing _ dc1 dc2 err -> + pprBootDataConMismatchErr dc1 dc2 err + +pprBootDataConMismatchErr :: DataCon -> DataCon -> BootDataConMismatch -> SDoc +pprBootDataConMismatchErr dc1 dc2 = \case + MismatchedDataConNames -> + text "The names" <+> pname1 <+> text "and" <+> pname2 <+> text "differ." + MismatchedDataConFixities -> + text "The fixities of" <+> pname1 <+> text "differ." + MismatchedDataConBangs -> + text "The strictness annotations for" <+> pname1 <+> text "differ." + MismatchedDataConFieldLabels -> + text "The record label lists for" <+> pname1 <+> text "differ." + MismatchedDataConTypes -> + text "The types for" <+> pname1 <+> text "differ." + where + name1 = dataConName dc1 + name2 = dataConName dc2 + pname1 = quotes (ppr name1) + pname2 = quotes (ppr name2) + +-------------------------------------------------------------------------------- +-- Illegal instance errors + +pprIllegalInstance :: IllegalInstanceReason -> SDoc +pprIllegalInstance = \case + IllegalClassInstance head_ty reason -> + pprIllegalClassInstanceReason head_ty reason + IllegalFamilyInstance reason -> + pprIllegalFamilyInstance reason + IllegalFamilyApplicationInInstance inst_ty invis_arg tf_tc tf_args -> + pprWithInvisibleBitsWhen invis_arg $ + hang (text "Illegal type synonym family application" + <+> quotes (ppr tf_ty) <+> text "in instance" <> colon) + 2 (ppr inst_ty) + where + tf_ty = mkTyConApp tf_tc tf_args + +pprIllegalClassInstanceReason :: TypedThing -> IllegalClassInstanceReason -> SDoc +pprIllegalClassInstanceReason head_ty = \case + IllegalInstanceHead reason -> + pprIllegalInstanceHeadReason head_ty reason + IllegalHasFieldInstance has_field_err -> + with_illegal_instance_header head_ty $ + pprIllegalHasFieldInstance has_field_err + IllegalSpecialClassInstance cls because_safeHaskell -> + text "Class" <+> quotes (ppr $ className cls) + <+> text "does not support user-specified instances" + <> safeHaskell_msg + where + safeHaskell_msg + | because_safeHaskell + = text " when Safe Haskell is enabled." + | otherwise + = dot + IllegalInstanceFailsCoverageCondition cls coverage_failure -> + with_illegal_instance_header head_ty $ + pprNotCovered cls coverage_failure + +pprIllegalInstanceHeadReason :: TypedThing + -> IllegalInstanceHeadReason -> SDoc +pprIllegalInstanceHeadReason head_ty = \case + InstHeadTySynArgs -> with_illegal_instance_header head_ty $ + text "All instance types must be of the form (T t1 ... tn)" $$ + text "where T is not a synonym." + InstHeadNonTyVarArgs -> with_illegal_instance_header head_ty $ vcat [ + text "All instance types must be of the form (T a1 ... an)", + text "where a1 ... an are *distinct type variables*,", + text "and each type variable appears at most once in the instance head."] + InstHeadMultiParam -> with_illegal_instance_header head_ty $ parens $ + text "Only one type can be given in an instance head." + InstHeadAbstractClass cls -> + text "Cannot define instance for abstract class" <+> + quotes (ppr cls) + InstHeadNonClassHead bad_head -> + vcat [ text "Illegal" <+> what_illegal <> dot + , text "Instance heads must be of the form" + , nest 2 $ text "C ty_1 ... ty_n" + , text "where" <+> quotes (char 'C') <+> text "is a class." + ] + where + what_illegal = case bad_head of + InstNonClassTyCon tc_nm flav -> + text "instance for" <+> ppr flav <+> quotes (ppr tc_nm) + InstNonTyCon -> + text "head of an instance declaration:" <+> quotes (ppr head_ty) + +with_illegal_instance_header :: TypedThing -> SDoc -> SDoc +with_illegal_instance_header head_ty msg = + hang (hang (text "Illegal instance declaration for") + 2 (quotes (ppr head_ty)) <> colon) + 2 msg + +pprIllegalHasFieldInstance :: IllegalHasFieldInstance -> SDoc +pprIllegalHasFieldInstance = \case + IllegalHasFieldInstanceNotATyCon + -> text "Record data type must be specified." + IllegalHasFieldInstanceFamilyTyCon + -> text "Record data type may not be a data family." + IllegalHasFieldInstanceTyConHasField tc lbl + -> quotes (ppr tc) <+> text "already has a field" <+> quotes (ppr lbl) <> dot + IllegalHasFieldInstanceTyConHasFields tc lbl + -> sep [ ppr_tc <+> text "has fields, and the type" <+> quotes (ppr lbl) + , text "could unify with one of the field labels of" <+> ppr_tc <> dot ] + where ppr_tc = quotes (ppr tc) + +pprNotCovered :: Class -> CoverageProblem -> SDoc +pprNotCovered clas + CoverageProblem + { not_covered_fundep = fd + , not_covered_fundep_inst = (ls, rs) + , not_covered_invis_vis_tvs = undetermined_tvs + , not_covered_liberal = which_cc_failed + } = + pprWithInvisibleBitsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $ + vcat [ sep [ text "The" + <+> ppWhen liberal (text "liberal") + <+> text "coverage condition fails in class" + <+> quotes (ppr clas) + , nest 2 $ text "for functional dependency:" + <+> quotes (pprFunDep fd) ] + , sep [ text "Reason: lhs type" <> plural ls <+> pprQuotedList ls + , nest 2 $ + (if isSingleton ls + then text "does not" + else text "do not jointly") + <+> text "determine rhs type" <> plural rs + <+> pprQuotedList rs ] + , text "Un-determined variable" <> pluralVarSet undet_set <> colon + <+> pprVarSet undet_set (pprWithCommas ppr) + ] + where + liberal = case which_cc_failed of + FailedLICC -> True + FailedICC {} -> False + undet_set = fold undetermined_tvs + +illegalInstanceHints :: IllegalInstanceReason -> [GhcHint] +illegalInstanceHints = \case + IllegalClassInstance _ reason -> + illegalClassInstanceHints reason + IllegalFamilyInstance reason -> + illegalFamilyInstanceHints reason + IllegalFamilyApplicationInInstance {} -> + noHints + +illegalInstanceReason :: IllegalInstanceReason -> DiagnosticReason +illegalInstanceReason = \case + IllegalClassInstance _ reason -> + illegalClassInstanceReason reason + IllegalFamilyInstance reason -> + illegalFamilyInstanceReason reason + IllegalFamilyApplicationInInstance {} -> + ErrorWithoutFlag + +illegalClassInstanceHints :: IllegalClassInstanceReason -> [GhcHint] +illegalClassInstanceHints = \case + IllegalInstanceHead reason -> + illegalInstanceHeadHints reason + IllegalHasFieldInstance has_field_err -> + illegalHasFieldInstanceHints has_field_err + IllegalSpecialClassInstance {} -> noHints + IllegalInstanceFailsCoverageCondition _ coverage_failure -> + failedCoverageConditionHints coverage_failure + + +illegalClassInstanceReason :: IllegalClassInstanceReason -> DiagnosticReason +illegalClassInstanceReason = \case + IllegalInstanceHead reason -> + illegalInstanceHeadReason reason + IllegalHasFieldInstance has_field_err -> + illegalHasFieldInstanceReason has_field_err + IllegalSpecialClassInstance {} -> ErrorWithoutFlag + IllegalInstanceFailsCoverageCondition _ coverage_failure -> + failedCoverageConditionReason coverage_failure + +illegalInstanceHeadHints :: IllegalInstanceHeadReason -> [GhcHint] +illegalInstanceHeadHints = \case + InstHeadTySynArgs -> + [suggestExtension LangExt.TypeSynonymInstances] + InstHeadNonTyVarArgs -> + [suggestExtension LangExt.FlexibleInstances] + InstHeadMultiParam -> + [suggestExtension LangExt.MultiParamTypeClasses] + InstHeadAbstractClass {} -> + noHints + InstHeadNonClassHead {} -> + noHints + +illegalInstanceHeadReason :: IllegalInstanceHeadReason -> DiagnosticReason +illegalInstanceHeadReason = \case + -- These are serious + InstHeadAbstractClass {} -> + ErrorWithoutFlag + InstHeadNonClassHead {} -> + ErrorWithoutFlag + + -- These are less serious (enable an extension) + InstHeadTySynArgs -> + ErrorWithoutFlag + InstHeadNonTyVarArgs -> + ErrorWithoutFlag + InstHeadMultiParam -> + ErrorWithoutFlag + +illegalHasFieldInstanceHints :: IllegalHasFieldInstance -> [GhcHint] +illegalHasFieldInstanceHints = \case + IllegalHasFieldInstanceNotATyCon + -> noHints + IllegalHasFieldInstanceFamilyTyCon + -> noHints + IllegalHasFieldInstanceTyConHasField {} + -> noHints + IllegalHasFieldInstanceTyConHasFields {} + -> noHints + +illegalHasFieldInstanceReason :: IllegalHasFieldInstance -> DiagnosticReason +illegalHasFieldInstanceReason = \case + IllegalHasFieldInstanceNotATyCon + -> ErrorWithoutFlag + IllegalHasFieldInstanceFamilyTyCon + -> ErrorWithoutFlag + IllegalHasFieldInstanceTyConHasField {} + -> ErrorWithoutFlag + IllegalHasFieldInstanceTyConHasFields {} + -> ErrorWithoutFlag + +failedCoverageConditionHints :: CoverageProblem -> [GhcHint] +failedCoverageConditionHints (CoverageProblem { not_covered_liberal = failed_cc }) + = case failed_cc of + FailedLICC -> noHints + FailedICC { alsoFailedLICC = failed_licc } -> + -- Turning on UndecidableInstances makes the check liberal, + -- so if the liberal check passes, suggest enabling UndecidableInstances. + if failed_licc + then noHints + else [suggestExtension LangExt.UndecidableInstances] + +failedCoverageConditionReason :: CoverageProblem -> DiagnosticReason +failedCoverageConditionReason _ = ErrorWithoutFlag + +pprIllegalFamilyInstance :: IllegalFamilyInstanceReason -> SDoc +pprIllegalFamilyInstance = \case + InvalidAssoc reason -> pprInvalidAssoc reason + NotAFamilyTyCon ty_or_data tc -> + vcat [ text "Illegal family instance for" <+> quotes (ppr tc) + , nest 2 $ parens (quotes (ppr tc) <+> text "is not a" <+> what) ] + where + what = ppr ty_or_data <+> text "family" + NotAnOpenFamilyTyCon tc -> + text "Illegal instance for closed family" <+> quotes (ppr tc) + FamilyCategoryMismatch tc -> + text "Wrong category of family instance; declaration was for a" <+> what <> dot + where + what = case tyConFlavour tc of + OpenFamilyFlavour (IAmData {}) _ -> text "data family" + _ -> text "type family" + FamilyArityMismatch _ max_args -> + text "Number of parameters must match family declaration; expected" + <+> ppr max_args <> dot + TyFamNameMismatch fam_tc_name eqn_tc_name -> + hang (text "Mismatched type name in type family instance.") + 2 (vcat [ text "Expected:" <+> ppr fam_tc_name + , text " Actual:" <+> ppr eqn_tc_name ]) + FamInstRHSOutOfScopeTyVars mb_dodgy (NE.toList -> tvs) -> + hang (text "Out of scope type variable" <> plural tvs + <+> pprWithCommas (quotes . ppr) tvs + <+> text "in the RHS of a family instance.") + 2 (text "All such variables must be bound on the LHS.") + $$ mk_extra + where + -- mk_extra: #7536: give a decent error message for + -- type T a = Int + -- type instance F (T a) = a + mk_extra = case mb_dodgy of + Nothing -> empty + Just (fam_tc, pats, dodgy_tvs) -> + ppWhen (any (`elemVarSetByKey` dodgy_tvs) (fmap nameUnique tvs)) $ + hang (text "The real LHS (expanding synonyms) is:") + 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats)) + FamInstLHSUnusedBoundTyVars (NE.toList -> bad_qtvs) -> + vcat [ not_bound_msg, not_used_msg, dodgy_msg ] + where + + -- Filter to only keep user-written variables, + -- unless none were user-written in which case we report all of them + -- (as we need to report an error). + filter_user tvs + = map ifiqtv + $ case filter ifiqtv_user_written tvs of { [] -> tvs ; qvs -> qvs } + + (not_bound, not_used, dodgy) + = case foldr acc_tv ([], [], []) bad_qtvs of + (nb, nu, d) -> (filter_user nb, filter_user nu, filter_user d) + + acc_tv tv (nb, nu, d) = case ifiqtv_reason tv of + InvalidFamInstQTvNotUsedInRHS -> (nb, tv : nu, d) + InvalidFamInstQTvNotBoundInPats -> (tv : nb, nu, d) + InvalidFamInstQTvDodgy -> (nb, nu, tv : d) + + -- Error message for type variables not bound in LHS patterns. + not_bound_msg + | null not_bound + = empty + | otherwise + = vcat [ text "The type variable" <> plural not_bound <+> pprQuotedList not_bound + <+> isOrAre not_bound <+> text "bound by a forall," + , text "but" <+> doOrDoes not_bound <+> text "not appear in any of the LHS patterns of the family instance." ] + + -- Error message for type variables bound by a forall but not used + -- in the RHS. + not_used_msg = + if null not_used + then empty + else text "The type variable" <> plural not_used <+> pprQuotedList not_used + <+> isOrAre not_used <+> text "bound by a forall," $$ + text "but" <+> itOrThey not_used <+> + isOrAre not_used <> text "n't used in the family instance." + + -- Error message for dodgy type variables. + -- See Note [Dodgy binding sites in type family instances] in GHC.Tc.Validity. + dodgy_msg + | null dodgy + = empty + | otherwise + = hang (text "Dodgy type variable" <> plural dodgy <+> pprQuotedList dodgy + <+> text "in the LHS of a family instance:") + 2 (text "the type variable" <> plural dodgy <+> pprQuotedList dodgy + <+> text "syntactically appear" <> singular dodgy <+> text "in LHS patterns," + $$ text "but" <+> itOrThey dodgy <+> doOrDoes dodgy <> text "n't appear in an injective position.") + + +illegalFamilyInstanceHints :: IllegalFamilyInstanceReason -> [GhcHint] +illegalFamilyInstanceHints = \case + InvalidAssoc rea -> invalidAssocHints rea + NotAFamilyTyCon {} -> noHints + NotAnOpenFamilyTyCon {} -> noHints + FamilyCategoryMismatch {} -> noHints + FamilyArityMismatch {} -> noHints + TyFamNameMismatch {} -> noHints + FamInstRHSOutOfScopeTyVars {} -> noHints + FamInstLHSUnusedBoundTyVars {} -> noHints + +illegalFamilyInstanceReason :: IllegalFamilyInstanceReason -> DiagnosticReason +illegalFamilyInstanceReason = \case + InvalidAssoc rea -> invalidAssocReason rea + NotAFamilyTyCon {} -> ErrorWithoutFlag + NotAnOpenFamilyTyCon {} -> ErrorWithoutFlag + FamilyCategoryMismatch {} -> ErrorWithoutFlag + FamilyArityMismatch {} -> ErrorWithoutFlag + TyFamNameMismatch {} -> ErrorWithoutFlag + FamInstRHSOutOfScopeTyVars {} -> ErrorWithoutFlag + FamInstLHSUnusedBoundTyVars {} -> ErrorWithoutFlag + +pprInvalidAssoc :: InvalidAssoc -> SDoc +pprInvalidAssoc = \case + InvalidAssocInstance rea -> pprInvalidAssocInstance rea + InvalidAssocDefault rea -> pprInvalidAssocDefault rea + +pprInvalidAssocInstance :: InvalidAssocInstance -> SDoc +pprInvalidAssocInstance = \case + AssocInstanceMissing name -> + text "No explicit" <+> text "associated type" + <+> text "or default declaration for" + <+> quotes (ppr name) + AssocInstanceNotInAClass fam_tc -> + text "Associated type" <+> quotes (ppr fam_tc) <+> + text "must be inside a class instance" + AssocNotInThisClass cls fam_tc -> + hsep [ text "Class", quotes (ppr cls) + , text "does not have an associated type", quotes (ppr fam_tc) ] + AssocNoClassTyVar cls fam_tc -> + 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 cls <+> hsep (map ppr (classTyVars cls)))] + AssocTyVarsDontMatch vis fam_tc exp_tys act_tys -> + pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag vis) $ + vcat [ text "Type indexes must match class instance head" + , text "Expected:" <+> pp exp_tys + , text " Actual:" <+> pp act_tys ] + where + pp tys = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ + toIfaceTcArgs fam_tc tys + +pprInvalidAssocDefault :: InvalidAssocDefault -> SDoc +pprInvalidAssocDefault = \case + AssocDefaultNotAssoc cls tc -> + hsep [ text "Class", quotes (ppr cls) + , text "does not have an associated type", quotes (ppr tc) ] + AssocMultipleDefaults name -> + text "More than one default declaration for" <+> quotes (ppr name) + AssocDefaultBadArgs fam_tc pat_tys bad_arg -> + let (pat_vis, main_msg) = case bad_arg of + AssocDefaultNonTyVarArg (pat_ty, pat_vis) -> + (pat_vis, + text "Illegal argument" <+> quotes (ppr pat_ty) <+> text "in:") + AssocDefaultDuplicateTyVars dups -> + let (pat_tv, pat_vis) = NE.head dups + in (pat_vis, + text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:") + in pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag pat_vis) $ + hang main_msg + 2 (vcat [ppr_eqn, suggestion]) + where + ppr_eqn :: SDoc + ppr_eqn = + quotes (text "type" <+> ppr (mkTyConApp fam_tc pat_tys) + <+> equals <+> text "...") + + suggestion :: SDoc + suggestion = text "The arguments to" <+> quotes (ppr fam_tc) + <+> text "must all be distinct type variables." + +invalidAssocHints :: InvalidAssoc -> [GhcHint] +invalidAssocHints = \case + InvalidAssocInstance rea -> invalidAssocInstanceHints rea + InvalidAssocDefault rea -> invalidAssocDefaultHints rea + +invalidAssocInstanceHints :: InvalidAssocInstance -> [GhcHint] +invalidAssocInstanceHints = \case + AssocInstanceMissing {} -> noHints + AssocInstanceNotInAClass {} -> noHints + AssocNotInThisClass {} -> noHints + AssocNoClassTyVar {} -> noHints + AssocTyVarsDontMatch {} -> noHints + +invalidAssocDefaultHints :: InvalidAssocDefault -> [GhcHint] +invalidAssocDefaultHints = \case + AssocDefaultNotAssoc {} -> noHints + AssocMultipleDefaults {} -> noHints + AssocDefaultBadArgs _ _ bad -> + assocDefaultBadArgHints bad + +assocDefaultBadArgHints :: AssocDefaultBadArgs -> [GhcHint] +assocDefaultBadArgHints = \case + AssocDefaultNonTyVarArg {} -> noHints + AssocDefaultDuplicateTyVars {} -> noHints + +invalidAssocReason :: InvalidAssoc -> DiagnosticReason +invalidAssocReason = \case + InvalidAssocInstance rea -> invalidAssocInstanceReason rea + InvalidAssocDefault rea -> invalidAssocDefaultReason rea + +invalidAssocInstanceReason :: InvalidAssocInstance -> DiagnosticReason +invalidAssocInstanceReason = \case + AssocInstanceMissing {} -> WarningWithFlag (Opt_WarnMissingMethods) + AssocInstanceNotInAClass {} -> ErrorWithoutFlag + AssocNotInThisClass {} -> ErrorWithoutFlag + AssocNoClassTyVar {} -> ErrorWithoutFlag + AssocTyVarsDontMatch {} -> ErrorWithoutFlag + +invalidAssocDefaultReason :: InvalidAssocDefault -> DiagnosticReason +invalidAssocDefaultReason = \case + AssocDefaultNotAssoc {} -> ErrorWithoutFlag + AssocMultipleDefaults {} -> ErrorWithoutFlag + AssocDefaultBadArgs _ _ rea -> + assocDefaultBadArgReason rea + +assocDefaultBadArgReason :: AssocDefaultBadArgs -> DiagnosticReason +assocDefaultBadArgReason = \case + AssocDefaultNonTyVarArg {} -> ErrorWithoutFlag + AssocDefaultDuplicateTyVars {} -> ErrorWithoutFlag + +-------------------------------------------------------------------------------- +-- Template Haskell quotes and splices + +pprTHError :: THError -> DecoratedSDoc +pprTHError = \case + THSyntaxError err -> pprTHSyntaxError err + THNameError err -> pprTHNameError err + THReifyError err -> pprTHReifyError err + TypedTHError err -> pprTypedTHError err + THSpliceFailed rea -> pprSpliceFailReason rea + AddTopDeclsError err -> pprAddTopDeclsError err + + IllegalStaticFormInSplice e -> + mkSimpleDecorated $ + sep [ text "static forms cannot be used in splices:" + , nest 2 $ ppr e + ] + + FailedToLookupThInstName th_type reason -> + mkSimpleDecorated $ + case reason of + NoMatchesFound -> + text "Couldn't find any instances of" + <+> text (TH.pprint th_type) + <+> text "to add documentation to" + CouldNotDetermineInstance -> + text "Couldn't work out what instance" + <+> text (TH.pprint th_type) + <+> text "is supposed to be" + + AddInvalidCorePlugin plugin -> + mkSimpleDecorated $ + hang (text "addCorePlugin: invalid plugin module" <+> quotes (text plugin) ) + 2 (text "Plugins in the current package can't be specified.") + + AddDocToNonLocalDefn doc_loc -> + mkSimpleDecorated $ + text "Can't add documentation to" <+> ppr_loc doc_loc <> comma <+> + text "as it isn't inside the current module." + where + ppr_loc (TH.DeclDoc n) = text $ TH.pprint n + ppr_loc (TH.ArgDoc n _) = text $ TH.pprint n + ppr_loc (TH.InstDoc t) = text $ TH.pprint t + ppr_loc TH.ModuleDoc = text "the module header" + + ReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg + +pprTHSyntaxError :: THSyntaxError -> DecoratedSDoc +pprTHSyntaxError = mkSimpleDecorated . \case + IllegalTHQuotes expr -> + text "Syntax error on" <+> ppr expr + -- The error message context will say + -- "In the Template Haskell quotation", so no need to repeat that here. + BadImplicitSplice -> + sep [ text "Parse error: module header, import declaration" + , text "or top-level declaration expected." ] + -- The compiler should not mention TemplateHaskell, as the common case + -- is that this is a simple beginner error, for example: + -- + -- module M where + -- f :: Int -> Int; f x = x + -- xyzzy + -- g y = f y + 1 + -- + -- It's unlikely that 'xyzzy' above was intended to be a Template Haskell + -- splice; instead it's probably something mistakenly left in the code. + -- See #12146 for discussion. + + IllegalTHSplice -> + text "Unexpected top-level splice." + MismatchedSpliceType splice_type inner_splice_or_bracket -> + inner <+> text "may not appear in" <+> outer <> dot + where + (inner, outer) = case inner_splice_or_bracket of + IsSplice -> case splice_type of + Typed -> (text "Typed splices" , text "untyped brackets") + Untyped -> (text "Untyped splices", text "typed brackets") + IsBracket -> + case splice_type of + Typed -> (text "Untyped brackets", text "typed splices") + Untyped -> (text "Typed brackets" , text "untyped splices") + NestedTHBrackets -> + text "Template Haskell brackets cannot be nested" <+> + text "(without intervening splices)" + +pprTHNameError :: THNameError -> DecoratedSDoc +pprTHNameError = \case + NonExactName name -> + mkSimpleDecorated $ + 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.") + +pprTHReifyError :: THReifyError -> DecoratedSDoc +pprTHReifyError = \case + CannotReifyInstance ty + -> mkSimpleDecorated $ + hang (text "reifyInstances:" <+> quotes (ppr ty)) + 2 (text "is not a class constraint or type family application") + CannotReifyOutOfScopeThing th_name + -> mkSimpleDecorated $ + quotes (text (TH.pprint th_name)) <+> + text "is not in scope at a reify" + -- Ugh! Rather an indirect way to display the name + CannotReifyThingNotInTypeEnv name + -> mkSimpleDecorated $ + quotes (ppr name) <+> text "is not in the type environment at a reify" + NoRolesAssociatedWithThing thing + -> mkSimpleDecorated $ + text "No roles associated with" <+> (ppr thing) + CannotRepresentType sort ty + -> mkSimpleDecorated $ + hang (text "Can't represent" <+> sort_doc <+> text "in Template Haskell:") + 2 (ppr ty) + where + sort_doc = text $ + case sort of + LinearInvisibleArgument -> "linear invisible argument" + CoercionsInTypes -> "coercions in types" + DataConVisibleForall -> "visible forall in the type of a data constructor" + +pprTypedTHError :: TypedTHError -> DecoratedSDoc +pprTypedTHError = \case + SplicePolymorphicLocalVar ident + -> mkSimpleDecorated $ + text "Can't splice the polymorphic local variable" <+> quotes (ppr ident) + TypedTHWithPolyType ty + -> mkSimpleDecorated $ + vcat [ text "Illegal polytype:" <+> ppr ty + , text "The type of a Typed Template Haskell expression must" <+> + text "not have any quantification." ] + +pprSpliceFailReason :: SpliceFailReason -> DecoratedSDoc +pprSpliceFailReason = \case + SpliceThrewException phase _exn exn_msg expr show_code -> + mkSimpleDecorated $ + vcat [ text "Exception when trying to" <+> text phaseStr <+> text "compile-time code:" + , nest 2 (text exn_msg) + , if show_code then text "Code:" <+> ppr expr else empty] + where phaseStr = + case phase of + SplicePhase_Run -> "run" + SplicePhase_CompileAndLink -> "compile and link" + RunSpliceFailure err -> pprRunSpliceFailure Nothing err + +pprAddTopDeclsError :: AddTopDeclsError -> DecoratedSDoc +pprAddTopDeclsError = \case + InvalidTopDecl _decl -> + mkSimpleDecorated $ + sep [ text "Only function, value, annotation, and foreign import declarations" + , text "may be added with" <+> quotes (text "addTopDecls") <> dot ] + AddTopDeclsUnexpectedDeclarationSplice {} -> + mkSimpleDecorated $ + text "Declaration splices are not permitted" <+> + text "inside top-level declarations added with" <+> + quotes (text "addTopDecls") <> dot + AddTopDeclsRunSpliceFailure err -> + pprRunSpliceFailure (Just "addTopDecls") err + +pprRunSpliceFailure :: Maybe String -> RunSpliceFailReason -> DecoratedSDoc +pprRunSpliceFailure mb_calling_fn (ConversionFail what reason) = + mkSimpleDecorated . add_calling_fn . addSpliceInfo $ + pprConversionFailReason reason + where + add_calling_fn rest = + case mb_calling_fn of + Just calling_fn -> + hang (text "Error in a declaration passed to" <+> quotes (text calling_fn) <> colon) + 2 rest + Nothing -> rest + addSpliceInfo = case what of + ConvDec d -> addSliceInfo' "declaration" d + ConvExp e -> addSliceInfo' "expression" e + ConvPat p -> addSliceInfo' "pattern" p + ConvType t -> addSliceInfo' "type" t + addSliceInfo' what item reasonErr = reasonErr $$ descr + where + -- Show the item in pretty syntax normally, + -- but with all its constructors if you say -dppr-debug + descr = hang (text "When splicing a TH" <+> text what <> colon) + 2 (getPprDebug $ \case + True -> text (show item) + False -> text (TH.pprint item)) + +thErrorReason :: THError -> DiagnosticReason +thErrorReason = \case + THSyntaxError err -> thSyntaxErrorReason err + THNameError err -> thNameErrorReason err + THReifyError err -> thReifyErrorReason err + TypedTHError err -> typedTHErrorReason err + THSpliceFailed rea -> spliceFailedReason rea + AddTopDeclsError err -> addTopDeclsErrorReason err + + IllegalStaticFormInSplice {} -> ErrorWithoutFlag + FailedToLookupThInstName {} -> ErrorWithoutFlag + AddInvalidCorePlugin {} -> ErrorWithoutFlag + AddDocToNonLocalDefn {} -> ErrorWithoutFlag + ReportCustomQuasiError is_error _ -> + if is_error + then ErrorWithoutFlag + else WarningWithoutFlag + +thSyntaxErrorReason :: THSyntaxError -> DiagnosticReason +thSyntaxErrorReason = \case + IllegalTHQuotes{} -> ErrorWithoutFlag + BadImplicitSplice -> ErrorWithoutFlag + IllegalTHSplice{} -> ErrorWithoutFlag + NestedTHBrackets{} -> ErrorWithoutFlag + MismatchedSpliceType{} -> ErrorWithoutFlag + +thNameErrorReason :: THNameError -> DiagnosticReason +thNameErrorReason = \case + NonExactName {} -> ErrorWithoutFlag + +thReifyErrorReason :: THReifyError -> DiagnosticReason +thReifyErrorReason = \case + CannotReifyInstance {} -> ErrorWithoutFlag + CannotReifyOutOfScopeThing {} -> ErrorWithoutFlag + CannotReifyThingNotInTypeEnv {} -> ErrorWithoutFlag + NoRolesAssociatedWithThing {} -> ErrorWithoutFlag + CannotRepresentType {} -> ErrorWithoutFlag + +typedTHErrorReason :: TypedTHError -> DiagnosticReason +typedTHErrorReason = \case + SplicePolymorphicLocalVar {} -> ErrorWithoutFlag + TypedTHWithPolyType {} -> ErrorWithoutFlag + +spliceFailedReason :: SpliceFailReason -> DiagnosticReason +spliceFailedReason = \case + SpliceThrewException {} -> ErrorWithoutFlag + RunSpliceFailure {} -> ErrorWithoutFlag + +addTopDeclsErrorReason :: AddTopDeclsError -> DiagnosticReason +addTopDeclsErrorReason = \case + InvalidTopDecl {} + -> ErrorWithoutFlag + AddTopDeclsUnexpectedDeclarationSplice {} + -> ErrorWithoutFlag + AddTopDeclsRunSpliceFailure {} + -> ErrorWithoutFlag + +thErrorHints :: THError -> [GhcHint] +thErrorHints = \case + THSyntaxError err -> thSyntaxErrorHints err + THNameError err -> thNameErrorHints err + THReifyError err -> thReifyErrorHints err + TypedTHError err -> typedTHErrorHints err + THSpliceFailed rea -> spliceFailedHints rea + AddTopDeclsError err -> addTopDeclsErrorHints err + + IllegalStaticFormInSplice {} -> noHints + FailedToLookupThInstName {} -> noHints + AddInvalidCorePlugin {} -> noHints + AddDocToNonLocalDefn {} -> noHints + ReportCustomQuasiError {} -> noHints + +thSyntaxErrorHints :: THSyntaxError -> [GhcHint] +thSyntaxErrorHints = \case + IllegalTHQuotes{} + -> [suggestExtension LangExt.TemplateHaskellQuotes] + BadImplicitSplice {} + -> noHints -- NB: don't suggest TemplateHaskell + -- see comments on BadImplicitSplice in pprTHSyntaxError + IllegalTHSplice{} + -> [suggestExtension LangExt.TemplateHaskell] + NestedTHBrackets{} + -> noHints + MismatchedSpliceType{} + -> noHints + +thNameErrorHints :: THNameError -> [GhcHint] +thNameErrorHints = \case + NonExactName {} -> noHints + +thReifyErrorHints :: THReifyError -> [GhcHint] +thReifyErrorHints = \case + CannotReifyInstance {} -> noHints + CannotReifyOutOfScopeThing {} -> noHints + CannotReifyThingNotInTypeEnv {} -> noHints + NoRolesAssociatedWithThing {} -> noHints + CannotRepresentType {} -> noHints + +typedTHErrorHints :: TypedTHError -> [GhcHint] +typedTHErrorHints = \case + SplicePolymorphicLocalVar {} -> noHints + TypedTHWithPolyType {} -> noHints + +spliceFailedHints :: SpliceFailReason -> [GhcHint] +spliceFailedHints = \case + SpliceThrewException {} -> noHints + RunSpliceFailure {} -> noHints + +addTopDeclsErrorHints :: AddTopDeclsError -> [GhcHint] +addTopDeclsErrorHints = \case + InvalidTopDecl {} + -> noHints + AddTopDeclsUnexpectedDeclarationSplice {} + -> noHints + AddTopDeclsRunSpliceFailure {} + -> noHints + +-------------------------------------------------------------------------------- + +pprPatersonCondFailure :: + PatersonCondFailure -> PatersonCondFailureContext -> Type -> Type -> SDoc +pprPatersonCondFailure (PCF_TyVar tvs) InInstanceDecl lhs rhs = + hang (occMsg tvs) + 2 (sep [ text "in the constraint" <+> quotes (ppr lhs) + , text "than in the instance head" <+> quotes (ppr rhs) ]) + where + occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs) + <+> pp_occurs <+> text "more often" + pp_occurs | isSingleton tvs = text "occurs" + | otherwise = text "occur" +pprPatersonCondFailure (PCF_TyVar tvs) InTyFamEquation lhs rhs = + hang (occMsg tvs) + 2 (sep [ text "in the type-family application" <+> quotes (ppr rhs) + , text "than in the LHS of the family instance" <+> quotes (ppr lhs) ]) + where + occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs) + <+> pp_occurs <+> text "more often" + pp_occurs | isSingleton tvs = text "occurs" + | otherwise = text "occur" +pprPatersonCondFailure PCF_Size InInstanceDecl lhs rhs = + hang (text "The constraint" <+> quotes (ppr lhs)) + 2 (sep [ text "is no smaller than", pp_rhs ]) + where pp_rhs = text "the instance head" <+> quotes (ppr rhs) +pprPatersonCondFailure PCF_Size InTyFamEquation lhs rhs = + hang (text "The type-family application" <+> quotes (ppr rhs)) + 2 (sep [ text "is no smaller than", pp_lhs ]) + where pp_lhs = text "the LHS of the family instance" <+> quotes (ppr lhs) +pprPatersonCondFailure (PCF_TyFam tc) InInstanceDecl lhs _rhs = + hang (text "Illegal use of type family" <+> quotes (ppr tc)) + 2 (text "in the constraint" <+> quotes (ppr lhs)) +pprPatersonCondFailure (PCF_TyFam tc) InTyFamEquation _lhs rhs = + hang (text "Illegal nested use of type family" <+> quotes (ppr tc)) + 2 (text "in the arguments of the type-family application" <+> quotes (ppr rhs)) + +-------------------------------------------------------------------------------- + +defaultTypesAndImport :: ClassDefaults -> SDoc +defaultTypesAndImport ClassDefaults{cd_types, cd_provenance = DP_Imported cdm} = + hang (parens $ pprWithCommas ppr cd_types) + 2 (text "imported from" <+> ppr cdm) +defaultTypesAndImport ClassDefaults{cd_types} = parens (pprWithCommas ppr cd_types) + +-------------------------------------------------------------------------------- + +pprZonkerMessage :: ZonkerMessage -> SDoc +pprZonkerMessage = \case + ZonkerCannotDefaultConcrete frr -> + ppr (frr_context frr) $$ + text "cannot be assigned a fixed runtime representation," <+> + text "not even by defaulting." + +zonkerMessageHints :: ZonkerMessage -> [GhcHint] +zonkerMessageHints = \case + ZonkerCannotDefaultConcrete {} -> [SuggestAddTypeSignatures UnnamedBinding] + +zonkerMessageReason :: ZonkerMessage -> DiagnosticReason +zonkerMessageReason = \case + ZonkerCannotDefaultConcrete {} -> ErrorWithoutFlag + +-------------------------------------------------------------------------------- + +pprTypeSyntaxName :: TypeSyntax -> SDoc +pprTypeSyntaxName TypeKeywordSyntax = "keyword" <+> quotes "type" +pprTypeSyntaxName ForallTelescopeSyntax = "forall telescope" +pprTypeSyntaxName ContextArrowSyntax = "context arrow (=>)" +pprTypeSyntaxName FunctionArrowSyntax = "function type arrow (->)" + +-------------------------------------------------------------------------------- +-- ErrCtxt + +pprTyConInstFlavour :: TyConInstFlavour -> SDoc +pprTyConInstFlavour + ( TyConInstFlavour + { tyConInstFlavour = flav + , tyConInstIsDefault = is_dflt + } + ) = (if is_dflt then text "default" else empty) <+> ppr flav <+> text "instance" + +pprErrCtxtMsg :: ErrCtxtMsg -> SDoc +pprErrCtxtMsg = \case + ExprCtxt expr -> + hang (text "In the expression:") + 2 (ppr (stripParensHsExpr expr)) + ThetaCtxt ctxt theta -> + vcat [ text "In the context:" <+> pprTheta theta + , text "While checking" <+> pprUserTypeCtxt ctxt ] + QuantifiedCtCtxt pty -> + text "In the quantified constraint" <+> quotes (ppr pty) + InferredTypeCtxt poly_name poly_ty -> + vcat [ text "When checking the inferred type" + , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] + SigCtxt sig -> + text "In" <+> ppr sig + UserSigCtxt 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) + RecordUpdCtxt ne_relevant_cons@(relevant_con :| _) upd_fld_names ex_tvs -> + make_lines_msg $ + (text "In a record update at field" <> plural upd_fld_names <+> pprQuotedList upd_fld_names :) + $ case relevant_con of + RealDataCon con -> + [ text "with type constructor" <+> quotes (ppr (dataConTyCon con)) + , text "data constructor" <+> plural relevant_cons <+> cons ] + PatSynCon {} -> + [ text "with pattern synonym" <+> plural relevant_cons <+> cons ] + ++ if null ex_tvs + then [] + else [ text "existential variable" <> plural ex_tvs <+> pprQuotedList ex_tvs ] + + where + cons = pprQuotedList relevant_cons + relevant_cons = NE.toList ne_relevant_cons + -- Pretty-print a collection of lines, adding commas at the end of each line, + -- and adding "and" to the start of the last line. + make_lines_msg :: [SDoc] -> SDoc + make_lines_msg [] = empty + make_lines_msg [last] = ppr last <> dot + make_lines_msg [l1,l2] = l1 $$ text "and" <+> l2 <> dot + make_lines_msg (l:ls) = l <> comma $$ make_lines_msg ls + PatSigErrCtxt sig_ty res_ty -> + vcat [ hang (text "When checking that the pattern signature:") + 4 (ppr sig_ty) + , nest 2 (hang (text "fits the type of its context:") + 2 (ppr res_ty)) ] + PatCtxt pat -> + hang (text "In the pattern:") 2 (ppr pat) + PatSynDeclCtxt name -> + text "In the declaration for pattern synonym" <+> quotes (ppr name) + ClassOpCtxt meth meth_ty -> + sep [ text "When checking the class method:" + , nest 2 (pprPrefixOcc meth <+> dcolon <+> ppr meth_ty)] + MethSigCtxt sel_name sig_ty meth_ty -> + hang (text "When checking that instance signature for" <+> quotes (ppr sel_name)) + 2 (vcat [ text "is more general than its signature in the class" + , text "Instance sig:" <+> ppr sig_ty + , text " Class sig:" <+> ppr meth_ty ]) + PatMonoBindsCtxt pat grhss -> + hang (text "In a pattern binding:") + 2 (pprPatBind pat grhss) + ForeignDeclCtxt fo -> + hang (text "When checking declaration:") + 2 (ppr fo) + RuleCtxt rule_name -> + text "When checking the rewrite rule" <+> doubleQuotes (ftext rule_name) + FieldCtxt field_name -> + text "In the" <+> quotes (ppr field_name) <+> text "field of a record" + TypeCtxt ty -> + text "In the type" <+> quotes (ppr ty) + KindCtxt ki -> + text "In the kind" <+> quotes (ppr ki) + SubTypeCtxt ty_expected ty_actual -> + vcat [ hang (text "When checking that:") + 4 (ppr ty_actual) + , nest 2 (hang (text "is more polymorphic than:") + 2 (ppr ty_expected)) ] + AmbiguityCheckCtxt ctxt allow_ambiguous -> + vcat [ text "In the ambiguity check for" <+> what + , ppUnless allow_ambiguous ambig_msg ] + where + ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes" + what | Just n <- isSigMaybe ctxt = quotes (ppr n) + | otherwise = pprUserTypeCtxt ctxt + + FunAppCtxt fun_arg arg_no -> + hang (hsep [ text "In the", speakNth arg_no, text "argument of" + , quotes fun <> text ", namely"]) + 2 (quotes arg) + where + fun, arg :: SDoc + (fun, arg) = case fun_arg of + FunAppCtxtExpr fn a -> (ppr fn, ppr a) + FunAppCtxtTy fn a -> (ppr fn, ppr a) + FunTysCtxt herald fun_ty n_vis_args_in_call n_fun_args + | n_vis_args_in_call <= n_fun_args -- Enough args, in the end + -> text "In the result of a function call" + | otherwise + -> hang (full_herald <> comma) + 2 (sep [ text "but its type" <+> quotes (pprSigmaType fun_ty) + , if n_fun_args == 0 then text "has none" + else text "has only" <+> speakN n_fun_args]) + where + full_herald = pprExpectedFunTyHerald herald + <+> speakNOf n_vis_args_in_call (text "visible argument") + -- What are "visible" arguments? See Note [Visibility and arity] in GHC.Types.Basic + FunResCtxt fun n_val_args res_fun res_env n_fun n_env + | -- Check for too few args + -- fun_tau = a -> b, res_tau = Int + n_fun > n_env + , not_fun res_env + -> text "Probable cause:" <+> quotes (ppr fun) + <+> text "is applied to too few arguments" + + | -- Check for too many args + -- fun_tau = a -> Int, res_tau = a -> b -> c -> d + -- The final guard suppresses the message when there + -- aren't enough args to drop; eg. the call is (f e1) + n_fun < n_env + , not_fun res_fun + , n_fun + n_val_args >= n_env + -- Never suggest that a naked variable is + -- applied to too many args! + -> text "Possible cause:" <+> quotes (ppr fun) + <+> text "is applied to too many arguments" + + | otherwise + -> empty + where + not_fun ty -- ty is definitely not an arrow type, + -- and cannot conceivably become one + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isAlgTyCon tc + Nothing -> False + + TyConDeclCtxt name flav -> + hsep [ text "In the", ppr flav + , text "declaration for", quotes (ppr name) ] + TyConInstCtxt name flav -> + hsep [ text "In the" <+> pprTyConInstFlavour flav <+> text "declaration for" + , quotes (ppr name) ] + DataConDefCtxt cons -> + text "In the definition of data constructor" <> plural (NE.toList cons) + <+> ppr_cons (NE.toList cons) + where + ppr_cons :: [LocatedN Name] -> SDoc + ppr_cons [con] = quotes (ppr con) + ppr_cons cons = interpp'SP cons + DataConResTyCtxt cons -> + text "In the result type of data constructor" <> plural (NE.toList cons) + <+> ppr_cons (NE.toList cons) + where + ppr_cons :: [LocatedN Name] -> SDoc + ppr_cons [con] = quotes (ppr con) + ppr_cons cons = interpp'SP cons + ClosedFamEqnCtxt tc -> + text "In the equations for closed type family" <+> + quotes (ppr tc) + TySynErrCtxt tc -> + text "In the expansion of type synonym" <+> quotes (ppr tc) + RoleAnnotErrCtxt name -> + nest 2 $ text "while checking a role annotation for" <+> quotes (ppr name) + CmdCtxt cmd -> + text "In the command:" <+> ppr cmd + InstDeclErrCtxt either_ty_ty -> + hang (text "In the instance declaration for") + 2 (quotes $ ppr_ty) + where + ppr_ty = case either_ty_ty of + Left ty -> ppr ty + Right ty -> ppr ty + StaticFormCtxt expr -> + hang (text "In the body of a static form:") + 2 (ppr expr) + DefaultDeclErrCtxt { ddec_in_type_list = in_type_list } -> + if in_type_list + then + text "When checking the types in a default declaration" + else + text "When checking the class at the head of a named default declaration" + MainCtxt main_name -> + text "When checking the type of the" + <+> ppMainFn (nameOccName main_name) + + VDQWarningCtxt tycon -> + vcat + [ text "NB: Type" <+> quotes (ppr tycon) <+> + text "was inferred to use visible dependent quantification." + , text "Most types with visible dependent quantification are" + , text "polymorphically recursive and need a standalone kind" + , text "signature. Perhaps supply one, with StandaloneKindSignatures." + ] + TermLevelUseCtxt name ctxt -> + pprTermLevelUseCtxt name ctxt + + StmtErrCtxt ctxt stmt + -- For [ e | .. ], do not mutter about "stmts" + | LastStmt _ e _ _ <- stmt + , isComprehensionContext ctxt + -> hang (text "In the expression:") 2 (ppr e) + | otherwise + -> hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) + 2 (ppr_stmt stmt) + where + -- For Group and Transform Stmts, don't print the nested stmts! + ppr_stmt (TransStmt { trS_by = by, trS_using = using + , trS_form = form }) = pprTransStmt by using form + ppr_stmt stmt = pprStmt stmt + + DerivInstCtxt pred -> + text "When deriving the instance for" <+> parens (ppr pred) + StandaloneDerivCtxt ty -> + hang (text "In the stand-alone deriving instance for") + 2 (quotes (ppr ty)) + DerivBindCtxt sel_id clas tys -> + vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id) + , nest 2 (text "in a derived instance for" + <+> quotes (pprClassPred clas tys) <> colon) + , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ] + + + ExportCtxt ie -> + text "In the export:" <+> ppr ie + PatSynExportCtxt ps -> + text "In the pattern synonym:" <+> ppr ps + PatSynRecSelExportCtxt _ps sel -> + text "In the pattern synonym record selector:" <+> ppr sel + + SyntaxNameCtxt name orig ty loc -> + vcat [ text "when checking that" <+> quotes (ppr name) + <+> text "(needed by a syntactic construct)" + , nest 2 (text "has the required type:" + <+> ppr ty) + , nest 2 (sep [ppr orig, text "at" <+> ppr loc])] + + AnnCtxt ann -> + hang (text "In the annotation:") 2 (ppr ann) + SpecPragmaCtxt prag -> + hang (text "In the pragma:") 2 (ppr prag) + MatchCtxt ctxt -> + text "In" <+> pprMatchContext ctxt + MatchInCtxt match -> + hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon) + 4 (pprMatch match) + UntypedTHBracketCtxt br -> + hang (text "In the Template Haskell quotation" <> colon) + 2 (ppr br) + TypedTHBracketCtxt br_body -> + hang (text "In the Template Haskell typed quotation" <> colon) + 2 (thTyBrackets . ppr $ br_body) + UntypedSpliceCtxt splice -> + hang (text "In the" <+> what) 2 (pprUntypedSplice True Nothing splice) + where + what = case splice of + HsUntypedSpliceExpr {} -> text "untyped splice:" + HsQuasiQuote {} -> text "quasi-quotation:" + TypedSpliceCtxt mb_nm expr -> + hang (text "In the typed Template Haskell splice:") + 2 (pprTypedSplice mb_nm expr) + TypedSpliceResultCtxt expr -> + sep [ text "In the result of the splice:" + , nest 2 (pprTypedSplice Nothing (HsTypedSpliceExpr noExtField expr)) + , text "To see what the splice expanded to, use -ddump-splices"] + + ReifyInstancesCtxt th_nm th_tys -> + text "In the argument of" <+> quotes (text "reifyInstances") <> colon + <+> ppr_th th_nm <+> sep (map ppr_th th_tys) + where + ppr_th :: TH.Ppr a => a -> SDoc + ppr_th x = text (TH.pprint x) + + MergeSignaturesCtxt unit_state mod_name reqs -> + pprWithUnitState unit_state $ + if null reqs + then text "While checking the local signature" <+> ppr mod_name <+> + text "for consistency" + else hang (text "While merging the signatures from" <> colon) + 2 (vcat [ bullet <+> ppr req | req <- reqs ] $$ + bullet <+> text "...and the local signature for" <+> ppr mod_name) + CheckImplementsCtxt unit_state impl_mod (Module req_uid req_mod_name) -> + pprWithUnitState unit_state $ + text "While checking that" <+> quotes (ppr impl_mod) <+> + text "implements signature" <+> quotes (ppr req_mod_name) <+> + text "in" <+> quotes (ppr req_uid) <> dot + +-------------------------------------------------------------------------------- + +pprThBindLevel :: Set.Set ThLevelIndex -> SDoc +pprThBindLevel levels_set = text "level" <> pluralSet levels_set <+> pprUnquotedSet levels_set diff --git a/GHC/Tc/Errors/Types.hs b/GHC/Tc/Errors/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Types.hs @@ -0,0 +1,7064 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Tc.Errors.Types ( + -- * Main types + TcRnMessage(..) + , TcRnMessageOpts(..) + , mkTcRnUnknownMessage + , TcRnMessageDetailed(..), ErrInfo(..) + , TypeDataForbids(..) + , FixedRuntimeRepProvenance(..) + , pprFixedRuntimeRepProvenance + , ShadowedNameProvenance(..) + , ResolvedNameInfo(..) + , pprResolvedNameProvenance + , RecordFieldPart(..) + , IllegalNewtypeReason(..) + , BadRecordUpdateReason(..) + , InjectivityErrReason(..) + , HasKinds(..) + , hasKinds + , SuggestUndecidableInstances(..) + , suggestUndecidableInstances + , SuggestUnliftedTypes(..) + , DataSort(..), ppDataSort + , AllowedDataResKind(..) + , NotClosedReason(..) + , SuggestPartialTypeSignatures(..) + , suggestPartialTypeSignatures + , DeriveInstanceErrReason(..) + , UsingGeneralizedNewtypeDeriving(..) + , usingGeneralizedNewtypeDeriving + , DeriveAnyClassEnabled(..) + , deriveAnyClassEnabled + , DeriveInstanceBadConstructor(..) + , HasWildcard(..) + , hasWildcard + , BadAnonWildcardContext(..) + , SoleExtraConstraintWildcardAllowed(..) + , DeriveGenericsErrReason(..) + , HasAssociatedDataFamInsts(..) + , hasAssociatedDataFamInsts + , AssociatedTyLastVarInKind(..) + , associatedTyLastVarInKind + , AssociatedTyNotParamOverLastTyVar(..) + , associatedTyNotParamOverLastTyVar + , MissingSignature(..) + , Exported(..) + , HsDocContext(..) + , FixedRuntimeRepErrorInfo(..) + , TcRnNoDerivStratSpecifiedInfo(..) + + , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc + + , SolverReport(..), SupplementaryInfo(..) + , SolverReportWithCtxt(..) + , SolverReportErrCtxt(..) + , getUserGivens, discardProvCtxtGivens + , TcSolverReportMsg(..) + , CannotUnifyVariableReason(..) + , MismatchMsg(..) + , MismatchEA(..) + , mkPlainMismatchMsg, mkBasicMismatchMsg + , WhenMatching(..) + , ExpectedActualInfo(..) + , TyVarInfo(..), SameOccInfo(..) + , AmbiguityInfo(..) + , CND_Extra(..) + , FitsMbSuppressed(..) + , ValidHoleFits(..), noValidHoleFits + , HoleFitDispConfig(..) + , RelevantBindings(..), pprRelevantBindings + , PromotionErr(..), pprPECategory, peCategory + , TermLevelUseErr(..), teCategory + , NotInScopeError(..) + , Subordinate(..), pprSubordinate + , ImportError(..) + , WhatLooking(..) + , lookingForSubordinate + , HoleError(..) + , CoercibleMsg(..) + , PotentialInstances(..) + , UnsupportedCallConvention(..) + , ExpectedBackends + , ArgOrResult(..) + , MatchArgsContext(..), MatchArgBadMatches(..) + , PragmaWarningInfo(..) + , EmptyStatementGroupErrReason(..) + , UnexpectedStatement(..) + , DeclSort(..) + , NonStandardGuards(..) + , RuleLhsErrReason(..) + , HsigShapeMismatchReason(..) + , WrongThingSort(..) + , LevelCheckReason(..) + , UninferrableTyVarCtx(..) + , PatSynInvalidRhsReason(..) + , BadFieldAnnotationReason(..) + , SuperclassCycle(..) + , SuperclassCycleDetail(..) + , RoleValidationFailedReason(..) + , DisabledClassExtension(..) + , TyFamsDisabledReason(..) + , BadInvisPatReason(..) + , BadEmptyCaseReason(..) + , HsTypeOrSigType(..) + , HsTyVarBndrExistentialFlag(..) + , TySynCycleTyCons + , BadImportKind(..) + , DodgyImportsReason (..) + , ImportLookupExtensions (..) + , ImportLookupReason (..) + , UnusedImportReason (..) + , UnusedImportName (..) + , NestedForallsContextsIn(..) + , UnusedNameProv(..) + , NonCanonicalDefinition(..) + , NonCanonical_Monoid(..) + , NonCanonical_Monad(..) + , TypeSyntax(..) + , typeSyntaxExtension + + -- * Errors for hs-boot and signature files + , BadBootDecls(..) + , MissingBootThing(..), missingBootThing + , BootMismatch(..) + , BootMismatchWhat(..) + , BootTyConMismatch(..) + , BootAxiomBranchMismatch(..) + , BootClassMismatch(..) + , BootMethodMismatch(..) + , BootATMismatch(..) + , BootDataMismatch(..) + , BootDataConMismatch(..) + , SynAbstractDataError(..) + , BootListMismatch(..), BootListMismatches + + -- * Class and family instance errors + , IllegalInstanceReason(..) + , IllegalClassInstanceReason(..) + , IllegalInstanceHeadReason(..) + , IllegalHasFieldInstance(..) + , CoverageProblem(..), FailedCoverageCondition(..) + , IllegalFamilyInstanceReason(..) + , InvalidFamInstQTv(..), InvalidFamInstQTvReason(..) + , InvalidAssoc(..), InvalidAssocInstance(..) + , InvalidAssocDefault(..), AssocDefaultBadArgs(..) + , InstHeadNonClassHead(..) + + -- * Template Haskell errors + , THError(..), THSyntaxError(..), THNameError(..) + , THReifyError(..), TypedTHError(..) + , SpliceFailReason(..), RunSpliceFailReason(..) + , AddTopDeclsError(..) + , ConversionFailReason(..) + , UnrepresentableTypeDescr(..) + , LookupTHInstNameErrReason(..) + , SplicePhase(..) + , THDeclDescriptor(..) + , ThingBeingConverted(..) + , IllegalDecls(..) + + -- * Zonker errors + , ZonkerMessage(..) + + -- * FFI Errors + , IllegalForeignTypeReason(..) + , TypeCannotBeMarshaledReason(..) + + -- * Error contexts + , ErrCtxtMsg(..) + ) where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Tc.Errors.Types.PromotionErr +import GHC.Tc.Errors.Hole.FitTypes (HoleFit) +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence (EvBindsVar) +import GHC.Tc.Types.ErrCtxt +import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol) + , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing + , FixedRuntimeRepOrigin(..), InstanceWhat ) +import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin, SubGoalDepth ) +import GHC.Tc.Types.Rank (Rank) +import GHC.Tc.Types.TH +import GHC.Tc.Utils.TcType (TcType, TcSigmaType, TcPredType, + PatersonCondFailure, PatersonCondFailureContext) + +import GHC.Types.Basic +import GHC.Types.Error +import GHC.Types.Avail +import GHC.Types.Hint (UntickedPromotedThing(..), AssumedDerivingStrategy(..), SigLike) +import GHC.Types.ForeignCall (CLabelString) +import GHC.Types.Id.Info ( RecSelParent(..) ) +import GHC.Types.Name (NamedThing(..), Name, OccName, getSrcLoc, getSrcSpan) +import GHC.Types.Name.Env (NameEnv) +import qualified GHC.Types.Name.Occurrence as OccName +import GHC.Types.Name.Reader +import GHC.Types.SourceFile (HsBootOrSig(..)) +import GHC.Types.SrcLoc +import GHC.Types.TyThing (TyThing) +import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar, CoVar, Specificity) +import GHC.Types.Var.Env (TidyEnv) +import GHC.Types.Var.Set (TyVarSet, VarSet) +import GHC.Types.DefaultEnv (ClassDefaults) + +import GHC.Unit.Types (Module) +import GHC.Unit.State (UnitState) +import GHC.Unit.Module.Warnings (WarningCategory, WarningTxt) +import GHC.Unit.Module.ModIface (ModIface) + +import GHC.Utils.Outputable + +import GHC.Core.Class (Class, ClassMinimalDef, ClassOpItem, ClassATItem) +import GHC.Core.Coercion (Coercion) +import GHC.Core.Coercion.Axiom (CoAxBranch) +import GHC.Core.ConLike (ConLike) +import GHC.Core.DataCon (DataCon, FieldLabel) +import GHC.Core.FamInstEnv (FamInst) +import GHC.Core.InstEnv (LookupInstanceErrReason, ClsInst, DFunId) +import GHC.Core.PatSyn (PatSyn) +import GHC.Core.Predicate (EqRel, predTypeEqRel) +import GHC.Core.TyCon (TyCon, Role, FamTyConFlav, AlgTyConRhs) +import GHC.Core.Type (Kind, Type, ThetaType, PredType, ErrorMsgType, ForAllTyFlag, ForAllTyBinder) + +import GHC.Driver.Backend (Backend) + +import GHC.Iface.Errors.Types + +import GHC.Utils.Misc (filterOut) + +import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.FastString (FastString) +import GHC.Data.Pair +import GHC.Exception.Type (SomeException) + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Typeable (Typeable) +import qualified GHC.Boot.TH.Syntax as TH +import Data.Map.Strict (Map) + +import GHC.Generics ( Generic ) + +import qualified Data.Set as Set + +data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not + , tcOptsIfaceOpts :: !IfaceMessageOpts + } + +{- Note [Migrating TcM Messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As part of #18516, we are slowly migrating the diagnostic messages emitted +and reported in the TcM from SDoc to TcRnMessage. Historically, GHC emitted +some diagnostics in 3 pieces, i.e. there were lots of error-reporting functions +that accepted 3 SDocs an input: one for the important part of the message, +one for the context and one for any supplementary information. Consider the following: + + • Couldn't match expected type ‘Int’ with actual type ‘Char’ + • In the expression: x4 + In a stmt of a 'do' block: return (x2, x4) + In the expression: + +Under the hood, the reporting functions in Tc.Utils.Monad were emitting "Couldn't match" +as the important part, "In the expression" as the context and "In a stmt..In the expression" +as the supplementary, with the context and supplementary usually smashed together so that +the final message would be composed only by two SDoc (which would then be bulleted like in +the example). + +In order for us to smooth out the migration to the new diagnostic infrastructure, we +introduce the 'ErrInfo' and 'TcRnMessageDetailed' types, which serve exactly the purpose +of bridging the two worlds together without breaking the external API or the existing +format of messages reported by GHC. + +Using 'ErrInfo' and 'TcRnMessageDetailed' also allows us to move away from the SDoc-ridden +diagnostic API inside Tc.Utils.Monad, enabling further refactorings. + +In the future, once the conversion will be complete and we will successfully eradicate +any use of SDoc in the diagnostic reporting of GHC, we can surely revisit the usage and +existence of these two types, which for now remain a "necessary evil". +-} + + +-- | The majority of TcRn messages come with extra context about the error, +-- and this newtype captures it. See Note [Migrating TcM Messages]. +data ErrInfo = ErrInfo { + errInfoContext :: ![ErrCtxtMsg] + -- ^ Extra context associated to the error. + , errInfoSupplementary :: !(Maybe (HoleFitDispConfig, [SupplementaryInfo])) + -- ^ Extra supplementary info associated to the error. + , errInfoHints :: ![GhcHint] + -- ^ Extra hints associated to the error. + } + + +-- | 'TcRnMessageDetailed' is an \"internal\" type (used only inside +-- 'GHC.Tc.Utils.Monad' that wraps a 'TcRnMessage' while also providing +-- any extra info needed to correctly pretty-print this diagnostic later on. +data TcRnMessageDetailed + = TcRnMessageDetailed + !ErrInfo + -- ^ extra info associated with the message + !TcRnMessage + -- ^ main error payload + deriving Generic + +mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ DiagnosticHint TcRnMessage) + => a -> TcRnMessage +mkTcRnUnknownMessage diag = TcRnUnknownMessage (mkSimpleUnknownDiagnostic diag) + -- Please don't use this function inside the GHC codebase; + -- it mainly exists for users of the GHC API, such as plugins. + -- + -- If you need to emit a new error message in the typechecker, + -- you should add a new constructor to 'TcRnMessage' instead. + +-- | An error which might arise during typechecking/renaming. +data TcRnMessage where + {-| Simply wraps an unknown 'Diagnostic' message @a@. It can be used by plugins + to provide custom diagnostic messages originated during typechecking/renaming. + -} + TcRnUnknownMessage :: UnknownDiagnosticFor TcRnMessage -> TcRnMessage + + {-| Wrap an 'IfaceMessage' to a 'TcRnMessage' for when we attempt to load interface + files during typechecking but encounter an error. -} + + TcRnInterfaceError :: !IfaceMessage -> TcRnMessage + + {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed + to be provided in order to qualify a diagnostic and where it was originated (and why). + It carries an extra 'UnitState' which can be used to pretty-print some names + and it wraps a 'TcRnMessageDetailed', which includes any extra context associated + with this diagnostic. + -} + TcRnMessageWithInfo :: !UnitState + -- ^ The 'UnitState' will allow us to pretty-print + -- some diagnostics with more detail. + -> !TcRnMessageDetailed + -> TcRnMessage + + {-| TcRnWithHsDocContext annotates an error message with the context in which + it originated. + -} + TcRnWithHsDocContext :: !HsDocContext + -> !TcRnMessage + -> TcRnMessage + + {-| TcRnSolverReport is the constructor used to report unsolved constraints + after constraint solving, as well as other errors such as hole fit errors. + + See the documentation of t'TcSolverReportMsg' datatype for an overview + of the different errors. + -} + TcRnSolverReport :: SolverReportWithCtxt + -> DiagnosticReason + -> TcRnMessage + + {-| TcRnSolverDepthError is an error that occurs when the constraint solver + exceeds the maximum recursion depth. + + Example: + + class C a where { meth :: a } + instance Cls [a] => Cls a where { meth = head . meth } + + t :: () + t = meth + + Test cases: + T7788 + T8550 + T9554 + T15316A + T17267{∅,a,b,c,e} + T17458 + ContextStack1 + T22924b + TcCoercibleFail + -} + TcRnSolverDepthError :: !Type -> !SubGoalDepth -> TcRnMessage + + {-| TcRnRedundantConstraints is a warning that is emitted when a binding + has a user-written type signature which contains superfluous constraints. + + Example: + + f :: (Eq a, Ord a) => a -> a -> a + f x y = (x < y) || x == y + -- `Eq a` is superfluous: the `Ord a` constraint suffices. + + Test cases: T9939, T10632, T18036a, T20602, PluralS, T19296. + -} + TcRnRedundantConstraints :: [Id] + -> (SkolemInfoAnon, Bool) + -- ^ The contextual skolem info. + -- The boolean controls whether we + -- want to show it in the user message. + -- (Nice to keep track of the info in either case, + -- for other users of the GHC API.) + -> TcRnMessage + + {-| TcRnInaccessibleCode is a warning that is emitted when the RHS of a pattern + match is inaccessible, because the constraint solver has detected a contradiction. + + Example: + + data B a where { MkTrue :: B True; MkFalse :: B False } + + foo :: B False -> Bool + foo MkFalse = False + foo MkTrue = True -- Inaccessible: requires True ~ False + + Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167. + -} + TcRnInaccessibleCode :: Implication -- ^ The implication containing a contradiction. + -> SolverReportWithCtxt -- ^ The contradiction. + -> TcRnMessage + {-| TcRnInaccessibleCoAxBranch is a warning that is emitted when a closed type family has a + branch which is inaccessible due to a more general, prior branch. + + Example: + type family F a where + F a = Int + F Bool = Bool + Test cases: T9085, T14066a, T9085, T6018, tc265, + + -} + TcRnInaccessibleCoAxBranch :: TyCon -- ^ The type family's constructor + -> CoAxBranch -- ^ The inaccessible branch + -> TcRnMessage + {-| A type which was expected to have a fixed runtime representation + does not have a fixed runtime representation. + + Example: + + data D (a :: TYPE r) = MkD a + + Test cases: T11724, T18534, + RepPolyPatSynArg, RepPolyPatSynUnliftedNewtype, + RepPolyPatSynRes, T20423 + -} + TcRnTypeDoesNotHaveFixedRuntimeRep :: !Type + -> !FixedRuntimeRepProvenance + -> ![ErrCtxtMsg] -- Extra info accumulated in the TcM monad + -> TcRnMessage + + {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when + a Template Haskell quote implicitly uses 'lift'. + + Example: + warning1 :: Lift t => t -> Q Exp + warning1 x = [| x |] + + Test cases: th/T17804 + -} + TcRnImplicitLift :: Name -> ![ErrCtxtMsg] -> TcRnMessage + + {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds) + that occurs if a pattern binding binds no variables at all, unless it is a + lone wild-card pattern, or a banged pattern. + + Example: + Just _ = rhs3 -- Warning: unused pattern binding + (_, _) = rhs4 -- Warning: unused pattern binding + _ = rhs3 -- No warning: lone wild-card pattern + !() = rhs4 -- No warning: banged pattern; behaves like seq + + Test cases: rename/{T13646,T17c,T17e,T7085} + -} + TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage + + {-| TcRnUnusedQuantifiedTypeVar is a warning that occurs if there are unused + quantified type variables. + + Examples: + f :: forall a. Int -> Char + + Test cases: rename/should_compile/ExplicitForAllRules1 + rename/should_compile/T5331 + -} + TcRnUnusedQuantifiedTypeVar + :: HsDocContext + -> HsTyVarBndrExistentialFlag -- ^ tyVar binder. + -> TcRnMessage + + {-| TcRnDodgyImports is a group of warnings (controlled with -Wdodgy-imports). + + See 'DodgyImportsReason' for the different warnings. + -} + TcRnDodgyImports :: !DodgyImportsReason -> TcRnMessage + {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when + an export of the form 'T(..)' for a type constructor 'T' does not actually export anything + beside 'T' itself. + + Example: + module Foo ( + T(..) -- Warning: T is a type synonym + , A(..) -- Warning: A is a type family + , C(..) -- Warning: C is a data family + ) where + + type T = Int + type family A :: * -> * + data family C :: * -> * + + Test cases: warnings/should_compile/DodgyExports01 + -} + TcRnDodgyExports :: GlobalRdrElt -> TcRnMessage + {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when + an import declaration does not explicitly list all the names brought into scope. + + Test cases: rename/should_compile/T4489 + -} + TcRnMissingImportList :: IE GhcPs -> TcRnMessage + {-| When a module marked trustworthy or unsafe (using -XTrustworthy or -XUnsafe) is compiled + with a plugin, the TcRnUnsafeDueToPlugin warning (controlled by -Wunsafe) is used as the + reason the module was inferred to be unsafe. This warning is not raised if the + -fplugin-trustworthy flag is passed. + + Test cases: plugins/T19926 + -} + TcRnUnsafeDueToPlugin :: TcRnMessage + {-| TcRnModMissingRealSrcSpan is an error that occurs when compiling a module that lacks + an associated 'RealSrcSpan'. + + Test cases: None + -} + TcRnModMissingRealSrcSpan :: Module -> TcRnMessage + {-| TcRnIdNotExportedFromModuleSig is an error pertaining to backpack that occurs + when an identifier required by a signature is not exported by the module + or signature that is being used as a substitution for that signature. + + Example(s): None + + Test cases: backpack/should_fail/bkpfail36 + -} + TcRnIdNotExportedFromModuleSig :: Name -> Module -> TcRnMessage + {-| TcRnIdNotExportedFromLocalSig is an error pertaining to backpack that + occurs when an identifier which is necessary for implementing a module + signature is not exported from that signature. + + Example(s): None + + Test cases: backpack/should_fail/bkpfail30 + backpack/should_fail/bkpfail31 + backpack/should_fail/bkpfail34 + -} + TcRnIdNotExportedFromLocalSig :: Name -> TcRnMessage + + {-| TcRnShadowedName is a warning (controlled by -Wname-shadowing) that occurs whenever + an inner-scope value has the same name as an outer-scope value, i.e. the inner + value shadows the outer one. This can catch typographical errors that turn into + hard-to-find bugs. The warning is suppressed for names beginning with an underscore. + + Examples(s): + f = ... let f = id in ... f ... -- NOT OK, 'f' is shadowed + f x = do { _ignore <- this; _ignore <- that; return (the other) } -- suppressed via underscore + + Test cases: typecheck/should_compile/T10971a + rename/should_compile/rn039 + rename/should_compile/rn064 + rename/should_compile/T1972 + rename/should_fail/T2723 + rename/should_compile/T3262 + driver/werror + rename/should_fail/T22478d + typecheck/should_fail/TyAppPat_ScopedTyVarConflict + -} + TcRnShadowedName :: OccName -> ShadowedNameProvenance -> TcRnMessage + + {-| TcRnInvalidWarningCategory is an error that occurs when a warning is declared + with a category name that is not the special category "deprecations", and + either does not begin with the prefix "x-" indicating a user-defined + category, or contains characters not valid in category names. See Note + [Warning categories] in GHC.Unit.Module.Warnings + + Examples(s): + module M {-# WARNING in "invalid" "Oops" #-} where + + {-# WARNING in "x- spaces not allowed" foo "Oops" #-} + + Test cases: warnings/should_fail/WarningCategoryInvalid + -} + TcRnInvalidWarningCategory :: !WarningCategory -> TcRnMessage + + {-| TcRnDuplicateWarningDecls is an error that occurs whenever + a warning is declared twice. + + Examples(s): + {-# DEPRECATED foo "Don't use me" #-} + {-# DEPRECATED foo "Don't use me" #-} + foo :: Int + foo = 2 + + Test cases: + rename/should_fail/rnfail058 + -} + TcRnDuplicateWarningDecls :: !(LocatedN RdrName) -> !RdrName -> TcRnMessage + + {-| TcRnSimplifierTooManyIterations is an error that occurs whenever + the constraint solver in the simplifier hits the iterations' limit. + + Examples(s): + None. + + Test cases: + None. + -} + TcRnSimplifierTooManyIterations :: Cts + -> !IntWithInf + -- ^ The limit. + -> WantedConstraints + -> TcRnMessage + + {-| TcRnIllegalPatSynDecl is an error that occurs whenever + there is an illegal pattern synonym declaration. + + Examples(s): + + varWithLocalPatSyn x = case x of + P -> () + where + pattern P = () -- not valid, it can't be local, it must be defined at top-level. + + Test cases: patsyn/should_fail/local + -} + TcRnIllegalPatSynDecl :: !(LIdP GhcPs) -> TcRnMessage + + {-| TcRnLinearPatSyn is an error that occurs whenever a pattern + synonym signature uses a field that is not unrestricted. + + Example(s): None + + Test cases: linear/should_fail/LinearPatSyn2 + -} + TcRnLinearPatSyn :: !Type -> TcRnMessage + + {-| TcRnEmptyRecordUpdate is an error that occurs whenever + a record is updated without specifying any field. + + Examples(s): + + $(deriveJSON defaultOptions{} ''Bad) -- not ok, no fields selected for update of defaultOptions + + Test cases: th/T12788 + -} + TcRnEmptyRecordUpdate :: TcRnMessage + + {-| TcRnIllegalFieldPunning is an error that occurs whenever + field punning is used without the 'NamedFieldPuns' extension enabled. + + Examples(s): + + data Foo = Foo { a :: Int } + + foo :: Foo -> Int + foo Foo{a} = a -- Not ok, punning used without extension. + + Test cases: parser/should_fail/RecordDotSyntaxFail12 + -} + TcRnIllegalFieldPunning :: !(Located RdrName) -> TcRnMessage + + {-| TcRnIllegalWildcardsInRecord is an error that occurs whenever + wildcards (..) are used in a record without the relevant + extension being enabled. + + Examples(s): + + data Foo = Foo { a :: Int } + + foo :: Foo -> Int + foo Foo{..} = a -- Not ok, wildcards used without extension. + + Test cases: parser/should_fail/RecordWildCardsFail + -} + TcRnIllegalWildcardsInRecord :: !RecordFieldPart -> TcRnMessage + + {-| TcRnIllegalWildcardInType is an error that occurs + when a wildcard appears in a type in a location in which + wildcards aren't allowed. + + Examples: + + Type synonyms: + + type T = _ + + Class declarations and instances: + + class C _ + instance C _ + + Standalone kind signatures: + + type D :: _ + data D + + Test cases: + ExtraConstraintsWildcardInTypeSplice2 + ExtraConstraintsWildcardInTypeSpliceUsed + ExtraConstraintsWildcardNotLast + ExtraConstraintsWildcardTwice + NestedExtraConstraintsWildcard + NestedNamedExtraConstraintsWildcard + PartialClassMethodSignature + PartialClassMethodSignature2 + T12039 + T13324_fail1 + UnnamedConstraintWildcard1 + UnnamedConstraintWildcard2 + WildcardInADT1 + WildcardInADT2 + WildcardInADT3 + WildcardInADTContext1 + WildcardInDefault + WildcardInDefaultSignature + WildcardInDeriving + WildcardInForeignExport + WildcardInForeignImport + WildcardInGADT1 + WildcardInGADT2 + WildcardInInstanceHead + WildcardInInstanceSig + WildcardInNewtype + WildcardInPatSynSig + WildcardInStandaloneDeriving + WildcardInTypeFamilyInstanceRHS + WildcardInTypeSynonymRHS + saks_fail003 + T15433a + -} + TcRnIllegalWildcardInType + :: Maybe Name + -- ^ the wildcard name, or 'Nothing' for an anonymous wildcard + -> !BadAnonWildcardContext + -> TcRnMessage + + {-| TcRnIllegalNamedWildcardInTypeArgument is an error that occurs + when a named wildcard is used in a required type argument. + + Example: + + vfun :: forall (a :: k) -> () + x = vfun _nwc + -- ^^^^ + -- named wildcards not allowed in type arguments + + Test cases: + T23738_fail_wild + -} + TcRnIllegalNamedWildcardInTypeArgument + :: RdrName + -> TcRnMessage + + {- TcRnIllegalImplicitTyVarInTypeArgument is an error raised + when a type variable is implicitly quantified in a required type argument. + + Example: + vfun :: forall (a :: k) -> () + x = vfun (Nothing :: Maybe a) + -- ^^^ + -- implicit quantification not allowed in type arguments + + -} + TcRnIllegalImplicitTyVarInTypeArgument + :: RdrName + -> TcRnMessage + + {- TcRnIllegalPunnedVarOccInTypeArgument is an error raised + when a punned variable occurs in a required type argument. + + Example: + vfun :: forall (a :: k) -> () + f (Just @a a) = vfun a + -- ^^^ + -- which `a` is referenced? + -} + TcRnIllegalPunnedVarOccInTypeArgument + :: { illegalPunTermName :: !ResolvedNameInfo -- ^ How the variable was actually resolved (term namespace) + , illegalPunTypeName :: !ResolvedNameInfo -- ^ How the variable could have been resolved (type namespace) + } -> TcRnMessage + + {-| TcRnDuplicateFieldName is an error that occurs whenever + there are duplicate field names in a single record. + + Examples(s): + + data R = MkR { x :: Int, x :: Bool } + f r = r { x = 3, x = 4 } + + Test cases: T21959. + -} + TcRnDuplicateFieldName :: !RecordFieldPart -> NE.NonEmpty RdrName -> TcRnMessage + + {-| TcRnIllegalViewPattern is an error that occurs whenever + the ViewPatterns syntax is used but the ViewPatterns language extension + is not enabled. + + Examples(s): + data Foo = Foo { a :: Int } + + foo :: Foo -> Int + foo (a -> l) = l -- not OK, the 'ViewPattern' extension is not enabled. + + Test cases: parser/should_fail/ViewPatternsFail + -} + TcRnIllegalViewPattern :: !(Pat GhcPs) -> TcRnMessage + + {-| TcRnCharLiteralOutOfRange is an error that occurs whenever + a character is out of range. + + Examples(s): None + + Test cases: None + -} + TcRnCharLiteralOutOfRange :: !Char -> TcRnMessage + + {-| TcRnNegativeNumTypeLiteral is an error that occurs whenever + a type-level number literal is negative. + + type Neg = -1 + + Test cases: th/T8412 + typecheck/should_fail/T8306 + -} + TcRnNegativeNumTypeLiteral :: HsTyLit GhcPs -> TcRnMessage + + {-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever + the record wildcards '..' are used inside a constructor without labeled fields. + + Examples(s): None + + Test cases: + rename/should_fail/T9815.hs + rename/should_fail/T9815b.hs + rename/should_fail/T9815ghci.hs + rename/should_fail/T9815bghci.hs + -} + TcRnIllegalWildcardsInConstructor :: !Name -> TcRnMessage + + {-| TcRnIgnoringAnnotations is a warning that occurs when the source code + contains annotation pragmas but the platform in use does not support an + external interpreter such as GHCi and therefore the annotations are ignored. + + Example(s): None + + Test cases: None + -} + TcRnIgnoringAnnotations :: [LAnnDecl GhcRn] -> TcRnMessage + + {-| TcRnAnnotationInSafeHaskell is an error that occurs if annotation pragmas + are used in conjunction with Safe Haskell. + + Example(s): None + + Test cases: annotations/should_fail/T10826 + -} + TcRnAnnotationInSafeHaskell :: TcRnMessage + + {-| TcRnInvalidTypeApplication is an error that occurs when a visible type application + is used with an expression that does not accept "specified" type arguments. + + Example(s): + foo :: forall {a}. a -> a + foo x = x + bar :: () + bar = let x = foo @Int 42 + in () + + Test cases: overloadedrecflds/should_fail/overloadedlabelsfail03 + typecheck/should_fail/ExplicitSpecificity1 + typecheck/should_fail/ExplicitSpecificity10 + typecheck/should_fail/ExplicitSpecificity2 + typecheck/should_fail/T17173 + typecheck/should_fail/VtaFail + -} + TcRnInvalidTypeApplication :: Type -> LHsWcType GhcRn -> TcRnMessage + + {-| TcRnTagToEnumMissingValArg is an error that occurs when the 'tagToEnum#' + function is not applied to a single value argument. + + Example(s): + tagToEnum# 1 2 + + Test cases: None + -} + TcRnTagToEnumMissingValArg :: TcRnMessage + + {-| TcRnTagToEnumUnspecifiedResTy is an error that occurs when the 'tagToEnum#' + function is not given a concrete result type. + + Example(s): + foo :: forall a. a + foo = tagToEnum# 0# + + Test cases: typecheck/should_fail/tcfail164 + -} + TcRnTagToEnumUnspecifiedResTy :: Type -> TcRnMessage + + {-| TcRnTagToEnumResTyNotAnEnum is an error that occurs when the 'tagToEnum#' + function is given a result type that is not an enumeration type. + + Example(s): + foo :: Int -- not an enumeration TyCon + foo = tagToEnum# 0# + + Test cases: typecheck/should_fail/tcfail164 + -} + TcRnTagToEnumResTyNotAnEnum :: Type -> TcRnMessage + + {-| TcRnTagToEnumResTyTypeData is an error that occurs when the 'tagToEnum#' + function is given a result type that is headed by a @type data@ type, as + the data constructors of a @type data@ do not exist at the term level. + + Example(s): + type data Letter = A | B | C + + foo :: Letter + foo = tagToEnum# 0# + + Test cases: type-data/should_fail/TDTagToEnum.hs + -} + TcRnTagToEnumResTyTypeData :: Type -> TcRnMessage + + {-| TcRnArrowIfThenElsePredDependsOnResultTy is an error that occurs when the + predicate type of an ifThenElse expression in arrow notation depends on + the type of the result. + + Example(s): None + + Test cases: None + -} + TcRnArrowIfThenElsePredDependsOnResultTy :: TcRnMessage + + {-| TcRnIllegalHsBootOrSigDecl is an error that occurs when an hs-boot file + contains declarations that are not allowed, such as bindings. + + Examples: + + -- A.hs-boot + f :: Int -> Int + f x = 2 * x -- binding not allowed + + -- B.hs-boot + type family F a where { F Int = Bool } + -- type family equations not allowed + + -- C.hsig + bar :: Int -> Int + {-# RULES forall x. bar x = x #-} -- RULES not allowed + + + Test cases: + + - bindings: T19781 + - class instance body: none + - type family instance: HsBootFam + - splice: none + - foreign declaration: none + - default declaration: none + - RULEs: none + -} + TcRnIllegalHsBootOrSigDecl :: !HsBootOrSig -> !BadBootDecls -> TcRnMessage + + {-| TcRnBootMismatch is a family of errors that occur when there is a + mismatch between the hs-boot and hs files. + + Examples: + + -- A.hs-boot + foo :: Int -> Bool + data D = MkD + + -- A.hs + foo :: Int -> Char + foo = chr + + data D = MkD Int + + Test cases: + + - missing export: bkpcabal06, bkpfail{01,05,09,16,35}, rnfail{047,055} + - missing definition: none + - missing instance: T14075 + - mismatch in exports: bkpfail{03,19} + - conflicting definitions: bkpcabal02, + bkpfail{04,06,07,10,12,133,14,15,17,22,23,25,26,27,41,42,45,47,50,52,53,54}, + T19244{a,b}, T23344, ClosedFam3, rnfail055 + -} + TcRnBootMismatch :: !HsBootOrSig -> !BootMismatch -> TcRnMessage + + {-| TcRnRecursivePatternSynonym is an error that occurs when a pattern synonym + is defined in terms of itself, either directly or indirectly. + + Example(s): + pattern A = B + pattern B = A + + Test cases: patsyn/should_fail/T16900 + -} + TcRnRecursivePatternSynonym :: LHsBinds GhcRn -> TcRnMessage + + {-| TcRnPartialTypeSigTyVarMismatch is an error that occurs when a partial type signature + attempts to unify two different types. + + Example(s): + f :: a -> b -> _ + f x y = [x, y] + + Test cases: partial-sigs/should_fail/T14449 + -} + TcRnPartialTypeSigTyVarMismatch + :: Name -- ^ first type variable + -> Name -- ^ second type variable + -> Name -- ^ function name + -> LHsSigWcType GhcRn -> TcRnMessage + + {-| TcRnPartialTypeSigBadQuantifier is an error that occurs when a type variable + being quantified over in the partial type signature of a function gets unified + with a type that is free in that function's context. + + Example(s): + foo :: Num a => a -> a + foo xxx = g xxx + where + g :: forall b. Num b => _ -> b + g y = xxx + y + + Test cases: partial-sig/should_fail/T14479 + -} + TcRnPartialTypeSigBadQuantifier + :: Name -- ^ user-written name of type variable being quantified + -> Name -- ^ function name + -> Maybe Type -- ^ type the variable unified with, if known + -> LHsSigWcType GhcRn -- ^ partial type signature + -> TcRnMessage + + {-| TcRnMissingSignature is a warning that occurs when a top-level binding + or a pattern synonym does not have a type signature. + + Controlled by the flags: + -Wmissing-signatures + -Wmissing-exported-signatures + -Wmissing-pattern-synonym-signatures + -Wmissing-exported-pattern-synonym-signatures + -Wmissing-kind-signatures + -Wmissing-poly-kind-signatures + + Test cases: + T11077 (top-level bindings) + T12484 (pattern synonyms) + T19564 (kind signatures) + -} + TcRnMissingSignature :: MissingSignature + -> Exported + -> TcRnMessage + + {-| TcRnPolymorphicBinderMissingSig is a warning controlled by -Wmissing-local-signatures + that occurs when a local polymorphic binding lacks a type signature. + + Example(s): + id a = a + + Test cases: warnings/should_compile/T12574 + -} + TcRnPolymorphicBinderMissingSig :: Name -> Type -> TcRnMessage + + {-| TcRnOverloadedSig is an error that occurs when a binding group conflicts + with the monomorphism restriction. + + Example(s): + data T a = T a + mono = ... where + x :: Applicative f => f a + T x = ... + + Test cases: typecheck/should_compile/T11339 + -} + TcRnOverloadedSig :: TcIdSig -> TcRnMessage + + {-| TcRnTupleConstraintInst is an error that occurs whenever an instance + for a tuple constraint is specified. + + Examples(s): + class C m a + class D m a + f :: (forall a. Eq a => (C m a, D m a)) => m a + f = undefined + + Test cases: quantified-constraints/T15334 + -} + TcRnTupleConstraintInst :: !Class -> TcRnMessage + + {-| TcRnUserTypeError is an error that occurs due to a user's custom type error, + which can be triggered by adding a `TypeError` constraint in a type signature + or typeclass instance. + + Examples(s): + f :: TypeError (Text "This is a type error") + f = undefined + + Test cases: typecheck/should_fail/CustomTypeErrors02 + typecheck/should_fail/CustomTypeErrors03 + -} + TcRnUserTypeError :: !Type -> TcRnMessage + + {-| TcRnConstraintInKind is an error that occurs whenever a constraint is specified + in a kind. + + Examples(s): + data Q :: Eq a => Type where {} + + Test cases: dependent/should_fail/T13895 + polykinds/T16263 + saks/should_fail/saks_fail004 + typecheck/should_fail/T16059a + typecheck/should_fail/T18714 + -} + TcRnConstraintInKind :: !Type -> TcRnMessage + + {-| TcRnUnboxedTupleTypeFuncArg is an error that occurs whenever an unboxed tuple + or unboxed sum type is specified as a function argument, when the appropriate + extension (`-XUnboxedTuples` or `-XUnboxedSums`) isn't enabled. + + Examples(s): + -- T15073.hs + import T15073a + newtype Foo a = MkFoo a + deriving P + + -- T15073a.hs + class P a where + p :: a -> (# a #) + + Test cases: deriving/should_fail/T15073.hs + deriving/should_fail/T15073a.hs + typecheck/should_fail/T16059d + -} + TcRnUnboxedTupleOrSumTypeFuncArg + :: UnboxedTupleOrSum -- ^ whether this is an unboxed tuple or an unboxed sum + -> !Type + -> TcRnMessage + + {-| TcRnLinearFuncInKind is an error that occurs whenever a linear function is + specified in a kind. + + Examples(s): + data A :: * %1 -> * + + Test cases: linear/should_fail/LinearKind + linear/should_fail/LinearKind2 + linear/should_fail/LinearKind3 + -} + TcRnLinearFuncInKind :: !Type -> TcRnMessage + + {-| TcRnForAllEscapeError is an error that occurs whenever a quantified type's kind + mentions quantified type variable. + + Examples(s): + type T :: TYPE (BoxedRep l) + data T = MkT + + Test cases: unlifted-datatypes/should_fail/UnlDataNullaryPoly + -} + TcRnForAllEscapeError :: !Type -> !Kind -> TcRnMessage + + {-| TcRnVDQInTermType is an error that occurs whenever a visible dependent quantification + is specified in the type of a term. + + Examples(s): + a = (undefined :: forall k -> k -> Type) @Int + + Test cases: dependent/should_fail/T15859 + dependent/should_fail/T16326_Fail1 + dependent/should_fail/T16326_Fail2 + dependent/should_fail/T16326_Fail3 + dependent/should_fail/T16326_Fail4 + dependent/should_fail/T16326_Fail5 + dependent/should_fail/T16326_Fail6 + dependent/should_fail/T16326_Fail7 + dependent/should_fail/T16326_Fail8 + dependent/should_fail/T16326_Fail9 + dependent/should_fail/T16326_Fail10 + dependent/should_fail/T16326_Fail11 + dependent/should_fail/T16326_Fail12 + dependent/should_fail/T17687 + dependent/should_fail/T18271 + -} + TcRnVDQInTermType :: !(Maybe Type) -> TcRnMessage + + {-| TcRnBadQuantPredHead is an error that occurs whenever a quantified predicate + lacks a class or type variable head. + + Examples(s): + class (forall a. A t a => A t [a]) => B t where + type A t a :: Constraint + + Test cases: quantified-constraints/T16474 + -} + TcRnBadQuantPredHead :: !Type -> TcRnMessage + + {-| TcRnIllegalTupleConstraint is an error that occurs whenever an illegal tuple + constraint is specified. + + Examples(s): + g :: ((Show a, Num a), Eq a) => a -> a + g = undefined + + Test cases: typecheck/should_fail/tcfail209a + -} + TcRnIllegalTupleConstraint :: !Type -> TcRnMessage + + {-| TcRnNonTypeVarArgInConstraint is an error that occurs whenever a non type-variable + argument is specified in a constraint. + + Examples(s): + data T + instance Eq Int => Eq T + + Test cases: ghci/scripts/T13202 + ghci/scripts/T13202a + polykinds/T12055a + typecheck/should_fail/T10351 + typecheck/should_fail/T19187 + typecheck/should_fail/T6022 + typecheck/should_fail/T8883 + -} + TcRnNonTypeVarArgInConstraint :: !Type -> TcRnMessage + + {-| TcRnIllegalImplicitParam is an error that occurs whenever an illegal implicit + parameter is specified. + + Examples(s): + type Bla = ?x::Int + data T = T + instance Bla => Eq T + + Test cases: polykinds/T11466 + typecheck/should_fail/T8912 + typecheck/should_fail/tcfail041 + typecheck/should_fail/tcfail211 + typecheck/should_fail/tcrun045 + -} + TcRnIllegalImplicitParam :: !Type -> TcRnMessage + + {-| TcRnIllegalConstraintSynonymOfKind is an error that occurs whenever an illegal constraint + synonym of kind is specified. + + Examples(s): + type Showish = Show + f :: (Showish a) => a -> a + f = undefined + + Test cases: typecheck/should_fail/tcfail209 + -} + TcRnIllegalConstraintSynonymOfKind :: !Type -> TcRnMessage + + {-| TcRnOversaturatedVisibleKindArg is an error that occurs whenever an illegal oversaturated + visible kind argument is specified. + + Examples(s): + type family + F2 :: forall (a :: Type). Type where + F2 @a = Maybe a + + Test cases: typecheck/should_fail/T15793 + typecheck/should_fail/T16255 + -} + TcRnOversaturatedVisibleKindArg :: !Type -> TcRnMessage + + {-| TcRnForAllRankErr is an error that occurs whenever an illegal ranked type + is specified. + + Examples(s): + foo :: (a,b) -> (a~b => t) -> (a,b) + foo p x = p + + Test cases: + - ghci/should_run/T15806 + - indexed-types/should_fail/SimpleFail15 + - typecheck/should_fail/T11355 + - typecheck/should_fail/T12083a + - typecheck/should_fail/T12083b + - typecheck/should_fail/T16059c + - typecheck/should_fail/T16059e + - typecheck/should_fail/T17213 + - typecheck/should_fail/T18939_Fail + - typecheck/should_fail/T2538 + - typecheck/should_fail/T5957 + - typecheck/should_fail/T7019 + - typecheck/should_fail/T7019a + - typecheck/should_fail/T7809 + - typecheck/should_fail/T9196 + - typecheck/should_fail/tcfail127 + - typecheck/should_fail/tcfail184 + - typecheck/should_fail/tcfail196 + - typecheck/should_fail/tcfail197 + -} + TcRnForAllRankErr :: !Rank -> !Type -> TcRnMessage + + {-| TcRnSimplifiableConstraint is a warning triggered by the occurrence of + a simplifiable constraint in a context, when MonoLocalBinds is not enabled. + + Examples(s): + simplifiableEq :: Eq (a, a) => a -> a -> Bool + simplifiableEq = undefined + + Test cases: + - indexed-types/should_compile/T15322 + - partial-sigs/should_compile/SomethingShowable + - typecheck/should_compile/T13526 + -} + TcRnSimplifiableConstraint :: !PredType -> !InstanceWhat -> TcRnMessage + + {-| TcRnArityMismatch is an error that occurs when a type constructor is supplied with + fewer arguments than required. + + Examples(s): + f Left = undefined + + Test cases: + - backpack/should_fail/bkpfail25.bkp + - ghci/should_fail/T16013 + - ghci/should_fail/T16287 + - indexed-types/should_fail/BadSock + - indexed-types/should_fail/T9433 + - module/mod60 + - ndexed-types/should_fail/T2157 + - parser/should_fail/ParserNoBinaryLiterals2 + - parser/should_fail/ParserNoBinaryLiterals3 + - patsyn/should_fail/T12819 + - polykinds/T10516 + - typecheck/should_fail/T12124 + - typecheck/should_fail/T15954 + - typecheck/should_fail/T16874 + - typecheck/should_fail/tcfail100 + - typecheck/should_fail/tcfail101 + - typecheck/should_fail/tcfail107 + - typecheck/should_fail/tcfail129 + - typecheck/should_fail/tcfail187 + -} + TcRnArityMismatch :: !TyThing + -> !Arity -- ^ expected arity + -> !Arity -- ^ actual arity + -> TcRnMessage + + {-| TcRnIllegalClassInstance is a collection of diagnostics that arise + from an invalid class or family instance declaration. + + See t'IllegalInstanceReason'. + -} + TcRnIllegalInstance :: IllegalInstanceReason -> TcRnMessage + + {-| TcRnMonomorphicBindings is a warning (controlled by -Wmonomorphism-restriction) + that arises when the monomorphism restriction applies to the given bindings. + + Examples(s): + {-# OPTIONS_GHC -Wmonomorphism-restriction #-} + + bar = 10 + + foo :: Int + foo = bar + + main :: IO () + main = print foo + + The example above emits the warning (for 'bar'), because without monomorphism + restriction the inferred type for 'bar' is 'bar :: Num p => p'. This warning tells us + that /if/ we were to enable '-XMonomorphismRestriction' we would make 'bar' + less polymorphic, as its type would become 'bar :: Int', so GHC warns us about that. + + Test cases: typecheck/should_compile/T13785 + -} + TcRnMonomorphicBindings :: [Name] -> TcRnMessage + + {-| TcRnOrphanInstance is a warning (controlled by -Worphans) that arises when + a typeclass instance or family instance is an \"orphan\", i.e. if it + appears in a module in which neither the class/family nor the type being + instanced are declared in the same module. + + Examples(s): None + + Test cases: warnings/should_compile/T9178 + typecheck/should_compile/T4912 + -} + TcRnOrphanInstance :: Either ClsInst FamInst -> TcRnMessage + + {-| TcRnFunDepConflict is an error that occurs when there are functional dependencies + conflicts between instance declarations. + + Examples(s): None + + Test cases: typecheck/should_fail/T2307 + typecheck/should_fail/tcfail096 + typecheck/should_fail/tcfail202 + -} + TcRnFunDepConflict :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage + + {-| TcRnDupInstanceDecls is an error that occurs when there are duplicate instance + declarations. + + Examples(s): + class Foo a where + foo :: a -> Int + + instance Foo Int where + foo = id + + instance Foo Int where + foo = const 42 + + Test cases: cabal/T12733/T12733 + typecheck/should_fail/tcfail035 + typecheck/should_fail/tcfail023 + backpack/should_fail/bkpfail18 + typecheck/should_fail/TcNullaryTCFail + typecheck/should_fail/tcfail036 + typecheck/should_fail/tcfail073 + module/mod51 + module/mod52 + module/mod44 + -} + TcRnDupInstanceDecls :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage + + {-| TcRnConflictingFamInstDecls is an error that occurs when there are conflicting + family instance declarations. + + Examples(s): None. + + Test cases: indexed-types/should_fail/ExplicitForAllFams4b + indexed-types/should_fail/NoGood + indexed-types/should_fail/Over + indexed-types/should_fail/OverDirectThisMod + indexed-types/should_fail/OverIndirectThisMod + indexed-types/should_fail/SimpleFail11a + indexed-types/should_fail/SimpleFail11b + indexed-types/should_fail/SimpleFail11c + indexed-types/should_fail/SimpleFail11d + indexed-types/should_fail/SimpleFail2a + indexed-types/should_fail/SimpleFail2b + indexed-types/should_fail/T13092/T13092 + indexed-types/should_fail/T13092c/T13092c + indexed-types/should_fail/T14179 + indexed-types/should_fail/T2334A + indexed-types/should_fail/T2677 + indexed-types/should_fail/T3330b + indexed-types/should_fail/T4246 + indexed-types/should_fail/T7102a + indexed-types/should_fail/T9371 + polykinds/T7524 + typecheck/should_fail/UnliftedNewtypesOverlap + -} + TcRnConflictingFamInstDecls :: NE.NonEmpty FamInst -> TcRnMessage + + {-| TcRnFamInstNotInjective is a collection of errors that arise from + a type family equation violating the injectivity annotation. + + See 'InjectivityErrReason'. + -} + TcRnFamInstNotInjective :: InjectivityErrReason -- ^ the violation + -> TyCon -- ^ the family 'TyCon' + -> NE.NonEmpty CoAxBranch -- ^ the family equations + -> TcRnMessage + + {-| TcRnBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that + occurs when a strictness annotation is applied to an unlifted type. + + Example(s): + data T = MkT !Int# -- Strictness flag has no effect on unlifted types + + Test cases: typecheck/should_compile/T20187a + typecheck/should_compile/T20187b + -} + TcRnBangOnUnliftedType :: !Type -> TcRnMessage + + {-| TcRnLazyBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that + occurs when a lazy annotation is applied to an unlifted type. + + Example(s): + data T = MkT ~Int# -- Lazy flag has no effect on unlifted types + + Test cases: typecheck/should_compile/T21951a + typecheck/should_compile/T21951b + -} + TcRnLazyBangOnUnliftedType :: !Type -> TcRnMessage + + {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has + more than one default declaration for the same class. + + Example: + default (Integer, Int) -- implicitly applies to Num + default (Double, Float) -- 2nd default declaration not allowed + + Text cases: module/mod58 + -} + TcRnMultipleDefaultDeclarations :: Class -> ClassDefaults -> TcRnMessage + + {-| TcRnWarnClashingDefaultImports is a warning that occurs when a module imports + more than one default declaration for the same class, and they are not all + subsumed by one of them nor by a local `default` declaration. + + See Note [Named default declarations] in GHC.Tc.Gen.Default + + Test cases: default/Import07.hs + -} + TcRnWarnClashingDefaultImports :: Class + -> Maybe [Type] -- ^ locally declared defaults + -> NE.NonEmpty ClassDefaults -- ^ imported defaults + -> TcRnMessage + + {-| TcRnBadDefaultType is an error that occurs when a type used in a default + declaration does not have an instance for any of the applicable classes. + + Example(s): + data Foo + default (Foo) + + Test cases: typecheck/should_fail/T11974b + -} + TcRnBadDefaultType :: LHsType GhcRn -> NonEmpty Class -> TcRnMessage + + {-| TcRnPatSynBundledWithNonDataCon is an error that occurs when a module's + export list bundles a pattern synonym with a type that is not a proper + `data` or `newtype` construction. + + Example(s): + module Foo (MyClass(.., P)) where + pattern P = Nothing + class MyClass a where + foo :: a -> Int + + Test cases: patsyn/should_fail/export-class + -} + TcRnPatSynBundledWithNonDataCon :: TcRnMessage + + {-| TcRnPatSynBundledWithWrongType is an error that occurs when the export list + of a module has a pattern synonym bundled with a type that does not match + the type of the pattern synonym. + + Example(s): + module Foo (R(P,x)) where + data Q = Q Int + data R = R + pattern P{x} = Q x + + Text cases: patsyn/should_fail/export-ps-rec-sel + patsyn/should_fail/export-type-synonym + patsyn/should_fail/export-type + -} + TcRnPatSynBundledWithWrongType :: Type -> Type -> TcRnMessage + + {-| TcRnDupeModuleExport is a warning controlled by @-Wduplicate-exports@ that + occurs when a module appears more than once in an export list. + + Example(s): + module Foo (module Bar, module Bar) + import Bar + + Text cases: None + -} + TcRnDupeModuleExport :: ModuleName -> TcRnMessage + + {-| TcRnExportedModNotImported is an error that occurs when an export list + contains a module that is not imported. + + Example(s): None + + Text cases: module/mod135 + module/mod8 + rename/should_fail/rnfail028 + backpack/should_fail/bkpfail48 + -} + TcRnExportedModNotImported :: ModuleName -> TcRnMessage + + {-| TcRnNullExportedModule is a warning controlled by -Wdodgy-exports that occurs + when an export list contains a module that has no exports. + + Example(s): + module Foo (module Bar) where + import Bar () + + Test cases: None + -} + TcRnNullExportedModule :: ModuleName -> TcRnMessage + + {-| TcRnMissingExportList is a warning controlled by -Wmissing-export-lists that + occurs when a module does not have an explicit export list. + + Example(s): None + + Test cases: typecheck/should_fail/MissingExportList03 + -} + TcRnMissingExportList :: ModuleName -> TcRnMessage + + {-| TcRnExportHiddenComponents is an error that occurs when an export contains + constructor or class methods that are not visible. + + Example(s): None + + Test cases: None + -} + TcRnExportHiddenComponents :: IE GhcPs -> TcRnMessage + + {-| TcRnExportHiddenDefault is an error that occurs when an export contains + a class default (with language extension NamedDefaults) that is not visible. + + Example(s): None + + Test cases: default/fail06.hs + -} + TcRnExportHiddenDefault :: IE GhcPs -> TcRnMessage + + {-| TcRnDuplicateExport is a warning (controlled by -Wduplicate-exports) that occurs + when an identifier appears in an export list more than once. + + Example(s): None + + Test cases: module/MultiExport + module/mod128 + module/mod14 + module/mod5 + overloadedrecflds/should_fail/DuplicateExports + patsyn/should_compile/T11959 + -} + TcRnDuplicateExport :: GlobalRdrElt -> IE GhcPs -> IE GhcPs -> TcRnMessage + + {-| TcRnDuplicateNamedDefaultExport is a warning (controlled by -Wduplicate-exports) + that occurs when a named default declaration appears in an export list + more than once. + + -} + TcRnDuplicateNamedDefaultExport :: TyCon -> IE GhcPs -> IE GhcPs -> TcRnMessage + + {-| TcRnExportedParentChildMismatch is an error that occurs when an export is + bundled with a parent that it does not belong to + + Example(s): + module Foo (T(a)) where + data T + a = True + + Test cases: module/T11970 + module/T11970B + module/mod17 + module/mod3 + overloadedrecflds/should_fail/NoParent + -} + TcRnExportedParentChildMismatch :: Name -- ^ parent + -> TyThing + -> Name -- ^ child + -> [Name] -> TcRnMessage + + {-| TcRnConflictingExports is an error that occurs when different identifiers that + have the same name are being exported by a module. + + Example(s): + module Foo (Bar.f, module Baz) where + import qualified Bar (f) + import Baz (f) + + Test cases: module/mod131 + module/mod142 + module/mod143 + module/mod144 + module/mod145 + module/mod146 + module/mod150 + module/mod155 + overloadedrecflds/should_fail/T14953 + overloadedrecflds/should_fail/overloadedrecfldsfail10 + rename/should_fail/rnfail029 + rename/should_fail/rnfail040 + typecheck/should_fail/T16453E2 + typecheck/should_fail/tcfail025 + typecheck/should_fail/tcfail026 + -} + TcRnConflictingExports + :: OccName -- ^ Occurrence name shared by both exports + -> GlobalRdrElt -- ^ First export + -> IE GhcPs -- ^ Export decl of first export + -> GlobalRdrElt -- ^ Second export + -> IE GhcPs -- ^ Export decl of second export + -> TcRnMessage + + {-| TcRnDuplicateFieldExport is an error that occurs when a module exports + multiple record fields with the same name, without enabling + DuplicateRecordFields. + + Example: + + module M1 where + data D1 = MkD1 { foo :: Int } + module M2 where + data D2 = MkD2 { foo :: Int } + module M ( D1(..), D2(..) ) where + import module M1 + import module M2 + + Test case: overloadedrecflds/should_fail/overloadedrecfldsfail10 + -} + TcRnDuplicateFieldExport + :: (GlobalRdrElt, IE GhcPs) + -> NE.NonEmpty (GlobalRdrElt, IE GhcPs) + -> TcRnMessage + + {-| TcRnAmbiguousRecordUpdate is a warning, controlled by -Wambiguous-fields, + which occurs when a user relies on the type-directed disambiguation + mechanism to disambiguate a record update. This will not be supported by + -XDuplicateRecordFields in future releases. + + Example(s): + + data Person = MkPerson { personId :: Int, name :: String } + data Address = MkAddress { personId :: Int, address :: String } + bad1 x = x { personId = 4 } :: Person -- ambiguous + bad2 (x :: Person) = x { personId = 4 } -- ambiguous + good x = (x :: Person) { personId = 4 } -- not ambiguous + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail06 + -} + TcRnAmbiguousRecordUpdate + :: HsExpr GhcRn -- ^ Field update + -> TyCon -- ^ Record type + -> TcRnMessage + + {-| TcRnMissingFields is a warning controlled by -Wmissing-fields occurring + when the intialisation of a record is missing one or more (lazy) fields. + + Example(s): + data Rec = Rec { a :: Int, b :: String, c :: Bool } + x = Rec { a = 1, b = "two" } -- missing field 'c' + + Test cases: deSugar/should_compile/T13870 + deSugar/should_compile/ds041 + patsyn/should_compile/T11283 + rename/should_compile/T5334 + rename/should_compile/T12229 + rename/should_compile/T5892a + warnings/should_fail/WerrorFail2 + -} + TcRnMissingFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage + + {-| TcRnFieldUpdateInvalidType is an error occurring when an updated field's + type mentions something that is outside the universally quantified variables + of the data constructor, such as an existentially quantified type. + + Example(s): + data X = forall a. MkX { f :: a } + x = (MkX ()) { f = False } + + Test cases: patsyn/should_fail/records-exquant + typecheck/should_fail/T3323 + -} + TcRnFieldUpdateInvalidType :: [(FieldLabelString,TcType)] -> TcRnMessage + + {-| TcRnMissingStrictFields is an error occurring when a record field marked + as strict is omitted when constructing said record. + + Example(s): + data R = R { strictField :: !Bool, nonStrict :: Int } + x = R { nonStrict = 1 } + + Test cases: typecheck/should_fail/T18869 + typecheck/should_fail/tcfail085 + typecheck/should_fail/tcfail112 + -} + TcRnMissingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage + + {-| TcRnAmbiguousFieldInUpdate is an error that occurs when a field in a + record update clashes with another field or top-level function of the + same name, and the user hasn't enabled -XDisambiguateRecordFields. + + Example: + + {-# LANGUAGE NoFieldSelectors #-} + {-# LANGUAGE NoDisambiguateRecordFields #-} + module M where + + data A = MkA { fld :: Int } + + fld :: Bool + fld = False + + f r = r { fld = 3 } + + -} + TcRnAmbiguousFieldInUpdate :: (GlobalRdrElt, GlobalRdrElt, [GlobalRdrElt]) + -> TcRnMessage + + {-| TcRnBadRecordUpdate is an error when a regular (non-overloaded) + record update cannot be pinned down to any one parent. + + The problem with the record update is stored in the 'BadRecordUpdateReason' + field. + + Example(s): + + data R1 = R1 { x :: Int } + data R2 = R2 { x :: Int } + update r = r { x = 1 } + -- ambiguous + + data R1 = R1 { x :: Int, y :: Int } + data R2 = R2 { y :: Int, z :: Int } + update r = r { x = 1, y = 2, z = 3 } + -- no parent has all the fields + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 + overloadedrecflds/should_fail/overloadedrecfldsfail01 + overloadedrecflds/should_fail/overloadedrecfldsfail14 + -} + TcRnBadRecordUpdate :: [RdrName] + -- ^ the fields of the record update + -> BadRecordUpdateReason + -- ^ the reason this record update was rejected + -> TcRnMessage + + {-| TcRnStaticFormNotClosed is an error pertaining to terms that are marked static + using the -XStaticPointers extension but which are not closed terms. + + Example(s): + f x = static x + + Test cases: rename/should_fail/RnStaticPointersFail01 + rename/should_fail/RnStaticPointersFail03 + -} + TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage + + {-| TcRnUselessTypeable is a warning (controlled by -Wderiving-typeable) that + occurs when trying to derive an instance of the 'Typeable' class. Deriving + 'Typeable' is no longer necessary (hence the \"useless\") as all types + automatically derive 'Typeable' in modern GHC versions. + + Example(s): None. + + Test cases: warnings/should_compile/DerivingTypeable + -} + TcRnUselessTypeable :: TcRnMessage + + {-| TcRnDerivingDefaults is a warning (controlled by -Wderiving-defaults) that + occurs when both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are + enabled, and therefore GHC defaults to 'DeriveAnyClass', which might not + be what the user wants. + + Example(s): None. + + Test cases: typecheck/should_compile/T15839a + deriving/should_compile/T16179 + -} + TcRnDerivingDefaults :: !Class -> TcRnMessage + + {-| TcRnNonUnaryTypeclassConstraint is an error that occurs when GHC + encounters a non-unary constraint when trying to derive a typeclass. + + Example(s): + class A + deriving instance A + data B deriving A -- We cannot derive A, is not unary (i.e. 'class A a'). + + Test cases: deriving/should_fail/T7959 + deriving/should_fail/drvfail005 + deriving/should_fail/drvfail009 + deriving/should_fail/drvfail006 + -} + TcRnNonUnaryTypeclassConstraint :: !UserTypeCtxt -> !TypedThing -> TcRnMessage + + {-| TcRnPartialTypeSignatures is a warning (controlled by -Wpartial-type-signatures) + that occurs when a wildcard '_' is found in place of a type in a signature or a + type class derivation + + Example(s): + foo :: _ -> Int + foo = ... + + deriving instance _ => Eq (Foo a) + + Test cases: dependent/should_compile/T11241 + dependent/should_compile/T15076 + dependent/should_compile/T14880-2 + typecheck/should_compile/T17024 + typecheck/should_compile/T10072 + partial-sigs/should_fail/TidyClash2 + partial-sigs/should_fail/Defaulting1MROff + partial-sigs/should_fail/WildcardsInPatternAndExprSig + partial-sigs/should_fail/T10615 + partial-sigs/should_fail/T14584a + partial-sigs/should_fail/TidyClash + partial-sigs/should_fail/T11122 + partial-sigs/should_fail/T14584 + partial-sigs/should_fail/T10045 + partial-sigs/should_fail/PartialTypeSignaturesDisabled + partial-sigs/should_fail/T10999 + partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature + partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice + partial-sigs/should_fail/WildcardInstantiations + partial-sigs/should_run/T15415 + partial-sigs/should_compile/T10463 + partial-sigs/should_compile/T15039a + partial-sigs/should_compile/T16728b + partial-sigs/should_compile/T15039c + partial-sigs/should_compile/T10438 + partial-sigs/should_compile/SplicesUsed + partial-sigs/should_compile/T18008 + partial-sigs/should_compile/ExprSigLocal + partial-sigs/should_compile/T11339a + partial-sigs/should_compile/T11670 + partial-sigs/should_compile/WarningWildcardInstantiations + partial-sigs/should_compile/T16728 + partial-sigs/should_compile/T12033 + partial-sigs/should_compile/T15039b + partial-sigs/should_compile/T10403 + partial-sigs/should_compile/T11192 + partial-sigs/should_compile/T16728a + partial-sigs/should_compile/TypedSplice + partial-sigs/should_compile/T15039d + partial-sigs/should_compile/T11016 + partial-sigs/should_compile/T13324_compile2 + linear/should_fail/LinearPartialSig + polykinds/T14265 + polykinds/T14172 + -} + TcRnPartialTypeSignatures :: !SuggestPartialTypeSignatures -> !ThetaType -> TcRnMessage + + {-| TcRnCannotDeriveInstance is an error that occurs every time a typeclass instance + can't be derived. The 'DeriveInstanceErrReason' will contain the specific reason + this error arose. + + Example(s): None. + + Test cases: generics/T10604/T10604_no_PolyKinds + deriving/should_fail/drvfail009 + deriving/should_fail/drvfail-functor2 + deriving/should_fail/T10598_fail3 + deriving/should_fail/deriving-via-fail2 + deriving/should_fail/deriving-via-fail + deriving/should_fail/T16181 + -} + TcRnCannotDeriveInstance :: !Class + -- ^ The typeclass we are trying to derive + -- an instance for + -> [Type] + -- ^ The typeclass arguments, if any. + -> !(Maybe (DerivStrategy GhcTc)) + -- ^ The derivation strategy, if any. + -> !UsingGeneralizedNewtypeDeriving + -- ^ Is '-XGeneralizedNewtypeDeriving' enabled? + -> !DeriveInstanceErrReason + -- ^ The specific reason why we couldn't derive + -- an instance for the class. + -> TcRnMessage + + {-| TcRnLazyGADTPattern is an error that occurs when a user writes a nested + GADT pattern match inside a lazy (~) pattern. + + Test case: gadt/lazypat + -} + TcRnLazyGADTPattern :: TcRnMessage + + {-| TcRnArrowProcGADTPattern is an error that occurs when a user writes a + GADT pattern inside arrow proc notation. + + Test case: arrows/should_fail/arrowfail004. + -} + TcRnArrowProcGADTPattern :: TcRnMessage + + {-| TcRnCapturedTermName is a warning (controlled by -Wterm-variable-capture) that occurs + when an implicitly quantified type variable's name is already used for a term. + Example: + a = 10 + f :: a -> a + + Test cases: T22513a T22513b T22513c T22513d T22513e T22513f T22513g T22513h T22513i + -} + TcRnCapturedTermName :: RdrName -> Either [GlobalRdrElt] Name -> TcRnMessage + + {-| TcRnTypeEqualityOutOfScope is a warning (controlled by -Wtype-equality-out-of-scope) + that occurs when the type equality (a ~ b) is not in scope. + + Test case: warnings/should_compile/T18862b + -} + TcRnTypeEqualityOutOfScope :: TcRnMessage + + {-| TcRnTypeEqualityRequiresOperators is a warning (controlled by -Wtype-equality-requires-operators) + that occurs when the type equality (a ~ b) is used without the TypeOperators extension. + + Example: + {-# LANGUAGE NoTypeOperators #-} + f :: (a ~ b) => a -> b + + Test case: T18862a + -} + TcRnTypeEqualityRequiresOperators :: TcRnMessage + + {-| TcRnIllegalTypeOperator is an error that occurs when a type operator + is used without the TypeOperators extension. + + Example: + {-# LANGUAGE NoTypeOperators #-} + f :: Vec a n -> Vec a m -> Vec a (n + m) + + Test case: T12811 + -} + TcRnIllegalTypeOperator :: !SDoc -> !RdrName -> TcRnMessage + + {-| TcRnIllegalTypeOperatorDecl is an error that occurs when a type or class + operator is declared without the TypeOperators extension. + + See Note [Type and class operator definitions] + + Example: + {-# LANGUAGE Haskell2010 #-} + {-# LANGUAGE MultiParamTypeClasses #-} + + module T3265 where + + data a :+: b = Left a | Right b + + class a :*: b where {} + + + Test cases: T3265, tcfail173 + -} + TcRnIllegalTypeOperatorDecl :: !RdrName -> TcRnMessage + + {-| TcRnGADTMonoLocalBinds is a warning controlled by -Wgadt-mono-local-binds + that occurs when pattern matching on a GADT when -XMonoLocalBinds is off. + + Example(s): None + + Test cases: T20485, T20485a + -} + TcRnGADTMonoLocalBinds :: TcRnMessage + + {-| The TcRnNotInScope constructor is used for various not-in-scope errors. + See 'NotInScopeError' for more details. -} + TcRnNotInScope :: NotInScopeError -- ^ what the problem is + -> RdrName -- ^ the name that is not in scope + -> TcRnMessage + + {-| TcRnTermNameInType is an error that occurs when a term-level identifier + is used in a type. + + Example: + + import qualified Prelude + + bad :: Prelude.fst (Bool, Float) + bad = False + + Test cases: T21605{c,d} + -} + TcRnTermNameInType :: !RdrName -> TcRnMessage + + {-| TcRnUntickedPromotedThing is a warning (controlled with -Wunticked-promoted-constructors) + that is triggered by an unticked occurrence of a promoted data constructor. + + Examples: + + data A = MkA + type family F (a :: A) where { F MkA = Bool } + + type B = [ Int, Bool ] + + Test cases: T9778, T19984. + -} + TcRnUntickedPromotedThing :: UntickedPromotedThing + -> TcRnMessage + + {-| TcRnIllegalBuiltinSyntax is an error that occurs when built-in syntax appears + in an unexpected location, e.g. as a data constructor or in a fixity declaration. + + Examples: + + infixl 5 : + + data P = (,) + + Test cases: rnfail042, T14907b, T15124, T15233. + -} + TcRnIllegalBuiltinSyntax :: SigLike -- ^ what kind of thing this is (a binding, fixity declaration, ...) + -> RdrName + -> TcRnMessage + + {-| TcRnWarnDefaulting is a warning (controlled by -Wtype-defaults) + that is triggered whenever a Wanted typeclass constraint + is solving through the defaulting of a type variable. + + Example: + + one = show 1 + -- We get Wanteds Show a0, Num a0, and default a0 to Integer. + + Test cases: + none (which are really specific to defaulting), + but see e.g. tcfail204. + -} + TcRnWarnDefaulting :: [Ct] -- ^ Wanted constraints in which defaulting occurred + -> Maybe TyVar -- ^ The type variable being defaulted + -> Type -- ^ The default type + -> TcRnMessage + + {-| TcRnIncorrectNameSpace is an error that occurs when a 'Name' + is used in the incorrect 'NameSpace', e.g. a type constructor + or class used in a term, or a term variable used in a type. + + Example: + + list2 = $( conE ''(:) `appE` litE (IntegerL 5) `appE` conE '[] ) + -- ^^^^^ + -- should use a single quotation tick, i.e. '(:) + + Test cases: T20884. + -} + TcRnIncorrectNameSpace :: Name + -> Bool -- ^ whether the error is happening + -- in a Template Haskell tick + -- (so we should give a Template Haskell hint) + -> TcRnMessage + + {-| TcRnForeignImportPrimExtNotSet is an error occurring when a foreign import + is declared using the @prim@ calling convention without having turned on + the -XGHCForeignImportPrim extension. + + Example(s): + foreign import prim "foo" foo :: ByteArray# -> (# Int#, Int# #) + + Test cases: ffi/should_fail/T20116 + -} + TcRnForeignImportPrimExtNotSet :: ForeignImport GhcRn -> TcRnMessage + + {-| TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe + annotation should not be used with @prim@ foreign imports. + + Example(s): + foreign import prim unsafe "my_primop_cmm" :: ... + + Test cases: None + -} + TcRnForeignImportPrimSafeAnn :: ForeignImport GhcRn -> TcRnMessage + + {-| TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@ + imports cannot have function types. + + Example(s): + foreign import capi "math.h value sqrt" f :: CInt -> CInt + + Test cases: ffi/should_fail/capi_value_function + -} + TcRnForeignFunctionImportAsValue :: ForeignImport GhcRn -> TcRnMessage + + {-| TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@ + that informs the user of a possible missing @&@ in the declaration of a + foreign import with a 'FunPtr' return type. + + Example(s): + foreign import ccall "f" f :: FunPtr (Int -> IO ()) + + Test cases: ffi/should_compile/T1357 + -} + TcRnFunPtrImportWithoutAmpersand :: ForeignImport GhcRn -> TcRnMessage + + {-| TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration + is not compatible with the code generation backend being used. + + Example(s): None + + Test cases: None + -} + TcRnIllegalForeignDeclBackend + :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> Backend + -> ExpectedBackends + -> TcRnMessage + + {-| TcRnUnsupportedCallConv informs the user that the calling convention specified + for a foreign export declaration is not compatible with the target platform. + It is a warning controlled by @-Wunsupported-calling-conventions@ in the case of + @stdcall@ but is otherwise considered an error. + + Example(s): None + + Test cases: None + -} + TcRnUnsupportedCallConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> UnsupportedCallConvention + -> TcRnMessage + + {-| TcRnIllegalForeignType is an error for when a type appears in a foreign + function signature that is not compatible with the FFI. + + Example(s): None + + Test cases: ffi/should_fail/T3066 + ffi/should_fail/ccfail004 + ffi/should_fail/T10461 + ffi/should_fail/T7506 + ffi/should_fail/T5664 + safeHaskell/ghci/p6 + safeHaskell/safeLanguage/SafeLang08 + ffi/should_fail/T16702 + linear/should_fail/LinearFFI + ffi/should_fail/T7243 + -} + TcRnIllegalForeignType :: !(Maybe ArgOrResult) -> !IllegalForeignTypeReason -> TcRnMessage + + {-| TcRnInvalidCIdentifier indicates a C identifier that is not valid. + + Example(s): + foreign import prim safe "not valid" cmm_test2 :: Int# -> Int# + + Test cases: th/T10638 + -} + TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage + + {-| TcRnExpectedValueId is an error occurring when something that is not a + value identifier is used where one is expected. + + Example(s): none + + Test cases: none + -} + TcRnExpectedValueId :: !TcTyThing -> TcRnMessage + + {-| TcRnRecSelectorEscapedTyVar is an error indicating that a record field selector + containing an existential type variable is used as a function rather than in + a pattern match. + + Example(s): + data Rec = forall a. Rec { field :: a } + field (Rec True) + + Test cases: patsyn/should_fail/records-exquant + typecheck/should_fail/T3176 + -} + TcRnRecSelectorEscapedTyVar :: !OccName -> TcRnMessage + + {-| TcRnPatSynNotBidirectional is an error for when a non-bidirectional pattern + synonym is used as a constructor. + + Example(s): + pattern Five :: Int + pattern Five <- 5 + five = Five + + Test cases: patsyn/should_fail/records-no-uni-update + patsyn/should_fail/records-no-uni-update2 + -} + TcRnPatSynNotBidirectional :: !Name -> TcRnMessage + + {-| TcRnIllegalDerivingItem is an error for when something other than a type class + appears in a deriving statement. + + Example(s): + data X = X deriving Int + + Test cases: deriving/should_fail/T5922 + -} + TcRnIllegalDerivingItem :: !(LHsSigType GhcRn) -> TcRnMessage + + {-| TcRnIllegalDefaultClass is an error for when something other than a type class + appears in a default declaration after the keyword. + + Example(s): + default Integer (Int) + + Test cases: default/fail01 + -} + TcRnIllegalDefaultClass :: !Name -> TcRnMessage + + {-| TcRnIllegalNamedDefault is an error for specifying an explicit default class name + without @-XNamedDefaults@. + + Example(s): + default Num (Integer) + + Test cases: default/fail02 + -} + TcRnIllegalNamedDefault :: !(LDefaultDecl GhcRn) -> TcRnMessage + + {-| TcRnUnexpectedAnnotation indicates the erroroneous use of an annotation such + as strictness, laziness, or unpacking. + + Example(s): + data T = T { t :: Maybe {-# UNPACK #-} Int } + data C = C { f :: !IntMap Int } + + Test cases: parser/should_fail/unpack_inside_type + typecheck/should_fail/T7210 + rename/should_fail/T22478b + -} + TcRnUnexpectedAnnotation :: !(HsType GhcPs) -> !HsSrcBang -> TcRnMessage + + {-| TcRnIllegalRecordSyntax is an error indicating an illegal use of record syntax. + + Example(s): + data T = T Int { field :: Int } + + Test cases: rename/should_fail/T7943 + rename/should_fail/T9077 + rename/should_fail/T22478b + -} + TcRnIllegalRecordSyntax :: HsType GhcPs -> TcRnMessage + + {-| TcRnInvalidVisibleKindArgument is an error for a kind application on a + target type that cannot accept it. + + Example(s): + bad :: Int @Type + bad = 1 + type Foo :: forall a {b}. a -> b -> b + type Foo x y = y + type Bar = Foo @Bool @Int True 42 + + Test cases: indexed-types/should_fail/T16356_Fail3 + typecheck/should_fail/ExplicitSpecificity7 + typecheck/should_fail/T12045b + typecheck/should_fail/T12045c + typecheck/should_fail/T15592a + typecheck/should_fail/T15816 + -} + TcRnInvalidVisibleKindArgument + :: !(LHsType GhcRn) -- ^ The visible kind argument + -> !Type -- ^ Target of the kind application + -> TcRnMessage + + {-| TcRnTooManyBinders is an error for a type constructor that is declared with + more arguments then its kind specifies. + + Example(s): + type T :: Type -> (Type -> Type) -> Type + data T a (b :: Type -> Type) x1 (x2 :: Type -> Type) + + Test cases: saks/should_fail/saks_fail008 + -} + TcRnTooManyBinders :: !Kind -> ![LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] -> TcRnMessage + + {-| TcRnDifferentNamesForTyVar is an error that indicates different names being + used for the same type variable. + + Example(s): + data SameKind :: k -> k -> * + data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) + + Test cases: polykinds/T11203 + polykinds/T11821a + saks/should_fail/T20916 + typecheck/should_fail/T17566b + typecheck/should_fail/T17566c + -} + TcRnDifferentNamesForTyVar :: !Name -> !Name -> TcRnMessage + + {-| TcRnDisconnectedTyVar is an error for a data declaration that has a kind signature, + where the implicitly-bound type type variables can't be matched up unambiguously + with the ones from the signature. See Note [Disconnected type variables] in + GHC.Tc.Gen.HsType. + + Test cases: T24083 + -} + TcRnDisconnectedTyVar :: !Name -> TcRnMessage + + {-| TcRnInvalidReturnKind is an error for a data declaration that has a kind signature + with an invalid result kind. + + Example(s): + data family Foo :: Constraint + + Test cases: typecheck/should_fail/T14048b + typecheck/should_fail/UnliftedNewtypesConstraintFamily + typecheck/should_fail/T12729 + typecheck/should_fail/T15883 + typecheck/should_fail/T16829a + typecheck/should_fail/T16829b + typecheck/should_fail/UnliftedNewtypesNotEnabled + typecheck/should_fail/tcfail079 + -} + TcRnInvalidReturnKind + :: !DataSort -- ^ classification of thing being returned + -> !AllowedDataResKind -- ^ allowed kind + -> !Kind -- ^ the return kind + -> !(Maybe SuggestUnliftedTypes) -- ^ suggested extension + -> TcRnMessage + + {-| TcRnUnexpectedKindVar is an error that occurs when the user + tries to use kind variables without -XPolyKinds. + + Example: + f :: forall k a. Proxy (a :: k) + + Test cases: polykinds/BadKindVar + polykinds/T14710 + saks/should_fail/T16722 + -} + TcRnUnexpectedKindVar :: RdrName -> TcRnMessage + + {-| TcRnIllegalKind is used for a various illegal kinds errors including + + Example: + type T :: forall k. Type -- without emabled -XPolyKinds + + Test cases: polykinds/T16762b + -} + TcRnIllegalKind + :: HsTypeOrSigType GhcPs + -- ^ The illegal kind + -> Bool -- ^ Whether enabling -XPolyKinds should be suggested + -> TcRnMessage + + {-| TcRnClassKindNotConstraint is an error for a type class that has a kind that + is not equivalent to Constraint. + + Example(s): + type C :: Type -> Type + class C a + + Test cases: saks/should_fail/T16826 + -} + TcRnClassKindNotConstraint :: !Kind -> TcRnMessage + + {-| TcRnUnpromotableThing is an error that occurs when the user attempts to + use the promoted version of something which is not promotable. + + Example(s): + data T :: T -> * + data X a where + MkX :: Show a => a -> X a + foo :: Proxy ('MkX 'True) + foo = Proxy + + Test cases: dependent/should_fail/PromotedClass + dependent/should_fail/T14845_fail1 + dependent/should_fail/T14845_fail2 + dependent/should_fail/T15215 + dependent/should_fail/T13780c + dependent/should_fail/T15245 + polykinds/T5716 + polykinds/T5716a + polykinds/T6129 + polykinds/T7433 + patsyn/should_fail/T11265 + patsyn/should_fail/T9161-1 + patsyn/should_fail/T9161-2 + dependent/should_fail/SelfDep + polykinds/PolyKinds06 + polykinds/PolyKinds07 + polykinds/T13625 + polykinds/T15116 + polykinds/T15116a + saks/should_fail/T16727a + saks/should_fail/T16727b + rename/should_fail/T12686 + rename/should_fail/T16635a + rename/should_fail/T16635b + rename/should_fail/T16635c + -} + TcRnUnpromotableThing :: !Name -> !PromotionErr -> TcRnMessage + + {- | TcRnIllegalTermLevelUse is an error that occurs when the user attempts to + use a type-level entity at the term-level. + + Examples: + f x = Int -- illegal use of a type constructor + g (Proxy :: Proxy a) = a -- illegal use of a type variable + + Note that the namespace cannot be used to determine if a name refers to a + type-level entity: + + {-# LANGUAGE RequiredTypeArguments #-} + bad :: forall (a :: k) -> k + bad t = t + + The name `t` is assigned the `varName` namespace but stands for a type + variable that cannot be used at the term level. + + Test cases: T18740a, T18740b, T23739_fail_ret, T23739_fail_case + -} + TcRnIllegalTermLevelUse + :: !Bool -- ^ should we give a simple "out of scope" message, + -- instead of a full-blown "Illegal term level use" message? + -> !RdrName -- ^ the user-written identifier + -> !Name -- ^ the type-level 'Name' we resolved it to + -> !TermLevelUseErr + -> TcRnMessage + + {-| TcRnMatchesHaveDiffNumArgs is an error occurring when something has matches + that have different numbers of arguments + + Example(s): + foo x = True + foo x y = False + + Test cases: rename/should_fail/rnfail045 + typecheck/should_fail/T20768_fail + -} + TcRnMatchesHaveDiffNumArgs + :: !HsMatchContextRn -- ^ Pattern match specifics + -> !MatchArgBadMatches + -> TcRnMessage + + {-| TcRnUnexpectedPatSigType is an error occurring when there is + a type signature in a pattern without -XScopedTypeVariables extension + + Examples: + f (a :: Bool) = ... + + Test case: rename/should_fail/T11663 + -} + TcRnUnexpectedPatSigType :: HsPatSigType GhcPs -> TcRnMessage + + {-| TcRnIllegalKindSignature is an error occurring when there is + a kind signature without -XKindSignatures extension + + Examples: + data Foo (a :: Nat) = .... + + Test case: parser/should_fail/readFail036 + -} + TcRnIllegalKindSignature :: HsType GhcPs -> TcRnMessage + + {-| TcRnDataKindsError is an error occurring when there is + an illegal type or kind, probably required -XDataKinds + and is used without the enabled extension. + + This error can occur in both the renamer and the typechecker. The field + of type @'Either' ('HsType' 'GhcPs') 'Type'@ reflects this: this field + will contain a 'Left' value if the error occurred in the renamer, and this + field will contain a 'Right' value if the error occurred in the + typechecker. + + Examples: + + type Foo = [Nat, Char] + + type Bar = [Int, String] + + Test cases: linear/should_fail/T18888 + parser/should_fail/readFail001 + polykinds/T7151 + polykinds/T7433 + rename/should_fail/T13568 + rename/should_fail/T22478e + th/TH_Promoted1Tuple + typecheck/should_compile/tcfail094 + typecheck/should_fail/T22141a + typecheck/should_fail/T22141b + typecheck/should_fail/T22141c + typecheck/should_fail/T22141d + typecheck/should_fail/T22141e + typecheck/should_compile/T22141f + typecheck/should_compile/T22141g + typecheck/should_fail/T20873c + typecheck/should_fail/T20873d + -} + TcRnDataKindsError :: TypeOrKind -> Either (HsType GhcPs) Type -> TcRnMessage + + {-| TcRnCannotBindScopedTyVarInPatSig is an error stating that scoped type + variables cannot be used in pattern bindings. + + Example(s): + let (x :: a) = 5 + + Test cases: typecheck/should_compile/tc141 + -} + TcRnCannotBindScopedTyVarInPatSig :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage + + {-| TcRnCannotBindTyVarsInPatBind is an error for when type + variables are introduced in a pattern binding + + Example(s): + Just @a x = Just True + + Test cases: typecheck/should_fail/TyAppPat_PatternBinding + typecheck/should_fail/TyAppPat_PatternBindingExistential + -} + TcRnCannotBindTyVarsInPatBind :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage + + {-| TcRnMultipleInlinePragmas is a warning signifying that multiple inline pragmas + reference the same definition. + + Example(s): + {-# INLINE foo #-} + {-# INLINE foo #-} + foo :: Bool -> Bool + foo = id + + Test cases: none + -} + TcRnMultipleInlinePragmas + :: !Id -- ^ Target of the pragmas + -> !(LocatedA InlinePragma) -- ^ The first pragma + -> !(NE.NonEmpty (LocatedA InlinePragma)) -- ^ Other pragmas + -> TcRnMessage + + {-| TcRnUnexpectedPragmas is a warning that occurs when unexpected pragmas appear + in the source. + + Example(s): + + Test cases: none + -} + TcRnUnexpectedPragmas :: !Id -> !(NE.NonEmpty (LSig GhcRn)) -> TcRnMessage + + {-| TcRnNonOverloadedSpecialisePragma is a warning for a specialise pragma being + placed on a definition that is not overloaded. + + Example(s): + {-# SPECIALISE foo :: Bool -> Bool #-} + foo :: Bool -> Bool + foo = id + + Test cases: simplCore/should_compile/T8537 + typecheck/should_compile/T10504 + -} + TcRnNonOverloadedSpecialisePragma :: !(LIdP GhcRn) -> TcRnMessage + -- NB: this constructor is deprecated and will be removed in GHC 9.18 (#25540) + + {-| TcRnSpecialiseNotVisible is a warning that occurs when the subject of a + SPECIALISE pragma has a definition that is not visible from the current module. + + Example(s): none + + Test cases: none + -} + TcRnSpecialiseNotVisible :: !Name -> TcRnMessage + + {-| TcRnPragmaWarning is a warning that can happen when usage of something + is warned or deprecated by pragma. + + Test cases: + DeprU + T5281 + T5867 + rn050 + rn066 (here is a warning, not deprecation) + T3303 + ExportWarnings1 + ExportWarnings2 + ExportWarnings3 + ExportWarnings4 + ExportWarnings5 + ExportWarnings6 + InstanceWarnings + -} + TcRnPragmaWarning :: { + pragma_warning_info :: PragmaWarningInfo, + pragma_warning_msg :: WarningTxt GhcRn + } -> TcRnMessage + + {-| TcRnDifferentExportWarnings is an error that occurs when the + warning messages for exports of a name differ between several export items. + + Test case: + DifferentExportWarnings + -} + TcRnDifferentExportWarnings :: !Name -- ^ The name with different export warnings + -> NE.NonEmpty SrcSpan -- ^ The locations of export list items that differ + -- from the one at which the error is reported + -> TcRnMessage + + {-| TcRnIncompleteExportWarnings is a warning (controlled by -Wincomplete-export-warnings) that + occurs when some of the exports of a name do not have an export warning and some do + + Test case: + ExportWarnings6 + -} + TcRnIncompleteExportWarnings :: !Name -- ^ The name that is exported + -> NE.NonEmpty SrcSpan -- ^ The locations of export list items that are + -- missing the export warning + -> TcRnMessage + + {-| TcRnIllegalHsigDefaultMethods is an error that occurs when a binding for + a class default method is provided in a Backpack signature file. + + Test case: + bkpfail40 + -} + TcRnIllegalHsigDefaultMethods :: !Name -- ^ 'Name' of the class + -> NE.NonEmpty (LHsBind GhcRn) -- ^ default methods + -> TcRnMessage + + {-| TcRnHsigFixityMismatch is an error indicating that the fixity decl in a + Backpack signature file differs from the one in the source file for the same + operator. + + Test cases: + bkpfail37, bkpfail38 + -} + TcRnHsigFixityMismatch :: !TyThing -- ^ The operator whose fixity is defined + -> !Fixity -- ^ the fixity used in the source file + -> !Fixity -- ^ the fixity used in the signature + -> TcRnMessage + + {-| TcRnHsigShapeMismatch is a group of errors related to mismatches between + backpack signatures. + -} + TcRnHsigShapeMismatch :: !HsigShapeMismatchReason + -> TcRnMessage + + {-| TcRnHsigMissingModuleExport is an error indicating that a module doesn't + export a name exported by its signature. + + Test cases: + bkpfail01, bkpfail05, bkpfail09, bkpfail16, bkpfail35, bkpcabal06 + -} + TcRnHsigMissingModuleExport :: !OccName -- ^ The missing name + -> !UnitState -- ^ The module's unit state + -> !Module -- ^ The implementation module + -> TcRnMessage + + {-| TcRnBadGenericMethod + This test ensures that if you provide a "more specific" type signatures + for the default method, you must also provide a binding. + + Example: + {-# LANGUAGE DefaultSignatures #-} + + class C a where + meth :: a + default meth :: Num a => a + meth = 0 + + Test case: + typecheck/should_fail/MissingDefaultMethodBinding.hs + -} + TcRnBadGenericMethod :: !Name -- ^ 'Name' of the class + -> !Name -- ^ Problematic method + -> TcRnMessage + + {-| TcRnWarningMinimalDefIncomplete is a warning that one must + specify which methods must be implemented by all instances. + + Example: + class Cheater a where -- WARNING LINE + cheater :: a + {-# MINIMAL #-} -- warning! + + Test case: + warnings/minimal/WarnMinimal.hs: + -} + TcRnWarningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage + + {-| TcRnIllegalQuasiQuotes is an error that occurs when a quasi-quote + is used without the QuasiQuotes extension. + + Example: + + foo = [myQuoter|x y z|] + + Test cases: none; the parser fails to parse this if QuasiQuotes is off. + -} + TcRnIllegalQuasiQuotes :: TcRnMessage + + {-| TcRnTHError is a family of errors involving Template Haskell. + See 'THError'. + -} + TcRnTHError :: THError -> TcRnMessage + + {-| TcRnDefaultMethodForPragmaLacksBinding is an error that occurs when + a default method pragma is missing an accompanying binding. + + Test cases: + typecheck/should_fail/T5084.hs + typecheck/should_fail/T2354.hs + -} + TcRnDefaultMethodForPragmaLacksBinding + :: Id -- ^ method + -> Sig GhcRn -- ^ the pragma + -> TcRnMessage + {-| TcRnIgnoreSpecialisePragmaOnDefMethod is a warning that occurs when + a specialise pragma is put on a default method. + + Test cases: none + -} + TcRnIgnoreSpecialisePragmaOnDefMethod + :: !Name + -> TcRnMessage + {-| TcRnBadMethodErr is an error that happens when one attempts to provide a method + in a class instance, when the class doesn't have a method by that name. + + Test case: + th/T12387 + -} + TcRnBadMethodErr + :: { badMethodErrClassName :: !Name + , badMethodErrMethodName :: !Name + } -> TcRnMessage + + {-| TcRnIllegalNewtype is an error that occurs when a newtype: + + * Does not have exactly one field, or + * is non-linear, or + * is a GADT, or + * has a context in its constructor's type, or + * has existential type variables in its constructor's type, or + * has strictness annotations. + + Test cases: + gadt/T14719 + indexed-types/should_fail/T14033 + indexed-types/should_fail/T2334A + linear/should_fail/LinearGADTNewtype + parser/should_fail/readFail008 + polykinds/T11459 + typecheck/should_fail/T15523 + typecheck/should_fail/T15796 + typecheck/should_fail/T17955 + typecheck/should_fail/T18891a + typecheck/should_fail/T21447 + typecheck/should_fail/tcfail156 + -} + TcRnIllegalNewtype + :: DataCon + -> Bool -- ^ True if linear types enabled + -> IllegalNewtypeReason + -> TcRnMessage + + {-| TcRnIllegalTypeData is an error that occurs when a @type data@ + declaration occurs without the TypeOperators extension. + + See Note [Type data declarations] + + Test case: + type-data/should_fail/TDNoPragma + -} + TcRnIllegalTypeData :: TcRnMessage + + {-| TcRnTypeDataForbids is an error that occurs when a @type data@ + declaration contains @data@ declaration features that are + forbidden in a @type data@ declaration. + + See Note [Type data declarations] + + Test cases: + type-data/should_fail/TDDeriving + type-data/should_fail/TDRecordsGADT + type-data/should_fail/TDRecordsH98 + type-data/should_fail/TDStrictnessGADT + type-data/should_fail/TDStrictnessH98 + -} + TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage + + {-| TcRnOrPatBindsVariables is an error that happens when an + or-pattern binds term or type variables, e.g. (A @x; B y). + + Test case: + testsuite/tests/typecheck/should_fail/Or3 + -} + TcRnOrPatBindsVariables + :: NE.NonEmpty (IdP GhcRn) -- ^ List of binders + -> TcRnMessage + + {- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance + is missing methods that are required by the minimal definition. + + Example: + class C a where + foo :: a -> a + instance C () -- | foo needs to be defined here + + Test cases: + typecheck/prog001/typecheck.prog001 + typecheck/should_compile/tc126 + typecheck/should_compile/T7903 + typecheck/should_compile/tc116 + typecheck/should_compile/tc175 + typecheck/should_compile/HasKey + typecheck/should_compile/tc125 + typecheck/should_compile/tc078 + typecheck/should_compile/tc161 + typecheck/should_fail/T5051 + typecheck/should_compile/T21583 + backpack/should_compile/bkp47 + backpack/should_fail/bkpfail25 + parser/should_compile/T2245 + parser/should_compile/read014 + indexed-types/should_compile/Class3 + indexed-types/should_compile/Simple2 + indexed-types/should_fail/T7862 + deriving/should_compile/deriving-1935 + deriving/should_compile/T9968a + deriving/should_compile/drv003 + deriving/should_compile/T4966 + deriving/should_compile/T14094 + perf/compiler/T15304 + warnings/minimal/WarnMinimal + simplCore/should_compile/simpl020 + deSugar/should_compile/T14546d + ghci/scripts/T5820 + ghci/scripts/ghci019 + -} + TcRnUnsatisfiedMinimalDef :: ClassMinimalDef -> TcRnMessage + + {-| 'TcRnMisplacedInstSig' is an error that happens when a method in + a class instance is given a type signature, but the user has not + enabled the @InstanceSigs@ extension. + + Test case: module/mod45 + -} + TcRnMisplacedInstSig :: Name -> (LHsSigType GhcRn) -> TcRnMessage + {-| TcRnNoRebindableSyntaxRecordDot is an error triggered by an overloaded record update + without RebindableSyntax enabled. + + Example(s): + + Test cases: parser/should_fail/RecordDotSyntaxFail5 + -} + TcRnNoRebindableSyntaxRecordDot :: TcRnMessage + + {-| TcRnNoFieldPunsRecordDot is an error triggered by the use of record field puns + in an overloaded record update without enabling NamedFieldPuns. + + Example(s): + print $ a{ foo.bar.baz.quux } + + Test cases: parser/should_fail/RecordDotSyntaxFail12 + -} + TcRnNoFieldPunsRecordDot :: TcRnMessage + + {-| TcRnIllegalStaticExpression is an error thrown when user creates a static + pointer via TemplateHaskell without enabling the StaticPointers extension. + + Example(s): + + Test cases: th/T14204 + -} + TcRnIllegalStaticExpression :: HsExpr GhcPs -> TcRnMessage + + {-| TcRnListComprehensionDuplicateBinding is an error triggered by duplicate + let-bindings in a list comprehension. + + Example(s): + [ () | let a = 13 | let a = 17 ] + + Test cases: typecheck/should_fail/tcfail092 + -} + TcRnListComprehensionDuplicateBinding :: Name -> TcRnMessage + + {-| TcRnEmptyStmtsGroup is an error triggered by an empty list of statements + in a statement block. For more information, see 'EmptyStatementGroupErrReason' + + Example(s): + + [() | then ()] + + do + + proc () -> do + + Test cases: rename/should_fail/RnEmptyStatementGroup1 + -} + TcRnEmptyStmtsGroup:: EmptyStatementGroupErrReason -> TcRnMessage + + {-| TcRnLastStmtNotExpr is an error caused by the last statement + in a statement block not being an expression. + + Example(s): + + do x <- pure () + + do let x = 5 + + Test cases: rename/should_fail/T6060 + parser/should_fail/T3811g + parser/should_fail/readFail028 + -} + TcRnLastStmtNotExpr + :: HsStmtContextRn + -> UnexpectedStatement + -> TcRnMessage + + {-| TcRnUnexpectedStatementInContext is an error when a statement appears + in an unexpected context (e.g. an arrow statement appears in a list comprehension). + + Example(s): + + Test cases: parser/should_fail/readFail042 + parser/should_fail/readFail038 + parser/should_fail/readFail043 + -} + TcRnUnexpectedStatementInContext + :: HsStmtContextRn + -> UnexpectedStatement + -> Maybe LangExt.Extension + -> TcRnMessage + + {-| TcRnIllegalTupleSection is an error triggered by usage of a tuple section + without enabling the TupleSections extension. + + Example(s): + (5,) + + Test cases: rename/should_fail/rnfail056 + -} + TcRnIllegalTupleSection :: TcRnMessage + + {-| TcRnIllegalImplicitParameterBindings is an error triggered by binding + an implicit parameter in an mdo block. + + Example(s): + mdo { let { ?x = 5 }; () } + + Test cases: rename/should_fail/RnImplicitBindInMdoNotation + -} + TcRnIllegalImplicitParameterBindings + :: Either (HsLocalBindsLR GhcPs GhcPs) (HsLocalBindsLR GhcRn GhcPs) + -> TcRnMessage + + {-| TcRnSectionWithoutParentheses is an error triggered by attempting to + use an operator section without parentheses. + + Example(s): + (`head` x, ()) + + Test cases: rename/should_fail/T2490 + rename/should_fail/T5657 + -} + TcRnSectionWithoutParentheses :: HsExpr GhcPs -> TcRnMessage + + {-| TcRnBindingOfExistingName is an error triggered by an attempt to rebind + built-in syntax, punned list or tuple syntax, or a name quoted via Template Haskell. + + Examples: + + data [] + data (->) + $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []]) + + Test cases: rename/should_fail/T14907b + rename/should_fail/T22839 + rename/should_fail/rnfail042 + th/T13968 + -} + TcRnBindingOfExistingName :: RdrName -> TcRnMessage + {-| TcRnMultipleFixityDecls is an error triggered by multiple + fixity declarations for the same operator. + + Example(s): + + infixr 6 $$ + infixl 4 $$ + + Test cases: rename/should_fail/RnMultipleFixityFail + -} + TcRnMultipleFixityDecls :: SrcSpan -> RdrName -> TcRnMessage + + {-| TcRnIllegalPatternSynonymDecl is an error thrown when a user + defines a pattern synonyms without enabling the PatternSynonyms extension. + + Example: + + pattern O :: Int + pattern O = 0 + + Test cases: rename/should_fail/RnPatternSynonymFail + -} + TcRnIllegalPatternSynonymDecl :: TcRnMessage + + {-| TcRnIllegalClassBinding is an error triggered by a binding + in a class or instance declaration of an illegal form. + + Examples: + + class ZeroOne a where + zero :: a + one :: a + instance ZeroOne Int where + (zero,one) = (0,1) + + class C a where + pattern P = () + + Test cases: module/mod48 + patsyn/should_fail/T9705-1 + patsyn/should_fail/T9705-2 + typecheck/should_fail/tcfail021 + + -} + TcRnIllegalClassBinding :: DeclSort -> HsBindLR GhcPs GhcPs -> TcRnMessage + + {-| TcRnOrphanCompletePragma is an error triggered by a {-# COMPLETE #-} + pragma which does not mention any data constructors or pattern synonyms + defined in the current module. + + Test cases: patsyn/should_fail/T13349 + -} + TcRnOrphanCompletePragma :: TcRnMessage + + {-| TcRnEmptyCase is an error thrown when a user uses + a case expression with an empty list of alternatives without + enabling the EmptyCase extension. + + Example for EmptyCaseWithoutFlag: + + {-# LANGUAGE NoEmptyCase #-} + f :: Void -> a + f = \case {} -- extension not enabled + + Example for EmptyCaseDisallowedCtxt: + + f = \cases {} -- multi-case requires n>0 alternatives + + Example for EmptyCaseForall: + + f :: forall (xs :: Type) -> () + f = \case {} -- can't match on a type argument + + Test cases: rename/should_fail/RnEmptyCaseFail + typecheck/should_fail/T25004 + -} + TcRnEmptyCase :: !HsMatchContextRn + -> !BadEmptyCaseReason + -> TcRnMessage + + {-| TcRnNonStdGuards is a warning thrown when a user uses + non-standard guards (e.g. patterns in guards) without + enabling the PatternGuards extension. + More realistically: the user has explicitly disabled PatternGuards, + as it is enabled by default with `-XHaskell2010`. + + Example(s): + + f | 5 <- 2 + 3 = ... + + Test cases: rename/should_compile/rn049 + -} + TcRnNonStdGuards :: NonStandardGuards -> TcRnMessage + + {-| TcRnDuplicateSigDecl is an error triggered by two or more + signatures for one entity. + + Examples: + + f :: Int -> Bool + f :: Int -> Bool + f _ = True + + g x = x + {-# INLINE g #-} + {-# NOINLINE g #-} + + pattern P = () + {-# COMPLETE P #-} + {-# COMPLETE P #-} + + Test cases: module/mod68 + parser/should_fail/OpaqueParseFail4 + patsyn/should_fail/T12165 + rename/should_fail/rnfail048 + rename/should_fail/T5589 + rename/should_fail/T7338 + rename/should_fail/T7338a + -} + TcRnDuplicateSigDecl :: NE.NonEmpty (LocatedN RdrName, Sig GhcPs) -> TcRnMessage + + {-| TcRnMisplacedSigDecl is an error triggered by the pragma application + in the wrong context, like `MINIMAL` applied to a function or + `SPECIALIZE` to an instance. + + Example: + + f x = x + {-# MINIMAL f #-} + + Test cases: rename/should_fail/T18138 + warnings/minimal/WarnMinimalFail1 + -} + TcRnMisplacedSigDecl :: Sig GhcRn -> TcRnMessage + + {-| TcRnUnexpectedDefaultSig is an error thrown when a user uses + default signatures without enabling the DefaultSignatures extension. + + Example: + + class C a where + m :: a + default m :: Num a => a + m = 0 + + Test cases: rename/should_fail/RnDefaultSigFail + -} + TcRnUnexpectedDefaultSig :: Sig GhcPs -> TcRnMessage + + {-| TcRnDuplicateMinimalSig is an error triggered by two or more minimal + signatures for one type class. + + Example: + + class C where + f :: () + {-# MINIMAL f #-} + {-# MINIMAL f #-} + + Test cases: rename/should_fail/RnMultipleMinimalPragmaFail + -} + TcRnDuplicateMinimalSig :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> TcRnMessage + + {-| TcRnSpecSigShape is an error that occurs when the user writes a SPECIALISE + pragma that isn't just a function application. + + Example: + {-# SPECIALISE let x=True in x #-} + -} + TcRnSpecSigShape :: LHsExpr GhcPs -> TcRnMessage + + {-| 'TcRnIllegalInvisTyVarBndr' is an error that occurs + when invisible type variable binders in type declarations + are used without enabling the @TypeAbstractions@ extension. + + Example: + {-# LANGUAGE NoTypeAbstractions #-} -- extension disabled + data T @k (a :: k) @(j :: Type) (b :: j) + ^^ ^^^^^^^^^^^^ + + Test case: T22560_fail_ext + -} + TcRnIllegalInvisTyVarBndr + :: !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) + -> TcRnMessage + + {-| 'TcRnIllegalWildcardTyVarBndr' is an error that occurs + when a wildcard binder is used in a type declaration + without enabling the @TypeAbstractions@ extension. + + Example: + {-# LANGUAGE NoTypeAbstractions #-} -- extension disabled + type Const a _ = a + ^ + + Test case: T23501_fail_ext + -} + TcRnIllegalWildcardTyVarBndr + :: !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) + -> TcRnMessage + + {-| 'TcRnInvalidInvisTyVarBndr' is an error that occurs + when an invisible type variable binder has no corresponding + @forall k.@ quantifier in the standalone kind signature. + + Example: + type P :: forall a -> Type + data P @a = MkP + + Test cases: T22560_fail_a T22560_fail_b + -} + TcRnInvalidInvisTyVarBndr + :: !Name + -> !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) + -> TcRnMessage + + {-| 'TcRnInvisBndrWithoutSig' is an error triggered by attempting to use + an invisible type variable binder in a type declaration without a + standalone kind signature or a complete user-supplied kind. + + Example: + data T @k (a :: k) -- No CUSK, no SAKS + + Test case: T22560_fail_d + -} + TcRnInvisBndrWithoutSig + :: !Name + -> !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) + -> TcRnMessage + + {-| TcRnUnexpectedStandaloneDerivingDecl is an error thrown when a user uses + standalone deriving without enabling the StandaloneDeriving extension. + + Example: + + deriving instance Eq Foo + + Test cases: rename/should_fail/RnUnexpectedStandaloneDeriving + -} + TcRnUnexpectedStandaloneDerivingDecl :: TcRnMessage + + {-| TcRnUnusedVariableInRuleDecl is an error triggered by forall'd variable in + rewrite rule that does not appear on left-hand side + + Example: + + {-# RULES "rule" forall a. id = id #-} + + Test cases: rename/should_fail/ExplicitForAllRules2 + -} + TcRnUnusedVariableInRuleDecl :: FastString -> Name -> TcRnMessage + + {-| TcRnUnexpectedStandaloneKindSig is an error thrown when a user uses standalone + kind signature without enabling the StandaloneKindSignatures extension. + + Example: + + type D :: Type + data D = D + + Test cases: saks/should_fail/saks_fail001 + -} + TcRnUnexpectedStandaloneKindSig :: TcRnMessage + + {-| TcRnIllegalRuleLhs is an error triggered by malformed left-hand side + of rewrite rule + + Examples: + + {-# RULES "test" forall x. f x = x #-} + + {-# RULES "test" forall x. case x of = x #-} + + Test cases: rename/should_fail/T15659 + -} + TcRnIllegalRuleLhs + :: RuleLhsErrReason + -> FastString -- ^ Rule name + -> LHsExpr GhcRn -- ^ Full expression + -> HsExpr GhcRn -- ^ Bad expression + -> TcRnMessage + + {-| TcRnRuleLhsEqualities is a warning, controlled by '-Wrule-lhs-equalities', + that is triggered by a RULE whose LHS contains equality constraints + (of a certain form, such as @F a ~ b@ for a type family @F@). + + Test case: typecheck/should_compile/RuleEqs + -} + TcRnRuleLhsEqualities + :: FastString -- ^ rule name + -> LHsExpr GhcRn -- ^ LHS expression + -> NE.NonEmpty Ct -- ^ LHS equality constraints + -> TcRnMessage + + {-| TcRnDuplicateRoleAnnot is an error triggered by two or more role + annotations for one type + + Example: + + data D a + type role D phantom + type role D phantom + + Test cases: roles/should_fail/Roles8 + -} + TcRnDuplicateRoleAnnot :: NE.NonEmpty (LRoleAnnotDecl GhcPs) -> TcRnMessage + + {-| TcRnDuplicateKindSig is an error triggered by two or more standalone + kind signatures for one type + + Example: + + type D :: Type + type D :: Type + data D + + Test cases: saks/should_fail/saks_fail002 + -} + TcRnDuplicateKindSig :: NE.NonEmpty (LStandaloneKindSig GhcPs) -> TcRnMessage + + {-| TcRnIllegalDerivStrategy is an error thrown when a user uses deriving + strategy without enabling the DerivingStrategies extension or uses deriving + via without enabling the DerivingVia extension. + + Examples: + + data T = T deriving stock Eq + + data T = T deriving via Eq T + + Test cases: deriving/should_fail/deriving-via-fail3 + deriving/should_fail/T10598_fail4 + -} + TcRnIllegalDerivStrategy :: DerivStrategy GhcPs -> TcRnMessage + + {-| TcRnIllegalMultipleDerivClauses is an error thrown when a user uses two or more + deriving clauses without enabling the DerivingStrategies extension. + + Example: + + data T = T + deriving Eq + deriving Ord + + Test cases: deriving/should_fail/T10598_fail5 + -} + TcRnIllegalMultipleDerivClauses :: TcRnMessage + + {-| TcRnNoDerivStratSpecified is a warning implied by + -Wmissing-deriving-strategies and triggered by deriving without + mentioning a strategy. + + See 'TcRnNoDerivStratSpecifiedInfo' cases for examples. + + Test cases: deriving/should_compile/T15798a + deriving/should_compile/T15798b + deriving/should_compile/T15798c + deriving/should_compile/T24955a + deriving/should_compile/T24955b + deriving/should_compile/T24955c + -} + TcRnNoDerivStratSpecified + :: Bool -- ^ True if DerivingStrategies is enabled + -> TcRnNoDerivStratSpecifiedInfo + -> TcRnMessage + + {-| TcRnStupidThetaInGadt is an error triggered by data contexts in GADT-style + data declaration + + Example: + + data (Eq a) => D a where + MkD :: D Int + + Test cases: rename/should_fail/RnStupidThetaInGadt + -} + TcRnStupidThetaInGadt :: HsDocContext -> TcRnMessage + + {-| TcRnShadowedTyVarNameInFamResult is an error triggered by type variable in + type family result that shadows type variable from left hand side + + Example: + + type family F a b c = b + + Test cases: ghci/scripts/T6018ghcirnfail + rename/should_fail/T6018rnfail + -} + TcRnShadowedTyVarNameInFamResult :: IdP GhcPs -> TcRnMessage + + {-| TcRnIncorrectTyVarOnRhsOfInjCond is an error caused by a situation where the + left-hand side of an injectivity condition of a type family is not a variable + referring to the type family result. + See Note [Renaming injectivity annotation] for more details. + + Example: + + type family F a = r | a -> a + + Test cases: ghci/scripts/T6018ghcirnfail + rename/should_fail/T6018rnfail + -} + TcRnIncorrectTyVarOnLhsOfInjCond + :: IdP GhcRn -- Expected + -> LIdP GhcPs -- Actual + -> TcRnMessage + + {-| TcRnUnknownTyVarsOnRhsOfInjCond is an error triggered by out-of-scope type + variables on the right-hand side of a of an injectivity condition of a type family + + Example: + + type family F a = res | res -> b + + Test cases: ghci/scripts/T6018ghcirnfail + rename/should_fail/T6018rnfail + -} + TcRnUnknownTyVarsOnRhsOfInjCond :: [Name] -> TcRnMessage + + {-| TcRnLookupInstance groups several errors emitted when looking up class instances. + + Test cases: + none + -} + TcRnLookupInstance + :: !Class + -> ![Type] + -> !LookupInstanceErrReason + -> TcRnMessage + + {-| TcRnBadlyLevelled is an error that occurs when a TH binding is used at an + invalid level. + + Test cases: + T17820d, T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9} + -} + TcRnBadlyLevelled + :: !LevelCheckReason -- ^ The binding + -> !(Set.Set ThLevelIndex) -- ^ The binding levels + -> !ThLevelIndex -- ^ The level at which the binding is used. + -> !(Maybe ErrorItem) -- ^ The attempt we made to implicitly lift the binding. + -> DiagnosticReason -- ^ Whether to defer this error or fail + -> TcRnMessage + + {-| TcRnBadlyLevelledWarn is a warning that occurs when a TH type binding is + used in an invalid stage. + + Controlled by flags: + - Wbadly-levelled-type + + Test cases: + T23829_timely T23829_tardy T23829_hasty + -} + TcRnBadlyLevelledType + :: !Name -- ^ The type binding being spliced. + -> !(Set.Set ThLevelIndex) -- ^ The binding stage. + -> !ThLevelIndex -- ^ The stage at which the binding is used. + -> TcRnMessage + + {-| TcRnTyThingUsedWrong is an error that occurs when a thing is used where another + thing was expected. + + Test cases: + none + -} + TcRnTyThingUsedWrong + :: !WrongThingSort -- ^ Expected thing. + -> !TcTyThing -- ^ Thing used wrongly. + -> !Name -- ^ Name of the thing used wrongly. + -> TcRnMessage + + {-| TcRnCannotDefaultKindVar is an error that occurs when attempting to use + unconstrained kind variables whose type isn't @Type@, without -XPolyKinds. + + Test cases: + T11334b + -} + TcRnCannotDefaultKindVar + :: !TyVar -- ^ The unconstrained variable. + -> !Kind -- ^ Kind of the variable. + -> TcRnMessage + + {-| TcRnUninferrableTyVar is an error that occurs when metavariables + in a type could not be defaulted. + + Test cases: + T17301, T17562, T17567, T17567StupidTheta, T15474, T21479 + -} + TcRnUninferrableTyVar + :: ![TyCoVar] -- ^ The variables that could not be defaulted. + -> !UninferrableTyVarCtx -- ^ Description of the surrounding context. + -> TcRnMessage + + {-| TcRnSkolemEscape is an error that occurs when type variables from an + outer scope is used in a context where they should be locally scoped. + + Test cases: + T15076, T15076b, T14880-2, T15825, T14880, T15807, T16946, T14350, + T14040A, T15795, T15795a, T14552 + -} + TcRnSkolemEscape + :: ![TcTyVar] -- ^ The variables that would escape. + -> !TcTyVar -- ^ The variable that is being quantified. + -> !Type -- ^ The type in which they occur. + -> TcRnMessage + + {-| TcRnPatSynEscapedCoercion is an error indicating that a coercion escaped from + a pattern synonym into a type. + See Note [Coercions that escape] in GHC.Tc.TyCl.PatSyn + + Test cases: + T14507 + -} + TcRnPatSynEscapedCoercion :: !Id -- ^ The pattern-bound variable + -> !(NE.NonEmpty CoVar) -- ^ The escaped coercions + -> TcRnMessage + + {-| TcRnPatSynExistentialInResult is an error indicating that the result type + of a pattern synonym mentions an existential type variable. + + Test cases: + PatSynExistential + -} + TcRnPatSynExistentialInResult :: !Name -- ^ The name of the pattern synonym + -> !TcSigmaType -- ^ The result type + -> ![TyVar] -- ^ The escaped existential variables + -> TcRnMessage + + {-| TcRnPatSynArityMismatch is an error indicating that the number of arguments in a + pattern synonym's equation differs from the number of parameters in its + signature. + + Test cases: + PatSynArity + -} + TcRnPatSynArityMismatch :: !Name -- ^ The name of the pattern synonym + -> !Arity -- ^ The number of equation arguments + -> !Arity -- ^ The difference + -> TcRnMessage + + {-| TcRnPatSynInvalidRhs is an error group indicating that the pattern on the + right hand side of a pattern synonym is invalid. + + Test cases: + unidir, T14112 + -} + TcRnPatSynInvalidRhs :: !Name -- ^ The name of the pattern synonym + -> !(LPat GhcRn) -- ^ The pattern + -> ![LIdP GhcRn] -- ^ The LHS args + -> !PatSynInvalidRhsReason -- ^ The number of equation arguments + -> TcRnMessage + + {-| TcRnZonkerMessage is collection of errors that occur when zonking, + i.e. filling in metavariables with their final values. + + See 'ZonkerMessage' + -} + TcRnZonkerMessage :: ZonkerMessage -> TcRnMessage + + {-| TcRnTyFamDepsDisabled is an error indicating that a type family injectivity + annotation was used without enabling the extension TypeFamilyDependencies. + + Test cases: + T11381 + -} + TcRnTyFamDepsDisabled :: TcRnMessage + + {-| TcRnAbstractClosedTyFamDecl is an error indicating that an abstract closed + type family was declared in a regular source file, while it is only allowed + in hs-boot files. + + Test cases: + ClosedFam4 + -} + TcRnAbstractClosedTyFamDecl :: TcRnMessage + + {-| TcRnPartialFieldSelector is a warning indicating that a record field + was not defined for all constructors of a data type. + + Test cases: + DRFPartialFields, T7169 + -} + TcRnPartialFieldSelector :: !FieldLabel -- ^ The selector + -> TcRnMessage + + {-| TcRnHasFieldResolvedIncomplete is a warning triggered when a HasField constraint + is resolved for a record field for which a `getField @"field"` application + might not be successful. Currently, this means that the warning is triggered when + the parent data type of that record field does not have that field in all + its constructors. + + Example(s): + data T = T1 | T2 {x :: Bool} + f :: HasField t "x" Bool => t -> Bool + f = getField @"x" + g :: T -> Bool + g = f + + Test cases: + TcIncompleteRecSel + -} + TcRnHasFieldResolvedIncomplete :: !Name -- ^ The selector + -> ![ConLike] -- ^ The partial constructors + -> !Int -- ^ The max number of constructors reported + -> TcRnMessage + + {-| TcRnBadFieldAnnotation is an error/warning group indicating that a + strictness/unpack related data type field annotation is invalid. + -} + TcRnBadFieldAnnotation :: !Int -- ^ The index of the field + -> !DataCon -- ^ The constructor in which the field is defined + -> !BadFieldAnnotationReason -- ^ The error specifics + -> TcRnMessage + + {-| TcRnSuperclassCycle is an error indicating that a class has a superclass + cycle. + + Test cases: + mod40, tcfail027, tcfail213, tcfail216, tcfail217, T9415, T9739 + -} + TcRnSuperclassCycle :: !SuperclassCycle -- ^ The details of the cycle + -> TcRnMessage + + {-| TcRnDefaultSigMismatch is an error indicating that a default method + signature doesn't match the regular method signature. + + Test cases: + T7437, T12918a, T12918b, T12151 + -} + TcRnDefaultSigMismatch :: !Id -- ^ The name of the method + -> !Type -- ^ The type of the default signature + -> TcRnMessage + + {-| TcRnTyFamsDisabled is an error indicating that a type family or instance + was declared while the extension TypeFamilies was disabled. + + Test cases: + TyFamsDisabled + -} + TcRnTyFamsDisabled :: !TyFamsDisabledReason -- ^ The name of the family or instance + -> TcRnMessage + + {-| TcRnBadTyConTelescope is an error caused by an ill-scoped 'TyCon' kind, + due to type variables being out of dependency order. + + Example: + + class C a (b :: Proxy a) (c :: Proxy b) where + type T c a + + Test cases: + BadTelescope{∅,3,4} + T14066{f,g} + T14887 + T15591{b,c} + T15743{c,d} + T15764 + T23252 + + -} + TcRnBadTyConTelescope :: !TyCon -> TcRnMessage + + {-| TcRnTyFamResultDisabled is an error indicating that a result variable + was used on a type family while the extension TypeFamilyDependencies was + disabled. + + Test cases: + T13571, T13571a + -} + TcRnTyFamResultDisabled :: !Name -- ^ The name of the type family + -> !(LHsTyVarBndr () GhcRn) -- ^ Name of the result variable + -> TcRnMessage + + {-| TcRnRoleValidationFailed is an error indicating that a variable was + assigned an invalid role by the inference algorithm. + This is only performed with -dcore-lint. + -} + TcRnRoleValidationFailed :: !Role -- ^ The validated role + -> !RoleValidationFailedReason -- ^ The failure reason + -> TcRnMessage + + {-| TcRnCommonFieldResultTypeMismatch is an error indicating that a sum type + declares the same field name in multiple constructors, but the constructors' + result types differ. + + Test cases: + CommonFieldResultTypeMismatch + -} + TcRnCommonFieldResultTypeMismatch :: !DataCon -- ^ First constructor + -> !DataCon -- ^ Second constructor + -> !FieldLabelString -- ^ Field name + -> TcRnMessage + + {-| TcRnCommonFieldTypeMismatch is an error indicating that a sum type + declares the same field name in multiple constructors, but their types + differ. + + Test cases: + CommonFieldTypeMismatch + -} + TcRnCommonFieldTypeMismatch :: !DataCon -- ^ First constructor + -> !DataCon -- ^ Second constructor + -> !FieldLabelString -- ^ Field name + -> TcRnMessage + + {-| TcRnClassExtensionDisabled is an error indicating that a class + was declared with an extension feature while the extension was disabled. + -} + TcRnClassExtensionDisabled :: !Class -- ^ The class + -> !DisabledClassExtension -- ^ The extension + -> TcRnMessage + + {-| TcRnDataConParentTypeMismatch is an error indicating that a data + constructor was declared with a type that doesn't match its type + constructor (i.e. a GADT result type and its data name). + + Test cases: + T7175, T13300, T14719, T18357, T18357b, gadt11, tcfail155, tcfail176 + -} + TcRnDataConParentTypeMismatch :: !DataCon -- ^ The data constructor + -> !Type -- ^ The parent type + -> TcRnMessage + + {-| TcRnGADTsDisabled is an error indicating that a GADT was declared + while the extension GADTs was disabled. + + Test cases: + ghci057, T9293 + -} + TcRnGADTsDisabled :: !Name -- ^ The name of the GADT + -> TcRnMessage + + {-| TcRnExistentialQuantificationDisabled is an error indicating that + a data constructor was declared with existential features while the + extension ExistentialQuantification was disabled. + + Test cases: + ghci057, T9293, gadtSyntaxFail001, gadtSyntaxFail002, gadtSyntaxFail003, + prog006, rnfail053, T12083a + -} + TcRnExistentialQuantificationDisabled :: !DataCon -- ^ The constructor + -> TcRnMessage + + {-| TcRnGADTDataContext is an error indicating that a GADT was declared with a + data type context. + This error is emitted in the tc, but it is also caught in the renamer. + -} + TcRnGADTDataContext :: !Name -- ^ The data type name + -> TcRnMessage + + {-| TcRnMultipleConForNewtype is an error indicating that a newtype was + declared with multiple constructors. + This error is caught by the parser. + -} + TcRnMultipleConForNewtype :: !Name -- ^ The newtype name + -> !Int -- ^ The number of constructors + -> TcRnMessage + + {-| TcRnKindSignaturesDisabled is an error indicating that a kind signature + was used in a data type declaration while the extension KindSignatures was + disabled. + + Test cases: + T20873c, readFail036 + -} + TcRnKindSignaturesDisabled :: !(Either (HsType GhcPs) (Name, HsType GhcRn)) + -- ^ The data type name + -> TcRnMessage + + {-| TcRnEmptyDataDeclsDisabled is an error indicating that a data type + was declared with no constructors while the extension EmptyDataDecls was + disabled. + + Test cases: + readFail035 + -} + TcRnEmptyDataDeclsDisabled :: !Name -- ^ The data type name + -> TcRnMessage + + {-| TcRnRoleMismatch is an error indicating that the role specified + in an annotation differs from its inferred role. + + Test cases: + T7253, Roles11 + -} + TcRnRoleMismatch :: !Name -- ^ The type variable + -> !Role -- ^ The annotated role + -> !Role -- ^ The inferred role + -> TcRnMessage + + {-| TcRnRoleCountMismatch is an error indicating that the number of + roles in an annotation doesn't match the number of type parameters. + + Test cases: + Roles6 + -} + TcRnRoleCountMismatch :: !Int -- ^ The number of type variables + -> !(LRoleAnnotDecl GhcRn) -- ^ The role annotation + -> TcRnMessage + + {-| TcRnIllegalRoleAnnotation is an error indicating that a role + annotation was attached to a decl that doesn't allow it. + + Test cases: + Roles5 + -} + TcRnIllegalRoleAnnotation :: !(RoleAnnotDecl GhcRn) -- ^ The role annotation + -> TcRnMessage + + {-| TcRnRoleAnnotationsDisabled is an error indicating that a role + annotation was declared while the extension RoleAnnotations was disabled. + + Test cases: + Roles5, TH_Roles1 + -} + TcRnRoleAnnotationsDisabled :: !TyCon -- ^ The annotated type + -> TcRnMessage + + {-| TcRnIncoherentRoles is an error indicating that a role + annotation for a class parameter was declared as not nominal. + + Test cases: + T8773 + -} + TcRnIncoherentRoles :: !TyCon -- ^ The class tycon + -> TcRnMessage + {-| TcRnPrecedenceParsingError is an error caused by attempting to + use operators with the same precedence in one infix expression. + + Example: + eq :: (a ~ b ~ c) :~: () + + Test cases: module/mod61 + parser/should_fail/readFail016 + rename/should_fail/rnfail017 + rename/should_fail/T9077 + typecheck/should_fail/T18252a + -} + TcRnPrecedenceParsingError + :: (OpName, Fixity) -- ^ first operator's name and fixity + -> (OpName, Fixity) -- ^ second operator's name and fixity + -> TcRnMessage + + {-| TcRnPrecedenceParsingError is an error caused by attempting to + use an operator with higher precedence than the operand. + + Example: + k = (-3 **) + where + (**) = const + infixl 7 ** + + Test cases: overloadedrecflds/should_fail/T13132_duplicaterecflds + parser/should_fail/readFail023 + rename/should_fail/rnfail019 + th/TH_unresolvedInfix2 + -} + TcRnSectionPrecedenceError + :: (OpName, Fixity) -- ^ first operator's name and fixity + -> (OpName, Fixity) -- ^ argument operator + -> HsExpr GhcPs -- ^ Section + -> TcRnMessage + + {-| TcRnTypeSynonymCycle is an error indicating that a cycle between type + synonyms has occurred. + + Test cases: + mod27, ghc-e-fail2, bkpfail29 + -} + TcRnTypeSynonymCycle :: !TySynCycleTyCons -- ^ The tycons involved in the cycle + -> TcRnMessage + + {-| TcRnSelfImport is an error indicating that a module contains an + import of itself. + + Test cases: + T9032 + -} + TcRnSelfImport :: !ModuleName -- ^ The module + -> TcRnMessage + + {-| TcRnNoExplicitImportList is a warning indicating that an import + statement did not include an explicit import list. + + Test cases: + T1789, T4489 + -} + TcRnNoExplicitImportList :: !ModuleName -- ^ The imported module + -> TcRnMessage + + {-| TcRnSafeImportsDisabled is an error indicating that an import was + declared using the @safe@ keyword while SafeHaskell wasn't active. + + Test cases: + Mixed01 + -} + TcRnSafeImportsDisabled :: !ModuleName -- ^ The imported module + -> TcRnMessage + + {-| TcRnDeprecatedModule is a warning indicating that an imported module + is annotated with a warning or deprecation pragma. + + Test cases: + DeprU + -} + TcRnDeprecatedModule :: !ModuleName -- ^ The imported module + -> !(WarningTxt GhcRn) -- ^ The pragma data + -> TcRnMessage + + {-| TcRnRedundantSourceImport is a warning indicating that a {-# SOURCE #-} + import was used when there is no import cycle. + + Test cases: + none + -} + TcRnRedundantSourceImport :: !ModuleName -- ^ The imported module + -> TcRnMessage + + {-| TcRnImportLookup is a group of errors about bad imported names. + -} + TcRnImportLookup :: !ImportLookupReason -- ^ Details about the error + -> TcRnMessage + + {-| TcRnUnusedImport is a group of errors about unused imports. + -} + TcRnUnusedImport :: !(ImportDecl GhcRn) -- ^ The import + -> !UnusedImportReason -- ^ Details about the error + -> TcRnMessage + + {-| TcRnDuplicateDecls is an error indicating that the same name was used for + multiple declarations. + + Test cases: + FieldSelectors, overloadedrecfldsfail03, T17965, NFSDuplicate, T9975a, + TDMultiple01, mod19, mod38, mod21, mod66, mod20, TDPunning, mod18, mod22, + TDMultiple02, T4127a, ghci048, T8932, rnfail015, rnfail010, rnfail011, + rnfail013, rnfail002, rnfail003, rn_dup, rnfail009, T7164, rnfail043, + TH_dupdecl, rnfail012 + -} + TcRnDuplicateDecls :: !OccName -- ^ The name of the declarations + -> !(NE.NonEmpty Name) -- ^ The individual declarations + -> TcRnMessage + + {-| TcRnPackageImportsDisabled is an error indicating that an import uses + a package qualifier while the extension PackageImports was disabled. + + Test cases: + PackageImportsDisabled + -} + TcRnPackageImportsDisabled :: TcRnMessage + + {-| TcRnIllegalDataCon is an error indicating that a data constructor was + defined using a lowercase name, or a symbolic name in prefix position. + Mostly caught by PsErrNotADataCon. + + Test cases: + None + -} + TcRnIllegalDataCon :: !RdrName -- ^ The constructor name + -> TcRnMessage + + {-| TcRnNestedForallsContexts is an error indicating that multiple foralls or + contexts are nested/curried where this is not supported, + like @∀ x. ∀ y.@ instead of @∀ x y.@. + + Test cases: + T12087, T14320, T16114, T16394, T16427, T18191, T18240a, T18240b, T18455, T5951 + -} + TcRnNestedForallsContexts :: !NestedForallsContextsIn -> TcRnMessage + + {-| TcRnRedundantRecordWildcard is a warning indicating that a pattern uses + a record wildcard even though all of the record's fields are bound explicitly. + + Test cases: + T15957_Fail + -} + TcRnRedundantRecordWildcard :: TcRnMessage + + {-| TcRnUnusedRecordWildcard is a warning indicating that a pattern uses + a record wildcard while none of the fields bound by it are used. + + Test cases: + T15957_Fail + -} + TcRnUnusedRecordWildcard :: ![Name] -- ^ The names bound by the wildcard + -> TcRnMessage + + {-| TcRnUnusedName is a warning indicating that a defined or imported name + is not used in the module. + + Test cases: + ds053, mc10, overloadedrecfldsfail05, overloadedrecfldsfail06, prog018, + read014, rn040, rn041, rn047, rn063, T13839, T13839a, T13919, T17171b, + T17a, T17b, T17d, T17e, T18470, T1972, t22391, t22391j, T2497, T3371, + T3449, T7145b, T7336, TH_recover_warns, unused_haddock, WarningGroups, + werror + -} + TcRnUnusedName :: !OccName -- ^ The unused name + -> !UnusedNameProv -- ^ The provenance of the name + -> TcRnMessage + + {-| TcRnQualifiedBinder is an error indicating that a qualified name + was used in binding position. + + Test cases: + mod62, rnfail021, rnfail034, rnfail039, rnfail046 + -} + TcRnQualifiedBinder :: !RdrName -- ^ The name used as a binder + -> TcRnMessage + + {-| TcRnTypeApplicationsDisabled is an error indicating that a type + application was used while the extension TypeApplications was disabled. + + Test cases: + T12411, T12446, T15527, T16133, T18251c + -} + TcRnTypeApplicationsDisabled :: !(HsType GhcPs) + -> !TypeOrKind + -> TcRnMessage + + {-| TcRnInvalidRecordField is an error indicating that a record field was + used that doesn't exist in a constructor. + + Test cases: + T13644, T13847, T17469, T8448, T8570, tcfail083, tcfail084 + -} + TcRnInvalidRecordField :: !Name -- ^ The constructor name + -> !FieldLabelString -- ^ The name of the field + -> TcRnMessage + + {-| TcRnTupleTooLarge is an error indicating that the arity of a tuple + exceeds mAX_TUPLE_SIZE. + + Test cases: + T18723a, T18723b, T18723c, T6148a, T6148b, T6148c, T6148d + -} + TcRnTupleTooLarge :: !Int -- ^ The arity of the tuple + -> TcRnMessage + + {-| TcRnCTupleTooLarge is an error indicating that the arity of a constraint + tuple exceeds mAX_CTUPLE_SIZE. + + Test cases: + T10451 + -} + TcRnCTupleTooLarge :: !Int -- ^ The arity of the constraint tuple + -> TcRnMessage + + {-| TcRnIllegalInferredTyVars is an error indicating that some type variables + were quantified as inferred (like @∀ {a}.@) in a place where this is not + allowed, like in an instance declaration. + + Test cases: + ExplicitSpecificity5, ExplicitSpecificity6, ExplicitSpecificity8, + ExplicitSpecificity9 + -} + TcRnIllegalInferredTyVars :: !(NE.NonEmpty (HsTyVarBndr Specificity GhcPs)) + -- ^ The offending type variables + -> TcRnMessage + + {-| TcRnAmbiguousName is an error indicating that an unbound name + might refer to multiple names in scope. + + Test cases: + BootFldReexport, DRFUnused, duplicaterecfldsghci01, GHCiDRF, mod110, + mod151, mod152, mod153, mod164, mod165, NoFieldSelectorsFail, + overloadedrecfldsfail02, overloadedrecfldsfail04, overloadedrecfldsfail11, + overloadedrecfldsfail12, overloadedrecfldsfail13, + overloadedrecfldswasrunnowfail06, rnfail044, T11167_ambig, + T11167_ambiguous_fixity, T13132_duplicaterecflds, T15487, T16745, T17420, + T18999_NoDisambiguateRecordFields, T19397E1, T19397E2, T23010_fail, + tcfail037 + -} + TcRnAmbiguousName :: !GlobalRdrEnv + -> !RdrName -- ^ The name + -> !(NE.NonEmpty GlobalRdrElt) -- ^ The possible matches + -> TcRnMessage + + {-| TcRnBindingNameConflict is an error indicating that multiple local or + top-level bindings have the same name. + + Test cases: + dsrun006, mdofail002, mdofail003, mod23, mod24, qq006, rnfail001, + rnfail004, SimpleFail6, T14114, T16110_Fail1, tcfail038, TH_spliceD1, + T22478b, TyAppPat_NonlinearMultiAppPat, TyAppPat_NonlinearMultiPat, + TyAppPat_NonlinearSinglePat, + -} + TcRnBindingNameConflict :: !RdrName -- ^ The conflicting name + -> !(NE.NonEmpty SrcSpan) + -- ^ The locations of the duplicates + -> TcRnMessage + + {-| TcRnNonCanonicalDefinition is a warning indicating that an instance + defines an implementation for a method that should not be defined in a way + that deviates from its default implementation, for example because it has + been scheduled to be absorbed into another method, like @pure@ making + @return@ obsolete. + + Test cases: + WCompatWarningsOn, WCompatWarningsOff, WCompatWarningsOnOff + -} + TcRnNonCanonicalDefinition :: !NonCanonicalDefinition -- ^ Specifics + -> !(LHsSigType GhcRn) -- ^ The instance type + -> TcRnMessage + {-| TcRnImplicitImportOfPrelude is a warning, controlled by @Wimplicit-prelude@, + that is triggered upon an implicit import of the @Prelude@ module. + + Example: + + {-# OPTIONS_GHC -fwarn-implicit-prelude #-} + module M where {} + + Test case: rn055 + + -} + TcRnImplicitImportOfPrelude :: TcRnMessage + + {-| TcRnMissingMain is an error that occurs when a Main module does + not define a main function (named @main@ by default, but overridable + with the @main-is@ command line flag). + + Example: + + module Main where {} + + Test cases: + T414, T7765, readFail021, rnfail007, T13839b, T17171a, T16453E1, tcfail030, + T19397E3, T19397E4 + + -} + TcRnMissingMain + :: !Bool -- ^ whether the module has an explicit export list + -> !Module + -> !OccName -- ^ the expected name of the main function + -> TcRnMessage + + {-| TcRnGhciUnliftedBind is an error that occurs when a user attempts to + bind an unlifted value in GHCi. + + Example (in GHCi): + + let a = (# 1#, 3# #) + + Test cases: T9140, T19035b + -} + TcRnGhciUnliftedBind :: !Id -> TcRnMessage + + {-| TcRnGhciMonadLookupFail is an error that occurs when the user sets + the GHCi monad, using the GHC API 'setGHCiMonad' function, but GHC + can't find which monad the user is referring to. + + Example: + + import GHC ( setGHCiMonad ) + + ... setGHCiMonad "NoSuchThing" + + Test cases: none + -} + TcRnGhciMonadLookupFail + :: String -- ^ the textual name of the monad requested by the user + -> Maybe [GlobalRdrElt] -- ^ lookup result + -> TcRnMessage + + {-| TcRnMissingRoleAnnotation is a warning that occurs when type declaration + doesn't have a role annotatiosn + + Controlled by flags: + - Wmissing-role-annotations + + Test cases: + T22702 + + -} + TcRnMissingRoleAnnotation :: Name -> [Role] -> TcRnMessage + {-| TcRnPatersonCondFailure is an error that occurs when an instance + declaration fails to conform to the Paterson conditions. Which particular condition + fails depends on the constructor of PatersonCondFailure + See Note [Paterson conditions]. + + Test cases: + T15231, tcfail157, T15316, T19187a, fd-loop, tcfail108, tcfail154, + T15172, tcfail214 + -} + TcRnPatersonCondFailure + :: PatersonCondFailure -- ^ the failed Paterson Condition + -> PatersonCondFailureContext + -> Type -- ^ the LHS + -> Type -- ^ the RHS + -> TcRnMessage + + {-| TcRnImplicitRhsQuantification is a warning that occurs when GHC implicitly + quantifies over a type variable that occurs free on the RHS of the type declaration + that is not mentioned on the LHS + + Example: + + type T = 'Nothing :: Maybe a + + Controlled by flags: + - Wimplicit-rhs-quantification + + Test cases: + T23510a + T23510b + -} + TcRnImplicitRhsQuantification :: LocatedN RdrName -> TcRnMessage + + {-| TcRnIllformedTypePattern is an error raised when the pattern + corresponding to a required type argument (visible forall) + does not have a form that can be interpreted as a type pattern. + + Example: + + vfun :: forall (a :: k) -> () + vfun !x = () + -- ^^ + -- bang-patterns not allowed as type patterns + + Test cases: + T22326_fail_bang_pat + -} + TcRnIllformedTypePattern :: !(Pat GhcRn) -> TcRnMessage + + {-| TcRnIllegalTypePattern is an error raised when a pattern constructed + with the @type@ keyword occurs in a position that does not correspond + to a required type argument (visible forall). + + Example: + + case x of + (type _) -> True -- the (type _) pattern is illegal here + _ -> False + + Test cases: + T22326_fail_ado + T22326_fail_caseof + -} + TcRnIllegalTypePattern :: TcRnMessage + + {-| TcRnIllformedTypeArgument is an error raised when an argument + that specifies a required type argument (instantiates a visible forall) + does not have a form that can be interpreted as a type argument. + + Example: + + vfun :: forall (a :: k) -> () + x = vfun (\_ -> _) + -- ^^^^^^^^^ + -- lambdas not allowed in type arguments + + Test cases: + T22326_fail_lam_arg + -} + TcRnIllformedTypeArgument :: !(LHsExpr GhcRn) -> TcRnMessage + + {- TcRnIllegalTypeExpr is an error raised when an expression constructed with + type syntax (@type@, @->@, @=>@, @forall@) occurs in a position that + doesn't correspond to required type argument (visible forall). + + Examples: + + -- Not a function argument: + xtop1 = type Int + xtop2 = (Int -> Int) + xtop3 = (forall a. a) + xtop4 = ((Show Int, Eq Bool) => Unit) + + -- The function does not expect a type argument: + xarg1 = length (type Int) + xarg2 = show (Int -> Int) + + Test cases: + T22326_fail_app + T22326_fail_top + T24159_type_syntax_tc_fail + -} + TcRnIllegalTypeExpr :: TypeSyntax -> TcRnMessage + + {-| TcRnInvalidDefaultedTyVar is an error raised when a + defaulting plugin proposes to default a type variable that is + not an unfilled metavariable + + Test cases: + T23832_invalid + -} + TcRnInvalidDefaultedTyVar + :: ![Ct] -- ^ The constraints passed to the plugin + -> [(TcTyVar, Type)] -- ^ The plugin-proposed type variable defaults + -> NE.NonEmpty TcTyVar -- ^ The invalid type variables of the proposal + -> TcRnMessage + + {-| TcRnNamespacedWarningPragmaWithoutFlag is an error that occurs when + a namespace specifier is used in {-# WARNING ... #-} or {-# DEPRECATED ... #-} + pragmas without the -XExplicitNamespaces extension enabled + + Example: + + {-# LANGUAGE NoExplicitNamespaces #-} + f = id + {-# WARNING data f "some warning message" #-} + + Test cases: + T24396c + -} + TcRnNamespacedWarningPragmaWithoutFlag :: WarnDecl GhcPs -> TcRnMessage + + {-| TcRnIllegalInvisibleTypePattern is an error raised when an invisible + type pattern, i.e. a pattern of the form `@p`, is rejected. + + Example for InvisPatWithoutFlag: + + {-# LANGUAGE NoTypeAbstractions #-} + id :: a -> a + id @t x = x + + Examples for InvisPatNoForall: + + f :: Int + f @t = 5 + + g :: [a -> a] + g = [\ @t x -> x :: t] + + Examples for InvisPatMisplaced: + + f (smth, $(invisP (varT (newName "blah")))) = ... + + g = do + $(invisP (varT (newName "blah"))) <- aciton1 + ... + + Test cases: + T17694b -- InvisPatWithoutFlag + T17694c -- InvisPatNoForall + T17594d -- InvisPatNoForall + T24557a -- InvisPatMisplaced + T24557b -- InvisPatMisplaced + T24557c -- InvisPatMisplaced + T24557d -- InvisPatMisplaced + -} + TcRnIllegalInvisibleTypePattern + :: !(HsTyPat GhcRn) -- the rejected type pattern + -> !BadInvisPatReason -- the reason for rejection + -> TcRnMessage + + {-| TcRnNamespacedFixitySigWithoutFlag is an error that occurs when + a namespace specifier is used in fixity signatures + without the -XExplicitNamespaces extension enabled + + Example: + + {-# LANGUAGE NoExplicitNamespaces #-} + f = const + infixl 7 data `f` + + Test cases: + T14032c + -} + TcRnNamespacedFixitySigWithoutFlag :: FixitySig GhcPs -> TcRnMessage + + {-| TcRnDefaultedExceptionContext is a warning that is triggered when the + backward-compatibility logic solving for implicit ExceptionContext + constraints fires. + + Test cases: DefaultExceptionContext + -} + TcRnDefaultedExceptionContext :: CtLoc -> TcRnMessage + + {-| TcRnOutOfArityTyVar is an error raised when the arity of a type synonym + (as determined by the SAKS and the LHS) is insufficiently high to + accommodate an implicit binding for a free variable that occurs in the + outermost kind signature on the RHS of the said type synonym. + + Example: + + type SynBad :: forall k. k -> Type + type SynBad = Proxy :: j -> Type + + Test cases: + T24770a + -} + TcRnOutOfArityTyVar + :: Name -- ^ Type synonym's name + -> Name -- ^ Type variable's name + -> TcRnMessage + + {- TcRnUnexpectedTypeSyntaxInTerms is an error that occurs + when type syntax is used in terms without -XRequiredTypeArguments + extension enabled + + Examples: + + idVis (forall a. forall b -> (a ~ Int, b ~ Bool) => a -> b) + + Test cases: T24159_type_syntax_rn_fail + -} + TcRnUnexpectedTypeSyntaxInTerms :: TypeSyntax -> TcRnMessage + deriving Generic + +---- + +data ZonkerMessage where + {-| ZonkerCannotDefaultConcrete is an error occurring when a concrete + type variable cannot be defaulted. + + Test cases: + T23153 + -} + ZonkerCannotDefaultConcrete + :: !FixedRuntimeRepOrigin + -> ZonkerMessage + + deriving Generic + +---- + +-- | Things forbidden in @type data@ declarations. +-- See Note [Type data declarations] +data TypeDataForbids + = TypeDataForbidsDatatypeContexts + | TypeDataForbidsLabelledFields + | TypeDataForbidsStrictnessAnnotations + | TypeDataForbidsDerivingClauses + deriving Generic + +instance Outputable TypeDataForbids where + ppr TypeDataForbidsDatatypeContexts = text "Data type contexts" + ppr TypeDataForbidsLabelledFields = text "Labelled fields" + ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags" + ppr TypeDataForbidsDerivingClauses = text "Deriving clauses" + +-- | Specifies which back ends can handle a requested foreign import or export +type ExpectedBackends = [Backend] + +-- | Specifies which calling convention is unsupported on the current platform +data UnsupportedCallConvention + = StdCallConvUnsupported + | PrimCallConvUnsupported + | JavaScriptCallConvUnsupported + deriving Eq + +-- | Whether the error pertains to a function argument or a result. +data ArgOrResult + = Arg | Result + +-- | Which parts of a record field are affected by a particular error or warning. +data RecordFieldPart + = RecordFieldDecl !Name + | RecordFieldConstructor !Name + | RecordFieldPattern !Name + | RecordFieldUpdate + +-- | Why did we reject a record update? +data BadRecordUpdateReason + -- | No constructor has all of the required fields. + = NoConstructorHasAllFields + { conflictingFields :: [FieldLabelString] } + + -- | There are several possible parents which have all of the required fields, + -- and we weren't able to disambiguate in any way. + | MultiplePossibleParents + (RecSelParent, RecSelParent, [RecSelParent]) + -- ^ The possible parents (at least 2) + + -- | We used type-directed disambiguation, but this resulted in + -- an invalid parent (the type-directed parent is not among the + -- parents we computed from the field labels alone). + | InvalidTyConParent TyCon (NE.NonEmpty RecSelParent) + + deriving Generic + +-- | Where a shadowed name comes from +data ShadowedNameProvenance + = ShadowedNameProvenanceLocal !SrcLoc + -- ^ The shadowed name is local to the module + | ShadowedNameProvenanceGlobal [GlobalRdrElt] + -- ^ The shadowed name is global, typically imported from elsewhere. + +-- | Information about a resolved name +data ResolvedNameInfo + = ResolvedNameInfo ![GlobalRdrElt] !RdrName !Name + +instance Outputable ResolvedNameInfo where + ppr (ResolvedNameInfo _ rdr name) = ppr (WithUserRdr rdr name) + +pprResolvedNameProvenance :: ResolvedNameInfo -> SDoc +pprResolvedNameProvenance (ResolvedNameInfo gres _ name) + | gre:_ <- gres = pprNameProvenance gre + | otherwise = text "bound at" <+> ppr (getSrcLoc name) + +-- | In what context did we require a type to have a fixed runtime representation? +-- +-- Used by 'GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep' for throwing +-- representation polymorphism errors when validity checking. +-- +-- See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete +data FixedRuntimeRepProvenance + -- | Data constructor fields must have a fixed runtime representation. + -- + -- Tests: T11734, T18534. + = FixedRuntimeRepDataConField + + -- | Pattern synonym signature arguments must have a fixed runtime representation. + -- + -- Test: RepPolyPatSynArg. + | FixedRuntimeRepPatSynSigArg + + -- | Pattern synonym signature scrutinee must have a fixed runtime representation. + -- + -- Test: RepPolyPatSynRes. + | FixedRuntimeRepPatSynSigRes + +pprFixedRuntimeRepProvenance :: FixedRuntimeRepProvenance -> SDoc +pprFixedRuntimeRepProvenance FixedRuntimeRepDataConField = text "data constructor field" +pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigArg = text "pattern synonym argument" +pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigRes = text "pattern synonym scrutinee" + +-- | Why the particular illegal newtype error arose together with more +-- information, if any. +data IllegalNewtypeReason + = DoesNotHaveSingleField !Int + | IsNonLinear + | IsGADT + | HasConstructorContext + | HasExistentialTyVar + | HasStrictnessAnnotation + deriving Generic + +-- | Why the particular injectivity error arose together with more information, +-- if any. +data InjectivityErrReason + = InjErrRhsBareTyVar [Type] + | InjErrRhsCannotBeATypeFam + | InjErrRhsOverlap + | InjErrCannotInferFromRhs !TyVarSet !HasKinds !SuggestUndecidableInstances + +data HasKinds + = YesHasKinds + | NoHasKinds + deriving (Show, Eq) + +hasKinds :: Bool -> HasKinds +hasKinds True = YesHasKinds +hasKinds False = NoHasKinds + +data SuggestUndecidableInstances + = YesSuggestUndecidableInstaces + | NoSuggestUndecidableInstaces + deriving (Show, Eq) + +suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances +suggestUndecidableInstances True = YesSuggestUndecidableInstaces +suggestUndecidableInstances False = NoSuggestUndecidableInstaces + +data SuggestUnliftedTypes + = SuggestUnliftedNewtypes + | SuggestUnliftedDatatypes + +-- | 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 + +ppDataSort :: DataSort -> SDoc +ppDataSort data_sort = text $ + case data_sort of + DataDeclSort DataType -> "Data type" + DataDeclSort NewType -> "Newtype" + DataInstanceSort DataType -> "Data instance" + DataInstanceSort NewType -> "Newtype instance" + DataFamilySort -> "Data family" + +-- | 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 + +-- | A data type to describe why a variable is not closed. +-- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr +data NotClosedReason = NotLetBoundReason + | NotTypeClosed VarSet + | NotClosed Name NotClosedReason + +data SuggestPartialTypeSignatures + = YesSuggestPartialTypeSignatures + | NoSuggestPartialTypeSignatures + deriving (Show, Eq) + +suggestPartialTypeSignatures :: Bool -> SuggestPartialTypeSignatures +suggestPartialTypeSignatures True = YesSuggestPartialTypeSignatures +suggestPartialTypeSignatures False = NoSuggestPartialTypeSignatures + +data UsingGeneralizedNewtypeDeriving + = YesGeneralizedNewtypeDeriving + | NoGeneralizedNewtypeDeriving + deriving Eq + +usingGeneralizedNewtypeDeriving :: Bool -> UsingGeneralizedNewtypeDeriving +usingGeneralizedNewtypeDeriving True = YesGeneralizedNewtypeDeriving +usingGeneralizedNewtypeDeriving False = NoGeneralizedNewtypeDeriving + +data DeriveAnyClassEnabled + = YesDeriveAnyClassEnabled + | NoDeriveAnyClassEnabled + deriving Eq + +deriveAnyClassEnabled :: Bool -> DeriveAnyClassEnabled +deriveAnyClassEnabled True = YesDeriveAnyClassEnabled +deriveAnyClassEnabled False = NoDeriveAnyClassEnabled + +-- | Why a particular typeclass instance couldn't be derived. +data DeriveInstanceErrReason + = + -- | The typeclass instance is not well-kinded. + DerivErrNotWellKinded !TyCon + -- ^ The type constructor that occurs in + -- the typeclass instance declaration. + !Kind + -- ^ The typeclass kind. + !Int + -- ^ The number of typeclass arguments that GHC + -- kept. See Note [tc_args and tycon arity] in + -- GHC.Tc.Deriv. + -- | Generic instances can only be derived using the stock strategy + -- in Safe Haskell. + | DerivErrSafeHaskellGenericInst + | DerivErrDerivingViaWrongKind !Kind !Type !Kind + | DerivErrNoEtaReduce !Type + -- ^ The instance type + -- | We cannot derive instances in boot files + | DerivErrBootFileFound + | DerivErrDataConsNotAllInScope !TyCon + -- | We cannot use GND on non-newtype types + | DerivErrGNDUsedOnData + -- | We cannot derive instances of nullary classes + | DerivErrNullaryClasses + -- | Last arg must be newtype or data application + | DerivErrLastArgMustBeApp + | DerivErrNoFamilyInstance !TyCon [Type] + | DerivErrNotStockDeriveable !DeriveAnyClassEnabled + | DerivErrHasAssociatedDatatypes !HasAssociatedDataFamInsts + !AssociatedTyLastVarInKind + !AssociatedTyNotParamOverLastTyVar + | DerivErrNewtypeNonDeriveableClass + | DerivErrCannotEtaReduceEnough !Bool -- Is eta-reduction OK? + | DerivErrOnlyAnyClassDeriveable !TyCon + -- ^ Type constructor for which the instance + -- is requested + !DeriveAnyClassEnabled + -- ^ Whether or not -XDeriveAnyClass is enabled + -- already. + -- | Stock deriving won't work, but perhaps DeriveAnyClass will. + | DerivErrNotDeriveable !DeriveAnyClassEnabled + -- | The given 'PredType' is not a class. + | DerivErrNotAClass !PredType + -- | The given (representation of the) 'TyCon' has no + -- data constructors. + | DerivErrNoConstructors !TyCon + | DerivErrLangExtRequired !LangExt.Extension + -- | GHC simply doesn't how to how derive the input 'Class' for the given + -- 'Type'. + | DerivErrDunnoHowToDeriveForType !Type + -- | The given 'TyCon' must be an enumeration. + -- See Note [Enumeration types] in GHC.Core.TyCon + | DerivErrMustBeEnumType !TyCon + -- | The given 'TyCon' must have /precisely/ one constructor. + | DerivErrMustHaveExactlyOneConstructor !TyCon + -- | The given data type must have some parameters. + | DerivErrMustHaveSomeParameters !TyCon + -- | The given data type must not have a class context. + | DerivErrMustNotHaveClassContext !TyCon !ThetaType + -- | We couldn't derive an instance for a particular data constructor + -- for a variety of reasons. + | DerivErrBadConstructor !(Maybe HasWildcard) [DeriveInstanceBadConstructor] + -- | We couldn't derive a 'Generic' instance for the given type for a + -- variety of reasons + | DerivErrGenerics [DeriveGenericsErrReason] + -- | We couldn't derive an instance either because the type was not an + -- enum type or because it did have more than one constructor. + | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason + deriving Generic + +data DeriveInstanceBadConstructor + = + -- | The given 'DataCon' must be truly polymorphic in the + -- last argument of the data type. + DerivErrBadConExistential !DataCon + -- | The given 'DataCon' must not use the type variable in a function argument" + | DerivErrBadConCovariant !DataCon + -- | The given 'DataCon' must not contain function types + | DerivErrBadConFunTypes !DataCon + -- | The given 'DataCon' must use the type variable only + -- as the last argument of a data type + | DerivErrBadConWrongArg !DataCon + -- | The given 'DataCon' is a GADT so we cannot directly + -- derive an istance for it. + | DerivErrBadConIsGADT !DataCon + -- | The given 'DataCon' has existentials type vars in its type. + | DerivErrBadConHasExistentials !DataCon + -- | The given 'DataCon' has constraints in its type. + | DerivErrBadConHasConstraints !DataCon + -- | The given 'DataCon' has a higher-rank type. + | DerivErrBadConHasHigherRankType !DataCon + +data DeriveGenericsErrReason + = -- | The type must not have some datatype context. + DerivErrGenericsMustNotHaveDatatypeContext !TyCon + -- | The data constructor must not have exotic unlifted + -- or polymorphic arguments. + | DerivErrGenericsMustNotHaveExoticArgs !DataCon + -- | The data constructor must be a vanilla constructor. + | DerivErrGenericsMustBeVanillaDataCon !DataCon + -- | The type must have some type parameters. + -- check (d) from Note [Requirements for deriving Generic and Rep] + -- in GHC.Tc.Deriv.Generics. + | DerivErrGenericsMustHaveSomeTypeParams !TyCon + -- | The data constructor must not have existential arguments. + | DerivErrGenericsMustNotHaveExistentials !DataCon + -- | The derivation applies a type to an argument involving + -- the last parameter but the applied type is not of kind * -> *. + | DerivErrGenericsWrongArgKind !DataCon + +data HasWildcard + = YesHasWildcard + | NoHasWildcard + deriving Eq + +hasWildcard :: Bool -> HasWildcard +hasWildcard True = YesHasWildcard +hasWildcard False = NoHasWildcard + +-- | A context in which we don't allow anonymous wildcards. +data BadAnonWildcardContext + = WildcardNotLastInConstraint + | ExtraConstraintWildcardNotAllowed + SoleExtraConstraintWildcardAllowed + | WildcardsNotAllowedAtAll + + -- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type + | WildcardBndrInForallTelescope + | WildcardBndrInTyFamResultVar + +-- | Whether a sole extra-constraint wildcard is allowed, +-- e.g. @_ => ..@ as opposed to @( .., _ ) => ..@. +data SoleExtraConstraintWildcardAllowed + = SoleExtraConstraintWildcardNotAllowed + | SoleExtraConstraintWildcardAllowed + +-- | Why is a class instance head invalid? +data IllegalInstanceHeadReason + -- | An instance for an abstract class from an hs-boot or Backpack + -- hsig file. + -- + -- Example: + -- + -- -- A.hs-boot + -- module A where + -- class C a + -- + -- -- B.hs + -- module B where + -- import {-# SOURCE #-} A + -- instance C Int where + -- + -- -- A.hs + -- module A where + -- import B + -- class C a where + -- f :: a + -- + -- Test cases: typecheck/should_fail/T13068 + = InstHeadAbstractClass !(WithUserRdr Name) -- ^ name of the abstract 'Class' + -- | An instance whose head is not a class. + -- + -- Examples(s): + -- + -- instance c + -- + -- instance 42 + -- + -- instance !Show D + -- + -- type C1 a = (Show (a -> Bool)) + -- instance C1 Int where + -- + -- Test cases: typecheck/rename/T5513 + -- typecheck/rename/T16385 + -- parser/should_fail/T3811c + -- rename/should_fail/T18240a + -- polykinds/T13267 + -- deriving/should_fail/T23522 + | InstHeadNonClassHead InstHeadNonClassHead + + -- | Instance head was headed by a type synonym. + -- + -- Example: + -- type MyInt = Int + -- class C a where {..} + -- instance C MyInt where {..} + -- + -- Test cases: drvfail015, mod42, TidyClassKinds, tcfail139 + | InstHeadTySynArgs + -- | Instance head was not of the form @T a1 ... an@, + -- where @a1, ..., an@ are all type variables or literals. + -- + -- Example: + -- + -- instance Num [Int] where {..} + -- + -- Test cases: mod41, mod42, tcfail044, tcfail047. + | InstHeadNonTyVarArgs + -- | Multi-param instance without -XMultiParamTypeClasses. + -- + -- Example: + -- + -- instance C a b where {..} + -- + -- Test case: IllegalMultiParamInstance + | InstHeadMultiParam + deriving Generic + + +-- | What was at the head of an instance head, when we expected a class? +data InstHeadNonClassHead + -- | A 'TyCon' that isn't a class was at the head + = InstNonClassTyCon (WithUserRdr Name) (TyConFlavour Name) + -- | Something else than a 'TyCon' was at the head + | InstNonTyCon + +-- | Why is a (type or data) family instance invalid? +data IllegalFamilyInstanceReason + {-| A top-level family instance for a 'TyCon' that isn't a family 'TyCon'. + + Example: + + data D a = MkD + type instance D Int = Bool + + Test case: indexed-types/should_fail/T3092 + -} + = NotAFamilyTyCon + !TypeOrData -- ^ was this a 'type' or a 'data' instance? + !TyCon + {-| A top-level (open) type family instance for a closed type family. + + Test cases: + indexed-types/should_fail/Overlap7 + indexed-types/should_fail/Overlap3 + -} + | NotAnOpenFamilyTyCon !TyCon + + {-| A family instance was declared for a family of a different kind, + e.g. a data instance for a type family 'TyCon'. + + Test cases: + T9896, SimpleFail3a + -} + | FamilyCategoryMismatch !TyCon -- ^ The family tycon + + + {-| A family instance was declared with a different number of arguments + than expected. + See Note [Oversaturated type family equations] in "GHC.Tc.Validity". + + Test cases: + TyFamArity1, TyFamArity2, T11136, Overlap4, AssocTyDef05, AssocTyDef06, + T14110 + -} + | FamilyArityMismatch !TyCon -- ^ The family tycon + !Arity -- ^ The right number of parameters + + {-| A closed type family equation used a different name than the parent family. + + Example: + + type family F a where + G Int = Bool + + Test cases: + Overlap5, T15362, T16002, T20260, T11623 + -} + | TyFamNameMismatch !Name -- ^ The family name + !Name -- ^ The name used in the equation + + + -- | There are out-of-scope type variables in the right-hand side + -- of an associated type or data family instance. + -- + -- Example: + -- + -- instance forall a. C Int where + -- data instance D Int = MkD1 a + -- + -- Test cases: indexed-types/should_fail/T5515, polykinds/T9574, rename/should_fail/T18021 + | FamInstRHSOutOfScopeTyVars + !(Maybe (TyCon, [Type], TyVarSet)) + -- ^ family 'TyCon', arguments, and set of "dodgy" type variables + -- See Note [Dodgy binding sites in type family instances] + -- in GHC.Tc.Validity + !(NE.NonEmpty Name) -- ^ the out-of-scope type variables + + | FamInstLHSUnusedBoundTyVars + !(NE.NonEmpty InvalidFamInstQTv) -- ^ the unused bound type variables + + | InvalidAssoc !InvalidAssoc + deriving Generic + +-- | A quantified type variable in a type or data family equation that +-- is either not bound in any LHS patterns or not used in the RHS (or both). +data InvalidFamInstQTv + = InvalidFamInstQTv + { ifiqtv :: TcTyVar + , ifiqtv_user_written :: Bool + -- ^ Did the user write this type variable, or was introduced by GHC? + -- For example: with @-XPolyKinds@, in @type instance forall a. F = ()@, + -- we have a user-written @a@ but GHC introduces a kind variable @k@ + -- as well. See #23734. + , ifiqtv_reason :: InvalidFamInstQTvReason + -- ^ For what reason was the quantified type variable invalid? + } + +data InvalidFamInstQTvReason + -- | A dodgy binder, i.e. a variable that syntactically appears in + -- LHS patterns but only in non-injective positions. + -- + -- See Note [Dodgy binding sites in type family instances] + -- in GHC.Tc.Validity. + = InvalidFamInstQTvDodgy + -- | A quantified type variable in a type or data family equation + -- that is not bound in any LHS patterns. + | InvalidFamInstQTvNotBoundInPats + -- | A quantified type variable in a type or data family equation + -- that is not used on the RHS. + | InvalidFamInstQTvNotUsedInRHS + +-- The 'check_tvs' function in 'GHC.Tc.Validity.checkFamPatBinders' +-- uses 'getSrcSpan', so this 'NamedThing' instance is convenient. +instance NamedThing InvalidFamInstQTv where + getName = getName . ifiqtv + +data InvalidAssoc + -- | An invalid associated family instance. + -- + -- See t'InvalidAssocInstance'.Builder + = InvalidAssocInstance !InvalidAssocInstance + -- | An invalid associated family default declaration. + -- + -- See t'InvalidAssocDefault'. + | InvalidAssocDefault !InvalidAssocDefault + deriving Generic + +-- | The reason that an associated family instance was invalid. +data InvalidAssocInstance + -- | A class instance is missing its expected associated type/data instance. + -- + -- Test cases: deriving/should_compile/T14094 + -- indexed-types/should_compile/Simple2 + -- typecheck/should_compile/tc254 + = AssocInstanceMissing !Name + + -- | A top-level instance for an associated family 'TyCon'. + -- + -- Example: + -- + -- class C a where { type T a } + -- instance T Int = Bool + -- + -- Test case: indexed-types/should_fail/SimpleFail7 + | AssocInstanceNotInAClass !TyCon + + -- | An associated type instance is provided for a class that doesn't have + -- that associated type. + -- + -- Examples(s): + -- $(do d <- instanceD (cxt []) (conT ''Eq `appT` conT ''Foo) + -- [tySynInstD $ tySynEqn Nothing (conT ''Rep `appT` conT ''Foo) (conT ''Maybe)] + -- return [d]) + -- ======> + -- instance Eq Foo where + -- type Rep Foo = Maybe + -- + -- Test cases: th/T12387a + | AssocNotInThisClass !Class !TyCon + -- | An associated family instance does not mention any of the parent 'Class' + -- 'TyVar's. + -- + -- Test cases: T2888, T9167, T12867 + | AssocNoClassTyVar !Class !TyCon + + | AssocTyVarsDontMatch + !ForAllTyFlag + !TyCon -- ^ family 'TyCon' + ![Type] -- ^ expected type arguments + ![Type] -- ^ actual type arguments + deriving Generic + + +-- | The reason that an associated family default declaration was invalid. +data InvalidAssocDefault + -- | An associated family default declaration for something that isn't + -- an associated family. + = AssocDefaultNotAssoc !Name -- ^ 'Class' 'Name' + !Name -- ^ 'TyCon' 'Name' + -- | Multiple default declarations were given for an associated + -- family instance. + -- + -- Test cases: none. + | AssocMultipleDefaults !Name + -- | Invalid arguments in an associated family instance default declaration. + -- + -- See t'AssocDefaultBadArgs'. + | AssocDefaultBadArgs !TyCon ![Type] AssocDefaultBadArgs + deriving Generic + +-- | Invalid arguments in an associated family instance declaration. +data AssocDefaultBadArgs + -- | An argument which isn't a type variable in an associated + -- family instance default declaration. + = AssocDefaultNonTyVarArg !(Type, ForAllTyFlag) + -- | Duplicate occurrence of a type variable in an associated + -- family instance default declaration. + | AssocDefaultDuplicateTyVars !(NE.NonEmpty (TyCoVar, ForAllTyFlag)) + deriving Generic + +-- | A type representing whether or not the input type has associated data family instances. +data HasAssociatedDataFamInsts + = YesHasAdfs + | NoHasAdfs + deriving Eq + +hasAssociatedDataFamInsts :: Bool -> HasAssociatedDataFamInsts +hasAssociatedDataFamInsts True = YesHasAdfs +hasAssociatedDataFamInsts False = NoHasAdfs + +-- | If 'YesAssocTyLastVarInKind', the associated type of a typeclass +-- contains the last type variable of the class in a kind, which is not (yet) allowed +-- by GHC. +data AssociatedTyLastVarInKind + = YesAssocTyLastVarInKind !TyCon -- ^ The associated type family of the class + | NoAssocTyLastVarInKind + deriving Eq + +associatedTyLastVarInKind :: Maybe TyCon -> AssociatedTyLastVarInKind +associatedTyLastVarInKind (Just tc) = YesAssocTyLastVarInKind tc +associatedTyLastVarInKind Nothing = NoAssocTyLastVarInKind + +-- | If 'NoAssociatedTyNotParamOverLastTyVar', the associated type of a +-- typeclass is not parameterized over the last type variable of the class +data AssociatedTyNotParamOverLastTyVar + = YesAssociatedTyNotParamOverLastTyVar !TyCon -- ^ The associated type family of the class + | NoAssociatedTyNotParamOverLastTyVar + deriving Eq + +associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLastTyVar +associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc +associatedTyNotParamOverLastTyVar Nothing = NoAssociatedTyNotParamOverLastTyVar + +-- | What kind of thing is missing a type signature? +-- +-- Used for reporting @"missing signature"@ warnings, see +-- 'tcRnMissingSignature'. +data MissingSignature + = MissingTopLevelBindingSig Name Type + | MissingPatSynSig PatSyn + | MissingTyConKindSig + TyCon + Bool -- ^ whether -XCUSKs is enabled + +-- | Is the object we are dealing with exported or not? +-- +-- Used for reporting @"missing signature"@ warnings, see +-- 'TcRnMissingSignature'. +data Exported + = IsNotExported + | IsExported + deriving Eq + +instance Outputable Exported where + ppr IsNotExported = text "IsNotExported" + ppr IsExported = text "IsExported" + +-- | What declarations were not allowed in an hs-boot or hsig file? +data BadBootDecls + = BootBindsPs !(NE.NonEmpty (LHsBindLR GhcRn GhcPs)) + | BootBindsRn !(NE.NonEmpty (LHsBindLR GhcRn GhcRn)) + | BootInstanceSigs !(NE.NonEmpty (LSig GhcRn)) + | BootFamInst !TyCon + | BootSpliceDecls !(NE.NonEmpty (LocatedA (HsUntypedSplice GhcPs))) + | BootForeignDecls !(NE.NonEmpty (LForeignDecl GhcRn)) + | BootDefaultDecls !(NE.NonEmpty (LDefaultDecl GhcRn)) + | BootRuleDecls !(NE.NonEmpty (LRuleDecls GhcRn)) + +-- | A mismatch between an hs-boot or signature file and its implementing module. +data BootMismatch + -- | Something defined or exported by an hs-boot or signature file + -- is missing from the implementing module. + = MissingBootThing !Name !MissingBootThing + + -- | A typeclass instance is declared in the hs-boot file but + -- it is not present in the implementing module. + | MissingBootInstance !DFunId -- ^ the boot instance 'DFunId' + -- NB: we never trigger this for hsig files, as in that case we do + -- a full round of constraint solving, and a missing instance gets reported + -- as an unsolved Wanted constraint with a 'InstProvidedOrigin' 'CtOrigin'. + -- See GHC.Tc.Utils.Backpack.check_inst. + + -- | A mismatch between an hsig file and its implementing module + -- in the 'Name' that a particular re-export refers to. + | BadReexportedBootThing !Name !Name + + -- | A mismatch between the declaration of something in the hs-boot or + -- signature file and its implementation, e.g. a type mismatch or + -- a type family implemented as a class. + | BootMismatch + !TyThing -- ^ boot thing + !TyThing -- ^ real thing + !BootMismatchWhat + deriving Generic + +-- | Something from the hs-boot or signature file is missing from the +-- implementing module. +data MissingBootThing + -- | Something defined in the hs-boot or signature file is not defined in the + -- implementing module. + = MissingBootDefinition + -- | Something exported by the hs-boot or signature file is not exported by the + -- implementing module. + | MissingBootExport + deriving Generic + +missingBootThing :: HsBootOrSig -> Name -> MissingBootThing -> TcRnMessage +missingBootThing src nm thing = + TcRnBootMismatch src (MissingBootThing nm thing) + +-- | A mismatch of two 'TyThing's between an hs-boot or signature file +-- and its implementing module. +data BootMismatchWhat + -- | The 'Id's have different types. + = BootMismatchedIdTypes !Id -- ^ boot 'Id' + !Id -- ^ real 'Id' + -- | Two 'TyCon's aren't compatible. + | BootMismatchedTyCons !TyCon -- ^ boot 'TyCon' + !TyCon -- ^ real 'TyCon' + !(NE.NonEmpty BootTyConMismatch) + deriving Generic + +-- | An error in the implementation of an abstract datatype using +-- a type synonym. +data SynAbstractDataError + -- | The type synony was not nullary. + = SynAbsDataTySynNotNullary + -- | The type synonym RHS contained invalid types, e.g. + -- a type family or a forall. + | SynAbstractDataInvalidRHS !(NE.NonEmpty Type) + +-- | Mismatched implementation of a 'TyCon' in an hs-boot or signature file. +data BootTyConMismatch + -- | The 'TyCon' kinds differ. + = TyConKindMismatch + -- | The 'TyCon' 'Role's aren't compatible. + | TyConRoleMismatch !Bool -- ^ True <=> role subtype check + -- | Two type synonyms have different RHSs. + | TyConSynonymMismatch !Kind !Kind + -- | The two 'TyCon's are of a different flavour, e.g. one is + -- a data family and the other is a type family. + | TyConFlavourMismatch !FamTyConFlav !FamTyConFlav + -- | The equations of a type family don't match. + | TyConAxiomMismatch !(BootListMismatches CoAxBranch BootAxiomBranchMismatch) + -- | The type family injectivity annotations don't match. + | TyConInjectivityMismatch + -- | The 'TyCon's are both datatype 'TyCon's, but they have diferent 'DataCon's. + | TyConMismatchedData !AlgTyConRhs !AlgTyConRhs !BootDataMismatch + -- | The 'TyCon's are both 'Class' 'TyCon's, but the classes don't match. + | TyConMismatchedClasses !Class !Class !BootClassMismatch + -- | The 'TyCon's are something completely different. + | TyConsVeryDifferent + -- | An abstract 'TyCon' is implemented using a type synonym in an invalid + -- manner. See 'SynAbstractDataError'. + | SynAbstractData !SynAbstractDataError + + +-- | Utility datatype to record errors when checking compatibity +-- between two lists of things, e.g. class methods, associated types, +-- type family equations, etc. +data BootListMismatch item err + -- | Different number of items. + = MismatchedLength + -- | The item at the given position in the list differs. + | MismatchedThing !Int !item !item !err + +type BootListMismatches item err = + NE.NonEmpty (BootListMismatch item err) + +data BootAxiomBranchMismatch + -- | The quantified variables in an equation don't match. + -- + -- Example: the quantification of @a@ in + -- + -- @type family F a where { forall a. F a = Maybe a }@ + = MismatchedAxiomBinders + -- | The LHSs of an equation don't match. + | MismatchedAxiomLHS + -- | The RHSs of an equation don't match. + | MismatchedAxiomRHS + +-- | A mismatch in a class, between its declaration in an hs-boot or signature +-- file, and its implementation in a source Haskell file. +data BootClassMismatch + -- | The class methods don't match. + = MismatchedMethods !(BootListMismatches ClassOpItem BootMethodMismatch) + -- | The associated types don't match. + | MismatchedATs !(BootListMismatches ClassATItem BootATMismatch) + -- | The functional dependencies don't match. + | MismatchedFunDeps + -- | The superclasses don't match. + | MismatchedSuperclasses + -- | The @MINIMAL@ pragmas are not compatible. + | MismatchedMinimalPragmas + +-- | A mismatch in a class method, between its declaration in an hs-boot or signature +-- file, and its implementation in a source Haskell file. +data BootMethodMismatch + -- | The class method names are different. + = MismatchedMethodNames + -- | The types of a class method are different. + | MismatchedMethodTypes !Type !Type + -- | The default method types are not compatible. + | MismatchedDefaultMethods !Bool -- ^ True <=> subtype check + +-- | A mismatch in an associated type of a class, between its declaration +-- in an hs-boot or signature file, and its implementation in a source Haskell file. +data BootATMismatch + -- | Two associated types don't match. + = MismatchedTyConAT !BootTyConMismatch + -- | Two associated type defaults don't match. + | MismatchedATDefaultType + +-- | A mismatch in a datatype declaration, between an hs-boot file or signature +-- file and its implementing module. +data BootDataMismatch + -- | A datatype is implemented as a newtype or vice-versa. + = MismatchedNewtypeVsData + -- | The constructors don't match. + | MismatchedConstructors !(BootListMismatches DataCon BootDataConMismatch) + -- | The datatype contexts differ. + | MismatchedDatatypeContexts + +-- | A mismatch in a data constrcutor, between its declaration in an hs-boot +-- file or signature file, and its implementation in a source Haskell module. +data BootDataConMismatch + -- | The 'Name's of the 'DataCon's differ. + = MismatchedDataConNames + -- | The fixities of the 'DataCon's differ. + | MismatchedDataConFixities + -- | The strictness annotations of the 'DataCon's differ. + | MismatchedDataConBangs + -- | The 'DataCon's have different field labels. + | MismatchedDataConFieldLabels + -- | The 'DataCon's have incompatible types. + | MismatchedDataConTypes + +-------------------------------------------------------------------------------- +-- +-- Errors used in GHC.Tc.Errors +-- +-------------------------------------------------------------------------------- + +{- Note [Error report] +~~~~~~~~~~~~~~~~~~~~~~ +The idea is that error msgs are divided into three parts: the main msg, the +context block ("In the second argument of ..."), and the relevant bindings +block, which are displayed in that order, with a mark to divide them. The +the main msg ('report_important') varies depending on the error +in question, but context and relevant bindings are always the same, which +should simplify visual parsing. + +See 'GHC.Tc.Errors.Types.SolverReport' and 'GHC.Tc.Errors.mkErrorReport'. +-} + +-- | A collection of main error messages and supplementary information. +-- +-- In practice, we will: +-- - display the important messages first, +-- - then the error context (e.g. by way of a call to 'GHC.Tc.Errors.mkErrorReport'), +-- - then the supplementary information (e.g. relevant bindings, valid hole fits), +-- - then the hints ("Possible fix: ..."). +-- +-- So this is mostly just a way of making sure that the error context appears +-- early on rather than at the end of the message. +-- +-- See Note [Error report] for details. +data SolverReport + = SolverReport + { sr_important_msg :: SolverReportWithCtxt + , sr_supplementary :: [SupplementaryInfo] + , sr_hints :: [GhcHint] + } + +-- | Additional information to print in an error message, after the +-- important messages and after the error context. +-- +-- See Note [Error report]. +data SupplementaryInfo + = SupplementaryBindings RelevantBindings + | SupplementaryHoleFits ValidHoleFits + | SupplementaryCts (NE.NonEmpty (PredType, RealSrcSpan)) + | SupplementaryImportErrors (NE.NonEmpty ImportError) + +-- | A 'TcSolverReportMsg', together with context (e.g. enclosing implication constraints) +-- that are needed in order to report it. +data SolverReportWithCtxt = + SolverReportWithCtxt + { reportContext :: SolverReportErrCtxt + -- ^ Context for what we wish to report. + -- This can change as we enter implications, so is + -- stored alongside the content. + , reportContent :: TcSolverReportMsg + -- ^ The content of the message to report. + } + deriving Generic + +-- | Context needed when reporting a 'TcSolverReportMsg', such as +-- the enclosing implication constraints or whether we are deferring type errors. +data SolverReportErrCtxt + = CEC { cec_encl :: [Implication] -- ^ Enclosing implications + -- (innermost first) + -- ic_skols and givens are tidied, rest are not + , cec_tidy :: TidyEnv + + , cec_binds :: EvBindsVar -- ^ We make some errors (depending on cec_defer) + -- into warnings, and emit evidence bindings + -- into 'cec_binds' for unsolved constraints + + , cec_defer_type_errors :: DiagnosticReason -- ^ Whether to defer type errors until runtime + + -- We might throw a warning on an error when encountering a hole, + -- depending on the type of hole (expression hole, type hole, out of scope hole). + -- We store the reasons for reporting a diagnostic for each type of hole. + , cec_expr_holes :: DiagnosticReason -- ^ Reason for reporting holes in expressions. + , cec_type_holes :: DiagnosticReason -- ^ Reason for reporting holes in types. + , cec_out_of_scope_holes :: DiagnosticReason -- ^ Reason for reporting out of scope holes. + + , cec_warn_redundant :: Bool -- ^ True <=> -Wredundant-constraints + , cec_expand_syns :: Bool -- ^ True <=> -fprint-expanded-synonyms + + , cec_suppress :: Bool -- ^ True <=> More important errors have occurred, + -- so create bindings if need be, but + -- don't issue any more errors/warnings + -- See Note [Suppressing error messages] + } + +getUserGivens :: SolverReportErrCtxt -> [UserGiven] +-- One item for each enclosing implication +getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics + +---------------------------------------------------------------------------- +-- +-- ErrorItem +-- +---------------------------------------------------------------------------- + +-- | A predicate with its arising location; used to encapsulate a constraint +-- that will give rise to a diagnostic. +data ErrorItem +-- We could perhaps use Ct here (and indeed used to do exactly that), but +-- having a separate type gives to denote errors-in-formation gives us +-- a nice place to do pre-processing, such as calculating ei_suppress. +-- Perhaps some day, an ErrorItem could eventually evolve to contain +-- the error text (or some representation of it), so we can then have all +-- the errors together when deciding which to report. + = EI { ei_pred :: PredType -- report about this + -- The ei_pred field will never be an unboxed equality with + -- a (casted) tyvar on the right; this is guaranteed by the solver + , ei_evdest :: Maybe TcEvDest + -- ^ for Wanteds, where to put the evidence + -- for Givens, Nothing + , ei_flavour :: CtFlavour + , ei_loc :: CtLoc + , ei_m_reason :: Maybe CtIrredReason -- if this ErrorItem was made from a + -- CtIrred, this stores the reason + , ei_suppress :: Bool -- Suppress because of Note [Wanteds rewrite Wanteds] + -- in GHC.Tc.Constraint + } + +instance Outputable ErrorItem where + ppr (EI { ei_pred = pred + , ei_evdest = m_evdest + , ei_flavour = flav + , ei_suppress = supp }) + = pp_supp <+> ppr flav <+> pp_dest m_evdest <+> ppr pred + where + pp_dest Nothing = empty + pp_dest (Just ev) = ppr ev <+> dcolon + + pp_supp = if supp then text "suppress:" else empty + +errorItemOrigin :: ErrorItem -> CtOrigin +errorItemOrigin = ctLocOrigin . ei_loc + +errorItemEqRel :: ErrorItem -> EqRel +errorItemEqRel = predTypeEqRel . ei_pred + +errorItemCtLoc :: ErrorItem -> CtLoc +errorItemCtLoc = ei_loc + +errorItemPred :: ErrorItem -> PredType +errorItemPred = ei_pred + +{- Note [discardProvCtxtGivens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In most situations we call all enclosing implications "useful". There is one +exception, and that is when the constraint that causes the error is from the +"provided" context of a pattern synonym declaration: + + pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a + -- required => provided => type + pattern Pat x <- (Just x, 4) + +When checking the pattern RHS we must check that it does actually bind all +the claimed "provided" constraints; in this case, does the pattern (Just x, 4) +bind the (Show a) constraint. Answer: no! + +But the implication we generate for this will look like + forall a. (Num a, Eq a) => [W] Show a +because when checking the pattern we must make the required +constraints available, since they are needed to match the pattern (in +this case the literal '4' needs (Num a, Eq a)). + +BUT we don't want to suggest adding (Show a) to the "required" constraints +of the pattern synonym, thus: + pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a +It would then typecheck but it's silly. We want the /pattern/ to bind +the alleged "provided" constraints, Show a. + +So we suppress that Implication in discardProvCtxtGivens. It's +painfully ad-hoc but the truth is that adding it to the "required" +constraints would work. Suppressing it solves two problems. First, +we never tell the user that we could not deduce a "provided" +constraint from the "required" context. Second, we never give a +possible fix that suggests to add a "provided" constraint to the +"required" context. + +For example, without this distinction the above code gives a bad error +message (showing both problems): + + error: Could not deduce (Show a) ... from the context: (Eq a) + ... Possible fix: add (Show a) to the context of + the signature for pattern synonym `Pat' ... +-} + + +discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] +discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] + | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig + = filterOut (discard name) givens + | otherwise + = givens + where + discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' + discard _ _ = False + + +-- | An error reported after constraint solving. +-- This is usually, some sort of unsolved constraint error, +-- but we try to be specific about the precise problem we encountered. +data TcSolverReportMsg + -- | Quantified variables appear out of dependency order. + -- + -- Example: + -- + -- forall (a :: k) k. ... + -- + -- Test cases: BadTelescope2, T16418, T16247, T16726, T18451. + = BadTelescope TyVarBndrs [TyCoVar] + + -- | We came across a custom type error and we have decided to report it. + -- + -- Example: + -- + -- type family F a where + -- F a = TypeError (Text "error") + -- + -- err :: F () + -- err = () + -- + -- Test cases: CustomTypeErrors0{1,2,3,4,5}, T12104. + | UserTypeError ErrorMsgType -- ^ the message to report + + -- | Report a Wanted constraint of the form "Unsatisfiable msg". + | UnsatisfiableError ErrorMsgType -- ^ the message to report + + -- | We want to report an out of scope variable or a typed hole. + -- See 'HoleError'. + | ReportHoleError Hole HoleError + + -- | Cannot unify a variable, because of a type mismatch. + | CannotUnifyVariable + { mismatchMsg :: MismatchMsg + , cannotUnifyReason :: CannotUnifyVariableReason } + + -- | A mismatch between two types. + | Mismatch + { mismatchMsg :: MismatchMsg + , mismatchTyVarInfo :: Maybe TyVarInfo + , mismatchAmbiguityInfo :: [AmbiguityInfo] + , mismatchCoercibleInfo :: Maybe CoercibleMsg } + + -- | A violation of the representation-polymorphism invariants. + -- + -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information. + | FixedRuntimeRepError [FixedRuntimeRepErrorInfo] + + -- | Something was not applied to sufficiently many arguments. + -- + -- Example: + -- + -- instance Eq Maybe where {..} + -- + -- Test case: T11563. + | ExpectingMoreArguments Int TypedThing + + -- | Trying to use an unbound implicit parameter. + -- + -- Example: + -- + -- foo :: Int + -- foo = ?param + -- + -- Test case: tcfail130. + | UnboundImplicitParams + (NE.NonEmpty ErrorItem) + + -- | A constraint couldn't be solved because it contains + -- ambiguous type variables. + -- + -- Example: + -- + -- class C a b where + -- f :: (a,b) + -- + -- x = fst f + -- + -- + -- Test case: T4921. + | AmbiguityPreventsSolvingCt + ErrorItem -- ^ always a class constraint + ([TyVar], [TyVar]) -- ^ ambiguous kind and type variables, respectively + + -- | Could not solve a constraint; there were several unifying candidate instances + -- but no matching instances. This is used to report as much useful information + -- as possible about why we couldn't choose any instance, e.g. because of + -- ambiguous type variables. + | CannotResolveInstance + { cannotResolve_item :: ErrorItem + , cannotResolve_unifiers :: [ClsInst] + , cannotResolve_candidates :: [ClsInst] + , cannotResolve_relBinds :: RelevantBindings + } + + -- | Could not solve a constraint using available instances + -- because the instances overlap. + -- + -- Test cases: tcfail118, tcfail121, tcfail218. + | OverlappingInstances + { overlappingInstances_item :: ErrorItem + , overlappingInstances_matches :: NE.NonEmpty ClsInst + , overlappingInstances_unifiers :: [ClsInst] } + + -- | Could not solve a constraint from instances because + -- instances declared in a Safe module cannot overlap instances + -- from other modules (with -XSafeHaskell). + -- + -- Test cases: SH_Overlap{1,2,5,6,7,11}. + | UnsafeOverlap + { unsafeOverlap_item :: ErrorItem + , unsafeOverlap_match :: ClsInst + , unsafeOverlapped :: NE.NonEmpty ClsInst } + + | MultiplicityCoercionsNotSupported + + deriving Generic + +data MismatchMsg + = -- | Couldn't unify two types or kinds. + -- + -- Example: + -- + -- 3 + 3# -- can't match a lifted type with an unlifted type + -- + -- Test cases: T1396, T8263, ... + BasicMismatch + { mismatch_ea :: MismatchEA -- ^ Should this be phrased in terms of expected vs actual? + , mismatch_item :: ErrorItem -- ^ The constraint in which the mismatch originated. + , mismatch_ty1 :: Type -- ^ First type (the expected type if if mismatch_ea is True) + , mismatch_ty2 :: Type -- ^ Second type (the actual type if mismatch_ea is True) + , mismatch_whenMatching :: Maybe WhenMatching + , mismatch_mb_same_occ :: Maybe SameOccInfo + } + + -- | A mismatch between two types, which arose from a type equality. + -- + -- Test cases: T1470, tcfail212, T2994, T7609. + | TypeEqMismatch + { teq_mismatch_item :: ErrorItem + , teq_mismatch_ty1 :: Type + , teq_mismatch_ty2 :: Type + , teq_mismatch_expected :: Type -- ^ The overall expected type + , teq_mismatch_actual :: Type -- ^ The overall actual type + , teq_mismatch_what :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of? + , teq_mb_same_occ :: Maybe SameOccInfo + } + -- TODO: combine with 'BasicMismatch'. + + -- | Couldn't solve some Wanted constraints using the Givens. + -- Used for messages such as @"No instance for ..."@ and + -- @"Could not deduce ... from"@. + | CouldNotDeduce + { cnd_user_givens :: [Implication] + -- | The Wanted constraints we couldn't solve. + -- + -- N.B.: the 'ErrorItem' at the head of the list has been tidied, + -- perhaps not the others. + , cnd_wanted :: NE.NonEmpty ErrorItem + + -- | Some additional info consumed by 'mk_supplementary_ea_msg'. + , cnd_extra :: Maybe CND_Extra + } + deriving Generic + +-- | Construct a basic mismatch message between two types. +-- +-- See 'pprMismatchMsg' for how such a message is displayed to users. +mkBasicMismatchMsg :: MismatchEA -> ErrorItem -> Type -> Type -> MismatchMsg +mkBasicMismatchMsg ea item ty1 ty2 + = BasicMismatch + { mismatch_ea = ea + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 + , mismatch_whenMatching = Nothing + , mismatch_mb_same_occ = Nothing + } + +-- | Whether to use expected/actual in a type mismatch message. +data MismatchEA + -- | Don't use expected/actual. + = NoEA + -- | Use expected/actual. + | EA + { mismatch_mbEA :: Maybe ExpectedActualInfo + -- ^ Whether to also mention type synonym expansion. + } + +data CannotUnifyVariableReason + = -- | A type equality between a type variable and a polytype. + -- + -- Test cases: T12427a, T2846b, T10194, ... + CannotUnifyWithPolytype ErrorItem TyVar Type (Maybe TyVarInfo) + + -- | An occurs check. + | OccursCheck + { occursCheckInterestingTyVars :: [TyVar] + , occursCheckAmbiguityInfos :: [AmbiguityInfo] } + + -- | A skolem type variable escapes its scope. + -- + -- Example: + -- + -- data Ex where { MkEx :: a -> MkEx } + -- foo (MkEx x) = x + -- + -- Test cases: TypeSkolEscape, T11142. + | SkolemEscape ErrorItem Implication [TyVar] + + -- | Can't unify the type variable with the other type + -- due to the kind of type variable it is. + -- + -- For example, trying to unify a 'SkolemTv' with the + -- type Int, or with a 'TyVarTv'. + | DifferentTyVars TyVarInfo + | RepresentationalEq TyVarInfo (Maybe CoercibleMsg) + deriving Generic + +-- | Report a mismatch error without any extra +-- information. +mkPlainMismatchMsg :: MismatchMsg -> TcSolverReportMsg +mkPlainMismatchMsg msg + = Mismatch + { mismatchMsg = msg + , mismatchTyVarInfo = Nothing + , mismatchAmbiguityInfo = [] + , mismatchCoercibleInfo = Nothing } + +-- | Additional information to be given in a 'CouldNotDeduce' message, +-- which is then passed on to 'mk_supplementary_ea_msg'. +data CND_Extra = CND_Extra TypeOrKind Type Type + +-- | A cue to print out information about type variables, +-- e.g. where they were bound, when there is a mismatch @tv1 ~ ty2@. +data TyVarInfo = + TyVarInfo { thisTyVar :: TyVar + , thisTyVarIsUntouchable :: Maybe Implication + , otherTy :: Maybe TyVar } + +-- | Add some information to disambiguate errors in which +-- two 'Names' would otherwise appear to be identical. +-- +-- See Note [Disambiguating (X ~ X) errors]. +data SameOccInfo + = SameOcc + { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package. + , sameOcc_lhs :: Name + , sameOcc_rhs :: Name } + +-- | Add some information about ambiguity +data AmbiguityInfo + + -- | Some type variables remained ambiguous: print them to the user. + = Ambiguity + { lead_with_ambig_msg :: Bool -- ^ True <=> start the message with "Ambiguous type variable ..." + -- False <=> create a message of the form "The type variable is ambiguous." + , ambig_tyvars :: ([TyVar], [TyVar]) -- ^ Ambiguous kind and type variables, respectively. + -- Guaranteed to not both be empty. + } + + -- | Remind the user that a particular type family is not injective. + | NonInjectiveTyFam TyCon + +-- | Expected/actual information. +data ExpectedActualInfo + -- | Display the expected and actual types. + = ExpectedActual + { ea_expected, ea_actual :: Type } + + -- | Display the expected and actual types, after expanding type synonyms. + | ExpectedActualAfterTySynExpansion + { ea_expanded_expected, ea_expanded_actual :: Type } + +-- | Explain how a kind equality originated. +data WhenMatching + + = WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind) + deriving Generic + +data BadImportKind + -- | Module does not export... + = BadImportNotExported [GhcHint] -- ^ suggestions for what might have been meant + -- | Missing @type@ keyword when importing a type. + -- e.g. `import TypeLits( (+) )`, where TypeLits exports a /type/ (+), not a /term/ (+) + -- Then we want to suggest using `import TypeLits( type (+) )` + | BadImportAvailTyCon + -- | Trying to import a data constructor directly, e.g. + -- @import Data.Maybe (Just)@ instead of @import Data.Maybe (Maybe(Just))@ + | BadImportAvailDataCon OccName + -- | The parent does not export the given children. + | BadImportNotExportedSubordinates !GlobalRdrElt (NonEmpty FastString) + -- | Incorrect @type@ keyword when importing subordinates that aren't types. + | BadImportNonTypeSubordinates !GlobalRdrElt (NonEmpty GlobalRdrElt) + -- | Incorrect @data@ keyword when importing something which isn't a term. + | BadImportNonDataSubordinates !GlobalRdrElt (NonEmpty GlobalRdrElt) + -- | Incorrect @type@ keyword when importing something which isn't a type. + | BadImportAvailVar + deriving Generic + +{- Note [Reasons for BadImportAvailTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BadImportAvailTyCon means a name is available in the TcCls namespace +but name resolution could not use it. Possible reasons for that: + +- Case (TyOp) `import M ((#))` or `import M (data (#))` + The user tried to import a type operator without using the `type` keyword, + or using a different keyword. Suggested fix: add 'type'. + +- Case (DataKw) `import M (data T)` + The user tried to import a non-operator type constructor, but mistakenly + used the `data` keyword, which restricted the lookup to the value namespace. + Suggested fix: remove 'data'; no need to add 'type' for non-operators. + +- Case (PatternKw) `import M (pattern T)` + Same as the (DataKw) case, mutatis mutandis. + +Any other case would not have resulted in BadImportAvailTyCon. +-} + +-- | Describes what category of subordinate we are dealing with, e.g. +-- a method of a class, a field of a record, etc. +data Subordinate + = MethodOfClass -- ^ A method of a class + | AssociatedTypeOfClass -- ^ An associated type of a class + | FieldOfConstructor -- ^ A field of a constructor + + deriving Generic + +pprSubordinate :: Name -> Subordinate -> SDoc +pprSubordinate parent_nm = \case + MethodOfClass -> + text "method of class" <+> quotes (ppr parent_nm) + AssociatedTypeOfClass -> + text "associated type of class" <+> quotes (ppr parent_nm) + FieldOfConstructor -> + text "field of constructor" <+> quotes (ppr parent_nm) + +-- | Some form of @"not in scope"@ error. See also the 'OutOfScopeHole' +-- constructor of 'HoleError'. +data NotInScopeError + + -- | A run-of-the-mill @"not in scope"@ error. + = NotInScope + + -- | Like 'NotInScope', but when we know we are looking for a + -- record field. + | NotARecordField + + -- | An exact 'Name' was not in scope. + -- + -- This usually indicates a problem with a Template Haskell splice. + -- + -- Test cases: T5971, T18263. + | NoExactName Name + + -- The same exact 'Name' occurs in multiple name-spaces. + -- + -- This usually indicates a problem with a Template Haskell splice. + -- + -- Test case: T7241. + | SameName [GlobalRdrElt] -- ^ always at least 2 elements + + -- A type signature, fixity declaration, pragma, standalone kind signature... + -- is missing an associated binding. + | MissingBinding SigLike [GhcHint] + + -- | Couldn't find a top-level binding. + -- + -- Happens when specifying an annotation for something that + -- is not in scope. + -- + -- Test cases: annfail01, annfail02, annfail11. + | NoTopLevelBinding + + -- | A class doesn't have a method with this name, + -- or, a class doesn't have an associated type with this name, + -- or, a record doesn't have a record field with this name. + | UnknownSubordinate + Name -- ^ name of the parent + Subordinate -- ^ the kind of subordinate + + -- | A name is not in scope during type checking but passed the renamer. + -- + -- Test cases: + -- none + | NotInScopeTc (NameEnv TcTyThing) + deriving Generic + +-- | Configuration for pretty-printing valid hole fits. +data HoleFitDispConfig = + HFDC { showWrap, showWrapVars, showType, showProv, showMatches + :: Bool } + +-- | Report an error involving a 'Hole'. +-- +-- This could be an out of scope data constructor or variable, +-- a typed hole, or a wildcard in a type. +data HoleError + -- | Report an out-of-scope data constructor or variable + -- masquerading as an expression hole. + -- + -- See Note [Insoluble holes] in GHC.Tc.Types.Constraint. + -- See 'NotInScopeError' for other not-in-scope errors. + -- + -- Test cases: T9177a. + = OutOfScopeHole + -- | Report a typed hole, or wildcard, with additional information. + | HoleError HoleSort + [TcTyVar] -- Other type variables which get computed on the way. + [(SkolemInfoAnon, [TcTyVar])] -- Zonked and grouped skolems for the type of the hole. + +-- | A message that aims to explain why two types couldn't be seen +-- to be representationally equal. +data CoercibleMsg + -- | Not knowing the role of a type constructor prevents us from + -- concluding that two types are representationally equal. + -- + -- Example: + -- + -- foo :: Applicative m => m (Sum Int) + -- foo = coerce (pure $ 1 :: Int) + -- + -- We don't know what role `m` has, so we can't coerce `m Int` to `m (Sum Int)`. + -- + -- Test cases: T8984, TcCoercibleFail. + = UnknownRoles Type + + -- | The fact that a 'TyCon' is abstract prevents us from decomposing + -- a 'TyConApp' and deducing that two types are representationally equal. + -- + -- Test cases: none. + | TyConIsAbstract TyCon + + -- | We can't unwrap a newtype whose constructor is not in scope. + -- + -- Example: + -- + -- import Data.Ord (Down) -- NB: not importing the constructor + -- foo :: Int -> Down Int + -- foo = coerce + -- + -- Test cases: TcCoercibleFail. + | OutOfScopeNewtypeConstructor TyCon DataCon + +-- | Explain a problem with an import. +data ImportError + -- | Couldn't find a module with the requested name. + = MissingModule ModuleName + -- | The imported modules don't export what we're looking for. + | ModulesDoNotExport (NE.NonEmpty Module) WhatLooking OccName + +-- What kind of suggestion are we looking for? #19843 +data WhatLooking = WL_Anything + -- ^ Any sugestion + | WL_Constructor + -- ^ Suggest type constructors, data constructors + -- (including promoted data constructors), and pattern + -- synonyms. + | WL_TyCon + -- ^ Suggest type constructors/classes only; do not + -- include promoted data constructors. + | WL_TyCon_or_TermVar + -- ^ Suggest type constructors and term variables, + -- but not data constructors nor type variables + | WL_TyVar + -- ^ Suggest type variables only. + | WL_ConLike + -- ^ Suggest term-level data constructors and pattern + -- synonyms; no type constructors or promoted data + -- constructors + | WL_RecField + -- ^ Suggest record fields + -- + -- E.g. in @K { f1 = True, f2 = False }@, if @f2@ is not in + -- scope, suggest only constructor fields + | WL_Term + -- ^ Suggest terms + -- + -- If we are expecting a term value, then only suggest + -- terms (e.g. term variables, data constructors) and + -- not type constructors or type variables + | WL_TermVariable + -- ^ Suggest term variables (and record fields) + | WL_Type + -- ^ Suggest types: type constructors, type variables, + -- promoted data constructors. + | WL_None + -- ^ No suggestions + -- + -- This is is used for rebindable syntax, where there + -- is no point in suggesting alternative spellings + deriving (Eq, Show) + +-- | In what namespaces should we look for a subordinate +-- of the given 'GlobalRdrElt'. +lookingForSubordinate :: GlobalRdrElt -> WhatLooking +lookingForSubordinate parent_gre = + case greInfo parent_gre of + IAmTyCon ClassFlavour + -> WL_TyCon_or_TermVar + _ -> WL_Term + +-- | This datatype collates instances that match or unifier, +-- in order to report an error message for an unsolved typeclass constraint. +data PotentialInstances + = PotentialInstances + { matches :: [ClsInst] + , unifiers :: [ClsInst] + } + +-- | A collection of valid hole fits or refinement fits, +-- in which some fits might have been suppressed. +data FitsMbSuppressed + = Fits + { fits :: [HoleFit] + , fitsSuppressed :: Bool -- ^ Whether we have suppressed any fits because there were too many. + } + +-- | A collection of hole fits and refinement fits. +data ValidHoleFits + = ValidHoleFits + { holeFits :: FitsMbSuppressed + , refinementFits :: FitsMbSuppressed + } + +noValidHoleFits :: ValidHoleFits +noValidHoleFits = ValidHoleFits (Fits [] False) (Fits [] False) + +data RelevantBindings + = RelevantBindings + { relevantBindingNamesAndTys :: [(Name, Type)] + , ranOutOfFuel :: Bool -- ^ Whether we ran out of fuel generating the bindings. + } + +-- | Display some relevant bindings. +pprRelevantBindings :: RelevantBindings -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but it's here for the moment as it's needed in "GHC.Tc.Errors". +pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) = + ppUnless (null rel_bds) $ + hang (text "Relevant bindings include") + 2 (vcat (map ppr_binding rel_bds) $$ ppWhen ran_out_of_fuel discardMsg) + where + ppr_binding (nm, tidy_ty) = + sep [ pprPrefixOcc nm <+> dcolon <+> ppr tidy_ty + , nest 2 (parens (text "bound at" + <+> ppr (getSrcLoc nm)))] + rel_bds = filter (not . isGeneratedSrcSpan . getSrcSpan . fst) bds + +discardMsg :: SDoc +discardMsg = text "(Some bindings suppressed;" <+> + text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" + + +-- | Stores the information to be reported in a representation-polymorphism +-- error message. +data FixedRuntimeRepErrorInfo + = FRR_Info + { frr_info_origin :: FixedRuntimeRepOrigin + -- ^ What is the original type we checked for + -- representation-polymorphism, and what specific + -- check did we perform? + , frr_info_not_concrete :: Maybe (TcTyVar, TcType) + -- ^ Which non-concrete type did we try to + -- unify this concrete type variable with? + , frr_info_other_origin :: Maybe CtOrigin + -- ^ Did the representation polymorphism check arise + -- from another constraint? If so, record that 'CtOrigin' here + -- (it will never be a 'FRROrigin'). + } + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +-- | An error message context, for errors in the renamer. +-- +-- TODO: this should probably get merged in some way with 'ErrCtxtMsg', +-- but that's a battle for another day. +data HsDocContext + = TypeSigCtx [LocatedN RdrName] + | StandaloneKindSigCtx (LocatedN RdrName) + | PatCtx + | SpecInstSigCtx + | DefaultDeclCtx + | ForeignDeclCtx (LocatedN RdrName) + | DerivDeclCtx + | RuleCtx FastString + | SpecECtx RdrName + | 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) + | ReifyInstancesCtx + | ClassInstanceCtx (LHsType GhcRn) + | ClassMethodSigCtx (LocatedN RdrName) -- ^ Class method signature + | SpecialiseSigCtx (LocatedN RdrName) -- ^ SPECIALISE signature + | PatSynSigCtx [LocatedN RdrName] -- ^ Pattern synonym signature + + -- | Escape hatch, for GHC plugins and other GHC API users. + -- + -- Not for use within GHC; add a new constructor to 'HsDocContext' + -- if you need to add a new renamer error context. + | GenericCtx SDoc + +-- | Context for a mismatch in the number of arguments +data MatchArgsContext + = EquationArgs + !Name -- ^ Name of the function + | PatternArgs + !HsMatchContextRn -- ^ Pattern match specifics + +-- | The information necessary to report mismatched +-- numbers of arguments in a match group. +data MatchArgBadMatches where + MatchArgMatches + :: { matchArgFirstMatch :: LocatedA (Match GhcRn body) + , matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) } + -> MatchArgBadMatches + +data PragmaWarningInfo + = PragmaWarningName { pwarn_occname :: OccName + , pwarn_impmod :: ModuleName + , pwarn_declmod :: ModuleName } + | PragmaWarningExport { pwarn_occname :: OccName + , pwarn_impmod :: ModuleName } + | PragmaWarningInstance { pwarn_dfunid :: DFunId + , pwarn_ctorig :: CtOrigin } + | PragmaWarningDefault { pwarn_class :: TyCon + , pwarn_impmod :: ModuleName } + + +-- | The context for an "empty statement group" error. +data EmptyStatementGroupErrReason + = EmptyStmtsGroupInParallelComp + -- ^ Empty statement group in a parallel list comprehension + | EmptyStmtsGroupInTransformListComp + -- ^ Empty statement group in a transform list comprehension + -- + -- Example: + -- [() | then ()] + | EmptyStmtsGroupInDoNotation HsDoFlavour + -- ^ Empty statement group in do notation + -- + -- Example: + -- do + | EmptyStmtsGroupInArrowNotation + -- ^ Empty statement group in arrow notation + -- + -- Example: + -- proc () -> do + + deriving (Generic) + +-- | An existential wrapper around @'StmtLR' GhcPs GhcPs body@. +data UnexpectedStatement where + UnexpectedStatement + :: Outputable (StmtLR GhcPs GhcPs body) + => StmtLR GhcPs GhcPs body + -> UnexpectedStatement + +data DeclSort = ClassDeclSort | InstanceDeclSort + +data NonStandardGuards where + NonStandardGuards + :: (Outputable body, + Anno (Stmt GhcRn body) ~ SrcSpanAnnA) + => [LStmtLR GhcRn GhcRn body] + -> NonStandardGuards + +data RuleLhsErrReason + = UnboundVariable RdrName NotInScopeError + | IllegalExpression + +data HsigShapeMismatchReason = + {-| HsigShapeSortMismatch is an error indicating that an item in the + export list of a signature doesn't match the item of the same name in + another signature when merging the two – one is a type while the other is a + plain identifier. + + Test cases: + none + -} + HsigShapeSortMismatch !AvailInfo !AvailInfo + | + {-| HsigShapeNotUnifiable is an error indicating that a name in the + export list of a signature cannot be unified with a name of the same name in + another signature when merging the two. + + Test cases: + bkpfail20, bkpfail21 + -} + HsigShapeNotUnifiable !Name !Name !Bool + deriving (Generic) + +data WrongThingSort + = WrongThingType + | WrongThingDataCon + | WrongThingPatSyn + | WrongThingConLike + | WrongThingClass + | WrongThingTyCon + | WrongThingAxiom + +data LevelCheckReason + = LevelCheckInstance !InstanceWhat !PredType + | LevelCheckSplice !Name !(Maybe GlobalRdrElt) + +data UninferrableTyVarCtx + = UninfTyCtx_ClassContext [TcType] + | UninfTyCtx_DataContext [TcType] + | UninfTyCtx_ProvidedContext [TcType] + | UninfTyCtx_TyFamRhs TcType + | UninfTyCtx_TySynRhs TcType + | UninfTyCtx_Sig TcType (LHsSigType GhcRn) + +data PatSynInvalidRhsReason + = PatSynNotInvertible !(Pat GhcRn) + | PatSynUnboundVar !Name + deriving (Generic) + +data BadFieldAnnotationReason where + {-| A lazy data type field annotation (~) was used without enabling the + extension StrictData. + + Test cases: + LazyFieldsDisabled + -} + LazyFieldsDisabled :: BadFieldAnnotationReason + {-| An UNPACK pragma was applied to a field without strictness annotation (!). + + Test cases: + T14761a, T7562 + -} + UnpackWithoutStrictness :: BadFieldAnnotationReason + {-| An UNPACK pragma is unusable. + + A possible reason for this warning is that the UNPACK pragma was applied to + one of the following: + + * a function type @a -> b@ + * a recursive use of the data type being defined + * a sum type that cannot be unpacked, see @Note [UNPACK for sum types]@ + * a type/data family application with no matching instance in the environment + + However, it is deliberately /not/ emitted if: + + * the failure occurs in an indefinite package in Backpack + * the pragma is usable, but unpacking is disabled by @-O0@ + + Test cases: + unpack_sums_5, T3966, T7050, T25672, T23307c + + Negative test cases (must not trigger this warning): + T3990 + -} + UnusableUnpackPragma :: BadFieldAnnotationReason + deriving (Generic) + +data SuperclassCycle = + MkSuperclassCycle { cls :: Class, definite :: Bool, reasons :: [SuperclassCycleDetail] } + +data SuperclassCycleDetail + = SCD_HeadTyVar !PredType + | SCD_HeadTyFam !PredType + | SCD_Superclass !Class + +data RoleValidationFailedReason + = TyVarRoleMismatch !TyVar !Role + | TyVarMissingInEnv !TyVar + | BadCoercionRole !Coercion + deriving (Generic) + +data DisabledClassExtension where + {-| MultiParamTypeClasses is required. + + Test cases: + readFail037, TcNoNullaryTC + -} + MultiParamDisabled :: !Int -- ^ The arity + -> DisabledClassExtension + {-| FunctionalDependencies is required. + + Test cases: + readFail041 + -} + FunDepsDisabled :: DisabledClassExtension + {-| ConstrainedClassMethods is required. + + Test cases: + mod39, tcfail150 + -} + ConstrainedClassMethodsDisabled :: !Id + -> !TcPredType + -> DisabledClassExtension + deriving (Generic) + +data TyFamsDisabledReason + = TyFamsDisabledFamily !Name + | TyFamsDisabledInstance !TyCon + deriving (Generic) + +-- | Why was an invisible pattern `@p` rejected? +data BadInvisPatReason + = InvisPatWithoutFlag + | InvisPatNoForall + | InvisPatMisplaced + deriving (Generic) + +-- | Why was the empty case rejected? +data BadEmptyCaseReason + = EmptyCaseWithoutFlag + | EmptyCaseDisallowedCtxt + | EmptyCaseForall ForAllTyBinder + +-- | Either `HsType p` or `HsSigType p`. +-- +-- Used for reporting errors in `TcRnIllegalKind`. +data HsTypeOrSigType p + = HsType (HsType p) + | HsSigType (HsSigType p) + +instance OutputableBndrId p => Outputable (HsTypeOrSigType (GhcPass p)) where + ppr (HsType ty) = ppr ty + ppr (HsSigType sig_ty) = ppr sig_ty + +-- | A wrapper around HsTyVarBndr. +-- Used for reporting errors in `TcRnUnusedQuantifiedTypeVar`. +data HsTyVarBndrExistentialFlag = forall flag. OutputableBndrFlag flag 'Renamed => + HsTyVarBndrExistentialFlag (HsTyVarBndr flag GhcRn) + +instance Outputable HsTyVarBndrExistentialFlag where + ppr (HsTyVarBndrExistentialFlag hsTyVarBndr) = ppr hsTyVarBndr + +type TySynCycleTyCons = + [Either TyCon (LTyClDecl GhcRn)] + +-- | Different types of warnings for dodgy imports. +data DodgyImportsReason = + {-| An import of the form 'T(..)' or 'f(..)' does not actually import anything beside + 'T'/'f' itself. + + Test cases: + DodgyImports + -} + DodgyImportsEmptyParent !GlobalRdrElt + | + {-| A 'hiding' clause contains something that would be reported as an error in a + regular import, but is relaxed to a warning. + + Test cases: + DodgyImports_hiding + -} + DodgyImportsHiding !ImportLookupReason + deriving (Generic) + +-- | What extensions were enabled at import site. +data ImportLookupExtensions = + ImportLookupExtensions + { ile_pattern_synonyms :: !Bool + , ile_explicit_namespaces :: !Bool + } + deriving (Generic) + +-- | Different types of errors for import lookup. +data ImportLookupReason where + {-| An item in an import statement is not exported by the corresponding + module. + + Test cases: + T21826, recomp001, retc001, mod79, mod80, mod81, mod91, T6007, T7167, + T9006, T11071, T9905fail2, T5385, T10668 + -} + ImportLookupBad :: BadImportKind + -> ModIface + -> ImpDeclSpec + -> IE GhcPs + -> ImportLookupExtensions + -> ImportLookupReason + {-| A name is specified with a qualifying module. + + Test cases: + T3792 + -} + ImportLookupQualified :: !RdrName -- ^ The name extracted from the import item + -> ImportLookupReason + + {-| Something completely unexpected is in an import list, like @module Foo@. + + Test cases: + ImportLookupIllegal + -} + ImportLookupIllegal :: ImportLookupReason + {-| An item in an import list matches multiple names exported from that module. + + Test cases: + None + -} + ImportLookupAmbiguous :: !RdrName -- ^ The name extracted from the import item + -> ![GlobalRdrElt] -- ^ The potential matches + -> ImportLookupReason + deriving (Generic) + +-- | Distinguish record fields from other names for pretty-printing. +data UnusedImportName where + UnusedImportNameRecField :: !Parent -> !OccName -> UnusedImportName + UnusedImportNameRegular :: !Name -> UnusedImportName + +-- | Different types of errors for unused imports. +data UnusedImportReason where + {-| No names in the import list are used in the module. + + Test cases: + overloadedrecfldsfail06, T10890_2, t22391, t22391j, T1074, prog018, + mod177, rn046, rn037, T5211 + -} + UnusedImportNone :: UnusedImportReason + {-| A set of names in the import list are not used in the module. + + Test cases: + overloadedrecfldsfail06, T17324, mod176, T11970A, rn046, T14881, + T7454, T8149, T13064 + -} + UnusedImportSome :: ![UnusedImportName] -- ^ The unsed names + -> UnusedImportReason + deriving (Generic) + +-- | Different places in which a nested foralls/contexts error might occur. +data NestedForallsContextsIn + -- | Nested forall in @SPECIALISE instance@ + = NFC_Specialize + -- | Nested forall in @deriving via@ (via-type) + | NFC_ViaType + -- | Nested forall in the type of a GADT constructor + | NFC_GadtConSig + -- | Nested forall in an instance head + | NFC_InstanceHead + -- | Nested forall in a standalone deriving instance head + | NFC_StandaloneDerivedInstanceHead + -- | Nested forall in deriving class type + | NFC_DerivedClassType + +-- | Provenance of an unused name. +data UnusedNameProv + = UnusedNameTopDecl + | UnusedNameImported !ModuleName + | UnusedNameTypePattern + | UnusedNameMatch + | UnusedNameLocalBind + +-- | Different reasons for TcRnNonCanonicalDefinition. +data NonCanonicalDefinition = + -- | Related to @(<>)@ and @mappend@. + NonCanonicalMonoid NonCanonical_Monoid + | + -- | Related to @(*>)@/@(>>)@ and @pure@/@return@. + NonCanonicalMonad NonCanonical_Monad + deriving (Generic) + +-- | Possible cases for the -Wnoncanonical-monoid-instances. +data NonCanonical_Monoid = + -- | @(<>) = mappend@ was defined. + NonCanonical_Sappend + | + -- | @mappend@ was defined as something other than @(<>)@. + NonCanonical_Mappend + +-- | Possible cases for the -Wnoncanonical-monad-instances. +data NonCanonical_Monad = + -- | @pure = return@ was defined. + NonCanonical_Pure + | + -- | @(*>) = (>>)@ was defined. + NonCanonical_ThenA + | + -- | @return@ was defined as something other than @pure@. + NonCanonical_Return + | + -- | @(>>)@ was defined as something other than @(*>)@. + NonCanonical_ThenM + +-- | Why was an instance declaration rejected? +data IllegalInstanceReason + = IllegalClassInstance + !TypedThing -- ^ the instance head type + !IllegalClassInstanceReason -- ^ the problem with the instance head + | IllegalFamilyInstance !IllegalFamilyInstanceReason + | IllegalFamilyApplicationInInstance + !Type -- ^ the instance head type + !Bool -- ^ is this an invisible argument? + !TyCon -- ^ type family + ![Type] -- ^ type family argument + deriving Generic + +-- | Why was a class instance declaration rejected? +data IllegalClassInstanceReason + -- | An illegal type at the head of the instance. + -- + -- See t'IllegalInstanceHeadReason'. + = IllegalInstanceHead !IllegalInstanceHeadReason + -- | An illegal HasField instance. See t'IllegalHasFieldInstance'. + | IllegalHasFieldInstance !IllegalHasFieldInstance + -- | An illegal instance for a built-in typeclass such as + -- 'Coercible', 'Typeable', or 'KnownNat', outside of a signature file. + -- + -- Test cases: deriving/should_fail/T9687 + -- deriving/should_fail/T14916 + -- polykinds/T8132 + -- typecheck/should_fail/TcCoercibleFail2 + -- typecheck/should_fail/T12837 + -- typecheck/should_fail/T14390 + | IllegalSpecialClassInstance !Class !Bool -- ^ Whether the error is due to Safe Haskell being enabled + -- | The instance failed the coverage condition, i.e. the functional + -- dependencies were not respected. + -- + -- Example: + -- + -- class C a b | a -> b where {..} + -- instance C a b where {..} + -- + -- Test cases: T9106, T10570, T2247, T12803, tcfail170. + | IllegalInstanceFailsCoverageCondition + !Class !CoverageProblem + deriving Generic + +-- | Why was a HasField instance declaration rejected? +data IllegalHasFieldInstance + -- | HasField instance for a type not headed by a TyCon. + -- + -- Example: + -- + -- instance HasField a where {..} + -- + -- Test case: hasfieldfail03 + = IllegalHasFieldInstanceNotATyCon + -- | HasField instance for a data family. + -- + -- Example: + -- + -- data family D a + -- data instance D Int = MkDInt Char + -- + -- instance HasField "fld" (D Int) where {..} + -- + -- Test case: hasfieldfail03 + | IllegalHasFieldInstanceFamilyTyCon + -- | HasField instance for a type that already has that field. + -- + -- Example + -- + -- data T = MkT { quux :: Int } + -- instance HasField "quux" T Int where {..} + -- + -- Test case: hasfieldfail03 + | IllegalHasFieldInstanceTyConHasField !TyCon !FieldLabelString + -- | HasField instance for a type that already has fields, when the + -- field label could potentially unify with those fields. + -- + -- Example: + -- + -- data T = MkInt { quux :: Int } + -- instance forall (fld :: Symbol). HasField fld T Int where {..} + -- + -- Test case: hasfieldfail03 + | IllegalHasFieldInstanceTyConHasFields !TyCon !Type -- ^ the label type in the instance head + deriving Generic + +-- | Description of an instance coverage condition failure. +data CoverageProblem = + CoverageProblem + { not_covered_fundep :: ([TyVar], [TyVar]) + , not_covered_fundep_inst :: ([Type], [Type]) + , not_covered_invis_vis_tvs :: Pair VarSet + , not_covered_liberal :: FailedCoverageCondition + } + +-- | Which instance coverage condition failed? Was it the liberal +-- coverage condition? +data FailedCoverageCondition + -- | Failed the instance coverage condition (ICC) + = FailedICC + { alsoFailedLICC :: !Bool + -- ^ Whether the instance also failed the LICC + } + -- | Failed the liberal instance coverage condition (LICC) + | FailedLICC + +-------------------------------------------------------------------------------- +-- Template Haskell errors + +data THError + -- | A syntax error with Template Haskel quotes & splices. + -- See t'THSyntaxError'. + = THSyntaxError !THSyntaxError + -- | An error in Template Haskell involving 'Name's. + -- See t'THNameError'. + | THNameError !THNameError + -- | An error in Template Haskell reification. See t'THReifyError'. + | THReifyError !THReifyError + -- | An error due to typing restrictions in Typed Template Haskell. + -- See t'TypedTHError'. + | TypedTHError !TypedTHError + -- | An error occurred when trying to run a splice in Template Haskell. + -- See 'SpliceFailReason'. + | THSpliceFailed !SpliceFailReason + -- | An error involving the 'addTopDecls' functionality. See t'AddTopDeclsError'. + | AddTopDeclsError !AddTopDeclsError + + {-| IllegalStaticFormInSplice is an error when a user attempts to define + a static pointer in a Template Haskell splice. + + Example(s): + + Test cases: th/TH_StaticPointers02 + -} + | IllegalStaticFormInSplice !(HsExpr GhcPs) + + {-| FailedToLookupThInstName is a Template Haskell error that occurrs when looking up an + instance fails. + + Example(s): + + Test cases: showIface/should_fail/THPutDocNonExistent + -} + | FailedToLookupThInstName !TH.Type !LookupTHInstNameErrReason + + {-| AddInvalidCorePlugin is a Template Haskell error indicating that a + Core plugin being added has an invalid module due to being + in the current package. + + Example(s): + + Test cases: + -} + | AddInvalidCorePlugin !String -- ^ Module name + + {-| AddDocToNonLocalDefn is a Template Haskell error for documentation being added to a + definition which is not in the current module. + + Example(s): + + Test cases: showIface/should_fail/THPutDocExternal + -} + | AddDocToNonLocalDefn !TH.DocLoc + + {-| ReportCustomQuasiError is an error or warning thrown using 'qReport' from + the 'Quasi' instance of 'TcM'. + + Example(s): + + Test cases: + -} + | ReportCustomQuasiError + !Bool -- ^ True => Error, False => Warning + !String -- ^ Error body + deriving Generic + +-- | An error involving Template Haskell quotes or splices, e.g. nested +-- quotation brackets or the use of an untyped bracket inside a typed splice. +data THSyntaxError + = {-| IllegalTHQuotes is an error that occurs when a Template Haskell + quote is used without the TemplateHaskell extension enabled. + + Test case: T18251e + -} + IllegalTHQuotes !(HsExpr GhcPs) + + {-| IllegalTHSplice is an error that occurs when a Template Haskell + splice occurs without having enabled the TemplateHaskell extension. + + Test cases: + bkpfail01, bkpfail05, bkpfail09, bkpfail16, bkpfail35, bkpcabal06 + -} + | IllegalTHSplice + + {-| NestedTHBrackets is an error that occurs when Template Haskell + brackets are nested without any intervening splices. + + Example: + + foo = [| [| 'x' |] |] + + Test cases: TH_NestedSplicesFail{5,6,7,8} + -} + | NestedTHBrackets + + {-| MismatchedSpliceType is an error that happens when a typed bracket + or splice is used inside a typed splice/bracket, or the other way around. + + Examples: + + f1 = [| $$x |] + f2 = [|| $y ||] + f3 = $$( [| 'x' |] ) + f4 = $( [|| 'y' ||] ) + + Test cases: TH_NestedSplicesFail{1,2,3,4} + -} + | MismatchedSpliceType + SpliceType -- ^ type of the splice + SpliceOrBracket -- ^ what's nested inside + {-| BadImplicitSplice is an error thrown when a user uses top-level implicit + TH-splice without enabling the TemplateHaskell extension. + + Example: + + pure [] -- on top-level + + Test cases: ghci/prog019/prog019 + ghci/scripts/T1914 + ghci/scripts/T6106 + rename/should_fail/T4042 + rename/should_fail/T12146 + -} + | BadImplicitSplice + deriving Generic + +data THNameError + {-| NonExactName is a Template Haskell error that occurs when the user + attempts to define a binder with a 'RdrName' that is not an exact 'Name'. + + Example(s): + + Test cases: + -} + = NonExactName !RdrName + + deriving Generic + +data THReifyError + = {-| CannotReifyInstance is a Template Haskell error for when an instance being reified + via `reifyInstances` is not a class constraint or type family application. + + Example(s): + + Test cases: + -} + CannotReifyInstance !Type + + {-| CannotReifyOutOfScopeThing is a Template Haskell error indicating + that the given name is not in scope and therefore cannot be reified. + + Example(s): + + Test cases: th/T16976f + -} + | CannotReifyOutOfScopeThing !TH.Name + + {-| CannotReifyThingNotInTypeEnv is a Template Haskell error occurring + when the given name is not in the type environment and therefore cannot be reified. + + Example(s): + + Test cases: + -} + | CannotReifyThingNotInTypeEnv !Name + + {-| NoRolesAssociatedWithName is a Template Haskell error for when the user + tries to reify the roles of a given name but it is not something that has + roles associated with it. + + Example(s): + + Test cases: + -} + | NoRolesAssociatedWithThing !TcTyThing + + {-| CannotRepresentThing is a Template Haskell error indicating that a + type cannot be reified because it does not have a representation in Template Haskell. + + Example(s): + + Test cases: + -} + | CannotRepresentType !UnrepresentableTypeDescr !Type + deriving Generic + +data AddTopDeclsError + = {-| InvalidTopDecl is a Template Haskell error occurring when one of the 'Dec's passed to + 'addTopDecls' is not a function, value, annotation, or foreign import declaration. + + Example(s): + + Test cases: + -} + InvalidTopDecl !(HsDecl GhcPs) + {-| UnexpectedDeclarationSplice is an error that occurs when a Template Haskell + splice appears inside top-level declarations added with 'addTopDecls'. + + Example(s): none + + Test cases: none + -} + | AddTopDeclsUnexpectedDeclarationSplice + + | AddTopDeclsRunSpliceFailure !RunSpliceFailReason + deriving Generic + +data TypedTHError + = {-| SplicePolymorphicLocalVar is the error that occurs when the expression + inside typed Template Haskell brackets is a polymorphic local variable. + + Example(s): + x = \(y :: forall a. a -> a) -> [|| y ||] + + Test cases: quotes/T10384 + -} + SplicePolymorphicLocalVar !Id + + {-| TypedTHWithPolyType is an error that signifies the illegal use + of a polytype in a typed Template Haskell expression. + + Example(s): + bad :: (forall a. a -> a) -> () + bad = $$( [|| \_ -> () ||] ) + + Test cases: th/T11452 + -} + | TypedTHWithPolyType !TcType + deriving Generic + +data SpliceFailReason + = {-| SpliceThrewException is an error that occurs when running a Template + Haskell splice throws an exception. + + Example(s): + + Test cases: annotations/should_fail/annfail12 + perf/compiler/MultiLayerModulesTH_Make + perf/compiler/MultiLayerModulesTH_OneShot + th/T10796b + th/T19470 + th/T19709d + th/T5358 + th/T5976 + th/T7276a + th/T8987 + th/TH_exn1 + th/TH_exn2 + th/TH_runIO + -} + SpliceThrewException + !SplicePhase + !SomeException + !String -- ^ Result of showing the exception (cannot be done safely outside IO) + !(LHsExpr GhcTc) + !Bool -- True <=> Print the expression + + {-| RunSpliceFailure is an error indicating that a Template Haskell splice + failed to be converted into a valid expression. + + Example(s): + + Test cases: th/T10828a + th/T10828b + th/T12478_4 + th/T15270A + th/T15270B + th/T16895a + th/T16895b + th/T16895c + th/T16895d + th/T16895e + th/T18740d + th/T2597b + th/T2674 + th/T3395 + th/T7484 + th/T7667a + th/TH_implicitParamsErr1 + th/TH_implicitParamsErr2 + th/TH_implicitParamsErr3 + th/TH_invalid_add_top_decl + -} + | RunSpliceFailure !RunSpliceFailReason + deriving Generic + +data RunSpliceFailReason + = ConversionFail !ThingBeingConverted !ConversionFailReason + deriving Generic + +-- | Identifies the TH splice attempting to be converted +data ThingBeingConverted + = ConvDec !TH.Dec + | ConvExp !TH.Exp + | ConvPat !TH.Pat + | ConvType !TH.Type + +-- | The reason a TH splice could not be converted to a Haskell expression +data ConversionFailReason + = IllegalOccName !OccName.NameSpace !String + | SumAltArityExceeded !TH.SumAlt !TH.SumArity + | IllegalSumAlt !TH.SumAlt + | IllegalSumArity !TH.SumArity + | MalformedType !TypeOrKind !TH.Type + | IllegalLastStatement !HsDoFlavour !(LStmt GhcPs (LHsExpr GhcPs)) + | KindSigsOnlyAllowedOnGADTs + | IllegalDeclaration !THDeclDescriptor !IllegalDecls + | CannotMixGADTConsWith98Cons + | EmptyStmtListInDoBlock + | NonVarInInfixExpr + | MultiWayIfWithoutAlts + | CasesExprWithoutAlts + | ImplicitParamsWithOtherBinds + | InvalidCCallImpent !String -- ^ Source + | RecGadtNoCons + | GadtNoCons + | InvalidTypeInstanceHeader !TH.Type + | InvalidTyFamInstLHS !TH.Type + | InvalidImplicitParamBinding + | DefaultDataInstDecl ![LDataFamInstDecl GhcPs] + | FunBindLacksEquations !TH.Name + | EmptyGuard + | EmptyParStmt + deriving Generic + +data IllegalDecls + = IllegalDecls !(NE.NonEmpty (LHsDecl GhcPs)) + | IllegalFamDecls !(NE.NonEmpty (LFamilyDecl GhcPs)) + +-- | Label for a TH declaration +data THDeclDescriptor + = InstanceDecl + | WhereClause + | LetBinding + | LetExpression + | ClssDecl + +-- | The phase in which an exception was encountered when dealing with a TH splice +data SplicePhase + = SplicePhase_Run + | SplicePhase_CompileAndLink + +data LookupTHInstNameErrReason + = NoMatchesFound + | CouldNotDetermineInstance + +data UnrepresentableTypeDescr + = LinearInvisibleArgument + | CoercionsInTypes + | DataConVisibleForall + +-- FFI error types +data IllegalForeignTypeReason + = TypeCannotBeMarshaled !Type TypeCannotBeMarshaledReason + | ForeignDynNotPtr + !Type -- ^ Expected type + !Type -- ^ Actual type + | SafeHaskellMustBeInIO + | IOResultExpected + | UnexpectedNestedForall + | LinearTypesNotAllowed + | OneArgExpected + | AtLeastOneArgExpected + deriving Generic + +-- | Reason why a type cannot be marshalled through the FFI. +data TypeCannotBeMarshaledReason + = NotADataType + | NewtypeDataConNotInScope !TyCon ![Type] + | UnliftedFFITypesNeeded + | NotABoxedMarshalableTyCon + | ForeignLabelNotAPtr + | NotSimpleUnliftedType + | NotBoxedKindAny + deriving Generic + +data TcRnNoDerivStratSpecifiedInfo where + {-| 'TcRnNoDerivStratSpecified TcRnNoDerivingClauseStrategySpecified' is + a warning implied by -Wmissing-deriving-strategies and triggered by a + deriving clause without a specified deriving strategy. + + Example: + + newtype T = T Int + deriving (Eq, Ord, Show) + + Here we would suggest fixing the deriving clause to: + + deriving stock (Show) + deriving newtype (Eq, Ord) + + Test cases: deriving/should_compile/T15798a + deriving/should_compile/T15798c + deriving/should_compile/T24955a + deriving/should_compile/T24955b + -} + TcRnNoDerivingClauseStrategySpecified + :: Map AssumedDerivingStrategy [LHsSigType GhcRn] + -> TcRnNoDerivStratSpecifiedInfo + + {-| 'TcRnNoDerivStratSpecified TcRnNoStandaloneDerivingStrategySpecified' is + a warning implied by -Wmissing-deriving-strategies and triggered by a + standalone deriving declaration without a specified deriving strategy. + + Example: + + data T a = T a + deriving instance Show a => Show (T a) + + Here we would suggest fixing the instance to: + + deriving stock instance Show a => Show (T a) + + Test cases: deriving/should_compile/T15798b + deriving/should_compile/T24955c + -} + TcRnNoStandaloneDerivingStrategySpecified + :: AssumedDerivingStrategy + -> LHsSigWcType GhcRn -- ^ The instance signature (e.g @Show a => Show (T a)@) + -> TcRnNoDerivStratSpecifiedInfo + +-- | Label for syntax that may occur in terms (expressions) only as part of a +-- required type argument. +data TypeSyntax + = TypeKeywordSyntax -- ^ @type t@ + | ContextArrowSyntax -- ^ @ctx => t@ + | FunctionArrowSyntax -- ^ @t1 -> t2@ + | ForallTelescopeSyntax -- ^ @forall tvs. t@ + deriving Generic + +typeSyntaxExtension :: TypeSyntax -> LangExt.Extension +typeSyntaxExtension TypeKeywordSyntax = LangExt.ExplicitNamespaces +typeSyntaxExtension ContextArrowSyntax = LangExt.RequiredTypeArguments +typeSyntaxExtension FunctionArrowSyntax = LangExt.RequiredTypeArguments +typeSyntaxExtension ForallTelescopeSyntax = LangExt.RequiredTypeArguments diff --git a/GHC/Tc/Errors/Types/PromotionErr.hs b/GHC/Tc/Errors/Types/PromotionErr.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Types/PromotionErr.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Tc.Errors.Types.PromotionErr ( PromotionErr(..) + , pprPECategory + , peCategory + , TermLevelUseErr(..) + , TermLevelUseCtxt(..) + , pprTermLevelUseCtxt + , teCategory + ) where + +import GHC.Prelude +import GHC.Core.Type (ThetaType) +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Generics (Generic) +import GHC.Types.Name.Reader (GlobalRdrElt, pprNameProvenance) +import GHC.Types.Name (Name, nameSrcLoc) + +data PromotionErr + = TyConPE -- TyCon used in a kind before we are ready + -- data T :: T -> * where ... + | ClassPE -- Ditto Class + + | FamDataConPE -- Data constructor for a data family + -- See Note [AFamDataCon: not promoting data family constructors] + -- in GHC.Tc.Utils.Env. + | ConstrainedDataConPE ThetaType -- Data constructor with a context + -- See Note [No constraints in kinds] in GHC.Tc.Validity + | PatSynPE -- Pattern synonyms + -- See Note [Don't promote pattern synonyms] in GHC.Tc.Utils.Env + + | RecDataConPE -- Data constructor in a recursive loop + -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl + | TermVariablePE -- See Note [Demotion of unqualified variables] in GHC.Rename.Env + | TypeVariablePE -- See Note [Type variable scoping errors during typechecking] + deriving (Generic) + +instance Outputable PromotionErr where + ppr ClassPE = text "ClassPE" + ppr TyConPE = text "TyConPE" + ppr PatSynPE = text "PatSynPE" + ppr FamDataConPE = text "FamDataConPE" + ppr (ConstrainedDataConPE theta) = text "ConstrainedDataConPE" <+> parens (ppr theta) + ppr RecDataConPE = text "RecDataConPE" + ppr TermVariablePE = text "TermVariablePE" + ppr TypeVariablePE = text "TypeVariablePE" + +pprPECategory :: PromotionErr -> SDoc +pprPECategory = text . capitalise . peCategory + +peCategory :: PromotionErr -> String +peCategory ClassPE = "class" +peCategory TyConPE = "type constructor" +peCategory PatSynPE = "pattern synonym" +peCategory FamDataConPE = "data constructor" +peCategory ConstrainedDataConPE{} = "data constructor" +peCategory RecDataConPE = "data constructor" +peCategory TermVariablePE = "term variable" +peCategory TypeVariablePE = "type variable" + +-- The opposite of a promotion error (a demotion error, in a sense). +data TermLevelUseErr + = TyConTE -- Type constructor used at the term level, e.g. x = Int + | ClassTE -- Class used at the term level, e.g. x = Functor + | TyVarTE -- Type variable used at the term level, e.g. f (Proxy :: Proxy a) = a + deriving (Generic) + +teCategory :: TermLevelUseErr -> String +teCategory ClassTE = "class" +teCategory TyConTE = "type constructor" +teCategory TyVarTE = "type variable" + +data TermLevelUseCtxt + = TermLevelUseGRE !GlobalRdrElt + | TermLevelUseTyVar + deriving (Generic) + +pprTermLevelUseCtxt :: Name -> TermLevelUseCtxt -> SDoc +pprTermLevelUseCtxt nm = \case + TermLevelUseGRE gre -> pprNameProvenance gre + TermLevelUseTyVar -> text "bound at" <+> ppr (nameSrcLoc nm) + + +{- Note [Type variable scoping errors during typechecking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the scoping of the type variable `a` in the following +term-level example: + + -- f :: [forall b . Either b ()] + f = [Right @a @() () :: forall a. Either a ()] + +Here `@a` in the type application and `a` in the type signature refer to +the same type variable. Indeed, this term elaborates to the following Core: + + f = [(\@a -> Right @a @() ()) :: forall a . Either a ()] + +But how does this work with types? Suppose we have: + + type F = '[Right @a @() () :: forall a. Either a ()] + +To be consistent with the term-level language, we would have to elaborate +this using a big lambda: + + type F = '[(/\ a . Right @a @() ()) :: forall a. Either a ()] + +Core has no such construct, so this is not a valid type. + +Conclusion: Even with -XExtendedForAllScope, the forall'd variables of a +kind signature on a type cannot scope over the type. + +In implementation terms, to get a helpful error message we do this: + +* The renamer treats the type variable as bound by the forall + (so it doesn't just say "out of scope"); see the `HsKindSig` case of GHC.Rename.HsType.rnHsTyKi. + +* The typechecker adds the forall-bound type variables to the type environent, + but bound to `APromotionErr TypeVariablePE`; see the call to `tcAddKindSigPlaceholders` + in the `HsKindSig` case of `GHC.Tc.Gen.HsType.tc_infer_hs_type`. + +* The occurrence site of a type variable then complains when it finds `APromotionErr`; + see `GHC.Tc.Gen.HsType.tcTyVar`. +-} diff --git a/GHC/Tc/Gen/Annotation.hs b/GHC/Tc/Gen/Annotation.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Annotation.hs @@ -0,0 +1,66 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking annotations +module GHC.Tc.Gen.Annotation ( tcAnnotations ) where + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Driver.Env + +import GHC.Tc.Errors.Types +import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation ) +import GHC.Tc.Utils.Monad + +import GHC.Unit.Module + +import GHC.Hs + +import GHC.Types.Name +import GHC.Types.Annotations +import GHC.Types.SrcLoc + +import Control.Monad ( when ) + +-- Some platforms don't support the interpreter, and compilation on those +-- platforms shouldn't fail just due to annotations +tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] +tcAnnotations anns = do + hsc_env <- getTopEnv + case hsc_interp hsc_env of + Just _ -> mapM tcAnnotation anns + Nothing -> warnAnns anns + +warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] +--- No GHCI; emit a warning (not an error) and ignore. cf #4268 +warnAnns [] = return [] +warnAnns anns@(L loc _ : _) + = do { setSrcSpanA loc $ addDiagnosticTc (TcRnIgnoringAnnotations anns) + ; return [] } + +tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation +tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do + -- Work out what the full target of this annotation was + mod <- getModule + let target = annProvenanceToTarget mod provenance + + -- Run that annotation and construct the full Annotation data structure + setSrcSpanA loc $ addErrCtxt (AnnCtxt ann) $ do + -- See #10826 -- Annotations allow one to bypass Safe Haskell. + dflags <- getDynFlags + when (safeLanguageOn dflags) $ failWithTc TcRnAnnotationInSafeHaskell + runAnnotation target expr + +annProvenanceToTarget :: Module -> AnnProvenance GhcRn + -> AnnTarget Name +annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name +annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name +annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod + diff --git a/GHC/Tc/Gen/App.hs b/GHC/Tc/Gen/App.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/App.hs @@ -0,0 +1,2337 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] +{-# LANGUAGE TypeApplications #-} -- Wrinkle in Note [Trees That Grow] + +{- +% +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Tc.Gen.App + ( tcApp + , tcExprPrag ) where + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) + +import GHC.Hs + +import GHC.Tc.Gen.Head +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.Concrete ( unifyConcrete, idConcreteTvs ) +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..) ) +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType as TcType +import GHC.Tc.Utils.Concrete( hasFixedRuntimeRep_syntactic ) +import GHC.Tc.Zonk.TcType + +import GHC.Core.ConLike (ConLike(..)) +import GHC.Core.DataCon ( dataConConcreteTyVars, isNewDataCon, dataConTyCon ) +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Subst ( substTyWithInScope ) +import GHC.Core.Type +import GHC.Core.Coercion + +import GHC.Builtin.Types ( multiplicityTy ) +import GHC.Builtin.PrimOps( tagToEnumKey ) +import GHC.Builtin.Names + +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) + +import GHC.Data.Maybe + +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic + +import qualified GHC.LanguageExtensions as LangExt +import Language.Haskell.Syntax.Basic( isBoxed ) + +import Control.Monad +import Data.Function +import Data.Semigroup + +import GHC.Prelude + +{- ********************************************************************* +* * + Quick Look overview +* * +********************************************************************* -} + +{- Note [Quick Look overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The implementation of Quick Look closely follows the QL paper + A quick look at impredicativity, Serrano et al, ICFP 2020 + https://www.microsoft.com/en-us/research/publication/a-quick-look-at-impredicativity/ + +All the moving parts are in this module, GHC.Tc.Gen.App, so named +because it deal with n-ary application. The main workhorse is tcApp. + +Some notes relative to the paper + +(QL1) The "instantiation variables" of the paper are ordinary unification + variables. We keep track of which variables are instantiation variables + by giving them a TcLevel of QLInstVar, which is like "infinity". + +(QL2) When we learn what an instantiation variable must be, we simply unify + it with that type; this is done in qlUnify, which is the function mgu_ql(t1,t2) + of the paper. This may fill in a (mutable) instantiation variable with + a polytype. + +(QL3) When QL is done, we turn the instantiation variables into ordinary unification + variables, using qlZonkTcType. This function fully zonks the type (thereby + revealing all the polytypes), and updates any instantiation variables with + ordinary unification variables. + See Note [Instantiation variables are short lived]. + +(QL4) We cleverly avoid the quadratic cost of QL, alluded to in the paper. + See Note [Quick Look at value arguments] + +Note [Instantiation variables are short lived] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* An instantation variable is a mutable meta-type-variable, whose level number + is QLInstVar. + +* Ordinary unification variables always stand for monotypes; only instantiation + variables can be unified with a polytype (by `qlUnify`). + +* When we start typechecking the argments of the call, in tcValArgs, we will + (a) monomorphise any un-filled-in instantiation variables + (see Note [Monomorphise instantiation variables]) + (b) zonk the argument type to reveal any polytypes before typechecking that + argument (see calls to `zonkTcType` and "Crucial step" in tcValArg).. + See Section 4.3 "Applications and instantiation" of the paper. + +* The constraint solver never sees an instantiation variable [not quite true; + see below] + + However, the constraint solver can see a meta-type-variable filled + in with a polytype (#18987). Suppose + f :: forall a. Dict a => [a] -> [a] + xs :: [forall b. b->b] + and consider the call (f xs). QL will + * Instantiate f, with a := kappa, where kappa is an instantiation variable + * Emit a constraint (Dict kappa), via instantiateSigma, called from tcInstFun + * Do QL on the argument, to discover kappa := forall b. b->b + + But by the time the third step has happened, the constraint has been emitted + into the monad. The constraint solver will later find it, and rewrite it to + (Dict (forall b. b->b)). That's fine -- the constraint solver does no implicit + instantiation (which is what makes it so tricky to have foralls hiding inside + unification variables), so there is no difficulty with allowing those + filled-in kappa's to persist. (We could find them and zonk them away, but + that would cost code and execution time, for no purpose.) + + Since the constraint solver does not do implicit instantiation (as the + constraint generator does), the fact that a unification variable might stand + for a polytype does not matter. + +* Actually, sadly the constraint solver /can/ see an instantiation variable. + Consider this from test VisFlag1_ql: + f :: forall {k} {a :: k} (hk :: forall j. j -> Type). hk a -> () + + bad_wild :: () + bad_wild = f @_ MkV + In tcInstFun instantiate f with [k:=k0, a:=a0], and then encounter the `@_`, + expecting it to have kind (forall j. j->Type). We make a fresh variable (it'll + be an instantiation variable since we are in tcInstFun) for the `_`, thus + (_ : k0) and do `checkExpectedKind` to match up `k0` with `forall j. j->Type`. + The unifier doesn't solve it (it does not unify instantiation variables) so + it leaves it for the constraint solver. Yuk. It's hard to see what to do + about this, but it seems to do no harm for the constraint solver to see the + occasional instantiation variable. +-} + + +{- ********************************************************************* +* * + Typechecking n-ary applications +* * +********************************************************************* -} + +{- Note [Application chains and heads] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Quick Look treats application chains specially. What is an +"application chain"? See Fig 2, of the QL paper: "A quick look at +impredicativity" (ICFP'20). Here's the syntax: + +app ::= head + | app expr -- HsApp: ordinary application + | app @type -- HsTypeApp: VTA + | expr `head` expr -- OpApp: infix applications + | ( app ) -- HsPar: parens + | {-# PRAGMA #-} app -- HsPragE: pragmas + +head ::= f -- HsVar: variables + | fld -- HsRecSel: record field selectors + | (expr :: ty) -- ExprWithTySig: expr with user type sig + | lit -- HsOverLit: overloaded literals + | other_expr -- Other expressions + +When tcExpr sees something that starts an application chain (namely, +any of the constructors in 'app' or 'head'), it invokes tcApp to +typecheck it: see Note [tcApp: typechecking applications]. However, +for HsPar and HsPragE, there is no tcWrapResult (which would +instantiate types, bypassing Quick Look), so nothing is gained by +using the application chain route, and we can just recurse to tcExpr. + +A "head" has three special cases (for which we can infer a polytype +using tcInferAppHead_maybe); otherwise is just any old expression (for +which we can infer a rho-type (via runInferExpr). + +There is no special treatment for HsHole (HsVar ...), HsOverLit, etc, because +we can't get a polytype from them. + +Left and right sections (e.g. (x +) and (+ x)) are not yet supported. +Probably left sections (x +) would be easy to add, since x is the +first arg of (+); but right sections are not so easy. For symmetry +reasons I've left both unchanged, in GHC.Tc.Gen.Expr. + +It may not be immediately obvious why ExprWithTySig (e::ty) should be +dealt with by tcApp, even when it is not applied to anything. Consider + f :: [forall a. a->a] -> Int + ...(f (undefined :: forall b. b))... +Clearly this should work! But it will /only/ work because if we +instantiate that (forall b. b) impredicatively! And that only happens +in tcApp. + +Note [tcApp: typechecking applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcApp implements the APP-Downarrow/Uparrow rule of +Fig 3, plus the modification in Fig 5, of the QL paper: +"A quick look at impredicativity" (ICFP'20). + +It treats application chains (f e1 @ty e2) specially: + +* So we can report errors like "in the third argument of a call of f" + +* So we can do Visible Type Application (VTA), for which we must not + eagerly instantiate the function part of the application. + +* So that we can do Quick Look impredicativity. + +tcApp works like this: + +1. Use splitHsApps, which peels off + HsApp, HsTypeApp, HsPrag, HsPar + returning the function in the corner and the arguments + + splitHsApps can deal with infix as well as prefix application, + and returns a Rebuilder to re-assemble the application after + typechecking. + + The "list of arguments" is [HsExprArg], described in Note [HsExprArg]. + in GHC.Tc.Gen.Head + +2. Use tcInferAppHead to infer the type of the function, + as an (uninstantiated) TcSigmaType + There are special cases for + HsVar, HsRecSel, and ExprWithTySig + Otherwise, delegate back to tcExpr, which + infers an (instantiated) TcRhoType + + This isn't perfect. Consider this (which uses visible type application): + (let { f :: forall a. a -> a; f x = x } in f) @Int + Since 'let' is not among the special cases for tcInferAppHead, + we'll delegate back to tcExpr, which will instantiate f's type + and the type application to @Int will fail. Too bad! + +3. Use tcInstFun to instantiate the function, Quick-Looking as we go. This + implements the |-inst judgement in Fig 4, plus the modification in Fig 5, of + the QL paper: "A quick look at impredicativity" (ICFP'20). + + In tcInstFun we take a quick look at value arguments, using quickLookArg. + See Note [Quick Look at value arguments]. + + (TCAPP1) Crucially, just before `tcApp` calls `tcInstFun`, it sets the + ambient TcLevel to QLInstVar, so all unification variables allocated by + tcInstFun, and in the quick-looks it does at the arguments, will be + instantiation variables. + + Consider (f (g (h x))).`tcApp` instantiates the call to `f`, and in doing + so quick-looks at the argument(s), in this case (g (h x)). But + `quickLookArg` on (g (h x)) in turn instantiates `g` and quick-looks at + /its/ argument(s), in this case (h x). And so on recursively. Key + point: all these instantiations make instantiation variables. + +Now we split into two cases: + +4. Case NoQL: no Quick Look + + 4.1 Use checkResultTy to connect the the result type. + Do this /before/ checking the arguments; see + Note [Unify with expected type before typechecking arguments] + + 4.2 Check the arguments with `tcValArgs`. + + 4.3 Use `finishApp` to wrap up. + +5. Case DoQL: use Quick Look + + 5.1 Use `quickLookResultType` to take a quick look at the result type, + when in checking mode. This is the shaded part of APP-Downarrow + in Fig 5. It also implements the key part of + Note [Unify with expected type before typechecking arguments] + + 5.2 Check the arguments with `tcValArgs`. Importantly, this will monomorphise + all the instantiation variables of the call. + See Note [Monomorphise instantiation variables]. + + 5.3 Use `zonkTcType` to expose the polymophism hidden under instantiation + variables in `app_res_rho`, and the monomorphic versions of any + un-unified instantiation variables. + + 5.4 Use `checkResTy` to do the subsumption check as usual + + 5.4 Use `finishApp` to wrap up + +The funcion `finishApp` mainly calls `rebuildHsApps` to rebuild the +application; but it also does a couple of gruesome final checks: + * Horrible newtype check + * Special case for tagToEnum + +(TCAPP2) There is a lurking difficulty in the above plan: + * Before calling tcInstFun, we set the ambient level in the monad + to QLInstVar (Step 2 above). + * Then, when kind-checking the visible type args of the application, + we may perhaps build an implication constraint. + * That means we'll try to add 1 to the ambient level; which is a no-op. + * So skolem escape checks won't work right. + This is pretty exotic, so I'm just deferring it for now, leaving + this note to alert you to the possiblity. + +Note [Quick Look for particular Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We switch on Quick Look (regardless of -XImpredicativeTypes) for certain +particular Ids: + +* ($): For a long time GHC has had a special typing rule for ($), that + allows it to type (runST $ foo), which requires impredicative instantiation + of ($), without language flags. It's a bit ad-hoc, but it's been that + way for ages. Using quickLookKeys is the only special treatment ($) needs + now, which is a lot better. + +* leftSection, rightSection: these are introduced by the expansion step in + the renamer (Note [Handling overloaded and rebindable constructs] in + GHC.Rename.Expr), and we want them to be instantiated impredicatively + so that (f `op`), say, will work OK even if `f` is higher rank. + See Note [Left and right sections] in GHC.Rename.Expr. + +Note [Unify with expected type before typechecking arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#19364) + data Pair a b = Pair a b + baz :: MkPair Int Bool + baz = MkPair "yes" "no" + +We instantiate MkPair with `alpha`, `beta`, and push its argument +types (`alpha` and `beta`) into the arguments ("yes" and "no"). +But if we first unify the result type (Pair alpha beta) with the expected +type (Pair Int Bool) we will push the much more informative types +`Int` and `Bool` into the arguments. This makes a difference: + +Unify result type /after/ typechecking the args + • Couldn't match type ‘[Char]’ with ‘Bool’ + Expected type: Pair Foo Bar + Actual type: Pair [Char] [Char] + • In the expression: Pair "yes" "no" + +Unify result type /before/ typechecking the args + • Couldn't match type ‘[Char]’ with ‘Bool’ + Expected: Foo + Actual: String + • In the first argument of ‘Pair’, namely ‘"yes"’ + +The latter is much better. That is why we call checkResultType before tcValArgs. +-} + +tcApp :: HsExpr GhcRn + -> ExpRhoType -- When checking, -XDeepSubsumption <=> deeply skolemised + -> TcM (HsExpr GhcTc) +-- See Note [tcApp: typechecking applications] +tcApp rn_expr exp_res_ty + = do { -- Step 1: Split the application chain + (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr + ; traceTc "tcApp {" $ + vcat [ text "rn_expr:" <+> ppr rn_expr + , text "rn_fun:" <+> ppr rn_fun + , text "fun_ctxt:" <+> ppr fun_ctxt + , text "rn_args:" <+> ppr rn_args ] + + -- Step 2: Infer the type of `fun`, the head of the application + ; (tc_fun, fun_sigma) <- tcInferAppHead fun + ; let tc_head = (tc_fun, fun_ctxt) + -- inst_final: top-instantiate the result type of the application, + -- EXCEPT if we are trying to infer a sigma-type + inst_final = case exp_res_ty of + Check {} -> True + Infer (IR {ir_inst=iif}) -> + case iif of + IIF_ShallowRho -> True + IIF_DeepRho -> True + IIF_Sigma -> False + + -- Step 3: Instantiate the function type (taking a quick look at args) + ; do_ql <- wantQuickLook rn_fun + ; (inst_args, app_res_rho) + <- setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in + -- Note [tcApp: typechecking applications] + tcInstFun do_ql inst_final tc_head fun_sigma rn_args + + ; case do_ql of + NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho) + + -- Step 4.1: subsumption check against expected result type + -- See Note [Unify with expected type before typechecking arguments] + ; res_wrap <- checkResultTy rn_expr tc_head inst_args + app_res_rho exp_res_ty + -- Step 4.2: typecheck the arguments + ; tc_args <- tcValArgs NoQL inst_args + + -- Step 4.3: wrap up + ; finishApp tc_head tc_args app_res_rho res_wrap } + + DoQL -> do { traceTc "tcApp:DoQL" (ppr rn_fun $$ ppr app_res_rho) + + -- Step 5.1: Take a quick look at the result type + ; quickLookResultType app_res_rho exp_res_ty + + -- Step 5.2: typecheck the arguments, and monomorphise + -- any un-unified instantiation variables + ; tc_args <- tcValArgs DoQL inst_args + -- Step 5.3: zonk to expose the polymophism hidden under + -- QuickLook instantiation variables in `app_res_rho` + ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho + + -- Step 5.4: subsumption check against the expected type + ; res_wrap <- checkResultTy rn_expr tc_head inst_args + app_res_rho exp_res_ty + -- Step 5.5: wrap up + ; finishApp tc_head tc_args app_res_rho res_wrap } } + +setQLInstLevel :: QLFlag -> TcM a -> TcM a +setQLInstLevel DoQL thing_inside = setTcLevel QLInstVar thing_inside +setQLInstLevel NoQL thing_inside = thing_inside + +quickLookResultType :: TcRhoType -> ExpRhoType -> TcM () +-- This function implements the shaded bit of rule APP-Downarrow in +-- Fig 5 of the QL paper: "A quick look at impredicativity" (ICFP'20). +quickLookResultType app_res_rho (Check exp_rho) = qlUnify app_res_rho exp_rho +quickLookResultType _ _ = return () + +finishApp :: (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc] + -> TcRhoType -> HsWrapper + -> TcM (HsExpr GhcTc) +-- Do final checks and wrap up the result +finishApp tc_head@(tc_fun,_) tc_args app_res_rho res_wrap + = do { -- Horrible newtype check + ; rejectRepPolyNewtypes tc_head app_res_rho + + -- Reconstruct, with a horrible special case for tagToEnum#. + ; res_expr <- if isTagToEnum tc_fun + then tcTagToEnum tc_head tc_args app_res_rho + else return (rebuildHsApps tc_head tc_args) + ; traceTc "End tcApp }" (ppr tc_fun) + ; return (mkHsWrap res_wrap res_expr) } + +-- | Connect up the inferred type of an application with the expected type. +-- This is usually just a unification, but with deep subsumption there is more to do. +checkResultTy :: HsExpr GhcRn + -> (HsExpr GhcTc, AppCtxt) -- Head + -> [HsExprArg p] -- Arguments, just error messages + -> TcRhoType -- Inferred type of the application; zonked to + -- expose foralls, but maybe not /deeply/ instantiated + -> ExpRhoType -- Expected type; this is deeply skolemised + -> TcM HsWrapper +checkResultTy rn_expr _fun _inst_args app_res_rho (Infer inf_res) + = fillInferResult (exprCtOrigin rn_expr) app_res_rho inf_res + -- fillInferResult does deep instantiation if DeepSubsumption is on + +checkResultTy rn_expr (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty) +-- Unify with expected type from the context +-- See Note [Unify with expected type before typechecking arguments] +-- +-- Match up app_res_rho: the result type of rn_expr +-- with res_ty: the expected result type + = perhaps_add_res_ty_ctxt $ + do { ds_flag <- getDeepSubsumptionFlag + ; traceTc "checkResultTy {" $ + vcat [ text "tc_fun:" <+> ppr tc_fun + , text "app_res_rho:" <+> ppr app_res_rho + , text "res_ty:" <+> ppr res_ty + , text "ds_flag:" <+> ppr ds_flag ] + ; case ds_flag of + Shallow -> -- No deep subsumption + -- app_res_rho and 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 <- unifyExprType rn_expr app_res_rho res_ty + ; traceTc "checkResultTy 1 }" (ppr co) + ; return (mkWpCastN co) } + + Deep -> -- Deep subsumption + -- Even though both app_res_rho and res_ty are rho-types, + -- they may have nested polymorphism, so if deep subsumption + -- is on we must call tcSubType. + do { wrap <- tcSubTypeDS rn_expr app_res_rho res_ty + ; traceTc "checkResultTy 2 }" (ppr app_res_rho $$ ppr res_ty) + ; return wrap } } + where + -- perhaps_add_res_ty_ctxt: Inside an expansion, the addFunResCtxt stuff is + -- more confusing than helpful because the function at the head isn't in + -- the source program; it was added by the renamer. See + -- Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr + perhaps_add_res_ty_ctxt thing_inside + | insideExpansion fun_ctxt + = addHeadCtxt fun_ctxt thing_inside + | otherwise + = addFunResCtxt tc_fun inst_args app_res_rho (mkCheckExpType res_ty) $ + thing_inside + +---------------- +tcValArgs :: QLFlag -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc] +-- Importantly, tcValArgs works left-to-right, so that by the time we +-- encounter an argument, we have monomorphised all the instantiation +-- variables that its type contains. All that is left to do is an ordinary +-- zonkTcType. See Note [Monomorphise instantiation variables]. +tcValArgs do_ql args = mapM (tcValArg do_ql) args + +tcValArg :: QLFlag -> HsExprArg 'TcpInst -- Actual argument + -> TcM (HsExprArg 'TcpTc) -- Resulting argument +tcValArg _ (EPrag l p) = return (EPrag l (tcExprPrag p)) +tcValArg _ (ETypeArg l hty ty) = return (ETypeArg l hty ty) +tcValArg do_ql (EWrap (EHsWrap w)) = do { whenQL do_ql $ qlMonoHsWrapper w + ; return (EWrap (EHsWrap w)) } + -- qlMonoHsWrapper: see Note [Monomorphise instantiation variables] +tcValArg _ (EWrap ew) = return (EWrap ew) + +tcValArg do_ql (EValArg { ea_ctxt = ctxt + , ea_arg = larg@(L arg_loc arg) + , ea_arg_ty = sc_arg_ty }) + = addArgCtxt ctxt larg $ + do { traceTc "tcValArg" $ + vcat [ ppr ctxt + , text "arg type:" <+> ppr sc_arg_ty + , text "arg:" <+> ppr arg ] + + -- Crucial step: expose QL results before checking exp_arg_ty + -- So far as the paper is concerned, this step applies + -- the poly-substitution Theta, learned by QL, so that we + -- "see" the polymorphism in that argument type. E.g. + -- (:) e ids, where ids :: [forall a. a->a] + -- (:) :: forall p. p->[p]->[p] + -- Then Theta = [p :-> forall a. a->a], and we want + -- to check 'e' with expected type (forall a. a->a) + -- See Note [Instantiation variables are short lived] + ; Scaled mult exp_arg_ty <- case do_ql of + DoQL -> liftZonkM $ zonkScaledTcType sc_arg_ty + NoQL -> return sc_arg_ty + + -- Now check the argument + ; arg' <- tcScalingUsage mult $ + tcPolyExpr arg (mkCheckExpType exp_arg_ty) + + ; return (EValArg { ea_ctxt = ctxt + , ea_arg = L arg_loc arg' + , ea_arg_ty = noExtField }) } + +tcValArg _ (EValArgQL { eaql_wanted = wanted + , eaql_ctxt = ctxt + , eaql_arg_ty = sc_arg_ty + , eaql_larg = larg@(L arg_loc rn_expr) + , eaql_tc_fun = tc_head + , eaql_fun_ue = head_ue + , eaql_args = inst_args + , eaql_encl = arg_influences_enclosing_call + , eaql_res_rho = app_res_rho }) + = addArgCtxt ctxt larg $ + do { -- Expose QL results to tcSkolemise, as in EValArg case + Scaled mult exp_arg_ty <- liftZonkM $ zonkScaledTcType sc_arg_ty + + ; traceTc "tcEValArgQL {" (vcat [ text "app_res_rho:" <+> ppr app_res_rho + , text "exp_arg_ty:" <+> ppr exp_arg_ty + , text "args:" <+> ppr inst_args + , text "mult:" <+> ppr mult]) + + ; ds_flag <- getDeepSubsumptionFlag + ; (wrap, arg') + <- tcScalingUsage mult $ + tcSkolemise ds_flag GenSigCtxt exp_arg_ty $ \ exp_arg_rho -> + do { -- Emit saved-up constraints, /under/ the tcSkolemise + -- See (QLA4) in Note [Quick Look at value arguments] + emitConstraints wanted + -- Emit saved-up usages /under/ the tcScalingUsage. + -- See (QLA5) in Note [Quick Look at value arguments] + ; tcEmitBindingUsage head_ue + + -- Unify with context if we have not already done so + -- See (QLA4) in Note [Quick Look at value arguments] + ; unless arg_influences_enclosing_call $ -- Don't repeat + qlUnify app_res_rho exp_arg_rho -- the qlUnify + + ; tc_args <- tcValArgs DoQL inst_args + ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho + ; res_wrap <- checkResultTy rn_expr tc_head inst_args + app_res_rho (mkCheckExpType exp_arg_rho) + ; finishApp tc_head tc_args app_res_rho res_wrap } + + ; traceTc "tcEValArgQL }" $ + vcat [ text "app_res_rho:" <+> ppr app_res_rho ] + + ; return (EValArg { ea_ctxt = ctxt + , ea_arg = L arg_loc (mkHsWrap wrap arg') + , ea_arg_ty = noExtField }) } + + +-------------------- +wantQuickLook :: HsExpr GhcRn -> TcM QLFlag +wantQuickLook (HsVar _ (L _ (WithUserRdr _ f))) + | getUnique f `elem` quickLookKeys = return DoQL +wantQuickLook _ = do { impred <- xoptM LangExt.ImpredicativeTypes + ; if impred then return DoQL else return NoQL } + +quickLookKeys :: [Unique] +-- See Note [Quick Look for particular Ids] +quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey] + +{- ********************************************************************* +* * + Instantiating the call +* * +********************************************************************* -} + +tcInstFun :: QLFlag + -> Bool -- False <=> Instantiate only /top-level, inferred/ variables; + -- so may return a sigma-type + -- True <=> Instantiate /top-level, invisible/ type variables; + -- always return a rho-type (but not a deep-rho type) + -- Generally speaking we pass in True; in Fig 5 of the paper + -- |-inst returns a rho-type + -> (HsExpr GhcTc, AppCtxt) + -> TcSigmaType -> [HsExprArg 'TcpRn] + -> TcM ( [HsExprArg 'TcpInst] + , TcSigmaType ) -- Does not instantiate trailing invisible foralls +-- This crucial function implements the |-inst judgement in Fig 4, plus the +-- modification in Fig 5, of the QL paper: +-- "A quick look at impredicativity" (ICFP'20). +tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args + = do { traceTc "tcInstFun" (vcat [ text "tc_fun" <+> ppr tc_fun + , text "fun_sigma" <+> ppr fun_sigma + , text "fun_ctxt" <+> ppr fun_ctxt + , text "args:" <+> ppr rn_args + , text "do_ql" <+> ppr do_ql ]) + ; go 1 [] fun_sigma rn_args } + where + fun_orig = case fun_ctxt of + VAExpansion (OrigStmt{}) _ _ -> DoOrigin + VAExpansion (OrigPat pat) _ _ -> DoPatOrigin pat + VAExpansion (OrigExpr e) _ _ -> exprCtOrigin e + VACall e _ _ -> exprCtOrigin e + + -- These are the type variables which must be instantiated to concrete + -- types. See Note [Representation-polymorphic Ids with no binding] + -- in GHC.Tc.Utils.Concrete + fun_conc_tvs + | HsVar _ (L _ fun_id) <- tc_fun + = idConcreteTvs fun_id + -- Recall that DataCons are represented using ConLikeTc at GhcTc stage, + -- see Note [Typechecking data constructors] in GHC.Tc.Gen.Head. + | XExpr (ConLikeTc (RealDataCon dc) _ _) <- tc_fun + = dataConConcreteTyVars dc + | otherwise + = noConcreteTyVars + + -- Count value args only when complaining about a function + -- applied to too many value args + -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify. + n_val_args = count isHsValArg rn_args + + fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] + = case tc_fun of + HsHole _ -> True + _ -> False + + inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool + -- True <=> instantiate a tyvar that has this ForAllTyFlag + inst_fun [] | inst_final = isInvisibleForAllTyFlag + | otherwise = const False + inst_fun (EValArg {} : _) = isInvisibleForAllTyFlag + inst_fun _ = isInferredForAllTyFlag + + ----------- + go, go1 :: Int -- Value-argument position of next arg + -> [HsExprArg 'TcpInst] -- Accumulator, reversed + -> TcSigmaType -> [HsExprArg 'TcpRn] + -> TcM ([HsExprArg 'TcpInst], TcSigmaType) + + -- go: If fun_ty=kappa, look it up in Theta + go pos acc fun_ty args + | Just kappa <- getTyVar_maybe fun_ty + , isQLInstTyVar kappa + = do { cts <- readMetaTyVar kappa + ; case cts of + Indirect fun_ty' -> go pos acc fun_ty' args + Flexi -> go1 pos acc fun_ty args } + | otherwise + = go1 pos acc fun_ty args + + -- go1: fun_ty is not filled-in instantiation variable + -- ('go' dealt with that case) + + -- Handle out-of-scope functions gracefully + go1 pos acc fun_ty (arg : rest_args) + | fun_is_out_of_scope, looks_like_type_arg arg -- See Note [VTA for out-of-scope functions] + = go pos acc fun_ty rest_args + + -- Rule IALL from Fig 4 of the QL paper; applies even if args = [] + -- Instantiate invisible foralls and dictionaries. + -- c.f. GHC.Tc.Utils.Instantiate.topInstantiate + go1 pos acc fun_ty args + | (tvs, body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty + , (theta, body2) <- if inst_fun args Inferred + then tcSplitPhiTy body1 + else ([], body1) + -- inst_fun args Inferred: dictionary parameters are like Inferred foralls + -- E.g. #22908: f :: Foo => blah + -- No foralls! But if inst_final=False, don't instantiate + , let no_tvs = null tvs + no_theta = null theta + , not (no_tvs && no_theta) + = do { (_inst_tvs, wrap, fun_rho) <- + -- addHeadCtxt: important for the class constraints + -- that may be emitted from instantiating fun_sigma + addHeadCtxt fun_ctxt $ + instantiateSigma fun_orig fun_conc_tvs tvs theta body2 + -- See Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. + -- NB: we are doing this even when "acc" is not empty, + -- to handle e.g. + -- + -- badTup :: forall r (a :: TYPE r). a -> (# Int, a #) + -- badTup = (# , #) @LiftedRep + -- + -- in which we already have instantiated the first RuntimeRep + -- argument of (#,#) to @LiftedRep, but want to rule out the + -- second instantiation @r. + + ; go pos (addArgWrap wrap acc) fun_rho args } + -- Going around again means we deal easily with + -- nested forall a. Eq a => forall b. Show b => blah + + -- Rule IRESULT from Fig 4 of the QL paper; no more arguments + go1 _pos acc fun_ty [] + = do { traceTc "tcInstFun:ret" (ppr fun_ty) + ; return (reverse acc, fun_ty) } + + -- Rule ITVDQ from the GHC Proposal #281 + go1 pos acc fun_ty ((EValArg { ea_arg = arg }) : rest_args) + | Just (tvb, body) <- tcSplitForAllTyVarBinder_maybe fun_ty + = assertPpr (binderFlag tvb == Required) (ppr fun_ty $$ ppr arg) $ + -- Any invisible binders have been instantiated by IALL above, + -- so this forall must be visible (i.e. Required) + do { (ty_arg, inst_body) <- tcVDQ fun_conc_tvs (tvb, body) arg + ; let wrap = mkWpTyApps [ty_arg] + ; go (pos+1) (addArgWrap wrap acc) inst_body rest_args } + + go1 pos acc fun_ty (EWrap w : args) + = go1 pos (EWrap w : acc) fun_ty args + + go1 pos acc fun_ty (EPrag sp prag : args) + = go1 pos (EPrag sp prag : acc) fun_ty args + + -- Rule ITYARG from Fig 4 of the QL paper + go1 pos acc fun_ty ( ETypeArg { ea_ctxt = ctxt, ea_hs_ty = hs_ty } + : rest_args ) + = do { (ty_arg, inst_ty) <- tcVTA fun_conc_tvs fun_ty hs_ty + ; let arg' = ETypeArg { ea_ctxt = ctxt, ea_hs_ty = hs_ty, ea_ty_arg = ty_arg } + ; go pos (arg' : acc) inst_ty rest_args } + + -- Rule IVAR from Fig 4 of the QL paper: + go1 pos acc fun_ty args@(EValArg {} : _) + | Just kappa <- getTyVar_maybe fun_ty + , isQLInstTyVar kappa + = -- Function type was of form f :: forall a b. t1 -> t2 -> b + -- with 'b', one of the quantified type variables, in the corner + -- but the call applies it to three or more value args. + -- Suppose b is instantiated by kappa. Then we want to make fresh + -- instantiation variables nu1, nu2, and set kappa := nu1 -> nu2 + -- + -- In principle what is happening here is not unlike matchActualFunTys + -- but there are many small differences: + -- - We know that the function type in unfilled meta-tyvar + -- matchActualFunTys is much more general, has a loop, etc. + -- - We must be sure to actually update the variable right now, + -- not defer in any way, because this is a QL instantiation variable. + -- It's easier just to do the job directly here. + do { arg_tys <- zipWithM new_arg_ty (leadingValArgs args) [pos..] + ; res_ty <- newOpenFlexiTyVarTy + ; let fun_ty' = mkScaledFunTys arg_tys res_ty + + -- Fill in kappa := nu_1 -> .. -> nu_n -> res_nu + -- NB: kappa is uninstantiated ('go' already checked that) + ; kind_co <- unifyKind Nothing liftedTypeKind (tyVarKind kappa) + -- unifyKind: see (UQL3) in Note [QuickLook unification] + ; liftZonkM (writeMetaTyVar kappa (mkCastTy fun_ty' kind_co)) + + ; let co_wrap = mkWpCastN (mkGReflLeftCo Nominal fun_ty' kind_co) + acc' = addArgWrap co_wrap acc + -- Suppose kappa :: kk + -- Then fun_ty :: kk, fun_ty' :: Type, kind_co :: Type ~ kk + -- co_wrap :: (fun_ty' |> kind_co) ~ fun_ty' + + ; go pos acc' fun_ty' args } + + -- Rule IARG from Fig 4 of the QL paper: + go1 pos acc fun_ty + (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args) + = do { let herald = case fun_ctxt of + VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun + _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg) + ; (wrap, arg_ty, res_ty) <- + -- NB: matchActualFunTy does the rep-poly check. + -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int + -- In an application (f x), we need 'x' to have a fixed runtime + -- representation; matchActualFunTy checks that when + -- taking apart the arrow type (a -> Int). + matchActualFunTy herald + (Just $ HsExprTcThing tc_fun) + (n_val_args, fun_sigma) fun_ty + + ; arg' <- quickLookArg do_ql ctxt arg arg_ty + ; let acc' = arg' : addArgWrap wrap acc + ; go (pos+1) acc' res_ty rest_args } + + new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType) + -- Make a fresh nus for each argument in rule IVAR + new_arg_ty (L _ arg) i + = do { arg_nu <- newOpenFlexiFRRTyVarTy $ + FRRExpectedFunTy (ExpectedFunTyArg (HsExprTcThing tc_fun) arg) i + -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc], + -- thereby ensuring that the arguments have concrete runtime representations + + ; mult_ty <- newFlexiTyVarTy multiplicityTy + -- mult_ty: e need variables for argument multiplicities (#18731) + -- Otherwise, 'undefined x' wouldn't be linear in x + + ; return (mkScaled mult_ty arg_nu) } + +-- Is the argument supposed to instantiate a forall? +-- +-- In other words, given a function application `fn arg`, +-- can we look at the `arg` and conclude that `fn :: forall x. t` +-- or `fn :: forall x -> t`? +-- +-- This is a conservative heuristic that returns `False` for "don't know". +-- Used to improve error messages only. +-- See Note [VTA for out-of-scope functions]. +looks_like_type_arg :: HsExprArg 'TcpRn -> Bool +looks_like_type_arg ETypeArg{} = + -- The argument is clearly supposed to instantiate an invisible forall, + -- i.e. when we see `f @a`, we expect `f :: forall x. t`. + True +looks_like_type_arg EValArg{ ea_arg = L _ e } = + -- Check if the argument is supposed to instantiate a visible forall, + -- i.e. when we see `f (type Int)`, we expect `f :: forall x -> t`, + -- but not if we see `f True`. + -- We can't say for sure though. Part 2 of GHC Proposal #281 allows + -- type arguments without the `type` qualifier, so `f True` could + -- instantiate `forall (b :: Bool) -> t`. + case stripParensHsExpr e of + HsEmbTy _ _ -> True + _ -> False +looks_like_type_arg _ = False + +addArgCtxt :: AppCtxt -> LHsExpr GhcRn + -> TcM a -> TcM a +-- There are four cases: +-- 1. In the normal case, we add an informative context +-- "In the third argument of f, namely blah" +-- 2. If we are deep inside generated code (`isGeneratedCode` is `True`) +-- or if all or part of this particular application is an expansion +-- `VAExpansion`, just use the less-informative context +-- "In the expression: arg" +-- Unless the arg is also a generated thing, in which case do nothing. +-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr +-- 3. We are in an expanded `do`-block's non-bind statement +-- we simply add the statement context +-- "In the statement of the `do`-block .." +-- 4. We are in an expanded do block's bind statement +-- a. Then either we are typechecking the first argument of the bind which is user located +-- so we set the location to be that of the argument +-- b. Or, we are typechecking the second argument which would be a generated lambda +-- so we set the location to be whatever the location in the context is +-- See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do +-- For future: we need a cleaner way of doing this bit of adding the right error context. +-- There is a delicate dance of looking at source locations and reconstructing +-- whether the piece of code is a `do`-expanded code or some other expanded code. +addArgCtxt ctxt (L arg_loc arg) thing_inside + = do { in_generated_code <- inGeneratedCode + ; case ctxt of + VACall fun arg_no _ | not in_generated_code + -> do setSrcSpanA arg_loc $ + addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $ + thing_inside + + VAExpansion (OrigStmt (L _ stmt@(BindStmt {}))) _ loc + | isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=) + -> setSrcSpan loc $ + addStmtCtxt stmt $ + thing_inside + | otherwise -- This arg is the first argument to generated (>>=) + -> setSrcSpanA arg_loc $ + addStmtCtxt stmt $ + thing_inside + VAExpansion (OrigStmt (L loc stmt)) _ _ + -> setSrcSpanA loc $ + addStmtCtxt stmt $ + thing_inside + + _ -> setSrcSpanA arg_loc $ + addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated + thing_inside } + +{- ********************************************************************* +* * + Visible type application +* * +********************************************************************* -} + +-- See Note [Visible type application and abstraction] +tcVTA :: ConcreteTyVars + -- ^ Type variables that must be instantiated to concrete types. + -- + -- See Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. + -> TcType -- ^ Function type + -> LHsWcType GhcRn -- ^ Argument type + -> TcM (TcType, TcType) +-- Deal with a visible type application +-- The function type has already had its Inferred binders instantiated +tcVTA conc_tvs fun_ty hs_ty + | Just (tvb, inner_ty) <- tcSplitForAllTyVarBinder_maybe fun_ty + , binderFlag tvb == Specified + = do { tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_ty } + + | otherwise + = do { (_, fun_ty) <- liftZonkM $ zonkTidyTcType emptyTidyEnv fun_ty + ; failWith $ TcRnInvalidTypeApplication fun_ty hs_ty } + +-- See Note [Visible type application and abstraction] +tcVDQ :: ConcreteTyVars -- See Note [Representation-polymorphism checking built-ins] + -> (ForAllTyBinder, TcType) -- Function type + -> LHsExpr GhcRn -- Argument type + -> TcM (TcType, TcType) +tcVDQ conc_tvs (tvb, inner_ty) arg + = do { hs_wc_ty <- expr_to_type arg + ; tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_wc_ty } + +-- Convert a HsExpr into the equivalent HsType. +-- See [RequiredTypeArguments and the T2T mapping] +expr_to_type :: LHsExpr GhcRn -> TcM (LHsWcType GhcRn) +expr_to_type earg = + case stripParensLHsExpr earg of + L _ (HsEmbTy _ hs_ty) -> + -- The entire type argument is guarded with the `type` herald, + -- e.g. `vfun (type (Maybe Int))`. This special case supports + -- named wildcards. See Note [Wildcards in the T2T translation] + return hs_ty + e -> + -- The type argument is not guarded with the `type` herald, or perhaps + -- only parts of it are, e.g. `vfun (Maybe Int)` or `vfun (Maybe (type Int))`. + -- Apply a recursive T2T transformation. + HsWC [] <$> go e + <* failIfErrsM -- Suppress unhelpful errors that arise after a failed T2T + where + go :: LHsExpr GhcRn -> TcM (LHsType GhcRn) + go (L _ (HsEmbTy _ t)) = + -- HsEmbTy means there is an explicit `type` herald, e.g. vfun :: forall a -> blah + -- and the call vfun (type Int) + -- or vfun (Int -> type Int) + -- The T2T transformation can simply discard the herald and use the embedded type. + unwrap_wc t + go (L l (HsFunArr _ mult arg res)) = + do { arg' <- go arg + ; mult' <- go_arrow mult + ; res' <- go res + ; return (L l (HsFunTy noExtField mult' arg' res'))} + where + go_arrow :: HsMultAnnOf (LHsExpr GhcRn) GhcRn -> TcM (HsMultAnn GhcRn) + go_arrow (HsUnannotated _) = pure (HsUnannotated noExtField) + go_arrow (HsLinearAnn{}) = pure (HsLinearAnn noExtField) + go_arrow (HsExplicitMult _ exp) = HsExplicitMult noExtField <$> go exp + go (L l (HsForAll _ tele expr)) = + do { ty <- go expr + ; return (L l (HsForAllTy noExtField tele ty))} + go (L l (HsQual _ (L ann ctxt) expr)) = + do { ctxt' <- mapM go ctxt + ; ty <- go expr + ; return (L l (HsQualTy noExtField (L ann ctxt') ty)) } + go (L l (HsVar _ lname)) = + -- GHC Proposal #281, section 7.5 "T2T-Mapping": + -- variables and constructors (regardless of their namespace) + -- are mapped directly, without modification. + do { detect_puns lname + ; return (L l (HsTyVar noAnn NotPromoted lname)) } + go (L l (HsApp _ lhs rhs)) = + do { lhs' <- go lhs + ; rhs' <- go rhs + ; return (L l (HsAppTy noExtField lhs' rhs')) } + go (L l (HsAppType _ lhs rhs)) = + do { lhs' <- go lhs + ; rhs' <- unwrap_wc rhs + ; return (L l (HsAppKindTy noExtField lhs' rhs')) } + go (L l e@(OpApp _ lhs op rhs)) = + do { lhs' <- go lhs + ; op' <- go op + ; rhs' <- go rhs + ; op_id <- unwrap_op_tv op' + ; return (L l (HsOpTy noExtField NotPromoted lhs' op_id rhs')) } + where + unwrap_op_tv (L _ (HsTyVar _ _ op_id)) = return op_id + unwrap_op_tv _ = failWith $ TcRnIllformedTypeArgument (L l e) + go (L l (HsOverLit _ lit)) + | Just tylit <- tyLitFromOverloadedLit (ol_val lit) + = return (L l (HsTyLit noExtField tylit)) + go (L l (HsLit _ lit)) + | Just tylit <- tyLitFromLit lit + = return (L l (HsTyLit noExtField tylit)) + go (L l (ExplicitTuple _ tup_args boxity)) + -- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be promoted + | isBoxed boxity + , Just es <- tupArgsPresent_maybe tup_args + = do { ts <- traverse go es + ; return (L l (HsExplicitTupleTy noExtField NotPromoted ts)) } + go (L l (ExplicitList _ es)) = + do { ts <- traverse go es + ; return (L l (HsExplicitListTy noExtField NotPromoted ts)) } + go (L l (ExprWithTySig _ e sig_ty)) = + do { t <- go e + ; sig_ki <- (unwrap_sig <=< unwrap_wc) sig_ty + ; return (L l (HsKindSig noAnn t sig_ki)) } + where + unwrap_sig :: LHsSigType GhcRn -> TcM (LHsType GhcRn) + unwrap_sig (L _ (HsSig _ HsOuterImplicit{hso_ximplicit=bndrs} body)) + | null bndrs = return body + | otherwise = illegal_implicit_tvs bndrs + unwrap_sig (L l (HsSig _ HsOuterExplicit{hso_bndrs=bndrs} body)) = + return $ L l (HsForAllTy noExtField (HsForAllInvis noAnn bndrs) body) + go (L l (HsPar _ e)) = + do { t <- go e + ; return (L l (HsParTy noAnn t)) } + go (L l (HsUntypedSplice splice_result splice)) + | HsUntypedSpliceTop finalizers e <- splice_result + = do { t <- go (L l e) + ; let splice_result' = HsUntypedSpliceTop finalizers t + ; return (L l (HsSpliceTy splice_result' splice)) } + go (L l (HsHole (HoleVar (L _ rdr)))) + | isUnderscore occ = return (L l (HsWildCardTy noExtField)) + | startsWithUnderscore occ = + -- See Note [Wildcards in the T2T translation] + do { wildcards_enabled <- xoptM LangExt.NamedWildCards + ; if wildcards_enabled + then illegal_wc rdr + else not_in_scope } + | otherwise = not_in_scope + where occ = occName rdr + not_in_scope = failWith $ TcRnNotInScope NotInScope rdr + go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _))) = + -- Use the original, user-written expression (before expansion). + -- Example. Say we have vfun :: forall a -> blah + -- and the call vfun (Maybe [1,2,3]) + -- expanded to vfun (Maybe (fromListN 3 [1,2,3])) + -- (This happens when OverloadedLists is enabled). + -- The expanded expression can't be promoted, as there is no type-level + -- equivalent of fromListN, so we must use the original. + go (L l orig) + go e = failWith $ TcRnIllformedTypeArgument e + + detect_puns :: LocatedN (WithUserRdr Name) -> TcM () + -- GHC Proposal #281, section 7.5 "T2T-Mapping": + -- there should be no variable of the same name but from + -- a different namespace, or else raise an ambiguity error + -- (does not apply to constructors) + detect_puns (L l (WithUserRdr rdr _)) + | isTermVarOrFieldNameSpace (rdrNameSpace rdr) + , Just promoted_rdr <- promoteRdrName rdr + = do { envs <- getRdrEnvs + ; whenIsJust (lookup_rdr envs rdr) $ \unpromoted -> + whenIsJust (lookup_rdr envs promoted_rdr) $ \promoted -> + addErrAt (locA l) $ + TcRnIllegalPunnedVarOccInTypeArgument { illegalPunTermName = unpromoted + , illegalPunTypeName = promoted } } + | otherwise = return () + + lookup_rdr :: (GlobalRdrEnv, LocalRdrEnv) -> RdrName -> Maybe ResolvedNameInfo + lookup_rdr (gbl_env, lcl_env) rdr + | Just name <- lookupLocalRdrEnv lcl_env rdr + = Just (ResolvedNameInfo [] rdr name) + | gres@(gre:_) <- lookupGRE gbl_env (LookupRdrName rdr (RelevantGREsFOS WantNormal)) + = Just (ResolvedNameInfo gres rdr (gre_name gre)) + | otherwise = Nothing + + unwrap_wc :: HsWildCardBndrs GhcRn t -> TcM t + unwrap_wc (HsWC wcs t) + = do { mapM_ (illegal_wc . nameRdrName) wcs + ; return t } + + illegal_wc :: RdrName -> TcM t + illegal_wc rdr = failWith $ TcRnIllegalNamedWildcardInTypeArgument rdr + + illegal_implicit_tvs :: [Name] -> TcM t + illegal_implicit_tvs tvs + = do { mapM_ (addErr . TcRnIllegalImplicitTyVarInTypeArgument . nameRdrName) tvs + ; failM } + +{- Note [RequiredTypeArguments and the T2T mapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "T2T-Mapping" section of GHC Proposal #281 introduces a term-to-type transformation +that comes into play when we typecheck function applications to required type arguments. +Say we have a function that expects a required type argument, vfun :: forall a -> ... +then it is possible to call it as follows: + + vfun (Maybe Int) + +The Maybe Int argument is parsed and renamed as a term. There is no syntactic marker +to tell GHC that it is actually a type argument. We only discover this by the time +we get to type checking, where we know that f's type has a visible forall at the front, +so we are expecting a type argument. More precisely, this happens in tcVDQ in GHC/Tc/Gen/App.hs: + + tcVDQ :: ConcreteTyVars -- See Note [Representation-polymorphism checking built-ins] + -> (ForAllTyBinder, TcType) -- Function type + -> LHsExpr GhcRn -- Argument type + -> TcM (TcType, TcType) + +What we want is a type to instantiate the forall-bound variable. But what we have is an HsExpr, +and we need to convert it to an HsType in order to reuse the same code paths as we use for +checking f @ty (see tc_inst_forall_arg). + + f (Maybe Int) + -- ^^^^^^^^^ + -- parsed and renamed as: HsApp (HsVar "Maybe") (HsVar "Int") :: HsExpr GhcRn + -- must be converted to: HsTyApp (HsTyVar "Maybe") (HsTyVar "Int") :: HsType GhcRn + +We do this using a helper function: + + expr_to_type :: LHsExpr GhcRn -> TcM (LHsWcType GhcRn) + +This conversion is in the TcM monad because +* It can fail, if the expression is not convertible to a type. + vfun [x | x <- xs] Can't convert list comprehension to a type + vfun (\x -> x) Can't convert a lambda to a type +* It needs to check for LangExt.NamedWildCards to generate an appropriate + error message for HsHole (HsVar ...). + vfun _a Not in scope: ‘_a’ + (NamedWildCards disabled) + vfun _a Illegal named wildcard in a required type argument: ‘_a’ + (NamedWildCards enabled) + +Note [Wildcards in the T2T translation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose f1 :: forall a b. blah + f2 :: forall a b -> blah + +Consider the terms + f1 @_ @(Either _ _) + f2 (type _) (type (Either _ _)) +Those `_` wildcards are type wildcards, each standing for a monotype. +All good. + +Now consider this, with -XNamedWildCards: + f1 @_a @(Either _a _a) + f2 (type _a) (type (Either _a _a)) +Those `_a` are "named wildcards", specified by the user manual like this: "All +occurrences of the same named wildcard within one type signature will unify to +the same type". Note "within one signature". So each type argument is considered +separately, and the examples mean the same as: + f1 @_a1 @(Either _a2 _a2) + f2 (type _a1) (type (Either _a2 _a2)) +The repeated `_a2` ensures that the two arguments of `Either` are the same type; +but there is no connection with `_a1`. (NB: `_a1` and `_a2` only scope within +their respective type, no further.) + +Now, consider the T2T translation for + f2 _ (Either _ _) +This is fine: the term wildcard `_` is translated to a type wildcard, so we get +the same as if we had written + f2 (type _) (type (Either _ _)) + +But what about /named/ wildcards? + f2 _a (Either _a _a) +Now we are in difficulties. The renamer looks for a /term/ variable `_a` in scope, +and won't find one. Even if it did, the three `_a`'s would not be renamed separately +as above. + +Conclusion: we treat a named wildcard in the T2T translation as an error. If you +want that, use a `(type ty)` argument instead. +-} + +tc_inst_forall_arg :: ConcreteTyVars -- See Note [Representation-polymorphism checking built-ins] + -> (ForAllTyBinder, TcType) -- Function type + -> LHsWcType GhcRn -- Argument type + -> TcM (TcType, TcType) +tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_ty + = do { let tv = binderVar tvb + kind = tyVarKind tv + tv_nm = tyVarName tv + mb_conc = lookupNameEnv conc_tvs tv_nm + ; ty_arg0 <- tcHsTypeApp hs_ty kind + + -- Is this type variable required to be instantiated to a concrete type? + -- If so, ensure that that is the case. + -- + -- See [Wrinkle: VTA] in Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. + ; th_lvl <- getThLevel + ; ty_arg <- case mb_conc of + Nothing -> return ty_arg0 + Just conc + -- See [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + | TypedBrack {} <- th_lvl + -> return ty_arg0 + | otherwise + -> + -- Example: user wrote e.g. (#,#) @(F Bool) for a type family F. + -- Emit [W] F Bool ~ kappa[conc] and pretend the user wrote (#,#) @kappa. + coercionRKind <$> unifyConcrete (occNameFS $ getOccName $ tv_nm) conc ty_arg0 + + ; let fun_ty = mkForAllTy tvb inner_ty + in_scope = mkInScopeSet (tyCoVarsOfTypes [fun_ty, ty_arg]) + insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty + -- This substitution is well-kinded even when inner_ty + -- is not fully zonked, because ty_arg is fully zonked. + -- See Note [Type application substitution]. + + ; traceTc "tc_inst_forall_arg (VTA/VDQ)" ( + vcat [ text "fun_ty" <+> ppr fun_ty + , text "tv" <+> ppr tv <+> dcolon <+> debugPprType kind + , text "ty_arg" <+> debugPprType ty_arg <+> dcolon + <+> debugPprType (typeKind ty_arg) + , text "inner_ty" <+> debugPprType inner_ty + , text "insted_ty" <+> debugPprType insted_ty ]) + ; return (ty_arg, insted_ty) } + +{- Note [Visible type application and abstraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC supports the types + forall {a}. a -> t -- ForAllTyFlag is Inferred + forall a. a -> t -- ForAllTyFlag is Specified + forall a -> a -> t -- ForAllTyFlag is Required + +The design of type abstraction and type application for those types has gradually +evolved over time, and is based on the following papers and proposals: + - "Visible Type Application" + https://richarde.dev/papers/2016/type-app/visible-type-app.pdf + - "Type Variables in Patterns" + https://richarde.dev/papers/2018/pat-tyvars/pat-tyvars.pdf + - "Modern Scoped Type Variables" + https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0448-type-variable-scoping.rst + - "Visible forall in types of terms" + https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0281-visible-forall.rst + +Here we offer an overview of the design mixed with commentary on the +implementation status. The proposals have not been fully implemented at the +time of writing this Note (see "not implemented" in the rest of this Note). + +Now consider functions + fi :: forall {a}. a -> t -- Inferred: type argument cannot be supplied + fs :: forall a. a -> t -- Specified: type argument may be supplied + fr :: forall a -> a -> t -- Required: type argument must be supplied + +At a call site we may have calls looking like this + fi True -- Inferred: no visible type argument + fs True -- Specified: type argument omitted + fs @Bool True -- Specified: type argument supplied + fr (type Bool) True -- Required: type argument is compulsory, `type` qualifier used + fr Bool True -- Required: type argument is compulsory, `type` qualifier omitted + +At definition sites we may have type /patterns/ to abstract over type variables + fi x = rhs -- Inferred: no type pattern + fs x = rhs -- Specified: type pattern omitted + fs @a (x :: a) = rhs -- Specified: type pattern supplied + fr (type a) (x :: a) = rhs -- Required: type pattern is compulsory, `type` qualifier used + fr a (x :: a) = rhs -- Required: type pattern is compulsory, `type` qualifier omitted + +Type patterns in lambdas mostly work the same way as they do in a function LHS, +except for @-binders + OK: fs = \ x -> rhs -- Specified: type pattern omitted + Bad: fs = \ @a (x :: a) -> rhs -- Specified: type pattern supplied + OK: fr = \ (type a) (x :: a) -> rhs -- Required: type pattern is compulsory, `type` qualifier used + OK: fr = \ a (x :: a) -> rhs -- Required: type pattern is compulsory, `type` qualifier omitted + +When it comes to @-binders in lambdas, they do work, but only in a limited set +of circumstances: + * the lambda occurs as an argument to a higher-rank function or constructor + higher-rank function: h :: (forall a. blah) -> ... + call site: x = h (\ @a -> ... ) + * the lambda is annotated with an inline type signature: + (\ @a -> ... ) :: forall a. blah + * the lambda is a field in a data structure, whose type is impredicative + [ \ @a -> ... ] :: [forall a. blah] + * the @-binder is not the first binder in the lambda: + \ x @a -> ... + +Type patterns may also occur in a constructor pattern. Consider the following data declaration + data T where + MkTI :: forall {a}. Show a => a -> T -- Inferred + MkTS :: forall a. Show a => a -> T -- Specified + MkTR :: forall a -> Show a => a -> T -- Required (NB: not implemented) + +Matching on its constructors may look like this + f (MkTI x) = rhs -- Inferred: no type pattern + f (MkTS x) = rhs -- Specified: type pattern omitted + f (MkTS @a (x :: a)) = rhs -- Specified: type pattern supplied + f (MkTR (type a) (x :: a)) = rhs -- Required: type pattern is compulsory, `type` qualifier used (NB: not implemented) + f (MkTR a (x :: a)) = rhs -- Required: type pattern is compulsory, `type` qualifier omitted (NB: not implemented) + +The moving parts are as follows: + (abbreviations used: "c.o." = "constructor of") + +Syntax of types +--------------- +* The types are all initially represented with HsForAllTy (c.o. HsType). + The binders are in the (hst_tele :: HsForAllTelescope pass) field of the HsForAllTy + At this stage, we have + forall {a}. t -- HsForAllInvis (c.o. HsForAllTelescope) and InferredSpec (c.o. Specificity) + forall a. t -- HsForAllInvis (c.o. HsForAllTelescope) and SpecifiedSpec (c.o. Specificity) + forall a -> t -- HsForAllVis (c.o. HsForAllTelescope) + +* By the time we get to checking applications/abstractions (e.g. GHC.Tc.Gen.App) + the types have been kind-checked (e.g. by tcLHsType) into ForAllTy (c.o. Type). + At this stage, we have: + forall {a}. t -- ForAllTy (c.o. Type) and Inferred (c.o. ForAllTyFlag) + forall a. t -- ForAllTy (c.o. Type) and Specified (c.o. ForAllTyFlag) + forall a -> t -- ForAllTy (c.o. Type) and Required (c.o. ForAllTyFlag) + +Syntax of applications in HsExpr +-------------------------------- +* We represent type applications in HsExpr like this (ignoring parameterisation) + data HsExpr = HsApp HsExpr HsExpr -- (f True) (plain function application) + | HsAppType HsExpr HsType -- (f @True) (function application with `@`) + | HsEmbTy HsType -- (type Int) (embed a type into an expression with `type`) + | ... + +* So (f @ty) is represented, just as you might expect: + HsAppType f ty + +* But (f (type ty)) is represented by: + HsApp f (HsEmbTy ty) + + Why the difference? Because we /also/ need to express these /nested/ uses of `type`: + + g (Maybe (type Int)) -- valid for g :: forall (a :: Type) -> t + g (Either (type Int) (type Bool)) -- valid for g :: forall (a :: Type) -> t + + This nesting makes `type` rather different from `@`. Remember, the HsEmbTy mainly just + switches namespace, and is subject to the term-to-type transformation. + +Syntax of abstractions in Pat +----------------------------- +* Type patterns are represented in Pat roughly like this + data Pat = ConPat ConLike [Pat] -- (Con @tp1 @tp2 p1 p2) (constructor pattern) + | EmbTyPat HsTyPat -- (type tp) (embed a type into a pattern with `type`) + | InvisPat HsTyPat -- (@tp) (invisible type pattern) + | ... + data HsTyPat = HsTP LHsType + (In ConPat, the type and term arguments are actually inside HsConPatDetails.) + + * Similar to HsAppType in HsExpr, InvisPat in ConPat is used for @ty arguments + * Similar to HsEmbTy in HsExpr, EmbTyPat lets you embed a type in a pattern + +* Examples: + \ (MkT @a (x :: a)) -> rhs -- ConPat (c.o. Pat) and InvisPat (c.o. Pat) + \ (type a) (x :: a) -> rhs -- EmbTyPat (c.o. Pat) + \ a (x :: a) -> rhs -- VarPat (c.o. Pat) + \ @a (x :: a) -> rhs -- InvisPat (c.o. Pat) + +* A HsTyPat is not necessarily a plain variable. At the very least, + we support kind signatures and wildcards: + \ (type _) -> rhs + \ (type (b :: Bool)) -> rhs + \ (type (_ :: Bool)) -> rhs + But in constructor patterns we also support full-on types + \ (P @(a -> Either b c)) -> rhs + All these forms are represented with HsTP (c.o. HsTyPat). + +Renaming type applications +-------------------------- +rnExpr delegates renaming of type arguments to rnHsWcType if possible: + f @t -- HsAppType, t is renamed with rnHsWcType + f (type t) -- HsApp and HsEmbTy, t is renamed with rnHsWcType + +But what about: + f t -- HsApp, no HsEmbTy +We simply rename `t` as a term using a recursive call to rnExpr; in particular, +the type of `f` does not affect name resolution (Lexical Scoping Principle). +We will later convert `t` from a `HsExpr` to a `Type`, see "Typechecking type +applications" later in this Note. The details are spelled out in the "Resolved +Syntax Tree" and "T2T-Mapping" sections of GHC Proposal #281. + +Renaming type abstractions +-------------------------- +rnPat delegates renaming of type arguments to rnHsTyPat if possible: + f (P @t) = rhs -- ConPat, t is renamed with rnHsTyPat + f (type t) = rhs -- EmbTyPat, t is renamed with rnHsTyPat + +But what about: + f t = rhs -- VarPat +The solution is as before (see previous section), mutatis mutandis. +Rename `t` as a pattern using a recursive call to `rnPat`, convert it +to a type pattern later. + +One particularly prickly issue is that of implicit quantification. Consider: + + f :: forall a -> ... + f t = ... -- binding site of `t` + where + g :: t -> t -- use site of `t` or a fresh variable? + g = ... + +Does the signature of `g` refer to `t` bound in `f`, or is it a fresh, +implicitly quantified variable? This is normally controlled by +ScopedTypeVariables, but in this example the renamer can't tell `t` from a term +variable. Only later (in the type checker) will we find out that it stands for +the forall-bound type variable `a`. So when RequiredTypeArguments is in effect, +we change implicit quantification to take term variables into account; that is, +we do not implicitly quantify the signature of `g` to `g :: forall t. t->t` +because of the term-level `t` that is in scope. +See Note [Term variable capture and implicit quantification]. + +Typechecking type applications +------------------------------ +Type applications are checked alongside ordinary function applications +in tcInstFun. + +First of all, we assume that the function type is known (i.e. not a metavariable) +and contains a `forall`. Consider: + f :: forall a. a -> a + f x = const x (f @Int 5) +If the type signature is removed, the definition results in an error: + Cannot apply expression of type ‘t1’ + to a visible type argument ‘Int’ + +The same principle applies to required type arguments: + f :: forall a -> a -> a + f (type a) x = const x (f (type Int) 5) +If the type signature is removed, the error is: + Illegal type pattern. + A type pattern must be checked against a visible forall. + +When the type of the function is known and contains a `forall`, all we need to +do is instantiate the forall-bound variable with the supplied type argument. +This is done by tcVTA (if Specified) and tcVDQ (if Required). + +tcVDQ unwraps the HsEmbTy and uses the type contained within it. Crucially, in +tcVDQ we know that we are expecting a type argument. This means that we can +support + f (Maybe Int) -- HsApp, no HsEmbTy +The type argument (Maybe Int) is represented as an HsExpr, but tcVDQ can easily +convert it to HsType. This conversion is called the "T2T-Mapping" in GHC +Proposal #281. + +Typechecking type abstractions +------------------------------ +Type abstractions are checked alongside ordinary patterns in GHC.Tc.Gen.Pat.tcMatchPats. +One of its inputs is a list of ExpPatType that has two constructors + * ExpFunPatTy ... -- the type A of a function A -> B + * ExpForAllPatTy ... -- the binder (a::A) of forall (a::A) -> B +so when we are checking + f :: forall a b -> a -> b -> ... + f (type a) (type b) (x :: a) (y :: b) = ... +our expected pattern types are + [ ExpForAllPatTy ... -- forall a -> + , ExpForAllPatTy ... -- forall b -> + , ExpFunPatTy ... -- a -> + , ExpFunPatTy ... -- b -> + ] + +The [ExpPatType] is initially constructed by GHC.Tc.Utils.Unify.matchExpectedFunTys, +by decomposing the type signature for `f` in our example. If we are given a +definition + g (type a) = ... +we never /infer/ a type g :: forall a -> blah. We can only /check/ +explicit type abstractions in terms. + +The [ExpPatType] allows us to use different code paths for type abstractions +and ordinary patterns: + * tc_pat :: Scaled ExpSigmaTypeFRR -> Checker (Pat GhcRn) (Pat GhcTc) + * tc_forall_pat :: Checker (Pat GhcRn, TcTyVar) (Pat GhcTc) + +tc_forall_pat unwraps the EmbTyPat and uses the type pattern contained +within it. This is another spot where the "T2T-Mapping" can take place, +allowing us to support + f a (x :: a) = rhs -- no EmbTyPat + +Type patterns in constructor patterns are handled in with tcConTyArg. +Both tc_forall_pat and tcConTyArg delegate most of the work to tcHsTyPat. + +Note [VTA for out-of-scope functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose 'wurble' is not in scope, and we have + (wurble @Int @Bool True 'x') + +Then the renamer will make (HsHole (HsVar "wurble")) for 'wurble', +and the typechecker will typecheck it with tcUnboundId, giving it +a type 'alpha', and emitting a deferred Hole constraint, to +be reported later. + +But then comes the visible type application. If we do nothing, we'll +generate an immediate failure (in tc_app_err), saying that a function +of type 'alpha' can't be applied to Bool. That's insane! And indeed +users complain bitterly (#13834, #17150.) + +The right error is the Hole, which has /already/ been emitted by +tcUnboundId. It later reports 'wurble' as out of scope, and tries to +give its type. + +Fortunately in tcInstFun we still have access to the function, so we +can check if it is a HsHole. We use this info to simply skip +over any visible type arguments. We'll /already/ have emitted a +Hole constraint; failing preserves that constraint. + +We do /not/ want to fail altogether in this case (via failM) because +that may abandon an entire instance decl, which (in the presence of +-fdefer-type-errors) leads to leading to #17792. + +What about required type arguments? Suppose we see + f (type Int) +where `f` is out of scope. Then again we don't want to crash because f's +type (which will be just a fresh unification variable) isn't a visible forall. +Instead we just skip the `(type Int)` argument, as before. + +Downside: the typechecked term has lost its visible type arguments; we +don't even kind-check them. But let's jump that bridge if we come to +it. Meanwhile, let's not crash! + +Note [Type application substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `tc_inst_forall_arg`, suppose we are checking a visible type +application `f @hs_ty`, where `f :: forall (a :: k). body`. We will: + * Compute `ty <- tcHsTypeApp hs_ty k` + * Then substitute `a :-> ty` in `body`. +Now, you might worry that `a` might not have the same kind as `ty`, so that the +substitution isn't kind-preserving. How can that happen? The kinds will +definitely be the same after zonking, and `ty` will be zonked (as this is +a postcondition of `tcHsTypeApp`). But the function type `forall a. body` +might not be fully zonked (hence the worry). + +But it's OK! During type checking, we don't require types to be well-kinded (without +zonking); we only require them to satsisfy the Purely Kinded Type Invariant (PKTI). +See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType. + +In the case of a type application: + * `forall a. body` satisfies the PKTI + * `ty` is zonked + * If we substitute a fully-zonked thing into an un-zonked Type that + satisfies the PKTI, the result still satisfies the PKTI. + +This last statement isn't obvious, but read +Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType. +The tricky case is when `body` contains an application of the form `a b1 ... bn`, +and we substitute `a :-> ty` where `ty` has fewer arrows in its kind than `a` does. +That can't happen: the call `tcHsTypeApp hs_ty k` would have rejected the +type application as ill-kinded. + +Historical remark: we used to require a stronger invariant than the PKTI, +namely that all types are well-kinded prior to zonking. In that context, we did +need to zonk `body` before performing the substitution above. See test case +#14158, as well as the discussion in #23661. +-} + +{- ********************************************************************* +* * + Quick Look +* * +********************************************************************* -} + +{- Note [Quick Look at value arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function quickLookArg implements the "QL argument" judgement of +the QL paper, in Fig 5 of "A quick look at impredicativity" (ICFP 2020), +rather directly. The key rule, implemented by `quickLookArg` is + + G |-h h:sg -- Find the type of the head + G |-inst sg;pis ~> phis;rho_r -- tcInstFun on the args + (A) rho = T sgs OR (B) fiv(phis) = emptyset -- can_do_ql + -------------------------------------- APP-QL + G |-ql h pis : rho ~> qlUnify( rho, rho_r ) + +(The paper uses a lightning-bolt where we use "ql".) The most straightforward +way to implement this rule for a call (f e1 ... en) would be: + + 1. Take a quick look at the argumets e1..en to guide instantiation + of the function f. + 2. Then typecheck e1..en from scratch. + +That's wasteful, because in Step 1, the quick look at each argument, say (g +h1..hm), involves instantiating `h` and taking a quick look at /its/ +arguments. Then in Step 2 we typecheck (g h1..hm) and again take a quick look +at its arguments. This is quadratic in the nesting depth of the arguments. + +Instead, after the quick look, we /save/ the work we have done in an EValArgQL +record, and /resume/ it later. The way to think of it is this: + + * `tcApp` typechecks an application. It uses `tcInstFun`, which in turn + calls `quickLookArg` on each value argument. + + * `quickLookArg` (which takes a quick look at the argument) + + - Does the "initial" part of `tcApp`, especially `tcInstFun` + + - Captures the result in an EValArgQL record + + - Later, `tcValArg` starts from the EValArgQL record, and + completes the job of typechecking the application + +This turned out to be more subtle than I expected. Wrinkles: + +(QLA1) `quickLookArg` decides whether or not premises (A) and (B) of the + quick-look-arg judgement APP-QL are satisfied; this is captured in + `arg_influences_enclosing_call`. + +(QLA2) We avoid zonking, so the `arg_influences_enclosing_call` sees the + argument type /before/ the QL substitution Theta is applied to it. So we + achieve argument-order independence for free (see 5.7 in the paper). See the + `isGuardedTy orig_arg_rho` test in `quickLookArg`. + +(QLA3) Deciding whether the premises are satisfied involves calling `tcInstFun` + (which takes quite some work becuase it calls quickLookArg on nested calls). + That's why we want to capture the work done, in EValArgQL. + + Do we really have to call `tcInstFun` before deciding (B) of + `arg_influences_enclosing_call`? Yes (#24686). + Suppose ids :: [forall a. a->a], and consider + (:) (reverse ids) blah + `tcApp` on the outer call will instantiate (:) with `kappa`, and take a + quick look at (reverse ids). Only after instantiating `reverse` with kappa2, + quick-looking at `ids` can we discover that (kappa2:=forall a. a->a), which + satisfies premise (B) of `arg_influence_enclosing_call`. + +(QLA4) When we resume typechecking an argument, in `tcValArg` on `EValArgQL` + + - Calling `tcInstFun` on the argument may have emitted some constraints, which + we carefully captured in `quickLookArg` and stored in the EValArgQL. We must + now emit them with `emitConstraints`. This must be done /under/ the skolemisation + of the argument's type (see `tcSkolemise` in `tcValArg` for EValArgQL { ...}. + Example: f :: (forall b. Ord b => b -> b -> Bool) -> ... + Call: f (==) + we must skolemise the argument type (forall b. Ord b => b -> b -> Bool) + before emitting the [W] Eq alpha constraint arising from the call to (==). + It will be solved from the Ord b! + + - quickLookArg may or may not have done `qlUnify` with the calling context. + If not (eaql_encl = False) must do so now. Example: choose [] ids, + where ids :: [forall a. a->a] + choose :: a -> a -> a + We instantiate choose with `kappa` and discover from `ids` that + (kappa = [forall a. a->a]). Now we resume typechecking argument [], and + we must take advantage of what we have now discovered about `kappa`, + to typecheck [] :: [forall a. a->a] + +(QLA5) In the quicklook pass, we don't scale multiplicities. Since arguments + aren't typechecked yet, we don't know their free variable usages + anyway. But, in a nested call, the head of an application chain is fully + typechecked. + + In order for the multiplicities in the head to be properly scaled, we store + the head's usage environment in the eaql_fun_ue field. Then, when we do the + full-typechecking pass, we can emit the head's usage environment where we + would have typechecked the head in a naive algorithm. + +(QLA6) `quickLookArg` is supposed to capture the result of partially typechecking + the argument, so it can be resumed later. "Capturing" should include all + generated type-class/equality constraints and Linear-Haskell usage info. There + are two calls in `quickLookArg1` that might generate such constraints: + + - `tcInferAppHead_maybe`. This can generat Linear-Haskell usage info, via + the call to `tcEmitBindingUsage` in `check_local_id`, which is called + indirectly by `tcInferAppHead_maybe`. + + In contrast, `tcInferAppHead_maybe` does not generate any type-class or + equality constraints, because it doesn't instantiate any functions. [But + see #25493 and #25494 for why this isn't quite true today.] + + - `tcInstFun` generates lots of type-class and equality constraints, as it + instantiates the function. But it generates no usage info, because that + comes only from the call to `check_local_id`, whose usage info is captured + in the call to `tcInferAppHead_maybe` in `quickLookArg1`. + + Conclusion: in quickLookArg1: + - capture usage information (but not constraints) + for the call to `tcInferAppHead_maybe` + - capture constraints (but not usage information) + for the call to `tcInstFun` + +-} + +quickLookArg :: QLFlag -> AppCtxt + -> LHsExpr GhcRn -- ^ Argument + -> Scaled TcSigmaTypeFRR -- ^ Type expected by the function + -> TcM (HsExprArg 'TcpInst) +-- See Note [Quick Look at value arguments] +quickLookArg NoQL ctxt larg orig_arg_ty + = skipQuickLook ctxt larg orig_arg_ty +quickLookArg DoQL ctxt larg orig_arg_ty + = do { is_rho <- tcIsDeepRho (scaledThing orig_arg_ty) + ; traceTc "qla" (ppr orig_arg_ty $$ ppr is_rho) + ; if not is_rho + then skipQuickLook ctxt larg orig_arg_ty + else quickLookArg1 ctxt larg orig_arg_ty } + +skipQuickLook :: AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType + -> TcM (HsExprArg 'TcpInst) +skipQuickLook ctxt larg arg_ty + = return (EValArg { ea_ctxt = ctxt + , ea_arg = larg + , ea_arg_ty = arg_ty }) + +whenQL :: QLFlag -> ZonkM () -> TcM () +whenQL DoQL thing_inside = liftZonkM thing_inside +whenQL NoQL _ = return () + +tcIsDeepRho :: TcType -> TcM Bool +-- This top-level zonk step, which is the reason we need a local 'go' loop, +-- is subtle. See Section 9 of the QL paper + +tcIsDeepRho ty + = do { ds_flag <- getDeepSubsumptionFlag + ; go ds_flag ty } + where + go ds_flag ty + | isSigmaTy ty = return False + + | Just kappa <- getTyVar_maybe ty + , isQLInstTyVar kappa + = do { info <- readMetaTyVar kappa + ; case info of + Indirect arg_ty' -> go ds_flag arg_ty' + Flexi -> return True } + + | Deep <- ds_flag + , Just (_, res_ty) <- tcSplitFunTy_maybe ty + = go ds_flag res_ty + + | otherwise = return True + +isGuardedTy :: TcType -> Bool +isGuardedTy ty + | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal + | Just {} <- tcSplitAppTy_maybe ty = True + | otherwise = False + +quickLookArg1 :: AppCtxt -> LHsExpr GhcRn + -> Scaled TcRhoType -- Deeply skolemised + -> TcM (HsExprArg 'TcpInst) +-- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper +quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) + = addArgCtxt ctxt larg $ -- Context needed for constraints + -- generated by calls in arg + do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg + + -- Step 1: get the type of the head of the argument + ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun + -- tcCollectingUsage: the use of an Id at the head generates usage-info + -- See the call to `tcEmitBindingUsage` in `check_local_id`. So we must + -- capture and save it in the `EValArgQL`. See (QLA6) in + -- Note [Quick Look at value arguments] + + ; traceTc "quickLookArg {" $ + vcat [ text "arg:" <+> ppr arg + , text "orig_arg_rho:" <+> ppr orig_arg_rho + , text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty + , text "args:" <+> ppr rn_args ] + + ; case mb_fun_ty of { + Nothing -> skipQuickLook ctxt larg sc_arg_ty ; -- fun is too complicated + Just (tc_fun, fun_sigma) -> + + -- step 2: use |-inst to instantiate the head applied to the arguments + do { let tc_head = (tc_fun, fun_ctxt) + ; do_ql <- wantQuickLook rn_fun + ; ((inst_args, app_res_rho), wanted) + <- captureConstraints $ + tcInstFun do_ql True tc_head fun_sigma rn_args + -- We must capture type-class and equality constraints here, but + -- not equality constraints. See (QLA6) in Note [Quick Look at + -- value arguments] + + ; traceTc "quickLookArg 2" $ + vcat [ text "arg:" <+> ppr arg + , text "orig_arg_rho:" <+> ppr orig_arg_rho + , text "app_res_rho:" <+> ppr app_res_rho ] + + -- Step 3: Check the two other premises of APP-lightning-bolt (Fig 5 in the paper) + -- Namely: (A) is orig_arg_rho is guarded + -- or: (B) fiv(app_res_rho) = emptyset + -- This tells us if the quick look at the argument yields information that + -- influences the enclosing function call + -- NB: guardedness is computed based on the original, + -- unzonked orig_arg_rho, so that we deliberately do + -- not exploit guardedness that emerges a result of QL on earlier args + -- We must do the anyFreeKappa test /after/ tcInstFun; see (QLA3). + ; arg_influences_enclosing_call + <- if isGuardedTy orig_arg_rho + then return True + else not <$> anyFreeKappa app_res_rho -- (B) + -- For (B) see Note [The fiv test in quickLookArg] + + -- Step 4: do quick-look unification if either (A) or (B) hold + -- NB: orig_arg_rho may not be zonked, but that's ok + ; when arg_influences_enclosing_call $ + qlUnify app_res_rho orig_arg_rho + + ; traceTc "quickLookArg done }" (ppr rn_fun) + + ; return (EValArgQL { eaql_ctxt = ctxt + , eaql_arg_ty = sc_arg_ty + , eaql_larg = larg + , eaql_tc_fun = tc_head + , eaql_fun_ue = fun_ue + , eaql_args = inst_args + , eaql_wanted = wanted + , eaql_encl = arg_influences_enclosing_call + , eaql_res_rho = app_res_rho }) }}} + +{- ********************************************************************* +* * + Folding over instantiation variables +* * +********************************************************************* -} + +{- Note [Monomorphise instantiation variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are done with Quick Look on a call, we must turn any un-unified +/instantiation/ variables into regular /unification/ variables. This is the +lower-case 'theta' (a mono-substitution) in the APP-DOWN rule of Fig 5 of the +Quick Look paper. + +We so this by look at the arguments, left to right, monomorphising the free +instantiation variables of the /type/ arguments of the call. Those type +arguments appear (only) in + * the `WpTyApp` components of + * the `HsWrapper` of + * a `EWrap` argument +See `qlMonoHsWrapper`. + +By going left to right, we are sure to monomorphise instantiation variables +before we encounter them in an argument type (in `tcValArg`). + +All instantiation variables for a call will be reachable from the type(s) +at which the function is instantiated -- i.e. those WpTyApps. Even instantiation +variables allocoated by tcInstFun itself, such as in the IRESULT rule, end up +connected to the original type(s) at which the function is instantiated. + +To monomorphise the free QL instantiation variables of a type, we use +`foldQLInstVars`. + +Wrinkles: + +(MIV1) When monomorphising an instantiation variable, don't forget to + monomorphise its kind. It might have type (a :: TYPE k), where both + `a` and `k` are instantiation variables. + +(MIV2) In `qlUnify`, `make_kinds_ok` may unify + a :: k1 ~ b :: k2 + making a cast + a := b |> (co :: k1 ~ k2) + But now suppose k1 is an instantiation variable. Then that coercion hole + `co` is the only place that `k1` will show up in the traversal, and yet + we want to monomrphise it. Hence the do_hole in `foldQLInstTyVars` +-} + +qlMonoHsWrapper :: HsWrapper -> ZonkM () +-- See Note [Monomorphise instantiation variables] +qlMonoHsWrapper (WpCompose w1 w2) = qlMonoHsWrapper w1 >> qlMonoHsWrapper w2 +qlMonoHsWrapper (WpTyApp ty) = qlMonoTcType ty +qlMonoHsWrapper _ = return () + +qlMonoTcType :: TcType -> ZonkM () +-- See Note [Monomorphise instantiation variables] +qlMonoTcType ty + = do { traceZonk "monomorphiseQLInstVars {" (ppr ty) + ; go_ty ty + ; traceZonk "monomorphiseQLInstVars }" empty } + where + go_ty :: TcType -> ZonkM () + go_ty ty = unTcMUnit (foldQLInstVars go_tv ty) + + go_tv :: TcTyVar -> TcMUnit + -- Precondition: tv is a QL instantiation variable + -- If it is already unified, look through it and carry on + -- If not, monomorphise it, by making a fresh unification variable, + -- at the ambient level + go_tv tv + | MetaTv { mtv_ref = ref, mtv_tclvl = lvl, mtv_info = info } <- tcTyVarDetails tv + = assertPpr (case lvl of QLInstVar -> True; _ -> False) (ppr tv) $ + TCMU $ do { traceZonk "qlMonoTcType" (ppr tv) + ; flex <- readTcRef ref + ; case flex of { + Indirect ty -> go_ty ty ; + Flexi -> + do { let kind = tyVarKind tv + ; go_ty kind -- See (MIV1) in Note [Monomorphise instantiation variables] + ; ref2 <- newTcRef Flexi + ; lvl2 <- getZonkTcLevel + ; let details = MetaTv { mtv_info = info + , mtv_ref = ref2 + , mtv_tclvl = lvl2 } + tv2 = mkTcTyVar (tyVarName tv) kind details + ; writeTcRef ref (Indirect (mkTyVarTy tv2)) }}} + | otherwise + = pprPanic "qlMonoTcType" (ppr tv) + +newtype TcMUnit = TCMU { unTcMUnit :: ZonkM () } +instance Semigroup TcMUnit where + TCMU ml <> TCMU mr = TCMU (ml >> mr) +instance Monoid TcMUnit where + mempty = TCMU (return ()) + +{- Note [The fiv test in quickLookArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In rule APP-lightning-bolt in Fig 5 of the paper, we have to test rho_r +for having no free instantiation variables. We do this in Step 3 of quickLookArg1, +using anyFreeKappa. Example: + Suppose ids :: [forall a. a->a] + and consider Just (ids++ids) +We will instantiate Just with kappa, say, and then call + quickLookArg1 False {kappa} (ids ++ ids) kappa +The call to tcInstFun will return with app_res_rho = [forall a. a->a] +which has no free instantiation variables, so we can QL-unify + kappa ~ [Forall a. a->a] +-} + +anyFreeKappa :: TcType -> TcM Bool +-- True if there is a free instantiation variable +-- in the argument type, after zonking +-- See Note [The fiv test in quickLookArg] +anyFreeKappa ty = unTcMBool (foldQLInstVars go_tv ty) + where + go_tv tv = TCMB $ do { info <- readMetaTyVar tv + ; case info of + Indirect ty -> anyFreeKappa ty + Flexi -> return True } + +newtype TcMBool = TCMB { unTcMBool :: TcM Bool } +instance Semigroup TcMBool where + TCMB ml <> TCMB mr = TCMB (do { l <- ml; if l then return True else mr }) +instance Monoid TcMBool where + mempty = TCMB (return False) + +foldQLInstVars :: forall a. Monoid a => (TcTyVar -> a) -> TcType -> a +{-# INLINE foldQLInstVars #-} +foldQLInstVars check_tv ty + = do_ty ty + where + (do_ty, _, _, _) = foldTyCo folder () + + folder :: TyCoFolder () a + folder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] + -- in GHC.Core.TyCo.FVs + , tcf_tyvar = do_tv, tcf_covar = mempty + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + + do_bndr _ _ _ = () + + do_hole _ hole = do_ty (coVarKind (coHoleCoVar hole)) + -- See (MIV2) in Note [Monomorphise instantiation variables] + + do_tv :: () -> TcTyVar -> a + do_tv _ tv | isQLInstTyVar tv = check_tv tv + | otherwise = mempty + +{- ********************************************************************* +* * + QuickLook unification +* * +********************************************************************* -} + +qlUnify :: TcType -> TcType -> TcM () +-- Unify ty1 with ty2: +-- * It can unify both instantiation variables (possibly with polytypes), +-- and ordinary unification variables (but only with monotypes) +-- * It does not return a coercion (unlike unifyType); it is called +-- for the sole purpose of unifying instantiation variables, although it +-- may also (opportunistically) unify regular unification variables. +-- * It never produces errors, even for mis-matched types +-- * It may return without having made the argument types equal, of course; +-- it just makes best efforts. +qlUnify ty1 ty2 + = do { traceTc "qlUnify" (ppr ty1 $$ ppr ty2) + ; go ty1 ty2 } + where + go :: TcType -> TcType + -> TcM () + go (TyVarTy tv) ty2 + | isMetaTyVar tv = go_kappa tv ty2 + go ty1 (TyVarTy tv) + | isMetaTyVar tv = go_kappa tv ty1 + + go (CastTy ty1 _) ty2 = go ty1 ty2 + go ty1 (CastTy ty2 _) = go ty1 ty2 + + go (TyConApp tc1 []) (TyConApp tc2 []) + | tc1 == tc2 -- See GHC.Tc.Utils.Unify + = return () -- Note [Expanding synonyms during unification] + + -- Now, and only now, expand synonyms + go rho1 rho2 + | Just rho1 <- coreView rho1 = go rho1 rho2 + | Just rho2 <- coreView rho2 = go rho1 rho2 + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2 + , not (isTypeFamilyTyCon tc1) + , tys1 `equalLength` tys2 + = zipWithM_ go tys1 tys2 + + -- Decompose (arg1 -> res1) ~ (arg2 -> res2) + -- and (c1 => res1) ~ (c2 => res2) + -- But for the latter we only learn instantiation info from res1~res2 + -- We look at the multiplicity too, although the chances of getting + -- impredicative instantiation info from there seems...remote. + go (FunTy { ft_af = af1, ft_arg = arg1, ft_res = res1, ft_mult = mult1 }) + (FunTy { ft_af = af2, ft_arg = arg2, ft_res = res2, ft_mult = mult2 }) + | af1 == af2 -- Match the arrow TyCon + = do { when (isVisibleFunArg af1) (go arg1 arg2) + ; when (isFUNArg af1) (go mult1 mult2) + ; go res1 res2 } + + -- ToDo: c.f. Tc.Utils.unify.uType, + -- which does not split FunTy here + -- Also NB tcSplitAppTyNoView here, which does not split (c => t) + go (AppTy t1a t1b) ty2 + | Just (t2a, t2b) <- tcSplitAppTyNoView_maybe ty2 + = do { go t1a t2a; go t1b t2b } + + go ty1 (AppTy t2a t2b) + | Just (t1a, t1b) <- tcSplitAppTyNoView_maybe ty1 + = do { go t1a t2a; go t1b t2b } + + go _ _ = return () + -- Don't look under foralls; see (UQL4) of Note [QuickLook unification] + + ---------------- + go_kappa kappa ty2 + = assertPpr (isMetaTyVar kappa) (ppr kappa) $ + do { info <- readMetaTyVar kappa + ; case info of + Indirect ty1 -> go ty1 ty2 + Flexi -> do { ty2 <- liftZonkM $ zonkTcType ty2 + ; go_flexi kappa ty2 } } + + ---------------- + -- Swap (kappa1[conc] ~ kappa2[tau]) + -- otherwise we'll fail to unify and emit a coercion. + -- Just an optimisation: emitting a coercion is fine + go_flexi kappa (TyVarTy tv2) + | lhsPriority tv2 > lhsPriority kappa + = go_flexi1 tv2 (TyVarTy kappa) + go_flexi kappa ty2 + = go_flexi1 kappa ty2 + + go_flexi1 kappa ty2 -- ty2 is zonked + = do { cur_lvl <- getTcLevel + -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles + -- Here we are in the TcM monad, which does not track enclosing + -- Given equalities; so for quick-look unification we conservatively + -- treat /any/ level outside this one as untouchable. Hence cur_lvl. + ; case simpleUnifyCheck UC_QuickLook cur_lvl kappa ty2 of + SUC_CanUnify -> + do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind + -- unifyKind: see (UQL2) in Note [QuickLook unification] + -- and (MIV2) in Note [Monomorphise instantiation variables] + ; let ty2' = mkCastTy ty2 co + ; traceTc "qlUnify:update" $ + ppr kappa <+> text ":=" <+> ppr ty2 + ; liftZonkM $ writeMetaTyVar kappa ty2' } + _ -> return () -- e.g. occurs-check or forall-bound variable + } + where + kappa_kind = tyVarKind kappa + ty2_kind = typeKind ty2 + +{- Note [QuickLook unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In qlUnify, if we find (kappa ~ ty), we are going to update kappa := ty. +That is the entire point of qlUnify! Wrinkles: + +(UQL1) Before unifying an instantiation variable in `go_flexi`, we must check + the usual unification conditions, by calling `GHC.Tc.Utils.Unify.simpleUnifyCheck`. + For example that checks for + * An occurs-check + * Level mis-match + * An attempt to unify a concrete type variable with a non-concrete type. + +(UQL2) What if kappa and ty have different kinds? We simply call the + ordinary unifier and use the coercion to connect the two. + + If that coercion is not Refl, it is all in vain: The whole point of + qlUnify is to impredicatively unify (kappa := forall a. blah). It is + no good to unify (kappa := (forall a.blah) |> co) because we can't + use that casted polytype. + + BUT: unifyKind has emitted constraint(s) into the Tc monad, so we may as well + use them. (An alternative; use uType directly, if the result is not Refl, + discard the constraints and the coercion, and do not update the instantiation + variable. But see "Sadly discarded design alternative" below.) + + See also (TCAPP2) in Note [tcApp: typechecking applications]. + +(UQL3) Instantiation variables don't really have a settled level yet; + they have level QLInstVar (see Note [The QLInstVar TcLevel] in GHC.Tc.Utils.TcType. + You might worry that we might unify + alpha[1] := Maybe kappa[qlinst] + and later this kappa turns out to be a level-2 variable, and we have committed + a skolem-escape error. + + But happily this can't happen: QL instantiation variables have level infinity, + and we never unify a variable with a type from a deeper level. + +(UQL4) Should we look under foralls in qlUnify? The use-case would be + (forall a. beta[qlinst] -> a) ~ (forall a. (forall b. b->b) -> a) + where we might hope for + beta := forall b. b + + But in fact we don't attempt this: + + * The normal on-the-fly unifier doesn't look under foralls, so why + should qlUnify? + + * Looking under foralls means we'd have to track the bound variables on both + sides. Tiresome but not a show stopper. + + * We might call the *regular* unifier (via unifyKind) under foralls, and that + doesn't know about those bound variables (it controls scope through level + numbers) so it might go totally wrong. At least we'd have to instantaite + the forall-types with skolems (with level numbers). Maybe more. + + It's just not worth the trouble, we think (for now at least). + + +Sadly discarded design alternative +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very tempting to use `unifyType` rather than `qlUnify`, killing off the +latter. (Extending `unifyType` slightly to allow it to unify an instantiation +variable with a polytype is easy.). But I could not see how to make it work: + + * `unifyType` makes the types /equal/, and returns a coercion, and it is hard to + marry that up with DeepSubsumption. Absent deep subsumption, this approach + might just work. + + * I considered making a wrapper for `uType`, which simply discards any deferred + equality constraints. But we can't do that: in a heterogeneous equality we might + have unified a unification variable (alpha := ty |> co), where `co` is only bound + by those constraints. +-} + +{- ********************************************************************* +* * + tagToEnum# +* * +********************************************************************* -} + +{- Note [tagToEnum#] +~~~~~~~~~~~~~~~~~~~~ +Nasty check to ensure that tagToEnum# is applied to a type that is an +enumeration TyCon. It's crude, because it relies on our +knowing *now* that the type is ok, which in turn relies on the +eager-unification part of the type checker pushing enough information +here. In theory the Right Thing to do is to have a new form of +constraint but I definitely cannot face that! And it works ok as-is. + +Here's are two cases that should fail + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + +When data type families are involved it's a bit more complicated. + data family F a + data instance F [Int] = A | B | C +Then we want to generate something like + tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] +Usually that coercion is hidden inside the wrappers for +constructors of F [Int] but here we have to do it explicitly. + +It's all grotesquely complicated. +-} + +isTagToEnum :: HsExpr GhcTc -> Bool +isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey +isTagToEnum _ = False + +tcTagToEnum :: (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc] + -> TcRhoType + -> TcM (HsExpr GhcTc) +-- tagToEnum# :: forall a. Int# -> a +-- See Note [tagToEnum#] Urgh! +tcTagToEnum (tc_fun, fun_ctxt) tc_args res_ty + | [val_arg] <- dropWhile (not . isHsValArg) tc_args + = do { res_ty <- liftZonkM $ zonkTcType res_ty + + -- Check that the type is algebraic + ; case tcSplitTyConApp_maybe res_ty of { + Nothing -> do { addErrTc (TcRnTagToEnumUnspecifiedResTy res_ty) + ; vanilla_result } ; + Just (tc, tc_args) -> + + do { -- Look through any type family + ; fam_envs <- tcGetFamInstEnvs + ; case tcLookupDataFamInst_maybe fam_envs tc tc_args of { + Nothing -> do { check_enumeration res_ty tc + ; vanilla_result } ; + Just (rep_tc, rep_args, coi) -> + + do { -- coi :: tc tc_args ~R rep_tc rep_args + check_enumeration res_ty rep_tc + ; let rep_ty = mkTyConApp rep_tc rep_args + tc_fun' = mkHsWrap (WpTyApp rep_ty) tc_fun + df_wrap = mkWpCastR (mkSymCo coi) + tc_expr = rebuildHsApps (tc_fun', fun_ctxt) [val_arg] + ; return (mkHsWrap df_wrap tc_expr) }}}}} + + | otherwise + = failWithTc TcRnTagToEnumMissingValArg + + where + vanilla_result = return (rebuildHsApps (tc_fun, fun_ctxt) tc_args) + + check_enumeration ty' tc + | -- isTypeDataTyCon: see wrinkle (W1) in + -- Note [Type data declarations] in GHC.Rename.Module + isTypeDataTyCon tc = addErrTc (TcRnTagToEnumResTyTypeData ty') + | isEnumerationTyCon tc = return () + | otherwise = addErrTc (TcRnTagToEnumResTyNotAnEnum ty') + + +{- ********************************************************************* +* * + Horrible hack for rep-poly unlifted newtypes +* * +********************************************************************* -} + +{- Note [Eta-expanding rep-poly unlifted newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Any occurrence of a newtype constructor must appear at a known representation. +If the newtype is applied to an argument, then we are done: by (I2) in +Note [Representation polymorphism invariants], the argument has a known +representation, and we are done. So we are left with the situation of an +unapplied newtype constructor. For example: + + type N :: TYPE r -> TYPE r + newtype N a = MkN a + + ok :: N Int# -> N Int# + ok = MkN + + bad :: forall r (a :: TYPE r). N (# Int, r #) -> N (# Int, r #) + bad = MkN + +The difficulty is that, unlike the situation described in +Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete, +it is not necessarily the case that we simply need to check the instantiation +of a single variable. Consider for example: + + type RR :: Type -> Type -> RuntimeRep + type family RR a b where ... + + type T :: forall a -> forall b -> TYPE (RR a b) + type family T a b where ... + + type M :: forall a -> forall b -> TYPE (RR a b) + newtype M a b = MkM (T a b) + +Now, suppose we instantiate MkM, say with two types X, Y from the environment: + + foo :: T X Y -> M X Y + foo = MkM @X @Y + +we need to check that we can eta-expand MkM, for which we need to know the +representation of its argument, which is "RR X Y". + +To do this, in "rejectRepPolyNewtypes", we perform a syntactic representation- +polymorphism check on the instantiated argument of the newtype, and reject +the definition if the representation isn't concrete (in the sense of Note [Concrete types] +in GHC.Tc.Utils.Concrete). + +For example, we would accept "ok" above, as "IntRep" is a concrete RuntimeRep. +However, we would reject "foo", because "RR X Y" is not a concrete RuntimeRep. +If we wanted to accept "foo" (performing a PHASE 2 check (in the sense of +Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete), we would have to +significantly re-engineer unlifted newtypes in GHC. Currently, "MkM" has type: + + MkM :: forall a b. T a b %1 -> M a b + +However, we should only be able to use MkM when we know the representation of +T a b (which is RR a b). This means that MkM should instead have type: + + MkM :: forall {must_be_conc} a b (co :: RR a b ~# must_be_conc) + . T a b |> GRefl Nominal (TYPE co) %1 -> M a b + +where "must_be_conc" is a skolem type variable that must be instantiated to a +concrete type, just as in Note [Representation-polymorphism checking built-ins] +in GHC.Tc.Utils.Concrete. This means that any instantiation of "MkM", such as +"MkM @X @Y" from "foo", would create a fresh concrete metavariable "gamma[conc]" +and emit a Wanted constraint + + [W] co :: RR X Y ~# gamma[conc] + +However, this all seems like a lot of work for a feature that no one is asking for, +so we decided to keep the much simpler syntactic check. Note that one possible +advantage of this approach is that we should be able to stop skipping +representation-polymorphism checks in the output of the desugarer; see (C) in +Wrinkle [Representation-polymorphic lambdas] in Note [Typechecking data constructors]. +-} + +-- | Reject any unsaturated use of an unlifted newtype constructor +-- if the representation of its argument isn't known. +-- +-- See Note [Eta-expanding rep-poly unlifted newtypes]. +rejectRepPolyNewtypes :: (HsExpr GhcTc, AppCtxt) + -> TcRhoType + -> TcM () +rejectRepPolyNewtypes (fun,_) app_res_rho = case fun of + + XExpr (ConLikeTc (RealDataCon con) _ _) + -- Check that this is an unsaturated occurrence of a + -- representation-polymorphic newtype constructor. + | isNewDataCon con + , not $ tcHasFixedRuntimeRep $ dataConTyCon con + , Just (_rem_arg_af, _rem_arg_mult, rem_arg_ty, _nt_res_ty) + <- splitFunTy_maybe app_res_rho + -> do { let frr_ctxt = FRRRepPolyUnliftedNewtype con + ; hasFixedRuntimeRep_syntactic frr_ctxt rem_arg_ty } + + _ -> return () + + +{- ********************************************************************* +* * + Pragmas on expressions +* * +********************************************************************* -} + +tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc +tcExprPrag (HsPragSCC x1 ann) = HsPragSCC x1 ann diff --git a/GHC/Tc/Gen/Arrow.hs b/GHC/Tc/Gen/Arrow.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Arrow.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BlockArguments #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Typecheck arrow notation +module GHC.Tc.Gen.Arrow ( tcProc ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckMonoExpr, tcInferRho, tcSyntaxOp + , tcCheckPolyExpr ) + +import GHC.Hs +import GHC.Tc.Errors.Types +import GHC.Tc.Gen.Match +import GHC.Tc.Gen.Head( tcCheckId ) +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Gen.Bind +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Core.Multiplicity +import GHC.Core.Coercion +import GHC.Types.Id( mkLocalId ) +import GHC.Tc.Utils.Instantiate +import GHC.Builtin.Types +import GHC.Types.Var.Set +import GHC.Builtin.Types.Prim +import GHC.Types.Basic( Arity ) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import Control.Monad + +{- +Note [Arrow overview] +~~~~~~~~~~~~~~~~~~~~~ +Here's a summary of arrows and how they typecheck. First, here's +a cut-down syntax: + + expr ::= .... + | proc pat cmd + + cmd ::= cmd exp -- Arrow application + | \pat -> cmd -- Arrow abstraction + | (| exp cmd1 ... cmdn |) -- Arrow form, n>=0 + | ... -- If, case in the usual way + + cmd_type ::= carg_type --> type + + carg_type ::= () + | (type, carg_type) + +Note that + * The 'exp' in an arrow form can mention only + "arrow-local" variables + + * An "arrow-local" variable is bound by an enclosing + cmd binding form (eg arrow abstraction) + + * A cmd_type is here written with a funny arrow "-->", + The bit on the left is a carg_type (command argument type) + which itself is a nested tuple, finishing with () + + * The arrow-tail operator (e1 -< e2) means + (| e1 <<< arr snd |) e2 + + +************************************************************************ +* * + Proc +* * +************************************************************************ +-} + +tcProc :: LPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr + -> ExpRhoType -- Expected type of whole proc expression + -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion) + +tcProc pat cmd@(L loc (HsCmdTop names _)) exp_ty + = do { exp_ty <- expTypeToType exp_ty -- no higher-rank stuff with arrows + ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty + ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 + -- start with the names as they are used to desugar the proc itself + -- See #17423 + ; names' <- setSrcSpanA loc $ + mapM (tcSyntaxName ProcOrigin arr_ty) names + ; let cmd_env = CmdEnv { cmd_arr = arr_ty } + ; (pat', cmd') <- newArrowScope + $ tcCheckPat (ArrowMatchCtxt ProcExpr) pat (unrestricted arg_ty) + $ tcCmdTop cmd_env names' cmd (unitTy, res_ty) + ; let res_co = co `mkTransCo` mkAppCo co1 (mkNomReflCo res_ty) + ; return (pat', cmd', res_co) } + +{- +************************************************************************ +* * + Commands +* * +************************************************************************ +-} + +-- See Note [Arrow overview] +type CmdType = (CmdArgType, TcTauType) -- cmd_type +type CmdArgType = TcTauType -- carg_type, a nested tuple + +data CmdEnv + = CmdEnv { + cmd_arr :: TcType -- ^ Arrow type constructor, of kind *->*->* + } + +mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType +mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] + +--------------------------------------- +tcCmdTop :: CmdEnv + -> CmdSyntaxTable GhcTc -- ^ Type-checked Arrow class methods (arr, (>>>), ...) + -> LHsCmdTop GhcRn + -> CmdType + -> TcM (LHsCmdTop GhcTc) + +tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty) + = setSrcSpanA loc $ + do { cmd' <- tcCmd env cmd cmd_ty + ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') } + +---------------------------------------- +tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc) + -- The main recursive function +tcCmd env (L loc cmd) cmd_ty@(_, res_ty) + = setSrcSpan (locA loc) $ do + { cmd' <- tc_cmd env cmd cmd_ty + ; hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowCmdResTy cmd) res_ty + ; return (L loc cmd') } + +tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTc) +tc_cmd env (HsCmdPar x cmd) res_ty + = do { cmd' <- tcCmd env cmd res_ty + ; return (HsCmdPar x cmd') } + +tc_cmd env (HsCmdLet x binds (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')) } + +tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) + = addErrCtxt (CmdCtxt in_cmd) $ do + 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 (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' + = do { pred' <- tcCheckMonoExpr pred boolTy + ; b1' <- tcCmd env b1 res_ty + ; b2' <- tcCmd env b2 res_ty + ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2') + } + +tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syntax for if + = do { pred_ty <- newOpenFlexiTyVarTy + -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r + -- because we're going to apply it to the environment, not + -- the return value. + ; skol_info <- mkSkolemInfo ArrowReboundIfSkol + ; (_, [r_tv]) <- tcInstSkolTyVars skol_info [alphaTyVar] + ; let r_ty = mkTyVarTy r_tv + ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) + TcRnArrowIfThenElsePredDependsOnResultTy + ; (pred', fun') <- tcSyntaxOp IfThenElseOrigin fun + (map synKnownType [pred_ty, r_ty, r_ty]) + (mkCheckExpType r_ty) $ \ _ _ -> + tcCheckMonoExpr pred pred_ty + + ; b1' <- tcCmd env b1 res_ty + ; b2' <- tcCmd env b2 res_ty + ; return (HsCmdIf x fun' pred' b1' b2') + } + +------------------------------------------- +-- Arrow application +-- (f -< a) or (f -<< a) +-- +-- D |- fun :: a t1 t2 +-- D,G |- arg :: t1 +-- ------------------------ +-- D;G |-a fun -< arg :: stk --> t2 +-- +-- D,G |- fun :: a t1 t2 +-- D,G |- arg :: t1 +-- ------------------------ +-- D;G |-a fun -<< arg :: stk --> t2 +-- +-- (plus -<< requires ArrowApply) + +tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty) + = addErrCtxt (CmdCtxt cmd) $ + do { arg_ty <- newOpenFlexiTyVarTy + ; let fun_ty = mkCmdArrTy env arg_ty res_ty + ; fun' <- select_arrow_scope (tcCheckMonoExpr fun fun_ty) + + ; arg' <- tcCheckMonoExpr arg arg_ty + + ; hasFixedRuntimeRep_syntactic + (FRRArrow $ ArrowCmdArrApp (unLoc fun) (unLoc arg) ho_app) + fun_ty + + ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) } + where + -- Before type-checking f, use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside f. In the higher-order case (-<<), they are. + -- See Note [Escaping the arrow scope] in GHC.Tc.Types + select_arrow_scope tc = case ho_app of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc + +------------------------------------------- +-- Command application +-- +-- D,G |- exp : t +-- D;G |-a cmd : (t,stk) --> res +-- ----------------------------- +-- D;G |-a cmd exp : stk --> res + +tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty) + = addErrCtxt (CmdCtxt cmd) $ + do { arg_ty <- newOpenFlexiTyVarTy + ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) + ; arg' <- tcCheckMonoExpr arg arg_ty + ; hasFixedRuntimeRep_syntactic + (FRRArrow $ ArrowCmdApp (unLoc fun) (unLoc arg)) + arg_ty + ; return (HsCmdApp x fun' arg') } + +------------------------------------------- +-- Lambda +-- +-- D;G,x:t |-a cmd : stk --> res +-- ------------------------------ +-- D;G |-a (\x.cmd) : (t,stk) --> res + +tc_cmd env cmd@(HsCmdLam x lam_variant match) cmd_ty + = (case lam_variant of -- Add context only for \case and \cases + LamSingle -> id -- Avoids clutter in the vanilla-lambda form + _ -> addErrCtxt (CmdCtxt cmd)) $ + do { let match_ctxt = ArrowLamAlt lam_variant + ; arity <- checkArgCounts match + ; (wrap, match') <- tcCmdMatchLambda env match_ctxt arity match cmd_ty + ; return (mkHsCmdWrap wrap (HsCmdLam x lam_variant match')) } + +------------------------------------------- +-- Do notation + +tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty) + = do { co <- unifyType Nothing unitTy cmd_stk -- Expecting empty argument stack + ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty + ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) } + + +----------------------------------------------------------------- +-- Arrow ``forms'' (| e c1 .. cn |) +-- +-- D; G |-a1 c1 : stk1 --> r1 +-- ... +-- D; G |-an cn : stkn --> rn +-- D |- e :: forall e. a1 (e, stk1) t1 +-- ... +-- -> an (e, stkn) tn +-- -> a (e, stk) t +-- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) +-- ---------------------------------------------- +-- D; G |-a (| e c1 ... cn |) : stk --> t + +tc_cmd env cmd@(HsCmdArrForm fixity expr f cmd_args) (cmd_stk, res_ty) + = addErrCtxt (CmdCtxt cmd) + do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args + -- We use alphaTyVar for 'w' + ; let e_ty = mkInfForAllTy alphaTyVar $ + mkVisFunTysMany cmd_tys $ + mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty + ; expr' <- tcCheckPolyExpr expr e_ty + ; return (HsCmdArrForm fixity expr' f cmd_args') } + + where + tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType) + tc_cmd_arg cmd@(L loc (HsCmdTop names _)) + = do { arr_ty <- newFlexiTyVarTy arrowTyConKind + ; stk_ty <- newFlexiTyVarTy liftedTypeKind + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; names' <- setSrcSpanA loc $ + mapM (tcSyntaxName ArrowCmdOrigin arr_ty) names + ; let env' = env { cmd_arr = arr_ty } + ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty) + ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } + +-- | Typechecking for case command alternatives. Used for 'HsCmdCase'. +tcCmdMatches :: CmdEnv + -> TcTypeFRR -- ^ Type of the scrutinee. + -> MatchGroup GhcRn (LHsCmd GhcRn) -- ^ case alternatives + -> CmdType + -> TcM (MatchGroup GhcTc (LHsCmd GhcTc)) +tcCmdMatches env scrut_ty matches (stk, res_ty) + = tcCaseMatches ctxt tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty) + where + ctxt = ArrowMatchCtxt ArrowCaseAlt + tc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' + ; tcCmd env body (stk, res_ty') } + +-- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'. +tcCmdMatchLambda :: CmdEnv + -> HsArrowMatchContext + -> Arity + -> MatchGroup GhcRn (LHsCmd GhcRn) + -> CmdType + -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc)) +tcCmdMatchLambda env ctxt arity + mg@MG { mg_alts = L l matches, mg_ext = origin } + (cmd_stk, res_ty) + = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs arity cmd_stk + + ; let check_arg_tys = map (unrestricted . mkCheckExpType) arg_tys + ; matches' <- forM matches $ + addErrCtxt . MatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk' + + ; let arg_tys' = map unrestricted arg_tys + mg' = mg { mg_alts = L l matches' + , mg_ext = MatchGroupTc arg_tys' res_ty origin } + + ; return (mkWpCastN co, mg') } + where + -- Check the patterns, and the GRHSs inside + tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = L l pats, m_grhss = grhss })) + = do { (pats', grhss') <- setSrcSpanA mtch_loc $ + tcMatchPats match_ctxt pats (map ExpFunPatTy arg_tys) $ + tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) + + ; return $ L mtch_loc (Match { m_ext = noExtField + , m_ctxt = match_ctxt + , m_pats = L l 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 res_ty) + ; return (GRHS x guards' rhs') } + +matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcTypeFRR], TcType) +matchExpectedCmdArgs 0 ty + = return (mkNomReflCo ty, [], ty) +matchExpectedCmdArgs n ty + = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty + ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 + ; return (mkTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } + +{- +************************************************************************ +* * + Stmts +* * +************************************************************************ +-} + +-------------------------------- +-- Mdo-notation +-- The distinctive features here are +-- (a) RecStmts, and +-- (b) no rebindable syntax + +tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker +tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside + = do { rhs' <- tcCmd env rhs (unitTy, res_ty) + ; thing <- thing_inside (panic "tcArrDoStmt") + ; return (LastStmt x rhs' noret noSyntaxExpr, thing) } + +tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside + = do { (rhs', elt_ty) <- tc_arr_rhs env rhs + ; thing <- thing_inside res_ty + ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) } + +tcArrDoStmt env ctxt (BindStmt _ pat rhs) res_ty thing_inside + = do { (rhs', pat_ty) <- tc_arr_rhs env rhs + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ + thing_inside res_ty + ; return (mkTcBindStmt pat' rhs', thing) } + +tcArrDoStmt env ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names + , recS_rec_ids = rec_names }) res_ty thing_inside + = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names + ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind + ; let tup_ids = zipWith (\n p -> mkLocalId n ManyTy p) tup_names tup_elt_tys + -- Many because it's a recursive definition + ; tcExtendIdEnv tup_ids $ do + { (stmts', tup_rets) + <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> + -- ToDo: res_ty not really right + zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys) + + ; thing <- thing_inside res_ty + -- NB: The rec_ids for the recursive things + -- already scope over this part. This binding may shadow + -- some of them with polymorphic things with the same Name + -- (see Note [How RecStmt works] in Language.Haskell.Syntax.Expr) + + ; let rec_ids = takeList rec_names tup_ids + ; later_ids <- tcLookupLocalIds later_names + + ; let rec_rets = takeList rec_names tup_rets + ; let ret_table = zip tup_ids tup_rets + ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] + + ; let + stmt :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) + stmt = emptyRecStmtId + { recS_stmts = L l stmts' + -- { recS_stmts = _ stmts' + , recS_later_ids = later_ids + , recS_rec_ids = rec_ids + , recS_ext = unitRecStmtTc + { recS_later_rets = later_rets + , recS_rec_rets = rec_rets + , recS_ret_ty = res_ty} } + ; return (stmt, thing) + }} + +tcArrDoStmt _ _ stmt _ _ + = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) + +tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType) +tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcCmd env rhs (unitTy, ty) + ; return (rhs', ty) } + +{- +************************************************************************ +* * + Helpers +* * +************************************************************************ +-} + +mkPairTy :: Type -> Type -> Type +mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] + +arrowTyConKind :: Kind -- *->*->* +arrowTyConKind = mkVisFunTysMany [liftedTypeKind, liftedTypeKind] liftedTypeKind diff --git a/GHC/Tc/Gen/Bind.hs b/GHC/Tc/Gen/Bind.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Bind.hs @@ -0,0 +1,1917 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +module GHC.Tc.Gen.Bind + ( tcLocalBinds + , tcTopBinds + , tcValBinds + , tcHsBootSigs + , tcPolyCheck + , chooseInferredQuantifiers + ) +where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcFunBindMatches ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckMonoExpr ) +import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) + +import GHC.Types.Tickish (CoreTickish, GenTickish (..)) +import GHC.Types.CostCentre (mkUserCC, mkDeclCCFlavour) +import GHC.Driver.DynFlags +import GHC.Data.FastString +import GHC.Hs + +import GHC.Rename.Bind ( rejectBootDecls ) + +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.Core.UsageEnv ( bottomUE ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.TcMType +import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Validity (checkValidType, checkEscapingKind) +import GHC.Tc.Zonk.TcType +import GHC.Core.Reduction ( Reduction(..) ) +import GHC.Core.Multiplicity +import GHC.Core.FamInstEnv( normaliseType ) +import GHC.Core.Class ( Class ) +import GHC.Core.Coercion( mkSymCo ) +import GHC.Core.Type (mkStrLitTy, mkCastTy) +import GHC.Core.TyCo.Ppr( pprTyVars ) +import GHC.Core.TyCo.Tidy( tidyOpenTypeX ) + +import GHC.Builtin.Types ( mkConstraintTupleTy, multiplicityTy, oneDataConTy ) +import GHC.Builtin.Types.Prim +import GHC.Unit.Module + +import GHC.Types.SourceText +import GHC.Types.Id +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env( TidyEnv, TyVarEnv, mkVarEnv, lookupVarEnv ) +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.SourceFile +import GHC.Types.SrcLoc + +import GHC.Utils.Misc +import GHC.Types.Basic +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Builtin.Names( ipClassName ) +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.Bag +import GHC.Data.Graph.Directed +import GHC.Data.Maybe + +import Control.Monad +import Data.Foldable (find, traverse_) + +{- +************************************************************************ +* * +\subsection{Type-checking bindings} +* * +************************************************************************ + +@tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because +it needs to know something about the {\em usage} of the things bound, +so that it can create specialisations of them. So @tcBindsAndThen@ +takes a function which, given an extended environment, E, typechecks +the scope of the bindings returning a typechecked thing and (most +important) an LIE. It is this LIE which is then used as the basis for +specialising the things bound. + +@tcBindsAndThen@ also takes a "combiner" which glues together the +bindings and the "thing" to make a new "thing". + +The real work is done by @tcBindWithSigsAndThen@. + +Recursive and non-recursive binds are handled in essentially the same +way: because of uniques there are no scoping issues left. The only +difference is that non-recursive bindings can bind primitive values. + +Even for non-recursive binding groups we add typings for each binder +to the LVE for the following reason. When each individual binding is +checked the type of its LHS is unified with that of its RHS; and +type-checking the LHS of course requires that the binder is in scope. + +At the top-level the LIE is sure to contain nothing but constant +dictionaries, which we resolve at the module level. + +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is + + * Bind any variable for which we have a type signature + to an Id with a polymorphic type. Then when type-checking + the RHSs we'll make a full polymorphic call. + +This fine, but if you aren't a bit careful you end up with a horrendous +amount of partial application and (worse) a huge space leak. For example: + + f :: Eq a => [a] -> [a] + f xs = ...f... + +If we don't take care, after typechecking we get + + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... + +Notice the stupid construction of (f a d), which is of course +identical to the function we're executing. In this case, the +polymorphic recursion isn't being used (but that's a very common case). +This can lead to a massive space leak, from the following top-level defn +(post-typechecking) + + ff :: [Int] -> [Int] + ff = f Int dEqInt + +Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but +f' is another thunk which evaluates to the same thing... and you end +up with a chain of identical values all hung onto by the CAF ff. + + ff = f Int dEqInt + + = let f' = f Int dEqInt in \ys. ...f'... + + = let f' = let f' = f Int dEqInt in \ys. ...f'... + in \ys. ...f'... + +Etc. + +NOTE: a bit of arity analysis would push the (f a d) inside the (\ys...), +which would make the space leak go away in this case + +Solution: when typechecking the RHSs we always have in hand the +*monomorphic* Ids for each binding. So we just need to make sure that +if (Method f a d) shows up in the constraints emerging from (...f...) +we just use the monomorphic Id. We achieve this by adding monomorphic Ids +to the "givens" when simplifying constraints. That's what the "lies_avail" +is doing. + +Then we get + + f = /\a -> \d::Eq a -> letrec + fm = \ys:[a] -> ...fm... + in + fm +-} + +tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] + -> TcM (TcGblEnv, TcLclEnv) +-- The TcGblEnv contains the new tcg_binds and tcg_spects +-- The TcLclEnv has an extended type envt for the new bindings +tcTopBinds binds sigs + = do { -- Pattern synonym bindings populate the global environment + (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs getEnvs + ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids + + + ; let { tcg_env' = tcg_env { tcg_imp_specs + = specs ++ tcg_imp_specs tcg_env } + `addTypecheckedBinds` map snd binds' } + + ; return (tcg_env', tcl_env) } + -- The top level bindings are flattened into a giant + -- implicitly-mutually-recursive LHsBinds + +tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] +-- A hs-boot file has only one BindGroup, and it only has type +-- signatures in it. The renamer checked all this. +tcHsBootSigs binds sigs + = do { unless (null binds) $ + rejectBootDecls HsBoot BootBindsRn (concatMap snd binds) + ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } + where + tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames + where + f (L _ name) + = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name NoRRC) hs_ty + ; return (mkVanillaGlobal name sigma_ty) } + -- Notice that we make GlobalIds, not LocalIds + tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) + +------------------------ + +tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing + -> TcM (HsLocalBinds GhcTc, thing) + +tcLocalBinds (EmptyLocalBinds x) thing_inside + = do { thing <- thing_inside + ; return (EmptyLocalBinds x, thing) } + +tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside + = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside + ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) } +tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" + +tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside + = do { ipClass <- tcLookupClass ipClassName + ; (given_ips, ip_binds') <- + mapAndUnzipM (wrapLocSndMA (tc_ip_bind ipClass)) ip_binds + + -- Add all the IP bindings as givens for the body of the 'let' + ; (ev_binds, result) <- checkConstraints (IPSkol ips) + [] given_ips thing_inside + + ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } + where + ips = [ip | (L _ (IPBind _ (L _ ip) _)) <- ip_binds] + + -- I wonder if we should do these one at a time + -- Consider ?x = 4 + -- ?y = ?x + 1 + tc_ip_bind :: Class -> IPBind GhcRn -> TcM (DictId, IPBind GhcTc) + tc_ip_bind ipClass (IPBind _ l_name@(L _ ip) expr) + = do { ty <- newFlexiTyVarTy liftedTypeKind -- see #24298 + ; let p = mkStrLitTy $ hsIPNameFS ip + ; ip_id <- newDict ipClass [p, ty] + ; expr' <- tcCheckMonoExpr expr ty + ; return (ip_id, IPBind ip_id l_name expr') } + +tcValBinds :: TopLevelFlag + -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] + -> TcM thing + -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) + +tcValBinds top_lvl binds sigs thing_inside + = do { -- Typecheck the signatures + -- It's easier to do so now, once for all the SCCs together + -- because a single signature f,g :: + -- might relate to more than one SCC + (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $ + tcTySigs sigs + + -- Extend the envt right away with all the Ids + -- declared with complete type signatures + -- Do not extend the TcBinderStack; instead + -- we extend it on a per-rhs basis in tcExtendForRhs + -- See Note [Relevant bindings and the binder stack] + -- + -- For the moment, let bindings and top-level bindings introduce + -- only unrestricted variables. + ; tcExtendSigIds top_lvl poly_ids $ + do { (binds', (extra_binds', thing)) + <- tcBindGroups top_lvl sig_fn prag_fn binds $ + do { thing <- thing_inside + -- See Note [Pattern synonym builders don't yield dependencies] + -- in GHC.Rename.Bind + ; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns + ; let extra_binds = [ (NonRecursive, builder) + | builder <- patsyn_builders ] + ; return (extra_binds, thing) } + ; return (binds' ++ extra_binds', thing) }} + where + patsyns = getPatSynBinds binds + prag_fn = mkPragEnv sigs (concatMap snd binds) + +------------------------ + +tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv + -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing + -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) +-- Typecheck a whole lot of value bindings, +-- one strongly-connected component at a time +-- Here a "strongly connected component" has the straightforward +-- meaning of a group of bindings that mention each other, +-- ignoring type signatures (that part comes later) + +tcBindGroups _ _ _ [] thing_inside + = do { thing <- thing_inside + ; return ([], thing) } + +tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside + = do { -- See Note [Closed binder groups] + type_env <- getLclTypeEnv + ; let closed = isClosedBndrGroup type_env (snd group) + ; (group', (groups', thing)) + <- tc_group top_lvl sig_fn prag_fn group closed $ + tcBindGroups top_lvl sig_fn prag_fn groups thing_inside + ; return (group' ++ groups', thing) } + +-- Note [Closed binder groups] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- A mutually recursive group is "closed" if all of the free variables of +-- the bindings are closed. For example +-- +-- > h = \x -> let f = ...g... +-- > g = ....f...x... +-- > in ... +-- +-- Here @g@ is not closed because it mentions @x@; and hence neither is @f@ +-- closed. +-- +-- So we need to compute closed-ness on each strongly connected components, +-- before we sub-divide it based on what type signatures it has. +-- + +------------------------ +tc_group :: forall thing. + TopLevelFlag -> TcSigFun -> TcPragEnv + -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing + -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) + +-- Typecheck one strongly-connected component of the original program. +-- We get a list of groups back, because there may +-- be specialisations etc as well + +tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside + -- A single non-recursive binding + -- We want to keep non-recursive things non-recursive + -- so that we desugar unlifted bindings correctly + = do { let bind = case binds of + [bind] -> bind + [] -> panic "tc_group: empty list of binds" + _ -> panic "tc_group: NonRecursive binds is not a singleton bag" + ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed + thing_inside + ; return ( [(NonRecursive, bind')], thing) } + +tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside + = -- To maximise polymorphism, we do a new + -- strongly-connected-component analysis, this time omitting + -- any references to variables with type signatures. + -- (This used to be optional, but isn't now.) + -- See Note [Polymorphic recursion] in "GHC.Hs.Binds". + do { traceTc "tc_group rec" (pprLHsBinds binds) + ; whenIsJust mbFirstPatSyn $ \lpat_syn -> + recursivePatSynErr (locA $ getLoc lpat_syn) binds + ; (binds1, thing) <- go sccs + ; return ([(Recursive, binds1)], thing) } + -- Rec them all together + where + mbFirstPatSyn = find (isPatSyn . unLoc) binds + isPatSyn PatSynBind{} = True + isPatSyn _ = False + + sccs :: [SCC (LHsBind GhcRn)] + sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds) + + go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing) + go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc + -- recursive bindings must be unrestricted + -- (the ids added to the environment here are the name of the recursive definitions). + ; (binds2, thing) <- + tcExtendLetEnv top_lvl sig_fn closed ids1 + (go sccs) + ; return (binds1 ++ binds2, thing) } + go [] = do { thing <- thing_inside; return ([], thing) } + + tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] + tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds + + tc_sub_group rec_tc binds = tcPolyBinds top_lvl sig_fn prag_fn + Recursive rec_tc closed binds + +recursivePatSynErr + :: SrcSpan -- ^ The location of the first pattern synonym binding + -- (for error reporting) + -> LHsBinds GhcRn + -> TcM a +recursivePatSynErr loc binds + = failAt loc $ TcRnRecursivePatternSynonym binds + +tc_single :: forall thing. + TopLevelFlag -> TcSigFun -> TcPragEnv + -> LHsBind GhcRn -> IsGroupClosed -> TcM thing + -> TcM (LHsBinds GhcTc, thing) +tc_single _top_lvl sig_fn prag_fn + (L loc (PatSynBind _ psb)) + _ thing_inside + = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn + ; thing <- setGblEnv tcg_env thing_inside + ; return (aux_binds, thing) + } + +tc_single top_lvl sig_fn prag_fn lbind closed thing_inside + = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn + NonRecursive NonRecursive + closed + [lbind] + ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside + ; return (binds1, thing) } + +------------------------ +type BKey = Int -- Just number off the bindings + +mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)] +-- See Note [Polymorphic recursion] in "GHC.Hs.Binds". +mkEdges sig_fn binds + = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)), + Just key <- [lookupNameEnv key_map n], no_sig n ] + | (bind, key) <- keyd_binds + ] + -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices + -- is still deterministic even if the edges are in nondeterministic order + -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. + where + bind_fvs (FunBind { fun_ext = fvs }) = fvs + bind_fvs (PatBind { pat_ext = fvs }) = fvs + bind_fvs _ = emptyNameSet + + no_sig :: Name -> Bool + no_sig n = not (hasCompleteSig sig_fn n) + + keyd_binds = binds `zip` [0::BKey ..] + + key_map :: NameEnv BKey -- Which binding it comes from + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds + , bndr <- collectHsBindBinders CollNoDictBinders bind ] + +------------------------ +tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv + -> RecFlag -- Whether the group is really recursive + -> RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> IsGroupClosed -- Whether the group is closed + -> [LHsBind GhcRn] -- None are PatSynBind + -> TcM (LHsBinds GhcTc, [Scaled TcId]) + +-- Typechecks a single bunch of values bindings all together, +-- and generalises them. The bunch may be only part of a recursive +-- group, because we use type signatures to maximise polymorphism +-- +-- Returns a list because the input may be a single non-recursive binding, +-- in which case the dependency order of the resulting bindings is +-- important. +-- +-- Knows nothing about the scope of the bindings +-- None of the bindings are pattern synonyms + +tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list + = setSrcSpan loc $ + recoverM (recoveryCode binder_names sig_fn) $ do + -- Set up main recover; take advantage of any type sigs + + { traceTc "------------------------------------------------" Outputable.empty + ; traceTc "Bindings for {" (ppr binder_names) + ; dflags <- getDynFlags + ; let plan = decideGeneralisationPlan dflags top_lvl closed sig_fn bind_list + ; traceTc "Generalisation plan" (ppr plan) + ; result@(_, scaled_poly_ids) <- case plan of + NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list + InferGen -> tcPolyInfer top_lvl rec_tc prag_fn sig_fn bind_list + CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind + + ; let poly_ids = map scaledThing scaled_poly_ids + + ; mapM_ (\ poly_id -> + hasFixedRuntimeRep_syntactic (FRRBinder $ idName poly_id) (idType poly_id)) + poly_ids + + ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group + , vcat [ppr id <+> ppr (idType id) | id <- poly_ids] + ]) + + ; return result } + where + binder_names = collectHsBindListBinders CollNoDictBinders bind_list + loc = foldr1WithDefault noSrcSpan combineSrcSpans (map (locA . getLoc) bind_list) + -- The mbinds have been dependency analysed and + -- may no longer be adjacent; so find the narrowest + -- span that includes them all + +-------------- +-- If typechecking the binds fails, then return with each +-- signature-less binder given type (forall a.a), to minimise +-- subsequent error messages +recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Scaled Id]) +recoveryCode binder_names sig_fn + = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) + ; let poly_ids = map (Scaled ManyTy) $ map mk_dummy binder_names + ; return ([], poly_ids) } + where + mk_dummy name + | Just sig <- sig_fn name + , Just poly_id <- completeSigPolyId_maybe sig + = poly_id + | otherwise + = mkLocalId name ManyTy forall_a_a + +forall_a_a :: TcType +-- At one point I had (forall r (a :: TYPE r). a), but of course +-- that type is ill-formed: its mentions 'r' which escapes r's scope. +-- Another alternative would be (forall (a :: TYPE kappa). a), where +-- kappa is a unification variable. But I don't think we need that +-- complication here. I'm going to just use (forall (a::*). a). +-- See #15276 +forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy + +{- ********************************************************************* +* * + tcPolyNoGen +* * +********************************************************************* -} + +tcPolyNoGen -- No generalisation whatsoever + :: RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> TcPragEnv -> TcSigFun + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTc, [Scaled TcId]) + +tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list + = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn + (LetGblBndr prag_fn) + bind_list + ; mono_ids' <- mapM tc_mono_info mono_infos + ; return (binds', mono_ids') } + where + tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id, mbi_mono_mult = mult }) + = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name) + ; return $ Scaled mult mono_id } + -- NB: tcPrags generates error messages for + -- specialisation pragmas for non-overloaded sigs + -- Indeed that is why we call it here! + -- So we can safely ignore _specs + + +{- ********************************************************************* +* * + tcPolyCheck +* * +********************************************************************* -} + +tcPolyCheck :: TcPragEnv + -> TcCompleteSig + -> LHsBind GhcRn -- Must be a FunBind + -> TcM (LHsBinds GhcTc, [Scaled TcId]) +-- There is just one binding, +-- it is a FunBind +-- it has a complete type signature, +tcPolyCheck prag_fn + sig@(CSig { sig_bndr = poly_id, sig_ctxt = ctxt }) + (L bind_loc (FunBind { fun_id = L nm_loc name + , fun_matches = matches })) + = do { traceTc "tcPolyCheck" (ppr sig) + + -- Make a new Name, whose SrcSpan is nm_loc. For a ClassOp + -- The original Name, in the FunBind{fun_id}, is bound in the + -- class declaration, whereas we want a Name bound right here. + -- We pass mono_name to tcFunBindMatches which in turn puts it in + -- the BinderStack, whence it shows up in "Relevant bindings.." + ; mono_name <- newNameAt (nameOccName name) (locA nm_loc) + + ; mult <- newMultiplicityVar + ; (wrap_gen, (wrap_res, matches')) + <- tcSkolemiseCompleteSig sig $ \invis_pat_tys rho_ty -> + + let mono_id = mkLocalId mono_name (idMult poly_id) rho_ty in + tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ + -- Why mono_id in the BinderStack? + -- See Note [Relevant bindings and the binder stack] + + setSrcSpanA bind_loc $ + tcFunBindMatches ctxt mono_name mult matches invis_pat_tys (mkCheckExpType rho_ty) + + -- We make a funny AbsBinds, abstracting over nothing, + -- just so we have somewhere to put the SpecPrags. + -- Otherwise we could just use the FunBind + -- Hence poly_id2 is just a clone of poly_id; + -- We re-use mono-name, but we could equally well use a fresh one + + ; let prag_sigs = lookupPragEnv prag_fn name + poly_id2 = mkLocalId mono_name (idMult poly_id) (idType poly_id) + ; spec_prags <- tcSpecPrags poly_id prag_sigs + ; poly_id <- addInlinePrags poly_id prag_sigs + + ; mod <- getModule + ; tick <- funBindTicks (locA nm_loc) poly_id mod prag_sigs + + ; let bind' = FunBind { fun_id = L nm_loc poly_id2 + , fun_matches = matches' + , fun_ext = (wrap_gen <.> wrap_res, tick) } + + export = ABE { abe_wrap = idHsWrapper + , abe_poly = poly_id + , abe_mono = poly_id2 + , abe_prags = SpecPrags spec_prags } + + abs_bind = L bind_loc $ XHsBindsLR $ + AbsBinds { abs_tvs = [] + , abs_ev_vars = [] + , abs_ev_binds = [] + , abs_exports = [export] + , abs_binds = [L bind_loc bind'] + , abs_sig = True } + + ; return ([abs_bind], [Scaled mult poly_id]) } + +tcPolyCheck _prag_fn sig bind + = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) + +funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] + -> TcM [CoreTickish] +funBindTicks loc fun_id mod sigs + | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ] + -- this can only be a singleton list, as duplicate pragmas are rejected + -- by the renamer + , let cc_str + | Just cc_str <- mb_cc_str + = sl_fs $ unLoc cc_str + | otherwise + = getOccFS (Var.varName fun_id) + cc_name = concatFS [moduleNameFS (moduleName mod), fsLit ".", cc_str] + = do + flavour <- mkDeclCCFlavour <$> getCCIndexTcM cc_name + let cc = mkUserCC cc_name mod loc flavour + return [ProfNote cc True True] + | otherwise + = return [] + +{- Note [Instantiate sig with fresh variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's vital to instantiate a type signature with fresh variables. +For example: + type T = forall a. [a] -> [a] + f :: T; + f = g where { g :: T; g = } + + We must not use the same 'a' from the defn of T at both places!! +(Instantiation is only necessary because of type synonyms. Otherwise, +it's all cool; each signature has distinct type variables from the renamer.) +-} + + +{- ********************************************************************* +* * + tcPolyInfer +* * +********************************************************************* -} + +{- Note [Non-variable pattern bindings aren't linear] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A fundamental limitation of the typechecking algorithm is that we cannot have a +binding which, at the same time, +- is linear in its rhs +- is a non-variable pattern +- binds variables to polymorphic or qualified types + +A detailed explanation can be found at: +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst#let-bindings-and-polymorphism + +To address this we to do a few things + +- (NVP1) When a pattern is annotated with a multiplicity annotation `let %q pat = rhs + in body` (note: multiplicity-annotated bindings are always parsed as a + PatBind, see Note [Multiplicity annotations] in Language.Haskell.Syntax.Binds), + then the let is never generalised (we use the NoGen plan). We do this with a + dedicated test in decideGeneralisationPlan. +- (NVP2) Whenever the typechecker infers an AbsBind *and* the inner binding is a + non-variable PatBind, then the multiplicity of the binding is inferred to be + Many. We do this by calling manyIfPats in tcPolyInfer. This is a little + infelicitous: sometimes the typechecker infers an AbsBind where it didn't need + to. This may cause some programs to be spuriously rejected, when + NoMonoLocalBinds is on. +- (NVP3) LinearLet implies MonoLocalBinds to avoid the AbsBind case altogether. +- (NVP4) Wrinkle: even when other conditions (including MonoLocalBinds), GHC + will generalise some binders, namely so-called closed binding groups. We need + to make sure that the test for (NVP1) has priority over the test for closed + binders. +- (NVP5) Wrinkle: Closed binding groups (NVP4) are usually fine to type with + multiplicity Many. But there's one exception: when there's no binder at all, + the binding group is considered closed. Even if the rhs contains arbitrary + variables. + + f :: () %1 -> Bool + f x = let !() = x in True + + If we consider `!() = x` as a generalisable group (which does nothing anyway), + then (NVP2) will infer the pattern as multiplicity Many, and reject the + function. We don't want that, see also #25428. So we take care not to + generalise in this case, by excluding the no-binder case from automatic + generalisation in decideGeneralisationPlan. +-} + +tcPolyInfer + :: TopLevelFlag + -> RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> TcPragEnv -> TcSigFun + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTc, [Scaled TcId]) +tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn bind_list + = do { (tclvl, wanted, (binds', mono_infos)) + <- pushLevelAndCaptureConstraints $ + tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list + + ; apply_mr <- checkMonomorphismRestriction mono_infos bind_list + + -- AbsBinds which are PatBinds can't be linear. + -- See (NVP2) in Note [Non-variable pattern bindings aren't linear] + ; manyIfPats binds' + + ; traceTc "tcPolyInfer" (ppr apply_mr $$ ppr (map mbi_sig mono_infos)) + + ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info)) + | info <- mono_infos ] + sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ] + infer_mode = if apply_mr then ApplyMR else NoRestrictions + + ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) + ; ((qtvs, givens, ev_binds, insoluble), residual) + <- captureConstraints $ simplifyInfer top_lvl tclvl infer_mode sigs name_taus wanted + + ; let inferred_theta = map evVarPred givens + ; scaled_exports <- checkNoErrs $ + mapM (mkExport prag_fn residual insoluble qtvs inferred_theta) mono_infos + ; let exports = map scaledThing scaled_exports + + -- 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 scaled_poly_ids = [ Scaled p (abe_poly export) | Scaled p export <- scaled_exports] + poly_ids = map scaledThing scaled_poly_ids + abs_bind = L (noAnnSrcSpan loc) $ XHsBindsLR $ + AbsBinds { abs_tvs = qtvs + , abs_ev_vars = givens, abs_ev_binds = [ev_binds] + , abs_exports = exports, abs_binds = binds' + , abs_sig = False } + + ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids)) + ; return ([abs_bind], scaled_poly_ids) } + -- poly_ids are guaranteed zonked by mkExport + where + manyIfPat (L _ (PatBind{pat_lhs=(L _ (VarPat{}))})) + = return () + manyIfPat (L _ (PatBind {pat_mult=mult_ann})) + = tcSubMult (NonLinearPatternOrigin GeneralisedPatternReason nlWildPatName) ManyTy (getTcMultAnn mult_ann) + manyIfPat _ = return () + manyIfPats binds' = traverse_ manyIfPat binds' + +checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool +-- True <=> apply the MR +-- See Note [When the MR applies] +checkMonomorphismRestriction mbis lbinds + = do { mr_on <- xoptM LangExt.MonomorphismRestriction + ; let mr_applies = mr_on && any (restricted . unLoc) lbinds + ; when mr_applies $ mapM_ checkOverloadedSig mbis + ; return mr_applies } + where + no_mr_bndrs :: NameSet + no_mr_bndrs = mkNameSet (mapMaybe no_mr_name mbis) + + no_mr_name :: MonoBindInfo -> Maybe Name + -- Just n for binders that have a signature that says "no MR needed for me" + no_mr_name (MBI { mbi_sig = Just sig }) + | TISI { sig_inst_sig = info, sig_inst_theta = theta, sig_inst_wcx = wcx } <- sig + = case info of + TcCompleteSig (CSig { sig_bndr = bndr }) -> Just (idName bndr) + TcPartialSig (PSig { psig_name = nm }) + | null theta, isNothing wcx -> Nothing -- f :: _ -> _ + | otherwise -> Just nm -- f :: Num a => a -> _ + -- For the latter case, we don't want the MR: + -- the user has explicitly specified a type-class context + no_mr_name _ = Nothing + + -- The Haskell 98 monomorphism restriction + restricted :: HsBindLR GhcRn GhcRn -> Bool + restricted (PatBind {}) = True + restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m + && mr_needed_for (unLoc v) + restricted (VarBind { var_ext = x }) = dataConCantHappen x + restricted b@(PatSynBind {}) = pprPanic "isRestrictedGroup/unrestricted" (ppr b) + + restricted_match mg = matchGroupArity mg == 0 + -- No args => like a pattern binding + -- Some args => a function binding + + mr_needed_for nm = not (nm `elemNameSet` no_mr_bndrs) + +checkOverloadedSig :: MonoBindInfo -> TcM () +-- Example: +-- f :: Eq a => a -> a +-- K f = e +-- The MR applies, but the signature is overloaded, and it's +-- best to complain about this directly +-- c.f #11339 +checkOverloadedSig (MBI { mbi_sig = Just sig }) + | TISI { sig_inst_sig = orig_sig, sig_inst_theta = theta, sig_inst_wcx = wcx } <- sig + , not (null theta && isNothing wcx) + = setSrcSpan (tcIdSigLoc orig_sig) $ + failWith $ TcRnOverloadedSig orig_sig +checkOverloadedSig _ = return () + +{- Note [When the MR applies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Monomorphism Restriction (MR) applies as specifies in the Haskell Report: + +* If -XMonomorphismRestriction is on, and +* Any binding is restricted + +A binding is restricted if: +* It is a pattern binding e.g. (x,y) = e +* Or it is a FunBind with no arguments e.g. f = rhs + and the binder `f` lacks a No-MR signature + +A binder f has a No-MR signature if + +* It has a complete type signature + e.g. f :: Num a => a -> a + +* Or it has a /partial/ type signature with a /context/ + e.g. f :: (_) => a -> _ + g :: Num a => a -> _ + h :: (Num a, _) => a -> _ + All of f,g,h have a No-MR signature. They say that the function is overloaded + so it's silly to try to apply the MR. This means that #19106 works out + fine. Ditto #11016, which looked like + f4 :: (?loc :: Int) => _ + f4 = ?loc + + This partial-signature stuff is a bit ad-hoc but seems to match our + use-cases. See also Note [Constraints in partial type signatures] + in GHC.Tc.Solver. + +Example: the MR does apply to + k :: _ -> _ + k = rhs +because k's binding has no arguments, and `k` does not have +a No-MR signature. + +All of this checking takes place after synonym expansion. For example: + type Wombat a = forall b. Eq [b] => ...b...a... + f5 :: Wombat _ +This (and does) behave just like + f5 :: forall b. Eq [b] => ...b..._... + +-} + +-------------- +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 (Scaled ABExport) +-- Only called for generalisation plan InferGen, not by CheckGen or NoGen +-- +-- mkExport generates exports with +-- zonked type variables, +-- zonked poly_ids +-- The former is just because no further unifications will change +-- the quantified type variables, so we can fix their final form +-- right now. +-- The latter is needed because the poly_ids are used to extend the +-- type environment; see the invariant on GHC.Tc.Utils.Env.tcExtendIdEnv + +-- Pre-condition: the qtvs and theta are already zonked + +mkExport prag_fn residual insoluble qtvs theta + (MBI { mbi_poly_name = poly_name + , mbi_sig = mb_sig + , mbi_mono_id = mono_id + , mbi_mono_mult = mono_mult }) + = do { mono_ty <- liftZonkM $ zonkTcType (idType mono_id) + ; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty + + -- NB: poly_id has a zonked type + ; poly_id <- addInlinePrags poly_id prag_sigs + ; spec_prags <- tcExtendIdEnv1 poly_name poly_id $ + tcSpecPrags poly_id prag_sigs + -- tcSpecPrags requires a zonked poly_id. It also needs poly_id to + -- be in the type env (so we can typecheck the SPECIALISE expression) + + -- See Note [Impedance matching] + -- NB: we have already done checkValidType, including an ambiguity check, + -- on the type; either when we checked the sig or in mkInferredPolyId + ; let poly_ty = idType poly_id + sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty + -- This type is just going into tcSubType, + -- so Inferred vs. Specified doesn't matter + + ; traceTc "mkExport" (vcat [ ppr poly_id <+> dcolon <+> ppr poly_ty + , ppr sel_poly_ty ]) + + ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility + then return idHsWrapper -- Fast path; also avoids complaint when we infer + -- an ambiguous type and have AllowAmbiguousType + -- e..g infer x :: forall a. F a -> Int + else tcSubTypeSigma (ImpedanceMatching poly_id) + sig_ctxt sel_poly_ty poly_ty + -- See Note [Impedance matching] + + ; localSigWarn poly_id mb_sig + + ; return (Scaled mono_mult $ + ABE { abe_wrap = wrap + -- abe_wrap :: (forall qtvs. theta => mono_ty) ~ idType poly_id + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = SpecPrags spec_prags }) } + where + prag_sigs = lookupPragEnv prag_fn poly_name + sig_ctxt = InfSigCtxt poly_name + +mkInferredPolyId :: WantedConstraints -- the residual constraints, already emitted + -> Bool -- True <=> there was an insoluble error when + -- checking the binding group for this Id + -> [TyVar] -> TcThetaType + -> Name -> Maybe TcIdSigInst -> TcType + -> TcM TcId +mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty + | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst + , TcCompleteSig (CSig { sig_bndr = poly_id }) <- sig + = return poly_id + + | otherwise -- Either no type sig or partial type sig + = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous + -- we don't carry on to the impedance matching, and generate + -- a duplicate ambiguity error. There is a similar + -- checkNoErrs for complete type signatures too. + do { fam_envs <- tcGetFamInstEnvs + ; let mono_ty' = reductionReducedType $ normaliseType fam_envs Nominal mono_ty + -- Unification may not have normalised the type, + -- so do it here to make it as uncomplicated as possible. + -- Example: f :: [F Int] -> Bool + -- should be rewritten to f :: [Char] -> Bool, if possible + -- + -- We can discard the coercion _co, because we'll reconstruct + -- it in the call to tcSubType below + + ; (binders, theta') <- chooseInferredQuantifiers residual inferred_theta + (tyCoVarsOfType mono_ty') qtvs mb_sig_inst + + ; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty') + + ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' + , ppr inferred_poly_ty + , text "insoluble" <+> ppr insoluble ]) + + ; unless insoluble $ + addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ + do { checkEscapingKind inferred_poly_ty + -- See Note [Inferred type with escaping kind] + ; checkValidType (InfSigCtxt poly_name) inferred_poly_ty } + -- See Note [Validity of inferred types] + -- unless insoluble: if we found an insoluble error in the + -- function definition, don't do this check; otherwise + -- (#14000) we may report an ambiguity error for a rather + -- bogus type. + + ; return (mkLocalId poly_name ManyTy inferred_poly_ty) } + + +chooseInferredQuantifiers :: WantedConstraints -- residual constraints + -> TcThetaType -- inferred + -> TcTyVarSet -- tvs free in tau type + -> [TcTyVar] -- inferred quantified tvs + -> Maybe TcIdSigInst + -> TcM ([InvisTVBinder], TcThetaType) +chooseInferredQuantifiers _residual inferred_theta tau_tvs qtvs Nothing + = -- No type signature (partial or complete) for this binder, + do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) + -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver + -- Include kind variables! #7916 + my_theta = pickCapturedPreds free_tvs inferred_theta + binders = [ mkTyVarBinder InferredSpec tv + | tv <- qtvs + , tv `elemVarSet` free_tvs ] + ; return (binders, my_theta) } + +chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs + (Just (TISI { sig_inst_sig = sig, sig_inst_wcx = wcx + , sig_inst_theta = annotated_theta, sig_inst_skols = annotated_tvs })) + | TcPartialSig (PSig { psig_name = fn_name, psig_hs_ty = hs_ty }) <- sig + = -- Choose quantifiers for a partial type signature + do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs + ; psig_qtv_bndrs <- liftZonkM $ mapM zonkInvisTVBinder psig_qtv_bndrs + ; let psig_qtvs = map binderVar psig_qtv_bndrs + psig_qtv_set = mkVarSet psig_qtvs + psig_qtv_prs = psig_qtv_nms `zip` psig_qtvs + psig_bndr_map :: TyVarEnv InvisTVBinder + psig_bndr_map = mkVarEnv [ (binderVar tvb, tvb) | tvb <- psig_qtv_bndrs ] + + -- Check whether the quantified variables of the + -- partial signature have been unified together + -- See Note [Quantified variables in partial type signatures] + ; mapM_ (report_dup_tyvar_tv_err fn_name hs_ty) $ + findDupTyVarTvs psig_qtv_prs + + -- Check whether a quantified variable of the partial type + -- signature is not actually quantified. How can that happen? + -- See Note [Quantification and partial signatures] Wrinkle 4 + -- in GHC.Tc.Solver + ; mapM_ (report_mono_sig_tv_err fn_name hs_ty) + [ pr | pr@(_,tv) <- psig_qtv_prs, not (tv `elem` qtvs) ] + + ; annotated_theta <- liftZonkM $ zonkTcTypes annotated_theta + ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx + -- NB: free_tvs includes tau_tvs + + ; let (_,final_qtvs) = foldr (choose_qtv psig_bndr_map) (free_tvs, []) qtvs + -- Pulling from qtvs maintains original order + -- NB: qtvs is already in dependency order + + ; traceTc "chooseInferredQuantifiers" $ + vcat [ text "qtvs" <+> pprTyVars qtvs + , text "psig_qtv_bndrs" <+> ppr psig_qtv_bndrs + , text "free_tvs" <+> ppr free_tvs + , text "final_tvs" <+> ppr final_qtvs ] + + ; return (final_qtvs, my_theta) } + where + choose_qtv :: TyVarEnv InvisTVBinder -> TcTyVar + -> (TcTyVarSet, [InvisTVBinder]) -> (TcTyVarSet, [InvisTVBinder]) + -- Pick which of the original qtvs should be retained + -- Keep it if (a) it is mentioned in the body of the type (free_tvs) + -- (b) it is a forall'd variable of the partial signature (psig_qtv_bndrs) + -- (c) it is mentioned in the kind of a retained qtv (#22065) + choose_qtv psig_bndr_map tv (free_tvs, qtvs) + | Just psig_bndr <- lookupVarEnv psig_bndr_map tv + = (free_tvs', psig_bndr : qtvs) + | tv `elemVarSet` free_tvs + = (free_tvs', mkTyVarBinder InferredSpec tv : qtvs) + | otherwise -- Do not pick it + = (free_tvs, qtvs) + where + free_tvs' = free_tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) + + choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType + -> TcM (VarSet, TcThetaType) + choose_psig_context _ annotated_theta Nothing + = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta + `unionVarSet` tau_tvs) + ; return (free_tvs, annotated_theta) } + + choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty) + = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs) + -- growThetaTyVars just like the no-type-sig case + -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver + -- Omitting this caused #12844 + seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there + `unionVarSet` tau_tvs -- by the user + + ; let keep_me = psig_qtvs `unionVarSet` free_tvs + my_theta = pickCapturedPreds keep_me inferred_theta + + -- Fill in the extra-constraints wildcard hole with inferred_theta, + -- so that the Hole constraint we have already emitted + -- (in tcHsPartialSigType) can report what filled it in. + -- NB: my_theta already includes all the annotated constraints + ; diff_theta <- findInferredDiff annotated_theta my_theta + + ; case getCastedTyVar_maybe wc_var_ty of + -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it + -- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc. + -- So, to make the kinds work out, we reverse the cast here. + Just (wc_var, wc_co) -> liftZonkM $ + writeMetaTyVar wc_var (mkConstraintTupleTy diff_theta + `mkCastTy` mkSymCo wc_co) + Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) + + ; traceTc "completeTheta" $ + vcat [ ppr sig + , text "annotated_theta:" <+> ppr annotated_theta + , text "inferred_theta:" <+> ppr inferred_theta + , text "my_theta:" <+> ppr my_theta + , text "diff_theta:" <+> ppr diff_theta ] + ; return (free_tvs, annotated_theta ++ diff_theta) } + -- Return (annotated_theta ++ diff_theta) + -- See Note [Extra-constraints wildcards] + + report_dup_tyvar_tv_err fn_name hs_ty (n1,n2) + = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty) + + report_mono_sig_tv_err fn_name hs_ty (n,tv) + = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty) + where + m_unif_ty = listToMaybe + [ rhs + -- recall that residuals are always implications + | residual_implic <- bagToList $ wc_impl residual + , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic) + , let residual_pred = ctPred residual_ct + , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ] + , Just lhs_tv <- [ getTyVar_maybe lhs ] + , lhs_tv == tv ] + +chooseInferredQuantifiers _ _ _ _ (Just sig) + = pprPanic "chooseInferredQuantifiers" (ppr sig) + +mk_inf_msg :: Name -> TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) +mk_inf_msg poly_name poly_ty tidy_env + = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty + ; return (tidy_env1, InferredTypeCtxt poly_name poly_ty) } + +-- | Warn the user about polymorphic local binders that lack type signatures. +localSigWarn :: Id -> Maybe TcIdSigInst -> TcM () +localSigWarn id mb_sig + | Just _ <- mb_sig = return () + | not (isSigmaTy (idType id)) = return () + | otherwise = warnMissingSignatures id + +warnMissingSignatures :: Id -> TcM () +warnMissingSignatures id + = do { env0 <- liftZonkM $ tcInitTidyEnv + ; let (env1, tidy_ty) = tidyOpenTypeX env0 (idType id) + ; let dia = TcRnPolymorphicBinderMissingSig (idName id) tidy_ty + ; addDiagnosticTcM (env1, dia) } + +{- Note [Partial type signatures and generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If /any/ of the signatures in the group is a partial type signature + f :: _ -> Int +then we *always* use the InferGen plan, and hence tcPolyInfer. +We do this even for a local binding with -XMonoLocalBinds, when +we normally use NoGen. + +Reasons: + * The TcSigInfo for 'f' has a unification variable for the '_', + whose TcLevel is one level deeper than the current level. + (See pushTcLevelM in tcTySig.) But NoGen doesn't increase + the TcLevel like InferGen, so we lose the level invariant. + + * The signature might be f :: forall a. _ -> a + so it really is polymorphic. It's not clear what it would + mean to use NoGen on this, and indeed the ASSERT in tcLhs, + in the (Just sig) case, checks that if there is a signature + then we are using LetLclBndr, and hence a nested AbsBinds with + increased TcLevel + +It might be possible to fix these difficulties somehow, but there +doesn't seem much point. Indeed, adding a partial type signature is a +way to get per-binding inferred generalisation. + +Note [Quantified variables in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a. a -> a -> _ + f x y = g x y + g :: forall b. b -> b -> _ + g x y = [x, y] + +Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b' +together, which is fine. So we bind 'a' and 'b' to TyVarTvs, which can then +unify with each other. + +But now consider: + f :: forall a b. a -> b -> _ + f x y = [x, y] + +We want to get an error from this, because 'a' and 'b' get unified. +So we make a test, one per partial signature, to check that the +explicitly-quantified type variables have not been unified together. +#14449 showed this up. + +Note [Extra-constraints wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this from #18646 + class Foo x where + foo :: x + + bar :: (Foo (), _) => f () + bar = pure foo + +We get [W] Foo (), [W] Applicative f. When we do pickCapturedPreds in +choose_psig_context, we'll discard Foo ()! Usually would not quantify over +such (closed) predicates. So my_theta will be (Applicative f). But we really +do want to quantify over (Foo ()) -- it was specified by the programmer. +Solution: always return annotated_theta (user-specified) plus the extra piece +diff_theta. + +Note [Validity of inferred types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to check inferred type for validity, in case it uses language +extensions that are not turned on. The principle is that if the user +simply adds the inferred type to the program source, it'll compile fine. +See #8883. + +Examples that might fail: + - the type might be ambiguous + + - an inferred theta that requires type equalities e.g. (F a ~ G b) + or multi-parameter type classes + - an inferred type that includes unboxed tuples + +Note [Inferred type with escaping kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check for an inferred type with an escaping kind; e.g. #23051 + forall {k} {f :: k -> RuntimeRep} {g :: k} {a :: TYPE (f g)}. a +where the kind of the body of the forall mentions `f` and `g` which +are bound by the forall. No no no. + +This check, mkInferredPolyId, is really in the wrong place: +`inferred_poly_ty` doesn't obey the PKTI and it would be better not to +generalise it in the first place; see #20686. But for now it works. + +I considered adjusting the generalisation in GHC.Tc.Solver to directly check for +escaping kind variables; instead, promoting or defaulting them. But that +gets into the defaulting swamp and is a non-trivial and unforced +change, so I have left it alone for now. + +Note [Impedance matching] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f 0 x = x + f n x = g [] (not x) + + g [] y = f 10 y + g _ y = f 9 y + +After typechecking we'll get + f_mono_ty :: a -> Bool -> Bool + g_mono_ty :: [b] -> Bool -> Bool +with constraints + (Eq a, Num a) + +Note that f is polymorphic in 'a' and g in 'b'; and these are not linked. +The types we really want for f and g are + f :: forall a. (Eq a, Num a) => a -> Bool -> Bool + g :: forall b. [b] -> Bool -> Bool + +We can get these by "impedance matching": + tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool) + tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) + + f a d1 d2 = case tuple a Any d1 d2 of (f_mono, g_mono) -> f_mono + g b = case tuple Integer b dEqInteger dNumInteger of (f_mono,g_mono) -> g_mono + +Suppose the shared quantified tyvars are qtvs and constraints theta. +Then we want to check that + forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype +and the proof is the impedance matcher. + +The impedance matcher can do defaulting: in the above example, we default +to Integer because of Num. See #7173. If we're dealing with a nondefaultable +class, impedance matching can fail. See #23427. + +************************************************************************ +* * + tcMonoBinds +* * +************************************************************************ + +@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. +The signatures have been dealt with already. +-} + +data MonoBindInfo = MBI { mbi_poly_name :: Name + , mbi_sig :: Maybe TcIdSigInst + , mbi_mono_id :: TcId + , mbi_mono_mult :: Mult } + +tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes + -- i.e. the binders are mentioned in their RHSs, and + -- we are not rescued by a type signature + -> TcSigFun -> LetBndrSpec + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTc, [MonoBindInfo]) + +-- SPECIAL CASE 1: see Note [Special case for non-recursive function bindings] +tcMonoBinds is_rec sig_fn no_gen + [ L b_loc (FunBind { fun_id = L nm_loc name + , fun_matches = matches })] + -- Single function binding, + | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS + , Nothing <- sig_fn name -- ...with no type signature + = setSrcSpanA b_loc $ + do { mult <- newMultiplicityVar + + ; ((co_fn, matches'), rhs_ty') + <- runInferRhoFRR (FRRBinder name) $ \ exp_ty -> + -- runInferRhoFRR: the type of a let-binder must have + -- a fixed runtime rep. See #23176 + 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. + -- See Note [Relevant bindings and the binder stack] + tcFunBindMatches (InfSigCtxt name) name mult matches [] exp_ty + ; mono_id <- newLetBndr no_gen name mult rhs_ty' + + ; return (singleton $ L b_loc $ + FunBind { fun_id = L nm_loc mono_id, + fun_matches = matches', + fun_ext = (co_fn, []) }, + [MBI { mbi_poly_name = name + , mbi_sig = Nothing + , mbi_mono_id = mono_id + , mbi_mono_mult = mult }]) } + +-- 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, pat_mult = mult_ann })] + | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS + , all (isNothing . sig_fn) bndrs + = addErrCtxt (PatMonoBindsCtxt pat grhss) $ + do { mult <- tcMultAnnOnPatBind mult_ann + + ; (grhss', pat_ty) <- runInferRhoFRR FRRPatBind $ \ exp_ty -> + -- runInferRhoFRR: the type of each let-binder must have + -- a fixed runtime rep. See #23176 + tcGRHSsPat mult grhss exp_ty + + ; let exp_pat_ty :: Scaled ExpSigmaTypeFRR + exp_pat_ty = Scaled mult (mkCheckExpType pat_ty) + ; (_, (pat', mbis)) <- tcCollectingUsage $ + tcLetPat (const Nothing) no_gen pat exp_pat_ty $ do + tcEmitBindingUsage bottomUE + mapM lookupMBI bndrs + -- What's happening here? Typing pattern-matching (either from case + -- expression or equation) and typing bindings (let or where) have a + -- different control flow: for pattern-matching, the rhs is typed + -- within the `thing_inside` argument. The type-checker walks down + -- the pattern, and when finally it is done, all variables have been + -- added to the environment, thing_inside is called. So, when + -- type-checking patterns, the check for the correctness of + -- multiplicity is generated in the VarPat case. This is quite + -- natural. + -- + -- Bindings, however, have a more complex control flow for our + -- purpose: we collect all the variables as we go down, then return + -- them (here as `mapM lookupMBI bndrs`), and in a subsequent + -- computation (rather than an inner computation), the rhs is + -- type-checked. This poses a problem here: we're calling + -- `tcLetPat`, which will verify the proper usage of the introduced + -- variable when reaching the `VarPat` case. But there is no actual + -- usage of variable in the `thing_inside`. This would always + -- fail. So we emit a `bottomUE`, which is compatible with every + -- usage. So that we can bypass the check in VarPat. Then we use + -- `tcCollectingUsage` to throw the `bottomUE` away, since it would + -- let us bypass many linearity checks. + + ; return ( singleton $ L b_loc $ + PatBind { pat_lhs = pat', pat_rhs = grhss' + , pat_ext = (pat_ty, ([],[])) + , pat_mult = setTcMultAnn mult mult_ann } + + , mbis ) } + where + bndrs = collectPatBinders CollNoDictBinders pat + +-- GENERAL CASE +tcMonoBinds _ sig_fn no_gen binds + = do { tc_binds <- mapM (wrapLocMA (tcLhs sig_fn no_gen)) binds + + -- Bring the monomorphic Ids, into scope for the RHSs + ; let mono_infos = getMonoBindInfo tc_binds + rhs_id_env = [ (name, mono_id) + | MBI { mbi_poly_name = name + , mbi_sig = mb_sig + , mbi_mono_id = mono_id } <- mono_infos + , case mb_sig of + Just sig -> isPartialSig sig + Nothing -> True ] + -- A monomorphic binding for each term variable that lacks + -- a complete type sig. (Ones with a sig are already in scope.) + + ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) + | (n,id) <- rhs_id_env] + ; binds' <- tcExtendRecIds rhs_id_env $ + mapM (wrapLocMA tcRhs) tc_binds + + ; return (binds', mono_infos) } + +{- Note [Special case for non-recursive function bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the special case of +* A non-recursive FunBind +* With no type signature +we infer the type of the right hand side first (it may have a +higher-rank type) and *then* make the monomorphic Id for the LHS e.g. + f = \(x::forall a. a->a) -> + +We want to infer a higher-rank type for f + +Note [Special case for non-recursive pattern bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the special case of +* A pattern binding +* With no type signature for any of the binders +we can /infer/ the type of the RHS, and /check/ the pattern +against that type. For example (#18323) + + ids :: [forall a. a -> a] + combine :: (forall a . [a] -> a) -> [forall a. a -> a] + -> ((forall a . [a] -> a), [forall a. a -> a]) + + (x,y) = combine head ids + +with -XImpredicativeTypes we can infer a good type for +(combine head ids), and use that to tell us the polymorphic +types of x and y. + +We don't need to check -XImpredicativeTypes because without it +these types like [forall a. a->a] are illegal anyway, so this +special case code only really has an effect if -XImpredicativeTypes +is on. Small exception: + (x) = e +is currently treated as a pattern binding so, even absent +-XImpredicativeTypes, we will get a small improvement in behaviour. +But I don't think it's worth an extension flag. + +Why do we require no type signatures on /any/ of the binders? +Consider + x :: forall a. a->a + y :: forall a. a->a + (x,y) = (id,id) + +Here we should /check/ the RHS with expected type + (forall a. a->a, forall a. a->a). + +If we have no signatures, we can the approach of this Note +to /infer/ the type of the RHS. + +But what if we have some signatures, but not all? Say this: + p :: forall a. a->a + (p,q) = (id, (\(x::forall b. b->b). x True)) + +Here we want to push p's signature inwards, i.e. /checking/, to +correctly elaborate 'id'. But we want to /infer/ q's higher rank +type. There seems to be no way to do this. So currently we only +switch to inference when we have no signature for any of the binders. + +-} + + +------------------------ +-- tcLhs typechecks the LHS of the bindings, to construct the environment in which +-- we typecheck the RHSs. Basically what we are doing is this: for each binder: +-- if there's a signature for it, use the instantiated signature type +-- otherwise invent a type variable +-- You see that quite directly in the FunBind case. +-- +-- But there's a complication for pattern bindings: +-- data T = MkT (forall a. a->a) +-- MkT f = e +-- Here we can guess a type variable for the entire LHS (which will be refined to T) +-- but we want to get (f::forall a. a->a) as the RHS environment. +-- The simplest way to do this is to typecheck the pattern, and then look up the +-- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing +-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't + +data TcMonoBind -- Half completed; LHS done, RHS not done + = TcFunBind MonoBindInfo SrcSpan Mult (MatchGroup GhcRn (LHsExpr GhcRn)) + | TcPatBind [MonoBindInfo] (LPat GhcTc) Mult (HsMultAnn GhcRn) (GRHSs GhcRn (LHsExpr GhcRn)) + TcSigmaTypeFRR + +tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind +-- Only called with plan InferGen (LetBndrSpec = LetLclBndr) +-- or NoGen (LetBndrSpec = LetGblBndr) +-- CheckGen is used only for functions with a complete type signature, +-- and tcPolyCheck doesn't use tcMonoBinds at all + +tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name + , fun_matches = matches }) + | Just (TcIdSig sig) <- sig_fn name + = -- There is a type signature. + -- It must be partial; if complete we'd be in tcPolyCheck! + -- e.g. f :: _ -> _ + -- f x = ...g... + -- Just g = ...f... + -- Hence always typechecked with InferGen + do { mono_info <- tcLhsSigId no_gen (name, sig) + ; mult <- newMultiplicityVar + ; return (TcFunBind mono_info (locA nm_loc) mult matches) } + + | otherwise -- No type signature + = do { mono_ty <- newOpenFlexiTyVarTy + ; mult <- newMultiplicityVar + ; mono_id <- newLetBndr no_gen name mult mono_ty + ; let mono_info = MBI { mbi_poly_name = name + , mbi_sig = Nothing + , mbi_mono_id = mono_id + , mbi_mono_mult = mult} + ; return (TcFunBind mono_info (locA nm_loc) mult matches) } + +tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_ann }) + = -- See Note [Typechecking pattern bindings] + do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names + + ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $ + [ (mbi_poly_name mbi, mbi_mono_id mbi) + | mbi <- sig_mbis ] + ; mult <- tcMultAnnOnPatBind mult_ann + -- See Note [Typechecking pattern bindings] + ; ((pat', nosig_mbis), pat_ty) + <- addErrCtxt (PatMonoBindsCtxt pat grhss) $ + runInferSigmaFRR FRRPatBind $ \ exp_ty -> + tcLetPat inst_sig_fun no_gen pat (Scaled mult exp_ty) $ + -- The above inferred type get an unrestricted multiplicity. It may be + -- worth it to try and find a finer-grained multiplicity here + -- if examples warrant it. + mapM lookupMBI nosig_names + + ; let mbis = sig_mbis ++ nosig_mbis + + ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id) + | mbi <- mbis, let id = mbi_mono_id mbi ] + $$ ppr no_gen) + + ; return (TcPatBind mbis pat' mult mult_ann grhss pat_ty) } + where + bndr_names = collectPatBinders CollNoDictBinders pat + (nosig_names, sig_names) = partitionWith find_sig bndr_names + + find_sig :: Name -> Either Name (Name, TcIdSig) + find_sig name = case sig_fn name of + Just (TcIdSig sig) -> Right (name, sig) + _ -> Left name + +tcLhs _ _ b@(PatSynBind {}) = pprPanic "tcLhs: PatSynBind" (ppr b) + -- pattern synonyms are handled separately; see tc_single + +tcLhs _ _ (VarBind { var_ext = x }) = dataConCantHappen x + +lookupMBI :: Name -> TcM MonoBindInfo +-- After typechecking the pattern, look up the binder +-- names that lack a signature, which the pattern has brought +-- into scope. +lookupMBI name + = do { mono_id <- tcLookupId name + ; return (MBI { mbi_poly_name = name + , mbi_sig = Nothing + , mbi_mono_id = mono_id + , mbi_mono_mult = idMult mono_id }) } + +------------------- +tcLhsSigId :: LetBndrSpec -> (Name, TcIdSig) -> TcM MonoBindInfo +tcLhsSigId no_gen (name, sig) + = do { inst_sig <- tcInstSig sig + ; mono_id <- newSigLetBndr no_gen name inst_sig + ; return (MBI { mbi_poly_name = name + , mbi_sig = Just inst_sig + , mbi_mono_id = mono_id + , mbi_mono_mult = idMult mono_id }) } + +------------ +newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId +newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig }) + | TcCompleteSig (CSig { sig_bndr = poly_id }) <- id_sig + = addInlinePrags poly_id (lookupPragEnv prags name) +newSigLetBndr no_gen name (TISI { sig_inst_tau = tau }) + = newLetBndr no_gen name ManyTy tau + -- Binders with a signature are currently always of multiplicity + -- Many. Because they come either from toplevel, let, or where + -- declarations. Which are all unrestricted currently. + +------------------- +tcRhs :: TcMonoBind -> TcM (HsBind GhcTc) +tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) + loc mult matches) + = tcExtendIdBinderStackForRhs [info] $ + tcExtendTyVarEnvForRhs mb_sig $ + do { let mono_ty = idType mono_id + mono_name = idName mono_id + ; traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr mono_ty) + ; (co_fn, matches') <- tcFunBindMatches (InfSigCtxt mono_name) mono_name mult + matches [] (mkCheckExpType mono_ty) + ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id + , fun_matches = matches' + , fun_ext = (co_fn, []) + } ) } + +tcRhs (TcPatBind infos pat' mult mult_ann grhss pat_ty) + = -- When we are doing pattern bindings we *don't* bring any scoped + -- type variables into scope unlike function bindings + -- Wny not? They are not completely rigid. + -- That's why we have the special case for a single FunBind in tcMonoBinds + tcExtendIdBinderStackForRhs infos $ + do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) + ; grhss' <- addErrCtxt (PatMonoBindsCtxt pat' grhss) $ + tcGRHSsPat mult grhss (mkCheckExpType pat_ty) + + ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' + , pat_ext = (pat_ty, ([],[])) + , pat_mult = setTcMultAnn mult mult_ann } )} + + +-- | @'tcMultAnnOnPatBind' ann@ takes an optional multiplicity annotation. If +-- present the multiplicity is returned, otherwise a fresh unification variable +-- is generated so that multiplicity can be inferred. +tcMultAnnOnPatBind :: HsMultAnn GhcRn -> TcM Mult +tcMultAnnOnPatBind (HsLinearAnn _) = return oneDataConTy +tcMultAnnOnPatBind (HsExplicitMult _ p) = tcCheckLHsTypeInContext p (TheKind multiplicityTy) +tcMultAnnOnPatBind (HsUnannotated _) = newMultiplicityVar + +tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a +tcExtendTyVarEnvForRhs Nothing thing_inside + = thing_inside +tcExtendTyVarEnvForRhs (Just sig) thing_inside + = tcExtendTyVarEnvFromSig sig thing_inside + +tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a +tcExtendTyVarEnvFromSig sig_inst thing_inside + | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst + = tcExtendNameTyVarEnv wcs $ + tcExtendNameTyVarEnv (mapSnd binderVar skol_prs) $ + thing_inside + +tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a +-- See Note [Relevant bindings and the binder stack] +tcExtendIdBinderStackForRhs infos thing_inside + = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel + | MBI { mbi_mono_id = mono_id } <- infos ] + thing_inside + -- NotTopLevel: it's a monomorphic binding + +--------------------- +getMonoBindInfo :: [LocatedA TcMonoBind] -> [MonoBindInfo] +getMonoBindInfo tc_binds + = foldr (get_info . unLoc) [] tc_binds + where + get_info (TcFunBind info _ _ _) rest = info : rest + get_info (TcPatBind infos _ _ _ _ _) rest = infos ++ rest + + +{- Note [Relevant bindings and the binder stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typecking a binding we extend the TcBinderStack for the RHS of +the binding, with the /monomorphic/ Id. That way, if we have, say + f = \x -> blah +and something goes wrong in 'blah', we get a "relevant binding" +looking like f :: alpha -> beta +This applies if 'f' has a type signature too: + f :: forall a. [a] -> [a] + f x = True +We can't unify True with [a], and a relevant binding is f :: [a] -> [a] +If we had the *polymorphic* version of f in the TcBinderStack, it +would not be reported as relevant, because its type is closed. +(See TcErrors.relevantBindings.) + +Note [Typechecking pattern bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Look at: + - typecheck/should_compile/ExPat + - #12427, typecheck/should_compile/T12427{a,b} + + data T where + MkT :: Integral a => a -> Int -> T + +and suppose t :: T. Which of these pattern bindings are ok? + + E1. let { MkT p _ = t } in + + E2. let { MkT _ q = t } in + + E3. let { MkT (toInteger -> r) _ = t } in + +* (E1) is clearly wrong because the existential 'a' escapes. + What type could 'p' possibly have? + +* (E2) is fine, despite the existential pattern, because + q::Int, and nothing escapes. + +* Even (E3) is fine. The existential pattern bindings a dictionary + for (Integral a) which the view pattern can use to convert the + a-valued field to an Integer, so r :: Integer. + +An easy way to see all three is to imagine the desugaring. +For (E2) it would look like + let q = case t of MkT _ q' -> q' + in + + +We typecheck pattern bindings as follows. First tcLhs does this: + + 1. Take each type signature q :: ty, partial or complete, and + instantiate it (with tcLhsSigId) to get a MonoBindInfo. This + gives us a fresh "mono_id" qm :: instantiate(ty), where qm has + a fresh name. + + Any fresh unification variables in instantiate(ty) born here, not + deep under implications as would happen if we allocated them when + we encountered q during tcPat. + + 2. Build a little environment mapping "q" -> "qm" for those Ids + with signatures (inst_sig_fun) + + 3. Invoke tcLetPat to typecheck the pattern. + + - We pass in the current TcLevel. This is captured by + GHC.Tc.Gen.Pat.tcLetPat, and put into the pc_lvl field of PatCtxt, in + PatEnv. + + - When tcPat finds an existential constructor, it binds fresh + type variables and dictionaries as usual, increments the TcLevel, + and emits an implication constraint. + + - When we come to a binder (GHC.Tc.Gen.Pat.tcPatBndr), it looks it up + in the little environment (the pc_sig_fn field of PatCtxt). + + Success => There was a type signature, so just use it, + checking compatibility with the expected type. + + Failure => No type signature. + Infer case: (happens only outside any constructor pattern) + use a unification variable + at the outer level pc_lvl + + Check case: use promoteTcType to promote the type + to the outer level pc_lvl. This is the + place where we emit a constraint that'll blow + up if existential capture takes place + + Result: the type of the binder is always at pc_lvl. This is + crucial. + + 4. Throughout, when we are making up an Id for the pattern-bound variables + (newLetBndr), we have two cases: + + - If we are generalising (generalisation plan is InferGen or + CheckGen), then the let_bndr_spec will be LetLclBndr. In that case + we want to bind a cloned, local version of the variable, with the + type given by the pattern context, *not* by the signature (even if + there is one; see #7268). The mkExport part of the + generalisation step will do the checking and impedance matching + against the signature. + + - If for some reason we are not generalising (plan = NoGen), the + LetBndrSpec will be LetGblBndr. In that case we must bind the + global version of the Id, and do so with precisely the type given + in the signature. (Then we unify with the type from the pattern + context type.) + + +And that's it! The implication constraints check for the skolem +escape. It's quite simple and neat, and more expressive than before +e.g. GHC 8.0 rejects (E2) and (E3). + +Example for (E1), starting at level 1. We generate + p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta) +The (a~beta) can't float (because of the 'a'), nor be solved (because +beta is untouchable.) + +Example for (E2), we generate + q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta) +The beta is untouchable, but floats out of the constraint and can +be solved absolutely fine. + + +************************************************************************ +* * + Generalisation +* * +********************************************************************* -} + +data GeneralisationPlan + = NoGen -- No generalisation, no AbsBinds + + | InferGen -- Implicit generalisation; there is an AbsBinds + + | CheckGen -- One FunBind with a complete signature: + (LHsBind GhcRn) -- do explicit generalisation + TcCompleteSig + +-- A consequence of the no-AbsBinds choice (NoGen) is that there is +-- no "polymorphic Id" and "monmomorphic Id"; there is just the one + +instance Outputable GeneralisationPlan where + ppr NoGen = text "NoGen" + ppr InferGen = text "InferGen" + ppr (CheckGen _ s) = text "CheckGen" <+> ppr s + +decideGeneralisationPlan + :: DynFlags -> TopLevelFlag -> IsGroupClosed -> TcSigFun + -> [LHsBind GhcRn] -> GeneralisationPlan +decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds + | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig + | generalise_binds = InferGen + | otherwise = NoGen + where + generalise_binds + | isTopLevel top_lvl = True + -- See Note [Always generalise top-level bindings] + + | has_mult_anns_and_pats = False + -- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear] + + | IsGroupClosed _ True <- closed + , not (null binders) = True + -- The 'True' means that all of the group's + -- free vars have ClosedTypeId=True; so we can ignore + -- -XMonoLocalBinds, and generalise anyway. + -- Except if 'fv' is empty: there is no binder to generalise, so + -- generalising does nothing. And trying to generalise hurts linear + -- types (see #25428). So we don't force it. + -- See (NVP5) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind. + + | has_partial_sigs = True + -- See Note [Partial type signatures and generalisation] + + | otherwise = not (xopt LangExt.MonoLocalBinds dflags) + + -- With OutsideIn, all nested bindings are monomorphic + -- except a single function binding with a complete signature + one_funbind_with_sig + | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds + , Just (TcIdSig (TcCompleteSig sig)) <- sig_fn (unLoc v) + = Just (lbind, sig) + | otherwise + = Nothing + + binders = collectHsBindListBinders CollNoDictBinders lbinds + has_partial_sigs = any has_partial_sig binders + has_partial_sig nm = case sig_fn nm of + Just (TcIdSig (TcPartialSig {})) -> True + _ -> False + has_mult_anns_and_pats = any has_mult_ann_and_pat lbinds + has_mult_ann_and_pat (L _ (PatBind{pat_mult=HsUnannotated{}})) = False + has_mult_ann_and_pat (L _ (PatBind{pat_lhs=(L _ (VarPat{}))})) = False + has_mult_ann_and_pat (L _ (PatBind{})) = True + has_mult_ann_and_pat _ = False + +isClosedBndrGroup :: TcTypeEnv -> [(LHsBind GhcRn)] -> IsGroupClosed +isClosedBndrGroup type_env binds + = IsGroupClosed fv_env type_closed + where + type_closed = allUFM (nameSetAll is_closed_type_id) fv_env + + fv_env :: NameEnv NameSet + fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds + + bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] + bindFvs (FunBind { fun_id = L _ f + , fun_ext = fvs }) + = let open_fvs = get_open_fvs fvs + in [(f, open_fvs)] + bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) + = let open_fvs = get_open_fvs fvs + in [(b, open_fvs) | b <- collectPatBinders CollNoDictBinders pat] + bindFvs _ + = [] + + get_open_fvs fvs = filterNameSet (not . is_closed) fvs + + is_closed :: Name -> ClosedTypeId + is_closed name + | Just thing <- lookupNameEnv type_env name + = case thing of + AGlobal {} -> True + ATcId { tct_info = ClosedLet } -> True + _ -> False + + | otherwise + = True -- The free-var set for a top level binding mentions + + + is_closed_type_id :: Name -> Bool + -- We're already removed Global and ClosedLet Ids + is_closed_type_id name + | Just thing <- lookupNameEnv type_env name + = case thing of + ATcId { tct_info = NonClosedLet _ cl } -> cl + ATcId { tct_info = NotLetBound } -> False + ATyVar {} -> False + -- In-scope type variables are not closed! + _ -> pprPanic "is_closed_id" (ppr name) + + | otherwise + = True -- The free-var set for a top level binding mentions + -- imported things too, so that we can report unused imports + -- These won't be in the local type env. + -- Ditto class method etc from the current module + +{- Note [Always generalise top-level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very confusing to apply NoGen to a top level binding. Consider (#20123): + module M where + x = 5 + f y = (x, y) + +The MR means that x=5 is not generalise, so f's binding is no Closed. So we'd +be tempted to use NoGen. But that leads to f :: Any -> (Integer, Any), which +is plain stupid. + +NoGen is good when we have call sites, but not at top level, where the +function may be exported. And it's easier to grok "MonoLocalBinds" as +applying to, well, local bindings. +-} + diff --git a/GHC/Tc/Gen/Default.hs b/GHC/Tc/Gen/Default.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Default.hs @@ -0,0 +1,346 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} + +-- | Typechecking @default@ declarations +module GHC.Tc.Gen.Default ( tcDefaultDecls, extendDefaultEnvWithLocalDefaults ) where + +import GHC.Prelude +import GHC.Hs + +import GHC.Builtin.Names +import GHC.Core.Class +import GHC.Core.Predicate ( Pred (..), classifyPredType ) + +import GHC.Data.Maybe ( firstJusts, maybeToList ) + +import GHC.Tc.Errors.Types +import GHC.Tc.Gen.HsType +import GHC.Tc.Solver.Monad ( runTcS ) +import GHC.Tc.Solver.Solve ( solveWanteds ) +import GHC.Tc.Types.Constraint ( isEmptyWC, andWC, mkSimpleWC ) +import GHC.Tc.Types.Origin ( CtOrigin(DefaultOrigin) ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType ( newWanted ) +import GHC.Tc.Utils.TcType + +import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), lookupDefaultEnv, insertDefaultEnv, DefaultProvenance (..) ) +import GHC.Types.SrcLoc + +import GHC.Unit.Types (ghcInternalUnit, moduleUnit) + +import GHC.Utils.Outputable + +import qualified GHC.LanguageExtensions as LangExt + +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified Data.List.NonEmpty as NE +import Data.Traversable ( for ) + +{- Note [Named default declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With the `NamedDefaults` language extension, a `default` declaration can specify type-class +defaulting behaviour for specific classes. For example + + class C a where + ... + default C( Int, Bool ) -- The default types for class C + +The `default` declaration tells GHC to default unresolved constraints (C a) to (C Int) or +(C Bool), in that order. Of course, if you don't specify a class, thus + + default (Int, Bool) + +the default declaration behaves as before, affecting primarily the `Num` class. + +Moreover, a module export list can specify a list of classes whose defaults should be +exported. For example + + module M( C, default C ) + +would export the above `default` declaration for `C`. + +See details at +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0409-exportable-named-default.rst + +The moving parts are as follows: + +* Language.Haskell.Syntax.Decls.DefaultDecl: A `DefaultDecl` optionally carries + the specified class. + +* Parsing and renaming are entirely straightforward. + +* The typechecker maintains a `DefaultEnv` (see GHC.Types.DefaultEnv) + which maps a class to a `ClassDefaults`. The `ClassDefaults` for a class + specifies the defaults for that class, in the current module. + +* The `DefaultEnv` of all defaults in scope in a module is kept in the `tcg_default` + field of `TcGblEnv`. + +* This field is populated by `GHC.Tc.Gen.Default.tcDefaultDecls` which typechecks + any local or imported `default` declarations. + +* Only a single default declaration can be in effect in any single module for + any particular class. We issue an error if a single module contains two + default declarations for the same class, a possible warning if it imports + them. + + See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module + +* There is a _default_ `DefaultEnv` even in absence of any user-declared + `default` declarations. It is determined by the presence of the + `ExtendedDefaultRules` and `OverloadedStrings` extensions. If neither of these + extensions nor user-declared declarations are present, the `DefaultEnv` will + in effect be `default Num (Integer, Double)` as specified by Haskell Language + Report. + + See Note [Builtin class defaults] in GHC.Tc.Utils.Env + +* Beside the defaults, the `ExtendedDefaultRules` and `OverloadedStrings` + extensions also affect the traditional `default` declarations that don't name + the class. They have no effect on declarations with explicit class name. + For details of their operation see the corresponding sections of GHC User's Guide: + - https://downloads.haskell.org/ghc/latest/docs/users_guide/ghci.html#extension-ExtendedDefaultRules + - https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/overloaded_strings.html#extension-OverloadedStrings + +* The module's `tcg_default` is consulted when defaulting unsolved constraints, + in GHC.Tc.Solver.applyDefaultingRules. + See Note [How type-class constraints are defaulted] in GHC.Tc.Solver + +* Class defaults are imported automatically, like class instances. They are + tracked separately from `ImportAvails`, and returned separately from them by + `GHC.Rename.Names.rnImports`. + +* Class defaults are exported explicitly. + For example, + module M( ..., default C, ... ) + exports the defaults for class C. + + A module's exported defaults are computed by exports_from_avail, + tracked in tcg_default_exports, which are then transferred to mg_defaults, + md_defaults, and mi_defaults_. + + Only defaults explicitly exported are actually exported. + (i.e. No defaults are exported in a module header like: + module M where ...) + + See Note [Default exports] in GHC.Tc.Gen.Export + +* Since the class defaults merely help the solver infer the correct types, they + leave no trace in Haskell Core. +-} + +-- | Typecheck a collection of default declarations. These can be either: +-- +-- - Haskell 98 default declarations, of the form @default (Float, Double)@ +-- - Named default declarations, of the form @default Cls(Int, Char)@. +-- See Note [Named default declarations] +tcDefaultDecls :: [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults] +tcDefaultDecls decls = + do + tcg_env <- getGblEnv + let here = tcg_mod tcg_env + is_internal_unit = moduleUnit here == ghcInternalUnit + case (is_internal_unit, decls) of + -- No default declarations + (_, []) -> return [] + -- As per Remark [default () in ghc-internal] in Note [Builtin class defaults], + -- some modules in ghc-internal include an empty `default ()` declaration, in order + -- to disable built-in defaults. This is no longer necessary (see `GHC.Tc.Utils.Env.tcGetDefaultTys`), + -- but we must still make sure not to error if we fail to look up e.g. the 'Num' + -- typeclass when typechecking such a default declaration. To do this, we wrap + -- calls of 'tcLookupClass' in 'tryTc'. + (True, [L _ (DefaultDecl _ Nothing [])]) -> do + h2010_dflt_clss <- foldMapM (fmap maybeToList . fmap fst . tryTc . tcLookupClass) =<< getH2010DefaultNames + case NE.nonEmpty h2010_dflt_clss of + Nothing -> return [] + Just h2010_dflt_clss' -> toClassDefaults h2010_dflt_clss' decls + -- Otherwise we take apart the declaration into the class constructor and its default types. + _ -> do + h2010_dflt_clss <- getH2010DefaultClasses + toClassDefaults h2010_dflt_clss decls + where + getH2010DefaultClasses :: TcM (NonEmpty Class) + -- All the classes subject to defaulting with a Haskell 2010 default + -- declaration, of the form: + -- + -- default (Int, Bool, Float) + -- + -- Specifically: + -- No extensions: Num + -- OverloadedStrings: add IsString + -- ExtendedDefaults: add Show, Eq, Ord, Foldable, Traversable + getH2010DefaultClasses = mapM tcLookupClass =<< getH2010DefaultNames + getH2010DefaultNames + = do { ovl_str <- xoptM LangExt.OverloadedStrings + ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules + ; let deflt_str = if ovl_str + then [isStringClassName] + else [] + ; let deflt_interactive = if ext_deflt + then interactiveClassNames + else [] + ; let extra_clss_names = deflt_str ++ deflt_interactive + ; return $ numClassName :| extra_clss_names + } + declarationParts :: NonEmpty Class -> LDefaultDecl GhcRn -> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [Type])) + declarationParts h2010_dflt_clss decl@(L locn (DefaultDecl _ mb_cls_name dflt_hs_tys)) + = setSrcSpan (locA locn) $ + case mb_cls_name of + -- Haskell 98 default declaration + Nothing -> + do { tau_tys <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = True }) + $ mapMaybeM (check_instance_any h2010_dflt_clss) dflt_hs_tys + ; return $ Just (Nothing, decl, tau_tys) } + -- Named default declaration + Just cls_name -> + do { named_deflt <- xoptM LangExt.NamedDefaults + ; checkErr named_deflt (TcRnIllegalNamedDefault decl) + ; mb_cls <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = False }) + $ tcDefaultDeclClass cls_name + ; for mb_cls $ \ cls -> + do { tau_tys <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = True }) + $ mapMaybeM (check_instance_any (NE.singleton cls)) dflt_hs_tys + ; return (Just cls, decl, tau_tys) + } } + + toClassDefaults :: NonEmpty Class -> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults] + toClassDefaults h2010_dflt_clss dfs = do + dfs <- mapMaybeM (declarationParts h2010_dflt_clss) dfs + return $ concatMap (go False) dfs + where + go h98 = \case + (Nothing, rn_decl, tys) -> concatMap (go True) [(Just cls, rn_decl, tys) | cls <- NE.toList h2010_dflt_clss] + (Just cls, (L locn _), tys) -> [(L locn $ ClassDefaults cls tys (DP_Local (locA locn) h98) Nothing)] + +-- | Extend the default environment with the local default declarations +-- and do the action in the extended environment. +extendDefaultEnvWithLocalDefaults :: [LocatedA ClassDefaults] -> TcM a -> TcM a +extendDefaultEnvWithLocalDefaults decls action = do + tcg_env <- getGblEnv + let default_env = tcg_default tcg_env + new_default_env <- insertDefaultDecls default_env decls + updGblEnv (\gbl -> gbl { tcg_default = new_default_env } ) $ action + +-- | Insert local default declarations into the default environment. +-- +-- See 'insertDefaultDecl'. +insertDefaultDecls :: DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv +insertDefaultDecls = foldrM insertDefaultDecl +-- | Insert a local default declaration into the default environment. +-- +-- If the class already has a local default declaration in the DefaultEnv, +-- report an error and return the original DefaultEnv. Otherwise, override +-- any existing default declarations (e.g. imported default declarations). +-- +-- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module +insertDefaultDecl :: LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv +insertDefaultDecl (L decl_loc new_cls_defaults ) default_env = + case lookupDefaultEnv default_env (className cls) of + Just cls_defaults + | DP_Local {} <- cd_provenance cls_defaults + -> do { setSrcSpan (locA decl_loc) (addErrTc $ TcRnMultipleDefaultDeclarations cls cls_defaults) + ; return default_env } + _ -> return $ insertDefaultEnv new_cls_defaults default_env + -- NB: this overrides imported and built-in default declarations + -- for this class, if there were any. + where + cls = cd_class new_cls_defaults + + +-- | Check that the type is an instance of at least one of the default classes. +-- +-- See Note [Instance check for default declarations] +check_instance_any :: NonEmpty Class + -- ^ classes, all assumed to be unary + -> LHsType GhcRn + -- ^ default type + -> TcM (Maybe Type) +check_instance_any deflt_clss ty + = do { oks <- mapM (\ cls -> simplifyDefault cls ty) deflt_clss + ; case firstJusts oks of + Nothing -> + do { addErrTc $ TcRnBadDefaultType ty deflt_clss + ; return Nothing } + Just ty -> + return $ Just ty + } + +-- | Given a class @C@ and a type @ty@, is @C ty@ soluble? +-- +-- Used to check that a type is an instance of a class in a default +-- declaration. +-- +-- See Note [Instance check for default declarations] in GHC.Tc.Solver.Default. +simplifyDefault + :: Class -- ^ class, assumed to be unary,i.e. it takes some invisible arguments + -- and then a single (final) visible argument + -> LHsType GhcRn -- ^ default type + -> TcM (Maybe Type) +simplifyDefault cls dflt_ty@(L l _) + = do { let app_ty :: LHsType GhcRn + app_ty = L l $ HsAppTy noExtField (nlHsTyVar NotPromoted (className cls)) dflt_ty + ; (inst_pred, wtds) <- captureConstraints $ tcCheckLHsType app_ty constraintKind + ; wtd_inst <- newWanted DefaultOrigin (Just TypeLevel) inst_pred + ; let all_wanteds = wtds `andWC` mkSimpleWC [wtd_inst] + ; (unsolved, _) <- runTcS $ solveWanteds all_wanteds + ; traceTc "simplifyDefault" $ + vcat [ text "cls:" <+> ppr cls + , text "dflt_ty:" <+> ppr dflt_ty + , text "inst_pred:" <+> ppr inst_pred + , text "all_wanteds " <+> ppr all_wanteds + , text "unsolved:" <+> ppr unsolved ] + ; let is_instance = isEmptyWC unsolved + ; return $ + if | is_instance + , ClassPred _ tys <- classifyPredType inst_pred + -- inst_pred looks like (C @k1 .. @kn t); + -- we want the final (visible) argument `t` + , Just tys_ne <- NE.nonEmpty tys + -> Just $ NE.last tys_ne + | otherwise + -> Nothing + } + +{- Note [Instance check for default declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see a named default declaration, such as: + + default C(ty_1, ..., ty_n) + +we must check that each of the types 'ty1', ..., 'ty_n' is an instance of +the class 'C'. For each individual type 'ty', the strategy is thus: + + - Create a new Wanted constraint 'C ty', and run the solver on it. + The default declaration 'default C(ty)' is valid iff the solver succeeds + in solving this constraint (with no residual unsolved Wanteds). + +This is implemented in GHC.Tc.Gen.Default.check_instance, and tested in T25882. + +The only slightly subtle point is that we want to allow classes such as + + Typeable :: forall k. k -> Constraint + +which take invisible arguments and a (single) visible argument. The function +GHC.Tc.Gen.HsType.tcDefaultDeclClass checks that the class 'C' takes a single +visible parameter. + +Note that Haskell98 default declarations, of the form + + default (ty_1, ..., ty_n) + +work similarly, except that instead of checking for a single class, we check +whether each type is an instance of: + + - only the Num class, by default + - ... or the IsString class, with -XOverloadedStrings + - ... or any of the Show, Eq, Ord, Foldable, and Traversable classes, + with -XExtendedDefaultRules +-} diff --git a/GHC/Tc/Gen/Do.hs b/GHC/Tc/Gen/Do.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Do.hs @@ -0,0 +1,494 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +(c) The University of Iowa 2023 + +-} + +-- | Expand @Do@ block statements into @(>>=)@, @(>>)@ and @let@s +-- After renaming but right ebefore type checking +module GHC.Tc.Gen.Do (expandDoStmts) where + +import GHC.Prelude + +import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet, + genHsLamDoExp, genHsCaseAltDoExp, genWildPat ) +import GHC.Rename.Env ( irrefutableConLikeRn ) + +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType + +import GHC.Hs + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Driver.DynFlags ( DynFlags, getDynFlags ) +import GHC.Driver.Ppr (showPpr) + +import GHC.Types.SrcLoc +import GHC.Types.Basic +import qualified GHC.LanguageExtensions as LangExt + +import Data.List ((\\)) + + +{- +************************************************************************ +* * +\subsection{XXExprGhcRn for Do Statements} +* * +************************************************************************ +-} + +-- | Expand the `do`-statments into expressions right after renaming +-- so that they can be typechecked. +-- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary +-- and Note [Handling overloaded and rebindable constructs] for high level commentary +expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn) +expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts + case expanded_expr of + L _ (XExpr (PopErrCtxt e)) -> return e + -- The first expanded stmt doesn't need a pop as + -- it would otherwise pop the "In the expression do ... " from + -- the error context + _ -> return expanded_expr + +-- | The main work horse for expanding do block statements into applications of binds and thens +-- See Note [Expanding HsDo with XXExprGhcRn] +expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn) + +expand_do_stmts ListComp _ = + pprPanic "expand_do_stmts: impossible happened. ListComp" empty + -- handeled by `GHC.Tc.Gen.Match.tcLcStmt` + +expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty + +expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) = + pprPanic "expand_do_stmts: TransStmt" $ ppr stmt + -- handeled by `GHC.Tc.Gen.Match.tcLcStmt` + +expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) = + pprPanic "expand_do_stmts: ParStmt" $ ppr stmt + -- handeled by `GHC.Tc.Gen.Match.tcLcStmt` + +expand_do_stmts _ (stmt@(L _ (XStmtLR ApplicativeStmt{})): _) = + pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt + -- Handeled by tcSyntaxOp see `GHC.Tc.Gen.Match.tcStmtsAndThen` + + +expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))] +-- See Note [Expanding HsDo with XXExprGhcRn] Equation (5) below +-- last statement of a list comprehension, needs to explicitly return it +-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt` + | NoSyntaxExprRn <- ret_expr + -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt + = do traceTc "expand_do_stmts last" (ppr ret_expr) + return $ mkExpandedStmtPopAt loc stmt body + + | SyntaxExprRn ret <- ret_expr + -- + -- ------------------------------------------------ + -- return e ~~> return e + -- to make T18324 work + = do traceTc "expand_do_stmts last" (ppr ret_expr) + let expansion = genHsApp ret (L body_loc body) + return $ mkExpandedStmtPopAt loc stmt expansion + +expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bs)) : lstmts) = +-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below +-- stmts ~~> stmts' +-- ------------------------------------------------ +-- let x = e ; stmts ~~> let x = e in stmts' + do expand_stmts <- expand_do_stmts do_or_lc lstmts + let expansion = genHsLet bs expand_stmts + return $ mkExpandedStmtPopAt loc stmt expansion + +expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) + | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn + , fail_op <- xbsrn_failOp xbsrn +-- See Note [Expanding HsDo with XXExprGhcRn] Equation (2) below +-- the pattern binding pat can fail +-- stmts ~~> stmt' f = \case pat -> stmts'; +-- _ -> fail "Pattern match failure .." +-- ------------------------------------------------------- +-- pat <- e ; stmts ~~> (>>=) e f + = do expand_stmts <- expand_do_stmts do_or_lc lstmts + failable_expr <- mk_failable_expr do_or_lc pat expand_stmts fail_op + let expansion = genHsExpApps bind_op -- (>>=) + [ e + , failable_expr ] + return $ mkExpandedStmtPopAt loc stmt expansion + + | otherwise + = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt) + +expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) = +-- See Note [BodyStmt] in Language.Haskell.Syntax.Expr +-- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below +-- stmts ~~> stmts' +-- ---------------------------------------------- +-- e ; stmts ~~> (>>) e stmts' + do expand_stmts_expr <- expand_do_stmts do_or_lc lstmts + let expansion = genHsExpApps then_op -- (>>) + [ e + , expand_stmts_expr ] + return $ mkExpandedStmtPopAt loc stmt expansion + +expand_do_stmts do_or_lc + ((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts + , recS_later_ids = later_ids -- forward referenced local ids + , recS_rec_ids = local_ids -- ids referenced outside of the rec block + , recS_bind_fn = SyntaxExprRn bind_fun -- the (>>=) expr + , recS_mfix_fn = SyntaxExprRn mfix_fun -- the `mfix` expr + , recS_ret_fn = SyntaxExprRn return_fun -- the `return` expr + -- use it explicitly + -- at the end of expanded rec block + })) + : lstmts) = +-- See Note [Typing a RecStmt] in Language.Haskell.Syntax.Expr +-- See Note [Expanding HsDo with XXExprGhcRn] Equation (4) and (6) below +-- stmts ~~> stmts' +-- ------------------------------------------------------------------------------------------- +-- rec { later_ids, local_ids, rec_block } ; stmts +-- ~~> (>>=) (mfix (\[ local_only_ids ++ later_ids ] +-- -> do { rec_stmts +-- ; return (local_only_ids ++ later_ids) } )) +-- (\ [ local_only_ids ++ later_ids ] -> stmts') + do expand_stmts <- expand_do_stmts do_or_lc lstmts + -- NB: No need to wrap the expansion with an ExpandedStmt + -- as we want to flatten the rec block statements into its parent do block anyway + return $ mkHsApps (wrapGenSpan bind_fun) -- (>>=) + [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block)) + , genHsLamDoExp do_or_lc [ mkBigLHsVarPatTup all_ids ] -- (\ x -> + expand_stmts -- stmts') + ] + where + local_only_ids = local_ids \\ later_ids -- get unique local rec ids; + -- local rec ids and later ids can overlap + all_ids = local_only_ids ++ later_ids -- put local ids before return ids + + return_stmt :: ExprLStmt GhcRn + return_stmt = wrapGenSpan $ LastStmt noExtField + (mkBigLHsTup (map nlHsVar all_ids) noExtField) + Nothing + (SyntaxExprRn return_fun) + do_stmts :: XRec GhcRn [ExprLStmt GhcRn] + do_stmts = L stmts_loc $ rec_stmts ++ [return_stmt] + do_block :: LHsExpr GhcRn + do_block = L loc $ HsDo noExtField do_or_lc do_stmts + mfix_expr :: LHsExpr GhcRn + mfix_expr = genHsLamDoExp do_or_lc [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] + $ do_block + -- NB: LazyPat because we do not want to eagerly evaluate the pattern + -- and potentially loop forever + +expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts) + +-- checks the pattern `pat` for irrefutability which decides if we need to wrap it with a fail block +mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn) +mk_failable_expr doFlav pat@(L loc _) expr fail_op = + do { is_strict <- xoptM LangExt.Strict + ; hscEnv <- getTopEnv + ; rdrEnv <- getGlobalRdrEnv + ; comps <- getCompleteMatchesTcM + ; let irrf_pat = isIrrefutableHsPat is_strict (irrefutableConLikeRn hscEnv rdrEnv comps) pat + ; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat + , text "isIrrefutable:" <+> ppr irrf_pat + ]) + + ; if irrf_pat -- don't wrap with fail block if + -- the pattern is irrefutable + then return $ genHsLamDoExp doFlav [pat] expr + else L loc <$> mk_fail_block doFlav pat expr fail_op + } + +-- makes the fail block with a given fail_op +mk_fail_block :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn) +mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) = + do dflags <- getDynFlags + return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \ + (wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr + , fail_alt_case dflags pat fail_op -- _ -> fail "fail pattern" + ]) + where + fail_alt_case :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn) + fail_alt_case dflags pat fail_op = genHsCaseAltDoExp doFlav genWildPat $ + L ploc (fail_op_expr dflags pat fail_op) + + fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn + fail_op_expr dflags pat fail_op + = mkExpandedPatRn pat $ + genHsApp fail_op (mk_fail_msg_expr dflags pat) + + mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn + mk_fail_msg_expr dflags pat + = nlHsLit $ mkHsString $ showPpr dflags $ + text "Pattern match failure in" <+> pprHsDoFlavour (DoExpr Nothing) + <+> text "at" <+> ppr (getLocA pat) + + +mk_fail_block _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty + + +{- Note [Expanding HsDo with XXExprGhcRn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand `do`-blocks before typechecking it, by re-using the existing `XXExprGhcRns` and `RebindableSyntax` machinery. +This is very similar to: + 1. Expansions done in `GHC.Rename.Expr.rnHsIf` for expanding `HsIf`; and + 2. `desugarRecordUpd` in `GHC.Tc.Gen.Expr.tcExpr` for expanding `RecordUpd` +See Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr + +To disabmiguate desugaring (`HsExpr GhcTc -> Core.Expr`) we use the phrase expansion +(`HsExpr GhcRn -> HsExpr GhcRn`) + +This expansion is done right before typechecking and after renaming +See Part 2. of Note [Doing XXExprGhcRn in the Renamer vs Typechecker] in `GHC.Rename.Expr` + +Historical note START +--------------------- +In previous versions of GHC, the `do`-notation wasn't expanded before typechecking, +instead the typechecker would operate directly on the original. +Why? because it ensured that type error messages were explained in terms of +what the programmer has written. In practice, however, this didn't work very well: + +* Attempts to typecheck the original source code turned out to be buggy, and virtually impossible + to fix (#14963, #15598, #21206 and others) + +* The typechecker expected the `>>=` operator to have a type that matches + `m _ -> (_ -> m _) -> m _` for some `m`. With `RebindableSyntax` or + `QualifiedDo` the `>>=` operator might not have the + standard type. It might have a type like + + (>>=) :: Wombat m => m a1 a2 b -> (b -> m a2 a3 c) -> m a1 a3 c + + Typechecking the term `(>>=) e1 (\x -> e2)` deals with all of this automatically. + +* With `ImpredicativeTypes` the programmer will expect Quick Look to instantiate + the quantifiers impredicatively (#18324). Again, that happens automatically if + you typecheck the expanded expression. + +Historical note END +------------------- + +Do Expansions Equationally +-------------------------- +We have the following schema for expanding `do`-statements. +They capture the essence of statement expansions as implemented in `expand_do_stmts` + + DO【 _ 】 maps a sequence of do statements and recursively converts them into expressions + + (1) DO【 s; ss 】 = ‹ExpansionStmt s›((>>) s (‹PopErrCtxt›DO【 ss 】)) + + (2) DO【 p <- e; ss 】 = if p is irrefutable + then ‹ExpansionStmt (p <- e)› + (>>=) s (‹PopExprCtxt›(\ p -> DO【 ss 】)) + else ‹ExpansionStmt (p <- e)› + (>>=) s (‹PopExprCtxt›(\case p -> DO【 ss 】 + _ -> fail "pattern p failure")) + + (3) DO【 let x = e; ss 】 + = ‹ExpansionStmt (let x = e)› (let x = e in (‹PopErrCtxt›DO【 ss 】)) + + + (4) DO【 rec ss; sss 】 + = (>>=) e (\vars -> ‹PopErrCtxt›DO【 sss 】)) + where (vars, e) = RECDO【 ss 】 + + (5) DO【 s 】 = s + + RECDO【 _ 】 maps a sequence of recursively dependent monadic statements and converts it into an expression paired + with the variables that the rec finds a fix point of. + + (6) RECDO【 ss 】 = (vars, mfix (\~vars -> (>>=) (DO【 ss 】) (return vars))) + where vars are all the variables free in ss + + +For a concrete example, consider a `do`-block written by the user + + f = {l0} do {l1} {pl}p <- {l1'} e1 + {l2} g p + {l3} return {l3'} p + +The expanded version (performed by `expand_do_stmts`) looks like: + + f = {g1} (>>=) ({l1'} e1) (\ {pl}p -> + {g2} (>>) ({l2} g p) + ({l3} return p)) + +The {l1} etc are location/source span information stored in the AST by the parser, +{g1} are compiler generated source spans. + + +The 3 non-obvious points to consider are: + 1. Wrap the expression with a `fail` block if the pattern match is not irrefutable. + See Part 1. below + 2. Generate appropriate warnings for discarded results in a body statement + eg. say `do { .. ; (g p :: m Int) ; ... }` + See Part 2. below + 3. Generating appropriate type error messages which blame the correct source spans + See Part 3. below + +Part 1. Expanding Patterns Bindings +----------------------------------- +If `p` is a failable pattern---checked by `GHC.Tc.Gen.Pat.isIrrefutableHsPatRnTcM`--- +we need to wrap it with a `fail`-block. See Equation (2) above. + +The expansion of the `do`-block + + do { Just p <- e1; e2 } + +(ignoring the location information) will be + + (>>=) (e1) + (\case -- anonymous continuation lambda + Just p -> e2 + _ -> fail "failable pattern p at location") + +The `fail`-block wrapping is done by `GHC.Tc.Gen.Do.mk_failable_expr`. + +* Note the explicit call to `fail`, in the monad of the `do`-block. Part of the specification + of do-notation is that if the pattern match fails, we fail in the monad, *not* just crash + at runtime. + +* According to the language specification, when the pattern is irrefutable, + we should not add the `fail` alternative. This is important because + the occurrence of `fail` means that the typechecker will generate a `MonadFail` constraint, + and irrefutable patterns shouldn't need a fail alternative. + +* _Wrinkel 1_: Note that pattern synonyms count as refutable during type checking, + (see `isIrrefutableHsPat`). They will hence generate a + `MonadFail` constraint and they will always be wrapped in a `fail`able-block. + + Consider a patten synonym declaration (testcase T24552): + + pattern MyJust :: a -> Maybe a + pattern MyJust x <- Just x where MyJust = Just + + and a `do`-block with the following bind and return statement + + do { MyJust x <- [MyNothing, MyJust ()] + ; return x } + + The `do`-expansion will generate the expansion + + (>>=) ([MyNothing, MyJust ()]) + (\case MyJust x -> return x -- (1) + _ -> fail "failable pattern .. " -- (2) + ) + + This code (specifically the `match` spanning lines (1) and (2)) is a compiler generated code; + the associated `Origin` in tagged `Generated` + The alternative statements will thus be ignored by the pattern match check (c.f. `isMatchContextPmChecked`). + This ensures we do not generate spurious redundant-pattern-match warnings due to the line (2) above. + See Note [Generated code and pattern-match checking] + See Note [Long-distance information in matchWrapper] + +* _Wrinkle 2_: The call to `fail` will give rise to a `MonadFail` constraint. What `CtOrigin` do we + attach to that constraint? When the `MonadFail` constraint can't be solved, it'll show up in error + messages and it needs to be a good location. Ideally, it should identify the + pattern `p`. Hence, we wrap the `fail` alternative expression with a `ExpandedPat` + that tags the fail expression with the failable pattern. (See testcase MonadFailErrors.hs) + +Part 2. Generate warnings for discarded body statement results +-------------------------------------------------------------- +If the `do`-blocks' body statement is an expression that returns a +value that is not of type `()`, we need to warn the user about discarded +the value when `-Wunused-binds` flag is turned on. (See testcase T3263-2.hs) + +For example the `do`-block + + do { e1; e2 } -- where, e1 :: m Int + +expands to + + (>>) e1 e2 + +* If `e1` returns a non-() value we want to emit a warning, telling the user that they + are discarding the value returned by e1. This is done by `HsToCore.dsExpr` in the `HsApp` + with a call to `HsToCore.warnUnusedBindValue`. + +* The decision to trigger the warning is: if the function is a compiler generated `(>>)`, + and its first argument `e1` has a non-() type + +Part 3. Blaming Offending Source Code and Generating Appropriate Error Messages +------------------------------------------------------------------------------- +To ensure we correctly track source of the offending user written source code, +in this case the `do`-statement, we need to keep track of +which source statement's expansion the typechecker is currently typechecking. +For this purpose we use the `XXExprGhcRn.ExpansionRn`. +It stores the original statement (with location) and the expanded expression + + A. Expanding Body Statements + ----------------------------- + For example, the `do`-block + + do { e1; e2; e3 } + + expands (ignoring the location info) to + + ‹ExpandedThingRn do { e1; e2; e3 }› -- Original Do Expression + -- Expanded Do Expression + (‹ExpandedThingRn e1› -- Original Statement + ({(>>) e1} -- Expanded Expression + ‹PopErrCtxt› (‹ExpandedThingRn e2› + ({(>>) e2} + ‹PopErrCtxt› (‹ExpandedThingRn e3› {e3}))))) + + * Whenever the typechecker steps through an `ExpandedThingRn`, + we push the original statement in the error context, set the error location to the + location of the statement, and then typecheck the expanded expression. + This is similar to vanilla `XXExprGhcRn` and rebindable syntax + See Note [Rebindable syntax and XXExprGhcRn] in `GHC.Hs.Expr`. + + * Recall, that when a source function argument fails to typecheck, + we print an error message like "In the second argument of the function f..". + However, `(>>)` is generated thus, we don't want to display that to the user; it would be confusing. + But also, we do not want to completely ignore it as we do want to keep the error blame carets + as precise as possible, and not just blame the complete `do`-block. + Thus, when we typecheck the application `(>>) e1`, we push the "In the stmt of do block e1" with + the source location of `e1` in the error context stack as we walk inside an `ExpandedThingRn`. + See also Note [splitHsApps]. + + * After the expanded expression of a `do`-statement is typechecked + and before moving to the next statement of the `do`-block, we need to first pop the top + of the error context stack which contains the error message for + the previous statement: eg. "In the stmt of a do block: e1". + This is explicitly encoded in the expansion expression using + the `XXExprGhcRn.PopErrCtxt`. Whenever `GHC.Tc.Gen.Expr.tcExpr` (via `GHC.Tc.Gen.tcXExpr`) + sees a `PopErrCtxt` it calls `GHC.Tc.Utils.Monad.popErrCtxt` to pop of the top of error context stack. + See ‹PopErrCtxt› in the example above. + Without this popping business for error context stack, + if there is a type error in `e2`, we would get a spurious and confusing error message + which mentions "In the stmt of a do block e1" along with the message + "In the stmt of a do block e2". + + B. Expanding Bind Statements + ----------------------------- + A `do`-block with a bind statement: + + do { p <- e1; e2 } + + expands (ignoring the location information) to + + ‹ExpandedThingRn do{ p <- e1; e2 }› -- Original Do Expression + -- + (‹ExpandedThingRn (p <- e1)› -- Original Statement + (((>>=) e1) -- Expanded Expression + ‹PopErrCtxt› ((\ p -> ‹ExpandedThingRn (e2)› e2))) + ) + + + However, the expansion lambda `(\p -> e2)` is special as it is generated from a `do`-stmt expansion + and if a type checker error occurs in the pattern `p` (which is source generated), we need to say + "in a pattern binding in a do block" and not "in the pattern of a lambda" (cf. Typeable1.hs). + We hence use a tag `GenReason` in `Ghc.Tc.Origin`. When typechecking a `HsLam` in `Tc.Gen.Expr.tcExpr` + the `match_ctxt` is set to a `StmtCtxt` if `GenOrigin` is a `DoExpansionOrigin`. +-} diff --git a/GHC/Tc/Gen/Export.hs b/GHC/Tc/Gen/Export.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Export.hs @@ -0,0 +1,1153 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} + +module GHC.Tc.Gen.Export (rnExports, exports_from_avail, classifyGREs) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Builtin.Names +import GHC.Core.Class +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env + ( TyThing(AConLike, AnId), tcLookupGlobal, tcLookupTyCon ) +import GHC.Tc.Utils.TcType +import GHC.Rename.Doc +import GHC.Rename.Module +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Unbound ( reportUnboundName ) +import GHC.Rename.Splice +import GHC.Unit.Module +import GHC.Unit.Module.Imported +import GHC.Unit.Module.Warnings +import GHC.Core.TyCon +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Core.ConLike +import GHC.Core.PatSyn +import GHC.Data.Maybe +import GHC.Data.FastString (fsLit) +import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Types.Unique.Map +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.DefaultEnv +import GHC.Types.Avail +import GHC.Types.SourceFile +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name.Reader + +import Control.Arrow ( first ) +import Control.Monad ( when ) +import qualified Data.List.NonEmpty as NE +import Data.Traversable ( for ) +import Data.List ( sortBy ) +import qualified Data.Map as Map +import GHC.Types.Unique.FM + +{- +************************************************************************ +* * +\subsection{Export list processing} +* * +************************************************************************ + +Processing the export list. + +You might think that we should record things that appear in the export +list as ``occurrences'' (using @addOccurrenceName@), but you'd be +wrong. We do check (here) that they are in scope, but there is no +need to slurp in their actual declaration (which is what +@addOccurrenceName@ forces). + +Indeed, doing so would big trouble when compiling @PrelBase@, because +it re-exports @GHC@, which includes @takeMVar#@, whose type includes +@ConcBase.StateAndSynchVar#@, and so on... + +Note [Exports of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose you see (#5306) + module M where + import X( F ) + data instance F Int = FInt +What does M export? AvailTC F [FInt] + or AvailTC F [F,FInt]? +The former is strictly right because F isn't defined in this module. +But then you can never do an explicit import of M, thus + import M( F( FInt ) ) +because F isn't exported by M. Nor can you import FInt alone from here + import M( FInt ) +because we don't have syntax to support that. (It looks like an import of +the type FInt.) + +At one point I implemented a compromise: + * When constructing exports with no export list, or with module M( + module M ), we add the parent to the exports as well. + * But not when you see module M( f ), even if f is a + class method with a parent. + * Nor when you see module M( module N ), with N /= M. + +But the compromise seemed too much of a hack, so we backed it out. +You just have to use an explicit export list: + module M( F(..) ) where ... + +Note [Avails of associated data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose you have (#16077) + + {-# LANGUAGE TypeFamilies #-} + module A (module A) where + + class C a where { data T a } + instance C () where { data T () = D } + +Because @A@ is exported explicitly, GHC tries to produce an export list +from the @GlobalRdrEnv@. In this case, it pulls out the following: + + [ C defined at A.hs:4:1 + , T parent:C defined at A.hs:4:23 + , D parent:T defined at A.hs:5:35 ] + +If map these directly into avails, (via 'availFromGRE'), we get +@[C{C;}, C{T;}, T{D;}]@, which eventually gets merged into @[C{C, T;}, T{D;}]@. +That's not right, because @T{D;}@ violates the AvailTC invariant: @T@ is +exported, but it isn't the first entry in the avail! + +We work around this issue by expanding GREs where the parent and child +are both type constructors into two GRES. + + T parent:C defined at A.hs:4:23 + + => + + [ T parent:C defined at A.hs:4:23 + , T defined at A.hs:4:23 ] + +Then, we get @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged +into @[C{C, T;}, T{T, D;}]@ (which satisfies the AvailTC invariant). +-} + +data ExportAccum -- The type of the accumulating parameter of + -- the main worker function in rnExports + = ExportAccum { + expacc_exp_occs :: ExportOccMap, + -- ^ Tracks exported occurrence names + expacc_exp_dflts :: NameEnv (ClassDefaults, IE GhcPs), + -- ^ Tracks exported named default declarations + expacc_mods :: UniqMap ModuleName [Name], + -- ^ Tracks (re-)exported module names + -- and the names they re-export + expacc_warn_spans :: ExportWarnSpanNames, + -- ^ Information about warnings for names + expacc_dont_warn :: DontWarnExportNames + -- ^ What names not to export warnings for + -- (because they are exported without a warning) + } + + +emptyExportAccum :: ExportAccum +emptyExportAccum = ExportAccum emptyOccEnv emptyNameEnv emptyUniqMap [] emptyNameEnv + +accumExports :: (ExportAccum -> x -> TcRn (ExportAccum, Maybe y)) + -> [x] + -> TcRn ([y], DefaultEnv, ExportWarnSpanNames, DontWarnExportNames) +accumExports f xs = do + (ExportAccum _ dflts _ export_warn_spans dont_warn_export, ys) + <- mapAccumLM f' emptyExportAccum xs + return ( catMaybes ys + , fmap fst dflts + , export_warn_spans + , dont_warn_export ) + where f' acc x + = fromMaybe (acc, Nothing) <$> attemptM (f acc x) + +type ExportOccMap = OccEnv (Name, IE GhcPs) + -- Tracks what a particular exported OccName + -- in an export list refers to, and which item + -- it came from. It's illegal to export two distinct things + -- that have the same occurrence name + +rnExports :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (LocatedLI [LIE GhcPs]) -- Nothing => no explicit export list + -> RnM TcGblEnv + + -- Complains if two distinct exports have same OccName + -- Warns about identical exports. + -- Complains about exports items not in scope + +rnExports explicit_mod exports + = checkNoErrs $ -- Fail if anything in rnExports finds + -- an error fails, to avoid error cascade + do { hsc_env <- getTopEnv + ; tcg_env <- getGblEnv + ; let dflags = hsc_dflags hsc_env + TcGblEnv { tcg_mod = this_mod + , tcg_rdr_env = rdr_env + , tcg_imports = imports + , tcg_warns = warns + , tcg_src = hsc_src } = tcg_env + default_main | mainModIs (hsc_HUE hsc_env) == this_mod + , Just main_fun <- mainFunIs dflags + = mkUnqual varName (fsLit main_fun) + | otherwise + = main_RDR_Unqual + ; has_main <- (not . null) <$> lookupInfoOccRn default_main -- #17832 + + -- If a module has no explicit header, and it has one or more main + -- functions in scope, then add a header like + -- "module Main(main) where ..." #13839 + -- See Note [Modules without a module header] + ; let real_exports + | explicit_mod = exports + | has_main + = Just (noLocA [noLocA (IEVar Nothing + (noLocA (IEName noExtField $ noLocA default_main)) Nothing)]) + -- ToDo: the 'noLoc' here is unhelpful if 'main' + -- turns out to be out of scope + | otherwise = Nothing + + -- Rename the export list + ; let do_it = exports_from_avail real_exports rdr_env imports this_mod + ; (rn_exports, default_env, final_avails, new_export_warns) + <- if hsc_src == HsigFile + then do (mb_r, msgs) <- tryTc do_it + case mb_r of + Just r -> return r + Nothing -> addMessages msgs >> failM + else checkNoErrs do_it + + -- Final processing + ; let final_ns = availsToNameSet final_avails + + ; traceRn "rnExports: Exports:" (ppr final_avails) + + ; return (tcg_env { tcg_exports = final_avails + , tcg_rn_exports = case tcg_rn_exports tcg_env of + Nothing -> Nothing + Just _ -> rn_exports + , tcg_default_exports = case exports of + Nothing -> emptyDefaultEnv + _ -> default_env + , tcg_dus = tcg_dus tcg_env `plusDU` + usesOnly final_ns + , tcg_warns = insertWarnExports + warns new_export_warns}) } + +-- | List of names and the information about their warnings +-- (warning, export list item span) +type ExportWarnSpanNames = [(Name, WarningTxt GhcRn, SrcSpan)] + +-- | Map from names that should not have export warnings to +-- the spans of export list items that are missing those warnings +type DontWarnExportNames = NameEnv (NE.NonEmpty SrcSpan) + + +{- Note [Default exports] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Named default declarations (see Note [Named default declarations] in +GHC.Tc.Gen.Default) can be exported. A named default declaration is +exported only when it's specified in the export list, using the `default` +keyword and the class name. For example: + + module TextWrap (Text, default IsString) where + import Data.String (IsString) + import Data.Text (Text) + default IsString (Text, String) + +A module with no explicit export list does not export any default +declarations, and neither does the re-export of a whole imported module. + +The export item `default IsString` is parsed into the `IE` item + + IEThingAbs ext (L loc (IEDefault ext "IsString")) doc + +If exported, a default is imported automatically much like a class instance. For +example, + + import TextWrap () + +would import the above `default IsString (Text, String)` declaration into the +importing module. + +The `cd_provenance` field of `ClassDefaults` tracks the module whence the default was +imported from, for the purpose of warning reports. The said warning report may be +triggered by `-Wtype-defaults` or by a user-defined `WARNING` pragma attached to +the default export. In the latter case the warning text is stored in the +`cd_warn` field. See test `testsuite/tests/default/ExportWarn.hs` for an example +of a user-defined warning on default. +-} + +exports_from_avail :: Maybe (LocatedLI [LIE GhcPs]) + -- ^ 'Nothing' means no explicit export list + -> GlobalRdrEnv + -> ImportAvails + -- ^ Imported modules; this is used to test if a + -- @module Foo@ export is valid (it's not valid + -- if we didn't import @Foo@!) + -> Module + -> RnM (Maybe [(LIE GhcRn, Avails)], DefaultEnv, Avails, ExportWarnNames GhcRn) + -- (Nothing, _, _) <=> no explicit export list + -- if explicit export list is present it contains + -- each renamed export item together with its exported + -- names. + +exports_from_avail Nothing rdr_env _imports _this_mod + -- The same as (module M) where M is the current module name, + -- so that's how we handle it, except we also export the data family + -- when a data instance is exported. + = do { + ; addDiagnostic + (TcRnMissingExportList $ moduleName _this_mod) + ; let avails = + map fix_faminst . gresToAvailInfo . mapMaybe pickLevelZeroGRE + . filter isLocalGRE . globalRdrEnvElts $ rdr_env + ; return (Nothing, emptyDefaultEnv, avails, []) } + where + -- #11164: when we define a data instance + -- but not data family, re-export the family + -- Even though we don't check whether this is actually a data family + -- only data families can locally define subordinate things (`ns` here) + -- without locally defining (and instead importing) the parent (`n`) + fix_faminst avail@(AvailTC n ns) + | availExportsDecl avail + = avail + | otherwise + = AvailTC n (n:ns) + fix_faminst avail = avail + + +exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod + = do (ie_avails, ie_dflts, export_warn_spans, dont_warn_export) + <- accumExports do_litem rdr_items + let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families + export_warn_names <- aggregate_warnings export_warn_spans dont_warn_export + return (Just ie_avails, ie_dflts, final_exports, export_warn_names) + where + do_litem :: ExportAccum -> LIE GhcPs + -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails)) + do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie) + + -- Maps a parent to its in-scope children + kids_env :: NameEnv [GlobalRdrElt] + kids_env = mkChildEnv (globalRdrEnvElts rdr_env) + + -- See Note [Avails of associated data families] + expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt] + expand_tyty_gre (gre@GRE { gre_par = ParentIs p }) + | isTyConName p + , isTyConName (greName gre) + = [gre, gre{ gre_par = NoParent }] + expand_tyty_gre gre + = [gre] + + imported_modules = [ imv_name imv + | xs <- Map.elems $ imp_mods imports + , imv <- importedByUser xs ] + + exports_from_item :: ExportAccum -> LIE GhcPs + -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails)) + exports_from_item expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_exp_dflts = exp_dflts, + expacc_mods = earlier_mods, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEModuleContents (warn_txt_ps, _) lmod@(L _ mod))) + | Just exported_names <- lookupUniqMap earlier_mods mod -- Duplicate export of M + = do { addDiagnostic (TcRnDupeModuleExport mod) + ; (export_warn_spans', dont_warn_export', _) <- + process_warning export_warn_spans + dont_warn_export + exported_names + warn_txt_ps + (locA loc) + -- Checks if all the names are exported with the same warning message + -- or if they should not be warned about + ; return ( expacc{ expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , Nothing ) } + + | otherwise + = do { let { exportValid = (mod `elem` imported_modules) + || (moduleName this_mod == mod) + ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) + -- NB: this filters out non level 0 exports + ; new_gres = [ gre' + | (gre, _) <- gre_prs + , gre' <- expand_tyty_gre gre ] + ; new_exports = map availFromGRE new_gres + ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs + ; exported_names = map greName new_gres + ; mods = addToUniqMap earlier_mods mod exported_names + } + + ; checkErr exportValid (TcRnExportedModNotImported mod) + ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod) + + ; traceRn "efa" (ppr mod $$ ppr all_gres) + ; addUsedGREs ExportDeprecationWarnings all_gres + + ; occs' <- check_occs occs ie new_gres + -- This check_occs not only finds conflicts + -- between this item and others, but also + -- internally within this item. That is, if + -- 'M.x' is in scope in several ways, we'll have + -- several members of mod_avails with the same + -- OccName. + ; (export_warn_spans', dont_warn_export', warn_txt_rn) <- + process_warning export_warn_spans + dont_warn_export + exported_names + warn_txt_ps + (locA loc) + + ; traceRn "export_mod" + (vcat [ ppr mod + , ppr new_exports ]) + ; return ( ExportAccum { expacc_exp_occs = occs' + , expacc_exp_dflts = exp_dflts -- IEModuleContents does not re-export defaults + , expacc_mods = mods + , expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , Just (L loc (IEModuleContents warn_txt_rn lmod), new_exports) ) } + + exports_from_item acc lie = do + m_doc_ie <- lookup_doc_ie lie + case m_doc_ie of + Just new_ie -> + return (acc, Just (new_ie, [])) + Nothing -> do + m_ie <- lookup_ie acc lie + case m_ie of + Nothing -> return (acc, Nothing) + Just (acc', new_ie, mb_item) -> + case mb_item of + Nothing -> + return (acc', Nothing) + Just avail -> + return (acc', Just (new_ie, [avail])) + + ------------- + lookup_ie :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, LIE GhcRn, Maybe AvailInfo)) + lookup_ie expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEVar warn_txt_ps l doc)) + = do mb_gre <- lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l + for mb_gre $ \ gre -> do + let avail = availFromGRE gre + name = greName gre + + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) + occs' <- check_occs occs ie [gre] + (export_warn_spans', dont_warn_export', warn_txt_rn) + <- process_warning export_warn_spans + dont_warn_export + [name] + warn_txt_ps + (locA loc) + + doc' <- traverse rnLHsDoc doc + return ( expacc{ expacc_exp_occs = occs' + , expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , L loc (IEVar warn_txt_rn (replaceLWrappedName l name) doc') + , Just avail ) + + lookup_ie expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_exp_dflts = exp_dflts, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEThingAbs warn_txt_ps l doc)) + = do mb_gre <- lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l + for mb_gre $ \ gre -> do + let avail = availFromGRE gre + name = greName gre + + (mb_avail, occs', exp_dflts') <- + case unLoc l of + -- see Note [Default exports] + IEDefault {} -> do + defaults <- tcg_default <$> getGblEnv + case lookupUFM_Directly defaults (nameUnique name) of + Nothing -> + do addErr $ TcRnExportHiddenDefault ie + return (Nothing, occs, exp_dflts) + Just cls_dflts -> do + let cls = cd_class cls_dflts + case lookupNameEnv exp_dflts (className cls) of + Just (_, ie') -> do + addDiagnostic $ + TcRnDuplicateNamedDefaultExport (classTyCon cls) ie ie' + return (Nothing, occs, exp_dflts) + Nothing -> + return $ (Nothing, occs, extendNameEnv exp_dflts (className cls) (cls_dflts, ie)) + _ -> do + occs' <- check_occs occs ie [gre] + return (Just avail, occs', exp_dflts) + + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) + (export_warn_spans', dont_warn_export', warn_txt_rn) + <- process_warning export_warn_spans + dont_warn_export + [name] + warn_txt_ps + (locA loc) + + doc' <- traverse rnLHsDoc doc + return ( expacc{ expacc_exp_occs = occs' + , expacc_exp_dflts = exp_dflts' + , expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , L loc (IEThingAbs warn_txt_rn (replaceLWrappedName l name) doc') + , mb_avail ) + + lookup_ie expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEThingAll (warn_txt_ps, ann) l doc)) + = do mb_gre <- lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l + for mb_gre $ \ par -> do + all_kids <- lookup_ie_kids_all ie l par + let name = greName par + all_gres = par : all_kids + all_names = map greName all_gres + + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) + occs' <- check_occs occs ie all_gres + (export_warn_spans', dont_warn_export', warn_txt_rn) + <- process_warning export_warn_spans + dont_warn_export + all_names + warn_txt_ps + (locA loc) + + doc' <- traverse rnLHsDoc doc + return ( expacc{ expacc_exp_occs = occs' + , expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , L loc (IEThingAll (warn_txt_rn, ann) (replaceLWrappedName l name) doc') + , Just $ AvailTC name all_names ) + + lookup_ie expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEThingWith (warn_txt_ps, ann) l wc sub_rdrs doc)) + = do mb_gre <- addErrCtxt (ExportCtxt ie) + $ lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l + for mb_gre $ \ par -> do + (subs, with_kids) + <- addErrCtxt (ExportCtxt ie) + $ lookup_ie_kids_with par sub_rdrs + + wc_kids <- + case wc of + NoIEWildcard -> return [] + IEWildcard _ -> lookup_ie_kids_all ie l par + + let name = greName par + all_kids = with_kids ++ wc_kids + all_gres = par : all_kids + all_names = map greName all_gres + + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) + occs' <- check_occs occs ie all_gres + (export_warn_spans', dont_warn_export', warn_txt_rn) + <- process_warning export_warn_spans + dont_warn_export + all_names + warn_txt_ps + (locA loc) + + doc' <- traverse rnLHsDoc doc + return ( expacc{ expacc_exp_occs = occs' + , expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , L loc (IEThingWith (warn_txt_rn, ann) (replaceLWrappedName l name) wc subs doc') + , Just $ AvailTC name all_names ) + + lookup_ie _ _ = panic "lookup_ie" -- Other cases covered earlier + + + lookup_ie_kids_with :: GlobalRdrElt -> [LIEWrappedName GhcPs] + -> RnM ([LIEWrappedName GhcRn], [GlobalRdrElt]) + lookup_ie_kids_with gre sub_rdrs = + do { kids <- lookupChildrenExport gre sub_rdrs + ; return (map fst kids, map snd kids) } + + lookup_ie_kids_all :: IE GhcPs -> LIEWrappedName GhcPs -> GlobalRdrElt + -> RnM [GlobalRdrElt] + lookup_ie_kids_all ie (L _loc rdr) gre = + do { let name = greName gre + gres = findChildren kids_env name + -- We only choose level 0 exports when filling in part of an export list implicitly. + ; let kids_0 = mapMaybe pickLevelZeroGRE gres + ; addUsedKids (ieWrappedName rdr) kids_0 + ; when (null kids_0) $ + if isTyConName name + then addTcRnDiagnostic (TcRnDodgyExports gre) + else -- This occurs when you export T(..), but + -- only import T abstractly, or T is a synonym. + addErr (TcRnExportHiddenComponents ie) + ; return kids_0 } + + ------------- + + -- Runs for every Name + -- - If there is no new warning, flags that the old warning should not be + -- included (since a warning should only be emitted if all + -- of the export statements have a warning) + -- - If the Name already has a warning, adds it + process_warning :: ExportWarnSpanNames -- Old aggregate data about warnins + -> DontWarnExportNames -- Old names not to warn about + -> [Name] -- Names to warn about + -> Maybe (LWarningTxt GhcPs) -- Warning + -> SrcSpan -- Span of the export list item + -> RnM (ExportWarnSpanNames, -- Aggregate data about the warnings + DontWarnExportNames, -- Names not to warn about in the end + -- (when there was a non-warned export) + Maybe (LWarningTxt GhcRn)) -- Renamed warning + process_warning export_warn_spans + dont_warn_export + names Nothing loc + = return ( export_warn_spans + , foldr update_dont_warn_export + dont_warn_export names + , Nothing ) + where + update_dont_warn_export :: Name -> DontWarnExportNames -> DontWarnExportNames + update_dont_warn_export name dont_warn_export' + = extendNameEnv_Acc (NE.<|) + NE.singleton + dont_warn_export' + name + loc + + process_warning export_warn_spans + dont_warn_export + names (Just warn_txt_ps) loc + = do + warn_txt_rn <- rnLWarningTxt warn_txt_ps + let new_export_warn_spans = map (, unLoc warn_txt_rn, loc) names + return ( new_export_warn_spans ++ export_warn_spans + , dont_warn_export + , Just warn_txt_rn ) + + -- For each name exported with any warnings throws an error + -- if there are any exports of that name with a different warning + aggregate_warnings :: ExportWarnSpanNames + -> DontWarnExportNames + -> RnM (ExportWarnNames GhcRn) + aggregate_warnings export_warn_spans dont_warn_export + = fmap catMaybes + $ mapM (aggregate_single . extract_name) + $ NE.groupBy (\(n1, _, _) (n2, _, _) -> n1 == n2) + $ sortBy (\(n1, _, _) (n2, _, _) -> n1 `compare` n2) export_warn_spans + where + extract_name :: NE.NonEmpty (Name, WarningTxt GhcRn, SrcSpan) + -> (Name, NE.NonEmpty (WarningTxt GhcRn, SrcSpan)) + extract_name l@((name, _, _) NE.:| _) + = (name, NE.map (\(_, warn_txt, span) -> (warn_txt, span)) l) + + aggregate_single :: (Name, NE.NonEmpty (WarningTxt GhcRn, SrcSpan)) + -> RnM (Maybe (Name, WarningTxt GhcRn)) + aggregate_single (name, (warn_txt_rn, loc) NE.:| warn_spans) + = do + -- Emit an error if the warnings differ + case NE.nonEmpty spans_different of + Nothing -> return () + Just spans_different + -> addErrAt loc (TcRnDifferentExportWarnings name spans_different) + -- Emit a warning if some export list items do not have a warning + case lookupNameEnv dont_warn_export name of + Nothing -> return $ Just (name, warn_txt_rn) + Just not_warned_spans -> do + addDiagnosticAt loc (TcRnIncompleteExportWarnings name not_warned_spans) + return Nothing + where + spans_different = map snd $ filter (not . warningTxtSame warn_txt_rn . fst) warn_spans + + ------------- + lookup_doc_ie :: LIE GhcPs -> RnM (Maybe (LIE GhcRn)) + lookup_doc_ie (L loc (IEGroup _ lev doc)) = do + doc' <- rnLHsDoc doc + pure $ Just (L loc (IEGroup noExtField lev doc')) + lookup_doc_ie (L loc (IEDoc _ doc)) = do + doc' <- rnLHsDoc doc + pure $ Just (L loc (IEDoc noExtField doc')) + lookup_doc_ie (L loc (IEDocNamed _ str)) + = pure $ Just (L loc (IEDocNamed noExtField str)) + lookup_doc_ie _ = pure Nothing + + -- In an export item M.T(A,B,C), we want to treat the uses of + -- A,B,C as if they were M.A, M.B, M.C + -- Happily pickGREs does just the right thing + addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM () + addUsedKids parent_rdr kid_gres + = addUsedGREs ExportDeprecationWarnings (pickGREs parent_rdr kid_gres) + + +ieLWrappedUserRdrName :: LIEWrappedName GhcPs -> Name -> LIdOccP GhcRn +ieLWrappedUserRdrName l n = fmap (\rdr -> WithUserRdr rdr n) $ ieLWrappedName l + +-- | In what namespaces should we go looking for an import/export item +-- that is out of scope, for suggestions in error messages? +ieWrappedNameWhatLooking :: IEWrappedName GhcPs -> WhatLooking +ieWrappedNameWhatLooking = \case + IEName {} -> WL_TyCon_or_TermVar + IEDefault {} -> WL_TyCon + IEType {} -> WL_Type + IEData {} -> WL_Term + IEPattern {} -> WL_ConLike + +ieLWrappedNameWhatLooking :: LIEWrappedName GhcPs -> WhatLooking +ieLWrappedNameWhatLooking = ieWrappedNameWhatLooking . unLoc + +-- Renaming and typechecking of exports happens after everything else has +-- been typechecked. + +{- +Note [Modules without a module header] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Haskell 2010 report says in section 5.1: + +>> An abbreviated form of module, consisting only of the module body, is +>> permitted. If this is used, the header is assumed to be +>> 'module Main(main) where'. + +For modules without a module header, this is implemented the +following way: + +If the module has a main function in scope: + Then create a module header and export the main function, + as if a module header like 'module Main(main) where...' would exist. + This has the effect to mark the main function and all top level + functions called directly or indirectly via main as 'used', + and later on, unused top-level functions can be reported correctly. + There is no distinction between GHC and GHCi. +If the module has several main functions in scope: + Then generate a header as above. The ambiguity is reported later in + module `GHC.Tc.Module` function `check_main`. +If the module has NO main function: + Then export all top-level functions. This marks all top level + functions as 'used'. + In GHCi this has the effect, that we don't get any 'non-used' warnings. + In GHC, however, the 'has-main-module' check in GHC.Tc.Module.checkMain + fires, and we get the error: + The IO action 'main' is not defined in module 'Main' +-} + + +-- Renaming exports lists is a minefield. Five different things can appear in +-- children export lists ( T(A, B, C) ). +-- 1. Record selectors +-- 2. Type constructors +-- 3. Data constructors +-- 4. Pattern Synonyms +-- 5. Pattern Synonym Selectors +-- +-- However, things get put into weird name spaces. +-- 1. Some type constructors are parsed as variables (-.->) for example. +-- 2. All data constructors are parsed as type constructors +-- 3. When there is ambiguity, we default type constructors to data +-- constructors and require the explicit `type` keyword for type +-- constructors. +-- +-- This function first establishes the possible namespaces that an +-- identifier might be in (`choosePossibleNameSpaces`). +-- +-- Then for each namespace in turn, tries to find the correct identifier +-- there returning the first positive result or the first terminating +-- error. +-- + + + +lookupChildrenExport :: GlobalRdrElt + -> [LIEWrappedName GhcPs] + -> RnM ([(LIEWrappedName GhcRn, GlobalRdrElt)]) +lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items + where + spec_parent = greName parent_gre + -- Process an individual child + doOne :: LIEWrappedName GhcPs + -> RnM (LIEWrappedName GhcRn, GlobalRdrElt) + doOne n = do + + let bareName = (ieWrappedName . unLoc) n + -- Do not report export list declaration deprecations + name <- lookupSubBndrOcc_helper False ExportDeprecationWarnings + (ParentGRE spec_parent (greInfo parent_gre)) bareName + traceRn "lookupChildrenExport" (ppr name) + -- Default to data constructors for slightly better error + -- messages + let unboundName :: RdrName + unboundName = if rdrNameSpace bareName == varName + then bareName + else setRdrNameSpace bareName dataName + + case name of + NameNotFound -> + do { ub <- reportUnboundName (lookingForSubordinate parent_gre) unboundName + ; let l = getLoc n + gre = mkLocalGRE UnboundGRE NoParent ub + ; return (L l (IEName noExtField (L (l2l l) ub)), gre)} + FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) -> + do { checkPatSynParent spec_parent par child_nm + ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child_nm) + ; return (replaceLWrappedName n child_nm, child) + } + IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs + + +-- Note [Typing Pattern Synonym Exports] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- It proved quite a challenge to precisely specify which pattern synonyms +-- should be allowed to be bundled with which type constructors. +-- In the end it was decided to be quite liberal in what we allow. Below is +-- how Simon described the implementation. +-- +-- "Personally I think we should Keep It Simple. All this talk of +-- satisfiability makes me shiver. I suggest this: allow T( P ) in all +-- situations except where `P`'s type is ''visibly incompatible'' with +-- `T`. +-- +-- What does "visibly incompatible" mean? `P` is visibly incompatible +-- with +-- `T` if +-- * `P`'s type is of form `... -> S t1 t2` +-- * `S` is a data/newtype constructor distinct from `T` +-- +-- Nothing harmful happens if we allow `P` to be exported with +-- a type it can't possibly be useful for, but specifying a tighter +-- relationship is very awkward as you have discovered." +-- +-- Note that this allows *any* pattern synonym to be bundled with any +-- datatype type constructor. For example, the following pattern `P` can be +-- bundled with any type. +-- +-- ``` +-- pattern P :: (A ~ f) => f +-- ``` +-- +-- So we provide basic type checking in order to help the user out, most +-- pattern synonyms are defined with definite type constructors, but don't +-- actually prevent a library author completely confusing their users if +-- they want to. +-- +-- So, we check for exactly four things +-- 1. The name arises from a pattern synonym definition. (Either a pattern +-- synonym constructor or a pattern synonym selector) +-- 2. The pattern synonym is only bundled with a datatype or newtype. +-- 3. Check that the head of the result type constructor is an actual type +-- constructor and not a type variable. (See above example) +-- 4. Is so, check that this type constructor is the same as the parent +-- type constructor. +-- +-- +-- Note [Types of TyCon] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- This check appears to be overly complicated, Richard asked why it +-- is not simply just `isAlgTyCon`. The answer for this is that +-- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. +-- (It is either a newtype or data depending on the number of methods) +-- + +-- | Given a resolved name in the children export list and a parent. Decide +-- whether we are allowed to export the child with the parent. +-- Invariant: gre_par == NoParent +-- See Note [Typing Pattern Synonym Exports] +checkPatSynParent :: Name -- ^ Alleged parent type constructor + -- User wrote T( P, Q ) + -> Parent -- The parent of P we discovered + -> Name + -- ^ Either a + -- a) Pattern Synonym Constructor + -- b) A pattern synonym selector + -> TcM () -- Fails if wrong parent +checkPatSynParent _ (ParentIs {}) _ + = return () + +checkPatSynParent parent NoParent nm + | isUnboundName parent -- Avoid an error cascade + = return () + + | otherwise + = do { parent_ty_con <- tcLookupTyCon parent + ; mpat_syn_thing <- tcLookupGlobal nm + + -- 1. Check that the Id was actually from a thing associated with patsyns + ; case mpat_syn_thing of + AnId i | isId i + , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i + -> handle_pat_syn (PatSynRecSelExportCtxt p nm) parent_ty_con p + + AConLike (PatSynCon p) -> handle_pat_syn (PatSynExportCtxt p) parent_ty_con p + + _ -> failWithDcErr parent nm [] } + where + handle_pat_syn :: ErrCtxtMsg + -> TyCon -- Parent TyCon + -> PatSyn -- Corresponding bundled PatSyn + -- and pretty printed origin + -> TcM () + handle_pat_syn doc ty_con pat_syn + + -- 2. See Note [Types of TyCon] + | not $ isTyConWithSrcDataCons ty_con + = addErrCtxt doc $ failWithTc TcRnPatSynBundledWithNonDataCon + + -- 3. Is the head a type variable? + | Nothing <- mtycon + = return () + -- 4. Ok. Check they are actually the same type constructor. + + | Just p_ty_con <- mtycon, p_ty_con /= ty_con + = addErrCtxt doc $ failWithTc + (TcRnPatSynBundledWithWrongType expected_res_ty res_ty) + + -- 5. We passed! + | otherwise + = return () + + where + expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con)) + (_, _, _, _, _, res_ty) = patSynSig pat_syn + mtycon = fst <$> tcSplitTyConApp_maybe res_ty + + +{-===========================================================================-} + +-- | Insert the given 'GlobalRdrElt's into the 'ExportOccMap', checking that +-- each of the given 'GlobalRdrElt's does not appear multiple times in +-- the 'ExportOccMap', as per Note [Exporting duplicate declarations]. +check_occs :: ExportOccMap -> IE GhcPs -> [GlobalRdrElt] -> RnM ExportOccMap +check_occs occs ie gres + -- 'gres' are the entities specified by 'ie' + = do { drf <- xoptM LangExt.DuplicateRecordFields + ; foldlM (check drf) occs gres } + where + + -- Check for distinct children exported with the same OccName (an error) or + -- for duplicate exports of the same child (a warning). + -- + -- See Note [Exporting duplicate declarations]. + check :: Bool -> ExportOccMap -> GlobalRdrElt -> RnM ExportOccMap + check drf_enabled occs gre + = case try_insert occs gre of + Right occs' + -- If DuplicateRecordFields is not enabled, also make sure + -- that we are not exporting two fields with the same occNameFS + -- under different namespaces. + -- + -- See Note [Exporting duplicate record fields]. + | drf_enabled || not (isFieldOcc child_occ) + -> return occs' + | otherwise + -> do { let flds = filter (\(_,ie') -> not $ dupFieldExport_ok ie ie') + $ lookupFieldsOccEnv occs (occNameFS child_occ) + ; case flds of { [] -> return occs'; clash1:clashes -> + do { addDuplicateFieldExportErr (gre,ie) (clash1 NE.:| clashes) + ; return occs } } } + + Left (child', ie') + | child == child' -- Duplicate export of a single Name: a warning. + -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport gre ie ie') + ; return occs } + + | otherwise -- Same OccName but different Name: an error. + -> do { global_env <- getGlobalRdrEnv + ; addErr (exportClashErr global_env child' child ie' ie) + ; return occs } + where + child = greName gre + child_occ = occName child + + -- Try to insert a child into the map, returning Left if there is something + -- already exported with the same OccName. + try_insert :: ExportOccMap -> GlobalRdrElt -> Either (Name, IE GhcPs) ExportOccMap + try_insert occs child + = case lookupOccEnv occs occ of + Nothing -> Right (extendOccEnv occs occ (greName child, ie)) + Just x -> Left x + where + occ = greOccName child + +-- | Is it OK for the given name to be exported by both export items? +-- +-- See Note [Exporting duplicate declarations]. +dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool +dupExport_ok child ie1 ie2 + = not ( single ie1 || single ie2 + || (explicit_in ie1 && explicit_in ie2) ) + where + explicit_in (IEModuleContents {}) = False -- module M + explicit_in (IEThingAll _ r _) + = occName child == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..) + explicit_in _ = True + + single IEVar {} = True + single IEThingAbs {} = True + single _ = False + +failWithDcErr :: Name -> Name -> [Name] -> TcM a +failWithDcErr parent child parents = do + ty_thing <- tcLookupGlobal child + failWithTc $ TcRnExportedParentChildMismatch parent ty_thing child parents + + +exportClashErr :: GlobalRdrEnv + -> Name -> Name + -> IE GhcPs -> IE GhcPs + -> TcRnMessage +exportClashErr global_env child1 child2 ie1 ie2 + = TcRnConflictingExports occ gre1' ie1' gre2' ie2' + where + occ = occName child1 + -- get_gre finds a GRE for the Name, so that we can show its provenance + gre1 = get_gre child1 + gre2 = get_gre child2 + get_gre child + = fromMaybe (pprPanic "exportClashErr" (ppr child)) + (lookupGRE_Name global_env child) + (gre1', ie1', gre2', ie2') = + case SrcLoc.leftmost_smallest (greSrcSpan gre1) (greSrcSpan gre2) of + LT -> (gre1, ie1, gre2, ie2) + GT -> (gre2, ie2, gre1, ie1) + EQ -> panic "exportClashErr: clashing exports have identical location" + +addDuplicateFieldExportErr :: (GlobalRdrElt, IE GhcPs) + -> NE.NonEmpty (Name, IE GhcPs) + -> RnM () +addDuplicateFieldExportErr gre others + = do { rdr_env <- getGlobalRdrEnv + ; let lkup = expectJust . lookupGRE_Name rdr_env + other_gres = fmap (first lkup) others + ; addErr (TcRnDuplicateFieldExport gre other_gres) } + +-- | Is it OK to export two clashing duplicate record fields coming from the +-- given export items, with @-XDisambiguateRecordFields@ disabled? +-- +-- See Note [Exporting duplicate record fields]. +dupFieldExport_ok :: IE GhcPs -> IE GhcPs -> Bool +dupFieldExport_ok ie1 ie2 + | IEModuleContents {} <- ie1 + , ie2 == ie1 + = True + | otherwise + = False + +{- Note [Exporting duplicate declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to check that two different export items don't have both attempt to export +the same thing. What do we mean precisely? There are three main situations to consider: + + 1. We export two distinct Names with identical OccNames. This is an error. + 2. We export the same Name in two different export items. This is usually + a warning, but see below. + 3. We export a duplicate record field, and DuplicateRecordFields is not enabled. + See Note [Exporting duplicate record fields]. + +Concerning (2), we sometimes want to allow a duplicate export of a given Name, +as #4478 points out. The logic, as implemented in dupExport_ok, is that we +do not allow a given Name to be exported by two IEs iff either: + + - the Name is mentioned explicitly in both IEs, or + - one of the IEs mentions the name *alone*. + +Examples: + + NOT OK: module M( f, f ) + + f is mentioned explicitly in both + + NOT OK: module M( fmap, Functor(..) ) + NOT OK: module M( module Data.Functor, fmap ) + + One of the import items mentions fmap alone, which is also + exported by the other export item. + + OK: + module M( module A, module B ) where + import A( f ) + import B( f ) + + OK: (#2436) + module M( C(..), T(..) ) where + class C a where { data T a } + instance C Int where { data T Int = TInt } + + OK: (#2436) + module Foo ( T ) where + data family T a + module Bar ( T(..), module Foo ) where + import Foo + data instance T Int = TInt + +Note [Exporting duplicate record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record fields belonging to different datatypes belong to different namespaces, +as explained in Note [Record field namespacing] in GHC.Types.Name.Occurrence. +However, when the DuplicateRecordFields extension is NOT enabled, we want to +prevent users from exporting record fields that share the same underlying occNameFS. + +To enforce this, in check_occs, when inserting a new record field into the ExportOccMap +and DuplicateRecordFields is not enabled, we also look up any clashing record fields, +and report an error. + +Note however that the clash check has an extra wrinkle, similar to dupExport_ok, +as we want to allow the following: + + {-# LANGUAGE DuplicateRecordFields #-} + module M1 where + data D1 = MkD1 { foo :: Int } + data D2 = MkD2 { foo :: Bool } + + --------------------------------------------- + + module M2 ( module M1 ) where + import M1 + +That is, we should be allowed to re-export the whole module M1, without reporting +any nameclashes, even though M1 exports duplicate record fields and we have not +enabled -XDuplicateRecordFields in M2. This logic is implemented in +dupFieldExport_ok. See test case NoDRFModuleExport. + +Note that this logic only applies to whole-module imports, as we don't want +to allow the following: + + module N0 where + data family D a + module N1 where + import N0 + data instance D Int = MkDInt { foo :: Int } + module N2 where + import N0 + data instance D Bool = MkDBool { foo :: Int } + + module N (D(..)) where + import N1 + import N2 + +Here, the single export item D(..) of N exports both record fields, +`$fld:MkDInt:foo` and `$fld:MkDBool:foo`, so we have to reject the program. +See test overloadedrecfldsfail10. +-} diff --git a/GHC/Tc/Gen/Expr.hs b/GHC/Tc/Gen/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Expr.hs @@ -0,0 +1,1925 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- +% +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +module GHC.Tc.Gen.Expr + ( tcCheckPolyExpr, tcCheckPolyExprNC, + tcCheckMonoExpr, tcCheckMonoExprNC, + tcMonoExpr, tcMonoExprNC, + tcInferExpr, tcInferSigma, tcInferRho, tcInferRhoNC, + tcPolyLExpr, tcPolyExpr, tcExpr, tcPolyLExprSig, + tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, + tcCheckId, + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import {-# SOURCE #-} GHC.Tc.Gen.Splice + ( tcTypedSplice, tcTypedBracket, tcUntypedBracket, getUntypedSpliceBody ) + +import GHC.Hs +import GHC.Hs.Syn.Type + +import GHC.Rename.Utils +import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls ) + +import GHC.Tc.Gen.App +import GHC.Tc.Gen.Head +import GHC.Tc.Gen.Bind ( tcLocalBinds ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Arrow +import GHC.Tc.Gen.Match( tcBody, tcLambdaMatches, tcCaseMatches + , tcGRHSNE, tcDoStmts ) +import GHC.Tc.Instance.Family ( tcGetFamInstEnvs ) +import GHC.Tc.Zonk.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType as TcType +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep ) +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Tc.Errors.Types hiding (HoleError) + +import GHC.Core.Multiplicity +import GHC.Core.UsageEnv +import GHC.Core.FamInstEnv ( FamInstEnvs ) +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Class(classTyCon) +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Predicate( decomposeIPPred ) + +import GHC.Types.Basic +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Types.Unique.Set +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc + +import GHC.Builtin.Types +import GHC.Builtin.Names +import GHC.Builtin.Uniques ( mkBuiltinUnique ) + +import GHC.Driver.DynFlags + +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic + +import GHC.Data.List.SetOps +import GHC.Data.Maybe + +import Control.Monad +import qualified Data.List.NonEmpty as NE + +{- +************************************************************************ +* * +\subsection{Main wrappers} +* * +************************************************************************ +-} + +tcCheckPolyExpr, tcCheckPolyExprNC + :: LHsExpr GhcRn -- Expression to type check + -> TcSigmaType -- Expected type (could be a polytype) + -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type + +-- tcCheckPolyExpr is a convenient place (frequent but not too frequent) +-- place to add context information. +-- The NC version does not do so, usually because the caller wants +-- to do so themselves. + +tcCheckPolyExpr expr res_ty = tcPolyLExpr expr (mkCheckExpType res_ty) +tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty) + +----------------- +-- These versions take an ExpType +tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType + -> TcM (LHsExpr GhcTc) + +tcPolyLExpr (L loc expr) res_ty + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { expr' <- tcPolyExpr expr res_ty + ; return (L loc expr') } + +tcPolyLExprNC (L loc expr) res_ty + = setSrcSpanA loc $ + do { expr' <- tcPolyExpr expr res_ty + ; return (L loc expr') } + +----------------- +tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) +tcPolyExpr e (Infer inf) = tcExpr e (Infer inf) +tcPolyExpr e (Check ty) = tcPolyExprCheck e (Left ty) + +----------------- +tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc) +tcPolyLExprSig (L loc expr) sig + = setSrcSpanA loc $ + -- No addExprCtxt. For (e :: ty) we don't want generate + -- In the expression e + -- In the expression e :: ty + -- We have already got an error-context for (e::ty), so when we + -- get to `e`, just add the location + do { traceTc "tcPolyLExprSig" (ppr loc $$ ppr expr) + ; expr' <- tcPolyExprCheck expr (Right sig) + ; return (L loc expr') } + +----------------- +tcPolyExprCheck :: HsExpr GhcRn + -> Either TcSigmaType TcCompleteSig + -> TcM (HsExpr GhcTc) +-- tcPolyExpCheck deals with the special case for HsLam, in case the pushed-down +-- type is a forall-type. E.g. (\@a -> blah) :: forall b. b -> Int +-- +-- The (Either TcSigmaType TcCompleteSig) deals with: +-- Left ty: (f e) pushes f's argument type `ty` into `e` +-- Right sig: (e :: sig) pushes `sig` into `e` +-- The Either stuff is entirely local to this function and its immediate callers. +-- +-- See Note [Skolemisation overview] in GHC.Tc.Utils.Unify + +tcPolyExprCheck expr res_ty + = outer_skolemise res_ty $ \pat_tys rho_ty -> + let + -- tc_body is a little loop that looks past parentheses + tc_body (HsPar x (L loc e)) + = setSrcSpanA loc $ + do { e' <- tc_body e + ; return (HsPar x (L loc e')) } + + -- Look through any untyped splices (#24559) + -- c.f. Note [Looking through Template Haskell splices in splitHsApps] + tc_body (HsUntypedSplice splice_res _) + = do { body <- getUntypedSpliceBody splice_res + ; tc_body body } + + -- The special case for lambda: go to tcLambdaMatches, passing pat_tys + tc_body e@(HsLam x lam_variant matches) + = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches pat_tys + (mkCheckExpType rho_ty) + -- NB: tcLambdaMatches concludes with deep skolemisation, + -- if DeepSubsumption is on; hence no need to do that here + ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } + + -- The general case: just do deep skolemisation if necessary, + -- before handing off to tcExpr + tc_body e = do { ds_flag <- getDeepSubsumptionFlag + ; inner_skolemise ds_flag rho_ty $ \rho_ty' -> + tcExpr e (mkCheckExpType rho_ty') } + in tc_body expr + where + -- `outer_skolemise` is used always + -- It only does shallow skolemisation + -- It always makes an implication constraint if deferred-errors is on + outer_skolemise :: Either TcSigmaType TcCompleteSig + -> ([ExpPatType] -> TcRhoType -> TcM (HsExpr GhcTc)) + -> TcM (HsExpr GhcTc) + outer_skolemise (Left ty) thing_inside + = do { (wrap, expr') <- tcSkolemiseExpectedType ty thing_inside + ; return (mkHsWrap wrap expr') } + outer_skolemise (Right sig) thing_inside + = do { (wrap, expr') <- tcSkolemiseCompleteSig sig thing_inside + ; return (mkHsWrap wrap expr') } + + -- inner_skolemise is used when we do not have a lambda + -- With deep skolemisation we must remember to deeply skolemise + -- after the (always-shallow) tcSkolemiseCompleteSig + inner_skolemise :: DeepSubsumptionFlag -> TcRhoType + -> (TcRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc) + inner_skolemise Shallow rho_ty thing_inside + = -- We have already done shallow skolemisation, so nothing further to do + thing_inside rho_ty + inner_skolemise Deep rho_ty thing_inside + = -- Try deep skolemisation + do { (wrap, expr') <- tcSkolemise Deep ctxt rho_ty thing_inside + ; return (mkHsWrap wrap expr') } + + ctxt = case res_ty of + Left {} -> GenSigCtxt + Right sig -> sig_ctxt sig + + +{- ********************************************************************* +* * + tcExpr: the main expression typechecker +* * +********************************************************************* -} + +tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType) +tcInferSigma = tcInferExpr IIF_Sigma + +tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) +-- Infer a *rho*-type. The return type is always instantiated. +tcInferRho = tcInferExpr IIF_DeepRho +tcInferRhoNC = tcInferExprNC IIF_DeepRho + +tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) +tcInferExpr iif (L loc expr) + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr) + ; return (L loc expr', rho) } + +tcInferExprNC iif (L loc expr) + = setSrcSpanA loc $ + do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr) + ; return (L loc expr', rho) } + +--------------- +tcCheckMonoExpr, tcCheckMonoExprNC + :: LHsExpr GhcRn -- Expression to type check + -> TcRhoType -- Expected type + -- Definitely no foralls at the top + -> TcM (LHsExpr GhcTc) +tcCheckMonoExpr expr res_ty = tcMonoExpr expr (mkCheckExpType res_ty) +tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty) + +--------------- +tcMonoExpr, tcMonoExprNC + :: LHsExpr GhcRn -- Expression to type check + -> ExpRhoType -- Expected type + -- Definitely no foralls at the top + -> TcM (LHsExpr GhcTc) + +tcMonoExpr (L loc expr) res_ty + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } + +tcMonoExprNC (L loc expr) res_ty + = setSrcSpanA loc $ + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } + +--------------- +tcExpr :: HsExpr GhcRn + -> ExpRhoType -- DeepSubsumption <=> when checking, this type + -- is deeply skolemised + -> TcM (HsExpr GhcTc) + +-- Use tcApp to typecheck applications, which are treated specially +-- by Quick Look. Specifically: +-- - HsVar lone variables, to ensure that they can get an +-- impredicative instantiation (via Quick Look +-- driven by res_ty (in checking mode)). +-- - HsApp value applications +-- - HsAppType type applications +-- - ExprWithTySig (e :: type) +-- - HsRecSel overloaded record fields +-- - ExpandedThingRn renamer/pre-typechecker expansions +-- - HsOpApp operator applications +-- - HsOverLit overloaded literals +-- These constructors are the union of +-- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps +-- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe +-- See Note [Application chains and heads] in GHC.Tc.Gen.App +tcExpr e@(HsVar {}) res_ty = tcApp e res_ty +tcExpr e@(HsApp {}) res_ty = tcApp e res_ty +tcExpr e@(OpApp {}) res_ty = tcApp e res_ty +tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty +tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty + +tcExpr (XExpr e) res_ty = tcXExpr e res_ty + +-- Typecheck an occurrence of an unbound Id +-- +-- Some of these started life as a true expression hole "_". +-- Others might simply be variables that accidentally have no binding site. +tcExpr (HsHole (HoleVar locc@(L _ occ))) res_ty + = do { ty <- expTypeToType res_ty -- Allow Int# etc (#12531) + ; her <- emitNewExprHole occ ty + ; tcEmitBindingUsage bottomUE -- Holes fit any usage environment + -- (#18491) + ; return (HsHole (HoleVar locc, her)) + } +tcExpr (HsHole HoleError) _ = + panic "GHC.Tc.Gen.Expr: tcExpr: HoleError: Not implemented" + +tcExpr e@(HsLit x lit) res_ty + = do { let lit_ty = hsLitType lit + ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } + +tcExpr (HsPar x expr) res_ty + = do { expr' <- tcMonoExprNC expr res_ty + ; return (HsPar x expr') } + +tcExpr (HsPragE x prag expr) res_ty + = do { expr' <- tcMonoExpr expr res_ty + ; return (HsPragE x (tcExprPrag prag) expr') } + +tcExpr (NegApp x expr neg_expr) res_ty + = do { (expr', neg_expr') + <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ + \[arg_ty] [arg_mult] -> + tcScalingUsage arg_mult $ tcCheckMonoExpr expr arg_ty + ; return (NegApp x expr' neg_expr') } + +tcExpr e@(HsIPVar _ x) res_ty + = do { ip_ty <- newFlexiTyVarTy liftedTypeKind + -- Create a unification type variable of kind 'Type'. + -- (The type of an implicit parameter must have kind 'Type'.) + ; let ip_name = mkStrLitTy (hsIPNameFS x) + origin = IPOccOrigin x + ; ip_class <- tcLookupClass ipClassName + ; let ip_pred = mkClassPred ip_class [ip_name, ip_ty] + ; ip_dict <- emitWantedEvVar origin ip_pred + ; let (ip_op, _) = decomposeIPPred ip_pred + wrap = mkWpEvVarApps [ip_dict] <.> mkWpTyApps [ip_name, ip_ty] + ; tcWrapResult e + (mkHsWrap wrap (mkHsVar (noLocA ip_op))) + ip_ty res_ty } + +tcExpr e@(HsLam x lam_variant matches) res_ty + = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches [] res_ty + ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } + +{- +************************************************************************ +* * + Overloaded literals +* * +************************************************************************ +-} + +tcExpr e@(HsOverLit _ lit) res_ty + = -- See Note [Typechecking overloaded literals] + do { mb_res <- tcShortCutLit lit res_ty + -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.TcMType + ; case mb_res of + Just lit' -> return (HsOverLit noExtField lit') + Nothing -> tcApp e res_ty } + -- Why go via tcApp? See Note [Typechecking overloaded literals] + +{- Note [Typechecking overloaded literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, an overloaded literal like "3" typechecks as if you +had written (fromInteger (3 :: Integer)). But in practice it's a little +tricky: + +* Rebindable syntax (see #19154 and !4981). With rebindable syntax we might have + fromInteger :: Integer -> forall a. Num a => a + and then we might hope to use a Visible Type Application (VTA) to write + 3 @Int + expecting it to expand to + fromInteger (3::Integer) @Int dNumInt + To achieve that, we need to + * treat the application using `tcApp` to deal with the VTA + * treat the overloaded literal as the "head" of an application; + see `GHC.Tc.Gen.Head.tcInferAppHead`. + +* Short-cutting. If we have + xs :: [Int] + xs = [3,4,5,6... ] + then it's a huge short-cut (in compile time) to just cough up the `Int` literal + for `3`, rather than (fromInteger @Int d), with a wanted constraint `[W] Num Int`. + See Note [Short cut for overloaded literals] in GHC.Tc.Utils.TcMType. + + We can only take this short-cut if rebindable syntax is off; see `tcShortCutLit`. +-} + + +{- +************************************************************************ +* * + Explicit lists +* * +************************************************************************ +-} + +-- Explicit lists [e1,e2,e3] have been expanded already in the renamer +-- The expansion includes an ExplicitList, but it is always the built-in +-- list type, so that's all we need concern ourselves with here. See +-- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs] +tcExpr (ExplicitList _ exprs) res_ty + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty + ; let tc_elt expr = tcCheckPolyExpr expr elt_ty + ; exprs' <- mapM tc_elt exprs + ; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' } + +tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty + | all tupArgPresent tup_args + = do { let arity = length tup_args + tup_tc = tupleTyCon boxity arity + -- NB: tupleTyCon doesn't flatten 1-tuples + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + ; res_ty <- expTypeToType res_ty + ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty + -- Unboxed tuples have RuntimeRep vars, which we + -- don't care about here + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys + Boxed -> arg_tys + ; tup_args1 <- tcCheckExplicitTuple tup_args arg_tys' + ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } + + | otherwise + = -- The tup_args are a mixture of Present and Missing (for tuple sections). + do { (tup_args1, arg_tys) <- tcInferTupArgs boxity tup_args + + ; let expr' = ExplicitTuple x tup_args1 boxity + missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys] + + -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + act_res_ty = mkScaledFunTys missing_tys (mkTupleTy1 boxity arg_tys) + + ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty) + + ; tcWrapResultMono expr expr' act_res_ty res_ty } + +tcExpr (ExplicitSum _ alt arity expr) res_ty + = do { let sum_tc = sumTyCon arity + ; res_ty <- expTypeToType res_ty + ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty + ; -- Drop levity vars, we don't care about them here + let arg_tys' = drop arity arg_tys + arg_ty = arg_tys' `getNth` (alt - 1) + ; expr' <- tcCheckPolyExpr expr arg_ty + -- Check the whole res_ty, not just the arg_ty, to avoid #20277. + -- Example: + -- a :: TYPE rep (representation-polymorphic) + -- (# 17# | #) :: (# Int# | a #) + -- This should cause an error, even though (17# :: Int#) + -- is not representation-polymorphic: we don't know how + -- wide the concrete representation of the sum type will be. + ; hasFixedRuntimeRep_syntactic (FRRUnboxedSum Nothing) res_ty + ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } + + +{- +************************************************************************ +* * + Let, case, if, do +* * +************************************************************************ +-} + +tcExpr (HsLet x binds expr) res_ty + = do { (binds', expr') <- tcLocalBinds binds $ + tcMonoExpr expr res_ty + ; return (HsLet x binds' expr') } + +tcExpr (HsCase ctxt scrut matches) res_ty + = do { -- We used to typecheck the case alternatives first. + -- The case patterns tend to give good type info to use + -- when typechecking the scrutinee. For example + -- case (map f) of + -- (x:xs) -> ... + -- will report that map is applied to too few arguments + -- + -- But now, in the GADT world, we need to typecheck the scrutinee + -- first, to get type info that may be refined in the case alternatives + mult <- newFlexiTyVarTy multiplicityTy + + -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma + -- would also be possible (tcCaseMatches accepts sigma-types) + -- Interesting litmus test: do these two behave the same? + -- case id of {..} + -- case (\v -> v) of {..} + -- This design choice is discussed in #17790 + ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut + + ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty + ; matches' <- tcCaseMatches ctxt tcBody (Scaled mult scrut_ty) matches res_ty + ; return (HsCase ctxt scrut' matches') } + +tcExpr (HsIf x pred b1 b2) res_ty + = do { pred' <- tcCheckMonoExpr pred boolTy + ; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty + ; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty + ; tcEmitBindingUsage (supUE u1 u2) + ; return (HsIf x pred' b1' b2') } + +{- +Note [MultiWayIf linearity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we'd like to compute the usage environment for + +if | b1 -> e1 + | b2 -> e2 + | otherwise -> e3 + +and let u1, u2, v1, v2, v3 denote the usage env for b1, b2, e1, e2, e3 +respectively. + +Since a multi-way if is mere sugar for nested if expressions, the usage +environment should ideally be u1 + sup(v1, u2 + sup(v2, v3)). +However, currently we don't support linear guards (#19193). All variables +used in guards from u1 and u2 will have multiplicity Many. +But in that case, we have equality u1 + sup(x,y) = sup(u1 + x, y), + and likewise u2 + sup(x,y) = sup(u2 + x, y) for any x,y. +Using this identity, we can just compute sup(u1 + v1, u2 + v2, v3) instead. +This is simple to do, since we get u_i + v_i directly from tcGRHS. +If we add linear guards, this code will have to be revisited. +Not using 'sup' caused #23814. +-} + +tcExpr (HsMultiIf _ alts) res_ty + = do { alts' <- tcGRHSNE IfAlt tcBody alts res_ty + -- See Note [MultiWayIf linearity checking] + ; res_ty <- readExpType res_ty + ; return (HsMultiIf res_ty alts') } + +tcExpr (HsDo _ do_or_lc stmts) res_ty + = tcDoStmts do_or_lc stmts res_ty + +tcExpr (HsProc x pat cmd) res_ty + = do { (pat', cmd', coi) <- tcProc pat cmd res_ty + ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } + +-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. +-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. +-- To type check +-- (static e) :: p a +-- we want to check (e :: a), +-- and wrap (static e) in a call to +-- fromStaticPtr :: IsStatic p => StaticPtr a -> p a + +tcExpr (HsStatic fvs expr) res_ty + = do { res_ty <- expTypeToType res_ty + ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty + ; (expr', lie) <- captureConstraints $ + addErrCtxt (StaticFormCtxt expr) $ + tcCheckPolyExprNC expr expr_ty + + -- Check that the free variables of the static form are closed. + -- It's OK to use nonDetEltsUniqSet here as the only side effects of + -- checkClosedInStaticForm are error messages. + ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs + + -- Require the type of the argument to be Typeable. + ; typeableClass <- tcLookupClass typeableClassName + ; typeable_ev <- emitWantedEvVar StaticOrigin $ + mkTyConApp (classTyCon typeableClass) + [liftedTypeKind, expr_ty] + + -- Insert the constraints of the static form in a global list for later + -- validation. See #13499 for an explanation of why this really isn't the + -- right thing to do: the enclosing skolems aren't in scope any more! + -- Static forms really aren't well worked out yet. + ; emitStaticConstraints lie + + -- Wrap the static form with the 'fromStaticPtr' call. + ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName + [p_ty] + ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty] + ; loc <- getSrcSpanM + ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName + ; return $ mkHsWrapCo co $ HsApp noExtField + (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr) + (L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr')) + } + +tcExpr (HsEmbTy _ _) _ = failWith (TcRnIllegalTypeExpr TypeKeywordSyntax) +tcExpr (HsQual _ _ _) _ = failWith (TcRnIllegalTypeExpr ContextArrowSyntax) +tcExpr (HsForAll _ _ _) _ = failWith (TcRnIllegalTypeExpr ForallTelescopeSyntax) +tcExpr (HsFunArr _ _ _ _) _ = failWith (TcRnIllegalTypeExpr FunctionArrowSyntax) + +{- +************************************************************************ +* * + Record construction and update +* * +************************************************************************ +-} + +tcExpr expr@(RecordCon { rcon_con = L loc qcon@(WithUserRdr _ con_name) + , rcon_flds = rbinds }) res_ty + = do { con_like <- tcLookupConLike qcon + + ; (con_expr, con_sigma) <- tcInferConLike con_like + ; (con_wrap, con_tau) <- topInstantiate orig con_sigma + -- a shallow instantiation should really be enough for + -- a data constructor. + ; let arity = conLikeArity con_like + Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau + + ; checkTc (conLikeHasBuilder con_like) $ + nonBidirectionalErr (conLikeName con_like) + + ; rbinds' <- tcRecordBinds con_like arg_tys rbinds + + ; let rcon_tc = mkHsWrap con_wrap con_expr + expr' = RecordCon { rcon_ext = rcon_tc + , rcon_con = L loc con_like + , rcon_flds = rbinds' } + + ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty + + -- Check for missing fields. We do this after type-checking to get + -- better types in error messages (cf #18869). For example: + -- data T a = MkT { x :: a, y :: a } + -- r = MkT { y = True } + -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`. + -- + -- NB: to do this really properly we should delay reporting until typechecking is complete, + -- via a new `HoleSort`. But that seems too much work. + ; checkMissingFields con_like rbinds arg_tys + + ; return ret } + where + orig = OccurrenceOf con_name + +-- Record updates via dot syntax are replaced by expanded expressions +-- in the renamer. See Note [Overview of record dot syntax] in +-- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here +-- and panic otherwise. +tcExpr expr@(RecordUpd { rupd_expr = record_expr + , rupd_flds = + RegularRecUpdFields + { xRecUpdFields = possible_parents + , recUpdFields = rbnds } + }) + res_ty + = assert (notNull rbnds) $ + do { -- Expand the record update. See Note [Record Updates]. + ; (ds_expr, ds_res_ty, err_ctxt) + <- expandRecordUpd record_expr possible_parents rbnds res_ty + + -- Typecheck the expanded expression. + ; expr' <- addErrCtxt err_ctxt $ + tcExpr (mkExpandedExpr expr ds_expr) (Check ds_res_ty) + -- NB: it's important to use ds_res_ty and not res_ty here. + -- Test case: T18802b. + + ; addErrCtxt err_ctxt $ tcWrapResultMono expr expr' ds_res_ty res_ty + -- We need to unify the result type of the expanded + -- expression with the expected result type. + -- + -- See Note [Unifying result types in tcRecordUpd]. + -- Test case: T10808. + } + +tcExpr e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {}}) _ + = pprPanic "tcExpr: unexpected overloaded-dot RecordUpd" $ ppr e + +{- +************************************************************************ +* * + Arithmetic sequences e.g. [a,b..] + and their parallel-array counterparts e.g. [: a,b.. :] + +* * +************************************************************************ +-} + +tcExpr (ArithSeq _ witness seq) res_ty + = tcArithSeq witness seq res_ty + +{- +************************************************************************ +* * + Record dot syntax +* * +************************************************************************ +-} + +-- These terms have been replaced by their expanded expressions in the renamer. See +-- Note [Overview of record dot syntax]. +tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented" +tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented" + +{- +************************************************************************ +* * + Template Haskell +* * +************************************************************************ +-} + +-- Here we get rid of it and add the finalizers to the global environment. +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. +tcExpr (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty +tcExpr e@(HsTypedBracket _ext body) res_ty = tcTypedBracket e body res_ty + +tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty +tcExpr (HsUntypedSplice splice _) res_ty + -- Since `tcApp` deals with `HsUntypedSplice` (in `splitHsApps`), you might + -- wonder why we don't delegate to `tcApp` as we do for `HsVar`, etc. + -- (See the initial block of equations for `tcExpr`.) But we can't do this + -- for `HsUntypedSplice`; to see why, read Wrinkle (UTS1) in + -- Note [Looking through Template Haskell splices in splitHsApps] in + -- GHC.Tc.Gen.Head. + = do { expr <- getUntypedSpliceBody splice + ; tcExpr expr res_ty } + +{- +************************************************************************ +* * + Catch-all +* * +************************************************************************ +-} + +tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty) +tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty) +tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) + + +{- +************************************************************************ +* * + Expansion Expressions (XXExprGhcRn) +* * +************************************************************************ +-} + +tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) + +tcXExpr (PopErrCtxt (L loc e)) res_ty + = popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` + setSrcSpanA loc $ + tcExpr e res_ty + +tcXExpr xe@(ExpandedThingRn o e') res_ty + | OrigStmt ls@(L loc s@LetStmt{}) <- o + , HsLet x binds e <- e' + = do { (binds', e') <- setSrcSpanA loc $ + addStmtCtxt s $ + tcLocalBinds binds $ + tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds + -- a duplicate error context + ; return $ mkExpandedStmtTc ls (HsLet x binds' e') + } + | OrigStmt ls@(L loc s@LastStmt{}) <- o + = setSrcSpanA loc $ + addStmtCtxt s $ + mkExpandedStmtTc ls <$> tcExpr e' res_ty + -- It is important that we call tcExpr (and not tcApp) here as + -- `e` is the last statement's body expression + -- and not a HsApp of a generated (>>) or (>>=) + -- This improves error messages e.g. tests: DoExpansion1, DoExpansion2, DoExpansion3 + | OrigStmt ls@(L loc _) <- o + = setSrcSpanA loc $ + mkExpandedStmtTc ls <$> tcApp (XExpr xe) res_ty + +tcXExpr xe res_ty = tcApp (XExpr xe) res_ty + +{- +************************************************************************ +* * + Arithmetic sequences [a..b] etc +* * +************************************************************************ +-} + +tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType + -> TcM (HsExpr GhcTc) + +tcArithSeq witness seq@(From expr) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty + ; enum_from <- newMethodFromName (ArithSeqOrigin seq) + enumFromName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from wit' (From expr') } + +tcArithSeq witness seq@(FromThen expr1 expr2) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty + ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from_then wit' (FromThen expr1' expr2') } + +tcArithSeq witness seq@(FromTo expr1 expr2) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty + ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) + enumFromToName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from_to wit' (FromTo expr1' expr2') } + +tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty + ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty + ; eft <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenToName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } + +----------------- +arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType + -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc)) +arithSeqEltType Nothing res_ty + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty + ; return (mkWpCastN coi, OneTy, elt_ty, Nothing) } +arithSeqEltType (Just fl) res_ty + = do { ((elt_mult, elt_ty), fl') + <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ + \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty) + ; return (idHsWrapper, elt_mult, elt_ty, Just fl') } + +---------------- + +-- | Typecheck an explicit tuple @(a,b,c)@ or @(\#a,b,c\#)@. +-- +-- Does not handle tuple sections. +tcCheckExplicitTuple :: [HsTupArg GhcRn] + -> [TcSigmaType] + -- ^ Argument types. + -- This function ensures they all have + -- a fixed runtime representation. + -> TcM [HsTupArg GhcTc] +tcCheckExplicitTuple args tys + = do massert (equalLength args tys) + checkTupSize (length args) + zipWith3M go [1,2..] args tys + where + go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc) + go i (Missing {}) arg_ty + = pprPanic "tcCheckExplicitTuple: tuple sections not handled here" + (ppr i $$ ppr arg_ty) + go i (Present x expr) arg_ty + = do { expr' <- tcCheckPolyExpr expr arg_ty + ; (co, _) <- hasFixedRuntimeRep (FRRUnboxedTuple i) arg_ty + ; return (Present x (mkLHsWrap (mkWpCastN co) expr')) } + +-- | Typecheck an explicit tuple or tuple section by performing type inference. +tcInferTupArgs :: Boxity + -> [HsTupArg GhcRn] -- ^ argument types + -> TcM ([HsTupArg GhcTc], [TcSigmaTypeFRR]) +tcInferTupArgs boxity args + = do { checkTupSize (length args) + ; zipWithAndUnzipM tc_infer_tup_arg [1,2..] args } + where + tc_infer_tup_arg :: Int -> HsTupArg GhcRn -> TcM (HsTupArg GhcTc, TcSigmaTypeFRR) + tc_infer_tup_arg i (Missing {}) + = do { mult <- newFlexiTyVarTy multiplicityTy + ; arg_ty <- new_arg_ty i + ; return (Missing (Scaled mult arg_ty), arg_ty) } + tc_infer_tup_arg i (Present x lexpr@(L l expr)) + = do { (expr', arg_ty) <- case boxity of + Unboxed -> runInferRhoFRR (FRRUnboxedTuple i) (tcPolyExpr expr) + Boxed -> do { arg_ty <- newFlexiTyVarTy liftedTypeKind + ; L _ expr' <- tcCheckPolyExpr lexpr arg_ty + ; return (expr', arg_ty) } + ; return (Present x (L l expr'), arg_ty) } + + new_arg_ty :: Int -> TcM TcTypeFRR + new_arg_ty i = + case boxity of + Unboxed -> newOpenFlexiFRRTyVarTy (FRRUnboxedTupleSection i) + Boxed -> newFlexiTyVarTy liftedTypeKind + +--------------------------- +-- See TcType.SyntaxOpType also for commentary +tcSyntaxOp :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] -- ^ shape of syntax operator arguments + -> ExpRhoType -- ^ overall result type + -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments, + -- takes a type per hole and a + -- multiplicity per arrow in + -- the shape. + -> TcM (a, SyntaxExprTc) +-- ^ Typecheck a syntax operator +-- The operator is a variable or a lambda at this stage (i.e. renamer +-- output)t +tcSyntaxOp orig expr arg_tys res_ty + = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) + +-- | Slightly more general version of 'tcSyntaxOp' that allows the caller +-- to specify the shape of the result of the syntax operator +tcSyntaxOpGen :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] + -> SyntaxOpType + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) + -> TcM (a, SyntaxExprTc) +tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside + = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) + -- Ugh!! But all this code is scheduled for demolition anyway + ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) + ; (result, expr_wrap, arg_wraps, res_wrap) + <- tcSynArgA orig op sigma arg_tys res_ty $ + thing_inside + ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) + ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) } +tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen" + +{- +Note [tcSynArg] +~~~~~~~~~~~~~~~ +Because of the rich structure of SyntaxOpType, we must do the +contra-/covariant thing when working down arrows, to get the +instantiation vs. skolemisation decisions correct (and, more +obviously, the orientation of the HsWrappers). We thus have +two tcSynArgs. +-} + +-- works on "expected" types, skolemising where necessary +-- See Note [tcSynArg] +tcSynArgE :: CtOrigin + -> HsExpr GhcRn -- ^ the operator to check (for error messages only) + -> TcSigmaType + -> SyntaxOpType -- ^ shape it is expected to have + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments + -> TcM (a, HsWrapper) + -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) +tcSynArgE orig op sigma_ty syn_ty thing_inside + = do { (skol_wrap, (result, ty_wrapper)) + <- tcSkolemise Shallow GenSigCtxt sigma_ty $ \rho_ty -> + go rho_ty syn_ty + ; return (result, skol_wrap <.> ty_wrapper) } + where + go rho_ty SynAny + = do { result <- thing_inside [rho_ty] [] + ; return (result, idHsWrapper) } + + go rho_ty SynRho -- same as SynAny, because we skolemise eagerly + = do { result <- thing_inside [rho_ty] [] + ; return (result, idHsWrapper) } + + go rho_ty SynList + = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty + ; result <- thing_inside [elt_ty] [] + ; return (result, mkWpCastN list_co) } + + go rho_ty (SynFun arg_shape res_shape) + = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty + , ( ( (result, arg_ty, res_ty, op_mult) + , res_wrapper ) -- :: res_ty_out "->" res_ty + , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out + <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $ + \ [ExpFunPatTy arg_ty] res_ty -> + do { arg_tc_ty <- expTypeToType (scaledThing arg_ty) + ; res_tc_ty <- expTypeToType res_ty + + -- another nested arrow is too much for now, + -- but I bet we'll never need this + ; massertPpr (case arg_shape of + SynFun {} -> False; + _ -> True) + (text "Too many nested arrows in SyntaxOpType" $$ + pprCtOrigin orig) + + ; let arg_mult = scaledMult arg_ty + ; tcSynArgA orig op arg_tc_ty [] arg_shape $ + \ arg_results arg_res_mults -> + tcSynArgE orig op res_tc_ty res_shape $ + \ res_results res_res_mults -> + do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults) + ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }} + + ; let fun_wrap = mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper + (Scaled op_mult arg_ty) res_ty + -- NB: arg_ty comes from matchExpectedFunTys, so it has a + -- fixed RuntimeRep, as needed to call mkWpFun. + ; return (result, match_wrapper <.> fun_wrap) } + where + herald = ExpectedFunTySyntaxOp orig op + + go rho_ty (SynType the_ty) + = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty + ; result <- thing_inside [] [] + ; return (result, wrap) } + +-- works on "actual" types, instantiating where necessary +-- See Note [tcSynArg] +tcSynArgA :: CtOrigin + -> HsExpr GhcRn -- ^ the operator we are checking (for error messages) + -> TcSigmaType + -> [SyntaxOpType] -- ^ argument shapes + -> SyntaxOpType -- ^ result shape + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments + -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) + -- ^ returns a wrapper to be applied to the original function, + -- wrappers to be applied to arguments + -- and a wrapper to be applied to the overall expression +tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside + = do { (match_wrapper, arg_tys, res_ty) + <- matchActualFunTys herald orig (length arg_shapes) sigma_ty + -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) + ; ((result, res_wrapper), arg_wrappers) + <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults -> + tc_syn_arg res_ty res_shape $ \ res_results -> + thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) + ; return (result, match_wrapper, arg_wrappers, res_wrapper) } + where + herald = ExpectedFunTySyntaxOp orig op + + tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType] + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) + -> TcM (a, [HsWrapper]) + -- the wrappers are for arguments + tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside + = do { ((result, arg_wraps), arg_wrap) + <- tcSynArgE orig op arg_ty arg_shape $ \ arg1_results arg1_mults -> + tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults -> + thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults) + ; return (result, arg_wrap : arg_wraps) } + tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] [] + + tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType + -> ([TcSigmaTypeFRR] -> TcM a) + -> TcM (a, HsWrapper) + -- the wrapper applies to the overall result + tc_syn_arg res_ty SynAny thing_inside + = do { result <- thing_inside [res_ty] + ; return (result, idHsWrapper) } + tc_syn_arg res_ty SynRho thing_inside + = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty + -- inst_wrap :: res_ty "->" rho_ty + ; result <- thing_inside [rho_ty] + ; return (result, inst_wrap) } + tc_syn_arg res_ty SynList thing_inside + = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty + -- inst_wrap :: res_ty "->" rho_ty + ; (list_co, elt_ty) <- matchExpectedListTy rho_ty + -- list_co :: [elt_ty] ~N rho_ty + ; result <- thing_inside [elt_ty] + ; return (result, mkWpCastN (mkSymCo list_co) <.> inst_wrap) } + tc_syn_arg _ (SynFun {}) _ + = pprPanic "tcSynArgA hits a SynFun" (ppr orig) + tc_syn_arg res_ty (SynType the_ty) thing_inside + = do { wrap <- addSubTypeCtxt res_ty the_ty $ + tcSubType orig GenSigCtxt Nothing res_ty the_ty + ; result <- thing_inside [] + ; return (result, wrap) } + +{- +Note [Push result type in] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unify with expected result before type-checking the args so that the +info from res_ty percolates to args. This is when we might detect a +too-few args situation. (One can think of cases when the opposite +order would give a better error message.) +experimenting with putting this first. + +Here's an example where it actually makes a real difference + + class C t a b | t a -> b + instance C Char a Bool + + data P t a = forall b. (C t a b) => MkP b + data Q t = MkQ (forall a. P t a) + + f1, f2 :: Q Char; + f1 = MkQ (MkP True) + f2 = MkQ (MkP True :: forall a. P Char a) + +With the change, f1 will type-check, because the 'Char' info from +the signature is propagated into MkQ's argument. With the check +in the other order, the extra signature in f2 is reqd. +-} + +{- ********************************************************************* +* * + Expanding record update +* * +********************************************************************* -} + +{- Note [Record Updates] +~~~~~~~~~~~~~~~~~~~~~~~~ +To typecheck a record update, we expand it first. Suppose we have + data T p q = T1 { x :: Int, y :: Bool, z :: Char } + | T2 { v :: Char } + | T3 { x :: Int } + | T4 { p :: Float, y :: Bool, x :: Int } + | T5 +Then the record update `e { x=e1, y=e2 }` expands as follows + + e { x=e1, y=e2 } + ===> + let { x' = e1; y' = e2 } in + case e of + T1 _ _ z -> T1 x' y' z + T4 p _ _ -> T4 p y' x' +T2, T3 and T5 should not occur, so we omit them from the match. +The critical part of expansion is to identify T and then T1/T4. + +Wrinkle [Disambiguating fields] + + As explained in Note [Disambiguating record updates] in GHC.Rename.Pat, + to typecheck a record update we first need to disambiguate the field labels, + in order to find a parent which has at least one constructor with all of the fields + being updated. + + As mentioned in Note [Type-directed record disambiguation], we sometimes use + type-directed disambiguation, although this mechanism is deprecated and + scheduled for removal via the implementation of GHC proposal #366 + https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst. + + +All in all, this means that when typechecking a record update via expansion, +we take the following steps: + + (0) Perform a first typechecking pass on the record expression (`e` in the example above), + to infer the type of the record being updated. + (1) Disambiguate the record fields (potentially using the type obtained in (0)). + (2) Expand the record update as described above, using an XXExprGhcRn. + (a) Create a let-binding to share the record update right-hand sides. + (b) Expand the record update to a case expression updating all the + relevant constructors (those that have all of the fields being updated). + (3) Typecheck the expanded code. + +In (0), we call inferRho to infer the type of the record being updated. This returns the +inferred type of the record, together with a typechecked expression (of type HsExpr GhcTc) +and a collection of residual constraints. +We have no need for the latter two, because we will typecheck again in (D3). So, for +the time being (and until GHC proposal #366 is implemented), we simply drop them. + +Wrinkle [Using IdSig] + + As noted above, we want to let-bind the updated fields to avoid code duplication: + + let { x' = e1; y' = e2 } in + case e of + T1 _ _ z -> T1 x' y' z + T4 p _ _ -> T4 p y' x' + + However, doing so in a naive way would cause difficulties for type inference. + For example: + + data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } + foo r = r { f = \ k -> (k 3, k 'x') } + + If we expand to: + + ds_foo r = + let f' = \ k -> (k 3, k 'x') + in case r of + MkR _ b -> MkR f' b + + then we are unable to infer an appropriately polymorphic type for f', because we + never infer higher-rank types. To circumvent this problem, we proceed as follows: + + 1. Obtain general field types by instantiating any of the constructors + that contain all the necessary fields. (Note that the field type must be + identical across different constructors of a given data constructor). + 2. Let-bind an 'IdSig' with this type. This amounts to giving the let-bound + 'Id's a partial type signature. + + In the above example, it's as if we wrote: + + ds_foo r = + let f' :: (forall a. a -> a) -> (Int, _b) + f' = \ k -> (k 3, k 'x') + in case r of + MkR _ b -> MkR f' b + + This allows us to compute the right type for f', and thus accept this record update. + +Note [Type-directed record disambiguation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deprecation notice: + The type-directed disambiguation mechanism for record updates described in + this Note is deprecated, as per GHC proposal #366 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst). + The removal of type-directed disambiguation for record updates is tracked + in GHC ticket #19461, but progress towards this goal has stalled. + + Why? There are several suggested replacement mechanisms, such as: + 1. using module qualification to disambiguate, + 2. using OverloadedRecordUpdate for type-directed disambiguation + (as described in Note [Overview of record dot syntax] in GHC.Hs.Expr). + However, these solutions do not work in all situations: + 1. Module qualification doesn't work for fields defined in the current module, + nor to disambiguate between constructors of different data family instances + of a given parent data family TyCon. + 2. OverloadedRecordUpdate does not allow for type-changing record update, + nor can it deal with fields with existentials or polytypes. + There are also some avenues to improve the renamer's ability to disambiguate: + - GHC ticket #23032 suggests using as-patterns to disambiguate in the renamer. + - GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/537 + suggests a syntactic form of type-directed disambiguation that could be + carried out in the renamer. + Neither of these have been accepted/implemented at the time of writing (Sept 2025). + This means that removal of type-directed disambiguation is currently stalled. + +GHC tries to disambiguate record updates in the renamer, as described in +Note [Disambiguating record updates] in GHC.Rename.Pat. However, if the renamer +is unable to disambiguate, the renamer will defer to the typechecker: see +GHC.Tc.Gen.Expr.disambiguateRecordBinds, and in particular the auxiliary +function identifyParentLabels, which picks a parent for the record update +using the following additional mechanisms: + + (a) Use the type being pushed in, if it is already a TyConApp. The + following are valid updates at type `R`: + + g :: R -> R + g x = x { fld1 = 3 } + + g' x = x { fld1 = 3 } :: R + + (b) Use the type signature of the record expression, if it exists and + is a TyConApp. Thus this is valid update at type `R`: + + h x = (x :: R) { fld1 = 3 } + +Note that this type-directed disambiguation mechanism isn't very robust, +as it doesn't properly integrate with the rest of the typechecker. +For example, the following updates will all be rejected as ambiguous: + + let r :: R + r = blah + in r { foo = 3 } + + \r. (r { foo = 3 }, r :: R) + +Record updates which require constraint-solving should instead use the +-XOverloadedRecordUpdate extension, as described in Note [Overview of record dot syntax]. + +Note [Unifying result types in tcRecordUpd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After expanding and typechecking a record update in the way described in +Note [Record Updates], we must take care to unify the result types. + +Example: + + type family F (a :: Type) :: Type where {} + data D a = MkD { fld :: F a } + + f :: F Int -> D Bool -> D Int + f i r = r { fld = i } + +This record update expands to: + + let x :: F alpha -- metavariable + x = i + in case r of + MkD _ -> MkD x + +Because the type family F is not injective, our only hope for unifying the +metavariable alpha is through the result type of the record update, which tells +us that we should unify alpha := Int. + +Test case: T10808. + +Wrinkle [GADT result type in tcRecordUpd] + + When dealing with a GADT, we want to be careful about which result type we use. + + Example: + + data G a b where + MkG :: { bar :: F a } -> G a Int + + g :: F Int -> G Float b -> G Int b + g i r = r { bar = i } + + We **do not** want to use the result type from the constructor MkG, which would + leave us with a result type "G alpha Int". Instead, we should use the result type + from the GADT header, instantiating as above, to get "G alpha beta" which will get + unified withy "G Int b". + + Test cases: T18809, HardRecordUpdate. + +-} + +-- | Expands a record update @record_expr { fld1 = e1, fld2 = e2 }@ into a case expression +-- that matches on the constructors of the record @r@, as described in +-- Note [Record Updates]. +-- +-- Returns a renamed but not-yet-typechecked expression, together with the +-- result type of this expanded record update. +expandRecordUpd :: LHsExpr GhcRn + -- ^ @record_expr@: expression to which the record update is applied + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -- ^ Possible parent 'TyCon'/'PatSyn's for the record update, + -- with the associated constructors and field labels + -> [LHsRecUpdField GhcRn GhcRn] + -- ^ the record update fields + -> ExpRhoType + -- ^ the expected result type of the record update + -> TcM ( HsExpr GhcRn + -- Expanded record update expression + , TcType + -- result type of expanded record update + , ErrCtxtMsg + -- error context to push when typechecking + -- the expanded code + ) +expandRecordUpd record_expr possible_parents rbnds res_ty + = do { -- STEP 0: typecheck the record_expr, the record to be updated. + -- + -- Until GHC proposal #366 is implemented, we still use the type of + -- the record to disambiguate its fields, so we must infer the record + -- type here before we can expand. See Wrinkle [Disambiguating fields] + -- in Note [Record Updates]. + ; ((_, record_rho), _lie) <- captureConstraints $ -- see (1) below + tcScalingUsage ManyTy $ -- see (2) below + tcInferRho record_expr + + -- (1) + -- Note that we capture, and then discard, the constraints. + -- This `tcInferRho` is used *only* to identify the data type, + -- so we can deal with field disambiguation. + -- Then we are going to generate a expanded record update, including `record_expr`, + -- and typecheck it from scratch. We don't want to generate the constraints twice! + + -- (2) + -- Record update drops some of the content of the record (namely the + -- content of the field being updated). As a consequence, unless the + -- field being updated is unrestricted in the record, we need an + -- unrestricted record. Currently, we simply always require an + -- unrestricted record. + -- + -- Consider the following example: + -- + -- data R a = R { self :: a } + -- bad :: a ⊸ () + -- bad x = let r = R x in case r { self = () } of { R x' -> x' } + -- + -- This should definitely *not* typecheck. + + -- STEP 1: disambiguate the record update by computing a single parent + -- which has a constructor with all of the fields being updated. + -- + -- See Note [Disambiguating record updates] in GHC.Rename.Pat. + ; (cons, rbinds) + <- disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty + ; let sel_ids = map (unLoc . foLabel . unLoc . hfbLHS . unLoc) rbinds + upd_fld_names = map idName sel_ids + relevant_cons@(relevant_con NE.:| _) = + case NE.nonEmpty $ nonDetEltsUniqSet cons of + Just rel_cons -> rel_cons + Nothing -> pprPanic "desugarRecordUpd: no relevant constructors" $ + vcat [ text "record_expr:" <+> ppr record_expr ] + + -- STEP 2: expand the record update. + -- + -- (a) Create new variables for the fields we are updating, + -- so that we can share them across constructors. + -- + -- Example: + -- + -- e { x=e1, y=e2 } + -- + -- We want to let-bind variables to `e1` and `e2`: + -- + -- let x' :: Int + -- x' = e1 + -- y' :: Bool + -- y' = e2 + -- in ... + + -- Instantiate the type variables of any relevant constuctor + -- with metavariables to obtain a type for each 'Id'. + -- This will allow us to have 'Id's with polymorphic types + -- by using 'IdSig'. See Wrinkle [Using IdSig] in Note [Record Updates]. + ; let (univ_tvs, ex_tvs, eq_spec, _, _, arg_tys, con_res_ty) = conLikeFullSig relevant_con + ; (subst, tc_tvs) <- newMetaTyVars (univ_tvs ++ ex_tvs) + ; let (actual_univ_tys, _actual_ex_tys) = splitAtList univ_tvs $ map mkTyVarTy tc_tvs + + -- See Wrinkle [GADT result type in tcRecordUpd] + -- for an explanation of the following. + ds_res_ty = case relevant_con of + RealDataCon con + | not (null eq_spec) -- We only need to do this if we have actual GADT equalities. + -> mkFamilyTyConApp (dataConTyCon con) actual_univ_tys + _ -> substTy subst con_res_ty + + -- Gather pairs of let-bound Ids and their right-hand sides, + -- e.g. (x', e1), (y', e2), ... + ; let mk_upd_id :: Name -> LHsFieldBind GhcTc fld (LHsExpr GhcRn) -> TcM (Name, (TcId, LHsExpr GhcRn)) + mk_upd_id fld_nm (L _ rbind) + = do { let Scaled _ arg_ty = lookupNameEnv_NF arg_ty_env fld_nm + nm_occ = rdrNameOcc . nameRdrName $ fld_nm + actual_arg_ty = substTy subst arg_ty + rhs = hfbRHS rbind + ; (_co, actual_arg_ty) <- hasFixedRuntimeRep (FRRRecordUpdate fld_nm (unLoc rhs)) actual_arg_ty + -- We get a better error message by doing a (redundant) representation-polymorphism check here, + -- rather than delaying until the typechecker typechecks the let-bindings, + -- because the let-bound Ids have internal names. + -- (As we will typecheck the let-bindings later, we can drop this coercion here.) + -- See RepPolyRecordUpdate test. + ; nm <- newNameAt nm_occ generatedSrcSpan + ; let id = mkLocalId nm ManyTy actual_arg_ty + -- NB: create fresh names to avoid any accidental shadowing + -- occurring in the RHS expressions when creating the let bindings: + -- + -- let x1 = e1; x2 = e2; ... + -- + -- Above, we use multiplicity Many rather than the one associated to arg_ty. + -- Normally, there shouldn't be a difference, since it's a let binding. + -- But -XStrict can convert the let to a case, and this causes issues + -- in test LinearRecUpd. Since we don't support linear record updates, + -- using Many is simple and safe. + ; return (fld_nm, (id, rhs)) + } + arg_ty_env = mkNameEnv + $ zipWith (\ lbl arg_ty -> (flSelector lbl, arg_ty)) + (conLikeFieldLabels relevant_con) + arg_tys + + ; traceTc "tcRecordUpd" $ + vcat [ text "upd_fld_names:" <+> ppr upd_fld_names + , text "relevant_cons:" <+> ppr relevant_cons ] + + ; upd_ids <- zipWithM mk_upd_id upd_fld_names rbinds + ; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn) + updEnv = listToUniqMap $ upd_ids + + make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn) + -- As explained in Note [Record Updates], to expand + -- + -- e { x=e1, y=e2 } + -- + -- we generate a case statement, with an equation for + -- each constructor of the record. For example, for + -- the constructor + -- + -- T1 :: { x :: Int, y :: Bool, z :: Char } -> T p q + -- + -- we let-bind x' = e1, y' = e2 and generate the equation: + -- + -- T1 _ _ z -> T1 x' y' z + make_pat conLike = mkSimpleMatch RecUpd (noLocA [pat]) rhs + where + (lhs_con_pats, rhs_con_args) + = zipWithAndUnzip mk_con_arg [1..] con_fields + pat = genSimpleConPat con lhs_con_pats + rhs = wrapGenSpan $ genHsApps con rhs_con_args + con = conLikeName conLike + con_fields = conLikeFieldLabels conLike + + mk_con_arg :: Int + -> FieldLabel + -> ( LPat GhcRn + -- LHS constructor pattern argument + , LHsExpr GhcRn ) + -- RHS constructor argument + mk_con_arg i fld_lbl = + -- The following generates the pattern matches of the expanded `case` expression. + -- For fields being updated (for example `x`, `y` in T1 and T4 in Note [Record Updates]), + -- wildcards are used to avoid creating unused variables. + case lookupUniqMap updEnv $ flSelector fld_lbl of + -- Field is being updated: LHS = wildcard pattern, RHS = appropriate let-bound Id. + Just (upd_id, _) -> (genWildPat, genLHsVar (idName upd_id)) + -- Field is not being updated: LHS = variable pattern, RHS = that same variable. + _ -> let fld_nm = mkInternalName (mkBuiltinUnique i) + (nameOccName $ flSelector $ fld_lbl) + generatedSrcSpan + in (genVarPat fld_nm, genLHsVar fld_nm) + + -- STEP 2 (b): expand to HsCase, as per note [Record Updates] + ; let ds_expr :: HsExpr GhcRn + ds_expr = HsLet noExtField let_binds (L gen case_expr) + + case_expr :: HsExpr GhcRn + case_expr = HsCase RecUpd record_expr + $ mkMatchGroup (Generated OtherExpansion DoPmc) (wrapGenSpan matches) + matches :: [LMatch GhcRn (LHsExpr GhcRn)] + matches = map make_pat (NE.toList relevant_cons) + + let_binds :: HsLocalBindsLR GhcRn GhcRn + let_binds = HsValBinds noAnn $ XValBindsLR + $ NValBinds upd_ids_lhs (map mk_idSig upd_ids) + upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)] + upd_ids_lhs = [ (NonRecursive, [genSimpleFunBind (idName id) [] rhs]) + | (_, (id, rhs)) <- upd_ids ] + mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn + mk_idSig (_, (id, _)) = L gen $ XSig $ IdSig id + -- We let-bind variables using 'IdSig' in order to accept + -- record updates involving higher-rank types. + -- See Wrinkle [Using IdSig] in Note [Record Updates]. + gen = noAnnSrcSpan generatedSrcSpan + + ; traceTc "expandRecordUpd" $ + vcat [ text "relevant_con:" <+> ppr relevant_con + , text "res_ty:" <+> ppr res_ty + , text "ds_res_ty:" <+> ppr ds_res_ty + , text "ds_expr:" <+> ppr ds_expr + ] + + ; return (ds_expr, ds_res_ty, RecordUpdCtxt relevant_cons upd_fld_names ex_tvs) } + + + +{- ********************************************************************* +* * + Record bindings +* * +**********************************************************************-} + +-- | Disambiguate the fields in a record update. +-- +-- Most of the disambiguation has been done by the renamer; this function +-- performs a final type-directed disambiguation pass, as explained in +-- Note [Type-directed record disambiguation]. +disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> [LHsRecUpdField GhcRn GhcRn] -> ExpRhoType + -> TcM (UniqSet ConLike, [LHsRecUpdField GhcTc GhcRn]) +disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty + = do { fam_inst_envs <- tcGetFamInstEnvs + -- Identify a single parent, using type-directed disambiguation + -- if necessary. (Note that type-directed disambiguation of + -- record field updates is is scheduled for removal, as per + -- Note [Type-directed record disambiguation].) + ; TcRecUpdParent + { tcRecUpdLabels = lbls + , tcRecUpdCons = cons } + <- identifyParentLabels fam_inst_envs possible_parents + -- Pick the right selector with that parent for each field + ; rbnds' <- zipWithM lookupField (NE.toList lbls) rbnds + ; return (cons, rbnds') } + where + + -- Try to identify a single parent, using type-directed disambiguation. + -- + -- Any non-type-directed disambiguation will have been done already. + -- See GHC.Rename.Env.lookupRecUpdFields. + identifyParentLabels :: FamInstEnvs + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> TcM (HsRecUpdParent GhcTc) + identifyParentLabels fam_inst_envs possible_parents + = case possible_parents of + + -- Exactly one possible parent for the record update! + p NE.:| [] -> lookup_parent_flds p + + -- Multiple possible parents: try harder to disambiguate. + -- Can we get a parent TyCon from the pushed-in type? + -- + -- See (a) in Note [Type-directed record disambiguation] in GHC.Rename.Pat. + _ NE.:| _ : _ + | Just tc <- tyConOfET fam_inst_envs res_ty + -> do { reportAmbiguousUpdate possible_parents tc + ; try_disambiguated_tycon tc possible_parents } + + -- Does the expression being updated have a type signature? + -- If so, try to extract a parent TyCon from it. + -- + -- See (b) inNote [Type-directed record disambiguation] in GHC.Rename.Pat. + | Just {} <- obviousSig (unLoc record_expr) + , Just tc <- tyConOf fam_inst_envs record_rho + -> do { reportAmbiguousUpdate possible_parents tc + ; try_disambiguated_tycon tc possible_parents } + + -- Nothing else we can try... + p1 NE.:| p2 : ps + -> do { p1 <- tcLookupRecSelParent p1 + ; p2 <- tcLookupRecSelParent p2 + ; ps <- mapM tcLookupRecSelParent ps + ; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds) + $ MultiplePossibleParents (p1, p2, ps) } + + -- Try to use the 'TyCon' we learned from type-directed disambiguation. + -- This might not work, if it doesn't match up with any of the parents we had + -- computed on the basis of the field labels. + -- (See test cases overloadedrecfields01 and T21946.) + try_disambiguated_tycon :: TyCon + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> TcM (HsRecUpdParent GhcTc) + try_disambiguated_tycon tc pars + = do { pars <- mapMaybeM (fmap (guard_parent tc) . lookup_parent_flds) (NE.toList pars) + ; case pars of + [par] -> return par + [] -> do { pars <- mapM tcLookupRecSelParent possible_parents + ; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds) + $ InvalidTyConParent tc pars } + _ -> pprPanic "try_disambiguated_tycon: more than 1 valid parent" + (ppr $ map tcRecUpdParent pars) } + + guard_parent :: TyCon -> HsRecUpdParent GhcTc -> Maybe (HsRecUpdParent GhcTc) + guard_parent disamb_tc cand_parent@(TcRecUpdParent { tcRecUpdParent = cand_tc }) + = do { guard (RecSelData disamb_tc == cand_tc) + ; return cand_parent } + + lookup_parent_flds :: HsRecUpdParent GhcRn + -> TcM (HsRecUpdParent GhcTc) + lookup_parent_flds par@(RnRecUpdParent { rnRecUpdLabels = lbls, rnRecUpdCons = cons }) + = do { let cons' :: NonDetUniqFM ConLike ConLikeName + cons' = NonDetUniqFM $ unsafeCastUFMKey $ getUniqSet cons + lookup_one con = tcLookupConLike (noUserRdr $ getName con) + ; cons <- traverse lookup_one cons' + ; tc <- tcLookupRecSelParent par + ; return $ + TcRecUpdParent + { tcRecUpdParent = tc + , tcRecUpdLabels = lbls + , tcRecUpdCons = unsafeUFMToUniqSet $ getNonDet cons } } + + lookupField :: FieldGlobalRdrElt + -> LHsRecUpdField GhcRn GhcRn + -> TcM (LHsRecUpdField GhcTc GhcRn) + lookupField fld_gre (L l upd) + = do { let L loc af = hfbLHS upd + lbl = fieldOccRdrName af + mb_gre = pickGREs lbl [fld_gre] + -- NB: this GRE can be 'Nothing' when in GHCi. + -- See test T10439. + + -- Mark the record fields as used, now that we have disambiguated. + -- There is no risk of duplicate deprecation warnings, as we have + -- not marked the GREs as used previously. + ; setSrcSpanA loc $ mapM_ (addUsedGRE AllDeprecationWarnings) mb_gre + ; sel <- tcLookupId (greName fld_gre) + ; return $ L l HsFieldBind + { hfbAnn = hfbAnn upd + , hfbLHS = L (l2l loc) (FieldOcc lbl (L (l2l loc) sel)) + , hfbRHS = hfbRHS upd + , hfbPun = hfbPun upd + } } + + -- The type-directed disambiguation mechanism is scheduled for removal, + -- as per Note [Type-directed record disambiguation]. + -- So we emit a warning whenever the user relies on it. + reportAmbiguousUpdate :: NE.NonEmpty (HsRecUpdParent GhcRn) + -> TyCon -> TcM () + reportAmbiguousUpdate parents parent_type = + setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousRecordUpdate rupd parent_type + where + rupd = RecordUpd { rupd_expr = record_expr + , rupd_flds = + RegularRecUpdFields + { xRecUpdFields = parents + , recUpdFields = rbnds } + , rupd_ext = noExtField } + loc = getLocA (head rbnds) + +{- +Game plan for record bindings +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Find the TyCon for the bindings, from the first field label. + +2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. + +For each binding field = value + +3. Instantiate the field type (from the field label) using the type + envt from step 2. + +4 Type check the value using tcCheckPolyExprNC (in tcRecordField), + passing the field type as the expected argument type. + +This extends OK when the field types are universally quantified. +-} + +tcRecordBinds + :: ConLike + -> [Scaled TcType] -- Expected type for each field + -> HsRecordBinds GhcRn + -> TcM (HsRecordBinds GhcTc) + +tcRecordBinds con_like arg_tys (HsRecFields x rbinds dd) + = do { mb_binds <- mapM do_bind rbinds + ; return (HsRecFields x (catMaybes mb_binds) dd) } + where + fields = map flSelector $ conLikeFieldLabels con_like + flds_w_tys = zipEqual fields arg_tys + + do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) + -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc))) + do_bind (L l fld@(HsFieldBind { hfbLHS = f + , hfbRHS = rhs })) + + = do { mb <- tcRecordField con_like flds_w_tys f rhs + ; case mb of + Nothing -> return Nothing + Just (f', rhs') -> return (Just (L l (HsFieldBind + { hfbAnn = hfbAnn fld + , hfbLHS = f' + , hfbRHS = rhs' + , hfbPun = hfbPun fld}))) } + +tcRecordField :: ConLike -> Assoc Name (Scaled Type) + -> LFieldOcc GhcRn -> LHsExpr GhcRn + -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) +tcRecordField con_like flds_w_tys (L loc (FieldOcc rdr (L l sel_name))) rhs + | Just (Scaled field_mult field_ty) <- assocMaybe flds_w_tys sel_name + = addErrCtxt (FieldCtxt field_lbl)$ + do { rhs' <- tcScalingUsage field_mult $ tcCheckPolyExprNC rhs field_ty + ; hasFixedRuntimeRep_syntactic (FRRRecordCon rdr (unLoc rhs')) + field_ty + ; let field_id = mkUserLocal (nameOccName sel_name) + (nameUnique sel_name) + field_mult 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 expansion knows the type of local binder to make) + ; return (Just (L loc (FieldOcc rdr (L l field_id)), rhs')) } + | otherwise + = do { addErrTc (badFieldConErr (getName con_like) field_lbl) + ; return Nothing } + where + field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc rdr + + +checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM () +checkMissingFields con_like rbinds arg_tys + | null field_labels -- Not declared as a record; + -- But C{} is still valid if no strict fields + = if any isBanged field_strs then + -- Illegal if any arg is strict + addErrTc (TcRnMissingStrictFields con_like []) + else do + when (notNull field_strs && null field_labels) $ do + let msg = TcRnMissingFields con_like [] + (diagnosticTc True msg) + + | otherwise = do -- A record + unless (null missing_s_fields) $ do + fs <- liftZonkM $ zonk_fields missing_s_fields + -- It is an error to omit a strict field, because + -- we can't substitute it with (error "Missing field f") + addErrTc (TcRnMissingStrictFields con_like fs) + + warn <- woptM Opt_WarnMissingFields + when (warn && notNull missing_ns_fields) $ do + fs <- liftZonkM $ zonk_fields missing_ns_fields + -- It is not an error (though we may want) to omit a + -- lazy field, because we can always use + -- (error "Missing field f") instead. + let msg = TcRnMissingFields con_like fs + diagnosticTc True msg + + where + -- we zonk the fields to get better types in error messages (#18869) + zonk_fields fs = forM fs $ \(str,ty) -> do + ty' <- zonkTcType ty + return (str,ty') + missing_s_fields + = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, + isBanged str, + not (fl `elemField` field_names_used) + ] + missing_ns_fields + = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, + not (isBanged str), + not (fl `elemField` field_names_used) + ] + + field_names_used = hsRecFields rbinds + field_labels = conLikeFieldLabels con_like + + field_info = zip3 field_labels field_strs arg_tys + + field_strs = conLikeImplBangs con_like + + fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds + +{- +************************************************************************ +* * +\subsection{Static Pointers} +* * +************************************************************************ +-} + +-- | Checks if the given name is closed and emits an error if not. +-- +-- See Note [Not-closed error messages]. +checkClosedInStaticForm :: Name -> TcM () +checkClosedInStaticForm name = do + type_env <- getLclTypeEnv + case checkClosed type_env name of + Nothing -> return () + Just reason -> addErrTc $ explain name reason + where + -- See Note [Checking closedness]. + checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason + checkClosed type_env n = checkLoop type_env (unitNameSet n) n + + checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason + checkLoop type_env visited n = + -- The @visited@ set is an accumulating parameter that contains the set of + -- visited nodes, so we avoid repeating cycles in the traversal. + case lookupNameEnv type_env n of + Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of + ClosedLet -> Nothing + NotLetBound -> Just NotLetBoundReason + NonClosedLet fvs type_closed -> listToMaybe $ + -- Look for a non-closed variable in fvs + [ NotClosed n' reason + | n' <- nameSetElemsStable fvs + , not (elemNameSet n' visited) + , Just reason <- [checkLoop type_env (extendNameSet visited n') n'] + ] ++ + if type_closed then + [] + else + -- We consider non-let-bound variables easier to figure out than + -- non-closed types, so we report non-closed types to the user + -- only if we cannot spot the former. + [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ] + -- The binding is closed. + _ -> Nothing + + -- Converts a reason into a human-readable sentence. + -- + -- @explain name reason@ starts with + -- + -- " is used in a static form but it is not closed because it" + -- + -- and then follows a list of causes. For each id in the path, the text + -- + -- "uses which" + -- + -- is appended, yielding something like + -- + -- "uses which uses which uses which" + -- + -- until the end of the path is reached, which is reported as either + -- + -- "is not let-bound" + -- + -- when the final node is not let-bound, or + -- + -- "has a non-closed type because it contains the type variables: + -- v1, v2, v3" + -- + -- when the final node has a non-closed type. + -- + explain :: Name -> NotClosedReason -> TcRnMessage + explain = TcRnStaticFormNotClosed + +-- Note [Not-closed error messages] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- When variables in a static form are not closed, we go through the trouble +-- of explaining why they aren't. +-- +-- Thus, the following program +-- +-- > {-# LANGUAGE StaticPointers #-} +-- > module M where +-- > +-- > f x = static g +-- > where +-- > g = h +-- > h = x +-- +-- produces the error +-- +-- 'g' is used in a static form but it is not closed because it +-- uses 'h' which uses 'x' which is not let-bound. +-- +-- And a program like +-- +-- > {-# LANGUAGE StaticPointers #-} +-- > module M where +-- > +-- > import Data.Typeable +-- > import GHC.StaticPtr +-- > +-- > f :: Typeable a => a -> StaticPtr TypeRep +-- > f x = const (static (g undefined)) (h x) +-- > where +-- > g = h +-- > h = typeOf +-- +-- produces the error +-- +-- 'g' is used in a static form but it is not closed because it +-- uses 'h' which has a non-closed type because it contains the +-- type variables: 'a' +-- + +-- Note [Checking closedness] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- @checkClosed@ checks if a binding is closed and returns a reason if it is +-- not. +-- +-- The bindings define a graph where the nodes are ids, and there is an edge +-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free +-- variables. +-- +-- When @n@ is not closed, it has to exist in the graph some node reachable +-- from @n@ that it is not a let-bound variable or that it has a non-closed +-- type. Thus, the "reason" is a path from @n@ to this offending node. +-- +-- When @n@ is not closed, we traverse the graph reachable from @n@ to build +-- the reason. +-- diff --git a/GHC/Tc/Gen/Expr.hs-boot b/GHC/Tc/Gen/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Expr.hs-boot @@ -0,0 +1,50 @@ +module GHC.Tc.Gen.Expr where +import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn + , SyntaxExprTc ) +import GHC.Tc.Utils.TcType ( TcType, TcRhoType, TcSigmaType, TcSigmaTypeFRR + , SyntaxOpType, InferInstFlag + , ExpType, ExpRhoType, ExpSigmaType ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.BasicTypes( TcCompleteSig ) +import GHC.Tc.Types.Origin ( CtOrigin ) +import GHC.Core.Type ( Mult ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) + +tcCheckPolyExpr, tcCheckPolyExprNC :: + LHsExpr GhcRn + -> TcSigmaType + -> TcM (LHsExpr GhcTc) + +tcMonoExpr, tcMonoExprNC :: + LHsExpr GhcRn + -> ExpRhoType + -> TcM (LHsExpr GhcTc) +tcCheckMonoExpr, tcCheckMonoExprNC :: + LHsExpr GhcRn + -> TcRhoType + -> TcM (LHsExpr GhcTc) + +tcPolyLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) +tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc) + +tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) +tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) + +tcInferRho, tcInferRhoNC :: + LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) + +tcInferExpr :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) + +tcSyntaxOp :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] -- ^ shape of syntax operator arguments + -> ExpType -- ^ overall result type + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ Type check any arguments + -> TcM (a, SyntaxExprTc) + +tcSyntaxOpGen :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] + -> SyntaxOpType + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) + -> TcM (a, SyntaxExprTc) diff --git a/GHC/Tc/Gen/Foreign.hs b/GHC/Tc/Gen/Foreign.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Foreign.hs @@ -0,0 +1,790 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + +-} + + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Typechecking @foreign@ declarations +-- +-- A foreign declaration is used to either give an externally +-- implemented function a Haskell type (and calling interface) or +-- give a Haskell function an external calling interface. Either way, +-- the range of argument and result types these functions can accommodate +-- is restricted to what the outside world understands (read C), and this +-- module checks to see if a foreign declaration has got a legal type. +module GHC.Tc.Gen.Foreign + ( tcForeignImports + , tcForeignExports + + -- Low-level exports for hooks + , isForeignImport, isForeignExport + , tcFImport, tcFExport + , tcForeignImports' + , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes + , normaliseFfiType + , nonIOok, mustBeIO + , checkSafe, noCheckSafe + , tcForeignExports' + , tcCheckFEType + ) where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType +import GHC.Tc.Instance.Family + +import GHC.Core.FamInstEnv +import GHC.Core.Coercion +import GHC.Core.Reduction +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCon.RecWalk + +import GHC.Types.ForeignCall +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc + +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim( isArrowTyCon ) + +import GHC.Driver.Session +import GHC.Driver.Backend + +import GHC.Utils.Error +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Unique +import GHC.Platform + +import GHC.Data.Bag +import GHC.Driver.Hooks +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad ( when, zipWithM ) +import Control.Monad.Trans.Writer.CPS + ( WriterT, runWriterT, tell ) +import Control.Monad.Trans.Class + ( lift ) +import Data.Maybe (isJust) +import GHC.Builtin.Types (unitTyCon) +import GHC.Types.RepType (typePrimRep1) + +-- Defines a binding +isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool +isForeignImport (unXRec @name -> ForeignImport {}) = True +isForeignImport _ = False + +-- Exports a binding +isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool +isForeignExport (unXRec @name -> ForeignExport {}) = True +isForeignExport _ = False + +{- +Note [Don't recur in normaliseFfiType'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +normaliseFfiType' is the workhorse for normalising a type used in a foreign +declaration. If we have + +newtype Age = MkAge Int + +we want to see that Age -> IO () is the same as Int -> IO (). But, we don't +need to recur on any type parameters, because no parameterized types (with +interesting parameters) are marshalable! The full list of marshalable types +is in the body of boxedMarshalableTyCon in GHC.Tc.Utils.TcType. The only members of that +list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled +the same way regardless of type parameter. So, no need to recur into +parameters. + +Similarly, we don't need to look in AppTy's, because nothing headed by +an AppTy will be marshalable. +-} + +-- normaliseFfiType takes the type from an FFI declaration, and +-- evaluates any type synonyms, type functions, and newtypes. However, +-- we are only allowed to look through newtypes if the constructor is +-- in scope. We return a bag of all the newtype constructors thus found. +-- Always returns a Representational coercion +normaliseFfiType :: Type -> TcM (Reduction, Bag GlobalRdrElt) +normaliseFfiType ty + = do fam_envs <- tcGetFamInstEnvs + normaliseFfiType' fam_envs ty + +normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt) +normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0 + where + go :: Role -> RecTcChecker -> Type -> WriterT (Bag GlobalRdrElt) TcM Reduction + go role rec_nts ty + | Just ty' <- coreView ty -- Expand synonyms + = go role rec_nts ty' + + | Just (tc, tys) <- splitTyConApp_maybe ty + = go_tc_app role rec_nts tc tys + + | (bndrs, inner_ty) <- splitForAllForAllTyBinders ty + , not (null bndrs) + = do redn <- go role rec_nts inner_ty + return $ mkHomoForAllRedn bndrs redn + + | otherwise -- see Note [Don't recur in normaliseFfiType'] + = return $ mkReflRedn role ty + + go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type] + -> WriterT (Bag GlobalRdrElt) TcM Reduction + go_tc_app role rec_nts tc tys + | isArrowTyCon tc -- Recurse through arrows, or at least the top + = children_only -- level arrows. Remember, the default case is + -- "don't recurse" (see last eqn for go_tc_app) + + | tc_key `elem` [ioTyConKey, funPtrTyConKey] + -- We don't want to look through the IO newtype, even if it is + -- in scope, so we have a special case for it: + = children_only + + | isNewTyCon tc -- Expand newtypes + , Just rec_nts' <- checkRecTc rec_nts tc + -- See Note [Expanding newtypes and products] in GHC.Core.TyCon.RecWalk + -- We can't just use isRecursiveTyCon; sometimes recursion is ok: + -- newtype T = T (Ptr T) + -- Here, we don't reject the type for being recursive. + -- If this is a recursive newtype then it will normally + -- be rejected later as not being a valid FFI type. + = do { rdr_env <- lift $ getGlobalRdrEnv + ; case checkNewtypeFFI rdr_env tc of + Nothing -> nothing + Just gre -> + do { redn <- go role rec_nts' nt_rhs + ; tell (unitBag gre) + ; return $ nt_co `mkTransRedn` redn } } + + | isFamilyTyCon tc -- Expand open tycons + , Reduction co ty <- normaliseTcApp env role tc tys + , not (isReflexiveCo co) + = do redn <- go role rec_nts ty + return $ co `mkTransRedn` redn + + | otherwise + = nothing -- see Note [Don't recur in normaliseFfiType'] + where + tc_key = getUnique tc + children_only + = do { args <- unzipRedns <$> + zipWithM ( \ ty r -> go r rec_nts ty ) + tys (tyConRoleListX role tc) + ; return $ mkTyConAppRedn role tc args } + nt_co = mkUnbranchedAxInstCo role (newTyConCo tc) tys [] + nt_rhs = newTyConInstRhs tc tys + + ty = mkTyConApp tc tys + nothing = return $ mkReflRedn role ty + +checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt +checkNewtypeFFI rdr_env tc + | Just con <- tyConSingleDataCon_maybe tc + , Just gre <- lookupGRE_Name rdr_env (dataConName con) + = Just gre -- See Note [Newtype constructor usage in foreign declarations] + | otherwise + = Nothing + +{- +Note [Newtype constructor usage in foreign declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC automatically "unwraps" newtype constructors in foreign import/export +declarations. In effect that means that a newtype data constructor is +used even though it is not mentioned expclitly in the source, so we don't +want to report it as "defined but not used" or "imported but not used". +eg newtype D = MkD Int + foreign import foo :: D -> IO () +Here 'MkD' is used. See #7408. + +GHC also expands type functions during this process, so it's not enough +just to look at the free variables of the declaration. +eg type instance F Bool = D + foreign import bar :: F Bool -> IO () +Here again 'MkD' is used. + +So we really have wait until the type checker to decide what is used. +That's why tcForeignImports and tecForeignExports return a (Bag GRE) +for the newtype constructors they see. Then GHC.Tc.Module can add them +to the module's usages. + + +************************************************************************ +* * +\subsection{Imports} +* * +************************************************************************ +-} + +tcForeignImports :: [LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) +tcForeignImports decls = do + hooks <- getHooks + case tcForeignImportsHook hooks of + Nothing -> tcForeignImports' decls + Just h -> h decls + +tcForeignImports' :: [LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) +-- For the (Bag GlobalRdrElt) result, +-- see Note [Newtype constructor usage in foreign declarations] +tcForeignImports' decls + = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $ + filter isForeignImport decls + ; return (ids, decls, unionManyBags gres) } + +tcFImport :: LForeignDecl GhcRn + -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) +tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty + , fd_fi = imp_decl })) + = setSrcSpanA dloc $ addErrCtxt (ForeignDeclCtxt fo) $ + do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty + ; let + -- Drop the foralls before inspecting the + -- structure of the foreign type. + -- Use splitFunTys, which splits (=>) as well as (->) + -- so that for foreign import foo :: Eq a => a -> blah + -- we get "unacceptable argument Eq a" rather than + -- "unacceptable result Eq a => a -> blah" + -- Not a big deal. We could make a better error message specially + -- for overloaded functions, but doesn't seem worth it + (arg_tys, res_ty) = splitFunTys (dropForAlls norm_sig_ty) + + id = mkLocalId nm ManyTy sig_ty + -- Use a LocalId to obey the invariant that locally-defined + -- things are LocalIds. However, it does not need zonking, + -- (so GHC.Tc.Zonk.Type.zonkForeignExports ignores it). + + ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl + -- Can't use sig_ty here because sig_ty :: Type and + -- we need HsType Id hence the undefined + ; let fi_decl = ForeignImport { fd_name = L nloc id + , fd_sig_ty = undefined + , fd_i_ext = mkSymCo norm_co + , fd_fi = imp_decl' } + ; return (id, L dloc fi_decl, gres) } +tcFImport d = pprPanic "tcFImport" (ppr d) + +-- ------------ Checking types for foreign import ---------------------- + +tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport GhcRn -> TcM (ForeignImport GhcTc) + +tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh l@(CLabel _)) + -- Foreign import label + = do checkCg (Right idecl) backendValidityOfCImport + -- NB check res_ty not sig_ty! + -- In case sig_ty is (forall a. ForeignPtr a) + check (isFFILabelTy (mkScaledFunTys arg_tys res_ty)) + (TcRnIllegalForeignType Nothing) + cconv' <- checkCConv (Right idecl) cconv + return (CImport src (L lc cconv') safety mh l) + +tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh CWrapper) = do + -- Foreign wrapper (former foreign export dynamic) + -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid + -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. + -- The use of the latter form is DEPRECATED, though. + checkCg (Right idecl) backendValidityOfCImport + cconv' <- checkCConv (Right idecl) cconv + case arg_tys of + [Scaled arg1_mult arg1_ty] -> do + checkNoLinearFFI arg1_mult + checkForeignArgs isFFIExternalTy arg1_tys + checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty + checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty + where + (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty + _ -> addErrTc (TcRnIllegalForeignType Nothing OneArgExpected) + return (CImport src (L lc cconv') safety mh CWrapper) + +tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh + (CFunction target)) + | isDynamicTarget target = do -- Foreign import dynamic + checkCg (Right idecl) backendValidityOfCImport + cconv' <- checkCConv (Right idecl) cconv + case arg_tys of -- The first arg must be Ptr or FunPtr + [] -> + addErrTc (TcRnIllegalForeignType Nothing AtLeastOneArgExpected) + (Scaled arg1_mult arg1_ty:arg_tys) -> do + dflags <- getDynFlags + let curried_res_ty = mkScaledFunTys arg_tys res_ty + checkNoLinearFFI arg1_mult + check (isFFIDynTy curried_res_ty arg1_ty) + (TcRnIllegalForeignType (Just Arg)) + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys + checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty + return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target) + | cconv == PrimCallConv = do + dflags <- getDynFlags + checkTc (xopt LangExt.GHCForeignImportPrim dflags) + (TcRnForeignImportPrimExtNotSet idecl) + checkCg (Right idecl) backendValidityOfCImport + checkCTarget idecl target + checkTc (playSafe safety) + (TcRnForeignImportPrimSafeAnn idecl) + checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys + -- prim import result is more liberal, allows (#,,#) + checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty + return (CImport src (L lc cconv) (L ls safety) mh (CFunction target)) + | cconv == JavaScriptCallConv = do + cconv' <- checkCConv (Right idecl) cconv + checkCg (Right idecl) backendValidityOfCImport + -- leave the rest to the JS backend (at least for now) + return (CImport src (L lc cconv') (L ls safety) mh (CFunction target)) + | otherwise = do -- Normal foreign import + checkCg (Right idecl) backendValidityOfCImport + cconv' <- checkCConv (Right idecl) cconv + checkCTarget idecl target + dflags <- getDynFlags + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys + checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty + checkMissingAmpersand idecl target (map scaledThing arg_tys) res_ty + case target of + StaticTarget _ _ _ False + | not (null arg_tys) -> + addErrTc (TcRnForeignFunctionImportAsValue idecl) + _ -> return () + return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target) + +-- This makes a convenient place to check +-- that the C identifier is valid for C +checkCTarget :: ForeignImport GhcRn -> CCallTarget -> TcM () +checkCTarget idecl (StaticTarget _ str _ _) = do + checkCg (Right idecl) backendValidityOfCImport + checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) + +checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget" + +checkMissingAmpersand :: ForeignImport GhcRn -> CCallTarget -> [Type] -> Type -> TcM () +checkMissingAmpersand _ (StaticTarget _ _ _ False) _ _ = return () + +checkMissingAmpersand idecl _ arg_tys res_ty + | null arg_tys && isFunPtrTy res_ty + = addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl + | otherwise + = return () + +{- +************************************************************************ +* * +\subsection{Exports} +* * +************************************************************************ +-} + +tcForeignExports :: [LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt) +tcForeignExports decls = do + hooks <- getHooks + case tcForeignExportsHook hooks of + Nothing -> tcForeignExports' decls + Just h -> h decls + +tcForeignExports' :: [LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt) +-- For the (Bag GlobalRdrElt) result, +-- see Note [Newtype constructor usage in foreign declarations] +tcForeignExports' decls + = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) + where + combine (binds, fs, gres1) (L loc fe) = do + (b, f, gres2) <- setSrcSpanA loc (tcFExport fe) + return (b : binds, L loc f : fs, gres1 `unionBags` gres2) + +tcFExport :: ForeignDecl GhcRn + -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt) +tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec }) + = addErrCtxt (ForeignDeclCtxt fo) $ do + + sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty + + (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty + + spec' <- tcCheckFEType norm_sig_ty spec + + -- we're exporting a function, but at a type possibly more + -- constrained than its declared/inferred type. Hence the need + -- to create a local binding which will call the exported function + -- at a particular type (and, maybe, overloading). + + + -- We need to give a name to the new top-level binding that + -- is *stable* (i.e. the compiler won't change it later), + -- because this name will be referred to by the C code stub. + id <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc + return ( mkVarBind id rhs + , ForeignExport { fd_name = L loc id + , fd_sig_ty = undefined + , fd_e_ext = norm_co + , fd_fe = spec' } + , gres) +tcFExport d = pprPanic "tcFExport" (ppr d) + +-- ------------ Checking argument types for foreign export ---------------------- + +tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc) +tcCheckFEType sig_ty edecl@(CExport src (L l (CExportStatic esrc str cconv))) = do + checkCg (Left edecl) backendValidityOfCExport + when (cconv /= JavaScriptCallConv) $ checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) + cconv' <- checkCConv (Left edecl) cconv + checkForeignArgs isFFIExternalTy arg_tys + checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty + return (CExport src (L l (CExportStatic esrc str cconv'))) + where + -- Drop the foralls before inspecting + -- the structure of the foreign type. + (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty) + +{- +************************************************************************ +* * +\subsection{Miscellaneous} +* * +************************************************************************ +-} + +------------ Checking argument types for foreign import ---------------------- +checkForeignArgs :: (Type -> Validity' IllegalForeignTypeReason) -> [Scaled Type] -> TcM () +checkForeignArgs _pred [(Scaled mult ty)] + -- If there is a single argument allow: + -- foo :: (# #) -> T + | isUnboxedTupleType ty + , VoidRep <- typePrimRep1 ty + = do + checkNoLinearFFI mult + dflags <- getDynFlags + case (validIfUnliftedFFITypes dflags) of + IsValid -> checkNoLinearFFI mult + NotValid needs_uffi -> addErrTc $ + TcRnIllegalForeignType + (Just Arg) + (TypeCannotBeMarshaled ty needs_uffi) + -- = check (validIfUnliftedFFITypes dflags) (TypeCannotBeMarshaled (Just Arg)) >> checkNoLinearFFI mult +checkForeignArgs pred tys = mapM_ go tys + where + go (Scaled mult ty) = checkNoLinearFFI mult >> + check (pred ty) (TcRnIllegalForeignType (Just Arg)) + +checkNoLinearFFI :: Mult -> TcM () -- No linear types in FFI (#18472) +checkNoLinearFFI ManyTy = return () +checkNoLinearFFI _ = addErrTc $ TcRnIllegalForeignType (Just Arg) + LinearTypesNotAllowed + +------------ Checking result types for foreign calls ---------------------- +-- | Check that the type has the form +-- (IO t) or (t) , and that t satisfies the given predicate. +-- When calling this function, any newtype wrappers (should) have been +-- already dealt with by normaliseFfiType. +-- +-- We also check that the Safe Haskell condition of FFI imports having +-- results in the IO monad holds. +-- +checkForeignRes :: Bool -> Bool -> (Type -> Validity' IllegalForeignTypeReason) -> Type -> TcM () +checkForeignRes non_io_result_ok check_safe pred_res_ty ty + | Just (_, res_ty) <- tcSplitIOType_maybe ty + = -- Got an IO result type, that's always fine! + check (pred_res_ty res_ty) + (TcRnIllegalForeignType (Just Result)) + + -- We disallow nested foralls in foreign types + -- (at least, for the time being). See #16702. + | isForAllTy ty + = addErrTc $ TcRnIllegalForeignType (Just Result) UnexpectedNestedForall + + -- Case for non-IO result type with FFI Import + | not non_io_result_ok + = addErrTc $ TcRnIllegalForeignType (Just Result) IOResultExpected + + | otherwise + = do { dflags <- getDynFlags + ; case pred_res_ty ty of + -- Handle normal typecheck fail, we want to handle this first and + -- only report safe haskell errors if the normal type check is OK. + NotValid msg -> addErrTc $ TcRnIllegalForeignType (Just Result) msg + + -- handle safe infer fail + _ | check_safe && safeInferOn dflags + -> recordUnsafeInfer emptyMessages + + -- handle safe language typecheck fail + _ | check_safe && safeLanguageOn dflags + -> addErrTc (TcRnIllegalForeignType (Just Result) SafeHaskellMustBeInIO) + + -- success! non-IO return is fine + _ -> return () } + +nonIOok, mustBeIO :: Bool +nonIOok = True +mustBeIO = False + +checkSafe, noCheckSafe :: Bool +checkSafe = True +noCheckSafe = False + +checkCg :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> (Backend -> Validity' ExpectedBackends) -> TcM () +checkCg decl check = do + dflags <- getDynFlags + let bcknd = backend dflags + case check bcknd of + IsValid -> return () + NotValid expectedBcknds -> + addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknds + +-- Calling conventions + +checkCConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> CCallConv -> TcM CCallConv +checkCConv _ CCallConv = return CCallConv +checkCConv _ CApiConv = return CApiConv +checkCConv decl StdCallConv = do + -- 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) `elem` [ ArchJavaScript, ArchWasm32 ] + then return JavaScriptCallConv + else do + addErrTc $ TcRnUnsupportedCallConv decl JavaScriptCallConvUnsupported + return JavaScriptCallConv + +-- Warnings + +check :: Validity' IllegalForeignTypeReason + -> (IllegalForeignTypeReason -> TcRnMessage) + -> TcM () +check IsValid _ = return () +check (NotValid reason) mkMessage = addErrTc (mkMessage reason) + +{- Predicates on Types used in this module -} + +-- | Reason why a type in an FFI signature is invalid + +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason +-- Checks for valid argument type for a 'foreign import' +isFFIArgumentTy dflags safety ty + = checkRepTyCon (legalOutgoingTyCon dflags safety) ty + +isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason +-- Types that are allowed as arguments of a 'foreign export' +isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty + +isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason +isFFIImportResultTy dflags ty + = checkRepTyCon (legalFIResultTyCon dflags) ty + +isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason +isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty + +isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason +-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of +-- either, and the wrapped function type must be equal to the given type. +-- We assume that all types have been run through normaliseFfiType, so we don't +-- need to worry about expanding newtypes here. +isFFIDynTy expected ty + -- Note [Foreign import dynamic] + -- In the example below, expected would be 'CInt -> IO ()', while ty would + -- be 'FunPtr (CDouble -> IO ())'. + | Just (tc, [ty']) <- splitTyConApp_maybe ty + , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] + , eqType ty' expected + = IsValid + | otherwise + = NotValid (ForeignDynNotPtr expected ty) + +isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason +-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. +isFFILabelTy ty = checkRepTyCon ok ty + where + ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey + = IsValid + | otherwise + = NotValid ForeignLabelNotAPtr + +-- | Check validity for a type of the form @Any :: k@. +-- +-- This function returns: +-- +-- - @Just IsValid@ for @Any :: Type@ and @Any :: UnliftedType@, +-- - @Just (NotValid ..)@ for @Any :: k@ if @k@ is not a kind of boxed types, +-- - @Nothing@ if the type is not @Any@. +checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason) +checkAnyTy ty + | Just ki <- anyTy_maybe ty + = Just $ + if isJust $ kindBoxedRepLevity_maybe ki + then IsValid + -- NB: don't allow things like @Any :: TYPE IntRep@, as per #21305. + else NotValid (TypeCannotBeMarshaled ty NotBoxedKindAny) + | otherwise + = Nothing + +isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason +-- Checks for valid argument type for a 'foreign import prim' +-- Currently they must all be simple unlifted types, or Any (at kind Type or UnliftedType), +-- which can be used to pass the address to a Haskell object on the heap to +-- the foreign function. +isFFIPrimArgumentTy dflags ty + | Just validity <- checkAnyTy ty + = validity + | otherwise + = checkRepTyCon (legalFIPrimArgTyCon dflags) ty + +isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason +-- Checks for valid result type for a 'foreign import prim' Currently +-- it must be an unlifted type, including unboxed tuples, unboxed +-- sums, or the well-known type Any (at kind Type or UnliftedType). +isFFIPrimResultTy dflags ty + | Just validity <- checkAnyTy ty + = validity + | otherwise + = checkRepTyCon (legalFIPrimResultTyCon dflags) ty + +isFunPtrTy :: Type -> Bool +isFunPtrTy ty + | Just (tc, [_]) <- splitTyConApp_maybe ty + = tc `hasKey` funPtrTyConKey + | otherwise + = False + +-- normaliseFfiType gets run before checkRepTyCon, so we don't +-- need to worry about looking through newtypes or type functions +-- here; that's already been taken care of. +checkRepTyCon + :: (TyCon -> Validity' TypeCannotBeMarshaledReason) + -> Type + -> Validity' IllegalForeignTypeReason +checkRepTyCon check_tc ty + = fmap (TypeCannotBeMarshaled ty) $ case splitTyConApp_maybe ty of + Just (tc, tys) + | isNewTyCon tc -> NotValid (mk_nt_reason tc tys) + | otherwise -> check_tc tc + Nothing -> NotValid NotADataType + where + mk_nt_reason tc tys = NewtypeDataConNotInScope tc tys + +{- +Note [Foreign import dynamic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign +type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. + +We use isFFIDynTy to check whether a signature is well-formed. For example, +given a (illegal) declaration like: + +foreign import ccall "dynamic" + foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () + +isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried +result type 'CInt -> IO ()', and return False, as they are not equal. + + +---------------------------------------------- +These chaps do the work; they are not exported +---------------------------------------------- +-} + +legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason +legalFEArgTyCon tc + -- It's illegal to make foreign exports that take unboxed + -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 + = boxedMarshalableTyCon tc + +legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +legalFIResultTyCon dflags tc + | tc == unitTyCon = IsValid + | otherwise = marshalableTyCon dflags tc + +legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason +legalFEResultTyCon tc + | tc == unitTyCon = IsValid + | otherwise = boxedMarshalableTyCon tc + +legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason +-- Checks validity of types going from Haskell -> external world +legalOutgoingTyCon dflags _ tc + = marshalableTyCon dflags tc + +-- Check for marshalability of a primitive type. +-- We exclude lifted types such as RealWorld and TYPE. +-- They can technically appear in types, e.g. +-- f :: RealWorld -> TYPE LiftedRep -> RealWorld +-- f x _ = x +-- but there are no values of type RealWorld or TYPE LiftedRep, +-- so it doesn't make sense to use them in FFI. +marshalablePrimTyCon :: TyCon -> Bool +marshalablePrimTyCon tc = isPrimTyCon tc && not (isLiftedTypeKind (tyConResKind tc)) + +marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +marshalableTyCon dflags tc + | marshalablePrimTyCon tc + = validIfUnliftedFFITypes dflags + | otherwise + = boxedMarshalableTyCon tc + +boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason +boxedMarshalableTyCon tc + | anyOfUnique tc [ intTyConKey, int8TyConKey, int16TyConKey + , int32TyConKey, int64TyConKey + , wordTyConKey, word8TyConKey, word16TyConKey + , word32TyConKey, word64TyConKey + , floatTyConKey, doubleTyConKey + , ptrTyConKey, funPtrTyConKey + , charTyConKey + , stablePtrTyConKey + , boolTyConKey + , jsvalTyConKey + ] + = IsValid + + | otherwise = NotValid NotABoxedMarshalableTyCon + +legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +-- Check args of 'foreign import prim', only allow simple unlifted types. +legalFIPrimArgTyCon dflags tc + | marshalablePrimTyCon tc + = validIfUnliftedFFITypes dflags + | otherwise + = NotValid NotSimpleUnliftedType + +legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +-- Check result type of 'foreign import prim'. Allow simple unlifted +-- types and also unboxed tuple and sum result types. +legalFIPrimResultTyCon dflags tc + | marshalablePrimTyCon tc + = validIfUnliftedFFITypes dflags + + | isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc + = validIfUnliftedFFITypes dflags + + | otherwise + = NotValid $ NotSimpleUnliftedType + +validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason +validIfUnliftedFFITypes dflags + | xopt LangExt.UnliftedFFITypes dflags = IsValid + | otherwise = NotValid UnliftedFFITypesNeeded diff --git a/GHC/Tc/Gen/Head.hs b/GHC/Tc/Gen/Head.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Head.hs @@ -0,0 +1,1224 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DisambiguateRecordFields #-} + +{- +% +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Tc.Gen.Head + ( HsExprArg(..), TcPass(..), QLFlag(..), EWrap(..) + , AppCtxt(..), appCtxtLoc, insideExpansion + , splitHsApps, rebuildHsApps + , addArgWrap, isHsValArg + , leadingValArgs, isVisibleArg + + , tcInferAppHead, tcInferAppHead_maybe + , tcInferId, tcCheckId, tcInferConLike, obviousSig + , tyConOf, tyConOfET + , nonBidirectionalErr + + , pprArgInst + , addHeadCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig ) +import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody ) + +import GHC.Prelude +import GHC.Hs +import GHC.Hs.Syn.Type + +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Bind( chooseInferredQuantifiers ) +import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig ) +import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) +import GHC.Tc.Errors.Types +import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint( WantedConstraints ) +import GHC.Tc.Utils.TcType as TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Zonk.TcType + + +import GHC.Core.FamInstEnv ( FamInstEnvs ) +import GHC.Core.UsageEnv ( singleUsageUE, UsageEnv ) +import GHC.Core.PatSyn( PatSyn, patSynName ) +import GHC.Core.ConLike( ConLike(..) ) +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type + +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Error + +import GHC.Builtin.Types( multiplicityTy ) +import GHC.Builtin.Names + +import GHC.Driver.DynFlags +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic + +import GHC.Data.Maybe + + + +{- ********************************************************************* +* * + HsExprArg: auxiliary data type +* * +********************************************************************* -} + +{- Note [HsExprArg] +~~~~~~~~~~~~~~~~~~~ +The data type HsExprArg :: TcPass -> Type +is a very local type, used only within this module and GHC.Tc.Gen.App + +* It's really a zipper for an application chain + See Note [Application chains and heads] in GHC.Tc.Gen.App for + what an "application chain" is. + +* It's a GHC-specific type, so using TTG only where necessary + +* It is indexed by TcPass, meaning + - HsExprArg TcpRn: + The result of splitHsApps, which decomposes a HsExpr GhcRn + + - HsExprArg TcpInst: + The result of tcInstFun, which instantiates the function type, + perhaps taking a quick look at arguments. + + - HsExprArg TcpTc: + The result of tcArg, which typechecks the value args + In EValArg we now have a (LHsExpr GhcTc) + +* rebuildPrefixApps is dual to splitHsApps, and zips an application + back into a HsExpr + +Invariants: + +1. With QL switched off, all arguments are ValArg; no ValArgQL + +2. With QL switched on, tcInstFun converts some ValArgs to ValArgQL, + under the conditions when quick-look should happen (eg the argument + type is guarded) -- see quickLookArg + +Note [EValArgQL] +~~~~~~~~~~~~~~~~ +Data constructor EValArgQL represents an argument that has been +partly-type-checked by Quick Look: the first part of `tcApp` has been +done, but not the second, `finishApp` part. + +The constuctor captures all the bits and pieces needed to complete +typechecking. (An alternative would to to store a function closure, +but that's less concrete.) See Note [Quick Look at value arguments] +in GHC.Tc.Gen.App + +Note [splitHsApps] +~~~~~~~~~~~~~~~~~~ +The key function + splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, HsExpr GhcRn, [HsExprArg 'TcpRn]) +takes apart either an HsApp, or an infix OpApp, returning + +* The "head" of the application, an expression that is often a variable; + this is used for typechecking + +* The "user head" or "error head" of the application, to be reported to the + user in case of an error. Example: + (`op` e) + expands (via ExpandedThingRn) to + (rightSection op e) + but we don't want to see 'rightSection' in error messages. So we keep the + innermost un-expanded head as the "error head". + +* A list of HsExprArg, the arguments +-} + +data TcPass = TcpRn -- Arguments decomposed + | TcpInst -- Function instantiated + | TcpTc -- Typechecked + +data HsExprArg (p :: TcPass) where -- See Note [HsExprArg] + + -- Data constructor EValArg represents a value argument + EValArg :: { ea_ctxt :: AppCtxt + , ea_arg_ty :: !(XEVAType p) + , ea_arg :: LHsExpr (GhcPass (XPass p)) } + -> HsExprArg p + + -- Data constructor EValArgQL represents an argument that has been + -- partly-type-checked by Quick Look; see Note [EValArgQL] + EValArgQL :: { eaql_ctxt :: AppCtxt + , eaql_arg_ty :: Scaled TcSigmaType -- Argument type expected by function + , eaql_larg :: LHsExpr GhcRn -- Original application, for + -- location and error msgs + , eaql_tc_fun :: (HsExpr GhcTc, AppCtxt) -- Typechecked head + , eaql_fun_ue :: UsageEnv -- Usage environment of the typechecked head (QLA5) + , eaql_args :: [HsExprArg 'TcpInst] -- Args: instantiated, not typechecked + , eaql_wanted :: WantedConstraints + , eaql_encl :: Bool -- True <=> we have already qlUnified + -- eaql_arg_ty and eaql_res_rho + , eaql_res_rho :: TcRhoType } -- Result type of the application + -> HsExprArg 'TcpInst -- Only exists in TcpInst phase + + ETypeArg :: { ea_ctxt :: AppCtxt + , ea_hs_ty :: LHsWcType GhcRn -- The type arg + , ea_ty_arg :: !(XETAType p) } -- Kind-checked type arg + -> HsExprArg p + + EPrag :: AppCtxt -> (HsPragE (GhcPass (XPass p))) -> HsExprArg p + EWrap :: EWrap -> HsExprArg p + +type family XETAType (p :: TcPass) where -- Type arguments + XETAType 'TcpRn = NoExtField + XETAType _ = Type + +type family XEVAType (p :: TcPass) where -- Value arguments + XEVAType 'TcpInst = Scaled TcSigmaType + XEVAType _ = NoExtField + +data QLFlag = DoQL | NoQL + +data EWrap = EPar AppCtxt + | EExpand HsThingRn + | EHsWrap HsWrapper + +data AppCtxt + = VAExpansion + HsThingRn + SrcSpan + SrcSpan + + | VACall + (HsExpr GhcRn) Int -- In the third argument of function f + SrcSpan -- The SrcSpan of the application (f e1 e2 e3) + -- noSrcSpan if outermost; see Note [AppCtxt] + + +{- Note [AppCtxt] +~~~~~~~~~~~~~~~~~ +In a call (f e1 ... en), we pair up each argument with an AppCtxt. For +example, the AppCtxt for e3 allows us to say + "In the third argument of `f`" +See splitHsApps. + +To do this we must take a quick look into the expression to find the +function at the head (`f` in this case) and how many arguments it +has. That is what the funcion top_ctxt does. + +If the function part is an expansion, we don't want to look further. +For example, with rebindable syntax the expression + (if e1 then e2 else e3) e4 e5 +might expand to + (ifThenElse e1 e2 e3) e4 e5 +For e4 we an AppCtxt that says "In the first argument of (if ...)", +not "In the fourth argument of ifThenElse". So top_ctxt stops +at expansions. + +The SrcSpan in an AppCtxt describes the whole call. We initialise +it to noSrcSpan, because splitHsApps deals in HsExpr not LHsExpr, so +we don't have a span for the whole call; and we use that noSrcSpan in +GHC.Tc.Gen.App.tcInstFun (set_fun_ctxt) to avoid pushing "In the expression `f`" +a second time. +-} + +appCtxtLoc :: AppCtxt -> SrcSpan +appCtxtLoc (VAExpansion _ l _) = l +appCtxtLoc (VACall _ _ l) = l + +insideExpansion :: AppCtxt -> Bool +insideExpansion (VAExpansion {}) = True +insideExpansion (VACall {}) = False -- but what if the VACall has a generated context? + +instance Outputable QLFlag where + ppr DoQL = text "DoQL" + ppr NoQL = text "NoQL" + +instance Outputable AppCtxt where + ppr (VAExpansion e l _) = text "VAExpansion" <+> ppr e <+> ppr l + ppr (VACall f n l) = text "VACall" <+> int n <+> ppr f <+> ppr l + +type family XPass (p :: TcPass) where + XPass 'TcpRn = 'Renamed + XPass 'TcpInst = 'Renamed + XPass 'TcpTc = 'Typechecked + +mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn +mkEValArg ctxt e = EValArg { ea_arg = e, ea_ctxt = ctxt + , ea_arg_ty = noExtField } + +mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn +mkETypeArg ctxt hs_ty = + ETypeArg { ea_ctxt = ctxt + , ea_hs_ty = hs_ty + , ea_ty_arg = noExtField } + +addArgWrap :: HsWrapper -> [HsExprArg p] -> [HsExprArg p] +addArgWrap wrap args + | isIdHsWrapper wrap = args + | otherwise = EWrap (EHsWrap wrap) : args + +splitHsApps :: HsExpr GhcRn + -> TcM ( (HsExpr GhcRn, AppCtxt) -- Head + , [HsExprArg 'TcpRn]) -- Args +-- See Note [splitHsApps]. +-- +-- This uses the TcM monad solely because we must run modFinalizers when looking +-- through HsUntypedSplices +-- (see Note [Looking through Template Haskell splices in splitHsApps]). +splitHsApps e = go e (top_ctxt 0 e) [] + where + top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt + -- Always returns VACall fun n_val_args noSrcSpan + -- to initialise the argument splitting in 'go' + -- See Note [AppCtxt] + top_ctxt n (HsPar _ fun) = top_lctxt n fun + top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun + top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun + top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun + top_ctxt n (XExpr (ExpandedThingRn o _)) + | OrigExpr fun <- o = VACall fun n noSrcSpan + top_ctxt n other_fun = VACall other_fun n noSrcSpan + + top_lctxt n (L _ fun) = top_ctxt n fun + + go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn] + -> TcM ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn]) + -- Modify the AppCtxt as we walk inwards, so it describes the next argument + go (HsPar _ (L l fun)) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args) + go (HsPragE _ p (L l fun)) ctxt args = go fun (set l ctxt) (EPrag ctxt p : args) + go (HsAppType _ (L l fun) 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) + + -- See Note [Looking through Template Haskell splices in splitHsApps] + go e@(HsUntypedSplice splice_res splice) ctxt args + = do { fun <- getUntypedSpliceBody splice_res + ; go fun ctxt' (EWrap (EExpand (OrigExpr e)) : args) } + where + ctxt' :: AppCtxt + ctxt' = case splice of + HsUntypedSpliceExpr _ (L l _) -> set l ctxt -- l :: SrcAnn AnnListItem + HsQuasiQuote _ _ (L l _) -> set l ctxt -- l :: SrcAnn NoEpAnns + (XUntypedSplice (HsImplicitLiftSplice _ _ _ (L l _))) -> set l ctxt + + -- See Note [Looking through ExpandedThingRn] + go (XExpr (ExpandedThingRn o e)) ctxt args + | isHsThingRnExpr o + = go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt)) + (EWrap (EExpand o) : args) + + | OrigStmt (L _ stmt) <- o -- so that we set `(>>)` as generated + , BodyStmt{} <- stmt -- and get the right unused bind warnings + = go e (VAExpansion o generatedSrcSpan generatedSrcSpan) + -- See Part 3. in Note [Expanding HsDo with XXExprGhcRn] + (EWrap (EExpand o) : args) -- in `GHC.Tc.Gen.Do` + + + | OrigPat (L loc _) <- o -- so that we set the compiler generated fail context + = go e (VAExpansion o (locA loc) (locA loc)) -- to be originating from a failable pattern + -- See Part 1. Wrinkle 2. of + (EWrap (EExpand o) : args) -- Note [Expanding HsDo with XXExprGhcRn] + -- in `GHC.Tc.Gen.Do` + + | otherwise + = go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt)) + (EWrap (EExpand o) : args) + + -- See Note [Desugar OpApp in the typechecker] + go e@(OpApp _ arg1 (L l op) arg2) _ args + = pure ( (op, VACall op 0 (locA l)) + , mkEValArg (VACall op 1 generatedSrcSpan) arg1 + : mkEValArg (VACall op 2 generatedSrcSpan) arg2 + -- generatedSrcSpan because this the span of the call, + -- and its hard to say exactly what that is + : EWrap (EExpand (OrigExpr e)) + : args ) + + go e ctxt args = pure ((e,ctxt), args) + + set :: EpAnn ann -> AppCtxt -> AppCtxt + set l (VACall f n _) = VACall f n (locA l) + set l (VAExpansion orig ol _) = VAExpansion orig ol (locA l) + + dec :: EpAnn ann -> AppCtxt -> AppCtxt + dec l (VACall f n _) = VACall f (n-1) (locA l) + dec l (VAExpansion orig ol _) = VAExpansion orig ol (locA l) + +-- | Rebuild an application: takes a type-checked application head +-- expression together with arguments in the form of typechecked 'HsExprArg's +-- and returns a typechecked application of the head to the arguments. +-- +-- This performs a representation-polymorphism check to ensure that +-- representation-polymorphic unlifted newtypes have been eta-expanded. +-- +-- See Note [Eta-expanding rep-poly unlifted newtypes]. +rebuildHsApps :: (HsExpr GhcTc, AppCtxt) + -- ^ the function being applied + -> [HsExprArg 'TcpTc] + -- ^ the arguments to the function + -> HsExpr GhcTc +rebuildHsApps (fun, _) [] = fun +rebuildHsApps (fun, ctxt) (arg : args) + = case arg of + EValArg { ea_arg = arg, ea_ctxt = ctxt' } + -> rebuildHsApps (HsApp noExtField lfun arg, ctxt') args + ETypeArg { ea_hs_ty = hs_ty, ea_ty_arg = ty, ea_ctxt = ctxt' } + -> rebuildHsApps (HsAppType ty lfun hs_ty, ctxt') args + EPrag ctxt' p + -> rebuildHsApps (HsPragE noExtField p lfun, ctxt') args + EWrap (EPar ctxt') + -> rebuildHsApps (gHsPar lfun, ctxt') args + EWrap (EExpand orig) + | OrigExpr oe <- orig + -> rebuildHsApps (mkExpandedExprTc oe fun, ctxt) args + | otherwise + -> rebuildHsApps (fun, ctxt) args + EWrap (EHsWrap wrap) + -> rebuildHsApps (mkHsWrap wrap fun, ctxt) args + where + lfun = L (noAnnSrcSpan $ appCtxtLoc' ctxt) fun + appCtxtLoc' (VAExpansion _ _ l) = l + appCtxtLoc' v = appCtxtLoc v + + +isHsValArg :: HsExprArg id -> Bool +isHsValArg (EValArg {}) = True +isHsValArg _ = False + +leadingValArgs :: [HsExprArg 'TcpRn] -> [LHsExpr GhcRn] +leadingValArgs [] = [] +leadingValArgs (EValArg { ea_arg = arg } : args) = arg : leadingValArgs args +leadingValArgs (EWrap {} : args) = leadingValArgs args +leadingValArgs (EPrag {} : args) = leadingValArgs args +leadingValArgs (ETypeArg {} : _) = [] + +isValArg :: HsExprArg id -> Bool +isValArg (EValArg {}) = True +isValArg _ = False + +isVisibleArg :: HsExprArg id -> Bool +isVisibleArg (EValArg {}) = True +isVisibleArg (ETypeArg {}) = True +isVisibleArg _ = False + +instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where + ppr (EPrag _ p) = text "EPrag" <+> ppr p + ppr (ETypeArg { ea_hs_ty = hs_ty }) = char '@' <> ppr hs_ty + ppr (EWrap wrap) = ppr wrap + ppr (EValArg { ea_arg = arg, ea_ctxt = ctxt }) + = text "EValArg" <> braces (ppr ctxt) <+> ppr arg + ppr (EValArgQL { eaql_tc_fun = fun, eaql_args = args, eaql_res_rho = ty}) + = hang (text "EValArgQL" <+> ppr fun) + 2 (vcat [ ppr args, text "ea_ql_ty:" <+> ppr ty ]) + +pprArgInst :: HsExprArg 'TcpInst -> SDoc +-- Ugh! A special version for 'TcpInst, se we can print the arg_ty of EValArg +pprArgInst (EPrag _ p) = text "EPrag" <+> ppr p +pprArgInst (ETypeArg { ea_hs_ty = hs_ty }) = char '@' <> ppr hs_ty +pprArgInst (EWrap wrap) = ppr wrap +pprArgInst (EValArg { ea_arg = arg, ea_arg_ty = ty }) + = hang (text "EValArg" <+> ppr arg) + 2 (text "arg_ty" <+> ppr ty) +pprArgInst (EValArgQL { eaql_tc_fun = fun, eaql_args = args, eaql_res_rho = ty}) + = hang (text "EValArgQL" <+> ppr fun) + 2 (vcat [ vcat (map pprArgInst args), text "ea_ql_ty:" <+> ppr ty ]) + +instance Outputable EWrap where + ppr (EPar _) = text "EPar" + ppr (EHsWrap w) = text "EHsWrap" <+> ppr w + ppr (EExpand orig) = text "EExpand" <+> ppr orig + +{- Note [Desugar OpApp in the typechecker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Operator sections are desugared in the renamer; see GHC.Rename.Expr +Note [Handling overloaded and rebindable constructs]. +But for reasons explained there, we rename OpApp to OpApp. Then, +here in the typechecker, we desugar it to a use of ExpandedThingRn. +That makes it possible to typecheck something like + e1 `f` e2 +where + f :: forall a. t1 -> forall b. t2 -> t3 + +Note [Looking through ExpandedThingRn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When creating an application chain in splitHsApps, we must deal with + ExpandedThingRn f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3 + +as a single application chain `f e1 e2 e3`. Otherwise stuff like overloaded +labels (#19154) won't work. + +It's easy to achieve this: `splitHsApps` unwraps `ExpandedThingRn`. + +In order to be able to more accurately reconstruct the original `SrcSpan`s +from the renamer in `rebuildHsApps`, we also have to track the `SrcSpan` +of the current application in `VAExpansion` when unwrapping `ExpandedThingRn` +in `splitHsApps`, just as we track it in a non-expanded expression. + +Previously, `rebuildHsApps` substituted the location of the original +expression as given by `splitHsApps` for this. As a result, the application +head in expanded expressions, e.g. the call to `fromListN`, would either +have `noSrcSpan` set as its location post-typecheck, or get the location +of the original expression, depending on whether the `XExpr` given to +`splitHsApps` is in the outermost layer. The span it got in the renamer +would always be discarded, causing #23120. + +Note [Looking through Template Haskell splices in splitHsApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking an application, we must look through untyped TH splices in +order to typecheck examples like the one in #21077: + + data Foo = MkFoo () (forall a. a -> a) + + foo :: Foo + foo = $([| MkFoo () |]) $ \x -> x + +In principle, this is straightforward to accomplish. By the time we typecheck +`foo`, the renamer will have already run the splice, so all we have to do is +look at the expanded version of the splice in `splitHsApps`. See the +`HsUntypedSplice` case in `splitHsApps` for how this is accomplished. + +There is one slight complication in that untyped TH splices also include +modFinalizers (see Note [Delaying modFinalizers in untyped splices] in +GHC.Rename.Splice), which must be run during typechecking. splitHsApps is a +convenient place to run the modFinalizers, so we do so there. This is the only +reason that `splitHsApps` uses the TcM monad. + +`HsUntypedSplice` covers both ordinary TH splices, such as the example above, +as well as quasiquotes (see Note [Quasi-quote overview] in +Language.Haskell.Syntax.Expr). The `splitHsApps` case for `HsUntypedSplice` +handles both of these. This is easy to accomplish, since all the real work in +handling splices and quasiquotes has already been performed by the renamer by +the time we get to `splitHsApps`. + +Wrinkle (UTS1): + `tcExpr` has a separate case for `HsUntypedSplice`s that do /not/ occur at the + head of an application. This is important to handle programs like this one: + + foo :: (forall a. a -> a) -> b -> b + foo = $([| \g x -> g x |]) + + Here, it is vital that we push the expected type inwards so that `g` gets the + type `forall a. a -> a`, and the `tcExpr` case for `HsUntypedSplice` performs + this pushing. Without it, we would instead infer `g` to have type `b -> b`, + which isn't sufficiently general. Unfortunately, this does mean that there are + two different places in the code where an `HsUntypedSplice`'s modFinalizers can + be ran, depending on whether the splice appears at the head of an application + or not. +-} + +{- ********************************************************************* +* * + tcInferAppHead +* * +********************************************************************* -} + +tcInferAppHead :: (HsExpr GhcRn, AppCtxt) + -> TcM (HsExpr GhcTc, TcSigmaType) +-- Infer type of the head of an application +-- i.e. the 'f' in (f e1 ... en) +-- See Note [Application chains and heads] in GHC.Tc.Gen.App +-- We get back a /SigmaType/ because we have special cases for +-- * A bare identifier (just look it up) +-- This case also covers a record selector HsRecSel +-- * An expression with a type signature (e :: ty) +-- See Note [Application chains and heads] in GHC.Tc.Gen.App +-- +-- Note that [] and (,,) are both HsVar: +-- see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr +-- +-- NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those +-- cases are dealt with by splitHsApps. +-- +-- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App +tcInferAppHead (fun,ctxt) + = addHeadCtxt ctxt $ + do { mb_tc_fun <- tcInferAppHead_maybe fun + ; case mb_tc_fun of + Just (fun', fun_sigma) -> return (fun', fun_sigma) + Nothing -> runInferRho (tcExpr fun) } + +tcInferAppHead_maybe :: HsExpr GhcRn + -> 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 + = case fun of + HsVar _ nm -> Just <$> tcInferId nm + XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f + ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty + HsOverLit _ lit -> Just <$> tcInferOverLit lit + _ -> return Nothing + +addHeadCtxt :: AppCtxt -> TcM a -> TcM a +addHeadCtxt (VAExpansion (OrigStmt (L loc stmt)) _ _) thing_inside = + do setSrcSpanA loc $ + addStmtCtxt stmt + thing_inside +addHeadCtxt fun_ctxt thing_inside + | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments + = thing_inside -- => context is already set + | otherwise + = setSrcSpan fun_loc $ + do case fun_ctxt of + VAExpansion (OrigExpr orig) _ _ -> addExprCtxt orig thing_inside + _ -> thing_inside + where + fun_loc = appCtxtLoc fun_ctxt + + +{- ********************************************************************* +* * + Record selectors +* * +********************************************************************* -} + +tcInferRecSelId :: FieldOcc GhcRn + -> TcM ( (HsExpr GhcTc, TcSigmaType)) +tcInferRecSelId (FieldOcc lbl (L l sel_name)) + = do { sel_id <- tc_rec_sel_id + ; let expr = XExpr (HsRecSelTc (FieldOcc lbl (L l sel_id))) + ; return $ (expr, idType sel_id) + } + where + occ :: OccName + occ = nameOccName sel_name + tc_rec_sel_id :: TcM TcId + -- Like tc_infer_id, but returns an Id not a HsExpr, + -- so we can wrap it back up into a HsRecSel + tc_rec_sel_id + = do { thing <- tcLookup sel_name + ; case thing of + ATcId { tct_id = id } + -> do { check_naughty occ id -- See Note [Local record selectors] + ; check_local_id id + ; return id } + + AGlobal (AnId id) + -> do { check_naughty occ id + ; return id } + -- A global cannot possibly be ill-staged + -- nor does it need the 'lifting' treatment + -- hence no checkTh stuff here + + _ -> failWithTc $ TcRnExpectedValueId thing } + +------------------------ + +-- A type signature on the argument of an ambiguous record selector or +-- the record expression in an update must be "obvious", i.e. the +-- outermost constructor ignoring parentheses. +obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) +obviousSig (ExprWithTySig _ _ ty) = Just ty +obviousSig (HsPar _ p) = obviousSig (unLoc p) +obviousSig (HsPragE _ _ p) = obviousSig (unLoc p) +obviousSig _ = Nothing + +-- Extract the outermost TyCon of a type, if there is one; for +-- data families this is the representation tycon (because that's +-- where the fields live). +tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon +tyConOf fam_inst_envs ty0 + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) + Nothing -> Nothing + where + (_, _, ty) = tcSplitSigmaTy ty0 + +-- Variant of tyConOf that works for ExpTypes +tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon +tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 + +{- ********************************************************************* +* * + Expressions with a type signature + expr :: type +* * +********************************************************************* -} + +tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn) + -> TcM (HsExpr GhcTc, TcSigmaType) +tcExprWithSig expr hs_ty + = do { sig_info <- checkNoErrs $ -- Avoid error cascade + tcUserTypeSig loc hs_ty Nothing + ; (expr', poly_ty) <- tcExprSig expr sig_info + ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) } + where + loc = getLocA (dropWildCards hs_ty) + +tcExprSig :: LHsExpr GhcRn -> TcIdSig -> TcM (LHsExpr GhcTc, TcSigmaType) +tcExprSig expr (TcCompleteSig sig) + = do { expr' <- tcPolyLExprSig expr sig + ; return (expr', idType (sig_bndr sig)) } + +tcExprSig expr sig@(TcPartialSig (PSig { psig_name = name, psig_loc = loc })) + = setSrcSpan loc $ -- Sets the location for the implication constraint + do { (tclvl, wanted, (expr', sig_inst)) + <- pushLevelAndCaptureConstraints $ + do { sig_inst <- tcInstSig sig + ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $ + tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ + tcCheckPolyExprNC expr (sig_inst_tau sig_inst) + ; return (expr', sig_inst) } + -- See Note [Partial expression signatures] + ; let tau = sig_inst_tau sig_inst + infer_mode | null (sig_inst_theta sig_inst) + , isNothing (sig_inst_wcx sig_inst) + = ApplyMR + | otherwise + = NoRestrictions + ; ((qtvs, givens, ev_binds, _), residual) + <- captureConstraints $ + simplifyInfer NotTopLevel tclvl infer_mode [sig_inst] [(name, tau)] wanted + ; emitConstraints residual + + ; tau <- liftZonkM $ zonkTcType tau + ; let inferred_theta = map evVarPred givens + tau_tvs = tyCoVarsOfType tau + ; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta + tau_tvs qtvs (Just sig_inst) + ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau + my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau) + ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. + then return idHsWrapper -- Fast path; also avoids complaint when we infer + -- an ambiguous type and have AllowAmbiguousType + -- e..g infer x :: forall a. F a -> Int + else tcSubTypeSigma ExprSigOrigin (ExprSigCtxt NoRRC) inferred_sigma my_sigma + + ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) + ; let poly_wrap = wrap + <.> mkWpTyLams qtvs + <.> mkWpEvLams givens + <.> mkWpLet ev_binds + ; return (mkLHsWrap poly_wrap expr', my_sigma) } + + +{- Note [Partial expression signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Partial type signatures on expressions are easy to get wrong. But +here is a guiding principle + e :: ty +should behave like + let x :: ty + x = e + in x + +So for partial signatures we apply the MR if no context is given. So + e :: IO _ apply the MR + e :: _ => IO _ do not apply the MR +just like in GHC.Tc.Gen.Bind.decideGeneralisationPlan + +This makes a difference (#11670): + peek :: Ptr a -> IO CLong + peek ptr = peekElemOff undefined 0 :: _ +from (peekElemOff undefined 0) we get + type: IO w + constraints: Storable w + +We must NOT try to generalise over 'w' because the signature specifies +no constraints so we'll complain about not being able to solve +Storable w. Instead, don't generalise; then _ gets instantiated to +CLong, as it should. +-} + + +{- ********************************************************************* +* * + Overloaded literals +* * +********************************************************************* -} + +tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) +tcInferOverLit lit@(OverLit { ol_val = val + , ol_ext = OverLitRn { ol_rebindable = rebindable + , ol_from_fun = L loc from_name } }) + = -- Desugar "3" to (fromInteger (3 :: Integer)) + -- where fromInteger is gotten by looking up from_name, and + -- the (3 :: Integer) is returned by mkOverLit + -- Ditto the string literal "foo" to (fromString ("foo" :: String)) + -- + -- See Note [Typechecking overloaded literals] in GHC.Tc.Gen.Expr + 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 noExtField hs_lit) + ; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty + + ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) + -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast + ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $ + HsLit noExtField hs_lit + from_expr = mkHsWrap (wrap2 <.> wrap1) $ + mkHsVar (L loc from_id) + witness = HsApp noExtField (L (l2l loc) from_expr) lit_expr + lit' = OverLit { ol_val = val + , ol_ext = OverLitTc { ol_rebindable = rebindable + , ol_witness = witness + , ol_type = res_ty } } + ; return (HsOverLit noExtField lit', res_ty) } + +{- ********************************************************************* +* * + tcInferId, tcCheckId +* * +********************************************************************* -} + +tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc) +tcCheckId name res_ty + = do { (expr, actual_res_ty) <- tcInferId (noLocA $ noUserRdr name) + ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) + ; addFunResCtxt expr [] actual_res_ty res_ty $ + tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty } + where + rn_fun = mkHsVar (noLocA name) + +------------------------ +tcInferId :: LocatedN (WithUserRdr Name) -> TcM (HsExpr GhcTc, TcSigmaType) +-- Look up an occurrence of an Id +-- Do not instantiate its type +tcInferId lname@(L loc (WithUserRdr rdr id_name)) + + | id_name `hasKey` assertIdKey + = -- See Note [Overview of assertions] + do { dflags <- getDynFlags + ; if gopt Opt_IgnoreAsserts dflags + then tc_infer_id lname + else tc_infer_id (L loc $ WithUserRdr rdr assertErrorName) } + + | otherwise + = tc_infer_id lname + +tc_infer_id :: LocatedN (WithUserRdr Name) -> TcM (HsExpr GhcTc, TcSigmaType) +tc_infer_id (L loc (WithUserRdr rdr id_name)) + = do { thing <- tcLookup id_name + ; (expr,ty) <- case thing of + ATcId { tct_id = id } + -> do { check_local_id id + ; return_id id } + + AGlobal (AnId id) -> return_id id + -- A global cannot possibly be ill-staged + -- nor does it need the 'lifting' treatment + -- Hence no checkTh stuff here + + AGlobal (AConLike cl) -> tcInferConLike cl + + (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Term (WithUserRdr rdr (tyConName tc)) + ATyVar name _ -> failIllegalTyVar (WithUserRdr rdr name) + + _ -> failWithTc $ TcRnExpectedValueId thing + + ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) + ; return (expr, ty) } + where + return_id id = return (mkHsVar (L loc id), idType id) + +{- Note [Overview of assertions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you write (assert pred x) then + + * If `-fignore-asserts` (which sets Opt_IgnoreAsserts) is on, the code is + typechecked as written, but `assert`, defined in GHC.Internal.Base + assert _pred r = r + simply ignores `pred` + + * But without `-fignore-asserts`, GHC rewrites it to (assertError pred e) + and that is defined in GHC.Internal.IO.Exception as + assertError :: (?callStack :: CallStack) => Bool -> a -> a + which does test the predicate and, if it is not True, throws an exception, + capturing the CallStack. + + This rewrite is done in `tcInferId`. + +So `-fignore-asserts` makes the assertion go away altogether, which may be good for +production code. + +The reason that `assert` and `assertError` are defined in very different modules +is a historical accident. + +Note: the Haddock for `assert` is on `GHC.Internal.Base.assert`, since that is +what appears in the user's source proram. + +It's not entirely kosher to rewrite `assert` to `assertError`, because there's no +way to "undo" if you want to see the original source code in the typechecker +output. We can fix this if it becomes a problem. + +Note [Suppress hints with RequiredTypeArguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a type variable is used at the term level, GHC assumes the user might +have made a typo and suggests a term variable with a similar name. + +For example, if the user writes + f (Proxy :: Proxy nap) (Proxy :: Proxy gap) = nap (+1) [1,2,3] +then GHC will helpfully suggest `map` instead of `nap` + • Illegal term-level use of the type variable ‘nap’ + • Perhaps use ‘map’ (imported from Prelude) + +Importantly, GHC does /not/ suggest `gap`, which is in scope. +Question: How does GHC know not to suggest `gap`? After all, the edit distance + between `map`, `nap`, and `gap` is equally short. +Answer: GHC takes the namespace into consideration. `gap` is a `tvName`, and GHC + would only suggest a `varName` at the term level. + +In other words, the current hint infrastructure assumes that the namespace of an +entity is a reliable indicator of its level + term-level name <=> term-level entity + type-level name <=> type-level entity + +With RequiredTypeArguments, this assumption does not hold. Consider + bad :: forall a b -> ... + bad nap gap = nap + +This use of `nap` on the RHS is illegal because `nap` stands for a type +variable. It cannot be returned as the result of a function. At the same time, +it is bound as a `varName`, i.e. in the term-level namespace. + +Unless we suppress hints, GHC gets awfully confused + • Illegal term-level use of the variable ‘nap’ + • Perhaps use one of these: + ‘nap’ (line 2), ‘gap’ (line 2), ‘map’ (imported from Prelude) + +GHC shouldn't suggest `gap`, which is also a type variable; using it would +result in the same error. And it especially shouldn't suggest using `nap` +instead of `nap`, which is absurd. + +The proper solution is to overhaul the hint system to consider what a name +stands for instead of looking at its namespace alone. This is tracked in #24231. +As a temporary measure, we avoid those potentially misleading hints by +suppressing them entirely if RequiredTypeArguments is in effect. +-} + +check_local_id :: Id -> TcM () +check_local_id id + = do { tcEmitBindingUsage $ singleUsageUE id } + +check_naughty :: OccName -> TcId -> TcM () +check_naughty lbl id + | isNaughtyRecordSelector id = failWithTc (TcRnRecSelectorEscapedTyVar lbl) + | otherwise = return () + +tcInferConLike :: ConLike -> TcM (HsExpr GhcTc, TcSigmaType) +tcInferConLike (RealDataCon con) = tcInferDataCon con +tcInferConLike (PatSynCon ps) = tcInferPatSyn ps + +tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType) +-- See Note [Typechecking data constructors] +tcInferDataCon con + = do { let tvbs = dataConUserTyVarBinders con + tvs = binderVars tvbs + theta = dataConOtherTheta con + args = dataConOrigArgTys con + res = dataConOrigResTy con + stupid_theta = dataConStupidTheta con + + ; scaled_arg_tys <- mapM linear_to_poly args + + ; let full_theta = stupid_theta ++ theta + all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys + -- We are building the type of the data con wrapper, so the + -- type must precisely match the construction in + -- GHC.Core.DataCon.dataConWrapperType. + -- See Note [Instantiating stupid theta] + -- in GHC.Core.DataCon. + + ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys) + , mkForAllTys tvbs $ mkPhiTy full_theta $ + mkScaledFunTys scaled_arg_tys res ) } + where + linear_to_poly :: Scaled Type -> TcM (Scaled Type) + -- linear_to_poly implements point (3,4) + -- of Note [Typechecking data constructors] + linear_to_poly (Scaled OneTy ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy + ; return (Scaled mul_var ty) } + linear_to_poly scaled_ty = return scaled_ty + +tcInferPatSyn :: PatSyn -> TcM (HsExpr GhcTc, TcSigmaType) +tcInferPatSyn ps + = case patSynBuilderOcc ps of + Just (expr,ty) -> return (expr,ty) + Nothing -> failWithTc (nonBidirectionalErr (patSynName ps)) + +nonBidirectionalErr :: Name -> TcRnMessage +nonBidirectionalErr = TcRnPatSynNotBidirectional + +{- Note [Typechecking data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Polymorphisation of linear fields] in +GHC.Core.Multiplicity, linear fields of data constructors get a +polymorphic multiplicity when the data constructor is used as a term: + + Just :: forall {p} a. a %p -> Maybe a + +So at an occurrence of a data constructor we do the following: + +1. Typechecking, in tcInferDataCon. + + a. Get the original type of the constructor, say + K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a + Note the %1: it is linear + + b. We are going to return a ConLikeTc, thus: + XExpr (ConLikeTc K [r,a] [Scaled p a]) + :: forall (r :: RuntimeRep) (a :: TYPE r). a %p -> T r a + where 'p' is a fresh multiplicity unification variable. + + To get the returned ConLikeTc, we allocate a fresh multiplicity + variable for each linear argument, and store the type, scaled by + the fresh multiplicity variable in the ConLikeTc; along with + the type of the ConLikeTc. This is done by linear_to_poly. + + If the argument is not linear (perhaps explicitly declared as + non-linear by the user), don't bother with this. + +2. Desugaring, in dsConLike. + + a. The (ConLikeTc K [r,a] [Scaled p a]) is desugared to + (/\r (a :: TYPE r). \(x %p :: a). K @r @a x) + which has the desired type given in the previous bullet. + + The 'p' is the multiplicity unification variable, which + will by now have been unified to something, or defaulted in + `GHC.Tc.Zonk.Type.commitFlexi`. So it won't just be an + (unbound) variable. + + So a saturated application (K e), where e::Int will desugar to + (/\r (a :: TYPE r). ..etc..) + @LiftedRep @Int e + and all those lambdas will beta-reduce away in the simple optimiser + (see Wrinkle [Representation-polymorphic lambdas] below). + + But for an /unsaturated/ application, such as `map (K @LiftedRep @Int) xs`, + beta reduction will leave (\x %Many :: Int. K x), which is the type `map` + expects whereas if we had just plain K, with its linear type, we'd + get a type mismatch. That's why we do this funky desugaring. + +Wrinkles + + [ConLikeTc arguments] + + Note that the [TcType] argument to ConLikeTc is strictly redundant; those are + the type variables from the dataConUserTyVarBinders of the data constructor. + Similarly in the [Scaled TcType] field of ConLikeTc, the types come directly + from the data constructor. The only bit that /isn't/ redundant is the + fresh multiplicity variables! + + So an alternative would be to define ConLikeTc like this: + | ConLikeTc [TcType] -- Just the multiplicity variables + But then the desugarer would need to repeat some of the work done here. + So for now at least ConLikeTc records this strictly-redundant info. + + [Representation-polymorphic lambdas] + + The lambda expression we produce in (4) can have representation-polymorphic + arguments, as indeed in (/\r (a :: TYPE r). \(x %p :: a). K @r @a x), + we have a lambda-bound variable x :: (a :: TYPE r). + This goes against the representation polymorphism invariants given in + Note [Representation polymorphism invariants] in GHC.Core. The trick is that + this this lambda will always be instantiated in a way that upholds the invariants. + This is achieved as follows: + + A. Any arguments to such lambda abstractions are guaranteed to have + a fixed runtime representation. This is enforced in 'tcApp' by + 'matchActualFunTy'. + + B. If there are fewer arguments than there are bound term variables, + we will ensure that the appropriate type arguments are instantiated + concretely, such as 'r' in + + ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int# + :: Int# -> T IntRep Int# + + See Note [Representation-polymorphic Ids with no binding] in GHC.Tc.Utils.Concrete + + C. In the output of the desugarer in (4) above, we have a representation + polymorphic lambda, which Lint would normally reject. So for that one + pass, we switch off Lint's representation-polymorphism checks; see + the `lf_check_fixed_rep` flag in `LintFlags`. +-} + +{- +************************************************************************ +* * + Template Haskell checks +* * +************************************************************************ +-} + + +{- +Note [Lifting strings] +~~~~~~~~~~~~~~~~~~~~~~ +If we see $(... [| s |] ...) where s::String, we don't want to +generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. +So this conditional short-circuits the lifting mechanism to generate +(liftString "xy") in that case. I didn't want to use overlapping instances +for the Lift class in TH.Syntax, because that can lead to overlapping-instance +errors in a polymorphic situation. + +If this check fails (which isn't impossible) we get another chance; see +Note [Converting strings] in Convert.hs + +Note [Local record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record selectors for TyCons in this module are ordinary local bindings, +which show up as ATcIds rather than AGlobals. So we need to check for +naughtiness in both branches. c.f. GHC.Tc.TyCl.Utils.mkRecSelBinds. + +Note [Explicit Level Imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is the overview note which explains the whole implementation of ExplicitLevelImports + +GHC Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0682-explicit-level-imports.rst +Paper: https://mpickering.github.io/papers/explicit-level-imports.pdf + +The feature is turned on by the `ExplicitLevelImports` extension. +At the source level, the user marks imports with `quote` or `splice` to introduce +them at level 1 or -1. + +The function GHC.Tc.Utils.Monad.getCurrentAndBindLevel. computes the levels +at which a Name is available: + - for top-level Names, this information is stored in its GRE; it is either local + (level 0) or imported, in which case the levels it is imported at are stored in the + 'ImpDeclSpec's for the GRE. The function 'greLevels' retrieves this information. + - for locally-bound Names, this information is stored in the ThBindEnv. +GHC.Rename.Splice.checkCrossLevelLifting checks that levels in user-written programs +are correct. + +Instances are checked by `checkWellLevelledDFun`, which computes the level of an +instance by calling `checkWellLevelledInstanceWhat`, which sees what is available at by looking at the module graph. + +That's it for the main implementation of the feature; the rest is modifications +to the driver parts of the code to use this information. For example, in downsweep, +we only enable code generation for modules needed at the runtime stage. +See Note [-fno-code mode]. + +-} + + +{- ********************************************************************* +* * + Error reporting for function result mis-matches +* * +********************************************************************* -} + +addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] + -> TcType -> ExpRhoType + -> TcM a -> TcM a +-- When we have a mis-match in the return type of a function +-- try to give a helpful message about too many/few arguments +-- But not in generated code, where we don't want +-- to mention internal (rebindable syntax) function names +addFunResCtxt fun args fun_res_ty env_ty thing_inside + = do { env_tv <- newFlexiTyVarTy liftedTypeKind + ; dumping <- doptM Opt_D_dump_tc_trace + ; addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg dumping env_tv) thing_inside } + -- NB: use a landmark error context, so that an empty context + -- doesn't suppress some more useful context + where + mk_msg dumping env_tv + = do { mb_env_ty <- readExpType_maybe env_ty + -- by the time the message is rendered, the ExpType + -- will be filled in (except if we're debugging) + ; fun_res' <- zonkTcType fun_res_ty + ; env' <- case mb_env_ty of + Just env_ty -> zonkTcType env_ty + Nothing -> do { massert dumping; return env_tv } + ; let -- See Note [Splitting nested sigma types in mismatched + -- function types] + (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' + (_, _, env_tau) = tcSplitNestedSigmaTys env' + -- env_ty is an ExpRhoTy, but with simple subsumption it + -- is not deeply skolemised, so still use tcSplitNestedSigmaTys + (args_fun, res_fun) = tcSplitFunTys fun_tau + (args_env, res_env) = tcSplitFunTys env_tau + info = + FunResCtxt fun (count isValArg args) res_fun res_env + (length args_fun) (length args_env) + ; return info } + + +{- +Note [Splitting nested sigma types in mismatched function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When one applies a function to too few arguments, GHC tries to determine this +fact if possible so that it may give a helpful error message. It accomplishes +this by checking if the type of the applied function has more argument types +than supplied arguments. + +Previously, GHC computed the number of argument types through tcSplitSigmaTy. +This is incorrect in the face of nested foralls, however! +This caused Ticket #13311, for instance: + + f :: forall a. (Monoid a) => Int -> forall b. (Monoid b) => Maybe a -> Maybe b + +If one uses `f` like so: + + do { f; putChar 'a' } + +Then tcSplitSigmaTy will decompose the type of `f` into: + + Tyvars: [a] + Context: (Monoid a) + Argument types: [] + Return type: Int -> forall b. Monoid b => Maybe a -> Maybe b + +That is, it will conclude that there are *no* argument types, and since `f` +was given no arguments, it won't print a helpful error message. On the other +hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to: + + Tyvars: [a, b] + Context: (Monoid a, Monoid b) + Argument types: [Int, Maybe a] + Return type: Maybe b + +So now GHC recognizes that `f` has one more argument type than it was actually +provided. + +Notice that tcSplitNestedSigmaTys looks through function arrows too, regardless +of simple/deep subsumption. Here we are concerned only whether there is a +mis-match in the number of value arguments. +-} + + +{- ********************************************************************* +* * + Misc utility functions +* * +********************************************************************* -} + +addStmtCtxt :: ExprStmt GhcRn -> TcRn a -> TcRn a +addStmtCtxt stmt = + addErrCtxt (StmtErrCtxt (HsDoStmt (DoExpr Nothing)) stmt) + +addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a +addExprCtxt e thing_inside + = case e of + HsHole _ -> thing_inside + _ -> addErrCtxt (ExprCtxt e) thing_inside + -- The HsHole special case addresses situations like + -- f x = _ + -- when we don't want to say "In the expression: _", + -- because it is mentioned in the error message itself diff --git a/GHC/Tc/Gen/HsType.hs b/GHC/Tc/Gen/HsType.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/HsType.hs @@ -0,0 +1,4783 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecursiveDo #-} + +{- +(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, + tcDefaultDeclClass, 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, + tcGadtConTyVarBndrs, + bindOuterSigTKBndrs_Tv, + tcExplicitTKBndrs, + bindNamedWildCardBinders, + + -- Type checking type and class decls, and instances thereof + bindTyClTyVars, bindTyClTyVarsAndZonk, + tcFamTyPats, + maybeEtaExpandAlgTyCon, tcbVisibilities, + etaExpandAlgTyCon, + + -- tyvars + zonkAndScopedSort, + + -- Kind-checking types + -- No kind generalisation, no checkValidType + InitialKindStrategy(..), + SAKS_or_CUSK(..), + ContextKind(..), + kcDeclHeader, checkForDuplicateScopedTyVars, + tcHsLiftedType, tcHsOpenType, + tcHsLiftedTypeNC, tcHsOpenTypeNC, + tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated, + tcCheckLHsTypeInContext, tcCheckLHsType, + tcHsContext, tcLHsPredType, + + kindGeneralizeAll, + + -- Sort-checking kinds + tcLHsKindSig, checkDataKindSig, DataSort(..), + checkClassKindSig, + + -- Multiplicity + tcMult, + + -- Pattern type signatures + tcHsPatSigType, tcHsTyPat, tcRuleBndrSig, + HoleMode(..), + + -- Utils + tyLitFromLit, tyLitFromOverloadedLit, + + ) where + +import GHC.Prelude hiding ( head, init, last, tail ) + +import GHC.Hs +import GHC.Rename.Utils +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Types.LclEnv +import GHC.Tc.Types.ErrCtxt +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.Zonk.Type +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN, + tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs, + tcInstTypeBndrs ) +import GHC.Tc.Zonk.TcType + +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr + +import GHC.Builtin.Types.Prim +import GHC.Types.Error +import GHC.Types.Name.Env +import GHC.Types.Name.Reader( WithUserRdr(..), 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.Builtin.Names hiding ( wildCardName ) +import GHC.Driver.DynFlags +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.FastString +import GHC.Data.List.Infinite ( Infinite (..) ) +import qualified GHC.Data.List.Infinite as Inf +import GHC.Data.List.SetOps +import GHC.Data.Maybe +import GHC.Data.Bag( unitBag ) + +import Data.Function ( on ) +import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) +import qualified Data.List.NonEmpty as NE +import Data.List ( mapAccumL ) +import Control.Monad +import Data.Tuple( swap ) +import GHC.Types.SourceText + +{- + ---------------------------- + 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 $ + + + ; spec_tkvs <- zonkAndScopedSort spec_tkvs + + ; reportUnsolvedEqualities skol_info spec_tkvs tclvl wanted + + ; let ty1 = mkSpecForAllTys spec_tkvs ty + ; kvs <- kindGeneralizeAll ty1 + + ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1) + + ; checkValidType final_ty + +This pattern is repeated many times in GHC.Tc.Gen.HsType, +GHC.Tc.Gen.Sig, and GHC.Tc.TyCl, with variations. In more detail: + +* pushLevelAndSolveEqualitiesX (Step 0, step 3) bumps the TcLevel, + calls the thing inside to generate constraints, solves those + constraints as much as possible, returning the residual unsolved + constraints in 'wanted'. + +* bindImplicitTKBndrs_Skol (Step 1) binds the user-specified type + variables E.g. when kind-checking f :: forall a. F a -> a we must + bring 'a' into scope before kind-checking (F a -> a) + +* zonkAndScopedSort (Step 4) puts those user-specified variables in + the dependency order. (For "implicit" variables the order is no + user-specified. E.g. forall (a::k1) (b::k2). blah k1 and k2 are + implicitly brought into scope. + +* reportUnsolvedEqualities (Step 3 continued) reports any unsolved + equalities, carefully wrapping them in an implication that binds the + skolems. We can't do that in pushLevelAndSolveEqualitiesX because + that function doesn't have access to the skolems. + +* kindGeneralize (Step 5). See Note [Kind generalisation] + +* The final zonkTcTypeToType must happen after promoting/generalizing, + because promoting and generalizing fill in metavariables. + + +Doing Step 3 (constraint solving) eagerly (rather than building an +implication constraint and solving later) is necessary for several +reasons: + +* Exactly as for Solver.simplifyInfer: when generalising, we solve all + the constraints we can so that we don't have to quantify over them + or, since we don't quantify over constraints in kinds, float them + and inhibit generalisation. + +* Most signatures also bring implicitly quantified variables into + scope, and solving is necessary to get these in the right order + (Step 4) see Note [Keeping implicitly quantified variables in + order]). + +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Step 5 of Note [Recipe for checking a signature], namely +kind-generalisation, is done by + kindGeneraliseAll + kindGeneraliseSome + kindGeneraliseNone + +Here, we have to deal with the fact that metatyvars generated in the +type will have a bumped TcLevel, because explicit foralls raise the +TcLevel. To avoid these variables from ever being visible in the +surrounding context, we must obey the following dictum: + + Every metavariable in a type must either be + (A) generalized, or + (B) promoted, or See Note [Promotion in signatures] + (C) a cause to error See Note [Naughty quantification candidates] + in GHC.Tc.Utils.TcMType + +There are three steps (look at kindGeneraliseSome): + +1. candidateQTyVarsOfType finds the free variables of the type or kind, + to generalise + +2. filterConstrainedCandidates filters out candidates that appear + in the unsolved 'wanteds', and promotes the ones that get filtered out + thereby. + +3. quantifyTyVars quantifies the remaining type variables + +The kindGeneralize functions do not require pre-zonking; they zonk as they +go. + +kindGeneraliseAll specialises for the case where step (2) is vacuous. +kindGeneraliseNone specialises for the case where we do no quantification, +but we must still promote. + +If you are actually doing kind-generalization, you need to bump the +level before generating constraints, as we will only generalize +variables with a TcLevel higher than the ambient one. +Hence the "pushLevel" in pushLevelAndSolveEqualities. + +Note [Promotion in signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If an unsolved metavariable in a signature is not generalized +(because we're not generalizing the construct -- e.g., pattern +sig -- or because the metavars are constrained -- see kindGeneralizeSome) +we need to promote to maintain (WantedInv) of Note [TcLevel invariants] +in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing +and the reinstantiating with a fresh metavariable at the current level. +So in some sense, we generalize *all* variables, but then re-instantiate +some of them. + +Here is an example of why we must promote: + foo (x :: forall a. a -> Proxy b) = ... + +In the pattern signature, `b` is unbound, and will thus be brought into +scope. We do not know its kind: it will be assigned kappa[2]. Note that +kappa is at TcLevel 2, because it is invented under a forall. (A priori, +the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel +than the surrounding context.) This kappa cannot be solved for while checking +the pattern signature (which is not kind-generalized). When we are checking +the *body* of foo, though, we need to unify the type of x with the argument +type of bar. At this point, the ambient TcLevel is 1, and spotting a +metavariable with level 2 would violate the (WantedInv) invariant of +Note [TcLevel invariants]. So, instead of kind-generalizing, +we promote the metavariable to level 1. This is all done in kindGeneralizeNone. + +-} + +funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt +-- Returns FunSigCtxt, with no redundant-context-reporting, +-- form a list of located names +funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC +funsSigCtxt [] = panic "funSigCtxt" + +addSigCtxt :: UserTypeCtxt -> UserSigType GhcRn -> TcM a -> TcM a +addSigCtxt ctxt hs_ty thing_inside + = setSrcSpan l $ + addErrCtxt (UserSigCtxt ctxt hs_ty) $ + thing_inside + where + l = case hs_ty of + UserLHsSigType ty -> getLocA ty + UserLHsType ty -> getLocA ty + +pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc +-- (pprSigCtxt ctxt ) +-- prints In the type signature for 'f': +-- f :: +-- The 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 may block unification (Note [Equalities with heterogeneous kinds] in +-- GHC.Tc.Solver.Equality, wrinkle (EIK2)) 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) (UserLHsSigType sig_ty) $ + do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs $ + tcCheckLHsType hs_ty liftedTypeKind + ; return () } + +tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type +-- Does not do validity checking +tcClassSigType names sig_ty + = addSigCtxt sig_ctxt (UserLHsSigType 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 (UserLHsSigType 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 <- liftZonkM $ 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 $ + tcCheckLHsType 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 (err_ctx 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 + err_ctx exp_kind tidy_env + = do { (tidy_env2, exp_kind) <- zonkTidyTcType tidy_env exp_kind + ; return (tidy_env2, UninfTyCtx_Sig exp_kind full_hs_ty) } + + + +{- Note [Escaping kind in type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider kind-checking the signature for `foo` (#19495, #24686): + 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}. Note carefully that + this call is /outside/ the tcOuterTKBndrs call. + * 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 (UserLHsSigType 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" $ + do { kind <- newExpectedKind (expectedKindInCtxt ctxt) + ; tcOuterTKBndrs skol_info hs_outer_bndrs $ + tc_check_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 + + ; final_ty <- initZonkEnv DefaultFlexi + $ zonkTcTypeToTypeX (mkInfForAllTys kvs ty1) + ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty]) + ; return final_ty } + where + skol_info_anon = SigTypeSkol ctxt + +-- | Typecheck the class in a default declaration, checking that: +-- +-- - it is indeed a class (not e.g. a type family), +-- - that the class expects some invisible arguments followed +-- by a single visible argument. +tcDefaultDeclClass :: LIdP GhcRn -> TcM (Maybe Class) +tcDefaultDeclClass l_nm + = setSrcSpan (locA l_nm) $ + do { let nm = unLoc l_nm + ; thing <- tcLookupGlobal nm + ; case thing of + ATyCon tc + | Just cls <- tyConClass_maybe tc + -> if is_unary (tyConBinders tc) + then return $ Just cls + else + do { addErrTc $ TcRnNonUnaryTypeclassConstraint DefaultDeclCtxt (NameThing nm) + ; return Nothing } + + _ -> do { addErrTc $ TcRnIllegalDefaultClass nm + ; return Nothing } + } + where + is_unary :: [TyConBinder] -> Bool + is_unary = ( `lengthIs` 1 ) . dropWhile isInvisibleTyConBinder + +----------------- +tcHsDeriv :: LHsSigType GhcRn -> TcM (Maybe (Class, [TyCoVar], [Type], Kind)) +-- ^ Like tcHsSigType, but for the @...deriving( C ty1 ty2 )@ clause +-- +-- Returns a class constraint with the last argument missing, and the +-- expected kind of the remaining argument. +-- +-- E.g.: +-- +-- @class C (a::*) (b::k->k)@ +-- @data T a b = ... deriving( C Int )@ +-- +-- This function returns @(C, [k], [k, Int], k->k)@. +-- +-- Return values are fully zonked +tcHsDeriv hs_ty + = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty + + ; let (tvs, pred) = splitForAllTyCoVars ty + (kind_args, _) = splitFunTys (typeKind pred) + -- Checking that `pred` a is type class application + + ; case splitTyConApp_maybe pred of + Just (tc, tc_args) -> + case tyConClass_maybe tc of + Just cls -> + case kind_args of + [Scaled _ last_kind] -> + return $ Just $ + (cls, tvs, tc_args, last_kind) + _ -> + do { addErrTc $ TcRnNonUnaryTypeclassConstraint DerivClauseCtxt (TypeThing pred) + ; return Nothing + } + Nothing -> + do { addErrTc $ TcRnIllegalInstance + $ IllegalClassInstance (TypeThing ty) + $ IllegalInstanceHead + $ InstHeadNonClassHead + $ InstNonClassTyCon + (noUserRdr $ tyConName tc) + (fmap tyConName $ tyConFlavour tc) + ; return Nothing } + Nothing -> + do { addErrTc $ TcRnIllegalDerivingItem hs_ty; return Nothing } + } + +-- | 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 {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; 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_check_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 <- liftZonkM $ 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, tcCheckLHsTypeInContext 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 + -> HsFamEqnPats 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 <- liftZonkM $ 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 $ noUserRdr 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 tcCheckLHsTypeInContext in tcTyFamInstEqnGuts in GHC.Tc.Tycl. + +But we want the kind from the LHS to be /zonked/, so that when +kind-checking the RHS (tcCheckLHsTypeInContext) 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; tcCheckLHsType hs_ty ek } +tcHsLiftedTypeNC hs_ty = tcCheckLHsType hs_ty liftedTypeKind + +-- Like tcCheckLHsType, but takes an expected kind +tcCheckLHsTypeInContext :: LHsType GhcRn -> ContextKind -> TcM TcType +tcCheckLHsTypeInContext hs_ty exp_kind + = addTypeCtxt hs_ty $ + do { ek <- newExpectedKind exp_kind + ; tcCheckLHsType 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_maybe (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. So we may well end up with + x = /\a. id @a +But we cannot do this in types, as we have no type-level 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`; a particular case in point is in +`checkExpectedKind`. + +For example, suppose we have: + Actual: ∀ k2 k. k -> k2 -> k + Expected: ∀ k. k -> Type -> k +We must very delicately instantiate just k2 to kappa, and then unify + (∀ k. k -> Type -> k) ~ (∀ k. k -> kappa -> k) + +Otherwise, we are careful /not/ to instantiate. For example: + * at a variable in `tcTyVar` + * 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 :: LHsType GhcRn -> TcM Mult +tcMult ty = tc_check_lhs_type typeLevelMode ty multiplicityTy + +-- | 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 types, as in terms, we use bidirectional type infefence. The main workhorse +function looks like this: + + type ExpKind = ExpType + data ExpType = Check TcSigmaKind | Infer ...(hole TcRhoType)... + + tcHsType :: TcTyMode -> HsType GhcRn -> ExpKind -> TcM TcType + +* When the `ExpKind` argument is (Check ki), we /check/ that the type has + kind `ki` +* When the `ExpKind` argument is (Infer hole), we /infer/ the kind of the + type, and fill the hole with that kind +-} + +------------------------------------------ +-- | 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 + +--------------------------- +-- | 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 rn_ty + = runInferKind $ \exp_kind -> + tcHsType mode rn_ty exp_kind + +{- +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) + (==) +-} + +------------------------------------------ +tcCheckLHsType :: LHsType GhcRn -> TcKind -> TcM TcType +tcCheckLHsType hs_ty exp_kind + = tc_check_lhs_type typeLevelMode hs_ty exp_kind + +tc_check_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType +tc_check_lhs_type mode (L span ty) exp_kind + = setSrcSpanA span $ + tc_check_hs_type mode ty exp_kind + +tc_check_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType +-- See Note [Bidirectional type checking] +tc_check_hs_type mode ty ek = tcHsType mode ty (Check ek) + +tcLHsType :: TcTyMode -> LHsType GhcRn -> ExpKind -> TcM TcType +tcLHsType mode (L span ty) exp_kind + = setSrcSpanA span $ + tcHsType mode ty exp_kind + +tcHsType :: TcTyMode -> HsType GhcRn -> ExpKind -> TcM TcType +-- The main workhorse for type kind checking +-- See Note [Bidirectional type checking] + +tcHsType mode (HsParTy _ ty) exp_kind = tcLHsType mode ty exp_kind +tcHsType mode (HsDocTy _ ty _) exp_kind = tcLHsType mode ty exp_kind + +-- 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]. +tcHsType mode (HsSpliceTy (HsUntypedSpliceTop mod_finalizers ty) _) + exp_kind + = do addModFinalizersWithLclEnv mod_finalizers + tcLHsType mode ty exp_kind + +tcHsType _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tcHsType: invalid nested splice" (pprUntypedSplice True (Just n) s) + +---------- Functions and applications +tcHsType mode (HsFunTy _ mult ty1 ty2) exp_kind + = tc_fun_type mode mult ty1 ty2 exp_kind + +tcHsType mode (HsOpTy _ _ ty1 (L _ (WithUserRdr _ op)) ty2) exp_kind + | op `hasKey` unrestrictedFunTyConKey + = tc_fun_type mode (HsUnannotated noExtField) ty1 ty2 exp_kind + +--------- Foralls +tcHsType mode t@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind + | HsForAllInvis{} <- tele + = tc_hs_forall_ty tele ty exp_kind + -- For an invisible forall, we allow the body to have + -- an arbitrary kind (hence exp_kind above). + -- See Note [Body kind of a HsForAllTy] + + | HsForAllVis{} <- tele + = do { ek <- newOpenTypeKind + ; r <- tc_hs_forall_ty tele ty (Check ek) + ; checkExpKind t r ek exp_kind } + -- For a visible forall, we require that the body is of kind TYPE r. + -- See Note [Body kind of a HsForAllTy] + + where + tc_hs_forall_ty tele ty ek + = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $ + tcLHsType mode ty ek + -- 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 + + -- Do not kind-generalise here! See Note [Kind generalisation] + ; return (mkForAllTys tv_bndrs ty') } + +tcHsType mode t@(HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind + | null (unLoc ctxt) + = tcLHsType mode rn_ty exp_kind + -- See Note [Body kind of a HsQualTy], point (BK1) + | Check kind <- exp_kind -- Checking mode + , isConstraintLikeKind kind -- CONSTRAINT rep + = do { ctxt' <- tc_hs_context mode ctxt + -- See Note [Body kind of a HsQualTy], point (BK2) + ; ty' <- tc_check_lhs_type mode rn_ty constraintKind + ; let res_ty = tcMkDFunPhiTy ctxt' ty' + ; checkExpKind t res_ty constraintKind exp_kind } + + | 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_check_lhs_type mode rn_ty ek + ; let res_ty = tcMkPhiTy ctxt' ty' + ; checkExpKind t res_ty liftedTypeKind exp_kind } + +--------- Lists, arrays, and tuples +tcHsType mode rn_ty@(HsListTy _ elt_ty) exp_kind + = do { tau_ty <- tc_check_lhs_type mode elt_ty liftedTypeKind + ; checkWiredInTyCon listTyCon + ; checkExpKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } + +tcHsType mode rn_ty@(HsTupleTy _ tup_sort tys) exp_kind + = do k <- expTypeToType exp_kind + tc_hs_tuple_ty rn_ty mode tup_sort tys k + +tcHsType mode rn_ty@(HsSumTy _ hs_tys) exp_kind + = do { let arity = length hs_tys + ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys + ; tau_tys <- zipWithM (tc_check_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 + ; checkExpKind rn_ty sum_ty sum_kind exp_kind + } + +--------- Promoted lists and tuples +tcHsType mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind + -- See Note [Kind-checking explicit lists] + + | null tys + = do let ty = mkTyConTy promotedNilDataCon + let kind = mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy + checkExpKind rn_ty ty kind exp_kind + + | otherwise + = do { tks <- mapM (tc_infer_lhs_type mode) tys + ; (taus', kind) <- unifyKinds tys tks + ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') + ; checkExpKind 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] + +tcHsType 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_check_lhs_type mode) tys ks + ; let kind_con = tupleTyCon Boxed arity + ty_con = promotedTupleDataCon Boxed arity + tup_k = mkTyConApp kind_con ks + ; checkTupSize arity + ; checkExpKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } + where + arity = length tys + +--------- Constraint types +tcHsType mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind + = do { massert (isTypeLevel (mode_tyki mode)) + ; ty' <- tc_check_lhs_type mode ty liftedTypeKind + ; let n' = mkStrLitTy $ hsIPNameFS n + ; ipClass <- tcLookupClass ipClassName + ; checkExpKind rn_ty (mkClassPred ipClass [n',ty']) + constraintKind exp_kind } + +tcHsType _ rn_ty@(HsStarTy _ _) exp_kind + -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't + -- have to handle it in 'coreView' + = checkExpKind rn_ty liftedTypeKind liftedTypeKind exp_kind + +--------- Literals +tcHsType _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind + = do { checkWiredInTyCon naturalTyCon + ; checkExpKind rn_ty (mkNumLitTy n) naturalTy exp_kind } + +tcHsType _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind + = do { checkWiredInTyCon typeSymbolKindCon + ; checkExpKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } +tcHsType _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind + = do { checkWiredInTyCon charTyCon + ; checkExpKind rn_ty (mkCharLitTy c) charTy exp_kind } + +--------- Wildcards + +tcHsType mode ty@(HsWildCardTy _) ek + = do k <- expTypeToType ek + tcAnonWildCardOcc NoExtraConstraint mode ty k + +--------- Type applications +tcHsType mode rn_ty@(HsTyVar{}) exp_kind = tc_app_ty mode rn_ty exp_kind +tcHsType mode rn_ty@(HsAppTy{}) exp_kind = tc_app_ty mode rn_ty exp_kind +tcHsType mode rn_ty@(HsAppKindTy{}) exp_kind = tc_app_ty mode rn_ty exp_kind +tcHsType mode rn_ty@(HsOpTy{}) exp_kind = tc_app_ty mode rn_ty exp_kind + +tcHsType mode rn_ty@(HsKindSig _ ty sig) exp_kind + = 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 "tcHsType:sig" (ppr ty $$ ppr sig') + ; ty' <- tcAddKindSigPlaceholders sig $ + tc_check_lhs_type mode ty sig' + ; checkExpKind rn_ty ty' sig' exp_kind } + +-- See Note [Typechecking HsCoreTys] +tcHsType _ rn_ty@(XHsType ty) exp_kind + = 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 (getLclEnvTypeEnv env) ] + subst = mkTvSubst + (mkInScopeSetList $ map snd subst_prs) + (listToUFM_Directly $ map (fmap mkTyVarTy) subst_prs) + ty' = substTy subst ty + checkExpKind rn_ty ty' (typeKind ty') exp_kind + +tc_hs_tuple_ty :: HsType GhcRn + -> TcTyMode + -> HsTupleSort + -> [LHsType GhcRn] + -> TcKind + -> TcM TcType +-- See Note [Distinguishing tuple kinds] in GHC.Hs.Type +-- See Note [Inferring tuple kinds] +tc_hs_tuple_ty rn_ty mode 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 "tcHsType tuple" (ppr hs_tys) >> + tc_tuple rn_ty mode tup_sort hs_tys exp_kind + | otherwise + = do { traceTc "tcHsType tuple 2" (ppr hs_tys) + ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys + ; kinds <- liftZonkM $ 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_tuple_ty rn_ty mode HsUnboxedTuple tys exp_kind = + tc_tuple rn_ty mode UnboxedTuple tys exp_kind + +{- +Note [Kind-checking explicit lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type, suppose we have an application (F [t1,t2]), +where [t1,t2] is an explicit list, and + F :: [ki] -> blah + +Then we want to return the type + F ((:) @ki t2 ((:) @ki t2 ([] @ki))) +where the argument list is instantiated to F's argument kind `ki`. + +But what about (G []), where + G :: (forall k. [k]) -> blah + +Here we want to return (G []), with no instantiation at all. But since we have +no lambda in types, we must be careful not to instantiate that `[]`, because we +can't re-generalise it. Hence, when kind-checking an explicit list, we need a +special case for `[]`. + +Note [Variable Specificity and Forall Visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall +binder. Furthermore, each invisible type variable binder also has a +Specificity. Together, these determine the variable binders (ForAllTyFlag) for each +variable in the generated ForAllTy type. + +This table summarises this relation: +---------------------------------------------------------------------------- +| User-written type HsForAllTelescope Specificity ForAllTyFlag +|--------------------------------------------------------------------------- +| f :: forall a. type HsForAllInvis SpecifiedSpec Specified +| f :: forall {a}. type HsForAllInvis InferredSpec Inferred +| f :: forall a -> type HsForAllVis SpecifiedSpec Required +| f :: forall {a} -> type HsForAllVis InferredSpec / +| This last form is nonsensical and is thus rejected. +---------------------------------------------------------------------------- + +For more information regarding the interpretation of the resulting ForAllTyFlag, see +Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep". +-} + +------------------------------------------ +tc_fun_type :: TcTyMode -> HsMultAnn GhcRn -> LHsType GhcRn -> LHsType GhcRn -> ExpKind + -> TcM TcType +tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of + TypeLevel -> + do { traceTc "tc_fun_type" (ppr ty1 $$ ppr ty2) + ; arg_k <- newOpenTypeKind + ; res_k <- newOpenTypeKind + ; ty1' <- tc_check_lhs_type mode ty1 arg_k + ; ty2' <- tc_check_lhs_type mode ty2 res_k + ; mult' <- tc_mult mode mult + ; checkExpKind (HsFunTy noExtField mult ty1 ty2) + (tcMkVisFunTy mult' ty1' ty2') + liftedTypeKind exp_kind } + KindLevel -> -- no representation polymorphism in kinds. yet. + do { ty1' <- tc_check_lhs_type mode ty1 liftedTypeKind + ; ty2' <- tc_check_lhs_type mode ty2 liftedTypeKind + ; mult' <- tc_mult mode mult + ; checkExpKind (HsFunTy noExtField mult ty1 ty2) + (tcMkVisFunTy mult' ty1' ty2') + liftedTypeKind exp_kind } + where + tc_mult mode mult = case multAnnToHsType mult of + Just mult' -> tc_check_lhs_type mode mult' multiplicityTy + Nothing -> return manyDataConTy + +{- Note [Skolem escape and forall-types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Checking telescopes]. + +Consider + f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> () + +The Proxy '[a,b] forces a and b to have the same kind. But a's +kind must be bound outside the 'forall a', and hence escapes. +We discover this by building an implication constraint for +each forall. So the inner implication constraint will look like + forall kb (b::kb). kb ~ ka +where ka is a's kind. We can't unify these two, /even/ if ka is +unification variable, because it would be untouchable inside +this inner implication. + +That's what the pushLevelAndCaptureConstraints, plus subsequent +buildTvImplication/emitImplication is all about, when kind-checking +HsForAllTy. + +Note that + +* We don't need to /simplify/ the constraints here + because we aren't generalising. We just capture them. + +* We can't use emitResidualTvConstraint, because that has a fast-path + for empty constraints. We can't take that fast path here, because + we must do the bad-telescope check even if there are no inner wanted + constraints. See Note [Checking telescopes] in + GHC.Tc.Types.Constraint. Lacking this check led to #16247. +-} + +{- ********************************************************************* +* * + Tuples +* * +********************************************************************* -} + +--------------------------- +tupKindSort_maybe :: TcKind -> Maybe TupleSort +tupKindSort_maybe k + | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' + | Just k' <- coreView k = tupKindSort_maybe k' + | isConstraintKind k = Just ConstraintTuple + | tcIsLiftedTypeKind k = Just BoxedTuple + | otherwise = Nothing + +tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType +tc_tuple rn_ty mode tup_sort tys exp_kind + = do { arg_kinds <- case tup_sort of + BoxedTuple -> return (replicate arity liftedTypeKind) + UnboxedTuple -> replicateM arity newOpenTypeKind + ConstraintTuple -> return (replicate arity constraintKind) + ; tau_tys <- zipWithM (tc_check_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 -> 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 + +{- ********************************************************************* +* * + Type applications +* * +********************************************************************* -} + +splitHsAppTys_maybe :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn]) +splitHsAppTys_maybe hs_ty + | is_app hs_ty = Just (splitHsAppTys hs_ty) + | otherwise = Nothing + where + is_app :: HsType GhcRn -> Bool + is_app (HsAppKindTy {}) = True + is_app (HsAppTy {}) = True + is_app (HsOpTy _ _ _ (L _ (WithUserRdr _ op)) _) + = not (op `hasKey` unrestrictedFunTyConKey) + -- I'm not sure why this funTyConKey test is necessary + -- Can it even happen? Perhaps for t1 `(->)` t2 + -- but then maybe it's ok to treat that like a normal + -- application rather than using the special rule for HsFunTy + is_app (HsTyVar {}) = True + is_app (HsParTy _ (L _ ty)) = is_app ty + is_app _ = False + +splitHsAppTys :: HsType GhcRn -> (LHsType GhcRn, [LHsTypeArg GhcRn]) + +splitHsAppTys hs_ty = go (noLocA hs_ty) [] + where + go :: LHsType GhcRn + -> [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)] + -> (LHsType GhcRn, + [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp + go (L _ (HsAppTy _ f a)) as = go f (HsValArg noExtField a : as) + go (L _ (HsAppKindTy _ ty k)) as = go ty (HsTypeArg noExtField 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 (l2l sp) (HsTyVar noAnn prom op) + , HsValArg noExtField l : HsValArg noExtField 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 _ (WithUserRdr _ tv)))) + = tcTyVar tv +tcInferTyAppHead mode ty + = tc_infer_lhs_type mode ty + +tc_app_ty :: TcTyMode -> HsType GhcRn -> ExpKind -> TcM TcType +tc_app_ty mode rn_ty exp_kind + = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty + ; (ty, infered_kind) <- tcInferTyApps mode hs_fun_ty fun_ty hs_args + ; checkExpKind rn_ty ty infered_kind exp_kind } + where + (hs_fun_ty, hs_args) = splitHsAppTys rn_ty + +--------------------------- +-- | Apply a type of a given kind to a list of arguments. This instantiates +-- invisible parameters as necessary. Always consumes all the arguments, +-- using matchExpectedFunKind as necessary. +-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.- +-- These kinds should be used to instantiate invisible kind variables; +-- they come from an enclosing class for an associated type/data family. +-- +-- tcInferTyApps also arranges to saturate any trailing invisible arguments +-- of a type-family application, which is usually the right thing to do +-- tcInferTyApps_nosat does not do this saturation; it is used only +-- by ":kind" in GHCi +tcInferTyApps, tcInferTyApps_nosat + :: TcTyMode + -> LHsType GhcRn -- ^ Function (for printing only) + -> TcType -- ^ Function + -> [LHsTypeArg GhcRn] -- ^ Args + -> TcM (TcType, TcKind) -- ^ (f args, result kind) +tcInferTyApps mode hs_ty fun hs_args + = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args + ; saturateFamApp f_args res_k } + +tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args + = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args) + ; (f_args, res_k) <- go_init 1 fun orig_hs_args + ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k) + ; return (f_args, res_k) } + where + + -- go_init just initialises the auxiliary + -- arguments of the 'go' loop + go_init n fun all_args + = go n fun empty_subst fun_ki all_args + where + fun_ki = typeKind fun + -- We do (typeKind fun) here, even though the caller + -- knows the function kind, to absolutely guarantee + -- INVARIANT for 'go' + -- Note that in a typical application (F t1 t2 t3), + -- the 'fun' is just a TyCon, so typeKind is fast + + empty_subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfType fun_ki + + go :: Int -- The # of the next argument + -> TcType -- Function applied to some args + -> Subst -- Applies to function kind + -> TcKind -- Function kind + -> [LHsTypeArg GhcRn] -- Un-type-checked args + -> TcM (TcType, TcKind) -- Result type and its kind + -- INVARIANT: in any call (go n fun subst fun_ki args) + -- typeKind fun = subst(fun_ki) + -- So the 'subst' and 'fun_ki' arguments are simply + -- there to avoid repeatedly calling typeKind. + -- + -- Reason for INVARIANT: to support the Purely Kinded Type Invariant + -- it's important that if fun_ki has a forall, then so does + -- (typeKind fun), because the next thing we are going to do + -- is apply 'fun' to an argument type. + + -- Dispatch on all_args first, for performance reasons + go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of + + ---------------- No user-written args left. We're done! + ([], _) -> return (fun, substTy subst fun_ki) + + ---------------- HsArgPar: We don't care about parens here + (HsArgPar _ : args, _) -> go n fun subst fun_ki args + + ---------------- HsTypeArg: a kind application (fun @ki) + (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) -> + case ki_binder of + + -- FunTy with PredTy on LHS, or ForAllTy with Inferred + Named (Bndr kv Inferred) -> instantiate kv inner_ki + + Named (Bndr _ Specified) -> -- Visible kind application + do { traceTc "tcInferTyApps (vis kind app)" + (vcat [ ppr ki_binder, ppr hs_ki_arg + , ppr (piTyBinderType ki_binder) + , ppr subst ]) + + ; let exp_kind = substTy subst $ piTyBinderType ki_binder + ; arg_mode <- mkHoleMode KindLevel HM_VTA + -- HM_VKA: see Note [Wildcards in visible kind application] + ; ki_arg <- addErrCtxt (FunAppCtxt (FunAppCtxtTy orig_hs_ty hs_ki_arg) n) $ + tc_check_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 + | Named (Bndr kv flag) <- ki_binder + , isInvisibleForAllTyFlag flag -- ForAllTy with Inferred or Specified + -> instantiate kv inner_ki + + -- "normal" case + | otherwise + -> do { traceTc "tcInferTyApps (vis normal app)" + (vcat [ ppr ki_binder + , ppr arg + , ppr (piTyBinderType ki_binder) + , ppr subst ]) + ; let exp_kind = substTy subst $ piTyBinderType ki_binder + ; arg' <- addErrCtxt (FunAppCtxt (FunAppCtxtTy orig_hs_ty arg) n) $ + tc_check_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' <- liftZonkM $ zonkTcType (fun `mkCastTy` co) + -- This zonk is essential, to expose the fruits + -- of matchExpectedFunKind to the 'go' loop + + ; traceTc "tcInferTyApps (no binder)" $ + vcat [ ppr fun <+> dcolon <+> ppr fun_ki + , ppr arrows_needed + , ppr co + , ppr fun' <+> dcolon <+> ppr (typeKind fun')] + ; go_init n fun' all_args } + -- Use go_init to establish go's INVARIANT + where + instantiate ki_binder inner_ki + = do { traceTc "tcInferTyApps (need to instantiate)" + (vcat [ ppr ki_binder, ppr subst]) + ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder + ; go n (mkAppTy fun arg') subst' inner_ki all_args } + -- Because tcInvisibleTyBinder instantiate ki_binder, + -- the kind of arg' will have the same shape as the kind + -- of ki_binder. So we don't need mkAppTyM here. + + try_again_after_substing_or fallthrough + | not (isEmptyTCvSubst subst) + = go n fun zapped_subst substed_fun_ki all_args + | otherwise + = fallthrough + + zapped_subst = zapSubst subst + substed_fun_ki = substTy subst fun_ki + hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) + + n_initial_val_args :: [HsArg p tm ty] -> Arity + -- Count how many leading HsValArgs we have + n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args + n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args + n_initial_val_args _ = 0 + + ty_app_err arg ty + = failWith $ TcRnInvalidVisibleKindArgument arg ty + +mkAppTyM :: Subst + -> TcType -> PiTyBinder -- fun, plus its top-level binder + -> TcType -- arg + -> TcM (Subst, TcType) -- Extended subst, plus (fun arg) +-- Precondition: the application (fun arg) is well-kinded after zonking +-- That is, the application makes sense +-- +-- Precondition: for (mkAppTyM subst fun bndr arg) +-- typeKind fun = Pi bndr. body +-- That is, fun always has a ForAllTy or FunTy at the top +-- and 'bndr' is fun's pi-binder +-- +-- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type +-- invariant, then so does the result type (fun arg) +-- +-- We do not require that +-- typeKind arg = tyVarKind (binderVar bndr) +-- This must be true after zonking (precondition 1), but it's not +-- required for the (PKTI). +mkAppTyM subst fun ki_binder arg + | -- See Note [mkAppTyM]: Nasty case 2 + TyConApp tc args <- fun + , isTypeSynonymTyCon tc + , args `lengthIs` (tyConArity tc - 1) + , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym + = do { (arg':args') <- liftZonkM $ zonkTcTypes (arg: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 + liftZonkM $ zonkTcType arg + else return arg + ; return ( extendTvSubstAndInScope subst tv arg' + , mk_app_ty fun arg' ) } + +mk_app_ty :: TcType -> TcType -> TcType +-- This function just adds an ASSERT for mkAppTyM's precondition +mk_app_ty fun arg + = assertPpr (isPiTy fun_kind) + (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $ + mkAppTy fun arg + where + fun_kind = typeKind fun + +isTrickyTvBinder :: TcTyVar -> Bool +-- NB: isTrickyTvBinder is just an optimisation +-- It would be absolutely sound to return True always +isTrickyTvBinder tv = isPiTy (tyVarKind tv) + +{- Note [The Purely Kinded Type Invariant (PKTI)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During type inference, we maintain this invariant + + (PKTI) It is legal to call 'typeKind' on any Type ty, + on any sub-term of ty, /without/ zonking ty + + Moreover, any such returned kind + will itself satisfy (PKTI) + +By "legal to call typeKind" we mean "typeKind will not crash". +The way in which typeKind can crash is in applications + (a t1 t2 .. tn) +if 'a' is a type variable whose kind doesn't have enough arrows +or foralls. (The crash is in piResultTys.) + +The loop in tcInferTyApps has to be very careful to maintain the (PKTI). +For example, suppose + kappa is a unification variable + We have already unified kappa := Type + yielding co :: Refl (Type -> Type) + a :: kappa +then consider the type + (a Int) +If we call typeKind on that, we'll crash, because the (un-zonked) +kind of 'a' is just kappa, not an arrow kind. So we must zonk first. + +So the type inference engine is very careful when building applications. +This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int), +where (a :: kappa). Then in tcInferApps we'll run out of binders on +a's kind, so we'll call matchExpectedFunKind, and unify + kappa := kappa1 -> kappa2, with evidence co :: kappa ~ (kappa1 ~ kappa2) +At this point we must zonk the function type to expose the arrrow, so +that (a Int) will satisfy (PKTI). + +The absence of this caused #14174 and #14520. + +The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM]. + +Wrinkle around FunTy: +Note that the PKTI does *not* guarantee anything about the shape of FunTys. +Specifically, when we have (FunTy vis mult arg res), it should be the case +that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we +might not have this. Example: if the user writes (a -> b), then we might +invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1 +(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2). +However, when we build the FunTy, we might not have zonked `a`, and so the +FunTy will be built without being able to purely extract the RuntimeReps. + +Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy, +we must be aware of this when splitting: splitTyConApp and splitAppTy will *not* +split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy] +in GHC.Tc.Solver.Equality. + +Note [mkAppTyM] +~~~~~~~~~~~~~~~ +mkAppTyM is trying to guarantee the Purely Kinded Type Invariant +(PKTI) for its result type (fun arg). There are two ways it can go wrong: + +* Nasty case 1: forall types (polykinds/T14174a) + T :: forall (p :: *->*). p Int -> p Bool + Now kind-check (T x), where x::kappa. + Well, T and x both satisfy the PKTI, but + T x :: x Int -> x Bool + and (x Int) does /not/ satisfy the PKTI. + +* Nasty case 2: type synonyms + type S f a = f a + Even though (S ff aa) would satisfy the (PKTI) if S was a data type + (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI) + if S is a type synonym, because the /expansion/ of (S ff aa) is + (ff aa), and /that/ does not satisfy (PKTI). E.g. perhaps + (ff :: kappa), where 'kappa' has already been unified with (*->*). + + We check for nasty case 2 on the final argument of a type synonym. + +Notice that in both cases the trickiness only happens if the +bound variable has a pi-type. Hence isTrickyTvBinder. +-} + + +saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) +-- Precondition for (saturateFamApp ty kind): +-- typeKind ty = kind +-- +-- If 'ty' is an unsaturated family application with trailing +-- invisible arguments, instantiate them. +-- See Note [saturateFamApp] + +saturateFamApp ty kind + | Just (tc, args) <- tcSplitTyConApp_maybe ty + , tyConMustBeSaturated tc + , let n_to_inst = tyConArity tc - length args + = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind + ; return (ty `mkAppTys` extra_args, ki') } + | otherwise + = return (ty, kind) + +{- Note [saturateFamApp] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: Either j k + type instance F @Type = Right Maybe + type instance F @Type = Right Either``` + +Then F :: forall {j,k}. Either j k + +The two type instances do a visible kind application that instantiates +'j' but not 'k'. But we want to end up with instances that look like + type instance F @Type @(*->*) = Right @Type @(*->*) Maybe + +so that F has arity 2. We must instantiate that trailing invisible +binder. In general, Invisible binders precede Specified and Required, +so this is only going to bite for apparently-nullary families. + +Note that + type family F2 :: forall k. k -> * +is quite different and really does have arity 0. + +It's not just type instances where we need to saturate those +unsaturated arguments: see #11246. Hence doing this in tcInferApps. +-} + +appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn +appTypeToArg f [] = f +appTypeToArg f (HsValArg _ arg : args) = appTypeToArg (mkHsAppTy f arg) args +appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args +appTypeToArg f (HsTypeArg _ arg : args) + = appTypeToArg (mkHsAppKindTy noExtField f arg) args + + +{- ********************************************************************* +* * + checkExpectedKind +* * +********************************************************************* -} + +-- | This instantiates invisible arguments for the type being checked if it must +-- be saturated and is not yet saturated. It then calls and uses the result +-- from checkExpectedKindX to build the final type +checkExpectedKind :: HasDebugCallStack + => HsType GhcRn -- ^ type we're checking (for printing) + -> TcType -- ^ type we're checking + -> TcKind -- ^ the known kind of that type + -> TcKind -- ^ the expected kind + -> TcM TcType +-- Just a convenience wrapper to save calls to 'ppr' +checkExpectedKind hs_ty ty act_kind exp_kind + = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind) + + ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind + + ; let origin = TypeEqOrigin { uo_actual = act_kind' + , uo_expected = exp_kind + , uo_thing = Just (HsTypeRnThing hs_ty) + , uo_visible = True } -- the hs_ty is visible + + ; traceTc "checkExpectedKindX" $ + vcat [ ppr hs_ty + , text "act_kind':" <+> ppr act_kind' + , text "exp_kind:" <+> ppr exp_kind ] + + ; let res_ty = ty `mkAppTys` new_args + + ; if act_kind' `tcEqType` exp_kind + then return res_ty -- This is very common + else do { co_k <- unifyTypeAndEmit KindLevel origin act_kind' exp_kind + ; traceTc "checkExpectedKind" (vcat [ ppr act_kind + , ppr exp_kind + , ppr co_k ]) + ; return (res_ty `mkCastTy` co_k) } } + where + -- We need to make sure that both kinds have the same number of implicit + -- foralls and constraints 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 = invisibleBndrCount exp_kind + n_act_invis_bndrs = invisibleBndrCount act_kind + n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs + + +-- tyr <- checkExpKind hs_ty ty (act_ki :: Kind) (exp_ki :: ExpKind) +-- requires that `ty` has kind `act_ki` +-- It checks that the actual kind `act_ki` matches the expected kind `exp_ki` +-- and returns `tyr`, a possibly-casted form of `ty`, that has precisely kind `exp_ki` +-- `hs_ty` is purely for error messages +checkExpKind :: HsType GhcRn -> TcType -> TcKind -> ExpKind -> TcM TcType +checkExpKind rn_ty ty ki (Check ki') = + checkExpectedKind rn_ty ty ki ki' +checkExpKind _rn_ty ty ki (Infer cell) = do + -- NB: do not instantiate. + -- See Note [Do not always instantiate eagerly in types] + co <- fillInferResultNoInst ki cell + pure (ty `mkCastTy` co) + +--------------------------- + +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_check_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 { when (isFamInstTyCon (dataConTyCon dc)) $ + -- see #15245 + promotionErr name FamDataConPE + ; let (_, _, _, theta, _, _) = dataConFullSig dc + ; traceTc "tcTyVar" (ppr dc <+> ppr theta) + -- promotionErr: Note [No constraints in kinds] in GHC.Tc.Validity + ; unless (null theta) $ + promotionErr name (ConstrainedDataConPE theta) + ; let tc = promoteDataCon dc + ; return (mkTyConApp tc [], tyConKind tc) } + + AGlobal AnId{} -> promotionErr name TermVariablePE + ATcId{} -> promotionErr name TermVariablePE + APromotionErr err -> promotionErr name err + + _ -> wrongThingErr WrongThingType thing name } + +{- +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. +Because of representation polymorphism, it can be a TYPE r, for any r. +(In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all via CPR analysis; see +typecheck/should_compile/tc170). + +A forall can also be used in an instance head, then the body should +be a constraint. + +Right now, we do not have any easy way to enforce that a type is +either a TYPE something or CONSTRAINT something, so we accept any kind. +This is unsound (#22063). We could fix this by implementing a TypeLike +predicate, see #20000. + +For a forall with a required argument, we do not allow constraints; +e.g. forall a -> Eq a is invalid. Therefore, we can enforce that the body +is a TYPE something in this case (#24176). + +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 and result 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. + +(BK1) How do we figure out the right body kind? + +Well, it's a bit of a kludge: I just look at the expected kind, `exp_kind`. +If we are in checking mode (`exp_kind` = `Check k`), and the pushed-in kind +`k` is `CONSTRAINT rep`, then we check that the body type has kind `Constraint` too. + +This is a kludge because it wouldn't work if any unification was +involved to compute that result kind -- but it isn't. + +Note that in the kludgy "figure out whether we are in a type or constraint" +check, we only check if `k` is a `CONSTRAINT rep`, not `Constraint`. +That turns out to give a better error message in T25243. + +(BK2) + +Note that, once we are in the constraint case, we check that the body has +kind Constraint; see the call to tc_check_lhs_type. (In contrast, for +types we check that the body has kind TYPE kappa for some fresh unification +variable kappa.) +Reason: we don't yet have support for constraints that are not lifted: it's +not possible to declare a class returning a different type than CONSTRAINT LiftedRep. +Evidence is always lifted, the fat arrow c => t requires c to be +a lifted constraint. In a far future, if we add support for non-lifted +constraints, we could allow c1 => c2 where +c1 :: CONSTRAINT rep1, c2 :: CONSTRAINT rep2 +have arbitrary representations rep1 and rep2. + +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 @Type) just + as in GHC.Tc.Zonk.Type. + - 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 @Type) 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 'Type', not to (Any @Type). + +-} + +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 ty thing = addErrCtxt (TypeCtxt ty) thing + + + +{- ********************************************************************* +* * + 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 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 -> fsLit "w" + HM_FamPat -> fsLit "_" + HM_VTA -> fsLit "w" + HM_TyAppPat -> fsLit "_" + + emit_holes = case hole_mode of + HM_Sig -> True + HM_FamPat -> False + HM_VTA -> False + HM_TyAppPat -> False + +tcAnonWildCardOcc is_extra _ _ _ +-- mode_holes is Nothing. This means we have an anonymous wildcard +-- in an unexpected place. The renamer rejects these wildcards in 'checkAnonWildcard', +-- but it is possible for a wildcard to be introduced by a Template Haskell splice, +-- as per #15433. To account for this, we throw a generic catch-all error message. + = failWith $ TcRnIllegalWildcardInType Nothing reason + where + reason = + case is_extra of + YesExtraConstraint -> + ExtraConstraintWildcardNotAllowed + SoleExtraConstraintWildcardNotAllowed + NoExtraConstraint -> + WildcardsNotAllowedAtAll + +{- Note [Wildcard names] +~~~~~~~~~~~~~~~~~~~~~~~~ +So we hackily use the mode_holes flag to control the name used +for wildcards: + +* For proper holes (whether in a visible type application (VTA) or no), + we rename the '_' to 'w'. This is so that we see variables like 'w0' + or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For + example, we prefer + Found type wildcard ‘_’ standing for ‘w0’ + over + Found type wildcard ‘_’ standing for ‘_1’ + + Even in the VTA case, where we do not emit an error to be printed, we + want to do the renaming, as the variables may appear in other, + non-wildcard error messages. + +* However, holes in the left-hand sides of type families ("type + patterns") stand for type variables which we do not care to name -- + much like the use of an underscore in an ordinary term-level + pattern. When we spot these, we neither wish to generate an error + message nor to rename the variable. We don't rename the variable so + that we can pretty-print a type family LHS as, e.g., + F _ Int _ = ... + and not + F w1 Int w2 = ... + + See also Note [Wildcards in family instances] in + GHC.Rename.Module. The choice of HM_FamPat is made in + tcFamTyPats. There is also some unsavory magic, relying on that + underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser. + +Note [Wildcards in visible kind application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are cases where users might want to pass in a wildcard as a visible kind +argument, for instance: + +data T :: forall k1 k2. k1 → k2 → Type where + MkT :: T a b +x :: T @_ @Nat False n +x = MkT + +So we should allow '@_' without emitting any hole constraints, and +regardless of whether PartialTypeSignatures is enabled or not. But how +would the typechecker know which '_' is being used in VKA and which is +not when it calls emitNamedTypeHole in +tcHsPartialSigType on all HsWildCardBndrs? The solution is to neither +rename nor include unnamed wildcards in HsWildCardBndrs, but instead +give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. + +And whenever we see a '@', we set mode_holes to HM_VKA, so that +we do not call emitAnonTypeHole in tcAnonWildCardOcc. +See related Note [Wildcards in visible type application] here and +Note [The wildcard story for types] in GHC.Hs.Type +-} + +{- ********************************************************************* +* * + Kind inference for type declarations +* * +********************************************************************* -} + +-- See Note [kcCheckDeclHeader vs kcInferDeclHeader] +data InitialKindStrategy + = InitialKindCheck SAKS_or_CUSK + | InitialKindInfer + +-- Does the declaration have a standalone kind signature (SAKS) or a complete +-- user-supplied kind (CUSK)? +data SAKS_or_CUSK + = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) + | CUSK -- Complete user-supplied 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 TyCon -- ^ 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 TyCon -- ^ 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 TyCon -- ^ 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 + = addErrCtxt (TyConDeclCtxt name flav) $ + do { skol_info <- mkSkolemInfo skol_info_anon + ; (tclvl, wanted, (scoped_kvs, (tc_bndrs, 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 ++ binderVars tc_bndrs + 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, tc_bndrs, res_kind) <- liftZonkM $ + do { scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs -- scoped_kvs and tc_bndrs are skolems, + ; tc_bndrs <- mapM zonkTyCoVarBndrKind tc_bndrs -- so zonkTyCoVarBndrKind suffices + ; res_kind <- zonkTcType res_kind + ; return (scoped_kvs, tc_bndrs, 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 (mkExplicitTyConBinder mentioned_kv_set) tc_bndrs + + -- Eta expand if necessary; we are building a PolyTyCon + ; (eta_tcbs, res_kind) <- maybeEtaExpandAlgTyCon flav skol_info all_tcbs res_kind + + ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ binderVars tc_bndrs) + final_tcbs = all_tcbs `chkAppend` eta_tcbs + tycon = mkTcTyCon name final_tcbs res_kind all_tv_prs + True -- Make a PolyTcTyCon, fully 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 (binderVars tc_bndrs) + , 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 + +-- | Create a TyConBinder for a user-written type variable binder. +mkExplicitTyConBinder :: TyCoVarSet -- variables that are used dependently + -> VarBndr TyVar (HsBndrVis GhcRn) + -> TyConBinder +mkExplicitTyConBinder dep_set (Bndr tv flag) = + case flag of + HsBndrRequired{} -> mkRequiredTyConBinder dep_set tv + HsBndrInvisible{} -> mkNamedTyConBinder Specified tv + +-- | 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 TyCon -- ^ 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_bndrs }) kc_res_ki + -- No standalone kind signature and no CUSK. + -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + = addErrCtxt (TyConDeclCtxt name flav) $ + do { rejectInvisibleBinders name hs_bndrs + ; (scoped_kvs, (tc_bndrs, 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_bndrs $ + 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_tvs = binderVars tc_bndrs + -- Discard visibility flags. We made sure all of them are HsBndrRequired + -- by the call to rejectInvisibleBinders above. + + tc_binders = mkAnonTyConBinders tc_tvs + -- This has to be mkAnonTyConBinder! + -- See Note [No polymorphic recursion in type decls] in GHC.Tc.TyCl + -- + -- Also, note that tc_binders has the tyvars from only the + -- user-written type variable binders. + -- See S1 Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl + + 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 -- Make a MonoTcTyCon + flav + + ; traceTc "kcInferDeclHeader: not-cusk" $ + vcat [ ppr name, ppr kv_ns, ppr hs_bndrs + , ppr scoped_kvs + , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] + ; return tycon } + where + ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind + | otherwise = AnyKind + +-- rejectInvisibleBinders is called on on the inference code path; there is +-- no standalone kind signature, nor CUSK. +-- See Note [No inference for invisible binders in type decls] in GHC.Tc.TyCl +rejectInvisibleBinders :: Name -> [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] -> TcM () +rejectInvisibleBinders name = mapM_ check_bndr_vis + where + check_bndr_vis :: LHsTyVarBndr (HsBndrVis GhcRn) GhcRn -> TcM () + check_bndr_vis bndr = + when (isHsBndrInvisible (hsTyVarBndrFlag (unLoc bndr))) $ + addErr (TcRnInvisBndrWithoutSig name bndr) + +-- | 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 TyCon -- ^ 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 + = addErrCtxt (TyConDeclCtxt name flav) $ + do { skol_info <- mkSkolemInfo (TyConSkol flav name) + ; let avoid_occs = map nameOccName (hsLTyVarNames hs_tv_bndrs) + ; (sig_tcbs :: [TcTyConBinder], sig_res_kind :: Kind) + <- splitTyConKind skol_info emptyInScopeSet + avoid_occs 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 + , text "implict_nms:" <+> ppr implicit_nms + , text "hs_tv_bndrs:" <+> ppr hs_tv_bndrs ] + + ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, skol_scoped_tvs, (extra_tcbs, tycon_res_kind)))) + <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687 + bindImplicitTKBndrs_Q_Tv implicit_nms $ -- Q means don't clone + matchUpSigWithDecl name 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'. + -- + -- Also see Note [Arity of type families and type synonyms] + ; res_kind :: ContextKind <- kc_res_ki + + ; let sig_res_kind' = mkTyConKind excess_sig_tcbs sig_res_kind + + ; traceTc "kcCheckDeclHeader_sig 2" $ + vcat [ text "excess_sig_tcbs" <+> ppr excess_sig_tcbs + , text "res_kind" <+> ppr res_kind + , text "sig_res_kind'" <+> ppr sig_res_kind' + ] + + -- Unify res_ki (from the type declaration) with + -- sig_res_kind', the residual kind from the kind signature. + ; checkExpectedResKind sig_res_kind' res_kind + + -- Add more binders for data/newtype, so the result kind has no arrows + -- See Note [Datatype return kinds] + ; if null excess_sig_tcbs || not (needsEtaExpansion flav) + then return ([], 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. + -- + -- With visible dependent quantification, one of the binders involved + -- may be explicit. Consider #24604 + -- type UF :: forall zk -> zk -> Constraint + -- class UF kk (xb :: k) + -- Here `k` and `kk` both denote the same variable; but only `k` is implicit + -- Hence we need to add skol_scoped_tvs + ; implicit_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars implicit_tvs + ; let implicit_prs = implicit_nms `zip` implicit_tvs + dup_chk_prs = implicit_prs ++ mkTyVarNamePairs skol_scoped_tvs + ; unless (null implicit_nms) $ -- No need if no implicit tyvars + checkForDuplicateScopedTyVars dup_chk_prs + ; checkForDisconnectedScopedTyVars name flav all_tcbs implicit_prs + + -- Swizzle the Names so that the TyCon uses the user-declared implicit names + -- E.g type T :: k -> Type + -- data T (a :: j) = .... + -- We want the TyConBinders of T to be [j, a::j], not [k, a::k] + -- Why? So that the TyConBinders of the TyCon will lexically scope over the + -- associated types and methods of a class. + ; let swizzle_env = mkVarEnv (map swap implicit_prs) + (subst, swizzled_tcbs) = mapAccumL (swizzleTcb swizzle_env) emptySubst all_tcbs + swizzled_kind = substTy subst tycon_res_kind + all_tv_prs = mkTyVarNamePairs (binderVars swizzled_tcbs) + + ; traceTc "kcCheckDeclHeader swizzle" $ vcat + [ text "sig_tcbs =" <+> ppr sig_tcbs + , text "implicit_prs =" <+> ppr implicit_prs + , 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 -- Make a PolyTcTyCon, fully generalised + 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 } + +-- | Check the result kind annotation on a type constructor against +-- the corresponding section of the standalone kind signature. +-- Drops invisible binders that interfere with unification. +checkExpectedResKind :: TcKind -- ^ the result kind from the separate kind signature + -> ContextKind -- ^ the result kind from the declaration header + -> TcM () +checkExpectedResKind _ AnyKind + = return () -- No signature in the declaration header +checkExpectedResKind sig_kind res_ki + = do { actual_res_ki <- newExpectedKind res_ki + + ; let -- Drop invisible binders from sig_kind until they match up + -- with res_ki. By analogy with checkExpectedKind. + n_res_invis_bndrs = invisibleBndrCount actual_res_ki + n_sig_invis_bndrs = invisibleBndrCount sig_kind + n_to_inst = n_sig_invis_bndrs - n_res_invis_bndrs + + (_, sig_kind') = splitInvisPiTysN n_to_inst sig_kind + + ; discardResult $ unifyKind Nothing sig_kind' actual_res_ki } + +matchUpSigWithDecl + :: Name -- Name of the type constructor for error messages + -> [TcTyConBinder] -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature + -> TcKind -- The tail end of the kind signature + -> [LHsTyVarBndr (HsBndrVis GhcRn) 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 + , [TcTyVar] -- Skolem tyvars brought into lexical scope by this matching-up + , a ) +-- See Note [Matching a kind signature with a declaration] +-- Invariant: Length of returned TyConBinders + length of excess TyConBinders +-- = length of incoming TyConBinders +matchUpSigWithDecl name sig_tcbs sig_res_kind hs_bndrs thing_inside + = go emptySubst sig_tcbs hs_bndrs + where + go subst tcbs [] + = do { let (subst', tcbs') = substTyConBindersX subst tcbs + ; res <- thing_inside tcbs' (substTy subst' sig_res_kind) + ; return ([], [], res) } + + go _ [] hs_bndrs + = failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs) + + go subst (tcb : tcbs') hs_bndrs@(hs_bndr : hs_bndrs') + | zippable (binderFlag tcb) (hsTyVarBndrFlag (unLoc hs_bndr)) + = -- Visible TyConBinder, so match up with the hs_bndrs + do { let Bndr tv vis = tcb + tv' = updateTyVarKind (substTy subst) $ + maybe tv (setTyVarName tv) (hsLTyVarName 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 (unLoc hs_bndr) (tyVarKind tv') + ; traceTc "musd1" (ppr tcb $$ ppr hs_bndr $$ ppr tv') + ; (tcbs', tvs, res) <- tcExtendTyVarEnv [tv'] $ + go subst' tcbs' hs_bndrs' + ; return (Bndr tv' vis : tcbs', tv':tvs, res) } + -- We do a tcExtendTyVarEnv [tv'], so we return tv' in + -- the list of lexically-scoped skolem type variables + + | skippable (binderFlag tcb) + = -- Invisible TyConBinder, so do not consume one of the hs_bndrs + do { let (subst', tcb') = substTyConBinderX subst tcb + ; traceTc "musd2" (ppr tcb $$ ppr hs_bndr $$ ppr tcb') + ; (tcbs', tvs, 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', tvs, res) } + -- Return `tvs`; no new lexically-scoped TyVars brought into scope + + | otherwise = + -- At this point we conclude that: + -- * the quantifier (tcb) is visible: (ty -> ...), (forall a -> ...) + -- * the binder (hs_bndr) is invisible: @t, @(t :: k) + -- Any other combination should have been handled by the zippable/skippable clauses. + failWithTc (TcRnInvalidInvisTyVarBndr name hs_bndr) + + tc_hs_bndr :: HsTyVarBndr (HsBndrVis GhcRn) GhcRn -> TcKind -> TcM () + tc_hs_bndr (HsTvb { tvb_kind = HsBndrNoKind _ }) _ = return () + tc_hs_bndr (HsTvb { tvb_kind = HsBndrKind _ kind, tvb_var = bvar }) + expected_kind + = do { traceTc "musd3:unifying" (ppr kind $$ ppr expected_kind) + ; tcHsTvbKind bvar kind expected_kind } + + -- See GHC Proposal #425, section "Kind checking", + -- where zippable and skippable are defined. + -- In particular: we match up if + -- (a) HsBndr looks like @k, and TyCon binder is forall k. (NamedTCB Specified) + -- (b) HsBndr looks like a, and TyCon binder is forall k -> (NamedTCB Required) + -- or k -> (AnonTCB) + zippable :: TyConBndrVis -> HsBndrVis GhcRn -> Bool + zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis -- (a) + zippable vis (HsBndrRequired _) = isVisibleTcbVis vis -- (b) + + -- See GHC Proposal #425, section "Kind checking", + -- where zippable and skippable are defined. + skippable :: TyConBndrVis -> Bool + skippable vis = not (isVisibleTcbVis vis) + +-- Check the kind of a type variable binder +tcHsTvbKind :: HsBndrVar GhcRn -> LHsKind GhcRn -> TcKind -> TcM () +tcHsTvbKind bvar kind expected_kind = + do { sig_kind <- tcLHsKindSig ctxt kind + ; traceTc "tcHsTvbKind:unifying" (ppr sig_kind $$ ppr expected_kind) + ; discardResult $ -- See Note [discardResult in tcHsTvbKind] + unifyKind mb_thing sig_kind expected_kind } + where + (ctxt, mb_thing) = case bvar of + HsBndrVar _ (L _ hs_nm) -> (TyVarBndrKindCtxt hs_nm, Just (NameThing hs_nm)) + HsBndrWildCard _ -> (KindSigCtxt, Nothing) + +substTyConBinderX :: Subst -> TyConBinder -> (Subst, TyConBinder) +substTyConBinderX subst (Bndr tv vis) + = (subst', Bndr tv' vis) + where + (subst', tv') = substTyVarBndr subst tv + +substTyConBindersX :: Subst -> [TyConBinder] -> (Subst, [TyConBinder]) +substTyConBindersX = mapAccumL substTyConBinderX + +swizzleTcb :: VarEnv Name -> Subst -> TyConBinder -> (Subst, TyConBinder) +swizzleTcb swizzle_env subst (Bndr tv vis) + = (subst', Bndr tv2 vis) + where + subst' = extendTCvSubstWithClone subst tv tv2 + tv1 = updateTyVarKind (substTy subst) tv + tv2 = case lookupVarEnv swizzle_env tv of + Just user_name -> setTyVarName tv1 user_name + Nothing -> tv1 + -- NB: the SrcSpan on an implicitly-bound name deliberately spans + -- the whole declaration. e.g. + -- data T (a :: k) (b :: Type -> k) = .... + -- There is no single binding site for 'k'. + -- See Note [Source locations for implicitly bound type variables] + -- in GHC.Tc.Rename.HsType + +{- 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 (HsBndrVis GhcRn) 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. + +Note [Arity of type families and type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type F0 :: forall k. k -> k -> Type + type family F0 + + type F1 :: forall k. k -> k -> Type + type family F1 @k + + type F2a :: forall k. k -> k -> Type + type family F2a @k a + + type F2b :: forall k. k -> k -> Type + type family F2b a + + type F3 :: forall k. k -> k -> Type + type family F3 a b + +All five have the same /kind/, but what /arity/ do they have? +For a type family, the arity is critical: +* A type family must always appear saturated (up to its arity) +* A type family can match only on `arity` arguments, not further ones +* The arity is recorded by `tyConArity`, and is equal to the number of + `TyConBinders` in the `TyCon`. +* In this context "arity" includes both kind and type arguments. + +The arity is not determined by the kind signature (all five have the same signature). +Rather, it is determined by the declaration of the family: +* `F0` has arity 0. +* `F1` has arity 1. +* `F2a` has arity 2. +* `F2b` also has arity 2: the kind argument is invisible. +* `F3` has arity 3; again the kind argument is invisible. + +The matching-up of kind signature with the declaration itself is done by +`matchUpWithSigDecl`. + +Note [discardResult in tcHsTvbKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 [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 _@ + +-- debug only +instance Outputable ContextKind where + ppr AnyKind = text "AnyKind" + ppr OpenKind = text "OpenKind" + ppr (TheKind k) = text "TheKind" <+> ppr k + +----------------------- +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 +* * +********************************************************************* -} + +checkForDisconnectedScopedTyVars :: Name -> TyConFlavour TyCon -> [TcTyConBinder] + -> [(Name,TcTyVar)] -> TcM () +-- See Note [Disconnected type variables] +-- For the type synonym case see Note [Out of arity type variables] +-- `scoped_prs` is the mapping gotten by unifying +-- - the standalone kind signature for T, with +-- - the header of the type/class declaration for T +checkForDisconnectedScopedTyVars name flav all_tcbs scoped_prs + -- needsEtaExpansion: see wrinkle (DTV1) in Note [Disconnected type variables] + | needsEtaExpansion flav = mapM_ report_disconnected (filterOut ok scoped_prs) + | flav == TypeSynonymFlavour = mapM_ report_out_of_arity (filterOut ok scoped_prs) + | otherwise = pure () + where + all_tvs = mkVarSet (binderVars all_tcbs) + ok (_, tc_tv) = tc_tv `elemVarSet` all_tvs + + report_disconnected :: (Name,TcTyVar) -> TcM () + report_disconnected (nm, _) + = setSrcSpan (getSrcSpan nm) $ + addErrTc $ TcRnDisconnectedTyVar nm + + report_out_of_arity :: (Name,TcTyVar) -> TcM () + report_out_of_arity (tv_nm, _) + = setSrcSpan (getSrcSpan tv_nm) $ + addErrTc $ TcRnOutOfArityTyVar name tv_nm + +checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM () +-- Check for duplicates +-- See Note [Aliasing in type and class declarations] +checkForDuplicateScopedTyVars scoped_prs + = unless (null err_prs) $ + do { mapM_ report_dup err_prs; failM } + where + -------------- Error reporting ------------ + err_prs :: [(Name,Name)] + err_prs = [ (n1,n2) + | prs :: NonEmpty (Name,TyVar) <- findDupsEq ((==) `on` snd) scoped_prs + , (n1,_) :| ((n2,_) : _) <- [NE.nubBy ((==) `on` fst) prs] ] + -- This nubBy avoids bogus error reports when we have + -- [("f", f), ..., ("f",f)....] in swizzle_prs + -- which happens with class C f where { type T f } + + report_dup :: (Name,Name) -> TcM () + report_dup (n1,n2) + = setSrcSpan (getSrcSpan n2) $ + addErrTc $ TcRnDifferentNamesForTyVar n1 n2 + + +{- Note [Aliasing in type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data SameKind (a::k) (b::k) + data T1 (a::k1) (b::k2) c = MkT (SameKind a b) c +We do not allow this, because `k1` and `k2` would both stand for the same type +variable -- they are both aliases for `k`. + +Other examples + data T2 (a::k1) = MkT2 (SameKind a Int) -- k1 stands for Type + data T3 @k1 @k2 (a::k1) (b::k2) = MkT (SameKind a b) -- k1 and k2 are aliases + + type UF :: forall zk. zk -> Constraint + class UF @kk (xb :: k) where -- kk and k are aliases + op :: (xs::kk) -> Bool + +See #24604 for an example that crashed GHC. + +There is a design choice here. It would be possible to allow implicit type variables +like `k1` and `k2` in T1's declartion to stand for /abitrary kinds/. This is in fact +the rule we use in /terms/ pattern signatures: + f :: [Int] -> Int + f ((x::a) : xs) = ... +Here `a` stands for `Int`. But in type /signatures/ we make a different choice: + f1 :: forall (a::k1) (b::k2). SameKind a b -> blah + f2 :: forall (a::k). SameKind a Int -> blah + +Here f1's signature is rejected because `k1` and `k2` are aliased; and f2's is +rejected because `k` stands for `Int`. + +Our current choice is that type and class declarations behave more like signatures; +we do not allow aliasing. That is what `checkForDuplicateScopedTyVars` checks. +See !12328 for some design discussion. + + +Note [Disconnected type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note applies when kind-checking the header of a type/class decl that has +a separate, standalone kind signature. See #24083. + +Consider: + type S a = Type + + type C :: forall k. S k -> Constraint + class C (a :: S kk) where + op :: ...kk... + +Note that the class has a separate kind signature, so the elaborated decl should +look like + class C @kk (a :: S kk) where ... + +But how can we "connect up" the scoped variable `kk` with the skolem kind from the +standalone kind signature for `C`? In general we do this by unifying the two. +For example + type T k = (k,Type) + type W :: forall k. T k -> Type + data W (a :: (x,Type)) = ..blah blah.. + +When we encounter (a :: (x,Type)) we unify the kind (x,Type) with the kind (T k) +from the standalone kind signature. Of course, unification looks through synonyms +so we end up with the mapping [x :-> k] that connects the scoped type variable `x` +with the kind from the signature. + +But in our earlier example this unification is ineffective -- because `S` is a +phantom synonym that just discards its argument. So our plan is this: + + if matchUpSigWithDecl fails to connect `kk with `k`, by unification, + we give up and complain about a "disconnected" type variable. + +See #24083 for dicussion of alternatives, none satisfactory. Also the fix is +easy: just add an explicit `@kk` parameter to the declaration, to bind `kk` +explicitly, rather than binding it implicitly via unification. + +(DTV1) We only want to make this check when there /are/ scoped type variables; and + that is determined by needsEtaExpansion. Examples: + + type C :: x -> y -> Constraint + class C a :: b -> Constraint where { ... } + -- The a,b scope over the "..." + + type D :: forall k. k -> Type + data family D :: kk -> Type + -- Nothing for `kk` to scope over! + + In the latter data-family case, the match-up stuff in kcCheckDeclHeader_sig will + return [] for `extra_tcbs`, and in fact `all_tcbs` will be empty. So if we do + the check-for-disconnected-tyvars check we'll complain that `kk` is not bound + to one of `all_tcbs` (see #24083, comments about the `singletons` package). + + The scoped-tyvar stuff is needed precisely for data/class/newtype declarations, + where needsEtaExpansion is True. + +Note [Out of arity type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(Relevant ticket: #24470) +Type synonyms have a special scoping rule that allows implicit quantification in +the outermost kind signature: + + type P_e :: k -> Type + type P_e @k = Proxy :: k -> Type -- explicit binding + + type P_i = Proxy :: k -> Type -- implicit binding (relies on the special rule) + +This is a deprecated feature (warning flag: -Wimplicit-rhs-quantification) but +we have to support it for a couple more releases. It is explained in more detail +in Note [Implicit quantification in type synonyms] in GHC.Rename.HsType. + +Type synonyms `P_e` and `P_i` are equivalent. Both of them have kind +`forall k. k -> Type` and arity 1. (Recall that the arity of a type synonym is +the number of arguments it requires at use sites; the arity matter because +unsaturated application of type families and type synonyms is not allowed). + +We start to see problems when implicit RHS quantification (as in `P_i`) is +combined with a standalone king signature (like the one that `P_e` has). +That is: + + type P_i_sig :: k -> Type + type P_i_sig = Proxy :: k -> Type + +Per GHC Proposal #425, the arity of `P_i_sig` is determined /by the LHS only/, +which has no binders. So the arity of `P_i_sig` is 0. +At the same time, the legacy implicit quantification rule dictates that `k` is +brought into scope, as if there was a binder `@k` on the LHS. + +We end up with a `k` that is in scope on the RHS but cannot be bound implicitly +on the LHS without affecting the arity. This led to #24470 (a compiler crash) + + GHC internal error: ‘k’ is not in scope during type checking, + but it passed the renamer + +This problem occurs only if the arity of the type synonym is insufficiently +high to accommodate an implicit binding. It can be worked around by adding an +unused binder on the LHS: + + type P_w :: k -> Type + type P_w @_w = Proxy :: k -> Type + +The variable `_w` is unused. The only effect of the `@_w` binder is that the +arity of `P_w` is changed from 0 to 1. However, bumping the arity is exactly +what's needed to make the implicit binding of `k` possible. + +All this is a rather unfortunate bit of accidental complexity that will go away +when GHC drops support for implicit RHS quantification. In the meantime, we +ought to produce a proper error message instead of a compiler panic, and we do +that with a check in checkForDisconnectedScopedTyVars: + + | flav == TypeSynonymFlavour = mapM_ report_out_of_arity (filterOut ok scoped_prs) + +-} + +{- ********************************************************************* +* * + Bringing type variables into scope +* * +********************************************************************* -} + +-------------------------------------- +-- HsForAllTelescope +-------------------------------------- + +tcTKTelescope :: TcTyMode + -> HsForAllTelescope GhcRn + -> TcM a + -> TcM ([TcTyVarBinder], a) +-- A HsForAllTelescope comes only from a HsForAllTy, +-- an explicit, user-written forall type +tcTKTelescope mode tele thing_inside = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } + -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode + , sm_tvtv = SMDSkolemTv skol_info } + ; (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside + -- req_tv_bndrs :: [VarBndr TyVar ()], + -- but we want [VarBndr TyVar ForAllTyFlag] + ; return (tyVarReqToBinders req_tv_bndrs, thing) } + + HsForAllInvis { hsf_invis_bndrs = bndrs } + -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode + , sm_tvtv = SMDSkolemTv skol_info } + ; (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside + -- inv_tv_bndrs :: [VarBndr TyVar Specificity], + -- but we want [VarBndr TyVar ForAllTyFlag] + ; return (tyVarSpecToBinders inv_tv_bndrs, thing) } + +-------------------------------------- +-- HsOuterTyVarBndrs +-------------------------------------- + +bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc + => 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 -- Only to support traceTc + => 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 -- Only to support traceTc + => 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) } + +--------------- +tcGadtConTyVarBndrs :: SkolemInfo + -> HsOuterSigTyVarBndrs GhcRn + -> [HsForAllTelescope GhcRn] + -> TcM a -> TcM ([TcTyVarBinder], a) +tcGadtConTyVarBndrs skol_info outer inner thing_inside + = do { (outer_bndrs, (inner_tvbs, a)) <- + tcOuterTKBndrs skol_info outer $ + tcExplicitTKBndrs skol_info (concatMap hsForAllTelescopeBndrs inner) $ + thing_inside + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tvbs = tyVarSpecToBinders (outerTyVarBndrs outer_bndrs) + ; return (outer_tvbs ++ inner_tvbs, a) } + +-------------------------------------- +-- Explicit tyvar binders +-------------------------------------- + +tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed -- Only to suppor traceTc + => 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 -- Only to suppor traceTc + => SkolemMode + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) +-- Push level, capture constraints, and emit an implication constraint. +-- The implication constraint has a ForAllSkol ic_info, +-- so that it is subject to a telescope test. +tcExplicitTKBndrsX skol_mode bndrs thing_inside = case nonEmpty bndrs of + Nothing -> do + { res <- thing_inside + ; return ([], res) } + + Just bndrs1 -> do + { (tclvl, wanted, (skol_tvs, res)) + <- pushLevelAndCaptureConstraints $ + bindExplicitTKBndrsX skol_mode bndrs $ + thing_inside + + -- Set up SkolemInfo for telescope test + ; let bndr_1 = NE.head bndrs1; bndr_n = NE.last bndrs1 + ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + -- Notice that we use ForAllSkol here, ignoring the enclosing + -- skol_info unlike tcImplicitTKBndrs, because the bad-telescope + -- test applies only to ForAllSkol + + ; setSrcSpan (combineSrcSpans (getLocA bndr_1) (getLocA bndr_n)) + $ emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted + + ; return (skol_tvs, res) } + +---------------- +-- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied +-- 'TcTyMode'. +bindExplicitTKBndrs_Skol + :: (OutputableBndrFlag flag 'Renamed) -- Only to suppor traceTc + => SkolemInfo + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) + +bindExplicitTKBndrs_Tv + :: (OutputableBndrFlag flag 'Renamed) -- Only to suppor traceTc + => [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 + :: (OutputableBndrFlag flag 'Renamed) -- Only to support traceTc + => SkolemInfo + -> ContextKind + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) + +bindExplicitTKBndrs_Q_Tv + :: (OutputableBndrFlag flag 'Renamed) -- Only to support traceTc + => ContextKind + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) +-- These do not clone: see Note [Cloning for type variable binders] +bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_bndrs thing_inside + = 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 + = 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) -- Only to support traceTc + => 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 (mk_tvb_pairs hs_tv tv) $ + go hs_tvs + ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) } + + tc_hs_bndr :: TcTypeEnv -> HsTyVarBndr flag GhcRn -> TcM TcTyVar + tc_hs_bndr lcl_env (HsTvb { tvb_var = bvar, tvb_kind = kind }) + | check_parent + , HsBndrVar _ (L _ name) <- bvar + , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name + = do { check_hs_bndr_kind name (tyVarKind tv) kind + ; return tv } + | otherwise + = do { name <- tcHsBndrVarName bvar + ; kind' <- tc_hs_bndr_kind name kind + ; newTyVarBndr skol_mode name kind' } + + tc_hs_bndr_kind :: Name -> HsBndrKind GhcRn -> TcM Kind + tc_hs_bndr_kind _ (HsBndrNoKind _) = newExpectedKind ctxt_kind + tc_hs_bndr_kind name (HsBndrKind _ kind) = tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) kind + + -- Check the HsBndrKind against the kind of the parent type variable, + -- e.g. the following is rejected: + -- class C (m :: * -> *) where + -- type F (m :: *) = ... + check_hs_bndr_kind :: Name -> Kind -> HsBndrKind GhcRn -> TcM () + check_hs_bndr_kind _ _ (HsBndrNoKind _) = return () + check_hs_bndr_kind name parent_kind (HsBndrKind _ kind) = + do { kind' <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) kind + ; discardResult $ + unifyKind (Just $ NameThing name) kind' parent_kind } + +tcHsBndrVarName :: HsBndrVar GhcRn -> TcM Name +tcHsBndrVarName (HsBndrVar _ (L _ name)) = return name +tcHsBndrVarName (HsBndrWildCard _) = newSysName (mkTyVarOcc "_") + +mk_tvb_pairs :: HsTyVarBndr flag GhcRn -> TcTyVar -> [(Name, TcTyVar)] +mk_tvb_pairs tvb tv = + case hsTyVarName tvb of + Nothing -> [] + Just nm -> [(nm, tv)] + +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 :: HasDebugCallStack => SkolemMode +smVanilla = SM { sm_clone = panic "sm_clone" -- We always override this + , sm_parent = False + , sm_tvtv = pprPanic "sm_tvtv" callStackDoc -- We always override this + , sm_kind = AnyKind + , sm_holes = Nothing } + +{- Note [Cloning for type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes we must clone the Name of a type variable binder (written in +the source program); and sometimes we must not. This is controlled by +the sm_clone field of SkolemMode. + +In some cases it doesn't matter whether or not we clone. Perhaps +it'd be better to use MustClone/MayClone/MustNotClone. + +When we /must not/ clone +* In the binders of a type signature (tcOuterTKBndrs) + f :: forall a{27}. blah + f = rhs + Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType), + we must get the type (forall a{27}. blah) for the Id f, because + we bring that type variable into scope when we typecheck 'rhs'. + +* In the binders of a data family instance (bindOuterFamEqnTKBndrs) + data instance + forall p q. D (p,q) = D1 p | D2 q + We kind-check the LHS in tcDataFamInstHeader, and then separately + (in tcDataFamInstDecl) bring p,q into scope before looking at the + the constructor decls. + +* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone + We take advantage of this in kcInferDeclHeader: + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + If we cloned, we'd need to take a bit more care here; not hard. + +* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone. + There is no need, I think. + + The payoff here is that avoiding gratuitous cloning means that we can + almost always take the fast path in swizzleTcTyConBndrs. + +When we /must/ clone. +* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning + + This for a narrow and tricky reason which, alas, I couldn't find a + simpler way round. #16221 is the poster child: + + data SameKind :: k -> k -> * + data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int + + When kind-checking T, we give (a :: kappa1). Then: + + - In kcConDecl we make a TyVarTv unification variable kappa2 for k2 + (as described in Note [Using TyVarTvs for kind-checking GADTs], + even though this example is an existential) + - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv + - We end up unifying kappa1 := kappa2, because of the (SameKind a b) + + Now we generalise over kappa2. But if kappa2's Name is precisely k2 + (i.e. we did not clone) we'll end up giving T the utterly final kind + T :: forall k2. k2 -> * + Nothing directly wrong with that but when we typecheck the data constructor + we have k2 in scope; but then it's brought into scope /again/ when we find + the forall k2. This is chaotic, and we end up giving it the type + MkT :: forall k2 (a :: k2) k2 (b :: k2). + SameKind @k2 a b -> Int -> T @{k2} a + which is bogus -- because of the shadowing of k2, we can't + apply T to the kind or a! + + And there no reason /not/ to clone the Name when making a unification + variable. So that's what we do. +-} + +-------------------------------------- +-- Binding type/class variables in the +-- kind-checking and typechecking phases +-------------------------------------- + +bindTyClTyVars :: Name -> ([TcTyConBinder] -> TcKind -> TcM a) -> TcM a +-- ^ Bring into scope the binders of a PolyTcTyCon +-- Used for the type variables of a type or class decl +-- in the "kind checking" and "type checking" pass, +-- but not in the initial-kind run. +bindTyClTyVars tycon_name thing_inside + = do { tycon <- tcLookupTcTyCon tycon_name -- The tycon is a PolyTcTyCon + ; let res_kind = tyConResKind tycon + binders = tyConBinders tycon + ; traceTc "bindTyClTyVars" (ppr tycon_name $$ ppr binders) + ; tcExtendTyVarEnv (binderVars binders) $ + thing_inside binders res_kind } + +bindTyClTyVarsAndZonk :: Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a +-- Like bindTyClTyVars, but in addition +-- zonk the skolem TcTyVars of a PolyTcTyCon to TyVars +-- We always do this same zonking after a call to bindTyClTyVars, but +-- here we do it right away because there are no more unifications to come +bindTyClTyVarsAndZonk tycon_name thing_inside + = bindTyClTyVars tycon_name $ \ tc_bndrs tc_kind -> + do { (bndrs, kind) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { kind <- zonkTcTypeToTypeX tc_kind + ; return (bndrs, kind) } + ; thing_inside bndrs kind } + + +{- ********************************************************************* +* * + Kind generalisation +* * +********************************************************************* -} + +zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] +zonkAndScopedSort spec_tkvs + = do { spec_tkvs <- liftZonkM $ zonkTcTyVarsToTcTyVars spec_tkvs + -- Zonk the kinds, to we can do the dependency analysis + + -- Do a stable topological sort, following + -- Note [Ordering of implicit variables] in GHC.Rename.HsType + ; return (scopedSort spec_tkvs) } + +-- | Generalize some of the free variables in the given type. +-- All such variables should be *kind* variables; any type variables +-- should be explicitly quantified (with a `forall`) before now. +-- +-- The WantedConstraints are un-solved kind constraints. Generally +-- they'll be reported as errors later, but meanwhile we refrain +-- from quantifying over any variable free in these unsolved +-- constraints. See Note [Failure in local type signatures]. +-- +-- But in all cases, generalize only those variables whose TcLevel is +-- strictly greater than the ambient level. This "strictly greater +-- than" means that you likely need to push the level before creating +-- whatever type gets passed here. +-- +-- Any variable whose level is greater than the ambient level but is +-- not selected to be generalized will be promoted. (See [Promoting +-- unification variables] in "GHC.Tc.Solver" and Note [Recipe for +-- checking a signature].) +-- +-- The resulting KindVar are the variables to quantify over, in the +-- correct, well-scoped order. They should generally be Inferred, not +-- Specified, but that's really up to the caller of this function. +kindGeneralizeSome :: SkolemInfo + -> WantedConstraints + -> TcType -- ^ needn't be zonked + -> TcM [KindVar] +kindGeneralizeSome skol_info wanted kind_or_type + = do { -- Use the "Kind" variant here, as any types we see + -- here will already have all type variables quantified; + -- thus, every free variable is really a kv, never a tv. + ; dvs <- candidateQTyVarsOfKind kind_or_type + ; filtered_dvs <- filterConstrainedCandidates wanted dvs + ; traceTc "kindGeneralizeSome" $ + vcat [ text "type:" <+> ppr kind_or_type + , text "dvs:" <+> ppr dvs + , text "filtered_dvs:" <+> ppr filtered_dvs ] + ; quantifyTyVars skol_info DefaultNonStandardTyVars filtered_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 +-- decidePromotedTyVars 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 <- liftZonkM $ zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) + ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs) + ; _ <- promoteTyVarSet to_promote + ; return dvs' } + +-- |- Specialised version of 'kindGeneralizeSome', but with empty +-- WantedConstraints, so no filtering is needed +-- i.e. kindGeneraliseAll = kindGeneralizeSome emptyWC +kindGeneralizeAll :: SkolemInfo -> TcType -> TcM [KindVar] +kindGeneralizeAll skol_info kind_or_type + = do { traceTc "kindGeneralizeAll" (ppr kind_or_type) + ; dvs <- candidateQTyVarsOfKind kind_or_type + ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs } + +-- | Specialized version of 'kindGeneralizeSome', but where no variables +-- can be generalized, but perhaps some may need to be promoted. +-- Use this variant when it is unknowable whether metavariables might +-- later be constrained. +-- +-- To see why this promotion is needed, see +-- Note [Recipe for checking a signature], and especially +-- Note [Promotion in signatures]. +kindGeneralizeNone :: TcType -- needn't be zonked + -> TcM () +kindGeneralizeNone kind_or_type + = do { traceTc "kindGeneralizeNone" (ppr kind_or_type) + ; dvs <- candidateQTyVarsOfKind kind_or_type + ; _ <- promoteTyVarSet (candidateKindVars dvs) + ; return () } + +{- Note [Levels and generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = e +with no type signature. We are currently at level i. +We must + * Push the level to level (i+1) + * Allocate a fresh alpha[i+1] for the result type + * Check that e :: alpha[i+1], gathering constraint WC + * Solve WC as far as possible + * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i] + * Find the free variables with level > i, in this case gamma[i] + * Skolemise those free variables and quantify over them, giving + f :: forall g. beta[i-1] -> g + * Emit the residual constraint wrapped in an implication for g, + thus forall g. WC + +All of this happens for types too. Consider + f :: Int -> (forall a. Proxy a -> Int) + +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do kind generalisation only at the outer level of a type signature. +For example, consider + T :: forall k. k -> * + f :: (forall a. T a -> Int) -> Int +When kind-checking f's type signature we generalise the kind at +the outermost level, thus: + f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! +and *not* at the inner forall: + f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! +Reason: same as for HM inference on value level declarations, +we want to infer the most general type. The f2 type signature +would be *less applicable* than f1, because it requires a more +polymorphic argument. + +NB: There are no explicit kind variables written in f's signature. +When there are, the renamer adds these kind variables to the list of +variables bound by the forall, so you can indeed have a type that's +higher-rank in its kind. But only by explicit request. + +Note [Kinds of quantified type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyVarBndrsGen quantifies over a specified list of type variables, +*and* over the kind variables mentioned in the kinds of those tyvars. + +Note that we must zonk those kinds (obviously) but less obviously, we +must return type variables whose kinds are zonked too. Example + (a :: k7) where k7 := k9 -> k9 +We must return + [k9, a:k9->k9] +and NOT + [k9, a:k7] +Reason: we're going to turn this into a for-all type, + forall k9. forall (a:k7). blah +which the type checker will then instantiate, and instantiate does not +look through unification variables! + +Hence using zonked_kinds when forming tvs'. + +-} + +----------------------------------- +maybeEtaExpandAlgTyCon :: TyConFlavour tc -> SkolemInfo + -> [TcTyConBinder] -> Kind + -> TcM ([TcTyConBinder], Kind) +maybeEtaExpandAlgTyCon flav skol_info tcbs res_kind + | needsEtaExpansion flav + = etaExpandAlgTyCon skol_info tcbs res_kind + | otherwise + = return ([], res_kind) + +etaExpandAlgTyCon :: SkolemInfo + -> [TcTyConBinder] -> Kind + -> TcM ([TcTyConBinder], Kind) +etaExpandAlgTyCon skol_info tcbs res_kind + = splitTyConKind skol_info in_scope avoid_occs res_kind + where + tyvars = binderVars tcbs + in_scope = mkInScopeSetList tyvars + avoid_occs = map getOccName tyvars + +needsEtaExpansion :: TyConFlavour tc -> 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 + ; new_uniqs <- getUniquesM + ; rdr_env <- getLocalRdrEnv + ; lvl <- getTcLevel + ; let new_occs = Inf.filter (\ occ -> + isNothing (lookupLocalRdrOcc rdr_env occ) && + -- Note [Avoid name clashes for associated data types] + not (occ `elem` avoid_occs)) $ mkOccName tvName <$> allNameStrings + subst = mkEmptySubst in_scope + details = SkolemTv skol_info (pushTcLevel lvl) False + -- As always, allocate skolems one level in + + go occs uniqs subst acc kind + = case splitPiTy_maybe kind of + Nothing -> (reverse acc, substTy subst kind) + + Just (Anon arg af, kind') + -> assert (af == FTF_T_T) $ + go occs' uniqs' subst' (tcb : acc) kind' + where + tcb = Bndr tv AnonTCB + arg' = substTy subst (scaledThing arg) + name = mkInternalName uniq occ loc + tv = mkTcTyVar name arg' details + subst' = extendSubstInScope subst tv + (uniq,uniqs') = case uniqs of + uniq:uniqs' -> (uniq,uniqs') + _ -> panic "impossible" + Inf occ occs' = occs + + Just (Named (Bndr tv vis), kind') + -> go occs uniqs subst' (tcb : acc) kind' + where + tcb = Bndr tv' (NamedTCB vis) + tc_tyvar = mkTcTyVar (tyVarName tv) (tyVarKind tv) details + (subst', tv') = substTyVarBndr subst tc_tyvar + + ; return (go new_occs new_uniqs subst [] kind) } + +isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool +isAllowedDataResKind AnyTYPEKind kind = isTypeLikeKind kind +isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind +isAllowedDataResKind LiftedKind kind = tcIsLiftedTypeKind kind + +-- | Checks that the return kind in a data declaration's kind signature is +-- permissible. There are three cases: +-- +-- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ +-- declaration, check that the return kind is @Type@. +-- +-- If the declaration is a @newtype@ or @newtype instance@ and the +-- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so +-- that a return kind of the form @TYPE r@ (for some @r@) is permitted. +-- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl". +-- +-- If dealing with a @data family@ declaration, check that the return kind is +-- either of the form: +-- +-- 1. @TYPE r@ (for some @r@), or +-- +-- 2. @k@ (where @k@ is a bare kind variable; see #12369) +-- +-- See also Note [Datatype return kinds] in "GHC.Tc.TyCl" +checkDataKindSig :: DataSort -> Kind -- any arguments in the kind are stripped off + -> TcM () +checkDataKindSig data_sort kind + = do { dflags <- getDynFlags + ; traceTc "checkDataKindSig" (ppr kind) + ; checkTc (tYPE_ok dflags || is_kind_var) + (err_msg dflags) } + where + res_kind = snd (tcSplitPiTys kind) + -- Look for the result kind after + -- peeling off any foralls and arrows + + is_newtype :: Bool + is_newtype = + case data_sort of + DataDeclSort new_or_data -> new_or_data == NewType + DataInstanceSort new_or_data -> new_or_data == NewType + DataFamilySort -> False + + is_datatype :: Bool + is_datatype = + case data_sort of + DataDeclSort DataType -> True + DataInstanceSort DataType -> True + _ -> False + + is_data_family :: Bool + is_data_family = + case data_sort of + DataDeclSort{} -> False + DataInstanceSort{} -> False + DataFamilySort -> True + + allowed_kind :: DynFlags -> AllowedDataResKind + allowed_kind dflags + | is_newtype && xopt LangExt.UnliftedNewtypes dflags + -- With UnliftedNewtypes, we allow kinds other than Type, but they + -- must still be of the form `TYPE r` since we don't want to accept + -- Constraint or Nat. + -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl. + = AnyTYPEKind + | is_data_family + -- If this is a `data family` declaration, we don't need to check if + -- UnliftedNewtypes is enabled, since data family declarations can + -- have return kind `TYPE r` unconditionally (#16827). + = AnyTYPEKind + | is_datatype && xopt LangExt.UnliftedDatatypes dflags + -- With UnliftedDatatypes, we allow kinds other than Type, but they + -- must still be of the form `TYPE (BoxedRep l)`, so that we don't + -- accept result kinds like `TYPE IntRep`. + -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl. + = AnyBoxedKind + | otherwise + = LiftedKind + + tYPE_ok :: DynFlags -> Bool + tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind + + -- In the particular case of a data family, permit a return kind of the + -- form `:: k` (where `k` is a bare kind variable). + is_kind_var :: Bool + is_kind_var | is_data_family = isJust (getCastedTyVar_maybe res_kind) + | otherwise = False + + err_msg :: DynFlags -> TcRnMessage + err_msg dflags = + TcRnInvalidReturnKind data_sort (allowed_kind dflags) kind (ext_hint dflags) + + ext_hint dflags + | isTypeLikeKind kind + , is_newtype + , not (xopt LangExt.UnliftedNewtypes dflags) + = Just SuggestUnliftedNewtypes + | tcIsBoxedTypeKind kind + , is_datatype + , not (xopt LangExt.UnliftedDatatypes dflags) + = Just SuggestUnliftedDatatypes + | otherwise + = Nothing + +-- | Checks that the result kind of a class is exactly `Constraint`, rejecting +-- type synonyms and type families that reduce to `Constraint`. See #16826. +checkClassKindSig :: Kind -> TcM () +checkClassKindSig kind = checkTc (isConstraintKind kind) err_msg + where + err_msg :: TcRnMessage + err_msg = TcRnClassKindNotConstraint kind + +tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] +-- Result is in 1-1 correspondence with orig_args +tcbVisibilities tc orig_args + = go (tyConKind tc) init_subst orig_args + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) + go _ _ [] + = [] + + go fun_kind subst all_args@(arg : args) + | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind + = case tcb of + Anon _ af -> assert (af == FTF_T_T) $ + AnonTCB : go inner_kind subst args + Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args + where + subst' = extendTCvSubst subst tv arg + + | not (isEmptyTCvSubst subst) + = go (substTy subst fun_kind) init_subst all_args + + | otherwise + = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) + + +{- Note [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 (UserLHsSigType sig_ty) $ + do { mode <- mkHoleMode TypeLevel HM_Sig + ; (outer_bndrs, (wcs, wcx, theta, tau)) + <- solveEqualities "tcHsPartialSigType" $ + -- See Note [Failure in local type signatures] + bindNamedWildCardBinders sig_wcs $ \ wcs -> + bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $ + do { -- Instantiate the type-class context; but if there + -- is an extra-constraints wildcard, just discard it here + (theta, wcx) <- tcPartialContext mode hs_ctxt + + ; ek <- newOpenTypeKind + ; tau <- -- Don't do (addTypeCtxt hs_tau) here else we get + -- In the type + -- In the type signature: foo :: + tc_check_lhs_type mode hs_tau ek + + ; return (wcs, wcx, theta, tau) } + + ; traceTc "tcHsPartialSigType 2" empty + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs + ; traceTc "tcHsPartialSigType 3" empty + + -- No kind-generalization here: + ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $ + tcMkPhiTy theta $ + tau) + + -- Spit out the wildcards (including the extra-constraints one) + -- as "hole" constraints, so that they'll be reported if necessary + -- See Note [Extra-constraint holes in partial type signatures] + ; mapM_ emitNamedTypeHole wcs + + -- The "tau" from tcHsPartialSigType might very well have some foralls + -- at the top, hidden behind a type synonym. Instantiate them! E.g. + -- type T x = forall b. x -> b -> b + -- f :: forall a. T (a,_) + -- We must instantiate the `forall b` just as we do the `forall a`! + -- Missing this led to #21667. + ; (tv_prs', theta', tau) <- tcInstTypeBndrs tau + + -- We return a proper (Name,InvisTVBinder) environment, to be sure that + -- we bring the right name into scope in the function body. + -- Test case: partial-sigs/should_compile/LocalDefinitionBug + ; let outer_bndr_names :: [Name] + outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs + tv_prs :: [(Name,InvisTVBinder)] + tv_prs = outer_bndr_names `zip` outer_tv_bndrs + + -- Zonk, so that any nested foralls can "see" their occurrences + -- See Note [Checking partial type signatures], and in particular + -- Note [Levels for wildcards] + ; (tv_prs, theta, tau) <- liftZonkM $ + do { tv_prs <- mapSndM zonkInvisTVBinder (tv_prs ++ tv_prs') + ; theta <- mapM zonkTcType (theta ++ theta') + ; tau <- zonkTcType tau + ; return (tv_prs, theta, tau) } + + -- NB: checkValidType on the final inferred type will be + -- done later by checkInferredPolyId. We can't do it + -- here because we don't have a complete type to check + + ; traceTc "tcHsPartialSigType" (ppr tv_prs) + ; return (wcs, wcx, tv_prs, theta, tau) } + +tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType) +tcPartialContext _ Nothing = return ([], Nothing) +tcPartialContext mode (Just (L _ hs_theta)) + | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta + , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last + = do { wc_tv_ty <- setSrcSpanA wc_loc $ + tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind + ; theta <- mapM (tc_lhs_pred mode) hs_theta1 + ; return (theta, Just wc_tv_ty) } + | otherwise + = do { theta <- mapM (tc_lhs_pred mode) hs_theta + ; return (theta, Nothing) } + +{- Note [Checking partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note is about tcHsPartialSigType. See also +Note [Recipe for checking a signature] + +When we have a partial signature like + f :: forall a. a -> _ +we do the following + +* tcHsPartialSigType does not make quantified type (forall a. blah) + and then instantiate it -- it makes no sense to instantiate a type + with wildcards in it. Rather, tcHsPartialSigType just returns the + 'a' and the 'blah' separately. + + Nor, for the same reason, do we push a level in tcHsPartialSigType. + +* We instantiate 'a' to a unification variable, a TyVarTv, and /not/ + a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv. Consider + f :: forall a. a -> _ + g :: forall b. _ -> b + f = g + g = f + They are typechecked as a recursive group, with monomorphic types, + so 'a' and 'b' will get unified together. Very like kind inference + for mutually recursive data types (sans CUSKs or SAKS); see + Note [Cloning for type variable binders] + +* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike + the companion CompleteSig) contains the original, as-yet-unchecked + source-code LHsSigWcType + +* Then, for f and g /separately/, we call tcInstSig, which in turn + call tcHsPartialSig (defined near this Note). It kind-checks the + LHsSigWcType, creating fresh unification variables for each "_" + wildcard. It's important that the wildcards for f and g are distinct + because they might get instantiated completely differently. E.g. + f,g :: forall a. a -> _ + f x = a + g x = True + It's really as if we'd written two distinct signatures. + +* Nested foralls. See Note [Levels for wildcards] + +* Just as for ordinary signatures, we must solve local equalities and + zonk the type after kind-checking it, to ensure that all the nested + forall binders can "see" their occurrences + + Just as for ordinary signatures, this zonk also gets any Refl casts + out of the way of instantiation. Example: #18008 had + foo :: (forall a. (Show a => blah) |> Refl) -> _ + and that Refl cast messed things up. See #18062. + +Note [Levels for wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall b. (forall a. a -> _) -> b +We do /not/ allow the "_" to be instantiated to 'a'; although we do +(as before) allow it to be instantiated to the (top level) 'b'. +Why not? Suppose + f x = (x True, x 'c') + +During typecking the RHS we must instantiate that (forall a. a -> _), +so we must know /precisely/ where all the a's are; they must not be +hidden under (possibly-not-yet-filled-in) unification variables! + +We achieve this as follows: + +- For /named/ wildcards such sas + g :: forall b. (forall la. a -> _x) -> b + there is no problem: we create them at the outer level (ie the + ambient level of the signature itself), and push the level when we + go inside a forall. So now the unification variable for the "_x" + can't unify with skolem 'a'. + +- For /anonymous/ wildcards, such as 'f' above, we carry the ambient + level of the signature to the hole in the TcLevel part of the + mode_holes field of TcTyMode. Then, in tcAnonWildCardOcc we us that + level (and /not/ the level ambient at the occurrence of "_") to + create the unification variable for the wildcard. That is the sole + purpose of the TcLevel in the mode_holes field: to transport the + ambient level of the signature down to the anonymous wildcard + occurrences. + +Note [Extra-constraint holes in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: (_) => a -> a + f x = ... + +* The renamer leaves '_' untouched. + +* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in + tcWildCardBinders. + +* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar + with the inferred constraints, e.g. (Eq a, Show a) + +* GHC.Tc.Errors.mkHoleError finally reports the error. + +An annoying difficulty happens if there are more than 64 inferred +constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple. +Where do we find the TyCon? For good reasons we only have constraint +tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types). So how +can we make a 70-tuple? This was the root cause of #14217. + +It's incredibly tiresome, because we only need this type to fill +in the hole, to communicate to the error reporting machinery. Nothing +more. So I use a HACK: + +* I make an /ordinary/ tuple of the constraints, in + GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because + ordinary tuples can't contain constraints, but it works fine. And for + ordinary tuples we don't have the same limit as for constraint + tuples (which need selectors and an associated class). + +* Because it is ill-kinded (unifying something of kind Constraint with + something of kind Type), it should trip an assert in writeMetaTyVarRef. + +Result works fine, but it may eventually bite us. + +See also Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver for +information about how these are printed. + +************************************************************************ +* * + Pattern signatures (i.e signatures that occur in patterns) +* * +********************************************************************* -} + +tcHsPatSigType :: UserTypeCtxt + -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications. + -> HsPatSigType GhcRn -- The type signature + -> ContextKind -- What kind is expected + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , TcType) -- The type +-- Used for type-checking type signatures in +-- (a) patterns e.g f (x::Int) = e +-- (b) RULE forall bndrs e.g. forall (x::Int). f x = x +-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type +-- +-- This may emit constraints +-- See Note [Recipe for checking a signature] +tcHsPatSigType ctxt hole_mode + (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns } + , hsps_body = hs_ty }) + ctxt_kind + = tc_type_in_pat ctxt Nothing hole_mode hs_ty sig_wcs sig_ns ctxt_kind + +tcRuleBndrSig :: Name + -> SkolemInfo + -> HsPatSigType GhcRn -- The type signature + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , TcType) -- The type +-- Used for type-checking type signatures in +-- 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] +tcRuleBndrSig name skol_info + (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns } + , hsps_body = hs_ty }) + = tc_type_in_pat (RuleBndrTypeCtxt name) (Just skol_info) + HM_Sig hs_ty sig_wcs sig_ns OpenKind + +-- Typecheck type patterns, in data constructor patterns, e.g +-- f (MkT @a @(Maybe b) ...) = ... +-- +-- We have two completely separate typing rules, +-- one for binder type patterns (handled by `tc_bndr_in_pat`) +-- one for unifier type patterns (handled by `tc_type_in_pat`) +-- The two cases are distinguished by `tyPatToBndr`. +-- See Note [Type patterns: binders and unifiers] +tcHsTyPat :: HsTyPat GhcRn -- The type pattern + -> Kind -- What kind is expected + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , TcType) -- The type +tcHsTyPat hs_pat@(HsTP{hstp_ext = hstp_rn, hstp_body = hs_ty}) expected_kind + = case tyPatToBndr hs_pat of + Nothing -> tc_unif_in_pat hs_ty wcs all_ns (TheKind expected_kind) + Just bndr -> tc_bndr_in_pat bndr wcs imp_ns expected_kind + where + all_ns = imp_ns ++ exp_ns + HsTPRn{hstp_nwcs = wcs, hstp_imp_tvs = imp_ns, hstp_exp_tvs = exp_ns} = hstp_rn + tc_unif_in_pat = tc_type_in_pat TypeAppCtxt Nothing HM_TyAppPat + +-- `tc_bndr_in_pat` is used in type patterns to handle the binders case. +-- See Note [Type patterns: binders and unifiers] +tc_bndr_in_pat :: HsTyVarBndr flag GhcRn + -> [Name] -- All named wildcards in type + -> [Name] -- Implicit (but not explicit) binders in type + -> Kind -- Expected kind + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , TcType) -- The type +tc_bndr_in_pat bndr wcs imp_ns expected_kind = do + let HsTvb { tvb_var = bvar, tvb_kind = bkind } = bndr + traceTc "tc_bndr_in_pat 1" (ppr expected_kind) + name <- tcHsBndrVarName bvar + tv <- newPatTyVar name expected_kind + case bkind of + HsBndrNoKind _ -> + pure ([], mk_tvb_pairs bndr tv, mkTyVarTy tv) + HsBndrKind _ ki -> do + tkv_prs <- mapM new_implicit_tv imp_ns + wcs <- addTypeCtxt ki $ + solveEqualities "tc_bndr_in_pat" $ + -- See Note [Failure in local type signatures] + -- and c.f #16033 + bindNamedWildCardBinders wcs $ \ wcs -> + tcExtendNameTyVarEnv tkv_prs $ + do { tcHsTvbKind bvar ki expected_kind + ; pure wcs } + + mapM_ emitNamedTypeHole wcs + + traceTc "tc_bndr_in_pat 2" $ vcat + [ text "expected_kind" <+> ppr expected_kind + , text "wcs" <+> ppr wcs + , text "(name,tv)" <+> ppr (name,tv) + , text "tkv_prs" <+> ppr tkv_prs] + + let tvb_prs = mk_tvb_pairs bndr tv + pure (wcs, tvb_prs ++ tkv_prs, mkTyVarTy tv) + where + new_implicit_tv name + = do { kind <- newMetaKindVar + ; tv <- newPatTyVar name kind + -- NB: tv's Name is fresh + ; return (name, tv) } + +-- * In type patterns `tc_type_in_pat` is used to handle the unifiers case. +-- See Note [Type patterns: binders and unifiers] +-- +-- * In patterns `tc_type_in_pat` is used to check pattern signatures. +tc_type_in_pat :: UserTypeCtxt + -> Maybe SkolemInfo -- Just sk for RULE and SPECIALISE pragmas only + -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications. + -> LHsType GhcRn -- The type in pattern + -> [Name] -- All named wildcards in type + -> [Name] -- All binders in type + -> 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 +tc_type_in_pat ctxt mb_skol hole_mode hs_ty wcs ns ctxt_kind + = addSigCtxt ctxt (UserLHsType hs_ty) $ + do { tkvs <- mapM new_implicit_tv ns + ; let tkv_prs = ns `zip` tkvs + ; mode <- mkHoleMode TypeLevel hole_mode + ; (wcs, ty) + <- addTypeCtxt hs_ty $ + solveEqualities "tc_type_in_pat" $ + -- See Note [Failure in local type signatures] + -- and c.f #16033 + bindNamedWildCardBinders wcs $ \ wcs -> + tcExtendNameTyVarEnv tkv_prs $ + do { ek <- newExpectedKind ctxt_kind + ; ty <- tc_check_lhs_type mode hs_ty ek + ; return (wcs, ty) } + + ; mapM_ emitNamedTypeHole wcs + + -- 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 ty + ; ty <- liftZonkM $ zonkTcType ty + ; checkValidType ctxt ty + + ; traceTc "tc_type_in_pat" (ppr tkv_prs) + ; return (wcs, tkv_prs, ty) } + where + new_implicit_tv name + = do { kind <- newMetaKindVar + ; case mb_skol of + Just skol_info -> newSkolemTyVar skol_info name kind + Nothing -> newPatTyVar name kind } + -- See Note [Typechecking pattern signature binders] + -- NB: tv's Name may be fresh (in the case of newPatTyVar) + +-- See Note [Type patterns: binders and unifiers] +tyPatToBndr :: HsTyPat GhcRn -> Maybe (HsTyVarBndr () GhcRn) +tyPatToBndr HsTP{hstp_body = (L _ hs_ty)} = go hs_ty where + go :: HsType GhcRn -> Maybe (HsTyVarBndr () GhcRn) + go (HsParTy _ (L _ ty)) = go ty + go (HsKindSig _ (L _ ty) ki) = do + bvar <- go_bvar ty + let bkind = HsBndrKind noExtField ki + Just (HsTvb noAnn () bvar bkind) + go ty = do + bvar <- go_bvar ty + let bkind = HsBndrNoKind noExtField + Just (HsTvb noAnn () bvar bkind) + + go_bvar :: HsType GhcRn -> Maybe (HsBndrVar GhcRn) + go_bvar (HsTyVar _ _ tv) + | isTyVarName (getName tv) + = Just (HsBndrVar noExtField (fmap getName tv)) + go_bvar (HsWildCardTy _) + = Just (HsBndrWildCard noExtField) + go_bvar _ = Nothing + +{- Note [Type patterns: binders and unifiers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type pattern, of type `HsTyPat`, represents a type argument in a data +constructor pattern. For example + f (MkT @a @(Maybe b) p q) = ... +Here the `@a` and `@(Maybe b)` are type patterns. In general, then a +`HsTyPat` is represented by a `HsType`. + +However, for /typechecking/ purposes (only) we distinguish two categories of +type pattern: +* Binder type patterns +* Unifier type patterns + +Binder type patterns are a subset of type patterns described by the following grammar: + + bvar ::= tv | '_' -- type variable or wildcard + tp_bndr ::= + bvar -- plain binder + | bvar '::' kind -- binder with kind annotation + | '(' tp_bndr ')' -- parentheses + +This subset of HsTyPat can be represented by HsTyVarBndr, which is also used +in foralls and type declaration headers. + +Unifier type patterns include all other forms of type patterns, such as `Maybe x`. +This distinction allows the typechecker to accept more programs. +Consider this example from #18986: + + data T where + MkT :: forall (f :: forall k. k -> Type). + f Int -> f Maybe -> T + + k :: T -> () + k (MkT @f (x :: f Int) (y :: f Maybe)) = () + +In general case (if we treat `f` as a unifier) we would create a metavariable for its kind: + f :: kappa +Checking `x :: f Int` would unify + kappa := Type -> Type +and then checking `y :: f Maybe` would unify + kappa := (Type -> Type) -> Type +leading to a type error: + • Expecting one more argument to ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + +However, `@f` is a simple type variable binder, we don't need a metavariable for its kind, we +can add it directly to the context with its polymorphic kind: + f :: forall k . k -> Type +This way both `f Int` and `f Maybe` can be accepted because `k` can be instantiated differently at +each call site. + +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)) = + +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 '' 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 (KindCtxt hs_kind) $ + solveEqualities "tcLHsKindSig" $ + tc_check_lhs_type mode hs_kind liftedTypeKind + ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) + -- No generalization: + ; kindGeneralizeNone kind + ; kind <- liftZonkM $ zonkTcType kind + -- This zonk is very important in the case of higher rank kinds + -- E.g. #13879 f :: forall (p :: forall z (y::z). ). + -- + -- When instantiating p's kind at occurrences of p in + -- it's crucial that the kind we instantiate is fully zonked, + -- else we may fail to substitute properly + + ; checkValidType ctxt kind + ; traceTc "tcLHsKindSig2" (ppr kind) + ; return kind } + +promotionErr :: Name -> PromotionErr -> TcM a +promotionErr name err + = failWithTc $ TcRnUnpromotableThing name err + +{- +************************************************************************ +* * + Utils for constructing TyLit +* * +************************************************************************ +-} + + +tyLitFromLit :: HsLit GhcRn -> Maybe (HsTyLit GhcRn) +tyLitFromLit (HsString x str) = Just (HsStrTy x str) +tyLitFromLit (HsMultilineString x str) = Just (HsStrTy x str) +tyLitFromLit (HsChar x char) = Just (HsCharTy x char) +tyLitFromLit _ = Nothing + +tyLitFromOverloadedLit :: OverLitVal -> Maybe (HsTyLit GhcRn) +tyLitFromOverloadedLit (HsIntegral n) = Just $ HsNumTy NoSourceText (il_value n) +tyLitFromOverloadedLit (HsIsString _ s) = Just $ HsStrTy NoSourceText s +tyLitFromOverloadedLit HsFractional{} = Nothing diff --git a/GHC/Tc/Gen/Match.hs b/GHC/Tc/Gen/Match.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Match.hs @@ -0,0 +1,1311 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE PartialTypeSignatures #-} + +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Typecheck some @Matches@ +module GHC.Tc.Gen.Match + ( tcFunBindMatches + , tcCaseMatches + , tcLambdaMatches + , tcGRHSNE + , tcGRHSsPat + , TcStmtChecker + , TcExprStmtChecker + , TcCmdStmtChecker + , tcStmts + , tcStmtsAndThen + , tcDoStmts + , tcBody + , tcDoStmt + , tcGuardStmt + , checkArgCounts + ) +where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC + , tcMonoExprNC, tcExpr + , tcCheckMonoExpr, tcCheckMonoExprNC + , tcCheckPolyExpr, tcPolyLExpr ) + +import GHC.Rename.Utils ( bindLocalNames ) +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Pat +import GHC.Tc.Gen.Do +import GHC.Tc.Gen.Head( tcCheckId ) +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Gen.Bind +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) +import GHC.Tc.Utils.Unify +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Rename.Env ( irrefutableConLikeTc ) + +import GHC.Core.Multiplicity +import GHC.Core.UsageEnv +import GHC.Core.TyCon +-- Create chunkified tuple types for monad comprehensions +import GHC.Core.Make + +import GHC.Hs + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Id +import GHC.Types.SrcLoc +import GHC.Types.Basic( VisArity, isDoExpansionGenerated ) + +import qualified GHC.Data.List.NonEmpty as NE + +import Control.Monad +import Control.Arrow ( second ) +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (mapMaybe) + +import qualified GHC.LanguageExtensions as LangExt + + +{- +************************************************************************ +* * +\subsection{tcFunBindMatches, tcCaseMatches} +* * +************************************************************************ + +`tcFunBindMatches` typechecks a `[Match]` list which occurs in a +`FunBind`. The second argument is the name of the function, which +is used in error messages. It checks that all the equations have the +same number of arguments before using `tcMatches` to do the work. +-} + +tcFunBindMatches :: UserTypeCtxt + -> Name -- Function name + -> Mult -- The multiplicity of the binder + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] -- Scoped skolemised binders + -> ExpRhoType -- Expected type of function; caller + -- has skolemised any outer forall's + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +-- See Note [Skolemisation overview] in GHC.Tc.Utils.Unify +tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty + = assertPpr (funBindPrecondition matches) (pprMatches matches) $ + do { -- Check that they all have the same no of arguments + arity <- checkArgCounts matches + + ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) + + ; (wrap_fun, r) + <- matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> + tcScalingUsage mult $ + -- Makes sure that if the binding is unrestricted, it counts as + -- consuming its rhs Many times. + + do { traceTc "tcFunBindMatches 2" $ + vcat [ text "ctxt:" <+> pprUserTypeCtxt ctxt + , text "arity:" <+> ppr arity + , text "invis_pat_tys:" <+> ppr invis_pat_tys + , text "pat_tys:" <+> ppr pat_tys + , text "rhs_ty:" <+> ppr rhs_ty ] + ; tcMatches mctxt tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches } + + ; return (wrap_fun, r) } + where + mctxt = mkPrefixFunRhs (noLocA fun_name) noAnn + herald = ExpectedFunTyMatches (NameThing fun_name) matches + +funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool +funBindPrecondition (MG { mg_alts = L _ alts }) + = not (null alts) && all is_fun_rhs alts + where + is_fun_rhs (L _ (Match { m_ctxt = FunRhs {} })) = True + is_fun_rhs _ = False + +tcLambdaMatches :: HsExpr GhcRn -> HsLamVariant + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] -- Already skolemised + -> ExpSigmaType -- NB can be a sigma-type + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tcLambdaMatches e lam_variant matches invis_pat_tys res_ty + = do { arity <- checkArgCounts matches + -- Check argument counts since this is also used for \cases + + ; (wrapper, r) + <- matchExpectedFunTys herald GenSigCtxt arity res_ty $ \ pat_tys rhs_ty -> + tcMatches ctxt tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches + + ; return (wrapper, r) } + where + ctxt = LamAlt lam_variant + herald = ExpectedFunTyLam lam_variant e + -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify + + tc_body | isDoExpansionGenerated (mg_ext matches) + -- See Part 3. B. of Note [Expanding HsDo with XXExprGhcRn] in + -- `GHC.Tc.Gen.Do`. Testcase: Typeable1 + = tcBodyNC -- NB: Do not add any error contexts + -- It has already been done + | otherwise + = tcBody + +{- +@tcCaseMatches@ doesn't do the argument-count check because the +parser guarantees that each equation has exactly one argument. +-} + +tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc)) + => HsMatchContextRn + -> TcMatchAltChecker body -- ^ Typecheck the alternative RHSS + -> 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 + +tcCaseMatches ctxt tc_body (Scaled scrut_mult scrut_ty) matches res_ty + = tcMatches ctxt tc_body [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches + +-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. +tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType + -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) +-- Used for pattern bindings +tcGRHSsPat mult grhss res_ty + = tcScalingUsage mult $ tcGRHSs PatBindRhs tcBody grhss res_ty + +{- ********************************************************************* +* * + tcMatch +* * +********************************************************************* -} + +-- | Type checker for a body of a match alternative +type TcMatchAltChecker body -- c.f. TcStmtChecker, also in this module + = LocatedA (body GhcRn) + -> ExpRhoType + -> TcM (LocatedA (body GhcTc)) + +type AnnoBody body + = ( Outputable (body GhcRn) + , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA + , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnLW + , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnLW + , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO + , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO + , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA + , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + ) + +-- | Type-check a MatchGroup. +tcMatches :: (AnnoBody body, Outputable (body GhcTc)) + => HsMatchContextRn + -> TcMatchAltChecker body + -> [ExpPatType] -- ^ Expected pattern types. + -> ExpRhoType -- ^ Expected result-type of the Match. + -> MatchGroup GhcRn (LocatedA (body GhcRn)) + -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) + +tcMatches ctxt tc_body pat_tys rhs_ty (MG { mg_alts = L l matches + , mg_ext = origin }) + | null matches -- Deal with case e of {} + -- Since there are no branches, no one else will fill in rhs_ty + -- when in inference mode, so we must do it ourselves, + -- here, using expTypeToType + = do { tcEmitBindingUsage bottomUE + -- See Note [Pattern types for EmptyCase] + ; let vis_pat_tys = filter isVisibleExpPatType pat_tys + ; pat_ty <- case vis_pat_tys of + [ExpFunPatTy t] -> scaledExpTypeToType t + [ExpForAllPatTy tvb] -> failWithTc $ TcRnEmptyCase ctxt (EmptyCaseForall tvb) + [] -> panic "tcMatches: no arguments in EmptyCase" + _t1:(_t2:_ts) -> panic "tcMatches: multiple arguments in EmptyCase" + ; rhs_ty <- expTypeToType rhs_ty + ; return (MG { mg_alts = L l [] + , mg_ext = MatchGroupTc [pat_ty] rhs_ty origin + }) } + + | otherwise + = do { umatches <- mapM (tcCollectingUsage . tcMatch tc_body pat_tys rhs_ty) matches + ; let (usages, matches') = unzip umatches + ; tcEmitBindingUsage $ supUEs usages + ; pat_tys <- mapM readScaledExpType (filter_out_forall_pat_tys pat_tys) + ; rhs_ty <- readExpType rhs_ty + ; traceTc "tcMatches" (ppr matches' $$ ppr pat_tys $$ ppr rhs_ty) + ; return (MG { mg_alts = L l matches' + , mg_ext = MatchGroupTc pat_tys rhs_ty origin + }) } + where + -- We filter out foralls because we have no use for them in HsToCore. + filter_out_forall_pat_tys :: [ExpPatType] -> [Scaled ExpSigmaTypeFRR] + filter_out_forall_pat_tys = mapMaybe match_fun_pat_ty + where + match_fun_pat_ty (ExpFunPatTy t) = Just t + match_fun_pat_ty ExpForAllPatTy{} = Nothing + +{- Note [Pattern types for EmptyCase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In tcMatches, we might encounter an empty list of matches if the user wrote +`case x of {}` or `\case {}`. + +* First of all, both `case x of {}` and `\case {}` match on exactly one visible + argument, which follows from + + checkArgCounts :: MatchGroup GhcRn ... -> TcM VisArity + checkArgCounts (MG { mg_alts = L _ [] }) + = return 1 + ... + + So we expect vis_pat_tys to be a singleton list [pat_ty] and panic otherwise. + + Multi-case `\cases {}` can't violate this assumption in `tcMatches` because it + must have been rejected earlier in `rnMatchGroup`. + + Other MatchGroup contexts (function equations `f x = ...`, lambdas `\a b -> ...`, + etc) are not considered here because there is no syntax to construct them with + an empty list of alternatives. + +* With lambda-case, we run the risk of trying to match on a type argument: + + f :: forall (xs :: Type) -> () + f = \case {} + + This is not valid and it used to trigger a panic in pmcMatches (#25004). + We reject it by inspecting the expected pattern type: + + ; pat_ty <- case vis_pat_tys of + [ExpFunPatTy t] -> ... -- value argument, ok + [ExpForAllPatTy tvb] -> ... -- type argument, error! + + Test case: typecheck/should_fail/T25004 +-} + +------------- +tcMatch :: (AnnoBody body) + => TcMatchAltChecker body + -> [ExpPatType] -- Expected pattern types + -> ExpRhoType -- Expected result-type of the Match. + -> LMatch GhcRn (LocatedA (body GhcRn)) + -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) + +tcMatch tc_body pat_tys rhs_ty match + = do { (L loc r) <- wrapLocMA (tc_match pat_tys rhs_ty) match + ; return (L loc r) } + where + tc_match pat_tys rhs_ty + match@(Match { m_ctxt = ctxt, m_pats = L l pats, m_grhss = grhss }) + = add_match_ctxt $ + do { (pats', (grhss')) <- tcMatchPats ctxt pats pat_tys $ + tcGRHSs ctxt tc_body grhss rhs_ty + -- NB: pats' are just the /value/ patterns + -- See Note [tcMatchPats] in GHC.Tc.Gen.Pat + + ; return (Match { m_ext = noExtField + , m_ctxt = ctxt + , m_pats = L l pats' + , m_grhss = grhss' }) } + where + -- For (\x -> e), tcExpr has already said "In the expression \x->e" + -- so we don't want to add "In the lambda abstraction \x->e" + -- But for \cases with many alternatives, it is helpful to say + -- which particular alternative we are looking at + add_match_ctxt thing_inside = case ctxt of + LamAlt LamSingle -> thing_inside + StmtCtxt (HsDoStmt{}) -> thing_inside -- this is an expanded do stmt + _ -> addErrCtxt (MatchInCtxt match) thing_inside + +------------- +tcGRHSs :: AnnoBody body + => HsMatchContextRn + -> TcMatchAltChecker body + -> GRHSs GhcRn (LocatedA (body GhcRn)) + -> ExpRhoType + -> TcM (GRHSs GhcTc (LocatedA (body GhcTc))) +-- Notice that we pass in the full res_ty, so that we get +-- good inference from simple things like +-- f = \(x::forall a.a->a) -> +-- We used to force it to be a monotype when there was more than one guard +-- but we don't need to do that any more +tcGRHSs ctxt tc_body (GRHSs _ grhss binds) res_ty + = do { (binds', grhss') <- tcLocalBinds binds $ do + tcGRHSNE ctxt tc_body grhss res_ty + ; return (GRHSs emptyComments grhss' binds') } + +tcGRHSNE :: forall body. AnnoBody body + => HsMatchContextRn -> TcMatchAltChecker body + -> NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn))) -> ExpRhoType + -> TcM (NonEmpty (LGRHS GhcTc (LocatedA (body GhcTc)))) +tcGRHSNE ctxt tc_body grhss res_ty + = do { (usages, grhss') <- unzip <$> traverse (wrapLocSndMA tc_alt) grhss + ; tcEmitBindingUsage $ supUEs usages + ; return grhss' } + where + stmt_ctxt = PatGuard ctxt + + tc_alt :: GRHS GhcRn (LocatedA (body GhcRn)) + -> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc))) + tc_alt (GRHS _ guards rhs) + = tcCollectingUsage $ + do { (guards', rhs') + <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ + tc_body rhs + ; return (GRHS noAnn guards' rhs') } + +{- +************************************************************************ +* * +\subsection{@tcDoStmts@ typechecks a {\em list} of do statements} +* * +************************************************************************ +-} + +tcDoStmts :: HsDoFlavour + -> LocatedLW [LStmt GhcRn (LHsExpr GhcRn)] + -> ExpRhoType + -> TcM (HsExpr GhcTc) -- Returns a HsDo +tcDoStmts ListComp (L l stmts) res_ty + = do { res_ty <- expTypeToType res_ty + ; (co, elt_ty) <- matchExpectedListTy res_ty + ; let list_ty = mkListTy elt_ty + ; stmts' <- tcStmts (HsDoStmt ListComp) (tcLcStmt listTyCon) stmts + (mkCheckExpType elt_ty) + ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) } + +tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty + = do { isApplicativeDo <- xoptM LangExt.ApplicativeDo + ; if isApplicativeDo + then do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty + ; res_ty <- readExpType res_ty + ; return (HsDo res_ty doExpr (L l stmts')) } + else do { expanded_expr <- expandDoStmts doExpr stmts + -- Do expansion on the fly + ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> + tcExpr (unLoc expanded_expr) res_ty } + } + +tcDoStmts mDoExpr@(MDoExpr _) ss@(L _ stmts) res_ty + = do { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly + ; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$> + tcExpr (unLoc expanded_expr) res_ty } + +tcDoStmts MonadComp (L l stmts) res_ty + = do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty + ; res_ty <- readExpType res_ty + ; return (HsDo res_ty MonadComp (L l stmts')) } +tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt) + +tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) +tcBody body res_ty + = do { traceTc "tcBody" (ppr res_ty) + ; tcPolyLExpr body res_ty + } + +tcBodyNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) +tcBodyNC body res_ty + = do { traceTc "tcBodyNC" (ppr res_ty) + ; tcMonoExprNC body res_ty + } + +{- +************************************************************************ +* * +\subsection{tcStmts} +* * +************************************************************************ +-} + +type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType +type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType + +type TcStmtChecker body rho_type + = forall thing. HsStmtContextRn + -> 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) => HsStmtContextRn + -> TcStmtChecker body rho_type -- NB: higher-rank type + -> [LStmt GhcRn (LocatedA (body GhcRn))] + -> rho_type + -> TcM [LStmt GhcTc (LocatedA (body GhcTc))] +tcStmts ctxt stmt_chk stmts res_ty + = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ + const (return ()) + ; return stmts' } + +tcStmtsAndThen :: (AnnoBody body) => HsStmtContextRn + -> TcStmtChecker body rho_type -- NB: higher-rank type + -> [LStmt GhcRn (LocatedA (body GhcRn))] + -> rho_type + -> (rho_type -> TcM thing) + -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing) + +-- Note the higher-rank type. stmt_chk is applied at different +-- types in the equations for tcStmts + +tcStmtsAndThen _ _ [] res_ty thing_inside + = do { thing <- thing_inside res_ty + ; return ([], thing) } + +-- LetStmts are handled uniformly, regardless of context +tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x binds) : stmts) + res_ty thing_inside + = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ + tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside + ; return (L loc (LetStmt x binds') : stmts', thing) } + +-- Don't set the error context for an ApplicativeStmt. It ought to be +-- possible to do this with a popErrCtxt in the tcStmt case for +-- ApplicativeStmt, but it did something strange and broke a test (ado002). +tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside + | XStmtLR ApplicativeStmt{} <- stmt + = do { (stmt', (stmts', thing)) <- + stmt_chk ctxt stmt res_ty $ \ res_ty' -> + tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ + thing_inside + ; return (L loc stmt' : stmts', thing) } + + -- For the vanilla case, handle the location-setting part + | otherwise + = do { (stmt', (stmts', thing)) <- + setSrcSpanA loc $ + addErrCtxt (StmtErrCtxt ctxt stmt) $ + stmt_chk ctxt stmt res_ty $ \ res_ty' -> + popErrCtxt $ + tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ + thing_inside + ; return (L loc stmt' : stmts', thing) } + +--------------------------------------------------- +-- Pattern guards +--------------------------------------------------- + +tcGuardStmt :: TcExprStmtChecker +tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside + = do { guard' <- tcScalingUsage ManyTy $ tcCheckMonoExpr guard boolTy + -- Scale the guard to Many (see #19120 and #19193) + ; thing <- thing_inside res_ty + ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } + +tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside + = do { -- The Many on the next line and the unrestricted on the line after + -- are linked. These must be the same multiplicity. Consider + -- x <- rhs -> u + -- + -- The multiplicity of x in u must be the same as the multiplicity at + -- which the rhs has been consumed. When solving #18738, we want these + -- two multiplicity to still be the same. + (rhs', rhs_ty) <- tcScalingUsage ManyTy $ tcInferRhoNC rhs + -- Stmt has a context already + ; hasFixedRuntimeRep_syntactic FRRBindStmtGuard rhs_ty + ; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) + pat (unrestricted rhs_ty) $ + thing_inside res_ty + ; return (mkTcBindStmt pat' rhs', thing) } + +tcGuardStmt _ stmt _ _ + = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- List comprehensions +-- (no rebindable syntax) +--------------------------------------------------- + +-- Dealt with separately, rather than by tcMcStmt, because +-- a) We have special desugaring rules for list comprehensions, +-- which avoid creating intermediate lists. They in turn +-- assume that the bind/return operations are the regular +-- polymorphic ones, and in particular don't have any +-- coercion matching stuff in them. It's hard to avoid the +-- potential for non-trivial coercions in tcMcStmt + +{- +Note [Binding in list comprehension isn't linear] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In principle, [ y | () <- xs, y <- [0,1]] could be linear in `xs`. +But, the way the desugaring works, we get something like + +case xs of + () : xs ' -> letrec next_stmt = … xs' … + +In the current typing rules for letrec in Core, next_stmt is necessarily of +multiplicity Many and so is every free variable, including xs'. Which, in turns, +requires xs to be of multiplicity Many. + +Rodrigo Mesquita worked out, in his master thesis, how to make letrecs having +non-Many multiplicities. But it's a fair bit of work to implement. + +Since nobody actually cares about [ y | () <- xs, y <- [0,1]] being linear, then +we just conservatively make it unrestricted instead. + +If we're to change that, we have to be careful that [ y | _ <- xs, y <- [0,1]] +isn't linear in `xs` since the elements of `xs` are ignored. So we'd still have +to call `tcScalingUsage` on `xs` in `tcLcStmt`, we'd just have to create a fresh +multiplicity variable. We'd also use the same multiplicity variable in the call +to `tcCheckPat` instead of `unrestricted`. +-} + +tcLcStmt :: TyCon -- The list type constructor ([]) + -> TcExprStmtChecker + +tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside + = do { body' <- tcMonoExprNC body elt_ty + ; thing <- thing_inside (panic "tcLcStmt: thing_inside") + ; return (LastStmt x body' noret noSyntaxExpr, thing) } + +-- A generator, pat <- rhs +tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside + = do { pat_ty <- newFlexiTyVarTy liftedTypeKind + -- About the next `tcScalingUsage ManyTy` and unrestricted + -- see Note [Binding in list comprehension isn't linear] + ; rhs' <- tcScalingUsage ManyTy $ tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty]) + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ + tcScalingUsage ManyTy $ + thing_inside elt_ty + ; return (mkTcBindStmt pat' rhs', thing) } + +-- A boolean guard +tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside + = do { rhs' <- tcCheckMonoExpr rhs boolTy + ; thing <- tcScalingUsage ManyTy $ thing_inside elt_ty + ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } + +-- ParStmt: See notes with tcMcStmt and Note [Scoping in parallel list comprehensions] +tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside + = tcScalingUsage ManyTy $ -- parallel list comprehension never desugars to something linear. + do { env <- getLocalRdrEnv + ; (pairs', thing) <- loop env [] bndr_stmts_s + ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } + where + loop + :: LocalRdrEnv -> [Name] -> NonEmpty (ParStmtBlock GhcRn GhcRn) + -> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), _) + -- Invariant: on entry to `loop`, the LocalRdrEnv is set to + -- origEnv, the LocalRdrEnv for the entire comprehension + loop origEnv priorBinds (ParStmtBlock x stmts names _ :| pairs) + = do { (stmts', (ids, pairs', thing)) + <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> + do { ids <- tcLookupLocalIds names + ; (pairs', thing) <- setLocalRdrEnv origEnv $ + loop1 origEnv (names ++ priorBinds) pairs + ; return (ids, pairs', thing) } + ; return ( ParStmtBlock x stmts' ids noSyntaxExpr :| pairs', thing ) } + + loop1 + :: LocalRdrEnv -> [Name] -> [ParStmtBlock GhcRn GhcRn] + -> TcM ([ParStmtBlock GhcTc GhcTc], _) + -- matching in the branches + loop1 _ binds [] = [ ([], a) | a <- bindLocalNames binds (thing_inside elt_ty) ] + loop1 env binds (x:xs) = [ (toList ys, a) | (ys, a) <- loop env binds (x:|xs) ] + +tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts + , trS_bndrs = bindersMap + , trS_by = by, trS_using = using }) elt_ty thing_inside + = tcScalingUsage ManyTy $ -- Transform statements are too complex: just make everything multiplicity Many + do { let (bndr_names, n_bndr_names) = unzip bindersMap + unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) + -- The inner 'stmts' lack a LastStmt, so the element type + -- passed in to tcStmtsAndThen is never looked at + ; (stmts', (bndr_ids, by')) + <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do + { by' <- traverse tcInferRho by + ; bndr_ids <- tcLookupLocalIds bndr_names + ; return (bndr_ids, by') } + + ; let m_app ty = mkTyConApp m_tc [ty] + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm) + -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm + ; let n_app = case form of + ThenForm -> (\ty -> ty) + _ -> m_app + + by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present + by_arrow = case by' of + Nothing -> \ty -> ty + Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTyMany` e_ty) `mkVisFunTyMany` ty + + tup_ty = mkBigCoreVarTupTy bndr_ids + poly_arg_ty = m_app alphaTy + poly_res_ty = m_app (n_app alphaTy) + using_poly_ty = mkInfForAllTy alphaTyVar $ + by_arrow $ + poly_arg_ty `mkVisFunTyMany` poly_res_ty + + ; using' <- tcCheckPolyExpr using using_poly_ty + ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name ManyTy (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [TransStmt binder map] in GHC.Hs.Expr + n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty) + + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = fmap fst by', trS_using = final_using + , trS_ret = noSyntaxExpr + , trS_bind = noSyntaxExpr + , trS_fmap = noExpr + , trS_ext = unitTy + , trS_form = form }, thing) } + +tcLcStmt _ _ stmt _ _ + = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Monad comprehensions +-- (supports rebindable syntax) +--------------------------------------------------- + +tcMcStmt :: TcExprStmtChecker + +tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside + = do { (body', return_op') + <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $ + \ [a_ty] [mult]-> + tcScalingUsage mult $ tcCheckMonoExprNC body a_ty + ; thing <- thing_inside (panic "tcMcStmt: thing_inside") + ; return (LastStmt x body' noret return_op', thing) } + +-- Generators for monad comprehensions ( pat <- rhs ) +-- +-- [ body | q <- gen ] -> gen :: m a +-- q :: a +-- + +tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside + -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty + = do { ((rhs_ty, rhs', pat_mult, pat', thing, new_res_ty), bind_op') + <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn) + [SynRho, SynFun SynAny SynRho] res_ty $ + \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult, fun_mult, pat_mult] -> + do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty + ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ + thing_inside (mkCheckExpType new_res_ty) + ; return (rhs_ty, rhs', pat_mult, pat', thing, new_res_ty) } + + ; hasFixedRuntimeRep_syntactic (FRRBindStmt MonadComprehension) rhs_ty + + -- If (but only if) the pattern can fail, typecheck the 'fail' operator + ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail -> + tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty + + ; let xbstc = XBindStmtTc + { xbstc_bindOp = bind_op' + , xbstc_boundResultType = new_res_ty + , xbstc_boundResultMult = pat_mult + , xbstc_failOp = fail_op' + } + ; return (BindStmt xbstc pat' rhs', thing) } + +-- Boolean expressions. +-- +-- [ body | stmts, expr ] -> expr :: m Bool +-- +tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside + = do { -- Deal with rebindable syntax: + -- guard_op :: test_ty -> rhs_ty + -- then_op :: rhs_ty -> new_res_ty -> res_ty + -- Where test_ty is, for example, Bool + ; ((thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op'), then_op') + <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $ + \ [rhs_ty, new_res_ty] [rhs_mult, fun_mult] -> + do { ((rhs', test_ty), guard_op') + <- tcScalingUsage rhs_mult $ + tcSyntaxOp MCompOrigin guard_op [SynAny] + (mkCheckExpType rhs_ty) $ + \ [test_ty] [test_mult] -> do + rhs' <- tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty + return $ (rhs', test_ty) + ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) + ; return (thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op') } + + ; hasFixedRuntimeRep_syntactic FRRBodyStmtGuard test_ty + ; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 1) rhs_ty + ; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 2) new_res_ty + + ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } + +-- Grouping statements +-- +-- [ body | stmts, then group by e using f ] +-- -> e :: t +-- f :: forall a. (a -> t) -> m a -> m (m a) +-- [ body | stmts, then group using f ] +-- -> f :: forall a. m a -> m (m a) + +-- We type [ body | (stmts, group by e using f), ... ] +-- f [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body.... +-- +-- We type the functions as follows: +-- f :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm) +-- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm) +-- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm) +-- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm) +-- +tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap + , trS_by = by, trS_using = using, trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op }) res_ty thing_inside + = do { m1_ty <- newFlexiTyVarTy typeToTypeKind + ; m2_ty <- newFlexiTyVarTy typeToTypeKind + ; tup_ty <- newFlexiTyVarTy liftedTypeKind + ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm + ; n_app <- case form of + ThenForm -> return (\ty -> ty) + _ -> do { n_ty <- newFlexiTyVarTy typeToTypeKind + ; return (n_ty `mkAppTy`) } + ; let by_arrow :: Type -> Type + -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present) + -- or res ('by' absent) + by_arrow = case by of + Nothing -> \res -> res + Just {} -> \res -> (alphaTy `mkVisFunTyMany` by_e_ty) `mkVisFunTyMany` res + + poly_arg_ty = m1_ty `mkAppTy` alphaTy + using_arg_ty = m1_ty `mkAppTy` tup_ty + poly_res_ty = m2_ty `mkAppTy` n_app alphaTy + using_res_ty = m2_ty `mkAppTy` n_app tup_ty + using_poly_ty = mkInfForAllTy alphaTyVar $ + by_arrow $ + poly_arg_ty `mkVisFunTyMany` poly_res_ty + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let (bndr_names, n_bndr_names) = unzip bindersMap + ; (stmts', (bndr_ids, by', return_op')) <- + tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts + (mkCheckExpType using_arg_ty) $ \res_ty' -> do + { by' <- case by of + Nothing -> return Nothing + Just e -> do { e' <- tcCheckMonoExpr e by_e_ty + ; return (Just e') } + + -- Find the Ids (and hence types) of all old binders + ; bndr_ids <- tcLookupLocalIds bndr_names + + -- 'return' is only used for the binders, so we know its type. + -- return :: (a,b,c,..) -> m (a,b,c,..) + ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op + [synKnownType (mkBigCoreVarTupTy bndr_ids)] + res_ty' $ \ _ _ -> return () + + ; return (bndr_ids, by', return_op') } + + --------------- Typecheck the 'bind' function ------------- + -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op + [ synKnownType using_res_ty + , synKnownType (n_app tup_ty `mkVisFunTyMany` new_res_ty) ] + res_ty $ \ _ _ -> return () + + --------------- Typecheck the 'fmap' function ------------- + ; fmap_op' <- case form of + ThenForm -> return noExpr + _ -> fmap unLoc . tcCheckPolyExpr (noLocA fmap_op) $ + mkInfForAllTy alphaTyVar $ + mkInfForAllTy betaTyVar $ + (alphaTy `mkVisFunTyMany` betaTy) + `mkVisFunTyMany` (n_app alphaTy) + `mkVisFunTyMany` (n_app betaTy) + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) + + ; using' <- tcCheckPolyExpr using using_poly_ty + ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' + + --------------- Building the bindersMap ---------------- + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name ManyTy (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [TransStmt binder map] in GHC.Hs.Expr + n_bndr_ids = zipWithEqual mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids $ + thing_inside (mkCheckExpType new_res_ty) + + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = by', trS_using = final_using + , trS_ret = return_op', trS_bind = bind_op' + , trS_ext = n_app tup_ty + , trS_fmap = fmap_op', trS_form = form }, thing) } + +-- A parallel set of comprehensions +-- [ (g x, h x) | ... ; let g v = ... +-- | ... ; let h v = ... ] +-- +-- It's possible that g,h are overloaded, so we need to feed the LIE from the +-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods). +-- Similarly if we had an existential pattern match: +-- +-- data T = forall a. Show a => C a +-- +-- [ (show x, show y) | ... ; C x <- ... +-- | ... ; C y <- ... ] +-- +-- Then we need the LIE from (show x, show y) to be simplified against +-- the bindings for x and y. +-- +-- It's difficult to do this in parallel, so we rely on the renamer to +-- ensure that g,h and x,y don't duplicate, and simply grow the environment. +-- So the binders of the first parallel group will be in scope in the second +-- group. But that's fine; there's no shadowing to worry about. +-- +-- Note: The `mzip` function will get typechecked via: +-- +-- ParStmt [st1::t1, st2::t2, st3::t3] +-- +-- mzip :: m st1 +-- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call +-- -> m (st1, (st2, st3)) +-- +tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside + = do { m_ty <- newFlexiTyVarTy typeToTypeKind + + ; let mzip_ty = mkInfForAllTys [alphaTyVar, betaTyVar] $ + (m_ty `mkAppTy` alphaTy) + `mkVisFunTyMany` + (m_ty `mkAppTy` betaTy) + `mkVisFunTyMany` + (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) + ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLocA mzip_op) mzip_ty + + -- type dummies since we don't know all binder types yet + ; tup_tys_and_bndr_stmts_s <- traverse (\ bndr_stmts@(ParStmtBlock _ _ names _) -> + [ (tup_tys, bndr_stmts) + | tup_tys <- mkBigCoreTupTy <$> traverse (const (newFlexiTyVarTy liftedTypeKind)) names ]) bndr_stmts_s + + -- Typecheck bind: + ; let tuple_ty = mk_tuple_ty (NE.map fst tup_tys_and_bndr_stmts_s) + + ; (((blocks', thing), inner_res_ty), bind_op') + <- tcSyntaxOp MCompOrigin bind_op + [ synKnownType (m_ty `mkAppTy` tuple_ty) + , SynFun (synKnownType tuple_ty) SynRho ] res_ty $ + \ [inner_res_ty] _ -> + do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) tup_tys_and_bndr_stmts_s + ; return (stuff, inner_res_ty) } + + ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) } + + where + mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys + + loop + :: Type -> ExpRhoType -> NonEmpty (Type, ParStmtBlock GhcRn GhcRn) + -> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), _) + loop m_ty inner_res_ty ((tup_ty_in, ParStmtBlock x stmts names return_op) :| xs) + = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in + ; (stmts', (ids, return_op', pairs', thing)) + <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $ + \m_tup_ty' -> + do { ids <- tcLookupLocalIds names + ; let tup_ty = mkBigCoreVarTupTy ids + ; (_, return_op') <- + tcSyntaxOp MCompOrigin return_op + [synKnownType tup_ty] m_tup_ty' $ + \ _ _ -> return () + ; (pairs', thing) <- loop1 m_ty inner_res_ty xs + ; return (ids, return_op', pairs', thing) } + ; return (ParStmtBlock x stmts' ids return_op' :| pairs', thing) } + + loop1 + :: Type -> ExpRhoType -> [(Type, ParStmtBlock GhcRn GhcRn)] + -> TcM ([ParStmtBlock GhcTc GhcTc], _) + -- matching in the branches + loop1 _ r [] = [ ([], a) | a <- thing_inside r ] + loop1 m r (x:xs) = [ (toList ys, a) | (ys, a) <- loop m r (x:|xs) ] + +tcMcStmt _ stmt _ _ + = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Do-notation +-- (supports rebindable syntax) +--------------------------------------------------- + +tcDoStmt :: TcExprStmtChecker + +tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside + = do { body' <- tcMonoExprNC body res_ty + ; thing <- thing_inside (panic "tcDoStmt: thing_inside") + ; return (LastStmt x body' noret noSyntaxExpr, thing) } +tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside + = do { -- Deal with rebindable syntax: + -- (>>=) :: rhs_ty ->_rhs_mult (pat_ty ->_pat_mult new_res_ty) ->_fun_mult res_ty + -- This level of generality is needed for using do-notation + -- in full generality; see #1537 + + ((rhs_ty, rhs', pat_mult, pat', new_res_ty, thing), bind_op') + <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ + \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] -> + do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty + ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ + thing_inside (mkCheckExpType new_res_ty) + ; return (rhs_ty, rhs', pat_mult, pat', new_res_ty, thing) } + + ; hasFixedRuntimeRep_syntactic (FRRBindStmt DoNotation) rhs_ty + + -- If (but only if) the pattern can fail, typecheck the 'fail' operator + ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail -> + tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty + ; let xbstc = XBindStmtTc + { xbstc_bindOp = bind_op' + , xbstc_boundResultType = new_res_ty + , xbstc_boundResultMult = pat_mult + , xbstc_failOp = fail_op' + } + ; return (BindStmt xbstc pat' rhs', thing) } + +tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside + = do { -- Deal with rebindable syntax; + -- (>>) :: rhs_ty -> new_res_ty -> res_ty + ; ((rhs', rhs_ty, new_res_ty, thing), then_op') + <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ + \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] -> + do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty + ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) + ; return (rhs', rhs_ty, new_res_ty, thing) } + ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 1) rhs_ty + ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 2) new_res_ty + ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } +tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names + , recS_rec_ids = rec_names, recS_ret_fn = ret_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) + res_ty thing_inside + = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names + ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind + ; let tup_ids = zipWith (\n t -> mkLocalId n ManyTy t) tup_names tup_elt_tys + -- Many because it's a recursive definition + tup_ty = mkBigCoreTupTy tup_elt_tys + + ; tcExtendIdEnv tup_ids $ do + { ((stmts', (ret_op', tup_rets)), stmts_ty) + <- runInferRho $ \ exp_ty -> + tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty -> + do { tup_rets <- zipWithM tcCheckId tup_names + (map mkCheckExpType tup_elt_tys) + -- Unify the types of the "final" Ids (which may + -- be polymorphic) with those of "knot-tied" Ids + ; (_, ret_op') + <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty] + inner_res_ty $ \_ _ -> return () + ; return (ret_op', tup_rets) } + + ; ((_, mfix_op'), mfix_res_ty) + <- runInferRho $ \ exp_ty -> + tcSyntaxOp DoOrigin mfix_op + [synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $ + \ _ _ -> return () + + ; ((thing, new_res_ty), bind_op') + <- tcSyntaxOp DoOrigin bind_op + [ synKnownType mfix_res_ty + , SynFun (synKnownType tup_ty) SynRho ] + res_ty $ + \ [new_res_ty] _ -> + do { thing <- thing_inside (mkCheckExpType new_res_ty) + ; return (thing, new_res_ty) } + + ; let rec_ids = takeList rec_names tup_ids + ; later_ids <- tcLookupLocalIds later_names + ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids), + ppr later_ids <+> ppr (map idType later_ids)] + ; return (RecStmt { recS_stmts = L l stmts', recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' + , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' + , recS_ext = RecStmtTc + { recS_bind_ty = new_res_ty + , recS_later_rets = [] + , recS_rec_rets = tup_rets + , recS_ret_ty = stmts_ty} }, thing) + }} + +tcDoStmt ctxt (XStmtLR (ApplicativeStmt _ pairs mb_join)) res_ty thing_inside + = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $ + thing_inside . mkCheckExpType + ; ((pairs', body_ty, thing), mb_join') <- case mb_join of + Nothing -> (, Nothing) <$> tc_app_stmts res_ty + Just join_op -> + second Just <$> + (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ + \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty)) + + ; return (XStmtLR $ ApplicativeStmt body_ty pairs' mb_join', thing) } + +tcDoStmt _ stmt _ _ + = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) + + + +--------------------------------------------------- +-- MonadFail Proposal warnings +--------------------------------------------------- + +-- The idea behind issuing MonadFail warnings is that we add them whenever a +-- failable pattern is encountered. However, instead of throwing a type error +-- when the constraint cannot be satisfied, we only issue a warning in +-- "GHC.Tc.Errors". + +tcMonadFailOp :: CtOrigin + -> LPat GhcTc + -> SyntaxExpr GhcRn -- The fail op + -> TcType -- Type of the whole do-expression + -> TcRn (FailOperator GhcTc) -- Typechecked fail op +-- Get a 'fail' operator expression, to use if the pattern match fails. +-- This won't be used in cases where we've already determined the pattern +-- match can't fail (so the fail op is Nothing), however, it seems that the +-- isIrrefutableHsPat test is still required here for some reason I haven't +-- yet determined. +tcMonadFailOp orig pat fail_op res_ty = do + is_strict <- xoptM LangExt.Strict + comps <- getCompleteMatchesTcM + if isIrrefutableHsPat is_strict (irrefutableConLikeTc comps) pat + then return Nothing + else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] + (mkCheckExpType res_ty) $ \_ _ -> return ()) + +{- +Note [Treat rebindable syntax first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking + do { bar; ... } :: IO () +we want to typecheck 'bar' in the knowledge that it should be an IO thing, +pushing info from the context into the RHS. To do this, we check the +rebindable syntax first, and push that information into (tcLExprNC rhs). +Otherwise the error shows up when checking the rebindable syntax, and +the expected/inferred stuff is back to front (see #3613). + +Note [typechecking ApplicativeStmt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en) + +fresh type variables: + pat_ty_1..pat_ty_n + exp_ty_1..exp_ty_n + t_1..t_(n-1) + +body :: body_ty +(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty +pat_i :: pat_ty_i +e_i :: exp_ty_i +<$> :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1 +<*>_i :: t_(i-1) -> exp_ty_i -> t_i +join :: tn -> res_ty + +Note [Scoping in parallel list comprehensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a parallel list comprehension like [ ebody | a <- blah1; e1 | b <- blah2; e2 ] +we want to ensure that in the lexical environment, tcl_rdr :: LocalRdrEnv, we have + * 'a' in scope in e1, but not 'b' + * 'b' in scope in e2, but not 'a' + * Both in scope in ebody +We don't want too /many/ variables in the LocalRdrEnv, else we make stupid +suggestions for an out-of-scope variable (#22940). + +To achieve this we: + * At the start of each branch, reset the LocalRdrEnv to the outer scope. + * Before typechecking ebody, add to LocalRdrEnv all the variables bound in + all branches. This step is done with bindLocalNames. +-} + +tcApplicativeStmts + :: HsStmtContextRn + -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] + -> ExpRhoType -- rhs_ty + -> (TcRhoType -> TcM t) -- thing_inside + -> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Type, t) + +tcApplicativeStmts ctxt pairs rhs_ty thing_inside + = do { body_ty <- newFlexiTyVarTy liftedTypeKind + ; let arity = length pairs + ; ts <- replicateM (arity-1) $ newInferExpType IIF_DeepRho + ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind + ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind + ; let fun_ty = mkVisFunTysMany pat_tys body_ty + + -- NB. do the <$>,<*> operators first, we don't want type errors here + -- i.e. goOps before goArgs + -- See Note [Treat rebindable syntax first] + ; let (ops, args) = unzip pairs + ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys) + + -- Typecheck each ApplicativeArg separately + -- See Note [ApplicativeDo and constraints] + ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys) + + -- Bring into scope all the things bound by the args, + -- and typecheck the thing_inside + -- See Note [ApplicativeDo and constraints] + ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $ + thing_inside body_ty + + ; return (zip ops' args', body_ty, res) } + where + goOps _ [] = return [] + goOps t_left ((op,t_i,exp_ty) : ops) + = do { (_, op') + <- tcSyntaxOp DoOrigin op + [synKnownType t_left, synKnownType exp_ty] t_i $ + \ _ _ -> return () + ; t_i <- readExpType t_i + ; ops' <- goOps t_i ops + ; return (op' : ops') } + + goArg :: Type -> (ApplicativeArg GhcRn, Type, Type) + -> TcM (ApplicativeArg GhcTc) + + goArg body_ty (ApplicativeArgOne + { xarg_app_arg_one = fail_op + , app_arg_pattern = pat + , arg_expr = rhs + , .. + }, pat_ty, exp_ty) + = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $ + addErrCtxt (StmtErrCtxt ctxt (mkRnBindStmt pat rhs)) $ + do { rhs' <- tcCheckMonoExprNC rhs exp_ty + ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ + return () + ; fail_op' <- fmap join . forM fail_op $ \fail -> + tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty + + ; return (ApplicativeArgOne + { xarg_app_arg_one = fail_op' + , app_arg_pattern = pat' + , arg_expr = rhs' + , .. } + ) } + + goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty) + = do { (stmts', (ret',pat')) <- + tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $ + \res_ty -> do + { ret' <- tcExpr ret res_ty + ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $ + return () + ; return (ret', pat') + } + ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) } + + get_arg_bndrs :: ApplicativeArg GhcTc -> [Id] + get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders CollNoDictBinders pat + get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders CollNoDictBinders pat + +{- Note [ApplicativeDo and constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An applicative-do is supposed to take place in parallel, so +constraints bound in one arm can't possibly be available in another +(#13242). Our current rule is this (more details and discussion +on the ticket). Consider + + ...stmts... + ApplicativeStmts [arg1, arg2, ... argN] + ...more stmts... + +where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts. +Now, we say that: + +* Constraints required by the argi can be solved from + constraint bound by ...stmts... + +* Constraints and existentials bound by the argi are not available + to solve constraints required either by argj (where i /= j), + or by ...more stmts.... + +* Within the stmts of each 'argi' individually, however, constraints bound + by earlier stmts can be used to solve later ones. + +To achieve this, we just typecheck each 'argi' separately, bring all +the variables they bind into scope, and typecheck the thing_inside. + +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ +-} + +-- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same +-- number of /required/ (aka visible) args are used in each equation. +-- Returns the arity, the number of required args +-- E.g. f @a True y = ... +-- f False z = ... +-- The MatchGroup for `f` has arity 2, not 3 +checkArgCounts :: AnnoBody body + => MatchGroup GhcRn (LocatedA (body GhcRn)) + -> TcM VisArity +checkArgCounts (MG { mg_alts = L _ [] }) + = return 1 -- See Note [Empty MatchGroups] in GHC.Rename.Bind + -- case e of {} or \case {} + -- Both have arity 1 + +checkArgCounts (MG { mg_alts = L _ (match1:matches) }) + | null matches -- There was only one match; nothing to check + = return n_args1 + + -- Two or more matches: check that they agree on arity + | Just bad_matches <- mb_bad_matches + = failWithTc $ TcRnMatchesHaveDiffNumArgs (m_ctxt (unLoc match1)) + $ MatchArgMatches match1 bad_matches + | otherwise + = return n_args1 + where + n_args1 = reqd_args_in_match match1 + mb_bad_matches = NE.nonEmpty [m | m <- matches, reqd_args_in_match m /= n_args1] + + reqd_args_in_match :: LocatedA (Match GhcRn body1) -> VisArity + -- Counts the number of /required/ (aka visible) args in the match + reqd_args_in_match (L _ (Match { m_pats = L _ pats })) = count isVisArgLPat pats diff --git a/GHC/Tc/Gen/Match.hs-boot b/GHC/Tc/Gen/Match.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Match.hs-boot @@ -0,0 +1,21 @@ +module GHC.Tc.Gen.Match where +import GHC.Hs ( GRHSs, MatchGroup, LHsExpr, Mult ) +import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, ExpPatType ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Origin ( UserTypeCtxt ) +import GHC.Tc.Types.Evidence ( HsWrapper ) +import GHC.Types.Name ( Name ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) + +tcGRHSsPat :: Mult + -> GRHSs GhcRn (LHsExpr GhcRn) + -> ExpRhoType + -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) + +tcFunBindMatches :: UserTypeCtxt + -> Name + -> Mult + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] + -> ExpSigmaType + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) diff --git a/GHC/Tc/Gen/Pat.hs b/GHC/Tc/Gen/Pat.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Pat.hs @@ -0,0 +1,1951 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Typechecking patterns +module GHC.Tc.Gen.Pat + ( tcLetPat + , newLetBndr + , LetBndrSpec(..) + , tcCheckPat, tcCheckPat_O, tcInferPat + , tcMatchPats + , addDataConStupidTheta + ) +where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferExpr ) + +import GHC.Hs +import GHC.Hs.Syn.Type +import GHC.Rename.Utils +import GHC.Tc.Errors.Types +import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate +import GHC.Types.FieldLabel +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Core.Multiplicity +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Zonk.TcType +import GHC.Core.TyCo.Ppr ( pprTyVars ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Unify +import GHC.Tc.Gen.HsType +import GHC.Builtin.Types +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.ConLike +import GHC.Builtin.Names +import GHC.Types.Basic hiding (SuccessFlag(..)) +import GHC.Driver.DynFlags +import GHC.Types.SrcLoc +import GHC.Types.Var.Set +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import qualified GHC.LanguageExtensions as LangExt +import Control.Arrow ( second ) +import Control.Monad +import GHC.Data.FastString +import qualified Data.List.NonEmpty as NE + +import GHC.Data.List.SetOps ( getNth ) +import Language.Haskell.Syntax.Basic (FieldLabelString(..), LexicalFixity(..)) + +import Data.List( partition ) +import Control.Monad.Trans.Writer.CPS +import Control.Monad.Trans.Class + +{- +************************************************************************ +* * + External interface +* * +************************************************************************ +-} + +tcLetPat :: (Name -> Maybe TcId) + -> LetBndrSpec + -> LPat GhcRn -> Scaled ExpSigmaTypeFRR + -> TcM a + -> TcM (LPat GhcTc, a) +tcLetPat sig_fn no_gen pat pat_ty thing_inside + = do { bind_lvl <- getTcLevel + ; let ctxt = LetPat { pc_lvl = bind_lvl + , pc_sig_fn = sig_fn + , pc_new = no_gen } + penv = PE { pe_lazy = True + , pe_ctxt = ctxt + , pe_orig = PatOrigin } + ; dflags <- getDynFlags + ; manyIfLazy dflags pat + ; tc_lpat pat_ty penv pat thing_inside } + where + -- The logic is partly duplicated from decideBangHood in + -- GHC.HsToCore.Utils. Ugh… + manyIfLazy dflags lpat + | xopt LangExt.Strict dflags = xstrict lpat + | otherwise = not_xstrict lpat + where + xstrict p@(L _ (LazyPat _ _)) = checkManyPattern LazyPatternReason p pat_ty + xstrict (L _ (ParPat _ p)) = xstrict p + xstrict _ = return () + + not_xstrict (L _ (BangPat _ _)) = return () + not_xstrict (L _ (VarPat _ _)) = return () + not_xstrict (L _ (ParPat _ p)) = not_xstrict p + not_xstrict p = checkManyPattern LazyPatternReason p pat_ty + +----------------- +tcMatchPats :: forall a. + HsMatchContextRn + -> [LPat GhcRn] -- ^ patterns + -> [ExpPatType] -- ^ types of the patterns + -> TcM a -- ^ checker for the body + -> TcM ([LPat GhcTc], a) +-- See Note [tcMatchPats] +-- +-- PRECONDITION: +-- number of visible pats::[LPat GhcRn] (p is visible, @p is invisible) +-- == +-- number of visible pat_tys::[ExpPatType] (ExpFunPatTy is visible, +-- ExpForAllPatTy b is visible iff b is Required) +-- +-- POSTCONDITION: +-- Returns only the /value/ patterns; see Note [tcMatchPats] + +tcMatchPats match_ctxt pats pat_tys thing_inside + = assertPpr (count isVisibleExpPatType pat_tys == count isVisArgLPat pats) + (ppr pats $$ ppr pat_tys) $ + -- Check PRECONDITION + -- When we get @patterns the (length pats) will change + do { err_ctxt <- getErrCtxt + ; let loop :: [LPat GhcRn] -> [ExpPatType] -> TcM ([LPat GhcTc], a) + + -- No more patterns. Discard excess pat_tys; + -- they should all be invisible. Example: + -- f :: Int -> forall a b. blah + -- f x @p = rhs + -- We will call tcMatchPats with + -- pats = [x, @p] + -- pat_tys = [Int, @a, @b] + loop [] pat_tys + = assertPpr (not (any isVisibleExpPatType pat_tys)) (ppr pats $$ ppr pat_tys) $ + do { res <- setErrCtxt err_ctxt thing_inside + ; return ([], res) } + + -- ExpForAllPat: expecting a type pattern + loop all_pats@(pat : pats) (ExpForAllPatTy (Bndr tv vis) : pat_tys) + | isVisibleForAllTyFlag vis + = do { (_p, (ps, res)) <- tc_forall_lpat tv penv pat $ + loop pats pat_tys + + ; return (ps, res) } + -- This VisPat is Erased. + -- See Note [Invisible binders in functions] in GHC.Hs.Pat + + -- Invisible (Specified) forall in type, and an @a type pattern + -- E.g. f :: forall a. Bool -> a -> blah + -- f @b True x = rhs1 -- b is bound to skolem a + -- f @c False y = rhs2 -- c is bound to skolem a + -- Also handles invisible (Inferred) case originating from type + -- class deriving; see Note [Inferred invisible patterns] + | L _ (InvisPat pat_spec tp) <- pat + , Invisible spec <- vis + , pat_spec == spec + = do { (_p, (ps, res)) <- tc_ty_pat tp tv $ + loop pats pat_tys + ; return (ps, res) } + + | otherwise -- Discard invisible pat_ty + = loop all_pats pat_tys + + -- This case handles the user error when an InvisPat is used + -- without a corresponding invisible (Specified) forall in the type + -- E.g. 1. f :: Int + -- f @a = ... -- loop (InvisPat{} : _) [] + -- 2. f :: Int -> Int + -- f @a x = ... -- loop (InvisPat{} : _) (ExpFunPatTy{} : _) + -- 3. f :: forall a -> Int + -- f @a t = ... -- loop (InvisPat{} : _) (ExpForAllPatTy (Bndr _ Required) : _) + -- 4. f :: forall {a}. Int + -- f @a t = ... -- loop (InvisPat{} : _) (ExpForAllPatTy (Bndr _ Inferred) : _) + loop (L loc (InvisPat _ tp) : _) _ + = setSrcSpanA loc $ + failWithTc (TcRnIllegalInvisibleTypePattern tp InvisPatNoForall) + + -- ExpFunPatTy: expecting a value pattern + -- tc_lpat will error if it sees a @t type pattern + loop (pat : pats) (ExpFunPatTy pat_ty : pat_tys) + = do { (p, (ps, res)) <- tc_lpat pat_ty penv pat $ + loop pats pat_tys + ; return (p : ps, res) } + -- This VisPat is Retained. + -- See Note [Invisible binders in functions] in GHC.Hs.Pat + + loop pats@(_:_) [] = pprPanic "tcMatchPats" (ppr pats) + -- Failure of PRECONDITION + + ; loop pats pat_tys } + where + penv = PE { pe_lazy = False, pe_ctxt = LamPat match_ctxt, pe_orig = PatOrigin } + + +tcInferPat :: FixedRuntimeRepContext + -> HsMatchContextRn + -> LPat GhcRn + -> TcM a + -> TcM ((LPat GhcTc, a), TcSigmaTypeFRR) +tcInferPat frr_orig ctxt pat thing_inside + = runInferSigmaFRR 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 :: HsMatchContextRn + -> 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 :: HsMatchContextRn + -> CtOrigin -- ^ origin to use if the type needs inst'ing + -> LPat GhcRn -> Scaled TcSigmaTypeFRR + -> TcM a -- Checker for body + -> TcM (LPat GhcTc, a) +tcCheckPat_O ctxt orig pat (Scaled pat_mult pat_ty) thing_inside + = tc_lpat (Scaled pat_mult (mkCheckExpType pat_ty)) penv pat thing_inside + where + penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig } + + +{- Note [tcMatchPats] +~~~~~~~~~~~~~~~~~~~~~ +tcMatchPats is the externally-callable wrapper function for + function definitions f p1 .. pn = rhs + lambdas \p1 .. pn -> body +Typecheck the patterns, extend the environment to bind the variables, do the +thing inside, use any existentially-bound dictionaries to discharge parts of +the returning LIE, and deal with pattern type signatures + +It takes the list of patterns writen by the user, but it returns only the +/value/ patterns. For example: + f :: forall a. forall b -> a -> Mabye b -> blah + f @a w x (Just y) = .... +tcMatchPats returns only the /value/ patterns [x, Just y]. Why? The +desugarer expects only value patterns. (We could change that, but we would +have to do so carefullly.) However, distinguishing value patterns from type +patterns is a bit tricky; e.g. the `w` in this example. So it's very +convenient to filter them out right here. + + +************************************************************************ +* * + PatEnv, PatCtxt, LetBndrSpec +* * +************************************************************************ +-} + +data PatEnv + = PE { pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed + , pe_ctxt :: PatCtxt -- Context in which the whole pattern appears + , pe_orig :: CtOrigin -- origin to use if the pat_ty needs inst'ing + } + +data PatCtxt + = LamPat -- Used for lambdas, case etc + HsMatchContextRn + + | LetPat -- Used only for let(rec) pattern bindings + -- See Note [Typing patterns in pattern bindings] + { pc_lvl :: TcLevel + -- Level of the binding group + + , pc_sig_fn :: Name -> Maybe TcId + -- Tells the expected type + -- for binders with a signature + + , pc_new :: LetBndrSpec + -- How to make a new binder + } -- for binders without signatures + +data LetBndrSpec + = LetLclBndr -- We are going to generalise, and wrap in an AbsBinds + -- so clone a fresh binder for the local monomorphic Id + + | LetGblBndr TcPragEnv -- Generalisation plan is NoGen, so there isn't going + -- to be an AbsBinds; So we must bind the global version + -- of the binder right away. + -- And here is the inline-pragma information + +instance Outputable LetBndrSpec where + ppr LetLclBndr = text "LetLclBndr" + ppr (LetGblBndr {}) = text "LetGblBndr" + +makeLazy :: PatEnv -> PatEnv +makeLazy penv = penv { pe_lazy = True } + +inPatBind :: PatEnv -> Bool +inPatBind (PE { pe_ctxt = LetPat {} }) = True +inPatBind (PE { pe_ctxt = LamPat {} }) = False + +{- ********************************************************************* +* * + Binders +* * +********************************************************************* -} + +tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaTypeFRR -> TcM (HsWrapper, TcId) +-- (coi, xp) = tcPatBndr penv x pat_ty +-- Then coi : pat_ty ~ typeof(xp) +-- +tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl + , pc_sig_fn = sig_fn + , pc_new = no_gen } }) + bndr_name exp_pat_ty + -- For the LetPat cases, see + -- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind + + | Just bndr_id <- sig_fn bndr_name -- There is a signature + = do { wrap <- tc_sub_type penv (scaledThing exp_pat_ty) (idType bndr_id) + -- See Note [Subsumption check at pattern variables] + ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty) + ; return (wrap, bndr_id) } + + | otherwise -- No signature + = do { (co, bndr_ty) <- case scaledThing exp_pat_ty of + Check pat_ty -> promoteTcType bind_lvl pat_ty + Infer infer_res -> assert (bind_lvl `sameDepthAs` ir_lvl infer_res) $ + -- If we were under a constructor that bumped the + -- level, we'd be in checking mode (see tcConArg) + -- hence this assertion + do { bndr_ty <- inferResultToType infer_res + ; return (mkNomReflCo bndr_ty, bndr_ty) } + ; let bndr_mult = scaledMult exp_pat_ty + ; bndr_id <- newLetBndr no_gen bndr_name bndr_mult bndr_ty + ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl + , ppr exp_pat_ty, ppr bndr_ty, ppr co + , ppr bndr_id ]) + ; return (mkWpCastN co, bndr_id) } + +tcPatBndr _ bndr_name pat_ty + = do { let pat_mult = scaledMult pat_ty + ; pat_ty <- expTypeToType (scaledThing pat_ty) + ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty) + ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_mult pat_ty) } + -- We should not have "OrCoVar" here, this is a bug (#17545) + -- Whether or not there is a sig is irrelevant, + -- as this is local + +newLetBndr :: LetBndrSpec -> Name -> Mult -> TcType -> TcM TcId +-- Make up a suitable Id for the pattern-binder. +-- See Note [Typechecking pattern bindings], item (4) in GHC.Tc.Gen.Bind +-- +-- In the polymorphic case when we are going to generalise +-- (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version" +-- of the Id; the original name will be bound to the polymorphic version +-- by the AbsBinds +-- In the monomorphic case when we are not going to generalise +-- (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds, +-- and we use the original name directly +newLetBndr LetLclBndr name w ty + = do { mono_name <- cloneLocalName name + ; return (mkLocalId mono_name w ty) } +newLetBndr (LetGblBndr prags) name w ty + = addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name) + +tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper +-- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt +-- Used during typechecking patterns +tc_sub_type penv t1 t2 = tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2 + +{- Note [Subsumption check at pattern variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come across a variable with a type signature, we need to do a +subsumption, not equality, check against the context type. e.g. + + data T = MkT (forall a. a->a) + f :: forall b. [b]->[b] + MkT f = blah + +Since 'blah' returns a value of type T, its payload is a polymorphic +function of type (forall a. a->a). And that's enough to bind the +less-polymorphic function 'f', but we need some impedance matching +to witness the instantiation. + + +************************************************************************ +* * + The main worker functions +* * +************************************************************************ + +Note [Nesting] +~~~~~~~~~~~~~~ +tcPat takes a "thing inside" over which the pattern scopes. This is partly +so that tcPat can extend the environment for the thing_inside, but also +so that constraints arising in the thing_inside can be discharged by the +pattern. + +This does not work so well for the ErrCtxt carried by the monad: we don't +want the error-context for the pattern to scope over the RHS. +Hence the getErrCtxt/setErrCtxt stuff in tcMultiple +-} + +-------------------- + +type Checker inp out = forall r. + PatEnv + -> inp + -> TcM r -- Thing inside + -> TcM ( out + , r -- Result of thing inside + ) + +tcMultiple_ :: Checker inp () -> PatEnv -> [inp] -> TcM r -> TcM r +tcMultiple_ tc_pat penv args thing_inside + = do { (_, res) <- tcMultiple tc_pat penv args thing_inside + ; return res } + +tcMultiple :: Checker inp out -> Checker [inp] [out] +tcMultiple tc_pat penv args thing_inside + = do { err_ctxt <- getErrCtxt + ; let loop [] + = do { res <- thing_inside + ; return ([], res) } + + loop (arg:args) + = do { (p', (ps', res)) + <- tc_pat penv arg $ + setErrCtxt err_ctxt $ + loop args + -- setErrCtxt: restore context before doing the next pattern + -- See Note [Nesting] above + + ; return (p':ps', res) } + + ; loop args } + +-------------------- +tc_lpat :: Scaled ExpSigmaTypeFRR + -> Checker (LPat GhcRn) (LPat GhcTc) +tc_lpat pat_ty penv (L span pat) thing_inside + = setSrcSpanA span $ + do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat pat_ty penv pat) + thing_inside + ; return (L span pat', res) } + +tc_lpats :: [Scaled ExpSigmaTypeFRR] + -> Checker [LPat GhcRn] [LPat GhcTc] +tc_lpats tys penv pats + = assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $ + tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p) + penv + (zipEqual pats tys) + +-------------------- +checkManyPattern :: NonLinearPatternReason -> LPat GhcRn -> Scaled a -> TcM () +checkManyPattern reason pat pat_ty = tcSubMult (NonLinearPatternOrigin reason pat) ManyTy (scaledMult pat_ty) + + +tc_forall_lpat :: TcTyVar -> Checker (LPat GhcRn) (LPat GhcTc) +tc_forall_lpat tv penv (L span pat) thing_inside + = setSrcSpanA span $ + do { (pat', res) <- maybeWrapPatCtxt pat (tc_forall_pat tv penv pat) + thing_inside + ; return (L span pat', res) } + +tc_forall_pat :: TcTyVar -> Checker (Pat GhcRn) (Pat GhcTc) +tc_forall_pat tv penv (ParPat x lpat) thing_inside + = do { (lpat', res) <- tc_forall_lpat tv penv lpat thing_inside + ; return (ParPat x lpat', res) } + +tc_forall_pat tv _ (EmbTyPat _ tp) thing_inside + -- The entire type pattern is guarded with the `type` herald: + -- f (type t) (x :: t) = ... + -- This special case is not necessary for correctness but avoids + -- a redundant `ExpansionPat` node. + = do { (arg_ty, result) <- tc_ty_pat tp tv thing_inside + ; return (EmbTyPat arg_ty tp, result) } + +tc_forall_pat tv _ pat thing_inside + -- The type pattern is not guarded with the `type` herald, or perhaps + -- only parts of it are, e.g. + -- f (t :: Type) (x :: t) = ... -- no `type` herald + -- f ((type t) :: Type) (x :: t) = ... -- nested `type` herald + -- Apply a recursive T2T transformation. + = do { tp <- pat_to_type_pat pat + ; (arg_ty, result) <- tc_ty_pat tp tv thing_inside + ; let pat' = XPat $ ExpansionPat pat (EmbTyPat arg_ty tp) + ; return (pat', result) } + + +-- Convert a Pat into the equivalent HsTyPat. +-- See `expr_to_type` (GHC.Tc.Gen.App) for the HsExpr counterpart. +-- The `TcM` monad is only used to fail on ill-formed type patterns. +pat_to_type_pat :: Pat GhcRn -> TcM (HsTyPat GhcRn) +pat_to_type_pat pat = do + (ty, x) <- runWriterT (pat_to_type pat) + pure (HsTP (buildHsTyPatRn x) ty) + +pat_to_type :: Pat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn) +pat_to_type (EmbTyPat _ (HsTP x t)) = + do { tell (builderFromHsTyPatRn x) + ; return t } +pat_to_type (VarPat _ lname) = + do { tell (tpBuilderExplicitTV (unLoc lname)) + ; return b } + where b = noLocA (HsTyVar noAnn NotPromoted $ fmap noUserRdr lname) +pat_to_type (WildPat _) = return b + where b = noLocA (HsWildCardTy noExtField) +pat_to_type (SigPat _ pat sig_ty) + = do { t <- pat_to_type (unLoc pat) + ; let { !(HsPS x_hsps k) = sig_ty + ; b = noLocA (HsKindSig noAnn t k) } + ; tell (tpBuilderPatSig x_hsps) + ; return b } +pat_to_type (ParPat _ pat) + = do { t <- pat_to_type (unLoc pat) + ; return (noLocA (HsParTy noAnn t)) } +pat_to_type (SplicePat (HsUntypedSpliceTop mod_finalizers pat) splice) = do + { t <- pat_to_type pat + ; return (noLocA (HsSpliceTy (HsUntypedSpliceTop mod_finalizers t) splice)) } + +pat_to_type (TuplePat _ pats Boxed) + = do { tys <- traverse (pat_to_type . unLoc) pats + ; let t = noLocA (HsExplicitTupleTy noExtField NotPromoted tys) + ; pure t } +pat_to_type (ListPat _ pats) + = do { tys <- traverse (pat_to_type . unLoc) pats + ; let t = noLocA (HsExplicitListTy NoExtField NotPromoted tys) + ; pure t } + +pat_to_type (LitPat _ lit) + | Just ty_lit <- tyLitFromLit lit + = do { let t = noLocA (HsTyLit noExtField ty_lit) + ; pure t } +pat_to_type (NPat _ (L _ lit) _ _) + | Just ty_lit <- tyLitFromOverloadedLit (ol_val lit) + = do { let t = noLocA (HsTyLit noExtField ty_lit) + ; pure t} + +pat_to_type (ConPat _ lname (InfixCon left right)) + = do { lty <- pat_to_type (unLoc left) + ; rty <- pat_to_type (unLoc right) + ; let { t = noLocA (HsOpTy noExtField NotPromoted lty lname rty)} + ; pure t } +pat_to_type (ConPat _ lname (PrefixCon args)) + = do { let { appHead = noLocA (HsTyVar noAnn NotPromoted lname) } + ; foldM apply_arg appHead args } + where + apply_arg :: LHsType GhcRn -> LPat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn) + apply_arg !t (L _ (InvisPat _ (HsTP argx arg))) + = do { tell (builderFromHsTyPatRn argx) + ; pure (mkHsAppKindTy noExtField t arg)} + apply_arg !t (L _ p) + = do { ty_p <- pat_to_type p + ; pure (mkHsAppTy t ty_p)} + +pat_to_type pat = lift $ + failWith $ TcRnIllformedTypePattern pat + -- This failure is the only use of the TcM monad in `pat_to_type_pat` + +{- +Note [Pattern to type (P2T) conversion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + data T a b where + MkT :: forall a. forall b -> a -> b -> T a b + -- NB: `a` is invisible, but `b` is required + + f (MkT @[Int] (Maybe Bool) x y) = ... + +The second type argument of `MkT` is Required, so we write it without +an `@` sign in the pattern match. So the (Maybe Bool) will be + * parsed and renamed as a term pattern + * converted to a type when typechecking the pattern-match: the P2T conversion + +This is the only place we have P2T. In type-lambdas, the "pattern" is always a +type variable: + + f :: forall a -> a -> blah + f b (x::b) = ... + +The `b` argument must be a simple variable; we can't pattern-match on types. + +The function `pat_to_type` does the P2T conversion: + pat_to_type :: Pat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn) + +It is arranged as a writer monad, where the `HsTyPatRnBuilder` accumulates the +binders bound by the type. (We could discover these binders by a subsequent +traversal, that would mean writing another traversal.) +-} + +tc_ty_pat :: HsTyPat GhcRn -> TcTyVar -> TcM r -> TcM (TcType, r) +tc_ty_pat tp tv thing_inside + = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsTyPat tp (varType tv) + ; _ <- unifyType Nothing arg_ty (mkTyVarTy tv) + ; result <- tcExtendNameTyVarEnv sig_wcs $ + tcExtendNameTyVarEnv sig_ibs $ + thing_inside + ; return (arg_ty, result) } + +tc_pat :: Scaled ExpSigmaTypeFRR + -- ^ Fully refined result type + -> Checker (Pat GhcRn) (Pat GhcTc) + -- ^ Translated pattern + +tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of + + VarPat x (L l name) -> do + { (wrap, id) <- tcPatBndr penv name pat_ty + ; res <- tcCheckUsage name (scaledMult pat_ty) $ + tcExtendIdEnv1 name id thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } + + ParPat x pat -> do + { (pat', res) <- tc_lpat pat_ty penv pat thing_inside + ; return (ParPat x pat', res) } + + BangPat x pat -> do + { (pat', res) <- tc_lpat pat_ty penv pat thing_inside + ; return (BangPat x pat', res) } + + OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1) + { let pats_list = NE.toList pats + ; (pats_list', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats_list) penv pats_list (captureConstraints thing_inside) + ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness + ; emitConstraints pat_ct + -- captureConstraints/extendConstraints: + -- like in Note [Hopping the LIE in lazy patterns] + ; pat_ty <- expTypeToType (scaledThing pat_ty) + ; return (OrPat pat_ty pats', res) } + + LazyPat x pat -> do + { checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty + ; (pat', (res, pat_ct)) + <- tc_lpat pat_ty (makeLazy penv) pat $ + captureConstraints thing_inside + -- Ignore refined penv', revert to penv + + ; emitConstraints pat_ct + -- captureConstraints/extendConstraints: + -- see Note [Hopping the LIE in lazy patterns] + + -- Check that the expected pattern type is itself lifted + ; pat_ty <- readExpType (scaledThing pat_ty) + ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind + + ; return ((LazyPat x pat'), res) } + + WildPat _ -> do + { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty + ; res <- thing_inside + ; pat_ty <- expTypeToType (scaledThing pat_ty) + ; return (WildPat pat_ty, res) } + + AsPat x (L nm_loc name) pat -> do + { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty + ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty) + ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ + tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id)) + penv pat thing_inside + -- NB: if we do inference on: + -- \ (y@(x::forall a. a->a)) = e + -- we'll fail. The as-pattern infers a monotype for 'y', which then + -- fails to unify with the polymorphic type for 'x'. This could + -- perhaps be fixed, but only with a bit more work. + -- + -- If you fix it, don't forget the bindInstsOfPatIds! + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } + + ViewPat _ expr pat -> do + { checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty + -- + -- It should be possible to have view patterns at linear (or otherwise + -- non-Many) multiplicity. But it is not clear at the moment what + -- restriction need to be put in place, if any, for linear view + -- patterns to desugar to type-correct Core. + + ; (expr', expr_rho) <- tcInferExpr IIF_ShallowRho expr + -- IIF_ShallowRho: do not perform deep instantiation, regardless of + -- DeepSubsumption (Note [View patterns and polymorphism]) + -- But we must do top-instantiation to expose the arrow to matchActualFunTy + + -- Expression must be a function + ; let herald = ExpectedFunTyViewPat $ unLoc expr + ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) + <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho + -- See Note [View patterns and polymorphism] + -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma) + + -- Check that overall pattern is more polymorphic than arg type + ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty + -- expr_wrap2 :: pat_ty "->" inf_arg_ty + + -- Pattern must have inf_res_sigma + ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside + + ; let Scaled w h_pat_ty = pat_ty + ; pat_ty <- readExpType h_pat_ty + ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper + (Scaled w pat_ty) inf_res_sigma + -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->" + -- (pat_ty -> inf_res_sigma) + -- NB: pat_ty comes from matchActualFunTy, so it has a + -- fixed RuntimeRep, as needed to call mkWpFun. + + expr_wrap = expr_wrap2' <.> expr_wrap1 + + ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) } + +{- Note [View patterns and polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this exotic example (test T26331a): + pair :: forall a. Bool -> a -> forall b. b -> (a,b) + + f :: Int -> blah + f (pair True -> x) = ...here (x :: forall b. b -> (Int,b)) + +The expression (pair True) should have type + pair True :: Int -> forall b. b -> (Int,b) +so that it is ready to consume the incoming Int. It should be an +arrow type (t1 -> t2); and we must not instantiate that `forall b`, +/even with DeepSubsumption/. Hence using `IIF_ShallowRho`; this is the only +place where `IIF_ShallowRho` is used. + +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 matchActualFunTy returns anyway. + +Another example is #26331. +-} + +-- Type signatures in patterns +-- See Note [Pattern coercions] below + SigPat _ pat sig_ty -> do + { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) + sig_ty (scaledThing pat_ty) + -- Using tcExtendNameTyVarEnv is appropriate here + -- because we're not really bringing fresh tyvars into scope. + -- We're *naming* existing tyvars. Note that it is OK for a tyvar + -- from an outer scope to mention one of these tyvars in its kind. + ; (pat', res) <- tcExtendNameTyVarEnv wcs $ + tcExtendNameTyVarEnv tv_binds $ + tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } + +------------------------ +-- Lists, tuples, arrays + + -- Necessarily a built-in list pattern, not an overloaded list pattern. + -- See Note [Desugaring overloaded list patterns]. + ListPat _ pats -> do + { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty) + ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty)) + penv pats thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat coi + (ListPat elt_ty pats') pat_ty, res) } + + TuplePat _ pats boxity -> do + { let arity = length pats + tc = tupleTyCon boxity arity + -- NB: tupleTyCon does not flatten 1-tuples + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + ; checkTupSize arity + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) + penv (scaledThing pat_ty) + -- Unboxed tuples have RuntimeRep vars, which we discard: + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys + Boxed -> arg_tys + ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys) + penv pats thing_inside + + ; dflags <- getDynFlags + + -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) + -- so that we can experiment with lazy tuple-matching. + -- This is a pretty odd place to make the switch, but + -- it was easy to do. + ; let + unmangled_result = TuplePat con_arg_tys pats' boxity + -- pat_ty /= pat_ty iff coi /= IdCo + possibly_mangled_result + | gopt Opt_IrrefutableTuples dflags && + isBoxed boxity = LazyPat noExtField (noLocA unmangled_result) + | otherwise = unmangled_result + + ; pat_ty <- readExpType (scaledThing pat_ty) + ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced + ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) + } + + SumPat _ pat alt arity -> do + { let tc = sumTyCon arity + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) + penv (scaledThing pat_ty) + ; -- Drop levity vars, we don't care about them here + let con_arg_tys = drop arity arg_tys + ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1))) + penv pat thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty + , res) + } + +------------------------ +-- Data constructors + ConPat _ con arg_pats -> + tcConPat penv con pat_ty arg_pats thing_inside + +------------------------ +-- Literal patterns + LitPat x simple_lit -> do + { let lit_ty = hsLitType simple_lit + ; wrap <- tc_sub_type penv (scaledThing pat_ty) lit_ty + ; res <- thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty + , res) } + +------------------------ +-- Overloaded patterns: n, and n+k + +-- In the case of a negative literal (the more complicated case), +-- we get +-- +-- case v of (-5) -> blah +-- +-- becoming +-- +-- if v == (negate (fromInteger 5)) then blah else ... +-- +-- There are two bits of rebindable syntax: +-- (==) :: pat_ty -> neg_lit_ty -> Bool +-- negate :: lit_ty -> neg_lit_ty +-- where lit_ty is the type of the overloaded literal 5. +-- +-- When there is no negation, neg_lit_ty and lit_ty are the same + NPat _ (L l over_lit) mb_neg eq -> do + { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty + -- It may be possible to refine linear pattern so that they work in + -- linear environments. But it is not clear how useful this is. + ; let orig = LiteralOrigin over_lit + ; ((lit', mb_neg'), eq') + <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny] + (mkCheckExpType boolTy) $ + \ [neg_lit_ty] _ -> + let new_over_lit lit_ty = newOverloadedLit over_lit + (mkCheckExpType lit_ty) + in case mb_neg of + Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty + Just neg -> -- Negative literal + -- The 'negate' is re-mappable syntax + second Just <$> + (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $ + \ [lit_ty] _ -> new_over_lit lit_ty) + -- applied to a closed literal: linearity doesn't matter as + -- literals are typed in an empty environment, hence have + -- all multiplicities. + + ; res <- thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } + +{- +Note [NPlusK patterns] +~~~~~~~~~~~~~~~~~~~~~~ +From + + case v of x + 5 -> blah + +we get + + if v >= 5 then (\x -> blah) (v - 5) else ... + +There are two bits of rebindable syntax: + (>=) :: pat_ty -> lit1_ty -> Bool + (-) :: pat_ty -> lit2_ty -> var_ty + +lit1_ty and lit2_ty could conceivably be different. +var_ty is the type inferred for x, the variable in the pattern. + +Note that we need to type-check the literal twice, because it is used +twice, and may be used at different types. The second HsOverLit stored in the +AST is used for the subtraction operation. +-} + +-- See Note [NPlusK patterns] + NPlusKPat _ (L nm_loc name) + (L loc lit) _ ge minus -> do + { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty + ; let pat_exp_ty = scaledThing pat_ty + orig = LiteralOrigin lit + ; (lit1', ge') + <- tcSyntaxOp orig ge [SynType pat_exp_ty, SynRho] + (mkCheckExpType boolTy) $ + \ [lit1_ty] _ -> + newOverloadedLit lit (mkCheckExpType lit1_ty) + ; ((lit2', minus_wrap, bndr_id), minus') + <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $ + \ [lit2_ty, var_ty] _ -> + do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) + ; (wrap, bndr_id) <- setSrcSpanA nm_loc $ + tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty) + -- co :: var_ty ~ idType bndr_id + + -- minus_wrap is applicable to minus' + ; return (lit2', wrap, bndr_id) } + + ; pat_ty <- readExpType pat_exp_ty + + -- The Report says that n+k patterns must be in Integral + -- but it's silly to insist on this in the RebindableSyntax case + ; unlessM (xoptM LangExt.RebindableSyntax) $ + do { icls <- tcLookupClass integralClassName + ; instStupidTheta orig [mkClassPred icls [pat_ty]] } + + ; res <- tcExtendIdEnv1 name bndr_id thing_inside + + ; let minus'' = case minus' of + NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus') + -- this should be statically avoidable + -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr" + SyntaxExprTc { syn_expr = minus'_expr + , syn_arg_wraps = minus'_arg_wraps + , syn_res_wrap = minus'_res_wrap } + -> SyntaxExprTc { syn_expr = minus'_expr + , syn_arg_wraps = minus'_arg_wraps + , syn_res_wrap = minus_wrap <.> minus'_res_wrap } + -- Oy. This should really be a record update, but + -- we get warnings if we try. #17783 + pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' + ge' minus'' + ; return (pat', res) } + +-- Here we get rid of it and add the finalizers to the global environment. +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. + SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do + { addModFinalizersWithLclEnv mod_finalizers + ; tc_pat pat_ty penv pat thing_inside } + + SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat" + + EmbTyPat _ _ -> failWith TcRnIllegalTypePattern + + InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern" + + XPat (HsPatExpanded lpat rpat) -> do + { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside + ; return (XPat $ ExpansionPat lpat rpat', res) } + +{- +Note [Hopping the LIE in lazy patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a lazy pattern, we must *not* discharge constraints from the RHS +from dictionaries bound in the pattern. E.g. + f ~(C x) = 3 +We can't discharge the Num constraint from dictionaries bound by +the pattern C! + +So we have to make the constraints from thing_inside "hop around" +the pattern. Hence the captureConstraints and emitConstraints. + +The same thing ensures that equality constraints in a lazy match +are not made available in the RHS of the match. For example + data T a where { T1 :: Int -> T Int; ... } + f :: T a -> Int -> a + f ~(T1 i) y = y +It's obviously not sound to refine a to Int in the right +hand side, because the argument might not match T1 at all! + +Finally, a lazy pattern should not bind any existential type variables +because they won't be in scope when we do the desugaring + + +************************************************************************ +* * + Pattern signatures (pat :: type) +* * +************************************************************************ +-} + +tcPatSig :: Bool -- True <=> pattern binding + -> HsPatSigType GhcRn + -> ExpSigmaType + -> TcM (TcType, -- The type to use for "inside" the signature + [(Name,TcTyVar)], -- The new bit of type environment, binding + -- the scoped type variables + [(Name,TcTyVar)], -- The wildcards + HsWrapper) -- Coercion due to unification with actual ty + -- Of shape: res_ty ~ sig_ty +tcPatSig in_pat_bind sig res_ty + = do { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt HM_Sig sig OpenKind + -- sig_tvs are the type variables free in 'sig', + -- and not already in scope. These are the ones + -- that should be brought into scope + + ; case NE.nonEmpty sig_tvs of + Nothing -> do { + -- Just do the subsumption check and return + wrap <- addErrCtxtM (mk_msg sig_ty) $ + tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty + ; return (sig_ty, [], sig_wcs, wrap) + } + Just sig_tvs_ne -> do + -- Type signature binds at least one scoped type variable + + -- A pattern binding cannot bind scoped type variables + -- It is more convenient to make the test here + -- than in the renamer + when in_pat_bind + (addErr (TcRnCannotBindScopedTyVarInPatSig sig_tvs_ne)) + + -- Now do a subsumption check of the pattern signature against res_ty + wrap <- addErrCtxtM (mk_msg sig_ty) $ + tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty + + -- Phew! + return (sig_ty, sig_tvs, sig_wcs, wrap) + } + where + mk_msg sig_ty tidy_env + = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty + ; res_ty <- readExpType res_ty -- should be filled in by now + ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty + ; return (tidy_env, PatSigErrCtxt sig_ty res_ty) } + +{- ********************************************************************* +* * + Most of the work for constructors is here + (the rest is in the ConPatIn case of tc_pat) +* * +************************************************************************ + +[Pattern matching indexed data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following declarations: + + data family Map k :: * -> * + data instance Map (a, b) v = MapPair (Map a (Pair b v)) + +and a case expression + + case x :: Map (Int, c) w of MapPair m -> ... + +As explained by [Wrappers for data instance tycons] in GHC.Types.Id.Make, the +worker/wrapper types for MapPair are + + $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v + $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + +So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is +:R123Map, which means the straight use of boxySplitTyConApp would give a type +error. Hence, the smart wrapper function boxySplitTyConAppWithFamily calls +boxySplitTyConApp with the family tycon Map instead, which gives us the family +type list {(Int, c), w}. To get the correct split for :R123Map, we need to +unify the family type list {(Int, c), w} with the instance types {(a, b), v} +(provided by tyConFamInst_maybe together with the family tycon). This +unification yields the substitution [a -> Int, b -> c, v -> w], which gives us +the split arguments for the representation tycon :R123Map as {Int, c, w} + +In other words, boxySplitTyConAppWithFamily implicitly takes the coercion + + Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} + +moving between representation and family type into account. To produce type +correct Core, this coercion needs to be used to case the type of the scrutinee +from the family to the representation type. This is achieved by +unwrapFamInstScrutinee using a CoPat around the result pattern. + +Now it might appear seem as if we could have used the previous GADT type +refinement infrastructure of refineAlt and friends instead of the explicit +unification and CoPat generation. However, that would be wrong. Why? The +whole point of GADT refinement is that the refinement is local to the case +alternative. In contrast, the substitution generated by the unification of +the family type list and instance types needs to be propagated to the outside. +Imagine that in the above example, the type of the scrutinee would have been +(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the +substitution [x -> (a, b), v -> w]. In contrast to GADT matching, the +instantiation of x with (a, b) must be global; ie, it must be valid in *all* +alternatives of the case expression, whereas in the GADT case it might vary +between alternatives. + +RIP GADT refinement: refinements have been replaced by the use of explicit +equality constraints that are used in conjunction with implication constraints +to express the local scope of GADT refinements. + +Note [Freshen existentials] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is essential that these existentials are freshened. +Otherwise, if we have something like + case (a :: Ex, b :: Ex) of (MkEx ..., MkEx ...) -> ... +we'll give both unpacked existential variables the +same name, leading to shadowing. + +-} + +-- Running example: +-- MkT :: forall a b c. (a~[b]) => b -> c -> T a +-- with scrutinee of type (T ty) + +tcConPat :: PatEnv -> LocatedN (WithUserRdr Name) + -> Scaled ExpSigmaTypeFRR -- Type of the pattern + -> HsConPatDetails GhcRn -> TcM a + -> TcM (Pat GhcTc, a) +tcConPat penv (L loc qcon) pat_ty arg_pats thing_inside + = do { let con_lname = L loc (getName qcon) + ; con_like <- tcLookupConLike qcon + ; case con_like of + RealDataCon data_con -> tcDataConPat con_lname data_con pat_ty + penv arg_pats thing_inside + PatSynCon pat_syn -> tcPatSynPat con_lname pat_syn pat_ty + penv 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 :: LocatedN Name -> DataCon + -> Scaled ExpSigmaTypeFRR -- Type of the pattern + -> Checker (HsConPatDetails GhcRn) (Pat GhcTc) +tcDataConPat (L con_span con_name) data_con pat_ty_scaled + penv arg_pats thing_inside + = do { let tycon = dataConTyCon data_con + -- For data families this is the representation tycon + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) + = dataConFullSig data_con + header = L con_span (RealDataCon data_con) + + -- Instantiate the constructor type variables [a->ty] + -- This may involve doing a family-instance coercion, + -- and building a wrapper + ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty_scaled + ; pat_ty <- readExpType (scaledThing pat_ty_scaled) + + -- Add the stupid theta + ; setSrcSpanA con_span $ addDataConStupidTheta data_con ctxt_res_tys + + -- Check that this isn't a GADT pattern match + -- in situations in which that isn't allowed. + ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) + ; checkGADT (RealDataCon data_con) ex_tvs all_arg_tys penv + + ; tenv1 <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys + -- NB: Do not use zipTvSubst! See #14154 + -- We want to create a well-kinded substitution, so + -- that the instantiated type is well-kinded + + ; let mc = case pe_ctxt penv of + LamPat mc -> mc + LetPat {} -> PatBindRhs + ; skol_info <- mkSkolemInfo (PatSkol (RealDataCon data_con) mc) + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info tenv1 ex_tvs + -- Get location from monad, not from ex_tvs + -- This freshens: See Note [Freshen existentials] + -- Why "super"? See Note [Super skolems: 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' + con_like = RealDataCon data_con + + -- This check is necessary to uphold the invariant that 'tcConArgs' + -- is given argument types with a fixed runtime representation. + -- See test case T20363. + ; checkFixedRuntimeRep data_con 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 ]) + + ; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats + + ; traceTc "tcConPat" (vcat [ text "univ_ty_args:" <+> ppr univ_ty_args + , text "ex_ty_args:" <+> ppr ex_ty_args + , text "val_arg_pats:" <+> ppr val_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]) + (val_arg_pats', res) <- + tcConTyArgs tenv penv univ_ty_args $ + tcConValArgs con_like arg_tys_scaled + penv val_arg_pats thing_inside + ; let res_pat = ConPat { pat_con = header + , pat_args = val_arg_pats' + , pat_con_ext = ConPatTc + { cpt_tvs = [], cpt_dicts = [] + , cpt_binds = emptyTcEvBinds + , cpt_arg_tys = ctxt_res_tys + , cpt_wrap = idHsWrapper + } + } + + ; return (mkHsWrapPat wrap res_pat pat_ty, res) } + + else do -- The general case, with existential, + -- and local equality constraints + { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) + -- order is *important* as we generate the list of + -- dictionary binders from theta' + + ; when (not (null eq_spec) || any isEqClassPred theta) warnMonoLocalBinds + + ; given <- newEvVars theta' + ; (ev_binds, (arg_pats', res)) + <- -- See Note [Type applications in patterns] (W4) + tcConTyArgs tenv penv univ_ty_args $ + checkConstraints (getSkolemInfo skol_info) ex_tvs' given $ + tcConTyArgs tenv penv ex_ty_args $ + tcConValArgs con_like arg_tys_scaled penv val_arg_pats thing_inside + + ; let res_pat = ConPat + { pat_con = header + , pat_args = arg_pats' + , pat_con_ext = ConPatTc + { cpt_tvs = ex_tvs' + , cpt_dicts = given + , cpt_binds = ev_binds + , cpt_arg_tys = ctxt_res_tys + , cpt_wrap = idHsWrapper + } + } + ; return (mkHsWrapPat wrap res_pat pat_ty, res) + } } + +tcPatSynPat :: LocatedN Name -> PatSyn + -> Scaled ExpSigmaType -- ^ Type of the pattern + -> Checker (HsConPatDetails GhcRn) (Pat GhcTc) +tcPatSynPat (L con_span con_name) pat_syn pat_ty penv arg_pats thing_inside + = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn + + ; (subst, univ_tvs') <- newMetaTyVars univ_tvs + + -- Check that we aren't matching on a GADT-like pattern synonym + -- in situations in which that isn't allowed. + ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys) + ; checkGADT (PatSynCon pat_syn) ex_tvs all_arg_tys penv + + ; let match_ctxt = case pe_ctxt penv of + LamPat mc -> mc + LetPat {} -> PatBindRhs + ; skol_info <- mkSkolemInfo (PatSkol (PatSynCon pat_syn) match_ctxt) + + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info subst ex_tvs + -- This freshens: Note [Freshen existentials] + + ; let ty' = substTy tenv ty + arg_tys' = substScaledTys tenv arg_tys + pat_mult = scaledMult pat_ty + arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' + prov_theta' = substTheta tenv prov_theta + req_theta' = substTheta tenv req_theta + con_like = PatSynCon pat_syn + + ; when (any isEqClassPred prov_theta) warnMonoLocalBinds + + ; checkManyPattern PatternSynonymReason nlWildPatName pat_ty + + ; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats + + ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty' + + ; traceTc "tcPatSynPat" $ + vcat [ text "Pat syn:" <+> ppr pat_syn + , text "Expected type:" <+> ppr pat_ty + , text "Pat res ty:" <+> ppr ty' + , text "ex_tvs':" <+> pprTyVars ex_tvs' + , text "prov_theta':" <+> ppr prov_theta' + , text "req_theta':" <+> ppr req_theta' + , text "arg_tys':" <+> ppr arg_tys' + , text "univ_ty_args:" <+> ppr univ_ty_args + , text "ex_ty_args:" <+> ppr ex_ty_args ] + + ; 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) -> not (typeHasFixedRuntimeRep arg_ty)) + $ 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 + ; prov_dicts' <- newEvVars prov_theta' + ; (ev_binds, (val_arg_pats', res)) + <- -- See Note [Type applications in patterns] (W4) + tcConTyArgs tenv penv univ_ty_args $ + checkConstraints (getSkolemInfo skol_info) ex_tvs' prov_dicts' $ + tcConTyArgs tenv penv ex_ty_args $ + tcConValArgs con_like arg_tys_scaled penv val_arg_pats $ + thing_inside + ; traceTc "checkConstraints }" (ppr ev_binds) + + ; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn + , pat_args = val_arg_pats' + , pat_con_ext = ConPatTc + { cpt_tvs = ex_tvs' + , cpt_dicts = prov_dicts' + , cpt_binds = ev_binds + , cpt_arg_tys = mkTyVarTys univ_tvs' + , cpt_wrap = req_wrap + } + } + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat wrap res_pat pat_ty, res) } + +checkFixedRuntimeRep :: DataCon -> [Scaled TcSigmaTypeFRR] -> TcM () +checkFixedRuntimeRep data_con arg_tys + = zipWithM_ check_one [1..] arg_tys + where + check_one i arg_ty = hasFixedRuntimeRep_syntactic + (FRRDataConPatArg data_con i) + (scaledThing arg_ty) + +{- Note [Call-stack tracing of pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: HasCallStack => blah + + pattern Annotated :: HasCallStack => (CallStack, a) -> a + pattern Annotated x <- (f -> x) + +When we pattern-match against `Annotated` we will call `f`, and must +pass a call-stack. We may want `Annotated` itself to propagate the call +stack, so we give it a HasCallStack constraint too. But then we expect +to see `Annotated` in the call stack. + +This is achieve easily, but a bit trickily. When we instantiate +Annotated's "required" constraints, in tcPatSynPat, give them a +CtOrigin of (OccurrenceOf "Annotated"). That way the special magic +in GHC.Tc.Solver.Dict.canDictCt which deals with CallStack +constraints will kick in: that logic only fires on constraints +whose Origin is (OccurrenceOf f). + +See also Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +and Note [Solving CallStack constraints] in GHC.Tc.Solver.Dict +-} +---------------------------- +-- | Convenient wrapper for calling a matchExpectedXXX function +matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a)) + -> PatEnv -> ExpSigmaTypeFRR -> TcM (HsWrapper, a) +-- See Note [Matching polytyped patterns] +-- Returns a wrapper : pat_ty ~R inner_ty +matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty + = do { pat_ty <- expTypeToType pat_ty + ; (wrap, pat_rho) <- topInstantiate orig pat_ty + ; (co, res) <- inner_match pat_rho + ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap) + ; return (mkWpCastN (mkSymCo co) <.> wrap, res) } + +---------------------------- +matchExpectedConTy :: PatEnv + -> TyCon + -- ^ The TyCon that this data constructor actually returns. + -- In the case of a data family, this is + -- the /representation/ TyCon. + -> Scaled ExpSigmaTypeFRR + -- ^ The type of the pattern. + -- In the case of a data family, this would + -- mention the /family/ TyCon + -> TcM (HsWrapper, [TcSigmaType]) +-- See Note [Matching constructor patterns] +-- Returns a wrapper : pat_ty "->" T ty1 ... tyn +matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty + | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc + -- Comments refer to Note [Matching constructor patterns] + -- co_tc :: forall a. T [a] ~ T7 a + = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty) + ; (wrap, pat_rho) <- topInstantiate orig pat_ty + + ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc) + -- tys = [ty1,ty2] + + ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, + ppr (tyConTyVars data_tc), + ppr fam_tc, ppr fam_args, + ppr exp_pat_ty, + ppr pat_ty, + ppr pat_rho, ppr wrap]) + ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho + -- co1 : T (ty1,ty2) ~N pat_rho + -- could use tcSubType here... but it's the wrong way round + -- for actual vs. expected in error messages. + + ; let tys' = mkTyVarTys tvs' + co2 = mkUnbranchedAxInstCo Representational co_tc tys' [] + -- co2 : T (ty1,ty2) ~R T7 ty1 ty2 + + full_co = mkSubCo (mkSymCo co1) `mkTransCo` co2 + -- full_co :: pat_rho ~R T7 ty1 ty2 + + ; return ( mkWpCastR full_co <.> wrap, tys') } + + | otherwise + = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty) + ; (wrap, pat_rho) <- topInstantiate orig pat_ty + ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho + ; return (mkWpCastN (mkSymCo coi) <.> wrap, tys) } + +{- +Note [Matching constructor patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (coi, tys) = matchExpectedConType data_tc pat_ty + + * In the simple case, pat_ty = tc tys + + * If pat_ty is a polytype, we want to instantiate it + This is like part of a subsumption check. Eg + f :: (forall a. [a]) -> blah + f [] = blah + + * In a type family case, suppose we have + data family T a + data instance T (p,q) = A p | B q + Then we'll have internally generated + data T7 p q = A p | B q + axiom coT7 p q :: T (p,q) ~ T7 p q + + So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that + coi = coi2 . coi1 : T7 t ~ pat_ty + coi1 : T (ty1,ty2) ~ pat_ty + coi2 : T7 ty1 ty2 ~ T (ty1,ty2) + + For families we do all this matching here, not in the unifier, + because we never want a whisper of the data_tycon to appear in + error messages; it's a purely internal thing +-} + +{- Note [Type applications in patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type applications in patterns are enabled by -XTypeAbstractions. +For example: + f :: Either (Maybe a) [b] -> blah + f (Left @x @[y] (v::Maybe x)) = blah + +How should we typecheck them? The basic plan is pretty simple, and is +all done in tcConTyArgs. For each type argument: + +* Step 1: + * bind the newly-in-scope type variables (here `x` or `y`) to + unification variables, say `x0` or `y0` + + * typecheck the type argument, `@x` or `@[y]` to get the + types `x0` or `[y0]`. + + This step is done by `tcHsPatSigType`, similar to the way we + deal with pattern signatures. + +* Step 2: Unify those types with the type arguments we expect from + the context, in this case (Maybe a) and [b]. These unifications + will (perhaps after the constraint solver has done its work) + unify x0 := Maybe a + y0 := b + Thus we learn that x stands for (Maybe a) and y for b. + +* Step 3: Extend the lexical context to bind `x` to `x0` and + `y` to `y0`, and typecheck the body of the pattern match. + +However there are several quite tricky wrinkles. + +(W1) Surprisingly, we can discard the coercions arising from + these unifications. The *only* thing the unification does is + to side-effect those unification variables, so that we know + what type x and y stand for; and cause an error if the equality + is not soluble. It's a bit like a constraint arising + from a functional dependency, where we don't use the evidence. + +(W2) Note that both here and in pattern signatures the unification may + not even end up unifying the variable. For example + type S a b = a + f :: Maybe a -> Bool + f (Just @(S a b) x) = True :: b + In Step 2 we will unify (S a0 b0 ~ a), which succeeds, but has no + effect on the unification variable b0, to which 'b' is bound. + Later, in the RHS, we find that b0 must be Bool, and unify it there. + All is fine. + +(W3) The order of the arguments to the /data constructor/ may differ from + the order of the arguments to the /type constructor/. Example + data T a b where { MkT :: forall c d. (c,d) -> T d c } + f :: T Int Bool -> blah + f (MkT @x @y p) = ... + The /first/ type argument to `MkT`, namely `@x` corresponds to the + /second/ argument to `T` in the type `T Int Bool`. So `x` is bound + to `Bool` -- not to `Int`!. That is why splitConTyArgs uses + conLikeUserTyVarBinders to match up with the user-supplied type arguments + in the pattern, not dataConUnivTyVars/dataConExTyVars. + +(W4) A similar story works for existentials, but it is subtly different + (#19847). Consider + data T a where { MkT :: forall a b. a -> b -> T a } + f :: T Int -> blah + f (MkT @x @y v w) = blah + Here we create a fresh unification variables x0,y0 for x,y and + unify x0~Int, y0~b, where b is the fresh existential variable bound by + the pattern. But + * (x0~Int) must be /outside/ the implication constraint + * (y0~b) must be /inside/ it + (and hence x0 and y0 themselves must have different levels). + Thus: + x0[1]~Int, (forall[2] b. (y0[2]~b, ...constraints-from-blah...)) + + We need (x0~Int) /outside/ so that it can influence the type of the + pattern in an inferred setting, e.g. + g :: T _ -> blah + g (MkT @Int @y v w) = blah + Here we want to infer `g` to have type `T Int -> blah`. If the + (x0~Int) was inside the implication, and the the constructor bound + equality constraints, `x0` would be untouchable. This was the root + cause of #19847. + + We need (y0~b) to be /inside/ the implication, so that `b` is in + scope. In fact, we may actually /need/ equalities bound by the + implication to prove the equality constraint we generate. + Example data T a where + MkT :: forall p q. T (p,q) + f :: T (Int,Bool) -> blah + f (MkT @Int @Bool) = ... + We get the implication + forall[2] p q. (p,q)~(Int,Bool) => (p ~ Int, q ~ Bool, ...) + where the Given comes from the GADT match, while (p~Int, q~Bool) + comes from matching the type arguments. + + Wow. That's all quite subtle! See the long discussion on #19847. We + must treat universal and existential arguments separately, even though + they are all mixed up (W3). The function splitConTyArgs separates the + universals from existentials; and we build the implication between + typechecking the two sets: + tcConTyArgs ... univ_ty_args $ + checkConstraints ... $ + tcConTyArgs ... ex_ty_args $ + ..typecheck body.. + You can see this code shape in tcDataConPat and tcPatSynPat. + + Where pattern synonyms are involved, this two-level split may not be + enough. See #22328 for the story. +-} + +{- Note [Omitted record fields and linearity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T = MkT {a:A, b:B} + f :: T -> A + f (MkT{a=a}) = a + +The pattern in f is equivalent to + + f (MkT a _) = a + +Evidently, the b field isn't used linearly here, it must be typed as a wildcard +pattern. However, this is *the only check* for omitted record fields: if it +weren't for linearity checking, the type checker could ignore b altogether. So +we have a function check_omitted_fields_multiplicity, whose purpose is to do the +linearity checking on the omitted fields. +-} + +tcConValArgs :: ConLike + -> [Scaled TcSigmaTypeFRR] + -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) +tcConValArgs con_like arg_tys penv con_args thing_inside = case con_args of + PrefixCon arg_pats -> do + -- NB: Type arguments already dealt with by splitConTyArgs, tcConTyArgs. + -- See Note [Type applications in patterns] + { report_invis_arg_pats arg_pats + ; let pats_w_tys = zipEqual arg_pats arg_tys + ; (arg_pats', res) <- tcMultiple tcConArg penv pats_w_tys thing_inside + + -- Return only /value/ patterns, all /type/ patterns are discarded. + -- This is also what tcMatchPats does, and Note [tcMatchPats] explains why. + ; return (PrefixCon arg_pats', res) } + where + -- Report @-patterns as errors. The valid ones have been dealt with + -- outside tcConValArgs. At this point we are expecting patterns for + -- value arguments only. + report_invis_arg_pats :: [LPat GhcRn] -> TcM () + report_invis_arg_pats ps = do + let bad_ps = [L loc tp | L loc (InvisPat _ tp) <- ps] + forM_ bad_ps $ \(L loc tp) -> + setSrcSpanA loc $ + addErrTc (TcRnIllegalInvisibleTypePattern tp InvisPatNoForall) + unless (null bad_ps) failM + + InfixCon p1 p2 -> do + { let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after splitConTyArgs + ; ([p1',p2'], res) <- tcMultiple tcConArg penv [(p1,arg_ty1),(p2,arg_ty2)] + thing_inside + ; return (InfixCon p1' p2', res) } + + RecCon (HsRecFields x rpats dd) -> do + { check_omitted_fields_multiplicity + ; (rpats', res) <- tcMultiple tc_field penv rpats thing_inside + ; return ((RecCon (HsRecFields x rpats' dd)), res) } + where + tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) + (LHsRecField GhcTc (LPat GhcTc)) + tc_field penv + (L l (HsFieldBind ann (L loc (FieldOcc rdr (L lr sel))) pat pun)) + thing_inside + = do { sel' <- tcLookupId sel + ; pat_ty <- setSrcSpanA loc $ find_field_ty sel + (occNameFS $ rdrNameOcc rdr) + ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside + ; return (L l (HsFieldBind ann (L loc (FieldOcc rdr (L lr sel'))) pat' + pun), res) } + -- See Note [Omitted record fields and linearity] + check_omitted_fields_multiplicity :: TcM () + check_omitted_fields_multiplicity = do + forM_ omitted_field_tys $ \(fl, pat_ty) -> + tcSubMult (OmittedFieldOrigin fl) ManyTy (scaledMult pat_ty) + + find_field_ty :: Name -> FastString -> TcM (Scaled TcType) + find_field_ty sel lbl + = case [ty | (Just fl, ty) <- bound_field_tys, flSelector fl == sel ] of + + -- No matching field; chances are this field label comes from some + -- other record type (or maybe none). If this happens, just fail, + -- otherwise we get crashes later (#8570), and similar: + -- f (R { foo = (a,b) }) = a+b + -- If foo isn't one of R's fields, we don't want to crash when + -- typechecking the "a+b". + [] -> failWith (badFieldConErr (getName con_like) (FieldLabelString lbl)) + + -- The normal case, when the field comes from the right constructor + (pat_ty : extras) -> do + traceTc "find_field" (ppr pat_ty <+> ppr extras) + assert (null extras) (return pat_ty) + + bound_field_tys, omitted_field_tys :: [(Maybe FieldLabel, Scaled TcType)] + (bound_field_tys, omitted_field_tys) = partition is_bound all_field_tys + + is_bound :: (Maybe FieldLabel, Scaled TcType) -> Bool + is_bound (Just fl, _) = elem (flSelector fl) (map (\(L _ (HsFieldBind _ (L _ (FieldOcc _ sel )) _ _)) -> unLoc sel) rpats) + is_bound _ = False + + all_field_tys :: [(Maybe FieldLabel, Scaled TcType)] + all_field_tys = zip con_field_labels arg_tys + -- If the constructor isn't really a record, then dataConFieldLabels + -- will be empty (and each field in the pattern will generate an error + -- below). We still need those unnamed fields for + -- linearity-checking. Hence we zip the anonymous fields with Nothing. + + con_field_labels :: [Maybe FieldLabel] + con_field_labels = (map Just (conLikeFieldLabels con_like)) ++ repeat Nothing + +check_con_pat_arity :: ConLike -> Int -> TcM () +check_con_pat_arity con_like no_of_vis_args = + checkTc (con_vis_arity == no_of_vis_args) + (TcRnArityMismatch (AConLike con_like) con_vis_arity no_of_vis_args) + where + con_vis_arity = conLikeVisArity con_like + +splitConTyArgs :: ConLike -> HsConPatDetails GhcRn + -> TcM ( [(HsTyPat GhcRn, TyVar)] -- Universals + , [(HsTyPat GhcRn, TyVar)] -- Existentials + , HsConPatDetails GhcRn ) -- Value arguments +-- See Note [Type applications in patterns] (W4) +-- This function is monadic only to emit error messages +splitConTyArgs con_like (PrefixCon arg_pats) = do + check_con_pat_arity con_like (count isVisArgLPat arg_pats) + split_con_ty_args Prefix con_like arg_pats +splitConTyArgs con_like (InfixCon arg1 arg2) = do + -- should not occur: (@a :+ b), (a :+ @b), or (@a :+ @b) + massert (isVisArgLPat arg1 && isVisArgLPat arg2) + check_con_pat_arity con_like 2 + split_con_ty_args Infix con_like [arg1, arg2] +splitConTyArgs _ p@(RecCon {}) = return ([], [], p) -- No type args in RecCon + +split_con_ty_args :: LexicalFixity -- How to wrap value arguments + -> ConLike -- Data constructor or pattern synonym + -> [LPat GhcRn] -- Argument patterns + -> TcM ( [(HsTyPat GhcRn, TyVar)] -- Universals + , [(HsTyPat GhcRn, TyVar)] -- Existentials + , HsConPatDetails GhcRn ) -- Value arguments +split_con_ty_args fixity con_like arg_pats = do + (bndr_ty_arg_prs, value_args) <- zip_pats_bndrs arg_pats (conLikeUserTyVarBinders con_like) + return $ if null ex_tvs -- Short cut common case + then (bndr_ty_arg_prs, [], mk_details fixity value_args) + else let (ex_prs, univ_prs) = partition is_existential bndr_ty_arg_prs + in (univ_prs, ex_prs, mk_details fixity value_args) + where + ex_tvs = conLikeExTyCoVars con_like + is_existential (_, tv) = tv `elem` ex_tvs + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon + -- especially INVARIANT(dataConTyVars). + + mk_details Infix [a,b] = InfixCon a b + mk_details _ ps = PrefixCon ps + -- InfixCon becomes PrefixCon if there are fewer than 2 value arguments. + -- Test case: T25127_infix + +zip_pats_bndrs :: [LPat GhcRn] -> [TyVarBinder] -> TcM ([(HsTyPat GhcRn, TyVar)], [LPat GhcRn]) +zip_pats_bndrs (L loc pat : pats) (Bndr tv vis : tvbs) + | isVisibleForAllTyFlag vis + = do { tp <- setSrcSpanA loc $ pat_to_type_pat pat + ; (prs, pats') <- zip_pats_bndrs pats tvbs + ; return ((tp, tv) : prs, pats') } + | InvisPat pat_spec tp <- pat + , Invisible spec <- vis + , pat_spec == spec + = do { (prs, pats') <- zip_pats_bndrs pats tvbs + ; return ((tp, tv):prs, pats') } +zip_pats_bndrs pats (Bndr _ vis : tvbs) + -- zip_pats_bndrs [] (Bndr _ Required : tvbs) + -- is ruled out by the arity check in splitConTyArgs, + -- so we can assume (isInvisibleForAllTyFlag vis) + = do { massert (isInvisibleForAllTyFlag vis) + ; zip_pats_bndrs pats tvbs } +zip_pats_bndrs pats [] = return ([], pats) + +tcConTyArgs :: Subst -> PatEnv -> [(HsTyPat GhcRn, TyVar)] + -> TcM a -> TcM a +tcConTyArgs tenv penv prs thing_inside + = tcMultiple_ (tcConTyArg tenv) penv prs thing_inside + +tcConTyArg :: Subst -> Checker (HsTyPat GhcRn, TyVar) () +tcConTyArg tenv penv (rn_ty, con_tv) thing_inside + = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsTyPat rn_ty (substTy tenv (varType con_tv)) + + ; case NE.nonEmpty sig_ibs of + Just sig_ibs_ne | inPatBind penv -> + addErr (TcRnCannotBindTyVarsInPatBind sig_ibs_ne) + _ -> pure () + + -- This unification is straight from Figure 7 of + -- "Type Variables in Patterns", Haskell'18 + -- OK to drop coercions here. These unifications are all about + -- guiding inference based on a user-written type annotation + -- See Note [Type applications in patterns] (W1) + ; _ <- unifyType Nothing arg_ty (substTyVar tenv con_tv) + + ; result <- tcExtendNameTyVarEnv sig_wcs $ + tcExtendNameTyVarEnv sig_ibs $ + thing_inside + -- NB: Because we call tConTyArgs twice, once for universals and + -- once for existentials; so this brings things into scope + -- "out of left-right order". But it doesn't matter; the renamer + -- has dealt with all that. + + ; return ((), result) } + +tcConArg :: Checker (LPat GhcRn, Scaled TcSigmaType) (LPat GhcTc) +tcConArg penv (arg_pat, Scaled arg_mult arg_ty) + = tc_lpat (Scaled arg_mult (mkCheckExpType arg_ty)) penv arg_pat + +addDataConStupidTheta :: DataCon -> [TcType] -> TcM () +-- Instantiate the "stupid theta" of the data con, and throw +-- the constraints into the constraint set. +-- See Note [The stupid context] in GHC.Core.DataCon. +addDataConStupidTheta data_con inst_tys + | null stupid_theta = return () + | otherwise = instStupidTheta origin inst_theta + where + origin = OccurrenceOf (dataConName data_con) + -- The origin should always report "occurrence of C" + -- even when C occurs in a pattern + stupid_theta = dataConStupidTheta data_con + univ_tvs = dataConUnivTyVars data_con + tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys) + -- NB: inst_tys can be longer than the univ tyvars + -- because the constructor might have existentials + inst_theta = substTheta tenv stupid_theta + +{- +Note [Arrows and patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +(Oct 07) Arrow notation has the odd property that it involves +"holes in the scope". For example: + expr :: Arrow a => a () Int + expr = proc (y,z) -> do + x <- term -< y + expr' -< x + +Here the 'proc (y,z)' binding scopes over the arrow tails but not the +arrow body (e.g 'term'). As things stand (bogusly) all the +constraints from the proc body are gathered together, so constraints +from 'term' will be seen by the tcPat for (y,z). But we must *not* +bind constraints from 'term' here, because the desugarer will not make +these bindings scope over 'term'. + +The Right Thing is not to confuse these constraints together. But for +now the Easy Thing is to ensure that we do not have existential or +GADT constraints in a 'proc', which we do by disallowing any +non-vanilla pattern match (i.e. one that introduces existential +variables or provided constraints), in tcDataConPat and tcPatSynPat. + +We also short-cut the constraint simplification for such vanilla patterns, +so that we bind no constraints. Hence the 'fast path' in tcDataConPat; +which applies more generally (not just within 'proc'), as it's a good +plan in general to bypass the constraint simplification step entirely +when it's not needed. + +Note [Pattern coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +In principle, these program would be reasonable: + + f :: (forall a. a->a) -> Int + f (x :: Int->Int) = x 3 + + g :: (forall a. [a]) -> Bool + g [] = True + +In both cases, the function type signature restricts what arguments can be passed +in a call (to polymorphic ones). The pattern type signature then instantiates this +type. For example, in the first case, (forall a. a->a) <= Int -> Int, and we +generate the translated term + f = \x' :: (forall a. a->a). let x = x' Int in x 3 + +From a type-system point of view, this is perfectly fine, but it's *very* seldom useful. +And it requires a significant amount of code to implement, because we need to decorate +the translated pattern with coercion functions (generated from the subsumption check +by tcSub). + +So for now I'm just insisting on type *equality* in patterns. No subsumption. + +Old notes about desugaring, at a time when pattern coercions were handled: + +A SigPat is a type coercion and must be handled one at a time. We can't +combine them unless the type of the pattern inside is identical, and we don't +bother to check for that. For example: + + data T = T1 Int | T2 Bool + f :: (forall a. a -> a) -> T -> t + f (g::Int->Int) (T1 i) = T1 (g i) + f (g::Bool->Bool) (T2 b) = T2 (g b) + +We desugar this as follows: + + f = \ g::(forall a. a->a) t::T -> + let gi = g Int + in case t of { T1 i -> T1 (gi i) + other -> + let gb = g Bool + in case t of { T2 b -> T2 (gb b) + other -> fail }} + +Note that we do not treat the first column of patterns as a +column of variables, because the coerced variables (gi, gb) +would be of different types. So we get rather grotty code. +But I don't think this is a common case, and if it was we could +doubtless improve it. + +Meanwhile, the strategy is: + * treat each SigPat coercion (always non-identity coercions) + as a separate block + * deal with the stuff inside, and then wrap a binding round + the result to bind the new variable (gi, gb, etc) + + +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ + +Note [Existential check] +~~~~~~~~~~~~~~~~~~~~~~~~ +Lazy patterns can't bind existentials. They arise in two ways: + * Let bindings let { C a b = e } in b + * Twiddle patterns f ~(C a b) = e +The pe_lazy field of PatEnv says whether we are inside a lazy +pattern (perhaps deeply) + +See also Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind +-} + +maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b +-- Not all patterns are worth pushing a context +maybeWrapPatCtxt pat tcm thing_inside + | not (worth_wrapping pat) = tcm thing_inside + | otherwise = addErrCtxt (PatCtxt pat) $ tcm $ popErrCtxt thing_inside + -- Remember to pop before doing thing_inside + where + worth_wrapping (VarPat {}) = False + worth_wrapping (ParPat {}) = False + worth_wrapping (AsPat {}) = False + worth_wrapping _ = True + +----------------------------------------------- + +-- | Check that a pattern isn't a GADT, or doesn't have existential variables, +-- in a situation in which that is not permitted (inside a lazy pattern, or +-- in arrow notation). +checkGADT :: ConLike + -> [TyVar] -- ^ existentials + -> [Type] -- ^ argument types + -> PatEnv + -> TcM () +checkGADT conlike ex_tvs arg_tys = \case + PE { pe_ctxt = LetPat {} } + -> return () + PE { pe_ctxt = LamPat (ArrowMatchCtxt {}) } + | not $ isVanillaConLike conlike + -- See Note [Arrows and patterns] + -> failWithTc TcRnArrowProcGADTPattern + PE { pe_lazy = True } + | has_existentials + -- See Note [Existential check] + -> failWithTc TcRnLazyGADTPattern + _ -> return () + where + has_existentials :: Bool + has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs diff --git a/GHC/Tc/Gen/Sig.hs b/GHC/Tc/Gen/Sig.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Sig.hs @@ -0,0 +1,1692 @@ +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-2002 + +-} + + +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Gen.Sig( + TcSigInfo(..), TcIdSig(..), TcSigFun, + + isPartialSig, hasCompleteSig, tcSigInfoName, tcIdSigLoc, + completeSigPolyId_maybe, isCompleteHsSig, + lhsSigWcTypeContextSpan, lhsSigTypeContextSpan, + + tcTySigs, tcUserTypeSig, completeSigFromId, + tcInstSig, + + TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv, + mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, + addInlinePrags, addInlinePragArity, + + tcRules + ) where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Driver.DynFlags +import GHC.Driver.Backend + +import GHC.Hs + +import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcInferRho, tcCheckMonoExpr ) + +import GHC.Tc.Errors.Types +import GHC.Tc.Gen.HsType +import GHC.Tc.Solver( reportUnsolvedEqualities, pushLevelAndSolveEqualitiesX + , emitResidualConstraints ) +import GHC.Tc.Solver.Solve( solveWanteds ) +import GHC.Tc.Solver.Monad( runTcS, setTcSMode, TcSMode(..), vanillaTcSMode, runTcSWithEvBinds ) +import GHC.Tc.Validity ( checkValidType ) + +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Unify( DeepSubsumptionFlag(..), tcSkolemise, unifyType, buildImplicationFor ) +import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) +import GHC.Tc.Utils.Env + +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint + +import GHC.Tc.Zonk.TcType +import GHC.Tc.Zonk.Type + +import GHC.Core( hasSomeUnfolding ) +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.Predicate +import GHC.Core.TyCo.Rep( mkNakedFunTy ) +import GHC.Core.TyCon( isTypeFamilyTyCon ) + +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Id ( idName, idType, setInlinePragma + , mkLocalId, realIdUnfolding ) +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.SrcLoc + +import GHC.Builtin.Names( mkUnboundName ) +import GHC.Unit.Module( Module, getModule ) + +import GHC.Utils.Misc as Utils ( singleton ) +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.Bag +import GHC.Data.Maybe( orElse, whenIsJust ) + +import Control.Monad( unless ) +import Data.Foldable ( toList ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe( mapMaybe ) + +{- ------------------------------------------------------------- + Note [Overview of type signatures] +---------------------------------------------------------------- +Type signatures, including partial signatures, are jolly tricky, +especially on value bindings. Here's an overview. + + f :: forall a. [a] -> [a] + g :: forall b. _ -> b + + f = ...g... + g = ...f... + +* HsSyn: a signature in a binding starts off as a TypeSig, in + type HsBinds.Sig + +* When starting a mutually recursive group, like f/g above, we + call tcTySig on each signature in the group. + +* tcTySig: Sig -> TcIdSig + - For a /complete/ signature, like 'f' above, tcTySig kind-checks + the HsType, producing a Type, and wraps it in a TcCompleteSig, and + extend the type environment with this polymorphic 'f'. + + - For a /partial/signature, like 'g' above, tcTySig does nothing + Instead it just wraps the pieces in a PartialSig, to be handled + later. + +* tcInstSig: TcIdSig -> TcIdSigInst + In tcMonoBinds, when looking at an individual binding, we use + tcInstSig to instantiate the signature forall's in the signature, + and attribute that instantiated (monomorphic) type to the + binder. You can see this in GHC.Tc.Gen.Bind.tcLhsId. + + The instantiation does the obvious thing for complete signatures, + but for /partial/ signatures it starts from the HsSyn, so it + has to kind-check it etc: tcHsPartialSigType. It's convenient + to do this at the same time as instantiation, because we can + make the wildcards into unification variables right away, rather + than somehow quantifying over them. And the "TcLevel" of those + unification variables is correct because we are in tcMonoBinds. + + +Note [Binding scoped type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type variables *brought into lexical scope* by a type signature +may be a subset of the *quantified type variables* of the signatures, +for two reasons: + +* With kind polymorphism a signature like + f :: forall f a. f a -> f a + may actually give rise to + f :: forall k. forall (f::k -> *) (a:k). f a -> f a + So the sig_tvs will be [k,f,a], but only f,a are scoped. + NB: the scoped ones are not necessarily the *initial* ones! + +* Even aside from kind polymorphism, there may be more instantiated + type variables than lexically-scoped ones. For example: + type T a = forall b. b -> (a,b) + f :: forall c. T c + Here, the signature for f will have one scoped type variable, c, + but two instantiated type variables, c' and b'. + +However, all of this only applies to the renamer. The typechecker +just puts all of them into the type environment; any lexical-scope +errors were dealt with by the renamer. + +-} + +{- ********************************************************************* +* * + Typechecking user signatures +* * +********************************************************************* -} + +tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun) +tcTySigs hs_sigs + = checkNoErrs $ + do { -- Fail if any of the signatures is duff + -- Hence mapAndReportM + -- See Note [Fail eagerly on bad signatures] + ty_sigs_s <- mapAndReportM tcTySig hs_sigs + + ; let ty_sigs = concat ty_sigs_s + poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs + -- The returned [TcId] are the ones for which we have + -- a complete type signature. + -- See Note [Complete and partial type signatures] + env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs] + + ; return (poly_ids, lookupNameEnv env) } + +tcTySig :: LSig GhcRn -> TcM [TcSigInfo] +tcTySig (L _ (XSig (IdSig id))) + = do { let ctxt = FunSigCtxt (idName id) NoRRC + -- NoRRC: do not report redundant constraints + -- The user has no control over the signature! + sig = completeSigFromId ctxt id + ; return [TcIdSig (TcCompleteSig sig)] } + +tcTySig (L loc (TypeSig _ names sig_ty)) + = setSrcSpanA loc $ + do { sigs <- sequence [ tcUserTypeSig (locA loc) sig_ty (Just name) + | L _ name <- names ] + ; return (map TcIdSig sigs) } + +tcTySig (L loc (PatSynSig _ names sig_ty)) + = setSrcSpanA loc $ + do { tpsigs <- sequence [ tcPatSynSig name sig_ty + | L _ name <- names ] + ; return (map TcPatSynSig tpsigs) } + +tcTySig _ = return [] + + +tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name -> TcM TcIdSig +-- A function or expression type signature +-- Returns a fully quantified type signature; even the wildcards +-- are quantified with ordinary skolems that should be instantiated +-- +-- The SrcSpan is what to declare as the binding site of the +-- any skolems in the signature. For function signatures we +-- use the whole `f :: ty' signature; for expression signatures +-- just the type part. +-- +-- Just n => Function type signature name :: type +-- Nothing => Expression type signature :: type +tcUserTypeSig loc hs_sig_ty mb_name + | isCompleteHsSig hs_sig_ty + = do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty + ; traceTc "tcuser" (ppr sigma_ty) + ; return $ TcCompleteSig $ + CSig { sig_bndr = mkLocalId name ManyTy sigma_ty + -- We use `Many' as the multiplicity here, + -- as if this identifier corresponds to + -- anything, it is a top-level + -- definition. Which are all unrestricted in + -- the current implementation. + , sig_ctxt = ctxt_rrc -- Report redundant constraints + , sig_loc = loc } } -- Location of the in f :: + + -- Partial sig with wildcards + | otherwise + = return $ TcPartialSig $ + PSig { psig_name = name, psig_hs_ty = hs_sig_ty + , psig_ctxt = ctxt_no_rrc, psig_loc = loc } + where + name = case mb_name of + Just n -> n + Nothing -> mkUnboundName (mkVarOccFS (fsLit "")) + + 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 -> TcCompleteSig +-- Used for instance methods and record selectors +completeSigFromId ctxt id + = CSig { sig_bndr = id + , sig_ctxt = ctxt + , sig_loc = getSrcSpan id } + +isCompleteHsSig :: LHsSigWcType GhcRn -> Bool +-- ^ If there are no wildcards, return a LHsSigWcType +isCompleteHsSig (HsWC { hswc_ext = wcs, hswc_body = hs_sig_ty }) + = null wcs && no_anon_wc_sig_ty hs_sig_ty + +no_anon_wc_sig_ty :: LHsSigType GhcRn -> Bool +no_anon_wc_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) + = all no_anon_wc_tvb (hsOuterExplicitBndrs outer_bndrs) + && no_anon_wc_ty body + +no_anon_wc_ty :: LHsType GhcRn -> Bool +no_anon_wc_ty lty = go lty + where + go (L _ ty) = case ty of + HsWildCardTy _ -> False + HsAppTy _ ty1 ty2 -> go ty1 && go ty2 + HsAppKindTy _ ty ki -> go ty && go ki + HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && all go (multAnnToHsType w) + HsListTy _ ty -> go ty + HsTupleTy _ _ tys -> gos tys + HsSumTy _ tys -> gos tys + HsOpTy _ _ ty1 _ ty2 -> go ty1 && go ty2 + HsParTy _ ty -> go ty + HsIParamTy _ _ ty -> go ty + HsKindSig _ ty kind -> go ty && go kind + HsDocTy _ ty _ -> go ty + HsExplicitListTy _ _ tys -> gos tys + HsExplicitTupleTy _ _ tys -> gos tys + HsForAllTy { hst_tele = tele + , hst_body = ty } -> no_anon_wc_tele tele + && go ty + HsQualTy { hst_ctxt = ctxt + , hst_body = ty } -> gos (unLoc ctxt) && go ty + HsSpliceTy (HsUntypedSpliceTop _ ty) _ -> go ty + HsSpliceTy (HsUntypedSpliceNested _) _ -> True + HsTyLit{} -> True + HsTyVar{} -> True + HsStarTy{} -> True + XHsType{} -> True -- HsCoreTy, which does not have any wildcard + + gos = all go + +no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool +no_anon_wc_tele tele = case tele of + HsForAllVis { hsf_vis_bndrs = ltvs } -> all no_anon_wc_tvb ltvs + HsForAllInvis { hsf_invis_bndrs = ltvs } -> all no_anon_wc_tvb ltvs + +no_anon_wc_tvb :: LHsTyVarBndr flag GhcRn -> Bool +no_anon_wc_tvb (L _ tvb) = case hsBndrKind tvb of + HsBndrNoKind _ -> True + HsBndrKind _ ki -> no_anon_wc_ty ki + +{- Note [Fail eagerly on bad signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a type signature is wrong, fail immediately: + + * the type sigs may bind type variables, so proceeding without them + can lead to a cascade of errors + + * the type signature might be ambiguous, in which case checking + the code against the signature will give a very similar error + to the ambiguity error. + +ToDo: this means we fall over if any top-level type signature in the +module is wrong, because we typecheck all the signatures together +(see GHC.Tc.Gen.Bind.tcValBinds). Moreover, because of top-level +captureTopConstraints, only insoluble constraints will be reported. +We typecheck all signatures at the same time because a signature +like f,g :: blah might have f and g from different SCCs. + +So it's a bit awkward to get better error recovery, and no one +has complained! +-} + +{- ********************************************************************* +* * + Type checking a pattern synonym signature +* * +************************************************************************ + +Note [Pattern synonym signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Pattern synonym signatures are surprisingly tricky (see #11224 for example). +In general they look like this: + + pattern P :: forall univ_tvs. req_theta + => forall ex_tvs. prov_theta + => arg1 -> .. -> argn -> res_ty + +For parsing and renaming we treat the signature as an ordinary LHsSigType. + +Once we get to type checking, we decompose it into its parts, in tcPatSynSig. + +* Note that 'forall univ_tvs' and 'req_theta =>' + and 'forall ex_tvs' and 'prov_theta =>' + are all optional. We gather the pieces at the top of tcPatSynSig + +* Initially the implicitly-bound tyvars (added by the renamer) include both + universal and existential vars. + +* After we kind-check the pieces and convert to Types, we do kind generalisation. + +Note [Report unsolved equalities in tcPatSynSig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important that we solve /all/ the equalities in a pattern +synonym signature, because we are going to zonk the signature to +a Type (not a TcType), in GHC.Tc.TyCl.PatSyn.tc_patsyn_finish, and that +fails if there are un-filled-in coercion variables mentioned +in the type (#15694). + +So we solve all the equalities we can, and report any unsolved ones, +rather than leaving them in the ambient constraints to be solved +later. Pattern synonyms are top-level, so there's no problem with +completely solving them. +-} + +tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynSig +-- See Note [Pattern synonym signatures] +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty})) + | (hs_req, hs_ty1) <- splitLHsQualTy hs_ty + , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 + = do { traceTc "tcPatSynSig 1" (ppr sig_ty) + + ; skol_info <- mkSkolemInfo (DataConSkol name) + ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty)))) + <- pushLevelAndSolveEqualitiesX "tcPatSynSig" $ + -- See Note [Report unsolved equalities in tcPatSynSig] + do { res_kind <- newOpenTypeKind + -- "open" because a (literal) pattern can be unlifted; + -- e.g. pattern Zero <- 0# (#12094) + -- See Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType + ; tcOuterTKBndrs skol_info hs_outer_bndrs $ + tcExplicitTKBndrs skol_info ex_hs_tvbndrs $ + do { req <- tcHsContext hs_req + ; prov <- tcHsContext hs_prov + ; body_ty <- tcCheckLHsType hs_body_ty res_kind + ; return (req, prov, body_ty) } } + + ; let implicit_tvs :: [TcTyVar] + univ_bndrs :: [TcInvisTVBinder] + (implicit_tvs, univ_bndrs) = case outer_bndrs of + HsOuterImplicit{hso_ximplicit = implicit_tvs} -> (implicit_tvs, []) + HsOuterExplicit{hso_xexplicit = univ_bndrs} -> ([], univ_bndrs) + + ; implicit_tvs <- zonkAndScopedSort implicit_tvs + ; let implicit_bndrs = mkTyVarBinders SpecifiedSpec implicit_tvs + + -- Kind generalisation + ; let ungen_patsyn_ty = build_patsyn_type implicit_bndrs univ_bndrs + req ex_bndrs prov body_ty + ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty) + ; kvs <- kindGeneralizeAll skol_info ungen_patsyn_ty + ; reportUnsolvedEqualities skol_info kvs tclvl wanted + -- See Note [Report unsolved equalities in tcPatSynSig] + + -- These are /signatures/ so we zonk to squeeze out any kind + -- unification variables. Do this after kindGeneralizeAll which may + -- default kind variables to *. + ; (kv_bndrs, implicit_bndrs, univ_bndrs, ex_bndrs, req, prov, body_ty) <- + initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX (mkTyVarBinders InferredSpec kvs)) $ \ kv_bndrs -> + runZonkBndrT (zonkTyVarBindersX implicit_bndrs) $ \ implicit_bndrs -> + runZonkBndrT (zonkTyVarBindersX univ_bndrs) $ \ univ_bndrs -> + do { req <- zonkTcTypesToTypesX req + ; runZonkBndrT (zonkTyVarBindersX ex_bndrs) $ \ ex_bndrs -> + do { prov <- zonkTcTypesToTypesX prov + ; body_ty <- zonkTcTypeToTypeX body_ty + ; return (kv_bndrs, implicit_bndrs, univ_bndrs, ex_bndrs, + req, prov, body_ty) } } + + -- Now do validity checking + ; checkValidType ctxt $ + build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty + + -- Neither argument types nor the return type may be representation polymorphic. + -- This is because, when creating a matcher: + -- - the argument types become the binder types (see test RepPolyPatySynArg), + -- - the return type becomes the scrutinee type (see test RepPolyPatSynRes). + ; let (arg_tys, res_ty) = tcSplitFunTys body_ty + ; mapM_ + (\(Scaled _ arg_ty) -> checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigArg arg_ty) + arg_tys + ; checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigRes res_ty + + ; traceTc "tcTySig }" $ + vcat [ text "kvs" <+> ppr_tvs (binderVars kv_bndrs) + , text "implicit_tvs" <+> ppr_tvs (binderVars implicit_bndrs) + , text "univ_tvs" <+> ppr_tvs (binderVars univ_bndrs) + , text "req" <+> ppr req + , text "ex_tvs" <+> ppr_tvs (binderVars ex_bndrs) + , text "prov" <+> ppr prov + , text "body_ty" <+> ppr body_ty ] + ; return $ + PatSig { patsig_name = name + , patsig_implicit_bndrs = kv_bndrs ++ implicit_bndrs + , patsig_univ_bndrs = univ_bndrs + , patsig_req = req + , patsig_ex_bndrs = ex_bndrs + , patsig_prov = prov + , patsig_body_ty = body_ty } } + where + ctxt = PatSynCtxt name + + build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body + = mkInvisForAllTys implicit_bndrs $ + mkInvisForAllTys univ_bndrs $ + mk_naked_phi_ty req $ + mkInvisForAllTys ex_bndrs $ + mk_naked_phi_ty prov $ + body + + -- Use mk_naked_phi_ty because we call build_patsyn_type /before zonking/ + -- just before kindGeneraliseAll, and the invariants that mkPhiTy checks + -- don't hold of the un-zonked types. #22521 was a case in point. + -- (We also called build_patsyn_type on the fully zonked type, so mkPhiTy + -- would work; but it doesn't seem worth duplicating the code.) + mk_naked_phi_ty :: [TcPredType] -> TcType -> TcType + mk_naked_phi_ty theta body = foldr (mkNakedFunTy invisArgTypeLike) body theta + +ppr_tvs :: [TyVar] -> SDoc +ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) + | tv <- tvs]) + + +{- ********************************************************************* +* * + Instantiating user signatures +* * +********************************************************************* -} + + +tcInstSig :: TcIdSig -> TcM TcIdSigInst +-- Instantiate a type signature; only used with plan InferGen +tcInstSig hs_sig@(TcCompleteSig (CSig { sig_bndr = poly_id, sig_loc = loc })) + = setSrcSpan loc $ -- Set the binding site of the tyvars + do { (tv_prs, theta, tau) <- tcInstTypeBndrs (idType poly_id) + -- See Note [Pattern bindings and complete signatures] + + ; return (TISI { sig_inst_sig = hs_sig + , sig_inst_skols = tv_prs + , sig_inst_wcs = [] + , sig_inst_wcx = Nothing + , sig_inst_theta = theta + , sig_inst_tau = tau }) } + +tcInstSig hs_sig@(TcPartialSig (PSig { psig_hs_ty = hs_ty + , psig_ctxt = ctxt + , psig_loc = loc })) + = setSrcSpan loc $ -- Set the binding site of the tyvars + do { traceTc "Staring partial sig {" (ppr hs_sig) + ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty + -- See Note [Checking partial type signatures] in GHC.Tc.Gen.HsType + + ; let inst_sig = TISI { sig_inst_sig = hs_sig + , sig_inst_skols = tv_prs + , sig_inst_wcs = wcs + , sig_inst_wcx = wcx + , sig_inst_theta = theta + , sig_inst_tau = tau } + ; traceTc "End partial sig }" (ppr inst_sig) + ; return inst_sig } + +{- Note [Pattern bindings and complete signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = MkT a a + f :: forall a. a->a + g :: forall b. b->b + MkT f g = MkT (\x->x) (\y->y) +Here we'll infer a type from the pattern of 'T a', but if we feed in +the signature types for f and g, we'll end up unifying 'a' and 'b' + +So we instantiate f and g's signature with TyVarTv skolems +(newMetaTyVarTyVars) that can unify with each other. If too much +unification takes place, we'll find out when we do the final +impedance-matching check in GHC.Tc.Gen.Bind.mkExport + +See Note [TyVarTv] in GHC.Tc.Utils.TcMType + +None of this applies to a function binding with a complete +signature, which doesn't use tcInstSig. See GHC.Tc.Gen.Bind.tcPolyCheck. +-} + +{- ********************************************************************* +* * + Pragmas and PragEnv +* * +********************************************************************* -} + +type TcPragEnv = NameEnv [LSig GhcRn] + +emptyPragEnv :: TcPragEnv +emptyPragEnv = emptyNameEnv + +lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn] +lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] + +extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv +extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) Utils.singleton prag_fn n sig + +--------------- +mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv +mkPragEnv sigs binds + = foldl' extendPragEnv emptyNameEnv prs + where + prs = mapMaybe get_sig sigs + + get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) + get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig) + get_sig sig@(L _ (SpecSigE nm _ _ _)) = Just (nm, add_arity nm sig) + get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig) + get_sig sig@(L _ (SCCFunSig _ (L _ nm) _)) = Just (nm, sig) + get_sig _ = Nothing + + add_arity n sig -- Adjust inl_sat field to match visible arity of function + = case lookupNameEnv ar_env n of + Just ar -> addInlinePragArity ar sig + Nothing -> sig -- See Note [Pattern synonym inline arity] + + -- ar_env maps a local to the arity of its definition + ar_env :: NameEnv Arity + ar_env = foldr lhsBindArity emptyNameEnv binds + +addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn +addInlinePragArity ar (L l (InlineSig x nm inl)) = L l (InlineSig x nm (add_inl_arity ar inl)) +addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl)) +addInlinePragArity ar (L l (SpecSigE n x e inl)) = L l (SpecSigE n x e (add_inl_arity ar inl)) +addInlinePragArity _ sig = sig + +add_inl_arity :: Arity -> InlinePragma -> InlinePragma +add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec }) + | Inline {} <- inl_spec -- Add arity only for real INLINE pragmas, not INLINABLE + = prag { inl_sat = Just ar } + | otherwise + = prag + +lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity +lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env + = extendNameEnv env (unLoc id) (matchGroupArity ms) +lhsBindArity _ env = env -- PatBind/VarBind + + +----------------- +addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId +addInlinePrags poly_id prags_for_me + | inl@(L _ prag) : inls <- inl_prags + = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) + ; unless (null inls) (warn_multiple_inlines inl inls) + ; return (poly_id `setInlinePragma` prag) } + | otherwise + = return poly_id + where + inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me] + + warn_multiple_inlines _ [] = return () + + warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls) + | inlinePragmaActivation prag1 == inlinePragmaActivation prag2 + , noUserInlineSpec (inlinePragmaSpec prag1) + = -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop + -- and inl2 is a user NOINLINE pragma; we don't want to complain + warn_multiple_inlines inl2 inls + | otherwise + = setSrcSpanA loc $ + let dia = TcRnMultipleInlinePragmas poly_id inl1 (inl2 NE.:| inls) + in addDiagnosticTc dia + + +{- Note [Pattern synonym inline arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + {-# INLINE P #-} + pattern P x = (x, True) + +The INLINE pragma attaches to both the /matcher/ and the /builder/ for +the pattern synonym; see Note [Pragmas for pattern synonyms] in +GHC.Tc.TyCl.PatSyn. But they have different inline arities (i.e. number +of binders to which we apply the function before inlining), and we don't +know what those arities are yet. So for pattern synonyms we don't set +the inl_sat field yet; instead we do so (via addInlinePragArity) in +GHC.Tc.TyCl.PatSyn.tcPatSynMatcher and tcPatSynBuilderBind. + +It's a bit messy that we set the arities in different ways. Perhaps we +should add the arity later for all binders. But it works fine like this. +-} + + +{- ********************************************************************* +* * + SPECIALISE pragmas +* * +************************************************************************ + +Note [Overview of SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea is this: + + foo :: Num a => a -> b -> a + foo = rhs + {-# SPECIALISE foo :: Int -> b -> Int #-} -- Old form + {-# SPECIALISE foo @Float #-} -- New form + +Generally: +* Rename as usual +* Typecheck, attaching info to the ABExport record of the AbsBinds for foo +* Desugar by generating + - a specialised binding $sfoo = rhs @Float + - a rewrite rule like RULE "USPEC foo" foo @Float = $sfoo + +There are two major routes: + +* Old form + - Handled by `SpecSig` and `SpecPrag` + - Deals with SPECIALISE pragmas have multiple signatures + {-# SPECIALISE f :: Int -> Int, Float -> Float #-} + - See Note [Handling old-form SPECIALISE pragmas] + - Deprecated, to be removed in GHC 9.18 as per #25540. + +* New form, described in GHC Proposal #493 + - Handled by `SpecSigE` and `SpecPragE` + - Deals with SPECIALISE pragmas which may have value arguments + {-# SPECIALISE f @Int 3 #-} + - See Note [Handling new-form SPECIALISE pragmas] + +Note [Handling new-form SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +New-form SPECIALISE pragmas are described by GHC Proposal #493. + +The pragma takes the form of a function application, possibly with intervening +parens and type signatures, with a variable at the head: + + {-# SPECIALISE f1 @Int 3 #-} + {-# SPECIALISE f2 :: Int -> Int #-} + {-# SPECIALISE (f3 :: Int -> Int) 5 #-} + +It may also have rule for-alls at the top, e.g. + + {-# SPECIALISE forall x xs. f4 (x:xs) #-} + {-# SPECIALISE forall a. forall x xs. f5 @a @a (x:xs) #-} + +See `GHC.Rename.Bind.checkSpecESigShape` for the shape-check. + +Example: + f :: forall a b. (Eq a, Eq b, Eq c) => a -> b -> c -> Bool -> blah + {-# SPECIALISE forall x y. f (x::Int) y y True #-} + -- y::p + +We want to generate: + + RULE forall @p (d1::Eq Int) (d2::Eq p) (d3::Eq p) (x::Int) (y::p). + f @Int @p @p d1 d2 d3 x y y True + = $sf @p d2 x y + $sf @p (d2::Eq p) (x::Int) (y::p) + = let d1 = $fEqInt + d3 = d2 + in @p @p @Int (d1::Eq p) (d2::Eq p) (d3::Eq p) x y y True + +Note that + +* The `rule_bndrs`, over which the RULE is quantified, are all the variables + free in the call to `f`, /ignoring/ all dictionary simplification. Why? + Because we want to make the rule maximally applicable; provided the types + match, the dictionaries should match. + + rule_bndrs = @p (d1::Eq Int) (d2::Eq p) (d3::Eq p) (x::Int) (y::p). + + Note that we have separate binders for `d1` and `d2` even though they are + the same (Eq p) dictionary. Reason: we don't want to force them to be visibly + equal at the call site. + +* The `spec_bndrs`, which are lambda-bound in the specialised function `$sf`, + are a subset of `rule_bndrs`. + + spec_bndrs = @p (d2::Eq p) (x::Int) (y::p) + +* The `spec_const_binds` make up the difference between `rule_bndrs` and + `spec_bndrs`. They communicate the specialisation! + If `spec_bndrs` = `rule_bndrs`, no specialisation has happened. + + spec_const_binds = let d1 = $fEqInt + d3 = d2 + +This is done in three parts. + + A. Typechecker: `GHC.Tc.Gen.Sig.tcSpecPrag` + + (1) Typecheck the expression, capturing its constraints + + (2) Solve these constraints. When doing so, switch on `tcsmFullySolveQCIs`; + see wrinkle (NFS1) below. + + (3) Compute the constraints to quantify over, using `getRuleQuantCts` on + the unsolved constraints returned by (2). + + (4) Emit the residual (non-solved, non-quantified) constraints, and wrap the + expression in a let binding for those constraints. + + (5) Wrap the call in the combined evidence bindings from steps (2) and (4) + + (6) Store all the information in a 'SpecPragE' record, to be consumed + by the desugarer. + + B. Zonker: `GHC.Tc.Zonk.Type.zonkLTcSpecPrags` + + The zonker does a little extra work to collect any free type variables + of the LHS. See Note [Free tyvars on rule LHS] in GHC.Tc.Zonk.Type. + These weren't conveniently available earlier. + + C. Desugarer: `GHC.HsToCore.Binds.dsSpec`. + + See Note [Desugaring new-form SPECIALISE pragmas] in GHC.HsToCore.Binds for details, + but in brief: + + (1) Simplify the expression. This is important because a type signature in + the expression will have led to type/dictionary abstractions/applications. + After simplification it should look like + let in f d1 d2 d3 + + (2) `prepareSpecLHS` identifies the `spec_const_binds`, discards the other + dictionary bindings, and decomposes the call. + + (3) Then we build the specialised function $sf, and concoct a RULE + of the form: + forall @a @b d1 d2 d3. f d1 d2 d3 = $sf d1 d2 d3 + +(NFS1) Consider + f :: forall f a. (Ix a, forall x. Eq x => Eq (f x)) => a -> f a + {-# SPECIALISE f :: forall f. (forall x. Eq x => Eq (f x)) => Int -> f Int #-} + This SPECIALISE is treated like an expression with a type signature, so + we instantiate the constraints, simplify them and re-generalise. From the + instantiation we get [W] d :: (forall x. Eq a => Eq (f x)) + and we want to generalise over that. We do not want to attempt to solve it + and then get stuck, and emit an error message. If we can't solve it, it is + much, much better to leave it alone. + + We still need to simplify quantified constraints that can be /fully solved/ + from instances, otherwise we would never be able to specialise them + away. Example: {-# SPECIALISE f @[] @a #-}. So: + + * The constraint solver has a mode flag `tcsmFullySolveQCIs` that says + "fully solve quantified constraint, or leave them alone + * When simplifying constraints in a SPECIALISE pragma, we switch on this + flag the `SpecPragE` case of `tcSpecPrag`. + + You might worry about the wasted work from failed attempts to fully-solve, but + it is seldom repeated (because the constraint solver seldom iterates much). + +Note [Handling old-form SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: this code path is deprecated, and is scheduled to be removed in GHC 9.18, as per #25440. +We check that + (forall a b. Num a => a -> b -> a) + is more polymorphic than + forall b. Int -> b -> Int +(for which we could use tcSubType, but see below), generating a HsWrapper +to connect the two, something like + wrap = /\b. Int b dNumInt +This wrapper is put in the TcSpecPrag, in the ABExport record of +the AbsBinds. + + + f :: (Eq a, Ix b) => a -> b -> Bool + {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} + f = + +From this the typechecker generates + + AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds + + SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX + -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) + + wrap_fn = /\ p q \(d1::Ix p)(d2:Ix q). + let w1 = $fEqInt + w2 = $fIxPair d1 d2 + HOLE @Int @(p,q) (w1:Eq Int) (w2:Ix (p,q)) + +From these we generate: + + Rule: forall p, q, (dInt::Eq Int), (dp:Ix p), (dq:Ix q). + f Int (p,q) dInt ($fIxPair dp dq) = f_spec p q dp dq + + Spec bind: f_spec = wrap_fn[ ] + +Note that + + * The LHS of the rule may mention dictionary *expressions* (eg + $fIxPair dp dq), and that is essential because the dp, dq are + needed on the RHS. + + * The RHS of f_spec, has a *copy* of 'binds', so that it + can fully specialise it. + +From the TcSpecPrag, in GHC.HsToCore.Binds we generate a binding for f_spec and a RULE: + + f_spec :: Int -> b -> Int + f_spec = wrap + + RULE: forall b (d:Num b). f b d = f_spec b + +The RULE is generated by taking apart the HsWrapper, which is a little +delicate, but works. + +Some wrinkles + +1. In tcSpecWrapper, rather than calling tcSubType, we directly call + skolemise/instantiate. That is mainly because of wrinkle (2). + + Historical note: in the past, tcSubType did co/contra stuff, which + could generate too complex a LHS for the RULE, which was another + reason for not using tcSubType. But that reason has gone away + with simple subsumption (#17775). + +2. We need to take care with type families (#5821). Consider + type instance F Int = Bool + f :: Num a => a -> F a + {-# SPECIALISE foo :: Int -> Bool #-} + + We *could* try to generate an f_spec with precisely the declared type: + f_spec :: Int -> Bool + f_spec = Int dNumInt |> co + + RULE: forall d. f Int d = f_spec |> sym co + + but the 'co' and 'sym co' are (a) playing no useful role, and (b) are + hard to generate. At all costs we must avoid this: + RULE: forall d. f Int d |> co = f_spec + because the LHS will never match (indeed it's rejected in + decomposeRuleLhs). + + So we simply do this: + - Generate a constraint to check that the specialised type (after + skolemisation) is equal to the instantiated function type. + - But *discard* the evidence (coercion) for that constraint, + so that we ultimately generate the simpler code + f_spec :: Int -> F Int + f_spec = Int dNumInt + + RULE: forall d. f Int d = f_spec + You can see this discarding happening in tcSpecPrag + +3. Note that the HsWrapper can transform *any* function with the right + type prefix + forall ab. (Eq a, Ix b) => XXX + regardless of XXX. It's sort of polymorphic in XXX. This is + useful: we use the same wrapper to transform each of the class ops, as + well as the dict. That's what goes on in GHC.Tc.TyCl.Instance.mk_meth_spec_prags + +Note [SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no point in a SPECIALISE pragma for a non-overloaded function: + reverse :: [a] -> [a] + {-# SPECIALISE reverse :: [Int] -> [Int] #-} + +But SPECIALISE INLINE *can* make sense for GADTS: + data Arr e where + ArrInt :: !Int -> ByteArray# -> Arr Int + ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) + + (!:) :: Arr e -> Int -> e + {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} + {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} + (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) + (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) + +When (!:) is specialised it becomes non-recursive, and can usefully +be inlined. Scary! So we only warn for SPECIALISE *without* INLINE +for a non-overloaded function. +-} + +tcSpecPrags :: Id -> [LSig GhcRn] + -> TcM [LTcSpecPrag] +-- Add INLINE and SPECIALISE pragmas +-- INLINE prags are added to the (polymorphic) Id directly +-- SPECIALISE prags are passed to the desugarer via TcSpecPrags +-- Pre-condition: the poly_id is zonked +-- Reason: required by tcSubExp +tcSpecPrags poly_id prag_sigs + = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) + ; whenIsJust (NE.nonEmpty bad_sigs) warn_discarded_sigs + ; pss <- mapAndRecoverM (wrapLocMA (tcSpecPrag poly_id)) spec_sigs + ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } + where + spec_sigs = filter isSpecLSig prag_sigs + bad_sigs = filter is_bad_sig prag_sigs + is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) + + warn_discarded_sigs bad_sigs_ne + = let dia = TcRnUnexpectedPragmas poly_id bad_sigs_ne + in addDiagnosticTc dia + +-------------- +tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] +tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) +-- See Note [Handling old-form SPECIALISE pragmas] +-- +-- The Name fun_name in the SpecSig may not be the same as that of the poly_id +-- Example: SPECIALISE for a class method: the Name in the SpecSig is +-- for the selector Id, but the poly_id is something like $cop +-- However we want to use fun_name in the error message, since that is +-- what the user wrote (#8537) + = addErrCtxt (SpecPragmaCtxt prag) $ + do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $ + TcRnNonOverloadedSpecialisePragma fun_name + -- Note [SPECIALISE pragmas] + ; spec_prags <- mapM tc_one hs_tys + ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) + ; return spec_prags } + where + name = idName poly_id + poly_ty = idType poly_id + + tc_one hs_ty + = do { spec_ty <- tcHsSigType (FunSigCtxt name NoRRC) hs_ty + ; wrap <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty + ; return (SpecPrag poly_id wrap inl) } + +tcSpecPrag poly_id (SpecSigE nm rule_bndrs spec_e inl) + -- For running commentary, see Note [Handling new-form SPECIALISE pragmas] + = do { -- (1) Typecheck the expression, spec_e, capturing its constraints + let skol_info_anon = SpecESkol nm + ; traceTc "tcSpecPrag SpecSigE {" (ppr nm $$ ppr spec_e) + ; skol_info <- mkSkolemInfo skol_info_anon + ; (rhs_tclvl, spec_e_wanted, (rule_bndrs', (tc_spec_e, _rho))) + <- tcRuleBndrs skol_info rule_bndrs $ + tcInferRho spec_e + + -- (2) Solve the resulting wanteds + ; ev_binds_var <- newTcEvBinds + ; spec_e_wanted <- setTcLevel rhs_tclvl $ + runTcSWithEvBinds ev_binds_var $ + setTcSMode (vanillaTcSMode { tcsmFullySolveQCIs = True }) $ + -- tcsmFullySolveQCIs: see (NFS1) + solveWanteds spec_e_wanted + ; spec_e_wanted <- liftZonkM $ zonkWC spec_e_wanted + + -- (3) Compute which constraints to quantify over, by looking + -- at the unsolved constraints from (2) + ; (quant_cands, residual_wc) <- getRuleQuantCts spec_e_wanted + + -- (4) Emit the residual constraints (i.e. ones that we have + -- not solved in (2) nor quantified in (3) + -- NB: use the same `ev_binds_var` as (2), so the bindings + -- for (2) and (4) are combined + ; let tv_bndrs = filter isTyVar rule_bndrs' + qevs = map ctEvId (bagToList quant_cands) + ; emitResidualConstraints rhs_tclvl skol_info_anon ev_binds_var + emptyVarSet tv_bndrs qevs + residual_wc + + -- (5) Wrap the call in the combined evidence bindings + -- from steps (2) and (4) + ; let lhs_call = mkLHsWrap (WpLet (TcEvBinds ev_binds_var)) tc_spec_e + + ; ev_binds <- getTcEvBindsMap ev_binds_var + + ; traceTc "tcSpecPrag SpecSigE }" $ + vcat [ text "nm:" <+> ppr nm + , text "rule_bndrs':" <+> ppr rule_bndrs' + , text "qevs:" <+> ppr qevs + , text "spec_e:" <+> ppr tc_spec_e + , text "inl:" <+> ppr inl + , text "spec_e_wanted:" <+> ppr spec_e_wanted + , text "quant_cands:" <+> ppr quant_cands + , text "residual_wc:" <+> ppr residual_wc + , text (replicate 80 '-') + , text "ev_binds_var:" <+> ppr ev_binds_var + , text "ev_binds:" <+> ppr ev_binds + ] + + -- (6) Store the results in a SpecPragE record, which will be + -- zonked and then consumed by the desugarer. + + ; return [SpecPragE { spe_fn_nm = nm + , spe_fn_id = poly_id + , spe_bndrs = qevs ++ rule_bndrs' -- Dependency order + -- does not matter + , spe_call = lhs_call + , spe_inl = inl }] } + +tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag) + +-------------- +tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper +-- A simpler variant of tcSubType, used for SPECIALISE pragmas +-- See Note [Handling old-form SPECIALISE pragmas], wrinkle 1 +tcSpecWrapper ctxt poly_ty spec_ty + = do { (sk_wrap, inst_wrap) + <- tcSkolemise Shallow ctxt spec_ty $ \spec_tau -> + do { (inst_wrap, tau) <- topInstantiate orig poly_ty + ; _ <- unifyType Nothing spec_tau tau + -- Deliberately ignore the evidence + -- See Note [Handling old-form SPECIALISE pragmas], + -- wrinkle (2) + ; return inst_wrap } + ; return (sk_wrap <.> inst_wrap) } + where + orig = SpecPragOrigin ctxt + +-------------- +tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag] +-- SPECIALISE pragmas for imported things +tcImpPrags prags + = do { dflags <- getDynFlags + ; traceTc "tcImpPrags1" (ppr prags) + ; if (not_specialising dflags) then + return [] + else do + { this_mod <- getModule + ; pss <- mapAndRecoverM (wrapLocMA (tcImpSpec this_mod)) prags + ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } } + where + -- Ignore SPECIALISE pragmas for imported things + -- when we aren't specialising, or when we aren't generating + -- code. The latter happens when Haddocking the base library; + -- we don't want complaints about lack of INLINABLE pragmas + not_specialising dflags = + not (gopt Opt_Specialise dflags) || not (backendRespectsSpecialise (backend dflags)) + +tcImpSpec :: Module -> Sig GhcRn -> TcM [TcSpecPrag] +tcImpSpec this_mod prag + | Just name <- is_spec_prag prag -- It's a specialisation pragma + , not (nameIsLocalOrFrom this_mod name) -- The Id is imported + = do { id <- tcLookupId name + ; if hasSomeUnfolding (realIdUnfolding id) + -- See Note [SPECIALISE pragmas for imported Ids] + then tcSpecPrag id prag + else do { let dia = TcRnSpecialiseNotVisible name + ; addDiagnosticTc dia + ; return [] } } + | otherwise + = return [] + where + is_spec_prag (SpecSig _ (L _ nm) _ _) = Just nm + is_spec_prag (SpecSigE nm _ _ _) = Just nm + is_spec_prag _ = Nothing + +{- Note [SPECIALISE pragmas for imported Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An imported Id may or may not have an unfolding. If not, we obviously +can't specialise it here; indeed the desugar falls over (#18118). + +We used to test whether it had a user-specified INLINABLE pragma but, +because of Note [Worker/wrapper for INLINABLE functions] in +GHC.Core.Opt.WorkWrap, even an INLINABLE function may end up with +a wrapper that has no pragma, just an unfolding (#19246). So now +we just test whether the function has an unfolding. + +There's a risk that a pragma-free function may have an unfolding now +(because it is fairly small), and then gets a bit bigger, and no +longer has an unfolding in the future. But then you'll get a helpful +error message suggesting an INLINABLE pragma, which you can follow. +That seems enough for now. +-} + + +{- ********************************************************************* +* * + Rules +* * +************************************************************************ + +Note [Typechecking rules] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We *infer* the type of the LHS, and use that type to *check* the type of +the RHS. That means that higher-rank rules work reasonably well. Here's +an example (test simplCore/should_compile/rule2.hs) produced by Roman: + + foo :: (forall m. m a -> m b) -> m a -> m b + foo f = ... + + bar :: (forall m. m a -> m a) -> m a -> m a + bar f = ... + + {-# RULES "foo/bar" foo = bar #-} + +He wanted the rule to typecheck. + +Note [TcLevel in type checking rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Bringing type variables into scope naturally bumps the TcLevel. Thus, we type +check the term-level binders in a bumped level, and we must accordingly bump +the level whenever these binders are in scope. + +Note [Re-quantify type variables in rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example from #17710: + + foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b + foo x = Proxy + {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-} + +Written out in more detail, the "foo" rewrite rule looks like this: + + forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0 + +Where b0 is a unification variable. Where should b0 be quantified? We have to +quantify it after k, since (b0 :: k). But generalization usually puts inferred +type variables (such as b0) at the /front/ of the telescope! This creates a +conflict. + +One option is to simply throw an error, per the principles of +Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType. This is what would happen +if we were generalising over a normal type signature. On the other hand, the +types in a rewrite rule aren't quite "normal", since the notions of specified +and inferred type variables aren't applicable. + +A more permissive design (and the design that GHC uses) is to simply requantify +all of the type variables. That is, we would end up with this: + + forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b + +It's a bit strange putting the generalized variable `b` after the user-written +variables `k` and `a`. But again, the notion of specificity is not relevant to +rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not +only makes "foo" typecheck, but it also makes the implementation simpler. + +See also Note [Generalising in tcTyFamInstEqnGuts] in GHC.Tc.TyCl, which +explains a very similar design when generalising over a type family instance +equation. +-} + +tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc] +tcRules decls = mapM (wrapLocMA tcRuleDecls) decls + +tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc) +tcRuleDecls (HsRules { rds_ext = src + , rds_rules = decls }) + = do { maybe_tc_decls <- mapM (wrapLocMA tcRule) decls + ; let tc_decls = [L loc rule | (L loc (Just rule)) <- maybe_tc_decls] + ; return $ HsRules { rds_ext = src + , rds_rules = tc_decls } } + +tcRule :: RuleDecl GhcRn -> TcM (Maybe (RuleDecl GhcTc)) +tcRule (HsRule { rd_ext = ext + , rd_name = rname@(L _ name) + , rd_act = act + , rd_bndrs = bndrs + , rd_lhs = lhs + , rd_rhs = rhs }) + = addErrCtxt (RuleCtxt name) $ + do { traceTc "---- Rule ------" (pprFullRuleName (snd ext) rname) + ; skol_info <- mkSkolemInfo (RuleSkol name) + -- Note [Typechecking rules] + ; (tc_lvl, lhs_wanted, stuff) + <- tcRuleBndrs skol_info bndrs $ + do { (lhs', rule_ty) <- tcInferRho lhs + ; (rhs', rhs_wanted) <- captureConstraints $ + tcCheckMonoExpr rhs rule_ty + ; return (lhs', rule_ty, rhs', rhs_wanted) } + + ; let (bndrs', (lhs', rule_ty, rhs', rhs_wanted)) = stuff + + ; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname + , ppr lhs_wanted + , ppr rhs_wanted ]) + + ; (lhs_evs, residual_lhs_wanted, dont_default) + <- simplifyRule name tc_lvl lhs_wanted rhs_wanted + + -- SimplifyRule Plan, step 4 + -- Now figure out what to quantify over + -- c.f. GHC.Tc.Solver.simplifyInfer + -- We quantify over any tyvars free in *either* the rule + -- *or* the bound variables. The latter is important. Consider + -- ss (x,(y,z)) = (x,z) + -- RULE: forall v. fst (ss v) = fst v + -- The type of the rhs of the rule is just a, but v::(a,(b,c)) + -- + -- We also need to get the completely-unconstrained tyvars of + -- the LHS, lest they otherwise get defaulted to Any; but we do that + -- during zonking (see GHC.Tc.Zonk.Type.zonkRule) + + ; let tpl_ids = lhs_evs ++ filter isId bndrs' + + -- See Note [Re-quantify type variables in rules] + ; dvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids) + ; let weed_out = (`dVarSetMinusVarSet` dont_default) + weeded_dvs = weedOutCandidates weed_out dvs + ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars weeded_dvs + ; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname + , text "dvs:" <+> ppr dvs + , text "weeded_dvs:" <+> ppr weeded_dvs + , text "dont_default:" <+> ppr dont_default + , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted + , text "qtkvs:" <+> ppr qtkvs + , text "rule_ty:" <+> ppr rule_ty + , text "bndrs:" <+> ppr bndrs + , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids) + , text "tpl_id info:" <+> + vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] + ]) + + -- /Temporarily/ deal with the fact that we previously accepted + -- rules that quantify over certain equality constraints. + -- + -- See Note [Quantifying over equalities in RULES]. + ; case allPreviouslyQuantifiableEqualities residual_lhs_wanted of { + Just cts | not (insolubleWC rhs_wanted) + -> do { addDiagnostic $ TcRnRuleLhsEqualities name lhs cts + ; return Nothing } ; + _ -> + + do { -- SimplifyRule Plan, step 5 + -- Simplify the LHS and RHS constraints: + -- For the LHS constraints we must solve the remaining constraints + -- (a) so that we report insoluble ones + -- (b) so that we bind any soluble ones + (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs + lhs_evs residual_lhs_wanted + ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs + lhs_evs rhs_wanted + + ; emitImplications (lhs_implic `unionBags` rhs_implic) + + ; return $ Just $ + HsRule { rd_ext = ext + , rd_name = rname + , rd_act = act + , rd_bndrs = bndrs { rb_ext = qtkvs ++ tpl_ids } + , rd_lhs = mkHsDictLet lhs_binds lhs' + , rd_rhs = mkHsDictLet rhs_binds rhs' } } } } + +{- ******************************************************************************** +* * + tcRuleBndrs +* * +******************************************************************************** -} + +tcRuleBndrs :: SkolemInfo -> RuleBndrs GhcRn + -> TcM a -- Typecheck this with the rule binders in scope + -> TcM (TcLevel, WantedConstraints, ([Var], a)) + -- The [Var] are the explicitly-quantified variables, + -- both type variables and term variables +tcRuleBndrs skol_info (RuleBndrs { rb_tyvs = mb_tv_bndrs, rb_tmvs = tm_bndrs }) + thing_inside + = pushLevelAndCaptureConstraints $ + case mb_tv_bndrs of + Nothing -> go_tms tm_bndrs thing_inside + Just tv_bndrs -> do { (bndrs1, (bndrs2, res)) <- go_tvs tv_bndrs $ + go_tms tm_bndrs $ + thing_inside + ; return (binderVars bndrs1 ++ bndrs2, res) } + where + -------------- + go_tvs tvs thing_inside = bindExplicitTKBndrs_Skol skol_info tvs thing_inside + + -------------- + go_tms [] thing_inside + = do { res <- thing_inside; return ([], res) } + go_tms (L _ (RuleBndr _ (L _ name)) : rule_bndrs) thing_inside + = do { ty <- newOpenFlexiTyVarTy + ; let bndr_id = mkLocalId name ManyTy ty + ; (bndrs, res) <- tcExtendIdEnv [bndr_id] $ + go_tms rule_bndrs thing_inside + ; return (bndr_id : bndrs, res) } + + go_tms (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) thing_inside + -- 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 { (_ , tv_prs, id_ty) <- tcRuleBndrSig name skol_info rn_ty + ; let bndr_id = mkLocalId name ManyTy id_ty + -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType + + -- The type variables scope over subsequent bindings; yuk + ; (bndrs, res) <- tcExtendNameTyVarEnv tv_prs $ + tcExtendIdEnv [bndr_id] $ + go_tms rule_bndrs thing_inside + ; return (map snd tv_prs ++ bndr_id : bndrs, res) } + + +{- +********************************************************************************* +* * + Constraint simplification for rules +* * +*********************************************************************************** + +Note [The SimplifyRule Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example. Consider the following left-hand side of a rule + f (x == y) (y > z) = ... +If we typecheck this expression we get constraints + d1 :: Ord a, d2 :: Eq a +We do NOT want to "simplify" to the LHS + forall x::a, y::a, z::a, d1::Ord a. + f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... +Instead we want + forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. + f ((==) d2 x y) ((>) d1 y z) = ... + +Here is another example: + fromIntegral :: (Integral a, Num b) => a -> b + {-# RULES "foo" fromIntegral = id :: Int -> Int #-} +In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But +we *dont* want to get + forall dIntegralInt. + fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int +because the scsel will mess up RULE matching. Instead we want + forall dIntegralInt, dNumInt. + fromIntegral Int Int dIntegralInt dNumInt = id Int + +Even if we have + g (x == y) (y == z) = .. +where the two dictionaries are *identical*, we do NOT WANT + forall x::a, y::a, z::a, d1::Eq a + f ((==) d1 x y) ((>) d1 y z) = ... +because that will only match if the dict args are (visibly) equal. +Instead we want to quantify over the dictionaries separately. + +In short, simplifyRuleLhs must *only* squash equalities, leaving +all dicts unchanged, with absolutely no sharing. + +Also note that we can't solve the LHS constraints in isolation: +Example foo :: Ord a => a -> a + foo_spec :: Int -> Int + {-# RULE "foo" foo = foo_spec #-} +Here, it's the RHS that fixes the type variable + +HOWEVER, under a nested implication things are different +Consider + f :: (forall a. Eq a => a->a) -> Bool -> ... + {-# RULES "foo" forall (v::forall b. Eq b => b->b). + f b True = ... + #-} +Here we *must* solve the wanted (Eq a) from the given (Eq a) +resulting from skolemising the argument type of g. So we +revert to SimplCheck when going under an implication. + + +--------- So the SimplifyRule Plan is this ----------------------- + +* Step 0: typecheck the LHS and RHS to get constraints from each + +* Step 1: Simplify the LHS and RHS constraints all together in one bag, + but /discarding/ the simplified constraints. We do this only + to discover all unification equalities. + +* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take + advantage of those unifications + +* Step 3: Partition the LHS constraints into the ones we will + quantify over, and the others. + See Note [RULE quantification over equalities] + +* Step 4: Decide on the type variables to quantify over + +* Step 5: Simplify the LHS and RHS constraints separately, using the + quantified constraints as givens + +Note [Solve order for RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In step 1 above, we need to be a bit careful about solve order. +Consider + f :: Int -> T Int + type instance T Int = Bool + + RULE f 3 = True + +From the RULE we get + lhs-constraints: T Int ~ alpha + rhs-constraints: Bool ~ alpha +where 'alpha' is the type that connects the two. If we glom them +all together, and solve the RHS constraint first, we might solve +with alpha := Bool. But then we'd end up with a RULE like + + RULE: f 3 |> (co :: T Int ~ Bool) = True + +which is terrible. We want + + RULE: f 3 = True |> (sym co :: Bool ~ T Int) + +So we are careful to solve the LHS constraints first, and *then* the +RHS constraints. Actually much of this is done by the on-the-fly +constraint solving, so the same order must be observed in +tcRule. + +Note [RULE quantification over equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment a RULE never quantifies over an equality; see `rule_quant_ct` +in `getRuleQuantCts`. Why not? + + * It's not clear why we would want to do so (see Historical Note + below) + + * We do not want to quantify over insoluble equalities (Int ~ Bool) + (a) because we prefer to report a LHS type error + (b) because if such things end up in 'givens' we get a bogus + "inaccessible code" error + + * Matching on coercions is Deeply Suspicious. We don't want to generate a + RULE like + forall a (co :: F a ~ Int). + foo (x |> Sym co) = ...co... + because matching on that template, to bind `co`, would require us to + match on the /structure/ of a coercion, which we must never do. + See GHC.Core.Rules Note [Casts in the template] + + * Equality constraints are unboxed, and that leads to complications + For example equality constraints from the LHS will emit coercion hole + Wanteds. These don't have a name, so we can't quantify over them directly. + Instead, in `getRuleQuantCts`, we'd have to invent a new EvVar for the + coercion, fill the hole with the invented EvVar, and then quantify over the + EvVar. Here is old code from `mk_one` + do { ev_id <- newEvVar pred + ; fillCoercionHole hole (mkCoVarCo ev_id) + ; return ev_id } + But that led to new complications becuase of the side effect on the coercion + hole. Much easier just to side-step the issue entirely by not quantifying over + equalities. + +Historical Note: + Back in 2012 (5aa1ae24567) we started quantifying over some equality + constraints, saying + * But we do want to quantify over things like (a ~ F b), + where F is a type function. + It is not clear /why/ we did so, and we don't do so any longer. +End of historical note. + +Note [Simplify cloned constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At this stage, we're simplifying constraints only for insolubility +and for unification. Note that all the evidence is quickly discarded. +We use a clone of the real constraint. If we don't do this, +then RHS coercion-hole constraints get filled in, only to get filled +in *again* when solving the implications emitted from tcRule. That's +terrible, so we avoid the problem by cloning the constraints. + +-} + +simplifyRule :: RuleName + -> TcLevel -- Level at which to solve the constraints + -> WantedConstraints -- Constraints from LHS + -> WantedConstraints -- Constraints from RHS + -> TcM ( [EvVar] -- Quantify over these LHS vars + , WantedConstraints -- Residual un-quantified LHS constraints + , TcTyVarSet ) -- Don't default these +-- See Note [The SimplifyRule Plan] +-- NB: This consumes all simple constraints on the LHS, but not +-- any LHS implication constraints. +simplifyRule name tc_lvl lhs_wanted rhs_wanted + = do { + -- Note [The SimplifyRule Plan] step 1 + -- First solve the LHS and *then* solve the RHS + -- Crucially, this performs unifications + -- Why clone? See Note [Simplify cloned constraints] + ; lhs_clone <- cloneWC lhs_wanted + ; rhs_clone <- cloneWC rhs_wanted + ; (dont_default, _) + <- setTcLevel tc_lvl $ + runTcS $ + do { lhs_wc <- solveWanteds lhs_clone + ; _rhs_wc <- solveWanteds rhs_clone + -- Why do them separately? + -- See Note [Solve order for RULES] + + ; let dont_default = nonDefaultableTyVarsOfWC lhs_wc + -- If lhs_wanteds has + -- (a[sk] :: TYPE rr[sk]) ~ (b0[tau] :: TYPE r0[conc]) + -- we want r0 to be non-defaultable; + -- see nonDefaultableTyVarsOfWC. Simplest way to get + -- this is to look at the post-simplified lhs_wc, which + -- will contain (rr[sk] ~ r0[conc)]. An example is in + -- test rep-poly/RepPolyRule1 + ; return dont_default } + + -- Note [The SimplifyRule Plan] step 2 + ; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted + + -- Note [The SimplifyRule Plan] step 3 + ; (quant_cts, residual_lhs_wanted) <- getRuleQuantCts lhs_wanted + ; let quant_evs = map ctEvId (bagToList quant_cts) + + ; traceTc "simplifyRule" $ + vcat [ text "LHS of rule" <+> doubleQuotes (ftext name) + , text "lhs_wanted" <+> ppr lhs_wanted + , text "rhs_wanted" <+> ppr rhs_wanted + , text "quant_cts" <+> ppr quant_evs + , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted + , text "dont_default" <+> ppr dont_default + ] + + ; return (quant_evs, residual_lhs_wanted, dont_default) } + +getRuleQuantCts :: WantedConstraints -> TcM (Cts, WantedConstraints) +-- Extract all the constraints that we can quantify over, +-- also returning the depleted WantedConstraints +-- +-- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged, +-- and attempt to solve them from the quantified constraints. Instead +-- we /partition/ the WantedConstraints into ones to quantify and ones +-- we can't quantify. We could use approximateWC instead, and leave +-- `wanted` unchanged; but then we'd have to clone fresh binders and +-- generate silly identity bindings. Seems more direct to do this. +-- Probably not a big deal wither way. +-- +-- NB: we must look inside implications, because with +-- -fdefer-type-errors we generate implications rather eagerly; +-- see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732. + +getRuleQuantCts wc + = return $ float_wc emptyVarSet wc + where + float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints) + float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs }) + = ( simple_yes `andCts` implic_yes + , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_errors = errs }) + where + (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples + (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs) emptyBag implics + + float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication) + float_implic skol_tvs yes1 imp + = (yes1 `andCts` yes2, imp { ic_wanted = no }) + where + (yes2, no) = float_wc new_skol_tvs (ic_wanted imp) + new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp + + rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool + rule_quant_ct skol_tvs ct + | insolubleWantedCt ct + = False + | otherwise + = case classifyPredType (ctPred ct) of + EqPred {} -> False -- Note [RULE quantification over equalities] + _ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs + +{- Note [Quantifying over equalities in RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Up until version 9.12 (inclusive), GHC would happily quantify over certain Wanted +equalities in the LHS of a RULE. This was incorrect behaviour that led to a RULE +that would never fire, so GHC 9.14 and above no longer allow such RULES. +However, instead of throwing an error, GHC will /temporarily/ emit a warning +and drop the rule instead, in order to ease migration for library maintainers +(NB: this warning is not emitted when the RHS constraints are insoluble; in that +case we simply report those constraints as errors instead). +This warning is scheduled to be turned into an error, and the warning flag +removed (becoming a normal typechecker error), starting from version 9.18. + +The function 'allPreviouslyQuantifiableEqualities' computes the equality +constraints that previous (<= 9.12) versions of GHC accepted quantifying over. + + + Example (test case 'RuleEqs', extracted from the 'mono-traversable' library): + + type family Element mono + type instance Element [a] = a + + class MonoFoldable mono where + otoList :: mono -> [Element mono] + instance MonoFoldable [a] where + otoList = id + + ointercalate :: (MonoFoldable mono, Monoid (Element mono)) + => Element mono -> mono -> Element mono + {-# RULES "ointercalate list" forall x. ointercalate x = Data.List.intercalate x . otoList #-} + + Now, because Data.List.intercalate has the type signature + + forall a. [a] -> [[a]] -> [a] + + typechecking the LHS of this rule would give rise to the Wanted equality + + [W] Element mono ~ [a] + + Due to the type family, GHC 9.12 and below accepted to quantify over this + equality, which would lead to a rule LHS template of the form: + + forall (@mono) (@a) + ($dMonoFoldable :: MonoFoldable mono) + ($dMonoid :: Monoid (Element mono)) + (co :: [a] ~ Element mono) + (x :: [a]). + ointercalate @mono $dMonoFoldable $dMonoid + (x `cast` (Sub co)) + + Matching against this template would match on the structure of a coercion, + which goes against Note [Casts in the template] in GHC.Core.Rules. + In practice, this meant that this RULE would never fire. +-} + +-- | Computes all equality constraints that GHC doesn't accept, but previously +-- did accept (until GHC 9.12 (included)), when deciding what to quantify over +-- in the LHS of a RULE. +-- +-- See Note [Quantifying over equalities in RULES]. +allPreviouslyQuantifiableEqualities :: WantedConstraints -> Maybe (NE.NonEmpty Ct) +allPreviouslyQuantifiableEqualities wc = go emptyVarSet wc + where + go :: TyVarSet -> WantedConstraints -> Maybe (NE.NonEmpty Ct) + go skol_tvs (WC { wc_simple = simples, wc_impl = implics }) + = do { cts1 <- mapM (go_simple skol_tvs) simples + ; cts2 <- concatMapM (go_implic skol_tvs) implics + ; NE.nonEmpty $ toList cts1 ++ toList cts2 } + + go_simple :: TyVarSet -> Ct -> Maybe Ct + go_simple skol_tvs ct + | not (tyCoVarsOfCt ct `disjointVarSet` skol_tvs) + = Nothing + | EqPred _ t1 t2 <- classifyPredType (ctPred ct), ok_eq t1 t2 + = Just ct + | otherwise + = Nothing + + go_implic :: TyVarSet -> Implication -> Maybe [Ct] + go_implic skol_tvs (Implic { ic_skols = skols, ic_wanted = wc }) + = fmap toList $ go (skol_tvs `extendVarSetList` skols) wc + + ok_eq t1 t2 + | t1 `tcEqType` t2 = False + | otherwise = is_fun_app t1 || is_fun_app t2 + + is_fun_app ty -- ty is of form (F tys) where F is a type function + = case tyConAppTyCon_maybe ty of + Just tc -> isTypeFamilyTyCon tc + Nothing -> False diff --git a/GHC/Tc/Gen/Splice.hs b/GHC/Tc/Gen/Splice.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Splice.hs @@ -0,0 +1,3123 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE NamedFieldPuns #-} + +#if __GLASGOW_HASKELL__ < 914 +-- In GHC 9.14, GHC.Desugar will be removed from base in favour of +-- ghc-internal's GHC.Internal.Desugar. However, because of bootstrapping +-- concerns, we will only depend on ghc-internal when the boot compiler is +-- certain to have it. +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} +#endif + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Template Haskell splices +module GHC.Tc.Gen.Splice( + tcTypedSplice, tcTypedBracket, tcUntypedBracket, + runAnnotation, getUntypedSpliceBody, + + runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, + tcTopSpliceExpr, lookupThName_maybe, + defaultRunMeta, runMeta', runRemoteModFinalizers, + finishTH, runTopSplice + ) where + +import GHC.Prelude + +import GHC.Driver.Errors +import GHC.Driver.Plugins +import GHC.Driver.Main +import GHC.Driver.DynFlags +import GHC.Driver.Env +import GHC.Driver.Hooks +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Finder + +import GHC.Hs + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin +import GHC.Tc.Types.LclEnv +import GHC.Tc.Types.Evidence +import GHC.Tc.Zonk.Type +import GHC.Tc.Zonk.TcType +import GHC.Tc.Solver +import GHC.Tc.Utils.TcMType +import GHC.Tc.Gen.HsType +import GHC.Tc.Instance.Family +import GHC.Tc.Utils.Instantiate + +import GHC.Core.Multiplicity +import GHC.Core.Coercion( etaExpandCoAxBranch ) +import GHC.Core.Type as Type +import GHC.Core.TyCo.Rep as TyCoRep +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv as InstEnv + +import GHC.Builtin.Names.TH +import GHC.Builtin.Names +import GHC.Builtin.Types + +import GHC.ThToHs +import GHC.HsToCore.Docs +import GHC.HsToCore.Expr +import GHC.HsToCore.Monad +import GHC.IfaceToCore +import GHC.Iface.Load + +import GHCi.Message +import GHCi.RemoteTypes +import GHC.Runtime.Interpreter + +import GHC.Rename.Splice( traceSplice, SpliceInfo(..) ) +import GHC.Rename.Expr +import GHC.Rename.Env +import GHC.Rename.Fixity ( lookupFixityRn_help ) +import GHC.Rename.HsType + +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.PatSyn +import GHC.Core.ConLike +import GHC.Core.DataCon as DataCon + +import GHC.Types.SrcLoc +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence as OccName +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Unique +import GHC.Types.Var.Set +import GHC.Types.Meta +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Types.Error +import GHC.Types.Fixity as Hs +import GHC.Types.Annotations +import GHC.Types.Name +import GHC.Types.Unique.Map +import GHC.Serialized + +import GHC.Unit.Finder +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Iface.Syntax + +import GHC.Utils.Misc +import GHC.Utils.Panic as Panic +import GHC.Utils.Lexeme +import GHC.Utils.Outputable +import GHC.Utils.Logger +import GHC.Utils.Exception (throwIO, ErrorCall(..)) + +import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) ) + +import GHC.Data.FastString +import GHC.Data.Maybe( MaybeErr(..) ) +import GHC.Data.EnumSet (EnumSet) +import qualified GHC.Data.EnumSet as EnumSet +import qualified GHC.LanguageExtensions as LangExt + +-- THSyntax gives access to internal functions and data types +import qualified GHC.Boot.TH.Syntax as TH +import qualified GHC.Boot.TH.Ppr as TH + +#if defined(HAVE_INTERNAL_INTERPRETER) +import Unsafe.Coerce ( unsafeCoerce ) +#if !MIN_VERSION_base(4,22,0) +import GHC.Desugar ( AnnotationWrapper(..) ) +#else +import GHC.Internal.Desugar ( AnnotationWrapper(..) ) +#endif +import Control.DeepSeq +#endif + +import Control.Monad +import Data.Binary +import Data.Binary.Get +import Data.Maybe +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Dynamic ( fromDynamic, toDyn ) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) +import Data.Data (Data) +import Data.Proxy ( Proxy (..) ) +import Data.IORef +import GHC.Parser.HaddockLex (lexHsDoc) +import GHC.Parser (parseIdentifier) +import GHC.Rename.Doc (rnHsDoc) + + + +{- +Note [Template Haskell state diagram] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here are the ThLevels, their corresponding level numbers +(the result of (thLevelIndex s)), and their state transitions. +The top level of the program is stage Comp: + + Start here + | + V + ----------- $ ------------ $ ----------------- + | Comp | ---------> | Splice | -----> | Splice Splice | + | 0 | | -1 | <---- | -2 | + ----------- ------------ [||] ----------------- + ^ | ^ | + $ | | [||] $ | | [||] + | v | v + -------------- ---------------- + | Brack Comp | | Brack Splice | + | 1 | | 0 | + -------------- ---------------- + +* Normal top-level declarations start in state Comp + (which has level 0). + Annotations start in state Splice, since they are + treated very like a splice (only without a '$') + +* Code compiled in state Splice (and only such code) + will be *run at compile time*, with the result replacing + the splice + +* The original paper did not allow a splice within a + splice, but there is no reason not to. This is the + $ transition in the top right. + +Note [Template Haskell levels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* The level checks are implemented for terms in `checkThLocalName` + +* Imported things are level 0 + +* Top-level things are level 0 + +* In GHCi, variables bound by a previous command are treated + as imported, because we have bytecode for them. + +* Variables are bound at the "current level" + +* The current level starts off at 0 + +* The level is decremented by splicing $(..) + incremented by brackets [| |] + incremented by name-quoting 'f + +* When a variable is used, checkThLocalName compares + bind: binding level, and + use: current level at usage site + + Generally + bind > use Always error (bound later than used) + [| \x -> $(f x) |] + + bind = use Always OK (bound same stage as used) + [| \x -> $(f [| x |]) |] + + bind < use Inside brackets, it depends on what cross stage + persistence rules are used. + + For (bind < use) inside brackets, there are three cases: + - Imported things (if ImplicitStagePersistence is enabled) OK f = [| map |] + - Top-level things (if ImplicitStagePersistence is enabled) OK g = [| f |] + - Non-top-level Only if there is a liftable instance + h = \(x:Int) -> [| x |] + + If ExplicitLevelImports is used, then imports can bring identifiers into scope + at non-zero levels. + + To track top-level-ness we use the ThBindEnv in TcLclEnv + + For example: + f = ... + g1 = $(map ...) is OK + g2 = $(f ...) is not OK; because we haven't compiled f yet + + +Note [How top-level splices are handled] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Top-level splices (those not inside a [| .. |] quotation bracket) are handled +very straightforwardly: + + 1. tcTopSpliceExpr: typecheck the body e of the splice $(e) + + 2. runMetaT: desugar, compile, run it, and convert result back to + GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName, + HsExpr RdrName etc) + + 3. treat the result as if that's what you saw in the first place + e.g for HsType, rename and kind-check + for HsExpr, rename and type-check + + (The last step is different for decls, because they can *only* be + top-level: we return the result of step 2.) + +Note [Warnings for TH splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only produce warnings for TH splices when the user requests so +(-fenable-th-splice-warnings). There are multiple reasons: + + * It's not clear that the user that compiles a splice is the author of the code + that produces the warning. Think of the situation where they just splice in + code from a third-party library that produces incomplete pattern matches. + In this scenario, the user isn't even able to fix that warning. + * Gathering information for producing the warnings (pattern-match check + warnings in particular) is costly. There's no point in doing so if the user + is not interested in those warnings. + +That's why we store Origin flags in the Haskell AST. The functions from ThToHs +take such a flag and depending on whether TH splice warnings were enabled or +not, we pass FromSource (if the user requests warnings) or Generated +(otherwise). This is implemented in getThSpliceOrigin. + +For correct pattern-match warnings it's crucial that we annotate the Origin +consistently (#17270). In the future we could offer the Origin as part of the +TH AST. That would enable us to give quotes from the current module get +FromSource origin, and/or third library authors to tag certain parts of +generated code as FromSource to enable warnings. +That effort is tracked in #14838. + +Note [The life cycle of a TH quotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When desugaring a bracket (aka quotation), we want to produce Core +code that, when run, will produce the TH syntax tree for the quotation. +To that end, we want to desugar /renamed/ but not /typechecked/ code; +the latter is cluttered with the typechecker's elaboration that should +not appear in the TH syntax tree. So in (HsExpr GhcTc) tree, we must +have a (HsExpr GhcRn) for the quotation itself. + +As such, when typechecking both typed and untyped brackets, +we keep a /renamed/ bracket in the extension field. + +The HsBracketTc, the GhcTc ext field for both typed and untyped +brackets, contains: + - The renamed quote :: HsQuote GhcRn -- for the desugarer + - [PendingTcSplice] + - The type of the quote + - Maybe QuoteWrapper + +Note that HsBracketTc stores the untyped (HsQuote GhcRn) for both typed and +untyped brackets. They are treated uniformly by the desugarer, and we can +easily construct untyped brackets from typed ones (with ExpBr). + +See Note [Desugaring of brackets]. + +------------ +Typed quotes +------------ +Here is the life cycle of a /typed/ quote [|| e ||], whose datacon is + HsTypedBracket (XTypedBracket p) (LHsExpr p) + + In pass p (XTypedBracket p) (LHsExpr p) + ------------------------------------------- + GhcPs Annotations only LHsExpr GhcPs + GhcRn Annotations only LHsExpr GhcRn + GhcTc HsBracketTc LHsExpr GhcTc: unused! + +Note that in the GhcTc tree, the second field (HsExpr GhcTc) +is entirely unused; the desugarer uses the (HsExpr GhcRn) from the +first field. + +-------------- +Untyped quotes +-------------- +Here is the life cycle of an /untyped/ quote, whose datacon is + HsUntypedBracket (XUntypedBracket p) (HsQuote p) + +Here HsQuote is a sum-type of expressions [| e |], patterns [| p |], +types [| t |] etc. + + In pass p (XUntypedBracket p) (HsQuote p) + ------------------------------------------------------- + GhcPs Annotations only HsQuote GhcPs + GhcRn Annotations, [PendingRnSplice] HsQuote GhcRn + GhcTc HsBracketTc HsQuote GhcTc: unused! + +The difficulty is: the typechecker does not typecheck the body of an +untyped quote, so how do we make a (HsQuote GhcTc) to put in the +second field? + +Answer: we use the extension constructor of HsQuote, namely XQuote, +and make all the other constructors into DataConCantHappen. That is, +the only non-bottom value of type (HsQuote GhcTc) is (XQuote noExtField). +Hence the instances + + type instance XExpBr GhcTc = DataConCantHappen + ...etc... + +See the related Note [How brackets and nested splices are handled] + +Note [Typechecking Overloaded Quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The main function for typechecking untyped quotations is `tcUntypedBracket`. + +Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`. +Note carefully that this is overloaded: its type is not `Q Exp` for some fixed Q. + +When we typecheck it we therefore create a template of a metavariable +`m` applied to `Exp` and emit a constraint `Quote m`. All this is done +in the `brackTy` function. `brackTy` also selects the correct +contents type for the quotation (Exp, Type, Decs etc). + +The meta variable and the constraint evidence variable are +returned together in a `QuoteWrapper` and then passed along to two further places +during compilation: + +1. Typechecking nested splices (immediately in tcUntypedSplice) +2. Desugaring quotations (see GHC.HsToCore.Quote) + +`tcPendingSplice` takes the `m` type variable as an argument and +checks each nested splice against this variable `m`. During this +process the variable `m` can either be fixed to a specific value or +further constrained by the nested splices. + +Once we have checked all the nested splices, the quote type is checked against +the expected return type. + +The process is very simple and like typechecking a list where the quotation is +like the container and the splices are the elements of the list which must have +a specific type. + +After the typechecking process is completed, the evidence variable for `Quote m` +and the type `m` is stored in a `QuoteWrapper` which is passed through the pipeline +and used when desugaring quotations. + +Typechecking typed quotations is a similar idea but the `QuoteWrapper` is stored +in the `PendingStuff` as the nested splices are gathered up in a different way +to untyped splices. Untyped splices are found in the renamer but typed splices are +not typechecked and extracted until during typechecking. + +Note [Lifecycle of an untyped splice, and PendingRnSplice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Untyped splices $(f x) and quasiquotes [p| stuff |] have the following +life cycle. Quasi-quotes are very like splices; see Note [Quasi-quote overview]). + +The type structure is + + data HsExpr p = ... + | HsUntypedSplice (XUntypedSplice p) (HsUntypedSplice p) + + data HsUntypedSplice p + = HsUntypedSpliceExpr (XUntypedSpliceExpr p) (LHsExpr p) + | HsQuasiQuote (XQuasiQuote p) (IdP id) (XRec p FastString) + | XXUntypedSplice (XUntypedSplice p) + +Untyped splices can occur in expressions, patterns, +types, and declarations. So we have a HsUntypedSplice data +constructor in all four of these types. + +Untyped splices never occur in (HsExpr GhcTc), and similarly +patterns etc, because the body of a untyped quotation is not typechecked. So we have + + type instance XUntypedSplice GhcTc = DataConCantHappen + +Top-level and nested splices are handled differently. + +------------------------------------- +Nested untyped splices/quasiquotes +---------------------------------- +When we rename an /untyped/ bracket, such as + [| f $(g x) |] +we name and lift out all the nested splices, so that when the +typechecker hits the bracket, it can typecheck those nested splices +without having to walk over the untyped bracket code. Our example +[| f $(g x) |] parses as + + HsUntypedBracket _ + (HsApp (HsVar "f") + (HsUntypedSplice _ (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcPs))) + +RENAMER (rnUntypedBracket): + +* Set the ThLevel to (Brack s (RnPendingUntyped ps_var)) + +* Rename the body + +* Nested splices (which must be untyped) are renamed (rnUntypedSplice), + and the results accumulated in ps_var. Each gets a fresh + SplicePointName, 'spn' + +* The SplicePointName connects the `PendingRnSplice` with the particular point + in the syntax tree where that expression should be spliced in. That point + in the tree is identified by `(HsUntypedSpliceNested spn)`. It is used by + the desugarer, so that we ultimately generate something like + let spn = g x + in App (Var "f") spn + +The result is + HsUntypedBracket + [PendingRnSplice spn (HsUntypedSpliceExpr UntypedExpSplice (g x :: LHsExpr GHcRn))] + (HsApp (HsVar f) (HsUntypedSplice (HsUntypedSpliceNested spn) + (HsUntypedSpliceExpr UntypedExpSplice (g x :: LHsExpr GhcRn)))) + +Note that a nested splice, such as the `$(g x)` now appears twice: + - In the PendingRnSplice: this is the version that will later be typechecked + - In the HsUntypedSpliceExpr in the body of the bracket. This copy is used + only for pretty printing. + +NB: a single untyped bracket can contain many splices, each of a different +`UntypedSpliceFlavour`. For example + + [| let $e0 in (f :: $e1) $e2 (\ $e -> body ) |] + 1 + +Here $e0 is a declaration splice, $e1 is a type splice, $e2 is an +expression splice, and $e3 is a pattern splice. The `SpliceFlavour` is stored +in the extension field of HsUntypedSpliceExpr. + +TYPECHECKER (tcUntypedBracket): see also Note [Typechecking Overloaded Quotes] + +* Typecheck the [PendingRnSplice] individually, to give [PendingTcSplice]. + PendingTcSplice is used for both typed and untyped splices. + +* Ignore the body of the bracket; just check that the context + expects a bracket of that type (e.g. a [p| pat |] bracket should + be in a context needing a (m Pat) + +* Stash the whole lot inside a HsBracketTc + +Result is: + HsUntypedBracket + (HsBracketTc { hsb_splices = [PendingTcSplice spn (g x :: LHsExpr GHcTc)] + , hsb_quote = HsApp (HsVar f) + (HsUntypedSplice (HsUntypedSpliceNested spn) + (HsUntypedSpliceExpr UntypedExpSplice (g x :: LHsExpr GhcRn))) + }) + (XQuote noExtField) + +NB in the typechecker output, the original payload (which would now +have type (HsQuote GhcTc) is stubbed off with (XQuote noExtField). The payload +is now in the hsb_quote field of the HsBracketTc. + +------------------------------------- +Implicit lifting +------------------------------------- + +When a variable is bound at level n and used at level n+1, the renamer will decide, +in `checkThLocalNameWithLift`, to implicitly lift this variable to level n+1. +This is done by replacing the occurrence of `x` with `$(lift x)`. +This decision is then stored in the extension points 'XXUntypedSplice'/'XXTypedSplice'. +When we come to typechecking these splices, the typechecker will emit the appropriate +'Lift' constraint, with a `ImplicitLiftOrigin` `CtOrigin`. If we fail to solve this constraint, +a level error is reported to the user. + + + +------------------------------------- +Top-level untyped splices/quasiquotes +------------------------------------- +A top-level splice (not inside a bracket) does not need a SpliceName, +nor does a top-level splice ever end up inside a PendingRnSplice; +hence HsUntypedSpliceTop does not have a SplicePointName field. + +Example $(g x). This is parsed as + + HsUntypedSplice _ (HsUntypedSpliceExpr _ ((g x) :: LHsExpr GhcPs)) + +Renamer: the renamer runs the splice, so the output of the renamer looks like + + HsUntypedSplice (HsUntypedSpliceTop fins (e2 :: LHsExpr GhcRn)) + (HsUntypedSpliceExpr ((g x) :: LHsExpr GhcRn)) + +where 'e2' is the result of running (g x) to + produce the syntax tree for 'e2' + 'fins' is a bunch of TH finalisers, to be run later. + +Typechecker: the typechecker simply adds the finalisers, and +typechecks e2, discarding the HsUntypedSplice altogether. + + +Note [Lifecycle of an typed splice, and PendingTcSplice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +---------------------- +Nested, typed splices +---------------------- +When we typecheck a /typed/ bracket, we lift nested splices out as +`PendingTcSplice`, very similar to Note [Pending Splices]. Again, the +splice needs a SplicePointName, for the desugarer to use to connect +the splice expression with the point in the syntax tree where it is +used. Example: + [|| f $$(g 2)||] + +Parser: this is parsed as + + HsTypedBracket _ (HsApp (HsVar "f") + (HsTypedSplice _ (HsTypedSpliceExpr _ (g 2 :: LHsExpr GhcPs)))) + +RENAMER (rnTypedSplice): the renamer adds a SplicePointName, spn: + + HsTypedBracket _ (HsApp (HsVar "f") + (HsTypedSplice (HsTypedSpliceNested spn) (HsTypedSpliceExpr _ (g x :: LHsExpr GhcRn)))) + +TYPECHECKER (tcTypedBracket): + +* Set the ThLevel to (Brack s (TcPending ps_var lie_var quote_wrapper)) + +* Typecheck the body, and keep the elaborated result (despite never using it!, todo: it should be stored in the AST) + +* Nested splices (which must be typed) are typechecked by tcTypedSplice, and + the results accumulated in ps_var; their constraints accumulate in lie_var + +* Result is a HsTypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) tc_brack + where rn_brack is the untyped renamed exp quote constructed from the typed renamed expression :: HsQuote GhcRn + +Just like untyped brackets, dump the output into a HsBracketTc. + + HsTypedBracket + (HsBracketTc { hsb_splices = [PendingTcSplice spn (g x :: LHsExpr GHcTc)] + , hsb_quote = HsApp (HsVar f) + (HsUntypedSplice (HsUntypedSpliceNested spn) + (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn))) + }) + (panic "should never be looked at") + +NB: we never need to represent typed /nested/ splices in phase GhcTc. + +There are only typed expression splices so `PendingTcSplice` doesn't have a +flavour field. + + +-------------------------------- +Top-level, typed splices $$(f x) +-------------------------------- +Typed splices are renamed and typechecked, but only actually run in +the zonker, after typechecking. See Note [Running typed splices in the zonker] + +* Output of parser: + HsTypedSplice _ (e :: HsExpr GhcPs) + +* Output of renamer: + HsTypedSplice (n :: SplicePointName) (e :: HsExpr GhcRn) + +* Output of typechecker: (top-level splices only) + HsTypedSplice (del_splice :: DelayedSplice) (e :: HsExpr GhcTc) + where 'del_splice' is something the zonker can run to produce + the syntax tree to splice in. + See Note [Running typed splices in the zonker] + +Note [Desugaring of brackets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In both cases, desugaring happens like this: + * Hs*Bracket is desugared by GHC.HsToCore.Quote.dsBracket using the renamed + expression held in `HsBracketTc` (`type instance X*Bracket GhcTc = HsBracketTc`). It + + a) Extends the ds_meta environment with the PendingSplices + attached to the bracket + + b) Converts the quoted (HsExpr Name) to a CoreExpr that, when + run, will produce a suitable TH expression/type/decl. This + is why we leave the *renamed* expression attached to the bracket: + the quoted expression should not be decorated with all the goop + added by the type checker + + * Each splice carries a unique Name, called a "splice point", thus + ${n}(e). The name is initialised to an (Unqual "splice") when the + splice is created; the renamer gives it a unique. + + * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across + a splice, it looks up the splice's Name, n, in the ds_meta envt, + to find an (HsExpr Id) that should be substituted for the splice; + it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice). + +Example: + Source: f = [| Just $(g 3) |] + The [| |] part is a HsUntypedBracket GhcPs + + Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} + The [| |] part is a HsUntypedBracket GhcTc, containing *renamed* + (not typechecked) expression (see Note [The life cycle of a TH quotation]) + The "s7" is the "splice point"; the (g Int 3) part + is a typechecked expression + + Desugared: f = do { s7 <- g Int 3 + ; return (ConE "Data.Maybe.Just" s7) } + +-} + +{- +************************************************************************ +* * +\subsection{Main interface + stubs for the non-GHCI case +* * +************************************************************************ +-} + +-- None of these functions add constraints to the LIE + +tcTypedBracket :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcUntypedBracket :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcTypedSplice :: HsTypedSpliceResult -> HsTypedSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) + +getUntypedSpliceBody :: HsUntypedSpliceResult (HsExpr GhcRn) -> TcM (HsExpr GhcRn) +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation + +{- +************************************************************************ +* * +\subsection{Quoting an expression} +* * +************************************************************************ +-} + +-- See Note [How brackets and nested splices are handled] +tcTypedBracket rn_expr expr res_ty + = addErrCtxt (TypedTHBracketCtxt expr) $ + do { cur_lvl <- getThLevel + ; ps_var <- newMutVar [] + ; lie_var <- getConstraintVar -- Any constraints arising from nested splices + -- should get thrown into the constraint set + -- from outside the bracket + + -- Make a new type variable for the type of the overall quote + ; m_var <- mkTyVarTy <$> mkMetaTyVar + -- Make sure the type variable satisfies Quote + ; ev_var <- emitQuoteWanted m_var + -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring + -- brackets. + ; let wrapper = QuoteWrapper ev_var m_var + + -- Typecheck expr to make sure it is valid. + -- The typechecked expression won't be used, so we just discard it + -- (See Note [The life cycle of a TH quotation] in GHC.Hs.Expr) + -- We'll typecheck it again when we splice it in somewhere + ; (tc_expr, expr_ty) <- setThLevel (Brack cur_lvl (TcPending ps_var lie_var wrapper)) $ + tcScalingUsage ManyTy $ + -- Scale by Many, TH lifting is currently nonlinear (#18465) + tcInferRhoNC expr + -- NC for no context; tcBracket does that + ; let rep = getRuntimeRep expr_ty + ; meta_ty <- tcCodeTy m_var expr_ty + ; ps' <- readMutVar ps_var + ; codeco <- tcLookupId unsafeCodeCoerceName + ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName + ; let brack_tc = HsBracketTc { hsb_quote = ExpBr noExtField expr, hsb_ty = bracket_ty + , hsb_wrap = Just wrapper, hsb_splices = ps' } + -- The tc_expr is stored here so that the expression can be used in HIE files. + brack_expr = HsTypedBracket brack_tc tc_expr + ; tcWrapResultO (Shouldn'tHappenOrigin "TH typed bracket expression") + rn_expr + (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper) + (nlHsTyApp codeco [rep, expr_ty])) + (noLocA brack_expr))) + meta_ty res_ty } + +-- See Note [Typechecking Overloaded Quotes] +tcUntypedBracket rn_expr brack ps res_ty + = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) + + -- Create the type m Exp for expression bracket, m Type for a type + -- bracket and so on. The brack_info is a Maybe because the + -- VarBracket ('a) isn't overloaded, but also shouldn't contain any + -- splices. + ; (brack_info, expected_type) <- brackTy brack + + -- Match the expected type with the type of all the internal + -- splices. They might have further constrained types and if they do + -- we want to reflect that in the overall type of the bracket. + ; ps' <- case brack_info of + Just q -> mapM (tc_nested_splice q) ps + Nothing -> assert (null ps) $ return [] + + -- Notice that we don't attempt to typecheck the body + -- of the bracket, which is in brack. + ; traceTc "tc_bracket done untyped" (ppr expected_type) + + -- Unify the overall type of the bracket with the expected result type + ; tcWrapResultO BracketOrigin rn_expr + (HsUntypedBracket (HsBracketTc { hsb_quote = brack, hsb_ty = expected_type + , hsb_wrap = brack_info, hsb_splices = ps' }) + (XQuote noExtField)) + -- (XQuote noExtField): see Note [The life cycle of a TH quotation] in GHC.Hs.Expr + expected_type res_ty + + } + where + tc_nested_splice :: QuoteWrapper -> PendingRnSplice -> TcM PendingTcSplice + tc_nested_splice q (PendingRnSplice splice_name expr) = tcUntypedSplice q splice_name expr + +-- | A type variable with kind * -> * named "m" +mkMetaTyVar :: TcM TyVar +mkMetaTyVar = + newNamedFlexiTyVar (fsLit "m") (mkVisFunTyMany liftedTypeKind liftedTypeKind) + + +-- | For a type 'm', emit the constraint 'Quote m'. +emitQuoteWanted :: Type -> TcM EvVar +emitQuoteWanted m_var = do + quote_con <- tcLookupTyCon quoteClassName + emitWantedEvVar BracketOrigin $ + mkTyConApp quote_con [m_var] + +--------------- +-- | Compute the expected type of a quotation, and also the QuoteWrapper in +-- the case where it is an overloaded quotation. All quotation forms are +-- overloaded aprt from Variable quotations ('foo) +brackTy :: HsQuote GhcRn -> TcM (Maybe QuoteWrapper, Type) +brackTy b = + let mkTy n = do + -- New polymorphic type variable for the bracket + m_var <- mkTyVarTy <$> mkMetaTyVar + -- Emit a Quote constraint for the bracket + ev_var <- emitQuoteWanted m_var + -- Construct the final expected type of the quote, for example + -- m Exp or m Type + final_ty <- mkAppTy m_var <$> tcMetaTy n + -- Return the evidence variable and metavariable to be used during + -- desugaring. + let wrapper = QuoteWrapper ev_var m_var + return (Just wrapper, final_ty) + in + case b of + (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName + -- Result type is Var (not Quote-monadic) + (ExpBr {}) -> mkTy expTyConName -- Result type is m Exp + (TypBr {}) -> mkTy typeTyConName -- Result type is m Type + (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec] + (PatBr {}) -> mkTy patTyConName -- Result type is m Pat + (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL" + + +untypedSpliceResultType :: UntypedSpliceFlavour -> TcType -> TcM TcType +untypedSpliceResultType flavour meta_ty = do + sp_ty <- tcMetaTy sp_ty_name + return $ mkAppTy meta_ty sp_ty + where + sp_ty_name = case flavour of + UntypedExpSplice -> expTyConName + UntypedPatSplice -> patTyConName + UntypedTypeSplice -> typeTyConName + UntypedDeclSplice -> decsTyConName + +--------------- +-- | Typechecking a pending splice from a untyped bracket +-- TODO: Should return HsUntypedSplice GhcTc, and the desugarer should +-- construct the relevant CoreExpr rather than performing desugaring here. +tcUntypedSplice :: QuoteWrapper -- Metavariable for the expected overall type of the + -- quotation. + -> SplicePointName + -> HsUntypedSplice GhcRn + -> TcM PendingTcSplice +tcUntypedSplice (QuoteWrapper _ m_var) splice_name (HsUntypedSpliceExpr (HsUserSpliceExt flavour) expr) + -- See Note [Typechecking Overloaded Quotes] + = do { expected_type <- untypedSpliceResultType flavour m_var + ; expr' <- tcScalingUsage ManyTy $ tcCheckPolyExpr expr expected_type + -- Scale by Many, TH lifting is currently nonlinear (#18465) + ; return (PendingTcSplice splice_name expr') } +tcUntypedSplice (QuoteWrapper _ m_var) splice_name (HsQuasiQuote (HsQuasiQuoteExt flavour) quoter s) = do + -- 1. Check that the quoter is of type 'QuasiQuoter' + qq_type <- mkTyConTy <$> tcLookupTyCon quasiQuoterTyConName + quoter' <- setSrcSpan (getLocA quoter) $ tcCheckId (unLoc quoter) (Check qq_type) + + -- 2. Check that the quasi-quote has type Q Exp/Q Pat/Q Dec/Q Decs (as appropriate) + qTy <- mkTyConTy <$> tcLookupTyCon qTyConName + quote_ty <- untypedSpliceResultType flavour m_var + splice_ty <- untypedSpliceResultType flavour qTy + res_co <- unifyInvisibleType splice_ty quote_ty + + -- 3. Lookup the relevant field selector from QuasiQuoter + sel <- tcLookupId qq_sel_name + + -- 4. Apply the selector to the quasi-quoter + let expr' = mkLHsWrapCo res_co $ + nlHsApp (nlHsApp (nlHsVar sel) (noLocA quoter')) (nlHsLit (mkHsStringFS (unLoc s))) + + return (PendingTcSplice splice_name expr') + where + qq_sel_name = case flavour of + UntypedExpSplice -> quoteExpName + UntypedPatSplice -> quotePatName + UntypedTypeSplice -> quoteTypeName + UntypedDeclSplice -> quoteDecName + + -- Identifiers that are lifted implicitly, such as 'x' in + -- E.g. \x -> [| h x |] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the SplicePointName, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same SplicePointName, but that doesn't + -- matter, although it's a mite untidy. +tcUntypedSplice q splice_name (XUntypedSplice ils) + = do { let id_name = implicit_lift_lid ils + ; id_ty <- newOpenFlexiTyVarTy + ; let v_expr = noLocA (HsVar noExtField id_name) + ; v_expr' <- tcCheckMonoExpr v_expr id_ty + -- lift :: Quote m' => a -> m' Exp + ; lift <- setSrcSpan (getLocA id_name) $ + newMethodFromName (ImplicitLiftOrigin ils) + GHC.Builtin.Names.TH.liftName + [getRuntimeRep id_ty, id_ty] + ; let res = nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) v_expr' + + ; return (PendingTcSplice splice_name res) } + +tcPendingSpliceTyped :: QuoteWrapper -> SplicePointName -> HsTypedSplice GhcRn -> ExpRhoType -> TcM PendingTcSplice +tcPendingSpliceTyped q@(QuoteWrapper _ m_var) splice_name (HsTypedSpliceExpr _ expr) res_ty + = do { res_ty <- expTypeToType res_ty + ; let rep = getRuntimeRep res_ty + ; meta_exp_ty <- tcCodeTy m_var res_ty + ; expr' <- tcCheckMonoExpr expr meta_exp_ty + ; untype_code <- tcLookupId unTypeCodeName + ; let expr'' = mkHsApp + (mkLHsWrap (applyQuoteWrapper q) + (nlHsTyApp untype_code [rep, res_ty])) expr' + ; return (PendingTcSplice splice_name expr'') } +tcPendingSpliceTyped q splice_name (XTypedSplice ils) res_ty + = do { let id_name = implicit_lift_lid ils + ; res_ty <- expTypeToType res_ty + ; let rep = getRuntimeRep res_ty + ; let v_expr = noLocA (HsVar noExtField id_name) + ; v_expr' <- tcCheckMonoExpr v_expr res_ty + -- lift :: Quote m' => a -> m' Exp + ; lift <- setSrcSpan (getLocA id_name) $ + newMethodFromName (ImplicitLiftOrigin ils) + GHC.Builtin.Names.TH.liftName + [rep, res_ty] + ; let res = nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) v_expr' + ; return (PendingTcSplice splice_name res) } + + +--------------- +-- Takes a m and tau and returns the type m (TExp tau) +tcCodeTy :: TcType -> TcType -> TcM TcType +tcCodeTy m_ty exp_ty + = do { unless (isTauTy exp_ty) $ addErr $ + TcRnTHError $ TypedTHError $ TypedTHWithPolyType exp_ty + ; codeCon <- tcLookupTyCon codeTyConName + ; let rep = getRuntimeRep exp_ty + ; return (mkTyConApp codeCon [m_ty, rep, exp_ty]) } + + + -- The whole of the rest of the file is the else-branch (ie stage2 only) + + +{- +************************************************************************ +* * +\subsection{Splicing an expression} +* * +************************************************************************ +-} + +-- getUntypedSpliceBody: the renamer has expanded the splice. +-- Just run the finalizers that it produced, and return +-- the renamed expression +getUntypedSpliceBody (HsUntypedSpliceTop { utsplice_result_finalizers = mod_finalizers + , utsplice_result = rn_expr }) + = do { addModFinalizersWithLclEnv mod_finalizers + ; return rn_expr } +getUntypedSpliceBody (HsUntypedSpliceNested {}) + = panic "tcTopUntypedSplice: invalid nested splice" + +tcTypedSplice HsTypedSpliceTop ctxt@(HsTypedSpliceExpr _ expr) res_ty + = addErrCtxt (TypedSpliceCtxt Nothing ctxt) $ + setSrcSpan (getLocA expr) $ + tcTopSplice expr res_ty +tcTypedSplice (HsTypedSpliceNested sp) expr res_ty + -- The expr is checked in tcPendingSpliceTyped + = addErrCtxt (TypedSpliceCtxt (Just sp) expr) $ + setSrcSpan loc $ do + lvl <- getThLevel + case lvl of + Brack _ (TcPending ps_var lie_var q) -> do + tc_splice <- setConstraintVar lie_var $ tcPendingSpliceTyped q sp expr res_ty + updTcRef ps_var (tc_splice : ) + -- stubNestedSplice: the returned expression is ignored; it's in the pending splices. + -- + -- Unfortunately, this means that tooling that works with typechecked + -- expressions will not be able to identify where the nested splices are. + -- Instead, we should modify the extension point of HsTypedSplice, in + -- order to propagate the result of typechecking. + + return stubNestedSplice + _ -> panic "tcTypedSplice: invalid level" + where + loc = case expr of + HsTypedSpliceExpr _ expr -> getLocA expr + XTypedSplice (HsImplicitLiftSplice _ _ _ expr) -> getLocA expr +tcTypedSplice _ _ _ = panic "tcTypedSplice: invalid splice" + + +{- Note [Collecting modFinalizers in typed splices] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local +environment (see Note [Delaying modFinalizers in untyped splices] in +GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the +finalizer list in the global environment and set them to use the current local +environment (with 'addModFinalizersWithLclEnv'). + +-} + +------------------ +tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcTopSplice expr res_ty + = do { -- Typecheck the expression, + -- making sure it has type Q (T res_ty) + res_ty <- expTypeToType res_ty + ; q_type <- tcMetaTy qTyConName + -- Top level splices must still be of type Q (TExp a) + ; meta_exp_ty <- tcCodeTy q_type res_ty + ; q_expr <- tcTopSpliceExpr Typed $ + tcCheckMonoExpr expr meta_exp_ty + ; lcl_env <- getLclEnv + ; let delayed_splice + = DelayedSplice lcl_env expr res_ty q_expr + ; return (HsTypedSplice delayed_splice (HsTypedSpliceExpr noExtField q_expr)) + + } + +------------------- +tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) +-- Note [How top-level splices are handled] +-- Type check an expression that is the body of a top-level splice +-- (the caller will compile and run it) +-- Note that set the level to Splice, regardless of the original level, +-- before typechecking the expression. For example: +-- f x = $( ...$(g 3) ... ) +-- The recursive call to tcCheckPolyExpr will simply expand the +-- inner escape before dealing with the outer one + +tcTopSpliceExpr isTypedSplice tc_action + = checkNoErrs $ -- checkNoErrs: must not try to run the thing + -- if the type checker fails! + + setThLevel (Splice isTypedSplice Comp) $ + do { -- Typecheck the expression + (mb_expr', wanted) <- tryCaptureConstraints tc_action + -- If tc_action fails (perhaps because of insoluble constraints) + -- we want to capture and report those constraints, else we may + -- just get a silent failure (#20179). Hence the 'try' part. + + ; const_binds <- simplifyTop wanted + + ; case mb_expr' of + Nothing -> failM -- In this case simplifyTop should have + -- reported some errors + Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' } + +------------------ +-- This is called in the zonker +-- See Note [Running typed splices in the zonker] +runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) +runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr) + = restoreLclEnv lcl_env $ + do { zonked_ty <- liftZonkM $ zonkTcType res_ty + ; zonked_q_expr <- zonkTopLExpr q_expr + -- See Note [Collecting modFinalizers in typed splices]. + ; modfinalizers_ref <- newTcRef [] + -- Run the expression + ; expr2 <- setThLevel (RunSplice modfinalizers_ref) $ + runMetaE zonked_q_expr + ; mod_finalizers <- readTcRef modfinalizers_ref + ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers + -- We use orig_expr here and not q_expr when tracing as a call to + -- unsafeCodeCoerce is added to the original expression by the + -- typechecker when typed quotes are type checked. + ; traceSplice (SpliceInfo { spliceDescription = "expression" + , spliceIsDecl = False + , spliceSource = Just orig_expr + , spliceGenerated = ppr expr2 }) + -- Rename and typecheck the spliced-in expression, + -- making sure it has type res_ty + -- These steps should never fail; this is a *typed* splice + ; (res, wcs) <- + captureConstraints $ + addErrCtxt (TypedSpliceResultCtxt zonked_q_expr) $ do + { (exp3, _fvs) <- rnLExpr expr2 + ; tcCheckMonoExpr exp3 zonked_ty } + ; ev <- simplifyTop wcs + ; return $ unLoc (mkHsDictLet (EvBinds ev) res) + } + + +{- +************************************************************************ +* * + +* * +************************************************************************ +-} + +stubNestedSplice :: HsExpr GhcTc +-- Used when we need a (LHsExpr GhcTc) that we are never going +-- to look at. We could use "panic" but that's confusing if we ever +-- do a debug-print. The warning is because this should never happen +-- /except/ when doing debug prints. +stubNestedSplice = warnPprTrace True "stubNestedSplice" empty $ + HsLit noExtField (mkHsString "stubNestedSplice") + + +{- +************************************************************************ +* * + Annotations +* * +************************************************************************ +-} + +runAnnotation target expr = do + -- Find the classes we want instances for in order to call toAnnotationWrapper + loc <- getSrcSpanM + data_class <- tcLookupClass dataClassName + to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName + + -- Check the instances we require live in another module (we want to execute it..) + -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr + -- also resolves the LIE constraints to detect e.g. instance ambiguity + zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped ( + do { (expr', expr_ty) <- tcInferRhoNC expr + -- We manually wrap the typechecked expression in a call to toAnnotationWrapper + -- By instantiating the call >here< it gets registered in the + -- LIE consulted by tcTopSpliceExpr + -- and hence ensures the appropriate dictionary is bound by const_binds + ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] + ; let loc' = noAnnSrcSpan loc + ; let specialised_to_annotation_wrapper_expr + = L loc' (mkHsWrap wrapper + (mkHsVar (L (noAnnSrcSpan loc) to_annotation_wrapper_id))) + ; return (L loc' (HsApp noExtField + specialised_to_annotation_wrapper_expr expr')) + }) + + -- Run the appropriately wrapped expression to get the value of + -- the annotation and its dictionaries. The return value is of + -- type AnnotationWrapper by construction, so this conversion is + -- safe + serialized <- runMetaAW zonked_wrapped_expr' + return Annotation { + ann_target = target, + ann_value = serialized + } + +convertAnnotationWrapper :: ForeignHValue -> TcM Serialized +convertAnnotationWrapper fhv = do + interp <- tcGetInterp + case interpInstance interp of + ExternalInterp {} -> runTH THAnnWrapper fhv +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + annotation_wrapper <- liftIO $ wormhole interp fhv + return $ + case unsafeCoerce annotation_wrapper of + AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> + -- Got the value and dictionaries: build the serialized value and + -- call it a day. We ensure that we seq the entire serialized value + -- in order that any errors in the user-written code for the + -- annotation are exposed at this point. This is also why we are + -- doing all this stuff inside the context of runMeta: it has the + -- facilities to deal with user error in a meta-level expression + rnf serialized `seq` serialized + +#endif + +{- +************************************************************************ +* * +\subsection{Running an expression} +* * +************************************************************************ +-} + +runQuasi :: TH.Q a -> TcM a +runQuasi act = TH.runQ act + +runRemoteModFinalizers :: ThModFinalizers -> TcM () +runRemoteModFinalizers (ThModFinalizers finRefs) = do + let withForeignRefs [] f = f [] + withForeignRefs (x : xs) f = withForeignRef x $ \r -> + withForeignRefs xs $ \rs -> f (r : rs) + interp <- tcGetInterp + + case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + qs <- liftIO (withForeignRefs finRefs $ mapM localRef) + runQuasi $ sequence_ qs +#endif + + ExternalInterp ext -> withExtInterp ext $ \inst -> do + tcg <- getGblEnv + th_state <- readTcRef (tcg_th_remote_state tcg) + case th_state of + Nothing -> return () -- TH was not started, nothing to do + Just fhv -> do + r <- liftIO $ withForeignRef fhv $ \st -> + withForeignRefs finRefs $ \qrefs -> + sendMessageDelayedResponse inst (RunModFinalizers st qrefs) + () <- runRemoteTH inst [] + qr <- liftIO $ receiveDelayedResponse inst r + checkQResult qr + +runQResult + :: (a -> String) + -> (EnumSet LangExt.Extension -> Origin -> SrcSpan -> a -> b) + -> (ForeignHValue -> TcM a) + -> SrcSpan + -> ForeignHValue {- TH.Q a -} + -> TcM b +runQResult show_th f runQ expr_span hval + = do { exts <- fmap extensionFlags getDynFlags + ; th_result <- runQ hval + ; th_origin <- getThSpliceOrigin + ; traceTc "Got TH result:" (text (show_th th_result)) + ; return (f exts th_origin expr_span th_result) } + + +----------------- +runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) + -> LHsExpr GhcTc + -> TcM hs_syn +runMeta unwrap e = do + hooks <- getHooks + case runMetaHook hooks of + Nothing -> unwrap defaultRunMeta e + Just h -> unwrap h e + +defaultRunMeta :: MetaHook TcM +defaultRunMeta (MetaE r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp) +defaultRunMeta (MetaP r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat) +defaultRunMeta (MetaT r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType) +defaultRunMeta (MetaD r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) +defaultRunMeta (MetaAW r) + = fmap r . runMeta' False (const empty) (const $ fmap Right . convertAnnotationWrapper) + -- We turn off showing the code in meta-level exceptions because doing so exposes + -- the toAnnotationWrapper function that we slap around the user's code + +---------------- +runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper + -> TcM Serialized +runMetaAW = runMeta metaRequestAW + +runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) + -> TcM (LHsExpr GhcPs) +runMetaE = runMeta metaRequestE + +runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) + -> TcM (LPat GhcPs) +runMetaP = runMeta metaRequestP + +runMetaT :: LHsExpr GhcTc -- Of type (Q Type) + -> TcM (LHsType GhcPs) +runMetaT = runMeta metaRequestT + +runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] + -> TcM [LHsDecl GhcPs] +runMetaD = runMeta metaRequestD + +{- Note [Errors in desugaring a splice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we do if there are errors when desugaring a splice? We should +abort. There are several cases to consider: + +(a) The desugarer hits an unrecoverable error and fails in the monad. +(b) The desugarer hits a recoverable error, reports it, and continues. +(c) The desugarer reports a fatal warning (with -Werror), reports it, and continues. +(d) The desugarer reports a non-fatal warning, and continues. + +Each case is tested in th/T19709[abcd]. + +General principle: we wish to report all messages from dealing with a splice +eagerly, as these messages arise during an earlier stage than type-checking +generally. It's also likely that a compile-time warning from spliced code +will be easier to understand then an error that arises from processing the +code the splice produces. (Rationale: the warning will be about the code the +user actually wrote, not what is generated.) + +Case (a): We have no choice but to abort here, but we must make sure that +the messages are printed or logged before aborting. Logging them is annoying, +because we're in the type-checker, and the messages are DsMessages, from the +desugarer. So we report and then fail in the monad. This case is detected +by the fact that initDsTc returns Nothing. + +Case (b): We detect this case by looking for errors in the messages returned +from initDsTc and aborting if we spot any (after printing, of course). Note +that initDsTc will return a Just ds_expr in this case, but we don't wish to +use the (likely very bogus) expression. + +Case (c): This is functionally the same as (b), except that the expression +isn't bogus. We still don't wish to use it, as the user's request for -Werror +tells us not to. + +Case (d): We report the warnings and then carry on with the expression. +This might result in warnings printed out of source order, but this is +appropriate, as the warnings from the splice arise from an earlier stage +of compilation. + +Previously, we failed to abort in cases (b) and (c), leading to #19709. +-} + +--------------- +runMeta' :: Bool -- Whether code should be printed in the exception message + -> (hs_syn -> SDoc) -- how to print the code + -> (SrcSpan -> ForeignHValue -> TcM (Either RunSpliceFailReason hs_syn)) -- How to run x + -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or + -- something like that + -> TcM hs_syn -- Of type t +runMeta' show_code ppr_hs run_and_convert expr + = do { traceTc "About to run" (ppr expr) + + -- Check that we've had no errors of any sort so far. + -- For example, if we found an error in an earlier defn f, but + -- recovered giving it type f :: forall a.a, it'd be very dodgy + -- to carry on. Mind you, the staging restrictions mean we won't + -- actually run f, but it still seems wrong. And, more concretely, + -- see #5358 for an example that fell over when trying to + -- reify a function with an unlifted kind in it. (These don't occur + -- in type-correct programs.) + ; failIfErrsM + + -- run plugins + ; hsc_env <- getTopEnv + ; expr' <- withPlugins (hsc_plugins hsc_env) spliceRunAction expr + + -- Desugar + ; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr') + + -- Print any messages (even warnings) eagerly: they might be helpful if anything + -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all + -- cases. + ; logger <- getLogger + ; diag_opts <- initDiagOpts <$> getDynFlags + ; print_config <- initDsMessageOpts <$> getDynFlags + ; liftIO $ printMessages logger print_config diag_opts ds_msgs + + ; ds_expr <- case mb_ds_expr of + Nothing -> failM -- Case (a) from Note [Errors in desugaring a splice] + Just ds_expr -> -- There still might be a fatal warning or recoverable + -- Cases (b) and (c) from Note [Errors in desugaring a splice] + do { when (errorsOrFatalWarningsFound ds_msgs) + failM + ; return ds_expr } + + -- Compile and link it; might fail if linking fails + ; src_span <- getSrcSpanM + ; traceTc "About to run (desugared)" (ppr ds_expr) + ; either_hval <- tryM $ liftIO $ + GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr + ; case either_hval of { + Left exn -> fail_with_exn SplicePhase_CompileAndLink exn ; + Right (hval, needed_mods, needed_pkgs) -> do + + { -- Coerce it to Q t, and run it + + -- Running might fail if it throws an exception of any kind (hence tryAllM) + -- including, say, a pattern-match exception in the code we are running + -- + -- We also do the TH -> HS syntax conversion inside the same + -- exception-catching thing so that if there are any lurking + -- exceptions in the data structure returned by hval, we'll + -- encounter them inside the try + -- + -- See Note [Exceptions in TH] + let expr_span = getLocA expr + ; recordThNeededRuntimeDeps needed_mods needed_pkgs + ; either_tval <- tryAllM $ + setSrcSpan expr_span $ -- Set the span so that qLocation can + -- see where this splice is + do { mb_result <- run_and_convert expr_span hval + ; case mb_result of + Left err -> failWithTc $ + TcRnTHError $ THSpliceFailed $ RunSpliceFailure err + Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) + ; return $! result } } + + ; case either_tval of + Right v -> return v + Left se -> case fromException se of + Just IOEnvFailure -> failM -- Error already in Tc monad + _ -> fail_with_exn SplicePhase_Run se -- Exception + }}} + where + -- see Note [Concealed TH exceptions] + fail_with_exn :: Exception e => SplicePhase -> e -> TcM a + fail_with_exn phase exn = do + exn_msg <- liftIO $ Panic.safeShowException exn + failWithTc $ TcRnTHError $ THSpliceFailed $ + SpliceThrewException phase (toException exn) exn_msg expr show_code + +{- +Note [Running typed splices in the zonker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +See #15471 for the full discussion. + +For many years typed splices were run immediately after they were type checked +however, this is too early as it means to zonk some type variables before +they can be unified with type variables in the surrounding context. + +For example, + +``` +module A where + +test_foo :: forall a . Q (TExp (a -> a)) +test_foo = [|| id ||] + +module B where + +import A + +qux = $$(test_foo) +``` + +We would expect `qux` to have inferred type `forall a . a -> a` but if +we run the splices too early the unified variables are zonked to `Any`. The +inferred type is the unusable `Any -> Any`. + +To run the splice, we must compile `test_foo` all the way to byte code. +But at the moment when the type checker is looking at the splice, test_foo +has type `Q (TExp (alpha -> alpha))` and we +certainly can't compile code involving unification variables! + +We could default `alpha` to `Any` but then we infer `qux :: Any -> Any` +which definitely is not what we want. Moreover, if we had + qux = [$$(test_foo), (\x -> x +1::Int)] +then `alpha` would have to be `Int`. + +Conclusion: we must defer taking decisions about `alpha` until the +typechecker is done; and *then* we can run the splice. It's fine to do it +later, because we know it'll produce type-correct code. + +Deferring running the splice until later, in the zonker, means that the +unification variables propagate upwards from the splice into the surrounding +context and are unified correctly. + +This is implemented by storing the arguments we need for running the splice +in a `DelayedSplice`. In the zonker, the arguments are passed to +`GHC.Tc.Gen.Splice.runTopSplice` and the expression inserted into the AST as normal. + + + +Note [Exceptions in TH] +~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have something like this + $( f 4 ) +where + f :: Int -> Q [Dec] + f n | n>3 = fail "Too many declarations" + | otherwise = ... + +The 'fail' is a user-generated failure, and should be displayed as a +perfectly ordinary compiler error message, not a panic or anything +like that. Here's how it's processed: + + * 'fail' is the monad fail. The monad instance for Q in TH.Syntax + effectively transforms (fail s) to + qReport True s >> fail + where 'qReport' comes from the Quasi class and fail from its monad + superclass. + + * The TcM monad is an instance of Quasi (see GHC.Tc.Gen.Splice), and it implements + (qReport True s) by using addErr to add an error message to the bag of errors. + The 'fail' in TcM raises an IOEnvFailure exception + + * 'qReport' forces the message to ensure any exception hidden in unevaluated + thunk doesn't get into the bag of errors. Otherwise the following splice + will trigger panic (#8987): + $(fail undefined) + See also Note [Concealed TH exceptions] + + * So, when running a splice, we catch all exceptions; then for + - an IOEnvFailure exception, we assume the error is already + in the error-bag (above) + - other errors, we add an error to the bag + and then fail + +Note [Concealed TH exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When displaying the error message contained in an exception originated from TH +code, we need to make sure that the error message itself does not contain an +exception. For example, when executing the following splice: + + $( error ("foo " ++ error "bar") ) + +the message for the outer exception is a thunk which will throw the inner +exception when evaluated. + +For this reason, we display the message of a TH exception using the +'safeShowException' function, which recursively catches any exception thrown +when showing an error message. + + +To call runQ in the Tc monad, we need to make TcM an instance of Quasi: +-} + +instance TH.Quasi TcM where + qNewName s = do { u <- newUnique + ; let i = toInteger (getKey u) + ; return (TH.mkNameU s i) } + + -- 'msg' is forced to ensure exceptions don't escape, + -- see Note [Exceptions in TH] + qReport True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg + qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg + + qLocation :: TcM TH.Loc + qLocation = do { m <- getModule + ; l <- getSrcSpanM + ; r <- case l of + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + RealSrcSpan s _ -> return s + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = unitString (moduleUnit m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } + + qLookupName = lookupName + qReify = reify + qReifyFixity nm = lookupThName nm >>= reifyFixity + qReifyType = reifyTypeOfThing + qReifyInstances = reifyInstances + qReifyRoles = reifyRoles + qReifyAnnotations = reifyAnnotations + qReifyModule = reifyModule + qReifyConStrictness nm = do { nm' <- lookupThName nm + ; dc <- tcLookupDataCon nm' + ; let bangs = dataConImplBangs dc + ; return (map reifyDecidedStrictness bangs) } + + -- For qRecover, discard error messages if + -- the recovery action is chosen. Otherwise + -- we'll only fail higher up. + qRecover recover main = tryTcDiscardingErrs recover main + + qGetPackageRoot = do + dflags <- getDynFlags + return $ fromMaybe "." (workingDirectory dflags) + + qAddDependentFile fp = do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fp:dep_files) + + qAddTempFile suffix = do + dflags <- getDynFlags + logger <- getLogger + tmpfs <- hsc_tmpfs <$> getTopEnv + liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix + + qAddTopDecls thds = do + exts <- fmap extensionFlags getDynFlags + l <- getSrcSpanM + th_origin <- getThSpliceOrigin + let either_hval = convertToHsDecls exts th_origin l thds + ds <- case either_hval of + Left exn -> failWithTc $ TcRnTHError $ AddTopDeclsError $ + AddTopDeclsRunSpliceFailure exn + Right ds -> return ds + mapM_ (checkTopDecl . unLoc) ds + th_topdecls_var <- fmap tcg_th_topdecls getGblEnv + updTcRef th_topdecls_var (\topds -> ds ++ topds) + where + checkTopDecl :: HsDecl GhcPs -> TcM () + checkTopDecl (ValD _ binds) + = mapM_ bindName (collectHsBindBinders CollNoDictBinders binds) + checkTopDecl (SigD _ _) + = return () + checkTopDecl (AnnD _ _) + = return () + checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) + = bindName name + checkTopDecl d + = addErr $ TcRnTHError $ AddTopDeclsError $ InvalidTopDecl d + + bindName :: RdrName -> TcM () + bindName (Exact n) + = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv + ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) + } + + bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name + + qAddForeignFilePath lang fp = do + var <- fmap tcg_th_foreign_files getGblEnv + updTcRef var ((lang, fp) :) + + qAddModFinalizer fin = do + r <- liftIO $ mkRemoteRef fin + fref <- liftIO $ mkForeignRef r (freeRemoteRef r) + addModFinalizerRef fref + + qAddCorePlugin plugin = do + hsc_env <- getTopEnv + let fc = hsc_FC hsc_env + let home_unit = hsc_home_unit hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) + let err = TcRnTHError $ AddInvalidCorePlugin plugin + case r of + Found {} -> addErr err + FoundMultiple {} -> addErr err + _ -> return () + th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv + updTcRef th_coreplugins_var (plugin:) + + qGetQ :: forall a. Typeable a => TcM (Maybe a) + qGetQ = do + th_state_var <- fmap tcg_th_state getGblEnv + th_state <- readTcRef th_state_var + -- See #10596 for why we use a scoped type variable here. + return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) + + qPutQ x = do + th_state_var <- fmap tcg_th_state getGblEnv + updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) + + qIsExtEnabled = xoptM + + qExtsEnabled = + EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv + + qPutDoc doc_loc s = do + th_doc_var <- tcg_th_docs <$> getGblEnv + resolved_doc_loc <- resolve_loc doc_loc + is_local <- checkLocalName resolved_doc_loc + unless is_local $ failWithTc $ TcRnTHError $ AddDocToNonLocalDefn doc_loc + let ds = mkGeneratedHsDocString s + hd = lexHsDoc parseIdentifier ds + hd' <- rnHsDoc hd + updTcRef th_doc_var (Map.insert resolved_doc_loc hd') + where + resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n + resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i + resolve_loc (TH.InstDoc t) = InstDoc <$> fmap getName (lookupThInstName t) + resolve_loc TH.ModuleDoc = pure ModuleDoc + + -- It doesn't make sense to add documentation to something not inside + -- the current module. So check for it! + checkLocalName (DeclDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n + checkLocalName (ArgDoc n _) = nameIsLocalOrFrom <$> getModule <*> pure n + checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n + checkLocalName ModuleDoc = pure True + + + qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc + qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc + qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i + qGetDoc TH.ModuleDoc = do + df <- getDynFlags + docs <- getGblEnv >>= extractDocs df + return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs)) + +-- | Looks up documentation for a declaration in first the current module, +-- otherwise tries to find it in another module via 'hscGetModuleInterface'. +lookupDeclDoc :: Name -> TcM (Maybe String) +lookupDeclDoc nm = do + df <- getDynFlags + Docs{docs_decls} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df + case lookupUniqMap docs_decls nm of + Just doc -> pure $ Just (renderHsDocStrings $ map hsDocString doc) + Nothing -> do + -- Wasn't in the current module. Try searching other external ones! + mIface <- getExternalModIface nm + case mIface of + Just iface + | Just Docs{docs_decls = dmap} <- mi_docs iface -> + pure $ renderHsDocStrings . map hsDocString <$> lookupUniqMap dmap nm + _ -> pure Nothing + +-- | Like 'lookupDeclDoc', looks up documentation for a function argument. If +-- it can't find any documentation for a function in this module, it tries to +-- find it in another module. +lookupArgDoc :: Int -> Name -> TcM (Maybe String) +lookupArgDoc i nm = do + df <- getDynFlags + Docs{docs_args = argDocs} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df + case lookupUniqMap argDocs nm of + Just m -> pure $ renderHsDocString . hsDocString <$> IntMap.lookup i m + Nothing -> do + mIface <- getExternalModIface nm + case mIface of + Just iface + | Just Docs{docs_args = amap} <- mi_docs iface-> + pure $ renderHsDocString . hsDocString <$> (lookupUniqMap amap nm >>= IntMap.lookup i) + _ -> pure Nothing + +-- | Returns the module a Name belongs to, if it is isn't local. +getExternalModIface :: Name -> TcM (Maybe ModIface) +getExternalModIface nm = do + isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm + if isLocal + then pure Nothing + else case nameModule_maybe nm of + Nothing -> pure Nothing + Just modNm -> do + hsc_env <- getTopEnv + iface <- liftIO $ hscGetModuleInterface hsc_env modNm + pure (Just iface) + +-- | Find the GHC name of the first instance that matches the TH type +lookupThInstName :: TH.Type -> TcM Name +lookupThInstName th_type = do + cls_name <- inst_cls_name th_type + insts <- reifyInstances' cls_name (inst_arg_types th_type) + case insts of -- This expands any type synonyms + Left (_, (inst:_)) -> return $ getName inst + Left (_, []) -> noMatches + Right (_, (inst:_)) -> return $ getName inst + Right (_, []) -> noMatches + where + noMatches = failWithTc $ + TcRnTHError $ FailedToLookupThInstName th_type NoMatchesFound + + -- Get the name of the class for the instance we are documenting + -- > inst_cls_name (Monad Maybe) == Monad + -- > inst_cls_name C = C + inst_cls_name :: TH.Type -> TcM TH.Name + inst_cls_name (TH.AppT t _) = inst_cls_name t + inst_cls_name (TH.SigT n _) = inst_cls_name n + inst_cls_name (TH.VarT n) = pure n + inst_cls_name (TH.ConT n) = pure n + inst_cls_name (TH.PromotedT n) = pure n + inst_cls_name (TH.InfixT _ n _) = pure n + inst_cls_name (TH.UInfixT _ n _) = pure n + inst_cls_name (TH.PromotedInfixT _ n _) = pure n + inst_cls_name (TH.PromotedUInfixT _ n _) = pure n + inst_cls_name (TH.ParensT t) = inst_cls_name t + + inst_cls_name (TH.ForallT _ _ _) = inst_cls_name_err + inst_cls_name (TH.ForallVisT _ _) = inst_cls_name_err + inst_cls_name (TH.AppKindT _ _) = inst_cls_name_err + inst_cls_name (TH.TupleT _) = inst_cls_name_err + inst_cls_name (TH.UnboxedTupleT _) = inst_cls_name_err + inst_cls_name (TH.UnboxedSumT _) = inst_cls_name_err + inst_cls_name TH.ArrowT = inst_cls_name_err + inst_cls_name TH.MulArrowT = inst_cls_name_err + inst_cls_name TH.EqualityT = inst_cls_name_err + inst_cls_name TH.ListT = inst_cls_name_err + inst_cls_name (TH.PromotedTupleT _) = inst_cls_name_err + inst_cls_name TH.PromotedNilT = inst_cls_name_err + inst_cls_name TH.PromotedConsT = inst_cls_name_err + inst_cls_name TH.StarT = inst_cls_name_err + inst_cls_name TH.ConstraintT = inst_cls_name_err + inst_cls_name (TH.LitT _) = inst_cls_name_err + inst_cls_name TH.WildCardT = inst_cls_name_err + inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err + + inst_cls_name_err = failWithTc $ + TcRnTHError $ FailedToLookupThInstName th_type CouldNotDetermineInstance + + -- Basically does the opposite of 'mkThAppTs' + -- > inst_arg_types (Monad Maybe) == [Maybe] + -- > inst_arg_types C == [] + inst_arg_types :: TH.Type -> [TH.Type] + inst_arg_types (TH.AppT _ args) = + let go (TH.AppT t ts) = t:go ts + go t = [t] + in go args + inst_arg_types _ = [] + +-- | Adds a mod finalizer reference to the local environment. +addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () +addModFinalizerRef finRef = do + th_lvl <- getThLevel + case th_lvl of + RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :) + -- This case happens only if a splice is executed and the caller does + -- not set the 'ThLevel' to 'RunSplice' to collect finalizers. + -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. + _ -> + pprPanic "addModFinalizer was called when no finalizers were collected" + (ppr th_lvl) + +-- | Releases the external interpreter state. +finishTH :: TcM () +finishTH = do + hsc_env <- getTopEnv + case interpInstance <$> hsc_interp hsc_env of + Nothing -> pure () +#if defined(HAVE_INTERNAL_INTERPRETER) + Just InternalInterp -> pure () +#endif + Just (ExternalInterp {}) -> do + tcg <- getGblEnv + writeTcRef (tcg_th_remote_state tcg) Nothing + + +runTHExp :: ForeignHValue -> TcM TH.Exp +runTHExp = runTH THExp + +runTHPat :: ForeignHValue -> TcM TH.Pat +runTHPat = runTH THPat + +runTHType :: ForeignHValue -> TcM TH.Type +runTHType = runTH THType + +runTHDec :: ForeignHValue -> TcM [TH.Dec] +runTHDec = runTH THDec + +runTH :: Binary a => THResultType -> ForeignHValue -> TcM a +runTH ty fhv = do + interp <- tcGetInterp + case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + -- Run it in the local TcM + hv <- liftIO $ wormhole interp fhv + r <- runQuasi (unsafeCoerce hv :: TH.Q a) + return r +#endif + + ExternalInterp ext -> withExtInterp ext $ \inst -> do + -- Run it on the server. For an overview of how TH works with + -- Remote GHCi, see Note [Remote Template Haskell] in + -- libraries/ghci/GHCi/TH.hs. + rstate <- getTHState inst + loc <- TH.qLocation + -- run a remote TH request + r <- liftIO $ + withForeignRef rstate $ \state_hv -> + withForeignRef fhv $ \q_hv -> + sendMessageDelayedResponse inst (RunTH state_hv q_hv ty (Just loc)) + -- respond to requests from the interpreter + runRemoteTH inst [] + -- get the final result + qr <- liftIO $ receiveDelayedResponse inst r + bs <- checkQResult qr + return $! runGet get (LB.fromStrict bs) + + +-- | communicate with a remotely-running TH computation until it finishes. +-- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. +runRemoteTH + :: ExtInterpInstance d + -> [Messages TcRnMessage] -- saved from nested calls to qRecover + -> TcM () +runRemoteTH inst recovers = do + THMsg msg <- liftIO $ receiveTHMessage inst + case msg of + RunTHDone -> return () + StartRecover -> do -- Note [TH recover with -fexternal-interpreter] + v <- getErrsVar + msgs <- readTcRef v + writeTcRef v emptyMessages + runRemoteTH inst (msgs : recovers) + EndRecover caught_error -> do + let (prev_msgs, rest) = case recovers of + [] -> panic "EndRecover" + a : b -> (a,b) + v <- getErrsVar + warn_msgs <- getWarningMessages <$> readTcRef v + -- keep the warnings only if there were no errors + writeTcRef v $ if caught_error + then prev_msgs + else mkMessages warn_msgs `unionMessages` prev_msgs + runRemoteTH inst rest + _other -> do + r <- handleTHMessage msg + liftIO $ sendAnyValue inst r + runRemoteTH inst recovers + +-- | Check a QResult +checkQResult :: QResult a -> TcM a +checkQResult qr = + case qr of + QDone a -> return a + QException str -> liftIO $ throwIO (ErrorCall str) + QFail str -> fail str + +{- Note [TH recover with -fexternal-interpreter] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recover is slightly tricky to implement. + +The meaning of "recover a b" is + - Do a + - If it finished with no errors, then keep the warnings it generated + - If it failed, discard any messages it generated, and do b + +Note that "failed" here can mean either + (1) threw an exception (failTc) + (2) generated an error message (addErrTcM) + +The messages are managed by GHC in the TcM monad, whereas the +exception-handling is done in the ghc-iserv process, so we have to +coordinate between the two. + +On the server: + - emit a StartRecover message + - run "a; FailIfErrs" inside a try + - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed + - if "a; FailIfErrs" failed, run "b" + +Back in GHC, when we receive: + + FailIfErrrs + failTc if there are any error messages (= failIfErrsM) + StartRecover + save the current messages and start with an empty set. + EndRecover caught_error + Restore the previous messages, + and merge in the new messages if caught_error is false. +-} + +-- | Retrieve (or create, if it hasn't been created already), the +-- remote TH state. The TH state is a remote reference to an IORef +-- QState living on the server, and we have to pass this to each RunTH +-- call we make. +-- +-- The TH state is stored in tcg_th_remote_state in the TcGblEnv. +-- +getTHState :: ExtInterpInstance d -> TcM (ForeignRef (IORef QState)) +getTHState inst = do + th_state_var <- tcg_th_remote_state <$> getGblEnv + liftIO $ do + th_state <- readIORef th_state_var + case th_state of + Just rhv -> return rhv + Nothing -> do + rref <- sendMessage inst StartTH + fhv <- mkForeignRef rref (freeReallyRemoteRef inst rref) + writeIORef th_state_var (Just fhv) + return fhv + +wrapTHResult :: TcM a -> TcM (THResult a) +wrapTHResult tcm = do + e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic + case e of + Left e -> return (THException (show e)) + Right a -> return (THComplete a) + +handleTHMessage :: THMessage a -> TcM a +handleTHMessage msg = case msg of + NewName a -> wrapTHResult $ TH.qNewName a + Report b str -> wrapTHResult $ TH.qReport b str + LookupName b str -> wrapTHResult $ TH.qLookupName b str + Reify n -> wrapTHResult $ TH.qReify n + ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n + ReifyType n -> wrapTHResult $ TH.qReifyType n + ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts + ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n + ReifyAnnotations lookup tyrep -> + wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) + ReifyModule m -> wrapTHResult $ TH.qReifyModule m + ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm + GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot + AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f + AddTempFile s -> wrapTHResult $ TH.qAddTempFile s + AddModFinalizer r -> do + interp <- hscInterp <$> getTopEnv + wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef + AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str + AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs + AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str + IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext + ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled + PutDoc l s -> wrapTHResult $ TH.qPutDoc l s + GetDoc l -> wrapTHResult $ TH.qGetDoc l + FailIfErrs -> wrapTHResult failIfErrsM + _ -> panic ("handleTHMessage: unexpected message " ++ show msg) + +getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]] +getAnnotationsByTypeRep th_name tyrep + = do { name <- lookupThAnnLookup th_name + ; topEnv <- getTopEnv + ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing + ; tcg <- getGblEnv + ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep + ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep + ; return (selectedEpsHptAnns ++ selectedTcgAnns) } + +{- +************************************************************************ +* * + Instance Testing +* * +************************************************************************ +-} + +reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] +reifyInstances th_nm th_tys + = do { insts <- reifyInstances' th_nm th_tys + ; case insts of + Left (cls, cls_insts) -> + reifyClassInstances cls cls_insts + Right (tc, fam_insts) -> + reifyFamilyInstances tc fam_insts } + +reifyInstances' :: TH.Name + -> [TH.Type] + -> TcM (Either (Class, [ClsInst]) (TyCon, [FamInst])) + -- ^ Returns 'Left' in the case that the instances were found to + -- be class instances, or 'Right' if they are family instances. +reifyInstances' th_nm th_tys + = addErrCtxt (ReifyInstancesCtxt th_nm th_tys) $ + do { exts <- fmap extensionFlags getDynFlags + ; loc <- getSrcSpanM + ; th_origin <- getThSpliceOrigin + ; rdr_ty <- cvt exts th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys) + -- #9262 says to bring vars into scope, like in HsForAllTy case + -- of rnHsTyKi + ; tv_rdrs <- filterInScopeM $ extractHsTyRdrTyVars rdr_ty + -- Rename to HsType Name + ; ((tv_names, rn_ty), _fvs) + <- checkNoErrs $ -- If there are out-of-scope Names here, then we + -- must error before proceeding to typecheck the + -- renamed type, as that will result in GHC + -- internal errors (#13837). + rnImplicitTvOccs Nothing tv_rdrs $ \ tv_names -> + do { (rn_ty, fvs) <- rnLHsType doc rdr_ty + ; return ((tv_names, rn_ty), fvs) } + ; skol_info <- mkSkolemInfo ReifySkol + ; (tclvl, wanted, (tvs, ty)) + <- pushLevelAndSolveEqualitiesX "reifyInstances" $ + bindImplicitTKBndrs_Skol skol_info tv_names $ + tcInferLHsType rn_ty + + ; tvs <- zonkAndScopedSort tvs + + -- Avoid error cascade if there are unsolved + ; reportUnsolvedEqualities skol_info tvs tclvl wanted + + ; ty <- zonkTcTypeToType ty + -- Substitute out the meta type variables + -- In particular, the type might have kind + -- variables inside it (#7477) + + ; traceTc "reifyInstances'" (ppr ty $$ ppr (typeKind ty)) + ; case splitTyConApp_maybe ty of -- This expands any type synonyms + Just (tc, tys) -- See #7910 + | Just cls <- tyConClass_maybe tc + -> do { inst_envs <- tcGetInstEnvs + ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys + ; traceTc "reifyInstances'1" (ppr matches) + ; return $ Left (cls, map fst matches ++ getCoherentUnifiers 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 $ TcRnTHError $ THReifyError $ CannotReifyInstance ty } + where + doc = ReifyInstancesCtx + bale_out msg = failWithTc msg + + cvt :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) + cvt exts origin loc th_ty = case convertToHsType exts origin loc th_ty of + Left msg -> failWithTc (TcRnTHError $ THSpliceFailed $ RunSpliceFailure msg) + Right ty -> return ty + +{- +************************************************************************ +* * + Reification +* * +************************************************************************ +-} + +lookupName :: Bool -- True <=> type namespace + -- False <=> value namespace + -> String -> TcM (Maybe TH.Name) +lookupName is_type_name s + = do { mb_nm <- lookupOccRn_maybe rdr_name + ; return (fmap (reifyName . greName) mb_nm) } + where + th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' + + occ_fs :: FastString + occ_fs = mkFastString (TH.nameBase th_name) + + occ :: OccName + occ | is_type_name + = if isLexVarSym occ_fs || isLexCon occ_fs + then mkTcOccFS occ_fs + else mkTyVarOccFS occ_fs + | otherwise + = if isLexCon occ_fs then mkDataOccFS occ_fs + else mkVarOccFS occ_fs + -- NB: when we pick the variable namespace, we + -- might well obtain an identifier in a record + -- field namespace, as lookupOccRn_maybe looks in + -- record field namespaces when looking up variables. + -- This ensures we can look up record fields using + -- this function (#24293). + + rdr_name = case TH.nameModule th_name of + Nothing -> mkRdrUnqual occ + Just mod -> mkRdrQual (mkModuleName mod) occ + +-- | We only want to produce warnings for TH-splices if the user requests so. +-- See Note [Warnings for TH splices]. +getThSpliceOrigin :: TcM Origin +getThSpliceOrigin = do + warn <- goptM Opt_EnableThSpliceWarnings + if warn then return FromSource else return (Generated OtherExpansion SkipPmc) + +getThing :: TH.Name -> TcM TcTyThing +getThing th_name + = do { name <- lookupThName th_name + ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) + ; tcLookupTh name } + -- ToDo: this tcLookup could fail, which would give a + -- rather unhelpful error message + where + ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" + ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" + ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns (TH.Name _ (TH.NameG (TH.FldName {}) _pkg _mod)) = text "fld" + ppr_ns _ = panic "reify/ppr_ns" + +reify :: TH.Name -> TcM TH.Info +reify th_name + = do { traceTc "reify 1" (text (TH.showName th_name)) + ; thing <- getThing th_name + ; traceTc "reify 2" (ppr thing) + ; reifyThing thing } + +lookupThName :: TH.Name -> TcM Name +lookupThName th_name = do + mb_name <- lookupThName_maybe th_name + case mb_name of + Nothing -> failWithTc (notInScope th_name) + Just name -> return name + +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) +lookupThName_maybe th_name + = do { listTuplePuns <- xoptM LangExt.ListTuplePuns + ; let guesses = thRdrNameGuesses listTuplePuns th_name + ; case guesses of + { [for_sure] -> lookupSameOccRn_maybe for_sure + ; _ -> + do { gres <- mapMaybeM lookupOccRn_maybe guesses + -- Pick the first that works + -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A + ; return (fmap greName $ listToMaybe gres) } } } + +tcLookupTh :: Name -> TcM TcTyThing +-- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that +-- it gives a reify-related error message on failure, whereas in the normal +-- tcLookup, failure is a bug. +tcLookupTh name + = do { (gbl_env, lcl_env) <- getEnvs + ; case lookupNameEnv (getLclEnvTypeEnv lcl_env) name of { + Just thing -> return thing; + Nothing -> + + case lookupNameEnv (tcg_type_env gbl_env) name of { + Just thing -> return (AGlobal thing); + Nothing -> + + -- EZY: I don't think this choice matters, no TH in signatures! + if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name + then -- It's defined in this module + failWithTc (notInEnv name) + + else + do { mb_thing <- tcLookupImported_maybe name + ; case mb_thing of + Succeeded thing -> return (AGlobal thing) + Failed msg -> failWithTc (TcRnInterfaceError msg) + }}}} + +notInScope :: TH.Name -> TcRnMessage +notInScope th_name = + TcRnTHError $ THReifyError $ CannotReifyOutOfScopeThing th_name + +notInEnv :: Name -> TcRnMessage +notInEnv name = TcRnTHError $ THReifyError $ CannotReifyThingNotInTypeEnv name + +------------------------------ +reifyRoles :: TH.Name -> TcM [TH.Role] +reifyRoles th_name + = do { thing <- getThing th_name + ; case thing of + AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) + _ -> failWithTc $ TcRnTHError $ THReifyError $ + NoRolesAssociatedWithThing thing + } + where + reify_role Nominal = TH.NominalR + reify_role Representational = TH.RepresentationalR + reify_role Phantom = TH.PhantomR + +------------------------------ +reifyThing :: TcTyThing -> TcM TH.Info +-- The only reason this is monadic is for error reporting, +-- which in turn is mainly for the case when TH can't express +-- some random GHC extension + +reifyThing (AGlobal (AnId id)) + = do { ty <- reifyType (idType id) + ; let v = reifyName id + ; case idDetails id of + ClassOpId cls _ -> return (TH.ClassOpI v ty (reifyName cls)) + _ -> return (TH.VarI v ty Nothing) + } + +reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc +reifyThing (AGlobal (AConLike (RealDataCon dc))) + = mkDataConI dc + +reifyThing (AGlobal (AConLike (PatSynCon ps))) + = do { let name = reifyName ps + ; ty <- reifyPatSynType (patSynSigBndr ps) + ; return (TH.PatSynI name ty) } + +reifyThing (ATcId {tct_id = id}) + = do { ty1 <- liftZonkM $ zonkTcType (idType id) -- Make use of all the info we have, even + -- though it may be incomplete + ; ty2 <- reifyType ty1 + ; return (TH.VarI (reifyName id) ty2 Nothing) } + +reifyThing (ATyVar tv tv1) + = do { ty1 <- liftZonkM $ zonkTcTyVar tv1 + ; ty2 <- reifyType ty1 + ; return (TH.TyVarI (reifyName tv) ty2) } + +reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) + +------------------------------------------- +reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn +reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + -- remove kind patterns (#8884) + = do { tvs' <- reifyTyVarsToMaybe tvs + ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs + ; lhs' <- reifyTypes lhs_types_only + ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc) + lhs_types_only lhs' + ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs + ; rhs' <- reifyType rhs + ; return (TH.TySynEqn tvs' lhs_type rhs') } + +reifyTyCon :: TyCon -> TcM TH.Info +reifyTyCon tc + | Just cls <- tyConClass_maybe tc + = reifyClass cls + +{- Seems to be just a short cut for the next equation -- omit + | tc `hasKey` fUNTyConKey -- I'm not quite sure what is happening here + = return (TH.PrimTyConI (reifyName tc) 2 False) +-} + + | isPrimTyCon tc + = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc)) + (isUnliftedTypeKind (tyConResKind tc))) + + | isTypeFamilyTyCon tc + = do { let tvs = tyConTyVars tc + res_kind = tyConResKind tc + resVar = tyConFamilyResVar_maybe tc + + ; kind' <- reifyKind res_kind + ; let (resultSig, injectivity) = + case resVar of + Nothing -> (TH.KindSig kind', Nothing) + Just name -> + let thName = reifyName name + injAnnot = tyConInjectivityInfo tc + sig = TH.TyVarSig (TH.KindedTV thName () kind') + inj = case injAnnot of + NotInjective -> Nothing + Injective ms -> + Just (TH.InjectivityAnn thName injRHS) + where + injRHS = map (reifyName . tyVarName) + (filterByList ms tvs) + in (sig, inj) + ; tvs' <- reifyTyConBinders tc + ; let tfHead = + TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity + ; if isOpenTypeFamilyTyCon tc + then do { fam_envs <- tcGetFamInstEnvs + ; instances <- reifyFamilyInstances tc + (familyInstances fam_envs tc) + ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) } + else do { eqns <- + case isClosedSynFamilyTyConWithAxiom_maybe tc of + Just ax -> mapM (reifyAxBranch tc) $ + fromBranches $ coAxiomBranches ax + Nothing -> return [] + ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns) + []) } } + + | isDataFamilyTyCon tc + = do { let res_kind = tyConResKind tc + + ; kind' <- fmap Just (reifyKind res_kind) + + ; tvs' <- reifyTyConBinders tc + ; fam_envs <- tcGetFamInstEnvs + ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) + ; return (TH.FamilyI + (TH.DataFamilyD (reifyName tc) tvs' kind') instances) } + + | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym + = do { rhs' <- reifyType rhs + ; tvs' <- reifyTyConBinders tc + ; return (TH.TyConI + (TH.TySynD (reifyName tc) tvs' rhs')) + } + + -- Special case for `type data` data constructors, which are reified as + -- `ATyCon`s rather than `ADataCon`s (#22818). + -- See Note [Type data declarations] in GHC.Rename.Module. + | Just dc <- isPromotedDataCon_maybe tc + , isTypeDataCon dc + = mkDataConI dc + + | otherwise + = do { cxt <- reifyCxt (tyConStupidTheta tc) + ; let tvs = tyConTyVars tc + dataCons = tyConDataCons tc + isGadt = isGadtSyntaxTyCon tc + ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons + ; r_tvs <- reifyTyConBinders tc + ; let name = reifyName tc + deriv = [] -- Don't know about deriving + decl | isTypeDataTyCon tc = + -- `type data` declarations have a special `Dec`, + -- separate from other `DataD`s. See + -- [Type data declarations] in GHC.Rename.Module. + TH.TypeDataD name r_tvs Nothing cons + | isNewTyCon tc = + TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv + | otherwise = + TH.DataD cxt name r_tvs Nothing cons deriv + ; return (TH.TyConI decl) } + +reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con +reifyDataCon isGadtDataCon tys dc + = do { let -- used for H98 data constructors + (ex_tvs, theta, arg_tys) + = dataConInstSig dc tys + -- used for GADTs data constructors + g_user_tvs' = dataConUserTyVarBinders dc + (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty') + = dataConFullSig dc + (srcUnpks, srcStricts) + = mapAndUnzip reifySourceBang (dataConSrcBangs dc) + dcdBangs = zipWith TH.Bang srcUnpks srcStricts + fields = dataConFieldLabels dc + name = reifyName dc + -- Universal tvs present in eq_spec need to be filtered out, as + -- they will not appear anywhere in the type. + eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec) + + ; (univ_subst, _) + -- See Note [Freshen reified GADT constructors' universal tyvars] + <- freshenTyVarBndrs $ + filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs + ; let (tvb_subst, g_user_tvs) = subst_tv_binders univ_subst g_user_tvs' + g_theta = substTys tvb_subst g_theta' + g_arg_tys = substTys tvb_subst (map scaledThing g_arg_tys') + g_res_ty = substTy tvb_subst g_res_ty' + + ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys) + + ; main_con <- + if | not (null fields) && not isGadtDataCon -> + return $ TH.RecC name (zip3 (map reifyFieldLabel fields) + dcdBangs r_arg_tys) + | not (null fields) -> do + { res_ty <- reifyType g_res_ty + ; return $ TH.RecGadtC [name] + (zip3 (map reifyFieldLabel fields) + dcdBangs r_arg_tys) res_ty } + -- We need to check not isGadtDataCon here because GADT + -- constructors can be declared infix. + -- See Note [Infix GADT constructors] in GHC.Tc.TyCl. + | dataConIsInfix dc && not isGadtDataCon -> + assert (r_arg_tys `lengthIs` 2) $ do + { let [r_a1, r_a2] = r_arg_tys + [s1, s2] = dcdBangs + ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) } + | isGadtDataCon -> do + { res_ty <- reifyType g_res_ty + ; return $ TH.GadtC [name] + (dcdBangs `zip` r_arg_tys) res_ty } + | otherwise -> + return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) + + ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta) + | otherwise = assert (all isTyVar ex_tvs) + -- no covars for haskell syntax + (map mk_specified ex_tvs, theta) + ret_con | null ex_tvs' && null theta' = return main_con + | otherwise = do + { cxt <- reifyCxt theta' + ; ex_tvs'' <- case to_invis_bndrs ex_tvs' of + Nothing -> noTH DataConVisibleForall (dataConDisplayType False dc) + Just tvs -> reifyTyVarBndrs tvs + ; return (TH.ForallC ex_tvs'' cxt main_con) } + ; assert (r_arg_tys `equalLength` dcdBangs) + ret_con } + where + mk_specified tv = Bndr tv Specified + + to_invis_bndrs :: [TyVarBinder] -> Maybe [InvisTVBinder] + to_invis_bndrs = traverse $ \(Bndr tv vis) -> + case vis of + Invisible spec -> Just (Bndr tv spec) + Required -> Nothing + + subst_tv_binders subst tv_bndrs = + let tvs = binderVars tv_bndrs + flags = binderFlags tv_bndrs + (subst', tvs') = substTyVarBndrs subst tvs + tv_bndrs' = map (\(tv,fl) -> Bndr tv fl) (zip tvs' flags) + in (subst', tv_bndrs') + +mkDataConI :: DataCon -> TcM TH.Info +mkDataConI dc + = do { let name = dataConName dc + ; ty <- reifyType (idType (dataConWrapId dc)) + ; return (TH.DataConI (reifyName name) ty + (reifyName (dataConOrigTyCon dc))) + } + +{- +Note [Freshen reified GADT constructors' universal tyvars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose one were to reify this GADT: + + data a :~: b where + Refl :: forall a b. (a ~ b) => a :~: b + +We ought to be careful here about the uniques we give to the occurrences of `a` +and `b` in this definition. That is because in the original DataCon, all uses +of `a` and `b` have the same unique, since `a` and `b` are both universally +quantified type variables--that is, they are used in both the (:~:) tycon as +well as in the constructor type signature. But when we turn the DataCon +definition into the reified one, the `a` and `b` in the constructor type +signature becomes differently scoped than the `a` and `b` in `data a :~: b`. + +While it wouldn't technically be *wrong* per se to re-use the same uniques for +`a` and `b` across these two different scopes, it's somewhat annoying for end +users of Template Haskell, since they wouldn't be able to rely on the +assumption that all TH names have globally distinct uniques (#13885). For this +reason, we freshen the universally quantified tyvars that go into the reified +GADT constructor type signature to give them distinct uniques from their +counterparts in the tycon. +-} + +------------------------------ +reifyClass :: Class -> TcM TH.Info +reifyClass cls + = do { cxt <- reifyCxt theta + ; inst_envs <- tcGetInstEnvs + ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) + ; assocTys <- concatMapM reifyAT ats + ; ops <- concatMapM reify_op op_stuff + ; tvs' <- reifyTyConBinders (classTyCon cls) + ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) + ; return (TH.ClassI dec insts) } + where + (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls + fds' = map reifyFunDep fds + reify_op (op, def_meth) + = do { let (_, _, ty) = tcSplitMethodTy (idType op) + -- Use tcSplitMethodTy to get rid of the extraneous class + -- variables and predicates at the beginning of op's type + -- (see #15551). + ; ty' <- reifyType ty + ; let nm' = reifyName op + ; case def_meth of + Just (_, GenericDM gdm_ty) -> + do { gdm_ty' <- reifyType gdm_ty + ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] } + _ -> return [TH.SigD nm' ty'] } + + reifyAT :: ClassATItem -> TcM [TH.Dec] + reifyAT (ATI tycon def) = do + tycon' <- reifyTyCon tycon + case tycon' of + TH.FamilyI dec _ -> do + let (tyName, tyArgs) = tfNames dec + (dec :) <$> maybe (return []) + (fmap (:[]) . reifyDefImpl tyName tyArgs . fst) + def + _ -> pprPanic "reifyAT" (text (show tycon')) + + reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec + reifyDefImpl n args ty = + TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args)) + <$> reifyType ty + + tfNames :: TH.Dec -> (TH.Name, [TH.Name]) + tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _)) + = (n, map bndrName args) + tfNames d = pprPanic "tfNames" (text (show d)) + + bndrName :: TH.TyVarBndr flag -> TH.Name + bndrName (TH.PlainTV n _) = n + bndrName (TH.KindedTV n _ _) = n + +------------------------------ +-- | Annotate (with TH.SigT) a type if the first parameter is True +-- and if the type contains a free variable. +-- This is used to annotate type patterns for poly-kinded tyvars in +-- reifying class and type instances. +-- See @Note [Reified instances and explicit kind signatures]@. +annotThType :: Bool -- True <=> annotate + -> TyCoRep.Type -> TH.Type -> TcM TH.Type + -- tiny optimization: if the type is annotated, don't annotate again. +annotThType _ _ th_ty@(TH.SigT {}) = return th_ty +annotThType True ty th_ty + | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty + = do { let ki = typeKind ty + ; th_ki <- reifyKind ki + ; return (TH.SigT th_ty th_ki) } +annotThType _ _ th_ty = return th_ty + +-- | For every argument type that a type constructor accepts, +-- report whether or not the argument is poly-kinded. This is used to +-- eventually feed into 'annotThType'. +-- See @Note [Reified instances and explicit kind signatures]@. +tyConArgsPolyKinded :: TyCon -> [Bool] +tyConArgsPolyKinded tc = + map (is_poly_ty . tyVarKind) tc_vis_tvs + -- See "Wrinkle: Oversaturated data family instances" in + -- @Note [Reified instances and explicit kind signatures]@ + ++ map (is_poly_ty . piTyBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle + ++ repeat True -- (2) in Wrinkle + where + is_poly_ty :: Type -> Bool + is_poly_ty ty = not $ + isEmptyVarSet $ + filterVarSet isTyVar $ + tyCoVarsOfType ty + + tc_vis_tvs :: [TyVar] + tc_vis_tvs = tyConVisibleTyVars tc + + tc_res_kind_vis_bndrs :: [PiTyBinder] + tc_res_kind_vis_bndrs = filter isVisiblePiTyBinder $ fst $ splitPiTys $ tyConResKind tc + +{- +Note [Reified instances and explicit kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Reified class instances and type family instances often include extra kind +information to disambiguate instances. Here is one such example that +illustrates this (#8953): + + type family Poly (a :: k) :: Type + type instance Poly (x :: Bool) = Int + type instance Poly (x :: Maybe k) = Double + +If you're not careful, reifying these instances might yield this: + + type instance Poly x = Int + type instance Poly x = Double + +To avoid this, we go through some care to annotate things with extra kind +information. Some functions which accomplish this feat include: + +* annotThType: This annotates a type with a kind signature if the type contains + a free variable. +* tyConArgsPolyKinded: This checks every argument that a type constructor can + accept and reports if the type of the argument is poly-kinded. This + information is ultimately fed into annotThType. + +----- +-- Wrinkle: Oversaturated data family instances +----- + +What constitutes an argument to a type constructor in the definition of +tyConArgsPolyKinded? For most type constructors, it's simply the visible +type variable binders (i.e., tyConVisibleTyVars). There is one corner case +we must keep in mind, however: data family instances can appear oversaturated +(#17296). For instance: + + data family Foo :: Type -> Type + data instance Foo x + + data family Bar :: k + data family Bar x + +For these sorts of data family instances, tyConVisibleTyVars isn't enough, +as they won't give you the kinds of the oversaturated arguments. We must +also consult: + +1. The kinds of the arguments in the result kind (i.e., the tyConResKind). + This will tell us, e.g., the kind of `x` in `Foo x` above. +2. If we go beyond the number of arguments in the result kind (like the + `x` in `Bar x`), then we conservatively assume that the argument's + kind is poly-kinded. + +----- +-- Wrinkle: data family instances with return kinds +----- + +Another squirrelly corner case is this: + + data family Foo (a :: k) + data instance Foo :: Bool -> Type + data instance Foo :: Char -> Type + +If you're not careful, reifying these instances might yield this: + + data instance Foo + data instance Foo + +We can fix this ambiguity by reifying the instances' explicit return kinds. We +should only do this if necessary (see +Note [When does a tycon application need an explicit kind signature?] in GHC.Core.Type), +but more importantly, we *only* do this if either of the following are true: + +1. The data family instance has no constructors. +2. The data family instance is declared with GADT syntax. + +If neither of these are true, then reifying the return kind would yield +something like this: + + data instance (Bar a :: Type) = MkBar a + +Which is not valid syntax. +-} + +------------------------------ +reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] +reifyClassInstances cls insts + = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts + +reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded + -- includes only *visible* tvs + -> ClsInst -> TcM TH.Dec +reifyClassInstance is_poly_tvs i + = do { cxt <- reifyCxt theta + ; let vis_types = filterOutInvisibleTypes cls_tc types + ; thtypes <- reifyTypes vis_types + ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes + ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes + ; return $ (TH.InstanceD over cxt head_ty []) } + where + (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) + cls_tc = classTyCon cls + dfun = instanceDFunId i + over = case overlapMode (is_flag i) of + NoOverlap _ -> Nothing + Overlappable _ -> Just TH.Overlappable + Overlapping _ -> Just TH.Overlapping + Overlaps _ -> Just TH.Overlaps + Incoherent _ -> Just TH.Incoherent + NonCanonical _ -> Just TH.Incoherent + +------------------------------ +reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] +reifyFamilyInstances fam_tc fam_insts + = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts + +reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded + -- includes only *visible* tvs + -> FamInst -> TcM TH.Dec +reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor + , fi_axiom = ax + , fi_fam = fam }) + | let fam_tc = coAxiomTyCon ax + branch = coAxiomSingleBranch ax + , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch + = case flavor of + SynFamilyInst -> + -- remove kind patterns (#8884) + do { th_tvs <- reifyTyVarsToMaybe tvs + ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs + ; th_lhs <- reifyTypes lhs_types_only + ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only + th_lhs + ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs + ; th_rhs <- reifyType rhs + ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) } + + DataFamilyInst rep_tc -> + do { let -- eta-expand lhs types, because sometimes data/newtype + -- instances are eta-reduced; See #9692 + -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch + fam' = reifyName fam + dataCons = tyConDataCons rep_tc + isGadt = isGadtSyntaxTyCon rep_tc + ; th_tvs <- reifyTyVarsToMaybe ee_tvs + ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons + ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs + ; th_tys <- reifyTypes types_only + ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys + ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys + ; mb_sig <- + -- See "Wrinkle: data family instances with return kinds" in + -- Note [Reified instances and explicit kind signatures] + if (null cons || isGadtSyntaxTyCon rep_tc) + && tyConAppNeedsKindSig False fam_tc (length ee_lhs) + then do { let full_kind = typeKind (mkTyConApp fam_tc ee_lhs) + ; th_full_kind <- reifyKind full_kind + ; pure $ Just th_full_kind } + else pure Nothing + ; return $ + if isNewTyCon rep_tc + then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) [] + else TH.DataInstD [] th_tvs lhs_type mb_sig cons [] + } + +------------------------------ +reifyType :: TyCoRep.Type -> TcM TH.Type +-- Monadic only because of failure +reifyType ty | tcIsLiftedTypeKind ty = return TH.StarT + -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it + -- with Constraint (#14869). +reifyType ty@(ForAllTy (Bndr _ argf) _) + = reify_for_all argf ty +reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } +reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) +reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here +reifyType ty@(AppTy {}) = do + let (ty_head, ty_args) = splitAppTys ty + ty_head' <- reifyType ty_head + ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args) + pure $ mkThAppTs ty_head' ty_args' + where + -- Make sure to filter out any invisible arguments. For instance, if you + -- reify the following: + -- + -- newtype T (f :: forall a. a -> Type) = MkT (f Bool) + -- + -- Then you should receive back `f Bool`, not `f Type Bool`, since the + -- `Type` argument is invisible (#15792). + filter_out_invisible_args :: Type -> [Type] -> [Type] + filter_out_invisible_args ty_head ty_args = + filterByList (map isVisibleForAllTyFlag $ appTyForAllTyFlags ty_head ty_args) + ty_args +reifyType ty@(FunTy { ft_af = af, ft_mult = ManyTy, ft_arg = t1, ft_res = t2 }) + | isInvisibleFunArg af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char) + | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] + ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } +reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 }) + | isInvisibleFunArg af = noTH LinearInvisibleArgument ty + | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2] + ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } +reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH +reifyType ty@(CoercionTy {})= noTH CoercionsInTypes ty + +reify_for_all :: TyCoRep.ForAllTyFlag -> TyCoRep.Type -> TcM TH.Type +-- Arg of reify_for_all is always ForAllTy or a predicate FunTy +reify_for_all argf ty + | isVisibleForAllTyFlag argf + = do let (req_bndrs, phi) = tcSplitForAllReqTVBinders ty + tvbndrs' <- reifyTyVarBndrs req_bndrs + phi' <- reifyType phi + pure $ TH.ForallVisT tvbndrs' phi' + | otherwise + = do let (inv_bndrs, phi) = tcSplitForAllInvisTVBinders ty + tvbndrs' <- reifyTyVarBndrs inv_bndrs + let (cxt, tau) = tcSplitPhiTy phi + cxt' <- reifyCxt cxt + tau' <- reifyType tau + pure $ TH.ForallT tvbndrs' cxt' tau' + +reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit +reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) +reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) +reifyTyLit (CharTyLit c) = return (TH.CharTyLit c) + +reifyTypes :: [Type] -> TcM [TH.Type] +reifyTypes = mapM reifyType + +reifyPatSynType + :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type) -> TcM TH.Type +-- reifies a pattern synonym's type and returns its *complete* type +-- signature; see Note [Pattern synonym type signatures and Template +-- Haskell] in GHC.ThToHs +reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) + = do { univTyVars' <- reifyTyVarBndrs univTyVars + ; req' <- reifyCxt req + ; exTyVars' <- reifyTyVarBndrs exTyVars + ; prov' <- reifyCxt prov + ; tau' <- reifyType (mkScaledFunTys argTys resTy) + ; return $ TH.ForallT univTyVars' req' + $ TH.ForallT exTyVars' prov' tau' } + +reifyKind :: Kind -> TcM TH.Kind +reifyKind = reifyType + +reifyCxt :: [PredType] -> TcM [TH.Pred] +reifyCxt = mapM reifyType + +reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep +reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) + +class ReifyFlag flag flag' | flag -> flag' where + reifyFlag :: flag -> flag' + +instance ReifyFlag () () where + reifyFlag () = () + +instance ReifyFlag Specificity TH.Specificity where + reifyFlag SpecifiedSpec = TH.SpecifiedSpec + reifyFlag InferredSpec = TH.InferredSpec + +instance ReifyFlag TyConBndrVis (Maybe TH.BndrVis) where + reifyFlag AnonTCB = Just TH.BndrReq + reifyFlag (NamedTCB Required) = Just TH.BndrReq + reifyFlag (NamedTCB (Invisible _)) = + Nothing -- See Note [Reifying invisible type variable binders] and #22828. + +-- Currently does not return invisible type variable binders (@k-binders). +-- See Note [Reifying invisible type variable binders] and #22828. +reifyTyConBinders :: TyCon -> TcM [TH.TyVarBndr TH.BndrVis] +reifyTyConBinders tc = fmap (mapMaybe get_bndr) (reifyTyVarBndrs (tyConBinders tc)) + where + get_bndr :: TH.TyVarBndr (Maybe flag) -> Maybe (TH.TyVarBndr flag) + get_bndr = sequenceA + +{- Note [Reifying invisible type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In reifyFlag for TyConBndrVis, we have the following clause: + + reifyFlag (NamedTCB (Invisible _)) = Nothing + +This means that reifyTyConBinders doesn't reify invisible type variables as +@k-binders. However, it is possible (and not hard) to change this. +Just replace the above clause with: + + reifyFlag (NamedTCB Specified) = Just TH.BndrInvis + reifyFlag (NamedTCB Inferred) = Nothing -- Inferred variables can not be bound + +There are two reasons we opt not to do that for now. + 1. It would be a (sometimes silent) breaking change affecting th-abstraction, + aeson, and other libraries that assume that reified binders are visible. + 2. It would create an asymmetry with visible kind applications, which are + not reified either. + +This decision is not set in stone. If a use case for reifying invisible type +variable binders presents itself, we can reconsider. See #22828. +-} + +reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr ()] +reifyTyVars = reifyTyVarBndrs . map mk_bndr + where + mk_bndr tv = Bndr tv () + +reifyTyVarBndrs :: ReifyFlag flag flag' + => [VarBndr TyVar flag] -> TcM [TH.TyVarBndr flag'] +reifyTyVarBndrs = mapM reify_tvbndr + where + -- even if the kind is *, we need to include a kind annotation, + -- in case a poly-kind would be inferred without the annotation. + -- See #8953 or test th/T8953 + reify_tvbndr (Bndr tv fl) = TH.KindedTV (reifyName tv) + (reifyFlag fl) + <$> reifyKind (tyVarKind tv) + +reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr ()]) +reifyTyVarsToMaybe [] = pure Nothing +reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys + +reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type +reify_tc_app tc tys + = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys) + ; maybe_sig_t (mkThAppTs r_tc tys') } + where + arity = tyConArity tc + + r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2) + | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2) + | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2) + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + | isTupleTyCon tc = if isPromotedDataCon tc + then TH.PromotedTupleT arity + else TH.TupleT arity + | tc `hasKey` constraintKindTyConKey + = TH.ConstraintT + | tc `hasKey` unrestrictedFunTyConKey = TH.ArrowT + | tc `hasKey` listTyConKey = TH.ListT + | tc `hasKey` nilDataConKey = TH.PromotedNilT + | tc `hasKey` consDataConKey = TH.PromotedConsT + | tc `hasKey` heqTyConKey = TH.EqualityT + | tc `hasKey` eqPrimTyConKey = TH.EqualityT + | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) + | isDataKindsPromotedDataCon tc = TH.PromotedT (reifyName tc) + | otherwise = TH.ConT (reifyName tc) + + -- See Note [When does a tycon application need an explicit kind + -- signature?] in GHC.Core.TyCo.Rep + maybe_sig_t th_type + | tyConAppNeedsKindSig + False -- We don't reify types using visible kind applications, so + -- don't count specified binders as contributing towards + -- injective positions in the kind of the tycon. + tc (length tys) + = do { let full_kind = typeKind (mkTyConApp tc tys) + ; th_full_kind <- reifyKind full_kind + ; return (TH.SigT th_type th_full_kind) } + | otherwise + = return th_type + +------------------------------ +reifyName :: NamedThing n => n -> TH.Name +reifyName thing + | isExternalName name + = mk_varg pkg_str mod_str occ_str + | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name)) + -- Many of the things we reify have local bindings, and + -- NameL's aren't supposed to appear in binding positions, so + -- we use NameU. When/if we start to reify nested things, that + -- have free variables, we may need to generate NameL's for them. + where + name = getName thing + mod = assert (isExternalName name) $ nameModule name + pkg_str = unitString (moduleUnit mod) + mod_str = moduleNameString (moduleName mod) + occ_str = occNameString occ + occ = nameOccName name + mk_varg | OccName.isDataOcc occ = TH.mkNameG_d + | OccName.isVarOcc occ = TH.mkNameG_v + | OccName.isTcOcc occ = TH.mkNameG_tc + | Just con_fs <- OccName.fieldOcc_maybe occ + = \ pkg mod occ -> TH.mkNameG_fld pkg mod (unpackFS con_fs) occ + | otherwise = pprPanic "reifyName" (ppr name) + +reifyFieldLabel :: FieldLabel -> TH.Name +reifyFieldLabel fl = reifyName $ flSelector fl + +------------------------------ +reifyFixity :: Name -> TcM (Maybe TH.Fixity) +reifyFixity name + = do { (found, fix) <- lookupFixityRn_help name + ; return (if found then Just (conv_fix fix) else Nothing) } + where + conv_fix (Hs.Fixity i d) = TH.Fixity i (conv_dir d) + conv_dir Hs.InfixR = TH.InfixR + conv_dir Hs.InfixL = TH.InfixL + conv_dir Hs.InfixN = TH.InfixN + +reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness +reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness +reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack +reifyUnpackedness SrcUnpack = TH.SourceUnpack + +reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness +reifyStrictness NoSrcStrict = TH.NoSourceStrictness +reifyStrictness SrcStrict = TH.SourceStrict +reifyStrictness SrcLazy = TH.SourceLazy + +reifySourceBang :: DataCon.HsSrcBang + -> (TH.SourceUnpackedness, TH.SourceStrictness) +reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s) + +reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness +reifyDecidedStrictness HsLazy = TH.DecidedLazy +reifyDecidedStrictness (HsStrict _) = TH.DecidedStrict +reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack + +reifyTypeOfThing :: TH.Name -> TcM TH.Type +reifyTypeOfThing th_name = do + thing <- getThing th_name + case thing of + AGlobal (AnId id) -> reifyType (idType id) + AGlobal (ATyCon tc) -> reifyKind (tyConKind tc) + AGlobal (AConLike (RealDataCon dc)) -> + reifyType (idType (dataConWrapId dc)) + AGlobal (AConLike (PatSynCon ps)) -> + reifyPatSynType (patSynSigBndr ps) + ATcId{tct_id = id} -> liftZonkM (zonkTcType (idType id)) >>= reifyType + ATyVar _ tctv -> liftZonkM (zonkTcTyVar tctv) >>= reifyType + -- Impossible cases, supposedly: + AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom" + ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon" + APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr" + +------------------------------ +lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget +lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) +lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) + = return $ ModuleTarget $ + mkModule (stringToUnit $ TH.pkgString pn) (mkModuleName $ TH.modString mn) + +reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] +reifyAnnotations th_name + = do { name <- lookupThAnnLookup th_name + ; topEnv <- getTopEnv + ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing + ; tcg <- getGblEnv + ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name + ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name + ; return (selectedEpsHptAnns ++ selectedTcgAnns) } + +------------------------------ +modToTHMod :: Module -> TH.Module +modToTHMod m = TH.Module (TH.PkgName $ unitString $ moduleUnit m) + (TH.ModName $ moduleNameString $ moduleName m) + +reifyModule :: TH.Module -> TcM TH.ModuleInfo +reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do + this_mod <- getModule + let reifMod = mkModule (stringToUnit pkgString) (mkModuleName mString) + if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod + where + reifyThisModule = do + usages <- fmap (map modToTHMod . Map.keys . imp_mods) getImports + return $ TH.ModuleInfo usages + + reifyFromIface reifMod = do + iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod + let IfaceTopEnv _ imports = mi_top_env iface + -- Convert IfaceImport to module names + usages = [modToTHMod (ifImpModule imp) | imp <- imports] + return $ TH.ModuleInfo usages + + + +------------------------------ +mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type +mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys + +noTH :: UnrepresentableTypeDescr -> Type -> TcM a +noTH s d = failWithTc $ TcRnTHError $ THReifyError $ CannotRepresentType s d + +tcGetInterp :: TcM Interp +tcGetInterp = do + hsc_env <- getTopEnv + case hsc_interp hsc_env of + Nothing -> liftIO $ throwIO (InstallationError "Template haskell requires a target code interpreter") + Just i -> pure i + +-- Note [Bootstrapping Template Haskell] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Staged Metaprogramming as implemented in Template Haskell introduces a whole +-- new dimension of staging to the already staged bootstrapping process. +-- While users depend on the user-facing `template-haskell` library, the TH +-- interface (all wired-in identifiers) is defined in `ghc-internal` and for +-- bootstrapping purposes, re-exported from `ghc-boot-th`. +-- +-- Nomenclature: +-- +-- boot/stage0 compiler: An already released compiler used to compile GHC +-- stage(N+1) compiler: The result of compiling GHC from source with stage(N) +-- Recall that any code compiled by the stage1 compiler should be binary +-- identical to the same code compiled by later stages. +-- boot `ghc-boot-th`: the `ghc-boot-th` that comes with (and is linked to) the +-- boot/stage0 compiler +-- in-tree `ghc-boot-th`: the `ghc-boot-th` library that lives in GHC's repository. +-- +-- Here is how we bootstrap TH in tandem with GHC: +-- +-- 1. Build the stage1 compiler with the boot compiler. +-- The latter comes with its own boot `ghc-boot-th` library, but we do not import it. +-- 2. Instead, the stage1 compiler depends on the in-tree `ghc-boot-th`. +-- * To avoid clashes with the boot `ghc-boot-th`, we change its +-- package-id `ghc-boot-th-next`. +-- * There is a bit of CPP to vendor the stage1 TH AST defined in +-- `ghc-internal`, which we cannot build with the boot compiler. +-- 3. Build `ghc-internal` and in-tree `ghc-boot-th` with the stage1 compiler. +-- From here on `ghc-boot-th` re-exposes the TH modules from `ghc-internal`. +-- 4. Build and link the stage2 compiler against the in-tree `ghc-boot-th`. +-- NB: No dependency on `ghc-boot-th-next`. +-- +-- Observations: +-- +-- A. The vendoring in (2) means that the fully qualified name of the in-tree TH +-- AST will be, e.g., `ghc-boot-th-next:...VarE`, not `ghc-internal:...VarE`. +-- That is OK, because we need it just for the `Binary` instance and to +-- convert TH ASTs returned by splices into the Hs AST, both of which do not +-- depend on the fully qualified name of the type to serialise! Importantly, +-- Note [Hard-wiring in-tree template-haskell for desugaring quotes] is +-- unaffected, because the desugaring refers to names in the in-tree TH +-- library, which is built in the next stage, stage1, and later. +-- +-- When we decided in favour of the current design, `template-haskell` +-- still contained the wired-in Ids that meanwhile were moved to +-- `ghc-internal`. +-- These were the (rejected) alternative designs back then: +-- +-- 1b. Build the in-tree TH with the stage0 compiler and link the stage1 compiler +-- against it. This is what we did until Apr 24 and it is problematic (#23536): +-- * (It rules out using TH in GHC, for example to derive GHC.Core.Map types, +-- because the boot compiler expects the boot TH AST in splices, but, e.g., +-- splice functions in GHC.Core.Map.TH would return the in-tree TH AST. +-- However, at the moment, we are not using TH in GHC anyway.) +-- * Ultimately, we must link the stage1 compiler against a +-- single version of template-haskell. +-- (Beyond the fact that doing otherwise would invite even +-- more "which `template-haskell` is this" confusion, it +-- would also result in confusing linker errors: see for +-- example #21981. In principle we could likely lift this +-- restriction with more aggressive name mangling, but the +-- knock-on effects of doing so are unexplored.) +-- * If the single version is the in-tree TH, we have to recompile all boot +-- libraries (e.g. bytestring, containers) with this new TH version. +-- * But the boot libraries must *not* be built against a non-boot TH version. +-- The reason is Note [Hard-wiring in-tree template-haskell for desugaring quotes]: +-- The boot compiler will desugar quotes wrt. names in the boot TH version. +-- A quote like `[| unsafePackLenLiteral |]` in bytestring will desugar +-- to `varE (mkNameS "unsafePackLenLiteral")`, and all +-- those smart constructors refer to locations in *boot TH*, because that +-- is all that the boot GHC knows about. +-- If the in-tree TH were to move or rename the definition of +-- `mkNameS`, the boot compiler would report a linker error when +-- compiling bytestring. +-- * (Stopping to use quotes in bytestring is no solution, either, because +-- the `Lift` type class is wired-in as well. +-- Only remaining option: provide an entirely TH-less variant of every +-- boot library. That would place a huge burden on maintainers and is +-- thus rejected.) +-- * We have thus made it impossible to refactor in-tree TH. +-- This problem was discussed in #23536. +-- 1c. Do not build the stage1 compiler against any library exposing the in-tree TH AST. +-- This is viable because no splices need to be run as part of the +-- bootstrapping process, so we could CPP away all the code in the stage1 +-- compiler that refers to template-haskell types. However, +-- * it is not so simple either: a surprising example is GHC.Tc.Errors.Types +-- where we would need to replace all TH types with dummy types. +-- (We *cannot* simply CPP away TH-specific error constructors because +-- that affects binary compatibility with the stage2 compiler.) +-- * we would still need to vendor the updated Extension enum, so even +-- though we had to use a lot of CPP, we still end up depending on names +-- that are not present in the stage2 compiler. +-- * this design would never allow us to use TH in GHC's code base, for +-- example in GHC.Core.Map. +-- It seems simpler just to depend on a template-haskell library in a fake +-- namespace. +-- 2b. Alternatively vendor the parts relevant to serialising +-- the (new, in-tree) TH AST into `ghc-boot`, thus shadowing definitions in the +-- implicitly linked boot TH. +-- * We found that this led to quite a bit of duplication in the +-- `ghc-boot` cabal file. + +-- Note [Hard-wiring in-tree template-haskell for desugaring quotes] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- To desugar Template Haskell quotes, GHC needs to wire in a bunch of Names in the +-- `ghc-internal` library as Note [Known-key names], in GHC.Builtin.Names.TH. +-- Consider +-- > foo :: Q Exp +-- > foo = [| unwords ["hello", "world"] |] +-- this desugars to Core that looks like this +-- > varE (mkNameS "unwords") `appE` listE [litE (stringE "hello"), litE (stringE "world")] +-- And all these smart constructors are known-key. +-- NB: Since the constructors are known-key, it is impossible to link this program +-- against another `ghc-internal` library in which, e.g., `varE` was moved into a +-- different module. So effectively, GHC is hard-wired against the in-tree +-- `ghc-internal` library. diff --git a/GHC/Tc/Gen/Splice.hs-boot b/GHC/Tc/Gen/Splice.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Splice.hs-boot @@ -0,0 +1,46 @@ +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Gen.Splice where + +import GHC.Prelude +import GHC.Types.Name +import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) +import GHC.Tc.Types( TcM , SpliceType ) +import GHC.Tc.Utils.TcType ( ExpRhoType ) +import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) +import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc ) + +import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers, HsUntypedSpliceResult, HsTypedSpliceResult, HsTypedSplice ) +import qualified GHC.Boot.TH.Syntax as TH + +tcTypedSplice :: HsTypedSpliceResult + -> HsTypedSplice GhcRn + -> ExpRhoType + -> TcM (HsExpr GhcTc) + +tcTypedBracket :: HsExpr GhcRn + -> LHsExpr GhcRn + -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcUntypedBracket :: HsExpr GhcRn + -> HsQuote GhcRn + -> [PendingRnSplice] + -> ExpRhoType + -> TcM (HsExpr GhcTc) + +runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) + +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation +getUntypedSpliceBody :: HsUntypedSpliceResult (HsExpr GhcRn) -> TcM (HsExpr GhcRn) + +tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) + +runMetaE :: LHsExpr GhcTc -> TcM (LHsExpr GhcPs) +runMetaP :: LHsExpr GhcTc -> TcM (LPat GhcPs) +runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs) +runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] + +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) +runQuasi :: TH.Q a -> TcM a +runRemoteModFinalizers :: ThModFinalizers -> TcM () +finishTH :: TcM () diff --git a/GHC/Tc/Instance/Class.hs b/GHC/Tc/Instance/Class.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Instance/Class.hs @@ -0,0 +1,1324 @@ +{-# LANGUAGE MultiWayIf #-} + +module GHC.Tc.Instance.Class ( + matchGlobalInst, matchEqualityInst, + ClsInstResult(..), + InstanceWhat(..), safeOverlap, instanceReturnsDictCon, + AssocInstInfo(..), isNotAssociated, + lookupHasFieldLabel + ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags + +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Instantiate(instDFunType, tcInstType) +import GHC.Tc.Instance.Typeable +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.CtLoc +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) ) +import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcLookupDataFamInst, FamInstEnvs ) + +import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names +import GHC.Builtin.PrimOps ( PrimOp(..) ) +import GHC.Builtin.PrimOps.Ids ( primOpId ) + +import GHC.Types.FieldLabel +import GHC.Types.SafeHaskell +import GHC.Types.Name ( Name ) +import GHC.Types.Name.Reader +import GHC.Types.Var.Env ( VarEnv ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var + +import GHC.Core.TyCo.Rep +import GHC.Core.Predicate +import GHC.Core.Coercion +import GHC.Core.InstEnv +import GHC.Core.Type +import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams ) +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Core ( Expr(..), mkConApp ) + +import GHC.StgToCmm.Closure ( isSmallFamily ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc( splitAtList, fstOf3 ) +import GHC.Data.FastString + +import GHC.Unit.Module.Warnings + +import GHC.Hs.Extension + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import GHC.Tc.Errors.Types + +import Data.Maybe + +{- ******************************************************************* +* * + A helper for associated types within + class instance declarations +* * +**********************************************************************-} + +-- | Extra information about the parent instance declaration, needed +-- when type-checking associated types. The 'Class' is the enclosing +-- class, the [TyVar] are the /scoped/ type variable of the instance decl. +-- The @VarEnv Type@ maps class variables to their instance types. +data AssocInstInfo + = NotAssociated + | InClsInst { ai_class :: Class + , ai_tyvars :: [TyVar] -- ^ The /scoped/ tyvars of the instance + -- Why scoped? See bind_me in + -- 'GHC.Tc.Validity.checkConsistentFamInst' + , ai_inst_env :: VarEnv Type -- ^ Maps /class/ tyvars to their instance types + -- See Note [Matching in the consistent-instantiation check] + } + +isNotAssociated :: AssocInstInfo -> Bool +isNotAssociated (NotAssociated {}) = True +isNotAssociated (InClsInst {}) = False + + +{- ******************************************************************* +* * + Class lookup +* * +**********************************************************************-} + +data ClsInstResult + = NoInstance -- Definitely no instance + + | OneInst { cir_new_theta :: [TcPredType] + , cir_mk_ev :: [EvExpr] -> EvTerm + , cir_canonical :: CanonicalEvidence + -- cir_canonical=EvCanonical => you can specialise on this instance + -- cir_canonical=EvNonCanonical => you cannot specialise on this instance + -- (its OverlapFlag is NonCanonical) + -- See Note [Coherence and specialisation: overview] + , cir_what :: InstanceWhat } + + | NotSure -- Multiple matches and/or one or more unifiers + +instance Outputable ClsInstResult where + ppr NoInstance = text "NoInstance" + ppr NotSure = text "NotSure" + ppr (OneInst { cir_new_theta = ev + , cir_what = what }) + = text "OneInst" <+> vcat [ppr ev, ppr what] + +safeOverlap :: InstanceWhat -> Bool +safeOverlap (TopLevInstance { iw_safe_over = so }) = so +safeOverlap _ = True + +instanceReturnsDictCon :: InstanceWhat -> Bool +-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet +instanceReturnsDictCon (TopLevInstance {}) = True +instanceReturnsDictCon BuiltinInstance = True +instanceReturnsDictCon BuiltinTypeableInstance {} = True +instanceReturnsDictCon BuiltinEqInstance = False +instanceReturnsDictCon LocalInstance = False + +matchGlobalInst :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> Maybe CtLoc + -> TcM ClsInstResult +-- Precondition: Class does not satisfy GHC.Core.Predicate.isEqualityClass +-- (That is handled by a separate code path: see GHC.Tc.Solver.Dict.solveDict, +-- which calls solveEqualityDict for equality classes.) +matchGlobalInst dflags short_cut clas tys mb_loc + | cls_name == knownNatClassName = matchKnownNat dflags short_cut clas tys + | cls_name == knownSymbolClassName = matchKnownSymbol dflags short_cut clas tys + | cls_name == knownCharClassName = matchKnownChar dflags short_cut clas tys + | isCTupleClass clas = matchCTuple clas tys + | cls_name == typeableClassName = matchTypeable clas tys + | cls_name == withDictClassName = matchWithDict tys + | cls_name == dataToTagClassName = matchDataToTag clas tys + | cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys mb_loc + | cls_name == unsatisfiableClassName = matchUnsatisfiable + | otherwise = matchInstEnv dflags short_cut clas tys + where + cls_name = className clas + +matchUnsatisfiable :: TcM ClsInstResult +-- See (B) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors +matchUnsatisfiable + = return NoInstance + +{- ******************************************************************** +* * + Looking in the instance environment +* * +***********************************************************************-} + + +matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult +matchInstEnv dflags short_cut_solver clas tys + = do { instEnvs <- tcGetInstEnvs + ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy] + (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys + safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps) + ; traceTc "matchInstEnv" $ + vcat [ text "goal:" <+> ppr clas <+> ppr tys + , text "matches:" <+> ppr matches + , text "unify:" <+> ppr unify ] + ; case (matches, unify, safeHaskFail) of + + -- Nothing matches + ([], NoUnifiers{}, _) + -> do { traceTc "matchClass not matching" (ppr pred $$ ppr (ie_local instEnvs)) + ; return NoInstance } + + -- A single match (& no safe haskell failure) + ([(ispec, inst_tys)], NoUnifiers canonical, False) + | short_cut_solver -- Called from the short-cut solver + , isOverlappable ispec + -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT + -- then don't let the short-cut solver choose it, because a + -- later instance might overlap it. #14434 is an example + -- See Note [Shortcut solving: overlap] + -> do { traceTc "matchClass: ignoring overlappable" (ppr pred) + ; return NotSure } + + | otherwise + -> do { let dfun_id = instanceDFunId ispec + warn = instanceWarning ispec + ; traceTc "matchClass success" $ + vcat [text "dict" <+> ppr pred <+> ppr canonical, + text "witness" <+> ppr dfun_id + <+> ppr (idType dfun_id) ] + -- Record that this dfun is needed + ; match_one (null unsafeOverlaps) canonical dfun_id inst_tys warn } + + -- More than one matches (or Safe Haskell fail!). Defer any + -- reactions of a multitude until we learn more about the reagent + _ -> do { traceTc "matchClass multiple matches, deferring choice" $ + vcat [text "dict" <+> ppr pred, + text "matches" <+> ppr matches] + ; return NotSure } } + where + pred = mkClassPred clas tys + +match_one :: SafeOverlapping -> CanonicalEvidence -> DFunId -> [DFunInstType] + -> Maybe (WarningTxt GhcRn) -> TcM ClsInstResult +match_one so canonical dfun_id mb_inst_tys warn + = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys) + ; (tys, theta) <- instDFunType dfun_id mb_inst_tys + ; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta) + ; return $ OneInst { cir_new_theta = theta + , cir_mk_ev = evDFunApp dfun_id tys + , cir_canonical = canonical + , cir_what = TopLevInstance { iw_dfun_id = dfun_id + , iw_safe_over = so + , iw_warn = warn } } } + +{- Note [Shortcut solving: overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + instance {-# OVERLAPPABLE #-} C a where ... +and we are typechecking + f :: C a => a -> a + f = e -- Gives rise to [W] C a + +We don't want to solve the wanted constraint with the overlappable +instance; rather we want to use the supplied (C a)! That was the whole +point of it being overlappable! #14434 wwas an example. + +Alas even if the instance has no overlap flag, thus + instance C a where ... +there is nothing to stop it being overlapped. GHC provides no way to +declare an instance as "final" so it can't be overlapped. But really +only final instances are OK for short-cut solving. Sigh. #15135 +was a puzzling example. +-} + + +{- ******************************************************************** +* * + Class lookup for CTuples +* * +***********************************************************************-} + +matchCTuple :: Class -> [Type] -> TcM ClsInstResult +matchCTuple clas tys -- (isCTupleClass clas) holds + = return (OneInst { cir_new_theta = tys + , cir_mk_ev = evDictApp clas tys + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance }) + -- The dfun *is* the data constructor! + +{- ******************************************************************** +* * + Class lookup for Literals +* * +***********************************************************************-} + +{- +Note [KnownNat & KnownSymbol and EvLit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A part of the type-level literals implementation are the classes +"KnownNat" and "KnownSymbol", which provide a "smart" constructor for +defining singleton values. Here is the key stuff from GHC.TypeNats + + class KnownNat (n :: Nat) where + natSing :: SNat n + + newtype SNat (n :: Nat) = SNat Natural + +Conceptually, this class has infinitely many instances: + + instance KnownNat 0 where natSing = SNat 0 + instance KnownNat 1 where natSing = SNat 1 + instance KnownNat 2 where natSing = SNat 2 + ... + +In practice, we solve `KnownNat` predicates in the type-checker (see +`matchKnownNat` in this module) because we can't have infinitely many +instances. The evidence (aka "dictionary") for `KnownNat` is of the +form `EvLit (EvNum n)`. + +We make the following assumptions about dictionaries in GHC: + 1. The "dictionary" for classes with a single method---like `KnownNat`---is + a newtype for the type of the method, so using a evidence amounts + to a coercion, and + 2. Newtypes use the same representation as their definition types. + +So, the evidence for `KnownNat` is just a value of the representation type, +wrapped in two newtype constructors: one to make it into a `SNat` value, +and another to make it into a `KnownNat` dictionary. + +Also note that `natSing` and `SNat` are never actually exposed from the +library---they are just an implementation detail. Instead, users see +a more convenient function, defined in terms of `natSing`: + + natVal :: KnownNat n => proxy n -> Natural + +The reason we don't use this directly in the class is that it is simpler +and more efficient to pass around a Natural rather than an entire function, +especially when the `KnownNat` evidence is packaged up in an existential. + +The story for kind `Symbol` is analogous: + * class KnownSymbol + * newtype SSymbol + * Evidence: a Core literal (e.g. mkNaturalExpr) + + +Note [Fabricating Evidence for Literals in Backpack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Let `T` be a type of kind `Nat`. When solving for a purported instance +of `KnownNat T`, ghc tries to resolve the type `T` to an integer `n`, +in which case the evidence `EvLit (EvNum n)` is generated on the +fly. It might appear that this is sufficient as users cannot define +their own instances of `KnownNat`. However, for backpack module this +would not work (see issue #15379). Consider the signature `Abstract` + +> signature Abstract where +> data T :: Nat +> instance KnownNat T + +and a module `Util` that depends on it: + +> module Util where +> import Abstract +> printT :: IO () +> printT = do print $ natVal (Proxy :: Proxy T) + +Clearly, we need to "use" the dictionary associated with `KnownNat T` +in the module `Util`, but it is too early for the compiler to produce +a real dictionary as we still have not fixed what `T` is. Only when we +mixin a concrete module + +> module Concrete where +> type T = 42 + +do we really get hold of the underlying integer. So the strategy that +we follow is the following + +1. If T is indeed available as a type alias for an integer constant, + generate the dictionary on the fly, failing which + +2. Look up the type class environment for the evidence. + +Finally actual code gets generate for Util only when a module like +Concrete gets "mixed-in" in place of the signature Abstract. As a +result all things, including the typeclass instances, in Concrete gets +reexported. So `KnownNat` gets resolved the normal way post-Backpack. + +A similar generation works for `KnownSymbol` as well + +-} + +matchKnownNat :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcM ClsInstResult +matchKnownNat dflags _ clas [ty] -- clas = KnownNat + | Just n <- isNumLitTy ty = makeLitDict clas ty (mkNaturalExpr (targetPlatform dflags) n) +matchKnownNat df sc clas tys = matchInstEnv df sc clas tys + -- See Note [Fabricating Evidence for Literals in Backpack] for why + -- this lookup into the instance environment is required. + +matchKnownSymbol :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcM ClsInstResult +matchKnownSymbol _ _ clas [ty] -- clas = KnownSymbol + | Just s <- isStrLitTy ty = do + et <- mkStringExprFS s + makeLitDict clas ty et +matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys + -- See Note [Fabricating Evidence for Literals in Backpack] for why + -- this lookup into the instance environment is required. + +matchKnownChar :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcM ClsInstResult +matchKnownChar _ _ clas [ty] -- clas = KnownChar + | Just s <- isCharLitTy ty = makeLitDict clas ty (mkCharExpr s) +matchKnownChar df sc clas tys = matchInstEnv df sc clas tys + -- See Note [Fabricating Evidence for Literals in Backpack] for why + -- this lookup into the instance environment is required. + +makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult +-- makeLitDict adds a coercion that will convert the literal into a dictionary +-- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit]. +-- The coercion happens in 2 steps: +-- +-- Integer -> SNat n -- representation of literal to singleton +-- SNat n -> KnownNat n -- singleton to dictionary +-- +-- The process is mirrored for Symbols: +-- String -> SSymbol n +-- SSymbol n -> KnownSymbol n +makeLitDict clas lit_ty lit_expr + | [meth] <- classMethods clas + , Just rep_tc <- tyConAppTyCon_maybe (classMethodTy meth) + -- If the method type is forall n. KnownNat n => SNat n + -- then rep_tc :: TyCon is SNat + , [rep_con] <- tyConDataCons rep_tc + = do { let mk_ev _ = evDictApp clas [lit_ty] $ + [mkConApp rep_con [Type lit_ty, lit_expr]] + ; return $ OneInst { cir_new_theta = [] + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance } } + + | otherwise + = pprPanic "makeLitDict" $ + text "Unexpected evidence for" <+> ppr (className clas) + $$ vcat (map (ppr . idType) (classMethods clas)) + + + +{- ******************************************************************** +* * + Class lookup for WithDict +* * +***********************************************************************-} + +-- See Note [withDict] +matchWithDict :: [Type] -> TcM ClsInstResult +matchWithDict [cls_ty, mty] + -- Check that cls_ty 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_ty + -- Check that C is a class of the form + -- `class C a_1 ... a_n where op :: meth_ty` + , Just (cls, dict_dc) <- isUnaryClassTyCon_maybe dict_tc + , [inst_meth_ty] <- dataConInstArgTys dict_dc dict_args + = do { sv <- mkSysLocalM (fsLit "withDict_s") ManyTy mty + ; k <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls_ty openAlphaTy) + ; wd_cls <- tcLookupClass withDictClassName + + -- Given ev_expr : mty ~N# inst_meth_ty, construct the method of + -- the WithDict dictionary: + -- + -- \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) -> + -- k (MkC tys (sv |> sub co2)) + ; let evWithDict ev_expr + = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ + Var k `App` (evUnaryDictAppE cls dict_args meth_arg) + where + meth_arg = Var sv `Cast` mkSubCo (evExprCoercion ev_expr) + + ; let mk_ev [c] = evDictApp wd_cls [cls_ty, mty] [evWithDict c] + mk_ev e = pprPanic "matchWithDict" (ppr e) + + ; return $ OneInst { cir_new_theta = [mkNomEqPred mty (scaledThing inst_meth_ty)] + , cir_mk_ev = mk_ev + , cir_canonical = EvNonCanonical -- See (WD6) in Note [withDict] + , 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 (MkC (sv |> sub co))) + +That is, it matches on the first (constraint) argument of C; if C is +a single-method class, the instance "fires" and emits an equality +constraint `mty ~# inst_meth_ty`, where `inst_meth_ty` is `meth_ty[ti/ai]`. +The coercion `co2` witnesses the equality `mty ~ inst_meth_ty`. + +The coercion `co` is a newtype coercion that coerces from `C t1 ... tn` +to `inst_meth_ty`. +This coercion is guaranteed to exist by virtue of the fact that +C is a class with exactly one method and no superclasses, so it +is treated like a newtype when compiled to Core. + +The condition that `C` is a single-method class is implemented in the +guards of matchWithDict's definition. +If the conditions are not held, the rewriting will not fire, +and we'll report an unsolved constraint. + +Some further observations about `withDict`: + +(WD1) The `cls` in the type of withDict must be explicitly instantiated with + visible type application, as invoking `withDict` would be ambiguous + otherwise. + + For examples of how `withDict` is used in the `base` library, see `withSNat` + in GHC.TypeNats, as well as `withSChar` and `withSSymbol` in GHC.TypeLits. + +(WD2) The `r` is representation-polymorphic, to support things like + `withTypeable` in `Data.Typeable.Internal`. + +(WD3) As an alternative to `withDict`, one could define functions like `withT` + above in terms of `unsafeCoerce`. This is more error-prone, however. + +(WD4) In order to define things like `withKnownNat` below: + + withKnownNat :: SNat n -> (KnownNat n => r) -> r + + `withDict` needs to be instantiated with `Any`, like so: + + withKnownNat = withDict @(KnownNat Any) @(SNat Any) @r + + The use of `Any` is explained in Note [NOINLINE withSomeSNat] in + base:GHC.TypeNats. + +(WD5) In earlier implementations, `withDict` was implemented as an identifier + with special handling during either constant-folding or desugaring. + The current approach is more robust: previously, the type of `withDict` + did not have a type-class constraint and was overly polymorphic. + See #19915. + +(WD6) In fact, we desugar `withDict @cls @mty @{rr} @r` to + + \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) -> + k (sv |> (sub co2 ; sym co))) + + That is, we cast the method using a coercion, and apply k to + it. Moreover, we mark the evidence as non-canonical, resulting in + the use of the 'nospec' magicId (see Note [nospecId magic] in + GHC.Types.Id.Make) to ensure that the typeclass specialiser + doesn't incorrectly common-up distinct evidence terms. This is + super important! Suppose we have calls + + withDict A k + withDict B k + + where k1, k2 :: C T -> blah. If we desugared withDict naively, we'd get + + k (A |> co1) + k (B |> co2) + + and the Specialiser would assume that those arguments (of type `C T`) are + the same. It would then specialise `k` for that type, and then call the same, + specialised function from both call sites. #21575 is a concrete case in point. + + To avoid this, we need to stop the typeclass specialiser from seeing this + structure, by using nospec. This function is inlined only in CorePrep; crucially + this means that it still appears in interface files, so that the desugaring of + withDict remains opaque to the typeclass specialiser across modules. + This means the specialiser will always see instead: + + nospec @(cls => a) k (A |> co1) + nospec @(cls => a) k (B |> co2) + + Why does this work? Recall that nospec is not an overloaded function; + it has the type + + nospec :: forall a. a -> a + + This means that there is nothing for the specialiser to do with function calls + such as + + nospec @(cls => a) k (A |> co) + + as the specialiser only looks at calls of the form `f dict` for an + overloaded function `f` (e.g. with a type such as `f :: Eq a => ...`). + + See test-case T21575b. +-} + + +{- ******************************************************************** +* * + Class lookup for DataToTag +* * +***********************************************************************-} + +matchDataToTag :: Class -> [Type] -> TcM ClsInstResult +-- See Note [DataToTag overview] +matchDataToTag dataToTagClass [levity, dty] = do + famEnvs <- tcGetFamInstEnvs + (gbl_env, _lcl_env) <- getEnvs + platform <- getPlatform + if | isConcreteType levity -- condition C3 + , Just (rawTyCon, rawTyConArgs) <- tcSplitTyConApp_maybe dty + , let (repTyCon, repArgs, repCo) + = tcLookupDataFamInst famEnvs rawTyCon rawTyConArgs + + -- Condition C1 + , Just constrs <- tyConDataCons_maybe repTyCon + , not (isTypeDataTyCon repTyCon || isNewTyCon repTyCon) + + -- Condition C2 + , let rdr_env = tcg_rdr_env gbl_env + inScope con = isJust $ lookupGRE_Name rdr_env $ dataConName con + , all inScope constrs + + , let repTy = mkTyConApp repTyCon repArgs + numConstrs = tyConFamilySize repTyCon + !whichOp -- see wrinkle DTW4 + | isSmallFamily platform numConstrs + = primOpId DataToTagSmallOp + | otherwise + = primOpId DataToTagLargeOp + + -- See wrinkle DTW1; we must apply the underlying + -- operation at the representation type and cast it + methodRep = Var whichOp `App` Type levity `App` Type repTy + methodCo = mkFunCo Representational + FTF_T_T + (mkNomReflCo ManyTy) + (mkSymCo repCo) + (mkReflCo Representational intPrimTy) + -> do { addUsedDataCons rdr_env repTyCon -- See wrinkles DTW2 and DTW3 + ; let mk_ev _ = evDictApp dataToTagClass [levity, dty] $ + [methodRep `Cast` methodCo] + ; pure (OneInst { cir_new_theta = [] -- (Ignore stupid theta.) + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance })} + | otherwise -> pure NoInstance + +matchDataToTag _ _ = pure NoInstance + + +{- Note [DataToTag overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Class `DataToTag` is defined like this, in GHC.Magic: + + type DataToTag :: forall {lev :: Levity}. + TYPE (BoxedRep lev) -> Constraint + class DataToTag a where + dataToTag# :: a -> Int# + +`dataToTag#`, evaluates its argument and returns the index of the data +constructor used to build that argument. Clearly, `dataToTag#` cannot +work on /any/ type, only on data types, hence the type-class constraint. + +Users cannot define instances of `DataToTag` +(see `GHC.Tc.Validity.check_special_inst_head`). +Instead, GHC's constraint solver has built-in solving behaviour, + implemented in `GHC.Tc.Instance.Class.matchGlobalInst`. + +(#20441: This common handling of special typeclasses is a bit of a +mess and could use some love, and a dedicated Note.) + +GHC solves a wanted constraint `DataToTag @{lev} dty` +when all of the following conditions are met: + +C1: `dty` is an algebraic data type, i.e. `dty` matches any of: + * a "data" declaration, + * a "data instance" declaration, + * a boxed tuple type + But NOT + * A "type data" declaration; see also wrinkle W2c + of Note [Type data declarations] in GHC.Rename.Module. + * A newtype; in principle we could accept newtypes that wrap + an algebraic data type, but we do not do so. + +C2: All of the constructors of that "data" or "data instance" + declaration are in scope. Otherwise, `dataToTag#` could be + used to peek behind the curtain when used with an abstract + data type whose constructors are intentionally hidden. + +C3: `lev` is statically known, either Lifted or Unlifted: + Otherwise the argument to `dataToTag#` would be + representation-polymorphic and we couldn't do anything + with it without Core Lint rightfully complaining. + This guarantees invariant (DTT1) below. + +It would be possible for GHC to generate custom code for each type, like +this: + + instance DataToTag [a] where + dataToTag# [] = 0# + dataToTag# (_:_) = 1# + +But, to avoid all this boilerplate code, and improve optimisation opportunities, +GHC generates instances like this: + + instance DataToTag [a] where + dataToTag# = dataToTagSmall# + +using one of two dedicated primops: `dataToTagSmall#` and `dataToTagLarge#`. +(Why two primops? What's the difference? See wrinkles DTW4 and DTW5.) +Both primops have the following over-polymorphic type: + + dataToTagLarge# :: forall {l::levity} (a::TYPE (BoxedRep l)). a -> Int# + +Every call to either primop that we generate should look like +(dataToTagSmall# @{lev} @ty) with two type arguments that satisfy +these conditions: + +(DTT1) `lev` is concrete (either lifted or unlifted), not polymorphic. + This is an invariant--we must satisfy this or Core Lint will complain. + (This falls under situation 1 in GHC.Core.Lint's + Note [Linting representation-polymorphic builtins].) + +(DTT2) `ty` is always headed by a TyCon corresponding to one of the following: + * A boxed tuple + * A "data" declaration (but NOT a "type data" declaration) + * The /representation type/ for a "data instance" declaration + (but NOT the data family TyCon itself) + + This ensures that the DataCons associated with `ty` are easily + accessible and safe to use in Core without running afoul of + invariant I1 from Note [Type data declarations] in + GHC.Rename.Module. See Note [caseRules for dataToTag] in + GHC.Core.Opt.ConstantFold for why this matters. + + While wrinkle DTW7 is unresolved, this cannot be a true invariant. + But with a little effort we can ensure that every primop + call we generate in a DataToTag instance satisfies this condition. + +(DTT3) If the TyCon in wrinkle DTT2 is a "large data type" with more + constructors than fit in pointer tags on the target, then the + primop must be dataToTagLarge# and not dataToTagSmall#. + Otherwise, the primop must be dataToTagSmall# and not dataToTagLarge#. + (See wrinkles DTW4 and DTW5.) + +These two primops have special handling in several parts of +the compiler: + +H1. They have a couple of built-in rewrite rules, implemented in + GHC.Core.Opt.ConstantFold.dataToTagRule + +H2. The simplifier rewrites most case expressions scrutinizing their results. + See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. + +H3. Each evaluates its argument. But we want to omit this eval when the + actual argument is already evaluated and properly tagged. To do this, + + * We have a special case in GHC.Stg.EnforceEpt.Rewrite.rewriteOpApp + ensuring that any inferred tag information on the argument is + retained until code generation. + + * We generate code via special cases in GHC.StgToCmm.Expr.cgExpr + instead of with the other primops in GHC.StgToCmm.Prim.emitPrimOp; + tag info is not readily available in the latter function. + (Wrinkle DTW4 describes what we generate after the eval.) + +Wrinkles: + +(DTW1) To guarantee (DTT2) we need to take care with data families. + Consider data family D a + data instance D (Either p q) = D1 | D2 p q + To solve the constraint + [W] DataToTag (D (Either t1 t2)) + GHC uses the built-in instance + instance DataToTag (D (Either p q)) where + dataToTag# x = dataToTagSmall# @Lifted @(R:DEither p q) + (x |> sym (ax:DEither p q)) + where `ax:DEither` is the axiom arising from the `data instance`: + ax:DEither p q :: D (Either p q) ~ R:DEither p q + + Notice that we cast `x` before giving it to `dataToTagSmall#`, so + that (DTT2) is satisfied. + +(DTW2) Suppose we have module A (T(..)) where { data T = TCon } + and in module B, the constraint `DataToTag T` is needed. Per + condition C2, we only solve this constraint if `TCon` is in + scope. So we had better not later report a warning about the + import of `TCon` being unused in module B! + + To avoid this simply call `addUsedDataCons` when creating a built-in + DataToTag instance. + +(DTW3) Similar to DTW2, consider this example: + + {-# LANGUAGE MagicHash #-} + module A (X(X2, X3), g) where + -- see also testsuite/tests/warnings/should_compile/DataToTagWarnings.hs + import GHC.Exts (dataToTag#, Int#) + data X = X1 | X2 | X3 | X4 + g :: X -> Int# + g X2 = 12# + g v = dataToTag# v + + QUESTION: What warnings should be emitted with -Wunused-top-binds? + + The X1 and X4 constructors are used only in the solving of a + `DataToTag X` constraint in the second equation for `g`. But if + these constructors were just removed, they would not be needed for + the solving of that `DataToTag X` constraint! So for now we take + the stance that both X1 and X4 should be reported as unused. + + It's not entirely clear if this is the right behavior: + Notice that removing X1 changes the value of `g X3` from 2# to 1#. + (Removing X4 causes no observable change in behavior.) + But this is a very obscure program! The current "warn about both" + approach is not obviously wrong, either, and is consistent with the + behavior of derived Ix instances. + + To get these warnings, we do nothing; in particular we do not call + keepAlive on the constructor names. + (Contrast with Note [Unused name reporting and HasField].) + +(DTW4) Why have two primops, `dataToTagSmall#` and `dataToTagLarge#`? + The way tag information is stored at runtime is described in + Note [Tagging big families] in GHC.StgToCmm.Expr. In particular, + for "big data types" we must consult the heap object's info table at + least in the mAX_PTR_TAG case, while for "small data types" we can + always just examine the tag bits on the pointer itself. So: + + * dataToTagSmall# consults the tag bits in the pointer, ignoring the + info table. It should, therefore, be used only for data type with + few enough constructors that the tag always fits in the pointer. + + * dataToTagLarge# also consults the tag bits in the pointer, but + must fall back to examining the info table whenever those tag + bits are equal to mAX_PTR_TAG. + + One could imagine having one primop with a small/large tag, or just + the data type width, but the PrimOp data type is not currently set + up for that. Looking at the type information on the argument during + code generation is also possible, but would be less reliable. + Remember: type information is not always preserved in STG. + +(DTW5) How do the two primops differ in their semantics? We consider + a call `dataToTagSmall# x` to result in undefined behavior whenever + the target supports pointer tagging but the actual constructor index + for `x` is too large to fit in the pointer's tag bits. Otherwise, + `dataToTagSmall#` behaves identically to `dataToTagLarge#`. + + This allows the rewrites performed in GHC.Core.Opt.ConstantFold to + safely treat `dataToTagSmall#` identically to `dataToTagLarge#`: + the allowed program behaviors for the former is always a superset of + the allowed program behaviors for the latter. + + This undefined behavior is only observable if a user writes a + wrongly-sized primop call. The calls we generate are properly-sized + (condition DTT3 above) so that the type system protects us. + +(DTW6) We make no promises about the primops used to implement + DataToTag instances. Changes to GHC's representation of algebraic + data types at runtime may force us to redesign these primops. + Indeed, accommodating such changes without breaking users of the + original (no longer existing) "dataToTag#" primop is one of the + main reasons the DataToTag class exists! + + In particular, our current two primop implementations (as described + in wrinkle DTW4) are adequate for every DataToTag instance only + because every Haskell-land data constructor use gets translated to + its own "real" heap or static data object at runtime and the index + of that constructor is always exposed via pointer tagging and via + the object's info table. + +(DTW7) Currently, the generated module GHC.PrimopWrappers in ghc-prim + contains the following non-sense definitions: + + {-# NOINLINE dataToTagSmall# #-} + dataToTagSmall# :: a_levpoly -> Int# + dataToTagSmall# a1 = GHC.Prim.dataToTagSmall# a1 + {-# NOINLINE dataToTagLarge# #-} + dataToTagLarge# :: a_levpoly -> Int# + dataToTagLarge# a1 = GHC.Prim.dataToTagLarge# a1 + + Why do these exist? GHCi uses these symbols for... something. There + is on-going work to get rid of them. See also #24169, #20155, and !6245. + Their continued existence makes it difficult to do several nice things: + + * As explained in DTW6, the dataToTag# primops are very internal. + We would like to hide them from GHC.Prim entirely to prevent + their mis-use, but doing so would cause GHC.PrimopWrappers to + fail to compile. + + * The primops are applied at the (confusingly monomorphic) type + variable `a_levpoly` in the above definitions. In particular, + they do not satisfy conditions DTT2 and DTT3 above. We would + very much like these conditions to be invariants, but while + GHC.PrimopWrappers breaks them we cannot do so. (The code that + would check these invariants in Core Lint exists but remains + commented out for now.) + + * This in turn means that `GHC.Core.Opt.ConstantFold.caseRules` + must check for condition DTT2 before doing the work described in + Note [caseRules for dataToTag]. + + * Likewise, wrinkle DTW5 is only necessary because condition DTT3 + is not an invariant. Otherwise, invoking the currently-specified + undefined behavior of `dataToTagSmall# @ty` would require passing it + an argument which will not really have type `ty` at runtime. And + evaluating such an expression is always undefined behavior anyway! + + + +Historical note: +During its time as a primop, `dataToTag#` underwent several changes, +mostly relating to under what circumstances it evaluates its argument. +Today, that story is simple: A dataToTag primop always evaluates its +argument, unless tag inference determines the argument was already +evaluated and correctly tagged. Getting here was a long journey, with +many similarities to the story behind Note [Evaluated and Properly Tagged] in +GHC.Stg.EnforceEpt. See also #15696. +-} + +{- ******************************************************************** +* * + Class lookup for Typeable +* * +***********************************************************************-} + +-- | Assumes that we've checked that this is the 'Typeable' class, +-- and it was applied to the correct argument. +matchTypeable :: Class -> [Type] -> TcM ClsInstResult +matchTypeable clas [k,t] -- clas = Typeable + -- Forall types: see Note [No Typeable for polytypes or qualified types] + | isForAllTy k = return NoInstance + + -- Functions; but only with a visible argment + | Just (af,mult,arg,ret) <- splitFunTy_maybe t + = if isVisibleFunArg af + then doFunTy clas t mult arg ret + else return NoInstance + -- 'else' case: qualified types like (Num a => blah) are not typeable + -- see Note [No Typeable for polytypes or qualified types] + + -- Now cases that do work + | k `eqType` naturalTy = doTyLit knownNatClassName t + | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t + | k `eqType` charTy = doTyLit knownCharClassName t + + -- TyCon applied to its kind args + -- No special treatment of Type and Constraint; they get distinct TypeReps + -- see wrinkle (W4) of Note [Type and Constraint are not apart] + -- in GHC.Builtin.Types.Prim. + | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] + , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks + + | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt + +matchTypeable _ _ = return NoInstance + +-- | Representation for a type @ty@ of the form @arg -> ret@. +doFunTy :: Class -> Type -> Mult -> Type -> Type -> TcM ClsInstResult +doFunTy clas ty mult arg_ty ret_ty + = return $ OneInst { cir_new_theta = preds + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance } + where + preds = map (mk_typeable_pred clas) [mult, arg_ty, ret_ty] + mk_ev [mult_ev, arg_ev, ret_ev] + = evTypeable ty $ EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev) + mk_ev _ = panic "GHC.Tc.Instance.Class.doFunTy" + + +-- | Representation for type constructor applied to some kinds. +-- 'onlyNamedBndrsApplied' has ensured that this application results in a type +-- of monomorphic kind (e.g. all kind variables have been instantiated). +doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult +doTyConApp clas ty tc kind_args + | tyConIsTypeable tc + = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) kind_args + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinTypeableInstance tc } + | otherwise + = return NoInstance + where + mk_ev kinds = evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds) + +-- | Representation for TyCon applications of a concrete kind. We just use the +-- kind itself, but first we must make sure that we've instantiated all kind- +-- polymorphism, but no more. +onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool +onlyNamedBndrsApplied tc ks + = all isNamedTyConBinder used_bndrs && + not (any isNamedTyConBinder leftover_bndrs) + where + bndrs = tyConBinders tc + (used_bndrs, leftover_bndrs) = splitAtList ks bndrs + +doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult +-- Representation for an application of a type to a type-or-kind. +-- This may happen when the type expression starts with a type variable. +-- Example (ignoring kind parameter): +-- Typeable (f Int Char) --> +-- (Typeable (f Int), Typeable Char) --> +-- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) +-- Typeable f +doTyApp clas ty f tk + | isForAllTy (typeKind f) + = return NoInstance -- We can't solve until we know the ctr. + | otherwise + = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk] + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance } + where + mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2) + mk_ev _ = panic "doTyApp" + + +-- Emit a `Typeable` constraint for the given type. +mk_typeable_pred :: Class -> Type -> PredType +mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ] + + -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal + -- we generate a sub-goal for the appropriate class. + -- See Note [Typeable for Nat and Symbol] +doTyLit :: Name -> Type -> TcM ClsInstResult +doTyLit kc t = do { kc_clas <- tcLookupClass kc + ; let kc_pred = mkClassPred kc_clas [ t ] + mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev) + mk_ev _ = panic "doTyLit" + ; return (OneInst { cir_new_theta = [kc_pred] + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance }) } + +{- Note [Typeable (T a b c)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For type applications we always decompose using binary application, +via doTyApp (building a TrApp), until we get to a *kind* instantiation +(building a TrTyCon). We detect a pure kind instantiation using +`onlyNamedBndrsApplied`. + +Example: Proxy :: forall k. k -> * + + To solve Typeable (Proxy @(* -> *) Maybe) we + + - First decompose with doTyApp (onlyNamedBndrsApplied is False) + to get (Typeable (Proxy @(* -> *))) and Typeable Maybe. + This step returns a TrApp. + + - Then solve (Typeable (Proxy @(* -> *))) with doTyConApp + (onlyNamedBndrsApplied is True). + This step returns a TrTyCon + + So the TypeRep we build is + TrApp (TrTyCon ("Proxy" @(*->*))) (TrTyCon "Maybe") + +Notice also that TYPE and CONSTRAINT are distinct so, in effect, we +allow (Typeable TYPE) and (Typeable CONSTRAINT), giving disinct TypeReps. +This is very important: we may want to get a TypeRep for a kind like + Type -> Constraint + +If we attempt to short-cut by solving it all at once, via +doTyConApp + +(this note is sadly truncated FIXME) + + +Note [No Typeable for polytypes or qualified types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not support impredicative typeable, such as + Typeable (forall a. a->a) + Typeable (Eq a => a -> a) + Typeable (() => Int) + Typeable (((),()) => Int) + +See #9858. For forall's the case is clear: we simply don't have +a TypeRep for them. For qualified but not polymorphic types, like +(Eq a => a -> a), things are murkier. But: + + * We don't need a TypeRep for these things. TypeReps are for + monotypes only. + + * Perhaps we could treat `=>` as another type constructor for `Typeable` + purposes, and thus support things like `Eq Int => Int`, however, + at the current state of affairs this would be an odd exception as + no other class works with impredicative types. + For now we leave it off, until we have a better story for impredicativity. + + +Note [Typeable for Nat and Symbol] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have special Typeable instances for Nat and Symbol. Roughly we +have this instance, implemented here by doTyLit: + instance KnownNat n => Typeable (n :: Nat) where + typeRep = typeNatTypeRep @n +where + Data.Typeable.Internal.typeNatTypeRep :: KnownNat a => TypeRep a + +Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a +runtime value 'n'; it turns it into a string with 'show' and uses +that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon. +See #10348. + +Because of this rule it's inadvisable (see #15322) to have a constraint + f :: (Typeable (n :: Nat)) => blah +in a function signature; it gives rise to overlap problems just as +if you'd written + f :: Eq [a] => blah +-} + +{- ******************************************************************** +* * + Class lookup for lifted equality +* * +***********************************************************************-} + +-- See also Note [The equality types story] in GHC.Builtin.Types.Prim +matchEqualityInst :: Class -> [Type] -> (Role, Type, Type) +-- Precondition: `cls` satisfies GHC.Core.Predicate.isEqualityClass +-- See Note [Solving equality classes] in GHC.Tc.Solver.Dict +matchEqualityInst cls args + | cls `hasKey` eqTyConKey -- Solves (t1 ~ t2) + , [_,t1,t2] <- args + = (Nominal, t1, t2) + + | cls `hasKey` heqTyConKey -- Solves (t1 ~~ t2) + , [_,_,t1,t2] <- args + = (Nominal, t1, t2) + + | cls `hasKey` coercibleTyConKey -- Solves (Coercible t1 t2) + , [_, t1, t2] <- args + = (Representational, t1, t2) + + | otherwise -- Does not satisfy the precondition + = pprPanic "matchEqualityInst" (ppr (mkClassPred cls args)) + + +{- ******************************************************************** +* * + Class lookup for overloaded record fields +* * +***********************************************************************-} + +{- Note [HasField instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall that the HasField class is defined (in GHC.Records) thus: + + type HasField :: forall {k} {r_rep} {a_rep} . + k -> TYPE r_rep -> TYPE a_rep -> Constraint + class HasField x r a | x r -> a where + getField :: r -> a + +Suppose we have + data T y = MkT { foo :: [y] } +and `foo` is in scope, with type + foo :: forall y. T y -> [y] + +Then `matchHasField` implements the followind built-in magic to solve + [W] d : HasField "foo" (T rty) fty + + * Check that `T` has a field `foo`, and get the selector Id, sel_id + This is done by `lookupHasFieldLabel` + + * Instantiate sel_id's type, giving: T alpha -> [alpha] + + * Generating a new Wanted + [W] co : (T alpha -> [alpha]) ~# (T rty -> fty) + + * Solve the original Wanted via + d = MkHasField (sel_id @alpha |> co) + +Wrinkles: + +(HF1) If `foo` is not in scope, or is "naughty" (has a higher-rank or + existentially quantified type), then the constraint is not solved + automatically, but may be solved by a user-supplied HasField instance. + Similarly, if we encounter a HasField constraint where the field is not a + literal string, or does not belong to the type, then we fall back on the + normal constraint solver behaviour. + + +Note [Unused name reporting and HasField] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a HasField constraint is solved by the type-checker, we must record a use +of the corresponding field name, as otherwise it might be reported as unused. +See #19213. We need to call keepAlive to add the name to the tcg_keep set, +which accumulates names used by the constraint solver, as described by +Note [Tracking unused binding and imports] in GHC.Tc.Types. + +We need to call addUsedGRE as well because there may be a deprecation warning on +the field, which will be reported by addUsedGRE. But calling addUsedGRE without +keepAlive is not enough, because the field might be defined locally, and +addUsedGRE extends tcg_used_gres with imported GREs only. +-} + +-- See Note [HasField instances] +matchHasField :: DynFlags -> Bool -> Class -> [Type] + -> Maybe CtLoc -- Nothing used only during type validity checking + -> TcM ClsInstResult +matchHasField dflags short_cut clas tys mb_ct_loc + = do { fam_inst_envs <- tcGetFamInstEnvs + ; rdr_env <- getGlobalRdrEnv + ; case lookupHasFieldLabel fam_inst_envs rdr_env tys of + Just (sel_name, gre, r_ty, a_ty) -> + do { sel_id <- tcLookupId sel_name + ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id + + -- The first new wanted constraint equates the actual + -- type of the selector with the type (r -> a) within + -- the HasField x r a dictionary. The preds will + -- typically be empty, but if the datatype has a + -- "stupid theta" then we have to include it here. + ; let tvs = mkTyVarTys (map snd tv_prs) + theta = mkNomEqPred sel_ty (mkVisFunTyMany r_ty a_ty) : preds + + -- Use the equality proof to cast the selector Id to + -- type (r -> a), then use evUnaryDictAppE to turn it + -- into a HasField dictionary. + mk_ev (ev1:evs) = EvExpr $ + evUnaryDictAppE clas tys $ + evCastE (evSelector sel_id tvs evs) + (mkSubCo (evExprCoercion ev1)) + mk_ev [] = panic "matchHasField.mk_ev" + + -- The selector must not be "naughty" (i.e. the field + -- cannot have an existentially quantified type), + -- and it must not be higher-rank. + ; if (isNaughtyRecordSelector sel_id) || not (isTauTy sel_ty) + then try_user_instances + else + do { case mb_ct_loc of + Nothing -> return () -- Nothing: happens when type-validity checking + Just loc -> setCtLocM loc $ -- Set location for warnings + do { -- See Note [Unused name reporting and HasField] + addUsedGRE AllDeprecationWarnings gre + ; keepAlive sel_name + + -- Warn about incomplete record selection + ; warnIncompleteRecSel dflags sel_id loc } + + ; return OneInst { cir_new_theta = theta + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance } } } + + Nothing -> try_user_instances } + where + -- See (HF1) in Note [HasField instances] + try_user_instances = matchInstEnv dflags short_cut clas tys + +warnIncompleteRecSel :: DynFlags -> Id -> CtLoc -> TcM () +-- Warn about incomplete record selectors +-- See (IRS6) in Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc +warnIncompleteRecSel dflags sel_id ct_loc + | not (isGetFieldOrigin (ctLocOrigin ct_loc)) + -- isGetFieldOrigin: see (IRS7) in + -- Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc + , RecSelId { sel_cons = RSI { rsi_undef = fallible_cons } } <- idDetails sel_id + , not (null fallible_cons) + = addDiagnostic $ + TcRnHasFieldResolvedIncomplete (idName sel_id) fallible_cons maxCons + + | otherwise + = return () + where + maxCons = maxUncoveredPatterns dflags + + -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin, + -- despite the expansion to (getField @"x" r) + isGetFieldOrigin (GetFieldOrigin {}) = True + isGetFieldOrigin _ = False + +lookupHasFieldLabel + :: FamInstEnvs -> GlobalRdrEnv -> [Type] + -> Maybe ( Name -- Name of the record selector + , GlobalRdrElt -- GRE for the selector + , Type -- Type of the record value + , Type ) -- Type of the field of the record +-- If possible, decompose application +-- (HasField @k @rrep @arep @"fld" @(T t1..tn) @fld-ty), +-- or (getField @k @rrep @arep @"fld" @(T t1..tn) @fld-ty) +-- and return the pieces, if the record selector is in scope +-- +-- A complication is that `T` might be a data family, so we need to +-- look it up in the `fam_envs` to find its representation tycon. +lookupHasFieldLabel fam_inst_envs rdr_env arg_tys + | -- We are matching HasField {k} {r_rep} {a_rep} x r a... + (_k : _rec_rep : _fld_rep : x_ty : rec_ty : fld_ty : _) <- arg_tys + -- x should be a literal string + , Just x <- isStrLitTy x_ty + -- r should be an applied type constructor + , Just (tc, args) <- tcSplitTyConApp_maybe rec_ty + -- Use the representation tycon (if data family); it has the fields + , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args) + -- x should be a field of r + , Just fl <- lookupTyConFieldLabel (FieldLabelString x) r_tc + -- Ensure the field selector is in scope + , Just gre <- lookupGRE_FieldLabel rdr_env fl + = Just (flSelector fl, gre, rec_ty, fld_ty) + + | otherwise + = Nothing diff --git a/GHC/Tc/Instance/Family.hs b/GHC/Tc/Instance/Family.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Instance/Family.hs @@ -0,0 +1,944 @@ +{-# LANGUAGE GADTs, ViewPatterns, LambdaCase #-} + +-- | The @FamInst@ type: family instance heads +module GHC.Tc.Instance.Family ( + FamInstEnvs, tcGetFamInstEnvs, + checkFamInstConsistency, tcExtendLocalFamInstEnv, + tcLookupDataFamInst, tcLookupDataFamInst_maybe, + tcTopNormaliseNewTypeTF_maybe, + + -- * Injectivity + reportInjectivityErrors, reportConflictingInjectivityErrs + ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Driver.Env + +import GHC.Core.FamInstEnv +import GHC.Core.Coercion +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.DataCon ( dataConName ) +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs + +import GHC.Iface.Load + +import GHC.Tc.Errors.Types +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType + +import GHC.Unit.External +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps + +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Var.Set + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.FV + +import GHC.Data.Bag( Bag, unionBags, unitBag ) +import GHC.Data.Maybe + +import Control.Monad +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.Function ( on ) + +import qualified GHC.LanguageExtensions as LangExt +import Data.List (sortOn) +import qualified GHC.Unit.Home.Graph as HUG + +{- Note [The type family instance consistency story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To preserve type safety we must ensure that for any given module, all +the type family instances used either in that module or in any module +it directly or indirectly imports are consistent. For example, consider + + module F where + type family F a + + module A where + import F( F ) + type instance F Int = Bool + f :: F Int -> Bool + f x = x + + module B where + import F( F ) + type instance F Int = Char + g :: Char -> F Int + g x = x + + module Bad where + import A( f ) + import B( g ) + bad :: Char -> Int + bad c = f (g c) + +Even though module Bad never mentions the type family F at all, by +combining the functions f and g that were type checked in contradictory +type family instance environments, the function bad is able to coerce +from one type to another. So when we type check Bad we must verify that +the type family instances defined in module A are consistent with those +defined in module B. + +How do we ensure that we maintain the necessary consistency? + +* Call a module which defines at least one type family instance a + "family instance module". This flag `mi_finsts` is recorded in the + interface file. + +* For every module we calculate the set of all of its direct and + indirect dependencies that are family instance modules. This list + `dep_finsts` is also recorded in the interface file so we can compute + this list for a module from the lists for its direct dependencies. + +* When type checking a module M we check consistency of all the type + family instances that are either provided by its `dep_finsts` or + defined in the module M itself. This is a pairwise check, i.e., for + every pair of instances we must check that they are consistent. + + - For family instances coming from `dep_finsts`, this is checked in + checkFamInstConsistency, called from tcRnImports. See Note + [Checking family instance consistency] for details on this check + (and in particular how we avoid having to do all these checks for + every module we compile). + + - That leaves checking the family instances defined in M itself + against instances defined in either M or its `dep_finsts`. This is + checked in `tcExtendLocalFamInstEnv'. + +There are four subtle points in this scheme which have not been +addressed yet. + +* We have checked consistency of the family instances *defined* by M + or its imports, but this is not by definition the same thing as the + family instances *used* by M or its imports. Specifically, we need to + ensure when we use a type family instance while compiling M that this + instance was really defined from either M or one of its imports, + rather than being an instance that we happened to know about from + reading an interface file in the course of compiling an unrelated + module. Otherwise, we'll end up with no record of the fact that M + depends on this family instance and type safety will be compromised. + See #13102. + +* It can also happen that M uses a function defined in another module + which is not transitively imported by M. Examples include the + desugaring of various overloaded constructs, and references inserted + by Template Haskell splices. If that function's definition makes use + of type family instances which are not checked against those visible + from M, type safety can again be compromised. See #13251. + +* When a module C imports a boot module B.hs-boot, we check that C's + type family instances are compatible with those visible from + B.hs-boot. However, C will eventually be linked against a different + module B.hs, which might define additional type family instances which + are inconsistent with C's. This can also lead to loss of type safety. + See #9562. + +* The call to checkFamConsistency for imported functions occurs very + early (in tcRnImports) and that causes problems if the imported + instances use type declared in the module being compiled. + See Note [Loading your own hi-boot file] in GHC.Iface.Load. +-} + +{- +************************************************************************ +* * + Optimised overlap checking for family instances +* * +************************************************************************ + +Note [Checking family instance consistency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For any two family instance modules that we import directly or indirectly, we +check whether the instances in the two modules are consistent, *unless* we can +be certain that the instances of the two modules have already been checked for +consistency during the compilation of modules that we import. + +Why do we need to check? Consider + module X1 where module X2 where + data T1 data T2 + type instance F T1 b = Int type instance F a T2 = Char + f1 :: F T1 a -> Int f2 :: Char -> F a T2 + f1 x = x f2 x = x + +Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char. +Notice that neither instance is an orphan. + +How do we know which pairs of modules have already been checked? For each +module M we directly import, we look up the family instance modules that M +imports (directly or indirectly), say F1, ..., FN. For any two modules +among M, F1, ..., FN, we know that the family instances defined in those +two modules are consistent--because we checked that when we compiled M. + +For every other pair of family instance modules we import (directly or +indirectly), we check that they are consistent now. (So that we can be +certain that the modules in our `GHC.Driver.Env.dep_finsts' are consistent.) + +Note [Checking family instance optimization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [Checking family instance consistency] +we need to ensure that every pair of transitive imports that define type family +instances is consistent. + +Let's define df(A) = transitive imports of A that define type family instances ++ A, if A defines type family instances + +Then for every direct import A, df(A) is already consistent. + +Let's name the current module M. + +We want to make sure that df(M) is consistent. +df(M) = df(D_1) U df(D_2) U ... U df(D_i) where D_1 .. D_i are direct imports. + +We perform the check iteratively, maintaining a set of consistent modules 'C' +and trying to add df(D_i) to it. + +The key part is how to ensure that the union C U df(D_i) is consistent. + +Let's consider two modules: A and B from C U df(D_i). +There are nine possible ways to choose A and B from C U df(D_i): + + | A in C only | A in C and B in df(D_i) | A in df(D_i) only +-------------------------------------------------------------------------------- +B in C only | Already checked | Already checked | Needs to be checked + | when checking C | when checking C | +-------------------------------------------------------------------------------- +B in C and | Already checked | Already checked | Already checked when +B in df(D_i) | when checking C | when checking C | checking df(D_i) +-------------------------------------------------------------------------------- +B in df(D_i) | Needs to be | Already checked | Already checked when +only | checked | when checking df(D_i) | checking df(D_i) + +That means to ensure that C U df(D_i) is consistent we need to check every +module from C - df(D_i) against every module from df(D_i) - C and +every module from df(D_i) - C against every module from C - df(D_i). +But since the checks are symmetric it suffices to pick A from C - df(D_i) +and B from df(D_i) - C. + +In other words these are the modules we need to check: + [ (m1, m2) | m1 <- C, m1 not in df(D_i) + , m2 <- df(D_i), m2 not in C ] + +One final thing to note here is that if there's lot of overlap between +subsequent df(D_i)'s then we expect those set differences to be small. +That situation should be pretty common in practice, there's usually +a set of utility modules that every module imports directly or indirectly. + +This is basically the idea from #13092, comment:14. + +Note [Order of type family consistency checks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider a module M which imports modules A, B and C, all defining (open) type +family instances. + +We can waste a lot of work in type family consistency checking depending on the +order in which the modules are processed. + +Suppose for example that C imports A and B. When we compiled C, we will have +checked A and B for consistency against eachother. This means that, when +processing the imports of M to check type family instance consistency: + +* if C is processed first, then A and B will not need to be checked for + consistency against eachother again, +* if we process A and B before C,then the + consistency checks between A and B will be performed again. This is wasted + work, as we already performed them for C. + +This can make a significant difference. Keeping the nomenclature of the above +example for illustration, we have observed situations in practice in which the +compilation time of M goes from 1 second (the "processing A and B first" case) +down to 80 milliseconds (the "processing C first" case). + +Clearly we should engineer that C is checked before B and A, but by what scheme? + +A simple one is to observe that if a module M is in the transitive closure of X +then the size of the consistent family set of M is less than or equal to size +of the consistent family set of X. + +Therefore, by sorting the imports by the size of the consistent family set and +processing the largest first, we make sure to process modules in topological +order. + +For a particular project, without this change we did 40 million checks and with +this change we did 22.9 million checks. This is significant as before this change +type family consistency checks accounted for 26% of total type checker allocations which +was reduced to 15%. + +See tickets #25554 for discussion about this exact issue and #25555 for +why we still do redundant checks. + +-} + +-- We don't need to check the current module, this is done in +-- tcExtendLocalFamInstEnv. +-- See Note [The type family instance consistency story]. +checkFamInstConsistency :: [Module] -> TcM () +checkFamInstConsistency directlyImpMods + = do { (eps, hug) <- getEpsAndHug + ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) + ; let { -- Fetch the iface of a given module. Must succeed as + -- all directly imported modules must already have been loaded. + modIface mod = liftIO $ + lookupIfaceByModule hug (eps_PIT eps) mod >>= \case + Nothing -> panicDoc "FamInst.checkFamInstConsistency" + (ppr mod $$ ppr (HUG.allUnits hug)) + Just iface -> pure iface + + -- Which family instance modules were checked for consistency + -- when we compiled `mod`? + -- Itself (if a family instance module) and its dep_finsts. + -- This is df(D_i) from + -- Note [Checking family instance optimization] + ; modConsistent :: Module -> TcM [Module] + ; modConsistent mod = do + ifc <- modIface mod + deps <- dep_finsts . mi_deps <$> modIface mod + pure $ + if mi_finsts ifc + then mod:deps + else deps + + + -- Sorting the list by size has the effect of performing a topological sort. + -- See Note [Order of type family consistency checks] + } + + ; hpt_fam_insts <- liftIO $ HUG.allFamInstances hug + ; debug_consistent_set <- mapM (\x -> (\y -> (x, length y)) <$> modConsistent x) directlyImpMods + ; traceTc "init_consistent_set" (ppr debug_consistent_set) + ; let init_consistent_set = map fst (reverse (sortOn snd debug_consistent_set)) + ; checkMany hpt_fam_insts modConsistent init_consistent_set + + } + where + -- See Note [Checking family instance optimization] + checkMany + :: ModuleEnv FamInstEnv -- home package family instances + -> (Module -> TcM [Module]) -- given A, modules checked when A was checked + -> [Module] -- modules to process + -> TcM () + checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods + where + go :: [Module] -- list of consistent modules + -> ModuleSet -- set of consistent modules, same elements as the + -- list above + -> [Module] -- modules to process + -> TcM () + go _ _ [] = return () + go consistent consistent_set (mod:mods) = do + mod_deps_consistent <- modConsistent mod + let + mod_deps_consistent_set = mkModuleSet mod_deps_consistent + consistent' = to_check_from_mod ++ consistent + consistent_set' = + extendModuleSetList consistent_set to_check_from_mod + to_check_from_consistent = + filterOut (`elemModuleSet` mod_deps_consistent_set) consistent + to_check_from_mod = + filterOut (`elemModuleSet` consistent_set) mod_deps_consistent + -- Why don't we just minusModuleSet here (above)? + -- We could, but doing so means one of two things: + -- + -- 1. When looping over the cartesian product we convert + -- a set into a non-deterministically ordered list. Which + -- happens to be fine for interface file determinism + -- in this case, today, because the order only + -- determines the order of deferred checks. But such + -- invariants are hard to keep. + -- + -- 2. When looping over the cartesian product we convert + -- a set into a deterministically ordered list - this + -- adds some additional cost of sorting for every + -- direct import. + -- + -- That also explains why we need to keep both 'consistent' + -- and 'consistentSet'. + -- + -- See also Note [ModuleEnv performance and determinism]. + + traceTc "checkManySize" (vcat [text "mod:" <+> ppr mod + , text "m1:" <+> ppr (length to_check_from_mod) + , text "m2:" <+> ppr (length (to_check_from_consistent)) + , text "product:" <+> ppr (length to_check_from_mod * length to_check_from_consistent) + ]) + sequence_ + [ check hpt_fam_insts m1 m2 + | m1 <- to_check_from_mod + -- loop over toCheckFromMod first, it's usually smaller, + -- it may even be empty + , m2 <- to_check_from_consistent + ] + go consistent' consistent_set' mods + check hpt_fam_insts m1 m2 + = do { env1' <- getFamInsts hpt_fam_insts m1 + ; env2' <- getFamInsts hpt_fam_insts m2 + -- We're checking each element of env1 against env2. + -- The cost of that is dominated by the size of env1, because + -- for each instance in env1 we look it up in the type family + -- environment env2, and lookup is cheap. + -- The code below ensures that env1 is the smaller environment. + ; let sizeE1 = famInstEnvSize env1' + sizeE2 = famInstEnvSize env2' + (env1, env2) = if sizeE1 < sizeE2 then (env1', env2') + else (env2', env1') + + ; let check_now = famInstEnvElts env1 + ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) check_now + ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now + } + +getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv +getFamInsts hpt_fam_insts mod + | Just env <- lookupModuleEnv hpt_fam_insts mod = return env + | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod) + ; eps <- getEps + ; return (expectJust $ + lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } + where + doc = ppr mod <+> text "is a family-instance module" + +{- +************************************************************************ +* * + Lookup +* * +************************************************************************ + +-} + +-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if +-- there is no data family to unwrap. +-- Returns a Representational coercion +tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType] + -> (TyCon, [TcType], Coercion) +tcLookupDataFamInst fam_inst_envs tc tc_args + | Just (rep_tc, rep_args, co) + <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args + = (rep_tc, rep_args, co) + | otherwise + = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args)) + +tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType] + -> Maybe (TyCon, [TcType], Coercion) +-- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a) +-- and returns a coercion between the two: co :: F [a] ~R FList a. +tcLookupDataFamInst_maybe fam_inst_envs tc tc_args + | isDataFamilyTyCon tc + , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args + , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax + , fi_cvs = cvs }) + , fim_tys = rep_args + , fim_cos = rep_cos } <- match + , let rep_tc = dataFamInstRepTyCon rep_fam + co = mkUnbranchedAxInstCo Representational ax rep_args + (mkCoVarCos cvs) + = assert (null rep_cos) $ -- See Note [Constrained family instances] in ??? (renamed?) + Just (rep_tc, rep_args, co) + + | otherwise + = Nothing + +-- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes, +-- potentially looking through newtype /instances/ and type synonyms. +-- +-- It is only used by the type inference engine (specifically, when +-- solving representational equality), and hence it is careful to unwrap +-- only if the relevant data constructor is in scope. That's why +-- it gets a GlobalRdrEnv argument. +-- +-- It is careful not to unwrap data/newtype instances nor synonyms +-- if it can't continue unwrapping. Such care is necessary for proper +-- error messages. +-- +-- It does not look through type families. +-- It does not normalise arguments to a tycon. +-- +-- If the result is Just ((gres, co), rep_ty), then +-- co : ty ~R rep_ty +-- gres are the GREs for the data constructors that +-- had to be in scope +tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs + -> GlobalRdrEnv + -> Type + -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type) +tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty +-- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe + = topNormaliseTypeX stepper plus ty + where + plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion) + -> (Bag GlobalRdrElt, TcCoercion) + plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2 + , co1 `mkTransCo` co2 ) + + stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion) + stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance + + -- For newtype instances we take a double step or nothing, so that + -- we don't return the representation type of the newtype instance, + -- which would lead to terrible error messages + unwrap_newtype_instance rec_nts tc tys + | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys + = fmap (mkTransCo co) <$> unwrap_newtype rec_nts tc' tys' + | otherwise = NS_Done + + unwrap_newtype rec_nts tc tys + | Just con <- newTyConDataCon_maybe tc + , Just gre <- lookupGRE_Name rdr_env (dataConName con) + -- This is where we check that the + -- data constructor is in scope + = (,) (unitBag gre) <$> unwrapNewTypeStepper rec_nts tc tys + + | otherwise + = NS_Done + +{- +************************************************************************ +* * + Extending the family instance environment +* * +************************************************************************ +-} + +-- Add new locally-defined family instances, checking consistency with +-- previous locally-defined family instances as well as all instances +-- available from imported modules. This requires loading all of our +-- imports that define family instances (if we haven't loaded them already). +tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a + +-- If we weren't actually given any instances to add, then we don't want +-- to go to the bother of loading family instance module dependencies. +tcExtendLocalFamInstEnv [] thing_inside = thing_inside + +-- Otherwise proceed... +tcExtendLocalFamInstEnv fam_insts thing_inside + = do { -- Load family-instance modules "below" this module, so that + -- allLocalFamInst can check for consistency with them + -- See Note [The type family instance consistency story] + loadDependentFamInstModules fam_insts + + -- Now add the instances one by one + ; env <- getGblEnv + ; (inst_env', fam_insts') <- foldlM addLocalFamInst + (tcg_fam_inst_env env, tcg_fam_insts env) + fam_insts + + ; let env' = env { tcg_fam_insts = fam_insts' + , tcg_fam_inst_env = inst_env' } + ; setGblEnv env' thing_inside + } + +loadDependentFamInstModules :: [FamInst] -> TcM () +-- Load family-instance modules "below" this module, so that +-- allLocalFamInst can check for consistency with them +-- See Note [The type family instance consistency story] +loadDependentFamInstModules fam_insts + = do { env <- getGblEnv + ; let this_mod = tcg_mod env + imports = tcg_imports env + + want_module mod -- See Note [Home package family instances] + | mod == this_mod = False + | home_fams_only = moduleUnit mod == moduleUnit this_mod + | otherwise = True + home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts + + ; loadModuleInterfaces (text "Loading family-instance modules") $ + filter want_module (imp_finsts imports) } + +{- Note [Home package family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Optimization: If we're only defining type family instances +for type families *defined in the home package*, then we +only have to load interface files that belong to the home +package. The reason is that there's no recursion between +packages, so modules in other packages can't possibly define +instances for our type families. + +(Within the home package, we could import a module M that +imports us via an hs-boot file, and thereby defines an +instance of a type family defined in this module. So we can't +apply the same logic to avoid reading any interface files at +all, when we define an instances for type family defined in +the current module. +-} + +-- Check that the proposed new instance is OK, +-- and then add it to the home inst env +-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] +-- in GHC.Core.FamInstEnv +addLocalFamInst :: (FamInstEnv,[FamInst]) + -> FamInst + -> TcM (FamInstEnv, [FamInst]) +addLocalFamInst (home_fie, my_fis) fam_inst + -- home_fie includes home package and this module + -- my_fies is just the ones from this module + = do { traceTc "addLocalFamInst" (ppr fam_inst) + + -- Unlike the case of class instances, don't override existing + -- instances in GHCi; it's unsound. See #7102. + + ; mod <- getModule + ; traceTc "alfi" (ppr mod) + + -- Fetch imported instances, so that we report + -- overlaps correctly. + -- Really we ought to only check consistency with + -- those instances which are transitively imported + -- by the current module, rather than every instance + -- we've ever seen. Fixing this is part of #13102. + ; eps <- getEps + ; let inst_envs = (eps_fam_inst_env eps, home_fie) + home_fie' = extendFamInstEnv home_fie fam_inst + + -- Check for conflicting instance decls and injectivity violations + ; ((), no_errs) <- askNoErrs $ + do { checkForConflicts inst_envs fam_inst + ; checkForInjectivityConflicts inst_envs fam_inst + ; checkInjectiveEquation fam_inst + } + + ; if no_errs then + return (home_fie', fam_inst : my_fis) + else + return (home_fie, my_fis) } + +{- +************************************************************************ +* * + Checking an instance against conflicts with an instance env +* * +************************************************************************ + +Check whether a single family instance conflicts with those in two instance +environments (one for the EPS and one for the HPT). +-} + +-- | Checks to make sure no two family instances overlap. +checkForConflicts :: FamInstEnvs -> FamInst -> TcM () +checkForConflicts inst_envs fam_inst + = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst + ; traceTc "checkForConflicts" $ + vcat [ ppr conflicts + , ppr fam_inst + -- , ppr inst_envs + ] + ; reportConflictInstErr fam_inst conflicts } + +checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM () + -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv, check 1B1. +checkForInjectivityConflicts instEnvs famInst + | isTypeFamilyTyCon tycon -- as opposed to data family tycon + , Injective inj <- tyConInjectivityInfo tycon + = let conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst in + reportConflictingInjectivityErrs tycon conflicts (coAxiomSingleBranch (fi_axiom famInst)) + + | otherwise + = return () + + where tycon = famInstTyCon famInst + +-- | Check whether a new open type family equation can be added without +-- violating injectivity annotation supplied by the user. Returns True when +-- this is possible and False if adding this equation would violate injectivity +-- annotation. This looks only at the one equation; it does not look for +-- interaction between equations. Use checkForInjectivityConflicts for that. +-- Does checks (2)-(4) of Note [Verifying injectivity annotation] in "GHC.Core.FamInstEnv". +checkInjectiveEquation :: FamInst -> TcM () +checkInjectiveEquation famInst + | isTypeFamilyTyCon tycon + -- type family is injective in at least one argument + , Injective inj <- tyConInjectivityInfo tycon = do + { dflags <- getDynFlags + ; let axiom = coAxiomSingleBranch fi_ax + -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv + ; reportInjectivityErrors dflags fi_ax axiom inj + } + + -- if there was no injectivity annotation or tycon does not represent a + -- type family we report no conflicts + | otherwise + = return () + + where tycon = famInstTyCon famInst + fi_ax = fi_axiom famInst + +-- | Report a list of injectivity errors together with their source locations. +-- Looks only at one equation; does not look for conflicts *among* equations. +reportInjectivityErrors + :: DynFlags + -> CoAxiom br -- ^ Type family for which we generate errors + -> CoAxBranch -- ^ Currently checked equation (represented by axiom) + -> [Bool] -- ^ Injectivity annotation + -> TcM () +reportInjectivityErrors dflags fi_ax axiom inj + = assertPpr (any id inj) (text "No injective type variables") $ + do let lhs = coAxBranchLHS axiom + rhs = coAxBranchRHS axiom + fam_tc = coAxiomTyCon fi_ax + (unused_inj_tvs, unused_vis, undec_inst_flag) + = unusedInjTvsInRHS dflags fam_tc lhs rhs + inj_tvs_unused = not $ isEmptyVarSet unused_inj_tvs + tf_headed = isTFHeaded rhs + bare_variables = bareTvInRHSViolated lhs rhs + wrong_bare_rhs = not $ null bare_variables + + when inj_tvs_unused $ reportUnusedInjectiveVarsErr fam_tc unused_inj_tvs + unused_vis undec_inst_flag axiom + when tf_headed $ reportTfHeadedErr fam_tc axiom + when wrong_bare_rhs $ reportBareVariableInRHSErr fam_tc bare_variables axiom + +-- | Is type headed by a type family application? +isTFHeaded :: Type -> Bool +-- See Note [Verifying injectivity annotation], case 3. +isTFHeaded ty | Just ty' <- coreView ty + = isTFHeaded ty' +isTFHeaded ty | (TyConApp tc args) <- ty + , isTypeFamilyTyCon tc + = args `lengthIs` tyConArity tc +isTFHeaded _ = False + + +-- | If a RHS is a bare type variable return a set of LHS patterns that are not +-- bare type variables. +bareTvInRHSViolated :: [Type] -> Type -> [Type] +-- See Note [Verifying injectivity annotation], case 2. +bareTvInRHSViolated pats rhs | isTyVarTy rhs + = filter (not . isTyVarTy) pats +bareTvInRHSViolated _ _ = [] + +------------------------------------------------------------------ +-- Checking for the coverage condition for injective type families +------------------------------------------------------------------ + +{- +Note [Coverage condition for injective type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Injective Type Families paper describes how we can tell whether +or not a type family equation upholds the injectivity condition. +Briefly, consider the following: + + type family F a b = r | r -> a -- NB: b is not injective + + type instance F ty1 ty2 = ty3 + +We need to make sure that all variables mentioned in ty1 are mentioned in ty3 +-- that's how we know that knowing ty3 determines ty1. But they can't be +mentioned just anywhere in ty3: they must be in *injective* positions in ty3. +For example: + + type instance F a Int = Maybe (G a) + +This is no good, if G is not injective. However, if G is indeed injective, +then this would appear to meet our needs. There is a trap here, though: while +knowing G a does indeed determine a, trying to compute a from G a might not +terminate. This is precisely the same problem that we have with functional +dependencies and their liberal coverage condition. Here is the test case: + + type family G a = r | r -> a + type instance G [a] = [G a] + [W] G alpha ~ [alpha] + +We see that the equation given applies, because G alpha equals a list. So we +learn that alpha must be [beta] for some beta. We then have + + [W] G [beta] ~ [[beta]] + +This can reduce to + + [W] [G beta] ~ [[beta]] + +which then decomposes to + + [W] G beta ~ [beta] + +right where we started. The equation G [a] = [G a] thus is dangerous: while +it does not violate the injectivity assumption, it might throw us into a loop, +with a particularly dastardly Wanted. + +We thus do what functional dependencies do: require -XUndecidableInstances to +accept this. + +Checking the coverage condition is not terribly hard, but we also want to produce +a nice error message. A nice error message has at least two properties: + +1. If any of the variables involved are invisible or are used in an invisible context, +we want to print invisible arguments (as -fprint-explicit-kinds does). + +2. If we fail to accept the equation because we're worried about non-termination, +we want to suggest UndecidableInstances. + +To gather the right information, we can talk about the *usage* of a variable. Every +variable is used either visibly or invisibly, and it is either not used at all, +in a context where acceptance requires UndecidableInstances, or in a context that +does not require UndecidableInstances. If a variable is used both visibly and +invisibly, then we want to remember the fact that it was used invisibly: printing +out invisibles will be helpful for the user to understand what is going on. +If a variable is used where we need -XUndecidableInstances and where we don't, +we can similarly just remember the latter. + +We thus define Visibility and NeedsUndecInstFlag below. These enumerations are +*ordered*, and we used their Ord instances. We then define VarUsage, which is just a pair +of a Visibility and a NeedsUndecInstFlag. (The visibility is irrelevant when a +variable is NotPresent, but this extra slack in the representation causes no +harm.) We finally define VarUsages as a mapping from variables to VarUsage. +Its Monoid instance combines two maps, using the Semigroup instance of VarUsage +to combine elements that are represented in both maps. In this way, we can +compositionally analyze types (and portions thereof). + +To do the injectivity check: + +1. We build VarUsages that represent the LHS (rather, the portion of the LHS +that is flagged as injective); each usage on the LHS is NotPresent, because we +have not yet looked at the RHS. + +2. We also build a VarUsage for the RHS, done by injTyVarUsages. + +3. We then combine these maps. Now, every variable in the injective components of the LHS +will be mapped to its correct usage (either NotPresent or perhaps needing +-XUndecidableInstances in order to be seen as injective). + +4. We look up each var used in an injective argument on the LHS in +the map, making a list of tvs that should be determined by the RHS +but aren't. + +5. We then return the set of bad variables, whether any of the bad +ones were used invisibly, and whether any bad ones need -XUndecidableInstances. +If -XUndecidableInstances is enabled, than a var that needs the flag +won't be bad, so it won't appear in this list. + +6. We use all this information to produce a nice error message, (a) switching +on -fprint-explicit-kinds if appropriate and (b) telling the user about +-XUndecidableInstances if appropriate. + +-} + +-- | Return the set of type variables that a type family equation is +-- expected to be injective in but is not. Suppose we have @type family +-- F a b = r | r -> a@. Then any variables that appear free in the first +-- argument to F in an equation must be fixed by that equation's RHS. +-- This function returns all such variables that are not indeed fixed. +-- It also returns whether any of these variables appear invisibly +-- and whether -XUndecidableInstances would help. +-- See Note [Coverage condition for injective type families]. +unusedInjTvsInRHS :: DynFlags + -> TyCon -- type family + -> [Type] -- LHS arguments + -> Type -- the RHS + -> ( TyVarSet + , HasKinds -- YesHasKinds <=> one or more variable is used invisibly + , SuggestUndecidableInstances) -- YesSuggestUndecidableInstaces <=> suggest -XUndecidableInstances +-- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. +-- This function implements check (4) described there, further +-- described in Note [Coverage condition for injective type families]. +-- In theory (and modulo the -XUndecidableInstances wrinkle), +-- instead of implementing this whole check in this way, we could +-- attempt to unify equation with itself. We would reject exactly the same +-- equations but this method gives us more precise error messages by returning +-- precise names of variables that are not mentioned in the RHS. +unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs = + -- Note [Coverage condition for injective type families], step 5 + (bad_vars, hasKinds any_invisible, suggestUndecidableInstances suggest_undec) + where + undec_inst = xopt LangExt.UndecidableInstances dflags + + inj_lhs = filterByList inj_list lhs + lhs_vars = tyCoVarsOfTypes inj_lhs + + rhs_inj_vars = fvVarSet $ injectiveVarsOfType undec_inst rhs + + bad_vars = lhs_vars `minusVarSet` rhs_inj_vars + + any_bad = not $ isEmptyVarSet bad_vars + + invis_vars = fvVarSet $ invisibleVarsOfTypes [mkTyConApp tycon lhs, rhs] + + any_invisible = any_bad && (bad_vars `intersectsVarSet` invis_vars) + suggest_undec = any_bad && + not undec_inst && + (lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs)) + +-- When the type family is not injective in any arguments +unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, NoHasKinds, NoSuggestUndecidableInstaces) + +--------------------------------------- +-- Producing injectivity error messages +--------------------------------------- + +-- | Report error message for a pair of equations violating an injectivity +-- annotation. No error message if there are no branches. +reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM () +reportConflictingInjectivityErrs _ [] _ = return () +reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn + = addErrs [buildInjectivityError (TcRnFamInstNotInjective InjErrRhsOverlap) + fam_tc + (confEqn1 :| [tyfamEqn])] + +-- | Report error message for equation with injective type variables unused in +-- the RHS. Note [Coverage condition for injective type families], step 6 +reportUnusedInjectiveVarsErr :: TyCon + -> TyVarSet + -> HasKinds -- YesHasKinds <=> print invisible arguments + -> SuggestUndecidableInstances -- YesSuggestUndecidableInstaces <=> suggest -XUndecidableInstances + -> CoAxBranch + -> TcM () +reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn + = let reason = InjErrCannotInferFromRhs tvs has_kinds undec_inst + (loc, dia) = buildInjectivityError (TcRnFamInstNotInjective reason) fam_tc (tyfamEqn :| []) + in addErrAt loc dia + +-- | Report error message for equation that has a type family call at the top +-- level of RHS +reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM () +reportTfHeadedErr fam_tc branch + = addErrs [buildInjectivityError (TcRnFamInstNotInjective InjErrRhsCannotBeATypeFam) + fam_tc + (branch :| [])] + +-- | Report error message for equation that has a bare type variable in the RHS +-- but LHS pattern is not a bare type variable. +reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM () +reportBareVariableInRHSErr fam_tc tys branch + = addErrs [buildInjectivityError (TcRnFamInstNotInjective (InjErrRhsBareTyVar tys)) + fam_tc + (branch :| [])] + +buildInjectivityError :: (TyCon -> NonEmpty CoAxBranch -> TcRnMessage) + -> TyCon + -> NonEmpty CoAxBranch + -> (SrcSpan, TcRnMessage) +buildInjectivityError mkErr fam_tc branches + = ( coAxBranchSpan (NE.head branches), mkErr fam_tc branches ) + +reportConflictInstErr :: FamInst -> [FamInst] -> TcRn () +reportConflictInstErr _ [] + = return () -- No conflicts +reportConflictInstErr fam_inst (conf_inst : _) = + -- The sortBy just arranges that instances are displayed in order + -- of source location, which reduced wobbling in error messages, + -- and is better for users + let sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst]) + fi1 = NE.head sorted + span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) + getSpan = getSrcSpan . famInstAxiom + in setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted + +tcGetFamInstEnvs :: TcM FamInstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +tcGetFamInstEnvs + = do { eps <- getEps; env <- getGblEnv + ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } diff --git a/GHC/Tc/Instance/FunDeps.hs b/GHC/Tc/Instance/FunDeps.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Instance/FunDeps.hs @@ -0,0 +1,702 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 2000 + + +-} + +{-# LANGUAGE DeriveFunctor #-} + +-- | Functional dependencies +-- +-- It's better to read it as: "if we know these, then we're going to know these" +module GHC.Tc.Instance.FunDeps + ( FunDepEqn(..) + , pprEquation + , improveFromInstEnv + , improveFromAnother + , checkInstCoverage + , checkFunDeps + , pprFundeps + , instFD, closeWrtFunDeps + ) +where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Core.Class +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.RoughMap( RoughMatchTc(..) ) +import GHC.Core.Coercion.Axiom( TypeEqn ) +import GHC.Core.Unify +import GHC.Core.InstEnv +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Compare( eqTypes, eqType ) + +import GHC.Tc.Errors.Types ( CoverageProblem(..), FailedCoverageCondition(..) ) +import GHC.Tc.Types.Constraint ( isUnsatisfiableCt_maybe ) +import GHC.Tc.Utils.TcType( transSuperClasses ) + +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Utils.Outputable +import GHC.Utils.FV +import GHC.Utils.Error( Validity'(..), allValid ) +import GHC.Utils.Misc +import GHC.Utils.Panic + +import GHC.Data.Pair ( Pair(..) ) +import Data.List ( nubBy ) +import Data.Maybe ( isJust, isNothing ) + +{- +************************************************************************ +* * +\subsection{Generate equations from functional dependencies} +* * +************************************************************************ + +Each functional dependency with one variable in the RHS is responsible +for generating a single equality. For instance: + class C a b | a -> b +The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha +will generate the following FunDepEqn + FDEqn { fd_qtvs = [] + , fd_eqs = [Pair Bool alpha] + , fd_loc = ... } +However notice that a functional dependency may have more than one variable +in the RHS which will create more than one pair of types in fd_eqs. Example: + class C a b c | a -> b c + [Wanted] C Int alpha alpha + [Wanted] C Int Bool beta +Will generate: + FDEqn { fd_qtvs = [] + , fd_eqs = [Pair Bool alpha, Pair alpha beta] + , fd_loc = ... } + +INVARIANT: Corresponding types aren't already equal +That is, there exists at least one non-identity equality in FDEqs. + +Note [Improving against instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Assume: + class C a b | a -> b + instance C Int Bool + [W] C Int ty + +Then `improveFromInstEnv` should return a FDEqn with + FDEqn { fd_qtvs = [], fd_eqs = [Pair Bool ty] } + +describing an equality (Bool ~ ty). To do this we /match/ the instance head +against the [W], using just the LHS of the fundep; if we match, we return +an equality for the RHS. + +Wrinkles: + +(1) meta_tvs: sometimes the instance mentions variables in the RHS that + are not bound in the LHS. For example + + class C a b | a -> b + instance C Int (Maybe x) + [W] C Int ty + + Note that although the `Int` parts match, that does not fix what `x` is. + So we just make up a fresh unification variable (a meta_tv), to give the + "shape" of the RHS. So we emit the FDEqun + FDEqn { fd_qtvs = [x], fd_eqs = [Pair (Maybe x) ty] } + + Note that the fd_qtvs can be free in the /first/ component of the Pair, + but not in the second (which comes from the [W] constraint). + +(2) Multi-range fundeps. When these meta_tvs are involved, there is a subtle + difference between the fundep (a -> b c) and the two fundeps (a->b, a->c). + Consider + class D a b c | a -> b c + instance D Int x (Maybe x) + [W] D Int Bool ty + + Then we'll generate + FDEqn { fd_qtvs = [x0], fd_eqs = [ x0 ~ Bool, Maybe x0 ~ ty] } + which generates one fresh unification variable x0 + + But if the fundeps had been (a->b, a->c) we'd generate two FDEqns + FDEqn { fd_qtvs = [x1], fd_eqs = [ x1 ~ Bool ] } + FDEqn { fd_qtvs = [x2], fd_eqs = [ Maybe x2 ~ ty ] } + with two FDEqns, generating two separate unification variables. + +(3) improveFromInstEnv doesn't return any equations that already hold. + Reason: then we know if any actual improvement has happened, in + which case we need to iterate the solver +-} + +data FunDepEqn loc + = FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars + -- to fresh unification vars, + -- Non-empty only for FunDepEqns arising from instance decls + + , fd_eqs :: [TypeEqn] -- Make these pairs of types equal + -- Invariant: In each (Pair ty1 ty2), the fd_qtvs may be + -- free in ty1 but not in ty2. See Wrinkle (1) of + -- Note [Improving against instances] + + , fd_loc :: loc } + deriving Functor + +instance Outputable (FunDepEqn a) where + ppr = pprEquation + +pprEquation :: FunDepEqn a -> SDoc +pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) + = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs), + nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2 + | Pair t1 t2 <- pairs])] + +{- +Given a bunch of predicates that must hold, such as + + C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5 + +improve figures out what extra equations must hold. +For example, if we have + + class C a b | a->b where ... + +then improve will return + + [(t1,t2), (t4,t5)] + +NOTA BENE: + + * improve does not iterate. It's possible that when we make + t1=t2, for example, that will in turn trigger a new equation. + This would happen if we also had + C t1 t7, C t2 t8 + If t1=t2, we also get t7=t8. + + improve does *not* do this extra step. It relies on the caller + doing so. + + * The equations unify types that are not already equal. So there + is no effect iff the result of improve is empty +-} + +instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type +-- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys) +instFD (ls,rs) tvs tys + = (map lookup ls, map lookup rs) + where + env = zipVarEnv tvs tys + lookup tv = lookupVarEnv_NF env tv + +zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true + -> [Type] -> [Type] + -> [TypeEqn] +-- Create a list of (Type,Type) pairs from two lists of types, +-- making sure that the types are not already equal +zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2) + | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2 + | otherwise = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2 +zipAndComputeFDEqs _ _ _ = [] + +-- Improve a class constraint from another class constraint +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +improveFromAnother :: loc + -> PredType -- Template item (usually given, or inert) + -> PredType -- Workitem [that can be improved] + -> [FunDepEqn loc] +-- Post: FDEqs always oriented from the other to the workitem +-- Equations have empty quantified variables +improveFromAnother loc pred1 pred2 + | Just (cls1, tys1) <- getClassPredTys_maybe pred1 + , Just (cls2, tys2) <- getClassPredTys_maybe pred2 + , cls1 == cls2 + = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_loc = loc } + | let (cls_tvs, cls_fds) = classTvsFds cls1 + , fd <- cls_fds + , let (ltys1, rs1) = instFD fd cls_tvs tys1 + (ltys2, rs2) = instFD fd cls_tvs tys2 + , eqTypes ltys1 ltys2 -- The LHSs match + , let eqs = zipAndComputeFDEqs eqType rs1 rs2 + , not (null eqs) ] + +improveFromAnother _ _ _ = [] + + +-- Improve a class constraint from instance declarations +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +improveFromInstEnv :: InstEnvs + -> (ClsInst -> loc) + -> Class -> [Type] + -> [FunDepEqn loc] -- Needs to be a FunDepEqn because + -- of quantified variables +-- See Note [Improving against instances] +-- Post: Equations oriented from the template (matching instance) to the workitem! +improveFromInstEnv inst_env mk_loc cls tys + = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs, fd_loc = mk_loc ispec } + | fd <- cls_fds -- Iterate through the fundeps first, + -- because there often are none! + , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs + -- Trim the rough_tcs based on the head of the fundep. + -- Remember that instanceCantMatch treats both arguments + -- symmetrically, so it's ok to trim the rough_tcs, + -- rather than trimming each inst_tcs in turn + , ispec <- instances + , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec + tys trimmed_tcs -- NB: orientation + ] + where + (cls_tvs, cls_fds) = classTvsFds cls + instances = classInstances inst_env cls + rough_tcs = RM_KnownTc (className cls) : roughMatchTcs tys + +improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class + -> ClsInst -- An instance template + -> [Type] -> [RoughMatchTc] -- Arguments of this (C tys) predicate + -> [([TyCoVar], [TypeEqn])] -- Empty or singleton +-- See Note [Improving against instances] + +improveClsFD clas_tvs fd + (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) + tys_actual rough_tcs_actual + + | instanceCantMatch rough_tcs_inst rough_tcs_actual + = [] -- Filter out ones that can't possibly match, + + | otherwise + = assertPpr (equalLength tys_inst tys_actual && + equalLength tys_inst clas_tvs) + (ppr tys_inst <+> ppr tys_actual) $ + + case tcMatchTyKisX init_subst ltys1 ltys2 of + Nothing -> [] + Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2) + -- Don't include any equations that already hold. + -- See Note [Improving against instances] wrinkle (3) + -- In making this check we must taking account of the fact that any + -- qtvs that aren't already instantiated can be instantiated to anything + -- at all + -- NB: We can't do this 'is-useful-equation' check element-wise + -- because of: + -- class C a b c | a -> b c + -- instance C Int x x + -- [Wanted] C Int alpha Int + -- We would get that x -> alpha (isJust) and x -> Int (isJust) + -- so we would produce no FDs, which is clearly wrong. + -> [] + + | null fdeqs + -> [] + + | otherwise + -> -- pprTrace "iproveClsFD" (vcat + -- [ text "is_tvs =" <+> ppr qtvs + -- , text "tys_inst =" <+> ppr tys_inst + -- , text "tys_actual =" <+> ppr tys_actual + -- , text "ltys1 =" <+> ppr ltys1 + -- , text "ltys2 =" <+> ppr ltys2 + -- , text "subst =" <+> ppr subst ]) $ + [(meta_tvs, fdeqs)] + -- We could avoid this substTy stuff by producing the eqn + -- (qtvs, ls1++rs1, ls2++rs2) + -- which will re-do the ls1/ls2 unification when the equation is + -- executed. What we're doing instead is recording the partial + -- work of the ls1/ls2 unification leaving a smaller unification problem + where + rtys1' = map (substTy subst) rtys1 + + fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2 + -- Don't discard anything! + -- We could discard equal types but it's an overkill to call + -- eqType again, since we know for sure that /at least one/ + -- equation in there is useful) + + meta_tvs = [ setVarType tv (substTy subst (varType tv)) + | tv <- qtvs + , tv `notElemSubst` subst + , tv `elemVarSet` rtys1_tvs ] + -- meta_tvs are the quantified type variables + -- that have not been substituted out + -- + -- Eg. class C a b | a -> b + -- instance C Int [y] + -- Given constraint C Int z + -- we generate the equation + -- ({y}, [y], z) + -- + -- But note (a) we get them from the dfun_id, so they are *in order* + -- because the kind variables may be mentioned in the + -- type variables' kinds + -- (b) we must apply 'subst' to the kinds, in case we have + -- matched out a kind variable, but not a type variable + -- whose kind mentions that kind variable! #6015, #6068 + -- (c) no need to include tyvars not in rtys1 + where + init_subst = mkEmptySubst $ mkInScopeSet $ + mkVarSet qtvs `unionVarSet` tyCoVarsOfTypes ltys2 + (ltys1, rtys1) = instFD fd clas_tvs tys_inst + (ltys2, rtys2) = instFD fd clas_tvs tys_actual + rtys1_tvs = tyCoVarsOfTypes rtys1 + +{- +%************************************************************************ +%* * + The Coverage condition for instance declarations +* * +************************************************************************ + +Note [Coverage condition] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Example + class C a b | a -> b + instance theta => C t1 t2 + +For the coverage condition, we check + (normal) fv(t2) `subset` fv(t1) + (liberal) fv(t2) `subset` closeWrtFunDeps(fv(t1), theta) + +The liberal version ensures the self-consistency of the instance, but +it does not guarantee termination. Example: + + class Mul a b c | a b -> c where + (.*.) :: a -> b -> c + + instance Mul Int Int Int where (.*.) = (*) + instance Mul Int Float Float where x .*. y = fromIntegral x * y + instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v + +In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]). +But it is the case that fv([c]) `subset` closeWrtFunDeps( theta, fv(a,[b]) ) + +But it is a mistake to accept the instance because then this defn: + f = \ b x y -> if b then x .*. [y] else y +makes instance inference go into a loop, because it requires the constraint + Mul a [b] b +-} + +checkInstCoverage :: Bool -- Be liberal + -> Class -> [PredType] -> [Type] + -> Validity' CoverageProblem +-- "be_liberal" flag says whether to use "liberal" coverage of +-- See Note [Coverage condition] below +-- +-- Return values +-- Nothing => no problems +-- Just msg => coverage problem described by msg + +checkInstCoverage be_liberal clas theta inst_taus + | any (isJust . isUnsatisfiableCt_maybe) theta + -- As per [GHC proposal #433](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst), + -- we skip checking the coverage condition if there is an "Unsatisfiable" + -- constraint in the instance context. + -- + -- See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors, + -- point (E). + = IsValid + | otherwise + = allValid (map fundep_ok fds) + where + (tyvars, fds) = classTvsFds clas + fundep_ok fd + | all isEmptyVarSet undetermined_tvs + = IsValid + | otherwise + = NotValid not_covered_msg + where + (ls,rs) = instFD fd tyvars inst_taus + ls_tvs = tyCoVarsOfTypes ls + rs_tvs = visVarsOfTypes rs + + undetermined_tvs | be_liberal = liberal_undet_tvs + | otherwise = conserv_undet_tvs + + closed_ls_tvs = closeWrtFunDeps theta ls_tvs + liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs + conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs + + not_covered_msg = + CoverageProblem + { not_covered_fundep = fd + , not_covered_fundep_inst = (ls, rs) + , not_covered_invis_vis_tvs = undetermined_tvs + , not_covered_liberal = + if be_liberal + then FailedLICC + else FailedICC + { alsoFailedLICC = not $ all isEmptyVarSet liberal_undet_tvs } + } + + +{- Note [Closing over kinds in coverage] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a fundep (a::k) -> b +Then if 'a' is instantiated to (x y), where x:k2->*, y:k2, +then fixing x really fixes k2 as well, and so k2 should be added to +the lhs tyvars in the fundep check. + +Example (#8391), using liberal coverage + data Foo a = ... -- Foo :: forall k. k -> * + class Bar a b | a -> b + instance Bar a (Foo a) + + In the instance decl, (a:k) does fix (Foo k a), but only if we notice + that (a:k) fixes k. #10109 is another example. + +Here is a more subtle example, from HList-0.4.0.0 (#10564) + + class HasFieldM (l :: k) r (v :: Maybe *) + | l r -> v where ... + class HasFieldM1 (b :: Maybe [*]) (l :: k) r v + | b l r -> v where ... + class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) + | e1 l -> r + + data Label :: k -> * + type family LabelsOf (a :: [*]) :: * + + instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b, + HasFieldM1 b l (r xs) v) + => HasFieldM l (r xs) v where + +Is the instance OK? Does {l,r,xs} determine v? Well: + + * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b, + plus the fundep "| el l -> r" in class HMameberM, + we get {l,k,xs} -> b + + * Note the 'k'!! We must call closeOverKinds on the seed set + ls_tvs = {l,r,xs}, BEFORE doing closeWrtFunDeps, else the {l,k,xs}->b + fundep won't fire. This was the reason for #10564. + + * So starting from seeds {l,r,xs,k} we do closeWrtFunDeps to get + first {l,r,xs,k,b}, via the HMemberM constraint, and then + {l,r,xs,k,b,v}, via the HasFieldM1 constraint. + + * And that fixes v. + +However, we must closeOverKinds whenever augmenting the seed set +in closeWrtFunDeps! Consider #10109: + + data Succ a -- Succ :: forall k. k -> * + class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab + instance (Add a b ab) => Add (Succ {k1} (a :: k1)) + b + (Succ {k3} (ab :: k3}) + +We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}. +Now use the fundep to extend to {a,k1,b,k2,ab}. But we need to +closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all +the variables free in (Succ {k3} ab). + +Bottom line: + * closeOverKinds on initial seeds (done automatically + by tyCoVarsOfTypes in checkInstCoverage) + * and closeOverKinds whenever extending those seeds (in closeWrtFunDeps) + +Note [The liberal coverage condition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(closeWrtFunDeps preds tvs) closes the set of type variables tvs, +wrt functional dependencies in preds. The result is a superset +of the argument set. For example, if we have + class C a b | a->b where ... +then + closeWrtFunDeps [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} +because if we know x and y then that fixes z. + +We also use equality predicates in the predicates; if we have an +assumption `t1 ~ t2`, then we use the fact that if we know `t1` we +also know `t2` and the other way. + eg closeWrtFunDeps [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} + +closeWrtFunDeps is used + - when checking the coverage condition for an instance declaration + - when determining which tyvars are unquantifiable during generalization, in + GHC.Tc.Solver.decidePromotedTyVars. + +Note [Equality superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + class (a ~ [b]) => C a b + +Remember from Note [The equality types story] in GHC.Builtin.Types.Prim, that + * (a ~~ b) is a superclass of (a ~ b) + * (a ~# b) is a superclass of (a ~~ b) + +So when closeWrtFunDeps expands superclasses we'll get a (a ~# [b]) superclass. +But that's an EqPred not a ClassPred, and we jolly well do want to +account for the mutual functional dependencies implied by (t1 ~# t2). +Hence the EqPred handling in closeWrtFunDeps. See #10778. + +Note [Care with type functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12803) + class C x y | x -> y + type family F a b + type family G c d = r | r -> d + +Now consider + closeWrtFunDeps (C (F a b) (G c d)) {a,b} + +Knowing {a,b} fixes (F a b) regardless of the injectivity of F. +But knowing (G c d) fixes only {d}, because G is only injective +in its second parameter. + +Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds. +-} + +closeWrtFunDeps :: [PredType] -> TyCoVarSet -> TyCoVarSet +-- See Note [The liberal coverage condition] +closeWrtFunDeps preds fixed_tvs + | null tv_fds = fixed_tvs -- Fast escape hatch for common case. + | otherwise = assertPpr (closeOverKinds fixed_tvs == fixed_tvs) + (vcat [ text "closeWrtFunDeps: fixed_tvs is not closed over kinds" + , text "fixed_tvs:" <+> ppr fixed_tvs + , text "closure:" <+> ppr (closeOverKinds fixed_tvs) ]) + $ fixVarSet extend fixed_tvs + where + + extend fixed_tvs = foldl' add fixed_tvs tv_fds + where + add fixed_tvs (ls,rs) + | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs + | otherwise = fixed_tvs + -- closeOverKinds: see Note [Closing over kinds in coverage] + + tv_fds :: [(TyCoVarSet,TyCoVarSet)] + tv_fds = [ (tyCoVarsOfTypes ls, fvVarSet $ injectiveVarsOfTypes True rs) + -- See Note [Care with type functions] + | pred <- preds + , pred' <- pred : transSuperClasses pred + -- Look for fundeps in superclasses too + , (ls, rs) <- determined pred' ] + + determined :: PredType -> [([Type],[Type])] + determined pred + = case classifyPredType pred of + EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])] + -- See Note [Equality superclasses] + + ClassPred cls tys | not (isIPClass cls) + -- isIPClass: see Note [closeWrtFunDeps ignores implicit parameters] + -> [ instFD fd cls_tvs tys + | let (cls_tvs, cls_fds) = classTvsFds cls + , fd <- cls_fds ] + _ -> [] + +{- Note [closeWrtFunDeps ignores implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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. +-} + +{- ********************************************************************* +* * + Check that a new instance decl is OK wrt fundeps +* * +************************************************************************ + +Here is the bad case: + class C a b | a->b where ... + instance C Int Bool where ... + instance C Int Char where ... + +The point is that a->b, so Int in the first parameter must uniquely +determine the second. In general, given the same class decl, and given + + instance C s1 s2 where ... + instance C t1 t2 where ... + +Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). + +Matters are a little more complicated if there are free variables in +the s2/t2. + + class D a b c | a -> b + instance D a b => D [(a,a)] [b] Int + instance D a b => D [a] [b] Bool + +The instance decls don't overlap, because the third parameter keeps +them separate. But we want to make sure that given any constraint + D s1 s2 s3 +if s1 matches + +Note [Bogus consistency check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In checkFunDeps we check that a new ClsInst is consistent with all the +ClsInsts in the environment. + +The bogus aspect is discussed in #10675. Currently it if the two +types are *contradictory*, using (isNothing . tcUnifyTys). But all +the papers say we should check if the two types are *equal* thus + not (substTys subst rtys1 `eqTypes` substTys subst rtys2) +For now I'm leaving the bogus form because that's the way it has +been for years. +-} + +checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst] +-- The Consistency Check. +-- Check whether adding DFunId would break functional-dependency constraints +-- Used only for instance decls defined in the module being compiled +-- Returns a list of the ClsInst in InstEnvs that are inconsistent +-- with the proposed new ClsInst +checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls + , is_tys = tys1, is_tcs = rough_tcs1 }) + | null fds + = [] + | otherwise + = nubBy eq_inst $ + [ ispec | ispec <- cls_insts + , fd <- fds + , is_inconsistent fd ispec ] + where + cls_insts = classInstances inst_envs cls + (cls_tvs, fds) = classTvsFds cls + qtv_set1 = mkVarSet qtvs1 + + is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 }) + | instanceCantMatch trimmed_tcs rough_tcs2 + = False + | otherwise + = case tcUnifyFunDeps qtvs ltys1 ltys2 of + Nothing -> False + Just subst + -> isNothing $ -- Bogus legacy test (#10675) + -- See Note [Bogus consistency check] + tcUnifyFunDeps qtvs (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2) + + where + trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs1 + (ltys1, rtys1) = instFD fd cls_tvs tys1 + (ltys2, rtys2) = instFD fd cls_tvs tys2 + qtv_set2 = mkVarSet qtvs2 + qtvs = qtv_set1 `unionVarSet` qtv_set2 + + eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2 + -- A single instance may appear twice in the un-nubbed conflict list + -- because it may conflict with more than one fundep. E.g. + -- class C a b c | a -> b, a -> c + -- instance C Int Bool Bool + -- instance C Int Char Char + -- The second instance conflicts with the first by *both* fundeps + +trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [RoughMatchTc] -> [RoughMatchTc] +-- Computing rough_tcs for a particular fundep +-- class C a b c | a -> b where ... +-- For each instance .... => C ta tb tc +-- we want to match only on the type ta; so our +-- rough-match thing must similarly be filtered. +-- Hence, we Nothing-ise the tb and tc types right here +-- +-- Result list is same length as input list, just with more Nothings +trimRoughMatchTcs _clas_tvs _ [] = panic "trimRoughMatchTcs: nullary [RoughMatchTc]" +trimRoughMatchTcs clas_tvs (ltvs, _) (cls:mb_tcs) + = cls : zipWith select clas_tvs mb_tcs + where + select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc + | otherwise = RM_WildCard diff --git a/GHC/Tc/Instance/Typeable.hs b/GHC/Tc/Instance/Typeable.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Instance/Typeable.hs @@ -0,0 +1,789 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 +-} + + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where + +import GHC.Prelude +import GHC.Platform + +import GHC.Types.Basic ( TypeOrConstraint(..), neverInlinePragma ) +import GHC.Types.SourceText ( SourceText(..) ) +import GHC.Iface.Env( newGlobalBinder ) +import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Evidence ( mkWpTyApps ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Types.TyThing ( lookupId ) +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim ( primTyCons ) +import GHC.Builtin.Types + ( runtimeRepTyCon + , levityTyCon, vecCountTyCon, vecElemTyCon + , nilDataCon, consDataCon ) +import GHC.Types.Name +import GHC.Types.Id +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Unit.Module +import GHC.Hs +import GHC.Driver.DynFlags +import GHC.Types.Var ( VarBndr(..) ) +import GHC.Core.Map.Type +import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.FastString ( FastString, mkFastString, fsLit ) + +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Class (lift) +import Data.Maybe ( isJust ) + +{- Note [Grand plan for Typeable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The overall plan is this: + +1. Generate a binding for each module p:M + (done in GHC.Tc.Instance.Typeable by mkModIdBindings) + M.$trModule :: GHC.Unit.Module + M.$trModule = Module "p" "M" + ("tr" is short for "type representation"; see GHC.Types) + + We might want to add the filename too. + This can be used for the lightweight stack-tracing stuff too + + Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv + +2. Generate a binding for every data type declaration T in module M, + M.$tcT :: GHC.Types.TyCon + M.$tcT = TyCon ...fingerprint info... + $trModule + "T" + 0# + kind_rep + + Here 0# is the number of arguments expected by the tycon to fully determine + its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a + recipe for computing the kind of an instantiation of the tycon (see + Note [Representing TyCon kinds: KindRep] later in this file for details). + + We define (in GHC.Core.TyCon) + + type TyConRepName = Name + + to use for these M.$tcT "tycon rep names". Note that these must be + treated as "never exported" names by Backpack (see + Note [Handling never-exported TyThings under Backpack]). Consequently + they get slightly special treatment in GHC.Iface.Rename.rnIfaceDecl. + +3. Record the TyConRepName in T's TyCon, including for promoted + data and type constructors, and kinds like * and #. + + The TyConRepName is not an "implicit Id". It's more like a record + selector: the TyCon knows its name but you have to go to the + interface file to find its type, value, etc + +4. Solve Typeable constraints. This is done by a custom Typeable solver, + currently in GHC.Tc.Instance.Class, that use M.$tcT so solve (Typeable T). + +There are many wrinkles: + +* The timing of when we produce this bindings is rather important: they must be + defined after the rest of the module has been typechecked since we need to be + able to lookup Module and TyCon in the type environment and we may be + currently compiling GHC.Types (where they are defined). + +* GHC.Prim doesn't have any associated object code, so we need to put the + representations for types defined in this module elsewhere. We chose this + place to be GHC.Types. GHC.Tc.Instance.Typeable.mkPrimTypeableTodos is responsible for + injecting the bindings for the GHC.Prim representations when compiling + GHC.Types. + +* TyCon.tyConRepModOcc is responsible for determining where to find + the representation binding for a given type. This is where we handle + the special case for GHC.Prim. + +* To save space and reduce dependencies, we need use quite low-level + representations for TyCon and Module. See GHC.Types + Note [Runtime representation of modules and tycons] + +* The KindReps can unfortunately get quite large. Moreover, the simplifier will + float out various pieces of them, resulting in numerous top-level bindings. + Consequently we mark the KindRep bindings as noinline, ensuring that the + float-outs don't make it into the interface file. This is important since + there is generally little benefit to inlining KindReps and they would + otherwise strongly affect compiler performance. + +* In general there are lots of things of kind *, * -> *, and * -> * -> *. To + reduce the number of bindings we need to produce, we generate their KindReps + once in GHC.Types. These are referred to as "built-in" KindReps below. + +* Even though KindReps aren't inlined, this scheme still has more of an effect on + compilation time than I'd like. This is especially true in the case of + families of type constructors (e.g. tuples and unboxed sums). The problem is + particularly bad in the case of sums, since each arity-N tycon brings with it + N promoted datacons, each with a KindRep whose size also scales with N. + Consequently we currently simply don't allow sums to be Typeable. + + In general we might consider moving some or all of this generation logic back + to the solver since the performance hit we take in doing this at + type-definition time is non-trivial and Typeable isn't very widely used. This + is discussed in #13261. + +-} + +-- | Generate the Typeable bindings for a module. This is the only +-- entry-point of this module and is invoked by the typechecker driver in +-- 'tcRnSrcDecls'. +-- +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +mkTypeableBinds :: TcM TcGblEnv +mkTypeableBinds + = do { dflags <- getDynFlags + ; if gopt Opt_NoTypeableBinds dflags then getGblEnv else do + { -- Create a binding for $trModule. + -- Do this before processing any data type declarations, + -- which need tcg_tr_module to be initialised + ; tcg_env <- mkModIdBindings + -- Now we can generate the TyCon representations... + -- First we handle the primitive TyCons if we are compiling GHC.Types + ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos + + -- Then we produce bindings for the user-defined types in this module. + ; setGblEnv tcg_env $ + do { mod <- getModule + ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env) + mod_id = case tcg_tr_module tcg_env of -- Should be set by now + Just mod_id -> mod_id + Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons) + ; traceTc "mkTypeableBinds" (ppr tycons) + ; this_mod_todos <- todoForTyCons mod mod_id tycons + ; mkTypeRepTodoBinds (this_mod_todos : prim_todos) + } } } + where + needs_typeable_binds tc + | tc `elem` ghcTypesTypeableTyCons + = False + | otherwise = + isAlgTyCon tc + || isDataFamilyTyCon tc + || isClassTyCon tc + + +{- ********************************************************************* +* * + Building top-level binding for $trModule +* * +********************************************************************* -} + +mkModIdBindings :: TcM TcGblEnv +mkModIdBindings + = do { mod <- getModule + ; loc <- getSrcSpanM + ; mod_nm <- newGlobalBinder mod (mkVarOccFS (fsLit "$trModule")) loc + ; trModuleTyCon <- tcLookupTyCon trModuleTyConName + ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon []) + ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod + + ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv + ; return (tcg_env { tcg_tr_module = Just mod_id } + `addTypecheckedBinds` [[mod_bind]]) } + +mkModIdRHS :: Module -> TcM (LHsExpr GhcTc) +mkModIdRHS mod + = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName + ; trNameLit <- mkTrNameLit + ; return $ nlHsDataCon trModuleDataCon + `nlHsApp` trNameLit (unitFS (moduleUnit mod)) + `nlHsApp` trNameLit (moduleNameFS (moduleName mod)) + } + +{- ********************************************************************* +* * + Building type-representation bindings +* * +********************************************************************* -} + +-- | Information we need about a 'TyCon' to generate its representation. We +-- carry the 'Id' in order to share it between the generation of the @TyCon@ and +-- @KindRep@ bindings. +data TypeableTyCon + = TypeableTyCon + { tycon :: !TyCon + , tycon_rep_id :: !Id + } + +data TypeRepTodo + = TyConTodo TyConTodo + | ExportedKindRepsTodo [(Kind, Id)] + -- ^ Build exported 'KindRep' bindings for the given set of kinds. + + +-- | A group of 'TyCon's in need of type-rep bindings. +data TyConTodo + = TCTD { mod_rep_expr :: LHsExpr GhcTc -- ^ Module's typerep binding + , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint + , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint + , todo_tycons :: [TypeableTyCon] + -- ^ The 'TyCon's in need of bindings kinds + } + +todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo +todoForTyCons mod mod_id tycons = do + trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName + let mk_rep_id :: TyConRepName -> Id + mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy + + let typeable_tycons :: [TypeableTyCon] + typeable_tycons = + [ TypeableTyCon { tycon = tc'' + , tycon_rep_id = mk_rep_id rep_name + } + | tc <- tycons + , tc' <- tc : tyConATs tc + -- We need type representations for any associated types + , let promoted = map promoteDataCon (tyConDataCons tc') + , tc'' <- tc' : promoted + -- Don't make bindings for data-family instance tycons. + -- Do, however, make them for their promoted datacon (see #13915). + , not $ isFamInstTyCon tc'' + , Just rep_name <- pure $ tyConRepName_maybe tc'' + , tyConIsTypeable tc'' + ] + return $ TyConTodo $ + TCTD { mod_rep_expr = nlHsVar mod_id + , pkg_fingerprint = pkg_fpr + , mod_fingerprint = mod_fpr + , todo_tycons = typeable_tycons } + where + mod_fpr = fingerprintString $ moduleNameString $ moduleName mod + pkg_fpr = fingerprintString $ unitString $ moduleUnit mod + +todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo +todoForExportedKindReps kinds = do + trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName + let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy) + return $ ExportedKindRepsTodo $ map mkId kinds + +-- | Generate TyCon bindings for a set of type constructors +mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv +mkTypeRepTodoBinds [] = getGblEnv +mkTypeRepTodoBinds todos + = do { stuff <- collect_stuff + + -- First extend the type environment with all of the bindings + -- which we are going to produce since we may need to refer to them + -- while generating kind representations (namely, when we want to + -- represent a TyConApp in a kind, we must be able to look up the + -- TyCon associated with the applied type constructor). + ; let produced_bndrs :: [Id] + produced_bndrs = [ tycon_rep_id + | TyConTodo (TCTD { todo_tycons = tcs }) <- todos + , TypeableTyCon {..} <- tcs + ] ++ + [ rep_id + | ExportedKindRepsTodo kinds <- todos + , (_, rep_id) <- kinds + ] + ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv + + ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc] + mk_binds (TyConTodo (todo@(TCTD { todo_tycons = tcs }))) = + mapM (mkTyConRepBinds stuff todo) tcs + mk_binds (ExportedKindRepsTodo kinds) = + mkExportedKindReps stuff kinds >> return [] + + ; (gbl_env, binds) <- setGblEnv gbl_env + $ runKindRepM (mapM mk_binds todos) + ; return $ gbl_env `addTypecheckedBinds` concat binds } + +-- | Generate bindings for the type representation of a wired-in 'TyCon's +-- defined by the virtual "GHC.Prim" module. This is where we inject the +-- representation bindings for these primitive types into "GHC.Types" +-- +-- See Note [Grand plan for Typeable] in this module. +mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo]) +mkPrimTypeableTodos + = do { mod <- getModule + ; if mod == gHC_TYPES + then do { -- Build Module binding for GHC.Prim + trModuleTyCon <- tcLookupTyCon trModuleTyConName + ; let ghc_prim_module_id = + mkExportedVanillaId trGhcPrimModuleName + (mkTyConTy trModuleTyCon) + + ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id + <$> mkModIdRHS gHC_PRIM + + -- Extend our environment with above + ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id] + getGblEnv + ; let gbl_env' = gbl_env `addTypecheckedBinds` + [[ghc_prim_module_bind]] + + -- Build TypeRepTodos for built-in KindReps + ; todo1 <- todoForExportedKindReps builtInKindReps + + -- Build TypeRepTodos for types in GHC.Prim + ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id + ghcPrimTypeableTyCons + + ; 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]) + } + else do gbl_env <- getGblEnv + return (gbl_env, []) + } + +-- | This is the list of primitive 'TyCon's for which we must generate bindings +-- in "GHC.Types". This should include all types defined in "GHC.Prim". +-- +-- The majority of the types we need here are contained in 'primTyCons'. +-- However, not all of them: in particular unboxed tuples are absent since we +-- don't want to include them in the original name cache. See +-- Note [Built-in syntax and the OrigNameCache] in "GHC.Types.Name.Cache" for more. +ghcPrimTypeableTyCons :: [TyCon] +ghcPrimTypeableTyCons = concat + [ 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@ + , trNameLit :: FastString -> LHsExpr GhcTc + -- ^ To construct @TrName@s + -- The various TyCon and DataCons of KindRep + , kindRepTyCon :: TyCon + , kindRepTyConAppDataCon :: DataCon + , kindRepVarDataCon :: DataCon + , kindRepAppDataCon :: DataCon + , kindRepFunDataCon :: DataCon + , kindRepTYPEDataCon :: DataCon + , kindRepTypeLitSDataCon :: DataCon + , typeLitSymbolDataCon :: DataCon + , typeLitCharDataCon :: DataCon + , typeLitNatDataCon :: DataCon + } + +-- | Collect various tidbits which we'll need to generate TyCon representations. +collect_stuff :: TcM TypeableStuff +collect_stuff = do + platform <- targetPlatform <$> getDynFlags + trTyConDataCon <- tcLookupDataCon trTyConDataConName + kindRepTyCon <- tcLookupTyCon kindRepTyConName + kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName + kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName + kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName + kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName + kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName + kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName + typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName + typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName + typeLitCharDataCon <- tcLookupDataCon typeLitCharDataConName + trNameLit <- mkTrNameLit + return Stuff {..} + +-- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we +-- can save the work of repeating lookups when constructing many TyCon +-- representations. +mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc) +mkTrNameLit = do + trNameSDataCon <- tcLookupDataCon trNameSDataConName + let trNameLit :: FastString -> LHsExpr GhcTc + trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit fs) + return trNameLit + +-- | Make Typeable bindings for the given 'TyCon'. +mkTyConRepBinds :: TypeableStuff -> TyConTodo + -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) +mkTyConRepBinds stuff todo (TypeableTyCon {..}) + = do -- Make a KindRep + let (bndrs, kind) = splitForAllForAllTyBinders (tyConKind tycon) + liftTc $ traceTc "mkTyConKindRepBinds" + (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind) + let ctx = mkDeBruijnContext (map binderVar bndrs) + kind_rep <- getKindRep stuff ctx kind + + -- Make the TyCon binding + let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep + tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs + return [tycon_rep_bind] + +-- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type +-- families and polytypes. +tyConIsTypeable :: TyCon -> Bool +tyConIsTypeable tc = isJust (tyConRepName_maybe tc) + && kindIsTypeable (dropForAlls $ tyConKind tc) + +-- | Is a particular 'Kind' representable by @Typeable@? Here we look for +-- polytypes and types containing casts (which may be, for instance, a type +-- family). +kindIsTypeable :: Kind -> Bool +-- We handle types of the form (TYPE LiftedRep) specifically to avoid +-- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr) +-- to be typeable without inspecting rr, but this exhibits bad behavior +-- when rr is a type family. +kindIsTypeable ty + | Just ty' <- coreView ty = kindIsTypeable ty' +kindIsTypeable ty + | isLiftedTypeKind ty = True +kindIsTypeable (TyVarTy _) = True +kindIsTypeable (AppTy a b) = kindIsTypeable a && kindIsTypeable b +kindIsTypeable (FunTy _ w a b) = kindIsTypeable w && + kindIsTypeable a && + kindIsTypeable b +kindIsTypeable (TyConApp tc args) = tyConIsTypeable tc + && all kindIsTypeable args +kindIsTypeable (ForAllTy{}) = False +kindIsTypeable (LitTy _) = True +kindIsTypeable (CastTy{}) = False + -- See Note [Typeable instances for casted types] +kindIsTypeable (CoercionTy{}) = False + +-- | Maps kinds to 'KindRep' bindings. This binding may either be defined in +-- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing') +-- or a binding which we generated in the current module (in which case it will +-- be 'Just' the RHS of the binding). +type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc)) + +-- | A monad within which we will generate 'KindRep's. Here we keep an +-- environment containing 'KindRep's which we've already generated so we can +-- re-use them opportunistically. +newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a } + deriving (Functor, Applicative, Monad) + +liftTc :: TcRn a -> KindRepM a +liftTc = KindRepM . lift + +-- | We generate `KindRep`s for a few common kinds, so that they +-- can be reused across modules. +-- These definitions are generated in `ghc-prim:GHC.Types`. +builtInKindReps :: [(Kind, Name)] +builtInKindReps = + [ (star, starKindRepName) + , (constraintKind, constraintKindRepName) + , (mkVisFunTyMany star star, starArrStarKindRepName) + , (mkVisFunTysMany [star, star] star, starArrStarArrStarKindRepName) + ] + where + star = liftedTypeKind + +initialKindRepEnv :: TcRn KindRepEnv +initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps + where + add_kind_rep acc (k,n) = do + id <- tcLookupId n + return $! extendTypeMap acc k (id, Nothing) + -- The TypeMap looks through type synonyms + +-- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's. +mkExportedKindReps :: TypeableStuff + -> [(Kind, Id)] -- ^ the kinds to generate bindings for + -> KindRepM () +mkExportedKindReps stuff = mapM_ kindrep_binding + where + empty_scope = mkDeBruijnContext [] + + kindrep_binding :: (Kind, Id) -> KindRepM () + kindrep_binding (kind, rep_bndr) = do + -- We build the binding manually here instead of using mkKindRepRhs + -- since the latter would find the built-in 'KindRep's in the + -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv'). + rhs <- mkKindRepRhs stuff empty_scope kind + liftTc (traceTc "mkExport" (ppr kind $$ ppr rep_bndr $$ ppr rhs)) + addKindRepBind empty_scope kind rep_bndr rhs + +addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM () +addKindRepBind in_scope k bndr rhs = + KindRepM $ modify' $ + \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs) + +-- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking +-- environment. +runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a) +runKindRepM (KindRepM action) = do + kindRepEnv <- initialKindRepEnv + (res, reps_env) <- runStateT action kindRepEnv + let rep_binds = foldTypeMap to_bind_pair [] reps_env + to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest + to_bind_pair (_, Nothing) rest = rest + tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv + let binds = map (uncurry mkVarBind) rep_binds + tcg_env' = tcg_env `addTypecheckedBinds` [binds] + return (tcg_env', res) + +-- | Produce or find a 'KindRep' for the given kind. +getKindRep :: TypeableStuff -> CmEnv -- ^ in-scope kind variables + -> Kind -- ^ the kind we want a 'KindRep' for + -> KindRepM (LHsExpr GhcTc) +getKindRep stuff@(Stuff {..}) in_scope = go + where + go :: Kind -> KindRepM (LHsExpr GhcTc) + go = KindRepM . StateT . go' + + go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv) + go' k env + -- We've already generated the needed KindRep + -- This lookup looks through synonyms + | Just (id, _) <- lookupTypeMapWithScope env in_scope k + = return (nlHsVar id, env) + + -- We need to construct a new KindRep binding + | otherwise + = do -- Place a NOINLINE pragma on KindReps since they tend to be quite + -- large and bloat interface files. + rep_bndr <- (`setInlinePragma` neverInlinePragma) + <$> newSysLocalId (fsLit "$krep") ManyTy (mkTyConTy kindRepTyCon) + + -- do we need to tie a knot here? + flip runStateT env $ unKindRepM $ do + rhs <- mkKindRepRhs stuff in_scope k + addKindRepBind in_scope k rep_bndr rhs + return $ nlHsVar rep_bndr + +-- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and +-- in-scope kind variable set. +mkKindRepRhs :: TypeableStuff + -> CmEnv -- ^ in-scope kind variables + -> Kind -- ^ the kind we want a 'KindRep' for + -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression +mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep_shortcut + where + new_kind_rep_shortcut k + -- We handle (TYPE LiftedRep) etc separately to make it + -- clear to consumers (e.g. serializers) that there is + -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep) + | Just (TypeLike, rep) <- sORTKind_maybe k + -- Typeable respects the Constraint/Type distinction + -- so do not follow the special case here + = -- Here k = TYPE + case splitTyConApp_maybe rep of + Just (tc, []) -- TYPE IntRep, TYPE FloatRep etc + | Just dc <- isPromotedDataCon_maybe tc + -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc + + Just (rep_tc, [levArg]) -- TYPE (BoxedRep lev) + | Just dcRep <- isPromotedDataCon_maybe rep_tc + , Just (lev_tc, []) <- splitTyConApp_maybe levArg + , Just dcLev <- isPromotedDataCon_maybe lev_tc + -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` (nlHsDataCon dcRep `nlHsApp` nlHsDataCon dcLev) + + _ -> new_kind_rep k + | otherwise = new_kind_rep k + + new_kind_rep ki -- Expand synonyms + | Just ki' <- coreView ki + = new_kind_rep ki' + + new_kind_rep (TyVarTy v) + | Just idx <- lookupCME in_scope v + = return $ nlHsDataCon kindRepVarDataCon + `nlHsApp` nlHsIntLit (fromIntegral idx) + | otherwise + = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v) + + new_kind_rep (AppTy t1 t2) + = do rep1 <- getKindRep stuff in_scope t1 + rep2 <- getKindRep stuff in_scope t2 + return $ nlHsDataCon kindRepAppDataCon + `nlHsApp` rep1 `nlHsApp` rep2 + + new_kind_rep k@(TyConApp tc tys) + | Just rep_name <- tyConRepName_maybe tc + = do rep_id <- liftTc $ lookupId rep_name + tys' <- mapM (getKindRep stuff in_scope) tys + return $ nlHsDataCon kindRepTyConAppDataCon + `nlHsApp` nlHsVar rep_id + `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys' + | otherwise + = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k) + + new_kind_rep (ForAllTy (Bndr var _) ty) + = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) + + new_kind_rep (FunTy _ _ t1 t2) + = do rep1 <- getKindRep stuff in_scope t1 + rep2 <- getKindRep stuff in_scope t2 + return $ nlHsDataCon kindRepFunDataCon + `nlHsApp` rep1 `nlHsApp` rep2 + + new_kind_rep (LitTy (NumTyLit n)) + = return $ nlHsDataCon kindRepTypeLitSDataCon + `nlHsApp` nlHsDataCon typeLitNatDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n) + + new_kind_rep (LitTy (StrTyLit s)) + = return $ nlHsDataCon kindRepTypeLitSDataCon + `nlHsApp` nlHsDataCon typeLitSymbolDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s) + + new_kind_rep (LitTy (CharTyLit c)) + = return $ nlHsDataCon kindRepTypeLitSDataCon + `nlHsApp` nlHsDataCon typeLitCharDataCon + `nlHsApp` nlHsLit (mkHsCharPrimLit c) + + -- See Note [Typeable instances for casted types] + new_kind_rep (CastTy ty co) + = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co) + + new_kind_rep (CoercionTy co) + = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co) + +-- | Produce the right-hand-side of a @TyCon@ representation. +mkTyConRepTyConRHS :: TypeableStuff -> TyConTodo + -> TyCon -- ^ the 'TyCon' we are producing a binding for + -> LHsExpr GhcTc -- ^ its 'KindRep' + -> LHsExpr GhcTc +mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep + = nlHsDataCon trTyConDataCon + `nlHsApp` nlHsLit (HsWord64Prim NoSourceText (toInteger high)) + `nlHsApp` nlHsLit (HsWord64Prim NoSourceText (toInteger low)) + `nlHsApp` mod_rep_expr todo + `nlHsApp` trNameLit (mkFastString tycon_str) + `nlHsApp` nlHsLit (HsIntPrim NoSourceText (toInteger n_kind_vars)) + `nlHsApp` kind_rep + where + n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon) + tycon_str = add_tick (occNameString (getOccName tycon)) + add_tick s | isDataKindsPromotedDataCon tycon = '\'' : s + | otherwise = s + + -- This must match the computation done in + -- Data.Typeable.Internal.mkTyConFingerprint. + Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo + , mod_fingerprint todo + , fingerprintString tycon_str + ] + +{- +Note [Representing TyCon kinds: KindRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One of the operations supported by Typeable is typeRepKind, + + typeRepKind :: TypeRep (a :: k) -> TypeRep k + +Implementing this is a bit tricky for poly-kinded types like + + data Proxy (a :: k) :: Type + -- Proxy :: forall k. k -> Type + +The TypeRep encoding of `Proxy Type Int` looks like this: + + $tcProxy :: GHC.Types.TyCon + $trInt :: TypeRep Int + TrType :: TypeRep Type + + $trProxyType :: TypeRep (Proxy Type :: Type -> Type) + $trProxyType = TrTyCon $tcProxy + [TrType] -- kind variable instantiation + (tyConKind $tcProxy [TrType]) -- The TypeRep of + -- Type -> Type + + $trProxy :: TypeRep (Proxy Type Int) + $trProxy = TrApp $trProxyType $trInt TrType + + $tkProxy :: GHC.Types.KindRep + $tkProxy = KindRepFun (KindRepVar 0) + (KindRepTyConApp (KindRepTYPE LiftedRep) []) + +Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent +polymorphic types. So instead + + * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations) + of all its kind arguments. We can't represent a tycon that is + applied to only some of its kind arguments. + + * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a + GHC.Types.KindRep, which represents the polymorphic kind of Proxy + Proxy :: forall k. k->Type + + * A KindRep is just a recipe that we can instantiate with the + argument kinds, using Data.Typeable.Internal.tyConKind and + store in the relevant 'TypeRep' constructor. + + Data.Typeable.Internal.typeRepKind looks up the stored kinds. + + * In a KindRep, the kind variables are represented by 0-indexed + de Bruijn numbers: + + type KindBndr = Int -- de Bruijn index + + data KindRep = KindRepTyConApp TyCon [KindRep] + | KindRepVar !KindBndr + | KindRepApp KindRep KindRep + | KindRepFun KindRep KindRep + ... + +Note [Typeable instances for casted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At present, GHC does not manufacture TypeReps for types containing casts +(#16835). In theory, GHC could do so today, but it might be dangerous tomorrow. + +In today's GHC, we normalize all types before computing their TypeRep. +For example: + + type family F a + type instance F Int = Type + + data D = forall (a :: F Int). MkD a + + tr :: TypeRep (MkD Bool) + tr = typeRep + +When computing the TypeRep for `MkD Bool` (or rather, +`MkD (Bool |> Sym (FInt[0]))`), we simply discard the cast to obtain the +TypeRep for `MkD Bool`. + +Why does this work? If we have a type definition with casts, then the +only coercions that those casts can mention are either Refl, type family +axioms, built-in axioms, and coercions built from those roots. Therefore, +type family (and built-in) axioms will apply precisely when type normalization +succeeds (i.e, the type family applications are reducible). Therefore, it +is safe to ignore the cast entirely when constructing the TypeRep. + +This approach would be fragile in a future where GHC permits other forms of +coercions to appear in casts (e.g., coercion quantification as described +in #15710). If GHC permits local assumptions to appear in casts that cannot be +reduced with conventional normalization, then discarding casts would become +unsafe. It would be unfortunate for the Typeable solver to become a roadblock +obstructing such a future, so we deliberately do not implement the ability +for TypeReps to represent types with casts at the moment. + +If we do wish to allow this in the future, it will likely require modeling +casts and coercions in TypeReps themselves. +-} + +mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc +mkList ty = foldr consApp (nilExpr ty) + where + cons = consExpr ty + consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc + consApp x xs = cons `nlHsApp` x `nlHsApp` xs + + nilExpr :: Type -> LHsExpr GhcTc + nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon) + + consExpr :: Type -> LHsExpr GhcTc + consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon) diff --git a/GHC/Tc/Module.hs b/GHC/Tc/Module.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Module.hs @@ -0,0 +1,3334 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Typechecking a whole module +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker +module GHC.Tc.Module ( + tcRnStmt, tcRnExpr, TcRnExprMode(..), + tcRnType, tcRnTypeSkolemising, + tcRnImportDecls, + tcRnLookupRdrName, + getModuleInterface, + tcRnDeclsi, + isGHCiMonad, + runTcInteractive, -- Used by GHC API clients (#8878) + withTcPlugins, -- Used by GHC API clients (#20499) + withHoleFitPlugins, -- Used by GHC API clients (#20499) + tcRnLookupName, + tcRnGetInfo, + tcRnModule, tcRnModuleTcRnM, + tcTopSrcDecls, + rnTopSrcDecls, + checkBootDecl, checkHiBootIface', + findExtraSigImports, + implicitRequirements, + checkUnit, + mergeSignatures, + tcRnMergeSignatures, + instantiateSignature, + tcRnInstantiateSignature, + loadUnqualIfaces, + -- More private... + checkBootDeclM, + getRenamedStuff, RenamedStuff + ) where + +import GHC.Prelude + +import GHC.Driver.Env +import GHC.Driver.Plugins +import GHC.Driver.DynFlags +import GHC.Driver.Config.Diagnostic +import GHC.IO.Unsafe ( unsafeInterleaveIO ) + +import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR (..) ) +import GHC.Tc.Errors.Types +import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Validity( checkValidType ) +import GHC.Tc.Gen.Match +import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma ) +import GHC.Tc.Zonk.Type +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.Export +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Instance.Family +import GHC.Tc.Gen.Annotation +import GHC.Tc.Gen.Bind +import GHC.Tc.Gen.Default +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Sig( tcRules ) +import GHC.Tc.Gen.Foreign +import GHC.Tc.TyCl.Instance +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Solver +import GHC.Tc.TyCl +import GHC.Tc.Instance.Typeable ( mkTypeableBinds ) +import GHC.Tc.Utils.Backpack +import GHC.Tc.Zonk.TcType + +import GHC.Rename.Bind ( rejectBootDecls ) +import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) +import GHC.Rename.HsType +import GHC.Rename.Expr +import GHC.Rename.Fixity ( lookupFixityRn ) +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Module +import GHC.Rename.Doc +import GHC.Rename.Utils ( mkNameClashErr, mkRnSyntaxExpr ) + +import GHC.Iface.Decl ( coAxiomToIfaceDecl ) +import GHC.Iface.Env ( externaliseName ) +import GHC.Iface.Load + +import GHC.Builtin.Types ( mkListTy, anyTypeOfKind ) +import GHC.Builtin.Names +import GHC.Builtin.Utils + +import GHC.Hs hiding ( FunDep(..) ) +import GHC.Hs.Dump + +import GHC.Core.PatSyn +import GHC.Core.Predicate ( classMethodTy ) +import GHC.Core.InstEnv +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.Reduction ( Reduction(..) ) +import GHC.Core.TyCo.Ppr( debugPprType ) +import GHC.Core.TyCo.Tidy( tidyTopType ) +import GHC.Core.FamInstEnv + ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst + , famInstEnvElts, extendFamInstEnvList, normaliseType ) + +import GHC.Parser.Header ( mkPrelImports ) + +import GHC.IfaceToCore + +import GHC.Runtime.Context + +import GHC.Utils.Error +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Logger + +import GHC.Types.Error +import GHC.Types.Name.Reader +import GHC.Types.DefaultEnv +import GHC.Types.Fixity.Env +import GHC.Types.Id as Id +import GHC.Types.Id.Info( IdDetails(..) ) +import GHC.Types.Var.Env +import GHC.Types.TypeEnv +import GHC.Types.Unique.FM +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Types.Annotations +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Unit.Env as UnitEnv +import GHC.Unit.External +import GHC.Unit.Types +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.Deps +import GHC.Driver.Downsweep + +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.List.SetOps +import GHC.Data.Bag +import qualified GHC.Data.BooleanFormula as BF + +import Control.Arrow ( second ) +import Control.DeepSeq +import Control.Monad +import Control.Monad.Trans.Writer.CPS +import Data.Data ( Data ) +import Data.Function (on) +import Data.Functor.Classes ( liftEq ) +import Data.List ( sort, sortBy ) +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified Data.List.NonEmpty as NE +import Data.Ord +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Foldable ( for_ ) +import Data.Traversable ( for ) +import Data.IORef( newIORef ) + + + +{- +************************************************************************ +* * + Typecheck and rename a module +* * +************************************************************************ +-} + +-- | Top level entry point for typechecker and renamer +tcRnModule :: HscEnv + -> ModSummary + -> Bool -- True <=> save renamed syntax + -> HsParsedModule + -> IO (Messages TcRnMessage, Maybe TcGblEnv) + +tcRnModule hsc_env mod_sum save_rn_syntax + parsedModule@HsParsedModule {hpm_module= L loc this_module} + | RealSrcSpan real_loc _ <- loc + = withTiming logger + (text "Renamer/typechecker"<+>brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ + withTcPlugins hsc_env $ + withDefaultingPlugins hsc_env $ + withHoleFitPlugins hsc_env $ + + tcRnModuleTcRnM hsc_env mod_sum parsedModule pair + + | otherwise + = return (err_msg `addMessage` emptyMessages, Nothing) + + where + hsc_src = ms_hsc_src mod_sum + logger = hsc_logger hsc_env + home_unit = hsc_home_unit hsc_env + err_msg = mkPlainErrorMsgEnvelope loc $ + TcRnModMissingRealSrcSpan this_mod + + pair :: (Module, SrcSpan) + pair@(this_mod,_) + | Just (L mod_loc mod) <- hsmodName this_module + = (mkHomeModule home_unit mod, locA mod_loc) + + | otherwise -- 'module M where' is omitted + = (mkHomeModule home_unit mAIN_NAME, srcLocSpan (srcSpanStart loc)) + + + + +tcRnModuleTcRnM :: HscEnv + -> ModSummary + -> HsParsedModule + -> (Module, SrcSpan) + -> TcRn TcGblEnv +-- Factored out separately from tcRnModule so that a Core plugin can +-- call the type checker directly +tcRnModuleTcRnM hsc_env mod_sum + (HsParsedModule { + hpm_module = + (L loc (HsModule (XModulePs _ _ mod_deprec maybe_doc_hdr) + maybe_mod export_ies import_decls local_decls)), + hpm_src_files = src_files + }) + (this_mod, prel_imp_loc) + = setSrcSpan loc $ + do { let { explicit_mod_hdr = isJust maybe_mod + ; hsc_src = ms_hsc_src mod_sum } + ; -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + tcg_env <- getGblEnv + ; boot_info <- tcHiBootIface hsc_src this_mod + ; setGblEnv (tcg_env { tcg_self_boot = boot_info }) + $ do + { -- Deal with imports; first add implicit prelude + implicit_prelude <- xoptM LangExt.ImplicitPrelude + ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc + implicit_prelude import_decls } + + ; when (notNull prel_imports) $ do + addDiagnostic TcRnImplicitImportOfPrelude + + ; -- TODO This is a little skeevy; maybe handle a bit more directly + let { simplifyImport (L _ idecl) = + ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl) + , reLoc $ ideclName idecl) + } + ; raw_sig_imports <- liftIO + $ findExtraSigImports hsc_env hsc_src + (moduleName this_mod) + ; raw_req_imports <- liftIO + $ implicitRequirements hsc_env + (map simplifyImport (prel_imports + ++ import_decls)) + ; let { mkImport mod_name = noLocA + $ (simpleImportDecl mod_name) + { ideclImportList = Just (Exactly, noLocA [])}} + ; let { withReason t imps = map (,text t) imps } + ; let { all_imports = withReason "is implicitly imported" prel_imports + ++ withReason "is directly imported" import_decls + ++ withReason "is an extra sig import" (map mkImport raw_sig_imports) + ++ withReason "is an implicit req import" (map mkImport raw_req_imports) } + ; -- OK now finally rename the imports + (defaultImportsByClass, tcg_env) <- + {-# SCC "tcRnImports" #-} tcRnImports hsc_env all_imports + + -- Put a version of the header without identifier info into the tcg_env + -- Make sure to do this before 'tcRnSrcDecls', because we need the + -- module header when we're splicing TH, since it can be accessed via + -- 'getDoc'. + -- We will rename it properly after renaming everything else so that + -- haddock can link the identifiers + ; tcg_env <- return (tcg_env + { tcg_hdr_info = (fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str []) + <$> maybe_doc_hdr , maybe_mod ) }) + ; -- If the whole module is warned about or deprecated + -- (via mod_deprec) record that in tcg_warns. If we do thereby add + -- a WarnAll, it will override any subsequent deprecations added to tcg_warns + ; tcg_env1 <- case mod_deprec of + Just (L _ txt) -> do { txt' <- rnWarningTxt txt + ; pure $ tcg_env {tcg_warns = WarnAll txt'} + } + Nothing -> pure tcg_env + ; setGblEnv tcg_env1 + $ do { -- Rename and type check the declarations + traceRn "rn1a" empty + ; tcg_env <- + case hsc_src of + -- See Note [Don't typecheck GHC.Internal.Prim] + _ | tcg_mod tcg_env1 == gHC_PRIM -> pure tcg_env1 + + HsBootOrSig boot_or_sig -> + do { tcg_env <- tcRnHsBootDecls boot_or_sig local_decls + ; traceRn "rn4a: before exports" empty + ; tcg_env <- setGblEnv tcg_env $ + rnExports explicit_mod_hdr export_ies + ; traceRn "rn4b: after exports" empty + ; return tcg_env + } + HsSrcFile -> + {-# SCC "tcRnSrcDecls" #-} + tcRnSrcDecls explicit_mod_hdr export_ies local_decls + + ; whenM (goptM Opt_DoCoreLinting) $ + lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env + + ; setGblEnv tcg_env + $ do { -- Compare hi-boot iface (if any) with the real thing + -- Must be done after processing the exports + tcg_env <- checkHiBootIface tcg_env boot_info + ; -- The new type env is already available to stuff + -- slurped from interface files, via + -- GHC.Tc.Utils.Env.setGlobalTypeEnv. It's important that this + -- includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for + -- boot_dfuns, which may be mentioned in imported + -- unfoldings. + ; -- Report unused names + -- Do this /after/ type inference, so that when reporting + -- a function with no type signature we can give the + -- inferred type + ; reportUnusedNames tcg_env hsc_src + ; reportClashingDefaultImports defaultImportsByClass (tcg_default tcg_env) + + -- 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_hdr_info = (maybe_doc_hdr, maybe_mod) }) + + ; -- add extra source files to tcg_dependent_files + addDependentFiles src_files + -- Ensure plugins run with the same tcg_env that we pass in + ; setGblEnv tcg_env + $ do { tcg_env <- runTypecheckerPlugin mod_sum tcg_env + ; -- Dump output and return + tcDump tcg_env + ; return tcg_env + } + } + } + } + } + +{- Note [Don't typecheck GHC.Internal.Prim] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC (currently) can't type-check GHC.Internal.Prim, as that module +contains primitive functions that can't be defined in source Haskell. +The GHC.Internal.Prim source file is only used to generate Haddock documentation; +the actual contents of the module are wired in to GHC. +-} + +{- Note [Disambiguation of multiple default declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +See Note [Named default declarations] in GHC.Tc.Gen.Default + +Only a single default declaration can be in effect in any single module for +any particular class. + +* Two declarations for the same class explicitly declared in the same module + are considered a static error. + +* Definition: given two default declarations for the same class + + default C (Type_1a , … , Type_ma) + default C (Type_1b , … , Type_nb) + + if the first type sequence Type_1a , … , Type_ma is a sub-sequence of the + second sequence Type_1b , … , Type_nb (i.e., the former can be obtained by + removing a number of Type_ib items from the latter), we say that the second + declaration *subsumes* the first one. + +* A default declaration in a module takes precedence over any imported default + declarations for the same class. However the compiler warns the user if an + imported declaration is not subsumed by the local declaration. + +* For any two imported default declarations for the same class where one + subsumes the other, we ignore the subsumed declaration. + +* If a class has neither a local default declaration nor an imported default + declaration that subsumes all other imported default declarations for the + class, the conflict between the imports is unresolvable. The effect is to + ignore all default declarations for the class, so that no declaration is in + effect in the module. The compiler emits a warning in this case, but no + error. +-} + +-- See Note [Disambiguation of multiple default declarations] +-- | Warn about any imported default declaration that is not subsumed by either +-- a local or an imported default declaration. +reportClashingDefaultImports :: [NonEmpty ClassDefaults] -> DefaultEnv -> TcM () +reportClashingDefaultImports importsByClass local = mapM_ check importsByClass + where + check cds@(ClassDefaults{cd_class = cls} :| _) = do + let cdLocal = lookupDefaultEnv local (className cls) + case cdLocal of + Just ClassDefaults{cd_types = localTypes} + | all ((`isTypeSubsequenceOf` localTypes) . cd_types) cds -> pure () + Nothing + | not (isEmptyDefaultEnv $ subsume cds) -> pure () + _ -> do + warn_default <- woptM Opt_WarnTypeDefaults + diagnosticTc warn_default $ + TcRnWarnClashingDefaultImports cls (cd_types <$> cdLocal) cds + +-- | Collapse a non-empty list of @default@ declarations for the same class to +-- the single declaration among them that subsumes all others, or to no +-- declaration otherwise. +subsume :: NonEmpty ClassDefaults -> DefaultEnv +subsume (deft :| []) = unitDefaultEnv deft +subsume (deft :| deft' : defts) + | cd_types deft `isTypeSubsequenceOf` cd_types deft' = subsume (deft' :| defts) + | cd_types deft' `isTypeSubsequenceOf` cd_types deft = subsume (deft :| defts) + | otherwise = emptyDefaultEnv + +isTypeSubsequenceOf :: [Type] -> [Type] -> Bool +isTypeSubsequenceOf [] _ = True +isTypeSubsequenceOf _ [] = False +isTypeSubsequenceOf (t1:t1s) (t2:t2s) + | tcEqType t1 t2 = isTypeSubsequenceOf t1s t2s + | otherwise = isTypeSubsequenceOf (t1:t1s) t2s + +{- +************************************************************************ +* * + Import declarations +* * +************************************************************************ +-} + +tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM ([NonEmpty ClassDefaults], TcGblEnv) +tcRnImports hsc_env import_decls + = do { (rn_imports, imp_user_spec, rdr_env, imports) <- rnImports import_decls + -- Get the default declarations for the classes imported by this module + -- and group them by class. + ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList)) + <$> tcGetClsDefaults (M.keys $ imp_mods imports) + ; this_mod <- getModule + ; gbl_env <- getGblEnv + ; let unitId = homeUnitId $ hsc_home_unit hsc_env + mnwib = GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env)) + ; -- We want instance declarations from all home-package + -- modules below this one, including boot modules, except + -- ourselves. The 'except ourselves' is so that we don't + -- get the instances from this module's hs-boot file. This + -- filtering also ensures that we don't see instances from + -- modules batch (@--make@) compiled before this one, but + -- which are not below this one. + ; (home_insts, home_fam_insts) <- liftIO $ + hugInstancesBelow hsc_env unitId mnwib + + -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations + -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad + -- and see https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14274#note_620545 + ; completeSigsBelow <- liftIO $ unsafeInterleaveIO $ + hugCompleteSigsBelow hsc_env unitId mnwib + + -- Record boot-file info in the EPS, so that it's + -- visible to loadHiBootInterface in tcRnSrcDecls, + -- and any other incrementally-performed imports + ; when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do { + updateEps_ $ \eps -> eps { eps_is_boot = imp_boot_mods imports } + } + + -- Update the gbl env + ; updGblEnv ( \ gbl -> + gbl { + tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_complete_match_env = tcg_complete_match_env gbl ++ + completeSigsBelow, + tcg_import_decls = imp_user_spec, + tcg_rn_imports = rn_imports, + tcg_default = foldMap subsume tc_defaults, + tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + home_fam_insts + }) $ do { + + ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) + -- Fail if there are any errors so far + -- The error printing (if needed) takes advantage + -- of the tcg_env we have now set +-- ; traceIf (text "rdr_env: " <+> ppr rdr_env) + ; failIfErrsM + + -- Load any orphan-module (including orphan family + -- instance-module) interfaces, so that their rules and + -- instance decls will be found. But filter out a + -- self hs-boot: these instances will be checked when + -- we define them locally. + -- (We don't need to load non-orphan family instance + -- modules until we either try to use the instances they + -- define, or define our own family instances, at which + -- point we need to check them for consistency.) + ; loadModuleInterfaces (text "Loading orphan modules") + (filter (/= this_mod) (imp_orphs imports)) + + -- Check type-family consistency between imports. + -- See Note [The type family instance consistency story] + ; traceRn "rn1: checking family instance consistency {" empty + ; let { dir_imp_mods = M.keys + . imp_mods + $ imports } + ; logger <- getLogger + ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ()) + $ checkFamInstConsistency dir_imp_mods + ; traceRn "rn1: } checking family instance consistency" empty + + ; gbl_env <- getGblEnv + ; return (tc_defaults, gbl_env) } } + +{- +************************************************************************ +* * + Type-checking the top level of a module +* * +************************************************************************ +-} + +tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (LocatedLI [LIE GhcPs]) + -> [LHsDecl GhcPs] -- Declarations + -> TcM TcGblEnv +tcRnSrcDecls explicit_mod_hdr export_ies decls + = do { -- Do all the declarations + ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls + + ------ Simplify constraints --------- + -- + -- We do this after checkMainType, so that we use the type + -- info that checkMainType adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to simplifyTop, + -- and affects how names are rendered in error messages + -- * the local env exposes the local Ids to simplifyTop, + -- so that we get better error messages (monomorphism restriction) + ; new_ev_binds <- {-# SCC "simplifyTop" #-} + restoreEnvs (tcg_env, tcl_env) $ + do { lie_main <- checkMainType tcg_env + ; simplifyTop (lie `andWC` lie_main) } + + -- Emit Typeable bindings + ; tcg_env <- setGblEnv tcg_env $ + mkTypeableBinds + + ; traceTc "Tc9" empty + ; failIfErrsM -- Stop now if if there have been errors + -- Continuing is a waste of time; and we may get debug + -- warnings when zonking about strangely-typed TyCons! + + -- Zonk the final code. This must be done last. + -- Even simplifyTop may do some unification. + -- This pass also warns about missing type signatures + ; (id_env, ev_binds', binds', fords', imp_specs', rules') + <- zonkTcGblEnv new_ev_binds tcg_env + + --------- Run finalizers -------------- + -- Finalizers must run after constraints are simplified, lest types + -- might not be complete when using reify (see #12777). + -- and also after we zonk the first time because we run typed splices + -- in the zonker which gives rise to the finalisers. + ; let -- init_tcg_env: + -- * Remove accumulated bindings, rules and so on from + -- TcGblEnv. They are now in ev_binds', binds', etc. + -- * Add the zonked Ids from the value bindings to tcg_type_env + -- Up to now these Ids are only in tcl_env's type-envt + init_tcg_env = tcg_env { tcg_binds = [] + , tcg_ev_binds = emptyBag + , tcg_imp_specs = [] + , tcg_rules = [] + , tcg_fords = [] + , tcg_type_env = tcg_type_env tcg_env + `plusTypeEnv` id_env } + ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env + run_th_modfinalizers + ; finishTH + ; traceTc "Tc11" empty + + --------- Deal with the exports ---------- + -- Can't be done earlier, because the export list must "see" + -- the declarations created by the finalizers + ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $ + rnExports explicit_mod_hdr export_ies + + --------- Emit the ':Main.main = runMainIO main' declaration ---------- + -- Do this /after/ rnExports, so that it can consult + -- the tcg_exports created by rnExports + ; (tcg_env, main_ev_binds) + <- restoreEnvs (tcg_env, tcl_env) $ + do { (tcg_env, lie) <- captureTopConstraints $ + checkMain explicit_mod_hdr export_ies + ; ev_binds <- simplifyTop lie + ; return (tcg_env, ev_binds) } + + ; failIfErrsM -- Stop now if if there have been errors + -- Continuing is a waste of time; and we may get debug + -- warnings when zonking about strangely-typed TyCons! + + ---------- Final zonking --------------- + -- Zonk the new bindings arising from running the finalisers, + -- and main. This won't give rise to any more finalisers as you + -- can't nest finalisers inside finalisers. + ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) + <- zonkTcGblEnv main_ev_binds tcg_env + + ; let { !final_type_env = tcg_type_env tcg_env + `plusTypeEnv` id_env_mf + -- Add the zonked Ids from the value bindings (they were in tcl_env) + -- Force !final_type_env, lest we retain an old reference + -- to the previous tcg_env + + ; tcg_env' = tcg_env + { tcg_binds = binds' ++ binds_mf + , tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf + , tcg_imp_specs = imp_specs' ++ imp_specs_mf + , tcg_rules = rules' ++ rules_mf + , tcg_fords = fords' ++ fords_mf } } ; + + ; setGlobalTypeEnv tcg_env' final_type_env + } + +zonkTcGblEnv :: Bag EvBind -> TcGblEnv + -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, + [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc]) +zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds = binds + , tcg_ev_binds = cur_ev_binds + , tcg_imp_specs = imp_specs + , tcg_rules = rules + , tcg_fords = fords }) + = {-# SCC "zonkTopDecls" #-} + setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering + -- error messages during zonking (notably levity errors) + do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds + ; zonkTopDecls all_ev_binds binds rules imp_specs fords } + +-- | Runs TH finalizers and renames and typechecks the top-level declarations +-- that they could introduce. +run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv) +run_th_modfinalizers = do + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + th_modfinalizers <- readTcRef th_modfinalizers_var + if null th_modfinalizers + then getEnvs + else do + writeTcRef th_modfinalizers_var [] + let run_finalizer (lcl_env, f) = + restoreLclEnv lcl_env (runRemoteModFinalizers f) + + (_, lie_th) <- captureTopConstraints $ + mapM_ run_finalizer th_modfinalizers + + -- Finalizers can add top-level declarations with addTopDecls, so + -- we have to run tc_rn_src_decls to get them + (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls [] + + restoreEnvs (tcg_env, tcl_env) $ do + -- Subsequent rounds of finalizers run after any new constraints are + -- simplified, or some types might not be complete when using reify + -- (see #12777). + new_ev_binds <- {-# SCC "simplifyTop2" #-} + simplifyTop (lie_th `andWC` lie_top_decls) + addTopEvBinds new_ev_binds run_th_modfinalizers + -- addTopDecls can add declarations which add new finalizers. + +tc_rn_src_decls :: [LHsDecl GhcPs] + -> TcM (TcGblEnv, TcLclEnv, WantedConstraints) +-- Loops around dealing with each top level inter-splice group +-- in turn, until it's dealt with the entire module +-- Never emits constraints; calls captureTopConstraints internally +tc_rn_src_decls ds + = {-# SCC "tc_rn_src_decls" #-} + do { (first_group, group_tail) <- findSplice ds + -- If ds is [] we get ([], Nothing) + + -- Deal with decls up to, but not including, the first splice + ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group + -- rnTopSrcDecls fails if there are any errors + + -- Get TH-generated top-level declarations and make sure they don't + -- contain any splices since we don't handle that at the moment + -- + -- The plumbing here is a bit odd: see #10853 + ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv + ; th_ds <- readTcRef th_topdecls_var + ; writeTcRef th_topdecls_var [] + + ; (tcg_env, rn_decls) <- + if null th_ds + then return (tcg_env, rn_decls) + else do { (th_group, th_group_tail) <- findSplice th_ds + ; case th_group_tail of + { Nothing -> return () + ; Just (SpliceDecl _ (L loc _) _, _) -> + setSrcSpanA loc $ addErr $ + TcRnTHError $ AddTopDeclsError + AddTopDeclsUnexpectedDeclarationSplice + } + -- Rename TH-generated top-level declarations + ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env + $ rnTopSrcDecls th_group + + -- Dump generated top-level declarations + ; let msg = "top-level declarations added with 'addTopDecls'" + ; traceSplice + $ SpliceInfo { spliceDescription = msg + , spliceIsDecl = True + , spliceSource = Nothing + , spliceGenerated = ppr th_rn_decls } + ; return (tcg_env, appendGroups rn_decls th_rn_decls) + } + + -- Type check all declarations + -- NB: set the env **before** captureTopConstraints so that error messages + -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that + -- the captureTopConstraints must go here, not in tcRnSrcDecls. + ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $ + captureTopConstraints $ + tcTopSrcDecls rn_decls + + -- If there is no splice, we're nearly done + ; restoreEnvs (tcg_env, tcl_env) $ + case group_tail of + { Nothing -> return (tcg_env, tcl_env, lie1) + + -- If there's a splice, we must carry on + ; Just (SpliceDecl _ (L _ splice) _, rest_ds) -> + do { + -- We need to simplify any constraints from the previous declaration + -- group, or else we might reify metavariables, as in #16980. + ; ev_binds1 <- simplifyTop lie1 + + -- Rename the splice expression, and get its supporting decls + ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice + + -- Glue them on the front of the remaining decls and loop + ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + addTopEvBinds ev_binds1 $ + tc_rn_src_decls (spliced_decls ++ rest_ds) + } + } + } + +{- +************************************************************************ +* * + Compiling hs-boot source files, and + comparing the hi-boot interface with the real thing +* * +************************************************************************ +-} + +tcRnHsBootDecls :: HsBootOrSig -> [LHsDecl GhcPs] -> TcM TcGblEnv +tcRnHsBootDecls boot_or_sig decls + = do { (first_group, group_tail) <- findSplice decls + + -- Rename the declarations + ; (tcg_env, HsGroup { hs_tyclds = tycl_decls + , hs_derivds = deriv_decls + , hs_fords = for_decls + , hs_defds = def_decls + , hs_ruleds = rule_decls + , hs_annds = _ + , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) }) + <- rnTopSrcDecls first_group + + ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do { + -- NB: setGblEnv **before** captureTopConstraints so that + -- if the latter reports errors, it knows what's in scope + + -- Check for illegal declarations + ; case group_tail of + Just (SpliceDecl _ d _, _) -> rejectBootDecls boot_or_sig BootSpliceDecls [d] + Nothing -> return () + ; rejectBootDecls boot_or_sig BootForeignDecls for_decls + ; rejectBootDecls boot_or_sig BootDefaultDecls def_decls + ; rejectBootDecls boot_or_sig BootRuleDecls rule_decls + + -- Typecheck type/class/instance decls + ; traceTc "Tc2 (boot)" empty + ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs) + <- tcTyClsInstDecls tycl_decls deriv_decls def_decls val_binds + ; setGblEnv tcg_env $ do { + + -- Emit Typeable bindings + ; tcg_env <- mkTypeableBinds + ; setGblEnv tcg_env $ do { + + -- Typecheck value declarations + ; traceTc "Tc5" empty + ; val_ids <- tcHsBootSigs val_binds val_sigs + + -- Wrap up + -- No simplification or zonking to do + ; traceTc "Tc7a" empty + ; gbl_env <- getGblEnv + + -- Make the final type-env + -- Include the dfun_ids so that their type sigs + -- are written into the interface file. + ; let { type_env0 = tcg_type_env gbl_env + ; type_env1 = extendTypeEnvWithIds type_env0 val_ids + ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids + ; dfun_ids = map iDFunId inst_infos + } + + ; setGlobalTypeEnv gbl_env type_env2 + }}} + ; traceTc "boot" (ppr lie); return gbl_env } + +{- +Once we've typechecked the body of the module, we want to compare what +we've found (gathered in a TypeEnv) with the hi-boot details (if any). +-} + +checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv +-- Compare the hi-boot file for this module (if there is one) +-- with the type environment we've just come up with +-- In the common case where there is no hi-boot file, the list +-- of boot_names is empty. + +checkHiBootIface tcg_env boot_info + | NoSelfBoot <- boot_info -- Common case + = return tcg_env + + | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file! + = return tcg_env + + | SelfBoot { sb_mds = boot_details } <- boot_info + , TcGblEnv { tcg_binds = binds + , tcg_insts = local_insts + , tcg_type_env = local_type_env + , tcg_exports = local_exports } <- tcg_env + = do { -- This code is tricky, see Note [DFun knot-tying] + ; imp_prs <- checkHiBootIface' local_insts local_type_env + local_exports boot_details + + -- Now add the impedance-matching boot bindings: + -- + -- - dfun bindings $fxblah = $fblah + -- - record bindings fld{var} = fld{rec field of ..} + -- + -- to (a) the type envt, and (b) the top-level bindings + ; let boot_impedance_bds = map fst imp_prs + type_env' = extendTypeEnvWithIds local_type_env boot_impedance_bds + impedance_binds = [ mkVarBind boot_id (nlHsVar id) + | (boot_id, id) <- imp_prs ] + tcg_env_w_binds + = tcg_env { tcg_binds = binds ++ impedance_binds } + + ; type_env' `seq` + -- Why the seq? Without, we will put a TypeEnv thunk in + -- tcg_type_env_var. That thunk will eventually get + -- forced if we are typechecking interfaces, but that + -- is no good if we are trying to typecheck the very + -- DFun we were going to put in. + -- TODO: Maybe setGlobalTypeEnv should be strict. + setGlobalTypeEnv tcg_env_w_binds type_env' } + +{- Note [DFun impedance matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We return a list of "impedance-matching" bindings for the dfuns +defined in the hs-boot file, such as + $fxEqT = $fEqT +We need these because the module and hi-boot file might differ in +the name it chose for the dfun: the name of a dfun is not +uniquely determined by its type; there might be multiple dfuns +which, individually, would map to the same name (in which case +we have to disambiguate them.) There's no way for the hi file +to know exactly what disambiguation to use... without looking +at the hi-boot file itself. + +In fact, the names will always differ because we always pick names +prefixed with "$fx" for boot dfuns, and "$f" for real dfuns +(so that this impedance matching is always possible). + +Note [Record field impedance matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a hs-boot file defines a function whose implementation in the hs file +is a record selector, we have to do something similar to Note [DFun impedance matching]. + +Example: + + -- M.hs-boot + module M where + data A + fld :: A -> () + + -- M.hs + module M where + data A = MkA { fld :: () } + +Recall from Note [Record field namespacing] in GHC.Types.Name.Occurrence that +record fields have their own namespaces. This means that M.hs exports the Id +fld{record selector of MkA} :: A -> (), while M.hs-boot exports the Id +fld{variable} :: A -> (). + +To remedy this, we add an impedance-matching binding in M.hs: + + fld{variable} :: A -> () + fld{variable} = fld{record selector of MkA} + +Note that we imperatively need to add a binding for fld{variable} in M.hs, as we +might have an exact Name reference to it (e.g. in a module that imports M.hs-boot). +Not doing so would cause Core Lint errors, at the very least. + +These bindings are returned by the check_export in checkHiBootIface', and +added to the DFun impedance-matching bindings. + +[Wrinkle: exports] + + We MUST NOT add fld{variable} to the export list of M.hs, as this + would mean that M.hs exports both a record field and variable with the same + occNameFS, which would cause ambiguity errors at use-sites. + It's OK to only export the field name even though the boot-file exported + the variable: name resolution will take care of that. + +Another situation is that we are re-exporting, e.g. (with M as above): + + -- N.hs-boot + module N ( module M ) where + import {-# SOURCE #-} M + + -- N.hs + module N ( module M where ) + import M + +In this case, N.hs-boot re-exports the variable fld, and N re-exports the +record field fld, but not the variable fld. We don't need to do anything in +this situation; in particular, don't re-export the variable name from N.hs, +as per [Wrinkle: exports] above. + +Note [DFun knot-tying] +~~~~~~~~~~~~~~~~~~~~~~ +The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from +typechecking the hi-boot file that we are presently implementing. +Suppose we are typechecking the module A: when we typecheck the +hi-boot file, whenever we see an identifier A.T, we knot-tie this +identifier to the *local* type environment (via if_rec_types.) The +contract then is that we don't *look* at 'SelfBootInfo' until we've +finished typechecking the module and updated the type environment with +the new tycons and ids. + +This most works well, but there is one problem: DFuns! We do not want +to look at the mb_insts of the ModDetails in SelfBootInfo, because a +dfun in one of those ClsInsts is gotten (in GHC.IfaceToCore.tcIfaceInst) by a +(lazily evaluated) lookup in the if_rec_types. We could extend the +type env, do a setGloblaTypeEnv etc; but that all seems very indirect. +It is much more directly simply to extract the DFunIds from the +md_types of the SelfBootInfo. + +See #4003, #16038 for why we need to take care here. +-} + +checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] + -> ModDetails -> TcM [(Id, Id)] +-- Variant which doesn't require a full TcGblEnv; you could get the +-- local components from another ModDetails. +checkHiBootIface' + local_insts local_type_env local_exports + (ModDetails { md_types = boot_type_env + , md_fam_insts = boot_fam_insts + , md_exports = boot_exports }) + = do { traceTc "checkHiBootIface" $ vcat + [ ppr boot_type_env, ppr boot_exports ] + + ; mod <- tcg_mod <$> getGblEnv + + -- See Note [Don't typecheck GHC.Internal.Prim] + ; if mod == gHC_PRIM then pure [] else do { + + ; gre_env <- getGlobalRdrEnv + + -- Check the exports of the boot module, one by one + ; fld_prs <- mapMaybeM (check_export gre_env) boot_exports + + -- Check for no family instances + ; unless (null boot_fam_insts) $ + panic ("GHC.Tc.Module.checkHiBootIface: Cannot handle family " ++ + "instances in boot files yet...") + -- FIXME: Why? The actual comparison is not hard, but what would + -- be the equivalent to the dfun bindings returned for class + -- instances? We can't easily equate tycons... + + -- Check instance declarations + -- and generate an impedance-matching binding + ; dfun_prs <- mapMaybeM check_cls_inst boot_dfuns + + ; failIfErrsM + + ; return (fld_prs ++ dfun_prs) }} + + where + boot_dfun_names = map idName boot_dfuns + boot_dfuns = filter isDFunId $ typeEnvIds boot_type_env + -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts + -- We don't want to look at md_insts! + -- Why not? See Note [DFun knot-tying] + + check_export gre_env boot_avail -- boot_avail is exported by the boot iface + | name `elem` boot_dfun_names + = return Nothing + + -- Check that the actual module exports the same thing + | missing_name:_ <- missing_names + = -- Lookup might have failed because the hs-boot file defines a variable + -- that is implemented in the hs file as a record selector, which + -- lives in a different namespace. + -- + -- See Note [Record field impedance matching]. + let missing_occ = nameOccName missing_name + mb_ok :: GlobalRdrElt -> Maybe (GlobalRdrElt, Maybe Id) + mb_ok gre + -- Ensure that this GRE refers to an Id that is exported. + | isNothing $ lookupNameEnv local_export_env (greName gre) + = Nothing + -- We locally define the field: create an impedance-matching + -- binding for the variable. + | Just (AnId id) <- lookupTypeEnv local_type_env (greName gre) + = Just (gre, Just id) + -- We are re-exporting the field but not the variable: not a problem, + -- as per [Wrinkle: exports] in Note [Record field impedance matching]. + | otherwise + = Just (gre, Nothing) + matching_flds + | isVarOcc missing_occ -- (This only applies to variables.) + = lookupGRE gre_env $ + LookupOccName missing_occ (RelevantGREsFOS WantField) + | otherwise + = [] -- BootFldReexport T18999_NoDisambiguateRecordFields T16745A + + in case mapMaybe mb_ok $ matching_flds of + + -- At least 2 matches: report an ambiguity error. + (gre1,_):(gre2,_):gres_ids -> do + addErrAt (nameSrcSpan missing_name) $ + mkNameClashErr gre_env (nameRdrName missing_name) + (gre1 NE.:| gre2 : map fst gres_ids) + return Nothing + + -- Single match: resolve the issue. + [(_,mb_fld_id)] -> + -- See Note [Record field impedance matching]. + for mb_fld_id $ \ fld_id -> do + let local_boot_var = + Id.mkExportedVanillaId missing_name (idType fld_id) + return (local_boot_var, fld_id) + + -- Otherwise: report that the hs file does not export something + -- that the hs-boot file exports. + [] -> do + addErrAt (nameSrcSpan missing_name) + (missingBootThing HsBoot missing_name MissingBootExport) + return Nothing + + -- If the boot module does not *define* the thing, we are done + -- (it simply re-exports it, and names match, so nothing further to do) + | isNothing mb_boot_thing + = return Nothing + + -- Check that the actual module also defines the thing, and + -- then compare the definitions + | Just real_thing <- lookupTypeEnv local_type_env name, + Just boot_thing <- mb_boot_thing + = do checkBootDeclM HsBoot boot_thing real_thing + return Nothing + + | otherwise + = do addErrTc (missingBootThing HsBoot name MissingBootDefinition) + return Nothing + where + name = availName boot_avail + mb_boot_thing = lookupTypeEnv boot_type_env name + missing_names = case lookupNameEnv local_export_env name of + Nothing -> [name] + Just avail -> availNames boot_avail + `minusList` availNames avail + + local_export_env :: NameEnv AvailInfo + local_export_env = availsToNameEnv local_exports + + check_cls_inst :: DFunId -> TcM (Maybe (Id,Id)) + -- Returns a pair of the boot dfun in terms of the equivalent + -- real dfun. Delicate (like checkBootDecl) because it depends + -- on the types lining up precisely even to the ordering of + -- the type variables in the foralls. + check_cls_inst boot_dfun + | (real_dfun : _) <- find_real_dfun boot_dfun + , let dfun_name = idName boot_dfun + local_boot_dfun = Id.mkExportedVanillaId dfun_name (idType real_dfun) + = return $ Just (local_boot_dfun, real_dfun) + -- Two tricky points here: + -- + -- * The local_boot_fun should have a Name from the /boot-file/, + -- but type from the dfun defined in /this module/. + -- That ensures that the TyCon etc inside the type are + -- the ones defined in this module, not the ones gotten + -- from the hi-boot file, which may have a lot less info + -- (#8743, comment:10). + -- + -- * The DFunIds from boot_details are /GlobalIds/, because + -- they come from typechecking M.hi-boot. + -- But all bindings in this module should be for /LocalIds/, + -- otherwise dependency analysis fails (#16038). This + -- is another reason for using mkExportedVanillaId, rather + -- that modifying boot_dfun, to make local_boot_fun. + -- + -- See Note [DFun impedance matching]. + + | otherwise + = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ + do { traceTc "check_cls_inst" $ vcat + [ text "local_insts" <+> + vcat (map (ppr . idType . instanceDFunId) local_insts) + , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ] + + ; addErrTc $ TcRnBootMismatch HsBoot + $ MissingBootInstance boot_dfun + ; return Nothing } + + find_real_dfun :: DFunId -> [DFunId] + find_real_dfun boot_dfun + = [dfun | inst <- local_insts + , let dfun = instanceDFunId inst + , idType dfun `eqType` boot_dfun_ty ] + where + boot_dfun_ty = idType boot_dfun + + +-- In general, to perform these checks we have to +-- compare the TyThing from the .hi-boot file to the TyThing +-- in the current source file. We must be careful to allow alpha-renaming +-- where appropriate, and also the boot declaration is allowed to omit +-- constructors and class methods. +-- +-- See rnfail055 for a good test of this stuff. + +-- | Compares two things for equivalence between boot-file and normal code, +-- reporting an error if they don't match up. +checkBootDeclM :: HsBootOrSig + -> TyThing -- ^ boot thing + -> TyThing -- ^ real thing + -> TcM () +checkBootDeclM boot_or_sig boot_thing real_thing + = for_ boot_errs $ \ boot_err -> + addErrAt span $ + TcRnBootMismatch boot_or_sig $ + BootMismatch boot_thing real_thing boot_err + where + boot_errs = execWriter $ checkBootDecl boot_or_sig boot_thing real_thing + + -- Here we use the span of the boot thing or, if it doesn't have a sensible + -- span, that of the real thing, + span + | let span = nameSrcSpan (getName boot_thing) + , isGoodSrcSpan span + = span + | otherwise + = nameSrcSpan (getName real_thing) + +-- | Writer monad for accumulating errors when comparing an hs-boot or +-- signature file with its implementing module. +type BootErrsM err = Writer [err] () + +-- | If the test in the first parameter is True, succeed. +-- Otherwise, record the given error. +check :: Bool -> err -> BootErrsM err +check True _ = checkSuccess +check False err = bootErr err + +-- | Record an error. +bootErr :: err -> BootErrsM err +bootErr err = tell [err] + +-- | A convenience synonym for a lack of errors, for @checkBootDecl@ and friends. +checkSuccess :: BootErrsM err +checkSuccess = return () + +-- | Map over the error types in an error-accumulating computation. +embedErrs :: (err1 -> err2) -> BootErrsM err1 -> BootErrsM err2 +embedErrs f = mapWriter (second (fmap f)) + +-- | Wrap up a list of errors into a single message. +wrapErrs :: (NE.NonEmpty err1 -> err2) -> BootErrsM err1 -> BootErrsM err2 +wrapErrs f w = + case execWriter w of + [] -> checkSuccess + err : errs -> bootErr (f $ err :| errs) + +-- | Compares the two things for equivalence between boot-file and normal +-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ +-- failure. If the difference will be apparent to the user, @Just empty@ is +-- perfectly suitable. +checkBootDecl :: HsBootOrSig -> TyThing -> TyThing -> BootErrsM BootMismatchWhat + +checkBootDecl _ (AnId id1) (AnId id2) + = assert (id1 == id2) $ + check (idType id1 `eqType` idType id2) + (BootMismatchedIdTypes id1 id2) + +checkBootDecl boot_or_sig (ATyCon tc1) (ATyCon tc2) + = wrapErrs (BootMismatchedTyCons tc1 tc2) $ + checkBootTyCon boot_or_sig tc1 tc2 + +checkBootDecl _ t1 t2 + = pprPanic "checkBootDecl" (ppr t1 $$ ppr t2) + +-- | Run the check provided for every pair of elements in the lists. +-- +-- Records an error: +-- +-- - when any two items at the same position in the two lists don't match +-- according to the given function, +-- - when the lists are of different lengths. +checkListBy :: (a -> a -> BootErrsM err) -> [a] -> [a] + -> (BootListMismatches a err -> err2) + -> BootErrsM err2 +checkListBy check_fun as bs mk_err = wrapErrs mk_err $ go 1 as bs + where + go _ [] [] = checkSuccess + go !i (x:xs) (y:ys) = + do { embedErrs (MismatchedThing i x y) $ check_fun x y + ; go (i+1) xs ys } + go _ _ _ = bootErr MismatchedLength + +---------------- +checkBootTyCon :: HsBootOrSig -> TyCon -> TyCon -> BootErrsM BootTyConMismatch +checkBootTyCon boot_or_sig tc1 tc2 + | not (eqType (tyConKind tc1) (tyConKind tc2)) + -- First off, check the kind + = bootErr TyConKindMismatch + + | Just c1 <- tyConClass_maybe tc1 + , Just c2 <- tyConClass_maybe tc2 + , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1) + = classExtraBigSig c1 + (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) + = classExtraBigSig c2 + , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 + = do { check_roles + ; embedErrs (TyConMismatchedClasses c1 c2) $ + do { -- Checks kind of class + ; check (liftEq (eqFD env) clas_fds1 clas_fds2) + MismatchedFunDeps + ; unless (isAbstractTyCon tc1) $ + do { check (liftEq (eqTypeX env) sc_theta1 sc_theta2) + MismatchedSuperclasses + ; checkListBy (compatClassOp env boot_or_sig) op_stuff1 op_stuff2 + MismatchedMethods + ; checkListBy (compatAT env boot_or_sig) ats1 ats2 + MismatchedATs + ; check (classMinimalDef c1 `BF.implies` classMinimalDef c2) + MismatchedMinimalPragmas + } } } + + | Just syn_rhs1 <- synTyConRhs_maybe tc1 + , Just syn_rhs2 <- synTyConRhs_maybe tc2 + , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + = assert (tc1 == tc2) $ + do { check_roles + ; check (eqTypeX env syn_rhs1 syn_rhs2) $ + TyConSynonymMismatch syn_rhs1 syn_rhs2 } + + -- This allows abstract 'data T a' to be implemented using 'type T = ...' + -- and abstract 'class K a' to be implement using 'type K = ...' + -- See Note [Synonyms implement abstract data] + | Hsig <- boot_or_sig -- don't support for hs-boot yet + , isAbstractTyCon tc1 + , Just (tvs, ty) <- synTyConDefn_maybe tc2 + = checkSynAbsData tc1 tc2 tvs ty + + | Just fam_flav1 <- famTyConFlav_maybe tc1 + , Just fam_flav2 <- famTyConFlav_maybe tc2 + = assert (tc1 == tc2) $ + do { let injInfo1 = tyConInjectivityInfo tc1 + injInfo2 = tyConInjectivityInfo tc2 + ; -- check equality of roles, family flavours and injectivity annotations + -- (NB: Type family roles are always nominal. But the check is + -- harmless enough.) + ; check_roles + ; compatFamFlav fam_flav1 fam_flav2 + ; check (injInfo1 == injInfo2) TyConInjectivityMismatch } + + | isAlgTyCon tc1 && isAlgTyCon tc2 + , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + = assert (tc1 == tc2) $ + do { check_roles + ; let rhs1 = algTyConRhs tc1 + rhs2 = algTyConRhs tc2 + ; embedErrs (TyConMismatchedData rhs1 rhs2) $ + do { check (liftEq (eqTypeX env) + (tyConStupidTheta tc1) (tyConStupidTheta tc2)) + MismatchedDatatypeContexts + ; compatAlgRhs rhs1 rhs2 } } + + | otherwise = bootErr TyConsVeryDifferent + -- two very different types; + -- should be obvious to the user what the problem is + where + check_roles = checkRoles boot_or_sig tc1 (tyConRoles tc2) + + +emptyRnEnv2 :: RnEnv2 +emptyRnEnv2 = mkRnEnv2 emptyInScopeSet + +-- | Check that two class methods have compatible type signatures. +compatClassOp :: RnEnv2 -> HsBootOrSig -> ClassOpItem -> ClassOpItem -> BootErrsM BootMethodMismatch +compatClassOp env boot_or_sig (id1, def_meth1) (id2, def_meth2) + = do { check (name1 == name2) $ + MismatchedMethodNames + ; check (eqTypeX env op_ty1 op_ty2) $ + MismatchedMethodTypes op_ty1 op_ty2 + ; case boot_or_sig of + HsBoot -> + check (liftEq eqDM def_meth1 def_meth2) $ + MismatchedDefaultMethods False + Hsig -> + check (subDM op_ty1 def_meth1 def_meth2) $ + MismatchedDefaultMethods True } + where + name1 = idName id1 + name2 = idName id2 + op_ty1 = classMethodTy id1 + op_ty2 = classMethodTy id2 + + eqDM (_, VanillaDM) (_, VanillaDM) = True + eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2 + eqDM _ _ = False + + -- NB: first argument is from hsig, second is from real impl. + -- Order of pattern matching matters. + subDM _ Nothing _ = True + subDM _ _ Nothing = False + + -- If the hsig wrote: + -- + -- f :: a -> a + -- default f :: a -> a + -- + -- this should be validly implementable using an old-fashioned + -- vanilla default method. + subDM t1 (Just (_, GenericDM gdm_t1)) (Just (_, VanillaDM)) + = eqType t1 gdm_t1 -- Take care (#22476). Both t1 and gdm_t1 come + -- from tc1, so use eqType, and /not/ eqTypeX + + -- This case can occur when merging signatures + subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2)) + = eqTypeX env t1 t2 + + subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True + subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2)) + = eqTypeX env t1 t2 + +-- | Check that two associated types are compatible. +compatAT :: RnEnv2 -> HsBootOrSig -> ClassATItem -> ClassATItem + -> BootErrsM BootATMismatch +compatAT env boot_or_sig (ATI tc1 def_ats1) (ATI tc2 def_ats2) + = do { embedErrs MismatchedTyConAT $ + checkBootTyCon boot_or_sig tc1 tc2 + ; check (compatATDef def_ats1 def_ats2) + MismatchedATDefaultType } + + where + -- Ignore the location of the defaults + compatATDef Nothing Nothing = True + compatATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 + compatATDef _ _ = False + +-- | Check that two functional dependencies are the same. +eqFD :: RnEnv2 -> FunDep TyVar -> FunDep TyVar -> Bool +eqFD env (as1,bs1) (as2,bs2) = + liftEq (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + liftEq (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + +-- | Check compatibility of two type family flavours. +compatFamFlav :: FamTyConFlav -> FamTyConFlav -> BootErrsM BootTyConMismatch +compatFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon + = checkSuccess +compatFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) + = checkSuccess +compatFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon + = checkSuccess -- This case only happens for hsig merging. +compatFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) + = checkSuccess +compatFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon + = checkSuccess +compatFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) + = eqClosedFamilyAx ax1 ax2 +compatFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) + = checkSuccess +compatFamFlav flav1 flav2 + = bootErr $ TyConFlavourMismatch flav1 flav2 + +-- | Check that two 'AlgTyConRhs's are compatible. +compatAlgRhs :: AlgTyConRhs -> AlgTyConRhs -> BootErrsM BootDataMismatch +compatAlgRhs (AbstractTyCon {}) _rhs2 = + checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon +compatAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = + checkListBy compatCon (data_cons tc1) (data_cons tc2) MismatchedConstructors +compatAlgRhs tc1@NewTyCon{ data_con = dc1 } tc2@NewTyCon{ data_con = dc2 } = + embedErrs (MismatchedConstructors . NE.singleton . MismatchedThing 1 dc1 dc2) $ + compatCon (data_con tc1) (data_con tc2) +compatAlgRhs _ _ = bootErr MismatchedNewtypeVsData + +-- | Check that two 'DataCon's are compatible. +compatCon :: DataCon -> DataCon -> BootErrsM BootDataConMismatch +compatCon c1 c2 + = do { check (dataConName c1 == dataConName c2) + MismatchedDataConNames + ; check (dataConIsInfix c1 == dataConIsInfix c2) + MismatchedDataConFixities + ; check (liftEq eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) + MismatchedDataConBangs + ; check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) + MismatchedDataConFieldLabels + ; check (eqType (dataConWrapperType c1) (dataConWrapperType c2)) + MismatchedDataConTypes } + +eqClosedFamilyAx :: Maybe (CoAxiom br) -> Maybe (CoAxiom br1) + -> BootErrsM BootTyConMismatch +eqClosedFamilyAx Nothing Nothing = checkSuccess +eqClosedFamilyAx Nothing (Just _) = bootErr $ TyConAxiomMismatch $ NE.singleton MismatchedLength +eqClosedFamilyAx (Just _) Nothing = bootErr $ TyConAxiomMismatch $ NE.singleton MismatchedLength +eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 })) + (Just (CoAxiom { co_ax_branches = branches2 })) + = checkListBy eqClosedFamilyBranch branch_list1 branch_list2 + TyConAxiomMismatch + where + branch_list1 = fromBranches branches1 + branch_list2 = fromBranches branches2 + +eqClosedFamilyBranch :: CoAxBranch -> CoAxBranch -> BootErrsM BootAxiomBranchMismatch +eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 + , cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 + , cab_lhs = lhs2, cab_rhs = rhs2 }) + | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 + , Just env <- eqVarBndrs env1 cvs1 cvs2 + = do { check (liftEq (eqTypeX env) lhs1 lhs2) MismatchedAxiomLHS + ; check (eqTypeX env rhs1 rhs2) MismatchedAxiomRHS } + | otherwise + = bootErr MismatchedAxiomBinders + +{- Note [Role subtyping] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the current formulation of roles, role subtyping is only OK if the +"abstract" TyCon was not representationally injective. Among the most +notable examples of non representationally injective TyCons are abstract +data, which can be implemented via newtypes (which are not +representationally injective). The key example is +in this example from #13140: + + -- In an hsig file + data T a -- abstract! + type role T nominal + + -- Elsewhere + foo :: Coercible (T a) (T b) => a -> b + foo x = x + +We must NOT allow foo to typecheck, because if we instantiate +T with a concrete data type with a phantom role would cause +Coercible (T a) (T b) to be provable. Fortunately, if T is not +representationally injective, we cannot make the inference that a ~N b if +T a ~R T b. + +Unconditional role subtyping would be possible if we setup +an extra set of roles saying when we can project out coercions +(we call these proj-roles); then it would NOT be valid to instantiate T +with a data type at phantom since the proj-role subtyping check +would fail. See #13140 for more details. + +One consequence of this is we get no role subtyping for non-abstract +data types in signatures. Suppose you have: + + signature A where + type role T nominal + data T a = MkT + +If you write this, we'll treat T as injective, and make inferences +like T a ~R T b ==> a ~N b (mkSelCo). But if we can +subsequently replace T with one at phantom role, we would then be able to +infer things like T Int ~R T Bool which is bad news. + +We could allow role subtyping here if we didn't treat *any* data types +defined in signatures as injective. But this would be a bit surprising, +replacing a data type in a module with one in a signature could cause +your code to stop typechecking (whereas if you made the type abstract, +it is more understandable that the type checker knows less). + +It would have been best if this was purely a question of defaults +(i.e., a user could explicitly ask for one behavior or another) but +the current role system isn't expressive enough to do this. +Having explicit proj-roles would solve this problem. +-} + +checkRoles :: HsBootOrSig -> TyCon -> [Role] -> BootErrsM BootTyConMismatch +checkRoles boot_or_sig tc1 r2 + | boot_or_sig == HsBoot + || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping] + = check (r1 == r2) (TyConRoleMismatch False) + | otherwise + = check (r2 `rolesSubtypeOf` r1) (TyConRoleMismatch True) + where + + r1 = tyConRoles tc1 + + rolesSubtypeOf [] [] = True + -- NB: this relation is the OPPOSITE of the subroling relation + rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys + rolesSubtypeOf _ _ = False + +{- Note [Synonyms implement abstract data] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An abstract data type or class can be implemented using a type synonym, +but ONLY if: + + 1. T, as a standalone occurrence, is a valid type + (T is "curryable"), and + + 2. T is valid in an instance head. + +This gives rise to the following conditions under which we can implement +an abstract data declaration @data T@ using a type synonym @type T tvs = rhs@: + + 1. The type synonym T is nullary (tvs is null). + + 2. The rhs must not contain any foralls, quantified types, or type family + applications. + See 'invalidAbsDataSubTypes' which computes a collection of + invalid subtypes. + +See also 'HowAbstract' and Note [Skolem abstract data]. +-} + +-- | We are implementing an abstract data declaration of the form @data T@ +-- in a signature file, with a type synonym @type T tvs = rhs@ in the +-- implementing module. +-- +-- This function checks that the implementation is valid: +-- +-- 1. the type synonym T is nullary, i.e. tvs is null, +-- 2. rhs doesn't contain any type families, foralls, or qualified types. +-- +-- See Note [Synonyms implement abstract data] +checkSynAbsData :: TyCon -- ^ @tc1@, the abstract data 'TyCon' we are implementing + -> TyCon -- ^ @tc2@, a type synonym @type T tvs = ty@ + -- we are using to implement @tc1@ + -> [TyVar] -- ^ @tvs@ + -> Type -- ^ @ty@ + -> BootErrsM BootTyConMismatch +checkSynAbsData tc1 tc2 syn_tvs syn_rhs + -- We are implementing @data T@ with @type T tvs = rhs@. + -- Check the conditions of Note [Synonyms implement abstract data]. + = do { -- (1): T is nullary. + ; check (null syn_tvs) $ + SynAbstractData SynAbsDataTySynNotNullary + -- (2): the RHS of the type synonym is valid. + ; case invalidAbsDataSubTypes syn_rhs of + [] -> checkSuccess + err:errs -> bootErr $ SynAbstractData $ + SynAbstractDataInvalidRHS (err :| errs) + -- NB: this allows implementing e.g. @data T :: Nat@ with @type T = 3@. + -- See #15138. + + -- TODO: When it's a synonym implementing a class, we really + -- should check that the fundeps are satisfied, but + -- there is not an obvious way to do this for a constraint synonym. + -- So for now, let it all through (it won't cause segfaults, anyway). + -- Tracked at #12704. + + -- ... we also need to check roles. + ; if | Just (tc2', args) <- tcSplitTyConApp_maybe syn_rhs + , null syn_tvs -- Don't report role errors unless the type synonym is nullary + -> assert (null (tyConRoles tc2)) $ + -- If we have something like: + -- + -- signature H where + -- data T a + -- module H where + -- data K a b = ... + -- type T = K Int + -- + -- we need to drop the first role of K when comparing! + checkRoles Hsig tc1 (drop (length args) (tyConRoles tc2')) + | otherwise + -> checkSuccess + } + +{- + -- Hypothetically, if we were allow to non-nullary type synonyms, here + -- is how you would check the roles + if length tvs == length roles1 + then checkRoles roles1 roles2 + else case tcSplitTyConApp_maybe ty of + Just (tc2', args) -> + checkRoles Hsig tc1 (drop (length args) (tyConRoles tc2') ++ roles2) + Nothing -> Just roles_msg +-} + +-- | Is this type a valid implementation of abstract data? +-- +-- Returns a list of invalid sub-types encountered. +invalidAbsDataSubTypes :: Type -> [Type] +invalidAbsDataSubTypes = execWriter . go + where + go :: Type -> Writer [Type] () + go ty + | Just ty' <- coreView ty + = go ty' + go TyVarTy{} + = ok -- We report an error at the binding site of type variables, + -- e.g. in the TySyn LHS or in the forall. + -- It's not useful to report a second error for their occurrences + go (AppTy t1 t2) + = do { go t1; go t2 } + go ty@(TyConApp tc tys) + | isTypeFamilyTyCon tc + = invalid ty + | otherwise + = mapM_ go tys + go ty@(ForAllTy{}) + = invalid ty + go ty@(FunTy af w t1 t2) + | af == FTF_T_T + = do { go w + ; go (typeKind t1) ; go t1 + ; go (typeKind t2) ; go t2 + } + | otherwise + = invalid ty + go LitTy{} + = ok + go ty@(CastTy{}) + = invalid ty + go ty@(CoercionTy{}) + = invalid ty + + ok = pure () + invalid ty = tell [ty] + +{- +************************************************************************ +* * + Type-checking the top level of a module (continued) +* * +************************************************************************ +-} + +rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn) +-- Fails if there are any errors +rnTopSrcDecls group + = do { -- Rename the source decls + traceRn "rn12" empty ; + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; + traceRn "rn13" empty ; + (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ; + traceRn "rn13-plugin" empty ; + + -- save the renamed syntax, if we want it + let { tcg_env' + | Just grp <- tcg_rn_decls tcg_env + = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } + | otherwise + = tcg_env }; + + -- Dump trace of renaming part + rnDump rn_decls ; + return (tcg_env', rn_decls) + } + +tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_annds = annotation_decls, + hs_ruleds = rule_decls, + hs_valds = hs_val_binds@(XValBindsLR + (NValBinds val_binds val_sigs)) }) + = do { -- Type-check the type and class decls, and all imported decls + -- The latter come in via tycl_decls + traceTc "Tc2 (src)" empty ; + + -- Source-language instances, including derivings, + -- and import the supporting declarations + traceTc "Tc3" empty ; + (tcg_env, inst_infos, th_bndrs, + XValBindsLR (NValBinds deriv_binds deriv_sigs)) + <- tcTyClsInstDecls tycl_decls deriv_decls default_decls val_binds ; + + updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $ + setGblEnv tcg_env $ do { + + -- Foreign import declarations next. + traceTc "Tc4" empty ; + (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; + tcExtendGlobalValEnv fi_ids $ do { + + -- Value declarations next. + -- It is important that we check the top-level value bindings + -- before the GHC-generated derived bindings, since the latter + -- may be defined in terms of the former. (For instance, + -- the bindings produced in a Data instance.) + traceTc "Tc5" empty ; + tc_envs <- tcTopBinds val_binds val_sigs; + restoreEnvs tc_envs $ do { + + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + tc_envs@(tcg_env, tcl_env) + <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ; + restoreEnvs tc_envs $ do { -- Environment doesn't change now + + -- Second pass over class and instance declarations, + -- now using the kind-checked decls + traceTc "Tc6" empty ; + inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; + + -- Foreign exports + traceTc "Tc7" empty ; + (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ; + + -- Annotations + annotations <- tcAnnotations annotation_decls ; + + -- Rules + rules <- tcRules rule_decls ; + + -- Wrap up + traceTc "Tc7a" empty ; + let { all_binds = inst_binds ++ foe_binds + + ; fo_gres = fi_gres `unionBags` foe_gres + ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` (greName gre)) + emptyFVs fo_gres + + ; sig_names = mkNameSet (collectHsValBinders CollNoDictBinders hs_val_binds) + `minusNameSet` getTypeSigNames val_sigs + + -- Extend the GblEnv with the (as yet un-zonked) + -- bindings, rules, foreign decls + ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env ++ all_binds + , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names + , tcg_rules = tcg_rules tcg_env + ++ flattenRuleDecls rules + , tcg_anns = tcg_anns tcg_env ++ annotations + , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations + , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls + , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; + -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] + + -- See Note [Newtype constructor usage in foreign declarations] + addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; + + return (tcg_env', tcl_env) + }}}}} + +tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" + +--------------------------- +tcTyClsInstDecls :: [TyClGroup GhcRn] + -> [LDerivDecl GhcRn] + -> [LDefaultDecl GhcRn] + -> [(RecFlag, LHsBinds GhcRn)] + -> TcM (TcGblEnv, -- The full inst env + [InstInfo GhcRn], -- Source-code instance decls to + -- process; contains all dfuns for + -- this module + ThBindEnv, -- TH binding levels + HsValBinds GhcRn) -- Supporting bindings for derived + -- instances + +tcTyClsInstDecls tycl_decls deriv_decls default_decls binds + = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ + tcAddPatSynPlaceholders (getPatSynBinds binds) $ + do { (tcg_env, inst_info, deriv_info, th_bndrs) + <- tcTyAndClassDecls tycl_decls ; + + ; setGblEnv tcg_env $ do { + + -- With the @TyClDecl@s and @InstDecl@s checked we're ready to + -- process the deriving clauses, including data family deriving + -- clauses discovered in @tcTyAndClassDecls@. + -- + -- But only after we've typechecked 'default' declarations. + -- See Note [Typechecking default declarations] + defaults <- tcDefaultDecls default_decls + ; extendDefaultEnvWithLocalDefaults defaults $ do { + + -- Careful to quit now in case there were instance errors, so that + -- the deriving errors don't pile up as well. + ; failIfErrsM + ; (tcg_env', inst_info', val_binds) + <- tcInstDeclsDeriv deriv_info deriv_decls + ; setGblEnv tcg_env' $ do { + failIfErrsM + ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds ) + }}}} + +{- ********************************************************************* +* * + Checking for 'main' +* * +************************************************************************ +-} + +checkMainType :: TcGblEnv -> TcRn WantedConstraints +-- If this is the Main module, and it defines a function main, +-- check that its type is of form IO tau. +-- If not, do nothing +-- See Note [Dealing with main] +checkMainType tcg_env + = do { hsc_env <- getTopEnv + ; if tcg_mod tcg_env /= mainModIs (hsc_HUE hsc_env) + then return emptyWC else + + do { rdr_env <- getGlobalRdrEnv + ; let dflags = hsc_dflags hsc_env + main_occ = getMainOcc dflags + main_gres = lookupGRE rdr_env (LookupOccName main_occ SameNameSpace) + ; case filter isLocalGRE main_gres of { + [] -> return emptyWC ; + (_:_:_) -> return emptyWC ; + [main_gre] -> + + do { let main_name = greName main_gre + ctxt = FunSigCtxt main_name NoRRC + ; main_id <- tcLookupId main_name + ; (io_ty,_) <- getIOType + ; let main_ty = idType main_id + eq_orig = TypeEqOrigin { uo_actual = main_ty + , uo_expected = io_ty + , uo_thing = Nothing + , uo_visible = True } + ; (_, lie) <- captureTopConstraints $ + setMainCtxt main_name io_ty $ + tcSubTypeSigma eq_orig ctxt main_ty io_ty + ; return lie } } } } + +checkMain :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (LocatedLI [LIE GhcPs]) -- Export specs of Main module + -> TcM TcGblEnv +-- If we are in module Main, check that 'main' is exported, +-- and generate the runMainIO binding that calls it +-- See Note [Dealing with main] +checkMain explicit_mod_hdr export_ies + = do { hsc_env <- getTopEnv + ; tcg_env <- getGblEnv + + ; let dflags = hsc_dflags hsc_env + main_mod = mainModIs (hsc_HUE hsc_env) + main_occ = getMainOcc dflags + + exported_mains :: [Name] + -- Exported things that are called 'main' + exported_mains = [ name | avail <- tcg_exports tcg_env + , name <- availNames avail + , nameOccName name == main_occ ] + + ; if | tcg_mod tcg_env /= main_mod + -> -- Not the main module + return tcg_env + + | [main_name] <- exported_mains + -> -- The module indeed exports a function called 'main' + generateMainBinding tcg_env main_name + + | otherwise + -> assert (null exported_mains) $ + -- A fully-checked export list can't contain more + -- than one function with the same OccName + do { complain_no_main dflags main_mod main_occ + ; return tcg_env } } + where + complain_no_main dflags main_mod main_occ + = unless (interactive && not explicit_mod_hdr) $ + addErrTc (noMainMsg main_mod main_occ) -- #12906 + where + interactive = ghcLink dflags == LinkInMemory + -- Without an explicit module header... + -- in interactive mode, don't worry about the absence of 'main'. + -- in other modes, add error message and go on with typechecking. + + noMainMsg main_mod main_occ + = TcRnMissingMain explicit_export_list main_mod main_occ + explicit_export_list = explicit_mod_hdr && isJust export_ies + +-- | Get the unqualified name of the function to use as the \"main\" for the main module. +-- Either returns the default name or the one configured on the command line with -main-is +getMainOcc :: DynFlags -> OccName +getMainOcc dflags = case mainFunIs dflags of + Just fn -> mkVarOccFS (mkFastString fn) + Nothing -> mkVarOccFS (fsLit "main") + +generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv +-- There is a single exported 'main' function, called 'foo' (say), +-- which may be locally defined or imported +-- Define and typecheck the binding +-- :Main.main :: IO res_ty = runMainIO res_ty foo +-- This wraps the user's main function in the top-level stuff +-- defined in runMainIO (eg catching otherwise un-caught exceptions) +-- See Note [Dealing with main] +generateMainBinding tcg_env main_name = do + { traceTc "checkMain found" (ppr main_name) + ; (io_ty, res_ty) <- getIOType + ; let loc = getSrcSpan main_name + main_expr_rn = L (noAnnSrcSpan loc) (mkHsVar (L (noAnnSrcSpan loc) main_name)) + ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $ + tcCheckMonoExpr main_expr_rn io_ty + + -- See Note [Root-main Id] + -- Construct the binding + -- :Main.main :: IO res_ty = runMainIO res_ty main + ; run_main_id <- tcLookupId runMainIOName + ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN + (mkVarOccFS (fsLit "main")) + (getSrcSpan main_name) + ; root_main_id = Id.mkExportedVanillaId root_main_name io_ty + ; co = mkWpTyApps [res_ty] + -- The ev_binds of the `main` function may contain deferred + -- type errors when type of `main` is not `IO a`. The `ev_binds` + -- must be put inside `runMainIO` to ensure the deferred type + -- error can be emitted correctly. See #13838. + ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $ + mkHsDictLet ev_binds main_expr + ; main_bind = mkVarBind root_main_id rhs } + + ; return (tcg_env { tcg_main = Just main_name + , tcg_binds = tcg_binds tcg_env + ++ [main_bind] + , tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) }) + -- Record the use of 'main', so that we don't + -- complain about it being defined but not used + } + +getIOType :: TcM (TcType, TcType) +-- Return (IO alpha, alpha) for fresh alpha +getIOType = do { ioTyCon <- tcLookupTyCon ioTyConName + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; return (mkTyConApp ioTyCon [res_ty], res_ty) } + +setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a) +setMainCtxt main_name io_ty thing_inside + = setSrcSpan (getSrcSpan main_name) $ + addErrCtxt (MainCtxt main_name) $ + checkConstraints skol_info [] [] $ -- Builds an implication if necessary + thing_inside -- e.g. with -fdefer-type-errors + where + skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty [] + +{- Note [Dealing with main] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dealing with the 'main' declaration is surprisingly tricky. Here are +the moving parts: + +* The flag -main-is=M.foo allows you to set the main module to 'M', + and the main function to 'foo'. We access them through + mainModIs :: HscEnv -> Module -- returns M + getMainOcc :: DynFlags -> OccName -- returns foo + Of course usually M = Main, and foo = main. + +* checkMainType: when typechecking module M, we add an extra check that + foo :: IO tau, for some type tau. + This avoids getting ambiguous-type errors from the monomorphism restriction + applying to things like + main = return () + Note that checkMainType does not consult the export list because + we have not yet done rnExports (and can't do it until later). + +* rnExports: checks the export list. Very annoyingly, we can only do + this after running any finalisers, which may add new declarations. + That's why checkMainType and checkMain have to be separate. + +* checkMain: does two things: + - check that the export list does indeed export something called 'foo' + - generateMainBinding: generate the root-main binding + :Main.main = runMainIO M.foo + See Note [Root-main Id] + +An annoying consequence of having both checkMainType and checkMain is +that, when (but only when) -fdefer-type-errors is on, we may report an +ill-typed 'main' twice (as warnings): once in checkMainType and once +in checkMain. See test typecheck/should_fail/T13292. + +We have the following tests to check this processing: +----------------+----------------------------------------------------------------------------------+ + | Module Header: | + +-------------+-------------+-------------+-------------+-------------+------------+ + | module | module Main | | module Main |module |module Main | + | Main(main) | | | (module X)| Main () | (Sub.main)| +----------------+==================================================================================+ +`main` function | ERROR: | Main.main | ERROR: | Main.main | ERROR: | Sub.main | +in Main module | Ambiguous | | Ambiguous | | `main` not | | +and in imported | | | | | exported | | +module Sub. | T19397E1 | T16453M0 | T19397E2 | T16453M3 | | T16453M1 | + | | | | X = Main | Remark 2) | | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ +`main`function | Sub.main | ERROR: | Sub.main | Sub.main | ERROR: | Sub.main | +only in imported| | No `main` in| | | `main` not | | +submodule Sub. | | `Main` | | | exported | | + | T19397M0 | T16453E1 | T19397M1 | T16453M4 | | T16453M5 | + | | | | X = Sub | Remark 2) | | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ +`foo` function | Sub.foo | ERROR: | Sub.foo | Sub.foo | ERROR: | Sub.foo | +in submodule | | No `foo` in | | | `foo` not | | +Sub. | | `Main` | | | exported | | +GHC option: | | | | | | | + -main-is foo | T19397M2 | T19397E3 | T19397M3 | T19397M4 | T19397E4 | T16453M6 | + | Remark 1) | | | X = Sub | | Remark 3) | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ + +Remarks: +* The first line shows the exported `main` function or the error. +* The second line shows the coresponding test case. +* The module `Sub` contains the following functions: + main :: IO () + foo :: IO () +* Remark 1) Here the header is `Main (foo)`. +* Remark 2) Here we have no extra test case. It would exercise the same code path as `T19397E4`. +* Remark 3) Here the header is `Main (Sub.foo)`. + + +Note [Root-main Id] +~~~~~~~~~~~~~~~~~~~ +The function that the RTS invokes is always :Main.main, which we call +root_main_id. (Because GHC allows the user to have a module not +called Main as the main module, we can't rely on the main function +being called "Main.main". That's why root_main_id has a fixed module +":Main".) + +This is unusual: it's a LocalId whose Name has a Module from another +module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we +get two defns for 'main' in the interface file! + +When using `-fwrite-if-simplified-core` the root_main_id can end up in an interface file. +When the interface is read back in we have to add a special case when creating the +Id because otherwise we would go looking for the :Main module which obviously doesn't +exist. For this logic see GHC.IfaceToCore.mk_top_id. + +There is also some similar (probably dead) logic in GHC.Rename.Env which says it +was added for External Core which faced a similar issue. + +Note [runTcInteractive module graph] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The `withInteractiveModuleNode` function sets up the module graph which contains +the interactive module used by `runTcInteractive`. + +The module graph is essentially the ambient module graph which is set up when +ghci loads a module using `load`, with the addition of the interactive module (Ghci), +which imports the parts specified by the `InteractiveImports`. + +Therefore `downsweepInteractiveImports` presumes that any import which is +determined to be from the home module is already present in the module graph. +This saves resummarising and performing the whole downsweep again if it's already been +done. + +On the other hand, when GHCi starts up, and no modules have been loaded yet, the +module graph will be empty. Therefore `downsweepInteractiveImports` will perform +for the unit portion of the graph, if it's not already been performed. + + +********************************************************* +* * + GHCi stuff +* * +********************************************************* +-} + +-- See Note [runTcInteractive module graph] +withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a +withInteractiveModuleNode hsc_env thing_inside = do + mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env) + updTopEnv (setModuleGraph mg) thing_inside + + +runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) +-- Initialise the tcg_inst_env with instances from all home modules. +-- This mimics the more selective call to hptInstances in tcRnImports +runTcInteractive hsc_env thing_inside + = initTcInteractive hsc_env $ withTcPlugins hsc_env $ + withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $ + withInteractiveModuleNode hsc_env $ + do { traceTc "setInteractiveContext" $ + vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) + , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts)) + , text "icReaderEnv (LocalDef)" <+> + vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt) + , let local_gres = filter isLocalGRE gres + , not (null local_gres) ]) ] + + ; let getOrphansForModuleName m mb_pkg = do + iface <- loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg + pure $ mi_module iface : dep_orphs (mi_deps iface) + + getOrphansForModule m = do + iface <- loadModuleInterface (text "runTcInteractive") m + pure $ mi_module iface : dep_orphs (mi_deps iface) + + ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> + case i of -- force above: see #15111 + IIModule n -> getOrphansForModule n + IIDecl i -> getOrphansForModuleName (unLoc (ideclName i)) + (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) + + + ; (home_insts, home_fam_insts) <- liftIO $ UnitEnv.hugAllInstances (hsc_unit_env hsc_env) + + ; let imports = emptyImportAvails { imp_orphs = orphs } + + upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env') + + where + gbl_env' = gbl_env + { tcg_rdr_env = icReaderEnv icxt + , tcg_type_env = type_env + , tcg_inst_env = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts + , tcg_fam_inst_env = extendFamInstEnvList + (extendFamInstEnvList (tcg_fam_inst_env gbl_env) + ic_finsts) + home_fam_insts + , tcg_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' = modifyLclCtxt (tcExtendLocalTypeEnv lcl_ids) lcl_env + + ; updEnvs upd_envs thing_inside } + where + icxt = hsc_IC hsc_env + (ic_insts, ic_finsts) = ic_instances icxt + (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt) + + is_closed :: TyThing -> Either (Name, TcTyThing) TyThing + -- Put Ids with free type variables (always RuntimeUnks) + -- in the *local* type environment + -- See Note [Initialising the type environment for GHCi] + is_closed thing + | AnId id <- thing + , not (isTypeClosedLetBndr id) + = Left (idName id, ATcId { tct_id = id + , tct_info = NotLetBound }) + | otherwise + = Right thing + + type_env1 = mkTypeEnvWithImplicits top_ty_things + type_env = extendTypeEnvWithIds type_env1 + $ map instanceDFunId (instEnvElts ic_insts) + -- Putting the dfuns in the type_env + -- is just to keep Core Lint happy + +{- Note [Initialising the type environment for GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the Ids in ic_things, defined by the user in 'let' stmts, +have closed types. E.g. + ghci> let foo x y = x && not y + +However the GHCi debugger creates top-level bindings for Ids whose +types have free RuntimeUnk skolem variables, standing for unknown +types. If we don't register these free TyVars as global TyVars then +the typechecker will try to quantify over them and fall over in +skolemiseQuantifiedTyVar. so we must add any free TyVars to the +typechecker's global TyVar set. That is done by using +tcExtendLocalTypeEnv. + +We do this by splitting out the Ids with open types, using 'is_closed' +to do the partition. The top-level things go in the global TypeEnv; +the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the +local TypeEnv. + +Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope +things are already in the interactive context's GlobalRdrEnv. +Extending the local RdrEnv isn't terrible, but it means there is an +entry for the same Name in both global and local RdrEnvs, and that +lead to duplicate "perhaps you meant..." suggestions (e.g. T5564). + +We don't bother with the tcl_th_bndrs environment either. +-} + +-- | The returned [Id] is the list of new Ids bound by this statement. It can +-- be used to extend the InteractiveContext via extendInteractiveContext. +-- +-- The returned TypecheckedHsExpr is of type IO [ Any ], a list of the bound +-- values, coerced to Any. +tcRnStmt :: HscEnv -> GhciLStmt GhcPs + -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) +tcRnStmt hsc_env rdr_stmt + = runTcInteractive hsc_env $ do { + + -- The real work is done here + ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; + zonked_expr <- zonkTopLExpr tc_expr ; + zonked_ids <- zonkTopBndrs bound_ids ; + + failIfErrsM ; -- we can't do the next step if there are + -- representation polymorphism errors + -- test case: ghci/scripts/T13202{,a} + + -- None of the Ids should be of unboxed type, because we + -- cast them all to HValues in the end! + mapM_ (addErr . TcRnGhciUnliftedBind) $ + filter (mightBeUnliftedType . idType) zonked_ids ; + + traceTc "tcs 1" empty ; + this_mod <- getModule ; + global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ; + -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env + + traceOptTcRn Opt_D_dump_tc + (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, + text "Typechecked expr" <+> ppr zonked_expr]) ; + + return (global_ids, zonked_expr, fix_env) + } + +{- +-------------------------------------------------------------------------- + Typechecking Stmts in GHCi + +Here is the grand plan, implemented in tcUserStmt + + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] + [NB: result not printed] bindings: [it] + + expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] + result showable) bindings: [it] + + expr (of non-IO type, + result not showable) ==> error +-} + +-- | A plan is an attempt to lift some code into the IO monad. +type PlanResult = ([Id], LHsExpr GhcTc) +type Plan = TcM PlanResult + +-- | Try the plans in order. If one fails (by raising an exn), try the next. +-- If one succeeds, take it. +runPlans :: NonEmpty Plan -> Plan +runPlans = foldr1 (flip tryTcDiscardingErrs) + +-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the +-- GHCi 'environment'. +-- +-- By 'lift' and 'environment we mean that the code is changed to +-- execute properly in an IO monad. See Note [Interactively-bound Ids +-- in GHCi] in GHC.Driver.Env for more details. We do this lifting by trying +-- different ways ('plans') of lifting the code into the IO monad and +-- type checking each plan until one succeeds. +tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) + +-- An expression typed at the prompt is treated very specially +tcUserStmt (L loc (BodyStmt _ expr _ _)) + = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) + + ; dumpOptTcRn Opt_D_dump_rn_ast "Renamer" FormatHaskell + (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_expr) + -- Don't try to typecheck if the renamer fails! + ; ghciStep <- getGhciStepIO + ; uniq <- newUnique + ; let loc' = noAnnSrcSpan $ locA loc + ; interPrintName <- getInteractivePrintName + ; let fresh_it = itName uniq (locA loc) + matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it) noAnn) (noLocA []) rn_expr + emptyLocalBinds] + -- [it = expr] + the_bind = L loc $ (mkTopFunBind FromSource + (L loc' fresh_it) matches) + { fun_ext = fvs } + -- Care here! In GHCi the expression might have + -- free variables, and they in turn may have free type variables + -- (if we are at a breakpoint, say). We must put those free vars + + -- [let it = expr] + let_stmt = L loc $ LetStmt noAnn $ HsValBinds noAnn + $ XValBindsLR + (NValBinds [(NonRecursive,[the_bind])] []) + + -- [it <- e] + bind_stmt = L loc $ BindStmt + (XBindStmtRn + { xbsrn_bindOp = mkRnSyntaxExpr bindIOName + , xbsrn_failOp = Nothing + }) + (L loc (VarPat noExtField (L loc' fresh_it))) + (nlHsApp ghciStep rn_expr) + + -- [; print it] + print_it = L loc $ BodyStmt noExtField + (nlHsApp (nlHsVar interPrintName) + (nlHsVar fresh_it)) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + -- NewA + no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName + [rn_expr , nlHsVar interPrintName]) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + no_it_b = L loc $ BodyStmt noExtField (rn_expr) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + no_it_c = L loc $ BodyStmt noExtField + (nlHsApp (nlHsVar interPrintName) rn_expr) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + -- See Note [GHCi Plans] + + it_plans = + -- Plan A + do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] + ; it_ty <- liftZonkM $ zonkTcType (idType it_id) + ; when (isUnitTy it_ty) failM + ; return stuff } :| + + -- Plan B; a naked bind statement + [ tcGhciStmts [bind_stmt] + + -- Plan C; check that the let-binding is typeable all by itself. + -- If not, fail; if so, try to print it. + -- The two-step process avoids getting two errors: one from + -- the expression itself, and one from the 'print it' part + -- This two-step story is very clunky, alas + , do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) + --- checkNoErrs defeats the error recovery of let-bindings + ; tcGhciStmts [let_stmt, print_it] } ] + + -- Plans where we don't bind "it" + no_it_plans = + tcGhciStmts [no_it_a] :| + tcGhciStmts [no_it_b] : + tcGhciStmts [no_it_c] : + [] + + ; generate_it <- goptM Opt_NoIt + + -- We disable `-fdefer-type-errors` in GHCi for naked expressions. + -- See Note [Deferred type errors in GHCi] + + -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes` + -- and `-fdefer-out-of-scope-variables`. However the flag + -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and + -- `-fno-defer-out-of-scope-variables`. Thus the later two flags + -- also need to be unset here. + ; plan <- unsetGOptM Opt_DeferTypeErrors $ + unsetGOptM Opt_DeferTypedHoles $ + unsetGOptM Opt_DeferOutOfScopeVariables $ + runPlans $ if generate_it + then no_it_plans + else it_plans + + ; dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell + (showAstData NoBlankSrcSpan NoBlankEpAnnotations plan) + + ; fix_env <- getFixityEnv + ; return (plan, fix_env) } + +{- Note [Deferred type errors in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHCi, we ensure that type errors don't get deferred when type checking the +naked expressions. Deferring type errors here is unhelpful because the +expression gets evaluated right away anyway. It also would potentially emit +two redundant type-error warnings, one from each plan. + +#14963 reveals another bug that when deferred type errors is enabled +in GHCi, any reference of imported/loaded variables (directly or indirectly) +in interactively issued naked expressions will cause ghc panic. See more +detailed discussion in #14963. + +The interactively issued declarations, statements, as well as the modules +loaded into GHCi, are not affected. That means, for declaration, you could +have + + Prelude> :set -fdefer-type-errors + Prelude> x :: IO (); x = putStrLn True + :14:26: warning: [-Wdeferred-type-errors] + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘x’: x = putStrLn True + +But for naked expressions, you will have + + Prelude> :set -fdefer-type-errors + Prelude> putStrLn True + :2:10: error: + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘it’: it = putStrLn True + + Prelude> let x = putStrLn True + :2:18: warning: [-Wdeferred-type-errors] + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘x’: x = putStrLn True +-} + +tcUserStmt rdr_stmt@(L loc _) + = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ + rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do + fix_env <- getFixityEnv + return (fix_env, emptyFVs) + -- Don't try to typecheck if the renamer fails! + ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) + ; rnDump rn_stmt ; + + ; ghciStep <- getGhciStepIO + ; let gi_stmt + | (L loc (BindStmt x pat expr)) <- rn_stmt + = L loc $ BindStmt x pat (nlHsApp ghciStep expr) + | otherwise = rn_stmt + + ; opt_pr_flag <- goptM Opt_PrintBindResult + ; let print_result_plan + | opt_pr_flag -- The flag says "print result" + , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt -- One binder + = Just $ mk_print_result_plan gi_stmt v + | otherwise = Nothing + + -- The plans are: + -- [stmt; print v] if one binder and not v::() + -- [stmt] otherwise + ; plan <- runPlans $ maybe id (NE.<|) print_result_plan $ NE.singleton $ tcGhciStmts [gi_stmt] + ; return (plan, fix_env) } + where + mk_print_result_plan stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] + ; v_ty <- liftZonkM $ zonkTcType (idType v_id) + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff } + where + print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) + (nlHsVar v)) + (mkRnSyntaxExpr thenIOName) noSyntaxExpr + +{- +Note [GHCi Plans] +~~~~~~~~~~~~~~~~~ +When a user types an expression in the repl we try to print it in three different +ways. Also, depending on whether -fno-it is set, we bind a variable called `it` +which can be used to refer to the result of the expression subsequently in the repl. + +The normal plans are : + A. [it <- e; print e] but not if it::() + B. [it <- e] + C. [let it = e; print it] + +When -fno-it is set, the plans are: + A. [e >>= print] + B. [e] + C. [let it = e in print it] + +The reason for -fno-it is explained in #14336. `it` can lead to the repl +leaking memory as it is repeatedly queried. +-} + +any_lifted :: Type +any_lifted = anyTypeOfKind liftedTypeKind + +-- | Typecheck the statements given and then return the results of the +-- statement in the form 'IO [Any]'. +tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult +tcGhciStmts stmts + = do { ioTyCon <- tcLookupTyCon ioTyConName + ; ret_id <- tcLookupId returnIOName -- return @ IO + ; let ret_ty = mkListTy any_lifted + io_ret_ty = mkTyConApp ioTyCon [ret_ty] + tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts + (mkCheckExpType io_ret_ty) + names = collectLStmtsBinders CollNoDictBinders stmts + + -- OK, we're ready to typecheck the stmts + ; traceTc "GHC.Tc.Module.tcGhciStmts: tc stmts" empty + ; ((tc_stmts, ids), lie) <- captureTopConstraints $ + tc_io_stmts $ \ _ -> + mapM tcLookupId names + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + ; traceTc "GHC.Tc.Module.tcGhciStmts: simplify ctxt" empty + ; const_binds <- checkNoErrs (simplifyInteractive lie) + -- checkNoErrs ensures that the plan fails if context redn fails + + + ; traceTc "GHC.Tc.Module.tcGhciStmts: done" empty + + -- ret_expr is the expression + -- returnIO @[Any] [unsafeCoerce# @Any x, .., unsafeCoerce# @Any z] + -- + -- Despite the inconvenience of building the type applications etc, + -- this *has* to be done in type-annotated post-typecheck form + -- because we are going to return a list of *polymorphic* values + -- coerced to type Any. If we built a *source* stmt + -- return [coerce x, ..., coerce z] + -- then the type checker would instantiate x..z, and we wouldn't + -- get their *polymorphic* values. (And we'd get ambiguity errs + -- if they were overloaded, since they aren't applied to anything.) + -- + -- We use Any rather than a dummy type such as () because of + -- the rules of unsafeCoerce#; see Unsafe/Coerce.hs for the details. + + ; AnId unsafe_coerce_id <- tcLookupGlobal unsafeCoercePrimName + -- We use unsafeCoerce# here because of (U11) in + -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce + + ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $ + noLocA $ ExplicitList any_lifted $ + map mk_item ids + + mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id) + , getRuntimeRep any_lifted + , idType id, any_lifted] + `nlHsApp` nlHsVar id + stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)] + + ; return (ids, mkHsDictLet (EvBinds const_binds) $ + noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts))) + } + +-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) +getGhciStepIO :: TcM (LHsExpr GhcRn) +getGhciStepIO = do + ghciTy <- getGHCiMonad + a_tv <- newName (mkTyVarOccFS (fsLit "a")) + let ghciM = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv) + ioM = nlHsAppTy (nlHsTyVar NotPromoted ioTyConName) (nlHsTyVar NotPromoted a_tv) + + step_ty :: LHsSigType GhcRn + step_ty = noLocA $ HsSig + { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]} + , sig_ext = noExtField + , sig_body = nlHsFunTy ghciM ioM } + + stepTy :: LHsSigWcType GhcRn + stepTy = mkEmptyWildCardBndrs step_ty + + return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) + +isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name) +isGHCiMonad hsc_env ty + = runTcInteractive hsc_env $ do + rdrEnv <- getGlobalRdrEnv + let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) + case occIO of + Just [n] -> do + let name = greName n + ghciClass <- tcLookupClass ghciIoClassName + userTyCon <- tcLookupTyCon name + let userTy = mkTyConApp userTyCon [] + _ <- tcLookupInstance ghciClass [userTy] + return name + _ -> failWithTc $ TcRnGhciMonadLookupFail ty occIO + +-- | How should we infer a type? See Note [TcRnExprMode] +data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:type) + | TM_Default -- ^ Instantiate all quantifiers, + -- and do eager defaulting (:type +d) + +-- | tcRnExpr just finds the type of an expression +-- for :type +tcRnExpr :: HscEnv + -> TcRnExprMode + -> LHsExpr GhcPs + -> IO (Messages TcRnMessage, Maybe Type) +tcRnExpr hsc_env mode rdr_expr + = runTcInteractive hsc_env $ + do { + + (rn_expr, _fvs) <- rnLExpr rdr_expr ; + failIfErrsM ; + + -- Typecheck the expression + ((tclvl, (_tc_expr, res_ty)), lie) + <- captureTopConstraints $ + pushTcLevelM $ + (if inst then tcInferRho rn_expr + else tcInferSigma rn_expr); + + -- Generalise + uniq <- newUnique ; + let { fresh_it = itName uniq (getLocA rdr_expr) } ; + ((qtvs, dicts, _, _), residual) + <- captureConstraints $ + simplifyInfer TopLevel tclvl infer_mode + [] {- No sig vars -} + [(fresh_it, res_ty)] + lie ; + + -- Ignore the dictionary bindings + _ <- perhaps_disable_default_warnings $ + simplifyInteractive residual ; + + let { all_expr_ty = mkInfForAllTys qtvs $ + mkPhiTy (map idType dicts) res_ty } ; + ty <- liftZonkM $ zonkTcType all_expr_ty ; + + -- See Note [Normalising the type in :type] + fam_envs <- tcGetFamInstEnvs ; + let { normalised_type = reductionReducedType $ normaliseType fam_envs Nominal ty + -- normaliseType returns a coercion which we discard, so the Role is irrelevant. + ; final_type = if isSigmaTy res_ty then ty else normalised_type } ; + return final_type } + where + -- Optionally instantiate the type of the expression + -- See Note [TcRnExprMode] + (inst, infer_mode, perhaps_disable_default_warnings) = case mode of + TM_Inst -> (False, NoRestrictions, id) + TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) + +{- Note [Implementing :type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider :type const + +We want forall a b. a -> b -> a +and not forall {a}{b}. a -> b -> a + +The latter is what we'd get if we eagerly instantiated and then +re-generalised with Inferred binders. It makes a difference, because +it tells us we where we can use Visible Type Application (VTA). + +And also for :type const @Int +we want forall b. Int -> b -> Int +and not forall {b}. Int -> b -> Int + +Solution: use tcInferSigma, which in turn uses tcInferApp, which +has a special case for application chains. + +Note [Normalising the type in :type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In :t we usually normalise the type (to simplify type functions) +before displaying the result. Reason (see #10321): otherwise we may show +types like + :: Vec (1+2) Int +rather than the simpler + :: Vec 3 Int +In GHC.Tc.Gen.Bind.mkInferredPolyId we normalise for a very similar reason. + +However this normalisation is less helpful when is just +an identifier, whose user-written type happens to contain type-function +applications. E.g. (#20974) + test :: F [Monad, A, B] m => m () +where F is a type family. If we say `:t test`, we'd prefer to see +the type family un-expanded. + +We adopt the following ad-hoc solution: if the type inferred for +(before generalisation, namely res_ty) is a SigmaType (i.e. is not +fully instantiated) then do not normalise; otherwise normalise. +This is not ideal; for example, suppose x :: F Int. Then + :t x +would be normalised because `F Int` is not a SigmaType. But +anything here is ad-hoc, and it's a user-sought improvement. +-} + +-------------------------- +tcRnImportDecls :: HscEnv + -> [LImportDecl GhcPs] + -> IO (Messages TcRnMessage, Maybe GlobalRdrEnv) +-- Find the new chunk of GlobalRdrEnv created by this list of import +-- decls. In contract tcRnImports *extends* the TcGblEnv. +tcRnImportDecls hsc_env import_decls + = runTcInteractive hsc_env $ + do { (_, gbl_env) <- updGblEnv zap_rdr_env $ + tcRnImports hsc_env $ map (,text "is directly imported") import_decls + ; return (tcg_rdr_env gbl_env) } + where + zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } + + +tcRnTypeSkolemising :: HscEnv + -> LHsType GhcPs + -> IO (Messages TcRnMessage, Maybe (Type, Kind)) +-- tcRnTypeSkolemising skolemisese any free unification variables, +-- and normalises the type +tcRnTypeSkolemising env ty + = do { skol_tv_ref <- liftIO (newIORef []) + ; tcRnType env (SkolemiseFlexi skol_tv_ref) True ty } + +-- tcRnType just finds the kind of a type +tcRnType :: HscEnv + -> ZonkFlexi + -> Bool -- Normalise the returned type + -> LHsType GhcPs + -> IO (Messages TcRnMessage, Maybe (Type, Kind)) +tcRnType hsc_env flexi normalise rdr_type + = runTcInteractive hsc_env $ + setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] + do { (HsWC { hswc_ext = wcs, hswc_body = rn_sig_type@(L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body })) }, _fvs) + -- we are using 'rnHsSigWcType' to bind the unbound type variables + -- and in combination with 'tcOuterTKBndrs' we are able to + -- implicitly quantify them as if the user wrote 'forall' by + -- hand (see #19217). This allows kind check to work in presence + -- of free type variables : + -- ghci> :k [a] + -- [a] :: * + <- rnHsSigWcType GHCiCtx (mkHsWildCardBndrs $ noLocA (mkHsImplicitSigType rdr_type)) + -- The type can have wild cards, but no implicit + -- generalisation; e.g. :kind (T _) + ; failIfErrsM + + -- We follow Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType here + + -- Now kind-check the type + -- It can have any rank or kind + -- First bring into scope any wildcards + ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_sig_type]) + ; si <- mkSkolemInfo $ SigTypeSkol (GhciCtxt True) + ; ((_, (ty, kind)), wanted) + <- captureTopConstraints $ + pushTcLevelM_ $ + bindNamedWildCardBinders wcs $ \ wcs' -> + do { mapM_ emitNamedTypeHole wcs' + ; tcOuterTKBndrs si outer_bndrs $ tcInferLHsTypeUnsaturated body } + -- Since all the wanteds are equalities, the returned bindings will be empty + ; empty_binds <- simplifyTop wanted + ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) + + -- Do kind generalisation; see Note [Kind-generalise in tcRnType] + ; kvs <- kindGeneralizeAll unkSkol kind + + ; ty <- initZonkEnv flexi $ zonkTcTypeToTypeX ty + + -- Do validity checking on type + ; checkValidType (GhciCtxt True) ty + + -- Optionally (:k vs :k!) normalise the type. Does two things: + -- normaliseType: expand type-family applications + -- expandTypeSynonyms: expand type synonyms (#18828) + ; fam_envs <- tcGetFamInstEnvs + ; let ty' | normalise = expandTypeSynonyms $ reductionReducedType $ + normaliseType fam_envs Nominal ty + | otherwise = ty + + ; traceTc "tcRnExpr" (debugPprType ty $$ debugPprType ty') + ; return (ty', mkInfForAllTys kvs (typeKind ty')) } + + +{- Note [TcRnExprMode] +~~~~~~~~~~~~~~~~~~~~~~ +How should we infer a type when a user asks for the type of an expression e +at the GHCi prompt? We offer 2 different possibilities, described below. Each +considers this example, with -fprint-explicit-foralls enabled. See also +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0179-printing-foralls.rst + +:type / TM_Inst + + In this mode, we report the type obtained by instantiating only the + /inferred/ quantifiers of e's type, solving constraints, and + re-generalising, as discussed in #11376. + + > :type reverse + reverse :: forall a. [a] -> [a] + + -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String + > :type foo @Int + forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String + + Note that Show Int is still reported, because the solver never got a chance + to see it. + +:type +d / TM_Default + + This mode is for the benefit of users who wish to see instantiations + of generalized types, and in particular to instantiate Foldable and + Traversable. In this mode, all type variables (inferred or + specified) are instantiated. Because GHCi uses + -XExtendedDefaultRules, this means that Foldable and Traversable are + defaulted. + + > :type +d reverse + reverse :: forall {a}. [a] -> [a] + + -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String + > :type +d foo @Int + Int -> [Integer] -> String + + Note that this mode can sometimes lead to a type error, if a type variable is + used with a defaultable class but cannot actually be defaulted: + + bar :: (Num a, Monoid a) => a -> a + > :type +d bar + ** error ** + + The error arises because GHC tries to default a but cannot find a concrete + type in the defaulting list that is both Num and Monoid. (If this list is + modified to include an element that is both Num and Monoid, the defaulting + would succeed, of course.) + + Note that the variables and constraints are reordered here, because this + is possible during regeneralization. Also note that the variables are + reported as Inferred instead of Specified. + +Note [Kind-generalise in tcRnType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We switch on PolyKinds when kind-checking a user type, so that we will +kind-generalise the type, even when PolyKinds is not otherwise on. +This gives the right default behaviour at the GHCi prompt, where if +you say ":k T", and T has a polymorphic kind, you'd like to see that +polymorphism. Of course. If T isn't kind-polymorphic you won't get +anything unexpected, but the apparent *loss* of polymorphism, for +types that you know are polymorphic, is quite surprising. See Trac +#7688 for a discussion. + +Note that the goal is to generalise the *kind of the type*, not +the type itself! Example: + ghci> data SameKind :: k -> k -> Type + ghci> :k SameKind _ + +We want to get `k -> Type`, not `Any -> Type`, which is what we would +get without kind-generalisation. Note that `:k SameKind` is OK, as +GHC will not instantiate SameKind here, and so we see its full kind +of `forall k. k -> k -> Type`. + +************************************************************************ +* * + tcRnDeclsi +* * +************************************************************************ + +tcRnDeclsi exists to allow class, data, and other declarations in GHCi. +-} + +tcRnDeclsi :: HscEnv + -> [LHsDecl GhcPs] + -> IO (Messages TcRnMessage, Maybe TcGblEnv) +tcRnDeclsi hsc_env local_decls + = runTcInteractive hsc_env $ + tcRnSrcDecls False Nothing local_decls + +externaliseAndTidyId :: Module -> Id -> TcM Id +externaliseAndTidyId this_mod id + = do { name' <- externaliseName this_mod (idName id) + ; return $ globaliseId id + `setIdName` name' + `setIdType` tidyTopType (idType id) } + + +{- +************************************************************************ +* * + More GHCi stuff, to do with browsing and getting info +* * +************************************************************************ +-} + +-- | ASSUMES that the module is either in the 'HomePackageTable' or is +-- a package module with an interface on disk. If neither of these is +-- true, then the result will be an error indicating the interface +-- could not be found. +getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface) +getModuleInterface hsc_env mod + = runTcInteractive hsc_env $ + loadModuleInterface (text "getModuleInterface") mod + +tcRnLookupRdrName :: HscEnv -> LocatedN RdrName + -> IO (Messages TcRnMessage, Maybe [Name]) +-- ^ Find all the Names that this RdrName could mean, in GHCi +tcRnLookupRdrName hsc_env (L loc rdr_name) + = runTcInteractive hsc_env $ + setSrcSpanA loc $ + do { -- If the identifier is a constructor (begins with an + -- upper-case letter), then we need to consider both + -- constructor and type class identifiers. + let rdr_names = dataTcOccs rdr_name + ; names_s <- mapM lookupInfoOccRn rdr_names + ; let names = concat names_s + ; when (null names) (addErrTc $ TcRnNotInScope NotInScope rdr_name) + ; return names } + +tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) +tcRnLookupName hsc_env name + = runTcInteractive hsc_env $ + tcRnLookupName' name + +-- To look up a name we have to look in the local environment (tcl_lcl) +-- as well as the global environment, which is what tcLookup does. +-- But we also want a TyThing, so we have to convert: + +tcRnLookupName' :: Name -> TcRn TyThing +tcRnLookupName' name = do + tcthing <- tcLookup name + case tcthing of + AGlobal thing -> return thing + ATcId{tct_id=id} -> return (AnId id) + _ -> panic "tcRnLookupName'" + +tcRnGetInfo :: HscEnv + -> Name + -> IO ( Messages TcRnMessage + , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) + +-- Used to implement :info in GHCi +-- +-- Look up a RdrName and return all the TyThings it might be +-- A capitalised RdrName is given to us in the DataName namespace, +-- but we want to treat it as *both* a data constructor +-- *and* as a type or class constructor; +-- hence the call to dataTcOccs, and we return up to two results +tcRnGetInfo hsc_env name + = runTcInteractive hsc_env $ + do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) + -- Load the interface for all unqualified types and classes + -- That way we will find all the instance declarations + -- (Packages have not orphan modules, and we assume that + -- in the home package all relevant modules are loaded.) + + ; thing <- tcRnLookupName' name + ; fixity <- lookupFixityRn name + ; (cls_insts, fam_insts) <- lookupInsts thing + ; let info = lookupKnownNameInfo name + ; return (thing, fixity, cls_insts, fam_insts, info) } + + +-- Lookup all class and family instances for a type constructor. +-- +-- This function filters all instances in the type environment, so there +-- is a lot of duplicated work if it is called many times in the same +-- type environment. If this becomes a problem, the NameEnv computed +-- in GHC.getNameToInstancesIndex could be cached in TcM and both functions +-- could be changed to consult that index. +lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) +lookupInsts (ATyCon tc) + = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs + ; (pkg_fie, home_fie) <- tcGetFamInstEnvs + -- Load all instances for all classes that are + -- in the type environment (which are all the ones + -- we've seen in any interface file so far) + + -- Return only the instances relevant to the given thing, i.e. + -- the instances whose head contains the thing's name. + ; let cls_insts = + [ ispec -- Search all + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , instIsVisible vis_mods ispec + , tc_name `elemNameSet` orphNamesOfClsInst ispec ] + ; let fam_insts = + [ fispec + | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie + , tc_name `elemNameSet` orphNamesOfFamInst fispec ] + ; return (cls_insts, fam_insts) } + where + tc_name = tyConName tc + +lookupInsts _ = return ([],[]) + +loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () +-- Load the interface for everything that is in scope unqualified +-- This is so that we can accurately report the instances for +-- something +loadUnqualIfaces hsc_env ictxt + = initIfaceTcRn $ + mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) + where + home_unit = hsc_home_unit hsc_env + + unqual_mods = [ nameModule name + | gre <- globalRdrEnvElts (icReaderEnv ictxt) + , let name = greName gre + , nameIsFromExternalPackage home_unit name + , isTcOcc (nameOccName name) -- Types and classes only + , unQualOK gre ] -- In scope unqualified + doc = text "Need interface for module whose export(s) are in scope unqualified" + + + +{- +************************************************************************ +* * + Debugging output + This is what happens when you do -ddump-types +* * +************************************************************************ +-} + +-- | Dump, with a banner, if -ddump-rn +rnDump :: (Outputable a, Data a) => a -> TcRn () +rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn) + +tcDump :: TcGblEnv -> TcRn () +tcDump env + = do { unit_state <- hsc_units <$> getTopEnv ; + logger <- getLogger ; + + -- Dump short output if -ddump-types or -ddump-tc + when (logHasDumpFlag logger Opt_D_dump_types || logHasDumpFlag logger Opt_D_dump_tc) + (dumpTcRn True Opt_D_dump_types + "" FormatText (pprWithUnitState unit_state short_dump)) ; + + -- Dump bindings if -ddump-tc + dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump; + + -- Dump bindings as an hsSyn AST if -ddump-tc-ast + dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump + } + where + short_dump = pprTcGblEnv env + full_dump = pprLHsBinds (tcg_binds env) + -- NB: foreign x-d's have undefined's in their types; + -- hence can't show the tc_fords + ast_dump = showAstData NoBlankSrcSpan NoBlankEpAnnotations (tcg_binds env) + +-- It's unpleasant having both pprModGuts and pprModDetails here +pprTcGblEnv :: TcGblEnv -> SDoc +pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_rules = rules, + tcg_imports = imports }) + = getPprDebug $ \debug -> + vcat [ ppr_types debug type_env + , ppr_tycons debug fam_insts type_env + , ppr_datacons debug type_env + , ppr_patsyns type_env + , ppr_insts insts + , ppr_fam_insts fam_insts + , ppr_rules rules + , text "Dependent modules:" <+> + (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) + , text "Dependent packages:" <+> + ppr (S.toList $ imp_dep_direct_pkgs imports)] + -- The use of sort is just to reduce unnecessary + -- wobbling in testsuite output + +ppr_rules :: [LRuleDecl GhcTc] -> SDoc +ppr_rules rules + = ppUnless (null rules) $ + hang (text "RULES") + 2 (vcat (map ppr rules)) + +ppr_types :: Bool -> TypeEnv -> SDoc +ppr_types debug type_env + = ppr_things "TYPE SIGNATURES" ppr_sig + (sortBy (comparing getOccName) ids) + where + ids = [id | id <- typeEnvIds type_env, want_sig id] + want_sig id + | debug = True + | otherwise = hasTopUserName id + && case idDetails id of + VanillaId -> True + WorkerLikeId {} -> True + RecSelId {} -> True + ClassOpId {} -> True + FCallId {} -> True + _ -> False + -- Data cons (workers and wrappers), pattern synonyms, + -- etc are suppressed (unless -dppr-debug), + -- because they appear elsewhere + + ppr_sig id = hang (pprPrefixOcc id <+> dcolon) 2 (ppr (tidyTopType (idType id))) + +ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc +ppr_tycons debug fam_insts type_env + = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons + , ppr_things "COERCION AXIOMS" ppr_ax + (typeEnvCoAxioms type_env) ] + where + fi_tycons = famInstsRepTyCons fam_insts + + tycons = sortBy (comparing getOccName) $ + [tycon | tycon <- typeEnvTyCons type_env + , want_tycon tycon] + -- Sort by OccName to reduce unnecessary changes + want_tycon tycon | debug = True + | otherwise = isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) + ppr_tc tc + = vcat [ hang (ppr (tyConFlavour tc) <+> pprPrefixOcc (tyConName tc) + <> braces (ppr (tyConArity tc)) <+> dcolon) + 2 (ppr (tidyTopType (tyConKind tc))) + , nest 2 $ + ppWhen show_roles $ + text "roles" <+> (sep (map ppr roles)) ] + where + show_roles = debug || not (all (== boring_role) roles) + roles = tyConRoles tc + boring_role | isClassTyCon tc = Nominal + | otherwise = Representational + -- Matches the choice in GHC.Iface.Syntax, calls to pprRoles + + ppr_ax ax = ppr (coAxiomToIfaceDecl ax) + -- We go via IfaceDecl rather than using pprCoAxiom + -- This way we get the full axiom (both LHS and RHS) with + -- wildcard binders tidied to _1, _2, etc. + +ppr_datacons :: Bool -> TypeEnv -> SDoc +ppr_datacons debug type_env + = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs + -- The filter gets rid of class data constructors + where + ppr_dc dc = sdocOption sdocLinearTypes (\show_linear_types -> + ppr dc <+> dcolon <+> ppr (dataConDisplayType show_linear_types dc)) + all_dcs = typeEnvDataCons type_env + wanted_dcs | debug = all_dcs + | otherwise = filterOut is_cls_dc all_dcs + is_cls_dc dc = isClassTyCon (dataConTyCon dc) + +ppr_patsyns :: TypeEnv -> SDoc +ppr_patsyns type_env + = ppr_things "PATTERN SYNONYMS" ppr_ps + (typeEnvPatSyns type_env) + where + ppr_ps ps = pprPrefixOcc ps <+> dcolon <+> pprPatSynType ps + +ppr_insts :: [ClsInst] -> SDoc +ppr_insts ispecs + = ppr_things "CLASS INSTANCES" pprInstance ispecs + +ppr_fam_insts :: [FamInst] -> SDoc +ppr_fam_insts fam_insts + = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts + +ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc +ppr_things herald ppr_one things + | null things = empty + | otherwise = text herald $$ nest 2 (vcat (map ppr_one things)) + +hasTopUserName :: NamedThing x => x -> Bool +-- A top-level thing whose name is not "derived" +-- Thus excluding things like $tcX, from Typeable boilerplate +-- and C:Coll from class-dictionary data constructors +hasTopUserName x + = isExternalName name && not (isDerivedOccName (nameOccName name)) + where + name = getName x + +{- +******************************************************************************** + +Type Checker Plugins + +******************************************************************************** +-} + +withTcPlugins :: HscEnv -> TcM a -> TcM a +withTcPlugins hsc_env m = + case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of + [] -> m -- Common fast case + plugins -> do + (solvers, rewriters, stops) <- + unzip3 `fmap` mapM start_plugin plugins + let + rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter] + !rewritersUniqFM = sequenceUFMList rewriters + -- The following ensures that tcPluginStop is called even if a type + -- error occurs during compilation (Fix of #10078) + eitherRes <- tryM $ + updGblEnv (\e -> e { tcg_tc_plugin_solvers = solvers + , tcg_tc_plugin_rewriters = rewritersUniqFM }) m + mapM_ runTcPluginM stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + start_plugin (TcPlugin start solve rewrite stop) = + do s <- runTcPluginM start + return (solve s, rewrite s, stop s) + +withDefaultingPlugins :: HscEnv -> TcM a -> TcM a +withDefaultingPlugins hsc_env m = + do case catMaybes $ mapPlugins (hsc_plugins hsc_env) defaultingPlugin of + [] -> m -- Common fast case + plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins + -- This ensures that dePluginStop is called even if a type + -- error occurs during compilation + eitherRes <- tryM $ do + updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) m + mapM_ runTcPluginM stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + start_plugin (DefaultingPlugin start fill stop) = + do s <- runTcPluginM start + return (fill s, stop s) + +withHoleFitPlugins :: HscEnv -> TcM a -> TcM a +withHoleFitPlugins hsc_env m = + case catMaybes $ mapPlugins (hsc_plugins hsc_env) holeFitPlugin of + [] -> m -- Common fast case + plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins + -- This ensures that hfPluginStop is called even if a type + -- error occurs during compilation. + eitherRes <- tryM $ + updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m + sequence_ stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + start_plugin (HoleFitPluginR init plugin stop) = + do ref <- init + return (plugin ref, stop ref) + + +runRenamerPlugin :: TcGblEnv + -> HsGroup GhcRn + -> TcM (TcGblEnv, HsGroup GhcRn) +runRenamerPlugin gbl_env hs_group = do + hsc_env <- getTopEnv + withPlugins (hsc_plugins hsc_env) + (\p opts (e, g) -> ( mark_plugin_unsafe (hsc_dflags hsc_env) + >> renamedResultAction p opts e g)) + (gbl_env, hs_group) + + +-- XXX: should this really be a Maybe X? Check under which circumstances this +-- can become a Nothing and decide whether this should instead throw an +-- exception/signal an error. +type RenamedStuff = + (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], + Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName))) + +-- | Extract the renamed information from TcGblEnv. +getRenamedStuff :: TcGblEnv -> RenamedStuff +getRenamedStuff tc_result + = fmap (\decls -> ( decls, tcg_rn_imports tc_result + , tcg_rn_exports tc_result, doc_hdr, name_hdr )) + (tcg_rn_decls tc_result) + where (doc_hdr, name_hdr) = tcg_hdr_info tc_result + +runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv +runTypecheckerPlugin sum gbl_env = do + hsc_env <- getTopEnv + withPlugins (hsc_plugins hsc_env) + (\p opts env -> mark_plugin_unsafe (hsc_dflags hsc_env) + >> typeCheckResultAction p opts sum env) + gbl_env + +mark_plugin_unsafe :: DynFlags -> TcM () +mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ + recordUnsafeInfer pluginUnsafe + where + !diag_opts = initDiagOpts dflags + pluginUnsafe = + singleMessage $ + mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin + + +-- Note [Typechecking default declarations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Typechecking default declarations requires careful placement: +-- +-- 1. We must check them after types (tcTyAndClassDecls) because they can refer +-- to them. E.g. +-- +-- data T = MkT ... +-- default(Int, T, Integer) +-- +-- -- or even (tested by T11974b and T2245) +-- default(Int, T, Integer) +-- data T = MkT ... +-- +-- 2. We must check them before typechecking deriving clauses (tcInstDeclsDeriv) +-- otherwise we may lookup default default types (Integer, Double) while checking +-- deriving clauses, ignoring the default declaration. +-- +-- Before this careful placement (#24566), compiling the following example +-- (T24566) with "-ddump-if-trace -ddump-tc-trace" showed a call to +-- `applyDefaultingRules` with default types set to "(Integer,Double)": +-- +-- module M where +-- +-- import GHC.Classes +-- default () +-- +-- data Foo a = Nothing | Just a +-- deriving (Eq, Ord) +-- +-- This was an issue while building modules like M in the ghc-internal package +-- because they would spuriously fail to build if the module defining Integer +-- (ghc-bignum:GHC.Num.Integer) wasn't compiled yet and its interface not to be +-- found. The implicit dependency between M and GHC.Num.Integer isn't known to +-- the build system. +-- In addition, trying to explicitly avoid the implicit dependency with `default +-- ()` didn't work, except if *standalone* deriving was used, which was an +-- inconsistent behavior. diff --git a/GHC/Tc/Module.hs-boot b/GHC/Tc/Module.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Module.hs-boot @@ -0,0 +1,7 @@ +module GHC.Tc.Module where + +import GHC.Types.SourceFile(HsBootOrSig) +import GHC.Types.TyThing(TyThing) +import GHC.Tc.Types (TcM) + +checkBootDeclM :: HsBootOrSig -> TyThing -> TyThing -> TcM () diff --git a/GHC/Tc/Plugin.hs b/GHC/Tc/Plugin.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Plugin.hs @@ -0,0 +1,206 @@ +-- | 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 + lookupTHName, + 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.Zonk.TcType 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, CtEvidence(..), GivenCtEvidence(..) ) +import GHC.Tc.Types.CtLoc ( CtLoc ) + +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.Plugins ( thNameToGhcNameIO ) + +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 ) + +import qualified GHC.Boot.TH.Syntax as TH + +-- | 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 + +-- | Resolve a @template-haskell@ 'TH.Name' to a GHC 'Name'. +-- +-- @since 9.14.1 +lookupTHName :: TH.Name -> TcPluginM (Maybe Name) +lookupTHName th = do + nc <- hsc_NC <$> getTopEnv + tcPluginIO $ thNameToGhcNameIO nc th + +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.Zonk.Type". +zonkTcType :: TcType -> TcPluginM TcType +zonkTcType = unsafeTcPluginTcM . TcM.liftZonkM . TcM.zonkTcType + +zonkCt :: Ct -> TcPluginM Ct +zonkCt = unsafeTcPluginTcM . TcM.liftZonkM . 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 $ + GivenCt { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc } + +-- | Create a fresh evidence variable. +-- +-- This should only be invoked within 'tcPluginSolve'. +newEvVar :: PredType -> TcPluginM EvVar +newEvVar = unsafeTcPluginTcM . TcM.newEvVar + +-- | Create a fresh coercion hole. +-- This should only be invoked within 'tcPluginSolve'. +newCoercionHole :: PredType -> TcPluginM CoercionHole +newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole + +-- | Bind an evidence variable. +-- +-- This should only be invoked within 'tcPluginSolve'. +setEvBind :: EvBindsVar -> EvBind -> TcPluginM () +setEvBind tc_evbinds ev_bind = do + unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind diff --git a/GHC/Tc/Solver.hs b/GHC/Tc/Solver.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver.hs @@ -0,0 +1,2247 @@ +{-# LANGUAGE MultiWayIf, RecursiveDo, TupleSections #-} + +module GHC.Tc.Solver( + InferMode(..), simplifyInfer, findInferredDiff, + growThetaTyVars, + simplifyAmbiguityCheck, + simplifyTop, simplifyTopImplic, + simplifyInteractive, + solveEqualities, + pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX, + reportUnsolvedEqualities, + simplifyWantedsTcM, + tcCheckGivens, + tcCheckWanteds, + tcNormalise, + approximateWC, -- Exported for plugins to use + + captureTopConstraints, emitResidualConstraints, + + simplifyTopWanteds, + + promoteTyVarSet, simplifyAndEmitFlatConstraints + + ) where + +import GHC.Prelude + +import GHC.Tc.Errors +import GHC.Tc.Errors.Types +import GHC.Tc.Types.Evidence +import GHC.Tc.Solver.Solve ( solveSimpleGivens, solveSimpleWanteds + , solveWanteds, simplifyWantedsTcM ) +import GHC.Tc.Solver.Default ( tryDefaulting, tryDefaultingForAmbiguityCheck + , isInteractiveClass ) +import GHC.Tc.Solver.Dict ( makeSuperClasses ) +import GHC.Tc.Solver.Rewrite ( rewriteType ) +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.TcMType as TcM +import GHC.Tc.Utils.Monad as TcM +import GHC.Tc.Zonk.TcType as TcM +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Monad as TcS +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( mkGivenLoc ) +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType + +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Ppr +import GHC.Core.TyCon ( TyConBinder ) + +import GHC.Types.Name +import GHC.Types.Id + +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Error + +import GHC.Driver.DynFlags( DynFlags, xopt ) +import GHC.Driver.Flags( WarningFlag(..) ) +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Utils.Misc( filterOut ) + +import GHC.Data.Bag + +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.List ( partition ) +import GHC.Data.Maybe ( mapMaybe ) + +{- +********************************************************************************* +* * +* External interface * +* * +********************************************************************************* +-} + +captureTopConstraints :: TcM a -> TcM (a, WantedConstraints) +-- (captureTopConstraints m) runs m, and returns the type constraints it +-- generates plus the constraints produced by static forms inside. +-- If it fails with an exception, it reports any insolubles +-- (out of scope variables) before doing so +-- +-- captureTopConstraints is used exclusively by GHC.Tc.Module at the top +-- level of a module. +-- +-- Importantly, if captureTopConstraints propagates an exception, it +-- reports any insoluble constraints first, lest they be lost +-- altogether. This is important, because solveEqualities (maybe +-- other things too) throws an exception without adding any error +-- messages; it just puts the unsolved constraints back into the +-- monad. See GHC.Tc.Utils.Monad Note [Constraints and errors] +-- #16376 is an example of what goes wrong if you don't do this. +-- +-- NB: the caller should bring any environments into scope before +-- calling this, so that the reportUnsolved has access to the most +-- complete GlobalRdrEnv +captureTopConstraints thing_inside + = do { static_wc_var <- TcM.newTcRef emptyWC ; + ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $ + TcM.tryCaptureConstraints thing_inside + ; stWC <- TcM.readTcRef static_wc_var + + -- See GHC.Tc.Utils.Monad Note [Constraints and errors] + -- If the thing_inside threw an exception, but generated some insoluble + -- constraints, report the latter before propagating the exception + -- Otherwise they will be lost altogether + ; case mb_res of + Just res -> return (res, lie `andWC` stWC) + Nothing -> do { _ <- simplifyTop lie; failM } } + -- This call to simplifyTop is the reason + -- this function is here instead of GHC.Tc.Utils.Monad + -- We call simplifyTop so that it does defaulting + -- (esp of runtime-reps) before reporting errors + +simplifyTopImplic :: Bag Implication -> TcM () +simplifyTopImplic implics + = do { empty_binds <- simplifyTop (mkImplicWC implics) + + -- Since all the inputs are implications the returned bindings will be empty + ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) + + ; return () } + +simplifyTop :: WantedConstraints -> TcM (Bag EvBind) +-- Simplify top-level constraints +-- Usually these will be implications, +-- but when there is nothing to quantify we don't wrap +-- in a degenerate implication, so we do that here instead +simplifyTop wanteds + = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds + ; ((final_wc, unsafe_ol), binds1) <- runTcS $ + do { final_wc <- simplifyTopWanteds wanteds + ; unsafe_ol <- getSafeOverlapFailures + ; return (final_wc, unsafe_ol) } + ; traceTc "End simplifyTop }" empty + + ; binds2 <- reportUnsolved final_wc + + ; traceTc "reportUnsolved (unsafe overlapping) {" empty + ; unless (isEmptyBag unsafe_ol) $ do { + -- grab current error messages and clear, warnAllUnsolved will + -- update error messages which we'll grab and then restore saved + -- messages. + ; errs_var <- getErrsVar + ; saved_msg <- TcM.readTcRef errs_var + ; TcM.writeTcRef errs_var emptyMessages + + ; warnAllUnsolved $ emptyWC { wc_simple = fmap CDictCan unsafe_ol } + + ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var + ; TcM.writeTcRef errs_var saved_msg + ; recordUnsafeInfer (mkMessages whyUnsafe) + } + ; traceTc "reportUnsolved (unsafe overlapping) }" empty + + ; return (evBindMapBinds binds1 `unionBags` binds2) } + +pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a +-- Push level, and solve all resulting equalities +-- If there are any unsolved equalities, report them +-- and fail (in the monad) +-- +-- Panics if we solve any non-equality constraints. (In runTCSEqualities +-- we use an error thunk for the evidence bindings.) +pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside + = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX + "pushLevelAndSolveEqualities" thing_inside + ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted + ; return res } + +pushLevelAndSolveEqualitiesX :: String -> TcM a + -> TcM (TcLevel, WantedConstraints, a) +-- Push the level, gather equality constraints, and then solve them. +-- Returns any remaining unsolved equalities. +-- Does not report errors. +-- +-- Panics if we solve any non-equality constraints. (In runTCSEqualities +-- we use an error thunk for the evidence bindings.) +pushLevelAndSolveEqualitiesX callsite thing_inside + = do { traceTc "pushLevelAndSolveEqualitiesX {" (text "Called from" <+> text callsite) + ; (tclvl, (wanted, res)) + <- pushTcLevelM $ + do { (res, wanted) <- captureConstraints thing_inside + ; wanted <- runTcSEqualities (simplifyTopWanteds wanted) + ; return (wanted,res) } + ; traceTc "pushLevelAndSolveEqualities }" (vcat [ text "Residual:" <+> ppr wanted + , text "Level:" <+> ppr tclvl ]) + ; return (tclvl, wanted, res) } + +-- | Type-check a thing that emits only equality constraints, solving any +-- constraints we can and re-emitting constraints that we can't. +-- Use this variant only when we'll get another crack at it later +-- See Note [Failure in local type signatures] +-- +-- Panics if we solve any non-equality constraints. (In runTCSEqualities +-- we use an error thunk for the evidence bindings.) +solveEqualities :: String -> TcM a -> TcM a +solveEqualities callsite thing_inside + = do { traceTc "solveEqualities {" (text "Called from" <+> text callsite) + ; (res, wanted) <- captureConstraints thing_inside + ; simplifyAndEmitFlatConstraints wanted + -- simplifyAndEmitFlatConstraints fails outright unless + -- the only unsolved constraints are soluble-looking + -- equalities that can float out + ; traceTc "solveEqualities }" empty + ; return res } + +simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM () +-- See Note [Failure in local type signatures] +simplifyAndEmitFlatConstraints wanted + = do { -- Solve and zonk to establish the + -- preconditions for floatKindEqualities + wanted <- runTcSEqualities (solveWanteds wanted) + ; wanted <- TcM.liftZonkM $ TcM.zonkWC wanted + + ; traceTc "emitFlatConstraints {" (ppr wanted) + ; case floatKindEqualities wanted of + Nothing -> do { traceTc "emitFlatConstraints } failing" (ppr wanted) + -- Emit the bad constraints, wrapped in an implication + -- See Note [Wrapping failing kind equalities] + ; tclvl <- TcM.getTcLevel + ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted + -- ^^^^^^ | ^^^^^^^^^^^^^^^^^ + -- it's OK to use unkSkol | we must increase the TcLevel, + -- because we don't bind | as explained in + -- any skolem variables here | Note [Wrapping failing kind equalities] + ; TcM.emitImplication implic + ; failM } + Just (simples, errs) + -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples) + ; traceTc "emitFlatConstraints }" $ + vcat [ text "simples:" <+> ppr simples + , text "errs: " <+> ppr errs ] + -- Holes and other delayed errors don't need promotion + ; emitDelayedErrors errs + ; emitSimples simples } } + +floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) +-- Float out all the constraints from the WantedConstraints, +-- Return Nothing if any constraints can't be floated (captured +-- by skolems), or if there is an insoluble constraint, or +-- IC_Telescope telescope error +-- Precondition 1: we have tried to solve the 'wanteds', both so that +-- the ic_status field is set, and because solving can make constraints +-- more floatable. +-- Precondition 2: the 'wanteds' are zonked, since floatKindEqualities +-- is not monadic +-- See Note [floatKindEqualities vs approximateWC] +floatKindEqualities wc = float_wc emptyVarSet wc + where + float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) + float_wc trapping_tvs (WC { wc_simple = simples + , wc_impl = implics + , wc_errors = errs }) + | all is_floatable simples + = do { (inner_simples, inner_errs) + <- flatMapBagPairM (float_implic trapping_tvs) implics + ; return ( simples `unionBags` inner_simples + , errs `unionBags` inner_errs) } + | otherwise + = Nothing + where + is_floatable ct + | insolubleCt ct = False + | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs + + float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError) + float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs + , ic_skols = skols, ic_status = status }) + | isInsolubleStatus status + = Nothing -- A short cut /plus/ we must keep track of IC_BadTelescope + | otherwise + = do { (simples, holes) <- float_wc new_trapping_tvs wanted + ; when (not (isEmptyBag simples) && given_eqs == MaybeGivenEqs) $ + Nothing + -- If there are some constraints to float out, but we can't + -- because we don't float out past local equalities + -- (c.f GHC.Tc.Solver.approximateWC), then fail + ; return (simples, holes) } + where + new_trapping_tvs = trapping_tvs `extendVarSetList` skols + + +{- Note [Failure in local type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind checking a type signature, we like to fail fast if we can't +solve all the kind equality constraints, for two reasons: + + * A kind-bogus type signature may cause a cascade of knock-on + errors if we let it pass + + * More seriously, we don't have a convenient term-level place to add + deferred bindings for unsolved kind-equality constraints. In + earlier GHCs this led to un-filled-in coercion holes, which caused + GHC to crash with "fvProv falls into a hole" See #11563, #11520, + #11516, #11399 + +But what about /local/ type signatures, mentioning in-scope type +variables for which there might be 'given' equalities? For these we +might not be able to solve all the equalities locally. Here's an +example (T15076b): + + class (a ~ b) => C a b + data SameKind :: k -> k -> Type where { SK :: SameKind a b } + + bar :: forall (a :: Type) (b :: Type). + C a b => Proxy a -> Proxy b -> () + bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y) + +Consider the type signature on 'undefined'. It's ill-kinded unless +a~b. But the superclass of (C a b) means that indeed (a~b). So all +should be well. BUT it's hard to see that when kind-checking the signature +for undefined. We want to emit a residual (a~b) constraint, to solve +later. + +Another possibility is that we might have something like + F alpha ~ [Int] +where alpha is bound further out, which might become soluble +"later" when we learn more about alpha. So we want to emit +those residual constraints. + +BUT it's no good simply wrapping all unsolved constraints from +a type signature in an implication constraint to solve later. The +problem is that we are going to /use/ that signature, including +instantiate it. Say we have + f :: forall a. (forall b. blah) -> blah2 + f x = +To typecheck the definition of f, we have to instantiate those +foralls. Moreover, any unsolved kind equalities will be coercion +holes in the type. If we naively wrap them in an implication like + forall a. (co1:k1~k2, forall b. co2:k3~k4) +hoping to solve it later, we might end up filling in the holes +co1 and co2 with coercions involving 'a' and 'b' -- but by now +we've instantiated the type. Chaos! + +Moreover, the unsolved constraints might be skolem-escape things, and +if we proceed with f bound to a nonsensical type, we get a cascade of +follow-up errors. For example polykinds/T12593, T15577, and many others. + +So here's the plan (see tcHsSigType): + +* pushLevelAndSolveEqualitiesX: try to solve the constraints + +* kindGeneraliseSome: do kind generalisation + +* buildTvImplication: build an implication for the residual, unsolved + constraint + +* simplifyAndEmitFlatConstraints: try to float out every unsolved equality + inside that implication, in the hope that it constrains only global + type variables, not the locally-quantified ones. + + * If we fail, or find an insoluble constraint, emit the implication, + so that the errors will be reported, and fail. + + * If we succeed in floating all the equalities, promote them and + re-emit them as flat constraint, not wrapped at all (since they + don't mention any of the quantified variables. + +* Note that this float-and-promote step means that anonymous + wildcards get floated to top level, as we want; see + Note [Checking partial type signatures] in GHC.Tc.Gen.HsType. + +All this is done: + +* In GHC.Tc.Gen.HsType.tcHsSigType, as above + +* solveEqualities. Use this when there no kind-generalisation + step to complicate matters; then we don't need to push levels, + and can solve the equalities immediately without needing to + wrap it in an implication constraint. (You'll generally see + a kindGeneraliseNone nearby.) + +* In GHC.Tc.TyCl and GHC.Tc.TyCl.Instance; see calls to + pushLevelAndSolveEqualitiesX, followed by quantification, and + then reportUnsolvedEqualities. + + NB: we call reportUnsolvedEqualities before zonkTcTypeToType + because the latter does not expect to see any un-filled-in + coercions, which will happen if we have unsolved equalities. + By calling reportUnsolvedEqualities first, which fails after + reporting errors, we avoid that happening. + +See also #18062, #11506 + +Note [Wrapping failing kind equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In simplifyAndEmitFlatConstraints, if we fail to get down to simple +flat constraints we will +* re-emit the constraints so that they are reported +* fail in the monad +But there is a Terrible Danger that, if -fdefer-type-errors is on, and +we just re-emit an insoluble constraint like (* ~ (*->*)), that we'll +report only a warning and proceed with compilation. But if we ever fail +in the monad it should be fatal; we should report an error and stop after +the type checker. If not, chaos results: #19142. + +Our solution is this: +* Even with -fdefer-type-errors, inside an implication with no place for + value bindings (ic_binds = CoEvBindsVar), report failing equalities as + errors. We have to do this anyway; see GHC.Tc.Errors + Note [Failing equalities with no evidence bindings]. + +* Right here in simplifyAndEmitFlatConstraints, use buildTvImplication + to wrap the failing constraint in a degenerate implication (no + skolems, no theta), with ic_binds = CoEvBindsVar. This setting of + `ic_binds` means that any failing equalities will lead to an + error not a warning, irrespective of -fdefer-type-errors: see + Note [Failing equalities with no evidence bindings] in GHC.Tc.Errors, + and `maybeSwitchOffDefer` in that module. + + We still take care to bump the TcLevel of the implication. Partly, + that ensures that nested implications have increasing level numbers + which seems nice. But more specifically, suppose the outer level + has a Given `(C ty)`, which has pending (not-yet-expanded) + superclasses. Consider what happens when we process this implication + constraint (which we have re-emitted) in that context: + - in the inner implication we'll call `getPendingGivenScs`, + - we /do not/ want to get the `(C ty)` from the outer level, + lest we try to add an evidence term for the superclass, + which we can't do because we have specifically set + `ic_binds` = `CoEvBindsVar`. + - as `getPendingGivenSCcs is careful to only get Givens from + the /current/ level, and we bumped the `TcLevel` of the implication, + we're OK. + + TL;DR: bump the `TcLevel` when creating the nested implication. + If we don't we get a panic in `GHC.Tc.Utils.Monad.addTcEvBind` (#20043). + + +We re-emit the implication rather than reporting the errors right now, +so that the error messages are improved by other solving and defaulting. +e.g. we prefer + Cannot match 'Type->Type' with 'Type' +to Cannot match 'Type->Type' with 'TYPE r0' + + +Note [floatKindEqualities vs approximateWC] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +floatKindEqualities and approximateWC are strikingly similar to each +other, but + +* floatKindEqualites tries to float /all/ equalities, and fails if + it can't, or if any implication is insoluble. +* approximateWC just floats out any constraints + (not just equalities) that can float; it never fails. +-} + + +reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel + -> WantedConstraints -> TcM () +-- Reports all unsolved wanteds provided; fails in the monad if there are any. +-- +-- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to +-- provide skolem info for any errors. +reportUnsolvedEqualities skol_info skol_tvs tclvl wanted + = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted + +report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel + -> WantedConstraints -> TcM () +report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted + | isEmptyWC wanted + = return () + + | otherwise -- NB: we build an implication /even if skol_tvs is empty/, + -- just to ensure that our level invariants hold, specifically + -- (WantedInv). See Note [TcLevel invariants]. + = checkNoErrs $ -- Fail + do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted + ; reportAllUnsolved (mkImplicWC (unitBag implic)) } + + +-- | Simplify top-level constraints, but without reporting any unsolved +-- constraints nor unsafe overlapping. +simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints +simplifyTopWanteds wanteds + = do { -- Solve the constraints + wc_first_go <- nestTcS (solveWanteds wanteds) + + -- Now try defaulting: + -- see Note [Top-level Defaulting Plan] + ; tryDefaulting wc_first_go } + +{- Note [Safe Haskell Overlapping Instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Safe Haskell, we apply an extra restriction to overlapping instances. The +motive is to prevent untrusted code provided by a third-party, changing the +behavior of trusted code through type-classes. This is due to the global and +implicit nature of type-classes that can hide the source of the dictionary. + +Another way to state this is: if a module M compiles without importing another +module N, changing M to import N shouldn't change the behavior of M. + +Overlapping instances with type-classes can violate this principle. However, +overlapping instances aren't always unsafe. They are just unsafe when the most +selected dictionary comes from untrusted code (code compiled with -XSafe) and +overlaps instances provided by other modules. + +In particular, in Safe Haskell at a call site with overlapping instances, we +apply the following rule to determine if it is a 'unsafe' overlap: + + 1) Most specific instance, I1, defined in an `-XSafe` compiled module. + 2) I1 is an orphan instance or a MPTC. + 3) At least one overlapped instance, Ix, is both: + A) from a different module than I1 + B) Ix is not marked `OVERLAPPABLE` + +This is a slightly involved heuristic, but captures the situation of an +imported module N changing the behavior of existing code. For example, if +condition (2) isn't violated, then the module author M must depend either on a +type-class or type defined in N. + +Secondly, when should these heuristics be enforced? We enforced them when the +type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. +This allows `-XUnsafe` modules to operate without restriction, and for Safe +Haskell inference to infer modules with unsafe overlaps as unsafe. + +One alternative design would be to also consider if an instance was imported as +a `safe` import or not and only apply the restriction to instances imported +safely. However, since instances are global and can be imported through more +than one path, this alternative doesn't work. + +Note [Safe Haskell Overlapping Instances Implementation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How is this implemented? It's complicated! So we'll step through it all: + + 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where + we check if a particular type-class method call is safe or unsafe. We do this + through the return type, `ClsInstLookupResult`, where the last parameter is a + list of instances that are unsafe to overlap. When the method call is safe, + the list is null. + + 2) `GHC.Tc.Solver.Dict.matchClassInst` -- This module drives the instance resolution + / dictionary generation. The return type is `ClsInstResult`, which either + says no instance matched, or one found, and if it was a safe or unsafe + overlap. + + 3) `GHC.Tc.Solver.Dict.tryInstances` -- Takes a dictionary / class constraint and + tries to resolve it by calling (in part) `matchClassInst`. The resolving + mechanism has a work list (of constraints) that it process one at a time. If + the constraint can't be resolved, it's added to an inert set. When compiling + an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know + compilation should fail. These are handled as normal constraint resolution + failures from here-on (see step 6). + + Otherwise, we may be inferring safety (or using `-Wunsafe`), and + compilation should succeed, but print warnings and/or mark the compiled module + as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds + the unsafe (but resolved!) constraint to the `inert_safehask` field of + `InertCans`. + + 4) `GHC.Tc.Solver.simplifyTop`: + * Call simplifyTopWanteds, the top-level function for driving the simplifier for + constraint resolution. + + * Once finished, call `getSafeOverlapFailures` to retrieve the + list of overlapping instances that were successfully resolved, + but unsafe. Remember, this is only applicable for generating warnings + (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy` + cause compilation failure by not resolving the unsafe constraint at all. + + * For unresolved constraints (all types), call `GHC.Tc.Errors.reportUnsolved`, + while for resolved but unsafe overlapping dictionary constraints, call + `GHC.Tc.Errors.warnAllUnsolved`. Both functions convert constraints into a + warning message for the user. + + * In the case of `warnAllUnsolved` for resolved, but unsafe + dictionary constraints, we collect the generated warning + message (pop it) and call `GHC.Tc.Utils.Monad.recordUnsafeInfer` to + mark the module we are compiling as unsafe, passing the + warning message along as the reason. + + 5) `GHC.Tc.Errors.*Unsolved` -- Generates error messages for constraints by + actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we + know is the constraint that is unresolved or unsafe. For dictionary, all we + know is that we need a dictionary of type C, but not what instances are + available and how they overlap. So we once again call `lookupInstEnv` to + figure that out so we can generate a helpful error message. + + 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in + IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`. + + 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling + `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inference + failed. +-} + +------------------ +simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () +simplifyAmbiguityCheck ty wc + = do { traceTc "simplifyAmbiguityCheck {" $ + text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wc + + ; (final_wc, _) <- runTcS $ do { wc1 <- solveWanteds wc + ; tryDefaultingForAmbiguityCheck wc1 } + + ; discardResult (reportUnsolved final_wc) + + ; traceTc "End simplifyAmbiguityCheck }" empty } + +------------------ +simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) +simplifyInteractive wanteds + = traceTc "simplifyInteractive" empty >> + simplifyTop wanteds + +------------------ +{- Note [Pattern match warnings with insoluble Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A pattern match on a GADT can introduce new type-level information, which needs +to be analysed in order to get the expected pattern match warnings. + +For example: + +> type IsBool :: Type -> Constraint +> type family IsBool a where +> IsBool Bool = () +> IsBool b = b ~ Bool +> +> data T a where +> MkTInt :: Int -> T Int +> MkTBool :: IsBool b => b -> T b +> +> f :: T Int -> Int +> f (MkTInt i) = i + +The pattern matching performed by `f` is complete: we can't ever call +`f (MkTBool b)`, as type-checking that application would require producing +evidence for `Int ~ Bool`, which can't be done. + +The pattern match checker uses `tcCheckGivens` to accumulate all the Given +constraints, and relies on `tcCheckGivens` to return Nothing if the +Givens become insoluble. `tcCheckGivens` in turn relies on `insolubleCt` +to identify these insoluble constraints. So the precise definition of +`insolubleCt` has a big effect on pattern match overlap warnings. + +To detect this situation, we check whether there are any insoluble Given +constraints. In the example above, the insoluble constraint was an +equality constraint, but it is also important to detect custom type errors: + +> type NotInt :: Type -> Constraint +> type family NotInt a where +> NotInt Int = TypeError (Text "That's Int, silly.") +> NotInt _ = () +> +> data R a where +> MkT1 :: a -> R a +> MkT2 :: NotInt a => R a +> +> foo :: R Int -> Int +> foo (MkT1 x) = x + +To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble +because it is a custom type error. +Failing to do so proved quite inconvenient for users, as evidence by the +tickets #11503 #14141 #16377 #20180. +Test cases: T11503, T14141. + +Examples of constraints that tcCheckGivens considers insoluble: + - Int ~ Bool, + - Coercible Float Word, + - TypeError msg. + +Non-examples: + - constraints which we know aren't satisfied, + e.g. Show (Int -> Int) when no such instance is in scope, + - Eq (TypeError msg), + - C (Int ~ Bool), with @class C (c :: Constraint)@. +-} + +tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) +-- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely +-- contradictory. +-- +-- See Note [Pattern match warnings with insoluble Givens] above. +tcCheckGivens inerts given_ids = do + (sat, new_inerts) <- runTcSInerts inerts $ do + traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids) + lcl_env <- TcS.getLclEnv + let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) + let given_cts = mkGivens given_loc (bagToList given_ids) + -- See Note [Superclasses and satisfiability] + solveSimpleGivens given_cts + insols <- getInertInsols + insols <- try_harder insols + traceTcS "checkGivens }" (ppr insols) + return (isEmptyBag insols) + return $ if sat then Just new_inerts else Nothing + where + try_harder :: Cts -> TcS Cts + -- Maybe we have to search up the superclass chain to find + -- an unsatisfiable constraint. Example: pmcheck/T3927b. + -- At the moment we try just once + try_harder insols + | not (isEmptyBag insols) -- We've found that it's definitely unsatisfiable + = return insols -- Hurrah -- stop now. + | otherwise + = do { pending_given <- getPendingGivenScs + ; new_given <- makeSuperClasses pending_given + ; solveSimpleGivens new_given + ; getInertInsols } + +tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool +-- ^ Return True if the Wanteds are soluble, False if not +tcCheckWanteds inerts wanteds = do + cts <- newWanteds PatCheckOrigin wanteds + (sat, _new_inerts) <- runTcSInerts inerts $ do + traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds) + -- See Note [Superclasses and satisfiability] + wcs <- solveWanteds (mkSimpleWC cts) + traceTcS "checkWanteds }" (ppr wcs) + return (isSolvedWC wcs) + return sat + +-- | Normalise a type as much as possible using the given constraints. +-- See @Note [tcNormalise]@. +tcNormalise :: InertSet -> Type -> TcM Type +tcNormalise inerts ty + = do { norm_loc <- getCtLocM PatCheckOrigin Nothing + ; (res, _new_inerts) <- runTcSInerts inerts $ + do { traceTcS "tcNormalise {" (ppr inerts) + ; ty' <- rewriteType norm_loc ty + ; traceTcS "tcNormalise }" (ppr ty') + ; pure ty' } + ; return res } + +{- Note [Superclasses and satisfiability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Expand superclasses before starting, because (Int ~ Bool), has +(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool) +as a superclass, and it's the latter that is insoluble. See +Note [The equality types story] in GHC.Builtin.Types.Prim. + +If we fail to prove unsatisfiability we (arbitrarily) try just once to +find superclasses, using try_harder. Reason: we might have a type +signature + f :: F op (Implements push) => .. +where F is a type function. This happened in #3972. + +We could do more than once but we'd have to have /some/ limit: in the +the recursive case, we would go on forever in the common case where +the constraints /are/ satisfiable (#10592 comment:12!). + +For straightforward situations without type functions the try_harder +step does nothing. + +Note [tcNormalise] +~~~~~~~~~~~~~~~~~~ +tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas +most invocations of the constraint solver are intended to simplify a set of +constraints or to decide if a particular set of constraints is satisfiable, +the purpose of tcNormalise is to take a type, plus some locally solved +constraints in the form of an InertSet, and normalise the type as much as +possible with respect to those constraints. + +It does *not* reduce type or data family applications or look through newtypes. + +Why is this useful? As one example, when coverage-checking an EmptyCase +expression, it's possible that the type of the scrutinee will only reduce +if some local equalities are solved for. See "Wrinkle: Local equalities" +in Note [Type normalisation] in "GHC.HsToCore.Pmc". + +To accomplish its stated goal, tcNormalise first initialises the solver monad +with the given InertCans, then uses rewriteType to simplify the desired type +with respect to the Givens in the InertCans. + +*********************************************************************************** +* * +* Inference +* * +*********************************************************************************** + +Note [Inferring the type of a let-bound variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = rhs + +To infer f's type we do the following: + * Gather the constraints for the RHS with ambient level *one more than* + the current one. This is done by the call + pushLevelAndCaptureConstraints (tcMonoBinds...) + in GHC.Tc.Gen.Bind.tcPolyInfer + + * Call simplifyInfer to simplify the constraints and decide what to + quantify over. We pass in the level used for the RHS constraints, + here called rhs_tclvl. + +This ensures that the implication constraint we generate, if any, +has a strictly-increased level compared to the ambient level outside +the let binding. + +Note [Inferring principal types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't always infer principal types. For instance, the inferred type for + +> f x = show [x] + +is + +> f :: Show a => a -> String + +This is not the most general type if we allow flexible contexts. +Indeed, if we try to write the following + +> g :: Show [a] => a -> String +> g x = f x + +we get the error: + + * Could not deduce (Show a) arising from a use of `f' + from the context: Show [a] + +Though replacing f x in the right-hand side of g with the definition +of f x works, the call to f x does not. This is the hallmark of +unprincip{led,al} types. + +Another example: + +> class C a +> class D a where +> d :: a +> instance C a => D a where +> d = undefined +> h _ = d -- argument is to avoid the monomorphism restriction + +The inferred type for h is + +> h :: C a => t -> a + +even though + +> h :: D a => t -> a + +is more general. + +The fix is easy: don't simplify constraints before inferring a type. +That is, have the inferred type quantify over all constraints that arise +in a definition's right-hand side, even if they are simplifiable. +Unfortunately, this would yield all manner of unwieldy types, +and so we won't do so. +-} + +-- | How should we choose which constraints to quantify over? +data InferMode = ApplyMR -- ^ Apply the monomorphism restriction, + -- never quantifying over any constraints + | EagerDefaulting -- ^ See Note [TcRnExprMode] in "GHC.Tc.Module", + -- the :type +d case; this mode refuses + -- to quantify over any defaultable constraint + | NoRestrictions -- ^ Quantify over any constraint that + -- satisfies pickQuantifiablePreds + +instance Outputable InferMode where + ppr ApplyMR = text "ApplyMR" + ppr EagerDefaulting = text "EagerDefaulting" + ppr NoRestrictions = text "NoRestrictions" + +simplifyInfer :: TopLevelFlag + -> TcLevel -- Used when generating the constraints + -> InferMode + -> [TcIdSigInst] -- Any signatures (possibly partial) + -> [(Name, TcTauType)] -- Variables to be generalised, + -- and their tau-types + -> WantedConstraints + -> TcM ([TcTyVar], -- Quantify over these type variables + [EvVar], -- ... and these constraints (fully zonked) + TcEvBinds, -- ... binding these evidence variables + Bool) -- True <=> the residual constraints are insoluble + +simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds + | isEmptyWC wanteds + = do { -- When quantifying, we want to preserve any order of variables as they + -- appear in partial signatures. cf. decideQuantifiedTyVars + let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs + , (_,Bndr tv _) <- sig_inst_skols sig ] + psig_theta = [ pred | sig <- partial_sigs + , pred <- sig_inst_theta sig ] + + ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) + + ; skol_info <- mkSkolemInfo (InferSkol name_taus) + ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars + ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) + ; return (qtkvs, [], emptyTcEvBinds, False) } + + | otherwise + = do { traceTc "simplifyInfer {" $ vcat + [ text "sigs =" <+> ppr sigs + , text "binds =" <+> ppr name_taus + , text "rhs_tclvl =" <+> ppr rhs_tclvl + , text "infer_mode =" <+> ppr infer_mode + , text "(unzonked) wanted =" <+> ppr wanteds + ] + + ; let psig_theta = concatMap sig_inst_theta partial_sigs + + -- First do full-blown solving + -- NB: we must gather up all the bindings from doing this solving; hence + -- (runTcSWithEvBinds ev_binds_var). And note that since there are + -- nested implications, calling solveWanteds will side-effect their + -- evidence bindings, so we can't just revert to the input constraint. + -- + -- See also Note [Inferring principal types] + ; ev_binds_var <- TcM.newTcEvBinds + ; psig_evs <- newWanteds AnnOrigin psig_theta + ; wanted_transformed + <- runTcSWithEvBinds ev_binds_var $ + setTcLevelTcS rhs_tclvl $ + solveWanteds (mkSimpleWC psig_evs `andWC` wanteds) + -- setLevelTcS: we do setLevel /inside/ the runTcS, so that + -- we initialise the InertSet inert_given_eq_lvl as far + -- out as possible, maximising oppportunities to unify + -- psig_evs : see Note [Add signature contexts as wanteds] + + -- Find quant_pred_candidates, the predicates that + -- we'll consider quantifying over + -- NB1: wanted_transformed does not include anything provable from + -- the psig_theta; it's just the extra bit + -- NB2: We do not do any defaulting when inferring a type, this can lead + -- to less polymorphic types, see Note [Default while Inferring] + ; wanted_transformed <- TcM.liftZonkM $ TcM.zonkWC wanted_transformed + ; let definite_error = insolubleWC wanted_transformed + -- See Note [Quantification with errors] + wanted_dq | definite_error = emptyWC + | otherwise = wanted_transformed + + -- Decide what type variables and constraints to quantify + -- NB: quant_pred_candidates is already fully zonked + -- NB: bound_theta are constraints we want to quantify over, + -- including the psig_theta, which we always quantify over + -- NB: bound_theta are fully zonked + -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification + top_lvl rhs_tclvl infer_mode + skol_info name_taus partial_sigs + wanted_dq + + ; bound_theta_vars <- mapM TcM.newEvVar bound_theta + + ; let full_theta = map idType bound_theta_vars + skol_info = InferSkol [ (name, mkPhiTy full_theta ty) + | (name, ty) <- name_taus ] + -- mkPhiTy: we don't add the quantified variables here, because + -- they are also bound in ic_skols and we want them to be tidied + -- uniformly. + } + + + -- Now emit the residual constraint + ; emitResidualConstraints rhs_tclvl skol_info ev_binds_var + co_vars qtvs bound_theta_vars + wanted_transformed + + -- All done! + ; traceTc "} simplifyInfer/produced residual implication for quantification" $ + vcat [ text "wanted_dq =" <+> ppr wanted_dq + , text "psig_theta =" <+> ppr psig_theta + , text "bound_theta =" <+> pprCoreBinders bound_theta_vars + , text "qtvs =" <+> ppr qtvs + , text "definite_error =" <+> ppr definite_error ] + + ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) } + -- NB: bound_theta_vars must be fully zonked + where + partial_sigs = filter isPartialSig sigs + +-------------------- +emitResidualConstraints :: TcLevel -> SkolemInfoAnon -> EvBindsVar + -> CoVarSet -> [TcTyVar] -> [EvVar] + -> WantedConstraints -> TcM () +-- Emit the remaining constraints from the RHS. +emitResidualConstraints rhs_tclvl skol_info ev_binds_var + co_vars qtvs full_theta_vars wanteds + | isEmptyWC wanteds + = return () + + | otherwise + = do { wanted_simple <- TcM.liftZonkM $ TcM.zonkSimples (wc_simple wanteds) + ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple + is_mono ct + | Just ct_ev_id <- wantedEvId_maybe ct + = ct_ev_id `elemVarSet` co_vars + | otherwise + = False + -- Reason for the partition: + -- see Note [Emitting the residual implication in simplifyInfer] + +-- Already done by defaultTyVarsAndSimplify +-- ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple) + + ; let inner_wanted = wanteds { wc_simple = inner_simple } + ; implics <- if isEmptyWC inner_wanted + then return emptyBag + else do implic1 <- newImplication + return $ unitBag $ + implic1 { ic_tclvl = rhs_tclvl + , ic_skols = qtvs + , ic_given = full_theta_vars + , ic_wanted = inner_wanted + , ic_binds = ev_binds_var + , ic_given_eqs = MaybeGivenEqs + , ic_info = skol_info } + + ; emitConstraints (emptyWC { wc_simple = outer_simple + , wc_impl = implics }) } + +-------------------- +findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType +-- Given a partial type signature f :: (C a, D a, _) => blah +-- and the inferred constraints (X a, D a, Y a, C a) +-- compute the difference, which is what will fill in the "_" underscore, +-- In this case the diff is (X a, Y a). +findInferredDiff annotated_theta inferred_theta + | null annotated_theta -- Short cut the common case when the user didn't + = return inferred_theta -- write any constraints in the partial signature + | otherwise + = pushTcLevelM_ $ + do { lcl_env <- TcM.getLclEnv + ; given_ids <- mapM TcM.newEvVar annotated_theta + ; wanteds <- newWanteds AnnOrigin inferred_theta + ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) + given_cts = mkGivens given_loc given_ids + + ; (residual_wc, _) <- runTcS $ + do { _ <- solveSimpleGivens given_cts + ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) } + -- NB: There are no meta tyvars fromn this level annotated_theta + -- because we have either promoted them or unified them + -- See `Note [Quantification and partial signatures]` Wrinkle 2 + + ; return (map (box_pred . ctPred) $ + bagToList (wc_simple residual_wc)) } + where + box_pred :: PredType -> PredType + box_pred pred = case classifyPredType pred of + EqPred rel ty1 ty2 + | Just (cls,tys) <- boxEqPred rel ty1 ty2 + -> mkClassPred cls tys + | otherwise + -> pprPanic "findInferredDiff" (ppr pred) + _other -> pred + +{- Note [Emitting the residual implication in simplifyInfer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = e +where f's type is inferred to be something like (a, Proxy k (Int |> co)) +and we have an as-yet-unsolved, or perhaps insoluble, constraint + [W] co :: Type ~ k +We can't form types like (forall co. blah), so we can't generalise over +the coercion variable, and hence we can't generalise over things free in +its kind, in the case 'k'. But we can still generalise over 'a'. So +we'll generalise to + f :: forall a. (a, Proxy k (Int |> co)) +Now we do NOT want to form the residual implication constraint + forall a. [W] co :: Type ~ k +because then co's eventual binding (which will be a value binding if we +use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose +type mentions 'co'). Instead, just as we don't generalise over 'co', we +should not bury its constraint inside the implication. Instead, we must +put it outside. + +That is the reason for the partitionBag in emitResidualConstraints, +which takes the CoVars free in the inferred type, and pulls their +constraints out. (NB: this set of CoVars should be closed-over-kinds.) + +All rather subtle; see #14584. + +Note [Add signature contexts as wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#11016): + f2 :: (?x :: Int) => _ + f2 = ?x + +or this + class C a b | a -> b + g :: C p q => p -> q + f3 :: C Int b => _ + f3 = g (3::Int) + +We'll use plan InferGen because there are holes in the type. But: + * For f2 we want to have the (?x :: Int) constraint floating around + so that the functional dependencies kick in. Otherwise the + occurrence of ?x on the RHS produces constraint (?x :: alpha), and + we won't unify alpha:=Int. + + * For f3 want the (C Int b) constraint from the partial signature + to meet the (C Int beta) constraint we get from the call to g; again, + fundeps + +Solution: in simplifyInfer, we add the constraints from the signature +as extra Wanteds. + +Why Wanteds? Wouldn't it be neater to treat them as Givens? Alas +that would mess up (GivenInv) in Note [TcLevel invariants]. Consider + f :: (Eq a, _) => blah1 + f = ....g... + g :: (Eq b, _) => blah2 + g = ...f... + +Then we have two psig_theta constraints (Eq a[tv], Eq b[tv]), both with +TyVarTvs inside. Ultimately a[tv] := b[tv], but only when we've solved +all those constraints. And both have level 1, so we can't put them as +Givens when solving at level 1. + +Best to treat them as Wanteds. + +But see also #20076, which would be solved if they were Givens. + + +************************************************************************ +* * + Quantification +* * +************************************************************************ + +Note [Deciding quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the monomorphism restriction does not apply, then we quantify as follows: + +* Step 1: decidePromotedTyVars. + Take the global tyvars, and "grow" them using functional dependencies + E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can + happen because alpha is untouchable here) then do not quantify over + beta, because alpha fixes beta, and beta is effectively free in + the environment too; this logic extends to general fundeps, not + just equalities + + We also account for the monomorphism restriction; if it applies, + add the free vars of all the constraints. + + Result is mono_tvs; we will promote all of these to the outer levek, + and certainly not quantify over them. + +* Step 2: defaultTyVarsAndSimplify. + Default any non-promoted tyvars (i.e ones that are definitely + not going to become further constrained), and re-simplify the + candidate constraints. + + Motivation for re-simplification (#7857): imagine we have a + constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are + not free in the envt, and instance forall (a::*) (b::*). (C a) => C + (a -> b) The instance doesn't match while l1,l2 are polymorphic, but + it will match when we default them to LiftedRep. + + This is all very tiresome. + + This step also promotes the mono_tvs from Step 1. See + Note [Promote monomorphic tyvars]. In fact, the *only* + use of the mono_tvs from Step 1 is to promote them here. + This promotion effectively stops us from quantifying over them + later, in Step 3. Because the actual variables to quantify + over are determined in Step 3 (not in Step 1), it is OK for + the mono_tvs to be missing some variables free in the + environment. This is why removing the psig_qtvs is OK in + decidePromotedTyVars. Test case for this scenario: T14479. + +* Step 3: decideQuantifiedTyVars. + Decide which variables to quantify over, as follows: + + - Take the free vars of the partial-type-signature types and constraints, + and the tau-type (zonked_tau_tvs), and then "grow" + them using all the constraints. These are grown_tcvs. + See Note [growThetaTyVars vs closeWrtFunDeps]. + + - Use quantifyTyVars to quantify over the free variables of all the types + involved, but only those in the grown_tcvs. + + Result is qtvs. + +* Step 4: Filter the constraints using pickQuantifiablePreds and the + qtvs. We have to zonk the constraints first, so they "see" the + freshly created skolems. + +Note [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 constraints 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. + +-} + +decideQuantification + :: TopLevelFlag + -> TcLevel + -> InferMode + -> SkolemInfoAnon + -> [(Name, TcTauType)] -- Variables to be generalised + -> [TcIdSigInst] -- Partial type signatures (if any) + -> WantedConstraints -- Candidate theta; already zonked + -> TcM ( [TcTyVar] -- Quantify over these (skolems) + , [PredType] -- and this context (fully zonked) + , CoVarSet) +-- See Note [Deciding quantification] +decideQuantification top_lvl rhs_tclvl infer_mode skol_info name_taus psigs wanted + = do { -- Step 1: find the mono_tvs + ; (candidates, co_vars) + <- decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted + + -- Step 2: default any non-mono tyvars, and re-simplify + -- This step may do some unification, but result candidates is zonked + ; candidates <- defaultTyVarsAndSimplify rhs_tclvl candidates + + -- Step 3: decide which kind/type variables to quantify over + ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates + + -- Step 4: choose which of the remaining candidate + -- predicates to actually quantify over + -- NB: decideQuantifiedTyVars turned some meta tyvars + -- into quantified skolems, so we have to zonk again + ; (candidates, psig_theta) <- TcM.liftZonkM $ + do { candidates <- TcM.zonkTcTypes candidates + ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs) + ; return (candidates, psig_theta) } + + -- Take account of partial type signatures + -- See Note [Constraints in partial type signatures] + ; let min_psig_theta = mkMinimalBySCs id psig_theta + min_theta = pickQuantifiablePreds (mkVarSet qtvs) candidates + ; theta <- if + | null psigs -> return min_theta -- Case (P3) + | not (all has_extra_constraints_wildcard psigs) -- Case (P2) + -> return min_psig_theta + | otherwise -- Case (P1) + -> do { diff <- findInferredDiff min_psig_theta min_theta + ; return (min_psig_theta ++ diff) } + + ; traceTc "decideQuantification" + (vcat [ text "infer_mode:" <+> ppr infer_mode + , text "candidates:" <+> ppr candidates + , text "psig_theta:" <+> ppr psig_theta + , text "co_vars:" <+> ppr co_vars + , text "qtvs:" <+> ppr qtvs + , text "theta:" <+> ppr theta ]) + ; return (qtvs, theta, co_vars) } + + where + has_extra_constraints_wildcard (TISI { sig_inst_wcx = Just {} }) = True + has_extra_constraints_wildcard _ = False + +{- Note [Constraints in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have decided to quantify over min_theta, say (Eq a, C a, Ix a). +Then we distinguish three cases: + +(P1) No partial type signatures: just quantify over min_theta + +(P2) Partial type signatures with no extra_constraints wildcard: + e.g. f :: (Eq a, C a) => a -> _ + Quantify over psig_theta: the user has explicitly specified the + entire context. + + That may mean we have an unsolved residual constraint (Ix a) arising + from the RHS of the function. But so be it: the user said (Eq a, C a). + +(P3) Partial type signature with an extra_constraints wildcard. + e.g. f :: (Eq a, C a, _) => a -> a + Quantify over (psig_theta ++ diff) + where diff = min_theta - psig_theta, using findInferredDiff. + In our example, diff = Ix a + +Some rationale and observations + +* See Note [When the MR applies] in GHC.Tc.Gen.Bind. + +* We always want to quantify over psig_theta (if present). The user specified + it! And pickQuantifiableCandidates might have dropped some + e.g. CallStack constraints. c.f #14658 + equalities (a ~ Bool) + +* In case (P3) we ask that /all/ the signatures have an extra-constraints + wildcard. It's a bit arbitrary; not clear what the "right" thing is. + +* In (P2) we encounter #20076: + f :: Eq [a] => a -> _ + f x = [x] == [x] + From the RHS we get [W] Eq [a]. We simplify those Wanteds in simplifyInfer, + to get (Eq a). But then we quantify over the user-specified (Eq [a]), leaving + a residual implication constraint (forall a. Eq [a] => [W] Eq a), which is + insoluble. Idea: in simplifyInfer we could put the /un-simplified/ constraints + in the residual -- at least in the case like #20076 where the partial signature + fully specifies the final constraint. Maybe: a battle for another day. + +* It's helpful to use the same "find difference" algorithm, `findInferredDiff`, + here as we use in GHC.Tc.Gen.Bind.chooseInferredQuantifiers (#20921) + + At least for single functions we would like to quantify f over precisely the + same theta as , so that we get to take the short-cut path in + `GHC.Tc.Gen.Bind.mkExport`, and avoid calling `tcSubTypeSigma` for impedance + matching. Why avoid? Because it falls over for ambiguous types (#20921). + + We can get precisely the same theta by using the same algorithm, + `findInferredDiff`. + +* All of this goes wrong if we have (a) mutual recursion, (b) multiple + partial type signatures, (c) with different constraints, and (d) + ambiguous types. Something like + f :: forall a. Eq a => F a -> _ + f x = (undefined :: a) == g x undefined + g :: forall b. Show b => F b -> _ -> b + g x y = let _ = (f y, show x) in x + But that's a battle for another day. + +Note [Generalising top-level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class C a b | a -> b where .. + f x = ...[W] C Int beta[1]... + +When generalising `f`, closeWrtFunDeps will promote beta[1] to beta[0]. +But we do NOT want to make a top level type + f :: C Int beta[0] => blah +The danger is that beta[0] is defaulted to Any, and that then appears +in a user error message. Even if the type `blah` mentions beta[0], /and/ +there is a call that fixes beta[0] to (say) Bool, we'll end up with +[W] C Int Bool, which is insoluble. Why insoluble? If there was an + instance C Int Bool +then fundeps would have fixed beta:=Bool in the first place. + +If the binding of `f` is nested, things are different: we can +definitely see all the calls. + +For nested bindings, I think it just doesn't matter. No one cares what this +variable ends up being; it seems silly to halt compilation around it. (Like in +the length [] case.) +-} + +decideAndPromoteTyVars :: TopLevelFlag -> TcLevel + -> InferMode + -> [(Name,TcType)] + -> [TcIdSigInst] + -> WantedConstraints + -> TcM ([PredType], CoVarSet) +-- See Note [decideAndPromoteTyVars] +decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted + = do { dflags <- getDynFlags + + -- 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, psig_theta, tau_tys) <- getSeedTys name_taus psigs + + ; let is_top_level = isTopLevel top_lvl -- A syntactically top-level binding + + -- Step 1 of Note [decideAndPromoteTyVars] + -- Get candidate constraints, decide which we can potentially quantify + -- The `no_quant_tvs` are free in constraints we can't quantify. + (can_quant_cts, no_quant_tvs) = approximateWCX False wanted + can_quant = ctsPreds can_quant_cts + can_quant_tvs = tyCoVarsOfTypes can_quant + + -- Step 2 of Note [decideAndPromoteTyVars] + -- Apply the monomorphism restriction + (post_mr_quant, mr_no_quant) = applyMR dflags infer_mode can_quant + mr_no_quant_tvs = tyCoVarsOfTypes mr_no_quant + + -- The co_var_tvs are tvs mentioned in the types of covars or + -- coercion holes. We can't quantify over these covars, so we + -- must include the variable in their types in the mono_tvs. + -- E.g. If we can't quantify over co :: k~Type, then we can't + -- quantify over k either! Hence closeOverKinds + -- Recall that coVarsOfTypes also returns coercion holes + co_vars = coVarsOfTypes (mkTyVarTys psig_qtvs ++ psig_theta + ++ tau_tys ++ post_mr_quant) + co_var_tvs = closeOverKinds co_vars + + -- outer_tvs are mentioned in `wanted`, and belong to some outer level. + -- We definitely can't quantify over them + outer_tvs = outerLevelTyVars rhs_tclvl $ + can_quant_tvs `unionVarSet` no_quant_tvs + + -- Step 3 of Note [decideAndPromoteTyVars], (a-c) + -- Identify mono_tvs: the type variables that we must not quantify over + -- At top level we are much less keen to create mono tyvars, to avoid + -- spooky action at a distance. + mono_tvs_without_mr + | is_top_level = outer_tvs -- See (DP2) + | otherwise = outer_tvs -- (a) + `unionVarSet` no_quant_tvs -- (b) + `unionVarSet` co_var_tvs -- (c) + + -- Step 3 of Note [decideAndPromoteTyVars], (d) + mono_tvs_with_mr + = -- Even at top level, we don't quantify over type variables + -- mentioned in constraints that the MR tells us not to quantify + -- See Note [decideAndPromoteTyVars] (DP2) + mono_tvs_without_mr `unionVarSet` mr_no_quant_tvs + + -------------------------------------------------------------------- + -- Step 4 of Note [decideAndPromoteTyVars] + -- Use closeWrtFunDeps to find any other variables that are determined by mono_tvs + add_determined tvs preds = closeWrtFunDeps preds tvs + `delVarSetList` psig_qtvs + -- Why delVarSetList psig_qtvs? + -- If the user has explicitly asked for quantification, then that + -- request "wins" over the MR. + -- + -- What if a psig variable is also free in the environment + -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation + -- in Step 2 of Note [Deciding quantification]. + + mono_tvs_with_mr_det = add_determined mono_tvs_with_mr post_mr_quant + mono_tvs_without_mr_det = add_determined mono_tvs_without_mr can_quant + + -------------------------------------------------------------------- + -- Step 5 of Note [decideAndPromoteTyVars] + -- Do not quantify over any constraint mentioning a "newly-mono" tyvar. + newly_mono_tvs = mono_tvs_with_mr_det `minusVarSet` mono_tvs_with_mr + final_quant + | is_top_level = filterOut (predMentions newly_mono_tvs) post_mr_quant + | otherwise = post_mr_quant + + -------------------------------------------------------------------- + -- Check if the Monomorphism Restriction has bitten + ; warn_mr <- woptM Opt_WarnMonomorphism + ; when (warn_mr && case infer_mode of { ApplyMR -> True; _ -> False}) $ + diagnosticTc (not (mono_tvs_with_mr_det `subVarSet` mono_tvs_without_mr_det)) $ + TcRnMonomorphicBindings (map fst name_taus) + -- If there is a variable in mono_tvs, but not in mono_tvs_wo_mr + -- then the MR has "bitten" and reduced polymorphism. + + -------------------------------------------------------------------- + -- Step 6: Promote the mono_tvs: see Note [Promote monomorphic tyvars] + ; _ <- promoteTyVarSet mono_tvs_with_mr_det + + ; traceTc "decideAndPromoteTyVars" $ vcat + [ text "rhs_tclvl =" <+> ppr rhs_tclvl + , text "top =" <+> ppr is_top_level + , text "infer_mode =" <+> ppr infer_mode + , text "psigs =" <+> ppr psigs + , text "psig_qtvs =" <+> ppr psig_qtvs + , text "outer_tvs =" <+> ppr outer_tvs + , text "mono_tvs_with_mr =" <+> ppr mono_tvs_with_mr + , text "mono_tvs_without_mr =" <+> ppr mono_tvs_without_mr + , text "mono_tvs_with_mr_det =" <+> ppr mono_tvs_with_mr_det + , text "mono_tvs_without_mr_det =" <+> ppr mono_tvs_without_mr_det + , text "newly_mono_tvs =" <+> ppr newly_mono_tvs + , text "can_quant =" <+> ppr can_quant + , text "post_mr_quant =" <+> ppr post_mr_quant + , text "no_quant_tvs =" <+> ppr no_quant_tvs + , text "mr_no_quant =" <+> ppr mr_no_quant + , text "final_quant =" <+> ppr final_quant + , text "co_vars =" <+> ppr co_vars ] + + ; return (final_quant, co_vars) } + -- We return `co_vars` that appear free in the final quantified types + -- we can't quantify over these, and we must make sure they are in scope + +------------------- +applyMR :: DynFlags -> InferMode -> [PredType] + -> ( [PredType] -- Quantify over these + , [PredType] ) -- But not over these +-- Split the candidates into ones we definitely +-- won't quantify, and ones that we might +applyMR _ NoRestrictions cand = (cand, []) +applyMR _ ApplyMR cand = ([], cand) +applyMR dflags EagerDefaulting cand = partition not_int_ct cand + where + ovl_strings = xopt LangExt.OverloadedStrings dflags + + -- not_int_ct returns True for a constraint we /can/ quantify + -- For EagerDefaulting, do not quantify over + -- over any interactive class constraint + not_int_ct pred + = case classifyPredType pred of + ClassPred cls _ -> not (isInteractiveClass ovl_strings cls) + _ -> True + +------------------- +outerLevelTyVars :: TcLevel -> TcTyVarSet -> TcTyVarSet +-- Find just the tyvars that are bound outside rhs_tc_lvl +outerLevelTyVars rhs_tclvl tvs + = filterVarSet is_outer_tv tvs + where + is_outer_tv tcv + | isTcTyVar tcv -- Might be a CoVar; change this when gather covars separately + = rhs_tclvl `strictlyDeeperThan` tcTyVarLevel tcv + | otherwise + = False + +{- Note [decideAndPromoteTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are about to generalise a let-binding at "outer level" N, where we have +typechecked its RHS at "rhs level" N+1. Each tyvar must be either + (P) promoted + (D) defaulted + (Q) quantified +The function `decideAndPromoteTyVars` figures out (P), the type variables +mentioned in constraints should definitely not be quantified, and promotes them +to the outer level, namely N. + +The plan + +* Step 1. Use `approximateWCX` to extract, from the RHS `WantedConstraints`, + the PredTypes that we might quantify over; and also those that we can't. + Example: suppose the `wanted` is this: + (d1:Eq alpha, forall b. (F b ~ a) => (co:t1 ~ t2), (d:Show alpha)) + Then + can_quant = [Eq alpha, Show alpha] + no_quant = (t1 ~ t2) + We can't quantify over that (t1~t2) because of the enclosing equality (F b ~ a). + + We also choose never to quantify over some forms of equality constraints. + Both this and the "given-equality" thing are described in + Note [Quantifying over equality constraints] in GHC.Tc.Types.Constraint. + +* Step 2. Further trim can_quant using the Monomorphism Restriction, yielding the + further `mr_no_quant` predicates that we won't quantify over; plus `post_mr_quant`, + which we can in principle quantify. + +* Step 3. Identify the type variables we definitely won't quantify, because they are: + a) From an outer level <=N anyway + b) Mentioned in a constraint we /can't/ quantify. See Wrinkle (DP1). + c) Mentioned in the kind of a CoVar; we can't quantify over a CoVar, + so we must not quantify over a type variable free in its kind + d) Mentioned in a constraint that the MR says we should not quantify. + + There is a special case for top-level bindings: see Wrinkle (DP2). + +* Step 4. Close wrt functional dependencies and equalities.Example + Example + f x y = ... + where z = x 3 + The body of z tries to unify the type of x (call it alpha[1]) with + (beta[2] -> gamma[2]). This unification fails because alpha is untouchable, leaving + [W] alpha[1] ~ (beta[2] -> gamma[2]) + We don't want to quantify over beta or gamma because they are fixed by alpha, + which is monomorphic. Actual test case: typecheck/should_compile/tc213 + + Another example. Suppose we have + class C a b | a -> b + and a constraint ([W] C alpha beta), if we promote alpha we should promote beta. + + See also Note [growThetaTyVars vs closeWrtFunDeps] + +* Step 5. Further restrict the quantifiable constraints `post_mr_quant` to ones + that do not mention a "newly mono" tyvar. The "newly-mono" tyvars are the ones + not free in the envt, nor forced to be promoted by the MR; but are determined + (via fundeps) by them. Example: + class C a b | a -> b + [W] C Int beta[1], tau = beta[1]->Int + We promote beta[1] to beta[0] since it is determined by fundep, but we do not + want to generate f :: (C Int beta[0]) => beta[0] -> Int Rather, we generate + f :: beta[0] -> Int, but leave [W] C Int beta[0] in the residual constraints, + which will probably cause a type error + + See Note [Do not quantify over constraints that determine a variable] + +* Step 6: actually promote the type variables we don't want to quantify. + We must do this: see Note [Promote monomorphic tyvars]. + +We also add a warning that signals when the MR "bites". + +Wrinkles + +(DP1) In step 3, why (b)? Consider the example given in Step 1. we can't + quantify over the constraint (t1~t2). But if we quantify over the /tyvars/ in + t1 or t2, we may simply make that constraint insoluble (#25266 was an example). + +(DP2) In Step 3, for top-level bindings, we do (a,d), but /not/ (b,c). Reason: + see Note [The top-level Any principle]. At top level we are very reluctant to + promote type variables. But for bindings affected by the MR we have no choice + but to promote. + + An example is in #26004. + f w e = case e of + T1 -> let y = not w in False + T2 -> True + When generalising `f` we have a constraint + forall. (a ~ Bool) => alpha ~ Bool + where our provisional type for `f` is `f :: T alpha -> blah`. + In a /nested/ setting, we might simply not-generalise `f`, hoping to learn + about `alpha` from f's call sites (test T5266b is an example). But at top + level, to avoid spooky action at a distance. + +Note [The top-level Any principle] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Key principles: + * we never want to show the programmer a type with `Any` in it. + * avoid "spooky action at a distance" and silent defaulting + +Most /top level/ bindings have a type signature, so none of this arises. But +where a top-level binding lacks a signature, we don't want to infer a type like + f :: alpha[0] -> Int +and then subsequently default alpha[0]:=Any. Exposing `Any` to the user is bad +bad bad. Better to report an error, which is what may well happen if we +quantify over alpha instead. + +Moreover, + * If (elsewhere in this module) we add a call to `f`, say (f True), then + `f` will get the type `Bool -> Int` + * If we add /another/ call, say (f 'x'), we will then get a type error. + * If we have no calls, the final exported type of `f` may get set by + defaulting, and might not be principal (#26004). + +For /nested/ bindings, a monomorphic type like `f :: alpha[0] -> Int` is fine, +because we can see all the call sites of `f`, and they will probably fix +`alpha`. In contrast, we can't see all of (or perhaps any of) the calls of +top-level (exported) functions, reducing the worries about "spooky action at a +distance". This also moves in the direction of `MonoLocalBinds`, which we like. + +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[1] (Z [Char]) beta[1] +We definitely 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]`. Quantifying over it +would be "Henry Ford polymorphism". (Presumably we don't have an +instance in scope that tells us what `beta` actually is.) Instead +we promote `beta[1]` to `beta[0]`, in `decidePromotedTyVars`. + +The question here: do we want to quantify over the constraint, to +give the type + forall a. Zork a (Z [Char]) beta[0] => blah +Definitely not: see Note [The top-level Any principle] + +What we really want (to catch the Zork example) is this: + + Quantify over the constraint only if all its free variables are + (a) quantified, or + (b) appears in the type of something in the environment (mono_tvs0). + +To understand (b) consider + + class C a b where { op :: a -> b -> () } + + mr = 3 -- mr :: alpha + f1 x = op x mr -- f1 :: forall b. b -> (), plus [W] C b alpha + intify = mr + (4 :: Int) + +In `f1` should we quantify over that `(C b alpha)`? Answer: since `alpha` is +free in the type envt, yes we should. After all, if we'd typechecked `intify` +first, we'd have set `alpha := Int`, and /then/ we'd certainly quantify. The +delicate Zork situation applies when beta is completely unconstrained (not free +in the environment) -- except by the fundep. Hence `newly_mono`. + +Another way to put it: let's say `alpha` is in `outer_tvs`. It must be that +some variable `x` has `alpha` free in its type. If we are at top-level (and we +are, because nested decls don't go through this path all), then `x` must also +be at top-level. And, by induction, `x` will not have Any in its type when all +is said and done. The induction is well-founded because, if `x` is mutually +recursive with the definition at hand, then their constraints get processed +together (or `x` has a type signature, in which case the type doesn't have +`Any`). So the key thing is that we must not introduce a new top-level +unconstrained variable here. + +However this regrettably-subtle reasoning is needed only for /top-level/ +declarations. For /nested/ decls we can see all the calls, so we'll instantiate +that quantifed `Zork a (Z [Char]) beta` constraint at call sites, and either +solve it or not (probably not). We won't be left with a still-callable function +with Any in its type. So for nested definitions we don't make this tricky test. + +Historical note: we had a different, and more complicated test before, but it +was utterly wrong: #23199. + +Note [Promote monomorphic tyvars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Promote any type variables that are free in the environment. Eg + f :: forall qtvs. bound_theta => zonked_tau +The free vars of f's type become free in the envt, and hence will show +up whenever 'f' is called. They may currently at rhs_tclvl, but they +had better be unifiable at the outer_tclvl! Example: envt mentions +alpha[1] + tau_ty = beta[2] -> beta[2] + constraints = alpha ~ [beta] +we don't quantify over beta (since it is fixed by envt) +so we must promote it! The inferred type is just + f :: beta -> beta + +NB: promoteTyVarSet ignores coercion variables + +Note [Defaulting during simplifyInfer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are inferring a type, we simplify the constraint, and then use +approximateWC to produce a list of candidate constraints. Then we MUST + + a) Promote any meta-tyvars that have been floated out by + approximateWC, to restore invariant (WantedInv) described in + Note [TcLevel invariants] in GHC.Tc.Utils.TcType. + + b) Default the kind of any meta-tyvars that are not mentioned in + in the environment. + +To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we +have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it +should! If we don't solve the constraint, we'll stupidly quantify over +(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over +(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332. +#7641 is a simpler example. + +-} + +------------------- +defaultTyVarsAndSimplify :: TcLevel + -> [PredType] -- Assumed zonked + -> TcM [PredType] -- Guaranteed zonked +-- Default any tyvar free in the constraints; +-- and re-simplify in case the defaulting allows further simplification +-- See Note [Defaulting during simplifyInfer] +defaultTyVarsAndSimplify rhs_tclvl candidates + = do { -- Default any kind/levity vars + ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} + <- candidateQTyVarsOfTypes candidates + -- NB1: decidePromotedTyVars has promoted any type variable fixed by the + -- type envt, so they won't be chosen by candidateQTyVarsOfTypes + -- NB2: Defaulting for variables free in tau_tys is done later, by quantifyTyVars + -- Hence looking only at 'candidates' + -- NB3: Any covars should already be handled by + -- the logic in decidePromotedTyVars, which looks at + -- the constraints generated + + ; poly_kinds <- xoptM LangExt.PolyKinds + ; let default_kv | poly_kinds = default_tv + | otherwise = defaultTyVar DefaultKindVars + default_tv = defaultTyVar (NonStandardDefaulting DefaultNonStandardTyVars) + ; mapM_ default_kv (dVarSetElems cand_kvs) + ; mapM_ default_tv (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) + + ; simplify_cand candidates + } + where + -- See Note [Unconditionally resimplify constraints when quantifying] + simplify_cand [] = return [] -- Fast path + simplify_cand candidates + = do { clone_wanteds <- newWanteds DefaultOrigin candidates + ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $ + simplifyWantedsTcM clone_wanteds + -- Discard evidence; simples is fully zonked + + ; let new_candidates = ctsPreds simples + ; traceTc "Simplified after defaulting" $ + vcat [ text "Before:" <+> ppr candidates + , text "After:" <+> ppr new_candidates ] + ; return new_candidates } + +------------------ +decideQuantifiedTyVars + :: SkolemInfoAnon + -> [(Name,TcType)] -- Annotated theta and (name,tau) pairs + -> [TcIdSigInst] -- Partial signatures + -> [PredType] -- Candidates, zonked + -> TcM [TyVar] +-- Fix what tyvars we are going to quantify over, and quantify them +decideQuantifiedTyVars skol_info_anon name_taus psigs candidates + = do { -- Why psig_tys? We try to quantify over everything free in here + -- See Note [Quantification and partial signatures] + -- Wrinkles 2 and 3 + (psig_qtvs, psig_theta, tau_tys) <- getSeedTys name_taus psigs + + ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta + seed_tvs = tyCoVarsOfTypes (psig_tys ++ tau_tys) + + -- "Grow" those seeds to find ones reachable via 'candidates' + -- See Note [growThetaTyVars vs closeWrtFunDeps] + grown_tcvs = growThetaTyVars candidates seed_tvs + + -- Now we have to classify them into kind variables and type variables + -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars + -- + -- The psig_tys are first in seed_tys, then candidates, then tau_tvs. + -- This makes candidateQTyVarsOfTypes produces them in that order, so that the + -- final qtvs quantifies in the same- order as the partial signatures do (#13524) + ; dvs <- candidateQTyVarsOfTypes (psig_tys ++ candidates ++ tau_tys) + ; let dvs_plus = weedOutCandidates (`dVarSetIntersectVarSet` grown_tcvs) dvs + + ; traceTc "decideQuantifiedTyVars" (vcat + [ text "tau_tys =" <+> ppr tau_tys + , text "candidates =" <+> ppr candidates + , text "dvs =" <+> ppr dvs + , text "tau_tys =" <+> ppr tau_tys + , text "seed_tvs =" <+> ppr seed_tvs + , text "grown_tcvs =" <+> ppr grown_tcvs + , text "dvs =" <+> ppr dvs_plus]) + + ; skol_info <- mkSkolemInfo skol_info_anon + ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus } + +------------------ +getSeedTys :: [(Name,TcType)] -- The type of each RHS in the group + -> [TcIdSigInst] -- Any partial type signatures + -> TcM ( [TcTyVar] -- Zonked partial-sig quantified tyvars + , ThetaType -- Zonked partial signature thetas + , [TcType] ) -- Zonked tau-tys from the bindings +getSeedTys name_taus psigs + = TcM.liftZonkM $ + do { psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | TISI{ sig_inst_skols = skols } <- psigs + , (_, Bndr tv _) <- skols ] + ; psig_theta <- mapM TcM.zonkTcType [ pred | TISI{ sig_inst_theta = theta } <- psigs + , pred <- theta ] + ; tau_tys <- mapM (TcM.zonkTcType . snd) name_taus + ; return ( map getTyVar psig_tv_tys + , psig_theta + , tau_tys ) } + +------------------ +predMentions :: TcTyVarSet -> TcPredType -> Bool +predMentions qtvs pred = tyCoVarsOfType pred `intersectsVarSet` qtvs + +-- | When inferring types, should we quantify over a given predicate? +-- See Note [pickQuantifiablePreds] +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 + = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] + mapMaybe pick_me theta + where + pick_me pred + = case classifyPredType pred of + ClassPred cls _ + | isIPClass cls + -> Just pred -- Pick, say, (?x::Int) whether or not it mentions qtvs + -- See Note [Inheriting implicit parameters] + + EqPred eq_rel ty1 ty2 + | predMentions qtvs pred + , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 + -- boxEqPred: See Note [Lift equality constraints when quantifying] + -> Just (mkClassPred cls tys) + | otherwise + -> Nothing + + _ | predMentions qtvs pred -> Just pred + | otherwise -> Nothing + +------------------ +growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet +-- See Note [growThetaTyVars vs closeWrtFunDeps] +growThetaTyVars theta tcvs + | null theta = tcvs + | otherwise = transCloVarSet mk_next seed_tcvs + where + seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips + (ips, non_ips) = partition couldBeIPLike theta + -- See Note [Inheriting implicit parameters] + + mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones + mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips + grow_one so_far pred tcvs + | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs + | otherwise = tcvs + where + pred_tcvs = tyCoVarsOfType pred + + +{- Note [pickQuantifiablePreds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pickQuantifiablePreds is called we have decided what type +variables to quantify over, `qtvs`. The only quesion is: which of the +unsolved candidate predicates should we quantify over? Call them +`picked_theta`. + +Note that will leave behind a residual implication + forall qtvs. picked_theta => unsolved_constraints +For the members of unsolved_constraints that we select for picked_theta +it is easy to solve, by identity. For the others we just hope that +we can solve them. + +So which of the candidates should we pick to quantify over? It's pretty easy: + +* Never pick a constraint that doesn't mention any of the quantified + variables `qtvs`. Picking such a constraint essentially moves the solving of + the constraint from this function definition to call sites. But because the + constraint mentions no quantified variables, call sites have no advantage + over the definition site. Well, not quite: there could be new constraints + brought into scope by a pattern-match against a constrained (e.g. GADT) + constructor. Example + + data T a where { T1 :: T1 Bool; ... } + + f :: forall a. a -> T a -> blah + f x t = let g y = x&&y -- This needs a~Bool + in case t of + T1 -> g True + .... + + At g's call site we have `a~Bool`, so we /could/ infer + g :: forall . (a~Bool) => Bool -> Bool -- qtvs = {} + + This is all very contrived, and probably just postponse type errors to + the call site. If that's what you want, write a type signature. + +* Implicit parameters is an exception to the "no quantified vars" + rule (see Note [Inheriting implicit parameters]) so we can't actually + simply test this case first. + +* Finally, we may need to "box" equality predicates: if we want to quantify + over `a ~# b`, we actually quantify over the boxed version, `a ~ b`. + See Note [Lift equality constraints when quantifying]. + +Notice that we do /not/ consult -XFlexibleContexts here. For example, +we allow `pickQuantifiablePreds` to quantify over a constraint like +`Num [a]`; then if we don't have `-XFlexibleContexts` we'll get an +error from `checkValidType` but (critically) it includes the helpful +suggestion of adding `-XFlexibleContexts`. See #10608, #10351. + +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.Predicate + +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 [Quantification and partial signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When choosing type variables to quantify, the basic plan is to +quantify over all type variables that are + * free in the tau_tvs, and + * not forced to be monomorphic (mono_tvs), + for example by being free in the environment. + +However, in the case of a partial type signature, we are doing inference +*in the presence of a type signature*. For example: + f :: _ -> a + f x = ... +or + g :: (Eq _a) => _b -> _b +In both cases we use plan InferGen, and hence call simplifyInfer. But +those 'a' variables are skolems (actually TyVarTvs), and we should be +sure to quantify over them. This leads to several wrinkles: + +* Wrinkle 1. In the case of a type error + f :: _ -> Maybe a + f x = True && x + The inferred type of 'f' is f :: Bool -> Bool, but there's a + left-over error of form (Maybe a ~ Bool). The error-reporting + machine expects to find a binding site for the skolem 'a', so we + add it to the quantified tyvars. + +* Wrinkle 2. Consider the partial type signature + f :: (Eq _) => Int -> Int + f x = x + In normal cases that makes sense; e.g. + g :: Eq _a => _a -> _a + g x = x + where the signature makes the type less general than it could + be. But for 'f' we must therefore quantify over the user-annotated + constraints, to get + f :: forall a. Eq a => Int -> Int + (thereby correctly triggering an ambiguity error later). If we don't + we'll end up with a strange open type + f :: Eq alpha => Int -> Int + which isn't ambiguous but is still very wrong. + + Bottom line: Try to quantify over any variable free in psig_theta, + just like the tau-part of the type. + +* Wrinkle 3 (#13482). Also consider + f :: forall a. _ => Int -> Int + f x = if (undefined :: a) == undefined then x else 0 + Here we get an (Eq a) constraint, but it's not mentioned in the + psig_theta nor the type of 'f'. But we still want to quantify + over 'a' even if the monomorphism restriction is on. + +* Wrinkle 4 (#14479) + foo :: Num a => a -> a + foo xxx = g xxx + where + g :: forall b. Num b => _ -> b + g y = xxx + y + + In the signature for 'g', we cannot quantify over 'b' because it turns out to + get unified with 'a', which is free in g's environment. So we carefully + refrain from bogusly quantifying, in GHC.Tc.Solver.decidePromotedTyVars. We + report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. + +Note [growThetaTyVars vs closeWrtFunDeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with +the same type and similar behavior. This Note outlines the differences +and why we use one or the other. + +Both functions take a list of constraints. We will call these the +*candidates*. + +closeWrtFunDeps takes a set of "determined" type variables and finds the +closure of that set with respect to the functional dependencies +within the class constraints in the set of candidates. So, if we +have + + class C a b | a -> b + class D a b -- no fundep + candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)} + +then closeWrtFunDeps {a} will return the set {a,b,c}. +This is because, if `a` is determined, then `b` and `c` are, too, +by functional dependency. closeWrtFunDeps called with any seed set not including +`a` will just return its argument, as only `a` determines any other +type variable (in this example). + +growThetaTyVars operates similarly, but it behaves as if every +constraint has a functional dependency among all its arguments. +So, continuing our example, growThetaTyVars {a} will return +{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of +variables to include all variables that are mentioned in the same +constraint (transitively). + +We use closeWrtFunDeps in places where we need to know which variables are +*always* determined by some seed set. This includes + * when determining the mono-tyvars in decidePromotedTyVars. If `a` + is going to be monomorphic, we need b and c to be also: they + are determined by the choice for `a`. + * when checking instance coverage, in + GHC.Tc.Instance.FunDeps.checkInstCoverage + +On the other hand, we use growThetaTyVars where we need to know +which variables *might* be determined by some seed set. This includes + * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers + and decideQuantifiedTyVars +How can `a` determine (say) `d` in the example above without a fundep? +Suppose we have + instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c) +Now, if `a` turns out to be a list, it really does determine b and c. +The danger in overdoing quantification is the creation of an ambiguous +type signature, but this is conveniently caught in the validity checker. + +Note [Quantification with errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find that the RHS of the definition has some absolutely-insoluble +constraints (including especially "variable not in scope"), we + +* Abandon all attempts to find a context to quantify over, + and instead make the function fully-polymorphic in whatever + type we have found + +* Return a flag from simplifyInfer, indicating that we found an + insoluble constraint. This flag is used to suppress the ambiguity + check for the inferred type, which may well be bogus, and which + tends to obscure the real error. This fix feels a bit clunky, + but I failed to come up with anything better. + +Reasons: + - Avoid downstream errors + - Do not perform an ambiguity test on a bogus type, which might well + fail spuriously, thereby obfuscating the original insoluble error. + #14000 is an example + +I tried an alternative approach: simply failM, after emitting the +residual implication constraint; the exception will be caught in +GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type +(forall a. a). But that didn't work with -fdefer-type-errors, because +the recovery from failM emits no code at all, so there is no function +to run! But -fdefer-type-errors aspires to produce a runnable program. + +Note [Default while Inferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our current plan is that defaulting only happens at simplifyTop and +not simplifyInfer. This may lead to some insoluble deferred constraints. +Example: + +instance D g => C g Int b + +constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha +type inferred = gamma -> gamma + +Now, if we try to default (alpha := Int) we will be able to refine the implication to + (forall b. 0 => C gamma Int b) +which can then be simplified further to + (forall b. 0 => D gamma) +Finally, we /can/ approximate this implication with (D gamma) and infer the quantified +type: forall g. D g => g -> g + +Instead what will currently happen is that we will get a quantified type +(forall g. g -> g) and an implication: + forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha + +Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an +unsolvable implication: + forall g. 0 => (forall b. 0 => D g) + +The concrete example would be: + h :: C g a s => g -> a -> ST s a + f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1) + +But it is quite tedious to do defaulting and resolve the implication constraints, and +we have not observed code breaking because of the lack of defaulting in inference, so +we don't do it for now. + +Note [Minimize by Superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we quantify over a constraint, in simplifyInfer we need to +quantify over a constraint that is minimal in some sense: For +instance, if the final wanted constraint is (Eq alpha, Ord alpha), +we'd like to quantify over Ord alpha, because we can just get Eq alpha +from superclass selection from Ord alpha. This minimization is what +mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint +to check the original wanted. + + +Note [Avoid unnecessary constraint simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -------- NB NB NB (Jun 12) ------------- + This note not longer applies; see the notes with #4361. + But I'm leaving it in here so we remember the issue.) + ---------------------------------------- +When inferring the type of a let-binding, with simplifyInfer, +try to avoid unnecessarily simplifying class constraints. +Doing so aids sharing, but it also helps with delicate +situations like + + instance C t => C [t] where .. + + f :: C [t] => .... + f x = let g y = ...(constraint C [t])... + in ... +When inferring a type for 'g', we don't want to apply the +instance decl, because then we can't satisfy (C t). So we +just notice that g isn't quantified over 't' and partition +the constraints before simplifying. + +This only half-works, but then let-generalisation only half-works. + +Note [DefaultTyVar] +~~~~~~~~~~~~~~~~~~~ +defaultTyVar is used on any un-instantiated meta type variables to +default any RuntimeRep variables to LiftedRep. This is important +to ensure that instance declarations match. For example consider + + instance Show (a->b) + foo x = show (\_ -> True) + +Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r), +and that won't match the typeKind (*) in the instance decl. See tests +tc217 and tc175. + +We look only at touchable type variables. No further constraints +are going to affect these type variables, so it's time to do it by +hand. However we aren't ready to default them fully to () or +whatever, because the type-class defaulting rules have yet to run. + +An alternate implementation would be to emit a Wanted constraint setting +the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. +-} diff --git a/GHC/Tc/Solver/Default.hs b/GHC/Tc/Solver/Default.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Default.hs @@ -0,0 +1,1263 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Tc.Solver.Default( + tryDefaulting, tryDefaultingForAmbiguityCheck, + isInteractiveClass, isNumClass + ) where + +import GHC.Prelude + +import GHC.Tc.Errors +import GHC.Tc.Errors.Types +import GHC.Tc.Types.Evidence +import GHC.Tc.Solver.Solve ( solveSimpleWanteds, setImplicationStatus ) +import GHC.Tc.Solver.Dict ( solveCallStack ) +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.TcMType as TcM +import GHC.Tc.Utils.Monad as TcM +import GHC.Tc.Zonk.TcType as TcM +import GHC.Tc.Solver.Solve( solveWanteds ) +import GHC.Tc.Solver.Monad as TcS +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( mkGivenLoc ) +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType + +import GHC.Core.Class +import GHC.Core.Reduction( Reduction, reductionCoercion ) +import GHC.Core +import GHC.Core.DataCon +import GHC.Core.Make +import GHC.Core.Coercion( isReflCo, mkReflCo, mkSubCo, hasCoercionHole ) +import GHC.Core.Unify ( tcMatchTyKis ) +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.TyCo.Tidy + +import GHC.Types.DefaultEnv ( ClassDefaults (..), defaultList ) +import GHC.Types.Unique.Set +import GHC.Types.Id + +import GHC.Builtin.Utils +import GHC.Builtin.Names +import GHC.Builtin.Types + +import GHC.Types.TyThing ( MonadThings(lookupId) ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Id.Make ( unboxedUnitExpr ) + +import GHC.Driver.DynFlags +import GHC.Unit.Module ( getModule ) + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable + +import GHC.Data.FastString +import GHC.Data.List.SetOps +import GHC.Data.Bag + +import Control.Monad +import Control.Monad.Trans.Class ( lift ) +import Control.Monad.Trans.State.Strict ( StateT(runStateT), put ) +import Data.Foldable ( toList, traverse_ ) +import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) +import qualified Data.List.NonEmpty as NE +import GHC.Data.Maybe ( isJust, mapMaybe, catMaybes ) +import Data.Monoid ( First(..) ) + + +{- Note [Top-level Defaulting Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have considered two design choices for where/when to apply defaulting. + (i) Do it in SimplCheck mode only /whenever/ you try to solve some + simple constraints, maybe deep inside the context of implications. + This used to be the case in GHC 7.4.1. + (ii) Do it in a tight loop at simplifyTop, once all other constraints have + finished. This is the current story. + +Option (i) had many disadvantages: + a) Firstly, it was deep inside the actual solver. + b) Secondly, it was dependent on the context (Infer a type signature, + or Check a type signature, or Interactive) since we did not want + to always start defaulting when inferring (though there is an exception to + this, see Note [Default while Inferring]). + c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs: + f :: Int -> Bool + f x = const True (\y -> let w :: a -> a + w a = const a (y+1) + in w y) + We will get an implication constraint (for beta the type of y): + [untch=beta] forall a. 0 => Num beta + which we really cannot default /while solving/ the implication, since beta is + untouchable. + +Instead our new defaulting story is to pull defaulting out of the solver loop and +go with option (ii), implemented at SimplifyTop. Namely: + - First, have a go at solving the residual constraint of the whole + program + - Try to approximate it with a simple constraint + - Figure out derived defaulting equations for that simple constraint + - Go round the loop again if you did manage to get some equations + +Now, that has to do with class defaulting. However there exists type variable /kind/ +defaulting. Again this is done at the top-level and the plan is: + - At the top-level, once you had a go at solving the constraint, do + figure out /all/ the touchable unification variables of the wanted constraints. + - Apply defaulting to their kinds + +More details in Note [DefaultTyVar]. + +Note [Limited defaulting in the ambiguity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying constraints for the ambiguity check, we don't want full +defaulting. E.g. #11947 was an example: + f :: Num a => Int -> Int +This is ambiguous of course, but we don't want to default the (Num +alpha) constraint to (Num Int)! Doing so gives a defaulting warning, +but no error. + +But we still do + +* tryConstraintDefaulting. Example in T10009 where we have this type signature + f :: (UnF (F b) ~ b) => F b -> () + We finish up with an equality that is a member of it's + [W] hole{co_aF0} {rewriters: {co_aF0}}:: b_aES[tau:1] ~# b_aEP[sk:1] + It is not unified because of (REWRITERS) in Note [Unification preconditions] + in GHC.Tc.Utils.Unify + + (`tryConstraintDefaulting` defaults call-stack and exception constraint + as well as equalities; but in the case of the ambiguity check we will + only see equality constraints. Does not seem worth making a version + of `tryConstraintDefaulting` that looks only for equalities.) + +* tryUnsatisfiableGivens: see Wrinkle [Ambiguity] under point (C) of + Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors. +-} + + +tryDefaulting :: WantedConstraints -> TcS WantedConstraints +-- This is the function that pulls all the defaulting strategies together +tryDefaulting wc + = do { dflags <- getDynFlags + ; traceTcS "tryDefaulting {" (ppr wc) + ; wc1 <- tryTyVarDefaulting dflags wc + ; wc2 <- tryConstraintDefaulting wc1 + ; wc3 <- tryTypeClassDefaulting wc2 + ; wc4 <- tryUnsatisfiableGivens wc3 + ; traceTcS "tryDefaulting }" (ppr wc4) + ; return wc4 } + +tryDefaultingForAmbiguityCheck :: WantedConstraints -> TcS WantedConstraints +-- See Note [Limited defaulting in the ambiguity check] +tryDefaultingForAmbiguityCheck wc + = do { traceTcS "tryDefaulting for ambiguity {" (ppr wc) + ; wc1 <- tryConstraintDefaulting wc + ; wc2 <- tryUnsatisfiableGivens wc1 + ; traceTcS "tryDefaulting }" (ppr wc2) + ; return wc2 } + +solveAgainIf :: Bool -> WantedConstraints -> TcS WantedConstraints +-- If the Bool is true, solve the wanted constraints again +-- See Note [Must simplify after defaulting] +solveAgainIf False wc = return wc +solveAgainIf True wc = nestTcS (solveWanteds wc) + + +{- ****************************************************************************** +* * + tryTyVarDefaulting +* * +****************************************************************************** -} + +tryTyVarDefaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints +tryTyVarDefaulting dflags wc + | isEmptyWC wc + = return wc + | insolubleWC wc + , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles] + = return wc + | otherwise + = do { -- Need to zonk first, as the WantedConstraints are not yet zonked. + ; free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc) + ; let defaultable_tvs = filter can_default free_tvs + can_default tv + = isTyVar tv + -- Weed out coercion variables. + + && isMetaTyVar tv + -- Weed out runtime-skolems in GHCi, which we definitely + -- shouldn't try to default. + + && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc) + -- Weed out variables for which defaulting would be unhelpful, + -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk]. + + ; unification_s <- mapM defaultTyVarTcS defaultable_tvs -- Has unification side effects + ; solveAgainIf (or unification_s) wc } + -- solveAgainIf: see Note [Must simplify after defaulting] + +type UnificationDone = Bool + +noUnification, didUnification :: UnificationDone +noUnification = False +didUnification = True + +-- | Like 'defaultTyVar', but in the TcS monad. +defaultTyVarTcS :: TcTyVar -> TcS UnificationDone +defaultTyVarTcS the_tv + | isTyVarTyVar the_tv + -- TyVarTvs should only be unified with a tyvar + -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar + -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + = return noUnification + | isRuntimeRepVar the_tv + = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) + ; unifyTyVar the_tv liftedRepTy + ; return didUnification } + | isLevityVar the_tv + = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv) + ; unifyTyVar the_tv liftedDataConTy + ; return didUnification } + | isMultiplicityVar the_tv + = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv) + ; unifyTyVar the_tv ManyTy + ; return didUnification } + | otherwise + = return noUnification -- the common case + + +{- ****************************************************************************** +* * + tryUnsatisfiableGivens +* * +****************************************************************************** -} + +-- | If an implication contains a Given of the form @Unsatisfiable msg@, +-- use it to solve all Wanteds within the implication. +-- See point (C) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors. +-- +-- This does a complete walk over the implication tree. +tryUnsatisfiableGivens :: WantedConstraints -> TcS WantedConstraints +tryUnsatisfiableGivens wc = + do { (final_wc, did_work) <- (`runStateT` False) $ go_wc wc + ; solveAgainIf did_work final_wc } + where + go_wc (WC { wc_simple = wtds, wc_impl = impls, wc_errors = errs }) + = do impls' <- mapBagM go_impl impls + return $ WC { wc_simple = wtds, wc_impl = impls', wc_errors = errs } + go_impl impl + | isSolvedStatus (ic_status impl) + = return impl + -- Is there a Given with type "Unsatisfiable msg"? + -- If so, use it to solve all other Wanteds. + | unsat_given:_ <- mapMaybe unsatisfiableEv_maybe (ic_given impl) + = do { put True + ; lift $ solveImplicationUsingUnsatGiven unsat_given impl } + -- Otherwise, recurse. + | otherwise + = do { wcs' <- go_wc (ic_wanted impl) + ; lift $ setImplicationStatus $ impl { ic_wanted = wcs' } } + +-- | Is this evidence variable the evidence for an 'Unsatisfiable' constraint? +-- +-- If so, return the variable itself together with the error message type. +unsatisfiableEv_maybe :: EvVar -> Maybe (EvVar, Type) +unsatisfiableEv_maybe v = (v,) <$> isUnsatisfiableCt_maybe (idType v) + +-- | We have an implication with an 'Unsatisfiable' Given; use that Given to +-- solve all the other Wanted constraints, including those nested within +-- deeper implications. +solveImplicationUsingUnsatGiven :: (EvVar, Type) -> Implication -> TcS Implication +solveImplicationUsingUnsatGiven + unsat_given@(given_ev,_) + impl@(Implic { ic_wanted = wtd, ic_tclvl = tclvl, ic_binds = ev_binds_var + , ic_need_implic = inner }) + | isCoEvBindsVar ev_binds_var + -- We can't use Unsatisfiable evidence in kinds. + -- See Note [Coercion evidence only] in GHC.Tc.Types.Evidence. + = return impl + | otherwise + = do { wcs <- nestImplicTcS ev_binds_var tclvl $ go_wc wtd + ; setImplicationStatus $ + impl { ic_wanted = wcs + , ic_need_implic = inner `extendEvNeedSet` given_ev } } + -- Record that the Given is needed; I'm not certain why + where + go_wc :: WantedConstraints -> TcS WantedConstraints + go_wc wc@(WC { wc_simple = wtds, wc_impl = impls }) + = do { mapBagM_ go_simple wtds + ; impls <- mapBagM (solveImplicationUsingUnsatGiven unsat_given) impls + ; return $ wc { wc_simple = emptyBag, wc_impl = impls } } + go_simple :: Ct -> TcS () + go_simple ct = case ctEvidence ct of + CtWanted (WantedCt { ctev_pred = pty, ctev_dest = dest }) + -> do { ev_expr <- unsatisfiableEvExpr unsat_given pty + ; setWantedEvTerm dest EvNonCanonical $ EvExpr ev_expr } + _ -> return () + +-- | Create an evidence expression for an arbitrary constraint using +-- evidence for an "Unsatisfiable" Given. +-- +-- See Note [Evidence terms from Unsatisfiable Givens] +unsatisfiableEvExpr :: (EvVar, ErrorMsgType) -> PredType -> TcS EvExpr +unsatisfiableEvExpr (unsat_ev, given_msg) wtd_ty + = do { mod <- getModule + -- If we're typechecking GHC.TypeError, return a bogus expression; + -- it's only used for the ambiguity check, which throws the evidence away anyway. + -- This avoids problems with circularity; where we are trying to look + -- up the "unsatisfiable" Id while we are in the middle of typechecking it. + ; if mod == gHC_INTERNAL_TYPEERROR then return (Var unsat_ev) else + do { unsatisfiable_id <- tcLookupId unsatisfiableIdName + + -- See Note [Evidence terms from Unsatisfiable Givens] + -- for a description of what evidence term we are constructing here. + + ; let -- (##) -=> wtd_ty + fun_ty = mkFunTy visArgConstraintLike ManyTy unboxedUnitTy wtd_ty + mkDictBox = case boxingDataCon fun_ty of + BI_Box { bi_data_con = mkDictBox } -> mkDictBox + _ -> pprPanic "unsatisfiableEvExpr: no DictBox!" (ppr wtd_ty) + dictBox = dataConTyCon mkDictBox + ; ev_bndr <- mkSysLocalM (fsLit "ct") ManyTy fun_ty + -- Dict ((##) -=> wtd_ty) + ; let scrut_ty = mkTyConApp dictBox [fun_ty] + -- unsatisfiable @{LiftedRep} @given_msg @(Dict ((##) -=> wtd_ty)) unsat_ev + scrut = + mkCoreApps (Var unsatisfiable_id) + [ Type liftedRepTy + , Type given_msg + , Type scrut_ty + , Var unsat_ev ] + -- case scrut of { MkDictBox @((##) -=> wtd_ty)) ct -> ct (# #) } + ev_expr = + mkWildCase scrut (unrestricted $ scrut_ty) wtd_ty + [ Alt (DataAlt mkDictBox) [ev_bndr] $ + mkCoreApps (Var ev_bndr) [unboxedUnitExpr] + ] + ; return ev_expr } } + +{- Note [Evidence terms from Unsatisfiable Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An Unsatisfiable Given constraint, of the form [G] Unsatisfiable msg, should be +able to solve ANY Wanted constraint whatsoever. + +Recall that we have + + unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep) + . Unsatisfiable msg => a + +We want to use this function, together with the evidence +[G] unsat_ev :: Unsatisfiable msg, to solve any other constraint [W] wtd_ty. + +We could naively think that a valid evidence term for the Wanted might be: + + wanted_ev = unsatisfiable @{rep} @msg @wtd_ty unsat_ev + +Unfortunately, this is a kind error: "wtd_ty :: CONSTRAINT rep", but +"unsatisfiable" expects the third type argument to be of kind "TYPE rep". + +Instead, we use a boxing data constructor to box the constraint into a type. +In the end, we construct the following evidence for the implication: + + [G] unsat_ev :: Unsatisfiable msg + ==> + [W] wtd_ev :: wtd_ty + + wtd_ev = + case unsatisfiable @{LiftedRep} @msg @(Dict ((##) -=> wtd_ty)) unsat_ev of + MkDictBox ct -> ct (# #) + +Note that we play the same trick with the function arrow -=> that we did +in order to define "unsatisfiable" in terms of "unsatisfiableLifted", as described +in Note [The Unsatisfiable representation-polymorphism trick] in base:GHC.TypeError. +This allows us to indirectly box constraints with different representations +(such as primitive equality constraints). +-} + + +{- ****************************************************************************** +* * + tryConstraintDefaulting +* * +****************************************************************************** -} + +-- | A 'TcS' action which can may solve a `Ct` +type CtDefaultingStrategy = Ct -> TcS Bool + -- True <=> I solved the constraint + +tryConstraintDefaulting :: WantedConstraints -> TcS WantedConstraints +-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +tryConstraintDefaulting wc + | isEmptyWC wc + = return wc + | otherwise + = do { (n_unifs, better_wc) <- reportUnifications (go_wc wc) + -- We may have done unifications; so solve again + ; solveAgainIf (n_unifs > 0) better_wc } + where + go_wc :: WantedConstraints -> TcS WantedConstraints + go_wc wc@(WC { wc_simple = simples, wc_impl = implics }) + = do { simples' <- mapMaybeBagM go_simple simples + ; implics' <- mapBagM go_implic implics + ; return (wc { wc_simple = simples', wc_impl = implics' }) } + + go_simple :: Ct -> TcS (Maybe Ct) + go_simple ct = do { solved <- tryCtDefaultingStrategy ct + ; if solved then return Nothing + else return (Just ct) } + + go_implic :: Implication -> TcS Implication + -- The Maybe is because solving the CallStack constraint + -- may well allow us to discard the implication entirely + go_implic implic + | isSolvedStatus (ic_status implic) + = return implic -- Nothing to solve inside here + | otherwise + = do { wanteds <- setEvBindsTcS (ic_binds implic) $ + -- defaultCallStack sets a binding, so + -- we must set the correct binding group + go_wc (ic_wanted implic) + ; setImplicationStatus (implic { ic_wanted = wanteds }) } + +tryCtDefaultingStrategy :: CtDefaultingStrategy +-- The composition of all the CtDefaultingStrategies we want +tryCtDefaultingStrategy + = foldr1 combineStrategies + ( defaultCallStack :| + defaultExceptionContext : + defaultEquality : + [] ) + +-- | Default @ExceptionContext@ constraints to @emptyExceptionContext@. +defaultExceptionContext :: CtDefaultingStrategy +defaultExceptionContext ct + | ClassPred cls tys <- classifyPredType (ctPred ct) + , isJust (isExceptionContextPred cls tys) + = do { warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct) + ; empty_ec_id <- lookupId emptyExceptionContextName + ; let ev = ctEvidence ct + ev_tm = EvExpr (evWrapIPE (ctEvPred ev) (Var empty_ec_id)) + ; setEvBindIfWanted ev EvCanonical ev_tm + -- EvCanonical: see Note [CallStack and ExceptionContext hack] + -- in GHC.Tc.Solver.Dict + ; return True } + | otherwise + = return False + +-- | Default any remaining @CallStack@ constraints to empty @CallStack@s. +-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +defaultCallStack :: CtDefaultingStrategy +defaultCallStack ct + | ClassPred cls tys <- classifyPredType (ctPred ct) + , isJust (isCallStackPred cls tys) + = do { solveCallStack (ctEvidence ct) EvCsEmpty + ; return True } + | otherwise + = return False + +defaultEquality :: CtDefaultingStrategy +-- See Note [Defaulting equalities] +defaultEquality ct + | EqPred eq_rel ty1 ty2 <- classifyPredType (ctPred ct) + = do { -- Remember: `ct` may not be zonked; + -- see (DE3) in Note [Defaulting equalities] + z_ty1 <- TcS.zonkTcType ty1 + ; z_ty2 <- TcS.zonkTcType ty2 + ; case eq_rel of + { NomEq -> + -- Now see if either LHS or RHS is a bare type variable + -- You might think the type variable will only be on the LHS + -- but with a type function we might get F t1 ~ alpha + case (getTyVar_maybe z_ty1, getTyVar_maybe z_ty2) of + (Just z_tv1, _) -> try_default_tv z_tv1 z_ty2 + (_, Just z_tv2) -> try_default_tv z_tv2 z_ty1 + _ -> return False ; + + ; ReprEq + -- See Note [Defaulting representational equalities] + | CIrredCan (IrredCt { ir_reason }) <- ct + , isInsolubleReason ir_reason + -- Don't do this for definitely insoluble representational + -- equalities such as Int ~R# Bool. + -> return False + | otherwise + -> + do { traceTcS "defaultEquality ReprEq {" $ vcat + [ text "ct:" <+> ppr ct + , text "z_ty1:" <+> ppr z_ty1 + , text "z_ty2:" <+> ppr z_ty2 + ] + -- Promote this representational equality to a nominal equality. + -- + -- This handles cases such as @IO alpha[tau] ~R# IO Int@ + -- by defaulting @alpha := Int@, which is useful in practice + -- (see Note [Defaulting representational equalities]). + ; (co, new_eqs, _unifs) <- + wrapUnifierX (ctEvidence ct) Nominal $ + -- NB: nominal equality! + \ uenv -> uType uenv z_ty1 z_ty2 + -- Only accept this solution if no new equalities are produced + -- by the unifier. + -- + -- See Note [Defaulting representational equalities]. + ; if null new_eqs + then do { setEvBindIfWanted (ctEvidence ct) EvCanonical $ + (evCoercion $ mkSubCo co) + ; return True } + else return False + } } } + | otherwise + = return False + + where + try_default_tv lhs_tv rhs_ty + | MetaTv { mtv_info = info } <- tcTyVarDetails lhs_tv + , tyVarKind lhs_tv `tcEqType` typeKind rhs_ty + , checkTopShape info rhs_ty + , not (hasCoercionHole rhs_ty) -- See (DE6) in Note [Defaulting equalities] + -- Do not test for touchability of lhs_tv; that is the whole point! + -- See (DE2) in Note [Defaulting equalities] + = do { traceTcS "defaultEquality 1" (ppr lhs_tv $$ ppr rhs_ty) + + -- checkTyEqRhs: check that we can in fact unify lhs_tv := rhs_ty + -- See Note [Defaulting equalities] + ; let flags :: TyEqFlags TcM () + flags = defaulting_TEFTask lhs_tv + + ; res :: PuResult () Reduction <- wrapTcS (checkTyEqRhs flags rhs_ty) + + ; case res of + PuFail {} -> cant_default_tv "checkTyEqRhs" + PuOK _ redn -> assertPpr (isReflCo (reductionCoercion redn)) (ppr redn) $ + -- With TEFA_Recurse we never get any reductions + default_tv } + | otherwise + = cant_default_tv "fall through" + + where + cant_default_tv msg + = do { traceTcS ("defaultEquality fails: " ++ msg) $ + vcat [ ppr lhs_tv <+> char '~' <+> ppr rhs_ty + , ppr (tyVarKind lhs_tv) + , ppr (typeKind rhs_ty) ] + ; return False } + + -- All tests passed: do the unification + default_tv + = do { traceTcS "defaultEquality success:" (ppr rhs_ty) + ; unifyTyVar lhs_tv rhs_ty -- NB: unifyTyVar adds to the + -- TcS unification counter + ; setEvBindIfWanted (ctEvidence ct) EvCanonical $ + evCoercion (mkReflCo Nominal rhs_ty) + ; return True + } + + +combineStrategies :: CtDefaultingStrategy -> CtDefaultingStrategy -> CtDefaultingStrategy +combineStrategies default1 default2 ct + = do { solved <- default1 ct + ; case solved of + True -> return True -- default1 solved it! + False -> default2 ct -- default1 failed, try default2 + } + + +{- Note [When to do type-class defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC +was false, on the grounds that defaulting can't help solve insoluble +constraints. But if we *don't* do defaulting we may report a whole +lot of errors that would be solved by defaulting; these errors are +quite spurious because fixing the single insoluble error means that +defaulting happens again, which makes all the other errors go away. +This is jolly confusing: #9033. + +So it seems better to always do type-class defaulting. + +However, always doing defaulting does mean that we'll do it in +situations like this (#5934): + run :: (forall s. GenST s) -> Int + run = fromInteger 0 +We don't unify the return type of fromInteger with the given function +type, because the latter involves foralls. So we're left with + (Num alpha, alpha ~ (forall s. GenST s) -> Int) +Now we do defaulting, get alpha := Integer, and report that we can't +match Integer with (forall s. GenST s) -> Int. That's not totally +stupid, but perhaps a little strange. + +Another potential alternative would be to suppress *all* non-insoluble +errors if there are *any* insoluble errors, anywhere, but that seems +too drastic. + +Note [Defaulting equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In top-level defaulting (as per Note [Top-level Defaulting Plan]), it makes +sense to try to default equality constraints, in addition to e.g. typeclass +defaulting: this doesn't threaten principal types (see DE1 below), but +allows GHC to accept strictly more programs. + +This Note explains defaulting nominal equalities; see also +Note [Defaulting representational equalities] which describes +the defaulting of representational equalities. + +Consider + + f :: forall a. (forall t. (F t ~ Int) => a -> Int) -> Int + + g :: Int + g = f id + +We'll typecheck + + id :: forall t. (F t ~ Int) => alpha[1] -> Int + +where the `alpha[1]` comes from instantiating `f`. So we'll end up +with the implication constraint + + forall[2] t. (F t ~ Int) => alpha[1] ~ Int + +and that can't be solved because `alpha` is untouchable under the +equality (F t ~ Int). + +This is tiresome, and gave rise to user complaints: #25125 and #25029. +Moreover, in this case there is no good reason not to unify alpha:=Int. +Doing so solves the constraint, and since `alpha` is not otherwise +constrained, it does no harm. + +In conclusion, for a Wanted equality constraint [W] lhs ~ rhs, if the only +reason for not unifying is that either lhs or rhs is an untouchable metavariable +then, in top-level defaulting, go ahead and unify. + +In top-level defaulting, we already do several other somewhat-ad-hoc, +but terribly convenient, unifications. This is just one more. + +Wrinkles: + +(DE1) Note carefully that this does not threaten principal types. + The original worry about unifying untouchable type variables was this: + + data T a where + T1 :: T Bool + f x = case x of T1 -> True + + Should we infer f :: T a -> Bool, or f :: T a -> a. Both are valid, but + neither is more general than the other. + +(DE2) We still can't unify if there is a skolem-escape check, or an occurs check, + or it it'd mean unifying a TyVarTv with a non-tyvar. It's only the + "untouchability test" that we lift. + +(DE3) The contraint we are looking at may not be fully zonked; for example, + an earlier defaulting might have affected it. So we zonk-on-the fly in + `defaultEquality`. + +(DE4) Promotion. Suppose we see alpha[2] := Maybe beta[4]. We want to promote + beta[4] to level 2 and unify alpha[2] := Maybe beta'[2]. This is done by + checkTyEqRhs called in defaultEquality. + +(DE5) Promotion. Suppose we see alpha[2] := F beta[4], where F is a type + family. Then we still want to promote beta to beta'[2], and unify. This is + unusual: more commonly, we don't promote unification variables under a + type family. But here we want to. (This mattered in #25251.) + + Hence the Bool flag on LC_Promote, and its use in `tef_unifying` in + `defaultEquality`. + +(DE6) /Don't/ unify if the RHS has a free coercion hole in it. That means + that there is an as-yet-unsolved equality constraint (whose evidence + will fill that hole); unifying can lead to very confusing type errors. + e.g. [W] co1 :: IntRep ~ LiftedRep + [W] co2 {rewritten by co1} :: alpha ~ t2 |> (TYPE co1) + Unifying alpha := (t1 |> TYPE co1) is a Bad Idea. + + Note that we /do/ unify even if the constraint has a non-empty rewriter + set, which has prevented unification up to now; see + Note [Unify only if the rewriter set is empty] in GHC.Tc.Solver.Equality. + In obscure situations a constraint can end up in its own rewriter set, but + without a coercion hole being in the RHS. + + See #10009, and Note [Limited defaulting in the ambiguity check]. + + +Note [Must simplify after defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may have a deeply buried constraint + (t:*) ~ (a:Open) +which we couldn't solve because of the kind incompatibility, and 'a' is free. +Then when we default 'a' we can solve the constraint. And we want to do +that before starting in on type classes. We MUST do it before reporting +errors, because it isn't an error! #7967 was due to this. + +Note [Defaulting representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we end up with [W] alpha ~#R Int, with no other constraints on alpha. +Then it makes sense to simply unify alpha := Int -- the alternative is to +reject the program due to an ambiguous metavariable alpha, so it makes sense +to unify and accept instead. + +This is particularly convenient for users of `coerce`, as it lessens the +amount of type annotations required (see #21003). Consider for example: + + -- 'foldMap' defined using 'traverse' + foldMapUsingTraverse :: forall t m a. (Traversable t, Monoid m) => (a -> m) -> t a -> m + foldMapUsingTraverse = coerce $ traverse @t @(Const m) + + -- 'traverse_' defined using 'foldMap' + traverse_UsingFoldMap :: forall f t a. (Foldable t, Applicative f) => (a -> f ()) -> t a -> f () + traverse_UsingFoldMap = coerce $ foldMap @t @(Ap f ()) + +Typechecking these functions results in unsolved Wanted constraints of the form +[W] alpha[tau] ~R# some_ty; accepting such programs by unifying +alpha := some_ty avoids the need for users to specify tiresome additional +type annotations, such as: + + foldMapUsingTraverse = coerce $ traverse @t @(Const m) @a + traverse_UsingFoldMap = coerce $ foldMap @t @(Ap f ()) @a + +Consider also the following example: + + -- 'sequence_', but for two nested 'Foldable' structures + sequenceNested_ :: forall f1 f2. (Foldable f1, Foldable f2) => f1 (f2 (IO ())) -> IO () + sequenceNested_ = coerce $ sequence_ @( Compose f1 f2 ) + +Here, we end up with [W] mu[tau] beta[tau] ~#R IO (), and it similarly makes +sense to default mu := IO, beta := (). This avoids requiring the +user to provide additional type applications: + + sequenceNested_ = coerce $ sequence_ @( Compose f1 f2 ) @IO @() + +The plan for defaulting a representational equality, say [W] ty1 ~R# ty2, +is thus as follows: + + 1. attempt to unify ty1 ~# ty2 (at nominal role) + 2. a. if this succeeds without deferring any constraints, accept this solution + b. otherwise, keep the original constraint. + +(2b) ensures that we don't degrade all error messages by always turning unsolved +representational equalities into nominal ones; we only want to default a +representational equality when we can fully solve it. + +Note that this does not threaten principle types. Recall that the original worry +(as per Note [Do not unify representational equalities]) was that we might have + + [W] alpha ~R# Int + [W] alpha ~ Age + +in which case unifying alpha := Int would be wrong, as the correct solution is +alpha := Age. This worry doesn't concern us in top-level defaulting, because +defaulting takes place after generalisation; it is fully monomorphic. + +********************************************************************************* +* * +* Type-class defaulting +* * +********************************************************************************* + +Note [How type-class constraints are defaulted] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type-class defaulting deals with the situation where we have unsolved +constraints like (Num alpha), where `alpha` is a unification variable. We want +to pick a default for `alpha`, such as `alpha := Int` to resolve the ambiguity. + +The function 'tryTypeClassDefaulting' implements type-class defaulting. The +algorithm for defaulting depends on whether certain extensions are enabled, +such as -XOverloadedStrings or -XExtendedDefaultRules. To explain this, let us +define the following: + + Unary typeclass: + a typeclass with a single visible type argument. + + Examples: + + Num :: Type -> Constraint + Eq :: Type -> Constraint + Foldable :: (Type -> Type) -> Constraint + Typeable :: forall k. k -> Constraint -- NB: also has an /invisible/ argument + + Non-examples: + + Nullary :: Constraint + Binary :: Type -> Type -> Constraint + Binary2 :: forall k -> k -> Constraint -- Two visible arguments + + Defaultable class + a typeclass which has at least one in-scope default declaration + + This includes the two different categories of default declarations: + + - Haskell 98 default declarations such as 'default (Integer, Float)'. + + - `Num` is always defaultable; either the user says 'default( Integer, Float )' + or (absent such a declaration) the system fills in a fallback default declaration. + See Section 4.3.4 in https://www.haskell.org/onlinereport/haskell2010/haskellch4.html + + - With `OverloadedStrings`, the class `IsString` is defaultable + - With `ExtendedDefaultRules`, the classes `Show`, `Eq`, `Ord`, `Foldable` and `Traversable` + are defaultable + + - Named default declarations, which apply to the named class, e.g. + 'default Cls(X, Y)' applies precisely to 'Cls'. + Note that these may be locally defined, or they may be imported. + + Standard class: + a class defined in the Prelude or the standard library, as defined + by the Haskell 98 report (section 4.3.4) + + These are defined in GHC.Builtin.Names.standardClassKeys. + +The rules for defaulting a collection 'S' of unsolved constraints are as follows: + + 1. For each metavariable 'v' appearing in 'S', define + + U_v = { C v | C v ∈ U, C is a unary typeclass } + + We then process each 'U_v' in turn, in order to find a defaulting + assignment 'v := ty' that solves all of 'U_v'. + + 2. Unless -XExtendedDefaultRules is in effect, give up if 'v' appears: + + - in any constraint that isn't a unary class constraint + - in a class constraint which is non-standard and does not have + a default declaration in scope. + + 3. Compute candidate assignments: for each unary typeclass 'C' in 'U_v' which + has a default declaration in scope, find the first type 'ty' in the list + of in-scope default types for 'C' for which all of 'U_v' is soluble. + + 4. If there is precisely one type candidate type assignment 'ty' that allows + all of 'U_v' to be solved, we default 'v := ty'. Otherwise, do nothing + ('v' remains ambiguous). + +Note [Defaulting plugins] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Defaulting plugins enable extending or overriding the defaulting +behaviour. In `applyDefaultingRules`, before the built-in defaulting +mechanism runs, the loaded defaulting plugins are passed the +`WantedConstraints` and get a chance to propose defaulting assignments +based on them. + +Proposals are represented as `[DefaultingProposal]` with each proposal +consisting of a type variable to fill-in, the list of defaulting types to +try in order, and a set of constraints to check at each try. This is +the same representation (albeit in a nicely packaged-up data type) as +the candidates generated by the built-in defaulting mechanism, so the +actual trying of proposals is done by the same `disambigGroup` function. + +Wrinkle (DP1): The role of `WantedConstraints` + + Plugins are passed `WantedConstraints` that can perhaps be + progressed on by defaulting. But a defaulting plugin is not a solver + plugin, its job is to provide defaulting proposals, i.e. mappings of + type variable to types. How do plugins know which type variables + they are supposed to default? + + The `WantedConstraints` passed to the defaulting plugin are zonked + beforehand to ensure all remaining metavariables are unfilled. Thus, + the `WantedConstraints` serve a dual purpose: they are both the + constraints of the given context that can act as hints to the + defaulting, as well as the containers of the type variables under + consideration for defaulting. + +Wrinkle (DP2): Interactions between defaulting mechanisms + + In the general case, we have multiple defaulting plugins loaded and + there is also the built-in defaulting mechanism. In this case, we + have to be careful to keep the `WantedConstraints` passed to the + plugins up-to-date by zonking between successful defaulting + rounds. Otherwise, two plugins might come up with a defaulting + proposal for the same metavariable; if the first one is accepted by + `disambigGroup` (thus the meta gets filled), the second proposal + becomes invalid (see #23821 for an example). + +Note [Defaulting insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a set of wanteds is insoluble, we have no hope of accepting the +program. Yet we do not stop constraint solving, etc., because we may +simplify the wanteds to produce better error messages. So, once +we have an insoluble constraint, everything we do is just about producing +helpful error messages. + +Should we default in this case or not? Let's look at an example (tcfail004): + + (f,g) = (1,2,3) + +With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer). +Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard) +find the latter more helpful. Several other test cases (e.g. tcfail005) suggest +similarly. So: we should not do class defaulting with insolubles. + +On the other hand, RuntimeRep-defaulting is different. Witness tcfail078: + + f :: Integer i => i + f = 0 + +Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind +TYPE r0 -> Constraint and then complains that r0 is actually untouchable +(presumably, because it can't be sure if `Integer i` entails an equality). +If we default, we are told of a clash between (* -> Constraint) and Constraint. +The latter seems far better, suggesting we *should* do RuntimeRep-defaulting +even on insolubles. + +But, evidently, not always. Witness UnliftedNewtypesInfinite: + + newtype Foo = FooC (# Int#, Foo #) + +This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes). +If we default RuntimeRep-vars, we get + + Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted + +which is just plain wrong. + +Another situation in which we don't want to default involves concrete metavariables. + +In equalities such as alpha[conc] ~# rr[sk] , alpha[conc] ~# RR beta[tau] +for a type family RR (all at kind RuntimeRep), we would prefer to report a +representation-polymorphism error rather than default alpha and get error: + + Could not unify `rr` with `Lifted` / Could not unify `RR b0` with `Lifted` + +which is very confusing. For this reason, we weed out the concrete +metavariables participating in such equalities in nonDefaultableTyVarsOfWC. +Just looking at insolublity is not enough, as `alpha[conc] ~# RR beta[tau]` could +become soluble after defaulting beta (see also #21430). + +Conclusion: we should do RuntimeRep-defaulting on insolubles only when the +user does not want to hear about RuntimeRep stuff -- that is, when +-fprint-explicit-runtime-reps is not set. +However, we must still take care not to default concrete type variables +participating in an equality with a non-concrete type, as seen in the +last example above. + +-} + +tryTypeClassDefaulting :: WantedConstraints -> TcS WantedConstraints +tryTypeClassDefaulting wc + | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles] + = return wc + | otherwise -- See Note [When to do type-class defaulting] + = do { something_happened <- applyDefaultingRules wc + -- See Note [Top-level Defaulting Plan] + ; solveAgainIf something_happened wc } + +applyDefaultingRules :: WantedConstraints -> TcS Bool +-- True <=> I did some defaulting, by unifying a meta-tyvar +-- Input WantedConstraints are not necessarily zonked +-- See Note [How type-class constraints are defaulted] + +applyDefaultingRules wanteds + | isEmptyWC wanteds + = return False + | otherwise + = do { (default_env, extended_rules) <- getDefaultInfo + ; wanteds <- TcS.zonkWC wanteds + + ; tcg_env <- TcS.getGblEnv + ; let plugins = tcg_defaulting_plugins tcg_env + default_tys = defaultList default_env + -- see Note [Named default declarations] in GHC.Tc.Gen.Default + + -- Run any defaulting plugins + -- See Note [Defaulting plugins] for an overview + ; (wanteds, plugin_defaulted) <- if null plugins then return (wanteds, []) else + do { + ; traceTcS "defaultingPlugins {" (ppr wanteds) + ; (wanteds, defaultedGroups) <- mapAccumLM run_defaulting_plugin wanteds plugins + ; traceTcS "defaultingPlugins }" (ppr defaultedGroups) + ; return (wanteds, defaultedGroups) + } + + ; let groups = findDefaultableGroups (default_tys, extended_rules) wanteds + + ; traceTcS "applyDefaultingRules {" $ + vcat [ text "wanteds =" <+> ppr wanteds + , text "groups =" <+> ppr groups + , text "info =" <+> ppr (default_tys, extended_rules) ] + + ; something_happeneds <- mapM (disambigGroup wanteds default_tys) groups + + ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) + + ; return $ or something_happeneds || or plugin_defaulted } + + where + run_defaulting_plugin wanteds p + = do { groups <- runTcPluginTcS (p wanteds) + ; defaultedGroups <- + filterM (\g -> disambigMultiGroup + wanteds + (deProposalCts g) + (ProposalSequence (Proposal <$> deProposals g))) + groups + ; traceTcS "defaultingPlugin " $ ppr defaultedGroups + ; case defaultedGroups of + [] -> return (wanteds, False) + _ -> do + -- If a defaulting plugin solves any tyvars, some of the wanteds + -- will have filled-in metavars by now (see wrinkle DP2 of + -- Note [Defaulting plugins]). So we re-zonk to make sure later + -- defaulting doesn't try to solve the same metavars. + wanteds' <- TcS.zonkWC wanteds + return (wanteds', True) } + +findDefaultableGroups + :: ( [ClassDefaults] + , Bool ) -- extended default rules + -> WantedConstraints -- Unsolved + -> [(TyVar, [Ct])] +findDefaultableGroups (default_tys, extended_defaults) wanteds + | null default_tys + = [] + | otherwise + = [ (tv, map fstOf3 group) + | group'@((_,_,tv) :| _) <- unary_groups + , let group = toList group' + , defaultable_tyvar tv + , defaultable_classes (map sndOf3 group) ] + where + simples = approximateWC True wanteds + -- True: for the purpose of defaulting we don't care + -- about shape or enclosing equalities + -- See (W3) in Note [ApproximateWC] in GHC.Tc.Types.Constraint + + (unaries, non_unaries) = partitionWith find_unary (bagToList simples) + unary_groups = equivClasses cmp_tv unaries + + unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints + unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints + non_unaries :: [Ct] -- and *other* constraints + + -- Finds unary type-class constraints + -- But take account of polykinded classes like Typeable, + -- which may look like (Typeable Type (a:Type)) (#8931) + -- See step (1) in Note [How type-class constraints are defaulted] + find_unary :: Ct -> Either (Ct, Class, TyVar) Ct + find_unary cc + | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) + , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys + -- Ignore invisible arguments for this purpose + , Just tv <- getTyVar_maybe ty + , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and + -- we definitely don't want to try to assign to those! + = Left (cc, cls, tv) + find_unary cc = Right cc -- Non unary or non dictionary + + nonunary_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries + nonunary_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries + + cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 + + defaultable_tyvar :: TcTyVar -> Bool + defaultable_tyvar tv + = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] + b2 = not (tv `elemVarSet` nonunary_tvs) + in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults] + + -- Determines whether the collection of class constraints permits defaulting. + -- See step (2) in Note [How type-class constraints are defaulted] + defaultable_classes :: [Class] -> Bool + defaultable_classes clss = + -- One of the classes has a default declaration in scope + -- (this includes 'Num', and e.g. 'IsString' with -XOverloadedStrings) + any (`elementOfUniqSet` classes_with_defaults) clss + && + -- AND, either: + -- - ExtendedDefaultRules is in effect, or + -- - all the classes are standard or have a default declaration in scope + (extended_defaults || all is_std_or_has_default clss) + is_std_or_has_default :: Class -> Bool + is_std_or_has_default cls = + (getUnique cls `elem` standardClassKeys) + || + (cls `elementOfUniqSet` classes_with_defaults) + + -- All classes with a default declaration in scope; either: + -- + -- - a named default declaration such as 'default C(Double, Bool)', or + -- - a Haskell 98 default declaration such as 'default(Int, Float)', + -- which adds defaults for Num, for IsString with OverloadedStrings, + -- and for Foldable/Traversable/... with ExtendedDefaultRules + classes_with_defaults = mkUniqSet $ map cd_class default_tys + +------------------------------ + +-- | 'Proposal's to be tried in sequence until the first one that succeeds +newtype ProposalSequence = ProposalSequence{getProposalSequence :: [Proposal]} + +-- | An atomic set of proposed type assignments to try applying all at once +newtype Proposal = Proposal [(TcTyVar, Type)] + +instance Outputable ProposalSequence where + ppr (ProposalSequence proposals) = ppr proposals +instance Outputable Proposal where + ppr (Proposal assignments) = ppr assignments + +disambigGroup :: WantedConstraints -- ^ Original constraints, for diagnostic purposes + -> [ClassDefaults] -- ^ The default classes and types + -> (TcTyVar, [Ct]) -- ^ All constraints sharing same type variable + -> TcS Bool -- True <=> something happened, reflected in ty_binds +disambigGroup orig_wanteds default_ctys (tv, wanteds) + = disambigProposalSequences orig_wanteds wanteds proposalSequences allConsistent + where + proposalSequences = [ ProposalSequence [Proposal [(tv, ty)] | ty <- tys] + | ClassDefaults{cd_types = tys} <- defaultses ] + allConsistent ((_, sub) :| subs) = all (eqSubAt tv sub . snd) subs + defaultses = + [ defaults | defaults@ClassDefaults{cd_class = cls} <- default_ctys + , any (isDictForClass (className cls)) wanteds ] + isDictForClass clcon ct = any ((clcon ==) . className . fst) (getClassPredTys_maybe $ ctPred ct) + eqSubAt :: TcTyVar -> Subst -> Subst -> Bool + eqSubAt tvar s1 s2 = or $ liftA2 tcEqType (lookupTyVar s1 tvar) (lookupTyVar s2 tvar) + +-- See Note [How type-class constraints are defaulted] +disambigMultiGroup :: WantedConstraints -- ^ Original constraints, for diagnostic purposes + -> [Ct] -- ^ check these are solved by defaulting + -> ProposalSequence -- ^ defaulting type assignments to try + -> TcS Bool -- True <=> something happened, reflected in ty_binds +disambigMultiGroup orig_wanteds wanteds proposalSequence + = disambigProposalSequences orig_wanteds wanteds [proposalSequence] (const True) + +disambigProposalSequences :: WantedConstraints -- ^ Original constraints, for diagnostic purposes + -> [Ct] -- ^ Check these are solved by defaulting + -> [ProposalSequence] -- ^ The sequences of assignment proposals + -> (NonEmpty ([TcTyVar], Subst) -> Bool) + -- ^ Predicate for successful assignments + -> TcS Bool -- True <=> something happened, reflected in ty_binds +disambigProposalSequences orig_wanteds wanteds proposalSequences allConsistent + = do { traverse_ (traverse_ reportInvalidDefaultedTyVars . getProposalSequence) proposalSequences + ; fake_ev_binds_var <- TcS.newTcEvBinds + ; tclvl <- TcS.getTcLevel + -- Step (3) in Note [How type-class constraints are defaulted] + ; successes <- fmap catMaybes $ + nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) $ + mapM firstSuccess proposalSequences + ; traceTcS "disambigProposalSequences {" (vcat [ ppr wanteds + , ppr proposalSequences + , ppr successes ]) + -- Step (4) in Note [How type-class constraints are defaulted] + ; case successes of + success@(tvs, subst) : rest + | allConsistent (success :| rest) + -> do { applyDefaultSubst tvs subst + ; let warn tv = mapM_ (warnDefaulting wanteds tv) (lookupTyVar subst tv) + ; wrapWarnTcS $ mapM_ warn tvs + ; traceTcS "disambigProposalSequences succeeded }" (ppr proposalSequences) + ; return True } + _ -> + do { traceTcS "disambigProposalSequences failed }" (ppr proposalSequences) + ; return False } } + where + reportInvalidDefaultedTyVars :: Proposal -> TcS () + firstSuccess :: ProposalSequence -> TcS (Maybe ([TcTyVar], Subst)) + firstSuccess (ProposalSequence proposals) + = getFirst <$> foldMapM (fmap First . tryDefaultGroup wanteds) proposals + reportInvalidDefaultedTyVars proposal@(Proposal assignments) + = do { let tvs = fst <$> assignments + ; invalid_tvs <- filterOutM TcS.isUnfilledMetaTyVar tvs + ; traverse_ (errInvalidDefaultedTyVar orig_wanteds proposal) (nonEmpty invalid_tvs) } + +applyDefaultSubst :: [TcTyVar] -> Subst -> TcS () +applyDefaultSubst tvs subst = + do { deep_tvs <- filterM TcS.isUnfilledMetaTyVar $ nonDetEltsUniqSet $ closeOverKinds (mkVarSet tvs) + ; forM_ deep_tvs $ \ tv -> mapM_ (unifyTyVar tv) (lookupVarEnv (getTvSubstEnv subst) tv) + } + +tryDefaultGroup :: [Ct] -- ^ check these are solved by defaulting + -> Proposal -- ^ defaulting type assignments to try + -> TcS (Maybe ([TcTyVar], Subst)) -- ^ successful substitutions, *not* reflected in ty_binds +tryDefaultGroup wanteds (Proposal assignments) + | let (tvs, default_tys) = unzip assignments + , Just subst <- tcMatchTyKis (mkTyVarTys tvs) default_tys + -- Make sure the kinds match too; hence this call to tcMatchTyKi + -- E.g. suppose the only constraint was (Typeable k (a::k)) + -- With the addition of polykinded defaulting we also want to reject + -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here. + = do { lcl_env <- TcS.getLclEnv + ; tc_lvl <- TcS.getTcLevel + ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) + new_wtd_ct :: WantedCtEvidence -> TcS Ct + new_wtd_ct (WantedCt { ctev_pred = wtd_pred, ctev_rewriters = rws }) = + mkNonCanonical . CtWanted <$> + -- NB: equality constraints are possible, + -- due to type defaulting plugins + newWantedNC loc rws (substTy subst wtd_pred) + ; new_wanteds <- sequence [ new_wtd_ct wtd + | CtWanted wtd <- map ctEvidence wanteds + ] + ; residual <- solveSimpleWanteds (listToBag new_wanteds) + ; return $ if isEmptyWC residual then Just (tvs, subst) else Nothing } + + | otherwise + = return Nothing + +errInvalidDefaultedTyVar :: WantedConstraints -> Proposal -> NonEmpty TcTyVar -> TcS () +errInvalidDefaultedTyVar wanteds (Proposal assignments) problematic_tvs + = failTcS $ TcRnInvalidDefaultedTyVar tidy_wanteds tidy_assignments tidy_problems + where + proposal_tvs = concatMap (\(tv, ty) -> tv : tyCoVarsOfTypeList ty) assignments + tidy_env = tidyFreeTyCoVars emptyTidyEnv $ proposal_tvs ++ NE.toList problematic_tvs + tidy_wanteds = map (tidyCt tidy_env) $ flattenWC wanteds + tidy_assignments = [(tidyTyCoVarOcc tidy_env tv, tidyType tidy_env ty) | (tv, ty) <- assignments] + tidy_problems = fmap (tidyTyCoVarOcc tidy_env) problematic_tvs + + flattenWC :: WantedConstraints -> [Ct] + flattenWC (WC { wc_simple = cts, wc_impl = impls }) + = ctsElts cts ++ concatMap (flattenWC . ic_wanted) impls + +-- In interactive mode, or with -XExtendedDefaultRules, +-- we default Show a to Show () to avoid gratuitous errors on "show []" +isInteractiveClass :: Bool -- -XOverloadedStrings? + -> Class -> Bool +isInteractiveClass ovl_strings cls + = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys) + + -- isNumClass adds IsString to the standard numeric classes, + -- when -XOverloadedStrings is enabled +isNumClass :: Bool -- -XOverloadedStrings? + -> Class -> Bool +isNumClass ovl_strings cls + = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) + + +{- +Note [Avoiding spurious errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When doing the unification for defaulting, we check for skolem +type variables, and simply don't default them. For example: + f = (*) -- Monomorphic + g :: Num a => a -> a + g x = f x x +Here, we get a complaint when checking the type signature for g, +that g isn't polymorphic enough; but then we get another one when +dealing with the (Num a) context arising from f's definition; +we try to unify a with Int (to default it), but find that it's +already been unified with the rigid variable from g's type sig. + +Note [Multi-parameter defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -XExtendedDefaultRules, we default only based on single-variable +constraints, but do not exclude from defaulting any type variables which also +appear in multi-variable constraints. This means that the following will +default properly: + + default (Integer, Double) + + class A b (c :: Symbol) where + a :: b -> Proxy c + + instance A Integer c where a _ = Proxy + + main = print (a 5 :: Proxy "5") + +Note that if we change the above instance ("instance A Integer") to +"instance A Double", we get an error: + + No instance for (A Integer "5") + +This is because the first defaulted type (Integer) has successfully satisfied +its single-parameter constraints (in this case Num). +-} diff --git a/GHC/Tc/Solver/Dict.hs b/GHC/Tc/Solver/Dict.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Dict.hs @@ -0,0 +1,2231 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Solving Class constraints CDictCan +module GHC.Tc.Solver.Dict ( + solveDict, solveDictNC, solveCallStack, + checkInstanceOK, + matchLocalInst, chooseInstance, + makeSuperClasses, mkStrictSuperClasses, + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Solver.Solve( solveSimpleWanteds ) + +import GHC.Tc.Errors.Types +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Instance.Class( matchEqualityInst ) +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc +import GHC.Tc.Types.Origin +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Monad +import GHC.Tc.Solver.Types +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Unify( uType, mightEqualLater ) + +import GHC.Hs.Type( HsIPName(..) ) + +import GHC.Core +import GHC.Core.Make +import GHC.Core.Type +import GHC.Core.InstEnv ( DFunInstType, ClsInst(..) ) +import GHC.Core.Class +import GHC.Core.Predicate +import GHC.Core.Multiplicity ( scaledThing ) +import GHC.Core.Unify ( ruleMatchTyKiX ) + +import GHC.Types.TyThing( lookupDataCon, lookupId ) +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Var +import GHC.Types.Id( mkTemplateLocals ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.SrcLoc + +import GHC.Builtin.Names( srcLocDataConName, pushCallStackName, emptyCallStackName ) + +import GHC.Utils.Monad ( concatMapM, foldlM ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Unit.Module + +import GHC.Data.Bag + +import GHC.Driver.DynFlags + +import qualified GHC.LanguageExtensions as LangExt + +import Data.Maybe ( listToMaybe, mapMaybe, isJust ) +import Data.Void( Void ) + +import Control.Monad + +{- ********************************************************************* +* * +* Class Canonicalization +* * +********************************************************************* -} + +solveDictNC :: CtEvidence -> Class -> [Type] -> SolverStage Void +-- NC: this comes from CNonCanonical or CIrredCan +-- Precondition: already rewritten by inert set +solveDictNC ev cls tys + = do { simpleStage $ traceTcS "solveDictNC" (ppr (mkClassPred cls tys) $$ ppr ev) + ; dict_ct <- canDictCt ev cls tys + ; solveDict dict_ct } + +solveDict :: DictCt -> SolverStage Void +-- Preconditions: `tys` are already rewritten by the inert set +solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys }) + | isEqualityClass cls + = solveEqualityDict ev cls tys + + | otherwise + = assertPpr (ctEvRewriteRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $ + do { simpleStage $ traceTcS "solveDict" (ppr dict_ct) + + ; tryInertDicts dict_ct + ; tryInstances dict_ct + + -- Try fundeps /after/ tryInstances: + -- see (DFL2) in Note [Do fundeps last] + ; doLocalFunDepImprovement dict_ct + -- doLocalFunDepImprovement does StartAgain if there + -- are any fundeps: see (DFL1) in Note [Do fundeps last] + + ; doTopFunDepImprovement dict_ct + + ; simpleStage (updInertDicts dict_ct) + ; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" } + +canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt +-- Once-only processing of Dict constraints: +-- * expand superclasses +-- * deal with CallStack +canDictCt ev cls tys + | isGiven ev -- See Note [Eagerly expand given superclasses] + = Stage $ + do { dflags <- getDynFlags + ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev [] [] cls tys + -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + ; emitWork (listToBag sc_cts) + + ; continueWith (DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = doNotExpand }) } + -- doNotExpand: We have already expanded superclasses for /this/ dict + -- so set the fuel to doNotExpand to avoid repeating expansion + + | CtWanted (WantedCt { ctev_rewriters = rws }) <- ev + , Just ip_name <- isCallStackPred cls tys + , Just fun_fs <- isPushCallStackOrigin_maybe 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] + = Stage $ + 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 <- CtWanted <$> newWantedEvVarNC new_loc rws pred + + -- Then we solve the wanted by pushing the call-site + -- onto the newly emitted CallStack + ; let ev_cs = EvCsPushCall fun_fs (ctLocSpan loc) (ctEvExpr new_ev) + ; solveCallStack ev ev_cs + + ; continueWith (DictCt { di_ev = new_ev, di_cls = cls + , di_tys = tys, di_pend_sc = doNotExpand }) } + -- doNotExpand: No superclasses for class CallStack + -- See invariants in CDictCan.cc_pend_sc + + | otherwise + = Stage $ + do { dflags <- getDynFlags + ; let fuel | classHasSCs cls = wantedsFuel dflags + | otherwise = doNotExpand + -- See Invariants in `CCDictCan.cc_pend_sc` + ; continueWith (DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = fuel }) } + + where + loc = ctEvLoc ev + orig = ctLocOrigin loc + pred = ctEvPred ev + +{- ********************************************************************* +* * +* Implicit parameters and call stacks +* * +********************************************************************* -} + +solveCallStack :: CtEvidence -> EvCallStack -> TcS () +-- Also called from GHC.Tc.Solver when defaulting call stacks +solveCallStack ev ev_cs + -- We're given ev_cs :: CallStack, but the evidence term should be a + -- dictionary, so we have to coerce ev_cs to a dictionary for + -- `IP ip CallStack`. See Note [Overview of implicit CallStacks] + = do { inner_stk <- evCallStack pred ev_cs + ; let ev_tm = EvExpr (evWrapIPE pred inner_stk) + ; setEvBindIfWanted ev EvCanonical ev_tm } + -- EvCanonical: see Note [CallStack and ExceptionContext hack] + where + pred = ctEvPred ev + +-- Dictionary for CallStack implicit parameters +evCallStack :: TcPredType -> EvCallStack -> TcS EvExpr +-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +evCallStack _ EvCsEmpty + = Var <$> lookupId emptyCallStackName +evCallStack pred (EvCsPushCall fs loc tm) + = do { df <- getDynFlags + ; m <- getModule + ; srcLocDataCon <- lookupDataCon srcLocDataConName + ; let platform = targetPlatform df + mkSrcLoc l = mkCoreConWrapApps srcLocDataCon <$> + sequence [ mkStringExprFS (unitFS $ moduleUnit m) + , mkStringExprFS (moduleNameFS $ moduleName m) + , mkStringExprFS (srcSpanFile l) + , return $ mkIntExprInt platform (srcSpanStartLine l) + , return $ mkIntExprInt platform (srcSpanStartCol l) + , return $ mkIntExprInt platform (srcSpanEndLine l) + , return $ mkIntExprInt platform (srcSpanEndCol l) + ] + + ; push_cs_id <- lookupId pushCallStackName + ; name_expr <- mkStringExprFS fs + ; loc_expr <- mkSrcLoc loc + -- At this point tm :: IP sym CallStack + -- but we need the actual CallStack to pass to pushCS, + -- so we use evUwrapIP to strip the dictionary wrapper + -- See Note [Overview of implicit CallStacks] + ; let outer_stk = evUnwrapIPE pred tm + ; return (mkCoreApps (Var push_cs_id) + [mkCoreTup [name_expr, loc_expr], outer_stk]) } + +{- Note [Solving CallStack constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence. + +Suppose f :: HasCallStack => blah. Then + +* Each call to 'f' gives rise to + [W] s1 :: IP "callStack" CallStack -- CtOrigin = OccurrenceOf f + with a CtOrigin that says "OccurrenceOf f". + Remember that HasCallStack is just shorthand for + IP "callStack" CallStack + See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence + +* We canonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by + pushing the call-site info on the stack, and changing the CtOrigin + to record that has been done. + Bind: s1 = pushCallStack 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. We guarantee +this by canonicalising before looking up in the inert set. + +Note [CallStack and ExceptionContext hack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It isn't really right that we treat CallStack and ExceptionContext dictionaries +as canonical, in the sense of Note [Coherence and specialisation: overview]. +They definitely are not! + +But if we use EvNonCanonical here we get lots of + nospec (error @Int) dict string +(since `error` takes a HasCallStack dict), and that isn't bottoming (at least not +without extra work) So, hackily, we just say that HasCallStack and ExceptionContext +are canonical, even though they aren't really. + +Note [Shadowing of implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we add a new /given/ implicit parameter to the inert set, it /replaces/ +any existing givens for the same implicit parameter. This makes a difference +in two places: + +* In `GHC.Tc.Solver.InertSet.solveOneFromTheOther`, be careful when we have + (?x :: ty) in the inert set and an identical (?x :: ty) as the work item. + +* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any + existing [G] (?x :: ty'), regardless of ty'. + +* Wrinkle (SIP1): we must be careful of superclasses. 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 when we add [G] (?x::ty) we delete + * from the inert_cans, and + * from the inert_solved_dicts + any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass + with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate. + + An important special case is constraint tuples like [G] (% ?x::ty, Eq a %). + But it could happen for `class xx => D xx where ...` and the constraint D + (?x :: int). This corner (constraint-kinded variables instantiated with + implicit parameter constraints) is not well explored. + + Example in #14218, and #23761 + + The code that accounts for (SIP1) is in updInertDicts; in particular the call to + GHC.Core.Predicate.mentionsIP. + +* Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts` + as well as `inert_cans`. + You might think that wouldn't be necessary, because an element of + `inert_solved_dicts` is never an implicit parameter (see + Note [Solved dictionaries] in GHC.Tc.Solver.InertSet). + While that is true, dictionaries in `inert_solved_dicts` may still have + implicit parameters as a /superclass/! For example: + + class c => C c where ... + f :: C (?x::Int) => blah + + Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it + happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`. + +Example 1: + +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 if that (?x::Int) is still +in the inert set, we'd get a fundep interaction that tells us that alpha ~ Int, +and we get a type error. This is bad. The "replacement" semantics stops this +happening. + +Example 2: + +f :: (?x :: Char) => Char +f = let ?x = 'a' in ?x + +The "let ?x = ..." generates an implication constraint of the form: + +?x :: Char => ?x :: Char + +Furthermore, the signature for `f` also generates an implication +constraint, so we end up with the following nested implication: + +?x :: Char => (?x :: Char => ?x :: Char) + +Note that the wanted (?x :: Char) constraint may be solved in two incompatible +ways: either by using the parameter from the signature, or by using the local +definition. Our intention is that the local definition should "shadow" the +parameter of the signature. The "replacement" semantics for implicit parameters +does this. + +Example 3: + +Similarly, consider + f :: (?x::a) => Bool -> a + + g v = let ?x::Int = 3 + in (f v, let ?x::Bool = True in f v) + +This should probably be well typed, with + g :: Bool -> (Int, Bool) + +So the inner binding for ?x::Bool *overrides* the outer one. + +See ticket #17104 for a rather tricky example of this overriding +behaviour. + +All this works for the normal cases but it has an odd side effect in +some pathological programs like this: + + -- This is accepted, the second parameter shadows + f1 :: (?x :: Int, ?x :: Char) => Char + f1 = ?x + + -- This is rejected, the second parameter shadows + f2 :: (?x :: Int, ?x :: Char) => Int + f2 = ?x + +Both of these are actually wrong: when we try to use either one, +we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char), +which would lead to an error. + +I can think of two ways to fix this: + + 1. Simply disallow multiple constraints for the same implicit + parameter---this is never useful, and it can be detected completely + syntactically. + + 2. Move the shadowing machinery to the location where we nest + implications, and add some code here that will produce an + error if we get multiple givens for the same implicit parameter. +-} + + +{- ****************************************************************************** +* * + solveEqualityDict +* * +****************************************************************************** -} + +{- Note [Solving equality classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (~), which behaves as if it was defined like this: + class a ~# b => a ~ b + instance a ~# b => a ~ b +There are two more similar "equality classes" like this. The full list is + * (~) eqTyCon + * (~~) heqTyCon + * Coercible coercibleTyCon +(See Note [The equality types story] in GHC.Builtin.Types.Prim.) + +(EQC1) For Givens, when expanding the superclasses of a equality class, + we can /replace/ the constraint with its superclasses (which, remember, are + equally powerful) rather than /adding/ them. This can make a huge difference. + Consider T17836, which has a constraint like + forall b,c. a ~ (b,c) => + forall d,e. c ~ (d,e) => + ...etc... + If we just /add/ the superclasses of [G] g1:a ~ (b,c), we'll put + [G] g1:(a~(b,c)) in the inert set and emit [G] g2:a ~# (b,c). That will + kick out g1, and it'll be re-inserted as [G] g1':(b,c)~(b,c) which does + no good to anyone. When the implication is deeply nested, this has + quadratic cost, and no benefit. Just replace! + + (This can have a /big/ effect: test T17836 involves deeply-nested GADT + pattern matching. Its compile-time allocation decreased by 40% when + I added the "replace" rather than "add" semantics.) + + We achieve this by + (a) not expanding superclasses for equality classes at all; + see the `isEqualityClass` test in `mk_strict_superclasses` + (b) special logic to solve (t1 ~ t2) in `solveEqualityDict`. + +(EQC2) Faced with [W] t1 ~ t2, it's always OK to reduce it to [W] t1 ~# t2, + without worrying about Note [Instance and Given overlap]. Why? Because + if we had [G] s1 ~ s2, then we'd get the superclass [G] s1 ~# s2, and + so the reduction of the [W] constraint does not risk losing any solutions. + + On the other hand, it can be fatal to /fail/ to reduce such equalities + on the grounds of Note [Instance and Given overlap], because many good + things flow from [W] t1 ~# t2. + +Conclusion: we have a special solver pipeline for equality-class constraints, +`solveEqualityDict`. It aggressively decomposes the boxed equality constraint +into an unboxed coercion, both for Givens and Wanteds, and /replaces/ the +boxed equality constraint with the unboxed one, so that the inert set never +contains the boxed one. + +Note [Solving tuple constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I tried treating tuple constraints, such as (% Eq a, Show a %), rather like +equality-class constraints (see Note [Solving equality classes]). That is, by +eagerly decomposing tuple-constraints into their component (Eq a) and (Show a). + +But discarding the tuple Given (which "replacing" does) means that we may +have to reconstruct it for a recursive call. For example + f :: (% Eq a, Show a %) => blah + f x = ....(f x').... +If we decomposed eagerly we'd get + f = \(d : (% Eq a, Show a %)). + let de = fst d + ds = snd d + in ....(f (% de, ds %))... +and the optimiser may not be clever enough to transform (f (% de, ds %)) into +(f d). See #10359 and its test case, and #23398. (This issue is less pressing for +equality classes because they have to be unpacked strictly, so CSE-ing away +the reconstruction works fine. + +So at the moment we don't decompose tuple constraints eagerly; instead we mostly +just treat them like other constraints. +* Given tuples are decomposed via their superclasses, in `canDictCt`. So + [G] (% Eq a, Show a %) + has superclasses + [G] Eq a, [G] Show a + +* Wanted tuples are decomposed via a built-in "instance". See + `GHC.Tc.Instance.Class.matchCTuple` + +There is a bit of special treatment: search for isCTupleClass. +-} + +solveEqualityDict :: CtEvidence -> Class -> [Type] -> SolverStage Void +-- See Note [Solving equality classes] +-- Precondition: (isEqualityClass cls) True, so cls is (~), (~~), or Coercible +solveEqualityDict ev cls tys + | CtWanted (WantedCt { ctev_dest = dest }) <- ev + = Stage $ + do { let (role, t1, t2) = matchEqualityInst cls tys + -- Unify t1~t2, putting anything that can't be solved + -- immediately into the work list + ; (co, _, _) <- wrapUnifierTcS ev role $ \uenv -> + uType uenv t1 t2 + -- Set d :: (t1~t2) = Eq# co + ; setWantedEvTerm dest EvCanonical $ + evDictApp cls tys [Coercion co] + ; stopWith ev "Solved wanted lifted equality" } + + | CtGiven (GivenCt { ctev_evar = ev_id }) <- ev + , [sel_id] <- classSCSelIds cls -- Equality classes have just one superclass + = Stage $ + do { let loc = ctEvLoc ev + sc_pred = classMethodInstTy sel_id tys + ev_expr = EvExpr $ Var sel_id `mkTyApps` tys `App` evId ev_id + ; given_ev <- newGivenEvVar loc (sc_pred, ev_expr) + ; startAgainWith (mkNonCanonical $ CtGiven given_ev) } + | otherwise + = pprPanic "solveEqualityDict" (ppr cls) + +{- ****************************************************************************** +* * + interactDict +* * +********************************************************************************* + +Note [Shortcut solving] +~~~~~~~~~~~~~~~~~~~~~~~ +When we interact a [W] constraint with a [G] constraint that solves it, there is +a possibility that we could produce better code if instead we solved from a +top-level instance declaration (See #12791, #5835). For example: + + class M a b where m :: a -> b + + type C a b = (Num a, M a b) + + f :: C Int b => b -> Int -> Int + f _ x = x + 1 + +The body of `f` requires a [W] `Num Int` instance. We could solve this +constraint from the givens because we have `C Int b` and that provides us a +solution for `Num Int`. This would let us produce core like the following +(with -O2): + + f :: forall b. C Int b => b -> Int -> Int + f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) -> + + @ Int + (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%)) + eta1 + A.f1 + +This is bad! We could do /much/ better if we solved [W] `Num Int` directly +from the instance that we have in scope: + + f :: forall b. C Int b => b -> Int -> Int + f = \ (@ b) _ _ (x :: Int) -> + case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) } + +** NB: It is important to emphasize that all this is purely an optimization: +** exactly the same programs should typecheck with or without this procedure. + +Consider + f :: Ord [a] => ... + f x = ..Need Eq [a]... +We could use the Eq [a] superclass of the Ord [a], or we could use the top-level +instance `Eq a => Eq [a]`. But if we did the latter we'd be stuck with an +insoluble constraint (Eq a). + +----------------------------------- +So the ShortCutSolving plan is this: + If we could solve a constraint from a local Given, + try first to /completely/ solve the constraint + using only top-level instances, + /without/ using any local Givens. + - If that succeeds, use it + - If not, use the local Given +----------------------------------- + +An example that succeeds: + + class Eq a => C a b | b -> a where + m :: b -> a + + f :: C [Int] b => b -> Bool + f x = m x == [] + +We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This +produces the following core: + + f :: forall b. C [Int] b => b -> Bool + f = \ (@ b) ($dC :: C [Int] b) (x :: b) -> + GHC.Classes.$fEq[]_$s$c== + (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int) + +An example that fails: + + class Eq a => C a b | b -> a where + m :: b -> a + + f :: C [a] b => b -> Bool + f x = m x == [] + +Which, because solving `Eq [a]` demands `Eq a` which we cannot solve. so short-cut +solving fails and we use the superclass of C: + + f :: forall a b. C [a] b => b -> Bool + f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) -> + == + @ [a] + (A.$p1C @ [a] @ b $dC) + (m @ [a] @ b $dC eta) + (GHC.Types.[] @ a) + +The moving parts are relatively simple: + +* To attempt to solve the constraint completely, we just recursively + call the constraint solver. See the use of `tryShortCutTcS` in + `tcShortCutSolver`. + +* When this attempted recursive solving, in `tryShortCutTcS`, we + - start with an empty inert set: no Givens and no Wanteds + - set a special mode `TcSShortCut`, which signals that we are trying to solve + using only top-level instances. + +* When in TcSShortCut mode, since there are no Givens we can short-circuit; + these are all just optimisations: + - `tryInertDicts` + - `GHC.Tc.Solver.Monad.lookupInertDict` + - `noMatchableGivenDicts` + - `matchLocalInst` + - `GHC.Tc.Solver.Solve.runTcPluginsWanted` + +* In `GHC.Tc.Solver.Instance.Class.matchInstEnv`: when short-cut solving, + don't pick overlappable top-level instances + +Some wrinkles: + +(SCS1) Note [Shortcut solving: incoherence] + +(SCS2) The short-cut solver just uses the solver recursively, so we get its + full power: + + * We need to be able to handle recursive super classes. The + solved_dicts state ensures that we remember what we have already + tried to solve to avoid looping. + + * As #15164 showed, it can be important to exploit sharing between + goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H; + and to solve G2 we may need H. If we don't spot this sharing we may + solve H twice; and if this pattern repeats we may get exponentially bad + behaviour. + + * Suppose we have (#13943) + class Take (n :: Nat) where ... + instance {-# OVERLAPPING #-} Take 0 where .. + instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where .. + + And we have [W] Take 3. That only matches one instance so we get + [W] Take (3-1). Then we should reduce the (3-1) to 2, and continue. + +(SCS3) When doing short-cut solving we can (and should) inherit the `solved_dicts` + of the caller (#15164). You might worry about having a solved-dict that uses + a Given -- but that too will have been subject to short-cut solving so it's fine. + +Note [Shortcut solving: incoherence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This optimization relies on coherence of dictionaries to be correct. When we +cannot assume coherence because of IncoherentInstances then this optimization +can change the behavior of the user's code. + +The following four modules produce a program whose output would change depending +on whether we apply this optimization when IncoherentInstances is in effect: + +========= + {-# LANGUAGE MultiParamTypeClasses #-} + module A where + + class A a where + int :: a -> Int + + class A a => C a b where + m :: b -> a -> a + +========= + {-# LANGUAGE FlexibleInstances #-} + {-# LANGUAGE MultiParamTypeClasses #-} + module B where + + import A + + instance A a where + int _ = 1 + + instance C a [b] where + m _ = id + +========= + {-# LANGUAGE FlexibleContexts #-} + {-# LANGUAGE FlexibleInstances #-} + {-# LANGUAGE IncoherentInstances #-} + {-# LANGUAGE MultiParamTypeClasses #-} + module C where + + import A + + instance A Int where + int _ = 2 + + instance C Int [Int] where + m _ = id + + intC :: C Int a => a -> Int -> Int + intC _ x = int x + +========= + module Main where + + import A + import B + import C + + main :: IO () + main = print (intC [] (0::Int)) + +The output of `main` if we avoid the optimization under the effect of +IncoherentInstances is `1`. If we were to do the optimization, the output of +`main` would be `2`. + + +Note [No Given/Given fundeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not create constraints from: +* Given/Given interactions via functional dependencies or type family + injectivity annotations. +* Given/instance fundep interactions via functional dependencies or + type family injectivity annotations. + +In this Note, all these interactions are called just "fundeps". + +We ingore such fundeps for several reasons: + +1. These fundeps will never serve a purpose in accepting more + programs: Given constraints do not contain metavariables that could + be unified via exploring fundeps. They *could* be useful in + discovering inaccessible code. However, the constraints will be + Wanteds, and as such will cause errors (not just warnings) if they + go unsolved. Maybe there is a clever way to get the right + inaccessible code warnings, but the path forward is far from + clear. #12466 has further commentary. + +2. Furthermore, here is a case where a Given/instance interaction is actively + harmful (from dependent/should_compile/RaeJobTalk): + + type family a == b :: Bool + type family Not a = r | r -> a where + Not False = True + Not True = False + + [G] Not (a == b) ~ True + + Reacting this Given with the equations for Not produces + + [W] a == b ~ False + + This is indeed a true consequence, and would make sense as a fresh Given. + But we don't have a way to produce evidence for fundeps, as a Wanted it + is /harmful/: we can't prove it, and so we'll report an error and reject + the program. (Previously fundeps gave rise to Deriveds, which + carried no evidence, so it didn't matter that they could not be proved.) + +3. #20922 showed a subtle different problem with Given/instance fundeps. + type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where + ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss + ... + + tclevel = 4 + [G] ZipCons is1 iss ~ (i : is2) : jss + + (The tclevel=4 means that this Given is at level 4.) The fundep tells us that + 'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification + variable; we don't know what type it stands for. So we would emit + [W] iss ~ is2 : beta + + Again we can't prove that equality; and worse we'll rewrite iss to + (is2:beta) in deeply nested constraints inside this implication, + where beta is untouchable (under other equality constraints), leading + to other insoluble constraints. + +The bottom line: since we have no evidence for them, we should ignore Given/Given +and Given/instance fundeps entirely. +-} + +tryInertDicts :: DictCt -> SolverStage () +tryInertDicts dict_ct + = Stage $ do { inerts <- getInertCans + ; try_inert_dicts inerts dict_ct } + +try_inert_dicts :: InertCans -> DictCt -> TcS (StopOrContinue ()) +try_inert_dicts inerts dict_w@(DictCt { di_ev = ev_w, di_cls = cls, di_tys = tys }) + | Just dict_i <- lookupInertDict inerts cls tys + , let ev_i = dictCtEvidence dict_i + loc_i = ctEvLoc ev_i + loc_w = ctEvLoc ev_w + = -- There is a matching dictionary in the inert set + do { -- For a Wanted, first to try to solve it /completely/ from top level instances + -- See Note [Shortcut solving] + ; short_cut_worked <- tryShortCutSolver (isGiven ev_i) dict_w + + ; if | short_cut_worked + -> stopWith ev_w "shortCutSolver worked(1)" + + -- Next see if we are in "loopy-superclass" land. If so, + -- we don't want to replace the (Given) inert with the + -- (Wanted) work-item, or vice versa; we want to hang on + -- to both, and try to solve the work-item via an instance. + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + | prohibitedSuperClassSolve loc_i loc_w + -> continueWith () + + | otherwise -- We can either solve the inert from the work-item or vice-versa. + -> case solveOneFromTheOther (CDictCan dict_i) (CDictCan dict_w) of + KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr dict_w) + ; setEvBindIfWanted ev_w EvCanonical (ctEvTerm ev_i) + ; return $ Stop ev_w (text "Dict equal" <+> ppr dict_w) } + KeepWork -> do { traceTcS "lookupInertDict:KeepWork" (ppr dict_w) + ; setEvBindIfWanted ev_i EvCanonical (ctEvTerm ev_w) + ; updInertCans (updDicts $ delDict dict_w) + ; continueWith () } } + + | otherwise + = do { traceTcS "tryInertDicts:no" (ppr dict_w $$ ppr cls <+> ppr tys) + ; continueWith () } + +-- See Note [Shortcut solving] +tryShortCutSolver :: Bool -- True <=> try the short-cut solver; False <=> don't + -> DictCt -- Work item + -> TcS Bool -- True <=> success +-- We are about to solve a [W] constraint from a [G] constraint. We take +-- a moment to see if we can get a better solution using an instance. +-- Note that we only do this for the sake of performance. Exactly the same +-- programs should typecheck regardless of whether we take this step or +-- not. See Note [Shortcut solving] +tryShortCutSolver try_short_cut dict_w@(DictCt { di_ev = ev_w }) + | not try_short_cut + = return False + | otherwise + = do { dflags <- getDynFlags + ; if | CtWanted (WantedCt { ctev_pred = pred_w }) <- ev_w + + , not (couldBeIPLike pred_w) -- Not for implicit parameters (#18627) + + , not (xopt LangExt.IncoherentInstances dflags) + -- If IncoherentInstances is on then we cannot rely on coherence of proofs + -- in order to justify this optimization: The proof provided by the + -- [G] constraint's superclass may be different from the top-level proof. + -- See Note [Shortcut solving: incoherence] + + , gopt Opt_SolveConstantDicts dflags + -- Enabled by the -fsolve-constant-dicts flag + + -> tryShortCutTcS $ -- tryTcS tries to completely solve some contraints + do { residual <- solveSimpleWanteds (unitBag (CDictCan dict_w)) + ; return (isEmptyWC residual) } + + | otherwise + -> return False } + + +{- ******************************************************************* +* * + Top-level reaction for class constraints (CDictCan) +* * +**********************************************************************-} + +tryInstances :: DictCt -> SolverStage () +tryInstances dict_ct + = Stage $ do { inerts <- getInertSet + ; try_instances inerts dict_ct } + +try_instances :: InertSet -> DictCt -> TcS (StopOrContinue ()) +-- Try to use type-class instance declarations to simplify the constraint +try_instances inerts work_item@(DictCt { di_ev = ev, di_cls = cls + , di_tys = xis }) + | isGiven ev -- Never use instances for Given constraints + = continueWith () + -- See Note [No Given/Given fundeps] + + | Just solved_ev <- lookupSolvedDict inerts cls xis -- Cached + = do { setEvBindIfWanted ev EvCanonical (ctEvTerm solved_ev) + ; stopWith ev "Dict/Top (cached)" } + + | otherwise -- Wanted, but not cached + = do { dflags <- getDynFlags + ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc + ; case lkup_res of + OneInst { cir_what = what } + -> do { let is_local_given = case what of { LocalInstance -> True; _ -> False } + ; take_shortcut <- tryShortCutSolver is_local_given work_item + ; if take_shortcut + then stopWith ev "shortCutSolver worked(2)" + else do { insertSafeOverlapFailureTcS what work_item + ; updSolvedDicts what work_item + ; chooseInstance ev lkup_res } } + _ -> -- NoInstance or NotSure: we didn't solve it + continueWith () } + where + dict_loc = ctEvLoc ev + +chooseInstance :: CtEvidence -> ClsInstResult -> TcS (StopOrContinue a) +chooseInstance work_item + (OneInst { cir_new_theta = theta + , cir_what = what + , cir_mk_ev = mk_ev + , cir_canonical = canonical }) + = do { traceTcS "doTopReact/found instance for" $ ppr work_item + ; deeper_loc <- checkInstanceOK loc what pred + ; checkReductionDepth deeper_loc pred + ; assertPprM (getTcEvBindsVar >>= return . not . isCoEvBindsVar) + (ppr work_item) + ; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta + ; setEvBindIfWanted work_item canonical (mk_ev (map getEvExpr evc_vars)) + ; emitWorkNC (map CtWanted $ freshGoals evc_vars) + ; stopWith work_item "Dict/Top (solved wanted)" } + where + pred = ctEvPred work_item + loc = ctEvLoc work_item + +chooseInstance work_item lookup_res + = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res) + +checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc +-- Check that it's OK to use this instance: +-- (a) the use is well staged in the Template Haskell sense +-- Returns the CtLoc to used for sub-goals +-- Probably also want to call checkReductionDepth +checkInstanceOK loc what pred + = do { checkWellLevelledDFun loc what pred + ; return deeper_loc } + where + deeper_loc = zap_origin (bumpCtLocDepth loc) + origin = ctLocOrigin loc + + zap_origin loc -- After applying an instance we can set ScOrigin to + -- NotNakedSc, so that prohibitedSuperClassSolve never fires + -- See Note [Solving superclass constraints] in + -- GHC.Tc.TyCl.Instance, (sc1). + | ScOrigin what _ <- origin + = setCtLocOrigin loc (ScOrigin what NotNakedSc) + | otherwise + = loc + +matchClassInst :: DynFlags -> InertSet + -> Class -> [Type] + -> CtLoc -> TcS ClsInstResult +matchClassInst dflags inerts clas tys loc +-- First check whether there is an in-scope Given that could +-- match this constraint. In that case, do not use any instance +-- whether top level, or local quantified constraints. +-- See Note [Instance and Given overlap] and see +-- (IL0) in Note [Rules for instance lookup] in GHC.Core.InstEnv + | not (xopt LangExt.IncoherentInstances dflags) + , not (isCTupleClass clas) + -- It is always safe to unpack constraint tuples + -- And if we don't do so, we may never solve it at all + -- See Note [Solving tuple constraints] + , not (noMatchableGivenDicts inerts loc clas tys) + = do { traceTcS "Delaying instance application" $ + vcat [ text "Work item:" <+> pprClassPred clas tys ] + ; return NotSure } + + | otherwise + = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{' + ; local_res <- matchLocalInst pred loc + ; case local_res of + OneInst {} -> -- See Note [Local instances and incoherence] + do { traceTcS "} matchClassInst local match" $ ppr local_res + ; return local_res } + + NotSure -> -- In the NotSure case for local instances + -- we don't want to try global instances + do { traceTcS "} matchClassInst local not sure" empty + ; return local_res } + + NoInstance -- No local instances, so try global ones + -> do { global_res <- matchGlobalInst dflags clas tys loc + ; warn_custom_warn_instance global_res loc + -- See Note [Implementation of deprecated instances] + ; traceTcS "} matchClassInst global result" $ ppr global_res + ; return global_res } } + where + pred = mkClassPred clas tys + +-- | Returns True iff there are no Given constraints that might, +-- potentially, match the given class constraint. 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.Dict +noMatchableGivenDicts :: InertSet -> CtLoc -> Class -> [TcType] -> Bool +noMatchableGivenDicts inerts@(IS { inert_cans = inert_cans }) loc_w clas tys + = not $ anyBag matchable_given $ + findDictsByClass (inert_dicts inert_cans) clas + where + pred_w = mkClassPred clas tys + + matchable_given :: DictCt -> Bool + matchable_given (DictCt { di_ev = ev }) + | CtGiven (GivenCt { ctev_loc = loc_g, ctev_pred = pred_g }) <- ev + = isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w + + | otherwise + = False + +{- Note [Implementation of deprecated instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note describes the implementation of the deprecated instances GHC proposal + https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0575-deprecated-instances.rst + +In the parser, we parse deprecations/warnings attached to instances: + + instance {-# DEPRECATED "msg" #-} Show X + deriving instance {-# WARNING "msg2" #-} Eq Y + +(Note that non-standalone deriving instance declarations do not support this mechanism.) +(Note that the DEPRECATED and WARNING pragmas can be used here interchangeably.) + +We store the resulting warning message in the extension field of `ClsInstDecl` +(respectively, `DerivDecl`; See Note [Trees That Grow]). + +In `GHC.Tc.TyCl.Instance.tcClsInstDecl` (respectively, `GHC.Tc.Deriv.Utils.newDerivClsInst`), +we pass on that information to `ClsInst` (and eventually store it in `IfaceClsInst` too). + +Next, if we solve a constraint using such an instance, in +`GHC.Tc.Instance.Class.matchInstEnv`, we pass it further into the +`Ghc.Tc.Types.Origin.InstanceWhat`. + +Finally, if the instance solving function `GHC.Tc.Solver.Monad.matchGlobalInst` returns +a `Ghc.Tc.Instance.Class.ClsInstResult` with `Ghc.Tc.Types.Origin.InstanceWhat` containing +a warning, when called from either `matchClassInst` or `shortCutSolver`, we call +`warn_custom_warn_instance` that ultimately emits the warning if needed. + +Note that we only emit a warning when the instance is used in a different module +than it is defined, which keeps the behaviour in line with the deprecation of +top-level identifiers. +-} + +-- | Emits the custom warning for a deprecated instance +-- +-- See Note [Implementation of deprecated instances] +warn_custom_warn_instance :: ClsInstResult -> CtLoc -> TcS () +warn_custom_warn_instance (OneInst{ cir_what = what }) ct_loc + | TopLevInstance{ iw_dfun_id = dfun, iw_warn = Just warn } <- what = do + let mod = nameModule $ getName dfun + this_mod <- getModule + when (this_mod /= mod) + -- We don't emit warnings for usages inside of the same module + -- to prevent it being triggered for instance child declarations + $ ctLocWarnTcS ct_loc + $ TcRnPragmaWarning + { pragma_warning_info = PragmaWarningInstance dfun (ctl_origin ct_loc) + , pragma_warning_msg = warn } +warn_custom_warn_instance _ _ = return () + +{- Note [Instance and Given overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example, from the OutsideIn(X) paper: + instance P x => Q [x] + instance (x ~ y) => R y [x] + + wob :: forall a b. (Q [b], R b a) => a -> Int + + g :: forall a. Q [a] => [a] -> Int + g x = wob x + +From 'g' we get the implication constraint: + forall a. Q [a] => (Q [beta], R beta [a]) +If we react (Q [beta]) with its top-level axiom, we end up with a +(P beta), which we have no way of discharging. On the other hand, +if we react R beta [a] with the top-level we get (beta ~ a), which +is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is +now solvable by the given Q [a]. + +The partial solution is that: + In matchClassInst (and thus in topReact), we return a matching + instance only when there is no Given in the inerts which is + unifiable to this particular dictionary. + + We treat any meta-tyvar as "unifiable" for this purpose, + *including* untouchable ones. But not skolems like 'a' in + the implication constraint above. + +The end effect is that, much as we do for overlapping instances, we +delay choosing a class instance if there is a possibility of another +instance OR a given to match our constraint later on. This fixes +tickets #4981 and #5002. + +Other notes: + +* The check is done *first*, so that it also covers classes + with built-in instance solving, such as + - constraint tuples + - natural numbers + - Typeable + +* See also Note [What might equal later?] in GHC.Tc.Utils.Unify + +* The given-overlap problem is arguably not easy to appear in practice + due to our aggressive prioritization of equality solving over other + constraints, but it is possible. I've added a test case in + typecheck/should-compile/GivenOverlapping.hs + +* Another "live" example is #10195; another is #10177. + +* We ignore the overlap problem if -XIncoherentInstances is in force: + see #6002 for a worked-out example where this makes a + difference. + +* Moreover notice that our goals here are different than the goals of + the top-level overlapping checks. There we are interested in + validating the following principle: + + If we inline a function f at a site where the same global + instance environment is available as the instance environment at + the definition site of f then we should get the same behaviour. + + But for the Given Overlap check our goal is just related to completeness of + constraint solving. + +* The solution is only a partial one. Consider the above example with + g :: forall a. Q [a] => [a] -> Int + g x = let v = wob x + in v + and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most + general type for 'v'. When generalising v's type we'll simplify its + Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we + will use the instance declaration after all. #11948 was a case + in point. + +All of this is disgustingly delicate, so to discourage people from writing +simplifiable class givens, we warn about signatures that contain them; +see GHC.Tc.Validity Note [Simplifiable given constraints]. + + +Note [Local instances and incoherence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall b c. (Eq b, forall a. Eq a => Eq (c a)) + => c b -> Bool + f x = x==x + +We get [W] Eq (c b), and we must use the local instance to solve it. + +BUT that wanted also unifies with the top-level Eq [a] instance, +and Eq (Maybe a) etc. We want the local instance to "win", otherwise +we can't solve the wanted at all. So we mark it as Incohherent. +According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll +make it win even if there are other instances that unify. + +Moreover this is not a hack! The evidence for this local instance +will be constructed by GHC at a call site... from the very instances +that unify with it here. It is not like an incoherent user-written +instance which might have utterly different behaviour. + +Consider f :: Eq a => blah. If we have [W] Eq a, we certainly +get it from the Eq a context, without worrying that there are +lots of top-level instances that unify with [W] Eq a! We'll use +those instances to build evidence to pass to f. That's just the +nullary case of what's happening here. +-} + +matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult +-- Look up the predicate in Given quantified constraints, +-- which are effectively just local instance declarations. +matchLocalInst body_pred loc + = do { -- Look in the inert set for a matching Given quantified constraint + inerts@(IS { inert_cans = ics }) <- getInertSet + ; case match_local_inst inerts (inert_qcis ics) of + { ([], []) -> do { traceTcS "No local instance for" (ppr body_pred) + ; return NoInstance } + ; (matches, unifs) -> + + do { -- Find the best match + -- See Note [Use only the best matching quantified constraint] + matches <- mapM mk_instDFun matches + ; unifs <- mapM mk_instDFun unifs + ; case dominatingMatch matches of + { Just (dfun_id, tys, theta) + | all ((theta `impliedBySCs`) . thdOf3) unifs + -> + do { let result = OneInst { cir_new_theta = theta + , cir_mk_ev = evDFunApp dfun_id tys + , cir_canonical = EvCanonical + , cir_what = LocalInstance } + ; traceTcS "Best local instance found:" $ + vcat [ text "body_pred:" <+> ppr body_pred + , text "result:" <+> ppr result + , text "matches:" <+> ppr matches + , text "unifs:" <+> ppr unifs ] + ; return result } + + ; mb_best -> + do { traceTcS "Multiple local instances; not committing to any" + $ vcat [ text "body_pred:" <+> ppr body_pred + , text "matches:" <+> ppr matches + , text "unifs:" <+> ppr unifs + , text "best_match:" <+> ppr mb_best ] + ; return NotSure }}}}} + where + body_pred_tv_set = tyCoVarsOfType body_pred + + mk_instDFun :: (CtEvidence, [DFunInstType]) -> TcS InstDFun + mk_instDFun (ev, tys) = + let dfun_id = ctEvEvId ev + in do { (tys, theta) <- instDFunType (ctEvEvId ev) tys + ; return (dfun_id, tys, theta) } + + -- Compute matching and unifying local instances + match_local_inst :: InertSet + -> [QCInst] + -> ( [(CtEvidence, [DFunInstType])] + , [(CtEvidence, [DFunInstType])] ) + match_local_inst _inerts [] + = ([], []) + match_local_inst inerts (qci@(QCI { qci_tvs = qtvs + , qci_body = qbody + , qci_ev = qev }) + : qcis) + | isWanted qev -- Skip Wanteds + = match_local_inst inerts qcis + + | let in_scope = mkInScopeSet (qtv_set `unionVarSet` body_pred_tv_set) + , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) + emptyTvSubstEnv qbody body_pred + , let match = (qev, map (lookupVarEnv tv_subst) qtvs) + = (match:matches, unifs) + + | otherwise + = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType body_pred)) + (ppr qci $$ ppr body_pred) + -- ASSERT: unification relies on the + -- quantified variables being fresh + (matches, this_unif `combine` unifs) + where + qloc = ctEvLoc qev + qtv_set = mkVarSet qtvs + (matches, unifs) = match_local_inst inerts qcis + this_unif + | Just subst <- mightEqualLater inerts qbody qloc body_pred loc + = Just (qev, map (lookupTyVar subst) qtvs) + | otherwise + = Nothing + + combine Nothing us = us + combine (Just u) us = u : us + +-- | Instance dictionary function and type. +type InstDFun = (DFunId, [TcType], TcThetaType) + +-- | Try to find a local quantified instance that dominates all others, +-- i.e. which has a weaker instance context than all the others. +-- +-- See Note [Use only the best matching quantified constraint]. +dominatingMatch :: [InstDFun] -> Maybe InstDFun +dominatingMatch matches = + listToMaybe $ mapMaybe (uncurry go) (holes matches) + -- listToMaybe: arbitrarily pick any one context that is weaker than + -- all others, e.g. so that we can handle [Eq a, Num a] vs [Num a, Eq a] + -- (see test case T22223). + + where + go :: InstDFun -> [InstDFun] -> Maybe InstDFun + go this [] = Just this + go this@(_,_,this_theta) ((_,_,other_theta):others) + | this_theta `impliedBySCs` other_theta + = go this others + | otherwise + = Nothing + +-- | Whether a collection of constraints is implied by another collection, +-- according to a simple superclass check. +-- +-- See Note [When does a quantified instance dominate another?]. +impliedBySCs :: TcThetaType -> TcThetaType -> Bool +impliedBySCs c1 c2 = all in_c2 c1 + where + in_c2 :: TcPredType -> Bool + in_c2 pred = any (pred `tcEqType`) c2_expanded + + c2_expanded :: [TcPredType] -- Includes all superclasses + c2_expanded = [ q | p <- c2, q <- p : transSuperClasses p ] + + +{- Note [When does a quantified instance dominate another?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When matching local quantified instances, it's useful to be able to pick +the one with the weakest precondition, e.g. if one has both + + [G] d1: forall a b. ( Eq a, Num b, C a b ) => D a b + [G] d2: forall a . C a Int => D a Int + [W] {w}: D a Int + +Then it makes sense to use d2 to solve w, as doing so we end up with a strictly +weaker proof obligation of `C a Int`, compared to `(Eq a, Num Int, C a Int)` +were we to use d1. + +In theory, to compute whether one context implies another, we would need to +recursively invoke the constraint solver. This is expensive, so we instead do +a simple check using superclasses, implemented in impliedBySCs. + +Examples: + + - [Eq a] is implied by [Ord a] + - [Ord a] is not implied by [Eq a], + - any context is implied by itself, + - the empty context is implied by any context. + +Note [Use only the best matching quantified constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#20582) the ambiguity check for + (forall a. Ord (m a), forall a. Semigroup a => Eq (m a)) => m Int + +Because of eager expansion of given superclasses, we get + [G] d1: forall a. Ord (m a) + [G] d2: forall a. Eq (m a) + [G] d3: forall a. Semigroup a => Eq (m a) + + [W] {w1}: forall a. Ord (m a) + [W] {w2}: forall a. Semigroup a => Eq (m a) + +The first wanted is solved straightforwardly. But the second wanted +matches *two* local instances: d2 and d3. Our general rule around multiple local +instances is that we refuse to commit to any of them. However, that +means that our type fails the ambiguity check. That's bad: the type +is perfectly fine. (This actually came up in the wild, in the streamly +library.) + +The solution is to prefer local instances which are easier to prove, meaning +that they have a weaker precondition. In this case, the empty context +of d2 is a weaker constraint than the "Semigroup a" context of d3, so we prefer +using it when proving w2. This allows us to pass the ambiguity check here. + +Our criterion for solving a Wanted by matching local quantified instances is +thus as follows: + + - There is a matching local quantified instance that dominates all others + matches, in the sense of [When does a quantified instance dominate another?]. + Any such match do, we pick it arbitrarily (the T22223 example below says why). + - This local quantified instance also dominates all the unifiers, as we + wouldn't want to commit to a single match when we might have multiple, + genuinely different matches after further unification takes place. + +Some other examples: + + + #15244: + + f :: (C g, D g) => .... + class S g => C g where ... + class S g => D g where ... + class (forall a. Eq a => Eq (g a)) => S g where ... + + Here, in f's RHS, there are two identical quantified constraints + available, one via the superclasses of C and one via the superclasses + of D. Given that each implies the other, we pick one arbitrarily. + + + #22216: + + class Eq a + class Eq a => Ord a + class (forall b. Eq b => Eq (f b)) => Eq1 f + class (Eq1 f, forall b. Ord b => Ord (f b)) => Ord1 f + + Suppose we have + + [G] d1: Ord1 f + [G] d2: Eq a + [W] {w}: Eq (f a) + + Superclass expansion of d1 gives us: + + [G] d3 : Eq1 f + [G] d4 : forall b. Ord b => Ord (f b) + + expanding d4 and d5 gives us, respectively: + + [G] d5 : forall b. Eq b => Eq (f b) + [G] d6 : forall b. Ord b => Eq (f b) + + Now we have two matching local instances that we could use when solving the + Wanted. However, it's obviously silly to use d6, given that d5 provides us with + as much information, with a strictly weaker precondition. So we pick d5 to solve + w. If we chose d6, we would get [W] Ord a, which in this case we can't solve. + + + #22223: + + [G] forall a b. (Eq a, Ord b) => C a b + [G] forall a b. (Ord b, Eq a) => C a b + [W] C x y + + Here we should be free to pick either quantified constraint, as they are + equivalent up to re-ordering of the constraints in the context. + See also Note [Do not add duplicate quantified instances] + in GHC.Tc.Solver.Monad. + +Test cases: + typecheck/should_compile/T20582 + quantified-constraints/T15244 + quantified-constraints/T22216{a,b,c,d,e} + quantified-constraints/T22223 + +Historical note: a previous solution was to instead pick the local instance +with the least superclass depth (see Note [Replacement vs keeping]), +but that doesn't work for the example from #22216. +-} + +{- ********************************************************************* +* * +* Functional dependencies, instantiation of equations +* * +************************************************************************ + +When we spot an equality arising from a functional dependency, +we now use that equality (a "wanted") to rewrite the work-item +constraint right away. This avoids two dangers + + Danger 1: If we send the original constraint on down the pipeline + it may react with an instance declaration, and in delicate + situations (when a Given overlaps with an instance) that + may produce new insoluble goals: see #4952 + + Danger 2: If we don't rewrite the constraint, it may re-react + with the same thing later, and produce the same equality + again --> termination worries. + +To achieve this required some refactoring of GHC.Tc.Instance.FunDeps (nicer +now!). + +Note [FunDep and implicit parameter reactions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, our story of interacting two dictionaries (or a dictionary +and top-level instances) for functional dependencies, and implicit +parameters, is that we simply produce new Wanted equalities. So for example + + class D a b | a -> b where ... + Inert: + [G] d1 : D Int Bool + WorkItem: + [W] d2 : D Int alpha + + We generate the extra work item + [W] cv : 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: + [W] d2' : D Int Bool + d2 := d2' |> D Int cv + Now d2' can be discharged from d1 + +We could be more aggressive and try to *immediately* solve the dictionary +using those extra equalities. + +If that were the case with the same inert set and work item we might discard +d2 directly: + + [W] cv : alpha ~ Bool + d2 := d1 |> D Int cv + +But in general it's a bit painful to figure out the necessary coercion, +so we just take the first approach. Here is a better example. Consider: + class C a b c | a -> b +And: + [G] d1 : C T Int Char + [W] d2 : C T beta Int +In this case, it's *not even possible* to solve the wanted immediately. +So we should simply output the functional dependency and add this guy +[but NOT its superclasses] back in the worklist. Even worse: + [G] d1 : C T Int beta + [W] d2: C T beta Int +Then it is solvable, but its very hard to detect this on the spot. + +It's exactly the same with implicit parameters, except that the +"aggressive" approach would be much easier to implement. + +Note [Fundeps with instances, and equality orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes a delicate interaction that constrains the orientation of +equalities. This one is about fundeps, but the /exact/ same thing arises for +type-family injectivity constraints: see Note [Improvement orientation]. + +doTopFunDepImprovement compares the constraint with all the instance +declarations, to see if we can produce any equalities. E.g + class C2 a b | a -> b + instance C Int Bool +Then the constraint (C Int ty) generates the equality [W] ty ~ Bool. + +There is a nasty corner in #19415 which led to the typechecker looping: + class C s t b | s -> t + instance ... => C (T kx x) (T ky y) Int + T :: forall k. k -> Type + + work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char + where kb0, b0 are unification vars + + ==> {doTopFunDepImprovement: compare work_item with instance, + generate /fresh/ unification variables kfresh0, yfresh0, + emit a new Wanted, and add dwrk to inert set} + + Suppose we emit this new Wanted from the fundep: + [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0) + + ==> {solve that equality kb0 := kfresh0, b0 := yfresh0} + Now kick out dwrk, since it mentions kb0 + But now we are back to the start! Loop! + +NB1: This example relies on an instance that does not satisfy the + coverage condition (although it may satisfy the weak coverage + condition), and hence whose fundeps generate fresh unification + variables. Not satisfying the coverage condition is known to + lead to termination trouble, but in this case it's plain silly. + +NB2: In this example, the third parameter to C ensures that the + instance doesn't actually match the Wanted, so we can't use it to + solve the Wanted + +We solve the problem by (#21703): + + carefully orienting the new Wanted so that all the + freshly-generated unification variables are on the LHS. + + Thus we call unifyWanteds on + T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0) + and /NOT/ + T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0) + +Now we'll unify kfresh0:=kb0, yfresh0:=b0, and all is well. The general idea +is that we want to preferentially eliminate those freshly-generated +unification variables, rather than unifying older variables, which causes +kick-out etc. + +Keeping younger variables on the left also gives very minor improvement in +the compiler performance by having less kick-outs and allocations (-0.1% on +average). Indeed Historical Note [Eliminate younger unification variables] +in GHC.Tc.Utils.Unify describes an earlier attempt to do so systematically, +apparently now in abeyance. + +But this is is a delicate solution. We must take care to /preserve/ +orientation during solving. Wrinkles: + +(W1) We start with + [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0) + Decompose to + [W] kfresh0 ~ kb0 + [W] (yfresh0::kfresh0) ~ (b0::kb0) + Preserve orientation when decomposing!! + +(W2) Suppose we happen to tackle the second Wanted from (W1) + first. Then in canEqCanLHSHetero we emit a /kind/ equality, as + well as a now-homogeneous type equality + [W] kco : kfresh0 ~ kb0 + [W] (yfresh0::kfresh0) ~ (b0::kb0) |> (sym kco) + Preserve orientation in canEqCanLHSHetero!! (Failing to + preserve orientation here was the immediate cause of #21703.) + +(W3) There is a potential interaction with the swapping done by + GHC.Tc.Utils.Unify.swapOverTyVars. We think it's fine, but it's + a slight worry. See especially Note [TyVar/TyVar orientation] in + that module. + +The trouble is that "preserving orientation" is a rather global invariant, +and sometimes we definitely do want to swap (e.g. Int ~ alpha), so we don't +even have a precise statement of what the invariant is. The advantage +of the preserve-orientation plan is that it is extremely cheap to implement, +and apparently works beautifully. + +--- Alternative plan (1) --- +Rather than have an ill-defined invariant, another possiblity is to +elminate those fresh unification variables at birth, when generating +the new fundep-inspired equalities. + +The key idea is to call `instFlexiX` in `emitFunDepWanteds` on only those +type variables that are guaranteed to give us some progress. This means we +have to locally (without calling emitWanteds) identify the type variables +that do not give us any progress. In the above example, we _know_ that +emitting the two wanteds `kco` and `co` is fruitless. + + Q: How do we identify such no-ops? + + 1. Generate a matching substitution from LHS to RHS + ɸ = [kb0 :-> k0, b0 :-> y0] + 2. Call `instFlexiX` on only those type variables that do not appear in the domain of ɸ + ɸ' = instFlexiX ɸ (tvs - domain ɸ) + 3. Apply ɸ' on LHS and then call emitWanteds + unifyWanteds ... (subst ɸ' LHS) RHS + +Why will this work? The matching substitution ɸ will be a best effort +substitution that gives us all the easy solutions. It can be generated with +modified version of `Core/Unify.unify_tys` where we run it in a matching mode +and never generate `SurelyApart` and always return a `MaybeApart Subst` +instead. + +The same alternative plan would work for type-family injectivity constraints: +see Note [Improvement orientation] in GHC.Tc.Solver.Equality. +--- End of Alternative plan (1) --- + +--- Alternative plan (2) --- +We could have a new flavour of TcTyVar (like `TauTv`, `TyVarTv` etc; see GHC.Tc.Utils.TcType.MetaInfo) +for the fresh unification variables introduced by functional dependencies. Say `FunDepTv`. Then in +GHC.Tc.Utils.Unify.swapOverTyVars we could arrange to keep a `FunDepTv` on the left if possible. +Looks possible, but it's one more complication. +--- End of Alternative plan (2) --- + + +--- Historical note: Failed Alternative Plan (3) --- +Previously we used a flag `cc_fundeps` in `CDictCan`. It would flip to False +once we used a fun dep to hint the solver to break and to stop emitting more +wanteds. This solution was not complete, and caused a failures while trying +to solve for transitive functional dependencies (test case: T21703) +-- End of Historical note: Failed Alternative Plan (3) -- + +Note [Do fundeps last] +~~~~~~~~~~~~~~~~~~~~~~ +Consider T4254b: + class FD a b | a -> b where { op :: a -> b } + + instance FD Int Bool + + foo :: forall a b. (a~Int,FD a b) => a -> Bool + foo = op + +(DFL1) Try local fundeps first. + From the ambiguity check on the type signature we get + [G] FD Int b + [W] FD Int beta + Interacting these gives beta:=b; then we start again and solve without + trying fundeps between the new [W] FD Int b and the top-level instance. + If we did, we'd generate [W] b ~ Bool, which fails. + +(DFL2) Try solving from top-level instances before fundeps + From the definition `foo = op` we get + [G] FD Int b + [W] FD Int Bool + We solve this from the top level instance before even trying fundeps. + If we did try fundeps, we'd generate [W] b ~ Bool, which fails. + + +Note [Weird fundeps] +~~~~~~~~~~~~~~~~~~~~ +Consider class Het a b | a -> b where + het :: m (f c) -> a -> m b + + class GHet (a :: * -> *) (b :: * -> *) | a -> b + instance GHet (K a) (K [a]) + instance Het a b => GHet (K a) (K b) + +The two instances don't actually conflict on their fundeps, +although it's pretty strange. So they are both accepted. Now +try [W] GHet (K Int) (K Bool) +This triggers fundeps from both instance decls; + [W] K Bool ~ K [a] + [W] K Bool ~ K beta +And there's a risk of complaining about Bool ~ [a]. But in fact +the Wanted matches the second instance, so we never get as far +as the fundeps. + +#7875 is a case in point. +-} + +doLocalFunDepImprovement :: DictCt -> SolverStage () +-- Add wanted constraints from type-class functional dependencies. +doLocalFunDepImprovement dict_ct@(DictCt { di_ev = work_ev, di_cls = cls }) + = Stage $ + do { inerts <- getInertCans + ; imp <- foldlM add_fds False (findDictsByClass (inert_dicts inerts) cls) + ; if imp then startAgainWith (CDictCan dict_ct) + else continueWith () } + where + work_pred = ctEvPred work_ev + work_loc = ctEvLoc work_ev + + add_fds :: Bool -> DictCt -> TcS Bool + add_fds so_far (DictCt { di_ev = inert_ev }) + | isGiven work_ev && isGiven inert_ev + -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps] + = return so_far + | otherwise + = do { traceTcS "doLocalFunDepImprovement" (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) ]) + + ; unifs <- emitFunDepWanteds work_ev $ + improveFromAnother (derived_loc, inert_rewriters) + inert_pred work_pred + ; return (so_far || unifs) + } + where + inert_pred = ctEvPred inert_ev + inert_loc = ctEvLoc inert_ev + inert_rewriters = ctEvRewriters inert_ev + derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` + ctl_depth inert_loc + , ctl_origin = FunDepOrigin1 work_pred + (ctLocOrigin work_loc) + (ctLocSpan work_loc) + inert_pred + (ctLocOrigin inert_loc) + (ctLocSpan inert_loc) } + +doTopFunDepImprovement :: DictCt -> SolverStage () +-- Try to functional-dependency improvement between the constraint +-- and the top-level instance declarations +-- See Note [Fundeps with instances, and equality orientation] +-- See also Note [Weird fundeps] +doTopFunDepImprovement dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) + | isGiven ev -- No improvement for Givens + = Stage $ continueWith () + | otherwise + = Stage $ + do { traceTcS "try_fundeps" (ppr dict_ct) + ; instEnvs <- getInstEnvs + ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis + ; imp <- emitFunDepWanteds ev fundep_eqns + ; if imp then startAgainWith (CDictCan dict_ct) + else continueWith () } + where + dict_pred = mkClassPred cls xis + dict_loc = ctEvLoc ev + dict_origin = ctLocOrigin dict_loc + + mk_ct_loc :: ClsInst -- The instance decl + -> (CtLoc, RewriterSet) + mk_ct_loc ispec + = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin + inst_pred inst_loc } + , emptyRewriterSet ) + where + inst_pred = mkClassPred cls (is_tys ispec) + inst_loc = getSrcSpan (is_dfun ispec) + + +{- ********************************************************************* +* * +* Superclasses +* * +********************************************************************* -} + +{- Note [The superclass story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to add superclass constraints for two reasons: + +* For givens [G], they give us a route to proof. E.g. + f :: Ord a => a -> Bool + f x = x == x + We get a Wanted (Eq a), which can only be solved from the superclass + of the Given (Ord a). + +* For wanteds [W], they may give useful + functional dependencies. E.g. + class C a b | a -> b where ... + class C a b => D a b where ... + Now a [W] constraint (D Int beta) has (C Int beta) as a superclass + and that might tell us about beta, via C's fundeps. We can get this + by generating a [W] (C Int beta) constraint. We won't use the evidence, + but it may lead to unification. + +See Note [Why adding superclasses can help]. + +For these reasons we want to generate superclass constraints for both +Givens and Wanteds. But: + +* (Minor) they are often not needed, so generating them aggressively + is a waste of time. + +* (Major) if we want recursive superclasses, there would be an infinite + number of them. Here is a real-life example (#10318); + + class (Frac (Frac a) ~ Frac a, + Fractional (Frac a), + IntegralDomain (Frac a)) + => IntegralDomain a where + type Frac a :: * + + Notice that IntegralDomain has an associated type Frac, and one + of IntegralDomain's superclasses is another IntegralDomain constraint. + +So here's the plan: + +1. Eagerly generate superclasses for given (but not wanted) + constraints; see Note [Eagerly expand given superclasses]. + This is done using mkStrictSuperClasses in canDictCt, when + we take a non-canonical Given constraint and cannonicalise it. + + However stop if you encounter the same class twice. That is, + mkStrictSuperClasses expands eagerly, but has a conservative + termination condition: see Note [Expanding superclasses] in GHC.Tc.Utils.TcType. + +2. Solve the wanteds as usual, but do no further expansion of + superclasses for canonical CDictCans in solveSimpleGivens or + solveSimpleWanteds; Note [Danger of adding superclasses during solving] + + However, /do/ continue to eagerly expand superclasses for new /given/ + /non-canonical/ constraints (canDictCt does this). As #12175 + showed, a type-family application can expand to a class constraint, + and we want to see its superclasses for just the same reason as + Note [Eagerly expand given superclasses]. + +3. If we have any remaining unsolved wanteds + (see Note [When superclasses help] in GHC.Tc.Types.Constraint) + try harder: take both the Givens and Wanteds, and expand + superclasses again. See the calls to expandSuperClasses in + GHC.Tc.Solver.simpl_loop and solveWanteds. + + This may succeed in generating (a finite number of) extra Givens, + and extra Wanteds. Both may help the proof. + +3a An important wrinkle: only expand Givens from the current level. + Two reasons: + - We only want to expand it once, and that is best done at + the level it is bound, rather than repeatedly at the leaves + of the implication tree + - We may be inside a type where we can't create term-level + evidence anyway, so we can't superclass-expand, say, + (a ~ b) to get (a ~# b). This happened in #15290. + +4. Go round to (2) again. This loop (2,3,4) is implemented + in GHC.Tc.Solver.simpl_loop. + +The cc_pend_sc field in a CDictCan records whether the superclasses of +this constraint have been expanded. Specifically, in Step 3 we only +expand superclasses for constraints with cc_pend_sc > 0 +(i.e. isPendingScDict holds). +See Note [Expanding Recursive Superclasses and ExpansionFuel] + +Why do we do this? Two reasons: + +* To avoid repeated work, by repeatedly expanding the superclasses of + same constraint, + +* To terminate the above loop, at least in the -XNoUndecidableSuperClasses + case. If there are recursive superclasses we could, in principle, + expand forever, always encountering new constraints. + +When we take a CNonCanonical or CIrredCan, but end up classifying it +as a CDictCan, we set the cc_pend_sc flag to False. + +Note [Superclass loops] +~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + class C a => D a + class D a => C a + +Then, when we expand superclasses, we'll get back to the self-same +predicate, so we have reached a fixpoint in expansion and there is no +point in fruitlessly expanding further. This case just falls out from +our strategy. Consider + f :: C a => a -> Bool + f x = x==x +Then canDictCt gets the [G] d1: C a constraint, and eager emits superclasses +G] d2: D a, [G] d3: C a (psc). (The "psc" means it has its cc_pend_sc has pending +expansion fuel.) +When processing d3 we find a match with d1 in the inert set, and we always +keep the inert item (d1) if possible: see Note [Replacement vs keeping] in +GHC.Tc.Solver.InertSet. So d3 dies a quick, happy death. + +Note [Eagerly expand given superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In step (1) of Note [The superclass story], why do we eagerly expand +Given superclasses by one layer? (By "one layer" we mean expand transitively +until you meet the same class again -- the conservative criterion embodied +in expandSuperClasses. So a "layer" might be a whole stack of superclasses.) +We do this eagerly for Givens mainly because of some very obscure +cases like this: + + instance Bad a => Eq (T a) + + f :: (Ord (T a)) => blah + f x = ....needs Eq (T a), Ord (T a).... + +Here if we can't satisfy (Eq (T a)) from the givens we'll use the +instance declaration; but then we are stuck with (Bad a). Sigh. +This is really a case of non-confluent proofs, but to stop our users +complaining we expand one layer in advance. + +See Note [Instance and Given overlap]. + +We also want to do this if we have + + f :: F (T a) => blah + +where + type instance F (T a) = Ord (T a) + +So we may need to do a little work on the givens to expose the +class that has the superclasses. That's why the superclass +expansion for Givens happens in canDictCt. + +This same scenario happens with quantified constraints, whose superclasses +are also eagerly expanded. Test case: typecheck/should_compile/T16502b +These are handled in canForAllNC, analogously to canDictCt. + +Note [Why adding superclasses can help] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Examples of how adding superclasses can help: + + --- Example 1 + class C a b | a -> b + Suppose we want to solve + [G] C a b + [W] C a beta + Then adding [W] beta~b will let us solve it. + + -- Example 2 (similar but using a type-equality superclass) + class (F a ~ b) => C a b + And try to sllve: + [G] C a b + [W] C a beta + Follow the superclass rules to add + [G] F a ~ b + [W] F a ~ beta + Now we get [W] beta ~ b, and can solve that. + + -- Example (tcfail138) + class L a b | a -> b + class (G a, L a b) => C a b + + instance C a b' => G (Maybe a) + instance C a b => C (Maybe a) a + instance L (Maybe a) a + + When solving the superclasses of the (C (Maybe a) a) instance, we get + [G] C a b, and hence by superclasses, [G] G a, [G] L a b + [W] G (Maybe a) + Use the instance decl to get + [W] C a beta + Generate its superclass + [W] L a beta. Now using fundeps, combine with [G] L a b to get + [W] beta ~ b + which is what we want. + +Note [Danger of adding superclasses during solving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's a serious, but now out-dated example, from #4497: + + class Num (RealOf t) => Normed t + type family RealOf x + +Assume the generated wanted constraint is: + [W] RealOf e ~ e + [W] Normed e + +If we were to be adding the superclasses during simplification we'd get: + [W] RealOf e ~ e + [W] Normed e + [W] RealOf e ~ fuv + [W] Num fuv +==> + e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv + +While looks exactly like our original constraint. If we add the +superclass of (Normed fuv) again we'd loop. By adding superclasses +definitely only once, during canonicalisation, this situation can't +happen. + +Note [Nested quantified constraint superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (typecheck/should_compile/T17202) + + class C1 a + class (forall c. C1 c) => C2 a + class (forall b. (b ~ F a) => C2 a) => C3 a + +Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass +to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a +superclass, as well. But we now must be careful: we cannot just add +(forall c. C1 c) as a Given, because we need to remember g2's context. +That new constraint is Given only when forall b. (b ~ F a) is true. + +It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c), +but that's problematic, because it's nested, and ForAllPred is not capable +of representing a nested quantified constraint. (We could change ForAllPred +to allow this, but the solution in this Note is much more local and simpler.) + +So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c). + +More generally, if we are expanding the superclasses of + g0 :: forall tvs. theta => cls tys +and find a superclass constraint (itself perhaps a quantified constraint) + forall sc_tvs. sc_theta => sc_inner_pred +we must have a selector + sel_id :: forall cls_tvs. cls cls_tvs => forall sc_tvs. sc_theta => sc_inner_pred +and thus build + g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred + g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids. + sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids + +Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the +last bound variables and the last arguments. This avoids the need to produce +the sc_theta_ids at all. So our final construction is + + g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. + sel_id tys (g0 tvs theta_ids) sc_tvs + +(NQCS1) Common case. If theta_ids[] we get just + g_sc = /\ tvs. /\sc_tvs. sel_id tys (g0 tvs) sc_tvs + and can eta-reduce even more to + g_sc = /\ tvs. sel_id tys (g0 tvs) + and if tvs=[] we get the straight superclass selection + g_sc = sel_id tys g0 +-} + +makeSuperClasses :: [Ct] -> TcS [Ct] +-- Returns strict superclasses, transitively, see Note [The superclass story] +-- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType +-- Specifically, for an incoming (C t) constraint, we return all of (C t)'s +-- superclasses, up to /and including/ the first repetition of C +-- +-- Example: class D a => C a +-- class C [a] => D a +-- makeSuperClasses (C x) will return (D x, C [x]) +-- +-- NB: the incoming constraint's superclass will consume a unit of fuel +-- Preconditions on `cts`: 1. They are either `CDictCan` or `CQuantCan` +-- 2. Their fuel (stored in cc_pend_sc or qci_pend_sc) is > 0 +makeSuperClasses cts = concatMapM go cts + where + go (CDictCan (DictCt { di_ev = ev, di_cls = cls, di_tys = tys, di_pend_sc = fuel })) + = assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always + mkStrictSuperClasses fuel ev [] [] cls tys + go (CQuantCan (QCI { qci_body = body_pred, qci_ev = ev, qci_pend_sc = fuel })) + = assertPpr (isClassPred body_pred) (ppr body_pred) $ -- The cts should all have class pred heads + assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0, always + mkStrictSuperClasses fuel ev tvs theta cls tys + where + (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev) + go ct = pprPanic "makeSuperClasses" (ppr ct) + +mkStrictSuperClasses + :: ExpansionFuel -> CtEvidence + -> [TyVar] -> ThetaType -- These two args are non-empty only when taking + -- superclasses of a /quantified/ constraint + -> Class -> [Type] -> TcS [Ct] +-- Return constraints for the strict superclasses of +-- ev :: forall as. theta => cls tys +-- Precondition: fuel > 0 +-- Postcondition: fuel for recursive superclass ct is one unit less than cls fuel +mkStrictSuperClasses fuel ev tvs theta cls tys + = mk_strict_superclasses (consumeFuel fuel) (unitNameSet (className cls)) + ev tvs theta cls tys + +mk_strict_superclasses :: ExpansionFuel -> NameSet -> CtEvidence + -> [TyVar] -> ThetaType + -> Class -> [Type] -> TcS [Ct] +-- Always return the immediate superclasses of (cls tys); +-- and expand their superclasses, provided none of them are in rec_clss +-- nor are repeated +-- The caller of this function is supposed to perform fuel book keeping +-- Precondition: fuel >= 0 +mk_strict_superclasses _ _ _ _ _ cls _ + | isEqualityClass cls -- See (EQC1) in Note [Solving equality classes] + = return [] + +mk_strict_superclasses fuel rec_clss ev@(CtGiven (GivenCt { ctev_evar = evar })) tvs theta cls tys + = -- Given case + do { traceTcS "mk_strict" (ppr ev $$ ppr (ctLocOrigin loc)) + ; concatMapM do_one_given (classSCSelIds cls) } + where + loc = ctEvLoc ev + dict_ids = mkTemplateLocals theta + this_size = pSizeClassPred cls tys + + do_one_given sel_id + | isUnliftedType sc_pred + -- NB: class superclasses are never representation-polymorphic, + -- so isUnliftedType is OK here. + , not (null tvs && null theta) + = -- See Note [Equality superclasses in quantified constraints] + return [] + | otherwise + = do { given_ev <- newGivenEvVar sc_loc $ + mk_given_desc sel_id sc_pred + ; assertFuelPrecondition fuel $ + mk_superclasses fuel rec_clss (CtGiven given_ev) tvs theta sc_pred } + where + sc_pred = classMethodInstTy sel_id tys + + -- See Note [Nested quantified constraint superclasses] + mk_given_desc :: Id -> PredType -> (PredType, EvTerm) + mk_given_desc sel_id sc_pred + = (swizzled_pred, EvExpr swizzled_evterm) + where + (sc_tvs, sc_rho) = splitForAllTyCoVars sc_pred + (sc_theta, sc_inner_pred) = splitFunTys sc_rho + + all_tvs = tvs `chkAppend` sc_tvs + all_theta = theta `chkAppend` (map scaledThing sc_theta) + swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred + + -- evar :: forall tvs. theta => cls tys + -- sel_id :: forall cls_tvs. cls cls_tvs + -- => forall sc_tvs. sc_theta => sc_inner_pred + -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred + swizzled_evterm + | null tvs, null theta -- See wrinkle (NQCS1) + = Var sel_id `mkTyApps` tys `App` evId evar + | otherwise + = mkLams all_tvs $ mkLams dict_ids $ + Var sel_id `mkTyApps` tys + `App` (evId evar `mkVarApps` (tvs ++ dict_ids)) + `mkVarApps` sc_tvs + + sc_loc | isCTupleClass cls = loc + | otherwise = loc { ctl_origin = mk_sc_origin (ctLocOrigin loc) } + -- isCTupleClass: we don't want tuples to mess up the size calculations + -- of Note [Solving superclass constraints]. For tuple predicates, this + -- matters, because their size can be large, and we don't want to add a + -- big class to the size of the dictionaries in the chain. When we get + -- down to a base predicate, we'll include its size. See #10335. + -- See Note [Solving tuple constraints] + + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + -- for explanation of GivenSCOrigin and Note [Replacement vs keeping] in + -- GHC.Tc.Solver.InertSet for why we need depths + mk_sc_origin :: CtOrigin -> CtOrigin + mk_sc_origin (GivenSCOrigin skol_info sc_depth already_blocked) + = GivenSCOrigin skol_info (sc_depth + 1) + (already_blocked || newly_blocked skol_info) + + mk_sc_origin (GivenOrigin skol_info) + = -- These cases do not already have a superclass constraint: depth starts at 1 + GivenSCOrigin skol_info 1 (newly_blocked skol_info) + + mk_sc_origin other_orig = pprPanic "Given constraint without given origin" $ + ppr evar $$ ppr other_orig + + newly_blocked (InstSkol _ head_size) = isJust (this_size `ltPatersonSize` head_size) + newly_blocked _ = False + +-- Wanted case +mk_strict_superclasses fuel rec_clss + (CtWanted (WantedCt { ctev_pred = pty, ctev_loc = loc0, ctev_rewriters = rws })) + tvs theta cls tys + | all noFreeVarsOfType tys + = return [] -- Wanteds with no variables yield no superclass constraints. + -- See Note [Improvement from Ground Wanteds] + + | otherwise -- Wanted case, just add Wanted superclasses + -- that can lead to improvement. + = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $ + concatMapM do_one (immSuperClasses cls tys) + where + loc = loc0 `updateCtLocOrigin` WantedSuperclassOrigin pty + + do_one sc_pred + = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred) + ; sc_ev <- newWantedNC loc rws sc_pred + ; mk_superclasses fuel rec_clss (CtWanted sc_ev) [] [] sc_pred } + +{- Note [Improvement from Ground Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose class C b a => D a b +and consider + [W] D Int Bool +Is there any point in emitting [W] C Bool Int? No! The only point of +emitting superclass constraints for W constraints is to get +improvement, extra unifications that result from functional +dependencies. See Note [Why adding superclasses can help] above. + +But no variables means no improvement; case closed. +-} + +mk_superclasses :: ExpansionFuel -> NameSet -> CtEvidence + -> [TyVar] -> ThetaType -> PredType -> TcS [Ct] +-- Return this constraint, plus its superclasses, if any +-- Precondition: fuel >= 0 +mk_superclasses fuel rec_clss ev tvs theta pred + | ClassPred cls tys <- classifyPredType pred + = assertFuelPrecondition fuel $ + mk_superclasses_of fuel rec_clss ev tvs theta cls tys + + | otherwise -- Superclass is not a class predicate + = return [mkNonCanonical ev] + +mk_superclasses_of :: ExpansionFuel -> NameSet -> CtEvidence + -> [TyVar] -> ThetaType -> Class -> [Type] + -> TcS [Ct] +-- Always return this class constraint, +-- and expand its superclasses +-- Precondition: fuel >= 0 +mk_superclasses_of fuel rec_clss ev tvs theta cls tys + | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys) + ; assertFuelPrecondition fuel $ return [mk_this_ct fuel] } + -- cc_pend_sc of returning ct = fuel + | otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys + , ppr (isCTupleClass cls) + , ppr rec_clss + ]) + ; sc_cts <- assertFuelPrecondition fuel $ + mk_strict_superclasses fuel rec_clss' ev tvs theta cls tys + ; return (mk_this_ct doNotExpand : sc_cts) } + -- doNotExpand: we have expanded this cls's superclasses, so + -- exhaust the associated constraint's fuel, + -- to avoid duplicate work + where + cls_nm = className cls + loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss + -- Tuples never contribute to recursion, and can be nested + rec_clss' = rec_clss `extendNameSet` cls_nm + + mk_this_ct :: ExpansionFuel -> Ct + -- We can't use CNonCanonical here because we need to tradk the fuel + mk_this_ct fuel | null tvs, null theta + = CDictCan (DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = fuel }) + -- NB: If there is a loop, we cut off, so we have not + -- added the superclasses, hence cc_pend_sc = fuel + | otherwise + = CQuantCan (QCI { qci_tvs = tvs, qci_theta = theta + , qci_body = mkClassPred cls tys + , qci_ev = ev, qci_pend_sc = fuel }) + + +{- Note [Equality superclasses in quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#15359, #15593, #15625) + f :: (forall a. theta => a ~ b) => stuff + +It's a bit odd to have a local, quantified constraint for `(a~b)`, +but some people want such a thing (see the tickets). And for +Coercible it is definitely useful + f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q))) + => stuff + +Moreover it's not hard to arrange; we just need to look up /equality/ +constraints in the quantified-constraint environment, which we do in +GHC.Tc.Solver.Equality.tryQCsEqCt. + +There is a wrinkle though, in the case where 'theta' is empty, so +we have + f :: (forall a. a~b) => stuff + +Now, potentially, the superclass machinery kicks in, in +makeSuperClasses, giving us a a second quantified constraint + (forall a. a ~# b) +BUT this is an unboxed value! And nothing has prepared us for +dictionary "functions" that are unboxed. Actually it does just +about work, but the simplifier ends up with stuff like + case (/\a. eq_sel d) of df -> ...(df @Int)... +and fails to simplify that any further. + +So for now we simply decline to take superclasses in the quantified +case. Instead we have a special case in GHC.Tc.Solver.Equality.tryQCsEqCt +which looks for primitive equalities specially in the quantified +constraints. + +See also Note [Evidence for quantified constraints] in GHC.Core.Predicate. +-} diff --git a/GHC/Tc/Solver/Equality.hs b/GHC/Tc/Solver/Equality.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Equality.hs @@ -0,0 +1,3467 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Tc.Solver.Equality( + solveEquality + ) where + + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Solver.Solve( trySolveImplication ) + +import GHC.Tc.Solver.Irred( solveIrred ) +import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) +import GHC.Tc.Solver.Rewrite +import GHC.Tc.Solver.Monad +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Types( findFunEqsByTyCon ) +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.TcType +import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe ) +import GHC.Tc.Instance.FunDeps( FunDepEqn(..) ) +import qualified GHC.Tc.Utils.Monad as TcM + +import GHC.Core.Type +import GHC.Core.Predicate +import GHC.Core.Class +import GHC.Core.DataCon ( dataConName ) +import GHC.Core.TyCon +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.Unify( tcUnifyTyForInjectivity ) +import GHC.Core.FamInstEnv ( FamInstEnvs, FamInst(..), apartnessCheck + , lookupFamInstEnvByTyCon ) +import GHC.Core + +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set( anyVarSet ) +import GHC.Types.Name.Reader +import GHC.Types.Basic + +import GHC.Builtin.Types.Literals ( tryInteractTopFam, tryInteractInertFam ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Monad + +import GHC.Data.Pair +import GHC.Data.Bag +import Control.Monad +import Data.Maybe ( isJust, isNothing ) +import Data.List ( zip4 ) + +import qualified Data.Semigroup as S +import Data.Bifunctor ( bimap ) +import Data.Void( Void ) + +{- ********************************************************************* +* * +* Equalities +* * +************************************************************************ + +Note [Canonicalising equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to canonicalise an equality, we look at the structure of the +two types at hand, looking for similarities. A difficulty is that the +types may look dissimilar before rewriting but similar after rewriting. +However, we don't just want to jump in and rewrite right away, because +this might be wasted effort. So, after looking for similarities and failing, +we rewrite and then try again. Of course, we don't want to loop, so we +track whether or not we've already rewritten. + +It is conceivable to do a better job at tracking whether or not a type +is rewritten, but this is left as future work. (Mar '15) + +Note [Decomposing FunTy] +~~~~~~~~~~~~~~~~~~~~~~~~ +can_eq_nc' may attempt to decompose a FunTy that is un-zonked. This +means that we may very well have a FunTy containing a type of some +unknown kind. For instance, we may have, + + FunTy (a :: k) Int + +Where k is a unification variable. So the calls to splitRuntimeRep_maybe may +fail (returning Nothing). In that case we'll fall through, zonk, and try again. +Zonking should fill the variable k, meaning that decomposition will succeed the +second time around. + +Also note that we require the FunTyFlag to match. This will stop +us decomposing + (Int -> Bool) ~ (Show a => blah) +It's as if we treat (->) and (=>) as different type constructors, which +indeed they are! +-} + +solveEquality :: CtEvidence -> EqRel -> Type -> Type + -> SolverStage Void +solveEquality ev eq_rel ty1 ty2 + = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2 + ; mb_canon <- canonicaliseEquality ev eq_rel ty1' ty2' + + ; case mb_canon of { + + -- An IrredCt equality may be insoluble; but maybe not! + -- E.g. m a ~R# m b is not canonical, but may be + -- solved by a quantified constraint (T15290) + -- See Note [Looking up primitive equalities in quantified constraints] + Left irred_ct -> do { tryQCsIrredEqCt irred_ct + ; solveIrred irred_ct } ; + + Right eq_ct -> do { tryInertEqs eq_ct + ; tryFunDeps eq_rel eq_ct + ; tryQCsEqCt eq_ct + ; simpleStage (updInertEqs eq_ct) + ; stopWithStage (eqCtEvidence eq_ct) "Kept inert EqCt" } } } + +updInertEqs :: EqCt -> TcS () +updInertEqs eq_ct + = do { kickOutRewritable (KOAfterAdding (eqCtLHS eq_ct)) (eqCtFlavourRole eq_ct) + ; tc_lvl <- getTcLevel + ; updInertCans (addEqToCans tc_lvl eq_ct) } + + +{- ********************************************************************* +* * +* zonkEqTypes +* * +********************************************************************* -} + +--------------------------------- +-- | Compare types for equality, while zonking as necessary. Gives up +-- as soon as it finds that two types are not equal. +-- This is quite handy when some unification has made two +-- types in an inert Wanted to be equal. We can discover the equality without +-- rewriting, which is sometimes very expensive (in the case of type functions). +-- In particular, this function makes a ~20% improvement in test case +-- perf/compiler/T5030. +-- +-- Returns either the (partially zonked) types in the case of +-- inequality, or the one type in the case of equality. canEqReflexive is +-- a good next step in the 'Right' case. Returning 'Left' is always safe. +-- +-- NB: This does *not* look through type synonyms. In fact, it treats type +-- synonyms as rigid constructors. In the future, it might be convenient +-- to look at only those arguments of type synonyms that actually appear +-- in the synonym RHS. But we're not there yet. +zonkEqTypes :: CtEvidence -> EqRel -> TcType -> TcType -> SolverStage (Pair TcType) +zonkEqTypes ev eq_rel ty1 ty2 + = Stage $ do { res <- go ty1 ty2 + ; case res of + Left pair -> continueWith pair + Right ty -> canEqReflexive ev eq_rel ty } + where + go :: TcType -> TcType -> TcS (Either (Pair TcType) TcType) + go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2 + go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2 + go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1 + + -- We handle FunTys explicitly here despite the fact that they could also be + -- treated as an application. Why? Well, for one it's cheaper to just look + -- at two types (the argument and result types) than four (the argument, + -- result, and their RuntimeReps). Also, we haven't completely zonked yet, + -- so we may run into an unzonked type variable while trying to compute the + -- RuntimeReps of the argument and result types. This can be observed in + -- testcase tc269. + go (FunTy af1 w1 arg1 res1) (FunTy af2 w2 arg2 res2) + | af1 == af2 + , eqType w1 w2 + = do { res_a <- go arg1 arg2 + ; res_b <- go res1 res2 + ; return $ combine_rev (FunTy af1 w1) res_b res_a } + + go ty1@(FunTy {}) ty2 = bale_out ty1 ty2 + go ty1 ty2@(FunTy {}) = bale_out ty1 ty2 + + go ty1 ty2 + | Just (tc1, tys1) <- splitTyConAppNoView_maybe ty1 + , Just (tc2, tys2) <- splitTyConAppNoView_maybe ty2 + = if tc1 == tc2 && tys1 `equalLength` tys2 + -- Crucial to check for equal-length args, because + -- we cannot assume that the two args to 'go' have + -- the same kind. E.g go (Proxy * (Maybe Int)) + -- (Proxy (*->*) Maybe) + -- We'll call (go (Maybe Int) Maybe) + -- See #13083 + then tycon tc1 tys1 tys2 + else bale_out ty1 ty2 + + -- If you are temppted to add a case for AppTy/AppTy, be careful + -- See Note [zonkEqTypes and the PKTI] + + go ty1@(LitTy lit1) (LitTy lit2) + | lit1 == lit2 + = return (Right ty1) + + go ty1 ty2 = bale_out ty1 ty2 + -- We don't handle more complex forms here + + bale_out ty1 ty2 = return $ Left (Pair ty1 ty2) + + tyvar :: SwapFlag -> TcTyVar -> TcType + -> TcS (Either (Pair TcType) TcType) + -- Try to do as little as possible, as anything we do here is redundant + -- with rewriting. In particular, no need to zonk kinds. That's why + -- we don't use the already-defined zonking functions + tyvar swapped tv ty + = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> give_up + Indirect ty' -> do { trace_indirect tv ty' + ; unSwap swapped go ty' ty } } + _ -> give_up + where + give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty + + tyvar_tyvar tv1 tv2 + | tv1 == tv2 = return (Right (mkTyVarTy tv1)) + | otherwise = do { (ty1', progress1) <- quick_zonk tv1 + ; (ty2', progress2) <- quick_zonk tv2 + ; if progress1 || progress2 + then go ty1' ty2' + else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) } + + trace_indirect tv ty + = traceTcS "Following filled tyvar (zonk_eq_types)" + (ppr tv <+> equals <+> ppr ty) + + quick_zonk tv = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> return (TyVarTy tv, False) + Indirect ty' -> do { trace_indirect tv ty' + ; return (ty', True) } } + _ -> return (TyVarTy tv, False) + + -- This happens for type families, too. But recall that failure + -- here just means to try harder, so it's OK if the type function + -- isn't injective. + tycon :: TyCon -> [TcType] -> [TcType] + -> TcS (Either (Pair TcType) TcType) + tycon tc tys1 tys2 + = do { results <- zipWithM go tys1 tys2 + ; return $ case combine_results results of + Left tys -> Left (mkTyConApp tc <$> tys) + Right tys -> Right (mkTyConApp tc tys) } + + combine_results :: [Either (Pair TcType) TcType] + -> Either (Pair [TcType]) [TcType] + combine_results = bimap (fmap reverse) reverse . + foldl' (combine_rev (:)) (Right []) + + -- combine (in reverse) a new result onto an already-combined result + combine_rev :: (a -> b -> c) + -> Either (Pair b) b + -> Either (Pair a) a + -> Either (Pair c) c + combine_rev f (Left list) (Left elt) = Left (f <$> elt <*> list) + combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list) + combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys) + combine_rev f (Right tys) (Right ty) = Right (f ty tys) + + +{- Note [zonkEqTypes and the PKTI] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because `zonkEqTypes` does /partial/ zonking, we need to be very careful +to maintain the Purely Kinded Type Invariant: see GHC.Tc.Gen/HsType +HsNote [The Purely Kinded Type Invariant (PKTI)]. + +In #26256 we try to solve this equality constraint: + Int :-> Maybe Char ~# k0 Int (m0 Char) +where m0 and k0 are unification variables, and + m0 :: Type -> Type +It happens that m0 was already unified + m0 := (w0 :: kappa) +where kappa is another unification variable that is also already unified: + kappa := Type->Type. +So the original type satisifed the PKTI, but a partially-zonked form + k0 Int (w0 Char) +does not!! (This a bit reminiscent of Note [mkAppTyM].) + +The solution I have adopted is simply to make `zonkEqTypes` bale out on `AppTy`. +After all, it's only supposed to be a quick hack to see if two types are already +equal; if we bale out we'll just get into the "proper" canonicaliser. + +The only tricky thing about this approach is that it relies on /omitting/ +code -- for the AppTy/AppTy case! Hence this Note +-} + +{- ********************************************************************* +* * +* canonicaliseEquality +* * +********************************************************************* -} + +canonicaliseEquality + :: CtEvidence -> EqRel + -> Type -> Type -- LHS and RHS + -> SolverStage (Either IrredCt EqCt) +-- Nota Bene: `ty1` and `ty2` may be more-zonked than `ev` +-- This matters when calling mkSelCo, in canDecomposableTyConAppOK and +-- canDecomposableFunTy, when we need the precondition of mkSelCo to +-- hold. + +canonicaliseEquality ev eq_rel ty1 ty2 + = Stage $ do { traceTcS "canonicaliseEquality" $ + vcat [ ppr ev, ppr eq_rel, ppr ty1, ppr ty2 ] + ; rdr_env <- getGlobalRdrEnvTcS + ; fam_insts <- getFamInstEnvs + ; can_eq_nc False rdr_env fam_insts ev eq_rel ty1 ty1 ty2 ty2 } + +can_eq_nc + :: Bool -- True => both input types are rewritten + -> GlobalRdrEnv -- needed to see which newtypes are in scope + -> FamInstEnvs -- needed to unwrap data instances + -> CtEvidence + -> EqRel + -> Type -> Type -- LHS, after and before type-synonym expansion, resp + -> Type -> Type -- RHS, after and before type-synonym expansion, resp + -> TcS (StopOrContinue (Either IrredCt EqCt)) + +-- See Note [Unifying type synonyms] in GHC.Core.Unify +can_eq_nc _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2 + | tc1 == tc2 + = canEqReflexive ev eq_rel ty1 + +-- Expand synonyms first; see Note [Type synonyms and canonicalization] +can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | Just ty1' <- coreView ty1 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 + | Just ty2' <- coreView ty2 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2 + +-- need to check for reflexivity in the ReprEq case. +-- See Note [Eager reflexivity check] +-- Check only when rewritten because the zonk_eq_types check in canEqNC takes +-- care of the non-rewritten case. +can_eq_nc True _rdr_env _envs ev ReprEq ty1 _ ty2 _ + | ty1 `tcEqType` ty2 + = canEqReflexive ev ReprEq ty1 + +-- When working with ReprEq, unwrap newtypes. +-- See Note [Unwrap newtypes first] +-- This must be above the TyVarTy case, in order to guarantee (TyEq:N) +can_eq_nc _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | ReprEq <- eq_rel + , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1 + = can_eq_newtype_nc rdr_env envs ev NotSwapped ty1 stuff1 ty2 ps_ty2 + + | ReprEq <- eq_rel + , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 + = can_eq_newtype_nc rdr_env envs ev IsSwapped ty2 stuff2 ty1 ps_ty1 + +-- Then, get rid of casts +can_eq_nc rewritten rdr_env envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 + | isNothing (canEqLHS_maybe ty2) + = -- See (EIK3) in Note [Equalities with heterogeneous kinds] + canEqCast rewritten rdr_env envs ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 +can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ + | isNothing (canEqLHS_maybe ty1) + = -- See (EIK3) in Note [Equalities with heterogeneous kinds] + canEqCast rewritten rdr_env envs ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 + +---------------------- +-- Otherwise try to decompose +---------------------- + +-- Literals +can_eq_nc _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ + | l1 == l2 + = do { setEvBindIfWanted ev EvCanonical (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1) + ; stopWith ev "Equal LitTy" } + +-- Decompose FunTy: (s -> t) and (c => t) +-- NB: don't decompose (Int -> blah) ~ (Show a => blah) +can_eq_nc _rewritten _rdr_env _envs ev eq_rel + ty1@(FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1 + ty2@(FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2 + | af1 == af2 -- See Note [Decomposing FunTy] + = canDecomposableFunTy ev eq_rel af1 (ty1,am1,ty1a,ty1b) (ty2,am2,ty2a,ty2b) + +-- Decompose type constructor applications +-- NB: we have expanded type synonyms already +can_eq_nc rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _ + | Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1 + , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2 + -- tcSplitTyConApp_maybe: we want to catch e.g. Maybe Int ~ (Int -> Int) + -- here for better error messages rather than decomposing into AppTys; + -- hence not using a direct match on TyConApp + + , not (isTypeFamilyTyCon tc1 || isTypeFamilyTyCon tc2) + -- A type family at the top of LHS or RHS: we want to fall through + -- to the canonical-LHS cases (look for canEqLHS_maybe) + + -- See (TC1) in Note [Canonicalising TyCon/TyCon equalities] + , let role = eqRelRole eq_rel + both_generative = isGenerativeTyCon tc1 role && isGenerativeTyCon tc2 role + , rewritten || both_generative + = canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2) + +can_eq_nc _rewritten _rdr_env _envs ev eq_rel + s1@ForAllTy{} _ + s2@ForAllTy{} _ + = can_eq_nc_forall ev eq_rel s1 s2 + +-- See Note [Canonicalising type applications] about why we require rewritten types +-- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families +-- NB: Only decompose AppTy for nominal equality. +-- See Note [Decomposing AppTy equalities] +can_eq_nc True _rdr_env _envs ev NomEq ty1 _ ty2 _ + | Just (t1, s1) <- tcSplitAppTy_maybe ty1 + , Just (t2, s2) <- tcSplitAppTy_maybe ty2 + = can_eq_app ev t1 s1 t2 s2 + +------------------- +-- Can't decompose. +------------------- + +-- No similarity in type structure detected. Rewrite and try again. +can_eq_nc False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 + = -- Rewrite the two types and try again + 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 + ; traceTcS "can_eq_nc: go round again" (ppr new_ev $$ ppr xi1 $$ ppr xi2) + ; can_eq_nc True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } + +---------------------------- +-- Look for a canonical LHS. +-- Only rewritten types end up below here. +---------------------------- + +-- NB: pattern match on rewritten=True: we want only rewritten types sent to canEqLHS +-- This means we've rewritten any variables and reduced any type family redexes +-- See also Note [No top-level newtypes on RHS of representational equalities] + +can_eq_nc True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | Just can_eq_lhs1 <- canEqLHS_maybe ty1 + = do { traceTcS "can_eq1" (ppr ty1 $$ ppr ty2) + ; canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2 } + + | Just can_eq_lhs2 <- canEqLHS_maybe ty2 + = do { traceTcS "can_eq2" (ppr ty1 $$ ppr ty2) + ; canEqCanLHS ev eq_rel IsSwapped can_eq_lhs2 ps_ty2 ty1 ps_ty1 } + + -- If the type is TyConApp tc1 args1, then args1 really can't be less + -- than tyConArity tc1. It could be *more* than tyConArity, but then we + -- should have handled the case as an AppTy. That case only fires if + -- _both_ sides of the equality are AppTy-like... but if one side is + -- AppTy-like and the other isn't (and it also isn't a variable or + -- saturated type family application, both of which are handled by + -- can_eq_nc), we're in a failure mode and can just fall through. + +---------------------------- +-- Fall-through. Give up. +---------------------------- + +-- We've rewritten and the types don't match. Give up. +can_eq_nc True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 + = do { traceTcS "can_eq_nc catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) + ; case eq_rel of -- See Note [Unsolved equalities] + ReprEq -> finishCanWithIrred ReprEqReason ev + NomEq -> finishCanWithIrred ShapeMismatchReason ev } + -- No need to call canEqSoftFailure/canEqHardFailure because they + -- rewrite, and the types involved here are already rewritten + + +{- Note [Unsolved equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an unsolved equality like + (a b ~R# Int) +that is not necessarily insoluble! Maybe 'a' will turn out to be a newtype. +So we want to make it a potentially-soluble Irred not an insoluble one. +Missing this point is what caused #15431 +-} + +--------------------------------- +can_eq_nc_forall :: CtEvidence -> EqRel + -> Type -> Type -- LHS and RHS + -> TcS (StopOrContinue (Either IrredCt EqCt)) +-- See Note [Solving forall equalities] + +can_eq_nc_forall ev eq_rel s1 s2 + | CtWanted (WantedCt { ctev_dest = orig_dest, ctev_loc = loc }) <- ev + = do { let (bndrs1, phi1, bndrs2, phi2) = split_foralls s1 s2 + flags1 = binderFlags bndrs1 + flags2 = binderFlags bndrs2 + + ; if eq_rel == NomEq && not (all2 eqForAllVis flags1 flags2) -- Note [ForAllTy and type equality] + then do { traceTcS "Forall failure: visibility-mismatch" $ + vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 + , ppr flags1, ppr flags2 ] + ; canEqHardFailure ev s1 s2 } + + else + do { let free_tvs = tyCoVarsOfTypes [s1,s2] + empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs + skol_info_anon = UnifyForAllSkol phi1 + ; skol_info <- mkSkolemInfo skol_info_anon + ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $ + binderVars bndrs1 + + ; let phi1' = substTy subst1 phi1 + + -- Unify the kinds, extend the substitution + go :: UnifyEnv -> [TcTyVar] -> Subst + -> [TyVarBinder] -> [TyVarBinder] -> TcM.TcM TcCoercion + go uenv (skol_tv:skol_tvs) subst2 (bndr1:bndrs1) (bndr2:bndrs2) + = do { let tv2 = binderVar bndr2 + vis1 = binderFlag bndr1 + vis2 = binderFlag bndr2 + + -- Unify the kinds, at Nominal role + -- See (SF1) in Note [Solving forall equalities] + ; kind_co <- uType (uenv `setUEnvRole` Nominal) + (tyVarKind skol_tv) + (substTy subst2 (tyVarKind tv2)) + + ; let subst2' = extendTvSubstAndInScope subst2 tv2 + (mkCastTy (mkTyVarTy skol_tv) kind_co) + -- skol_tv is already in the in-scope set, but the + -- free vars of kind_co are not; hence "...AndInScope" + ; co <- go uenv skol_tvs subst2' bndrs1 bndrs2 + + ; return (mkNakedForAllCo skol_tv vis1 vis2 kind_co co)} + -- mkNaked.. because these types are not zonked, and the + -- assertions in mkForAllCo may fail without that zonking + + -- Done: unify phi1 ~ phi2 + go uenv [] subst2 bndrs1 bndrs2 + = assert (null bndrs1 && null bndrs2) $ + uType uenv phi1' (substTyUnchecked subst2 phi2) + + go _ _ _ _ _ = panic "can_eq_nc_forall" -- case (s:ss) [] + + init_subst2 = mkEmptySubst (substInScopeSet subst1) + + ; traceTcS "Generating wanteds" (ppr s1 $$ ppr s2) + + -- Generate the constraints that live in the body of the implication + -- See (SF5) in Note [Solving forall equalities] + ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ + unifyForAllBody ev (eqRelRole eq_rel) $ \uenv -> + go uenv skol_tvs init_subst2 bndrs1 bndrs2 + + -- Solve the implication right away, using `trySolveImplication` + -- See (SF6) in Note [Solving forall equalities] + ; traceTcS "Trying to solve the implication" (ppr s1 $$ ppr s2 $$ ppr wanteds) + ; ev_binds_var <- newNoTcEvBinds + ; solved <- trySolveImplication $ + (implicationPrototype (ctLocEnv loc)) + { ic_tclvl = lvl + , ic_binds = ev_binds_var + , ic_info = skol_info_anon + , ic_warn_inaccessible = False + , ic_skols = skol_tvs + , ic_given = [] + , ic_wanted = emptyWC { wc_simple = wanteds } } + + ; if solved + then do { zonked_all_co <- zonkCo all_co + -- ToDo: explain this zonk + ; setWantedEq orig_dest zonked_all_co + ; stopWith ev "Polytype equality: solved" } + else canEqSoftFailure IrredShapeReason ev s1 s2 } } + + | otherwise + = do { traceTcS "Omitting decomposition of given polytype equality" $ + pprEq s1 s2 -- See Note [Do not decompose Given polytype equalities] + ; stopWith ev "Discard given polytype equality" } + + where + split_foralls :: TcType -> TcType + -> ( [ForAllTyBinder], TcType + , [ForAllTyBinder], TcType) + -- Split matching foralls; stop when the foralls don't match + -- See #22537. See (SF3) in Note [Solving forall equalities] + -- Postcondition: the two lists of binders returned have the same length + split_foralls s1 s2 + | Just (bndr1, s1') <- splitForAllForAllTyBinder_maybe s1 + , Just (bndr2, s2') <- splitForAllForAllTyBinder_maybe s2 + = let !(bndrs1, phi1, bndrs2, phi2) = split_foralls s1' s2' + in (bndr1:bndrs1, phi1, bndr2:bndrs2, phi2) + split_foralls s1 s2 = ([], s1, [], s2) + +{- Note [Solving forall equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To solve an equality between foralls + [W] (forall a. t1) ~ (forall b. t2) +the basic plan is simple: use `trySolveImplication` to solve the +implication constraint + [W] forall a. { t1 ~ (t2[a/b]) } + +The evidence we produce is a ForAllCo; see the typing rule for +ForAllCo in Note [ForAllCo] in GHC.Tc.TyCo.Rep. + +There are lots of wrinkles of course: + +(SF1) We must check the kinds match (at Nominal role). So from + [W] (forall (a:ka). t1) ~ (forall (b:kb). t2) + we actually generate the implication + [W] forall (a:ka). { ka ~N kb, t1 ~ t2[a/b] } + These kind equalities are generated by the `go` loop in `can_eq_nc_forall`. + Why Nominal role? See the typing rule for ForAllCo. + +(SF2) At Nominal role we must check that the visiblities match. + For example + [W] (forall a. a -> a) ~N (forall b -> b -> b) + should fail. At /Representational/ role we allow this; see the + typing rule for ForAllCo, mentioned above. + +(SF3) Consider this (#22537) + newtype P a = MkP (forall c. (a,c)) + [W] (forall a. P a) ~R (forall a b. (a,b)) + The number of foralls does not line up. But if we just unwrap the outer + forall a, we'll get + [W] P a ~R forall b. (a,b) + Now unwrap the newtype + [W] (forall c. (a,c)) ~R (forall b. (a,b)) + and all is good. + + Conclusion: Don't fail if the number of foralls does not line up. Instead, + handle as many binders as are visibly apparent on both sides, and then keep + going with unification. See `split_foralls` in `can_eq_nc_forall`. In the + above example, at Representational role, the unifier will proceed to unwrap + the newtype on the RHS and we'll end up back in can_eq_nc_forall. + +(SF4) Remember also that we might have forall z (a:z). blah + so in that `go` loop, we must proceed one binder at a time (#13879) + +(SF5) Rather than manually gather the constraints needed in the body of the + implication, we use `uType`. That way we can solve some of them on the fly, + especially Refl ones. We use the `unifyForAllBody` wrapper for `uType`, + because we want to /gather/ the equality constraint (to put in the implication) + rather than /emit/ them into the monad, as `wrapUnifierTcS` does. + +(SF6) We solve the implication on the spot, using `trySolveImplication`. In + the past we instead generated an `Implication` to be solved later. Nice in + some ways but it added complexity: + - We needed a `wl_implics` field of `WorkList` to collect + these emitted implications + - The types of `solveSimpleWanteds` and friends were more complicated + - Trickily, an `EvFun` had to contain an `EvBindsVar` ref-cell, which made + `evVarsOfTerm` harder. Now an `EvFun` just contains the bindings. + The disadvantage of solve-on-the-spot is that if we fail we are simply + left with an unsolved (forall a. blah) ~ (forall b. blah), and it may + not be clear /why/ we couldn't solve it. But on balance the error messages + improve: it is easier to undertand that + (forall a. a->a) ~ (forall b. b->Int) + is insoluble than it is to understand a message about matching `a` with `Int`. +-} + +{- Note [Unwrap newtypes first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Decomposing newtype equalities] + +Consider + newtype N m a = MkN (m a) +N will get a conservative, Nominal role for its second parameter 'a', +because it appears as an argument to the unknown 'm'. Now consider + [W] N Maybe a ~R# N Maybe b + +If we /decompose/, we'll get + [W] a ~N# b + +But if instead we /unwrap/ we'll get + [W] Maybe a ~R# Maybe b +which in turn gives us + [W] a ~R# b +which is easier to satisfy. + +Conclusion: we must unwrap newtypes before decomposing them. This happens +in `can_eq_newtype_nc` + +We did flirt with making the /rewriter/ expand newtypes, rather than +doing it in `can_eq_newtype_nc`. But with recursive newtypes we want +to be super-careful about expanding! + + newtype A = MkA [A] -- Recursive! + + f :: A -> [A] + f = coerce + +We have [W] A ~R# [A]. If we rewrite [A], it'll expand to + [[[[[...]]]]] +and blow the reduction stack. See Note [Newtypes can blow the stack] +in GHC.Tc.Solver.Rewrite. But if we expand only the /top level/ of +both sides, we get + [W] [A] ~R# [A] +which we can, just, solve by reflexivity. + +So we simply unwrap, on-demand, at top level, in `can_eq_newtype_nc`. + +This is all very delicate. There is a real risk of a loop in the type checker +with recursive newtypes -- but I think we're doomed to do *something* +delicate, as we're really trying to solve for equirecursive type +equality. Bottom line for users: recursive newtypes do not play well with type +inference for representational equality. See also Section 5.3.1 and 5.3.4 of +"Safe Zero-cost Coercions for Haskell" (JFP 2016). + +See also Note [Decomposing newtype equalities]. + +--- Historical side note --- + +We flirted with doing /both/ unwrap-at-top-level /and/ rewrite-deeply; +see #22519. But that didn't work: see discussion in #22924. Specifically +we got a loop with a minor variation: + f2 :: a -> [A] + f2 = coerce + +Note [Eager reflexivity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype X = MkX (Int -> X) + +and + + [W] X ~R X + +Naively, we would start unwrapping X and end up in a loop. Instead, +we do this eager reflexivity check. This is necessary only for representational +equality because the rewriter technology deals with the similar case +(recursive type families) for nominal equality. + +Note that this check does not catch all cases, but it will catch the cases +we're most worried about, types like X above that are actually inhabited. + +Here's another place where this reflexivity check is key: +Consider trying to prove (f a) ~R (f a). The AppTys in there can't +be decomposed, because representational equality isn't congruent with respect +to AppTy. So, when canonicalising the equality above, we get stuck and +would normally produce a CIrredCan. However, we really do want to +be able to solve (f a) ~R (f a). So, in the representational case only, +we do a reflexivity check. + +(This would be sound in the nominal case, but unnecessary, and I [Richard +E.] am worried that it would slow down the common case.) + + Note [Newtypes can blow the stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype X = MkX (Int -> X) + newtype Y = MkY (Int -> Y) + +and now wish to prove + + [W] X ~R Y + +This Wanted will loop, expanding out the newtypes ever deeper looking +for a solid match or a solid discrepancy. Indeed, there is something +appropriate to this looping, because X and Y *do* have the same representation, +in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized +coercion will ever witness it. This loop won't actually cause GHC to hang, +though, because we check our depth in `can_eq_newtype_nc`. +-} + +------------------------ +-- | We're able to unwrap a newtype. Update the bits accordingly. +can_eq_newtype_nc :: GlobalRdrEnv -> FamInstEnvs + -> CtEvidence -- ^ :: ty1 ~ ty2 + -> SwapFlag + -> TcType -- ^ ty1 + -> ((Bag GlobalRdrElt, TcCoercion), TcType) -- ^ :: ty1 ~ ty1' + -> TcType -- ^ ty2 + -> TcType -- ^ ty2, with type synonyms + -> TcS (StopOrContinue (Either IrredCt EqCt)) +can_eq_newtype_nc rdr_env envs ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2 + = do { traceTcS "can_eq_newtype_nc" $ + vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ] + + -- Check for blowing our stack, and increase the depth + -- See Note [Newtypes can blow the stack] + ; let loc = ctEvLoc ev + ev' = ev `setCtEvLoc` bumpCtLocDepth loc + ; checkReductionDepth loc ty1 + + -- Next, we record uses of newtype constructors, since coercing + -- through newtypes is tantamount to using their constructors. + ; recordUsedGREs gres + + ; let redn1 = mkReduction co1 ty1' + + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev' swapped + redn1 (mkReflRedn Representational ps_ty2) + + ; can_eq_nc False rdr_env envs new_ev ReprEq ty1' ty1' ty2 ps_ty2 } + +--------- +-- ^ Decompose a type application. +-- All input types must be rewritten. See Note [Canonicalising type applications] +-- Nominal equality only! +can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2 + -> Xi -> Xi -- s1 t1 + -> Xi -> Xi -- s2 t2 + -> TcS (StopOrContinue (Either IrredCt EqCt)) + +-- AppTys only decompose for nominal equality, so this case just leads +-- to an irreducible constraint; see typecheck/should_compile/T10494 +-- See Note [Decomposing AppTy equalities] +can_eq_app ev s1 t1 s2 t2 + | CtWanted (WantedCt { ctev_dest = dest }) <- ev + = do { traceTcS "can_eq_app" (vcat [ text "s1:" <+> ppr s1, text "t1:" <+> ppr t1 + , text "s2:" <+> ppr s2, text "t2:" <+> ppr t2 + , text "vis:" <+> ppr (isNextArgVisible s1) ]) + ; (co,_,_) <- wrapUnifierTcS ev Nominal $ \uenv -> + -- Unify arguments t1/t2 before function s1/s2, because + -- the former have smaller kinds, and hence simpler error messages + -- c.f. GHC.Tc.Utils.Unify.uType (go_app) + do { let arg_env = updUEnvLoc uenv (adjustCtLoc (isNextArgVisible s1) False) + ; co_t <- uType arg_env t1 t2 + ; co_s <- uType uenv s1 s2 + ; return (mkAppCo co_s co_t) } + ; setWantedEq dest co + ; stopWith ev "Decomposed [W] AppTy" } + + -- If there is a ForAll/(->) mismatch, the use of the Left coercion + -- below is ill-typed, potentially leading to a panic in splitTyConApp + -- Test case: typecheck/should_run/Typeable1 + -- We could also include this mismatch check above (for W and D), but it's slow + -- and we'll get a better error message not doing it + | s1k `mismatches` s2k + = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2) + + | CtGiven (GivenCt { ctev_evar = evar }) <- ev + = do { let co = mkCoVarCo evar + co_s = mkLRCo CLeft co + co_t = mkLRCo CRight co + ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 + , evCoercion co_s ) + ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 + , evCoercion co_t ) + ; emitWorkNC [CtGiven evar_t] + ; startAgainWith (mkNonCanonical $ CtGiven evar_s) } + + where + loc = ctEvLoc ev + + s1k = typeKind s1 + s2k = typeKind s2 + + k1 `mismatches` k2 + = isForAllTy k1 && not (isForAllTy k2) + || not (isForAllTy k1) && isForAllTy k2 + +----------------------- +-- | Break apart an equality over a casted type +-- looking like (ty1 |> co1) ~ ty2 (modulo a swap-flag) +canEqCast :: Bool -- are both types rewritten? + -> GlobalRdrEnv -> FamInstEnvs + -> CtEvidence + -> EqRel + -> SwapFlag + -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 + -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCast rewritten rdr_env envs ev eq_rel swapped ty1 co1 ty2 ps_ty2 + = do { traceTcS "Decomposing cast" (vcat [ ppr ev + , ppr ty1 <+> text "|>" <+> ppr co1 + , ppr ps_ty2 ]) + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkGReflLeftRedn role ty1 co1) + (mkReflRedn role ps_ty2) + ; can_eq_nc rewritten rdr_env envs new_ev eq_rel ty1 ty1 ty2 ps_ty2 } + where + role = eqRelRole eq_rel + +------------------------ +canTyConApp :: CtEvidence -> EqRel + -> Bool -- True <=> both TyCons are generative + -> (Type,TyCon,[TcType]) + -> (Type,TyCon,[TcType]) + -> TcS (StopOrContinue (Either IrredCt EqCt)) +-- See Note [Decomposing TyConApp equalities] +-- Neither tc1 nor tc2 is a saturated funTyCon, nor a type family +-- But they can be data families. +canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2) + | tc1 == tc2 + , tys1 `equalLength` tys2 + = do { inerts <- getInertSet + ; if can_decompose inerts + then canDecomposableTyConAppOK ev eq_rel tc1 (ty1,tys1) (ty2,tys2) + else assert (eq_rel == ReprEq) $ + canEqSoftFailure ReprEqReason ev ty1 ty2 } + + -- See Note [Skolem abstract data] in GHC.Core.Tycon + | tyConSkolem tc1 || tyConSkolem tc2 + = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) + ; finishCanWithIrred AbstractTyConReason ev } + + -- Different TyCons + | NomEq <- eq_rel + = canEqHardFailure ev ty1 ty2 + + -- Different TyCons, eq_rel = ReprEq + -- See (TC2) and (TC3) in + -- Note [Canonicalising TyCon/TyCon equalities] + | both_generative + = canEqHardFailure ev ty1 ty2 + + | otherwise + = canEqSoftFailure ReprEqReason ev ty1 ty2 + where + -- See Note [Decomposing TyConApp equalities] + -- and Note [Decomposing newtype equalities] + can_decompose inerts + = isInjectiveTyCon tc1 (eqRelRole eq_rel) + || (assert (eq_rel == ReprEq) $ + -- assert: isInjectiveTyCon is always True for Nominal except + -- for type synonyms/families, neither of which happen here + -- Moreover isInjectiveTyCon is True for Representational + -- for algebraic data types. So we are down to newtypes + -- and data families. + ctEvFlavour ev == Wanted && noGivenNewtypeReprEqs tc1 inerts) + -- See Note [Decomposing newtype equalities] (EX2) + +{- Note [Canonicalising TyCon/TyCon equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type family TF a where TF Char = Bool + data family DF a + newtype instance DF Bool = MkDF Int + +Suppose we are canonicalising [W] Int ~R# DF (TF a). Then + +(TC1) We might have an inert Given (a ~# Char), so if we rewrote the wanted + (i.e. went around again in `can_eq_nc` with `rewritten`=True, we'd get + [W] Int ~R# DF Bool + and then the `tcTopNormaliseNewTypeTF_maybe` call would fire and + we'd unwrap the newtype. So we must do that "go round again" bit. + Hence the complicated guard (rewritten || both_generative) in `can_eq_nc`. + +(TC2) If we can't rewrite `a` yet, we'll finish with an unsolved + [W] Int ~R# DF (TF a) + in the inert set. But we must use canEqSoftFailure, not canEqHardFailure, + because it might be solved "later" when we learn more about `a`. + Hence the use of `both_generative` in `canTyConApp`. + +(TC3) Here's another example: + [G] Age ~R# Int + where Age's constructor is not in scope. We don't want to report + an "inaccessible code" error in the context of this Given! So again + we want `canEqSoftFailure`. + + For example, see typecheck/should_compile/T10493, repeated here: + import Data.Ord (Down) -- no constructor + foo :: Coercible (Down Int) Int => Down Int -> Int + foo = coerce + + That should compile, but only because we use canEqSoftFailure and + not canEqHardFailure. + +Note [Fast path when decomposing TyConApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see (T s1 t1 ~ T s2 t2), then we can just decompose to + (s1 ~ s2, t1 ~ t2) +and push those back into the work list. But if + s1 = K k1 s2 = K k2 +then we will just decompose s1~s2, and it might be better to +do so on the spot. An important special case is where s1=s2, +and we get just Refl. + +So canDecomposableTyConAppOK uses wrapUnifierTcS etc to short-cut +that work. See also Note [Work-list ordering]. + +Note [Decomposing TyConApp equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + [G/W] T ty1 ~r T ty2 +Can we decompose it, and replace it by + [G/W] ty1 ~r' ty2 +and if so what role is r'? (In this Note, all the "~" are primitive +equalities "~#", but I have dropped the noisy "#" symbols.) Lots of +background in the paper "Safe zero-cost coercions for Haskell". + +This Note covers the topic for + * Datatypes + * Newtypes + * Data families +For the rest: + * Type synonyms: are always expanded + * Type families: see Note [Decomposing type family applications] + * AppTy: see Note [Decomposing AppTy equalities]. + +---- Roles of the decomposed constraints ---- +For a start, the role r' will always be defined like this: + * If r=N then r' = N + * If r=R then r' = role of T's first argument + +For example: + data TR a = MkTR a -- Role of T's first arg is Representational + data TN a = MkTN (F a) -- Role of T's first arg is Nominal + +The function tyConRolesX :: Role -> TyCon -> [Role] gets the argument +role r' for a TyCon T at role r. E.g. + tyConRolesX Nominal TR = [Nominal] + tyConRolesX Representational TR = [Representational] + +---- Soundness and completeness ---- +For Givens, for /soundness/ of decomposition we need, forall ty1,ty2: + T ty1 ~r T ty2 ===> ty1 ~r' ty2 +Here "===>" means "implies". That is, given evidence for (co1 : T ty1 ~r T co2) +we can produce evidence for (co2 : ty1 ~r' ty2). But in the solver we +/replace/ co1 with co2 in the inert set, and we don't want to lose any proofs +thereby. So for /completeness/ of decomposition we also need the reverse: + ty1 ~r' ty2 ===> T ty1 ~r T ty2 + +For Wanteds, for /soundness/ of decomposition we need: + ty1 ~r' ty2 ===> T ty1 ~r T ty2 +because if we do decompose we'll get evidence (co2 : ty1 ~r' ty2) and +from that we want to derive evidence (T co2 : T ty1 ~r T ty2). +For /completeness/ of decomposition we need the reverse implication too, +else we may decompose to a new proof obligation that is stronger than +the one we started with. See Note [Decomposing newtype equalities]. + +---- Injectivity ---- +When do these bi-implications hold? In one direction it is easy. +We /always/ have + ty1 ~r' ty2 ===> T ty1 ~r T ty2 +This is the CO_TYCONAPP rule of the paper (Fig 5); see also the +TyConAppCo case of GHC.Core.Lint.lintCoercion. + +In the other direction, we have + T ty1 ~r T ty2 ==> ty1 ~r' ty2 if T is /injective at role r/ +This is the very /definition/ of injectivity: injectivity means result +is the same => arguments are the same, modulo the role shift. +See comments on GHC.Core.TyCon.isInjectiveTyCon. This is also +the CO_NTH rule in Fig 5 of the paper, except in the paper only +newtypes are non-injective at representation role, so the rule says +"H is not a newtype". + +Injectivity is a bit subtle: + Nominal Representational + Datatype YES YES + Newtype YES NO{1} + Data family YES NO{2} + +{1} Consider newtype N a = MkN (F a) -- Arg has Nominal role + Is it true that (N t1) ~R (N t2) ==> t1 ~N t2 ? + No, absolutely not. E.g. + type instance F Int = Int; type instance F Bool = Char + Then (N Int) ~R (N Bool), by unwrapping, but we don't want Int~Char! + + See Note [Decomposing newtype equalities] + +{2} We must treat data families precisely like newtypes, because of the + possibility of newtype instances. See also + Note [Decomposing newtype equalities]. See #10534 and + test case typecheck/should_fail/T10534. + +---- Takeaway summary ----- +For sound and complete decomposition, we simply need injectivity; +that is for isInjectiveTyCon to be true: + +* At Nominal role, isInjectiveTyCon is True for all the TyCons we are + considering in this Note: datatypes, newtypes, and data families. + +* For Givens, injectivity is necessary for soundness; completeness has no + side conditions. + +* For Wanteds, soundness has no side conditions; but injectivity is needed + for completeness. See Note [Decomposing newtype equalities] + +This is implemented in `can_decompose` in `canTyConApp`; it looks at +injectivity, just as specified above. + +Note [Work-list ordering] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider decomposing a TyCon equality + + (0) [W] T k_fresh (t1::k_fresh) ~ T k1 (t2::k1) + +This gives rise to 2 equalities in the solver worklist + + (1) [W] k_fresh ~ k1 + (2) [W] t1::k_fresh ~ t2::k1 + +We would like to solve (1) before looking at (2), so that we don't end +up in the complexities of canEqLHSHetero. To do this: + +* `canDecomposableTyConAppOK` calls `uType` on the arguments + /left-to-right/. See the call to zipWith4M in that function. + +* `uType` keeps the bag of emitted constraints in the same + left-to-right order. See the use of `snocBag` in `uType_defer`. + +* `wrapUnifierTcS` adds the bag of deferred constraints from + `do_unifications` to the work-list using `extendWorkListChildEqs`. + +* `extendWorkListChildEqs` and `selectWorkItem` together arrange that the + list of constraints given to `extendWorkListChildEqs` is processed in + left-to-right order. + +This is not a very big deal. It reduces the number of solver steps +in the test RaeJobTalk from 1830 to 1815, a 1% reduction. But still, +it doesn't cost anything either. + +Note [Decomposing type family applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose we have + [G/W] (F ty1) ~r (F ty2) +This is handled by the TyFamLHS/TyFamLHS case of canEqCanLHS2. + +We never decompose to + [G/W] ty1 ~r' ty2 + +Instead + +* For Givens we do nothing. Injective type families have no corresponding + evidence of their injectivity, so we cannot decompose an + injective-type-family Given. + +* For Wanteds, for the Nominal role only, we emit new Wanteds rather like + functional dependencies, for each injective argument position. + + E.g type family F a b -- injective in first arg, but not second + [W] (F s1 t1) ~N (F s2 t2) + Emit new Wanteds + [W] s1 ~N s2 + But retain the existing, unsolved constraint. + +Note [Decomposing newtype equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note also applies to data families, which we treat like +newtype in case of 'newtype instance'. + +As Note [Decomposing TyConApp equalities] describes, if N is injective +at role r, we can do this decomposition? + [G/W] (N ty1) ~r (N ty2) to [G/W] ty1 ~r' ty2 + +For a Given with r=R, the answer is a solid NO: newtypes are not injective at +representational role, and we must not decompose, or we lose soundness. +Example is wrinkle {1} in Note [Decomposing TyConApp equalities]. + +For a Wanted with r=R, since newtypes are not injective at representational +role, decomposition is sound, but we may lose completeness. Nevertheless, +if the newtype is abstract (so can't be unwrapped) we can only solve +the equality by (a) using a Given or (b) decomposition. If (a) is impossible +(e.g. no Givens) then (b) is safe albeit potentially incomplete. + +There are two ways in which decomposing (N ty1) ~r (N ty2) could be incomplete: + +* Incompleteness example (EX1): unwrap first + newtype Nt a = MkNt (Id a) + type family Id a where Id a = a + + [W] Nt Int ~R Nt Age + + Because of its use of a type family, Nt's parameter will get inferred to + have a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, + which is unsatisfiable. Unwrapping, though, leads to a solution. + + CONCLUSION: always unwrap newtypes before attempting to decompose + them. This is done in can_eq_nc. Of course, we can't unwrap if the data + constructor isn't in scope. See Note [Unwrap newtypes first]. + +* Incompleteness example (EX2): prioritise Nominal equalities. See #24887 + data family D a + data instance D Int = MkD1 (D Char) + data instance D Bool = MkD2 (D Char) + Now suppose we have + [W] g1: D Int ~R# D a + [W] g2: a ~# Bool + If we solve g2 first, giving a:=Bool, then we can solve g1 easily: + D Int ~R# D Char ~R# D Bool + by newtype unwrapping. + + BUT: if we instead attempt to solve g1 first, we can unwrap the LHS (only) + leaving [W] D Char ~#R D Bool + If we decompose now, we'll get (Char ~R# Bool), which is insoluble. + + CONCLUSION: prioritise nominal equalites in the work list. + See Note [Prioritise equalities] in GHC.Tc.Solver.InertSet. + +* Incompleteness example (EX3): check available Givens + newtype Nt a = Mk Bool -- NB: a is not used in the RHS, + type role Nt representational -- but the user gives it an R role anyway + + [G] Nt t1 ~R Nt t2 + [W] Nt alpha ~R Nt beta + + We *don't* want to decompose to [W] alpha ~R beta, because it's possible + that alpha and beta aren't representationally equal. And if we figure + out (elsewhere) that alpha:=t1 and beta:=t2, we can solve the Wanted + from the Given. This is somewhat similar to the question of overlapping + Givens for class constraints: see Note [Instance and Given overlap] in + GHC.Tc.Solver.Dict. + + CONCLUSION: don't decompose [W] N s ~R N t, if there are any Given + equalities that could later solve it. + + But what precisely does it mean to say "any Given equalities that could + later solve it"? It's tricky! + + * In #22924 we had + [G] f a ~R# a [W] Const (f a) a ~R# Const a a + where Const is an abstract newtype. If we decomposed the newtype, we + could solve. Not-decomposing on the grounds that (f a ~R# a) might turn + into (Const (f a) a ~R# Const a a) seems a bit silly. + + * In #22331 we had + [G] N a ~R# N b [W] N b ~R# N a + (where N is abstract so we can't unwrap). Here we really /don't/ want to + decompose, because the /only/ way to solve the Wanted is from that Given + (with a Sym). + + * In #22519 we had + [G] a <= b [W] IO Age ~R# IO Int + + (where IO is abstract so we can't unwrap, and newtype Age = Int; and (<=) + is a type-level comparison on Nats). Here we /must/ decompose, despite the + existence of an Irred Given, or we will simply be stuck. (Side note: We + flirted with deep-rewriting of newtypes (see discussion on #22519 and + !9623) but that turned out not to solve #22924, and also makes type + inference loop more often on recursive newtypes.) + + * In #26020 we had a /quantified/ constraint + forall x. Coercible (N t1) (N t2) + and (roughly) [W] N t1 ~R# N t2 + That quantified constraint can solve the Wanted, so don't decompose! + + The currently-implemented compromise is this: + We decompose [W] N s ~R# N t unless there is + - an Irred [G] N s' ~ N t' + - a quantified [G] forall ... => N s' ~ N t' + that is, a Given equality with both sides headed with N. + See the call to `noGivenNewtypeReprEqs` in `canTyConApp`. + + This is not perfect. In principle a Given like [G] (a b) ~ (c d), or + even just [G] c, could later turn into N s ~ N t. But since the free + vars of a Given are skolems, or at least untouchable unification + variables, this is extremely unlikely to happen. + + Another worry: there could, just, be a CDictCan with some + un-expanded equality superclasses; but only in some very obscure + recursive-superclass situations. + + Yet another approach (!) is described in + Note [Decomposing newtypes a bit more aggressively]. + +Remember: decomposing Wanteds is always /sound/. This Note is +only about /completeness/. + +Note [Decomposing newtypes a bit more aggressively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +IMPORTANT: the ideas in this Note are *not* implemented. Instead, the +current approach is detailed in Note [Decomposing newtype equalities] +and Note [Unwrap newtypes first]. +For more details about the ideas in this Note see + * GHC propoosal: https://github.com/ghc-proposals/ghc-proposals/pull/549 + * issue #22441 + * discussion on !9282. + +Consider [G] c, [W] (IO Int) ~R (IO Age) +where IO is abstract, and + newtype Age = MkAge Int -- Not abstract +With the above rules, if there any Given Irreds, +the Wanted is insoluble because we can't decompose it. But in fact, +if we look at the defn of IO, roughly, + newtype IO a = State# -> (State#, a) +we can see that decomposing [W] (IO Int) ~R (IO Age) to + [W] Int ~R Age +definitely does not lose completeness. Why not? Because the role of +IO's argment is representational. Hence: + + DecomposeNewtypeIdea: + decompose [W] (N s1 .. sn) ~R (N t1 .. tn) + if the roles of all N's arguments are representational + +If N's arguments really /are/ representational this will not lose +completeness. Here "really are representational" means "if you expand +all newtypes in N's RHS, we'd infer a representational role for each +of N's type variables in that expansion". See Note [Role inference] +in GHC.Tc.TyCl.Utils. + +But the user might /override/ a phantom role with an explicit role +annotation, and then we could (obscurely) get incompleteness. +Consider + + module A( silly, T ) where + newtype T a = MkT Int + type role T representational -- Override phantom role + + silly :: Coercion (T Int) (T Bool) + silly = Coercion -- Typechecks by unwrapping the newtype + + data Coercion a b where -- Actually defined in Data.Type.Coercion + Coercion :: Coercible a b => Coercion a b + + module B where + import A + f :: T Int -> T Bool + f = case silly of Coercion -> coerce + +Here the `coerce` gives [W] (T Int) ~R (T Bool) which, if we decompose, +we'll get stuck with (Int ~R Bool). Instead we want to use the +[G] (T Int) ~R (T Bool), which will be in the Irreds. + +Summary: we could adopt (DecomposeNewtypeIdea), at the cost of a very +obscure incompleteness (above). But no one is reporting a problem from +the lack of decompostion, so we'll just leave it for now. This long +Note is just to record the thinking for our future selves. + +Note [Decomposing AppTy equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For AppTy all the same questions arise as in +Note [Decomposing TyConApp equalities]. We have + + s1 ~r s2, t1 ~N t2 ==> s1 t1 ~r s2 t2 (rule CO_APP) + s1 t1 ~N s2 t2 ==> s1 ~N s2, t1 ~N t2 (CO_LEFT, CO_RIGHT) + +In the first of these, why do we need Nominal equality in (t1 ~N t2)? +See {2} below. + +For sound and complete solving, we need both directions to decompose. So: +* At nominal role, all is well: we have both directions. +* At representational role, decomposition of Givens is unsound (see {1} below), + and decomposition of Wanteds is incomplete. + +Here is an example of the incompleteness for Wanteds: + + [G] g1 :: a ~R b + [W] w1 :: Maybe b ~R alpha a + [W] w2 :: alpha ~N Maybe + +Suppose we see w1 before w2. If we decompose, using AppCo to prove w1, we get + + w1 := AppCo w3 w4 + [W] w3 :: Maybe ~R alpha + [W] w4 :: b ~N a + +Note that w4 is *nominal*. A nominal role here is necessary because AppCo +requires a nominal role on its second argument. (See {2} for an example of +why.) Now we are stuck, because w4 is insoluble. On the other hand, if we +see w2 first, setting alpha := Maybe, all is well, as we can decompose +Maybe b ~R Maybe a into b ~R a. + +Another example: + newtype Phant x = MkPhant Int + [W] w1 :: Phant Int ~R alpha Bool + [W] w2 :: alpha ~ Phant + +If we see w1 first, decomposing would be disastrous, as we would then try +to solve Int ~ Bool. Instead, spotting w2 allows us to simplify w1 to become + [W] w1' :: Phant Int ~R Phant Bool + +which can then (assuming MkPhant is in scope) be simplified to Int ~R Int, +and all will be well. See also Note [Unwrap newtypes first]. + +Bottom line: +* Always decompose AppTy at nominal role: can_eq_app +* Never decompose AppTy at representational role (neither Given nor Wanted): + the lack of an equation in can_eq_nc + +Extra points +{1} Decomposing a Given AppTy over a representational role is simply + unsound. For example, if we have co1 :: Phant Int ~R a Bool (for + the newtype Phant, above), then we surely don't want any relationship + between Int and Bool, lest we also have co2 :: Phant ~ a around. + +{2} The role on the AppCo coercion is a conservative choice, because we don't + know the role signature of the function. For example, let's assume we could + have a representational role on the second argument of AppCo. Then, consider + + data G a where -- G will have a nominal role, as G is a GADT + MkG :: G Int + newtype Age = MkAge Int + + co1 :: G ~R a -- by assumption + co2 :: Age ~R Int -- by newtype axiom + co3 = AppCo co1 co2 :: G Age ~R a Int -- by our broken AppCo + + and now co3 can be used to cast MkG to have type G Age, in violation of + the way GADTs are supposed to work (which is to use nominal equality). +-} + +canDecomposableTyConAppOK :: CtEvidence -> EqRel + -> TyCon + -> (Type,[TcType]) -> (Type,[TcType]) + -> TcS (StopOrContinue a) +-- Precondition: tys1 and tys2 are the same finite length, hence "OK" +canDecomposableTyConAppOK ev eq_rel tc (ty1,tys1) (ty2,tys2) + = assert (tys1 `equalLength` tys2) $ + do { traceTcS "canDecomposableTyConAppOK" + (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2) + ; case ev of + CtWanted (WantedCt { ctev_dest = dest }) + -- new_locs and tc_roles are both infinite, so we are + -- guaranteed that cos has the same length as tys1 and tys2 + -- See Note [Fast path when decomposing TyConApps] + -> do { (co, _, _) <- wrapUnifierTcS ev role $ \uenv -> + do { cos <- zipWith4M (u_arg uenv) new_locs tc_roles tys1 tys2 + -- zipWith4M: see Note [Work-list ordering] + ; return (mkTyConAppCo role tc cos) } + ; setWantedEq dest co } + + CtGiven (GivenCt { ctev_evar = evar }) + | let pred_ty = mkEqPred eq_rel ty1 ty2 + ev_co = mkCoVarCo (setVarType evar pred_ty) + -- setVarType: satisfy Note [mkSelCo precondition] in Coercion.hs + -- Remember: ty1/ty2 may be more fully zonked than evar + -- See the call to canonicaliseEquality in solveEquality. + -> emitNewGivens loc + [ (r, mkSelCo (SelTyCon i r) ev_co) + | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] + , r /= Phantom + , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] + + ; stopWith ev "Decomposed TyConApp" } + + where + loc = ctEvLoc ev + role = eqRelRole eq_rel + + u_arg uenv arg_loc arg_role = uType arg_env + where + arg_env = uenv `setUEnvRole` arg_role + `updUEnvLoc` const arg_loc + + -- Infinite, to allow for over-saturated TyConApps + tc_roles = tyConRoleListX role tc + + -- Add nuances to the location during decomposition: + -- * if the argument is a kind argument, remember this, so that error + -- messages say "kind", not "type". This is determined based on whether + -- the corresponding tyConBinder is named (that is, dependent) + -- * if the argument is invisible, note this as well, again by + -- looking at the corresponding binder + -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't + -- do either of these changes. (Forgetting to do so led to #16188) + -- + -- NB: infinite in length + new_locs = [ adjustCtLocTyConBinder bndr loc + | bndr <- tyConBinders tc ] + ++ repeat loc + +canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag + -> (Type,Type,Type,Type) -- (fun_ty,multiplicity,arg,res) + -> (Type,Type,Type,Type) -- (fun_ty,multiplicity,arg,res) + -> TcS (StopOrContinue a) +canDecomposableFunTy ev eq_rel af f1@(ty1,m1,a1,r1) f2@(ty2,m2,a2,r2) + = do { traceTcS "canDecomposableFunTy" + (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2) + ; case ev of + CtWanted (WantedCt { ctev_dest = dest }) + -> do { (co, _, _) <- wrapUnifierTcS ev Nominal $ \ uenv -> + do { let mult_env = uenv `updUEnvLoc` toInvisibleLoc + `setUEnvRole` funRole role SelMult + ; mult <- uType mult_env m1 m2 + ; arg <- uType (uenv `setUEnvRole` funRole role SelArg) a1 a2 + ; res <- uType (uenv `setUEnvRole` funRole role SelRes) r1 r2 + ; return (mkNakedFunCo role af mult arg res) } + ; setWantedEq dest co } + + CtGiven (GivenCt { ctev_evar = evar }) + | let pred_ty = mkEqPred eq_rel ty1 ty2 + ev_co = mkCoVarCo (setVarType evar pred_ty) + -- setVarType: satisfy Note [mkSelCo precondition] in Coercion.hs + -- Remember: ty1/ty2 may be more fully zonked than evar + -- See the call to canonicaliseEquality in solveEquality. + -> emitNewGivens loc + [ (funRole role fs, mkSelCo (SelFun fs) ev_co) + | fs <- [SelMult, SelArg, SelRes] ] + + ; stopWith ev "Decomposed TyConApp" } + + where + loc = ctEvLoc ev + role = eqRelRole eq_rel + +-- | Call canEqSoftFailure when canonicalizing an equality fails, but if the +-- equality is representational, there is some hope for the future. +canEqSoftFailure :: CtIrredReason -> CtEvidence -> TcType -> TcType + -> TcS (StopOrContinue (Either IrredCt a)) +canEqSoftFailure reason ev ty1 ty2 + = do { (redn1, rewriters1) <- rewrite ev ty1 + ; (redn2, rewriters2) <- rewrite ev ty2 + -- We must rewrite the types before putting them in the + -- inert set, so that we are sure to kick them out when + -- new equalities become available + ; traceTcS "canEqSoftFailure" $ + vcat [ ppr ev, ppr redn1, ppr redn2 ] + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 + ; finishCanWithIrred reason new_ev } + +-- | Call when canonicalizing an equality fails with utterly no hope. +canEqHardFailure :: CtEvidence -> TcType -> TcType + -> TcS (StopOrContinue (Either IrredCt a)) +-- See Note [Make sure that insolubles are fully rewritten] +canEqHardFailure ev ty1 ty2 + = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2) + ; (redn1, rewriters1) <- rewriteForErrors ev ty1 + ; (redn2, rewriters2) <- rewriteForErrors ev ty2 + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 + ; finishCanWithIrred ShapeMismatchReason new_ev } + +{- +Note [Canonicalising type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (s1 t1) ~ ty2, how should we proceed? +The simple thing is to see if ty2 is of form (s2 t2), and +decompose. + +However, over-eager decomposition gives bad error messages +for things like + a b ~ Maybe c + e f ~ p -> q +Suppose (in the first example) we already know a~Array. Then if we +decompose the application eagerly, yielding + a ~ Maybe + b ~ c +we get an error "Can't match Array ~ Maybe", +but we'd prefer to get "Can't match Array b ~ Maybe c". + +So instead can_eq_wanted_app rewrites the LHS and RHS, in the hope of +replacing (a b) by (Array b), before using try_decompose_app to +decompose it. + +Note [Make sure that insolubles are fully rewritten] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When an equality fails, we still want to rewrite the equality +all the way down, so that it accurately reflects + (a) the mutable reference substitution in force at start of solving + (b) any ty-binds in force at this point in solving +See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet. +And if we don't do this there is a bad danger that +GHC.Tc.Solver.applyTyVarDefaulting will find a variable +that has in fact been substituted. + +Note [Do not decompose Given polytype equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? +No -- what would the evidence look like? So instead we simply discard +this given evidence. + +Note [No top-level newtypes on RHS of representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we're in this situation: + + work item: [W] c1 : a ~R b + inert: [G] c2 : b ~R Id a + +where + newtype Id a = Id a + +We want to make sure canEqCanLHS sees [W] a ~R a, after b is rewritten +and the Id newtype is unwrapped. This is assured by requiring only rewritten +types in canEqCanLHS *and* having the newtype-unwrapping check above +the tyvar check in can_eq_nc. + +Note that this only applies to saturated applications of newtype TyCons, as +we can't rewrite an unsaturated application. See for example T22310, where +we ended up with: + + newtype Compose f g a = ... + + [W] t[tau] ~# Compose Foo Bar + +Note [Put touchable variables on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticket #10009, a very nasty example: + + f :: (UnF (F b) ~ b) => F b -> () + + g :: forall a. (UnF (F a) ~ a) => a -> () + g _ = f (undefined :: F a) + +For g we get [G] g1 : UnF (F a) ~ a + [W] w1 : UnF (F beta) ~ beta + [W] w2 : F a ~ F beta + +g1 is canonical (CEqCan). It is oriented as above because a is not touchable. +See canEqTyVarFunEq. + +w1 is similarly canonical, though the occurs-check in canEqTyVarFunEq is key +here. + +w2 is canonical. But which way should it be oriented? As written, we'll be +stuck. When w2 is added to the inert set, nothing gets kicked out: g1 is +a Given (and Wanteds don't rewrite Givens), and w2 doesn't mention the LHS +of w2. We'll thus lose. + +But if w2 is swapped around, to + + [W] w3 : F beta ~ F a + +then we'll kick w1 out of the inert set (it mentions the LHS of w3). We then +rewrite w1 to + + [W] w4 : UnF (F a) ~ beta + +and then, using g1, to + + [W] w5 : a ~ beta + +at which point we can unify and go on to glory. (This rewriting actually +happens all at once, in the call to rewrite during canonicalisation.) + +But what about the new LHS makes it better? It mentions a variable (beta) +that can appear in a Wanted -- a touchable metavariable never appears +in a Given. On the other hand, the original LHS mentioned only variables +that appear in Givens. We thus choose to put variables that can appear +in Wanteds on the left. + +Ticket #12526 is another good example of this in action. + +-} + +--------------------- +canEqCanLHS :: CtEvidence -- ev :: lhs ~ rhs + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs (or, if swapped, rhs) + -> TcType -- lhs: pretty lhs, already rewritten + -> TcType -> TcType -- rhs: already rewritten + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 + | k1 `tcEqType` k2 + = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 + + | otherwise + = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2 + + where + k1 = canEqLHSKind lhs1 + k2 = typeKind xi2 + + +{- +Note [Kind Equality Orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While in theory [W] x ~ y and [W] y ~ x ought to give us the same behaviour, in +practice it does not. See Note [Fundeps with instances, and equality +orientation] where this is discussed at length. As a rule of thumb: we keep +the newest unification variables on the left of the equality. See also +Note [Improvement orientation]. + +In particular, `canEqCanLHSHetero` produces the following constraint equalities + +[X] (xi1 :: ki1) ~ (xi2 :: ki2) + --> [X] kco :: ki1 ~ ki2 + [X] co : xi1 :: ki1 ~ (xi2 |> sym kco) :: ki1 + +Note that the types in the LHS of the new constraints are the ones that were on the LHS of +the original constraint. + +--- Historical note --- +We prevously used to flip the kco to avoid using a sym in the cast + +[X] (xi1 :: ki1) ~ (xi2 :: ki2) + --> [X] kco :: ki2 ~ ki1 + [X] co : xi1 :: ki1 ~ (xi2 |> kco) :: ki1 + +But this sent solver in an infinite loop (see #19415). +-- End of historical note -- +-} + +canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2) + -- (or reversed if SwapFlag=IsSwapped) + -> EqRel -> SwapFlag + -> CanEqLHS -> TcType -- xi1 + -> TcKind -- ki1 + -> TcType -> TcType -- xi2 + -> TcKind -- ki2 + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 +-- See Note [Equalities with heterogeneous kinds] +-- See Note [Kind Equality Orientation] + +-- NB: preserve left-to-right orientation!! See wrinkle (W2) in +-- Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Dict +-- NotSwapped: +-- ev :: (lhs1:ki1) ~r# (xi2:ki2) +-- kind_co :: k11 ~# ki2 -- Same orientation as ev +-- new_ev :: lhs1 ~r# (xi2 |> sym kind_co) +-- Swapped +-- ev :: (xi2:ki2) ~r# (lhs1:ki1) +-- kind_co :: ki2 ~# ki1 -- Same orientation as ev +-- new_ev :: (xi2 |> kind_co) ~r# lhs1 +-- Note that we need the `sym` when we are /not/ swapped; hence `mk_sym_co` + + = case ev of + CtGiven (GivenCt { ctev_evar = evar, ctev_loc = loc }) + -> do { let kind_co = mkKindCo (mkCoVarCo evar) + pred_ty = unSwap swapped mkNomEqPred ki1 ki2 + kind_loc = mkKindEqLoc xi1 xi2 loc + ; kind_ev <- newGivenEvVar kind_loc (pred_ty, evCoercion kind_co) + ; emitWorkNC [CtGiven kind_ev] + ; finish emptyRewriterSet (givenCtEvCoercion kind_ev) } + + CtWanted {} + -> do { (kind_co, cts, unifs) <- wrapUnifierTcS ev Nominal $ \uenv -> + let uenv' = updUEnvLoc uenv (mkKindEqLoc xi1 xi2) + in unSwap swapped (uType uenv') ki1 ki2 + -- mkKindEqLoc: any new constraints, arising from the kind + -- unification, say they thay come from unifying xi1~xi2 + ; if not (null unifs) + then -- Unifications happened, so start again to do the zonking + -- Otherwise we might put something in the inert set that isn't inert + startAgainWith (mkNonCanonical ev) + else + + assertPpr (not (isEmptyCts cts)) (ppr ev $$ ppr ki1 $$ ppr ki2) $ + -- assert: the constraints won't be empty because the two kinds differ, + -- and there are no unifications, so we must have emitted one or + -- more constraints + finish (rewriterSetFromCts cts) kind_co } + -- rewriterSetFromCts: record in the /type/ unification xi1~xi2 that + -- it has been rewritten by any (unsolved) consraints in `cts`; that + -- stops xi1~xi2 from unifying until `cts` are solved. See (EIK2). + where + xi1 = canEqLHSType lhs1 + role = eqRelRole eq_rel + + finish rewriters kind_co + = do { traceTcS "Hetero equality gives rise to kind equality" + (ppr swapped $$ + ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ]) + ; new_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn + -- rewriteEqEvidence adds any as-yet-unsolved equalities + -- from the kind equality (namely `rewriters`) to the + -- rewriter set for `new_ev`. See (EIK2). + + -- Now `new_ev` is homogenous: carry on! + ; canEqCanLHSHomo new_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 } + + where + -- kind_co :: ki1 ~N ki2 + lhs_redn = mkReflRedn role ps_xi1 + rhs_redn = mkGReflRightRedn role xi2 sym_kind_co + new_xi2 = mkCastTy ps_xi2 sym_kind_co + + -- Apply mkSymCo when /not/ swapped + sym_kind_co = case swapped of + NotSwapped -> mkSymCo kind_co + IsSwapped -> kind_co + + +canEqCanLHSHomo :: CtEvidence -- lhs ~ rhs + -- or, if swapped: rhs ~ lhs + -> EqRel -> SwapFlag + -> CanEqLHS -> TcType -- lhs, pretty lhs + -> TcType -> TcType -- rhs, pretty rhs + -> TcS (StopOrContinue (Either IrredCt EqCt)) +-- Guaranteed that typeKind lhs == typeKind rhs +canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 + | (xi2', mco) <- split_cast_ty xi2 + , Just lhs2 <- canEqLHS_maybe xi2' + = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkSymMCo mco) mco + + | otherwise + = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2 + + where + split_cast_ty (CastTy ty co) = (ty, MCo co) + split_cast_ty other = (other, MRefl) + +-- This function deals with the case that both LHS and RHS are potential +-- CanEqLHSs. +canEqCanLHS2 :: CtEvidence -- lhs ~ (rhs |> mco) + -- or, if swapped: (rhs |> mco) ~ lhs + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs (or, if swapped, rhs) + -> TcType -- pretty lhs + -> CanEqLHS -- rhs + -> TcType -- pretty rhs + -> MCoercion -- :: kind(rhs) ~N kind(lhs) + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco + | lhs1 `eqCanEqLHS` lhs2 + -- It must be the case that mco is reflexive + = canEqReflexive ev eq_rel lhs1_ty + + | TyVarLHS tv1 <- lhs1 + , TyVarLHS tv2 <- lhs2 + = -- See Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify + do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) + ; if swapOverTyVars (isGiven ev) tv1 tv2 + then finish_with_swapping + else finish_without_swapping } + + | TyVarLHS {} <- lhs1 + , TyFamLHS {} <- lhs2 + = if put_tyvar_on_lhs + then finish_without_swapping + else finish_with_swapping + + | TyFamLHS {} <- lhs1 + , TyVarLHS {} <- lhs2 + = if put_tyvar_on_lhs + then finish_with_swapping + else finish_without_swapping + + | TyFamLHS _fun_tc1 fun_args1 <- lhs1 + , TyFamLHS _fun_tc2 fun_args2 <- lhs2 + -- See Note [Decomposing type family applications] + = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2) + ; tclvl <- getTcLevel + ; let tvs1 = tyCoVarsOfTypes fun_args1 + tvs2 = tyCoVarsOfTypes fun_args2 + + -- See Note [Orienting TyFamLHS/TyFamLHS] + swap_for_size = typesSize fun_args2 > typesSize fun_args1 + + -- See Note [Orienting TyFamLHS/TyFamLHS] + meta_tv_lhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs1 + meta_tv_rhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 + swap_for_rewriting = meta_tv_rhs && not meta_tv_lhs + -- See Note [Put touchable variables on the left] + -- This second check is just to avoid unfruitful swapping + + -- It's important that we don't flip-flop (#T24134) + -- So swap_for_rewriting "wins", and we only try swap_for_size + -- if swap_for_rewriting doesn't care either way + ; if swap_for_rewriting || (meta_tv_lhs == meta_tv_rhs && swap_for_size) + then finish_with_swapping + else finish_without_swapping } + where + sym_mco = mkSymMCo mco + role = eqRelRole eq_rel + lhs1_ty = canEqLHSType lhs1 + lhs2_ty = canEqLHSType lhs2 + + finish_without_swapping + = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco) + + -- Swapping. We have ev : lhs1 ~ lhs2 |> co + -- We swap to new_ev : lhs2 ~ lhs1 |> sym co + -- ev = grefl1 ; sym new_ev ; grefl2 + -- where grefl1 : lhs1 ~ lhs1 |> sym co + -- grefl2 : lhs2 ~ lhs2 |> co + finish_with_swapping + = do { let lhs1_redn = mkGReflRightMRedn role lhs1_ty sym_mco + lhs2_redn = mkGReflLeftMRedn role lhs2_ty mco + ; new_ev <-rewriteEqEvidence emptyRewriterSet ev swapped lhs1_redn lhs2_redn + ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) } + + put_tyvar_on_lhs = isWanted ev && eq_rel == NomEq + -- See Note [Orienting TyVarLHS/TyFamLHS] + -- Same conditions as for canEqCanLHSFinish_try_unification + -- which we are setting ourselves up for here + +{- Note [Orienting TyVarLHS/TyFamLHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What if one side is a TyVarLHS and the other is a TyFamLHS, (a ~ F tys)? +Which to put on the left? Answer: + +* If there is no chance of unifying, put the type family on the left, + (F tys ~ a), because it's generally better to rewrite away function + calls. See `put_tyvar_on_lhs` in canEqCanLHS2; and + Note [Orienting TyVarLHS/TyFamLHS] + +* But if there /is/ a chance of unifying, put the tyvar on the left, + (a ~ F tys), as this may be our only shot to unify. Again see + `put_tyvar_on_lhs`. + +* But if we /fail/ to unify then flip back to (F tys ~ a) because it's + generally better to rewrite away function calls. See the call to + `swapAndFinish` in `canEqCanLHSFinish_try_unification` + + It's important to flip back. Consider + [W] F alpha ~ alpha + [W] F alpha ~ beta + [W] G alpha beta ~ Int ( where we have type instance G a a = a ) + If we end up with a stuck alpha ~ F alpha, we won't be able to solve this. + Test case: indexed-types/should_compile/CEqCanOccursCheck + +Note [Orienting TyFamLHS/TyFamLHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a TyFamLHS on both sides, we choose how to orient it. + +* swap_for_size. If we have + S a ~ F (G (H (Maybe a))) + then we swap so that we tend to rewrite the bigger type (F (G (H (Maybe a)))) + into the smaller one (S a). This same test tends to avoid occurs-check + errors. E.g. + S g ~ F (G (S g)) + Here (S g) occurs on the RHS, so this is not canonical. But if we swap it + around, it /is/ canonical + F (G (S g)) ~ S g + +* swap_for_rewriting: put touchable meta-tyvars on the left: + see Note [Put touchable variables on the left] +-} + +-- The RHS here is either not CanEqLHS, or it's one that we +-- want to rewrite the LHS to (as per e.g. swapOverTyVars) +canEqCanLHSFinish, canEqCanLHSFinish_try_unification, + canEqCanLHSFinish_no_unification + :: CtEvidence -- (lhs ~ rhs) or if swapped (rhs ~ lhs) + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs + -> TcType -- rhs + -> TcS (StopOrContinue (Either IrredCt EqCt)) + -- RHS is fully rewritten, but with type synonyms + -- preserved as much as possible + -- Guaranteed preconditions that + -- (TyEq:K) handled in canEqCanLHSHomo + -- (TyEq:N) checked in can_eq_nc + -- (TyEq:TV) handled in canEqCanLHS2 + +--------------------------- +canEqCanLHSFinish ev eq_rel swapped lhs rhs + = do { traceTcS "canEqCanLHSFinish" $ + vcat [ text "ev:" <+> ppr ev + , text "swapped:" <+> ppr swapped + , text "lhs:" <+> ppr lhs + , text "rhs:" <+> ppr rhs ] + + -- Assertion: (TyEq:K) is already satisfied + ; massert (canEqLHSKind lhs `eqType` typeKind rhs) + + -- Assertion: (TyEq:N) is already satisfied (if applicable) + ; assertPprM ty_eq_N_OK $ + vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied" + , text "rhs:" <+> ppr rhs ] + + ; canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs } + + where + -- This is about (TyEq:N): check that we don't have a saturated application + -- of a newtype TyCon at the top level of the RHS, if the constructor + -- of the newtype is in scope. + ty_eq_N_OK :: TcS Bool + ty_eq_N_OK + | ReprEq <- eq_rel + , Just (tc, tc_args) <- splitTyConApp_maybe rhs + , Just con <- newTyConDataCon_maybe tc + -- #22310: only a problem if the newtype TyCon is saturated. + , tc_args `lengthAtLeast` tyConArity tc + -- #21010: only a problem if the newtype constructor is in scope. + = do { rdr_env <- getGlobalRdrEnvTcS + ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con) + ; return $ not con_in_scope } + | otherwise + = return True + +----------------------- +canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs + -- Try unification; for Wanted, Nominal equalities with a meta-tyvar on the LHS + | CtWanted wev <- ev -- See Note [Do not unify Givens] + , NomEq <- eq_rel -- See Note [Do not unify representational equalities] + , wantedCtHasNoRewriters wev -- See Note [Unify only if the rewriter set is empty] + , TyVarLHS lhs_tv <- lhs + = do { given_eq_lvl <- getInnermostGivenEqLevel + ; case simpleUnifyCheck UC_Solver given_eq_lvl lhs_tv rhs of + SUC_CanUnify -> + unify lhs_tv (mkReflRedn Nominal rhs) + SUC_CannotUnify + | Just can_rhs <- canTyFamEqLHS_maybe rhs + -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS] + | otherwise + -> finish_no_unify + SUC_NotSure -> + -- We have a touchable unification variable on the left, + -- and the top-shape check succeeded. These are both guaranteed + -- by the fact that simpleUnifyCheck did not return SUC_CannotUnify. + do { let flags = unifyingLHSMetaTyVar_TEFTask ev lhs_tv + ; check_result <- wrapTcS (checkTyEqRhs flags rhs) + ; case check_result of + PuOK cts rhs_redn -> + do { emitWork cts + ; unify lhs_tv rhs_redn } + PuFail reason + | Just can_rhs <- canTyFamEqLHS_maybe rhs + -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS] + | reason `cterHasOnlyProblems` do_not_prevent_rewriting + -> + -- ContinueWith, to allow using this constraint for + -- rewriting (e.g. alpha[2] ~ beta[3]). + do { let role = eqRelRole eq_rel + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn role (canEqLHSType lhs)) + (mkReflRedn role rhs) + ; continueWith $ Right $ + EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel + , eq_lhs = lhs , eq_rhs = rhs } + } + | otherwise + -> try_irred reason + } + } + -- Otherwise unification is off the table + | otherwise + = finish_no_unify + + where + -- We can't unify, but this equality can go in the inert set + -- and be used to rewrite other constraints. + finish_no_unify = + canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs + + -- We can't unify, and this equality should not be used to rewrite + -- other constraints (e.g. because it has an occurs check). + -- So add it to the inert Irreds. + try_irred reason = + tryIrredInstead reason ev eq_rel swapped lhs rhs + + -- We can't unify as-is, and want to flip the equality around. + -- Example: alpha ~ F tys, flip it around to become the canonical + -- equality f tys ~ alpha. + swap_and_finish tv can_rhs = + swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs + + -- We can unify; go ahead and do so. + unify tv rhs_redn = + + do { -- In the common case where rhs_redn is Refl, we don't need to rewrite + -- the evidence, even if swapped=IsSwapped. Suppose the original was + -- [W] co : Int ~ alpha + -- We unify alpha := Int, and set co := . No need to + -- swap to co = sym co' + -- co' = + new_ev <- if isReflCo (reductionCoercion rhs_redn) + then return ev + else rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn + + ; let tv_ty = mkTyVarTy tv + final_rhs = reductionReducedType rhs_redn + + ; traceTcS "Sneaky unification:" $ + vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr final_rhs, + text "Coercion:" <+> pprEq tv_ty final_rhs, + text "Left Kind is:" <+> ppr (typeKind tv_ty), + text "Right Kind is:" <+> ppr (typeKind final_rhs) ] + + -- Update the unification variable itself + ; unifyTyVar tv final_rhs + + -- Provide Refl evidence for the constraint + -- Ignore 'swapped' because it's Refl! + ; setEvBindIfWanted new_ev EvCanonical $ + evCoercion (mkNomReflCo final_rhs) + + -- Kick out any constraints that can now be rewritten + ; kickOutAfterUnification [tv] + + ; return (Stop new_ev (text "Solved by unification")) } + +--------------------------- +-- Unification is off the table +canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs + = do { -- Do checkTypeEq to guarantee (TyEq:OC), (TyEq:F) + -- Must do the occurs check even on tyvar/tyvar equalities, + -- in case have x ~ (y :: ..x...); this is #12593. + ; check_result <- checkTypeEq ev eq_rel lhs rhs + + ; let lhs_ty = canEqLHSType lhs + ; case check_result of + PuFail reason + + -- If we had F a ~ G (F a), which gives an occurs check, + -- then swap it to G (F a) ~ F a, which does not + -- However `swap_for_size` above will orient it with (G (F a)) on + -- the left anwyway. `swap_for_rewriting` "wins", but that doesn't + -- matter: in the occurs check case swap_for_rewriting will be moot. + -- TL;DR: the next four lines of code are redundant + -- I'm leaving them here in case they become relevant again +-- | TyFamLHS {} <- lhs +-- , Just can_rhs <- canTyFamEqLHS_maybe rhs +-- , reason `cterHasOnlyProblem` cteSolubleOccurs +-- -> swapAndFinish ev eq_rel swapped lhs_ty can_rhs +-- | otherwise + + | reason `cterHasOnlyProblems` do_not_prevent_rewriting + -> do { let role = eqRelRole eq_rel + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn role (canEqLHSType lhs)) + (mkReflRedn role rhs) + ; continueWith $ Right $ + EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel + , eq_lhs = lhs , eq_rhs = rhs } + } + + | otherwise + -> tryIrredInstead reason ev eq_rel swapped lhs rhs + + PuOK _ rhs_redn + -> do { new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn (eqRelRole eq_rel) lhs_ty) + rhs_redn + + -- Important: even if the coercion is Refl, + -- * new_ev has reductionReducedType on the RHS + -- * eq_rhs is set to reductionReducedType + -- See Note [Forgetful synonyms in checkTyConApp] in GHC.Tc.Utils.Unify + ; continueWith $ Right $ + EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel + , eq_lhs = lhs + , eq_rhs = reductionReducedType rhs_redn } } } + +-- | Some problems prevent /unification/ but not /rewriting/: +-- +-- Skolem-escape: if we have [W] alpha[2] ~ Maybe b[3] +-- we can't unify (skolem-escape); but it /is/ canonical, +-- and hence we /can/ use it for rewriting +-- +-- Concrete-ness: alpha[conc] ~ b[sk] +-- We can use it to rewrite; we still have to solve the original +do_not_prevent_rewriting :: CheckTyEqResult +do_not_prevent_rewriting = cteProblem cteSkolemEscape S.<> + cteProblem cteConcrete + +---------------------- +swapAndFinish :: CtEvidence -> EqRel -> SwapFlag + -> TcType -> CanEqLHS -- ty ~ F tys + -> TcS (StopOrContinue (Either unused EqCt)) +-- We have an equality alpha ~ F tys, that we can't unify e.g because 'tys' +-- mentions alpha, it would not be a canonical constraint as-is. +-- We want to flip it to (F tys ~ a), whereupon it is canonical +swapAndFinish ev eq_rel swapped lhs_ty can_rhs + = do { let role = eqRelRole eq_rel + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev (flipSwap swapped) + (mkReflRedn role (canEqLHSType can_rhs)) + (mkReflRedn role lhs_ty) + ; continueWith $ Right $ + EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel + , eq_lhs = can_rhs, eq_rhs = lhs_ty } } + +---------------------- +tryIrredInstead :: CheckTyEqResult -> CtEvidence + -> EqRel -> SwapFlag -> CanEqLHS -> TcType + -> TcS (StopOrContinue (Either IrredCt unused)) +-- We have a non-canonical equality +-- We still swap it if 'swapped' says so, so that it is oriented +-- in the direction that the error-reporting machinery +-- expects it; e.g. (m ~ t m) rather than (t m ~ m) +-- This is not very important, and only affects error reporting. +tryIrredInstead reason ev eq_rel swapped lhs rhs + = do { traceTcS "cantMakeCanonical" (ppr reason $$ ppr lhs $$ ppr rhs) + ; let role = eqRelRole eq_rel + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn role (canEqLHSType lhs)) + (mkReflRedn role rhs) + ; finishCanWithIrred (NonCanonicalReason reason) new_ev } + +finishCanWithIrred :: CtIrredReason -> CtEvidence + -> TcS (StopOrContinue (Either IrredCt a)) +finishCanWithIrred reason ev + = do { -- Abort fast if we have any insoluble Wanted constraints, + -- and the TcS abort-if-insoluble flag is on. + when (isInsolubleReason reason) tryEarlyAbortTcS + + ; continueWith $ Left $ IrredCt { ir_ev = ev, ir_reason = reason } } + +----------------------- +-- | Solve a reflexive equality constraint +canEqReflexive :: CtEvidence -- ty ~ ty + -> EqRel + -> TcType -- ty + -> TcS (StopOrContinue a) -- always Stop +canEqReflexive ev eq_rel ty + = do { setEvBindIfWanted ev EvCanonical $ + evCoercion (mkReflCo (eqRelRole eq_rel) ty) + ; stopWith ev "Solved by reflexivity" } + +{- Note [Equalities with heterogeneous kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What do we do when we have an equality + + (tv :: k1) ~ (rhs :: k2) + +where k1 and k2 differ? Easy: we create a coercion that relates k1 and +k2 and use this to cast. To wit, from + + [X] co1 :: (tv :: k1) ~ (rhs :: k2) + +(where [X] is [G] or [W]), we go to + + co1 = co2 ; sym (GRefl kco) + [X] co2 :: (tv :: k1) ~ ((rhs |> sym kco) :: k1) + [X] kco :: k1 ~ k2 + +Wrinkles: + +(EIK1) When X=Wanted, the new type-level wanted for `co` 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. + +(EIK2) Suppose we have [W] (a::Type) ~ (b::Type->Type). The above rewrite will produce + [W] w (rewriters: {kw}) : a ~ (b |> kw) + [W] kw : Type ~ (Type->Type) + + We track `w` as having `kw` in its rewriter set. That will stop us unifying `w` + (see Note [Unify only if the rewriter set is empty] in GHC.Tc.Solver.Equality). + + But `w` is still /canonical/, and used for rewriting other constraints. + See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. That's important + in general. Consider: + [W] kw : k ~ Type + [W] w : a ~ F k t + We can rewrite `w` with `kw` like this: + [W] w' (rewriters: {kw}) : a ~ F Type (t |> kw) + The cast on the second argument of `F` is necessary to keep the appliation well-kinded. + There is nothing special here; no reason not treat w' as canonical, and use it for + rewriting. Indeed test JuanLopez only typechecks if we do. + + So here is our implementation: + * When doing the kind unification, any equality constraints we can't solve + immediately get an origin that tells that the constraint arises from + the kind of the parent type-equality. See the calls to `mkKindEqLoc` + in `canEqCanLHSHetero`. + + * We /also/ add these unsolved kind equalities to the `RewriterSet` of the + parent constraint; see the call to `rewriteEqEvidence` in `finish` in + `canEqCanLHSHetero`. + + * When filling a coercion hole we kick out any equality constraints whose + rewriter set mentions this hole. See `kickOutAfterFillingCoercionHole` + +(EIK3) Suppose we have [W] co1 : (a :: k1) ~ (rhs :: k2). We duly follow the + algorithm detailed here, producing [W] kco :: k1 ~ k2, and adding + [W] co2 : (a :: k1) ~ ((rhs |> sym kco) :: k1) to the inert set. + Some time later, we solve `kco`, and fill in kco's coercion hole. + This kicks out the inert equality `co2` + + But now, during canonicalization, we see the cast and remove it, in + `canEqCast`. By the time we get into `canEqCanLHS`, the equality is + heterogeneous again, and the process repeats! + + To avoid this, we don't strip casts off a type if the other type in the + equality is a CanEqLHS. See the `CastTy` case of `can_eq_nc`. + (The scenario above can happen with a type family, too. + testcase: typecheck/should_compile/T13822). + + And this is an improvement regardless: because tyvars can, generally, + unify with casted types, there's no reason to go through the work of + stripping off the cast when the cast appears opposite a tyvar. + +Historical note: + +We used to do this via emitting a Derived kind equality and then parking +the heterogeneous equality as irreducible. But this new approach is much +more direct. And it doesn't produce duplicate Deriveds (as the old one did). + +Note [Type synonyms and canonicalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat type synonym applications as xi types, that is, they do not +count as type function applications. However, we do need to be a bit +careful with type synonyms: like type functions they may not be +generative or injective. However, unlike type functions, they are +parametric, so there is no problem in expanding them whenever we see +them, since we do not need to know anything about their arguments in +order to expand them; this is what justifies not having to treat them +as specially as type function applications. The thing that causes +some subtleties is that we prefer to leave type synonym applications +*unexpanded* whenever possible, in order to generate better error +messages. + +If we encounter an equality constraint with type synonym applications +on both sides, or a type synonym application on one side and some sort +of type application on the other, we simply must expand out the type +synonyms in order to continue decomposing the equality constraint into +primitive equality constraints. For example, suppose we have + + type F a = [Int] + +and we encounter the equality + + F a ~ [b] + +In order to continue we must expand F a into [Int], giving us the +equality + + [Int] ~ [b] + +which we can then decompose into the more primitive equality +constraint + + Int ~ b. + +However, if we encounter an equality constraint with a type synonym +application on one side and a variable on the other side, we should +NOT (necessarily) expand the type synonym, since for the purpose of +good error messages we want to leave type synonyms unexpanded as much +as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS. + +Note [Type equality cycles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this situation (from indexed-types/should_compile/GivenLoop): + + instance C (Maybe b) + *[G] a ~ Maybe (F a) + [W] C a + +or (typecheck/should_compile/T19682b): + + instance C (a -> b) + *[W] alpha ~ (Arg alpha -> Res alpha) + [W] C alpha + +or (typecheck/should_compile/T21515): + + type family Code a + *[G] Code a ~ '[ '[ Head (Head (Code a)) ] ] + [W] Code a ~ '[ '[ alpha ] ] + +In order to solve the final Wanted, we must use the starred constraint +for rewriting. But note that all starred constraints have occurs-check failures, +and so we can't straightforwardly add these to the inert set and +use them for rewriting. (NB: A rigid type constructor is at the +top of all RHSs, preventing reorienting in canEqTyVarFunEq in the tyvar +cases.) + +The key idea is to replace the outermost type family applications in the RHS of +the starred constraints with a fresh variable, which we'll call a cycle-breaker +variable, or cbv. Then, relate the cbv back with the original type family +application via new equality constraints. Our situations thus become: + + instance C (Maybe b) + [G] a ~ Maybe cbv + [G] F a ~ cbv + [W] C a + +or + + instance C (a -> b) + [W] alpha ~ (cbv1 -> cbv2) + [W] Arg alpha ~ cbv1 + [W] Res alpha ~ cbv2 + [W] C alpha + +or + + [G] Code a ~ '[ '[ cbv ] ] + [G] Head (Head (Code a)) ~ cbv + [W] Code a ~ '[ '[ alpha ] ] + +This transformation (creating the new types and emitting new equality +constraints) is done by the `FamAppBreaker` field of `TEFA_Break`, which +in turn lives in the `tef_fam_app` field of `TyEqFlags`. And that in +turn controls the behaviour of the workhorse: GHC.Tc.Utils.Unify.checkTyEqRhs. + +The details depend on whether we're working with a Given or a Wanted. + +Given +----- +We emit a new Given, [G] F a ~ cbv, equating the type family application +to our new cbv. This is actually done by `break_given` in +`GHC.Tc.Solver.Monad.checkTypeEq`. + +Note its orientation: The type family ends up on the left; see +Note [Orienting TyFamLHS/TyFamLHS]. No special treatment for +CycleBreakerTvs is necessary. This scenario is now easily soluble, by using +the first Given to rewrite the Wanted, which can now be solved. + +(The first Given actually also rewrites the second one, giving +[G] F (Maybe cbv) ~ cbv, but this causes no trouble.) + +Of course, we don't want our fresh variables leaking into e.g. error +messages. So we fill in the metavariables with their original type family +applications after we're done running the solver (in nestImplicTcS and +runTcSWithEvBinds). This is done by `restoreTyVarCycles`, which uses the +`inert_cycle_breakers` field in InertSet, which contains the pairings +invented in `break_given`. + +That is, we transform + [G] g : lhs ~ ...(F lhs)... +to + [G] (Refl lhs) : F lhs ~ cbv -- CEqCan + [G] g : lhs ~ ...cbv... -- CEqCan + +Note that +* `cbv` is a fresh cycle breaker variable. +* `cbv` is a meta-tyvar, but it is completely untouchable. +* We track the cycle-breaker variables in inert_cycle_breakers in InertSet +* We eventually fill in the cycle-breakers, with `cbv := F lhs`. + No one else fills in CycleBreakerTvs! +* The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know + this fill-in is ultimately going to happen. +* In `inert_cycle_breakers`, we remember the (cbv, F lhs) pair; that is, we + remember the /original/ type. The [G] F lhs ~ cbv constraint may be rewritten + by other givens (eg if we have another [G] lhs ~ (b,c)), but at the end we + still fill in with cbv := F lhs +* This fill-in is done when solving is complete, by restoreTyVarCycles + in nestImplicTcS and runTcSWithEvBinds. + +Wanted +------ +First, we do not cycle-break unless the LHS is a unifiable type variable +See Note [Don't cycle-break Wanteds when not unifying] in GHC.Tc.Solver.Monad. + +OK, so suppose the LHS is a unifiable type variable. The fresh cycle-breaker +variables here must actually be normal, touchable metavariables. That is, they +are TauTvs. Nothing at all unusual. Repeating the example from above, we have + + *[W] alpha ~ (Arg alpha -> Res alpha) + +and we turn this into + + *[W] alpha ~ (cbv1 -> cbv2) + [W] Arg alpha ~ cbv1 + [W] Res alpha ~ cbv2 + +where cbv1 and cbv2 are fresh TauTvs. This is actually done within checkTyEqRhs, +called within canEqCanLHSFinish_try_unification, which will use the BreakWanted +FamAppBreaker. + +Why TauTvs? See [Why TauTvs] below. + +Critically, we emit the two new constraints (the last two above) +directly instead of calling wrapUnifierTcS. (Otherwise, we'd end up +unifying cbv1 and cbv2 immediately, achieving nothing.) Next, we +unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This +unification happens immediately following a successful call to +checkTyEqRhs, in canEqCanLHSFinish_try_unification. + +Now, we're here (including further context from our original example, +from the top of the Note): + + instance C (a -> b) + [W] Arg (cbv1 -> cbv2) ~ cbv1 + [W] Res (cbv1 -> cbv2) ~ cbv2 + [W] C (cbv1 -> cbv2) + +The first two W constraints reduce to reflexivity and are discarded, +and the last is easily soluble. + +[Why TauTvs]: +Let's look at another example (typecheck/should_compile/T19682) where we need +to unify the cbvs: + + class (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys + instance (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys + + type family SameShapeAs xs ys :: Constraint where + SameShapeAs '[] ys = (ys ~ '[]) + SameShapeAs (x : xs) ys = (ys ~ (Head ys : Tail ys)) + + type family AllEqF xs ys :: Constraint where + AllEqF '[] '[] = () + AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys) + + [W] alpha ~ (Head alpha : Tail alpha) + [W] AllEqF '[Bool] alpha + +Without the logic detailed in this Note, we're stuck here, as AllEqF cannot +reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach, +just as described above. We thus invent cbv1 and cbv2 and unify +alpha := cbv1 -> cbv2, yielding (after zonking) + + [W] Head (cbv1 : cbv2) ~ cbv1 + [W] Tail (cbv1 : cbv2) ~ cbv2 + [W] AllEqF '[Bool] (cbv1 : cbv2) + +The first two W constraints simplify to reflexivity and are discarded. +But the last reduces: + + [W] Bool ~ cbv1 + [W] AllEq '[] cbv2 + +The first of these is solved by unification: cbv1 := Bool. The second +is solved by the instance for AllEq to become + + [W] AllEqF '[] cbv2 + [W] SameShapeAs '[] cbv2 + +While the first of these is stuck, the second makes progress, to lead to + + [W] AllEqF '[] cbv2 + [W] cbv2 ~ '[] + +This second constraint is solved by unification: cbv2 := '[]. We now +have + + [W] AllEqF '[] '[] + +which reduces to + + [W] () + +which is trivially satisfiable. Hooray! + +Note that we need to unify the cbvs here; if we did not, there would be +no way to solve those constraints. That's why the cycle-breakers are +ordinary TauTvs. + +How all this is implemented +--------------------------- +We implement all this via the `TEFA_Break` constructor of `TyEqFamApp`, +itself stored in the `tef_fam_app` field of `TyEqFlags`, which controls +the behaviour of `GHC.Tc.Utils.Unify.checkTyEqRhs`. The `TEFA_Break` +stuff happens when `checkTyEqRhs` encounters a family application. + +We try the cycle-breaking trick: +* For Wanteds, when there is a touchable unification variable on the left +* For Givens, regardless of the LHS + +EXCEPT that, in both cases, as `GHC.Tc.Solver.Monad.mkTEFA_Break` shows, we +don't use this trick: + +* When the constraint we are looking at was itself created by cycle-breaking; + see Detail (7) below. + +* For representational equalities, as there is no concrete use case where it is + helpful (unlike for nominal equalities). + + Furthermore, because function applications can be CanEqLHSs, but newtype + applications cannot, the disparities between the cases are enough that it + would be effortful to expand the idea to representational equalities. A quick + attempt, with + data family N a b + f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b + f = coerce + failed with "Could not match 'b' with 'b'." Further work is held off + until when we have a concrete incentive to explore this dark corner. + +More details: + + (1) We don't look under foralls, at all, in `checkTyEqRhs`. There might be + a cyclic occurrence underneath, in a case like + [G] lhs ~ forall b. ... lhs .... + but it doesn't matter because we will classify the constraint as Irred, + so it will not be used for rewriting. + + Earlier versions required an extra, post-breaking, check. Skipping this + check causes typecheck/should_fail/GivenForallLoop and polykinds/T18451 to + loop. But now it is all simpler, with no need for a second check. + + (2) Historical Note: our goal here is to avoid loops in rewriting. We can thus + skip looking in coercions, as we don't rewrite in coercions in the + algorithm in GHC.Solver.Rewrite. This doesn't seem relevant any more. + We cycle break to make the constraint canonical. + + (3) As we cycle-break as described in this Note, we can build ill-kinded + types. For example, if we have Proxy (F a) b, where (b :: F a), then + replacing this with Proxy cbv b is ill-kinded. However, we will later + set cbv := F a, and so the zonked type will be well-kinded again. + The temporary ill-kinded type hurts no one, and avoiding this would + be quite painfully difficult. + + Specifically, this detail does not contravene the Purely Kinded Type Invariant + (Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType). + The PKTI says that we can call typeKind on any type, without failure. + It would be violated if we, say, replaced a kind (a -> b) with a kind c, + because an arrow kind might be consulted in piResultTys. Here, we are + replacing one opaque type like (F a b c) with another, cbv (opaque in + that we never assume anything about its structure, like that it has a + result type or a RuntimeRep argument). + + (4) The evidence for the produced Givens is all just reflexive, because we + will eventually set the cycle-breaker variable to be the type family, and + then, after the zonk, all will be well. See also the notes at the end of + the Given section of this Note. + + (5) The implementation in `checkTyEqRhs` is efficient because it only replaces + a type family application with a type variable, if that particular + appplication is implicated in the occurs check. For example: + [W] alpha ~ Maybe (F alpha, G beta) + We'll end up calling GHC.Tc.Utils.Unify.checkFamApp + * On `F alpha`, which fail and calls the cycle-breaker in TEFA_Break + * On `G beta`, which succeeds no problem. + + However, we make no attempt to detect cases like a ~ (F a, F a) and use the + same tyvar to replace F a. The constraint solver will common them up later! + (Cf. Note [Apartness and type families] in GHC.Core.Unify, which goes to + this extra effort.) However, this is really a very small corner case. The + investment to craft a clever, performant solution seems unworthwhile. + + (6) We often get the predicate associated with a constraint from its evidence + with ctPred. We thus must not only make sure the generated CEqCan's fields + have the updated RHS type (that is, the one produced by replacing type + family applications with fresh variables), but we must also update the + evidence itself. This is done by the call to rewriteEqEvidence in + canEqCanLHSFinish. + + (7) We don't wish to apply this magic on the equalities created + by this very same process. Consider this, from + typecheck/should_compile/ContextStack2: + + type instance TF (a, b) = (TF a, TF b) + t :: (a ~ TF (a, Int)) => ... + + [G] a ~ TF (a, Int) + + The RHS reduces, so we get + + [G] a ~ (TF a, TF Int) + + We then break cycles, to get + + [G] g1 :: a ~ (cbv1, cbv2) + [G] g2 :: TF a ~ cbv1 + [G] g3 :: TF Int ~ cbv2 + + g1 gets added to the inert set, as written. But then g2 becomes + the work item. g1 rewrites g2 to become + + [G] TF (cbv1, cbv2) ~ cbv1 + + which then uses the type instance to become + + [G] (TF cbv1, TF cbv2) ~ cbv1 + + which looks remarkably like the Given we started with. If left unchecked, + this will end up breaking cycles again, looping ad infinitum (and + resulting in a context-stack reduction error, not an outright loop). The + solution is easy: don't break cycles on an equality generated by breaking + cycles. Instead, we mark this final Given as a CIrredCan with a + NonCanonicalReason with the soluble occurs-check bit set (only). + + We track these equalities by giving them a special CtOrigin, + CycleBreakerOrigin. This works for both Givens and Wanteds, as we need the + logic in the W case for e.g. typecheck/should_fail/T17139. Because this + logic needs to work for Wanteds, too, we cannot simply look for a + CycleBreakerTv on the left: Wanteds don't use them. + + +********************************************************************** +* * + Rewriting evidence +* * +********************************************************************** +-} + +rewriteEqEvidence :: RewriterSet -- New rewriters + -- See GHC.Tc.Types.Constraint + -- Note [Wanteds rewrite Wanteds] + -> CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) + -- or orhs ~ olhs (swapped) + -> SwapFlag + -> Reduction -- lhs_co :: olhs ~ nlhs + -> Reduction -- rhs_co :: orhs ~ nrhs + -> TcS CtEvidence -- Of type nlhs ~ nrhs +-- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs), +-- rewriteEqEvidence yields, for a given equality (Given g olhs orhs): +-- If not swapped +-- g1 : nlhs ~ nrhs = sym lhs_co ; g ; rhs_co +-- If swapped +-- g1 : nlhs ~ nrhs = sym lhs_co ; Sym g ; rhs_co +-- +-- For a wanted equality (Wanted w), we do the dual thing: +-- New w1 : nlhs ~ nrhs +-- If not swapped +-- w : olhs ~ orhs = lhs_co ; w1 ; sym rhs_co +-- If swapped +-- w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co +-- +-- It's all a form of rewriteEvidence, specialised for equalities +rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) + | NotSwapped <- swapped + , isReflCo lhs_co -- See Note [Rewriting with Refl] + , isReflCo rhs_co + = return (setCtEvPredType old_ev new_pred) + + | CtGiven (GivenCt { ctev_evar = old_evar }) <- old_ev + = do { let new_tm = evCoercion ( mkSymCo lhs_co + `mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar) + `mkTransCo` rhs_co) + ; CtGiven <$> newGivenEvVar loc (new_pred, new_tm) } + + | CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rewriters }) <- old_ev + = do { let rewriters' = rewriters S.<> new_rewriters + ; (new_ev, hole_co) <- newWantedEq loc rewriters' (ctEvRewriteRole old_ev) nlhs nrhs + ; let co = maybeSymCo swapped $ + lhs_co `mkTransCo` hole_co `mkTransCo` mkSymCo rhs_co + ; setWantedEq dest co + ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev + , ppr nlhs + , ppr nrhs + , ppr co + , ppr new_rewriters ]) + ; return $ CtWanted new_ev } + + where + new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs + loc = ctEvLoc old_ev + +{- +********************************************************************** +* * + tryInertEqs +* * +********************************************************************** + +Note [Combining equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + Inert: g1 :: a ~ t + Work item: g2 :: a ~ t + +Then we can simply solve g2 from g1, thus g2 := g1. Easy! +But it's not so simple: + +(CE1) If t is a type variable, the equalties might be oriented differently: + e.g. (g1 :: a~b) and (g2 :: b~a) + So we look both ways round. Hence the SwapFlag result to + inertsCanDischarge. + +(CE2) We can only do g2 := g1 if g1 can discharge g2; that depends on + (a) the role and (b) the flavour. E.g. a representational equality + cannot discharge a nominal one; a Wanted cannot discharge a Given. + The predicate is eqCanRewriteFR. + +(CE3) Visibility. Suppose S :: forall k. k -> Type, and consider unifying + S @Type (a::Type) ~ S @(Type->Type) (b::Type->Type) + From the first argument we get (Type ~ Type->Type); from the second + argument we get (a ~ b) which in turn gives (Type ~ Type->Type). + See typecheck/should_fail/T16204c. + + That first argument is invisible in the source program (aside from + visible type application), so we'd much prefer to get the error from + the second. We track visibility in the uo_visible field of a TypeEqOrigin. + We use this to prioritise visible errors (see GHC.Tc.Errors.tryReporters, + the partition on isVisibleOrigin). + + So when combining two otherwise-identical equalites, we want to + keep the visible one, and discharge the invisible one. Hence the + call to strictly_more_visible. + +(CE4) Suppose we have this set up (#25440): + Inert: [W] g1: F a ~ a Int (arising from (F a ~ a Int) + Work item: [W] g2: F alpha ~ F a (arising from (F alpha ~ F a) + We rewrite g2 with g1, to give + [W] g2{rw:g1} : F alpha ~ a Int + Now if F is injective we can get [W] alpha~a, and hence alpha:=a, and + we kick out g1. Now we have two constraints + [W] g1 : F a ~ a Int (arising from (F a ~ a Int) + [W] g2{rw:g1} : F a ~ a Int (arising from (F alpha ~ F a) + If we end up with g2 in the inert set (not g1) we'll get a very confusing + error message that we can solve (F a ~ a Int) + arising from F a ~ F a + + TL;DR: Better to hang on to `g1` (with no rewriters), in preference + to `g2` (which has a rewriter). + + See (WRW1) in Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. +-} + +tryInertEqs :: EqCt -> SolverStage () +tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) + = Stage $ + do { inerts <- getInertCans + ; if | Just (ev_i, swapped) <- inertsEqsCanDischarge inerts work_item + -> do { setEvBindIfWanted ev EvCanonical $ + evCoercion (maybeSymCo swapped $ + downgradeRole (eqRelRole eq_rel) + (ctEvRewriteRole ev_i) + (ctEvCoercion ev_i)) + ; stopWith ev "Solved from inert" } + + | otherwise + -> continueWith () } + +inertsEqsCanDischarge :: InertCans -> EqCt + -> Maybe ( CtEvidence -- The evidence for the inert + , SwapFlag ) -- Whether we need mkSymCo +inertsEqsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w + , eq_ev = ev_w, eq_eq_rel = eq_rel }) + | (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i + , eq_eq_rel = eq_rel } + <- findEq inerts lhs_w + , rhs_i `tcEqType` rhs_w + , inert_beats_wanted ev_i eq_rel ] + = -- Inert: a ~ ty + -- Work item: a ~ ty + Just (ev_i, NotSwapped) + + | Just rhs_lhs <- canEqLHS_maybe rhs_w + , (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i + , eq_eq_rel = eq_rel } + <- findEq inerts rhs_lhs + , rhs_i `tcEqType` canEqLHSType lhs_w + , inert_beats_wanted ev_i eq_rel ] + = -- Inert: a ~ b + -- Work item: b ~ a + Just (ev_i, IsSwapped) + + where + loc_w = ctEvLoc ev_w + flav_w = ctEvFlavour ev_w + fr_w = (flav_w, eq_rel) + empty_rw_w = isEmptyRewriterSet (ctEvRewriters ev_w) + + inert_beats_wanted ev_i eq_rel + = -- eqCanRewriteFR: see second bullet of Note [Combining equalities] + fr_i `eqCanRewriteFR` fr_w + && not (prefer_wanted ev_i && (fr_w `eqCanRewriteFR` fr_i)) + where + fr_i = (ctEvFlavour ev_i, eq_rel) + + -- See (CE3) in Note [Combining equalities] + strictly_more_visible loc1 loc2 + = not (isVisibleOrigin (ctLocOrigin loc2)) && + isVisibleOrigin (ctLocOrigin loc1) + + prefer_wanted ev_i + = (loc_w `strictly_more_visible` ctEvLoc ev_i) + -- strictly_more_visible: see (CE3) in Note [Combining equalities] + || (empty_rw_w && not (isEmptyRewriterSet (ctEvRewriters ev_i))) + -- Prefer the one that has no rewriters + -- See (CE4) in Note [Combining equalities] + +inertsEqsCanDischarge _ _ = Nothing + + + +{- 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! + +Note [Do not unify representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [W] alpha ~R# b +where alpha is touchable. Should we unify alpha := b? + +Certainly not! Unifying forces alpha and be to be the same; but they +only need to be representationally equal types. + +For example, we might have another constraint [W] alpha ~# N b +where + newtype N b = MkN b +and we want to get alpha := N b. + +See also #15144, which was caused by unifying a representational +equality. + +Note that it does however make sense to perform such unifications, as a last +resort, when doing top-level defaulting. +See Note [Defaulting representational equalities]. + +Note [Unify only if the rewriter set is empty] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + co (rewriters = {co1,co2}) :: alpha ~# blah +If we unify before solving `co1` and `co2` (which might well be insoluble) +we destroy the careful tracking of Note [Wanteds rewrite Wanteds] in +GHC.Tc.Types.Constraint. So we decline to unify any equality with a +non-empty rewriter set: see (REWRITERS) in Note [Unification preconditions] +in GHC.Tc.Utils. + +Wrinkles: + +(URW1) We may, however, be willing to /default/ such an equality; see + (DE6) in Note [Defaulting equalities] in GHC.Tc.Solver.Default. + +(URW2) If we have `co` in the inert set, and we solve `co1` and `co2`, + we should kick out `co` so that we can now unify it, which might + unlock other stuff. See `kickOutAfterFillingCoercionHole` in + GHC.Tc.Solver.Monad. + + However the solver prioritises equalities with an empty rewriter + set, to try to avoid unnecessary kick-out. See GHC.Tc.Types.Constraint + Note [Prioritise Wanteds with empty RewriterSet] esp (PER1) + +Note [Solve by unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we solve + alpha[n] ~ ty +by unification, there are two cases to consider + +* TouchableSameLevel: if the ambient level is 'n', then + we can simply update alpha := ty, and do nothing else + +* TouchableOuterLevel free_metas n: if the ambient level is greater than + 'n' (the level of alpha), in addition to setting alpha := ty we must + do two other things: + + 1. Promote all the free meta-vars of 'ty' to level n. After all, + alpha[n] is at level n, and so if we set, say, + alpha[n] := Maybe beta[m], + we must ensure that when unifying beta we do skolem-escape checks + etc relevant to level n. Simple way to do that: promote beta to + level n. + + 2. Set the Unification Level Flag to record that a level-n unification has + taken place. See Note [The Unification Level Flag] in GHC.Tc.Solver.Monad + +NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion +would be a no-op, and setting the unification flag unnecessarily would just +make the solver iterate more often. (We don't need to iterate when unifying +at the ambient level because of the kick-out mechanism.) +-} + + +{-******************************************************************** +* * + Final wrap-up for equalities +* * +********************************************************************-} + +{- Note [Looking up primitive equalities in quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For equalities (a ~# b) look up (a ~ b), and then do a superclass +selection. This avoids having to support quantified constraints whose +kind is not Constraint, such as (forall a. F a ~# b) + +See + * Note [Evidence for quantified constraints] in GHC.Core.Predicate + * Note [Equality superclasses in quantified constraints] + in GHC.Tc.Solver.Dict +-} + +-------------------- +tryQCsIrredEqCt :: IrredCt -> SolverStage () +tryQCsIrredEqCt irred@(IrredCt { ir_ev = ev }) + | EqPred eq_rel t1 t2 <- classifyPredType (ctEvPred ev) + = lookup_eq_in_qcis (CIrredCan irred) eq_rel t1 t2 + + | otherwise -- All the calls come from in this module, where we deal only with + -- equalities, so ctEvPred ev) must be an equality. Indeed, we could + -- pass eq_rel, t1, t2 as arguments, to avoid this can't-happen case, + -- but it's not a hot path, and this is simple and robust + = pprPanic "solveIrredEquality" (ppr ev) + +-------------------- +tryQCsEqCt :: EqCt -> SolverStage () +tryQCsEqCt work_item@(EqCt { eq_lhs = lhs, eq_rhs = rhs, eq_eq_rel = eq_rel }) + = lookup_eq_in_qcis (CEqCan work_item) eq_rel (canEqLHSType lhs) rhs + +-------------------- +lookup_eq_in_qcis :: Ct -> EqRel -> TcType -> TcType -> SolverStage () +-- The "final QCI check" checks to see if we have +-- [W] t1 ~# t2 +-- and a Given quantified contraint like (forall a b. blah => a ~ b) +-- Why? See Note [Looking up primitive equalities in quantified constraints] +-- See also GHC.Tc.Solver.Dict +-- Note [Equality superclasses in quantified constraints] +lookup_eq_in_qcis work_ct eq_rel lhs rhs + = Stage $ + do { ev_binds_var <- getTcEvBindsVar + ; ics <- getInertCans + ; if isWanted ev -- Never look up Givens in quantified constraints + && not (null (inert_qcis ics)) -- Shortcut common case + && not (isCoEvBindsVar ev_binds_var) -- See Note [Instances in no-evidence implications] + then try_for_qci + else continueWith () } + where + ev = ctEvidence work_ct + loc = ctEvLoc ev + role = eqRelRole eq_rel + + try_for_qci -- First try looking for (lhs ~ rhs) + | Just (cls, tys) <- boxEqPred eq_rel lhs rhs + = do { res <- matchLocalInst (mkClassPred cls tys) loc + ; traceTcS "lookup_irred_in_qcis:1" (ppr (mkClassPred cls tys)) + ; case res of + OneInst { cir_mk_ev = mk_ev } + -> chooseInstance ev (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) + _ -> try_swapping } + | otherwise + = continueWith () + + try_swapping -- Now try looking for (rhs ~ lhs) (see #23333) + | Just (cls, tys) <- boxEqPred eq_rel rhs lhs + = do { res <- matchLocalInst (mkClassPred cls tys) loc + ; traceTcS "lookup_irred_in_qcis:2" (ppr (mkClassPred cls tys)) + ; case res of + OneInst { cir_mk_ev = mk_ev } + -> do { ev' <- rewriteEqEvidence emptyRewriterSet ev IsSwapped + (mkReflRedn role rhs) (mkReflRedn role lhs) + ; chooseInstance ev' (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) } + _ -> do { traceTcS "lookup_irred_in_qcis:3" (ppr work_ct) + ; continueWith () }} + | otherwise + = continueWith () + + mk_eq_ev cls tys mk_ev evs + | sc_id : rest <- classSCSelIds cls -- Just one superclass for this + = assert (null rest) $ case (mk_ev evs) of + EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e) + ev -> pprPanic "mk_eq_ev" (ppr ev) + | otherwise = pprPanic "finishEqCt" (ppr work_ct) + +{- Note [Instances in no-evidence implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #15290 we had + [G] forall p q. Coercible p q => Coercible (m p) (m q)) -- Quantified + [W] forall a. m (Int, IntStateT m a) + ~R# + m (Int, StateT Int m a) + +The Given is an ordinary quantified constraint; the Wanted is an implication +equality that arises from + [W] (forall a. t1) ~R# (forall a. t2) + +But because the (t1 ~R# t2) is solved "inside a type" (under that forall a) +we can't generate any term evidence. So we can't actually use that +lovely quantified constraint. Alas! + +This test arranges to ignore the instance-based solution under these +(rare) circumstances. It's sad, but I really don't see what else we can do. +-} + + +{- +********************************************************************** +* * + Functional dependencies for type families +* * +********************************************************************** + +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 wrapUnifierTcS, 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 heterogeneous kinds]). +However, the idea of working left-to-right still seems worthwhile, and so the calls +to 'reverse' remain. + +Note [Improvement orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Fundeps with instances, and equality orientation], which describes +the Exact Same Problem, with the same solution, but for functional dependencies. + +A very delicate point is the orientation of equalities +arising from injectivity improvement (#12522). Suppose we have + type family F x = t | t -> x + type instance F (a, Int) = (Int, G a) +where G is injective; and wanted constraints + + [W] F (alpha, beta) ~ (Int, ) + +The injectivity will give rise to constraints + + [W] gamma1 ~ alpha + [W] Int ~ beta + +The fresh unification variable gamma1 comes from the fact that we +can only do "partial improvement" here; see Section 5.2 of +"Injective type families for Haskell" (HS'15). + +Now, it's very important to orient the equations this way round, +so that the fresh unification variable will be eliminated in +favour of alpha. If we instead had + [W] alpha ~ gamma1 +then we would unify alpha := gamma1; and kick out the wanted +constraint. But when we substitute it back in, it'd look like + [W] F (gamma1, beta) ~ fuv +and exactly the same thing would happen again! Infinite loop. + +This all seems fragile, and it might seem more robust to avoid +introducing gamma1 in the first place, in the case where the +actual argument (alpha, beta) partly matches the improvement +template. But that's a bit tricky, esp when we remember that the +kinds much match too; so it's easier to let the normal machinery +handle it. Instead we are careful to orient the new +equality with the template on the left. Delicate, but it works. + +-} + +-------------------- +tryFunDeps :: EqRel -> EqCt -> SolverStage () +tryFunDeps eq_rel work_item@(EqCt { eq_lhs = lhs, eq_ev = ev }) + | NomEq <- eq_rel + , TyFamLHS tc args <- lhs + = Stage $ + do { inerts <- getInertCans + ; imp1 <- improveLocalFunEqs inerts tc args work_item + ; imp2 <- improveTopFunEqs tc args work_item + ; if (imp1 || imp2) + then startAgainWith (mkNonCanonical ev) + else continueWith () } + | otherwise + = nopStage () + +-------------------- +improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> TcS Bool +-- TyCon is definitely a type family +-- See Note [FunDep and implicit parameter reactions] in GHC.Tc.Solver.Dict +improveTopFunEqs fam_tc args (EqCt { eq_ev = ev, eq_rhs = rhs_ty }) + | isGiven ev = improveGivenTopFunEqs fam_tc args ev rhs_ty + | otherwise = improveWantedTopFunEqs fam_tc args ev rhs_ty + +improveGivenTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool +-- TyCon is definitely a type family +-- Work-item is a Given +improveGivenTopFunEqs fam_tc args ev rhs_ty + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = do { traceTcS "improveGivenTopFunEqs" (ppr fam_tc <+> ppr args $$ ppr ev $$ ppr rhs_ty) + ; emitNewGivens (ctEvLoc ev) $ + [ (Nominal, new_co) + | (ax, _) <- tryInteractTopFam ops fam_tc args rhs_ty + , let new_co = mkAxiomCo ax [given_co] ] + ; return False } -- False: no unifications + | otherwise + = return False + where + given_co :: Coercion = ctEvCoercion ev + +improveWantedTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool +-- TyCon is definitely a type family +-- Work-item is a Wanted +improveWantedTopFunEqs fam_tc args ev rhs_ty + = do { eqns <- improve_wanted_top_fun_eqs fam_tc args rhs_ty + ; traceTcS "improveTopFunEqs" (vcat [ text "lhs:" <+> ppr fam_tc <+> ppr args + , text "rhs:" <+> ppr rhs_ty + , text "eqns:" <+> ppr eqns ]) + ; unifyFunDeps ev Nominal $ \uenv -> + uPairsTcM (bump_depth uenv) (reverse eqns) } + -- Missing that `reverse` causes T13135 and T13135_simple to loop. + -- See Note [Reverse order of fundep equations] + + where + bump_depth env = env { u_loc = bumpCtLocDepth (u_loc env) } + -- ToDo: this location is wrong; it should be FunDepOrigin2 + -- See #14778 + +improve_wanted_top_fun_eqs :: TyCon -> [TcType] -> Xi + -> TcS [TypeEqn] +-- TyCon is definitely a type family +improve_wanted_top_fun_eqs fam_tc lhs_tys rhs_ty + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = return (map snd $ tryInteractTopFam ops fam_tc lhs_tys rhs_ty) + + -- See Note [Type inference for type families with injectivity] + | Injective inj_args <- tyConInjectivityInfo fam_tc + = do { fam_envs <- getFamInstEnvs + ; top_eqns <- improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty + ; let local_eqns = improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty + ; traceTcS "improve_wanted_top_fun_eqs" $ + vcat [ ppr fam_tc, text "local_eqns" <+> ppr local_eqns, text "top_eqns" <+> ppr top_eqns ] + ; return (local_eqns ++ top_eqns) } + + | otherwise -- No injectivity + = return [] + +improve_injective_wanted_top :: FamInstEnvs -> [Bool] -> TyCon -> [TcType] -> Xi -> TcS [TypeEqn] +-- Interact with top-level instance declarations +-- See Section 5.2 in the Injective Type Families paper +improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty + = concatMapM do_one branches + where + branches :: [CoAxBranch] + branches | isOpenTypeFamilyTyCon fam_tc + , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc + = concatMap (fromBranches . coAxiomBranches . fi_axiom) fam_insts + + | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc + = fromBranches (coAxiomBranches ax) + + | otherwise + = [] + + do_one :: CoAxBranch -> TcS [TypeEqn] + do_one branch@(CoAxBranch { cab_tvs = branch_tvs, cab_lhs = branch_lhs_tys, cab_rhs = branch_rhs }) + | let in_scope1 = in_scope `extendInScopeSetList` branch_tvs + , Just subst <- tcUnifyTyForInjectivity False in_scope1 branch_rhs rhs_ty + -- False: matching, not unifying + = do { let inSubst tv = tv `elemVarEnv` getTvSubstEnv subst + unsubstTvs = filterOut inSubst branch_tvs + -- The order of unsubstTvs is important; it must be + -- in telescope order e.g. (k:*) (a:k) + + ; subst1 <- instFlexiX subst unsubstTvs + -- If the current substitution bind [k -> *], and + -- one of the un-substituted tyvars is (a::k), we'd better + -- be sure to apply the current substitution to a's kind. + -- Hence instFlexiX. #13135 was an example. + + ; traceTcS "improve_inj_top" $ + vcat [ text "branch_rhs" <+> ppr branch_rhs + , text "rhs_ty" <+> ppr rhs_ty + , text "subst" <+> ppr subst + , text "subst1" <+> ppr subst1 ] + ; if apartnessCheck (substTys subst1 branch_lhs_tys) branch + then do { traceTcS "improv_inj_top1" (ppr branch_lhs_tys) + ; return (mkInjectivityEqns inj_args (map (substTy subst1) branch_lhs_tys) lhs_tys) } + -- NB: The fresh unification variables (from unsubstTvs) are on the left + -- See Note [Improvement orientation] + else do { traceTcS "improve_inj_top2" empty; return [] } } + | otherwise + = do { traceTcS "improve_inj_top:fail" (ppr branch_rhs $$ ppr rhs_ty $$ ppr in_scope $$ ppr branch_tvs) + ; return [] } + + in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty) + + +improve_injective_wanted_famfam :: [Bool] -> TyCon -> [TcType] -> Xi -> [TypeEqn] +-- Interact with itself, specifically F s1 s2 ~ F t1 t2 +improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty + | Just (tc, rhs_tys) <- tcSplitTyConApp_maybe rhs_ty + , tc == fam_tc + = mkInjectivityEqns inj_args lhs_tys rhs_tys + | otherwise + = [] + +mkInjectivityEqns :: [Bool] -> [TcType] -> [TcType] -> [TypeEqn] +-- When F s1 s2 s3 ~ F t1 t2 t3, and F has injectivity info [True,False,True] +-- return the equations [Pair s1 t1, Pair s3 t3] +mkInjectivityEqns inj_args lhs_args rhs_args + = [ Pair lhs_arg rhs_arg | (True, lhs_arg, rhs_arg) <- zip3 inj_args lhs_args rhs_args ] + +--------------------------------------------- +improveLocalFunEqs :: InertCans + -> TyCon -> [TcType] -> EqCt -- F args ~ rhs + -> TcS Bool +-- Emit equalities from interaction between two equalities +improveLocalFunEqs inerts fam_tc args (EqCt { eq_ev = work_ev, eq_rhs = rhs }) + | isGiven work_ev = improveGivenLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs + | otherwise = improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs + where + funeqs = inert_funeqs inerts + funeqs_for_tc :: [EqCt] -- Mixture of Given and Wanted + funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc + , funeq_ct <- equal_ct_list + , NomEq == eq_eq_rel funeq_ct ] + -- Representational equalities don't interact + -- with type family dependencies + + +improveGivenLocalFunEqs :: [EqCt] -- Inert items, mixture of Given and Wanted + -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Given) + -> TcS Bool -- Always False (no unifications) +-- Emit equalities from interaction between two Given type-family equalities +-- e.g. (x+y1~z, x+y2~z) => (y1 ~ y2) +improveGivenLocalFunEqs funeqs_for_tc fam_tc work_args work_ev work_rhs + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = do { mapM_ (do_one ops) funeqs_for_tc + ; return False } -- False: no unifications + | otherwise + = return False + where + given_co :: Coercion = ctEvCoercion work_ev + + do_one :: BuiltInSynFamily -> EqCt -> TcS () + -- Used only work-item is Given + do_one ops EqCt { eq_ev = inert_ev, eq_lhs = inert_lhs, eq_rhs = inert_rhs } + | isGiven inert_ev -- Given/Given interaction + , TyFamLHS _ inert_args <- inert_lhs -- Inert item is F inert_args ~ inert_rhs + , work_rhs `tcEqType` inert_rhs -- Both RHSs are the same + , -- So we have work_ev : F work_args ~ rhs + -- inert_ev : F inert_args ~ rhs + let pairs :: [(CoAxiomRule, TypeEqn)] + pairs = tryInteractInertFam ops fam_tc work_args inert_args + , not (null pairs) + = do { traceTcS "improveGivenLocalFunEqs" (vcat[ ppr fam_tc <+> ppr work_args + , text "work_ev" <+> ppr work_ev + , text "inert_ev" <+> ppr inert_ev + , ppr work_rhs + , ppr pairs ]) + ; emitNewGivens (ctEvLoc inert_ev) (map mk_ax_co pairs) } + -- This CtLoc for the new Givens doesn't reflect the + -- fact that it's a combination of Givens, but I don't + -- this that matters. + where + inert_co = ctEvCoercion inert_ev + mk_ax_co (ax,_) = (Nominal, mkAxiomCo ax [combined_co]) + where + combined_co = given_co `mkTransCo` mkSymCo inert_co + -- given_co :: F work_args ~ rhs + -- inert_co :: F inert_args ~ rhs + -- the_co :: F work_args ~ F inert_args + + do_one _ _ = return () + +improveWantedLocalFunEqs + :: [EqCt] -- Inert items (Given and Wanted) + -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Wanted) + -> TcS Bool -- True <=> some unifications +-- Emit improvement equalities for a Wanted constraint, by comparing +-- the current work item with inert CFunEqs (boh Given and Wanted) +-- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y' +-- +-- See Note [FunDep and implicit parameter reactions] in GHC.Tc.Solver.Dict +improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs + | null improvement_eqns + = return False + | otherwise + = do { traceTcS "interactFunEq improvements: " $ + vcat [ text "Eqns:" <+> ppr improvement_eqns + , text "Candidates:" <+> ppr funeqs_for_tc ] + ; emitFunDepWanteds work_ev improvement_eqns } + where + work_loc = ctEvLoc work_ev + work_pred = ctEvPred work_ev + fam_inj_info = tyConInjectivityInfo fam_tc + + -------------------- + improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)] + improvement_eqns + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = -- Try built-in families, notably for arithmethic + concatMap (do_one_built_in ops rhs) funeqs_for_tc + + | Injective injective_args <- fam_inj_info + = -- Try improvement from type families with injectivity annotations + concatMap (do_one_injective injective_args rhs) funeqs_for_tc + + | otherwise + = [] + + -------------------- + do_one_built_in ops rhs (EqCt { eq_lhs = TyFamLHS _ iargs, eq_rhs = irhs, eq_ev = inert_ev }) + | irhs `tcEqType` rhs + = mk_fd_eqns inert_ev (map snd $ tryInteractInertFam ops fam_tc args iargs) + | otherwise + = [] + do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -- TyVarLHS + + -------------------- + -- See Note [Type inference for type families with injectivity] + do_one_injective inj_args rhs (EqCt { eq_lhs = TyFamLHS _ inert_args + , eq_rhs = irhs, eq_ev = inert_ev }) + | rhs `tcEqType` irhs + = mk_fd_eqns inert_ev $ mkInjectivityEqns inj_args args inert_args + | otherwise + = [] + + do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS + + -------------------- + mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)] + mk_fd_eqns inert_ev eqns + | null eqns = [] + | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns + , fd_loc = (loc, inert_rewriters) } ] + where + initial_loc -- start with the location of the Wanted involved + | isGiven work_ev = inert_loc + | otherwise = work_loc + eqn_orig = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc) + inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc) + eqn_loc = setCtLocOrigin initial_loc eqn_orig + inert_pred = ctEvPred inert_ev + inert_loc = ctEvLoc inert_ev + inert_rewriters = ctEvRewriters inert_ev + loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` + ctl_depth work_loc } + +{- Note [Type inference for type families with injectivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a type family with an injectivity annotation: + type family F a b = r | r -> b + +Then if we have an equality like F s1 t1 ~ F s2 t2, +we can use the injectivity to get a new Wanted constraint on +the injective argument + [W] t1 ~ t2 + +That in turn can help GHC solve constraints that would otherwise require +guessing. For example, consider the ambiguity check for + f :: F Int b -> Int +We get the constraint + [W] F Int b ~ F Int beta +where beta is a unification variable. Injectivity lets us pick beta ~ b. + +Injectivity information is also used at the call sites. For example: + g = f True +gives rise to + [W] F Int b ~ Bool +from which we can derive b. This requires looking at the defining equations of +a type family, ie. finding equation with a matching RHS (Bool in this example) +and inferring values of type variables (b in this example) from the LHS patterns +of the matching equation. For closed type families we have to perform +additional apartness check for the selected equation to check that the selected +is guaranteed to fire for given LHS arguments. + +These new constraints are Wanted constraints, but we will not use the evidence. +We could go further and offer evidence from decomposing injective type-function +applications, but that would require new evidence forms, and an extension to +FC, so we don't do that right now (Dec 14). + +We generate these Wanteds in three places, depending on how we notice the +injectivity. + +1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and +described in Note [Decomposing type family applications] in GHC.Tc.Solver.Equality + +2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these +constraints rewrites the other, as they have different LHSs. This is done +in improveLocalFunEqs, called during the interactWithInertsStage. + +3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T. +This is done in improve_top_fun_eqs, called from the top-level reactions stage. + +See also Note [Injective type families] in GHC.Core.TyCon + +Note [Cache-caused loops] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very dangerous to cache a rewritten wanted family equation as 'solved' in our +solved cache (which is the default behaviour or xCtEvidence), because the interaction +may not be contributing towards a solution. Here is an example: + +Initial inert set: + [W] g1 : F a ~ beta1 +Work item: + [W] g2 : F a ~ beta2 +The work item will react with the inert yielding the _same_ inert set plus: + (i) Will set g2 := g1 `cast` g3 + (ii) Will add to our solved cache that [S] g2 : F a ~ beta2 + (iii) Will emit [W] g3 : beta1 ~ beta2 +Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 +and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it +will set + g1 := g ; sym g3 +and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but +remember that we have this in our solved cache, and it is ... g2! In short we +created the evidence loop: + + g2 := g1 ; g3 + g3 := refl + g1 := g2 ; sym g3 + +To avoid this situation we do not cache as solved any workitems (or inert) +which did not really made a 'step' towards proving some goal. Solved's are +just an optimization so we don't lose anything in terms of completeness of +solving. +-} diff --git a/GHC/Tc/Solver/InertSet.hs b/GHC/Tc/Solver/InertSet.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/InertSet.hs @@ -0,0 +1,2142 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +module GHC.Tc.Solver.InertSet ( + -- * The work list + WorkList(..), isEmptyWorkList, emptyWorkList, + extendWorkListNonEq, extendWorkListCt, + extendWorkListCts, extendWorkListCtList, + extendWorkListEq, extendWorkListChildEqs, + extendWorkListRewrittenEqs, + appendWorkList, + workListSize, + + -- * The inert set + InertSet(..), + InertCans(..), + emptyInertSet, emptyInertCans, + + noGivenNewtypeReprEqs, updGivenEqs, + prohibitedSuperClassSolve, + + -- * Inert equalities + InertEqs, + foldTyEqs, delEq, findEq, + partitionInertEqs, partitionFunEqs, + filterInertEqs, filterFunEqs, + foldFunEqs, addEqToCans, + + -- * Inert Dicts + updDicts, delDict, addDict, filterDicts, partitionDicts, + addSolvedDict, lookupSolvedDict, lookupInertDict, + + -- * Inert Irreds + InertIrreds, delIrred, addIrreds, addIrred, foldIrreds, + findMatchingIrreds, updIrreds, addIrredToCans, + + -- * Kick-out + KickOutSpec(..), kickOutRewritableLHS, + + -- * Cycle breaker vars + CycleBreakerVarStack, + pushCycleBreakerVarStack, + addCycleBreakerBindings, + forAllCycleBreakerBindings_, + + -- * Solving one from another + InteractResult(..), solveOneFromTheOther + + ) where + +import GHC.Prelude + +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin, ctLocSpan, ctLocLevel ) +import GHC.Tc.Solver.Types +import GHC.Tc.Utils.TcType + +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique( hasKey ) +import GHC.Types.Basic( SwapFlag(..) ) + +import GHC.Core.Reduction +import GHC.Core.Predicate +import qualified GHC.Core.TyCo.Rep as Rep +import GHC.Core.TyCon +import GHC.Core.Class( Class, classTyCon ) +import GHC.Builtin.Names( eqPrimTyConKey, heqTyConKey, eqTyConKey, coercibleTyConKey ) +import GHC.Utils.Misc ( partitionWith ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.Bag + +import Control.Monad ( forM_ ) +import Data.List.NonEmpty ( NonEmpty(..), (<|) ) +import Data.Function ( on ) + +{- +************************************************************************ +* * +* 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 over class constraints: + +* (Efficiency) The general reason to do so is that if we process a + class constraint first, we may end up putting it into the inert set + and then kicking it out later. That's extra work compared to just + doing the equality first. + +* (Avoiding fundep iteration) As #14723 showed, it's possible to + get non-termination if we + - Emit the fundep equalities for a class constraint, + generating some fresh unification variables. + - That leads to some unification + - Which kicks out the class constraint + - Which isn't solved (because there are still some more + equalities in the work-list), but generates yet more fundeps + Solution: prioritise equalities over class constraints + +* (Class equalities) We need to prioritise equalities even if they + are hidden inside a class constraint; see Note [Prioritise class equalities] + +* (Kick-out) We want to apply this priority scheme to kicked-out + constraints too (see the call to extendWorkListCt in kick_out_rewritable) + E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become + homo-kinded when kicked out, and hence we want to prioritise it. + +Further refinements: + +* Among the equalities we prioritise ones with an empty rewriter set; + see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint, wrinkle (W1). + +* Among equalities with an empty rewriter set, we prioritise nominal equalities. + * They have more rewriting power, so doing them first is better. + * Prioritising them ameliorates the incompleteness of newtype + solving: see (Ex2) in Note [Decomposing newtype equalities] in + GHC.Tc.Solver.Equality. + +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_N :: [Ct] -- /Nominal/ equalities (s ~#N t), (s ~ t), (s ~~ t) + -- with definitely-empty rewriter set + + , wl_eqs_X :: [Ct] -- CEqCan, CDictCan, CIrredCan + -- with definitely-empty rewriter set + -- All other equalities: contains both equality constraints and + -- their class-level variants (a~b) and (a~~b); + -- See Note [Prioritise equalities] + -- See Note [Prioritise class equalities] + + , wl_rw_eqs :: [Ct] -- Like wl_eqs, but ones that may have a non-empty + -- rewriter set + -- We prioritise wl_eqs over wl_rw_eqs; + -- see Note [Prioritise Wanteds with empty RewriterSet] + -- in GHC.Tc.Types.Constraint for more details. + + , wl_rest :: [Ct] + } + +isNominalEqualityCt :: Ct -> Bool +-- A nominal equality, primitive or not, +-- canonical or not +-- (s ~# t), (s ~ t), or (s ~~ t) +isNominalEqualityCt ct + | Just tc <- tcTyConAppTyCon_maybe (ctPred ct) + = tc `hasKey` eqPrimTyConKey || tc `hasKey` heqTyConKey || tc `hasKey` eqTyConKey + | otherwise + = False + +appendWorkList :: WorkList -> WorkList -> WorkList +appendWorkList + (WL { wl_eqs_N = eqs1_N, wl_eqs_X = eqs1_X, wl_rw_eqs = rw_eqs1, wl_rest = rest1 }) + (WL { wl_eqs_N = eqs2_N, wl_eqs_X = eqs2_X, wl_rw_eqs = rw_eqs2, wl_rest = rest2 }) + = WL { wl_eqs_N = eqs1_N ++ eqs2_N + , wl_eqs_X = eqs1_X ++ eqs2_X + , wl_rw_eqs = rw_eqs1 ++ rw_eqs2 + , wl_rest = rest1 ++ rest2 } + +workListSize :: WorkList -> Int +workListSize (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs, wl_rest = rest }) + = length eqs_N + length eqs_X + length rw_eqs + length rest + +extendWorkListEq :: RewriterSet -> Ct -> WorkList -> WorkList +extendWorkListEq rewriters ct + wl@(WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs }) + | isEmptyRewriterSet rewriters -- A wanted that has not been rewritten + -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet] + -- in GHC.Tc.Types.Constraint + = if isNominalEqualityCt ct + then wl { wl_eqs_N = ct : eqs_N } + else wl { wl_eqs_X = ct : eqs_X } + + | otherwise + = wl { wl_rw_eqs = ct : rw_eqs } + +extendWorkListChildEqs :: CtEvidence -> Bag Ct -> WorkList -> WorkList +-- Add [eq1,...,eqn] to the work-list +-- The constraints will be solved in left-to-right order: +-- see Note [Work-list ordering] in GHC.Tc.Solver.Equality +-- +-- Precondition: if the parent constraint has an empty +-- rewriter set, so will the new equalities +-- Precondition: new_eqs is non-empty +extendWorkListChildEqs parent_ev new_eqs + wl@(WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs }) + | isEmptyRewriterSet (ctEvRewriters parent_ev) + -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet] + -- in GHC.Tc.Types.Constraint + -- If the rewriter set is empty, add to wl_eqs_X and wl_eqs_N + = case partitionBag isNominalEqualityCt new_eqs of + (new_eqs_N, new_eqs_X) + | isEmptyBag new_eqs_N -> wl { wl_eqs_X = new_eqs_X `push_on_front` eqs_X } + | isEmptyBag new_eqs_X -> wl { wl_eqs_N = new_eqs_N `push_on_front` eqs_N } + | otherwise -> wl { wl_eqs_N = new_eqs_N `push_on_front` eqs_N + , wl_eqs_X = new_eqs_X `push_on_front` eqs_X } + -- These isEmptyBag tests are just trying + -- to avoid creating unnecessary thunks + + | otherwise -- If the rewriter set is non-empty, add to wl_rw_eqs + = wl { wl_rw_eqs = new_eqs `push_on_front` rw_eqs } + where + push_on_front :: Bag Ct -> [Ct] -> [Ct] + -- push_on_front puts the new equalities on the front of the queue + push_on_front new_eqs eqs = foldr (:) eqs new_eqs + +extendWorkListRewrittenEqs :: [EqCt] -> WorkList -> WorkList +-- Don't bother checking the RewriterSet: just pop them into wl_rw_eqs +extendWorkListRewrittenEqs new_eqs wl@(WL { wl_rw_eqs = rw_eqs }) + = wl { wl_rw_eqs = foldr ((:) . CEqCan) rw_eqs new_eqs } + +extendWorkListNonEq :: Ct -> WorkList -> WorkList +-- Extension by non equality +extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } + +extendWorkListCt :: Ct -> WorkList -> WorkList +-- Agnostic about what kind of constraint +extendWorkListCt ct wl + = case classifyPredType (ctEvPred ev) of + EqPred {} + -> extendWorkListEq rewriters ct wl + + ClassPred cls _ -- See Note [Prioritise class equalities] + | isEqualityClass cls + -> extendWorkListEq rewriters ct wl + + _ -> extendWorkListNonEq ct wl + where + ev = ctEvidence ct + rewriters = ctEvRewriters ev + +extendWorkListCtList :: [Ct] -> WorkList -> WorkList +extendWorkListCtList cts wl = foldr extendWorkListCt wl cts + +extendWorkListCts :: Cts -> WorkList -> WorkList +extendWorkListCts cts wl = foldr extendWorkListCt wl cts + +isEmptyWorkList :: WorkList -> Bool +isEmptyWorkList (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X + , wl_rw_eqs = rw_eqs, wl_rest = rest }) + = null eqs_N && null eqs_X && null rw_eqs && null rest + +emptyWorkList :: WorkList +emptyWorkList = WL { wl_eqs_N = [], wl_eqs_X = [] + , wl_rw_eqs = [], wl_rest = [] } + +-- Pretty printing +instance Outputable WorkList where + ppr (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X + , wl_rw_eqs = rw_eqs, wl_rest = rest }) + = text "WL" <+> (braces $ + vcat [ ppUnless (null eqs_N) $ + text "Eqs_N =" <+> vcat (map ppr eqs_N) + , ppUnless (null eqs_X) $ + text "Eqs_X =" <+> vcat (map ppr eqs_X) + , ppUnless (null rw_eqs) $ + text "RwEqs =" <+> vcat (map ppr rw_eqs) + , ppUnless (null rest) $ + text "Non-eqs =" <+> vcat (map ppr rest) + ]) + +{- ********************************************************************* +* * + InertSet: the inert set +* * +* * +********************************************************************* -} + +type CycleBreakerVarStack = NonEmpty (Bag (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.Equality + -- Why store the outer implications? For the use in mightEqualLater (only) + -- + -- Why NonEmpty? So there is always a top element to add to + +data InertSet + = IS { inert_cans :: InertCans + -- Canonical Given, Wanted + -- Sometimes called "the inert set" + + , inert_givens :: InertCans + -- A subset of inert_cans, containing only Givens + -- Used to initialise inert_cans when recursing inside implications + + , inert_cycle_breakers :: CycleBreakerVarStack + + , inert_famapp_cache :: FunEqMap Reduction + -- Just a hash-cons cache for use when reducing family applications + -- only + -- + -- If F tys :-> (co, rhs, flav), + -- then co :: F tys ~N rhs + -- all evidence is from instances or Givens; no coercion holes here + -- (We have no way of "kicking out" from the cache, so putting + -- wanteds here means we can end up solving a Wanted with itself. Bad) + + , inert_solved_dicts :: DictMap DictCt + -- All Wanteds, of form (C t1 .. tn) + -- Always a dictionary solved by an instance decl; never an implict parameter + -- See Note [Solved dictionaries] + -- and Note [Do not add superclasses of solved dictionaries] + + , inert_safehask :: DictMap DictCt + -- 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 + } + +instance Outputable InertSet where + ppr (IS { inert_cans = ics + , inert_safehask = safehask + , inert_solved_dicts = solved_dicts }) + = vcat [ ppr ics + , ppUnless (null dicts) $ + text "Solved dicts =" <+> vcat (map ppr dicts) + , ppUnless (isEmptyTcAppMap safehask) $ + text "Safe Haskell unsafe overlap =" <+> pprBag (dictsToBag safehask) ] + where + dicts = bagToList (dictsToBag solved_dicts) + +emptyInertCans :: TcLevel -> InertCans +emptyInertCans given_eq_lvl + = IC { inert_eqs = emptyTyEqs + , inert_funeqs = emptyFunEqs + , inert_given_eq_lvl = given_eq_lvl + , inert_given_eqs = False + , inert_dicts = emptyDictMap + , inert_qcis = [] + , inert_irreds = emptyBag } + +emptyInertSet :: TcLevel -> InertSet +emptyInertSet given_eq_lvl + = IS { inert_cans = empty_cans + , inert_givens = empty_cans + , inert_cycle_breakers = emptyBag :| [] + , inert_famapp_cache = emptyFunEqs + , inert_solved_dicts = emptyDictMap + , inert_safehask = emptyDictMap } + where + empty_cans = emptyInertCans given_eq_lvl + +{- 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 applying 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.Dict.tryInstances + + - ClsInst.InstanceWhat says what kind of instance was + used to solve the constraint. In particular + * LocalInstance identifies quantified constraints + * BuiltinEqInstance identifies the strange built-in + instances for equality. + + - ClsInst.instanceReturnsDictCon says which kind of + instance guarantees to return a dictionary constructor + +Other notes about solved dictionaries + +* See also Note [Do not add superclasses of solved dictionaries] + +* The inert_solved_dicts field is not rewritten by equalities, + so it may get out of date. + +* The inert_solved_dicts are all Wanteds, never givens + +* We only cache dictionaries from top-level instances, not from + local quantified constraints. Reason: if we cached the latter + we'd need to purge the cache when bringing new quantified + constraints into scope, because quantified constraints "shadow" + top-level instances. + +Note [Do not add superclasses of solved dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every member of inert_solved_dicts is the result of applying a +dictionary function, NOT of applying superclass selection to anything. +Consider + + class Ord a => C a where + instance Ord [a] => C [a] where ... + +Suppose we are trying to solve + [G] d1 : Ord a + [W] d2 : C [a] + +Then we'll use the instance decl to give + + [G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3 + [W] d3 : Ord [a] + +We must not add d4 : Ord [a] to the 'solved' set (by taking the +superclass of d2), otherwise we'll use it to solve d3, without ever +using d1, which would be a catastrophe. + +Solution: when extending the solved dictionaries, do not add superclasses. +That's why each element of the inert_solved_dicts is the result of applying +a dictionary function. + +Note [Example of recursive dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +--- Example 1 + + data D r = ZeroD | SuccD (r (D r)); + + instance (Eq (r (D r))) => Eq (D r) where + ZeroD == ZeroD = True + (SuccD a) == (SuccD b) = a == b + _ == _ = False; + + equalDC :: D [] -> D [] -> Bool; + equalDC = (==); + +We need to prove (Eq (D [])). Here's how we go: + + [W] d1 : Eq (D []) +By instance decl of Eq (D r): + [W] d2 : Eq [D []] where d1 = dfEqD d2 +By instance decl of Eq [a]: + [W] d3 : Eq (D []) where d2 = dfEqList d3 + d1 = dfEqD d2 +Now this wanted can interact with our "solved" d1 to get: + d3 = d1 + +-- Example 2: +This code arises in the context of "Scrap Your Boilerplate with Class" + + class Sat a + class Data ctx a + instance Sat (ctx Char) => Data ctx Char -- dfunData1 + instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 + + class Data Maybe a => Foo a + + instance Foo t => Sat (Maybe t) -- dfunSat + + instance Data Maybe a => Foo a -- dfunFoo1 + instance Foo a => Foo [a] -- dfunFoo2 + instance Foo [Char] -- dfunFoo3 + +Consider generating the superclasses of the instance declaration + instance Foo a => Foo [a] + +So our problem is this + [G] d0 : Foo t + [W] d1 : Data Maybe [t] -- Desired superclass + +We may add the given in the inert set, along with its superclasses + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + WorkList + [W] d1 : Data Maybe [t] + +Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + WorkList: + [W] d2 : Sat (Maybe [t]) + [W] d3 : Data Maybe t + +Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + WorkList: + [W] d3 : Data Maybe t + [W] d4 : Foo [t] + +Now, we can just solve d3 from d01; d3 := d01 + Inert + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + WorkList + [W] d4 : Foo [t] + +Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 + Inert + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + d4 : Foo [t] + WorkList: + [W] d5 : Foo t + +Now, d5 can be solved! d5 := d0 + +Result + d1 := dfunData2 d2 d3 + d2 := dfunSat d4 + d3 := d01 + d4 := dfunFoo2 d5 + d5 := d0 +-} + +{- ********************************************************************* +* * + InertCans: the canonical inerts +* * +* * +********************************************************************* -} + +{- Note [Tracking Given equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify +Note [Unification preconditions], we can't unify + alpha[2] ~ Int +under a level-4 implication if there are any Given equalities +bound by the implications at level 3 of 4. To that end, the +InertCans tracks + + inert_given_eq_lvl :: TcLevel + -- The TcLevel of the innermost implication that has a Given + -- equality of the sort that make a unification variable untouchable + -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify). + +We update inert_given_eq_lvl whenever we add a Given to the +inert set, in updGivenEqs. + +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? + +(TGE1) We do /not/ need to worry about let-bound skolems, such as + forall[2] a. a ~ [b] => blah + See Note [Let-bound skolems] and the isOuterTyVar tests in `updGivenEqs` + +(TGE2) 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 subsequntly (see + `getHasGivenEqs`), to set the ic_given_eqs field to LocalGivenEqs. + +(TGE3) 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). + +(TGE4) 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, updGivenEqs conservatively + treats it as a potential equality, and updates inert_give_eq_lvl + +(TGE5) We should 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. + +(TGE6) A subtle point is this: when initialising the solver, giving it + an empty InertSet, we must conservatively initialise `inert_given_lvl` + to the /current/ TcLevel. This matters when doing let-generalisation. + Consider #26004: + f w e = case e of + T1 -> let y = not w in False -- T1 is a GADT + T2 -> True + When let-generalising `y`, we will have (w :: alpha[1]) in the type + envt; and we are under GADT pattern match. So when we solve the + constraints from y's RHS, in simplifyInfer, we must NOT unify + alpha[1] := Bool + Since we don't know what enclosing equalities there are, we just + conservatively assume that there are some. + + This initialisation in done in `runTcSWithEvBinds`, which passes + the current TcLevel to `emptyInertSet`. + +Historical note: prior to #24938 we also ignored Given equalities that +did not mention an "outer" type variable. But that is wrong, as #24938 +showed. Another example is immortalised in test LocalGivenEqs2 + data T where + MkT :: F a ~ G b => a -> b -> T + f (MkT _ _) = True +We should not infer the type for `f`; let-bound-skolems does not apply. + +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. + +The actual test is in `isLetBoundSkolemCt` + +Wrinkles: + +(LBS1) See GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure + that the correct variable is on the left of the equality when both are + tyvars. + +(LBS2) We also want this to work for + forall a. [G] F b ~ a (CEqCt with TyFamLHS) + Here the Given will have a TyFamLHS, with the skolem-bound tyvar on the RHS. + See tests T24938a, and LocalGivenEqs. + +(LBS3) Happily (LBS2) also makes cycle-breakers work. Suppose we have + forall a. [G] (F a) Int ~ a + where F has arity 1, and `a` is the locally-bound skolem. Then, as + Note [Type equality cycles] explains, we split into + [G] F a ~ cbv, [G] cbv Int ~ a + where `cbv` is the cycle breaker variable. But cbv has the same level + as `a`, so `isOuterTyVar` (called in `isLetBoundSkolemCt`) will return False. + + This actually matters occasionally: see test LocalGivenEqs. + +You might wonder whether the skolem really needs to be bound "in the +very same implication" as the equality constraint. +Consider this (c.f. #15009): + + data S a where + MkS :: (a ~ Int) => S a + + g :: forall a. S a -> a -> blah + g x y = let h = \z. ( z :: Int + , case x of + MkS -> [y,z]) + in ... + +From the type signature for `g`, we get `y::a` . Then when we +encounter the `\z`, we'll assign `z :: alpha[1]`, say. Next, from the +body of the lambda we'll get + + [W] alpha[1] ~ Int -- From z::Int + [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a -- From [y,z] + +Now, unify alpha := a. Now we are stuck with an unsolved alpha~Int! +So we must treat alpha as untouchable under the forall[2] implication. + +Possible future improvements. The current test just looks to see whether one +side of an equality is a locally-bound skolem. But actually we could, in +theory, do better: if one side (or both sides, actually) of an equality +ineluctably mentions a local skolem, then the equality cannot possibly impact +types outside of the implication (because doing to would cause those types to be +ill-scoped). The problem is the "ineluctably": this means that no expansion, +other solving, etc., could possibly get rid of the variable. This is hard, +perhaps impossible, to know for sure, especially when we think about type family +interactions. (And it's a user-visible property so we don't want it to be hard +to predict.) So we keep the existing check, looking for one lone variable, +because we're sure that variable isn't going anywhere. + +Note [Detailed InertCans Invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The InertCans represents a collection of constraints with the following properties: + + * All canonical + + * No two dictionaries with the same head + * No two CIrreds with the same type + + * Family equations inert wrt top-level family axioms + + * Dictionaries have no matching top-level instance + + * Given family or dictionary constraints don't mention touchable + unification variables + + * Non-CEqCan constraints are fully rewritten with respect + to the CEqCan equalities (modulo eqCanRewrite of course; + eg a wanted cannot rewrite a given) + + * CEqCan equalities: see Note [inert_eqs: the inert equalities] + Also see documentation in Constraint.Ct for a list of invariants + +Note [inert_eqs: the inert equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our main invariant: + the EqCts in inert_eqs should be a + terminating generalised substitution + +-------------- 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 + + (WF3) No LHS in S is rewritable in an RHS in S, + in the argument of a type family application (F ty1..tyn) + where F heads a LHS in S + +--------- Definition [Applying a generalised substitution] ---------- +If S is a generalised substitution + S(f,lhs) = rhs, if (lhs -fs-> rhs) in S, and fs >= f + S(f,T t1..tn) = T S(f1,t1)..S(fn,tn) + S(f,t1 t2) = S(f,t1) S(f_N,t2) + S(f,t) = t +Here f1..fn are obtained from f and T using the roles of T, and f_N is +the nominal version of f. See Note [Flavours with roles]. + +Notation: repeated application. + S^0(f,t) = t + S^(n+1)(f,t) = S(f, S^n(t)) + S*(f,t) is the result of applying S until you reach a fixpoint + +--------- Definition [Terminating generalised substitution] --------- +A generalised substitution S is *terminating* iff + + (IG1) for every f,t, there is an n such that + 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. +--------- End of definitions ------------------------------------ + + +Rationale for (WF1)-(WF3) +------------------------- +* (WF1) guarantees that S is well-defined /as a function/; + see Theorem (S is a function) + + Theorem (S is a function): 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) + Note: this argument isn't quite right. WF1 ensures that lhs1 does + not appear inside lhs2, and that guarantees confluence. But I can't quite + see how to make that argument precise. + +* (WF2) is a bit trivial. It means that if S is terminating, so that + S^(n+1)(f,t) = S^n(f,t), then there is no LHS of S in S^n(f,t). We + never get a silly infinite sequence a -> a -> a -> a .... which is + technically a fixed point but would still go on for ever. + +* (WF3) is need for the termination proof. + +Note that termination is not the same as idempotence. To apply S to a +type, you may have to apply it recursively. But termination does +guarantee that this recursive use will terminate. + +Note [Why R2?] +~~~~~~~~~~~~~~ +R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >= +f1. If we do not have R2, we will easily fall into a loop. + +To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our +inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And +yet, we have a hard time noticing an occurs-check problem when building S, as +the two equalities cannot rewrite one another. + +R2 actually restricts our ability to accept user-written programs. See +Note [Avoiding rewriting cycles] in GHC.Tc.Types.Constraint for an example. + +Note [Rewritable] +~~~~~~~~~~~~~~~~~ +Definition. 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. + +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. + +This definition is used by the anyRewritableXXX family of functions and is meant +to model the actual behaviour in GHC.Tc.Solver.Rewrite. + +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. + +Wrinkles + +* 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. + +* 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.Equality.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. + +Note [Extending the inert equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Main Theorem [Stability under extension] + GIVEN a "work item" [lhs_w -fw-> rhs_w] + and a terminating generalised substitution S, + + SUCH THAT + (T1) S(fw,lhs_w) = lhs_w -- LHS of work-item is a fixpoint of S(fw,_) + (T2) S(fw,rhs_w) = rhs_w -- RHS of work-item is a fixpoint of S(fw,_) + (T3) lhs_w not in rhs_w -- No occurs check in the work item + -- If lhs is a type family application, we require only that + -- lhs is not *rewritable* in rhs_w. See Note [Rewritable] and + -- Note [EqCt occurs check] in GHC.Tc.Types.Constraint. + (T4) no [lhs_s -fs-> rhs_s] in S meets [The KickOut Criteria] + (i.e. we already kicked any such items out!) + + THEN the extended substitution T = S+(lhs_w -fw-> rhs_w) + is a terminating generalised substitution + +How do we establish these conditions? + + * (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 [EqCt occurs check] in GHC.Tc.Types.Constraint. + + * (T4) is established by GHC.Tc.Solver.Monad.kickOutRewritable. If the inert + set contains a triple that meets the KickOut Criteria, we kick it out and + add it to the work list for later re-examination. See + Note [The KickOut Criteria] + +Theorem: T (defined in "THEN" above) is a generalised substitution; + that is, it satisfies (WF1)-(WF3) +Proof: + (WF1) Suppose we are adding [lhs_w -fw-> rhs_w], and [lhs_s -fs-> rhs_s] is in S. + Then: + - by (T1) if fs>=fw, lhs_s does not occur within lhs_w. + - by (KK1) if fw>=fs, lhs_w is not rewritable in lhs_s, or we'd have + kicked out the stable constraint. + + (WF2) is directly guaranteed by (T3) + + (WF3) No lhs_s in S is rewritable in rhs_w at all, because of (T2) + And (KK2) guarantees that lhs_w is not rewritable under a type + family in rhs_s + +Note [The KickOut Criteria] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kicking out is a Bad Thing: +* It means we have to re-process a constraint. The less we kick out, the better. +* In the limit, kicking can lead to non-termination: imagine that we /always/ + kick out the entire inert set! +* Because (mid 2024) we don't support sharing in constraints, excessive kicking out + can lead to exponentially big constraints (#24984). + +So we seek to do as little kicking out as possible. For example, consider this, +which happens a lot: + + Inert: g1: a ~ Maybe b + Work: g2: b ~ Int + +We do /not/ kick out g1 when adding g2. The new substitution S' = {g1,g2} is still +/terminating/ but it is not /idmempotent/. To apply S' to, say, (Tree a), we may +need to apply it twice: Tree a --> Tree (Maybe b) --> Tree (Maybe Int) + +Here are the KickOut Criteria: + + When adding [lhs_w -fw-> rhs_w] to a well-formed terminating substitution S, + element [lhs_s -fs-> rhs_s] in S meets the KickOut Criteria if: + + (KK0) fw >= fs AND any of (KK1), (KK2) or (KK3) hold + + * (KK1: satisfy WF1) `lhs_w` is rewritable in `lhs_s`. + + * (KK2: termination) `lhs_w` is rewritable in `rhs_s` in these positions: + If not(fs>=fw) + then (KK2a) anywhere + else (KK2b) look only in the argument of type family applications, + whose type family heads some LHS in `S` + + * (KK3: completeness) + If not(fs >= fw) -- If fs can rewrite fw, kick-out is redundant/harmful + * (KK3a) If the role of `fs` is Nominal: + kick out if `rhs_s = lhs_w` + * (KK3b) If the role of `fs` is Representational: + kick out if `rhs_s` is of form `(lhs_w t1 .. tn)` + +Rationale + +* (KK0) kick out only if `fw` can rewrite `fs`. + Reason: suppose we kick out (lhs1 -fs-> s), and add (lhs -fw-> t) to the ineart + set. The latter can't rewrite the former, so the kick-out achieved nothing + +* (KK1) `lhs_w` is rewritable in `lhs_s`. + Reason: needed to guarantee (WF1). See Theorem: T is well formed + +* (KK2) see Note [KK2: termination of the extended substitution] + +* (KK3) see Note [KK3: completeness of solving] + +The above story is a bit vague wrt roles, but the code is not. +See Note [Flavours with roles] + +Note [KK2: termination of the extended substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Proving termination of the extended substitution T is surprisingly tricky. + +* Reason for (KK2a). Consider + Work: [G] b ~ a + Inert: [W] a ~ b + If we don't kick out the inert, then we get a loop on e.g. [W] a ~ Int. + But if both were Wanted we really should not kick out (the substitution does not + have to be idempotent). So we only look everywhere for the `lhs_w` if + not (fs>=fw), that is the inert item cannot rewrite the work item. So in the + above example we will kick out; but if both were Wanted we won't. + +* Reason for (KK2b). Consider the case where (fs >= fw) + Work: [G] a ~ Int + Inert: [G] F Int ~ F a + If we just added the work item, the substitution would loop on type (F Int). + So we must kick out the inert item, even though (fs>=fw). (KK2b) does this + by looking for lhs_w under type family applications in rhs_s. + + (KK2b) makes kick-out less aggressive by looking only under type-family applications, + in the case where (fs >= fw), and that made a /huge/ difference to #24944. + +Tricky examples in: #19042, #17672, #24984. The last (#24984) is particular subtle: + + Inert: [W] g1: F a0 ~ F a1 + [W] g2: F a2 ~ F a1 + [W] g3: F a3 ~ F a1 + +Now we add [W] g4: F a1 ~ F a7. Should we kick out g1,g2,g3? No! The +substitution doesn't need to be idempotent, merely terminating. And in #24984 +it turned out that we kept adding one new constraint and kicking out all the +previous inert ones (and that rewriting led to exponentially big constraints due +to lack of contraint sharing.) So we only want to look /under/ type family applications. + +The proof is hard. We start by ignoring flavours. Suppose that: +* We are adding [lhs_w -fw-> rhs_w] to a well-formed, terminating substitution S. +* None of the constraints in S meet the KickOut Criteria. +* Define T = S+[lhs_w -fw-> rhs_w] +* `f` is an arbitrary flavour + +Lemma 1: for any lhs_s in S, T*(f,lhs_s) terminates. + Proof. + * We know that r1 = S*(f,lhs_s) terminates. + * Moreover, we know there are no occurrences of lhs_w under a type family (which + is the head of a LHS) in r1 (KK2)+(WF3). We need (WF3) because you might wonder + what if rhs_s is (F a), and [a --> lhs_w] was in S. But (WF3) prevents that. + * Define r2 = r1{rhs_w/lhs_w}. We know that rhs_w has no occurrences of any lhs in S, + nor of lhs_w. + * Since any occurrence of lhs_w does not occur under a type family, the substitution + won't make any F t1..tn ~ s in S match. + * So r2 is a fixed point of T. + +Lemma 2: T*(f,lhs_w) teminates. + Proof: no occurrences of any LHS in rhs_w. + +Theorem. For any type r, T*(r) terminates. + Proof: + 1. Consider any sub-term of r, which is a LHS of T. + - Rewrite it with T*; this terminates (Lemma 1). + - Do this simultaneously to all sub-terms that match a LHS of T, yielding r1. + 2. Could this new r1 have a sub-term that is an LHS of T? Yes, but only if r has a + sub-term F w, and w rewrote in Step 1 to w' and F w' matches a LHS in T. + 3. Very well: apply step 1 again, but note that /doing so consumes one of the family + applications in the original r/. + 4. After Step 1 either we have reached a fixed point, or we repeat Step 1 consuming at + least one family application of r. + 5. There are only a finite number of family applications in r, so this process terminates. + +Example: + +Inert set: gs : F Int ~ b +Work item: gw : b ~ Int + +F (F (F b)) --[gw]--> F (F (F Int)) --[gs]--> F (F b) + --[gw]--> F (F Int) --[gs]--> F b + --[gw]--> F Int --[gs]--> b + --[gw]--> Int + +Notice that each iteration of Step 1 strips off one of the layers of F, all +of which were in the original r. + +The argument is even more tricky when flavours are involved, and we have not +fleshed it out in detail. + +Note [KK3: completeness of solving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(KK3) is not necessary for the extended substitution +to be terminating. In fact (KK0) 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 (KK3) to the kick-out criteria: + + * (KK3: completeness) + If not(fs >= fw) (KK3a) + * (KK3b) If the role of `fs` is Nominal: + kick out if `rhs_s = lhs_w` + * (KK3c) If the role of `fs` is Representational: + kick out if `rhs_s` is of form `(lhs_w t1 .. tn)` + +Wrinkles: + +* (KK3a) All this can only happen if the work-item can rewrite the inert + one, /but not vice versa/; that is not(fs >= fw). It is useless to kick + out if (fs >= fw) becuase then the work-item is already fully rewritten + by the inert item. And too much kick-out is positively harmful. + (Historical example #14363.) + +* (KK3b) addresses teh main example above for KK3. Another way to understand + (KK3b) 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. + +* (KK3c) When considering roles, we also need the second clause (KK3b). 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 (KK3a), 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 head_is_new_lhs. This is encoded in + (KK3c)). + + +Note [Flavours with roles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The system described in Note [inert_eqs: the inert equalities] +discusses an abstract +set of flavours. In GHC, flavours have two components: the flavour proper, +taken from {Wanted, Given} and the equality relation (often called +role), taken from {NomEq, ReprEq}. +When substituting w.r.t. the inert set, +as described in Note [inert_eqs: the inert equalities], +we must be careful to respect all components of a flavour. +For example, if we have + + inert set: a -G/R-> Int + b -G/R-> Bool + + type role T nominal representational + +and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT +T Int Bool. The reason is that T's first parameter has a nominal role, and +thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of +substitution means that the proof in Note [inert_eqs: the inert equalities] may +need to be revisited, but we don't think that the end conclusion is wrong. +-} + +data InertCans -- See Note [Detailed InertCans Invariants] for more + = IC { inert_eqs :: InertEqs + -- See Note [inert_eqs: the inert equalities] + -- All EqCt with a TyVarLHS; index is the LHS tyvar + -- Domain = skolems and untouchables; a touchable would be unified + + , inert_funeqs :: InertFunEqs + -- All EqCt with a TyFamLHS; index is the whole family head type. + -- LHS is fully rewritten (modulo eqCanRewrite constraints) + -- wrt inert_eqs + -- Can include both [G] and [W] + + , inert_dicts :: DictMap DictCt + -- Dictionaries only + -- All fully rewritten (modulo flavour constraints) + -- wrt inert_eqs + + , inert_qcis :: [QCInst] -- See Note [Quantified constraints] + -- in GHC.Tc.Solver.Solve + + , inert_irreds :: InertIrreds + -- Irreducible predicates that cannot be made canonical, + -- and which don't interact with others (e.g. (c a)) + -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) + + , inert_given_eq_lvl :: TcLevel + -- The TcLevel of the innermost implication that has a Given + -- equality of the sort that make a unification variable untouchable + -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify). + -- See Note [Tracking Given equalities] + + , inert_given_eqs :: Bool + -- True <=> The inert Givens *at this level* (tcl_tclvl) + -- could includes at least one equality /other than/ a + -- let-bound skolem equality. + -- Reason: report these givens when reporting a failed equality + -- See Note [Tracking Given equalities] + } + +type InertEqs = DTyVarEnv EqualCtList +type InertFunEqs = FunEqMap EqualCtList +type InertIrreds = Bag IrredCt + +instance Outputable InertCans where + ppr (IC { inert_eqs = eqs + , inert_funeqs = funeqs + , inert_dicts = dicts + , inert_irreds = irreds + , inert_given_eq_lvl = ge_lvl + , inert_given_eqs = given_eqs + , inert_qcis = insts }) + + = braces $ vcat + [ ppUnless (isEmptyDVarEnv eqs) $ + text "Equalities =" + <+> pprBag (foldTyEqs consBag eqs emptyBag) + , ppUnless (isEmptyTcAppMap funeqs) $ + text "Type-function equalities =" + <+> pprBag (foldFunEqs consBag funeqs emptyBag) + , ppUnless (isEmptyTcAppMap dicts) $ + text "Dictionaries =" <+> pprBag (dictsToBag dicts) + , ppUnless (isEmptyBag irreds) $ + text "Irreds =" <+> pprBag irreds + , ppUnless (null insts) $ + text "Given instances =" <+> vcat (map ppr insts) + , text "Innermost given equalities =" <+> ppr ge_lvl + , text "Given eqs at this level =" <+> ppr given_eqs + ] + + +{- ********************************************************************* +* * + Inert equalities +* * +********************************************************************* -} + +emptyTyEqs :: InertEqs +emptyTyEqs = emptyDVarEnv + +addEqToCans :: TcLevel -> EqCt -> InertCans -> InertCans +addEqToCans tc_lvl eq_ct@(EqCt { eq_lhs = lhs }) + ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs }) + = updGivenEqs tc_lvl (CEqCan eq_ct) $ + case lhs of + TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys eq_ct } + TyVarLHS tv -> ics { inert_eqs = addTyEq eqs tv eq_ct } + +addTyEq :: InertEqs -> TcTyVar -> EqCt -> InertEqs +addTyEq old_eqs tv ct + = extendDVarEnv_C add_eq old_eqs tv [ct] + where + add_eq old_eqs _ = addToEqualCtList ct old_eqs + +foldTyEqs :: (EqCt -> b -> b) -> InertEqs -> b -> b +foldTyEqs k eqs z + = foldDVarEnv (\cts z -> foldr k z cts) z eqs + +findTyEqs :: InertCans -> TyVar -> [EqCt] +findTyEqs icans tv = concat @Maybe (lookupDVarEnv (inert_eqs icans) tv) + +delEq :: EqCt -> InertCans -> InertCans +delEq (EqCt { eq_lhs = lhs, eq_rhs = rhs }) ic = 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 :: EqCt -> Bool + isThisOne (EqCt { eq_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1 + + upd :: Maybe EqualCtList -> Maybe EqualCtList + upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list + upd Nothing = Nothing + +findEq :: InertCans -> CanEqLHS -> [EqCt] +findEq icans (TyVarLHS tv) = findTyEqs icans tv +findEq icans (TyFamLHS fun_tc fun_args) + = concat @Maybe (findFunEq (inert_funeqs icans) fun_tc fun_args) + +{-# INLINE partition_eqs_container #-} +partition_eqs_container + :: forall container + . container -- empty container + -> (forall b. (EqCt -> b -> b) -> container -> b -> b) -- folder + -> (EqCt -> container -> container) -- extender + -> (EqCt -> Bool) + -> container + -> ([EqCt], container) +partition_eqs_container empty_container fold_container extend_container pred orig_inerts + = fold_container folder orig_inerts ([], empty_container) + where + folder :: EqCt -> ([EqCt], container) -> ([EqCt], container) + folder eq_ct (acc_true, acc_false) + | pred eq_ct = (eq_ct : acc_true, acc_false) + | otherwise = (acc_true, extend_container eq_ct acc_false) + +partitionInertEqs :: (EqCt -> Bool) -- EqCt will always have a TyVarLHS + -> InertEqs + -> ([EqCt], InertEqs) +partitionInertEqs = partition_eqs_container emptyTyEqs foldTyEqs addInertEqs + +addInertEqs :: EqCt -> InertEqs -> InertEqs +-- Precondition: CanEqLHS is a TyVarLHS +addInertEqs eq_ct@(EqCt { eq_lhs = TyVarLHS tv }) eqs = addTyEq eqs tv eq_ct +addInertEqs other _ = pprPanic "extendInertEqs" (ppr other) + +-- | Filter InertEqs according to a predicate +filterInertEqs :: (EqCt -> Bool) -> InertEqs -> InertEqs +filterInertEqs f = mapMaybeDVarEnv g + where + g xs = + let filtered = filter f xs + in + if null filtered + then Nothing + else Just filtered + +------------------------ + +addCanFunEq :: InertFunEqs -> TyCon -> [TcType] -> EqCt -> InertFunEqs +addCanFunEq old_eqs fun_tc fun_args ct + = alterTcApp old_eqs fun_tc fun_args upd + where + upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list + upd Nothing = Just [ct] + +foldFunEqs :: (EqCt -> b -> b) -> FunEqMap EqualCtList -> b -> b +foldFunEqs k fun_eqs z = foldTcAppMap (\eqs z -> foldr k z eqs) fun_eqs z + +partitionFunEqs :: (EqCt -> Bool) -- EqCt will have a TyFamLHS + -> InertFunEqs + -> ([EqCt], InertFunEqs) +partitionFunEqs = partition_eqs_container emptyFunEqs foldFunEqs addFunEqs + +addFunEqs :: EqCt -> InertFunEqs -> InertFunEqs +-- Precondition: EqCt is a TyFamLHS +addFunEqs eq_ct@(EqCt { eq_lhs = TyFamLHS tc args }) fun_eqs + = addCanFunEq fun_eqs tc args eq_ct +addFunEqs other _ = pprPanic "extendFunEqs" (ppr other) + +-- | Filter entries in InertFunEqs that satisfy the predicate +filterFunEqs :: (EqCt -> Bool) -> InertFunEqs -> InertFunEqs +filterFunEqs f = mapMaybeTcAppMap g + where + g xs = + let filtered = filter f xs + in + if null filtered + then Nothing + else Just filtered + +{- ********************************************************************* +* * + Inert Dicts +* * +********************************************************************* -} + +-- | Look up a dictionary inert. +lookupInertDict :: InertCans -> Class -> [Type] -> Maybe DictCt +lookupInertDict (IC { inert_dicts = dicts }) cls tys + = findDict dicts cls tys + +-- | Look up a solved inert. +lookupSolvedDict :: InertSet -> Class -> [Type] -> Maybe CtEvidence +-- Returns just if exactly this predicate type exists in the solved. +lookupSolvedDict (IS { inert_solved_dicts = solved }) cls tys + = fmap dictCtEvidence (findDict solved cls tys) + +updDicts :: (DictMap DictCt -> DictMap DictCt) -> InertCans -> InertCans +updDicts upd ics = ics { inert_dicts = upd (inert_dicts ics) } + +delDict :: DictCt -> DictMap a -> DictMap a +delDict (DictCt { di_cls = cls, di_tys = tys }) m + = delTcApp m (classTyCon cls) tys + +addDict :: DictCt -> DictMap DictCt -> DictMap DictCt +addDict item@(DictCt { di_cls = cls, di_tys = tys }) dm + = insertTcApp dm (classTyCon cls) tys item + +addSolvedDict :: DictCt -> DictMap DictCt -> DictMap DictCt +addSolvedDict item@(DictCt { di_cls = cls, di_tys = tys }) dm + = insertTcApp dm (classTyCon cls) tys item + +filterDicts :: (DictCt -> Bool) -> DictMap DictCt -> DictMap DictCt +filterDicts f m = filterTcAppMap f m + +partitionDicts :: (DictCt -> Bool) -> DictMap DictCt -> (Bag DictCt, DictMap DictCt) +partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDictMap) + where + k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) + | otherwise = (yeses, addDict ct noes) + + +{- ********************************************************************* +* * + Inert Irreds +* * +********************************************************************* -} + +addIrredToCans :: TcLevel -> IrredCt -> InertCans -> InertCans +addIrredToCans tc_lvl irred ics + = updGivenEqs tc_lvl (CIrredCan irred) $ + updIrreds (addIrred irred) ics + +addIrreds :: [IrredCt] -> InertIrreds -> InertIrreds +addIrreds extras irreds + | null extras = irreds + | otherwise = irreds `unionBags` listToBag extras + +addIrred :: IrredCt -> InertIrreds -> InertIrreds +addIrred extra irreds = irreds `snocBag` extra + +updIrreds :: (InertIrreds -> InertIrreds) -> InertCans -> InertCans +updIrreds upd ics = ics { inert_irreds = upd (inert_irreds ics) } + +delIrred :: IrredCt -> InertCans -> InertCans +-- Remove a particular (Given) Irred, on the instructions of a plugin +-- For some reason this is done vis the evidence Id, not the type +-- Compare delEq. I have not idea why +delIrred (IrredCt { ir_ev = ev }) ics + = updIrreds (filterBag keep) ics + where + ev_id = ctEvEvId ev + keep (IrredCt { ir_ev = ev' }) = ev_id /= ctEvEvId ev' + +foldIrreds :: (IrredCt -> b -> b) -> InertIrreds -> b -> b +foldIrreds k irreds z = foldr k z irreds + +findMatchingIrreds :: InertIrreds -> CtEvidence + -> (Bag (IrredCt, SwapFlag), InertIrreds) +findMatchingIrreds irreds ev + | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred + -- See Note [Solving irreducible equalities] + = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds + | otherwise + = partitionBagWith match_non_eq irreds + where + pred = ctEvPred ev + match_non_eq irred + | irredCtPred irred `tcEqType` pred = Left (irred, NotSwapped) + | otherwise = Right irred + + match_eq eq_rel1 lty1 rty1 irred + | EqPred eq_rel2 lty2 rty2 <- classifyPredType (irredCtPred irred) + , eq_rel1 == eq_rel2 + , Just swap <- match_eq_help lty1 rty1 lty2 rty2 + = Left (irred, swap) + | otherwise + = Right irred + + match_eq_help lty1 rty1 lty2 rty2 + | lty1 `tcEqType` lty2, rty1 `tcEqType` rty2 + = Just NotSwapped + | lty1 `tcEqType` rty2, rty1 `tcEqType` lty2 + = Just IsSwapped + | otherwise + = Nothing + +{- Note [Solving irreducible equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14333) + [G] a b ~R# c d + [W] c d ~R# a b +Clearly we should be able to solve this! Even though the constraints are +not decomposable. We solve this when looking up the work-item in the +irreducible constraints to look for an identical one. When doing this +lookup, findMatchingIrreds spots the equality case, and matches either +way around. It has to return a swap-flag so we can generate evidence +that is the right way round too. +-} + +{- ********************************************************************* +* * + Adding to and removing from the inert set +* * +* * +********************************************************************* -} + +updGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans +-- Set the inert_given_eq_level to the current level (tclvl) +-- if the constraint is a given equality that should prevent +-- filling in an outer unification variable. +-- See Note [Tracking Given equalities] +-- +-- Precondition: Ct is either CEqCan or CIrredCan +updGivenEqs tclvl ct inerts + | not (isGivenCt ct) = inerts + + -- See Note [Let-bound skolems] + | isLetBoundSkolemCt tclvl ct = inerts { inert_given_eqs = True } + + -- At this point we are left with a constraint that either + -- is an equality (F a ~ ty), or /might/ be, like (c a) + | otherwise = inerts { inert_given_eq_lvl = tclvl + , inert_given_eqs = True } + +isLetBoundSkolemCt :: TcLevel -> Ct -> Bool +-- See Note [Let-bound skolems] +isLetBoundSkolemCt tclvl (CEqCan (EqCt { eq_lhs = lhs, eq_rhs = rhs })) + = case lhs of + TyVarLHS tv -> not (isOuterTyVar tclvl tv) + TyFamLHS {} -> case getTyVar_maybe rhs of + Just tv -> not (isOuterTyVar tclvl tv) + Nothing -> False +isLetBoundSkolemCt _ _ = False + +data KickOutSpec -- See Note [KickOutSpec] + = KOAfterUnify TcTyVarSet -- We have unified these tyvars + | KOAfterAdding CanEqLHS -- We are adding to the inert set a canonical equality + -- constraint with this LHS + +instance Outputable KickOutSpec where + ppr (KOAfterUnify tvs) = text "KOAfterUnify" <> ppr tvs + ppr (KOAfterAdding lhs) = text "KOAfterAdding" <> parens (ppr lhs) + +{- Note [KickOutSpec] +~~~~~~~~~~~~~~~~~~~~~~ +KickOutSpec explains why we are kicking out. + +Important property: + KOAfterAdding (TyVarLHS tv) should behave exactly like + KOAfterUnifying (unitVarSet tv) + +The main reasons for treating the two separately are +* More efficient in the single-tyvar case +* The code is far more perspicuous +-} + +data WhereToLook = LookEverywhere | LookOnlyUnderFamApps + deriving( Eq ) + +kickOutRewritableLHS :: KickOutSpec -> CtFlavourRole -> InertCans -> (Cts, InertCans) +-- See Note [kickOutRewritable] +kickOutRewritableLHS ko_spec new_fr@(_, new_role) + ics@(IC { inert_eqs = tv_eqs + , inert_dicts = dictmap + , inert_funeqs = funeqmap + , inert_irreds = irreds + , inert_qcis = old_insts }) + = (kicked_out, inert_cans_in) + where + inert_cans_in = ics { inert_eqs = tv_eqs_in + , inert_dicts = dicts_in + , inert_funeqs = feqs_in + , inert_irreds = irs_in + , inert_qcis = insts_in } + + kicked_out :: Cts + kicked_out = (fmap CDictCan dicts_out `andCts` fmap CIrredCan irs_out) + `extendCtsList` insts_out + `extendCtsList` map CEqCan tv_eqs_out + `extendCtsList` map CEqCan feqs_out + + (tv_eqs_out, tv_eqs_in) = partitionInertEqs kick_out_eq tv_eqs + (feqs_out, feqs_in) = partitionFunEqs kick_out_eq funeqmap + (dicts_out, dicts_in) = partitionDicts kick_out_dict dictmap + (irs_out, irs_in) = partitionBag kick_out_irred 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.Solve + 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 LookEverywhere NomEq (ctEvPred (qci_ev qci)) + = Left (mkNonCanonical ev) + | otherwise + = Right qci + + fr_tv_can_rewrite_ty :: WhereToLook -> (TyVar -> Bool) -> EqRel -> Type -> Bool + fr_tv_can_rewrite_ty where_to_look check_tv role ty + = anyRewritableTyVar role can_rewrite ty + where + can_rewrite :: UnderFam -> EqRel -> TyVar -> Bool + can_rewrite is_under_famapp old_role tv + = (where_to_look == LookEverywhere || is_under_famapp) && + new_role `eqCanRewrite` old_role && check_tv tv + + fr_tf_can_rewrite_ty :: WhereToLook -> TyCon -> [TcType] -> EqRel -> Type -> Bool + fr_tf_can_rewrite_ty where_to_look new_tf new_tf_args role ty + = anyRewritableTyFamApp role can_rewrite ty + where + can_rewrite :: UnderFam -> EqRel -> TyCon -> [TcType] -> Bool + can_rewrite is_under_famapp old_role old_tf old_tf_args + = (where_to_look == LookEverywhere || is_under_famapp) && + 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. + + + fr_can_rewrite_ty :: WhereToLook -> EqRel -> Type -> Bool + -- UnderFam = True <=> look only under type-family applications + fr_can_rewrite_ty uf = case ko_spec of -- See Note [KickOutSpec] + KOAfterUnify tvs -> fr_tv_can_rewrite_ty uf (`elemVarSet` tvs) + KOAfterAdding (TyVarLHS tv) -> fr_tv_can_rewrite_ty uf (== tv) + KOAfterAdding (TyFamLHS tf tf_args) -> fr_tf_can_rewrite_ty uf tf tf_args + + fr_may_rewrite :: CtFlavourRole -> Bool + fr_may_rewrite fs = new_fr `eqCanRewriteFR` fs + -- Can the new item rewrite the inert item? + + kick_out_dict :: DictCt -> Bool + -- Kick it out if the new CEqCan can rewrite the inert one + -- See Note [kickOutRewritable] + kick_out_dict (DictCt { di_tys = tys, di_ev = ev }) + = fr_may_rewrite (ctEvFlavour ev, NomEq) + && any (fr_can_rewrite_ty LookEverywhere NomEq) tys + + kick_out_irred :: IrredCt -> Bool + kick_out_irred (IrredCt { ir_ev = ev }) + = fr_may_rewrite (ctEvFlavour ev, eq_rel) + && fr_can_rewrite_ty LookEverywhere eq_rel pred + where + pred = ctEvPred ev + eq_rel = predTypeEqRel pred + + -- Implements criteria K1-K3 in Note [Extending the inert equalities] + kick_out_eq :: EqCt -> Bool + kick_out_eq (EqCt { eq_lhs = lhs, eq_rhs = rhs_ty + , eq_ev = ev, eq_eq_rel = eq_rel }) + + -- (KK0) Keep it in the inert set if the new thing can't rewrite it + | not (fr_may_rewrite fs) + = False + + -- Below here (fr_may_rewrite fs) is True + + -- (KK1) + | fr_can_rewrite_ty LookEverywhere eq_rel (canEqLHSType lhs) + = True -- (KK1) + -- The above check redundantly checks the role & flavour, + -- but it's very convenient + + -- (KK2) + | let where_to_look | fs_can_rewrite_fr = LookOnlyUnderFamApps + | otherwise = LookEverywhere + , fr_can_rewrite_ty where_to_look eq_rel rhs_ty + = True + + -- (KK3) + | not fs_can_rewrite_fr -- (KK3a) + , case eq_rel of + NomEq -> is_new_lhs rhs_ty -- (KK3b) + ReprEq -> head_is_new_lhs rhs_ty -- (KK3c) + = True + + | otherwise = False + + where + fs_can_rewrite_fr = fs `eqCanRewriteFR` new_fr + fs = (ctEvFlavour ev, eq_rel) + + is_new_lhs :: Type -> Bool + is_new_lhs = case ko_spec of -- See Note [KickOutSpec] + KOAfterUnify tvs -> is_tyvar_ty_for tvs + KOAfterAdding lhs -> (`eqType` canEqLHSType lhs) + + is_tyvar_ty_for :: TcTyVarSet -> Type -> Bool + -- True if the type is equal to one of the tyvars + is_tyvar_ty_for tvs ty + = case getTyVar_maybe ty of + Nothing -> False + Just tv -> tv `elemVarSet` tvs + + head_is_new_lhs :: Type -> Bool + head_is_new_lhs = case ko_spec of -- See Note [KickOutSpec] + KOAfterUnify tvs -> tv_at_head (`elemVarSet` tvs) + KOAfterAdding (TyVarLHS tv) -> tv_at_head (== tv) + KOAfterAdding (TyFamLHS tf tf_args) -> fam_at_head tf tf_args + + tv_at_head :: (TyVar -> Bool) -> Type -> Bool + tv_at_head is_tv = go + where + go (Rep.TyVarTy tv) = is_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 + + fam_at_head :: TyCon -> [Type] -> Type -> Bool + fam_at_head fun_tc fun_args = go + where + go (Rep.TyVarTy {}) = False + go (Rep.AppTy {}) = False -- no TyConApp to the left of an AppTy + go (Rep.CastTy ty _) = go ty + go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args + go (Rep.LitTy {}) = False + go (Rep.ForAllTy {}) = False + go (Rep.FunTy {}) = False + go (Rep.CoercionTy {}) = False + +{- Note [kickOutRewritable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [inert_eqs: the inert equalities]. + +When we add a new inert equality (lhs ~N ty) to the inert set, +we must kick out any inert items that could be rewritten by the +new equality, to maintain the inert-set invariants. + + - We want to kick out an existing inert constraint if + a) the new constraint can rewrite the inert one + b) 'lhs' is free in the inert constraint (so that it *will*) + rewrite it if we kick it out. + + For (b) we use anyRewritableCanLHS, which examines the types /and + kinds/ that are directly visible in the type. Hence + we will have exposed all the rewriting we care about to make the + most precise kinds visible for matching classes etc. No need to + kick out constraints that mention type variables whose kinds + contain this LHS! + + - We don't kick out constraints from inert_solved_dicts, and + inert_solved_funeqs optimistically. But when we lookup we have to + take the substitution into account + +NB: we could in principle avoid kick-out: + a) When unifying a meta-tyvar from an outer level, because + then the entire implication will be iterated; see + Note [The Unification Level Flag] in GHC.Tc.Solver.Monad. + + b) For Givens, after a unification. By (GivenInv) in GHC.Tc.Utils.TcType + Note [TcLevel invariants], a Given can't include a meta-tyvar from + its own level, so it falls under (a). Of course, we must still + kick out Givens when adding a new non-unification Given. + +But kicking out more vigorously may lead to earlier unification and fewer +iterations, so we don't take advantage of these possibilities. + +Note [Rewrite insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an insoluble alpha ~ [alpha], which is insoluble +because an occurs check. And then we unify alpha := [Int]. Then we +really want to rewrite the insoluble to [Int] ~ [[Int]]. Now it can +be decomposed. Otherwise we end up with a "Can't match [Int] ~ +[[Int]]" which is true, but a bit confusing because the outer type +constructors match. + +Hence: + * In the main simplifier loops in GHC.Tc.Solver (solveWanteds, + simpl_loop), we feed the insolubles in solveSimpleWanteds, + so that they get rewritten (albeit not solved). + + * We kick insolubles out of the inert set, if they can be + rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable) + + * We rewrite those insolubles in GHC.Tc.Solver.Equality + See Note [Make sure that insolubles are fully rewritten] + in GHC.Tc.Solver.Equality +-} + +{- ********************************************************************* +* * + Queries +* * +* * +********************************************************************* -} + +isOuterTyVar :: TcLevel -> TyCoVar -> Bool +-- True of a type variable that comes from a +-- shallower level than the ambient level (tclvl) +isOuterTyVar tclvl tv + | isTyVar tv = assertPpr (not (isTouchableMetaTyVar tclvl tv)) (ppr tv <+> ppr tclvl) $ + tclvl `strictlyDeeperThan` tcTyVarLevel tv + -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from + -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't + -- be a touchable meta tyvar. If this wasn't true, you might worry that, + -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby + -- becomes "outer" even though its level numbers says it isn't. + | otherwise = False -- Coercion variables; doesn't much matter + +noGivenNewtypeReprEqs :: TyCon -> InertSet -> Bool +-- True <=> there is no Given looking like (N tys1 ~ N tys2) +-- See Note [Decomposing newtype equalities] (EX3) in GHC.Tc.Solver.Equality +noGivenNewtypeReprEqs tc (IS { inert_cans = inerts }) + | IC { inert_irreds = irreds, inert_qcis = quant_cts } <- inerts + = not (anyBag might_help_irred irreds || any might_help_qc quant_cts) + -- Look in both inert_irreds /and/ inert_qcis (#26020) + where + might_help_irred (IrredCt { ir_ev = ev }) + | EqPred ReprEq t1 t2 <- classifyPredType (ctEvPred ev) + = headed_by_tc t1 t2 + | otherwise + = False + + might_help_qc (QCI { qci_ev = ev, qci_body = pred }) + | isGiven ev + , ClassPred cls [_, t1, t2] <- classifyPredType pred + , cls `hasKey` coercibleTyConKey + = headed_by_tc t1 t2 + | otherwise + = False + + headed_by_tc t1 t2 + | Just (tc1,_) <- tcSplitTyConApp_maybe t1 + , tc == tc1 + , Just (tc2,_) <- tcSplitTyConApp_maybe t2 + , tc == tc2 + = True + | otherwise + = False + +-- | Is it (potentially) loopy to use the first @ct1@ to solve @ct2@? +-- +-- Necessary (but not sufficient) conditions for this function to return @True@: +-- +-- - @ct1@ and @ct2@ both arise from superclass expansion, +-- - @ct1@ is a Given and @ct2@ is a Wanted. +-- +-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance, (sc2). +prohibitedSuperClassSolve :: CtLoc -- ^ is it loopy to use this one ... + -> CtLoc -- ^ ... to solve this one? + -> Bool -- ^ True ==> don't solve it +prohibitedSuperClassSolve given_loc wanted_loc + | GivenSCOrigin _ _ blocked <- ctLocOrigin given_loc + , blocked + , ScOrigin _ NakedSc <- ctLocOrigin wanted_loc + = True -- Prohibited if the Wanted is a superclass + -- and the Given has come via a superclass selection from + -- a predicate bigger than the head + | otherwise + = False + + +{- ********************************************************************* +* * + Cycle breakers +* * +********************************************************************* -} + +-- | Push a fresh environment onto the cycle-breaker var stack. Useful +-- when entering a nested implication. +pushCycleBreakerVarStack :: CycleBreakerVarStack -> CycleBreakerVarStack +pushCycleBreakerVarStack = (emptyBag <|) + +-- | Add a new cycle-breaker binding to the top environment on the stack. +addCycleBreakerBindings :: Bag (TcTyVar, Type) -- ^ (cbv,expansion) pairs + -> InertSet -> InertSet +addCycleBreakerBindings prs ics + = assertPpr (all (isCycleBreakerTyVar . fst) prs) (ppr prs) $ + ics { inert_cycle_breakers = add_to (inert_cycle_breakers ics) } + where + add_to (top_env :| rest_envs) = (prs `unionBags` 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 + + +{- ********************************************************************* +* * + Solving one from another +* * +********************************************************************* -} + +data InteractResult + = KeepInert -- Keep the inert item, and solve the work item from it + -- (if the latter is Wanted; just discard it if not) + | KeepWork -- Keep the work item, and solve the inert item from it + +instance Outputable InteractResult where + ppr KeepInert = text "keep inert" + ppr KeepWork = text "keep work-item" + +solveOneFromTheOther :: Ct -- Inert (Dict or Irred) + -> Ct -- WorkItem (same predicate as inert) + -> InteractResult +-- Precondition: +-- * inert and work item represent evidence for the /same/ predicate +-- * Both are CDictCan or CIrredCan +-- +-- We can always solve one from the other: even if both are wanted, +-- although we don't rewrite wanteds with wanteds, we can combine +-- two wanteds into one by solving one from the other +-- +-- Compare the corresponding function for equalities: +-- GHC.Tc.Solver.Equality.inertEqsCanDischarge + +solveOneFromTheOther ct_i ct_w + | CtWanted {} <- ev_w + , prohibitedSuperClassSolve loc_i loc_w + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + = -- Inert must be Given + KeepWork + + | CtWanted (WantedCt { ctev_rewriters = rw_w }) <- ev_w + = -- Inert is Given or Wanted + case ev_i of + CtGiven {} -> KeepInert + -- work is Wanted; inert is Given: easy choice. + + CtWanted (WantedCt { ctev_rewriters = rw_i }) -- Both are Wanted + -- If only one has no pending superclasses, use it + -- Otherwise we can get infinite superclass expansion (#22516) + -- in silly cases like class C T b => C a b where ... + | Just res <- better (not is_psc_i) (not is_psc_w) + -> res + + -- If only one has an empty rewriter set, use it + -- c.f. GHC.Tc.Solver.Equality.inertsCanDischarge, and especially + -- (CE4) in Note [Combining equalities] + | Just res <- better (isEmptyRewriterSet rw_i) (isEmptyRewriterSet rw_w) + -> res + + -- If only one is a WantedSuperclassOrigin (arising from expanding + -- a Wanted class constraint), keep the other: wanted superclasses + -- may be unexpected by users + | Just res <- better (not is_wsc_orig_i) (not is_wsc_orig_w) + -> res + + -- 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 + + -- From here on the work-item is Given + + | CtWanted {} <- ev_i + , prohibitedSuperClassSolve loc_w loc_i + = KeepInert -- Just discard the un-usable Given + -- This never actually happens because + -- Givens get processed first + + | CtWanted {} <- ev_i + = KeepWork + + -- From here on both are Given + -- See Note [Replacement vs keeping] + + | lvl_i `sameDepthAs` lvl_w + = same_level_strategy + + | otherwise -- Both are Given, levels differ + = different_level_strategy + where + better :: Bool -> Bool -> Maybe InteractResult + -- (better inert-is-good wanted-is-good) returns + -- Just KeepWork if wanted is strictly better than inert + -- Just KeepInert if inert is strictly better than wanted + -- Nothing if they are the same + better True False = Just KeepInert + better False True = Just KeepWork + better _ _ = Nothing + + ev_i = ctEvidence ct_i + ev_w = ctEvidence ct_w + + pred = ctEvPred ev_i + + loc_i = ctEvLoc ev_i + loc_w = ctEvLoc ev_w + orig_i = ctLocOrigin loc_i + orig_w = ctLocOrigin loc_w + lvl_i = ctLocLevel loc_i + lvl_w = ctLocLevel loc_w + + is_psc_w = isPendingScDict ct_w + is_psc_i = isPendingScDict ct_i + + is_wsc_orig_i = isWantedSuperclassOrigin orig_i + is_wsc_orig_w = isWantedSuperclassOrigin orig_w + + different_level_strategy -- Both Given + | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert + | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork + -- See Note [Replacement vs keeping] part (1) + -- For the couldBeIPLike case see Note [Shadowing of implicit parameters] + -- in GHC.Tc.Solver.Dict + + same_level_strategy -- Both Given + = case (orig_i, orig_w) of + + (GivenSCOrigin _ depth_i blocked_i, GivenSCOrigin _ depth_w blocked_w) + | blocked_i, not blocked_w -> KeepWork -- Case 2(a) from + | not blocked_i, blocked_w -> KeepInert -- Note [Replacement vs keeping] + + -- Both blocked or both not blocked + + | depth_w < depth_i -> KeepWork -- Case 2(c) from + | otherwise -> KeepInert -- Note [Replacement vs keeping] + + (GivenSCOrigin {}, _) -> KeepWork -- Case 2(b) from Note [Replacement vs keeping] + + _ -> KeepInert -- Case 2(d) from Note [Replacement vs keeping] + +{- +Note [Replacement vs keeping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have two Given constraints both of type (C tys), say, which should +we keep? More subtle than you might think! This is all implemented in +solveOneFromTheOther. + + 1) Constraints come from different levels (different_level_strategy) + + - For implicit parameters we want to keep the innermost (deepest) + one, so that it overrides the outer one. + See Note [Shadowing of implicit parameters] in GHC.Tc.Solver.Dict + + - For everything else, we want to keep the outermost one. Reason: that + makes it more likely that the inner one will turn out to be unused, + and can be reported as redundant. See Note [Tracking redundant constraints] + in GHC.Tc.Solver. + + It transpires that using the outermost one is responsible for an + 8% performance improvement in nofib cryptarithm2, compared to + just rolling the dice. I didn't investigate why. + + 2) Constraints coming from the same level (i.e. same implication) + + (a) If both are GivenSCOrigin, choose the one that is unblocked if possible + according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. + + (b) Prefer constraints that are not superclass selections. See + (TRC3) in Note [Tracking redundant constraints] in GHC.Tc.Solver. + + (c) If both are GivenSCOrigin, chooose the one with the shallower + superclass-selection depth, in the hope of identifying more correct + redundant constraints. This is really a generalization of point (b), + because the superclass depth of a non-superclass constraint is 0. + + (If the levels differ, we definitely won't have both with GivenSCOrigin.) + + (d) Finally, when there is still a choice, use KeepInert rather than + KeepWork, for two reasons: + - to avoid unnecessary munging of the inert set. + - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Dict + +Doing the level-check for implicit parameters, rather than making the work item +always override, is important. Consider + + data T a where { T1 :: (?x::Int) => T Int; T2 :: T a } + + f :: (?x::a) => T a -> Int + f T1 = ?x + f T2 = 3 + +We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add +two new givens in the work-list: [G] (?x::Int) + [G] (a ~ Int) +Now consider these steps + - process a~Int, kicking out (?x::a) + - process (?x::Int), the inner given, adding to inert set + - process (?x::a), the outer given, overriding the inner given +Wrong! The level-check ensures that the inner implicit parameter wins. +(Actually I think that the order in which the work-list is processed means +that this chain of events won't happen, but that's very fragile.) +-} + diff --git a/GHC/Tc/Solver/Irred.hs b/GHC/Tc/Solver/Irred.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Irred.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} + +module GHC.Tc.Solver.Irred( + solveIrred + ) where + +import GHC.Prelude + +import GHC.Tc.Types.Constraint +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) +import GHC.Tc.Solver.Monad +import GHC.Tc.Types.Evidence + +import GHC.Core.Coercion + +import GHC.Types.Basic( SwapFlag(..) ) + +import GHC.Utils.Outputable + +import GHC.Data.Bag + +import Data.Void( Void ) + + +{- ********************************************************************* +* * +* Irreducibles +* * +********************************************************************* -} + +solveIrred :: IrredCt -> SolverStage Void +solveIrred irred + = do { simpleStage $ traceTcS "solveIrred:" (ppr irred) + ; tryInertIrreds irred + ; tryQCsIrredCt irred + ; simpleStage (updInertIrreds irred) + ; stopWithStage (irredCtEvidence irred) "Kept inert IrredCt" } + + +{- ********************************************************************* +* * +* Inert Irreducibles +* * +********************************************************************* -} + +-- Two pieces of irreducible evidence: if their types are *exactly identical* +-- we can rewrite them. We can never improve using this: +-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not +-- mean that (ty1 ~ ty2) +tryInertIrreds :: IrredCt -> SolverStage () +tryInertIrreds irred + = Stage $ do { ics <- getInertCans + ; try_inert_irreds ics irred } + +try_inert_irreds :: InertCans -> IrredCt -> TcS (StopOrContinue ()) + +try_inert_irreds inerts irred_w@(IrredCt { ir_ev = ev_w, ir_reason = reason }) + | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w + , ((irred_i, swap) : _rest) <- bagToList matching_irreds + -- See Note [Multiple matching irreds] + , let ev_i = irredCtEvidence irred_i + ct_i = CIrredCan irred_i + , not (isInsolubleReason reason) || isGiven ev_i || isGiven ev_w + -- See Note [Insoluble irreds] + = do { traceTcS "iteractIrred" $ + vcat [ text "wanted:" <+> (ppr ct_w $$ ppr (ctOrigin ct_w)) + , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) ] + ; case solveOneFromTheOther ct_i ct_w of + KeepInert -> do { setEvBindIfWanted ev_w EvCanonical (swap_me swap ev_i) + ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) } + KeepWork -> do { setEvBindIfWanted ev_i EvCanonical (swap_me swap ev_w) + ; updInertCans (updIrreds (\_ -> others)) + ; continueWith () } } + + | otherwise + = continueWith () + + where + ct_w = CIrredCan irred_w + + swap_me :: SwapFlag -> CtEvidence -> EvTerm + swap_me swap ev + = case swap of + NotSwapped -> ctEvTerm ev + IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev))) + + +{- Note [Multiple matching irreds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that it's impossible to have multiple irreds all match the +work item; after all, interactIrred looks for matches and solves one from the +other. However, note that interacting insoluble, non-droppable irreds does not +do this matching. We thus might end up with several insoluble, non-droppable, +matching irreds in the inert set. When another irred comes along that we have +not yet labeled insoluble, we can find multiple matches. These multiple matches +cause no harm, but it would be wrong to ASSERT that they aren't there (as we +once had done). This problem can be tickled by typecheck/should_compile/holes. + +Note [Insoluble irreds] +~~~~~~~~~~~~~~~~~~~~~~~ +We don't allow an /insoluble/ Wanted to be solved from another identical +Wanted. We want to keep all the insoluble Wanteds distinct, so that we get +distinct error messages with -fdefer-type-errors + +However we /do/ allow an insoluble constraint (Given or Wanted) to be solved +from an identical insoluble Given. This might seem a little odd, but there is +lots of discussion in #23413 and #17543. We currently implement the PermissivePlan +of #23413. An alternative would be the LibertarianPlan, but that is harder to +implemnent. + +By "identical" we include swapping. See Note [Solving irreducible equalities] +in GHC.Tc.Solver.InertSet. + +Test cases that are involved bkpfail24.run, T15450, GivenForallLoop, T20189, T8392a. +-} + +{- ********************************************************************* +* * +* Quantified constraints +* * +********************************************************************* -} + +tryQCsIrredCt :: IrredCt -> SolverStage () +-- Try local quantified constraints for +-- and CIrredCan e.g. (c a) +tryQCsIrredCt (IrredCt { ir_ev = ev }) + | isGiven ev + = Stage $ continueWith () + + | otherwise + = Stage $ do { res <- matchLocalInst pred loc + ; case res of + OneInst {} -> chooseInstance ev res + _ -> continueWith () } + where + loc = ctEvLoc ev + pred = ctEvPred ev diff --git a/GHC/Tc/Solver/Monad.hs b/GHC/Tc/Solver/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Monad.hs @@ -0,0 +1,2458 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Monadic definitions for the constraint solver +module GHC.Tc.Solver.Monad ( + + -- The TcS monad + TcS(..), TcSEnv(..), + runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts, + failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS, + runTcSEqualities, + nestTcS, nestImplicTcS, tryShortCutTcS, + setEvBindsTcS, setTcLevelTcS, + emitFunDepWanteds, + + selectNextWorkItem, + getWorkList, + updWorkListTcS, + pushLevelNoWorkList, + + runTcPluginTcS, recordUsedGREs, + matchGlobalInst, TcM.ClsInstResult(..), + + QCInst(..), + + -- TcSMode + TcSMode(..), getTcSMode, setTcSMode, vanillaTcSMode, + + -- The pipeline + StopOrContinue(..), continueWith, stopWith, + startAgainWith, SolverStage(Stage, runSolverStage), simpleStage, + stopWithStage, nopStage, + + -- Tracing etc + panicTcS, traceTcS, tryEarlyAbortTcS, + traceFireTcS, bumpStepCountTcS, csTraceTcS, + wrapErrTcS, wrapWarnTcS, + resetUnificationFlag, setUnificationFlag, + + -- Evidence creation and transformation + MaybeNew(..), freshGoals, isFresh, getEvExpr, + CanonicalEvidence(..), + + newTcEvBinds, newNoTcEvBinds, + newWantedEq, emitNewWantedEq, + newWanted, + newWantedNC, newWantedEvVarNC, + newBoundEvVarId, + unifyTyVar, reportUnifications, + setEvBind, setWantedEq, + setWantedEvTerm, setEvBindIfWanted, + newEvVar, newGivenEvVar, emitNewGivens, + checkReductionDepth, + + getInstEnvs, getFamInstEnvs, -- Getting the environments + getTopEnv, getGblEnv, getLclEnv, setSrcSpan, + getTcEvBindsVar, getTcLevel, + getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, + tcLookupClass, tcLookupId, tcLookupTyCon, + + getUnifiedRef, + + + -- Inerts + updInertSet, updInertCans, + getHasGivenEqs, setInertCans, + getInertEqs, getInertCans, getInertGivens, + getInertInsols, getInnermostGivenEqLevel, + getInertSet, setInertSet, + getUnsolvedInerts, + removeInertCts, getPendingGivenScs, + insertFunEq, addInertQCI, + updInertDicts, updInertIrreds, + emitWorkNC, emitWork, + lookupInertDict, + + -- The Model + kickOutAfterUnification, kickOutRewritable, + + -- Inert Safe Haskell safe-overlap failures + insertSafeOverlapFailureTcS, + getSafeOverlapFailures, + + -- Inert solved dictionaries + getSolvedDicts, setSolvedDicts, + updSolvedDicts, lookupSolvedDict, + + -- Irreds + foldIrreds, + + -- The family application cache + lookupFamAppInert, lookupFamAppCache, extendFamAppCache, + pprKicked, + + -- Instantiation + instDFunType, + + -- Unification + wrapUnifierX, wrapUnifierTcS, unifyFunDeps, uPairsTcM, unifyForAllBody, + + -- MetaTyVars + newFlexiTcSTy, instFlexiX, + cloneMetaTyVar, + tcInstSkolTyVarsX, + + TcLevel, + isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, + zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo, + zonkTyCoVarsAndFVList, + zonkSimples, zonkWC, + zonkTyCoVarKind, + + -- References + newTcRef, readTcRef, writeTcRef, updTcRef, + + -- Misc + getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, + matchFam, matchFamTcM, + checkWellLevelledDFun, + pprEq, + + -- Enforcing invariants for type equalities + checkTypeEq +) 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 + ( tcGetDefaultTys + , tcLookupClass, tcLookupId, tcLookupTyCon + ) +import GHC.Tc.Zonk.Monad ( ZonkM ) +import qualified GHC.Tc.Zonk.TcType as TcM + +import GHC.Driver.DynFlags + +import GHC.Tc.Instance.Class( safeOverlap, instanceReturnsDictCon ) +import GHC.Tc.Instance.FunDeps( FunDepEqn(..) ) +import GHC.Utils.Misc + + +import GHC.Tc.Solver.Types +import GHC.Tc.Solver.InertSet +import GHC.Tc.Errors.Types + +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Unify + +import GHC.Tc.Types.Evidence +import GHC.Tc.Types +import GHC.Tc.Types.Origin +import GHC.Tc.Types.CtLoc +import GHC.Tc.Types.Constraint + +import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName ) + +import GHC.Core.Type +import GHC.Core.TyCo.Rep as Rep +import GHC.Core.TyCo.Tidy +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom( TypeEqn ) +import GHC.Core.Predicate +import GHC.Core.Reduction +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Unify (typesAreApart) + +import GHC.Types.Name +import GHC.Types.TyThing +import GHC.Types.Name.Reader +import GHC.Types.DefaultEnv ( DefaultEnv ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Supply +import GHC.Types.Unique.Set( elementOfUniqSet ) +import GHC.Types.Id +import GHC.Types.Basic (allImportLevels) +import GHC.Types.ThLevelIndex (thLevelIndexFromImportLevel) +import GHC.Types.SrcLoc + +import GHC.Unit.Module +import qualified GHC.Rename.Env as TcM +import GHC.Rename.Env + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Logger + +import GHC.Data.Bag as Bag +import GHC.Data.Pair + +import GHC.Utils.Monad + +import GHC.Exts (oneShot) +import Control.Monad +import Data.Foldable hiding ( foldr1 ) +import Data.IORef +import Data.Maybe( catMaybes ) +import Data.List ( mapAccumL ) +import Data.List.NonEmpty ( nonEmpty ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as S +import GHC.LanguageExtensions as LangExt + +#if defined(DEBUG) +import GHC.Types.Unique.Set (nonDetEltsUniqSet) +import GHC.Data.Graph.Directed +#endif + +import qualified Data.Set as Set +import GHC.Unit.Module.Graph + +{- ********************************************************************* +* * + SolverStage and StopOrContinue +* * +********************************************************************* -} + +{- Note [The SolverStage monad] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The SolverStage monad allows us to write simple code like that in +GHC.Tc.Solver.solveEquality. At the time of writing it looked like +this (may get out of date but the idea is clear): + +solveEquality :: ... -> SolverStage Void +solveEquality ev eq_rel ty1 ty2 + = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2 + ; mb_canon <- canonicaliseEquality ev' eq_rel ty1' ty2' + ; case mb_canon of { + Left irred_ct -> do { tryQCsIrredEqCt irred_ct + ; solveIrred irred_ct } ; + Right eq_ct -> do { tryInertEqs eq_ct + ; tryFunDeps eq_ct + ; tryQCsEqCt eq_ct + ; simpleStage (updInertEqs eq_ct) + ; stopWithStage (eqCtEvidence eq_ct) ".." }}} + +Each sub-stage can elect to + (a) ContinueWith: continue to the next stasge + (b) StartAgain: start again at the beginning of the pipeline + (c) Stop: stop altogether; constraint is solved + +These three possiblities are described by the `StopOrContinue` data type. +The `SolverStage` monad does the plumbing. + +Notes: + +(SM1) Each individual stage pretty quickly drops down into + TcS (StopOrContinue a) + because the monadic plumbing of `SolverStage` is relatively ineffienct, + with that three-way split. + +(SM2) We use `SolverStage Void` to express the idea that ContinueWith is + impossible; we don't need to pattern match on it as a possible outcome:A + see GHC.Tc.Solver.Solve.solveOne. To that end, ContinueWith is strict. +-} + +data StopOrContinue a + = StartAgain Ct -- Constraint is not solved, but some unifications + -- happened, so go back to the beginning of the pipeline + + | ContinueWith !a -- The constraint was not solved, although it may have + -- been rewritten. It is strict so that + -- ContinueWith Void can't happen; see (SM2) in + -- Note [The SolverStage monad] + + | Stop CtEvidence -- The (rewritten) constraint was solved + SDoc -- Tells how it was solved + -- Any new sub-goals have been put on the work list + deriving (Functor) + +instance Outputable a => Outputable (StopOrContinue a) where + ppr (Stop ev s) = text "Stop" <> parens (s $$ text "ev:" <+> ppr ev) + ppr (ContinueWith w) = text "ContinueWith" <+> ppr w + ppr (StartAgain w) = text "StartAgain" <+> ppr w + +newtype SolverStage a = Stage { runSolverStage :: TcS (StopOrContinue a) } + deriving( Functor ) + +instance Applicative SolverStage where + pure x = Stage (return (ContinueWith x)) + (<*>) = ap + +instance Monad SolverStage where + return = pure + (Stage m) >>= k = Stage $ + do { soc <- m + ; case soc of + StartAgain x -> return (StartAgain x) + Stop ev d -> return (Stop ev d) + ContinueWith x -> runSolverStage (k x) } + +nopStage :: a -> SolverStage a +nopStage res = Stage (continueWith res) + +simpleStage :: TcS a -> SolverStage a +-- Always does a ContinueWith; no Stop or StartAgain +simpleStage thing = Stage (do { res <- thing; continueWith res }) + +startAgainWith :: Ct -> TcS (StopOrContinue a) +startAgainWith ct = return (StartAgain ct) + +continueWith :: a -> TcS (StopOrContinue a) +continueWith ct = return (ContinueWith ct) + +stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) +stopWith ev s = return (Stop ev (text s)) + +stopWithStage :: CtEvidence -> String -> SolverStage a +stopWithStage ev s = Stage (stopWith ev s) + + +{- ********************************************************************* +* * + Inert instances: inert_qcis +* * +********************************************************************* -} + +addInertQCI :: QCInst -> TcS () +-- Add a local quantified constraint, typically arising from a type signature +addInertQCI new_qci + = do { ics <- getInertCans + ; ics1 <- add_qci ics + + -- Update given equalities. C.f updateGivenEqs + ; tclvl <- getTcLevel + ; let body_pred = qci_body new_qci + not_equality = isClassPred body_pred && not (isEqClassPred body_pred) + -- True <=> definitely not an equality + -- A qci_body 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_qcis = 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_qcis = new_qci : qcis }) } + + same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci)) + (ctEvPred (qci_ev new_qci)) + +{- Note [Do not add duplicate quantified instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As an optimisation, we avoid adding duplicate quantified instances to the +inert set; we use a simple duplicate check using tcEqType for simplicity, +even though it doesn't account for superficial differences, e.g. it will count +the following two constraints as different (#22223): + + - forall a b. C a b + - forall b a. C a b + +The main logic that allows us to pick local instances, even in the presence of +duplicates, is explained in Note [Use only the best matching quantified constraint] +in GHC.Tc.Solver.Dict. +-} + +updInertDicts :: DictCt -> TcS () +updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) + = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys) + + ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys + -> -- For [G] ?x::ty, remove any dicts mentioning ?x, + -- from /both/ inert_cans /and/ inert_solved_dicts (#23761) + -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters] + updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) -> + inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics + , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved } + | otherwise + -> return () + -- Add the new constraint to the inert set + ; updInertCans (updDicts (addDict dict_ct)) } + where + -- Does this class constraint or any of its superclasses mention + -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'? + does_not_mention_ip_for :: Type -> DictCt -> Bool + does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys }) + = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys + -- See Note [Using typesAreApart when calling mightMentionIP] + -- in GHC.Core.Predicate + +updInertIrreds :: IrredCt -> TcS () +updInertIrreds irred + = do { tc_lvl <- getTcLevel + ; updInertCans $ addIrredToCans tc_lvl irred } + +{- ********************************************************************* +* * + Kicking out +* * +************************************************************************ +-} + + +----------------------------------------- +kickOutRewritable :: KickOutSpec -> CtFlavourRole -> TcS () +kickOutRewritable ko_spec new_fr + = do { ics <- getInertCans + ; let (kicked_out, ics') = kickOutRewritableLHS ko_spec new_fr ics + n_kicked = lengthBag kicked_out + ; setInertCans ics' + + ; unless (isEmptyBag kicked_out) $ + do { emitWork 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 = foldr add_one emptyVarSet kicked_out + add_one :: Ct -> VarSet -> VarSet + add_one ct vs | CtGiven (GivenCt { ctev_evar = ev_var }) <- ctEvidence ct + = vs `extendVarSet` ev_var + | otherwise = vs + + ; when (new_fr `eqCanRewriteFR` (Given, NomEq) && + -- if this isn't true, no use looking through the constraints + not (isEmptyVarSet kicked_given_ev_vars)) $ + do { traceTcS "Given(s) have been kicked out; drop from famapp-cache" + (ppr kicked_given_ev_vars) + ; dropFromFamAppCache kicked_given_ev_vars } + + ; csTraceTcS $ + hang (text "Kick out") + 2 (vcat [ text "n-kicked =" <+> int n_kicked + , text "kicked_out =" <+> ppr kicked_out + , text "Residual inerts =" <+> ppr ics' ]) } } + +kickOutAfterUnification :: [TcTyVar] -> TcS () +kickOutAfterUnification tv_list = case nonEmpty tv_list of + Nothing -> return () + Just tvs -> do + { let tv_set = mkVarSet tv_list + + ; n_kicked <- kickOutRewritable (KOAfterUnify tv_set) (Given, NomEq) + -- Given because the tv := xi is given; NomEq because + -- only nominal equalities are solved by unification + + -- Set the unification flag if we have done outer unifications + -- that might affect an earlier implication constraint + ; let min_tv_lvl = foldr1 minTcLevel (NE.map tcTyVarLevel tvs) + ; ambient_lvl <- getTcLevel + ; when (ambient_lvl `strictlyDeeperThan` min_tv_lvl) $ + setUnificationFlag min_tv_lvl + + ; traceTcS "kickOutAfterUnification" (ppr tvs $$ text "n_kicked =" <+> ppr n_kicked) + ; return n_kicked } + +kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () +-- See Wrinkle (URW2) in Note [Unify only if the rewriter set is empty] +-- in GHC.Tc.Solver.Equality +-- +-- 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 hole + = do { ics <- getInertCans + ; let (kicked_out, ics') = kick_out ics + n_kicked = length kicked_out + + ; unless (n_kicked == 0) $ + do { updWorkListTcS (extendWorkListRewrittenEqs 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 -> ([EqCt], InertCans) + kick_out ics@(IC { inert_eqs = eqs }) + = (eqs_to_kick, ics { inert_eqs = eqs_to_keep }) + where + (eqs_to_kick, eqs_to_keep) = partitionInertEqs kick_out_eq eqs + + kick_out_eq :: EqCt -> Bool -- True: kick out; False: keep. + kick_out_eq (EqCt { eq_ev = ev ,eq_lhs = lhs }) + | CtWanted (WantedCt { ctev_rewriters = RewriterSet rewriters }) <- ev + , TyVarLHS tv <- lhs + , isMetaTyVar tv + = hole `elementOfUniqSet` rewriters + | otherwise + = False + +-------------- +insertSafeOverlapFailureTcS :: InstanceWhat -> DictCt -> TcS () +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +insertSafeOverlapFailureTcS what item + | safeOverlap what + = return () + | otherwise + = updInertSet (\is -> is { inert_safehask = addDict item (inert_safehask is) }) + +getSafeOverlapFailures :: TcS (Bag DictCt) +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +getSafeOverlapFailures + = do { IS { inert_safehask = safehask } <- getInertSet + ; return $ foldDicts consBag safehask emptyBag } + +-------------- +updSolvedDicts :: InstanceWhat -> DictCt -> TcS () +-- Conditionally add a new item in the solved set of the monad +-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet +updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) + | isWanted ev + , instanceReturnsDictCon what + = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName + ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName + ; let contains_callstack_or_exceptionCtx = + mightMentionIP + (const True) + -- NB: the name of the call-stack IP is irrelevant + -- e.g (?foo :: CallStack) counts! + (is_callstack <||> is_exceptionCtx) + cls tys + -- See Note [Don't add HasCallStack constraints to the solved set] + ; unless contains_callstack_or_exceptionCtx $ + do { traceTcS "updSolvedDicts:" $ ppr dict_ct + ; updInertSet $ \ ics -> + ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) } + } } + | otherwise + = return () + where + + -- Return a predicate that decides whether a type is CallStack + -- or ExceptionContext, accounting for e.g. type family reduction, as + -- per Note [Using typesAreApart when calling mightMentionIP]. + -- + -- See Note [Using isCallStackTy in mightMentionIP]. + is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool) + is_tyConTy is_eq tc_name + = do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name + ; case mb_tc of + Just tc -> + return $ \ ty -> not (typesAreApart ty (mkTyConTy tc)) + Nothing -> + return is_eq + } + +{- Note [Don't add HasCallStack constraints to the solved set] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must not add solved Wanted dictionaries that mention HasCallStack constraints +to the solved set, or we might fail to accumulate the proper call stack, as was +reported in #25529. + +Recall that HasCallStack constraints (and the related HasExceptionContext +constraints) are implicit parameter constraints, and are accumulated as per +Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence. + +When we solve a Wanted that contains a HasCallStack constraint, we don't want +to cache the result, because re-using that solution means re-using the call-stack +in a different context! + +See also Note [Shadowing of implicit parameters], which deals with a similar +problem with Given implicit parameter constraints. + +Note [Using isCallStackTy in mightMentionIP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To implement Note [Don't add HasCallStack constraints to the solved set], +we need to check whether a constraint contains a HasCallStack or HasExceptionContext +constraint. We do this using the 'mentionsIP' function, but as per +Note [Using typesAreApart when calling mightMentionIP] we don't want to simply do: + + mightMentionIP + (const True) -- (ignore the implicit parameter string) + (isCallStackTy <||> isExceptionContextTy) + +because this does not account for e.g. a type family that reduces to CallStack. +The predicate we want to use instead is: + + \ ty -> not (typesAreApart ty callStackTy && typesAreApart ty exceptionContextTy) + +However, this is made difficult by the fact that CallStack and ExceptionContext +are not wired-in types; they are only known-key. This means we must look them +up using 'tcLookupTyCon'. However, this might fail, e.g. if we are in the middle +of typechecking ghc-internal and these data-types have not been typechecked yet! + +In that case, we simply fall back to the naive 'isCallStackTy'/'isExceptionContextTy' +logic. + +Note that it would be somewhat painful to wire-in ExceptionContext: at the time +of writing (March 2025), this would require wiring in the ExceptionAnnotation +class, as well as SomeExceptionAnnotation, which is a data type with existentials. +-} + +getSolvedDicts :: TcS (DictMap DictCt) +getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) } + +setSolvedDicts :: DictMap DictCt -> TcS () +setSolvedDicts solved_dicts + = updInertSet $ \ ics -> + ics { inert_solved_dicts = solved_dicts } + +{- ********************************************************************* +* * + Other inert-set operations +* * +********************************************************************* -} + +updInertSet :: (InertSet -> InertSet) -> TcS () +-- Modify the inert set with the supplied function +updInertSet upd_fn + = do { is_var <- getInertSetRef + ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var + ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } + +getInertCans :: TcS InertCans +getInertCans = do { inerts <- getInertSet; return (inert_cans inerts) } + +setInertCans :: InertCans -> TcS () +setInertCans ics = updInertSet $ \ 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 <- getInertSetRef + ; 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 + = updInertSet $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } + +getInertEqs :: TcS InertEqs +getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } + +getInnermostGivenEqLevel :: TcS TcLevel +getInnermostGivenEqLevel = do { inert <- getInertCans + ; return (inert_given_eq_lvl inert) } + +-- | Retrieves all insoluble constraints from the inert set, +-- specifically including Given constraints. +-- +-- This consists of: +-- +-- - insoluble equalities, such as @Int ~# Bool@; +-- - constraints that are top-level custom type errors, of the form +-- @TypeError msg@, but not constraints such as @Eq (TypeError msg)@ +-- in which the type error is nested; +-- - unsatisfiable constraints, of the form @Unsatisfiable msg@. +-- +-- The inclusion of Givens is important for pattern match warnings, as we +-- want to consider a pattern match that introduces insoluble Givens to be +-- redundant (see Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver). +getInertInsols :: TcS Cts +getInertInsols + = do { inert <- getInertCans + ; let insols = filterBag insolubleIrredCt (inert_irreds inert) + unsats = findDictsByTyConKey (inert_dicts inert) unsatisfiableClassNameKey + ; return $ fmap CDictCan unsats `unionBags` fmap CIrredCan insols } + +getInertGivens :: TcS [Ct] +-- Returns the Given constraints in the inert set +getInertGivens + = do { inerts <- getInertCans + ; let all_cts = foldIrreds ((:) . CIrredCan) (inert_irreds inerts) + $ foldDicts ((:) . CDictCan) (inert_dicts inerts) + $ foldFunEqs ((:) . CEqCan) (inert_funeqs inerts) + $ foldTyEqs ((:) . CEqCan) (inert_eqs inerts) + $ [] + ; return (filter isGivenCt all_cts) } + +getPendingGivenScs :: TcS [Ct] +-- Find all inert Given dictionaries, or quantified constraints, such that +-- 1. cc_pend_sc flag has fuel strictly > 0 +-- 2. belongs to the current level +-- For each such dictionary: +-- * Return it (with unmodified cc_pend_sc) in sc_pending +-- * Modify the dict in the inert set to have cc_pend_sc = doNotExpand +-- to record that we have expanded superclasses for this dict +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_qcis = 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_qcis = insts' }) + where + sc_pending = sc_pend_insts ++ map CDictCan sc_pend_dicts + + sc_pend_dicts :: [DictCt] + sc_pend_dicts = foldDicts get_pending dicts [] + dicts' = foldr exhaustAndAdd dicts sc_pend_dicts + + (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts + + exhaustAndAdd :: DictCt -> DictMap DictCt -> DictMap DictCt + exhaustAndAdd ct dicts = addDict (ct {di_pend_sc = doNotExpand}) dicts + -- Exhaust the fuel for this constraint before adding it as + -- we don't want to expand these constraints again + + get_pending :: DictCt -> [DictCt] -> [DictCt] -- Get dicts with cc_pend_sc > 0 + get_pending dict dicts + | isPendingScDictCt dict + , belongs_to_this_level (dictCtEvidence dict) + = dict : dicts + | otherwise + = dicts + + get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) + get_pending_inst cts qci@(QCI { qci_ev = ev }) + | Just qci' <- pendingScInst_maybe qci + , belongs_to_this_level ev + = (CQuantCan qci : cts, qci') + -- qci' have their fuel exhausted + -- we don't want to expand these constraints again + -- qci is expanded + | otherwise + = (cts, qci) + + belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) `sameDepthAs` this_lvl + -- We only want Givens from this level; see (3a) in + -- Note [The superclass story] in GHC.Tc.Solver.Dict + +getUnsolvedInerts :: TcS 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 + , inert_qcis = qcis + } <- getInertCans + + ; let unsolved_tv_eqs = foldTyEqs (add_if_unsolved CEqCan) tv_eqs emptyCts + unsolved_fun_eqs = foldFunEqs (add_if_unsolved CEqCan) fun_eqs emptyCts + unsolved_irreds = foldr (add_if_unsolved CIrredCan) emptyCts irreds + unsolved_dicts = foldDicts (add_if_unsolved CDictCan) idicts emptyCts + unsolved_qcis = foldr (add_if_unsolved CQuantCan) emptyCts qcis + + ; traceTcS "getUnsolvedInerts" $ + vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs + , text "fun eqs =" <+> ppr unsolved_fun_eqs + , text "dicts =" <+> ppr unsolved_dicts + , text "irreds =" <+> ppr unsolved_irreds ] + + ; return ( unsolved_tv_eqs `unionBags` + unsolved_fun_eqs `unionBags` + unsolved_irreds `unionBags` + unsolved_dicts `unionBags` + unsolved_qcis ) } + where + add_if_unsolved :: (a -> Ct) -> a -> Cts -> Cts + add_if_unsolved mk_ct thing cts + | isWantedCt ct = ct `consCts` cts + | otherwise = cts + where + ct = mk_ct thing + + +getHasGivenEqs :: TcLevel -- TcLevel of this implication + -> TcS ( HasGivenEqs -- are there Given equalities? + , InertIrreds ) -- 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 `sameDepthAs` 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 :: IrredCt -> Bool + -- Check for unreachability; specifically do not include UserError/Unsatisfiable + insoluble_given_equality (IrredCt { ir_ev = ev, ir_reason = reason }) + = isInsolubleReason reason && isGiven ev + +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 dict_ct -> is { inert_dicts = delDict dict_ct (inert_dicts is) } + CEqCan eq_ct -> delEq eq_ct is + CIrredCan ir_ct -> delIrred ir_ct is + CQuantCan {} -> panic "removeInertCt: CQuantCan" + CNonCanonical {} -> panic "removeInertCt: CNonCanonical" + +-- | Looks up a family application in the inerts. +lookupFamAppInert :: (CtFlavourRole -> Bool) -- can it rewrite the target? + -> TyCon -> [Type] -> TcS (Maybe EqCt) +lookupFamAppInert rewrite_pred fam_tc tys + = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getInertSet + ; return (lookup_inerts inert_funeqs) } + where + lookup_inerts inert_funeqs + = case findFunEq inert_funeqs fam_tc tys of + Nothing -> Nothing + Just (ecl :: [EqCt]) -> find (rewrite_pred . eqCtFlavourRole) ecl + +--------------------------- +lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction) +lookupFamAppCache fam_tc tys + = do { IS { inert_famapp_cache = famapp_cache } <- getInertSet + ; 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 ]) + ; updInertSet $ \ 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 + = updInertSet (\inerts@(IS { inert_famapp_cache = famapp_cache }) -> + inerts { inert_famapp_cache = filterTcAppMap check famapp_cache }) + where + check :: Reduction -> Bool + check redn + = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn) + +{- +************************************************************************ +* * +* 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. +-} + +-- | The mode for the constraint solving monad. +data TcSMode + = TcSMode -- See Note [TcSMode], where each field is documented + { tcsmResumable :: Bool + -- ^ Do not restore type-equality cycles + , tcsmEarlyAbort :: Bool + -- ^ Abort early on insoluble constraints + , tcsmSkipOverlappable :: Bool + -- ^ Do not select an OVERLAPPABLE instance + , tcsmFullySolveQCIs :: Bool + -- ^ Fully solve quantified constraints + } + +vanillaTcSMode :: TcSMode +vanillaTcSMode = TcSMode { tcsmResumable = False + , tcsmEarlyAbort = False + , tcsmSkipOverlappable = False + , tcsmFullySolveQCIs = False } + +instance Outputable TcSMode where + ppr (TcSMode { tcsmResumable = pm, tcsmEarlyAbort = ea + , tcsmSkipOverlappable = so, tcsmFullySolveQCIs = fs }) + = text "TcSMode" <> (braces $ cat $ punctuate comma $ catMaybes $ + [ pp_one pm "Resumable", pp_one ea "EarlyAbort" + , pp_one so "SkipOverlappable", pp_one fs "FullySolveQCIs" ]) + -- We get something like TcSMode{EarlyAbort,FullySolveQCIs}, + -- mentioning just the flags that are on + where + pp_one True s = Just (text s) + pp_one False _ = Nothing + +{- Note [TcSMode] +~~~~~~~~~~~~~~~~~ +The constraint solver can operate in different modes: + +* `tcsmResumable`: Used by the pattern match overlap checker. The idea is that + the returned InertSet will later be resumed, so we do not want to restore + type-equality cycles See also Note [Type equality cycles] in GHC.Tc.Solver.Equality + +* `tcsmEarlyAbort`: Abort (fail in the monad) as soon as we come across an + insoluble constraint. This is used to fail-fast when checking for hole-fits. + See Note [Speeding up valid hole-fits]. + +* `tcsmSkipOverlappable`: don't use OVERLAPPABLE instances. Used by the + short-cut solver. See Note [Shortcut solving] in GHC.Tc.Solver.Dict + +* `tcsmFullSolveQCIs`: fully solve quantified constraints, or leave them alone. + Used (only) for SPECIALISE pragmas; + see (NFS1) in Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig +-} + +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, so it + -- could equally well be a Bool instead of an Int. + + 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 TcM a } + deriving (Functor) + +instance MonadFix TcS where + mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env) + +-- | 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 + +liftZonkTcS :: ZonkM a -> TcS a +liftZonkTcS = wrapTcS . TcM.liftZonkM + +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.Monad" doc + +tryEarlyAbortTcS :: TcS () +-- Abort (fail in the monad) if the mode is TcSEarlyAbort +tryEarlyAbortTcS + = mkTcS (\env -> when (tcsmEarlyAbort (tcs_mode env)) TcM.failM) + +-- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'. +ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS () +ctLocWarnTcS loc msg = wrapTcS $ TcM.setCtLocM loc $ TcM.addDiagnostic msg + +traceTcS :: String -> SDoc -> TcS () +traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) +{-# INLINE traceTcS #-} -- see Note [INLINE conditional tracing utilities] + +runTcPluginTcS :: TcPluginM a -> TcS a +runTcPluginTcS = wrapTcS . runTcPluginM + +instance HasDynFlags TcS where + getDynFlags = wrapTcS getDynFlags + +getGlobalRdrEnvTcS :: TcS GlobalRdrEnv +getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv + +bumpStepCountTcS :: TcS () +bumpStepCountTcS = mkTcS $ \env -> + do { let ref = tcs_count env + ; n <- TcM.readTcRef ref + ; TcM.writeTcRef ref (n+1) } + +csTraceTcS :: SDoc -> TcS () +csTraceTcS doc + = wrapTcS $ csTraceTcM (return doc) +{-# INLINE csTraceTcS #-} -- see Note [INLINE conditional tracing utilities] + +traceFireTcS :: CtEvidence -> SDoc -> TcS () +-- Dump a rule-firing trace +traceFireTcS ev doc + = mkTcS $ \env -> csTraceTcM $ + do { n <- TcM.readTcRef (tcs_count env) + ; tclvl <- TcM.getTcLevel + ; return (hang (text "Step" <+> int n + <> brackets (text "l:" <> ppr tclvl <> comma <> + text "d:" <> ppr (ctLocDepth (ctEvLoc ev))) + <+> doc <> colon) + 4 (ppr ev)) } +{-# INLINE traceFireTcS #-} -- see Note [INLINE conditional tracing utilities] + +csTraceTcM :: TcM SDoc -> TcM () +-- Constraint-solver tracing, -ddump-cs-trace +csTraceTcM mk_doc + = do { logger <- getLogger + ; when ( logHasDumpFlag logger Opt_D_dump_cs_trace + || logHasDumpFlag logger Opt_D_dump_tc_trace) + ( do { msg <- mk_doc + ; TcM.dumpTcRn False + Opt_D_dump_cs_trace + "" FormatText + msg }) } +{-# INLINE csTraceTcM #-} -- see Note [INLINE conditional tracing utilities] + +runTcS :: TcS a -- What to run + -> TcM (a, EvBindMap) +runTcS tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; res <- runTcSWithEvBinds ev_binds_var tcs + ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var + ; return (res, ev_binds) } + +-- | This variant of 'runTcS' will immediately fail upon encountering an +-- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage +-- site does not need the ev_binds, so we do not return them. +runTcSEarlyAbort :: TcS a -> TcM a +runTcSEarlyAbort tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; runTcSWithEvBinds' mode ev_binds_var tcs } + where + mode = vanillaTcSMode { tcsmEarlyAbort = True } + +-- | 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' (vanillaTcSMode { tcsmResumable = True }) + ev_binds_var $ + do { setInertSet inerts + ; a <- tcs + ; new_inerts <- getInertSet + ; return (a, new_inerts) } } + +runTcSWithEvBinds :: EvBindsVar + -> TcS a + -> TcM a +runTcSWithEvBinds = runTcSWithEvBinds' vanillaTcSMode + +runTcSWithEvBinds' :: TcSMode + -> EvBindsVar + -> TcS a + -> TcM a +runTcSWithEvBinds' mode ev_binds_var thing_inside + = do { unified_var <- TcM.newTcRef 0 + ; step_count <- TcM.newTcRef 0 + + -- Make a fresh, empty inert set + -- Subtle point: see (TGE6) in Note [Tracking Given equalities] + -- in GHC.Tc.Solver.InertSet + ; tc_lvl <- TcM.getTcLevel + ; inert_var <- TcM.newTcRef (emptyInertSet tc_lvl) + + ; 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_mode = mode + , tcs_worklist = wl_var } + + -- Run the computation + ; res <- unTcS thing_inside env + + ; count <- TcM.readTcRef step_count + ; when (count > 0) $ + csTraceTcM $ return (text "Constraint solver steps =" <+> int count) + + -- Restore tyvar cycles: see Note [Type equality cycles] in + -- GHC.Tc.Solver.Equality + -- But /not/ when tcsmResumable is set: see Note [TcSMode] + ; unless (tcsmResumable mode) $ + 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 }) = isEqPred (varType b) + + edges :: [ Node EvVar EvBind ] + edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (nestedEvIdsOfTerm 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 }) + +setTcLevelTcS :: TcLevel -> TcS a -> TcS a +setTcLevelTcS lvl (TcS thing_inside) + = TcS $ \ env -> TcM.setTcLevel lvl (thing_inside env) + +nestImplicTcS :: EvBindsVar + -> TcLevel -> TcS a + -> TcS a +nestImplicTcS ev_binds_var inner_tclvl (TcS thing_inside) + = TcS $ \ env@(TcSEnv { tcs_inerts = old_inert_var }) -> + do { inerts <- TcM.readTcRef old_inert_var + + -- Initialise the inert_cans from the inert_givens of the parent + -- so that the child is not polluted with the parent's inert Wanteds + -- See Note [trySolveImplication] in GHC.Tc.Solver.Solve + -- All other InertSet fields are inherited + ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack + (inert_cycle_breakers inerts) + , inert_cans = (inert_givens inerts) + { inert_given_eqs = False } } + ; new_inert_var <- TcM.newTcRef nest_inert + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; let nest_env = env { tcs_ev_binds = ev_binds_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 ev_binds_var + ; 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 } + -- Inherit tcs_ev_binds from caller + + ; res <- thing_inside nest_env + + ; new_inerts <- TcM.readTcRef new_inert_var + ; TcM.updTcRef inerts_var (`updateInertsWith` new_inerts) + + ; return res } + +tryShortCutTcS :: TcS Bool -> TcS Bool +-- Like nestTcS, but +-- (a) be a no-op if the nested computation returns False +-- (b) if (but only if) success, propagate nested bindings to the caller +-- Use only by the short-cut solver; +-- see Note [Shortcut solving] in GHC.Tc.Solver.Dict +tryShortCutTcS (TcS thing_inside) + = TcS $ \ env@(TcSEnv { tcs_mode = mode + , tcs_inerts = inerts_var + , tcs_ev_binds = old_ev_binds_var }) -> + do { -- Initialise a fresh inert set, with no Givens and no Wanteds + -- (i.e. empty `inert_cans`) + -- But inherit all the InertSet cache fields; in particular + -- * the given_eq_lvl, so we don't accidentally unify a + -- unification variable from outside a GADT match + -- * the `solved_dicts`; see wrinkle (SCS3) of Note [Shortcut solving] + -- * the `famapp_cache`; similarly + old_inerts <- TcM.readTcRef inerts_var + ; let given_eq_lvl = inert_given_eq_lvl (inert_cans old_inerts) + new_inerts = old_inerts { inert_cans = emptyInertCans given_eq_lvl } + ; new_inert_var <- TcM.newTcRef new_inerts + + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; new_ev_binds_var <- TcM.cloneEvBindsVar old_ev_binds_var + ; let nest_env = env { tcs_mode = mode { tcsmSkipOverlappable = True } + , tcs_ev_binds = new_ev_binds_var + , tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var } + + ; TcM.traceTc "tryTcS {" $ + vcat [ text "old_ev_binds:" <+> ppr old_ev_binds_var + , text "new_ev_binds:" <+> ppr new_ev_binds_var + , ppr old_inerts ] + ; solved <- thing_inside nest_env + ; TcM.traceTc "tryTcS }" (ppr solved) + + ; if not solved + then return False + else do { -- Successfully solved + -- Add the new bindings to the existing ones + ; TcM.updTcEvBinds old_ev_binds_var new_ev_binds_var + + -- Update the existing inert set + ; new_inerts <- TcM.readTcRef new_inert_var + ; TcM.updTcRef inerts_var (`updateInertsWith` new_inerts) + + ; TcM.traceTc "tryTcS update" (ppr (inert_solved_dicts new_inerts)) + + ; return True } } + +updateInertsWith :: InertSet -> InertSet -> InertSet +-- Update the current inert set with bits from a nested solve, +-- that finished with a new inert set +-- In particular, propagate: +-- - solved dictionaires; see Note [Propagate the solved dictionaries] +-- - Safe Haskell failures +updateInertsWith current_inerts + (IS { inert_solved_dicts = new_solved + , inert_safehask = new_safehask }) + = current_inerts { inert_solved_dicts = new_solved + , inert_safehask = new_safehask } + +{- 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 +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +getTcSMode :: TcS TcSMode +getTcSMode = TcS (return . tcs_mode) + +setTcSMode :: TcSMode -> TcS a -> TcS a +setTcSMode mode thing_inside + = TcS (\env -> unTcS thing_inside (env { tcs_mode = mode })) + +getUnifiedRef :: TcS (IORef Int) +getUnifiedRef = TcS (return . tcs_unified) + +-- Getter of inerts and worklist +getInertSetRef :: TcS (IORef InertSet) +getInertSetRef = TcS (return . tcs_inerts) + +getInertSet :: TcS InertSet +getInertSet = getInertSetRef >>= readTcRef + +setInertSet :: InertSet -> TcS () +setInertSet is = do { r <- getInertSetRef; writeTcRef r is } + + +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 [TcCoercion] +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.liftZonkM $ TcM.writeMetaTyVar tv ty + ; TcM.updTcRef (tcs_unified env) (+1) } + +reportUnifications :: TcS a -> TcS (Int, a) +-- Record how many unifications are done by thing_inside +-- We could return a Bool instead of an Int; +-- all that matters is whether it is no-zero +reportUnifications (TcS thing_inside) + = TcS $ \ env -> + do { inner_unified <- TcM.newTcRef 0 + ; res <- thing_inside (env { tcs_unified = inner_unified }) + ; n_unifs <- TcM.readTcRef inner_unified + ; TcM.updTcRef (tcs_unified env) (+ n_unifs) + ; return (n_unifs, res) } + +getDefaultInfo :: TcS (DefaultEnv, 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 + +setSrcSpan :: RealSrcSpan -> TcS a -> TcS a +setSrcSpan ss = wrap2TcS (TcM.setSrcSpan (RealSrcSpan ss mempty)) + +tcLookupClass :: Name -> TcS Class +tcLookupClass c = wrapTcS $ TcM.tcLookupClass c + +tcLookupId :: Name -> TcS Id +tcLookupId n = wrapTcS $ TcM.tcLookupId n + +tcLookupTyCon :: Name -> TcS TyCon +tcLookupTyCon n = wrapTcS $ TcM.tcLookupTyCon n + +-- Any use of this function is a bit suspect, because it violates the +-- pure veneer of TcS. But it's just about warnings around unused imports +-- and local constructors (GHC will issue fewer warnings than it otherwise +-- might), so it's not worth losing sleep over. +recordUsedGREs :: Bag GlobalRdrElt -> TcS () +recordUsedGREs gres + = do { wrapTcS $ TcM.addUsedGREs NoDeprecationWarnings gre_list + -- If a newtype constructor was imported, don't warn about not + -- importing it... + ; wrapTcS $ traverse_ (TcM.keepAlive . greName) gre_list } + -- ...and similarly, if a newtype constructor was defined in the same + -- module, don't warn about it being unused. + -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils. + + where + gre_list = bagToList gres + +-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +checkWellLevelledDFun :: 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 + +checkWellLevelledDFun loc what pred + = do + mbind_lvl <- checkWellLevelledInstanceWhat what + case mbind_lvl of + Just (bind_lvls, is_local) -> + wrapTcS $ TcM.setCtLocM loc $ do + { use_lvl <- thLevelIndex <$> TcM.getThLevel + ; dflags <- getDynFlags + ; checkCrossLevelClsInst dflags (LevelCheckInstance what pred) bind_lvls use_lvl is_local } + -- If no level information is returned for an InstanceWhat, then it's safe to use + -- at any level. + Nothing -> return () + + +-- TODO: Unify this with checkCrossLevelLifting function +checkCrossLevelClsInst :: DynFlags -> LevelCheckReason + -> Set.Set ThLevelIndex -> ThLevelIndex + -> Bool -> TcM () +checkCrossLevelClsInst dflags reason bind_lvls use_lvl_idx is_local + -- If the Id is imported, then allow with ImplicitStagePersistence + | not is_local + , xopt LangExt.ImplicitStagePersistence dflags + = return () + -- NB: Do this check after the ImplicitStagePersistence check, because + -- it will do some computation to work out the levels of instances. + | use_lvl_idx `Set.member` bind_lvls = return () + -- With ImplicitStagePersistence, using later than bound is fine + | xopt LangExt.ImplicitStagePersistence dflags + , any (use_lvl_idx >=) bind_lvls = return () + | otherwise = TcM.addErrTc (TcRnBadlyLevelled reason bind_lvls use_lvl_idx Nothing ErrorWithoutFlag) + + + +-- | Returns the ThLevel of evidence for the solved constraint (if it has evidence) +-- See Note [Well-levelled instance evidence] +checkWellLevelledInstanceWhat :: HasCallStack => InstanceWhat -> TcS (Maybe (Set.Set ThLevelIndex, Bool)) +checkWellLevelledInstanceWhat what + | TopLevInstance { iw_dfun_id = dfun_id } <- what + = Just <$> checkNameVisibleLevels (idName dfun_id) + | BuiltinTypeableInstance tc <- what + -- The typeable instance is always defined in the same module as the TyCon. + = Just <$> checkNameVisibleLevels (tyConName tc) + | otherwise = return Nothing + +-- | Check the levels at which the given name is visible, including a boolean +-- indicating if the name is local or not. +checkNameVisibleLevels :: Name -> TcS (Set.Set ThLevelIndex, Bool) +checkNameVisibleLevels name = do + cur_mod <- extractModule <$> getGblEnv + if nameIsLocalOrFrom cur_mod name + then return (Set.singleton topLevelIndex, True) + else do + lvls <- checkModuleVisibleLevels (nameModule name) + return (lvls, False) + +{- Note [Using the module graph to compute TH level visiblities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking a module M, in order to implement GHC proposal #682 +(see Note [Explicit Level Imports] in GHC.Tc.Gen.Head), we need to be able to +compute the Template Haskell levels that typeclass instances are visible at in M. + +To do this, we use the "level 0 imports" module graph, which we query via +GHC.Unit.Module.Graph.mgQueryZero. For example, if we want all modules that are +visible at level -1 from M, we do the following: + + 1. start with all the direct of M imports at level -1, i.e. the "splice imports" + 2. then look at all modules that are reachable from these using only level 0 + normal imports, using 'mgQueryZero'. + +This works precisely because, as specified in the proposal, with -XNoImplicitStagePersistence, +modules only export items at level 0. In particular, instances are only exported +at level 0. + +See the SI36 test for an illustration. +-} + +-- | Check which TH levels a module is visable at +-- +-- Used to check visibility of instances (do not use this for normal identifiers). +checkModuleVisibleLevels :: Module -> TcS (Set.Set ThLevelIndex) +checkModuleVisibleLevels check_mod = do + cur_mod <- extractModule <$> getGblEnv + hsc_env <- getTopEnv + + -- 0. The keys for the scope of the current module. + let mkKey s m = (ModuleScope (moduleToMnk m NotBoot) s) + cur_mod_scope_key s = mkKey s cur_mod + + -- 1. is_visible checks that a specific key is visible from the given level in the + -- current module. + let is_visible :: ImportLevel -> ZeroScopeKey -> Bool + is_visible s k = mgQueryZero (hsc_mod_graph hsc_env) (cur_mod_scope_key s) k + + -- 2. The key we are looking for, either the module itself in the home package or the + -- module unit id of the module we are checking. + let instance_key = if moduleUnitId check_mod `Set.member` hsc_all_home_unit_ids hsc_env + then mkKey NormalLevel check_mod + else UnitScope (moduleUnitId check_mod) + + -- 3. For each level, check if the key is visible from that level. + let lvls = [ thLevelIndexFromImportLevel lvl | lvl <- allImportLevels, is_visible lvl instance_key] + return $ Set.fromList lvls + +{- +Note [Well-levelled 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 levelled. It's easy to know the level of `$tcT`: for imported TyCons it +will be the level of the imported TyCon Name, 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 level 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) + +isUnfilledMetaTyVar :: TcTyVar -> TcS Bool +isUnfilledMetaTyVar tv = wrapTcS $ TcM.isUnfilledMetaTyVar tv + +zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet +zonkTyCoVarsAndFV tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFV tvs) + +zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar] +zonkTyCoVarsAndFVList tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFVList tvs) + +zonkCo :: Coercion -> TcS Coercion +zonkCo = wrapTcS . fmap TcM.liftZonkM TcM.zonkCo + +zonkTcType :: TcType -> TcS TcType +zonkTcType ty = liftZonkTcS (TcM.zonkTcType ty) + +zonkTcTypes :: [TcType] -> TcS [TcType] +zonkTcTypes tys = liftZonkTcS (TcM.zonkTcTypes tys) + +zonkTcTyVar :: TcTyVar -> TcS TcType +zonkTcTyVar tv = liftZonkTcS (TcM.zonkTcTyVar tv) + +zonkSimples :: Cts -> TcS Cts +zonkSimples cts = liftZonkTcS (TcM.zonkSimples cts) + +zonkWC :: WantedConstraints -> TcS WantedConstraints +zonkWC wc = liftZonkTcS (TcM.zonkWC wc) + +zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar +zonkTyCoVarKind tv = liftZonkTcS (TcM.zonkTyCoVarKind tv) + +---------------------------- +pprKicked :: Int -> SDoc +pprKicked 0 = empty +pprKicked n = parens (int n <+> text "kicked out") + + +{- ********************************************************************* +* * +* The work list +* * +********************************************************************* -} + + +getTcSWorkListRef :: TcS (IORef WorkList) +getTcSWorkListRef = TcS (return . tcs_worklist) + +getWorkList :: TcS WorkList +getWorkList = do { wl_var <- getTcSWorkListRef + ; readTcRef wl_var } + +updWorkListTcS :: (WorkList -> WorkList) -> TcS () +updWorkListTcS f + = do { wl_var <- getTcSWorkListRef + ; updTcRef wl_var f } + +emitWorkNC :: [CtEvidence] -> TcS () +emitWorkNC evs + | null evs + = return () + | otherwise + = emitWork (listToBag (map mkNonCanonical evs)) + +emitWork :: Cts -> TcS () +emitWork cts + | isEmptyBag cts -- Avoid printing, among other work + = return () + | otherwise + = do { traceTcS "Emitting fresh work" (pprBag cts) + ; updWorkListTcS (extendWorkListCts cts) } + +selectNextWorkItem :: TcS (Maybe Ct) +-- Pick which work item to do next +-- See Note [Prioritise equalities] +-- +-- Postcondition: if the returned item is a Wanted equality, +-- then its rewriter set is fully zonked. +-- +-- Suppose a constraint c1 is rewritten by another, c2. When c2 +-- gets solved, c1 has no rewriters, and can be prioritised; see +-- Note [Prioritise Wanteds with empty RewriterSet] in +-- GHC.Tc.Types.Constraint wrinkle (PER1) + +-- ToDo: if wl_rw_eqs is long, we'll re-zonk it each time we pick +-- a new item from wl_rest. Bad. +selectNextWorkItem + = do { wl_var <- getTcSWorkListRef + ; wl <- readTcRef wl_var + + ; case wl of { WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X + , wl_rw_eqs = rw_eqs, wl_rest = rest } + | ct:cts <- eqs_N -> pick_me ct (wl { wl_eqs_N = cts }) + | ct:cts <- eqs_X -> pick_me ct (wl { wl_eqs_X = cts }) + | otherwise -> try_rws [] rw_eqs + where + pick_me :: Ct -> WorkList -> TcS (Maybe Ct) + pick_me ct new_wl + = do { writeTcRef wl_var new_wl + ; return (Just ct) } + -- NB: no need for checkReductionDepth (ctLoc ct) (ctPred ct) + -- This is done by GHC.Tc.Solver.Dict.chooseInstance + + -- try_rws looks through rw_eqs to find one that has an empty + -- rewriter set, after zonking. If none such, call try_rest. + try_rws acc (ct:cts) + = do { ct' <- liftZonkTcS (TcM.zonkCtRewriterSet ct) + ; if ctHasNoRewriters ct' + then pick_me ct' (wl { wl_rw_eqs = cts ++ acc }) + else try_rws (ct':acc) cts } + try_rws acc [] = try_rest acc + + try_rest zonked_rws + | ct:cts <- rest = pick_me ct (wl { wl_rw_eqs = zonked_rws, wl_rest = cts }) + | ct:cts <- zonked_rws = pick_me ct (wl { wl_rw_eqs = cts }) + | otherwise = return Nothing + } } + + +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 + + +{- ********************************************************************* +* * +* 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 is done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver. + +It helpful not to iterate unless there is a chance of progress. #8474 is +an example: + + * There's a deeply-nested chain of implication constraints. + ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int + + * From the innermost one we get a [W] alpha[1] ~ Int, + so we can unify. + + * It's better not to iterate the inner implications, but go all the + way out to level 1 before iterating -- because iterating level 1 + will iterate the inner levels anyway. + +(In the olden days when we "floated" thse Derived constraints, this was +much, much more important -- we got exponential behaviour, as each iteration +produced the same Derived constraint.) +-} + + +resetUnificationFlag :: TcS Bool +-- We are at ambient level i +-- If the unification flag = Just i, reset it to Nothing and return True +-- Otherwise leave it unchanged and return False +resetUnificationFlag + = TcS $ \env -> + do { let ref = tcs_unif_lvl env + ; ambient_lvl <- TcM.getTcLevel + ; mb_lvl <- TcM.readTcRef ref + ; TcM.traceTc "resetUnificationFlag" $ + vcat [ text "ambient:" <+> ppr ambient_lvl + , text "unif_lvl:" <+> ppr mb_lvl ] + ; case mb_lvl of + Nothing -> return False + Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl + -> return False + | otherwise + -> do { TcM.writeTcRef ref Nothing + ; return True } } + +setUnificationFlag :: TcLevel -> TcS () +-- (setUnificationFlag i) sets the unification level to (Just i) +-- unless it already is (Just j) where j <= i +setUnificationFlag lvl + = TcS $ \env -> + do { let ref = tcs_unif_lvl env + ; mb_lvl <- TcM.readTcRef ref + ; case mb_lvl of + Just unif_lvl | lvl `deeperThanOrSame` unif_lvl + -> return () + _ -> TcM.writeTcRef ref (Just lvl) } + + +{- ********************************************************************* +* * +* Instantiation etc. +* * +********************************************************************* -} + +-- Instantiations +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType) +instDFunType dfun_id inst_tys + = wrapTcS $ TcM.instDFunType dfun_id inst_tys + +newFlexiTcSTy :: Kind -> TcS TcType +newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) + +cloneMetaTyVar :: TcTyVar -> TcS TcTyVar +cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) + +instFlexiX :: Subst -> [TKVar] -> TcS Subst +instFlexiX subst tvs = wrapTcS (instFlexiXTcM subst tvs) + +instFlexiXTcM :: Subst -> [TKVar] -> TcM Subst +-- Makes fresh tyvar, extends the substitution, and the in-scope set +-- Takes account of the case [k::Type, a::k, ...], +-- where we must substitute for k in a's kind +instFlexiXTcM subst [] + = return subst +instFlexiXTcM subst (tv:tvs) + = do { uniq <- TcM.newUnique + ; details <- TcM.newMetaDetails TauTv + ; let name = setNameUnique (tyVarName tv) uniq + kind = substTyUnchecked subst (tyVarKind tv) + tv' = mkTcTyVar name kind details + subst' = extendTvSubstWithClone subst tv tv' + ; instFlexiXTcM subst' tvs } + +matchGlobalInst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS TcM.ClsInstResult +matchGlobalInst dflags cls tys loc + = do { mode <- getTcSMode + ; let skip_overlappable = tcsmSkipOverlappable mode + ; wrapTcS $ TcM.matchGlobalInst dflags skip_overlappable cls tys (Just loc) } + +tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar]) +tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs + +-- Creating and setting evidence variables and CtFlavors +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data MaybeNew = Fresh WantedCtEvidence | Cached EvExpr + +isFresh :: MaybeNew -> Bool +isFresh (Fresh {}) = True +isFresh (Cached {}) = False + +freshGoals :: [MaybeNew] -> [WantedCtEvidence] +freshGoals mns = [ ctev | Fresh ctev <- mns ] + +getEvExpr :: MaybeNew -> EvExpr +getEvExpr (Fresh ctev) = ctEvExpr (CtWanted 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 +addUsedCoercion :: TcCoercion -> TcS () +addUsedCoercion co + = do { ev_binds_var <- getTcEvBindsVar + ; wrapTcS (TcM.updTcRef (ebv_tcvs ev_binds_var) (co :)) } + +-- | Equalities only +setWantedEq :: HasDebugCallStack => TcEvDest -> TcCoercion -> TcS () +setWantedEq (HoleDest hole) co + = do { addUsedCoercion co + ; fillCoercionHole hole co } +setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev) + +-- | Good for both equalities and non-equalities +setWantedEvTerm :: TcEvDest -> CanonicalEvidence -> EvTerm -> TcS () +setWantedEvTerm (HoleDest hole) _canonical tm + | Just co <- evTermCoercion_maybe tm + = do { addUsedCoercion co + ; fillCoercionHole hole co } + | otherwise + = -- See Note [Yukky eq_sel for a HoleDest] + do { let co_var = coHoleCoVar hole + ; setEvBind (mkWantedEvBind co_var EvCanonical tm) + ; fillCoercionHole hole (mkCoVarCo co_var) } + +setWantedEvTerm (EvVarDest ev_id) canonical tm + = setEvBind (mkWantedEvBind ev_id canonical 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 -> CanonicalEvidence -> EvTerm -> TcS () +setEvBindIfWanted ev canonical tm + = case ev of + CtWanted (WantedCt { ctev_dest = dest }) -> setWantedEvTerm dest canonical 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 GivenCtEvidence +-- 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 $ GivenCt { 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 } + +emitNewGivens :: CtLoc -> [(Role,TcCoercion)] -> TcS () +emitNewGivens loc pts + = do { traceTcS "emitNewGivens" (ppr pts) + ; gs <- mapM (newGivenEvVar loc) $ + [ (mkEqPredRole role ty1 ty2, evCoercion co) + | (role, co) <- pts + , let Pair ty1 ty2 = coercionKind co + , not (ty1 `tcEqType` ty2) ] -- Kill reflexive Givens at birth + ; emitWorkNC (map CtGiven gs) } + +emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion +-- | Emit a new Wanted equality into the work-list +emitNewWantedEq loc rewriters role ty1 ty2 + = do { (wtd, co) <- newWantedEq loc rewriters role ty1 ty2 + ; updWorkListTcS (extendWorkListEq rewriters (mkNonCanonical $ CtWanted wtd)) + ; 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 (WantedCtEvidence, Coercion) +newWantedEq loc rewriters role ty1 ty2 + = do { hole <- wrapTcS $ TcM.newCoercionHole pty + ; let wtd = WantedCt { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = rewriters } + ; return (wtd, mkHoleCo hole) } + where + pty = mkEqPredRole 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 WantedCtEvidence +-- Don't look up in the solved/inerts; we know it's not there +newWantedEvVarNC loc rewriters pty + = assertPpr (not (isEqPred pty)) (ppr pty) $ + do { new_ev <- newEvVar pty + ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ + pprCtLoc loc) + ; return $ WantedCt { ctev_pred = pty + , ctev_dest = EvVarDest new_ev + , ctev_loc = loc + , ctev_rewriters = rewriters } + } + +-- | `newWantedEvVar` makes up a fresh evidence variable for the given predicate. +-- For ClassPred, check if this exact predicate type is in the solved dicts +-- But do /not/ look in the inert_cans, because doing so bypasses all +-- all the careful tests in tryInertDicts, leading to +-- #20666 (prohibitedSuperClassSolve) and #26117 (short-cut solve) +-- We do no such caching forIPs, holes, or errors; so for anything +-- except ClassPred, this is the same as newWantedEvVarNC +-- +-- Don't use this for equality constraints: this function is only for +-- constraints with 'EvVarDest'. +newWantedEvVar :: CtLoc -> RewriterSet + -> TcPredType -> TcS MaybeNew +newWantedEvVar loc rewriters pty + = case classifyPredType pty of + EqPred {} -> pprPanic "newWantedEvVar: HoleDestPred" (ppr pty) + ClassPred cls tys + -> do { inerts <- getInertSet + ; case lookupSolvedDict inerts cls tys of + Just ev -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ev + ; return $ Cached (ctEvExpr ev) } + Nothing -> do { ev <- newWantedEvVarNC loc rewriters pty + ; return (Fresh ev) } } + _other -> do { ev <- newWantedEvVarNC loc rewriters pty + ; return (Fresh ev) } + +-- | 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 WantedCtEvidence +newWantedNC loc rewriters pty + | Just (role, ty1, ty2) <- getEqPredTys_maybe pty + = fst <$> newWantedEq loc rewriters role ty1 ty2 + | otherwise + = newWantedEvVarNC loc rewriters pty + +-- | 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 (reductionDepth 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, env0) <- TcM.liftZonkM $ + do { ty <- TcM.zonkTcType ty + ; env0 <- TcM.tcInitTidyEnv + ; return (ty, env0) } + ; let (tidy_env, tidy_ty) = tidyOpenTypeX env0 ty + msg = TcRnSolverDepthError tidy_ty depth + ; TcM.failWithTcM (tidy_env, msg) } + where + depth = ctLocDepth loc + +{- +************************************************************************ +* * + Emitting equalities arising from fundeps +* * +************************************************************************ +-} + +emitFunDepWanteds :: CtEvidence -- The work item + -> [FunDepEqn (CtLoc, RewriterSet)] + -> TcS Bool -- True <=> some unification happened + +emitFunDepWanteds _ [] = return False -- common case noop +-- See Note [FunDep and implicit parameter reactions] in GHC.Tc.Solver.Dict + +emitFunDepWanteds ev fd_eqns + = unifyFunDeps ev Nominal do_fundeps + where + do_fundeps :: UnifyEnv -> TcM () + do_fundeps env = mapM_ (do_one env) fd_eqns + + do_one :: UnifyEnv -> FunDepEqn (CtLoc, RewriterSet) -> TcM () + do_one uenv (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) }) + = do { eqs' <- instantiate_eqs tvs (reverse eqs) + -- (reverse eqs): See Note [Reverse order of fundep equations] + ; uPairsTcM env_one eqs' } + where + env_one = uenv { u_rewriters = u_rewriters uenv S.<> rewriters + , u_loc = loc } + + instantiate_eqs :: [TyVar] -> [TypeEqn] -> TcM [TypeEqn] + instantiate_eqs tvs eqs + | null tvs + = return eqs + | otherwise + = do { TcM.traceTc "emitFunDepWanteds 2" (ppr tvs $$ ppr eqs) + ; subst <- instFlexiXTcM emptySubst tvs -- Takes account of kind substitution + ; return [ Pair (substTyUnchecked subst' ty1) ty2 + -- ty2 does not mention fd_qtvs, so no need to subst it. + -- See GHC.Tc.Instance.Fundeps Note [Improving against instances] + -- Wrinkle (1) + | Pair ty1 ty2 <- eqs + , let subst' = extendSubstInScopeSet subst (tyCoVarsOfType ty1) ] + -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result + -- of matching with the [W] constraint. So we add its free + -- vars to InScopeSet, to satisfy substTy's invariants, even + -- though ty1 will never (currently) be a poytype, so this + -- InScopeSet will never be looked at. + } + +{- +************************************************************************ +* * + Unification +* * +************************************************************************ + +Note [wrapUnifierTcS] +~~~~~~~~~~~~~~~~~~~ +When decomposing equalities we often create new wanted constraints for +(s ~ t). But what if s=t? Then it'd be faster to return Refl right away. + +Rather than making an equality test (which traverses the structure of the type, +perhaps fruitlessly), we call uType (via wrapUnifierTcS) to traverse the common +structure, and bales out when it finds a difference by creating a new deferred +Wanted constraint. But where it succeeds in finding common structure, it just +builds a coercion to reflect it. + +This is all much faster than creating a new constraint, putting it in the +work list, picking it out, canonicalising it, etc etc. + +Note [unifyFunDeps] +~~~~~~~~~~~~~~~~~~~ +The Bool returned by `unifyFunDeps` is True if we have unified a variable +that occurs in the constraint we are trying to solve; it is not in the +inert set so `wrapUnifierTcS` won't kick it out. Instead we want to send it +back to the start of the pipeline. Hence the Bool. + +It's vital that we don't return (not (null unified)) because the fundeps +may create fresh variables; unifying them (alone) should not make us send +the constraint back to the start, or we'll get an infinite loop. See +Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Dict +and Note [Improvement orientation] in GHC.Tc.Solver.Equality. +-} + +uPairsTcM :: UnifyEnv -> [TypeEqn] -> TcM () +uPairsTcM uenv eqns = mapM_ (\(Pair ty1 ty2) -> uType uenv ty1 ty2) eqns + +unifyFunDeps :: CtEvidence -> Role + -> (UnifyEnv -> TcM ()) + -> TcS Bool +unifyFunDeps ev role do_unifications + = do { (_, _, unified) <- wrapUnifierTcS ev role do_unifications + ; return (any (`elemVarSet` fvs) unified) } + -- See Note [unifyFunDeps] + where + fvs = tyCoVarsOfType (ctEvPred ev) + +unifyForAllBody :: CtEvidence -> Role -> (UnifyEnv -> TcM a) + -> TcS (a, Cts) +-- We /return/ the equality constraints we generate, +-- rather than emitting them into the monad. +-- See See (SF5) in Note [Solving forall equalities] in GHC.Tc.Solver.Equality +unifyForAllBody ev role unify_body + = do { (res, cts, unified) <- wrapUnifierX ev role unify_body + + -- Kick out any inert constraint that we have unified + ; _ <- kickOutAfterUnification unified + + ; return (res, cts) } + +wrapUnifierTcS :: CtEvidence -> Role + -> (UnifyEnv -> TcM a) -- Some calls to uType + -> TcS (a, Bag Ct, [TcTyVar]) +-- Invokes the do_unifications argument, with a suitable UnifyEnv. +-- Emit deferred equalities and kick-out from the inert set as a +-- result of any unifications. +-- Very good short-cut when the two types are equal, or nearly so +-- See Note [wrapUnifierTcS] +-- +-- The [TcTyVar] is the list of unification variables that were +-- unified the process; the (Bag Ct) are the deferred constraints. + +wrapUnifierTcS ev role do_unifications + = do { (res, cts, unified) <- wrapUnifierX ev role do_unifications + + -- Emit the deferred constraints + -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality + -- + -- All the constraints in `cts` share the same rewriter set so, + -- rather than looking at it one by one, we pass it to + -- extendWorkListChildEqs; just a small optimisation. + ; unless (isEmptyBag cts) $ + updWorkListTcS (extendWorkListChildEqs ev cts) + + -- And kick out any inert constraint that we have unified + ; _ <- kickOutAfterUnification unified + + ; return (res, cts, unified) } + +wrapUnifierX :: CtEvidence -> Role + -> (UnifyEnv -> TcM a) -- Some calls to uType + -> TcS (a, Bag Ct, [TcTyVar]) +wrapUnifierX ev role do_unifications + = do { unif_count_ref <- getUnifiedRef + ; wrapTcS $ + do { defer_ref <- TcM.newTcRef emptyBag + ; unified_ref <- TcM.newTcRef [] + ; let env = UE { u_role = role + , u_rewriters = ctEvRewriters ev + , u_loc = ctEvLoc ev + , u_defer = defer_ref + , u_unified = Just unified_ref} + -- u_rewriters: the rewriter set and location from + -- the parent constraint `ev` are inherited in any + -- new constraints spat out by the unifier + + ; res <- do_unifications env + + ; cts <- TcM.readTcRef defer_ref + ; unified <- TcM.readTcRef unified_ref + + -- Don't forget to update the count of variables + -- unified, lest we forget to iterate (#24146) + ; unless (null unified) $ + TcM.updTcRef unif_count_ref (+ (length unified)) + + ; return (res, cts, unified) } } + + +{- +************************************************************************ +* * + Breaking type variable cycles +* * +************************************************************************ +-} + +checkTypeEq :: CtEvidence -> EqRel -> CanEqLHS -> TcType + -> TcS (PuResult () Reduction) +-- Used for general CanEqLHSs, ones that do +-- not have a touchable type variable on the LHS (i.e. not unifying) +checkTypeEq ev eq_rel lhs rhs = + case ev of + CtGiven {} -> + do { traceTcS "checkTypeEq {" (vcat [ text "lhs:" <+> ppr lhs + , text "rhs:" <+> ppr rhs ]) + ; check_result <- wrapTcS (checkTyEqRhs given_flags rhs) + ; traceTcS "checkTypeEq }" (ppr check_result) + ; case check_result of + PuFail reason -> return (PuFail reason) + PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs + ; emitWork new_givens + ; updInertSet (addCycleBreakerBindings prs) + ; return (pure redn) } } + CtWanted {} -> + do { check_result <- wrapTcS (checkTyEqRhs wanted_flags rhs) + ; case check_result of + PuFail reason -> return (PuFail reason) + PuOK cts redn -> do { emitWork cts + ; return (pure redn) } } + where + wanted_flags :: TyEqFlags TcM Ct + wanted_flags = notUnifying_TEFTask occ_prob lhs + -- checkTypeEq deals only with the non-unifying case + + given_flags :: TyEqFlags TcM (TcTyVar, TcType) + given_flags = wanted_flags { tef_fam_app = mkTEFA_Break ev eq_rel BreakGiven } + -- TEFA_Break used for: [G] a ~ Maybe (F a) + -- or [W] F a ~ Maybe (F a) + + -- occ_prob: see Note [Occurs check and representational equality] + occ_prob = case eq_rel of + NomEq -> cteInsolubleOccurs + ReprEq -> cteSolubleOccurs + + --------------------------- + mk_new_given :: (TcTyVar, TcType) -> TcS Ct + mk_new_given (new_tv, fam_app) + = mkNonCanonical . CtGiven <$> newGivenEvVar cb_loc (given_pred, given_term) + where + new_ty = mkTyVarTy new_tv + given_pred = mkNomEqPred fam_app new_ty + given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note + + -- See Detail (7) of the Note + cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin + +------------------------- +-- | Fill in CycleBreakerTvs with the variables they stand for. +-- See Note [Type equality cycles] in GHC.Tc.Solver.Equality +restoreTyVarCycles :: InertSet -> TcM () +restoreTyVarCycles is + = TcM.liftZonkM + $ forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar +{-# SPECIALISE forAllCycleBreakerBindings_ :: + CycleBreakerVarStack -> (TcTyVar -> TcType -> ZonkM ()) -> ZonkM () #-} + + +{- Note [Occurs check and representational equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(a ~R# b a) is soluble if b later turns out to be Identity +So we treat this as a "soluble occurs check". + +Note [Don't cycle-break Wanteds when not unifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consdier + [W] a[2] ~ Maybe (F a[2]) + +Should we cycle-break this Wanted, thus? + + [W] a[2] ~ Maybe delta[2] + [W] delta[2] ~ F a[2] + +For a start, this is dodgy because we might just unify delta, thus undoing +what we have done, and getting an infinite loop in the solver. Even if we +somehow prevented ourselves from doing so, is there any merit in the split? +Maybe: perhaps we can use that equality on `a` to unlock other constraints? +Consider + type instance F (Maybe _) = Bool + + [G] g1: a ~ Maybe Bool + [W] w1: a ~ Maybe (F a) + +If we loop-break w1 to get + [W] w1': a ~ Maybe gamma + [W] w3: gamma ~ F a +Now rewrite w3 with w1' + [W] w3': gamma ~ F (Maybe gamma) +Now use the type instance to get + gamma := Bool +Now we are left with + [W] w1': a ~ Maybe Bool +which we can solve from the Given. + +BUT in this situation we could have rewritten the +/original/ Wanted from the Given, like this: + [W] w1': Maybe Bool ~ Maybe (F (Maybe Bool)) +and that is readily soluble. + +In short: loop-breaking Wanteds, when we aren't unifying, +seems of no merit. Hence TEFA_Recurse, rather than TEFA_Break, +in `wanted_flags` in `checkTypeEq`. +-} diff --git a/GHC/Tc/Solver/Rewrite.hs b/GHC/Tc/Solver/Rewrite.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Rewrite.hs @@ -0,0 +1,1115 @@ +module GHC.Tc.Solver.Rewrite( + rewrite, rewriteForErrors, rewriteArgsNom, + rewriteType + ) where + +import GHC.Prelude + +import GHC.Core.TyCo.Ppr ( pprTyVar ) +import GHC.Tc.Types ( TcGblEnv(tcg_tc_plugin_rewriters), + TcPluginRewriter, TcPluginRewriteResult(..), + RewriteEnv(..), + runTcPluginM ) +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( CtLoc, bumpCtLocDepth ) +import GHC.Core.Predicate +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Tc.Types.Evidence +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep -- performs delicate algorithm on types +import GHC.Core.Coercion +import GHC.Core.Reduction +import GHC.Types.Unique.FM +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Driver.DynFlags +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Tc.Solver.Monad as TcS + +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Exts (oneShot) +import Control.Monad +import Control.Applicative (liftA3) +import GHC.Builtin.Types (tYPETyCon) +import Data.List ( find ) +import GHC.Data.List.Infinite (Infinite) +import GHC.Data.Bag( listToBag ) +import qualified GHC.Data.List.Infinite as Inf + +{- +************************************************************************ +* * +* RewriteEnv & RewriteM +* The rewriting environment & monad +* * +************************************************************************ +-} + +-- | The 'RewriteM' monad is a wrapper around 'TcS' with a 'RewriteEnv' +newtype RewriteM a + = RewriteM { runRewriteM :: RewriteEnv -> TcS a } + +-- | Smart constructor for 'RewriteM', as describe in Note [The one-shot state +-- monad trick] in "GHC.Utils.Monad". +mkRewriteM :: (RewriteEnv -> TcS a) -> RewriteM a +mkRewriteM f = RewriteM (oneShot f) +{-# INLINE mkRewriteM #-} + +instance Monad RewriteM where + m >>= k = mkRewriteM $ \env -> + do { a <- runRewriteM m env + ; runRewriteM (k a) env } + +instance Applicative RewriteM where + pure x = mkRewriteM $ \_ -> pure x + (<*>) = ap + +instance Functor RewriteM where + fmap f (RewriteM x) = mkRewriteM $ \env -> fmap f (x env) + +instance HasDynFlags RewriteM where + getDynFlags = liftTcS getDynFlags + +liftTcS :: TcS a -> RewriteM a +liftTcS thing_inside + = mkRewriteM $ \_ -> thing_inside + +-- convenient wrapper when you have a CtEvidence describing +-- the rewriting operation +runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS (a, RewriterSet) +runRewriteCtEv ev + = runRewrite (ctEvLoc ev) (ctEvFlavour ev) (ctEvRewriteEqRel ev) + +-- Run thing_inside (which does the rewriting) +-- Also returns the set of Wanteds which rewrote a Wanted; +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint +runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS (a, RewriterSet) +runRewrite loc flav eq_rel thing_inside + = do { rewriters_ref <- newTcRef emptyRewriterSet + ; let fmode = RE { re_loc = loc + , re_flavour = flav + , re_eq_rel = eq_rel + , re_rewriters = rewriters_ref } + ; res <- runRewriteM thing_inside fmode + ; rewriters <- readTcRef rewriters_ref + ; return (res, rewriters) } + +traceRewriteM :: String -> SDoc -> RewriteM () +traceRewriteM herald doc = liftTcS $ traceTcS herald doc +{-# INLINE traceRewriteM #-} -- see Note [INLINE conditional tracing utilities] + +getRewriteEnv :: RewriteM RewriteEnv +getRewriteEnv + = mkRewriteM $ \env -> return env + +getRewriteEnvField :: (RewriteEnv -> a) -> RewriteM a +getRewriteEnvField accessor + = mkRewriteM $ \env -> return (accessor env) + +getEqRel :: RewriteM EqRel +getEqRel = getRewriteEnvField re_eq_rel + +getRole :: RewriteM Role +getRole = eqRelRole <$> getEqRel + +getFlavour :: RewriteM CtFlavour +getFlavour = getRewriteEnvField re_flavour + +getFlavourRole :: RewriteM CtFlavourRole +getFlavourRole + = do { flavour <- getFlavour + ; eq_rel <- getEqRel + ; return (flavour, eq_rel) } + +getLoc :: RewriteM CtLoc +getLoc = getRewriteEnvField re_loc + +checkStackDepth :: Type -> RewriteM () +checkStackDepth ty + = do { loc <- getLoc + ; liftTcS $ checkReductionDepth loc ty } + +-- | Change the 'EqRel' in a 'RewriteM'. +setEqRel :: EqRel -> RewriteM a -> RewriteM a +setEqRel new_eq_rel thing_inside + = mkRewriteM $ \env -> + if new_eq_rel == re_eq_rel env + then runRewriteM thing_inside env + else runRewriteM thing_inside (env { re_eq_rel = new_eq_rel }) +{-# INLINE setEqRel #-} + +bumpDepth :: RewriteM a -> RewriteM a +bumpDepth (RewriteM thing_inside) + = mkRewriteM $ \env -> do + -- bumpDepth can be called a lot during rewriting so we force the + -- new env to avoid accumulating thunks. + { let !env' = env { re_loc = bumpCtLocDepth (re_loc env) } + ; thing_inside env' } + +recordRewriter :: CtEvidence -> RewriteM () +-- Record that we have rewritten the target with this (equality) evidence +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint +-- Precondition: the CtEvidence is for an equality constraint +recordRewriter (CtGiven {}) + = return () +recordRewriter (CtWanted (WantedCt { ctev_dest = dest })) + = case dest of + HoleDest hole -> RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriter` hole) + other -> pprPanic "recordRewriter: non-equality constraint" (ppr other) + +{- Note [Rewriter EqRels] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When rewriting, we need to know which equality relation -- nominal +or representational -- we should be respecting. This is controlled +by the `re_eq_rel` field of RewriteEnv. + +* When rewriting primitive /representational/ equalities, (t1 ~# t2), + we set re_eq_rel=ReprEq. +* For all other constraints, we set re_eq_rel=NomEq + +See Note [The rewrite-role of a constraint] in GHC.Tc.Types.Constraint. + +The only difference is that when re_eq_rel=ReprEq +* we rewrite variables by representational equalities +* we unwrap newtypes + +Note [Rewriter CtLoc] +~~~~~~~~~~~~~~~~~~~~~~ +The rewriter does eager type-family reduction. +Type families might loop, and we +don't want GHC to do so. A natural solution is to have a bounded depth +to these processes. A central difficulty is that such a solution isn't +quite compositional. For example, say it takes F Int 10 steps to get to Bool. +How many steps does it take to get from F Int -> F Int to Bool -> Bool? +10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to +know and hard to track. So, we punt, essentially. We store a CtLoc in +the RewriteEnv and just update the environment when recurring. In the +TyConApp case, where there may be multiple type families to rewrite, +we just copy the current CtLoc into each branch. If any branch hits the +stack limit, then the whole thing fails. + +A consequence of this is that setting the stack limits appropriately +will be essentially impossible. So, the official recommendation if a +stack limit is hit is to disable the check entirely. Otherwise, there +will be baffling, unpredictable errors. + +Note [Phantoms in the rewriter] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + +data Proxy p = Proxy + +and we're rewriting (Proxy ty) w.r.t. ReprEq. Then, we know that `ty` +is really irrelevant -- it will be ignored when solving for representational +equality later on. So, we omit rewriting `ty` entirely. This may +violate the expectation of "xi"s for a bit, but the canonicaliser will +soon throw out the phantoms when decomposing a TyConApp. (Or, the +canonicaliser will emit an insoluble, in which case we get +a better error message anyway.) + +-} + +{- ********************************************************************* +* * +* Externally callable rewriting functions * +* * +************************************************************************ +-} + +-- | See Note [Rewriting]. +-- If (xi, co, rewriters) <- rewrite mode ev ty, then co :: xi ~r ty +-- where r is the role in @ev@. +-- `rewriters` is the set of coercion holes that have been used to rewrite +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint +rewrite :: CtEvidence -> TcType + -> TcS (Reduction, RewriterSet) +rewrite ev ty + = do { traceTcS "rewrite {" (ppr ty) + ; result@(redn, _) <- runRewriteCtEv ev (rewrite_one ty) + ; traceTcS "rewrite }" (ppr $ reductionReducedType redn) + ; return result } + +-- | See Note [Rewriting] +-- `rewriteForErrors` is a variant of 'rewrite' that rewrites +-- w.r.t. nominal equality only, as this is better than full rewriting +-- for error messages. (This was important when we flirted with rewriting +-- newtypes but perhaps less so now.) +rewriteForErrors :: CtEvidence -> TcType + -> TcS (Reduction, RewriterSet) +rewriteForErrors ev ty + = do { traceTcS "rewriteForErrors {" (ppr ty) + ; result@(redn, rewriters) <- + runRewrite (ctEvLoc ev) (ctEvFlavour ev) NomEq (rewrite_one ty) + ; traceTcS "rewriteForErrors }" (ppr $ reductionReducedType redn) + ; return $ case ctEvRewriteEqRel ev of + NomEq -> result + ReprEq -> (mkSubRedn redn, rewriters) } + +-- See Note [Rewriting] +rewriteArgsNom :: CtEvidence -> TyCon -> [TcType] + -> TcS (Reductions, RewriterSet) +-- Externally-callable, hence runRewrite +-- Rewrite a vector of types all at once; in fact they are +-- always the arguments of type family or class, so +-- ctEvFlavour ev = Nominal +-- and we want to rewrite all at nominal role +-- The kind passed in is the kind of the type family or class, call it T +-- The kind of T args must be constant (i.e. not depend on the args) +-- +-- Final return value returned which Wanteds rewrote another Wanted +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint +rewriteArgsNom ev tc tys + = do { traceTcS "rewrite_args {" (vcat (map ppr tys)) + ; (ArgsReductions redns@(Reductions _ tys') kind_co, rewriters) + <- runRewriteCtEv ev (rewrite_args_tc tc Nothing tys) + ; massert (isReflMCo kind_co) + ; traceTcS "rewrite }" (vcat (map ppr tys')) + ; return (redns, rewriters) } + +-- | Rewrite a type w.r.t. nominal equality. This is useful to rewrite +-- a type w.r.t. any givens. It does not do type-family reduction. This +-- will never emit new constraints. Call this when the inert set contains +-- only givens. +rewriteType :: CtLoc -> TcType -> TcS TcType +rewriteType loc ty + = do { (redn, _) <- runRewrite loc Given NomEq $ + rewrite_one ty + -- use Given flavor so that it is rewritten + -- only w.r.t. Givens, never Wanteds + -- (Shouldn't matter, if only Givens are present + -- anyway) + ; return $ reductionReducedType redn } + +{- ********************************************************************* +* * +* The main rewriting functions +* * +********************************************************************* -} + +{- Note [Rewriting] +~~~~~~~~~~~~~~~~~~~~ + rewrite ty ==> Reduction co xi + where + xi has no reducible type functions + has no skolems that are mapped in the inert set + has no filled-in metavariables + co :: ty ~ xi (coercions in reductions are always left-to-right) + +Key invariants: + (F0) co :: zonk(ty') ~ xi where zonk(ty') ~ zonk(ty) + (F1) typeKind(xi) succeeds and returns a fully zonked kind + (F2) typeKind(xi) `eqType` zonk(typeKind(ty)) + +Note that it is rewrite's job to try to reduce *every type function it sees*. + +Rewriting also: + * zonks, removing any metavariables, and + * applies the substitution embodied in the inert set + +Because rewriting zonks and the returned coercion ("co" above) is also +zonked, it's possible that (co :: ty ~ xi) isn't quite true. So, instead, +we can rely on this fact: + + (F0) co :: zonk(ty') ~ xi, where zonk(ty') ~ zonk(ty) + +Note that the right-hand type of co is *always* precisely xi. The left-hand +type may or may not be ty, however: if ty has unzonked filled-in metavariables, +then the left-hand type of co will be the zonk-equal to ty. +It is for this reason that we occasionally have to explicitly zonk, +when (co :: ty ~ xi) is important even before we zonk the whole program. +For example, see the RTRNotFollowed case in rewriteTyVar. + +Why have these invariants on rewriting? Because we sometimes use typeKind +during canonicalisation, and we want this kind to be zonked (e.g., see +GHC.Tc.Solver.Equality.canEqCanLHS). + +Rewriting is always homogeneous. That is, the kind of the result of rewriting is +always the same as the kind of the input, modulo zonking. More formally: + + (F2) zonk(typeKind(ty)) `eqType` typeKind(xi) + +This invariant means that the kind of a rewritten type might not itself be rewritten. + +Note that we prefer to leave type synonyms unexpanded when possible, +so when the rewriter encounters one, it first asks whether its +transitive expansion contains any type function applications or is +forgetful -- that is, omits one or more type variables in its RHS. If so, +it expands the synonym and proceeds; if not, it simply returns the +unexpanded synonym. See also Note [Rewriting synonyms]. + +Where do we actually perform rewriting within a type? See Note [Rewritable] in +GHC.Tc.Solver.InertSet. + +Note [rewrite_args performance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In programs with lots of type-level evaluation, rewrite_args becomes +part of a tight loop. For example, see test perf/compiler/T9872a, which +calls rewrite_args a whopping 7,106,808 times. It is thus important +that rewrite_args be efficient. + +Performance testing showed that the current implementation is indeed +efficient. It's critically important that zipWithAndUnzipM be +specialized to TcS, and it's also quite helpful to actually `inline` +it. On test T9872a, here are the allocation stats (Dec 16, 2014): + + * Unspecialized, uninlined: 8,472,613,440 bytes allocated in the heap + * Specialized, uninlined: 6,639,253,488 bytes allocated in the heap + * Specialized, inlined: 6,281,539,792 bytes allocated in the heap + +To improve performance even further, rewrite_args_nom is split off +from rewrite_args, as nominal equality is the common case. This would +be natural to write using mapAndUnzipM, but even inlined, that function +is not as performant as a hand-written loop. + + * mapAndUnzipM, inlined: 7,463,047,432 bytes allocated in the heap + * hand-written recursion: 5,848,602,848 bytes allocated in the heap + +If you make any change here, pay close attention to the T9872{a,b,c} tests +and T5321Fun. + +If we need to make this yet more performant, a possible way forward is to +duplicate the rewriter code for the nominal case, and make that case +faster. This doesn't seem quite worth it, yet. + +Note [rewrite_exact_fam_app performance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Once we've got a rewritten rhs, we extend the famapp-cache to record +the result. Doing so can save lots of work when the same redex shows up more +than once. Note that we record the link from the redex all the way to its +*final* value, not just the single step reduction. + +If we can reduce the family application right away (the first call +to try_to_reduce), we do *not* add to the cache. There are two possibilities +here: 1) we just read the result from the cache, or 2) we used one type +family instance. In either case, recording the result in the cache doesn't +save much effort the next time around. And adding to the cache here is +actually disastrous: it more than doubles the allocations for T9872a. So +we skip adding to the cache here. +-} + +{-# INLINE rewrite_args_tc #-} +rewrite_args_tc + :: TyCon -- T + -> Maybe (Infinite Role) -- Nothing: ambient role is Nominal; all args are Nominal + -- Otherwise: no assumptions; use roles provided + -> [Type] + -> RewriteM ArgsReductions -- See the commentary on rewrite_args +rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet + -- NB: TyCon kinds are always closed + where + -- There are many bang patterns in here. It's been observed that they + -- greatly improve performance of an optimized build. + -- The T9872 test cases are good witnesses of this fact. + + (bndrs, named) + = ty_con_binders_ty_binders' (tyConBinders tc) + -- it's possible that the result kind has arrows (for, e.g., a type family) + -- so we must split it + (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc) + !all_bndrs = bndrs `chkAppend` inner_bndrs + !any_named_bndrs = named || inner_named + -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%. + +{-# INLINE rewrite_args #-} +rewrite_args :: [PiTyBinder] -> Bool -- Binders, and True iff any of them are + -- named. + -> Kind -> TcTyCoVarSet -- function kind; kind's free vars + -> Maybe (Infinite Role) -> [Type] -- these are in 1-to-1 correspondence + -- Nothing: use all Nominal + -> RewriteM ArgsReductions +-- This function returns ArgsReductions (Reductions cos xis) res_co +-- coercions: co_i :: ty_i ~ xi_i, at roles given +-- types: xi_i +-- coercion: res_co :: typeKind(fun tys) ~N typeKind(fun xis) +-- That is, the result coercion relates the kind of some function (whose kind is +-- passed as the first parameter) instantiated at tys to the kind of that +-- function instantiated at the xis. This is useful in keeping rewriting +-- homogeneous. The list of roles must be at least as long as the list of +-- types. +rewrite_args orig_binders + any_named_bndrs + orig_inner_ki + orig_fvs + orig_m_roles + orig_tys + = case (orig_m_roles, any_named_bndrs) of + (Nothing, False) -> rewrite_args_fast orig_tys + _ -> rewrite_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys + where orig_roles = fromMaybe (Inf.repeat Nominal) orig_m_roles + +{-# INLINE rewrite_args_fast #-} +-- | fast path rewrite_args, in which none of the binders are named and +-- therefore we can avoid tracking a lifting context. +rewrite_args_fast :: [Type] -> RewriteM ArgsReductions +rewrite_args_fast orig_tys + = fmap finish (iterate orig_tys) + where + + iterate :: [Type] -> RewriteM Reductions + iterate (ty : tys) = do + Reduction co xi <- rewrite_one ty + Reductions cos xis <- iterate tys + pure $ Reductions (co : cos) (xi : xis) + iterate [] = pure $ Reductions [] [] + + {-# INLINE finish #-} + finish :: Reductions -> ArgsReductions + finish redns = ArgsReductions redns MRefl + +{-# INLINE rewrite_args_slow #-} +-- | Slow path, compared to rewrite_args_fast, because this one must track +-- a lifting context. +rewrite_args_slow :: [PiTyBinder] -> Kind -> TcTyCoVarSet + -> Infinite Role -> [Type] + -> RewriteM ArgsReductions +rewrite_args_slow binders inner_ki fvs roles tys + = do { rewritten_args <- zipWithM rw (Inf.toList roles) tys + ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) } + where + {-# INLINE rw #-} + rw :: Role -> Type -> RewriteM Reduction + rw Nominal ty + = setEqRel NomEq $ + rewrite_one ty + + rw Representational ty + = setEqRel ReprEq $ + rewrite_one ty + + rw Phantom ty + -- See Note [Phantoms in the rewriter] + = do { ty <- liftTcS $ zonkTcType ty + ; return $ mkReflRedn Phantom ty } + +------------------ +rewrite_one :: TcType -> RewriteM Reduction +-- Rewrite a type to get rid of type function applications, returning +-- the new type-function-free type, and a collection of new equality +-- constraints. See Note [Rewriting] for more detail. +-- +-- Postcondition: +-- the role on the result coercion matches the EqRel in the RewriteEnv + +rewrite_one ty + | Just ty' <- rewriterView ty -- See Note [Rewriting synonyms] + = rewrite_one ty' + +rewrite_one xi@(LitTy {}) + = do { role <- getRole + ; return $ mkReflRedn role xi } + +rewrite_one (TyVarTy tv) + = rewriteTyVar tv + +rewrite_one (AppTy ty1 ty2) + = rewrite_app_tys ty1 [ty2] + +rewrite_one (TyConApp tc tys) + -- If it's a type family application, try to reduce it + | isTypeFamilyTyCon tc + = rewrite_fam_app tc tys + + | otherwise -- We just recursively rewrite the arguments. + -- See Note [Do not rewrite newtypes] + = rewrite_ty_con_app tc tys + +rewrite_one (FunTy { ft_af = vis, ft_mult = mult, ft_arg = ty1, ft_res = ty2 }) + = do { arg_redn <- rewrite_one ty1 + ; res_redn <- rewrite_one ty2 + + -- Important: look at the *reduced* type, so that any unzonked variables + -- in kinds are gone and the getRuntimeRep succeeds. + -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Equality. + ; let arg_rep = getRuntimeRep (reductionReducedType arg_redn) + res_rep = getRuntimeRep (reductionReducedType res_redn) + + ; (w_redn, arg_rep_redn, res_rep_redn) <- setEqRel NomEq $ + liftA3 (,,) (rewrite_one mult) + (rewrite_one arg_rep) + (rewrite_one res_rep) + ; role <- getRole + + ; let arg_rep_co = reductionCoercion arg_rep_redn + -- :: arg_rep ~ arg_rep_xi + arg_ki_co = mkTyConAppCo Nominal tYPETyCon [arg_rep_co] + -- :: TYPE arg_rep ~ TYPE arg_rep_xi + casted_arg_redn = mkCoherenceRightRedn role arg_redn arg_ki_co + -- :: ty1 ~> arg_xi |> arg_ki_co + + res_rep_co = reductionCoercion res_rep_redn + res_ki_co = mkTyConAppCo Nominal tYPETyCon [res_rep_co] + casted_res_redn = mkCoherenceRightRedn role res_redn res_ki_co + + -- We must rewrite the representations, because that's what would + -- be done if we used TyConApp instead of FunTy. These rewritten + -- representations are seen only in casts of the arg and res, below. + -- Forgetting this caused #19677. + ; return $ mkFunRedn role vis w_redn casted_arg_redn casted_res_redn } + +rewrite_one ty@(ForAllTy {}) +-- TODO (RAE): This is inadequate, as it doesn't rewrite the kind of +-- the bound tyvar. Doing so will require carrying around a substitution +-- and the usual substTyVarBndr-like silliness. Argh. + +-- We allow for-alls when, but only when, no type function +-- applications inside the forall involve the bound type variables. + = do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty + ; redn <- rewrite_one rho + ; return $ mkHomoForAllRedn bndrs redn } + +rewrite_one (CastTy ty g) + = do { redn <- rewrite_one ty + ; g' <- rewrite_co g + ; role <- getRole + ; return $ mkCastRedn1 role ty g' redn } + -- This calls castCoercionKind1. + -- It makes a /big/ difference to call castCoercionKind1 not + -- the more general castCoercionKind2. + -- See Note [castCoercionKind1] in GHC.Core.Coercion + +rewrite_one (CoercionTy co) + = do { co' <- rewrite_co co + ; role <- getRole + ; return $ mkReflCoRedn role co' } + +-- | "Rewrite" a coercion. Really, just zonk it so we can uphold +-- (F1) of Note [Rewriting] +rewrite_co :: Coercion -> RewriteM Coercion +rewrite_co co = liftTcS $ zonkCo co + +-- | Rewrite a reduction, composing the resulting coercions. +rewrite_reduction :: Reduction -> RewriteM Reduction +rewrite_reduction (Reduction co xi) + = do { redn <- bumpDepth $ rewrite_one xi + ; return $ co `mkTransRedn` redn } + +-- rewrite (nested) AppTys +rewrite_app_tys :: Type -> [Type] -> RewriteM Reduction +-- commoning up nested applications allows us to look up the function's kind +-- only once. Without commoning up like this, we would spend a quadratic amount +-- of time looking up functions' types +rewrite_app_tys (AppTy ty1 ty2) tys = rewrite_app_tys ty1 (ty2:tys) +rewrite_app_tys fun_ty arg_tys + = do { redn <- rewrite_one fun_ty + ; rewrite_app_ty_args redn arg_tys } + +-- Given a rewritten function (with the coercion produced by rewriting) and +-- a bunch of unrewritten arguments, rewrite the arguments and apply. +-- The coercion argument's role matches the role stored in the RewriteM monad. +-- +-- The bang patterns used here were observed to improve performance. If you +-- wish to remove them, be sure to check for regressions in allocations. +rewrite_app_ty_args :: Reduction -> [Type] -> RewriteM Reduction +rewrite_app_ty_args redn [] + -- this will be a common case when called from rewrite_fam_app, so shortcut + = return redn +rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys + = do { het_redn <- case tcSplitTyConApp_maybe fun_xi of + Just (tc, xis) -> + do { let tc_roles = tyConRolesRepresentational tc + arg_roles = Inf.dropList xis tc_roles + ; ArgsReductions (Reductions arg_cos arg_xis) kind_co + <- rewrite_vector (typeKind fun_xi) arg_roles arg_tys + + -- We start with a reduction of the form + -- fun_co :: ty ~ T xi_1 ... xi_n + -- and further arguments a_1, ..., a_m. + -- We rewrite these arguments, and obtain coercions: + -- arg_co_i :: a_i ~ zeta_i + -- Now, we need to apply fun_co to the arg_cos. The problem is + -- that using mkAppCo is wrong because that function expects + -- its second coercion to be Nominal, and the arg_cos might + -- not be. The solution is to use transitivity: + -- fun_co ... ;; T .. arg_co_1 ... arg_co_m + ; eq_rel <- getEqRel + ; let app_xi = mkTyConApp tc (xis ++ arg_xis) + app_co = case eq_rel of + NomEq -> mkAppCos fun_co arg_cos + ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys) + `mkTransCo` + mkTyConAppCo Representational tc + (zipWith mkReflCo (Inf.toList tc_roles) xis ++ arg_cos) + + ; return $ + mkHetReduction + (mkReduction app_co app_xi ) + kind_co } + Nothing -> + do { ArgsReductions redns kind_co + <- rewrite_vector (typeKind fun_xi) (Inf.repeat Nominal) arg_tys + ; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co } + + ; role <- getRole + ; return (homogeniseHetRedn role het_redn) } + +rewrite_ty_con_app :: TyCon -> [TcType] -> RewriteM Reduction +rewrite_ty_con_app tc tys + = do { role <- getRole + ; let m_roles | Nominal <- role = Nothing + | otherwise = Just $ tyConRolesX role tc + ; ArgsReductions redns kind_co <- rewrite_args_tc tc m_roles tys + ; let tyconapp_redn + = mkHetReduction + (mkTyConAppRedn role tc redns) + kind_co + ; return $ homogeniseHetRedn role tyconapp_redn } + +-- Rewrite a vector (list of arguments). +rewrite_vector :: Kind -- of the function being applied to these arguments + -> Infinite Role -- If we're rewriting w.r.t. ReprEq, what roles do the + -- args have? + -> [Type] -- the args to rewrite + -> RewriteM ArgsReductions +rewrite_vector ki roles tys + = do { eq_rel <- getEqRel + ; let mb_roles = case eq_rel of { NomEq -> Nothing; ReprEq -> Just roles } + ; rewrite_args bndrs any_named_bndrs inner_ki fvs mb_roles tys + } + where + (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki + fvs = tyCoVarsOfType ki +{-# INLINE rewrite_vector #-} + + +{- Note [Do not rewrite newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We flirted with unwrapping newtypes in the rewriter -- see GHC.Tc.Solver.Equality +Note [Unwrap newtypes first]. But that turned out to be a bad idea because +of recursive newtypes, as that Note says. So be careful if you re-add it! + +Note [Rewriting synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Not expanding synonyms aggressively improves error messages, and +keeps types smaller. But we need to take care. + +Suppose + type Syn a = Int + type instance F Bool = Syn (F Bool) + [G] F Bool ~ Syn (F Bool) + +If we don't expand the synonym, we'll get a spurious occurs-check +failure. This is normally what occCheckExpand takes care of, but +the LHS is a type family application, and occCheckExpand (already +complex enough as it is) does not know how to expand to avoid +a type family application. + +In addition, expanding the forgetful synonym like this +will generally yield a *smaller* type. To wit, if we spot +S ( ... F tys ... ), where S is forgetful, we don't want to bother +doing hard work simplifying (F tys). We thus expand forgetful +synonyms, but not others. + +isForgetfulSynTyCon returns True more often than it needs to, so +we err on the side of more expansion. + +We also, of course, must expand type synonyms that mention type families, +so those families can get reduced. + +************************************************************************ +* * + Rewriting a type-family application +* * +************************************************************************ + +Note [How to normalise a family application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given an exactly saturated family application, how should we normalise it? +This Note spells out the algorithm and its reasoning. + +First, we attempt to directly rewrite the type family application, +without simplifying any of the arguments first, in an attempt to avoid +doing unnecessary work. + +STEP 1a. Call the rewriting plugins. If any plugin rewrites the type family +application, jump to FINISH. + +STEP 1b. Try the famapp-cache. If we get a cache hit, jump to FINISH. + +STEP 1c. Try top-level instances. Remember: we haven't simplified the arguments + yet. Example: + type instance F (Maybe a) = Int + target: F (Maybe (G Bool)) + Instead of first trying to simplify (G Bool), we use the instance first. This + avoids the work of simplifying G Bool. + + If an instance is found, jump to FINISH. + +STEP 2: At this point we rewrite all arguments. This might expose more + information, which might allow plugins to make progress, or allow us to + pick up a top-level instance. + +STEP 3. Try the inerts. Note that we try the inerts *after* rewriting the + arguments, because the inerts will have rewritten LHSs. + + If an inert is found, jump to FINISH. + +Next, we try STEP 1 again, as we might be able to make further progress after +having rewritten the arguments: + +STEP 4a. Query the rewriting plugins again. + + If any plugin supplies a rewriting, jump to FINISH. + +STEP 4b. Try the famapp-cache again. + + If we get a cache hit, jump to FINISH. + +STEP 4c. Try top-level instances again. + + If an instance is found, jump to FINISH. + +STEP 5: GIVEUP. No progress to be made. Return what we have. (Do not FINISH.) + +FINISH 1. We've made a reduction, but the new type may still have more + work to do. So rewrite the new type. + +FINISH 2. Add the result to the famapp-cache, connecting the type we started + with to the one we ended with. + +Because STEP 1{a,b,c} and STEP 4{a,b,c} happen the same way, they are abstracted into +try_to_reduce. + +FINISH is naturally implemented in `finish`. But, Note [rewrite_exact_fam_app performance] +tells us that we should not add to the famapp-cache after STEP 1. So `finish` +is inlined in that case, and only FINISH 1 is performed. + +-} + +rewrite_fam_app :: TyCon -> [TcType] -> RewriteM Reduction + -- rewrite_fam_app can be over-saturated + -- rewrite_exact_fam_app lifts out the application to top level + -- Postcondition: Coercion :: Xi ~ F tys +rewrite_fam_app tc tys -- Can be over-saturated + = assertPpr (tys `lengthAtLeast` tyConArity tc) + (ppr tc $$ ppr (tyConArity tc) $$ ppr tys) $ + + -- Type functions are saturated + -- The type function might be *over* saturated + -- in which case the remaining arguments should + -- be dealt with by AppTys + do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys + ; redn <- rewrite_exact_fam_app tc tys1 + ; rewrite_app_ty_args redn tys_rest } + +-- the [TcType] exactly saturate the TyCon +-- See Note [How to normalise a family application] +rewrite_exact_fam_app :: TyCon -> [TcType] -> RewriteM Reduction +rewrite_exact_fam_app tc tys + = do { checkStackDepth (mkTyConApp tc tys) + + -- Query the typechecking plugins for all their rewriting functions + -- which apply to a type family application headed by the TyCon 'tc'. + ; tc_rewriters <- getTcPluginRewritersForTyCon tc + + -- STEP 1. Try to reduce without reducing arguments first. + ; result1 <- try_to_reduce tc tys tc_rewriters + ; case result1 of + -- Don't use the cache; + -- See Note [rewrite_exact_fam_app performance] + { Just redn -> finish False redn + ; Nothing -> + + -- That didn't work. So reduce the arguments, in STEP 2. + do { eq_rel <- getEqRel + -- checking eq_rel == NomEq saves ~0.5% in T9872a + ; ArgsReductions (Reductions cos xis) kind_co <- + if eq_rel == NomEq + then rewrite_args_tc tc Nothing tys + else setEqRel NomEq $ + rewrite_args_tc tc Nothing tys + + -- If we manage to rewrite the type family application after + -- rewriting the arguments, we will need to compose these + -- reductions. + -- + -- We have: + -- + -- arg_co_i :: ty_i ~ xi_i + -- fam_co :: F xi_1 ... xi_n ~ zeta + -- + -- The full reduction is obtained as a composite: + -- + -- full_co :: F ty_1 ... ty_n ~ zeta + -- full_co = F co_1 ... co_n ;; fam_co + ; let + role = eqRelRole eq_rel + args_co = mkTyConAppCo role tc cos + ; let homogenise :: Reduction -> Reduction + homogenise redn + = homogeniseHetRedn role + $ mkHetReduction + (args_co `mkTransRedn` redn) + kind_co + + give_up :: Reduction + give_up = homogenise $ mkReflRedn role reduced + where reduced = mkTyConApp tc xis + + -- STEP 3: try the inerts + ; flavour <- getFlavour + ; mb_eq <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis + ; case mb_eq of + { Just (EqCt { eq_ev = inert_ev, eq_rhs = inert_rhs, eq_eq_rel = inert_eq_rel }) + -> do { traceRewriteM "rewrite family application with inert" + (ppr tc <+> ppr xis $$ ppr redn) + ; recordRewriter inert_ev + ; finish (isGiven inert_ev) (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 + redn = mkReduction (ctEvCoercion inert_ev) inert_rhs + inert_role = eqRelRole inert_eq_rel + role = eqRelRole eq_rel + downgraded_redn = downgradeRedn role inert_role redn + + ; _ -> + + -- inerts didn't work. Try to reduce again, in STEP 4. + do { result3 <- try_to_reduce tc xis tc_rewriters + ; case result3 of + Just redn -> finish True (homogenise redn) + -- we have made no progress at all: STEP 5 (GIVEUP). + _ -> return give_up }}}}} + where + -- call this if the above attempts made progress. + -- This recursively rewrites the result and then adds to the cache + finish :: Bool -- add to the cache? + -- Precondition: True ==> input coercion has + -- no coercion holes + -> Reduction -> RewriteM Reduction + finish use_cache redn + = do { -- rewrite the result: FINISH 1 + final_redn <- rewrite_reduction redn + ; eq_rel <- getEqRel + + -- extend the cache: FINISH 2 + ; when (use_cache && eq_rel == NomEq) $ + -- the cache only wants Nominal eqs + liftTcS $ extendFamAppCache tc tys final_redn + ; return final_redn } + {-# INLINE finish #-} + +-- Returned coercion is input ~r output, where r is the role in the RewriteM monad +-- See Note [How to normalise a family application] +try_to_reduce :: TyCon -> [TcType] -> [TcPluginRewriter] + -> RewriteM (Maybe Reduction) +try_to_reduce tc tys tc_rewriters + = do { rewrite_env <- getRewriteEnv + ; result <- + liftTcS $ firstJustsM + [ runTcPluginRewriters rewrite_env tc_rewriters tys -- STEP 1a & STEP 4a + , lookupFamAppCache tc tys -- STEP 1b & STEP 4b + , matchFam tc tys ] -- STEP 1c & STEP 4c + ; traverse downgrade result } + where + -- The result above is always Nominal. We might want a Representational + -- coercion; this downgrades (and prints, out of convenience). + downgrade :: Reduction -> RewriteM Reduction + downgrade redn + = do { traceRewriteM "Eager T.F. reduction success" $ + vcat [ ppr tc + , ppr tys + , ppr redn + ] + ; eq_rel <- getEqRel + -- manually doing it this way avoids allocation in the vastly + -- common NomEq case + ; case eq_rel of + NomEq -> return redn + ReprEq -> return $ mkSubRedn redn } + +-- Retrieve all type-checking plugins that can rewrite a (saturated) type-family application +-- headed by the given 'TyCon`. +getTcPluginRewritersForTyCon :: TyCon -> RewriteM [TcPluginRewriter] +getTcPluginRewritersForTyCon tc + = liftTcS $ do { rewriters <- tcg_tc_plugin_rewriters <$> getGblEnv + ; return (lookupWithDefaultUFM rewriters [] tc) } + +-- Run a collection of rewriting functions obtained from type-checking plugins, +-- querying in sequence if any plugin wants to rewrite the type family +-- applied to the given arguments. +-- +-- Note that the 'TcPluginRewriter's provided all pertain to the same type family +-- (the 'TyCon' of which has been obtained ahead of calling this function). +runTcPluginRewriters :: RewriteEnv + -> [TcPluginRewriter] + -> [TcType] + -> TcS (Maybe Reduction) +runTcPluginRewriters rewriteEnv rewriterFunctions tys + | null rewriterFunctions + = return Nothing -- short-circuit for common case + | otherwise + = do { givens <- getInertGivens + ; runRewriters givens rewriterFunctions } + where + runRewriters :: [Ct] -> [TcPluginRewriter] -> TcS (Maybe Reduction) + runRewriters _ [] + = return Nothing + runRewriters givens (rewriter:rewriters) + = do + rewriteResult <- wrapTcS . runTcPluginM $ rewriter rewriteEnv givens tys + case rewriteResult of + TcPluginRewriteTo + { tcPluginReduction = redn + , tcRewriterNewWanteds = wanteds + } -> do { emitWork (listToBag wanteds); return $ Just redn } + TcPluginNoRewrite {} -> runRewriters givens rewriters + +{- +************************************************************************ +* * + Rewriting a type variable +* * +********************************************************************* -} + +-- | The result of rewriting a tyvar "one step". +data RewriteTvResult + = RTRNotFollowed + -- ^ The inert set doesn't make the tyvar equal to anything else + + | RTRFollowed !Reduction + -- ^ The tyvar rewrites to a not-necessarily rewritten other type. + -- The role is determined by the RewriteEnv. + -- + -- With Quick Look, the returned TcType can be a polytype; + -- that is, in the constraint solver, a unification variable + -- can contain a polytype. See GHC.Tc.Gen.App + -- Note [Instantiation variables are short lived] + +rewriteTyVar :: TyVar -> RewriteM Reduction +rewriteTyVar tv + = do { mb_yes <- rewrite_tyvar1 tv + ; case mb_yes of + RTRFollowed redn -> rewrite_reduction redn + + RTRNotFollowed -- Done, but make sure the kind is zonked + -- Note [Rewriting] invariant (F0) and (F1) + -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv + ; role <- getRole + ; let ty' = mkTyVarTy tv' + ; return $ mkReflRedn role ty' } } + +rewrite_tyvar1 :: TcTyVar -> RewriteM RewriteTvResult +-- "Rewriting" a type variable means to apply the substitution to it +-- Specifically, look up the tyvar in +-- * the internal MetaTyVar box +-- * the inerts +-- See also the documentation for RewriteTvResult + +rewrite_tyvar1 tv + = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv + ; case mb_ty of + Just ty -> do { traceRewriteM "Following filled tyvar" + (ppr tv <+> equals <+> ppr ty) + ; role <- getRole + ; return $ RTRFollowed $ + mkReflRedn role ty } + Nothing -> do { traceRewriteM "Unfilled tyvar" (pprTyVar tv) + ; fr <- getFlavourRole + ; rewrite_tyvar2 tv fr } } + +rewrite_tyvar2 :: TcTyVar -> CtFlavourRole -> RewriteM RewriteTvResult +-- The tyvar is not a filled-in meta-tyvar +-- Try in the inert equalities +-- See Definition [Applying a generalised substitution] in GHC.Tc.Solver.Monad +-- See Note [Stability of rewriting] in GHC.Tc.Solver.Monad + +rewrite_tyvar2 tv fr@(_, eq_rel) + = do { ieqs <- liftTcS $ getInertEqs + ; case lookupDVarEnv ieqs tv of + Just equal_ct_list + | Just ct <- find can_rewrite equal_ct_list + , EqCt { eq_ev = ctev, eq_lhs = TyVarLHS tv + , eq_rhs = rhs_ty, eq_eq_rel = ct_eq_rel } <- ct + -> do { traceRewriteM "Following inert tyvar" $ + vcat [ ppr tv <+> equals <+> ppr rhs_ty + , ppr ctev ] + ; recordRewriter ctev + -- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint + + ; let rewriting_co1 = ctEvCoercion ctev + rewriting_co = case (ct_eq_rel, eq_rel) of + (ReprEq, _rel) -> assert (_rel == ReprEq) + -- if this assert fails, then + -- eqCanRewriteFR answered incorrectly + rewriting_co1 + (NomEq, NomEq) -> rewriting_co1 + (NomEq, ReprEq) -> mkSubCo rewriting_co1 + + ; return $ RTRFollowed $ mkReduction rewriting_co rhs_ty } + + _other -> return RTRNotFollowed } + + where + can_rewrite :: EqCt -> Bool + can_rewrite ct = eqCtFlavourRole ct `eqCanRewriteFR` fr + -- This is THE key call of eqCanRewriteFR + +{- +Note [An alternative story for the inert substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This entire note is just background, left here in case we ever want + to return the previous state of affairs) + +We used (GHC 7.8) to have this story for the inert substitution inert_eqs + + * 'a' is not in fvs(ty) + * They are *inert* in the weaker sense that there is no infinite chain of + (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc + +This means that rewriting must be recursive, but it does allow + [G] a ~ [b] + [G] b ~ Maybe c + +This avoids "saturating" the Givens, which can save a modest amount of work. +It is easy to implement, in GHC.Tc.Solver.InertSet.kickOutRewritableLHS, by +only kicking out an inert only if + (a) the work item can rewrite the inert AND + (b) the inert cannot rewrite the work item + +This is significantly harder to think about. It can save a LOT of work +in occurs-check cases, but we don't care about them much. #5837 +is an example, but it causes trouble only with the old (pre-Fall 2020) +rewriting story. It is unclear if there is any gain w.r.t. to +the new story. + +-} + +-------------------------------------- +-- Utilities + +-- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at +-- least one named binder. +split_pi_tys' :: Type -> ([PiTyBinder], Type, Bool) +split_pi_tys' ty = split ty ty + where + -- put common cases first + split _ (ForAllTy b res) = let -- This bang is necessary lest we see rather + -- terrible reboxing, as noted in #19102. + !(bs, ty, _) = split res res + in (Named b : bs, ty, True) + split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + = let -- See #19102 + !(bs, ty, named) = split res res + in (Anon (mkScaled w arg) af : bs, ty, named) + + split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' + split orig_ty _ = ([], orig_ty, False) +{-# INLINE split_pi_tys' #-} + +-- | Like 'tyConBindersPiTyBinders' but you also get a 'Bool' which is true iff +-- there is at least one named binder. +ty_con_binders_ty_binders' :: [TyConBinder] -> ([PiTyBinder], Bool) +ty_con_binders_ty_binders' = foldr go ([], False) + where + go (Bndr tv (NamedTCB vis)) (bndrs, _) + = (Named (Bndr tv vis) : bndrs, True) + go (Bndr tv AnonTCB) (bndrs, n) + = (Anon (tymult (tyVarKind tv)) FTF_T_T : bndrs, n) + {-# INLINE go #-} +{-# INLINE ty_con_binders_ty_binders' #-} diff --git a/GHC/Tc/Solver/Solve.hs b/GHC/Tc/Solver/Solve.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Solve.hs @@ -0,0 +1,1837 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} + +module GHC.Tc.Solver.Solve ( + simplifyWantedsTcM, + solveWanteds, -- Solves WantedConstraints + solveSimpleGivens, -- Solves [Ct] + solveSimpleWanteds, -- Solves Cts + trySolveImplication, + + setImplicationStatus + ) where + +import GHC.Prelude + +import GHC.Tc.Solver.Dict +import GHC.Tc.Solver.Equality( solveEquality ) +import GHC.Tc.Solver.Irred( solveIrred ) +import GHC.Tc.Solver.Rewrite( rewrite, rewriteType ) +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.CtLoc( ctLocEnv, ctLocOrigin, setCtLocOrigin ) +import GHC.Tc.Types +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( mkGivenLoc ) +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Monad as TcS +import qualified GHC.Tc.Utils.Monad as TcM +import qualified GHC.Tc.Zonk.TcType as TcM + +import GHC.Core.Predicate +import GHC.Core.Reduction +import GHC.Core.Coercion +import GHC.Core.TyCo.FVs( coVarsOfCos ) +import GHC.Core.Class( classHasSCs ) + +import GHC.Types.Id( idType ) +import GHC.Types.Var( EvVar, tyVarKind ) +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic ( IntWithInf, intGtLimit ) +import GHC.Types.Unique.Set( nonDetStrictFoldUniqSet ) + +import GHC.Data.Bag + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Driver.Session + + +import Control.Monad + +import Data.List( deleteFirstsBy ) +import Data.Maybe ( mapMaybe ) +import qualified Data.Semigroup as S +import Data.Void( Void ) + +{- ******************************************************************************** +* * +* Main Simplifier * +* * +******************************************************************************** -} + +simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints +-- Solve the specified Wanted constraints +-- Discard the evidence binds +-- Postcondition: fully zonked +simplifyWantedsTcM wanted + = do { TcM.traceTc "simplifyWantedsTcM {" (ppr wanted) + ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted)) + ; result <- TcM.liftZonkM $ TcM.zonkWC result + ; TcM.traceTc "simplifyWantedsTcM }" (ppr result) + ; return result } + +solveWanteds :: WantedConstraints -> TcS WantedConstraints +solveWanteds wc@(WC { wc_errors = errs }) + = do { cur_lvl <- TcS.getTcLevel + ; traceTcS "solveWanteds {" $ + vcat [ text "Level =" <+> ppr cur_lvl + , ppr wc ] + + ; dflags <- getDynFlags + ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc + + ; errs' <- simplifyDelayedErrors errs + ; let final_wc = solved_wc { wc_errors = errs' } + + ; ev_binds_var <- getTcEvBindsVar + ; bb <- TcS.getTcEvBindsMap ev_binds_var + ; traceTcS "solveWanteds }" $ + vcat [ text "final wc =" <+> ppr final_wc + , text "ev_binds_var =" <+> ppr ev_binds_var + , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] + + ; return final_wc } + +simplify_loop :: Int -> IntWithInf -> Bool + -> WantedConstraints -> TcS WantedConstraints +-- Do a round of solving, and call maybe_simplify_again to iterate +-- The 'definitely_redo_implications' flags is False if the only reason we +-- are iterating is that we have added some new Wanted superclasses +-- hoping for fundeps to help us; see Note [Superclass iteration] +-- +-- Does not affect wc_holes at all; reason: wc_holes never affects anything +-- else, so we do them once, at the end in solveWanteds +simplify_loop n limit definitely_redo_implications + wc@(WC { wc_simple = simples, wc_impl = implics }) + | isSolvedWC wc -- Fast path + = return wc + | otherwise + = do { csTraceTcS $ + text "simplify_loop iteration=" <> int n + <+> (parens $ hsep [ text "definitely_redo =" <+> ppr definitely_redo_implications <> comma + , int (lengthBag simples) <+> text "simples to solve" ]) + ; traceTcS "simplify_loop: wc =" (ppr wc) + + ; (unifs1, wc1) <- reportUnifications $ -- See Note [Superclass iteration] + solveSimpleWanteds simples + -- Any insoluble constraints are in 'simples' and so get rewritten + -- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet + + -- Next, solve implications from wc_impl + ; implics' <- if not definitely_redo_implications -- See Note [Superclass iteration] + && unifs1 == 0 -- for this conditional + then return implics + else solveNestedImplications implics + + ; let wc' = wc1 { wc_impl = wc_impl wc1 `unionBags` implics' } + + ; 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 wc' } + +maybe_simplify_again :: Int -> IntWithInf -> Bool + -> WantedConstraints -> TcS WantedConstraints +maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples }) + | n `intGtLimit` limit + = do { -- Add an error (not a warning) if we blow the limit, + -- Typically if we blow the limit we are going to report some other error + -- (an unsolved constraint), and we don't want that error to suppress + -- the iteration limit warning! + addErrTcS $ TcRnSimplifierTooManyIterations simples limit wc + ; return wc } + + | unif_happened + = simplify_loop n limit True wc + + | superClassesMightHelp wc -- Returns False quickly if wc is solved + = -- We still have unsolved goals, and apparently no way to solve them, + -- so try expanding superclasses at this level, both Given and Wanted + do { pending_given <- getPendingGivenScs + ; let (pending_wanted, simples1) = getPendingWantedScs simples + ; if null pending_given && null pending_wanted + then return wc -- After all, superclasses did not help + else + do { new_given <- makeSuperClasses pending_given + ; new_wanted <- makeSuperClasses pending_wanted + ; solveSimpleGivens new_given -- Add the new Givens to the inert set + ; traceTcS "maybe_simplify_again" (vcat [ text "pending_given" <+> ppr pending_given + , text "new_given" <+> ppr new_given + , text "pending_wanted" <+> ppr pending_wanted + , text "new_wanted" <+> ppr new_wanted ]) + ; simplify_loop n limit (not (null pending_given)) $ + wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } } + -- (not (null pending_given)): see Note [Superclass iteration] + + | otherwise + = return wc + +{- Note [Superclass iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this implication constraint + forall a. + [W] d: C Int beta + forall b. blah +where + class D a b | a -> b + class D a b => C a b +We will expand d's superclasses, giving [W] D Int beta, in the hope of geting +fundeps to unify beta. Doing so is usually fruitless (no useful fundeps), +and if so it seems a pity to waste time iterating the implications (forall b. blah) +(If we add new Given superclasses it's a different matter: it's really worth looking +at the implications.) + +Hence the definitely_redo_implications flag to simplify_loop. It's usually +True, but False in the case where the only reason to iterate is new Wanted +superclasses. In that case we check whether the new Wanteds actually led to +any new unifications, and iterate the implications only if so. +-} + +{- Note [Expanding Recursive Superclasses and ExpansionFuel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the class declaration (T21909) + + class C [a] => C a where + foo :: a -> Int + +and suppose during type inference we obtain an implication constraint: + + forall a. C a => C [[a]] + +To solve this implication constraint, we first expand one layer of the superclass +of Given constraints, but not for Wanted constraints. +(See Note [Eagerly expand given superclasses] and Note [Why adding superclasses can help] +in GHC.Tc.Solver.Dict.) We thus get: + + [G] g1 :: C a + [G] g2 :: C [a] -- new superclass layer from g1 + [W] w1 :: C [[a]] + +Now, we cannot solve `w1` directly from `g1` or `g2` as we may not have +any instances for C. So we expand a layer of superclasses of each Wanteds and Givens +that we haven't expanded yet. +This is done in `maybe_simplify_again`. And we get: + + [G] g1 :: C a + [G] g2 :: C [a] + [G] g3 :: C [[a]] -- new superclass layer from g2, can solve w1 + [W] w1 :: C [[a]] + [W] w2 :: C [[[a]]] -- new superclass layer from w1, not solvable + +Now, although we can solve `w1` using `g3` (obtained from expanding `g2`), +we have a new wanted constraint `w2` (obtained from expanding `w1`) that cannot be solved. +We thus make another go at solving in `maybe_simplify_again` by expanding more +layers of superclasses. This looping is futile as Givens will never be able to catch up with Wanteds. + +Side Note: In principle we don't actually need to /solve/ `w2`, as it is a superclass of `w1` +but we only expand it to expose any functional dependencies (see Note [The superclass story]) +But `w2` is a wanted constraint, so we will try to solve it like any other, +even though ultimately we will discard its evidence. + +Solution: Simply bound the maximum number of layers of expansion for +Givens and Wanteds, with ExpansionFuel. Give the Givens more fuel +(say 3 layers) than the Wanteds (say 1 layer). Now the Givens will +win. The Wanteds don't need much fuel: we are only expanding at all +to expose functional dependencies, and wantedFuel=1 means we will +expand a full recursive layer. If the superclass hierarchy is +non-recursive (the normal case) one layer is therefore full expansion. + +The default value for wantedFuel = Constants.max_WANTEDS_FUEL = 1. +The default value for givenFuel = Constants.max_GIVENS_FUEL = 3. +Both are configurable via the `-fgivens-fuel` and `-fwanteds-fuel` +compiler flags. + +There are two preconditions for the default fuel values: + (1) default givenFuel >= default wantedsFuel + (2) default givenFuel < solverIterations + +Precondition (1) ensures that we expand givens at least as many times as we expand wanted constraints +preferably givenFuel > wantedsFuel to avoid issues like T21909 while +the precondition (2) ensures that we do not reach the solver iteration limit and fail with a +more meaningful error message (see T19627) + +This also applies for quantified constraints; see `-fqcs-fuel` compiler flag and `QCI.qci_pend_sc` field. +-} + +{- ******************************************************************************** +* * +* Solving implication constraints * +* * +******************************************************************************** -} + +solveNestedImplications :: Bag Implication + -> TcS (Bag Implication) +-- Precondition: the TcS inerts may contain unsolved simples which have +-- to be converted to givens before we go inside a nested implication. +solveNestedImplications implics + | isEmptyBag implics + = return (emptyBag) + | otherwise + = do { traceTcS "solveNestedImplications starting {" empty + ; unsolved_implics <- mapBagM solveImplication implics + + -- ... and we are back in the original TcS inerts + -- Notice that the original includes the _insoluble_simples so it was safe to ignore + -- them in the beginning of this function. + ; traceTcS "solveNestedImplications end }" $ + vcat [ text "unsolved_implics =" <+> ppr unsolved_implics ] + + ; return unsolved_implics } + +{- Note [trySolveImplication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`trySolveImplication` may be invoked while solving simple wanteds, notably from +`solveWantedForAll`. It returns a Bool to say if solving succeeded or failed. + +It uses `nestImplicTcS` to build a nested scope. One subtle point is that +`nestImplicTcS` uses the `inert_givens` (not the `inert_cans`) of the current +inert set to initialse the `InertSet` of the nested scope. It is super-important not +to pollute the sub-solving problem with the unsolved Wanteds of the current scope. + +Whenever we do `solveSimpleGivens`, we snapshot the `inert_cans` into `inert_givens`. +(At that moment there should be no Wanteds.) +-} + +trySolveImplication :: Implication -> TcS Bool +-- See Note [trySolveImplication] +trySolveImplication (Implic { ic_tclvl = tclvl + , ic_binds = ev_binds_var + , ic_given = given_ids + , ic_wanted = wanteds + , ic_env = ct_loc_env + , ic_info = info }) + = nestImplicTcS ev_binds_var tclvl $ + do { let loc = mkGivenLoc tclvl info ct_loc_env + givens = mkGivens loc given_ids + ; solveSimpleGivens givens + ; residual_wanted <- solveWanteds wanteds + ; return (isSolvedWC residual_wanted) } + +solveImplication :: Implication -- Wanted + -> TcS Implication -- Simplified implication +-- Precondition: The TcS monad contains an empty worklist and given-only inerts +-- which after trying to solve this implication we must restore to their original value +solveImplication imp@(Implic { ic_tclvl = tclvl + , ic_binds = ev_binds_var + , ic_given = given_ids + , ic_wanted = wanteds + , ic_info = info + , ic_env = ct_loc_env + , ic_status = status }) + | isSolvedStatus status + = return imp -- Do nothing + + | otherwise -- Even for IC_Insoluble it is worth doing more work + -- The insoluble stuff might be in one sub-implication + -- and other unsolved goals in another; and we want to + -- solve the latter as much as possible + = do { inerts <- getInertSet + ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) + + -- commented out; see `where` clause below + -- ; when debugIsOn check_tc_level + + -- Solve the nested constraints + ; (has_given_eqs, given_insols, residual_wanted) + <- nestImplicTcS ev_binds_var tclvl $ + do { let loc = mkGivenLoc tclvl info ct_loc_env + givens = mkGivens loc given_ids + ; solveSimpleGivens givens + + ; residual_wanted <- solveWanteds wanteds + + ; (has_eqs, given_insols) <- getHasGivenEqs tclvl + -- Call getHasGivenEqs /after/ solveWanteds, because + -- solveWanteds can augment the givens, via expandSuperClasses, + -- to reveal given superclass equalities + + ; return (has_eqs, given_insols, residual_wanted) } + + ; traceTcS "solveImplication 2" + (ppr given_insols $$ ppr residual_wanted) + + ; evbinds <- TcS.getTcEvBindsMap ev_binds_var + ; traceTcS "solveImplication 3" $ vcat + [ text "ev_binds_var" <+> ppr ev_binds_var + , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) ] + + ; let final_wanted = residual_wanted `addInsols` given_insols + -- Don't lose track of the insoluble givens, + -- which signal unreachable code; put them in ic_wanted + + ; res_implic <- setImplicationStatus (imp { ic_given_eqs = has_given_eqs + , ic_wanted = final_wanted }) + + ; evbinds <- TcS.getTcEvBindsMap ev_binds_var + ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var + ; traceTcS "solveImplication end }" $ vcat + [ text "has_given_eqs =" <+> ppr has_given_eqs + , text "res_implic =" <+> ppr res_implic + , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) + , text "implication tvcs =" <+> ppr tcvs ] + + ; return res_implic } + + -- TcLevels must be strictly increasing (see (ImplicInv) in + -- Note [TcLevel invariants] in GHC.Tc.Utils.TcType), + -- and in fact I think they should always increase one level at a time. + + -- Though sensible, this check causes lots of testsuite failures. It is + -- remaining commented out for now. + {- + check_tc_level = do { cur_lvl <- TcS.getTcLevel + ; massertPpr (tclvl == pushTcLevel cur_lvl) + (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) } + -} + +---------------------- +setImplicationStatus :: Implication -> TcS Implication +-- Finalise the implication returned from solveImplication, +-- * Set the ic_status field +-- * Prune unnecessary evidence bindings +-- * Prune unnecessary child implications +-- Precondition: the ic_status field is not already IC_Solved +setImplicationStatus implic@(Implic { ic_status = old_status + , ic_info = info + , ic_wanted = wc }) + = assertPpr (not (isSolvedStatus old_status)) (ppr info) $ + -- Precondition: we only set the status if it is not already solved + do { traceTcS "setImplicationStatus {" (ppr implic) + + ; let solved = isSolvedWC wc + ; new_implic <- neededEvVars implic + ; bad_telescope <- if solved then checkBadTelescope implic + else return False + + ; let new_status | insolubleWC wc = IC_Insoluble + | not solved = IC_Unsolved + | bad_telescope = IC_BadTelescope + | otherwise = IC_Solved { ics_dead = dead_givens } + dead_givens = findRedundantGivens new_implic + new_wc = pruneImplications wc + + final_implic = new_implic { ic_status = new_status + , ic_wanted = new_wc } + + ; traceTcS "setImplicationStatus }" (ppr final_implic) + ; return final_implic } + +pruneImplications :: WantedConstraints -> WantedConstraints +-- We have now recorded the `ic_need` variables of the child +-- implications (in `ic_need_implics` of the parent) so we can +-- delete any unnecessary children. +pruneImplications wc@(WC { wc_impl = implics }) + = wc { wc_impl = filterBag keep_me implics } + -- Do not prune holes; these should be reported + where + keep_me :: Implication -> Bool + keep_me (Implic { ic_status = status, ic_wanted = wanted }) + | IC_Solved { ics_dead = dead_givens } <- status -- Fully solved + , null dead_givens -- No redundant givens to report + , isEmptyBag (wc_impl wanted) -- No children that might have things to report + = False + | otherwise + = True -- Otherwise, keep it + +findRedundantGivens :: Implication -> [EvVar] +findRedundantGivens (Implic { ic_info = info, ic_need = need, ic_given = givens }) + | not (warnRedundantGivens info) -- Don't report redundant constraints at all + = [] -- See (TRC4) of Note [Tracking redundant constraints] + + | not (null unused_givens) -- Some givens are literally unused + = unused_givens + + -- Only try this if unused_givens is empty: see (TRC2a) + | otherwise -- All givens are used, but some might + = redundant_givens -- still be redundant e.g. (Eq a, Ord a) + + where + in_instance_decl = case info of { InstSkol {} -> True; _ -> False } + -- See Note [Redundant constraints in instance decls] + + unused_givens = filterOut is_used givens + + needed_givens_ignoring_default_methods = ens_fvs need + is_used given = is_type_error given + || given `elemVarSet` needed_givens_ignoring_default_methods + || (in_instance_decl && is_improving (idType given)) + + minimal_givens = mkMinimalBySCs evVarPred givens -- See (TRC2) + + is_minimal = (`elemVarSet` mkVarSet minimal_givens) + redundant_givens + | in_instance_decl = [] + | otherwise = filterOut is_minimal givens + + -- See #15232 + is_type_error id = isTopLevelUserTypeError (idType id) + + is_improving pred -- (transSuperClasses p) does not include p + = any isImprovementPred (pred : transSuperClasses pred) + +warnRedundantGivens :: SkolemInfoAnon -> Bool +warnRedundantGivens (SigSkol ctxt _ _) + = case ctxt of + FunSigCtxt _ rrc -> reportRedundantConstraints rrc + ExprSigCtxt rrc -> reportRedundantConstraints rrc + _ -> False + +warnRedundantGivens (InstSkol from _) + -- Do not report redundant constraints for quantified constraints + -- See (TRC4) in Note [Tracking redundant constraints] + -- Fortunately it is easy to spot implications constraints that arise + -- from quantified constraints, from their SkolInfo + = case from of + IsQC {} -> False + IsClsInst {} -> True + + -- To think about: do we want to report redundant givens for + -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21. +warnRedundantGivens _ = False + +{- Note [Redundant constraints in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instance declarations are special in two ways: + +* 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. + +* We don't report givens that are a superclass of another given. E.g. + class Ord r => UserOfRegs r a where ... + instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where + The (Ord r) is not redundant, even though it is a superclass of + (UserOfRegs r CmmReg). See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance. + + Again this is specific to instance declarations. +-} + + +checkBadTelescope :: Implication -> TcS Bool +-- True <=> the skolems form a bad telescope +-- See Note [Checking telescopes] in GHC.Tc.Types.Constraint +checkBadTelescope (Implic { ic_info = info + , ic_skols = skols }) + | checkTelescopeSkol info + = do{ skols <- mapM TcS.zonkTyCoVarKind skols + ; return (go emptyVarSet (reverse skols))} + + | otherwise + = return False + + where + go :: TyVarSet -- skolems that appear *later* than the current ones + -> [TcTyVar] -- ordered skolems, in reverse order + -> Bool -- True <=> there is an out-of-order skolem + go _ [] = False + go later_skols (one_skol : earlier_skols) + | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols + = True + | otherwise + = go (later_skols `extendVarSet` one_skol) earlier_skols + +neededEvVars :: Implication -> TcS Implication +-- Find all the evidence variables that are "needed", +-- /and/ delete dead evidence bindings +-- +-- See Note [Tracking redundant constraints] +-- See Note [Delete dead Given evidence bindings] +-- +-- - Start from initial_seeds (from nested implications) +-- +-- - Add free vars of RHS of all Wanted evidence bindings +-- and coercion variables accumulated in tcvs (all Wanted) +-- +-- - Generate 'needed', the needed set of EvVars, by doing transitive +-- closure through Given bindings +-- e.g. Needed {a,b} +-- Given a = sc_sel a2 +-- Then a2 is needed too +-- +-- - Prune out all Given bindings that are not needed + +neededEvVars implic@(Implic { ic_info = info + , ic_binds = ev_binds_var + , ic_wanted = WC { wc_impl = implics } + , ic_need_implic = old_need_implic -- See (TRC1) + }) + = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var + ; used_cos <- TcS.getTcEvTyCoVars ev_binds_var + + ; let -- Find the variables needed by `implics` + new_need_implic@(ENS { ens_dms = dm_seeds, ens_fvs = other_seeds }) + = foldr add_implic old_need_implic implics + -- Start from old_need_implic! See (TRC1) + + -- Get the variables needed by the solved bindings + -- (It's OK to use a non-deterministic fold here + -- because add_wanted is commutative.) + used_covars = coVarsOfCos used_cos + seeds_w = nonDetStrictFoldEvBindMap add_wanted used_covars ev_binds + + need_ignoring_dms = findNeededGivenEvVars ev_binds (other_seeds `unionVarSet` seeds_w) + need_from_dms = findNeededGivenEvVars ev_binds dm_seeds + need_full = need_ignoring_dms `unionVarSet` need_from_dms + + -- `need`: the Givens from outer scopes that are used in this implication + -- is_dm_skol: see (TRC5) + need | is_dm_skol info = ENS { ens_dms = trim ev_binds need_full + , ens_fvs = emptyVarSet } + | otherwise = ENS { ens_dms = trim ev_binds need_from_dms + , ens_fvs = trim ev_binds need_ignoring_dms } + + -- Delete dead Given evidence bindings + -- See Note [Delete dead Given evidence bindings] + ; let live_ev_binds = filterEvBindMap (needed_ev_bind need_full) ev_binds + ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds + + ; traceTcS "neededEvVars" $ + vcat [ text "old_need_implic:" <+> ppr old_need_implic + , text "new_need_implic:" <+> ppr new_need_implic + , text "used_covars:" <+> ppr used_covars + , text "need_ignoring_dms:" <+> ppr need_ignoring_dms + , text "need_from_dms:" <+> ppr need_from_dms + , text "need:" <+> ppr need + , text "ev_binds:" <+> ppr ev_binds + , text "live_ev_binds:" <+> ppr live_ev_binds ] + ; return (implic { ic_need = need + , ic_need_implic = new_need_implic }) } + where + trim :: EvBindMap -> VarSet -> VarSet + -- Delete variables bound by Givens or bindings + trim ev_binds needs = needs `varSetMinusEvBindMap` ev_binds + + add_implic :: Implication -> EvNeedSet -> EvNeedSet + add_implic (Implic { ic_given = givens, ic_need = need }) acc + = (need `delGivensFromEvNeedSet` givens) `unionEvNeedSet` acc + + needed_ev_bind needed (EvBind { eb_lhs = ev_var, eb_info = info }) + | EvBindGiven{} <- info = ev_var `elemVarSet` needed + | otherwise = True -- Keep all wanted bindings + + add_wanted :: EvBind -> VarSet -> VarSet + add_wanted (EvBind { eb_info = info, eb_rhs = rhs }) needs + | EvBindGiven{} <- info = needs -- Add the rhs vars of the Wanted bindings only + | otherwise = nestedEvIdsOfTerm rhs `unionVarSet` needs + + is_dm_skol :: SkolemInfoAnon -> Bool + is_dm_skol (MethSkol _ is_dm) = is_dm + is_dm_skol _ = False + +findNeededGivenEvVars :: EvBindMap -> VarSet -> VarSet +-- Find all the Given evidence needed by seeds, +-- looking transitively through bindings for Givens (only) +findNeededGivenEvVars ev_binds seeds + = transCloVarSet also_needs seeds + where + also_needs :: VarSet -> VarSet + also_needs needs = nonDetStrictFoldUniqSet add emptyVarSet needs + -- It's OK to use a non-deterministic fold here because we immediately + -- forget about the ordering by creating a set + + add :: Var -> VarSet -> VarSet + add v needs + | Just ev_bind <- lookupEvBind ev_binds v + , EvBind { eb_info = EvBindGiven, eb_rhs = rhs } <- ev_bind + -- Look at Given bindings only + = nestedEvIdsOfTerm rhs `unionVarSet` needs + | otherwise + = needs + +------------------------------------------------- +simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError) +-- Simplify any delayed errors: e.g. type and term holes +-- NB: At this point we have finished with all the simple +-- constraints; they are in wc_simple, not in the inert set. +-- So those Wanteds will not rewrite these delayed errors. +-- That's probably no bad thing. +-- +-- However if we have [W] alpha ~ Maybe a, [W] alpha ~ Int +-- and _ : alpha, then we'll /unify/ alpha with the first of +-- the Wanteds we get, and thereby report (_ : Maybe a) or +-- (_ : Int) unpredictably, depending on which we happen to see +-- first. Doesn't matter much; there is a type error anyhow. +-- T17139 is a case in point. +simplifyDelayedErrors = mapMaybeBagM simpl_err + where + simpl_err :: DelayedError -> TcS (Maybe DelayedError) + simpl_err (DE_Hole hole) = Just . DE_Hole <$> simpl_hole hole + simpl_err err@(DE_NotConcrete {}) = return $ Just err + simpl_err (DE_Multiplicity mult_co loc) + = do { mult_co' <- TcS.zonkCo mult_co + ; if isReflexiveCo mult_co' then + return Nothing + else + return $ Just (DE_Multiplicity mult_co' loc) } + + simpl_hole :: Hole -> TcS Hole + + -- See Note [Do not simplify ConstraintHoles] + simpl_hole h@(Hole { hole_sort = ConstraintHole }) = return h + + -- other wildcards should be simplified for printing + -- we must do so here, and not in the error-message generation + -- code, because we have all the givens already set up + simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc }) + = do { ty' <- rewriteType loc ty + ; traceTcS "simpl_hole" (ppr ty $$ ppr ty') + ; return (h { hole_ty = ty' }) } + +{- Note [Delete dead Given evidence bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As a result of superclass expansion, we speculatively +generate evidence bindings for Givens. E.g. + f :: (a ~ b) => a -> b -> Bool + f x y = ... +We'll have + [G] d1 :: (a~b) +and we'll speculatively generate the evidence binding + [G] d2 :: (a ~# b) = sc_sel d + +Now d2 is available for solving. But it may not be needed! Usually +such dead superclass selections will eventually be dropped as dead +code, but: + + * It won't always be dropped (#13032). In the case of an + unlifted-equality superclass like d2 above, we generate + case heq_sc d1 of d2 -> ... + and we can't (in general) drop that case expression in case + d1 is bottom. So it's technically unsound to have added it + in the first place. + + * Simply generating all those extra superclasses can generate lots of + code that has to be zonked, only to be discarded later. Better not + to generate it in the first place. + + Moreover, if we simplify this implication more than once + (e.g. because we can't solve it completely on the first iteration + of simpl_loop), we'll generate all the same bindings AGAIN! + +Easy solution: take advantage of the work we are doing to track dead +(unused) Givens, and use it to prune the Given bindings too. This is +all done by neededEvVars. + +This led to a remarkable 25% overall compiler allocation decrease in +test T12227. + +But we don't get to discard all redundant equality superclasses, alas; +see #15205. + +Note [Do not simplify ConstraintHoles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before printing the inferred value for a type hole (a _ wildcard in +a partial type signature), we simplify it w.r.t. any Givens. This +makes for an easier-to-understand diagnostic for the user. + +However, we do not wish to do this for extra-constraint holes. Here is +the example for why (partial-sigs/should_compile/T12844): + + bar :: _ => FooData rngs + bar = foo + + data FooData rngs + + class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs + + type family Head (xs :: [k]) where Head (x ': xs) = x + +GHC correctly infers that the extra-constraints wildcard on `bar` +should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this +constraint as a Given on the implication constraint for `bar`. (This +implication is emitted by emitResidualConstraints.) The Hole for the _ +is stored within the implication's WantedConstraints. When +simplifyHoles is called, that constraint is already assumed as a +Given. Simplifying with respect to it turns it into ('(r, r') ~ '(r, +r'), Foo rngs), which is disastrous. + +Furthermore, there is no need to simplify here: extra-constraints wildcards +are filled in with the output of the solver, in chooseInferredQuantifiers +(choose_psig_context), so they are already simplified. (Contrast to normal +type holes, which are just bound to a meta-variable.) Avoiding the poor output +is simple: just don't simplify extra-constraints wildcards. + +This is the only reason we need to track ConstraintHole separately +from TypeHole in HoleSort. + +See also Note [Extra-constraint holes in partial type signatures] +in GHC.Tc.Gen.HsType. + +Note [Tracking redundant constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Opt_WarnRedundantConstraints, GHC can report which constraints of a type +signature (or instance declaration) are redundant, and can be omitted. Here is +an overview of how it works. + +This is all tested in typecheck/should_compile/T20602 (among others). + +How tracking works: + +* We maintain the `ic_need` field in an implication: + ic_need: the set of Given evidence variables that are needed somewhere + inside this implication; and are bound either by this implication + or by an enclosing one. + +* `setImplicationStatus` does all the work: + - When the constraint solver finishes solving all the wanteds in + an implication, it sets its status to IC_Solved + + - `neededEvVars`: computes which evidence variables are needed by an + implication in `setImplicationStatus`. A variable is needed if + + a) It is in the ic_need field of this implication, computed in + a previous call to `setImplicationStatus`; see (TRC1) + + b) It is in the ics_need of a nested implication; see `add_implic` + in `neededEvVars` + + c) It is free in the RHS of any /Wanted/ EvBind; each such binding + solves a Wanted, so we want them all. See `add_wanted` in + `neededEvVars` + + d) It is free in the RHS of a /Given/ EvBind whose LHS is needed: + see `findNeededGivenEvVars` called from `neededEvVars`. + + - Next, if the final status is IC_Solved, `setImplicationStatus` uses + `findRedundantGivens` to decide which of this implication's Givens + are redundant. + + - It also uses `pruneImplications` to discard any now-unnecessary child + implications. + +* GHC.Tc.Errors does the actual warning, in `warnRedundantConstraints`. + + +Wrinkles: + +(TRC1) `pruneImplications` drops any sub-implications of an Implication + that are irrelevant for error reporting: + - no unsolved wanteds + - no sub-implications + - no redundant givens to report + But in doing so we must not lose track of the variables that those implications + needed! So we track the ic_needs of all child implications in `ic_need_implics`. + Crucially, this set includes things need by child implications that have been + discarded by `pruneImplications`. + +(TRC2) A Given can be redundant because it is implied by other Givens + f :: (Eq a, Ord a) => blah -- Eq a unnecessary + g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary + We nail this by using `mkMinimalBySCs` in `findRedundantGivens`. + (TRC2a) But NOTE that we only attempt this mkMinimalBySCs stuff if all Givens + used by evidence bindings. Example: + f :: (Eq a, Ord a) => a -> Bool + f x = x == x + We report (Ord a) as unused because it is. But we must not also report (Eq a) + as unused because it is a superclass of Ord! + +(TRC3) When two Givens are the same, prefer one that does not involve superclass + selection, or more generally has shallower superclass-selection depth: + see 2(b,c) in Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet. + e.g f :: (Eq a, Ord a) => a -> Bool + f x = x == x + Eager superclass expansion gives us two [G] Eq a constraints. We want to keep + the one from the user-written Eq a, not the superclass selection. This means + we report the Ord a as redundant with -Wredundant-constraints, not the Eq a. + Getting this wrong was #20602. + +(TRC4) We don't compute redundant givens for *every* implication; only + for those which reply True to `warnRedundantGivens`: + + - For example, in a class declaration, the default method *can* + use the class constraint, but it certainly doesn't *have* to, + and we don't want to report an error there. Ditto instance decls. + + - More subtly, in a function definition + f :: (Ord a, Ord a, Ix a) => a -> a + f x = rhs + we do an ambiguity check on the type (which would find that one + of the Ord a constraints was redundant), and then we check that + the definition has that type (which might find that both are + redundant). We don't want to report the same error twice, so we + disable it for the ambiguity check. Hence using two different + FunSigCtxts, one with the warn-redundant field set True, and the + other set False in + - GHC.Tc.Gen.Bind.tcSpecPrag + - GHC.Tc.Gen.Bind.tcTySig + + - We do not want to report redundant constraints for implications + that come from quantified constraints. Example #23323: + data T a + instance Show (T a) where ... -- No context! + foo :: forall f c. (forall a. c a => Show (f a)) => Proxy c -> f Int -> Int + bar = foo @T @Eq + + The call to `foo` gives us + [W] d : (forall a. Eq a => Show (T a)) + To solve this, GHC.Tc.Solver.Solve.solveForAll makes an implication constraint: + forall a. Eq a => [W] ds : Show (T a) + and because of the degnerate instance for `Show (T a)`, we don't need the `Eq a` + constraint. But we don't want to report it as redundant! + +(TRC5) Consider this (#25992), where `op2` has a default method + class C a where { op1, op2 :: a -> a + ; op2 = op1 . op1 } + instance C a => C [a] where + op1 x = x + + Plainly the (C a) constraint is unused; but the expanded decl will look like + $dmop2 :: C a => a -> a + $dmop2 = op1 . op1 + + $fCList :: forall a. C a => C [a] + $fCList @a (d::C a) = MkC (\(x:a).x) ($dmop2 @a d) + + Notice that `d` gets passed to `$dmop`: it is "needed". But it's only + /really/ needed if some /other/ method (in this case `op1`) uses it. + + So, rather than one set of "needed Givens" we use `EvNeedSet` to track + a /pair/ of sets: + ens_dms: needed /only/ by default-method calls + ens_fvs: needed by something other than a default-method call + It's a bit of a palaver, but not really difficult. + All the logic is localised in `neededEvVars`. + + But NOTE that this only applies to /vanilla/ default methods. + For /generic/ default methods, like + class D a where { op1 :: blah + ; default op1 :: Eq a => blah2 } + the (Eq a) constraint really is needed (e.g. class NFData and #25992). + Hence the `Bool` field of `MethSkol` indicates a /vanilla/ default method. + +----- Examples + + f, g, h :: (Eq a, Ord a) => a -> Bool + f x = x == x + g x = x > x + h x = x == x && x > x + + All of f,g,h will discover that they have two [G] Eq a constraints: one as + given and one extracted from the Ord a constraint. They will both discard + the latter; see (TRC3). + + The body of f uses the [G] Eq a, but not the [G] Ord a. It will report a + redundant Ord a. + + The body of g uses the [G] Ord a, but not the [G] Eq a. It will report a + redundant Eq a. + + The body of h uses both [G] Ord a and [G] Eq a; each is used in a solved + Wanted evidence binding. But (TRC2) kicks in and discovers the Eq a + is redundant. + +----- Shortcomings + +Shortcoming 1. Consider + + j :: (Eq a, a ~ b) => a -> Bool + j x = x == x + + k :: (Eq a, b ~ a) => a -> Bool + k x = x == x + +Currently (Nov 2021), j issues no warning, while k says that b ~ a +is redundant. This is because j uses the a ~ b constraint to rewrite +everything to be in terms of b, while k does none of that. This is +ridiculous, but I (Richard E) don't see a good fix. + +Shortcoming 2. Removing a redundant constraint can cause clients to fail to +compile, by making the function more polymorphic. Consider (#16154) + + f :: (a ~ Bool) => a -> Int + f x = 3 + + g :: String -> Int + g s = f (read s) + +The constraint in f's signature is redundant; not used to typecheck +`f`. And yet if you remove it, `g` won't compile, because there'll +be an ambiguous variable in `g`. + + +********************************************************************** +* * +* Main Solver * +* * +********************************************************************** + +Note [Basic Simplifier Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Pick an element from the WorkList if there exists one with depth + less than our context-stack depth. + +2. Run it down the 'stage' pipeline. Stages are: + - canonicalization + - inert reactions + - spontaneous reactions + - top-level interactions + Each stage returns a StopOrContinue and may have sideeffected + the inerts or worklist. + + The threading of the stages is as follows: + - If (Stop) is returned by a stage then we start again from Step 1. + - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to + the next stage in the pipeline. +4. If the element has survived (i.e. ContinueWith x) the last stage + then we add it in the inerts and jump back to Step 1. + +If in Step 1 no such element exists, we have exceeded our context-stack +depth and will simply fail. +-} + +solveSimpleGivens :: [Ct] -> TcS () +solveSimpleGivens givens + | null givens -- Shortcut for common case + = return () + | otherwise + = do { traceTcS "solveSimpleGivens {" (ppr givens) + ; go givens + + -- Capture the Givens in the inert_givens of the inert set + -- for use by subsequent calls of nestImplicTcS + -- See Note [trySolveImplication] + ; updInertSet (\is -> is { inert_givens = inert_cans is }) + + ; cans <- getInertCans + ; traceTcS "End solveSimpleGivens }" (ppr cans) } + where + go givens = do { solveSimples (listToBag givens) + ; new_givens <- runTcPluginsGiven + ; when (notNull new_givens) $ + go new_givens } + +solveSimpleWanteds :: Cts -> TcS WantedConstraints +-- Returns unsolved constraints, mostly just flat ones (Cts), +-- but also any unsolved implications arising from forall-constraints +-- The result is not necessarily zonked +solveSimpleWanteds simples + = do { mode <- getTcSMode + ; dflags <- getDynFlags + ; inerts <- getInertSet + + ; traceTcS "solveSimpleWanteds {" $ + vcat [ text "Mode:" <+> ppr mode + , text "Inerts:" <+> ppr inerts + , text "Wanteds to solve:" <+> ppr simples ] + + ; (n,simples',implics') <- go (solverIterations dflags) 1 emptyBag simples + + ; let unsolved_wc = emptyWC { wc_simple = simples', wc_impl = implics' } + + ; traceTcS "solveSimpleWanteds end }" $ + vcat [ text "iterations =" <+> ppr n + , text "residual =" <+> ppr unsolved_wc ] + + ; return unsolved_wc } + where + go :: IntWithInf -- Limit + -> Int -- Iteration number + -> Bag Implication -- Accumulating parameter: unsolved implications + -> Cts -- Try to solve these + -> TcS (Int, Cts, Bag Implication) + -- See Note [The solveSimpleWanteds loop] + go limit n implics wanted + | n `intGtLimit` limit + = failTcS $ TcRnSimplifierTooManyIterations + simples limit + (emptyWC { wc_simple = wanted, wc_impl = implics }) + + | isEmptyBag wanted + = return (n, wanted, implics) + + | otherwise + = do { -- Solve + (wanted1, implics1) <- solve_one wanted + ; let implics2 = implics `unionBags` implics1 + + -- Run plugins + -- NB: runTcPluginsWanted has a fast path for + -- empty wanted1, which is the common case + ; (rerun_plugin, wanted2) <- runTcPluginsWanted wanted1 + + ; if rerun_plugin + then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin) + ; go limit (n+1) implics2 wanted2 } -- Loop + else return (n, wanted2, implics2) } -- Done + + + solve_one :: Cts -> TcS (Cts, Bag Implication) + -- Try solving these constraints + -- Affects the unification state (of course) but not the inert set + -- The result is not necessarily zonked + solve_one simples + = nestTcS $ + do { solveSimples simples + ; simples' <- getUnsolvedInerts + -- Now try to solve any Wanted quantified + -- constraints (i.e. QCInsts) in `simples1` + ; solveWantedQCIs simples' } + + +{- Note [The solveSimpleWanteds loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Solving a bunch of simple constraints is done in a loop, +(the 'go' loop of 'solveSimpleWanteds'): + 1. Try to solve them + 2. Try the plugin + 3. If the plugin wants to run again, go back to step 1 +-} + +{- +************************************************************************ +* * + Solving flat constraints: solveSimples +* * +********************************************************************* -} + +-- The main solver loop implements Note [Basic Simplifier Plan] +--------------------------------------------------------------- + +solveSimples :: Cts -> TcS () +-- Solve this bag of constraints, +-- returning the final InertSet in TcS +-- The constraints are initially examined in left-to-right order + +solveSimples cts + = {-# SCC "solveSimples" #-} + do { emitWork cts; solve_loop } + where + solve_loop + = {-# SCC "solve_loop" #-} + do { sel <- selectNextWorkItem + ; case sel of + Nothing -> return () + Just ct -> do { solveOne ct + ; solve_loop } } + +solveOne :: Ct -> TcS () -- Solve one constraint +solveOne workItem + = do { wl <- getWorkList + ; inerts <- getInertSet + ; tclevel <- TcS.getTcLevel + ; traceTcS "----------------------------- " empty + ; traceTcS "Start solver pipeline {" $ + vcat [ text "tclevel =" <+> ppr tclevel + , text "work item =" <+> ppr workItem + , text "inerts =" <+> ppr inerts + , text "rest of worklist =" <+> ppr wl ] + + ; bumpStepCountTcS -- One step for each constraint processed + ; solve workItem } + where + solve :: Ct -> TcS () + solve ct + = do { traceTcS "solve {" (text "workitem = " <+> ppr ct) + ; res <- runSolverStage (solveCt ct) + ; traceTcS "end solve }" (ppr res) + ; case res of + StartAgain ct -> do { traceTcS "Go round again" (ppr ct) + ; solve ct } + + Stop ev s -> do { traceFireTcS ev s + ; traceTcS "End solver pipeline }" empty + ; return () } + + -- ContinueWith can't happen: res :: SolverStage Void + -- solveCt either solves the constraint, or puts + -- the unsolved constraint in the inert set. + } + +{- ********************************************************************* +* * +* Solving one constraint: solveCt +* * +************************************************************************ + +Note [Canonicalization] +~~~~~~~~~~~~~~~~~~~~~~~ +Canonicalization converts a simple constraint to a canonical form. It is +unary (i.e. treats individual constraints one at a time). + +Constraints originating from user-written code come into being as +CNonCanonicals. We know nothing about these constraints. So, first: + + Classify CNonCanoncal constraints, depending on whether they + are equalities, class predicates, or other. + +Then proceed depending on the shape of the constraint. Generally speaking, +each constraint gets rewritten and then decomposed into one of several forms +(see type Ct in GHC.Tc.Types). + +When an already-canonicalized constraint gets kicked out of the inert set, +it must be recanonicalized. But we know a bit about its shape from the +last time through, so we can skip the classification step. +-} + +solveCt :: Ct -> SolverStage Void +-- The Void result tells us that solveCt cannot return +-- a ContinueWith; it must return Stop or StartAgain. +solveCt (CNonCanonical ev) = solveNC ev +solveCt (CIrredCan (IrredCt { ir_ev = ev })) = solveNC ev + +solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel + , eq_lhs = lhs, eq_rhs = rhs })) + = solveEquality ev eq_rel (canEqLHSType lhs) rhs + +solveCt (CQuantCan qci@(QCI { qci_ev = ev })) + = do { ev' <- rewriteEvidence ev + -- It is (much) easier to rewrite and re-classify than to + -- rewrite the pieces and build a Reduction that will rewrite + -- the whole constraint + ; case classifyPredType (ctEvPred ev') of + ForAllPred tvs theta body_pred + -> solveForAll (qci { qci_ev = ev', qci_tvs = tvs + , qci_theta = theta, qci_body = body_pred }) + _ -> pprPanic "SolveCt" (ppr ev) } + +solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc })) + = do { ev <- rewriteEvidence ev + -- It is easier to rewrite and re-classify than to rewrite + -- the pieces and build a Reduction that will rewrite the + -- whole constraint + ; case classifyPredType (ctEvPred ev) of + ClassPred cls tys + -> solveDict (DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = pend_sc }) + _ -> pprPanic "solveCt" (ppr ev) } + +------------------ +solveNC :: CtEvidence -> SolverStage Void +solveNC ev + = -- Instead of rewriting the evidence before classifying, it's possible we + -- can make progress without the rewrite. Try this first. + -- For insolubles (all of which are equalities), do /not/ rewrite the arguments + -- In #14350 doing so led entire-unnecessary and ridiculously large + -- type function expansion. Instead, canEqNC just applies + -- the substitution to the predicate, and may do decomposition; + -- e.g. a ~ [a], where [G] a ~ [Int], can decompose + case classifyPredType (ctEvPred ev) of { + EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 ; + _ -> + + -- Do rewriting on the constraint, especially zonking + do { ev <- rewriteEvidence ev + + -- And then re-classify + ; case classifyPredType (ctEvPred ev) of + ClassPred cls tys -> solveDictNC ev cls tys + ForAllPred tvs th p -> solveForAllNC ev tvs th p + IrredPred {} -> solveIrred (IrredCt { ir_ev = ev, ir_reason = IrredShapeReason }) + EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 + -- EqPred only happens if (say) `c` is unified with `a ~# b`, + -- but that is rare because it requires c :: CONSTRAINT UnliftedRep + + }} + + +{- ********************************************************************* +* * +* Quantified constraints +* * +********************************************************************* -} + +{- Note [Quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The -XQuantifiedConstraints extension allows type-class contexts like this: + + data Rose f x = Rose x (f (Rose f x)) + + instance (Eq a, forall b. Eq b => Eq (f b)) + => Eq (Rose f a) where + (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2 + +Note the (forall b. Eq b => Eq (f b)) in the instance contexts. +This quantified constraint is needed to solve the + [W] (Eq (f (Rose f x))) +constraint which arises form the (==) definition. + +The wiki page is + https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints +which in turn contains a link to the GHC Proposal where the change +is specified, and a Haskell Symposium paper about it. + +We implement two main extensions to the design in the paper: + + 1. We allow a variable in the instance head, e.g. + f :: forall m a. (forall b. m b) => D (m a) + Notice the 'm' in the head of the quantified constraint, not + a class. + + 2. We support superclasses to quantified constraints. + For example (contrived): + f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool + f x y = x==y + Here we need (Eq (m a)); but the quantified constraint deals only + with Ord. But we can make it work by using its superclass. + +Here are the moving parts + * Language extension {-# LANGUAGE QuantifiedConstraints #-} + and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension + + * A new form of evidence, EvDFun, that is used to discharge + such wanted constraints + + * checkValidType gets some changes to accept forall-constraints + only in the right places. + + * Predicate.Pred gets a new constructor ForAllPred, and + and `classifyPredType` analyses a `PredType` to decompose + the new forall-constraints + + * GHC.Tc.Solver.Monad.InertCans gets an extra field, `inert_qcis`, + which holds all the Given forall-constraints. In effect, + such Given constraints are like local instance decls. + + * `inert_qcis` also temporarily holds Wanted quantified constraints + (see Note [Solving a Wanted forall-constraint]) + + * When trying to solve a class constraint, GHC.Tc.Solver.Dict.matchLocalInst + (note "local" inst) uses the Given `inert_qcis` to solve the constraint. + + * `solveForAll` deals with solving a forall-constraint. See + * Note [Solving a Given forall-constraint] + * Note [Solving a Wanted forall-constraint] + +Note that a quantified constraint is never /inferred/ +(by GHC.Tc.Solver.simplifyInfer). A function can only have a +quantified constraint in its type if it is given an explicit +type signature. + +Note [Solving a Given forall-constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a Given constraint + [G] df :: forall ab. (Eq a, Ord b) => C x a b +we just add it to TcS's local InstEnv of known instances, `inert_qcis`, +via addInertQCI. Then, if we look up (C x Int Bool), say, +we'll find a match in the `inert_qcis`. + +Note [Solving a Wanted forall-constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Solving a wanted forall (quantified) constraint + [W] df :: forall a b. (Eq a, Ord b) => C x a b +is delightfully easy in principle. Just build an implication constraint + forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a +and discharge df thus: + df = /\ab. \g1 g2. let in d +where is filled in by solving the implication constraint. + +What we actually do is this: + +* In `solveForAll` we see if we have an identical quantified constraint + to solve it (using tryInertQCs). In particular, solve a Wanted QCI + from an identical Given. This is more than a simple optimisation: + see Note [Solving Wanted QCs from Given QCs] + + If not, just stash it in `inert_qcis :: [QCInst]`. (If it's a Given + we can use it to solve other constraints; if a Wanted we will solve + it later using `solveWantedQCIs`.) + +* In the main `solveSimpleWanteds` (specifically `solve_one`): + + - We attempt to solve the `wc_simple` constraints with `solveSimples` + Unsolved quantified constraints just accumulate in the `inert_qcis` field + of the `InertSet`. + + - Then we use `solveWantedQCIs` to solve any quantified constraints. That + often turns the `QCInst` into an `Implication`; but not invariably (WFA4) + +Wrinkles: + +(WFA2) Termination: see #19690. We want to maintain the invariant (QC-INV): + + (QC-INV) Every quantified constraint returns a non-bottom dictionary + + just as every top-level instance declaration guarantees to return a non-bottom + dictionary. But as #19690 shows, it is possible to get a bottom dictionary + by superclass selection if we aren't careful. The situation is very similar + to that described in Note [Recursive superclasses] in GHC.Tc.TyCl.Instance; + and we use the same solution: + + * Give the Givens a CtOrigin of (GivenOrigin (InstSkol IsQC head_size)) + * Give the Wanted a CtOrigin of (ScOrigin IsQC NakedSc) + + Both of these things are done in `solveWantedQCI`. Now the mechanism described + in Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance takes over. + +(WFA3) Error messages. Suppose we are trying to solve the quantified constraint + forall a. Eq a => Eq (c a) + We don't just want to say "No instance for Eq (c a)". It /really/ helps to + say what quantified constraint we were trying to solve. + + So the `IsQC` origin carries that info, and `GHC.Tc.Errors.Ppr.pprQCOriginExtra` + prints the extra info. + +(WFA4) When `tcsmFullySolveQCIs` is on, we adopt an all-or-nothing strategy: + either solve the forall-constraint /fully/ or do nothing at all. + Why? See (NFS1) in Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig + +(WFA5) Why not /always/ us the all-or-nothing strategy, so we don't need a + flag? Several reasons: + + * Less efficient; `tcsmFullySolveQCIs` abandons the work done on the constraint, + so we might do it again next time around. + + * More importantly, we would get worse results from `deriving`: #26315. + In that code the `deriving` mechanism was trying to solve + [W] df :: forall n. Eq (Const i n) + If we turn it into an implication, we can simplfy that `Const` to get + the residual implication + forall n. [W] d :: Eq i + And then `approximateWC` can extract the (Eq i) as a plausible context for + the instance. + + * Very much the same issue came up for the inferred type of a function that + lacks a type signature #26376. Again, if the forall-constraint is not + turned into an implication `approximateWC` gives a less-good answer. + +Note [Solving Wanted QCs from Given QCs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are about to solve a Wanted quantified constraint, and there is a +Given quantified constraint with the same type, we should directly solve the +Wanted from the Given (instead of building an implication). + +Not only is this more direct and efficient, sometimes it is also /necessary/. +Consider: + + f :: forall a k. (Eq a, forall x. Eq x => Eq k x) => a -> blah + {-# SPECIALISE (f :: forall k. (forall x. Eq x => Eq k x) => Int -> blah #-} + +Here we specialise the `a` parameter to `f`, leaving the quantified constraint +untouched. We want to get a rule like: + + RULE forall @k (d :: forall x. Eq x => Eq k x). + f @Int @k d = $sf @k d + +But when we typecheck that expression-with-a-type-signature, if we don't solve +Wanted forall constraints directly, we will do so indirectly and end up with +this as the LHS of the RULE: + + (/\k \(df::forall x.Eq x => Eq k x). f @Int @k (/\x \(d:Eq x). df @x d)) + @kk dd + +We run the simple optimiser on that, which eliminates the beta-redex. However, +it may not eta-reduce that `/\x \(d:Eq x)...`, because we are cautious about +eta-reduction. So we may be left with an over-complicated and hard-to-match +RULE LHS. It's all a bit silly, because the implication constraint is /identical/; +we just need to spot it. + +This came up while implementing GHC proposal 493 (allowing expresions in +SPECIALISE pragmas). +-} + +-- | Solve a quantified constraint that came from @CNonCanonical@ (which means +-- that superclasses have not yet been expanded). +-- +-- Precondition: the constraint has already been rewritten by the inert set. +solveForAllNC :: CtEvidence -> [TcTyVar] -> TcThetaType -> TcPredType + -> SolverStage Void +solveForAllNC ev tvs theta body_pred + = do { fuel <- simpleStage mk_super_classes + ; solveForAll (QCI { qci_ev = ev, qci_tvs = tvs, qci_theta = theta + , qci_body = body_pred, qci_pend_sc = fuel }) } + + where + mk_super_classes :: TcS ExpansionFuel + mk_super_classes + | Just (cls,tys) <- getClassPredTys_maybe body_pred + , classHasSCs cls + = do { dflags <- getDynFlags + -- Either expand superclasses (Givens) or provide fuel to do so (Wanteds) + ; if isGiven ev + then + -- See Note [Eagerly expand given superclasses] + -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + do { sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys + ; emitWork (listToBag sc_cts) + ; return doNotExpand } + else + -- See invariants (a) and (b) in QCI.qci_pend_sc + -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + -- See Note [Quantified constraints] + return (qcsFuel dflags) + } + + | otherwise + = return doNotExpand + +-- | Solve a canonical quantified constraint. +-- +-- Precondition: the constraint has already been rewritten by the inert set. +solveForAll :: QCInst -> SolverStage Void +solveForAll qci@(QCI { qci_ev = ev }) + = case ev of + CtGiven {} -> + -- See Note [Solving a Given forall-constraint] + do { simpleStage (addInertQCI qci) + ; stopWithStage ev "Given forall-constraint" } + CtWanted {} -> + -- See Note [Solving a Wanted forall-constraint] + do { tryInertQCs qci + ; simpleStage (addInertQCI qci) + ; stopWithStage ev "Wanted forall-constraint" } + +tryInertQCs :: QCInst -> SolverStage () +tryInertQCs qc + = Stage $ + do { inerts <- getInertCans + ; try_inert_qcs qc (inert_qcis inerts) } + +try_inert_qcs :: QCInst -> [QCInst] -> TcS (StopOrContinue ()) +try_inert_qcs (QCI { qci_ev = ev_w }) inerts = + case mapMaybe matching_inert inerts of + [] -> do { traceTcS "tryInertQCs:nothing" (ppr ev_w $$ ppr inerts) + ; continueWith () } + ev_i:_ -> + do { traceTcS "tryInertQCs:KeepInert" (ppr ev_i) + ; setEvBindIfWanted ev_w EvCanonical (ctEvTerm ev_i) + ; stopWith ev_w "Solved Wanted forall-constraint from inert" } + where + matching_inert (QCI { qci_ev = ev_i }) + | ctEvPred ev_i `tcEqType` ctEvPred ev_w + = Just ev_i + | otherwise + = Nothing + +solveWantedQCIs :: Cts -> TcS (Cts, Bag Implication) +solveWantedQCIs wanteds + = do { mode <- getTcSMode + ; bag_of_eithers <- mapBagM (solveWantedQCI mode) wanteds + -- bag_of_eithers :: Bag (Either Ct Implication) + ; return (partitionBagWith id bag_of_eithers) } + +solveWantedQCI :: TcSMode + -> Ct -- Definitely a Wanted + -> TcS (Either Ct Implication) +-- Try to solve a quantified constraint, `ct` +-- Returns +-- (Left ct) if `ct` is not a quantified constraint +-- (Right implic) if we can solve a quantified constraint `ct` by creating +-- an implication and fully or partly solving it +-- (Left ct) for a quantified constraint that can't be /fully solved/, +-- but mode is tcsmFullySolveQCIs +-- See Note [Solving a Wanted forall-constraint] +solveWantedQCI mode ct@(CQuantCan (QCI { qci_ev = ev, qci_tvs = tvs + , qci_theta = theta, qci_body = body_pred })) + | CtWanted (WantedCt { ctev_pred = forall_pred, ctev_dest = dest + , ctev_rewriters = rewriters, ctev_loc = loc }) <- ev + , let is_qc = IsQC forall_pred (ctLocOrigin loc) + empty_subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfTypes (body_pred:theta) `delVarSetList` tvs + = TcS.setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $ + -- This setSrcSpan is important: the TcM.newImplication uses that + -- TcLclEnv for the implication, and that in turn sets the location + -- for the Givens when solving the constraint (#21006) + do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + -- Very like the code in tcSkolDFunType + ; rec { skol_info <- mkSkolemInfo skol_info_anon + ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs + ; let inst_pred = substTy subst body_pred + inst_theta = substTheta subst theta + skol_info_anon = InstSkol is_qc (pSizeHead inst_pred) } + + ; given_ev_vars <- mapM TcS.newEvVar inst_theta + ; (lvl, wanted_ev) + <- pushLevelNoWorkList (ppr skol_info) $ + do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc) + -- Set the thing to prove to have a ScOrigin, so we are + -- careful about its termination checks. + -- See (QC-INV) in Note [Solving a Wanted forall-constraint] + ; newWantedNC loc' rewriters inst_pred } + + ; ev_binds_var <- TcS.newTcEvBinds + ; let imp :: Implication + imp = (implicationPrototype (ctLocEnv loc)) + { ic_tclvl = lvl + , ic_skols = skol_tvs + , ic_given = given_ev_vars + , ic_wanted = mkSimpleWC [CtWanted wanted_ev] + , ic_binds = ev_binds_var + , ic_warn_inaccessible = False + , ic_info = skol_info_anon } + + ; imp' <- solveImplication imp + + + ; if | tcsmFullySolveQCIs mode + , not (isSolvedStatus (ic_status imp')) + -> -- Not fully solved, but mode says that we must fully + -- solve quantified constraints; so abandon the attempt + -- See (WFA4) in Note [Solving a Wanted forall-constraint] + return (Left ct) + + | otherwise + -> -- Commit to the (partly or fully solved) implication + -- See (WFA5) in Note [Solving a Wanted forall-constraint] + -- Record evidence and return residual implication + -- NB: even if it is fully solved we must return it, because it is + -- carrying a record of which evidence variables are used + -- See Note [Free vars of EvFun] in GHC.Tc.Types.Evidence + do { setWantedEvTerm dest EvCanonical $ + EvFun { et_tvs = skol_tvs, et_given = given_ev_vars + , et_binds = TcEvBinds ev_binds_var + , et_body = wantedCtEvEvId wanted_ev } + + ; return (Right imp') } + } + + | otherwise -- A Given QCInst + = pprPanic "wantedQciToImplic: found a Given QCI" (ppr ct) + +-- No-op on all Ct's other than CQuantCan +solveWantedQCI _ ct = return (Left ct) + + +{- +************************************************************************ +* * + Evidence transformation +* * +************************************************************************ +-} + +rewriteEvidence :: CtEvidence -> SolverStage CtEvidence +-- (rewriteEvidence old_ev new_pred co do_next) +-- Main purpose: create new evidence for new_pred; +-- unless new_pred is cached already +-- * Calls do_next with (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 +-- * Stops if new_ev is already cached +-- +-- Old evidence New predicate is Return new evidence +-- flavour of same flavor +-- ------------------------------------------------------------------- +-- Wanted Already solved or in inert Stop +-- Not do_next new_evidence +-- +-- Given Already in inert Stop +-- Not do_next new_evidence + +{- Note [Rewriting with Refl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the coercion is just reflexivity then you may re-use the same +evidence variable. But be careful! Although the coercion is Refl, new_pred +may reflect the result of unification alpha := ty, so new_pred might +not _look_ the same as old_pred, and it's vital to proceed from now on +using new_pred. + +The rewriter preserves type synonyms, so they should appear in new_pred +as well as in old_pred; that is important for good error messages. + +If we are rewriting with Refl, then there are no new rewriters to add to +the rewriter set. We check this with an assertion. + -} + + +rewriteEvidence ev + = Stage $ do { traceTcS "rewriteEvidence" (ppr ev) + ; (redn, rewriters) <- rewrite ev (ctEvPred ev) + ; finish_rewrite ev redn rewriters } + +finish_rewrite :: CtEvidence -- ^ old evidence + -> Reduction -- ^ new predicate + coercion, of type ~ new predicate + -> RewriterSet -- ^ See Note [Wanteds rewrite Wanteds] + -- in GHC.Tc.Types.Constraint + -> TcS (StopOrContinue CtEvidence) +finish_rewrite old_ev (Reduction co new_pred) rewriters + | isReflCo co -- See Note [Rewriting with Refl] + = assert (isEmptyRewriterSet rewriters) $ + continueWith (setCtEvPredType old_ev new_pred) + +finish_rewrite + ev@(CtGiven (GivenCt { ctev_evar = old_evar })) + (Reduction co new_pred) + rewriters + = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted + do { let loc = ctEvLoc ev + -- mkEvCast optimises ReflCo + ev_rw_role = ctEvRewriteRole ev + new_tm = assert (coercionRole co == ev_rw_role) + evCast (evId old_evar) $ -- evCast optimises ReflCo + downgradeRole Representational ev_rw_role co + ; new_ev <- newGivenEvVar loc (new_pred, new_tm) + ; continueWith $ CtGiven new_ev } + +finish_rewrite + ev@(CtWanted (WantedCt { ctev_rewriters = rewriters, ctev_dest = dest })) + (Reduction co new_pred) + new_rewriters + = do { let loc = ctEvLoc ev + rewriters' = rewriters S.<> new_rewriters + ev_rw_role = ctEvRewriteRole ev + ; mb_new_ev <- newWanted loc rewriters' new_pred + ; massert (coercionRole co == ev_rw_role) + ; setWantedEvTerm dest EvCanonical $ + evCast (getEvExpr mb_new_ev) $ + downgradeRole Representational ev_rw_role (mkSymCo co) + ; case mb_new_ev of + Fresh new_ev -> continueWith $ CtWanted new_ev + Cached _ -> stopWith ev "Cached wanted" } + +{- ******************************************************************* +* * +* Typechecker plugins +* * +******************************************************************* -} + +-- | Extract the (inert) givens and invoke the plugins on them. +-- Remove solved givens from the inert set and emit insolubles, but +-- return new work produced so that 'solveSimpleGivens' can feed it back +-- into the main solver. +runTcPluginsGiven :: TcS [Ct] +runTcPluginsGiven + = do { solvers <- getTcPluginSolvers + ; if null solvers then return [] else + do { givens <- getInertGivens + ; if null givens then return [] else + do { traceTcS "runTcPluginsGiven {" (ppr givens) + ; p <- runTcPluginSolvers solvers (givens,[]) + ; let (solved_givens, _) = pluginSolvedCts p + insols = map (ctIrredCt PluginReason) (pluginBadCts p) + ; updInertCans (removeInertCts solved_givens . + updIrreds (addIrreds insols) ) + ; traceTcS "runTcPluginsGiven }" $ + vcat [ text "solved_givens:" <+> ppr solved_givens + , text "insols:" <+> ppr insols + , text "new:" <+> ppr (pluginNewCts p) ] + ; return (pluginNewCts p) } } } + +-- | Given a bag of (rewritten, zonked) wanteds, invoke the plugins on +-- them and produce an updated bag of wanteds (possibly with some new +-- work) and a bag of insolubles. The boolean indicates whether +-- 'solveSimpleWanteds' should feed the updated wanteds back into the +-- main solver. +runTcPluginsWanted :: Cts -> TcS (Bool, Cts) +runTcPluginsWanted wanted + | isEmptyBag wanted + = return (False, wanted) + | otherwise + = do { solvers <- getTcPluginSolvers + ; if null solvers then return (False, wanted) else + + do { -- Find the set of Givens to give to the plugin. + given <- getInertGivens + + -- Plugin requires zonked input wanteds + ; zonked_wanted <- TcS.zonkSimples wanted + + ; traceTcS "Running plugins {" (vcat [ text "Given:" <+> ppr given + , text "Wanted:" <+> ppr zonked_wanted ]) + ; p <- runTcPluginSolvers solvers (given, bagToList zonked_wanted) + ; let (_, solved_wanted) = pluginSolvedCts p + (_, unsolved_wanted) = pluginInputCts p + new_wanted = pluginNewCts p + insols = pluginBadCts p + all_new_wanted = listToBag new_wanted `andCts` + listToBag unsolved_wanted `andCts` + listToBag insols + + ; mapM_ setEv solved_wanted + + ; traceTcS "Finished plugins }" (ppr new_wanted) + ; return ( notNull (pluginNewCts p), all_new_wanted ) } } + where + setEv :: (EvTerm,Ct) -> TcS () + setEv (ev,ct) = case ctEvidence ct of + CtWanted (WantedCt { ctev_dest = dest }) -> setWantedEvTerm dest EvCanonical ev + -- TODO: plugins should be able to signal non-canonicity + _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" + +-- | A pair of (given, wanted) constraints to pass to plugins +type SplitCts = ([Ct], [Ct]) + +-- | A solved pair of constraints, with evidence for wanteds +type SolvedCts = ([Ct], [(EvTerm,Ct)]) + +-- | Represents collections of constraints generated by typechecker +-- plugins +data TcPluginProgress = TcPluginProgress + { pluginInputCts :: SplitCts + -- ^ Original inputs to the plugins with solved/bad constraints + -- removed, but otherwise unmodified + , pluginSolvedCts :: SolvedCts + -- ^ Constraints solved by plugins + , pluginBadCts :: [Ct] + -- ^ Constraints reported as insoluble by plugins + , pluginNewCts :: [Ct] + -- ^ New constraints emitted by plugins + } + +getTcPluginSolvers :: TcS [TcPluginSolver] +getTcPluginSolvers + = do { tcg_env <- TcS.getGblEnv; return (tcg_tc_plugin_solvers tcg_env) } + +-- | Starting from a pair of (given, wanted) constraints, +-- invoke each of the typechecker constraint-solving plugins in turn and return +-- +-- * the remaining unmodified constraints, +-- * constraints that have been solved, +-- * constraints that are insoluble, and +-- * new work. +-- +-- Note that new work generated by one plugin will not be seen by +-- other plugins on this pass (but the main constraint solver will be +-- re-invoked and they will see it later). There is no check that new +-- work differs from the original constraints supplied to the plugin: +-- the plugin itself should perform this check if necessary. +runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress +runTcPluginSolvers solvers all_cts + = do { ev_binds_var <- getTcEvBindsVar + ; foldM (do_plugin ev_binds_var) initialProgress solvers } + where + do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress + do_plugin ev_binds_var p solver = do + result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p)) + return $ progress p result + + progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress + progress p + (TcPluginSolveResult + { tcPluginInsolubleCts = bad_cts + , tcPluginSolvedCts = solved_cts + , tcPluginNewCts = new_cts + } + ) = + p { pluginInputCts = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p) + , pluginSolvedCts = add solved_cts (pluginSolvedCts p) + , pluginNewCts = new_cts ++ pluginNewCts p + , pluginBadCts = bad_cts ++ pluginBadCts p + } + + initialProgress = TcPluginProgress all_cts ([], []) [] [] + + discard :: [Ct] -> SplitCts -> SplitCts + discard cts (xs, ys) = + (xs `without` cts, ys `without` cts) + + without :: [Ct] -> [Ct] -> [Ct] + without = deleteFirstsBy eq_ct + + eq_ct :: Ct -> Ct -> Bool + eq_ct c c' = ctFlavour c == ctFlavour c' + && ctPred c `tcEqType` ctPred c' + + add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts + add xs scs = foldl' addOne scs xs + + addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts + addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of + CtGiven {} -> (ct:givens, wanteds) + CtWanted {} -> (givens, (ev,ct):wanteds) diff --git a/GHC/Tc/Solver/Solve.hs-boot b/GHC/Tc/Solver/Solve.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Solve.hs-boot @@ -0,0 +1,8 @@ +module GHC.Tc.Solver.Solve where + +import Prelude( Bool ) +import GHC.Tc.Solver.Monad( TcS ) +import GHC.Tc.Types.Constraint( Cts, Implication, WantedConstraints ) + +solveSimpleWanteds :: Cts -> TcS WantedConstraints +trySolveImplication :: Implication -> TcS Bool diff --git a/GHC/Tc/Solver/Types.hs b/GHC/Tc/Solver/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Types.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} + +-- | Utility types used within the constraint solver +module GHC.Tc.Solver.Types ( + -- Inert CDictCans + DictMap, emptyDictMap, + findDictsByTyConKey, findDictsByClass, + foldDicts, findDict, + dictsToBag, + + FunEqMap, emptyFunEqs, findFunEq, insertFunEq, + findFunEqsByTyCon, + + TcAppMap, emptyTcAppMap, isEmptyTcAppMap, + insertTcApp, alterTcApp, filterTcAppMap, + mapMaybeTcAppMap, + tcAppMapToBag, foldTcAppMap, delTcApp, + + EqualCtList, filterEqualCtList, addToEqualCtList + + ) where + +import GHC.Prelude + +import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.TcType + +import GHC.Types.Unique +import GHC.Types.Unique.DFM + +import GHC.Core.Class +import GHC.Core.Map.Type +import GHC.Core.TyCon +import GHC.Core.TyCon.Env + +import GHC.Data.Bag +import GHC.Data.Maybe +import GHC.Data.TrieMap +import GHC.Utils.Constants +import GHC.Utils.Outputable +import GHC.Utils.Panic + +{- ********************************************************************* +* * + 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 + +mapMaybeTcAppMap :: forall a b. (a -> Maybe b) -> TcAppMap a -> TcAppMap b +mapMaybeTcAppMap f m = mapMaybeDTyConEnv one_tycon m + where + one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap b) + one_tycon tm + | isEmptyTM mapped_tm = Nothing + | otherwise = Just mapped_tm + where + mapped_tm = mapMaybeTM f tm + +tcAppMapToBag :: TcAppMap a -> Bag a +tcAppMapToBag m = foldTcAppMap consBag m emptyBag + +foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b +foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m + +{- ********************************************************************* +* * + DictMap +* * +********************************************************************* -} + +type DictMap a = TcAppMap a + +emptyDictMap :: DictMap a +emptyDictMap = emptyTcAppMap + +findDict :: DictMap a -> Class -> [Type] -> Maybe a +findDict m cls tys + = findTcApp m (classTyCon cls) tys + +findDictsByClass :: DictMap a -> Class -> Bag a +findDictsByClass m cls = findDictsByTyConKey m (getUnique $ classTyCon cls) + +findDictsByTyConKey :: DictMap a -> Unique -> Bag a +findDictsByTyConKey m tc + | Just tm <- lookupUDFM_Directly m tc = foldTM consBag tm emptyBag + | otherwise = emptyBag + +dictsToBag :: DictMap a -> Bag a +dictsToBag = tcAppMapToBag + +foldDicts :: (a -> b -> b) -> DictMap a -> b -> b +foldDicts = foldTcAppMap + +{- ********************************************************************* +* * + FunEqMap +* * +********************************************************************* -} + +type FunEqMap a = TcAppMap a -- A map whose key is a (TyCon, [Type]) pair + +emptyFunEqs :: TcAppMap a +emptyFunEqs = emptyTcAppMap + +findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a +findFunEq m tc tys = findTcApp m tc tys + +findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] +-- Get inert function equation constraints that have the given tycon +-- in their head. Not that the constraints remain in the inert set. +-- We use this to check for wanted interactions with built-in type-function +-- constructors. +findFunEqsByTyCon m tc + | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm [] + | otherwise = [] + +insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a +insertFunEq m tc tys val = insertTcApp m tc tys val + + +{- ********************************************************************* +* * + EqualCtList +* * +********************************************************************* -} + +{- +Note [EqualCtList invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * All are equalities + * All these equalities have the same LHS + * No element of the list can rewrite any other + +Accordingly, this list is either empty, contains one element, or +contains a Given representational equality and a Wanted nominal one. +-} + +type EqualCtList = [EqCt] + -- See Note [EqualCtList invariants] + +addToEqualCtList :: EqCt -> EqualCtList -> EqualCtList +-- See Note [EqualCtList invariants] +addToEqualCtList ct old_eqs + | debugIsOn + = case ct of + EqCt { eq_lhs = TyVarLHS tv } -> + assert (all (shares_lhs tv) old_eqs) $ + assertPpr (null bad_prs) + (vcat [ text "bad_prs" <+> ppr bad_prs + , text "ct:old_eqs" <+> ppr (ct : old_eqs) ]) $ + (ct : old_eqs) + + _ -> pprPanic "addToEqualCtList not CEqCan" (ppr ct) + + | otherwise + = ct : old_eqs + where + shares_lhs tv (EqCt { eq_lhs = TyVarLHS old_tv }) = tv == old_tv + shares_lhs _ _ = False + bad_prs = filter is_bad_pair (distinctPairs (ct : old_eqs)) + is_bad_pair :: (EqCt, EqCt) -> Bool + is_bad_pair (ct1,ct2) = eqCtFlavourRole ct1 `eqCanRewriteFR` eqCtFlavourRole ct2 + +distinctPairs :: [a] -> [(a,a)] +-- distinctPairs [x1,...xn] is the list of all pairs [ ...(xi, xj)...] +-- where i /= j +-- NB: does not return pairs (xi,xi), which would be stupid in the +-- context of addToEqualCtList (#22645) +distinctPairs [] = [] +distinctPairs (x:xs) = concatMap (\y -> [(x,y),(y,x)]) xs ++ distinctPairs xs + +-- returns Nothing when the new list is empty, to keep the environments smaller +filterEqualCtList :: (EqCt -> Bool) -> EqualCtList -> Maybe EqualCtList +filterEqualCtList pred cts + | null new_list + = Nothing + | otherwise + = Just new_list + where + new_list = filter pred cts diff --git a/GHC/Tc/TyCl.hs b/GHC/Tc/TyCl.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl.hs @@ -0,0 +1,5922 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections, ScopedTypeVariables, MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} + +-- | Typecheck type and class declarations +module GHC.Tc.TyCl ( + tcTyAndClassDecls, + + -- Functions used by GHC.Tc.TyCl.Instance to check + -- data/type family instance declarations + kcConDecls, tcConDecls, DataDeclInfo(..), + dataDeclChecks, checkValidTyCon, + tcFamTyPats, tcTyFamInstEqn, + tcAddOpenTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, + unravelFamInstPats, addConsistencyConstraints, + checkFamTelescope, + + -- Used by GHC.HsToCore.Quote + IsPrefixConGADT(..), unannotatedMultIsLinear + ) where + +import GHC.Prelude + +import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Driver.Config.HsToCore + +import GHC.Hs + +import GHC.Tc.Errors.Types +import GHC.Tc.TyCl.Build +import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX + , reportUnsolvedEqualities ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Unify( unifyType, emitResidualTvConstraint ) +import GHC.Tc.Types.Constraint( emptyWC ) +import GHC.Tc.Validity +import GHC.Tc.Zonk.Type +import GHC.Tc.Zonk.TcType +import GHC.Tc.TyCl.Utils +import GHC.Tc.TyCl.Class +import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 ) +import {-# SOURCE #-} GHC.Tc.Module( checkBootDeclM ) +import GHC.Tc.Deriv (DerivInfo(..)) +import GHC.Tc.Gen.HsType +import GHC.Tc.Instance.Class( AssocInstInfo(..) ) +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Instance.Family +import GHC.Tc.Types.ErrCtxt ( TyConInstFlavour(..) ) +import GHC.Tc.Types.LclEnv +import GHC.Tc.Types.Origin + +import GHC.Builtin.Types ( oneDataConTy, unitTy, makeRecoveryTyCon, manyDataConTy ) + +import GHC.Rename.Env( lookupConstructorFields ) + +import GHC.Core.Multiplicity +import GHC.Core.FamInstEnv ( mkBranchedCoAxiom, mkCoAxBranch ) +import GHC.Core.Coercion +import GHC.Core.Type +import GHC.Core.TyCo.Rep -- for checkValidRoles +import GHC.Core.TyCo.Ppr( pprTyVars ) +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Unify + +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import GHC.Types.TypeEnv +import GHC.Types.Unique +import GHC.Types.Basic +import GHC.Types.Error +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.List.SetOps( minusList, equivClasses ) +import GHC.Data.OrdList + +import GHC.Unit +import GHC.Unit.Module.ModDetails + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.Monad +import Data.Foldable ( toList, traverse_ ) +import Data.Functor.Identity +import Data.List ( partition) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.Traversable ( for ) +import Data.Tuple( swap ) +import qualified Data.Semigroup as S + +{- +************************************************************************ +* * +\subsection{Type checking for type and class declarations} +* * +************************************************************************ + +Note [Grouping of type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly +connected component of mutually dependent types and classes. We kind check and +type check each group separately to enhance kind polymorphism. Take the +following example: + + type Id a = a + data X = X (Id Int) + +If we were to kind check the two declarations together, we would give Id the +kind * -> *, since we apply it to an Int in the definition of X. But we can do +better than that, since Id really is kind polymorphic, and should get kind +forall (k::*). k -> k. Since it does not depend on anything else, it can be +kind-checked by itself, hence getting the most general kind. We then kind check +X, which works fine because we then know the polymorphic kind of Id, and simply +instantiate k to *. + +Note [Check role annotations in a second pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Role inference potentially depends on the types of all of the datacons declared +in a mutually recursive group. The validity of a role annotation, in turn, +depends on the result of role inference. Because the types of datacons might +be ill-formed (see #7175 and Note [rejigConRes]) we must check +*all* the tycons in a group for validity before checking *any* of the roles. +Thus, we take two passes over the resulting tycons, first checking for general +validity and then checking for valid role annotations. + +Note [Retrying TyClGroups] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +After renaming type, class, and instance declarations in a module (or, to be +more precise, in an HsGroup), GHC.Rename.Module.rnTyClDecls does dependency +analysis on the renamed declarations and returns a topologically sorted list +of SCCs, each SCC represented by one TyClGroup. + +If the dependency analysis were complete, i.e. if it were able to discover all +dependencies between all declarations, then tcTyAndClassDecls could simply +kind-check TyClGroups in order. Unfortunately, this is not the case, because +dependencies come in two varieties: + +* Lexical dependencies arise when X mentions Y by name: + + data X (a :: Y) = MkX -- depends on Y + data Y = MkY + +* Non-lexical dependencies arise when an instance must be in the + typing environment: + + type family F x + data X (a :: F Int) = MkX a -- depends on (F Int ~ Type) + type instance F x = Type + +Non-lexical dependencies can't be discovered by looking at the free variables of +a declaration (attempts to find a good heuristic did not bear fruit, see the +long discussion at #12088 and the linked Wiki pages). As a consequence, the +order of SCCs (i.e. TyClGroups) coming out of the renamer is determined solely +by lexical dependencies. + +In other words, the TyClGroups are in /lexical dependency order/, meaning: +- definitely in dependency order if all dependencies are lexical +- possibly not in dependency order if there are non-lexical dependencies + +Here are some examples how type checking declarations might go wrong due to +non-lexical dependencies: + +* Consider (#11348) + + type family F a + type instance F Int = Bool + + data R = MkR (F Int) + + type Foo = 'MkR 'True + + For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't + know that unless we've looked at the type instance declaration for F + before kind-checking Foo. + +* Things become more complicated when we introduce transitive + dependencies through imported definitions, like in this scenario: + + A.hs + type family Closed (t :: Type) :: Type where + Closed t = Open t + + type family Open (t :: Type) :: Type + + B.hs + data Q where + Q :: Closed Bool -> Q + + type instance Open Int = Bool + + type S = 'Q 'True + + Somehow, we must ensure that the instance Open Int = Bool is checked before + the type synonym S. While we know that S depends upon 'Q depends upon Closed, + we have no idea that Closed depends upon Open! + +* Another example is this (#3990). + + data family Complex a + data instance Complex Double = CD {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + + data T = T {-# UNPACK #-} !(Complex Double) + + Here, to generate the right kind of unpacked implementation for T, + we must have access to the 'data instance' declaration. + +To accommodate for these situations, tcTyAndClassDecls discovers the correct +kind-checking order by trial and error. + +The algorithm works as follows: + +1. (in rnTyClDecls) + Perform the SCC analysis on declarations without instances and considering + lexical dependencies only. The result is a topologically sorted list of SCCs. + See Note [Dependency analysis of type and class decls] in GHC.Rename.Module + +2. (in rnTyClDecls) + Create one singleton "SCC" per instance and put them at the end. + See Note [Put instances at the end] in GHC.Rename.Module + +3. (in tcTyAndClassDecls) + Check all SCCs in order, skipping any that are blocked (FVs not in env), + flawed (unusable unpack pragmas), or fail (type errors) + (3a) if none were skipped, we are done + (3b) if all were skipped and none are flawed, we are stuck; + report errors and exit (tcFailedTyClGroups) + (3c) if all were skipped and some are flawed, redo the pass + allowing flawed SCCs (tcTyClGroupsPass.go with strict=False) + (3d) if some were skipped and some weren't, we've made progress; iterate + +In the common case of lexical dependencies only, the algorithm is linear in the +number of groups: it completes in one pass if the program is kind-correct, or +two passes if there are kind errors. + +In the less common case of non-lexical dependencies, the algorithm is worst-case +quadratic in the number of groups: if each pass manages to check only one group, +we end up doing a pass per group. + +Now, regarding the "flawed" groups. These are the ones where the programmer used +the {-# UNPACK #-} pragma on a field, yet we could not unpack (#3990) + +* One possible reason for this is that we lack a data instance in the + environment that would allow for the field to be unpacked, so it is beneficial + to treat this like a kind error: skip the flawed group and retry it in a later + pass, when we might have more data instances in the env. + +* However, if the /only/ reason a pass gets stuck is due to flawed groups, + then we can make progress by treating unpacking failure is a warning. + +This way we maximize unpacking with explicit {-# UNPACK #-} pragmas. +Unfortunately, it does not help with -funbox-strict-fields. +See Note [Flaky -funbox-strict-fields with type/data families] + +Later we might check TyClGroups for other "flaws", but for now the property is +just about unusable unpack pragmas. + +Finally, a short comment on why it is necessary to check whether a group is +ready (FVs in the env) or blocked (FVs not in the env) using isReadyTyClGroup. +One might expect this check to be redundant, as the TyClGroups come in lexical +dependency order. However, as soon as we skip a group, the rest of the pass can +no longer rely on this property, hence the check. It is rare to encounter this +problem in a kind-correct program, but see e.g. the T12088e test case. + +Note [Flaky -funbox-strict-fields with type/data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this program: + + {-# OPTIONS -funbox-strict-fields #-} + data family Complex a + data instance Complex Double = CD !Double !Double + data T = T !(Complex Double) -- does (Complex Double) get unpacked? + +Could we unpack T's field (Complex Double)? This depends on whether we have the +data instance in the environment. Prior GHC versions could handle this example, +but it was not reliable. A slightly more involved arrangement could throw it off +balance: + + {-# OPTIONS -funbox-strict-fields #-} + type family F a + data D1 = MkD1 !(F Int) -- does (F Int) get unpacked? + data D2 = MkD2 !Int !Int + type instance F Int = D2 + +Here, MkD1's field (F Int) would not get unpacked unless we used a top-level +splice to separate the module and force the desired order of kind-checking: + + {-# OPTIONS -funbox-strict-fields #-} + type family F a + data D2 = MkD2 !Int !Int + type instance F Int = D2 + $(return []) -- break the module into two sections + data D1 = MkD1 !(F Int) -- now (F Int) surely gets unpacked + +The current version of GHC is more predictable. Neither the (Complex Double) nor +the (F Int) example gets unpacking unless the type/data instance is put into a +separate HsGroup, either with $(return []) or by placing it in another module +altogether. This is a direct result of placing instances after the other SCCs, +as described in Note [Put instances at the end] in GHC.Rename.Module + +It is also possible to get the desired unpacking with an explicit {-# UNPACK #-} +pragma, as an unusable unpack pragma marks a TyClGroup "flawed", which means it +will be retried after more type/data instances are added to the typing +environment. See the algorithm in Note [Retrying TyClGroups]. +-} + +data TcTyClGroupsAccum = + TcTyClGroupsAccum + { ttcga_inst_info :: !(OrdList (InstInfo GhcRn)) -- ^ Source-code instance decls info + , ttcga_deriv_info :: !(OrdList DerivInfo) -- ^ Deriving info + , ttcga_th_bndrs :: !ThBindEnv -- ^ TH binding levels + } + +instance S.Semigroup TcTyClGroupsAccum where + (TcTyClGroupsAccum a1 b1 c1) <> (TcTyClGroupsAccum a2 b2 c2) = + TcTyClGroupsAccum (a1 S.<> a2) + (b1 S.<> b2) + (c1 S.<> c2) + +instance Monoid TcTyClGroupsAccum where + mempty = TcTyClGroupsAccum mempty mempty mempty + +tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in lexical dependency order + -> TcM ( TcGblEnv -- Input env extended by types and classes and their implicit Ids, DataCons + , [InstInfo GhcRn] -- Source-code instance decls info + , [DerivInfo] -- Deriving info + , ThBindEnv -- TH binding levels + ) +-- Fails if there are any errors +tcTyAndClassDecls tyclds_s + -- The code recovers internally, but if anything gave rise to + -- an error we'd better stop now, to avoid a cascade + -- Type check each group in dependency order folding the global env + = checkNoErrs $ go mempty tyclds_s + where + go :: TcTyClGroupsAccum + -> [TyClGroup GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) + go acc [] = do -- Case (3a) of the algorithm in Note [Retrying TyClGroups] + -- All good, we are done. + tcg_env <- getGblEnv + let inst_info = fromOL (ttcga_inst_info acc) + deriv_info = fromOL (ttcga_deriv_info acc) + th_bndrs = ttcga_th_bndrs acc + return (tcg_env, inst_info, deriv_info, th_bndrs) + go acc gs = + tcTyClGroupsPass gs $ \acc' n gs' -> + if n == 0 then + -- Case (3b) of the algorithm in Note [Retrying TyClGroups] + -- The pass made no progress. We are stuck. Report errors and exit. + tcFailedTyClGroups gs' + else + -- Case (3b) of the algorithm in Note [Retrying TyClGroups] + -- The pass made some progress. Iterate. + go (acc' S.<> acc) gs' + +-- Check the remaining TyClGroups that are known to fail, +-- extending the environment with fake tycons to report more errors. +-- See Note [Recover from validity error] +tcFailedTyClGroups :: [TyClGroup GhcRn] -> TcM a +tcFailedTyClGroups [] = failM +tcFailedTyClGroups (g:gs) = do + tcg_env <- getGblEnv + m_result <- + if isReadyTyClGroup tcg_env g + then attemptM (tcTyClGroup g) + else return Nothing + let tcg_env' = maybe tcg_env fst m_result + setGblEnv tcg_env' $ tcFailedTyClGroups gs + +-- Type check as many TyClGroups as possible, skipping any failures. +-- thing_inside runs in the extended environment. +tcTyClGroupsPass :: forall a. + [TyClGroup GhcRn] -- Mutually-recursive groups in lexical dependency order + -> (TcTyClGroupsAccum + -> Int -- Number of successfully checked groups + -> [TyClGroup GhcRn] -- Remaining groups in lexical dependency order + -> TcM a) + -> TcM a +tcTyClGroupsPass all_gs thing_inside = go True ttcgs_zero mempty nilOL all_gs + where + go :: Bool -- Strict pass, True <=> fail on unusable {-# UNPACK #-} + -> TcTyClGroupsStats + -> TcTyClGroupsAccum + -> OrdList (TyClGroup GhcRn) -- Skipped groups (accumulator) + -> [TyClGroup GhcRn] -- Groups to check + -> TcM a + go strict !stats acc skipped_gs [] + | strict, ttcgs_n_success stats == 0, ttcgs_n_flawed stats > 0 = do + -- Case (3b) of the algorithm in Note [Retrying TyClGroups] + -- The strict pass made no progress but found flawed groups; + -- now do a lax pass to allow them to succeed. + traceTc "tcTyClGroupsPass end of strict pass" (ppr stats) + go False ttcgs_zero acc nilOL (fromOL skipped_gs) + | otherwise = do + traceTc "tcTyClGroupsPass done" (ppr stats) + thing_inside acc (ttcgs_n_success stats) (fromOL skipped_gs) + go strict !stats acc skipped_gs (g:gs) = do + (stats', m_result) <- try_tc_group strict stats (null skipped_gs) g + case m_result of + Nothing -> + go strict stats' acc (skipped_gs `snocOL` g) gs + Just (tcg_env, acc') -> + setGblEnv tcg_env $ + go strict stats' (acc' S.<> acc) skipped_gs gs + + try_tc_group :: Bool -- Strict pass, True <=> fail on unusable {-# UNPACK #-} + -> TcTyClGroupsStats + -> Bool -- True <=> No groups skipped this pass (yet) + -> TyClGroup GhcRn + -> TcM (TcTyClGroupsStats, Maybe (TcGblEnv, TcTyClGroupsAccum)) + try_tc_group strict stats no_skipped g = do + tcg_env <- getGblEnv + let on_flawed = (ttcgs_inc_flawed stats, Nothing) + on_failed = (ttcgs_inc_failed stats, Nothing) + on_blocked = (ttcgs_inc_blocked stats, Nothing) + on_success r = (ttcgs_inc_success stats, Just r) + ready = no_skipped || isReadyTyClGroup tcg_env g + -- (no_skipped ||) is a shortcut: if no groups were skipped this + -- pass, the current group's lexical dependencies must have been + -- satisfied by the preceding groups; no need for the ready check, + -- this avoids some lookups in tcg_env + + -- See Note [Expedient use of diagnostics in tcTyClGroupsPass] + set_opts action + | strict = setWOptM Opt_WarnUnusableUnpackPragmas action + | otherwise = action + validate _ msgs _ + | strict = not (unpackErrorsFound msgs) + | otherwise = True + + if not ready then return on_blocked else + tryTcDiscardingErrs' validate + (return on_flawed) + (return on_failed) + (on_success <$> set_opts (tcTyClGroup g)) + +data TcTyClGroupsStats = + TcTyClGroupsStats + { ttcgs_n_success :: !Int -- ^ Number of successfully checked groups + , ttcgs_n_blocked :: !Int -- ^ Number of groups whose FVs are not in the env + , ttcgs_n_failed :: !Int -- ^ Number of groups that failed with an error + , ttcgs_n_flawed :: !Int -- ^ Number of groups that did not pass validation + } + +ttcgs_zero :: TcTyClGroupsStats +ttcgs_zero = TcTyClGroupsStats 0 0 0 0 + +ttcgs_inc_success, ttcgs_inc_blocked, ttcgs_inc_failed, ttcgs_inc_flawed :: TcTyClGroupsStats -> TcTyClGroupsStats +ttcgs_inc_success stats = stats { ttcgs_n_success = 1 + ttcgs_n_success stats } +ttcgs_inc_blocked stats = stats { ttcgs_n_blocked = 1 + ttcgs_n_blocked stats } +ttcgs_inc_failed stats = stats { ttcgs_n_failed = 1 + ttcgs_n_failed stats } +ttcgs_inc_flawed stats = stats { ttcgs_n_flawed = 1 + ttcgs_n_flawed stats } + +instance Outputable TcTyClGroupsStats where + ppr stats = + vcat [ text "n_success =" <+> ppr (ttcgs_n_success stats) + , text "n_blocked =" <+> ppr (ttcgs_n_blocked stats) + , text "n_failed =" <+> ppr (ttcgs_n_failed stats) + , text "n_flawed =" <+> ppr (ttcgs_n_flawed stats) ] + +-- See Note [Expedient use of diagnostics in tcTyClGroupsPass] +unpackErrorsFound :: Messages TcRnMessage -> Bool +unpackErrorsFound = any is_unpack_error + where + is_unpack_error :: TcRnMessage -> Bool + is_unpack_error (TcRnMessageWithInfo _ (TcRnMessageDetailed _ msg)) = is_unpack_error msg + is_unpack_error (TcRnWithHsDocContext _ msg) = is_unpack_error msg + is_unpack_error (TcRnBadFieldAnnotation _ _ UnusableUnpackPragma) = True + is_unpack_error _ = False + +{- Note [Expedient use of diagnostics in tcTyClGroupsPass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In tcTyClGroupsPass.go with strict=True, we want to skip "flawed" groups, i.e. +groups with unusable unpack pragmas, as explained in Note [Retrying TyClGroups]. +To detect these unusable {-# UNPACK #-} pragmas, we currently piggy-back on the +diagnostics infrastructure: + + 1. (setWOptM Opt_WarnUnusableUnpackPragmas) to enable the warning. + The warning is on by default, but the user may have disabled it with + -Wno-unusable-unpack-pragmas, in which case we need to turn it back on. + + 2. (unpackErrorsFound msgs) to check if UnusableUnpackPragma is one of the + collected diagnostics. This is somewhat unpleasant because of the need to + recurse into TcRnMessageWithInfo and TcRnWithHsDocContext. + +Arguably, this is not a principled solution, because diagnostics are meant for +the user and here we inspect them to determine the order of type-checking. The +only reason for the current setup is that it was the easy thing to do. +-} + +isReadyTyClGroup :: TcGblEnv -> TyClGroup GhcRn -> Bool +isReadyTyClGroup tcg_env TyClGroup{group_ext = deps} = + nameSetAll (\n -> n `elemNameEnv` tcg_type_env tcg_env) deps + +tcTyClGroup :: TyClGroup GhcRn + -> TcM (TcGblEnv, TcTyClGroupsAccum) +-- Typecheck one strongly-connected component of type, class, and instance decls +-- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls +tcTyClGroup (TyClGroup { group_tyclds = tyclds + , group_roles = roles + , group_kisigs = kisigs + , group_instds = instds }) + = do { let role_annots = mkRoleAnnotEnv roles + + -- Step 1: Typecheck the standalone kind signatures and type/class declarations + ; traceTc "---- tcTyClGroup ---- {" empty + ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds)) + ; (tyclss_with_validity_infos, data_deriv_info, kindless) <- + tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] + do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs + ; tcTyClDecls tyclds kisig_env role_annots } + ; let tyclss = map fst tyclss_with_validity_infos + -- Step 1.5: Make sure we don't have any type synonym cycles + + ; traceTc "Starting synonym cycle check" (ppr tyclss) + ; home_unit <- hsc_home_unit <$> getTopEnv + ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds + ; traceTc "Done synonym cycle check" (ppr tyclss) + + -- Step 2: Perform the validity check on those types/classes + -- We can do this now because we are done with the recursive knot + -- Do it before Step 3 (adding implicit things) because the latter + -- expects well-formed TyCons + ; traceTc "Starting validity check" (ppr tyclss) + ; tyclss <- tcExtendTyConEnv tyclss $ + -- NB: put the TyCons in the environment for validity checking, + -- as we might look them up in checkTyConConsistentWithBoot. + -- See Note [TyCon boot consistency checking]. + fmap concat . for tyclss_with_validity_infos $ \ (tycls, ax_validity_infos) -> + do { let inst_flav = + TyConInstFlavour + { tyConInstFlavour = tyConFlavour tycls + , tyConInstIsDefault = False + } + ; tcAddFamInstCtxt inst_flav (tyConName tycls) $ + addErrCtxt (ClosedFamEqnCtxt tycls) $ + mapM_ (checkTyFamEqnValidityInfo tycls) ax_validity_infos + ; checkValidTyCl tycls } + + ; traceTc "Done validity check" (ppr tyclss) + ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss + -- See Note [Check role annotations in a second pass] + + ; traceTc "---- end tcTyClGroup ---- }" empty + + -- Step 3: Add the implicit things; + -- we want them in the environment because + -- they may be mentioned in interface files + ; (gbl_env, th_bndrs) <- addTyConsToGblEnv tyclss + + -- Step 4: check instance declarations + ; (gbl_env', inst_info, datafam_deriv_info, th_bndrs') <- + setGblEnv gbl_env $ + tcInstDecls1 instds + + ; let deriv_info = datafam_deriv_info ++ data_deriv_info + ; let gbl_env'' = gbl_env' + { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless } + ; let acc = TcTyClGroupsAccum{ ttcga_inst_info = toOL inst_info + , ttcga_deriv_info = toOL deriv_info + , ttcga_th_bndrs = th_bndrs' `plusNameEnv` th_bndrs } + ; return (gbl_env'', acc) } + +-- Gives the kind for every TyCon that has a standalone kind signature +type KindSigEnv = NameEnv Kind + +tcTyClDecls + :: [LTyClDecl GhcRn] + -> KindSigEnv + -> RoleAnnotEnv + -> TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet) +tcTyClDecls tyclds kisig_env role_annots + = do { -- Step 1: kind-check this group and returns the final + -- (possibly-polymorphic) kind of each TyCon and Class + -- See Note [Kind checking for type and class decls] + (tc_tycons, kindless) <- checkNoErrs $ + kcTyClGroup kisig_env tyclds + -- checkNoErrs: If the TyCons are ill-kinded, stop now. Else we + -- can get follow-on errors. Example: #23252, where the TyCon + -- had an ill-scoped kind forall (d::k) k (a::k). blah + -- and that ill-scoped kind made role inference fall over. + + ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons)) + + -- Step 2: type-check all groups together, returning + -- the final TyCons and Classes + -- + -- NB: We have to be careful here to NOT eagerly unfold + -- type synonyms, as we have not tested for type synonym + -- loops yet and could fall into a black hole. + ; fixM $ \ ~(rec_tyclss_with_validity_infos, _, _) -> do + { tcg_env <- getGblEnv + -- Forced so we don't retain a reference to the TcGblEnv + ; let !src = tcg_src tcg_env + rec_tyclss = map fst rec_tyclss_with_validity_infos + roles = inferRoles src role_annots rec_tyclss + + -- Populate environment with knot-tied ATyCon for TyCons + -- NB: if the decls mention any ill-staged data cons + -- (see Note [Recursion and promoting data constructors]) + -- we will have failed already in kcTyClGroup, so no worries here + ; (tycons, data_deriv_infos) <- + tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $ + + -- Also extend the local type envt with bindings giving + -- a TcTyCon for each knot-tied TyCon or Class + -- See Note [Type checking recursive type and class declarations] + -- and Note [Type environment evolution] + tcExtendKindEnvWithTyCons tc_tycons $ + + -- Kind and type check declarations for this group + mapAndUnzipM (tcTyClDecl roles) tyclds + ; return (tycons, concat data_deriv_infos, kindless) + } } + where + ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma + , ppr (tyConBinders tc) <> comma + , ppr (tyConResKind tc) + , ppr (isTcTyCon tc) ]) + +zipRecTyClss :: [TcTyCon] + -> [TyCon] -- Knot-tied + -> [(Name,TyThing)] +-- Build a name-TyThing mapping for the TyCons bound by decls +-- being careful not to look at the knot-tied [TyThing] +-- The TyThings in the result list must have a visible ATyCon, +-- because typechecking types (in, say, tcTyClDecl) looks at +-- this outer constructor +zipRecTyClss tc_tycons rec_tycons + = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ] + where + rec_tc_env :: NameEnv TyCon + rec_tc_env = foldr add_tc emptyNameEnv rec_tycons + + add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon + add_tc tc env = foldr add_one_tc env (tc : tyConATs tc) + + add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon + add_one_tc tc env = extendNameEnv env (tyConName tc) tc + + get name = case lookupNameEnv rec_tc_env name of + Just tc -> tc + other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) + +{- +************************************************************************ +* * + Kind checking +* * +************************************************************************ + +Note [Kind checking for type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kind checking is done thus: + + 1. Make up a kind variable for each parameter of the declarations, + and extend the kind environment (which is in the TcLclEnv) + + 2. Kind check the declarations + +We need to kind check all types in the mutually recursive group +before we know the kind of the type variables. For example: + + class C a where + op :: D b => a -> b -> b + + class D c where + bop :: (Monad c) => ... + +Here, the kind of the locally-polymorphic type variable "b" +depends on *all the uses of class D*. For example, the use of +Monad c in bop's type signature means that D must have kind Type->Type. + +Note: we don't treat type synonyms specially (we used to, in the past); +in particular, even if we have a type synonym cycle, we still kind check +it normally, and test for cycles later (checkSynCycles). The reason +we can get away with this is because we have more systematic TYPE r +inference, which means that we can do unification between kinds that +aren't lifted (this historically was not true.) + +The downside of not directly reading off the kinds of the RHS of +type synonyms in topological order is that we don't transparently +support making synonyms of types with higher-rank kinds. But +you can always specify a CUSK directly to make this work out. +See tc269 for an example. + +Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A TcTyCon is one of the variants of TyCon. First, here are its invariants: + +* TcTyCon: a TyCon built with the TcTyCon constructor + A TcTyCon contains TcTyVars in its binders and kind + +* TcTyConBinder: a TyConBinder with a TcTyVar inside (not a TyVar) + +* MonoTcTyCon: a form of TcTyCon + - Flag tcTyConIsPoly = False + + - tyConBinders are TcTyConBinders: they contain TcTyVars, which are + unification variables (TyVarTv), and whose kinds may contain + unification variables. + + - tyConKind: the Monomorphic Recursion Principle: + a MonoTcTyCon has a /monomorphic kind/. + See Note [No polymorphic recursion in type decls]. + But the tyConKind may contain free unification variables. + + - tyConScopedTyVars is important; maps a Name to a TyVarTv unification variable + The order matters: Specified then Required variables. + E.g. in + data T a (b :: k) = ... + the order will be [k, a, b]. + + We do not allow @k-binders in inference mode, so we do not need to worry about + data T a @k (b :: k) = ... + where we would have to put `k` (Specified) after `a` (Required) + + NB: There are no Inferred binders in tyConScopedTyVars; 'a' may + also be poly-kinded, but that kind variable will be added by + generaliseTcTyCon, in the passage to a PolyTcTyCon. + + - tyConBinders are irrelevant; we just use tcTyConScopedTyVars + Well not /quite/ irrelevant: + * its length gives the number of explicit binders, and so allows us to + distinguish between the implicit and explicit elements of + tyConScopedTyVars. + * at construction time (mkTcTyCon) for a MonoTcTyCon (the call to mkTcTyCon + in GHC.Tc.Gen.HsType.kcInferDeclHeader) the tyConBinders are used to + construct the tyConKind; all must have AnonTCB visiblity so we we get + a monokind. + +* PolyTcTyCon: a form of TcTyCon + - Flag tcTyConIsPoly = True; this is used only to short-cut zonking + + - tyConBinders are still TcTyConBinders, but they are /skolem/ TcTyVars, + with fixed kinds, and accurate skolem info: no unification variables here + + tyConBinders includes the Inferred binders if any + + tyConBinders uses the Names from the original, renamed program. + + - tcTyConScopedTyVars is irrelevant: just use (binderVars tyConBinders) + All the types have been swizzled back to use the original Names + See Note [tyConBinders and lexical scoping] in GHC.Core.TyCon + +The main purpose of these TcTyCons is during kind-checking of +type/class declarations (in GHC.Tc.TyCl). During kind checking we +come upon knowledge of the eventual tycon in bits and pieces, and we +use a TcTyCon to record what we know before we are ready to build the +final TyCon. Here is the plan: + +* Step 1 (inferInitialKinds, called from kcTyClGroup + inference only, skipped for checking): + Make a MonoTcTyCon whose binders are TcTyVars, + that may contain free unification variables. + See Note [No polymorphic recursion in type decls] + +* Step 2 (kcTyClDecl, called from kcTyClGroup) + Kind-check the declarations of the group; this step just does + unifications that affect the unification variables created in + Step 1 + +* Step 3 (generaliseTcTyCon, called from kcTyClGroup) + Generalise that MonoTcTyCon to make a PolyTcTyCon + Its binders are skolem TcTyVars, with accurate SkolemInfo + +* Step 4 (tcTyClDecl, called from tcTyClDecls) + Typecheck the type and class decls to produce a final TyCon + Its binders are final TyVars, not TcTyVars + +Note that a MonoTcTyCon can contain unification variables, but a +PolyTcTyCon does not: only skolem TcTyVars. See the invariants above. + +More details about /kind inference/: + +S1) In kcTyClGroup, we use inferInitialKinds to look over the + declaration of any TyCon that lacks a kind signature or + CUSK, to determine its "shape"; for example, the number of + parameters, and any kind signatures. + + We record that shape record that shape in a MonoTcTyCon; it is + "mono" because it has not been been generalised, and its binders + and result kind may have free unification variables. + +S2) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the + body (class methods, data constructors, etc.) of each of + these MonoTcTyCons, which has the effect of filling in the + metavariables in the tycon's initial kind. + +S3) Still in kcTyClGroup, we use generaliseTyClDecl to generalize + each MonoTcTyCon to get a PolyTcTyCon, with skolem TcTyVars in it, + and a final, fixed kind. + +S4) Finally, back in tcTyClDecls, we extend the environment with + the PolyTcTyCons, and typecheck each declaration (regardless + of kind signatures etc) to get final TyCon. + +More details about /kind checking/ + +S5) In kcTyClGroup, we use checkInitialKinds to get the + utterly-final Kind of all TyCons in the group that + (a) have a standalone 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. + +Wrinkles: + +(W1) When recovering from a type error in a type declaration, + we want to put the erroneous TyCon in the environment in a + way that won't lead to more errors. We use a PolyTcTyCon for this; + see makeRecoveryTyCon. + +(W2) tyConScopedTyVars. A challenging piece in all of this is that we + end up taking three separate passes over every declaration: + - one in inferInitialKind (this pass look only at the head, not the body) + - one in kcTyClDecls (to kind-check the body) + - a final one in tcTyClDecls (to desugar) + + In the latter two passes, we need to connect the user-written type + variables in an LHsQTyVars with the variables in the tycon's + inferred kind. Because the tycon might not have a CUSK, this + matching up is, in general, quite hard to do. (Look through the + git history between Dec 2015 and Apr 2016 for + GHC.Tc.Gen.HsType.splitTelescopeTvs!) + + Instead of trying, we just store the list of type variables to + bring into scope, in the tyConScopedTyVars field of a MonoTcTyCon. + These tyvars are brought into scope by the calls to + tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) + in kcTyClDecl. + + In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather + than just [TcTyVar]? Consider these mutually-recursive decls + data T (a :: k1) b = MkT (S a b) + data S (c :: k2) d = MkS (T c d) + We start with k1 bound to kappa1, and k2 to kappa2; so initially + in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But + then kappa1 and kappa2 get unified; so after the zonking in + 'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ. + +See also Note [Type checking recursive type and class declarations]. + +Note [No polymorphic recursion in type decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC.Tc.HsType.kcInferDeclHeader we use mkAnonTyConBinders to make +the TyConBinders for the MonoTcTyCon. Here is why. + +Should this kind-check (cf #16344)? + 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. + +Many moons ago, 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 #16344), because `kappa` might get unified with `ka`, and +depending on just /when/ that unification happens, the instantiation of T's +kind would vary between different call sites of T. + +We encountered similar trickiness with invisible binders in type +declarations: see Note [No inference for invisible binders in type decls] + +Solution: the Monomorphic Recursion Principle: + + A MonoTcTyCon has a monomoprhic kind (no foralls!) + +See the invariants on MonoTcTyCon in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]. + +So kcInferDeclHeader gives T a straightforward monomorphic kind, with no +quantification whatsoever. That's why we always use mkAnonTyConBinder for +all arguments when figuring out tc_binders. + +But notice that (#16344 comment:3) + +* Consider this declaration: + data T2 ka (a::ka) = MkT2 (T2 Type a) + + Starting with inferInitialKinds + (Step 1 of Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]): + MonoTcTyCon binders: + ka[tyv] :: (kappa1[tau] :: Type) + a[tyv] :: (ka[tyv] :: Type) + MonoTcTyCon kind: + T2 :: kappa1[tau] -> ka[tyv] -> Type + + Given this kind for T2, in Step 2 we kind-check (T2 Type a) + from where we see + T2's first arg: (kappa1 ~ Type) + T2's second arg: (ka ~ ka) + These constraints are soluble by (kappa1 := Type) + so generaliseTcTyCon (Step 3) gives + T2 :: forall (k::Type) -> k -> * + + But now the /typechecking/ (Step 4, 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 [No inference for invisible binders in type decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#22560): + data T @k (a::k) = MkT (...(T ty)...) +What monokind can we give to T after step 1 of the kind inference +algorithm described in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]? +Remember: Step 1 generates a MonoTcTyCon. + +It can't be + T :: kappa1 -> kappa2 -> Type +because the invocation `(T ty)` doesn't have a visible argument for `kappa`. +Nor can it be + T :: forall k. kappa2 -> Type +because that breaks the Monomorphic Recursion Principle: MonoTcTyCons have +monomorphic kinds; see Note [No polymorphic recursion in type decls]. It could be + T :: kappa1 ->. kappa2 -> type +where `->.` is a new kind of arrow in kinds, which (like a type-class argument +in terms) is invisibly instantiated. Or we could fake it with + T :: forall _. kappa2 -> Type +where `_` is a completely fresh variable, but that seems very smelly and makes it +harder to talk about the Monomorphic Recursion Principle. Moreover we'd need +some extra fancy types in TyConBinders to record this extra information. + +Note that in *terms* we do not allow + f @a (x::a) = rhs +unless `f` has a type signature. So we do the same for types: + + We allow `@` binders in data type declarations ONLY if the + type constructor has a standalone kind signature (or a CUSK). + +That means that GHC.Tc.Gen.HsType.kcInferDeclHeader, which is used when we +don't have a kind signature or CUSK, and builds a MonoTcTyCon, we can simply +reject invisible binders outright (GHC.Tc.Gen.HsType.rejectInvisibleBinders); +and continue to use mkAnonTyConBinders as described in +Note [No polymorphic recursion in type decls]. + +If we get cries of pain we can revist this decision. + +Note [CUSKs and PolyKinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T (a :: *) = MkT (S a) -- Has CUSK + data S a = MkS (T Int) (S a) -- No CUSK + +Via inferInitialKinds we get + T :: * -> * + S :: kappa -> * + +Then we call kcTyClDecl on each decl in the group, to constrain the +kind unification variables. BUT we /skip/ the RHS of any decl with +a CUSK. Here we skip the RHS of T, so we eventually get + S :: forall k. k -> * + +This gets us more polymorphism than we would otherwise get, similar +(but implemented strangely differently from) the treatment of type +signatures in value declarations. + +However, we only want to do so when we have PolyKinds. +When we have NoPolyKinds, we don't skip those decls, because we have defaulting +(#16609). Skipping won't bring us more polymorphism when we have defaulting. +Consider + + data T1 a = MkT1 T2 -- No CUSK + data T2 = MkT2 (T1 Maybe) -- Has CUSK + +If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved. +With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the +program type-checks. +But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens +in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking +(T1 Maybe) will throw a type error. + +Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip. + +Open type families +~~~~~~~~~~~~~~~~~~ +This treatment of type synonyms only applies to Haskell 98-style synonyms. +General type functions can be recursive, and hence, appear in `alg_decls'. + +The kind of an open type family is solely determined by its kind signature; +hence, only kind signatures participate in the construction of the initial +kind environment (as constructed by `inferInitialKind'). In fact, we ignore +instances of families altogether in the following. However, we need to include +the kinds of *associated* families into the construction of the initial kind +environment. (This is handled by `allDecls'). + +See also Note [Kind checking recursive type and class declarations] + +Note [Swizzling the tyvars before generaliseTcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note only applies when /inferring/ the kind of a TyCon. +If there is a separate kind signature, or a CUSK, we take an entirely +different code path. + +For inference, consider + class C (f :: k) x where + type T f + op :: D f => blah + class D (g :: j) y where + op :: C g => y -> blah + +Here C and D are considered mutually recursive. Neither has a CUSK. +Just before generalisation we have the (un-quantified) kinds + C :: k1 -> k2 -> Constraint + T :: k1 -> Type + D :: k1 -> Type -> Constraint +Notice that f's kind and g's kind have been unified to 'k1'. We say +that k1 is the "representative" of k in C's decl, and of j in D's decl. + +Now when quantifying, we'd like to end up with + C :: forall {k2}. forall k. k -> k2 -> Constraint + T :: forall k. k -> Type + D :: forall j. j -> Type -> Constraint + +That is, we want to swizzle the representative to have the Name given +by the user. Partly this is to improve error messages and the output of +:info in GHCi. But it is /also/ important because the code for a +default method may mention the class variable(s), but at that point +(tcClassDecl2), we only have the final class tyvars available. +(Alternatively, we could record the scoped type variables in the +TyCon, but it's a nuisance to do so.) + +Notes: + +* On the input to generaliseTyClDecl, the mapping between the + user-specified Name and the representative TyVar is recorded in the + tyConScopedTyVars of the TcTyCon. NB: you first need to zonk to see + this representative TyVar. + +* The swizzling is actually performed by swizzleTcTyConBndrs + +* We must do the swizzling across the whole class decl. Consider + class C f where + type S (f :: k) + type T f + Here f's kind k is a parameter of C, and its identity is shared + with S and T. So if we swizzle the representative k at all, we + must do so consistently for the entire declaration. + + Hence the call to check_duplicate_tc_binders is in generaliseTyClDecl, + rather than in generaliseTcTyCon. + +There are errors to catch here. Suppose we had + class E (f :: j) (g :: k) where + op :: SameKind f g -> blah + +Then, just before generalisation we will have the (unquantified) + E :: k1 -> k1 -> Constraint + +That's bad! Two distinctly-named tyvars (j and k) have ended up with +the same representative k1. So when swizzling, we check (in +check_duplicate_tc_binders) that two distinct source names map +to the same representative. + +Here's an interesting case: + class C1 f where + type S (f :: k1) + type T (f :: k2) +Here k1 and k2 are different Names, but they end up mapped to the +same representative TyVar. To make the swizzling consistent (remember +we must have a single k across C1, S and T) we reject the program. + +Another interesting case + class C2 f where + type S (f :: k) (p::Type) + type T (f :: k) (p::Type->Type) + +Here the two k's (and the two p's) get distinct Uniques, because they +are seen by the renamer as locally bound in S and T resp. But again +the two (distinct) k's end up bound to the same representative TyVar. +You might argue that this should be accepted, but it's definitely +rejected (via an entirely different code path) if you add a kind sig: + type C2' :: j -> Constraint + class C2' f where + type S (f :: k) (p::Type) +We get + • Expected kind ‘j’, but ‘f’ has kind ‘k’ + • In the associated type family declaration for ‘S’ + +So we reject C2 too, even without the kind signature. We have +to do a bit of work to get a good error message, since both k's +look the same to the user. + +Another case + class C3 (f :: k1) where + type S (f :: k2) + +This will be rejected too. + + +Note [Type environment evolution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As we typecheck a group of declarations the type environment evolves. +Consider for example: + data B (a :: Type) = MkB (Proxy 'MkB) + +We do the following steps: + + 1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the + type env with promotion errors + B :-> TyConPE + MkB :-> DataConPE + + 2. kcTyCLGroup + - Do inferInitialKinds, which will signal a promotion + error if B is used in any of the kinds needed to initialise + B's kind (e.g. (a :: Type)) here + + - Extend the type env with these initial kinds (monomorphic for + decls that lack a CUSK) + B :-> TcTyCon + (thereby overriding the B :-> TyConPE binding) + and do kcLTyClDecl on each decl to get equality constraints on + all those initial kinds + + - Generalise the initial kind, making a poly-kinded TcTyCon + + 3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded + TcTyCons, again overriding the promotion-error bindings. + + But note that the data constructor promotion errors are still in place + so that (in our example) a use of MkB will still be signalled as + an error. + + 4. Typecheck the decls. + + 5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons + + +Note [Missed opportunity to retain higher-rank kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In 'kcTyClGroup', there is a missed opportunity to make kind +inference work in a few more cases. The idea is analogous +to Note [Special case for non-recursive function bindings]: + + * If we have an SCC with a single decl, which is non-recursive, + instead of creating a unification variable representing the + kind of the decl and unifying it with the rhs, we can just + read the type directly of the rhs. + + * Furthermore, we can update our SCC analysis to ignore + dependencies on declarations which have CUSKs: we don't + have to kind-check these all at once, since we can use + the CUSK to initialize the kind environment. + +Unfortunately this requires reworking a bit of the code in +'kcLTyClDecl' so I've decided to punt unless someone shouts about it. + +Note [Don't process associated types in getInitialKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, we processed associated types in the thing_inside in getInitialKind, +but this was wrong -- we want to do ATs separately. +The consequence for not doing it this way is #15142: + + class ListTuple (tuple :: Type) (as :: [(k, Type)]) where + type ListToTuple as :: Type + +We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify +kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring +`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't +unified with Type. And then, when we generalize the kind of ListToTuple (which +indeed has a CUSK, according to the rules), we skolemize the free metavariable +kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple, +because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1] +will unify with Type. + +Bottom line: as associated types should have no effect on a CUSK enclosing class, +we move processing them to a separate action, run after the outer kind has +been generalized. + +-} + +kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet) + +-- Kind check this group, kind generalize, and return the resulting local env +-- This binds the TyCons and Classes of the group, but not the DataCons +-- See Note [Kind checking for type and class decls] +-- and Note [Inferring kinds for type declarations] +-- +-- The NameSet returned contains kindless tycon names, without CUSK or SAKS. +kcTyClGroup kisig_env decls + = do { mod <- getModule + ; traceTc "---- kcTyClGroup ---- {" + (text "module" <+> ppr mod $$ vcat (map ppr decls)) + + -- Kind checking; + -- 1. Bind kind variables for decls + -- 2. Kind-check decls + -- 3. Generalise the inferred kinds + -- See Note [Kind checking for type and class decls] + + ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds + -- See Note [CUSKs and PolyKinds] + ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls + kindless_names = mkNameSet $ map get_name kindless_decls + + get_name d = tcdName (unLoc d) + + get_kind d + | Just ki <- lookupNameEnv kisig_env (get_name d) + = Right (d, SAKS ki) + + | cusks_enabled && hsDeclHasCusk (unLoc d) + = Right (d, CUSK) + + | otherwise = Left d + + ; checked_tcs <- checkNoErrs $ + checkInitialKinds kinded_decls + -- checkNoErrs because we are about to extend + -- the envt with these tycons, and we get + -- knock-on errors if we have tycons with + -- malformed kinds + + ; inferred_tcs + <- tcExtendKindEnvWithTyCons checked_tcs $ + pushLevelAndSolveEqualities unkSkolAnon [] $ + -- We are going to kind-generalise, so unification + -- variables in here must be one level in + do { -- Step 1: Bind kind variables for all decls + mono_tcs <- inferInitialKinds kindless_decls + + ; traceTc "kcTyClGroup: initial kinds" $ + ppr_tc_kinds mono_tcs + + -- Step 2: Set extended envt, kind-check the decls + -- NB: the environment extension overrides the tycon + -- promotion-errors bindings + -- See Note [Type environment evolution] + ; checkNoErrs $ + tcExtendKindEnvWithTyCons mono_tcs $ + mapM_ kcLTyClDecl kindless_decls + + ; return mono_tcs } + + -- Step 3: generalisation + -- Finally, go through each tycon and give it its final kind, + -- with all the required, specified, and inferred variables + -- in order. + ; let inferred_tc_env = mkNameEnv $ + map (\tc -> (tyConName tc, tc)) inferred_tcs + ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env) + kindless_decls + + ; let poly_tcs = checked_tcs ++ generalized_tcs + ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs) + ; return (poly_tcs, kindless_names) } + where + ppr_tc_kinds tcs = vcat (map pp_tc tcs) + pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc) + +type ScopedPairs = [(Name, TcTyVar)] + -- The ScopedPairs for a TcTyCon are precisely + -- specified-tvs ++ required-tvs + -- You can distinguish them because there are tyConArity required-tvs + +generaliseTyClDecl :: NameEnv MonoTcTyCon -> LTyClDecl GhcRn -> TcM [PolyTcTyCon] +-- See Note [Swizzling the tyvars before generaliseTcTyCon] +generaliseTyClDecl inferred_tc_env (L _ decl) + = do { let names_in_this_decl :: [Name] + names_in_this_decl = tycld_names decl + + ; tc_infos <- liftZonkM $ + do { -- Extract the specified/required binders and skolemise them + ; tc_with_tvs <- mapM skolemise_tc_tycon names_in_this_decl + + -- Zonk, to manifest the side-effects of skolemisation to the swizzler + -- NB: it's important to skolemise them all before this step. E.g. + -- class C f where { type T (f :: k) } + -- We only skolemise k when looking at T's binders, + -- but k appears in f's kind in C's binders. + ; mapM zonk_tc_tycon tc_with_tvs } + + -- Swizzle + ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos) + + -- And finally generalise + ; mapAndReportM generaliseTcTyCon swizzled_infos } + where + tycld_names :: TyClDecl GhcRn -> [Name] + tycld_names decl = tcdName decl : at_names decl + + at_names :: TyClDecl GhcRn -> [Name] + at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats + at_names _ = [] -- Only class decls have associated types + + skolemise_tc_tycon :: Name -> ZonkM (TcTyCon, SkolemInfo, ScopedPairs) + -- Zonk and skolemise the Specified and Required binders + skolemise_tc_tycon tc_name + = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name + -- This lookup should not fail + ; skol_info <- mkSkolemInfo (TyConSkol (tyConFlavour tc) tc_name ) + ; scoped_prs <- mapSndM (zonkAndSkolemise skol_info) (tcTyConScopedTyVars tc) + ; return (tc, skol_info, scoped_prs) } + + zonk_tc_tycon :: (TcTyCon, SkolemInfo, ScopedPairs) + -> ZonkM (TcTyCon, SkolemInfo, ScopedPairs, TcKind) + zonk_tc_tycon (tc, skol_info, scoped_prs) + = do { scoped_prs <- mapSndM zonkTcTyVarToTcTyVar scoped_prs + -- We really have to do this again, even though + -- we have just done zonkAndSkolemise, so that + -- occurrences in the /kinds/ get zonked to the skolem + ; res_kind <- zonkTcType (tyConResKind tc) + ; return (tc, skol_info, scoped_prs, res_kind) } + +swizzleTcTyConBndrs :: [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] + -> TcM [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] +swizzleTcTyConBndrs tc_infos + | all no_swizzle swizzle_prs + -- This fast path happens almost all the time + -- See Note [Cloning for type variable binders] in GHC.Tc.Gen.HsType + -- "Almost all the time" means not the case of mutual recursion with + -- polymorphic kinds. + = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr_infos tc_infos) + ; return tc_infos } + + | otherwise + = do { checkForDuplicateScopedTyVars swizzle_prs + + ; traceTc "swizzleTcTyConBndrs" $ + vcat [ text "before" <+> ppr_infos tc_infos + , text "swizzle_prs" <+> ppr swizzle_prs + , text "after" <+> ppr_infos swizzled_infos ] + + ; return swizzled_infos } + + where + swizzled_infos = [ (tc, skol_info, mapSnd swizzle_var scoped_prs, swizzle_ty kind) + | (tc, skol_info, scoped_prs, kind) <- tc_infos ] + + swizzle_prs :: [(Name,TyVar)] + -- Pairs the user-specified Name with its representative TyVar + -- See Note [Swizzling the tyvars before generaliseTcTyCon] + swizzle_prs = [ pr | (_, _, prs, _) <- tc_infos, pr <- prs ] + + no_swizzle :: (Name,TyVar) -> Bool + no_swizzle (nm, tv) = nm == tyVarName tv + + ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs) + | (tc, _, prs, _) <- infos ] + + -------------- The swizzler ------------ + -- This does a deep traverse, simply doing a + -- Name-to-Name change, governed by swizzle_env + -- The 'swap' is what gets from the representative TyVar + -- back to the original user-specified Name + swizzle_env = mkVarEnv (map swap swizzle_prs) + + swizzleMapper :: TyCoMapper () Identity + swizzleMapper = TyCoMapper { tcm_tyvar = swizzle_tv + , tcm_covar = swizzle_cv + , tcm_hole = swizzle_hole + , tcm_tycobinder = swizzle_bndr + , tcm_tycon = swizzle_tycon } + swizzle_hole _ hole = pprPanic "swizzle_hole" (ppr hole) + -- These types are pre-zonked + swizzle_tycon tc = pprPanic "swizzle_tc" (ppr tc) + -- TcTyCons can't appear in kinds (yet) + swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv)) + swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv)) + + swizzle_bndr :: () + -> TyCoVar + -> ForAllTyFlag + -> (() -> TyCoVar -> Identity r) + -> Identity r + swizzle_bndr _ tcv _ k + = k () (swizzle_var tcv) + + swizzle_var :: Var -> Var + swizzle_var v + | Just nm <- lookupVarEnv swizzle_env v + = updateVarType swizzle_ty (v `setVarName` nm) + | otherwise + = updateVarType swizzle_ty v + + (map_type, _, _, _) = mapTyCo swizzleMapper + swizzle_ty ty = runIdentity (map_type ty) + + +generaliseTcTyCon :: (MonoTcTyCon, SkolemInfo, ScopedPairs, TcKind) -> TcM PolyTcTyCon +generaliseTcTyCon (tc, skol_info, scoped_prs, tc_res_kind) + -- The scoped_prs are fully zonked skolem TcTyVars + -- And tc_res_kind is fully zonked too + -- See Note [Required, Specified, and Inferred for types] + = setSrcSpan (getSrcSpan tc) $ + addTyConCtxt tc $ + do { -- Step 1: Separate Specified from Required variables + -- NB: spec_req_tvs = spec_tvs ++ req_tvs + -- And req_tvs is 1-1 with tyConTyVars + -- See Note [Scoped tyvars in a TcTyCon] in GHC.Core.TyCon + ; let spec_req_tvs = map snd scoped_prs + n_spec = length spec_req_tvs - tyConArity tc + (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs + sorted_spec_tvs = scopedSort spec_tvs + -- NB: We can't do the sort until we've zonked + -- Maintain the L-R order of scoped_tvs + + -- Step 2a: find all the Inferred variables we want to quantify over + ; dvs1 <- candidateQTyVarsOfKinds $ + (tc_res_kind : map tyVarKind spec_req_tvs) + ; let dvs2 = dvs1 `delCandidates` spec_req_tvs + + -- Step 2b: quantify, mainly meaning skolemise the free variables + -- Returned 'inferred' are scope-sorted and skolemised + ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs2 + + ; traceTc "generaliseTcTyCon: pre zonk" + (vcat [ text "tycon =" <+> ppr tc + , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs + , text "tc_res_kind =" <+> ppr tc_res_kind + , text "dvs1 =" <+> ppr dvs1 + , text "inferred =" <+> pprTyVars inferred ]) + + -- Step 3: Final zonk: quantifyTyVars may have done some defaulting + ; (inferred, sorted_spec_tvs,req_tvs,tc_res_kind) <- liftZonkM $ + do { inferred <- zonkTcTyVarsToTcTyVars inferred + ; sorted_spec_tvs <- zonkTcTyVarsToTcTyVars sorted_spec_tvs + ; req_tvs <- zonkTcTyVarsToTcTyVars req_tvs + ; tc_res_kind <- zonkTcType tc_res_kind + ; return (inferred, sorted_spec_tvs, req_tvs, tc_res_kind) } + + ; traceTc "generaliseTcTyCon: post zonk" $ + vcat [ text "tycon =" <+> ppr tc + , text "inferred =" <+> pprTyVars inferred + , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs + , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs + , text "req_tvs =" <+> ppr req_tvs ] + + -- Step 4: Make the TyConBinders. + ; let dep_fv_set = candidateKindVars dvs1 + inferred_tcbs = mkNamedTyConBinders Inferred inferred + specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs + required_tcbs = map (mkRequiredTyConBinder dep_fv_set) req_tvs + + -- Step 5: Assemble the final list. + all_tcbs = concat [ inferred_tcbs + , specified_tcbs + , required_tcbs ] + flav = tyConFlavour tc + + -- Eta expand + ; (eta_tcbs, tc_res_kind) <- maybeEtaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind + + -- Step 6: Make the result TcTyCon + ; let final_tcbs = all_tcbs `chkAppend` eta_tcbs + tycon = mkTcTyCon (tyConName tc) + final_tcbs tc_res_kind + (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs)) + True {- it's generalised now -} + flav + + ; traceTc "generaliseTcTyCon done" $ + vcat [ text "tycon =" <+> ppr tc + , text "tc_res_kind =" <+> ppr tc_res_kind + , text "dep_fv_set =" <+> ppr dep_fv_set + , text "inferred_tcbs =" <+> ppr inferred_tcbs + , text "specified_tcbs =" <+> ppr specified_tcbs + , text "required_tcbs =" <+> ppr required_tcbs + , text "final_tcbs =" <+> ppr final_tcbs ] + + -- Step 7: Check for validity. + -- We do this here because we're about to put the tycon into the + -- the environment, and we don't want anything malformed there + ; checkTyConTelescope tycon + + ; return tycon } + +{- Note [Required, Specified, and Inferred for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each forall'd type variable in a type or kind is one of + + * Required: an argument must be provided at every call site + + * Specified: the argument can be inferred at call sites, but + may be instantiated with visible type/kind application + + * Inferred: the argument must be inferred at call sites; it + is unavailable for use with visible type/kind application. + +Why have Inferred at all? Because we just can't make user-facing +promises about the ordering of some variables. These might swizzle +around even between minor released. By forbidding visible type +application, we ensure users aren't caught unawares. + +Go read Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. + +The question for this Note is this: + given a TyClDecl, how are its quantified type variables classified? +Much of the debate is memorialized in #15743. + +Here is our design choice. When inferring the ordering of variables +for a TyCl declaration (that is, for those variables that the user +has not specified the order with an explicit `forall`), we use the +following order: + + 1. Inferred variables + 2. Specified variables; in the left-to-right order in which + the user wrote them, modified by scopedSort (see below) + to put them in dependency order. + 3. Required variables before a top-level :: + 4. All variables after a top-level :: + +If this ordering does not make a valid telescope, we reject the definition. + +Example: + data SameKind :: k -> k -> * + data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +For Bad: + - a, c, d, x are Required; they are explicitly listed by the user + as the positional arguments of Bad + - b is Specified; it appears explicitly in a kind signature + - k, the kind of a, is Inferred; it is not mentioned explicitly at all + +Putting variables in the order Inferred, Specified, Required +gives us this telescope: + Inferred: k + Specified: b : Proxy a + Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d) + +But this order is ill-scoped, because b's kind mentions a, which occurs +after b in the telescope. So we reject Bad. + +Associated types +~~~~~~~~~~~~~~~~ +For associated types everything above is determined by the +associated-type declaration alone, ignoring the class header. +Here is an example (#15592) + class C (a :: k) b where + type F (x :: b a) + +In the kind of C, 'k' is Specified. But what about F? +In the kind of F, + + * Should k be Inferred or Specified? It's Specified for C, + but not mentioned in F's declaration. + + * In which order should the Specified variables a and b occur? + It's clearly 'a' then 'b' in C's declaration, but the L-R ordering + in F's declaration is 'b' then 'a'. + +In both cases we make the choice by looking at F's declaration alone, +so it gets the kind + F :: forall {k}. forall b a. b a -> Type + +How it works +~~~~~~~~~~~~ +These design choices are implemented by two completely different code +paths for + + * Declarations with a standalone kind signature or a complete user-specified + kind signature (CUSK). Handled by the kcCheckDeclHeader. + + * Declarations without a kind signature (standalone or CUSK) are handled by + kcInferDeclHeader; see Note [Inferring kinds for type declarations]. + +Note that neither code path worries about point (4) above, as this +is nicely handled by not mangling the res_kind. (Mangling res_kinds is done +*after* all this stuff, in tcDataDefn's call to maybeEtaExpandAlgTyCon.) + +We can tell Inferred apart from Specified by looking at the scoped +tyvars; Specified are always included there. + +Design alternatives +~~~~~~~~~~~~~~~~~~~ +* For associated types we considered putting the class variables + before the local variables, in a nod to the treatment for class + methods. But it got too complicated; see #15592, comment:21ff. + +* We rigidly require the ordering above, even though we could be much more + permissive. Relevant musings are at + https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623 + The bottom line conclusion is that, if the user wants a different ordering, + then can specify it themselves, and it is better to be predictable and dumb + than clever and capricious. + + I (Richard) conjecture we could be fully permissive, allowing all classes + of variables to intermix. We would have to augment ScopedSort to refuse to + reorder Required variables (or check that it wouldn't have). But this would + allow more programs. See #15743 for examples. Interestingly, Idris seems + to allow this intermixing. The intermixing would be fully specified, in that + we can be sure that inference wouldn't change between versions. However, + would users be able to predict it? That I cannot answer. + +Test cases (and tickets) relevant to these design decisions +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + T15591* + T15592* + T15743* + +Note [Inferring kinds for type declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note deals with /inference/ for type declarations +that do not have a CUSK or a SAKS. Consider + data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x) + data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y) + +We do kind inference as follows: + +* Step 1: inferInitialKinds, and in particular kcInferDeclHeader. + Make a unification variable for each of the Required and Specified + type variables in the header. + + Record the connection between the Names the user wrote and the + fresh unification variables in the tcTyConScopedTyVars field + of the TcTyCon we are making + [ (a, aa) + , (k1, kk1) + , (k2, kk2) + , (x, xx) ] + (I'm using the convention that double letter like 'aa' or 'kk' + mean a unification variable.) + + These unification variables + - Are TyVarTvs: that is, unification variables that can + unify only with other type variables. + See Note [TyVarTv] in GHC.Tc.Utils.TcMType + + - Have complete fresh Names; see GHC.Tc.Utils.TcMType + Note [Unification variables need fresh Names] + + Assign initial monomorphic kinds to S, T + T :: kk1 -> * -> kk2 -> * + S :: kk3 -> * -> kk4 -> * + +* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and + T, with these monomorphic kinds. Now kind-check the declarations, + and solve the resulting equalities. The goal here is to discover + constraints on all these unification variables. + + Here we find that kk1 := kk3, and kk2 := kk4. + + This is why we can't use skolems for kk1 etc; they have to + unify with each other. + +* Step 3: generaliseTcTyCon. Generalise each TyCon in turn. + We find the free variables of the kind, skolemise them, + sort them out into Inferred/Required/Specified (see the above + Note [Required, Specified, and Inferred for types]), + and perform some validity checks. + + This makes the utterly-final TyConBinders for the TyCon. + + All this is very similar at the level of terms: see GHC.Tc.Gen.Bind + Note [Quantified variables in partial type signatures] + + But there are some tricky corners: Note [Tricky scoping in generaliseTcTyCon] + +* Step 4. Extend the type environment with a TcTyCon for S and T, now + with their utterly-final polymorphic kinds (needed for recursive + occurrences of S, T). Now typecheck the declarations, and build the + final AlgTyCon for S and T resp. + +The first three steps are in kcTyClGroup; the fourth is in +tcTyClDecls. + +There are some wrinkles + +* Do not default TyVarTvs. We always want to kind-generalise over + TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is + not allowed to unify with a type; it must stand for a type + variable. Hence the check in GHC.Tc.Solver.defaultTyVarTcS, and + GHC.Tc.Utils.TcMType.defaultTyVar. Here's another example (#14555): + data Exp :: [TYPE rep] -> TYPE rep -> Type where + Lam :: Exp (a:xs) b -> Exp xs (a -> b) + We want to kind-generalise over the 'rep' variable. + #14563 is another example. + +* Duplicate type variables. Consider #11203 + data SameKind :: k -> k -> * + data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) + Here we will unify k1 with k2, but this time doing so is an error, + because k1 and k2 are bound in the same declaration. + + We spot this during validity checking (checkForDuplicateScopeTyVars), + in generaliseTcTyCon. + +* Required arguments. Even the Required arguments should be made + into TyVarTvs, not skolems. Consider + data T k (a :: k) + Here, k is a Required, dependent variable. For uniformity, it is helpful + to have k be a TyVarTv, in parallel with other dependent variables. + +* Duplicate skolemisation is expected. When generalising in Step 3, + we may find that one of the variables we want to quantify has + already been skolemised. For example, suppose we have already + generalise S. When we come to T we'll find that kk1 (now the same as + kk3) has already been skolemised. + + That's fine -- but it means that + a) when collecting quantification candidates, in + candidateQTyVarsOfKind, we must collect skolems + b) quantifyTyVars should be a no-op on such a skolem + +Note [Tricky scoping in generaliseTcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider #16342 + class C (a::ka) x where + cop :: D a x => x -> Proxy a -> Proxy a + cop _ x = x :: Proxy (a::ka) + + class D (b::kb) y where + dop :: C b y => y -> Proxy b -> Proxy b + dop _ x = x :: Proxy (b::kb) + +C and D are mutually recursive, by the time we get to +generaliseTcTyCon we'll have unified kka := kkb. + +But when typechecking the default declarations for 'cop' and 'dop' in +tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope. +But at that point all we have is the utterly-final Class itself. + +Conclusion: the classTyVars of a class must have the same Name as +that originally assigned by the user. In our example, C must have +classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite +the fact that kka and kkb got unified! + +We achieve this sleight of hand in generaliseTcTyCon, using +the specialised function zonkRecTyVarBndrs. We make the call + zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx] +where the [ka,a,x] are the Names originally assigned by the user, and +[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars. +zonkRecTyVarBndrs builds a recursive ZonkEnv that binds + kkb :-> (ka :: ) + aa :-> (a :: ) + etc +That is, it maps each skolemised TcTyVars to the utterly-final +TyVar to put in the class, with its correct user-specified name. +When generalising D we'll do the same thing, but the ZonkEnv will map + kkb :-> (kb :: ) + bb :-> (b :: ) + etc +Note that 'kkb' again appears in the domain of the mapping, but this +time mapped to 'kb'. That's how C and D end up with differently-named +final TyVars despite the fact that we unified kka:=kkb + +zonkRecTyVarBndrs we need to do knot-tying because of the need to +apply this same substitution to the kind of each. + +Note [Inferring visible dependent quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T k :: k -> Type where + MkT1 :: T Type Int + MkT2 :: T (Type -> Type) Maybe + +This looks like it should work. However, it is polymorphically recursive, +as the uses of T in the constructor types specialize the k in the kind +of T. This trips up our dear users (#17131, #17541), and so we add +a "landmark" context (which cannot be suppressed) whenever we +spot inferred visible dependent quantification (VDQ). + +It's hard to know when we've actually been tripped up by polymorphic recursion +specifically, so we just include a note to users whenever we infer VDQ. The +testsuite did not show up a single spurious inclusion of this message. + +The context is added in addVDQNote, which looks for a visible +TyConBinder that also appears in the TyCon's kind. (I first looked at +the kind for a visible, dependent quantifier, but + Note [No polymorphic recursion in type decls] +in GHC.Tc.Gen.HsType defeats that approach.) addVDQNote is used in +kcTyClDecl, which is used only when inferring the kind of a tycon +(never with a CUSK or SAKS). + +Once upon a time, I (Richard E) thought that the tycon-kind could +not be a forall-type. But this is wrong: data T :: forall k. k -> Type +(with -XNoCUSKs) could end up here. And this is all OK. +-} + +-------------- +tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a +tcExtendKindEnvWithTyCons tcs + = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ] + +-------------- +mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv +-- Maps each tycon/datacon to a suitable promotion error +-- tc :-> APromotionErr TyConPE +-- dc :-> APromotionErr RecDataConPE +-- See Note [Recursion and promoting data constructors] + +mkPromotionErrorEnv decls + = foldr (plusNameEnv . mk_prom_err_env . unLoc) + emptyNameEnv decls + +mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv +mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) + = unitNameEnv nm (APromotionErr ClassPE) + `plusNameEnv` + mkNameEnv [ (familyDeclName at, APromotionErr TyConPE) + | L _ at <- ats ] + +mk_prom_err_env (DataDecl { tcdLName = L _ name + , tcdDataDefn = HsDataDefn { dd_cons = cons } }) + = unitNameEnv name (APromotionErr TyConPE) + `plusNameEnv` + mkNameEnv [ (con, APromotionErr conPE) + | L _ con' <- toList cons + , L _ con <- getConNames con' ] + where + -- In a "type data" declaration, the constructors are at the type level. + -- See Note [Type data declarations] in GHC.Rename.Module. + conPE + | isTypeDataDefnCons cons = TyConPE + | otherwise = RecDataConPE + +mk_prom_err_env decl + = unitNameEnv (tcdName decl) (APromotionErr TyConPE) + -- Works for family declarations too + +-------------- +inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [MonoTcTyCon] +-- Returns a TcTyCon for each TyCon bound by the decls, +-- each with its initial kind + +inferInitialKinds decls + = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls) + ; tcs <- concatMapM infer_initial_kind decls + ; traceTc "inferInitialKinds done }" empty + ; return tcs } + where + infer_initial_kind = addLocM (getInitialKind InitialKindInfer) + +-- Check type/class declarations against their standalone kind signatures or +-- CUSKs, producing a generalized TcTyCon for each. +checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon] +checkInitialKinds decls + = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls) + ; tcs <- concatMapM check_initial_kind decls + ; traceTc "checkInitialKinds done }" empty + ; return tcs } + where + check_initial_kind (ldecl, msig) = + addLocM (getInitialKind (InitialKindCheck msig)) ldecl + +-- | Get the initial kind of a TyClDecl, either generalized or non-generalized, +-- depending on the 'InitialKindStrategy'. +getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] + +-- Allocate a fresh kind variable for each TyCon and Class +-- For each tycon, return a TcTyCon with kind k +-- where k is the kind of tc, derived from the LHS +-- of the definition (and probably including +-- kind unification variables) +-- Example: data T a b = ... +-- return (T, kv1 -> kv2 -> kv3) +-- +-- This pass deals with (ie incorporates into the kind it produces) +-- * The kind signatures on type-variable binders +-- * The result kinds signature on a TyClDecl +-- +-- No family instances are passed to checkInitialKinds/inferInitialKinds +getInitialKind strategy + (ClassDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdATs = ats }) + = do { cls_tc <- kcDeclHeader strategy name ClassFlavour ktvs $ + return (TheKind constraintKind) + -- See Note [Don't process associated types in getInitialKind] + + ; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $ + mapM (addLocM (getAssocFamInitialKind cls_tc)) ats + ; return (cls_tc : at_tcs) } + where + getAssocFamInitialKind cls = + case strategy of + InitialKindInfer -> get_fam_decl_initial_kind (Just cls) + InitialKindCheck _ -> check_initial_kind_assoc_fam cls + +getInitialKind strategy + (DataDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig, dd_cons = cons } }) + = do { let flav = newOrDataToFlavour (dataDefnConsNewOrData cons) + ctxt = DataKindCtxt name + ; tc <- kcDeclHeader strategy name flav ktvs $ + case m_sig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> return $ dataDeclDefaultResultKind strategy (dataDefnConsNewOrData cons) + ; return [tc] } + +getInitialKind InitialKindInfer (FamDecl { tcdFam = decl }) + = do { tc <- get_fam_decl_initial_kind Nothing decl + ; return [tc] } + +getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = + FamilyDecl { fdLName = unLoc -> name + , fdTyVars = ktvs + , fdResultSig = unLoc -> resultSig + , fdInfo = info } } ) + = do { let flav = familyInfoTyConFlavour Nothing info + ctxt = TyFamResKindCtxt name + ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $ + case famResultKindSignature resultSig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> + case msig of + CUSK -> return (TheKind liftedTypeKind) + SAKS _ -> return AnyKind + ; return [tc] } + +getInitialKind strategy + (SynDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdRhs = rhs }) + = do { let ctxt = TySynKindCtxt name + ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $ + case hsTyKindSig rhs of + Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig + Nothing -> return AnyKind + ; return [tc] } + +get_fam_decl_initial_kind + :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls + -> FamilyDecl GhcRn + -> TcM TcTyCon +get_fam_decl_initial_kind mb_parent_tycon + FamilyDecl { fdLName = L _ name + , fdTyVars = ktvs + , fdResultSig = L _ resultSig + , fdInfo = info } + = kcDeclHeader InitialKindInfer name flav ktvs $ + case resultSig of + KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki + TyVarSig _ (L _ tvb) | HsTvb { tvb_kind = HsBndrKind _ ki } <- tvb + -> TheKind <$> tcLHsKindSig ctxt ki + _ -- open type families have * return kind by default + | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) + -- closed type families have their return kind inferred + -- by default + | otherwise -> return AnyKind + where + flav = familyInfoTyConFlavour mb_parent_tycon info + ctxt = TyFamResKindCtxt name + +-- See Note [Standalone kind signatures for associated types] +check_initial_kind_assoc_fam + :: TcTyCon -- parent class + -> FamilyDecl GhcRn + -> TcM TcTyCon +check_initial_kind_assoc_fam cls + FamilyDecl + { fdLName = unLoc -> name + , fdTyVars = ktvs + , fdResultSig = unLoc -> resultSig + , fdInfo = info } + = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $ + case famResultKindSignature resultSig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> return (TheKind liftedTypeKind) + where + ctxt = TyFamResKindCtxt name + flav = familyInfoTyConFlavour (Just cls) info + +{- Note [Standalone kind signatures for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If associated types had standalone kind signatures, would they wear them + +---------------------------+------------------------------ + like this? (OUT) | or like this? (IN) +---------------------------+------------------------------ + type T :: Type -> Type | class C a where + class C a where | type T :: Type -> Type + type T a | type T a + +The (IN) variant is syntactically ambiguous: + + class C a where + type T :: a -- standalone kind signature? + type T :: a -- declaration header? + +The (OUT) variant does not suffer from this issue, but it might not be the +direction in which we want to take Haskell: we seek to unify type families and +functions, and, by extension, associated types with class methods. And yet we +give class methods their signatures inside the class, not outside. Neither do +we have the counterpart of InstanceSigs for StandaloneKindSignatures. + +For now, we dodge the question by using CUSKs for associated types instead of +standalone kind signatures. This is a simple addition to the rule we used to +have before standalone kind signatures: + + old rule: associated type has a CUSK iff its parent class has a CUSK + new rule: associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature + +-} + +-- See Note [Data declaration default result kind] +dataDeclDefaultResultKind :: InitialKindStrategy -> NewOrData -> ContextKind +dataDeclDefaultResultKind strategy new_or_data + | NewType <- new_or_data + = OpenKind -- See Note [Implementation of UnliftedNewtypes], point . + | DataType <- new_or_data + , InitialKindCheck (SAKS _) <- strategy + = OpenKind -- See Note [Implementation of UnliftedDatatypes] + | otherwise + = TheKind liftedTypeKind + +{- Note [Data declaration default result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user has not written an inline result kind annotation on a data +declaration, we assume it to be 'Type'. That is, the following declarations +D1 and D2 are considered equivalent: + + data D1 where ... + data D2 :: Type where ... + +The consequence of this assumption is that we reject D3 even though we +accept D4: + + data D3 where + MkD3 :: ... -> D3 param + + data D4 :: Type -> Type where + MkD4 :: ... -> D4 param + +However, there are two twists: + + * For unlifted newtypes, we must relax the assumed result kind to (TYPE r): + + newtype D5 where + MkD5 :: Int# -> D5 + + See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note + . + + * For unlifted datatypes, we must relax the assumed result kind to + (TYPE (BoxedRep l)) in the presence of a SAKS: + + type D6 :: Type -> TYPE (BoxedRep Unlifted) + data D6 a = MkD6 a + + Otherwise, it would be impossible to declare unlifted data types in H98 + syntax (which doesn't allow specification of a result kind). + +-} + +------------------------------------------------------------------------ +kcLTyClDecl :: LTyClDecl GhcRn -> TcM () + -- See Note [Kind checking for type and class decls] + -- Called only for declarations without a signature (no CUSKs or SAKs here) +kcLTyClDecl (L loc decl) + = setSrcSpanA loc $ + do { tycon <- tcLookupTcTyCon tc_name -- Always a MonoTcTyCon + ; traceTc "kcTyClDecl {" (ppr tc_name) + ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] + addErrCtxt (tcMkDeclCtxt decl) $ + kcTyClDecl decl tycon + ; traceTc "kcTyClDecl done }" (ppr tc_name) } + where + tc_name = tcdName decl + +kcTyClDecl :: TyClDecl GhcRn -> MonoTcTyCon -> TcM () +-- This function is used solely for its side effect on kind variables +-- NB kind signatures on the type variables and +-- result kind signature have already been dealt with +-- by inferInitialKind, so we can ignore them here. + +-- NB these equations just extend the type environment with carefully constructed +-- TcTyVars rather than create skolemised variables for the bound variables. +-- - inferInitialKinds makes the TcTyCon where the tyvars are TcTyVars +-- - In this function, those TcTyVars are unified with other kind variables during +-- kind inference (see GHC.Tc.TyCl Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]) + +kcTyClDecl (DataDecl { tcdLName = (L _ _name) + , tcdDataDefn = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } }) + tycon + = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ + -- NB: binding these tyvars isn't necessary for GADTs, but it does no + -- harm. For GADTs, each data con brings its own tyvars into scope, + -- and the ones from this bindTyClTyVars are either not mentioned or + -- (conceivably) shadowed. + do { traceTc "kcTyClDecl" (ppr tycon $$ ppr (tyConTyVars tycon) $$ ppr (tyConResKind tycon)) + ; _ <- tcHsContext ctxt + ; kcConDecls (tyConResKind tycon) cons + } + +kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon + = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ + let res_kind = tyConResKind tycon + in discardResult $ tcCheckLHsTypeInContext rhs (TheKind res_kind) + -- NB: check against the result kind that we allocated + -- in inferInitialKinds. + +kcTyClDecl (ClassDecl { tcdLName = L _ _name + , tcdCtxt = ctxt, tcdSigs = sigs }) tycon + = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ + do { _ <- tcHsContext ctxt + ; mapM_ (wrapLocMA_ kc_sig) sigs } + where + kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType nms op_ty + kc_sig _ = return () + +kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc +-- closed type families look at their equations, but other families don't +-- do anything here + = case fd_info of + ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns + _ -> return () + +------------------- + +-- Kind-check the types of the arguments to a data constructor. +-- This includes doing kind unification if the type is a newtype. +-- See Note [Implementation of UnliftedNewtypes] for why we need +-- the first two arguments. +kcConArgTys :: ConArgKind -- Expected kind of the argument(s) + -> [HsConDeclField GhcRn] -- User-written argument types + -> TcM () +kcConArgTys exp_kind arg_tys + = forM_ arg_tys $ \(CDF { cdf_multiplicity, cdf_type }) -> + do { _ <- tcCheckLHsTypeInContext cdf_type exp_kind + ; maybe (pure ()) (void . tcMult) (multAnnToHsType cdf_multiplicity) } + -- See Note [Implementation of UnliftedNewtypes], STEP 2 + +-- Kind-check the types of arguments to a Haskell98 data constructor. +kcConH98Args :: ConArgKind -- Expected kind of the argument(s) + -> HsConDeclH98Details GhcRn + -> TcM () +kcConH98Args exp_kind con_args = case con_args of + PrefixCon tys -> kcConArgTys exp_kind tys + InfixCon ty1 ty2 -> kcConArgTys exp_kind [ty1, ty2] + RecCon (L _ flds) -> kcConArgTys exp_kind $ + map (cdrf_spec . unLoc) flds + +-- Kind-check the types of arguments to a GADT data constructor. +kcConGADTArgs :: ConArgKind -- Expected kind of the argument(s) + -> HsConDeclGADTDetails GhcRn + -> TcM () +kcConGADTArgs exp_kind con_args = case con_args of + PrefixConGADT _ tys -> kcConArgTys exp_kind tys + RecConGADT _ (L _ flds) -> kcConArgTys exp_kind $ + map (cdrf_spec . unLoc) flds + +kcConDecls :: TcKind -- Result kind of tycon + -- Used only in H98 case + -> DataDefnCons (LConDecl GhcRn) -> TcM () +-- See Note [kcConDecls: kind-checking data type decls] +kcConDecls tc_res_kind cons + = traverse_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) cons + where + new_or_data = dataDefnConsNewOrData cons + +-- Kind check a data constructor. In additional to the data constructor, +-- we also need to know about whether or not its corresponding type was +-- declared with data or newtype, and we need to know the result kind of +-- this type. See Note [Implementation of UnliftedNewtypes] for why +-- we need the first two arguments. +kcConDecl :: NewOrData -> TcKind -> ConDecl GhcRn -> TcM () +kcConDecl new_or_data tc_res_kind + (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs + , con_mb_cxt = ex_ctxt, con_args = args }) + = addErrCtxt (DataConDefCtxt (NE.singleton name)) $ + discardResult $ + bindExplicitTKBndrs_Tv ex_tvs $ + do { _ <- tcHsContext ex_ctxt + ; let arg_exp_kind = getArgExpKind new_or_data tc_res_kind + -- getArgExpKind: for newtypes, check that the argument kind + -- is the same as the tc_res_kind. See (KCD1) + -- in Note [kcConDecls: kind-checking data type decls] + ; kcConH98Args arg_exp_kind args + -- We don't need to check the telescope here, + -- because that's done in tcConDecl + } + +kcConDecl new_or_data _tc_res_kind + -- NB: _tc_res_kind is unused. See (KCD3) in + -- Note [kcConDecls: kind-checking data type decls] + (ConDeclGADT { con_names = names + , con_outer_bndrs = L _ outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = cxt + , con_g_args = args + , con_res_ty = res_ty }) + = -- See Note [kcConDecls: kind-checking data type decls] + addErrCtxt (DataConDefCtxt names) $ + -- Not sure this is right, should just extend rather than skolemise but no test + bind_con_tvbs outer_bndrs inner_bndrs $ + do { _ <- tcHsContext cxt + ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty) + ; con_res_kind <- newOpenTypeKind + ; _ <- tcCheckLHsTypeInContext res_ty (TheKind con_res_kind) + + ; let arg_exp_kind = getArgExpKind new_or_data con_res_kind + -- getArgExpKind: for newtypes, check that the argument kind + -- is the same the kind of `res_ty`, the data con's return type + -- See (KCD2) in Note [kcConDecls: kind-checking data type decls] + ; kcConGADTArgs arg_exp_kind args + + ; traceTc "kcConDecl:GADT }" (ppr names $$ ppr arg_exp_kind) + ; return () } + where + bind_con_tvbs outer_bndrs inner_bndrs thing_inside + -- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs] + = discardResult $ bindOuterSigTKBndrs_Tv outer_bndrs $ + bindExplicitTKBndrs_Tv (concatMap hsForAllTelescopeBndrs inner_bndrs) $ + thing_inside + +{- Note [kcConDecls: kind-checking data type decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +kcConDecls is used when we are inferring the kind of the type +constructor in a data type declaration. The basic plan is described in +Note [Inferring kinds for type declarations]; here we are doing Step 2. + +We are kind-checking the data constructors /only/ to compute the kind of +the type construtor. For example + data T f a = MkT (f a) +The (f a) in the data construtor constrains the kinds of `f` and `a`, and hence +of `T`. + +There are two cases to consider in `kcConDecl` + +* Haskell 98 data constructors, as above. We simply bring `f` and `a` + into scope and kind-check the data constructors. + +* GADT data type decls e.g. + data S f a where + MkS :: g b -> S g b + Here `f` and `a` don't scope over the data constructor signatures. + Instead, we just kind-check the entire signature (including the result `S g b`), + relying on the fact that `S` is in scope with its initial kind `k1 -> k2 -> Type`; + doing so will constrain `k1` and `k2` appropriately. + +The arguments of each data constructor are always of kind (TYPE r) for some +r :: RuntimeRep. But in the case of a newytype, the argument kind must be +the same as the tycon result kind. Since we are trying to figure out the +tycon kind, kcConDecls must account for this, which is surprisingly tricky. +Again there are two cases to consider in `kcConDecl`: + +* Haskell 98 data type decls, e.g. + data T f a = MkT (f a) + * In the header, all the tycon binders are specified (here `f` and `a`) + and there is no result kind signature. + * The binders from the header scope over the data construtors. + * In the case of unlifted newtypes, the argument kind affects the tycon kind + newtype N = MkN Int# + Here `getInitialKind` will give `N` the result kind `TYPE r`, where `r` is + a unification variable, and `kcConDecls` should unify that `r` with + `IntRep` becuase of the `Int#` + + Solution (KCD1): just check that the argumet type has the same kind as the result + kind of the tycon. + +* GADT data type decls e.g. + data S f :: Type -> Type where + MkS :: g a -> S g a + * In the header, not all the tycon binders are specified (here just `f`), + and there can be a kind signature + * The kind signature may describe some, all, or none of the tycon binders. + Regardless, in the TcTyCon constructed by `getInitialKind`, the tyConResKind + is the signature, not the "ultimate" result type of the tycon (which is + usually Type) + * In the case of unlifted newtypes, we again want the argument kind to be the + same as the result kind of the tycon; but it's not so clear what /is/ the + result kind of the tycon, because of the signature stuff in the previous bullet. + + Solution (KCD2): kind-check the result type of the data constructor (here + `S g a`) and, for newtypes, ensure that the arugment has that same kind. + + (KCD3) The tycon's result kind `tc_res_kind` is not used at all in the GADT + case; rather it is accessed via looking up S's kind in the type environment + when kind-checking the result type of the data constructor. + +Note [Using TyVarTvs for kind-checking GADTs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data Proxy a where + MkProxy1 :: forall k (b :: k). Proxy b + MkProxy2 :: forall j (c :: j). Proxy c + +It seems reasonable that this should be accepted. But something very strange +is going on here: when we're kind-checking this declaration, we need to unify +the kind of `a` with k and j -- even though k and j's scopes are local to the type of +MkProxy{1,2}. + +In effect, we are simply gathering constraints on the shape of Proxy's +kind, with no skolemisation or implication constraints involved at all. + +The best approach we've come up with is to use TyVarTvs during the +kind-checking pass, rather than ordinary skolems. This is why we use +the "_Tv" variant, bindOuterSigTKBndrs_Tv. + +Our only goal is to gather constraints on the kind of the type constructor; +we do not certify that the data declaration is well-kinded. For example: + + data SameKind :: k -> k -> Type + data Bad a where + MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b) + +which would be accepted by kcConDecl because k1 and k2 are +TyVarTvs. It is correctly rejected in the second pass, tcConDecl. +(Test case: polykinds/TyVarTvKinds3) + +One drawback of this approach is sometimes it will accept a definition that +a (hypothetical) declarative specification would likely reject. As a general +rule, we don't want to allow polymorphic recursion without a CUSK. Indeed, +the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs +approach allows a limited form of polymorphic recursion *without* a CUSK. + +To wit: + data T a = forall k (b :: k). MkT (T b) Int + (test case: dependent/should_compile/T14066a) + +Note that this is polymorphically recursive, with the recursive occurrence +of T used at a kind other than a's kind. The approach outlined here accepts +this definition, because this kind is still a kind variable (and so the +TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a +way to describe exactly what declarations will be accepted and which will +be rejected (without a CUSK). However, the accepted definitions are indeed +well-kinded and any rejected definitions would be accepted with a CUSK, +and so this wrinkle need not cause anyone to lose sleep. + +Note [Recursion and promoting data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to allow promotion in a strongly connected component +when kind checking. + +Consider: + data T f = K (f (K Any)) + +When kind checking the `data T' declaration the local env contains the +mappings: + T -> ATcTyCon + K -> APromotionErr + +APromotionErr is only used for DataCons, and only used during type checking +in tcTyClGroup. + +The same restriction applies constructors in to "type data" declarations. +See Note [Type data declarations] in GHC.Rename.Module. + + +************************************************************************ +* * +\subsection{Type checking} +* * +************************************************************************ + +Note [Type checking recursive type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At this point we have completed *kind-checking* of a mutually +recursive group of type/class decls (done in kcTyClGroup). However, +we discarded the kind-checked types (eg RHSs of data type decls); +note that kcTyClDecl returns (). There are two reasons: + + * It's convenient, because we don't have to rebuild a + kinded HsDecl (a fairly elaborate type) + + * It's necessary, because after kind-generalisation, the + TyCons/Classes may now be kind-polymorphic, and hence need + to be given kind arguments. + +Example: + data T f a = MkT (f a) (T f a) +During kind-checking, we give T the kind T :: k1 -> k2 -> * +and figure out constraints on k1, k2 etc. Then we generalise +to get T :: forall k. (k->*) -> k -> * +So now the (T f a) in the RHS must be elaborated to (T k f a). + +However, during tcTyClDecl of T (above) we will be in a recursive +"knot". So we aren't allowed to look at the TyCon T itself; we are only +allowed to put it (lazily) in the returned structures. But when +kind-checking the RHS of T's decl, we *do* need to know T's kind (so +that we can correctly elaborate (T k f a). How can we get T's kind +without looking at T? Delicate answer: during tcTyClDecl, we extend + + *Global* env with T -> ATyCon (the (not yet built) final TyCon for T) + *Local* env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T) + +Then: + + * During GHC.Tc.Gen.HsType.tcTyVar we look in the *local* env, to get the + fully-known, not knot-tied TcTyCon for T. + + * Then, in GHC.Tc.Zonk.Type.zonkTcTypeToType (and zonkTcTyCon in particular) + we look in the *global* env to get the TyCon. + +This fancy footwork (with two bindings for T) is only necessary for the +TyCons or Classes of this recursive group. Earlier, finished groups, +live in the global env only. + +See also Note [Kind checking recursive type and class declarations] + +Note [Kind checking recursive type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before we can type-check the decls, we must kind check them. This +is done by establishing an "initial kind", which is a rather uninformed +guess at a tycon's kind (by counting arguments, mainly) and then +using this initial kind for recursive occurrences. + +The initial kind is stored in exactly the same way during +kind-checking as it is during type-checking (Note [Type checking +recursive type and class declarations]): in the *local* environment, +with ATcTyCon. But we still must store *something* in the *global* +environment. Even though we discard the result of kind-checking, we +sometimes need to produce error messages. These error messages will +want to refer to the tycons being checked, except that they don't +exist yet, and it would be Terribly Annoying to get the error messages +to refer back to HsSyn. So we create a TcTyCon and put it in the +global env. This tycon can print out its name and knows its kind, but +any other action taken on it will panic. Note that TcTyCons are *not* +knot-tied, unlike the rather valid but knot-tied ones that occur +during type-checking. + +Note [Declarations for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For wired-in things we simply ignore the declaration +and take the wired-in information. That avoids complications. +e.g. the need to make the data constructor worker name for + a constraint tuple match the wired-in one + +Note [Datatype return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several poorly lit corners around datatype/newtype return kinds. +This Note explains these. We cover data/newtype families and instances +in Note [Data family/instance return kinds]. + +data T a :: where ... -- See Point DT4 +newtype T a :: where ... -- See Point DT5 + +DT1 Where this applies: Only GADT syntax for data/newtype/instance declarations + can have declared return kinds. This Note does not apply to Haskell98 + syntax. + +DT2 Where these kinds come from: The return kind is part of the TyCon kind, gotten either + by checkInitialKind (standalone kind signature / CUSK) or + inferInitialKind. It is extracted by bindTyClTyVars in tcTyClDecl1. It is + then passed to tcDataDefn. + +DT3 Eta-expansion: Any forall-bound variables and function arguments in a result kind + become parameters to the type. That is, when we say + + data T a :: Type -> Type where ... + + we really mean for T to have two parameters. The second parameter + is produced by processing the return kind in maybeEtaExpandAlgTyCon, + called in tcDataDefn. + + See also Note [splitTyConKind] in GHC.Tc.Gen.HsType. + +DT4 Datatype return kind restriction: A data type return kind must end + in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By + "end in", we mean we strip any foralls and function arguments off before + checking. + + Examples: + data T1 :: Type -- good + data T2 :: Bool -> Type -- good + data T3 :: Bool -> forall k. Type -- strange, but still accepted + data T4 :: forall k. k -> Type -- good + data T5 :: Bool -- bad + data T6 :: Type -> Bool -- bad + + Exactly the same applies to data instance (but not data family) + declarations. Examples + data instance D1 :: Type -- good + data instance D2 :: Bool -> Type -- good + + We can "look through" type synonyms + type Star = Type + data T7 :: Bool -> Star -- good (synonym expansion ok) + type Arrow = (->) + data T8 :: Arrow Bool Type -- good (ditto) + + But we specifically do *not* do type family reduction here. + type family ARROW where + ARROW = (->) + data T9 :: ARROW Bool Type -- bad + + type family F a where + F Int = Bool + F Bool = Type + data T10 :: Bool -> F Bool -- bad + + The /principle/ here is that in the TyCon for a data type or data instance, + we must be able to lay out all the type-variable binders, one by one, until + we reach (TYPE xx). There is no place for a cast here. We could add one, + but let's not! + + This check is done in checkDataKindSig. For data declarations, this + call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl. + +DT5 Newtype return kind restriction. + If -XUnliftedNewtypes is not on, then newtypes are treated just + like datatypes --- see (4) above. + + If -XUnliftedNewtypes is on, then a newtype return kind must end in + TYPE xyz, for some xyz (after type synonym expansion). The "xyz" + may include type families, but the TYPE part must be visible + /without/ expanding type families (only synonyms). + + This kind is unified with the kind of the representation type (the + type of the one argument to the one constructor). See also steps + (2) and (3) of Note [Implementation of UnliftedNewtypes]. + + The checks are done in the same places as for datatypes. + Examples (assume -XUnliftedNewtypes): + + newtype N1 :: Type -- good + newtype N2 :: Bool -> Type -- good + newtype N3 :: forall r. Bool -> TYPE r -- good + + type family F (t :: Type) :: RuntimeRep + newtype N4 :: forall t -> TYPE (F t) -- good + + type family STAR where + STAR = Type + newtype N5 :: Bool -> STAR -- bad + +Note [Data family/instance return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Within this note, understand "instance" to mean data or newtype +instance, and understand "family" to mean data family. No type +families or classes here. Some examples: + +data family T a :: -- See Point DF56 + +data instance T [a] :: where ... -- See Point DF2 +newtype instance T [a] :: where ... -- See Point DF2 + +Here is the Plan for Data Families: + +DF0 Where these kinds come from: + + Families: The return kind is either written in a standalone signature + or extracted from a family declaration in getInitialKind. + If a family declaration is missing a result kind, it is assumed to be + Type. This assumption is in getInitialKind for CUSKs or + get_fam_decl_initial_kind for non-signature & non-CUSK cases. + + Instances: There are potentially *two* return kinds: + * Master kind: + The data family already has a known kind. The return kind of an instance + is then calculated by applying the data family tycon to the patterns + provided, as computed by the `tcFamTyPats fam_tc hs_pats` in the + tcDataFamInstHeader. + * Instance kind: + The kind specified by the user in GADT syntax. If H98 syntax is used, + with UnliftedNewtypes/UnliftedDatatypes, it defaults to newOpenTypeKind + for newtypes/datatypes, otherwise it defaults to liftedTypeKind. + This is checked or defaulted by the tc_kind_sig function within + tcDataFamInstHeader. Defaulting can be tricky for some cases, + See Note [Defaulting result kind of newtype/data family instance]. + See also DF3, below. + +DF1 In a data/newtype instance, we treat the kind of the /data family/, + once instantiated, as the "master kind" for the representation + TyCon. For example: + data family T1 :: Type -> Type -> Type + data instance T1 Int :: F Bool -> Type where ... + The "master kind" for the representation TyCon R:T1Int comes + from T1, not from the signature on the data instance. It is as + if we declared + data R:T1Int :: Type -> Type where ... + See Note [Liberalising data family return kinds] for an alternative + plan. But this current plan is simple, and ensures that all instances + are simple instantiations of the master, without strange casts. + + An example with non-trivial instantiation: + data family T2 :: forall k. Type -> k + data instance T2 :: Type -> Type -> Type where ... + Here 'k' gets instantiated with (Type -> Type), driven by + the signature on the 'data instance'. (See also DT3 of + Note [Datatype return kinds] about eta-expansion, which applies here, + too; see tcDataFamInstDecl's call of etaExpandAlgTyCon.) + + A newtype example: + + data Color = Red | Blue + type family Interpret (x :: Color) :: RuntimeRep where + Interpret 'Red = 'IntRep + Interpret 'Blue = 'WordRep + data family Foo (x :: Color) :: TYPE (Interpret x) + newtype instance Foo 'Red :: TYPE IntRep where + FooRedC :: Int# -> Foo 'Red + + Here we get that Foo 'Red :: TYPE (Interpret Red), and our + representation newtype looks like + newtype R:FooRed :: TYPE (Interpret Red) where + FooRedC :: Int# -> R:FooRed + Remember: the master kind comes from the /family/ tycon. + +DF2 /After/ this instantiation, the return kind of the master kind + must obey the usual rules for data/newtype return kinds (DT4, DT5) + of Note [Datatype return kinds]. Examples: + data family T3 k :: k + data instance T3 Type where ... -- OK + data instance T3 (Type->Type) where ... -- OK + data instance T3 (F Int) where ... -- Not OK + +DF3 Any kind signatures on the data/newtype instance are checked for + equality with the master kind (and hence may guide instantiation) + but are otherwise ignored. So in the T1 example above, we check + that (F Int ~ Type) by unification; but otherwise ignore the + user-supplied signature from the /family/ not the /instance/. + + We must be sure to instantiate any trailing invisible binders + before doing this unification. See the call to tcInstInvisibleBinders + in tcDataFamInstHeader. For example: + data family D :: forall k. k + data instance D :: Type -- forall k. k <: Type + data instance D :: Type -> Type -- forall k. k <: Type -> Type + -- NB: these do not overlap + we must instantiate D before unifying with the signature in the + data instance declaration + +DF4 We also (redundantly) check that any user-specified return kind + signature in the data instance also obeys DT4/DT5. For example we + reject + data family T1 :: Type -> Type -> Type + data instance T1 Int :: Type -> F Int + even if (F Int ~ Type). We could omit this check, because we + use the master kind; but it seems more uniform to check it, again + with checkDataKindSig. + +DF5 Data /family/ return kind restrictions. Consider + data family D8 a :: F a + where F is a type family. No data/newtype instance can instantiate + this so that it obeys the rules of DT4 or DT5. So GHC proactively + rejects the data /family/ declaration if it can never satisfy (DT4)/(DT5). + Remember that a data family supports both data and newtype instances. + + More precisely, the return kind of a data family must be either + * TYPE xyz (for some type xyz) or + * a kind variable + Only in these cases can a data/newtype instance possibly satisfy (DT4)/(DT5). + This is checked by the call to checkDataKindSig in tcFamDecl1. Examples: + + data family D1 :: Type -- good + data family D2 :: Bool -> Type -- good + data family D3 k :: k -- good + data family D4 :: forall k -> k -- good + data family D5 :: forall k. k -> k -- good + data family D6 :: forall r. TYPE r -- good + data family D7 :: Bool -> STAR -- bad (see STAR from point 5) + +DF6 Two return kinds for instances: If an instance has two return kinds, + one from the family declaration and one from the instance declaration + (see point DF3 above), they are unified. More accurately, we make sure + that the kind of the applied data family is a subkind of the user-written + kind. GHC.Tc.Gen.HsType.checkExpectedKind normally does this check for types, but + that's overkill for our needs here. Instead, we just instantiate any + invisible binders in the (instantiated) kind of the data family + (called lhs_kind in tcDataFamInstHeader) with tcInstInvisibleTyBinders + and then unify the resulting kind with the kind written by the user. + This unification naturally produces a coercion, which we can drop, as + the kind annotation on the instance is redundant (except perhaps for + effects of unification). + + This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes]. + +Note [Liberalising data family return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Could we allow this? + type family F a where { F Int = Type } + data family T a :: F a + data instance T Int where + MkT :: T Int + +In the 'data instance', T Int :: F Int, and F Int = Type, so all seems +well. But there are lots of complications: + +* The representation constructor R:TInt presumably has kind Type. + So the axiom connecting the two would have to look like + axTInt :: T Int ~ R:TInt |> sym axFInt + and that doesn't match expectation in DataFamInstTyCon + in AlgTyConFlav + +* The wrapper can't have type + $WMkT :: Int -> T Int + because T Int has the wrong kind. It would have to be + $WMkT :: Int -> (T Int) |> axFInt + +* The code for $WMkT would also be more complicated, needing + two coherence coercions. Try it! + +* Code for pattern matching would be complicated in an + exactly dual way. + +So yes, we could allow this, but we currently do not. That's +why we have DF2 in Note [Data family/instance return kinds]. + +Note [Implementation of UnliftedNewtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Expected behavior of UnliftedNewtypes: + +* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst +* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98 + +What follows is a high-level overview of the implementation of the +proposal. + +STEP 1: Getting the initial kind, as done by inferInitialKind. We have +two sub-cases: + +* With a SAK/CUSK: no change in kind-checking; the tycon is given the kind + the user writes, whatever it may be. + +* Without a SAK/CUSK: If there is no kind signature, the tycon is given + a kind `TYPE r`, for a fresh unification variable `r`. We do this even + when -XUnliftedNewtypes is not on; see , below. + +STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs. +The key function here is kcConDecl, which looks at an individual constructor +declaration. When we are processing a newtype (but whether or not -XUnliftedNewtypes +is enabled; see , below), we generate a correct ContextKind +for the checking argument types: see getArgExpKind. + +Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is +enabled (we use r0 to denote a unification variable): + +newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) ++ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0) + is the kind that inferInitialKind invented for (Foo rep). + +data Color = Red | Blue +type family Interpret (x :: Color) :: RuntimeRep where + Interpret 'Red = 'IntRep + Interpret 'Blue = 'WordRep +data family Foo (x :: Color) :: TYPE (Interpret x) +newtype instance Foo 'Red = FooRedC Int# ++ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep + +Note that, in the GADT case, we might have a kind signature with arrows +(newtype XYZ a b :: Type -> Type where ...). We want only the final +component of the kind for checking in kcConDecl, so we call etaExpanAlgTyCon +in kcTyClDecl. + +STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function +here is tcConDecl. Once again, we must use getArgExpKind to ensure that the +representation type's kind matches that of the newtype, for two reasons: + + A. It is possible that a GADT has a CUSK. (Note that this is *not* + possible for H98 types.) Recall that CUSK types don't go through + kcTyClDecl, so we might not have done this kind check. + B. We need to produce the coercion to put on the argument type + if the kinds are different (for both H98 and GADT). + +Example of (B): + +type family F a where + F Int = LiftedRep + +newtype N :: TYPE (F Int) where + MkN :: Int -> N + +We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where +axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the +newtype kind, which is the principal correctness condition for newtypes. + +Wrinkle: Consider (#17021, typecheck/should_fail/T17021) + + type family Id (x :: a) :: a where + Id x = x + + newtype T :: TYPE (Id LiftedRep) where + MkT :: Int -> T + + In the type of MkT, we must end with (Int |> TYPE (sym axId)) -> T, + never Int -> (T |> TYPE axId); otherwise, the result type of the + constructor wouldn't match the datatype. However, type-checking the + HsType T might reasonably result in (T |> hole). We thus must ensure + that this cast is dropped, forcing the type-checker to add one to + the Int instead. + + Why is it always safe to drop the cast? This result type is type-checked by + tcHsOpenType, so its kind definitely looks like TYPE r, for some r. It is + important that even after dropping the cast, the type's kind has the form + TYPE r. This is guaranteed by restrictions on the kinds of datatypes. + For example, a declaration like `newtype T :: Id Type` is rejected: a + newtype's final kind always has the form TYPE r, just as we want. + +Note that this is possible in the H98 case only for a data family, because +the H98 syntax doesn't permit a kind signature on the newtype itself. + +There are also some changes for dealing with families: + +1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if + UnliftedNewtypes is on. This allows us to write things like: + data family Foo :: TYPE 'IntRep + +2. In a newtype instance (with -XUnliftedNewtypes), if the user does + not write a kind signature, we want to allow the possibility that + the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind. + This is done in tcDataFamInstHeader in GHC.Tc.TyCl.Instance. Example: + + data family Bar (a :: RuntimeRep) :: TYPE a + newtype instance Bar 'IntRep = BarIntC Int# + newtype instance Bar 'WordRep :: TYPE 'WordRep where + BarWordC :: Word# -> Bar 'WordRep + + The data instance corresponding to IntRep does not specify a kind signature, + so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable). + The data instance corresponding to WordRep does have a kind signature, so + we use that kind signature. + +3. A data family and its newtype instance may be declared with slightly + different kinds. See point DF6 in Note [Data family/instance return kinds] + +There's also a change in the renamer: + +* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means + for a newtype to have a CUSK. This is necessary since UnliftedNewtypes + means that, for newtypes without kind signatures, we must use the field + inside the data constructor to determine the result kind. + See Note [Unlifted Newtypes and CUSKs] for more detail. + +For completeness, it was also necessary to make coerce work on +unlifted types, resolving #13595. + +: It's tempting to think that the expected kind for a newtype +constructor argument when -XUnliftedNewtypes is *not* enabled should just be Type. +But this leads to difficulty in suggesting to enable UnliftedNewtypes. Here is +an example: + + newtype A = MkA Int# + +If we expect the argument to MkA to have kind Type, then we get a kind-mismatch +error. The problem is that there is no way to connect this mismatch error to +-XUnliftedNewtypes, and suggest enabling the extension. So, instead, we allow +the A to type-check, but then find the problem when doing validity checking (and +where we get make a suitable error message). One potential worry is + + {-# LANGUAGE PolyKinds #-} + newtype B a = MkB a + +This turns out OK, because unconstrained RuntimeReps default to LiftedRep, just +as we would like. Another potential problem comes in a case like + + -- no UnliftedNewtypes + + data family D :: k + newtype instance D = MkD Any + +Here, we want inference to tell us that k should be instantiated to Type in +the instance. With the approach described here (checking for Type only in +the validity checker), that will not happen. But I cannot think of a non-contrived +example that will notice this lack of inference, so it seems better to improve +error messages than be able to infer this instantiation. + +Note [Implementation of UnliftedDatatypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Expected behavior of UnliftedDatatypes: + +* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0265-unlifted-datatypes.rst +* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/265 + +The implementation heavily leans on Note [Implementation of UnliftedNewtypes]. + +In the frontend, the following tweaks have been made in the typechecker: + +* STEP 1: In the inferInitialKinds phase, newExpectedKind gives data type + constructors a result kind of `TYPE r` with a fresh unification variable + `r :: RuntimeRep` when there is a SAKS. (Same as for UnliftedNewtypes.) + Not needed with a CUSK, because it can't specify result kinds. + If there's a GADTSyntax result kind signature, we keep on using that kind. + + Similarly, for data instances without a kind signature, we use + `TYPE r` as the result kind, to support the following code: + + data family F a :: UnliftedType + data instance F Int = TInt + + The omission of a kind signature for `F` should not mean a result kind + of `Type` (and thus a kind error) here. + +* STEP 2: No change to kcTyClDecl. + +* STEP 3: In GHC.Tc.Gen.HsType.checkDataKindSig, we make sure that the result + kind of the data declaration is actually `Type` or `TYPE (BoxedRep l)`, + for some `l`. If UnliftedDatatypes is not activated, we emit an error with a + suggestion in the latter case. + + Why not start out with `TYPE (BoxedRep l)` in the first place? Because then + we get worse kind error messages in e.g. saks_fail010: + + - Couldn't match expected kind: TYPE ('GHC.Types.BoxedRep t0) + - with actual kind: * -> * + + Expected a type, but found something with kind ‘* -> *’ + In the data type declaration for ‘T’ + + It seems `TYPE r` already has appropriate pretty-printing support. + +The changes to Core, STG and Cmm are of rather cosmetic nature. +The IRs are already well-equipped to handle unlifted types, and unlifted +datatypes are just a new sub-class thereof. +-} + +tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]) +tcTyClDecl roles_info (L loc decl) + | Just thing <- wiredInNameTyThing_maybe (tcdName decl) + = case thing of -- See Note [Declarations for wired-in things] + ATyCon tc -> return ((tc, []), wiredInDerivInfo tc decl) + _ -> pprPanic "tcTyClDecl" (ppr thing) + + | otherwise + = setSrcSpanA loc $ tcAddDeclCtxt decl $ + do { traceTc "---- tcTyClDecl ---- {" (ppr decl) + ; (tc_vi@(tc, _), deriv_infos) <- tcTyClDecl1 Nothing roles_info decl + ; traceTc "---- tcTyClDecl end ---- }" (ppr tc) + ; return (tc_vi, deriv_infos) } + +noDerivInfos :: a -> (a, [DerivInfo]) +noDerivInfos a = (a, []) + +noEqnValidityInfos :: a -> (a, [TyFamEqnValidityInfo]) +noEqnValidityInfos a = (a, []) + +wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo] +wiredInDerivInfo tycon decl + | DataDecl { tcdDataDefn = dataDefn } <- decl + , HsDataDefn { dd_derivs = derivs } <- dataDefn + = [ DerivInfo { di_rep_tc = tycon + , di_scoped_tvs = + if isPrimTyCon tycon + then [] -- no tyConTyVars + else mkTyVarNamePairs (tyConTyVars tycon) + , di_clauses = derivs + , di_ctxt = tcMkDeclCtxt decl } ] +wiredInDerivInfo _ _ = [] + + -- "type family" declarations +tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]) +tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) + = fmap noDerivInfos $ + tcFamDecl1 parent fd + + -- "type" synonym declaration +tcTyClDecl1 _parent roles_info + (SynDecl { tcdLName = L _ tc_name + , tcdRhs = rhs }) + = assert (isNothing _parent ) + fmap ( noDerivInfos . noEqnValidityInfos ) $ + tcTySynRhs roles_info tc_name rhs + + -- "data/newtype" declaration +tcTyClDecl1 _parent roles_info + decl@(DataDecl { tcdLName = L _ tc_name + , tcdDataDefn = defn }) + = assert (isNothing _parent) $ + fmap (\(tc, deriv_info) -> ((tc, []), deriv_info)) $ + tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn + +tcTyClDecl1 _parent roles_info + (ClassDecl { tcdLName = L _ class_name + , tcdCtxt = hs_ctxt + , tcdMeths = meths + , tcdFDs = fundeps + , tcdSigs = sigs + , tcdATs = ats + , tcdATDefs = at_defs }) + = assert (isNothing _parent) $ + do { clas <- tcClassDecl1 roles_info class_name hs_ctxt + meths fundeps sigs ats at_defs + ; return (noDerivInfos $ noEqnValidityInfos (classTyCon clas)) } + + +{- ********************************************************************* +* * + Class declarations +* * +********************************************************************* -} + +tcClassDecl1 :: RolesInfo -> Name -> Maybe (LHsContext GhcRn) + -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn] + -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn] + -> TcM Class +tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs + = fixM $ \ clas -> -- We need the knot because 'clas' is passed into tcClassATs + bindTyClTyVars class_name $ \ tc_bndrs res_kind -> + do { checkClassKindSig res_kind + ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr tc_bndrs) + ; let tycon_name = class_name -- We use the same name + roles = roles_info tycon_name -- for TyCon and Class + + ; (ctxt, fds, sig_stuff, at_stuff) + <- pushLevelAndSolveEqualities skol_info tc_bndrs $ + -- The (binderVars tc_bndrs) is needed bring into scope the + -- skolems bound by the class decl header (#17841) + do { ctxt <- tcHsContext hs_ctxt + ; fds <- mapM (addLocM tc_fundep) fundeps + ; sig_stuff <- tcClassSigs class_name sigs meths + ; at_stuff <- tcClassATs class_name clas ats at_defs + ; return (ctxt, fds, sig_stuff, at_stuff) } + + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: (typecheck/should_fail/T17562) + -- type C :: Type -> Type -> Constraint + -- class (forall a. a b ~ a c) => C b c + -- The kind of `a` is unconstrained. + ; dvs <- candidateQTyVarsOfTypes ctxt + ; let err_ctx tidy_env = do { (tidy_env2, ctxt) <- zonkTidyTcTypes tidy_env ctxt + ; return (tidy_env2, UninfTyCtx_ClassContext ctxt) } + ; doNotQuantifyTyVars dvs err_ctx + + -- The pushLevelAndSolveEqualities will report errors for any + -- unsolved equalities, so these zonks should not encounter + -- any unfilled coercion variables unless there is such an error + -- The zonk also squeeze out the TcTyCons, and converts + -- Skolems to tyvars. + ; (bndrs, ctxt, sig_stuff) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { ctxt <- zonkTcTypesToTypesX ctxt + ; sig_stuff <- mapM zonkTcMethInfoToMethInfoX sig_stuff + -- ToDo: do we need to zonk at_stuff? + ; return (bndrs, ctxt, sig_stuff) } + + -- TODO: Allow us to distinguish between abstract class, + -- and concrete class with no methods (maybe by + -- specifying a trailing where or not + + ; mindef <- tcClassMinimalDef class_name sigs sig_stuff + ; is_boot <- tcIsHsBootOrSig + ; let abstract_class = 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. + + unary_class = case ctxt ++ map sndOf3 sig_stuff of + [ty] -> isBoxedType ty + _ -> False + -- Use a unary class if the data constructor + -- has exactly one, boxed value field + -- i.e. exactly one operation or superclass taken together + -- See (UCM10) in Note [Unary class magic] in GHC.Core.TyCon + + ; clas <- if abstract_class + then buildAbstractClass class_name bndrs roles fds + else buildClass class_name bndrs roles fds ctxt + at_stuff sig_stuff mindef unary_class + ; traceTc "tcClassDecl" (ppr fundeps $$ ppr bndrs $$ + ppr fds) + ; return clas } + where + skol_info = TyConSkol ClassFlavour class_name + + tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var]) + tc_fundep (FunDep _ tvs1 tvs2) + = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; + ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; + ; return (tvs1',tvs2') } + + +{- Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following is an example of associated type defaults: + + class C a where + data D a + + type F a b :: * + type F a b = [a] -- Default + +Note that we can get default definitions only for type families, not data +families. +-} + +tcClassATs :: Name -- The class name (not knot-tied) + -> Class -- The class parent of this associated type + -> [LFamilyDecl GhcRn] -- Associated types. + -> [LTyFamDefltDecl GhcRn] -- Associated type defaults. + -> TcM [ClassATItem] +tcClassATs class_name cls ats at_defs + = do { -- Complain about associated type defaults for non associated-types + sequence_ [ failWithTc $ TcRnIllegalInstance + $ IllegalFamilyInstance $ InvalidAssoc + $ InvalidAssocDefault + $ AssocDefaultNotAssoc class_name n + | n <- map at_def_tycon at_defs + , not (n `elemNameSet` at_names) ] + ; mapM tc_at ats } + where + at_def_tycon :: LTyFamDefltDecl GhcRn -> Name + at_def_tycon = tyFamInstDeclName . unLoc + + at_fam_name :: LFamilyDecl GhcRn -> Name + at_fam_name = familyDeclName . unLoc + + at_names = mkNameSet (map at_fam_name ats) + + at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn] + -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' + at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv + (at_def_tycon at_def) [at_def]) + emptyNameEnv at_defs + + tc_at at = do { (fam_tc, val_infos) <- addLocM (tcFamDecl1 (Just cls)) at + ; mapM_ (checkTyFamEqnValidityInfo fam_tc) val_infos + ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) + `orElse` [] + ; atd <- tcDefaultAssocDecl fam_tc at_defs + ; return (ATI fam_tc atd) } + +------------------------- +tcDefaultAssocDecl :: + TyCon -- ^ Family TyCon (not knot-tied) + -> [LTyFamDefltDecl GhcRn] -- ^ Defaults + -> TcM (Maybe (KnotTied Type, TyFamEqnValidityInfo)) -- ^ Type checked RHS +tcDefaultAssocDecl _ [] + = return Nothing -- No default declaration + +tcDefaultAssocDecl _ (d1:_:_) + = failWithTc $ TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocDefault $ + AssocMultipleDefaults (tyFamInstDeclName (unLoc d1)) + +tcDefaultAssocDecl fam_tc + [L loc (TyFamInstDecl { tfid_eqn = + FamEqn { feqn_tycon = L _ tc_name + , feqn_bndrs = outer_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty }})] + = -- See Note [Type-checking default assoc decls] + let + inst_flav = + TyConInstFlavour + { tyConInstFlavour = tyConFlavour fam_tc + , tyConInstIsDefault = True + } + in + setSrcSpanA loc $ + tcAddFamInstCtxt inst_flav tc_name $ + do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) + ; let fam_tc_name = tyConName fam_tc + vis_arity = length (tyConVisibleTyVars fam_tc) + vis_pats = numVisibleArgs hs_pats + + -- Kind of family check + ; assert (fam_tc_name == tc_name) $ + checkTc (isTypeFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyCategoryMismatch fam_tc + + -- Arity check + ; checkTc (vis_pats == vis_arity) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyArityMismatch fam_tc vis_arity + + -- Typecheck RHS + -- + -- You might think we should pass in some AssocInstInfo, as we're looking + -- at an associated type. But this would be wrong, because an associated + -- type default LHS can mention *different* type variables than the + -- enclosing class. So it's treated more as a freestanding beast. + ; (qtvs, non_user_tvs, pats, rhs_ty) + <- tcTyFamInstEqnGuts fam_tc NotAssociated + outer_bndrs hs_pats hs_rhs_ty + + ; let fam_tvs = tyConTyVars fam_tc + ; traceTc "tcDefaultAssocDecl 2" (vcat + [ text "hs_pats" <+> ppr hs_pats + , text "hs_rhs_ty" <+> ppr hs_rhs_ty + , text "fam_tvs" <+> ppr fam_tvs + , text "qtvs" <+> ppr qtvs + -- NB: Do *not* print `pats` or rhs_ty here, as they can mention + -- knot-tied TyCons. See #18648. + ]) + ; let subst = case traverse getTyVar_maybe pats of + Just cpt_tvs -> zipTvSubst cpt_tvs (mkTyVarTys fam_tvs) + Nothing -> emptySubst + -- The Nothing case can only be reached in invalid + -- associated type family defaults. In such cases, we + -- simply create an empty substitution and let GHC fall + -- over later, in GHC.Tc.Validity.checkValidAssocTyFamDeflt. + -- See Note [Type-checking default assoc decls]. + + ; pure $ Just ( substTyUnchecked subst rhs_ty + , VI { vi_loc = locA loc + , vi_qtvs = qtvs + , vi_non_user_tvs = non_user_tvs + , vi_pats = pats + , vi_rhs = rhs_ty } ) + -- We perform checks for well-formedness and validity later, in + -- GHC.Tc.Validity.checkValidAssocTyFamDeflt. + } + +{- Note [Type-checking default assoc decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this default declaration for an associated type + + class C a where + type F (a :: k) b :: Type + type F (x :: j) y = Proxy x -> y + +Note that the class variable 'a' doesn't scope over the default assoc +decl, nor do the type variables `k` and `b`. Instead, the default decl is +treated more like a top-level type instance. However, we store the default rhs +(Proxy x -> y) in F's TyCon, using F's own type variables, so we need to +convert it to (Proxy a -> b). We do this in the tcDefaultAssocDecl function by +creating a substitution [j |-> k, x |-> a, b |-> y] and applying this +substitution to the RHS. + +In order to create this substitution, we must first ensure that all of +the arguments in the default instance consist of distinct type variables. +Checking for this property proves surprisingly tricky. Three potential places +where GHC could check for this property include: + +1. Before typechecking (in the parser or renamer) +2. During typechecking (in tcDefaultAssocDecl) +3. After typechecking (using GHC.Tc.Validity) + +Currently, GHC picks option (3) and implements this check using +GHC.Tc.Validity.checkValidAssocTyFamDeflt. GHC previously used options (1) and +(2), but neither option quite worked out for reasons that we will explain +shortly. + +The first thing that checkValidAssocTyFamDeflt does is check that all arguments +in an associated type family default are type variables. As a motivating +example, consider this erroneous program (inspired by #11361): + + class C a where + type F (a :: k) b :: Type + type F x b = x + +If you squint, you'll notice that the kind of `x` is actually Type. However, +we cannot substitute from [Type |-> k], so we reject this default. This also +explains why GHC no longer implements option (1) above, since figuring out that +`x`'s kind is Type would be much more difficult without the knowledge that the +typechecker provides. + +Next, checkValidAssocTyFamDeflt checks that all arguments are distinct. Here is +another offending example, this time taken from #13971: + + class C2 (a :: j) where + type F2 (a :: j) (b :: k) + type F2 (x :: z) y = SameKind x y + data SameKind :: k -> k -> Type + +All of the arguments in the default equation for `F2` are type variables, so +that passes the first check. However, if we were to build this substitution, +then both `j` and `k` map to `z`! In terms of visible kind application, it's as +if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear +that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is +also rejected. + +There is one more design consideration in play here: what error message should +checkValidAssocTyFamDeflt produce if one of its checks fails? Ideally, it would +be something like this: + + Illegal duplicate variable ‘z’ in: + ‘type F2 @z @z x y = ...’ + The arguments to ‘F2’ must all be distinct type variables + +This requires printing out the arguments to the associated type family. This +can be dangerous, however. Consider this example, adapted from #18648: + + class C3 a where + type F3 a + type F3 (F3 a) = a + +F3's default is illegal, since its argument is not a bare type variable. But +note that when we typecheck F3's default, the F3 type constructor is knot-tied. +Therefore, if we print the type `F3 a` in an error message, GHC will diverge! +This is the reason why GHC no longer implements option (2) above and instead +waits until /after/ typechecking has finished, at which point the typechecker +knot has been worked out. + +As one final point, one might worry that the typechecker knot could cause the +substitution that tcDefaultAssocDecl creates to diverge, but this is not the +case. Since the LHS of a valid associated type family default is always just +variables, it won't contain any tycons. Accordingly, the patterns used in the +substitution won't actually be knot-tied, even though we're in the knot. (This +is too delicate for my taste, but it works.) If we're dealing with /invalid/ +default, such as F3's above, then we simply create an empty substitution and +rely on checkValidAssocTyFamDeflt throwing an error message afterwards before +any damage is done. +-} + +{- ********************************************************************* +* * + Type family declarations +* * +********************************************************************* -} + +tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM (TyCon, [TyFamEqnValidityInfo]) +tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info + , fdLName = tc_lname@(L _ tc_name) + , fdResultSig = L _ sig + , fdInjectivityAnn = inj }) + | DataFamily <- fam_info + = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do + { traceTc "tcFamDecl1 data family:" (ppr tc_name) + ; checkFamFlag tc_name + + -- Check that the result kind is OK + -- We allow things like + -- data family T (a :: Type) :: forall k. k -> Type + -- We treat T as having arity 1, but result kind forall k. k -> Type + -- But we want to check that the result kind finishes in + -- Type or a kind-variable + -- For the latter, consider + -- data family D a :: forall k. Type -> k + -- When UnliftedNewtypes is enabled, we loosen this restriction + -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1). + -- See also Note [Datatype return kinds] + ; checkDataKindSig DataFamilySort res_kind + ; tc_rep_name <- newTyConRepName tc_name + ; let inj = Injective $ replicate (length tc_bndrs) True + tycon = mkFamilyTyCon tc_name tc_bndrs + res_kind + (resultVariableName sig) + (DataFamilyTyCon tc_rep_name) + parent inj + ; return (tycon, []) } + + | OpenTypeFamily <- fam_info + = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do + { traceTc "tcFamDecl1 open type family:" (ppr tc_name) + ; checkFamFlag tc_name + ; inj' <- tcInjectivity tc_bndrs inj + ; checkResultSigFlag tc_name sig -- check after injectivity for better errors + ; let tycon = mkFamilyTyCon tc_name tc_bndrs res_kind + (resultVariableName sig) OpenSynFamilyTyCon + parent inj' + ; return (tycon, []) } + + | ClosedTypeFamily mb_eqns <- fam_info + = -- Closed type families are a little tricky, because they contain the definition + -- of both the type family and the equations for a CoAxiom. + do { traceTc "tcFamDecl1 Closed type family:" (ppr tc_name) + -- the variables in the header scope only over the injectivity + -- declaration but this is not involved here + ; (inj', tc_bndrs, res_kind) + <- bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> + do { inj' <- tcInjectivity tc_bndrs inj + ; return (inj', tc_bndrs, res_kind) } + + ; checkFamFlag tc_name -- make sure we have -XTypeFamilies + ; checkResultSigFlag tc_name sig + + -- If Nothing, this is an abstract family in a hs-boot file; + -- but eqns might be empty in the Just case as well + ; case mb_eqns of + Nothing -> + let tc = mkFamilyTyCon tc_name tc_bndrs res_kind + (resultVariableName sig) + AbstractClosedSynFamilyTyCon parent + inj' + in return (tc, []) + Just eqns -> do { + + -- Process the equations, creating CoAxBranches + ; let tc_fam_tc = mkTcTyCon tc_name tc_bndrs res_kind + noTcTyConScopedTyVars + False {- this doesn't matter here -} + ClosedTypeFamilyFlavour + + ; (branches, axiom_validity_infos) <- + unzip <$> mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns + -- Do not attempt to drop equations dominated by earlier + -- ones here; in the case of mutual recursion with a data + -- type, we get a knot-tying failure. Instead we check + -- for this afterwards, in GHC.Tc.Validity.checkValidCoAxiom + -- Example: tc265 + + -- Create a CoAxiom, with the correct src location. + ; co_ax_name <- newFamInstAxiomName tc_lname [] + + ; let mb_co_ax + | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list + | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) + + fam_tc = mkFamilyTyCon tc_name tc_bndrs res_kind (resultVariableName sig) + (ClosedSynFamilyTyCon mb_co_ax) parent inj' + + -- We check for instance validity later, when doing validity + -- checking for the tycon. Exception: checking equations + -- overlap done by dropDominatedAxioms + ; return (fam_tc, axiom_validity_infos) } } + +-- | Maybe return a list of Bools that say whether a type family was declared +-- injective in the corresponding type arguments. Length of the list is equal to +-- the number of arguments (including implicit kind/coercion arguments). +-- True on position +-- N means that a function is injective in its Nth argument. False means it is +-- not. +tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) + -> TcM Injectivity +tcInjectivity _ Nothing + = return NotInjective + + -- User provided an injectivity annotation, so for each tyvar argument we + -- check whether a type family was declared injective in that argument. We + -- return a list of Bools, where True means that corresponding type variable + -- was mentioned in lInjNames (type family is injective in that argument) and + -- False means that it was not mentioned in lInjNames (type family is not + -- injective in that type variable). We also extend injectivity information to + -- kind variables, so if a user declares: + -- + -- type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a + -- + -- then we mark both `a` and `k1` as injective. + -- NB: the return kind is considered to be *input* argument to a type family. + -- Since injectivity allows to infer input arguments from the result in theory + -- we should always mark the result kind variable (`k3` in this example) as + -- injective. The reason is that result type has always an assigned kind and + -- therefore we can always infer the result kind if we know the result type. + -- But this does not seem to be useful in any way so we don't do it. (Another + -- reason is that the implementation would not be straightforward.) +tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames))) + = setSrcSpanA loc $ + do { let tvs = binderVars tcbs + ; dflags <- getDynFlags + -- Fail eagerly to avoid reporting injectivity errors when + -- TypeFamilyDependencies is not enabled. + ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) + TcRnTyFamDepsDisabled + ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames + ; inj_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars inj_tvs -- zonk the kinds + ; let inj_ktvs = filterVarSet isTyVar $ -- no injective coercion vars + closeOverKinds (mkVarSet inj_tvs) + ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs + ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs + , ppr inj_ktvs, ppr inj_bools ]) + ; return $ Injective inj_bools } + +tcTySynRhs :: RolesInfo -> Name + -> LHsType GhcRn -> TcM TyCon +tcTySynRhs roles_info tc_name hs_ty + = bindTyClTyVars tc_name $ \ tc_bndrs res_kind -> + do { env <- getLclEnv + ; traceTc "tc-syn" (ppr tc_name $$ ppr (getLclEnvRdrEnv env)) + ; rhs_ty <- pushLevelAndSolveEqualities skol_info tc_bndrs $ + tcCheckLHsTypeInContext hs_ty (TheKind res_kind) + + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: (typecheck/should_fail/T17567) + -- type T = forall a. Proxy a + -- The kind of `a` is unconstrained. + ; dvs <- candidateQTyVarsOfType rhs_ty + ; let err_ctx tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty + ; return (tidy_env2, UninfTyCtx_TySynRhs rhs_ty) } + ; doNotQuantifyTyVars dvs err_ctx + + ; (bndrs, rhs_ty) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { rhs_ty <- zonkTcTypeToTypeX rhs_ty + ; return (bndrs, rhs_ty) } + ; let roles = roles_info tc_name + ; return (buildSynTyCon tc_name bndrs res_kind roles rhs_ty) } + where + skol_info = TyConSkol TypeSynonymFlavour tc_name + +tcDataDefn :: ErrCtxtMsg -> RolesInfo -> Name + -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo]) + -- NB: not used for newtype/data instances (whether associated or not) +tcDataDefn err_ctxt roles_info tc_name + (HsDataDefn { dd_cType = cType + , dd_ctxt = ctxt + , dd_kindSig = mb_ksig -- Already in tc's kind + -- via inferInitialKinds + , dd_cons = cons + , dd_derivs = derivs }) + = bindTyClTyVars tc_name $ \ tc_bndrs res_kind -> + -- The TyCon tyvars must scope over + -- - the stupid theta (dd_ctxt) + -- - for H98 constructors only, the ConDecl + -- But it does no harm to bring them into scope + -- over GADT ConDecls as well; and it's awkward not to + do { gadt_syntax <- dataDeclChecks tc_name ctxt cons + + ; tcg_env <- getGblEnv + ; let hsc_src = tcg_src tcg_env + ; unless (mk_permissive_kind hsc_src cons) $ + checkDataKindSig (DataDeclSort (dataDefnConsNewOrData cons)) res_kind + + ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $ + tcHsContext ctxt + + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: (typecheck/should_fail/T17567StupidTheta) + -- data (forall a. a b ~ a c) => T b c + -- The kind of 'a' is unconstrained. + ; dvs <- candidateQTyVarsOfTypes stupid_tc_theta + ; let err_ctx tidy_env + = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env stupid_tc_theta + ; return (tidy_env2, UninfTyCtx_DataContext theta) } + ; doNotQuantifyTyVars dvs err_ctx + + -- Check that we don't use kind signatures without the extension + ; kind_signatures <- xoptM LangExt.KindSignatures + ; case mb_ksig of + Just (L _ ksig) + | not kind_signatures + -> addErrTc $ TcRnKindSignaturesDisabled (Right (tc_name, ksig)) + _ -> return () + + ; (bndrs, stupid_theta, res_kind) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { stupid_theta <- zonkTcTypesToTypesX stupid_tc_theta + ; res_kind <- zonkTcTypeToTypeX res_kind + ; return (bndrs, stupid_theta, res_kind) } + + ; tycon <- fixM $ \ rec_tycon -> do + { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons + ; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons + ; tc_rep_nm <- newTyConRepName tc_name + + ; return (mkAlgTyCon tc_name + bndrs + res_kind + (roles_info tc_name) + (fmap unLoc cType) + stupid_theta tc_rhs + (VanillaAlgTyCon tc_rep_nm) + gadt_syntax) + } + + ; let scoped_tvs = mkTyVarNamePairs (binderVars tc_bndrs) + -- scoped_tvs: still the skolem TcTyVars + deriv_info = DerivInfo { di_rep_tc = tycon + , di_scoped_tvs = scoped_tvs + , di_clauses = derivs + , di_ctxt = err_ctxt } + ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tc_bndrs) + ; return (tycon, [deriv_info]) } + where + skol_info = TyConSkol flav tc_name + flav = newOrDataToFlavour (dataDefnConsNewOrData cons) + + -- Abstract data types in hsig files can have arbitrary kinds, + -- because they may be implemented by type synonyms + -- (which themselves can have arbitrary kinds, not just *). See #13955. + -- + -- Note that this is only a property that data type declarations possess, + -- so one could not have, say, a data family instance in an hsig file that + -- has kind `Bool`. Therefore, this check need only occur in the code that + -- typechecks data type declarations. + mk_permissive_kind HsigFile (DataTypeCons _ []) = True + mk_permissive_kind _ _ = False + + -- In an hs-boot or a signature file, + -- a 'data' declaration with no constructors + -- indicates a nominally distinct abstract data type. + mk_tc_rhs (isHsBootOrSig -> True) _ (DataTypeCons _ []) + = return AbstractTyCon + + mk_tc_rhs _ tycon data_cons = case data_cons of + DataTypeCons is_type_data data_cons -> return $ + mkLevPolyDataTyConRhs + (isFixedRuntimeRepKind (tyConResKind tycon)) + is_type_data + data_cons + NewTypeCon data_con -> mkNewTyConRhs tc_name tycon data_con + +------------------------- +kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () +-- Used for the equations of a closed type family only +-- Not used for data/type instances +kcTyFamInstEqn tc_fam_tc + (L loc (FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = outer_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty })) + = setSrcSpanA loc $ + do { traceTc "kcTyFamInstEqn" (vcat + [ text "tc_name =" <+> ppr eqn_tc_name + , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) + , text "feqn_bndrs =" <+> ppr outer_bndrs + , text "feqn_pats =" <+> ppr hs_pats ]) + + ; checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats + + ; discardResult $ + bindOuterFamEqnTKBndrs_Q_Tv outer_bndrs $ + do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats + ; tcCheckLHsTypeInContext hs_rhs_ty (TheKind res_kind) } + -- Why "_Tv" here? Consider (#14066) + -- type family Bar x y where + -- Bar (x :: a) (y :: b) = Int + -- Bar (x :: c) (y :: d) = Bool + -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately + } + +-------------------------- +tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn + -> TcM (KnotTied CoAxBranch, TyFamEqnValidityInfo) +-- Needs to be here, not in GHC.Tc.TyCl.Instance, because closed families +-- (typechecked here) have TyFamInstEqns + +tcTyFamInstEqn fam_tc mb_clsinfo + (L loc (FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = outer_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty })) + = setSrcSpanA loc $ + do { traceTc "tcTyFamInstEqn" $ + vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats + , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc) + , case mb_clsinfo of + NotAssociated {} -> empty + InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ] + + ; checkTyFamInstEqn fam_tc eqn_tc_name hs_pats + + ; (qtvs, non_user_tvs, pats, rhs_ty) + <- tcTyFamInstEqnGuts fam_tc mb_clsinfo + outer_bndrs hs_pats hs_rhs_ty + -- Don't print results they may be knot-tied + -- (tcFamInstEqnGuts zonks to Type) + + ; let ax = mkCoAxBranch qtvs [] [] pats rhs_ty + (map (const Nominal) qtvs) + (locA loc) + vi = VI { vi_loc = locA loc + , vi_qtvs = qtvs + , vi_non_user_tvs = non_user_tvs + , vi_pats = pats + , vi_rhs = rhs_ty } + + ; return (ax, vi) } + +checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg p tm ty] -> TcM () +checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats = + do { -- Ensure that each equation's type constructor is for the right + -- type family. E.g. barf on + -- type family F a where { G Int = Bool } + let tc_fam_tc_name = getName tc_fam_tc + ; checkTc (tc_fam_tc_name == eqn_tc_name) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + TyFamNameMismatch tc_fam_tc_name eqn_tc_name + + -- Check the arity of visible arguments + -- If we wait until validity checking, we'll get kind errors + -- below when an arity error will be much easier to understand. + ; let vis_arity = length (tyConVisibleTyVars tc_fam_tc) + vis_pats = numVisibleArgs hs_pats + ; checkTc (vis_pats == vis_arity) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyArityMismatch tc_fam_tc vis_arity + } + +{- Note [Instantiating a family tycon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's possible that kind-checking the result of a family tycon applied to +its patterns will instantiate the tycon further. For example, we might +have + + type family F :: k where + F = Int + F = Maybe + +After checking (F :: forall k. k) (with no visible patterns), we still need +to instantiate the k. With data family instances, this problem can be even +more intricate, due to Note [Arity of data families] in GHC.Core.FamInstEnv. See +indexed-types/should_compile/T12369 for an example. + +So, the kind-checker must return the new skolems and args (that is, Type +or (Type -> Type) for the equations above) and the instantiated kind. + +Note [Generalising in tcTyFamInstEqnGuts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have something like + type instance forall (a::k) b. F (Proxy t1) _ = rhs + +Then imp_vars = [k], exp_bndrs = [a::k, b] + +We want to quantify over all the free vars of the LHS including + * any invisible kind variables arising from instantiating tycons, + such as Proxy + * wildcards such as '_' above + +The wildcards are particularly awkward: they may need to be quantified + - before the explicit variables k,a,b + - after them + - or even interleaved with them + c.f. Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType + +So, we use bindOuterFamEqnTKBndrs (which does not create an implication for +the telescope), and generalise over /all/ the variables in the LHS, +without treating the explicitly-quantified ones specially. Wrinkles: + + - When generalising, include the explicit user-specified forall'd + variables, so that we get an error from Validity.checkFamPatBinders + if a forall'd variable is not bound on the LHS + + - We still want to complain about a bad telescope among the user-specified + variables. So in checkFamTelescope we emit an implication constraint + quantifying only over them, purely so that we get a good telescope error. + + - Note that, unlike a type signature like + f :: forall (a::k). blah + we do /not/ care about the Inferred/Specified designation or order for + the final quantified tyvars. Type-family instances are not invoked + directly in Haskell source code, so visible type application etc plays + no role. + +See also Note [Re-quantify type variables in rules] in +GHC.Tc.Gen.Sig, which explains a /very/ similar design when +generalising over the type of a rewrite rule. + +-} + +-------------------------- + +tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo + -> HsOuterFamEqnTyVarBndrs GhcRn -- Implicit and explicit binders + -> HsFamEqnPats GhcRn -- Patterns + -> LHsType GhcRn -- RHS + -> TcM ([TyVar], TyVarSet, [TcType], TcType) + -- (tyvars, non_user_tvs, pats, rhs) +-- Used only for type families, not data families +tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty + = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc $$ ppr outer_hs_bndrs $$ ppr hs_pats) + + -- By now, for type families (but not data families) we should + -- have checked that the number of patterns matches tyConArity + ; skol_info <- mkSkolemInfo FamInstSkol + + -- This code is closely related to the code + -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk + ; (tclvl, wanted, (outer_bndrs, (lhs_ty, rhs_ty))) + <- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $ + bindOuterFamEqnTKBndrs skol_info outer_hs_bndrs $ + do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats + -- Ensure that the instance is consistent with its + -- parent class (#16008) + ; addConsistencyConstraints mb_clsinfo lhs_ty + ; rhs_ty <- tcCheckLHsTypeInContext hs_rhs_ty (TheKind rhs_kind) + ; return (lhs_ty, rhs_ty) } + + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tvs = outerTyVars outer_bndrs + ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs + + ; traceTc "tcTyFamInstEqnGuts 1" (pprTyVars outer_tvs $$ ppr skol_info) + + -- This code (and the stuff immediately above) is very similar + -- to that in tcDataFamInstHeader. Maybe we should abstract the + -- common code; but for the moment I concluded that it's + -- clearer to duplicate it. Still, if you fix a bug here, + -- check there too! + + -- See Note [Generalising in tcTyFamInstEqnGuts] + ; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty + ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs + ; let final_tvs = scopedSort (qtvs ++ outer_tvs) + -- This scopedSort is important: the qtvs may be /interleaved/ with + -- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts] + ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted + + ; traceTc "tcTyFamInstEqnGuts 2" $ + vcat [ ppr fam_tc + , text "lhs_ty:" <+> ppr lhs_ty + , text "final_tvs:" <+> pprTyVars final_tvs ] + + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: typecheck/should_fail/T17301 + ; dvs_rhs <- candidateQTyVarsOfType rhs_ty + ; let err_ctx tidy_env + = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty + ; return (tidy_env2, UninfTyCtx_TyFamRhs rhs_ty) } + ; doNotQuantifyTyVars dvs_rhs err_ctx + + ; (final_tvs, non_user_tvs, lhs_ty, rhs_ty) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyBndrsX final_tvs) $ \ final_tvs -> + do { lhs_ty <- zonkTcTypeToTypeX lhs_ty + ; rhs_ty <- zonkTcTypeToTypeX rhs_ty + ; non_user_tvs <- traverse lookupTyVarX qtvs + ; return (final_tvs, non_user_tvs, lhs_ty, rhs_ty) } + + ; let pats = unravelFamInstPats lhs_ty + -- Note that we do this after solveEqualities + -- so that any strange coercions inside lhs_ty + -- have been solved before we attempt to unravel it + + ; traceTc "tcTyFamInstEqnGuts }" (vcat [ ppr fam_tc, pprTyVars final_tvs ]) + -- Don't try to print 'pats' here, because lhs_ty involves + -- a knot-tied type constructor, so we get a black hole + + ; return (final_tvs, mkVarSet non_user_tvs, pats, rhs_ty) } + +checkFamTelescope :: TcLevel + -> HsOuterFamEqnTyVarBndrs GhcRn + -> [TcTyVar] -> TcM () +-- Emit a constraint (forall a b c. ), so that +-- we will do telescope-checking on a,b,c +-- See Note [Generalising in tcTyFamInstEqnGuts] +checkFamTelescope tclvl hs_outer_bndrs outer_tvs + | HsOuterExplicit { hso_bndrs = bndrs } <- hs_outer_bndrs + , (b_first : _) <- bndrs + , let b_last = last bndrs + = do { skol_info <- mkSkolemInfo (ForAllSkol $ HsTyVarBndrsRn (map unLoc bndrs)) + ; setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ do + emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC } + | otherwise + = return () + +----------------- +unravelFamInstPats :: TcType -> [TcType] +-- Decompose fam_app to get the argument patterns +-- +-- We expect fam_app to look like (F t1 .. tn) +-- tcFamTyPats is capable of returning ((F ty1 |> co) ty2), +-- but that can't happen here because we already checked the +-- arity of F matches the number of pattern +unravelFamInstPats fam_app + = case tcSplitTyConApp_maybe fam_app of + Just (_, pats) -> pats + Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance" + -- The Nothing case cannot happen for type families, because + -- we don't call unravelFamInstPats until we've solved the + -- equalities. For data families, it shouldn't happen either, + -- we need to fail hard and early if it does. See issue #15905 + -- for an example of this happening. + +addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () +-- In the corresponding positions of the class and type-family, +-- ensure the family argument is the same as the class argument +-- E.g class C a b c d where +-- F c x y a :: Type +-- Here the first arg of F should be the same as the third of C +-- and the fourth arg of F should be the same as the first of C +addConsistencyConstraints mb_clsinfo fam_app + | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo + , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app + = do { let eqs = [ (cls_ty, pat) + | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats + , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ] + ; traceTc "addConsistencyConstraints" (ppr eqs) + ; emitWantedEqs AssocFamPatOrigin eqs } + -- Improve inference; these equalities will not produce errors. + -- See Note [Constraints to ignore] in GHC.Tc.Errors + -- Any mis-match is reports by checkConsistentFamInst + | otherwise + = return () + +{- Note [Constraints in patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: This isn't the whole story. See comment in tcFamTyPats. + +At first glance, it seems there is a complicated story to tell in tcFamTyPats +around constraint solving. After all, type family patterns can now do +GADT pattern-matching, which is jolly complicated. But, there's a key fact +which makes this all simple: everything is at top level! There cannot +be untouchable type variables. There can't be weird interaction between +case branches. There can't be global skolems. + +This means that the semantics of type-level GADT matching is a little +different than term level. If we have + + data G a where + MkGBool :: G Bool + +And then + + type family F (a :: G k) :: k + type instance F MkGBool = True + +we get + + axF : F Bool (MkGBool ) ~ True + +Simple! No casting on the RHS, because we can affect the kind parameter +to F. + +If we ever introduce local type families, this all gets a lot more +complicated, and will end up looking awfully like term-level GADT +pattern-matching. + + +** The new story ** + +Here is really what we want: + +The matcher really can't deal with covars in arbitrary spots in coercions. +But it can deal with covars that are arguments to GADT data constructors. +So we somehow want to allow covars only in precisely those spots, then use +them as givens when checking the RHS. TODO (RAE): Implement plan. + +Note [Quantified kind variables of a family pattern] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider type family KindFam (p :: k1) (q :: k1) + data T :: Maybe k1 -> k2 -> * + type instance KindFam (a :: Maybe k) b = T a b -> Int +The HsBSig for the family patterns will be ([k], [a]) + +Then in the family instance we want to + * Bring into scope [ "k" -> k:*, "a" -> a:k ] + * Kind-check the RHS + * Quantify the type instance over k and k', as well as a,b, thus + type instance [k, k', a:Maybe k, b:k'] + KindFam (Maybe k) k' a b = T k k' a b -> Int + +Notice that in the third step we quantify over all the visibly-mentioned +type variables (a,b), but also over the implicitly mentioned kind variables +(k, k'). In this case one is bound explicitly but often there will be +none. The role of the kind signature (a :: Maybe k) is to add a constraint +that 'a' must have that kind, and to bring 'k' into scope. + + + +************************************************************************ +* * + Data types +* * +************************************************************************ +-} + +dataDeclChecks :: Name + -> Maybe (LHsContext GhcRn) -> DataDefnCons (LConDecl GhcRn) + -> TcM Bool +dataDeclChecks tc_name mctxt cons + = do { let stupid_theta = fromMaybeContext mctxt + -- Check that we don't use GADT syntax in H98 world + ; gadtSyntax_ok <- xoptM LangExt.GADTSyntax + ; let gadt_syntax = anyLConIsGadt cons + ; unless (gadtSyntax_ok || not gadt_syntax) $ + addErrTc (TcRnGADTsDisabled tc_name) + + -- Check that the stupid theta is empty for a GADT-style declaration. + -- See Note [The stupid context] in GHC.Core.DataCon. + ; checkTc (null stupid_theta || not gadt_syntax) (TcRnGADTDataContext tc_name) + + -- Check that there's at least one condecl, + -- or else we're reading an hs-boot file, or -XEmptyDataDecls + ; empty_data_decls <- xoptM LangExt.EmptyDataDecls + ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? + ; unless (not (null cons) || empty_data_decls || is_boot) $ + addErrTc (TcRnEmptyDataDeclsDisabled tc_name) + ; return gadt_syntax } + + +----------------------------------- +data DataDeclInfo + = DDataType -- data T a b = T1 a | T2 b + | DDataInstance -- data instance D [a] = D1 a | D2 + Type -- The header D [a] + +mkDDHeaderTy :: DataDeclInfo -> TyCon -> [TyConBinder] -> Type +mkDDHeaderTy dd_info rep_tycon tc_bndrs + = case dd_info of + DDataType -> mkTyConApp rep_tycon $ + mkTyVarTys (binderVars tc_bndrs) + DDataInstance header_ty -> header_ty + +-- We use `concatMapDataDefnConsTcM` here, since the following is illegal: +-- @newtype T a where T1, T2 :: a -> T a@ +-- It would be represented as a single 'ConDeclGadt' with multiple names, which is valid for 'data', but not 'newtype'. +-- So when 'tcConDecl' expands the 'ConDecl' per each name it has, if we are type-checking a 'newtype' declaration, we +-- must fail if it returns more than one. +tcConDecls :: DataDeclInfo + -> KnotTied TyCon -- Representation TyCon + -> [TcTyConBinder] -- Binders of representation TyCon + -> TcKind -- Result kind + -> DataDefnCons (LConDecl GhcRn) -> TcM (DataDefnCons DataCon) +tcConDecls dd_info rep_tycon tmpl_bndrs res_kind + = concatMapDataDefnConsTcM (tyConName rep_tycon) $ \ new_or_data -> + addLocM $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon) + -- mkTyConTagMap: it's important that we pay for tag allocation here, + -- once per TyCon. See Note [Constructor tag allocation], fixes #14657 + +-- 'concatMap' for 'DataDefnCons', but fail if the given function returns multiple values and the argument is a 'NewTypeCon'. +concatMapDataDefnConsTcM :: Name -> (NewOrData -> a -> TcM (NonEmpty b)) -> DataDefnCons a -> TcM (DataDefnCons b) +concatMapDataDefnConsTcM name f = \ case + NewTypeCon a -> f NewType a >>= \ case + b:|[] -> pure (NewTypeCon b) + bs -> failWithTc $ TcRnMultipleConForNewtype name (length bs) + DataTypeCons is_type_data as -> DataTypeCons is_type_data <$> concatMapM (fmap toList . f DataType) as + +tcConDecl :: NewOrData + -> DataDeclInfo + -> KnotTied TyCon -- Representation tycon. Knot-tied! + -> [TcTyConBinder] -- Binders of representation TyCon + -> TcKind -- Result kind + -> NameEnv ConTag + -> ConDecl GhcRn + -> TcM (NonEmpty DataCon) + +tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map + (ConDeclH98 { con_name = lname@(L _ name) + , con_ex_tvs = explicit_tkv_nms + , con_mb_cxt = hs_ctxt + , con_args = hs_args }) + = addErrCtxt (DataConDefCtxt (NE.singleton lname)) $ + do { -- NB: the tyvars from the declaration header are in scope + + -- Get hold of the existential type variables + -- e.g. data T a = forall k (b::k) f. MkT a (f b) + -- Here tc_bndrs = {a} + -- hs_qvars = HsQTvs { hsq_implicit = {k} + -- , hsq_explicit = {f,b} } + + ; traceTc "tcConDecl 1" (vcat [ ppr name + , text "explicit_tkv_nms" <+> ppr explicit_tkv_nms + , text "tc_bndrs" <+> ppr tc_bndrs ]) + ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> explicit_tkv_nms))) + + ; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts))) + <- pushLevelAndSolveEqualitiesX "tcConDecl:H98" $ + tcExplicitTKBndrs skol_info explicit_tkv_nms $ + do { ctxt <- tcHsContext hs_ctxt + ; let exp_kind = getArgExpKind new_or_data res_kind + ; btys <- tcConH98Args exp_kind hs_args + ; field_lbls <- lookupConstructorFields $ noUserRdr name + ; let (arg_tys, stricts) = unzip btys + ; return (ctxt, arg_tys, field_lbls, stricts) + } + + + ; let tc_tvs = binderVars tc_bndrs + fake_ty = mkSpecForAllTys tc_tvs $ + mkInvisForAllTys exp_tvbndrs $ + tcMkPhiTy ctxt $ + tcMkScaledFunTys arg_tys $ + unitTy + -- That type is a lie, of course. (It shouldn't end in ()!) + -- And we could construct a proper result type from the info + -- at hand. But the result would mention only the univ_tvs, + -- and so it just creates more work to do it right. Really, + -- we're only doing this to find the right kind variables to + -- quantify over, and this type is fine for that purpose. + + -- exp_tvbndrs have explicit, user-written binding sites + -- the kvs below are those kind variables entirely unmentioned by the user + -- and discovered only by generalization + + ; kvs <- kindGeneralizeAll skol_info fake_ty + + ; let all_skol_tvs = tc_tvs ++ kvs + ; reportUnsolvedEqualities skol_info all_skol_tvs tclvl wanted + -- The skol_info claims that all the variables are bound + -- by the data constructor decl, whereas actually the + -- univ_tvs are bound by the data type decl itself. It + -- would be better to have a doubly-nested implication. + -- But that just doesn't seem worth it. + -- See test dependent/should_fail/T13780a + + -- Zonk to Types + ; (tc_bndrs, kvs, exp_tvbndrs, arg_tys, ctxt) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs ) $ \ tc_bndrs -> + runZonkBndrT (zonkTyBndrsX kvs ) $ \ kvs -> + runZonkBndrT (zonkTyVarBindersX exp_tvbndrs) $ \ exp_tvbndrs -> + do { arg_tys <- zonkScaledTcTypesToTypesX arg_tys + ; ctxt <- zonkTcTypesToTypesX ctxt + ; return (tc_bndrs, kvs, exp_tvbndrs, arg_tys, ctxt) } + + -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here + ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) + ; let univ_tvbs = tyConInvisTVBinders tc_bndrs + ex_tvbs = mkTyVarBinders InferredSpec kvs ++ exp_tvbndrs + ex_tvs = binderVars ex_tvbs + -- For H98 datatypes, the user-written tyvar binders are precisely + -- the universals followed by the existentials. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + user_tvbs = tyVarSpecToBinders $ univ_tvbs ++ ex_tvbs + user_res_ty = mkDDHeaderTy dd_info rep_tycon tc_bndrs + + ; traceTc "tcConDecl 2" (ppr name) + ; is_infix <- tcConIsInfixH98 name hs_args + ; rep_nm <- newTyConRepName name + ; fam_envs <- tcGetFamInstEnvs + ; dflags <- getDynFlags + ; let bang_opts = SrcBangOpts (initBangOpts dflags) + ; dc <- buildDataCon fam_envs bang_opts name is_infix rep_nm + stricts field_lbls + tc_tvs ex_tvs user_tvbs + [{- no eq_preds -}] ctxt arg_tys + user_res_ty rep_tycon tag_map + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. + + ; return (NE.singleton dc) } + +tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map + -- NB: don't use res_kind here, as it's ill-scoped. Instead, + -- we get the res_kind by typechecking the result type. + (ConDeclGADT { con_names = names + , con_outer_bndrs = L _ outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = cxt, con_g_args = hs_args + , con_res_ty = hs_res_ty }) + = addErrCtxt (DataConDefCtxt names) $ + do { traceTc "tcConDecl 1 gadt" (ppr names) + ; let L _ name :| _ = names + ; skol_info <- mkSkolemInfo (DataConSkol name) + ; (tclvl, wanted, (tvbs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) + <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $ + tcGadtConTyVarBndrs skol_info outer_bndrs inner_bndrs $ + do { ctxt <- tcHsContext cxt + ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty + -- See Note [GADT return kinds] + + -- For data instances (only), ensure that the return type, + -- res_ty, is a substitution instance of the header. + -- See Note [GADT return types] + ; case dd_info of + DDataType -> return () + DDataInstance hdr_ty -> + do { (subst, _meta_tvs) <- newMetaTyVars (binderVars tc_bndrs) + ; let head_shape = substTy subst hdr_ty + ; discardResult $ + popErrCtxt $ -- Drop DataConDefCtxt + addErrCtxt (DataConResTyCtxt names) $ + unifyType Nothing res_ty head_shape } + + -- See Note [Datatype return kinds] + ; let exp_kind = getArgExpKind new_or_data res_kind + ; btys <- tcConGADTArgs exp_kind hs_args + + ; let (arg_tys, stricts) = unzip btys + ; field_lbls <- lookupConstructorFields $ noUserRdr name + ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) + } + + ; tkvs <- kindGeneralizeAll skol_info + (mkForAllTys tvbs $ + tcMkPhiTy ctxt $ + tcMkScaledFunTys arg_tys $ + res_ty) + ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs) + ; reportUnsolvedEqualities skol_info tkvs tclvl wanted + + ; let tvbndrs = mkTyVarBinders Inferred tkvs ++ tvbs + + -- Zonk to Types + ; (tvbndrs, arg_tys, ctxt, res_ty) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tvbndrs) $ \ tvbndrs -> + do { arg_tys <- zonkScaledTcTypesToTypesX arg_tys + ; ctxt <- zonkTcTypesToTypesX ctxt + ; res_ty <- zonkTcTypeToTypeX res_ty + ; return (tvbndrs, arg_tys, ctxt, res_ty) } + + ; let res_tmpl = mkDDHeaderTy dd_info rep_tycon tc_bndrs + (univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst) + = rejigConRes tc_bndrs res_tmpl tvbndrs res_ty + -- See Note [rejigConRes] + + ctxt' = substTys arg_subst ctxt + arg_tys' = substScaledTys arg_subst arg_tys + res_ty' = substTy arg_subst res_ty + + -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here + ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) + ; fam_envs <- tcGetFamInstEnvs + ; dflags <- getDynFlags + ; let + buildOneDataCon (L _ name) = do + { is_infix <- tcConIsInfixGADT name hs_args + ; rep_nm <- newTyConRepName name + + ; let bang_opts = SrcBangOpts (initBangOpts dflags) + ; buildDataCon fam_envs bang_opts name is_infix + rep_nm stricts field_lbls + univ_tvs ex_tvs tvbndrs' eq_preds + ctxt' arg_tys' res_ty' rep_tycon tag_map + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. + } + ; mapM buildOneDataCon names } + +{- Note [GADT return types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T :: forall k. k -> Type + data instance T (a :: Type) where + MkT :: forall b. T b + +What kind does `b` have in the signature for MkT? +Since the return type must be an instance of the type in the header, +we must have (b :: Type), but you can't tell that by looking only at +the type of the data constructor; you have to look at the header too. +If you wrote it out fully, it'd look like + data instance T @Type (a :: Type) where + MkT :: forall (b::Type). T @Type b + +We could reject the program, and expect the user to add kind +annotations to `MkT` to restrict the signature. But an easy and +helpful alternative is this: simply instantiate the type from the +header with fresh unification variables, and unify with the return +type of `MkT`. That will force `b` to have kind `Type`. See #8707 +and #14111. + +Wrikles +* At first sight it looks as though this would completely subsume the + return-type check in checkValidDataCon. But it does not. Suppose we + have + data instance T [a] where + MkT :: T (F (Maybe a)) + + where F is a type function. Then maybe (F (Maybe a)) evaluates to + [a], so unifyType will succeed. But we discard the coercion + returned by unifyType; and we really don't want to accept this + program. The check in checkValidDataCon will, however, reject it. + TL;DR: keep the check in checkValidDataCon. + +* Consider a data type, rather than a data instance, declaration + data S a where { MkS :: b -> S [b] } + In tcConDecl, S is knot-tied, so we don't want to unify (S alpha) + with (S [b]). To put it another way, unifyType should never see a + TcTycon. Simple solution: do *not* do the extra unifyType for + data types (DDataType) only for data instances (DDataInstance); in + the latter the family constructor is not knot-tied so there is no + problem. + +* Consider this (from an earlier form of GHC itself): + + data Pass = Parsed | ... + data GhcPass (c :: Pass) where + GhcPs :: GhcPs + ... + type GhcPs = GhcPass 'Parsed + + Now GhcPs and GhcPass are mutually recursive. If we did unifyType + for datatypes like GhcPass, we would not be able to expand the type + synonym (it'd still be a TcTyCon). So again, we don't do unifyType + for data types; we leave it to checkValidDataCon. + + We /do/ perform the unifyType for data /instances/, but a data + instance doesn't declare a new (user-visible) type constructor, so + there is no mutual recursion with type synonyms to worry about. + All good. + + TL;DR we do support mutual recursion between type synonyms and + data type/instance declarations, as above. + +Note [GADT return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type family Star where Star = Type + data T :: Type where + MkT :: Int -> T + +If, for some stupid reason, tcInferLHsTypeKind on the return type of +MkT returned (T |> ax, Star), then the return-type check in +checkValidDataCon would reject the decl (although of course there is +nothing wrong with it). We are implicitly requiring tha +tcInferLHsTypeKind doesn't any gratuitous top-level casts. +-} + + +type ConArgKind = ContextKind + -- The expected kind of the argument(s) of a constructor + -- For data types this is always OpenKind + -- For newtypes it is (TheKind ki) + -- where `ki` is the result kind of the newtype + -- With NoUnliftedNewtype, ki=Type, but with UnliftedNewtypes it can be a variable + +-- | Produce an "expected kind" for the arguments of a data/newtype. +-- If the declaration is indeed for a newtype, +-- then this expected kind will be the kind provided. Otherwise, +-- it is OpenKind for datatypes and liftedTypeKind. +-- Why do we not check for -XUnliftedNewtypes? See point +-- in Note [Implementation of UnliftedNewtypes] +getArgExpKind :: NewOrData -> TcKind -> ConArgKind +getArgExpKind NewType res_ki = TheKind res_ki +getArgExpKind DataType _ = OpenKind + +tcConIsInfixH98 :: Name + -> HsConDeclH98Details GhcRn + -> TcM Bool +tcConIsInfixH98 _ details + = case details of + InfixCon{} -> return True + RecCon{} -> return False + PrefixCon{} -> return False + +tcConIsInfixGADT :: Name + -> HsConDeclGADTDetails GhcRn + -> TcM Bool +tcConIsInfixGADT con details + = case details of + RecConGADT{} -> return False + PrefixConGADT _ arg_tys -- See Note [Infix GADT constructors] + | isSymOcc (getOccName con) + , [_ty1,_ty2] <- arg_tys + -> do { fix_env <- getFixityEnv + ; return (con `elemNameEnv` fix_env) } + | otherwise -> return False + +tcConH98Args :: ConArgKind -- expected kind of arguments + -- always OpenKind for datatypes, but unlifted newtypes + -- might have a specific kind + -> HsConDeclH98Details GhcRn + -> TcM [(Scaled TcType, HsSrcBang)] +tcConH98Args exp_kind (PrefixCon btys) + = mapM (tcConArg exp_kind IsNotPrefixConGADT) btys +tcConH98Args exp_kind (InfixCon bty1 bty2) + = do { bty1' <- tcConArg exp_kind IsNotPrefixConGADT bty1 + ; bty2' <- tcConArg exp_kind IsNotPrefixConGADT bty2 + ; return [bty1', bty2'] } +tcConH98Args exp_kind (RecCon fields) + = tcRecHsConDeclRecFields exp_kind fields + +tcConGADTArgs :: ConArgKind -- expected kind of arguments + -- always OpenKind for datatypes, but unlifted newtypes + -- might have a specific kind + -> HsConDeclGADTDetails GhcRn + -> TcM [(Scaled TcType, HsSrcBang)] +tcConGADTArgs exp_kind (PrefixConGADT _ btys) + = mapM (tcConArg exp_kind IsPrefixConGADT) btys +tcConGADTArgs exp_kind (RecConGADT _ fields) + = tcRecHsConDeclRecFields exp_kind fields + +tcConArg :: ConArgKind -- expected kind for args; always OpenKind for datatypes, + -- but might be an unlifted type with UnliftedNewtypes + -> IsPrefixConGADT + -> HsConDeclField GhcRn -> TcM (Scaled TcType, HsSrcBang) +tcConArg exp_kind isPrefixConGADT (CDF (_, src) unp str w bty _) + = do { traceTc "tcConArg 1" (ppr bty) + ; arg_ty <- tcCheckLHsTypeInContext bty exp_kind + ; w' <- tcDataConMult isPrefixConGADT w + ; traceTc "tcConArg 2" (ppr bty) + ; return (Scaled w' arg_ty, HsSrcBang src unp str) } + +tcRecHsConDeclRecFields :: ConArgKind + -> LocatedL [LHsConDeclRecField GhcRn] + -> TcM [(Scaled TcType, HsSrcBang)] +tcRecHsConDeclRecFields exp_kind fields + = mapM (tcConArg exp_kind IsNotPrefixConGADT) btys + where + -- We need a one-to-one mapping from field_names to btys + combined = map (\(L _ f) -> (cdrf_names f, cdrf_spec f)) + (unLoc fields) + explode (ns,ty) = zip ns (repeat ty) + exploded = concatMap explode combined + (_,btys) = unzip exploded + +data IsPrefixConGADT = IsPrefixConGADT | IsNotPrefixConGADT deriving (Eq) + +-- See Note [Function arrows in GADT constructors] +unannotatedMultIsLinear :: IsPrefixConGADT -> TcRnIf gbl lcl Bool +unannotatedMultIsLinear isPrefixConGADT = do + if isPrefixConGADT == IsPrefixConGADT then do + linearEnabled <- xoptM LangExt.LinearTypes + return $ not linearEnabled + else + return True + +tcDataConMult :: IsPrefixConGADT -> HsMultAnn GhcRn -> TcM Mult +tcDataConMult isPrefixConGADT arr = case multAnnToHsType arr of + Nothing -> do + isLinear <- unannotatedMultIsLinear isPrefixConGADT + return $ if isLinear then oneDataConTy else manyDataConTy + Just ty -> tcMult ty + +{- +Note [Function arrows in GADT constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the absence of -XLinearTypes, we always interpret function arrows +in GADT constructor types as linear, even if the user wrote an +unrestricted arrow. See the "Without -XLinearTypes" section of the +linear types GHC proposal (#111). We opt to do this in the +typechecker, and not in an earlier pass, to ensure that the AST +matches what the user wrote (#18791). + +Note [Infix GADT constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not currently have syntax to declare an infix constructor in GADT syntax, +but it makes a (small) difference to the Show instance. So as a slightly +ad-hoc solution, we regard a GADT data constructor as infix if + a) it is an operator symbol + b) it has two arguments + c) there is a fixity declaration for it +For example: + infix 6 (:--:) + data T a where + (:--:) :: t1 -> t2 -> T Int + + +Note [rejigConRes] +~~~~~~~~~~~~~~~~~~ +There is a delicacy around checking the return types of a datacon. The +central problem is dealing with a declaration like + + data T a where + MkT :: T a -> Q a + +Note that the return type of MkT is totally bogus. When creating the T +tycon, we also need to create the MkT datacon, which must have a "rejigged" +return type. That is, the MkT datacon's type must be transformed to have +a uniform return type with explicit coercions for GADT-like type parameters. +This rejigging is what rejigConRes does. The problem is, though, that checking +that the return type is appropriate is much easier when done over *Type*, +not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully +defined yet. + +So, we want to make rejigConRes lazy and then check the validity of +the return type in checkValidDataCon. To do this we /always/ return a +6-tuple from rejigConRes (so that we can compute the return type from it, which +checkValidDataCon needs), but the first three fields may be bogus if +the return type isn't valid (the last equation for rejigConRes). + +This is better than an earlier solution which reduced the number of +errors reported in one pass. See #7175, and #10836. +-} + +-- Example +-- data instance T (b,c) where +-- TI :: forall e. e -> T (e,e) +-- +-- The representation tycon looks like this: +-- data :R7T b c where +-- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 +-- In this case orig_res_ty = T (e,e) + +rejigConRes :: [KnotTied TyConBinder] -- Template for result type; e.g. + -> KnotTied Type -- data instance T [a] b c ... + -- gives template ([a,b,c], T [a] b c) + -> [TyVarBinder] -- The constructor's type variables (both inferred and user-written) + -> KnotTied Type -- res_ty + -> ([TyVar], -- Universal + [TyVar], -- Existential (distinct OccNames from univs) + [TyVarBinder], -- The constructor's rejigged, user-written + -- type variables + [EqSpec], -- Equality predicates + Subst) -- Substitution to apply to argument types + -- We don't check that the TyCon given in the ResTy is + -- the same as the parent tycon, because checkValidDataCon will do it +-- NB: All arguments may potentially be knot-tied +rejigConRes tc_tvbndrs res_tmpl dc_tvbndrs res_ty + -- E.g. data T [a] b c where + -- MkT :: forall x y z. T [(x,y)] z z + -- The {a,b,c} are the tc_tvs, and the {x,y,z} are the dc_tvs + -- (NB: unlike the H98 case, the dc_tvs are not all existential) + -- Then we generate + -- Univ tyvars Eq-spec + -- a a~(x,y) + -- b b~z + -- z + -- Existentials are the leftover type vars: [x,y] + -- The user-written type variables are what is listed in the forall: + -- [x, y, z] (all specified). We must rejig these as well. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + -- So we return ( [a,b,z], [x,y] + -- , [], [x,y,z] + -- , [a~(x,y),b~z], ) + | Just subst <- tcMatchTy res_tmpl res_ty + = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tc_tvs dc_tvs subst + raw_ex_tvs = dc_tvs `minusList` univ_tvs + (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs + + -- After rejigging the existential tyvars, the resulting substitution + -- gives us exactly what we need to rejig the user-written tyvars, + -- since the dcUserTyVarBinders invariant guarantees that the + -- substitution has *all* the tyvars in its domain. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + subst_user_tvs = mapVarBndrs (substTyVarToTyVar arg_subst) + substed_tvbndrs = subst_user_tvs dc_tvbndrs + + substed_eqs = [ mkEqSpec (substTyVarToTyVar arg_subst tv) + (substTy arg_subst ty) + | (tv,ty) <- raw_eqs ] + in + (univ_tvs, substed_ex_tvs, substed_tvbndrs, substed_eqs, arg_subst) + + | otherwise + -- If the return type of the data constructor doesn't match the parent + -- type constructor, or the arity is wrong, the tcMatchTy will fail + -- e.g data T a b where + -- T1 :: Maybe a -- Wrong tycon + -- T2 :: T [a] -- Wrong arity + -- We are detect that later, in checkValidDataCon, but meanwhile + -- we must do *something*, not just crash. So we do something simple + -- albeit bogus, relying on checkValidDataCon to check the + -- bad-result-type error before seeing that the other fields look odd + -- See Note [rejigConRes] + = (tc_tvs, dc_tvs `minusList` tc_tvs, dc_tvbndrs, [], emptySubst) + where + dc_tvs = binderVars dc_tvbndrs + tc_tvs = binderVars tc_tvbndrs + +{- Note [mkGADTVars] +~~~~~~~~~~~~~~~~~~~~ +Running example: + +data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where + MkT :: forall (x1 : *) (y :: x1) (z :: *). + T x1 * (Proxy (y :: x1), z) z + +We need the rejigged type to be + + MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2). + forall (y :: x1) (z :: *). + (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z) + => T x1 k2 a b + +You might naively expect that z should become a universal tyvar, +not an existential. (After all, x1 becomes a universal tyvar.) +But z has kind * while b has kind k2, so the return type + T x1 k2 a z +is ill-kinded. Another way to say it is this: the universal +tyvars must have exactly the same kinds as the tyConTyVars. + +So we need an existential tyvar and a heterogeneous equality +constraint. (The b ~ z is a bit redundant with the k2 ~ * that +comes before in that b ~ z implies k2 ~ *. I'm sure we could do +some analysis that could eliminate k2 ~ *. But we don't do this +yet.) + +The data con signature has already been fully kind-checked. +The return type + + T x1 * (Proxy (y :: x1), z) z +becomes + qtkvs = [x1 :: *, y :: x1, z :: *] + res_tmpl = T x1 * (Proxy x1 y, z) z + +We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We +know this match will succeed because of the validity check (actually done +later, but laziness saves us -- see Note [rejigConRes]). +Thus, we get + + subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z } + +Now, we need to figure out what the GADT equalities should be. In this case, +we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a +renaming. The others should be GADT equalities. We also need to make +sure that the universally-quantified variables of the datacon match up +with the tyvars of the tycon, as required for Core context well-formedness. +(This last bit is why we have to rejig at all!) + +`choose` walks down the tycon tyvars, figuring out what to do with each one. +It carries two substitutions: + - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables + mentioned in the datacon signature. + - r_sub's domain is *result* tyvars, names written by the programmer in + the datacon signature. The final rejigged type will use these names, but + the subst is still needed because sometimes the printed name of these variables + is different. (See choose_tv_name, below.) + +Before explaining the details of `choose`, let's just look at its operation +on our example: + + choose [] [] {} {} [k1, k2, a, b] + --> -- first branch of `case` statement + choose + univs: [x1 :: *] + eq_spec: [] + t_sub: {k1 |-> x1} + r_sub: {x1 |-> x1} + t_tvs: [k2, a, b] + --> -- second branch of `case` statement + choose + univs: [k2 :: *, x1 :: *] + eq_spec: [k2 ~ *] + t_sub: {k1 |-> x1, k2 |-> k2} + r_sub: {x1 |-> x1} + t_tvs: [a, b] + --> -- second branch of `case` statement + choose + univs: [a :: k2, k2 :: *, x1 :: *] + eq_spec: [ a ~ (Proxy x1 y, z) + , k2 ~ * ] + t_sub: {k1 |-> x1, k2 |-> k2, a |-> a} + r_sub: {x1 |-> x1} + t_tvs: [b] + --> -- second branch of `case` statement + choose + univs: [b :: k2, a :: k2, k2 :: *, x1 :: *] + eq_spec: [ b ~ z + , a ~ (Proxy x1 y, z) + , k2 ~ * ] + t_sub: {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z} + r_sub: {x1 |-> x1} + t_tvs: [] + --> -- end of recursion + ( [x1 :: *, k2 :: *, a :: k2, b :: k2] + , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z] + , {x1 |-> x1} ) + +`choose` looks up each tycon tyvar in the matching (it *must* be matched!). + +* If it finds a bare result tyvar (the first branch of the `case` + statement), it checks to make sure that the result tyvar isn't yet + in the list of univ_tvs. If it is in that list, then we have a + repeated variable in the return type, and we in fact need a GADT + equality. + +* It then checks to make sure that the kind of the result tyvar + matches the kind of the template tyvar. This check is what forces + `z` to be existential, as it should be, explained above. + +* Assuming no repeated variables or kind-changing, we wish to use the + variable name given in the datacon signature (that is, `x1` not + `k1`), not the tycon signature (which may have been made up by + GHC). So, we add a mapping from the tycon tyvar to the result tyvar + to t_sub. + +* If we discover that a mapping in `subst` gives us a non-tyvar (the + second branch of the `case` statement), then we have a GADT equality + to create. We create a fresh equality, but we don't extend any + substitutions. The template variable substitution is meant for use + in universal tyvar kinds, and these shouldn't be affected by any + GADT equalities. + +This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways +of simplifying it: + +1) The first branch of the `case` statement is really an optimization, used +in order to get fewer GADT equalities. It might be possible to make a GADT +equality for *every* univ. tyvar, even if the equality is trivial, and then +either deal with the bigger type or somehow reduce it later. + +2) This algorithm strives to use the names for type variables as specified +by the user in the datacon signature. If we always used the tycon tyvar +names, for example, this would be simplified. This change would almost +certainly degrade error messages a bit, though. +-} + +-- | From information about a source datacon definition, extract out +-- what the universal variables and the GADT equalities should be. +-- See Note [mkGADTVars]. +mkGADTVars :: [TyVar] -- ^ The tycon vars + -> [TyVar] -- ^ The datacon vars + -> Subst -- ^ The matching between the template result type + -- and the actual result type + -> ( [TyVar] + , [(TyVar,Type)] -- The un-substituted eq-spec + , Subst ) -- ^ The univ. variables, the GADT equalities, + -- and a subst to apply to the GADT equalities + -- and existentials. +mkGADTVars tmpl_tvs dc_tvs subst + = choose [] [] empty_subst empty_subst tmpl_tvs + where + in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) + `unionInScope` substInScopeSet subst + empty_subst = mkEmptySubst in_scope + + choose :: [TyVar] -- accumulator of univ tvs, reversed + -> [(TyVar,Type)] -- accumulator of GADT equalities, reversed + -> Subst -- template substitution + -> Subst -- res. substitution + -> [TyVar] -- template tvs (the univ tvs passed in) + -> ( [TyVar] -- the univ_tvs + , [(TyVar,Type)] -- GADT equalities + , Subst ) -- a substitution to fix kinds in ex_tvs + + choose univs eqs _t_sub r_sub [] + = (reverse univs, reverse eqs, r_sub) + choose univs eqs t_sub r_sub (t_tv:t_tvs) + | Just r_ty <- lookupTyVar subst t_tv + = case getTyVar_maybe r_ty of + Just r_tv + | not (r_tv `elem` univs) + , tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv)) + -> -- simple, well-kinded variable substitution. + -- the name of the universal comes from the result of the ctor + -- see (R2) of Note [DataCon user type variable binders] in GHC.Core.DataCon + choose (r_tv:univs) eqs + (extendTvSubst t_sub t_tv r_ty') + (extendTvSubst r_sub r_tv r_ty') + t_tvs + where + r_tv1 = setTyVarName r_tv (choose_tv_name r_tv t_tv) + r_ty' = mkTyVarTy r_tv1 + + -- Not a simple substitution: make an equality predicate + -- the name of the universal comes from the datatype header + -- see (R2) of Note [DataCon user type variable binders] in GHC.Core.DataCon + _ -> choose (t_tv':univs) eqs' + (extendTvSubst t_sub t_tv (mkTyVarTy t_tv')) + -- We've updated the kind of t_tv, + -- so add it to t_sub (#14162) + r_sub t_tvs + where + tv_kind = tyVarKind t_tv + tv_kind' = substTy t_sub tv_kind + t_tv' = setTyVarKind t_tv tv_kind' + eqs' = (t_tv', r_ty) : eqs + + | otherwise + = choose (t_tv:univs) eqs t_sub r_sub t_tvs + + -- choose an appropriate name for a univ tyvar. + -- This *must* preserve the Unique of the result tv, so that we + -- can detect repeated variables. It prefers user-specified names + -- over system names. A result variable with a system name can + -- happen with GHC-generated implicit kind variables. + choose_tv_name :: TyVar -> TyVar -> Name + choose_tv_name r_tv t_tv + | isSystemName r_tv_name + = setNameUnique t_tv_name (getUnique r_tv_name) + + | otherwise + = r_tv_name + + where + r_tv_name = getName r_tv + t_tv_name = getName t_tv + +{- +Note [Substitution in template variables kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data G (a :: Maybe k) where + MkG :: G Nothing + +With explicit kind variables + +data G k (a :: Maybe k) where + MkG :: G k1 (Nothing k1) + +Note how k1 is distinct from k. So, when we match the template +`G k a` against `G k1 (Nothing k1)`, we get a subst +[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two +mappings, we surely don't want to add (k, k1) to the list of +GADT equalities -- that would be overly complex and would create +more untouchable variables than we need. So, when figuring out +which tyvars are GADT-like and which aren't (the fundamental +job of `choose`), we want to treat `k` as *not* GADT-like. +Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1) +instead of (a :: Maybe k). This is the reason for dealing +with a substitution in here. + +However, we do not *always* want to substitute. Consider + +data H (a :: k) where + MkH :: H Int + +With explicit kind variables: + +data H k (a :: k) where + MkH :: H * Int + +Here, we have a kind-indexed GADT. The subst in question is +[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s +kind, because that would give a constructor with the type + +MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a + +The problem here is that a's kind is wrong -- it needs to be k, not *! +So, if the matching for a variable is anything but another bare variable, +we drop the mapping from the substitution before proceeding. This +was not an issue before kind-indexed GADTs because this case could +never happen. + +************************************************************************ +* * + Validity checking +* * +************************************************************************ + +Validity checking is done once the mutually-recursive knot has been +tied, so we can look at things freely. +-} + +checkValidTyCl :: TyCon -> TcM [TyCon] +-- The returned list is either a singleton (if valid) +-- or a list of "fake tycons" (if not); the fake tycons +-- include any implicits, like promoted data constructors +-- See Note [Recover from validity error] +checkValidTyCl tc + = setSrcSpan (getSrcSpan tc) $ + addTyConCtxt tc $ + recoverM recovery_code $ + do { traceTc "Starting validity for tycon" (ppr tc) + ; checkValidTyCon tc + ; checkTyConConsistentWithBoot tc -- See Note [TyCon boot consistency checking] + ; traceTc "Done validity for tycon" (ppr tc) + ; return [tc] } + where + recovery_code -- See Note [Recover from validity error] + = do { traceTc "Aborted validity for tycon" (ppr tc) + ; return (map mk_fake_tc $ + tc : child_tycons tc) } + + mk_fake_tc tc + | isClassTyCon tc = tc -- Ugh! Note [Recover from validity error] + | otherwise = makeRecoveryTyCon tc + + child_tycons tc = tyConATs tc ++ map promoteDataCon (tyConDataCons tc) + +{- Note [Recover from validity error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We recover from a validity error in a type or class, which allows us +to report multiple validity errors. In the failure case we return a +TyCon of the right kind, but with no interesting behaviour +(makeRecoveryTyCon). Why? Suppose we have + type T a = Fun +where Fun is a type family of arity 1. The RHS is invalid, but we +want to go on checking validity of subsequent type declarations. +So we replace T with an abstract TyCon which will do no harm. +See indexed-types/should_fail/BadSock and #10896 + +Some notes: + +* We must make fakes for promoted DataCons too. Consider (#15215) + data T a = MkT ... + data S a = ...T...MkT.... + If there is an error in the definition of 'T' we add a "fake type + constructor" to the type environment, so that we can continue to + typecheck 'S'. But we /were not/ adding a fake anything for 'MkT' + and so there was an internal error when we met 'MkT' in the body of + 'S'. + + Similarly for associated types. + +* Painfully, we *don't* want to do this for classes. + Consider tcfail041: + class (?x::Int) => C a where ... + instance C Int + The class is invalid because of the superclass constraint. But + we still want it to look like a /class/, else the instance bleats + that the instance is mal-formed because it hasn't got a class in + the head. + + This is really bogus; now we have in scope a Class that is invalid + in some way, with unknown downstream consequences. A better + alternative might be to make a fake class TyCon. A job for another day. + +* Previously, we used implicitTyConThings to snaffle out the parts + to add to the context. The problem is that this also grabs data con + wrapper Ids. These could be filtered out. But, painfully, getting + the wrapper Ids checks the DataConRep, and forcing the DataConRep + can panic if there is a representation-polymorphic argument. This is #18534. + We don't need the wrapper Ids here anyway. So the code just takes what + it needs, via child_tycons. +-} + +------------------------- +-- For data types declared with record syntax, we require +-- that each constructor that has a field 'f' +-- (a) has the same result type +-- (b) has the same type for 'f' +-- module alpha conversion of the quantified type variables +-- of the constructor. +-- +-- Note that we allow existentials to match because the +-- fields can never meet. E.g +-- data T where +-- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T +-- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T +-- Here we do not complain about f1,f2 because they are existential + +-- | Check that a 'TyCon' is consistent with the one in the hs-boot file, +-- if any. +-- +-- See Note [TyCon boot consistency checking]. +checkTyConConsistentWithBoot :: TyCon -> TcM () +checkTyConConsistentWithBoot tc = + do { gbl_env <- getGblEnv + ; let name = tyConName tc + real_thing = ATyCon tc + boot_info = tcg_self_boot gbl_env + boot_type_env = case boot_info of + NoSelfBoot -> emptyTypeEnv + SelfBoot boot_details -> md_types boot_details + m_boot_info = lookupTypeEnv boot_type_env name + ; case m_boot_info of + Nothing -> return () + Just boot_thing -> checkBootDeclM HsBoot boot_thing real_thing + } + +{- Note [TyCon boot consistency checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to throw an error when A.hs and A.hs-boot define a TyCon inconsistently, +e.g. + + -- A.hs-boot + type D :: Type + data D + + -- A.hs + data D (k :: Type) = MkD + +Here A.D and A[boot].D have different kinds, so we must error. In addition, we +must error eagerly, lest other parts of the compiler witness this inconsistency +(which was the subject of #16127). To achieve this, we call +checkTyConIsConsistentWithBoot in checkValidTyCl, which is called in +GHC.Tc.TyCl.tcTyClGroup. + +Note that, when calling checkValidTyCl, we must extend the TyCon environment. +For example, we could end up comparing the RHS of two type synonym declarations +to check they are consistent, and these RHS might mention some of the TyCons we +are validity checking, so they need to be in the environment. +-} + +checkValidTyCon :: TyCon -> TcM () +checkValidTyCon tc + | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim + = return () + + | isWiredIn tc -- validity-checking wired-in tycons is a waste of + -- time. More importantly, a wired-in tycon might + -- violate assumptions. Example: (~) has a superclass + -- mentioning (~#), which is ill-kinded in source Haskell + = traceTc "Skipping validity check for wired-in" (ppr tc) + + | otherwise + = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc)) + ; if | Just cl <- tyConClass_maybe tc + -> checkValidClass cl + + | Just syn_rhs <- synTyConRhs_maybe tc + -> do { checkValidType syn_ctxt syn_rhs + ; checkTySynRhs syn_ctxt syn_rhs } + + | Just fam_flav <- famTyConFlav_maybe tc + -> case fam_flav of + { ClosedSynFamilyTyCon (Just ax) + -> addErrCtxt (ClosedFamEqnCtxt tc) $ + checkValidCoAxiom ax + ; ClosedSynFamilyTyCon Nothing -> return () + ; AbstractClosedSynFamilyTyCon -> + do { hsBoot <- tcIsHsBootOrSig + ; checkTc hsBoot $ TcRnAbstractClosedTyFamDecl } + ; DataFamilyTyCon {} -> return () + ; OpenSynFamilyTyCon -> return () + ; BuiltInSynFamTyCon _ -> return () } + + | otherwise -> do + { -- Check the context on the data decl + traceTc "cvtc1" (ppr tc) + ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) + + ; traceTc "cvtc2" (ppr tc) + + ; dflags <- getDynFlags + ; existential_ok <- xoptM LangExt.ExistentialQuantification + ; gadt_ok <- xoptM LangExt.GADTs + ; let ex_ok = existential_ok || gadt_ok + -- Data cons can have existential context + ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons + ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc) + + -- Check that fields with the same name share a type + ; mapM_ check_fields groups }} + where + syn_ctxt = TySynCtxt name + name = tyConName tc + data_cons = tyConDataCons tc + + groups = equivClasses cmp_fld (concatMap get_fields data_cons) + -- This spot seems OK with non-determinism. cmp_fld is used only in equivClasses + -- which produces equivalence classes. + -- The order of these equivalence classes might conceivably (non-deterministically) + -- depend on the result of this comparison, but that just affects the order in which + -- fields are checked for compatibility. It will not affect the compiled binary. + cmp_fld (f1,_) (f2,_) = field_label (flLabel f1) `uniqCompareFS` field_label (flLabel f2) + get_fields con = dataConFieldLabels con `zip` repeat con + -- dataConFieldLabels may return the empty list, which is fine + + -- See Note [GADT record selectors] in GHC.Tc.TyCl.Utils + -- We must check (a) that the named field has the same + -- type in each constructor + -- (b) that those constructors have the same result type + -- + -- However, the constructors may have differently named type variable + -- and (worse) we don't know how the correspond to each other. E.g. + -- C1 :: forall a b. { f :: a, g :: b } -> T a b + -- C2 :: forall d c. { f :: c, g :: c } -> T c d + -- + -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's + -- result type against other candidates' types BOTH WAYS ROUND. + -- If they magically agrees, take the substitution and + -- apply them to the latter ones, and see if they match perfectly. + check_fields ((label, con1) :| other_fields) + -- These fields all have the same name, but are from + -- different constructors in the data type + = recoverM (return ()) $ mapM_ checkOne other_fields + -- Check that all the fields in the group have the same type + -- NB: this check assumes that all the constructors of a given + -- data type use the same type variables + where + res1 = dataConOrigResTy con1 + fty1 = dataConFieldType con1 lbl + lbl = flLabel label + + checkOne (_, con2) -- Do it both ways to ensure they are structurally identical + = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2 + ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 } + where + res2 = dataConOrigResTy con2 + fty2 = dataConFieldType con2 lbl + +checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM () +-- Checks the partial record field selector, and warns. +-- See Note [Checking partial record field] +checkPartialRecordField all_cons fld + = setSrcSpan loc $ + warnIf (not is_exhaustive && not (startsWithUnderscore occ_name)) + (TcRnPartialFieldSelector fld) + where + sel = flSelector fld + loc = getSrcSpan sel + occ_name = nameOccName sel + + (cons_with_field, cons_without_field) = partition has_field all_cons + has_field con = fld `elem` (dataConFieldLabels con) + is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field + + con1 = assert (not (null cons_with_field)) $ head cons_with_field + inst_tys = dataConResRepTyArgs con1 + +checkFieldCompat :: FieldLabelString -> DataCon -> DataCon + -> Type -> Type -> Type -> Type -> TcM () +checkFieldCompat fld con1 con2 res1 res2 fty1 fty2 + = do { checkTc (isJust mb_subst1) (TcRnCommonFieldResultTypeMismatch con1 con2 fld) + ; checkTc (isJust mb_subst2) (TcRnCommonFieldTypeMismatch con1 con2 fld) } + where + mb_subst1 = tcMatchTy res1 res2 + mb_subst2 = tcMatchTyX (expectJust mb_subst1) fty1 fty2 + +------------------------------- +checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () +checkValidDataCon dflags existential_ok tc con + = setSrcSpan con_loc $ + addErrCtxt (DataConDefCtxt (NE.singleton (L (noAnnSrcSpan con_loc) con_name))) $ + do { let tc_tvs = tyConTyVars tc + res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) + arg_tys = dataConOrigArgTys con + orig_res_ty = dataConOrigResTy con + + ; traceTc "checkValidDataCon" (vcat + [ ppr con, ppr tc, ppr tc_tvs + , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl) + , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)]) + + + -- Check that the return type of the data constructor + -- matches the type constructor; eg reject this: + -- data T a where { MkT :: Bogus a } + -- It's important to do this first: + -- see Note [rejigConRes] + -- and c.f. Note [Check role annotations in a second pass] + + -- Check that the return type of the data constructor is an instance + -- of the header of the header of data decl. This checks for + -- data T a where { MkT :: S a } + -- data instance D [a] where { MkD :: D (Maybe b) } + -- see Note [GADT return types] + ; checkTc (isJust (tcMatchTyKi res_ty_tmpl orig_res_ty)) + (TcRnDataConParentTypeMismatch con res_ty_tmpl) + -- Note that checkTc aborts if it finds an error. This is + -- critical to avoid panicking when we call dataConDisplayType + -- on an un-rejiggable datacon! + -- Also NB that we match the *kind* as well as the *type* (#18357) + -- However, if the kind is the only thing that doesn't match, the + -- error message is terrible. E.g. test T18357b + -- type family Star where Star = Type + -- newtype T :: Type where MkT :: Int -> (T :: Star) + + ; traceTc "checkValidDataCon 2" (ppr data_con_display_type) + + -- Check that the result type is a *monotype* + -- e.g. reject this: MkT :: T (forall a. a->a) + -- Reason: it's really the argument of an equality constraint + ; checkValidMonoType orig_res_ty + ; checkEscapingKind (dataConWrapperType con) + + -- For /data/ types check that each argument has a fixed runtime rep + -- If we are dealing with a /newtype/, we allow representation + -- polymorphism regardless of whether or not UnliftedNewtypes + -- is enabled. A later check in checkNewDataCon handles this, + -- producing a better error message than checkTypeHasFixedRuntimeRep would. + ; let check_rr = checkTypeHasFixedRuntimeRep FixedRuntimeRepDataConField + ; unless (isNewTyCon tc) $ + checkNoErrs $ + mapM_ (check_rr . scaledThing) arg_tys + -- The checkNoErrs is to prevent a panic in isVanillaDataCon + -- (called a a few lines down), which can fall over if there is a + -- bang on a representation-polymorphic argument. This is #18534, + -- typecheck/should_fail/T18534 + + -- Extra checks for newtype data constructors. Importantly, these + -- checks /must/ come before the call to checkValidType below. This + -- is because checkValidType invokes the constraint solver, and + -- invoking the solver on an ill formed newtype constructor can + -- confuse GHC to the point of panicking. See #17955 for an example. + ; when (isNewTyCon tc) (checkNewDataCon con) + + -- Check all argument types for validity + ; checkValidType ctxt data_con_display_type + + -- Check that existentials are allowed if they are used + ; unless (existential_ok || isVanillaDataCon con) $ + addErrTc (TcRnExistentialQuantificationDisabled con) + + -- Check that the only constraints in signatures of constructors + -- in a "type data" declaration are equality constraints. + -- See Note [Type data declarations] in GHC.Rename.Module, + -- restriction (R4). + ; when (isTypeDataCon con) $ + checkTc (all isEqClassPred (dataConOtherTheta con)) + (TcRnConstraintInKind (dataConRepType con)) + + ; hsc_env <- getTopEnv + ; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM () + check_bang orig_arg_ty bang rep_bang n + | HsSrcBang _ _ SrcLazy <- bang + , not (bang_opt_strict_data bang_opts) + = addErrTc (bad_bang n LazyFieldsDisabled) + + -- Warn about UNPACK without "!" + -- e.g. data T = MkT {-# UNPACK #-} Int + | HsSrcBang _ want_unpack strict_mark <- bang + , isSrcUnpacked want_unpack, not (is_strict strict_mark) + , not (isUnliftedType orig_arg_ty) + = addDiagnosticTc (bad_bang n UnpackWithoutStrictness) + + -- Warn about a redundant ! on an unlifted type + -- e.g. data T = MkT !Int# + | HsSrcBang _ _ SrcStrict <- bang + , isUnliftedType orig_arg_ty + = addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty + + -- Warn about a ~ on an unlifted type (#21951) + -- e.g. data T = MkT ~Int# + | HsSrcBang _ _ SrcLazy <- bang + , isUnliftedType orig_arg_ty + = addDiagnosticTc $ TcRnLazyBangOnUnliftedType orig_arg_ty + + -- Warn about unusable UNPACK pragmas + -- e.g. data T a = MkT {-# UNPACK #-} !a -- Can't unpack + | HsSrcBang _ want_unpack _ <- bang + + -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon. + , isSrcUnpacked want_unpack -- this means the user wrote {-# UNPACK #-} + , case rep_bang of { HsUnpack {} -> False; HsStrict True -> False; _ -> True } + + -- When typechecking an indefinite package in Backpack, we + -- may attempt to UNPACK an abstract type. The test here will + -- conclude that this is unusable, but it might become usable + -- when we actually fill in the abstract type. As such, don't + -- warn in this case (it gives users the wrong idea about whether + -- or not UNPACK on abstract types is supported; it is!) + , isHomeUnitDefinite (hsc_home_unit hsc_env) + = addDiagnosticTc (bad_bang n UnusableUnpackPragma) + + | otherwise + = return () + + ; void $ zipWith4M check_bang (map scaledThing $ dataConOrigArgTys con) + (dataConSrcBangs con) (dataConImplBangs con) [1..] + + -- Check the dcUserTyVarBinders invariant + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon + -- checked here because we sometimes build invalid DataCons before + -- erroring above here + ; when debugIsOn $ whenNoErrs $ + massertPpr (checkDataConTyVars con) $ + ppr con $$ ppr (dataConFullSig con) $$ ppr (dataConUserTyVars con) + + ; traceTc "Done validity of data con" $ + vcat [ ppr con + , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con) + , text "Datacon src bangs:" <+> ppr (dataConSrcBangs con) + , text "Datacon impl bangs:" <+> ppr (dataConImplBangs con) + , text "Datacon rep type:" <+> ppr (dataConRepType con) + , text "Datacon display type:" <+> ppr data_con_display_type + , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con)) + , case tyConFamInst_maybe (dataConTyCon con) of + Nothing -> text "not family" + Just (f, _) -> ppr (tyConBinders f) ] + } + where + bang_opts = initBangOpts dflags + con_name = dataConName con + con_loc = nameSrcSpan con_name + ctxt = ConArgCtxt con_name + is_strict = \case + NoSrcStrict -> bang_opt_strict_data bang_opts + bang -> isSrcStrict bang + + bad_bang n + = TcRnBadFieldAnnotation n con + + show_linear_types = xopt LangExt.LinearTypes dflags + data_con_display_type = dataConDisplayType show_linear_types con + +------------------------------- +checkNewDataCon :: DataCon -> TcM () +-- Further checks for the data constructor of a newtype +-- You might wonder if we need to check for an unlifted newtype +-- without -XUnliftedNewtypes, such as +-- newtype C = MkC Int# +-- But they are caught earlier, by GHC.Tc.Gen.HsType.checkDataKindSig +checkNewDataCon con + = do { show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags + ; checkNoErrs $ + -- Fail here if the newtype is invalid: subsequent code in + -- checkValidDataCon can fall over if it comes across an invalid newtype. + do { case arg_tys of + [Scaled arg_mult _] -> + unless (ok_mult arg_mult) $ + addErrTc $ + TcRnIllegalNewtype con show_linear_types IsNonLinear + _ -> + addErrTc $ + TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys) + + -- Add an error if the newtype is a GADt or has existentials. + -- + -- If the newtype is a GADT, the GADT error is enough; + -- we don't need to *also* complain about existentials. + ; if not (null eq_spec) + then addErrTc $ TcRnIllegalNewtype con show_linear_types IsGADT + else unless (null ex_tvs) $ + addErrTc $ + TcRnIllegalNewtype con show_linear_types HasExistentialTyVar + + ; unless (null theta) $ + addErrTc $ + TcRnIllegalNewtype con show_linear_types HasConstructorContext + + ; unless (all ok_bang (dataConSrcBangs con)) $ + addErrTc $ + TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation } } + where + + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig con + + ok_bang (HsSrcBang _ _ SrcStrict) = False + ok_bang (HsSrcBang _ _ SrcLazy) = False + ok_bang _ = True + + ok_mult OneTy = True + ok_mult _ = False + +------------------------------- +checkValidClass :: Class -> TcM () +checkValidClass cls + = do { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods + ; multi_param_type_classes <- xoptM LangExt.MultiParamTypeClasses + ; nullary_type_classes <- xoptM LangExt.NullaryTypeClasses + ; fundep_classes <- xoptM LangExt.FunctionalDependencies + ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses + + -- Check that the class is unary, unless multiparameter type classes + -- are enabled; also recognize deprecated nullary type classes + -- extension (subsumed by multiparameter type classes, #8993) + ; checkTc (multi_param_type_classes || cls_arity == 1 || + (nullary_type_classes && cls_arity == 0)) + (TcRnClassExtensionDisabled cls (MultiParamDisabled cls_arity)) + ; unless (fundep_classes || null fundeps) $ + addErrTc (TcRnClassExtensionDisabled cls FunDepsDisabled) + + -- Check the super-classes + ; checkValidTheta (ClassSCCtxt (className cls)) theta + + -- Now check for cyclic superclasses + -- If there are superclass cycles, checkClassCycleErrs bails. + ; unless undecidable_super_classes $ + case checkClassCycles cls of + Just err -> setSrcSpan (getSrcSpan cls) $ + addErrTc (TcRnSuperclassCycle err) + Nothing -> return () + + -- Check the class operations. + -- But only if there have been no earlier errors + -- See Note [Abort when superclass cycle is detected] + ; whenNoErrs $ + mapM_ (check_op constrained_class_methods) op_stuff + + -- Check the associated type defaults are well-formed and instantiated + ; mapM_ check_at at_stuff } + where + (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls + cls_arity = length (tyConVisibleTyVars (classTyCon cls)) + -- Ignore invisible variables + cls_tv_set = mkVarSet tyvars + + check_op constrained_class_methods (sel_id, dm) + = setSrcSpan (getSrcSpan sel_id) $ + addErrCtxt (ClassOpCtxt sel_id op_ty) $ do + { traceTc "class op type" (ppr op_ty) + ; checkValidType ctxt op_ty + -- This implements the ambiguity check, among other things + -- Example: tc223 + -- class Error e => Game b mv e | b -> mv e where + -- newBoard :: MonadState b m => m () + -- Here, MonadState has a fundep m->b, so newBoard is fine + + -- NB: we don't check that the class method is not representation-polymorphic here, + -- as GHC.TcGen.TyCl.tcClassSigType already includes a subtype check that guarantees + -- typeclass methods always have kind 'Type'. + -- + -- Test case: rep-poly/RepPolyClassMethod. + + ; unless constrained_class_methods $ + mapM_ check_constraint op_theta + + ; check_dm ctxt sel_id cls_pred tau2 dm + } + where + ctxt = FunSigCtxt op_name (WantRRC (getSrcSpan cls)) -- Report redundant class constraints + op_name = idName sel_id + op_ty = idType sel_id + (_,cls_pred,tau1) = tcSplitMethodTy op_ty + -- See Note [Splitting nested sigma types in class type signatures] + (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1 + + check_constraint :: TcPredType -> TcM () + check_constraint pred -- See Note [Class method constraints] + = when (not (isEmptyVarSet pred_tvs) && + pred_tvs `subVarSet` cls_tv_set) + (addErrTc (TcRnClassExtensionDisabled cls (ConstrainedClassMethodsDisabled sel_id pred))) + where + pred_tvs = tyCoVarsOfType pred + + check_at (ATI fam_tc m_dflt_rhs) + = do { traceTc "ati" (ppr fam_tc $$ ppr tyvars $$ ppr fam_tvs) + ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + InvalidAssoc $ InvalidAssocInstance $ + AssocNoClassTyVar cls fam_tc + -- Check that the associated type mentions at least + -- one of the class type variables + -- The check is disabled for nullary type classes, + -- since there is no possible ambiguity (#10020) + + -- Check that any default declarations for associated types are valid + ; whenIsJust m_dflt_rhs $ \ (_, at_validity_info) -> + case at_validity_info of + NoVI -> pure () + VI { vi_loc = loc + , vi_qtvs = qtvs + , vi_non_user_tvs = non_user_tvs + , vi_pats = pats + , vi_rhs = orig_rhs } -> + let + inst_flav = + TyConInstFlavour + { tyConInstFlavour = tyConFlavour fam_tc + , tyConInstIsDefault = True + } + in + setSrcSpan loc $ + tcAddFamInstCtxt inst_flav (getName fam_tc) $ + do { checkValidAssocTyFamDeflt fam_tc pats + ; checkFamPatBinders fam_tc qtvs non_user_tvs pats orig_rhs + ; checkValidTyFamEqn fam_tc pats orig_rhs }} + where + fam_tvs = tyConTyVars fam_tc + + check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM () + -- Check validity of the /top-level/ generic-default type + -- E.g for class C a where + -- default op :: forall b. (a~b) => blah + -- we do not want to do an ambiguity check on a type with + -- a free TyVar 'a' (#11608). See TcType + -- Note [TyVars and TcTyVars during type checking] in GHC.Tc.Utils.TcType + -- Hence the mkDefaultMethodType to close the type. + check_dm ctxt sel_id vanilla_cls_pred vanilla_tau + (Just (dm_name, dm_spec@(GenericDM dm_ty))) + = setSrcSpan (getSrcSpan dm_name) $ do + -- We have carefully set the SrcSpan on the generic + -- default-method Name to be that of the generic + -- default type signature + + -- First, we check that the method's default type signature + -- aligns with the non-default type signature. + -- See Note [Default method type signatures must align] + let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls + -- Note that the second field of this tuple contains the context + -- of the default type signature, making it apparent that we + -- ignore method contexts completely when validity-checking + -- default type signatures. See the end of + -- Note [Default method type signatures must align] + -- to learn why this is OK. + -- + -- See also + -- Note [Splitting nested sigma types in class type signatures] + -- for an explanation of why we don't use tcSplitSigmaTy here. + (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty + + -- Given this class definition: + -- + -- class C a b where + -- op :: forall p q. (Ord a, D p q) + -- => a -> b -> p -> (a, b) + -- default op :: forall r s. E r + -- => a -> b -> s -> (a, b) + -- + -- We want to match up two types of the form: + -- + -- Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb) + -- Default type sig: C a b => a -> b -> s -> (a, b) + -- + -- Notice that the two type signatures can be quantified over + -- different class type variables! Therefore, it's important that + -- we include the class predicate parts to match up a with aa and + -- b with bb. + vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau + dm_phi_ty = mkPhiTy [cls_pred] dm_tau + + traceTc "check_dm" $ vcat + [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty + , text "dm_phi_ty" <+> ppr dm_phi_ty ] + + -- Actually checking that the types align is done with a call to + -- tcMatchTys. We need to get a match in both directions to rule + -- out degenerate cases like these: + -- + -- class Foo a where + -- foo1 :: a -> b + -- default foo1 :: a -> Int + -- + -- foo2 :: a -> Int + -- default foo2 :: a -> b + unless (isJust (tcMatchTy dm_phi_ty vanilla_phi_ty) && + isJust (tcMatchTy vanilla_phi_ty dm_phi_ty)) $ + addErrTc $ + TcRnDefaultSigMismatch sel_id dm_ty + + -- Now do an ambiguity check on the default type signature. + checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec) + check_dm _ _ _ _ _ = return () + +checkFamFlag :: Name -> TcM () +-- Check that we don't use families without -XTypeFamilies +-- The parser won't even parse them, but I suppose a GHC API +-- client might have a go! +checkFamFlag tc_name + = do { idx_tys <- xoptM LangExt.TypeFamilies + ; unless idx_tys $ addErrTc (TcRnTyFamsDisabled (TyFamsDisabledFamily tc_name)) } + +checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () +checkResultSigFlag tc_name (TyVarSig _ tvb) + = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies + ; unless ty_fam_deps $ addErrTc (TcRnTyFamResultDisabled tc_name tvb) } +checkResultSigFlag _ _ = return () -- other cases OK + +{- Note [Class method constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Haskell 2010 is supposed to reject + class C a where + op :: Eq a => a -> a +where the method type constrains only the class variable(s). (The extension +-XConstrainedClassMethods switches off this check.) But regardless +we should not reject + class C a where + op :: (?x::Int) => a -> a +as pointed out in #11793. So the test here rejects the program if + * -XConstrainedClassMethods is off + * the tyvars of the constraint are non-empty + * all the tyvars are class tyvars, none are locally quantified + +Note [Abort when superclass cycle is detected] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must avoid doing the ambiguity check for the methods (in +checkValidClass.check_op) when there are already errors accumulated. +This is because one of the errors may be a superclass cycle, and +superclass cycles cause canonicalization to loop. Here is a +representative example: + + class D a => C a where + meth :: D a => () + class C a => D a + +This fixes #9415, #9739 + +Note [Default method type signatures must align] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC enforces the invariant that a class method's default type signature +must "align" with that of the method's non-default type signature, as per +GHC #12918. For instance, if you have: + + class Foo a where + bar :: forall b. Context => a -> b + +Then a default type signature for bar must be alpha equivalent to +(forall b. a -> b). That is, the types must be the same modulo differences in +contexts. So the following would be acceptable default type signatures: + + default bar :: forall b. Context1 => a -> b + default bar :: forall x. Context2 => a -> x + +But the following are NOT acceptable default type signatures: + + default bar :: forall b. b -> a + default bar :: forall x. x + default bar :: a -> Int + +Note that a is bound by the class declaration for Foo itself, so it is +not allowed to differ in the default type signature. + +The default type signature (default bar :: a -> Int) deserves special mention, +since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To +write this, you need to declare the default type signature like so: + + default bar :: forall b. (b ~ Int). a -> b + +As noted in #12918, there are several reasons to do this: + +1. It would make no sense to have a type that was flat-out incompatible with + the non-default type signature. For instance, if you had: + + class Foo a where + bar :: a -> Int + default bar :: a -> Bool + + Then that would always fail in an instance declaration. So this check + nips such cases in the bud before they have the chance to produce + confusing error messages. + +2. Internally, GHC uses TypeApplications to instantiate the default method in + an instance. See Note [Default methods in instances] in GHC.Tc.TyCl.Instance. + Thus, GHC needs to know exactly what the universally quantified type + variables are, and when instantiated that way, the default method's type + must match the expected type. + +3. Aesthetically, by only allowing the default type signature to differ in its + context, we are making it more explicit the ways in which the default type + signature is less polymorphic than the non-default type signature. + +You might be wondering: why are the contexts allowed to be different, but not +the rest of the type signature? That's because default implementations often +rely on assumptions that the more general, non-default type signatures do not. +For instance, in the Enum class declaration: + + class Enum a where + enum :: [a] + default enum :: (Generic a, GEnum (Rep a)) => [a] + enum = map to genum + + class GEnum f where + genum :: [f a] + +The default implementation for enum only works for types that are instances of +Generic, and for which their generic Rep type is an instance of GEnum. But +clearly enum doesn't _have_ to use this implementation, so naturally, the +context for enum is allowed to be different to accommodate this. As a result, +when we validity-check default type signatures, we ignore contexts completely. + +Note that when checking whether two type signatures match, we must take care to +split as many foralls as it takes to retrieve the tau types we which to check. +See Note [Splitting nested sigma types in class type signatures]. + +Extra note: July 22. If we have + class C a b where + op :: op_ty + default op :: def_ty + op = blah + +then we'll generate something like + $gdm_op :: C a b => def_ty + $gdm_op = blah + +We expect to write an instance that looks (in effect) like this: + instance G => C t1 t2 where + op = $gdm_op -- Added when you leave out binding for 'op' + +So we need that + assuming constraints G, and C t1 t2, + we have (def_ty[t1/a,t2/b] <= op_ty[t1/a,t2/b] + +In the validity check, we want to check that there is such a G. +E.g. if we check def_ty <= op_ty, and get an insoluble constraint +(Int~Bool), we know there will never be such a G, and can complain. + +This seems to be a more general way of thinking about the problem. +But no one is complaining, so it'll have to wait for another day + +Note [Splitting nested sigma types in class type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this type synonym and class definition: + + type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t + + class Each s t a b where + each :: Traversal s t a b + default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b + +It might seem obvious that the tau types in both type signatures for `each` +are the same, but actually getting GHC to conclude this is surprisingly tricky. +That is because in general, the form of a class method's non-default type +signature is: + + forall a. C a => forall d. D d => E a b + +And the general form of a default type signature is: + + forall f. F f => E a f -- The variable `a` comes from the class + +So it you want to get the tau types in each type signature, you might find it +reasonable to call tcSplitSigmaTy twice on the non-default type signature, and +call it once on the default type signature. For most classes and methods, this +will work, but Each is a bit of an exceptional case. The way `each` is written, +it doesn't quantify any additional type variables besides those of the Each +class itself, so the non-default type signature for `each` is actually this: + + forall s t a b. Each s t a b => Traversal s t a b + +Notice that there _appears_ to only be one forall. But there's actually another +forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy +twice, you'll also go under the forall in Traversal! That is, you'll end up +with: + + (a -> f b) -> s -> f t + +A problem arises because you only call tcSplitSigmaTy once on the default type +signature for `each`, which gives you + + Traversal s t a b + +Or, equivalently: + + forall f. Applicative f => (a -> f b) -> s -> f t + +This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will +say that the tau types for `each` are not equal. + +A solution to this problem is to use tcSplitNestedSigmaTys instead of +tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it +sees until it can't go any further, so if you called it on the default type +signature for `each`, it would return (a -> f b) -> s -> f t like we desired. + +Note [Checking partial record field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This check checks the partial record field selector, and warns (#7169). + +For example: + + data T a = A { m1 :: a, m2 :: a } | B { m1 :: a } + +The function 'm2' is partial record field, and will fail when it is applied to +'B'. The warning identifies such partial fields. The check is performed at the +declaration of T, not at the call-sites of m2. + +The warning can be suppressed by prefixing the field-name with an underscore. +For example: + + data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a } + +************************************************************************ +* * + Checking role validity +* * +************************************************************************ +-} + +checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM () +checkValidRoleAnnots role_annots tc + | isTypeSynonymTyCon tc = check_no_roles + | isFamilyTyCon tc = check_no_roles + | isAlgTyCon tc = check_roles + | otherwise = return () + where + -- Role annotations are given only on *explicit* variables, + -- but a tycon stores roles for all variables. + -- So, we drop the implicit roles (which are all Nominal, anyway). + name = tyConName tc + roles = tyConRoles tc + (vis_roles, vis_vars) = unzip $ mapMaybe pick_vis $ + zip roles (tyConBinders tc) + role_annot_decl_maybe = lookupRoleAnnot role_annots name + + pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar) + pick_vis (role, tvb) + | isVisibleTyConBinder tvb = Just (role, binderVar tvb) + | otherwise = Nothing + + check_roles = case role_annot_decl_maybe of + Nothing -> + setSrcSpan (getSrcSpan name) $ + -- See Note [Missing role annotations warning] + warnIf (not (isClassTyCon tc) && not (null vis_roles)) $ + TcRnMissingRoleAnnotation name vis_roles + Just (decl@(L loc (RoleAnnotDecl _ _ the_role_annots))) -> + addErrCtxt (RoleAnnotErrCtxt name) $ + setSrcSpanA loc $ do + { role_annots_ok <- xoptM LangExt.RoleAnnotations + ; unless role_annots_ok $ addErrTc $ TcRnRoleAnnotationsDisabled tc + ; checkTc (vis_vars `equalLength` the_role_annots) + (TcRnRoleCountMismatch (length vis_vars) decl) + ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles + -- Representational or phantom roles for class parameters + -- quickly lead to incoherence. So, we require + -- IncoherentInstances to have them. See #8773, #14292 + ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances + ; checkTc ( incoherent_roles_ok + || (not $ isClassTyCon tc) + || (all (== Nominal) vis_roles)) + (TcRnIncoherentRoles tc) + + ; lint <- goptM Opt_DoCoreLinting + ; when lint $ checkValidRoles tc } + + check_no_roles + = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl + +-- Note [Missing role annotations warning] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We warn about missing role annotations for tycons +-- 1. not type-classes: +-- type classes are nominal by default, which is most conservative +-- choice. E.g. we cannot have a type-class with an (accidentally) +-- phantom or representational type variable, as we can with +-- data types. +-- 2. with visible roles +-- +-- We don't make any exceptions for other data types. +-- In particular we explicitly warn about omitted (default and common) +-- representational roles. That is the point of the warning. +-- For example the default representational role for `Map`s key type parameter +-- would be wrong, and this warning is there to warn about it, +-- asking users to be explicit. +-- +-- If the default roles have been nominal, i.e. as conservative as possible, +-- the warning would still be valuable, as most types can be `representational` +-- (c.f. type-classes, which usually cannot). +-- +-- We don't warn about types with invisible roles only, because users cannot +-- specify them: +-- +-- type Foo :: forall {k}. Type +-- data Foo = Foo Int +-- type role Foo phantom +-- +-- is incorrect, GHC complains: +-- Wrong number of roles listed in role annotation; +-- Expected 0, got 1: +-- + +checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM () +checkRoleAnnot _ (L _ Nothing) _ = return () +checkRoleAnnot tv (L _ (Just r1)) r2 + = when (r1 /= r2) $ + addErrTc $ TcRnRoleMismatch (tyVarName tv) r1 r2 + +-- This is a double-check on the role inference algorithm. It is only run when +-- -dcore-lint is enabled. See Note [Role inference] in GHC.Tc.TyCl.Utils +checkValidRoles :: TyCon -> TcM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +checkValidRoles tc + | isAlgTyCon tc + -- tyConDataCons returns an empty list for data families + = mapM_ check_dc_roles (tyConDataCons tc) + | Just rhs <- synTyConRhs_maybe tc + = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs + | otherwise + = return () + where + check_dc_roles datacon + = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) + ; mapM_ (check_ty_roles role_env Representational) $ + eqSpecPreds eq_spec ++ theta ++ map scaledThing arg_tys } + -- See Note [Role-checking data constructor arguments] in GHC.Tc.TyCl.Utils + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig datacon + univ_roles = zipVarEnv univ_tvs (tyConRoles tc) + -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs + ex_roles = mkVarEnv (map (, Nominal) ex_tvs) + role_env = univ_roles `plusVarEnv` ex_roles + + check_ty_roles env role ty + | Just ty' <- coreView ty -- #14101 + = check_ty_roles env role ty' + + check_ty_roles env role (TyVarTy tv) + = case lookupVarEnv env tv of + Just role' -> unless (role' `ltRole` role || role' == role) $ + report_error role $ TyVarRoleMismatch tv role' + Nothing -> report_error role $ TyVarMissingInEnv tv + + check_ty_roles env Representational (TyConApp tc tys) + = let roles' = tyConRoles tc in + zipWithM_ (maybe_check_ty_roles env) roles' tys + + check_ty_roles env Nominal (TyConApp _ tys) + = mapM_ (check_ty_roles env Nominal) tys + + check_ty_roles _ Phantom ty@(TyConApp {}) + = pprPanic "check_ty_roles" (ppr ty) + + check_ty_roles env role (AppTy ty1 ty2) + = check_ty_roles env role ty1 + >> check_ty_roles env Nominal ty2 + + check_ty_roles env role (FunTy _ w ty1 ty2) + = check_ty_roles env Nominal w + >> check_ty_roles env role ty1 + >> check_ty_roles env role ty2 + + check_ty_roles env role (ForAllTy (Bndr tv _) ty) + = check_ty_roles env Nominal (tyVarKind tv) + >> check_ty_roles (extendVarEnv env tv Nominal) role ty + + check_ty_roles _ _ (LitTy {}) = return () + + check_ty_roles env role (CastTy t _) + = check_ty_roles env role t + + check_ty_roles _ role (CoercionTy co) + = unless (role == Phantom) $ + report_error role $ BadCoercionRole co + + maybe_check_ty_roles env role ty + = when (role == Nominal || role == Representational) $ + check_ty_roles env role ty + + report_error role reason + = addErrTc $ TcRnRoleValidationFailed role reason + +{- +************************************************************************ +* * + Error messages +* * +************************************************************************ +-} + +tcMkDeclCtxt :: TyClDecl GhcRn -> ErrCtxtMsg +tcMkDeclCtxt decl = + TyConDeclCtxt (tcdName decl) (tyClDeclFlavour decl) + +addVDQNote :: TcTyCon -> TcM a -> TcM a +-- See Note [Inferring visible dependent quantification] +-- Only types without a signature (CUSK or SAKS) here +addVDQNote tycon thing_inside + | assertPpr (isMonoTcTyCon tycon) (ppr tycon $$ ppr tc_kind) + has_vdq + = addLandmarkErrCtxt (VDQWarningCtxt tycon) thing_inside + | otherwise + = thing_inside + where + -- Check whether a tycon has visible dependent quantification. + -- This will *always* be a TcTyCon. Furthermore, it will *always* + -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader. + -- Thus, all the TyConBinders will be anonymous. Thus, the + -- free variables of the tycon's kind will be the same as the free + -- variables from all the binders. + has_vdq = any is_vdq_tcb (tyConBinders tycon) + tc_kind = tyConKind tycon + kind_fvs = tyCoVarsOfType tc_kind + + is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) && + isVisibleTyConBinder tcb + +tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a +tcAddDeclCtxt decl thing_inside + = addErrCtxt (tcMkDeclCtxt decl) thing_inside + +tcAddOpenTyFamInstCtxt :: AssocInstInfo -> TyFamInstDecl GhcRn -> TcM a -> TcM a +tcAddOpenTyFamInstCtxt mb_assoc decl + = tcAddFamInstCtxt flav (tyFamInstDeclName decl) + where + assoc = case mb_assoc of + NotAssociated -> Nothing + InClsInst { ai_class = cls } -> Just $ classTyCon cls + flav = TyConInstFlavour + { tyConInstFlavour = OpenFamilyFlavour IAmType assoc + , tyConInstIsDefault = False + } + +tcMkDataFamInstCtxt :: AssocInstInfo -> NewOrData -> DataFamInstDecl GhcRn -> ErrCtxtMsg +tcMkDataFamInstCtxt mb_assoc new_or_data (DataFamInstDecl { dfid_eqn = eqn }) + = TyConInstCtxt (unLoc (feqn_tycon eqn)) + (TyConInstFlavour + { tyConInstFlavour = OpenFamilyFlavour (IAmData new_or_data) assoc + , tyConInstIsDefault = False + }) + where + assoc = case mb_assoc of + NotAssociated -> Nothing + InClsInst { ai_class = cls } -> Just $ classTyCon cls + +tcAddDataFamInstCtxt :: AssocInstInfo -> NewOrData -> DataFamInstDecl GhcRn -> TcM a -> TcM a +tcAddDataFamInstCtxt assoc new_or_data decl + = addErrCtxt (tcMkDataFamInstCtxt assoc new_or_data decl) + +tcAddFamInstCtxt :: TyConInstFlavour -> Name -> TcM a -> TcM a +tcAddFamInstCtxt flavour tycon thing_inside + = addErrCtxt (TyConInstCtxt tycon flavour) thing_inside + +illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () +illegalRoleAnnotDecl (L loc role) + = setErrCtxt [] $ + setSrcSpanA loc $ + addErrTc $ TcRnIllegalRoleAnnotation role + +addTyConCtxt :: TyCon -> TcM a -> TcM a +addTyConCtxt tc = addErrCtxt (TyConDeclCtxt name flav) + where + name = getName tc + flav = tyConFlavour tc diff --git a/GHC/Tc/TyCl/Build.hs b/GHC/Tc/TyCl/Build.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/Build.hs @@ -0,0 +1,446 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.TyCl.Build ( + buildDataCon, + buildPatSyn, + TcMethInfo, MethInfo, + buildClass, buildAbstractClass, + mkNewTyConRhs, + newImplicitBinder, newTyConRepName + ) where + +import GHC.Prelude + +import GHC.Iface.Env +import GHC.Builtin.Types + +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad + +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) + +import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id.Make +import GHC.Types.SourceText +import GHC.Types.Unique.Supply + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + + +mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs +-- ^ Monadic because it makes a Name for the coercion TyCon +-- We pass the Name of the parent TyCon, as well as the TyCon itself, +-- because the latter is part of a knot, whereas the former is not. +mkNewTyConRhs tycon_name tycon con + = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc + ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs + ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax) + ; return (NewTyCon { data_con = con, + nt_rhs = rhs_ty, + nt_etad_rhs = (etad_tvs, etad_rhs), + nt_co = nt_ax, + nt_fixed_rep = isFixedRuntimeRepKind res_kind } ) } + -- Coreview looks through newtypes with a Nothing + -- for nt_co, or uses explicit coercions otherwise + where + tvs = tyConTyVars tycon + roles = tyConRoles tycon + res_kind = tyConResKind tycon + rhs_ty + -- Only try if the newtype is actually valid (see "otherwise" below). + | [Scaled _ arg_ty] <- dataConRepArgTys con + , null $ dataConExTyCoVars con + = substTyWith (dataConUnivTyVars con) + (mkTyVarTys tvs) arg_ty + -- Instantiate the newtype's RHS with the + -- type variables from the tycon + -- NB: a newtype DataCon has a type that must look like + -- forall tvs. -> T tvs + -- Note that we *can't* use dataConInstOrigArgTys here because + -- the newtype arising from class Foo a => Bar a where {} + -- has a single argument (Foo a) that is a *type class*, so + -- dataConInstOrigArgTys returns []. + | otherwise + -- If the newtype is invalid (e.g. doesn't have a single argument), + -- we fake up a type here. The newtype will get rejected once we're + -- outside the knot-tied loop, in GHC.Tc.TyCl.checkNewDataCon. + -- See the various test cases in T23308. + = unitTy -- Might be ill-kinded, but checkNewDataCon should reject this + -- whole declaration soon enough, before that causes any problems. + + -- Eta-reduce the newtype + -- See Note [Newtype eta] in GHC.Core.TyCon + etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can + etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty + etad_rhs :: Type -- See Note [Tricky iface loop] in GHC.Iface.Load + (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty + + eta_reduce :: [TyVar] -- Reversed + -> [Role] -- also reversed + -> Type -- Rhs type + -> ([TyVar], [Role], Type) -- Eta-reduced version + -- (tyvars in normal order) + eta_reduce (a:as) (_:rs) ty + | Just (fun, arg) <- splitAppTy_maybe ty + , Just tv <- getTyVar_maybe arg + , tv == a + , not (a `elemVarSet` tyCoVarsOfType fun) + , typeKind fun `eqType` typeKind (mkTyConApp tycon (mkTyVarTys $ reverse as)) + -- Why this kind-check? See Note [Newtype eta and homogeneous axioms] + = eta_reduce as rs fun + eta_reduce as rs ty = (reverse as, reverse rs, ty) + +{- Note [Newtype eta and homogeneous axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When eta-reducing a newtype, we must be careful to make sure the axiom +is homogeneous. (That is, the two types related by the axiom must +have the same kind.) All known proofs of type safety for Core rely on +the homogeneity of axioms, so let's not monkey with that. + +It is easy to mistakenly make an inhomogeneous axiom (#19739): + type T :: forall (a :: Type) -> Type + newtype T a = MkT (Proxy a) + +Can we eta-reduce, thus? + axT :: T ~ Proxy + +No! Because + T :: forall a -> Type + Proxy :: Type -> Type + +This is inhomogeneous. Hence, we have an extra kind-check in eta_reduce, +to make sure the reducts have the same kind. This is simple, although +perhaps quadratic in complexity, if we eta-reduce many arguments (which +seems vanishingly unlikely in practice). But NB that the free-variable +check, which immediately precedes the kind check, is also potentially +quadratic. + +There are other ways we could do the check (discussion on #19739): + +* We could look at the sequence of binders on the newtype and on the + head of the representation type, and make sure the visibilities on + the binders match up. This is quite a bit more code, and the reasoning + is subtler. + +* We could, say, do the kind-check at the end and then backtrack until the + kinds match up. Hard to know whether that's more performant or not. +-} + +------------------------------------------------------ +buildDataCon :: FamInstEnvs + -> DataConBangOpts + -> Name + -> Bool -- Declared infix + -> TyConRepName + -> [HsSrcBang] + -> [FieldLabel] -- Field labels + -> [TyVar] -- Universals + -> [TyCoVar] -- Existentials + -> [TyVarBinder] -- User-written 'TyVarBinder's + -> [EqSpec] -- Equality spec + -> KnotTied ThetaType -- Does not include the "stupid theta" + -- or the GADT equalities + -> [KnotTied (Scaled Type)] -- Arguments + -> KnotTied Type -- Result types + -> KnotTied TyCon -- Rep tycon + -> NameEnv ConTag -- Maps the Name of each DataCon to its + -- ConTag + -> TcRnIf m n DataCon +-- A wrapper for DataCon.mkDataCon that +-- a) makes the worker Id +-- b) makes the wrapper Id if necessary, including +-- allocating its unique (hence monadic) +buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs + field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty + rep_tycon tag_map + = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc + ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc + -- This last one takes the name of the data constructor in the source + -- code, which (for Haskell source anyway) will be in the DataName name + -- space, and puts it into the VarName name space + + ; traceIf (text "buildDataCon 1" <+> ppr src_name) + ; us <- newUniqueSupply + ; let stupid_ctxt = mkDataConStupidTheta rep_tycon (map scaledThing arg_tys) univ_tvs + tag = lookupNameEnv_NF tag_map src_name + -- See Note [Constructor tag allocation], fixes #14657 + data_con = mkDataCon src_name declared_infix prom_info + src_bangs impl_bangs str_marks field_lbls + univ_tvs ex_tvs + noConcreteTyVars + user_tvbs eq_spec ctxt + arg_tys res_ty NoPromInfo rep_tycon tag + stupid_ctxt dc_wrk dc_rep + dc_wrk = mkDataConWorkId work_name data_con + (dc_rep, impl_bangs, str_marks) = + initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con) + + ; traceIf (text "buildDataCon 2" <+> ppr src_name) + ; return data_con } + + +-- The stupid context for a data constructor should be limited to +-- the type variables mentioned in the arg_tys +-- ToDo: Or functionally dependent on? +-- This whole stupid theta thing is, well, stupid. +-- +-- See Note [The stupid context] in GHC.Core.DataCon. +mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] +mkDataConStupidTheta tycon arg_tys univ_tvs + | null stupid_theta = [] -- The common case + | otherwise = filter in_arg_tys stupid_theta + where + tc_subst = zipTvSubst (tyConTyVars tycon) + (mkTyVarTys univ_tvs) + stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) + -- Start by instantiating the master copy of the + -- stupid theta, taken from the TyCon + + arg_tyvars = tyCoVarsOfTypes arg_tys + in_arg_tys pred = tyCoVarsOfType pred `intersectsVarSet` arg_tyvars + + +------------------------------------------------------ +buildPatSyn :: Name -> Bool + -> PatSynMatcher -> PatSynBuilder + -> ([InvisTVBinder], ThetaType) -- ^ Univ and req + -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov + -> [FRRType] -- ^ Argument types + -> Type -- ^ Result type + -> [FieldLabel] -- ^ Field labels for + -- a record pattern synonym + -> PatSyn +buildPatSyn src_name declared_infix matcher@(_, matcher_ty,_) builder + (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys + pat_ty field_labels + = -- The assertion checks that the matcher is + -- compatible with the pattern synonym + assertPpr (and [ univ_tvs `equalLength` univ_tvs1 + , ex_tvs `equalLength` ex_tvs1 + , pat_ty `eqType` substTy subst (scaledThing pat_ty1) + , prov_theta `eqTypes` substTys subst prov_theta1 + , req_theta `eqTypes` substTys subst req_theta1 + , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1)) + ]) + (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1 + , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1 + , ppr pat_ty <+> twiddle <+> ppr pat_ty1 + , ppr prov_theta <+> twiddle <+> ppr prov_theta1 + , ppr req_theta <+> twiddle <+> ppr req_theta1 + , ppr arg_tys <+> twiddle <+> ppr arg_tys1]) $ + mkPatSyn src_name declared_infix + (univ_tvs, req_theta) (ex_tvs, prov_theta) + arg_tys pat_ty + matcher builder field_labels + where + ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ matcher_ty + ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau + (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy (scaledThing cont_sigma) + (arg_tys1, _) = (tcSplitFunTys cont_tau) + twiddle = char '~' + subst = zipTvSubst (univ_tvs1 ++ ex_tvs1) + (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs))) + + -- For a nullary pattern synonym we add a single (# #) argument to the + -- matcher to preserve laziness in the case of unlifted types. + -- See #12746 + compareArgTys :: [Type] -> [Type] -> Bool + compareArgTys [] [x] = x `eqType` unboxedUnitTy + compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys + + +------------------------------------------------------ +type TcMethInfo = MethInfo -- this variant needs zonking +type MethInfo -- A temporary intermediate, to communicate + -- between tcClassSigs and buildClass. + = ( Name -- Name of the class op + , Type -- Type of the class op + , Maybe (DefMethSpec (SrcSpan, Type))) + -- Nothing => no default method + -- + -- Just VanillaDM => There is an ordinary + -- polymorphic default method + -- + -- Just (GenericDM (loc, ty)) => There is a generic default metho + -- Here is its type, and the location + -- of the type signature + -- We need that location /only/ to attach it to the + -- generic default method's Name; and we need /that/ + -- only to give the right location of an ambiguity error + -- for the generic default method, spat out by checkValidClass + +buildClass :: Name -- Name of the class/tycon (they have the same Name) + -> [TyConBinder] -- Of the tycon + -> [Role] + -> [FunDep TyVar] -- Functional dependencies + -> KnotTied ThetaType -- Superclasess + -> [ClassATItem] -- Associated types + -> [KnotTied MethInfo] -- Methods + -> ClassMinimalDef -- Minimal complete definition + -> Bool -- True <=> is a unary class + -> TcRnIf m n Class + +buildClass tycon_name binders roles fds sc_theta at_items sig_stuff mindef unary_class + = fixM $ \ rec_clas -> -- Only name generation inside loop + do { traceIf (text "buildClass") + + ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc + ; tc_rep_name <- newTyConRepName tycon_name + + ; op_items <- mapM (mk_op_item rec_clas) sig_stuff + -- Build the selector id and default method id + + -- Make selectors for the superclasses + ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc) + (takeList sc_theta [fIRST_TAG..]) + ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas + | sc_name <- sc_sel_names] + -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we + -- can construct names for the selectors. Thus + -- class (C a, C b) => D a b where ... + -- gives superclass selectors + -- D_sc1, D_sc2 + -- (We used to call them D_C, but now we can have two different + -- superclasses both called C!) + + ; let args = sc_sel_names ++ op_names + op_tys = [ty | (_,ty,_) <- sig_stuff] + op_names = [op | (op,_,_) <- sig_stuff] + rec_tycon = classTyCon rec_clas + univ_bndrs = tyVarSpecToBinders $ tyConInvisTVBinders binders + univ_tvs = binderVars univ_bndrs + bang_opts = FixedBangOpts (map (const HsLazy) args) + + ; rep_nm <- newTyConRepName datacon_name + ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") + bang_opts + datacon_name + False -- Not declared infix + rep_nm + (map (const no_bang) args) + [{- No fields -}] + univ_tvs + [{- no existentials -}] + univ_bndrs + [{- No GADT equalities -}] + sc_theta + (map unrestricted op_tys) -- type classes are unrestricted + (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) + rec_tycon + (mkTyConTagMap rec_tycon) + + ; let rhs | unary_class + = UnaryClassTyCon dict_con + | isCTupleTyConName tycon_name + = TupleTyCon { data_con = dict_con + , tup_sort = ConstraintTuple } + | otherwise + = mkDataTyConRhs [dict_con] + + tycon = mkClassTyCon tycon_name binders roles + rhs rec_clas tc_rep_name + -- A class can be recursive, and in the case of newtypes + -- this matters. For example + -- class C a where { op :: C b => a -> b -> Int } + -- Because C has only one operation, it is represented by + -- a newtype, and it should be a *recursive* newtype. + -- [If we don't make it a recursive newtype, we'll expand the + -- newtype like a synonym, but that will lead to an infinite + -- type] + + result = mkClass tycon_name univ_tvs fds + sc_theta sc_sel_ids at_items + op_items mindef tycon + + ; traceIf (text "buildClass" <+> ppr tycon) + ; return result } + where + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict + + mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem + mk_op_item rec_clas (op_name, _, dm_spec) + = do { dm_info <- mk_dm_info op_name dm_spec + ; return (mkDictSelId op_name rec_clas, dm_info) } + + mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type)) + -> TcRnIf n m (Maybe (Name, DefMethSpec Type)) + mk_dm_info _ Nothing + = return Nothing + mk_dm_info op_name (Just VanillaDM) + = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc + ; return (Just (dm_name, VanillaDM)) } + mk_dm_info op_name (Just (GenericDM (loc, dm_ty))) + = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc + ; return (Just (dm_name, GenericDM dm_ty)) } + +buildAbstractClass :: Name + -> [TyConBinder] + -> [Role] + -> [FunDep TyVar] + -> TcRnIf m n Class + +buildAbstractClass tycon_name binders roles fds + = fixM $ \ rec_clas -> -- Only name generation inside loop + do { traceIf (text "buildClass") + + ; tc_rep_name <- newTyConRepName tycon_name + ; let univ_tvs = binderVars binders + tycon = mkClassTyCon tycon_name binders roles + AbstractTyCon + rec_clas tc_rep_name + result = mkAbstractClass tycon_name univ_tvs fds tycon + ; traceIf (text "buildClass" <+> ppr tycon) + ; return result } + +newImplicitBinder :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> TcRnIf m n Name -- Implicit name +-- Called in GHC.Tc.TyCl.Build to allocate the implicit binders of type/class decls +-- For source type/class decls, this is the first occurrence +-- For iface ones, GHC.Iface.Load has already allocated a suitable name in the cache +newImplicitBinder base_name mk_sys_occ + = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name) + +newImplicitBinderLoc :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> SrcSpan + -> TcRnIf m n Name -- Implicit name +-- Just the same, but lets you specify the SrcSpan +newImplicitBinderLoc base_name mk_sys_occ loc + | Just mod <- nameModule_maybe base_name + = newGlobalBinder mod occ loc + | otherwise -- When typechecking a [d| decl bracket |], + -- TH generates types, classes etc with Internal names, + -- so we follow suit for the implicit binders + = do { uniq <- newUnique + ; return (mkInternalName uniq occ loc) } + where + occ = mk_sys_occ (nameOccName base_name) + +-- | Make the 'TyConRepName' for this 'TyCon' +newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName +newTyConRepName tc_name + | Just mod <- nameModule_maybe tc_name + , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name) + = newGlobalBinder mod occ noSrcSpan + | otherwise + = newImplicitBinder tc_name mkTyConRepOcc diff --git a/GHC/Tc/TyCl/Class.hs b/GHC/Tc/TyCl/Class.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/Class.hs @@ -0,0 +1,601 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + + +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking class declarations +module GHC.Tc.TyCl.Class + ( tcClassSigs + , tcClassDecl2 + , findMethodBind + , instantiateMethod + , tcClassMinimalDef + , HsSigFun + , mkHsSigFun + , instDeclCtxt1 + , instDeclCtxt2 + , instDeclCtxt3 + , tcATDefault + , substATBndrs + ) +where + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Errors.Types +import GHC.Tc.Gen.Sig +import GHC.Tc.Types.Evidence ( idHsWrapper ) +import GHC.Tc.Gen.Bind +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Instantiate( newFamInst, tcSuperSkolTyVars ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad +import GHC.Tc.TyCl.Build( TcMethInfo ) + +import GHC.Core.Type ( extendTvSubstWithClone, piResultTys ) +import GHC.Core.Predicate +import GHC.Core.Multiplicity +import GHC.Core.Class +import GHC.Core.Coercion ( pprCoAxiom ) +import GHC.Core.FamInstEnv +import GHC.Core.TyCon + +import GHC.Driver.DynFlags + +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Var +import GHC.Types.Var.Env ( lookupVarEnv ) +import GHC.Types.SourceFile (HscSource(..)) +import GHC.Types.SrcLoc +import GHC.Types.Basic + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.Maybe +import GHC.Data.BooleanFormula + +import Control.Monad +import Data.List ( mapAccumL, partition ) +import qualified Data.List.NonEmpty as NE + +{- +Dictionary handling +~~~~~~~~~~~~~~~~~~~ +Every class implicitly declares a new data type, corresponding to dictionaries +of that class. So, for example: + + class (D a) => C a where + op1 :: a -> a + op2 :: forall b. Ord b => a -> b -> b + +would implicitly declare + + data CDict a = CDict (D a) + (a -> a) + (forall b. Ord b => a -> b -> b) + +(We could use a record decl, but that means changing more of the existing apparatus. +One step at a time!) + +For classes with just one superclass+method, we use a newtype decl instead: + + class C a where + op :: forallb. a -> b -> b + +generates + + newtype CDict a = CDict (forall b. a -> b -> b) + +Now DictTy in Type is just a form of type synonym: + DictTy c t = TyConTy CDict `AppTy` t + +Death to "ExpandingDicts". + + +************************************************************************ +* * + Type-checking the class op signatures +* * +************************************************************************ +-} + +tcClassSigs :: Name -- Name of the class + -> [LSig GhcRn] + -> LHsBinds GhcRn + -> TcM [TcMethInfo] -- Exactly one for each method +tcClassSigs clas sigs def_methods + = do { traceTc "tcClassSigs 1" (ppr clas) + + ; gen_dm_prs <- concatMapM (addLocM tc_gen_sig) gen_sigs + ; let gen_dm_env :: NameEnv (SrcSpan, Type) + gen_dm_env = mkNameEnv gen_dm_prs + + ; op_info <- concatMapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs + + ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] + ; sequence_ [ failWithTc (TcRnBadMethodErr clas n) + | n <- dm_bind_names, not (n `elemNameSet` op_names) ] + -- Value binding for non class-method (ie no TypeSig) + + ; tcg_env <- getGblEnv + ; if tcg_src tcg_env == HsigFile + then + -- Error if we have value bindings + -- (Generic signatures without value bindings indicate + -- that a default of this form is expected to be + -- provided.) + case def_methods of + [] -> return () + meth : meths -> failWithTc (TcRnIllegalHsigDefaultMethods clas (meth NE.:| meths)) + else + -- Error for each generic signature without value binding + sequence_ [ failWithTc (TcRnBadGenericMethod clas n) + | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] + + ; traceTc "tcClassSigs 2" (ppr clas) + ; return op_info } + where + vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp + vanilla_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] + gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp + gen_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs] + dm_bind_names :: [Name] -- These ones have a value binding in the class decl + dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- def_methods] + + tc_sig :: NameEnv (SrcSpan, Type) -> ([LocatedN Name], LHsSigType GhcRn) + -> TcM [TcMethInfo] + tc_sig gen_dm_env (op_names, op_hs_ty) + = do { traceTc "ClsSig 1" (ppr op_names) + ; op_ty <- tcClassSigType op_names op_hs_ty + -- Class tyvars already in scope + + ; traceTc "ClsSig 2" (ppr op_names $$ ppr op_ty) + ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] } + where + f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty) + | nm `elem` dm_bind_names = Just VanillaDM + | otherwise = Nothing + + tc_gen_sig :: ([LocatedN Name], LHsSigType GhcRn) + -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))] -- AZ temp + tc_gen_sig (op_names, gen_hs_ty) + = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty + ; return [ (op_name, (locA loc, gen_op_ty)) + | L loc op_name <- op_names ] } + +{- +************************************************************************ +* * + Class Declarations +* * +************************************************************************ +-} + +tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration + -> TcM (LHsBinds GhcTc) + +tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, + tcdMeths = default_binds})) + = recoverM (return emptyLHsBinds) $ + setSrcSpan (getLocA class_name) $ + do { clas <- tcLookupLocatedClass (la2la class_name) + + -- We make a separate binding for each default method. + -- At one time I used a single AbsBinds for all of them, thus + -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } + -- But that desugars into + -- ds = \d -> (..., ..., ...) + -- dm1 = \d -> case ds d of (a,b,c) -> a + -- And since ds is big, it doesn't get inlined, so we don't get good + -- default methods. Better to make separate AbsBinds for each + + ; skol_info <- mkSkolemInfo (TyConSkol ClassFlavour (getName class_name)) + ; tc_lvl <- getTcLevel + ; let (tyvars, _, _, op_items) = classBigSig clas + prag_fn = mkPragEnv sigs default_binds + sig_fn = mkHsSigFun sigs + (_skol_subst, clas_tyvars) = tcSuperSkolTyVars tc_lvl skol_info tyvars + -- This make skolemTcTyVars, but does not clone, + -- so we can put them in scope with tcExtendTyVarEnv + pred = mkClassPred clas (mkTyVarTys clas_tyvars) + ; this_dict <- newEvVar pred + + ; let tc_item = tcDefMeth clas clas_tyvars this_dict + default_binds sig_fn prag_fn + ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ + mapM tc_item op_items + + ; return (concat dm_binds) } + +tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) + +tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn + -> HsSigFun -> TcPragEnv -> ClassOpItem + -> TcM (LHsBinds GhcTc) +-- Generate code for default methods +-- This is incompatible with Hugs, which expects a polymorphic +-- default method for every class op, regardless of whether or not +-- the programmer supplied an explicit default decl for the class. +-- (If necessary we can fix that, but we don't have a convenient Id to hand.) + +tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) + = do { -- No default method + mapM_ (addLocM (badDmPrag sel_id )) + (lookupPragEnv prag_fn (idName sel_id)) + ; return [] } + +tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn + (sel_id, Just (dm_name, dm_spec)) + | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn + = do { -- First look up the default method; it should be there! + -- It can be the ordinary default method + -- or the generic-default method. E.g of the latter + -- class C a where + -- op :: a -> a -> Bool + -- default op :: Eq a => a -> a -> Bool + -- op x y = x==y + -- The default method we generate is + -- $gm :: (C a, Eq a) => a -> a -> Bool + -- $gm x y = x==y + + global_dm_id <- tcLookupId dm_name + ; global_dm_id <- addInlinePrags global_dm_id prags + ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc + -- Base the local_dm_name on the selector name, because + -- type errors from tcInstanceMethodBody come from here + + ; spec_prags <- discardConstraints $ + tcSpecPrags global_dm_id prags + ; let dia = TcRnIgnoreSpecialisePragmaOnDefMethod sel_name + + ; diagnosticTc (not (null spec_prags)) dia + + ; let hs_ty = hs_sig_fn sel_name + `orElse` pprPanic "tc_dm" (ppr sel_name) + -- We need the HsType so that we can bring the right + -- type variables into scope + -- + -- Eg. class C a where + -- op :: forall b. Eq b => a -> [b] -> a + -- gen_op :: a -> a + -- generic gen_op :: D a => a -> a + -- The "local_dm_ty" is precisely the type in the above + -- type signatures, ie with no "forall a. C a =>" prefix + + local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) + + lm_bind = dm_bind { fun_id = L (l2l bind_loc) local_dm_name } + -- Substitute the local_meth_name for the binder + -- NB: the binding is always a FunBind + + warn_redundant = case dm_spec of + GenericDM {} -> lhsSigTypeContextSpan hs_ty + VanillaDM -> NoRRC + -- For GenericDM, warn if the user specifies a signature + -- with redundant constraints; but not for VanillaDM, where + -- the default method may well be 'error' or something + + ctxt = FunSigCtxt sel_name warn_redundant + + ; let local_dm_id = mkLocalId local_dm_name ManyTy local_dm_ty + local_dm_sig = CSig { sig_bndr = local_dm_id + , sig_ctxt = ctxt + , sig_loc = getLocA hs_ty } + + ; (ev_binds, (tc_bind, _)) + <- checkConstraints skol_info tyvars [this_dict] $ + tcPolyCheck no_prag_fn local_dm_sig + (L bind_loc lm_bind) + + ; let export = ABE { abe_poly = global_dm_id + , abe_mono = local_dm_id + , abe_wrap = idHsWrapper + , abe_prags = IsDefaultMethod } + full_bind = XHsBindsLR $ + AbsBinds { abs_tvs = tyvars + , abs_ev_vars = [this_dict] + , abs_exports = [export] + , abs_ev_binds = [ev_binds] + , abs_binds = tc_bind + , abs_sig = True } + + ; return [L bind_loc full_bind] } + + | otherwise = pprPanic "tcDefMeth" (ppr sel_id) + where + skol_info = TyConSkol ClassFlavour (getName clas) + sel_name = idName sel_id + no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; + -- they are all for meth_id + +--------------- +tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef +tcClassMinimalDef _clas sigs op_info + = case findMinimalDef sigs of + Nothing -> return defMindef + Just mindef -> do + -- Warn if the given mindef does not imply the default one + -- That is, the given mindef should at least ensure that the + -- class ops without default methods are required, since we + -- have no way to fill them in otherwise + tcg_env <- getGblEnv + -- However, only do this test when it's not an hsig file, + -- since you can't write a default implementation. + when (tcg_src tcg_env /= HsigFile) $ + whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ + (\bf -> addDiagnosticTc (TcRnWarningMinimalDefIncomplete bf)) + return mindef + where + -- By default require all methods without a default implementation + defMindef :: ClassMinimalDef + defMindef = mkAnd [ noLocA (mkVar (noLocA name)) + | (name, _, Nothing) <- op_info ] + +instantiateMethod :: Class -> TcId -> [TcType] -> TcType +-- Take a class operation, say +-- op :: forall ab. C a => forall c. Ix c => (b,c) -> a +-- Instantiate it at [ty1,ty2] +-- Return the "local method type": +-- forall c. Ix x => (ty2,c) -> ty1 +instantiateMethod clas sel_id inst_tys + = assert ok_first_pred local_meth_ty + where + rho_ty = piResultTys (idType sel_id) inst_tys + (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty + `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) + + ok_first_pred = case getClassPredTys_maybe first_pred of + Just (clas1, _tys) -> clas == clas1 + Nothing -> False + -- The first predicate should be of form (C a b) + -- where C is the class in question + + +--------------------------- +type HsSigFun = Name -> Maybe (LHsSigType GhcRn) + +mkHsSigFun :: [LSig GhcRn] -> HsSigFun +mkHsSigFun sigs = lookupNameEnv env + where + env = mkHsSigEnv get_classop_sig sigs + + get_classop_sig :: LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn) + get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty) + get_classop_sig _ = Nothing + +--------------------------- +findMethodBind :: Name -- Selector + -> LHsBinds GhcRn -- A group of bindings + -> TcPragEnv + -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn]) + -- Returns the binding, the binding + -- site of the method binder, and any inline or + -- specialisation pragmas +findMethodBind sel_name binds prag_fn + = foldl' mplus Nothing (map f binds) + where + prags = lookupPragEnv prag_fn sel_name + + f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) + | op_name == sel_name + = Just (bind, locA bndr_loc, prags) + f _other = Nothing + +--------------------------- +findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef +findMinimalDef = firstJusts . map toMinimalDef + where + toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef + toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just bf + toMinimalDef _ = Nothing + +{- +Note [Polymorphic methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class Foo a where + op :: forall b. Ord b => a -> b -> b -> b + instance Foo c => Foo [c] where + op = e + +When typechecking the binding 'op = e', we'll have a meth_id for op +whose type is + op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b + +So tcPolyBinds must be capable of dealing with nested polytypes; +and so it is. See GHC.Tc.Gen.Bind.tcMonoBinds (with type-sig case). + +Note [Silly default-method bind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we pass the default method binding to the type checker, it must +look like op2 = e +not $dmop2 = e +otherwise the "$dm" stuff comes out error messages. But we want the +"$dm" to come out in the interface file. So we typecheck the former, +and wrap it in a let, thus + $dmop2 = let op2 = e in op2 +This makes the error messages right. + + +************************************************************************ +* * + Error messages +* * +************************************************************************ +-} + +{- +badGenericInstanceType :: LHsBinds Name -> SDoc +badGenericInstanceType binds + = vcat [text "Illegal type pattern in the generic bindings", + nest 2 (ppr binds)] + +missingGenericInstances :: [Name] -> SDoc +missingGenericInstances missing + = text "Missing type patterns for" <+> pprQuotedList missing + +dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc +dupGenericInsts tc_inst_infos + = vcat [text "More than one type pattern for a single generic type constructor:", + nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), + text "All the type patterns for a generic type constructor must be identical" + ] + where + ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) +-} + +badDmPrag :: TcId -> Sig GhcRn -> TcM () +badDmPrag sel_id prag + = addErrTc (TcRnDefaultMethodForPragmaLacksBinding sel_id prag) + +instDeclCtxt1 :: LHsSigType GhcRn -> ErrCtxtMsg +instDeclCtxt1 hs_inst_ty + = InstDeclErrCtxt (Left $ getLHsInstDeclHead hs_inst_ty) + +instDeclCtxt2 :: Type -> ErrCtxtMsg +instDeclCtxt2 dfun_ty + = instDeclCtxt3 cls tys + where + (_,_,cls,tys) = tcSplitDFunTy dfun_ty + +instDeclCtxt3 :: Class -> [Type] -> ErrCtxtMsg +instDeclCtxt3 cls cls_tys + = InstDeclErrCtxt (Right $ mkClassPred cls cls_tys) + +tcATDefault :: SrcSpan + -> Subst + -> NameSet + -> ClassATItem + -> TcM [FamInst] +-- ^ Construct default instances for any associated types that +-- aren't given a user definition +-- Returns [] or singleton +tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) + -- User supplied instances ==> everything is OK + | tyConName fam_tc `elemNameSet` defined_ats + = return [] + + -- No user instance, have defaults ==> instantiate them + -- Example: class C a where { type F a b :: *; type F a b = () } + -- instance C [x] + -- Then we want to generate the decl: type F [x] b = () + | Just (rhs_ty, _loc) <- defs + = do { let (subst', pat_tys') = substATBndrs inst_subst (tyConTyVars fam_tc) + rhs' = substTyUnchecked subst' rhs_ty + tcv' = tyCoVarsOfTypesList pat_tys' + (tv', cv') = partition isTyVar tcv' + tvs' = scopedSort tv' + cvs' = scopedSort cv' + ; rep_tc_name <- newFamInstTyConName (L (noAnnSrcSpan loc) (tyConName fam_tc)) pat_tys' + ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs' + fam_tc pat_tys' rhs' + -- NB: no validity check. We check validity of default instances + -- in the class definition. Because type instance arguments cannot + -- be type family applications and cannot be polytypes, the + -- validity check is redundant. + + ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty + , pprCoAxiom axiom ]) + ; fam_inst <- newFamInst SynFamilyInst axiom + ; return [fam_inst] } + + -- No defaults ==> generate a warning + | otherwise -- defs = Nothing + = do { warnMissingAT (tyConName fam_tc) + ; return [] } + +-- | Apply a substitution to the type variable binders of an associated type +-- family. This is used to compute default instances for associated type +-- families (see 'tcATDefault') as well as @newtype@-derived associated type +-- family instances (see @gen_Newtype_fam_insts@ in "GHC.Tc.Deriv.Generate"). +-- +-- As a concrete example, consider the following class and associated type +-- family: +-- +-- @ +-- class C k (a :: k) where +-- type F k a (b :: k) :: Type +-- type F j p q = (Proxy @j p, Proxy @j (q :: j)) +-- @ +-- +-- If a user defines this instance: +-- +-- @ +-- instance C (Type -> Type) Maybe where {} +-- @ +-- +-- Then in order to typecheck the default @F@ instance, we must apply the +-- substitution @[k :-> (Type -> Type), a :-> Maybe]@ to @F@'s binders, which +-- are @[k, a, (b :: k)]@. The result should look like this: +-- +-- @ +-- type F (Type -> Type) Maybe (b :: Type -> Type) = +-- (Proxy @(Type -> Type) Maybe, Proxy @(Type -> Type) (b :: Type -> Type)) +-- @ +-- +-- Making this work requires some care. There are two cases: +-- +-- 1. If we encounter a type variable in the domain of the substitution (e.g., +-- @k@ or @a@), then we apply the substitution directly. +-- +-- 2. Otherwise, we substitute into the type variable's kind (e.g., turn +-- @b :: k@ to @b :: Type -> Type@). We then return an extended substitution +-- where the old @b@ (of kind @k@) maps to the new @b@ (of kind @Type -> Type@). +-- +-- This step is important to do in case there are later occurrences of @b@, +-- which we must ensure have the correct kind. Otherwise, we might end up +-- with @Proxy \@(Type -> Type) (b :: k)@ on the right-hand side of the +-- default instance, which would be completely wrong. +-- +-- Contrast 'substATBndrs' function with similar substitution functions: +-- +-- * 'substTyVars' does not substitute into the kinds of each type variable, +-- nor does it extend the substitution. 'substTyVars' is meant for occurrences +-- of type variables, whereas 'substATBndr's is meant for binders. +-- +-- * 'substTyVarBndrs' does substitute into kinds and extends the substitution, +-- but it does not apply the substitution to the variables themselves. As +-- such, 'substTyVarBndrs' returns a list of 'TyVar's rather than a list of +-- 'Type's. +substATBndrs :: Subst -> [TyVar] -> (Subst, [Type]) +substATBndrs = mapAccumL substATBndr + where + substATBndr :: Subst -> TyVar -> (Subst, Type) + substATBndr subst tc_tv + -- Case (1) in the Haddocks + | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv + = (subst, ty) + -- Case (2) in the Haddocks + | otherwise + = (extendTvSubstWithClone subst tc_tv tc_tv', mkTyVarTy tc_tv') + where + tc_tv' = updateTyVarKind (substTy subst) tc_tv + +warnMissingAT :: Name -> TcM () +warnMissingAT name + = do { warn <- woptM Opt_WarnMissingMethods + ; traceTc "warn" (ppr name <+> ppr warn) + ; hsc_src <- fmap tcg_src getGblEnv + -- hs-boot and signatures never need to provide complete "definitions" + -- of any sort, as they aren't really defining anything, but just + -- constraining items which are defined elsewhere. + ; let diag = TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocInstance + $ AssocInstanceMissing name + ; diagnosticTc (warn && hsc_src == HsSrcFile) diag + } diff --git a/GHC/Tc/TyCl/Instance.hs b/GHC/Tc/TyCl/Instance.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/Instance.hs @@ -0,0 +1,2691 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking instance declarations +module GHC.Tc.TyCl.Instance + ( tcInstDecls1 + , tcInstDeclsDeriv + , tcInstDecls2 + ) +where + +import GHC.Prelude + +import GHC.Hs +import GHC.Rename.Bind ( rejectBootDecls ) +import GHC.Tc.Errors.Types +import GHC.Tc.Gen.Bind +import GHC.Tc.TyCl +import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv ) +import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault, + HsSigFun, mkHsSigFun, findMethodBind, + instantiateMethod ) +import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) +import GHC.Tc.Gen.Sig +import GHC.Tc.Utils.Monad +import GHC.Tc.Validity +import GHC.Tc.Zonk.Type +import GHC.Tc.Zonk.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.TyCl.Build +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated ) +import GHC.Tc.Instance.Family + +import GHC.Tc.Deriv +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.Unify +import GHC.Tc.Types.Evidence + +import GHC.Builtin.Names ( unsatisfiableIdName ) + +import GHC.Core ( Expr(..), mkVarApps ) +import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID ) +import GHC.Core.Unfold.Make ( mkDFunUnfolding ) +import GHC.Core.FamInstEnv +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.InstEnv +import GHC.Core.Predicate( classMethodInstTy ) +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.Class + +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Fixity +import GHC.Types.Id +import GHC.Types.SourceFile +import GHC.Types.SourceText +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.SrcLoc + +import GHC.Driver.DynFlags +import GHC.Driver.Ppr + +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Data.FastString +import GHC.Data.List.SetOps +import GHC.Data.Bag +import GHC.Data.BooleanFormula ( isUnsatisfied ) +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Tuple +import GHC.Data.Maybe +import Data.List( mapAccumL ) + + +{- +Typechecking instance declarations is done in two passes. The first +pass, made by @tcInstDecls1@, collects information to be used in the +second pass. + +This pre-processed info includes the as-yet-unprocessed bindings +inside the instance declaration. These are type-checked in the second +pass, when the class-instance envs and GVE contain all the info from +all the instance and value decls. Indeed that's the reason we need +two passes over the instance decls. + + +Note [How instance declarations are translated] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is how we translate instance declarations into Core + +Running example: + class C a where + op1, op2 :: Ix b => a -> b -> b + op2 = + + instance C a => C [a] + {-# INLINE [2] op1 #-} + op1 = +===> + -- Method selectors + op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b + op1 = ... + op2 = ... + + -- Default methods get the 'self' dictionary as argument + -- so they can call other methods at the same type + -- Default methods get the same type as their method selector + $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b + $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). + -- NB: type variables 'a' and 'b' are *both* in scope in + -- Note [Tricky type variable scoping] + + -- A top-level definition for each instance method + -- Here op1_i, op2_i are the "instance method Ids" + -- The INLINE pragma comes from the user pragma + {-# INLINE [2] op1_i #-} -- From the instance decl bindings + op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b + op1_i = /\a. \(d:C a). + let this :: C [a] + this = df_i a d + -- Note [Subtle interaction of recursion and overlap] + + local_op1 :: forall b. Ix b => [a] -> b -> b + local_op1 = + -- Source code; run the type checker on this + -- NB: Type variable 'a' (but not 'b') is in scope in + -- Note [Tricky type variable scoping] + + in local_op1 a d + + op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) + + -- The dictionary function itself + {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions + df_i :: forall a. C a -> C [a] + df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) + -- But see Note [Default methods in instances] + -- We can't apply the type checker to the default-method call + + -- Use a RULE to short-circuit applications of the class ops + {-# RULE "op1@C[a]" forall a, d:C a. + op1 [a] (df_i d) = op1_i a d #-} + +Note [Instances and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Note that df_i may be mutually recursive with both op1_i and op2_i. + It's crucial that df_i is not chosen as the loop breaker, even + though op1_i has a (user-specified) INLINE pragma. + +* Instead the idea is to inline df_i into op1_i, which may then select + methods from the MkC record, and thereby break the recursion with + df_i, leaving a *self*-recursive op1_i. (If op1_i doesn't call op at + the same type, it won't mention df_i, so there won't be recursion in + the first place.) + +* If op1_i is marked INLINE by the user there's a danger that we won't + inline df_i in it, and that in turn means that (since it'll be a + loop-breaker because df_i isn't), op1_i will ironically never be + inlined. But this is OK: the recursion breaking happens by way of + a RULE (the magic ClassOp rule above), and RULES work inside stable + unfoldings. See Note [RULEs enabled in InitialPhase] in GHC.Core.Opt.Simplify.Utils + +Note [ClassOp/DFun selection] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This important Note explains how DFunIds and ClassOps work. + +One thing we see a lot is stuff like + op2 (df d1 d2) +where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* +'op2' and 'df' to get + case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of + MkD _ op2 _ _ _ -> op2 +And that will reduce to ($cop2 d1 d2) which is what we wanted. + +But it's tricky to make this work in practice, because it requires us to +inline both 'op2' and 'df'. But neither is keen to inline without having +seen the other's result; and it's very easy to get code bloat (from the +big intermediate) if you inline a bit too much. + +Instead we use a cunning trick. + * We arrange that 'df' and 'op2' NEVER inline. + + * We arrange that 'df' is ALWAYS defined in the sylised form + df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... + + * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..]) + that lists its methods. + + * We make GHC.Core.Unfold.exprIsConApp_maybe spot a DFunUnfolding and return + a suitable constructor application -- inlining df "on the fly" as it + were. + + * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that + extracts the right piece iff its argument satisfies + exprIsConApp_maybe. This is done in GHC.Types.Id.Make.mkDictSelId + + * We make 'df' CONLIKE, so that shared uses still match; eg + let d = df d1 d2 + in ...(op2 d)...(op1 d)... + + * ClassOps have no unfolding; they work /only/ through their RULE. + But a ClassOp might be called with no arguments, or with an argument that + the rule doesn't fire on. So each ClassOp does get an executable top-level + definition, injected by GHC.Iface.Tidy.getClassImplicitBinds, which uses + `GHC.Types.Id.Make.mkDictSelRhs` to make the code. + +Note [Single-method classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the class has just one method (or, more accurately, just one element +of {superclasses + methods}), then we use a different strategy. + + class C a where op :: a -> a + instance C a => C [a] where op = + +We translate the class decl into a newtype, which just gives a +top-level axiom. The "constructor" MkC expands to a cast, as does the +class-op selector. + + axiom Co:C a :: C a ~ (a->a) + + op :: forall a. C a -> (a -> a) + op a d = d |> (Co:C a) + + MkC :: forall a. (a->a) -> C a + MkC = /\a.\op. op |> (sym Co:C a) + +The clever RULE stuff doesn't work now, because ($df a d) isn't +a constructor application, so exprIsConApp_maybe won't return +Just . + +Instead, we simply rely on the fact that casts are cheap: + + $df :: forall a. C a => C [a] + {-# INLINE df #-} -- NB: INLINE this + $df = /\a. \d. MkC [a] ($cop_list a d) + = $cop_list |> forall a. C a -> (sym (Co:C [a])) + + $cop_list :: forall a. C a => [a] -> [a] + $cop_list = + +So if we see + (op ($df a d)) +we'll inline 'op' and '$df', since both are simply casts, and +good things happen. + +Why do we use this different strategy? Because otherwise we +end up with non-inlined dictionaries that look like + $df = $cop |> blah +which adds an extra indirection to every use, which seems stupid. See +#4138 for an example (although the regression reported there +wasn't due to the indirection). + +There is an awkward wrinkle though: we want to be very +careful when we have + instance C a => C [a] where + {-# INLINE op #-} + op = ... +then we'll get an INLINE pragma on $cop_list but it's important that +$cop_list only inlines when it's applied to *two* arguments (the +dictionary and the list argument). So we must not eta-expand $df +above. We ensure that this doesn't happen by putting an INLINE +pragma on the dfun itself; after all, it ends up being just a cast. + +There is one more dark corner to the INLINE story, even more deeply +buried. Consider this (#3772): + + class DeepSeq a => C a where + gen :: Int -> a + + instance C a => C [a] where + gen n = ... + + class DeepSeq a where + deepSeq :: a -> b -> b + + instance DeepSeq a => DeepSeq [a] where + {-# INLINE deepSeq #-} + deepSeq xs b = foldr deepSeq b xs + +That gives rise to these defns: + + $cdeepSeq :: DeepSeq a -> [a] -> b -> b + -- User INLINE( 3 args )! + $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ... + + $fDeepSeq[] :: DeepSeq a -> DeepSeq [a] + -- DFun (with auto INLINE pragma) + $fDeepSeq[] a d = $cdeepSeq a d |> blah + + $cp1 a d :: C a => DeepSep [a] + -- We don't want to eta-expand this, lest + -- $cdeepSeq gets inlined in it! + $cp1 a d = $fDeepSep[] a (scsel a d) + + $fC[] :: C a => C [a] + -- Ordinary DFun + $fC[] a d = MkC ($cp1 a d) ($cgen a d) + +Here $cp1 is the code that generates the superclass for C [a]. The +issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[] +and then $cdeepSeq will inline there, which is definitely wrong. Like +on the dfun, we solve this by adding an INLINE pragma to $cp1. + +Note [Subtle interaction of recursion and overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + class C a where { op1,op2 :: a -> a } + instance C a => C [a] where + op1 x = op2 x ++ op2 x + op2 x = ... + instance C [Int] where + ... + +When type-checking the C [a] instance, we need a C [a] dictionary (for +the call of op2). If we look up in the instance environment, we find +an overlap. And in *general* the right thing is to complain (see Note +[Overlapping instances] in GHC.Core.InstEnv). But in *this* case it's wrong to +complain, because we just want to delegate to the op2 of this same +instance. + +Why is this justified? Because we generate a (C [a]) constraint in +a context in which 'a' cannot be instantiated to anything that matches +other overlapping instances, or else we would not be executing this +version of op1 in the first place. + +It might even be a bit disguised: + + nullFail :: C [a] => [a] -> [a] + nullFail x = op2 x ++ op2 x + + instance C a => C [a] where + op1 x = nullFail x + +Precisely this is used in package 'regex-base', module Context.hs. +See the overlapping instances for RegexContext, and the fact that they +call 'nullFail' just like the example above. The DoCon package also +does the same thing; it shows up in module Fraction.hs. + +Conclusion: when typechecking the methods in a C [a] instance, we want to +treat the 'a' as an *existential* type variable, in the sense described +by Note [Super skolems: binding when looking up instances] in GHC.Core.InstEnv +That is why isOverlappableTyVar responds True to an InstSkol, which is the kind +of skolem we use in tcInstDecl2. + +Note [Tricky type variable scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In our example + class C a where + op1, op2 :: Ix b => a -> b -> b + op2 = + + instance C a => C [a] + {-# INLINE [2] op1 #-} + op1 = + +note that 'a' and 'b' are *both* in scope in , but only 'a' is +in scope in . In particular, we must make sure that 'b' is in +scope when typechecking . This is achieved by subFunTys, +which brings appropriate tyvars into scope. This happens for both + and for , but that doesn't matter: the *renamer* will have +complained if 'b' is mentioned in . + + + +************************************************************************ +* * +\subsection{Extracting instance decls} +* * +************************************************************************ + +Gather up the instance declarations from their various sources +-} + +tcInstDecls1 -- Deal with both source-code and imported instance decls + :: [LInstDecl GhcRn] -- Source code instance decls + -> TcM (TcGblEnv, -- The full inst env + [InstInfo GhcRn], -- Source-code instance decls to process; + -- contains all dfuns for this module + [DerivInfo], -- From data family instances + ThBindEnv) -- TH binding levels + +tcInstDecls1 inst_decls + = do { -- Do class and family instance declarations + ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls + + ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff + fam_insts = concat fam_insts_s + local_infos = concat local_infos_s + + ; (gbl_env, th_bndrs) <- + addClsInsts local_infos $ + addFamInsts fam_insts + + ; return ( gbl_env + , local_infos + , concat datafam_deriv_infos + , th_bndrs ) } + +-- | Use DerivInfo for data family instances (produced by tcInstDecls1), +-- datatype declarations (TyClDecl), and standalone deriving declarations +-- (DerivDecl) to check and process all derived class instances. +tcInstDeclsDeriv + :: [DerivInfo] + -> [LDerivDecl GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn) +tcInstDeclsDeriv deriv_infos derivds + = do th_lvl <- getThLevel -- See Note [Deriving inside TH brackets] + if isBrackLevel th_lvl + then do { gbl_env <- getGblEnv + ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) } + else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds + ; return (tcg_env, bagToList info_bag, valbinds) } + +addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a +addClsInsts infos thing_inside + = tcExtendLocalInstEnv (map iSpec infos) thing_inside + +addFamInsts :: [FamInst] -> TcM (TcGblEnv, ThBindEnv) +-- Extend (a) the family instance envt +-- (b) the type envt with stuff from data type decls +addFamInsts fam_insts + = tcExtendLocalFamInstEnv fam_insts $ + tcExtendGlobalEnv axioms $ + do { traceTc "addFamInsts" (pprFamInsts fam_insts) + ; (gbl_env, th_bndrs) <- addTyConsToGblEnv data_rep_tycons + -- Does not add its axiom; that comes + -- from adding the 'axioms' above + ; return (gbl_env, th_bndrs) + } + where + axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts + data_rep_tycons = famInstsRepTyCons fam_insts + -- The representation tycons for 'data instances' declarations + +{- +Note [Deriving inside TH brackets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a declaration bracket + [d| data T = A | B deriving( Show ) |] + +there is really no point in generating the derived code for deriving( +Show) and then type-checking it. This will happen at the call site +anyway, and the type check should never fail! Moreover (#6005) +the scoping of the generated code inside the bracket does not seem to +work out. + +The easy solution is simply not to generate the derived instances at +all. (A less brutal solution would be to generate them with no +bindings.) This will become moot when we shift to the new TH plan, so +the brutal solution will do. +-} + +tcLocalInstDecl :: LInstDecl GhcRn + -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) + -- A source-file instance declaration + -- Type-check all the stuff before the "where" + -- + -- We check for respectable instance type, and context +tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) + = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl) + ; return ([], [fam_inst], []) } + +tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) + = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated emptyVarEnv (L loc decl) + ; return ([], [fam_inst], maybeToList m_deriv_info) } + +tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) + = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl) + ; return (insts, fam_insts, deriv_infos) } + +tcClsInstDecl :: LClsInstDecl GhcRn + -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) +-- The returned DerivInfos are for any associated data families +tcClsInstDecl (L loc (ClsInstDecl { cid_ext = lwarn + , cid_poly_ty = hs_ty, cid_binds = binds + , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = overlap_mode + , cid_datafam_insts = adts })) + = setSrcSpanA loc $ + addErrCtxt (instDeclCtxt1 hs_ty) $ + do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty + ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty + -- NB: tcHsClsInstType does checkValidInstance + ; skol_info <- mkSkolemInfo (InstSkol IsClsInst pSizeZero) + -- pSizeZero: here the size part of InstSkol is irrelevant + ; (subst, skol_tvs) <- tcInstSkolTyVars skol_info tyvars + ; let tv_skol_prs = [ (tyVarName tv, skol_tv) + | (tv, skol_tv) <- tyvars `zip` skol_tvs ] + -- Map from the skolemized Names to the original Names. + -- See Note [Associated data family instances and di_scoped_tvs]. + tv_skol_env = mkVarEnv $ map swap tv_skol_prs + n_inferred = countWhile ((== Inferred) . binderFlag) $ + fst $ splitForAllForAllTyBinders dfun_ty + visible_skol_tvs = drop n_inferred skol_tvs + + ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleBndrCount dfun_ty) $$ ppr skol_tvs) + + -- Next, process any associated types. + ; (datafam_stuff, tyfam_insts) + <- tcExtendNameTyVarEnv tv_skol_prs $ + do { let mini_env = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys) + mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env + mb_info = InClsInst { ai_class = clas + , ai_tyvars = visible_skol_tvs + , ai_inst_env = mini_env } + ; df_stuff <- mapAndRecoverM (tcDataFamInstDecl mb_info tv_skol_env) adts + ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info) ats + + -- Check for missing associated types and build them + -- from their defaults (if available) + ; is_boot <- tcIsHsBootOrSig + ; let atItems = classATItems clas + ; tf_insts2 <- mapM (tcATDefault (locA loc) mini_subst defined_ats) + (if is_boot then [] else atItems) + -- Don't default type family instances, but rather omit, in hsig/hs-boot. + -- Since hsig/hs-boot files are essentially large binders we want omission + -- of the definition to result in no restriction, rather than for example + -- attempting to "pattern match" with the invisible defaults and generate + -- equalities. Without further handling, this would just result in a panic + -- anyway. + -- See https://github.com/ghc-proposals/ghc-proposals/pull/320 for + -- additional discussion. + ; return (df_stuff, tf_insts1 ++ concat tf_insts2) } + + + -- Finally, construct the Core representation of the instance. + -- (This no longer includes the associated types.) + ; dfun_name <- newDFunName clas inst_tys (getLocA hs_ty) + -- Dfun location is that of instance *header* + + ; let warn = fmap unLoc lwarn + ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name + tyvars theta clas inst_tys warn + + ; let inst_binds = InstBindings + { ib_binds = binds + , ib_tyvars = map Var.varName tyvars -- Scope over bindings + , ib_pragmas = uprags + , ib_extensions = [] + , ib_derived = False } + inst_info = InstInfo { iSpec = ispec, iBinds = inst_binds } + + (datafam_insts, m_deriv_infos) = unzip datafam_stuff + deriv_infos = catMaybes m_deriv_infos + all_insts = tyfam_insts ++ datafam_insts + + -- In hs-boot files there should be no bindings + ; gbl_env <- getGblEnv; + ; case tcg_src gbl_env of + { HsSrcFile -> return () + ; HsBootOrSig boot_or_sig -> + do { rejectBootDecls boot_or_sig BootBindsRn binds + ; rejectBootDecls boot_or_sig BootInstanceSigs uprags } } + ; return ([inst_info], all_insts, deriv_infos) } + where + defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) + `unionNameSet` + mkNameSet (map (unLoc . feqn_tycon + . dfid_eqn + . unLoc) adts) + +{- +************************************************************************ +* * + Type family instances +* * +************************************************************************ + +Family instances are somewhat of a hybrid. They are processed together with +class instance heads, but can contain data constructors and hence they share a +lot of kinding and type checking code with ordinary algebraic data types (and +GADTs). +-} + +tcTyFamInstDecl :: AssocInstInfo + -> LTyFamInstDecl GhcRn -> TcM FamInst + -- "type instance"; open type families only + -- See Note [Associated type instances] +tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) + = setSrcSpanA loc $ + tcAddOpenTyFamInstCtxt mb_clsinfo decl $ + do { let fam_lname = feqn_tycon eqn + ; fam_tc <- tcLookupLocatedTyCon fam_lname + ; tcFamInstDeclChecks mb_clsinfo IAmType fam_tc + + -- (0) Check it's an open type family + ; checkTc (isTypeFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyCategoryMismatch fam_tc + ; checkTc (isOpenTypeFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + NotAnOpenFamilyTyCon fam_tc + + -- (1) do the work of verifying the synonym group + -- For some reason we don't have a location for the equation + -- itself, so we make do with the location of family name + ; (co_ax_branch, co_ax_validity_info) + <- tcTyFamInstEqn fam_tc mb_clsinfo + (L (l2l $ getLoc fam_lname) eqn) + + -- (2) check for validity + ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch + ; checkTyFamEqnValidityInfo fam_tc co_ax_validity_info + ; checkValidCoAxBranch fam_tc co_ax_branch + + -- (3) construct coercion axiom + ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch] + ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch + ; newFamInst SynFamilyInst axiom } + + +--------------------- +tcFamInstDeclChecks :: AssocInstInfo -> TypeOrData -> TyCon -> TcM () +-- Used for both type and data families +tcFamInstDeclChecks mb_clsinfo ty_or_data fam_tc + = do { -- Type family instances require -XTypeFamilies + -- and can't (currently) be in an hs-boot file + ; traceTc "tcFamInstDecl" (ppr fam_tc) + ; type_families <- xoptM LangExt.TypeFamilies + ; hs_src <- tcHscSource -- Are we compiling an hs-boot file? + ; checkTc type_families (TcRnTyFamsDisabled (TyFamsDisabledInstance fam_tc)) + ; case hs_src of + HsBootOrSig boot_or_sig -> + addErrTc $ TcRnIllegalHsBootOrSigDecl boot_or_sig (BootFamInst fam_tc) + HsSrcFile -> + return () + + -- Check that it is a family TyCon + ; checkTc (isFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + NotAFamilyTyCon ty_or_data fam_tc + + -- Check that top-level type instances are not for associated types. + ; when (isNotAssociated mb_clsinfo && -- Not in a class decl + isTyConAssoc fam_tc) $ -- but an associated type + addErr $ TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocInstance + $ AssocInstanceNotInAClass fam_tc + } + +{- Note [Associated type instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow this: + class C a where + type T x a + instance C Int where + type T (S y) Int = y + type T Z Int = Char + +Note that + a) The variable 'x' is not bound by the class decl + b) 'x' is instantiated to a non-type-variable in the instance + c) There are several type instance decls for T in the instance + +All this is fine. Of course, you can't give any *more* instances +for (T ty Int) elsewhere, because it's an *associated* type. + + +************************************************************************ +* * + Data family instances +* * +************************************************************************ + +For some reason data family instances are a lot more complicated +than type family instances +-} + +tcDataFamInstDecl :: + AssocInstInfo + -> TyVarEnv Name -- If this is an associated data family instance, maps the + -- parent class's skolemized type variables to their + -- original Names. If this is a non-associated instance, + -- this will be empty. + -- See Note [Associated data family instances and di_scoped_tvs]. + -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo) + -- "newtype instance" and "data instance" +tcDataFamInstDecl mb_clsinfo tv_skol_env + (L loc decl@(DataFamInstDecl { dfid_eqn = + FamEqn { feqn_bndrs = outer_bndrs + , feqn_pats = hs_pats + , feqn_tycon = lfam_name@(L _ fam_name) + , feqn_fixity = fixity + , feqn_rhs = HsDataDefn { dd_cType = cType + , dd_ctxt = hs_ctxt + , dd_cons = hs_cons + , dd_kindSig = m_ksig + , dd_derivs = derivs } }})) + = setSrcSpanA loc $ + tcAddDataFamInstCtxt mb_clsinfo new_or_data decl $ + do { fam_tc <- tcLookupLocatedTyCon lfam_name + + ; tcFamInstDeclChecks mb_clsinfo (IAmData new_or_data) fam_tc + + -- Check that the family declaration is for the right kind + ; checkTc (isDataFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyCategoryMismatch fam_tc + ; gadt_syntax <- dataDeclChecks fam_name hs_ctxt hs_cons + -- Do /not/ check that the number of patterns = tyConArity fam_tc + -- See [Arity of data families] in GHC.Core.FamInstEnv + ; skol_info <- mkSkolemInfo FamInstSkol + ; (qtvs, non_user_tvs, pats, tc_res_kind, stupid_theta) + <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity + hs_ctxt hs_pats m_ksig hs_cons + + -- Eta-reduce the axiom if possible + -- Quite tricky: see Note [Implementing eta reduction for data families] + ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats + eta_tvs = map binderVar eta_tcbs + post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs + + full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs + (tyCoVarsOfType (mkSpecForAllTys eta_tvs tc_res_kind)) + ++ eta_tcbs + -- Put the eta-removed tyvars at the end + -- Remember, qtvs is in arbitrary order, except kind vars are + -- first, so there is no reason to suppose that the eta_tvs + -- (obtained from the pats) are at the end (#11148) + + -- Eta-expand the representation tycon until it has result + -- kind `TYPE r`, for some `r`. If UnliftedNewtypes is not enabled, we + -- go one step further and ensure that it has kind `TYPE 'LiftedRep`. + -- + -- See also Note [Arity of data families] in GHC.Core.FamInstEnv + -- NB: we can do this after eta-reducing the axiom, because if + -- we did it before the "extra" tvs from etaExpandAlgTyCon + -- would always be eta-reduced + -- + ; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon skol_info full_tcbs tc_res_kind + + -- Check the result kind; it may come from a user-written signature. + -- See Note [Datatype return kinds] in GHC.Tc.TyCl point 4(a) + ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs + all_pats = pats `chkAppend` extra_pats + orig_res_ty = mkTyConApp fam_tc all_pats + tc_ty_binders = full_tcbs `chkAppend` extra_tcbs + + ; traceTc "tcDataFamInstDecl 1" $ + vcat [ text "Fam tycon:" <+> ppr fam_tc + , text "Pats:" <+> ppr pats + , text "visibilities:" <+> ppr (tcbVisibilities fam_tc pats) + , text "all_pats:" <+> ppr all_pats + , text "tc_ty_binders" <+> ppr tc_ty_binders + , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) + , text "tc_res_kind:" <+> ppr tc_res_kind + , text "eta_pats" <+> ppr eta_pats + , text "eta_tcbs" <+> ppr eta_tcbs ] + + -- Zonk the patterns etc into the Type world + ; (ty_binders, res_kind, all_pats, eta_pats, stupid_theta, + zonked_post_eta_qtvs, zonked_eta_tvs) <- + initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_ty_binders) $ \ ty_binders -> + do { res_kind <- zonkTcTypeToTypeX tc_res_kind + ; all_pats <- zonkTcTypesToTypesX all_pats + ; eta_pats <- zonkTcTypesToTypesX eta_pats + ; stupid_theta <- zonkTcTypesToTypesX stupid_theta + ; zonked_post_eta_qtvs <- mapM lookupTyVarX post_eta_qtvs + ; zonked_eta_tvs <- mapM lookupTyVarX 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. + ; return (ty_binders, res_kind, all_pats, eta_pats, stupid_theta, + zonked_post_eta_qtvs, zonked_eta_tvs) } + + ; traceTc "tcDataFamInstDecl" $ + vcat [ text "Fam tycon:" <+> ppr fam_tc + , text "Pats:" <+> ppr pats + , text "visibilities:" <+> ppr (tcbVisibilities fam_tc pats) + , text "all_pats:" <+> ppr all_pats + , text "ty_binders" <+> ppr ty_binders + , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) + , text "res_kind:" <+> ppr res_kind + , text "eta_pats" <+> ppr eta_pats + , text "eta_tcbs" <+> ppr eta_tcbs ] + ; (rep_tc, (axiom, ax_rhs)) <- fixM $ \ ~(rec_rep_tc, _) -> + do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $ + -- For H98 decls, the tyvars scope + -- over the data constructors + tcConDecls (DDataInstance orig_res_ty) rec_rep_tc tc_ty_binders tc_res_kind + hs_cons + + ; rep_tc_name <- newFamInstTyConName lfam_name pats + ; axiom_name <- newFamInstAxiomName lfam_name [pats] + ; tc_rhs <- case data_cons of + DataTypeCons type_data data_cons -> return $ + mkLevPolyDataTyConRhs + (isFixedRuntimeRepKind res_kind) + type_data + data_cons + NewTypeCon data_con -> mkNewTyConRhs rep_tc_name rec_rep_tc data_con + + ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys zonked_post_eta_qtvs) + axiom = mkSingleCoAxiom Representational axiom_name + zonked_post_eta_qtvs zonked_eta_tvs + [] fam_tc eta_pats ax_rhs + parent = DataFamInstTyCon axiom fam_tc all_pats + + -- NB: Use the full ty_binders from the pats. See bullet toward + -- the end of Note [Data type families] in GHC.Core.TyCon + rep_tc = mkAlgTyCon rep_tc_name + ty_binders res_kind + (map (const Nominal) ty_binders) + (fmap unLoc cType) stupid_theta + tc_rhs parent + gadt_syntax + -- We always assume that indexed types are recursive. Why? + -- (1) Due to their open nature, we can never be sure that a + -- further instance might not introduce a new recursive + -- dependency. (2) They are always valid loop breakers as + -- they involve a coercion. + + ; return (rep_tc, (axiom, ax_rhs)) } + + -- Remember to check validity; no recursion to worry about here + -- Check that left-hand sides are ok (mono-types, no type families, + -- consistent instantiations, etc) + ; let ax_branch = coAxiomSingleBranch axiom + ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch + ; checkFamPatBinders fam_tc zonked_post_eta_qtvs non_user_tvs eta_pats ax_rhs + ; checkValidCoAxBranch fam_tc ax_branch + ; checkValidTyCon rep_tc + + ; let scoped_tvs = map mk_deriv_info_scoped_tv_pr (tyConTyVars rep_tc) + m_deriv_info = case derivs of + [] -> Nothing + preds -> + Just $ DerivInfo { di_rep_tc = rep_tc + , di_scoped_tvs = scoped_tvs + , di_clauses = preds + , di_ctxt = tcMkDataFamInstCtxt mb_clsinfo new_or_data decl + } + + ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom + ; return (fam_inst, m_deriv_info) } + where + + new_or_data = dataDefnConsNewOrData hs_cons + + eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder]) + -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + -- Splits the incoming patterns into two: the [TyVar] + -- are the patterns that can be eta-reduced away. + -- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c]) + -- + -- NB: quadratic algorithm, but types are small here + eta_reduce fam_tc pats + = go (reverse (zip3 pats fvs_s vis_s)) [] + where + vis_s :: [TyConBndrVis] + vis_s = tcbVisibilities fam_tc pats + + fvs_s :: [TyCoVarSet] -- 1-1 correspondence with pats + -- Each elt is the free vars of all /earlier/ pats + (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats + add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs) + + go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs + | Just tv <- getTyVar_maybe pat + , not (tv `elemVarSet` fvs_to_the_left) + = go pats (Bndr tv tcb_vis : etad_tvs) + go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs) + + -- Create a Name-TyVar mapping to bring into scope when typechecking any + -- deriving clauses this data family instance may have. + -- See Note [Associated data family instances and di_scoped_tvs]. + mk_deriv_info_scoped_tv_pr :: TyVar -> (Name, TyVar) + mk_deriv_info_scoped_tv_pr tv = + let n = lookupWithDefaultVarEnv tv_skol_env (tyVarName tv) tv + in (n, tv) + +{- +Note [Associated data family instances and di_scoped_tvs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some care is required to implement `deriving` correctly for associated data +family instances. Consider this example from #18055: + + class C a where + data D a + + class X a b + + instance C (Maybe a) where + data D (Maybe a) deriving (X a) + +When typechecking the `X a` in `deriving (X a)`, we must ensure that the `a` +from the instance header is brought into scope. This is the role of +di_scoped_tvs, which maps from the original, renamed `a` to the skolemized, +typechecked `a`. When typechecking the `deriving` clause, this mapping will be +consulted when looking up the `a` in `X a`. + +A naïve attempt at creating the di_scoped_tvs is to simply reuse the +tyConTyVars of the representation TyCon for `data D (Maybe a)`. This is only +half correct, however. We do want the typechecked `a`'s Name in the /range/ +of the mapping, but we do not want it in the /domain/ of the mapping. +To ensure that the original `a`'s Name ends up in the domain, we consult a +TyVarEnv (passed as an argument to tcDataFamInstDecl) that maps from the +typechecked `a`'s Name to the original `a`'s Name. In the even that +tcDataFamInstDecl is processing a non-associated data family instance, this +TyVarEnv will simply be empty, and there is nothing to worry about. +-} + +----------------------- +tcDataFamInstHeader + :: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn + -> LexicalFixity -> Maybe (LHsContext GhcRn) + -> HsFamEqnPats GhcRn -> Maybe (LHsKind GhcRn) -> DataDefnCons (LConDecl GhcRn) + -> TcM ([TcTyVar], TyVarSet, [TcType], TcKind, TcThetaType) + -- All skolem TcTyVars, all zonked so it's clear what the free vars are +-- The "header" of a data family instance is the part other than +-- the data constructors themselves +-- e.g. data instance D [a] :: * -> * where ... +-- Here the "header" is the bit before the "where" +tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity + hs_ctxt hs_pats m_ksig hs_cons + = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats) + ; (tclvl, wanted, (outer_bndrs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind))) + <- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $ + bindOuterFamEqnTKBndrs skol_info hs_outer_bndrs $ -- Binds skolem TcTyVars + do { stupid_theta <- tcHsContext hs_ctxt + ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats + ; (lhs_applied_ty, lhs_applied_kind) + <- tcInstInvisibleTyBinders lhs_ty lhs_kind + -- See Note [Data family/instance return kinds] + -- in GHC.Tc.TyCl point (DF3) + + -- Ensure that the instance is consistent + -- with its parent class + ; addConsistencyConstraints mb_clsinfo lhs_ty + + -- Add constraints from the data constructors + -- Fix #25611 + -- See DESIGN CHOICE in Note [Kind inference for data family instances] + ; when is_H98_or_newtype $ kcConDecls lhs_applied_kind hs_cons + + -- Check that the result kind of the TyCon applied to its args + -- is compatible with the explicit signature (or Type, if there + -- is none) + ; let hs_lhs = nlHsTyConApp NotPromoted fixity (noUserRdr $ getName fam_tc) hs_pats + -- Add constraints from the result signature + ; res_kind <- tc_kind_sig m_ksig + ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind + + ; traceTc "tcDataFamInstHeader" $ + vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind, ppr m_ksig] + ; return ( stupid_theta + , lhs_applied_ty + , lhs_applied_kind + , res_kind ) } + + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tvs = outerTyVars outer_bndrs + ; checkFamTelescope tclvl hs_outer_bndrs outer_tvs + + -- This code (and the stuff immediately above) is very similar + -- to that in tcTyFamInstEqnGuts. Maybe we should abstract the + -- common code; but for the moment I concluded that it's + -- clearer to duplicate it. Still, if you fix a bug here, + -- check there too! + + -- See GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts] + ; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty + ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs + ; let final_tvs = scopedSort (qtvs ++ outer_tvs) + -- This scopedSort is important: the qtvs may be /interleaved/ with + -- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts] + ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted + + ; (final_tvs, non_user_tvs, lhs_ty, master_res_kind, instance_res_kind, stupid_theta) <- + liftZonkM $ do + { final_tvs <- mapM zonkTcTyVarToTcTyVar final_tvs + ; non_user_tvs <- mapM zonkTcTyVarToTcTyVar qtvs + ; lhs_ty <- zonkTcType lhs_ty + ; master_res_kind <- zonkTcType master_res_kind + ; instance_res_kind <- zonkTcType instance_res_kind + ; stupid_theta <- zonkTcTypes stupid_theta + ; return (final_tvs, non_user_tvs, lhs_ty, master_res_kind, instance_res_kind, stupid_theta) } + + -- Check that res_kind is OK with checkDataKindSig. We need to + -- check that it's ok because res_kind can come from a user-written + -- kind signature. See Note [Datatype return kinds], point (4a) + ; checkDataKindSig (DataInstanceSort new_or_data) master_res_kind + ; checkDataKindSig (DataInstanceSort new_or_data) instance_res_kind + + -- Split up the LHS type to get the type patterns + -- For the scopedSort see Note [Generalising in tcTyFamInstEqnGuts] + ; let pats = unravelFamInstPats lhs_ty + + ; return (final_tvs, mkVarSet non_user_tvs, pats, master_res_kind, stupid_theta) } + where + fam_name = tyConName fam_tc + data_ctxt = DataKindCtxt fam_name + new_or_data = dataDefnConsNewOrData hs_cons + is_H98_or_newtype = case hs_cons of + NewTypeCon{} -> True + DataTypeCons _ cons -> all isH98 cons + isH98 (L _ (ConDeclH98 {})) = True + isH98 _ = False + + -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl, families (2), + -- Note [Implementation of UnliftedDatatypes] + -- and Note [Defaulting result kind of newtype/data family instance]. + tc_kind_sig Nothing + = do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; unlifted_datatypes <- xoptM LangExt.UnliftedDatatypes + ; case new_or_data of + NewType | unlifted_newtypes -> newOpenTypeKind + DataType | unlifted_datatypes -> newOpenTypeKind + _ -> pure liftedTypeKind + } + + -- See Note [Result kind signature for a data family instance] + tc_kind_sig (Just hs_kind) + = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind + ; (_tvs', inner_kind') <- tcSkolemiseInvisibleBndrs (SigTypeSkol data_ctxt) sig_kind + -- Perhaps surprisingly, we don't need the skolemised tvs themselves + ; return inner_kind' } + +{- Note [Result kind signature for a data family instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The expected type might have a forall at the type. Normally, we +can't skolemise in kinds because we don't have type-level lambda. +But here, we're at the top-level of an instance declaration, so +we actually have a place to put the regeneralised variables. +Thus: skolemise away. cf. GHC.Tc.Utils.Unify.tcTopSkolemise +Examples in indexed-types/should_compile/T12369 + +Note [Defaulting result kind of newtype/data family instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is tempting to let `tc_kind_sig` just return `newOpenTypeKind` +even without `-XUnliftedNewtypes`, but we rely on `tc_kind_sig` to +constrain the result kind of a newtype instance to `Type`. +Consider the following example: + + -- no UnliftedNewtypes + data family D :: k -> k + newtype instance D a = MkIntD a + +`tc_kind_sig` defaulting to `newOpenTypeKind` would result in `D a` +having kind `forall r. TYPE r` instead of `Type`, which would be +rejected validity checking. The same applies to Data Instances. + +Note [Implementing eta reduction for data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data D :: * -> * -> * -> * -> * + + data instance D [(a,b)] p q :: * -> * where + D1 :: blah1 + D2 :: blah2 + +Then we'll generate a representation data type + data Drep a b p q z where + D1 :: blah1 + D2 :: blah2 + +and an axiom to connect them + axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z + +except that we'll eta-reduce the axiom to + axiom AxDrep forall a b. D [(a,b]] = Drep a b + +This is described at some length in Note [Eta reduction for data families] +in GHC.Core.Coercion.Axiom. There are several fiddly subtleties lurking here, +however, so this Note aims to describe these subtleties: + +* The representation tycon Drep is parameterised over the free + variables of the pattern, in no particular order. So there is no + guarantee that 'p' and 'q' will come last in Drep's parameters, and + in the right order. So, if the /patterns/ of the family instance + are eta-reducible, we re-order Drep's parameters to put the + eta-reduced type variables last. + +* Although we eta-reduce the axiom, we eta-/expand/ the representation + tycon Drep. The kind of D says it takes four arguments, but the + data instance header only supplies three. But the AlgTyCon for Drep + itself must have enough TyConBinders so that its result kind is Type. + So, with etaExpandAlgTyCon we make up some extra TyConBinders. + See point (3) in Note [Datatype return kinds] in GHC.Tc.TyCl. + +* The result kind in the instance might be a polykind, like this: + data family DP a :: forall k. k -> * + data instance DP [b] :: forall k1 k2. (k1,k2) -> * + + So in type-checking the LHS (DP Int) we need to check that it is + more polymorphic than the signature. To do that we must skolemise + the signature and instantiate the call of DP. So we end up with + data instance DP [b] @(k1,k2) (z :: (k1,k2)) where + + Note that we must parameterise the representation tycon DPrep over + 'k1' and 'k2', as well as 'b'. + + The skolemise bit is done in tc_kind_sig, while the instantiate bit + is done by tcFamTyPats. + +* Very fiddly point. When we eta-reduce to + axiom AxDrep forall a b. D [(a,b]] = Drep a b + + we want the kind of (D [(a,b)]) to be the same as the kind of + (Drep a b). This ensures that applying the axiom doesn't change the + kind. Why is that hard? Because the kind of (Drep a b) depends on + the TyConBndrVis on Drep's arguments. In particular do we have + (forall (k::*). blah) or (* -> blah)? + + We must match whatever D does! In #15817 we had + data family X a :: forall k. * -> * -- Note: a forall that is not used + data instance X Int b = MkX + + So the data instance is really + data istance X Int @k b = MkX + + The axiom will look like + axiom X Int = Xrep + + and it's important that XRep :: forall k * -> *, following X. + + To achieve this we get the TyConBndrVis flags from tcbVisibilities, + and use those flags for any eta-reduced arguments. Sigh. + +* The final turn of the knife is that tcbVisibilities is itself + tricky to sort out. Consider + data family D k :: k + Then consider D (forall k2. k2 -> k2) Type Type + The visibility flags on an application of D may affected by the arguments + themselves. Heavy sigh. But not truly hard; that's what tcbVisibilities + does. + +* Happily, we don't need to worry about the possibility of + building an inhomogeneous axiom, described in GHC.Tc.TyCl.Build + Note [Newtype eta and homogeneous axioms]. For example + type F :: Type -> forall (b :: Type) -> Type + data family F a b + newtype instance F Int b = MkF (Proxy b) + we get a newtype, and a eta-reduced axiom connecting the data family + with the newtype: + type R:FIntb :: forall (b :: Type) -> Type + newtype R:FIntb b = MkF (Proxy b) + axiom Foo.D:R:FIntb0 :: F Int = Foo.R:FIntb + Now the subtleties of Note [Newtype eta and homogeneous axioms] are + dealt with by the newtype (via mkNewTyConRhs called in tcDataFamInstDecl) + while the axiom connecting F Int ~ R:FIntb is eta-reduced, but the + quantifier 'b' is derived from the original data family F, and so the + kinds will always match. + +Note [Kind inference for data family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GADT-style data type declaration, where I have used +fresh variables in the data constructor's type, to stress that c,d are +quite distinct from a,b. + data T a b where + MkT :: forall c d. c d -> T c d + +Following Note [Inferring kinds for type declarations] in GHC.Tc.TyCl, +to infer T's kind, we initially give T :: kappa, a monomorpic kind, +gather constraints from the header and data constructors, and conclude + T :: (kappa1 -> type) -> kappa1 -> Type +Then we generalise, giving + T :: forall k. (k->Type) -> k -> Type + +Now what about a data /instance/ decl + data family T :: forall k. (k->Type) -> k -> Type + + data instance T p Int where ... + +No doubt here! The poly-kinded T is instantiated with k=Type, so the +header really looks like + data instance T @Type (p :: Type->Type) Int where ... + +But what about this? + data instance T p q where + MkT :: forall r. r Int -> T r Int + +So what kind do 'p' and 'q' have? No clues from the header, but from +the data constructor we can clearly see that (r :: Type->Type). Does +that mean that the /entire data instance/ is instantiated at Type, +like this? + data instance T @Type (p :: Type->Type) (q :: Type) where + ... + +Not at all! This is a /GADT/-style decl, so the kind argument might +be specialised in this particular data constructor, thus: + data instance T @k (p :: k->Type) (q :: k) where + MkT :: forall (r :: Type -> Type). + r Int -> T @Type r Int +(and perhaps specialised differently in some other data +constructor MkT2). + +The key difference in this case and 'data T' at the top of this Note +is that we have no known kind for 'data T'. We thus forbid different +specialisations of T in its constructors, in an attempt to avoid +inferring polymorphic recursion. In data family T, however, there is +no problem with polymorphic recursion: we already /fully know/ T's +kind -- that came from the family declaration, and is not influenced +by the data instances -- and hence we /can/ specialise T's kind +differently in different GADT data constructors. + +SHORT SUMMARY: In a data instance decl, it's not clear whether kind +constraints arising from the data constructors should be considered +local to the (GADT) data /constructor/ or should apply to the entire +data instance. + +DESIGN CHOICE: In a data/newtype family instance declaration: +* We take account of the data constructors (via `kcConDecls`) for: + * Haskell-98 style data instance declarations + * All newtype instance declarations + For Haskell-98 style declarations, there is no GADT refinement. And for + GADT-style newtype declarations, no GADT matching is allowed anyway, + so it's just a syntactic difference from Haskell-98. + +* We /ignore/ the data constructors for: + * GADT-style data instance declarations + Here, the instance kinds are influenced only by the header. + +This choice is implemented by the guarded call to `kcConDecls` in +`tcDataFamInstHeader`. + +Observations: +* With `UnliftedNewtypes` or `UnliftedDatatypes`, looking at the data + constructors is necessary to infer the kind of the result type for + certain cases. Otherwise, additional kind signatures are required. + Consider the following example in #25611: + + data family Fix :: (k -> Type) -> k + newtype instance Fix f = In { out :: f (Fix f) } + + If we are not looking at the data constructors: + * Without `UnliftedNewtypes`, it is accepted since `Fix f` is defaulted + to `Type`. + * But with `UnliftedNewtypes`, `Fix f` is defaulted to `TYPE r` where + `r` is not scoped over the data constructor. Then the header `Fix f :: TYPE r` + will fail to kind unify with `f (Fix f) :: Type`. + + Hence, we need to look at the data constructor to infer `Fix f :: Type` + for this newtype instance. + +This DESIGN CHOICE strikes a balance between well-rounded kind inference +and implementation simplicity. See #25611, #18891, and !4419 for more +discussion of this issue. + +Kind inference for data types (Xie et al) https://arxiv.org/abs/1911.06153 +takes a slightly different approach. +-} + + +{- ********************************************************************* +* * + Class instance declarations, pass 2 +* * +********************************************************************* -} + +tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] + -> TcM (LHsBinds GhcTc) +-- (a) From each class declaration, +-- generate any default-method bindings +-- (b) From each instance decl +-- generate the dfun binding + +tcInstDecls2 tycl_decls inst_decls + = do { -- (a) Default methods from class decls + let class_decls = filter (isClassDecl . unLoc) tycl_decls + ; dm_binds_s <- mapM tcClassDecl2 class_decls + ; let dm_binds = concat dm_binds_s + + -- (b) instance declarations + ; let dm_ids = collectHsBindsBinders CollNoDictBinders dm_binds + -- Add the default method Ids (again) + -- (they were already added in GHC.Tc.TyCl.Utils.tcAddImplicits) + -- See Note [Default methods in the type environment] + ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ + mapM tcInstDecl2 inst_decls + + -- Done + ; return (dm_binds ++ concat inst_binds_s) } + +{- Note [Default methods in the type environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The default method Ids are already in the type environment (see Note +[Default method Ids and Template Haskell] in TcTyDcls), BUT they +don't have their InlinePragmas yet. Usually that would not matter, +because the simplifier propagates information from binding site to +use. But, unusually, when compiling instance decls we *copy* the +INLINE pragma from the default method to the method for that +particular operation (see Note [INLINE and default methods] below). + +So right here in tcInstDecls2 we must re-extend the type envt with +the default method Ids replete with their INLINE pragmas. Urk. +-} + +tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) + -- Returns a binding for the dfun +tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) + = recoverM (return emptyLHsBinds) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 dfun_ty) $ + do { -- Instantiate the instance decl with skolem constants + (skol_info, inst_tyvars, dfun_theta, clas, inst_tys) <- tcSkolDFunType dfun_ty + ; dfun_ev_vars <- newEvVars dfun_theta + + ; let (class_tyvars, sc_theta, _, op_items) = classBigSig clas + sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta + + ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta']) + + -- Deal with 'SPECIALISE instance' pragmas + -- See Note [SPECIALISE instance pragmas] + ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds + + -- Typecheck superclasses and methods + -- See Note [Typechecking plan for instance declarations] + ; dfun_ev_binds_var <- newTcEvBinds + ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var + ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) + <- pushTcLevelM $ + do { (sc_ids, sc_binds, sc_implics) + <- tcSuperClasses skol_info dfun_id clas inst_tyvars + dfun_ev_vars dfun_ev_binds sc_theta' + + -- Typecheck the methods + ; (meth_ids, meth_binds, meth_implics) + <- tcMethods skol_info dfun_id clas inst_tyvars dfun_ev_vars + inst_tys dfun_ev_binds spec_inst_info + op_items ibinds + + ; return ( sc_ids ++ meth_ids + , sc_binds ++ meth_binds + , sc_implics `unionBags` meth_implics ) } + + ; imp <- newImplication + ; emitImplication $ + imp { ic_tclvl = tclvl + , ic_skols = inst_tyvars + , ic_given = dfun_ev_vars + , ic_wanted = mkImplicWC sc_meth_implics + , ic_binds = dfun_ev_binds_var + , ic_info = skol_info } + + -- Create the result bindings + ; self_dict <- newDict clas inst_tys + ; let class_tc = classTyCon clas + loc' = noAnnSrcSpan loc + dict_constr = tyConSingleDataCon class_tc + dict_bind = mkVarBind self_dict (L loc' con_app_args) + + -- We don't produce a binding for the dict_constr; instead we + -- rely on the simplifier to unfold this saturated application + -- We do this rather than generate an HsCon directly, because + -- it means that the special cases (e.g. dictionary with only one + -- member) are dealt with by the common MkId.mkDataConWrapId + -- code rather than needing to be repeated here. + -- con_app_tys = MkD ty1 ty2 + -- con_app_scs = MkD ty1 ty2 sc1 sc2 + -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 + con_app_tys = mkHsWrap (mkWpTyApps inst_tys) $ + mkConLikeTc (RealDataCon dict_constr) + -- NB: We *can* have covars in inst_tys, in the case of + -- promoted GADT constructors. + + con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids + + app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc + app_to_meth fun meth_id = HsApp noExtField (L loc' fun) + (L loc' (wrapId arg_wrapper meth_id)) + + inst_tv_tys = mkTyVarTys inst_tyvars + arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys + + dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids + dfun_spec_prags = SpecPrags spec_inst_prags + + export = ABE { abe_wrap = idHsWrapper + , abe_poly = dfun_id_w_prags + , abe_mono = self_dict + , abe_prags = dfun_spec_prags } + -- NB: see Note [SPECIALISE instance pragmas] + main_bind = XHsBindsLR $ + AbsBinds { abs_tvs = inst_tyvars + , abs_ev_vars = dfun_ev_vars + , abs_exports = [export] + , abs_ev_binds = [] + , abs_binds = [dict_bind] + , abs_sig = True } + + ; return (L loc' main_bind : sc_meth_binds) + } + where + dfun_id = instanceDFunId ispec + dfun_ty = idType dfun_id + loc = getSrcSpan dfun_id + +addDFunPrags :: DFunId -> [Id] -> DFunId +-- DFuns need a special Unfolding and InlinePrag +-- See Note [ClassOp/DFun selection] +-- and Note [Single-method classes] +-- It's easiest to create those unfoldings right here, where +-- have all the pieces in hand, even though we are messing with +-- Core at this point, which the typechecker doesn't usually do +-- However we take care to build the unfolding using the TyVars from +-- the DFunId rather than from the skolem pieces that the typechecker +-- is messing with. +addDFunPrags dfun_id sc_meth_ids + = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args + `setInlinePragma` dfunInlinePragma + -- NB: mkDFunUnfolding takes care of unary classes + where + dict_args = map Type inst_tys ++ + [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] + + (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id) + ev_ids = mkTemplateLocalsNum 1 dfun_theta + dfun_bndrs = dfun_tvs ++ ev_ids + clas_tc = classTyCon clas + dict_con = tyConSingleDataCon clas_tc + +wrapId :: HsWrapper -> Id -> HsExpr GhcTc +wrapId wrapper id = mkHsWrap wrapper (mkHsVar (noLocA id)) + +{- Note [Typechecking plan for instance declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For instance declarations we generate the following bindings and implication +constraints. Example: + + instance Ord a => Ord [a] where compare = + +generates this: + + Bindings: + -- Method bindings + $ccompare :: forall a. Ord a => a -> a -> Ordering + $ccompare = /\a \(d:Ord a). let in ... + + -- Superclass bindings + $cp1Ord :: forall a. Ord a => Eq [a] + $cp1Ord = /\a \(d:Ord a). let + in dfEqList (dw :: Eq a) + + Constraints: + forall a. Ord a => + -- Method constraint + (forall. (empty) => ) + -- Superclass constraint + /\ (forall. (empty) => dw :: Eq a) + +Notice that + + * Per-meth/sc implication. There is one inner implication per + superclass or method, with no skolem variables or givens. The only + reason for this one is to gather the evidence bindings privately + for this superclass or method. This implication is generated + by checkInstConstraints. + + * Overall instance implication. There is an overall enclosing + implication for the whole instance declaration, with the expected + skolems and givens. We need this to get the correct "redundant + constraint" warnings, gathering all the uses from all the methods + and superclasses. See GHC.Tc.Solver Note [Tracking redundant + constraints] + + * The given constraints in the outer implication may generate + evidence, notably by superclass selection. Since the method and + superclass bindings are top-level, we want that evidence copied + into *every* method or superclass definition. (Some of it will + be usused in some, but dead-code elimination will drop it.) + + We achieve this by putting the evidence variable for the overall + instance implication into the AbsBinds for each method/superclass. + Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses. + (And that in turn is why the abs_ev_binds field of AbBinds is a + [TcEvBinds] rather than simply TcEvBinds. + + This is a bit of a hack, but works very nicely in practice. + + * Note that if a method has a locally-polymorphic binding, there will + be yet another implication for that, generated by tcPolyCheck + in tcMethodBody. E.g. + class C a where + foo :: forall b. Ord b => blah + + +************************************************************************ +* * + Type-checking superclasses +* * +************************************************************************ +-} + +tcSuperClasses :: SkolemInfoAnon -> DFunId -> Class -> [TcTyVar] + -> [EvVar] + -> TcEvBinds + -> TcThetaType + -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication) +-- Make a new top-level function binding for each superclass, +-- something like +-- $Ordp1 :: forall a. Ord a => Eq [a] +-- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d) +-- +-- See Note [Recursive superclasses] for why this is so hard! +-- In effect, we build a special-purpose solver for the first step +-- of solving each superclass constraint +tcSuperClasses skol_info dfun_id cls tyvars dfun_evs dfun_ev_binds sc_theta + = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..]) + ; return (ids, binds, listToBag implics) } + where + loc = getSrcSpan dfun_id + tc_super (sc_pred, n) + = do { (sc_implic, ev_binds_var, sc_ev_tm) + <- checkInstConstraints skol_info $ + emitWanted (ScOrigin IsClsInst NakedSc) sc_pred + -- ScOrigin IsClsInst True: see Note [Solving superclass constraints] + + ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) + ; sc_ev_id <- newEvVar sc_pred + ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id EvCanonical sc_ev_tm + ; let sc_top_ty = tcMkDFunSigmaTy tyvars (map idType dfun_evs) sc_pred + sc_top_id = mkLocalId sc_top_name ManyTy sc_top_ty + export = ABE { abe_wrap = idHsWrapper + , abe_poly = sc_top_id + , abe_mono = sc_ev_id + , abe_prags = noSpecPrags } + local_ev_binds = TcEvBinds ev_binds_var + bind = XHsBindsLR $ + AbsBinds { abs_tvs = tyvars + , abs_ev_vars = dfun_evs + , abs_exports = [export] + , abs_ev_binds = [dfun_ev_binds, local_ev_binds] + , abs_binds = [] + , abs_sig = False } + ; return (sc_top_id, L (noAnnSrcSpan loc) bind, sc_implic) } + +------------------- +checkInstConstraints :: SkolemInfoAnon -> TcM result + -> TcM (Implication, EvBindsVar, result) +-- See Note [Typechecking plan for instance declarations] +checkInstConstraints skol_info thing_inside + = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $ + thing_inside + + ; ev_binds_var <- newTcEvBinds + ; implic <- newImplication + ; let implic' = implic { ic_tclvl = tclvl + , ic_wanted = wanted + , ic_binds = ev_binds_var + , ic_info = skol_info } + + ; return (implic', ev_binds_var, result) } + +{- +Note [Recursive superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #3731, #4809, #5751, #5913, #6117, #6161, which all +describe somewhat more complicated situations, but ones +encountered in practice. + +See also tests tcrun020, tcrun021, tcrun033, and #11427. + +----- THE PROBLEM -------- +The problem is that it is all too easy to create a class whose +superclass is bottom when it should not be. + +Consider the following (extreme) situation: + class C a => D a where ... + instance D [a] => D [a] where ... (dfunD) + instance C [a] => C [a] where ... (dfunC) +Although this looks wrong (assume D [a] to prove D [a]), it is only a +more extreme case of what happens with recursive dictionaries, and it +can, just about, make sense because the methods do some work before +recursing. + +To implement the dfunD we must generate code for the superclass C [a], +which we had better not get by superclass selection from the supplied +argument: + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (scsel d) .. + +Otherwise if we later encounter a situation where +we have a [Wanted] dw::D [a] we might solve it thus: + dw := dfunD dw +Which is all fine except that now ** the superclass C is bottom **! + +The instance we want is: + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ... + +----- THE SOLUTION -------- +The basic solution is simple: be very careful about using superclass +selection to generate a superclass witness in a dictionary function +definition. More precisely: + + Superclass Invariant: in every class dictionary, + every superclass dictionary field + is non-bottom + +To achieve the Superclass Invariant, in a dfun definition we can +generate a guaranteed-non-bottom superclass witness from: + (sc1) one of the dictionary arguments itself (all non-bottom) + (sc2) an immediate superclass of a non-bottom dictionary that is + /Paterson-smaller/ than the instance head + See Note [The PatersonSize of a type] in GHC.Tc.Utils.TcType + (sc3) a call of a dfun (always returns a dictionary constructor) + +The tricky case is (sc2). We proceed by induction on the size of the +(type of) the dictionary, defined by GHC.Tc.Utils.TcType.pSizeType. Let's +suppose we are building a dictionary of size 3 (the "head"), and suppose +the Superclass Invariant holds of smaller dictionaries. Then if we have a +smaller dictionary, its immediate superclasses will be non-bottom by +induction. + +Why "Paterson-smaller"? See Note [Paterson conditions] in GHC.Tc.Validity. +We want to be sure that the superclass dictionary is smaller /for any +ground instatiation/ of the instance, so we need to account for type +variables that occur more than once, and for type families (#20666). And +that's exactly what the Paterson conditions check! + +Here is an example, taken from CmmExpr: + class Ord r => UserOfRegs r a where ... +(i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where +(i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where + +For (i1) we can get the (Ord r) superclass by selection from +(UserOfRegs r a), since it (i.e. UserOfRegs r a) is smaller than the +thing we are building, namely (UserOfRegs r (Maybe a)). + +But for (i2) that isn't the case: (UserOfRegs r CmmReg) is not smaller +than the thing we are building (UserOfRegs r CmmExpr), so we can't use +the superclasses of the former. Hence we must instead add an explicit, +and perhaps surprising, (Ord r) argument to the instance declaration. + +Here's another example from #6161: + + class Super a => Duper a where ... + class Duper (Maybe a) => Foo a where ... +(i3) instance Foo a => Duper (Maybe a) where ... +(i4) instance Foo Float where ... + +It would be horribly wrong to define + dfDuperMaybe :: Foo a -> Duper (Maybe a) -- from (i3) + dfDuperMaybe d = MkDuper (sc_sel1 (sc_sel2 d)) ... + + dfFooFloat :: Foo Float -- from (i4) + dfFooFloat = MkFoo (dfDuperMaybe dfFooFloat) ... + +Let's expand the RHS of dfFooFloat: + dfFooFloat = MkFoo (MkDuper (sc_sel1 (sc_sel2 dfFooFloat)) ...) ... +That superclass argument to MkDuper is bottom! + +This program gets rejected because: +* When processing (i3) we need to construct a dictionary for Super + (Maybe a), to put in the superclass field of (Duper (Maybe a)). +* We /can/ use the superclasses of (Foo a), because the latter is + smaller than the head of the instance, namely Duper (Maybe a). +* So we know (by (sc2)) that this Duper (Maybe a) dictionary is + non-bottom. But because (Duper (Maybe a)) is not smaller than the + instance head (Duper (Maybe a)), we can't take *its* superclasses. +As a result the program is rightly rejected, unless you add +(Super (Maybe a)) to the context of (i3). + +Wrinkle (W1): + (sc2) says we only get a non-bottom dict if the dict we are + selecting from is itself non-bottom. So in a superclass chain, + all the dictionaries in the chain must be non-bottom. + class C a => D3 a + class D2 a [[Maybe b]] => D1 a b + class D3 a => D2 a b + class C a => E a b + instance D1 a b => E a [b] + The instance needs the wanted superclass (C a). We can get it + by superclass selection from + D1 a b --> D2 a [[Maybe b]] --> D3 a --> C a + But on the way we go through the too-big (D2 a [[Maybe b]]), and + we don't know that is non-bottom. + +Note [Solving superclass constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we ensure that every superclass witness in an instance declaration +is generated by one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses]? +Answer: + + * The "given" constraints of an instance decl have CtOrigin of + (GivenOrigin (InstSkol head_size)), where head_size is the + PatersonSize of the head of the instance declaration. E.g. in + instance D a => C [a] + the `[G] D a` constraint has a CtOrigin whose head_size is the + PatersonSize of (C [a]). + + * When we make a superclass selection from a Given (transitively) + we give it a CtOrigin of (GivenSCOrigin skol_info sc_depth blocked). + + The 'blocked :: Bool' flag says if the superclass can be used to + solve a superclass Wanted. The new superclass is blocked unless: + + it is the superclass of an unblocked dictionary (wrinkle (W1)), + that is Paterson-smaller than the instance head. + + This is implemented in GHC.Tc.Solver.Dict.mk_strict_superclasses + (in the mk_given_loc helper function). + + * Superclass "Wanted" constraints have CtOrigin of (ScOrigin NakedSc) + The 'NakedSc' says that this is a naked superclass Wanted; we must + be careful when solving it. + + * (sc1) When we rewrite such a wanted constraint, it retains its + origin. But if we apply an instance declaration, we can set the + origin to (ScOrigin NotNakedSc), thus lifting any restrictions by + making prohibitedSuperClassSolve return False. This happens + in GHC.Tc.Solver.Dict.checkInstanceOK. + + * (sc2) ScOrigin wanted constraints can't be solved from a + superclass selection, except at a smaller type. This test is + implemented by GHC.Tc.Solver.InertSet.prohibitedSuperClassSolve + +Note [Silent superclass arguments] (historical interest only) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB1: this note describes our *old* solution to the + recursive-superclass problem. I'm keeping the Note + for now, just as institutional memory. + However, the code for silent superclass arguments + was removed in late Dec 2014 + +NB2: the silent-superclass solution introduced new problems + of its own, in the form of instance overlap. Tests + SilentParametersOverlapping, T5051, and T7862 are examples + +NB3: the silent-superclass solution also generated tons of + extra dictionaries. For example, in monad-transformer + code, when constructing a Monad dictionary you had to pass + an Applicative dictionary; and to construct that you need + a Functor dictionary. Yet these extra dictionaries were + often never used. Test T3064 compiled *far* faster after + silent superclasses were eliminated. + +Our solution to this problem "silent superclass arguments". We pass +to each dfun some ``silent superclass arguments’’, which are the +immediate superclasses of the dictionary we are trying to +construct. In our example: + dfun :: forall a. C [a] -> D [a] -> D [a] + dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... +Notice the extra (dc :: C [a]) argument compared to the previous version. + +This gives us: + + ----------------------------------------------------------- + DFun Superclass Invariant + ~~~~~~~~~~~~~~~~~~~~~~~~ + In the body of a DFun, every superclass argument to the + returned dictionary is + either * one of the arguments of the DFun, + or * constant, bound at top level + ----------------------------------------------------------- + +This net effect is that it is safe to treat a dfun application as +wrapping a dictionary constructor around its arguments (in particular, +a dfun never picks superclasses from the arguments under the +dictionary constructor). No superclass is hidden inside a dfun +application. + +The extra arguments required to satisfy the DFun Superclass Invariant +always come first, and are called the "silent" arguments. You can +find out how many silent arguments there are using Id.dfunNSilent; +and then you can just drop that number of arguments to see the ones +that were in the original instance declaration. + +DFun types are built (only) by MkId.mkDictFunId, so that is where we +decide what silent arguments are to be added. +-} + +{- +************************************************************************ +* * + Type-checking an instance method +* * +************************************************************************ + +tcMethod +- Make the method bindings, as a [(NonRec, HsBinds)], one per method +- Remembering to use fresh Name (the instance method Name) as the binder +- Bring the instance method Ids into scope, for the benefit of tcInstSig +- Use sig_fn mapping instance method Name -> instance tyvars +- Ditto prag_fn +- Use tcValBinds to do the checking +-} + +tcMethods :: SkolemInfoAnon -> DFunId -> Class + -> [TcTyVar] -> [EvVar] + -> [TcType] + -> TcEvBinds + -> ([LTcSpecPrag], TcPragEnv) + -> [ClassOpItem] + -> InstBindings GhcRn + -> TcM ([Id], LHsBinds GhcTc, Bag Implication) + -- The returned inst_meth_ids all have types starting + -- forall tvs. theta => ... +tcMethods _skol_info dfun_id clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds (spec_inst_prags, prag_fn) op_items + (InstBindings { ib_binds = binds + , ib_tyvars = lexical_tvs + , ib_pragmas = sigs + , ib_extensions = exts + , ib_derived = is_derived }) + = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $ + -- The lexical_tvs scope over the 'where' part + do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) + ; checkMinimalDefinition + ; checkMethBindMembership + ; (ids, binds, mb_implics) <- set_exts exts $ + unset_warnings_deriving $ + mapAndUnzip3M tc_item op_items + ; return (ids, binds, listToBag (catMaybes mb_implics)) } + where + set_exts :: [LangExt.Extension] -> TcM a -> TcM a + set_exts es thing = foldr setXOptM thing es + + -- See Note [Avoid -Winaccessible-code when deriving] + unset_warnings_deriving :: TcM a -> TcM a + unset_warnings_deriving + | is_derived = unsetWOptM Opt_WarnInaccessibleCode + | otherwise = id + + hs_sig_fn = mkHsSigFun sigs + inst_loc = getSrcSpan dfun_id + + unsat_thetas = + mapMaybe (\ id -> (id,) <$> isUnsatisfiableCt_maybe (idType id)) dfun_ev_vars + + ---------------------- + tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication) + tc_item (sel_id, dm_info) + | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn + = tcMethodBody False clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived hs_sig_fn + spec_inst_prags prags + sel_id user_bind bndr_loc + | otherwise + = do { traceTc "tc_def" (ppr sel_id) + ; tc_default sel_id dm_info } + + ---------------------- + tc_default :: Id -> DefMethInfo + -> TcM (TcId, LHsBind GhcTc, Maybe Implication) + + tc_default sel_id mb_dm = case mb_dm of + + -- If the instance has an "Unsatisfiable msg" context, + -- add method bindings that use "unsatisfiable". + -- + -- See Note [Implementation of Unsatisfiable constraints], + -- in GHC.Tc.Errors, point (D). + _ | (theta_id,unsat_msg) : _ <- unsat_thetas + -> do { (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars + inst_tys sel_id + ; unsat_id <- tcLookupId unsatisfiableIdName + -- Recall that unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a + -- + -- So we need to instantiate the forall and pass the dictionary evidence. + ; let meth_rhs = L inst_loc' $ + wrapId + ( mkWpEvApps [EvExpr $ Var theta_id] + <.> mkWpTyApps [getRuntimeRep meth_tau, unsat_msg, meth_tau]) + unsat_id + meth_bind = mkVarBind meth_id $ mkLHsWrap lam_wrapper meth_rhs + ; return (meth_id, meth_bind, Nothing) } + + Just (dm_name, dm_spec) -> + do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name dm_spec + ; tcMethodBody (is_vanilla_dm dm_spec) + clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived hs_sig_fn + spec_inst_prags inline_prags + sel_id meth_bind inst_loc } + + -- No default method + Nothing -> + do { traceTc "tc_def: warn" (ppr sel_id) + ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars + inst_tys sel_id + ; dflags <- getDynFlags + -- Add a binding whose RHS is an error + -- "No explicit nor default method for class operation 'meth'". + ; let meth_rhs = error_rhs dflags + meth_bind = mkVarBind meth_id $ mkLHsWrap lam_wrapper meth_rhs + ; return (meth_id, meth_bind, Nothing) } + + where + inst_loc' = noAnnSrcSpan inst_loc + error_rhs dflags = L inst_loc' + $ HsApp noExtField error_fun (error_msg dflags) + error_fun = L inst_loc' $ + wrapId (mkWpTyApps + [ getRuntimeRep meth_tau, meth_tau]) + nO_METHOD_BINDING_ERROR_ID + error_msg dflags = L inst_loc' + (HsLit noExtField (HsStringPrim NoSourceText + (unsafeMkByteString (error_string dflags)))) + meth_tau = classMethodInstTy sel_id inst_tys + error_string dflags = showSDoc dflags + (hcat [ppr inst_loc, vbar, quotes (ppr sel_id) ]) + lam_wrapper = mkWpTyLams tyvars <.> mkWpEvLams dfun_ev_vars + + ---------------------- + -- Check if one of the minimal complete definitions is satisfied + checkMinimalDefinition + = when (null unsat_thetas) $ + -- Don't warn if there is an "Unsatisfiable" constraint in the context. + -- + -- See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors, + -- point (D). + whenIsJust (isUnsatisfied (methodExists . unLoc) (classMinimalDef clas)) $ + warnUnsatisfiedMinimalDefinition + + methodExists meth = isJust (findMethodBind meth binds prag_fn) + + ---------------------- + -- Check if any method bindings do not correspond to the class. + -- See Note [Mismatched class methods and associated type families]. + checkMethBindMembership + = mapM_ (addErrTc . TcRnBadMethodErr (className clas)) mismatched_meths + where + bind_nms = map unLoc $ collectMethodBinders binds + cls_meth_nms = map (idName . fst) op_items + mismatched_meths = bind_nms `minusList` cls_meth_nms + + is_vanilla_dm :: DefMethSpec ty -> Bool + -- See (TRC5) in Note [Tracking redundant constraints] + -- in GHC.Tc.Solver.Solve + is_vanilla_dm VanillaDM = True + is_vanilla_dm (GenericDM {}) = False + +{- +Note [Mismatched class methods and associated type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's entirely possible for someone to put methods or associated type family +instances inside of a class in which it doesn't belong. For instance, we'd +want to fail if someone wrote this: + + instance Eq () where + type Rep () = Maybe + compare = undefined + +Since neither the type family `Rep` nor the method `compare` belong to the +class `Eq`. Normally, this is caught in the renamer when resolving RdrNames, +since that would discover that the parent class `Eq` is incorrect. + +However, there is a scenario in which the renamer could fail to catch this: +if the instance was generated through Template Haskell, as in #12387. In that +case, Template Haskell will provide fully resolved names (e.g., +`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going +on. For this reason, we also put an extra validity check for this in the +typechecker as a last resort. + +Note [Avoid -Winaccessible-code when deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-Winaccessible-code can be particularly noisy when deriving instances for +GADTs. Consider the following example (adapted from #8128): + + data T a where + MkT1 :: Int -> T Int + MkT2 :: T Bool + MkT3 :: T Bool + deriving instance Eq (T a) + deriving instance Ord (T a) + +In the derived Ord instance, GHC will generate the following code: + + instance Ord (T a) where + compare x y + = case x of + MkT2 + -> case y of + MkT1 {} -> GT + MkT2 -> EQ + _ -> LT + ... + +However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2 +differ, so if -Winaccessible-code is enabled, then deriving this instance will +result in unwelcome warnings. + +One conceivable approach to fixing this issue would be to change `deriving Ord` +such that it becomes smarter about not generating unreachable cases. This, +however, would be a highly nontrivial refactor, as we'd have to propagate +through typing information everywhere in the algorithm that generates Ord +instances in order to determine which cases were unreachable. This seems like +a lot of work for minimal gain, so we have opted not to go for this approach. + +Instead, we take the following approach: + +1. In tcMethods (which typechecks method bindings), use 'setInGeneratedCode'. +2. When creating Implications during typechecking, record this flag + (in ic_warn_inaccessible) at the time of creation. +3. After typechecking comes error reporting, where GHC must decide how to + report inaccessible code to the user, on an Implication-by-Implication + basis. If the ic_warn_inaccessible field of the Implication is False, then + we don't bother reporting it. That's it! +-} + +------------------------ +tcMethodBody :: Bool -- True <=> This is a vanilla default method + -- See (TRC5) in Note [Tracking redundant constraints] + -- in GHC.Tc.Solver.Solve + -> Class -> [TcTyVar] -> [EvVar] -> [TcType] + -> TcEvBinds -> Bool + -> HsSigFun + -> [LTcSpecPrag] -> [LSig GhcRn] + -> Id -> LHsBind GhcRn -> SrcSpan + -> TcM (TcId, LHsBind GhcTc, Maybe Implication) +tcMethodBody is_vanilla_dm clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived + sig_fn spec_inst_prags prags + sel_id (L bind_loc meth_bind) bndr_loc + = add_meth_ctxt $ + do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc) + ; let skol_info = MethSkol meth_name is_vanilla_dm + ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $ + mkMethIds clas tyvars dfun_ev_vars + inst_tys sel_id + + ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpan bndr_loc) + (idName local_meth_id) } + -- Substitute the local_meth_name for the binder + -- NB: the binding is always a FunBind + + -- taking instance signature into account might change the type of + -- the local_meth_id + ; (meth_implic, ev_binds_var, tc_bind) + <- checkInstConstraints skol_info $ + tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind) + + ; global_meth_id <- addInlinePrags global_meth_id prags + ; spec_prags <- tcExtendIdEnv1 meth_name global_meth_id $ + -- tcExtendIdEnv1: tricky point: a SPECIALISE pragma in prags + -- mentions sel_name but the pragma is really for global_meth_id. + -- So we bind sel_name to global_meth_id, just in the pragmas. + -- Example: + -- instance C [a] where + -- op :: forall b. Ord b => b -> a -> a + -- {-# SPECIALISE op @Int #-} + -- The specialisation is for the `op` for this instance decl, not + -- for the global selector-id, of course. + tcSpecPrags global_meth_id prags + + ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags + export = ABE { abe_poly = global_meth_id + , abe_mono = local_meth_id + , abe_wrap = idHsWrapper + , abe_prags = specs } + + local_ev_binds = TcEvBinds ev_binds_var + full_bind = XHsBindsLR $ + AbsBinds { abs_tvs = tyvars + , abs_ev_vars = dfun_ev_vars + , abs_exports = [export] + , abs_ev_binds = [dfun_ev_binds, local_ev_binds] + , abs_binds = tc_bind + , abs_sig = True } + + ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) } + where + meth_name = idName sel_id + + -- For instance decls that come from deriving clauses + -- we want to print out the full source code if there's an error + -- because otherwise the user won't see the code at all + add_meth_ctxt thing + | is_derived = addLandmarkErrCtxt (DerivBindCtxt sel_id clas inst_tys) thing + | otherwise = thing + +tcMethodBodyHelp :: HsSigFun -> Id -> TcId + -> LHsBind GhcRn -> TcM (LHsBinds GhcTc) +tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind + | Just hs_sig_ty <- hs_sig_fn sel_name + -- There is a signature in the instance + -- See Note [Instance method signatures] + = do { (sig_ty, hs_wrap) + <- setSrcSpan (getLocA hs_sig_ty) $ + do { inst_sigs <- xoptM LangExt.InstanceSigs + ; checkTc inst_sigs (TcRnMisplacedInstSig sel_name hs_sig_ty) + ; let ctxt = FunSigCtxt sel_name NoRRC + ; sig_ty <- tcHsSigType ctxt hs_sig_ty + ; let local_meth_ty = idType local_meth_id + -- False <=> do not report redundant constraints when + -- checking instance-sig <= class-meth-sig + -- The instance-sig is the focus here; the class-meth-sig + -- is fixed (#18036) + ; let orig = InstanceSigOrigin sel_name sig_ty local_meth_ty + ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $ + tcSubTypeSigma orig ctxt sig_ty local_meth_ty + ; return (sig_ty, hs_wrap) } + + ; inner_meth_name <- newName (nameOccName sel_name) + ; let ctxt = FunSigCtxt sel_name (lhsSigTypeContextSpan hs_sig_ty) + -- WantRCC <=> check for redundant constraints in the + -- user-specified instance signature + inner_meth_id = mkLocalId inner_meth_name ManyTy sig_ty + inner_meth_sig = CSig { sig_bndr = inner_meth_id + , sig_ctxt = ctxt + , sig_loc = getLocA hs_sig_ty } + + ; (tc_bind, [Scaled _ inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind + + ; let export = ABE { abe_poly = local_meth_id + , abe_mono = inner_id + , abe_wrap = hs_wrap + , abe_prags = noSpecPrags } + + ; return (singleton $ L (getLoc meth_bind) $ XHsBindsLR $ + AbsBinds { abs_tvs = [], abs_ev_vars = [] + , abs_exports = [export] + , abs_binds = tc_bind, abs_ev_binds = [] + , abs_sig = True }) } + + | otherwise -- No instance signature + = do { let ctxt = FunSigCtxt sel_name NoRRC + -- NoRRC <=> don't report redundant constraints + -- The signature is not under the users control! + tc_sig = completeSigFromId ctxt local_meth_id + -- Absent a type sig, there are no new scoped type variables here + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = } + -- In , 'c' is scope but 'b' is not! + + ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind + ; return tc_bind } + + where + sel_name = idName sel_id + no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; + -- they are all for meth_id + +------------------------ +mkMethIds :: Class -> [TcTyVar] -> [EvVar] + -> [TcType] -> Id -> TcM (TcId, TcId) + -- returns (poly_id, local_id), but ignoring any instance signature + -- See Note [Instance method signatures] +mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id + = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ) + ; local_meth_name <- newName sel_occ + -- Base the local_meth_name on the selector name, because + -- type errors from tcMethodBody come from here + ; let poly_meth_id = mkLocalId poly_meth_name ManyTy poly_meth_ty + local_meth_id = mkLocalId local_meth_name ManyTy local_meth_ty + + ; return (poly_meth_id, local_meth_id) } + where + sel_name = idName sel_id + -- Force so that a thunk doesn't end up in a Name (#19619) + !sel_occ = nameOccName sel_name + local_meth_ty = instantiateMethod clas sel_id inst_tys + poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty + theta = map idType dfun_ev_vars + +methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) +methSigCtxt sel_name sig_ty meth_ty env0 + = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty + ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty + ; return (env2, MethSigCtxt sel_name sig_ty meth_ty) } + +{- Note [Instance method signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -XInstanceSigs we allow the user to supply a signature for the +method in an instance declaration. Here is an artificial example: + + data T a = MkT a + instance Ord a => Ord (T a) where + (>) :: forall b. b -> b -> Bool + (>) = error "You can't compare Ts" + +The instance signature can be *more* polymorphic than the instantiated +class method (in this case: Age -> Age -> Bool), but it cannot be less +polymorphic. Moreover, if a signature is given, the implementation +code should match the signature, and type variables bound in the +signature should scope over the method body. + +We achieve this by building a TcSigInfo for the method, whether or not +there is an instance method signature, and using that to typecheck +the declaration (in tcMethodBody). That means, conveniently, +that the type variables bound in the signature will scope over the body. + +What about the check that the instance method signature is more +polymorphic than the instantiated class method type? We just do a +tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like +this (for the example above + + AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a] + , abs_exports + = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool + , gr_lcl :: T a -> T a -> Bool } + , abs_binds + = AbsBind { abs_tvs = [], abs_ev_vars = [] + , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool + , gr_inner :: forall b. b -> b -> Bool } + , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = [] + , ..etc.. } + } } + +Wow! Three nested AbsBinds! + * The outer one abstracts over the tyvars and dicts for the instance + * The middle one is only present if there is an instance signature, + and does the impedance matching for that signature + * The inner one is for the method binding itself against either the + signature from the class, or the instance signature. +-} + +---------------------- +mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags + -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id + -- There are two sources: + -- * spec_prags_for_me: {-# SPECIALISE op :: #-} + -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: #-} + -- These ones have the dfun inside, but [perhaps surprisingly] + -- the correct wrapper. + -- See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Bind +mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me + = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) + where + spec_prags_from_inst + | isInlinePragma (idInlinePragma meth_id) + = [] -- Do not inherit SPECIALISE from the instance if the + -- method is marked INLINE, because then it'll be inlined + -- and the specialisation would do nothing. (Indeed it'll provoke + -- a warning from the desugarer + | otherwise + = [ L inst_loc (SpecPrag meth_id wrap inl) + | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] + + +mkDefMethBind :: SrcSpan -> DFunId -> Class -> Id -> Name + -> DefMethSpec Type + -> TcM (LHsBind GhcRn, [LSig GhcRn]) +-- The is a default method (vanailla or generic) defined in the class +-- So make a binding op @m1 @m2 @m3 = $dmop @i1 @i2 @m1 @m2 @m3 +-- where $dmop is the name of the default method in the class; +-- i1 and t2 are the instance types; and m1, m2, and m3 are the type variables +-- from the method's type signature. See Note [Default methods in instances] for +-- why we use visible type application here. +mkDefMethBind loc dfun_id clas sel_id dm_name dm_spec + = do { logger <- getLogger + ; dm_id <- tcLookupId dm_name + ; let inline_prag = idInlinePragma dm_id + inline_prags | isAnyInlinePragma inline_prag + = [noLocA (InlineSig noAnn fn inline_prag)] + | otherwise + = [] + -- Copy the inline pragma (if any) from the default method + -- to this version. Note [INLINE and default methods] + + ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body" + FormatHaskell + (vcat [ppr clas <+> ppr inst_tys, + nest 2 (ppr bind)])) + + ; return (bind, inline_prags) } + where + (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id) + (_, _, sel_tau) = tcSplitMethodTy (idType sel_id) + (sel_tvbs, _) = tcSplitForAllInvisTVBinders sel_tau + + -- Compute the instance types to use in the visible type application. See + -- Note [Default methods in instances]. + visible_inst_tys = + [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys + , tyConBinderForAllTyFlag tcb /= Inferred ] + + visible_sel_tvbs = + case dm_spec of + -- When dealing with a vanilla default method, compute the type + -- variables from the method's type signature. That way, we can bind + -- them with TypeAbstractions (visible_sel_pats) and use them in the + -- visible type application (visible_sel_tys). See Note [Default methods + -- in instances] (Wrinkle: Ambiguous types from vanilla method type + -- signatures). + VanillaDM -> filter (\tvb -> binderFlag tvb /= InferredSpec) sel_tvbs + -- If we are dealing with a generic default method, on the other hand, + -- don't bother doing any of this. See Note [Default methods + -- in instances] (Wrinkle: Ambiguous types from generic default method + -- type signatures). + GenericDM {} -> [] + visible_sel_pats = map mk_ty_pat visible_sel_tvbs + visible_sel_tys = map (mkTyVarTy . binderVar) visible_sel_tvbs + + fn = noLocA (idName sel_id) + rhs = foldl' mk_vta (nlHsVar dm_name) $ + visible_inst_tys ++ visible_sel_tys + bind = L (noAnnSrcSpan loc) + $ mkTopFunBind (Generated OtherExpansion SkipPmc) fn + [mkSimpleMatch (mkPrefixFunRhs fn noAnn) (noLocA visible_sel_pats) rhs] + + mk_ty_pat :: VarBndr TyVar Specificity -> LPat GhcRn + mk_ty_pat (Bndr tv spec) = + noLocA $ + InvisPat spec $ + HsTP (HsTPRn [] [tyVarName tv] []) $ + nlHsTyVar NotPromoted $ + tyVarName tv + + mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn + mk_vta fun ty = noLocA (HsAppType noExtField fun + (mkEmptyWildCardBndrs $ type_to_hs_type ty)) + -- NB: use visible type application + -- See Note [Default methods in instances] + + type_to_hs_type :: Type -> LHsType GhcRn + type_to_hs_type = parenthesizeHsType appPrec . noLocA . XHsType + +---------------------- + +warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () +warnUnsatisfiedMinimalDefinition mindef + = do { warn <- woptM Opt_WarnMissingMethods + ; let msg = TcRnUnsatisfiedMinimalDef mindef + ; diagnosticTc warn msg + } + +{- +Note [Export helper functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We arrange to export the "helper functions" of an instance declaration, +so that they are not subject to preInlineUnconditionally, even if their +RHS is trivial. Reason: they are mentioned in the DFunUnfolding of +the dict fun as Ids, not as CoreExprs, so we can't substitute a +non-variable for them. + +We could change this by making DFunUnfoldings have CoreExprs, but it +seems a bit simpler this way. + +Note [Default methods in instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + + class Baz v x where + foo :: x -> x + foo y = + + instance Baz Int Int + +From the class decl we get + + $dmfoo :: forall v x. Baz v x => x -> x + $dmfoo y = + +Notice that the type of `v` is ambiguous. So we use Visible Type Application +(VTA) to disambiguate: + + $dBazIntInt = MkBaz fooIntInt + fooIntInt = $dmfoo @Int @Int + +Lacking VTA we'd get ambiguity errors involving the default method. This applies +equally to vanilla default methods (#1061) and generic default methods +(#12220). + +Historical note: before we had VTA we had to generate +post-type-checked code, which took a lot more code, and didn't work for +generic default methods. + +----- +-- Wrinkle: Ambiguous types from vanilla method type signatures +----- + +In the Bar example above, the ambiguity arises from `v`, a type variable +arising from the class header. It is also possible for the ambiguity to arise +from a type variable bound by the method's type signature itself (see #14266 +and #25148). For example: + + class A t where + f :: forall x m. Monoid x => t m -> m + f = + + instance A [] + +The class declaration gives rise to the following default function: + + $dmf :: forall t. A t => forall x m. Monoid x => t m -> m + $dmf = + +And the instance declaration gives rise to generated code that looks roughly +like this: + + instance A [] where + f = $dmf @[] ... + +In this example, it is not enough to use VTA to specify the type of `t`, since +the type of `x` (bound by `f`'s type signature) is also ambiguous. We need to +generate code that looks more like this: + + instance A [] where + f = $dmf @[] @x @m + +But where should `x` and `m` be bound? It's tempting to use ScopedTypeVariables +and InstanceSigs to accomplish this: + + instance A [] where + f :: forall x m. Monoid x => [m] -> m + f = $dmf @[] @x @m + +GHC will reject this code, however, as the type signature for `f` will fail the +subtype check for InstanceSigs: + + • Could not deduce (Monoid x0) + from the context: Monoid x + bound by the type signature for: + f :: forall x m. Monoid x => [m] -> m + The type variable ‘x0’ is ambiguous + • When checking that instance signature for ‘f’ + is more general than its signature in the class + Instance sig: forall x m. Monoid x => [m] -> m + Class sig: forall x m. Monoid x => [m] -> m + In the instance declaration for ‘A []’ + +See #17898. To avoid this problem, we instead bind `x` and `m` using +TypeAbstractions: + + instance A [] where + f @x @m = $dmf @[] @x @m + +This resolves the ambiguity and avoids the need for a subtype check. (We also +use a similar trick for resolving ambiguity in GeneralizedNewtypeDeriving: see +also Note [GND and ambiguity] in GHC.Tc.Deriv.Generate.) + +----- +-- Wrinkle: Ambiguous types from generic default method type signatures +----- + +Note that the approach described above (in Wrinkle: Ambiguous types from +vanilla method type signatures) will only work for vanilla default methods and +/not/ for generic default methods (i.e., methods using DefaultSignatures). This +is because for vanilla default methods, the type of the generated $dm* function +will always quantify the same type variables as the method's original type +signature, in the same order and with the same specificities. For example, the +type of the $dmf function will be: + + $dmf :: forall t. A t => forall x m. Monoid x => t m -> m + +As such, it is guaranteed that the type variables from the method's original +type signature will line up exactly with the type variables from the $dm* +function (after instantiating all of the class variables): + + instance A [] where + f @x @m = $dmf @[] @x @m + +We cannot guarantee this property for generic default methods, however. As +such, we must be more conservative and generate code without instantiating any +of the type variables bound by the method's type signature (only the type +variables bound by the class header): + + instance A [] where + f = $dmf @[] + +There are a number of reasons why we cannot reliably instantiate the type +variables bound by a generic default method's type signature: + +* Default methods can quantify type variables in a different order, e.g., + + class A t where + f :: forall x m. Monoid x => t m -> m + default f :: forall m x. Monoid x => t m -> m + f = + + Note that the default signature quantifies the type variables in the opposite + order from the method's original type signature. As such, the type of $dmf + will be: + + $dmf :: forall t. A t => forall m x. Monoid x => t m -> m + + Therefore, `f @x @m = $dmf @[] @x @m` would be incorrect. Nor would it be + straightforward to infer what the correct order of type variables should be. + +* Default methods can quantify a different number of type variables, e.g., + + class A t where + f :: forall x m. Monoid x => t m -> m + default f :: forall p q r m. C a t p q r => t m -> m + f = + + This gives rise to: + + $dmf :: forall t. A t => forall p q r m. C a t p q r => t m -> m + + And thus generating `f @x @m = $dmf @[] @x @m` would be incorrect, for + similar reasons as in the example above. + +* Default methods can use different type variable specificities, e.g., + + class A t where + f :: forall x m. Monoid x => t m -> m + default f :: forall {x} m. Monoid x => t m -> m + f = + + This gives rise to: + + $dmf :: forall t. A t => forall {x} m. Monoid x => t m -> m + + Therefore, generating `f @x @m = $dmf @[] @x @m` would be incorrect because + the `x` in the type of $dmf is inferred, so it is not eligible for visible + type application. + +As such, we do not bother trying to resolve the ambiguity of any method-bound +type variables when dealing with generic defaults. This means that GHC won't be +able to typecheck the default method examples above, but so be it. + +Note [INLINE and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Default methods need special case. They are supposed to behave rather like +macros. For example + + class Foo a where + op1, op2 :: Bool -> a -> a + + {-# INLINE op1 #-} + op1 b x = op2 (not b) x + + instance Foo Int where + -- op1 via default method + op2 b x = + +The instance declaration should behave + + just as if 'op1' had been defined with the + code, and INLINE pragma, from its original + definition. + +That is, just as if you'd written + + instance Foo Int where + op2 b x = + + {-# INLINE op1 #-} + op1 b x = op2 (not b) x + +So for the above example we generate: + + {-# INLINE $dmop1 #-} + -- $dmop1 has an InlineCompulsory unfolding + $dmop1 d b x = op2 d (not b) x + + $fFooInt = MkD $cop1 $cop2 + + {-# INLINE $cop1 #-} + $cop1 = $dmop1 $fFooInt + + $cop2 = + +Note carefully: + +* We *copy* any INLINE pragma from the default method $dmop1 to the + instance $cop1. Otherwise we'll just inline the former in the + latter and stop, which isn't what the user expected + +* Regardless of its pragma, we give the default method an + unfolding with an InlineCompulsory source. That means + that it'll be inlined at every use site, notably in + each instance declaration, such as $cop1. This inlining + must happen even though + a) $dmop1 is not saturated in $cop1 + b) $cop1 itself has an INLINE pragma + + It's vital that $dmop1 *is* inlined in this way, to allow the mutual + recursion between $fooInt and $cop1 to be broken + +* To communicate the need for an InlineCompulsory to the desugarer + (which makes the Unfoldings), we use the IsDefaultMethod constructor + in TcSpecPrags. + + +************************************************************************ +* * + Specialise instance pragmas +* * +************************************************************************ + +Note [SPECIALISE instance pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance (Ix a, Ix b) => Ix (a,b) where + {-# SPECIALISE instance Ix (Int,Int) #-} + range (x,y) = ... + +We make a specialised version of the dictionary function, AND +specialised versions of each *method*. Thus we should generate +something like this: + + $dfIxPair :: (Ix a, Ix b) => Ix (a,b) + {-# DFUN [$crangePair, ...] #-} + {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-} + $dfIxPair da db = Ix ($crangePair da db) (...other methods...) + + $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] + {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} + $crange da db = + +The SPECIALISE pragmas are acted upon by the desugarer, which generate + + dii :: Ix Int + dii = ... + + $s$dfIxPair :: Ix ((Int,Int),(Int,Int)) + {-# DFUN [$crangePair di di, ...] #-} + $s$dfIxPair = Ix ($crangePair di di) (...) + + {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-} + + $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)] + $c$crangePair = ...specialised RHS of $crangePair... + + {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-} + +Note that + + * The specialised dictionary $s$dfIxPair is very much needed, in case we + call a function that takes a dictionary, but in a context where the + specialised dictionary can be used. See #7797. + + * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because + it still has a DFunUnfolding. See Note [ClassOp/DFun selection] + + * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways: + --> {ClassOp rule for range} $crangePair Int Int d1 d2 + --> {SPEC rule for $crangePair} $s$crangePair + or thus: + --> {SPEC rule for $dfIxPair} range $s$dfIxPair + --> {ClassOpRule for range} $s$crangePair + It doesn't matter which way. + + * We want to specialise the RHS of both $dfIxPair and $crangePair, + but the SAME HsWrapper will do for both! We can call tcSpecPrag + just once, and pass the result (in spec_inst_info) to tcMethods. +-} + +tcSpecInstPrags :: DFunId -> InstBindings GhcRn + -> TcM ([LTcSpecPrag], TcPragEnv) +tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) + = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ + filter isSpecInstLSig uprags + -- The filter removes the pragmas for methods + ; return (spec_inst_prags, mkPragEnv uprags binds) } + +------------------------------ +tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag +tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) + = addErrCtxt (SpecPragmaCtxt prag) $ + do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty + ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty + ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } + +tcSpecInst _ _ = panic "tcSpecInst" + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +instDeclCtxt1 :: LHsSigType GhcRn -> ErrCtxtMsg +instDeclCtxt1 hs_inst_ty + = InstDeclErrCtxt $ Left $ getLHsInstDeclHead hs_inst_ty + +instDeclCtxt2 :: Type -> ErrCtxtMsg +instDeclCtxt2 dfun_ty + = InstDeclErrCtxt $ Right $ head_ty + where + (_,_,head_ty) = tcSplitQuantPredTy dfun_ty diff --git a/GHC/Tc/TyCl/Instance.hs-boot b/GHC/Tc/TyCl/Instance.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/Instance.hs-boot @@ -0,0 +1,16 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Tc.TyCl.Instance ( tcInstDecls1 ) where + +import GHC.Hs +import GHC.Tc.Types +import GHC.Tc.Utils.Env( InstInfo ) +import GHC.Tc.Deriv + +-- We need this because of the mutual recursion +-- between GHC.Tc.TyCl and GHC.Tc.TyCl.Instance +tcInstDecls1 :: [LInstDecl GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) diff --git a/GHC/Tc/TyCl/PatSyn.hs b/GHC/Tc/TyCl/PatSyn.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/PatSyn.hs @@ -0,0 +1,1263 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Typechecking pattern synonym declarations +module GHC.Tc.TyCl.PatSyn + ( tcPatSynDecl + , tcPatSynBuilderBind + , patSynBuilderOcc + ) +where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Zonk.Type +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Zonk.TcType +import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv + , addInlinePrags, addInlinePragArity ) +import GHC.Tc.Solver +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Tc.TyCl.Build + +import GHC.Core.Multiplicity +import GHC.Core.Type ( typeKind, isManyTy, mkTYPEapp ) +import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) +import GHC.Core.TyCo.Tidy( tidyForAllTyBinders, tidyTypes, tidyType ) +import GHC.Core.Predicate + +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Name.Set +import GHC.Types.SrcLoc +import GHC.Core.PatSyn +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Var +import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSetList ) +import GHC.Types.Id +import GHC.Types.Id.Info( RecSelParent(..) ) +import GHC.Tc.Gen.Bind +import GHC.Types.Basic +import GHC.Builtin.Types +import GHC.Types.Var.Set +import GHC.Tc.TyCl.Utils +import GHC.Core.ConLike +import GHC.Types.FieldLabel +import GHC.Rename.Env +import GHC.Rename.Utils (wrapGenSpan) +import GHC.Utils.Misc +import GHC.Driver.DynFlags ( getDynFlags, xopt_FieldSelectors ) + +import qualified GHC.LanguageExtensions as LangExt + +import Data.Maybe( mapMaybe ) +import Control.Monad ( zipWithM ) +import Data.List( partition, mapAccumL ) +import Data.List.NonEmpty (NonEmpty, nonEmpty) + +{- +************************************************************************ +* * + Type checking a pattern synonym +* * +************************************************************************ +-} + +tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn) + -> TcSigFun + -> TcPragEnv -- See Note [Pragmas for pattern synonyms] + -> TcM (LHsBinds GhcTc, TcGblEnv) +tcPatSynDecl (L loc psb@(PSB { psb_id = L _ name })) sig_fn prag_fn + = setSrcSpanA loc $ + addErrCtxt (PatSynDeclCtxt name) $ + case sig_fn name of + Nothing -> tcInferPatSynDecl psb prag_fn + Just (TcPatSynSig patsig) -> tcCheckPatSynDecl psb patsig prag_fn + _ -> panic "tcPatSynDecl" + +{- Note [Pattern synonym error recovery] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If type inference for a pattern synonym fails, we can't continue with +the rest of tc_patsyn_finish, because we may get knock-on errors, or +even a crash. E.g. from + pattern What = True :: Maybe +we get a kind error; and we must stop right away (#15289). + +We stop if there are /any/ unsolved constraints, not just insoluble +ones; because pattern synonyms are top-level things, we will never +solve them later if we can't solve them now. And if we were to carry +on, tc_patsyn_finish does zonkTcTypeToType, which defaults any +unsolved unification variables to Any, which confuses the error +reporting no end (#15685). + +So we use simplifyTop to completely solve the constraint, report +any errors, throw an exception. + +Unlike for value bindings, we don't create a placeholder pattern +synonym binding in an attempt to recover from the error, as this placeholder +was occasionally the cause of strange follow-up errors to occur, as reported in #23467. +It seems rather difficult to come up with a satisfactory placeholder: + + - it would need to have the right number of arguments, + with the appropriate field names (if any), + - we could give each argument the type `forall a. a`; this would generally + work OK in pattern occurrences of the PatSyn, but not so in expressions, + e.g. "let x = Con y" would require (y :: forall a. a) which would cause + confusing errors. + +So, for now at least, we don't attempt to recover at all. +-} + +tcInferPatSynDecl :: PatSynBind GhcRn GhcRn + -> TcPragEnv + -> TcM (LHsBinds GhcTc, TcGblEnv) +tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details + , psb_def = lpat, psb_dir = dir }) + prag_fn + = do { traceTc "tcInferPatSynDecl {" $ ppr name + + ; let (arg_names, is_infix) = collectPatSynArgInfo details + ; (tclvl, wanted, ((lpat', args), pat_ty)) + <- pushLevelAndCaptureConstraints $ + tcInferPat FRRPatSynArg PatSyn lpat $ + mapM tcLookupId arg_names + + ; let (ex_tvs, prov_dicts) = tcCollectEx lpat' + + named_taus = (name, pat_ty) : map mk_named_tau args + mk_named_tau arg + = (getName arg, mkSpecForAllTys ex_tvs (varType arg)) + -- The mkSpecForAllTys is important (#14552), albeit + -- slightly artificial (there is no variable with this funny type). + -- We do not want to quantify over variable (alpha::k) + -- that mention the existentially-bound type variables + -- ex_tvs in its kind k. + -- See Note [Type variables whose kind is captured] + + ; ((univ_tvs, req_dicts, ev_binds, _), residual) + <- captureConstraints $ + simplifyInfer TopLevel tclvl NoRestrictions [] named_taus wanted + ; top_ev_binds <- checkNoErrs (simplifyTop residual) + ; addTopEvBinds top_ev_binds $ + + do { prov_dicts <- liftZonkM $ mapM zonkId prov_dicts + ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts + -- Filtering: see Note [Remove redundant provided dicts] + (prov_theta, prov_evs) + = unzip (mapMaybe mkProvEvidence filtered_prov_dicts) + req_theta = map evVarPred req_dicts + + -- Report coercions that escape + -- See Note [Coercions that escape] + ; args <- liftZonkM $ mapM zonkId args + ; let bad_arg arg = fmap (\bad_cos -> (arg, bad_cos)) $ + nonEmpty $ + dVarSetElems $ + filterDVarSet isId (tyCoVarsOfTypeDSet (idType arg)) + bad_args = mapMaybe bad_arg (args ++ prov_dicts) + ; mapM_ dependentArgErr bad_args + + -- Report un-quantifiable type variables: + -- see Note [Unquantified tyvars in a pattern synonym] + ; dvs <- candidateQTyVarsOfTypes prov_theta + ; let err_ctx tidy_env + = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env prov_theta + ; return ( tidy_env2, UninfTyCtx_ProvidedContext theta ) } + ; doNotQuantifyTyVars dvs err_ctx + + ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) + ; rec_fields <- lookupConstructorFields $ noUserRdr name + ; tc_patsyn_finish lname dir is_infix lpat' prag_fn + (mkTyVarBinders InferredSpec univ_tvs + , req_theta, ev_binds, req_dicts) + (mkTyVarBinders InferredSpec ex_tvs + , mkTyVarTys ex_tvs, prov_theta, prov_evs) + (map nlHsVar args, map idType args) + pat_ty rec_fields } } + +mkProvEvidence :: EvId -> Maybe (PredType, EvTerm) +-- See Note [Equality evidence in pattern synonyms] +mkProvEvidence ev_id + | EqPred r ty1 ty2 <- classifyPredType pred + , let k1 = typeKind ty1 + k2 = typeKind ty2 + is_homo = k1 `tcEqType` k2 + homo_tys = [k1, ty1, ty2] + hetero_tys = [k1, k2, ty1, ty2] + = case r of + ReprEq | is_homo + -> Just ( mkClassPred coercibleClass homo_tys + , evDictApp coercibleClass homo_tys eq_con_args ) + | otherwise -> Nothing + NomEq | is_homo + -> Just ( mkClassPred eqClass homo_tys + , evDictApp eqClass homo_tys eq_con_args ) + | otherwise + -> Just ( mkClassPred heqClass hetero_tys + , evDictApp heqClass hetero_tys eq_con_args ) + + | otherwise + = Just (pred, EvExpr (evId ev_id)) + where + pred = evVarPred ev_id + eq_con_args = [evId ev_id] + +dependentArgErr :: (Id, NonEmpty CoVar) -> TcM () +-- See Note [Coercions that escape] +dependentArgErr (arg, bad_cos) + = failWithTc $ -- fail here: otherwise we get downstream errors + TcRnPatSynEscapedCoercion arg bad_cos + +{- Note [Type variables whose kind is captured] +~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data AST a = Sym [a] + class Prj s where { prj :: [a] -> Maybe (s a) } + pattern P x <= Sym (prj -> Just x) + +Here we get a matcher with this type + $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r + +No problem. But note that 's' is not fixed by the type of the +pattern (AST a), nor is it existentially bound. It's really only +fixed by the type of the continuation. + +#14552 showed that this can go wrong if the kind of 's' mentions +existentially bound variables. We obviously can't make a type like + $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r) + -> r -> r +But neither is 's' itself existentially bound, so the forall (s::k->*) +can't go in the inner forall either. (What would the matcher apply +the continuation to?) + +Solution: do not quantify over any unification variable whose kind +mentions the existentials. We can conveniently do that by making the +"taus" passed to simplifyInfer look like + forall ex_tvs. arg_ty + +After that, Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType takes +over and errors. + +Note [Remove redundant provided dicts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall that + HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2) + => a1 :~~: a2 +(NB: technically the (k1~k2) existential dictionary is not necessary, +but it's there at the moment.) + +Now consider (#14394): + pattern Foo = HRefl +in a non-poly-kinded module. We don't want to get + pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b +with that redundant (* ~ *). We'd like to remove it; hence the call to +mkMinimalWithSCs. + +Similarly consider + data S a where { MkS :: Ord a => a -> S a } + pattern Bam x y <- (MkS (x::a), MkS (y::a))) + +The pattern (Bam x y) binds two (Ord a) dictionaries, but we only +need one. Again mkMimimalWithSCs removes the redundant one. + +Note [Equality evidence in pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data X a where + MkX :: Eq a => [a] -> X (Maybe a) + pattern P x = MkG x + +Then there is a danger that GHC will infer + P :: forall a. () => + forall b. (a ~# Maybe b, Eq b) => [b] -> X a + +The 'builder' for P, which is called in user-code, will then +have type + $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a + +and that is bad because (a ~# Maybe b) is not a predicate type +(see Note [Types for coercions, predicates, and evidence] in GHC.Core.Predicate +and is not implicitly instantiated. + +So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and +marginally less efficient, if the builder/matcher are not inlined. + +See also Note [Lift equality constraints when quantifying] in GHC.Tc.Solver + +Note [Coercions that escape] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#14507 showed an example where the inferred type of the matcher +for the pattern synonym was something like + $mSO :: forall (r :: TYPE rep) kk (a :: k). + TypeRep k a + -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r) + -> (Void# -> r) + -> r + +What is that co_a2sv :: Bool ~# *?? It was bound (via a superclass +selection) by the pattern being matched; and indeed it is implicit in +the context (Bool ~ k). You could imagine trying to extract it like +this: + $mSO :: forall (r :: TYPE rep) kk (a :: k). + TypeRep k a + -> ( co :: ((Bool :: *) ~ (k :: *)) => + let co_a2sv = sc_sel co + in TypeRep Bool (a |> co_a2sv) -> r) + -> (Void# -> r) + -> r + +But we simply don't allow that in types. Maybe one day but not now. + +How to detect this situation? We just look for free coercion variables +in the types of any of the arguments to the matcher. The error message +is not very helpful, but at least we don't get a Lint error. + +Note [Unquantified tyvars in a pattern synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#21479) + + data T a where MkT :: Int -> T Char -- A GADT + foo :: forall b. Bool -> T b -- Somewhat strange type + + pattern T1 <- (foo -> MkT) + +In the view pattern, foo is instantiated, let's say b :-> b0 +where b0 is a unification variable. Then matching the GADT +MkT will add the "provided" constraint b0~Char, so we might infer + pattern T1 :: () => (b0~Char) => Int -> Bool + +Nothing constrains that `b0`. We don't want to quantify over it. +We don't want to to zonk to Any (we don't like Any showing up in +user-visible types). So we want to error here. See +Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + +Hence the call to doNotQuantifyTyVars here. +-} + +tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn + -> TcPatSynSig + -> TcPragEnv + -> TcM (LHsBinds GhcTc, TcGblEnv) +tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details + , psb_def = lpat, psb_dir = dir } + PatSig{ patsig_implicit_bndrs = implicit_bndrs + , patsig_univ_bndrs = explicit_univ_bndrs, patsig_req = req_theta + , patsig_ex_bndrs = explicit_ex_bndrs, patsig_prov = prov_theta + , patsig_body_ty = sig_body_ty } + prag_fn + = do { traceTc "tcCheckPatSynDecl" $ + vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta + , ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ] + + ; let decl_arity = length arg_names + (arg_names, is_infix) = collectPatSynArgInfo details + + ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of + Right stuff -> return stuff + Left missing -> wrongNumberOfParmsErr name decl_arity missing + + -- Complain about: pattern P :: () => forall x. x -> P x + -- The existential 'x' should not appear in the result type + -- Can't check this until we know P's arity (decl_arity above) + ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs + ; checkTc (null bad_tvs) $ TcRnPatSynExistentialInResult name pat_ty bad_tvs + + -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig + ; let univ_fvs = closeOverKinds $ + (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` (binderVars explicit_univ_bndrs)) + (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_bndrs + univ_bndrs = extra_univ ++ explicit_univ_bndrs + ex_bndrs = extra_ex ++ explicit_ex_bndrs + univ_tvs = binderVars univ_bndrs + ex_tvs = binderVars ex_bndrs + + -- Pattern synonyms currently cannot be linear (#18806) + ; checkTc (all (isManyTy . scaledMult) arg_tys) $ + TcRnLinearPatSyn sig_body_ty + + ; skol_info <- mkSkolemInfo (SigSkol (PatSynCtxt name) pat_ty []) + -- The type here is a bit bogus, but we do not print + -- the type for PatSynCtxt, so it doesn't matter + -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin" + + -- Skolemise the quantified type variables. This is necessary + -- in order to check the actual pattern type against the + -- expected type. Even though the tyvars in the type are + -- already skolems, this step changes their TcLevels, + -- avoiding level-check errors when unifying. + ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX skol_info emptySubst univ_bndrs + ; (skol_subst, skol_ex_bndrs) <- skolemiseTvBndrsX skol_info skol_subst0 ex_bndrs + ; let skol_univ_tvs = binderVars skol_univ_bndrs + skol_ex_tvs = binderVars skol_ex_bndrs + skol_req_theta = substTheta skol_subst0 req_theta + skol_prov_theta = substTheta skol_subst prov_theta + skol_arg_tys = substTys skol_subst (map scaledThing arg_tys) + skol_pat_ty = substTy skol_subst pat_ty + + univ_tv_prs = [ (getName orig_univ_tv, skol_univ_tv) + | (orig_univ_tv, skol_univ_tv) <- univ_tvs `zip` skol_univ_tvs ] + + -- Right! Let's check the pattern against the signature + -- See Note [Checking against a pattern signature] + ; req_dicts <- newEvVars skol_req_theta + ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <- + assertPpr (equalLength arg_names arg_tys) (ppr name $$ ppr arg_names $$ ppr arg_tys) $ + pushLevelAndCaptureConstraints $ + tcExtendNameTyVarEnv univ_tv_prs $ + tcCheckPat PatSyn lpat (unrestricted skol_pat_ty) $ + do { let in_scope = mkInScopeSetList skol_univ_tvs + empty_subst = mkEmptySubst in_scope + ; (inst_subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst skol_ex_tvs + -- newMetaTyVarX: see the "Existential type variables" + -- part of Note [Checking against a pattern signature] + ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs]) + ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs']) + ; let prov_theta' = substTheta inst_subst skol_prov_theta + -- Add univ_tvs to the in_scope set to + -- satisfy the substitution invariant. There's no need to + -- add 'ex_tvs' as they are already in the domain of the + -- substitution. + -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. + ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta' + ; args' <- zipWithM (tc_arg inst_subst) arg_names + skol_arg_tys + ; return (ex_tvs', prov_dicts, args') } + + ; (implics, ev_binds) <- buildImplicationFor tclvl (getSkolemInfo skol_info) skol_univ_tvs + req_dicts wanted + + -- Solve the constraints now, because we are about to make a PatSyn, + -- which should not contain unification variables and the like (#10997) + ; simplifyTopImplic implics + + -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct + -- Otherwise we may get a type error when typechecking the builder, + -- when that should be impossible + + ; traceTc "tcCheckPatSynDecl }" $ ppr name + + ; rec_fields <- lookupConstructorFields $ noUserRdr name + ; tc_patsyn_finish lname dir is_infix lpat' prag_fn + (skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts) + (skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts) + (args', skol_arg_tys) + skol_pat_ty rec_fields } + where + tc_arg :: Subst -> Name -> Type -> TcM (LHsExpr GhcTc) + -- Look up the variable actually bound by lpat + -- and check that it has the expected type + tc_arg subst arg_name arg_ty + = setSrcSpan (nameSrcSpan arg_name) $ + -- Set the SrcSpan to be the binding site of the Id (#18856) + -- e.g. pattern P :: Int -> Maybe (Int,Bool) + -- pattern P x = Just (x,True) + -- Before unifying x's actual type with its expected type, in tc_arg, set + -- location to x's binding site in lpat, namely the 'x' in Just (x,True). + -- Else the error message location is wherever tcCheckPat finished, + -- namely the right-hand corner of the pattern + do { arg_id <- tcLookupId arg_name + ; wrap <- tcSubTypeSigma (OccurrenceOf (idName arg_id)) + GenSigCtxt + (idType arg_id) + (substTy subst arg_ty) + -- Why do we need tcSubType here? + -- See Note [Pattern synonyms and higher rank types] + ; return (mkLHsWrap wrap $ nlHsVar arg_id) } + +skolemiseTvBndrsX :: SkolemInfo -> Subst -> [VarBndr TyVar flag] + -> TcM (Subst, [VarBndr TcTyVar flag]) +-- Make new TcTyVars, all skolems with levels, but do not clone +-- The level is one level deeper than the current level +-- See Note [Skolemising when checking a pattern synonym] +skolemiseTvBndrsX skol_info orig_subst tvs + = do { tc_lvl <- getTcLevel + ; let pushed_lvl = pushTcLevel tc_lvl + details = SkolemTv skol_info pushed_lvl False + + mk_skol_tv_x :: Subst -> VarBndr TyVar flag + -> (Subst, VarBndr TcTyVar flag) + mk_skol_tv_x subst (Bndr tv flag) + = (subst', Bndr new_tv flag) + where + new_kind = substTyUnchecked subst (tyVarKind tv) + new_tv = mkTcTyVar (tyVarName tv) new_kind details + subst' = extendTvSubstWithClone subst tv new_tv + + ; return (mapAccumL mk_skol_tv_x orig_subst tvs) } + +{- Note [Skolemising when checking a pattern synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + pattern P1 :: forall a. a -> Maybe a + pattern P1 x <- Just x where + P1 x = Just (x :: a) + +The scoped type variable 'a' scopes over the builder RHS, Just (x::a). +But the builder RHS is typechecked much later in tcPatSynBuilderBind, +and gets its scoped type variables from the type of the builder_id. +The easiest way to achieve this is not to clone when skolemising. + +Hence a special-purpose skolemiseTvBndrX here, similar to +GHC.Tc.Utils.Instantiate.tcInstSkolTyVarsX except that the latter +does cloning. + +Note [Pattern synonyms and higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT (forall a. a->a) + + pattern P :: (Int -> Int) -> T + pattern P x <- MkT x + +This should work. But in the matcher we must match against MkT, and then +instantiate its argument 'x', to get a function of type (Int -> Int). +Equality is not enough! #13752 was an example. + + +Note [The pattern-synonym signature splitting rule] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a pattern signature, we must split + the kind-generalised variables, and + the implicitly-bound variables +into universal and existential. The rule is this +(see discussion on #11224): + + The universal tyvars are the ones mentioned in + - univ_tvs: the user-specified (forall'd) universals + - req_theta + - res_ty + The existential tyvars are all the rest + +For example + + pattern P :: () => b -> T a + pattern P x = ... + +Here 'a' is universal, and 'b' is existential. But there is a wrinkle: +how do we split the arg_tys from req_ty? Consider + + pattern Q :: () => b -> S c -> T a + pattern Q x = ... + +This is an odd example because Q has only one syntactic argument, and +so presumably is defined by a view pattern matching a function. But +it can happen (#11977, #12108). + +We don't know Q's arity from the pattern signature, so we have to wait +until we see the pattern declaration itself before deciding res_ty is, +and hence which variables are existential and which are universal. + +And that in turn is why TcPatSynSig has a separate field, +patsig_implicit_bndrs, to capture the implicitly bound type variables, +because we don't yet know how to split them up. + +It's a slight compromise, because it means we don't really know the +pattern synonym's real signature until we see its declaration. So, +for example, in hs-boot file, we may need to think what to do... +(eg don't have any implicitly-bound variables). + + +Note [Checking against a pattern signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When checking the actual supplied pattern against the pattern synonym +signature, we need to be quite careful. + +----- Provided constraints +Example + + data T a where + MkT :: Ord a => a -> T a + + pattern P :: () => Eq a => a -> [T a] + pattern P x = [MkT x] + +We must check that the (Eq a) that P claims to bind (and to +make available to matches against P), is derivable from the +actual pattern. For example: + f (P (x::a)) = ...here (Eq a) should be available... +And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs. + +----- Existential type variables +Unusually, we instantiate the existential tyvars of the pattern with +*meta* type variables. For example + + data S where + MkS :: Eq a => [a] -> S + + pattern P :: () => Eq x => x -> S + pattern P x <- MkS x + +The pattern synonym conceals from its client the fact that MkS has a +list inside it. The client just thinks it's a type 'x'. So we must +unify x := [a] during type checking, and then use the instantiating type +[a] (called ex_tys) when building the matcher. In this case we'll get + + $mP :: S -> (forall x. Ex x => x -> r) -> r -> r + $mP x k = case x of + MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a] + dl = $dfunEqList d + in k [a] dl ys + +All this applies when type-checking the /matching/ side of +a pattern synonym. What about the /building/ side? + +* For Unidirectional, there is no builder + +* For ExplicitBidirectional, the builder is completely separate + code, typechecked in tcPatSynBuilderBind + +* For ImplicitBidirectional, the builder is still typechecked in + tcPatSynBuilderBind, by converting the pattern to an expression and + typechecking it. + + At one point, for ImplicitBidirectional I used TyVarTvs (instead of + TauTvs) in tcCheckPatSynDecl. But (a) strengthening the check here + is redundant since tcPatSynBuilderBind does the job, (b) it was + still incomplete (TyVarTvs can unify with each other), and (c) it + didn't even work (#13441 was accepted with + ExplicitBidirectional, but rejected if expressed in + ImplicitBidirectional form. Conclusion: trying to be too clever is + a bad idea. +-} + +collectPatSynArgInfo :: HsPatSynDetails GhcRn + -> ([Name], Bool) +collectPatSynArgInfo details = + case details of + PrefixCon names -> (map unLoc names, False) + InfixCon name1 name2 -> (map unLoc [name1, name2], True) + RecCon names -> (map (unLoc . recordPatSynPatVar) names, False) + +wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a +wrongNumberOfParmsErr name decl_arity missing + = failWithTc $ TcRnPatSynArityMismatch name decl_arity missing + +------------------------- +-- Shared by both tcInferPatSyn and tcCheckPatSyn +tc_patsyn_finish :: LocatedN Name -- ^ PatSyn Name + -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) + -> Bool -- ^ Whether infix + -> LPat GhcTc -- ^ Pattern of the PatSyn + -> TcPragEnv + -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar]) + -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm]) + -> ([LHsExpr GhcTc], [TcTypeFRR]) + -- ^ Pattern arguments and types. + -- These must have a syntactically fixed RuntimeRep as per + -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. + -> TcType -- ^ Pattern type + -> [FieldLabel] -- ^ Selector names + -- ^ Whether fields, empty if not record PatSyn + -> TcM (LHsBinds GhcTc, TcGblEnv) +tc_patsyn_finish lname dir is_infix lpat' prag_fn + (univ_tvs, req_theta, req_ev_binds, req_dicts) + (ex_tvs, ex_tys, prov_theta, prov_dicts) + (args, arg_tys) + pat_ty field_labels + = do { -- Zonk everything. We are about to build a final PatSyn + -- so there had better be no unification variables in there + + (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, pat_ty) <- + initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX univ_tvs) $ \ univ_tvs' -> + do { req_theta' <- zonkTcTypesToTypesX req_theta + ; runZonkBndrT (zonkTyVarBindersX ex_tvs) $ \ ex_tvs' -> + do { prov_theta' <- zonkTcTypesToTypesX prov_theta + ; pat_ty' <- zonkTcTypeToTypeX pat_ty + ; arg_tys' <- zonkTcTypesToTypesX arg_tys + + ; let (env1, univ_tvs) = tidyForAllTyBinders emptyTidyEnv univ_tvs' + (env2, ex_tvs) = tidyForAllTyBinders env1 ex_tvs' + req_theta = tidyTypes env2 req_theta' + prov_theta = tidyTypes env2 prov_theta' + arg_tys = tidyTypes env2 arg_tys' + pat_ty = tidyType env2 pat_ty' + + ; return (univ_tvs, req_theta, + ex_tvs, prov_theta, arg_tys, pat_ty) } } + + ; traceTc "tc_patsyn_finish {" $ + ppr (unLoc lname) $$ ppr (unLoc lpat') $$ + ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ + ppr (ex_tvs, prov_theta, prov_dicts) $$ + ppr args $$ + ppr arg_tys $$ + ppr pat_ty + + -- Make the 'matcher' + ; (matcher, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn + (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) + (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) + (args, arg_tys) + pat_ty + + -- Make the 'builder' + ; builder <- mkPatSynBuilder dir lname + univ_tvs req_theta + ex_tvs prov_theta + arg_tys pat_ty + + -- Make the PatSyn itself + ; let patSyn = mkPatSyn (unLoc lname) is_infix + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + arg_tys + pat_ty + matcher builder + field_labels + + -- Selectors + ; has_sel <- xopt_FieldSelectors <$> getDynFlags + ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) has_sel + tything = AConLike (PatSynCon patSyn) + ; tcg_env <- tcExtendGlobalEnv [tything] $ + tcRecSelBinds rn_rec_sel_binds + + ; traceTc "tc_patsyn_finish }" empty + ; return (matcher_bind, tcg_env) } + +{- +************************************************************************ +* * + Constructing the "matcher" Id and its binding +* * +************************************************************************ +-} + +tcPatSynMatcher :: LocatedN Name + -> LPat GhcTc + -> TcPragEnv + -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) + -> ([TcTyVar], [TcType], ThetaType, [EvTerm]) + -> ([LHsExpr GhcTc], [TcType]) + -> TcType + -> TcM (PatSynMatcher, LHsBinds GhcTc) +-- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn +tcPatSynMatcher (L loc ps_name) lpat prag_fn + (univ_tvs, req_theta, req_ev_binds, req_dicts) + (ex_tvs, ex_tys, prov_theta, prov_dicts) + (args, arg_tys) pat_ty + = do { let loc' = locA loc + ; rr_name <- newNameAt (mkTyVarOccFS (fsLit "rep")) loc' + ; tv_name <- newNameAt (mkTyVarOccFS (fsLit "r")) loc' + ; let rr_tv = mkTyVar rr_name runtimeRepTy + rr = mkTyVarTy rr_tv + res_tv = mkTyVar tv_name (mkTYPEapp rr) + res_ty = mkTyVarTy res_tv + is_unlifted = null args && null prov_dicts + (cont_args, cont_arg_tys) + | is_unlifted = ([nlHsDataCon unboxedUnitDataCon], [unboxedUnitTy]) + | otherwise = (args, arg_tys) + cont_ty = mkInfSigmaTy ex_tvs prov_theta $ + mkVisFunTysMany cont_arg_tys res_ty + + fail_ty = mkVisFunTyMany unboxedUnitTy res_ty + + ; matcher_name <- newImplicitBinder ps_name mkMatcherOcc + ; scrutinee <- newSysLocalId (fsLit "scrut") ManyTy pat_ty + ; cont <- newSysLocalId (fsLit "cont") ManyTy cont_ty + ; fail <- newSysLocalId (fsLit "fail") ManyTy fail_ty + + ; is_strict <- xoptM LangExt.Strict + ; comps <- getCompleteMatchesTcM + ; let matcher_tau = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty + matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau + matcher_id = mkExportedVanillaId matcher_name matcher_sigma + patsyn_id = mkExportedVanillaId ps_name matcher_sigma + -- See Note [Exported LocalIds] in GHC.Types.Id + + inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys + cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args + + fail' = nlHsApps fail [nlHsDataCon unboxedUnitDataCon] + + args = noLocA $ map nlVarPat [scrutinee, cont, fail] + lwpat = noLocA $ WildPat pat_ty + cases = if isIrrefutableHsPat is_strict (irrefutableConLikeTc comps) lpat + then [mkHsCaseAlt lpat cont'] + else [mkHsCaseAlt lpat cont', + mkHsCaseAlt lwpat fail'] + gen = Generated OtherExpansion SkipPmc + body = mkLHsWrap (mkWpLet req_ev_binds) $ + L (getLoc lpat) $ + HsCase PatSyn (nlHsVar scrutinee) $ + MG{ mg_alts = L (l2l $ getLoc lpat) cases + , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty gen + } + body' = noLocA $ + HsLam noAnn LamSingle $ + MG{ mg_alts = noLocA [mkSimpleMatch (LamAlt LamSingle) + args + body] + , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty gen + } + match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id)) noAnn) (noLocA []) + (mkHsLams (rr_tv:res_tv:univ_tvs) + req_dicts body') + (EmptyLocalBinds noExtField) + mg :: MatchGroup GhcTc (LHsExpr GhcTc) + mg = MG{ mg_alts = L (l2l $ getLoc match) [match] + , mg_ext = MatchGroupTc [] res_ty gen + } + matcher_arity = length req_theta + 3 + -- See Note [Pragmas for pattern synonyms] + + -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms] + -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) matcher name + ; matcher_prag_id <- addInlinePrags matcher_id $ + map (addInlinePragArity matcher_arity) $ + lookupPragEnv prag_fn ps_name + + ; let bind = FunBind{ fun_id = L loc matcher_prag_id + , fun_matches = mg + , fun_ext = (idHsWrapper, []) + } + matcher_bind = [noLocA bind] + ; traceTc "tcPatSynMatcher" (ppr ps_name $$ ppr (idType matcher_id)) + ; traceTc "tcPatSynMatcher" (ppr matcher_bind) + + ; return ((matcher_name, matcher_sigma, is_unlifted), matcher_bind) } + +mkPatSynRecSelBinds :: PatSyn + -> [FieldLabel] -- ^ Visible field labels + -> FieldSelectors + -> [(Id, LHsBind GhcRn)] +mkPatSynRecSelBinds ps fields has_sel + = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel + | fld_lbl <- fields ] + +isUnidirectional :: HsPatSynDir a -> Bool +isUnidirectional Unidirectional = True +isUnidirectional ImplicitBidirectional = False +isUnidirectional ExplicitBidirectional{} = False + +{- +************************************************************************ +* * + Constructing the "builder" Id +* * +************************************************************************ +-} + +mkPatSynBuilder :: HsPatSynDir a -> LocatedN Name + -> [InvisTVBinder] -> ThetaType + -> [InvisTVBinder] -> ThetaType + -> [Type] -> Type + -> TcM PatSynBuilder +mkPatSynBuilder dir (L _ name) + univ_bndrs req_theta ex_bndrs prov_theta + arg_tys pat_ty + | isUnidirectional dir + = return Nothing + | otherwise + = do { builder_name <- newImplicitBinder name mkBuilderOcc + ; let theta = req_theta ++ prov_theta + need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta + -- NB: pattern arguments cannot be representation-polymorphic, + -- as checked in 'tcPatSynSig'. So 'isUnliftedType' is OK here. + builder_sigma = add_void need_dummy_arg $ + mkInvisForAllTys univ_bndrs $ + mkInvisForAllTys ex_bndrs $ + mkPhiTy theta $ + mkVisFunTysMany arg_tys $ + pat_ty + + ; return (Just (builder_name, builder_sigma, need_dummy_arg)) } + +tcPatSynBuilderBind :: TcPragEnv + -> PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc) +-- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn +tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) + , psb_def = lpat + , psb_dir = dir + , psb_args = details }) + | isUnidirectional dir + = return [] + + | Left why <- mb_match_group -- Can't invert the pattern + = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnPatSynInvalidRhs ps_name lpat args why + + | Right match_group <- mb_match_group -- Bidirectional + = do { patsyn <- tcLookupPatSyn ps_name + ; case patSynBuilder patsyn of { + Nothing -> return [] ; + -- This case happens if we found a type error in the + -- pattern synonym, recovered, and put a placeholder + -- with patSynBuilder=Nothing in the environment + + Just (builder_name, builder_ty, need_dummy_arg) -> -- Normal case + do { -- Bidirectional, so patSynBuilder returns Just + let builder_id = mkExportedVanillaId builder_name builder_ty + -- See Note [Exported LocalIds] in GHC.Types.Id + + (_, req_theta, _, prov_theta, arg_tys, _) = patSynSigBndr patsyn + builder_arity = length req_theta + length prov_theta + + length arg_tys + + (if need_dummy_arg then 1 else 0) + + -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms] + -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) builder name + ; builder_id <- addInlinePrags builder_id $ + map (addInlinePragArity builder_arity) $ + lookupPragEnv prag_fn ps_name + + ; let match_group' | need_dummy_arg = add_dummy_arg match_group + | otherwise = match_group + + bind = FunBind { fun_id = L loc (idName builder_id) + , fun_matches = match_group' + , fun_ext = emptyNameSet + } + + sig = completeSigFromId (PatSynCtxt ps_name) builder_id + + ; traceTc "tcPatSynBuilderBind {" $ + vcat [ ppr patsyn + , ppr builder_id <+> dcolon <+> ppr (idType builder_id) ] + ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind) + ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds + ; return builder_binds } } } + + where + mb_match_group + = case dir of + ExplicitBidirectional explicit_mg -> Right explicit_mg + ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat) + Unidirectional -> panic "tcPatSynBuilderBind" + + mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) + mk_mg body = mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [builder_match]) + where + builder_args = noLocA [(L (l2l loc) (VarPat noExtField (L loc n))) + | L loc n <- args] + builder_match = mkMatch (mkPrefixFunRhs ps_lname noAnn) + builder_args body + (EmptyLocalBinds noExtField) + + args = case details of + PrefixCon args -> args + InfixCon arg1 arg2 -> [arg1, arg2] + RecCon args -> map recordPatSynPatVar args + + add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) + -> MatchGroup GhcRn (LHsExpr GhcRn) + add_dummy_arg mg@(MG { mg_alts = + (L l [L loc match@(Match { m_pats = L lp pats })]) }) + = mg { mg_alts = L l [L loc (match { m_pats = L lp $ nlWildPatName : pats })] } + add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ + pprMatches other_mg + +patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType) +patSynBuilderOcc ps + | Just (_, builder_ty, add_void_arg) <- patSynBuilder ps + , let builder_expr = mkConLikeTc (PatSynCon ps) + = Just $ + if add_void_arg + then ( builder_expr -- still just return builder_expr; the void# arg + -- is added by dsConLike in the desugarer + , tcFunResultTy builder_ty ) + else (builder_expr, builder_ty) + + | otherwise -- Unidirectional + = Nothing + +add_void :: Bool -> Type -> Type +add_void need_dummy_arg ty + | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty + | otherwise = ty + +tcPatToExpr :: [LocatedN Name] -> LPat GhcRn + -> Either PatSynInvalidRhsReason (LHsExpr GhcRn) +-- Given a /pattern/, return an /expression/ that builds a value +-- that matches the pattern. E.g. if the pattern is (Just [x]), +-- the expression is (Just [x]). They look the same, but the +-- input uses constructors from HsPat and the output uses constructors +-- from HsExpr. +-- +-- Returns (Left r) if the pattern is not invertible, for reason r. +-- See Note [Builder for a bidirectional pattern synonym] +tcPatToExpr args pat = go pat + where + lhsVars = mkNameSet (map unLoc args) + + -- Make a prefix con for prefix and infix patterns for simplicity + mkPrefixConExpr :: LocatedN (WithUserRdr Name) + -> [LPat GhcRn] + -> Either PatSynInvalidRhsReason (HsExpr GhcRn) + mkPrefixConExpr lcon@(L loc _) pats + = do { exprs <- mapM go pats + ; let con = L (l2l loc) (HsVar noExtField lcon) + ; return (unLoc $ mkHsApps con exprs) + } + + mkRecordConExpr :: LocatedN (WithUserRdr Name) + -> HsRecFields GhcRn (LPat GhcRn) + -> Either PatSynInvalidRhsReason (HsExpr GhcRn) + mkRecordConExpr con (HsRecFields x fields dd) + = do { exprFields <- mapM go' fields + ; return (RecordCon noExtField con (HsRecFields x exprFields dd)) } + + go' :: LHsRecField GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn)) + go' (L l rf) = L l <$> traverse go rf + + go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn) + go (L loc p) = L loc <$> go1 p + + go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn) + go1 (ConPat NoExtField con info) + = case info of + PrefixCon ps -> mkPrefixConExpr con ps + InfixCon l r -> mkPrefixConExpr con [l,r] + RecCon fields -> mkRecordConExpr con fields + + go1 (SigPat _ pat _) = go1 (unLoc pat) + -- See Note [Type signatures and the builder expression] + + go1 (VarPat _ (L l var)) + | var `elemNameSet` lhsVars + = return $ mkHsVar (L l var) + | otherwise + = Left (PatSynUnboundVar var) + go1 (ParPat _ pat) = fmap (HsPar noExtField) (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 noExtField) exprs) box } + go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) + ; return $ ExplicitSum noExtField alt arity + (noLocA expr) + } + go1 (LitPat _ lit) = return $ HsLit noExtField lit + go1 (NPat _ (L _ n) mb_neg _) + | Just (SyntaxExprRn neg) <- mb_neg + = return $ unLoc $ foldl' nlHsApp (noLocA neg) + [noLocA (HsOverLit noExtField n)] + | otherwise = return $ HsOverLit noExtField n + go1 (SplicePat (HsUntypedSpliceTop _ pat) _) = go1 pat + go1 (SplicePat (HsUntypedSpliceNested _) _) = panic "tcPatToExpr: invalid nested splice" + go1 (EmbTyPat _ tp) = return $ HsEmbTy noExtField (hstp_to_hswc tp) + where hstp_to_hswc :: HsTyPat GhcRn -> LHsWcType GhcRn + hstp_to_hswc (HsTP { hstp_ext = HsTPRn { hstp_nwcs = wcs }, hstp_body = hs_ty }) + = HsWC { hswc_ext = wcs, hswc_body = hs_ty } + go1 (InvisPat _ _tp) = panic "tcPatToExpr: invalid invisible pattern" + 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 noExtField (wrapGenSpan inverse) (wrapGenSpan expr)) + (go1 (unLoc pat)) + + -- The following patterns are not invertible. + go1 p@(BangPat {}) = notInvertible p -- #14112 + go1 p@(LazyPat {}) = notInvertible p + go1 p@(WildPat {}) = notInvertible p + go1 p@(AsPat {}) = notInvertible p + go1 p@(NPlusKPat {}) = notInvertible p + go1 p@(OrPat {}) = notInvertible p + + notInvertible p = Left (PatSynNotInvertible p) + +{- Note [Builder for a bidirectional pattern synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a bidirectional pattern synonym, the function 'tcPatToExpr' +needs to produce an /expression/ that matches the supplied /pattern/, +given values for the arguments of the pattern synonym. For example: + pattern F x y = (Just x, [y]) +The 'builder' for F looks like + $builderF x y = (Just x, [y]) + +We can't always do this: + * Some patterns aren't invertible; e.g. general view patterns + pattern F x = (f -> x) + as we don't have the ability to write down an expression that matches + the view pattern specified by an arbitrary view function `f`. + It is however sometimes possible to write down an inverse; + see Note [Invertible view patterns]. + + * The RHS pattern might bind more variables than the pattern + synonym, so again we can't invert it + pattern F x = (x,y) + + * Ditto wildcards + pattern F x = (x,_) + +Note [Invertible view patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some view patterns, such as those that arise from expansion of overloaded +patterns (as detailed in Note [Handling overloaded and rebindable patterns]), +we are able to explicitly write out an inverse (in the sense of the previous +Note [Builder for a bidirectional pattern synonym]). +For instance, the inverse to the pattern + + (toList -> [True, False]) + +is the expression + + (fromListN 2 [True,False]) + +Keeping track of the inverse for such view patterns fixed #14380. + +Note [Redundant constraints for builder] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The builder can have redundant constraints, which are awkward to eliminate. +Consider + pattern P = Just 34 +To match against this pattern we need (Eq a, Num a). But to build +(Just 34) we need only (Num a). Fortunately instTcSigFromId sets +sig_warn_redundant to False. + +************************************************************************ +* * + Helper functions +* * +************************************************************************ + +Note [As-patterns in pattern synonym definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rationale for rejecting as-patterns in pattern synonym definitions +is that an as-pattern would introduce nonindependent pattern synonym +arguments, e.g. given a pattern synonym like: + + pattern K x y = x@(Just y) + +one could write a nonsensical function like + + f (K Nothing x) = ... + +or + g (K (Just True) False) = ... + +Note [Type signatures and the builder expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + pattern L x = Left x :: Either [a] [b] + +In tc{Infer/Check}PatSynDecl we will check that the pattern has the +specified type. We check the pattern *as a pattern*, so the type +signature is a pattern signature, and so brings 'a' and 'b' into +scope. But we don't have a way to bind 'a, b' in the LHS, as we do +'x', say. Nevertheless, the signature may be useful to constrain +the type. + +When making the binding for the *builder*, though, we don't want + $buildL x = Left x :: Either [a] [b] +because that wil either mean (forall a b. Either [a] [b]), or we'll +get a complaint that 'a' and 'b' are out of scope. (Actually the +latter; #9867.) No, the job of the signature is done, so when +converting the pattern to an expression (for the builder RHS) we +simply discard the signature. + +Note [Record PatSyn Desugaring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is important that prov_theta comes before req_theta as this ordering is used +when desugaring record pattern synonym updates. + +Any change to this ordering should make sure to change GHC.HsToCore.Expr if you +want to avoid difficult to decipher core lint errors! + +Note [Pragmas for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +INLINE and NOINLINE pragmas are supported for pattern synonyms. +They affect both the matcher and the builder. +(See Note [Matchers and builders for pattern synonyms] in PatSyn) + +For example: + pattern InlinedPattern x = [x] + {-# INLINE InlinedPattern #-} + + pattern NonInlinedPattern x = [x] + {-# NOINLINE NonInlinedPattern #-} + +For pattern synonyms with explicit builders, only a pragma for the +entire pattern synonym is supported. For example: + pattern HeadC x <- x:xs where + HeadC x = [x] + -- This wouldn't compile: {-# INLINE HeadC #-} + {-# INLINE HeadC #-} -- But this works + +When no pragma is provided for a pattern, the inlining decision might change +between different versions of GHC. + +Implementation notes. The prag_fn passed in to tcPatSynDecl will have a binding +for the /pattern synonym/ Name, thus + InlinedPattern :-> INLINE +From this we cook up an INLINE pragma for the matcher (in tcPatSynMatcher) +and builder (in tcPatSynBuilderBind), by looking up the /pattern synonym/ +Name in the prag_fn, and then using addInlinePragArity to add the right +inl_sat field to that INLINE pragma for the matcher or builder respectively. + -} + + +-- Walk the whole pattern and for all ConPatOuts, collect the +-- existentially-bound type variables and evidence binding variables. +-- +-- These are used in computing the type of a pattern synonym and also +-- in generating matcher functions, since success continuations need +-- to be passed these pattern-bound evidences. +tcCollectEx + :: LPat GhcTc + -> ( [TyVar] -- Existentially-bound type variables + -- in correctly-scoped order; e.g. [ k:*, x:k ] + , [EvVar] ) -- and evidence variables + +tcCollectEx pat = go pat + where + go :: LPat GhcTc -> ([TyVar], [EvVar]) + go = go1 . unLoc + + go1 :: Pat GhcTc -> ([TyVar], [EvVar]) + go1 (LazyPat _ p) = go p + go1 (AsPat _ _ p) = go p + go1 (ParPat _ p) = go p + go1 (BangPat _ p) = go p + go1 (ListPat _ ps) = mergeMany . map go $ ps + go1 (TuplePat _ ps _) = mergeMany . map go $ ps + go1 (SumPat _ p _ _) = go p + go1 (ViewPat _ _ p) = go p + go1 con@ConPat{ pat_con_ext = con' } + = merge (cpt_tvs con', cpt_dicts con') $ + goConDetails $ pat_args con + go1 (SigPat _ p _) = go p + go1 (XPat ext) = case ext of + CoPat _ p _ -> go1 p + ExpansionPat _ p -> go1 p + go1 (NPlusKPat _ n k _ geq subtract) + = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract + go1 _ = empty + + goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar]) + goConDetails (PrefixCon ps) = mergeMany . map go $ ps + goConDetails (InfixCon p1 p2) = go p1 `merge` go p2 + goConDetails (RecCon HsRecFields{ rec_flds = flds }) + = mergeMany . map goRecFd $ flds + + goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) + goRecFd (L _ HsFieldBind{ hfbRHS = p }) = go p + + merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) + mergeMany = foldr merge empty + empty = ([], []) diff --git a/GHC/Tc/TyCl/PatSyn.hs-boot b/GHC/Tc/TyCl/PatSyn.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/PatSyn.hs-boot @@ -0,0 +1,17 @@ +module GHC.Tc.TyCl.PatSyn where + +import GHC.Hs ( PatSynBind, LHsBinds ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Utils.Monad ( TcGblEnv) +import GHC.Hs.Extension ( GhcRn, GhcTc ) +import GHC.Tc.Gen.Sig ( TcPragEnv, TcSigFun ) +import GHC.Parser.Annotation( LocatedA ) + +tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn) + -> TcSigFun + -> TcPragEnv + -> TcM (LHsBinds GhcTc, TcGblEnv) + +tcPatSynBuilderBind :: TcPragEnv -> PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc) + diff --git a/GHC/Tc/TyCl/Utils.hs b/GHC/Tc/TyCl/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/Utils.hs @@ -0,0 +1,1173 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 + +-} + +-- | Analysis functions over data types. Specifically, detecting recursive types. +-- +-- This stuff is only used for source-code decls; it's recorded in interface +-- files for imported data types. +module GHC.Tc.TyCl.Utils( + RolesInfo, + inferRoles, + checkSynCycles, + checkClassCycles, + + -- * Implicits + addTyConsToGblEnv, mkDefaultMethodType, + + -- * Record selectors + tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector + ) where + +import GHC.Prelude + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Bind( tcValBinds ) +import GHC.Tc.Utils.TcType + +import GHC.Builtin.Types( unitTy ) +import GHC.Builtin.Uniques ( mkBuiltinUnique ) + +import GHC.Hs + +import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..) ) +import GHC.Core.Multiplicity +import GHC.Core.Predicate +import GHC.Core.Make( rEC_SEL_ERROR_ID ) +import GHC.Core.Class +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCon.Set +import GHC.Core.Coercion ( ltRole ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.FV as FV + +import GHC.Data.Maybe +import GHC.Data.FastString + +import GHC.Unit.Module + +import GHC.Rename.Utils (genHsVar, genLHsApp, genLHsLit, genWildPat, wrapGenSpan) + +import GHC.Types.Basic +import GHC.Types.FieldLabel +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import GHC.Types.SourceText +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Reader ( mkRdrUnqual ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set +import GHC.Types.TyThing +import qualified GHC.LanguageExtensions as LangExt + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.Monad + +{- +************************************************************************ +* * + Cycles in type synonym declarations +* * +************************************************************************ +-} + +synonymTyConsOfType :: Type -> [TyCon] +-- Does not look through type synonyms at all. +-- Returns a list of synonym tycons in nondeterministic order. +-- Keep this synchronized with 'expandTypeSynonyms' +synonymTyConsOfType ty + = nonDetNameEnvElts (go ty) + where + go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim + go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys + go (LitTy _) = emptyNameEnv + go (TyVarTy _) = emptyNameEnv + go (AppTy a b) = go a `plusNameEnv` go b + go (FunTy _ w a b) = go w `plusNameEnv` go a `plusNameEnv` go b + go (ForAllTy _ ty) = go ty + go (CastTy ty co) = go ty `plusNameEnv` go_co co + go (CoercionTy co) = go_co co + + -- Note [TyCon cycles through coercions?!] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Although, in principle, it's possible for a type synonym loop + -- could go through a coercion (since a coercion can refer to + -- a TyCon or Type), it doesn't seem possible to actually construct + -- a Haskell program which tickles this case. Here is an example + -- program which causes a coercion: + -- + -- type family Star where + -- Star = Type + -- + -- data T :: Star -> Type + -- data S :: forall (a :: Type). T a -> Type + -- + -- Here, the application 'T a' must first coerce a :: Type to a :: Star, + -- witnessed by the type family. But if we now try to make Type refer + -- to a type synonym which in turn refers to Star, we'll run into + -- trouble: we're trying to define and use the type constructor + -- in the same recursive group. Possibly this restriction will be + -- lifted in the future but for now, this code is "just for completeness + -- sake". + go_mco MRefl = emptyNameEnv + go_mco (MCo co) = go_co co + + go_co (Refl ty) = go ty + go_co (GRefl _ ty mco) = go ty `plusNameEnv` go_mco mco + go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs + go_co (AppCo co co') = go_co co `plusNameEnv` go_co co' + go_co (ForAllCo { fco_kind = kind_co, fco_body = body_co }) + = go_co kind_co `plusNameEnv` go_co body_co + go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r }) + = go_co m `plusNameEnv` go_co a `plusNameEnv` go_co r + go_co (CoVarCo _) = emptyNameEnv + go_co (HoleCo {}) = emptyNameEnv + go_co (AxiomCo _ cs) = go_co_s cs + go_co (UnivCo { uco_lty = t1, uco_rty = t2}) + = go t1 `plusNameEnv` go t2 + go_co (SymCo co) = go_co co + go_co (TransCo co co') = go_co co `plusNameEnv` go_co co' + go_co (SelCo _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co co') = go_co co `plusNameEnv` go_co co' + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + + go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc + | otherwise = emptyNameEnv + go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys + go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos + +-- | A monad for type synonym cycle checking, which keeps +-- track of the TyCons which are known to be acyclic, or +-- a failure message reporting that a cycle was found. +newtype SynCycleM a = SynCycleM { + runSynCycleM :: SynCycleState -> Either (SrcSpan, TySynCycleTyCons) (a, SynCycleState) } + deriving (Functor) + +-- TODO: TyConSet is implemented as IntMap over uniques. +-- But we could get away with something based on IntSet +-- since we only check membership, but never extract the +-- elements. +type SynCycleState = TyConSet + +instance Applicative SynCycleM where + pure x = SynCycleM $ \state -> Right (x, state) + (<*>) = ap + +instance Monad SynCycleM where + m >>= f = SynCycleM $ \state -> + case runSynCycleM m state of + Right (x, state') -> + runSynCycleM (f x) state' + Left err -> Left err + +failSynCycleM :: SrcSpan -> TySynCycleTyCons -> SynCycleM () +failSynCycleM loc seen_tcs = SynCycleM $ \_ -> Left (loc, seen_tcs) + +-- | Test if a 'Name' is acyclic, short-circuiting if we've +-- seen it already. +checkTyConIsAcyclic :: TyCon -> SynCycleM () -> SynCycleM () +checkTyConIsAcyclic tc m = SynCycleM $ \s -> + if tc `elemTyConSet` s + then Right ((), s) -- short circuit + else case runSynCycleM m s of + Right ((), s') -> Right ((), extendTyConSet s' tc) + Left err -> Left err + +-- | Checks if any of the passed in 'TyCon's have cycles. +-- Takes the 'Unit' of the home package (as we can avoid +-- checking those TyCons: cycles never go through foreign packages) and +-- the corresponding @LTyClDecl Name@ for each 'TyCon', so we +-- can give better error messages. +checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () +checkSynCycles this_uid tcs tyclds = + case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of + Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnTypeSynonymCycle err) + Right _ -> return () + where + -- Try our best to print the LTyClDecl for locally defined things + lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds) + + -- Short circuit if we've already seen this Name and concluded + -- it was acyclic. + go :: TyConSet -> [TyCon] -> TyCon -> SynCycleM () + go so_far seen_tcs tc = + checkTyConIsAcyclic tc $ go' so_far seen_tcs tc + + -- Expand type synonyms, complaining if you find the same + -- type synonym a second time. + go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM () + go' so_far seen_tcs tc + | tc `elemTyConSet` so_far + = failSynCycleM (getSrcSpan (head seen_tcs)) (lookup_decl <$> seen_tcs) + -- Optimization: we don't allow cycles through external packages, + -- so once we find a non-local name we are guaranteed to not + -- have a cycle. + -- + -- This won't hold once we get recursive packages with Backpack, + -- but for now it's fine. + | not (isHoleModule mod || + moduleUnit mod == this_uid || + isInteractiveModule mod) + = return () + | Just ty <- synTyConRhs_maybe tc = + go_ty (extendTyConSet so_far tc) (tc:seen_tcs) ty + | otherwise = return () + where + n = tyConName tc + mod = nameModule n + lookup_decl tc = + case lookupNameEnv lcl_decls (tyConName tc) of + Just decl -> Right decl + Nothing -> Left tc + + go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM () + go_ty so_far seen_tcs ty = + mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty) + +{- Note [Superclass cycle check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The superclass cycle check for C decides if we can statically +guarantee that expanding C's superclass cycles transitively is +guaranteed to terminate. This is a Haskell98 requirement, +but one that we lift with -XUndecidableSuperClasses. + +The worry is that a superclass cycle could make the type checker loop. +More precisely, with a constraint (Given or Wanted) + C ty1 .. tyn +one approach is to instantiate all of C's superclasses, transitively. +We can only do so if that set is finite. + +This potential loop occurs only through superclasses. This, for +example, is fine + class C a where + op :: C b => a -> b -> b +even though C's full definition uses C. + +Making the check static also makes it conservative. Eg + type family F a + class F a => C a +Here an instance of (F a) might mention C: + type instance F [a] = C a +and now we'd have a loop. + +The static check works like this, starting with C + * Look at C's superclass predicates + * If any is a type-function application, + or is headed by a type variable, fail + * If any has C at the head, fail + * If any has a type class D at the head, + make the same test with D + +A tricky point is: what if there is a type variable at the head? +Consider this: + class f (C f) => C f + class c => Id c +and now expand superclasses for constraint (C Id): + C Id + --> Id (C Id) + --> C Id + --> .... +Each step expands superclasses one layer, and clearly does not terminate. +-} + +type ClassSet = UniqSet Class + +checkClassCycles :: Class -> Maybe SuperclassCycle +-- Nothing <=> ok +-- Just err <=> possible cycle error +checkClassCycles cls + = do { (definite_cycle, details) <- go (unitUniqSet cls) + cls (mkTyVarTys (classTyVars cls)) + ; return (MkSuperclassCycle cls definite_cycle details) } + where + -- Expand superclasses starting with (C a b), complaining + -- if you find the same class a second time, or a type function + -- or predicate headed by a type variable + -- + -- NB: this code duplicates TcType.transSuperClasses, but + -- with more error message generation clobber + -- Make sure the two stay in sync. + go :: ClassSet -> Class -> [Type] -> Maybe (Bool, [SuperclassCycleDetail]) + go so_far cls tys = firstJusts $ + map (go_pred so_far) $ + immSuperClasses cls tys + + go_pred :: ClassSet -> PredType -> Maybe (Bool, [SuperclassCycleDetail]) + -- Nothing <=> ok + -- Just (True, err) <=> definite cycle + -- Just (False, err) <=> possible cycle + go_pred so_far pred -- NB: tcSplitTyConApp looks through synonyms + | Just (tc, tys) <- tcSplitTyConApp_maybe pred + = go_tc so_far pred tc tys + | hasTyVarHead pred + = Just (False, [SCD_HeadTyVar pred]) + | otherwise + = Nothing + + go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, [SuperclassCycleDetail]) + go_tc so_far pred tc tys + | isFamilyTyCon tc + = Just (False, [SCD_HeadTyFam pred]) + | Just cls <- tyConClass_maybe tc + = go_cls so_far cls tys + | otherwise -- Equality predicate, for example + = Nothing + + go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, [SuperclassCycleDetail]) + go_cls so_far cls tys + | cls `elementOfUniqSet` so_far + = Just (True, [SCD_Superclass cls]) + | isCTupleClass cls + = go so_far cls tys + | otherwise + = do { (b, details) <- go (so_far `addOneToUniqSet` cls) cls tys + ; return (b, SCD_Superclass cls : details) } + +{- +************************************************************************ +* * + Role inference +* * +************************************************************************ + +Note [Role inference] +~~~~~~~~~~~~~~~~~~~~~ +The role inference algorithm datatype definitions to infer the roles on the +parameters. Although these roles are stored in the tycons, we can perform this +algorithm on the built tycons, as long as we don't peek at an as-yet-unknown +roles field! Ah, the magic of laziness. + +First, we choose appropriate initial roles. For families and classes, roles +(including initial roles) are N. For datatypes, we start with the role in the +role annotation (if any), or otherwise use Phantom. This is done in +initialRoleEnv1. + +The function irGroup then propagates role information until it reaches a +fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a +monad RoleM, which is a combination reader and state monad. In its state are +the current RoleEnv, which gets updated by role propagation, and an update +bit, which we use to know whether or not we've reached the fixpoint. The +environment of RoleM contains the tycon whose parameters we are inferring, and +a VarEnv from parameters to their positions, so we can update the RoleEnv. +Between tycons, this reader information is missing; it is added by +addRoleInferenceInfo. + +There are two kinds of tycons to consider: algebraic ones (excluding classes) +and type synonyms. (Remember, families don't participate -- all their parameters +are N.) An algebraic tycon processes each of its datacons, in turn. Note that +a datacon's universally quantified parameters might be different from the parent +tycon's parameters, so we use the datacon's univ parameters in the mapping from +vars to positions. Note also that we don't want to infer roles for existentials +(they're all at N, too), so we put them in the set of local variables. As an +optimisation, we skip any tycons whose roles are already all Nominal, as there +nowhere else for them to go. For synonyms, we just analyse their right-hand sides. + +irType walks through a type, looking for uses of a variable of interest and +propagating role information. Because anything used under a phantom position +is at phantom and anything used under a nominal position is at nominal, the +irType function can assume that anything it sees is at representational. (The +other possibilities are pruned when they're encountered.) + +The rest of the code is just plumbing. + +How do we know that this algorithm is correct? It should meet the following +specification: + +Let Z be a role context -- a mapping from variables to roles. The following +rules define the property (Z |- t : r), where t is a type and r is a role: + +Z(a) = r' r' <= r +------------------------- RCVar +Z |- a : r + +---------- RCConst +Z |- T : r -- T is a type constructor + +Z |- t1 : r +Z |- t2 : N +-------------- RCApp +Z |- t1 t2 : r + +forall i<=n. (r_i is R or N) implies Z |- t_i : r_i +roles(T) = r_1 .. r_n +---------------------------------------------------- RCDApp +Z |- T t_1 .. t_n : R + +Z, a:N |- t : r +---------------------- RCAll +Z |- forall a:k.t : r + + +We also have the following rules: + +For all datacon_i in type T, where a_1 .. a_n are universally quantified +and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p, +then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R, +then roles(T) = r_1 .. r_n + +roles(->) = R, R +roles(~#) = N, N + +With -dcore-lint on, the output of this algorithm is checked in checkValidRoles, +called from checkValidTycon. + +Note [Role-checking data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a where + MkT :: Eq b => F a -> (a->a) -> T (G a) + +Then we want to check the roles at which 'a' is used +in MkT's type. We want to work on the user-written type, +so we need to take into account + * the arguments: (F a) and (a->a) + * the context: C a b + * the result type: (G a) -- this is in the eq_spec + + +Note [Coercions in role inference] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing +the kind of a type is totally irrelevant to the representation of that type. So, +we want to totally ignore coercions when doing role inference. This includes omitting +any type variables that appear in nominal positions but only within coercions. +-} + +type RolesInfo = Name -> [Role] + +type RoleEnv = NameEnv [Role] -- from tycon names to roles + +-- This, and any of the functions it calls, must *not* look at the roles +-- field of a tycon we are inferring roles about! +-- See Note [Role inference] +inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role] +inferRoles hsc_src annots tycons + = let role_env = initialRoleEnv hsc_src annots tycons + role_env' = irGroup role_env tycons in + \name -> case lookupNameEnv role_env' name of + Just roles -> roles + Nothing -> pprPanic "inferRoles" (ppr name) + +initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv +initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv . + map (initialRoleEnv1 hsc_src annots) + +initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role]) +initialRoleEnv1 hsc_src annots_env tc + | isFamilyTyCon tc = (name, map (const Nominal) bndrs) + | isAlgTyCon tc = (name, default_roles) + | isTypeSynonymTyCon tc = (name, default_roles) + | otherwise = pprPanic "initialRoleEnv1" (ppr tc) + where name = tyConName tc + bndrs = tyConBinders tc + argflags = map tyConBinderForAllTyFlag bndrs + num_exps = count isVisibleForAllTyFlag argflags + + -- if the number of annotations in the role annotation decl + -- is wrong, just ignore it. We check this in the validity check. + role_annots + = case lookupRoleAnnot annots_env name of + Just (L _ (RoleAnnotDecl _ _ annots)) + | annots `lengthIs` num_exps -> map unLoc annots + _ -> replicate num_exps Nothing + default_roles = build_default_roles argflags role_annots + + build_default_roles (argf : argfs) (m_annot : ras) + | isVisibleForAllTyFlag argf + = (m_annot `orElse` default_role) : build_default_roles argfs ras + build_default_roles (_argf : argfs) ras + = Nominal : build_default_roles argfs ras + build_default_roles [] [] = [] + build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)" + (vcat [ppr tc, ppr role_annots]) + + default_role + | isClassTyCon tc = Nominal + -- Note [Default roles for abstract TyCons in hs-boot/hsig] + | HsBootFile <- hsc_src + , isAbstractTyCon tc = Representational + | HsigFile <- hsc_src + , isAbstractTyCon tc = Nominal + | otherwise = Phantom + +-- Note [Default roles for abstract TyCons in hs-boot/hsig] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- What should the default role for an abstract TyCon be? +-- +-- Originally, we inferred phantom role for abstract TyCons +-- in hs-boot files, because the type variables were never used. +-- +-- This was silly, because the role of the abstract TyCon +-- was required to match the implementation, and the roles of +-- data types are almost never phantom. Thus, in ticket #9204, +-- the default was changed so be representational (the most common case). If +-- the implementing data type was actually nominal, you'd get an easy +-- to understand error, and add the role annotation yourself. +-- +-- Then Backpack was added, and with it we added role *subtyping* +-- the matching judgment: if an abstract TyCon has a nominal +-- parameter, it's OK to implement it with a representational +-- parameter. But now, the representational default is not a good +-- one, because you should *only* request representational if +-- you're planning to do coercions. To be maximally flexible +-- with what data types you will accept, you want the default +-- for hsig files is nominal. We don't allow role subtyping +-- with hs-boot files (it's good practice to give an exactly +-- accurate role here, because any types that use the abstract +-- type will propagate the role information.) + +irGroup :: RoleEnv -> [TyCon] -> RoleEnv +irGroup env tcs + = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in + if update + then irGroup env' tcs + else env' + +irTyCon :: TyCon -> RoleM () +irTyCon tc + | isAlgTyCon tc + = do { old_roles <- lookupRoles tc + ; unless (all (== Nominal) old_roles) $ -- also catches data families, + -- which don't want or need role inference + irTcTyVars tc $ + do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 + ; whenIsJust (tyConClass_maybe tc) irClass + ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }} + + | Just ty <- synTyConRhs_maybe tc + = irTcTyVars tc $ + irType emptyVarSet ty + + | otherwise + = return () + +-- any type variable used in an associated type must be Nominal +irClass :: Class -> RoleM () +irClass cls + = mapM_ ir_at (classATs cls) + where + cls_tvs = classTyVars cls + cls_tv_set = mkVarSet cls_tvs + + ir_at at_tc + = mapM_ (updateRole Nominal) nvars + where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc + +-- See Note [Role inference] +irDataCon :: DataCon -> RoleM () +irDataCon datacon + = setRoleInferenceVars univ_tvs $ + irExTyVars ex_tvs $ \ ex_var_set -> + do mapM_ (irType ex_var_set) (eqSpecPreds eq_spec ++ theta ++ map scaledThing arg_tys) + mapM_ (markNominal ex_var_set) (map tyVarKind ex_tvs ++ map scaledMult arg_tys) -- Field multiplicities are nominal (#18799) + -- See Note [Role-checking data constructor arguments] + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig datacon + +irType :: VarSet -> Type -> RoleM () +irType = go + where + go lcls ty | Just ty' <- coreView ty -- #14101 + = go lcls ty' + go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $ + updateRole Representational tv + go lcls (AppTy t1 t2) = go lcls t1 >> markNominal lcls t2 + go lcls (TyConApp tc tys) = do { roles <- lookupRolesX tc + ; zipWithM_ (go_app lcls) roles tys } + go lcls (ForAllTy tvb ty) = do { let tv = binderVar tvb + lcls' = extendVarSet lcls tv + ; markNominal lcls (tyVarKind tv) + ; go lcls' ty } + go lcls (FunTy _ w arg res) = markNominal lcls w >> go lcls arg >> go lcls res + go _ (LitTy {}) = return () + -- See Note [Coercions in role inference] + go lcls (CastTy ty _) = go lcls ty + go _ (CoercionTy _) = return () + + go_app _ Phantom _ = return () -- nothing to do here + go_app lcls Nominal ty = markNominal lcls ty -- all vars below here are N + go_app lcls Representational ty = go lcls ty + +irTcTyVars :: TyCon -> RoleM a -> RoleM a +irTcTyVars tc thing + = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc) + where + go [] = thing + go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv) + ; addRoleInferenceVar tv $ go tvs } + +irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a +irExTyVars orig_tvs thing = go emptyVarSet orig_tvs + where + go lcls [] = thing lcls + go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv) + ; go (extendVarSet lcls tv) tvs } + +markNominal :: TyVarSet -- local variables + -> Type -> RoleM () +markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in + mapM_ (updateRole Nominal) nvars + where + -- get_ty_vars gets all the tyvars (no covars!) from a type *without* + -- recurring into coercions. Recall: coercions are totally ignored during + -- role inference. See [Coercions in role inference] + get_ty_vars :: Type -> FV + get_ty_vars t | Just t' <- coreView t -- #20999 + = get_ty_vars t' + get_ty_vars (TyVarTy tv) = unitFV tv + get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 + get_ty_vars (FunTy _ w t1 t2) = get_ty_vars w `unionFV` get_ty_vars t1 `unionFV` get_ty_vars t2 + get_ty_vars (TyConApp _ tys) = mapUnionFV get_ty_vars tys + get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty) + get_ty_vars (LitTy {}) = emptyFV + get_ty_vars (CastTy ty _) = get_ty_vars ty + get_ty_vars (CoercionTy _) = emptyFV + +-- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps +lookupRolesX :: TyCon -> RoleM [Role] +lookupRolesX tc + = do { roles <- lookupRoles tc + ; return $ roles ++ repeat Nominal } + +-- gets the roles either from the environment or the tycon +lookupRoles :: TyCon -> RoleM [Role] +lookupRoles tc + = do { env <- getRoleEnv + ; case lookupNameEnv env (tyConName tc) of + Just roles -> return roles + Nothing -> return $ tyConRoles tc } + +-- tries to update a role; won't ever update a role "downwards" +updateRole :: Role -> TyVar -> RoleM () +updateRole role tv + = do { var_ns <- getVarNs + ; name <- getTyConName + ; case lookupVarEnv var_ns tv of + Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns) + Just n -> updateRoleEnv name n role } + +-- the state in the RoleM monad +data RoleInferenceState = RIS { role_env :: RoleEnv + , update :: Bool } + +-- the environment in the RoleM monad +type VarPositions = VarEnv Int + +-- See [Role inference] +newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon + -> VarPositions + -> Int -- size of VarPositions + -> RoleInferenceState + -> (a, RoleInferenceState) } + deriving (Functor) + +instance Applicative RoleM where + pure x = RM $ \_ _ _ state -> (x, state) + (<*>) = ap + +instance Monad RoleM where + a >>= f = RM $ \m_info vps nvps state -> + let (a', state') = unRM a m_info vps nvps state in + unRM (f a') m_info vps nvps state' + +runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool) +runRoleM env thing = (env', update) + where RIS { role_env = env', update = update } + = snd $ unRM thing Nothing emptyVarEnv 0 state + state = RIS { role_env = env + , update = False } + +setRoleInferenceTc :: Name -> RoleM a -> RoleM a +setRoleInferenceTc name thing = RM $ \m_name vps nvps state -> + assert (isNothing m_name) $ + assert (isEmptyVarEnv vps) $ + assert (nvps == 0) $ + unRM thing (Just name) vps nvps state + +addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a +addRoleInferenceVar tv thing + = RM $ \m_name vps nvps state -> + assert (isJust m_name) $ + unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state + +setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a +setRoleInferenceVars tvs thing + = RM $ \m_name _vps _nvps state -> + assert (isJust m_name) $ + unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars") + state + +getRoleEnv :: RoleM RoleEnv +getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state) + +getVarNs :: RoleM VarPositions +getVarNs = RM $ \_ vps _ state -> (vps, state) + +getTyConName :: RoleM Name +getTyConName = RM $ \m_name _ _ state -> + case m_name of + Nothing -> panic "getTyConName" + Just name -> (name, state) + +updateRoleEnv :: Name -> Int -> Role -> RoleM () +updateRoleEnv name n role + = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((), + case lookupNameEnv role_env name of + Just roles + | (before, old_role : after) <- splitAt n roles + -> if role `ltRole` old_role + then let roles' = before ++ role : after + role_env' = extendNameEnv role_env name roles' in + RIS { role_env = role_env', update = True } + else state + _ -> pprPanic "updateRoleEnv" (ppr name)) + + +{- ********************************************************************* +* * + Building implicits +* * +********************************************************************* -} + +addTyConsToGblEnv :: [TyCon] -> TcM (TcGblEnv, ThBindEnv) +-- Given a [TyCon], add to the TcGblEnv +-- * extend the TypeEnv with the tycons +-- * extend the TypeEnv with their implicitTyThings +-- * extend the TypeEnv with any default method Ids +-- * add bindings for record selectors +-- Return separately the TH levels of these bindings, +-- to be added to a LclEnv later. +addTyConsToGblEnv tyclss + = tcExtendTyConEnv tyclss $ + tcExtendGlobalEnvImplicit implicit_things $ + tcExtendGlobalValEnv def_meth_ids $ + do { traceTc "tcAddTyCons" $ vcat + [ text "tycons" <+> ppr tyclss + , text "implicits" <+> ppr implicit_things ] + ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss) + ; th_bndrs <- tcTyThBinders implicit_things + ; return (gbl_env, th_bndrs) + } + where + implicit_things = concatMap implicitTyConThings tyclss + def_meth_ids = mkDefaultMethodIds tyclss + +mkDefaultMethodIds :: [TyCon] -> [Id] +-- We want to put the default-method Ids (both vanilla and generic) +-- into the type environment so that they are found when we typecheck +-- the filled-in default methods of each instance declaration +-- See Note [Default method Ids and Template Haskell] +mkDefaultMethodIds tycons + = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec) + | tc <- tycons + , Just cls <- [tyConClass_maybe tc] + , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ] + +mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type +-- Returns the top-level type of the default method +mkDefaultMethodType _ sel_id VanillaDM = idType sel_id +mkDefaultMethodType cls _ (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty + where + pred = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs)) + cls_bndrs = tyConBinders (classTyCon cls) + tv_bndrs = tyVarSpecToBinders $ tyConInvisTVBinders cls_bndrs + -- NB: the Class doesn't have TyConBinders; we reach into its + -- TyCon to get those. We /do/ need the TyConBinders because + -- we need the correct visibility: these default methods are + -- used in code generated by the fill-in for missing + -- methods in instances (GHC.Tc.TyCl.Instance.mkDefMethBind), and + -- then typechecked. So we need the right visibility info + -- (#13998) + +{- +Note [Default method Ids and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#4169): + class Numeric a where + fromIntegerNum :: a + fromIntegerNum = ... + + ast :: Q [Dec] + ast = [d| instance Numeric Int |] + +When we typecheck 'ast' we have done the first pass over the class decl +(in tcTyClDecls), but we have not yet typechecked the default-method +declarations (because they can mention value declarations). So we +must bring the default method Ids into scope first (so they can be seen +when typechecking the [d| .. |] quote, and typecheck them later. +-} + +{- +************************************************************************ +* * + Building record selectors +* * +************************************************************************ +-} + +{- Note [Record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record selectors are injected as ordianry functions definitions, very +early in the pipeline. + +* `mkRecSelBinds` produces /un-typechecked/ bindings, rather like 'deriving' + This makes life easier, because the later type checking will add + all necessary type abstractions and applications; and handling for + UNPACK pragmas etc + +* Record selectors are not treated as "implicit". See + See Note [Implicit TyThings] in GHC.Types.TyThing and + Note [Injecting implicit bindings] in GHC.CoreToStg.AddImplicitBinds +-} + +tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv +tcRecSelBinds sel_bind_prs + = tcExtendGlobalValEnv [sel_id | (L _ (XSig (IdSig sel_id))) <- sigs] $ + do { (rec_sel_binds, tcg_env) <- discardWarnings $ + -- See Note [Impredicative record selectors] + setXOptM LangExt.ImpredicativeTypes $ + tcValBinds TopLevel binds sigs getGblEnv + ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } + where + sigs = [ L (noAnnSrcSpan loc) (XSig $ IdSig sel_id) + | (sel_id, _) <- sel_bind_prs + , let loc = getSrcSpan sel_id ] + binds = [(NonRecursive, [bind]) | (_, bind) <- sel_bind_prs] + +mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] +-- See Note [Record selectors] +mkRecSelBinds tycons + = map mkRecSelBind [ (tc,fld) | tc <- tycons + , fld <- tyConFieldLabels tc ] + +mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn) +mkRecSelBind (tycon, fl) + = mkOneRecordSelector all_cons (RecSelData tycon) fl + FieldSelectors -- See Note [NoFieldSelectors and naughty record selectors] + where + all_cons = map RealDataCon (tyConDataCons tycon) + +mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors + -> (Id, LHsBind GhcRn) +mkOneRecordSelector all_cons idDetails fl has_sel + = (sel_id, L (noAnnSrcSpan loc) sel_bind) + where + loc = getSrcSpan sel_name + loc' = noAnnSrcSpan loc + locn = noAnnSrcSpan loc + locc = noAnnSrcSpan loc + lbl = flLabel fl + sel_name = flSelector fl + sel_lname = L locn sel_name + match_ctxt = mkPrefixFunRhs sel_lname noAnn + + sel_id = mkExportedLocalId rec_details sel_name sel_ty + + -- Find a representative constructor, con1 + rec_sel_info@(RSI { rsi_def = cons_w_field }) + = conLikesRecSelInfo all_cons [lbl] + con1 = assert (not (null cons_w_field)) $ head cons_w_field + + -- Construct the IdDetails + rec_details = RecSelId { sel_tycon = idDetails + , sel_naughty = is_naughty + , sel_fieldLabel = fl + , sel_cons = rec_sel_info } + -- See (IRS1) in Note [Detecting incomplete record selectors] + -- in GHC.HsToCore.Pmc + + + -- Selector type; Note [Polymorphic selectors] + (univ_tvs, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1 + + field_ty = conLikeFieldType con1 lbl + field_ty_tvs = tyCoVarsOfType field_ty + data_ty_tvs = tyCoVarsOfType data_ty + sel_tvs = field_ty_tvs `unionVarSet` data_ty_tvs + sel_tvbs = filter (\tvb -> binderVar tvb `elemVarSet` sel_tvs) $ + conLikeUserTyVarBinders con1 + + -- is_naughty: see Note [Naughty record selectors] + is_naughty = not ok_scoping || no_selectors + ok_scoping = case con1 of + RealDataCon {} -> field_ty_tvs `subVarSet` data_ty_tvs + PatSynCon {} -> field_ty_tvs `subVarSet` mkVarSet univ_tvs + -- In the PatSynCon case, the selector type is (data_ty -> field_ty), but + -- fvs(data_ty) are all universals (see Note [Pattern synonym result type] in + -- GHC.Core.PatSyn, so no need to check them. + + no_selectors = has_sel == NoFieldSelectors -- No field selectors => all are naughty + -- thus suppressing making a binding + -- A slight hack! + + sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] + | otherwise = mkForAllTys sel_tvbs $ + -- Urgh! See Note [The stupid context] in GHC.Core.DataCon + mkPhiTy (conLikeStupidTheta con1) $ + -- req_theta is empty for normal DataCon + mkPhiTy req_theta $ + mkVisFunTyMany data_ty $ + -- Record selectors are always typed with Many. We + -- could improve on it in the case where all the + -- fields in all the constructor have multiplicity Many. + field_ty + + -- make the binding: sel (C2 { fld = x }) = x + -- sel (C7 { fld = x }) = x + -- where cons_w_field = [C2,C7] + sel_bind = mkTopFunBind (Generated OtherExpansion SkipPmc) sel_lname alts + where + alts | is_naughty = [mkSimpleMatch match_ctxt (noLocA []) unit_rhs] + | otherwise = map mk_match cons_w_field ++ deflt + mk_match con = mkSimpleMatch match_ctxt + (L (l2l loc') [L loc' (mk_sel_pat con)]) + (L loc' (mkHsVar (L locn field_var))) + mk_sel_pat con = + let con_lname = L locn (noUserRdr (getName con)) + in ConPat NoExtField con_lname (RecCon rec_fields) + rec_fields = HsRecFields { rec_ext = noExtField, rec_flds = [rec_field], rec_dotdot = Nothing } + rec_field = noLocA (HsFieldBind + { hfbAnn = noAnn + , hfbLHS + = L locc (FieldOcc (mkRdrUnqual $ nameOccName sel_name) (L locn sel_name)) + , hfbRHS + = L loc' (VarPat noExtField (L locn field_var)) + , hfbPun = False }) + field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc + + -- Add catch-all default case unless the case is exhaustive + -- We do this explicitly so that we get a nice error message that + -- mentions this particular record selector + deflt | all dealt_with all_cons = [] + | otherwise = [mkSimpleMatch match_ctxt (wrapGenSpan [genWildPat]) + (genLHsApp + (genHsVar (getName rEC_SEL_ERROR_ID)) + (genLHsLit msg_lit))] + + -- Do not add a default case unless there are unmatched + -- constructors. We must take account of GADTs, else we + -- get overlap warning messages from the pattern-match checker + -- NB: we need to pass type args for the *representation* TyCon + -- to dataConCannotMatch, hence the calculation of inst_tys + -- This matters in data families + -- data instance T Int a where + -- A :: { fld :: Int } -> T Int Bool + -- B :: { fld :: Int } -> T Int Char + dealt_with :: ConLike -> Bool + dealt_with (PatSynCon _) = False -- We can't predict overlap + dealt_with con@(RealDataCon dc) + = con `elem` cons_w_field || dataConCannotMatch inst_tys dc + where + inst_tys = dataConResRepTyArgs dc + + unit_rhs = mkLHsTupleExpr [] noExtField + msg_lit = HsStringPrim NoSourceText (bytesFS (field_label lbl)) + +{- +Note [Polymorphic selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We take care to build the type of a polymorphic selector in the right +order, so that visible type application works according to the specification in +the GHC User's Guide (see the "Field selectors and TypeApplications" section). +We won't bother rehashing the entire specification in this Note, but the tricky +part is dealing with GADT constructor fields. Here is an appropriately tricky +example to illustrate the challenges: + + {-# LANGUAGE PolyKinds #-} + data T a b where + MkT :: forall b a x. + { field1 :: forall c. (Num a, Show c) => (Either a c, Proxy b) + , field2 :: x + } + -> T a b + +Our goal is to obtain the following type for `field1`: + + field1 :: forall {k} (b :: k) a. + T a b -> forall c. (Num a, Show c) => (Either a c, Proxy b) + +(`field2` is naughty, per Note [Naughty record selectors], so we cannot turn +it into a top-level field selector.) + +Some potential gotchas, inspired by #18023: + +1. Since the user wrote `forall b a x.` in the type of `MkT`, we want the `b` + to appear before the `a` when quantified in the type of `field1`. +2. On the other hand, we *don't* want to quantify `x` in the type of `field1`. + This is because `x` does not appear in the GADT return type, so it is not + needed in the selector type. +3. Because of PolyKinds, the kind of `b` is generalized to `k`. Moreover, since + this `k` is not written in the source code, it is inferred (i.e., not + available for explicit type applications) and thus written as {k} in the type + of `field1`. + +In order to address these gotchas, we start by looking at the +conLikeUserTyVarBinders, which gives the order and specificity of each binder. +This effectively solves (1) and (3). To solve (2), we filter the binders to +leave only those that are needed for the selector type. + +Note [Naughty record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "naughty" field is one for which we can't define a record +selector, because an existential type variable would escape. For example: + data T = forall a. MkT { x,y::a } +We obviously can't define + x (MkT v _) = v +Nevertheless we *do* put a RecSelId into the type environment +so that if the user tries to use 'x' as a selector we can bleat +helpfully, rather than saying unhelpfully that 'x' is not in scope. +Hence the sel_naughty flag, to identify record selectors that don't really exist. + +For naughty selectors we make a dummy binding + sel = () +so that the later type-check will add them to the environment, and they'll be +exported. The function is never called, because the typechecker spots the +sel_naughty field. + +To determine naughtiness we distingish two cases: + +* For RealDataCons, a field is "naughty" if its type mentions a + type variable that isn't in the (original, user-written) result type + of the constructor. Note that this *allows* GADT record selectors + (Note [GADT record selectors]) whose types may look like sel :: T [a] -> a + +* For a PatSynCon, a field is "naughty" if its type mentions a type variable + that isn't in the universal type variables. + + This is a bit subtle. Consider test patsyn/should_run/records_run: + pattern ReadP :: forall a. ReadP a => a -> String + pattern ReadP {fld} <- (read -> readp) + The selector is defined like this: + $selReadPfld :: forall a. ReadP a => String -> a + $selReadPfld @a (d::ReadP a) s = readp @a d s + Perfectly fine! The (ReadP a) constraint lets us construct a value of type + 'a' from a bare String. + + Another curious case (#23038): + pattern N :: forall a. () => forall. () => a -> Any + pattern N { fld } <- ( unsafeCoerce -> fld1 ) where N = unsafeCoerce + The selector looks like this + $selNfld :: forall a. Any -> a + $selNfld @a x = unsafeCoerce @Any @a x + Pretty strange (but used in the `cleff` package). + + TL;DR for pattern synonyms, the selector is OK if the field type mentions only + the universal type variables of the pattern synonym. + +Note [NoFieldSelectors and naughty record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Under NoFieldSelectors (see Note [NoFieldSelectors] in GHC.Rename.Env), record +selectors will not be in scope in the renamer. However, for normal datatype +declarations we still generate the underlying selector functions, so they can be +used for constructing the dictionaries for HasField constraints (as described by +Note [HasField instances] in GHC.Tc.Instance.Class). Hence the call to +mkOneRecordSelector in mkRecSelBind always uses FieldSelectors. + +However, record pattern synonyms are not used with HasField, so when +NoFieldSelectors is used we do not need to generate selector functions. Thus +mkPatSynRecSelBinds passes the current state of the FieldSelectors extension to +mkOneRecordSelector, and in the NoFieldSelectors case it will treat them as +"naughty" fields (see Note [Naughty record selectors]). + +Why generate a naughty binding, rather than no binding at all? Because when +type-checking a record update, we need to look up Ids for the fields. In +particular, disambiguateRecordBinds calls lookupParents which needs to look up +the RecSelIds to determine the sel_tycon. + +Note [GADT record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For GADTs, we require that all constructors with a common field 'f' have the same +result type (modulo alpha conversion). [Checked in GHC.Tc.TyCl.checkValidTyCon] +E.g. + data T where + T1 { f :: Maybe a } :: T [a] + T2 { f :: Maybe a, y :: b } :: T [a] + T3 :: T Int + +and now the selector takes that result type as its argument: + f :: forall a. T [a] -> Maybe a + +Details: the "real" types of T1,T2 are: + T1 :: forall r a. (r~[a]) => a -> T r + T2 :: forall r a b. (r~[a]) => a -> b -> T r + +So the selector loooks like this: + f :: forall a. T [a] -> Maybe a + f (a:*) (t:T [a]) + = case t of + T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) + T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) + T3 -> error "T3 does not have field f" + +Note the forall'd tyvars of the selector are just the free tyvars +of the result type; there may be other tyvars in the constructor's +type (e.g. 'b' in T2). + +Note the need for casts in the result! + +Note [Selector running example] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's OK to combine GADTs and type families. Here's a running example: + + data instance T [a] where + T1 { fld :: b } :: T [Maybe b] + +The representation type looks like this + data :R7T a where + T1 { fld :: b } :: :R7T (Maybe b) + +and there's coercion from the family type to the representation type + :CoR7T a :: T [a] ~ :R7T a + +The selector we want for fld looks like this: + + fld :: forall b. T [Maybe b] -> b + fld = /\b. \(d::T [Maybe b]). + case d `cast` :CoR7T (Maybe b) of + T1 (x::b) -> x + +The scrutinee of the case has type :R7T (Maybe b), which can be +gotten by applying the eq_spec to the univ_tvs of the data con. + +Note [Impredicative record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are situations where generating code for record selectors requires the +use of ImpredicativeTypes. Here is one example (adapted from #18005): + + type S = (forall b. b -> b) -> Int + data T = MkT {unT :: S} + | Dummy + +We want to generate HsBinds for unT that look something like this: + + unT :: S + unT (MkT x) = x + unT _ = recSelError "unT"# + +Note that the type of recSelError is `forall r (a :: TYPE r). Addr# -> a`. +Therefore, when used in the right-hand side of `unT`, GHC attempts to +instantiate `a` with `(forall b. b -> b) -> Int`, which is impredicative. +To make sure that GHC is OK with this, we enable ImpredicativeTypes internally +when typechecking these HsBinds so that the user does not have to. +-} diff --git a/GHC/Tc/Types.hs b/GHC/Tc/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types.hs @@ -0,0 +1,1199 @@ + +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} + +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-2002 + +-} + +-- | Various types used during typechecking. +-- +-- Please see "GHC.Tc.Utils.Monad" as well for operations on these types. You probably +-- want to import it, instead of this module. +-- +-- All the monads exported here are built on top of the same IOEnv monad. The +-- monad functions like a Reader monad in the way it passes the environment +-- around. This is done to allow the environment to be manipulated in a stack +-- like fashion when entering expressions... etc. +-- +-- For state that is global and should be returned at the end (e.g not part +-- of the stack mechanism), you should use a TcRef (= IORef) to store them. +module GHC.Tc.Types( + TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module + TcRef, + + -- The environment types + Env(..), + TcGblEnv(..), TcLclEnv(..), modifyLclCtxt, TcLclCtxt(..), + setLclEnvTcLevel, getLclEnvTcLevel, + setLclEnvLoc, getLclEnvLoc, lclEnvInGeneratedCode, + IfGblEnv(..), IfLclEnv(..), + tcVisibleOrphanMods, + RewriteEnv(..), + + -- Frontend types (shouldn't really be here) + FrontendResult(..), + + -- Renamer types + ErrCtxt, + ImportAvails(..), emptyImportAvails, plusImportAvails, + ImportUserSpec(..), + ImpUserList(..), + mkModDeps, + + -- Typechecker types + TcTypeEnv, TcBinderStack, TcBinder(..), + TcTyThing(..), tcTyThingTyCon_maybe, + PromotionErr(..), + IdBindingInfo(..), ClosedTypeId, RhsNames, + IsGroupClosed(..), + SelfBootInfo(..), bootExports, + tcTyThingCategory, pprTcTyThingCategory, + peCategory, pprPECategory, + CompleteMatch, CompleteMatches, + + -- Template Haskell + ThLevel(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..), + topLevel, topAnnLevel, topSpliceLevel, + ThLevelIndex, + topLevelIndex, + spliceLevelIndex, + quoteLevelIndex, + + thLevelIndex, + + ForeignSrcLang(..), THDocs, DocLoc(..), + ThBindEnv, + + -- Arrows + ArrowCtxt(..), + + -- TcSigInfo + TcSigFun, + TcSigInfo(..), TcIdSig(..), + TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..), + TcIdSigInst(..), + isPartialSig, hasCompleteSig, tcSigInfoName, tcIdSigLoc, + completeSigPolyId_maybe, + + -- Misc other types + TcId, + NameShape(..), + removeBindingShadowing, + getPlatform, + + -- Constraint solver plugins + TcPlugin(..), + TcPluginSolveResult(TcPluginContradiction, TcPluginOk, ..), + TcPluginRewriteResult(..), + TcPluginSolver, TcPluginRewriter, + TcPluginM(runTcPluginM), unsafeTcPluginTcM, + + -- Defaulting plugin + DefaultingPlugin(..), DefaultingProposal(..), + FillDefaulting, + + -- Role annotations + RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, + lookupRoleAnnot, getRoleAnnots, + + -- Linting + lintGblEnv, + + -- Diagnostics + TcRnMessage + ) where + +import GHC.Prelude +import GHC.Platform + +import GHC.Driver.Env +import GHC.Driver.Env.KnotVars +import GHC.Driver.Config.Core.Lint +import GHC.Driver.DynFlags +import {-# SOURCE #-} GHC.Driver.Hooks + +import GHC.Linker.Types + +import GHC.Hs + +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( CtLoc ) +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.TH +import GHC.Tc.Types.TcRef +import GHC.Tc.Types.LclEnv +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Types.ErrCtxt +import {-# SOURCE #-} GHC.Tc.Errors.Hole.Plugin ( HoleFitPlugin ) +import GHC.Tc.Errors.Types + +import GHC.Core.Reduction ( Reduction(..) ) +import GHC.Core.Type +import GHC.Core.TyCon ( TyCon ) +import GHC.Core.PatSyn ( PatSyn ) +import GHC.Core.Lint ( lintAxioms ) +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Core.Predicate + +import GHC.Types.DefaultEnv ( DefaultEnv ) +import GHC.Types.Fixity.Env +import GHC.Types.Annotations +import GHC.Types.CompleteMatch +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.TypeEnv +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM +import GHC.Types.Basic +import GHC.Types.CostCentre.State + +import GHC.Data.IOEnv +import GHC.Data.Bag +import GHC.Data.List.SetOps + +import GHC.Unit +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.Deps +import GHC.Unit.Module.ModDetails + +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Fingerprint +import GHC.Utils.Panic +import GHC.Utils.Logger + +import GHC.Builtin.Names ( isUnboundName ) + +import GHCi.Message +import GHCi.RemoteTypes + +import Data.Set ( Set ) +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Dynamic ( Dynamic ) +import Data.Map ( Map ) +import Data.Typeable ( TypeRep ) +import Data.Maybe ( mapMaybe ) + +-- | The import specification as written by the user, including +-- the list of explicitly imported names. Used in 'ModIface' to +-- allow GHCi to reconstruct the top level environment on demand. +-- +-- This is distinct from 'ImportSpec' because we don't want to store +-- the list of explicitly imported names along with each 'GRE' +-- +-- We don't want to store the entire GlobalRdrEnv for modules that +-- are imported without explicit export lists, as these may grow +-- to be very large. However, GlobalRdrEnvs which are the result +-- of explicit import lists are typically quite small. +-- +-- Why do we not store something like (Maybe (ImportListInterpretation, [IE GhcPs]) in such a case? +-- Because we don't want to store source syntax including annotations in +-- interface files. +data ImportUserSpec + = ImpUserSpec { ius_decl :: !ImpDeclSpec + , ius_imports :: !ImpUserList + } + +data ImpUserList + = ImpUserAll -- ^ no user import list + | ImpUserExplicit + { iul_avails :: ![AvailInfo] + , iul_non_explicit_parents :: !NameSet + -- ^ The @T@s in import list items of the form @T(..)@ + } + | ImpUserEverythingBut !NameSet + +-- | A 'NameShape' is a substitution on 'Name's that can be used +-- to refine the identities of a hole while we are renaming interfaces +-- (see "GHC.Iface.Rename"). Specifically, a 'NameShape' for +-- 'ns_module_name' @A@, defines a mapping from @{A.T}@ +-- (for some 'OccName' @T@) to some arbitrary other 'Name'. +-- +-- The most intriguing thing about a 'NameShape', however, is +-- how it's constructed. A 'NameShape' is *implied* by the +-- exported 'AvailInfo's of the implementor of an interface: +-- if an implementor of signature @\@ exports @M.T@, you implicitly +-- define a substitution from @{H.T}@ to @M.T@. So a 'NameShape' +-- is computed from the list of 'AvailInfo's that are exported +-- by the implementation of a module, or successively merged +-- together by the export lists of signatures which are joining +-- together. +-- +-- It's not the most obvious way to go about doing this, but it +-- does seem to work! +-- +-- NB: Can't boot this and put it in NameShape because then we +-- start pulling in too many DynFlags things. +data NameShape = NameShape { + ns_mod_name :: ModuleName, + ns_exports :: [AvailInfo], + ns_map :: OccEnv Name + } + + +{- +************************************************************************ +* * + Standard monad definition for TcRn + All the combinators for the monad can be found in GHC.Tc.Utils.Monad +* * +************************************************************************ + +The monad itself has to be defined here, because it is mentioned by ErrCtxt +-} + +type TcRnIf a b = IOEnv (Env a b) +type TcRn = TcRnIf TcGblEnv TcLclEnv -- Type inference +type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff +type IfG = IfM () -- Top level +type IfL = IfM IfLclEnv -- Nested + +-- TcRn is the type-checking and renaming monad: the main monad that +-- most type-checking takes place in. The global environment is +-- 'TcGblEnv', which tracks all of the top-level type-checking +-- information we've accumulated while checking a module, while the +-- local environment is 'TcLclEnv', which tracks local information as +-- we move inside expressions. + +-- | Historical "renaming monad" (now it's just 'TcRn'). +type RnM = TcRn + +-- | Historical "type-checking monad" (now it's just 'TcRn'). +type TcM = TcRn + +-- We 'stack' these envs through the Reader like monad infrastructure +-- as we move into an expression (although the change is focused in +-- the lcl type). +data Env gbl lcl + = Env { + env_top :: !HscEnv, -- Top-level stuff that never changes + -- Includes all info about imported things + -- BangPattern is to fix leak, see #15111 + + env_ut :: {-# UNPACK #-} !Char, -- Tag for Uniques + + env_gbl :: gbl, -- Info about things defined at the top level + -- of the module being compiled + + env_lcl :: lcl -- Nested stuff; changes as we go into + } + +instance ContainsDynFlags (Env gbl lcl) where + extractDynFlags env = hsc_dflags (env_top env) + +instance ContainsHooks (Env gbl lcl) where + extractHooks env = hsc_hooks (env_top env) + +instance ContainsLogger (Env gbl lcl) where + extractLogger env = hsc_logger (env_top env) + +instance ContainsModule gbl => ContainsModule (Env gbl lcl) where + extractModule env = extractModule (env_gbl env) + +{- +************************************************************************ +* * +* RewriteEnv +* The rewriting environment +* * +************************************************************************ +-} + +-- | A 'RewriteEnv' carries the necessary context for performing rewrites +-- (i.e. type family reductions and following filled-in metavariables) +-- in the solver. +data RewriteEnv + = RE { re_loc :: !CtLoc + -- ^ In which context are we rewriting? + -- + -- Type-checking plugins might want to use this location information + -- when emitting new Wanted constraints when rewriting type family + -- applications. This ensures that such Wanted constraints will, + -- when unsolved, give rise to error messages with the + -- correct source location. + + -- Within GHC, we use this field to keep track of reduction depth. + -- See Note [Rewriter CtLoc] in GHC.Tc.Solver.Rewrite. + , re_flavour :: !CtFlavour + , re_eq_rel :: !EqRel + -- ^ At what role are we rewriting? + -- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite + + , re_rewriters :: !(TcRef RewriterSet) -- ^ See Note [Wanteds rewrite Wanteds] + } +-- RewriteEnv is mostly used in @GHC.Tc.Solver.Rewrite@, but it is defined +-- here so that it can also be passed to rewriting plugins. +-- See the 'tcPluginRewrite' field of 'TcPlugin'. + + +{- +************************************************************************ +* * + The interface environments + Used when dealing with IfaceDecls +* * +************************************************************************ +-} + +data IfGblEnv + = IfGblEnv { + -- Some information about where this environment came from; + -- useful for debugging. + if_doc :: SDoc, + -- The type environment for the module being compiled, + -- in case the interface refers back to it via a reference that + -- was originally a hi-boot file. + -- We need the module name so we can test when it's appropriate + -- to look in this env. + -- See Note [Tying the knot] in GHC.IfaceToCore + if_rec_types :: (KnotVars (IfG TypeEnv)) + -- Allows a read effect, so it can be in a mutable + -- variable; c.f. handling the external package type env + -- Nothing => interactive stuff, no loops possible + } + +data IfLclEnv + = IfLclEnv { + -- The module for the current IfaceDecl + -- So if we see f = \x -> x + -- it means M.f = \x -> x, where M is the if_mod + -- NB: This is a semantic module, see + -- Note [Identity versus semantic module] + if_mod :: !Module, + + -- Whether or not the IfaceDecl came from a boot + -- file or not; we'll use this to choose between + -- NoUnfolding and BootUnfolding + if_boot :: IsBootInterface, + + -- The field is used only for error reporting + -- if (say) there's a Lint error in it + if_loc :: SDoc, + -- Where the interface came from: + -- .hi file, or GHCi state, or ext core + -- plus which bit is currently being examined + + if_nsubst :: Maybe NameShape, + + -- This field is used to make sure "implicit" declarations + -- (anything that cannot be exported in mi_exports) get + -- wired up correctly in typecheckIfacesForMerging. Most + -- of the time it's @Nothing@. See Note [Resolving never-exported Names] + -- in GHC.IfaceToCore. + if_implicits_env :: Maybe TypeEnv, + + if_tv_env :: FastStringEnv TyVar, -- Nested tyvar bindings + if_id_env :: FastStringEnv Id -- Nested id binding + } + +{- +************************************************************************ +* * + Global typechecker environment +* * +************************************************************************ +-} + +-- | 'FrontendResult' describes the result of running the frontend of a Haskell +-- module. Currently one always gets a 'FrontendTypecheck', since running the +-- frontend involves typechecking a program. hs-sig merges are not handled here. +-- +-- This data type really should be in GHC.Driver.Env, but it needs +-- to have a TcGblEnv which is only defined here. +data FrontendResult + = FrontendTypecheck TcGblEnv + +-- Note [Identity versus semantic module] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When typechecking an hsig file, it is convenient to keep track +-- of two different "this module" identifiers: +-- +-- - The IDENTITY module is simply thisPackage + the module +-- name; i.e. it uniquely *identifies* the interface file +-- we're compiling. For example, p[A=]:A is an +-- identity module identifying the requirement named A +-- from library p. +-- +-- - The SEMANTIC module, which is the actual module that +-- this signature is intended to represent (e.g. if +-- we have a identity module p[A=base:Data.IORef]:A, +-- then the semantic module is base:Data.IORef) +-- +-- Which one should you use? +-- +-- - In the desugarer and later phases of compilation, +-- identity and semantic modules coincide, since we never compile +-- signatures (we just generate blank object files for +-- hsig files.) +-- +-- A corollary of this is that the following invariant holds at any point +-- past desugaring, +-- +-- if I have a Module, this_mod, in hand representing the module +-- currently being compiled, +-- then moduleUnit this_mod == thisPackage dflags +-- +-- - For any code involving Names, we want semantic modules. +-- See lookupIfaceTop in GHC.Iface.Env, mkIface and addFingerprints +-- in GHC.Iface.{Make,Recomp}, and tcLookupGlobal in GHC.Tc.Utils.Env +-- +-- - When reading interfaces, we want the identity module to +-- identify the specific interface we want (such interfaces +-- should never be loaded into the EPS). However, if a +-- hole module is requested, we look for A.hi +-- in the home library we are compiling. (See GHC.Iface.Load.) +-- Similarly, in GHC.Rename.Names we check for self-imports using +-- identity modules, to allow signatures to import their implementor. +-- +-- - For recompilation avoidance, you want the identity module, +-- since that will actually say the specific interface you +-- want to track (and recompile if it changes) + +-- | 'TcGblEnv' describes the top-level of the module at the +-- point at which the typechecker is finished work. +-- It is this structure that is handed on to the desugarer +-- For state that needs to be updated during the typechecking +-- phase and returned at end, use a 'TcRef' (= 'IORef'). +data TcGblEnv + = TcGblEnv { + tcg_mod :: Module, -- ^ Module being compiled + tcg_semantic_mod :: Module, -- ^ If a signature, the backing module + -- See also Note [Identity versus semantic module] + tcg_src :: HscSource, + -- ^ What kind of module (regular Haskell, hs-boot, hsig) + + tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming + tcg_default :: DefaultEnv, -- ^ All class defaults in scope in the module + tcg_default_exports :: DefaultEnv, -- ^ All class defaults exported from the module + + tcg_fix_env :: FixityEnv, -- ^ Just for things in this module + + tcg_type_env :: TypeEnv, + -- ^ Global type env for the module we are compiling now. All + -- TyCons and Classes (for this module) end up in here right away, + -- along with their derived constructors, selectors. + -- + -- (Ids defined in this module start in the local envt, though they + -- move to the global envt during zonking) + -- + -- NB: for what "things in this module" means, see + -- Note [The interactive package] in "GHC.Runtime.Context" + + tcg_type_env_var :: KnotVars (IORef TypeEnv), + -- Used only to initialise the interface-file + -- typechecker in initIfaceTcRn, so that it can see stuff + -- bound in this module when dealing with hi-boot recursions + -- Updated at intervals (e.g. after dealing with types and classes) + + tcg_inst_env :: !InstEnv, + -- ^ Instance envt for all /home-package/ modules; + -- Includes the dfuns in tcg_insts + -- NB. BangPattern is to fix a leak, see #15111 + tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances + -- NB. BangPattern is to fix a leak, see #15111 + tcg_ann_env :: AnnEnv, -- ^ And for annotations + tcg_complete_match_env :: CompleteMatches, + -- ^ The complete matches for all /home-package/ modules; + -- Includes the complete matches in tcg_complete_matches + + -- Now a bunch of things about this module that are simply + -- accumulated, but never consulted until the end. + -- Nevertheless, it's convenient to accumulate them along + -- with the rest of the info from this module. + tcg_exports :: [AvailInfo], -- ^ What is exported + tcg_imports :: ImportAvails, + -- ^ Information about what was imported from where, including + -- things bound in this module. Also store Safe Haskell info + -- here about transitive trusted package requirements. + -- + -- There are not many uses of this field, so you can grep for + -- all them. + -- + -- The ImportAvails records information about the following + -- things: + -- + -- 1. All of the modules you directly imported (tcRnImports) + -- 2. The orphans (only!) of all imported modules in a GHCi + -- session (runTcInteractive) + -- 3. The module that instantiated a signature + -- 4. Each of the signatures that merged in + -- + -- It is used in the following ways: + -- - imp_orphs is used to determine what orphan modules should be + -- visible in the context (tcVisibleOrphanMods) + -- - imp_finsts is used to determine what family instances should + -- be visible (tcExtendLocalFamInstEnv) + -- - To resolve the meaning of the export list of a module + -- (tcRnExports) + -- - imp_mods is used to compute usage info (mkIfaceTc, deSugar) + -- - imp_trust_own_pkg is used for Safe Haskell in interfaces + -- (mkIfaceTc, as well as in "GHC.Driver.Main") + -- - To create the Dependencies field in interface (mkDependencies) + + + -- This field tracks the user-written imports of a module, so they can be + -- recorded in an interface file in order to reconstruct the top-level environment + -- if necessary for GHCi. + tcg_import_decls :: ![ImportUserSpec], + + -- These three fields track unused bindings and imports + -- See Note [Tracking unused binding and imports] + tcg_dus :: DefUses, + tcg_used_gres :: TcRef [GlobalRdrElt], + -- ^ INVARIANT: all these GREs were imported; that is, + -- they all have a non-empty gre_imp field. + tcg_keep :: TcRef NameSet, + + tcg_th_used :: TcRef Bool, + -- ^ @True@ \<=> Template Haskell syntax used. + -- + -- We need this so that we can generate a dependency on the + -- Template Haskell package, because the desugarer is going + -- to emit loads of references to TH symbols. The reference + -- is implicit rather than explicit, so we have to zap a + -- mutable variable. + + tcg_th_needed_deps :: TcRef ([Linkable], PkgsLoaded), + -- ^ The set of runtime dependencies required by this module + -- See Note [Object File Dependencies] + + tcg_dfun_n :: TcRef OccSet, + -- ^ Allows us to choose unique DFun names. + + tcg_zany_n :: TcRef Integer, + -- ^ A source of unique identities for ZonkAny instances + -- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4) + + tcg_merged :: [(Module, Fingerprint)], + -- ^ The requirements we merged with; we always have to recompile + -- if any of these changed. + + -- The next fields accumulate the payload of the module + -- The binds, rules and foreign-decl fields are collected + -- initially in un-zonked form and are finally zonked in tcRnSrcDecls + + tcg_rn_exports :: Maybe [(LIE GhcRn, Avails)], + -- Nothing <=> no explicit export list + -- Is always Nothing if we don't want to retain renamed + -- exports. + -- If present contains each renamed export list item + -- together with its exported names. + + tcg_rn_imports :: [LImportDecl GhcRn], + -- Keep the renamed imports regardless. They are not + -- voluminous and are needed if you want to report unused imports + + tcg_rn_decls :: Maybe (HsGroup GhcRn), + -- ^ Renamed decls, maybe. @Nothing@ \<=> Don't retain renamed + -- decls. + + tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile + + tcg_th_topdecls :: TcRef [LHsDecl GhcPs], + -- ^ Top-level declarations from addTopDecls + + tcg_th_foreign_files :: TcRef [(ForeignSrcLang, FilePath)], + -- ^ Foreign files emitted from TH. + + tcg_th_topnames :: TcRef NameSet, + -- ^ Exact names bound in top-level declarations in tcg_th_topdecls + + tcg_th_modfinalizers :: TcRef [(TcLclEnv, ThModFinalizers)], + -- ^ Template Haskell module finalizers. + -- + -- They can use particular local environments. + + tcg_th_coreplugins :: TcRef [String], + -- ^ Core plugins added by Template Haskell code. + + tcg_th_state :: TcRef (Map TypeRep Dynamic), + tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))), + -- ^ Template Haskell state + + tcg_th_docs :: TcRef THDocs, + -- ^ Docs added in Template Haskell via @putDoc@. + + tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings + + -- Things defined in this module, or (in GHCi) + -- in the declarations for a single GHCi command. + -- For the latter, see Note [The interactive package] in + -- GHC.Runtime.Context + tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Unit.Module + -- for which every module has a top-level defn + -- except in GHCi in which case we have Nothing + tcg_binds :: LHsBinds GhcTc, -- Value bindings in this module + tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature + tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids + tcg_warns :: (Warnings GhcRn), -- ...Warnings and deprecations + tcg_anns :: [Annotation], -- ...Annotations + tcg_tcs :: [TyCon], -- ...TyCons and Classes + tcg_ksigs :: NameSet, -- ...Top-level TyCon names that *lack* a signature + tcg_insts :: [ClsInst], -- ...Instances + tcg_fam_insts :: [FamInst], -- ...Family instances + tcg_rules :: [LRuleDecl GhcTc], -- ...Rules + tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports + tcg_patsyns :: [PatSyn], -- ...Pattern synonyms + + tcg_hdr_info :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)), + -- ^ Maybe Haddock header docs and Maybe located module name + + tcg_self_boot :: SelfBootInfo, -- ^ Whether this module has a + -- corresponding hi-boot file + + tcg_main :: Maybe Name, -- ^ The Name of the main + -- function, if this module is + -- the main module. + + tcg_safe_infer :: TcRef Bool, + -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell)? + -- See Note [Safe Haskell Overlapping Instances Implementation], + -- although this is used for more than just that failure case. + + tcg_safe_infer_reasons :: TcRef (Messages TcRnMessage), + -- ^ Unreported reasons why tcg_safe_infer is False. + -- INVARIANT: If this Messages is non-empty, then tcg_safe_infer is False. + -- It may be that tcg_safe_infer is False but this is empty, if no reasons + -- are supplied (#19714), or if those reasons have already been + -- reported by GHC.Driver.Main.markUnsafeInfer + + tcg_tc_plugin_solvers :: [TcPluginSolver], + -- ^ A list of user-defined type-checking plugins for constraint solving. + + tcg_tc_plugin_rewriters :: UniqFM TyCon [TcPluginRewriter], + -- ^ A collection of all the user-defined type-checking plugins for rewriting + -- type family applications, collated by their type family 'TyCon's. + + tcg_defaulting_plugins :: [FillDefaulting], + -- ^ A list of user-defined plugins for type defaulting plugins. + + tcg_hf_plugins :: [HoleFitPlugin], + -- ^ A list of user-defined plugins for hole fit suggestions. + + tcg_top_loc :: RealSrcSpan, + -- ^ The RealSrcSpan this module came from + + tcg_static_wc :: TcRef WantedConstraints, + -- ^ Wanted constraints of static forms. + -- See Note [Constraints in static forms]. + tcg_complete_matches :: !CompleteMatches, + -- ^ Complete matches defined in this module. + + tcg_cc_st :: TcRef CostCentreState, + -- ^ Tracking indices for cost centre annotations + + tcg_next_wrapper_num :: TcRef (ModuleEnv Int) + -- ^ See Note [Generating fresh names for FFI wrappers] + } + +-- NB: topModIdentity, not topModSemantic! +-- Definition sites of orphan identities will be identity modules, not semantic +-- modules. + +-- Note [Constraints in static forms] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- When a static form produces constraints like +-- +-- f :: StaticPtr (Bool -> String) +-- f = static show +-- +-- we collect them in tcg_static_wc and resolve them at the end +-- of type checking. They need to be resolved separately because +-- we don't want to resolve them in the context of the enclosing +-- expression. Consider +-- +-- g :: Show a => StaticPtr (a -> String) +-- g = static show +-- +-- If the @Show a0@ constraint that the body of the static form produces was +-- resolved in the context of the enclosing expression, then the body of the +-- static form wouldn't be closed because the Show dictionary would come from +-- g's context instead of coming from the top level. + +tcVisibleOrphanMods :: TcGblEnv -> ModuleSet +tcVisibleOrphanMods tcg_env + = mkModuleSet (tcg_mod tcg_env : imp_orphs (tcg_imports tcg_env)) + +instance ContainsModule TcGblEnv where + extractModule env = tcg_semantic_mod env + +data SelfBootInfo + = NoSelfBoot -- No corresponding hi-boot file + | SelfBoot + { sb_mds :: ModDetails } -- There was a hi-boot file + +bootExports :: SelfBootInfo -> NameSet +bootExports boot = + case boot of + NoSelfBoot -> emptyNameSet + SelfBoot { sb_mds = mds} -> + let exports = md_exports mds + in availsToNameSet exports + + + +{- Note [Tracking unused binding and imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We gather three sorts of usage information + + * tcg_dus :: DefUses (defs/uses) + Records what is defined in this module and what is used. + + Records *defined* Names (local, top-level) + and *used* Names (local or imported) + + Used (a) to report "defined but not used" + (see GHC.Rename.Names.reportUnusedNames) + (b) to generate version-tracking usage info in interface + files (see GHC.Iface.Make.mkUsedNames) + This usage info is mainly gathered by the renamer's + gathering of free-variables + + * tcg_used_gres :: TcRef [GlobalRdrElt] + Records occurrences of imported entities. + + Used only to report unused import declarations + + Records each *occurrence* an *imported* (not locally-defined) entity. + The occurrence is recorded by keeping a GlobalRdrElt for it. + These is not the GRE that is in the GlobalRdrEnv; rather it + is recorded *after* the filtering done by pickGREs. So it reflect + /how that occurrence is in scope/. See Note [GRE filtering] in + RdrName. + + * tcg_keep :: TcRef NameSet + Records names of the type constructors, data constructors, and Ids that + are used by the constraint solver. + + The typechecker may use find that some imported or + locally-defined things are used, even though they + do not appear to be mentioned in the source code: + + (a) The to/from functions for generic data types + + (b) Top-level variables appearing free in the RHS of an + orphan rule + + (c) Top-level variables appearing free in a TH bracket + See Note [Keeping things alive for Template Haskell] + in GHC.Rename.Splice + + (d) The data constructor of a newtype that is used + to solve a Coercible instance (e.g. #10347). Example + module T10347 (N, mkN) where + import Data.Coerce + newtype N a = MkN Int + mkN :: Int -> N a + mkN = coerce + + Then we wish to record `MkN` as used, since it is (morally) + used to perform the coercion in `mkN`. To do so, the + Coercible solver updates tcg_keep's TcRef whenever it + encounters a use of `coerce` that crosses newtype boundaries. + + (e) Record fields that are used to solve HasField constraints + (see Note [Unused name reporting and HasField] in GHC.Tc.Instance.Class) + + The tcg_keep field is used in two distinct ways: + + * Desugar.addExportFlagsAndRules. Where things like (a-c) are locally + defined, we should give them an Exported flag, so that the + simplifier does not discard them as dead code, and so that they are + exposed in the interface file (but not to export to the user). + + * GHC.Rename.Names.reportUnusedNames. Where newtype data constructors + like (d) are imported, we don't want to report them as unused. +-} + + +{- Note [Given Insts] + ~~~~~~~~~~~~~~~~~~ +Because of GADTs, we have to pass inwards the Insts provided by type signatures +and existential contexts. Consider + data T a where { T1 :: b -> b -> T [b] } + f :: Eq a => T a -> Bool + f (T1 x y) = [x]==[y] + +The constructor T1 binds an existential variable 'b', and we need Eq [b]. +Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we +pass it inwards. + +-} + + +-- fixes #12177 +-- Builds up a list of bindings whose OccName has not been seen before +-- i.e., If ys = removeBindingShadowing xs +-- then +-- - ys is obtained from xs by deleting some elements +-- - ys has no duplicate OccNames +-- - The first duplicated OccName in xs is retained in ys +-- Overloaded so that it can be used for both GlobalRdrElt in typed-hole +-- substitutions and TcBinder when looking for relevant bindings. +removeBindingShadowing :: HasOccName a => [a] -> [a] +removeBindingShadowing bindings = reverse $ fst $ foldl + (\(bindingAcc, seenNames) binding -> + if occName binding `elemOccSet` seenNames -- if we've seen it + then (bindingAcc, seenNames) -- skip it + else (binding:bindingAcc, extendOccSet seenNames (occName binding))) + ([], emptyOccSet) bindings + + +-- | Get target platform +getPlatform :: TcRnIf a b Platform +getPlatform = targetPlatform <$> getDynFlags + + +--------------------------- +-- Arrow-notation context +--------------------------- + +{- Note [Escaping the arrow scope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In arrow notation, a variable bound by a proc (or enclosed let/kappa) +is not in scope to the left of an arrow tail (-<) or the head of (|..|). +For example + + proc x -> (e1 -< e2) + +Here, x is not in scope in e1, but it is in scope in e2. This can get +a bit complicated: + + let x = 3 in + proc y -> (proc z -> e1) -< e2 + +Here, x and z are in scope in e1, but y is not. + +We implement this by +recording the environment when passing a proc (using newArrowScope), +and returning to that (using escapeArrowScope) on the left of -< and the +head of (|..|). + +All this can be dealt with by the *renamer*. But the type checker needs +to be involved too. Example (arrowfail001) + class Foo a where foo :: a -> () + data Bar = forall a. Foo a => Bar a + get :: Bar -> () + get = proc x -> case x of Bar a -> foo -< a +Here the call of 'foo' gives rise to a (Foo a) constraint that should not +be captured by the pattern match on 'Bar'. Rather it should join the +constraints from further out. So we must capture the constraint bag +from further out in the ArrowCtxt that we push inwards. +-} + +{- +************************************************************************ +* * + Operations over ImportAvails +* * +************************************************************************ +-} + + +mkModDeps :: Set (UnitId, ModuleNameWithIsBoot) + -> InstalledModuleEnv ModuleNameWithIsBoot +mkModDeps deps = S.foldl' add emptyInstalledModuleEnv deps + where + add env (uid, elt) = extendInstalledModuleEnv env (mkModule uid (gwib_mod elt)) elt + +plusDirectModDeps :: InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot) + -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot) + -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot) +plusDirectModDeps = plusInstalledModuleEnv plus_mod_dep + where + plus_mod_dep (st1, r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 })) + (st2, r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2})) + | assertPpr (m1 == m2) ((ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot))) + boot1 == IsBoot = (st1 `S.union` st2, r2) + | otherwise = (st1 `S.union` st2, r1) + -- If either side can "see" a non-hi-boot interface, use that + -- Reusing existing tuples saves 10% of allocations on test + -- perf/compiler/MultiLayerModules + +plusModDeps :: InstalledModuleEnv ModuleNameWithIsBoot + -> InstalledModuleEnv ModuleNameWithIsBoot + -> InstalledModuleEnv ModuleNameWithIsBoot +plusModDeps = plusInstalledModuleEnv plus_mod_dep + where + plus_mod_dep r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 }) + r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2}) + | assertPpr (m1 == m2) ((ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot))) + boot1 == IsBoot = r2 + | otherwise = r1 + -- If either side can "see" a non-hi-boot interface, use that + -- Reusing existing tuples saves 10% of allocations on test + -- perf/compiler/MultiLayerModules + +emptyImportAvails :: ImportAvails +emptyImportAvails = ImportAvails { imp_mods = M.empty, + imp_direct_dep_mods = emptyInstalledModuleEnv, + imp_dep_direct_pkgs = S.empty, + imp_sig_mods = [], + imp_trust_pkgs = S.empty, + imp_trust_own_pkg = False, + imp_boot_mods = emptyInstalledModuleEnv, + imp_orphs = [], + imp_finsts = [] } + +-- | Union two ImportAvails +-- +-- This function is a key part of Import handling, basically +-- for each import we create a separate ImportAvails structure +-- and then union them all together with this function. +plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails +plusImportAvails + (ImportAvails { imp_mods = mods1, + imp_direct_dep_mods = ddmods1, + imp_dep_direct_pkgs = ddpkgs1, + imp_boot_mods = srs1, + imp_sig_mods = sig_mods1, + imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, + imp_orphs = orphs1, imp_finsts = finsts1 }) + (ImportAvails { imp_mods = mods2, + imp_direct_dep_mods = ddmods2, + imp_dep_direct_pkgs = ddpkgs2, + imp_boot_mods = srcs2, + imp_sig_mods = sig_mods2, + imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, + imp_orphs = orphs2, imp_finsts = finsts2 }) + = ImportAvails { imp_mods = M.unionWith (++) mods1 mods2, + imp_direct_dep_mods = ddmods1 `plusDirectModDeps` ddmods2, + imp_dep_direct_pkgs = ddpkgs1 `S.union` ddpkgs2, + imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, + imp_trust_own_pkg = tself1 || tself2, + imp_boot_mods = srs1 `plusModDeps` srcs2, + imp_sig_mods = unionListsOrd sig_mods1 sig_mods2, + imp_orphs = unionListsOrd orphs1 orphs2, + imp_finsts = unionListsOrd finsts1 finsts2 } + + +{- +Constraint Solver Plugins +------------------------- +-} + +-- | The @solve@ function of a type-checking plugin takes in Given +-- and Wanted constraints, and should return a 'TcPluginSolveResult' +-- indicating which Wanted constraints it could solve, or whether any are +-- insoluble. +type TcPluginSolver = EvBindsVar + -> [Ct] -- ^ Givens + -> [Ct] -- ^ Wanteds + -> TcPluginM TcPluginSolveResult + +-- | For rewriting type family applications, a type-checking plugin provides +-- a function of this type for each type family 'TyCon'. +-- +-- The function is provided with the current set of Given constraints, together +-- with the arguments to the type family. +-- The type family application will always be fully saturated. +type TcPluginRewriter + = RewriteEnv -- ^ Rewriter environment + -> [Ct] -- ^ Givens + -> [TcType] -- ^ type family arguments + -> TcPluginM TcPluginRewriteResult + +-- | 'TcPluginM' is the monad in which type-checking plugins operate. +newtype TcPluginM a = TcPluginM { runTcPluginM :: TcM a } + deriving newtype (Functor, Applicative, Monad, MonadFail) + +-- | This function provides an escape for direct access to +-- the 'TcM` monad. It should not be used lightly, and +-- the provided 'TcPluginM' API should be favoured instead. +unsafeTcPluginTcM :: TcM a -> TcPluginM a +unsafeTcPluginTcM = TcPluginM + +data TcPlugin = forall s. TcPlugin + { tcPluginInit :: TcPluginM s + -- ^ Initialize plugin, when entering type-checker. + + , tcPluginSolve :: s -> TcPluginSolver + -- ^ Solve some constraints. + -- + -- This function will be invoked at two points in the constraint solving + -- process: once to simplify Given constraints, and once to solve + -- Wanted constraints. In the first case (and only in the first case), + -- no Wanted constraints will be passed to the plugin. + -- + -- The plugin can either return a contradiction, + -- or specify that it has solved some constraints (with evidence), + -- and possibly emit additional constraints. These returned constraints + -- must be Givens in the first case, and Wanteds in the second. + -- + -- Use @ \\ _ _ _ _ -> pure $ TcPluginOk [] [] @ if your plugin + -- does not provide this functionality. + + , tcPluginRewrite :: s -> UniqFM TyCon TcPluginRewriter + -- ^ Rewrite saturated type family applications. + -- + -- The plugin is expected to supply a mapping from type family names to + -- rewriting functions. For each type family 'TyCon', the plugin should + -- provide a function which takes in the given constraints and arguments + -- of a saturated type family application, and return a possible rewriting. + -- See 'TcPluginRewriter' for the expected shape of such a function. + -- + -- Use @ \\ _ -> emptyUFM @ if your plugin does not provide this functionality. + + , tcPluginStop :: s -> TcPluginM () + -- ^ Clean up after the plugin, when exiting the type-checker. + } + +-- | The plugin found a contradiction. +-- The returned constraints are removed from the inert set, +-- and recorded as insoluble. +-- +-- The returned list of constraints should never be empty. +pattern TcPluginContradiction :: [Ct] -> TcPluginSolveResult +pattern TcPluginContradiction insols + = TcPluginSolveResult + { tcPluginInsolubleCts = insols + , tcPluginSolvedCts = [] + , tcPluginNewCts = [] } + +-- | The plugin has not found any contradictions, +-- +-- The first field is for constraints that were solved. +-- The second field contains new work, that should be processed by +-- the constraint solver. +pattern TcPluginOk :: [(EvTerm, Ct)] -> [Ct] -> TcPluginSolveResult +pattern TcPluginOk solved new + = TcPluginSolveResult + { tcPluginInsolubleCts = [] + , tcPluginSolvedCts = solved + , tcPluginNewCts = new } + +-- | Result of running a solver plugin. +data TcPluginSolveResult + = TcPluginSolveResult + { -- | Insoluble constraints found by the plugin. + -- + -- These constraints will be added to the inert set, + -- and reported as insoluble to the user. + tcPluginInsolubleCts :: [Ct] + -- | Solved constraints, together with their evidence. + -- + -- These are removed from the inert set, and the + -- evidence for them is recorded. + , tcPluginSolvedCts :: [(EvTerm, Ct)] + -- | New constraints that the plugin wishes to emit. + -- + -- These will be added to the work list. + , tcPluginNewCts :: [Ct] + } + +data TcPluginRewriteResult + = + -- | The plugin does not rewrite the type family application. + TcPluginNoRewrite + + -- | The plugin rewrites the type family application + -- providing a rewriting together with evidence: a 'Reduction', + -- which contains the rewritten type together with a 'Coercion' + -- whose right-hand-side type is the rewritten type. + -- + -- The plugin can also emit additional Wanted constraints. + | TcPluginRewriteTo + { tcPluginReduction :: !Reduction + , tcRewriterNewWanteds :: [Ct] + } + +-- | A collection of candidate default types for sets of type variables. +data DefaultingProposal + = DefaultingProposal + { deProposals :: [[(TcTyVar, Type)]] + -- ^ The type variable assignments to try. + , deProposalCts :: [Ct] + -- ^ The constraints against which defaults are checked. + } + +instance Outputable DefaultingProposal where + ppr p = text "DefaultingProposal" + <+> ppr (deProposals p) + <+> ppr (deProposalCts p) + +type FillDefaulting + = WantedConstraints + -- Zonked constraints containing the unfilled metavariables that + -- can be defaulted. See wrinkle (DP1) of Note [Defaulting plugins] + -- in GHC.Tc.Solver + -> TcPluginM [DefaultingProposal] + +-- | A plugin for controlling defaulting. +data DefaultingPlugin = forall s. DefaultingPlugin + { dePluginInit :: TcPluginM s + -- ^ Initialize plugin, when entering type-checker. + , dePluginRun :: s -> FillDefaulting + -- ^ Default some types + , dePluginStop :: s -> TcPluginM () + -- ^ Clean up after the plugin, when exiting the type-checker. + } + +{- ********************************************************************* +* * + Role annotations +* * +********************************************************************* -} + +type RoleAnnotEnv = NameEnv (LRoleAnnotDecl GhcRn) + +mkRoleAnnotEnv :: [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv +mkRoleAnnotEnv role_annot_decls + = mkNameEnv [ (name, ra_decl) + | ra_decl <- role_annot_decls + , let name = roleAnnotDeclName (unLoc ra_decl) + , not (isUnboundName name) ] + -- Some of the role annots will be unbound; + -- we don't wish to include these + +emptyRoleAnnotEnv :: RoleAnnotEnv +emptyRoleAnnotEnv = emptyNameEnv + +lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn) +lookupRoleAnnot = lookupNameEnv + +getRoleAnnots :: [Name] -> RoleAnnotEnv -> [LRoleAnnotDecl GhcRn] +getRoleAnnots bndrs role_env + = mapMaybe (lookupRoleAnnot role_env) bndrs + +{- ********************************************************************* +* * + Linting a TcGblEnv +* * +********************************************************************* -} + +-- | Check the 'TcGblEnv' for consistency. Currently, only checks +-- axioms, but should check other aspects, too. +lintGblEnv :: Logger -> DynFlags -> TcGblEnv -> TcM () +lintGblEnv logger dflags tcg_env = + -- TODO empty list means no extra in scope from GHCi, is this correct? + liftIO $ lintAxioms logger (initLintConfig dflags []) (text "TcGblEnv axioms") axioms + where + axioms = typeEnvCoAxioms (tcg_type_env tcg_env) + +-- | This is a mirror of Template Haskell's DocLoc, but the TH names are +-- resolved to GHC names. +data DocLoc = DeclDoc Name + | ArgDoc Name Int + | InstDoc Name + | ModuleDoc + deriving (Eq, Ord) + +-- | The current collection of docs that Template Haskell has built up via +-- putDoc. +type THDocs = Map DocLoc (HsDoc GhcRn) diff --git a/GHC/Tc/Types/BasicTypes.hs b/GHC/Tc/Types/BasicTypes.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/BasicTypes.hs @@ -0,0 +1,524 @@ +module GHC.Tc.Types.BasicTypes ( + -- * TcBinder + TcBinderStack + , TcId + , TcBinder(..) + + -- * Signatures + , TcSigFun, TcSigInfo(..), TcIdSig(..) + , TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..) + , TcIdSigInst(..) + , isPartialSig, hasCompleteSig + , tcSigInfoName, tcIdSigLoc, completeSigPolyId_maybe + + -- * TcTyThing + , TcTyThing(..) + , IdBindingInfo(..) + , IsGroupClosed(..) + , RhsNames + , ClosedTypeId + , tcTyThingCategory + , tcTyThingTyCon_maybe + , pprTcTyThingCategory + ) where + +import GHC.Prelude + +import GHC.Tc.Types.Origin( UserTypeCtxt ) +import GHC.Tc.Utils.TcType + +import GHC.Types.Id +import GHC.Types.Basic +import GHC.Types.Var +import GHC.Types.SrcLoc +import GHC.Types.Name +import GHC.Types.TyThing +import GHC.Types.Name.Env +import GHC.Types.Name.Set + +import GHC.Hs.Extension ( GhcRn ) + +import Language.Haskell.Syntax.Type ( LHsSigWcType ) + +import GHC.Tc.Errors.Types.PromotionErr (PromotionErr, peCategory) + +import GHC.Core.TyCon ( TyCon, tyConKind ) +import GHC.Utils.Outputable +import GHC.Utils.Misc + + +--------------------------- +-- The TcBinderStack +--------------------------- + +type TcBinderStack = [TcBinder] +type TcId = Id + -- This is a stack of locally-bound ids and tyvars, + -- innermost on top + -- Used only in error reporting (relevantBindings in TcError), + -- and in tidying + -- We can't use the tcl_env type environment, because it doesn't + -- keep track of the nesting order + +data TcBinder + = TcIdBndr + TcId + TopLevelFlag -- Tells whether the binding is syntactically top-level + -- (The monomorphic Ids for a recursive group count + -- as not-top-level for this purpose.) + + | TcIdBndr_ExpType -- Variant that allows the type to be specified as + -- an ExpType + Name + ExpType + TopLevelFlag + + | TcTvBndr -- e.g. case x of P (y::a) -> blah + Name -- We bind the lexical name "a" to the type of y, + TyVar -- which might be an utterly different (perhaps + -- existential) tyvar + +instance Outputable TcBinder where + ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl) + ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl) + ppr (TcTvBndr name tv) = ppr name <+> ppr tv + +instance HasOccName TcBinder where + occName (TcIdBndr id _) = occName (idName id) + occName (TcIdBndr_ExpType name _ _) = occName name + occName (TcTvBndr name _) = occName name + +{- ********************************************************************* +* * + Type signatures +* * +********************************************************************* -} + +-- These data types need to be here only because +-- GHC.Tc.Solver uses them, and GHC.Tc.Solver is fairly +-- low down in the module hierarchy + +type TcSigFun = Name -> Maybe TcSigInfo + +-- TcSigInfo is simply the range of TcSigFun +data TcSigInfo = TcIdSig TcIdSig + | TcPatSynSig TcPatSynSig -- For a pattern synonym + +-- See Note [Complete and partial type signatures] +data TcIdSig -- For an Id + = TcCompleteSig TcCompleteSig + | TcPartialSig TcPartialSig + +data TcCompleteSig -- A complete signature with no wildcards, + -- so the complete polymorphic type is known. + = CSig { sig_bndr :: TcId -- The polymorphic Id with that type + + , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods, + -- the Name in the FunSigCtxt is not the same + -- as the TcId; the former is 'op', while the + -- latter is '$dmop' or some such + + , sig_loc :: SrcSpan -- Location of the type signature + } + +data TcPartialSig -- A partial type signature (i.e. includes one or more + -- wildcards). In this case it doesn't make sense to give + -- the polymorphic Id, because we are going to /infer/ its + -- type, so we can't make the polymorphic Id ab-initio + = PSig { psig_name :: Name -- Name of the function; used when report wildcards + , psig_hs_ty :: LHsSigWcType GhcRn -- The original partial signature in + -- HsSyn form + , psig_ctxt :: UserTypeCtxt + , psig_loc :: SrcSpan -- Location of the type signature + } + +data TcPatSynSig + = PatSig { + patsig_name :: Name, + patsig_implicit_bndrs :: [InvisTVBinder], -- Implicitly-bound kind vars (Inferred) and + -- implicitly-bound type vars (Specified) + -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.TyCl.PatSyn + patsig_univ_bndrs :: [InvisTVBinder], -- Bound by explicit user forall + patsig_req :: TcThetaType, + patsig_ex_bndrs :: [InvisTVBinder], -- Bound by explicit user forall + patsig_prov :: TcThetaType, + patsig_body_ty :: TcSigmaType + } + +{- Note [Complete and partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type signature is partial when it contains one or more wildcards +(= type holes). The wildcard can either be: +* A (type) wildcard occurring in sig_theta or sig_tau. These are + stored in sig_wcs. + f :: Bool -> _ + g :: Eq _a => _a -> _a -> Bool +* Or an extra-constraints wildcard, stored in sig_cts: + h :: (Num a, _) => a -> a + +A type signature is a complete type signature when there are no +wildcards in the type signature, i.e. iff sig_wcs is empty and +sig_extra_cts is Nothing. +-} + +data TcIdSigInst + = TISI { sig_inst_sig :: TcIdSig + + , sig_inst_skols :: [(Name, InvisTVBinder)] + -- Instantiated type and kind variables, TyVarTvs + -- The Name is the Name that the renamer chose; + -- but the TcTyVar may come from instantiating + -- the type and hence have a different unique. + -- No need to keep track of whether they are truly lexically + -- scoped because the renamer has named them uniquely + -- See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig + -- + -- NB: The order of sig_inst_skols is irrelevant + -- for a CompleteSig, but for a PartialSig see + -- Note [Quantified variables in partial type signatures] + + , sig_inst_theta :: TcThetaType + -- Instantiated theta. In the case of a + -- PartialSig, sig_theta does not include + -- the extra-constraints wildcard + + , sig_inst_tau :: TcSigmaType -- Instantiated tau + -- See Note [sig_inst_tau may be polymorphic] + + -- Relevant for partial signature only + , sig_inst_wcs :: [(Name, TcTyVar)] + -- Like sig_inst_skols, but for /named/ wildcards (_a etc). + -- The named wildcards scope over the binding, and hence + -- their Names may appear in type signatures in the binding + + , sig_inst_wcx :: Maybe TcType + -- Extra-constraints wildcard to fill in, if any + -- If this exists, it is surely of the form (meta_tv |> co) + -- (where the co might be reflexive). This is filled in + -- only from the return value of GHC.Tc.Gen.HsType.tcAnonWildCardOcc + } + +{- Note [sig_inst_tau may be polymorphic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that "sig_inst_tau" might actually be a polymorphic type, +if the original function had a signature like + forall a. Eq a => forall b. Ord b => .... +But that's ok: tcFunBindMatches (called by tcRhs) can deal with that +It happens, too! See Note [Polymorphic methods] in GHC.Tc.TyCl.Class. + +Note [Quantified variables in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a b. _ -> a -> _ -> b + f (x,y) p q = q + +Then we expect f's final type to be + f :: forall {x,y}. forall a b. (x,y) -> a -> b -> b + +Note that x,y are Inferred, and can't be use for visible type +application (VTA). But a,b are Specified, and remain Specified +in the final type, so we can use VTA for them. (Exception: if +it turns out that a's kind mentions b we need to reorder them +with scopedSort.) + +The sig_inst_skols of the TISI from a partial signature records +that original order, and is used to get the variables of f's +final type in the correct order. + + +Note [Wildcards in partial signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The wildcards in psig_wcs may stand for a type mentioning +the universally-quantified tyvars of psig_ty + +E.g. f :: forall a. _ -> a + f x = x +We get sig_inst_skols = [a] + sig_inst_tau = _22 -> a + sig_inst_wcs = [_22] +and _22 in the end is unified with the type 'a' + +Moreover the kind of a wildcard in sig_inst_wcs may mention +the universally-quantified tyvars sig_inst_skols +e.g. f :: t a -> t _ +Here we get + sig_inst_skols = [k:*, (t::k ->*), (a::k)] + sig_inst_tau = t a -> t _22 + sig_inst_wcs = [ _22::k ] +-} + +instance Outputable TcSigInfo where + ppr (TcIdSig sig) = ppr sig + ppr (TcPatSynSig sig) = ppr sig + +instance Outputable TcIdSig where + ppr (TcCompleteSig sig) = ppr sig + ppr (TcPartialSig sig) = ppr sig + +instance Outputable TcCompleteSig where + ppr (CSig { sig_bndr = bndr }) + = ppr bndr <+> dcolon <+> ppr (idType bndr) + +instance Outputable TcPartialSig where + ppr (PSig { psig_name = name, psig_hs_ty = hs_ty }) + = text "[partial signature]" <+> ppr name <+> dcolon <+> ppr hs_ty + +instance Outputable TcPatSynSig where + ppr (PatSig { patsig_name = name}) = ppr name + +instance Outputable TcIdSigInst where + ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols + , sig_inst_theta = theta, sig_inst_tau = tau }) + = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ]) + +isPartialSig :: TcIdSigInst -> Bool +isPartialSig (TISI { sig_inst_sig = TcPartialSig {} }) = True +isPartialSig _ = False + +-- | No signature or a partial signature +hasCompleteSig :: TcSigFun -> Name -> Bool +hasCompleteSig sig_fn name + = case sig_fn name of + Just (TcIdSig (TcCompleteSig {})) -> True + _ -> False + +tcSigInfoName :: TcSigInfo -> Name +tcSigInfoName (TcIdSig (TcCompleteSig sig)) = idName (sig_bndr sig) +tcSigInfoName (TcIdSig (TcPartialSig sig)) = psig_name sig +tcSigInfoName (TcPatSynSig sig) = patsig_name sig + +tcIdSigLoc :: TcIdSig -> SrcSpan +tcIdSigLoc (TcCompleteSig sig) = sig_loc sig +tcIdSigLoc (TcPartialSig sig) = psig_loc sig + +completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId +completeSigPolyId_maybe (TcIdSig (TcCompleteSig sig)) = Just (sig_bndr sig) +completeSigPolyId_maybe _ = Nothing + +{- ********************************************************************* +* * + TcTyThing +* * +********************************************************************* -} + +-- | A typecheckable thing available in a local context. Could be +-- 'AGlobal' 'TyThing', but also lexically scoped variables, etc. +-- See "GHC.Tc.Utils.Env" for how to retrieve a 'TyThing' given a 'Name'. +data TcTyThing + = AGlobal TyThing -- Used only in the return type of a lookup + + | ATcId -- Ids defined in this module; may not be fully zonked + { tct_id :: Id + , tct_info :: IdBindingInfo -- See Note [Meaning of IdBindingInfo] + } + + | ATyVar Name TcTyVar -- See Note [Type variables in the type environment] + + | ATcTyCon TyCon -- Used temporarily, during kind checking, for the + -- tycons and classes in this recursive group + -- The TyCon is always a TcTyCon. Its kind + -- can be a mono-kind or a poly-kind; in TcTyClsDcls see + -- Note [Type checking recursive type and class declarations] + + | APromotionErr PromotionErr + +-- | Matches on either a global 'TyCon' or a 'TcTyCon'. +tcTyThingTyCon_maybe :: TcTyThing -> Maybe TyCon +tcTyThingTyCon_maybe (AGlobal (ATyCon tc)) = Just tc +tcTyThingTyCon_maybe (ATcTyCon tc_tc) = Just tc_tc +tcTyThingTyCon_maybe _ = Nothing + +instance Outputable TcTyThing where -- Debugging only + ppr (AGlobal g) = ppr g + ppr elt@(ATcId {}) = text "Identifier" <> + brackets (ppr (tct_id elt) <> dcolon + <> ppr (varType (tct_id elt)) <> comma + <+> ppr (tct_info elt)) + ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv + <+> dcolon <+> ppr (varType tv) + ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) + ppr (APromotionErr err) = text "APromotionErr" <+> ppr err + +-- | IdBindingInfo describes how an Id is bound. +-- +-- It is used for the following purposes: +-- a) for static forms in 'GHC.Tc.Gen.Expr.checkClosedInStaticForm' and +-- b) to figure out when a nested binding can be generalised, +-- in 'GHC.Tc.Gen.Bind.decideGeneralisationPlan'. +-- +data IdBindingInfo -- See Note [Meaning of IdBindingInfo] + = NotLetBound + | ClosedLet + | NonClosedLet + RhsNames -- Used for (static e) checks only + ClosedTypeId -- Used for generalisation checks + -- and for (static e) checks + +-- | IsGroupClosed describes a group of mutually-recursive bindings +data IsGroupClosed + = IsGroupClosed + (NameEnv RhsNames) -- Free var info for the RHS of each binding in the group + -- Used only for (static e) checks + + ClosedTypeId -- True <=> all the free vars of the group are + -- imported or ClosedLet or + -- NonClosedLet with ClosedTypeId=True. + -- In particular, no tyvars, no NotLetBound + +type RhsNames = NameSet -- Names of variables, mentioned on the RHS of + -- a definition, that are not Global or ClosedLet + +type ClosedTypeId = Bool + -- See Note [Meaning of IdBindingInfo] + +{- Note [Meaning of IdBindingInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NotLetBound means that + the Id is not let-bound (e.g. it is bound in a + lambda-abstraction or in a case pattern) + +ClosedLet means that + - The Id is let-bound, + - Any free term variables are also Global or ClosedLet + - Its type has no free variables (NB: a top-level binding subject + to the MR might have free vars in its type) + These ClosedLets can definitely be floated to top level; and we + may need to do so for static forms. + + Property: ClosedLet + is equivalent to + NonClosedLet emptyNameSet True + +(NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that + - The Id is let-bound + + - The fvs::RhsNames contains the free names of the RHS, + excluding Global and ClosedLet ones. + + - For the ClosedTypeId field see Note [Bindings with closed types: ClosedTypeId] + +For (static e) to be valid, we need for every 'x' free in 'e', +that x's binding is floatable to the top level. Specifically: + * x's RhsNames must be empty + * x's type has no free variables +See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". +This test is made in GHC.Tc.Gen.Expr.checkClosedInStaticForm. +Actually knowing x's RhsNames (rather than just its emptiness +or otherwise) is just so we can produce better error messages + +Note [Bindings with closed types: ClosedTypeId] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + f x = let g ys = map not ys + in ... + +Can we generalise 'g' under the OutsideIn algorithm? Yes, +because all g's free variables are top-level; that is they themselves +have no free type variables, and it is the type variables in the +environment that makes things tricky for OutsideIn generalisation. + +Here's the invariant: + If an Id has ClosedTypeId=True (in its IdBindingInfo), then + the Id's type is /definitely/ closed (has no free type variables). + Specifically, + a) The Id's actual type is closed (has no free tyvars) + b) Either the Id has a (closed) user-supplied type signature + or all its free variables are Global/ClosedLet + or NonClosedLet with ClosedTypeId=True. + In particular, none are NotLetBound. + +Why is (b) needed? Consider + \x. (x :: Int, let y = x+1 in ...) +Initially x::alpha. If we happen to typecheck the 'let' before the +(x::Int), y's type will have a free tyvar; but if the other way round +it won't. So we treat any let-bound variable with a free +non-let-bound variable as not ClosedTypeId, regardless of what the +free vars of its type actually are. + +But if it has a signature, all is well: + \x. ...(let { y::Int; y = x+1 } in + let { v = y+2 } in ...)... +Here the signature on 'v' makes 'y' a ClosedTypeId, so we can +generalise 'v'. + +Note that: + + * A top-level binding may not have ClosedTypeId=True, if it suffers + from the MR + + * A nested binding may be closed (eg 'g' in the example we started + with). Indeed, that's the point; whether a function is defined at + top level or nested is orthogonal to the question of whether or + not it is closed. + + * A binding may be non-closed because it mentions a lexically scoped + *type variable* Eg + f :: forall a. blah + f x = let g y = ...(y::a)... + +Under OutsideIn we are free to generalise an Id all of whose free +variables have ClosedTypeId=True (or imported). This is an extension +compared to the JFP paper on OutsideIn, which used "top-level" as a +proxy for "closed". (It's not a good proxy anyway -- the MR can make +a top-level binding with a free type variable.) + +Note [Type variables in the type environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type environment has a binding for each lexically-scoped +type variable that is in scope. For example + + f :: forall a. a -> a + f x = (x :: a) + + g1 :: [a] -> a + g1 (ys :: [b]) = head ys :: b + + g2 :: [Int] -> Int + g2 (ys :: [c]) = head ys :: c + +* The forall'd variable 'a' in the signature scopes over f's RHS. + +* The pattern-bound type variable 'b' in 'g1' scopes over g1's + RHS; note that it is bound to a skolem 'a' which is not itself + lexically in scope. + +* The pattern-bound type variable 'c' in 'g2' is bound to + Int; that is, pattern-bound type variables can stand for + arbitrary types. (see + GHC proposal #128 "Allow ScopedTypeVariables to refer to types" + https://github.com/ghc-proposals/ghc-proposals/pull/128, + and the paper + "Type variables in patterns", Haskell Symposium 2018. + + +This is implemented by the constructor + ATyVar Name TcTyVar +in the type environment. + +* The Name is the name of the original, lexically scoped type + variable + +* The TcTyVar is sometimes a skolem (like in 'f'), and sometimes + a unification variable (like in 'g1', 'g2'). We never zonk the + type environment so in the latter case it always stays as a + unification variable, although that variable may be later + unified with a type (such as Int in 'g2'). +-} + +instance Outputable IdBindingInfo where + ppr NotLetBound = text "NotLetBound" + ppr ClosedLet = text "TopLevelLet" + ppr (NonClosedLet fvs closed_type) = + text "TopLevelLet" <+> ppr fvs <+> ppr closed_type + +-------------- +pprTcTyThingCategory :: TcTyThing -> SDoc +pprTcTyThingCategory = text . capitalise . tcTyThingCategory + +tcTyThingCategory :: TcTyThing -> String +tcTyThingCategory (AGlobal thing) = tyThingCategory thing +tcTyThingCategory (ATyVar {}) = "type variable" +tcTyThingCategory (ATcId {}) = "local identifier" +tcTyThingCategory (ATcTyCon {}) = "local tycon" +tcTyThingCategory (APromotionErr pe) = peCategory pe diff --git a/GHC/Tc/Types/Constraint.hs b/GHC/Tc/Types/Constraint.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/Constraint.hs @@ -0,0 +1,2739 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} + +-- | This module defines types and simple operations over constraints, as used +-- in the type-checker and constraint solver. +module GHC.Tc.Types.Constraint ( + -- Constraints + Xi, Ct(..), Cts, + singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, + isEmptyCts, emptyCts, andCts, ctsPreds, + isPendingScDictCt, isPendingScDict, pendingScDict_maybe, + superClassesMightHelp, getPendingWantedScs, + isWantedCt, isGivenCt, + isTopLevelUserTypeError, containsUserTypeError, getUserTypeErrorMsg, + isUnsatisfiableCt_maybe, + ctEvidence, updCtEvidence, + ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, + ctRewriters, ctHasNoRewriters, wantedCtHasNoRewriters, + ctEvId, wantedEvId_maybe, mkTcEqPredLikeEv, + mkNonCanonical, mkGivens, + tyCoVarsOfCt, tyCoVarsOfCts, + tyCoVarsOfCtList, tyCoVarsOfCtsList, + boundOccNamesOfWC, + + -- Particular forms of constraint + EqCt(..), eqCtEvidence, eqCtLHS, + DictCt(..), dictCtEvidence, dictCtPred, + IrredCt(..), irredCtEvidence, mkIrredCt, ctIrredCt, irredCtPred, + + -- QCInst + QCInst(..), pendingScInst_maybe, + + ExpansionFuel, doNotExpand, consumeFuel, pendingFuel, + assertFuelPrecondition, assertFuelPreconditionStrict, + + CtIrredReason(..), isInsolubleReason, + + CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck, + cteOK, cteImpredicative, cteTypeFamily, + cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble, + cteConcrete, cteSkolemEscape, + impredicativeProblem, insolubleOccursProblem, solubleOccursProblem, + + cterHasNoProblem, cterHasProblem, cterHasOnlyProblem, cterHasOnlyProblems, + cterRemoveProblem, cterHasOccursCheck, cterFromKind, + + -- Equality left-hand sides, re-exported from GHC.Core.Predicate + CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe, + canEqLHSKind, canEqLHSType, eqCanEqLHS, + + -- Holes + Hole(..), HoleSort(..), isOutOfScopeHole, + DelayedError(..), NotConcreteError(..), + + WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, + isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC, + addInsols, dropMisleading, addSimples, addImplics, addHoles, + addNotConcreteError, addMultiplicityCoercionError, addDelayedErrors, + tyCoVarsOfWC, tyCoVarsOfWCList, + insolubleWantedCt, insolubleCt, insolubleIrredCt, + insolubleImplic, nonDefaultableTyVarsOfWC, + approximateWCX, approximateWC, + + Implication(..), implicationPrototype, checkTelescopeSkol, + ImplicStatus(..), isInsolubleStatus, isSolvedStatus, + UserGiven, getUserGivensFromImplics, + HasGivenEqs(..), checkImplicationInvariants, + EvNeedSet(..), emptyEvNeedSet, unionEvNeedSet, extendEvNeedSet, delGivensFromEvNeedSet, + + -- CtLocEnv + CtLocEnv(..), setCtLocEnvLoc, setCtLocEnvLvl, getCtLocEnvLoc, getCtLocEnvLvl, ctLocEnvInGeneratedCode, + + -- CtEvidence + CtEvidence(..), TcEvDest(..), + isWanted, isGiven, + ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, + ctEvExpr, ctEvTerm, + ctEvCoercion, givenCtEvCoercion, + ctEvEvId, wantedCtEvEvId, + ctEvRewriters, setWantedCtEvRewriters, ctEvUnique, tcEvDestUnique, + ctEvRewriteRole, ctEvRewriteEqRel, setCtEvPredType, setCtEvLoc, + tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList, + + -- CtEvidence constructors + GivenCtEvidence(..), WantedCtEvidence(..), + + -- RewriterSet + RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet, + -- exported concretely only for zonkRewriterSet + addRewriter, unitRewriterSet, unionRewriterSet, rewriterSetFromCts, + + wrapType, + + CtFlavour(..), ctEvFlavour, + CtFlavourRole, ctEvFlavourRole, ctFlavourRole, eqCtFlavourRole, + eqCanRewrite, eqCanRewriteFR, + + -- Pretty printing + pprEvVarTheta, + pprEvVars, pprEvVarWithType, + + ) + where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr + +import GHC.Types.Name +import GHC.Types.Var + +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Tc.Types.CtLoc + +import GHC.Builtin.Names + +import GHC.Types.Var.Set +import GHC.Types.Unique.Set +import GHC.Types.Name.Reader + +import GHC.Utils.FV +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) + +import GHC.Data.Bag + +import Data.Coerce +import qualified Data.Semigroup as S +import Control.Monad ( msum, when ) +import Data.Maybe ( mapMaybe, isJust ) + +-- these are for CheckTyEqResult +import Data.Word ( Word8 ) +import Data.List ( intersperse ) + + + +{- +************************************************************************ +* * +* Canonical constraints * +* * +* These are the constraints the low-level simplifier works with * +* * +************************************************************************ +-} + +-- | A 'Xi'-type is one that has been fully rewritten with respect +-- to the inert set; that is, it has been rewritten by the algorithm +-- in GHC.Tc.Solver.Rewrite. (Historical note: 'Xi', for years and years, +-- meant that a type was type-family-free. It does *not* mean this +-- any more.) +type Xi = TcType + +type Cts = Bag Ct + +-- | Says how many layers of superclasses can we expand. +-- Invariant: ExpansionFuel should always be >= 0 +-- see Note [Expanding Recursive Superclasses and ExpansionFuel] +type ExpansionFuel = Int + +-- | Do not expand superclasses any further +doNotExpand :: ExpansionFuel +doNotExpand = 0 + +-- | Consumes one unit of fuel. +-- Precondition: fuel > 0 +consumeFuel :: ExpansionFuel -> ExpansionFuel +consumeFuel fuel = assertFuelPreconditionStrict fuel $ fuel - 1 + +-- | Returns True if we have any fuel left for superclass expansion +pendingFuel :: ExpansionFuel -> Bool +pendingFuel n = n > 0 + +insufficientFuelError :: SDoc +insufficientFuelError = text "Superclass expansion fuel should be > 0" + +-- | asserts if fuel is non-negative +assertFuelPrecondition :: ExpansionFuel -> a -> a +{-# INLINE assertFuelPrecondition #-} +assertFuelPrecondition fuel = assertPpr (fuel >= 0) insufficientFuelError + +-- | asserts if fuel is strictly greater than 0 +assertFuelPreconditionStrict :: ExpansionFuel -> a -> a +{-# INLINE assertFuelPreconditionStrict #-} +assertFuelPreconditionStrict fuel = assertPpr (pendingFuel fuel) insufficientFuelError + +-- | Constraint +data Ct + -- | A dictionary constraint (canonical) + = CDictCan DictCt + -- | An irreducible constraint (non-canonical) + | CIrredCan IrredCt + -- | An equality constraint (canonical) + | CEqCan EqCt + -- | A quantified constraint (canonical) + | CQuantCan QCInst + -- | A non-canonical constraint + -- + -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad + | CNonCanonical CtEvidence + +--------------- DictCt -------------- + +-- | A canonical dictionary constraint +data DictCt -- e.g. Num ty + = DictCt { di_ev :: CtEvidence -- See Note [Ct/evidence invariant] + + , di_cls :: Class + , di_tys :: [Xi] -- di_tys are rewritten w.r.t. inerts, so Xi + + , di_pend_sc :: ExpansionFuel + -- See Note [The superclass story] in GHC.Tc.Solver.Dict + -- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver + -- Invariants: di_pend_sc > 0 <=> + -- (a) di_cls has superclasses + -- (b) those superclasses are not yet explored + } + +dictCtEvidence :: DictCt -> CtEvidence +dictCtEvidence = di_ev + +dictCtPred :: DictCt -> TcPredType +dictCtPred (DictCt { di_cls = cls, di_tys = tys }) = mkClassPred cls tys + +instance Outputable DictCt where + ppr dict = ppr (CDictCan dict) + +--------------- EqCt -------------- + +{- Note [Canonical equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An EqCt is a canonical equality constraint, one that can live in the inert set, +and that can be used to rewrite other constraints. It satisfies these invariants: + + * (TyEq:OC) lhs does not occur in rhs (occurs check) + Note [EqCt occurs check] + + * (TyEq:F) rhs has no foralls + (this avoids substituting a forall for the tyvar in other types) + + * (TyEq:K) typeKind lhs `tcEqKind` typeKind rhs; Note [Ct kind invariant] + + * (TyEq:N) If the equality is representational, rhs is not headed by a saturated + application of a newtype TyCon. See GHC.Tc.Solver.Equality + Note [No top-level newtypes on RHS of representational equalities]. + (Applies only when constructor of newtype is in scope.) + + * (TyEq:U) An EqCt is not immediately unifiable. If we can unify a:=ty, we + will not form an EqCt (a ~ ty). + + * (TyEq:CH) rhs does not mention any coercion holes that resulted from fixing up + a hetero-kinded equality. See Note [Equalities with heterogeneous kinds] in + GHC.Tc.Solver.Equality, wrinkle (EIK2) + +These invariants ensure that the EqCts in inert_eqs constitute a terminating +generalised substitution. See Note [inert_eqs: the inert equalities] +in GHC.Tc.Solver.InertSet for what these words mean! + +Note [EqCt occurs check] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A CEqCan relates a CanEqLHS (a type variable or type family applications) on +its left to an arbitrary type on its right. It is used for rewriting. +Because it is used for rewriting, it would be disastrous if the RHS +were to mention the LHS: this would cause a loop in rewriting. + +We thus perform an occurs-check. There is, of course, some subtlety: + +* For type variables, the occurs-check looks deeply including kinds of + type variables. This is because a CEqCan over a meta-variable is + also used to inform unification, via `checkTyEqRhs`, called in + `canEqCanLHSFinish_try_unification`. + If the LHS appears anywhere in the RHS, at all, unification will create + an infinite structure, which is bad. + +* For type family applications, the occurs-check is shallow; it looks + only in places where we might rewrite. (Specifically, it does not + look in kinds or coercions.) An occurrence of the LHS in, say, an + RHS coercion is OK, as we do not rewrite in coercions. No loop to + be found. + + You might also worry about the possibility that a type family + application LHS doesn't exactly appear in the RHS, but something + that reduces to the LHS does. Yet that can't happen: the RHS is + already inert, with all type family redexes reduced. So a simple + syntactic check is just fine. + +The occurs check is performed in GHC.Tc.Utils.Unify.checkTyEqRhs +and forms condition T3 in Note [Extending the inert equalities] +in GHC.Tc.Solver.InertSet. +-} + +-- | A canonical equality constraint. +-- +-- See Note [Canonical equalities] in GHC.Tc.Types.Constraint. +data EqCt + = EqCt { -- CanEqLHS ~ rhs + eq_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + eq_lhs :: CanEqLHS, + eq_rhs :: Xi, -- See invariants above + eq_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev + } + +eqCtEvidence :: EqCt -> CtEvidence +eqCtEvidence = eq_ev + +eqCtLHS :: EqCt -> CanEqLHS +eqCtLHS = eq_lhs + +--------------- IrredCt -------------- + +data IrredCt -- These stand for yet-unusable predicates + -- See Note [CIrredCan constraints] + = IrredCt { ir_ev :: CtEvidence -- See Note [Ct/evidence invariant] + , ir_reason :: CtIrredReason } + +mkIrredCt :: CtIrredReason -> CtEvidence -> Ct +mkIrredCt reason ev = CIrredCan (IrredCt { ir_ev = ev, ir_reason = reason }) + +irredCtEvidence :: IrredCt -> CtEvidence +irredCtEvidence = ir_ev + +irredCtPred :: IrredCt -> PredType +irredCtPred = ctEvPred . irredCtEvidence + +ctIrredCt :: CtIrredReason -> Ct -> IrredCt +ctIrredCt _ (CIrredCan ir) = ir +ctIrredCt reason ct = IrredCt { ir_ev = ctEvidence ct + , ir_reason = reason } + +instance Outputable IrredCt where + ppr irred = ppr (CIrredCan irred) + +--------------- QCInst -------------- + +-- | A quantified constraint, also called a "local instance" +-- (a simplified version of 'ClsInst'). +-- +-- See Note [Quantified constraints] in GHC.Tc.Solver.Solve +data QCInst + -- | A quantified constraint, of type @forall tvs. context => ty@ + = QCI { qci_ev :: CtEvidence -- See Note [Ct/evidence invariant] + , qci_tvs :: [TcTyVar] -- ^ @tvs@ + , qci_theta :: TcThetaType + , qci_body :: TcPredType -- ^ the body of the @forall@, i.e. @ty@ + , qci_pend_sc :: ExpansionFuel + -- ^ Invariants: qci_pend_sc > 0 => + -- + -- (a) 'qci_body' is a ClassPred + -- (b) this class has superclass(es), and + -- (c) the superclass(es) are not explored yet + -- + -- Same as 'di_pend_sc' flag in 'DictCt' + -- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver + } + +instance Outputable QCInst where + ppr (QCI { qci_ev = ev }) = ppr ev + +------------------------------------------------------------------------------ +-- +-- Holes and other delayed errors +-- +------------------------------------------------------------------------------ + +-- | A delayed error, to be reported after constraint solving, in order to benefit +-- from deferred unifications. +data DelayedError + = DE_Hole Hole + -- ^ A hole (in a type or in a term). + -- + -- See Note [Holes in expressions]. + | DE_NotConcrete NotConcreteError + -- ^ A type could not be ensured to be concrete. + -- + -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete. + | DE_Multiplicity TcCoercion CtLoc + -- ^ An error if the TcCoercion isn't a reflexivity constraint. + -- + -- See Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify. + + +instance Outputable DelayedError where + ppr (DE_Hole hole) = ppr hole + ppr (DE_NotConcrete err) = ppr err + ppr (DE_Multiplicity co _) = ppr co + +-- | A hole stores the information needed to report diagnostics +-- about holes in terms (unbound identifiers or underscores) or +-- in types (also called wildcards, as used in partial type +-- signatures). See Note [Holes in expressions] for holes in terms. +data Hole + = Hole { hole_sort :: HoleSort -- ^ What flavour of hole is this? + , hole_occ :: RdrName -- ^ The name of this hole + , hole_ty :: TcType -- ^ Type to be printed to the user + -- For expression holes: type of expr + -- For type holes: the missing type + , hole_loc :: CtLoc -- ^ Where hole was written + } + -- For the hole_loc, we usually only want the TcLclEnv stored within. + -- Except when we rewrite, where we need a whole location. And this + -- might get reported to the user if reducing type families in a + -- hole type loops. + + +-- | Used to indicate which sort of hole we have. +data HoleSort = ExprHole HoleExprRef + -- ^ Either an out-of-scope variable or a "true" hole in an + -- expression (TypedHoles). + -- The HoleExprRef says where to write the + -- the erroring expression for -fdefer-type-errors. + | TypeHole + -- ^ A hole in a type (PartialTypeSignatures) + | ConstraintHole + -- ^ A hole in a constraint, like @f :: (_, Eq a) => ... + -- Differentiated from TypeHole because a ConstraintHole + -- is simplified differently. See + -- Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver. + +instance Outputable Hole where + ppr (Hole { hole_sort = ExprHole ref + , hole_occ = occ + , hole_ty = ty }) + = parens $ (braces $ ppr occ <> colon <> ppr ref) <+> dcolon <+> ppr ty + ppr (Hole { hole_sort = _other + , hole_occ = occ + , hole_ty = ty }) + = braces $ ppr occ <> colon <> ppr ty + +instance Outputable HoleSort where + ppr (ExprHole ref) = text "ExprHole:" <+> ppr ref + ppr TypeHole = text "TypeHole" + ppr ConstraintHole = text "ConstraintHole" + +-- | Why did we require that a certain type be concrete? +data NotConcreteError + -- | Concreteness was required by a representation-polymorphism + -- check. + -- + -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete. + = NCE_FRR + { nce_loc :: CtLoc + -- ^ Where did this check take place? + , nce_frr_origin :: FixedRuntimeRepOrigin + -- ^ Which representation-polymorphism check did we perform? + } + +instance Outputable NotConcreteError where + ppr (NCE_FRR { nce_frr_origin = frr_orig }) + = text "NCE_FRR" <+> parens (ppr (frr_type frr_orig)) + +------------ +-- | Used to indicate extra information about why a CIrredCan is irreducible +data CtIrredReason + = IrredShapeReason + -- ^ This constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@) + + | NonCanonicalReason CheckTyEqResult + -- ^ An equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied; + -- the 'CheckTyEqResult' states exactly why + + | ReprEqReason + -- ^ An equality that cannot be decomposed because it is representational. + -- Example: @a b ~R# Int@. + -- These might still be solved later. + -- INVARIANT: The constraint is a representational equality constraint + + | ShapeMismatchReason + -- ^ A nominal equality that relates two wholly different types, + -- like @Int ~# Bool@ or @a b ~# 3@. + -- INVARIANT: The constraint is a nominal equality constraint + + | AbstractTyConReason + -- ^ An equality like @T a b c ~ Q d e@ where either @T@ or @Q@ + -- is an abstract type constructor. See Note [Skolem abstract data] + -- in GHC.Core.TyCon. + -- INVARIANT: The constraint is an equality constraint between two TyConApps + + | PluginReason + -- ^ A typechecker plugin returned this in the pluginBadCts field + -- of TcPluginProgress + +instance Outputable CtIrredReason where + ppr IrredShapeReason = text "(irred)" + ppr (NonCanonicalReason cter) = ppr cter + ppr ReprEqReason = text "(repr)" + ppr ShapeMismatchReason = text "(shape)" + ppr AbstractTyConReason = text "(abstc)" + ppr PluginReason = text "(plugin)" + +-- | Are we sure that more solving will never solve this constraint? +isInsolubleReason :: CtIrredReason -> Bool +isInsolubleReason IrredShapeReason = False +isInsolubleReason (NonCanonicalReason cter) = cterIsInsoluble cter +isInsolubleReason ReprEqReason = False +isInsolubleReason ShapeMismatchReason = True +isInsolubleReason AbstractTyConReason = True +isInsolubleReason PluginReason = True + +------------------------------------------------------------------------------ +-- +-- CheckTyEqResult, defined here because it is stored in a CtIrredReason +-- +------------------------------------------------------------------------------ + +-- | A /set/ of problems in checking the validity of a type equality. +-- See 'checkTypeEq'. +newtype CheckTyEqResult = CTER Word8 + +-- | No problems in checking the validity of a type equality. +cteOK :: CheckTyEqResult +cteOK = CTER zeroBits + +-- | Check whether a 'CheckTyEqResult' is marked successful. +cterHasNoProblem :: CheckTyEqResult -> Bool +cterHasNoProblem (CTER 0) = True +cterHasNoProblem _ = False + +-- | An /individual/ problem that might be logged in a 'CheckTyEqResult' +newtype CheckTyEqProblem = CTEP Word8 + +cteImpredicative, cteTypeFamily, cteInsolubleOccurs, + cteSolubleOccurs, cteConcrete, + cteSkolemEscape :: CheckTyEqProblem +cteImpredicative = CTEP (bit 0) -- Forall or (=>) encountered +cteTypeFamily = CTEP (bit 1) -- Type family encountered + +cteInsolubleOccurs = CTEP (bit 2) -- Occurs-check +cteSolubleOccurs = CTEP (bit 3) -- Occurs-check under a type function, or in a coercion, + -- or in a representational equality; see + -- See Note [Occurs check and representational equality] + -- cteSolubleOccurs must be one bit to the left of cteInsolubleOccurs + -- See also Note [Insoluble mis-match] in GHC.Tc.Errors + +-- NB: CTEP (bit 4) currently unused + +cteConcrete = CTEP (bit 5) -- Type variable that can't be made concrete + -- e.g. alpha[conc] ~ Maybe beta[tv] + +cteSkolemEscape = CTEP (bit 6) -- Skolem escape e.g. alpha[2] ~ b[sk,4] + +cteProblem :: CheckTyEqProblem -> CheckTyEqResult +cteProblem (CTEP mask) = CTER mask + +impredicativeProblem, insolubleOccursProblem, solubleOccursProblem :: CheckTyEqResult +impredicativeProblem = cteProblem cteImpredicative +insolubleOccursProblem = cteProblem cteInsolubleOccurs +solubleOccursProblem = cteProblem cteSolubleOccurs + +occurs_mask :: Word8 +occurs_mask = insoluble_mask .|. soluble_mask + where + CTEP insoluble_mask = cteInsolubleOccurs + CTEP soluble_mask = cteSolubleOccurs + +-- | Check whether a 'CheckTyEqResult' has a 'CheckTyEqProblem' +cterHasProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool +CTER bits `cterHasProblem` CTEP mask = (bits .&. mask) /= 0 + +-- | Check whether a 'CheckTyEqResult' has one 'CheckTyEqProblem' and no other +cterHasOnlyProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool +CTER bits `cterHasOnlyProblem` CTEP mask = bits == mask + +cterHasOnlyProblems :: CheckTyEqResult -> CheckTyEqResult -> Bool +CTER bits `cterHasOnlyProblems` CTER mask = (bits .&. complement mask) == 0 + +cterRemoveProblem :: CheckTyEqResult -> CheckTyEqProblem -> CheckTyEqResult +cterRemoveProblem (CTER bits) (CTEP mask) = CTER (bits .&. complement mask) + +cterHasOccursCheck :: CheckTyEqResult -> Bool +cterHasOccursCheck (CTER bits) = (bits .&. occurs_mask) /= 0 + +cterClearOccursCheck :: CheckTyEqResult -> CheckTyEqResult +cterClearOccursCheck (CTER bits) = CTER (bits .&. complement occurs_mask) + +-- | Mark a 'CheckTyEqResult' as not having an insoluble occurs-check: any occurs +-- check under a type family or in a representation equality is soluble. +cterSetOccursCheckSoluble :: CheckTyEqResult -> CheckTyEqResult +cterSetOccursCheckSoluble (CTER bits) + = CTER $ ((bits .&. insoluble_mask) `shift` 1) .|. (bits .&. complement insoluble_mask) + where + CTEP insoluble_mask = cteInsolubleOccurs + +-- | Retain only information about occurs-check failures, because only that +-- matters after recurring into a kind. +cterFromKind :: CheckTyEqResult -> CheckTyEqResult +cterFromKind (CTER bits) + = CTER (bits .&. occurs_mask) + +cterIsInsoluble :: CheckTyEqResult -> Bool +cterIsInsoluble (CTER bits) = (bits .&. mask) /= 0 + where + mask = impredicative_mask .|. insoluble_occurs_mask + + CTEP impredicative_mask = cteImpredicative + CTEP insoluble_occurs_mask = cteInsolubleOccurs + +instance Semigroup CheckTyEqResult where + CTER bits1 <> CTER bits2 = CTER (bits1 .|. bits2) +instance Monoid CheckTyEqResult where + mempty = cteOK + +instance Eq CheckTyEqProblem where + (CTEP b1) == (CTEP b2) = b1==b2 + +instance Outputable CheckTyEqProblem where + ppr prob@(CTEP bits) = case lookup prob allBits of + Just s -> text s + Nothing -> text "unknown:" <+> ppr bits + +instance Outputable CheckTyEqResult where + ppr cter | cterHasNoProblem cter + = text "cteOK" + | otherwise + = braces $ fcat $ intersperse vbar $ + [ text str + | (bitmask, str) <- allBits + , cter `cterHasProblem` bitmask ] + +allBits :: [(CheckTyEqProblem, String)] +allBits = [ (cteImpredicative, "cteImpredicative") + , (cteTypeFamily, "cteTypeFamily") + , (cteInsolubleOccurs, "cteInsolubleOccurs") + , (cteSolubleOccurs, "cteSolubleOccurs") + , (cteConcrete, "cteConcrete") + , (cteSkolemEscape, "cteSkolemEscape") ] + +{- Note [CIrredCan constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CIrredCan constraints are used for constraints that are "stuck" + - we can't solve them (yet) + - we can't use them to solve other constraints + - but they may become soluble if we substitute for some + of the type variables in the constraint + +Example 1: (c Int), where c :: * -> Constraint. We can't do anything + with this yet, but if later c := Num, *then* we can solve it + +Example 2: a ~ b, where a :: *, b :: k, where k is a kind variable + We don't want to use this to substitute 'b' for 'a', in case + 'k' is subsequently unified with (say) *->*, because then + we'd have ill-kinded types floating about. Rather we want + to defer using the equality altogether until 'k' get resolved. + +Note [Ct/evidence invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field +of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for DictCt, + ctev_pred (di_ev ct) = (di_cls ct) (di_tys ct) +This holds by construction; look at the unique place where DictCt is +built (in GHC.Tc.Solver.Dict.canDictNC). + +Note [Ct kind invariant] +~~~~~~~~~~~~~~~~~~~~~~~~ +CEqCan requires that the kind of the lhs matches the kind +of the rhs. This is necessary because these constraints are used for substitutions +during solving. If the kinds differed, then the substitution would take a well-kinded +type to an ill-kinded one. +-} + +mkNonCanonical :: CtEvidence -> Ct +mkNonCanonical ev = CNonCanonical ev + +mkGivens :: CtLoc -> [EvId] -> [Ct] +mkGivens loc ev_ids + = map mk ev_ids + where + mk ev_id = mkNonCanonical (CtGiven (GivenCt { ctev_evar = ev_id + , ctev_pred = evVarPred ev_id + , ctev_loc = loc })) + +ctEvidence :: Ct -> CtEvidence +ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev +ctEvidence (CEqCan (EqCt { eq_ev = ev })) = ev +ctEvidence (CIrredCan (IrredCt { ir_ev = ev })) = ev +ctEvidence (CNonCanonical ev) = ev +ctEvidence (CDictCan (DictCt { di_ev = ev })) = ev + +updCtEvidence :: (CtEvidence -> CtEvidence) -> Ct -> Ct +updCtEvidence upd ct + = case ct of + CQuantCan qci@(QCI { qci_ev = ev }) -> CQuantCan (qci { qci_ev = upd ev }) + CEqCan eq@(EqCt { eq_ev = ev }) -> CEqCan (eq { eq_ev = upd ev }) + CIrredCan ir@(IrredCt { ir_ev = ev }) -> CIrredCan (ir { ir_ev = upd ev }) + CNonCanonical ev -> CNonCanonical (upd ev) + CDictCan di@(DictCt { di_ev = ev }) -> CDictCan (di { di_ev = upd ev }) + +ctLoc :: Ct -> CtLoc +ctLoc = ctEvLoc . ctEvidence + +ctOrigin :: Ct -> CtOrigin +ctOrigin = ctLocOrigin . ctLoc + +ctPred :: Ct -> PredType +-- See Note [Ct/evidence invariant] +ctPred ct = ctEvPred (ctEvidence ct) + +ctRewriters :: Ct -> RewriterSet +ctRewriters = ctEvRewriters . ctEvidence + +ctEvId :: HasDebugCallStack => Ct -> EvVar +-- The evidence Id for this Ct +ctEvId ct = ctEvEvId (ctEvidence ct) + +-- | Returns the evidence 'Id' for the argument 'Ct' +-- when this 'Ct' is a 'Wanted'. +-- +-- Returns 'Nothing' otherwise. +wantedEvId_maybe :: Ct -> Maybe EvVar +wantedEvId_maybe ct + = case ctEvidence ct of + ctev@(CtWanted {}) + | otherwise + -> Just $ ctEvEvId ctev + CtGiven {} + -> Nothing + +-- | Makes a new equality predicate with the same role as the given +-- evidence. +mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType +mkTcEqPredLikeEv ev + = case predTypeEqRel pred of + NomEq -> mkNomEqPred + ReprEq -> mkReprEqPred + where + pred = ctEvPred ev + +-- | Get the flavour of the given 'Ct' +ctFlavour :: Ct -> CtFlavour +ctFlavour = ctEvFlavour . ctEvidence + +-- | Get the equality relation for the given 'Ct' +ctEqRel :: Ct -> EqRel +ctEqRel = ctEvEqRel . ctEvidence + +instance Outputable Ct where + ppr ct = ppr (ctEvidence ct) <+> parens pp_sort + where + pp_sort = case ct of + CEqCan {} -> text "CEqCan" + CNonCanonical {} -> text "CNonCanonical" + CDictCan (DictCt { di_pend_sc = psc }) + | psc > 0 -> text "CDictCan" <> parens (text "psc" <+> ppr psc) + | otherwise -> text "CDictCan" + CIrredCan (IrredCt { ir_reason = reason }) -> text "CIrredCan" <> ppr reason + CQuantCan (QCI { qci_pend_sc = psc }) + | psc > 0 -> text "CQuantCan" <> parens (text "psc" <+> ppr psc) + | otherwise -> text "CQuantCan" + +instance Outputable EqCt where + ppr (EqCt { eq_ev = ev }) = ppr ev + +{- +************************************************************************ +* * + Simple functions over evidence variables +* * +************************************************************************ +-} + +---------------- Getting bound tyvars ------------------------- +boundOccNamesOfWC :: WantedConstraints -> [OccName] +-- Return the OccNames of skolem-bound type variables +-- We could recurse into types, and get the forall-bound ones too, +-- but I'm going wait until that is needed +-- See Note [tidyAvoiding] in GHC.Core.TyCo.Tidy +boundOccNamesOfWC wc = bagToList (go_wc wc) + where + go_wc (WC { wc_impl = implics }) + = concatMapBag go_implic implics + go_implic (Implic { ic_skols = tvs, ic_wanted = wc }) + = listToBag (map getOccName tvs) `unionBags` go_wc wc + + +---------------- Getting free tyvars ------------------------- + +-- | Returns free variables of constraints as a non-deterministic set +tyCoVarsOfCt :: Ct -> TcTyCoVarSet +tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt + +-- | Returns free variables of constraints as a non-deterministic set +tyCoVarsOfCtEv :: CtEvidence -> TcTyCoVarSet +tyCoVarsOfCtEv = fvVarSet . tyCoFVsOfCtEv + +-- | Returns free variables of constraints as a deterministically ordered +-- list. See Note [Deterministic FV] in GHC.Utils.FV. +tyCoVarsOfCtList :: Ct -> [TcTyCoVar] +tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt + +-- | Returns free variables of constraints as a deterministically ordered +-- list. See Note [Deterministic FV] in GHC.Utils.FV. +tyCoVarsOfCtEvList :: CtEvidence -> [TcTyCoVar] +tyCoVarsOfCtEvList = fvVarList . tyCoFVsOfType . ctEvPred + +-- | Returns free variables of constraints as a composable FV computation. +-- See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfCt :: Ct -> FV +tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) + -- This must consult only the ctPred, so that it gets *tidied* fvs if the + -- constraint has been tidied. Tidying a constraint does not tidy the + -- fields of the Ct, only the predicate in the CtEvidence. + +-- | Returns free variables of constraints as a composable FV computation. +-- See Note [Deterministic FV] in GHC.Utils.FV. +tyCoFVsOfCtEv :: CtEvidence -> FV +tyCoFVsOfCtEv ct = tyCoFVsOfType (ctEvPred ct) + +-- | Returns free variables of a bag of constraints as a non-deterministic +-- set. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfCts :: Cts -> TcTyCoVarSet +tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts + +-- | Returns free variables of a bag of constraints as a deterministically +-- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] +tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts + +-- | Returns free variables of a bag of constraints as a deterministically +-- ordered list. See Note [Deterministic FV] in GHC.Utils.FV. +tyCoVarsOfCtEvsList :: [CtEvidence] -> [TcTyCoVar] +tyCoVarsOfCtEvsList = fvVarList . tyCoFVsOfCtEvs + +-- | Returns free variables of a bag of constraints as a composable FV +-- computation. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfCts :: Cts -> FV +tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV + +-- | Returns free variables of a bag of constraints as a composable FV +-- computation. See Note [Deterministic FV] in GHC.Utils.FV. +tyCoFVsOfCtEvs :: [CtEvidence] -> FV +tyCoFVsOfCtEvs = foldr (unionFV . tyCoFVsOfCtEv) emptyFV + +-- | Returns free variables of WantedConstraints as a non-deterministic +-- set. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet +-- Only called on *zonked* things +tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC + +-- | Returns free variables of WantedConstraints as a deterministically +-- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar] +-- Only called on *zonked* things +tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC + +-- | Returns free variables of WantedConstraints as a composable FV +-- computation. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfWC :: WantedConstraints -> FV +-- Only called on *zonked* things +tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_errors = errors }) + = tyCoFVsOfCts simple `unionFV` + tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV` + tyCoFVsOfBag tyCoFVsOfDelayedError errors + +-- | Returns free variables of Implication as a composable FV computation. +-- See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfImplic :: Implication -> FV +-- Only called on *zonked* things +tyCoFVsOfImplic (Implic { ic_skols = skols + , ic_given = givens + , ic_wanted = wanted }) + | isEmptyWC wanted + = emptyFV + | otherwise + = tyCoFVsVarBndrs skols $ + tyCoFVsVarBndrs givens $ + tyCoFVsOfWC wanted + +tyCoFVsOfDelayedError :: DelayedError -> FV +tyCoFVsOfDelayedError (DE_Hole hole) = tyCoFVsOfHole hole +tyCoFVsOfDelayedError (DE_NotConcrete {}) = emptyFV +tyCoFVsOfDelayedError (DE_Multiplicity co _) = tyCoFVsOfCo co + +tyCoFVsOfHole :: Hole -> FV +tyCoFVsOfHole (Hole { hole_ty = ty }) = tyCoFVsOfType ty + +tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV +tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV + +{- +************************************************************************ +* * + CtEvidence + The "flavor" of a canonical constraint +* * +************************************************************************ +-} + +isWantedCt :: Ct -> Bool +isWantedCt = isWanted . ctEvidence + +isGivenCt :: Ct -> Bool +isGivenCt = isGiven . ctEvidence + +isPendingScDict :: Ct -> Bool +isPendingScDict (CDictCan dict_ct) = isPendingScDictCt dict_ct +isPendingScDict _ = False + +isPendingScDictCt :: DictCt -> Bool +-- Says whether this is a CDictCan with di_pend_sc has positive fuel; +-- i.e. pending un-expanded superclasses +isPendingScDictCt (DictCt { di_pend_sc = f }) = pendingFuel f + +pendingScDict_maybe :: Ct -> Maybe Ct +-- Says whether this is a CDictCan with di_pend_sc has fuel left, +-- AND if so exhausts the fuel so that they are not expanded again +pendingScDict_maybe (CDictCan dict@(DictCt { di_pend_sc = f })) + | pendingFuel f = Just (CDictCan (dict { di_pend_sc = doNotExpand })) + | otherwise = Nothing +pendingScDict_maybe _ = Nothing + +pendingScInst_maybe :: QCInst -> Maybe QCInst +-- Same as isPendingScDict, but for QCInsts +pendingScInst_maybe qci@(QCI { qci_ev = ev, qci_pend_sc = f }) + | isGiven ev -- Do not expand Wanted QCIs + , pendingFuel f = Just (qci { qci_pend_sc = doNotExpand }) + | otherwise = Nothing + +superClassesMightHelp :: WantedConstraints -> Bool +-- ^ True if taking superclasses of givens, or of wanteds (to perhaps +-- expose more equalities or functional dependencies) might help to +-- solve this constraint. See Note [When superclasses help] +superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics }) + = anyBag might_help_ct simples || anyBag might_help_implic implics + where + might_help_implic ic + | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic) + | otherwise = False + + might_help_ct ct = not (is_ip ct) + + is_ip (CDictCan (DictCt { di_cls = cls })) = isIPClass cls + is_ip _ = False + +getPendingWantedScs :: Cts -> ([Ct], Cts) +-- in the return values [Ct] has original fuel while Cts has fuel exhausted +getPendingWantedScs simples + = mapAccumBagL get [] simples + where + get acc ct | Just ct_exhausted <- pendingScDict_maybe ct + = (ct:acc, ct_exhausted) + | otherwise + = (acc, ct) + +{- Note [When superclasses help] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +First read Note [The superclass story] in GHC.Tc.Solver.Dict + +We expand superclasses and iterate only if there is at unsolved wanted +for which expansion of superclasses (e.g. from given constraints) +might actually help. The function superClassesMightHelp tells if +doing this superclass expansion might help solve this constraint. +Note that + + * We look inside implications; maybe it'll help to expand the Givens + at level 2 to help solve an unsolved Wanted buried inside an + implication. E.g. + forall a. Ord a => forall b. [W] Eq a + + * We say "no" for implicit parameters. + we have [W] ?x::ty, expanding superclasses won't help: + - Superclasses can't be implicit parameters + - If we have a [G] ?x:ty2, then we'll have another unsolved + [W] ty ~ ty2 (from the functional dependency) + which will trigger superclass expansion. + + It's a bit of a special case, but it's easy to do. The runtime cost + is low because the unsolved set is usually empty anyway (errors + aside), and the first non-implicit-parameter will terminate the search. + + The special case is worth it (#11480, comment:2) because it + applies to CallStack constraints, which aren't type errors. If we have + f :: (C a) => blah + f x = ...undefined... + we'll get a CallStack constraint. If that's the only unsolved + constraint it'll eventually be solved by defaulting. So we don't + want to emit warnings about hitting the simplifier's iteration + limit. A CallStack constraint really isn't an unsolved + constraint; it can always be solved by defaulting. +-} + +singleCt :: Ct -> Cts +singleCt = unitBag + +andCts :: Cts -> Cts -> Cts +andCts = unionBags + +listToCts :: [Ct] -> Cts +listToCts = listToBag + +ctsElts :: Cts -> [Ct] +ctsElts = bagToList + +consCts :: Ct -> Cts -> Cts +consCts = consBag + +snocCts :: Cts -> Ct -> Cts +snocCts = snocBag + +extendCtsList :: Cts -> [Ct] -> Cts +extendCtsList cts xs | null xs = cts + | otherwise = cts `unionBags` listToBag xs + +emptyCts :: Cts +emptyCts = emptyBag + +isEmptyCts :: Cts -> Bool +isEmptyCts = isEmptyBag + +ctsPreds :: Cts -> [PredType] +ctsPreds cts = foldr ((:) . ctPred) [] cts + +{- +************************************************************************ +* * + Wanted constraints +* * +************************************************************************ +-} + +data WantedConstraints + = WC { wc_simple :: Cts -- Unsolved constraints, all wanted + , wc_impl :: Bag Implication + , wc_errors :: Bag DelayedError + } + +emptyWC :: WantedConstraints +emptyWC = WC { wc_simple = emptyBag + , wc_impl = emptyBag + , wc_errors = emptyBag } + +mkSimpleWC :: [CtEvidence] -> WantedConstraints +mkSimpleWC cts + = emptyWC { wc_simple = listToBag (map mkNonCanonical cts) } + +mkImplicWC :: Bag Implication -> WantedConstraints +mkImplicWC implic + = emptyWC { wc_impl = implic } + +isEmptyWC :: WantedConstraints -> Bool +isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_errors = errors }) + = isEmptyBag f && isEmptyBag i && isEmptyBag errors + +-- | Checks whether a the given wanted constraints are solved, i.e. +-- that there are no simple constraints left and all the implications +-- are solved. +isSolvedWC :: WantedConstraints -> Bool +isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl, wc_errors = errors} = + isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl && isEmptyBag errors + +andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints +andWC (WC { wc_simple = f1, wc_impl = i1, wc_errors = e1 }) + (WC { wc_simple = f2, wc_impl = i2, wc_errors = e2 }) + = WC { wc_simple = f1 `unionBags` f2 + , wc_impl = i1 `unionBags` i2 + , wc_errors = e1 `unionBags` e2 } + +unionsWC :: [WantedConstraints] -> WantedConstraints +unionsWC = foldr andWC emptyWC + +addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints +addSimples wc cts + = wc { wc_simple = wc_simple wc `unionBags` cts } + -- Consider: Put the new constraints at the front, so they get solved first + +addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints +addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } + +addInsols :: WantedConstraints -> Bag IrredCt -> WantedConstraints +addInsols wc insols + = wc { wc_simple = wc_simple wc `unionBags` fmap CIrredCan insols } + +addHoles :: WantedConstraints -> Bag Hole -> WantedConstraints +addHoles wc holes + = wc { wc_errors = mapBag DE_Hole holes `unionBags` wc_errors wc } + +addNotConcreteError :: WantedConstraints -> NotConcreteError -> WantedConstraints +addNotConcreteError wc err + = wc { wc_errors = unitBag (DE_NotConcrete err) `unionBags` wc_errors wc } + +-- See Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify. +addMultiplicityCoercionError :: WantedConstraints -> TcCoercion -> CtLoc -> WantedConstraints +addMultiplicityCoercionError wc mult_co loc + = wc { wc_errors = unitBag (DE_Multiplicity mult_co loc) `unionBags` wc_errors wc } + +addDelayedErrors :: WantedConstraints -> Bag DelayedError -> WantedConstraints +addDelayedErrors wc errs + = wc { wc_errors = errs `unionBags` wc_errors wc } + +dropMisleading :: WantedConstraints -> WantedConstraints +-- Drop misleading constraints; really just class constraints +-- See Note [Constraints and errors] in GHC.Tc.Utils.Monad +-- for why this function is so strange, treating the 'simples' +-- and the implications differently. Sigh. +dropMisleading (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors }) + = WC { wc_simple = filterBag insolubleWantedCt simples + , wc_impl = mapBag drop_implic implics + , wc_errors = filterBag keep_delayed_error errors } + where + drop_implic implic + = implic { ic_wanted = drop_wanted (ic_wanted implic) } + drop_wanted (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors }) + = WC { wc_simple = filterBag keep_ct simples + , wc_impl = mapBag drop_implic implics + , wc_errors = filterBag keep_delayed_error errors } + + keep_ct ct + = case classifyPredType (ctPred ct) of + ClassPred cls _ -> isEqualityClass cls + -- isEqualityClass: see (CERR2) in Note [Constraints and errors] + -- in GHC.Tc.Utils.Monad + _ -> True + + keep_delayed_error (DE_Hole hole) = isOutOfScopeHole hole + keep_delayed_error (DE_NotConcrete {}) = True + keep_delayed_error (DE_Multiplicity {}) = True + +isSolvedStatus :: ImplicStatus -> Bool +isSolvedStatus (IC_Solved {}) = True +isSolvedStatus _ = False + +isInsolubleStatus :: ImplicStatus -> Bool +isInsolubleStatus IC_Insoluble = True +isInsolubleStatus IC_BadTelescope = True +isInsolubleStatus _ = False + +insolubleImplic :: Implication -> Bool +insolubleImplic ic = isInsolubleStatus (ic_status ic) + +-- | Gather all the type variables from 'WantedConstraints' +-- that it would be unhelpful to default. For the moment, +-- these are only 'ConcreteTv' metavariables participating +-- in a nominal equality whose other side is not concrete; +-- it's usually better to report those as errors instead of +-- defaulting. +nonDefaultableTyVarsOfWC :: WantedConstraints -> TyCoVarSet +-- Currently used in simplifyTop and in tcRule. +-- TODO: should we also use this in decideQuantifiedTyVars, kindGeneralize{All,Some}? +nonDefaultableTyVarsOfWC (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs }) + = concatMapBag non_defaultable_tvs_of_ct simples + `unionVarSet` concatMapBag (nonDefaultableTyVarsOfWC . ic_wanted) implics + `unionVarSet` concatMapBag non_defaultable_tvs_of_err errs + where + + concatMapBag :: (a -> TyVarSet) -> Bag a -> TyCoVarSet + concatMapBag f = foldr (\ r acc -> f r `unionVarSet` acc) emptyVarSet + + -- Don't default ConcreteTv metavariables involved + -- in an equality with something non-concrete: it's usually + -- better to report the unsolved Wanted. + -- + -- Example: alpha[conc] ~# rr[sk]. + non_defaultable_tvs_of_ct :: Ct -> TyCoVarSet + non_defaultable_tvs_of_ct ct = + -- NB: using classifyPredType instead of inspecting the Ct + -- so that we deal uniformly with CNonCanonical (which come up in tcRule), + -- CEqCan (unsolved but potentially soluble, e.g. @alpha[conc] ~# RR@) + -- and CIrredCan. + case classifyPredType $ ctPred ct of + EqPred NomEq lhs rhs + | Just tv <- getTyVar_maybe lhs + , isConcreteTyVar tv + , not (isConcreteType rhs) + -> unitVarSet tv + | Just tv <- getTyVar_maybe rhs + , isConcreteTyVar tv + , not (isConcreteType lhs) + -> unitVarSet tv + _ -> emptyVarSet + + -- Make sure to apply the same logic as above to delayed errors. + non_defaultable_tvs_of_err (DE_NotConcrete err) + = case err of + NCE_FRR { nce_frr_origin = frr } -> tyCoVarsOfType (frr_type frr) + non_defaultable_tvs_of_err (DE_Hole {}) = emptyVarSet + non_defaultable_tvs_of_err (DE_Multiplicity {}) = emptyVarSet + +insolubleWC :: WantedConstraints -> Bool +insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors }) + = anyBag insolubleWantedCt simples + -- insolubleWantedCt: wanteds only: see Note [Given insolubles] + || anyBag insolubleImplic implics + || anyBag is_insoluble errors + where + is_insoluble (DE_Hole hole) = isOutOfScopeHole hole -- See Note [Insoluble holes] + is_insoluble (DE_NotConcrete {}) = True + is_insoluble (DE_Multiplicity {}) = False + +insolubleWantedCt :: Ct -> Bool +-- Definitely insoluble, in particular /excluding/ type-hole constraints +-- Namely: +-- a) an insoluble constraint as per 'insolubleIrredCt', i.e. either +-- - an insoluble equality constraint (e.g. Int ~ Bool), or +-- - a custom type error constraint, TypeError msg :: Constraint +-- b) that does not arise from a Given or a Wanted/Wanted fundep interaction +-- See Note [Insoluble Wanteds] +insolubleWantedCt ct + | CIrredCan ir_ct <- ct + -- CIrredCan: see (IW1) in Note [Insoluble Wanteds] + , IrredCt { ir_ev = ev } <- ir_ct + , CtWanted (WantedCt { ctev_loc = loc, ctev_rewriters = rewriters }) <- ev + -- It's a Wanted + , insolubleIrredCt ir_ct + -- It's insoluble + , isEmptyRewriterSet rewriters + -- It has no rewriters; see (IW2) in Note [Insoluble Wanteds] + , not (isGivenLoc loc) + -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds] + , not (isWantedWantedFunDepOrigin (ctLocOrigin loc)) + -- origin check: see (IW4) in Note [Insoluble Wanteds] + = True + + | otherwise + = False + +-- | Returns True of constraints that are definitely insoluble, +-- as well as TypeError constraints. +-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. +-- +-- The function is tuned for application /after/ constraint solving +-- i.e. assuming canonicalisation has been done +-- That's why it looks only for IrredCt; all insoluble constraints +-- are put into CIrredCan +insolubleCt :: Ct -> Bool +insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct +insolubleCt _ = False + +insolubleIrredCt :: IrredCt -> Bool +-- Returns True of Irred constraints that are /definitely/ insoluble +-- +-- This function is critical for accurate pattern-match overlap warnings. +-- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver +-- +-- Note that this does not traverse through the constraint to find +-- nested custom type errors: it only detects @TypeError msg :: Constraint@, +-- and not e.g. @Eq (TypeError msg)@. +insolubleIrredCt (IrredCt { ir_ev = ev, ir_reason = reason }) + = isInsolubleReason reason + || isTopLevelUserTypeError (ctEvPred ev) + -- NB: 'isTopLevelUserTypeError' detects constraints of the form "TypeError msg" + -- and "Unsatisfiable msg". It deliberately does not detect TypeError + -- nested in a type (e.g. it does not use "containsUserTypeError"), as that + -- would be too eager: the TypeError might appear inside a type family + -- application which might later reduce, but we only want to return 'True' + -- for constraints that are definitely insoluble. + -- + -- For example: Num (F Int (TypeError "msg")), where F is a type family. + -- + -- Test case: T11503, with the 'Assert' type family: + -- + -- > type Assert :: Bool -> Constraint -> Constraint + -- > type family Assert check errMsg where + -- > Assert 'True _errMsg = () + -- > Assert _check errMsg = errMsg + +-- | Does this hole represent an "out of scope" error? +-- See Note [Insoluble holes] +isOutOfScopeHole :: Hole -> Bool +isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore (occName occ)) + +instance Outputable WantedConstraints where + ppr (WC {wc_simple = s, wc_impl = i, wc_errors = e}) + = text "WC" <+> braces (vcat + [ ppr_bag (text "wc_simple") s + , ppr_bag (text "wc_impl") i + , ppr_bag (text "wc_errors") e ]) + +ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc +ppr_bag doc bag + | isEmptyBag bag = empty + | otherwise = hang (doc <+> equals) + 2 (foldr (($$) . ppr) empty bag) + +{- Note [Given insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14325, comment:) + class (a~b) => C a b + + foo :: C a c => a -> c + foo x = x + + hm3 :: C (f b) b => b -> f b + hm3 x = foo x + +In the RHS of hm3, from the [G] C (f b) b we get the insoluble +[G] f b ~# b. Then we also get an unsolved [W] C b (f b). +Residual implication looks like + forall b. C (f b) b => [G] f b ~# b + [W] C f (f b) + +We do /not/ want to set the implication status to IC_Insoluble, +because that'll suppress reports of [W] C b (f b). But we +may not report the insoluble [G] f b ~# b either (see Note [Given errors] +in GHC.Tc.Errors), so we may fail to report anything at all! Yikes. + +Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus) + should ignore givens even if they are insoluble. + +Note [Insoluble Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~ +insolubleWantedCt returns True of a Wanted constraint that definitely +can't be solved. But not quite all such constraints; see wrinkles. + +(IW1) insolubleWantedCt is tuned for application /after/ constraint + solving i.e. assuming canonicalisation has been done. That's why + it looks only for IrredCt; all insoluble constraints are put into + CIrredCan + +(IW2) We only treat it as insoluble if it has an empty rewriter set. (See Note + [Wanteds rewrite Wanteds].) Otherwise #25325 happens: a Wanted constraint A + that is /not/ insoluble rewrites some other Wanted constraint B, so B has A + in its rewriter set. Now B looks insoluble. The danger is that we'll + suppress reporting B because of its empty rewriter set; and suppress + reporting A because there is an insoluble B lying around. (This suppression + happens in GHC.Tc.Errors.mkErrorItem.) Solution: don't treat B as insoluble. + +(IW3) If the Wanted arises from a Given (how can that happen?), don't + treat it as a Wanted insoluble (obviously). + +(IW4) If the Wanted came from a Wanted/Wanted fundep interaction, don't + treat the constraint as insoluble. See Note [Suppressing confusing errors] + in GHC.Tc.Errors + +Note [Insoluble holes] +~~~~~~~~~~~~~~~~~~~~~~ +Hole constraints that ARE NOT treated as truly insoluble: + a) type holes, arising from PartialTypeSignatures, + b) "true" expression holes arising from TypedHoles + +An "expression hole" or "type hole" isn't really an error +at all; it's a report saying "_ :: Int" here. But an out-of-scope +variable masquerading as expression holes IS treated as truly +insoluble, so that it trumps other errors during error reporting. +Yuk! + +-} + +{- ********************************************************************* +* * + Custom type errors: Unsatisfiable and TypeError +* * +********************************************************************* -} + +{- Note [Custom type errors in constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When GHC reports a type-error about an unsolved-constraint, we check +to see if the constraint contains any custom-type errors, and if so +we report them. Here are some examples of constraints containing type +errors: + + TypeError msg -- The actual constraint is a type error + + TypError msg ~ Int -- Some type was supposed to be Int, but ended up + -- being a type error instead + + Eq (TypeError msg) -- A class constraint is stuck due to a type error + + F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err + +It is also possible to have constraints where the type error is nested deeper, +for example see #11990, and also: + + Eq (F (TypeError msg)) -- Here the type error is nested under a type-function + -- call, which failed to evaluate because of it, + -- and so the `Eq` constraint was unsolved. + -- This may happen when one function calls another + -- and the called function produced a custom type error. + +A good use-case is described in "Detecting the undetectable" + https://blog.csongor.co.uk/report-stuck-families/ +which features + type family Assert (err :: Constraint) (break :: Type -> Type) (a :: k) :: k where + Assert _ Dummy _ = Any + Assert _ _ k = k +and an unsolved constraint like + Assert (TypeError ...) (F ty1) ty1 ~ ty2 +that reports that (F ty1) remains stuck. +-} + +-- | A constraint is considered to be a custom type error, if it contains +-- custom type errors anywhere in it. +-- See Note [Custom type errors in constraints] +getUserTypeErrorMsg :: PredType -> Maybe ErrorMsgType +getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred + : map getUserTypeErrorMsg (subTys pred) + where + -- Richard thinks this function is very broken. What is subTys + -- supposed to be doing? Why are exactly-saturated tyconapps special? + -- What stops this from accidentally ripping apart a call to TypeError? + subTys t = case splitAppTys t of + (t,[]) -> + case splitTyConApp_maybe t of + Nothing -> [] + Just (_,ts) -> ts + (t,ts) -> t : ts + +-- | Is this an user error message type, i.e. either the form @TypeError err@ or +-- @Unsatisfiable err@? +isTopLevelUserTypeError :: PredType -> Bool +isTopLevelUserTypeError pred = + isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred) + +-- | Does this constraint contain an user error message? +-- +-- That is, the type is either of the form @Unsatisfiable err@, or it contains +-- a type of the form @TypeError msg@, either at the top level or nested inside +-- the type. +containsUserTypeError :: PredType -> Bool +containsUserTypeError pred = + isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred) + +-- | Is this type an unsatisfiable constraint? +-- If so, return the error message. +isUnsatisfiableCt_maybe :: Type -> Maybe ErrorMsgType +isUnsatisfiableCt_maybe t + | Just (tc, [msg]) <- splitTyConApp_maybe t + , tc `hasKey` unsatisfiableClassNameKey + = Just msg + | otherwise + = Nothing + +{- +************************************************************************ +* * + Implication constraints +* * +************************************************************************ +-} + +data Implication + = Implic { -- Invariants for a tree of implications: + -- see TcType Note [TcLevel invariants] + + ic_tclvl :: TcLevel, -- TcLevel of unification variables + -- allocated /inside/ this implication + + ic_info :: SkolemInfoAnon, -- See Note [Skolems in an implication] + -- See Note [Shadowing in a constraint] + + ic_skols :: [TcTyVar], -- Introduced skolems; always skolem TcTyVars + -- Their level numbers should be precisely ic_tclvl + -- Their SkolemInfo should be precisely ic_info (almost) + -- See Note [Implication invariants] + + ic_given :: [EvVar], -- Given evidence variables + -- (order does not matter) + -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType + + ic_given_eqs :: HasGivenEqs, -- Are there Given equalities here? + + ic_warn_inaccessible :: Bool, + -- True <=> we should report inaccessible code + -- Note [Avoid -Winaccessible-code when deriving] + -- in GHC.Tc.TyCl.Instance + + ic_env :: !CtLocEnv, + -- Records the context at the time of creation. + -- + -- This provides all the information needed about + -- the context to report the source of errors linked + -- to this implication. + + ic_wanted :: WantedConstraints, -- The wanteds + -- See Invariant (WantedInf) in GHC.Tc.Utils.TcType + + ic_binds :: EvBindsVar, -- Points to the place to fill in the + -- abstraction and bindings. + + -- The ic_need fields keep track of which Given evidence + -- is used by this implication or its children + -- See Note [Tracking redundant constraints] + -- NB: these sets include stuff used by fully-solved nested implications + -- that have since been discarded + ic_need :: EvNeedSet, -- All needed Given evidence, from this implication + -- or outer ones + -- That is, /after/ deleting the binders of ic_binds, + -- but /before/ deleting ic_givens + + ic_need_implic :: EvNeedSet, -- Union of of the ic_need of all implications in ic_wanted + -- /including/ any fully-solved implications that have been + -- discarded by `pruneImplications`. This discarding is why + -- we need to keep this field in the first place. + + ic_status :: ImplicStatus + } + +data EvNeedSet = ENS { ens_dms :: VarSet -- Needed only by default methods + , ens_fvs :: VarSet -- Needed by things /other than/ default methods + -- See (TRC5) in Note [Tracking redundant constraints] + } + +emptyEvNeedSet :: EvNeedSet +emptyEvNeedSet = ENS { ens_dms = emptyVarSet, ens_fvs = emptyVarSet } + +unionEvNeedSet :: EvNeedSet -> EvNeedSet -> EvNeedSet +unionEvNeedSet (ENS { ens_dms = dm1, ens_fvs = fv1 }) + (ENS { ens_dms = dm2, ens_fvs = fv2 }) + = ENS { ens_dms = dm1 `unionVarSet` dm2, ens_fvs = fv1 `unionVarSet` fv2 } + +extendEvNeedSet :: EvNeedSet -> Var -> EvNeedSet +extendEvNeedSet ens@(ENS { ens_fvs = fvs }) v = ens { ens_fvs = fvs `extendVarSet` v } + +delGivensFromEvNeedSet :: EvNeedSet -> [Var] -> EvNeedSet +delGivensFromEvNeedSet (ENS { ens_dms = dms, ens_fvs = fvs }) givens + = ENS { ens_dms = dms `delVarSetList` givens + , ens_fvs = fvs `delVarSetList` givens } + +implicationPrototype :: CtLocEnv -> Implication +implicationPrototype ct_loc_env + = Implic { -- These fields must be initialised + ic_tclvl = panic "newImplic:tclvl" + , ic_binds = panic "newImplic:binds" + , ic_info = panic "newImplic:info" + , ic_warn_inaccessible = panic "newImplic:warn_inaccessible" + + -- Given by caller + , ic_env = ct_loc_env + + -- The rest have sensible default values + , ic_skols = [] + , ic_given = [] + , ic_wanted = emptyWC + , ic_given_eqs = MaybeGivenEqs + , ic_status = IC_Unsolved + , ic_need = emptyEvNeedSet + , ic_need_implic = emptyEvNeedSet } + +data ImplicStatus + = IC_Solved -- All wanteds in the tree are solved, all the way down + { ics_dead :: [EvVar] } -- Subset of ic_given that are not needed + -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + + | IC_Insoluble -- At least one insoluble Wanted constraint in the tree + + | IC_BadTelescope -- Solved, but the skolems in the telescope are out of + -- dependency order. See Note [Checking telescopes] + + | IC_Unsolved -- Neither of the above; might go either way + +data HasGivenEqs -- See Note [HasGivenEqs] + = NoGivenEqs -- Definitely no given equalities, + -- except by Note [Let-bound skolems] in GHC.Tc.Solver.InertSet + | LocalGivenEqs -- Might have Given equalities, but only ones that affect only + -- local skolems e.g. forall a b. (a ~ F b) => ... + | MaybeGivenEqs -- Might have any kind of Given equalities; no floating out + -- is possible. + deriving Eq + +type UserGiven = Implication + +getUserGivensFromImplics :: [Implication] -> [UserGiven] +getUserGivensFromImplics implics + = reverse (filterOut (null . ic_given) implics) + +{- Note [HasGivenEqs] +~~~~~~~~~~~~~~~~~~~~~ +The GivenEqs data type describes the Given constraints of an implication constraint: + +* NoGivenEqs: definitely no Given equalities, except perhaps let-bound skolems + which don't count: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet + Examples: forall a. Eq a => ... + forall a. (Show a, Num a) => ... + forall a. a ~ Either Int Bool => ... -- Let-bound skolem + +* LocalGivenEqs: definitely no Given equalities that would affect principal + types. But may have equalities that affect only skolems of this implication + (and hence do not affect principal types) + Examples: forall a. F a ~ Int => ... + forall a b. F a ~ G b => ... + +* MaybeGivenEqs: may have Given equalities that would affect principal + types + Examples: forall. (a ~ b) => ... + forall a. F a ~ b => ... + forall a. c a => ... -- The 'c' might be instantiated to (b ~) + forall a. C a b => .... + where class x~y => C a b + so there is an equality in the superclass of a Given + +The HasGivenEqs classifications affect two things: + +* Suppressing redundant givens during error reporting; see GHC.Tc.Errors + Note [Suppress redundant givens during error reporting] + +* Floating in approximateWC. + +Specifically, here's how it goes: + + Stops floating | Suppresses Givens in errors + in approximateWC | + ----------------------------------------------- + NoGivenEqs NO | YES + LocalGivenEqs NO | NO + MaybeGivenEqs YES | NO +-} + +instance Outputable Implication where + ppr (Implic { ic_tclvl = tclvl, ic_skols = skols + , ic_given = given, ic_given_eqs = given_eqs + , ic_wanted = wanted, ic_status = status + , ic_binds = binds + , ic_need = need, ic_need_implic = need_implic + , ic_info = info }) + = hang (text "Implic" <+> lbrace) + 2 (sep [ text "TcLevel =" <+> ppr tclvl + , text "Skolems =" <+> pprTyVars skols + , text "Given-eqs =" <+> ppr given_eqs + , text "Status =" <+> ppr status + , hang (text "Given =") 2 (pprEvVars given) + , hang (text "Wanted =") 2 (ppr wanted) + , text "Binds =" <+> ppr binds + , text "need =" <+> ppr need + , text "need_implic =" <+> ppr need_implic + , pprSkolInfo info ] <+> rbrace) + +instance Outputable EvNeedSet where + ppr (ENS { ens_dms = dms, ens_fvs = fvs }) + = text "ENS" <> braces (sep [text "ens_dms =" <+> ppr dms + , text "ens_fvs =" <+> ppr fvs]) + +instance Outputable ImplicStatus where + ppr IC_Insoluble = text "Insoluble" + ppr IC_BadTelescope = text "Bad telescope" + ppr IC_Unsolved = text "Unsolved" + ppr (IC_Solved { ics_dead = dead }) + = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) + +checkTelescopeSkol :: SkolemInfoAnon -> Bool +-- See Note [Checking telescopes] +checkTelescopeSkol (ForAllSkol {}) = True +checkTelescopeSkol _ = False + +instance Outputable HasGivenEqs where + ppr NoGivenEqs = text "NoGivenEqs" + ppr LocalGivenEqs = text "LocalGivenEqs" + ppr MaybeGivenEqs = text "MaybeGivenEqs" + +-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs +instance Semigroup HasGivenEqs where + NoGivenEqs <> other = other + other <> NoGivenEqs = other + + MaybeGivenEqs <> _other = MaybeGivenEqs + _other <> MaybeGivenEqs = MaybeGivenEqs + + LocalGivenEqs <> LocalGivenEqs = LocalGivenEqs + +-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs +instance Monoid HasGivenEqs where + mempty = NoGivenEqs + +{- Note [Checking telescopes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind-checking a /user-written/ type, we might have a "bad telescope" +like this one: + data SameKind :: forall k. k -> k -> Type + type Foo :: forall a k (b :: k). SameKind a b -> Type + +The kind of 'a' mentions 'k' which is bound after 'a'. Oops. + +One approach to doing this would be to bring each of a, k, and b into +scope, one at a time, creating a separate implication constraint for +each one, and bumping the TcLevel. This would work, because the kind +of, say, a would be untouchable when k is in scope (and the constraint +couldn't float out because k blocks it). However, it leads to terrible +error messages, complaining about skolem escape. While it is indeed a +problem of skolem escape, we can do better. + +Instead, our approach is to bring the block of variables into scope +all at once, creating one implication constraint for the lot: + +* We make a single implication constraint when kind-checking + the 'forall' in Foo's kind, something like + forall a k (b::k). { wanted constraints } + +* Having solved {wanted}, before discarding the now-solved implication, + the constraint solver checks the dependency order of the skolem + variables (ic_skols). This is done in setImplicationStatus. + +* This check is only necessary if the implication was born from a + 'forall' in a user-written signature (the HsForAllTy case in + GHC.Tc.Gen.HsType. If, say, it comes from checking a pattern match + that binds existentials, where the type of the data constructor is + known to be valid (it in tcConPat), no need for the check. + + So the check is done /if and only if/ ic_info is ForAllSkol. + +* If ic_info is (ForAllSkol dt dvs), the dvs::SDoc displays the + original, user-written type variables. + +* Be careful /NOT/ to discard an implication with a ForAllSkol + ic_info, even if ic_wanted is empty. We must give the + constraint solver a chance to make that bad-telescope test! Hence + the extra guard in emitResidualTvConstraint; see #16247 + +* Don't mix up inferred and explicit variables in the same implication + constraint. E.g. + foo :: forall a kx (b :: kx). SameKind a b + We want an implication + Implic { ic_skol = [(a::kx), kx, (b::kx)], ... } + but GHC will attempt to quantify over kx, since it is free in (a::kx), + and it's hopelessly confusing to report an error about quantified + variables kx (a::kx) kx (b::kx). + Instead, the outer quantification over kx should be in a separate + implication. TL;DR: an explicit forall should generate an implication + quantified only over those explicitly quantified variables. + +Note [Shadowing in a constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We assume NO SHADOWING in a constraint. Specifically + * The unification variables are all implicitly quantified at top + level, and are all unique + * The skolem variables bound in ic_skols are all fresh when the + implication is created. +So we can safely substitute. For example, if we have + forall a. a~Int => ...(forall b. ...a...)... +we can push the (a~Int) constraint inwards in the "givens" without +worrying that 'b' might clash. + +Note [Skolems in an implication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The skolems in an implication are used: + +* When considering floating a constraint outside the implication in + GHC.Tc.Solver.floatEqualities or GHC.Tc.Solver.approximateImplications + For this, we can treat ic_skols as a set. + +* When checking that a /user-specified/ forall (ic_info = ForAllSkol tvs) + has its variables in the correct order; see Note [Checking telescopes]. + Only for these implications does ic_skols need to be a list. + +Nota bene: Although ic_skols is a list, it is not necessarily +in dependency order: +- In the ic_info=ForAllSkol case, the user might have written them + in the wrong order +- In the case of a type signature like + f :: [a] -> [b] + the renamer gathers the implicit "outer" forall'd variables {a,b}, but + does not know what order to put them in. The type checker can sort them + into dependency order, but only after solving all the kind constraints; + and to do that it's convenient to create the Implication! + +So we accept that ic_skols may be out of order. Think of it as a set or +(in the case of ic_info=ForAllSkol, a list in user-specified, and possibly +wrong, order. + +Note [Insoluble constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some of the errors that we get during canonicalization are best +reported when all constraints have been simplified as much as +possible. For instance, assume that during simplification the +following constraints arise: + + [Wanted] F alpha ~ uf1 + [Wanted] beta ~ uf1 beta + +When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail +we will simply see a message: + 'Can't construct the infinite type beta ~ uf1 beta' +and the user has no idea what the uf1 variable is. + +Instead our plan is that we will NOT fail immediately, but: + (1) Record the "frozen" error in the ic_insols field + (2) Isolate the offending constraint from the rest of the inerts + (3) Keep on simplifying/canonicalizing + +At the end, we will hopefully have substituted uf1 := F alpha, and we +will be able to report a more informative error: + 'Can't construct the infinite type beta ~ F alpha beta' + + +************************************************************************ +* * + approximateWC +* * +************************************************************************ +-} + +type ApproxWC = ( Bag Ct -- Free quantifiable constraints + , TcTyCoVarSet ) -- Free vars of non-quantifiable constraints + -- due to shape, or enclosing equality + -- Why do we need that TcTyCoVarSet of non-quantifiable constraints? + -- See (DP1) in Note [decideAndPromoteTyVars] in GHC.Tc.Solver +approximateWC :: Bool -> WantedConstraints -> Bag Ct +approximateWC include_non_quantifiable cts + = fst (approximateWCX include_non_quantifiable cts) + +approximateWCX :: Bool -> WantedConstraints -> ApproxWC +-- The "X" means "extended"; +-- we return both quantifiable and non-quantifiable constraints +-- See Note [ApproximateWC] +-- See Note [floatKindEqualities vs approximateWC] +approximateWCX include_non_quantifiable wc + = float_wc False emptyVarSet wc (emptyBag, emptyVarSet) + where + float_wc :: Bool -- True <=> there are enclosing equalities + -> TcTyCoVarSet -- Enclosing skolem binders + -> WantedConstraints + -> ApproxWC -> ApproxWC + float_wc encl_eqs trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) acc + = foldBag_flip (float_ct encl_eqs trapping_tvs) simples $ + foldBag_flip (float_implic encl_eqs trapping_tvs) implics $ + acc + + float_implic :: Bool -> TcTyCoVarSet -> Implication + -> ApproxWC -> ApproxWC + float_implic encl_eqs trapping_tvs imp + = float_wc new_encl_eqs new_trapping_tvs (ic_wanted imp) + where + new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp + new_encl_eqs = encl_eqs || ic_given_eqs imp == MaybeGivenEqs + + float_ct :: Bool -> TcTyCoVarSet -> Ct + -> ApproxWC -> ApproxWC + float_ct encl_eqs skol_tvs ct acc@(quant, no_quant) + | isGivenCt ct = acc + -- There can be (insoluble) Given constraints in wc_simple, + -- there so that we get error reports for unreachable code + -- See `given_insols` in GHC.Tc.Solver.Solve.solveImplication + | insolubleCt ct = acc + | pred_tvs `intersectsVarSet` skol_tvs = acc + | include_non_quantifiable = add_to_quant + | is_quantifiable encl_eqs (ctPred ct) = add_to_quant + | otherwise = add_to_no_quant + where + pred = ctPred ct + pred_tvs = tyCoVarsOfType pred + add_to_quant = (ct `consBag` quant, no_quant) + add_to_no_quant = (quant, no_quant `unionVarSet` pred_tvs) + + is_quantifiable encl_eqs pred + = case classifyPredType pred of + -- See the classification in Note [ApproximateWC] + EqPred eq_rel ty1 ty2 + | encl_eqs -> False -- encl_eqs: See Wrinkle (W1) + | otherwise -> quantify_equality eq_rel ty1 ty2 + + 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 + -> False + + | otherwise + -> True -- See Wrinkle (W2) + + IrredPred {} -> True -- See Wrinkle (W2) + + ForAllPred {} -> warnPprTrace True "Unexpected ForAllPred" (ppr pred) $ + False -- See Wrinkle (W4) + + -- 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, _) -> isTypeFamilyTyCon tc + _ -> False + +{- Note [ApproximateWC] +~~~~~~~~~~~~~~~~~~~~~~~ +approximateWC takes a constraint, typically arising from the RHS of a +let-binding whose type we are *inferring*, and extracts from it some *simple* +constraints that we might plausibly abstract over. Of course the top-level +simple constraints are plausible, but we also float constraints out from inside, +if they are not captured by skolems. + +The same function is used when doing type-class defaulting (see the call +to applyDefaultingRules) to extract constraints that might be defaulted. + +We proceed by classifying the constraint: + * ClassPred: + * Never pick a CallStack constraint. + See Note [Overview of implicit CallStacks] + * Always pick an implicit-parameter constraint. + Note [Inheriting implicit parameters] + See wrinkle (W2) + + * EqPred: see Note [Quantifying over equality constraints] + + * IrredPred: we allow anything. + + * ForAllPred: never quantify over these + +Wrinkle (W1) + When inferring most-general types (in simplifyInfer), we + do *not* quantify over equality constraint if the implication binds + equality constraints, because that defeats the OutsideIn story. + Consider data T a where { TInt :: T Int; MkT :: T a } + f TInt = 3::Int + We get the implication (a ~ Int => res ~ Int), where so far we've decided + f :: T a -> res + We don't want to float (res~Int) out because then we'll infer + f :: T a -> Int + which is only on of the possible types. (GHC 7.6 accidentally *did* + float out of such implications, which meant it would happily infer + non-principal types.) + +Wrinkle (W2) + We do allow /class/ constraints to float, even if the implication binds + equalities. This is a subtle point: see #23224. In principle, a class + constraint might ultimately be satisfiable from a constraint bound by an + implication (see #19106 for an example of this kind), but it's extremely + obscure and I was unable to construct a concrete example. In any case, in + super-subtle cases where this might make a difference, you would be much + better advised to simply write a type signature. + +Wrinkle (W3) + In findDefaultableGroups we are not worried about the most-general type; and + we /do/ want to float out of equalities (#12797). Hence we just union the two + returned lists. + +Wrinkle (W4) + In #26376 we had constraints + [W] d1 : Functor f[tau:1] + [W] d2 : Functor p[tau:1] + [W] d3 : forall a. Functor (p[tau:1]) a -- A quantified constraint + We certainly don't want to /quantify/ over d3; but we /do/ want to + quantify over `p`, so it would be a mistake to make the function monomorphic + in `p` just because `p` is mentioned in this quantified constraint. + + Happily this problem cannot happen any more. That quantified constraint `d3` + dates from a time when we flirted with an all-or-nothing strategy for + quantified constraints Nowadays we'll never see this: we'll have simplified + that quantified constraint into a implication constraint. (Exception: + SPECIALISE pragmas: see (WFA4) in Note [Solving a Wanted forall-constraint]. + But there we don't use approximateWC.) + +------ Historical note ----------- +There used to be a second caveat, driven by #8155 + + 2. We do not float out an inner constraint that shares a type variable + (transitively) with one that is trapped by a skolem. Eg + forall a. F a ~ beta, Integral beta + We don't want to float out (Integral beta). Doing so would be bad + when defaulting, because then we'll default beta:=Integer, and that + makes the error message much worse; we'd get + Can't solve F a ~ Integer + rather than + Can't solve Integral (F a) + + Moreover, floating out these "contaminated" constraints doesn't help + when generalising either. If we generalise over (Integral b), we still + can't solve the retained implication (forall a. F a ~ b). Indeed, + arguably that too would be a harder error to understand. + +But this transitive closure stuff gives rise to a complex rule for +when defaulting actually happens, and one that was never documented. +Moreover (#12923), the more complex rule is sometimes NOT what +you want. So I simply removed the extra code to implement the +contamination stuff. There was zero effect on the testsuite (not even #8155). +------ End of historical note ----------- + +Note [Quantifying over equality constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should we quantify over an equality constraint (s ~ t) +in pickQuantifiablePreds? + +* It is always /sound/ to quantify over a constraint -- those + quantified constraints will need to be proved at each call site. + +* We definitely don't want to quantify over (Maybe a ~ Bool), to get + f :: forall a. (Maybe a ~ Bool) => blah + That simply postpones a type error from the function definition site to + its call site. Fortunately we have already filtered out insoluble + constraints: see `definite_error` in `simplifyInfer`. + +* What about (a ~ T alpha b), where we are about to quantify alpha, `a` and + `b` are in-scope skolems, and `T` is a data type. It's pretty unlikely + that this will be soluble at a call site, so we don't quantify over it. + +* What about `(F beta ~ Int)` where we are going to quantify `beta`? + Should we quantify over the (F beta ~ Int), to get + f :: forall b. (F b ~ Int) => blah + Aha! Perhaps yes, because at the call site we will instantiate `b`, and + perhaps we have `instance F Bool = Int`. So we *do* quantify over a + type-family equality where the arguments mention the quantified variables. + +This is all a bit ad-hoc. + + +************************************************************************ +* * + Invariant checking (debug only) +* * +************************************************************************ + +Note [Implication invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The skolems of an implication have the following invariants, which are checked +by checkImplicationInvariants: + +a) They are all SkolemTv TcTyVars; no TyVars, no unification variables +b) Their TcLevel matches the ic_lvl for the implication +c) Their SkolemInfo matches the implication. + +Actually (c) is not quite true. Consider + data T a = forall b. MkT a b + +In tcConDecl for MkT we'll create an implication with ic_info of +DataConSkol; but the type variable 'a' will have a SkolemInfo of +TyConSkol. So we allow the tyvar to have a SkolemInfo of TyConFlav if +the implication SkolemInfo is DataConSkol. +-} + +checkImplicationInvariants, check_implic :: (HasCallStack, Applicative m) => Implication -> m () +{-# INLINE checkImplicationInvariants #-} +-- Nothing => OK, Just doc => doc gives info +checkImplicationInvariants implic = when debugIsOn (check_implic implic) + +check_implic implic@(Implic { ic_tclvl = lvl + , ic_info = skol_info + , ic_skols = skols }) + | null bads = pure () + | otherwise = massertPpr False (vcat [ text "checkImplicationInvariants failure" + , nest 2 (vcat bads) + , ppr implic ]) + where + bads = mapMaybe check skols + + check :: TcTyVar -> Maybe SDoc + check tv | not (isTcTyVar tv) + = Just (ppr tv <+> text "is not a TcTyVar") + | otherwise + = check_details tv (tcTyVarDetails tv) + + check_details :: TcTyVar -> TcTyVarDetails -> Maybe SDoc + check_details tv (SkolemTv tv_skol_info tv_lvl _) + | not (tv_lvl `sameDepthAs` lvl) + = Just (vcat [ ppr tv <+> text "has level" <+> ppr tv_lvl + , text "ic_lvl" <+> ppr lvl ]) + | not (skol_info `checkSkolInfoAnon` skol_info_anon) + = Just (vcat [ ppr tv <+> text "has skol info" <+> ppr skol_info_anon + , text "ic_info" <+> ppr skol_info ]) + | otherwise + = Nothing + where + skol_info_anon = getSkolemInfo tv_skol_info + check_details tv details + = Just (ppr tv <+> text "is not a SkolemTv" <+> ppr details) + +checkSkolInfoAnon :: SkolemInfoAnon -- From the implication + -> SkolemInfoAnon -- From the type variable + -> Bool -- True <=> ok +-- Used only for debug-checking; checkImplicationInvariants +-- So it doesn't matter much if its's incomplete +checkSkolInfoAnon sk1 sk2 = go sk1 sk2 + where + go (SigSkol c1 t1 s1) (SigSkol c2 t2 s2) = c1==c2 && t1 `tcEqType` t2 && s1==s2 + go (SigTypeSkol cx1) (SigTypeSkol cx2) = cx1==cx2 + + go (ForAllSkol _) (ForAllSkol _) = True + + go (IPSkol ips1) (IPSkol ips2) = ips1 == ips2 + go (DerivSkol pred1) (DerivSkol pred2) = pred1 `tcEqType` pred2 + go (TyConSkol f1 n1) (TyConSkol f2 n2) = f1==f2 && n1==n2 + go (DataConSkol n1) (DataConSkol n2) = n1==n2 + go (InstSkol {}) (InstSkol {}) = True + go (MethSkol n1 d1) (MethSkol n2 d2) = n1==n2 && d1==d2 + go FamInstSkol FamInstSkol = True + go BracketSkol BracketSkol = True + go (RuleSkol n1) (RuleSkol n2) = n1==n2 + go (SpecESkol n1) (SpecESkol n2) = n1==n2 + go (PatSkol c1 _) (PatSkol c2 _) = getName c1 == getName c2 + -- Too tedious to compare the HsMatchContexts + go (InferSkol ids1) (InferSkol ids2) = equalLength ids1 ids2 && + and (zipWith eq_pr ids1 ids2) + go (UnifyForAllSkol t1) (UnifyForAllSkol t2) = t1 `tcEqType` t2 + go ReifySkol ReifySkol = True + go RuntimeUnkSkol RuntimeUnkSkol = True + go ArrowReboundIfSkol ArrowReboundIfSkol = True + go (UnkSkol _) (UnkSkol _) = True + + -------- Three slightly strange special cases -------- + go (DataConSkol _) (TyConSkol f _) = h98_data_decl f + -- In the H98 declaration data T a = forall b. MkT a b + -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of + -- DataConSkol, but the type variable 'a' will have a SkolemInfo of TyConSkol + + go (DataConSkol _) FamInstSkol = True + -- In data/newtype instance T a = MkT (a -> a), + -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of + -- DataConSkol, but 'a' will have SkolemInfo of FamInstSkol + + go FamInstSkol (InstSkol {}) = True + -- In instance C (T a) where { type F (T a) b = ... } + -- we have 'a' with SkolemInfo InstSkol, but we make an implication wi + -- SkolemInfo of FamInstSkol. Very like the ConDecl/TyConSkol case + + go (ForAllSkol _) _ = True + -- Telescope tests: we need a ForAllSkol to force the telescope + -- test, but the skolems might come from (say) a family instance decl + -- type instance forall a. F [a] = a->a + + go (SigTypeSkol DerivClauseCtxt) (TyConSkol f _) = h98_data_decl f + -- e.g. newtype T a = MkT ... deriving blah + -- We use the skolems from T (TyConSkol) when typechecking + -- the deriving clauses (SigTypeSkol DerivClauseCtxt) + + go _ _ = False + + eq_pr :: (Name,TcType) -> (Name,TcType) -> Bool + eq_pr (i1,_) (i2,_) = i1==i2 -- Types may be differently zonked + + h98_data_decl DataTypeFlavour = True + h98_data_decl NewtypeFlavour = True + h98_data_decl _ = False + + +{- ********************************************************************* +* * + Pretty printing +* * +********************************************************************* -} + +pprEvVars :: [EvVar] -> SDoc -- Print with their types +pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) + +pprEvVarTheta :: [EvVar] -> SDoc +pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) + +pprEvVarWithType :: EvVar -> SDoc +pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) + + + +wrapType :: Type -> [TyVar] -> [PredType] -> Type +wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty + + +{- +************************************************************************ +* * + CtEvidence +* * +************************************************************************ + +Note [CtEvidence invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The `ctev_pred` field of a `CtEvidence` is a just a cache for the type +of the evidence. More precisely: + +* For Givens, `ctev_pred` = `varType ctev_evar` +* For Wanteds, `ctev_pred` = `evDestType ctev_dest` + +where + + evDestType :: TcEvDest -> TcType + evDestType (EvVarDest evVar) = varType evVar + evDestType (HoleDest coercionHole) = varType (coHoleCoVar coercionHole) + +The invariant is maintained by `setCtEvPredType`, the only function that +updates the `ctev_pred` field of a `CtEvidence`. + +Why is the invariant important? Because when the evidence is a coercion, it may +be used in (CastTy ty co); and then we may call `typeKind` on that type (e.g. +in the kind-check of `eqType`); and expect to see a fully zonked kind. +(This came up in test T13333, in the MR that fixed #20641, namely !6942.) + +Historical Note [Evidence field of CtEvidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the past we tried leaving the `ctev_evar`/`ctev_dest` field of a +constraint untouched (and hence un-zonked) on the grounds that it is +never looked at. But in fact it is: the evidence can become part of a +type (via `CastTy ty kco`) and we may later ask the kind of that type +and expect a zonked result. (For example, in the kind-check +of `eqType`.) + +The safest thing is simply to keep `ctev_evar`/`ctev_dest` in sync +with `ctev_pred`, as stated in `Note [CtEvidence invariants]`. + +Note [Bind new Givens immediately] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Givens we make new EvVars and bind them immediately. Two main reasons: + * Gain sharing. E.g. suppose we start with g :: C a b, where + class D a => C a b + class (E a, F a) => D a + If we generate all g's superclasses as separate EvTerms we might + get selD1 (selC1 g) :: E a + selD2 (selC1 g) :: F a + selC1 g :: D a + which we could do more economically as: + g1 :: D a = selC1 g + g2 :: E a = selD1 g1 + g3 :: F a = selD2 g1 + + * For *coercion* evidence we *must* bind each given: + class (a~b) => C a b where .... + f :: C a b => .... + Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. + But that superclass selector can't (yet) appear in a coercion + (see evTermCoercion), so the easy thing is to bind it to an Id. + +So a Given has EvVar inside it rather than (as previously) an EvTerm. + +Note [The rewrite-role of a constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rewrite-role of a constraint says what can rewrite that constraint: + +* If the rewrite-role = Nominal, only a nominal equality can rewrite it + +* If the rewrite-rule = Representational, either a nominal or + representational equality can rewrit it. + +Notice that the constraint may itself not be an equality at all. +For example, the rewrite-role of (Eq [a]) is Nominal; only nominal +equalities can rewrite it. +-} + +-- | A place for type-checking evidence to go after it is generated. +-- +-- - Wanted equalities use HoleDest, +-- - other Wanteds use EvVarDest. +data TcEvDest + = EvVarDest EvVar -- ^ bind this var to the evidence + -- EvVarDest is always used for non-type-equalities + -- e.g. class constraints + + | HoleDest CoercionHole -- ^ fill in this hole with the evidence + -- HoleDest is always used for type-equalities + -- See Note [Coercion holes] in GHC.Core.TyCo.Rep + +data CtEvidence + = CtGiven GivenCtEvidence + | CtWanted WantedCtEvidence + +-- | Evidence for a Given constraint +data GivenCtEvidence = + GivenCt + { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] + , ctev_evar :: EvVar -- See Note [CtEvidence invariants] + , ctev_loc :: CtLoc } + +-- | Evidence for a Wanted constraint +data WantedCtEvidence = + WantedCt + { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] + , ctev_dest :: TcEvDest -- See Note [CtEvidence invariants] + , ctev_loc :: CtLoc + , ctev_rewriters :: RewriterSet } -- See Note [Wanteds rewrite Wanteds] + +ctEvPred :: CtEvidence -> TcPredType +-- The predicate of a flavor +ctEvPred (CtGiven (GivenCt { ctev_pred = pred })) = pred +ctEvPred (CtWanted (WantedCt { ctev_pred = pred })) = pred + +ctEvLoc :: CtEvidence -> CtLoc +ctEvLoc (CtGiven (GivenCt { ctev_loc = loc })) = loc +ctEvLoc (CtWanted (WantedCt { ctev_loc = loc })) = loc + +ctEvOrigin :: CtEvidence -> CtOrigin +ctEvOrigin = ctLocOrigin . ctEvLoc + +-- | Get the equality relation relevant for a 'CtEvidence' +ctEvEqRel :: HasDebugCallStack => CtEvidence -> EqRel +ctEvEqRel = predTypeEqRel . ctEvPred + +-- | Get the rewrite-role relevant for a 'CtEvidence' +-- See Note [The rewrite-role of a constraint] +ctEvRewriteRole :: HasDebugCallStack => CtEvidence -> Role +ctEvRewriteRole = eqRelRole . ctEvRewriteEqRel + +ctEvRewriteEqRel :: CtEvidence -> EqRel +-- ^ Return the rewrite-role of an abitrary CtEvidence +-- See Note [The rewrite-role of a constraint] +-- We return ReprEq for (a ~R# b) and NomEq for all other preds +ctEvRewriteEqRel = predTypeEqRel . ctEvPred + +ctEvTerm :: CtEvidence -> EvTerm +ctEvTerm ev = EvExpr (ctEvExpr ev) + +-- | Extract the set of rewriters from a 'CtEvidence' +-- See Note [Wanteds rewrite Wanteds] +-- If the provided CtEvidence is not for a Wanted, just +-- return an empty set. +ctEvRewriters :: CtEvidence -> RewriterSet +ctEvRewriters (CtWanted (WantedCt { ctev_rewriters = rws })) = rws +ctEvRewriters (CtGiven {}) = emptyRewriterSet + +ctHasNoRewriters :: Ct -> Bool +ctHasNoRewriters ev + = case ctEvidence ev of + CtWanted wev -> wantedCtHasNoRewriters wev + CtGiven {} -> True + +wantedCtHasNoRewriters :: WantedCtEvidence -> Bool +wantedCtHasNoRewriters (WantedCt { ctev_rewriters = rws }) + = isEmptyRewriterSet rws + +-- | Set the rewriter set of a Wanted constraint. +setWantedCtEvRewriters :: WantedCtEvidence -> RewriterSet -> WantedCtEvidence +setWantedCtEvRewriters ev rs = ev { ctev_rewriters = rs } + +ctEvExpr :: HasDebugCallStack => CtEvidence -> EvExpr +ctEvExpr (CtWanted ev@(WantedCt { ctev_dest = HoleDest _ })) + = Coercion $ ctEvCoercion (CtWanted ev) +ctEvExpr ev = evId (ctEvEvId ev) + +givenCtEvCoercion :: GivenCtEvidence -> TcCoercion +givenCtEvCoercion _given@(GivenCt { ctev_evar = ev_id }) + = assertPpr (isCoVar ev_id) + (text "givenCtEvCoercion used on non-equality Given constraint:" <+> ppr _given) + $ mkCoVarCo ev_id + +ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion +ctEvCoercion (CtGiven _given@(GivenCt { ctev_evar = ev_id })) + = assertPpr (isCoVar ev_id) + (text "ctEvCoercion used on non-equality Given constraint:" <+> ppr (CtGiven _given)) + $ mkCoVarCo ev_id +ctEvCoercion (CtWanted (WantedCt { ctev_dest = dest })) + | HoleDest hole <- dest + = -- ctEvCoercion is only called on type equalities + -- and they always have HoleDests + mkHoleCo hole +ctEvCoercion ev + = pprPanic "ctEvCoercion" (ppr ev) + +ctEvEvId :: CtEvidence -> EvVar +ctEvEvId (CtWanted wtd) = wantedCtEvEvId wtd +ctEvEvId (CtGiven (GivenCt { ctev_evar = ev })) = ev + +wantedCtEvEvId :: WantedCtEvidence -> EvVar +wantedCtEvEvId (WantedCt { ctev_dest = EvVarDest ev }) = ev +wantedCtEvEvId (WantedCt { ctev_dest = HoleDest h }) = coHoleCoVar h + +ctEvUnique :: CtEvidence -> Unique +ctEvUnique (CtGiven (GivenCt { ctev_evar = ev })) = varUnique ev +ctEvUnique (CtWanted (WantedCt { ctev_dest = dest })) = tcEvDestUnique dest + +tcEvDestUnique :: TcEvDest -> Unique +tcEvDestUnique (EvVarDest ev_var) = varUnique ev_var +tcEvDestUnique (HoleDest co_hole) = varUnique (coHoleCoVar co_hole) + +setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence +setCtEvLoc (CtGiven (GivenCt pred evar _)) loc = CtGiven (GivenCt pred evar loc) +setCtEvLoc (CtWanted (WantedCt pred dest _ rwrs)) loc = CtWanted (WantedCt pred dest loc rwrs) + +-- | Set the type of CtEvidence. +-- +-- This function ensures that the invariants on 'CtEvidence' hold, by updating +-- the evidence and the ctev_pred in sync with each other. +-- See Note [CtEvidence invariants]. +setCtEvPredType :: HasDebugCallStack => CtEvidence -> Type -> CtEvidence +setCtEvPredType (CtGiven old_ev@(GivenCt { ctev_evar = ev })) new_pred + = CtGiven (old_ev { ctev_pred = new_pred + , ctev_evar = setVarType ev new_pred }) + +setCtEvPredType (CtWanted old_ev@(WantedCt { ctev_dest = dest })) new_pred + = CtWanted (old_ev { ctev_pred = new_pred + , ctev_dest = new_dest }) + where + new_dest = case dest of + EvVarDest ev -> EvVarDest (setVarType ev new_pred) + HoleDest h -> HoleDest (setCoHoleType h new_pred) + +instance Outputable TcEvDest where + ppr (HoleDest h) = text "hole" <> ppr h + ppr (EvVarDest ev) = ppr ev + +instance Outputable GivenCtEvidence where + ppr = ppr . CtGiven +instance Outputable WantedCtEvidence where + ppr = ppr . CtWanted + +instance Outputable CtEvidence where + ppr ev = ppr (ctEvFlavour ev) + <+> hang (pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)) <> pp_rewriters)) + -- Show the sub-goal depth too + 2 (dcolon <+> pprPredType (ctEvPred ev)) + where + pp_ev = case ev of + CtGiven ev -> ppr (ctev_evar ev) + CtWanted ev -> ppr (ctev_dest ev) + + rewriters = ctEvRewriters ev + pp_rewriters | isEmptyRewriterSet rewriters = empty + | otherwise = semi <> ppr rewriters + +isWanted :: CtEvidence -> Bool +isWanted (CtWanted {}) = True +isWanted _ = False + +isGiven :: CtEvidence -> Bool +isGiven (CtGiven {}) = True +isGiven _ = False + +{- +************************************************************************ +* * + RewriterSet +* * +************************************************************************ +-} + +-- | Stores a set of CoercionHoles that have been used to rewrite a constraint. +-- See Note [Wanteds rewrite Wanteds]. +newtype RewriterSet = RewriterSet (UniqSet CoercionHole) + deriving newtype (Outputable, Semigroup, Monoid) + +emptyRewriterSet :: RewriterSet +emptyRewriterSet = RewriterSet emptyUniqSet + +unitRewriterSet :: CoercionHole -> RewriterSet +unitRewriterSet = coerce (unitUniqSet @CoercionHole) + +unionRewriterSet :: RewriterSet -> RewriterSet -> RewriterSet +unionRewriterSet = coerce (unionUniqSets @CoercionHole) + +isEmptyRewriterSet :: RewriterSet -> Bool +isEmptyRewriterSet = coerce (isEmptyUniqSet @CoercionHole) + +addRewriter :: RewriterSet -> CoercionHole -> RewriterSet +addRewriter = coerce (addOneToUniqSet @CoercionHole) + +rewriterSetFromCts :: Bag Ct -> RewriterSet +-- Take a bag of Wanted equalities, and collect them as a RewriterSet +rewriterSetFromCts cts + = foldr add emptyRewriterSet cts + where + add ct rw_set = + case ctEvidence ct of + CtWanted (WantedCt { ctev_dest = HoleDest hole }) -> rw_set `addRewriter` hole + _ -> rw_set + +{- +************************************************************************ +* * + CtFlavour +* * +************************************************************************ +-} + +data CtFlavour + = Given -- we have evidence + | Wanted -- we want evidence + deriving Eq + +instance Outputable CtFlavour where + ppr Given = text "[G]" + ppr Wanted = text "[W]" + +ctEvFlavour :: CtEvidence -> CtFlavour +ctEvFlavour (CtWanted {}) = Wanted +ctEvFlavour (CtGiven {}) = Given + +-- | Whether or not one 'Ct' can rewrite another is determined by its +-- flavour and its equality relation. See also +-- Note [Flavours with roles] in GHC.Tc.Solver.InertSet +type CtFlavourRole = (CtFlavour, EqRel) + +-- | Extract the flavour, role, and boxity from a 'CtEvidence' +ctEvFlavourRole :: HasDebugCallStack => CtEvidence -> CtFlavourRole +ctEvFlavourRole ev = (ctEvFlavour ev, ctEvRewriteEqRel ev) + +-- | Extract the flavour and role from a 'Ct' +eqCtFlavourRole :: EqCt -> CtFlavourRole +eqCtFlavourRole (EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) + = (ctEvFlavour ev, eq_rel) + +dictCtFlavourRole :: DictCt -> CtFlavourRole +dictCtFlavourRole (DictCt { di_ev = ev }) + = (ctEvFlavour ev, NomEq) + +-- | Extract the flavour and role from a 'Ct' +ctFlavourRole :: HasDebugCallStack => Ct -> CtFlavourRole +-- Uses short-cuts for the Role field, for special cases +ctFlavourRole (CDictCan di_ct) = dictCtFlavourRole di_ct +ctFlavourRole (CEqCan eq_ct) = eqCtFlavourRole eq_ct +ctFlavourRole ct = ctEvFlavourRole (ctEvidence ct) + +{- Note [eqCanRewrite] +~~~~~~~~~~~~~~~~~~~~~~ +(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CEqCan of form +lhs ~ ty) can be used to rewrite ct2. It must satisfy the properties of +a can-rewrite relation, see Definition [Can-rewrite relation] in +GHC.Tc.Solver.Monad. + +With the solver handling Coercible constraints like equality constraints, +the rewrite conditions must take role into account, never allowing +a representational equality to rewrite a nominal one. + +Note [Wanteds rewrite Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should one Wanted constraint be allowed to rewrite another? + +This example (along with #8450) suggests not: + f :: a -> Bool + f x = ( [x,'c'], [x,True] ) `seq` True +Here we get + [W] a ~ Char + [W] a ~ Bool +but we do not want to complain about Bool ~ Char! + +This example suggests yes (indexed-types/should_fail/T4093a): + type family Foo a + f :: (Foo e ~ Maybe e) => Foo e +In the ambiguity check, we get + [G] g1 :: Foo e ~ Maybe e + [W] w1 :: Foo alpha ~ Foo e + [W] w2 :: Foo alpha ~ Maybe alpha +w1 gets rewritten by the Given to become + [W] w3 :: Foo alpha ~ Maybe e +Now, the only way to make progress is to allow Wanteds to rewrite Wanteds. +Rewriting w3 with w2 gives us + [W] w4 :: Maybe alpha ~ Maybe e +which will soon get us to alpha := e and thence to victory. + +TL;DR we want equality saturation. + +We thus want Wanteds to rewrite Wanteds in order to accept more programs, +but we don't want Wanteds to rewrite Wanteds because doing so can create +inscrutable error messages. To solve this dilemma: + +* We allow Wanteds to rewrite Wanteds, but each Wanted tracks the set of Wanteds + it has been rewritten by, in its RewriterSet, stored in the ctev_rewriters + field of the CtWanted constructor of CtEvidence. (Only Wanteds have + RewriterSets.) + +* A RewriterSet is just a set of unfilled CoercionHoles. This is sufficient + because only equalities (evidenced by coercion holes) are used for rewriting; + other (dictionary) constraints cannot ever rewrite. + +* The rewriter (in e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks and returns a RewriterSet, + consisting of the evidence (a CoercionHole) for any Wanted equalities used in + rewriting. + +* Then GHC.Tc.Solver.Solve.rewriteEvidence and GHC.Tc.Solver.Equality.rewriteEqEvidence + add this RewriterSet to the rewritten constraint's rewriter set. + +* We prevent the unifier from unifying any equality with a non-empty rewriter set; + unification effectively turns a Wanted into a Given, and we lose all tracking. + See (REWRITERS) in Note [Unification preconditions] in GHC.Tc.Utils.Unify and + Note [Unify only if the rewriter set is empty] in GHC.Solver.Equality. + +* In error reporting, we simply suppress any errors that have been rewritten + by /unsolved/ wanteds. This suppression happens in GHC.Tc.Errors.mkErrorItem, + which uses `GHC.Tc.Zonk.Type.zonkRewriterSet` to look through any filled + coercion holes. The idea is that we wish to report the "root cause" -- the + error that rewrote all the others. + +* In `selectNextWorkItem`, priorities equalities with no rewiters. See + Note [Prioritise Wanteds with empty RewriterSet] in GHC.Tc.Types.Constraint + wrinkle (PER1). + +* In error reporting, we prioritise Wanteds that have an empty RewriterSet: + see Note [Prioritise Wanteds with empty RewriterSet]. + +Let's continue our first example above: + + inert: [W] w1 :: a ~ Char + work: [W] w2 :: a ~ Bool + +Because Wanteds can rewrite Wanteds, w1 will rewrite w2, yielding + + inert: [W] w1 :: a ~ Char + [W] w2 {w1}:: Char ~ Bool + +The {w1} in the second line of output is the RewriterSet of w1. + +Wrinkles: + +(WRW1) When we find a constraint identical to one already in the inert set, + we solve one from the other. Other things being equal, keep the one + that has fewer (better still no) rewriters. + See (CE4) in Note [Combining equalities] in GHC.Tc.Solver.Equality. + + To this accurately we should use `zonkRewriterSet` during canonicalisation, + to eliminate rewriters that have now been solved. Currently we only do so + during error reporting; but perhaps we should change that. + +(WRW2) When zonking a constraint (with `zonkCt` and `zonkCtEvidence`) we take + the opportunity to zonk its `RewriterSet`, which eliminates solved ones. + This doesn't guarantee that rewriter sets are always up to date -- see + (WRW1) -- but it helps, and it de-clutters debug output. + +Note [Prioritise Wanteds with empty RewriterSet] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When extending the WorkList, in GHC.Tc.Solver.InertSet.extendWorkListEq, +we prioritise constraints that have no rewriters. Here's why. + +Consider this, which came up in T22793: + inert: {} + work list: [W] co_ayf : awq ~ awo + work item: [W] co_ayb : awq ~ awp + + ==> {just put work item in inert set} + inert: co_ayb : awq ~ awp + work list: {} + work: [W] co_ayf : awq ~ awo + + ==> {rewrite ayf with co_ayb} + work list: {} + inert: co_ayb : awq ~ awp + co_aym{co_ayb} : awp ~ awo + ^ rewritten by ayb + + ----- start again in simplify_loop in Solver.hs ----- + inert: {} + work list: [W] co_ayb : awq ~ awp + work: co_aym{co_ayb} : awp ~ awo + + ==> {add to inert set} + inert: co_aym{co_ayb} : awp ~ awo + work list: {} + work: co_ayb : awq ~ awp + + ==> {rewrite co_ayb} + inert: co_aym{co_ayb} : awp ~ awo + co_ayp{co_aym} : awq ~ awo + work list: {} + +Now both wanteds have been rewriten by the other! This happened because +in our simplify_loop iteration, we happened to start with co_aym. All would have +been well if we'd started with the (not-rewritten) co_ayb and gotten it into the +inert set. + +With that in mind, we /prioritise/ the work-list to put +constraints with no rewriters first. This prioritisation +is done in `GHC.Tc.Solver.Monad.selectNextWorkItem`. + +Wrinkles + +(PER1) When picking the next work item, before checking for an empty RewriterSet + in GHC.Tc.Solver.Monad.selectNextWorkItem, we zonk the RewriterSet, because + some of those CoercionHoles may have been filled in since we last looked. + +(PER2) Despite the prioritisation, it is hard to be /certain/ that we can't end up + in a situation where all of the Wanteds have rewritten each other. In + order to report /some/ error in this case, we simply report all the + Wanteds. The user will get a perhaps-confusing error message, but they've + written a confusing program! (T22707 and T22793 were close, but they do + not exhibit this behaviour.) So belt and braces: see the `suppress` + stuff in GHC.Tc.Errors.mkErrorItem. + +Note [Avoiding rewriting cycles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet describes +the can-rewrite relation among CtFlavour/Role pairs, saying which constraints +can rewrite which other constraints. It puts forth (R2): + (R2) If f1 >= f, and f2 >= f, + then either f1 >= f2 or f2 >= f1 +The naive can-rewrite relation says that (Given, Representational) can rewrite +(Wanted, Representational) and that (Wanted, Nominal) can rewrite +(Wanted, Representational), but neither of (Given, Representational) and +(Wanted, Nominal) can rewrite the other. This would violate (R2). See also +Note [Why R2?] in GHC.Tc.Solver.InertSet. + +To keep R2, we do not allow (Wanted, Nominal) to rewrite (Wanted, Representational). +This can, in theory, bite, in this scenario: + + type family F a + data T a + type role T nominal + + [G] F a ~N T a + [W] F alpha ~N T alpha + [W] F alpha ~R T a + +As written, this makes no progress, and GHC errors. But, if we +allowed W/N to rewrite W/R, the first W could rewrite the second: + + [G] F a ~N T a + [W] F alpha ~N T alpha + [W] T alpha ~R T a + +Now we decompose the second W to get + + [W] alpha ~N a + +noting the role annotation on T. This causes (alpha := a), and then +everything else unlocks. + +What to do? We could "decompose" nominal equalities into nominal-only +("NO") equalities and representational ones, where a NO equality rewrites +only nominals. That is, when considering whether [W] F alpha ~N T alpha +should rewrite [W] F alpha ~R T a, we could require splitting the first W +into [W] F alpha ~NO T alpha, [W] F alpha ~R T alpha. Then, we use the R +half of the split to rewrite the second W, and off we go. This splitting +would allow the split-off R equality to be rewritten by other equalities, +thus avoiding the problem in Note [Why R2?] in GHC.Tc.Solver.InertSet. + +However, note that I said that this bites in theory. That's because no +known program actually gives rise to this scenario. A direct encoding +ends up starting with + + [G] F a ~ T a + [W] F alpha ~ T alpha + [W] Coercible (F alpha) (T a) + +where ~ and Coercible denote lifted class constraints. The ~s quickly +reduce to ~N: good. But the Coercible constraint gets rewritten to + + [W] Coercible (T alpha) (T a) + +by the first Wanted. This is because Coercible is a class, and arguments +in class constraints use *nominal* rewriting, not the representational +rewriting that is restricted due to (R2). Note that reordering the code +doesn't help, because equalities (including lifted ones) are prioritized +over Coercible. Thus, I (Richard E.) see no way to write a program that +is rejected because of this infelicity. I have not proved it impossible, +exactly, but my usual tricks have not yielded results. + +In the olden days, when we had Derived constraints, this Note was all +about G/R and D/N both rewriting D/R. Back then, the code in +typecheck/should_compile/T19665 really did get rejected. But now, +according to the rewriting of the Coercible constraint, the program +is accepted. + +-} + +eqCanRewrite :: EqRel -> EqRel -> Bool +eqCanRewrite NomEq _ = True +eqCanRewrite ReprEq ReprEq = True +eqCanRewrite ReprEq NomEq = False + +eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool +-- Can fr1 actually rewrite fr2? +-- Very important function! +-- See Note [eqCanRewrite] +-- See Note [Wanteds rewrite Wanteds] +-- See Note [Avoiding rewriting cycles] +eqCanRewriteFR (Given, r1) (_, r2) = eqCanRewrite r1 r2 +eqCanRewriteFR (Wanted, NomEq) (Wanted, ReprEq) = False +eqCanRewriteFR (Wanted, r1) (Wanted, r2) = eqCanRewrite r1 r2 +eqCanRewriteFR (Wanted, _) (Given, _) = False diff --git a/GHC/Tc/Types/CtLoc.hs b/GHC/Tc/Types/CtLoc.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/CtLoc.hs @@ -0,0 +1,259 @@ +module GHC.Tc.Types.CtLoc ( + + -- * CtLoc + CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, + ctLocTypeOrKind_maybe, toInvisibleLoc, + ctLocDepth, bumpCtLocDepth, isGivenLoc, mkGivenLoc, mkKindEqLoc, + setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan, + pprCtLoc, adjustCtLoc, adjustCtLocTyConBinder, + + -- * CtLocEnv + CtLocEnv(..), + getCtLocEnvLoc, setCtLocEnvLoc, setCtLocRealLoc, + getCtLocEnvLvl, setCtLocEnvLvl, + ctLocEnvInGeneratedCode, + + -- * SubGoalDepth + SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, + bumpSubGoalDepth, subGoalDepthExceeded + + ) where + +import GHC.Prelude + +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Types.ErrCtxt +import GHC.Tc.Types.Origin + +import GHC.Tc.Utils.TcType + +import GHC.Types.SrcLoc +import GHC.Types.Name.Reader +import GHC.Types.Basic( IntWithInf, mkIntWithInf, TypeOrKind(..) ) + +import GHC.Core.TyCon( TyConBinder, isVisibleTyConBinder, isNamedTyConBinder ) + +import GHC.Utils.Outputable + + +{- ********************************************************************* +* * + SubGoalDepth +* * +********************************************************************* -} + +{- Note [SubGoalDepth] +~~~~~~~~~~~~~~~~~~~~~~ +The 'SubGoalDepth' takes care of stopping the constraint solver from looping. + +The counter starts at zero and increases. It includes dictionary constraints, +equality simplification, and type family reduction. (Why combine these? Because +it's actually quite easy to mistake one for another, in sufficiently involved +scenarios, like ConstraintKinds.) + +The flag -freduction-depth=n fixes the maximum level. + +* The counter includes the depth of type class instance declarations. Example: + [W] d{7} : Eq [Int] + That is d's dictionary-constraint depth is 7. If we use the instance + $dfEqList :: Eq a => Eq [a] + to simplify it, we get + d{7} = $dfEqList d'{8} + where d'{8} : Eq Int, and d' has depth 8. + + For civilised (decidable) instance declarations, each increase of + depth removes a type constructor from the type, so the depth never + gets big; i.e. is bounded by the structural depth of the type. + +* The counter also increments when resolving +equalities involving type functions. Example: + Assume we have a wanted at depth 7: + [W] d{7} : F () ~ a + If there is a type function equation "F () = Int", this would be rewritten to + [W] d{8} : Int ~ a + and remembered as having depth 8. + + Again, without UndecidableInstances, this counter is bounded, but without it + can resolve things ad infinitum. Hence there is a maximum level. + +* Lastly, every time an equality is rewritten, the counter increases. Again, + rewriting an equality constraint normally makes progress, but it's possible + the "progress" is just the reduction of an infinitely-reducing type family. + Hence we need to track the rewrites. + +When compiling a program requires a greater depth, then GHC recommends turning +off this check entirely by setting -freduction-depth=0. This is because the +exact number that works is highly variable, and is likely to change even between +minor releases. Because this check is solely to prevent infinite compilation +times, it seems safe to disable it when a user has ascertained that their program +doesn't loop at the type level. + +-} + +-- | See Note [SubGoalDepth] +newtype SubGoalDepth = SubGoalDepth Int + deriving (Eq, Ord, Outputable) + +initialSubGoalDepth :: SubGoalDepth +initialSubGoalDepth = SubGoalDepth 0 + +bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth +bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1) + +maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth +maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m) + +subGoalDepthExceeded :: IntWithInf -> SubGoalDepth -> Bool +subGoalDepthExceeded reductionDepth (SubGoalDepth d) + = mkIntWithInf d > reductionDepth + + +{- ********************************************************************* +* * + CtLoc +* * +************************************************************************ + +The 'CtLoc' gives information about where a constraint came from. +This is important for decent error message reporting because +dictionaries don't appear in the original source code. + +-} + +data CtLoc = CtLoc { ctl_origin :: CtOrigin + , ctl_env :: CtLocEnv -- Everything we need to know about + -- the context this Ct arose in. + , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure + , ctl_depth :: !SubGoalDepth } + +mkKindEqLoc :: TcType -> TcType -- original *types* being compared + -> CtLoc -> CtLoc +mkKindEqLoc s1 s2 ctloc + | CtLoc { ctl_t_or_k = t_or_k, ctl_origin = origin } <- ctloc + = ctloc { ctl_origin = KindEqOrigin s1 s2 origin t_or_k + , ctl_t_or_k = Just KindLevel } + +adjustCtLocTyConBinder :: TyConBinder -> CtLoc -> CtLoc +-- Adjust the CtLoc when decomposing a type constructor +adjustCtLocTyConBinder tc_bndr loc + = adjustCtLoc is_vis is_kind loc + where + is_vis = isVisibleTyConBinder tc_bndr + is_kind = isNamedTyConBinder tc_bndr + +adjustCtLoc :: Bool -- True <=> A visible argument + -> Bool -- True <=> A kind argument + -> CtLoc -> CtLoc +-- Adjust the CtLoc when decomposing a type constructor, application, etc +adjustCtLoc is_vis is_kind loc + = loc2 + where + loc1 | is_kind = toKindLoc loc + | otherwise = loc + loc2 | is_vis = loc1 + | otherwise = toInvisibleLoc loc1 + +-- | Take a CtLoc and moves it to the kind level +toKindLoc :: CtLoc -> CtLoc +toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } + +toInvisibleLoc :: CtLoc -> CtLoc +toInvisibleLoc loc = updateCtLocOrigin loc toInvisibleOrigin + +mkGivenLoc :: TcLevel -> SkolemInfoAnon -> CtLocEnv -> CtLoc +mkGivenLoc tclvl skol_info env + = CtLoc { ctl_origin = GivenOrigin skol_info + , ctl_env = setCtLocEnvLvl env tclvl + , ctl_t_or_k = Nothing -- this only matters for error msgs + , ctl_depth = initialSubGoalDepth } + +ctLocEnv :: CtLoc -> CtLocEnv +ctLocEnv = ctl_env + +ctLocLevel :: CtLoc -> TcLevel +ctLocLevel loc = getCtLocEnvLvl (ctLocEnv loc) + +ctLocDepth :: CtLoc -> SubGoalDepth +ctLocDepth = ctl_depth + +ctLocOrigin :: CtLoc -> CtOrigin +ctLocOrigin = ctl_origin + +ctLocSpan :: CtLoc -> RealSrcSpan +ctLocSpan (CtLoc { ctl_env = lcl}) = getCtLocEnvLoc lcl + +ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind +ctLocTypeOrKind_maybe = ctl_t_or_k + +setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc +setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (setCtLocRealLoc lcl loc) + +bumpCtLocDepth :: CtLoc -> CtLoc +bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d } + +setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc +setCtLocOrigin ctl orig = ctl { ctl_origin = orig } + +updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc +updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd + = ctl { ctl_origin = upd orig } + +setCtLocEnv :: CtLoc -> CtLocEnv -> CtLoc +setCtLocEnv ctl env = ctl { ctl_env = env } + +isGivenLoc :: CtLoc -> Bool +isGivenLoc loc = isGivenOrigin (ctLocOrigin loc) + +pprCtLoc :: CtLoc -> SDoc +-- "arising from ... at ..." +-- Not an instance of Outputable because of the "arising from" prefix +pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl}) + = sep [ pprCtOrigin o + , text "at" <+> ppr (getCtLocEnvLoc lcl)] + + +{- ********************************************************************* +* * + CtLocEnv +* * +********************************************************************* -} + +-- | Local typechecker environment for a constraint. +-- +-- Used to restore the environment of a constraint +-- when reporting errors, see `setCtLocM`. +-- +-- See also 'TcLclCtxt'. +data CtLocEnv = CtLocEnv { ctl_ctxt :: ![ErrCtxt] + , ctl_loc :: !RealSrcSpan + , ctl_bndrs :: !TcBinderStack + , ctl_tclvl :: !TcLevel + , ctl_in_gen_code :: !Bool + , ctl_rdr :: !LocalRdrEnv } + +getCtLocEnvLoc :: CtLocEnv -> RealSrcSpan +getCtLocEnvLoc = ctl_loc + +getCtLocEnvLvl :: CtLocEnv -> TcLevel +getCtLocEnvLvl = ctl_tclvl + +setCtLocEnvLvl :: CtLocEnv -> TcLevel -> CtLocEnv +setCtLocEnvLvl env lvl = env { ctl_tclvl = lvl } + +setCtLocRealLoc :: CtLocEnv -> RealSrcSpan -> CtLocEnv +setCtLocRealLoc env ss = env { ctl_loc = ss } + +setCtLocEnvLoc :: CtLocEnv -> SrcSpan -> CtLocEnv +-- See Note [Error contexts in generated code] +-- for the ctl_in_gen_code manipulation +setCtLocEnvLoc env (RealSrcSpan loc _) + = env { ctl_loc = loc, ctl_in_gen_code = False } + +setCtLocEnvLoc env loc@(UnhelpfulSpan _) + | isGeneratedSrcSpan loc + = env { ctl_in_gen_code = True } + | otherwise + = env + +ctLocEnvInGeneratedCode :: CtLocEnv -> Bool +ctLocEnvInGeneratedCode = ctl_in_gen_code diff --git a/GHC/Tc/Types/ErrCtxt.hs b/GHC/Tc/Types/ErrCtxt.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/ErrCtxt.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHC.Tc.Types.ErrCtxt + ( ErrCtxt, ErrCtxtMsg(..) + , UserSigType(..), FunAppCtxtFunArg(..) + , TyConInstFlavour(..) + ) + where + +import GHC.Prelude +import GHC.Hs.Expr +import GHC.Hs.Extension + +import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA ) + +import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt ) +import GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt, ExpectedFunTyOrigin ) +import GHC.Tc.Utils.TcType ( TcType, TcTyCon ) +import GHC.Tc.Zonk.Monad ( ZonkM ) + +import GHC.Types.Basic ( TyConFlavour ) +import GHC.Types.Name ( Name ) +import GHC.Types.SrcLoc ( SrcSpan ) +import GHC.Types.Var ( Id, TyCoVar ) +import GHC.Types.Var.Env ( TidyEnv ) + +import GHC.Unit.Types ( Module, InstantiatedModule ) + +import GHC.Core.Class ( Class ) +import GHC.Core.ConLike ( ConLike ) +import GHC.Core.PatSyn ( PatSyn ) +import GHC.Core.TyCon ( TyCon ) +import GHC.Core.TyCo.Rep ( Type, ThetaType, PredType ) + +import GHC.Unit.State ( UnitState ) + +import GHC.Data.FastString ( FastString ) +import GHC.Utils.Outputable ( Outputable(..) ) + +import Language.Haskell.Syntax.Basic ( FieldLabelString(..) ) +import Language.Haskell.Syntax +import GHC.Boot.TH.Syntax qualified as TH + +import qualified Data.List.NonEmpty as NE + +-------------------------------------------------------------------------------- + +-- | Additional context to include in an error message, e.g. +-- "In the type signature ...", "In the ambiguity check for ...", etc. +type ErrCtxt = (Bool, TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) + -- Monadic so that we have a chance + -- to deal with bound type variables just before error + -- message construction + + -- Bool: True <=> this is a landmark context; do not + -- discard it when trimming for display + +-------------------------------------------------------------------------------- +-- Error message contexts + +data UserSigType p + = UserLHsSigType !(LHsSigType p) + | UserLHsType !(LHsType p) + +instance OutputableBndrId p => Outputable (UserSigType (GhcPass p)) where + ppr (UserLHsSigType ty) = ppr ty + ppr (UserLHsType ty) = ppr ty + +data FunAppCtxtFunArg + = FunAppCtxtExpr !(HsExpr GhcRn) !(HsExpr GhcRn) + | FunAppCtxtTy !(LHsType GhcRn) !(LHsType GhcRn) + +-- | Like 'TyConFlavour' but for instance declarations, with +-- the additional information of whether this we are dealing with +-- a default declaration. +data TyConInstFlavour + = TyConInstFlavour + { tyConInstFlavour :: !(TyConFlavour TyCon) + , tyConInstIsDefault :: !Bool + } + +-- | The "context" of an error message, e.g. "In the expression <...>", +-- "In the pattern <...>", or "In the equations for closed type family <...>". +data ErrCtxtMsg + -- | In an expression. + = ExprCtxt !(HsExpr GhcRn) + -- | In a user-written context. + | ThetaCtxt !UserTypeCtxt !ThetaType + -- | In a quantified constraint. + | QuantifiedCtCtxt !PredType + -- | When checking an inferred type. + | InferredTypeCtxt !Name !TcType + -- | In an inline pragma, or a fixity signature, + -- or a type signature, or... (see 'Sig'). + | SigCtxt !(Sig GhcRn) + -- | In a user-written type signature. + | UserSigCtxt !UserTypeCtxt !(UserSigType GhcRn) + -- | In a record update. + | RecordUpdCtxt !(NE.NonEmpty ConLike) ![Name] ![TyCoVar] + -- | In a class method. + | ClassOpCtxt !Id !Type + -- | In the instance type signature of a class method. + | MethSigCtxt !Name !TcType !TcType + -- | In a pattern type signature. + | PatSigErrCtxt !TcType !TcType + -- | In a pattern. + | PatCtxt !(Pat GhcRn) + -- | In a pattern synonym declaration. + | PatSynDeclCtxt !Name + -- | In a pattern matching context, e.g. a equation for a function binding, + -- or a case alternative, ... + | MatchCtxt !HsMatchContextRn + -- | In a match in a pattern matching context, + -- either for an expression or for an arrow command. + | forall body. (Outputable body) + => MatchInCtxt !(Match GhcRn body) + -- | In a function application. + | FunAppCtxt !FunAppCtxtFunArg !Int + -- | In a function call. + | FunTysCtxt !ExpectedFunTyOrigin !Type !Int !Int + -- | In the result of a function call. + | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int + -- | In the declaration of a type constructor. + | TyConDeclCtxt !Name !(TyConFlavour TyCon) + -- | In a type or data family instance (or default instance). + | TyConInstCtxt !Name !TyConInstFlavour + -- | In the declaration of a data constructor. + | DataConDefCtxt !(NE.NonEmpty (LocatedN Name)) + -- | In the result type of a data constructor. + | DataConResTyCtxt !(NE.NonEmpty (LocatedN Name)) + -- | In the equations for a closed type family. + | ClosedFamEqnCtxt !TyCon + -- | In the expansion of a type synonym. + | TySynErrCtxt !TyCon + -- | In a role annotation. + | RoleAnnotErrCtxt !Name + -- | In an arrow command. + | CmdCtxt !(HsCmd GhcRn) + -- | In an instance declaration. + | InstDeclErrCtxt !(Either (LHsType GhcRn) PredType) + -- | In a default declaration. + | DefaultDeclErrCtxt { ddec_in_type_list :: !Bool } + -- | In the body of a static form. + | StaticFormCtxt !(LHsExpr GhcRn) + -- | In a pattern binding. + | forall p. OutputableBndrId p + => PatMonoBindsCtxt !(LPat (GhcPass p)) !(GRHSs GhcRn (LHsExpr GhcRn)) + -- | In a foreign import/export declaration. + | ForeignDeclCtxt !(ForeignDecl GhcRn) + -- | In a record field. + | FieldCtxt !FieldLabelString + -- | In a type. + | TypeCtxt !(LHsType GhcRn) + -- | In a kind. + | KindCtxt !(LHsKind GhcRn) + -- | In an ambiguity check. + | AmbiguityCheckCtxt !UserTypeCtxt !Bool + + -- | In a term-level use of a 'Name'. + | TermLevelUseCtxt !Name !TermLevelUseCtxt + + -- | When checking the type of the @main@ function. + | MainCtxt !Name + -- | Warning emitted when inferring use of visible dependent quantification. + | VDQWarningCtxt !TcTyCon + + -- | In a statement. + | forall body. + ( Anno (StmtLR GhcRn GhcRn body) ~ SrcSpanAnnA + , Outputable body + ) => StmtErrCtxt !HsStmtContextRn !(StmtLR GhcRn GhcRn body) + + -- | In an rebindable syntax expression. + | SyntaxNameCtxt !(HsExpr GhcRn) !CtOrigin !TcType !SrcSpan + -- | In a RULE. + | RuleCtxt !FastString + -- | In a subtype check. + | SubTypeCtxt !TcType !TcType + + -- | In an export. + | forall p. OutputableBndrId p + => ExportCtxt (IE (GhcPass p)) + -- | In an export of a pattern synonym. + | PatSynExportCtxt !PatSyn + -- | In an export of a pattern synonym record field. + | PatSynRecSelExportCtxt !PatSyn !Name + + -- | In an annotation. + | forall p. OutputableBndrId p + => AnnCtxt (AnnDecl (GhcPass p)) + + -- | In a specialise pragma. + | SpecPragmaCtxt !(Sig GhcRn) + + -- | In a deriving clause. + | DerivInstCtxt !PredType + -- | In a standalone deriving clause. + | StandaloneDerivCtxt !(LHsSigWcType GhcRn) + -- | When typechecking the body of a derived instance. + | DerivBindCtxt !Id !Class ![Type] + + -- | In an untyped Template Haskell quote. + | UntypedTHBracketCtxt !(HsQuote GhcPs) + -- | In a typed Template Haskell quote. + | forall p. OutputableBndrId p + => TypedTHBracketCtxt !(LHsExpr (GhcPass p)) + -- | In an untyped Template Haskell splice or quasi-quote. + | UntypedSpliceCtxt !(HsUntypedSplice GhcPs) + -- | In a typed Template Haskell splice. + | forall p. OutputableBndrId p + => TypedSpliceCtxt !(Maybe SplicePointName) !(HsTypedSplice (GhcPass p)) + -- | In the result of a typed Template Haskell splice. + | TypedSpliceResultCtxt !(LHsExpr GhcTc) + -- | In an argument to the Template Haskell @reifyInstances@ function. + | ReifyInstancesCtxt !TH.Name ![TH.Type] + + -- | While merging Backpack signatures. + | MergeSignaturesCtxt !UnitState !ModuleName ![InstantiatedModule] + -- | While checking that a module implements a Backpack signature. + | CheckImplementsCtxt !UnitState !Module !InstantiatedModule diff --git a/GHC/Tc/Types/Evidence.hs b/GHC/Tc/Types/Evidence.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/Evidence.hs @@ -0,0 +1,1096 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Tc.Types.Evidence ( + + -- * HsWrapper + HsWrapper(..), + (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpForAllCast, + mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta, + collectHsWrapBinders, + idHsWrapper, isIdHsWrapper, + pprHsWrapper, hsWrapDictBinders, + + -- * Evidence bindings + TcEvBinds(..), EvBindsVar(..), + EvBindMap(..), emptyEvBindMap, extendEvBinds, unionEvBindMap, + lookupEvBind, evBindMapBinds, + foldEvBindMap, nonDetStrictFoldEvBindMap, + filterEvBindMap, + isEmptyEvBindMap, + evBindMapToVarSet, + varSetMinusEvBindMap, + EvBindInfo(..), EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, + evBindVar, isCoEvBindsVar, + + -- * EvTerm (already a CoreExpr) + EvTerm(..), EvExpr, + evId, evCoercion, evCast, evCastE, evDFunApp, evDictApp, evSelector, evDelayedError, + mkEvScSelectors, evTypeable, + evWrapIPE, evUnwrapIPE, evUnaryDictAppE, + mkEvCast, + nestedEvIdsOfTerm, evTermFVs, + + evTermCoercion, evTermCoercion_maybe, + evExprCoercion, evExprCoercion_maybe, + EvCallStack(..), + EvTypeable(..), + + -- * HoleExprRef + HoleExprRef(..), + + -- * TcCoercion + TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, + TcMCoercion, TcMCoercionN, TcMCoercionR, + Role(..), LeftOrRight(..), pickLR, + maybeSymCo, + + -- * QuoteWrapper + QuoteWrapper(..), applyQuoteWrapper, quoteWrapperTyVarTy + ) where + +import GHC.Prelude + +import GHC.Tc.Utils.TcType + +import GHC.Core +import GHC.Core.Coercion.Axiom +import GHC.Core.Coercion +import GHC.Core.Ppr () -- Instance OutputableBndr TyVar +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Make ( mkWildCase, mkRuntimeErrorApp, tYPE_ERROR_ID ) +import GHC.Core.Class ( classTyCon ) +import GHC.Core.DataCon ( dataConWrapId ) +import GHC.Core.Class (Class, classSCSelId ) +import GHC.Core.FVs +import GHC.Core.InstEnv ( CanonicalEvidence(..) ) + +import GHC.Types.Unique.DFM +import GHC.Types.Unique.FM +import GHC.Types.Name( isInternalName ) +import GHC.Types.Var +import GHC.Types.Id( idScaledType ) +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic + +import GHC.Builtin.Names +import GHC.Builtin.Types( unitTy ) + +import GHC.Utils.FV +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable + +import GHC.Data.Bag +import GHC.Data.FastString + +import qualified Data.Data as Data +import GHC.Types.SrcLoc +import Data.IORef( IORef ) +import GHC.Types.Unique.Set +import GHC.Core.Multiplicity + +import qualified Data.Semigroup as S + +{- +Note [TcCoercions] +~~~~~~~~~~~~~~~~~~ +| TcCoercions are a hack used by the typechecker. Normally, +Coercions have free variables of type (a ~# b): we call these +CoVars. However, the type checker passes around equality evidence +(boxed up) at type (a ~ b). + +An TcCoercion is simply a Coercion whose free variables have may be either +boxed or unboxed. After we are done with typechecking the desugarer finds the +boxed free variables, unboxes them, and creates a resulting real Coercion with +kosher free variables. + +-} + +type TcCoercion = Coercion +type TcCoercionN = CoercionN -- A Nominal coercion ~N +type TcCoercionR = CoercionR -- A Representational coercion ~R +type TcCoercionP = CoercionP -- a phantom coercion +type TcMCoercion = MCoercion +type TcMCoercionN = MCoercionN -- nominal +type TcMCoercionR = MCoercionR -- representational + + +-- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion +maybeSymCo :: SwapFlag -> TcCoercion -> TcCoercion +maybeSymCo IsSwapped co = mkSymCo co +maybeSymCo NotSwapped co = co + +{- +%************************************************************************ +%* * + HsWrapper +* * +************************************************************************ +-} + +-- We write wrap :: t1 ~> t2 +-- if wrap[ e::t1 ] :: t2 +data HsWrapper + = WpHole -- The identity coercion + + | WpCompose HsWrapper HsWrapper + -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] + -- + -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) + -- But ([] a) `WpCompose` ([] b) = ([] b a) + -- + -- If wrap1 :: t2 ~> t3 + -- wrap2 :: t1 ~> t2 + --- Then (wrap1 `WpCompose` wrap2) :: t1 ~> t3 + + | WpFun HsWrapper HsWrapper (Scaled TcTypeFRR) + -- (WpFun wrap1 wrap2 (w, t1))[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ] + -- So note that if e :: act_arg -> act_res + -- wrap1 :: exp_arg ~> act_arg + -- wrap2 :: act_res ~> exp_res + -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) ~> (exp_arg -> exp_res) + -- This isn't the same as for mkFunCo, but it has to be this way + -- because we can't use 'sym' to flip around these HsWrappers + -- The TcType is the "from" type of the first wrapper; + -- it always a Type, not a Constraint + -- + -- NB: a WpFun is always for a (->) function arrow + -- + -- Use 'mkWpFun' to construct such a wrapper. + + | WpCast TcCoercionR -- A cast: [] `cast` co + -- Guaranteed not the identity coercion + -- At role Representational + + -- Evidence abstraction and application + -- (both dictionaries and coercions) + -- Both WpEvLam and WpEvApp abstract and apply values + -- of kind CONSTRAINT rep + | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable + | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint + + -- Kind and Type abstraction and application + | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) + | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) + + + | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, + -- so that the identity coercion is always exactly WpHole + deriving Data.Data + +-- | The Semigroup instance is a bit fishy, since @WpCompose@, as a data +-- constructor, is "syntactic" and not associative. Concretely, if @a@, @b@, +-- and @c@ aren't @WpHole@: +-- +-- > (a <> b) <> c ?= a <> (b <> c) +-- +-- ==> +-- +-- > (a `WpCompose` b) `WpCompose` c /= @ a `WpCompose` (b `WpCompose` c) +-- +-- However these two associations are are "semantically equal" in the sense +-- that they produce equal functions when passed to +-- @GHC.HsToCore.Binds.dsHsWrapper@. +instance S.Semigroup HsWrapper where + (<>) = (<.>) + +instance Monoid HsWrapper where + mempty = WpHole + +(<.>) :: HsWrapper -> HsWrapper -> HsWrapper +WpHole <.> c = c +c <.> WpHole = c +WpCast c1 <.> WpCast c2 = WpCast (c1 `mkTransCo` c2) + -- If we can represent the HsWrapper as a cast, try to do so: this may avoid + -- unnecessary eta-expansion (see 'mkWpFun'). +c1 <.> c2 = c1 `WpCompose` c2 + +-- | Smart constructor to create a 'WpFun' 'HsWrapper', which avoids introducing +-- a lambda abstraction if the two supplied wrappers are either identities or +-- casts. +-- +-- PRECONDITION: either: +-- +-- 1. both of the 'HsWrapper's are identities or casts, or +-- 2. both the "from" and "to" types of the first wrapper have a syntactically +-- fixed RuntimeRep (see Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). +mkWpFun :: HsWrapper -> HsWrapper + -> Scaled TcTypeFRR -- ^ the "from" type of the first wrapper + -> TcType -- ^ Either "from" type or "to" type of the second wrapper + -- (used only when the second wrapper is the identity) + -> HsWrapper +mkWpFun WpHole WpHole _ _ = WpHole +mkWpFun WpHole (WpCast co2) (Scaled w t1) _ = WpCast (mk_wp_fun_co w (mkRepReflCo t1) co2) +mkWpFun (WpCast co1) WpHole (Scaled w _) t2 = WpCast (mk_wp_fun_co w (mkSymCo co1) (mkRepReflCo t2)) +mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ = WpCast (mk_wp_fun_co w (mkSymCo co1) co2) +mkWpFun w_arg w_res t1 _ = + -- In this case, we will desugar to a lambda + -- + -- \x. w_res[ e w_arg[x] ] + -- + -- To satisfy Note [Representation polymorphism invariants] in GHC.Core, + -- it must be the case that both the lambda bound variable x and the function + -- argument w_arg[x] have a fixed runtime representation, i.e. that both the + -- "from" and "to" types of the first wrapper "w_arg" have a fixed runtime representation. + -- + -- Unfortunately, we can't check this with an assertion here, because of + -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + WpFun w_arg w_res t1 + +mkWpEta :: [Id] -> HsWrapper -> HsWrapper +-- (mkWpEta [x1, x2] wrap) [e] +-- = \x1. \x2. wrap[e x1 x2] +-- Just generates a bunch of WpFuns +mkWpEta xs wrap = foldr eta_one wrap xs + where + eta_one x wrap = WpFun idHsWrapper wrap (idScaledType x) + +mk_wp_fun_co :: Mult -> TcCoercionR -> TcCoercionR -> TcCoercionR +mk_wp_fun_co mult arg_co res_co + = mkNakedFunCo Representational FTF_T_T (multToCo mult) arg_co res_co + -- FTF_T_T: WpFun is always (->) + +mkWpCastR :: TcCoercionR -> HsWrapper +mkWpCastR co + | isReflCo co = WpHole + | otherwise = assertPpr (coercionRole co == Representational) (ppr co) $ + WpCast co + +mkWpCastN :: TcCoercionN -> HsWrapper +mkWpCastN co + | isReflCo co = WpHole + | otherwise = assertPpr (coercionRole co == Nominal) (ppr co) $ + WpCast (mkSubCo co) + -- The mkTcSubCo converts Nominal to Representational + +mkWpTyApps :: [Type] -> HsWrapper +mkWpTyApps tys = mk_co_app_fn WpTyApp tys + +mkWpEvApps :: [EvTerm] -> HsWrapper +mkWpEvApps args = mk_co_app_fn WpEvApp args + +mkWpEvVarApps :: [EvVar] -> HsWrapper +mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs) + +mkWpTyLams :: [TyVar] -> HsWrapper +mkWpTyLams ids = mk_co_lam_fn WpTyLam ids + +-- mkWpForAllCast [tv{vis}] constructs a cast +-- forall tv. res ~R# forall tv{vis} res`. +-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep +-- +-- It's a no-op if all binders are invisible; +-- but in that case we refrain from calling it. +mkWpForAllCast :: [ForAllTyBinder] -> Type -> HsWrapper +mkWpForAllCast bndrs res_ty + = mkWpCastR (mkForAllVisCos bndrs (mkRepReflCo res_ty)) + +mkWpEvLams :: [Var] -> HsWrapper +mkWpEvLams ids = mk_co_lam_fn WpEvLam ids + +mkWpLet :: TcEvBinds -> HsWrapper +-- This no-op is a quite a common case +mkWpLet (EvBinds b) | isEmptyBag b = WpHole +mkWpLet ev_binds = WpLet ev_binds + +mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as + +mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +-- For applications, the *first* argument must +-- come *last* in the composition sequence +mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as + +idHsWrapper :: HsWrapper +idHsWrapper = WpHole + +isIdHsWrapper :: HsWrapper -> Bool +isIdHsWrapper WpHole = True +isIdHsWrapper _ = False + +hsWrapDictBinders :: HsWrapper -> Bag DictId +-- ^ Identifies the /lambda-bound/ dictionaries of an 'HsWrapper'. This is used +-- (only) to allow the pattern-match overlap checker to know what Given +-- dictionaries are in scope. +-- +-- We specifically do not collect dictionaries bound in a 'WpLet'. These are +-- either superclasses of lambda-bound ones, or (extremely numerous) results of +-- binding Wanted dictionaries. We definitely don't want all those cluttering +-- up the Given dictionaries for pattern-match overlap checking! +hsWrapDictBinders wrap = go wrap + where + go (WpEvLam dict_id) = unitBag dict_id + go (w1 `WpCompose` w2) = go w1 `unionBags` go w2 + go (WpFun _ w _) = go w + go WpHole = emptyBag + go (WpCast {}) = emptyBag + go (WpEvApp {}) = emptyBag + go (WpTyLam {}) = emptyBag + go (WpTyApp {}) = emptyBag + go (WpLet {}) = emptyBag + +collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper) +-- Collect the outer lambda binders of a HsWrapper, +-- stopping as soon as you get to a non-lambda binder +collectHsWrapBinders wrap = go wrap [] + where + -- go w ws = collectHsWrapBinders (w <.> w1 <.> ... <.> wn) + go :: HsWrapper -> [HsWrapper] -> ([Var], HsWrapper) + go (WpEvLam v) wraps = add_lam v (gos wraps) + go (WpTyLam v) wraps = add_lam v (gos wraps) + go (WpCompose w1 w2) wraps = go w1 (w2:wraps) + go wrap wraps = ([], foldl' (<.>) wrap wraps) + + gos [] = ([], WpHole) + gos (w:ws) = go w ws + + add_lam v (vs,w) = (v:vs, w) + +{- +************************************************************************ +* * + Evidence bindings +* * +************************************************************************ +-} + +data TcEvBinds + = TcEvBinds -- Mutable evidence bindings + EvBindsVar -- Mutable because they are updated "later" + -- when an implication constraint is solved + + | EvBinds -- Immutable after zonking + (Bag EvBind) + +data EvBindsVar + = EvBindsVar { + ebv_uniq :: Unique, + -- The Unique is for debug printing only + + ebv_binds :: IORef EvBindMap, + -- The main payload: the value-level evidence bindings + -- (dictionaries etc) + -- Some Given, some Wanted + + ebv_tcvs :: IORef [TcCoercion] + -- When we solve a Wanted by filling in a CoercionHole, it is as + -- if we were adding an evidence binding + -- co_hole := coercion + -- We keep all these RHS coercions in a list, alongside `ebv_binds`, + -- so that we can report unused given constraints, + -- in GHC.Tc.Solver.neededEvVars + -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + } + + | CoEvBindsVar { -- See Note [Coercion evidence only] + + -- See above for comments on ebv_uniq, ebv_tcvs + ebv_uniq :: Unique, + ebv_tcvs :: IORef [TcCoercion] + } + +instance Data.Data TcEvBinds where + -- Placeholder; we can't traverse into TcEvBinds + toConstr _ = abstractConstr "TcEvBinds" + gunfold _ _ = error "gunfold" + dataTypeOf _ = Data.mkNoRepType "TcEvBinds" +instance Data.Data EvBind where + -- Placeholder; we can't traverse into EvBind + toConstr _ = abstractConstr "TcEvBind" + gunfold _ _ = error "gunfold" + dataTypeOf _ = Data.mkNoRepType "EvBind" + +{- Note [Coercion evidence only] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Class constraints etc give rise to /term/ bindings for evidence, and +we have nowhere to put term bindings in /types/. So in some places we +use CoEvBindsVar (see newCoTcEvBinds) to signal that no term-level +evidence bindings are allowed. Notably (): + + - Places in types where we are solving kind constraints (all of which + are equalities); see solveEqualities + + - When unifying forall-types +-} + +isCoEvBindsVar :: EvBindsVar -> Bool +isCoEvBindsVar (CoEvBindsVar {}) = True +isCoEvBindsVar (EvBindsVar {}) = False + +----------------- +newtype EvBindMap + = EvBindMap { + ev_bind_varenv :: DVarEnv EvBind + } -- Map from evidence variables to evidence terms + -- We use @DVarEnv@ here to get deterministic ordering when we + -- turn it into a Bag. + -- If we don't do that, when we generate let bindings for + -- dictionaries in dsTcEvBinds they will be generated in random + -- order. + -- + -- For example: + -- + -- let $dEq = GHC.Classes.$fEqInt in + -- let $$dNum = GHC.Num.$fNumInt in ... + -- + -- vs + -- + -- let $dNum = GHC.Num.$fNumInt in + -- let $dEq = GHC.Classes.$fEqInt in ... + -- + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why + -- @UniqFM@ can lead to nondeterministic order. + +emptyEvBindMap :: EvBindMap +emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyDVarEnv } + +extendEvBinds :: EvBindMap -> EvBind -> EvBindMap +extendEvBinds bs ev_bind + = EvBindMap { ev_bind_varenv = extendDVarEnv (ev_bind_varenv bs) + (eb_lhs ev_bind) + ev_bind } + +-- | Union two evidence binding maps +unionEvBindMap :: EvBindMap -> EvBindMap -> EvBindMap +unionEvBindMap (EvBindMap env1) (EvBindMap env2) = + EvBindMap { ev_bind_varenv = plusDVarEnv env1 env2 } + +isEmptyEvBindMap :: EvBindMap -> Bool +isEmptyEvBindMap (EvBindMap m) = isEmptyDVarEnv m + +lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind +lookupEvBind bs = lookupDVarEnv (ev_bind_varenv bs) + +evBindMapBinds :: EvBindMap -> Bag EvBind +evBindMapBinds = foldEvBindMap consBag emptyBag + +foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a +foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs) + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a +nonDetStrictFoldEvBindMap k z bs = nonDetStrictFoldDVarEnv k z (ev_bind_varenv bs) + +filterEvBindMap :: (EvBind -> Bool) -> EvBindMap -> EvBindMap +filterEvBindMap k (EvBindMap { ev_bind_varenv = env }) + = EvBindMap { ev_bind_varenv = filterDVarEnv k env } + +evBindMapToVarSet :: EvBindMap -> VarSet +evBindMapToVarSet (EvBindMap dve) = unsafeUFMToUniqSet (mapUFM evBindVar (udfmToUfm dve)) + +varSetMinusEvBindMap :: VarSet -> EvBindMap -> VarSet +varSetMinusEvBindMap vs (EvBindMap dve) = vs `uniqSetMinusUDFM` dve + +instance Outputable EvBindMap where + ppr (EvBindMap m) = ppr m + +data EvBindInfo + = EvBindGiven { -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + } + | EvBindWanted { ebi_canonical :: CanonicalEvidence -- See Note [Desugaring non-canonical evidence] + } + +----------------- +-- All evidence is bound by EvBinds; no side effects +data EvBind + = EvBind { eb_lhs :: EvVar + , eb_rhs :: EvTerm + , eb_info :: EvBindInfo + } + +evBindVar :: EvBind -> EvVar +evBindVar = eb_lhs + +mkWantedEvBind :: EvVar -> CanonicalEvidence -> EvTerm -> EvBind +mkWantedEvBind ev c tm = EvBind { eb_info = EvBindWanted c, eb_lhs = ev, eb_rhs = tm } + +-- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm +mkGivenEvBind :: EvVar -> EvTerm -> EvBind +mkGivenEvBind ev tm = EvBind { eb_info = EvBindGiven, eb_lhs = ev, eb_rhs = tm } + + +-- An EvTerm is, conceptually, a CoreExpr that implements the constraint. +-- Unfortunately, we cannot just do +-- type EvTerm = CoreExpr +-- Because of staging problems issues around EvTypeable +data EvTerm + = EvExpr EvExpr + + | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty) + + | EvFun -- /\as \ds. let binds in v + { et_tvs :: [TyVar] + , et_given :: [EvVar] + , et_binds :: TcEvBinds -- This field is why we need an EvFun + -- constructor, and can't just use EvExpr + , et_body :: EvVar } + + deriving Data.Data + +type EvExpr = CoreExpr + +-- | Any sort of evidence Id, including coercions +evId :: EvId -> EvExpr +evId = Var + +-- coercion bindings +-- See Note [Coercion evidence terms] +evCoercion :: TcCoercion -> EvTerm +evCoercion co = EvExpr (Coercion co) + +{-# DEPRECATED mkEvCast "Please use evCast instead" #-} +-- We had gotten duplicate functions; let's get rid of mkEvCast in due course +mkEvCast :: EvExpr -> TcCoercion -> EvTerm +mkEvCast = evCast + +evCast :: EvExpr -> TcCoercion -> EvTerm +evCast et tc = EvExpr (evCastE et tc) + +-- | d |> co +evCastE :: EvExpr -> TcCoercion -> EvExpr +evCastE ee co + | assertPpr (coercionRole co == Representational) + (vcat [text "Coercion of wrong role passed to evCastE:", ppr ee, ppr co]) $ + isReflCo co = ee + | otherwise = Cast ee co + +evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm +-- Dictionary instance application, including when the "dictionary function" +-- is actually the data construtor for a dictionary +evDFunApp df tys ets = EvExpr (evDFunAppE df tys ets) + +evDFunAppE :: DFunId -> [Type] -> [EvExpr] -> EvExpr +evDFunAppE df tys ets = Var df `mkTyApps` tys `mkApps` ets + +evDictApp :: Class -> [Type] -> [EvExpr] -> EvTerm +evDictApp cls tys args = EvExpr (evDictAppE cls tys args) + +evDictAppE :: Class -> [Type] -> [EvExpr] -> EvExpr +evDictAppE cls tys args + = case tyConSingleDataCon_maybe (classTyCon cls) of + Just dc -> evDFunAppE (dataConWrapId dc) tys args + Nothing -> pprPanic "evDictApp" (ppr cls) + +evUnaryDictAppE :: Class -> [Type] -> EvExpr -> EvExpr +-- See (UCM6) in Note [Unary class magic] in GHC.Core.TyCon +evUnaryDictAppE cls tys meth + = evDictAppE cls tys [meth] + +evWrapIPE :: PredType -> EvExpr -> EvExpr +-- Given pred = IP s ty + -- et_tm :: ty +-- Return an EvTerm of type (IP s ty) +evWrapIPE pred ev_tm + = evUnaryDictAppE cls tys ev_tm + where + (cls, tys) = getClassPredTys pred + +evUnwrapIPE :: PredType -> EvExpr -> EvExpr +-- Given pred = IP s ty + -- et_tm :: (IP s ty) +-- Return an EvTerm of type ty +evUnwrapIPE pred ev_tm + = mkApps (Var ip_sel) (map Type tys ++ [ev_tm]) + where + (ip_sel, tys) = decomposeIPPred pred + + +-- Selector id plus the types at which it +-- should be instantiated, used for HasField +-- dictionaries; see Note [HasField instances] +-- in TcInterface +evSelector :: Id -> [Type] -> [EvExpr] -> EvExpr +evSelector sel_id tys tms = Var sel_id `mkTyApps` tys `mkApps` tms + +-- Dictionary for (Typeable ty) +evTypeable :: Type -> EvTypeable -> EvTerm +evTypeable = EvTypeable + +-- | Instructions on how to make a 'Typeable' dictionary. +-- See Note [Typeable evidence terms] +data EvTypeable + = EvTypeableTyCon TyCon [EvTerm] + -- ^ Dictionary for @Typeable T@ where @T@ is a type constructor with all of + -- its kind variables saturated. The @[EvTerm]@ is @Typeable@ evidence for + -- the applied kinds.. + + | EvTypeableTyApp EvTerm EvTerm + -- ^ Dictionary for @Typeable (s t)@, + -- given a dictionaries for @s@ and @t@. + + | EvTypeableTrFun EvTerm EvTerm EvTerm + -- ^ Dictionary for @Typeable (s % w -> t)@, + -- given a dictionaries for @w@, @s@, and @t@. + + | EvTypeableTyLit EvTerm + -- ^ Dictionary for a type literal, + -- e.g. @Typeable "foo"@ or @Typeable 3@ + -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@ + -- (see #10348) + deriving Data.Data + +-- | Evidence for @CallStack@ implicit parameters. +data EvCallStack + -- See Note [Overview of implicit CallStacks] + = EvCsEmpty + | EvCsPushCall + FastString -- Usually the name of the function being called + -- but can also be "the literal 42" + -- or "an if-then-else expression", etc + RealSrcSpan -- Location of the call + EvExpr -- Rest of the stack + -- ^ @EvCsPushCall origin loc stk@ represents a call from @origin@, + -- occurring at @loc@, in a calling context @stk@. + deriving Data.Data + +{- +************************************************************************ +* * + Evidence for holes +* * +************************************************************************ +-} + +-- | Where to store evidence for expression holes +-- See Note [Holes in expressions] in GHC.Hs.Expr. +data HoleExprRef = HER (IORef EvTerm) -- ^ where to write the erroring expression + TcType -- ^ expected type of that expression + Unique -- ^ for debug output only + +instance Outputable HoleExprRef where + ppr (HER _ _ u) = ppr u + +instance Data.Data HoleExprRef where + -- Placeholder; we can't traverse into HoleExprRef + toConstr _ = abstractConstr "HoleExprRef" + gunfold _ _ = error "gunfold" + dataTypeOf _ = Data.mkNoRepType "HoleExprRef" + +{- +Note [Typeable evidence terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The EvTypeable data type looks isomorphic to Type, but the EvTerms +inside can be EvIds. Eg + f :: forall a. Typeable a => a -> TypeRep + f x = typeRep (undefined :: Proxy [a]) +Here for the (Typeable [a]) dictionary passed to typeRep we make +evidence + dl :: Typeable [a] = EvTypeable [a] + (EvTypeableTyApp (EvTypeableTyCon []) (EvId d)) +where + d :: Typeable a +is the lambda-bound dictionary passed into f. + +Note [Coercion evidence terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "coercion evidence term" takes one of these forms + co_tm ::= EvId v where v :: t1 ~# t2 + | EvCoercion co + | EvCast co_tm co + +We do quite often need to get a TcCoercion from an EvTerm; see +'evTermCoercion'. + +INVARIANT: The evidence for any constraint with type (t1 ~# t2) is +a coercion evidence term. Consider for example + [G] d :: F Int a +If we have + ax7 a :: F Int a ~ (a ~ Bool) +then we do NOT generate the constraint + [G] (d |> ax7 a) :: a ~ Bool +because that does not satisfy the invariant (d is not a coercion variable). +Instead we make a binding + g1 :: a~Bool = g |> ax7 a +and the constraint + [G] g1 :: a~Bool +See #7238 and Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint + +Note [EvBinds/EvTerm] +~~~~~~~~~~~~~~~~~~~~~ +How evidence is created and updated. Bindings for dictionaries, +and coercions and implicit parameters are carried around in TcEvBinds +which during constraint generation and simplification is always of the +form (TcEvBinds ref). After constraint simplification is finished it +will be transformed to t an (EvBinds ev_bag). + +Evidence for coercions *SHOULD* be filled in using the TcEvBinds +However, all EvVars that correspond to *wanted* coercion terms in +an EvBind must be mutable variables so that they can be readily +inlined (by zonking) after constraint simplification is finished. + +Conclusion: a new wanted coercion variable should be made mutable. +[Notice though that evidence variables that bind coercion terms + from super classes will be "given" and hence rigid] + +Note [Overview of implicit CallStacks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(See https://gitlab.haskell.org/ghc/ghc/wikis/explicit-call-stack/implicit-locations) + +The goal of CallStack evidence terms is to reify locations +in the program source as runtime values, without any support +from the RTS. We accomplish this by assigning a special meaning +to constraints of type GHC.Stack.Types.HasCallStack, an alias + + type HasCallStack = (?callStack :: CallStack) + +Implicit parameters of type GHC.Stack.Types.CallStack (the /name/ of the +implicit parameter is not important, see (CS5) below) are solved as follows: + +1. Plan NORMAL. Explicit, user-written occurrences of `?stk :: CallStack`, which + have IPOccOrigin, are solved directly from the given IP, just like any other + implicit-parameter constraint; see GHC.Tc.Solver.Dict.tryInertDicts. We can + solve it from a Given or from another Wanted, if the two have the same type. + + For example, the occurrence of `?stk` in + + error :: (?stk :: CallStack) => String -> a + error s = raise (ErrorCall (s ++ prettyCallStack ?stk)) + + will be solved for the `?stk` in `error`s context as before. + +2. Plan PUSH. A /function call/ with a CallStack constraint, such as + a call to `foo` where + foo :: (?stk :: CallStack) => a + will give rise to a Wanted constraint + [W] d :: (?stk :: CallStack) CtOrigin = OccurrenceOf "foo" + + We do /not/ solve this constraint from Givens, or from other + Wanteds. Rather, have a built-in mechanism in that solves it thus: + d := EvCsPushCall "foo"
d2 + [W] d2 :: (?stk :: CallStack) CtOrigin = IPOccOrigin + + That is, `d` is a call-stack that has the `foo` call-site pushed on top of + `d2`, which can now be solved normally (as in (1) above). This is done as follows: + - In GHC.Tc.Solver.Dict.canDictCt we do the pushing. + - We only look up canonical constraints in the inert set + +3. For a CallStack constraint, we choose how to solve it based on its CtOrigin: + + * solve it normally (plan NORMAL above) + - IPOccOrigin (discussed above) + - GivenOrigin (see (CS1) below) + + * push an item on the stack and emit a new constraint (plan PUSH above) + - OccurrenceOf "foo" (discused above) + - anything else (see (CS1) below) + + This choice is by the predicate isPushCallStackOrigin_maybe + +4. We default any insoluble CallStacks to the empty CallStack. Suppose + `undefined` did not request a CallStack, ie + + undefinedNoStk :: a + undefinedNoStk = error "undefined!" + + Under the usual IP rules, the new wanted from rule (2) would be + insoluble as there's no given IP from which to solve it, so we + would get an "unbound implicit parameter" error. + + We don't ever want to emit an insoluble CallStack IP, so we add a + defaulting pass to default any remaining wanted CallStacks to the + empty CallStack with the evidence term + + EvCsEmpty + + (see GHC.Tc.Solver.simplifyTopWanteds and GHC.Tc.Solver.defaultCallStacks) + +This provides a lightweight mechanism for building up call-stacks +explicitly, but is notably limited by the fact that the stack will +stop at the first function whose type does not include a CallStack IP. +For example, using the above definition of `undefined`: + + head :: [a] -> a + head [] = undefined + head (x:_) = x + + g = head [] + +the resulting CallStack will include the call to `undefined` in `head` +and the call to `error` in `undefined`, but *not* the call to `head` +in `g`, because `head` did not explicitly request a CallStack. + + +Wrinkles + +(CS1) Which CtOrigins should qualify for plan PUSH? Certainly ones that arise + from a function call like (f a b). + + But (see #19918) when RebindableSyntax is involved we can function call whose + CtOrigin is somethign like `IfThenElseOrigin`. See the defn of fun_orig in + GHC.Tc.Gen.App.tcInstFun; it is this CtOrigin that is pinned on the + constraints generated by functions in the "expansion" for rebindable + syntax. c.f. GHC.Rename.Expr Note [Handling overloaded and rebindable + constructs]. + + So isPushCallStackOrigin_maybe has a fall-through for "anything else", and + assumes that we should adopt plan PUSH for it. + + However we should /not/ take this fall-through for Given constraints + (#25675). So isPushCallStackOrigin_maybe identifies Givens as plan NORMAL. + +(CS2) GHC should NEVER report an insoluble CallStack constraint. + +(CS3) GHC should NEVER infer a CallStack constraint unless one was requested + with a partial type signature (See GHC.Tc.Solver..pickQuantifiablePreds). + +(CS4) A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)], + where the String is the name of the binder that is used at the + SrcLoc. SrcLoc is also defined in GHC.Stack.Types and contains the + package/module/file name, as well as the full source-span. Both + CallStack and SrcLoc are kept abstract so only GHC can construct new + values. + +(CS5) We will automatically solve any wanted CallStack regardless of the + /name/ of the IP, i.e. + + f = show (?stk :: CallStack) + g = show (?loc :: CallStack) + + are both valid. However, we will only push new SrcLocs onto existing + CallStacks when the IP names match, e.g. in + + head :: (?loc :: CallStack) => [a] -> a + head [] = error (show (?stk :: CallStack)) + + the printed CallStack will NOT include head's call-site. This reflects the + standard scoping rules of implicit-parameters. + +(CS6) An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. + The desugarer will need to unwrap the IP newtype before pushing a new + call-site onto a given stack (See GHC.HsToCore.Binds.dsEvCallStack) + +(CS7) When we emit a new wanted CallStack in plan PUSH we set its origin to + `IPOccOrigin ip_name` instead of the original `OccurrenceOf func` + (see GHC.Tc.Solver.Dict.tryInertDicts). + + This is a bit shady, but is how we ensure that the new wanted is + solved like a regular IP. +-} + +mkEvScSelectors -- Assume class (..., D ty, ...) => C a b + :: Class -> [TcType] -- C ty1 ty2 + -> [(TcPredType, -- D ty[ty1/a,ty2/b] + EvExpr) -- :: C ty1 ty2 -> D ty[ty1/a,ty2/b] + ] +mkEvScSelectors cls tys + = zipWith mk_pr (immSuperClasses cls tys) [0..] + where + mk_pr pred i = (pred, Var sc_sel_id `mkTyApps` tys) + where + sc_sel_id = classSCSelId cls i -- Zero-indexed + +emptyTcEvBinds :: TcEvBinds +emptyTcEvBinds = EvBinds emptyBag + +isEmptyTcEvBinds :: TcEvBinds -> Bool +isEmptyTcEvBinds (EvBinds b) = isEmptyBag b +isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" + +evExprCoercion_maybe :: EvExpr -> Maybe TcCoercion +-- Applied only to EvExprs of type (s~t) +-- See Note [Coercion evidence terms] +evExprCoercion_maybe (Var v) = return (mkCoVarCo v) +evExprCoercion_maybe (Coercion co) = return co +evExprCoercion_maybe (Cast tm co) = do { co' <- evExprCoercion_maybe tm + ; return (mkCoCast co' co) } +evExprCoercion_maybe _ = Nothing + +evExprCoercion :: EvExpr -> TcCoercion +evExprCoercion tm = case evExprCoercion_maybe tm of + Just co -> co + Nothing -> pprPanic "evExprCoercion" (ppr tm) + +evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion +-- Applied only to EvTerms of type (s~t) +-- See Note [Coercion evidence terms] +evTermCoercion_maybe ev_term + | EvExpr e <- ev_term = evExprCoercion_maybe e + | otherwise = Nothing + +evTermCoercion :: EvTerm -> TcCoercion +evTermCoercion tm = case evTermCoercion_maybe tm of + Just co -> co + Nothing -> pprPanic "evTermCoercion" (ppr tm) + +-- Used with Opt_DeferTypeErrors +-- See Note [Deferring coercion errors to runtime] +-- in GHC.Tc.Solver +evDelayedError :: Type -> String -> EvTerm +evDelayedError ty msg + = EvExpr $ + let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg + in mkWildCase fail_expr (unrestricted unitTy) ty [] + -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils + -- c.f. mkErrorAppDs in GHC.HsToCore.Utils + +{- ********************************************************************* +* * + Free variables +* * +********************************************************************* -} + +isNestedEvId :: Var -> Bool +-- Just returns /nested/ free evidence variables; i.e ones with Internal Names +-- Top-level ones (DFuns, dictionary selectors and the like) don't count +-- Evidence variables are always Ids; do not pick TyVars +isNestedEvId v = isId v && isInternalName (varName v) + +nestedEvIdsOfTerm :: EvTerm -> VarSet +-- Returns only EvIds satisfying relevantEvId +nestedEvIdsOfTerm tm = fvVarSet (filterFV isNestedEvId (evTermFVs tm)) + +evTermFVs :: EvTerm -> FV +evTermFVs (EvExpr e) = exprFVs e +evTermFVs (EvTypeable _ ev) = evFVsOfTypeable ev +evTermFVs (EvFun { et_tvs = tvs, et_given = given + , et_binds = tc_ev_binds, et_body = v }) + = case tc_ev_binds of + TcEvBinds {} -> emptyFV -- See Note [Free vars of EvFun] + EvBinds binds -> addBndrsFV bndrs fvs + where + fvs = foldr (unionFV . evTermFVs . eb_rhs) (unitFV v) binds + bndrs = foldr ((:) . eb_lhs) (tvs ++ given) binds + +evTermFVss :: [EvTerm] -> FV +evTermFVss = mapUnionFV evTermFVs + +evFVsOfTypeable :: EvTypeable -> FV +evFVsOfTypeable ev = + case ev of + EvTypeableTyCon _ e -> mapUnionFV evTermFVs e + EvTypeableTyApp e1 e2 -> evTermFVss [e1,e2] + EvTypeableTrFun em e1 e2 -> evTermFVss [em,e1,e2] + EvTypeableTyLit e -> evTermFVs e + +{- Note [Free vars of EvFun] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Finding the free vars of an EvFun is made tricky by the fact the +bindings et_binds may be a mutable variable. Fortunately, we +can just squeeze by. Here's how. + +* /During/ typechecking, `evTermFVs` is used only by `GHC.Tc.Solver.neededEvVars` + * Each EvBindsVar in an et_binds field of an EvFun is /also/ in the + ic_binds field of an Implication + * So we can track usage via the processing for that implication, + (see Note [Tracking redundant constraints] in GHC.Tc.Solver). + We can ignore usage from the EvFun altogether. + +* /After/ typechecking `evTermFVs` is used by `GHC.Iface.Ext.Ast`, but by + then it has been zonked so we can get at the bindings. +-} + +{- ********************************************************************* +* * + Pretty printing +* * +********************************************************************* -} + +instance Outputable HsWrapper where + ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>")) + +pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc +-- With -fprint-typechecker-elaboration, print the wrapper +-- otherwise just print what's inside +-- The pp_thing_inside function takes Bool to say whether +-- it's in a position that needs parens for a non-atomic thing +pprHsWrapper wrap pp_thing_inside + = sdocOption sdocPrintTypecheckerElaboration $ \case + True -> help pp_thing_inside wrap False + False -> pp_thing_inside False + where + help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc + -- True <=> appears in function application position + -- False <=> appears as body of let or lambda + help it WpHole = it + help it (WpCompose f1 f2) = help (help it f2) f1 + help it (WpFun f1 f2 (Scaled w t1)) = add_parens $ text "\\(x" <> dcolon <> brackets (ppr w) <> ppr t1 <> text ")." <+> + help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False + help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" + <+> pprParendCo co)] + help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] + help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <> pprParendType ty] + help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False] + help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False] + help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] + +pprLamBndr :: Id -> SDoc +pprLamBndr v = pprBndr LambdaBind v + +add_parens, no_parens :: SDoc -> Bool -> SDoc +add_parens d True = parens d +add_parens d False = d +no_parens d _ = d + +instance Outputable TcEvBinds where + ppr (TcEvBinds v) = ppr v + ppr (EvBinds bs) = text "EvBinds" <> braces (vcat (map ppr (bagToList bs))) + +instance Outputable EvBindsVar where + ppr (EvBindsVar { ebv_uniq = u }) + = text "EvBindsVar" <> angleBrackets (ppr u) + ppr (CoEvBindsVar { ebv_uniq = u }) + = text "CoEvBindsVar" <> angleBrackets (ppr u) + +instance Uniquable EvBindsVar where + getUnique = ebv_uniq + +instance Outputable EvBind where + ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_info = info }) + = sep [ pp_gw <+> ppr v + , nest 2 $ equals <+> ppr e ] + -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing + where + pp_gw = brackets $ case info of + EvBindGiven{} -> char 'G' + EvBindWanted{} -> char 'W' + +instance Outputable EvTerm where + ppr (EvExpr e) = ppr e + ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty + ppr (EvFun { et_tvs = tvs, et_given = gs, et_binds = bs, et_body = w }) + = hang (text "\\" <+> sep (map pprLamBndr (tvs ++ gs)) <+> arrow) + 2 (ppr bs $$ ppr w) -- Not very pretty + +instance Outputable EvCallStack where + ppr EvCsEmpty + = text "[]" + ppr (EvCsPushCall orig loc tm) + = ppr (orig,loc) <+> text ":" <+> ppr tm + +instance Outputable EvTypeable where + ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts + ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) + ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 + ppr (EvTypeableTrFun tm t1 t2) = parens (ppr t1 <+> arr <+> ppr t2) + where + arr = pprArrowWithMultiplicity visArgTypeLike (Right (ppr tm)) + +---------------------------------------------------------------------- +-- A datatype used to pass information when desugaring quotations +---------------------------------------------------------------------- + +-- We have to pass a `EvVar` and `Type` into `dsBracket` so that the +-- correct evidence and types are applied to all the TH combinators. +-- This data type bundles them up together with some convenience methods. +-- +-- The EvVar is evidence for `Quote m` +-- The Type is a metavariable for `m` +-- +data QuoteWrapper = QuoteWrapper EvVar Type deriving Data.Data + +quoteWrapperTyVarTy :: QuoteWrapper -> Type +quoteWrapperTyVarTy (QuoteWrapper _ t) = t + +-- | Convert the QuoteWrapper into a normal HsWrapper which can be used to +-- apply its contents. +applyQuoteWrapper :: QuoteWrapper -> HsWrapper +applyQuoteWrapper (QuoteWrapper ev_var m_var) + = mkWpEvVarApps [ev_var] <.> mkWpTyApps [m_var] diff --git a/GHC/Tc/Types/LclEnv.hs b/GHC/Tc/Types/LclEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/LclEnv.hs @@ -0,0 +1,239 @@ +module GHC.Tc.Types.LclEnv ( + TcLclEnv(..) + , TcLclCtxt(..) + , modifyLclCtxt + + , getLclEnvArrowCtxt + , getLclEnvThBndrs + , getLclEnvTypeEnv + , getLclEnvBinderStack + , getLclEnvErrCtxt + , getLclEnvLoc + , getLclEnvRdrEnv + , getLclEnvTcLevel + , getLclEnvThLevel + , setLclEnvTcLevel + , setLclEnvLoc + , setLclEnvRdrEnv + , setLclEnvBinderStack + , setLclEnvErrCtxt + , setLclEnvThLevel + , setLclEnvTypeEnv + , modifyLclEnvTcLevel + + , lclEnvInGeneratedCode + + , addLclEnvErrCtxt + + , ArrowCtxt(..) + , ThBindEnv + , TcTypeEnv +) where + +import GHC.Prelude + +import GHC.Tc.Utils.TcType ( TcLevel ) +import GHC.Tc.Errors.Types ( TcRnMessage ) + +import GHC.Core.UsageEnv ( UsageEnv ) + +import GHC.Types.Name.Reader ( LocalRdrEnv ) +import GHC.Types.Name.Env ( NameEnv ) +import GHC.Types.SrcLoc ( RealSrcSpan ) +import GHC.Types.Basic ( TopLevelFlag ) + +import GHC.Types.Error ( Messages ) + +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Types.TH +import GHC.Tc.Types.TcRef +import GHC.Tc.Types.ErrCtxt +import GHC.Tc.Types.Constraint ( WantedConstraints ) + +{- +************************************************************************ +* * + The local typechecker environment +* * +************************************************************************ + +Note [The Global-Env/Local-Env story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During type checking, we keep in the tcg_type_env + * All types and classes + * All Ids derived from types and classes (constructors, selectors) + +At the end of type checking, we zonk the local bindings, +and as we do so we add to the tcg_type_env + * Locally defined top-level Ids + +Why? Because they are now Ids not TcIds. This final GlobalEnv is + a) fed back (via the knot) to typechecking the + unfoldings of interface signatures + b) used in the ModDetails of this module +-} + +data TcLclEnv -- Changes as we move inside an expression + -- Discarded after typecheck/rename; not passed on to desugarer + = TcLclEnv { + -- The part that we sometimes restore using `restoreLclEnv`. + tcl_lcl_ctxt :: !TcLclCtxt, + + -- These are exactly the parts of TcLclEnv which are not set by `restoreLclEnv`. + + tcl_usage :: TcRef UsageEnv, -- Required multiplicity of bindings is accumulated here. + tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints + tcl_errs :: TcRef (Messages TcRnMessage) -- Place to accumulate diagnostics + } + +data TcLclCtxt + = TcLclCtxt { + tcl_loc :: RealSrcSpan, -- Source span + tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top + tcl_in_gen_code :: Bool, -- See Note [Rebindable syntax and XXExprGhcRn] + tcl_tclvl :: TcLevel, + tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, + -- and for tidying type + + tcl_rdr :: LocalRdrEnv, -- Local name envt + -- Maintained during renaming, of course, but also during + -- type checking, solely so that when renaming a Template-Haskell + -- splice we have the right environment for the renamer. + -- + -- Does *not* include global name envt; may shadow it + -- Includes both ordinary variables and type variables; + -- they are kept distinct because tyvar have a different + -- occurrence constructor (Name.TvOcc) + -- We still need the unsullied global name env so that + -- we can look up record field names + + + tcl_th_ctxt :: ThLevel, -- Template Haskell context + tcl_th_bndrs :: ThBindEnv, -- and binder info + -- The ThBindEnv records the TH binding level of in-scope Names + -- defined in this module (not imported) + -- We can't put this info in the TypeEnv because it's needed + -- (and extended) in the renamer, for untyped splices + + tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context + + tcl_env :: TcTypeEnv -- The local type environment: + -- Ids and TyVars defined in this module + } + +getLclEnvThLevel :: TcLclEnv -> ThLevel +getLclEnvThLevel = tcl_th_ctxt . tcl_lcl_ctxt + +setLclEnvThLevel :: ThLevel -> TcLclEnv -> TcLclEnv +setLclEnvThLevel l = modifyLclCtxt (\env -> env { tcl_th_ctxt = l }) + +getLclEnvThBndrs :: TcLclEnv -> ThBindEnv +getLclEnvThBndrs = tcl_th_bndrs . tcl_lcl_ctxt + +getLclEnvArrowCtxt :: TcLclEnv -> ArrowCtxt +getLclEnvArrowCtxt = tcl_arrow_ctxt . tcl_lcl_ctxt + +getLclEnvTypeEnv :: TcLclEnv -> TcTypeEnv +getLclEnvTypeEnv = tcl_env . tcl_lcl_ctxt + +setLclEnvTypeEnv :: TcTypeEnv -> TcLclEnv -> TcLclEnv +setLclEnvTypeEnv ty_env = modifyLclCtxt (\env -> env { tcl_env = ty_env}) + +setLclEnvTcLevel :: TcLevel -> TcLclEnv -> TcLclEnv +setLclEnvTcLevel lvl = modifyLclCtxt (\env -> env {tcl_tclvl = lvl }) + +modifyLclEnvTcLevel :: (TcLevel -> TcLevel) -> TcLclEnv -> TcLclEnv +modifyLclEnvTcLevel f = modifyLclCtxt (\env -> env { tcl_tclvl = f (tcl_tclvl env)}) + +getLclEnvTcLevel :: TcLclEnv -> TcLevel +getLclEnvTcLevel = tcl_tclvl . tcl_lcl_ctxt + +setLclEnvLoc :: RealSrcSpan -> TcLclEnv -> TcLclEnv +setLclEnvLoc loc = modifyLclCtxt (\lenv -> lenv { tcl_loc = loc }) + +getLclEnvLoc :: TcLclEnv -> RealSrcSpan +getLclEnvLoc = tcl_loc . tcl_lcl_ctxt + +getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt] +getLclEnvErrCtxt = tcl_ctxt . tcl_lcl_ctxt + +setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv +setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt }) + +addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv +addLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt : (tcl_ctxt env) }) + +lclEnvInGeneratedCode :: TcLclEnv -> Bool +lclEnvInGeneratedCode = tcl_in_gen_code . tcl_lcl_ctxt + +getLclEnvBinderStack :: TcLclEnv -> TcBinderStack +getLclEnvBinderStack = tcl_bndrs . tcl_lcl_ctxt + +setLclEnvBinderStack :: TcBinderStack -> TcLclEnv -> TcLclEnv +setLclEnvBinderStack stack = modifyLclCtxt (\env -> env { tcl_bndrs = stack }) + +getLclEnvRdrEnv :: TcLclEnv -> LocalRdrEnv +getLclEnvRdrEnv = tcl_rdr . tcl_lcl_ctxt + +setLclEnvRdrEnv :: LocalRdrEnv -> TcLclEnv -> TcLclEnv +setLclEnvRdrEnv rdr_env = modifyLclCtxt (\env -> env { tcl_rdr = rdr_env }) + +modifyLclCtxt :: (TcLclCtxt -> TcLclCtxt) -> TcLclEnv -> TcLclEnv +modifyLclCtxt upd env = + let !res = upd (tcl_lcl_ctxt env) + in env { tcl_lcl_ctxt = res } + + + +type TcTypeEnv = NameEnv TcTyThing + +type ThBindEnv = NameEnv (TopLevelFlag, ThLevelIndex) + -- Domain = all Ids bound in this module (ie not imported) + -- The TopLevelFlag tells if the binding is syntactically top level. + -- We need to know this, because the cross-stage persistence story allows + -- cross-stage at arbitrary types if the Id is bound at top level. + -- + -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being + -- bound at top level! See Note [Template Haskell levels] in GHC.Tc.Gen.Splice + + +--------------------------- +-- Arrow-notation context +--------------------------- + +{- Note [Escaping the arrow scope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In arrow notation, a variable bound by a proc (or enclosed let/kappa) +is not in scope to the left of an arrow tail (-<) or the head of (|..|). +For example + + proc x -> (e1 -< e2) + +Here, x is not in scope in e1, but it is in scope in e2. This can get +a bit complicated: + + let x = 3 in + proc y -> (proc z -> e1) -< e2 + +Here, x and z are in scope in e1, but y is not. + +We implement this by +recording the environment when passing a proc (using newArrowScope), +and returning to that (using escapeArrowScope) on the left of -< and the +head of (|..|). + +All this can be dealt with by the *renamer*. But the type checker needs +to be involved too. Example (arrowfail001) + class Foo a where foo :: a -> () + data Bar = forall a. Foo a => Bar a + get :: Bar -> () + get = proc x -> case x of Bar a -> foo -< a +Here the call of 'foo' gives rise to a (Foo a) constraint that should not +be captured by the pattern match on 'Bar'. Rather it should join the +constraints from further out. So we must capture the constraint bag +from further out in the ArrowCtxt that we push inwards. +-} + +data ArrowCtxt -- Note [Escaping the arrow scope] + = NoArrowCtxt + | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints) diff --git a/GHC/Tc/Types/LclEnv.hs-boot b/GHC/Tc/Types/LclEnv.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/LclEnv.hs-boot @@ -0,0 +1,6 @@ +module GHC.Tc.Types.LclEnv where + +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + +data TcLclEnv diff --git a/GHC/Tc/Types/Origin.hs b/GHC/Tc/Types/Origin.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/Origin.hs @@ -0,0 +1,1677 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +-- | Describes the provenance of types as they flow through the type-checker. +-- The datatypes here are mainly used for error message generation. +module GHC.Tc.Types.Origin ( + -- * UserTypeCtxt + UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe, + ReportRedundantConstraints(..), reportRedundantConstraints, + redundantConstraintsSpan, + + -- * SkolemInfo + SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo, + unkSkol, unkSkolAnon, + + -- * CtOrigin + CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, + isVisibleOrigin, toInvisibleOrigin, + pprCtOrigin, pprCtOriginBriefly, + isGivenOrigin, isWantedWantedFunDepOrigin, + isWantedSuperclassOrigin, + ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..), + HsImplicitLiftSplice(..), + StandaloneDeriv, + + TypedThing(..), TyVarBndrs(..), + + -- * CallStack + isPushCallStackOrigin_maybe, + + -- * FixedRuntimeRep origin + FixedRuntimeRepOrigin(..), + FixedRuntimeRepContext(..), + pprFixedRuntimeRepContext, + StmtOrigin(..), ArgPos(..), + mkFRRUnboxedTuple, mkFRRUnboxedSum, + + -- ** FixedRuntimeRep origin for rep-poly 'Id's + RepPolyId(..), Polarity(..), Position(..), mkArgPos, + + -- ** Arrow command FixedRuntimeRep origin + FRRArrowContext(..), pprFRRArrowContext, + + -- ** ExpectedFunTy FixedRuntimeRepOrigin + ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald, + + -- * InstanceWhat + InstanceWhat(..), SafeOverlapping + ) where + +import GHC.Prelude + +import GHC.Tc.Utils.TcType + +import GHC.Hs + +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.InstEnv +import GHC.Core.PatSyn +import GHC.Core.Multiplicity ( scaledThing ) + +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Basic +import GHC.Types.SrcLoc + +import GHC.Data.FastString + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Stack +import GHC.Utils.Monad +import GHC.Utils.Misc( HasDebugCallStack, nTimes ) +import GHC.Types.Unique +import GHC.Types.Unique.Supply + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import qualified Data.Kind as Hs +import Data.List.NonEmpty (NonEmpty (..)) + +{- ********************************************************************* +* * + UserTypeCtxt +* * +********************************************************************* -} + +------------------------------------- +-- | UserTypeCtxt describes the origin of the polymorphic type +-- in the places where we need an expression to have that type +data UserTypeCtxt + = FunSigCtxt -- Function type signature, when checking the type + -- Also used for types in SPECIALISE pragmas + Name -- Name of the function + ReportRedundantConstraints + -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + -- This field is usually 'WantRCC', but 'NoRCC' for + -- * Record selectors (not important here) + -- * Class and instance methods. Here the code may legitimately + -- be more polymorphic than the signature generated from the + -- class declaration + -- * Functions whose type signature has hidden the constraints + -- behind a type synonym. E.g. + -- type Foo = forall a. Eq a => a -> a + -- id :: Foo + -- id x = x + -- Here we can't give a good location for the redundant constraints + -- (see lhsSigWcTypeContextSpan), so we don't report redundant + -- constraints at all. It's not clear that this a good choice; + -- perhaps we should report, just with a less informative SrcSpan. + -- c.f. #16154 + + | InfSigCtxt Name -- Inferred type for function + | ExprSigCtxt -- Expression type signature + ReportRedundantConstraints + | KindSigCtxt -- Kind signature + | StandaloneKindSigCtxt -- Standalone kind signature + Name -- Name of the type/class + | TypeAppCtxt -- Visible type application + | ConArgCtxt Name -- Data constructor argument + | TySynCtxt Name -- RHS of a type synonym decl + | PatSynCtxt Name -- Type sig for a pattern synonym + | PatSigCtxt -- Type sig in pattern + -- eg f (x::t) = ... + -- or (x::t, y) = e + | ForSigCtxt Name -- Foreign import or export signature + | DefaultDeclCtxt -- Class or types in a default declaration + | InstDeclCtxt Bool -- An instance declaration + -- True: stand-alone deriving + -- False: vanilla instance declaration + | SpecInstCtxt -- SPECIALISE instance pragma + | GenSigCtxt -- Higher-rank or impredicative situations + -- e.g. (f e) where f has a higher-rank type + -- We might want to elaborate this + | GhciCtxt Bool -- GHCi command :kind + -- The Bool indicates if we are checking the outermost + -- type application. + -- See Note [Unsaturated type synonyms in GHCi] in + -- GHC.Tc.Validity. + + | ClassSCCtxt Name -- Superclasses of a class + | SigmaCtxt -- Theta part of a normal for-all type + -- f :: => a -> a + | DataTyCtxt Name -- The "stupid theta" part of a data decl + -- data => T a = MkT a + | DerivClauseCtxt -- A 'deriving' clause + | TyVarBndrKindCtxt Name -- The kind of a type variable being bound + | RuleBndrTypeCtxt Name -- The type of a term variable being bound in a RULE + -- or SPECIALISE pragma + -- RULE "foo" forall (x :: a -> a). f (Just x) = ... + | DataKindCtxt Name -- The kind of a data/newtype (instance) + | TySynKindCtxt Name -- The kind of the RHS of a type synonym + | TyFamResKindCtxt Name -- The result kind of a type family + deriving( Eq ) -- Just for checkSkolInfoAnon + +-- | Report Redundant Constraints. +data ReportRedundantConstraints + = NoRRC -- ^ Don't report redundant constraints + + | WantRRC SrcSpan -- ^ Report redundant constraints + -- The SrcSpan is for the constraints + -- E.g. f :: (Eq a, Ord b) => blah + -- The span is for the (Eq a, Ord b) + -- We need to record the span here because we have + -- long since discarded the HsType in favour of a Type + + deriving( Eq ) -- Just for checkSkolInfoAnon + +reportRedundantConstraints :: ReportRedundantConstraints -> Bool +reportRedundantConstraints NoRRC = False +reportRedundantConstraints (WantRRC {}) = True + +redundantConstraintsSpan :: UserTypeCtxt -> SrcSpan +redundantConstraintsSpan (FunSigCtxt _ (WantRRC span)) = span +redundantConstraintsSpan (ExprSigCtxt (WantRRC span)) = span +redundantConstraintsSpan _ = noSrcSpan + +{- +-- Notes re TySynCtxt +-- We allow type synonyms that aren't types; e.g. type List = [] +-- +-- If the RHS mentions tyvars that aren't in scope, we'll +-- quantify over them: +-- e.g. type T = a->a +-- will become type T = forall a. a->a +-- +-- With gla-exts that's right, but for H98 we should complain. +-} + + +pprUserTypeCtxt :: UserTypeCtxt -> SDoc +pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) +pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature" +pprUserTypeCtxt KindSigCtxt = text "a kind signature" +pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) +pprUserTypeCtxt TypeAppCtxt = text "a type argument" +pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) +pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) +pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" +pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = text "a `default' declaration" +pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" +pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration" +pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" +pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" +pprUserTypeCtxt (GhciCtxt {}) = text "a type in a GHCi command" +pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) +pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" +pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) +pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) +pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" +pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n) +pprUserTypeCtxt (RuleBndrTypeCtxt n) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) +pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) +pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) + +isSigMaybe :: UserTypeCtxt -> Maybe Name +isSigMaybe (FunSigCtxt n _) = Just n +isSigMaybe (ConArgCtxt n) = Just n +isSigMaybe (ForSigCtxt n) = Just n +isSigMaybe (PatSynCtxt n) = Just n +isSigMaybe _ = Nothing + +{- +************************************************************************ +* * + SkolemInfo +* * +************************************************************************ +-} + +-- | 'SkolemInfo' stores the origin of a skolem type variable, +-- so that we can display this information to the user in case of a type error. +-- +-- The 'Unique' field allows us to report all skolem type variables bound in the +-- same place in a single report. +data SkolemInfo + = SkolemInfo + Unique -- ^ The Unique is used to common up skolem variables bound + -- at the same location (only used in pprSkols) + SkolemInfoAnon -- ^ The information about the origin of the skolem type variable + +instance Uniquable SkolemInfo where + getUnique (SkolemInfo u _) = u + +-- | 'SkolemInfoAnon' stores the origin of a skolem type variable (e.g. bound by +-- a user-written forall, the header of a data declaration, a deriving clause, ...). +-- +-- This information is displayed when reporting an error message, such as +-- +-- @"Couldn't match 'k' with 'l'"@ +-- +-- This allows us to explain where the type variable came from. +-- +-- When several skolem type variables are bound at once, prefer using 'SkolemInfo', +-- which stores a 'Unique' which allows these type variables to be reported +data SkolemInfoAnon + = SigSkol -- A skolem that is created by instantiating + -- a programmer-supplied type signature + -- Location of the binding site is on the TyVar + -- See Note [SigSkol SkolemInfo] + UserTypeCtxt -- What sort of signature + TcType -- Original type signature (before skolemisation) + [(Name,TcTyVar)] -- Maps the original name of the skolemised tyvar + -- to its instantiated version + + | SigTypeSkol UserTypeCtxt + -- like SigSkol, but when we're kind-checking the *type* + -- hence, we have less info + + | ForAllSkol -- Bound by a user-written "forall". + TyVarBndrs -- Shows just the binders, used when reporting a bad telescope + -- See Note [Checking telescopes] in GHC.Tc.Types.Constraint + + | DerivSkol Type -- Bound by a 'deriving' clause; + -- the type is the instance we are trying to derive + + | InstSkol -- Bound at an instance decl, or quantified constraint + ClsInstOrQC -- Whether class instance or quantified constraint + PatersonSize -- Head has the given PatersonSize + + | MethSkol Name Bool -- Bound by the type of class method op + -- True <=> it's a vanilla default method + -- False <=> it's a user-written, or generic-default, method + -- See (TRC5) in Note [Tracking redundant constraints] + -- in GHC.Tc.Solver.Solve + + | FamInstSkol -- Bound at a family instance decl + + | PatSkol -- An existential type variable bound by a pattern for + ConLike -- a data constructor with an existential type. + HsMatchContextRn + -- e.g. data T = forall a. Eq a => MkT a + -- f (MkT x) = ... + -- The pattern MkT x will allocate an existential type + -- variable for 'a'. + + | IPSkol [HsIPName] -- Binding site of an implicit parameter + + | RuleSkol RuleName -- The LHS of a RULE + | SpecESkol Name -- A SPECIALISE pragma + + | InferSkol [(Name,TcType)] + -- We have inferred a type for these (mutually recursive) + -- polymorphic Ids, and are now checking that their RHS + -- constraints are satisfied. + + | BracketSkol -- Template Haskell bracket + + | UnifyForAllSkol -- We are unifying two for-all types + TcType -- The instantiated type *inside* the forall + + | TyConSkol (TyConFlavour TyCon) Name -- bound in a type declaration of the given flavour + + | DataConSkol Name -- bound as an existential in a Haskell98 datacon decl or + -- as any variable in a GADT datacon decl + + | ReifySkol -- Bound during Template Haskell reification + + | RuntimeUnkSkol -- Runtime skolem from the GHCi debugger #14628 + + | ArrowReboundIfSkol -- Bound by the expected type of the rebound arrow ifThenElse command. + + | UnkSkol CallStack + + +-- | Use this when you can't specify a helpful origin for +-- some skolem type variable. +-- +-- We're hoping to be able to get rid of this entirely, but for the moment +-- it's still needed. +unkSkol :: HasDebugCallStack => SkolemInfo +unkSkol = SkolemInfo (mkUniqueGrimily 0) unkSkolAnon + +unkSkolAnon :: HasDebugCallStack => SkolemInfoAnon +unkSkolAnon = UnkSkol callStack + +-- | Wrap up the origin of a skolem type variable with a new 'Unique', +-- so that we can common up skolem type variables whose 'SkolemInfo' +-- shares a certain 'Unique'. +mkSkolemInfo :: MonadIO m => SkolemInfoAnon -> m SkolemInfo +mkSkolemInfo sk_anon = do + u <- liftIO $! uniqFromTag 's' + return (SkolemInfo u sk_anon) + +getSkolemInfo :: SkolemInfo -> SkolemInfoAnon +getSkolemInfo (SkolemInfo _ skol_anon) = skol_anon + +instance Outputable SkolemInfo where + ppr (SkolemInfo _ sk_info ) = ppr sk_info + +instance Outputable SkolemInfoAnon where + ppr = pprSkolInfo + +pprSkolInfo :: SkolemInfoAnon -> SDoc +-- Complete the sentence "is a rigid type variable bound by..." +pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty +pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx +pprSkolInfo (ForAllSkol tvs) = text "an explicit forall" <+> ppr tvs +pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" + <+> pprWithCommas ppr ips +pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) +pprSkolInfo (InstSkol IsClsInst sz) = vcat [ text "the instance declaration" + , whenPprDebug (braces (ppr sz)) ] +pprSkolInfo (InstSkol (IsQC {}) sz) = vcat [ text "a quantified constraint" + , whenPprDebug (braces (ppr sz)) ] +pprSkolInfo (MethSkol name d) = text "the" <+> ppWhen d (text "default") + <+> text "method declaration for" <+> ppr name +pprSkolInfo FamInstSkol = text "a family instance declaration" +pprSkolInfo BracketSkol = text "a Template Haskell bracket" +pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name +pprSkolInfo (SpecESkol name) = text "a SPECIALISE pragma for" <+> quotes (ppr name) +pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl + , text "in" <+> pprMatchContext mc ] +pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of") + 2 (vcat [ ppr name <+> dcolon <+> ppr ty + | (name,ty) <- ids ]) +pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty +pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name) +pprSkolInfo (DataConSkol name) = text "the type signature for" <+> quotes (ppr name) +pprSkolInfo ReifySkol = text "the type being reified" + +pprSkolInfo RuntimeUnkSkol = text "Unknown type from GHCi runtime" +pprSkolInfo ArrowReboundIfSkol = text "the expected type of a rebound if-then-else command" + +-- unkSkol +-- For type variables the others are dealt with by pprSkolTvBinding. +-- For Insts, these cases should not happen +pprSkolInfo (UnkSkol cs) = text "UnkSkol (please report this as a bug)" $$ prettyCallStackDoc cs + + +pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc +-- The type is already tidied +pprSigSkolInfo ctxt ty + = case ctxt of + FunSigCtxt f _ -> vcat [ text "the type signature for:" + , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ] + PatSynCtxt {} -> pprUserTypeCtxt ctxt -- See Note [Skolem info for pattern synonyms] + _ -> vcat [ pprUserTypeCtxt ctxt <> colon + , nest 2 (ppr ty) ] + +pprPatSkolInfo :: ConLike -> SDoc +pprPatSkolInfo (RealDataCon dc) + = sdocOption sdocLinearTypes (\show_linear_types -> + sep [ text "a pattern with constructor:" + , nest 2 $ ppr dc <+> dcolon + <+> pprType (dataConDisplayType show_linear_types dc) <> comma ]) + -- pprType prints forall's regardless of -fprint-explicit-foralls + -- which is what we want here, since we might be saying + -- type variable 't' is bound by ... + +pprPatSkolInfo (PatSynCon ps) + = sep [ text "a pattern with pattern synonym:" + , nest 2 $ ppr ps <+> dcolon + <+> pprPatSynType ps <> comma ] + +{- Note [Skolem info for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For pattern synonym SkolemInfo we have + SigSkol (PatSynCtxt p) ty _ +but the type 'ty' is not very helpful. The full pattern-synonym type +has the provided and required pieces, which it is inconvenient to +record and display here. So we simply don't display the type at all, +contenting ourselves with just the name of the pattern synonym, which +is fine. We could do more, but it doesn't seem worth it. + +Note [SigSkol SkolemInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we skolemise a type + f :: forall a. Eq a => forall b. b -> a +Then we'll instantiate [a :-> a', b :-> b'], and with the instantiated + a' -> b' -> a. +But when, in an error message, we report that "b is a rigid type +variable bound by the type signature for f", we want to show the foralls +in the right place. So we proceed as follows: + +* In SigSkol we record + - the original signature forall a. a -> forall b. b -> a + - the instantiation mapping [a :-> a', b :-> b'] + +* Then when tidying in GHC.Tc.Utils.TcMType.tidySkolemInfo, we first tidy a' to + whatever it tidies to, say a''; and then we walk over the type + replacing the binder a by the tidied version a'', to give + forall a''. Eq a'' => forall b''. b'' -> a'' + We need to do this under (=>) arrows and (->), to match what skolemisation + does. + +* Typically a'' will have a nice pretty name like "a", but the point is + that the foral-bound variables of the signature we report line up with + the instantiated skolems lying around in other types. +-} + +{- ********************************************************************* +* * + CtOrigin +* * +************************************************************************ +-} + +-- | Some thing which has a type. +-- +-- This datatype is used when we want to report to the user +-- that something has an unexpected type. +data TypedThing + = HsTypeRnThing (HsType GhcRn) + | TypeThing Type + | HsExprRnThing (HsExpr GhcRn) + | HsExprTcThing (HsExpr GhcTc) + | NameThing Name + +-- | Some kind of type variable binder. +-- +-- Used for reporting errors, in 'SkolemInfo' and 'TcSolverReportMsg'. +data TyVarBndrs + = forall flag. OutputableBndrFlag flag 'Renamed => + HsTyVarBndrsRn [HsTyVarBndr flag GhcRn] + +instance Outputable TypedThing where + ppr (HsTypeRnThing ty) = ppr ty + ppr (TypeThing ty) = ppr ty + ppr (HsExprRnThing expr) = ppr expr + ppr (HsExprTcThing expr) = ppr expr + ppr (NameThing name) = ppr name + +instance Outputable TyVarBndrs where + ppr (HsTyVarBndrsRn bndrs) = fsep (map ppr bndrs) + +data CtOrigin + = -- | A given constraint from a user-written type signature. The + -- 'SkolemInfo' inside gives more information. + GivenOrigin SkolemInfoAnon + + -- | 'GivenSCOrigin' is used for a Given constraint obtained by superclass selection + -- from the context of an instance declaration. E.g. + -- instance @(Foo a, Bar a) => C [a]@ where ... + -- When typechecking the instance decl itself, including producing evidence + -- for the superclasses of @C@, the superclasses of @(Foo a)@ and @(Bar a)@ will + -- have 'GivenSCOrigin' origin. + | GivenSCOrigin + SkolemInfoAnon -- ^ Just like GivenOrigin + + ScDepth -- ^ The number of superclass selections necessary to + -- get this constraint; see Note [Replacement vs keeping] + -- in GHC.Tc.Solver.Dict + + Bool -- ^ True => "blocked": cannot use this to solve naked superclass Wanteds + -- i.e. ones with (ScOrigin _ NakedSc) + -- False => can use this to solve all Wanted constraints + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + + ----------- Below here, all are Origins for Wanted constraints ------------ + + | OccurrenceOf Name -- ^ Occurrence of an overloaded identifier + | OccurrenceOfRecSel RdrName -- ^ Occurrence of a record selector + | AppOrigin -- ^ An application of some kind + + | SpecPragOrigin UserTypeCtxt -- ^ Specialisation pragma for + -- function or instance + + + | TypeEqOrigin { uo_actual :: TcType + , uo_expected :: TcType + , uo_thing :: Maybe TypedThing + -- ^ The thing that has type "actual" + , uo_visible :: Bool + -- ^ Is at least one of the three elements above visible? + -- (Errors from the polymorphic subsumption check are considered + -- visible.) Only used for prioritizing error messages. + } + + | KindEqOrigin + TcType TcType -- A kind equality arising from unifying these two types + CtOrigin -- originally arising from this + (Maybe TypeOrKind) -- the level of the eq this arises from + + | IPOccOrigin HsIPName -- Occurrence of an implicit parameter + | OverLabelOrigin FastString -- Occurrence of an overloaded label + + | LiteralOrigin (HsOverLit GhcRn) -- Occurrence of a literal + | NegateOrigin -- Occurrence of syntactic negation + + | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc + | AssocFamPatOrigin -- When matching the patterns of an associated + -- family instance with that of its parent class + -- IMPORTANT: These constraints will never cause errors; + -- See Note [Constraints to ignore] in GHC.Tc.Errors + | SectionOrigin + | GetFieldOrigin FastString + | TupleOrigin -- (..,..) + | ExprSigOrigin -- e :: ty + | PatSigOrigin -- p :: ty + | PatOrigin -- Instantiating a polytyped pattern at a constructor + | ProvCtxtOrigin -- The "provided" context of a pattern synonym signature + (PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in + -- particular the name and the right-hand side + | RecordUpdOrigin + | ViewPatOrigin + + -- | 'ScOrigin' is used only for the Wanted constraints for the + -- superclasses of an instance declaration. + | ScOrigin + ClsInstOrQC -- Whether class instance or quantified constraint + NakedScFlag + + | DerivOrigin StandaloneDeriv + -- Typechecking a `deriving` clause, or a standalone `deriving` declaration + | DerivOriginDC DataCon Int StandaloneDeriv + -- Checking constraints arising from this data con and field index. The + -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if + -- standalong deriving (with a wildcard constraint) is being used. This + -- is used to inform error messages on how to recommended fixes (e.g., if + -- the argument is True, then don't recommend "use standalone deriving", + -- but rather "fill in the wildcard constraint yourself"). + -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer + | DerivOriginCoerce Id Type Type StandaloneDeriv + -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from + -- `ty1` to `ty2`. + + | DefaultOrigin -- Typechecking a default decl + | DoOrigin -- Arising from a do expression + | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in + -- a do expression + | MCompOrigin -- Arising from a monad comprehension + | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a + -- monad comprehension + | ProcOrigin -- Arising from a proc expression + | ArrowCmdOrigin -- Arising from an arrow command + | AnnOrigin -- An annotation + + | FunDepOrigin1 -- A functional dependency from combining + PredType CtOrigin RealSrcSpan -- This constraint arising from ... + PredType CtOrigin RealSrcSpan -- and this constraint arising from ... + + | FunDepOrigin2 -- A functional dependency from combining + PredType CtOrigin -- This constraint arising from ... + PredType SrcSpan -- and this top-level instance + -- We only need a CtOrigin on the first, because the location + -- is pinned on the entire error message + + | InjTFOrigin1 -- injective type family equation combining + PredType CtOrigin RealSrcSpan -- This constraint arising from ... + PredType CtOrigin RealSrcSpan -- and this constraint arising from ... + + | ExprHoleOrigin (Maybe RdrName) -- from an expression hole + | TypeHoleOrigin OccName -- from a type hole (partial type signature) + | PatCheckOrigin -- normalisation of a type during pattern-match checking + | ListOrigin -- An overloaded list + | IfThenElseOrigin -- An if-then-else expression + | BracketOrigin -- An overloaded quotation bracket + | StaticOrigin -- A static form + | ImpedanceMatching Id -- See Note [Impedance matching] in GHC.Tc.Gen.Bind + | Shouldn'tHappenOrigin String -- The user should never see this one + + -- | Testing whether the constraint associated with an instance declaration + -- in a signature file is satisfied upon instantiation. + -- + -- Test cases: backpack/should_fail/bkpfail{11,43}.bkp + | InstProvidedOrigin + Module -- ^ Module in which the instance was declared + ClsInst -- ^ The declared typeclass instance + + | NonLinearPatternOrigin NonLinearPatternReason (LPat GhcRn) + | OmittedFieldOrigin (Maybe FieldLabel) + | UsageEnvironmentOf Name + + -- | See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Equality + | CycleBreakerOrigin + CtOrigin -- origin of the original constraint + + | FRROrigin + FixedRuntimeRepOrigin + + | WantedSuperclassOrigin PredType CtOrigin + -- From expanding out the superclasses of a Wanted; the PredType + -- is the subclass predicate, and the origin + -- of the original Wanted is the CtOrigin + + | InstanceSigOrigin -- from the sub-type check of an InstanceSig + Name -- the method name + Type -- the instance-sig type + Type -- the instantiated type of the method + | AmbiguityCheckOrigin UserTypeCtxt + | ImplicitLiftOrigin HsImplicitLiftSplice + +data NonLinearPatternReason + = LazyPatternReason + | GeneralisedPatternReason + | PatternSynonymReason + | ViewPatternReason + | OtherPatternReason + +type StandaloneDeriv = Bool + -- False <=> a `deriving` clause on a data/newtype declaration + -- e.g. data T a = MkT a deriving( Eq ) + -- True <=> a standalone `deriving` clause with a wildcard constraint + -- e.g deriving instance _ => Eq (T a) + -- See Note [Inferring the instance context] + -- in GHC.Tc.Deriv.Infer + +-- | The number of superclass selections needed to get this Given. +-- If @d :: C ty@ has @ScDepth=2@, then the evidence @d@ will look +-- like @sc_sel (sc_sel dg)@, where @dg@ is a Given. +type ScDepth = Int + +data ClsInstOrQC + = IsClsInst + | IsQC PredType CtOrigin -- The PredType is the forall-constraint we are trying to solve + +data NakedScFlag = NakedSc | NotNakedSc + -- The NakedScFlag affects only GHC.Tc.Solver.InertSet.prohibitedSuperClassSolve + -- * For the original superclass constraints we use (ScOrigin _ NakedSc) + -- * But after using an instance declaration we use (ScOrigin _ NotNakedSc) + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + +instance Outputable NakedScFlag where + ppr NakedSc = text "NakedSc" + ppr NotNakedSc = text "NotNakedSc" + +-- An origin is visible if the place where the constraint arises is manifest +-- in user code. Currently, all origins are visible except for invisible +-- TypeEqOrigins. This is used when choosing which error of +-- several to report +isVisibleOrigin :: CtOrigin -> Bool +isVisibleOrigin (TypeEqOrigin { uo_visible = vis }) = vis +isVisibleOrigin (KindEqOrigin _ _ sub_orig _) = isVisibleOrigin sub_orig +isVisibleOrigin _ = True + +-- Converts a visible origin to an invisible one, if possible. Currently, +-- this works only for TypeEqOrigin +toInvisibleOrigin :: CtOrigin -> CtOrigin +toInvisibleOrigin orig@(TypeEqOrigin {}) = orig { uo_visible = False } +toInvisibleOrigin orig = orig + +isGivenOrigin :: CtOrigin -> Bool +isGivenOrigin (GivenOrigin {}) = True +isGivenOrigin (GivenSCOrigin {}) = True +isGivenOrigin (CycleBreakerOrigin o) = isGivenOrigin o +isGivenOrigin _ = False + +-- See Note [Suppressing confusing errors] in GHC.Tc.Errors +isWantedWantedFunDepOrigin :: CtOrigin -> Bool +isWantedWantedFunDepOrigin (FunDepOrigin1 _ orig1 _ _ orig2 _) + = not (isGivenOrigin orig1) && not (isGivenOrigin orig2) +isWantedWantedFunDepOrigin (InjTFOrigin1 _ orig1 _ _ orig2 _) + = not (isGivenOrigin orig1) && not (isGivenOrigin orig2) +isWantedWantedFunDepOrigin _ = False + +-- | Did a constraint arise from expanding a Wanted constraint +-- to look at superclasses? +isWantedSuperclassOrigin :: CtOrigin -> Bool +isWantedSuperclassOrigin (WantedSuperclassOrigin {}) = True +isWantedSuperclassOrigin _ = False + +instance Outputable CtOrigin where + ppr = pprCtOrigin + +-- | Extract a suitable CtOrigin from a HsExpr +lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin +lexprCtOrigin (L _ e) = exprCtOrigin e + +exprCtOrigin :: HsExpr GhcRn -> CtOrigin +exprCtOrigin (HsVar _ (L _ (WithUserRdr _ name))) = OccurrenceOf name +exprCtOrigin (HsGetField _ _ (L _ f)) = GetFieldOrigin (field_label $ unLoc $ dfoLabel f) +exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l +exprCtOrigin (ExplicitList {}) = ListOrigin +exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip +exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit +exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" +exprCtOrigin (HsLam _ _ ms) = matchesCtOrigin ms +exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 +exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 +exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op +exprCtOrigin (NegApp _ e _) = lexprCtOrigin e +exprCtOrigin (HsPar _ e) = lexprCtOrigin e +exprCtOrigin (HsProjection _ _) = SectionOrigin +exprCtOrigin (SectionL _ _ _) = SectionOrigin +exprCtOrigin (SectionR _ _ _) = SectionOrigin +exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" +exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" +exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches +exprCtOrigin (HsIf {}) = IfThenElseOrigin +exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs +exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e +exprCtOrigin (HsDo {}) = DoOrigin +exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" +exprCtOrigin (RecordUpd {}) = RecordUpdOrigin +exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin +exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" +exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e +exprCtOrigin (HsTypedBracket {}) = Shouldn'tHappenOrigin "TH typed bracket" +exprCtOrigin (HsUntypedBracket {}) = Shouldn'tHappenOrigin "TH untyped bracket" +exprCtOrigin (HsTypedSplice {}) = Shouldn'tHappenOrigin "TH typed splice" +exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice" +exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" +exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" +exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression" +exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" +exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] +exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] +exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] +exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOrigin a + | OrigStmt _ <- thing = DoOrigin + | OrigPat p <- thing = DoPatOrigin p +exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt" +exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) + +-- | Extract a suitable CtOrigin from a MatchGroup +matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin +matchesCtOrigin (MG { mg_alts = alts }) + | L _ [L _ match] <- alts + , Match { m_grhss = grhss } <- match + = grhssCtOrigin grhss + + | otherwise + = Shouldn'tHappenOrigin "multi-way match" + +-- | Extract a suitable CtOrigin from guarded RHSs +grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin +grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss + +-- | Extract a suitable CtOrigin from a list of guarded RHSs +lGRHSCtOrigin :: NonEmpty (LGRHS GhcRn (LHsExpr GhcRn)) -> CtOrigin +lGRHSCtOrigin (L _ (GRHS _ _ (L _ e)) :| []) = exprCtOrigin e +lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" + +ctoHerald :: SDoc +ctoHerald = text "arising from" + +pprCtOrigin :: CtOrigin -> SDoc + +pprCtOrigin (GivenOrigin sk) + = ctoHerald <+> ppr sk + +pprCtOrigin (GivenSCOrigin sk d blk) + = vcat [ ctoHerald <+> pprSkolInfo sk + , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ] + +pprCtOrigin (SpecPragOrigin ctxt) + = ctoHerald <+> + case ctxt of + FunSigCtxt n _ -> text "a SPECIALISE pragma for" <+> quotes (ppr n) + SpecInstCtxt -> text "a SPECIALISE INSTANCE pragma" + _ -> text "a SPECIALISE pragma" -- Never happens I think + +pprCtOrigin (FunDepOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) + = hang (ctoHerald <+> text "a functional dependency between constraints:") + 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtOrigin orig1 <+> text "at" <+> ppr loc1) + , hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ]) + +pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) + = hang (ctoHerald <+> text "a functional dependency between:") + 2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1)) + 2 (pprCtOrigin orig1 ) + , hang (text "instance" <+> quotes (ppr pred2)) + 2 (text "at" <+> ppr loc2) ]) + +pprCtOrigin (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) + = hang (ctoHerald <+> text "reasoning about an injective type family using constraints:") + 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtOrigin orig1 <+> text "at" <+> ppr loc1) + , hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ]) + +pprCtOrigin AssocFamPatOrigin + = ctoHerald <+> text "matching a family LHS with its class instance head" + +pprCtOrigin (TypeEqOrigin { uo_actual = t1, uo_expected = t2, uo_visible = vis }) + = hang (ctoHerald <+> text "a type equality" <> whenPprDebug (brackets (ppr vis))) + 2 (sep [ppr t1, char '~', ppr t2]) + +pprCtOrigin (KindEqOrigin t1 t2 _ _) + = hang (ctoHerald <+> text "a kind equality arising from") + 2 (sep [ppr t1, char '~', ppr t2]) + +pprCtOrigin (DerivOriginDC dc n _) + = hang (ctoHerald <+> text "the" <+> speakNth n + <+> text "field of" <+> quotes (ppr dc)) + 2 (parens (text "type" <+> quotes (ppr (scaledThing ty)))) + where + ty = dataConOrigArgTys dc !! (n-1) + +pprCtOrigin (DerivOriginCoerce meth ty1 ty2 _) + = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth)) + 2 (sep [ text "from type" <+> quotes (ppr ty1) + , nest 2 $ text "to type" <+> quotes (ppr ty2) ]) + +pprCtOrigin (DoPatOrigin pat) + = ctoHerald <+> text "a do statement" + $$ + text "with the failable pattern" <+> quotes (ppr pat) + +pprCtOrigin (MCompPatOrigin pat) + = ctoHerald <+> hsep [ text "the failable pattern" + , quotes (ppr pat) + , text "in a statement in a monad comprehension" ] + +pprCtOrigin (Shouldn'tHappenOrigin note) + = vcat [ text "<< This should not appear in error messages. If you see this" + , text "in an error message, please report a bug mentioning" + <+> quotes (text note) <+> text "at" + , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>" + ] + +pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) + = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") + 2 (text "the signature of" <+> quotes (ppr name)) + +pprCtOrigin (InstProvidedOrigin mod cls_inst) + = vcat [ ctoHerald <+> text "attempting to show that" + , ppr cls_inst + , text "is provided by" <+> quotes (ppr mod)] + +pprCtOrigin (ImpedanceMatching x) + = vcat [ ctoHerald <+> text "matching required constraints" + , text "in a binding group involving" <+> quotes (ppr x)] + +pprCtOrigin (CycleBreakerOrigin orig) + = pprCtOrigin orig + +pprCtOrigin (WantedSuperclassOrigin subclass_pred subclass_orig) + = sep [ ctoHerald <+> text "a superclass required to satisfy" <+> quotes (ppr subclass_pred) <> comma + , pprCtOrigin subclass_orig ] + +pprCtOrigin (InstanceSigOrigin method_name sig_type orig_method_type) + = vcat [ ctoHerald <+> text "the check that an instance signature is more general" + , text "than the type of the method (instantiated for this instance)" + , hang (text "instance signature:") + 2 (ppr method_name <+> dcolon <+> ppr sig_type) + , hang (text "instantiated method type:") + 2 (ppr orig_method_type) ] + +pprCtOrigin (AmbiguityCheckOrigin ctxt) + = ctoHerald <+> text "a type ambiguity check for" $$ + pprUserTypeCtxt ctxt + +pprCtOrigin (ScOrigin IsClsInst nkd) + = vcat [ ctoHerald <+> text "the superclasses of an instance declaration" + , whenPprDebug (braces (text "sc-origin:" <> ppr nkd)) ] + +pprCtOrigin (ScOrigin (IsQC pred orig) nkd) + = vcat [ whenPprDebug (text "IsQC" <> braces (text "sc-origin:" <> ppr nkd) <+> ppr pred) + , hang (text "arising (via a quantified constraint) from") + 2 (pprCtOriginBriefly orig) ] + -- Print `orig` briefly with pprCtOriginBriefly. We'll print it more + -- voluminously later: see GHC.Tc.Errors.Ppr.pprQCOriginExtra + +pprCtOrigin (NonLinearPatternOrigin reason pat) + = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat)) + 2 (pprNonLinearPatternReason reason) + +pprCtOrigin simple_origin + = ctoHerald <+> pprCtOriginBriefly simple_origin + +-- | Print CtOrigin briefly, with a one-liner +pprCtOriginBriefly :: CtOrigin -> SDoc +pprCtOriginBriefly = ppr_br -- ppr_br is a local function with a short name! + +ppr_br :: CtOrigin -> SDoc +ppr_br (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] +ppr_br (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] +ppr_br AppOrigin = text "an application" +ppr_br (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] +ppr_br (OverLabelOrigin l) = hsep [text "the overloaded label" + ,quotes (char '#' <> ppr l)] +ppr_br RecordUpdOrigin = text "a record update" +ppr_br ExprSigOrigin = text "an expression type signature" +ppr_br PatSigOrigin = text "a pattern type signature" +ppr_br PatOrigin = text "a pattern" +ppr_br ViewPatOrigin = text "a view pattern" +ppr_br (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] +ppr_br (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] +ppr_br SectionOrigin = text "an operator section" +ppr_br (GetFieldOrigin f) = hsep [text "selecting the field", quotes (ppr f)] +ppr_br AssocFamPatOrigin = text "the LHS of a family instance" +ppr_br TupleOrigin = text "a tuple" +ppr_br NegateOrigin = text "a use of syntactic negation" +ppr_br (ScOrigin IsClsInst _) = text "the superclasses of an instance declaration" +ppr_br (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint" +ppr_br (DerivOrigin standalone) + | standalone = text "a 'deriving' declaration" + | otherwise = text "the 'deriving' clause of a data type declaration" +ppr_br DefaultOrigin = text "a 'default' declaration" +ppr_br DoOrigin = text "a do statement" +ppr_br MCompOrigin = text "a statement in a monad comprehension" +ppr_br ProcOrigin = text "a proc expression" +ppr_br ArrowCmdOrigin = text "an arrow command" +ppr_br AnnOrigin = text "an annotation" +ppr_br (ExprHoleOrigin Nothing) = text "an expression hole" +ppr_br (ExprHoleOrigin (Just occ)) = text "a use of" <+> quotes (ppr occ) +ppr_br (TypeHoleOrigin occ) = text "a use of wildcard" <+> quotes (ppr occ) +ppr_br PatCheckOrigin = text "a pattern-match completeness check" +ppr_br ListOrigin = text "an overloaded list" +ppr_br IfThenElseOrigin = text "an if-then-else expression" +ppr_br StaticOrigin = text "a static form" +ppr_br (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)] +ppr_br (OmittedFieldOrigin Nothing) = text "an omitted anonymous field" +ppr_br (OmittedFieldOrigin (Just fl)) = hsep [text "omitted field" <+> quotes (ppr fl)] +ppr_br BracketOrigin = text "a quotation bracket" +ppr_br (ImplicitLiftOrigin isp) = text "an implicit lift of" <+> quotes (ppr (implicit_lift_lid isp)) + +-- These ones are handled by pprCtOrigin, but we nevertheless sometimes +-- we call pprCtOriginBriefly directly (e.g. in callStackOriginFS) +ppr_br (GivenOrigin {}) = text "a given constraint" +ppr_br (GivenSCOrigin {}) = text "the superclass of a given constraint" +ppr_br (SpecPragOrigin {}) = text "a SPECIALISE pragma" +ppr_br (FunDepOrigin1 {}) = text "a functional dependency" +ppr_br (FunDepOrigin2 {}) = text "a functional dependency" +ppr_br (InjTFOrigin1 {}) = text "an injective type family" +ppr_br (TypeEqOrigin {}) = text "a type equality" +ppr_br (KindEqOrigin {}) = text "a kind equality" +ppr_br (DerivOriginDC {}) = text "a deriving clause" +ppr_br (DerivOriginCoerce m _ _ _) = text "the coercion of derived method" <+> quotes (ppr m) +ppr_br (DoPatOrigin {}) = text "a do statement" +ppr_br (MCompPatOrigin {}) = text "a monad comprehension pattern" +ppr_br (Shouldn'tHappenOrigin note) = text note +ppr_br (ProvCtxtOrigin {}) = text "a provided constraint" +ppr_br (InstProvidedOrigin {}) = text "a provided constraint" +ppr_br (CycleBreakerOrigin orig) = ppr_br orig +ppr_br (FRROrigin {}) = text "a representation-polymorphism check" +ppr_br (WantedSuperclassOrigin {}) = text "a superclass constraint" +ppr_br (InstanceSigOrigin {}) = text "a type signature in an instance" +ppr_br (AmbiguityCheckOrigin {}) = text "a type ambiguity check" +ppr_br (ImpedanceMatching {}) = text "combining required constraints" +ppr_br (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)] + +pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc +pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear") +pprNonLinearPatternReason GeneralisedPatternReason = parens (text "non-variable pattern bindings that have been generalised aren't linear") +pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms aren't linear") +pprNonLinearPatternReason ViewPatternReason = parens (text "view patterns aren't linear") +pprNonLinearPatternReason OtherPatternReason = empty + + +{- ********************************************************************* +* * + CallStacks and CtOrigin + + See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +* * +********************************************************************* -} + +isPushCallStackOrigin_maybe :: CtOrigin -> Maybe FastString +-- Do we want to solve this IP constraint normally (return Nothing) +-- or push the call site (returning the name of the function being called) +-- See Note [Overview of implicit CallStacks] esp (CS1) in GHC.Tc.Types.Evidence +isPushCallStackOrigin_maybe (GivenOrigin {}) = Nothing +isPushCallStackOrigin_maybe (GivenSCOrigin {}) = Nothing +isPushCallStackOrigin_maybe (IPOccOrigin {}) = Nothing +isPushCallStackOrigin_maybe (OccurrenceOf fun) = Just (occNameFS (getOccName fun)) +isPushCallStackOrigin_maybe orig = Just orig_fs + -- This fall-through case is important to deal with call stacks + -- that arise from rebindable syntax (#19919) + -- Here the "name of the function being called" is approximated as + -- the result of prettty-printing the CtOrigin; a bit messy, + -- but we can perhaps improve it in the light of user feedback + where + orig_fs = mkFastString (showSDocUnsafe (pprCtOriginBriefly orig)) + +{- +************************************************************************ +* * + Checking for representation polymorphism +* * +************************************************************************ + +Note [Reporting representation-polymorphism errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete, +to check that (ty :: ki) has a fixed runtime representation, we emit +an equality constraint of the form + + ki ~# concrete_tv + +where concrete_tv is a concrete metavariable. In this situation, we attach +a 'FixedRuntimeRepOrigin' to both the equality and the concrete type variable. +The 'FixedRuntimeRepOrigin' consists of two pieces of information: + + - the type 'ty' on which we performed the representation-polymorphism check, + - a 'FixedRuntimeRepContext' which explains why we needed to perform a check + (e.g. because 'ty' was the kind of a function argument, or of a bound variable + in a lambda abstraction, ...). + +This information gets passed along as we make progress on solving the constraint, +and if we end up with an unsolved constraint we can report an informative error +message to the user using the 'FixedRuntimeRepOrigin'. + +The error reporting goes through two different paths: + + - constraints whose 'CtOrigin' contains a 'FixedRuntimeRepOrigin' are reported + using 'mkFRRErr' in 'reportWanteds', + - equality constraints in which one side is a concrete metavariable and the + other side is not concrete are reported using 'mkTyVarEqErr'. In this case, + we pass on the type variable and the non-concrete type for error reporting, + using the 'frr_info_not_concrete' field. + +This is why we have the 'FixedRuntimeRepErrorInfo' datatype: so that we can optionally +include this extra message about an unsolved equality between a concrete type variable +and a non-concrete type. +-} + +-- | The context for a representation-polymorphism check. +-- +-- For example, when typechecking @ \ (a :: k) -> ...@, +-- we are checking the type @a@ because it's the type of +-- a term variable bound in a lambda, so we use 'FRRBinder'. +data FixedRuntimeRepOrigin + = FixedRuntimeRepOrigin + { frr_type :: Type + -- ^ What type are we checking? + -- For example, @a[tau]@ in @a[tau] :: TYPE rr[tau]@. + + , frr_context :: FixedRuntimeRepContext + -- ^ What context requires a fixed runtime representation? + } + +instance Outputable FixedRuntimeRepOrigin where + ppr (FixedRuntimeRepOrigin { frr_type = ty, frr_context = cxt }) + = text "FrOrigin" <> braces (vcat [ text "frr_type:" <+> ppr ty + , text "frr_context:" <+> ppr cxt ]) + +-- | The context in which a representation-polymorphism check was performed. +-- +-- Does not include the type on which the check was performed; see +-- 'FixedRuntimeRepOrigin' for that. +data FixedRuntimeRepContext + + -- | Record fields in record construction must have a fixed runtime + -- representation. + = FRRRecordCon !RdrName !(HsExpr GhcTc) + + -- | Record fields in record updates must have a fixed runtime representation. + -- + -- Test case: RepPolyRecordUpdate. + | FRRRecordUpdate !Name !(HsExpr GhcRn) + + -- | Variable binders must have a fixed runtime representation. + -- + -- Test cases: LevPolyLet, RepPolyPatBind. + | FRRBinder !Name + + -- | Types appearing in negative position in the type of a + -- representation-polymorphic 'Id' must have a fixed runtime representation. + -- + -- This includes: + -- + -- - arguments, + -- + -- Test cases: RepPolyMagic, RepPolyRightSection, RepPolyWrappedVar, + -- T14561b, T17817. + -- + -- - continuation result types, such as in 'catch#', 'keepAlive#' + -- and 'control0#'. + -- + -- Test case: T21906. + | FRRRepPolyId + !Name + !RepPolyId + !(Position Neg) + + -- | A partial application of the constructor of a representation-polymorphic + -- unlifted newtype in which the argument type does not have a fixed + -- runtime representation. + -- + -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail. + | FRRRepPolyUnliftedNewtype !DataCon + + -- | Pattern binds must have a fixed runtime representation. + -- + -- Test case: RepPolyInferPatBind. + | FRRPatBind + + -- | Pattern synonym arguments must have a fixed runtime representation. + -- + -- Test case: RepPolyInferPatSyn. + | FRRPatSynArg + + -- | The type of the scrutinee in a case statement must have a + -- fixed runtime representation. + -- + -- Test cases: RepPolyCase{1,2}. + | FRRCase + + -- | An instantiation of a newtype/data constructor pattern in which + -- an argument type does not have a fixed runtime representation. + -- + -- Test case: T20363. + | FRRDataConPatArg !DataCon !Int + + -- | The 'RuntimeRep' arguments to unboxed tuples must be concrete 'RuntimeRep's. + -- + -- Test case: RepPolyTuple. + | FRRUnboxedTuple !Int + + -- | Tuple sections must have a fixed runtime representation. + -- + -- Test case: RepPolyTupleSection. + | FRRUnboxedTupleSection !Int + + -- | The 'RuntimeRep' arguments to unboxed sums must be concrete 'RuntimeRep's. + -- + -- Test cases: RepPolySum. + | FRRUnboxedSum !(Maybe Int) + + -- | The body of a @do@ expression or a monad comprehension must + -- have a fixed runtime representation. + -- + -- Test cases: RepPolyDoBody{1,2}, RepPolyMcBody. + | FRRBodyStmt !StmtOrigin !Int + + -- | Arguments to a guard in a monad comprehension must have + -- a fixed runtime representation. + -- + -- Test case: RepPolyMcGuard. + | FRRBodyStmtGuard + + -- | Arguments to `(>>=)` arising from a @do@ expression + -- or a monad comprehension must have a fixed runtime representation. + -- + -- Test cases: RepPolyDoBind, RepPolyMcBind. + | FRRBindStmt !StmtOrigin + + -- | A value bound by a pattern guard must have a fixed runtime representation. + -- + -- Test cases: none. + | FRRBindStmtGuard + + -- | A representation-polymorphism check arising from arrow notation. + -- + -- See 'FRRArrowContext' for more details. + | FRRArrow !FRRArrowContext + + -- | A representation-polymorphism check arising from a call + -- to 'matchExpectedFunTys' or 'matchActualFunTy'. + -- + -- See 'ExpectedFunTyOrigin' for more details. + | FRRExpectedFunTy + !ExpectedFunTyOrigin + !Int + -- ^ argument position (1-indexed) + + -- | A representation-polymorphism check arising from eta-expansion + -- performed as part of deep subsumption. + | forall p. FRRDeepSubsumption + { frrDSExpected :: Bool + , frrDSPosition :: Position p + } + +-- | The description of a representation-polymorphic 'Id'. +data RepPolyId + -- | A representation-polymorphic 'PrimOp'. + = RepPolyPrimOp + -- | An unboxed tuple constructor. + | RepPolyTuple + -- | An unboxed sum constructor. + | RepPolySum + -- | An unspecified representation-polymorphic function, + -- e.g. a pseudo-op such as 'coerce'. + | RepPolyFunction + +-- | A synonym for 'FRRUnboxedTuple' exposed in the hs-boot file +-- for "GHC.Tc.Types.Origin". +mkFRRUnboxedTuple :: Int -> FixedRuntimeRepContext +mkFRRUnboxedTuple = FRRUnboxedTuple + +-- | A synonym for 'FRRUnboxedSum' exposed in the hs-boot file +-- for "GHC.Tc.Types.Origin". +mkFRRUnboxedSum :: Maybe Int -> FixedRuntimeRepContext +mkFRRUnboxedSum = FRRUnboxedSum + +-- | Print the context for a @FixedRuntimeRep@ representation-polymorphism check. +-- +-- Note that this function does not include the specific 'RuntimeRep' +-- which is not fixed. That information is stored in 'FixedRuntimeRepOrigin' +-- and is reported separately. +pprFixedRuntimeRepContext :: FixedRuntimeRepContext -> SDoc +pprFixedRuntimeRepContext (FRRRecordCon lbl _arg) + = sep [ text "The field", quotes (ppr lbl) + , text "of the record constructor" ] +pprFixedRuntimeRepContext (FRRRecordUpdate lbl _arg) + = sep [ text "The record update at field" + , quotes (ppr lbl) ] +pprFixedRuntimeRepContext (FRRBinder binder) + = sep [ text "The binder" + , quotes (ppr binder) ] +pprFixedRuntimeRepContext (FRRRepPolyId nm id pos) + = text "The" <+> ppr pos <+> text "of" <+> pprRepPolyId id nm +pprFixedRuntimeRepContext FRRPatBind + = text "The pattern binding" +pprFixedRuntimeRepContext FRRPatSynArg + = text "The pattern synonym argument pattern" +pprFixedRuntimeRepContext FRRCase + = text "The scrutinee of the case statement" +pprFixedRuntimeRepContext (FRRDataConPatArg con i) + = text "The" <+> what + where + what :: SDoc + what + | isNewDataCon con + = text "newtype constructor pattern" + | otherwise + = text "data constructor pattern in" <+> speakNth i <+> text "position" +pprFixedRuntimeRepContext (FRRRepPolyUnliftedNewtype dc) + = vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype." + , text "The argument of the newtype constructor" <+> quotes (ppr dc) ] +pprFixedRuntimeRepContext (FRRUnboxedTuple i) + = text "The" <+> speakNth i <+> text "component of the unboxed tuple" +pprFixedRuntimeRepContext (FRRUnboxedTupleSection i) + = text "The" <+> speakNth i <+> text "component of the unboxed tuple section" +pprFixedRuntimeRepContext (FRRUnboxedSum Nothing) + = text "The unboxed sum" +pprFixedRuntimeRepContext (FRRUnboxedSum (Just i)) + = text "The" <+> speakNth i <+> text "component of the unboxed sum" +pprFixedRuntimeRepContext (FRRBodyStmt stmtOrig i) + = vcat [ text "The" <+> speakNth i <+> text "argument to (>>)" <> comma + , text "arising from the" <+> ppr stmtOrig <> comma ] +pprFixedRuntimeRepContext FRRBodyStmtGuard + = vcat [ text "The argument to" <+> quotes (text "guard") <> comma + , text "arising from the" <+> ppr MonadComprehension <> comma ] +pprFixedRuntimeRepContext (FRRBindStmt stmtOrig) + = vcat [ text "The first argument to (>>=)" <> comma + , text "arising from the" <+> ppr stmtOrig <> comma ] +pprFixedRuntimeRepContext FRRBindStmtGuard + = sep [ text "The body of the bind statement" ] +pprFixedRuntimeRepContext (FRRArrow arrowContext) + = pprFRRArrowContext arrowContext +pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig arg_pos) + = pprExpectedFunTyOrigin funTyOrig arg_pos +pprFixedRuntimeRepContext (FRRDeepSubsumption is_exp pos) + = hsep [ text "The", what, text "type of the" + , ppr (Argument pos) + , text "of the eta-expansion" + ] + where + what = if is_exp then text "expected" else text "actual" + +instance Outputable FixedRuntimeRepContext where + ppr = pprFixedRuntimeRepContext + +-- | Are we in a @do@ expression or a monad comprehension? +-- +-- This datatype is only used to report this context to the user in error messages. +data StmtOrigin + = MonadComprehension + | DoNotation + +instance Outputable StmtOrigin where + ppr MonadComprehension = text "monad comprehension" + ppr DoNotation = quotes ( text "do" ) <+> text "statement" + +-- | The position of an argument (to be reported in an error message). +data ArgPos + = ArgPosInvis + -- ^ Invisible argument: don't report its position to the user. + | ArgPosVis !Int + -- ^ Visible argument in i-th position. + +{- ********************************************************************* +* * + FixedRuntimeRep: representation-polymorphic Ids +* * +********************************************************************* -} + +{- Note [Positional information in representation-polymorphism errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider an invalid instantiation of the 'catch#' primop: + + catch# + :: forall {q :: RuntimeRep} {k :: Levity} (a :: TYPE q) + (b :: TYPE (BoxedRep k)). + (State# RealWorld -> (# State# RealWorld, a #)) + -> (b -> State# RealWorld -> (# State# RealWorld, a #)) + -> State# RealWorld + -> (# State# RealWorld, a #) + + boo :: forall r (a :: TYPE r). ... + boo = catch# @a + +The instantiation is invalid because we insist that the quantified RuntimeRep +type variable 'q' be instantiated to a concrete RuntimeRep, as per +Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete. + +We report this as the following error message: + + The result of the first argument of the primop ‘catch#’ does not have a fixed runtime representation. + Its type is: (a :: TYPE r). + +The positional information in this message, namely "The result of the first argument", +is produced by using the 'Position' datatype. In this case: + + pos :: Position Neg + pos = Result (Argument Top) + ppr pos = "result of the first argument" + +Other examples: + + pos2 :: Position Neg + pos2 = Argument (Result (Result Top)) + ppr pos2 = "3rd argument" + + pos3 :: Position Pos + pos3 = Argument (Result (Argument (Result Top))) + ppr pos3 = "2nd argument of the 2nd argument" + +It's useful to keep track at the type-level whether we are in a positive or +negative position in the type, as for primops we can usually tolerate +representation-polymorphism in positive positions, but not in negative ones; +for example + + ($) :: forall {r} (a :: Type) (b :: TYPE r). (a -> b) -> a -> b + + +This positional information is (currently) used to report representation-polymorphism +errors in precisely the following two situations: + + 1. Representation-polymorphic Ids with no binding, as described in + Note [Representation-polymorphic Ids with no binding] in GHC.Tc.Utils.Concrete. + + This uses the 'FRRRepPolyId' constructor of 'FixedRuntimeRepContext'. + + 2. When inserting eta-expansions for deep subsumption. + See Wrinkle [Representation-polymorphism checking during subtyping] in + Note [FunTy vs FunTy case in tc_sub_type_deep] in GHC.Tc.Utils.Unify. + + This uses the 'FRRDeepSubsumption' constructor of 'FixedRuntimeRepContext'. +-} + +-- | Are we in a positive (covariant) or negative (contravariant) position? +-- +-- See Note [Positional information in representation-polymorphism errors]. +data Polarity = Pos | Neg + +-- | Flip the 'Polarity': turn positive into negative and vice-versa. +type FlipPolarity :: Polarity -> Polarity +type family FlipPolarity p = r | r -> p where + FlipPolarity Pos = Neg + FlipPolarity Neg = Pos + +-- | A position in which a type variable appears in a type; +-- in particular, whether it appears in a positive or a negative position. +-- +-- See Note [Positional information in representation-polymorphism errors]. +type Position :: Polarity -> Hs.Type +data Position p where + -- | In the argument of a function arrow + Argument :: Position p -> Position (FlipPolarity p) + -- | In the result of a function arrow + Result :: Position p -> Position p + -- | At the top level of a type + Top :: Position Pos +deriving stock instance Show (Position p) +instance Outputable (Position p) where + ppr = go 1 + where + go :: Int -> Position q -> SDoc + go i (Argument (Result pos)) = go (i+1) (Argument pos) + go i (Argument pos) = speakNth i <+> text "argument" <+> aux 1 pos + go i (Result (Result pos)) = go i (Result pos) + go i (Result pos) = text "result" <+> aux i pos + go _ Top = text "top-level" + + aux :: Int -> Position q -> SDoc + aux i pos = case pos of { Top -> empty; _ -> text "of the" <+> go i pos } + +-- | @'mkArgPos' i p@ makes the 'Position' @p@ relative to the @ith@ argument. +-- +-- Example: @ppr (mkArgPos 3 (Result Top)) == "in the result of the 3rd argument"@. +mkArgPos :: Int -> Position p -> Position (FlipPolarity p) +mkArgPos i = go + where + go :: Position p -> Position (FlipPolarity p) + go Top = Argument $ nTimes (i-1) Result Top + go (Result p) = Result $ go p + go (Argument p) = Argument $ go p + +pprRepPolyId :: RepPolyId -> Name -> SDoc +pprRepPolyId id nm = id_desc <+> quotes (ppr nm) + where + id_desc = case id of + RepPolyPrimOp {} -> text "the primop" + RepPolySum {} -> text "the unboxed sum constructor" + RepPolyTuple {} -> text "the unboxed tuple constructor" + RepPolyFunction {} -> empty + +{- ********************************************************************* +* * + FixedRuntimeRep: arrows +* * +********************************************************************* -} + +-- | While typechecking arrow notation, in which context +-- did a representation polymorphism check arise? +-- +-- See 'FixedRuntimeRepContext' for more general origins of +-- representation polymorphism checks. +data FRRArrowContext + + -- | The result of an arrow command does not have a fixed runtime representation. + -- + -- Test case: RepPolyArrowCmd. + = ArrowCmdResTy !(HsCmd GhcRn) + + -- | The argument to an arrow in an arrow command application does not have + -- a fixed runtime representation. + -- + -- Test cases: none. + | ArrowCmdApp !(HsCmd GhcRn) !(HsExpr GhcRn) + + -- | A function in an arrow application does not have + -- a fixed runtime representation. + -- + -- Test cases: none. + | ArrowCmdArrApp !(HsExpr GhcRn) !(HsExpr GhcRn) !HsArrAppType + + -- | The scrutinee type in an arrow command case statement does not have a + -- fixed runtime representation. + -- + -- Test cases: none. + | ArrowCmdCase + + -- | The overall type of an arrow proc expression does not have + -- a fixed runtime representation. + -- + -- Test case: RepPolyArrowFun. + | ArrowFun !(HsExpr GhcRn) + +pprFRRArrowContext :: FRRArrowContext -> SDoc +pprFRRArrowContext (ArrowCmdResTy cmd) + = vcat [ hang (text "The arrow command") 2 (quotes (ppr cmd)) ] +pprFRRArrowContext (ArrowCmdApp fun arg) + = vcat [ text "The argument in the arrow command application of" + , nest 2 (quotes (ppr fun)) + , text "to" + , nest 2 (quotes (ppr arg)) ] +pprFRRArrowContext (ArrowCmdArrApp fun arg ho_app) + = vcat [ text "The function in the" <+> pprHsArrType ho_app <+> text "of" + , nest 2 (quotes (ppr fun)) + , text "to" + , nest 2 (quotes (ppr arg)) ] +pprFRRArrowContext ArrowCmdCase + = text "The scrutinee of the arrow case command" +pprFRRArrowContext (ArrowFun fun) + = vcat [ text "The return type of the arrow function" + , nest 2 (quotes (ppr fun)) ] + +instance Outputable FRRArrowContext where + ppr = pprFRRArrowContext + +{- ********************************************************************* +* * + FixedRuntimeRep: ExpectedFunTy origin +* * +********************************************************************* -} + +-- | In what context are we calling 'matchExpectedFunTys' +-- or 'matchActualFunTy'? +-- +-- Used for two things: +-- +-- 1. Reporting error messages which explain that a function has been +-- given an unexpected number of arguments. +-- Uses 'pprExpectedFunTyHerald'. +-- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify. +-- +-- 2. Reporting representation-polymorphism errors when a function argument +-- doesn't have a fixed RuntimeRep as per Note [Fixed RuntimeRep] +-- in GHC.Tc.Utils.Concrete. +-- Uses 'pprExpectedFunTyOrigin'. +-- See 'FixedRuntimeRepContext' for the situations in which +-- representation-polymorphism checks are performed. +data ExpectedFunTyOrigin + + -- | A rebindable syntax operator is expected to have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK + = forall (p :: Pass) + . (OutputableBndrId p) + => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p)) + -- ^ rebindable syntax operator + + -- | A view pattern must have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder + | ExpectedFunTyViewPat + !(HsExpr GhcRn) + -- ^ function used in the view pattern + + -- | Need to be able to extract an argument type from a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyApp + | forall (p :: Pass) + . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg + !TypedThing + -- ^ function + !(HsExpr (GhcPass p)) + -- ^ argument + + -- | Ensure that a function defined by equations indeed has a function type + -- with the appropriate number of arguments. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern + | ExpectedFunTyMatches + !TypedThing + -- ^ name of the function + !(MatchGroup GhcRn (LHsExpr GhcRn)) + -- ^ equations + + -- | Ensure that a lambda abstraction has a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyLambda, RepPolyMatch + | ExpectedFunTyLam HsLamVariant + !(HsExpr GhcRn) + -- ^ the entire lambda-case expression + +pprExpectedFunTyOrigin :: ExpectedFunTyOrigin + -> Int -- ^ argument position (starting at 1) + -> SDoc +pprExpectedFunTyOrigin funTy_origin i = + case funTy_origin of + ExpectedFunTySyntaxOp orig op -> + vcat [ sep [ the_arg_of + , text "the rebindable syntax operator" + , quotes (ppr op) ] + , nest 2 (ppr orig) ] + ExpectedFunTyViewPat expr -> + vcat [ the_arg_of <+> text "the view pattern" + , nest 2 (ppr expr) ] + ExpectedFunTyArg fun arg -> + sep [ text "The argument" + , quotes (ppr arg) + , text "of" + , quotes (ppr fun) ] + ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }) + | null alts + -> the_arg_of <+> quotes (ppr fun) + | otherwise + -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts + <+> text "for" <+> quotes (ppr fun) + ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant + where + the_arg_of :: SDoc + the_arg_of = text "The" <+> speakNth i <+> text "argument of" + + binder_of :: SDoc -> SDoc + binder_of what = text "The binder of the" <+> what <+> text "expression" + +pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc +pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {}) + = text "This rebindable syntax expects a function with" +pprExpectedFunTyHerald (ExpectedFunTyViewPat {}) + = text "A view pattern expression expects" +pprExpectedFunTyHerald (ExpectedFunTyArg fun _) + = sep [ text "The function" <+> quotes (ppr fun) + , text "is applied to" ] +pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })) + = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts +pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr) + = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression" + <+> quotes (pprSetDepth (PartWay 1) (ppr expr)) + -- The pprSetDepth makes the lambda abstraction print briefly + , text "has" ] + +{- ******************************************************************* +* * + InstanceWhat +* * +**********************************************************************-} + +-- | Indicates if Instance met the Safe Haskell overlapping instances safety +-- check. +-- +-- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +type SafeOverlapping = Bool + +data 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-levelled 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 + , iw_warn :: Maybe (WarningTxt GhcRn) } + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict + +instance Outputable InstanceWhat where + ppr BuiltinInstance = text "a built-in instance" + ppr BuiltinTypeableInstance {} = text "a built-in typeable instance" + ppr BuiltinEqInstance = text "a built-in equality instance" + ppr LocalInstance = text "a locally-quantified instance" + ppr (TopLevInstance { iw_dfun_id = dfun }) + = hang (text "instance" <+> pprSigmaType (idType dfun)) + 2 (text "--" <+> pprDefinedAt (idName dfun)) diff --git a/GHC/Tc/Types/Origin.hs-boot b/GHC/Tc/Types/Origin.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/Origin.hs-boot @@ -0,0 +1,19 @@ +module GHC.Tc.Types.Origin where + +import GHC.Prelude.Basic ( Int, Maybe ) +import GHC.Utils.Misc ( HasDebugCallStack ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) + +data SkolemInfoAnon +data SkolemInfo +data FixedRuntimeRepContext +data FixedRuntimeRepOrigin + = FixedRuntimeRepOrigin + { frr_type :: Type + , frr_context :: FixedRuntimeRepContext + } + +mkFRRUnboxedTuple :: Int -> FixedRuntimeRepContext +mkFRRUnboxedSum :: Maybe Int -> FixedRuntimeRepContext + +unkSkol :: HasDebugCallStack => SkolemInfo diff --git a/GHC/Tc/Types/Rank.hs b/GHC/Tc/Types/Rank.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/Rank.hs @@ -0,0 +1,40 @@ +module GHC.Tc.Types.Rank (Rank(..)) where + +import GHC.Base (Bool) +import GHC.Utils.Outputable (Outputable, (<+>), parens, ppr, text) + +{- +Note [Higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~ +Technically + Int -> forall a. a->a +is still a rank-1 type, but it's not Haskell 98 (#5957). So the +validity checker allow a forall after an arrow only if we allow it +before -- that is, with Rank2Types or RankNTypes +-} + +data Rank = ArbitraryRank -- Any rank ok + + | LimitedRank -- Note [Higher rank types] + Bool -- Forall ok at top + Rank -- Use for function arguments + + -- Monotypes that could be a polytype through an extension + | MonoTypeRankZero -- RankNTypes + | MonoTypeTyConArg -- ImpredicativeTypes + | MonoTypeSynArg -- LiberalTypeSynonyms + | MonoTypeConstraint -- QuantifiedConstraints + -- + + | MustBeMonoType -- Monotype regardless of flags + +instance Outputable Rank where + ppr ArbitraryRank = text "ArbitraryRank" + ppr (LimitedRank top_forall_ok r) + = text "LimitedRank" <+> ppr top_forall_ok + <+> parens (ppr r) + ppr MonoTypeRankZero = text "MonoTypeRankZero" + ppr MonoTypeTyConArg = text "MonoTypeTyConArg" + ppr MonoTypeSynArg = text "MonoTypeSynArg" + ppr MonoTypeConstraint = text "MonoTypeConstraint" + ppr MustBeMonoType = text "MustBeMonoType" diff --git a/GHC/Tc/Types/TH.hs b/GHC/Tc/Types/TH.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/TH.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +module GHC.Tc.Types.TH ( + SpliceType(..) + , SpliceOrBracket(..) + , ThLevel(.., TypedBrack, UntypedBrack) + , PendingStuff(..) + , ThLevelIndex + , topLevel + , topAnnLevel + , topSpliceLevel + , thLevelIndex + , topLevelIndex + , spliceLevelIndex + , quoteLevelIndex + , thLevelIndexFromImportLevel + ) where + +import GHC.Prelude +import GHCi.RemoteTypes +import qualified GHC.Boot.TH.Syntax as TH +import GHC.Tc.Types.Evidence +import GHC.Utils.Outputable +import GHC.Tc.Types.TcRef +import GHC.Tc.Types.Constraint +import GHC.Hs.Expr ( PendingTcSplice, PendingRnSplice ) +import GHC.Types.ThLevelIndex + +--------------------------- +-- Template Haskell stages and levels +--------------------------- + +data SpliceType = Typed | Untyped +data SpliceOrBracket = IsSplice | IsBracket + +data ThLevel -- See Note [Template Haskell state diagram] + -- and Note [Template Haskell levels] in GHC.Tc.Gen.Splice + -- Start at: Comp + -- At bracket: wrap current stage in Brack + -- At splice: wrap current stage in Splice + = Splice SpliceType ThLevel -- Inside a splice + + | RunSplice (TcRef [ForeignRef (TH.Q ())]) + -- Set when running a splice, i.e. NOT when renaming or typechecking the + -- Haskell code for the splice. See Note [RunSplice ThLevel]. + -- + -- Contains a list of mod finalizers collected while executing the splice. + -- + -- 'addModFinalizer' inserts finalizers here, and from here they are taken + -- to construct an @HsSpliced@ annotation for untyped splices. See Note + -- [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. + -- + -- For typed splices, the typechecker takes finalizers from here and + -- inserts them in the list of finalizers in the global environment. + -- + -- See Note [Collecting modFinalizers in typed splices] in "GHC.Tc.Gen.Splice". + + | Comp -- Ordinary Haskell code + -- Binding level = 0 + + | Brack -- Inside brackets + ThLevel -- Enclosing level + PendingStuff + +data PendingStuff + = RnPending -- Renaming the inside of a bracket + (TcRef [PendingRnSplice]) -- Pending splices in here + + | RnPendingTyped -- Renaming the inside of a *typed* bracket + + | TcPending -- Typechecking the inside of a typed bracket + (TcRef [PendingTcSplice]) -- Accumulate pending splices here + (TcRef WantedConstraints) -- and type constraints here + QuoteWrapper -- A type variable and evidence variable + -- for the overall monad of + -- the bracket. Splices are checked + -- against this monad. The evidence + -- variable is used for desugaring + -- `lift`. + +isTypedPending :: PendingStuff -> Bool +isTypedPending (RnPending _) = False +isTypedPending (RnPendingTyped) = True +isTypedPending (TcPending _ _ _) = True + +pattern UntypedBrack :: ThLevel -> TcRef [PendingRnSplice] -> ThLevel +pattern UntypedBrack lvl tc_ref = Brack lvl (RnPending tc_ref) +pattern TypedBrack :: ThLevel -> ThLevel +pattern TypedBrack lvl <- Brack lvl (isTypedPending -> True) + +topLevel, topAnnLevel, topSpliceLevel :: ThLevel +topLevel = Comp +topAnnLevel = Splice Untyped Comp +topSpliceLevel = Splice Untyped Comp + + +instance Outputable ThLevel where + ppr (Splice _ s) = text "Splice" <> parens (ppr s) + ppr (RunSplice _) = text "RunSplice" + ppr Comp = text "Comp" + ppr (Brack s _) = text "Brack" <> parens (ppr s) + + +thLevelIndex :: ThLevel -> ThLevelIndex +thLevelIndex (Splice _ s) = decThLevelIndex (thLevelIndex s) +thLevelIndex Comp = topLevelIndex +thLevelIndex (Brack s _) = incThLevelIndex (thLevelIndex s) +thLevelIndex (RunSplice _) = thLevelIndex (Splice Untyped Comp) -- previously: panic "thLevel: called when running a splice" + -- See Note [RunSplice ThLevel]. + + +{- Note [RunSplice ThLevel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'RunSplice' level is set when executing a splice, and only when running a +splice. In particular it is not set when the splice is renamed or typechecked. + +However, this is not true. `reifyInstances` for example does rename the given type, +and these types may contain variables (#9262 allow free variables in reifyInstances). +Therefore here we assume that thLevel (RunSplice _) = 0 +Proper fix would probably require renaming argument `reifyInstances` separately prior +to evaluation of the overall splice. + +'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert +the finalizer (see Note [Delaying modFinalizers in untyped splices]), and +'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to +set 'RunSplice' when renaming or typechecking the splice, where 'Splice', +'Brack' or 'Comp' are used instead. + +-} + diff --git a/GHC/Tc/Types/TcRef.hs b/GHC/Tc/Types/TcRef.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/TcRef.hs @@ -0,0 +1,37 @@ +module GHC.Tc.Types.TcRef (TcRef, newTcRef, readTcRef, writeTcRef, updTcRef, updTcRefM) where + +import GHC.Prelude + +import Control.Monad.IO.Class +import Data.IORef + +-- | Type alias for 'IORef'; the convention is we'll use this for mutable +-- bits of data in the typechecker which are updated during typechecking and +-- returned at the end. +type TcRef a = IORef a + +-- The following functions are all marked INLINE so that we +-- don't end up passing a Monad or MonadIO dictionary. + +newTcRef :: MonadIO m => a -> m (TcRef a) +newTcRef = \ a -> liftIO $ newIORef a +{-# INLINE newTcRef #-} + +readTcRef :: MonadIO m => TcRef a -> m a +readTcRef = \ ref -> liftIO $ readIORef ref +{-# INLINE readTcRef #-} + +writeTcRef :: MonadIO m => TcRef a -> a -> m () +writeTcRef = \ ref a -> liftIO $ writeIORef ref a +{-# INLINE writeTcRef #-} + +updTcRef :: MonadIO m => TcRef a -> (a -> a) -> m () +updTcRef = \ ref fn -> liftIO $ modifyIORef' ref fn +{-# INLINE updTcRef #-} + +updTcRefM :: MonadIO m => TcRef a -> (a -> m a) -> m () +updTcRefM ref upd + = do { contents <- readTcRef ref + ; !new_contents <- upd contents + ; writeTcRef ref new_contents } +{-# INLINE updTcRefM #-} diff --git a/GHC/Tc/Utils/Backpack.hs b/GHC/Tc/Utils/Backpack.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Backpack.hs @@ -0,0 +1,1023 @@ + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Utils.Backpack ( + findExtraSigImports, + implicitRequirements, + implicitRequirementsShallow, + checkUnit, + tcRnCheckUnit, + tcRnMergeSignatures, + mergeSignatures, + tcRnInstantiateSignature, + instantiateSignature, +) where + +import GHC.Prelude + + +import GHC.Driver.Env +import GHC.Driver.Ppr +import GHC.Driver.DynFlags + +import GHC.Types.Basic (TypeOrKind(..)) +import GHC.Types.Fixity (defaultFixity) +import GHC.Types.Fixity.Env +import GHC.Types.TypeEnv +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import GHC.Types.Var +import GHC.Types.Id( idType ) +import GHC.Types.Unique.DSet +import GHC.Types.Name.Shape +import GHC.Types.PkgQual + +import GHC.Unit +import GHC.Unit.Finder +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.Imported +import GHC.Unit.Module.Deps + +import GHC.Tc.Errors +import GHC.Tc.Errors.Types +import {-# SOURCE #-} GHC.Tc.Module +import GHC.Tc.Gen.Export +import GHC.Tc.Solver +import GHC.Tc.TyCl.Utils +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( mkGivenLoc ) +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType + +import GHC.Hs + +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv + +import GHC.IfaceToCore +import GHC.Iface.Load +import GHC.Iface.Rename +import GHC.Iface.Syntax + +import GHC.Rename.Names +import GHC.Rename.Fixity ( lookupFixityRn ) + +import GHC.Utils.Error +import GHC.Utils.Misc ( HasDebugCallStack ) +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.FastString +import GHC.Data.Maybe + +import Control.Monad +import Data.List (find) + +import GHC.Iface.Errors.Types +import Data.Function ((&)) + +checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn () +checkHsigDeclM sig_iface sig_thing real_thing = do + let name = getName real_thing + -- TODO: Distinguish between signature merging and signature + -- implementation cases. + checkBootDeclM Hsig sig_thing real_thing + real_fixity <- lookupFixityRn name + let sig_fixity = case mi_fix_fn sig_iface (occName name) of + Nothing -> defaultFixity + Just f -> f + when (real_fixity /= sig_fixity) $ + addErrAt (nameSrcSpan name) + (TcRnHsigFixityMismatch real_thing real_fixity sig_fixity) + +-- | Given a 'ModDetails' of an instantiated signature (note that the +-- 'ModDetails' must be knot-tied consistently with the actual implementation) +-- and a 'GlobalRdrEnv' constructed from the implementor of this interface, +-- verify that the actual implementation actually matches the original +-- interface. +-- +-- Note that it is already assumed that the implementation *exports* +-- a sufficient set of entities, since otherwise the renaming and then +-- typechecking of the signature 'ModIface' would have failed. +checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn () +checkHsigIface tcg_env gre_env sig_iface + ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, + md_types = sig_type_env, md_exports = sig_exports } = do + traceTc "checkHsigIface" $ vcat + [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] + mapM_ check_export (map availName sig_exports) + failIfErrsM -- See Note [Fail before checking instances in checkHsigIface] + unless (null sig_fam_insts) $ + panic ("GHC.Tc.Utils.Backpack.checkHsigIface: " ++ + "Cannot handle family instances in hsig files yet...") + -- Delete instances so we don't look them up when + -- checking instance satisfiability + -- TODO: this should not be necessary + tcg_env <- getGblEnv + setGblEnv tcg_env { tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, + tcg_insts = [], + tcg_fam_insts = [] } $ do + mapM_ check_inst (instEnvElts sig_insts) + failIfErrsM + where + -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig + -- in package p that defines T; and we implement with himpl:H. Then the + -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just + -- have to look up the right name. + sig_type_occ_env = mkOccEnv + . map (\t -> (nameOccName (getName t), t)) + $ nonDetNameEnvElts sig_type_env + dfun_names = map getName (instEnvElts sig_insts) + check_export name + -- Skip instances, we'll check them later + -- TODO: Actually this should never happen, because DFuns are + -- never exported... + | name `elem` dfun_names = return () + -- See if we can find the type directly in the hsig ModDetails + -- TODO: need to special case wired in names + | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do + -- NB: We use tcLookupImported_maybe because we want to EXCLUDE + -- tcg_env (TODO: but maybe this isn't relevant anymore). + r <- tcLookupImported_maybe name + case r of + Failed err -> addErr (TcRnInterfaceError err) + Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing + + -- The hsig did NOT define this function; that means it must + -- be a reexport. In this case, make sure the 'Name' of the + -- reexport matches the 'Name' exported here. + | [gre] <- lookupGRE gre_env (LookupOccName (nameOccName name) SameNameSpace) = do + let name' = greName gre + when (name /= name') $ do + -- See Note [Error reporting bad reexport] + -- TODO: Actually this error swizzle doesn't work + let p (L _ ie) = name `elem` ieNames ie + loc = case tcg_rn_exports tcg_env of + Just es | Just e <- find p (map fst es) + -- TODO: maybe we can be a little more + -- precise here and use the Located + -- info for the *specific* name we matched. + -> getLocA e + _ -> nameSrcSpan name + addErrAt loc + (TcRnBootMismatch Hsig $ BadReexportedBootThing name name') + -- This should actually never happen, but whatever... + | otherwise = + addErrAt (nameSrcSpan name) + (missingBootThing Hsig name MissingBootExport) + +-- Note [Fail before checking instances in checkHsigIface] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We need to be careful about failing before checking instances if there happens +-- to be an error in the exports. +-- Otherwise, we might proceed with typechecking (and subsequently panic-ing) on +-- ill-kinded types that are constructed while checking instances. +-- This lead to #19244 + +-- Note [Error reporting bad reexport] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- NB: You want to be a bit careful about what location you report on reexports. +-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the +-- correct source location. However, if it was *reexported*, obviously the name +-- is not going to have the right location. In this case, we need to grovel in +-- tcg_rn_exports to figure out where the reexport came from. + + + +-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't +-- assume that the implementing file actually implemented the instances (they +-- may be reexported from elsewhere). Where should we look for the instances? +-- We do the same as we would otherwise: consult the EPS. This isn't perfect +-- (we might conclude the module exports an instance when it doesn't, see +-- #9422), but we will never refuse to compile something. +check_inst :: ClsInst -> TcM () +check_inst sig_inst@(ClsInst { is_dfun = dfun_id }) = do + -- TODO: This could be very well generalized to support instance + -- declarations in boot files. + tcg_env <- getGblEnv + lcl_env <- getLclEnv + + -- NB: Have to tug on the interface, not necessarily + -- tugged... but it didn't work? + mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst)) + + -- Based off of 'simplifyDeriv' + (skol_info, tvs_skols, inst_theta, cls, inst_tys) <- tcSkolDFunType (idType dfun_id) + (tclvl,cts) <- pushTcLevelM $ do + given_ids <- mapM newEvVar inst_theta + let given_loc = mkGivenLoc topTcLevel skol_info (mkCtLocEnv lcl_env) + givens = [ CtGiven $ + GivenCt { ctev_pred = idType given_id + -- Doesn't matter, make something up + , ctev_evar = given_id + , ctev_loc = given_loc } + | given_id <- given_ids ] + origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst + wanted <- newWanted origin (Just TypeLevel) (mkClassPred cls inst_tys) + return (wanted : givens) + unsolved <- simplifyWantedsTcM cts + + (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved + reportAllUnsolved (mkImplicWC implic) + +-- | For a module @modname@ of type 'HscSource', determine the list +-- of extra "imports" of other requirements which should be considered part of +-- the import of the requirement, because it transitively depends on those +-- requirements by imports of modules from other packages. The situation +-- is something like this: +-- +-- unit p where +-- signature X +-- signature Y +-- import X +-- +-- unit q where +-- dependency p[X=\,Y=\] +-- signature A +-- signature B +-- +-- Although q's B does not directly import A, we still have to make sure we +-- process A first, because the merging process will cause B to indirectly +-- import A. This function finds the TRANSITIVE closure of all such imports +-- we need to make. +findExtraSigImports :: HscEnv + -> HscSource + -> ModuleName + -> IO [ModuleName] +findExtraSigImports hsc_env HsigFile modname = do + let + dflags = hsc_dflags hsc_env + ctx = initSDocContext dflags defaultUserStyle + unit_state = hsc_units hsc_env + reqs = requirementMerges unit_state modname + holes <- forM reqs $ \(Module iuid mod_name) -> do + initIfaceLoad hsc_env + . withIfaceErr ctx + $ moduleFreeHolesPrecise (text "findExtraSigImports") + (mkModule (VirtUnit iuid) mod_name) + return (uniqDSetToList (unionManyUniqDSets holes)) + +findExtraSigImports _ _ _ = return [] + +-- Given a list of 'import M' statements in a module, figure out +-- any extra implicit requirement imports they may have. For +-- example, if they 'import M' and M resolves to p[A=,C=D], then +-- they actually also import the local requirement B. +implicitRequirements :: HscEnv + -> [(PkgQual, Located ModuleName)] + -> IO [ModuleName] +implicitRequirements hsc_env normal_imports + = fmap concat $ + forM normal_imports $ \(mb_pkg, L _ imp) -> do + found <- findImportedModule hsc_env imp mb_pkg + case found of + Found _ mod | notHomeModuleMaybe mhome_unit mod -> + return (uniqDSetToList (moduleFreeHoles mod)) + _ -> return [] + where + mhome_unit = hsc_home_unit_maybe hsc_env + +-- | Like @implicitRequirements'@, but returns either the module name, if it is +-- a free hole, or the instantiated unit the imported module is from, so that +-- that instantiated unit can be processed and via the batch mod graph (rather +-- than a transitive closure done here) all the free holes are still reachable. +implicitRequirementsShallow + :: HscEnv + -> [(ImportLevel, 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) ((_stage, mb_pkg, L _ imp):imports) = do + found <- findImportedModule hsc_env imp mb_pkg + let acc' = case found of + Found _ mod | notHomeModuleMaybe mhome_unit mod -> + case moduleUnit mod of + HoleUnit -> (moduleName mod : accL, accR) + RealUnit _ -> (accL, accR) + VirtUnit u -> (accL, u:accR) + _ -> (accL, accR) + go acc' imports + +-- | Given a 'Unit', make sure it is well typed. This is because +-- unit IDs come from Cabal, which does not know if things are well-typed or +-- not; a component may have been filled with implementations for the holes +-- that don't actually fulfill the requirements. +checkUnit :: Unit -> TcM () +checkUnit HoleUnit = return () +checkUnit (RealUnit _) = return () -- if it's already compiled, must be well-typed +checkUnit (VirtUnit indef) = do + let insts = instUnitInsts indef + forM_ insts $ \(mod_name, mod) -> + -- NB: direct hole instantiations are well-typed by construction + -- (because we FORCE things to be merged in), so don't check them + when (not (isHoleModule mod)) $ do + checkUnit (moduleUnit mod) + _ <- mod `checkImplements` Module indef mod_name + return () + +-- | Top-level driver for signature instantiation (run when compiling +-- an @hsig@ file.) +tcRnCheckUnit :: + HscEnv -> Unit -> + IO (Messages TcRnMessage, Maybe ()) +tcRnCheckUnit hsc_env uid = + withTiming logger + (text "Check unit id" <+> ppr uid) + (const ()) $ + initTc hsc_env + HsigFile -- bogus + False + (mainModIs (hsc_HUE hsc_env)) + (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus + $ checkUnit uid + where + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) + +-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear... + +-- | Top-level driver for signature merging (run after typechecking +-- an @hsig@ file). +tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface + -> IO (Messages TcRnMessage, Maybe TcGblEnv) +tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = + withTiming logger + (text "Signature merging" <+> brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env HsigFile False this_mod real_loc $ + mergeSignatures hpm orig_tcg_env iface + where + logger = hsc_logger hsc_env + this_mod = mi_module iface + real_loc = tcg_top_loc orig_tcg_env + +thinModIface :: [AvailInfo] -> ModIface -> ModIface +thinModIface avails iface = + iface + & set_mi_exports avails + -- mi_fixities = ..., + -- mi_warns = ..., + -- mi_anns = ..., + -- TODO: The use of nameOccName here is a bit dodgy, because + -- perhaps there might be two IfaceTopBndr that are the same + -- OccName but different Name. Requires better understanding + -- of invariants here. + & set_mi_decls (exported_decls ++ non_exported_decls ++ dfun_decls) + -- mi_insts = ..., + -- mi_fam_insts = ..., + where + decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs + filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface) + + exported_occs = mkOccSet [ nameOccName n + | a <- avails + , n <- availNames a ] + exported_decls = filter_decls exported_occs + + non_exported_occs = mkOccSet [ occName n + | (_, d) <- exported_decls + , n <- ifaceDeclNeverExportedRefs d ] + non_exported_decls = filter_decls non_exported_occs + + dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True + dfun_pred _ = False + dfun_decls = filter (dfun_pred . snd) (mi_decls iface) + +-- | The list of 'Name's of *non-exported* 'IfaceDecl's which this +-- 'IfaceDecl' may refer to. A non-exported 'IfaceDecl' should be kept +-- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps) +-- refers to it; we can't decide to keep it by looking at the exports +-- of a module after thinning. Keep this synchronized with +-- 'rnIfaceDecl'. +ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name] +ifaceDeclNeverExportedRefs d@IfaceFamily{} = + case ifFamFlav d of + IfaceClosedSynFamilyTyCon (Just (n, _)) + -> [n] + _ -> [] +ifaceDeclNeverExportedRefs _ = [] + + +-- Note [Blank hsigs for all requirements] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- One invariant that a client of GHC must uphold is that there +-- must be an hsig file for every requirement (according to +-- @-this-unit-id@); this ensures that for every interface +-- file (hi), there is a source file (hsig), which helps grease +-- the wheels of recompilation avoidance which assumes that +-- source files always exist. + +{- +inheritedSigPvpWarning :: WarningTxt +inheritedSigPvpWarning = + WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))] + where + msg = "Inherited requirements from non-signature libraries (libraries " ++ + "with modules) should not be used, as this mode of use is not " ++ + "compatible with PVP-style version bounds. Instead, copy the " ++ + "declaration to the local hsig file or move the signature to a " ++ + "library of its own and add that library as a dependency." +-} + +-- Note [Handling never-exported TyThings under Backpack] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will +-- never be mentioned in the export list of a module (mi_avails). +-- Unlike implicit TyThings (Note [Implicit TyThings]), non-exported +-- TyThings DO have a standalone IfaceDecl declaration in their +-- interface file. +-- +-- Originally, Backpack was designed under the assumption that anything +-- you could declare in a module could also be exported; thus, merging +-- the export lists of two signatures is just merging the declarations +-- of two signatures writ small. Of course, in GHC Haskell, there are a +-- few important things which are not explicitly exported but still can +-- be used: in particular, dictionary functions for instances, Typeable +-- TyCon bindings, and coercion axioms for type families also count. +-- +-- When handling these non-exported things, there two primary things +-- we need to watch out for: +-- +-- * Signature matching/merging is done by comparing each +-- of the exported entities of a signature and a module. These exported +-- entities may refer to non-exported TyThings which must be tested for +-- consistency. For example, an instance (ClsInst) will refer to a +-- non-exported DFunId. In this case, 'checkBootDeclM' directly compares the +-- embedded 'DFunId' in 'is_dfun'. +-- +-- For this to work at all, we must ensure that pointers in 'is_dfun' refer +-- to DISTINCT 'DFunId's, even though the 'Name's (may) be the same. +-- Unfortunately, this is the OPPOSITE of how we treat most other references +-- to 'Name's, so this case needs to be handled specially. +-- +-- The details are in the documentation for 'typecheckIfacesForMerging'. +-- and the Note [Resolving never-exported Names] in GHC.IfaceToCore. +-- +-- * When we rename modules and signatures, we use the export lists to +-- decide how the declarations should be renamed. However, this +-- means we don't get any guidance for how to rename non-exported +-- entities. Fortunately, we only need to rename these entities +-- *consistently*, so that 'typecheckIfacesForMerging' can wire them +-- up as needed. +-- +-- The details are in Note [rnIfaceNeverExported] in 'GHC.Iface.Rename'. +-- +-- The root cause for all of these complications is the fact that these +-- logically "implicit" entities are defined indirectly in an interface +-- file. #13151 gives a proposal to make these *truly* implicit. + +-- | Given a local 'ModIface', merge all inherited requirements +-- from 'requirementMerges' into this signature, producing +-- a final 'TcGblEnv' that matches the local signature and +-- all required signatures. +mergeSignatures :: HasDebugCallStack => HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv +mergeSignatures + (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }), + hpm_src_files = src_files }) + orig_tcg_env lcl_iface0 = setSrcSpan loc $ do + -- The lcl_iface0 is the ModIface for the local hsig + -- file, which is guaranteed to exist, see + -- Note [Blank hsigs for all requirements] + hsc_env <- getTopEnv + + -- Copy over some things from the original TcGblEnv that + -- we want to preserve + updGblEnv (\env -> env { + -- Renamed imports/declarations are often used + -- by programs that use the GHC API, e.g., Haddock. + -- These won't get filled by the merging process (since + -- we don't actually rename the parsed module again) so + -- we need to take them directly from the previous + -- typechecking. + -- + -- NB: the export declarations aren't in their final + -- form yet. We'll fill those in when we reprocess + -- the export declarations. + tcg_rn_imports = tcg_rn_imports orig_tcg_env, + tcg_rn_decls = tcg_rn_decls orig_tcg_env, + -- Annotations + tcg_ann_env = tcg_ann_env orig_tcg_env, + -- Documentation header and located module name + tcg_hdr_info = tcg_hdr_info orig_tcg_env + -- tcg_dus? + -- tcg_th_used = tcg_th_used orig_tcg_env, + -- tcg_th_splice_used = tcg_th_splice_used orig_tcg_env + }) $ do + tcg_env <- getGblEnv + + let outer_mod = tcg_mod tcg_env + let inner_mod = tcg_semantic_mod tcg_env + let mod_name = moduleName outer_mod + let unit_state = hsc_units hsc_env + let dflags = hsc_dflags hsc_env + + -- STEP 1: Figure out all of the external signature interfaces + -- we are going to merge in. + let reqs = requirementMerges unit_state mod_name + + addErrCtxt (MergeSignaturesCtxt unit_state mod_name reqs) $ do + + -- STEP 2: Read in the RAW forms of all of these interfaces + ireq_ifaces0 <- liftIO $ forM reqs $ \(Module iuid mod_name) -> do + let m = mkModule (VirtUnit iuid) mod_name + im = fst (getModuleInstantiation m) + ctx = initSDocContext dflags defaultUserStyle + fmap fst + . withIfaceErr ctx + $ findAndReadIface hsc_env (text "mergeSignatures") im m NotBoot + + -- STEP 3: Get the unrenamed exports of all these interfaces, + -- thin it according to the export list, and do shaping on them. + let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as + -- This function gets run on every inherited interface, and + -- it's responsible for: + -- + -- 1. Merging the exports of the interface into @nsubst@, + -- 2. Adding these exports to the "OK to import" set (@oks@) + -- if they came from a package with no exposed modules + -- (this means we won't report a PVP error in this case), and + -- 3. Thinning the interface according to an explicit export + -- list. + -- + gen_subst (nsubst,oks,ifaces) (imod@(Module iuid _), ireq_iface) = do + let insts = instUnitInsts iuid + isFromSignaturePackage = + let inst_uid = instUnitInstanceOf iuid + pkg = unsafeLookupUnitId unit_state inst_uid + in null (unitExposedModules pkg) + -- 3(a). Rename the exports according to how the dependency + -- was instantiated. The resulting export list will be accurate + -- except for exports *from the signature itself* (which may + -- be subsequently updated by exports from other signatures in + -- the merge. + as1 <- tcRnModExports insts ireq_iface + -- 3(b). Thin the interface if it comes from a signature package. + (thinned_iface, as2) <- case mb_exports of + Just (L loc _) + -- Check if the package containing this signature is + -- a signature package (i.e., does not expose any + -- modules.) If so, we can thin it. + | isFromSignaturePackage + -> setSrcSpanA loc $ do + -- Suppress missing errors; they might be used to refer + -- to entities from other signatures we are merging in. + -- If an identifier truly doesn't exist in any of the + -- signatures that are merged in, we will discover this + -- when we run exports_from_avail on the final merged + -- export list. + (mb_r, msgs) <- tryTc $ do + -- Suppose that we have written in a signature: + -- signature A ( module A ) where {- empty -} + -- If I am also inheriting a signature from a + -- signature package, does 'module A' scope over + -- all of its exports? + -- + -- There are two possible interpretations: + -- + -- 1. For non self-reexports, a module reexport + -- is interpreted only in terms of the local + -- signature module, and not any of the inherited + -- ones. The reason for this is because after + -- typechecking, module exports are completely + -- erased from the interface of a file, so we + -- have no way of "interpreting" a module reexport. + -- Thus, it's only useful for the local signature + -- module (where we have a useful GlobalRdrEnv.) + -- + -- 2. On the other hand, a common idiom when + -- you want to "export everything, plus a reexport" + -- in modules is to say module A ( module A, reex ). + -- This applies to signature modules too; and in + -- particular, you probably still want the entities + -- from the inherited signatures to be preserved + -- too. + -- + -- We think it's worth making a special case for + -- self reexports to make use case (2) work. To + -- do this, we take the exports of the inherited + -- signature @as1@, and bundle them into a + -- GlobalRdrEnv where we treat them as having come + -- from the import @import A@. Thus, we will + -- pick them up if they are referenced explicitly + -- (@foo@) or even if we do a module reexport + -- (@module A@). + let ispec = ImpSpec ImpDeclSpec{ + -- NB: This needs to be mod name + -- of the local signature, not + -- the (original) module name of + -- the inherited signature, + -- because we need module + -- LocalSig (from the local + -- export list) to match it! + is_mod = mi_module ireq_iface, + is_as = mod_name, + is_pkg_qual = NoPkgQual, + is_qual = False, + is_isboot = NotBoot, + is_dloc = locA loc, + is_level = NormalLevel + } ImpAll + rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just ispec) as1 + setGblEnv tcg_env { + tcg_rdr_env = rdr_env + } $ exports_from_avail mb_exports rdr_env + -- NB: tcg_imports is also empty! + emptyImportAvails + (tcg_semantic_mod tcg_env) + case mb_r of + Just (_, _, as2, _) -> return (thinModIface as2 ireq_iface, as2) + Nothing -> addMessages msgs >> failM + -- We can't thin signatures from non-signature packages + _ -> return (ireq_iface, as1) + -- 3(c). Only identifiers from signature packages are "ok" to + -- import (that is, they are safe from a PVP perspective.) + -- (NB: This code is actually dead right now.) + let oks' | isFromSignaturePackage + = extendOccSetList oks (exportOccs as2) + | otherwise + = oks + -- 3(d). Extend the name substitution (performing shaping) + mb_r <- extend_ns nsubst as2 + case mb_r of + Left err -> failWithTc (TcRnHsigShapeMismatch err) + Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces) + nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) + ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0)) + -- Process each interface, getting the thinned interfaces as well as + -- the final, full set of exports @nsubst@ and the exports which are + -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.) + (nsubst, ok_to_use, rev_thinned_ifaces) + <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0) + let thinned_ifaces = reverse rev_thinned_ifaces + exports = nameShapeExports nsubst + rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env Nothing exports) + _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports) + warns = emptyWarn + {- + -- TODO: Warnings are transitive, but this is not what we want here: + -- if a module reexports an entity from a signature, that should be OK. + -- Not supported in current warning framework + warns | null warn_occs = NoWarnings + | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs + -} + setGblEnv tcg_env { + -- The top-level GlobalRdrEnv is quite interesting. It consists + -- of two components: + -- 1. First, we reuse the GlobalRdrEnv of the local signature. + -- This is very useful, because it means that if we have + -- to print a message involving some entity that the local + -- signature imported, we'll qualify it accordingly. + -- 2. Second, we need to add all of the declarations we are + -- going to merge in (as they need to be in scope for the + -- final test of the export list.) + tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env, + -- Inherit imports from the local signature, so that module + -- reexports are picked up correctly + tcg_imports = tcg_imports orig_tcg_env, + tcg_exports = exports, + tcg_dus = usesOnly (availsToNameSet exports), + tcg_warns = warns + } $ do + tcg_env <- getGblEnv + + -- Make sure we didn't refer to anything that doesn't actually exist + -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return () + (mb_lies, exp_dflts, _, _) <- + exports_from_avail mb_exports rdr_env + (tcg_imports tcg_env) (tcg_semantic_mod tcg_env) + + {- -- NB: This is commented out, because warns above is disabled. + -- If you tried to explicitly export an identifier that has a warning + -- attached to it, that's probably a mistake. Warn about it. + case mb_lies of + Nothing -> return () + Just lies -> + forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) -> + setSrcSpan loc $ + unless (nameOccName n `elemOccSet` ok_to_use) $ + addWarn NoReason $ vcat [ + text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.", + parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.") + ] + -} + + failIfErrsM + + -- Save the exports + setGblEnv tcg_env { tcg_rn_exports = mb_lies, tcg_default_exports = exp_dflts } $ do + tcg_env <- getGblEnv + + let home_unit = hsc_home_unit hsc_env + + -- STEP 4: Rename the interfaces + ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) -> + tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface + lcl_iface <- tcRnModIface (homeUnitInstantiations home_unit) (Just nsubst) lcl_iface0 + let ifaces = lcl_iface : ext_ifaces + + -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env + let fix_env = mkNameEnv [ (greName rdr_elt, FixItem occ f) + | (occ, f) <- concatMap mi_fixities ifaces + , rdr_elt <- lookupGRE rdr_env (LookupOccName occ AllRelevantGREs) ] + + -- STEP 5: Typecheck the interfaces + let type_env_var = tcg_type_env_var tcg_env + + -- typecheckIfacesForMerging does two things: + -- 1. It merges the all of the ifaces together, and typechecks the + -- result to type_env. + -- 2. It typechecks each iface individually, but with their 'Name's + -- resolving to the merged type_env from (1). + -- See typecheckIfacesForMerging for more details. + (type_env, detailss) <- initIfaceTcRn $ + typecheckIfacesForMerging inner_mod ifaces type_env_var + let infos = zip ifaces detailss + + -- Test for cycles + checkSynCycles (homeUnitAsUnit home_unit) (typeEnvTyCons type_env) [] + + -- NB on type_env: it contains NO dfuns. DFuns are recorded inside + -- detailss, and given a Name that doesn't correspond to anything real. See + -- also Note [Signature merging DFuns] + + -- Add the merged type_env to TcGblEnv, so that it gets serialized + -- out when we finally write out the interface. + -- + -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly, + -- rather than use tcExtendGlobalEnv (the normal method to add newly + -- defined types to TcGblEnv?) tcExtendGlobalEnv adds these + -- TyThings to 'tcg_type_env_var', which is consulted when + -- we read in interfaces to tie the knot. But *these TyThings themselves + -- come from interface*, so that would result in deadlock. Don't + -- update it! + setGblEnv tcg_env { + tcg_tcs = typeEnvTyCons type_env, + tcg_patsyns = typeEnvPatSyns type_env, + tcg_type_env = type_env, + tcg_fix_env = fix_env + } $ do + tcg_env <- getGblEnv + + -- STEP 6: Check for compatibility/merge things + tcg_env <- (\x -> foldM x tcg_env infos) + $ \tcg_env (iface, details) -> do + + let check_export name + | Just sig_thing <- lookupTypeEnv (md_types details) name + = case lookupTypeEnv type_env (getName sig_thing) of + Just thing -> checkHsigDeclM iface sig_thing thing + Nothing -> panic "mergeSignatures: check_export" + -- Oops! We're looking for this export but it's + -- not actually in the type environment of the signature's + -- ModDetails. + -- + -- NB: This case happens because the we're iterating + -- over the union of all exports, so some interfaces + -- won't have everything. Note that md_exports is nonsense + -- (it's the same as exports); maybe we should fix this + -- eventually. + | otherwise + = return () + mapM_ check_export (map availName exports) + + -- Note [Signature merging instances] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Merge instances into the global environment. The algorithm here is + -- dumb and simple: if an instance has exactly the same DFun type + -- (tested by 'memberInstEnv') as an existing instance, we drop it; + -- otherwise, we add it even, even if this would cause overlap. + -- + -- Why don't we deduplicate instances with identical heads? There's no + -- good choice if they have premises: + -- + -- instance K1 a => K (T a) + -- instance K2 a => K (T a) + -- + -- Why not eagerly error in this case? The overlapping head does not + -- necessarily mean that the instances are unimplementable: in fact, + -- they may be implemented without overlap (if, for example, the + -- implementing module has 'instance K (T a)'; both are implemented in + -- this case.) The implements test just checks that the wanteds are + -- derivable assuming the givens. + -- + -- Still, overlapping instances with hypotheses like above are going + -- to be a bad deal, because instance resolution when we're typechecking + -- against the merged signature is going to have a bad time when + -- there are overlapping heads like this: we never backtrack, so it + -- may be difficult to see that a wanted is derivable. For now, + -- we hope that we get lucky / the overlapping instances never + -- get used, but it is not a very good situation to be in. + -- + let merge_inst (insts, inst_env) inst + | memberInstEnv inst_env inst -- test DFun Type equality + = (insts, inst_env) + | otherwise + -- NB: is_dfun_name inst is still nonsense here, + -- see Note [Signature merging DFuns] + = (inst:insts, extendInstEnv inst_env inst) + (insts, inst_env) = foldl' merge_inst + (tcg_insts tcg_env, tcg_inst_env tcg_env) + (instEnvElts $ md_insts details) + -- Use mi_deps directly rather than calculateAvails. + -- because a module is NOT + -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 + avails = tcg_imports tcg_env + deps = mi_deps iface + avails_with_trans = addTransitiveDepInfo avails deps + + return tcg_env { + tcg_inst_env = inst_env, + tcg_insts = insts, + tcg_imports = avails_with_trans, + tcg_merged = + if outer_mod == mi_module iface + -- Don't add ourselves! + then tcg_merged tcg_env + else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env + } + + -- Note [Signature merging DFuns] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Once we know all of instances which will be defined by this merged + -- signature, we go through each of the DFuns and rename them with a fresh, + -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing + -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'. + -- + -- We can't do this fixup earlier, because we need a way to identify each + -- source DFun (from each of the signatures we are merging in) so that + -- when we have a ClsInst, we can pull up the correct DFun to check if + -- the types match. + -- + -- See also Note [rnIfaceNeverExported] in GHC.Iface.Rename + dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do + n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst)) + let dfun = setVarName (is_dfun inst) n + return (dfun, inst { is_dfun_name = n, is_dfun = dfun }) + + tcg_env <- return $ + tcg_env { tcg_insts = map snd dfun_insts + , tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) } + + addDependentFiles src_files + + return tcg_env + +-- | Add on the necessary transitive information from the merged signature to +-- the 'ImportAvails' of the result of merging. This propagates the orphan instances +-- which were in the transitive closure of the signature through the merge. +addTransitiveDepInfo :: ImportAvails -- ^ From the signature resulting from the merge + -> Dependencies -- ^ From the original signature + -> ImportAvails +addTransitiveDepInfo avails deps = + -- Avails for the merged in signature + -- Add on transitive information from the signature but nothing else.. + -- because we do not "import" the signature. + avails { imp_orphs = imp_orphs avails ++ dep_orphs deps + , imp_finsts = imp_finsts avails ++ dep_finsts deps + , imp_sig_mods = imp_sig_mods avails ++ dep_sig_mods deps } + +-- | Top-level driver for signature instantiation (run when compiling +-- an @hsig@ file.) +tcRnInstantiateSignature :: + HscEnv -> Module -> RealSrcSpan -> + IO (Messages TcRnMessage, Maybe TcGblEnv) +tcRnInstantiateSignature hsc_env this_mod real_loc = + withTiming logger + (text "Signature instantiation"<+>brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature + where + logger = hsc_logger hsc_env + +exportOccs :: [AvailInfo] -> [OccName] +exportOccs = concatMap (map nameOccName . availNames) + +-- | Check if module implements a signature. (The signature is +-- always un-hashed, which is why its components are specified +-- explicitly.) +checkImplements :: HasDebugCallStack => Module -> InstantiatedModule -> TcRn TcGblEnv +checkImplements impl_mod req_mod@(Module uid mod_name) = do + hsc_env <- getTopEnv + let unit_state = hsc_units hsc_env + home_unit = hsc_home_unit hsc_env + other_home_units = hsc_all_home_unit_ids hsc_env + addErrCtxt (CheckImplementsCtxt unit_state impl_mod req_mod) $ do + let insts = instUnitInsts uid + + -- STEP 1: Load the implementing interface, and make a RdrEnv + -- for its exports. Also, add its 'ImportAvails' to 'tcg_imports', + -- so that we treat all orphan instances it provides as visible + -- when we verify that all instances are checked (see #12945), and so that + -- when we eventually write out the interface we record appropriate + -- dependency information. + impl_iface <- initIfaceTcRn $ + loadSysInterface (text "checkImplements 1") impl_mod + let impl_gr = mkGlobalRdrEnv + (gresFromAvails hsc_env Nothing (mi_exports impl_iface)) + nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) + + -- Load all the orphans, so the subsequent 'checkHsigIface' sees + -- all the instances it needs to + loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") + (dep_orphs (mi_deps impl_iface)) + + let avails = calculateAvails home_unit other_home_units + impl_iface False{- safe -} NotBoot ImportedBySystem + fix_env = mkNameEnv [ (greName rdr_elt, FixItem occ f) + | (occ, f) <- mi_fixities impl_iface + , rdr_elt <- lookupGRE impl_gr (LookupOccName occ AllRelevantGREs) ] + updGblEnv (\tcg_env -> tcg_env { + -- Setting tcg_rdr_env to treat all exported entities from + -- the implementing module as in scope improves error messages, + -- as it reduces the amount of qualification we need. Unfortunately, + -- we still end up qualifying references to external modules + -- (see bkpfail07 for an example); we'd need to record more + -- information in ModIface to solve this. + tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr, + tcg_imports = tcg_imports tcg_env `plusImportAvails` avails, + -- This is here so that when we call 'lookupFixityRn' for something + -- directly implemented by the module, we grab the right thing + tcg_fix_env = fix_env + }) $ do + + -- STEP 2: Load the *unrenamed, uninstantiated* interface for + -- the ORIGINAL signature. We are going to eventually rename it, + -- but we must proceed slowly, because it is NOT known if the + -- instantiation is correct. + let sig_mod = mkModule (VirtUnit uid) mod_name + isig_mod = fst (getModuleInstantiation sig_mod) + hsc_env <- getTopEnv + mb_isig_iface <- liftIO $ findAndReadIface hsc_env + (text "checkImplements 2") + isig_mod sig_mod NotBoot + isig_iface <- case mb_isig_iface of + Succeeded (iface, _) -> return iface + Failed err -> + failWithTc $ TcRnInterfaceError $ + Can'tFindInterface err (LookingForSig isig_mod) + + -- STEP 3: Check that the implementing interface exports everything + -- we need. (Notice we IGNORE the Modules in the AvailInfos.) + forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> + case lookupGRE impl_gr (LookupOccName occ SameNameSpace) of + [] -> addErr $ TcRnHsigMissingModuleExport occ unit_state impl_mod + _ -> return () + failIfErrsM + + -- STEP 4: Now that the export is complete, rename the interface... + sig_iface <- tcRnModIface insts (Just nsubst) isig_iface + + -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst + -- lets us determine how top-level identifiers should be handled.) + sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface + + -- STEP 6: Check that it's sufficient + tcg_env <- getGblEnv + checkHsigIface tcg_env impl_gr sig_iface sig_details + + -- STEP 7: Return the updated 'TcGblEnv' with the signature exports, + -- so we write them out. + return tcg_env { + tcg_exports = mi_exports sig_iface + } + +-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite +-- library to use the actual implementations of the relevant entities, +-- checking that the implementation matches the signature. +instantiateSignature :: TcRn TcGblEnv +instantiateSignature = do + hsc_env <- getTopEnv + tcg_env <- getGblEnv + let outer_mod = tcg_mod tcg_env + inner_mod = tcg_semantic_mod tcg_env + home_unit = hsc_home_unit hsc_env + -- TODO: setup the local RdrEnv so the error messages look a little better. + -- But this information isn't stored anywhere. Should we RETYPECHECK + -- the local one just to get the information? Hmm... + massert (isHomeModule home_unit outer_mod ) + massert (isHomeUnitInstantiating home_unit) + let uid = homeUnitInstanceOf home_unit + inner_mod `checkImplements` + Module + (mkInstantiatedUnit uid (homeUnitInstantiations home_unit)) + (moduleName outer_mod) diff --git a/GHC/Tc/Utils/Concrete.hs b/GHC/Tc/Utils/Concrete.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Concrete.hs @@ -0,0 +1,809 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ParallelListComp #-} + +-- | 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 + + , unifyConcrete + + , idConcreteTvs + ) + where + +import GHC.Prelude + +import GHC.Builtin.Names ( unsafeCoercePrimName ) +import GHC.Builtin.Types + +import GHC.Core.Coercion +import GHC.Core.TyCo.Rep +import GHC.Core.Type + +import GHC.Data.Bag + +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import {-# SOURCE #-} GHC.Tc.Utils.Unify + +import GHC.Types.Basic ( TypeOrKind(KindLevel) ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name.Env +import GHC.Types.Var + +import GHC.Utils.Misc ( HasDebugCallStack ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.FastString ( FastString, fsLit ) + +import Control.Monad ( void ) +import Data.Functor ( ($>) ) + + +{- 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 + 'isConcreteType`), 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.isConcreteType 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. + + +Note [Representation-polymorphic Ids with no binding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We cannot have representation-polymorphic or levity-polymorphic +function arguments. See Note [Representation polymorphism invariants] +in GHC.Core. That is checked in 'GHC.Tc.Gen.App.tcInstFun', see the call +to 'matchActualFunTy', which performs the representation-polymorphism +check. + +However, some special Ids have representation-polymorphic argument +types. These are all GHC built-ins or data constructors. They have no binding; +instead they have compulsory unfoldings. Specifically, these Ids are: + +1. Some wired-in Ids, such as coerce, oneShot and unsafeCoerce# (which is only + partly wired-in), +2. Representation-polymorphic primops, such as raise#. +3. Representation-polymorphic data constructors: unboxed tuples + and unboxed sums. +4. Newtype constructors with `UnliftedNewtypes` which have + a representation-polymorphic argument. + +For (1) consider + badId :: forall r (a :: TYPE r). a -> a + badId = unsafeCoerce# @r @r @a @a + +The (partly) 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) and unboxed tuples/sums (3), 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. + +The Note [Representation-polymorphism checking built-ins] explains how we handle +cases (1) (2) and (3). + +For (4), 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 + +(4) is handled differently than (1) (2) and (3); +see Note [Eta-expanding rep-poly unlifted newtypes]. + +Note [Representation-polymorphism checking built-ins] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some primops and wired-in functions are representation-polymorphic, but must +only be instantiated at particular, concrete representations. +There are three cases, all for `hasNoBinding` Ids: + +* Wired-in Ids. For example, `seq` + is a wired-in Id, defined in GHC.Types.Id.Make.seqId, with this type: + + seq :: forall {r} a (b :: TYPE r). a -> b -> b + + It is more like a macro than a regular Id: it has /compulsory/ unfolding, so + we inline it at every call site. At those call sites we should instantiate + `r` with a concrete RuntimeRep, so that the lambda has a concrete representation. + So somehow the type checker has to ensure that `seq` is called with a concrete + instantiation for `r`. + + NB: unsafeCoerce# is not quite wired-in (see Note [Wiring in unsafeCoerce#] in GHC.HsToCore), + but it gets a similar treatment. + +* PrimOps. Some representation-polymorphic primops must be called at a concrete + type. For example: + + catch# :: forall {r} {l} (k :: TYPE r) (w :: TYPE (BoxedRep l)). + (State# RealWorld -> (# State# RealWorld, k #) ) + -> (w -> State# RealWorld -> (# State# RealWorld, k #) ) + -> State# RealWorld -> (# State# RealWorld, k #) + + This primop pushes a "catch frame" on the stack, which must "know" + the return convention of `k`. So `k` must be concrete, so we know + what kind of catch-frame to push. (See #21868 for more details. + + So again we want to ensure that `r` is instantiated with a concrete RuntimeRep. + +* Unboxed-tuple data constructors. Consider the unboxed pair data constructor: + + (#,#) :: forall {r1} {r2} (a :: TYPE r1) (b :: TYPE r2). a -> b -> (# a, b #) + + Again, we need concrete `r1` and `r2`. For example, we want to reject + + f :: forall r (a :: TYPE r). a -> (# Int, a #) + f = (#,#) 3 + +As pointed out in #21906; we see here that it is not enough to simply check +the representation of the argument types, as for example "k :: TYPE r" in the +type of catch# occurs in negative position but not directly as the type of +an argument. + +NB: we specifically *DO NOT* handle representation-polymorphic unlifted newtypes +with this mechanism. See Note [Eta-expanding rep-poly unlifted newtypes] for an +overview of representation-polymorphism checks for those. + +To achieve this goal, for these these three kinds of `hasNoBinding` functions: + +* We identify the quantified variable `r` as a "concrete quantifier" + +* When instantiating a concrete quantifier, such as `r`, at a call site, we + instantiate with a ConcreteTv meta-tyvar, `r0[conc]`. + See Note [ConcreteTv] in GHC.Tc.Utils.Concrete. + +Now the type checker will ensure that `r0` is instantiated with a concrete +RuntimeRep. + +Here are the moving parts: + +* In the IdDetails of an Id, we record a mapping from type variable name + to concreteness information, in the form of a ConcreteTvOrigin. + See 'idDetailsConcreteTvs'. + + The ConcreteTvOrigin is used to determine which error message to show + to the user if the type variable gets instantiated to a non-concrete type; + this is slightly more granular than simply storing a set of type variable names. + +* The domain of this NameEnv is the outer forall'd TyVars of that + Id's type. (A bit yukky because it means that alpha-renaming that type + would be invalid. But we never do that.) So `seq` has + Type: forall {r} a (b :: TYPE r). a -> b -> b + IdDetails: RepPolyId [ r :-> ConcreteFRR (FixedRuntimeRepOrigin b (..)) ] + +* When instantiating the type of an Id at a call site, at the call to + GHC.Tc.Utils.Instantiate.instantiateSigma in GHC.Tc.Gen.App.tcInstFun, + create ConcreteTv metavariables (instead of TauTvs) based on the + ConcreteTyVars stored in the IdDetails of the Id. + +Note that the /only/ place that one of these restricted rep-poly Ids can enter +typechecking is in `tcInferId`, and all the interesting cases then land +in `tcInstFun` where we take care to instantantiate those concrete +type variables correctly. + + Design alternative: in some ways, it would be more kosher for the concrete-ness + to be stored in the /type/, thus forall (r[conc] :: RuntimeRep). ty. + But that pollutes Type for a very narrow use-case; so instead we adopt the + more ad-hoc solution described above. + +Examples: + + ok :: forall (a :: Type) (b :: Type). a -> b -> b + ok = seq + + bad :: forall s (b :: TYPE s). Int -> b -> b + bad x = seq x + + Here we will instantiate the RuntimeRep skolem variable r from the type + of seq to a concrete metavariable rr[conc]. + For 'ok' we will unify rr := LiftedRep, and for 'bad' we will fail to + solve rr[conc] ~# s[sk] and report a representation-polymorphism error to + the user. + + type RR :: RuntimeRep + type family RR where { RR = IntRep } + + tricky1, tricky2 :: forall (b :: TYPE RR). Int -> b -> b + tricky1 = seq + tricky2 = seq @RR + + 'tricky1' proceeds as above: we instantiate r |-> rr[conc], get a Wanted + rr[conc] ~# RR, which we solve by rewriting the type family. + + For 'tricky2', we again create a fresh ConcreteTv metavariable rr[conc], + and we then proceed as if the user had written "seq @rr", but adding an + additional [W] rr ~ RR to the constraint solving context. + +[Wrinkle: VTA] + + We must also handle the case when the user has instantiated the type variables + themselves, with a visible type application. We do this in GHC.Tc.Gen.App.tcVTA. + + For example: + + type F :: Type -> RuntimeRep + type family F a where { F Bool = IntRep } + + foo = (# , #) @(F Bool) @FloatRep + + We want to accept "foo" even though "F Bool" is not a concrete RuntimeRep. + We proceed as follows (see tcVTA): + + - create a fresh concrete metavariable kappa, + - emit [W] F Bool ~ kappa[conc] + - pretend the user wrote (#,#) @kappa. + + The solver will then unify kappa := IntRep, after rewriting the type family + application on the LHS of the Wanted. + + Note that this is a bit of a corner case: only a few built-ins, such as + unsafeCoerce# and unboxed tuples, have specified (not inferred) RuntimeRep + quantified variables which can be instantiated by the user with a + visible type application. + For example, + + coerce :: forall {r :: RuntimeRep} (a :: TYPE r) (b :: TYPE r) + . Coercible a b => a -> b + + does not allow the RuntimeRep argument to be specified by a visible type + application. +-} + +-- | 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 (fmap (fmap coToMCo) . unifyConcrete_kind (fsLit "cx") . ConcreteFRR) 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_lvl <- getThLevel + ; 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]. + | TypedBrack {} <- th_lvl + -> return refl + + -- Otherwise: ensure that the kind 'ki' of 'ty' is concrete. + | otherwise + -> do { kco <- check_kind frr_orig ki + ; return ( mkGReflRightMCo Nominal ty kco + , mkCastTyMCo ty kco ) } } + + where + refl :: (TcCoercionN, TcType) + refl = (mkNomReflCo ty, ty) + ki :: TcKind + ki = typeKind ty + frr_orig :: FixedRuntimeRepOrigin + frr_orig = FixedRuntimeRepOrigin { frr_type = ty, frr_context = frr_ctxt } + +-- | Ensure that the given kind @ki@ can unify with a concrete type, +-- in the sense of Note [Concrete types]. +-- +-- Returns a coercion @co :: ki ~# conc_ki@, where @conc_ki@ is +-- concrete. +-- +-- If the kind is already syntactically concrete, this +-- immediately returns a reflexive coercion. Otherwise, +-- it creates a new concrete metavariable @concrete_tv@ +-- and emits an equality constraint @ki ~# concrete_tv@, +-- to be handled by the constraint solver. +-- +-- Precondition: @ki@ must be of the form @TYPE rep@ or @CONSTRAINT rep@. +unifyConcrete_kind :: HasDebugCallStack + => FastString -- ^ name to use when creating concrete metavariables + -> ConcreteTvOrigin + -> TcKind + -> TcM TcCoercionN +unifyConcrete_kind occ_fs conc_orig ki + | Just (torc, rep) <- sORTKind_maybe ki + = do { let tc = case torc of + TypeLike -> tYPETyCon + ConstraintLike -> cONSTRAINTTyCon + ; rep_co <- unifyConcrete occ_fs conc_orig rep + ; return $ mkTyConAppCo Nominal tc [rep_co] } + | otherwise + = pprPanic "unifyConcrete_kind: kind is not of the form 'TYPE rep' or 'CONSTRAINT rep'" $ + ppr ki <+> dcolon <+> ppr (typeKind ki) + + +-- | Ensure the given type can be unified 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 will create new concrete metavariables and emit +-- new Wanted equality constraints, 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 :: FastString -> ConcreteTvOrigin -> TcType -> TcM TcCoercionN +unifyConcrete occ_fs conc_orig ty + = do { (co, cts) <- makeTypeConcrete occ_fs conc_orig ty + ; emitSimples cts + ; return co } + +-- | Ensure that the given kind @ki@ is concrete. +-- +-- This is an eager syntactic check, and never defers +-- any work to the constraint solver. However, +-- it may perform unification. +-- +-- Invariant: the output type is equal to the input type, up to zonking. +ensureConcrete :: HasDebugCallStack + => FixedRuntimeRepOrigin + -> TcKind + -> TcM TcKind +ensureConcrete frr_orig ki + = do { (co, cts) <- makeTypeConcrete (fsLit "cx") conc_orig ki + ; let trace_msg = vcat [ text "ty: " <+> ppr ki + , text "co:" <+> ppr co ] + ; if isEmptyBag cts + then traceTc "ensureConcrete } success" trace_msg + else do { traceTc "ensureConcrete } failure" trace_msg + ; loc <- getCtLocM (FRROrigin frr_orig) (Just KindLevel) + ; emitNotConcreteError $ + NCE_FRR + { nce_loc = loc + , nce_frr_origin = frr_orig } + } + ; return $ coercionRKind co } + where + conc_orig :: ConcreteTvOrigin + conc_orig = ConcreteFRR frr_orig + +{-*********************************************************************** +%* * + Concrete type variables of Ids +%* * +%**********************************************************************-} + +-- | Which type variables of this 'Id' must be concrete when instantiated? +-- +-- See Note [Representation-polymorphism checking built-ins] +idConcreteTvs :: TcId -> ConcreteTyVars +idConcreteTvs id + + -- HACK for unsafeCoerce#: because of the way it is not quite wired in, + -- as described in Note [Wiring in unsafeCoerce#] in GHC.HsToCore, we don't + -- have access to the correct IdDetails in the typechecker (as we only patch + -- in the correct information in the desugarer). + -- So, for the time being, we manually inspect the type of the original, + -- unpatched Id to retrieve which of its outer forall-d tyvars should be concrete. + | idName id == unsafeCoercePrimName + , (a_rep:_b_rep:a:_b:_, _) <- tcSplitForAllTyVars $ idType id + -- NB: only check the argument representation, not the result representation. + -- This is because the following is OK: + -- + -- unsafeCoerceWordRep :: forall {r2} (b :: TYPE r2). Word# -> b + -- unsafeCoerceWordRep = unsafeCoerce# + = mkNameEnv + [(tyVarName a_rep, ConcreteFRR $ FixedRuntimeRepOrigin (mkTyVarTy a) + $ FRRRepPolyId unsafeCoercePrimName RepPolyFunction + $ mkArgPos 1 Top)] + + | otherwise + = idDetailsConcreteTvs $ idDetails id diff --git a/GHC/Tc/Utils/Env.hs b/GHC/Tc/Utils/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Env.hs @@ -0,0 +1,1256 @@ +-- (c) The University of Glasgow 2006 +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an + -- orphan +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Tc.Utils.Env( + TyThing(..), TcTyThing(..), TcId, + + -- Instance environment, and InstInfo type + InstInfo(..), iDFunId, pprInstInfoDetails, + simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, + InstBindings(..), + + -- Global environment + tcExtendGlobalEnv, tcExtendTyConEnv, + tcExtendGlobalEnvImplicit, setGlobalTypeEnv, + tcExtendGlobalValEnv, tcTyThBinders, + tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly, + tcLookupTyCon, tcLookupClass, + tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, + tcLookupRecSelParent, + tcLookupLocatedGlobalId, tcLookupLocatedTyCon, + tcLookupLocatedClass, tcLookupAxiom, + lookupGlobal, lookupGlobal_maybe, + addTypecheckedBinds, + failIllegalTyCon, failIllegalTyVar, + + -- Local environment + tcExtendKindEnv, tcExtendKindEnvList, + tcExtendTyVarEnv, tcExtendNameTyVarEnv, + tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds, + tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, + tcExtendBinderStack, tcExtendLocalTypeEnv, + isTypeClosedLetBndr, + + tcLookup, tcLookupLocated, tcLookupLocalIds, + tcLookupId, tcLookupIdMaybe, tcLookupTyVar, + tcLookupTcTyCon, + tcLookupLcl_maybe, + getInLocalScope, + wrongThingErr, pprBinders, + + tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, tcAddKindSigPlaceholders, + getTypeSigNames, + tcExtendRecEnv, -- For knot-tying + + -- Instances + tcLookupInstance, tcGetInstEnvs, + + -- Rules + tcExtendRules, + + -- Defaults + tcGetDefaultTys, + + -- Template Haskell stuff + LevelCheckReason(..), + tcMetaTy, thLevelIndex, + isBrackLevel, + + -- New Ids + newDFunName, + newFamInstTyConName, newFamInstAxiomName, + mkStableIdFromString, mkStableIdFromName, + mkWrapperName, tcGetClsDefaults, + ) where + +import GHC.Prelude + + +import GHC.Driver.Env +import GHC.Driver.Env.KnotVars +import GHC.Driver.DynFlags + +import GHC.Builtin.Names +import GHC.Builtin.Types + +import GHC.Runtime.Context + +import GHC.Hs + +import GHC.Iface.Env +import GHC.Iface.Load + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import {-# SOURCE #-} GHC.Tc.Utils.TcMType ( tcCheckUsage ) +import GHC.Tc.Types.LclEnv + +import GHC.Core.InstEnv +import GHC.Core.DataCon ( DataCon, dataConTyCon, flSelector ) +import GHC.Core.PatSyn ( PatSyn ) +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Core.Coercion.Axiom +import GHC.Core.Class + + +import GHC.Unit.Module +import GHC.Unit.Module.ModDetails +import GHC.Unit.Home +import GHC.Unit.Home.Graph +import GHC.Unit.Home.ModInfo +import GHC.Unit.External + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Encoding +import GHC.Utils.Misc ( HasDebugCallStack ) + +import GHC.Data.FastString +import GHC.Data.List.SetOps +import GHC.Data.Maybe( MaybeErr(..), orElse, maybeToList, fromMaybe ) + +import GHC.Types.SrcLoc +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Types.TypeEnv +import GHC.Types.SourceFile +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.DefaultEnv +import GHC.Types.Error +import GHC.Types.Id +import GHC.Types.Id.Info ( RecSelParent(..) ) +import GHC.Types.Name.Reader +import GHC.Types.TyThing +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Iface.Errors.Types +import GHC.Rename.Unbound ( unknownNameSuggestions ) +import GHC.Tc.Errors.Types.PromotionErr +import {-# SOURCE #-} GHC.Tc.Errors.Hole (getHoleFitDispConfig) + +import Control.Monad +import Data.IORef +import Data.List ( intercalate ) +import qualified Data.List.NonEmpty as NE + +{- ********************************************************************* +* * + An IO interface to looking up globals +* * +********************************************************************* -} + +lookupGlobal :: HscEnv -> Name -> IO TyThing +-- A variant of lookupGlobal_maybe for the clients which are not +-- interested in recovering from lookup failure and accept panic. +lookupGlobal hsc_env name + = do { + mb_thing <- lookupGlobal_maybe hsc_env name + ; case mb_thing of + Succeeded thing -> return thing + Failed err -> + let msg = case err of + Left name -> text "Could not find local name:" <+> ppr name + Right err -> pprDiagnostic err + in pprPanic "lookupGlobal" msg + } +lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) TyThing) +-- This may look up an Id that one has previously looked up. +-- If so, we are going to read its interface file, and add its bindings +-- to the ExternalPackageTable. +lookupGlobal_maybe hsc_env name + = do { -- Try local envt + let mod = icInteractiveModule (hsc_IC hsc_env) + mhome_unit = hsc_home_unit_maybe hsc_env + tcg_semantic_mod = homeModuleInstantiation mhome_unit mod + + ; if nameIsLocalOrFrom tcg_semantic_mod name + then return $ Failed $ Left name + -- Internal names can happen in GHCi + else do + res <- lookupImported_maybe hsc_env name + -- Try home package table and external package table + return $ case res of + Succeeded ok -> Succeeded ok + Failed err -> Failed (Right err) + } + +lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing) +-- Returns (Failed err) if we can't find the interface file for the thing +lookupImported_maybe hsc_env name + = do { mb_thing <- lookupType hsc_env name + ; case mb_thing of + Just thing -> return (Succeeded thing) + Nothing -> importDecl_maybe hsc_env name + } + +importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing) +importDecl_maybe hsc_env name + | Just thing <- wiredInNameTyThing_maybe name + = do { when (needWiredInHomeIface thing) + (initIfaceLoad hsc_env (loadWiredInHomeIface name)) + -- See Note [Loading instances for wired-in things] + ; return (Succeeded thing) } + | otherwise + = initIfaceLoad hsc_env (importDecl name) + +addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv +addTypecheckedBinds tcg_env binds + | isHsBootOrSig (tcg_src tcg_env) = tcg_env + -- Do not add the code for record-selector bindings + -- when compiling hs-boot files + | otherwise = tcg_env { tcg_binds = foldr (++) + (tcg_binds tcg_env) + binds } +{- +************************************************************************ +* * +* tcLookupGlobal * +* * +************************************************************************ + +Using the Located versions (eg. tcLookupLocatedGlobal) is preferred, +unless you know that the SrcSpan in the monad is already set to the +span of the Name. +-} + + +tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing +-- c.f. GHC.IfaceToCore.tcIfaceGlobal +tcLookupLocatedGlobal name + = addLocM tcLookupGlobal name + +tcLookupGlobal :: Name -> TcM TyThing +-- The Name is almost always an ExternalName, but not always +-- In GHCi, we may make command-line bindings (ghci> let x = True) +-- that bind a GlobalId, but with an InternalName +tcLookupGlobal name + = do { -- Try local envt + env <- getGblEnv + ; case lookupNameEnv (tcg_type_env env) name of { + Just thing -> return thing ; + Nothing -> + + -- Should it have been in the local envt? + -- (NB: use semantic mod here, since names never use + -- identity module, see Note [Identity versus semantic module].) + if nameIsLocalOrFrom (tcg_semantic_mod env) name + then notFound name -- Internal names can happen in GHCi + else + + -- Try home package table and external package table + do { mb_thing <- tcLookupImported_maybe name + ; case mb_thing of + Succeeded thing -> return thing + Failed msg -> failWithTc (TcRnInterfaceError msg) + }}} + +-- Look up only in this module's global env't. Don't look in imports, etc. +-- Panic if it's not there. +tcLookupGlobalOnly :: Name -> TcM TyThing +tcLookupGlobalOnly name + = do { env <- getGblEnv + ; return $ case lookupNameEnv (tcg_type_env env) name of + Just thing -> thing + Nothing -> pprPanic "tcLookupGlobalOnly" (ppr name) } + +tcLookupDataCon :: Name -> TcM DataCon +tcLookupDataCon name = do + thing <- tcLookupGlobal name + case thing of + AConLike (RealDataCon con) -> return con + _ -> wrongThingErr WrongThingDataCon (AGlobal thing) name + +tcLookupPatSyn :: Name -> TcM PatSyn +tcLookupPatSyn name = do + thing <- tcLookupGlobal name + case thing of + AConLike (PatSynCon ps) -> return ps + _ -> wrongThingErr WrongThingPatSyn (AGlobal thing) name + +tcLookupConLike :: WithUserRdr Name -> TcM ConLike +tcLookupConLike qname@(WithUserRdr _ name) = do + thing <- tcLookupGlobal name + case thing of + AConLike cl -> return cl + ATyCon {} -> failIllegalTyCon WL_ConLike qname + _ -> wrongThingErr WrongThingConLike (AGlobal thing) name + +tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent +tcLookupRecSelParent (RnRecUpdParent { rnRecUpdCons = cons }) + = case any_con of + PatSynName ps -> + RecSelPatSyn <$> tcLookupPatSyn ps + DataConName dc -> + RecSelData . dataConTyCon <$> tcLookupDataCon dc + where + any_con = head $ nonDetEltsUniqSet cons + -- Any constructor will give the same result here. + +tcLookupClass :: Name -> TcM Class +tcLookupClass name = do + thing <- tcLookupGlobal name + case thing of + ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls + _ -> wrongThingErr WrongThingClass (AGlobal thing) name + +tcLookupTyCon :: Name -> TcM TyCon +tcLookupTyCon name = do + thing <- tcLookupGlobal name + case thing of + ATyCon tc -> return tc + _ -> wrongThingErr WrongThingTyCon (AGlobal thing) name + +tcLookupAxiom :: Name -> TcM (CoAxiom Branched) +tcLookupAxiom name = do + thing <- tcLookupGlobal name + case thing of + ACoAxiom ax -> return ax + _ -> wrongThingErr WrongThingAxiom (AGlobal thing) name + +tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id +tcLookupLocatedGlobalId = addLocM tcLookupId + +tcLookupLocatedClass :: LocatedA Name -> TcM Class +tcLookupLocatedClass = addLocM tcLookupClass + +tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon +tcLookupLocatedTyCon = addLocM tcLookupTyCon + +-- Find the instance that exactly matches a type class application. The class arguments must be precisely +-- the same as in the instance declaration (modulo renaming & casts). +-- +tcLookupInstance :: Class -> [Type] -> TcM ClsInst +tcLookupInstance cls tys + = do { instEnv <- tcGetInstEnvs + ; let inst = lookupUniqueInstEnv instEnv cls tys >>= \ (inst, tys) -> + if uniqueTyVars tys then Right inst else Left LookupInstErrNotExact + ; case inst of + Right i -> return i + Left err -> failWithTc (TcRnLookupInstance cls tys err) + } + where + uniqueTyVars tys = all isTyVarTy tys + && hasNoDups (map getTyVar tys) + +-- | Get the default types for classes +-- explicitly not combined to be use for `reportClashingDefaultImports` +tcGetClsDefaults :: [Module] -> TcM [DefaultEnv] +tcGetClsDefaults mods = do + hug <- hsc_HUG <$> getTopEnv + module_env_defaults <- eps_defaults <$> getEps + liftIO $ mapMaybeM (lookupClsDefault hug module_env_defaults) mods + +lookupClsDefault :: HomeUnitGraph -> ModuleEnv DefaultEnv -> Module -> IO (Maybe DefaultEnv) +lookupClsDefault hug module_env_defaults mod = + lookupHugByModule mod hug >>= \case + Just hm -> pure $ Just $ md_defaults $ hm_details hm + Nothing -> pure $ lookupModuleEnv module_env_defaults mod + +tcGetInstEnvs :: TcM InstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +tcGetInstEnvs = do { eps <- getEps + ; env <- getGblEnv + ; return (InstEnvs { ie_global = eps_inst_env eps + , ie_local = tcg_inst_env env + , ie_visible = tcVisibleOrphanMods env }) } + +instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where + lookupThing = tcLookupGlobal + +-- Illegal term-level use of type things +failIllegalTyCon :: WhatLooking -> WithUserRdr Name -> TcM a +failIllegalTyVar :: WithUserRdr Name -> TcM a +(failIllegalTyCon, failIllegalTyVar) = (fail_tycon, fail_tyvar) + where + fail_tycon what_looking (WithUserRdr rdr tc_nm) = do + gre <- getGlobalRdrEnv + let mb_gre = lookupGRE_Name gre tc_nm + err = case greInfo <$> mb_gre of + Just (IAmTyCon ClassFlavour) -> ClassTE + _ -> TyConTE + fail_with_msg what_looking dataName rdr tc_nm (TermLevelUseGRE <$> mb_gre) err + + fail_tyvar (WithUserRdr rdr nm) = + fail_with_msg WL_Term varName rdr nm (Just TermLevelUseTyVar) TyVarTE + + fail_with_msg what_looking whatName rdr nm pprov err = do + required_type_arguments <- xoptM LangExt.RequiredTypeArguments + (imp_errs, hints) <- get_suggestions required_type_arguments what_looking whatName rdr + hfdc <- getHoleFitDispConfig + unit_state <- hsc_units <$> getTopEnv + let + want_simple = want_simple_msg hints + msg = TcRnIllegalTermLevelUse want_simple rdr nm err + info = ErrInfo { errInfoContext = + if want_simple + then [] + else maybeToList $ fmap (TermLevelUseCtxt nm) pprov + , errInfoSupplementary = + fmap ((hfdc,) . (:[]) . SupplementaryImportErrors) $ + NE.nonEmpty imp_errs + , errInfoHints = hints + } + failWithTc $ TcRnMessageWithInfo unit_state (mkDetailedMessage info msg) + + get_suggestions required_type_arguments what_looking ns rdr = do + show_helpful_errors <- goptM Opt_HelpfulErrors + if not show_helpful_errors || (required_type_arguments && isVarNameSpace ns) + then return ([], []) -- See Note [Suppress hints with RequiredTypeArguments] + else do + let rdr' = fromMaybe rdr (demoteRdrName rdr) + lcl_env <- getLocalRdrEnv + unknownNameSuggestions lcl_env what_looking rdr' + +-- | Should we display a simpler "out of scope" message to the user, instead of +-- a full-blown "illegal term-level use" message? +-- +-- See Note [Simpler "illegal term-level use" errors] +want_simple_msg :: [GhcHint] -> Bool +want_simple_msg hints = any relevant_suggestion hints + where + relevant_suggestion = \case + ImportSuggestion {} -> True + SuggestSimilarNames {} -> True + _ -> False + +{- Note [Simpler "illegal term-level use" errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we rename the occurrence of A in the definition of 'f' in the following program: + + module M1 where + data A = A Int + module M2 where + import M1 (A) + f x = A x + +we initially resolve 'A' to the type constructor 'A', in order to support +-XRequiredTypeArguments. Then we come to find out that a type is illegal in +this position. It is more user-friendly to report the problem as: + + Data constructor out of scope: A + +rather than: + + Illegal term-level use of type constructor A + +This was reported in #23982. + +To achieve this, in 'failIllegalTyCon' and 'failIllegalTyVar', we include a +little heuristic to decide whether to emit an "out of scope" message rather than +an "illegal term-level use" message: when we have a term to suggest to the user, +then give the simpler "out of scope" error message. + +For instance, in the example above, we suggest extending the import list to + + import M1 (A(A)) + +to bring the data constructor A into scope. We thus emit the following message: + + Data constructor out of scope: A + Suggested fix: + Add ‘A’ to the import list in the import of M1 + +************************************************************************ +* * + Extending the global environment +* * +************************************************************************ +-} + +setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv +-- Use this to update the global type env +-- It updates both * the normal tcg_type_env field +-- * the tcg_type_env_var field seen by interface files +setGlobalTypeEnv tcg_env new_type_env + = do { -- Sync the type-envt variable seen by interface files + ; case lookupKnotVars (tcg_type_env_var tcg_env) (tcg_mod tcg_env) of + Just tcg_env_var -> writeMutVar tcg_env_var new_type_env + Nothing -> return () + ; return (tcg_env { tcg_type_env = new_type_env }) } + + +tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r + -- Just extend the global environment with some TyThings + -- Do not extend tcg_tcs, tcg_patsyns etc +tcExtendGlobalEnvImplicit things thing_inside + = do { tcg_env <- getGblEnv + ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } + +tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r + -- Given a mixture of Ids, TyCons, Classes, all defined in the + -- module being compiled, extend the global environment +tcExtendGlobalEnv things thing_inside + = do { env <- getGblEnv + ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env, + tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env } + ; setGblEnv env' $ + tcExtendGlobalEnvImplicit things thing_inside + } + +tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r + -- Given a mixture of Ids, TyCons, Classes, all defined in the + -- module being compiled, extend the global environment +tcExtendTyConEnv tycons thing_inside + = do { env <- getGblEnv + ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env } + ; setGblEnv env' $ + tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside + } + +-- Given a [TyThing] of "non-value" bindings coming from type decls +-- (constructors, field selectors, class methods) return their +-- TH binding levels (to be added to a LclEnv). +-- See GHC ticket #17820 . +tcTyThBinders :: [TyThing] -> TcM ThBindEnv +tcTyThBinders implicit_things = do + th_lvl <- thLevelIndex <$> getThLevel + let th_bndrs = mkNameEnv + [ ( n , (TopLevel, th_lvl) ) | n <- names ] + return th_bndrs + where + names = concatMap get_names implicit_things + get_names (AConLike acl) = + conLikeName acl : map flSelector (conLikeFieldLabels acl) + get_names (AnId i) = [idName i] + get_names _ = [] + +tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a + -- Same deal as tcExtendGlobalEnv, but for Ids +tcExtendGlobalValEnv ids thing_inside + = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside + +tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r +-- Extend the global environments for the type/class knot tying game +-- Just like tcExtendGlobalEnv, except the argument is a list of pairs +tcExtendRecEnv gbl_stuff thing_inside + = do { tcg_env <- getGblEnv + ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff + tcg_env' = tcg_env { tcg_type_env = ge' } + -- No need for setGlobalTypeEnv (which side-effects the + -- tcg_type_env_var); tcExtendRecEnv is used just + -- when kind-check a group of type/class decls. It would + -- in any case be wrong for an interface-file decl to end up + -- with a TcTyCon in it! + ; setGblEnv tcg_env' thing_inside } + +{- +************************************************************************ +* * +\subsection{The local environment} +* * +************************************************************************ +-} + +tcLookupLocated :: LocatedA Name -> TcM TcTyThing +tcLookupLocated = addLocM tcLookup + +tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) +tcLookupLcl_maybe name + = do { local_env <- getLclTypeEnv + ; return (lookupNameEnv local_env name) } + +tcLookup :: Name -> TcM TcTyThing +tcLookup name = do + local_env <- getLclTypeEnv + case lookupNameEnv local_env name of + Just thing -> return thing + Nothing -> AGlobal <$> tcLookupGlobal name + +tcLookupTyVar :: Name -> TcM TcTyVar +tcLookupTyVar name + = do { thing <- tcLookup name + ; case thing of + ATyVar _ tv -> return tv + _ -> pprPanic "tcLookupTyVar" (ppr name) } + +tcLookupId :: Name -> TcM Id +-- Used when we aren't interested in the binding level, nor refinement. +-- The "no refinement" part means that we return the un-refined Id regardless +-- +-- The Id is never a DataCon. (Why does that matter? see GHC.Tc.Gen.Expr.tcId) +tcLookupId name = do + thing <- tcLookupIdMaybe name + case thing of + Just id -> return id + _ -> pprPanic "tcLookupId" (ppr name) + +tcLookupIdMaybe :: Name -> TcM (Maybe Id) +tcLookupIdMaybe name + = do { thing <- tcLookup name + ; case thing of + ATcId { tct_id = id} -> return $ Just id + AGlobal (AnId id) -> return $ Just id + _ -> return Nothing } + +tcLookupLocalIds :: [Name] -> TcM [TcId] +-- We expect the variables to all be bound, and all at +-- the same level as the lookup. Only used in one place... +tcLookupLocalIds ns + = do { env <- getLclEnv + ; return (map (lookup (getLclEnvTypeEnv env)) ns) } + where + lookup lenv name + = case lookupNameEnv lenv name of + Just (ATcId { tct_id = id }) -> id + _ -> pprPanic "tcLookupLocalIds" (ppr name) + +-- inferInitialKind has made a suitably-shaped kind for the type or class +-- Look it up in the local environment. This is used only for tycons +-- that we're currently type-checking, so we're sure to find a TcTyCon. +tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon +tcLookupTcTyCon name = do + thing <- tcLookup name + case thing of + ATcTyCon tc -> return tc + _ -> pprPanic "tcLookupTcTyCon" (ppr name) + + +getInLocalScope :: TcM (Name -> Bool) +getInLocalScope = do { lcl_env <- getLclTypeEnv + ; return (`elemNameEnv` lcl_env) } + +tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r +-- Used only during kind checking, for TcThings that are +-- ATcTyCon or APromotionErr +-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr +tcExtendKindEnvList things thing_inside + = do { traceTc "tcExtendKindEnvList" (ppr things) + ; updLclCtxt upd_env thing_inside } + where + upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things } + +tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r +-- A variant of tcExtendKindEvnList +tcExtendKindEnv extra_env thing_inside + = do { traceTc "tcExtendKindEnv" (ppr extra_env) + ; updLclCtxt upd_env thing_inside } + where + upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env } + +----------------------- +-- Scoped type and kind variables +tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r +tcExtendTyVarEnv tvs thing_inside + -- MP: This silently coerces TyVar to TcTyVar. + = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside + +tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r +tcExtendNameTyVarEnv binds thing_inside + -- this should be used only for explicitly mentioned scoped variables. + -- thus, no coercion variables + = tc_extend_local_env NotTopLevel names $ + tcExtendBinderStack tv_binds $ + thing_inside + where + tv_binds :: [TcBinder] + tv_binds = [TcTvBndr name tv | (name,tv) <- binds] + + names = [(name, ATyVar name tv) | (name, tv) <- binds] + +isTypeClosedLetBndr :: Id -> Bool +-- See Note [Bindings with closed types: ClosedTypeId] in GHC.Tc.Types +isTypeClosedLetBndr = noFreeVarsOfType . idType + +tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a +-- Used for binding the recursive uses of Ids in a binding +-- both top-level value bindings and nested let/where-bindings +-- Does not extend the TcBinderStack +tcExtendRecIds pairs thing_inside + = tc_extend_local_env NotTopLevel + [ (name, ATcId { tct_id = let_id + , tct_info = NonClosedLet emptyNameSet False }) + | (name, let_id) <- pairs ] $ + thing_inside + +tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a +-- Used for binding the Ids that have a complete user type signature +-- Does not extend the TcBinderStack +tcExtendSigIds top_lvl sig_ids thing_inside + = tc_extend_local_env top_lvl + [ (idName id, ATcId { tct_id = id + , tct_info = info }) + | id <- sig_ids + , let closed = isTypeClosedLetBndr id + info = NonClosedLet emptyNameSet closed ] + thing_inside + + +tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed + -> [Scaled TcId] -> TcM a -> TcM a +-- Used for both top-level value bindings and nested let/where-bindings +-- Adds to the TcBinderStack too +tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) + ids thing_inside + = tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $ + tc_extend_local_env top_lvl + [ (idName id, ATcId { tct_id = id + , tct_info = mk_tct_info id }) + | Scaled _ id <- ids ] $ + foldr check_usage thing_inside scaled_names + where + mk_tct_info id + | type_closed && isEmptyNameSet rhs_fvs = ClosedLet + | otherwise = NonClosedLet rhs_fvs type_closed + where + name = idName id + rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet + type_closed = isTypeClosedLetBndr id && + (fv_type_closed || hasCompleteSig sig_fn name) + scaled_names = [Scaled p (idName id) | Scaled p id <- ids ] + check_usage :: Scaled Name -> TcM a -> TcM a + check_usage (Scaled p id) thing_inside = do + tcCheckUsage id p thing_inside + +tcExtendIdEnv :: [TcId] -> TcM a -> TcM a +-- For lambda-bound and case-bound Ids +-- Extends the TcBinderStack as well +tcExtendIdEnv ids thing_inside + = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside + +tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a +-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair +tcExtendIdEnv1 name id thing_inside + = tcExtendIdEnv2 [(name,id)] thing_inside + +tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a +tcExtendIdEnv2 names_w_ids thing_inside + = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel + | (_,mono_id) <- names_w_ids ] $ + tc_extend_local_env NotTopLevel + [ (name, ATcId { tct_id = id + , tct_info = NotLetBound }) + | (name,id) <- names_w_ids] + thing_inside + +tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a +tc_extend_local_env top_lvl extra_env thing_inside +-- Precondition: the argument list extra_env has TcTyThings +-- that ATcId or ATyVar, but nothing else +-- +-- Invariant: the ATcIds are fully zonked. Reasons: +-- (a) The kinds of the forall'd type variables are defaulted +-- (see Kind.defaultKind, done in skolemiseQuantifiedTyVar) +-- (b) There are no via-Indirect occurrences of the bound variables +-- in the types, because instantiation does not look through such things +-- (c) The call to tyCoVarsOfTypes is ok without looking through refs + +-- The second argument of type TyVarSet is a set of type variables +-- that are bound together with extra_env and should not be regarded +-- as free in the types of extra_env. + = do { traceTc "tc_extend_local_env" (ppr extra_env) + ; updLclCtxt upd_lcl_env thing_inside } + where + upd_lcl_env env0@(TcLclCtxt { tcl_th_ctxt = th_lvl + , tcl_rdr = rdr_env + , tcl_th_bndrs = th_bndrs + , tcl_env = lcl_type_env }) + = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env + [ n | (n, _) <- extra_env, isInternalName n ] + -- The LocalRdrEnv contains only non-top-level names + -- (GlobalRdrEnv handles the top level) + + , tcl_th_bndrs = extendNameEnvList th_bndrs + [(n, thlvl) | (n, _) <- extra_env] + + , 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, thLevelIndex th_lvl) + + +tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcLclCtxt -> TcLclCtxt +tcExtendLocalTypeEnv tc_ty_things lcl_env@(TcLclCtxt { tcl_env = lcl_type_env }) + = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } + +{- ********************************************************************* +* * + The TcBinderStack +* * +********************************************************************* -} + +tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a +tcExtendBinderStack bndrs thing_inside + = do { traceTc "tcExtendBinderStack" (ppr bndrs) + ; updLclCtxt (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) + thing_inside } + +{- ********************************************************************* +* * + Adding placeholders +* * +********************************************************************* -} + +tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a +-- See Note [AFamDataCon: not promoting data family constructors] +tcAddDataFamConPlaceholders inst_decls thing_inside + = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE) + | lid <- inst_decls, con <- get_cons lid ] + thing_inside + -- Note [AFamDataCon: not promoting data family constructors] + where + -- get_cons extracts the *constructor* bindings of the declaration + get_cons :: LInstDecl GhcRn -> [Name] + get_cons (L _ (TyFamInstD {})) = [] + get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid + get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) + = concatMap (get_fi_cons . unLoc) fids + + get_fi_cons :: DataFamInstDecl GhcRn -> [Name] + get_fi_cons (DataFamInstDecl { dfid_eqn = + FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}) + = map unLoc $ concatMap (getConNames . unLoc) cons + + +tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a +-- See Note [Don't promote pattern synonyms] +tcAddPatSynPlaceholders pat_syns thing_inside + = tcExtendKindEnvList [ (name, APromotionErr PatSynPE) + | PSB{ psb_id = L _ name } <- pat_syns ] + thing_inside + +tcAddKindSigPlaceholders :: LHsKind GhcRn -> TcM a -> TcM a +tcAddKindSigPlaceholders kind_sig thing_inside + = tcExtendKindEnvList [ (name, APromotionErr TypeVariablePE) + | name <- hsScopedKvs kind_sig ] + thing_inside + +getTypeSigNames :: [LSig GhcRn] -> NameSet +-- Get the names that have a user type sig +getTypeSigNames sigs + = foldr get_type_sig emptyNameSet sigs + where + get_type_sig :: LSig GhcRn -> NameSet -> NameSet + get_type_sig sig ns = + case sig of + L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names) + L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names) + _ -> ns + + +{- Note [AFamDataCon: not promoting data family constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T Int = MkT + data Proxy (a :: k) + data S = MkS (Proxy 'MkT) + +Is it ok to use the promoted data family instance constructor 'MkT' in +the data declaration for S (where both declarations live in the same module)? +No, we don't allow this. It *might* make sense, but at least it would mean that +we'd have to interleave typechecking instances and data types, whereas at +present we do data types *then* instances. + +So to check for this we put in the TcLclEnv a binding for all the family +constructors, bound to AFamDataCon, so that if we trip over 'MkT' when +type checking 'S' we'll produce a decent error message. + +#12088 describes this limitation. Of course, when MkT and S live in +different modules then all is well. + +Note [Don't promote pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never promote pattern synonyms. + +Consider this (#11265): + pattern A = True + instance Eq A +We want a civilised error message from the occurrence of 'A' +in the instance, yet 'A' really has not yet been type checked. + +Similarly (#9161) + {-# LANGUAGE PatternSynonyms, DataKinds #-} + pattern A = () + b :: A + b = undefined +Here, the type signature for b mentions A. But A is a pattern +synonym, which is typechecked as part of a group of bindings (for very +good reasons; a view pattern in the RHS may mention a value binding). +It is entirely reasonable to reject this, but to do so we need A to be +in the kind environment when kind-checking the signature for B. + +Hence tcAddPatSynPlaceholders adds a binding + A -> APromotionErr PatSynPE +to the environment. Then GHC.Tc.Gen.HsType.tcTyVar will find A in the kind +environment, and will give a 'wrongThingErr' as a result. But the +lookup of A won't fail. + + +************************************************************************ +* * +\subsection{Rules} +* * +************************************************************************ +-} + +tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a + -- Just pop the new rules into the EPS and envt resp + -- All the rules come from an interface file, not source + -- Nevertheless, some may be for this module, if we read + -- its interface instead of its source code +tcExtendRules lcl_rules thing_inside + = do { env <- getGblEnv + ; let + env' = env { tcg_rules = lcl_rules ++ tcg_rules env } + ; setGblEnv env' thing_inside } + +{- +************************************************************************ +* * + Meta level +* * +************************************************************************ +-} + +tcMetaTy :: Name -> TcM Type +-- Given the name of a Template Haskell data type, +-- return the type +-- E.g. given the name "Expr" return the type "Expr" +tcMetaTy tc_name = do + t <- tcLookupTyCon tc_name + return (mkTyConTy t) + +isBrackLevel :: ThLevel -> Bool +isBrackLevel (Brack {}) = True +isBrackLevel _other = False + +{- +************************************************************************ +* * + getDefaultTys +* * +************************************************************************ +-} + +{- Note [Builtin class defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the absence of user-defined `default` declarations, the set of class defaults in +effect (i.e. the `DefaultEnv`) depends on whether the `ExtendedDefaultRules` and +`OverloadedStrings` extensions are enabled. In their absence, the only rule in effect +is `default Num (Integer, Double)`, as specified by the Haskell 2010 report. + +Remark [No built-in defaults in ghc-internal] + + When typechecking the ghc-internal package, we **do not** include any built-in + defaults. This is because, in ghc-internal, types such as 'Num' or 'Integer' may + not even be available (they haven't been typechecked yet). + +Remark [default () in ghc-internal] + + Historically, modules inside ghc-internal have used a single default declaration, + of the form `default ()`, to work around the problem described in + Remark [No built-in defaults in ghc-internal]. + + When we typecheck such a default declaration, we must also make sure not to fail + if e.g. 'Num' is not in scope. We thus have special treatment for this case, + in 'GHC.Tc.Gen.Default.tcDefaultDecls'. +-} + +tcGetDefaultTys :: TcM (DefaultEnv, -- Default classes and types + Bool) -- True <=> Use extended defaulting rules +tcGetDefaultTys + = do { dflags <- getDynFlags + ; let ovl_strings = xopt LangExt.OverloadedStrings dflags + extended_defaults = xopt LangExt.ExtendedDefaultRules dflags + -- See also #1974 + builtinDefaults cls tys = ClassDefaults{ cd_class = cls + , cd_types = tys + , cd_provenance = DP_Builtin + , cd_warn = Nothing } + + -- see Note [Named default declarations] in GHC.Tc.Gen.Default + ; defaults <- getDeclaredDefaultTys -- User-supplied defaults + ; this_module <- tcg_mod <$> getGblEnv + ; let this_unit = moduleUnit this_module + ; if this_unit == ghcInternalUnit + -- see Remark [No built-in defaults in ghc-internal] + -- in Note [Builtin class defaults] in GHC.Tc.Utils.Env + then return (defaults, extended_defaults) + else do + -- not one of the built-in units + -- @default Num (Integer, Double)@, plus extensions + { extDef <- if extended_defaults + then do { list_ty <- tcMetaTy listTyConName + ; integer_ty <- tcMetaTy integerTyConName + ; foldableClass <- tcLookupClass foldableClassName + ; showClass <- tcLookupClass showClassName + ; eqClass <- tcLookupClass eqClassName + ; pure $ defaultEnv + [ builtinDefaults foldableClass [list_ty] + , builtinDefaults showClass [unitTy, integer_ty, doubleTy] + , builtinDefaults eqClass [unitTy, integer_ty, doubleTy] + ] + } + -- Note [Extended defaults] + else pure emptyDefaultEnv + ; ovlStr <- if ovl_strings + then do { isStringClass <- tcLookupClass isStringClassName + ; pure $ unitDefaultEnv $ builtinDefaults isStringClass [stringTy] + } + else pure emptyDefaultEnv + ; checkWiredInTyCon doubleTyCon + ; numDef <- case lookupDefaultEnv defaults numClassName of + Nothing -> do { integer_ty <- tcMetaTy integerTyConName + ; numClass <- tcLookupClass numClassName + ; pure $ unitDefaultEnv $ builtinDefaults numClass [integer_ty, doubleTy] + } + -- The Num class is already user-defaulted, no need to construct the builtin default + _ -> pure emptyDefaultEnv + -- Supply the built-in defaults, but make the user-supplied defaults + -- override them. + ; let deflt_tys = mconcat [ extDef, numDef, ovlStr, defaults ] + ; return (deflt_tys, extended_defaults) } } + +{- +Note [Extended defaults] +~~~~~~~~~~~~~~~~~~~~~~~~ +In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we +try when defaulting. This has very little real impact, except in the following case. +Consider: + Text.Printf.printf "hello" +This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't +want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to +default the 'a' to (), rather than to Integer (which is what would otherwise happen; +and then GHCi doesn't attempt to print the (). So in interactive mode, we add +() to the list of defaulting types. See #1200. + +Additionally, the list type [] is added as a default specialization for +Traversable and Foldable. As such the default default list now has types of +varying kinds, e.g. ([] :: * -> *) and (Integer :: *). + +************************************************************************ +* * +\subsection{The InstInfo type} +* * +************************************************************************ + +The InstInfo type summarises the information in an instance declaration + + instance c => k (t tvs) where b + +It is used just for *local* instance decls (not ones from interface files). +But local instance decls includes + - derived ones + - generic ones +as well as explicit user written ones. +-} + +data InstInfo a + = InstInfo + { iSpec :: ClsInst -- Includes the dfun id + , iBinds :: InstBindings a + } + +iDFunId :: InstInfo a -> DFunId +iDFunId info = instanceDFunId (iSpec info) + +data InstBindings a + = InstBindings + { ib_tyvars :: [Name] -- Names of the tyvars from the instance head + -- that are lexically in scope in the bindings + -- Must correspond 1-1 with the forall'd tyvars + -- of the dfun Id. When typechecking, we are + -- going to extend the typechecker's envt with + -- ib_tyvars -> dfun_forall_tyvars + + , ib_binds :: LHsBinds a -- Bindings for the instance methods + + , ib_pragmas :: [LSig a] -- User pragmas recorded for generating + -- specialised instances + + , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should + -- be enabled when type-checking + -- this instance; needed for + -- GeneralizedNewtypeDeriving + + , ib_derived :: Bool + -- True <=> This code was generated by GHC from a deriving clause + -- or standalone deriving declaration + -- Used only to improve error messages + } + +instance (OutputableBndrId a) + => Outputable (InstInfo (GhcPass a)) where + ppr = pprInstInfoDetails + +pprInstInfoDetails :: (OutputableBndrId a) + => InstInfo (GhcPass a) -> SDoc +pprInstInfoDetails info + = hang (pprInstanceHdr (iSpec info) <+> text "where") + 2 (details (iBinds info)) + where + details (InstBindings { ib_pragmas = p, ib_binds = b }) = + pprDeclList (pprLHsBindsForUser b p) + +simpleInstInfoClsTy :: InstInfo a -> (Class, Type) +simpleInstInfoClsTy info = case instanceHead (iSpec info) of + (_, cls, [ty]) -> (cls, ty) + _ -> panic "simpleInstInfoClsTy" + +simpleInstInfoTy :: InstInfo a -> Type +simpleInstInfoTy info = snd (simpleInstInfoClsTy info) + +simpleInstInfoTyCon :: InstInfo a -> TyCon + -- Gets the type constructor for a simple instance declaration, + -- i.e. one of the form instance (...) => C (T a b c) where ... +simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) + +-- | Make a name for the dict fun for an instance decl. It's an *external* +-- name, like other top-level names, and hence must be made with +-- newGlobalBinder. +newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name +newDFunName clas tys loc + = do { is_boot <- tcIsHsBootOrSig + ; mod <- getModule + ; let info_string = occNameString (getOccName clas) ++ + concatMap (occNameString . getDFunTyKey) tys + ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) + ; newGlobalBinder mod dfun_occ loc } + +newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name +newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locA loc) name [tys] + +newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name +newFamInstAxiomName (L loc name) branches + = mk_fam_inst_name mkInstTyCoOcc (locA loc) name branches + +mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name +mk_fam_inst_name adaptOcc loc tc_name tyss + = do { mod <- getModule + ; let info_string = occNameString (getOccName tc_name) ++ + intercalate "|" ty_strings + ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) + ; newGlobalBinder mod (adaptOcc occ) loc } + where + ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss + +{- +Stable names used for foreign exports and annotations. +For stable names, the name must be unique (see #1533). If the +same thing has several stable Ids based on it, the +top-level bindings generated must not have the same name. +Hence we create an External name (doesn't change), and we +append a Unique to the string right here. +-} + +mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromString str sig_ty loc occ_wrapper = do + uniq <- newUnique + mod <- getModule + nextWrapperNum <- tcg_next_wrapper_num <$> getGblEnv + name <- mkWrapperName nextWrapperNum "stable" str + let occ = mkVarOccFS name :: OccName + gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name + id = mkExportedVanillaId gnm sig_ty :: Id + return id + +mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromName nm = mkStableIdFromString (getOccString nm) + +mkWrapperName :: (MonadIO m, HasModule m) + => IORef (ModuleEnv Int) -> String -> String -> m FastString +-- ^ @mkWrapperName ref what nameBase@ +-- +-- See Note [Generating fresh names for FFI wrappers] for @ref@'s purpose. +mkWrapperName wrapperRef what nameBase + = do thisMod <- getModule + let pkg = unitString (moduleUnit thisMod) + mod = moduleNameString (moduleName thisMod) + wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env -> + let num = lookupWithDefaultModuleEnv mod_env 0 thisMod + mod_env' = extendModuleEnv mod_env thisMod (num+1) + in (mod_env', num) + let components = [what, show wrapperNum, pkg, mod, nameBase] + return $ mkFastString $ zEncodeString $ intercalate ":" components + +{- +Note [Generating fresh names for FFI wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to use a unique, rather than nextWrapperNum, to distinguish +between FFI wrapper functions. However, the wrapper names that we +generate are external names. This means that if a call to them ends up +in an unfolding, then we can't alpha-rename them, and thus if the +unique randomly changes from one compile to another then we get a +spurious ABI change (#4012). + +The wrapper counter has to be per-module, not global, so that the number we end +up using is not dependent on the modules compiled before the current one. +-} + +{- +************************************************************************ +* * +\subsection{Errors} +* * +************************************************************************ +-} + +pprBinders :: [Name] -> SDoc +-- Used in error messages +-- Use quotes for a single one; they look a bit "busy" for several +pprBinders [bndr] = quotes (ppr bndr) +pprBinders bndrs = pprWithCommas ppr bndrs + +notFound :: Name -> TcM TyThing +notFound name + = do { lcl_env <- getLclEnv + ; if isTermVarOrFieldNameSpace (nameNameSpace name) + then + -- This code path is only reachable with RequiredTypeArguments enabled + -- via the following chain of calls: + -- `notFound` called from + -- `tcLookupGlobal` called from + -- `tcLookup` called from + -- `tcTyVar` + -- It means the user tried to use a term variable at the type level, e.g. + -- let { a = 42; f :: a -> a; ... } in ... + -- If you are seeing this error for any other reason, it is a bug in GHC. + -- See Note [Demotion of unqualified variables] (W1) in GHC.Rename.Env + failWithTc $ TcRnUnpromotableThing name TermVariablePE + + else failWithTc $ + TcRnNotInScope (NotInScopeTc (getLclEnvTypeEnv lcl_env)) (getRdrName name) + -- Take care: printing the whole gbl env can + -- cause an infinite loop, in the case where we + -- are in the middle of a recursive TyCon/Class group; + -- so let's just not print it! Getting a loop here is + -- very unhelpful, because it hides one compiler bug with another + } + +wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a +wrongThingErr expected thing name = + failWithTc (TcRnTyThingUsedWrong expected thing name) + +{- Note [Out of scope might be a staging error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + x = 3 + data T = MkT $(foo x) + +where 'foo' is imported from somewhere. + +This is really a staging error, because we can't run code involving 'x'. +But in fact the type checker processes types first, so 'x' won't even be +in the type envt when we look for it in $(foo x). So inside splices we +report something missing from the type env as a staging error. +See #5752 and #5795. +-} diff --git a/GHC/Tc/Utils/Instantiate.hs b/GHC/Tc/Utils/Instantiate.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Instantiate.hs @@ -0,0 +1,1183 @@ +{-# LANGUAGE FlexibleContexts, RecursiveDo #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +module GHC.Tc.Utils.Instantiate ( + topSkolemise, skolemiseRequired, + topInstantiate, + instantiateSigma, + instCall, instDFunType, instStupidTheta, instTyVarsWith, + newWanted, newWanteds, + + tcInstType, tcInstTypeBndrs, + tcSkolemiseInvisibleBndrs, + tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarBndrsX, + tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, + + freshenTyVarBndrs, freshenCoVarBndrsX, + + tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, + + newOverloadedLit, mkOverLit, + + newClsInst, newFamInst, + tcGetInsts, tcGetInstEnvs, getOverlapFlag, + tcExtendLocalInstEnv, + instCallConstraints, newMethodFromName, + tcSyntaxName, + + -- Simple functions over evidence variables + tyCoVarsOfWC, + tyCoVarsOfCt, tyCoVarsOfCts, + ) where + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Driver.Env + +import GHC.Builtin.Types ( integerTyConName ) +import GHC.Builtin.Names + +import GHC.Hs +import GHC.Hs.Syn.Type ( hsLitType ) + +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Core ( isOrphan ) -- For the Coercion constructor +import GHC.Core.Type +import GHC.Core.TyCo.Ppr ( debugPprType ) +import GHC.Core.TyCo.Tidy ( tidyType ) +import GHC.Core.Class( Class ) +import GHC.Core.Coercion.Axiom + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Evidence +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Errors.Types +import GHC.Tc.Zonk.Monad ( ZonkM ) + +import GHC.Rename.Utils( mkRnSyntaxExpr ) + +import GHC.Types.Id.Make( mkDictFunId ) +import GHC.Types.Basic ( TypeOrKind(..), Arity, VisArity ) +import GHC.Types.SourceText +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Reader (WithUserRdr(..)) +import GHC.Types.Var +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Utils.Unique (sameUnique) + +import GHC.Unit.State +import GHC.Unit.External +import GHC.Unit.Module.Warnings + +import Data.List ( mapAccumL ) +import qualified Data.List.NonEmpty as NE +import Control.Monad( when, unless ) +import Data.Function ( on ) + +{- +************************************************************************ +* * + Creating and emitting constraints +* * +************************************************************************ +-} + +newMethodFromName + :: CtOrigin -- ^ why do we need this? + -> Name -- ^ name of the method + -> [TcRhoType] -- ^ types with which to instantiate the class + -> TcM (HsExpr GhcTc) +-- ^ Used when 'Name' is the wired-in name for a wired-in class method, +-- so the caller knows its type for sure, which should be of form +-- +-- > forall a. C a => +-- +-- 'newMethodFromName' is supposed to instantiate just the outer +-- type variable and constraint + +newMethodFromName origin name ty_args + = do { id <- tcLookupId name + -- Use tcLookupId not tcLookupGlobalId; the method is almost + -- always a class op, but with -XRebindableSyntax GHC is + -- meant to find whatever thing is in scope, and that may + -- be an ordinary function. + + ; let ty = piResultTys (idType id) ty_args + (theta, _caller_knows_this) = tcSplitPhiTy ty + ; wrap <- assert (not (isForAllTy ty) && isSingleton theta) $ + instCall origin ty_args theta + + ; return (mkHsWrap wrap (mkHsVar (noLocA id))) } + +{- +************************************************************************ +* * + Instantiation and skolemisation +* * +************************************************************************ + +Note [Skolemisation] +~~~~~~~~~~~~~~~~~~~~ +topSkolemise decomposes and skolemises a type, returning a type +with no top level foralls or (=>). + +Examples: + + topSkolemise (forall a. Ord a => a -> a) + = ( wp, [a], [d:Ord a], a->a ) + where + wp = /\a. \(d:Ord a). a d + +For nested foralls, see Note [Skolemisation en-bloc] + +In general, + if topSkolemise ty = (wrap, tvs, evs, rho) + and e :: rho + then wrap e :: ty + and 'wrap' binds {tvs, evs} + +Note [Skolemisation en-bloc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this case: + + topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b) + +We /could/ return just + (wp, [a], [d:Ord a, forall b. Eq b => a -> b -> b) + +But in fact we skolemise "en-bloc", looping around (in `topSkolemise` for +example) to skolemise the (forall b. Eq b =>). So in fact + + topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b) + = ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b ) + where + wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). a d1 b d2 + +This applies regardless of DeepSubsumption. + +Why do we do this "en-bloc" loopy thing? It is /nearly/ just an optimisation. +But not quite! At the call site of `topSkolemise` (and its cousins) we +use `checkConstraints` to gather constraints and build an implication +constraint. So skolemising just one level at a time would lead to nested +implication constraints. That is a bit less efficient, but there is /also/ a small +user-visible effect: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet. +Specifically, consider + + forall a. Eq a => forall b. (a ~ [b]) => blah + +If we skolemise en-bloc, the equality (a~[b]) is like a let-binding and we +don't treat it like a GADT pattern match, limiting unification. With nested +implications, the inner one would be treated as having-given-equalities. + +This is also relevant when Required foralls are involved; see #24810, and +the loop in `skolemiseRequired`. +-} + +topSkolemise :: SkolemInfo + -> TcSigmaType + -> TcM ( HsWrapper + , [(Name,TcInvisTVBinder)] -- All skolemised variables + , [EvVar] -- All "given"s + , TcRhoType ) +-- See Note [Skolemisation] +topSkolemise skolem_info ty + = go init_subst idHsWrapper [] [] ty + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) + + -- Why recursive? See Note [Skolemisation en-bloc] + go subst wrap tv_prs ev_vars ty + | (bndrs, theta, inner_ty) <- tcSplitSigmaTyBndrs ty + , let tvs = binderVars bndrs + , not (null tvs && null theta) + = do { (subst', bndrs1) <- tcInstSkolTyVarBndrsX skolem_info subst bndrs + ; let tvs1 = binderVars bndrs1 + ; traceTc "topSkol" (vcat [ ppr tvs <+> vcat (map (ppr . getSrcSpan) tvs) + , ppr tvs1 <+> vcat (map (ppr . getSrcSpan) tvs1) ]) + ; ev_vars1 <- newEvVars (substTheta subst' theta) + ; go subst' + (wrap <.> mkWpTyLams tvs1 <.> mkWpEvLams ev_vars1) + (tv_prs ++ (map tyVarName tvs `zip` bndrs1)) + (ev_vars ++ ev_vars1) + inner_ty } + + | otherwise + = return (wrap, tv_prs, ev_vars, substTy subst ty) + -- substTy is a quick no-op on an empty substitution + +skolemiseRequired :: SkolemInfo -> VisArity -> TcSigmaType + -> TcM (VisArity, HsWrapper, [Name], [ForAllTyBinder], [EvVar], TcRhoType) +-- Skolemise up to N required (visible) binders, +-- plus any invisible ones "in the way", +-- /and/ any trailing invisible ones. +-- So the result has no top-level invisible quantifiers. +-- Return the depleted arity. +skolemiseRequired skolem_info n_req sigma + = go n_req init_subst idHsWrapper [] [] [] sigma + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType sigma)) + + -- Why recursive? See Note [Skolemisation en-bloc] + go n_req subst wrap acc_nms acc_bndrs ev_vars ty + | (n_req', bndrs, inner_ty) <- tcSplitForAllTyVarsReqTVBindersN n_req ty + , not (null bndrs) + = do { (subst', bndrs1) <- tcInstSkolTyVarBndrsX skolem_info subst bndrs + ; let tvs1 = binderVars bndrs1 + -- fix_up_vis: see Note [Required foralls in Core] + -- in GHC.Core.TyCo.Rep + fix_up_vis | n_req == n_req' + = idHsWrapper + | otherwise + = mkWpForAllCast bndrs1 (substTy subst' inner_ty) + ; go n_req' subst' + (wrap <.> fix_up_vis <.> mkWpTyLams tvs1) + (acc_nms ++ map (tyVarName . binderVar) bndrs) + (acc_bndrs ++ bndrs1) + ev_vars + inner_ty } + + | (theta, inner_ty) <- tcSplitPhiTy ty + , not (null theta) + = do { ev_vars1 <- newEvVars (substTheta subst theta) + ; go n_req subst + (wrap <.> mkWpEvLams ev_vars1) + acc_nms + acc_bndrs + (ev_vars ++ ev_vars1) + inner_ty } + + | otherwise + = return (n_req, wrap, acc_nms, acc_bndrs, ev_vars, substTy subst ty) + -- substTy is a quick no-op on an empty substitution + +topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +-- Instantiate outer invisible binders (both Inferred and Specified) +-- If top_instantiate ty = (wrap, inner_ty) +-- then wrap :: inner_ty "->" ty +-- NB: returns a type with no (=>), +-- and no invisible forall at the top +topInstantiate orig sigma + | (tvs, body1) <- tcSplitSomeForAllTyVars isInvisibleForAllTyFlag sigma + , (theta, body2) <- tcSplitPhiTy body1 + , not (null tvs && null theta) + = do { (_, wrap1, body3) <- instantiateSigma orig noConcreteTyVars tvs theta body2 + -- Why 'noConcreteTyVars' here? + -- See Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. + + -- Loop, to account for types like + -- forall a. Num a => forall b. Ord b => ... + ; (wrap2, body4) <- topInstantiate orig body3 + + ; return (wrap2 <.> wrap1, body4) } + + | otherwise = return (idHsWrapper, sigma) + +instantiateSigma :: CtOrigin + -> ConcreteTyVars -- ^ concreteness information + -> [TyVar] + -> TcThetaType -> TcSigmaType + -> TcM ([TcTyVar], HsWrapper, TcSigmaType) +-- (instantiate orig tvs theta ty) +-- instantiates the type variables tvs, emits the (instantiated) +-- constraints theta, and returns the (instantiated) type ty +instantiateSigma orig concs tvs theta body_ty + = do { rec (subst, inst_tvs) <- mapAccumLM (new_meta subst) empty_subst tvs + ; let inst_theta = substTheta subst theta + inst_body = substTy subst body_ty + inst_tv_tys = mkTyVarTys inst_tvs + + ; wrap <- instCall orig inst_tv_tys inst_theta + ; traceTc "Instantiating" + (vcat [ text "origin" <+> pprCtOrigin orig + , text "tvs" <+> ppr tvs + , text "theta" <+> ppr theta + , text "type" <+> debugPprType body_ty + , text "with" <+> vcat (map debugPprType inst_tv_tys) + , text "theta:" <+> ppr inst_theta ]) + + ; return (inst_tvs, wrap, inst_body) } + where + in_scope = mkInScopeSet (tyCoVarsOfType (mkSpecSigmaTy tvs theta body_ty)) + -- mkSpecSigmaTy: Inferred vs Specified is not important here; + -- We just want an accurate free-var set + empty_subst = mkEmptySubst in_scope + new_meta :: Subst -> Subst -> TyVar -> TcM (Subst, TcTyVar) + new_meta final_subst subst tv + -- Is this a type variable that must be instantiated to a concrete type? + -- If so, create a ConcreteTv metavariable instead of a plain TauTv. + -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete. + | Just conc_orig0 <- lookupNameEnv concs (tyVarName tv) + , let conc_orig = substConcreteTvOrigin final_subst body_ty conc_orig0 + -- See Note [substConcreteTvOrigin]. + = newConcreteTyVarX conc_orig subst tv + | otherwise + = newMetaTyVarX subst tv + +instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM Subst +-- Use this when you want to instantiate (forall a b c. ty) with +-- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might +-- not yet match (perhaps because there are unsolved constraints; #14154) +-- If they don't match, emit a kind-equality to promise that they will +-- eventually do so, and thus make a kind-homogeneous substitution. +instTyVarsWith orig tvs tys + = go emptySubst tvs tys + where + go subst [] [] + = return subst + go subst (tv:tvs) (ty:tys) + | tv_kind `tcEqType` ty_kind + = go (extendTvSubstAndInScope subst tv ty) tvs tys + | otherwise + = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind + ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys } + where + tv_kind = substTy subst (tyVarKind tv) + ty_kind = typeKind ty + + go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys) + + +{- +************************************************************************ +* * + Instantiating a call +* * +************************************************************************ + +Note [Handling boxed equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The solver deals entirely in terms of unboxed (primitive) equality. +There should never be a boxed Wanted equality. Ever. But, what if +we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality +is boxed, so naive treatment here would emit a boxed Wanted equality. + +So we simply check for this case and make the right boxing of evidence. + +-} + +---------------- +instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper +-- Instantiate the constraints of a call +-- (instCall o tys theta) +-- (a) Makes fresh dictionaries as necessary for the constraints (theta) +-- (b) Throws these dictionaries into the LIE +-- (c) Returns an HsWrapper ([.] tys dicts) + +instCall orig tys theta + = do { dict_app <- instCallConstraints orig theta + ; return (dict_app <.> mkWpTyApps tys) } + +---------------- +instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper +-- Instantiates the TcTheta, puts all constraints thereby generated +-- into the LIE, and returns a HsWrapper to enclose the call site. + +instCallConstraints orig preds + | null preds + = return idHsWrapper + | otherwise + = do { evs <- mapM (emitWanted orig) preds + -- See Note [Possible fast path for equality constraints] + ; traceTc "instCallConstraints" (ppr evs) + ; return (mkWpEvApps evs) } + +{- Note [Possible fast path for equality constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given f :: forall a b. (a ~ [b]) => a -> b -> blah +rather than emitting ([W] alpha ~ [beta]) we could imagine calling unifyType +right here. But note + +* Often such constraints look like (F a ~ G b), in which case unification would end up + spitting out a wanted-equality anyway. + +* So perhaps the main fast-path would be where the LHS or RHS was an instantiation + variable. But note that this could, perhaps, impact on Quick Look: + + - The first arg of `f` changes from the naked `a` to the guarded `[b]` (or would do so + if we zonked it). That might affect typing under Quick Look. + + - We might imagine using the let-bound skolems trick: + g :: forall a b. (a ~ forall c. c->c) => a -> [a] -> [a] + Here we are just using `a` as a local abreviation for (forall c. c->c) + See Note [Let-bound skolems] in GHC.Tc.Solver.InertSet. + + If we substitute aggressively (including zonking) that abbreviation could work. But + again it affects what is typeable. And we don't support equalities over polytypes, + currently, anyway. + +* There is little point in trying to optimise for + - (s ~# t), because this has kind Constraint#, not Constraint, and so will not be + in the theta instantiated in instCall + - (s ~~ t), becaues heterogeneous equality is rare, and more complicated. + +Anyway, for now we don't take advantage of these potential effects. +-} + +instDFunType :: DFunId -> [DFunInstType] + -> TcM ( [TcType] -- instantiated argument types + , TcThetaType ) -- instantiated constraint +-- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv +instDFunType dfun_id dfun_inst_tys + = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys + ; return (inst_tys, substTheta subst dfun_theta) } + where + dfun_ty = idType dfun_id + (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty + empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType dfun_ty)) + -- With quantified constraints, the + -- type of a dfun may not be closed + + go :: Subst -> [TyVar] -> [DFunInstType] -> TcM (Subst, [TcType]) + go subst [] [] = return (subst, []) + go subst (tv:tvs) (Just ty : mb_tys) + = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty) + tvs + mb_tys + ; return (subst', ty : tys) } + go subst (tv:tvs) (Nothing : mb_tys) + = do { (subst', tv') <- newMetaTyVarX subst tv + ; (subst'', tys) <- go subst' tvs mb_tys + ; return (subst'', mkTyVarTy tv' : tys) } + go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys) + +---------------- +instStupidTheta :: CtOrigin -> TcThetaType -> TcM () +-- Similar to instCall, but only emit the constraints in the LIE +-- Used exclusively for the 'stupid theta' of a data constructor +instStupidTheta orig theta + = do { _co <- instCallConstraints orig theta -- Discard the coercion + ; return () } + + +{- ********************************************************************* +* * + Instantiating Kinds +* * +********************************************************************* -} + +-- | Given ty::forall k1 k2. k, instantiate all the invisible forall-binders +-- returning ty @kk1 @kk2 :: k[kk1/k1, kk2/k1] +-- Called only to instantiate kinds, in user-written type signatures +tcInstInvisibleTyBinders :: TcType -> TcKind -> TcM (TcType, TcKind) +tcInstInvisibleTyBinders ty kind + = do { (extra_args, kind') <- tcInstInvisibleTyBindersN n_invis kind + ; return (mkAppTys ty extra_args, kind') } + where + n_invis = invisibleBndrCount kind + -- We are re-using tcInstInvisibleTyBindersN, which is + -- needed elsewhere; so all that matters is that n_invis + -- is big enough! Does not matter if it is too big. + -- 10,000 would do equally well :-) + +tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind) +-- Called only to instantiate kinds, in user-written type signatures +tcInstInvisibleTyBindersN 0 kind + = return ([], kind) +tcInstInvisibleTyBindersN n ty + = go n empty_subst ty + where + empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) + + go n subst kind + | n > 0 + , Just (bndr, body) <- tcSplitForAllTyVarBinder_maybe kind + , isInvisibleForAllTyFlag (binderFlag bndr) + = do { (subst', arg) <- tcInstInvisibleTyBinder subst (binderVar bndr) + ; (args, inner_ty) <- go (n-1) subst' body + ; return (arg:args, inner_ty) } + | otherwise + = return ([], substTy subst kind) + +tcInstInvisibleTyBinder :: Subst -> TyVar -> TcM (Subst, TcType) +-- Called only to instantiate kinds, in user-written type signatures + +tcInstInvisibleTyBinder subst tv + = do { (subst', tv') <- newMetaTyVarX subst tv + ; return (subst', mkTyVarTy tv') } + +{- ********************************************************************* +* * + SkolemTvs (immutable) +* * +********************************************************************* -} + +tcInstType :: ([TyVar] -> TcM (Subst, [TcTyVar])) + -- ^ How to instantiate the type variables + -> Id -- ^ Type to instantiate + -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result + -- (type vars, preds (incl equalities), rho) +tcInstType inst_tyvars id + | null tyvars -- There may be overloading despite no type variables; + -- (?x :: Int) => Int -> Int + = return ([], theta, tau) + | otherwise + = do { (subst, tyvars') <- inst_tyvars tyvars + ; let tv_prs = map tyVarName tyvars `zip` tyvars' + subst' = extendSubstInScopeSet subst (tyCoVarsOfType rho) + ; return (tv_prs, substTheta subst' theta, substTy subst' tau) } + where + (tyvars, rho) = tcSplitForAllInvisTyVars (idType id) + (theta, tau) = tcSplitPhiTy rho + +tcInstTypeBndrs :: Type -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType) + -- (type vars, preds (incl equalities), rho) +-- Instantiate the binders of a type signature with TyVarTvs +tcInstTypeBndrs poly_ty + | null tyvars -- There may be overloading despite no type variables; + -- (?x :: Int) => Int -> Int + = return ([], theta, tau) + | otherwise + = do { (subst, tyvars') <- mapAccumLM inst_invis_bndr emptySubst tyvars + ; let tv_prs = map (tyVarName . binderVar) tyvars `zip` tyvars' + subst' = extendSubstInScopeSet subst (tyCoVarsOfType rho) + ; return (tv_prs, substTheta subst' theta, substTy subst' tau) } + where + (tyvars, rho) = tcSplitForAllInvisTVBinders poly_ty + (theta, tau) = tcSplitPhiTy rho + + inst_invis_bndr :: Subst -> InvisTVBinder + -> TcM (Subst, InvisTVBinder) + inst_invis_bndr subst (Bndr tv spec) + = do { (subst', tv') <- newMetaTyVarTyVarX subst tv + ; return (subst', Bndr tv' spec) } + +-------------------------- +tcSkolDFunType :: Type -> TcM (SkolemInfoAnon, [TcTyVar], TcThetaType, Class, [TcType]) +-- Instantiate a type signature with skolem constants. +-- This freshens the names, but no need to do so +tcSkolDFunType dfun_ty + = do { let (tvs, theta, cls, tys) = tcSplitDFunTy dfun_ty + + -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; rec { skol_info <- mkSkolemInfo skol_info_anon + ; (subst, inst_tvs) <- tcInstSuperSkolTyVars skol_info tvs + -- We instantiate the dfun_tyd with superSkolems. + -- See Note [Subtle interaction of recursion and overlap] + -- and Note [Super skolems: binding when looking up instances] + ; let inst_tys = substTys subst tys + skol_info_anon = InstSkol IsClsInst (pSizeClassPred cls inst_tys) + -- We need to take the size of `inst_tys` (not `tys`) because + -- Paterson sizes mention the free type variables + } + + ; let inst_theta = substTheta subst theta + ; return (skol_info_anon, inst_tvs, inst_theta, cls, inst_tys) } + +tcSuperSkolTyVars :: TcLevel -> SkolemInfo -> [TyVar] -> (Subst, [TcTyVar]) +-- Make skolem constants, but do *not* give them new names, as above +-- As always, allocate them one level in +-- Moreover, make them "super skolems"; see GHC.Core.InstEnv +-- Note [Super skolems: binding when looking up instances] +-- See Note [Kind substitution when instantiating] +-- Precondition: tyvars should be ordered by scoping +tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptySubst + where + details = SkolemTv skol_info (pushTcLevel tc_lvl) + True -- The "super" bit + do_one subst tv = (extendTvSubstWithClone subst tv new_tv, new_tv) + where + kind = substTyUnchecked subst (tyVarKind tv) + new_tv = mkTcTyVar (tyVarName tv) kind details + +-- | Given a list of @['TyVar']@, skolemize the type variables, +-- returning a substitution mapping the original tyvars to the +-- skolems, and the list of newly bound skolems. +tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (Subst, [TcTyVar]) +-- See Note [Skolemising type variables] +tcInstSkolTyVars skol_info = tcInstSkolTyVarsX skol_info emptySubst + +tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) +-- See Note [Skolemising type variables] +tcInstSkolTyVarsX skol_info = tcInstSkolTyVarsPushLevel skol_info False + +tcInstSkolTyVarBndrsX :: SkolemInfo -> Subst -> [VarBndr TyCoVar vis] -> TcM (Subst, [VarBndr TyCoVar vis]) +tcInstSkolTyVarBndrsX skol_info subs bndrs = do + (subst', bndrs') <- tcInstSkolTyVarsX skol_info subs (binderVars bndrs) + pure (subst', zipWith mkForAllTyBinder flags bndrs') + where + flags = binderFlags bndrs + +tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (Subst, [TcTyVar]) +-- See Note [Skolemising type variables] +-- This version freshens the names and creates "super skolems"; +-- see comments around superSkolemTv. +-- Must be lazy in skol_info: +-- see Note [Keeping SkolemInfo inside a SkolemTv] in GHC.Tc.Utils.TcType +tcInstSuperSkolTyVars skol_info = tcInstSuperSkolTyVarsX skol_info emptySubst + +tcInstSuperSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) +-- See Note [Skolemising type variables] +-- This version freshens the names and creates "super skolems"; +-- see comments around superSkolemTv. +tcInstSuperSkolTyVarsX skol_info subst = tcInstSkolTyVarsPushLevel skol_info True subst + +tcInstSkolTyVarsPushLevel :: SkolemInfo -> Bool -- True <=> make "super skolem" + -> Subst -> [TyVar] + -> TcM (Subst, [TcTyVar]) +-- Skolemise one level deeper, hence pushTcLevel +-- See Note [Skolemising type variables] +tcInstSkolTyVarsPushLevel skol_info overlappable subst tvs + = do { tc_lvl <- getTcLevel + -- Do not retain the whole TcLclEnv + ; let !pushed_lvl = pushTcLevel tc_lvl + ; tcInstSkolTyVarsAt skol_info pushed_lvl overlappable subst tvs } + +tcInstSkolTyVarsAt :: SkolemInfo -> TcLevel -> Bool + -> Subst -> [TyVar] + -> TcM (Subst, [TcTyVar]) +tcInstSkolTyVarsAt skol_info lvl overlappable subst tvs + = freshenTyCoVarsX new_skol_tv subst tvs + where + sk_details = SkolemTv skol_info lvl overlappable + new_skol_tv name kind = mkTcTyVar name kind sk_details + +tcSkolemiseInvisibleBndrs :: SkolemInfoAnon -> Type -> TcM ([TcTyVar], TcType) +-- Skolemise the outer invisible binders of a type +-- Do /not/ freshen them, because their scope is broader than +-- just this type. It's a bit dubious, but used in very limited ways. +tcSkolemiseInvisibleBndrs skol_info ty + = do { let (tvs, body_ty) = tcSplitForAllInvisTyVars ty + ; lvl <- getTcLevel + ; skol_info <- mkSkolemInfo skol_info + ; let details = SkolemTv skol_info lvl False + mk_skol_tv name kind = return (mkTcTyVar name kind details) -- No freshening + ; (subst, tvs') <- instantiateTyVarsX mk_skol_tv emptySubst tvs + ; return (tvs', substTy subst body_ty) } + +instantiateTyVarsX :: (Name -> Kind -> TcM TcTyVar) + -> Subst -> [TyVar] + -> TcM (Subst, [TcTyVar]) +-- Instantiate each type variable in turn with the specified function +instantiateTyVarsX mk_tv subst tvs + = case tvs of + [] -> return (subst, []) + (tv:tvs) -> do { let kind1 = substTyUnchecked subst (tyVarKind tv) + ; tv' <- mk_tv (tyVarName tv) kind1 + ; let subst1 = extendTCvSubstWithClone subst tv tv' + ; (subst', tvs') <- instantiateTyVarsX mk_tv subst1 tvs + ; return (subst', tv':tvs') } + +------------------ +freshenTyVarBndrs :: [TyVar] -> TcM (Subst, [TyVar]) +-- ^ Give fresh uniques to a bunch of TyVars, but they stay +-- as TyVars, rather than becoming TcTyVars +-- Used in 'GHC.Tc.Instance.Family.newFamInst', and 'GHC.Tc.Utils.Instantiate.newClsInst' +freshenTyVarBndrs = freshenTyCoVars mkTyVar + +freshenCoVarBndrsX :: Subst -> [CoVar] -> TcM (Subst, [CoVar]) +-- ^ Give fresh uniques to a bunch of CoVars +-- Used in "GHC.Tc.Instance.Family.newFamInst" +freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst + +------------------ +freshenTyCoVars :: (Name -> Kind -> TyCoVar) + -> [TyVar] -> TcM (Subst, [TyCoVar]) +freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptySubst + +freshenTyCoVarsX :: (Name -> Kind -> TyCoVar) + -> Subst -> [TyCoVar] + -> TcM (Subst, [TyCoVar]) +-- This a complete freshening operation: +-- the skolems have a fresh unique, and a location from the monad +-- See Note [Skolemising type variables] +freshenTyCoVarsX mk_tcv + = instantiateTyVarsX freshen_tcv + where + freshen_tcv :: Name -> Kind -> TcM TcTyVar + freshen_tcv name kind + = do { loc <- getSrcSpanM + ; uniq <- newUnique + ; let !occ_name = getOccName name + -- Force so we don't retain reference to the old + -- name and id. See (#19619) for more discussion + new_name = mkInternalName uniq occ_name loc + ; return (mk_tcv new_name kind) } + +{- Note [Skolemising type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The tcInstSkolTyVars family of functions instantiate a list of TyVars +to fresh skolem TcTyVars. Important notes: + +a) Level allocation. We generally skolemise /before/ calling + pushLevelAndCaptureConstraints. So we want their level to the level + of the soon-to-be-created implication, which has a level ONE HIGHER + than the current level. Hence the pushTcLevel. It feels like a + slight hack. + +b) The [TyVar] should be ordered (kind vars first) + See Note [Kind substitution when instantiating] + +c) Clone the variable to give a fresh unique. This is essential. + Consider (tc160) + type Foo x = forall a. a -> x + And typecheck the expression + (e :: Foo (Foo ()) + We will skolemise the signature, but after expanding synonyms it + looks like + forall a. a -> forall a. a -> x + We don't want to make two big-lambdas with the same unique! + +d) We retain locations. Because the location of the variable is the correct + location to report in errors (e.g. in the signature). We don't want the + location to change to the body of the function, which does *not* explicitly + bind the variable. + +e) The resulting skolems are + non-overlappable for tcInstSkolTyVars, + but overlappable for tcInstSuperSkolTyVars + See GHC.Tc.Deriv.Infer Note [Overlap and deriving] for an example + of where this matters. + +Note [Kind substitution when instantiating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we instantiate a bunch of kind and type variables, first we +expect them to be topologically sorted. +Then we have to instantiate the kind variables, build a substitution +from old variables to the new variables, then instantiate the type +variables substituting the original kind. + +Example: If we want to instantiate + [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)] +we want + [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)] +instead of the bogus + [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)] +-} + +{- ********************************************************************* +* * + Literals +* * +********************************************************************* -} + +{- +In newOverloadedLit we convert directly to an Int or Integer if we +know that's what we want. This may save some time, by not +temporarily generating overloaded literals, but it won't catch all +cases (the rest are caught in lookupInst). + +-} + +newOverloadedLit :: HsOverLit GhcRn + -> ExpRhoType + -> TcM (HsOverLit GhcTc) +newOverloadedLit lit res_ty + = do { mb_lit' <- tcShortCutLit lit res_ty + ; case mb_lit' of + Just lit' -> return lit' + Nothing -> newNonTrivialOverloadedLit lit res_ty } + +-- Does not handle things that 'shortCutLit' can handle. See also +-- newOverloadedLit in GHC.Tc.Utils.Unify +newNonTrivialOverloadedLit :: HsOverLit GhcRn + -> ExpRhoType + -> TcM (HsOverLit GhcTc) +newNonTrivialOverloadedLit + lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable (L loc meth_name) }) + res_ty + = do { hs_lit <- mkOverLit val + ; let lit_ty = hsLitType hs_lit + ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) + [synKnownType lit_ty] res_ty $ + \_ _ -> return () + ; let L _ witness = mkHsSyntaxApps (l2l loc) fi' [nlHsLit hs_lit] + ; res_ty <- readExpType res_ty + ; return (lit { ol_ext = OverLitTc { ol_rebindable = rebindable + , ol_witness = witness + , ol_type = res_ty } }) } + where + orig = LiteralOrigin lit + +------------ +mkOverLit :: OverLitVal -> TcM (HsLit GhcTc) +mkOverLit (HsIntegral i) + = do { integer_ty <- tcMetaTy integerTyConName + ; return (XLit $ HsInteger (il_text i) (il_value i) integer_ty) } + +mkOverLit (HsFractional r) + = do { rat_ty <- tcMetaTy rationalTyConName + ; return (XLit $ HsRat r rat_ty) } + +mkOverLit (HsIsString src s) = return (HsString src s) + +{- +************************************************************************ +* * + Re-mappable syntax + + Used only for arrow syntax -- find a way to nuke this +* * +************************************************************************ + +Suppose we are doing the -XRebindableSyntax thing, and we encounter +a do-expression. We have to find (>>) in the current environment, which is +done by the rename. Then we have to check that it has the same type as +Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had +this: + + (>>) :: HB m n mn => m a -> n b -> mn b + +So the idea is to generate a local binding for (>>), thus: + + let then72 :: forall a b. m a -> m b -> m b + then72 = ...something involving the user's (>>)... + in + ...the do-expression... + +Now the do-expression can proceed using then72, which has exactly +the expected type. + +In fact tcSyntaxName just generates the RHS for then72, because we only +want an actual binding in the do-expression case. For literals, we can +just use the expression inline. +-} + +tcSyntaxName :: CtOrigin + -> TcType -- ^ Type to instantiate it at + -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name) + -> TcM (Name, HsExpr GhcTc) + -- ^ (Standard name, suitable expression) +-- USED ONLY FOR CmdTop (sigh) *** +-- See Note [CmdSyntaxTable] in "GHC.Hs.Expr" + +tcSyntaxName orig ty (std_nm, HsVar _ (L _ (WithUserRdr _ user_nm))) + | std_nm == user_nm + = do rhs <- newMethodFromName orig std_nm [ty] + return (std_nm, rhs) + +tcSyntaxName orig ty (std_nm, user_nm_expr) = do + std_id <- tcLookupId std_nm + let + ([tv], _, tau) = tcSplitSigmaTy (idType std_id) + sigma1 = substTyWith [tv] [ty] tau + -- Actually, the "tau-type" might be a sigma-type in the + -- case of locally-polymorphic methods. + + span <- getSrcSpanM + addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1 span) $ do + + -- Check that the user-supplied thing has the + -- same type as the standard one. + -- Tiresome jiggling because tcCheckSigma takes a located expression + expr <- tcCheckPolyExpr (L (noAnnSrcSpan span) user_nm_expr) sigma1 + hasFixedRuntimeRepRes std_nm user_nm_expr sigma1 + return (std_nm, unLoc expr) + +syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan + -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) +syntaxNameCtxt name orig ty loc tidy_env = + return (tidy_env, SyntaxNameCtxt name orig (tidyType tidy_env ty) 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 + | sameUnique std_nm arrAName -- result used as an argument in, e.g., do_premap + = Just 3 + | sameUnique std_nm composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt + = Just 5 + | sameUnique std_nm firstAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt + = Just 4 + | sameUnique std_nm appAName -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp + = Just 2 + | sameUnique std_nm choiceAName -- result used as an argument in, e.g., HsCmdIf + = Just 5 + | sameUnique std_nm loopAName -- result used as an argument in, e.g., HsCmdIf + = Just 4 + | otherwise + = Nothing + +{- +************************************************************************ +* * + Class instances +* * +************************************************************************ +-} + +getOverlapFlag :: Maybe OverlapMode -- User pragma if any + -> TcM OverlapFlag +-- Construct the OverlapFlag from the global module flags, +-- but if the overlap_mode argument is (Just m), +-- set the OverlapMode to 'm' +-- +-- The overlap_mode argument comes from a user pragma on the instance decl: +-- Pragma overlap_mode_prag +-- ----------------------------------------- +-- {-# OVERLAPPABLE #-} Overlappable +-- {-# OVERLAPPING #-} Overlapping +-- {-# OVERLAPS #-} Overlaps +-- {-# INCOHERENT #-} Incoherent -- if -fspecialise-incoherent (on by default) +-- {-# INCOHERENT #-} NonCanonical -- if -fno-specialise-incoherent +-- See Note [Rules for instance lookup] in GHC.Core.InstEnv + +getOverlapFlag overlap_mode_prag + = do { dflags <- getDynFlags + ; let overlap_ok = xopt LangExt.OverlappingInstances dflags + incoherent_ok = xopt LangExt.IncoherentInstances dflags + noncanonical_incoherence = not $ gopt Opt_SpecialiseIncoherents dflags + + overlap_mode + | Just m <- overlap_mode_prag = m + | incoherent_ok = Incoherent NoSourceText + | overlap_ok = Overlaps NoSourceText + | otherwise = NoOverlap NoSourceText + + -- final_overlap_mode: the `-fspecialise-incoherents` flag controls the + -- meaning of the `Incoherent` overlap mode: as either an Incoherent overlap + -- flag, or a NonCanonical overlap flag. + -- See GHC.Core.InstEnv Note [Coherence and specialisation: overview] + final_overlap_mode + | Incoherent s <- overlap_mode + , noncanonical_incoherence = NonCanonical s + | otherwise = overlap_mode + + ; return (OverlapFlag { isSafeOverlap = safeLanguageOn dflags + , overlapMode = final_overlap_mode }) } + + +tcGetInsts :: TcM [ClsInst] +-- Gets the local class instances. +tcGetInsts = fmap tcg_insts getGblEnv + +newClsInst :: Maybe OverlapMode -- User pragma + -> Name -> [TyVar] -> ThetaType + -> Class -> [Type] -> Maybe (WarningTxt GhcRn) -> TcM ClsInst +newClsInst overlap_mode dfun_name tvs theta clas tys warn + = do { (subst, tvs') <- freshenTyVarBndrs tvs + -- Be sure to freshen those type variables, + -- so they are sure not to appear in any lookup + ; let tys' = substTys subst tys + + dfun = mkDictFunId dfun_name tvs theta clas tys + -- The dfun uses the original 'tvs' because + -- (a) they don't need to be fresh + -- (b) they may be mentioned in the ib_binds field of + -- an InstInfo, and in GHC.Tc.Utils.Env.pprInstInfoDetails it's + -- helpful to use the same names + + ; oflag <- getOverlapFlag overlap_mode + ; let cls_inst = mkLocalClsInst dfun oflag tvs' clas tys' warn + + ; when (isOrphan (is_orphan cls_inst)) $ + addDiagnostic (TcRnOrphanInstance $ Left cls_inst) + + ; return cls_inst } + +tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a + -- Add new locally-defined instances +tcExtendLocalInstEnv dfuns thing_inside + = do { traceDFuns dfuns + ; env <- getGblEnv + -- Force the access to the TcgEnv so it isn't retained. + -- During auditing it is much easier to observe in -hi profiles if + -- there are a very small number of TcGblEnv. Keeping a TcGblEnv + -- alive is quite dangerous because it contains reference to many + -- large data structures. + ; let !init_inst_env = tcg_inst_env env + !init_insts = tcg_insts env + ; (inst_env', cls_insts') <- foldlM addLocalInst + (init_inst_env, init_insts) + dfuns + ; let env' = env { tcg_insts = cls_insts' + , tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } + +addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) +-- Check that the proposed new instance is OK, +-- and then add it to the home inst env +-- If overwrite_inst, then we can overwrite a direct match +addLocalInst (home_ie, my_insts) ispec + = do { + -- Load imported instances, so that we report + -- duplicates correctly + + -- 'matches' are existing instance declarations that are less + -- specific than the new one + -- 'dups' are those 'matches' that are equal to the new one + ; isGHCi <- getIsGHCi + ; eps <- getEps + ; tcg_env <- getGblEnv + + -- In GHCi, we *override* any identical instances + -- that are also defined in the interactive context + -- See Note [Override identical instances in GHCi] + ; let home_ie' + | isGHCi = deleteFromInstEnv home_ie ispec + | otherwise = home_ie + + global_ie = eps_inst_env eps + inst_envs = InstEnvs { ie_global = global_ie + , ie_local = home_ie' + , ie_visible = tcVisibleOrphanMods tcg_env } + + -- Check for inconsistent functional dependencies + ; let inconsistent_ispecs = checkFunDeps inst_envs ispec + ; unless (null inconsistent_ispecs) $ + funDepErr ispec inconsistent_ispecs + + -- Check for duplicate instance decls. + ; let (_tvs, cls, tys) = instanceHead ispec + (matches, _, _) = lookupInstEnv False inst_envs cls tys + dups = filter (identicalClsInstHead ispec) (map fst matches) + ; unless (null dups) $ + dupInstErr ispec (head dups) + + ; return (extendInstEnv home_ie' ispec, ispec : my_insts) } + + +{- Note [Signature files and type class instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instances in signature files do not have an effect when compiling: +when you compile a signature against an implementation, you will +see the instances WHETHER OR NOT the instance is declared in +the file (this is because the signatures go in the EPS and we +can't filter them out easily.) This is also why we cannot +place the instance in the hi file: it would show up as a duplicate, +and we don't have instance reexports anyway. + +However, you might find them useful when typechecking against +a signature: the instance is a way of indicating to GHC that +some instance exists, in case downstream code uses it. + +Implementing this is a little tricky. Consider the following +situation (sigof03): + + module A where + instance C T where ... + + module ASig where + instance C T + +When compiling ASig, A.hi is loaded, which brings its instances +into the EPS. When we process the instance declaration in ASig, +we should ignore it for the purpose of doing a duplicate check, +since it's not actually a duplicate. But don't skip the check +entirely, we still want this to fail (tcfail221): + + module ASig where + instance C T + instance C T + +Note that in some situations, the interface containing the type +class instances may not have been loaded yet at all. The usual +situation when A imports another module which provides the +instances (sigof02m): + + module A(module B) where + import B + +See also Note [Signature lazy interface loading]. We can't +rely on this, however, since sometimes we'll have spurious +type class instances in the EPS, see #9422 (sigof02dm) + +************************************************************************ +* * + Family instances +* * +************************************************************************ +-} + +-- All type variables in a FamInst must be fresh. This function +-- creates the fresh variables and applies the necessary substitution +-- It is defined here to avoid a dependency from FamInstEnv on the monad +-- code. + +newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst +-- Freshen the type variables of the FamInst branches +newFamInst flavor axiom + | CoAxBranch { cab_tvs = tvs + , cab_cvs = cvs + , cab_lhs = lhs + , cab_rhs = rhs } <- coAxiomSingleBranch axiom + = do { -- Freshen the type variables + (subst, tvs') <- freshenTyVarBndrs tvs + ; (subst, cvs') <- freshenCoVarBndrsX subst cvs + ; let lhs' = substTys subst lhs + rhs' = substTy subst rhs + + ; let fam_inst = mkLocalFamInst flavor axiom tvs' cvs' lhs' rhs' + ; when (isOrphan (fi_orphan fam_inst)) $ + addDiagnostic (TcRnOrphanInstance $ Right fam_inst) + + ; return fam_inst } + + +{- ********************************************************************* +* * + Errors and tracing +* * +********************************************************************* -} + +traceDFuns :: [ClsInst] -> TcRn () +traceDFuns ispecs + = traceTc "Adding instances:" (vcat (map pp ispecs)) + where + pp ispec = hang (ppr (instanceDFunId ispec) <+> colon) + 2 (ppr ispec) + -- Print the dfun name itself too + +funDepErr :: ClsInst -> [ClsInst] -> TcRn () +funDepErr ispec ispecs + = addClsInstsErr TcRnFunDepConflict (ispec NE.:| ispecs) + +dupInstErr :: ClsInst -> ClsInst -> TcRn () +dupInstErr ispec dup_ispec + = addClsInstsErr TcRnDupInstanceDecls (ispec NE.:| [dup_ispec]) + +addClsInstsErr :: (UnitState -> NE.NonEmpty ClsInst -> TcRnMessage) + -> NE.NonEmpty ClsInst + -> TcRn () +addClsInstsErr mkErr ispecs = do + unit_state <- hsc_units <$> getTopEnv + setSrcSpan (getSrcSpan (NE.head sorted)) $ + addErr $ mkErr unit_state sorted + where + sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs + -- The sortBy just arranges that instances are displayed in order + -- of source location, which reduced wobbling in error messages, + -- and is better for users diff --git a/GHC/Tc/Utils/Monad.hs b/GHC/Tc/Utils/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Monad.hs @@ -0,0 +1,2461 @@ +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- +(c) The University of Glasgow 2006 + +-} + +-- | Functions for working with the typechecker environment (setters, +-- getters...). +module GHC.Tc.Utils.Monad( + -- * Initialisation + initTc, initTcWithGbl, initTcInteractive, initTcRnIf, + + -- * Simple accessors + discardResult, + getTopEnv, updTopEnv, updTopEnvIO, getGblEnv, updGblEnv, + setGblEnv, getLclEnv, updLclEnv, updLclCtxt, setLclEnv, restoreLclEnv, + updTopFlags, + getEnvs, setEnvs, updEnvs, restoreEnvs, + xoptM, doptM, goptM, woptM, + setXOptM, setWOptM, + unsetXOptM, unsetGOptM, unsetWOptM, + whenDOptM, whenGOptM, whenWOptM, + whenXOptM, unlessXOptM, + getGhcMode, + withoutDynamicNow, + getEpsVar, + getEps, + updateEps, updateEps_, + getHpt, getEpsAndHug, + + -- * Arrow scopes + newArrowScope, escapeArrowScope, + + -- * Unique supply + newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName, + newSysName, newSysLocalId, newSysLocalIds, + + -- * Accessing input/output + newTcRef, readTcRef, writeTcRef, updTcRef, updTcRefM, + + -- * Debugging + traceTc, traceRn, traceOptTcRn, dumpOptTcRn, + dumpTcRn, + getNamePprCtx, + printForUserTcRn, + traceIf, traceOptIf, + debugTc, + + -- * Typechecker global environment + getIsGHCi, getGHCiMonad, getInteractivePrintName, + tcHscSource, tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, + getRdrEnvs, getImports, + getFixityEnv, extendFixityEnv, + getDeclaredDefaultTys, + addDependentFiles, + + -- * Error management + getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, + inGeneratedCode, setInGeneratedCode, + wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, + wrapLocMA_,wrapLocMA, + getErrsVar, setErrsVar, + addErr, + failWith, failAt, + addErrAt, addErrs, + checkErr, checkErrAt, + addMessages, + discardWarnings, mkDetailedMessage, + + -- * Usage environment + tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, + + -- * Shared error message stuff: renamer and typechecker + recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, + attemptM, tryTc, + askNoErrs, discardErrs, + tryTcDiscardingErrs, + tryTcDiscardingErrs', + checkNoErrs, whenNoErrs, + ifErrsM, failIfErrsM, + + -- * Context management for the type checker + getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, + addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv, + + -- * Diagnostic message generation (type checker) + addErrTc, + addErrTcM, + failWithTc, failWithTcM, + checkTc, checkTcM, + checkJustTc, checkJustTcM, + failIfTc, failIfTcM, + mkErrCtxt, + addTcRnDiagnostic, addDetailedDiagnostic, + mkTcRnMessage, reportDiagnostic, reportDiagnostics, + warnIf, diagnosticTc, diagnosticTcM, + addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt, + + -- * Type constraints + newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, + addTcEvBind, addTcEvBinds, addTopEvBinds, + getTcEvBindsMap, setTcEvBindsMap, updTcEvBinds, + getTcEvTyCoVars, chooseUniqueOccTc, + getConstraintVar, setConstraintVar, + emitConstraints, emitStaticConstraints, emitSimple, emitSimples, + emitImplication, emitImplications, ensureReflMultiplicityCo, + emitDelayedErrors, emitHole, emitHoles, emitNotConcreteError, + discardConstraints, captureConstraints, tryCaptureConstraints, + pushLevelAndCaptureConstraints, + pushTcLevelM_, pushTcLevelM, + getTcLevel, setTcLevel, isTouchableTcM, + getLclTypeEnv, setLclTypeEnv, + traceTcConstraints, + emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole, + + -- * Template Haskell context + recordThUse, recordThNeededRuntimeDeps, + keepAlive, getThLevel, getCurrentAndBindLevel, setThLevel, + addModFinalizersWithLclEnv, + + -- * Safe Haskell context + recordUnsafeInfer, finalSafeMode, fixSafeInstances, + + -- * Stuff for the renamer's local env + getLocalRdrEnv, setLocalRdrEnv, + + -- * Stuff for interface decls + mkIfLclEnv, + initIfaceTcRn, + initIfaceCheck, + initIfaceLcl, + initIfaceLclWithSubst, + initIfaceLoad, + initIfaceLoadModule, + getIfModule, + failIfM, + forkM, + setImplicitEnvM, + + withException, withIfaceErr, + + -- * Stuff for cost centres. + getCCIndexM, getCCIndexTcM, + + -- * Zonking + liftZonkM, newZonkAnyType, + + -- * Complete matches + localAndImportedCompleteMatches, getCompleteMatchesTcM, + + -- * Types etc. + module GHC.Tc.Types, + module GHC.Data.IOEnv + ) where + +import GHC.Prelude + + +import GHC.Builtin.Names +import GHC.Builtin.Types( zonkAnyTyCon ) + +import GHC.Tc.Errors.Types +import GHC.Tc.Types -- Re-export all +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.LclEnv +import GHC.Tc.Types.Origin +import GHC.Tc.Types.TcRef +import GHC.Tc.Types.TH +import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.TcType + +import GHC.Hs hiding (LIE) + +import GHC.Unit +import GHC.Unit.Env +import GHC.Unit.External +import GHC.Unit.Module.Warnings +import GHC.Unit.Home.PackageTable + +import GHC.Core.UsageEnv +import GHC.Core.Multiplicity +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Core.Type( mkNumLitTy ) + +import GHC.Driver.Env +import GHC.Driver.Env.KnotVars +import GHC.Driver.Session +import GHC.Driver.Config.Diagnostic + +import GHC.Iface.Errors.Types +import GHC.Iface.Errors.Ppr + +import GHC.Linker.Types + +import GHC.Runtime.Context + +import GHC.Data.IOEnv -- Re-export all +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.Maybe + +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Error +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Logger +import qualified GHC.Data.Strict as Strict +import qualified Data.Set as Set + +import GHC.Types.Error +import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv ) +import GHC.Types.Fixity.Env +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.SafeHaskell +import GHC.Types.Id +import GHC.Types.TypeEnv +import GHC.Types.Var.Env +import GHC.Types.SrcLoc +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Ppr +import GHC.Types.Unique.FM ( emptyUFM ) +import GHC.Types.Unique.DFM +import GHC.Types.Unique.Supply +import GHC.Types.Annotations +import GHC.Types.Basic( TopLevelFlag(..), TypeOrKind(..) ) +import GHC.Types.CostCentre.State +import GHC.Types.SourceFile + +import qualified GHC.LanguageExtensions as LangExt + +import Data.IORef +import Control.Monad + +import qualified Data.Map as Map +import GHC.Core.Coercion (isReflCo) + + +{- +************************************************************************ +* * + initTc +* * +************************************************************************ +-} + +-- | Setup the initial typechecking environment +initTc :: HscEnv + -> HscSource + -> Bool -- True <=> retain renamed syntax trees + -> Module + -> RealSrcSpan + -> TcM r + -> IO (Messages TcRnMessage, Maybe r) + -- Nothing => error thrown by the thing inside + -- (error messages should have been printed already) + +initTc hsc_env hsc_src keep_rn_syntax mod loc do_this + = do { keep_var <- newIORef emptyNameSet ; + used_gre_var <- newIORef [] ; + th_var <- newIORef False ; + infer_var <- newIORef True ; + infer_reasons_var <- newIORef emptyMessages ; + dfun_n_var <- newIORef emptyOccSet ; + zany_n_var <- newIORef 0 ; + let { type_env_var = hsc_type_env_vars hsc_env }; + + dependent_files_var <- newIORef [] ; + static_wc_var <- newIORef emptyWC ; + cc_st_var <- newIORef newCostCentreState ; + th_topdecls_var <- newIORef [] ; + th_foreign_files_var <- newIORef [] ; + th_topnames_var <- newIORef emptyNameSet ; + th_modfinalizers_var <- newIORef [] ; + th_coreplugins_var <- newIORef [] ; + th_state_var <- newIORef Map.empty ; + th_remote_state_var <- newIORef Nothing ; + th_docs_var <- newIORef Map.empty ; + th_needed_deps_var <- newIORef ([], emptyUDFM) ; + next_wrapper_num <- newIORef emptyModuleEnv ; + let { + -- bangs to avoid leaking the env (#19356) + !dflags = hsc_dflags hsc_env ; + !mhome_unit = hsc_home_unit_maybe hsc_env; + !logger = hsc_logger hsc_env ; + + maybe_rn_syntax :: forall a. a -> Maybe a ; + maybe_rn_syntax empty_val + | logHasDumpFlag logger Opt_D_dump_rn_ast = Just empty_val + + | gopt Opt_WriteHie dflags = Just empty_val + + -- We want to serialize the documentation in the .hi-files, + -- and need to extract it from the renamed syntax first. + -- See 'GHC.HsToCore.Docs.extractDocs'. + | gopt Opt_Haddock dflags = Just empty_val + + | keep_rn_syntax = Just empty_val + | otherwise = Nothing ; + + gbl_env = TcGblEnv { + tcg_th_topdecls = th_topdecls_var, + tcg_th_foreign_files = th_foreign_files_var, + tcg_th_topnames = th_topnames_var, + tcg_th_modfinalizers = th_modfinalizers_var, + tcg_th_coreplugins = th_coreplugins_var, + tcg_th_state = th_state_var, + tcg_th_remote_state = th_remote_state_var, + tcg_th_docs = th_docs_var, + + tcg_mod = mod, + tcg_semantic_mod = homeModuleInstantiation mhome_unit mod, + tcg_src = hsc_src, + tcg_rdr_env = emptyGlobalRdrEnv, + tcg_fix_env = emptyNameEnv, + tcg_default = emptyDefaultEnv, + tcg_default_exports = emptyDefaultEnv, + tcg_type_env = emptyNameEnv, + tcg_type_env_var = type_env_var, + tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, + tcg_ann_env = emptyAnnEnv, + tcg_complete_match_env = [], + tcg_th_used = th_var, + tcg_th_needed_deps = th_needed_deps_var, + tcg_exports = [], + tcg_imports = emptyImportAvails, + tcg_import_decls = [], + tcg_used_gres = used_gre_var, + tcg_dus = emptyDUs, + + tcg_rn_imports = [], + tcg_rn_exports = + if hsc_src == HsigFile + -- Always retain renamed syntax, so that we can give + -- better errors. (TODO: how?) + then Just [] + else maybe_rn_syntax [], + tcg_rn_decls = maybe_rn_syntax emptyRnGroup, + tcg_tr_module = Nothing, + tcg_binds = emptyLHsBinds, + tcg_imp_specs = [], + tcg_sigs = emptyNameSet, + tcg_ksigs = emptyNameSet, + tcg_ev_binds = emptyBag, + tcg_warns = emptyWarn, + tcg_anns = [], + tcg_tcs = [], + tcg_insts = [], + tcg_fam_insts = [], + tcg_rules = [], + tcg_fords = [], + tcg_patsyns = [], + tcg_merged = [], + tcg_dfun_n = dfun_n_var, + tcg_zany_n = zany_n_var, + tcg_keep = keep_var, + tcg_hdr_info = (Nothing,Nothing), + tcg_main = Nothing, + tcg_self_boot = NoSelfBoot, + tcg_safe_infer = infer_var, + tcg_safe_infer_reasons = infer_reasons_var, + tcg_dependent_files = dependent_files_var, + tcg_tc_plugin_solvers = [], + tcg_tc_plugin_rewriters = emptyUFM, + tcg_defaulting_plugins = [], + tcg_hf_plugins = [], + tcg_top_loc = loc, + tcg_static_wc = static_wc_var, + tcg_complete_matches = [], + tcg_cc_st = cc_st_var, + tcg_next_wrapper_num = next_wrapper_num + } ; + } ; + + -- OK, here's the business end! + initTcWithGbl hsc_env gbl_env loc do_this + } + +-- | Run a 'TcM' action in the context of an existing 'GblEnv'. +initTcWithGbl :: HscEnv + -> TcGblEnv + -> RealSrcSpan + -> TcM r + -> IO (Messages TcRnMessage, Maybe r) +initTcWithGbl hsc_env gbl_env loc do_this + = do { lie_var <- newIORef emptyWC + ; errs_var <- newIORef emptyMessages + ; usage_var <- newIORef zeroUE + ; let lcl_env = TcLclEnv { + tcl_lcl_ctxt = TcLclCtxt { + tcl_loc = loc, + -- tcl_loc should be over-ridden very soon! + tcl_in_gen_code = False, + tcl_ctxt = [], + tcl_rdr = emptyLocalRdrEnv, + tcl_th_ctxt = topLevel, + tcl_th_bndrs = emptyNameEnv, + tcl_arrow_ctxt = NoArrowCtxt, + tcl_env = emptyNameEnv, + tcl_bndrs = [], + tcl_tclvl = topTcLevel + }, + tcl_usage = usage_var, + tcl_lie = lie_var, + tcl_errs = errs_var + } + + ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ + do { r <- tryM do_this + ; case r of + Right res -> return (Just res) + Left _ -> return Nothing } + + -- Check for unsolved constraints + -- If we succeed (maybe_res = Just r), there should be + -- no unsolved constraints. But if we exit via an + -- exception (maybe_res = Nothing), we may have skipped + -- solving, so don't panic then (#13466) + ; lie <- readIORef (tcl_lie lcl_env) + ; when (isJust maybe_res && not (isEmptyWC lie)) $ + pprPanic "initTc: unsolved constraints" (ppr lie) + + -- Collect any error messages + ; msgs <- readIORef (tcl_errs lcl_env) + + ; let { final_res | errorsFound msgs = Nothing + | otherwise = maybe_res } + + ; return (msgs, final_res) + } + +initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a) +-- Initialise the type checker monad for use in GHCi +initTcInteractive hsc_env thing_inside + = initTc hsc_env HsSrcFile False + (icInteractiveModule (hsc_IC hsc_env)) + (realSrcLocSpan interactive_src_loc) + thing_inside + where + interactive_src_loc = mkRealSrcLoc (fsLit "") 1 1 + +initTcRnIf :: Char -- ^ Tag for unique supply + -> HscEnv + -> gbl -> lcl + -> TcRnIf gbl lcl a + -> IO a +initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside + = do { let { env = Env { env_top = hsc_env, + env_ut = uniq_tag, + env_gbl = gbl_env, + env_lcl = lcl_env} } + + ; runIOEnv env thing_inside + } + +{- +************************************************************************ +* * + Simple accessors +* * +************************************************************************ +-} + +discardResult :: TcM a -> TcM () +discardResult a = a >> return () + +getTopEnv :: TcRnIf gbl lcl HscEnv +getTopEnv = do { env <- getEnv; return (env_top env) } + +updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updTopEnv upd = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = upd top }) + +updTopEnvIO :: (HscEnv -> IO HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updTopEnvIO upd = updEnvIO (\ env@(Env { env_top = top }) -> + upd top >>= \t' -> + pure env{ env_top = t' }) + +getGblEnv :: TcRnIf gbl lcl gbl +getGblEnv = do { Env{..} <- getEnv; return env_gbl } + +updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> + env { env_gbl = upd gbl }) + +setGblEnv :: gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a +setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) + +getLclEnv :: TcRnIf gbl lcl lcl +getLclEnv = do { Env{..} <- getEnv; return env_lcl } + +updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> + env { env_lcl = upd lcl }) + +updLclCtxt :: (TcLclCtxt -> TcLclCtxt) -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a +updLclCtxt upd = updLclEnv (modifyLclCtxt upd) + +setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a +setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) + +restoreLclEnv :: TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a +-- See Note [restoreLclEnv vs setLclEnv] +restoreLclEnv new_lcl_env = updLclEnv upd + where + upd old_lcl_env = new_lcl_env { tcl_errs = tcl_errs old_lcl_env + , tcl_lie = tcl_lie old_lcl_env + , tcl_usage = tcl_usage old_lcl_env } + +getEnvs :: TcRnIf gbl lcl (gbl, lcl) +getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } + +setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a +setEnvs (gbl_env, lcl_env) = setGblEnv gbl_env . setLclEnv lcl_env + +updEnvs :: ((gbl,lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updEnvs upd_envs = updEnv upd + where + upd env@(Env { env_gbl = gbl, env_lcl = lcl }) + = env { env_gbl = gbl', env_lcl = lcl' } + where + !(gbl', lcl') = upd_envs (gbl, lcl) + +restoreEnvs :: (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a +-- See Note [restoreLclEnv vs setLclEnv] +restoreEnvs (gbl, lcl) = setGblEnv gbl . restoreLclEnv lcl + +{- Note [restoreLclEnv vs setLclEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the typechecker we use this idiom quite a lot + do { (gbl_env, lcl_env) <- tcRnSrcDecls ... + ; setGblEnv gbl_env $ setLclEnv lcl_env $ + more_stuff } + +The `tcRnSrcDecls` extends the environments in `gbl_env` and `lcl_env` +which we then want to be in scope in `more stuff`. + +The problem is that `lcl_env :: TcLclEnv` has an IORef for error +messages `tcl_errs`, and another for constraints (`tcl_lie`), and +another for Linear Haskell usage information (`tcl_usage`). Now +suppose we change it a tiny bit + do { (gbl_env, lcl_env) <- checkNoErrs $ + tcRnSrcDecls ... + ; setGblEnv gbl_env $ setLclEnv lcl_env $ + more_stuff } + +That should be innocuous. But *alas*, `checkNoErrs` gathers errors in +a fresh IORef *which is then captured in the returned `lcl_env`. When +we do the `setLclEnv` we'll make that captured IORef into the place +where we gather error messages -- but no one is going to look at that!!! +This led to #19470 and #20981. + +Solution: instead of setLclEnv use restoreLclEnv, which preserves from +the /parent/ context these mutable collection IORefs: + tcl_errs, tcl_lie, tcl_usage +-} + +-- Command-line flags + +xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool +xoptM flag = xopt flag <$> getDynFlags + +doptM :: DumpFlag -> TcRnIf gbl lcl Bool +doptM flag = do + logger <- getLogger + return (logHasDumpFlag logger flag) + +goptM :: GeneralFlag -> TcRnIf gbl lcl Bool +goptM flag = gopt flag <$> getDynFlags + +woptM :: WarningFlag -> TcRnIf gbl lcl Bool +woptM flag = wopt flag <$> getDynFlags + +setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setXOptM flag = updTopFlags (\dflags -> xopt_set dflags flag) + +setWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setWOptM flag = updTopFlags (\dflags -> wopt_set dflags flag) + +unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetXOptM flag = updTopFlags (\dflags -> xopt_unset dflags flag) + +unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetGOptM flag = updTopFlags (\dflags -> gopt_unset dflags flag) + +unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetWOptM flag = updTopFlags (\dflags -> wopt_unset dflags flag) + +-- | Do it flag is true +whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenDOptM flag thing_inside = do b <- doptM flag + when b thing_inside +{-# INLINE whenDOptM #-} -- see Note [INLINE conditional tracing utilities] + + +whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenGOptM flag thing_inside = do b <- goptM flag + when b thing_inside +{-# INLINE whenGOptM #-} -- see Note [INLINE conditional tracing utilities] + +whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenWOptM flag thing_inside = do b <- woptM flag + when b thing_inside +{-# INLINE whenWOptM #-} -- see Note [INLINE conditional tracing utilities] + +whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenXOptM flag thing_inside = do b <- xoptM flag + when b thing_inside +{-# INLINE whenXOptM #-} -- see Note [INLINE conditional tracing utilities] + +unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +unlessXOptM flag thing_inside = do b <- xoptM flag + unless b thing_inside +{-# INLINE unlessXOptM #-} -- see Note [INLINE conditional tracing utilities] + +getGhcMode :: TcRnIf gbl lcl GhcMode +getGhcMode = ghcMode <$> getDynFlags + +withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a +withoutDynamicNow = updTopFlags (\dflags -> dflags { dynamicNow = False}) + +updTopFlags :: (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updTopFlags f = updTopEnv (hscUpdateFlags f) + +getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) +getEpsVar = do + env <- getTopEnv + return (euc_eps (ue_eps (hsc_unit_env env))) + +getEps :: TcRnIf gbl lcl ExternalPackageState +getEps = do { env <- getTopEnv; liftIO $ hscEPS env } + +-- | Update the external package state. Returns the second result of the +-- modifier function. +-- +-- This is an atomic operation and forces evaluation of the modified EPS in +-- order to avoid space leaks. +updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) + -> TcRnIf gbl lcl a +updateEps upd_fn = do + traceIf (text "updating EPS") + eps_var <- getEpsVar + atomicUpdMutVar' eps_var upd_fn + +-- | Update the external package state. +-- +-- This is an atomic operation and forces evaluation of the modified EPS in +-- order to avoid space leaks. +updateEps_ :: (ExternalPackageState -> ExternalPackageState) + -> TcRnIf gbl lcl () +updateEps_ upd_fn = updateEps (\eps -> (upd_fn eps, ())) + +getHpt :: TcRnIf gbl lcl HomePackageTable +getHpt = do { env <- getTopEnv; return (hsc_HPT env) } + +getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph) +getEpsAndHug = do { env <- getTopEnv; eps <- liftIO $ hscEPS env + ; return (eps, hsc_HUG env) } + +-- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing +-- an exception if it is an error. +withException :: MonadIO m => SDocContext -> m (MaybeErr SDoc a) -> m a +withException ctx do_this = do + r <- do_this + case r of + Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err)) + Succeeded result -> return result + +withIfaceErr :: MonadIO m => SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a +withIfaceErr ctx do_this = do + r <- do_this + case r of + Failed err -> do + let opts = defaultDiagnosticOpts @IfaceMessage + msg = missingInterfaceErrorDiagnostic opts err + liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx msg)) + Succeeded result -> return result + +{- +************************************************************************ +* * + Arrow scopes +* * +************************************************************************ +-} + +newArrowScope :: TcM a -> TcM a +newArrowScope + = updLclEnv $ \env -> + modifyLclCtxt (\ctx -> ctx { tcl_arrow_ctxt = ArrowCtxt (getLclEnvRdrEnv env) (tcl_lie env) } ) env + +-- Return to the stored environment (from the enclosing proc) +escapeArrowScope :: TcM a -> TcM a +escapeArrowScope + = updLclEnv $ \ env -> + case getLclEnvArrowCtxt env of + NoArrowCtxt -> env + ArrowCtxt rdr_env lie -> env { tcl_lcl_ctxt = (tcl_lcl_ctxt env) { tcl_arrow_ctxt = NoArrowCtxt + , tcl_rdr = rdr_env } + , tcl_lie = lie } + +{- +************************************************************************ +* * + Unique supply +* * +************************************************************************ +-} + +newUnique :: TcRnIf gbl lcl Unique +newUnique + = do { env <- getEnv + ; let tag = env_ut env + ; liftIO $! uniqFromTag tag } + +newUniqueSupply :: TcRnIf gbl lcl UniqSupply +newUniqueSupply + = do { env <- getEnv + ; let tag = env_ut env + ; liftIO $! mkSplitUniqSupply tag } + +cloneLocalName :: Name -> TcM Name +-- Make a fresh Internal name with the same OccName and SrcSpan +cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name) + +newName :: OccName -> TcM Name +newName occ = do { loc <- getSrcSpanM + ; newNameAt occ loc } + +newNameAt :: OccName -> SrcSpan -> TcM Name +newNameAt occ span + = do { uniq <- newUnique + ; return (mkInternalName uniq occ span) } + +newSysName :: OccName -> TcRnIf gbl lcl Name +newSysName occ + = do { uniq <- newUnique + ; return (mkSystemName uniq occ) } + +newSysLocalId :: FastString -> Mult -> TcType -> TcRnIf gbl lcl TcId +newSysLocalId fs w ty + = do { u <- newUnique + ; return (mkSysLocal fs u w ty) } + +newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId] +newSysLocalIds fs tys + = do { us <- getUniquesM + ; let mkId' n (Scaled w t) = mkSysLocal fs n w t + ; return (zipWith mkId' us tys) } + +instance MonadUnique (IOEnv (Env gbl lcl)) where + getUniqueM = newUnique + getUniqueSupplyM = newUniqueSupply + +{- +************************************************************************ +* * + Debugging +* * +************************************************************************ +-} + +{- Note [INLINE conditional tracing utilities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we want to optimise for the case where tracing is not enabled. +To ensure this happens, we ensure that traceTc and friends are inlined; this +ensures that the allocation of the document can be pushed into the tracing +path, keeping the non-traced path free of this extraneous work. For +instance, if we don't inline traceTc, we'll get + + let stuff_to_print = ... + in traceTc "wombat" stuff_to_print + +and the stuff_to_print thunk will be allocated in the "hot path", regardless +of tracing. But if we INLINE traceTc we get + + let stuff_to_print = ... + in if doTracing + then emitTraceMsg "wombat" stuff_to_print + else return () + +and then we float in: + + if doTracing + then let stuff_to_print = ... + in emitTraceMsg "wombat" stuff_to_print + else return () + +Now stuff_to_print is allocated only in the "cold path". + +Moreover, on the "cold" path, after the conditional, we want to inline +as /little/ as possible. Performance doesn't matter here, and we'd like +to bloat the caller's code as little as possible. So we put a NOINLINE +on 'emitTraceMsg' + +See #18168. +-} + +-- Typechecker trace +traceTc :: String -> SDoc -> TcRn () +traceTc herald doc = + labelledTraceOptTcRn Opt_D_dump_tc_trace herald doc +{-# INLINE traceTc #-} -- see Note [INLINE conditional tracing utilities] + +-- Renamer Trace +traceRn :: String -> SDoc -> TcRn () +traceRn herald doc = + labelledTraceOptTcRn Opt_D_dump_rn_trace herald doc +{-# INLINE traceRn #-} -- see Note [INLINE conditional tracing utilities] + +-- | Trace when a certain flag is enabled. This is like `traceOptTcRn` +-- but accepts a string as a label and formats the trace message uniformly. +labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn () +labelledTraceOptTcRn flag herald doc = + traceOptTcRn flag (formatTraceMsg herald doc) +{-# INLINE labelledTraceOptTcRn #-} -- see Note [INLINE conditional tracing utilities] + +formatTraceMsg :: String -> SDoc -> SDoc +formatTraceMsg herald doc = hang (text herald) 2 doc + +traceOptTcRn :: DumpFlag -> SDoc -> TcRn () +traceOptTcRn flag doc = + whenDOptM flag $ + dumpTcRn False flag "" FormatText doc +{-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities] + +-- | Dump if the given 'DumpFlag' is set. +dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () +dumpOptTcRn flag title fmt doc = + whenDOptM flag $ + dumpTcRn False flag title fmt doc +{-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities] + +-- | Unconditionally dump some trace output +-- +-- Certain tests (T3017, Roles3, T12763 etc.) expect part of the +-- output generated by `-ddump-types` to be in 'PprUser' style. However, +-- generally we want all other debugging output to use 'PprDump' +-- style. We 'PprUser' style if 'useUserStyle' is True. +-- +dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () +dumpTcRn useUserStyle flag title fmt doc = do + logger <- getLogger + name_ppr_ctx <- getNamePprCtx + real_doc <- wrapDocLoc doc + let sty = if useUserStyle + then mkUserStyle name_ppr_ctx AllTheWay + else mkDumpStyle name_ppr_ctx + liftIO $ logDumpFile logger sty flag title fmt real_doc + +-- | Add current location if -dppr-debug +-- (otherwise the full location is usually way too much) +wrapDocLoc :: SDoc -> TcRn SDoc +wrapDocLoc doc = do + logger <- getLogger + if logHasDumpFlag logger Opt_D_ppr_debug + then do + loc <- getSrcSpanM + return (mkLocMessage MCOutput loc doc) + else + return doc + +getNamePprCtx :: TcRn NamePprCtx +getNamePprCtx + = do { ptc <- initPromotionTickContext <$> getDynFlags + ; rdr_env <- getGlobalRdrEnv + ; hsc_env <- getTopEnv + ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env } + +-- | Like logInfoTcRn, but for user consumption +printForUserTcRn :: SDoc -> TcRn () +printForUserTcRn doc = do + logger <- getLogger + name_ppr_ctx <- getNamePprCtx + liftIO (printOutputForUser logger name_ppr_ctx doc) + +{- +traceIf works in the TcRnIf monad, where no RdrEnv is +available. Alas, they behave inconsistently with the other stuff; +e.g. are unaffected by -dump-to-file. +-} + +traceIf :: SDoc -> TcRnIf m n () +traceIf = traceOptIf Opt_D_dump_if_trace +{-# INLINE traceIf #-} + -- see Note [INLINE conditional tracing utilities] + +traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () +traceOptIf flag doc + = whenDOptM flag $ do -- No RdrEnv available, so qualify everything + logger <- getLogger + liftIO (putMsg logger doc) +{-# INLINE traceOptIf #-} -- see Note [INLINE conditional tracing utilities] + +{- +************************************************************************ +* * + Typechecker global environment +* * +************************************************************************ +-} + +getIsGHCi :: TcRn Bool +getIsGHCi = do { mod <- getModule + ; return (isInteractiveModule mod) } + +getGHCiMonad :: TcRn Name +getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } + +getInteractivePrintName :: TcRn Name +getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } + +tcIsHsBootOrSig :: TcRn Bool +tcIsHsBootOrSig = isHsBootOrSig <$> tcHscSource + +tcHscSource :: TcRn HscSource +tcHscSource = do { env <- getGblEnv; return (tcg_src env)} + +tcIsHsig :: TcRn Bool +tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) } + +tcSelfBootInfo :: TcRn SelfBootInfo +tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) } + +getGlobalRdrEnv :: TcRn GlobalRdrEnv +getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } + +getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) +getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, getLclEnvRdrEnv lcl) } + +getImports :: TcRn ImportAvails +getImports = do { env <- getGblEnv; return (tcg_imports env) } + +getFixityEnv :: TcRn FixityEnv +getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } + +extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a +extendFixityEnv new_bit + = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> + env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) + +getDeclaredDefaultTys :: TcRn DefaultEnv +getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } + +addDependentFiles :: [FilePath] -> TcRn () +addDependentFiles fs = do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fs ++ dep_files) + +{- +************************************************************************ +* * + Error management +* * +************************************************************************ +-} + +getSrcSpanM :: TcRn SrcSpan + -- Avoid clash with Name.getSrcLoc +getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (getLclEnvLoc env) Strict.Nothing) } + +-- See Note [Error contexts in generated code] +inGeneratedCode :: TcRn Bool +inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv + +setSrcSpan :: SrcSpan -> TcRn a -> TcRn a +-- See Note [Error contexts in generated code] +-- for the tcl_in_gen_code manipulation +setSrcSpan (RealSrcSpan loc _) thing_inside + = updLclCtxt (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) + thing_inside + +setSrcSpan loc@(UnhelpfulSpan _) thing_inside + | isGeneratedSrcSpan loc + = setInGeneratedCode thing_inside + + | otherwise + = thing_inside + +-- | Mark the inner computation as being done inside generated code. +-- +-- See Note [Error contexts in generated code] +setInGeneratedCode :: TcRn a -> TcRn a +setInGeneratedCode thing_inside = + updLclCtxt (\env -> env { tcl_in_gen_code = True }) thing_inside + +setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a +setSrcSpanA l = setSrcSpan (locA l) + +addLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM b +addLocM fn (L loc a) = setSrcSpan (getHasLoc loc) $ fn a + +wrapLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM (Located b) +wrapLocM fn (L loc a) = + let + loc' = getHasLoc loc + in setSrcSpan loc' $ do { b <- fn a + ; return (L loc' b) } + +wrapLocMA :: (a -> TcM b) -> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b) +wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a + ; return (L loc b) } + +wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) +wrapLocFstM fn (L loc a) = + setSrcSpan loc $ do + (b,c) <- fn a + return (L loc b, c) + +-- Possible instantiations: +-- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA a -> TcM (LocatedA b, c) +-- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedN a -> TcM (LocatedN b, c) +-- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c) +-- and so on. +wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c) +wrapLocFstMA fn (L loc a) = + setSrcSpanA loc $ do + (b,c) <- fn a + return (L loc b, c) + +wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c) +wrapLocSndM fn (L loc a) = + setSrcSpan loc $ do + (b,c) <- fn a + return (b, L loc c) + +-- Possible instantiations: +-- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c) +-- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedN a -> TcM (b, LocatedN c) +-- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAn t a -> TcM (b, LocatedAn t c) +-- and so on. +wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (EpAnn ann) a -> TcM (b, GenLocated (EpAnn ann) c) +wrapLocSndMA fn (L loc a) = + setSrcSpanA loc $ do + (b,c) <- fn a + return (b, L loc c) + +wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM () +wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) + +wrapLocMA_ :: (a -> TcM ()) -> LocatedA a -> TcM () +wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a) + +-- Reporting errors + +getErrsVar :: TcRn (TcRef (Messages TcRnMessage)) +getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } + +setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a +setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) + +addErr :: TcRnMessage -> TcRn () +addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } + +failWith :: TcRnMessage -> TcRn a +failWith msg = addErr msg >> failM + +failAt :: SrcSpan -> TcRnMessage -> TcRn a +failAt loc msg = addErrAt loc msg >> failM + +addErrAt :: SrcSpan -> TcRnMessage -> TcRn () +-- addErrAt is mainly (exclusively?) used by the renamer, where +-- tidying is not an issue, but it's all lazy so the extra +-- work doesn't matter +addErrAt loc msg = do { ctxt <- getErrCtxt + ; tidy_env <- liftZonkM $ tcInitTidyEnv + ; err_ctxt <- mkErrCtxt tidy_env ctxt + ; let detailed_msg = mkDetailedMessage (ErrInfo err_ctxt Nothing noHints) msg + ; add_long_err_at loc detailed_msg } + +mkDetailedMessage :: ErrInfo-> TcRnMessage -> TcRnMessageDetailed +mkDetailedMessage err_info msg = + TcRnMessageDetailed err_info msg + +addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn () +addErrs msgs = mapM_ add msgs + where + add (loc,msg) = addErrAt loc msg + +checkErr :: Bool -> TcRnMessage -> TcRn () +-- Add the error if the bool is False +checkErr ok msg = unless ok (addErr msg) + +checkErrAt :: SrcSpan -> Bool -> TcRnMessage -> TcRn () +checkErrAt loc ok msg = unless ok (addErrAt loc msg) + +addMessages :: Messages TcRnMessage -> TcRn () +addMessages msgs1 + = do { errs_var <- getErrsVar + ; msgs0 <- readTcRef errs_var + ; writeTcRef errs_var (msgs0 `unionMessages` msgs1) } + +discardWarnings :: TcRn a -> TcRn a +-- Ignore warnings inside the thing inside; +-- used to ignore-unused-variable warnings inside derived code +discardWarnings thing_inside + = do { errs_var <- getErrsVar + ; old_warns <- getWarningMessages <$> readTcRef errs_var + + ; result <- thing_inside + + -- Revert warnings to old_warns + ; new_errs <- getErrorMessages <$> readTcRef errs_var + ; writeTcRef errs_var $ mkMessages (old_warns `unionBags` new_errs) + + ; return result } + +{- +************************************************************************ +* * + Shared error message stuff: renamer and typechecker +* * +************************************************************************ +-} + +add_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn () +add_long_err_at loc msg = mk_long_err_at loc msg >>= reportDiagnostic + where + mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage) + mk_long_err_at loc msg + = do { name_ppr_ctx <- getNamePprCtx ; + unit_state <- hsc_units <$> getTopEnv ; + return $ mkErrorMsgEnvelope loc name_ppr_ctx + $ TcRnMessageWithInfo unit_state msg + } + +mkTcRnMessage :: SrcSpan + -> TcRnMessage + -> TcRn (MsgEnvelope TcRnMessage) +mkTcRnMessage loc msg + = do { name_ppr_ctx <- getNamePprCtx ; + diag_opts <- initDiagOpts <$> getDynFlags ; + return $ mkMsgEnvelope diag_opts loc name_ppr_ctx msg } + +reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM () +reportDiagnostics = mapM_ reportDiagnostic + +reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn () +reportDiagnostic msg + = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelopeDefault msg) ; + errs_var <- getErrsVar ; + msgs <- readTcRef errs_var ; + writeTcRef errs_var (msg `addMessage` msgs) } + +----------------------- +checkNoErrs :: TcM r -> TcM r +-- (checkNoErrs m) succeeds iff m succeeds and generates no errors +-- If m fails then (checkNoErrs m) fails. +-- If m succeeds, it checks whether m generated any errors messages +-- (it might have recovered internally) +-- If so, it fails too. +-- Regardless, any errors generated by m are propagated to the enclosing context. +checkNoErrs main + = do { (res, no_errs) <- askNoErrs main + ; unless no_errs failM + ; return res } + +----------------------- +whenNoErrs :: TcM () -> TcM () +whenNoErrs thing = ifErrsM (return ()) thing + +ifErrsM :: TcRn r -> TcRn r -> TcRn r +-- ifErrsM bale_out normal +-- does 'bale_out' if there are errors in errors collection +-- otherwise does 'normal' +ifErrsM bale_out normal + = do { errs_var <- getErrsVar ; + msgs <- readTcRef errs_var ; + if errorsFound msgs then + bale_out + else + normal } + +failIfErrsM :: TcRn () +-- Useful to avoid error cascades +failIfErrsM = ifErrsM failM (return ()) + +{- ********************************************************************* +* * + Context management for the type checker +* * +************************************************************************ +-} + +{- Note [Inlining addErrCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You will notice a bunch of INLINE pragamas on addErrCtxt and friends. +The reason is to promote better eta-expansion in client modules. +Consider + \e s. addErrCtxt c (tc_foo x) e s +It looks as if tc_foo is applied to only two arguments, but if we +inline addErrCtxt it'll turn into something more like + \e s. tc_foo x (munge c e) s +This is much better because Called Arity analysis can see that tc_foo +is applied to four arguments. See #18379 for a concrete example. + +This reliance on delicate inlining and Called Arity is not good. +See #18202 for a more general approach. But meanwhile, these +inlinings seem unobjectional, and they solve the immediate +problem. + +Note [Error contexts in generated code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* setSrcSpan sets tcl_in_gen_code to True if the SrcSpan is GeneratedSrcSpan, + and back to False when we get a useful SrcSpan + +* When tcl_in_gen_code is True, addErrCtxt becomes a no-op. + +So typically it's better to do setSrcSpan /before/ addErrCtxt. + +See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr for +more discussion of this fancy footwork, as well as +Note [Generated code and pattern-match checking] in GHC.Types.Basic for the +relation with pattern-match checks. +-} + +getErrCtxt :: TcM [ErrCtxt] +getErrCtxt = do { env <- getLclEnv; return (getLclEnvErrCtxt env) } + +setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a +{-# INLINE setErrCtxt #-} -- Note [Inlining addErrCtxt] +setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) + +-- | Add a fixed message to the error context. This message should not +-- do any tidying. +addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a +{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] +addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) + +-- | Add a message to the error context. This message may do tidying. +addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a +{-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] +addErrCtxtM ctxt = pushCtxt (False, ctxt) + +-- | Add a fixed landmark message to the error context. A landmark +-- message is always sure to be reported, even if there is a lot of +-- context. It also doesn't count toward the maximum number of contexts +-- reported. +addLandmarkErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a +{-# INLINE addLandmarkErrCtxt #-} -- Note [Inlining addErrCtxt] +addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) + +-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations +-- and tidying. +addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a +{-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] +addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt) + +pushCtxt :: ErrCtxt -> TcM a -> TcM a +{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt] +pushCtxt ctxt = updLclEnv (updCtxt ctxt) + +updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv +-- Do not update the context if we are in generated code +-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr +updCtxt ctxt env + | lclEnvInGeneratedCode env = env + | otherwise = addLclEnvErrCtxt ctxt env + +popErrCtxt :: TcM a -> TcM a +popErrCtxt thing_inside = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $ + thing_inside + where + pop [] = [] + pop (_:msgs) = msgs + +getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc +getCtLocM origin t_or_k + = do { env <- getLclEnv + ; return (CtLoc { ctl_origin = origin + , ctl_env = mkCtLocEnv env + , ctl_t_or_k = t_or_k + , ctl_depth = initialSubGoalDepth }) } + +mkCtLocEnv :: TcLclEnv -> CtLocEnv +mkCtLocEnv lcl_env = + CtLocEnv { ctl_bndrs = getLclEnvBinderStack lcl_env + , ctl_ctxt = getLclEnvErrCtxt lcl_env + , ctl_loc = getLclEnvLoc lcl_env + , ctl_tclvl = getLclEnvTcLevel lcl_env + , ctl_in_gen_code = lclEnvInGeneratedCode lcl_env + , ctl_rdr = getLclEnvRdrEnv lcl_env + } + +setCtLocM :: CtLoc -> TcM a -> TcM a +-- Set the SrcSpan and error context from the CtLoc +setCtLocM (CtLoc { ctl_env = lcl }) thing_inside + = updLclEnv (\env -> setLclEnvLoc (ctl_loc lcl) + $ setLclEnvErrCtxt (ctl_ctxt lcl) + $ setLclEnvBinderStack (ctl_bndrs lcl) + $ env) thing_inside + +{- ********************************************************************* +* * + Error recovery and exceptions +* * +********************************************************************* -} + +tcTryM :: TcRn r -> TcRn (Maybe r) +-- The most basic function: catch the exception +-- Nothing => an exception happened +-- Just r => no exception, result R +-- Errors and constraints are propagated in both cases +-- Never throws an exception +tcTryM thing_inside + = do { either_res <- tryM thing_inside + ; return (case either_res of + Left _ -> Nothing + Right r -> Just r) } + -- In the Left case the exception is always the IOEnv + -- built-in in exception; see IOEnv.failM + +----------------------- +capture_constraints :: TcM r -> TcM (r, WantedConstraints) +-- capture_constraints simply captures and returns the +-- constraints generated by thing_inside +-- Precondition: thing_inside must not throw an exception! +-- Reason for precondition: an exception would blow past the place +-- where we read the lie_var, and we'd lose the constraints altogether +capture_constraints thing_inside + = do { lie_var <- newTcRef emptyWC + ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $ + thing_inside + ; lie <- readTcRef lie_var + ; return (res, lie) } + +capture_messages :: TcM r -> TcM (r, Messages TcRnMessage) +-- capture_messages simply captures and returns the +-- errors and warnings generated by thing_inside +-- Precondition: thing_inside must not throw an exception! +-- Reason for precondition: an exception would blow past the place +-- where we read the msg_var, and we'd lose the constraints altogether +capture_messages thing_inside + = do { msg_var <- newTcRef emptyMessages + ; res <- setErrsVar msg_var thing_inside + ; msgs <- readTcRef msg_var + ; return (res, msgs) } + +----------------------- +-- (askNoErrs m) runs m +-- If m fails, +-- then (askNoErrs m) fails, propagating only +-- insoluble constraints +-- +-- If m succeeds with result r, +-- then (askNoErrs m) succeeds with result (r, b), +-- where b is True iff m generated no errors +-- +-- Regardless of success or failure, +-- propagate any errors/warnings generated by m +askNoErrs :: TcRn a -> TcRn (a, Bool) +askNoErrs thing_inside + = do { ((mb_res, lie), msgs) <- capture_messages $ + capture_constraints $ + tcTryM thing_inside + ; addMessages msgs + + ; case mb_res of + Nothing -> do { emitConstraints (dropMisleading lie) + ; failM } + + Just res -> do { emitConstraints lie + ; let errs_found = errorsFound msgs + || insolubleWC lie + ; return (res, not errs_found) } } + +----------------------- +tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints) +-- (tryCaptureConstraints_maybe m) runs m, +-- and returns the type constraints it generates +-- It never throws an exception; instead if thing_inside fails, +-- it returns Nothing and the /insoluble/ constraints +-- Error messages are propagated +tryCaptureConstraints thing_inside + = do { (mb_res, lie) <- capture_constraints $ + tcTryM thing_inside + + -- See Note [Constraints and errors] + ; case mb_res of + Just {} -> return (mb_res, lie) + Nothing -> do { let pruned_lie = dropMisleading lie + ; traceTc "tryCaptureConstraints" $ + vcat [ text "lie:" <+> ppr lie + , text "dropMisleading lie:" <+> ppr pruned_lie ] + ; return (Nothing, pruned_lie) } } + +captureConstraints :: TcM a -> TcM (a, WantedConstraints) +-- (captureConstraints m) runs m, and returns the type constraints it generates +-- If thing_inside fails (throwing an exception), +-- then (captureConstraints thing_inside) fails too +-- propagating the insoluble constraints only +-- Error messages are propagated in either case +captureConstraints thing_inside + = do { (mb_res, lie) <- tryCaptureConstraints thing_inside + + -- See Note [Constraints and errors] + -- If the thing_inside threw an exception, emit the insoluble + -- constraints only (returned by tryCaptureConstraints) + -- so that they are not lost + ; case mb_res of + Nothing -> do { emitConstraints lie; failM } + Just res -> return (res, lie) } + +----------------------- +-- | @tcCollectingUsage thing_inside@ runs @thing_inside@ and returns the usage +-- information which was collected as part of the execution of +-- @thing_inside@. Careful: @tcCollectingUsage thing_inside@ itself does not +-- report any usage information, it's up to the caller to incorporate the +-- returned usage information into the larger context appropriately. +tcCollectingUsage :: TcM a -> TcM (UsageEnv,a) +tcCollectingUsage thing_inside + = do { local_usage_ref <- newTcRef zeroUE + ; result <- updLclEnv (\env -> env { tcl_usage = local_usage_ref }) thing_inside + ; local_usage <- readTcRef local_usage_ref + ; return (local_usage,result) } + +-- | @tcScalingUsage mult thing_inside@ runs @thing_inside@ and scales all the +-- usage information by @mult@. +tcScalingUsage :: Mult -> TcM a -> TcM a +tcScalingUsage mult thing_inside + = do { (usage, result) <- tcCollectingUsage thing_inside + ; traceTc "tcScalingUsage" $ vcat [ppr mult, ppr usage] + ; tcEmitBindingUsage $ scaleUE mult usage + ; return result } + +tcEmitBindingUsage :: UsageEnv -> TcM () +tcEmitBindingUsage ue + = do { lcl_env <- getLclEnv + ; let usage = tcl_usage lcl_env + ; updTcRef usage (addUE ue) } + +----------------------- +attemptM :: TcRn r -> TcRn (Maybe r) +-- (attemptM thing_inside) runs thing_inside +-- If thing_inside succeeds, returning r, +-- we return (Just r), and propagate all constraints and errors +-- If thing_inside fail, throwing an exception, +-- we return Nothing, propagating insoluble constraints, +-- and all errors +-- attemptM never throws an exception +attemptM thing_inside + = do { (mb_r, lie) <- tryCaptureConstraints thing_inside + ; emitConstraints lie + + -- Debug trace + ; when (isNothing mb_r) $ + traceTc "attemptM recovering with insoluble constraints" $ + (ppr lie) + + ; return mb_r } + +----------------------- +recoverM :: TcRn r -- Recovery action; do this if the main one fails + -> TcRn r -- Main action: do this first; + -- if it generates errors, propagate them all + -> TcRn r +-- (recoverM recover thing_inside) runs thing_inside +-- If thing_inside fails, propagate its errors and insoluble constraints +-- and run 'recover' +-- If thing_inside succeeds, propagate all its errors and constraints +-- +-- Can fail, if 'recover' fails +recoverM recover thing + = do { mb_res <- attemptM thing ; + case mb_res of + Nothing -> recover + Just res -> return res } + +----------------------- + +-- | Drop elements of the input that fail, so the result +-- list can be shorter than the argument list +mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] +mapAndRecoverM f xs + = do { mb_rs <- mapM (attemptM . f) xs + ; return [r | Just r <- mb_rs] } + +-- | Apply the function to all elements on the input list +-- If all succeed, return the list of results +-- Otherwise fail, propagating all errors +mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b] +mapAndReportM f xs + = do { mb_rs <- mapM (attemptM . f) xs + ; when (any isNothing mb_rs) failM + ; return [r | Just r <- mb_rs] } + +-- | The accumulator is not updated if the action fails +foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b +foldAndRecoverM _ acc [] = return acc +foldAndRecoverM f acc (x:xs) = + do { mb_r <- attemptM (f acc x) + ; case mb_r of + Nothing -> foldAndRecoverM f acc xs + Just acc' -> foldAndRecoverM f acc' xs } + +----------------------- +tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage) +-- (tryTc m) executes m, and returns +-- Just r, if m succeeds (returning r) +-- Nothing, if m fails +-- It also returns all the errors and warnings accumulated by m +-- It always succeeds (never raises an exception) +tryTc thing_inside + = capture_messages (attemptM thing_inside) + +----------------------- +discardErrs :: TcRn a -> TcRn a +-- (discardErrs m) runs m, +-- discarding all error messages and warnings generated by m +-- If m fails, discardErrs fails, and vice versa +discardErrs m + = do { errs_var <- newTcRef emptyMessages + ; setErrsVar errs_var m } + +----------------------- +tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r +-- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside'; +-- if 'main' succeeds with no error messages, it's the answer +-- otherwise discard everything from 'main', including errors, +-- and try 'recover' instead. +tryTcDiscardingErrs recover = + tryTcDiscardingErrs' + (\_ _ _ -> True) -- No validation + recover recover -- Discard all errors and warnings + -- and unsolved constraints entirely + +tryTcDiscardingErrs' :: (WantedConstraints -> Messages TcRnMessage -> r -> Bool) -- Validation + -> TcM r -- Recover from validation error + -> TcM r -- Recover from failure + -> TcM r -- Action to try + -> TcM r +-- (tryTcDiscardingErrs' validate recover_invalid recover_error thing_inside) tries 'thing_inside'; +-- if 'thing_inside' succeeds and validation produces no errors, it's the answer +-- otherwise discard everything from 'thing_inside', including errors, +-- and try 'recover' instead. +tryTcDiscardingErrs' validate recover_invalid recover_error thing_inside + = do { ((mb_res, lie), msgs) <- capture_messages $ + capture_constraints $ + tcTryM thing_inside + ; case mb_res of + Just res | not (errorsFound msgs) + , not (insolubleWC lie) + -- 'thing_inside' succeeded with no errors + -> if validate lie msgs res + then do { addMessages msgs -- msgs might still have warnings + ; emitConstraints lie + ; return res } + else recover_invalid + + _ -> -- 'thing_inside' failed, or produced an error message + recover_error + } + +{- +************************************************************************ +* * + Error message generation (type checker) +* * +************************************************************************ + + The addErrTc functions add an error message, but do not cause failure. + The 'M' variants pass a TidyEnv that has already been used to + tidy up the message; we then use it to tidy the context messages +-} + +{- + +Note [Reporting warning diagnostics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use functions below to report warnings. For the most part, +we do /not/ need to check any warning flags before doing so. +See https://gitlab.haskell.org/ghc/ghc/-/wikis/Errors-as-(structured)-values +for the design. + +-} + +addErrTc :: TcRnMessage -> TcM () +addErrTc err_msg = do { env0 <- liftZonkM tcInitTidyEnv + ; addErrTcM (env0, err_msg) } + +addErrTcM :: (TidyEnv, TcRnMessage) -> TcM () +addErrTcM (tidy_env, err_msg) + = do { ctxt <- getErrCtxt ; + loc <- getSrcSpanM ; + add_err_tcm tidy_env err_msg loc ctxt } + +-- The failWith functions add an error message and cause failure + +failWithTc :: TcRnMessage -> TcM a -- Add an error message and fail +failWithTc err_msg + = addErrTc err_msg >> failM + +failWithTcM :: (TidyEnv, TcRnMessage) -> TcM a -- Add an error message and fail +failWithTcM local_and_msg + = addErrTcM local_and_msg >> failM + +checkTc :: Bool -> TcRnMessage -> TcM () -- Check that the boolean is true +checkTc True _ = return () +checkTc False err = failWithTc err + +checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM () +checkTcM True _ = return () +checkTcM False err = failWithTcM err + +checkJustTc :: TcRnMessage -> Maybe a -> TcM a +checkJustTc err = maybe (failWithTc err) pure + +checkJustTcM :: (TidyEnv, TcRnMessage) -> Maybe a -> TcM a +checkJustTcM err = maybe (failWithTcM err) pure + +failIfTc :: Bool -> TcRnMessage -> TcM () -- Check that the boolean is false +failIfTc False _ = return () +failIfTc True err = failWithTc err + +failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM () + -- Check that the boolean is false +failIfTcM False _ = return () +failIfTcM True err = failWithTcM err + + +-- Warnings have no 'M' variant, nor failure + +-- | Display a warning if a condition is met. +warnIf :: Bool -> TcRnMessage -> TcRn () +warnIf is_bad msg -- No need to check any flag here, it will be done in 'diagReasonSeverity'. + = when is_bad (addDiagnostic msg) + +-- | Display a warning if a condition is met. +diagnosticTc :: Bool -> TcRnMessage -> TcM () +diagnosticTc should_report warn_msg + | should_report = addDiagnosticTc warn_msg + | otherwise = return () + +-- | Display a diagnostic if a condition is met. +diagnosticTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM () +diagnosticTcM should_report warn_msg + | should_report = addDiagnosticTcM warn_msg + | otherwise = return () + +-- | Display a diagnostic in the current context. +addDiagnosticTc :: TcRnMessage -> TcM () +addDiagnosticTc msg + = do { env0 <- liftZonkM tcInitTidyEnv + ; addDiagnosticTcM (env0, msg) } + +-- | Display a diagnostic in a given context. +addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM () +addDiagnosticTcM (env0, msg) + = do { ctxt <- getErrCtxt + ; extra <- mkErrCtxt env0 ctxt + ; let detailed_msg = mkDetailedMessage (ErrInfo extra Nothing noHints) msg + ; add_diagnostic detailed_msg } + +-- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage' +-- given some additional context about the diagnostic. +addDetailedDiagnostic :: ([ErrCtxtMsg] -> TcRnMessage) -> TcM () +addDetailedDiagnostic mkMsg = do + loc <- getSrcSpanM + name_ppr_ctx <- getNamePprCtx + !diag_opts <- initDiagOpts <$> getDynFlags + env0 <- liftZonkM tcInitTidyEnv + ctxt <- getErrCtxt + err_info <- mkErrCtxt env0 ctxt + reportDiagnostic $ + mkMsgEnvelope diag_opts loc name_ppr_ctx $ + mkMsg err_info + +addTcRnDiagnostic :: TcRnMessage -> TcM () +addTcRnDiagnostic msg = do + loc <- getSrcSpanM + mkTcRnMessage loc msg >>= reportDiagnostic + +-- | Display a diagnostic for the current source location, taken from +-- the 'TcRn' monad. +addDiagnostic :: TcRnMessage -> TcRn () +addDiagnostic msg = add_diagnostic (mkDetailedMessage (ErrInfo [] Nothing noHints) msg) + +-- | Display a diagnostic for a given source location. +addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn () +addDiagnosticAt loc msg = do + unit_state <- hsc_units <$> getTopEnv + let detailed_msg = mkDetailedMessage (ErrInfo [] Nothing noHints) msg + mkTcRnMessage loc (TcRnMessageWithInfo unit_state detailed_msg) >>= reportDiagnostic + +-- | Display a diagnostic, with an optional flag, for the current source +-- location. +add_diagnostic :: TcRnMessageDetailed -> TcRn () +add_diagnostic msg + = do { loc <- getSrcSpanM + ; unit_state <- hsc_units <$> getTopEnv + ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic + } + +{- +----------------------------------- + Other helper functions +-} + +add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan + -> [ErrCtxt] + -> TcM () +add_err_tcm tidy_env msg loc ctxt + = do { err_ctxt <- mkErrCtxt tidy_env ctxt + ; add_long_err_at loc $ + mkDetailedMessage (ErrInfo err_ctxt Nothing noHints) msg } + +mkErrCtxt :: TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] +-- Tidy the error info, trimming excessive contexts +mkErrCtxt env ctxts +-- = do +-- dbg <- hasPprDebug <$> getDynFlags +-- if dbg -- In -dppr-debug style the output +-- then return empty -- just becomes too voluminous +-- else go dbg 0 env ctxts + = go False 0 env ctxts + where + go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] + go _ _ _ [] = return [] + go dbg n env ((is_landmark, ctxt) : ctxts) + | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg + = do { (env', msg) <- liftZonkM $ ctxt env + ; let n' = if is_landmark then n else n+1 + ; rest <- go dbg n' env' ctxts + ; return (msg : rest) } + | otherwise + = go dbg n env ctxts + +mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts +mAX_CONTEXTS = 3 + +-- debugTc is useful for monadic debugging code + +debugTc :: TcM () -> TcM () +debugTc thing + | debugIsOn = thing + | otherwise = return () + +{- +************************************************************************ +* * + Type constraints +* * +************************************************************************ +-} + +addTopEvBinds :: Bag EvBind -> TcM a -> TcM a +addTopEvBinds new_ev_binds thing_inside + =updGblEnv upd_env thing_inside + where + upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env + `unionBags` new_ev_binds } + +newTcEvBinds :: TcM EvBindsVar +newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap + ; tcvs_ref <- newTcRef [] + ; uniq <- newUnique + ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq) + ; return (EvBindsVar { ebv_binds = binds_ref + , ebv_tcvs = tcvs_ref + , ebv_uniq = uniq }) } + +-- | Creates an EvBindsVar incapable of holding any bindings. It still +-- tracks covar usages (see comments on ebv_tcvs in "GHC.Tc.Types.Evidence"), thus +-- must be made monadically +newNoTcEvBinds :: TcM EvBindsVar +newNoTcEvBinds + = do { tcvs_ref <- newTcRef [] + ; uniq <- newUnique + ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq) + ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref + , ebv_uniq = uniq }) } + +cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar +-- Clone the refs, so that any binding created when +-- solving don't pollute the original +cloneEvBindsVar ebv@(EvBindsVar {}) + = do { binds_ref <- newTcRef emptyEvBindMap + ; tcvs_ref <- newTcRef [] + ; return (ebv { ebv_binds = binds_ref + , ebv_tcvs = tcvs_ref }) } +cloneEvBindsVar ebv@(CoEvBindsVar {}) + = do { tcvs_ref <- newTcRef [] + ; return (ebv { ebv_tcvs = tcvs_ref }) } + +getTcEvTyCoVars :: EvBindsVar -> TcM [TcCoercion] +getTcEvTyCoVars ev_binds_var + = readTcRef (ebv_tcvs ev_binds_var) + +getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap +getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) + = readTcRef ev_ref +getTcEvBindsMap (CoEvBindsVar {}) + = return emptyEvBindMap + +setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM () +setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds + = writeTcRef ev_ref binds +setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds + | isEmptyEvBindMap ev_binds + = return () + | otherwise + = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds) + +updTcEvBinds :: EvBindsVar -> EvBindsVar -> TcM () +updTcEvBinds (EvBindsVar { ebv_binds = old_ebv_ref, ebv_tcvs = old_tcv_ref }) + (EvBindsVar { ebv_binds = new_ebv_ref, ebv_tcvs = new_tcv_ref }) + = do { new_ebvs <- readTcRef new_ebv_ref + ; updTcRef old_ebv_ref (`unionEvBindMap` new_ebvs) + ; new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (new_tcvs ++) } +updTcEvBinds (EvBindsVar { ebv_tcvs = old_tcv_ref }) + (CoEvBindsVar { ebv_tcvs = new_tcv_ref }) + = do { new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (new_tcvs ++) } +updTcEvBinds (CoEvBindsVar { ebv_tcvs = old_tcv_ref }) + (CoEvBindsVar { ebv_tcvs = new_tcv_ref }) + = do { new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (new_tcvs ++) } +updTcEvBinds old_var new_var + = pprPanic "updTcEvBinds" (ppr old_var $$ ppr new_var) + -- Terms inside types, no good + +addTcEvBind :: EvBindsVar -> EvBind -> TcM () +-- Add a binding to the TcEvBinds by side effect +addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind + = do { bnds <- readTcRef ev_ref + ; let bnds' = extendEvBinds bnds ev_bind + ; traceTc "addTcEvBind" $ + vcat [ text "EvBindsVar:" <+> ppr u + , text "ev_bind:" <+> ppr ev_bind + , text "bnds:" <+> ppr bnds + , text "bnds':" <+> ppr bnds' ] + ; writeTcRef ev_ref bnds' } +addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind + = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u) + +addTcEvBinds :: EvBindsVar -> EvBindMap -> TcM () +-- ^ Add a collection of binding to the TcEvBinds by side effect +addTcEvBinds _ new_ev_binds + | isEmptyEvBindMap new_ev_binds + = return () +addTcEvBinds (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) new_ev_binds + = do { traceTc "addTcEvBinds" $ ppr u $$ + ppr new_ev_binds + ; old_bnds <- readTcRef ev_ref + ; writeTcRef ev_ref (old_bnds `unionEvBindMap` new_ev_binds) } +addTcEvBinds (CoEvBindsVar { ebv_uniq = u }) new_ev_binds + = pprPanic "addTcEvBinds CoEvBindsVar" (ppr new_ev_binds $$ ppr u) + +chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName +chooseUniqueOccTc fn = + do { env <- getGblEnv + ; let dfun_n_var = tcg_dfun_n env + ; set <- readTcRef dfun_n_var + ; let occ = fn set + ; writeTcRef dfun_n_var (extendOccSet set occ) + ; return occ } + +newZonkAnyType :: Kind -> TcM Type +-- Return a type (ZonkAny @k n), where n is fresh +-- Recall ZonkAny :: forall k. Natural -> k +-- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4) +newZonkAnyType kind + = do { env <- getGblEnv + ; let zany_n_var = tcg_zany_n env + ; i <- readTcRef zany_n_var + ; let !i2 = i+1 + ; writeTcRef zany_n_var i2 + ; return (mkTyConApp zonkAnyTyCon [kind, mkNumLitTy i]) } + +getConstraintVar :: TcM (TcRef WantedConstraints) +getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } + +setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a +setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) + +emitStaticConstraints :: WantedConstraints -> TcM () +emitStaticConstraints static_lie + = do { gbl_env <- getGblEnv + ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) } + +emitConstraints :: WantedConstraints -> TcM () +emitConstraints ct + | isEmptyWC ct + = return () + | otherwise + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`andWC` ct) } + +emitSimple :: Ct -> TcM () +emitSimple ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addSimples` unitBag ct) } + +emitSimples :: Cts -> TcM () +emitSimples cts + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addSimples` cts) } + +emitImplication :: Implication -> TcM () +emitImplication ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addImplics` unitBag ct) } + +emitImplications :: Bag Implication -> TcM () +emitImplications ct + = unless (isEmptyBag ct) $ + do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addImplics` ct) } + +emitDelayedErrors :: Bag DelayedError -> TcM () +emitDelayedErrors errs + = do { traceTc "emitDelayedErrors" (ppr errs) + ; lie_var <- getConstraintVar + ; updTcRef lie_var (`addDelayedErrors` errs)} + +emitHole :: Hole -> TcM () +emitHole hole + = do { traceTc "emitHole" (ppr hole) + ; lie_var <- getConstraintVar + ; updTcRef lie_var (`addHoles` unitBag hole) } + +emitHoles :: Bag Hole -> TcM () +emitHoles holes + = do { traceTc "emitHoles" (ppr holes) + ; lie_var <- getConstraintVar + ; updTcRef lie_var (`addHoles` holes) } + +emitNotConcreteError :: NotConcreteError -> TcM () +emitNotConcreteError err + = do { traceTc "emitNotConcreteError" (ppr err) + ; lie_var <- getConstraintVar + ; updTcRef lie_var (`addNotConcreteError` err) } + +-- See Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify. +ensureReflMultiplicityCo :: TcCoercion -> CtOrigin -> TcM () +ensureReflMultiplicityCo mult_co origin + = do { traceTc "ensureReflMultiplicityCo" (ppr mult_co) + ; unless (isReflCo mult_co) $ do + { loc <- getCtLocM origin Nothing + ; lie_var <- getConstraintVar + ; updTcRef lie_var (\w -> addMultiplicityCoercionError w mult_co loc) } } + +-- | Throw out any constraints emitted by the thing_inside +discardConstraints :: TcM a -> TcM a +discardConstraints thing_inside = fst <$> captureConstraints thing_inside + +-- | The name says it all. The returned TcLevel is the *inner* TcLevel. +pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) +pushLevelAndCaptureConstraints thing_inside + = do { tclvl <- getTcLevel + ; let tclvl' = pushTcLevel tclvl + ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl') + ; (res, lie) <- updLclEnv (setLclEnvTcLevel tclvl') $ + captureConstraints thing_inside + ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl') + ; return (tclvl', lie, res) } + +pushTcLevelM_ :: TcM a -> TcM a +pushTcLevelM_ = updLclEnv (modifyLclEnvTcLevel pushTcLevel) + +pushTcLevelM :: TcM a -> TcM (TcLevel, a) +-- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType +pushTcLevelM thing_inside + = do { tclvl <- getTcLevel + ; let tclvl' = pushTcLevel tclvl + ; res <- updLclEnv (setLclEnvTcLevel tclvl') thing_inside + ; return (tclvl', res) } + +getTcLevel :: TcM TcLevel +getTcLevel = do { env <- getLclEnv + ; return $! getLclEnvTcLevel env } + +setTcLevel :: TcLevel -> TcM a -> TcM a +setTcLevel tclvl thing_inside + = updLclEnv (setLclEnvTcLevel tclvl) thing_inside + +isTouchableTcM :: TcTyVar -> TcM Bool +isTouchableTcM tv + = do { lvl <- getTcLevel + ; return (isTouchableMetaTyVar lvl tv) } + +getLclTypeEnv :: TcM TcTypeEnv +getLclTypeEnv = do { env <- getLclEnv; return (getLclEnvTypeEnv env) } + +setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a +-- Set the local type envt, but do *not* disturb other fields, +-- notably the lie_var +setLclTypeEnv lcl_env thing_inside + = updLclEnv (setLclEnvTypeEnv (getLclEnvTypeEnv lcl_env)) thing_inside + +traceTcConstraints :: String -> TcM () +traceTcConstraints msg + = do { lie_var <- getConstraintVar + ; lie <- readTcRef lie_var + ; traceOptTcRn Opt_D_dump_tc_trace $ + hang (text (msg ++ ": LIE:")) 2 (ppr lie) + } + +data IsExtraConstraint = YesExtraConstraint + | NoExtraConstraint + +instance Outputable IsExtraConstraint where + ppr YesExtraConstraint = text "YesExtraConstraint" + ppr NoExtraConstraint = text "NoExtraConstraint" + +emitAnonTypeHole :: IsExtraConstraint + -> TcTyVar -> TcM () +emitAnonTypeHole extra_constraints tv + = do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing + ; let hole = Hole { hole_sort = sort + , hole_occ = mkRdrUnqual occ + , hole_ty = mkTyVarTy tv + , hole_loc = ct_loc } + ; emitHole hole } + where + occ = mkTyVarOccFS (fsLit "_") + sort | YesExtraConstraint <- extra_constraints = ConstraintHole + | otherwise = TypeHole + +emitNamedTypeHole :: (Name, TcTyVar) -> TcM () +emitNamedTypeHole (name, tv) + = do { ct_loc <- setSrcSpan (nameSrcSpan name) $ + getCtLocM (TypeHoleOrigin occ) Nothing + ; let hole = Hole { hole_sort = TypeHole + , hole_occ = nameRdrName name + , hole_ty = mkTyVarTy tv + , hole_loc = ct_loc } + ; emitHole hole } + where + occ = nameOccName name + +{- Note [Constraints and errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#12124): + + foo :: Maybe Int + foo = return (case Left 3 of + Left -> 1 -- Hard error here! + _ -> 0) + +The call to 'return' will generate a (Monad m) wanted constraint; but +then there'll be "hard error" (i.e. an exception in the TcM monad), from +the unsaturated Left constructor pattern. + +We'll recover in tcPolyBinds, using recoverM. But then the final +tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly +un-filled-in, and will emit a misleading error message. + +The underlying problem is that an exception interrupts the constraint +gathering process. Bottom line: if we have an exception, it's best +simply to discard any gathered constraints. Hence in 'attemptM' we +capture the constraints in a fresh variable, and only emit them into +the surrounding context if we exit normally. If an exception is +raised, simply discard the collected constraints... we have a hard +error to report. So this capture-the-emit dance isn't as stupid as it +looks :-). + +However suppose we throw an exception inside an invocation of +captureConstraints, and discard all the constraints. Some of those +constraints might be "variable out of scope" Hole constraints, and that +might have been the actual original cause of the exception! For +example (#12529): + f = p @ Int +Here 'p' is out of scope, so we get an insoluble Hole constraint. But +the visible type application fails in the monad (throws an exception). +We must not discard the out-of-scope error. + +It's distressingly delicate though: + +* If we discard too /many/ constraints we may fail to report the error + that led us to interrupt the constraint gathering process. + + One particular example "variable out of scope" Hole constraints. For + example (#12529): + f = p @ Int + Here 'p' is out of scope, so we get an insoluble Hole constraint. But + the visible type application fails in the monad (throws an exception). + We must not discard the out-of-scope error. + + Also GHC.Tc.Solver.simplifyAndEmitFlatConstraints may fail having + emitted some constraints with skolem-escape problems. + +* If we discard too /few/ constraints, we may get the misleading + class constraints mentioned above. + + We may /also/ end up taking constraints built at some inner level, and + emitting them (via the exception catching in `tryCaptureConstraints` at some + outer level, and then breaking the TcLevel invariants See Note [TcLevel + invariants] in GHC.Tc.Utils.TcType + +So `dropMisleading` has a horridly ad-hoc structure: + +* It keeps only /insoluble/ flat constraints (which are unlikely to very visibly + trip up on the TcLevel invariant + +* But it keeps all /implication/ constraints (except the class constraints + inside them). The implication constraints are OK because they set the ambient + level before attempting to solve any inner constraints. + +Ugh! I hate this. But it seems to work. + +Other wrinkles + +(CERR1) Note that freshly-generated constraints like (Int ~ Bool), or + ((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as + insoluble. The constraint solver does that. So they'll be discarded. + That's probably ok; but see th/5358 as a not-so-good example: + t1 :: Int + t1 x = x -- Manifestly wrong + + foo = $(...raises exception...) + We report the exception, but not the bug in t1. Oh well. Possible + solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints. + +(CERR2) In #26015 I found that from the constraints + [W] alpha ~ Int -- A class constraint + [W] F alpha ~# Bool -- An equality constraint + we were dropping the first (becuase it's a class constraint) but not the + second, and then getting a misleading error message from the second. As + #25607 shows, we can get not just one but a zillion bogus messages, which + conceal the one genuine error. Boo. + + For now I have added an even more ad-hoc "drop class constraints except + equality classes (~) and (~~)"; see `dropMisleading`. That just kicks the can + down the road; but this problem seems somewhat rare anyway. The code in + `dropMisleading` hasn't changed for years. + +It would be great to have a more systematic solution to this entire mess. + + +************************************************************************ +* * + Template Haskell context +* * +************************************************************************ +-} + +recordThUse :: TcM () +recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } + +recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM () +recordThNeededRuntimeDeps new_links new_pkgs + = do { env <- getGblEnv + ; updTcRef (tcg_th_needed_deps env) $ \(needed_links, needed_pkgs) -> + let links = new_links ++ needed_links + !pkgs = plusUDFM needed_pkgs new_pkgs + in (links, pkgs) + } + +keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set +keepAlive name + = do { env <- getGblEnv + ; traceRn "keep alive" (ppr name) + ; updTcRef (tcg_keep env) (`extendNameSet` name) } + +getThLevel :: TcM ThLevel +getThLevel = do { env <- getLclEnv; return (getLclEnvThLevel env) } + +getCurrentAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel)) +getCurrentAndBindLevel name + = do { env <- getLclEnv; + ; case lookupNameEnv (getLclEnvThBndrs env) name of + Nothing -> do + lvls <- getExternalBindLvl name + if Set.empty == lvls + -- This case happens when code is generated for identifiers which are not + -- in scope. + -- + -- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||] + then do + return Nothing + else return (Just (TopLevel, lvls, getLclEnvThLevel env)) + Just (top_lvl, bind_lvl) -> return (Just (top_lvl, Set.singleton bind_lvl, getLclEnvThLevel env)) } + +getExternalBindLvl :: Name -> TcRn (Set.Set ThLevelIndex) +getExternalBindLvl name = do + env <- getGlobalRdrEnv + mod <- getModule + case lookupGRE_Name env name of + Just gre -> return $ (Set.map thLevelIndexFromImportLevel (greLevels gre)) + Nothing -> + if nameIsLocalOrFrom mod name + then return $ Set.singleton topLevelIndex + else return Set.empty + +setThLevel :: ThLevel -> TcM a -> TcRn a +setThLevel l = updLclEnv (setLclEnvThLevel l) + +-- | Adds the given modFinalizers to the global environment and set them to use +-- the current local environment. +addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () +addModFinalizersWithLclEnv mod_finalizers + = do lcl_env <- getLclEnv + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + updTcRef th_modfinalizers_var $ \fins -> + (lcl_env, mod_finalizers) : fins + +{- +************************************************************************ +* * + Safe Haskell context +* * +************************************************************************ +-} + +-- | Mark that safe inference has failed +-- See Note [Safe Haskell Overlapping Instances Implementation] +-- although this is used for more than just that failure case. +recordUnsafeInfer :: Messages TcRnMessage -> TcM () +recordUnsafeInfer msgs = + getGblEnv >>= \env -> do writeTcRef (tcg_safe_infer env) False + writeTcRef (tcg_safe_infer_reasons env) msgs + +-- | Figure out the final correct safe haskell mode +finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode +finalSafeMode dflags tcg_env = do + safeInf <- readIORef (tcg_safe_infer tcg_env) + return $ case safeHaskell dflags of + Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred + | otherwise -> Sf_None + s -> s + +-- | Switch instances to safe instances if we're in Safe mode. +fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst] +fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id +fixSafeInstances _ = map fixSafe + where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True } + in inst { is_flag = new_flag } + +{- +************************************************************************ +* * + Stuff for the renamer's local env +* * +************************************************************************ +-} + +getLocalRdrEnv :: RnM LocalRdrEnv +getLocalRdrEnv = do { env <- getLclEnv; return (getLclEnvRdrEnv env) } + +setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a +setLocalRdrEnv rdr_env thing_inside + = updLclEnv (setLclEnvRdrEnv rdr_env) thing_inside + +{- +************************************************************************ +* * + Stuff for interface decls +* * +************************************************************************ +-} + +mkIfLclEnv :: Module -> SDoc -> IsBootInterface -> IfLclEnv +mkIfLclEnv mod loc boot + = IfLclEnv { if_mod = mod, + if_loc = loc, + if_boot = boot, + if_nsubst = Nothing, + if_implicits_env = Nothing, + if_tv_env = emptyFsEnv, + if_id_env = emptyFsEnv } + +-- | Run an 'IfG' (top-level interface monad) computation inside an existing +-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv' +-- based on 'TcGblEnv'. +initIfaceTcRn :: IfG a -> TcRn a +initIfaceTcRn thing_inside + = do { tcg_env <- getGblEnv + ; hsc_env <- getTopEnv + -- bangs to avoid leaking the envs (#19356) + ; let !mhome_unit = hsc_home_unit_maybe hsc_env + !knot_vars = tcg_type_env_var tcg_env + -- When we are instantiating a signature, we DEFINITELY + -- do not want to knot tie. + is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit) + ; let { if_env = IfGblEnv { + if_doc = text "initIfaceTcRn", + if_rec_types = + if is_instantiate + then emptyKnotVars + else readTcRef <$> knot_vars + } + } + ; setEnvs (if_env, ()) thing_inside } + +-- | 'initIfaceLoad' can be used when there's no chance that the action will +-- call 'typecheckIface' when inside a module loop and hence 'tcIfaceGlobal'. +initIfaceLoad :: HscEnv -> IfG a -> IO a +initIfaceLoad hsc_env do_this + = do let gbl_env = IfGblEnv { + if_doc = text "initIfaceLoad", + if_rec_types = emptyKnotVars + } + initTcRnIf 'i' (hsc_env { hsc_type_env_vars = emptyKnotVars }) gbl_env () do_this + +-- | This is used when we are doing to call 'typecheckModule' on an 'ModIface', +-- if it's part of a loop with some other modules then we need to use their +-- IORef TypeEnv vars when typechecking but crucially not our own. +initIfaceLoadModule :: HscEnv -> Module -> IfG a -> IO a +initIfaceLoadModule hsc_env this_mod do_this + = do let gbl_env = IfGblEnv { + if_doc = text "initIfaceLoadModule", + if_rec_types = readTcRef <$> knotVarsWithout this_mod (hsc_type_env_vars hsc_env) + } + initTcRnIf 'i' hsc_env gbl_env () do_this + +initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a +-- Used when checking the up-to-date-ness of the old Iface +-- Initialise the environment with no useful info at all +initIfaceCheck doc hsc_env do_this + = do let gbl_env = IfGblEnv { + if_doc = text "initIfaceCheck" <+> doc, + if_rec_types = readTcRef <$> hsc_type_env_vars hsc_env + } + initTcRnIf 'i' hsc_env gbl_env () do_this + +initIfaceLcl :: Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a +initIfaceLcl mod loc_doc hi_boot_file thing_inside + = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside + +-- | Initialize interface typechecking, but with a 'NameShape' +-- to apply when typechecking top-level 'OccName's (see +-- 'lookupIfaceTop') +initIfaceLclWithSubst :: Module -> SDoc -> IsBootInterface -> NameShape -> IfL a -> IfM lcl a +initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside + = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside + +getIfModule :: IfL Module +getIfModule = do { env <- getLclEnv; return (if_mod env) } + +-------------------- +failIfM :: SDoc -> IfL a +-- The Iface monad doesn't have a place to accumulate errors, so we +-- just fall over fast if one happens; it "shouldn't happen". +-- We use IfL here so that we can get context info out of the local env +failIfM msg = do + env <- getLclEnv + let full_msg = (if_loc env <> colon) $$ nest 2 msg + logger <- getLogger + liftIO (logMsg logger MCFatal + noSrcSpan $ withPprStyle defaultErrStyle full_msg) + failM + +-------------------- + +-- | Run thing_inside in an interleaved thread. +-- It shares everything with the parent thread, so this is DANGEROUS. +-- +-- It throws an error if the computation fails +-- +-- It's used for lazily type-checking interface +-- signatures, which is pretty benign. +-- +-- See Note [Masking exceptions in forkM] +forkM :: SDoc -> IfL a -> IfL a +forkM doc thing_inside + = unsafeInterleaveM $ uninterruptibleMaskM_ $ + do { traceIf (text "Starting fork {" <+> doc) + ; mb_res <- tryM $ + updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ + thing_inside + ; case mb_res of + Right r -> do { traceIf (text "} ending fork" <+> doc) + ; return r } + Left exn -> do { + -- Bleat about errors in the forked thread, if -ddump-if-trace is on + -- Otherwise we silently discard errors. Errors can legitimately + -- happen when compiling interface signatures. + whenDOptM Opt_D_dump_if_trace $ do + logger <- getLogger + let msg = hang (text "forkM failed:" <+> doc) + 2 (text (show exn)) + liftIO $ logMsg logger + MCFatal + noSrcSpan + $ withPprStyle defaultErrStyle msg + ; traceIf (text "} ending fork (badly)" <+> doc) + ; pgmError "Cannot continue after interface file error" } + } + +setImplicitEnvM :: TypeEnv -> IfL a -> IfL a +setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl + { if_implicits_env = Just tenv }) m + +{- +Note [Masking exceptions in forkM] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When using GHC-as-API it must be possible to interrupt snippets of code +executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible +by throwing an asynchronous interrupt to the GHC thread. However, there is a +subtle problem: runStmt first typechecks the code before running it, and the +exception might interrupt the type checker rather than the code. Moreover, the +typechecker might be inside an unsafeInterleaveIO (through forkM), and +more importantly might be inside an exception handler inside that +unsafeInterleaveIO. If that is the case, the exception handler will rethrow the +asynchronous exception as a synchronous exception, and the exception will end +up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed +discussion). We don't currently know a general solution to this problem, but +we can use uninterruptibleMask_ to avoid the situation. +-} + +-- | Get the next cost centre index associated with a given name. +getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIf gbl lcl CostCentreIndex +getCCIndexM get_ccs nm = do + env <- getGblEnv + let cc_st_ref = get_ccs env + cc_st <- readTcRef cc_st_ref + let (idx, cc_st') = getCCIndex nm cc_st + writeTcRef cc_st_ref cc_st' + return idx + +-- | See 'getCCIndexM'. +getCCIndexTcM :: FastString -> TcM CostCentreIndex +getCCIndexTcM = getCCIndexM tcg_cc_st + +-------------------------------------------------------------------------------- + +-- | Lift a computation from the dedicated zonking monad 'ZonkM' to the +-- full-fledged 'TcM' monad. +liftZonkM :: ZonkM a -> TcM a +liftZonkM (ZonkM f) = + do { logger <- getLogger + ; name_ppr_ctx <- getNamePprCtx + ; lvl <- getTcLevel + ; src_span <- getSrcSpanM + ; bndrs <- getLclEnvBinderStack <$> getLclEnv + ; let zge = ZonkGblEnv { zge_logger = logger + , zge_name_ppr_ctx = name_ppr_ctx + , zge_src_span = src_span + , zge_tc_level = lvl + , zge_binder_stack = bndrs } + ; liftIO $ f zge } +{-# INLINE liftZonkM #-} + +-------------------------------------------------------------------------------- + +getCompleteMatchesTcM :: TcM CompleteMatches +getCompleteMatchesTcM + = do { hsc_env <- getTopEnv + ; eps <- liftIO $ hscEPS hsc_env + ; tcg_env <- getGblEnv + ; let tcg_comps = tcg_complete_match_env tcg_env + ; liftIO $ localAndImportedCompleteMatches tcg_comps eps + } + +localAndImportedCompleteMatches :: CompleteMatches -> ExternalPackageState -> IO CompleteMatches +localAndImportedCompleteMatches tcg_comps eps = do + return $ + tcg_comps -- from the current modulea and from the home package + ++ eps_complete_matches eps -- from external packages diff --git a/GHC/Tc/Utils/TcMType.hs b/GHC/Tc/Utils/TcMType.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/TcMType.hs @@ -0,0 +1,2483 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Monadic type operations +-- +-- This module contains monadic operations over types that contain mutable type +-- variables. +module GHC.Tc.Utils.TcMType ( + TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, + + -------------------------------- + -- Creating new mutable type variables + newFlexiTyVar, + newNamedFlexiTyVar, + newFlexiTyVarTy, -- Kind -> TcM TcType + newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] + newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind, + newOpenFlexiFRRTyVar, newOpenFlexiFRRTyVarTy, + newOpenBoxedTypeKind, + newMetaKindVar, newMetaKindVars, + newMetaTyVarTyAtLevel, newConcreteTyVarTyAtLevel, substConcreteTvOrigin, + newAnonMetaTyVar, newConcreteTyVar, + cloneMetaTyVar, cloneMetaTyVarWithInfo, + newCycleBreakerTyVar, + + newMultiplicityVar, + readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, + newTauTvDetailsAtLevel, newMetaDetails, newMetaTyVarName, + isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, + + -------------------------------- + -- Creating new evidence variables + newEvVar, newEvVars, newDict, + newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv, + emitWanted, emitWantedEq, emitWantedEvVar, + emitWantedEqs, + newTcEvBinds, newNoTcEvBinds, addTcEvBind, + emitNewExprHole, + + newCoercionHole, + fillCoercionHole, isFilledCoercionHole, + checkCoercionHole, + + newImplication, + + -------------------------------- + -- Instantiation + newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, newMetaTyVarBndrsX, + newMetaTyVarTyVarX, + newTyVarTyVar, cloneTyVarTyVar, + newConcreteTyVarX, + newPatTyVar, newSkolemTyVar, newWildCardX, + + -------------------------------- + -- Expected types + ExpType(..), ExpSigmaType, ExpRhoType, + mkCheckExpType, newInferExpType, newInferExpTypeFRR, + runInfer, runInferRho, runInferSigma, runInferKind, runInferRhoFRR, runInferSigmaFRR, + readExpType, readExpType_maybe, readScaledExpType, + expTypeToType, scaledExpTypeToType, + checkingExpType_maybe, checkingExpType, + inferResultToType, ensureMonoType, promoteTcType, + + -------------------------------- + -- Multiplicity usage environment + tcCheckUsage, + + --------------------------------- + -- Promotion, defaulting, skolemisation + defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet, + quantifyTyVars, doNotQuantifyTyVars, + zonkAndSkolemise, skolemiseQuantifiedTyVar, + + candidateQTyVarsOfType, candidateQTyVarsOfKind, + candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, + candidateQTyVarsWithBinders, weedOutCandidates, + CandidatesQTvs(..), delCandidates, + candidateKindVars, partitionCandidates, + + ------------------------------ + -- Representation polymorphism + checkTypeHasFixedRuntimeRep, + + -- * Other HsSyn functions + mkHsDictLet, mkHsApp, + mkHsAppTy, mkHsCaseAlt, + tcShortCutLit, shortCutLit, hsOverLitName, + conLikeResTy + ) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Platform + +import GHC.Driver.DynFlags +import qualified GHC.LanguageExtensions as LangExt + +import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyInvisibleType, tcSubMult ) +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.CtLoc( CtLoc ) +import GHC.Tc.Utils.Monad -- TcType, amongst others +import GHC.Tc.Utils.TcType +import GHC.Tc.Errors.Types +import GHC.Tc.Zonk.TcType + +import GHC.Builtin.Names + +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Tidy +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Class +import GHC.Core.Predicate +import GHC.Core.UsageEnv + +import GHC.Types.Var +import GHC.Types.Id as Id +import GHC.Types.Name +import GHC.Types.SourceText +import GHC.Types.Var.Set + +import GHC.Builtin.Types +import GHC.Types.Var.Env +import GHC.Types.Unique.Set +import GHC.Types.Basic ( TypeOrKind(..) + , NonStandardDefaultingStrategy(..) + , DefaultingStrategy(..), defaultNonStandardTyVars ) + +import GHC.Data.FastString +import GHC.Data.Bag + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) + +import Control.Monad +import Data.IORef +import GHC.Data.Maybe +import qualified Data.Semigroup as Semi +import GHC.Types.Name.Reader + +{- +************************************************************************ +* * + Kind variables +* * +************************************************************************ +-} + +newMetaKindVar :: TcM TcKind +newMetaKindVar + = do { details <- newMetaDetails TauTv + ; name <- newMetaTyVarName (fsLit "k") + -- All MetaKindVars are called "k" + -- They may be jiggled by tidying + ; let kv = mkTcTyVar name liftedTypeKind details + ; traceTc "newMetaKindVar" (ppr kv) + ; return (mkTyVarTy kv) } + +newMetaKindVars :: Int -> TcM [TcKind] +newMetaKindVars n = replicateM n newMetaKindVar + +{- +************************************************************************ +* * + Evidence variables; range over constraints we can abstract over +* * +************************************************************************ +-} + +newEvVars :: TcThetaType -> TcM [EvVar] +newEvVars theta = mapM newEvVar theta + +-------------- + +newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar +-- Creates new *rigid* variables for predicates +newEvVar ty = do { name <- newSysName (predTypeOccName ty) + ; return (mkLocalIdOrCoVar name ManyTy ty) } + +-- | Create a new Wanted constraint with the given 'CtLoc'. +newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence +newWantedWithLoc loc pty + = do dst <- case classifyPredType pty of + EqPred {} -> HoleDest <$> newCoercionHole pty + _ -> EvVarDest <$> newEvVar pty + return $ CtWanted $ + WantedCt { ctev_dest = dst + , ctev_pred = pty + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + +-- | Create a new Wanted constraint with the given 'CtOrigin', and +-- location information taken from the 'TcM' environment. +newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence +-- Deals with both equality and non-equality predicates +newWanted orig t_or_k pty + = do loc <- getCtLocM orig t_or_k + newWantedWithLoc loc pty + +-- | Create new Wanted constraints with the given 'CtOrigin', +-- and location information taken from the 'TcM' environment. +newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] +newWanteds orig = mapM (newWanted orig Nothing) + +---------------------------------------------- +-- Cloning constraints +---------------------------------------------- + +cloneWantedCtEv :: CtEvidence -> TcM CtEvidence +cloneWantedCtEv (CtWanted ctev@(WantedCt { ctev_pred = pty, ctev_dest = HoleDest _ })) + | isEqPred pty + = do { co_hole <- newCoercionHole pty + ; return $ CtWanted (ctev { ctev_dest = HoleDest co_hole }) } + | otherwise + = pprPanic "cloneWantedCtEv" (ppr pty) +cloneWantedCtEv ctev = return ctev + +cloneWanted :: Ct -> TcM Ct +cloneWanted ct = mkNonCanonical <$> cloneWantedCtEv (ctEvidence ct) + +cloneWC :: WantedConstraints -> TcM WantedConstraints +-- Clone all the evidence bindings in +-- a) the ic_bind field of any implications +-- b) the CoercionHoles of any wanted constraints +-- so that solving the WantedConstraints will not have any visible side +-- effect, /except/ from causing unifications +cloneWC wc@(WC { wc_simple = simples, wc_impl = implics }) + = do { simples' <- mapBagM cloneWanted simples + ; implics' <- mapBagM cloneImplication implics + ; return (wc { wc_simple = simples', wc_impl = implics' }) } + +cloneImplication :: Implication -> TcM Implication +cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted }) + = do { binds' <- cloneEvBindsVar binds + ; inner_wanted' <- cloneWC inner_wanted + ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) } + +---------------------------------------------- +-- Emitting constraints +---------------------------------------------- + +-- | Emits a new Wanted. Deals with both equalities and non-equalities. +emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm +emitWanted origin pty + = do { ev <- newWanted origin Nothing pty + ; emitSimple $ mkNonCanonical ev + ; return $ ctEvTerm ev } + +emitWantedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () +-- Emit some new wanted nominal equalities +emitWantedEqs origin pairs + | null pairs + = return () + | otherwise + = mapM_ (uncurry (emitWantedEq origin TypeLevel Nominal)) pairs + +-- | Emits a new equality constraint +emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion +emitWantedEq origin t_or_k role ty1 ty2 + = do { hole <- newCoercionHole pty + ; loc <- getCtLocM origin (Just t_or_k) + ; emitSimple $ mkNonCanonical $ CtWanted $ + WantedCt { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + ; return (HoleCo hole) } + where + pty = mkEqPredRole role ty1 ty2 + +-- | Creates a new EvVar and immediately emits it as a Wanted. +-- No equality predicates here. +emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar +emitWantedEvVar origin ty + = do { new_cv <- newEvVar ty + ; loc <- getCtLocM origin Nothing + ; let ctev = WantedCt { ctev_pred = ty + , ctev_dest = EvVarDest new_cv + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + ; emitSimple $ mkNonCanonical $ CtWanted ctev + ; return new_cv } + +-- | Emit a new wanted expression hole +emitNewExprHole :: RdrName -- of the hole + -> Type -> TcM HoleExprRef +emitNewExprHole occ ty + = do { u <- newUnique + ; ref <- newTcRef (pprPanic "unfilled unbound-variable evidence" (ppr u)) + ; let her = HER ref ty u + + ; loc <- getCtLocM (ExprHoleOrigin (Just occ)) (Just TypeLevel) + + ; let hole = Hole { hole_sort = ExprHole her + , hole_occ = occ + , hole_ty = ty + , hole_loc = loc } + ; emitHole hole + ; return her } + +newDict :: Class -> [TcType] -> TcM DictId +newDict cls tys + = do { name <- newSysName (mkDictOcc (getOccName cls)) + ; return (mkLocalId name ManyTy (mkClassPred cls tys)) } + +predTypeOccName :: PredType -> OccName +predTypeOccName ty = case classifyPredType ty of + ClassPred cls _ -> mkDictOcc (getOccName cls) + EqPred {} -> mkVarOccFS (fsLit "co") + IrredPred {} -> mkVarOccFS (fsLit "irred") + ForAllPred {} -> mkVarOccFS (fsLit "df") + +-- | Create a new 'Implication' with as many sensible defaults for its fields +-- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do +-- /not/ have sensible defaults, so they are initialized with lazy thunks that +-- will 'panic' if forced, so one should take care to initialize these fields +-- after creation. +-- +-- This is monadic to look up the 'TcLclEnv', which is used to initialize +-- 'ic_env', and to set the -Winaccessible-code flag. See +-- Note [Avoid -Winaccessible-code when deriving] in "GHC.Tc.TyCl.Instance". +newImplication :: TcM Implication +newImplication + = do env <- getLclEnv + warn_inaccessible <- woptM Opt_WarnInaccessibleCode + let in_gen_code = lclEnvInGeneratedCode env + return $ + (implicationPrototype (mkCtLocEnv env)) + { ic_warn_inaccessible = warn_inaccessible && not in_gen_code } + +{- +************************************************************************ +* * + Coercion holes +* * +************************************************************************ +-} + +newCoercionHole :: TcPredType -> TcM CoercionHole +-- For the Bool, see (EIK2) in Note [Equalities with heterogeneous kinds] +newCoercionHole pred_ty + = do { co_var <- newEvVar pred_ty + ; traceTc "New coercion hole:" (ppr co_var <+> dcolon <+> ppr pred_ty) + ; ref <- newMutVar Nothing + ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } } + +-- | Put a value in a coercion hole +fillCoercionHole :: CoercionHole -> Coercion -> TcM () +fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co = do + when debugIsOn $ do + cts <- readTcRef ref + whenIsJust cts $ \old_co -> + pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) + traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co) + writeTcRef ref (Just co) + + +{- ********************************************************************** +* + ExpType functions +* +********************************************************************** -} + +{- Note [ExpType] +~~~~~~~~~~~~~~~~~ +An ExpType is used as the "expected type" when type-checking an expression. +An ExpType can hold a "hole" that can be filled in by the type-checker. +This allows us to have one tcExpr that works in both checking mode and +synthesis mode (that is, bidirectional type-checking). Previously, this +was achieved by using ordinary unification variables, but we don't need +or want that generality. (For example, #11397 was caused by doing the +wrong thing with unification variables.) Instead, we observe that these +holes should + +1. never be nested +2. never appear as the type of a variable +3. be used linearly (never be duplicated) + +By defining ExpType, separately from Type, we can achieve goals 1 and 2 +statically. + +See also [wiki:typechecking] + +Note [TcLevel of ExpType] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data G a where + MkG :: G Bool + + foo MkG = True + +This is a classic untouchable-variable / ambiguous GADT return type +scenario. But, with ExpTypes, we'll be inferring the type of the RHS. +We thus must track a TcLevel in an Inferring ExpType. If we try to +fill the ExpType and find that the TcLevels don't work out, we fill +the ExpType with a tau-tv at the low TcLevel, hopefully to be worked +out later by some means -- see fillInferResult, and Note [fillInferResult] + +This behaviour triggered in test gadt/gadt-escape1. + +Note [FixedRuntimeRep context in ExpType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes, we want to be sure that we fill an ExpType with a type +that has a syntactically fixed RuntimeRep (in the sense of +Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). + +Example: + + pattern S a = (a :: (T :: TYPE R)) + +We have to infer a type for `a` which has a syntactically fixed RuntimeRep. +When it comes time to filling in the inferred type, we do the appropriate +representation-polymorphism check, much like we do a level check +as explained in Note [TcLevel of ExpType]. + +See test case T21325. +-} + +-- actual data definition is in GHC.Tc.Utils.TcType + +newInferExpType :: InferInstFlag -> TcM ExpType +newInferExpType iif = new_inferExpType iif IFRR_Any + +newInferExpTypeFRR :: InferInstFlag -> FixedRuntimeRepContext -> TcM ExpTypeFRR +newInferExpTypeFRR iif frr_orig + = do { th_lvl <- getThLevel + ; let mb_frr = case th_lvl of + TypedBrack {} -> IFRR_Any + _ -> IFRR_Check frr_orig + -- mb_frr: see [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + + ; new_inferExpType iif mb_frr } + +new_inferExpType :: InferInstFlag -> InferFRRFlag -> TcM ExpType +new_inferExpType iif ifrr + = do { u <- newUnique + ; tclvl <- getTcLevel + ; traceTc "newInferExpType" (ppr u <+> ppr tclvl) + ; ref <- newMutVar Nothing + ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl + , ir_inst = iif, ir_frr = ifrr + , ir_ref = ref })) } + +-- | Extract a type out of an ExpType, if one exists. But one should always +-- exist. Unless you're quite sure you know what you're doing. +readExpType_maybe :: MonadIO m => ExpType -> m (Maybe TcType) +readExpType_maybe (Check ty) = return (Just ty) +readExpType_maybe (Infer (IR { ir_ref = ref})) = liftIO $ readIORef ref +{-# INLINEABLE readExpType_maybe #-} + +-- | Same as readExpType, but for Scaled ExpTypes +readScaledExpType :: MonadIO m => Scaled ExpType -> m (Scaled Type) +readScaledExpType (Scaled m exp_ty) + = do { ty <- readExpType exp_ty + ; return (Scaled m ty) } +{-# INLINEABLE readScaledExpType #-} + +-- | Extract a type out of an ExpType. Otherwise, panics. +readExpType :: MonadIO m => ExpType -> m TcType +readExpType exp_ty + = do { mb_ty <- readExpType_maybe exp_ty + ; case mb_ty of + Just ty -> return ty + Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) } +{-# INLINEABLE readExpType #-} + +scaledExpTypeToType :: Scaled ExpType -> TcM (Scaled TcType) +scaledExpTypeToType (Scaled m exp_ty) + = do { ty <- expTypeToType exp_ty + ; return (Scaled m ty) } + +-- | Extracts the expected type if there is one, or generates a new +-- TauTv if there isn't. +expTypeToType :: ExpType -> TcM TcType +expTypeToType (Check ty) = return ty +expTypeToType (Infer inf_res) = inferResultToType inf_res + +inferResultToType :: InferResult -> TcM Type +inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl + , ir_ref = ref + , ir_frr = mb_frr }) + = do { mb_inferred_ty <- readTcRef ref + ; tau <- case mb_inferred_ty of + Just ty -> do { ensureMonoType ty + -- See Note [inferResultToType] + ; return ty } + Nothing -> do { tau <- new_meta + ; writeMutVar ref (Just tau) + ; return tau } + ; traceTc "Forcing ExpType to be monomorphic:" + (ppr u <+> text ":=" <+> ppr tau) + ; return tau } + where + -- See Note [TcLevel of ExpType] + new_meta = case mb_frr of + IFRR_Any -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy + ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) } + IFRR_Check frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy + ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) + ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr + ; return tau } + +{- Note [inferResultToType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +expTypeToType and inferResultType convert an InferResult to a monotype. +It must be a monotype because if the InferResult isn't already filled in, +we fill it in with a unification variable (hence monotype). So to preserve +order-independence we check for mono-type-ness even if it *is* filled in +already. + +See also Note [TcLevel of ExpType] above, and +Note [fillInferResult] in GHC.Tc.Utils.Unify. +-} + +-- | Infer a type using a fresh ExpType +-- See also Note [ExpType] in "GHC.Tc.Utils.TcMType" +-- +-- Use 'runInferFRR' if you require the type to have a fixed +-- runtime representation. +runInferSigma :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +runInferSigma = runInfer IIF_Sigma IFRR_Any + +runInferRho :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType) +runInferRho = runInfer IIF_DeepRho IFRR_Any + +runInferKind :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +-- Used for kind-checking types, where we never want deep instantiation, +-- nor FRR checks +runInferKind = runInfer IIF_Sigma IFRR_Any + +-- | Like 'runInferRho', except it ensures that the resulting type +-- has a syntactically fixed RuntimeRep as per Note [Fixed RuntimeRep] in +-- GHC.Tc.Utils.Concrete. +runInferRhoFRR :: FixedRuntimeRepContext -> (ExpRhoTypeFRR -> TcM a) -> TcM (a, TcRhoTypeFRR) +runInferRhoFRR frr_orig = runInfer IIF_DeepRho (IFRR_Check frr_orig) + +runInferSigmaFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR) +runInferSigmaFRR frr_orig = runInfer IIF_Sigma (IFRR_Check frr_orig) + +runInfer :: InferInstFlag -> InferFRRFlag -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +runInfer iif mb_frr tc_check + = do { res_ty <- new_inferExpType iif mb_frr + ; result <- tc_check res_ty + ; res_ty <- readExpType res_ty + ; return (result, res_ty) } + +{- ********************************************************************* +* * + Promoting types +* * +********************************************************************* -} + +ensureMonoType :: TcType -> TcM () +-- Assuming that the argument type is of kind (TYPE r), +-- ensure that it is a /monotype/ +-- If it is not a monotype we can see right away (since unification +-- variables and type-function applications stand for monotypes), but +-- we emit a Wanted equality just to delay the error message until later +ensureMonoType res_ty + | isTauTy res_ty -- isTauTy doesn't need zonking or anything + = return () + | otherwise + = do { mono_ty <- newOpenFlexiTyVarTy + ; _co <- unifyInvisibleType res_ty mono_ty + ; return () } + +promoteTcType :: TcLevel -> TcType -> TcM (TcCoercionN, TcType) +-- See Note [Promoting a type] +-- See also Note [fillInferResult] +-- promoteTcType level ty = (co, ty') +-- * Returns ty' whose max level is just 'level' +-- and whose kind is ~# to the kind of 'ty' +-- and whose kind has form TYPE rr +-- * and co :: ty ~ ty' +-- * and emits constraints to justify the coercion +-- +-- NB: we expect that 'ty' has already kind (TYPE rr) for +-- some rr::RuntimeRep. It is, after all, the type of a term. +promoteTcType dest_lvl ty + = do { cur_lvl <- getTcLevel + ; if (cur_lvl `sameDepthAs` dest_lvl) + then return (mkNomReflCo ty, ty) + else promote_it } + where + promote_it :: TcM (TcCoercion, TcType) + promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty + -- where alpha and rr are fresh and from level dest_lvl + = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy + ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (mkTYPEapp rr) + ; co <- unifyInvisibleType ty prom_ty + ; return (co, prom_ty) } + +{- Note [Promoting a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12427) + + data T where + MkT :: (Int -> Int) -> a -> T + + h y = case y of MkT v w -> v + +We'll infer the RHS type with an expected type ExpType of + (IR { ir_lvl = l, ir_ref = ref, ... ) +where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern +match will increase the level, so we'll end up in tcSubType, trying to +unify the type of v, + v :: Int -> Int +with the expected type. But this attempt takes place at level (l+1), +rightly so, since v's type could have mentioned existential variables, +(like w's does) and we want to catch that. + +So we + - create a new meta-var alpha[l+1] + - fill in the InferRes ref cell 'ref' with alpha + - emit an equality constraint, thus + [W] alpha[l+1] ~ (Int -> Int) + +That constraint will float outwards, as it should, unless v's +type mentions a skolem-captured variable. + +This approach fails if v has a higher rank type; see +Note [Promotion and higher rank types] + + +Note [Promotion and higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If v had a higher-rank type, say v :: (forall a. a->a) -> Int, +then we'd emit an equality + [W] alpha[l+1] ~ ((forall a. a->a) -> Int) +which will sadly fail because we can't unify a unification variable +with a polytype. But there is nothing really wrong with the program +here. + +We could just about solve this by "promote the type" of v, to expose +its polymorphic "shape" while still leaving constraints that will +prevent existential escape. But we must be careful! Exposing +the "shape" of the type is precisely what we must NOT do under +a GADT pattern match! So in this case we might promote the type +to + (forall a. a->a) -> alpha[l+1] +and emit the constraint + [W] alpha[l+1] ~ Int +Now the promoted type can fill the ref cell, while the emitted +equality can float or not, according to the usual rules. + +But that's not quite right! We are exposing the arrow! We could +deal with that too: + (forall a. mu[l+1] a a) -> alpha[l+1] +with constraints + [W] alpha[l+1] ~ Int + [W] mu[l+1] ~ (->) +Here we abstract over the '->' inside the forall, in case that +is subject to an equality constraint from a GADT match. + +Note that we kept the outer (->) because that's part of +the polymorphic "shape". And because of impredicativity, +GADT matches can't give equalities that affect polymorphic +shape. + +This reasoning just seems too complicated, so I decided not +to do it. These higher-rank notes are just here to record +the thinking. +-} + + +{- ********************************************************************* +* * + MetaTvs (meta type variables; mutable) +* * +********************************************************************* -} + +{- Note [TyVarTv] +~~~~~~~~~~~~~~~~~ +A TyVarTv can unify with type *variables* only, including other TyVarTvs and +skolems. They are used in two places: + +1. In kind signatures, see GHC.Tc.TyCl + Note [Inferring kinds for type declarations] + and Note [Using TyVarTvs for kind-checking GADTs] + +2. In partial type signatures. See GHC.Tc.Types + Note [Quantified variables in partial type signatures] + +Sometimes, they can unify with type variables that the user would +rather keep distinct; see #11203 for an example. So, any client of +this function needs to either allow the TyVarTvs to unify with each +other or check that they don't. In the case of (1) the check is done +in GHC.Tc.TyCl.swizzleTcTyConBndrs. In case of (2) it's done by +findDupTyVarTvs in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. + +Historical note: Before #15050 this (under the name SigTv) was also +used for ScopedTypeVariables in patterns, to make sure these type +variables only refer to other type variables, but this restriction was +dropped, and ScopedTypeVariables can now refer to full types (GHC +Proposal 29). +-} + +newMetaTyVarName :: FastString -> TcM Name +-- Makes a /System/ Name, which is eagerly eliminated by +-- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and +-- GHC.Tc.Solver.Equality.canEqTyVarTyVar (nicer_to_update_tv2) +newMetaTyVarName str + = newSysName (mkTyVarOccFS str) + +cloneMetaTyVarName :: Name -> TcM Name +cloneMetaTyVarName name + = newSysName (nameOccName name) + -- See Note [Name of an instantiated type variable] + +{- Note [Name of an instantiated type variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment we give a unification variable a System Name, which +influences the way it is tidied; see TypeRep.tidyTyVarBndr. +-} + +metaInfoToTyVarName :: MetaInfo -> FastString +metaInfoToTyVarName meta_info = + case meta_info of + TauTv -> fsLit "t" + TyVarTv -> fsLit "a" + RuntimeUnkTv -> fsLit "r" + CycleBreakerTv -> fsLit "b" + ConcreteTv {} -> fsLit "c" + +newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar +newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi + +newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar +-- Make a new meta tyvar out of thin air +newNamedAnonMetaTyVar tyvar_name meta_info kind + + = do { name <- newMetaTyVarName tyvar_name + ; details <- newMetaDetails meta_info + ; let tyvar = mkTcTyVar name kind details + ; traceTc "newAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr kind) + ; return tyvar } + +-- makes a new skolem tv +newSkolemTyVar :: SkolemInfo -> Name -> Kind -> TcM TcTyVar +newSkolemTyVar skol_info name kind + = do { lvl <- getTcLevel + ; return (mkTcTyVar name kind (SkolemTv skol_info lvl False)) } + +newTyVarTyVar :: Name -> Kind -> TcM TcTyVar +-- See Note [TyVarTv] +-- Does not clone a fresh unique +newTyVarTyVar name kind + = do { details <- newMetaDetails TyVarTv + ; let tyvar = mkTcTyVar name kind details + ; traceTc "newTyVarTyVar" (ppr tyvar) + ; return tyvar } + +cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar +-- See Note [TyVarTv] +-- Clones a fresh unique +cloneTyVarTyVar name kind + = do { details <- newMetaDetails TyVarTv + ; uniq <- newUnique + ; let name' = name `setNameUnique` uniq + tyvar = mkTcTyVar name' kind details + -- Don't use cloneMetaTyVar, which makes a SystemName + -- We want to keep the original more user-friendly Name + -- In practical terms that means that in error messages, + -- when the Name is tidied we get 'a' rather than 'a0' + ; traceTc "cloneTyVarTyVar" (ppr tyvar) + ; return tyvar } + +-- | Create a new metavariable, of the given kind, which can only be unified +-- with a concrete type. +-- +-- Invariant: the kind must be concrete, as per Note [ConcreteTv]. +-- This is checked with an assertion. +newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin + -> FastString -> TcKind -> TcM TcTyVar +newConcreteTyVar reason fs kind + = assertPpr (isConcreteType kind) assert_msg $ + do { th_lvl <- getThLevel + ; if + -- See [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + | TypedBrack _ <- th_lvl + -> newNamedAnonMetaTyVar fs TauTv kind + + | otherwise + -> newNamedAnonMetaTyVar fs (ConcreteTv reason) kind } + where + assert_msg = text "newConcreteTyVar: non-concrete kind" <+> ppr kind + +newPatTyVar :: Name -> Kind -> TcM TcTyVar +newPatTyVar name kind + = do { details <- newMetaDetails TauTv + ; uniq <- newUnique + ; let name' = name `setNameUnique` uniq + tyvar = mkTcTyVar name' kind details + -- Don't use cloneMetaTyVar; + -- same reasoning as in newTyVarTyVar + ; traceTc "newPatTyVar" (ppr tyvar) + ; return tyvar } + +cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar +-- Make a fresh MetaTyVar, basing the name +-- on that of the supplied TyVar +cloneAnonMetaTyVar info tv kind + = do { details <- newMetaDetails info + ; name <- cloneMetaTyVarName (tyVarName tv) + ; let tyvar = mkTcTyVar name kind details + ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) + ; return tyvar } + +-- | Make a new cycle-breaker type variable. See Note [Type equality cycles] +-- in GHC.Tc.Solver.Equality. +newCycleBreakerTyVar :: TcKind -> TcM TcTyVar +newCycleBreakerTyVar kind + = do { details <- newMetaDetails CycleBreakerTv + ; name <- newMetaTyVarName (fsLit "cbv") + ; return (mkTcTyVar name kind details) } + +newMetaDetails :: MetaInfo -> TcM TcTyVarDetails +newMetaDetails info + = do { ref <- newMutVar Flexi + ; tclvl <- getTcLevel + ; return (MetaTv { mtv_info = info + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + +newTauTvDetailsAtLevel :: TcLevel -> TcM TcTyVarDetails +newTauTvDetailsAtLevel tclvl + = do { ref <- newMutVar Flexi + ; return (MetaTv { mtv_info = TauTv + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + +newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails +newConcreteTvDetailsAtLevel conc_orig tclvl + = do { ref <- newMutVar Flexi + ; return (MetaTv { mtv_info = ConcreteTv conc_orig + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + +cloneMetaTyVar :: TcTyVar -> TcM TcTyVar +cloneMetaTyVar tv + = assert (isTcTyVar tv) $ + do { ref <- newMutVar Flexi + ; name' <- cloneMetaTyVarName (tyVarName tv) + ; let details' = case tcTyVarDetails tv of + details@(MetaTv {}) -> details { mtv_ref = ref } + _ -> pprPanic "cloneMetaTyVar" (ppr tv) + tyvar = mkTcTyVar name' (tyVarKind tv) details' + ; traceTc "cloneMetaTyVar" (ppr tyvar) + ; return tyvar } + +cloneMetaTyVarWithInfo :: MetaInfo -> TcLevel -> TcTyVar -> TcM TcTyVar +cloneMetaTyVarWithInfo info tc_lvl tv + = assert (isTcTyVar tv) $ + do { ref <- newMutVar Flexi + ; name' <- cloneMetaTyVarName (tyVarName tv) + ; let details = MetaTv { mtv_info = info + , mtv_ref = ref + , mtv_tclvl = tc_lvl } + tyvar = mkTcTyVar name' (tyVarKind tv) details + ; traceTc "cloneMetaTyVarWithInfo" (ppr tyvar) + ; return tyvar } + +-- Works for both type and kind variables +readMetaTyVar :: MonadIO m => TyVar -> m MetaDetails +readMetaTyVar tyvar = assertPpr (isMetaTyVar tyvar) (ppr tyvar) $ + liftIO $ readIORef (metaTyVarRef tyvar) +{-# SPECIALISE readMetaTyVar :: TyVar -> TcM MetaDetails #-} +{-# SPECIALISE readMetaTyVar :: TyVar -> ZonkM MetaDetails #-} + +isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) +isFilledMetaTyVar_maybe tv +-- TODO: This should be an assertion that tv is definitely a TcTyVar but it fails +-- at the moment (Jan 22) + | isTcTyVar tv + , MetaTv { mtv_ref = ref } <- tcTyVarDetails tv + = do { cts <- readTcRef ref + ; case cts of + Indirect ty -> return (Just ty) + Flexi -> return Nothing } + | otherwise + = return Nothing + +isFilledMetaTyVar :: TyVar -> TcM Bool +-- True of a filled-in (Indirect) meta type variable +isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv + +isUnfilledMetaTyVar :: TyVar -> TcM Bool +-- True of a un-filled-in (Flexi) meta type variable +-- NB: Not the opposite of isFilledMetaTyVar +isUnfilledMetaTyVar tv + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv + = do { details <- readMutVar ref + ; return (isFlexi details) } + | otherwise = return False + +{- +************************************************************************ +* * + MetaTvs: TauTvs +* * +************************************************************************ + +Note [Never need to instantiate coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With coercion variables sloshing around in types, it might seem that we +sometimes need to instantiate coercion variables. This would be problematic, +because coercion variables inhabit unboxed equality (~#), and the constraint +solver thinks in terms only of boxed equality (~). The solution is that +we never need to instantiate coercion variables in the first place. + +The tyvars that we need to instantiate come from the types of functions, +data constructors, and patterns. These will never be quantified over +coercion variables, except for the special case of the promoted Eq#. But, +that can't ever appear in user code, so we're safe! +-} + + +newMultiplicityVar :: TcM TcType +newMultiplicityVar = newFlexiTyVarTy multiplicityTy + +newFlexiTyVar :: Kind -> TcM TcTyVar +newFlexiTyVar kind = newAnonMetaTyVar TauTv kind + +-- | Create a new flexi ty var with a specific name +newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar +newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind + +newFlexiTyVarTy :: Kind -> TcM TcType +newFlexiTyVarTy kind = do + tc_tyvar <- newFlexiTyVar kind + return (mkTyVarTy tc_tyvar) + +newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] +newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind) + +newOpenTypeKind :: TcM TcKind +newOpenTypeKind + = do { rr <- newFlexiTyVarTy runtimeRepTy + ; return (mkTYPEapp rr) } + +-- | Create a tyvar that can be a lifted or unlifted type. +-- Returns @alpha :: TYPE kappa@, where both @alpha@ and @kappa@ are fresh. +-- +-- Note: you should use 'newOpenFlexiFRRTyVarTy' if you also need to ensure +-- that the representation is concrete, in the sense of Note [Concrete types] +-- in GHC.Tc.Utils.Concrete. +newOpenFlexiTyVarTy :: TcM TcType +newOpenFlexiTyVarTy + = do { tv <- newOpenFlexiTyVar + ; return (mkTyVarTy tv) } + +newOpenFlexiTyVar :: TcM TcTyVar +newOpenFlexiTyVar + = do { kind <- newOpenTypeKind + ; newFlexiTyVar kind } + +-- | Like 'newOpenFlexiTyVar', but ensures the type variable has a +-- syntactically fixed RuntimeRep in the sense of Note [Fixed RuntimeRep] +-- in GHC.Tc.Utils.Concrete. +newOpenFlexiFRRTyVar :: FixedRuntimeRepContext -> TcM TcTyVar +newOpenFlexiFRRTyVar frr_ctxt + = do { th_lvl <- getThLevel + ; case th_lvl of + { TypedBrack _ -- See [Wrinkle: Typed Template Haskell] + -> newOpenFlexiTyVar -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + ; _ -> + mdo { let conc_orig = ConcreteFRR $ + FixedRuntimeRepOrigin + { frr_context = frr_ctxt + , frr_type = mkTyVarTy tv } + ; rr <- mkTyVarTy <$> newConcreteTyVar conc_orig (fsLit "cx") runtimeRepTy + ; tv <- newFlexiTyVar (mkTYPEapp rr) + ; return tv } } } + +-- | See 'newOpenFlexiFRRTyVar'. +newOpenFlexiFRRTyVarTy :: FixedRuntimeRepContext -> TcM TcType +newOpenFlexiFRRTyVarTy frr_ctxt + = do { tv <- newOpenFlexiFRRTyVar frr_ctxt + ; return (mkTyVarTy tv) } + +newOpenBoxedTypeKind :: TcM TcKind +newOpenBoxedTypeKind + = do { lev <- newFlexiTyVarTy (mkTyConTy levityTyCon) + ; let rr = mkTyConApp boxedRepDataConTyCon [lev] + ; return (mkTYPEapp rr) } + +newMetaTyVars :: [TyVar] -> TcM (Subst, [TcTyVar]) +-- Instantiate with META type variables +-- Note that this works for a sequence of kind, type, and coercion variables +-- variables. Eg [ (k:*), (a:k->k) ] +-- Gives [ (k7:*), (a8:k7->k7) ] +newMetaTyVars = newMetaTyVarsX emptySubst + -- emptySubst has an empty in-scope set, but that's fine here + -- Since the tyvars are freshly made, they cannot possibly be + -- captured by any existing for-alls. + +newMetaTyVarsX :: Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) +-- Just like newMetaTyVars, but start with an existing substitution. +newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst + +newMetaTyVarBndrsX :: Subst -> [VarBndr TyVar vis] -> TcM (Subst, [VarBndr TcTyVar vis]) +newMetaTyVarBndrsX subst bndrs = do + (subst, bndrs') <- newMetaTyVarsX subst (binderVars bndrs) + pure (subst, zipWith mkForAllTyBinder flags bndrs') + where + flags = binderFlags bndrs + +newMetaTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) +-- Make a new unification variable tyvar whose Name and Kind come from +-- an existing TyVar. We substitute kind variables in the kind. +newMetaTyVarX = new_meta_tv_x TauTv + +-- | Like 'newMetaTyVarX', but for concrete type variables. +newConcreteTyVarX :: ConcreteTvOrigin -> Subst -> TyVar -> TcM (Subst, TcTyVar) +newConcreteTyVarX conc subst tv + = do { th_lvl <- getThLevel + ; if + -- See [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + | TypedBrack _ <- th_lvl + -> new_meta_tv_x TauTv subst tv + | otherwise + -> new_meta_tv_x (ConcreteTv conc) subst tv } + +newMetaTyVarTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) +-- Just like newMetaTyVarX, but make a TyVarTv +newMetaTyVarTyVarX subst tv = new_meta_tv_x TyVarTv subst tv + +newWildCardX :: Subst -> TyVar -> TcM (Subst, TcTyVar) +newWildCardX subst tv + = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv)) + ; return (extendTvSubstWithClone subst tv new_tv, new_tv) } + +new_meta_tv_x :: MetaInfo -> Subst -> TyVar -> TcM (Subst, TcTyVar) +new_meta_tv_x info subst tv + = do { new_tv <- cloneAnonMetaTyVar info tv substd_kind + ; let subst1 = extendTvSubstWithClone subst tv new_tv + ; return (subst1, new_tv) } + where + substd_kind = substTy subst (tyVarKind tv) + +newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType +newMetaTyVarTyAtLevel tc_lvl kind + = do { details <- newTauTvDetailsAtLevel tc_lvl + ; name <- newMetaTyVarName (fsLit "p") + ; return (mkTyVarTy (mkTcTyVar name kind details)) } + +newConcreteTyVarTyAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType +newConcreteTyVarTyAtLevel conc_orig tc_lvl kind + = do { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl + ; name <- newMetaTyVarName (fsLit "c") + ; return (mkTyVarTy (mkTcTyVar name kind details)) } + +{- Note [substConcreteTvOrigin] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To report helpful representation-polymorphism errors to the users, we want to +indicate which type caused the error, instead of simply printing kinds. +For example, in + + coerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b + + bad :: forall {s} (z :: TYPE s). z -> z + bad = coerce + +we want the error message to say (with additional debug info on type variables +for clarity of this explanation): + + The first argument of 'coerce' does not have a fixed runtime representation. + Its type is: + a0[tau] :: TYPE r0[conc] + Could not unify s[sk] with r0[conc] because the former is not a concrete + RuntimeRep. + +This is more informative than just saying that we could not unify s[sk] with +r0[conc]; it's helpful to users to phrase it in terms of types rather than kinds +whenever possible (especially as the kind variables often have inferred Specificity). + +To achieve this, we store the type on which the representation-polymorphism +check is being performed, in the field frr_type of FixedRuntimeRepOrigin. +This is all described in Note [Reporting representation-polymorphism errors] in +GHC.Tc.Types.Origin. + +However, we have to be careful in the example above, in which we are +instantiating a built-in representation-polymorphic 'Id'. As described in the +Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete, in such +cases we end up storing types appearing in the original type of the primop, +which means for the situation above with 'coerce' we end up with a ConcreteTvOrigin +which includes type variables bound in the original type of 'coerce': + + FixedRuntimeRepOrigin + { frr_type = a[tv] :: TYPE r[tv] + , frr_context = "first argument of coerce" } + +When we instantiate 'coerce' in the previous example, we obtain a substitution + + [ r[tv] |-> r0[conc], a |-> a0 :: TYPE r0[conc] ] + +which we need to apply to the 'frr_type' field in order for the type variables +in the error message to match up. +This is done by the call to 'substConcreteTvOrigin' in 'instantiateSigma'. + +Wrinkle [Extending the substitution] + + In certain cases, we need to extend the substitution we get from 'instantiateSigma'. + For example, suppose we have: + + bad2 :: forall {s} (z :: TYPE s). z -> z + bad2 = coerce @z + + Then 'instantiateSigma' will only instantiate the inferred type variable 'r' + of 'coerce', as it needs to leave 'a' un-instantiated so that the visible + type application '@z' makes sense. In this case, we end up with a substitution + + subst: [ r[tv] |-> r0[conc] ] + body_ty: forall (a :: TYPE r[tv]) (b :: TYPE r[tv]). ... + substTy subst body_ty: forall (a' :: TYPE r0[conc]) (b' :: TYPE r0[conc]). ... + + Now, we still want a substitution that maps (a :: TYPE r[tv]) to + (a' :: TYPE r0[conc]) in order to apply it to the 'frr_type', so that we don't + mention the un-substed (a :: TYPE r[tv]) in the error message. + To achieve this, we extend the substitution with the outermost quantified type + variables in the leftover (partially-instantiated) type using 'substTyVarBndrs' + to get the full substitution which we use in 'substConcreteTvOrigin'. +-} + +substConcreteTvOrigin :: Subst -> Type -> ConcreteTvOrigin -> ConcreteTvOrigin +substConcreteTvOrigin subst body_ty (ConcreteFRR frr_orig) + -- See Note [substConcreteTvOrigin], Wrinkle [Extending the substitution] + -- for the justification of this extra complication. + = let subst' = case splitForAllTyCoVars body_ty of + ([], _) -> subst + (bndrs, _) -> fst $ substTyVarBndrs subst bndrs + in ConcreteFRR $ substFRROrigin subst' frr_orig + +substFRROrigin :: Subst -> FixedRuntimeRepOrigin -> FixedRuntimeRepOrigin +substFRROrigin subst orig@(FixedRuntimeRepOrigin { frr_type = ty }) + = orig { frr_type = substTy subst ty } + +{- ********************************************************************* +* * + Finding variables to quantify over +* * +********************************************************************* -} + +{- Note [Dependent type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Haskell type inference we quantify over type variables; but we only +quantify over /kind/ variables when -XPolyKinds is on. Without -XPolyKinds +we default the kind variables to *. + +So, to support this defaulting, and only for that reason, when +collecting the free vars of a type (in candidateQTyVarsOfType and friends), +prior to quantifying, we must keep the type and kind variables separate. + +But what does that mean in a system where kind variables /are/ type +variables? It's a fairly arbitrary distinction based on how the +variables appear: + + - "Kind variables" appear in the kind of some other free variable + or in the kind of a locally quantified type variable + (forall (a :: kappa). ...) or in the kind of a coercion + (a |> (co :: kappa1 ~ kappa2)). + + These are the ones we default to * if -XPolyKinds is off + + - "Type variables" are all free vars that are not kind variables + +E.g. In the type T k (a::k) + 'k' is a kind variable, because it occurs in the kind of 'a', + even though it also appears at "top level" of the type + 'a' is a type variable, because it doesn't + +We gather these variables using a CandidatesQTvs record: + DV { dv_kvs: Variables free in the kind of a free type variable + or of a forall-bound type variable + , dv_tvs: Variables syntactically free in the type } + +So: dv_kvs are the kind variables of the type + (dv_tvs - dv_kvs) are the type variable of the type + +Note that + +* A variable can occur in both. + T k (x::k) The first occurrence of k makes it + show up in dv_tvs, the second in dv_kvs + +* We include any coercion variables in the "dependent", + "kind-variable" set because we never quantify over them. + +* The "kind variables" might depend on each other; e.g + (k1 :: k2), (k2 :: *) + The "type variables" do not depend on each other; if + one did, it'd be classified as a kind variable! + +Note [CandidatesQTvs determinism and order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Determinism: when we quantify over type variables we decide the + order in which they appear in the final type. Because the order of + type variables in the type can end up in the interface file and + affects some optimizations like worker-wrapper, we want this order to + be deterministic. + + To achieve that we use deterministic sets of variables that can be + converted to lists in a deterministic order. For more information + about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. + +* Order: as well as being deterministic, we use an + accumulating-parameter style for candidateQTyVarsOfType so that we + add variables one at a time, left to right. That means we tend to + produce the variables in left-to-right order. This is just to make + it bit more predictable for the programmer. + +Note [Naughty quantification candidates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14880, dependent/should_compile/T14880-2), suppose +we are trying to generalise this type: + + forall arg. ... (alpha[tau]:arg) ... + +We have a metavariable alpha whose kind mentions a skolem variable +bound inside the very type we are generalising. +This can arise while type-checking a user-written type signature +(see the test case for the full code). + +We cannot generalise over alpha! That would produce a type like + forall {a :: arg}. forall arg. ...blah... +The fact that alpha's kind mentions arg renders it completely +ineligible for generalisation. + +However, we are not going to learn any new constraints on alpha, +because its kind isn't even in scope in the outer context (but see Wrinkle). +So alpha is entirely unconstrained. + +What then should we do with alpha? During generalization, every +metavariable is either (A) promoted, (B) generalized, or (C) zapped +(according to Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType). + + * We can't generalise it. + * We can't promote it, because its kind prevents that + * We can't simply leave it be, because this type is about to + go into the typing environment (as the type of some let-bound + variable, say), and then chaos erupts when we try to instantiate. + +Previously, we zapped it to Any. This worked, but it had the unfortunate +effect of causing Any sometimes to appear in error messages. If this +kind of signature happens, the user probably has made a mistake -- no +one really wants Any in their types. So we now error. This must be +a hard error (failure in the monad) to avoid other messages from mentioning +Any. + +We do this eager erroring in candidateQTyVars, which always precedes +generalisation, because at that moment we have a clear picture of what +skolems are in scope within the type itself (e.g. that 'forall arg'). + +This change is inspired by and described in Section 7.2 of "Kind Inference +for Datatypes", POPL'20. + +NB: this is all rather similar to, but sadly not the same as + Note [Error on unconstrained meta-variables] + +Wrinkle: + +We must make absolutely sure that alpha indeed is not from an outer +context. (Otherwise, we might indeed learn more information about it.) +This can be done easily: we just check alpha's TcLevel. That level +must be strictly greater than the ambient TcLevel in order to treat it +as naughty. We say "strictly greater than" because the call to +candidateQTyVars is made outside the bumped TcLevel, as stated in the +comment to candidateQTyVarsOfType. The level check is done in go_tv in +collect_cand_qtvs. Skipping this check caused #16517. + +-} + +data CandidatesQTvs + -- See Note [Dependent type variables] + -- See Note [CandidatesQTvs determinism and order] + -- + -- Invariants: + -- * All variables are fully zonked, including their kinds + -- * All variables are at a level greater than the ambient level + -- See Note [Use level numbers for quantification] + -- + -- This *can* contain skolems. For example, in `data X k :: k -> Type` + -- we need to know that the k is a dependent variable. This is done + -- by collecting the candidates in the kind after skolemising. It also + -- comes up when generalizing a associated type instance, where instance + -- variables are skolems. (Recall that associated type instances are generalized + -- independently from their enclosing class instance, and the associated + -- type instance may be generalized by more, fewer, or different variables + -- than the class instance.) + -- + = DV { dv_kvs :: DTyVarSet -- "kind" metavariables (dependent) + , dv_tvs :: DTyVarSet -- "type" metavariables (non-dependent) + -- A variable may appear in both sets + -- E.g. T k (x::k) The first occurrence of k makes it + -- show up in dv_tvs, the second in dv_kvs + -- See Note [Dependent type variables] + + , dv_cvs :: CoVarSet + -- These are covars. Included only so that we don't repeatedly + -- look at covars' kinds in accumulator. Not used by quantifyTyVars. + } + +instance Semi.Semigroup CandidatesQTvs where + (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 }) + <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 }) + = DV { dv_kvs = kv1 `unionDVarSet` kv2 + , dv_tvs = tv1 `unionDVarSet` tv2 + , dv_cvs = cv1 `unionVarSet` cv2 } + +instance Monoid CandidatesQTvs where + mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet } + mappend = (Semi.<>) + +instance Outputable CandidatesQTvs where + ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) + = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs + , text "dv_tvs =" <+> ppr tvs + , text "dv_cvs =" <+> ppr cvs ]) + +weedOutCandidates :: (DTyVarSet -> DTyVarSet) -> CandidatesQTvs -> CandidatesQTvs +weedOutCandidates weed_out dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) + = dv { dv_kvs = weed_out kvs, dv_tvs = weed_out tvs } + +isEmptyCandidates :: CandidatesQTvs -> Bool +isEmptyCandidates (DV { dv_kvs = kvs, dv_tvs = tvs }) + = isEmptyDVarSet kvs && isEmptyDVarSet tvs + +-- | Extract out the kind vars (in order) and type vars (in order) from +-- a 'CandidatesQTvs'. The lists are guaranteed to be distinct. Keeping +-- the lists separate is important only in the -XNoPolyKinds case. +candidateVars :: CandidatesQTvs -> ([TcTyVar], [TcTyVar]) +candidateVars (DV { dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set }) + = (dep_kvs, nondep_tvs) + where + dep_kvs = scopedSort $ dVarSetElems dep_kv_set + -- scopedSort: put the kind variables into + -- well-scoped order. + -- E.g. [k, (a::k)] not the other way round + + nondep_tvs = dVarSetElems (nondep_tkv_set `minusDVarSet` dep_kv_set) + -- See Note [Dependent type variables] + -- The `minus` dep_tkvs removes any kind-level vars + -- e.g. T k (a::k) Since k appear in a kind it'll + -- be in dv_kvs, and is dependent. So remove it from + -- dv_tvs which will also contain k + -- NB kinds of tvs are already zonked + +candidateKindVars :: CandidatesQTvs -> TyVarSet +candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) + +delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs +delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars + = DV { dv_kvs = kvs `delDVarSetList` vars + , dv_tvs = tvs `delDVarSetList` vars + , dv_cvs = cvs `delVarSetList` vars } + +partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs) +-- The selected TyVars are returned as a non-deterministic TyVarSet +partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred + = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs }) + where + (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs + (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs + extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs + +candidateQTyVarsWithBinders :: [TyVar] -> Type -> TcM CandidatesQTvs +-- (candidateQTyVarsWithBinders tvs ty) returns the candidateQTyVars +-- of (forall tvs. ty), but do not treat 'tvs' as bound for the purpose +-- of Note [Naughty quantification candidates]. Why? +-- Because we are going to scoped-sort the quantified variables +-- in among the tvs +candidateQTyVarsWithBinders bound_tvs ty + = do { kvs <- candidateQTyVarsOfKinds (map tyVarKind bound_tvs) + ; cur_lvl <- getTcLevel + ; all_tvs <- collect_cand_qtvs ty False cur_lvl emptyVarSet kvs ty + ; return (all_tvs `delCandidates` bound_tvs) } + +-- | Gathers free variables to use as quantification candidates (in +-- 'quantifyTyVars'). This might output the same var +-- in both sets, if it's used in both a type and a kind. +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) +-- See Note [CandidatesQTvs determinism and order] +-- See Note [Dependent type variables] +candidateQTyVarsOfType :: TcType -- not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfType ty + = do { cur_lvl <- getTcLevel + ; collect_cand_qtvs ty False cur_lvl emptyVarSet mempty ty } + +-- | Like 'candidateQTyVarsOfType', but over a list of types +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) +candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs +candidateQTyVarsOfTypes tys + = do { cur_lvl <- getTcLevel + ; foldlM (\acc ty -> collect_cand_qtvs ty False cur_lvl emptyVarSet acc ty) + mempty tys } + +-- | Like 'candidateQTyVarsOfType', but consider every free variable +-- to be dependent. This is appropriate when generalizing a *kind*, +-- instead of a type. (That way, -XNoPolyKinds will default the variables +-- to Type.) +candidateQTyVarsOfKind :: TcKind -- Not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfKind ty + = do { cur_lvl <- getTcLevel + ; collect_cand_qtvs ty True cur_lvl emptyVarSet mempty ty } + +candidateQTyVarsOfKinds :: [TcKind] -- Not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfKinds tys + = do { cur_lvl <- getTcLevel + ; foldM (\acc ty -> collect_cand_qtvs ty True cur_lvl emptyVarSet acc ty) + mempty tys } + +collect_cand_qtvs + :: TcType -- Original type that we started recurring into; for errors + -> Bool -- True <=> consider every fv in Type to be dependent + -> TcLevel -- Current TcLevel; collect only tyvars whose level is greater + -> VarSet -- Bound variables (locals only) + -> CandidatesQTvs -- Accumulating parameter + -> Type -- Not necessarily zonked + -> TcM CandidatesQTvs + +-- Key points: +-- * Looks through meta-tyvars as it goes; +-- no need to zonk in advance +-- +-- * Needs to be monadic anyway, because it handles naughty +-- quantification; see Note [Naughty quantification candidates] +-- +-- * Returns fully-zonked CandidateQTvs, including their kinds +-- so that subsequent dependency analysis (to build a well +-- scoped telescope) works correctly + +collect_cand_qtvs orig_ty is_dep cur_lvl bound dvs ty + = go dvs ty + where + is_bound tv = tv `elemVarSet` bound + + ----------------- + go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs + -- Uses accumulating-parameter style + go dv (AppTy t1 t2) = foldlM go dv [t1, t2] + go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys + go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res] + go dv (LitTy {}) = return dv + go dv (CastTy ty co) = do { dv1 <- go dv ty + ; collect_cand_qtvs_co orig_ty cur_lvl bound dv1 co } + go dv (CoercionTy co) = collect_cand_qtvs_co orig_ty cur_lvl bound dv co + + go dv (TyVarTy tv) + | is_bound tv = return dv + | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv + ; case m_contents of + Just ind_ty -> go dv ind_ty + Nothing -> go_tv dv tv } + + go dv (ForAllTy (Bndr tv _) ty) + = do { dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv (tyVarKind tv) + ; collect_cand_qtvs orig_ty is_dep cur_lvl (bound `extendVarSet` tv) dv1 ty } + + -- This makes sure that we default e.g. the alpha in Proxy alpha (Any alpha). + -- Tested in polykinds/NestedProxies. + -- We just might get this wrong in AppTy, but I don't think that's possible + -- with -XNoPolyKinds. And fixing it would be non-performant, as we'd need + -- to look at kinds. + go_tc_args dv (tc_bndr:tc_bndrs) (ty:tys) + = do { dv1 <- collect_cand_qtvs orig_ty (is_dep || isNamedTyConBinder tc_bndr) + cur_lvl bound dv ty + ; go_tc_args dv1 tc_bndrs tys } + go_tc_args dv _bndrs tys -- _bndrs might be non-empty: undersaturation + -- tys might be non-empty: oversaturation + -- either way, the foldlM is correct + = foldlM go dv tys + + ----------------- + go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv + | cur_lvl `deeperThanOrSame` tcTyVarLevel tv + = return dv -- This variable is from an outer context; skip + -- See Note [Use level numbers for quantification] + + | case tcTyVarDetails tv of + SkolemTv _ lvl _ -> lvl `strictlyDeeperThan` pushTcLevel cur_lvl + _ -> False + = return dv -- Skip inner skolems + -- This only happens for erroneous program with bad telescopes + -- e.g. BadTelescope2: forall a k (b :: k). SameKind a b + -- We have (a::k), and at the outer we don't want to quantify + -- over the already-quantified skolem k. + -- (Apparently we /do/ want to quantify over skolems whose level sk_lvl is + -- sk_lvl > cur_lvl; you get lots of failures otherwise. A battle for another day.) + + | tv `elemDVarSet` kvs + = return dv -- We have met this tyvar already + + | not is_dep + , tv `elemDVarSet` tvs + = return dv -- We have met this tyvar already + + | otherwise + = do { tv_kind <- liftZonkM $ zonkTcType (tyVarKind tv) + -- This zonk is annoying, but it is necessary, both to + -- ensure that the collected candidates have zonked kinds + -- (#15795) and to make the naughty check + -- (which comes next) works correctly + + ; let tv_kind_vars = tyCoVarsOfType tv_kind + ; if | intersectsVarSet bound tv_kind_vars + -- the tyvar must not be from an outer context, but we have + -- already checked for this. + -- See Note [Naughty quantification candidates] + -> do { traceTc "Naughty quantifier" $ + vcat [ ppr tv <+> dcolon <+> ppr tv_kind + , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound) + , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet tv_kind_vars) ] + + ; let escapees = intersectVarSet bound tv_kind_vars + ; naughtyQuantification orig_ty tv escapees } + + | otherwise + -> do { let tv' = tv `setTyVarKind` tv_kind + dv' | is_dep = dv { dv_kvs = kvs `extendDVarSet` tv' } + | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' } + -- See Note [Order of accumulation] + + -- See Note [Recurring into kinds for candidateQTyVars] + ; collect_cand_qtvs orig_ty True cur_lvl bound dv' tv_kind } } + +collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors + -> TcLevel + -> VarSet -- bound variables + -> CandidatesQTvs -> Coercion + -> TcM CandidatesQTvs +collect_cand_qtvs_co orig_ty cur_lvl bound = go_co + where + go_co dv (Refl ty) = collect_cand_qtvs orig_ty True cur_lvl bound dv ty + go_co dv (GRefl _ ty mco) = do { dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv ty + ; go_mco dv1 mco } + go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos + go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (FunCo _ _ _ w co1 co2) = foldlM go_co dv [w, co1, co2] + go_co dv (AxiomCo _ cos) = foldlM go_co dv cos + go_co dv (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = do { dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv t1 + ; dv2 <- collect_cand_qtvs orig_ty True cur_lvl bound dv1 t2 + ; foldM go_co dv2 deps } + go_co dv (SymCo co) = go_co dv co + go_co dv (TransCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (SelCo _ co) = go_co dv co + go_co dv (LRCo _ co) = go_co dv co + go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (KindCo co) = go_co dv co + go_co dv (SubCo co) = go_co dv co + + go_co dv (HoleCo hole) + = do m_co <- liftZonkM (unpackCoercionHole_maybe hole) + case m_co of + Just co -> go_co dv co + Nothing -> go_cv dv (coHoleCoVar hole) + + go_co dv (CoVarCo cv) = go_cv dv cv + + go_co dv (ForAllCo { fco_tcv = tcv, fco_kind = kind_co, fco_body = co }) + = do { dv1 <- go_co dv kind_co + ; collect_cand_qtvs_co orig_ty cur_lvl (bound `extendVarSet` tcv) dv1 co } + + go_mco dv MRefl = return dv + go_mco dv (MCo co) = go_co dv co + + go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs + go_cv dv@(DV { dv_cvs = cvs }) cv + | is_bound cv = return dv + | cv `elemVarSet` cvs = return dv + + -- See Note [Recurring into kinds for candidateQTyVars] + | otherwise = collect_cand_qtvs orig_ty True cur_lvl bound + (dv { dv_cvs = cvs `extendVarSet` cv }) + (idType cv) + + is_bound tv = tv `elemVarSet` bound + +{- Note [Order of accumulation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might be tempted (like I was) to use unitDVarSet and mappend +rather than extendDVarSet. However, the union algorithm for +deterministic sets depends on (roughly) the size of the sets. The +elements from the smaller set end up to the right of the elements from +the larger one. When sets are equal, the left-hand argument to +`mappend` goes to the right of the right-hand argument. + +In our case, if we use unitDVarSet and mappend, we learn that the free +variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify +over them in that order. (The a comes after the b because we union the +singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter, +the size criterion works to our advantage.) This is just annoying to +users, so I use `extendDVarSet`, which unambiguously puts the new +element to the right. + +Note that the unitDVarSet/mappend implementation would not be wrong +against any specification -- just suboptimal and confounding to users. + +Note [Recurring into kinds for candidateQTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +First, read Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs, paying +attention to the end of the Note about using an empty bound set when +traversing a variable's kind. + +That Note concludes with the recommendation that we empty out the bound +set when recurring into the kind of a type variable. Yet, we do not do +this here. I have two tasks in order to convince you that this code is +right. First, I must show why it is safe to ignore the reasoning in that +Note. Then, I must show why is is necessary to contradict the reasoning in +that Note. + +Why it is safe: There can be no +shadowing in the candidateQ... functions: they work on the output of +type inference, which is seeded by the renamer and its insistence to +use different Uniques for different variables. (In contrast, the Core +functions work on the output of optimizations, which may introduce +shadowing.) Without shadowing, the problem studied by +Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs cannot happen. + +Why it is necessary: +Wiping the bound set would be just plain wrong here. Consider + + forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2)) + +We really don't want to think k1 and k2 are free here. (It's true that we'll +never be able to fill in `hole`, but we don't want to go off the rails just +because we have an insoluble coercion hole.) So: why is it wrong to wipe +the bound variables here but right in Core? Because the final statement +in Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs is wrong: not +every variable is either free or bound. A variable can be a hole, too! +The reasoning in that Note then breaks down. + +And the reasoning applies just as well to free non-hole variables, so we +retain the bound set always. + +-} + +{- ********************************************************************* +* * + Quantification +* * +************************************************************************ + +Note [quantifyTyVars] +~~~~~~~~~~~~~~~~~~~~~ +quantifyTyVars is given the free vars of a type that we +are about to wrap in a forall. + +It takes these free type/kind variables (partitioned into dependent and +non-dependent variables) skolemises metavariables with a TcLevel greater +than the ambient level (see Note [Use level numbers for quantification]). + +* This function distinguishes between dependent and non-dependent + variables only to keep correct defaulting behavior with -XNoPolyKinds. + With -XPolyKinds, it treats both classes of variables identically. + +* quantifyTyVars never quantifies over + - a coercion variable (or any tv mentioned in the kind of a covar) + - a runtime-rep variable + +Note [Use level numbers for quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The level numbers assigned to metavariables are very useful. Not only +do they track touchability (Note [TcLevel invariants] in GHC.Tc.Utils.TcType), +but they also allow us to determine which variables to +generalise. The rule is this: + + When generalising, quantify only metavariables with a TcLevel greater + than the ambient level. + +This works because we bump the level every time we go inside a new +source-level construct. In a traditional generalisation algorithm, we +would gather all free variables that aren't free in an environment. +However, if a variable is in that environment, it will always have a lower +TcLevel: it came from an outer scope. So we can replace the "free in +environment" check with a level-number check. + +Here is an example: + + f x = x + (z True) + where + z y = x * x + +We start by saying (x :: alpha[1]). When inferring the type of z, we'll +quickly discover that z :: alpha[1]. But it would be disastrous to +generalise over alpha in the type of z. So we need to know that alpha +comes from an outer environment. By contrast, the type of y is beta[2], +and we are free to generalise over it. What's the difference between +alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for +generalisation, and so we generalise it. alpha[1] does not, and so +we leave it alone. + +Note that not *every* variable with a higher level will get +generalised, either due to the monomorphism restriction or other +quirks. See, for example, the code in GHC.Tc.Solver.decidePromotedTyVars +and in GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude +certain otherwise-eligible variables from being generalised. + +Using level numbers for quantification is implemented in the candidateQTyVars... +functions, by adding only those variables with a level strictly higher than +the ambient level to the set of candidates. + +Note [quantifyTyVars determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The results of quantifyTyVars are wrapped in a forall and can end up in the +interface file. One such example is inferred type signatures. They also affect +the results of optimizations, for example worker-wrapper. This means that to +get deterministic builds quantifyTyVars needs to be deterministic. + +To achieve this CandidatesQTvs is backed by deterministic sets which allows them +to be later converted to a list in a deterministic order. + +For more information about deterministic sets see +Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. +-} + +quantifyTyVars :: SkolemInfo + -> NonStandardDefaultingStrategy + -> CandidatesQTvs -- See Note [Dependent type variables] + -- Already zonked + -> TcM [TcTyVar] +-- See Note [quantifyTyVars] +-- Can be given a mixture of TcTyVars and TyVars, in the case of +-- associated type declarations. Also accepts covars, but *never* returns any. +-- According to Note [Use level numbers for quantification] and the +-- invariants on CandidateQTvs, we do not have to filter out variables +-- free in the environment here. Just quantify unconditionally, subject +-- to the restrictions in Note [quantifyTyVars]. +quantifyTyVars skol_info ns_strat dvs + -- short-circuit common case + | isEmptyCandidates dvs + = do { traceTc "quantifyTyVars has nothing to quantify" empty + ; return [] } + + | otherwise + = do { traceTc "quantifyTyVars {" + ( vcat [ text "ns_strat =" <+> ppr ns_strat + , text "dvs =" <+> ppr dvs ]) + + ; undefaulted <- defaultTyVars ns_strat dvs + ; final_qtvs <- liftZonkM $ mapMaybeM zonk_quant undefaulted + + ; traceTc "quantifyTyVars }" + (vcat [ text "undefaulted:" <+> pprTyVars undefaulted + , text "final_qtvs:" <+> pprTyVars final_qtvs ]) + + -- We should never quantify over coercion variables; check this + ; let co_vars = filter isCoVar final_qtvs + ; massertPpr (null co_vars) (ppr co_vars) + + ; return final_qtvs } + where + -- zonk_quant returns a tyvar if it should be quantified over; + -- otherwise, it returns Nothing. The latter case happens for + -- non-meta-tyvars + zonk_quant tkv + | not (isTyVar tkv) + = return Nothing -- this can happen for a covar that's associated with + -- a coercion hole. Test case: typecheck/should_compile/T2494 + + | otherwise + = Just <$> skolemiseQuantifiedTyVar skol_info tkv + +zonkAndSkolemise :: SkolemInfo -> TcTyCoVar -> ZonkM TcTyCoVar +-- A tyvar binder is never a unification variable (TauTv), +-- rather it is always a skolem. It *might* be a TyVarTv. +-- (Because non-CUSK type declarations use TyVarTvs.) +-- Regardless, it may have a kind that has not yet been zonked, +-- and may include kind unification variables. +zonkAndSkolemise skol_info tyvar + | isTyVarTyVar tyvar + -- We want to preserve the binding location of the original TyVarTv. + -- This is important for error messages. If we don't do this, then + -- we get bad locations in, e.g., typecheck/should_fail/T2688 + = do { zonked_tyvar <- zonkTcTyVarToTcTyVar tyvar + ; skolemiseQuantifiedTyVar skol_info zonked_tyvar } + + | otherwise + = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $ + zonkTyCoVarKind tyvar + +skolemiseQuantifiedTyVar :: SkolemInfo -> TcTyVar -> ZonkM TcTyVar +-- The quantified type variables often include meta type variables +-- we want to freeze them into ordinary type variables +-- The meta tyvar is updated to point to the new skolem TyVar. Now any +-- bound occurrences of the original type variable will get zonked to +-- the immutable version. +-- +-- We leave skolem TyVars alone; they are immutable. +-- +-- This function is called on both kind and type variables, +-- but kind variables *only* if PolyKinds is on. + +skolemiseQuantifiedTyVar skol_info tv + = case tcTyVarDetails tv of + MetaTv {} -> skolemiseUnboundMetaTyVar skol_info tv + + SkolemTv _ lvl _ -- It might be a skolem type variable, + -- for example from a user type signature + -- But it might also be a shared meta-variable across several + -- type declarations, each with its own skol_info. The first + -- will skolemise it, but the other uses must update its + -- skolem info (#22379) + -> do { kind <- zonkTcType (tyVarKind tv) + ; let details = SkolemTv skol_info lvl False + name = tyVarName tv + ; return (mkTcTyVar name kind details) } + + _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk + +-- | Default a type variable using the given defaulting strategy. +-- +-- See Note [Type variable defaulting options] in GHC.Types.Basic. +defaultTyVar :: DefaultingStrategy + -> TcTyVar -- If it's a MetaTyVar then it is unbound + -> TcM Bool -- True <=> defaulted away altogether +defaultTyVar def_strat tv + | not (isMetaTyVar tv) + || isTyVarTyVar tv + -- Do not default TyVarTvs. Doing so would violate the invariants + -- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType. + -- #13343 is an example; #14555 is another + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + = return False + + | isRuntimeRepVar tv + , default_ns_vars + = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) + ; liftZonkM $ writeMetaTyVar tv liftedRepTy + ; return True } + + | isLevityVar tv + , default_ns_vars + = do { traceTc "Defaulting a Levity var to Lifted" (ppr tv) + ; liftZonkM $ writeMetaTyVar tv liftedDataConTy + ; return True } + + | isMultiplicityVar tv + , default_ns_vars + = do { traceTc "Defaulting a Multiplicity var to Many" (ppr tv) + ; liftZonkM $ writeMetaTyVar tv manyDataConTy + ; return True } + + | isConcreteTyVar tv + -- We don't want to quantify; but neither can we default to + -- anything sensible. (If it has kind RuntimeRep or Levity, as is + -- often the case, it'll have been caught earlier by earlier + -- cases. So in this exotic situation we just promote. Not very + -- satisfing, but it's very much a corner case: #23051 + -- We should really implement the plan in #20686. + = do { lvl <- getTcLevel + ; _ <- promoteMetaTyVarTo lvl tv + ; return True } + + | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it + = default_kind_var tv + + | otherwise + = return False + + where + default_ns_vars :: Bool + default_ns_vars = defaultNonStandardTyVars def_strat + default_kind_var :: TyVar -> TcM Bool + -- defaultKindVar is used exclusively with -XNoPolyKinds + -- See Note [Defaulting with -XNoPolyKinds] + -- It takes an (unconstrained) meta tyvar and defaults it. + -- Works only on vars of type *; for other kinds, it issues an error. + default_kind_var kv + | isLiftedTypeKind (tyVarKind kv) + = do { traceTc "Defaulting a kind var to *" (ppr kv) + ; liftZonkM $ writeMetaTyVar kv liftedTypeKind + ; return True } + | otherwise + = do { let (tidy_env, kv') = tidyFreeTyCoVarX emptyTidyEnv kv + ; addErrTcM $ (tidy_env, TcRnCannotDefaultKindVar kv' (tyVarKind kv')) + -- We failed to default it, so return False to say so. + -- Hence, it'll get skolemised. That might seem odd, but we must either + -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType + -- Note [Recipe for checking a signature] + -- Otherwise we get level-number assertion failures. It doesn't matter much + -- because we are in an error situation anyway. + ; return False + } + +-- | Default some unconstrained type variables, as specified +-- by the defaulting options: +-- +-- - 'RuntimeRep' tyvars default to 'LiftedRep' +-- - 'Levity' tyvars default to 'Lifted' +-- - 'Multiplicity' tyvars default to 'Many' +-- - 'Type' tyvars from dv_kvs default to 'Type', when -XNoPolyKinds +-- (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error) +defaultTyVars :: NonStandardDefaultingStrategy + -> CandidatesQTvs -- ^ all candidates for quantification + -> TcM [TcTyVar] -- ^ those variables not defaulted +defaultTyVars ns_strat dvs + = do { poly_kinds <- xoptM LangExt.PolyKinds + ; let + def_tvs, def_kvs :: DefaultingStrategy + def_tvs = NonStandardDefaulting ns_strat + def_kvs | poly_kinds = def_tvs + | otherwise = DefaultKindVars + -- As -XNoPolyKinds precludes polymorphic kind variables, we default them. + -- For example: + -- + -- type F :: Type -> Type + -- type family F a where + -- F (a -> b) = b + -- + -- Here we get `a :: TYPE r`, so to accept this program when -XNoPolyKinds is enabled + -- we must default the kind variable `r :: RuntimeRep`. + -- Test case: T20584. + ; defaulted_kvs <- mapM (defaultTyVar def_kvs) dep_kvs + ; defaulted_tvs <- mapM (defaultTyVar def_tvs) nondep_tvs + ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs `zip` defaulted_kvs ] + undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ] + ; return (undefaulted_kvs ++ undefaulted_tvs) } + -- NB: kvs before tvs because tvs may depend on kvs + where + (dep_kvs, nondep_tvs) = candidateVars dvs + +skolemiseUnboundMetaTyVar :: SkolemInfo -> TcTyVar -> ZonkM TyVar +-- We have a Meta tyvar with a ref-cell inside it +-- Skolemise it, so that we are totally out of Meta-tyvar-land +-- We create a skolem TcTyVar, not a regular TyVar +-- See Note [Zonking to Skolem] +-- +-- Its level should be one greater than the ambient level, which will typically +-- be the same as the level on the meta-tyvar. But not invariably; for example +-- f :: (forall a b. SameKind a b) -> Int +-- The skolems 'a' and 'b' are bound by tcTKTelescope, at level 2; and they each +-- have a level-2 kind unification variable, since it might get unified with another +-- of the level-2 skolems e.g. 'k' in this version +-- f :: (forall k (a :: k) b. SameKind a b) -> Int +-- So when we quantify the kind vars at the top level of the signature, the ambient +-- level is 1, but we will quantify over kappa[2]. + +skolemiseUnboundMetaTyVar skol_info tv + = assertPpr (isMetaTyVar tv) (ppr tv) $ + do { check_empty tv + -- Get the location and level from "here", + -- i.e. where we are generalising + ; ZonkGblEnv { zge_src_span = here, zge_tc_level = tc_lvl } + <- getZonkGblEnv + ; kind <- zonkTcType (tyVarKind tv) + ; let tv_name = tyVarName tv + -- See Note [Skolemising and identity] + final_name | isSystemName tv_name + = mkInternalName (nameUnique tv_name) + (nameOccName tv_name) here + | otherwise + = tv_name + details = SkolemTv skol_info (pushTcLevel tc_lvl) False + final_tv = mkTcTyVar final_name kind details + + ; traceZonk "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) + ; writeMetaTyVar tv (mkTyVarTy final_tv) + ; return final_tv } + where + check_empty tv -- [Sept 04] Check for non-empty. + = when debugIsOn $ -- See Note [Silly Type Synonyms] + do { cts <- readMetaTyVar tv + ; case cts of + Flexi -> return () + Indirect ty -> warnPprTrace True "skolemiseUnboundMetaTyVar" (ppr tv $$ ppr ty) $ + return () } + +{- Note [Error on unconstrained meta-variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + +* type C :: Type -> Type -> Constraint + class (forall a. a b ~ a c) => C b c + +* type T = forall a. Proxy a + +* data (forall a. a b ~ a c) => T b c + +* type instance F Int = Proxy Any + where Any :: forall k. k + +In the first three cases we will infer a :: Type -> kappa, but then +we get no further information on kappa. In the last, we will get + Proxy kappa Any +but again will get no further info on kappa. + +What do do? + A. We could choose kappa := Type. But this only works when the kind of kappa + is Type (true in this example, but not always). + B. We could default to Any. + C. We could quantify. + D. We could error. + +We choose (D), as described in #17567, and implement this choice in +doNotQuantifyTyVars. Discussion of alternatives A-C is below. + +NB: this is all rather similar to, but sadly not the same as + Note [Naughty quantification candidates] + +To do this, we must take an extra step before doing the final zonk to create +e.g. a TyCon. (There is no problem in the final term-level zonk. See the +section on alternative (B) below.) This extra step is needed only for +constructs that do not quantify their free meta-variables, such as a class +constraint or right-hand side of a type synonym. + +Specifically: before the final zonk, every construct must either call +quantifyTyVars or doNotQuantifyTyVars. The latter issues an error +if it is passed any free variables. (Exception: we still default +RuntimeRep and Multiplicity variables.) + +Because no meta-variables remain after quantifying or erroring, we perform +the zonk with NoFlexi, which panics upon seeing a meta-variable. + +Alternatives A-C, not implemented: + +A. As stated above, this works only sometimes. We might have a free + meta-variable of kind Nat, for example. + +B. This is what we used to do, but it caused Any to appear in error + messages sometimes. See #17567 for several examples. Defaulting to + Any during the final, whole-program zonk is OK, though, because + we are completely done type-checking at that point. No chance to + leak into an error message. + +C. Examine the class declaration at the top of this Note again. + Where should we quantify? We might imagine quantifying and + putting the kind variable in the forall of the quantified constraint. + But what if there are nested foralls? Which one should get the + variable? Other constructs have other problems. (For example, + the right-hand side of a type family instance equation may not + be a poly-type.) + + More broadly, the GHC AST defines a set of places where it performs + implicit lexical generalization. For example, in a type + signature + + f :: Proxy a -> Bool + + the otherwise-unbound a is lexically quantified, giving us + + f :: forall a. Proxy a -> Bool + + The places that allow lexical quantification are marked in the AST with + HsImplicitBndrs. HsImplicitBndrs offers a binding site for otherwise-unbound + variables. + + Later, during type-checking, we discover that a's kind is unconstrained. + We thus quantify *again*, to + + f :: forall {k} (a :: k). Proxy @k a -> Bool + + It is this second quantification that this Note is really about -- + let's call it *inferred quantification*. + So there are two sorts of implicit quantification in types: + 1. Lexical quantification: signalled by HsImplicitBndrs, occurs over + variables mentioned by the user but with no explicit binding site, + suppressed by a user-written forall (by the forall-or-nothing rule, + in Note [forall-or-nothing rule] in GHC.Hs.Type). + 2. Inferred quantification: no signal in HsSyn, occurs over unconstrained + variables invented by the type-checker, possible only with -XPolyKinds, + unaffected by forall-or-nothing rule + These two quantifications are performed in different compiler phases, and are + essentially unrelated. However, it is convenient + for programmers to remember only one set of implicit quantification + sites. So, we choose to use the same places (those with HsImplicitBndrs) + for lexical quantification as for inferred quantification of unconstrained + meta-variables. Accordingly, there is no quantification in a class + constraint, or the other constructs that call doNotQuantifyTyVars. +-} + +doNotQuantifyTyVars :: CandidatesQTvs + -> (TidyEnv -> ZonkM (TidyEnv, UninferrableTyVarCtx)) + -- ^ like "the class context (D a b, E foogle)" + -> TcM () +-- See Note [Error on unconstrained meta-variables] +doNotQuantifyTyVars dvs where_found + | isEmptyCandidates dvs + = traceTc "doNotQuantifyTyVars has nothing to error on" empty + + | otherwise + = do { traceTc "doNotQuantifyTyVars" (ppr dvs) + ; undefaulted <- defaultTyVars DefaultNonStandardTyVars dvs + -- could have regular TyVars here, in an associated type RHS, or + -- bound by a type declaration head. So filter looking only for + -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c` + -- are OK + ; let leftover_metas = filter isMetaTyVar undefaulted + ; unless (null leftover_metas) $ + do { let (tidy_env1, tidied_tvs) = tidyFreeTyCoVarsX emptyTidyEnv leftover_metas + ; (tidy_env2, where_doc) <- liftZonkM $ where_found tidy_env1 + ; let msg = TcRnUninferrableTyVar tidied_tvs where_doc + ; failWithTcM (tidy_env2, msg) } + ; traceTc "doNotQuantifyTyVars success" empty } + +{- Note [Defaulting with -XNoPolyKinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data Compose f g a = Mk (f (g a)) + +We infer + + Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> * + Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1). + f (g a) -> Compose k1 k2 f g a + +Now, in another module, we have -XNoPolyKinds -XDataKinds in effect. +What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds, +we just defaulted all kind variables to *. But that's no good here, +because the kind variables in 'Mk aren't of kind *, so defaulting to * +is ill-kinded. + +After some debate on #11334, we decided to issue an error in this case. +The code is in defaultKindVar. + +Note [What is a meta variable?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "meta type-variable", also know as a "unification variable" is a placeholder +introduced by the typechecker for an as-yet-unknown monotype. + +For example, when we see a call `reverse (f xs)`, we know that we calling + reverse :: forall a. [a] -> [a] +So we know that the argument `f xs` must be a "list of something". But what is +the "something"? We don't know until we explore the `f xs` a bit more. So we set +out what we do know at the call of `reverse` by instantiating its type with a fresh +meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the +result, is `[alpha]`. The unification variable `alpha` stands for the +as-yet-unknown type of the elements of the list. + +As type inference progresses we may learn more about `alpha`. For example, suppose +`f` has the type + f :: forall b. b -> [Maybe b] +Then we instantiate `f`'s type with another fresh unification variable, say +`beta`; and equate `f`'s result type with reverse's argument type, thus +`[alpha] ~ [Maybe beta]`. + +Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've +refined our knowledge about `alpha`. And so on. + +If you found this Note useful, you may also want to have a look at +Section 5 of "Practical type inference for higher rank types" (Peyton Jones, +Vytiniotis, Weirich and Shields. J. Functional Programming. 2011). + +Note [Zonking to Skolem] +~~~~~~~~~~~~~~~~~~~~~~~~ +We used to zonk quantified type variables to regular TyVars. However, this +leads to problems. Consider this program from the regression test suite: + + eval :: Int -> String -> String -> String + eval 0 root actual = evalRHS 0 root actual + + evalRHS :: Int -> a + evalRHS 0 root actual = eval 0 root actual + +It leads to the deferral of an equality (wrapped in an implication constraint) + + forall a. () => ((String -> String -> String) ~ a) + +which is propagated up to the toplevel (see GHC.Tc.Solver.tcSimplifyInferCheck). +In the meantime `a' is zonked and quantified to form `evalRHS's signature. +This has the *side effect* of also zonking the `a' in the deferred equality +(which at this point is being handed around wrapped in an implication +constraint). + +Finally, the equality (with the zonked `a') will be handed back to the +simplifier by GHC.Tc.Module.tcRnSrcDecls calling GHC.Tc.Solver.tcSimplifyTop. +If we zonk `a' with a regular type variable, we will have this regular type +variable now floating around in the simplifier, which in many places assumes to +only see proper TcTyVars. + +We can avoid this problem by zonking with a skolem TcTyVar. The +skolem is rigid (which we require for a quantified variable), but is +still a TcTyVar that the simplifier knows how to deal with. + +Note [Skolemising and identity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In some places, we make a TyVarTv for a binder. E.g. + class C a where ... +As Note [Inferring kinds for type declarations] discusses, +we make a TyVarTv for 'a'. Later we skolemise it, and we'd +like to retain its identity, location info etc. (If we don't +retain its identity we'll have to do some pointless swizzling; +see GHC.Tc.TyCl.swizzleTcTyConBndrs. If we retain its identity +but not its location we'll lose the detailed binding site info. + +Conclusion: use the Name of the TyVarTv. But we don't want +to do that when skolemising random unification variables; +there the location we want is the skolemisation site. + +Fortunately we can tell the difference: random unification +variables have System Names. That's why final_name is +set based on the isSystemName test. + + +Note [Silly Type Synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + type C u a = u -- Note 'a' unused + + foo :: (forall a. C u a -> C u a) -> u + foo x = ... + + bar :: Num u => u + bar = foo (\t -> t + t) + +* From the (\t -> t+t) we get type {Num d} => d -> d + where d is fresh. + +* Now unify with type of foo's arg, and we get: + {Num (C d a)} => C d a -> C d a + where a is fresh. + +* Now abstract over the 'a', but float out the Num (C d a) constraint + because it does not 'really' mention a. (see exactTyVarsOfType) + The arg to foo becomes + \/\a -> \t -> t+t + +* So we get a dict binding for Num (C d a), which is zonked to give + a = () + Note (Sept 04): now that we are zonking quantified type variables + on construction, the 'a' will be frozen as a regular tyvar on + quantification, so the floated dict will still have type (C d a). + Which renders this whole note moot; happily!] + +* Then the \/\a abstraction has a zonked 'a' in it. + +All very silly. I think its harmless to ignore the problem. We'll end up with +a \/\a in the final result but all the occurrences of a will be zonked to () +-} + +-------------------------------------------------------------------------------- + +-- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the +-- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the +-- usage environment. +tcCheckUsage :: Name -> Mult -> TcM a -> TcM a +tcCheckUsage name id_mult thing_inside + = do { (local_usage, result) <- tcCollectingUsage thing_inside + ; check_usage (lookupUE local_usage name) + ; tcEmitBindingUsage (deleteUE local_usage name) + ; return result } + where + check_usage :: Usage -> TcM () + -- Checks that the usage of the newly introduced binder is compatible with + -- its multiplicity. + check_usage actual_u + = do { traceTc "check_usage" (ppr id_mult $$ ppr actual_u) + ; case actual_u of + Bottom -> return () + Zero -> tcSubMult (UsageEnvironmentOf name) ManyTy id_mult + MUsage m -> do { m <- promote_mult m + ; tcSubMult (UsageEnvironmentOf name) m id_mult } } + + -- This is gross. The problem is in test case typecheck/should_compile/T18998: + -- f :: a %1-> Id n a -> Id n a + -- f x (MkId _) = MkId x + -- where MkId is a GADT constructor. Multiplicity polymorphism of constructors + -- invents a new multiplicity variable p[2] for the application MkId x. This + -- variable is at level 2, bumped because of the GADT pattern-match (MkId _). + -- We eventually unify the variable with One, due to the call to tcSubMult in + -- tcCheckUsage. But by then, we're at TcLevel 1, and so the level-check + -- fails. + -- + -- What to do? If we did inference "for real", the sub-multiplicity constraint + -- would end up in the implication of the GADT pattern-match, and all would + -- be well. But we don't have a real sub-multiplicity constraint to put in + -- the implication. (Multiplicity inference works outside the usual generate- + -- constraints-and-solve scheme.) Here, where the multiplicity arrives, we + -- must promote all multiplicity variables to reflect this outer TcLevel. + -- It's reminiscent of floating a constraint, really, so promotion is + -- appropriate. The promoteTcType function works only on types of kind TYPE rr, + -- so we can't use it here. Thus, this dirtiness. + -- + -- It works nicely in practice. + -- + -- We use a set to avoid calling promoteMetaTyVarTo twice on the same + -- metavariable. This happened in #19400. + promote_mult m = do { fvs <- liftZonkM $ zonkTyCoVarsAndFV (tyCoVarsOfType m) + ; any_promoted <- promoteTyVarSet fvs + ; if any_promoted then liftZonkM $ zonkTcType m else return m + } + +{- ********************************************************************* +* * + Short-cuts for overloaded numeric literals +* * +********************************************************************* -} + +-- Overloaded literals. Here mainly because it uses isIntTy etc + +{- Note [Short cut for overloaded literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)). +But if we have a list like + [4,2,3,2,4,4,2]::[Int] +we use a lot of compile time and space generating and solving all those Num +constraints, and generating calls to fromInteger etc. Better just to cut to +the chase, and cough up an Int literal. Large collections of literals like this +sometimes appear in source files, so it's quite a worthwhile fix. + +So we try to take advantage of whatever nearby type information we have, +to short-cut the process for built-in types. We can do this in two places; + +* In the typechecker, when we are about to typecheck the literal. +* If that fails, in the desugarer, once we know the final type. +-} + +tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc)) +tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable _}) exp_res_ty + | not rebindable + , Just res_ty <- checkingExpType_maybe exp_res_ty + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; case shortCutLit platform val res_ty of + Just expr -> return $ Just $ + lit { ol_ext = OverLitTc False expr res_ty } + Nothing -> return Nothing } + | otherwise + = return Nothing + +shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc) +shortCutLit platform val res_ty + = case val of + HsIntegral int_lit -> go_integral int_lit + HsFractional frac_lit -> go_fractional frac_lit + HsIsString s src -> go_string s src + where + go_integral int@(IL src neg i) + | isIntTy res_ty && platformInIntRange platform i + = Just (HsLit noExtField (HsInt noExtField int)) + | isWordTy res_ty && platformInWordRange platform i + = Just (mkLit wordDataCon (HsWordPrim src i)) + | isIntegerTy res_ty + = Just (HsLit noExtField (XLit $ HsInteger src i res_ty)) + | otherwise + = go_fractional (integralFractionalLit neg i) + -- The 'otherwise' case is important + -- Consider (3 :: Float). Syntactically it looks like an IntLit, + -- so we'll call shortCutIntLit, but of course it's a float + -- This can make a big difference for programs with a lot of + -- literals, compiled without -O + + go_fractional f + | isFloatTy res_ty && valueInRange = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) + | isDoubleTy res_ty && valueInRange = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) + | otherwise = Nothing + where + valueInRange = + case f of + FL { fl_exp = e } -> (-100) <= e && e <= 100 + -- We limit short-cutting Fractional Literals to when their power of 10 + -- is less than 100, which ensures desugaring isn't slow. + + go_string src s + | isStringTy res_ty = Just (HsLit noExtField (HsString src s)) + | otherwise = Nothing + +mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc +mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) + +------------------------------ +hsOverLitName :: OverLitVal -> Name +-- Get the canonical 'fromX' name for a particular OverLitVal +hsOverLitName (HsIntegral {}) = fromIntegerName +hsOverLitName (HsFractional {}) = fromRationalName +hsOverLitName (HsIsString {}) = fromStringName + + +{- ********************************************************************* +* * + Promotion +* * +********************************************************************* -} + +promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool +-- When we float a constraint out of an implication we must restore +-- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType +-- Return True <=> we did some promotion +-- Also returns either the original tyvar (no promotion) or the new one +-- See Note [Promote monomorphic tyvars] in GHC.Tc.Solver +promoteMetaTyVarTo tclvl tv + | assertPpr (isMetaTyVar tv) (ppr tv) $ + tcTyVarLevel tv `strictlyDeeperThan` tclvl + = do { cloned_tv <- cloneMetaTyVar tv + ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl + ; liftZonkM $ writeMetaTyVar tv (mkTyVarTy rhs_tv) + ; traceTc "promoteTyVar" (ppr tv <+> text "-->" <+> ppr rhs_tv) + ; return True } + | otherwise + = return False + +-- Returns whether or not *any* tyvar is defaulted +promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool +promoteTyVarSet tvs + = do { tclvl <- getTcLevel + ; bools <- mapM (promoteMetaTyVarTo tclvl) $ + filter isPromotableMetaTyVar $ + nonDetEltsUniqSet tvs + -- Non-determinism is OK because order of promotion doesn't matter + ; return (or bools) } + +{- +%************************************************************************ +%* * + Representation polymorphism checks +* * +***********************************************************************-} + +-- | Check that the specified type has a fixed runtime representation. +-- +-- If it isn't, throw a representation-polymorphism error appropriate +-- for the context (as specified by the 'FixedRuntimeRepProvenance'). +-- +-- Unlike the other representation polymorphism checks, which can emit +-- new Wanted constraints to be solved by the constraint solver, this function +-- does not emit any constraints: it has enough information to immediately +-- make a decision. +-- +-- See (1) in Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete +checkTypeHasFixedRuntimeRep :: FixedRuntimeRepProvenance -> Type -> TcM () +checkTypeHasFixedRuntimeRep prov ty = + unless (typeHasFixedRuntimeRep ty) + (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov) + +{- ********************************************************************** +* * + Error messages +* * +********************************************************************** -} + +-- See Note [Naughty quantification candidates] +naughtyQuantification :: TcType -- original type user wanted to quantify + -> TcTyVar -- naughty var + -> TyVarSet -- skolems that would escape + -> TcM a +naughtyQuantification orig_ty tv escapees + = do { (orig_ty1, escapees') <- liftZonkM $ + do { orig_ty1 <- zonkTcType orig_ty -- in case it's not zonked + ; escapees' <- zonkTcTyVarsToTcTyVars $ + nonDetEltsUniqSet escapees + -- we'll just be printing, so no harmful non-determinism + ; return (orig_ty1, escapees') } + + ; let fvs = tyCoVarsOfTypeList orig_ty1 + env0 = tidyFreeTyCoVars emptyTidyEnv fvs + env = env0 `delTidyEnvList` escapees' + -- this avoids gratuitous renaming of the escaped + -- variables; very confusing to users! + + orig_ty' = tidyType env orig_ty1 + tidied = map (tidyTyCoVarOcc env) escapees' + msg = TcRnSkolemEscape tidied (tidyTyCoVarOcc env tv) orig_ty' + + ; failWithTcM (env, msg) } diff --git a/GHC/Tc/Utils/TcMType.hs-boot b/GHC/Tc/Utils/TcMType.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/TcMType.hs-boot @@ -0,0 +1,7 @@ +module GHC.Tc.Utils.TcMType where + +import GHC.Tc.Types +import GHC.Types.Name +import GHC.Core.TyCo.Rep + +tcCheckUsage :: Name -> Mult -> TcM a -> TcM a diff --git a/GHC/Tc/Utils/TcType.hs b/GHC/Tc/Utils/TcType.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/TcType.hs @@ -0,0 +1,2463 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Types used in the typechecker +-- +-- This module provides the Type interface for front-end parts of the +-- compiler. These parts +-- +-- * treat "source types" as opaque: +-- newtypes, and predicates are meaningful. +-- * look through usage types +-- +module GHC.Tc.Utils.TcType ( + -------------------------------- + -- Types + TcType, TcSigmaType, TcTypeFRR, TcSigmaTypeFRR, + TcRhoType, TcRhoTypeFRR, TcTauType, TcPredType, TcThetaType, + TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, + TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder, + TcTyCon, MonoTcTyCon, PolyTcTyCon, TcTyConBinder, KnotTied, + + ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..), + ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR, + ExpRhoType, ExpRhoTypeFRR, + mkCheckExpType, + checkingExpType_maybe, checkingExpType, + + ExpPatType(..), mkCheckExpFunPatTy, mkInvisExpPatType, + isVisibleExpPatType, isExpFunPatType, + + SyntaxOpType(..), synKnownType, mkSynFunTys, + + -------------------------------- + -- TcLevel + TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, + strictlyDeeperThan, deeperThanOrSame, sameDepthAs, + tcTypeLevel, tcTyVarLevel, maxTcLevel, minTcLevel, + + -------------------------------- + -- MetaDetails + TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTvUnk, + MetaDetails(Flexi, Indirect), MetaInfo(..), skolemSkolInfo, + isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, + tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, + ConcreteTvOrigin(..), isConcreteTyVar_maybe, isConcreteTyVar, + isConcreteTyVarTy, isConcreteTyVarTy_maybe, concreteInfo_maybe, + ConcreteTyVars, noConcreteTyVars, + isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo, + isFlexi, isIndirect, isRuntimeUnkSkol, + isQLInstTyVar, isRuntimeUnkTyVar, + metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, + isTouchableMetaTyVar, isPromotableMetaTyVar, + findDupTyVarTvs, mkTyVarNamePairs, + + -------------------------------- + -- Builders + mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, mkPhiTy, tcMkPhiTy, + tcMkDFunSigmaTy, tcMkDFunPhiTy, + + -------------------------------- + -- Splitters + getTyVar, getTyVar_maybe, getCastedTyVar_maybe, + tcSplitForAllTyVarBinder_maybe, tcSplitForAllTyVarsReqTVBindersN, + tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars, + tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders, + tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBinders, + tcSplitPhiTy, tcSplitPredFunTy_maybe, + tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN, + tcSplitFunTysN, + tcSplitTyConApp, tcSplitTyConApp_maybe, + tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, + tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe, + tcSplitSigmaTy, tcSplitSigmaTyBndrs, tcSplitNestedSigmaTys, tcSplitIOType_maybe, + + --------------------------------- + -- Predicates. + -- Again, newtypes are opaque + isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, + isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, + isIntegerTy, isNaturalTy, + isBoolTy, isUnitTy, isAnyTy, isZonkAnyTy, isCharTy, + isTauTy, isTauTyCon, tcIsTyVarTy, + isPredTy, isSimplePredTy, isTyVarClassPred, + checkValidClsArgs, hasTyVarHead, + isRigidTy, anyTy_maybe, + + + -- Re-exported from GHC.Core.TyCo.Compare + -- mainly just for back-compat reasons + eqType, eqTypes, nonDetCmpType, eqTypeX, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, mayLookIdentical, + tcEqTyConApps, eqForAllVis, eqVarBndrs, + + --------------------------------- + -- Misc type manipulators + + deNoteType, + getDFunTyKey, evVarPred, + ambigTkvsOfTy, + + --------------------------------- + -- Predicate types + mkMinimalBySCs, transSuperClasses, + pickCapturedPreds, + immSuperClasses, boxEqPred, + isImprovementPred, + + -- * Finding type instances + tcTyFamInsts, tcTyFamInstsAndVis, tcTyConAppTyFamInstsAndVis, isTyFamFree, + + -- * Finding "exact" (non-dead) type variables + exactTyCoVarsOfType, exactTyCoVarsOfTypes, + anyRewritableTyVar, anyRewritableTyFamApp, UnderFam, + + --------------------------------- + -- Patersons sizes + PatersonSize(..), PatersonCondFailure(..), + PatersonCondFailureContext(..), + ltPatersonSize, + pSizeZero, pSizeOne, + pSizeType, pSizeTypeX, pSizeTypes, + pSizeClassPred, pSizeClassPredX, + pSizeTyConApp, pSizeHead, + noMoreTyVars, allDistinctTyVars, + TypeSize, sizeType, sizeTypes, scopedSort, + isTerminatingClass, isStuckTypeFamily, + + -------------------------------- + -- Reexported from Kind + Kind, liftedTypeKind, constraintKind, + isLiftedTypeKind, isUnliftedTypeKind, isTYPEorCONSTRAINT, + + -------------------------------- + -- Reexported from Type + Type, PredType, ThetaType, PiTyBinder, + ForAllTyFlag(..), FunTyFlag(..), + + mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, + mkSpecForAllTys, mkTyCoInvForAllTy, + mkInfForAllTy, mkInfForAllTys, + mkVisFunTy, mkVisFunTyMany, mkVisFunTysMany, + mkScaledFunTys, + mkInvisFunTy, mkInvisFunTys, + mkTyConApp, mkAppTy, mkAppTys, + mkTyConTy, mkTyVarTy, mkTyVarTys, + mkTyCoVarTy, mkTyCoVarTys, + + isClassPred, isEqPred, couldBeIPLike, isEqClassPred, + isEqualityClass, mkClassPred, + tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, + isRuntimeRepVar, isFixedRuntimeRepKind, + isVisiblePiTyBinder, isInvisiblePiTyBinder, + + -- Type substitutions + Subst(..), -- Representation visible to a few friends + TvSubstEnv, emptySubst, mkEmptySubst, + zipTvSubst, + mkTvSubstPrs, notElemSubst, unionSubst, + getTvSubstEnv, substInScopeSet, extendSubstInScope, + extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope, + Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, + Type.extendTvSubst, + isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, + Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars, + substTyAddInScope, + substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, + substThetaUnchecked, + substTyWithUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTheta, + + isUnliftedType, + isUnboxedTupleType, + isPrimitiveType, + + coreView, + + tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, + tyCoFVsOfType, tyCoFVsOfTypes, + tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet, + tyCoVarsOfTypeList, tyCoVarsOfTypesList, + noFreeVarsOfType, + + -------------------------------- + pprKind, pprParendKind, pprSigmaType, + pprType, pprParendType, pprTypeApp, + pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, + pprTCvBndr, pprTCvBndrs, + + --------------------------------- + -- argument visibility + tyConVisibilities, isNextTyConArgVisible, isNextArgVisible + + ) where + +-- friends: +import GHC.Prelude + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars ) +import GHC.Core.TyCo.Compare +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr +import GHC.Core.Class +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Core.Coercion +import GHC.Core.Type as Type +import GHC.Core.Predicate +import GHC.Core.TyCon + +import {-# SOURCE #-} GHC.Tc.Types.Origin + ( SkolemInfo, unkSkol + , FixedRuntimeRepOrigin, FixedRuntimeRepContext ) + +-- others: +import GHC.Types.Name as Name + -- We use this to make dictionaries for type literals. + -- Perhaps there's a better way to do this? +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Builtin.Names +import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyConKey + , listTyCon, constraintKind ) +import GHC.Types.Basic +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Data.List.SetOps ( getNth, findDupsEq ) +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.IORef ( IORef ) +import Data.List.NonEmpty( NonEmpty(..) ) +import Data.List ( partition, nub, (\\) ) + +{- +************************************************************************ +* * + Types +* * +************************************************************************ + +The type checker divides the generic Type world into the +following more structured beasts: + +sigma ::= forall tyvars. phi + -- A sigma type is a qualified type + -- + -- Note that even if 'tyvars' is empty, theta + -- may not be: e.g. (?x::Int) => Int + + -- Note that 'sigma' is in prenex form: + -- all the foralls are at the front. + -- A 'phi' type has no foralls to the right of + -- an arrow + +phi :: theta => rho + +rho ::= sigma -> rho + | tau + +-- A 'tau' type has no quantification anywhere +-- Note that the args of a type constructor must be taus +tau ::= tyvar + | tycon tau_1 .. tau_n + | tau_1 tau_2 + | tau_1 -> tau_2 + +-- In all cases, a (saturated) type synonym application is legal, +-- provided it expands to the required form. + +Note [TcTyVars and TyVars in the typechecker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker uses a lot of type variables with special properties, +notably being a unification variable with a mutable reference. These +use the 'TcTyVar' variant of Var.Var. + +Note, though, that a /bound/ type variable can (and probably should) +be a TyVar. E.g + forall a. a -> a +Here 'a' is really just a deBruijn-number; it certainly does not have +a significant TcLevel (as every TcTyVar does). So a forall-bound type +variable should be TyVars; and hence a TyVar can appear free in a TcType. + +The type checker and constraint solver can also encounter /free/ type +variables that use the 'TyVar' variant of Var.Var, for a couple of +reasons: + + - When typechecking a class decl, say + class C (a :: k) where + foo :: T a -> Int + We have first kind-check the header; fix k and (a:k) to be + TyVars, bring 'k' and 'a' into scope, and kind check the + signature for 'foo'. In doing so we call solveEqualities to + solve any kind equalities in foo's signature. So the solver + may see free occurrences of 'k'. + + See calls to tcExtendTyVarEnv for other places that ordinary + TyVars are bought into scope, and hence may show up in the types + and kinds generated by GHC.Tc.Gen.HsType. + + - The pattern-match overlap checker calls the constraint solver, + long after TcTyVars have been zonked away + +It's convenient to simply treat these TyVars as skolem constants, +which of course they are. We give them a level number of "outermost", +so they behave as global constants. Specifically: + +* Var.tcTyVarDetails succeeds on a TyVar, returning + vanillaSkolemTv, as well as on a TcTyVar. + +* tcIsTcTyVar returns True for both TyVar and TcTyVar variants + of Var.Var. The "tc" prefix means "a type variable that can be + encountered by the typechecker". + +This is a bit of a change from an earlier era when we remorselessly +insisted on real TcTyVars in the type checker. But that seems +unnecessary (for skolems, TyVars are fine) and it's now very hard +to guarantee, with the advent of kind equalities. + +Note [Coercion variables in free variable lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several places in the GHC codebase where functions like +tyCoVarsOfType, tyCoVarsOfCt, et al. are used to compute the free type +variables of a type. The "Co" part of these functions' names shouldn't be +dismissed, as it is entirely possible that they will include coercion variables +in addition to type variables! As a result, there are some places in GHC.Tc.Utils.TcType +where we must take care to check that a variable is a _type_ variable (using +isTyVar) before calling tcTyVarDetails--a partial function that is not defined +for coercion variables--on the variable. Failing to do so led to +GHC #12785. +-} + +-- See Note [TcTyVars and TyVars in the typechecker] +type TcCoVar = CoVar -- Used only during type inference +type TcType = Type -- A TcType can have mutable type variables +type TcTyCoVar = Var -- Either a TcTyVar or a CoVar + +-- | A type which has a syntactically fixed RuntimeRep as per +-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +type TcTypeFRR = TcType + -- TODO: consider making this a newtype. + +type TcTyVarBinder = TyVarBinder +type TcInvisTVBinder = InvisTVBinder +type TcReqTVBinder = ReqTVBinder + +-- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl +type TcTyCon = TyCon +type MonoTcTyCon = TcTyCon +type PolyTcTyCon = TcTyCon +type TcTyConBinder = TyConBinder -- With skolem TcTyVars + +-- These types do not have boxy type variables in them +type TcPredType = PredType +type TcThetaType = ThetaType +type TcSigmaType = TcType + +-- | A 'TcSigmaTypeFRR' is a 'TcSigmaType' which has a syntactically +-- fixed 'RuntimeRep' in the sense of Note [Fixed RuntimeRep] +-- in GHC.Tc.Utils.Concrete. +-- +-- In particular, this means that: +-- +-- - 'GHC.Types.RepType.typePrimRep' does not panic, +-- - 'GHC.Core.typeLevity_maybe' does not return 'Nothing'. +-- +-- This property is important in functions such as 'matchExpectedFunTys', where +-- we want to provide argument types which have a known runtime representation. +-- See Note [Return arguments with a fixed RuntimeRep. +type TcSigmaTypeFRR = TcSigmaType + -- TODO: consider making this a newtype. +type TcRhoTypeFRR = TcRhoType + +type TcRhoType = TcType -- Note [TcRhoType] +type TcTauType = TcType +type TcKind = Kind +type TcTyVarSet = TyVarSet +type TcTyCoVarSet = TyCoVarSet +type TcDTyVarSet = DTyVarSet +type TcDTyCoVarSet = DTyCoVarSet + + +{- ********************************************************************* +* * + ExpType: an "expected type" in the type checker +* * +********************************************************************* -} + +-- | An expected type to check against during type-checking. +-- See Note [ExpType] in "GHC.Tc.Utils.TcMType", where you'll also find manipulators. +data ExpType = Check TcType + | Infer !InferResult + +data InferResult + = IR { ir_uniq :: Unique + -- ^ This 'Unique' is for debugging only + + , ir_lvl :: TcLevel + -- ^ See Note [TcLevel of ExpType] in GHC.Tc.Utils.TcMType + + , ir_frr :: InferFRRFlag + -- ^ See Note [FixedRuntimeRep context in ExpType] in GHC.Tc.Utils.TcMType + + , ir_inst :: InferInstFlag + -- ^ True <=> when DeepSubsumption is on, deeply instantiate before filling, + -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify + + , ir_ref :: IORef (Maybe TcType) } + -- ^ The type that fills in this hole should be a @Type@, + -- that is, its kind should be @TYPE rr@ for some @rr :: RuntimeRep@. + -- + -- Additionally, if the 'ir_frr' field is @Just frr_orig@ then + -- @rr@ must be concrete, in the sense of Note [Concrete types] + -- in GHC.Tc.Utils.Concrete. + +data InferFRRFlag + = IFRR_Check -- Check that the result type has a fixed runtime rep + FixedRuntimeRepContext -- Typically used for function arguments and lambdas + + | IFRR_Any -- No need to check for fixed runtime-rep + +data InferInstFlag -- Specifies whether the inference should return an uninstantiated + -- SigmaType, or a (possibly deeply) instantiated RhoType + -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify + + = IIF_Sigma -- Trying to infer a SigmaType + -- Don't instantiate at all, regardless of DeepSubsumption + -- Typically used when inferring the type of a pattern + + | IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top) + -- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole + -- Typically used when inferring the type of an expression + + | IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption) + -- If DeepSubsumption is off, same as IIF_ShallowRho + -- If DeepSubsumption is on, instantiate deeply before filling the hole + +type ExpSigmaType = ExpType +type ExpRhoType = ExpType + -- Invariant: in ExpRhoType, if -XDeepSubsumption is on, + -- and we are in checking mode (i.e. the ExpRhoType is (Check rho)), + -- then the `rho` is deeply skolemised + +-- | An 'ExpType' which has a fixed RuntimeRep. +-- +-- For a 'Check' 'ExpType', the stored 'TcType' must have +-- a fixed RuntimeRep. For an 'Infer' 'ExpType', the 'ir_frr' +-- field must be of the form @IFRR_Check frr_orig@. +type ExpTypeFRR = ExpType + +-- | Like 'TcSigmaTypeFRR', but for an expected type. +-- +-- See 'ExpTypeFRR'. +type ExpSigmaTypeFRR = ExpTypeFRR +type ExpRhoTypeFRR = ExpTypeFRR + -- TODO: consider making this a newtype. + +-- | Like 'ExpType', but on kind level +type ExpKind = ExpType + +instance Outputable ExpType where + ppr (Check ty) = text "Check" <> braces (ppr ty) + ppr (Infer ir) = ppr ir + +instance Outputable InferResult where + ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr, ir_inst = inst }) + = text "Infer" <> parens (pp_inst <> pp_frr) + <> braces (ppr u <> comma <> ppr lvl) + where + pp_inst = case inst of + IIF_Sigma -> text "Sigma" + IIF_ShallowRho -> text "ShallowRho" + IIF_DeepRho -> text "DeepRho" + pp_frr = case mb_frr of + IFRR_Check {} -> text ",FRR" + IFRR_Any -> empty + +-- | Make an 'ExpType' suitable for checking. +mkCheckExpType :: TcType -> ExpType +mkCheckExpType = Check + +-- | Returns the expected type when in checking mode. +checkingExpType_maybe :: ExpType -> Maybe TcType +checkingExpType_maybe (Check ty) = Just ty +checkingExpType_maybe (Infer {}) = Nothing + +-- | Returns the expected type when in checking mode. +-- Panics if in inference mode. +checkingExpType :: ExpType -> TcType +checkingExpType (Check ty) = ty +checkingExpType et@(Infer {}) = pprPanic "checkingExpType" (ppr et) + +-- Expected type of a pattern in a lambda or a function left-hand side. +data ExpPatType = + ExpFunPatTy (Scaled ExpSigmaTypeFRR) -- the type A of a function A -> B + | ExpForAllPatTy ForAllTyBinder -- the binder (a::A) of forall (a::A) -> B or forall (a :: A). B + +mkCheckExpFunPatTy :: Scaled TcType -> ExpPatType +mkCheckExpFunPatTy (Scaled mult ty) = ExpFunPatTy (Scaled mult (mkCheckExpType ty)) + +mkInvisExpPatType :: InvisTyBinder -> ExpPatType +mkInvisExpPatType (Bndr tv spec) = ExpForAllPatTy (Bndr tv (Invisible spec)) + +isVisibleExpPatType :: ExpPatType -> Bool +isVisibleExpPatType (ExpForAllPatTy (Bndr _ vis)) = isVisibleForAllTyFlag vis +isVisibleExpPatType (ExpFunPatTy {}) = True + +isExpFunPatType :: ExpPatType -> Bool +isExpFunPatType ExpFunPatTy{} = True +isExpFunPatType ExpForAllPatTy{} = False + +instance Outputable ExpPatType where + ppr (ExpFunPatTy t) = ppr t + ppr (ExpForAllPatTy tv) = text "forall" <+> ppr tv + +{- ********************************************************************* +* * + SyntaxOpType +* * +********************************************************************* -} + +-- | What to expect for an argument to a rebindable-syntax operator. +-- Quite like 'Type', but allows for holes to be filled in by tcSyntaxOp. +-- The callback called from tcSyntaxOp gets a list of types; the meaning +-- of these types is determined by a left-to-right depth-first traversal +-- of the 'SyntaxOpType' tree. So if you pass in +-- +-- > SynAny `SynFun` (SynList `SynFun` SynType Int) `SynFun` SynAny +-- +-- you'll get three types back: one for the first 'SynAny', the /element/ +-- type of the list, and one for the last 'SynAny'. You don't get anything +-- for the 'SynType', because you've said positively that it should be an +-- Int, and so it shall be. +-- +-- You'll also get three multiplicities back: one for each function arrow. See +-- also Note [Linear types] in Multiplicity. +-- +-- This is defined here to avoid defining it in "GHC.Tc.Gen.Expr" boot file. +data SyntaxOpType + = SynAny -- ^ Any type + | SynRho -- ^ A rho type, skolemised or instantiated as appropriate + | SynList -- ^ A list type. You get back the element type of the list + | SynFun SyntaxOpType SyntaxOpType + -- ^ A function. + | SynType ExpType -- ^ A known type. +infixr 0 `SynFun` + +-- | Like 'SynType' but accepts a regular TcType +synKnownType :: TcType -> SyntaxOpType +synKnownType = SynType . mkCheckExpType + +-- | Like 'mkFunTys' but for 'SyntaxOpType' +mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType +mkSynFunTys arg_tys res_ty = foldr SynFun (SynType res_ty) arg_tys + + +{- +Note [TcRhoType] +~~~~~~~~~~~~~~~~ +A TcRhoType has no foralls or contexts at the top + NO forall a. a -> Int + NO Eq a => a -> a + YES a -> a + YES (forall a. a->a) -> Int + YES Int -> forall a. a -> Int + + +************************************************************************ +* * + TyVarDetails, MetaDetails, MetaInfo +* * +************************************************************************ + +TyVarDetails gives extra info about type variables, used during type +checking. It's attached to mutable type variables only. +It's knot-tied back to "GHC.Types.Var". There is no reason in principle +why "GHC.Types.Var" shouldn't actually have the definition, but it "belongs" here. + +Note [TyVars and TcTyVars during type checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Var type has constructors TyVar and TcTyVar. They are used +as follows: + +* TcTyVar: used /only/ during type checking. Should never appear + afterwards. May contain a mutable field, in the MetaTv case. + +* TyVar: is never seen by the constraint solver, except locally + inside a type like (forall a. [a] ->[a]), where 'a' is a TyVar. + We instantiate these with TcTyVars before exposing the type + to the constraint solver. + +I have swithered about the latter invariant, excluding TyVars from the +constraint solver. It's not strictly essential, and indeed +(historically but still there) Var.tcTyVarDetails returns +vanillaSkolemTv for a TyVar. + +But ultimately I want to separate Type from TcType, and in that case +we would need to enforce the separation. + +Note [Keeping SkolemInfo inside a SkolemTv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A SkolemTv contains a SkolemInfo, which describes the binding side of that +TcTyVar. This is very convenient to a consumer of a SkolemTv, but it is +a bit awkward for the /producer/. Why? Because sometimes we can't produce +the SkolemInfo until we have the TcTyVars! + +Example: in `GHC.Tc.Utils.Unify.tcSkolemise` we create SkolemTvs whose +`SkolemInfo` is `SigSkol`, whose arguments in turn mention the newly-created +SkolemTvs. So we a RecrusiveDo idiom, like this: + + rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } + +Note that the `skol_info` can't be created until we have the `tv_prs` returned +by `skolemise`. Note also that `skolemise` had better be lazy in `skol_info`. + +All uses of this idiom should be flagged with a reference to this Note. +-} + +-- A TyVarDetails is inside a TyVar +-- See Note [TyVars and TcTyVars during type checking] +data TcTyVarDetails + = SkolemTv -- A skolem + SkolemInfo -- See Note [Keeping SkolemInfo inside a SkolemTv] + TcLevel -- Level of the implication that binds it + -- See GHC.Tc.Utils.Unify Note [Deeper level on the left] for + -- how this level number is used + Bool -- True <=> this skolem type variable can be overlapped + -- when looking up instances + -- See Note [Super skolems: binding when looking up instances] + -- in GHC.Core.InstEnv + + | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi + -- interactive context + + | MetaTv { mtv_info :: MetaInfo + , mtv_ref :: IORef MetaDetails + , mtv_tclvl :: TcLevel } -- See Note [TcLevel invariants] + +vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails +vanillaSkolemTvUnk = SkolemTv unkSkol topTcLevel False + +instance Outputable TcTyVarDetails where + ppr = pprTcTyVarDetails + +pprTcTyVarDetails :: TcTyVarDetails -> SDoc +-- For debugging +pprTcTyVarDetails (RuntimeUnk {}) = text "rt" +pprTcTyVarDetails (SkolemTv _sk lvl True) = text "ssk" <> colon <> ppr lvl +pprTcTyVarDetails (SkolemTv _sk lvl False) = text "sk" <> colon <> ppr lvl +pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) + = ppr info <> colon <> ppr tclvl + +----------------------------- +data MetaDetails + = Flexi -- Flexi type variables unify to become Indirects + | Indirect TcType + +-- | What restrictions are on this metavariable around unification? +-- These are checked in GHC.Tc.Utils.Unify.checkTopShape +data MetaInfo + = TauTv -- ^ This MetaTv is an ordinary unification variable + -- A TauTv is always filled in with a tau-type, which + -- never contains any ForAlls. + + | TyVarTv -- ^ A variant of TauTv, except that it should not be + -- unified with a type, only with a type variable + -- See Note [TyVarTv] in GHC.Tc.Utils.TcMType + + | RuntimeUnkTv -- ^ A unification variable used in the GHCi debugger. + -- It /is/ allowed to unify with a polytype, unlike TauTv + + | CycleBreakerTv -- ^ Used to fix occurs-check problems in Givens + -- See Note [Type equality cycles] in + -- GHC.Tc.Solver.Equality + + | ConcreteTv ConcreteTvOrigin + -- ^ A unification variable that can only be unified + -- with a concrete type, in the sense of + -- Note [Concrete types] in GHC.Tc.Utils.Concrete. + -- See Note [ConcreteTv] in GHC.Tc.Utils.Concrete. + -- See also Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete + -- for an overview of how this works in context. + +instance Outputable MetaDetails where + ppr Flexi = text "Flexi" + ppr (Indirect ty) = text "Indirect" <+> ppr ty + +instance Outputable MetaInfo where + ppr TauTv = text "tau" + ppr TyVarTv = text "tyv" + ppr RuntimeUnkTv = text "rutv" + ppr CycleBreakerTv = text "cbv" + ppr (ConcreteTv {}) = text "conc" + +-- | What caused us to create a 'ConcreteTv' metavariable? +-- See Note [ConcreteTv] in GHC.Tc.Utils.Concrete. +data ConcreteTvOrigin + -- | A 'ConcreteTv' used to enforce the representation-polymorphism invariants. + -- + -- See 'FixedRuntimeRepOrigin' for more information. + = ConcreteFRR FixedRuntimeRepOrigin + +-- | A mapping from skolem type variable 'Name' to concreteness information, +-- +-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete. +type ConcreteTyVars = NameEnv ConcreteTvOrigin +-- | The 'Id' has no outer forall'd type variables which must be instantiated +-- to concrete types. +noConcreteTyVars :: ConcreteTyVars +noConcreteTyVars = emptyNameEnv + +{- ********************************************************************* +* * + Untouchable type variables +* * +********************************************************************* -} + +data TcLevel = TcLevel {-# UNPACK #-} !Int + | QLInstVar + -- See Note [TcLevel invariants] for what this Int is + -- See also Note [TcLevel assignment] + -- See also Note [The QLInstVar TcLevel] + +{- +Note [TcLevel invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +* Each unification variable (MetaTv) + and skolem (SkolemTv) + and each Implication + has a level number (of type TcLevel) + +* INVARIANT (KindInv) Given a type variable (tv::ki) at at level L, + the free vars of `ki` all have level <= L + +* INVARIANTS. In a tree of Implications, + + (ImplicInv) The level number (ic_tclvl) of an Implication is + STRICTLY GREATER THAN that of its parent + + (SkolInv) The level number of the skolems (ic_skols) of an + Implication is equal to the level of the implication + itself (ic_tclvl) + + (GivenInv) The level number of a unification variable appearing + in the 'ic_given' of an implication I should be + STRICTLY LESS THAN the ic_tclvl of I + See Note [GivenInv] + + (WantedInv) The level number of a unification variable appearing + in the 'ic_wanted' of an implication I should be + LESS THAN OR EQUAL TO the ic_tclvl of I + See Note [WantedInv] + +The level of a MetaTyVar also governs its untouchability. See +Note [Unification preconditions] in GHC.Tc.Utils.Unify. + + -- See also Note [The QLInstVar TcLevel] + +Note [TcLevel assignment] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We arrange the TcLevels like this + + 0 Top level + 1 First-level implication constraints + 2 Second-level implication constraints + ...etc... + QLInstVar The level for QuickLook instantiation variables + See Note [The QLInstVar TcLevel] + +Note [The QLInstVar TcLevel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +QuickLook instantiation variables are identified by having a TcLevel +of QLInstVar. See Note [Quick Look overview] in GHC.Tc.Gen.App. + +The QLInstVar level behaves like infinity: it is greater than any +other TcLevel. See `strictlyDeeperThan` and friends in this module. +That ensures that we never unify an ordinary unification variable +with a QL instantiation variable, e.g. + alpha[tau:3] := Maybe beta[tau:qlinstvar] +(This is an immediate consequence of our general rule that we never +unify a variable with a type mentioning deeper variables; the skolem +escape check.) + +QL instantation variables are eventually turned into ordinary unificaiton +variables; see (QL3) in Note [Quick Look overview]. + +Note [GivenInv] +~~~~~~~~~~~~~~~ +Invariant (GivenInv) is not essential, but it is easy to guarantee, and +it is a useful extra piece of structure. It ensures that the Givens of +an implication don't change because of unifications /at the same level/ +caused by Wanteds. (Wanteds can also cause unifications at an outer +level, but that will iterate the entire implication; see GHC.Tc.Solver.Monad +Note [The Unification Level Flag].) + +Givens can certainly contain meta-tyvars from /outer/ levels. E.g. + data T a where + MkT :: Eq a => a -> MkT a + + f x = case x of MkT y -> y && True + +Then we'll infer (x :: T alpha[1]). The Givens from the implication +arising from the pattern match will look like this: + + forall[2] . Eq alpha[1] => (alpha[1] ~ Bool) + +But if we unify alpha (which in this case we will), we'll iterate +the entire implication via Note [The Unification Level Flag] in +GHC.Tc.Solver.Monad. That isn't true of unifications at the /ambient/ +level. + +It would be entirely possible to weaken (GivenInv), to LESS THAN OR +EQUAL TO, but we'd need to think carefully about + - kick-out for Givens + - GHC.Tc.Solver.Monad.isOuterTyVar +But in fact (GivenInv) is automatically true, so we're adhering to +it for now. See #18929. + +* If a tyvar tv has level n, then the levels of all variables free + in tv's kind are <= n. Consequence: if tv is untouchable, so are + all variables in tv's kind. + +Note [WantedInv] +~~~~~~~~~~~~~~~~ +Why is WantedInv important? Consider this implication, where +the constraint (C alpha[3]) disobeys WantedInv: + + forall[2] a. blah => (C alpha[3]) + (forall[3] b. alpha[3] ~ b) + +We can unify alpha:=b in the inner implication, because 'alpha' is +touchable; but then 'b' has escaped its scope into the outer implication. +-} + +maxTcLevel :: TcLevel -> TcLevel -> TcLevel +maxTcLevel (TcLevel a) (TcLevel b) + | a > b = TcLevel a + | otherwise = TcLevel b +maxTcLevel _ _ = QLInstVar + +minTcLevel :: TcLevel -> TcLevel -> TcLevel +minTcLevel tcla@(TcLevel a) tclb@(TcLevel b) + | a < b = tcla + | otherwise = tclb +minTcLevel tcla@(TcLevel {}) QLInstVar = tcla +minTcLevel QLInstVar tclb@(TcLevel {}) = tclb +minTcLevel QLInstVar QLInstVar = QLInstVar + +topTcLevel :: TcLevel +-- See Note [TcLevel assignment] +topTcLevel = TcLevel 0 -- 0 = outermost level + +isTopTcLevel :: TcLevel -> Bool +isTopTcLevel (TcLevel 0) = True +isTopTcLevel _ = False + +pushTcLevel :: TcLevel -> TcLevel +-- See Note [TcLevel assignment] +pushTcLevel (TcLevel us) = TcLevel (us + 1) +pushTcLevel QLInstVar = QLInstVar + +strictlyDeeperThan :: TcLevel -> TcLevel -> Bool +-- See Note [The QLInstVar TcLevel] +strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl) + = tv_tclvl > ctxt_tclvl +strictlyDeeperThan QLInstVar (TcLevel {}) = True +strictlyDeeperThan _ _ = False + +deeperThanOrSame :: TcLevel -> TcLevel -> Bool +-- See Note [The QLInstVar TcLevel] +deeperThanOrSame (TcLevel tv_tclvl) (TcLevel ctxt_tclvl) + = tv_tclvl >= ctxt_tclvl +deeperThanOrSame (TcLevel {}) QLInstVar = False +deeperThanOrSame QLInstVar _ = True + +sameDepthAs :: TcLevel -> TcLevel -> Bool +sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) + = ctxt_tclvl == tv_tclvl + -- NB: invariant ctxt_tclvl >= tv_tclvl + -- So <= would be equivalent +sameDepthAs QLInstVar QLInstVar = True +sameDepthAs _ _ = False + +checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool +-- Checks (WantedInv) from Note [TcLevel invariants] +checkTcLevelInvariant ctxt_tclvl tv_tclvl + = ctxt_tclvl `deeperThanOrSame` tv_tclvl + +-- Returns topTcLevel for non-TcTyVars +tcTyVarLevel :: TcTyVar -> TcLevel +tcTyVarLevel tv + = case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl + SkolemTv _ tv_lvl _ -> tv_lvl + RuntimeUnk -> topTcLevel + + +tcTypeLevel :: TcType -> TcLevel +-- Max level of any free var of the type +tcTypeLevel ty + = nonDetStrictFoldDVarSet add topTcLevel (tyCoVarsOfTypeDSet ty) + -- It's safe to use a non-deterministic fold because `maxTcLevel` is + -- commutative. + where + add v lvl + | isTcTyVar v = lvl `maxTcLevel` tcTyVarLevel v + | otherwise = lvl + +instance Outputable TcLevel where + ppr (TcLevel n) = ppr n + ppr QLInstVar = text "qlinst" + +{- ********************************************************************* +* * + Finding type family instances +* * +************************************************************************ +-} + +-- | Finds outermost type-family applications occurring in a type, +-- after expanding synonyms. In the list (F, tys) that is returned +-- we guarantee that tys matches F's arity. For example, given +-- type family F a :: * -> * (arity 1) +-- calling tcTyFamInsts on (Maybe (F Int Bool) will return +-- (F, [Int]), not (F, [Int,Bool]) +-- +-- This is important for its use in deciding termination of type +-- instances (see #11581). E.g. +-- type instance G [Int] = ...(F Int \)... +-- we don't need to take \ into account when asking if +-- the calls on the RHS are smaller than the LHS +tcTyFamInsts :: Type -> [(TyCon, [Type])] +tcTyFamInsts = map (\(_,b,c) -> (b,c)) . tcTyFamInstsAndVis + +-- | Like 'tcTyFamInsts', except that the output records whether the +-- type family and its arguments occur as an /invisible/ argument in +-- some type application. This information is useful because it helps GHC know +-- when to turn on @-fprint-explicit-kinds@ during error reporting so that +-- users can actually see the type family being mentioned. +-- +-- As an example, consider: +-- +-- @ +-- class C a +-- data T (a :: k) +-- type family F a :: k +-- instance C (T @(F Int) (F Bool)) +-- @ +-- +-- There are two occurrences of the type family `F` in that `C` instance, so +-- @'tcTyFamInstsAndVis' (C (T \@(F Int) (F Bool)))@ will return: +-- +-- @ +-- [ ('True', F, [Int]) +-- , ('False', F, [Bool]) ] +-- @ +-- +-- @F Int@ is paired with 'True' since it appears as an /invisible/ argument +-- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a +-- /visible/ argument to @C@. +-- +-- See also Note [Showing invisible bits of types in error messages] +-- in "GHC.Tc.Errors.Ppr". +tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])] +tcTyFamInstsAndVis = tcTyFamInstsAndVisX False + +tcTyFamInstsAndVisX + :: Bool -- ^ Is this an invisible argument to some type application? + -> Type -> [(Bool, TyCon, [Type])] +tcTyFamInstsAndVisX = go + where + go is_invis_arg ty + | Just exp_ty <- coreView ty = go is_invis_arg exp_ty + go _ (TyVarTy _) = [] + go is_invis_arg (TyConApp tc tys) + | isTypeFamilyTyCon tc + = [(is_invis_arg, tc, take (tyConArity tc) tys)] + | otherwise + = tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys + go _ (LitTy {}) = [] + go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr) + ++ go is_invis_arg ty + go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg w + ++ go is_invis_arg ty1 + ++ go is_invis_arg ty2 + go is_invis_arg ty@(AppTy _ _) = + let (ty_head, ty_args) = splitAppTys ty + ty_arg_flags = appTyForAllTyFlags ty_head ty_args + in go is_invis_arg ty_head + ++ concat (zipWith (\flag -> go (isInvisibleForAllTyFlag flag)) + ty_arg_flags ty_args) + go is_invis_arg (CastTy ty _) = go is_invis_arg ty + go _ (CoercionTy _) = [] -- don't count tyfams in coercions, + -- as they never get normalized, + -- anyway + +-- | In an application of a 'TyCon' to some arguments, find the outermost +-- occurrences of type family applications within the arguments. This function +-- will not consider the 'TyCon' itself when checking for type family +-- applications. +-- +-- See 'tcTyFamInstsAndVis' for more details on how this works (as this +-- function is called inside of 'tcTyFamInstsAndVis'). +tcTyConAppTyFamInstsAndVis :: TyCon -> [Type] -> [(Bool, TyCon, [Type])] +tcTyConAppTyFamInstsAndVis = tcTyConAppTyFamInstsAndVisX False + +tcTyConAppTyFamInstsAndVisX + :: Bool -- ^ Is this an invisible argument to some type application? + -> TyCon -> [Type] -> [(Bool, TyCon, [Type])] +tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys = + let (invis_tys, vis_tys) = partitionInvisibleTypes tc tys + in concat $ map (tcTyFamInstsAndVisX True) invis_tys + ++ map (tcTyFamInstsAndVisX is_invis_arg) vis_tys + +isTyFamFree :: Type -> Bool +-- ^ Check that a type does not contain any type family applications. +isTyFamFree = null . tcTyFamInsts + +type UnderFam = Bool -- True <=> we are in the argument of a type family application + +any_rewritable :: EqRel -- Ambient role + -> (UnderFam -> EqRel -> TcTyVar -> Bool) -- Check tyvar + -> (UnderFam -> EqRel -> TyCon -> [TcType] -> Bool) -- Check type family application + -> TcType -> Bool +-- Checks every tyvar and tyconapp (not including FunTys) within a type, +-- ORing the results of the predicates above together +-- Do not look inside casts and coercions +-- See Note [anyRewritableTyVar must be role-aware] +-- +-- This looks like it should use foldTyCo, but that function is +-- role-agnostic, and this one must be role-aware. We could make +-- foldTyCon role-aware, but that may slow down more common usages. +-- +-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. +{-# INLINE any_rewritable #-} -- this allows specialization of predicates +any_rewritable role tv_pred tc_pred ty + = go False emptyVarSet role ty + where + go_tv uf bvs rl tv | tv `elemVarSet` bvs = False + | otherwise = tv_pred uf rl tv + + go :: UnderFam -> VarSet -> EqRel -> TcType -> Bool + go under_fam bvs rl (TyConApp tc tys) + + -- Expand synonyms, unless (a) we are at Nominal role and (b) the synonym + -- is type-family-free; then it suffices just to look at the args + | isTypeSynonymTyCon tc + , case rl of { NomEq -> not (isFamFreeTyCon tc); ReprEq -> True } + , Just ty' <- expandSynTyConApp_maybe tc tys + = go under_fam bvs rl ty' + + -- Check if we are going under a type family application + | case rl of + NomEq -> isTypeFamilyTyCon tc + ReprEq -> isFamilyTyCon tc + = if | tc_pred under_fam rl tc tys -> True + | otherwise -> go_fam under_fam (tyConArity tc) bvs tys + + | otherwise + = go_tc under_fam bvs rl tc tys + + go uf bvs rl (TyVarTy tv) = go_tv uf bvs rl tv + go _ _ _ (LitTy {}) = False + go uf bvs rl (AppTy fun arg) = go uf bvs rl fun || go uf bvs NomEq arg + go uf bvs rl (FunTy _ w arg res) = go uf bvs NomEq arg_rep || go uf bvs NomEq res_rep || + go uf bvs rl arg || go uf bvs rl res || go uf bvs NomEq w + where arg_rep = getRuntimeRep arg -- forgetting these causes #17024 + res_rep = getRuntimeRep res + go uf bvs rl (ForAllTy tv ty) = go uf (bvs `extendVarSet` binderVar tv) rl ty + go uf bvs rl (CastTy ty _) = go uf bvs rl ty + go _ _ _ (CoercionTy _) = False + + go_tc :: UnderFam -> VarSet -> EqRel -> TyCon -> [TcType] -> Bool + go_tc uf bvs NomEq _ tys = any (go uf bvs NomEq) tys + go_tc uf bvs ReprEq tc tys = any2 (go_arg uf bvs) tys (tyConRoleListRepresentational tc) + + go_arg uf bvs ty Nominal = go uf bvs NomEq ty + go_arg uf bvs ty Representational = go uf bvs ReprEq ty + go_arg _ _ _ Phantom = False -- We never rewrite with phantoms + + -- For a type-family or data-family application (F t1 .. tn), all arguments + -- have Nominal role (whether in F's arity or, if over-saturated, beyond it) + -- Switch on under_fam for arguments <= arity + go_fam uf 0 bvs tys = any (go uf bvs NomEq) tys -- Like AppTy + go_fam _ _ _ [] = False + go_fam uf n bvs (ty:tys) = go True bvs NomEq ty || go_fam uf (n-1) bvs tys + -- True <=> switch on under_fam + +anyRewritableTyVar :: EqRel -- Ambient role + -> (UnderFam -> EqRel -> TcTyVar -> Bool) -- check tyvar + -> TcType -> Bool +-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. +anyRewritableTyVar role check_tv + = any_rewritable role + check_tv + (\ _ _ _ _ -> False) -- No special check for tyconapps + -- (this False is ORed with other results, + -- so it really means "do nothing special"; + -- the arguments are still inspected) + +anyRewritableTyFamApp :: EqRel -- Ambient role + -> (UnderFam -> EqRel -> TyCon -> [TcType] -> Bool) + -- Check a type-family application + -> TcType -> Bool + -- always ignores casts & coercions +-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. +anyRewritableTyFamApp role check_tyconapp + = any_rewritable role (\ _ _ _ -> False) check_tyconapp + +{- Note [anyRewritableTyVar must be role-aware] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +anyRewritableTyVar is used during kick-out from the inert set, +to decide if, given a new equality (a ~ ty), we should kick out +a constraint C. Rather than gather free variables and see if 'a' +is among them, we instead pass in a predicate; this is just efficiency. + +Moreover, consider + work item: [G] a ~R f b + inert item: [G] b ~R f a +We use anyRewritableTyVar to decide whether to kick out the inert item, +on the grounds that the work item might rewrite it. Well, 'a' is certainly +free in [G] b ~R f a. But because the role of a type variable ('f' in +this case) is nominal, the work item can't actually rewrite the inert item. +Moreover, if we were to kick out the inert item the exact same situation +would re-occur and we end up with an infinite loop in which each kicks +out the other (#14363). + +-} + +{- ********************************************************************* +* * + The "exact" free variables of a type +* * +********************************************************************* -} + +{- Note [Silly type synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type T a = Int +What are the free tyvars of (T x)? Empty, of course! + +exactTyCoVarsOfType is used by the type checker to figure out exactly +which type variables are mentioned in a type. It only matters +occasionally -- see the calls to exactTyCoVarsOfType. + +We place this function here in GHC.Tc.Utils.TcType, not in GHC.Core.TyCo.FVs, +because we want to "see" coreView (efficiency issue only). +-} + +exactTyCoVarsOfType :: Type -> TyCoVarSet +exactTyCoVarsOfTypes :: [Type] -> TyCoVarSet +-- Find the free type variables (of any kind) +-- but *expand* type synonyms. See Note [Silly type synonym] above. + +exactTyCoVarsOfType ty = runTyCoVars (exact_ty ty) +exactTyCoVarsOfTypes tys = runTyCoVars (exact_tys tys) + +exact_ty :: Type -> Endo TyCoVarSet +exact_tys :: [Type] -> Endo TyCoVarSet +(exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder emptyVarSet + +exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +exactTcvFolder = deepTcvFolder { tcf_view = coreView } + -- This is the key line + +{- +************************************************************************ +* * + Predicates +* * +************************************************************************ +-} + +tcIsTcTyVar :: TcTyVar -> Bool +-- See Note [TcTyVars and TyVars in the typechecker] +tcIsTcTyVar tv = isTyVar tv + +isPromotableMetaTyVar :: TcTyVar -> Bool +-- True is this is a meta-tyvar that can be +-- promoted to an outer level +isPromotableMetaTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + , MetaTv { mtv_info = info } <- tcTyVarDetails tv + = isTouchableInfo info -- Can't promote cycle breakers + | otherwise + = False + +isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool +isTouchableMetaTyVar ctxt_tclvl tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv + , isTouchableInfo info + = assertPpr (checkTcLevelInvariant ctxt_tclvl tv_tclvl) + (ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl) $ + tv_tclvl `sameDepthAs` ctxt_tclvl + + | otherwise = False + +isImmutableTyVar :: TyVar -> Bool +isImmutableTyVar tv = isSkolemTyVar tv + +isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, + isMetaTyVar, isAmbiguousTyVar, isCycleBreakerTyVar :: TcTyVar -> Bool + +isTyConableTyVar tv + -- True of a meta-type variable that can be filled in + -- with a type constructor application; in particular, + -- not a TyVarTv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + MetaTv { mtv_info = TyVarTv } -> False + _ -> True + | otherwise = True + +isSkolemTyVar tv + = assertPpr (tcIsTcTyVar tv) (ppr tv) $ + case tcTyVarDetails tv of + MetaTv {} -> False + _other -> True + +skolemSkolInfo :: TcTyVar -> SkolemInfo +skolemSkolInfo tv + = assert (isSkolemTyVar tv) $ + case tcTyVarDetails tv of + SkolemTv skol_info _ _ -> skol_info + RuntimeUnk -> panic "RuntimeUnk" + MetaTv {} -> panic "skolemSkolInfo" + + +isOverlappableTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + SkolemTv _ _ overlappable -> overlappable + _ -> False + | otherwise = False + +isMetaTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + MetaTv {} -> True + _ -> False + | otherwise = False + +-- isAmbiguousTyVar is used only when reporting type errors +-- It picks out variables that are unbound, namely meta +-- type variables and the RuntimeUnk variables created by +-- GHC.Runtime.Heap.Inspect.zonkRTTIType. These are "ambiguous" in +-- the sense that they stand for an as-yet-unknown type +isAmbiguousTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + MetaTv {} -> True + RuntimeUnk {} -> True + _ -> False + | otherwise = False + +isQLInstTyVar :: TcTyVar -> Bool +isQLInstTyVar tv + = case tcTyVarDetails tv of + MetaTv { mtv_tclvl = QLInstVar } -> True + _ -> False + +isRuntimeUnkTyVar :: TcTyVar -> Bool +isRuntimeUnkTyVar tv + = case tcTyVarDetails tv of + MetaTv { mtv_info = RuntimeUnkTv } -> True + _ -> False + +isCycleBreakerTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + , MetaTv { mtv_info = CycleBreakerTv } <- tcTyVarDetails tv + = True + + | otherwise + = False + +-- | Is this type variable a concrete type variable, i.e. +-- it is a metavariable with 'ConcreteTv' 'MetaInfo'? +-- +-- Returns the 'ConcreteTvOrigin' stored in the type variable +-- if so, or 'Nothing' otherwise. +isConcreteTyVar_maybe :: TcTyVar -> Maybe ConcreteTvOrigin +isConcreteTyVar_maybe tv + | isTcTyVar tv + , MetaTv { mtv_info = ConcreteTv conc_orig } <- tcTyVarDetails tv + = Just conc_orig + | otherwise + = Nothing + +concreteInfo_maybe :: MetaInfo -> Maybe ConcreteTvOrigin +concreteInfo_maybe (ConcreteTv conc_orig) = Just conc_orig +concreteInfo_maybe _ = Nothing + +-- | Is this type variable a concrete type variable, i.e. +-- it is a metavariable with 'ConcreteTv' 'MetaInfo'? +isConcreteTyVar :: TcTyVar -> Bool +isConcreteTyVar = isJust . isConcreteTyVar_maybe + +-- | Is this type concrete type variable, i.e. +-- a metavariable with 'ConcreteTv' 'MetaInfo'? +isConcreteTyVarTy :: TcType -> Bool +isConcreteTyVarTy = isJust . isConcreteTyVarTy_maybe + +-- | Is this type a concrete type variable? If so, return +-- the associated 'TcTyVar' and 'ConcreteTvOrigin'. +isConcreteTyVarTy_maybe :: TcType -> Maybe (TcTyVar, ConcreteTvOrigin) +isConcreteTyVarTy_maybe (TyVarTy tv) = (tv, ) <$> isConcreteTyVar_maybe tv +isConcreteTyVarTy_maybe _ = Nothing + +isMetaTyVarTy :: TcType -> Bool +isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv +isMetaTyVarTy _ = False + +metaTyVarInfo :: TcTyVar -> MetaInfo +metaTyVarInfo tv + = case tcTyVarDetails tv of + MetaTv { mtv_info = info } -> info + _ -> pprPanic "metaTyVarInfo" (ppr tv) + +isTouchableInfo :: MetaInfo -> Bool +isTouchableInfo info + | CycleBreakerTv <- info = False + | otherwise = True + +metaTyVarTcLevel :: TcTyVar -> TcLevel +metaTyVarTcLevel tv + = case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tclvl } -> tclvl + _ -> pprPanic "metaTyVarTcLevel" (ppr tv) + +metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel +metaTyVarTcLevel_maybe tv + = case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tclvl } -> Just tclvl + _ -> Nothing + +metaTyVarRef :: TyVar -> IORef MetaDetails +metaTyVarRef tv + = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } -> ref + _ -> pprPanic "metaTyVarRef" (ppr tv) + +setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar +setMetaTyVarTcLevel tv tclvl + = case tcTyVarDetails tv of + details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl }) + _ -> pprPanic "metaTyVarTcLevel" (ppr tv) + +isTyVarTyVar :: Var -> Bool +isTyVarTyVar tv + = case tcTyVarDetails tv of + MetaTv { mtv_info = TyVarTv } -> True + _ -> False + +isFlexi, isIndirect :: MetaDetails -> Bool +isFlexi Flexi = True +isFlexi _ = False + +isIndirect (Indirect _) = True +isIndirect _ = False + +isRuntimeUnkSkol :: TyVar -> Bool +-- Called only in GHC.Tc.Errors; see Note [Runtime skolems] there +isRuntimeUnkSkol x + | RuntimeUnk <- tcTyVarDetails x = True + | otherwise = False + +mkTyVarNamePairs :: [TyVar] -> [(Name,TyVar)] +-- Just pair each TyVar with its own name +mkTyVarNamePairs tvs = [(tyVarName tv, tv) | tv <- tvs] + +findDupTyVarTvs :: [(Name,TcTyVar)] -> [(Name,Name)] +-- If we have [...(x1,tv)...(x2,tv)...] +-- return (x1,x2) in the result list +findDupTyVarTvs prs + = concatMap mk_result_prs $ + findDupsEq eq_snd prs + where + eq_snd (_,tv1) (_,tv2) = tv1 == tv2 + mk_result_prs ((n1,_) :| xs) = map (\(n2,_) -> (n1,n2)) xs + +-- | Returns the (kind, type) variables in a type that are +-- as-yet-unknown: metavariables and RuntimeUnks +ambigTkvsOfTy :: TcType -> ([Var],[Var]) +ambigTkvsOfTy ty + = partition (`elemVarSet` dep_tkv_set) ambig_tkvs + where + tkvs = tyCoVarsOfTypeList ty + ambig_tkvs = filter isAmbiguousTyVar tkvs + dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) + +{- +************************************************************************ +* * + Tau, sigma and rho +* * +************************************************************************ +-} + +-- | Make a sigma ty where all type variables are 'Inferred'. That is, +-- they cannot be used with visible type application. +mkInfSigmaTy :: HasDebugCallStack => [TyCoVar] -> [PredType] -> Type -> Type +mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkForAllTyBinders Inferred tyvars) theta ty + +-- | Make a sigma ty where all type variables are "specified". That is, +-- they can be used with visible type application +mkSpecSigmaTy :: HasDebugCallStack => [TyVar] -> [PredType] -> Type -> Type +mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkForAllTyBinders Specified tyvars) preds ty + +mkSigmaTy :: HasDebugCallStack => [ForAllTyBinder] -> [PredType] -> Type -> Type +-- Result is TypeLike +mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) + +tcMkDFunSigmaTy :: [TyVar] -> ThetaType -> Type -> Type +tcMkDFunSigmaTy tvs theta res_ty + = mkForAllTys (mkForAllTyBinders Specified tvs) $ + tcMkDFunPhiTy theta res_ty + +mkPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type +-- Result type is TypeLike +mkPhiTy = mkInvisFunTys + +tcMkPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type +-- Like mkPhiTy, but with no assertion checks; it is called +-- by the type checker and the result kind may not be zonked yet +-- But the result kind is TypeLike +tcMkPhiTy tys ty = foldr (tcMkInvisFunTy TypeLike) ty tys + +tcMkDFunPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type +-- Just like tcMkPhiTy, but result type is ConstraintLike +tcMkDFunPhiTy preds res = foldr (tcMkInvisFunTy ConstraintLike) res preds + +--------------- +getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to + -- construct a dictionary function name +getDFunTyKey ty | Just ty' <- coreView ty = getDFunTyKey ty' +getDFunTyKey (TyVarTy tv) = getOccName tv +getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (LitTy x) = getDFunTyLitKey x +getDFunTyKey (AppTy fun _) = getDFunTyKey fun +getDFunTyKey (FunTy { ft_af = af }) = getOccName (funTyFlagTyCon af) +getDFunTyKey (ForAllTy _ t) = getDFunTyKey t +getDFunTyKey (CastTy ty _) = getDFunTyKey ty +getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) + +getDFunTyLitKey :: TyLit -> OccName +getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) +getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm +getDFunTyLitKey (CharTyLit n) = mkOccName Name.varName (show n) + +{- +************************************************************************ +* * + Expanding and splitting +* * +************************************************************************ +-} + +-- | Splits a forall type into a list of 'PiTyVarBinder's and the inner type. +-- Always succeeds, even if it returns an empty list. +tcSplitPiTys :: Type -> ([PiTyVarBinder], Type) +tcSplitPiTys ty + = assert (all isTyBinder (fst sty)) -- No CoVar binders here + sty + where sty = splitPiTys ty + +-- | Splits a type into a PiTyVarBinder and a body, if possible. +tcSplitPiTy_maybe :: Type -> Maybe (PiTyVarBinder, Type) +tcSplitPiTy_maybe ty + = assert (isMaybeTyBinder sty) -- No CoVar binders here + sty + where + sty = splitPiTy_maybe ty + isMaybeTyBinder (Just (t,_)) = isTyBinder t + isMaybeTyBinder _ = True + +tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type) +tcSplitForAllTyVarBinder_maybe ty | Just ty' <- coreView ty = tcSplitForAllTyVarBinder_maybe ty' +tcSplitForAllTyVarBinder_maybe (ForAllTy tv ty) = assert (isTyVarBinder tv ) Just (tv, ty) +tcSplitForAllTyVarBinder_maybe _ = Nothing + +-- | Like 'tcSplitPiTys', but splits off only named binders, +-- returning just the tyvars. +tcSplitForAllTyVars :: Type -> ([TyVar], Type) +tcSplitForAllTyVars ty + = assert (all isTyVar (fst sty)) sty + where sty = splitForAllTyCoVars ty + +-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' +-- type variable binders. +tcSplitForAllInvisTyVars :: Type -> ([TyVar], Type) +tcSplitForAllInvisTyVars ty = tcSplitSomeForAllTyVars isInvisibleForAllTyFlag ty + +-- | Like 'tcSplitForAllTyVars', but only splits a 'ForAllTy' if @argf_pred argf@ +-- is 'True', where @argf@ is the visibility of the @ForAllTy@'s binder and +-- @argf_pred@ is a predicate over visibilities provided as an argument to this +-- function. +tcSplitSomeForAllTyVars :: (ForAllTyFlag -> Bool) -> Type -> ([TyVar], Type) +tcSplitSomeForAllTyVars argf_pred ty + = split ty ty [] + where + split _ (ForAllTy (Bndr tv argf) ty) tvs + | argf_pred argf = split ty ty (tv:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +tcSplitForAllTyVarsReqTVBindersN :: Arity -> Type -> (Arity, [ForAllTyBinder], Type) +-- Split off at most N /required/ (aka visible) binders, plus any invisible ones +-- in the way, /and/ any trailing invisible ones +tcSplitForAllTyVarsReqTVBindersN n_req ty + = split n_req ty ty [] + where + split n_req _orig_ty (ForAllTy b@(Bndr _ argf) ty) bs + | isVisibleForAllTyFlag argf, n_req > 0 -- Split off a visible forall + = split (n_req - 1) ty ty (b:bs) + | isInvisibleForAllTyFlag argf -- Split off an invisible forall, + = split n_req ty ty (b:bs) -- even if n_req=0, i.e. the trailing ones + split n_req orig_ty ty bs | Just ty' <- coreView ty = split n_req orig_ty ty' bs + split n_req orig_ty _ty bs = (n_req, reverse bs, orig_ty) + +-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type +-- variable binders. All split tyvars are annotated with '()'. +tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type) +tcSplitForAllReqTVBinders ty = assert (all isTyVarBinder (fst sty) ) sty + where sty = splitForAllReqTyBinders ty + +-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' type +-- variable binders. All split tyvars are annotated with their 'Specificity'. +tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type) +tcSplitForAllInvisTVBinders ty = assert (all (isTyVar . binderVar) (fst sty)) sty + where sty = splitForAllInvisTyBinders ty + +-- | Like 'tcSplitForAllTyVars', but splits off only named binders. +tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type) +tcSplitForAllTyVarBinders ty = assert (all isTyVarBinder (fst sty)) sty + where sty = splitForAllForAllTyBinders ty + +tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) +-- Split off the first predicate argument from a type +tcSplitPredFunTy_maybe ty + | Just ty' <- coreView ty = tcSplitPredFunTy_maybe ty' +tcSplitPredFunTy_maybe (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + | isInvisibleFunArg af + = Just (arg, res) +tcSplitPredFunTy_maybe _ + = Nothing + +tcSplitPhiTy :: Type -> (ThetaType, Type) +tcSplitPhiTy ty + = split ty [] + where + split ty ts + = case tcSplitPredFunTy_maybe ty of + Just (pred, ty) -> split ty (pred:ts) + Nothing -> (reverse ts, ty) + +-- | Split a sigma type into its parts. This only splits /invisible/ type +-- variable binders, as these are the only forms of binder that the typechecker +-- will implicitly instantiate. +tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) +tcSplitSigmaTy ty = case tcSplitForAllInvisTyVars ty of + (tvs, rho) -> case tcSplitPhiTy rho of + (theta, tau) -> (tvs, theta, tau) + +tcSplitSigmaTyBndrs :: Type -> ([TcInvisTVBinder], ThetaType, Type) +tcSplitSigmaTyBndrs ty = case tcSplitForAllInvisTVBinders ty of + (tvs, rho) -> case tcSplitPhiTy rho of + (theta, tau) -> (tvs, theta, tau) + +-- | Split a sigma type into its parts, going underneath as many arrows +-- and foralls as possible. See Note [tcSplitNestedSigmaTys] +tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type) +-- See Note [tcSplitNestedSigmaTys] +-- NB: This is basically a pure version of deeplyInstantiate (from Unify) that +-- doesn't compute an HsWrapper. +tcSplitNestedSigmaTys ty + -- If there's a forall, split it apart and try splitting the rho type + -- underneath it. + | (arg_tys, body_ty) <- tcSplitFunTys ty + , (tvs1, theta1, rho1) <- tcSplitSigmaTy body_ty + , not (null tvs1 && null theta1) + = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1 + in (tvs1 ++ tvs2, theta1 ++ theta2, mkScaledFunTys arg_tys rho2) + + -- If there's no forall, we're done. + | otherwise = ([], [], ty) + +{- Note [tcSplitNestedSigmaTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcSplitNestedSigmaTys splits out all the /nested/ foralls and constraints, +including under function arrows. E.g. given this type synonym: + type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t + +then + tcSplitNestedSigmaTys (forall s t a b. C s t a b => Int -> Traversal s t a b) + +will return + ( [s,t,a,b,f] + , [C s t a b, Applicative f] + , Int -> (a -> f b) -> s -> f t)@. + +This function is used in these places: +* Improving error messages in GHC.Tc.Gen.Head.addFunResCtxt +* Validity checking for default methods: GHC.Tc.TyCl.checkValidClass +* A couple of calls in the GHCi debugger: GHC.Runtime.Heap.Inspect + +In other words, just in validity checking and error messages; hence +no wrappers or evidence generation. + +Notice that tcSplitNestedSigmaTys even looks under function arrows; +doing so is the Right Thing even with simple subsumption, not just +with deep subsumption. +-} + +----------------------- +tcTyConAppTyCon :: Type -> TyCon +tcTyConAppTyCon ty + = case tcTyConAppTyCon_maybe ty of + Just tc -> tc + Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty) + +-- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'. +tcTyConAppTyCon_maybe :: Type -> Maybe TyCon +tcTyConAppTyCon_maybe ty | Just ty' <- coreView ty = tcTyConAppTyCon_maybe ty' +tcTyConAppTyCon_maybe (TyConApp tc _) = Just tc +tcTyConAppTyCon_maybe (FunTy { ft_af = af }) = Just (funTyFlagTyCon af) +tcTyConAppTyCon_maybe _ = Nothing + +tcTyConAppArgs :: Type -> [Type] +tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of + Just (_, args) -> args + Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) + +----------------------- +tcSplitFunTys :: Type -> ([Scaled Type], Type) +tcSplitFunTys ty = case tcSplitFunTy_maybe ty of + Nothing -> ([], ty) + Just (arg,res) -> (arg:args, res') + where + (args,res') = tcSplitFunTys res + +tcSplitFunTy_maybe :: Type -> Maybe (Scaled Type, Type) +-- Only splits function (->) and (-=>), not (=>) or (==>) +tcSplitFunTy_maybe ty + | Just ty' <- coreView ty = tcSplitFunTy_maybe ty' +tcSplitFunTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + | isVisibleFunArg af = Just (Scaled w arg, res) +tcSplitFunTy_maybe _ = Nothing + -- Note the isVisibleFunArg guard + -- Consider (?x::Int) => Bool + -- We don't want to treat this as a function type! + -- A concrete example is test tc230: + -- f :: () -> (?p :: ()) => () -> () + -- + -- g = f () () + +tcSplitFunTysN :: Arity -- n: Number of desired args + -> TcRhoType + -> Either Arity -- Number of missing arrows + ([Scaled TcSigmaType],-- Arg types (always N types) + TcSigmaType) -- The rest of the type +-- ^ Split off exactly the specified number argument types +-- Returns +-- (Left m) if there are 'm' missing arrows in the type +-- (Right (tys,res)) if the type looks like t1 -> ... -> tn -> res +tcSplitFunTysN n ty + | n == 0 + = Right ([], ty) + | Just (arg,res) <- tcSplitFunTy_maybe ty + = case tcSplitFunTysN (n-1) res of + Left m -> Left m + Right (args,body) -> Right (arg:args, body) + | otherwise + = Left n + +tcSplitFunTy :: Type -> (Scaled Type, Type) +tcSplitFunTy ty = expectJust (tcSplitFunTy_maybe ty) + +tcFunArgTy :: Type -> Scaled Type +tcFunArgTy ty = fst (tcSplitFunTy ty) + +tcFunResultTy :: Type -> Type +tcFunResultTy ty = snd (tcSplitFunTy ty) + +-- | Strips off n *visible* arguments and returns the resulting type +tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type +tcFunResultTyN n ty + | Right (_, res_ty) <- tcSplitFunTysN n ty + = res_ty + | otherwise + = pprPanic "tcFunResultTyN" (ppr n <+> ppr ty) + +----------------------- +tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) +tcSplitAppTy_maybe ty | Just ty' <- coreView ty = tcSplitAppTy_maybe ty' +tcSplitAppTy_maybe ty = tcSplitAppTyNoView_maybe ty + +tcSplitAppTy :: Type -> (Type, Type) +tcSplitAppTy ty = case tcSplitAppTy_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "tcSplitAppTy" (pprType ty) + +tcSplitAppTys :: Type -> (Type, [Type]) +tcSplitAppTys ty + = go ty [] + where + go ty args = case tcSplitAppTy_maybe ty of + Just (ty', arg) -> go ty' (arg:args) + Nothing -> (ty,args) + +----------------------- +tcIsTyVarTy :: Type -> Bool +tcIsTyVarTy ty | Just ty' <- coreView ty = tcIsTyVarTy ty' +tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as + -- this is only used for + -- e.g., FlexibleContexts +tcIsTyVarTy (TyVarTy _) = True +tcIsTyVarTy _ = False + +----------------------- +tcSplitQuantPredTy :: Type -> ([TyVar], [Type], PredType) +-- Split up the type of a quantified predicate +-- forall tys, theta => head +-- NB splitFunTys, not tcSplitFunTys; +-- the latter specifically stops at PredTy arguments, +-- and we don't want to do that here +tcSplitQuantPredTy ty + = case tcSplitForAllInvisTyVars ty of { (tvs, rho) -> + case splitFunTys rho of { (theta, head) -> + (tvs, map scaledThing theta, head) }} + +tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) +-- Split the type of a dictionary function +tcSplitDFunTy ty + = case tcSplitQuantPredTy ty of { (tvs, theta, head) -> + case tcSplitDFunHead head of { (clas, tys) -> + (tvs, theta, clas, tys) }} + +tcSplitDFunHead :: Type -> (Class, [Type]) +tcSplitDFunHead = getClassPredTys + +tcSplitMethodTy :: Type -> ([TyVar], PredType, Type) +-- A class method (selector) always has a type like +-- forall as. C as => blah +-- So if the class looks like +-- class C a where +-- op :: forall b. (Eq a, Ix b) => a -> b +-- the class method type looks like +-- op :: forall a. C a => forall b. (Eq a, Ix b) => a -> b +-- +-- tcSplitMethodTy just peels off the outer forall and +-- that first predicate +tcSplitMethodTy ty + | (sel_tyvars,sel_rho) <- tcSplitForAllInvisTyVars ty + , Just (first_pred, local_meth_ty) <- tcSplitPredFunTy_maybe sel_rho + = (sel_tyvars, first_pred, local_meth_ty) + | otherwise + = pprPanic "tcSplitMethodTy" (ppr ty) + + +{- ********************************************************************* +* * + Predicate types +* * +************************************************************************ + +Deconstructors and tests on predicate types + +Note [Kind polymorphic type classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + class C f where... -- C :: forall k. k -> Constraint + g :: forall (f::*). C f => f -> f + +Here the (C f) in the signature is really (C * f), and we +don't want to complain that the * isn't a type variable! +-} + +isTyVarClassPred :: PredType -> Bool +isTyVarClassPred ty = case getClassPredTys_maybe ty of + Just (_, tys) -> all isTyVarTy tys + _ -> False + +------------------------- +checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool +-- If the Bool is True (flexible contexts), return True (i.e. ok) +-- Otherwise, check that the type (not kind) args are all headed by a tyvar +-- E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected +-- This function is here in GHC.Tc.Utils.TcType, rather than in GHC.Tc.Validity, +-- because it is called from GHC.Tc.Solver, which itself is imported by GHC.Tc.Validity +checkValidClsArgs flexible_contexts cls kts + | flexible_contexts = True + | otherwise = all hasTyVarHead tys + where + tys = filterOutInvisibleTypes (classTyCon cls) kts + +hasTyVarHead :: Type -> Bool +-- Returns true of (a t1 .. tn), where 'a' is a type variable +hasTyVarHead ty -- Haskell 98 allows predicates of form + | tcIsTyVarTy ty = True -- C (a ty1 .. tyn) + | otherwise -- where a is a type variable + = case tcSplitAppTy_maybe ty of + Just (ty, _) -> hasTyVarHead ty + Nothing -> False + +evVarPred :: EvVar -> PredType +evVarPred var = varType var + -- Historical note: I used to have an ASSERT here, + -- checking (isPredTy (varType var)). But with something like + -- f :: c => _ -> _ + -- we end up with (c :: kappa), and (kappa ~ Constraint). Until + -- we solve and zonk (which there is no particular reason to do for + -- partial signatures, (isPredTy kappa) will return False. But + -- nothing is wrong. So I just removed the ASSERT. + +--------------------------- +boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type]) +-- Given (t1 ~# t2) or (t1 ~R# t2) return the boxed version +-- (t1 ~ t2) or (t1 `Coercible` t2) +boxEqPred eq_rel ty1 ty2 + = case eq_rel of + NomEq | homo_kind -> Just (eqClass, [k1, ty1, ty2]) + | otherwise -> Just (heqClass, [k1, k2, ty1, ty2]) + ReprEq | homo_kind -> Just (coercibleClass, [k1, ty1, ty2]) + | otherwise -> Nothing -- Sigh: we do not have heterogeneous Coercible + -- so we can't abstract over it + -- Nothing fundamental: we could add it + where + k1 = typeKind ty1 + k2 = typeKind ty2 + homo_kind = k1 `tcEqType` k2 + +pickCapturedPreds + :: TyVarSet -- Quantifying over these + -> TcThetaType -- Proposed constraints to quantify + -> TcThetaType -- A subset that we can actually quantify +-- A simpler version of pickQuantifiablePreds, used to winnow down +-- the inferred constraints of a group of bindings, into those for +-- one particular identifier +pickCapturedPreds qtvs theta + = filter captured theta + where + captured pred = couldBeIPLike pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) + + +-- Superclasses + +type PredWithSCs a = (PredType, [PredType], a) + +mkMinimalBySCs :: forall a. (a -> PredType) -> [a] -> [a] +-- Remove predicates that +-- +-- - are the same as another predicate +-- +-- - can be deduced from another by superclasses, +-- +-- - are a reflexive equality (e.g * ~ *) +-- (see Note [Remove redundant provided dicts] in GHC.Tc.TyCl.PatSyn) +-- +-- The result is a subset of the input. +-- The 'a' is just paired up with the PredType; +-- typically it might be a dictionary Id +mkMinimalBySCs get_pred xs = go preds_with_scs [] + where + preds_with_scs :: [PredWithSCs a] + preds_with_scs = [ (pred, implicants pred, x) + | x <- xs + , let pred = get_pred x ] + + go :: [PredWithSCs a] -- Work list + -> [PredWithSCs a] -- Accumulating result + -> [a] + go [] min_preds + = reverse (map thdOf3 min_preds) + -- The 'reverse' isn't strictly necessary, but it + -- means that the results are returned in the same + -- order as the input, which is generally saner + go (work_item@(p,_,_) : work_list) min_preds + | EqPred _ t1 t2 <- classifyPredType p + , t1 `tcEqType` t2 -- See GHC.Tc.TyCl.PatSyn + -- Note [Remove redundant provided dicts] + = go work_list min_preds + | p `in_cloud` work_list || p `in_cloud` min_preds + -- Why look at work-list too? Suppose work_item is Eq a, + -- and work-list contains Ord a + = go work_list min_preds + | otherwise + = go work_list (work_item : min_preds) + + in_cloud :: PredType -> [PredWithSCs a] -> Bool + in_cloud p ps = or [ p `tcEqType` p' | (_, scs, _) <- ps, p' <- scs ] + + implicants pred + = pred : eq_extras pred ++ transSuperClasses pred + + -- Combine (a ~ b) and (b ~ a); no need to have both in one context + -- These can arise when dealing with partial type signatures (e.g. T14715) + eq_extras pred + = case classifyPredType pred of + EqPred r t1 t2 -> [mkEqPred r t2 t1] + ClassPred cls [k1,k2,t1,t2] + | cls `hasKey` heqTyConKey -> [mkClassPred cls [k2, k1, t2, t1]] + ClassPred cls [k,t1,t2] + | cls `hasKey` eqTyConKey -> [mkClassPred cls [k, t2, t1]] + _ -> [] + +transSuperClasses :: PredType -> [PredType] +-- (transSuperClasses p) returns (p's superclasses) not including p +-- Stop if you encounter the same class again +-- See Note [Expanding superclasses] +transSuperClasses p + = go emptyNameSet p + where + go :: NameSet -> PredType -> [PredType] + go rec_clss p + | ClassPred cls tys <- classifyPredType p + , let cls_nm = className cls + , not (cls_nm `elemNameSet` rec_clss) + , let rec_clss' | isCTupleClass cls = rec_clss + | otherwise = rec_clss `extendNameSet` cls_nm + = [ p' | sc <- immSuperClasses cls tys + , p' <- sc : go rec_clss' sc ] + | otherwise + = [] + +immSuperClasses :: Class -> [Type] -> [PredType] +immSuperClasses cls tys + = substTheta (zipTvSubst tyvars tys) sc_theta + where + (tyvars,sc_theta,_,_) = classBigSig cls + +isImprovementPred :: PredType -> Bool +-- Either it's an equality, or has some functional dependency +isImprovementPred ty + = case classifyPredType ty of + EqPred NomEq t1 t2 -> not (t1 `tcEqType` t2) + EqPred ReprEq _ _ -> False + ClassPred cls _ -> classHasFds cls + IrredPred {} -> True -- Might have equalities after reduction? + ForAllPred {} -> False + +{- Note [Expanding superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we expand superclasses, we use the following algorithm: + +transSuperClasses( C tys ) returns the transitive superclasses + of (C tys), not including C itself + +For example + class C a b => D a b + class D b a => C a b + +Then + transSuperClasses( Ord ty ) = [Eq ty] + transSuperClasses( C ta tb ) = [D tb ta, C tb ta] + +Notice that in the recursive-superclass case we include C again at +the end of the chain. One could exclude C in this case, but +the code is more awkward and there seems no good reason to do so. +(However C.f. GHC.Tc.Solver.Dict.mk_strict_superclasses, which /does/ +appear to do so.) + +The algorithm is expand( so_far, pred ): + + 1. If pred is not a class constraint, return empty set + Otherwise pred = C ts + 2. If C is in so_far, return empty set (breaks loops) + 3. Find the immediate superclasses constraints of (C ts) + 4. For each such sc_pred, return (sc_pred : expand( so_far+C, D ss ) + +Notice that + + * With normal Haskell-98 classes, the loop-detector will never bite, + so we'll get all the superclasses. + + * We need the loop-breaker in case we have UndecidableSuperClasses on + + * Since there is only a finite number of distinct classes, expansion + must terminate. + + * The loop breaking is a bit conservative. Notably, a tuple class + could contain many times without threatening termination: + (Eq a, (Ord a, Ix a)) + And this is try of any class that we can statically guarantee + as non-recursive (in some sense). For now, we just make a special + case for tuples. Something better would be cool. + +See also GHC.Tc.TyCl.Utils.checkClassCycles. + +************************************************************************ +* * + Classifying types +* * +************************************************************************ +-} + +isSigmaTy :: TcType -> Bool +-- isSigmaTy returns true of any type with /invisible/ quantifiers at the top: +-- forall a. blah +-- Eq a => blah +-- ?x::Int => blah +-- But NOT +-- forall a -> blah +isSigmaTy (ForAllTy (Bndr _ af) _) = isInvisibleForAllTyFlag af +isSigmaTy (FunTy { ft_af = af }) = isInvisibleFunArg af +isSigmaTy ty | Just ty' <- coreView ty = isSigmaTy ty' +isSigmaTy _ = False + + +isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] +isRhoTy ty = not (isSigmaTy ty) + +-- | Like 'isRhoTy', but also says 'True' for 'Infer' types +isRhoExpTy :: ExpType -> Bool +isRhoExpTy (Check ty) = isRhoTy ty +isRhoExpTy (Infer {}) = True + +isOverloadedTy :: Type -> Bool +-- Yes for a type of a function that might require evidence-passing +-- Used by bindLocalMethods and for -fprof-late-overloaded +isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' +isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty +isOverloadedTy (FunTy { ft_af = af }) = isInvisibleFunArg af +isOverloadedTy _ = False + +isFloatTy, isDoubleTy, + isFloatPrimTy, isDoublePrimTy, + isIntegerTy, isNaturalTy, + isIntTy, isWordTy, isBoolTy, + isUnitTy, isAnyTy, isZonkAnyTy, isCharTy :: Type -> Bool +isFloatTy = is_tc floatTyConKey +isDoubleTy = is_tc doubleTyConKey +isFloatPrimTy = is_tc floatPrimTyConKey +isDoublePrimTy = is_tc doublePrimTyConKey +isIntegerTy = is_tc integerTyConKey +isNaturalTy = is_tc naturalTyConKey +isIntTy = is_tc intTyConKey +isWordTy = is_tc wordTyConKey +isBoolTy = is_tc boolTyConKey +isUnitTy = is_tc unitTyConKey +isAnyTy = is_tc anyTyConKey +isZonkAnyTy = is_tc zonkAnyTyConKey +isCharTy = is_tc charTyConKey + +-- | Check whether the type is of the form @Any :: k@, +-- returning the kind @k@. +anyTy_maybe :: Type -> Maybe Kind +anyTy_maybe ty + | Just (tc, [k]) <- splitTyConApp_maybe ty + , getUnique tc == anyTyConKey + = Just k + | otherwise + = Nothing + +-- | Is the type inhabited by machine floating-point numbers? +-- +-- Used to check that we don't use floating-point literal patterns +-- in Core. +-- +-- See #9238 and Note [Rules for floating-point comparisons] +-- in GHC.Core.Opt.ConstantFold. +isFloatingPrimTy :: Type -> Bool +isFloatingPrimTy ty = isFloatPrimTy ty || isDoublePrimTy ty + +-- | Is a type 'String'? +isStringTy :: Type -> Bool +isStringTy ty + = case tcSplitTyConApp_maybe ty of + Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty + _ -> False + +is_tc :: Unique -> Type -> Bool +-- Newtypes are opaque to this +is_tc uniq ty = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> uniq == getUnique tc + Nothing -> False + +isRigidTy :: TcType -> Bool +isRigidTy ty + | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal + | Just {} <- tcSplitAppTy_maybe ty = True + | isForAllTy ty = True + | Just {} <- isLitTy ty = True + | otherwise = False + +{- +************************************************************************ +* * + Misc +* * +************************************************************************ + +Note [Visible type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC implements a generalisation of the algorithm described in the +"Visible Type Application" paper (available from +http://www.cis.upenn.edu/~sweirich/publications.html). A key part +of that algorithm is to distinguish user-specified variables from inferred +variables. For example, the following should typecheck: + + f :: forall a b. a -> b -> b + f = const id + + g = const id + + x = f @Int @Bool 5 False + y = g 5 @Bool False + +The idea is that we wish to allow visible type application when we are +instantiating a specified, fixed variable. In practice, specified, fixed +variables are either written in a type signature (or +annotation), OR are imported from another module. (We could do better here, +for example by doing SCC analysis on parts of a module and considering any +type from outside one's SCC to be fully specified, but this is very confusing to +users. The simple rule above is much more straightforward and predictable.) + +So, both of f's quantified variables are specified and may be instantiated. +But g has no type signature, so only id's variable is specified (because id +is imported). We write the type of g as forall {a}. a -> forall b. b -> b. +Note that the a is in braces, meaning it cannot be instantiated with +visible type application. + +Tracking specified vs. inferred variables is done conveniently by a field +in PiTyVarBinder. + +-} + +deNoteType :: Type -> Type +-- Remove all *outermost* type synonyms and other notes +deNoteType ty | Just ty' <- coreView ty = deNoteType ty' +deNoteType ty = ty + +{- +Find the free tycons and classes of a type. This is used in the front +end of the compiler. +-} + +{- +************************************************************************ +* * + External types +* * +************************************************************************ + +The compiler's foreign function interface supports the passing of a +restricted set of types as arguments and results (the restricting factor +being the ) +-} + +tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) +-- (tcSplitIOType_maybe t) returns Just (IO,t') +-- if t = IO t' +-- returns Nothing otherwise +tcSplitIOType_maybe ty + = case tcSplitTyConApp_maybe ty of + Just (io_tycon, [io_res_ty]) + | io_tycon `hasKey` ioTyConKey -> + Just (io_tycon, io_res_ty) + _ -> + Nothing + + +{- +************************************************************************ +* * + Visiblities +* * +************************************************************************ +-} + +-- | For every arg a tycon can take, the returned list says True if the argument +-- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to +-- allow for oversaturation. +tyConVisibilities :: TyCon -> [Bool] +tyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True + where + tc_binder_viss = map isVisibleTyConBinder (tyConBinders tc) + tc_return_kind_viss = map isVisiblePiTyBinder (fst $ tcSplitPiTys (tyConResKind tc)) + +-- | If the tycon is applied to the types, is the next argument visible? +isNextTyConArgVisible :: TyCon -> [Type] -> Bool +isNextTyConArgVisible tc tys + = tyConVisibilities tc `getNth` length tys + +-- | Should this type be applied to a visible argument? +-- E.g. (s t): is `t` a visible argument of `s`? +isNextArgVisible :: TcType -> Bool +isNextArgVisible ty + | Just (bndr, _) <- tcSplitPiTy_maybe (typeKind ty) = isVisiblePiTyBinder bndr + | otherwise = True + -- this second case might happen if, say, we have an unzonked TauTv. + -- But TauTvs can't range over types that take invisible arguments + +{- +************************************************************************ +* * + Paterson sizes +* * +************************************************************************ +-} + +{- Note [The PatersonSize of a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The PatersonSize of type is something we can compare, with `ltPatersonSize`, +to determine if the Paterson conditions are satisfied for an instance +declaration. See Note [Paterson conditions] in GHC.Tc.Validity. + +There are some wrinkles + +(PS1) Once we get into an implicit parameter or equality we + can't get back to a class constraint, so it's safe + to say "size 0". See #4200. + + We do this with isTerminatingClass + +Note [Invisible arguments and termination] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When checking the ​Paterson conditions for termination an instance +declaration, we check for the number of "constructors and variables" +in the instance head and constraints. Question: Do we look at + + * All the arguments, visible or invisible? + * Just the visible arguments? + +I think both will ensure termination, provided we are consistent. +Currently we are /not/ consistent, which is really a bug. It's +described in #15177, which contains a number of examples. +The suspicious bits are the calls to filterOutInvisibleTypes. +See also #11833. + +Note [Stuck type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type-family application generally has infinite size (PS_TyFam); +see (PC3) in Note [Paterson conditions] in GHC.Tc.Validity. + +But a couple of built-in type families have no axioms, and can never +expand into anything else. They are: + +* (TypeError "stuff"). E.g. consider + + type family F a where + F Int = Bool + F Bool = Char + F _ = TypeError "Bad" + + We don't want to complain about possible non-termination of F, in + GHC.Tc.Validity.checkFamInstRhs. cf indexed-types/should_fail/T13271 + +* (Any @k). + +For now we treat them as being size zero, but (#22696) I think we should +actually treat them as big (like any other ype family) because we don't +want to abstract over them in e.g. validDerivPred. + +The type-family termination test, in GHC.Tc.Validity.checkFamInstRhs, already +has a separate call to isStuckTypeFamily, so the `F` above will still be accepted. +-} + +-- | Why did the Paterson conditions fail; that is, why +-- was the context P not Paterson-smaller than the head H? +-- +-- See Note [Paterson conditions] in GHC.Tc.Validity. +data PatersonCondFailure + -- | Some type variables occur more often in P than in H. + -- See (PC1) in Note [Paterson conditions] in GHC.Tc.Validity. + = PCF_TyVar + [TyVar] -- ^ the type variables which appear more often in the context + -- | P is not smaller in size than H. + -- See (PC2) in Note [Paterson conditions] in GHC.Tc.Validity. + | PCF_Size + -- | P contains a type family. + -- See (PC3) in Note [Paterson conditions] in GHC.Tc.Validity. + | PCF_TyFam + TyCon -- ^ the type constructor of the type family + +-- | Indicates whether a Paterson condition failure occurred in an instance declaration or a type family equation. +-- Useful for differentiating context in error messages. +data PatersonCondFailureContext + = InInstanceDecl + | InTyFamEquation + +-------------------------------------- + +-- | The Paterson size of a given type, in the sense of +-- Note [Paterson conditions] in GHC.Tc.Validity +-- +-- - after expanding synonyms, +-- - ignoring coercions (as they are not user written). +data PatersonSize + -- | The type mentions a type family, so the size could be anything. + = PS_TyFam TyCon + -- | The type does not mention a type family. + | PS_Vanilla { ps_tvs :: [TyVar] -- ^ free tyvars, including repetitions; + , ps_size :: Int -- ^ number of type constructors and variables + } + -- ToDo: ignore invisible arguments? See Note [Invisible arguments and termination] + +instance Outputable PatersonSize where + ppr (PS_TyFam tc) = text "PS_TyFam" <+> ppr tc + ppr (PS_Vanilla { ps_tvs = tvs, ps_size = size }) + = text "PS_Vanilla" <> braces (sep [ text "ps_tvs =" <+> ppr tvs <> comma + , text "ps_size =" <+> int size ]) + +pSizeZero, pSizeOne :: PatersonSize +pSizeZero = PS_Vanilla { ps_tvs = [], ps_size = 0 } +pSizeOne = PS_Vanilla { ps_tvs = [], ps_size = 1 } + +-- | @ltPatersonSize ps1 ps2@ returns: +-- +-- - @Nothing@ iff @ps1@ is definitely strictly smaller than @ps2@, +-- - @Just ps_fail@ otherwise; @ps_fail@ says what went wrong. +ltPatersonSize :: PatersonSize + -> PatersonSize + -> Maybe PatersonCondFailure +ltPatersonSize (PS_Vanilla { ps_tvs = tvs1, ps_size = s1 }) + (PS_Vanilla { ps_tvs = tvs2, ps_size = s2 }) + | s1 >= s2 = Just PCF_Size + | bad_tvs@(_:_) <- noMoreTyVars tvs1 tvs2 = Just (PCF_TyVar bad_tvs) + | otherwise = Nothing -- OK! +ltPatersonSize (PS_TyFam tc) _ = Just (PCF_TyFam tc) +ltPatersonSize _ (PS_TyFam tc) = Just (PCF_TyFam tc) + -- NB: this last equation is never taken when checking instances, because + -- type families are disallowed in instance heads. + -- + -- However, this function is also used in the logic for solving superclass + -- constraints (see Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance), + -- in which case we might well hit this case (see e.g. T23171). + +noMoreTyVars :: [TyVar] -- Free vars (with repetitions) of the constraint C + -> [TyVar] -- Free vars (with repetitions) of the head H + -> [TyVar] -- TyVars that appear more often in C than H; + -- no repetitions in this list +noMoreTyVars tvs head_tvs + = nub (tvs \\ head_tvs) -- The (\\) is list difference; e.g. + -- [a,b,a,a] \\ [a,a] = [b,a] + -- So we are counting repetitions + +addPSize :: PatersonSize -> PatersonSize -> PatersonSize +addPSize ps1@(PS_TyFam {}) _ = ps1 +addPSize _ ps2@(PS_TyFam {}) = ps2 +addPSize (PS_Vanilla { ps_tvs = tvs1, ps_size = s1 }) + (PS_Vanilla { ps_tvs = tvs2, ps_size = s2 }) + = PS_Vanilla { ps_tvs = tvs1 ++ tvs2, ps_size = s1 + s2 } + -- (++) is not very performant, but the types + -- are user-written and never large + +pSizeType :: Type -> PatersonSize +pSizeType = pSizeTypeX emptyVarSet + +pSizeTypes :: [Type] -> PatersonSize +pSizeTypes = pSizeTypesX emptyVarSet pSizeZero + +-- Paterson size of a type, retaining repetitions, and expanding synonyms +-- This ignores coercions, as coercions aren't user-written +pSizeTypeX :: VarSet -> Type -> PatersonSize +pSizeTypeX bvs ty | Just exp_ty <- coreView ty = pSizeTypeX bvs exp_ty +pSizeTypeX bvs (TyVarTy tv) + | tv `elemVarSet` bvs = pSizeOne + | otherwise = PS_Vanilla { ps_tvs = [tv], ps_size = 1 } +pSizeTypeX _ (LitTy {}) = pSizeOne +pSizeTypeX bvs (TyConApp tc tys) = pSizeTyConAppX bvs tc tys +pSizeTypeX bvs (AppTy fun arg) = pSizeTypeX bvs fun `addPSize` pSizeTypeX bvs arg +pSizeTypeX bvs (FunTy _ w arg res) = pSizeTypeX bvs w `addPSize` pSizeTypeX bvs arg `addPSize` + pSizeTypeX bvs res +pSizeTypeX bvs (ForAllTy (Bndr tv _) ty) = pSizeTypeX bvs (tyVarKind tv) `addPSize` + pSizeTypeX (bvs `extendVarSet` tv) ty +pSizeTypeX bvs (CastTy ty _) = pSizeTypeX bvs ty +pSizeTypeX _ (CoercionTy {}) = pSizeOne + +pSizeTypesX :: VarSet -> PatersonSize -> [Type] -> PatersonSize +pSizeTypesX bvs sz tys = foldr (addPSize . pSizeTypeX bvs) sz tys + +pSizeTyConApp :: TyCon -> [Type] -> PatersonSize +pSizeTyConApp = pSizeTyConAppX emptyVarSet + +pSizeTyConAppX :: VarSet -> TyCon -> [Type] -> PatersonSize +-- Open question: do we count all args, or just the visible ones? +-- See Note [Invisible arguments and termination] +pSizeTyConAppX bvs tc tys + | isTypeFamilyTyCon tc = pSizeTyFamApp tc + | otherwise = pSizeTypesX bvs pSizeOne tys + +pSizeTyFamApp :: TyCon -> PatersonSize +-- See Note [Stuck type families] +pSizeTyFamApp tc + | isStuckTypeFamily tc = pSizeZero + | otherwise = PS_TyFam tc + +pSizeHead :: PredType -> PatersonSize +-- Getting the size of an instance head is a bit horrible +-- because of the special treament for class predicates +pSizeHead pred = case classifyPredType pred of + ClassPred cls tys -> pSizeClassPred cls tys + _ -> pSizeType pred + +pSizeClassPred :: Class -> [Type] -> PatersonSize +pSizeClassPred = pSizeClassPredX emptyVarSet + +pSizeClassPredX :: VarSet -> Class -> [Type] -> PatersonSize +pSizeClassPredX bvs cls tys + | isTerminatingClass cls -- See (PS1) in Note [The PatersonSize of a type] + = pSizeZero + | otherwise + = pSizeTypesX bvs pSizeOne $ + filterOutInvisibleTypes (classTyCon cls) tys + -- filterOutInvisibleTypes Yuk! See Note [Invisible arguments and termination] + +isStuckTypeFamily :: TyCon -> Bool +-- See Note [Stuck type families] +isStuckTypeFamily tc + = tc `hasKey` errorMessageTypeErrorFamKey + || tc `hasKey` anyTyConKey + +-- | When this says "True", ignore this class constraint during +-- a termination check +-- See (PS1) in Note [The PatersonSize of a type] +isTerminatingClass :: Class -> Bool +isTerminatingClass cls + = isIPClass cls -- Implicit parameter constraints always terminate because + -- there are no instances for them --- they are only solved + -- by "local instances" in expressions + || isEqualityClass cls + || cls `hasKey` typeableClassKey + -- Typeable constraints are bigger than they appear due + -- to kind polymorphism, but we can never get instance divergence this way + || cls `hasKey` unsatisfiableClassNameKey + +allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool +-- (allDistinctTyVars tvs tys) returns True if tys are +-- a) all tyvars +-- b) all distinct +-- c) disjoint from tvs +allDistinctTyVars _ [] = True +allDistinctTyVars tkvs (ty : tys) + = case getTyVar_maybe ty of + Nothing -> False + Just tv | tv `elemVarSet` tkvs -> False + | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys + +----------------------- +type TypeSize = IntWithInf + +sizeType :: Type -> TypeSize +-- Size of a type: the number of variables and constructors +sizeType ty = toTypeSize (pSizeType ty) + +sizeTypes :: [Type] -> TypeSize +sizeTypes tys = toTypeSize (foldr (addPSize . pSizeType) pSizeZero tys) + +toTypeSize :: PatersonSize -> TypeSize +toTypeSize (PS_TyFam {}) = infinity +toTypeSize (PS_Vanilla { ps_size = size }) = mkIntWithInf size diff --git a/GHC/Tc/Utils/TcType.hs-boot b/GHC/Tc/Utils/TcType.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/TcType.hs-boot @@ -0,0 +1,22 @@ +module GHC.Tc.Utils.TcType where +import GHC.Utils.Outputable( SDoc ) +import GHC.Utils.Misc( HasDebugCallStack ) +import GHC.Prelude ( Bool ) +import {-# SOURCE #-} GHC.Types.Var ( TcTyVar ) +import {-# SOURCE #-} GHC.Tc.Types.Origin ( FixedRuntimeRepOrigin ) +import GHC.Types.Name.Env ( NameEnv ) + +data MetaDetails + +data TcTyVarDetails +pprTcTyVarDetails :: TcTyVarDetails -> SDoc +vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails +isMetaTyVar :: TcTyVar -> Bool +isTyConableTyVar :: TcTyVar -> Bool + +type ConcreteTyVars = NameEnv ConcreteTvOrigin +data ConcreteTvOrigin + = ConcreteFRR FixedRuntimeRepOrigin + +isConcreteTyVar :: TcTyVar -> Bool +noConcreteTyVars :: ConcreteTyVars diff --git a/GHC/Tc/Utils/Unify.hs b/GHC/Tc/Utils/Unify.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Unify.hs @@ -0,0 +1,4764 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +-- | Type subsumption and unification +module GHC.Tc.Utils.Unify ( + -- Full-blown subsumption + tcWrapResult, tcWrapResultO, tcWrapResultMono, + tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS, + addSubTypeCtxt, + tcSubTypeAmbiguity, tcSubMult, + checkConstraints, checkTvConstraints, + buildImplicationFor, buildTvImplication, emitResidualTvConstraint, + + -- Skolemisation + DeepSubsumptionFlag(..), getDeepSubsumptionFlag, isRhoTyDS, + tcSkolemise, tcSkolemiseCompleteSig, tcSkolemiseExpectedType, + dsInstantiate, + + -- Various unifications + unifyType, unifyKind, unifyInvisibleType, + unifyExprType, unifyTypeAndEmit, promoteTcType, + swapOverTyVars, touchabilityTest, checkTopShape, lhsPriority, + UnifyEnv(..), updUEnvLoc, setUEnvRole, + uType, + mightEqualLater, + makeTypeConcrete, + + -------------------------------- + -- Holes + matchExpectedListTy, + matchExpectedTyConApp, + matchExpectedAppTy, + matchExpectedFunTys, + matchExpectedFunKind, + matchActualFunTy, matchActualFunTys, + + checkTyEqRhs, recurseIntoTyConApp, recurseIntoFamTyConApp, + PuResult(..), okCheckRefl, mapCheck, + TyEqFlags(..), + notUnifying_TEFTask, unifyingLHSMetaTyVar_TEFTask, defaulting_TEFTask, + pureTyEqFlags_LHSMetaTyVar, mkTEFA_Break, + + OccursCheck(..), LevelCheck(..), ConcreteCheck(..), + TyEqFamApp(..), FamAppBreaker(..), + checkPromoteFreeVars, + + simpleUnifyCheck, UnifyCheckCaller(..), SimpleUnifyResult(..), + + fillInferResult, fillInferResultNoInst + ) where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) ) +import GHC.Tc.Errors.Ppr ( pprErrCtxtMsg ) +import GHC.Tc.Utils.Concrete +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.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( CtLoc, mkKindEqLoc, adjustCtLoc, updateCtLocOrigin, ctLocOrigin ) +import GHC.Tc.Types.Origin +import GHC.Tc.Zonk.TcType +import GHC.Tc.Utils.TcMType qualified as TcM + +import GHC.Tc.Solver.InertSet + +import GHC.Core.Type +import GHC.Core.TyCo.Rep hiding (Refl) +import GHC.Core.TyCo.FVs( isInjectiveInType ) +import GHC.Core.TyCo.Ppr( debugPprType {- pprTyVar -} ) +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Unify +import GHC.Core.Predicate( EqRel(..), mkEqPredRole, mkNomEqPred ) +import GHC.Core.Multiplicity +import GHC.Core.Reduction + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Builtin.Types +import GHC.Types.Name +import GHC.Types.Id( idType ) +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Basic +import GHC.Types.Unique.Set (nonDetEltsUniqSet) + +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic + +import GHC.Driver.DynFlags + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.Maybe (firstJusts) + +import Control.Monad +import Data.Functor.Identity (Identity(..)) +import qualified Data.List.NonEmpty as NE +import Data.Monoid as DM ( Any(..) ) +import qualified Data.Semigroup as S ( (<>) ) +import Data.Traversable (for) + +{- ********************************************************************* +* * + matchActualFunTys +* * +********************************************************************* -} + +-- | 'matchActualFunTy' 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]. +matchActualFunTy + :: ExpectedFunTyOrigin + -- ^ See Note [Herald for matchExpectedFunTys] + -> Maybe TypedThing + -- ^ The thing with type TcSigmaType + -> (Arity, TcType) + -- ^ Total number of value args in the call, and + -- the original function type + -- (Both are used only for error messages) + -> TcRhoType + -- ^ Type to analyse: a TcRhoType + -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) +-- This function takes in a type to analyse (a RhoType) and returns +-- an argument type and a result type (splitting apart a function arrow). +-- The returned argument type is a SigmaType with a fixed RuntimeRep; +-- as explained in Note [Return arguments with a fixed RuntimeRep]. +-- +-- See Note [matchActualFunTy error handling] for the first three arguments + +-- If (wrap, arg_ty, res_ty) = matchActualFunTy ... fun_ty +-- then wrap :: fun_ty ~> (arg_ty -> res_ty) +-- and NB: res_ty is an (uninstantiated) SigmaType + +matchActualFunTy herald mb_thing err_info fun_ty + = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $ + go fun_ty + where + -- Does not allocate unnecessary meta variables: if the input already is + -- a function, we just take it apart. Not only is this efficient, + -- it's important for higher rank: the argument might be of form + -- (forall a. ty) -> other + -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd + -- hide the forall inside a meta-variable + go :: TcRhoType -- The type we're processing, perhaps after + -- expanding type synonyms + -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) + go ty | Just ty' <- coreView ty = go ty' + + go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) + = assert (isVisibleFunArg af) $ + do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty + ; return (idHsWrapper, Scaled w arg_ty, res_ty) } + + go ty@(TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty' -> go ty' + Flexi -> defer ty } + + -- In all other cases we bale out into ordinary unification + -- However unlike the meta-tyvar case, we are sure that the + -- number of arguments doesn't match arity of the original + -- type, so we can add a bit more context to the error message + -- (cf #7869). + -- + -- It is not always an error, because specialized type may have + -- different arity, for example: + -- + -- > f1 = f2 'a' + -- > f2 :: Monad m => m Bool + -- > f2 = undefined + -- + -- But in that case we add specialized type into error context + -- anyway, because it may be useful. See also #9605. + go ty = addErrCtxtM (mk_ctxt ty) (defer ty) + + ------------ + defer fun_ty + = do { arg_ty <- new_check_arg_ty herald 1 + ; res_ty <- newOpenFlexiTyVarTy + ; let unif_fun_ty = mkScaledFunTys [arg_ty] res_ty + ; co <- unifyType mb_thing fun_ty unif_fun_ty + ; return (mkWpCastN co, arg_ty, res_ty) } + + ------------ + mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) + mk_ctxt _res_ty = mkFunTysMsg herald err_info + +{- Note [matchActualFunTy error handling] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +matchActualFunTy is made much more complicated by the +desire to produce good error messages. Consider the application + f @Int x y +In GHC.Tc.Gen.Head.tcInstFun we instantiate the function type, one +argument at a time. It must instantiate any type/dictionary args, +before looking for an arrow type. + +But if it doesn't find an arrow type, it wants to generate a message +like "f is applied to two arguments but its type only has one". +To do that, it needs to know about the args that tcArgs has already +munched up -- hence passing in n_val_args_in_call and arg_tys_so_far; +and hence also the accumulating so_far arg to 'go'. + +This allows us (in mk_ctxt) to construct f's /instantiated/ type, +with just the values-arg arrows, which is what we really want +in the error message. + +Ugh! +-} + +-- | Like 'matchExpectedFunTys', but used when you have an "actual" type, +-- for example in function application. +-- +-- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep +-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- See Note [Return arguments with a fixed RuntimeRep]. +matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys] + -> CtOrigin + -> Arity + -> TcSigmaType + -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType) +-- If matchActualFunTys n ty = (wrap, [t1,..,tn], res_ty) +-- then wrap : ty ~> (t1 -> ... -> tn -> res_ty) +-- and res_ty is a RhoType +-- NB: the returned type is top-instantiated; it's a RhoType +matchActualFunTys herald ct_orig n_val_args_wanted top_ty + = go n_val_args_wanted [] top_ty + where + go n so_far fun_ty + | not (isRhoTy fun_ty) + = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty + ; (wrap2, arg_tys, res_ty) <- go n so_far rho + ; return (wrap2 <.> wrap1, arg_tys, res_ty) } + + go 0 _ fun_ty = return (idHsWrapper, [], fun_ty) + + go n so_far fun_ty + = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTy + herald Nothing + (n_val_args_wanted, top_ty) + fun_ty + ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1 + ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty + -- NB: arg_ty1 comes from matchActualFunTy, so it has + -- a syntactically fixed RuntimeRep as needed to call mkWpFun. + ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) } + +{- +************************************************************************ +* * + Skolemisation and matchExpectedFunTys +* * +************************************************************************ + +Note [Skolemisation overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose f :: (forall a. a->a) -> blah, and we have the application (f e) +Then we want to typecheck `e` pushing in the type `forall a. a->a`. But we +need to be careful: + +* Roughly speaking, in (tcPolyExpr e (forall a b. rho)), we skolemise `a` and `b`, + and then call (tcExpr e rho) + +* But not quite! We must be careful if `e` is a type lambda (\ @p @q -> blah). + Then we want to line up the skolemised variables `a`,`b` + with `p`,`q`, so we can't just call (tcExpr (\ @p @q -> blah) rho) + +* A very similar situation arises with + (\ @p @q -> blah) :: forall a b. rho + Again, we must line up `p`, `q` with the skolemised `a` and `b`. + +* Another similar situation arises with + g :: forall a b. rho + g @p @q x y = .... + Here again when skolemising `a` and `b` we must be careful to match them up + with `p` and `q`. + +OK, so how exactly do we check @p binders in lambdas? First note that we only +we only attempt to deal with @p binders when /checking/. We don't do inference for +(\ @a -> blah), not yet anyway. + +For checking, there are two cases to consider: + * Function LHS, where the function has a type signature + f :: forall a. a -> forall b. [b] -> blah + f @p x @q y = ... + + * Lambda \ @p x @q y -> ... + \cases { @p x @q y -> ... } + (\case p behaves like \cases { p -> ... }, and p is always a term pattern.) + +Both ultimately handled by matchExpectedFunTys. + +* Function LHS case is handled by `GHC.Tc.Gen.Bind.tcPolyCheck`: + * It calls `tcSkolemiseCompleteSig` + * Passes the skolemised variables into `tcFunBindMatches` + * Which uses `matchExpectedFunTys` to decompose the function type to + match the arguments + * And then passes the (skolemised-variables ++ arg tys) on to `tcMatches` + +* For the Lambda case there are two sub-cases: + * An expression with a type signature: (\ @a x y -> blah) :: hs_ty + This is handled by `GHC.Tc.Gen.Head.tcExprWithSig`, which kind-checks + the signature and hands off to `tcExprPolyCheck` via `tcPolyLExprSig`. + Note that the foralls at the top of hs_ty scope over the expression. + + * A higher order call: h e, where h :: poly_ty -> blah + This is handlded by `GHC.Tc.Gen.Expr.tcPolyExpr`, which (in the + checking case) again hands off to `tcExprPolyCheck`. Here there is + no type-variable scoping to worry about. + + So both sub-cases end up in `GHC.Tc.Gen.Expr.tcPolyExprCheck` + * This skolemises the /top-level/ invisible binders, but remembers + the binders as [ExpPatType] + * Then it looks for a lambda, and if so, calls `tcLambdaMatches` passing in + the skolemised binders so they can be matched up with the lambda binders. + * Otherwise it does deep-skolemisation if DeepSubsumption is on, + and then calls tcExpr to typecheck `e` + + The outer skolemisation in tcPolyExprCheck is done using + * tcSkolemiseCompleteSig when there is a user-written signature + * tcSkolemiseGeneral when the polytype just comes from the context e.g. (f e) + The former just calls the latter, so the two cases differ only slightly: + * Both do shallow skolemisation + * Both go via checkConstraints, which uses implicationNeeded to decide whether + to build an implication constraint even if there /are/ no skolems. + See Note [When to build an implication] below. + + The difference between the two cases is that `tcSkolemiseCompleteSig` + also brings the outer type variables into scope. It would do no + harm to do so in both cases, but I found that (to my surprise) doing + so caused a non-trivial (1%-ish) perf hit on the compiler. + +* `tcFunBindMatches` and `tcLambdaMatches` both use `matchExpectedFunTys`, which + ensures that any trailing invisible binders are skolemised; and does so deeply + if DeepSubsumption is on. + + This corresponds to the plan: "skolemise at the '=' of a function binding or + at the '->' of a lambda binding". (See #17594 and "Plan B2".) + +Some wrinkles + +(SK1) tcSkolemiseGeneral and tcSkolemiseCompleteSig make fresh type variables + See Note [Instantiate sig with fresh variables] + +(SK2) All skolemisation (even without DeepSubsumption) builds just one implication + constraint for a nested forall like: + forall a. Eq a => forall b. Ord b => blah + The implication constraint will look like + forall a b. (Eq a, Ord b) => + See the loop in GHC.Tc.Utils.Instantiate.topSkolemise. + and Note [Skolemisation en-bloc] in that module + + +Some examples: + +* f :: forall a b. blah + f @p x = rhs + `tcPolyCheck` calls `tcSkolemiseCompleteSig` to skolemise the signature, and + then calls `tcFunBindMatches` passing in [a_sk, b_sk], the skolemsed + variables. The latter ultimately calls `tcMatches`, and thence `tcMatchPats`. + The latter matches up the `a_sk` with `@p`, and discards the `b_sk`. + +* f :: forall (a::Type) (b::a). blah + f @(p::b) x = rhs + `tcSkolemiseCompleteSig` brings `a` and `b` into scope, bound to `a_sk` and `b_sk` resp. + When `tcMatchPats` typechecks the pattern `@(p::b)` it'll find that `b` is in + scope (as a result of tcSkolemiseCompleteSig) which is a bit strange. But + it'll then unify the kinds `Type ~ b`, which will fail as it should. + +* f :: Int -> forall (a::Type) (b::a). blah + f x @p = rhs + `matchExpectedFunTys` does shallow skolemisation eagerly, so we'll skolemise the + forall a b. Then `tcMatchPats` will bind [p :-> a_sk], and discard `b_sk`. + Discarding the `b_sk` means that + f x @p = \ @q -> blah + or f x @p = let .. in \ @q -> blah + will both be rejected: this is Plan B2: skolemise at the "=". + +* Suppose DeepSubsumption is on + f :: forall a. a -> forall b. b -> b -> forall z. z + f @p x @q y = rhs + The `tcSkolemiseCompleteSig` uses shallow skolemisation, so it only skolemises + and brings into scope [a :-> a_sk]. Then `matchExpectedFunTys` skolemises the + forall b, because it needs to expose two value arguments. Finally + `matchExpectedFunTys` concludes with deeply skolemising the remaining type. + + So we end up with `[p :-> a_sk, q :-> b_sk]`. Notice that we must not + deeply-skolemise /first/ or we'd get the tyvars [a_sk, b_sk, c_sk] which would + not line up with the patterns [@p, x, @q, y] +-} + +tcSkolemiseGeneral + :: DeepSubsumptionFlag + -> UserTypeCtxt + -> TcType -> TcType -- top_ty and expected_ty + -- Here, top_ty is the type we started to skolemise; used only in SigSkol + -- - expected_ty is the type we are actually skolemising + -- matchExpectedFunTys walks down the type, skolemising as it goes, + -- keeping the same top_ty, but successively smaller expected_tys + -> ([(Name, TcInvisTVBinder)] -> TcType -> TcM result) + -> TcM (HsWrapper, result) +tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside + | isRhoTyDS ds_flag expected_ty + -- Fast path for a very very common case: no skolemisation to do + -- But still call checkConstraints in case we need an implication regardless + = do { let sig_skol = SigSkol ctxt top_ty [] + ; (ev_binds, result) <- checkConstraints sig_skol [] [] $ + thing_inside [] expected_ty + ; return (mkWpLet ev_binds, result) } + + | otherwise + = do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; rec { (wrap, tv_prs, given, rho_ty) <- case ds_flag of + Deep -> deeplySkolemise skol_info expected_ty + Shallow -> topSkolemise skol_info expected_ty + ; let sig_skol = SigSkol ctxt top_ty (map (fmap binderVar) tv_prs) + ; skol_info <- mkSkolemInfo sig_skol } + + ; let skol_tvs = map (binderVar . snd) tv_prs + ; traceTc "tcSkolemiseGeneral" (pprUserTypeCtxt ctxt <+> ppr skol_tvs <+> ppr given) + ; (ev_binds, result) <- checkConstraints sig_skol skol_tvs given $ + thing_inside tv_prs 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 + +tcSkolemiseCompleteSig :: TcCompleteSig + -> ([ExpPatType] -> TcRhoType -> TcM result) + -> TcM (HsWrapper, result) +-- ^ The wrapper has type: spec_ty ~> expected_ty +-- See Note [Skolemisation] for the differences between +-- tcSkolemiseCompleteSig and tcTopSkolemise + +tcSkolemiseCompleteSig (CSig { sig_bndr = poly_id, sig_ctxt = ctxt, sig_loc = loc }) + thing_inside + = do { cur_loc <- getSrcSpanM + ; let poly_ty = idType poly_id + ; setSrcSpan loc $ -- Sets the location for the implication constraint + tcSkolemiseGeneral Shallow ctxt poly_ty poly_ty $ \tv_prs rho_ty -> + setSrcSpan cur_loc $ -- Revert to the original location + tcExtendNameTyVarEnv (map (fmap binderVar) tv_prs) $ + thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty } + +tcSkolemiseExpectedType :: TcSigmaType + -> ([ExpPatType] -> TcRhoType -> TcM result) + -> TcM (HsWrapper, result) +-- Just like tcSkolemiseCompleteSig, except that we don't have a user-written +-- type signature, we only have a type comimg from the context. +-- Eg. f :: (forall a. blah) -> blah +-- In the call (f e) we will call tcSkolemiseExpectedType on (forall a.blah) +-- before typececking `e` +tcSkolemiseExpectedType exp_ty thing_inside + = tcSkolemiseGeneral Shallow GenSigCtxt exp_ty exp_ty $ \tv_prs rho_ty -> + thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty + +tcSkolemise :: DeepSubsumptionFlag -> UserTypeCtxt -> TcSigmaType + -> (TcRhoType -> TcM result) + -> TcM (HsWrapper, result) +tcSkolemise ds_flag ctxt expected_ty thing_inside + = tcSkolemiseGeneral ds_flag ctxt expected_ty expected_ty $ \_ rho_ty -> + thing_inside rho_ty + +checkConstraints :: SkolemInfoAnon + -> [TcTyVar] -- Skolems + -> [EvVar] -- Given + -> TcM result + -> TcM (TcEvBinds, result) +-- checkConstraints is careful to build an implication even if +-- `skol_tvs` and `given` are both empty, under certain circumstances +-- See Note [When to build an implication] +checkConstraints skol_info skol_tvs given thing_inside + = do { implication_needed <- implicationNeeded skol_info skol_tvs given + + ; if implication_needed + then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside + ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted + ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs) + ; emitImplications implics + ; return (ev_binds, result) } + + else -- Fast path. We check every function argument with tcCheckPolyExpr, + -- which uses tcTopSkolemise and hence checkConstraints. + -- So this fast path is well-exercised + do { res <- thing_inside + ; return (emptyTcEvBinds, res) } } + +checkTvConstraints :: SkolemInfo + -> [TcTyVar] -- Skolem tyvars + -> TcM result + -> TcM result + +checkTvConstraints skol_info skol_tvs thing_inside + = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside + ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted + ; return result } + +emitResidualTvConstraint :: SkolemInfo -> [TcTyVar] + -> TcLevel -> WantedConstraints -> TcM () +emitResidualTvConstraint skol_info skol_tvs tclvl wanted + | not (isEmptyWC wanted) || + checkTelescopeSkol skol_info_anon + = -- checkTelescopeSkol: in this case, /always/ emit this implication + -- even if 'wanted' is empty. We need the implication so that we check + -- for a bad telescope. See Note [Skolem escape and forall-types] in + -- GHC.Tc.Gen.HsType + do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted + ; emitImplication implic } + + | otherwise -- Empty 'wanted', emit nothing + = return () + where + skol_info_anon = getSkolemInfo skol_info + +buildTvImplication :: SkolemInfoAnon -> [TcTyVar] + -> TcLevel -> WantedConstraints -> TcM Implication +buildTvImplication skol_info skol_tvs tclvl wanted + = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ + do { ev_binds <- newNoTcEvBinds -- Used for equalities only, so all the constraints + -- are solved by filling in coercion holes, not + -- by creating a value-level evidence binding + ; implic <- newImplication + + ; let implic' = implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_given_eqs = NoGivenEqs + , ic_wanted = wanted + , ic_binds = ev_binds + , ic_info = skol_info } + + ; checkImplicationInvariants implic' + ; return implic' } + +implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool +-- See Note [When to build an implication] +implicationNeeded skol_info skol_tvs given + | null skol_tvs + , null given + , not (alwaysBuildImplication skol_info) + = -- Empty skolems and givens + do { tc_lvl <- getTcLevel + ; if not (isTopTcLevel tc_lvl) -- No implication needed if we are + then return False -- already inside an implication + else + do { dflags <- getDynFlags -- If any deferral can happen, + -- we must build an implication + ; return (gopt Opt_DeferTypeErrors dflags || + gopt Opt_DeferTypedHoles dflags || + gopt Opt_DeferOutOfScopeVariables dflags) } } + + | otherwise -- Non-empty skolems or givens + = return True -- Definitely need an implication + +alwaysBuildImplication :: SkolemInfoAnon -> Bool +-- See Note [When to build an implication] +alwaysBuildImplication _ = False + +{- Commmented out for now while I figure out about error messages. + See #14185 + +Caution: we get some duplication of errors if we build more implications. +Because we get one error for each function RHS, even if it's for +the same class constraint. + +alwaysBuildImplication (SigSkol ctxt _ _) + = case ctxt of + FunSigCtxt {} -> True -- RHS of a binding with a signature + _ -> False +alwaysBuildImplication (RuleSkol {}) = True +alwaysBuildImplication (InstSkol {}) = True +alwaysBuildImplication (FamInstSkol {}) = True +alwaysBuildImplication _ = False +-} + +buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar] + -> [EvVar] -> WantedConstraints + -> TcM (Bag Implication, TcEvBinds) +buildImplicationFor tclvl skol_info skol_tvs given wanted + | isEmptyWC wanted && null given + -- Optimisation : if there are no wanteds, and no givens + -- don't generate an implication at all. + -- Reason for the (null given): we don't want to lose + -- the "inaccessible alternative" error check + = return (emptyBag, emptyTcEvBinds) + + | otherwise + = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ + -- Why allow TyVarTvs? Because implicitly declared kind variables in + -- non-CUSK type declarations are TyVarTvs, and we need to bring them + -- into scope as a skolem in an implication. This is OK, though, + -- because TyVarTvs will always remain tyvars, even after unification. + do { ev_binds_var <- newTcEvBinds + ; implic <- newImplication + ; let implic' = implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_given = given + , ic_wanted = wanted + , ic_binds = ev_binds_var + , ic_info = skol_info } + ; checkImplicationInvariants implic' + + ; return (unitBag implic', TcEvBinds ev_binds_var) } + +{- Note [When to build an implication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have some 'skolems' and some 'givens', and we are +considering whether to wrap the constraints in their scope into an +implication. We must /always/ do so if either 'skolems' or 'givens' are +non-empty. But what if both are empty? You might think we could +always drop the implication. Other things being equal, the fewer +implications the better. Less clutter and overhead. But we must +take care: + +* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors, + we'll make a /term-level/ evidence binding for 'g = error "blah"'. + We must have an EvBindsVar those bindings!, otherwise they end up as + top-level unlifted bindings, which are verboten. This only matters + at top level, so we check for that + See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors. + cf #14149 for an example of what goes wrong. + +* This is /necessary/ for top level but may be /desirable/ even for + nested bindings, because if the deferred coercion is bound too far + out it will be reported even if that thunk (say) is not evaluated. + +* If you have + f :: Int; f = f_blah + g :: Bool; g = g_blah + If we don't build an implication for f or g (no tyvars, no givens), + the constraints for f_blah and g_blah are solved together. And that + can yield /very/ confusing error messages, because we can get + [W] C Int b1 -- from f_blah + [W] C Int b2 -- from g_blan + and fundeps 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. + +Note [Herald for matchExpectedFunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'herald' always looks like: + "The equation(s) for 'f' have" + "The abstraction (\x.e) takes" + "The section (+ x) expects" + "The function 'f' is applied to" + +This is used to construct a message of form + + The abstraction `\Just 1 -> ...' takes two arguments + but its type `Maybe a -> a' has only one + + The equation(s) for `f' have two arguments + but its type `Maybe a -> a' has only one + + The section `(f 3)' requires 'f' to take two arguments + but its type `Int -> Int' has only one + + The function 'f' is applied to two arguments + but its type `Int -> Int' has only one + +When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the +picture, we have a choice in deciding whether to count the type applications as +proper arguments: + + The function 'f' is applied to one visible type argument + and two value arguments + but its type `forall a. a -> a` has only one visible type argument + and one value argument + +Or whether to include the type applications as part of the herald itself: + + The expression 'f @Int' is applied to two arguments + but its type `Int -> Int` has only one + +The latter is easier to implement and is arguably easier to understand, so we +choose to implement that option. + +Note [matchExpectedFunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +matchExpectedFunTys checks that a sigma has the form +of an n-ary function. It passes the decomposed type to the +thing_inside, and returns a wrapper to coerce between the two types + +It's used wherever a language construct must have a functional type, +namely: + A lambda expression + A function definition + An operator section + +This function must be written CPS'd because it needs to fill in the +ExpTypes produced for arguments before it can fill in the ExpType +passed in. + +Note [Return arguments with a fixed RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions + + - matchExpectedFunTys, + - matchActualFunTy, + - matchActualFunTys, + +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.tcLambdaMatches'). We end up with desugared Core that + looks like this: + + f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0])) + f = \ @(a :: TYPE (F Int)) -> + (\ (x :: (a |> (TYPE F[0]))) -> ()) + `cast` + (Sub (Sym (Dual[0] <(a |> (TYPE F[0]))>))) + + Two important transformations took place: + + 1. We inserted casts around the argument type to ensure that it has + a fixed runtime representation, as required by invariant (I1) from + Note [Representation polymorphism invariants] in GHC.Core. + 2. We inserted a cast around the whole lambda to make everything line up + with the type signature. +-} + +-- | Use this function to split off arguments types when you have an +-- \"expected\" type. +-- +-- This function skolemises at each polytype. +-- +-- Invariant: this function only applies the provided function +-- to a list of argument types which all have a syntactically fixed RuntimeRep +-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- See Note [Return arguments with a fixed RuntimeRep]. +matchExpectedFunTys :: forall a. + ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] + -> UserTypeCtxt + -> VisArity + -> ExpSigmaType + -> ([ExpPatType] -> ExpRhoType -> TcM a) + -> TcM (HsWrapper, a) +-- If matchExpectedFunTys n ty = (wrap, _) +-- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, +-- where [t1, ..., tn], ty_r are passed to the thing_inside +-- +-- Unconditionally concludes by skolemising any trailing invisible +-- binders and, if DeepSubsumption is on, it does so deeply. +-- +-- Postcondition: +-- If exp_ty is Check {}, then [ExpPatType] and ExpRhoType results are all Check{} +-- If exp_ty is Infer {}, then [ExpPatType] and ExpRhoType results are all Infer{} +matchExpectedFunTys herald _ctxt arity (Infer inf_res) thing_inside + = do { arg_tys <- mapM (new_infer_arg_ty herald) [1 .. arity] + ; res_ty <- newInferExpType (ir_inst inf_res) + ; result <- thing_inside (map ExpFunPatTy arg_tys) res_ty + ; arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) arg_tys + ; res_ty <- readExpType res_ty + -- Remarks: + -- 1. use tcMkScaledFunTys rather than mkScaledFunTys, as we might + -- have res_ty :: kappa[tau] for a meta ty-var kappa, in which case + -- mkScaledFunTys would crash. See #26277. + -- 2. tcMkScaledFunTys arg_tys res_ty does not contain any foralls + -- (even nested ones), so no need to instantiate. + ; co <- fillInferResultNoInst (tcMkScaledFunTys arg_tys res_ty) inf_res + ; return (mkWpCastN co, result) } + +matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside + = check arity [] top_ty + where + check :: VisArity -> [ExpPatType] -> TcSigmaType -> TcM (HsWrapper, a) + -- `check` is called only in the Check{} case + -- It collects rev_pat_tys in reversed order + -- n_req is the number of /visible/ arguments still needed + + ---------------------------- + -- Skolemise quantifiers, both visible (up to n_req) and invisible + -- See Note [Visible type application and abstraction] in GHC.Tc.Gen.App + check n_req rev_pat_tys ty + | isSigmaTy ty -- An invisible quantifier at the top + || (n_req > 0 && isForAllTy ty) -- A visible quantifier at top, and we need it + = do { rec { (n_req', wrap_gen, tv_nms, bndrs, given, inner_ty) <- skolemiseRequired skol_info n_req ty + ; let sig_skol = SigSkol ctx top_ty (tv_nms `zip` skol_tvs) + skol_tvs = binderVars bndrs + ; skol_info <- mkSkolemInfo sig_skol } + -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; (ev_binds, (wrap_res, result)) + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ + check n_req' + (reverse (map ExpForAllPatTy bndrs) ++ rev_pat_tys) + inner_ty + ; assertPpr (not (null bndrs && null given)) (ppr ty) $ + -- The guard ensures that we made some progress + return (wrap_gen <.> mkWpLet ev_binds <.> wrap_res, result) } + + ---------------------------- + -- Base case: (n_req == 0): no more args + -- The earlier skolemisation ensurs that rho_ty has no top-level invisible quantifiers + -- If there is deep subsumption, do deep skolemisation now + check n_req rev_pat_tys rho_ty + | n_req == 0 + = do { let pat_tys = reverse rev_pat_tys + ; ds_flag <- getDeepSubsumptionFlag + ; case ds_flag of + Shallow -> do { res <- thing_inside pat_tys (mkCheckExpType rho_ty) + ; return (idHsWrapper, res) } + Deep -> tcSkolemiseGeneral Deep ctx top_ty rho_ty $ \_ rho_ty -> + -- "_" drop the /deeply/-skolemise binders + -- They do not line up with binders in the Match + thing_inside pat_tys (mkCheckExpType rho_ty) } + + ---------------------------- + -- Function types + check n_req rev_pat_tys (FunTy { ft_af = af, ft_mult = mult + , ft_arg = arg_ty, ft_res = res_ty }) + = assert (isVisibleFunArg af) $ + do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc + ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty + ; (wrap_res, result) <- check (n_req - 1) + (mkCheckExpFunPatTy (Scaled mult arg_ty) : rev_pat_tys) + res_ty + ; let wrap_arg = mkWpCastN arg_co + fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty + ; return (fun_wrap, result) } + + ---------------------------- + -- Type variables + check n_req rev_pat_tys ty@(TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty' -> check n_req rev_pat_tys ty' + Flexi -> defer n_req rev_pat_tys ty } + + ---------------------------- + -- NOW do coreView. We didn't do it before, so that we do not unnecessarily + -- unwrap a synonym in the returned rho_ty + check n_req rev_pat_tys ty + | Just ty' <- coreView ty = check n_req rev_pat_tys ty' + + -- In all other cases we bale out into ordinary unification + -- However unlike the meta-tyvar case, we are sure that the + -- number of arguments doesn't match arity of the original + -- type, so we can add a bit more context to the error message + -- (cf #7869). + -- + -- It is not always an error, because specialized type may have + -- different arity, for example: + -- + -- > f1 = f2 'a' + -- > f2 :: Monad m => m Bool + -- > f2 = undefined + -- + -- But in that case we add specialized type into error context + -- anyway, because it may be useful. See also #9605. + check n_req rev_pat_tys res_ty + = addErrCtxtM (mkFunTysMsg herald (arity, top_ty)) $ + defer n_req rev_pat_tys res_ty + + ------------ + defer :: VisArity -> [ExpPatType] -> TcRhoType -> TcM (HsWrapper, a) + defer n_req rev_pat_tys fun_ty + = do { more_arg_tys <- mapM (new_check_arg_ty herald) [arity - n_req + 1 .. arity] + ; let all_pats = reverse rev_pat_tys ++ map mkCheckExpFunPatTy more_arg_tys + ; res_ty <- newOpenFlexiTyVarTy + ; result <- thing_inside all_pats (mkCheckExpType res_ty) + + ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty + ; return (mkWpCastN co, result) } + +new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpRhoTypeFRR) +new_infer_arg_ty herald arg_pos -- position for error messages only + = do { mult <- newFlexiTyVarTy multiplicityTy + ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy herald arg_pos) + ; return (mkScaled mult inf_hole) } + +new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType) +new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg + = do { mult <- newFlexiTyVarTy multiplicityTy + ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos) + ; return (mkScaled mult arg_ty) } + +mkFunTysMsg :: ExpectedFunTyOrigin + -> (VisArity, TcType) + -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) +-- See Note [Reporting application arity errors] +mkFunTysMsg herald (n_vis_args_in_call, fun_ty) env + = do { (env', fun_ty) <- zonkTidyTcType env fun_ty + + ; let (pi_ty_bndrs, _) = splitPiTys fun_ty + n_fun_args = count isVisiblePiTyBinder pi_ty_bndrs + + ; return (env', FunTysCtxt herald fun_ty n_vis_args_in_call n_fun_args) } + + +{- Note [Reporting application arity errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider f :: Int -> Int -> Int +and the call foo = f 3 4 5 +We'd like to get an error like: + + • Couldn't match expected type ‘t0 -> t’ with actual type ‘Int’ + • The function ‘f’ is applied to three visible arguments, -- What are "visible" arguments? + but its type ‘Int -> Int -> Int’ has only two -- See Note [Visibility and arity] in GHC.Types.Basic + +That is what `mkFunTysMsg` tries to do. But what is the "type of the function". +Most obviously, we can report its full, polymorphic type; that is simple and +explicable. But sometimes a bit odd. Consider + f :: Bool -> t Int Int + foo = f True 5 10 +We get this error: + • Couldn't match type ‘Int’ with ‘t0 -> t’ + Expected: Int -> t0 -> t + Actual: Int -> Int + • The function ‘f’ is applied to three visible arguments, + but its type ‘Bool -> t Int Int’ has only one + +That's not /quite/ right beause we can instantiate `t` to an arrow and get +two arrows (but not three!). With that in mind, one could consider reporting +the /instantiated/ type, and GHC used to do so. But it's more work, and in +some ways more confusing, especially when nested quantifiers are concerned, e.g. + f :: Bool -> forall t. t Int Int + +So we just keep it simple and report the original function type. + + +************************************************************************ +* * + Other matchExpected functions +* * +********************************************************************* -} + +matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) +-- Special case for lists +matchExpectedListTy exp_ty + = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty + ; return (co, elt_ty) } + +--------------------- +matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> * + -> TcRhoType -- orig_ty + -> TcM (TcCoercionN, -- T k1 k2 k3 a b c ~N orig_ty + [TcSigmaType]) -- Element types, k1 k2 k3 a b c + +-- It's used for wired-in tycons, so we call checkWiredInTyCon +-- Precondition: never called with FunTyCon +-- Precondition: input type :: * +-- Postcondition: (T k1 k2 k3 a b c) is well-kinded + +matchExpectedTyConApp tc orig_ty + = assertPpr (isAlgTyCon tc) (ppr tc) $ + go orig_ty + where + go ty + | Just ty' <- coreView ty + = go ty' + + go ty@(TyConApp tycon args) + | tc == tycon -- Common case + = return (mkNomReflCo ty, args) + + go (TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty -> go ty + Flexi -> defer } + + go _ = defer + + -- If the common case does not occur, instantiate a template + -- T k1 .. kn t1 .. tm, and unify with the original type + -- Doing it this way ensures that the types we return are + -- kind-compatible with T. For example, suppose we have + -- matchExpectedTyConApp T (f Maybe) + -- where data T a = MkT a + -- Then we don't want to instantiate T's data constructors with + -- (a::*) ~ Maybe + -- because that'll make types that are utterly ill-kinded. + -- This happened in #7368 + defer + = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc) + ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) + ; let args = mkTyVarTys arg_tvs + tc_template = mkTyConApp tc args + ; co <- unifyType Nothing tc_template orig_ty + ; return (co, args) } + +---------------------- +matchExpectedAppTy :: TcRhoType -- orig_ty + -> TcM (TcCoercion, -- m a ~N orig_ty + (TcSigmaType, TcSigmaType)) -- Returns m, a +-- If the incoming type is a mutable type variable of kind k, then +-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. + +matchExpectedAppTy orig_ty + = go orig_ty + where + go ty + | Just ty' <- coreView ty = go ty' + + | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty + = return (mkNomReflCo orig_ty, (fun_ty, arg_ty)) + + go (TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty -> go ty + Flexi -> defer } + + go _ = defer + + -- Defer splitting by generating an equality constraint + defer + = do { ty1 <- newFlexiTyVarTy kind1 + ; ty2 <- newFlexiTyVarTy kind2 + ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty + ; return (co, (ty1, ty2)) } + + orig_kind = typeKind orig_ty + kind1 = mkVisFunTyMany liftedTypeKind orig_kind + kind2 = liftedTypeKind -- m :: * -> k + -- arg type :: * + +{- ********************************************************************** +* + fillInferResult +* +********************************************************************** -} + +-- | 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 `IFRR_Check`, @t2@ is guaranteed +-- to have a syntactically fixed RuntimeRep, in the sense of +-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +fillInferResultNoInst :: TcType -> InferResult -> TcM TcCoercionN +fillInferResultNoInst 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 -- See (FIR1) + ; 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 + IFRR_Any -> return (mkNomReflCo act_res_ty, act_res_ty) + IFRR_Check frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty + + -- Compose the two coercions. + ; let final_co = prom_co `mkTransCo` frr_co + + ; writeTcRef ref (Just act_res_ty) + + ; return final_co } } + +fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper +-- See Note [Instantiation of InferResult] +fillInferResult ct_orig res_ty ires@(IR { ir_inst = iif }) + = case iif of + IIF_Sigma -> do { co <- fillInferResultNoInst res_ty ires + ; return (mkWpCastN co) } + IIF_ShallowRho -> do { (wrap, res_ty') <- topInstantiate ct_orig res_ty + ; co <- fillInferResultNoInst res_ty' ires + ; return (mkWpCastN co <.> wrap) } + IIF_DeepRho -> do { (wrap, res_ty') <- dsInstantiate ct_orig res_ty + ; co <- fillInferResultNoInst res_ty' ires + ; return (mkWpCastN co <.> wrap) } + +{- 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 + +(FIR1) There is one wrinkle. Suppose we have + case e of + T1 -> e1 :: (forall a. a->a) -> Int + G2 -> e2 + where T1 is not GADT or existential, but G2 is a GADT. Then suppose the + T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine. + But now the G2 alternative must not *just* unify with that else we'd risk + allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first + we'd have filled the hole with a unification variable, which enforces a + monotype. + + So if we check G2 second, we still want to emit a constraint that restricts + the RHS to be a monotype. This is done by ensureMonoType, and it works + by simply generating a constraint (alpha ~ ty), where alpha is a fresh +unification variable. We discard the evidence. + +Note [Instantiation of InferResult] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking expressions (not types, not patterns), we always almost +always instantiate before filling in `InferResult`, so that the result is a +TcRhoType. This behaviour is controlled by the `ir_inst :: InferInstFlag` +field of `InferResult`. + +If we do instantiate (ir_inst = IIF_DeepRho), and DeepSubsumption is enabled, +we instantiate deeply. See `tcInferResult`. + +Usually this field is `IIF_DeepRho` meaning "return a (possibly deep) rho-type". +Why is this the common case? See #17173 for discussion. Here are some examples +of why: + +1. Consider + f x = (*) + We want to instantiate the type of (*) before returning, else we + will infer the type + f :: forall {a}. a -> forall b. Num b => b -> b -> b + This is surely confusing for users. + + And worse, the monomorphism restriction won't work properly. The MR is + dealt with in simplifyInfer, and simplifyInfer has no way of + instantiating. This could perhaps be worked around, but it may be + hard to know even when instantiation should happen. + +2. Another reason. Consider + f :: (?x :: Int) => a -> a + g y = let ?x = 3::Int in f + Here want to instantiate f's type so that the ?x::Int constraint + gets discharged by the enclosing implicit-parameter binding. + +3. Suppose one defines plus = (+). If we instantiate lazily, we will + infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism + restriction compels us to infer + plus :: Integer -> Integer -> Integer + (or similar monotype). Indeed, the only way to know whether to apply + the monomorphism restriction at all is to instantiate + +HOWEVER, not always! Here are places where we want `IIF_Sigma` meaning +"return a sigma-type": + +* IIF_Sigma: In GHC.Tc.Module.tcRnExpr, which implements GHCi's :type + command, we want to return a completely uninstantiated type. + See Note [Implementing :type] in GHC.Tc.Module. + +* IIF_Sigma: In types we can't lambda-abstract, so we must be careful not to instantiate + at all. See calls to `runInferHsType` + +* IIF_Sigma: in patterns we don't want to instantiate at all. See the use of + `runInferSigmaFRR` in GHC.Tc.Gen.Pat + +* IIF_ShallowRho: in the expression part of a view pattern, we must top-instantiate + but /not/ deeply instantiate (#26331). See Note [View patterns and polymorphism] + in GHC.Tc.Gen.Pat. This the only place we use IIF_ShallowRho. + +Why do we want to deeply instantiate, ever? Why isn't top-instantiation enough? +Answer: to accept the following program (T26225b) with -XDeepSubsumption, we +need to deeply instantiate when inferring in checkResultTy: + + f :: Int -> (forall a. a->a) + g :: Int -> Bool -> Bool + + test b = + case b of + True -> f + False -> g + +If we don't deeply instantiate in the branches of the case expression, we will +try to unify the type of 'f' with that of 'g', which fails. If we instead +deeply instantiate 'f', we will fill the 'InferResult' with 'Int -> alpha -> alpha' +which then successfully unifies with the type of 'g' when we come to fill the +'InferResult' hole a second time for the second case branch. +-} + +{- +************************************************************************ +* * + Subsumption checking +* * +************************************************************************ + +Note [Subsumption checking: tcSubType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All the tcSubType calls have the form + tcSubType actual_ty expected_ty +which checks + actual_ty <= expected_ty + +That is, that a value of type actual_ty is acceptable in +a place expecting a value of type expected_ty. I.e. that + + actual ty is more polymorphic than expected_ty + +It returns a wrapper function + co_fn :: actual_ty ~ expected_ty +which takes an HsExpr of type actual_ty into one of type +expected_ty. + +Note [Ambiguity check and deep subsumption] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: (forall b. Eq b => a -> a) -> Int + +Does `f` have an ambiguous type? The ambiguity check usually checks +that this definition of f' would typecheck, where f' has the exact same +type as f: + f' :: (forall b. Eq b => a -> a) -> Intp + f' = f + +This will be /rejected/ with DeepSubsumption but /accepted/ with +ShallowSubsumption. On the other hand, this eta-expanded version f'' +would be rejected both ways: + f'' :: (forall b. Eq b => a -> a) -> Intp + f'' x = f x + +This is squishy in the same way as other examples in GHC.Tc.Validity +Note [The squishiness of the ambiguity check] + +The situation in June 2022. Since we have SimpleSubsumption at the moment, +we don't want introduce new breakage if you add -XDeepSubsumption, by +rejecting types as ambiguous that weren't ambiguous before. So, as a +holding decision, we /always/ use SimpleSubsumption for the ambiguity check +(erring on the side accepting more programs). Hence tcSubTypeAmbiguity. +-} + + + +----------------- +-- tcWrapResult needs both un-type-checked (for origins and error messages) +-- and type-checked (for wrapping) expressions +tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr + +tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcWrapResultO orig rn_expr expr actual_ty res_ty + = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty + , text "Expected:" <+> ppr res_ty ]) + ; wrap <- tcSubType orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty + ; return (mkHsWrap wrap expr) } + +-- | A version of 'tcWrapResult' to use when the actual type is a +-- rho-type, so nothing to instantiate; just go straight to unify. +-- It means we don't need to pass in a CtOrigin. +tcWrapResultMono :: HasDebugCallStack + => HsExpr GhcRn -> HsExpr GhcTc + -> TcRhoType -- ^ Actual; a rho-type, not a sigma-type + -> ExpRhoType -- ^ Expected + -> TcM (HsExpr GhcTc) +tcWrapResultMono rn_expr expr act_ty res_ty + = do { co <- tcSubTypeMono rn_expr act_ty res_ty + ; return (mkHsWrapCo co expr) } + +-- | A version of 'tcSubType' to use when the actual type is a rho-type, +-- so that no instantiation is needed. +tcSubTypeMono :: HasDebugCallStack + => HsExpr GhcRn + -> TcRhoType -- ^ Actual; a rho-type, not a sigma-type + -> ExpRhoType -- ^ Expected + -> TcM TcCoercionN +tcSubTypeMono rn_expr act_ty exp_ty + = assertPpr (isDeepRhoTy act_ty) + (vcat [ text "Actual type is not a (deep) rho-type." + , text "act_ty:" <+> ppr act_ty + , text "rn_expr:" <+> ppr rn_expr]) $ + case exp_ty of + Infer inf_res -> fillInferResultNoInst act_ty inf_res + Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty + +------------------------ +tcSubTypePat :: CtOrigin -> UserTypeCtxt + -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper +-- Used in patterns; polarity is backwards compared +-- to tcSubType +-- If wrap = tc_sub_type_et t1 t2 +-- => wrap :: t1 ~> t2 +tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected + = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected + +tcSubTypePat _ _ (Infer inf_res) ty_expected + = do { co <- fillInferResultNoInst ty_expected inf_res + -- In patterns we do not instantatiate + + ; return (mkWpCastN (mkSymCo co)) } + +--------------- + +-- | A subtype check that performs deep subsumption. +-- See also 'tcSubTypeMono', for when no instantiation is required. +tcSubTypeDS :: HsExpr GhcRn + -> TcRhoType -- Actual type -- a rho-type not a sigma-type + -> TcRhoType -- Expected type + -- DeepSubsumption <=> when checking, this type + -- is deeply skolemised + -> TcM HsWrapper +-- Only one call site, in GHC.Tc.Gen.App.tcApp +tcSubTypeDS rn_expr act_rho exp_rho + = tc_sub_type_deep Top (unifyExprType rn_expr) orig GenSigCtxt act_rho exp_rho + where + orig = exprCtOrigin rn_expr + +--------------- + +-- | Checks that the 'actual' type is more polymorphic than the 'expected' type. +tcSubType :: CtOrigin -- ^ Used when instantiating + -> UserTypeCtxt -- ^ Used when skolemising + -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known) + -> TcSigmaType -- ^ Actual type + -> ExpRhoType -- ^ Expected type + -> TcM HsWrapper +tcSubType inst_orig ctxt m_thing ty_actual res_ty + = case res_ty of + Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt + ty_actual ty_expected + + Infer inf_res -> fillInferResult inst_orig ty_actual inf_res + +--------------- +tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we + -- doing this subtype check? + -> UserTypeCtxt -- where did the expected type arise? + -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +-- External entry point, but no ExpTypes on either side +-- Checks that actual <= expected +-- Returns HsWrapper :: actual ~ expected +tcSubTypeSigma orig ctxt ty_actual ty_expected + = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected + +--------------- +tcSubTypeAmbiguity :: UserTypeCtxt -- Where did this type arise + -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +-- See Note [Ambiguity check and deep subsumption] +tcSubTypeAmbiguity ctxt ty_actual ty_expected + = tc_sub_type_ds Top Shallow (unifyType Nothing) + (AmbiguityCheckOrigin ctxt) + ctxt ty_actual ty_expected + +--------------- +addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a +addSubTypeCtxt ty_actual ty_expected thing_inside + | isRhoTy ty_actual -- If there is no polymorphism involved, the + , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) + = thing_inside -- gives enough context by itself + | otherwise + = addErrCtxtM mk_msg thing_inside + where + mk_msg tidy_env + = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual + ; ty_expected <- readExpType ty_expected + -- A worry: might not be filled if we're debugging. Ugh. + ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected + ; return (tidy_env, SubTypeCtxt ty_expected ty_actual) } + + +--------------- +tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify + -> CtOrigin -- Used when instantiating + -> UserTypeCtxt -- Used when skolemising + -> TcSigmaType -- Actual; a sigma-type + -> TcSigmaType -- Expected; also a sigma-type + -> TcM HsWrapper +-- Checks that actual_ty is more polymorphic than expected_ty +-- If wrap = tc_sub_type t1 t2 +-- => wrap :: t1 ~> t2 +-- +-- The "how to unify argument" is always a call to `uType TypeLevel orig`, +-- but with different ways of constructing the CtOrigin `orig` from +-- the argument types and context. + +---------------------- +tc_sub_type unify inst_orig ctxt ty_actual ty_expected + = do { ds_flag <- getDeepSubsumptionFlag + ; tc_sub_type_ds Top ds_flag unify inst_orig ctxt ty_actual ty_expected } + +---------------------- +tc_sub_type_ds :: Position p -- ^ position in the type (for error messages only) + -> DeepSubsumptionFlag + -> (TcType -> TcType -> TcM TcCoercionN) + -> CtOrigin -> UserTypeCtxt -> TcSigmaType + -> TcSigmaType -> TcM HsWrapper +-- tc_sub_type_ds is the main subsumption worker function +-- It takes an explicit DeepSubsumptionFlag +tc_sub_type_ds pos ds_flag unify inst_orig ctxt ty_actual ty_expected + | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] + , isRhoTyDS ds_flag ty_actual + = do { traceTc "tc_sub_type (drop to equality)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + ; mkWpCastN <$> + unify ty_actual ty_expected } + + | otherwise -- This is the general case + = do { traceTc "tc_sub_type (general case)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + + ; (sk_wrap, inner_wrap) + <- tcSkolemise ds_flag ctxt ty_expected $ \sk_rho -> + case ds_flag of + Deep -> tc_sub_type_deep pos unify inst_orig ctxt ty_actual sk_rho + Shallow -> tc_sub_type_shallow unify inst_orig ty_actual sk_rho + + ; return (sk_wrap <.> inner_wrap) } + +---------------------- +tc_sub_type_shallow :: (TcType -> TcType -> TcM TcCoercionN) + -> CtOrigin + -> TcSigmaType + -> TcRhoType -- Skolemised (shallow-ly) + -> TcM HsWrapper +tc_sub_type_shallow unify inst_orig ty_actual sk_rho + = do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual + ; cow <- unify rho_a sk_rho + ; return (mkWpCastN cow <.> wrap) } + +---------------------- +definitely_poly :: TcType -> Bool +-- A very conservative test: +-- see Note [Don't skolemise unnecessarily] +definitely_poly ty + | (tvs, theta, tau) <- tcSplitSigmaTy ty + , (tv:_) <- tvs -- At least one tyvar + , null theta -- No constraints; see (DP1) + , tv `isInjectiveInType` tau + -- The tyvar actually occurs (DP2), + -- and occurs in an injective position (DP3). + = True + | otherwise + = False + +{- Note [Don't skolemise unnecessarily] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are trying to solve + ty_actual <= ty_expected + (Char->Char) <= (forall a. a->a) +We could skolemise the 'forall a', and then complain +that (Char ~ a) is insoluble; but that's a pretty obscure +error. It's better to say that + (Char->Char) ~ (forall a. a->a) +fails. + +If we prematurely go to equality we'll reject a program we should +accept (e.g. #13752). So the test (which is only to improve error +message) is very conservative: + + * ty_actual is /definitely/ monomorphic: see `definitely_mono` + This definitely_mono test comes in "shallow" and "deep" variants + + * ty_expected is /definitely/ polymorphic: see `definitely_poly` + This definitely_poly test is more subtle than you might think. + Here are three cases where expected_ty looks polymorphic, but + isn't, and where it would be /wrong/ to switch to equality: + + (DP1) (Char->Char) <= (forall a. (a~Char) => a -> a) + + (DP2) (Char->Char) <= (forall a. Char -> Char) + + (DP3) (Char->Char) <= (forall a. F [a] Char -> Char) + where type instance F [x] t = t + + +Note [Coercion errors in tcSubMult] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment, we insist that all sub-multiplicity tests turn out +(once the typechecker has finished its work) to be equalities, +i.e. implementable by ReflCo. Why? Because our type system has +no way to express non-Refl sub-multiplicities. + +How can we check that every call to `tcSubMult` returns `Refl`? +It might not be `Refl` *yet*. + +[TODO: add counterexample #25130] + +So we take the following approach + +* In `tcEqMult`: + - Emit a perfectly ordinary Wanted equality constraint for the equality, + returning a coercion. + + - Wrap that coercion with `DE_Multiplicity` to make a `DelayedError`, and put + that delayed error into `wc_errors` of the current WantedConstraints. This + is done by `ensureReflMultiplicityCo`. + +* When solving constraints, discard any `DE_Multiplicity` errors that wrap a + reflective coercion, of kind `ty ~ ty`. This is done in + `GHC.Tc.Solver.simplifyDelayedErrors` + +* After constraint solving is complete report an error if there are any + remaining `DE_Multiplicity` errors. See + `GHC.Tc.Errors.reportMultiplicityCoercionErrs` + +Wrinkles + +(DME1) If the multiplicity constraint is /solved/, but with a non-reflective + coercion, we'll have just a `DE_Multiplicity` error left over. + + But if the multiplicity constraint is /unsolved/ (e.g. ManyTy ~ OneTy), we + will have /both/ an unsolved Wanted in `wc_simple`, /and/ a `DE_Multiplicity` + in `wc_errors`. We don't want to report both. Solution: suppress all + `DE_Multiplicity` constraints if there are any unsolved wanted. + + This way, the delayed error is indeed only reported when the constraint is + solved with a non-reflexivity coercion. + +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 () +tcSubMult origin w_actual w_expected + | Just (w1, w2) <- isMultMul w_actual = + do { tcSubMult origin w1 w_expected + ; tcSubMult origin w2 w_expected } + -- Currently, we consider p*q and sup p q to be equal. Therefore, p*q <= r is + -- equivalent to p <= r and q <= r. For other cases, we approximate p <= q by p + -- ~ q. This is not complete, but it's sound. See also Note [Overapproximating + -- multiplicities] in Multiplicity. +tcSubMult origin w_actual w_expected = + case submult w_actual w_expected of + Submult -> return () + Unknown -> tcEqMult origin w_actual w_expected + +tcEqMult :: CtOrigin -> Mult -> Mult -> TcM () +tcEqMult origin w_actual w_expected = do + { + -- Note that here we do not call to `submult`, so we check + -- for strict equality. + ; coercion <- unifyTypeAndEmit TypeLevel origin w_actual w_expected + -- See Note [Coercion errors in tcSubMult]. + ; ensureReflMultiplicityCo coercion origin } + + +{- ********************************************************************* +* * + Deep subsumption +* * +********************************************************************* -} + +{- Note [Deep subsumption] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The DeepSubsumption extension, documented here + + https://github.com/ghc-proposals/ghc-proposals/pull/511. + +makes a best-efforts attempt implement deep subsumption as it was +prior to the Simplify Subsumption proposal: + + https://github.com/ghc-proposals/ghc-proposals/pull/287 + +The effects are in these main places: + +1. In the subsumption check, tcSubType, we must do deep skolemisation: + see the call to tcSkolemise Deep in tc_sub_type_deep + +2. In tcPolyExpr we must do deep skolemisation: + see the call to tcSkolemise in tcSkolemiseExpType + +3. for expression type signatures (e :: ty), and functions with type + signatures (e.g. f :: ty; f = e), we must deeply skolemise the type; + see the call to tcDeeplySkolemise in tcSkolemiseScoped. + +4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result + type. Without deep subsumption, tcSubTypeMono would be sufficent. + +In all these cases note that the deep skolemisation must be done /first/. +Consider (1) + (forall a. Int -> a -> a) <= Int -> (forall b. b -> b) +We must skolemise the `forall b` before instantiating the `forall a`. +See also Note [Deep skolemisation]. + +Wrinkles: + +(DS1) Note that we /always/ use shallow subsumption in the ambiguity check. + See Note [Ambiguity check and deep subsumption]. + +(DS2) When doing deep subsumption, we must be careful not to needlessly + drop down to unification, e.g. in cases such as: + (Bool -> ∀ d. d->d) <= alpha beta gamma + See Note [FunTy vs non-FunTy case in tc_sub_type_deep]. + +(DS3) The interaction between deep subsumption and required foralls + (forall a -> ty) is a bit subtle. See #24696 and + Note [Deep subsumption and required foralls] + +Note [Deep skolemisation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +deeplySkolemise decomposes and skolemises a type, returning a type +with all its arrows visible (ie not buried under foralls) + +Examples: + + deeplySkolemise (Int -> forall a. Ord a => blah) + = ( wp, [a], [d:Ord a], Int -> blah ) + where wp = \x:Int. /\a. \(d:Ord a). x + + deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah) + = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah ) + where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). x + +In general, + if deeplySkolemise ty = (wrap, tvs, evs, rho) + and e :: rho + then wrap e :: ty + and 'wrap' binds tvs, evs + +ToDo: this eta-abstraction plays fast and loose with termination, + because it can introduce extra lambdas. Maybe add a `seq` to + fix this + +Note [FunTy vs FunTy case in tc_sub_type_deep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The goal of tc_sub_type_deep is to produce an HsWrapper that "proves" that the +actual type is a subtype of the expected type. The most important case is how +we deal with function arrows. Suppose we have: + + ty_actual = act_arg -> act_res + ty_expected = exp_arg -> exp_res + +To produce fun_wrap :: (act_arg -> act_res) ~> (exp_arg -> exp_res), we use +the fact that the function arrow is contravariant in its argument type and +covariant in its result type. Thus we recursively perform subtype checks +on the argument types (with actual/expected switched) and the result types, +to get: + + arg_wrap :: exp_arg ~> act_arg -- NB: expected/actual have switched sides + res_wrap :: act_res ~> exp_res + +Then fun_wrap = mkWpFun arg_wrap res_wrap. + +Wrinkle [Representation-polymorphism checking during subtyping] + + Inserting a WpFun HsWrapper amounts to impedance matching in deep subsumption + via eta-expansion: + + f ==> \ (x :: exp_arg) -> res_wrap [ f (arg_wrap [x]) ] + + As we produce a lambda, we must enforce the representation polymorphism + invariants described in Note [Representation polymorphism invariants] in GHC.Core. + That is, we must ensure that both x (the lambda binder) and (arg_wrap [x]) (the function argument) + have a fixed runtime representation. + + Note however that desugaring mkWpFun does not always introduce a lambda: if + both the argument and result HsWrappers are casts, then a FunCo cast suffices, + in which case we should not perform representation-polymorphism checking. + + This means that, in the FunTy/FunTy case of tc_sub_type_deep, we can skip + the representation-polymorphism checks if the produced argument and result + wrappers are identities or casts. + It is important to do so, otherwise we reject valid programs. + + Here's a contrived example (there are undoubtedly more natural examples) + (see testsuite/tests/rep-poly/NoEtaRequired): + + type Id :: k -> k + type family Id a where + + type T :: TYPE r -> TYPE (Id r) + type family T a where + + test :: forall r (a :: TYPE r). a :~~: T a -> () + test HRefl = + let + f :: (a -> a) -> () + f _ = () + g :: T a -> T a + g = undefined + in f g + + We don't need to eta-expand `g` to make `f g` typecheck; a cast suffices. + Hence we should not perform representation-polymorphism checks; they would + fail here. + +Note [Setting the argument context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider we are doing the ambiguity check for the (bogus) + f :: (forall a b. C b => a -> a) -> Int + +We'll call + tcSubType ((forall a b. C b => a->a) -> Int ) + ((forall a b. C b => a->a) -> Int ) + +with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing +on the argument type of the (->) -- and at that point we want to switch +to a UserTypeCtxt of GenSigCtxt. Why? + +* Error messages. If we stick with FunSigCtxt we get errors like + * Could not deduce: C b + from the context: C b0 + bound by the type signature for: + f :: forall a b. C b => a->a + But of course f does not have that type signature! + Example tests: T10508, T7220a, Simple14 + +* Implications. We may decide to build an implication for the whole + ambiguity check, but we don't need one for each level within it, + and TcUnify.alwaysBuildImplication checks the UserTypeCtxt. + See Note [When to build an implication] + +Note [Multiplicity in deep subsumption] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + t1 ->{mt} t2 <= s1 ->{ms} s2 + +At the moment we /unify/ ms~mt, via tcEqMult. + +Arguably we should use `tcSubMult`. But then if mt=m0 (a unification +variable) and ms=Many, `tcSubMult` is a no-op (since anything is a +sub-multiplicty of Many). But then `m0` may never get unified with +anything. It is then skolemised by the zonker; see GHC.HsToCore.Binds +Note [Free tyvars on rule LHS]. So we in RULE foldr/app in GHC.Base +we get this + + "foldr/app" [1] forall ys m1 m2. foldr (\x{m1} \xs{m2}. (:) x xs) ys + = \xs -> xs ++ ys + +where we eta-expanded that (:). But now foldr expects an argument +with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint +complains. + +The easiest solution was to unify the multiplicities in tc_sub_type_deep, +insisting on equality. This is only in the DeepSubsumption code anyway. + +Note [FunTy vs non-FunTy case in tc_sub_type_deep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this, without Quick Look, but with Deep Subsumption: + f :: ∀a b c. a b c -> Int + g :: Bool -> ∀d. d -> d +To typecheck the application (f g), we need to do the subsumption test + + (Bool -> ∀ d. d->d) <= alpha beta gamma + +where alpha, beta, gamma are the unification variables that instantiate a,b,c +(respectively). We must not drop down to unification, or we will reject the call. +Instead, we should only unify alpha := (->), in which case we end up with the +usual FunTy vs FunTy case of Note [FunTy vs FunTy case in tc_sub_type_deep]: + + (Bool -> ∀ d. d->d) <= beta -> gamma + +which is straightforwardly solved by beta := Bool, using covariance in the return +type of the function arrow, and instantiating the forall before unifying with gamma. + +The conclusion is this: when doing a deep subtype check (in tc_sub_type_deep), +if the LHS is a FunTy and the RHS is a rho-type which is not a FunTy, +then unify the RHS with a FunTy and continue by performing a sub-type check on +the LHS vs the new RHS. And vice-versa (if it's the RHS that is a FunTy). + +See T11305 and T26225 for examples of when this is important. + +Note [Deep subsumption and required foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A required forall, (forall a -> ty) behaves like a "rho-type", one with no +top-level quantification. In particular, it is neither implicitly instantiated nor +skolemised. So + + rid1 :: forall a -> a -> a + rid1 = id + + rid2 :: forall a -> a -> a + rid2 a = id + +Here `rid2` wll typecheck, but `rid1` will not, because we don't implicitly skolemise +the type. + +This "no implicit subsumption nor skolemisation" applies during subsumption. +For example + (forall a. a->a) <= (forall a -> a -> a) -- NOT! +does /not/ hold, because that would require implicitly skoleming the (forall a->). + +Note also that, in Core, `eqType` distinguishes between + (forall a. blah) and forall a -> blah) +See discussion on #22762 and these Notes in GHC.Core.TyCo.Compare + * Note [ForAllTy and type equality] + * Note [Comparing visibility] + +So during deep subsumption we simply stop (and drop down to equality) when we encounter +a (forall a->). This is a little odd: +* Deep subsumption looks inside invisible foralls (forall a. ty) +* Deep subsumption looks inside arrows (t1 -> t2) +* But it does not look inside required foralls (forall a -> ty) + +There is discussion on #24696. How is this implemented? + +* In `tc_sub_type_deep`, the calls to `topInstantiate` and `deeplyInstantiate` + instantiate only /invisible/ binders. +* In `tc_sub_type_ds`, the call to `tcSkolemise` skolemises only /invisible/ + binders. + +Here is a slightly more powerful alternative +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + In the story above, if we have + (forall a -> Eq a => a -> a) <= (forall a -> Ord a => a -> a) +we'll reject it, because both are rho-types but they aren't equal. But in the +"drop to equality" stage we could instead see if both rho-types are headed with +(forall a ->) and if so strip that off and go back into deep subsumption. + +This is a bit more powerful, but also a bit more complicated, so GHC +doesn't do it yet, awaiting credible user demand. See #24696. +-} + +data DeepSubsumptionFlag = Deep | Shallow + +instance Outputable DeepSubsumptionFlag where + ppr Deep = text "Deep" + ppr Shallow = text "Shallow" + +getDeepSubsumptionFlag :: TcM DeepSubsumptionFlag +getDeepSubsumptionFlag = do { ds <- xoptM LangExt.DeepSubsumption + ; if ds then return Deep else return Shallow } + +-- | 'tc_sub_type_deep' is where the actual work happens for deep subsumption. +-- +-- Given @ty_actual@ (a sigma-type) and @ty_expected@ (deeply skolemised, i.e. +-- a deep rho type), it returns an 'HsWrapper' @wrap :: ty_actual ~> ty_expected@. +tc_sub_type_deep :: HasDebugCallStack + => Position p -- ^ Position in the type (for error messages only) + -> (TcType -> TcType -> TcM TcCoercionN) -- ^ How to unify + -> CtOrigin -- ^ Used when instantiating + -> UserTypeCtxt -- ^ Used when skolemising + -> TcSigmaType -- ^ Actual; a sigma-type + -> TcRhoType -- ^ Expected; deeply skolemised + -> TcM HsWrapper + +-- If wrap = tc_sub_type_deep t1 t2 +-- => wrap :: t1 ~> t2 +-- Here is where the work actually happens! +-- Precondition: ty_expected is deeply skolemised + +tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected + = assertPpr (isDeepRhoTy ty_expected) (ppr ty_expected) $ + do { traceTc "tc_sub_type_deep" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + ; go ty_actual ty_expected } + where + + -- 'unwrap' removes top-level type synonyms & looks through filled meta-tyvars + unwrap :: TcType -> TcM TcType + unwrap ty + | Just ty' <- coreView ty + = unwrap ty' + unwrap ty@(TyVarTy tv) + = do { lookup_res <- isFilledMetaTyVar_maybe tv + ; case lookup_res of + Just ty' -> unwrap ty' + Nothing -> return ty } + unwrap ty = return ty + + go, go1 :: TcType -> TcType -> TcM HsWrapper + go ty_a ty_e = + do { ty_a' <- unwrap ty_a + ; ty_e' <- unwrap ty_e + ; go1 ty_a' ty_e' } + + -- If ty_actual is not a rho-type, instantiate it first; otherwise + -- unification has no chance of succeeding. + go1 ty_a ty_e + | let (tvs, theta, _) = tcSplitSigmaTy ty_a + , not (null tvs && null theta) + = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a + ; body_wrap <- go in_rho ty_e + ; return (body_wrap <.> in_wrap) } + + -- Main case: FunTy vs FunTy. go_fun does the work. + go1 (FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }) + (FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res }) + | isVisibleFunArg af1 + , isVisibleFunArg af2 + = go_fun af1 act_mult act_arg act_res + af2 exp_mult exp_arg exp_res + + -- See Note [FunTy vs non-FunTy case in tc_sub_type_deep] + go1 (FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }) ty_e + | isVisibleFunArg af1 + = do { exp_mult <- newMultiplicityVar + ; exp_arg <- newOpenFlexiTyVarTy -- NB: no FRR check needed; we might not need to eta-expand + ; exp_res <- newOpenFlexiTyVarTy + ; let exp_funTy = FunTy { ft_af = af1, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res } + ; unify_wrap <- just_unify exp_funTy ty_e + ; fun_wrap <- go_fun af1 act_mult act_arg act_res af1 exp_mult exp_arg exp_res + ; return $ unify_wrap <.> fun_wrap + -- unify_wrap :: exp_funTy ~> ty_e + -- fun_wrap :: ty_a ~> exp_funTy + } + go1 ty_a (FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res }) + | isVisibleFunArg af2 + = do { act_mult <- newMultiplicityVar + ; act_arg <- newOpenFlexiTyVarTy -- NB: no FRR check needed; we might not need to eta-expand + ; act_res <- newOpenFlexiTyVarTy + ; let act_funTy = FunTy { ft_af = af2, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res } + + ; unify_wrap <- just_unify ty_a act_funTy + ; fun_wrap <- go_fun af2 act_mult act_arg act_res af2 exp_mult exp_arg exp_res + ; return $ fun_wrap <.> unify_wrap + -- unify_wrap :: ty_a ~> act_funTy + -- fun_wrap :: act_funTy ~> ty_e + } + + -- Otherwise, revert to unification. + go1 ty_a ty_e = just_unify ty_a ty_e + + just_unify ty_a ty_e = do { cow <- unify ty_a ty_e + ; return (mkWpCastN cow) } + + -- FunTy/FunTy case: this is where we insert any necessary eta-expansions. + go_fun :: FunTyFlag -> Mult -> TcType -> TcType -- actual FunTy + -> FunTyFlag -> Mult -> TcType -> TcType -- expected FunTy + -> TcM HsWrapper + go_fun act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res + -- See Note [FunTy vs FunTy case in tc_sub_type_deep] + = do { arg_wrap <- tc_sub_type_ds (Argument pos) Deep unify given_orig GenSigCtxt exp_arg act_arg + -- GenSigCtxt: See Note [Setting the argument context] + ; res_wrap <- tc_sub_type_deep (Result pos) unify inst_orig ctxt act_res exp_res + + ; mkWpFun_FRR unify pos + act_af act_mult act_arg act_res + exp_af exp_mult exp_arg exp_res + arg_wrap res_wrap + } + where + given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) + +-- | Like 'mkWpFun', except that it performs the necessary +-- representation-polymorphism checks on the argument type in the case that +-- we introduce a lambda abstraction. +mkWpFun_FRR + :: (TcType -> TcType -> TcM TcCoercionN) -- ^ how to unify + -> Position p + -> FunTyFlag -> Type -> TcType -> Type -- actual FunTy + -> FunTyFlag -> Type -> TcType -> Type -- expected FunTy + -> HsWrapper -- ^ exp_arg ~> act_arg + -> HsWrapper -- ^ act_res ~> exp_res + -> TcM HsWrapper -- ^ act_funTy ~> exp_funTy +mkWpFun_FRR unify pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap + = do { ((exp_arg_co, exp_arg_frr), (act_arg_co, _act_arg_frr)) <- + if needs_frr_checks + -- See Wrinkle [Representation-polymorphism checking during subtyping] + then do { exp_frr_wrap <- hasFixedRuntimeRep (frr_ctxt True ) exp_arg + ; act_frr_wrap <- hasFixedRuntimeRep (frr_ctxt False) act_arg + ; return (exp_frr_wrap, act_frr_wrap) } + else return ((mkNomReflCo exp_arg, exp_arg), (mkNomReflCo act_arg, act_arg)) + + -- Enforce equality of multiplicities (not the more natural sub-multiplicity). + -- See Note [Multiplicity in deep subsumption] + ; act_arg_mult_co <- unify act_mult exp_mult + -- NB: don't use tcEqMult: that would require the evidence for + -- equality to be Refl, but it might well not be (#26332). + + ; let + exp_arg_fun_co = + mkFunCo Nominal exp_af + (mkReflCo Nominal exp_mult) + (mkSymCo exp_arg_co) + (mkReflCo Nominal exp_res) + act_arg_fun_co = + mkFunCo Nominal act_af + act_arg_mult_co + act_arg_co + (mkReflCo Nominal act_res) + arg_wrap_frr = + mkWpCastN (mkSymCo exp_arg_co) <.> arg_wrap <.> mkWpCastN act_arg_co + -- exp_arg_co :: exp_arg ~> exp_arg_frr + -- act_arg_co :: act_arg ~> act_arg_frr + -- arg_wrap :: exp_arg ~> act_arg + -- arg_wrap_frr :: exp_arg_frr ~> act_arg_frr + + ; return $ + mkWpCastN exp_arg_fun_co + <.> + mkWpFun arg_wrap_frr res_wrap (Scaled exp_mult exp_arg_frr) exp_res + <.> + mkWpCastN act_arg_fun_co + } + where + needs_frr_checks :: Bool + needs_frr_checks = + not (hole_or_cast arg_wrap) + || + not (hole_or_cast res_wrap) + hole_or_cast :: HsWrapper -> Bool + hole_or_cast WpHole = True + hole_or_cast (WpCast {}) = True + hole_or_cast _ = False + frr_ctxt :: Bool -> FixedRuntimeRepContext + frr_ctxt is_exp_ty = + FRRDeepSubsumption + { frrDSExpected = is_exp_ty + , frrDSPosition = pos + } + +----------------------- +deeplySkolemise :: SkolemInfo -> TcSigmaType + -> TcM ( HsWrapper + , [(Name,TcInvisTVBinder)] -- All skolemised variables + , [EvVar] -- All "given"s + , TcRhoType ) +-- See Note [Deep skolemisation] +deeplySkolemise skol_info ty + = go init_subst ty + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) + + go subst ty + | Just (arg_tys, bndrs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty + = do { let arg_tys' = substScaledTys subst arg_tys + ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' + ; (subst', bndrs1) <- tcInstSkolTyVarBndrsX skol_info subst bndrs + ; ev_vars1 <- newEvVars (substTheta subst' theta) + ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' + ; let tvs = binderVars bndrs + tvs1 = binderVars bndrs1 + tv_prs1 = map tyVarName tvs `zip` bndrs1 + ; return ( mkWpEta ids1 (mkWpTyLams tvs1 + <.> mkWpEvLams ev_vars1 + <.> wrap) + , tv_prs1 ++ tvs_prs2 + , ev_vars1 ++ ev_vars2 + , mkScaledFunTys arg_tys' rho ) } + + | otherwise + = return (idHsWrapper, [], [], substTy subst ty) + -- substTy is a quick no-op on an empty substitution + +dsInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type) +-- Do topInstantiate or deeplyInstantiate, depending on -XDeepSubsumption +dsInstantiate orig ty + = do { ds_flag <- getDeepSubsumptionFlag + ; case ds_flag of + Shallow -> topInstantiate orig ty + Deep -> deeplyInstantiate orig ty } + +deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type) +-- Instantiate invisible foralls, even ones nested +-- (to the right) under arrows +deeplyInstantiate orig ty + = go init_subst ty + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) + + go subst ty + | Just (arg_tys, bndrs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty + = do { let tvs = binderVars bndrs + ; (subst', tvs') <- newMetaTyVarsX subst tvs + ; let arg_tys' = substScaledTys subst' arg_tys + theta' = substTheta subst' theta + ; ids1 <- newSysLocalIds (fsLit "di") arg_tys' + ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' + ; (wrap2, rho2) <- go subst' rho + ; return (mkWpEta ids1 (wrap2 <.> wrap1), + mkScaledFunTys arg_tys' rho2) } + + | otherwise + = do { let ty' = substTy subst ty + ; return (idHsWrapper, ty') } + +tcDeepSplitSigmaTy_maybe + :: TcSigmaType -> Maybe ([Scaled TcType], [TcInvisTVBinder], ThetaType, TcSigmaType) +-- Looks for a *non-trivial* quantified type, under zero or more function arrows +-- By "non-trivial" we mean either tyvars or constraints are non-empty +tcDeepSplitSigmaTy_maybe ty + = go ty + where + go ty | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty + , Just (arg_tys, tvs, theta, rho) <- go res_ty + = Just (arg_ty:arg_tys, tvs, theta, rho) + + | (tvs, theta, rho) <- tcSplitSigmaTyBndrs ty + , not (null tvs && null theta) + = Just ([], tvs, theta, rho) + + | otherwise = Nothing + +isDeepRhoTy :: TcType -> Bool +-- True if there are no foralls or (=>) at the top, or nested under +-- arrows to the right. e.g +-- forall a. a False +-- Int -> forall a. a False +-- (forall a. a) -> Int True +-- Returns True iff tcDeepSplitSigmaTy_maybe returns Nothing +isDeepRhoTy ty + | not (isRhoTy ty) = False -- Foralls or (=>) at top + | Just (_, res) <- tcSplitFunTy_maybe ty = isDeepRhoTy res + | otherwise = True -- No forall, (=>), or (->) at top + +isRhoTyDS :: DeepSubsumptionFlag -> TcType -> Bool +isRhoTyDS ds_flag ty + = case ds_flag of + Shallow -> isRhoTy ty -- isRhoTy: no top level forall or (=>) + Deep -> isDeepRhoTy ty -- "deep" version: no nested forall or (=>) + +{- +************************************************************************ +* * + Boxy unification +* * +************************************************************************ + +The exported functions are all defined as versions of some +non-exported generic functions. +-} + +unifyExprType :: HsExpr GhcRn -> TcType -> TcType -> TcM TcCoercionN +unifyExprType rn_expr ty1 ty2 + = unifyType (Just (HsExprRnThing rn_expr)) ty1 ty2 + +unifyType :: Maybe TypedThing -- ^ If present, the thing that has type ty1 + -> TcTauType -> TcTauType -- ty1 (actual), ty2 (expected) + -> TcM TcCoercionN -- :: ty1 ~# ty2 +-- Actual and expected types +-- Returns a coercion : ty1 ~ ty2 +unifyType thing ty1 ty2 + = unifyTypeAndEmit TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = thing + , uo_visible = True } + +unifyInvisibleType :: TcTauType -> TcTauType -- ty1 (actual), ty2 (expected) + -> TcM TcCoercionN -- :: ty1 ~# ty2 +-- Actual and expected types +-- Returns a coercion : ty1 ~ ty2 +unifyInvisibleType ty1 ty2 + = unifyTypeAndEmit TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = Nothing + , uo_visible = False } -- This is the "invisible" bit + +unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN +-- Like unifyType, but swap expected and actual in error messages +-- This is used when typechecking patterns +unifyTypeET ty1 ty2 + = unifyTypeAndEmit TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty2 -- NB swapped + , uo_expected = ty1 -- NB swapped + , uo_thing = Nothing + , uo_visible = True } + + +unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN +unifyKind mb_thing ty1 ty2 + = unifyTypeAndEmit KindLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = mb_thing + , uo_visible = True } + +unifyTypeAndEmit :: TypeOrKind -> CtOrigin -> TcType -> TcType -> TcM CoercionN +-- Make a ref-cell, unify, emit the collected constraints +unifyTypeAndEmit t_or_k orig ty1 ty2 + = do { ref <- newTcRef emptyBag + ; loc <- getCtLocM orig (Just t_or_k) + ; let env = UE { u_loc = loc, u_role = Nominal + , u_rewriters = emptyRewriterSet -- ToDo: check this + , u_defer = ref, u_unified = Nothing } + + -- The hard work happens here + ; co <- uType env ty1 ty2 + + ; cts <- readTcRef ref + ; unless (null cts) (emitSimples cts) + ; return co } + +{- +%************************************************************************ +%* * + uType and friends +%* * +%************************************************************************ + +Note [The eager unifier] +~~~~~~~~~~~~~~~~~~~~~~~~ +The eager unifier, `uType`, is called by + + * The constraint generator (e.g. in GHC.Tc.Gen.Expr), + via the wrappers `unifyType`, `unifyKind` etc + + * The constraint solver (e.g. in GHC.Tc.Solver.Equality), + via `GHC.Tc.Solver.Monad.wrapUnifierTcS`. + +`uType` runs in the TcM monad, but it carries a UnifyEnv that tells it +what to do when unifying a variable or deferring a constraint. Specifically, + * it collects deferred constraints in `u_defer`, and + * it records which unification variables it has unified in `u_unified` +Then it is up to the wrappers (one for the constraint generator, one for +the constraint solver) to deal with these collected sets. + +Although `uType` runs in the TcM monad for convenience, really it could +operate just with the ability to + * write to the accumulators of deferred constraints + and unification variables in UnifyEnv. + * read and update existing unification variables + * zonk types befire unifying (`zonkTcType` in `uUnfilledVar`, and + `zonkTyCoVarKind` in `uUnfilledVar1` + * create fresh coercion holes (`newCoercionHole`) + * emit tracing info for debugging + * look at the ambient TcLevel: `getTcLevel` +A job for the future. +-} + +data UnifyEnv + = UE { u_role :: Role + , u_loc :: CtLoc + , u_rewriters :: RewriterSet + + -- Deferred constraints + , u_defer :: TcRef (Bag Ct) + + -- Which variables are unified; + -- if Nothing, we don't care + , u_unified :: Maybe (TcRef [TcTyVar]) + } + +setUEnvRole :: UnifyEnv -> Role -> UnifyEnv +setUEnvRole uenv role = uenv { u_role = role } + +updUEnvLoc :: UnifyEnv -> (CtLoc -> CtLoc) -> UnifyEnv +updUEnvLoc uenv@(UE { u_loc = loc }) upd = uenv { u_loc = upd loc } + +mkKindEnv :: UnifyEnv -> TcType -> TcType -> UnifyEnv +-- Modify the UnifyEnv to be right for unifing +-- the kinds of these two types +mkKindEnv env@(UE { u_loc = ctloc }) ty1 ty2 + = env { u_role = Nominal, u_loc = mkKindEqLoc ty1 ty2 ctloc } + +uType, uType_defer + :: UnifyEnv + -> TcType -- ty1 is the *actual* type + -> TcType -- ty2 is the *expected* type + -> TcM CoercionN + +-- It is always safe to defer unification to the main constraint solver +-- See Note [Deferred unification] +uType_defer (UE { u_loc = loc, u_defer = ref + , u_role = role, u_rewriters = rewriters }) + ty1 ty2 -- ty1 is "actual", ty2 is "expected" + = do { let pred_ty = mkEqPredRole role ty1 ty2 + ; hole <- newCoercionHole pred_ty + ; let ct = mkNonCanonical $ CtWanted $ + WantedCt { ctev_pred = pred_ty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = rewriters } + co = HoleCo hole + ; updTcRef ref (`snocBag` ct) + -- snocBag: see Note [Work-list ordering] in GHC.Tc.Solver.Equality + + -- Error trace only + -- NB. do *not* call mkErrCtxt unless tracing is on, + -- because it is hugely expensive (#5631) + ; whenDOptM Opt_D_dump_tc_trace $ + do { ctxt <- getErrCtxt + ; err_ctxt <- mkErrCtxt emptyTidyEnv ctxt + ; traceTc "utype_defer" $ + vcat ( ppr role + : debugPprType ty1 + : debugPprType ty2 + : map pprErrCtxtMsg err_ctxt ) + ; traceTc "utype_defer2" (ppr co) } + + ; return co } + + +-------------- +uType env@(UE { u_role = role }) orig_ty1 orig_ty2 + | Phantom <- role + = do { kind_co <- uType (mkKindEnv env orig_ty1 orig_ty2) + (typeKind orig_ty1) (typeKind orig_ty2) + ; return (mkPhantomCo kind_co orig_ty1 orig_ty2) } + + | otherwise + = do { tclvl <- getTcLevel + ; traceTc "u_tys" $ vcat + [ text "tclvl" <+> ppr tclvl + , sep [ ppr orig_ty1, text "~" <> ppr role, ppr orig_ty2] ] + ; co <- go orig_ty1 orig_ty2 + ; if isReflCo co + then traceTc "u_tys yields no coercion" Outputable.empty + else traceTc "u_tys yields coercion:" (ppr co) + ; return co } + where + go :: TcType -> TcType -> TcM CoercionN + -- The arguments to 'go' are always semantically identical + -- to orig_ty{1,2} except for looking through type synonyms + + -- Unwrap casts before looking for variables. This way, we can easily + -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we + -- didn't do it this way, and then the unification above was deferred. + go (CastTy t1 co1) t2 + = do { co_tys <- uType env t1 t2 + ; return (mkCoherenceLeftCo role t1 co1 co_tys) } + + go t1 (CastTy t2 co2) + = do { co_tys <- uType env t1 t2 + ; return (mkCoherenceRightCo role t2 co2 co_tys) } + + -- Variables; go for uUnfilledVar + -- Note that we pass in *original* (before synonym expansion), + -- so that type variables tend to get filled in with + -- the most informative version of the type + go (TyVarTy tv1) ty2 + = do { lookup_res <- isFilledMetaTyVar_maybe tv1 + ; case lookup_res of + Just ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) + ; uType env ty1 orig_ty2 } + Nothing -> uUnfilledVar env NotSwapped tv1 ty2 } + + go ty1 (TyVarTy tv2) + = do { lookup_res <- isFilledMetaTyVar_maybe tv2 + ; case lookup_res of + Just ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) + ; uType env orig_ty1 ty2 } + Nothing -> uUnfilledVar env IsSwapped tv2 ty1 } + + -- See Note [Unifying type synonyms] in GHC.Core.Unify + go ty1@(TyConApp tc1 []) (TyConApp tc2 []) + | tc1 == tc2 + = return $ mkReflCo role ty1 + + -- Now expand synonyms + -- See Note [Expanding synonyms during unification] + -- + -- Also NB that we recurse to 'go' so that we don't push a + -- new item on the origin stack. As a result if we have + -- type Foo = Int + -- and we try to unify Foo ~ Bool + -- we'll end up saying "can't match Foo with Bool" + -- rather than "can't match "Int with Bool". See #4535. + go ty1 ty2 + | Just ty1' <- coreView ty1 = go ty1' ty2 + | Just ty2' <- coreView ty2 = go ty1 ty2' + + -- Functions (t1 -> t2) just check the two parts + go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 }) + (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 }) + | isVisibleFunArg af1 -- Do not attempt (c => t); just defer + , af1 == af2 -- Important! See #21530 + = do { co_w <- uType (env { u_role = funRole role SelMult }) w1 w2 + ; co_l <- uType (env { u_role = funRole role SelArg }) arg1 arg2 + ; co_r <- uType (env { u_role = funRole role SelRes }) res1 res2 + ; return $ mkNakedFunCo role af1 co_w co_l co_r } + + -- Always defer if a type synonym family (type function) + -- is involved. (Data families behave rigidly.) + go ty1@(TyConApp tc1 _) ty2 + | isTypeFamilyTyCon tc1 = defer ty1 ty2 + go ty1 ty2@(TyConApp tc2 _) + | isTypeFamilyTyCon tc2 = defer ty1 ty2 + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + -- See Note [Mismatched type lists and application decomposition] + | tc1 == tc2, equalLength tys1 tys2 + , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality + = assertPpr (isGenerativeTyCon tc1 role) (ppr tc1) $ + do { traceTc "go-tycon" (ppr tc1 $$ ppr tys1 $$ ppr tys2 $$ ppr (take 10 (tyConRoleListX role tc1))) + ; cos <- zipWith4M u_tc_arg (tyConVisibilities tc1) -- Infinite + (tyConRoleListX role tc1) -- Infinite + tys1 tys2 + ; return $ mkTyConAppCo role tc1 cos } + + go (LitTy m) ty@(LitTy n) + | m == n + = return $ mkReflCo role ty + + -- See Note [Care with type applications] + -- Do not decompose FunTy against App; + -- it's often a type error, so leave it for the constraint solver + go ty1@(AppTy s1 t1) ty2@(AppTy s2 t2) + = go_app (isNextArgVisible s1) ty1 s1 t1 ty2 s2 t2 + + go ty1@(AppTy s1 t1) ty2@(TyConApp tc2 ts2) + | Just (ts2', t2') <- snocView ts2 + = assert (not (tyConMustBeSaturated tc2)) $ + go_app (isNextTyConArgVisible tc2 ts2') + ty1 s1 t1 ty2 (TyConApp tc2 ts2') t2' + + go ty1@(TyConApp tc1 ts1) ty2@(AppTy s2 t2) + | Just (ts1', t1') <- snocView ts1 + = assert (not (tyConMustBeSaturated tc1)) $ + go_app (isNextTyConArgVisible tc1 ts1') + ty1 (TyConApp tc1 ts1') t1' ty2 s2 t2 + + go ty1@(CoercionTy co1) ty2@(CoercionTy co2) + = do { kco <- uType (mkKindEnv env ty1 ty2) + (coercionType co1) (coercionType co2) + ; return $ mkProofIrrelCo role kco co1 co2 } + + -- Anything else fails + -- E.g. unifying for-all types, which is relative unusual + go ty1 ty2 = defer ty1 ty2 + + ------------------ + defer ty1 ty2 -- See Note [Check for equality before deferring] + | ty1 `tcEqType` ty2 = return (mkReflCo role ty1) + | otherwise = uType_defer env orig_ty1 orig_ty2 + + + ------------------ + u_tc_arg is_vis role ty1 ty2 + = do { traceTc "u_tc_arg" (ppr role $$ ppr ty1 $$ ppr ty2) + ; uType env_arg ty1 ty2 } + where + env_arg = env { u_loc = adjustCtLoc is_vis False (u_loc env) + , u_role = role } + + ------------------ + -- For AppTy, decompose only nominal equalities + -- See Note [Decomposing AppTy equalities] in GHC.Tc.Solver.Equality + go_app vis ty1 s1 t1 ty2 s2 t2 + | Nominal <- role + = -- Unify arguments t1/t2 before function s1/s2, because + -- the former have smaller kinds, and hence simpler error messages + -- c.f. GHC.Tc.Solver.Equality.can_eq_app + -- Example: test T8603 + do { let env_arg = env { u_loc = adjustCtLoc vis False (u_loc env) } + ; co_t <- uType env_arg t1 t2 + ; co_s <- uType env s1 s2 + ; return $ mkAppCo co_s co_t } + | otherwise + = defer ty1 ty2 + +{- Note [Check for equality before deferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Particularly in ambiguity checks we can get equalities like (ty ~ ty). +If ty involves a type function we may defer, which isn't very sensible. +An egregious example of this was in test T9872a, which has a type signature + Proxy :: Proxy (Solutions Cubes) +Doing the ambiguity check on this signature generates the equality + Solutions Cubes ~ Solutions Cubes +and currently the constraint solver normalises both sides at vast cost. +This little short-cut in 'defer' helps quite a bit. + +Note [Care with type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note: type applications need a bit of care! +They can match FunTy and TyConApp, so use splitAppTy_maybe +NB: we've already dealt with type variables and Notes, +so if one type is an App the other one jolly well better be too + +Note [Mismatched type lists and application decomposition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we find two TyConApps, you might think that the argument lists +are guaranteed equal length. But they aren't. Consider matching + w (T x) ~ Foo (T x y) +We do match (w ~ Foo) first, but in some circumstances we simply create +a deferred constraint; and then go ahead and match (T x ~ T x y). +This came up in #3950. + +So either + (a) either we must check for identical argument kinds + when decomposing applications, + + (b) or we must be prepared for ill-kinded unification sub-problems + +Currently we adopt (b) since it seems more robust -- no need to maintain +a global invariant. + +Note [Expanding synonyms during unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand synonyms during unification, but: + * We expand *after* the variable case so that we tend to unify + variables with un-expanded type synonym. This just makes it + more likely that the inferred types will mention type synonyms + understandable to the user + + * Similarly, we expand *after* the CastTy case, just in case the + CastTy wraps a variable. + + * We expand *before* the TyConApp case. For example, if we have + type Phantom a = Int + and are unifying + Phantom Int ~ Phantom Char + it is *wrong* to unify Int and Char. + + * The problem case immediately above can happen only with arguments + to the tycon. So we check for nullary tycons *before* expanding. + This is particularly helpful when checking (* ~ *), because * is + now a type synonym. See Note [Unifying type synonyms] in GHC.Core.Unify. + +Note [Deferred unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, +and yet its consistency is undetermined. Previously, there was no way to still +make it consistent. So a mismatch error was issued. + +Now these unifications are deferred until constraint simplification, where type +family instances and given equations may (or may not) establish the consistency. +Deferred unifications are of the form + F ... ~ ... +or x ~ ... +where F is a type function and x is a type variable. +E.g. + id :: x ~ y => x -> y + id e = e + +involves the unification x = y. It is deferred until we bring into account the +context x ~ y to establish that it holds. + +If available, we defer original types (rather than those where closed type +synonyms have already been expanded via tcCoreView). This is, as usual, to +improve error messages. + +************************************************************************ +* * + uUnfilledVar and friends +* * +************************************************************************ + +@uunfilledVar@ is called when at least one of the types being unified is a +variable. It does {\em not} assume that the variable is a fixed point +of the substitution; rather, notice that @uVar@ (defined below) nips +back into @uTys@ if it turns out that the variable is already bound. +-} + +---------- +uUnfilledVar, uUnfilledVar1 + :: UnifyEnv + -> SwapFlag + -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar + -- definitely not a /filled/ meta-tyvar + -> TcTauType -- Type 2 + -> TcM CoercionN +-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar +-- It might be a skolem, or untouchable, or meta +uUnfilledVar env swapped tv1 ty2 + | Nominal <- u_role env + = do { ty2 <- liftZonkM $ zonkTcType ty2 + -- Zonk to expose things to the occurs check, and so + -- that if ty2 looks like a type variable then it + -- /is/ a type variable + ; uUnfilledVar1 env swapped tv1 ty2 } + + | otherwise -- See Note [Do not unify representational equalities] + -- in GHC.Tc.Solver.Equality + = unSwap swapped (uType_defer env) (mkTyVarTy tv1) ty2 + +uUnfilledVar1 env -- Precondition: u_role==Nominal + swapped + tv1 + ty2 -- ty2 is zonked + | Just tv2 <- getTyVar_maybe ty2 + = go tv2 + + | otherwise + = uUnfilledVar2 env swapped tv1 ty2 + + where + -- 'go' handles the case where both are + -- tyvars so we might want to swap + -- E.g. maybe tv2 is a meta-tyvar and tv1 is not + go tv2 | tv1 == tv2 -- Same type variable => no-op + = return (mkNomReflCo (mkTyVarTy tv1)) + + | swapOverTyVars False tv1 tv2 -- Distinct type variables + -- Swap meta tyvar to the left if poss + = do { tv1 <- liftZonkM $ zonkTyCoVarKind tv1 + -- We must zonk tv1's kind because that might + -- not have happened yet, and it's an invariant of + -- uUnfilledTyVar2 that ty2 is fully zonked + -- Omitting this caused #16902 + ; uUnfilledVar2 env (flipSwap swapped) tv2 (mkTyVarTy tv1) } + + | otherwise + = uUnfilledVar2 env swapped tv1 ty2 + +---------- +uUnfilledVar2 :: UnifyEnv -- Precondition: u_role==Nominal + -> SwapFlag + -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar + -- definitely not a /filled/ meta-tyvar + -> TcTauType -- Type 2, zonked + -> TcM CoercionN +uUnfilledVar2 env@(UE { u_defer = def_eq_ref }) swapped tv1 ty2 + = do { cur_lvl <- getTcLevel + -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles + -- Here we don't know about given equalities; so we treat + -- /any/ level outside this one as untouchable. Hence cur_lvl. + ; if simpleUnifyCheck UC_OnTheFly cur_lvl tv1 ty2 /= SUC_CanUnify + then not_ok_so_defer cur_lvl + else + do { def_eqs <- readTcRef def_eq_ref -- Capture current state of def_eqs + + -- Attempt to unify kinds + -- When doing so, be careful to preserve orientation; + -- see Note [Kind Equality Orientation] in GHC.Tc.Solver.Equality + -- and wrinkle (W2) in Note [Fundeps with instances, and equality orientation] + -- in GHC.Tc.Solver.Dict + -- Failing to preserve orientation led to #25597. + ; let kind_env = unSwap swapped (mkKindEnv env) ty1 ty2 + ; co_k <- unSwap swapped (uType kind_env) (tyVarKind tv1) (typeKind ty2) + + ; traceTc "uUnfilledVar2 ok" $ + vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) + , ppr ty2 <+> dcolon <+> ppr (typeKind ty2) + , ppr (isReflCo co_k), ppr co_k ] + + ; if isReflCo co_k + -- Only proceed if the kinds match + -- NB: tv1 should still be unfilled, despite the kind unification + -- because tv1 is not free in ty2' (or, hence, in its kind) + then do { liftZonkM $ writeMetaTyVar tv1 ty2 + ; case u_unified env of + Nothing -> return () + Just uref -> updTcRef uref (tv1 :) + ; return (mkNomReflCo ty2) } -- Unification is always Nominal + + else -- The kinds don't match yet, so defer instead. + do { writeTcRef def_eq_ref def_eqs + -- Since we are discarding co_k, also discard any constraints + -- emitted by kind unification; they are just useless clutter. + -- Do this dicarding by simply restoring the previous state + -- of def_eqs; a bit imperative/yukky but works fine. + ; defer } + }} + where + ty1 = mkTyVarTy tv1 + defer = unSwap swapped (uType_defer env) ty1 ty2 + + not_ok_so_defer cur_lvl = + do { traceTc "uUnfilledVar2 not ok" $ + vcat [ text "tv1:" <+> ppr tv1 + , text "ty2:" <+> ppr ty2 + , text "simple-unify-chk:" <+> ppr (simpleUnifyCheck UC_OnTheFly cur_lvl tv1 ty2) + ] + -- Occurs check or an untouchable: just defer + -- NB: occurs check isn't necessarily fatal: + -- eg tv1 occurred in type family parameter + ; defer } + +swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool +swapOverTyVars is_given tv1 tv2 + -- See Note [Unification variables on the left] + | not is_given, pri1 == 0, pri2 > 0 = True + | not is_given, pri2 == 0, pri1 > 0 = False + + -- Level comparison: see Note [TyVar/TyVar orientation] + | lvl1 `strictlyDeeperThan` lvl2 = False + | lvl2 `strictlyDeeperThan` lvl1 = True + + -- Priority: see Note [TyVar/TyVar orientation] + | pri1 > pri2 = False + | pri2 > pri1 = True + + -- Names: see Note [TyVar/TyVar orientation] + | isSystemName tv2_name, not (isSystemName tv1_name) = True + + | otherwise = False + + where + lvl1 = tcTyVarLevel tv1 + lvl2 = tcTyVarLevel tv2 + pri1 = lhsPriority tv1 + pri2 = lhsPriority tv2 + tv1_name = Var.varName tv1 + tv2_name = Var.varName tv2 + + +lhsPriority :: TcTyVar -> Int +-- Higher => more important to be on the LHS +-- => more likely to be eliminated +-- Only used when the levels are identical +-- See Note [TyVar/TyVar orientation] +lhsPriority tv + = assertPpr (isTyVar tv) (ppr tv) $ + case tcTyVarDetails tv of + RuntimeUnk -> 0 + SkolemTv {} -> 0 + MetaTv { mtv_info = info, mtv_tclvl = lvl } + | QLInstVar <- lvl + -> 5 -- Eliminate instantiation variables first + | otherwise + -> case info of + CycleBreakerTv -> 0 + TyVarTv -> 1 + ConcreteTv {} -> 2 + TauTv -> 3 + RuntimeUnkTv -> 4 + +{- Note [Unification preconditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Question: given a homogeneous equality (alpha ~# ty), when is it OK to +unify alpha := ty? +(This note only applies to /homogeneous/ equalities, in which both +sides have the same kind.) + +There are five reasons not to unify: + +1. (SKOL-ESC) Skolem-escape + Consider the constraint + forall[2] a[2]. alpha[1] ~ Maybe a[2] + If we unify alpha := Maybe a, the skolem 'a' may escape its scope. + The level alpha[1] says that alpha may be used outside this constraint, + where 'a' is not in scope at all. So we must not unify. + + Bottom line: when looking at a constraint alpha[n] := ty, do not unify + if any free variable of 'ty' has level deeper (greater) than n + +2. (UNTOUCHABLE) Untouchable unification variables + Consider the constraint + forall[2] a[2]. b[1] ~ Int => alpha[1] ~ Int + There is no (SKOL-ESC) problem with unifying alpha := Int, but it might + not be the principal solution. Perhaps the "right" solution is alpha := b. + We simply can't tell. See "OutsideIn(X): modular type inference with local + assumptions", section 2.2. We say that alpha[1] is "untouchable" inside + this implication. + + Bottom line: at ambient level 'l', when looking at a constraint + alpha[n] ~ ty, do not unify alpha := ty if there are any given equalities + between levels 'n' and 'l'. + + Exactly what is a "given equality" for the purpose of (UNTOUCHABLE)? + Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet + +3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs + This precondition looks at the MetaInfo of the unification variable: + + * TyVarTv: When considering alpha{tyv} ~ ty, if alpha{tyv} is a + TyVarTv it can only unify with a type variable, not with a + structured type. So if 'ty' is a structured type, such as (Maybe x), + don't unify. + + * CycleBreakerTv: never unified, except by restoreTyVarCycles. + +4. (CONCRETE) A ConcreteTv can only unify with a concrete type, + by definition. + + That is, if we have `rr[conc] ~ F Int`, we can't unify + `rr` with `F Int`, so we hold off on unifying. + Note however that the equality might get rewritten; for instance + if we can rewrite `F Int` to a concrete type, say `FloatRep`, + then we will have `rr[conc] ~ FloatRep` and we can unify `rr ~ FloatRep`. + + Note that we can still make progress on unification even if + we can't fully solve an equality, e.g. + + alpha[conc] ~# TupleRep '[ beta[tau], F gamma[tau] ] + + we can fill beta[tau] := beta[conc]. This is why we call + 'makeTypeConcrete' in startSolvingByUnification. + +5. (REWRITERS) the equality does not have any unsolved equalities in its rewriter + set. If those other equalities have not been solved, unifying this equality + will propagate strange-looking errors elswhere. That is the whole point of + rewriter sets. Suppose our equality is + [W] co1 {rew = {cok}} (alpha :: k) ~ (Int |> {cok}) + where co :: Type ~ k is an unsolved wanted. Note that this equality + is homogeneous; both sides have kind k. We refrain from unifying + here, because of `cok` in its rewriter set. See + Note [Unify only if the rewriter set is empty] in GHC.Solver.Equality. + +Needless to say, all there are wrinkles: + +* (SKOL-ESC) Promotion. Given alpha[n] ~ ty, what if beta[k] is free + in 'ty', where beta is a unification variable, and k>n? 'beta' + stands for a monotype, and since it is part of a level-n type + (equal to alpha[n]), we must /promote/ beta to level n. Just make + up a fresh gamma[n], and unify beta[k] := gamma[n]. + +* (TYVAR-TV) Unification variables. Suppose alpha[tyv,n] is a level-n + TyVarTv (see Note [TyVarTv] in GHC.Tc.Types.TcMType)? Now + consider alpha[tyv,n] ~ Bool. We don't want to unify because that + would break the TyVarTv invariant. + + What about alpha[tyv,n] ~ beta[tau,n], where beta is an ordinary + TauTv? Again, don't unify, because beta might later be unified + with, say Bool. (If levels permit, we reverse the orientation here; + see Note [TyVar/TyVar orientation].) + +* (UNTOUCHABLE) Untouchability. When considering (alpha[n] ~ ty), how + do we know whether there are any given equalities between level n + and the ambient level? We answer in two ways: + + * In the eager unifier, we only unify if l=n. If not, alpha may be + untouchable, and defer to the constraint solver. This check is + made in GHC.Tc.Utils.uUnifilledVar2, in the guard + isTouchableMetaTyVar. + + * In the constraint solver, we track where Given equalities occur + and use that to guard unification in + GHC.Tc.Utils.Unify.touchabilityTest. More details in + Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet + + Historical note: in the olden days (pre 2021) the constraint solver + also used to unify only if l=n. Equalities were "floated" out of the + implication in a separate step, so that they would become touchable. + But the float/don't-float question turned out to be very delicate, + as you can see if you look at the long series of Notes associated with + GHC.Tc.Solver.floatEqualities, around Nov 2020. It's much easier + to unify in-place, with no floating. + +Note [TyVar/TyVar orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Fundeps with instances, and equality orientation] +where the kind equality orientation is important + +Given (a ~ b), should we orient the equality as (a~b) or (b~a)? +This is a surprisingly tricky question! + +The question is answered by swapOverTyVars, which is used + - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1 + - in the constraint solver, in GHC.Tc.Solver.Equality.canEqCanLHS2 + +First note: only swap if you have to! + See Note [Avoid unnecessary swaps] + +So we look for a positive reason to swap, using a three-step test: + +* Level comparison. If 'a' has deeper level than 'b', + put 'a' on the left. See Note [Deeper level on the left] + +* Priority. If the levels are the same, look at what kind of + type variable it is, using 'lhsPriority'. + + Generally speaking we always try to put a MetaTv on the left in + preference to SkolemTv or RuntimeUnkTv, because the MetaTv may be + touchable and can be unified. + + Tie-breaking rules for MetaTvs: + - CycleBreakerTv: This is essentially a stand-in for another type; + it's untouchable and should have the same priority as a skolem: 0. + + - TyVarTv: These can unify only with another tyvar, but we can't unify + a TyVarTv with a TauTv, because then the TyVarTv could (transitively) + get a non-tyvar type. So give these a low priority: 1. + + - ConcreteTv: These are like TauTv, except they can only unify with + a concrete type. So we want to be able to write to them, but not quite + as much as TauTvs: 2. + + - TauTv: This is the common case; we want these on the left so that they + can be written to: 3. + + - RuntimeUnkTv: These aren't really meta-variables used in type inference, + but just a convenience in the implementation of the GHCi debugger. + Eagerly write to these: 4. See Note [RuntimeUnkTv] in + GHC.Runtime.Heap.Inspect. + +* Names. If the level and priority comparisons are all + equal, try to eliminate a TyVar with a System Name in + favour of ones with a Name derived from a user type signature + +* Age. At one point in the past we tried to break any remaining + ties by eliminating the younger type variable, based on their + Uniques. See Note [Eliminate younger unification variables] + (which also explains why we don't do this any more) + +Note [Unification variables on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of +level, so that the unification variable is on the left. + +* We /don't/ want this for Givens because if we ave + [G] a[2] ~ alpha[1] + [W] Bool ~ a[2] + we want to rewrite the wanted to Bool ~ alpha[1], + so we can float the constraint and solve it. + +* But for Wanteds putting the unification variable on + the left means an easier job when floating, and when + reporting errors -- just fewer cases to consider. + + In particular, we get better skolem-escape messages: + see #18114 + +Note [Deeper level on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The most important thing is that we want to put tyvars with +the deepest level on the left. The reason to do so differs for +Wanteds and Givens, but either way, deepest wins! Simple. + +* Wanteds. Putting the deepest variable on the left maximise the + chances that it's a touchable meta-tyvar which can be solved. + +* Givens. Suppose we have something like + forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2] + + If we orient the Given a[2] on the left, we'll rewrite the Wanted to + (beta[1] ~ b[1]), and that can float out of the implication. + Otherwise it can't. By putting the deepest variable on the left + we maximise our changes of eliminating skolem capture. + + See also GHC.Tc.Solver.InertSet Note [Let-bound skolems] for another reason + to orient with the deepest skolem on the left. + + IMPORTANT NOTE: this test does a level-number comparison on + skolems, so it's important that skolems have (accurate) level + numbers. + +See #15009 for an further analysis of why "deepest on the left" +is a good plan. + +Note [Avoid unnecessary swaps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we swap without actually improving matters, we can get an infinite loop. +Consider + work item: a ~ b + inert item: b ~ c +We canonicalise the work-item to (a ~ c). If we then swap it before +adding to the inert set, we'll add (c ~ a), and therefore kick out the +inert guy, so we get + new work item: b ~ c + inert item: c ~ a +And now the cycle just repeats + +Historical Note [Eliminate younger unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a choice of unifying + alpha := beta or beta := alpha +we try, if possible, to eliminate the "younger" one, as determined +by `ltUnique`. Reason: the younger one is less likely to appear free in +an existing inert constraint, and hence we are less likely to be forced +into kicking out and rewriting inert constraints. + +This is a performance optimisation only. It turns out to fix +#14723 all by itself, but clearly not reliably so! + +It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars). +But, to my surprise, it didn't seem to make any significant difference +to the compiler's performance, so I didn't take it any further. Still +it seemed too nice to discard altogether, so I'm leaving these +notes. SLPJ Jan 18. + +Note [Prevent unification with type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We prevent unification with type families because of an uneasy compromise. +It's perfectly sound to unify with type families, and it even improves the +error messages in the testsuite. It also modestly improves performance, at +least in some cases. But it's disastrous for test case perf/compiler/T3064. +Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a. +What do we do? Do we reduce F? Or do we use the given? Hard to know what's +best. GHC reduces. This is a disaster for T3064, where the type's size +spirals out of control during reduction. If we prevent +unification with type families, then the solver happens to use the equality +before expanding the type family. + +It would be lovely in the future to revisit this problem and remove this +extra, unnecessary check. But we retain it for now as it seems to work +better in practice. + +Revisited in Nov '20, along with removing flattening variables. Problem +is still present, and the solution is still the same. + +Note [Non-TcTyVars in GHC.Tc.Utils.Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because the same code is now shared between unifying types and unifying +kinds, we sometimes will see proper TyVars floating around the unifier. +Example (from test case polykinds/PolyKinds12): + + type family Apply (f :: k1 -> k2) (x :: k1) :: k2 + type instance Apply g y = g y + +When checking the instance declaration, we first *kind-check* the LHS +and RHS, discovering that the instance really should be + + type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y + +During this kind-checking, all the tyvars will be TcTyVars. Then, however, +as a second pass, we desugar the RHS (which is done in functions prefixed +with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper +TyVars, not TcTyVars, get some kind unification must happen. + +Thus, we always check if a TyVar is a TcTyVar before asking if it's a +meta-tyvar. + +This used to not be necessary for type-checking (that is, before * :: *) +because expressions get desugared via an algorithm separate from +type-checking (with wrappers, etc.). Types get desugared very differently, +causing this wibble in behavior seen here. +-} + +-- | Breaks apart a function kind into its pieces. +matchExpectedFunKind + :: TypedThing -- ^ type, only for errors + -> Arity -- ^ n: number of desired arrows + -> TcKind -- ^ fun_kind + -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) + +matchExpectedFunKind hs_ty n k = go n k + where + go 0 k = return (mkNomReflCo k) + + go n k | Just k' <- coreView k = go n k' + + go n k@(TyVarTy kvar) + | isMetaTyVar kvar + = do { maybe_kind <- readMetaTyVar kvar + ; case maybe_kind of + Indirect fun_kind -> go n fun_kind + Flexi -> defer n k } + + go n (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + | isVisibleFunArg af + = do { co <- go (n-1) res + ; return (mkNakedFunCo Nominal af (mkNomReflCo w) (mkNomReflCo arg) co) } + + go n other + = defer n other + + defer n k + = do { arg_kinds <- newMetaKindVars n + ; res_kind <- newMetaKindVar + ; let new_fun = mkVisFunTysMany arg_kinds res_kind + origin = TypeEqOrigin { uo_actual = k + , uo_expected = new_fun + , uo_thing = Just hs_ty + , uo_visible = True + } + ; unifyTypeAndEmit KindLevel origin k new_fun } + +{- ********************************************************************* +* * + Checking alpha ~ ty + for the on-the-fly unifier +* * +********************************************************************* -} + +data UnifyCheckCaller + = UC_OnTheFly -- Called from the on-the-fly unifier + | UC_QuickLook -- Called from Quick Look + | UC_Solver -- Called from constraint solver + +-- | The result type of 'simpleUnifyCheck'. +data SimpleUnifyResult + -- | Definitely cannot unify (untouchable variable or incompatible top-shape) + = SUC_CannotUnify + -- | The variable is touchable and the top-shape test passed, but + -- it may or may not be OK to unify + | SUC_NotSure + -- | Definitely OK to unify + | SUC_CanUnify + deriving stock (Eq, Ord, Show) +instance Semigroup SimpleUnifyResult where + no@SUC_CannotUnify <> _ = no + SUC_CanUnify <> r = r + _ <> no@SUC_CannotUnify = no + r <> SUC_CanUnify = r + ns@SUC_NotSure <> SUC_NotSure = ns + +instance Outputable SimpleUnifyResult where + ppr = \case + SUC_CannotUnify -> text "SUC_CannotUnify" + SUC_NotSure -> text "SUC_NotSure" + SUC_CanUnify -> text "SUC_CanUnify" + +simpleUnifyCheck :: UnifyCheckCaller -> TcLevel -> TcTyVar -> TcType -> SimpleUnifyResult +-- ^ A fast check for unification. May return "not sure", in which case +-- unification might still be OK, but it'll take more work to do +-- (use the full 'checkTypeEq'). +-- +-- * Rejects if lhs_tv occurs in rhs_ty (occurs check) +-- * Rejects foralls unless +-- lhs_tv is RuntimeUnk (used by GHCi debugger) +-- or is a QL instantiation variable +-- * Rejects a non-concrete type if lhs_tv is concrete +-- * Rejects type families unless fam_ok=True +-- * Does a level-check for type variables, to avoid skolem escape +-- +-- This function is pretty heavily used, so it's optimised not to allocate +simpleUnifyCheck caller given_eq_lvl lhs_tv rhs + | not $ touchabilityTest given_eq_lvl lhs_tv + = SUC_CannotUnify + | not $ checkTopShape lhs_info rhs + = SUC_CannotUnify + | rhs_is_ok rhs + = SUC_CanUnify + | otherwise + = SUC_NotSure + where + lhs_info = metaTyVarInfo lhs_tv + + !(occ_in_ty, occ_in_co) = mkOccFolders (tyVarName lhs_tv) + + lhs_tv_lvl = tcTyVarLevel lhs_tv + lhs_tv_is_concrete = isConcreteTyVar lhs_tv + + forall_ok = case caller of + UC_QuickLook -> isQLInstTyVar lhs_tv + _ -> isRuntimeUnkTyVar lhs_tv + + -- This fam_ok thing relates to a very specific perf problem + -- See Note [Prevent unification with type families] + -- A couple of QuickLook regression tests rely on unifying with type + -- families, so we let it through there (not very principled, but let's + -- see if it bites us) + fam_ok = case caller of + UC_Solver -> True + UC_QuickLook -> True + UC_OnTheFly -> False + + rhs_is_ok (TyVarTy tv) + | lhs_tv == tv = False + | tcTyVarLevel tv `strictlyDeeperThan` lhs_tv_lvl = False + | lhs_tv_is_concrete, not (isConcreteTyVar tv) = False + | occ_in_ty $! (tyVarKind tv) = False + | otherwise = True + + rhs_is_ok (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) + | not forall_ok, isInvisibleFunArg af = False + | otherwise = rhs_is_ok w && rhs_is_ok a && rhs_is_ok r + + rhs_is_ok (TyConApp tc tys) + | lhs_tv_is_concrete, not (isConcreteTyCon tc) = False + | not forall_ok, not (isTauTyCon tc) = False + | not fam_ok, not (isFamFreeTyCon tc) = False + | otherwise = all rhs_is_ok tys + + rhs_is_ok (ForAllTy (Bndr tv _) ty) + | forall_ok = rhs_is_ok (tyVarKind tv) && (tv == lhs_tv || rhs_is_ok ty) + | otherwise = False + + rhs_is_ok (AppTy t1 t2) = rhs_is_ok t1 && rhs_is_ok t2 + rhs_is_ok (CastTy ty co) = not (occ_in_co co) && rhs_is_ok ty + rhs_is_ok (CoercionTy co) = not (occ_in_co co) + rhs_is_ok (LitTy {}) = True + + +mkOccFolders :: Name -> (TcType -> Bool, TcCoercion -> Bool) +-- These functions return True +-- * if lhs_tv occurs (incl deeply, in the kind of variable) +-- * if there is a coercion hole +-- No expansion of type synonyms +mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co) + where + !(check_ty, _, check_co, _) = foldTyCo occ_folder emptyVarSet + occ_folder = TyCoFolder { tcf_view = noView -- Don't expand synonyms + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole + , tcf_tycobinder = do_bndr } + + do_tcv is v = Any (not (v `elemVarSet` is) && tyVarName v == lhs_tv) + `mappend` check_ty (varType v) + + do_bndr is tcv _faf = extendVarSet is tcv + do_hole _is _hole = DM.Any True -- Reject coercion holes + +{- ********************************************************************* +* * + Equality invariant checking +* * +********************************************************************* -} + + +{- Note [Checking for foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never want to unify + alpha ~ (forall a. a->a) -> Int +So we look for foralls hidden inside the type, and it's convenient +to do that at the same time as the occurs check (which looks for +occurrences of alpha). + +However, it's not just a question of looking for foralls /anywhere/! +Consider + (alpha :: forall k. k->*) ~ (beta :: forall k. k->*) +This is legal; e.g. dependent/should_compile/T11635. + +We don't want to reject it because of the forall in beta's kind, but +(see Note [Occurrence checking: look inside kinds] in GHC.Core.Type) +we do need to look in beta's kind. So we carry a flag saying if a +'forall' is OK, and switch the flag on when stepping inside a kind. + +Why is it OK? Why does it not count as impredicative polymorphism? +The reason foralls are bad is because we reply on "seeing" foralls +when doing implicit instantiation. But the forall inside the kind is +fine. We'll generate a kind equality constraint + (forall k. k->*) ~ (forall k. k->*) +to check that the kinds of lhs and rhs are compatible. If alpha's +kind had instead been + (alpha :: kappa) +then this kind equality would rightly complain about unifying kappa +with (forall k. k->*) + +Note [Forgetful synonyms in checkTyConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type S a b = b -- Forgets 'a' + + [W] alpha[2] ~ Maybe (S beta[4] gamma[2]) + +We don't want to promote beta to level 2; rather, we should +expand the synonym. (Currently, in checkTypeEqRhs promotion +is irrevocable, by side effect.) + +To avoid this risk we eagerly expand forgetful synonyms. +This also means we won't get an occurs check in + a ~ Maybe (S a b) + +The annoyance is that we might expand the synonym unnecessarily, +something we generally try to avoid. But for now, this seems +simple. + +In a forgetful case like a ~ Maybe (S a b), `checkTyEqRhs` returns +a Reduction that looks + Reduction { reductionCoercion = Refl + , reductionReducedType = Maybe b } +We must jolly well use that reductionReduced type, even though the +reductionCoercion is Refl. See `canEqCanLHSFinish_no_unification`. +-} + +data PuResult a b + -- | Pure unifier failure. + -- + -- Invariant: the CheckTyEqResult is not 'cteOK'; that it, it specifies a problem. + = PuFail CheckTyEqResult + -- | Pure unifier success. + | PuOK (Bag a) b + deriving stock (Functor, Foldable, Traversable) + +instance Applicative (PuResult a) where + pure x = PuOK emptyBag x + PuFail p1 <*> PuFail p2 = PuFail (p1 S.<> p2) + PuFail p1 <*> PuOK {} = PuFail p1 + PuOK {} <*> PuFail p2 = PuFail p2 + PuOK c1 f <*> PuOK c2 x = PuOK (c1 `unionBags` c2) (f x) + +instance (Outputable a, Outputable b) => Outputable (PuResult a b) where + ppr (PuFail prob) = text "PuFail" <+> (ppr prob) + ppr (PuOK cts x) = text "PuOK" <> braces + (vcat [ text "redn:" <+> ppr x + , text "cts:" <+> ppr cts ]) + +okCheckRefl :: TcType -> PuResult a Reduction +okCheckRefl ty = PuOK emptyBag (mkReflRedn Nominal ty) + +mapCheck :: Monad m + => (x -> m (PuResult a Reduction)) + -> [x] + -> m (PuResult a Reductions) +mapCheck f xs + = do { (ress :: [PuResult a Reduction]) <- mapM f xs + ; return (unzipRedns <$> sequenceA ress) } + -- sequenceA :: [PuResult a Reduction] -> PuResult a [Reduction] + -- unzipRedns :: [Reduction] -> Reductions +{-# INLINEABLE mapCheck #-} + +----------------------------- +-- | Options describing how to deal with a type equality +-- in the eager unifier. See 'checkTyEqRhs' +data TyEqFlags m a + = -- | TFTyFam: LHS is a type family application + -- Invariant: we are not unifying; see `notUnifying_TEFTask` + TEFTyFam + { tefTyFam_occursCheck :: CheckTyEqProblem + -- ^ The 'CheckTyEqProblem' to report for occurs-check failures + -- (soluble or insoluble) + , tefTyFam_tyCon :: TyCon + , tefTyFam_args :: [Type] + , tef_fam_app :: TyEqFamApp m a + -- ^ How to deal with type family applications + } + + -- | TEFTyVar: LHS is a 'TyVar'. + | TEFTyVar + -- NB: this constructor does not actually store a 'TyVar', in order to + -- support being called from 'makeTypeConcrete' (which works as if we + -- created a fresh 'ConcreteTv' metavariable; see (3) in Note [TyEqFlags]) + { tefTyVar_occursCheck :: OccursCheck + -- ^ Occurs check + , tefTyVar_levelCheck :: LevelCheck m + -- ^ Level check + , tefTyVar_concreteCheck :: ConcreteCheck m + -- ^ Concreteness check + , tef_fam_app :: TyEqFamApp m a + -- ^ How to deal with type family applications + } + +-- | What to do when encountering a type-family application while processing +-- a type equality in the pure unifier. +-- +-- See Note [Family applications in canonical constraints] +data TyEqFamApp m a where + -- | Just recurse + TEFA_Recurse :: TyEqFamApp m a + -- | Recurse, but replace with cycle breaker if that fails, + -- using the specified 'FamAppBreaker' + TEFA_Break :: FamAppBreaker a -> TyEqFamApp TcM a + +-- | A defunctionalisation of family application breaker functions. +-- Interpreter: `famAppBreaker` +data FamAppBreaker a where + BreakGiven :: FamAppBreaker (TcTyVar, TcType) + BreakWanted :: CtEvidence -> TcTyVar -> FamAppBreaker Ct + +data OccursCheck where + -- | No occurs check. + OC_None :: OccursCheck + -- | Do an occurs check between the LHS tyvar and the RHS. + OC_Check :: + { occurs_tv_name :: Name + -- ^ The 'Name' to perform an occurs-check on + , occurs_problem :: CheckTyEqProblem + -- ^ Which 'CheckTyEqProblem' to report for occurs-check failures + -- (soluble or insoluble) + } -> OccursCheck + +-- | What level check to perform, in a call to the pure unifier? +-- A defunctionalisation of the possible level-check functions +-- Interpreter: `tyVarLevelCheck` +data LevelCheck m where + -- | No level check. + LC_None :: LevelCheck m + -- | Do a level check between the LHS tyvar and the occurrence tyvar. + -- + -- Fail if the level check fails. + -- + -- True <=> lenient check, e.g. the levels have a chance of working out + -- after promotion. + LC_Check :: + { lc_lvlc :: TcLevel + , lc_lenient :: Bool + } -> LevelCheck m + + -- | Do a level check between the LHS tyvar and the occurrence tyvar. + -- + -- If the level check fails, and the occurrence is a unification + -- variable, promote it. + -- + -- - False <=> don't promote under type families (the common case) + -- - True <=> promote even under type families + -- (see Note [Defaulting equalities] in GHC.Tc.Solver) + LC_Promote + :: { lc_lvlp :: TcLevel + , lc_deep :: Bool + } -> LevelCheck TcM + +data ConcreteCheck m where + -- | No concreteness check. + CC_None :: ConcreteCheck m + -- | Simple check for concreteness, leniently returning 'OK' + -- if concreteness could be achieved after promotion. + CC_Check :: ConcreteCheck m + -- | Proper concreteness check: promote non-concrete metavariables, + -- failing if there are any problems. + CC_Promote :: ConcreteTvOrigin -> ConcreteCheck TcM + +{- Note [TyEqFlags] +~~~~~~~~~~~~~~~~~~~ +When we call the eager unifier, e.g. through 'checkTyEqRhs', we specify what +kind of checks the unifier performs via the 'TyEqFlags' argument. In particular, +when the LHS type in a unification is a type variable, we might want to perform +different checks; this is achieved using the 'TEFTyVar' constructor to 'TyEqFlags': + + 1. `notUnifying_TEFTask` + LHS is a skolem tyvar, or an untouchable meta-tyvar. + We are not unifying; we only want to perform occurs-checks. + + TEFTyVar + { tefTyVar_occursCheck = OC_Check ... + , tefTyVar_levelCheck = LC_None + , tefTyVar_concreteCheck = CC_None + , tef_fam_app = TEFA_Recurse + } + + 2a. `unifyingLHSMetaTyVar_TEFTask` + We are unifying; we want to perform an occurs check, a level check, + and a concreteness check (when the meta-tyvar is a ConcreteTv). + + TEFTyVar + { tefTyVar_occursCheck = OC_Check ... + , tefTyVar_levelCheck = LC_Promote ... + , tefTyVar_concreteCheck = CC_Promote or CC_None + -- depending on whether or not the lhs tv is concrete + , tef_fam_app = TEFA_Recurse + } + + 2b. `defaulting_TEFTask` + We are in the top-level defaulting code, considering unifying a + touchable meta-tyvar with a type. + + TEFTyVar + { tefTyVar_occursCheck = OC_None + , tefTyVar_levelCheck = LC_None + , tefTyVar_concreteCheck = CC_Promote or CC_None + -- depending on whether or not the lhs tv is concrete + , tef_fam_app = TEFA_Recurse + } + + 3. `makeTypeConcrete` + LHS is a fresh ConcreteTv meta-tyvar (see call to 'checkTyEqRhs' in + `makeTypeConcrete`). We are unifying; we only want to perform + a concreteness check. + + TEFTyVar + { tefTyVar_occursCheck = OC_None + , tefTyVar_levelCheck = LC_None + , tefTyVar_concreteCheck = CC_Promote conc_orig + , tef_fam_app = TEFA_Recurse + } + + 4. `pureTyEqFlags_LHSMetaTyVar` + We want to perform a non-monadic check, i.e. we want to know whether we are able + to unify 'lhs_tv' with 'rhs_ty', but don't want to actually perform + a side-effecting unification. This is used in 'mightEqualLater'. + + TEFTyVar + { tefTyVar_occursCheck = OC_Check ... + , tefTyVar_levelCheck = LC_Check ... + , tefTyVar_concreteCheck = CC_Check or CC_None + -- depending on whether or not the lhs tv is concrete + , tef_fam_app = TEFA_Recurse + } + + Here 'LC_Check True' and 'ConcreteSimpleCheck' make 'checkTyEqRhs' perform + conservative pure checks, without actually carrying out any promotion. +-} + +-- | Create a "not unifying" 'TyEqFlags' from a 'CanEqLHS'. +-- +-- See use-case (1) in Note [TyEqFlags]. +notUnifying_TEFTask :: CheckTyEqProblem -> CanEqLHS -> TyEqFlags m a +notUnifying_TEFTask occ_prob = \case + TyFamLHS tc tys -> + TEFTyFam + { tefTyFam_tyCon = tc + , tefTyFam_args = tys + , tefTyFam_occursCheck = occ_prob + , tef_fam_app = TEFA_Recurse + } + TyVarLHS tv -> + TEFTyVar + { tefTyVar_occursCheck = OC_Check (tyVarName tv) occ_prob + , tefTyVar_levelCheck = LC_None + , tefTyVar_concreteCheck = CC_None + , tef_fam_app = TEFA_Recurse + } + -- We need an occurs-check here, but no level check. + -- See Note [Promotion and level-checking] wrinkle (W1) + -- TEFA_Recurse: see Note [Don't cycle-break Wanteds when not unifying] + +-- | Create "unifying" 'TyEqFlags' from a 'TyVarLHS'. +-- +-- Invariant: the argument 'TcTyVar' is a 'MetaTv'. +unifyingLHSMetaTyVar_TEFTask :: CtEvidence -> TcTyVar -> TyEqFlags TcM Ct +unifyingLHSMetaTyVar_TEFTask ev lhs_tv = + TEFTyVar + { tefTyVar_occursCheck = OC_Check (tyVarName lhs_tv) cteInsolubleOccurs + , tefTyVar_levelCheck = LC_Promote { lc_lvlp = tcTyVarLevel lhs_tv + , lc_deep = False } + , tefTyVar_concreteCheck = mkConcreteCheck lhs_tv + , tef_fam_app = mkTEFA_Break ev NomEq (BreakWanted ev lhs_tv) + } + +defaulting_TEFTask :: TcTyVar -> TyEqFlags TcM a +-- Used during top-level defauting in GHC.Tc.Solver.Default.defaultEquality +-- Invariant: the argument 'TcTyVar' is a 'MetaTv'. +defaulting_TEFTask lhs_tv = + TEFTyVar + { tefTyVar_occursCheck = OC_Check (tyVarName lhs_tv) cteInsolubleOccurs + , tefTyVar_levelCheck = LC_Promote { lc_lvlp = tcTyVarLevel lhs_tv + , lc_deep = True } + -- LC_Promote: promote deeper unification variables (DE4) + -- lc_deep = True: ...including under type families (DE5) + , tefTyVar_concreteCheck = mkConcreteCheck lhs_tv + , tef_fam_app = TEFA_Recurse + } + +mkConcreteCheck :: TcTyVar -> ConcreteCheck TcM +mkConcreteCheck lhs_tv = case isConcreteTyVar_maybe lhs_tv of + Nothing -> CC_None + Just conc_orig -> CC_Promote conc_orig + +-- | 'TyEqFlags' for a pure call of 'checkTyEqRhs'. +-- +-- A call to 'checkTyEqRhs' with these 'TyEqFlags' will perform an optimistic +-- check: it will return 'PuFail' if there is definitely a problem, but it +-- might return 'PuOK' if it isn't entirely sure. +pureTyEqFlags_LHSMetaTyVar :: TyVar -> TyEqFlags Identity () +pureTyEqFlags_LHSMetaTyVar lhs_tv = + TEFTyVar + { tefTyVar_occursCheck = OC_Check (tyVarName lhs_tv) cteInsolubleOccurs + , tefTyVar_levelCheck = LC_Check { lc_lvlc = tcTyVarLevel lhs_tv + , lc_lenient = True } + , tefTyVar_concreteCheck = case isConcreteTyVar_maybe lhs_tv of + Nothing -> CC_None + Just {} -> CC_Check -- No promotion + , tef_fam_app = TEFA_Recurse } + + +mkTEFA_Break :: CtEvidence -> EqRel -> FamAppBreaker a -> TyEqFamApp TcM a +mkTEFA_Break ev eq_rel breaker + | NomEq <- eq_rel + , not cycle_breaker_origin + = TEFA_Break breaker + | otherwise + = TEFA_Recurse + where + -- cycle_breaker_origin: see Detail (7) of Note [Type equality cycles] + -- in GHC.Tc.Solver.Equality + cycle_breaker_origin = case ctLocOrigin (ctEvLoc ev) of + CycleBreakerOrigin {} -> True + _ -> False + +-- | Do we want to perform a concreteness check in 'checkTyEqRhs'? +tefConcrete :: TyEqFlags m a -> Bool +tefConcrete (TEFTyFam {}) = False +tefConcrete (TEFTyVar { tefTyVar_concreteCheck = conc }) = + wantConcreteCheck conc + +wantConcreteCheck :: ConcreteCheck m -> Bool +wantConcreteCheck = \case + CC_None -> False + CC_Check -> True + CC_Promote {} -> True + +-- | Given a family-application @ty@, return a @'Reduction' :: ty ~ cbv@ +-- where @cbv@ is a fresh loop-breaker tyvar (for Given), or +-- just a fresh 'TauTv' (for Wanted) +famAppBreaker :: FamAppBreaker a -> TcType -> TcM (PuResult a Reduction) +famAppBreaker BreakGiven fam_app + = do { new_tv <- TcM.newCycleBreakerTyVar (typeKind fam_app) + ; return (PuOK (unitBag (new_tv, fam_app)) + (mkReflRedn Nominal (mkTyVarTy new_tv))) } + -- Why reflexive? See Detail (4) of Note [Type equality cycles] + -- in GHC.Tc.Solver.Equality +famAppBreaker (BreakWanted ev lhs_tv) fam_app + -- Occurs check or skolem escape; so flatten + = do { reason <- checkPromoteFreeVars cteInsolubleOccurs + (tyVarName lhs_tv) lhs_tv_lvl + (tyCoVarsOfType fam_app_kind) + ; if not (cterHasNoProblem reason) -- Failed to promote free vars + then return $ PuFail reason + else + do { new_tv_ty <- + case lhs_tv_info of + ConcreteTv conc_info -> + -- Make a concrete tyvar if lhs_tv is concrete + -- e.g. alpha[2,conc] ~ Maybe (F beta[4]) + -- We want to flatten to + -- alpha[2,conc] ~ Maybe gamma[2,conc] + -- gamma[2,conc] ~ F beta[4] + TcM.newConcreteTyVarTyAtLevel conc_info lhs_tv_lvl fam_app_kind + _ -> TcM.newMetaTyVarTyAtLevel lhs_tv_lvl fam_app_kind + + ; let pty = mkNomEqPred fam_app new_tv_ty + ; hole <- TcM.newCoercionHole pty + ; let new_ev = WantedCt { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = cb_loc + , ctev_rewriters = ctEvRewriters ev } + ; return (PuOK (singleCt (mkNonCanonical $ CtWanted new_ev)) + (mkReduction (HoleCo hole) new_tv_ty)) } } + where + fam_app_kind = typeKind fam_app + (lhs_tv_info, lhs_tv_lvl) = + case tcTyVarDetails lhs_tv of + MetaTv { mtv_info = info, mtv_tclvl = lvl } -> (info,lvl) + -- lhs_tv should be a meta-tyvar + _ -> pprPanic "famAppBreaker BreakWanted: lhs_tv is not a meta-tyvar" + (ppr lhs_tv) + cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin + -- CycleBreakerOrigin: see Detail (7) of Note [Type equality cycles] + +instance Outputable (TyEqFlags m a) where + ppr = \case + TEFTyFam occ tc tys fam_app -> + text "TEFTyFam" <> braces ( + hcat [ ppr occ + , ppr (mkTyConApp tc tys) + , ppr fam_app ] ) + TEFTyVar occ lc conc fam_app -> + text "TEFTyVar" <> braces (hcat (punctuate comma fields)) + where + fields = [ text "OccursCheck:" <+> ppr occ ] + ++ + [ text "LevelCheck:" <+> ppr lc ] + ++ + [ text "ConcreteCheck:" <+> ppr conc ] + ++ + [ text "FamApp:" <+> ppr fam_app ] + +instance Outputable (TyEqFamApp m a) where + ppr TEFA_Recurse = text "TEFA_Recurse" + ppr (TEFA_Break breaker) = text "TEFA_BreakGiven" <+> ppr breaker + +instance Outputable (FamAppBreaker a) where + ppr BreakGiven = text "BreakGiven" + ppr (BreakWanted ev tv) = parens $ text "BreakWanted" <+> ppr ev <+> ppr tv + +instance Outputable OccursCheck where + ppr OC_None = text "OC_None" + ppr (OC_Check { occurs_tv_name = nm }) = text "OC_Check" <+> ppr nm +instance Outputable (ConcreteCheck m) where + ppr CC_None = text "CC_None" + ppr CC_Check = text "CC_Check" + ppr (CC_Promote {}) = text "CC_Promote" +instance Outputable (LevelCheck m) where + ppr (LC_None) = text "LC_None" + ppr (LC_Check lvl lenient) = text "LC_Check" <+> ppr lvl <+> ppWhen lenient (text "(lenient)") + ppr (LC_Promote lvl deep) = text "LC_Promote" <+> ppr lvl <+> ppWhen deep (text "(deep)") + +-- | Adjust the 'TyEqFlags' when going under a type family: +-- +-- 1. Only the outer family application gets the loop-breaker treatment +-- 2. Weaken level checks for tyvar promotion. For example, in @[W] alpha[2] ~ Maybe (F beta[3])@, +-- do not promote @beta[3]@, instead promote @(F beta[3])@. +-- 3. Occurs checks become potentially soluble (after additional type family +-- reductions). +famAppArgFlags :: TyEqFlags m a -> TyEqFlags m a +famAppArgFlags flags = case flags of + TEFTyFam {} -> + flags + { tef_fam_app = TEFA_Recurse -- (1) + , tefTyFam_occursCheck = cteSolubleOccurs -- (3) + } + TEFTyVar { tefTyVar_occursCheck = occ, tefTyVar_levelCheck = mb_lc } -> + flags + { tef_fam_app = TEFA_Recurse -- (1) + , tefTyVar_levelCheck = zap_lc mb_lc -- (2) + , tefTyVar_occursCheck = soluble_occ occ -- (3) + } + where + soluble_occ = \case + OC_Check tv _ -> OC_Check tv cteSolubleOccurs + OC_None -> OC_None + zap_lc = \case + LC_Promote { lc_lvlp = lvl, lc_deep = deeply } + | not deeply + -> LC_Check { lc_lvlc = lvl, lc_lenient = False } + lc -> lc + +{- Note [checkTyEqRhs] +~~~~~~~~~~~~~~~~~~~~~~ +The key function `checkTyEqRhs ty_eq_flags rhs` is called on the +RHS of a type equality + lhs ~ rhs +and checks to see if `rhs` satisfies, or can be made to satisfy, +invariants described by `ty_eq_flags`. It can succeded or fail; in +the latter case it returns a `CheckTyEqResult` that describes why it +failed. + +When `lhs` is a touchable type variable, so unification might happen, then +`checkTyEqRhs` enforces the unification preconditions of Note [Unification preconditions]. + +Notably, it can check for things like: + * Insoluble occurs check + e.g. alpha[tau] ~ [alpha] + or F Int ~ [F Int] + * Potentially-soluble occurs check + e.g. alpha[tau] ~ [F alpha beta] + * Impredicativity error: + e.g. alpha[tau] ~ (forall a. a->a) + * Skolem escape + e.g alpha[1] ~ (b[sk:2], Int) + * Concreteness error + e.g. alpha[conc] ~ r[sk] + +Its specific behaviour is governed by the `TyEqFlags` that are passed +to it; see Note [TyEqFlags]. + +Note, however, that `checkTyEqRhs` specifically does /not/ check for: + * Touchability of the LHS (in the case of a unification variable) + * Shape of the LHS (e.g. we can't unify Int with a TyVarTv) +These things are checked by `simpleUnifyCheck`. +-} + + +-- | Perform the checks specified by the 'TyEqFlags' on the RHS, in order to +-- enforce the unification preconditions of Note [Unification preconditions]. +-- +-- See Note [checkTyEqRhs]. +checkTyEqRhs :: forall m a + . Monad m + => TyEqFlags m a + -> TcType -- Already zonked + -> m (PuResult a Reduction) +checkTyEqRhs flags rhs + -- Crucial special case for a top-level equality of the form 'alpha ~ F tys'. + -- We don't want to flatten that (F tys), as this gets us right back to where + -- we started! + -- + -- See also Note [Special case for top-level of Given equality] + | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs + , not $ tefConcrete flags + = recurseIntoFamTyConApp flags tc tys + | otherwise + = check_ty_eq_rhs flags rhs + +{- Note [Special case for top-level of Given equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We take care when examining + [G] F ty ~ G (...(F ty)...) +where both sides are TyFamLHSs. We don't want to flatten that RHS to + [G] F ty ~ cbv + [G] G (...(F ty)...) ~ cbv +Instead we'd like to say "occurs-check" and swap LHS and RHS, which yields a +canonical constraint + [G] G (...(F ty)...) ~ F ty +That tends to rewrite a big type to smaller one. This happens in T15703, +where we had: + [G] Pure g ~ From1 (To1 (Pure g)) +Making a loop breaker and rewriting left to right just makes much bigger +types than swapping it over. + +(We might hope to have swapped it over before getting to checkTypeEq, +but better safe than sorry.) + +NB: We never see a TyVarLHS here, such as + [G] a ~ F tys here +because we'd have swapped it to + [G] F tys ~ a +in canEqCanLHS2, before getting to checkTypeEq. +-} + +check_ty_eq_rhs :: forall m a + . Monad m + => TyEqFlags m a + -> TcType -- Already zonked + -> m (PuResult a Reduction) +check_ty_eq_rhs flags ty + = case ty of + LitTy {} -> return $ okCheckRefl ty + TyConApp tc tys -> checkTyConApp flags ty tc tys + TyVarTy tv -> checkTyVar flags tv + -- Don't worry about foralls inside the kind; see Note [Checking for foralls] + -- Nor can we expand synonyms; see Note [Occurrence checking: look inside kinds] + -- in GHC.Core.FVs + + FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r} + | isInvisibleFunArg af -- e.g. Num a => blah + -> return $ PuFail impredicativeProblem -- Not allowed (TyEq:F) + | otherwise + -> do { w_res <- check_ty_eq_rhs flags w + ; a_res <- check_ty_eq_rhs flags a + ; r_res <- check_ty_eq_rhs flags r + ; return (mkFunRedn Nominal af <$> w_res <*> a_res <*> r_res) } + + AppTy fun arg -> do { fun_res <- check_ty_eq_rhs flags fun + ; arg_res <- check_ty_eq_rhs flags arg + ; return (mkAppRedn <$> fun_res <*> arg_res) } + + CastTy ty co -> do { ty_res <- check_ty_eq_rhs flags ty + ; co_res <- checkCo flags co + ; return (mkCastRedn1 Nominal ty <$> co_res <*> ty_res) } + + CoercionTy co -> do { co_res <- checkCo flags co + ; return (mkReflCoRedn Nominal <$> co_res) } + + ForAllTy {} -> return $ PuFail impredicativeProblem -- Not allowed (TyEq:F) +{-# INLINEABLE check_ty_eq_rhs #-} + +------------------- +checkCo :: Monad m => TyEqFlags m a -> Coercion -> m (PuResult a Coercion) +-- See Note [checkCo] +checkCo flags co = + case flags of + TEFTyFam {} -> + -- NB: 'TEFTyFam' case means we are not unifying. + return (pure co) + TEFTyVar + { tefTyVar_concreteCheck = conc + , tefTyVar_levelCheck = lc + , tefTyVar_occursCheck = occ + } + -- Coercions cannot appear in concrete types. + -- + -- See Note [Concrete types] in GHC.Tc.Utils.Concrete. + | case conc of { CC_None -> False; _ -> True } + -> return $ PuFail (cteProblem cteConcrete) + + -- Occurs check (can promote) + | OC_Check lhs_tv occ_prob <- occ + , LC_Promote { lc_lvlp = lhs_tv_lvl } <- lc + -> do { reason <- checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl (tyCoVarsOfCo co) + ; return $ + if cterHasNoProblem reason + then pure co + else PuFail reason } + + -- Occurs check (no promotion) + | OC_Check lhs_tv occ_prob <- occ + , nameUnique lhs_tv `elemVarSetByKey` tyCoVarsOfCo co + -> return $ PuFail (cteProblem occ_prob) + + | otherwise + -> return (pure co) + +{- Note [checkCo] +~~~~~~~~~~~~~~~~~ +We don't often care about the contents of coercions, so checking +coercions before making an equality constraint may be surprising. +But there are several cases we need to be wary of: + +(1) When we're unifying a variable, we must make sure that the variable + appears nowhere on the RHS -- even in a coercion. Otherwise, we'll + create a loop. + +(2) We must still make sure that no variable in a coercion is at too + high a level. But, when unifying, we can promote any variables we encounter. + +Note [Promotion and level-checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +"Promotion" happens when we have this: + + [W] w1: alpha[2] ~ Maybe beta[4] + +Here we must NOT unify alpha := Maybe beta, because beta may turn out +to stand for a type involving some inner skolem. Yikes! +Skolem-escape. So instead we /promote/ beta, like this: + + beta[4] := beta'[2] + [W] w1: alpha[2] ~ Maybe beta'[2] + +Now we can unify alpha := Maybe beta', which might unlock other +constraints. But if some other constraint wants to unify beta with a +nested skolem, it'll get stuck with a skolem-escape error. + +Now consider `w2` where a type family is involved (#22194): + + [W] w2: alpha[2] ~ Maybe (F gamma beta[4]) + +In `w2`, it may or may not be the case that `beta` is level 2; suppose +we later discover gamma := Int, and type instance F Int _ = Int. +So, instead, we promote the entire funcion call: + + [W] w2': alpha[2] ~ Maybe gamma[2] + [W] w3: gamma[2] ~ F gamma beta[4] + +Now we can unify alpha := Maybe gamma, which is a Good Thng. + +Wrinkle (W1) + +There is an important wrinkle: /all this only applies when unifying/. +For example, suppose we have + [G] a[2] ~ Maybe b[4] +where 'a' is a skolem. This Given might arise from a GADT match, and +we can absolutely use it to rewrite locally. In fact we must do so: +that is how we exploit local knowledge about the outer skolem a[2]. +This applies equally for a Wanted [W] a[2] ~ Maybe b[4]. Using it for +local rewriting is fine. (It's not clear to me that it is /useful/, +but it's fine anyway.) + +So we only do the level-check in checkTyVar when /unifying/ not for +skolems (or untouchable unification variables). + +Note [Family applications in canonical constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A constraint with a type family application in the RHS needs special care. +This is dealt with by `checkFamApp`. + +(CFA1) First, occurs checks. If we have + [G] a ~ Maybe (F (Maybe a)) + [W] alpha ~ Maybe (F (Maybe alpha)) + it looks as if we have an occurs check. But go read + Note [Type equality cycles] in GHC.Tc.Solver.Equality + + The same considerations apply when the LHS is a type family: + [G] G a ~ Maybe (F (Maybe (G a))) + [W] G alpha ~ Maybe (F (Maybe (G alpha))) + +(CFA2) Second, promotion. If we have (#22194) + [W] alpha[2] ~ Maybe (F beta[4]) + it is wrong to promote beta. Instead we want to split to + [W] alpha[2] ~ Maybe gamma[2] + [W] gamma[2] ~ F beta[4] + See Note [Promotion and level-checking] above. + +(CFA3) Third, concrete type variables. If we have + [W] alpha[conc] ~ Maybe (F tys) + we want to add an extra variable thus: + [W] alpha[conc] ~ Maybe gamma[conc] + [W] gamma[conc] ~ F tys + Now we can unify alpha, and that might unlock something else. + +In all these cases we want to create a fresh type variable, and +emit a new equality connecting it to the type family application. + +Once these three cases are dealt with, the `tef_fam_app` field of `TypeEqFlags` +says what to do: + +(CFA4) `TEFA_Recurse` is straightforward: just recurse into the arguments, + BUT use `recurseIntoFamTyConApp` to record that we are now "under" a + type-family application; see `famAppArgFlags`. + +(CFA5) `TEFA_Break` is the clever one. It does a two-step process: + + (1) Recurse into the arguments with `recurseIntoFamTyConApp`. + + (2) If any of the arguments fail (level-check error, occurs check, + concreteness failure), use the `FamAppBreaker` to create a cycle breaker. + + Remarks: + + * It would be possible to use Step (2) above always, skipping Step (1). + But this would create many unnecessary cycle-breaker variables. + This was the cause of #25933. + + * This always cycle-breaks the /outermost/ family application. + If we have [W] alpha ~ Maybe (F (G alpha)): + - We'll use checkFamApp on `(F (G alpha))` + - In Step (1), `recurseIntoFamTyConApp` sets `tef_fam_app := TEFA_Recurse`, + before looking at the argument `(G alpha)`. So we will not cycle-break + the latter + - The occurs check will fire when we hit `alpha` + - `checkFamApp` on `(F (G alpha))` will see the failure and invoke + the `FamAppBreaker`. + + * Step (1) may fail because of a level-check problem, which activates step (2). + This is what implements (CFA2). +-} + +------------------- +checkTyConApp :: Monad m + => TyEqFlags m a + -> TcType -> TyCon -> [TcType] + -> m (PuResult a Reduction) +checkTyConApp flags tc_app tc tys + | isTypeFamilyTyCon tc + , let arity = tyConArity tc + = if tys `lengthIs` arity + then checkFamApp flags tc_app tc tys -- Common case + else do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys + fun_app = mkTyConApp tc fun_args + ; fun_res <- checkFamApp flags fun_app tc fun_args + ; extra_res <- mapCheck (check_ty_eq_rhs flags) extra_args + ; return (mkAppRedns <$> fun_res <*> extra_res) } + + | Just ty' <- rewriterView tc_app + -- e.g. S a where type S a = F [a] + -- or type S a = Int + -- See Note [Forgetful synonyms in checkTyConApp] + = check_ty_eq_rhs flags ty' + + | not (isTauTyCon tc) + = return $ PuFail impredicativeProblem + + | tefConcrete flags + , not (isConcreteTyCon tc) + = return $ PuFail (cteProblem cteConcrete) + + | otherwise -- Recurse on arguments + = recurseIntoTyConApp flags tc tys + +------------------- +recurseIntoTyConApp :: Monad m + => TyEqFlags m a + -> TyCon -> [TcType] + -> m (PuResult a Reduction) +recurseIntoTyConApp flags tc tys + = do { tys_res <- mapCheck (check_ty_eq_rhs flags) tys + ; return (mkTyConAppRedn Nominal tc <$> tys_res) } + +recurseIntoFamTyConApp :: Monad m + => TyEqFlags m a + -> TyCon -> [TcType] + -> m (PuResult a Reduction) +recurseIntoFamTyConApp flags tc tys + = recurseIntoTyConApp (famAppArgFlags flags) tc tys + -- famAppArgFlags: adjust flags when going under fam app + +------------------- + +-- | See Note [Family applications in canonical constraints] +checkFamApp :: forall m a. + Monad m + => TyEqFlags m a + -> TcType -> TyCon -> [TcType] -- Saturated family application + -> m (PuResult a Reduction) +checkFamApp flags fam_app tc tys = + case flags of + TEFTyFam { tefTyFam_tyCon = lhs_tc, tefTyFam_args = lhs_tys + , tefTyFam_occursCheck = occ_prob } + | tcEqTyConApps lhs_tc lhs_tys tc tys + -- There is an occurs check F ty ~ ...(F ty)... + -- Do not recurse; see (CFA1) in Note [Family applications in canonical constraints] + -> do_not_recurse occ_prob + TEFTyVar { tefTyVar_concreteCheck = conc } + | wantConcreteCheck conc + -- We are checking for concreteness, e.g. kappa[conc] ~ ...(F ty)... + -- Do not recurse: type family applications are not concrete. + -- See (CFA3) in Note [Family applications in canonical constraints] + -> do_not_recurse cteConcrete + _ -> + -- We can recurse into the arguments of the type family application. + case fam_flags of + TEFA_Recurse -> + -- Simply recurse into the arguments. + -- See (CFA4) in Note [Family applications in canonical constraints] + recurseIntoFamTyConApp flags tc tys + TEFA_Break brk -> + -- Recurse into the arguments, and cycle-break if that fails + -- + -- e.g. alpha[2] ~ Maybe (F beta[2]) No problem: just unify + -- alpha[2] ~ Maybe (F beta[4]) Level-check problem: break + -- + -- NB: in the latter case, don't promote beta[4]; use 'recurseIntoFamTyConApp' + -- which modifies the flags with 'famAppArgFlags'. + do { rec_res <- recurseIntoFamTyConApp flags tc tys + ; case rec_res of + PuOK {} -> return rec_res + PuFail {} -> famAppBreaker brk fam_app + } + where + fam_flags = tef_fam_app flags + do_not_recurse prob = + case fam_flags of + TEFA_Recurse -> return $ PuFail (cteProblem prob) + TEFA_Break brk -> famAppBreaker brk fam_app + +------------------- + +-- | The result of a single check in 'checkTyVar', such as a concreteness check +-- or a level check. +data TyVarCheckResult m where + -- | Check succeded; nothing else to do. + TyVarCheck_Success :: TyVarCheckResult m + -- | Check succeeded, but requires an additional promotion. + -- + -- Invariant: at least one of the fields is not 'Nothing'. + TyVarCheck_Promote + :: Maybe TcLevel + -- ^ @Just lvl@ <=> 'TyVar' needs to be promoted to @lvl@ + -> Maybe ConcreteTvOrigin + -- ^ @Just conc_orig@ <=> 'TyVar' needs to be make concrete + -> TyVarCheckResult TcM + + -- | Check failed with some 'CheckTyEqProblem's. + -- + -- Invariant: the 'CheckTyEqResult' is not 'cteOK'. + TyVarCheck_Error + :: CheckTyEqResult -> TyVarCheckResult m + +instance Semigroup (TyVarCheckResult m) where + TyVarCheck_Success <> r = r + r <> TyVarCheck_Success = r + TyVarCheck_Error e1 <> TyVarCheck_Error e2 = + TyVarCheck_Error (e1 S.<> e2) + e@(TyVarCheck_Error {}) <> _ = e + _ <> e@(TyVarCheck_Error {}) = e + TyVarCheck_Promote l1 c1 <> TyVarCheck_Promote l2 c2 = + TyVarCheck_Promote + (combineMaybe minTcLevel l1 l2) + (combineMaybe const c1 c2) -- pick one 'ConcreteTvOrigin' arbitrarily + +combineMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a +combineMaybe _ Nothing r = r +combineMaybe _ r Nothing = r +combineMaybe f (Just a) (Just b) = Just (f a b) +instance Monoid (TyVarCheckResult m) where + mempty = TyVarCheck_Success + +checkTyVar :: forall m a. Monad m => TyEqFlags m a -> TcTyVar -> m (PuResult a Reduction) +checkTyVar flags occ_tv + = case flags of + TEFTyFam {} + -> success -- Nothing to do if the LHS is a type-family + TEFTyVar { tefTyVar_occursCheck = occ, tefTyVar_levelCheck = lc + , tefTyVar_concreteCheck = conc } + -> do { already_promoted <- promotionDone occ_tv lc conc + + ; if already_promoted + then success + -- Already promoted; job done + -- Example alpha[2] ~ Maybe (beta[4], beta[4]) + -- We promote the first occurrence, and then encounter it + -- a second time; we don't want to re-promote it! + -- Remember, the entire process started with a fully zonked type + -- so the only reason for a filled meta-tyvar is promotion + + else do_rhs_checks + [ simpleOccursCheck occ occ_tv + , tyVarLevelCheck lc occ_tv + , tyVarConcretenessCheck conc occ_tv ] + } + where + success = return $ okCheckRefl (mkTyVarTy occ_tv) + + -- Combine the results of individual checks. See 'TyVarCheckResult'. + do_rhs_checks :: [TyVarCheckResult m] -> m (PuResult a Reduction) + do_rhs_checks checks = + case mconcat checks of + TyVarCheck_Success -> success + TyVarCheck_Promote mb_lvl mb_conc -> promote flags mb_lvl mb_conc + TyVarCheck_Error cte_prob -> return $ PuFail cte_prob + + --------------------- + -- occ_tv is definitely a MetaTyVar; we need to promote it/make it concrete + promote :: TyEqFlags TcM a -> Maybe TcLevel -> Maybe ConcreteTvOrigin + -> TcM (PuResult a Reduction) + promote flags mb_lhs_tv_lvl mb_conc + | MetaTv { mtv_info = info_occ, mtv_tclvl = lvl_occ } <- tcTyVarDetails occ_tv + = do { let new_info | Just conc <- mb_conc = ConcreteTv conc + | otherwise = info_occ + new_lvl = + case mb_lhs_tv_lvl of + Nothing -> lvl_occ + Just lhs_tv_lvl -> lhs_tv_lvl `minTcLevel` lvl_occ + -- c[conc,3] ~ p[tau,2]: want to clone p:=p'[conc,2] + -- c[tau,2] ~ p[tau,3]: want to clone p:=p'[tau,2] + + -- Check the kind of occ_tv + -- + -- This is important for several reasons: + -- + -- 1. To ensure there is no occurs check or skolem-escape + -- in the kind of occ_tv. + -- 2. If the LHS is a concrete type variable and the RHS is an + -- unfilled meta-tyvar, we need to ensure that the kind of + -- 'occ_tv' is concrete. Test cases: T23051, T23176. + ; let occ_kind = tyVarKind occ_tv + ; kind_result <- check_ty_eq_rhs flags occ_kind + ; for kind_result $ \ kind_redn -> + do { let kind_co = reductionCoercion kind_redn + new_kind = reductionReducedType kind_redn + occ_tv' = setTyVarKind occ_tv new_kind + ; new_tv_ty <- promote_meta_tyvar new_info new_lvl occ_tv' + ; return $ mkGReflLeftRedn Nominal new_tv_ty (mkSymCo kind_co) + } } + + | otherwise = pprPanic "promote" (ppr occ_tv) + +--------------------- +promotionDone :: Monad m => TcTyVar -> LevelCheck m -> ConcreteCheck m -> m Bool +promotionDone occ_tv (LC_Promote {}) _ = isFilledMetaTyVar occ_tv +promotionDone occ_tv _ (CC_Promote {}) = isFilledMetaTyVar occ_tv +promotionDone _ _ _ = return False + +--------------------- +simpleOccursCheck :: OccursCheck -> TcTyVar -> TyVarCheckResult m +-- ^ The "interpreter" for 'OccursCheck' +simpleOccursCheck OC_None _ + = TyVarCheck_Success +simpleOccursCheck (OC_Check lhs_tv occ_prob) occ_tv + | lhs_tv == tyVarName occ_tv || check_kind (tyVarKind occ_tv) + = TyVarCheck_Error (cteProblem occ_prob) + | otherwise + = TyVarCheck_Success + where + (check_kind, _) = mkOccFolders lhs_tv + +------------------------- +tyVarLevelCheck :: LevelCheck m -> TcTyVar -> TyVarCheckResult m +-- ^ The "interpreter" for 'LevelCheck' +tyVarLevelCheck LC_None _ = TyVarCheck_Success +tyVarLevelCheck lc occ_tv + | not occ_is_deeper + = TyVarCheck_Success + | isSkolemTyVar occ_tv + = TyVarCheck_Error (cteProblem cteSkolemEscape) + | otherwise + = case lc of + LC_Check { lc_lenient = lenient } -> + if lenient + then TyVarCheck_Success + else TyVarCheck_Error (cteProblem cteSkolemEscape) + LC_Promote { lc_lvlp = lhs_tv_lvl } -> + TyVarCheck_Promote (Just lhs_tv_lvl) Nothing + where + occ_is_deeper = + case lc of + LC_Check { lc_lvlc = lhs_tv_lvl } -> + tcTyVarLevel occ_tv `strictlyDeeperThan` lhs_tv_lvl + LC_Promote { lc_lvlp = lhs_tv_lvl } -> + tcTyVarLevel occ_tv `strictlyDeeperThan` lhs_tv_lvl + +------------------------- +tyVarConcretenessCheck :: ConcreteCheck m -> TcTyVar -> TyVarCheckResult m +-- ^ The "interpreter" for 'ConcreteCheck' +tyVarConcretenessCheck cc occ_tv + | CC_None <- cc -- No concreteness checks => ok + = TyVarCheck_Success + | isConcreteTyVar occ_tv -- It's concrete already => ok + = TyVarCheck_Success + | not (isMetaTyVar occ_tv) -- Not a meta-tyvar => error + = TyVarCheck_Error (cteProblem cteConcrete) + + | otherwise -- It's a non-concrete meta-tyvar + = case cc of + CC_Check -> TyVarCheck_Success + CC_Promote conc_orig -> TyVarCheck_Promote Nothing (Just conc_orig) + -- CC_None is dealt with at the top + +------------------------- +checkPromoteFreeVars :: CheckTyEqProblem -- What occurs check problem to report + -> Name -> TcLevel + -> TyCoVarSet -> TcM CheckTyEqResult +-- Check this set of TyCoVars for +-- (a) occurs check +-- (b) promote if necessary, or report skolem escape +checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl vs + = do { oks <- mapM do_one (nonDetEltsUniqSet vs) + ; return (mconcat oks) } + where + do_one :: TyCoVar -> TcM CheckTyEqResult + do_one v | isCoVar v = return cteOK + | tyVarName v == lhs_tv = return (cteProblem occ_prob) + | no_promotion = return cteOK + | not (isMetaTyVar v) = return (cteProblem cteSkolemEscape) + | otherwise = promote_one v + where + no_promotion = not (tcTyVarLevel v `strictlyDeeperThan` lhs_tv_lvl) + + -- isCoVar case: 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. + + promote_one :: TyVar -> TcM CheckTyEqResult + promote_one tv = + do { _ <- promote_meta_tyvar TauTv lhs_tv_lvl tv + ; return cteOK } + +promote_meta_tyvar :: MetaInfo -> TcLevel -> TcTyVar -> TcM TcType +promote_meta_tyvar info dest_lvl occ_tv + = do { -- Check whether occ_tv is already unified. The rhs-type + -- started zonked, but we may have promoted one of its type + -- variables, and we then encounter it for the second time. + -- But if so, it'll definitely be another already-checked TyVar + mb_filled <- isFilledMetaTyVar_maybe occ_tv + ; case mb_filled of { + Just ty -> return ty ; + Nothing -> + + -- OK, not done already, so clone/promote it + do { new_tv <- cloneMetaTyVarWithInfo info dest_lvl occ_tv + ; liftZonkM $ writeMetaTyVar occ_tv (mkTyVarTy new_tv) + ; traceTc "promoteTyVar" (ppr occ_tv <+> text "-->" <+> ppr new_tv) + ; return (mkTyVarTy new_tv) } } } + + + +------------------------- +touchabilityTest :: TcLevel -> TcTyVar -> Bool +-- ^ 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.Equality +-- +-- @True@ <=> the variable is touchable +touchabilityTest given_eq_lvl tv + | MetaTv { mtv_tclvl = tv_lvl } <- tcTyVarDetails tv + = tv_lvl `deeperThanOrSame` given_eq_lvl + | otherwise + = False + +------------------------- +-- | checkTopShape checks (TYVAR-TV) +-- Note [Unification preconditions]; returns True if these conditions +-- are satisfied. But see the Note for other preconditions, too. +checkTopShape :: MetaInfo -> TcType -> Bool +checkTopShape info xi + = case info of + TyVarTv -> + case getTyVar_maybe xi of -- Looks through type synonyms + Nothing -> False + Just tv -> case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle + SkolemTv {} -> True + RuntimeUnk -> True + MetaTv { mtv_info = TyVarTv } -> True + _ -> False + CycleBreakerTv -> False -- We never unify these + _ -> True + +-------------------------------------------------------------------------------- +-- Making a type concrete. + +-- | Try to turn the provided type into a concrete type, by ensuring +-- unfilled metavariables are appropriately marked as concrete. +-- +-- Returns a coercion whose RHS is a zonked type which is "as concrete as possible", +-- and a collection of Wanted equality constraints that are necessary to make +-- the type concrete. +-- +-- For example, for an input @TYPE a[sk]@ we will return a coercion with RHS +-- @TYPE gamma[conc]@ together with the Wanted equality constraint @a ~# gamma@. +-- +-- INVARIANT: the RHS type of the returned coercion is equal to the input type, +-- up to zonking and the returned Wanted equality constraints. +-- +-- INVARIANT: if this function returns an empty list of constraints +-- then the RHS type of the returned coercion is concrete, +-- in the sense of Note [Concrete types]. +makeTypeConcrete :: FastString -> ConcreteTvOrigin + -> TcType -> TcM (TcCoercion, Cts) +makeTypeConcrete occ_fs conc_orig ty = + do { traceTc "makeTypeConcrete {" $ + vcat [ text "ty:" <+> ppr ty ] + + -- To make a type 'ty' concrete, we query what would happen were we + -- to try unifying + -- + -- alpha[conc] ~# ty + -- + -- for a fresh concrete metavariable 'alpha'. + -- + -- We do this by calling 'checkTyEqRhs' with suitable 'TyEqFlags'. + -- NB: we don't actually need to create a fresh concrete metavariable + -- in order to call 'checkTyEqRhs'. + ; let ty_eq_flags = + TEFTyVar + { tefTyVar_occursCheck = OC_None + -- LHS is a fresh meta-tyvar: no occurs check needed + , tefTyVar_levelCheck = LC_None + , tefTyVar_concreteCheck = CC_Promote conc_orig + , tef_fam_app = TEFA_Recurse + } + + -- NB: 'checkTyEqRhs' expects a fully zonked type as input. + ; ty' <- liftZonkM $ zonkTcType ty + ; pu_res <- checkTyEqRhs @TcM @() ty_eq_flags ty' + -- NB: 'checkTyEqRhs' will also check the kind, thus upholding the + -- invariant that the kind of a concrete type must also be a concrete type. + + ; (cts, final_co) <- + case pu_res of + PuOK _ redn -> + do { traceTc "makeTypeConcrete: unifier success" $ + vcat [ text "ty:" <+> ppr ty <+> dcolon <+> ppr (typeKind ty) + , text "redn:" <+> ppr redn + ] + ; return (emptyBag, mkSymCo $ reductionCoercion redn) + -- NB: the unifier returns a 'Reduction' with the concrete + -- type on the left, but we want a coercion with it on the + -- right; so we use 'mkSymCo'. + } + PuFail _prob -> + do { traceTc "makeTypeConcrete: unifier failure" $ + vcat [ text "ty:" <+> ppr ty <+> dcolon <+> ppr (typeKind ty) + , text "problem:" <+> ppr _prob + ] + -- We failed to make 'ty' concrete. In order to continue + -- typechecking, we proceed as follows: + -- + -- - create a new concrete metavariable alpha[conc] + -- - emit the equality @ty ~# alpha[conc]@. + -- + -- This equality will eventually get reported as insoluble + -- to the user. + + -- The kind of a concrete metavariable must itself be concrete, + -- so we need to do a concreteness check on the kind first. + ; let ki = typeKind ty + ; (kind_co, kind_cts) <- + if isConcreteType ki + then return (mkNomReflCo ki, emptyBag) + else makeTypeConcrete occ_fs conc_orig ki + + -- Now create the new concrete metavariable. + ; conc_tv <- newConcreteTyVar conc_orig occ_fs (coercionRKind kind_co) + ; let conc_ty = mkTyVarTy conc_tv + pty = mkEqPredRole Nominal ty' conc_ty + ; hole <- newCoercionHole pty + ; loc <- getCtLocM orig (Just KindLevel) + ; let ct = mkNonCanonical $ CtWanted + $ WantedCt { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + ; return (kind_cts S.<> unitBag ct, HoleCo hole) + } + + ; traceTc "makeTypeConcrete }" $ + vcat [ text "ty :" <+> _ppr_ty ty + , text "ty':" <+> _ppr_ty ty' + , text "final_co:" <+> _ppr_co final_co ] + + ; return (final_co, cts) + } + where + + _ppr_ty ty = ppr ty <+> dcolon <+> ppr (typeKind ty) + _ppr_co co = ppr co <+> dcolon <+> parens (_ppr_ty (coercionLKind co)) <+> text "~#" <+> parens (_ppr_ty (coercionRKind co)) + + orig :: CtOrigin + orig = case conc_orig of + ConcreteFRR frr_orig -> FRROrigin frr_orig + + +{- ********************************************************************* +* * + mightEqualLater +* * +********************************************************************* -} + +{- Note [What might equal later?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must determine whether a Given might later equal a Wanted: + see Note [Instance and Given overlap] in GHC.Tc.Solver.Dict + +We definitely need to account for the possibility that any metavariable might be +arbitrarily instantiated. Yet we do *not* want to allow skolems 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[tau] ~? C Int + + That Given certainly might match later. + +2. C a[sk] ~? C Int + + No. No new givens are going to arise that will get the `a` to rewrite + to Int. Example: + f :: forall a. C a => blah + f = rhs -- Gives rise to [W] C Int + It would be silly to fail to solve ([W] C Int), just because we have + ([G] C a) in the Givens! + +3. C alpha[tv] ~? C Int + + In this variant of (1) that alpha[tv] is a TyVarTv, unifiable only with + other type /variables/. It cannot equal Int later. + +4. C (F alpha[tau]) ~? 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[sk]) ~? C Int. For example + f :: forall a. C (F a) => blah + f = rhs -- Gives rise to [W] C Int + + No, this won't match later. If we could rewrite (F a), we would + have by now. But see also Red Herring below. + + This arises in instance decls too. For example in GHC.Core.Ppr we see + instance Outputable (XTickishId pass) + => Outputable (GenTickish pass) where + If we have [W] Outputable Int in the body, we don't want to fail to solve + it because (XTickishId pass) might simplify to Int. + +7. C (Maybe alpha[tau]) ~? C alpha[tau] + + 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 led to #19107, tested in + typecheck/should_compile/T19107. + +8. C alpha[cbv] ~? C Int + where alpha[cbv] = F a + + The alpha[cbv] is a cycle-breaker var which stands for F a. See + Note [Type equality cycles] in GHC.Tc.Solver.Equality + 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 alpha[cbv] ~? C Int + where alpha[cbv] = F beta[tau] + + 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[tau], Int) ~? C (Bool, F alpha[tau]) + + This cannot equal later, because F alpha would have to equal both Bool and + Int. + +To deal with type family applications, we use the "fine-grained" Core unifier. +See Note [Apartness and type families] in GHC.Core.Unify, controlled +by the `bind_fam :: BindFamFun` function defined in `mightEqualLater`. + +One tricky point: 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. However: 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. See the +use of `mentions_meta_ty_var` in `mightEqualLater`. + +This treatment fixes #18910 and is tested in +typecheck/should_compile/InstanceGivenOverlap{,2} + +Red Herring +~~~~~~~~~~~ +In #21208, we have this scenario: + + instance forall b. C b + [G] C a[sk] + [W] C (F a[sk]) + +What should we do with that wanted? According to the logic above, the Given +cannot match later (this is example 6), and so we use the global instance. +But wait, you say: What if we learn later (say by a future type instance F a = a) +that F a unifies with a? That looks like the Given might really match later! + +This mechanism described in this Note is *not* about this kind of situation, however. +It is all asking whether a Given might match the Wanted *in this run of the solver*. +It is *not* about whether a variable might be instantiated so that the Given matches, +or whether a type instance introduced in a downstream module might make the Given match. +The reason we care about what might match later is only about avoiding order-dependence. +That is, we don't want to commit to a course of action that depends on seeing constraints +in a certain order. But an instantiation of a variable and a later type instance +don't introduce order dependency in this way, and so mightMatchLater is right to ignore +these possibilities. + +Here is an example, with no type families, that is perhaps clearer: + + instance forall b. C (Maybe b) + [G] C (Maybe Int) + [W] C (Maybe a) + +What to do? We *might* say that the Given could match later and should thus block +us from using the global instance. But we don't do this. Instead, we rely on class +coherence to say that choosing the global instance is just fine, even if later we +call a function with (a := Int). After all, in this run of the solver, [G] C (Maybe Int) +will definitely never match [W] C (Maybe a). (Recall that we process Givens before +Wanteds, so there is no [G] a ~ Int hanging about unseen.) + +Interestingly, in the first case (from #21208), the behavior changed between +GHC 8.10.7 and GHC 9.2, with the latter behaving correctly and the former +reporting overlapping instances. + +Test case: typecheck/should_compile/T21208. + +-} + +-------------------------------------------------------------------------------- +-- mightEqualLater + +mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Maybe Subst +-- See Note [What might equal later?] +-- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Dict +mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc + | prohibitedSuperClassSolve given_loc wanted_loc + = Nothing + + | otherwise + = case tcUnifyTysFG bind_fam bind_tv [given_pred] [wanted_pred] of + Unifiable subst + -> Just subst + MaybeApart reason subst + | MARInfinite <- reason -- see Example 7 in the Note. + -> Nothing + | otherwise + -> Just subst + SurelyApart -> Nothing + + where + bind_tv :: BindTvFun + bind_tv tv rhs_ty + | MetaTv { mtv_info = info } <- tcTyVarDetails tv + , ok_shape tv info rhs_ty + , can_unify tv rhs_ty + = BindMe + + | otherwise + = DontBindMe + + bind_fam :: BindFamFun + -- See Examples (4), (5), and (6) from the Note, especially (6) + bind_fam _fam_tc fam_args _rhs + | anyFreeVarsOfTypes mentions_meta_ty_var fam_args = BindMe + | otherwise = DontBindMe + + can_unify :: TcTyVar -> TcType -> Bool + can_unify tv rhs_ty + -- See Note [Use checkTyEqRhs in mightEqualLater] + | PuOK {} <- runIdentity $ checkTyEqRhs (pureTyEqFlags_LHSMetaTyVar tv) rhs_ty + = True + | otherwise + = False + + -- 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 checkTopShape, but allows cbv variables to unify + ok_shape :: TcTyVar -> MetaInfo -> Type -> Bool + ok_shape _lhs_tv TyVarTv rhs_ty -- see Example 3 from the Note + | Just rhs_tv <- getTyVar_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 + ok_shape lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv + +{- Note [Use checkTyEqRhs in mightEqualLater] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In 'mightEqualLater', we are checking whether two types ty1 and ty2 might become +equal after further unifications. To do this, we call the pure unifier, via +the function 'tcUnifyTysFG'. However, it is important that we don't return +false positives: + + 1. Level check: ty1 = alpha[tau:1] /~ ty2 = k[sk:3] + 2. Occurs check: ty1 = beta[tau] /~ ty2 = Maybe beta[tau] + 3. Concreteness: ty1 = kappa[conc] /~ ty2 = k[sk]. + +In these examples, ty1 and ty2 cannot unify; to inform the pure unifier of this +fact, we use 'checkTyEqRhs' to provide the 'BindTvFun'. + +Failing to account for this caused #25744: + + work item = [W] w1: Eq (g[sk:1] x[sk:3]) + inerts = { [G] g1: Eq x[sk:3] + , [G] g2: forall y. Eq y => Eq (g[sk:1] y) + , [G] g3: Eq (f[tau:1] v[tau:1]) } + +We want to solve w1 using g1 and g2. The presence of g3 is irrelevant, because +we cannot unify 'f[tau:1] v[tau:1]' and 'g[sk:1] x[sk:3]' due to skolem escape. +-} + +-- | 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 (lookupBag cbv) cbvs_stack) + = tyfam_app + | otherwise + = pprPanic "lookupCycleBreakerVar found an unbound cycle breaker" (ppr cbv $$ ppr cbvs_stack) + +-------------------------------------------------------------------------------- diff --git a/GHC/Tc/Utils/Unify.hs-boot b/GHC/Tc/Utils/Unify.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Unify.hs-boot @@ -0,0 +1,24 @@ +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.Constraint ( Cts ) +import GHC.Tc.Types.Evidence ( TcCoercion ) +import GHC.Tc.Types.Origin ( CtOrigin, TypedThing ) +import GHC.Tc.Utils.TcType ( TcType, ConcreteTvOrigin ) + +import GHC.Data.FastString ( FastString ) + + +-- This boot file exists only to tie the knot between +-- GHC.Tc.Utils.Unify and GHC.Tc.Utils.Instantiate/GHC.Tc.Utils.TcMType + +unifyType :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion +unifyInvisibleType :: TcTauType -> TcTauType -> TcM TcCoercion + +tcSubMult :: CtOrigin -> Mult -> Mult -> TcM () + +makeTypeConcrete :: FastString -> ConcreteTvOrigin + -> TcType -> TcM (TcCoercion, Cts) diff --git a/GHC/Tc/Validity.hs b/GHC/Tc/Validity.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Validity.hs @@ -0,0 +1,3025 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Tc.Validity ( + Rank(..), UserTypeCtxt(..), checkValidType, checkValidMonoType, + checkValidTheta, + checkValidInstance, checkValidInstHead, validDerivPred, + checkTySynRhs, checkEscapingKind, + checkValidCoAxiom, checkValidCoAxBranch, + checkFamPatBinders, checkTyFamEqnValidityInfo, + checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst, + checkTyConTelescope, + ) where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Data.Maybe + +-- friends: +import GHC.Tc.Utils.Unify ( tcSubTypeAmbiguity ) +import GHC.Tc.Solver ( simplifyAmbiguityCheck ) +import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), AssocInstInfo(..) ) +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Instance.Family +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Rank +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad +import GHC.Tc.Zonk.TcType + +import GHC.Builtin.Types +import GHC.Builtin.Names +import GHC.Builtin.Uniques ( mkAlphaTyVarUnique ) + +import GHC.Core.Type +import GHC.Core.Unify ( typesAreApart, tcMatchTyX_BM, BindFlag(..) ) +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Predicate +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Tidy +import GHC.Core.FamInstEnv ( isDominatedBy, injectiveBranches + , InjectivityCheckResult(..) ) + +import GHC.Hs +import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Types.Error +import GHC.Types.Basic ( TypeOrKind(..), UnboxedTupleOrSum(..) + , unboxedTupleOrSumExtension ) +import GHC.Types.Name +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Var ( VarBndr(..), isInvisibleFunArg, mkTyVar, tyVarName ) +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Types.TyThing ( TyThing(..) ) +import GHC.Types.Unique.Set( isEmptyUniqSet ) + +import GHC.Utils.FV +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic + +import GHC.Data.List.SetOps + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.Monad +import Data.Foldable +import Data.Function +import Data.List ( (\\) ) +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty ( NonEmpty(..) ) + +{- +************************************************************************ +* * + Checking for ambiguity +* * +************************************************************************ + +Note [The ambiguity check for type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +checkAmbiguity is a check on *user-supplied type signatures*. It is +*purely* there to report functions that cannot possibly be called. So for +example we want to reject: + f :: C a => Int +The idea is there can be no legal calls to 'f' because every call will +give rise to an ambiguous constraint. We could soundly omit the +ambiguity check on type signatures entirely, at the expense of +delaying ambiguity errors to call sites. Indeed, the flag +-XAllowAmbiguousTypes switches off the ambiguity check. + +What about things like this: + class D a b | a -> b where .. + h :: D Int b => Int +The Int may well fix 'b' at the call site, so that signature should +not be rejected. Moreover, using *visible* fundeps is too +conservative. Consider + class X a b where ... + class D a b | a -> b where ... + instance D a b => X [a] b where... + h :: X a b => a -> a +Here h's type looks ambiguous in 'b', but here's a legal call: + ...(h [True])... +That gives rise to a (X [Bool] beta) constraint, and using the +instance means we need (D Bool beta) and that fixes 'beta' via D's +fundep! + +Behind all these special cases there is a simple guiding principle. +Consider + + f :: + f = ...blah... + + g :: + g = f + +You would think that the definition of g would surely typecheck! +After all f has exactly the same type, and g=f. But in fact f's type +is instantiated and the instantiated constraints are solved against +the originals, so in the case of an ambiguous type it won't work. +Consider our earlier example f :: C a => Int. Then in g's definition, +we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a), +and fail. + +So in fact we use this as our *definition* of ambiguity. We use a +very similar test for *inferred* types, to ensure that they are +unambiguous. See Note [Impedance matching] in GHC.Tc.Gen.Bind. + +This test is very conveniently implemented by calling + tcSubType +This neatly takes account of the functional dependency stuff above, +and implicit parameter (see Note [Implicit parameters and ambiguity]). +And this is what checkAmbiguity does. + +Note [The squishiness of the ambiguity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What about this? + g :: C [a] => Int +Is every call to 'g' ambiguous? After all, we might have + instance C [a] where ... +at the call site. So maybe that type is ok! Indeed even f's +quintessentially ambiguous type might, just possibly be callable: +with -XFlexibleInstances we could have + instance C a where ... +and now a call could be legal after all! Well, we'll reject this +unless the instance is available *here*. + +But even that's not quite right. Even a function with an utterly-ambiguous +type like f :: Eq a => Int -> Int +is still callable if you are prepared to use visible type application, +thus (f @Bool x). + +In short, the ambiguity check is a good-faith attempt to say "you are likely +to have trouble if your function has this type"; it is NOT the case that +"you can't call this function without giving a type error". + +See also Note [Ambiguity check and deep subsumption] in GHC.Tc.Utils.Unify. + +Note [When to call checkAmbiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We call checkAmbiguity + (a) on user-specified type signatures + (b) in checkValidType + +Conncerning (b), you might wonder about nested foralls. What about + f :: forall b. (forall a. Eq a => b) -> b +The nested forall is ambiguous. Originally we called checkAmbiguity +in the forall case of check_type, but that had two bad consequences: + * We got two error messages about (Eq b) in a nested forall like this: + g :: forall a. Eq a => forall b. Eq b => a -> a + * If we try to check for ambiguity of a nested forall like + (forall a. Eq a => b), the implication constraint doesn't bind + all the skolems, which results in "No skolem info" in error + messages (see #10432). + +To avoid this, we call checkAmbiguity once, at the top, in checkValidType. +(I'm still a bit worried about unbound skolems when the type mentions +in-scope type variables.) + +In fact, because of the co/contra-variance implemented in tcSubType, +this *does* catch function f above. too. + +Concerning (a) the ambiguity check is only used for *user* types, not +for types coming from interface files. The latter can legitimately +have ambiguous types. Example + + class S a where s :: a -> (Int,Int) + instance S Char where s _ = (1,1) + f:: S a => [a] -> Int -> (Int,Int) + f (_::[a]) x = (a*x,b) + where (a,b) = s (undefined::a) + +Here the worker for f gets the type + fw :: forall a. S a => Int -> (# Int, Int #) + + +Note [Implicit parameters and ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only a *class* predicate can give rise to ambiguity +An *implicit parameter* cannot. For example: + foo :: (?x :: [a]) => Int + foo = length ?x +is fine. The call site will supply a particular 'x' + +Furthermore, the type variables fixed by an implicit parameter +propagate to the others. E.g. + foo :: (Show a, ?x::[a]) => Int + foo = show (?x++?x) +The type of foo looks ambiguous. But it isn't, because at a call site +we might have + let ?x = 5::Int in foo +and all is well. In effect, implicit parameters are, well, parameters, +so we can take their type variables into account as part of the +"tau-tvs" stuff. This is done in the function 'GHC.Tc.Instance.FunDeps.grow'. +-} + +checkAmbiguity :: UserTypeCtxt -> Type -> TcM () +checkAmbiguity ctxt ty + | wantAmbiguityCheck ctxt + = do { traceTc "Ambiguity check for {" (ppr ty) + -- Solve the constraints eagerly because an ambiguous type + -- can cause a cascade of further errors. Since the free + -- tyvars are skolemised, we can safely use tcSimplifyTop + ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes + ; unless allow_ambiguous $ + do { (_wrap, wanted) <- addErrCtxt (AmbiguityCheckCtxt ctxt allow_ambiguous) $ + captureConstraints $ + tcSubTypeAmbiguity ctxt ty ty + -- See Note [Ambiguity check and deep subsumption] + -- in GHC.Tc.Utils.Unify + ; simplifyAmbiguityCheck ty wanted } + + ; traceTc "} Done ambiguity check for" (ppr ty) } + + | otherwise + = return () + +wantAmbiguityCheck :: UserTypeCtxt -> Bool +wantAmbiguityCheck ctxt + = case ctxt of -- See Note [When we don't check for ambiguity] + GhciCtxt {} -> False + TySynCtxt {} -> False + TypeAppCtxt -> False + StandaloneKindSigCtxt{} -> False + _ -> True + +-- | Check whether the type signature contains custom type errors, +-- and fail if so. +-- +-- Note that some custom type errors are acceptable: +-- +-- - in the RHS of a type synonym, e.g. to allow users to define +-- type synonyms for custom type errors with large messages (#20181), +-- - inside a type family application, as a custom type error +-- might evaporate after performing type family reduction (#20241). +checkUserTypeError :: UserTypeCtxt -> Type -> TcM () +-- Very unsatisfactorily (#11144) we need to tidy the type +-- because it may have come from an /inferred/ signature, not a +-- user-supplied one. This is really only a half-baked fix; +-- the other errors in checkValidType don't do tidying, and so +-- may give bad error messages when given an inferred type. +checkUserTypeError ctxt ty + | TySynCtxt {} <- ctxt -- Do not complain about TypeError on the + = return () -- RHS of type synonyms. See #20181 + + | Just msg <- deepUserTypeError_maybe ty + = do { env0 <- liftZonkM tcInitTidyEnv + ; let (env1, tidy_msg) = tidyOpenTypeX env0 msg + ; failWithTcM (env1, TcRnUserTypeError tidy_msg) } + | otherwise + = return () + + +{- Note [When we don't check for ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a few places we do not want to check a user-specified type for ambiguity + +* GhciCtxt: Allow ambiguous types in GHCi's :kind command + E.g. type family T a :: * -- T :: forall k. k -> * + Then :k T should work in GHCi, not complain that + (T k) is ambiguous! + +* TySynCtxt: type T a b = C a b => blah + It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow + cure the ambiguity. So we defer the ambiguity check to the use site. + + There is also an implementation reason (#11608). In the RHS of + a type synonym we don't (currently) instantiate 'a' and 'b' with + TcTyVars before calling checkValidType, so we get assertion failures + from doing an ambiguity check on a type with TyVars in it. Fixing this + would not be hard, but let's wait till there's a reason. + +* TypeAppCtxt: visible type application + f @ty + No need to check ty for ambiguity + +* StandaloneKindSigCtxt: type T :: ksig + Kinds need a different ambiguity check than types, and the currently + implemented check is only good for types. See #14419, in particular + https://gitlab.haskell.org/ghc/ghc/issues/14419#note_160844 + +************************************************************************ +* * + Checking validity of a user-defined type +* * +************************************************************************ + +When dealing with a user-written type, we first translate it from an HsType +to a Type, performing kind checking, and then check various things that should +be true about it. We don't want to perform these checks at the same time +as the initial translation because (a) they are unnecessary for interface-file +types and (b) when checking a mutually recursive group of type and class decls, +we can't "look" at the tycons/classes yet. Also, the checks are rather +diverse, and used to really mess up the other code. + +One thing we check for is 'rank'. + + Rank 0: monotypes (no foralls) + Rank 1: foralls at the front only, Rank 0 inside + Rank 2: foralls at the front, Rank 1 on left of fn arrow, + + basic ::= tyvar | T basic ... basic + + r2 ::= forall tvs. cxt => r2a + r2a ::= r1 -> r2a | basic + r1 ::= forall tvs. cxt => r0 + r0 ::= r0 -> r0 | basic + +Another thing is to check that type synonyms are saturated. +This might not necessarily show up in kind checking. + type A i = i + data T k = MkT (k Int) + f :: T A -- BAD! +-} + +checkValidType :: UserTypeCtxt -> Type -> TcM () +-- Checks that a user-written type is valid for the given context +-- Assumes argument is fully zonked +-- Assumes argument is well-kinded; +-- that is, checkValidType doesn't need to do kind checking +-- Not used for instance decls; checkValidInstance instead +checkValidType ctxt ty + = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) + ; rankn_flag <- xoptM LangExt.RankNTypes + ; impred_flag <- xoptM LangExt.ImpredicativeTypes + ; let gen_rank :: Rank -> Rank + gen_rank r | rankn_flag = ArbitraryRank + | otherwise = r + + rank1 = gen_rank r1 + rank0 = gen_rank MonoTypeRankZero + + r1 = LimitedRank True MonoTypeRankZero + + rank + = case ctxt of + DefaultDeclCtxt-> MustBeMonoType + PatSigCtxt -> rank0 + TySynCtxt _ -> rank0 + + ExprSigCtxt {} -> rank1 + KindSigCtxt -> rank1 + StandaloneKindSigCtxt{} -> rank1 + TypeAppCtxt | impred_flag -> ArbitraryRank + | otherwise -> MonoTypeTyConArg + -- Normally, ImpredicativeTypes is handled in check_arg_type, + -- but visible type applications don't go through there. + -- So we do this check here. + + FunSigCtxt {} -> rank1 + InfSigCtxt {} -> rank1 -- Inferred types should obey the + -- same rules as declared ones + + ConArgCtxt _ -> rank1 -- We are given the type of the entire + -- constructor, hence rank 1 + PatSynCtxt _ -> rank1 + + ForSigCtxt _ -> rank1 + SpecInstCtxt -> rank1 + GhciCtxt {} -> ArbitraryRank + + TyVarBndrKindCtxt {} -> rank0 + RuleBndrTypeCtxt{} -> rank1 + DataKindCtxt _ -> rank1 + TySynKindCtxt _ -> rank1 + TyFamResKindCtxt _ -> rank1 + + _ -> panic "checkValidType" + -- Can't happen; not used for *user* sigs + + ; env <- liftZonkM $ tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) + ; expand <- initialExpandMode + ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt + , ve_rank = rank, ve_expand = expand } + + -- Check the internal validity of the type itself + -- Fail if bad things happen, else we misleading + -- (and more complicated) errors in checkAmbiguity + ; checkNoErrs $ + do { check_type ve ty + ; checkUserTypeError ctxt ty + ; traceTc "done ct" (ppr ty) } + + -- Check for ambiguous types. See Note [When to call checkAmbiguity] + -- NB: this will happen even for monotypes, but that should be cheap; + -- and there may be nested foralls for the subtype test to examine + ; checkAmbiguity ctxt ty + + ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) } + +checkValidMonoType :: Type -> TcM () +-- Assumes argument is fully zonked +checkValidMonoType ty + = do { env <- liftZonkM $ tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) + ; expand <- initialExpandMode + ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt + , ve_rank = MustBeMonoType, ve_expand = expand } + ; check_type ve ty } + +checkTySynRhs :: UserTypeCtxt -> TcType -> TcM () +checkTySynRhs ctxt ty + | returnsConstraintKind actual_kind + = do { ck <- xoptM LangExt.ConstraintKinds + ; if ck + then when (isConstraintLikeKind actual_kind) + (do { dflags <- getDynFlags + ; expand <- initialExpandMode + ; check_pred_ty emptyTidyEnv dflags ctxt expand ty }) + else addErrTcM ( emptyTidyEnv + , TcRnIllegalConstraintSynonymOfKind (tidyType emptyTidyEnv actual_kind) + ) } + + | otherwise + = return () + where + actual_kind = typeKind ty + +{- 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 /user-written/ type signatures f :: blah, we make this +check as part of kind-checking the type signature in tcHsSigType; see +Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType. + +But in two other places we need to check for an escaping result kind: + +* 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. + +* When inferring the type of a function, there is no user-written type + that we are checking. Forgetting this led to #22743. Now we call + checkEscapingKind in GHC.Tc.Gen.Bind.mkInferredPolyId + +Historical note: we used to do the escaping-kind check in +checkValidType (#20929 discusses), but that is now redundant. +-} + +checkEscapingKind :: Type -> TcM () +-- Give a sigma-type (forall a1 .. an. ty), where (ty :: ki), +-- check that `ki` does not mention any of the binders a1..an. +-- Otherwise the type is ill-kinded +-- See Note [Check for escaping result kind] +checkEscapingKind poly_ty + | (tvs, tau) <- splitForAllTyVars poly_ty + , let tau_kind = typeKind tau + , Nothing <- occCheckExpand 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 poly_ty tau_kind + | otherwise + = return () + +funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result +funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) +funArgResRank other_rank = (other_rank, other_rank) + +forAllAllowed :: Rank -> Bool +forAllAllowed ArbitraryRank = True +forAllAllowed (LimitedRank forall_ok _) = forall_ok +forAllAllowed _ = False + +-- | Indicates whether a 'UserTypeCtxt' represents type-level contexts, +-- kind-level contexts, or both. +data TypeOrKindCtxt + = OnlyTypeCtxt + -- ^ A 'UserTypeCtxt' that only represents type-level positions. + | OnlyKindCtxt + -- ^ A 'UserTypeCtxt' that only represents kind-level positions. + | BothTypeAndKindCtxt + -- ^ A 'UserTypeCtxt' that can represent both type- and kind-level positions. + deriving Eq + +instance Outputable TypeOrKindCtxt where + ppr ctxt = text $ case ctxt of + OnlyTypeCtxt -> "OnlyTypeCtxt" + OnlyKindCtxt -> "OnlyKindCtxt" + BothTypeAndKindCtxt -> "BothTypeAndKindCtxt" + +-- | Determine whether a 'UserTypeCtxt' can represent type-level contexts, +-- kind-level contexts, or both. +typeOrKindCtxt :: UserTypeCtxt -> TypeOrKindCtxt +typeOrKindCtxt (FunSigCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (InfSigCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (ExprSigCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (TypeAppCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (PatSynCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (PatSigCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (RuleBndrTypeCtxt {})= OnlyTypeCtxt +typeOrKindCtxt (ForSigCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (DefaultDeclCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (InstDeclCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (SpecInstCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (GenSigCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (ClassSCCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (SigmaCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (DataTyCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (DerivClauseCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (ConArgCtxt {}) = OnlyTypeCtxt + -- Although data constructors can be promoted with DataKinds, we always + -- validity-check them as though they are the types of terms. We may need + -- to revisit this decision if we ever allow visible dependent quantification + -- in the types of data constructors. + +typeOrKindCtxt (KindSigCtxt {}) = OnlyKindCtxt +typeOrKindCtxt (StandaloneKindSigCtxt {}) = OnlyKindCtxt +typeOrKindCtxt (TyVarBndrKindCtxt {}) = OnlyKindCtxt +typeOrKindCtxt (DataKindCtxt {}) = OnlyKindCtxt +typeOrKindCtxt (TySynKindCtxt {}) = OnlyKindCtxt +typeOrKindCtxt (TyFamResKindCtxt {}) = OnlyKindCtxt + +-- These cases are also described in Note [No constraints in kinds], so any +-- change here should be reflected in that note. +typeOrKindCtxt (TySynCtxt {}) = BothTypeAndKindCtxt + -- Type synonyms can have types and kinds on their RHSs +typeOrKindCtxt (GhciCtxt {}) = BothTypeAndKindCtxt + -- GHCi's :kind command accepts both types and kinds + +-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the +-- context for a kind of a type. +-- If the 'UserTypeCtxt' can refer to both types and kinds, this function +-- conservatively returns 'True'. +-- +-- An example of something that is unambiguously the kind of a type is the +-- @Show a => a -> a@ in @type Foo :: Show a => a -> a@. On the other hand, the +-- same type in @foo :: Show a => a -> a@ is unambiguously the type of a term, +-- not the kind of a type, so it is permitted. +typeLevelUserTypeCtxt :: UserTypeCtxt -> Bool +typeLevelUserTypeCtxt ctxt = case typeOrKindCtxt ctxt of + OnlyTypeCtxt -> True + OnlyKindCtxt -> False + BothTypeAndKindCtxt -> True + +-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the +-- context for a kind of a type, where the arbitrary use of constraints is +-- currently disallowed. +allConstraintsAllowed :: UserTypeCtxt -> Bool +allConstraintsAllowed = typeLevelUserTypeCtxt + +-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the +-- context for a kind of a type, where all function arrows currently +-- must be unrestricted. +linearityAllowed :: UserTypeCtxt -> Bool +linearityAllowed = typeLevelUserTypeCtxt + +-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the +-- context for the type of a term, where visible, dependent quantification is +-- currently disallowed. If the 'UserTypeCtxt' can refer to both types and +-- kinds, this function conservatively returns 'True'. +-- +-- An example of something that is unambiguously the type of a term is the +-- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the +-- same type in @type family Foo :: forall a -> a -> a@ is unambiguously the +-- kind of a type, not the type of a term, so it is permitted. +-- +-- For more examples, see +-- @testsuite/tests/dependent/should_compile/T16326_Compile*.hs@ (for places +-- where VDQ is permitted) and +-- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where +-- VDQ is disallowed). +vdqAllowed :: UserTypeCtxt -> Bool +vdqAllowed ctxt = case typeOrKindCtxt ctxt of + OnlyTypeCtxt -> False + OnlyKindCtxt -> True + BothTypeAndKindCtxt -> True + +{- +Note [Correctness and performance of type synonym validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the type A arg1 arg2, where A is a type synonym. How should we check +this type for validity? We have three distinct choices, corresponding to the +three constructors of ExpandMode: + +1. Expand the application of A, and check the resulting type (`Expand`). +2. Don't expand the application of A. Only check the arguments (`NoExpand`). +3. Check the arguments *and* check the expanded type (`Both`). + +It's tempting to think that we could always just pick choice (3), but this +results in serious performance issues when checking a type like in the +signature for `f` below: + + type S = ... + f :: S (S (S (S (S (S ....(S Int)...)))) + +When checking the type of `f`, we'll check the outer `S` application with and +without expansion, and in *each* of those checks, we'll check the next `S` +application with and without expansion... the result is exponential blowup! So +clearly we don't want to use `Both` 100% of the time. + +On the other hand, neither is it correct to use exclusively `Expand` or +exclusively `NoExpand` 100% of the time: + +* If one always expands, then one can miss erroneous programs like the one in + the `tcfail129` test case: + + type Foo a = String -> Maybe a + type Bar m = m Int + blah = undefined :: Bar Foo + + If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type + synonyms is unsaturated. +* If one never expands and only checks the arguments, then one can miss + erroneous programs like the one in #16059: + + type Foo b = Eq b => b + f :: forall b (a :: Foo b). Int + + The kind of `a` contains a constraint, which is illegal, but this will only + be caught if `Foo b` is expanded. + +Therefore, it's impossible to have these validity checks be simultaneously +correct and performant if one sticks exclusively to a single `ExpandMode`. In +that case, the solution is to vary the `ExpandMode`s! In more detail: + +1. When we start validity checking, we start with `Expand` if + LiberalTypeSynonyms is enabled (see Note [Liberal type synonyms] for why we + do this), and we start with `Both` otherwise. The `initialExpandMode` + function is responsible for this. +2. When expanding an application of a type synonym (in `check_syn_tc_app`), we + determine which things to check based on the current `ExpandMode` argument. + Importantly, if the current mode is `Both`, then we check the arguments in + `NoExpand` mode and check the expanded type in `Both` mode. + + Switching to `NoExpand` when checking the arguments is vital to avoid + exponential blowup. One consequence of this choice is that if you have + the following type synonym in one module (with RankNTypes enabled): + + {-# LANGUAGE RankNTypes #-} + module A where + type A = forall a. a + + And you define the following in a separate module *without* RankNTypes + enabled: + + module B where + + import A + + type Const a b = a + f :: Const Int A -> Int + + Then `f` will be accepted, even though `A` (which is technically a rank-n + type) appears in its type. We view this as an acceptable compromise, since + `A` never appears in the type of `f` post-expansion. If `A` _did_ appear in + a type post-expansion, such as in the following variant: + + g :: Const A A -> Int + + Then that would be rejected unless RankNTypes were enabled. +-} + +-- | When validity-checking an application of a type synonym, should we +-- check the arguments, check the expanded type, or both? +-- See Note [Correctness and performance of type synonym validity checking] +data ExpandMode + = Expand -- ^ Only check the expanded type. + | NoExpand -- ^ Only check the arguments. + | Both -- ^ Check both the arguments and the expanded type. + +instance Outputable ExpandMode where + ppr e = text $ case e of + Expand -> "Expand" + NoExpand -> "NoExpand" + Both -> "Both" + +-- | If @LiberalTypeSynonyms@ is enabled, we start in 'Expand' mode for the +-- reasons explained in @Note [Liberal type synonyms]@. Otherwise, we start +-- in 'Both' mode. +initialExpandMode :: TcM ExpandMode +initialExpandMode = do + liberal_flag <- xoptM LangExt.LiberalTypeSynonyms + pure $ if liberal_flag then Expand else Both + +-- | Information about a type being validity-checked. +data ValidityEnv = ValidityEnv + { ve_tidy_env :: TidyEnv + , ve_ctxt :: UserTypeCtxt + , ve_rank :: Rank + , ve_expand :: ExpandMode } + +instance Outputable ValidityEnv where + ppr (ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt + , ve_rank = rank, ve_expand = expand }) = + hang (text "ValidityEnv") + 2 (vcat [ text "ve_tidy_env" <+> ppr env + , text "ve_ctxt" <+> pprUserTypeCtxt ctxt + , text "ve_rank" <+> ppr rank + , text "ve_expand" <+> ppr expand ]) + +---------------------------------------- +check_type :: ValidityEnv -> Type -> TcM () +-- The args say what the *type context* requires, independent +-- of *flag* settings. You test the flag settings at usage sites. +-- +-- Rank is allowed rank for function args +-- Rank 0 means no for-alls anywhere + +check_type _ (TyVarTy _) + = return () + +check_type ve (AppTy ty1 ty2) + = do { check_type ve ty1 + ; check_arg_type False ve ty2 } + +check_type ve ty@(TyConApp tc tys) + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + = check_syn_tc_app ve ty tc tys + + -- Check for unboxed tuples and unboxed sums: these + -- require the corresponding extension to be enabled. + | isUnboxedTupleTyCon tc + = check_ubx_tuple_or_sum UnboxedTupleType ve ty tys + | isUnboxedSumTyCon tc + = check_ubx_tuple_or_sum UnboxedSumType ve ty tys + + | otherwise + = do { -- We require DataKinds to use a type constructor in a kind, unless it + -- is exempted (e.g., Type, TYPE, etc., which is checked by + -- isKindTyCon) or a `type data` type constructor. + -- See Note [Checking for DataKinds]. + unless (isKindTyCon tc || isTypeDataTyCon tc) $ + checkDataKinds ve ty + ; mapM_ (check_arg_type False ve) tys } + +check_type ve ty@(LitTy {}) = + -- Type-level literals are forbidden from appearing in kinds unless DataKinds + -- is enabled. See Note [Checking for DataKinds]. + checkDataKinds ve ty + +check_type ve (CastTy ty _) = check_type ve ty + +-- Check for rank-n types, such as (forall x. x -> x) or (Show x => x). +-- +-- Critically, this case must come *after* the case for TyConApp. +-- See Note [Liberal type synonyms]. +check_type ve@(ValidityEnv{ ve_tidy_env = env + , ve_rank = rank, ve_expand = expand }) ty + | not (null tvbs && null theta) + = do { traceTc "check_type" (ppr ty $$ ppr rank) + ; checkTcM (forAllAllowed rank) $ + let (env1, tidy_ty) = tidyOpenTypeX env ty + in (env1, TcRnForAllRankErr rank tidy_ty) + -- Reject e.g. (Maybe (?x::Int => Int)), + -- with a decent error message + + ; checkConstraintsOK ve theta ty + -- Reject forall (a :: Eq b => b). blah + -- In a kind signature we don't allow constraints + + ; checkVdqOK ve tvbs ty + -- Reject visible, dependent quantification in the type of a + -- term (e.g., `f :: forall a -> a -> Maybe a`) + + ; check_valid_theta env' SigmaCtxt expand theta + -- Allow type T = ?x::Int => Int -> Int + -- but not type T = ?x::Int + + ; check_type (ve{ve_tidy_env = env'}) tau + -- Allow foralls to right of arrow + + -- Note: skolem-escape in types (e.g. forall r (a::r). a) is handled + -- by tcHsSigType and the constraint solver, so no need to + -- check it here; c.f. #20929 + } + where + (tvbs, phi) = tcSplitForAllTyVarBinders ty + (theta, tau) = tcSplitPhiTy phi + (env', _) = tidyForAllTyBinders env tvbs + +check_type (ve@ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt + , ve_rank = rank }) + ty@(FunTy _ mult arg_ty res_ty) + = do { failIfTcM (not (linearityAllowed ctxt) && not (isManyTy mult)) + (env, TcRnLinearFuncInKind (tidyType env ty)) + ; check_type (ve{ve_rank = arg_rank}) arg_ty + ; check_type (ve{ve_rank = res_rank}) res_ty } + where + (arg_rank, res_rank) = funArgResRank rank + +check_type _ ty@(ForAllTy {}) = pprPanic "check_type" (ppr ty) +check_type _ ty@(CoercionTy {}) = pprPanic "check_type" (ppr ty) + +---------------------------------------- +check_syn_tc_app :: ValidityEnv + -> KindOrType -> TyCon -> [KindOrType] -> TcM () +-- Used for type synonyms and type synonym families, +-- which must be saturated, +-- but not data families, which need not be saturated +check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand }) + ty tc tys + | tys `lengthAtLeast` tc_arity -- Saturated + -- Check that the synonym has enough args + -- This applies equally to open and closed synonyms + -- It's OK to have an *over-applied* type synonym + -- data Tree a b = ... + -- type Foo a = Tree [a] + -- f :: Foo a b -> ... + = case expand of + _ | isTypeFamilyTyCon tc + -> check_args_only expand + -- See Note [Correctness and performance of type synonym validity + -- checking] + Expand -> check_expansion_only expand + NoExpand -> check_args_only expand + Both -> check_args_only NoExpand *> check_expansion_only Both + + | GhciCtxt True <- ctxt -- Accept outermost under-saturated type synonym or + -- type family constructors in GHCi :kind commands. + -- See Note [Unsaturated type synonyms in GHCi] + = check_args_only expand + + | otherwise + = failWithTc (tyConArityErr tc tys) + where + tc_arity = tyConArity tc + + check_arg :: ExpandMode -> KindOrType -> TcM () + check_arg expand = + check_arg_type (isTypeSynonymTyCon tc) (ve{ve_expand = expand}) + + check_args_only, check_expansion_only :: ExpandMode -> TcM () + check_args_only expand = mapM_ (check_arg expand) tys + + check_expansion_only expand + = assertPpr (isTypeSynonymTyCon tc) (ppr tc) $ + case coreView ty of + Just ty' -> addErrCtxt (TySynErrCtxt tc) $ + check_type (ve{ve_expand = expand}) ty' + Nothing -> pprPanic "check_syn_tc_app" (ppr ty) + +{- +Note [Unsaturated type synonyms in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, GHC disallows unsaturated uses of type synonyms or type +families. For instance, if one defines `type Const a b = a`, then GHC will not +permit using `Const` unless it is applied to (at least) two arguments. There is +an exception to this rule, however: GHCi's :kind command. For instance, it +is quite common to look up the kind of a type constructor like so: + + λ> :kind Const + Const :: j -> k -> j + λ> :kind Const Int + Const Int :: k -> Type + +Strictly speaking, the two uses of `Const` above are unsaturated, but this +is an extremely benign (and useful) example of unsaturation, so we allow it +here as a special case. + +That being said, we do not allow unsaturation carte blanche in GHCi. Otherwise, +this GHCi interaction would be possible: + + λ> newtype Fix f = MkFix (f (Fix f)) + λ> type Id a = a + λ> :kind Fix Id + Fix Id :: Type + +This is rather dodgy, so we move to disallow this. We only permit unsaturated +synonyms in GHCi if they are *top-level*—that is, if the synonym is the +outermost type being applied. This allows `Const` and `Const Int` in the +first example, but not `Fix Id` in the second example, as `Id` is not the +outermost type being applied (`Fix` is). + +We track this outermost property in the GhciCtxt constructor of UserTypeCtxt. +A field of True in GhciCtxt indicates that we're in an outermost position. Any +time we invoke `check_arg` to check the validity of an argument, we switch the +field to False. +-} + +---------------------------------------- +check_ubx_tuple_or_sum :: UnboxedTupleOrSum -> ValidityEnv -> KindOrType -> [KindOrType] -> TcM () +check_ubx_tuple_or_sum tup_or_sum (ve@ValidityEnv{ve_tidy_env = env}) ty tys + = do { ub_thing_allowed <- xoptM $ unboxedTupleOrSumExtension tup_or_sum + ; checkTcM ub_thing_allowed + (env, TcRnUnboxedTupleOrSumTypeFuncArg tup_or_sum (tidyType env ty)) + + -- Unboxed tuples and sums are forbidden from appearing in kinds + -- unless DataKinds is enabled. See Note [Checking for DataKinds]. + ; checkDataKinds ve ty + + ; impred <- xoptM LangExt.ImpredicativeTypes + ; let rank' = if impred then ArbitraryRank else MonoTypeTyConArg + -- c.f. check_arg_type + -- However, args are allowed to be unlifted, or + -- more unboxed tuples or sums, so can't use check_arg_ty + ; mapM_ (check_type (ve{ve_rank = rank'})) tys } + +---------------------------------------- +check_arg_type + :: Bool -- ^ Is this the argument to a type synonym? + -> ValidityEnv -> KindOrType -> TcM () +-- The sort of type that can instantiate a type variable, +-- or be the argument of a type constructor. +-- Not an unboxed tuple, but now *can* be a forall (since impredicativity) +-- Other unboxed types are very occasionally allowed as type +-- arguments depending on the kind of the type constructor +-- +-- For example, we want to reject things like: +-- +-- instance Ord a => Ord (forall s. T s a) +-- and +-- g :: T s (forall b.b) +-- +-- NB: unboxed tuples can have polymorphic or unboxed args. +-- This happens in the workers for functions returning +-- product types with polymorphic components. +-- But not in user code. +-- Anyway, they are dealt with by a special case in check_tau_type + +check_arg_type _ _ (CoercionTy {}) = return () + +check_arg_type type_syn (ve@ValidityEnv{ve_ctxt = ctxt, ve_rank = rank}) ty + = do { impred <- xoptM LangExt.ImpredicativeTypes + ; let rank' = case rank of -- Predictive => must be monotype + -- Rank-n arguments to type synonyms are OK, provided + -- that LiberalTypeSynonyms is enabled. + _ | type_syn -> MonoTypeSynArg + MustBeMonoType -> MustBeMonoType -- Monotype, regardless + _other | impred -> ArbitraryRank + | otherwise -> MonoTypeTyConArg + -- Make sure that MustBeMonoType is propagated, + -- so that we don't suggest -XImpredicativeTypes in + -- (Ord (forall a.a)) => a -> a + -- and so that if it Must be a monotype, we check that it is! + ctxt' :: UserTypeCtxt + ctxt' + | GhciCtxt _ <- ctxt = GhciCtxt False + -- When checking an argument, set the field of GhciCtxt to + -- False to indicate that we are no longer in an outermost + -- position (and thus unsaturated synonyms are no longer + -- allowed). + -- See Note [Unsaturated type synonyms in GHCi] + | otherwise = ctxt + + ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty } + +---------------------------------------- +checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () +checkConstraintsOK ve theta ty + | null theta = return () + | allConstraintsAllowed (ve_ctxt ve) = return () + | otherwise -- We are unambiguously in a kind; see + -- Note [No constraints in kinds] + = failWithTcM (env, TcRnConstraintInKind (tidyType env ty)) + where env = ve_tidy_env ve + +checkVdqOK :: ValidityEnv -> [TyVarBinder] -> Type -> TcM () +checkVdqOK ve tvbs ty = do + required_type_arguments <- xoptM LangExt.RequiredTypeArguments + checkTcM (required_type_arguments || vdqAllowed ctxt || no_vdq) + (env, TcRnVDQInTermType (Just (tidyType env ty))) + where + no_vdq = all (isInvisibleForAllTyFlag . binderFlag) tvbs + ValidityEnv{ve_tidy_env = env, ve_ctxt = ctxt} = ve + +-- | Check for a DataKinds violation in a kind context. +-- See @Note [Checking for DataKinds]@. +checkDataKinds :: ValidityEnv -> Type -> TcM () +checkDataKinds (ValidityEnv{ ve_ctxt = ctxt, ve_tidy_env = env }) ty = do + data_kinds <- xoptM LangExt.DataKinds + checkTcM + (data_kinds || typeLevelUserTypeCtxt ctxt) $ + (env, TcRnDataKindsError KindLevel (Right (tidyType env ty))) + +{- Note [No constraints in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC does not allow constraints in kinds. Equality constraints +in kinds were allowed from GHC 8.0, but this "feature" was removed +as part of Proposal #547 (https://github.com/ghc-proposals/ghc-proposals/pull/547), +which contains further context and motivation for the removal. + +The lack of constraints in kinds is enforced by checkConstraintsOK, which +uses the UserTypeCtxt to determine if we are unambiguously checking a kind. +There are two ambiguous contexts (constructor BothTypeAndKindCtxt of TypeOrKindCtxt) +as written in typeOfKindCtxt: + - TySynCtxt: this is the RHS of a type synonym. We check the expansion of type + synonyms for constraints, so this is handled at the usage site of the synonym. + - GhciCtxt: This is the type in a :kind command. A constraint here does not cause + any trouble, because the type cannot be used to classify a type. + +Beyond these two cases, we also promote data constructors. We check for constraints +in data constructor types in GHC.Tc.Gen.HsType.tcTyVar. + +Note [Liberal type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If -XLiberalTypeSynonyms is on, expand closed type synonyms *before* +doing validity checking. This allows us to instantiate a synonym defn +with a for-all type, or with a partially-applied type synonym. + e.g. type T a b = a + type S m = m () + f :: S (T Int) +Here, T is partially applied, so it's illegal in H98. But if you +expand S first, then T we get just + f :: Int +which is fine. + +IMPORTANT: suppose T is a type synonym. Then we must do validity +checking on an application (T ty1 ty2) + + *either* before expansion (i.e. check ty1, ty2) + *or* after expansion (i.e. expand T ty1 ty2, and then check) + BUT NOT BOTH + +If we do both, we get exponential behaviour!! + + data TIACons1 i r c = c i ::: r c + type TIACons2 t x = TIACons1 t (TIACons1 t x) + type TIACons3 t x = TIACons2 t (TIACons1 t x) + type TIACons4 t x = TIACons2 t (TIACons2 t x) + type TIACons7 t x = TIACons4 t (TIACons3 t x) + +The order in which you do validity checking is also somewhat delicate. Consider +the `check_type` function, which drives the validity checking for unsaturated +uses of type synonyms. There is a special case for rank-n types, such as +(forall x. x -> x) or (Show x => x), since those require at least one language +extension to use. It used to be the case that this case came before every other +case, but this can lead to bugs. Imagine you have this scenario (from #15954): + + type A a = Int + type B (a :: Type -> Type) = forall x. x -> x + type C = B A + +If the rank-n case came first, then in the process of checking for `forall`s +or contexts, we would expand away `B A` to `forall x. x -> x`. This is because +the functions that split apart `forall`s/contexts +(tcSplitForAllTyVarBinders/tcSplitPhiTy) expand type synonyms! If `B A` is expanded +away to `forall x. x -> x` before the actually validity checks occur, we will +have completely obfuscated the fact that we had an unsaturated application of +the `A` type synonym. + +We have since learned from our mistakes and now put this rank-n case /after/ +the case for TyConApp, which ensures that an unsaturated `A` TyConApp will be +caught properly. But be careful! We can't make the rank-n case /last/ either, +as the FunTy case must came after the rank-n case. Otherwise, something like +(Eq a => Int) would be treated as a function type (FunTy), which just +wouldn't do. + +Note [Checking for DataKinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Checking whether a piece of code requires -XDataKinds or not is surprisingly +complicated, so here is a specification (adapted from #22141) for what +-XDataKinds does and does not allow. First, some definitions: + +* A user-written type (i.e. part of the source text of a program) is in a + /kind context/ if it follows a `::` in: + * A standalone kind signature, e.g., + type T :: Nat -> Type + * A kind signature in a type, e.g.: + - forall (a :: Nat -> Type). blah + - type F = G :: Nat -> Type + - etc. + * A result kind signature in a type declaration, e.g.: + - data T a :: Nat -> Type where ... + - type family Fam :: Nat -> Type + - etc. + +* All other contexts where types can appear are referred to as /type contexts/. + +* The /kind type constructors/ are (see GHC.Core.TyCon.isKindTyCon): + * TYPE and Type + * CONSTRAINT and Constraint + * LiftedRep + * RuntimeRep, Levity, and their data constructors + * Multiplicity and its data construtors + * VecCount, VecElem, and their data constructors + +* A `type data` type constructor is defined using the -XTypeData extension, such + as the T in `type data T = A | B`. + +* The following are rejected in type contexts unless -XDataKinds is enabled: + * Promoted data constructors (e.g., 'Just), except for those data constructors + listed under /kind type constructors/ + * Promoted list or tuple syntax (e.g., '[Int, Bool] or '(Int, Bool)) + * Type-level literals (e.g., 42, "hello", or 'a' at the type level) + +* The following are rejected in kind contexts unless -XDataKinds is enabled: + * Everything that is rejected in a type context. + * Any type constructor that is not a kind type constructor or a `type data` + type constructor (e.g., Maybe, [], Char, Nat, Symbol, etc.) + + Note that this includes rejecting occurrences of non-kind type construtors + in type synomym (or type family) applications, even it the expansion would + be legal. For example: + + type T a = Type + f :: forall (x :: T Int). blah + + Here the `Int` in `T Int` is rejected even though the expansion is just + `Type`. This is consistent with, for example, rejecting `T (forall a. a->a)` + without -XImpredicativeTypes. + + This check only occurs in kind contexts. It is always permissible to mention + type synonyms in a type context without enabling -XDataKinds, even if the + type synonym expands to something that would otherwise require -XDataKinds. + +Because checking for DataKinds in a kind context requires looking beneath type +synonyms, it is natural to implement these checks in checkValidType, which has +the necessary machinery to check for language extensions in the presence of +type synonyms. For the exact same reason, checkValidType is *not* a good place +to check for DataKinds in a type context, since we deliberately do not want to +look beneath type synonyms there. As a result, we check for DataKinds in two +different places in the code: + +* We check for DataKinds violations in kind contexts in the typechecker. See + checkDataKinds in this module. +* We check for DataKinds violations in type contexts in the renamer. See + checkDataKinds in GHC.Rename.HsType and check_data_kinds in GHC.Rename.Pat. + + Note that the renamer can also catch "obvious" kind-level violations such as + `data Dat :: Proxy 42 -> Type` (where 42 is not hidden beneath a type + synonym), so we also catch a subset of kind-level violations in the renamer + to allow for earlier reporting of these errors. + +************************************************************************ +* * +\subsection{Checking a theta or source type} +* * +************************************************************************ + +Note [Implicit parameters in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Implicit parameters _only_ allowed in type signatures; not in instance +decls, superclasses etc. The reason for not allowing implicit params in +instances is a bit subtle. If we allowed + instance (?x::Int, Eq a) => Foo [a] where ... +then when we saw + (e :: (?x::Int) => t) +it would be unclear how to discharge all the potential uses of the ?x +in e. For example, a constraint Foo [Int] might come out of e, and +applying the instance decl would show up two uses of ?x. #8912. +-} + +checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () +-- Assumes argument is fully zonked +checkValidTheta ctxt theta + = addErrCtxtM (checkThetaCtxt ctxt theta) $ + do { env <- liftZonkM $ tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) + ; expand <- initialExpandMode + ; check_valid_theta env ctxt expand theta } + +------------------------- +check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode + -> [PredType] -> TcM () +check_valid_theta _ _ _ [] + = return () +check_valid_theta env ctxt expand theta + = do { dflags <- getDynFlags + ; traceTc "check_valid_theta" (ppr theta) + ; mapM_ (check_pred_ty env dflags ctxt expand) theta } + +------------------------- +{- Note [Validity checking for constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We look through constraint synonyms so that we can see the underlying +constraint(s). For example + type Foo = ?x::Int + instance Foo => C T +We should reject the instance because it has an implicit parameter in +the context. + +But we record, in 'under_syn', whether we have looked under a synonym +to avoid requiring language extensions at the use site. Main example +(#9838): + + {-# LANGUAGE ConstraintKinds #-} + module A where + type EqShow a = (Eq a, Show a) + + module B where + import A + foo :: EqShow a => a -> String + +We don't want to require ConstraintKinds in module B. +-} + +check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode + -> PredType -> TcM () +-- Check the validity of a predicate in a signature +-- See Note [Validity checking for constraints] +check_pred_ty env dflags ctxt expand pred + = do { check_type ve pred + ; check_pred_help False env dflags ctxt pred } + where + rank | xopt LangExt.QuantifiedConstraints dflags + = ArbitraryRank + | otherwise + = MonoTypeConstraint + + ve :: ValidityEnv + ve = ValidityEnv{ ve_tidy_env = env + , ve_ctxt = SigmaCtxt + , ve_rank = rank + , ve_expand = expand } + +check_pred_help :: Bool -- True <=> under a type synonym + -> TidyEnv + -> DynFlags -> UserTypeCtxt + -> PredType -> TcM () +check_pred_help under_syn env dflags ctxt pred + | Just pred' <- coreView pred -- Switch on under_syn when going under a + -- synonym (#9838, yuk) + = check_pred_help True env dflags ctxt pred' + + | otherwise -- A bit like classifyPredType, but not the same + -- E.g. we treat (~) like (~#); and we look inside tuples + = case classifyPredType pred of + ClassPred cls tys + | isCTupleClass cls -> check_tuple_pred under_syn env dflags ctxt pred tys + | otherwise -> check_class_pred env dflags ctxt pred cls tys + + EqPred _ _ _ -> pprPanic "check_pred_help" (ppr pred) + -- EqPreds, such as (t1 ~# t2) or (t1 ~R# t2), don't even have kind Constraint + -- and should never appear before the '=>' of a type. Thus + -- f :: (a ~# b) => blah + -- is wrong. For user written signatures, it'll be rejected by kind-checking + -- well before we get to validity checking. For inferred types we are careful + -- to box such constraints in GHC.Tc.Utils.TcType.pickQuantifiablePreds, as described + -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Solver + + ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head + _ -> return () + +check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt + -> PredType -> ThetaType -> PredType -> TcM () +check_quant_pred env dflags ctxt pred theta head_pred + = addErrCtxt (QuantifiedCtCtxt pred) $ + do { -- Check the instance head + case classifyPredType head_pred of + -- SigmaCtxt tells checkValidInstHead that + -- this is the head of a quantified constraint + ClassPred cls tys -> do { checkValidInstHead SigmaCtxt cls tys + ; check_pred_help False env dflags ctxt head_pred } + -- need check_pred_help to do extra pred-only validity + -- checks, such as for (~). Otherwise, we get #17563 + -- NB: checks for the context are covered by the check_type + -- in check_pred_ty + IrredPred {} | hasTyVarHead head_pred + -> return () + _ -> failWithTcM (env, TcRnBadQuantPredHead (tidyType env pred)) + + -- Check for termination + ; unless (xopt LangExt.UndecidableInstances dflags) $ + checkInstTermination theta head_pred + } + +check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM () +check_tuple_pred under_syn env dflags ctxt pred ts + = do { -- See Note [ConstraintKinds in predicates] + checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags) + (env, TcRnIllegalTupleConstraint (tidyType env pred)) + ; mapM_ (check_pred_help under_syn env dflags ctxt) ts } + -- This case will not normally be executed because without + -- -XConstraintKinds tuple types are only kind-checked as * + +{- Note [ConstraintKinds in predicates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't check for -XConstraintKinds under a type synonym, because that +was done at the type synonym definition site; see #9838 +e.g. module A where + type C a = (Eq a, Ix a) -- Needs -XConstraintKinds + module B where + import A + f :: C a => a -> a -- Does *not* need -XConstraintKinds +-} + +------------------------- +check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt + -> PredType -> Class -> [TcType] -> TcM () +check_class_pred env dflags ctxt pred cls tys + | isEqualityClass cls -- (~) and (~~) and Coercible are classified as classes, + -- but here we want to treat them as equalities + = -- Equational constraints are valid in all contexts, and + -- we do not need to check e.g. for FlexibleContexts here, so just do nothing + -- We used to require TypeFamilies/GADTs for equality constraints, + -- but not anymore (GHC Proposal #371) + return () + + | isIPClass cls + = do { check_arity + ; checkTcM (okIPCtxt ctxt) (env, TcRnIllegalImplicitParam (tidyType env pred)) } + + | otherwise -- Includes Coercible + = do { check_arity + ; checkSimplifiableClassConstraint env dflags ctxt cls tys + ; checkTcM arg_tys_ok (env, TcRnNonTypeVarArgInConstraint (tidyType env pred)) } + where + check_arity = checkTc (tys `lengthIs` classArity cls) + (tyConArityErr (classTyCon cls) tys) + + -- Check the arguments of a class constraint + flexible_contexts = xopt LangExt.FlexibleContexts dflags + arg_tys_ok = case ctxt of + SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine + InstDeclCtxt {} -> checkValidClsArgs flexible_contexts cls tys + -- Further checks on head and theta + -- in checkInstTermination + _ -> checkValidClsArgs flexible_contexts cls tys + +checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt + -> Class -> [TcType] -> TcM () +-- See Note [Simplifiable given constraints] +checkSimplifiableClassConstraint env dflags ctxt cls tys + | not (wopt Opt_WarnSimplifiableClassConstraints dflags) + = return () + | xopt LangExt.MonoLocalBinds dflags + = return () + + | DataTyCtxt {} <- ctxt -- Don't do this check for the "stupid theta" + = return () -- of a data type declaration + + | cls `hasKey` coercibleTyConKey + = return () -- Oddly, we treat (Coercible t1 t2) as unconditionally OK + -- matchGlobalInst will reply "yes" because we can reduce + -- (Coercible a b) to (a ~R# b) + + | otherwise + = do { result <- matchGlobalInst dflags False cls tys Nothing + ; case result of + OneInst { cir_what = what } + -> addDiagnosticTc (TcRnSimplifiableConstraint pred what) + _ -> return () } + where + pred = tidyType env (mkClassPred cls tys) + +{- Note [Simplifiable given constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type signature like + f :: Eq [(a,b)] => a -> b +is very fragile, for reasons described at length in GHC.Tc.Solver.Dict +Note [Instance and Given overlap]. As that Note discusses, for the +most part the clever stuff in GHC.Tc.Solver.Dict means that we don't use a +top-level instance if a local Given might fire, so there is no +fragility. But if we /infer/ the type of a local let-binding, things +can go wrong (#11948 is an example, discussed in the Note). + +So this warning is switched on only if we have NoMonoLocalBinds; in +that case the warning discourages users from writing simplifiable +class constraints. + +The warning only fires if the constraint in the signature +matches the top-level instances in only one way, and with no +unifiers -- that is, under the same circumstances that +GHC.Tc.Instance.Class.matchInstEnv fires an interaction with the top +level instances. For example (#13526), consider + + instance {-# OVERLAPPABLE #-} Eq (T a) where ... + instance Eq (T Char) where .. + f :: Eq (T a) => ... + +We don't want to complain about this, even though the context +(Eq (T a)) matches an instance, because the user may be +deliberately deferring the choice so that the Eq (T Char) +has a chance to fire when 'f' is called. And the fragility +only matters when there's a risk that the instance might +fire instead of the local 'given'; and there is no such +risk in this case. Just use the same rules as for instance +firing! +-} + +------------------------- +okIPCtxt :: UserTypeCtxt -> Bool + -- See Note [Implicit parameters in instance decls] +okIPCtxt (FunSigCtxt {}) = True +okIPCtxt (InfSigCtxt {}) = True +okIPCtxt (ExprSigCtxt {}) = True +okIPCtxt TypeAppCtxt = True +okIPCtxt PatSigCtxt = True +okIPCtxt GenSigCtxt = True +okIPCtxt (ConArgCtxt {}) = True +okIPCtxt (ForSigCtxt {}) = True -- ?? +okIPCtxt (GhciCtxt {}) = True +okIPCtxt SigmaCtxt = True +okIPCtxt (DataTyCtxt {}) = True +okIPCtxt (PatSynCtxt {}) = True +okIPCtxt (TySynCtxt {}) = True -- e.g. type Blah = ?x::Int + -- #11466 + +okIPCtxt (KindSigCtxt {}) = False +okIPCtxt (StandaloneKindSigCtxt {}) = False +okIPCtxt (ClassSCCtxt {}) = False +okIPCtxt (InstDeclCtxt {}) = False +okIPCtxt (SpecInstCtxt {}) = False +okIPCtxt (RuleBndrTypeCtxt {}) = False +okIPCtxt DefaultDeclCtxt = False +okIPCtxt DerivClauseCtxt = False +okIPCtxt (TyVarBndrKindCtxt {}) = False +okIPCtxt (DataKindCtxt {}) = False +okIPCtxt (TySynKindCtxt {}) = False +okIPCtxt (TyFamResKindCtxt {}) = False + +{- +Note [Kind polymorphic type classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +MultiParam check: + + class C f where... -- C :: forall k. k -> Constraint + instance C Maybe where... + + The dictionary gets type [C * Maybe] even if it's not a MultiParam + type class. + +Flexibility check: + + class C f where... -- C :: forall k. k -> Constraint + data D a = D a + instance C D where + + The dictionary gets type [C * (D *)]. IA0_TODO it should be + generalized actually. +-} + +checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) +checkThetaCtxt ctxt theta env + = return (env, ThetaCtxt ctxt (tidyTypes env theta)) + +tyConArityErr :: TyCon -> [TcType] -> TcRnMessage +-- For type-constructor arity errors, be careful to report +-- the number of /visible/ arguments required and supplied, +-- ignoring the /invisible/ arguments, which the user does not see. +-- (e.g. #10516) +tyConArityErr tc tks + = TcRnArityMismatch (ATyCon tc) tc_type_arity tc_type_args + where + vis_tks = filterOutInvisibleTypes tc tks + + -- tc_type_arity = number of *type* args expected + -- tc_type_args = number of *type* args encountered + tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) + tc_type_args = length vis_tks + +{- +************************************************************************ +* * +\subsection{Checking for a decent instance head type} +* * +************************************************************************ + +@checkValidInstHead@ checks the type {\em and} its syntactic constraints: +it must normally look like: @instance Foo (Tycon a b c ...) ...@ + +The exceptions to this syntactic checking: (1)~if the @GlasgowExts@ +flag is on, or (2)~the instance is imported (they must have been +compiled elsewhere). In these cases, we let them go through anyway. + +We can also have instances for functions: @instance Foo (a -> b) ...@. +-} + +checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () +checkValidInstHead ctxt clas cls_args + = do { dflags <- getDynFlags + ; hsc_src <- tcHscSource + ; check_special_inst_head dflags hsc_src ctxt clas cls_args + ; checkValidTypePats (classTyCon clas) cls_args + } + +{- + +Note [Instances of built-in classes in signature files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +User defined instances for KnownNat, KnownSymbol, KnownChar, +and Typeable are disallowed + -- they are generated when needed by GHC itself, on-the-fly. + +However, if they occur in a Backpack signature file, they have an +entirely different meaning. To illustrate, suppose in M.hsig we see + + signature M where + data T :: Nat + instance KnownNat T + +That says that any module satisfying M.hsig must provide a KnownNat +instance for T. We absolutely need that instance when compiling a +module that imports M.hsig: see #15379 and +Note [Fabricating Evidence for Literals in Backpack] in GHC.Tc.Instance.Class. + +Hence, checkValidInstHead accepts a user-written instance declaration +in hsig files, where `is_sig` is True. + +-} + +check_special_inst_head :: DynFlags -> HscSource -> 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 hs_src ctxt clas cls_args + + -- Abstract classes cannot have instances, except in hs-boot or signature files. + | isAbstractClass clas + , hs_src == HsSrcFile + = fail_with_inst_err $ IllegalInstanceHead + $ InstHeadAbstractClass (noUserRdr $ className clas) + + -- Complain about hand-written instances of built-in classes + -- Typeable, KnownNat, KnownSymbol, Coercible, HasField. + + -- Disallow hand-written Typeable instances, except that we + -- allow a standalone deriving declaration: they are no-ops, + -- and we warn about them in GHC.Tc.Deriv.deriveStandalone. + | clas_nm == typeableClassName + , not (hs_src == HsigFile) + -- Note [Instances of built-in classes in signature files] + , hand_written_bindings + = fail_with_inst_err $ IllegalSpecialClassInstance clas False + + -- Handwritten instances of KnownNat/KnownChar/KnownSymbol + -- are forbidden outside of signature files (#12837). + -- Derived instances are forbidden completely (#21087). + -- FIXME: DataToTag instances in signature files don't actually work yet + | clas_nm `elem` [ knownNatClassName, knownSymbolClassName + , knownCharClassName, dataToTagClassName ] + , (not (hs_src == HsigFile) && hand_written_bindings) || derived_instance + -- Note [Instances of built-in classes in signature files] + = fail_with_inst_err $ IllegalSpecialClassInstance clas False + + -- For the most part we don't allow + -- instances for (~), (~~), or Coercible; + -- but we DO want to allow them in quantified constraints: + -- f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m... + | clas_nm `elem` + [ heqTyConName, eqTyConName, coercibleTyConName + , withDictClassName, unsatisfiableClassName ] + , not quantified_constraint + = fail_with_inst_err $ IllegalSpecialClassInstance clas False + + -- Check for hand-written Generic instances (disallowed in Safe Haskell) + | clas_nm `elem` genericClassNames + , hand_written_bindings + = do { when (safeLanguageOn dflags) $ + fail_with_inst_err $ IllegalSpecialClassInstance 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 + = do + -- Since we're now declaring instances for constraint tuples in + -- GHC.Classes, this check must exclude that file. + this_mod <- fmap tcg_mod getGblEnv + when (this_mod /= gHC_CLASSES) (failWithTc (TcRnTupleConstraintInst clas)) + + -- Check language restrictions on the args to the class + | check_h98_arg_shape + , Just illegal_head <- mb_ty_args_type + = fail_with_inst_err $ IllegalInstanceHead illegal_head + + | otherwise + = pure () + where + + fail_with_inst_err err = + failWithTc $ TcRnIllegalInstance + $ IllegalClassInstance + (TypeThing $ mkClassPred clas cls_args) + $ err + + clas_nm = getName clas + ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args + + hand_written_bindings + = case ctxt of + InstDeclCtxt standalone -> not standalone + SpecInstCtxt -> False + DerivClauseCtxt -> False + SigmaCtxt -> False + _ -> True + + derived_instance + = case ctxt of + InstDeclCtxt standalone -> standalone + DerivClauseCtxt -> True + _ -> False + + check_h98_arg_shape = case ctxt of + SpecInstCtxt -> False + DerivClauseCtxt -> False + SigmaCtxt -> False + _ -> True + -- SigmaCtxt: once we are in quantified-constraint land, we + -- aren't so picky about enforcing H98-language restrictions + -- E.g. we want to allow a head like Coercible (m a) (m b) + + + -- When we are looking at the head of a quantified constraint, + -- check_quant_pred sets ctxt to SigmaCtxt + quantified_constraint = case ctxt of + SigmaCtxt -> True + _ -> False + + mb_ty_args_type + | not (xopt LangExt.TypeSynonymInstances dflags) + , not (all tcInstHeadTyNotSynonym ty_args) + = Just InstHeadTySynArgs + + | not (xopt LangExt.FlexibleInstances dflags) + , not (all tcInstHeadTyAppAllTyVars ty_args) + = Just InstHeadNonTyVarArgs + + | length ty_args /= 1 + , not (xopt LangExt.MultiParamTypeClasses dflags) + , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args) + = Just InstHeadMultiParam + + | otherwise + = Nothing + +tcInstHeadTyNotSynonym :: Type -> Bool +-- Used in Haskell-98 mode, for the argument types of an instance head +-- These must not be type synonyms, but everywhere else type synonyms +-- are transparent, so we need a special function here +tcInstHeadTyNotSynonym ty + = case ty of -- Do not use splitTyConApp, + -- because that expands synonyms! + TyConApp tc _ -> not (isTypeSynonymTyCon tc) || tc == unrestrictedFunTyCon + -- Allow (->), e.g. instance Category (->), + -- even though it's a type synonym for FUN 'Many + _ -> True + +tcInstHeadTyAppAllTyVars :: Type -> Bool +-- Used in Haskell-98 mode, for the argument types of an instance head +-- These must be a constructor applied to type variable arguments +-- or a type-level literal. +-- But we allow +-- 1) kind instantiations +-- 2) the type (->) = FUN 'Many, even though it's not in this form. +tcInstHeadTyAppAllTyVars ty + | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty) + = let tys' = filterOutInvisibleTypes tc tys -- avoid kinds + tys'' | tc `hasKey` fUNTyConKey + , ManyTy : tys_t <- tys' + = tys_t + | otherwise = tys' + in ok tys'' + | LitTy _ <- ty = True -- accept type literals (#13833) + | otherwise + = False + where + -- Check that all the types are type variables, + -- and that each is distinct + ok tys = equalLength tvs tys && hasNoDups tvs + where + tvs = mapMaybe getTyVar_maybe tys + +dropCasts :: Type -> Type +-- See Note [Casts during validity checking] +-- This function can turn a well-kinded type into an ill-kinded +-- one, so I've kept it local to this module +-- To consider: drop only HoleCo casts +dropCasts (CastTy ty _) = dropCasts ty +dropCasts (AppTy t1 t2) = mkAppTy (dropCasts t1) (dropCasts t2) +dropCasts ty@(FunTy _ w t1 t2) = ty { ft_mult = dropCasts w, ft_arg = dropCasts t1, ft_res = dropCasts t2 } +dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys) +dropCasts (ForAllTy b ty) = ForAllTy (dropCastsB b) (dropCasts ty) +dropCasts ty = ty -- LitTy, TyVarTy, CoercionTy + +dropCastsB :: TyVarBinder -> TyVarBinder +dropCastsB b = b -- Don't bother in the kind of a forall + +-- | See Note [Validity checking of HasField instances] +checkHasFieldInst :: Class -> [Type] -> TcM () +checkHasFieldInst cls tys@[_k_ty, _r_rep, _a_rep, lbl_ty, r_ty, _a_ty] = + case splitTyConApp_maybe r_ty of + Nothing -> add_err IllegalHasFieldInstanceNotATyCon + Just (tc, _) + | isFamilyTyCon tc + -> add_err IllegalHasFieldInstanceFamilyTyCon + | otherwise -> case isStrLitTy lbl_ty of + Just lbl + | let lbl_str = FieldLabelString lbl + , isJust (lookupTyConFieldLabel lbl_str tc) + -> add_err $ IllegalHasFieldInstanceTyConHasField tc lbl_str + | otherwise + -> return () + Nothing + -- If the label is not a literal, we need to ensure it can't unify + -- with any of the field labels of the TyCon. + | null (tyConFieldLabels tc) + -- No field labels at all: nothing to check. + || typesAreApart (typeKind lbl_ty) typeSymbolKind + -- If the label has a type whose kind can't unify with Symbol, + -- then it definitely can't unify with any of the field labels. + -> return () + | otherwise + -> add_err $ IllegalHasFieldInstanceTyConHasFields tc lbl_ty + where + add_err err = addErrTc $ TcRnIllegalInstance + $ IllegalClassInstance + (TypeThing $ mkClassPred cls tys) + $ IllegalHasFieldInstance err + +checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys) + +{- Note [Casts during validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the (bogus) + instance Eq Char# +We elaborate to 'Eq (Char# |> UnivCo(hole))' where the hole is an +insoluble equality constraint for Type ~ TYPE WordRep. We'll report the insoluble +constraint separately, but we don't want to *also* complain that Eq is +not applied to a type constructor. So we look gaily look through +CastTys here. + +Another example: Eq (Either a). Then we actually get a cast in +the middle: + Eq ((Either |> g) a) + + +Note [Validity checking of HasField instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The HasField class has magic constraint solving behaviour (see Note +[HasField instances] in GHC.Tc.Instance.Class). However, we permit users to +declare their own instances, provided they do not clash with the +built-in behaviour. In particular, we forbid: + + 1. `HasField _ r _` where r is a variable + + 2. `HasField _ (T ...) _` if T is a data family + (because it might have fields introduced later) + + 3. `HasField x (T ...) _` where x is a variable, + if T has any fields at all + + 4. `HasField "foo" (T ...) _` if T has a "foo" field + +The usual functional dependency checks also apply. + + +Note [Valid 'deriving' predicate] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a 'derived' instance declaration, we *infer* the context. It's a bit unclear +what rules we should apply for this; the Haskell report is silent. Obviously, +constraints like `Eq a` are fine, but what about + + data T f a = MkT (f a) deriving Eq + +where we'd get an `Eq (f a)` constraint. That's probably fine too. + +On the other hand, we don't want to allow *every* inferred constraint, as there +are some particularly complex constraints that are tricky to handle. If GHC +encounters a constraint that is too complex, it will reject it, and you will +have to use StandaloneDeriving to manually specify the instance context that +you want. + +There are two criteria for a constraint inferred by a `deriving` clause to be +considered valid, which are described below as (VD1) and (VD2). (Here, "VD" +stands for "valid deriving".) `validDerivPred` implements these checks. While +`validDerivPred` is similar to other things defined in GHC.Tc.Deriv.Infer, we +define it here in GHC.Tc.Validity because it is quite similar to +`checkInstTermination`. + +----------------------------------- +-- (VD1) The Paterson conditions -- +----------------------------------- + +Constraints must satisfy the Paterson conditions (see Note [Paterson +conditions]) to be valid. Not only does this check for termination (of course), +but it also deals with a nasty corner case: + + 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 +GHC.Tc.Deriv.Infer.simplifyInstanceContexts loop does not converge. +See #5287 and #21302. + +Another common situation in which a derived instance's context fails to meet +the Paterson conditions is when a constraint mentions a type variable more +often than the instance head, e.g., + + data Fix f = In (f (Fix f)) deriving Eq + +This would result in the following derived `Eq` instance: + + instance Eq (f (Fix f)) => Eq (Fix f) + +Because `f` is mentioned more often in the `Eq (f (Fix f))` constraint than in +the instance head `Eq (Fix f)`, GHC rejects this instance. + +This is a somewhat contentious restriction, and some have suggested that +instances like this one should be accepted if UndecidableInstances is enabled +(see #15868 for one such discussion). If we *do* lift this restriction in the +future, we should make sure to still meet the termination conditions. If not, +the deriving mechanism generates larger and larger constraints. Example: + + data Succ a = S a + data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show + +Note the lack of a Show instance for Succ. First we'll generate: + + instance (Show (Succ a), Show a) => Show (Seq a) + +and then: + + instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) + +and so on. Instead we want to complain of no instance for (Show (Succ a)). + +--------------------------------- +-- (VD2) No exotic constraints -- +--------------------------------- + +A constraint must satisfy one of the following properties in order to be valid: + +* It is a `ClassPred` of the form `C a_1 ... a_n`, where C is a type class + constructor and a_1, ..., a_n are either raw type variables or applications + of type variables (e.g., `f a`). +* It is an `IrredPred` of the form `c a_1 ... a_n`, where `c` is a raw type + variable and a_1, ..., a_n are either raw type variables or applications of + type variables (e.g., `f a`). + +If a constraint does not meet either of these properties, it is considered +*exotic*. A constraint will be exotic if it contains: + +* Other type constructors (besides the class in a `ClassPred`), +* Foralls, or +* Equalities + +A common form of exotic constraint is one that mentions another type +constructor. For example, given the following: + + data NotAShowInstance + data Foo = MkFoo Int NotAShowInstance deriving Show + +GHC would attempt to generate the following derived `Show` instance: + + instance (Show Int, Show NotAShowInstance) => Show Foo + +Note that because there is a top-level `Show Int` instance, GHC is able to +simplify away the inferred `Show Int` constraint. However, it cannot do the +same for the `Show NotAShowInstance` constraint. One possibility would be to +generate this instance: + + instance Show NotAShowInstance => Show Foo + +But this is almost surely not what we want most of the time. For this reason, +we reject the constraint above as being exotic. + +Here are some other interesting examples: + +* Derived instances whose instance context would mention TypeError, such as the + code from the deriving/should_fail/T14339 test case, are exotic. For example: + + newtype Foo = Foo Int + + class Bar a where + bar :: a + + instance (TypeError (Text "Boo")) => Bar Foo where + bar = undefined + + newtype Baz = Baz Foo + deriving Bar + + The `deriving Bar` clause would generate this instance: + + instance TypeError (Text "Boo") => Bar Baz + + The instance context is exotic, as `TypeError` is not a type constructor, and + `Text "Boo"` is not an application of type variables. As such, GHC rejects + it. This has the desirable side effect of causing the TypeError to fire in + the resulting error message. + +* The following `IrredPred`s are not exotic: + + instance c => C (T c a) + instance c a => C (T c a) + + This `IrredPred`, however, *is* exotic: + + instance c NotAShowInstance => C (T c) + + This is rejected for the same reasons that we do not permit a `ClassPred` + with a type constructor argument, such as the `Show NotAShowInstance` example + above. + +As part of implementing this check, GHC calls `tyConsOfType` on the arguments +of the constraint, ensuring that there are no other type constructors. +Wrinkle: for `ClassPred`s, we look only at 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 -> Type) where ... + newtype T (c :: Type -> Type -> Type) a b = MkT (c a b) + instance Category c => Category (T c) where ... + +since the first argument to `Category` is a non-visible `Type`, which has a type +constructor! See #11833. + +Note [Equality class instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can't have users writing instances for the equality classes. But we +still need to be able to write instances for them ourselves. So we allow +instances only in the defining module. +-} + +validDerivPred :: PatersonSize -> PredType -> Bool +-- See Note [Valid 'deriving' predicate] +validDerivPred head_size pred + = case classifyPredType pred of + EqPred {} -> False -- Reject equality constraints (VD2) + ForAllPred {} -> False -- Rejects quantified predicates (VD2) + + ClassPred cls tys -> check_size (pSizeClassPred cls tys) -- (VD1) + && isEmptyUniqSet (tyConsOfTypes visible_tys) -- (VD2) + where + -- See the wrinkle about visible arguments in (VD2) + visible_tys = filterOutInvisibleTypes (classTyCon cls) tys + + IrredPred {} -> check_size (pSizeType pred) -- (VD1) + && isEmptyUniqSet (tyConsOfType pred) -- (VD2) + + where + check_size pred_size = isNothing (pred_size `ltPatersonSize` head_size) + -- Check (VD1) + +{- +************************************************************************ +* * +\subsection{Checking instance for termination} +* * +************************************************************************ +-} + +{- Note [Paterson conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Paterson Conditions ensure termination of instance resolution. +Given an instance declaration + instance (..., C t1.. tn, ...) => D s1 .. sm + +we check that each constraint in the context of the instance is +"Paterson-smaller" than the instance head. The underlying idea of +Paterson-smaller is that + + For any ground substitution S, for each constraint P in the + context, S(P) has fewer type constructors, counting repetitions, + than the head S(H) + +We implement this check by checking the following syntactic conditions: + +(PC1) No type variable has more (shallow) occurrences in P than in H. + + (If not, a substitution that replaces that variable with a big type + would make P have many more type constructors than H. Side note: we + could in principle skip this test for a variable of kind Bool, + since there are no big ground types we can substitute for it.) + +(PC2) The constraint P has fewer constructors and variables (taken + together and counting repetitions) than the head H. This size + metric is computed by sizeType. + + (A substitution that replaces each variable with Int demonstrates + the need.) + +(PC3) The constraint P mentions no type functions. + + (A type function application can in principle expand to a type of + arbitrary size, and so are rejected out of hand. See #15172.) + +(See Section 5 of "Understanding functional dependencies via Constraint +Handling Rules", JFP Jan 2007; and the user manual section "Instance +termination rules".) + +We measure "size" with the data type PatersonSize, in GHC.Tc.Utils.TcType. + data PatersonSize + = PS_TyFam TyCon + | PS_Vanilla { ps_tvs :: [TyVar] -- Free tyvars, including repetitions; + , ps_size :: Int} -- Number of type constructors and variables + +* ps_tvs deals with (PC1) +* ps_size deals with (PC2) +* PS_TyFam deals with (PC3) + +Note [Tuples in checkInstTermination] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two ways of giving the same instance decl (#8359): + + instance (Eq a, Num a) => C (T a) + + type X a = (Eq a, Num a) + instance X a => C (T a) + +In the former, `checkInstTermination` will check the size of two predicates: +(Eq a) and (Num a). In the latter, it will see only one: (X a). But we want +to treat the latter like the former. + +So the `check` function in `checkInstTermination`, we simply recurse +if we find a constraint tuple. +-} + + +checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () +checkValidInstance ctxt hs_type ty = case tau of + -- See Note [Instances and constraint synonyms] + TyConApp tc inst_tys + | Just clas <- tyConClass_maybe tc + -> do + { setSrcSpanA head_loc $ + checkValidInstHead ctxt clas inst_tys + + ; traceTc "checkValidInstance {" (ppr ty) + + ; env0 <- liftZonkM $ tcInitTidyEnv + ; expand <- initialExpandMode + ; check_valid_theta env0 ctxt expand theta + + -- The Termination and Coverage Conditions + -- Check that instance inference will terminate (if we care) + -- For Haskell 98 this will already have been done by checkValidTheta, + -- but as we may be using other extensions we need to check. + -- + -- Note that the Termination Condition is *more conservative* than + -- the checkAmbiguity test we do on other type signatures + -- e.g. Bar a => Bar Int is ambiguous, but it also fails + -- the termination condition, because 'a' appears more often + -- in the constraint than in the head + ; undecidable_ok <- xoptM LangExt.UndecidableInstances + ; if undecidable_ok + then checkAmbiguity ctxt ty + else checkInstTermination theta tau + + ; traceTc "cvi 2" (ppr ty) + + ; case checkInstCoverage undecidable_ok clas theta inst_tys of + IsValid + -> return () -- Check succeeded + NotValid coverageInstErr + -> addErrTc $ mk_err + $ IllegalInstanceFailsCoverageCondition clas coverageInstErr + + ; traceTc "End checkValidInstance }" empty } + | otherwise + -> failWithTc $ mk_err $ IllegalInstanceHead + $ InstHeadNonClassHead + $ InstNonClassTyCon (noUserRdr $ tyConName tc) (fmap tyConName $ tyConFlavour tc) + _ -> failWithTc $ mk_err $ IllegalInstanceHead + $ InstHeadNonClassHead InstNonTyCon + where + (theta, tau) = splitInstTyForValidity ty + + mk_err err = TcRnIllegalInstance + $ IllegalClassInstance (TypeThing tau) err + + -- The location of the "head" of the instance + head_loc = getLoc (getLHsInstDeclHead hs_type) + +-- | Split an instance type of the form @forall tvbs. inst_ctxt => inst_head@ +-- and return @(inst_ctxt, inst_head)@. This function makes no attempt to look +-- through type synonyms. See @Note [Instances and constraint synonyms]@. +splitInstTyForValidity :: Type -> (ThetaType, Type) +splitInstTyForValidity = split_context [] . drop_foralls + where + -- This is like 'dropForAlls', except that it does not look through type + -- synonyms. + drop_foralls :: Type -> Type + drop_foralls (ForAllTy (Bndr _tv argf) ty) + | isInvisibleForAllTyFlag argf = drop_foralls ty + drop_foralls ty = ty + + -- This is like 'tcSplitPhiTy', except that it does not look through type + -- synonyms. + split_context :: ThetaType -> Type -> (ThetaType, Type) + split_context preds (FunTy { ft_af = af, ft_arg = pred, ft_res = tau }) + | isInvisibleFunArg af = split_context (pred:preds) tau + split_context preds ty = (reverse preds, ty) + +checkInstTermination :: ThetaType -> TcPredType -> TcM () +-- See Note [Paterson conditions] +checkInstTermination theta head_pred + = check_preds emptyVarSet theta + where + head_size = pSizeType head_pred + -- This is inconsistent and probably wrong. pSizeType does not filter out + -- invisible type args (making the instance head look big), whereas the use of + -- pSizeClassPredX below /does/ filter them out (making the tested constraints + -- look smaller). I'm sure there is non termination lurking here, but see #15177 + -- for why I didn't change it. See Note [Invisible arguments and termination] + -- in GHC.Tc.Utils.TcType + + check_preds :: VarSet -> [PredType] -> TcM () + check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds + + check :: VarSet -> PredType -> TcM () + check foralld_tvs pred + = case classifyPredType pred of + EqPred {} -> return () -- See #4200. + IrredPred {} -> check2 (pSizeTypeX foralld_tvs pred) + + ClassPred cls tys + | isCTupleClass cls -- See Note [Tuples in checkInstTermination] + -> check_preds foralld_tvs tys + + | otherwise -- Other ClassPreds + -> check2 (pSizeClassPredX foralld_tvs cls tys) + + ForAllPred tvs _ head_pred' + -> check (foralld_tvs `extendVarSetList` tvs) head_pred' + -- Termination of the quantified predicate itself is checked + -- when the predicates are individually checked for validity + + where + check2 pred_size + = case pred_size `ltPatersonSize` head_size of + Just pc_failure -> failWithTc $ TcRnPatersonCondFailure pc_failure InInstanceDecl pred head_pred + Nothing -> return () + +{- Note [Instances and constraint synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, we don't allow instances for constraint synonyms at all. +Consider these (#13267): + type C1 a = Show (a -> Bool) + instance C1 Int where -- I1 + show _ = "ur" + +This elicits "show is not a (visible) method of class C1", which isn't +a great message. But it comes from the renamer, so it's hard to improve. + +This needs a bit more care: + type C2 a = (Show a, Show Int) + instance C2 Int -- I2 + +If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose +the instance head, we'll expand the synonym on fly, and it'll look like + instance (%,%) (Show Int, Show Int) +and we /really/ don't want that. So we carefully do /not/ expand +synonyms, by matching on TyConApp directly. + +For similar reasons, we do not use tcSplitSigmaTy when decomposing the instance +context, as the looks through type synonyms. If we looked through type +synonyms, then it could be possible to write an instance for a type synonym +involving a quantified constraint (see #22570). Instead, we define +splitInstTyForValidity, a specialized version of tcSplitSigmaTy (local to +GHC.Tc.Validity) that does not expand type synonyms. +-} + + +{- +************************************************************************ +* * + Checking type instance well-formedness and termination +* * +************************************************************************ +-} + +checkValidCoAxiom :: CoAxiom Branched -> TcM () +checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) + = do { mapM_ (checkValidCoAxBranch fam_tc) branch_list + ; foldlM_ check_branch_compat [] branch_list } + where + branch_list = fromBranches branches + injectivity = tyConInjectivityInfo fam_tc + + check_branch_compat :: [CoAxBranch] -- previous branches in reverse order + -> CoAxBranch -- current branch + -> TcM [CoAxBranch]-- current branch : previous branches + -- Check for + -- (a) this branch is dominated by previous ones + -- (b) failure of injectivity + check_branch_compat prev_branches cur_branch + | cur_branch `isDominatedBy` prev_branches + = do { let dia = TcRnInaccessibleCoAxBranch fam_tc cur_branch + ; addDiagnosticAt (coAxBranchSpan cur_branch) dia + ; return prev_branches } + | otherwise + = do { check_injectivity prev_branches cur_branch + ; return (cur_branch : prev_branches) } + + -- Injectivity check: check whether a new (CoAxBranch) can extend + -- already checked equations without violating injectivity + -- annotation supplied by the user. + -- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv + check_injectivity prev_branches cur_branch + | Injective inj <- injectivity + = do { dflags <- getDynFlags + ; let conflicts = + fst $ foldl' (gather_conflicts inj prev_branches cur_branch) + ([], 0) prev_branches + ; reportConflictingInjectivityErrs fam_tc conflicts cur_branch + ; reportInjectivityErrors dflags ax cur_branch inj } + | otherwise + = return () + + gather_conflicts inj prev_branches cur_branch (acc, n) branch + -- n is 0-based index of branch in prev_branches + = case injectiveBranches inj cur_branch branch of + -- Case 1B2 in Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv + InjectivityUnified ax1 ax2 + | ax1 `isDominatedBy` (replace_br prev_branches n ax2) + -> (acc, n + 1) + | otherwise + -> (branch : acc, n + 1) + InjectivityAccepted -> (acc, n + 1) + + -- Replace n-th element in the list. Assumes 0-based indexing. + replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch] + replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs + + +-- Check that a "type instance" is well-formed (which includes decidability +-- unless -XUndecidableInstances is given). +-- +-- See also the separate 'checkFamPatBinders' which performs scoping checks +-- on a type family equation. +-- (It's separate because it expects 'TyFamEqnValidityInfo', which comes from a +-- separate place e.g. for associated type defaults.) +checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM () +checkValidCoAxBranch fam_tc + (CoAxBranch { cab_lhs = typats + , cab_rhs = rhs, cab_loc = loc }) + = setSrcSpan loc $ + checkValidTyFamEqn fam_tc typats rhs + +-- | Do validity checks on a type family equation, including consistency +-- with any enclosing class instance head, termination, and lack of +-- polytypes. +-- +-- See also the separate 'checkFamPatBinders' which performs scoping checks +-- on a type family equation. +-- (It's separate because it expects 'TyFamEqnValidityInfo', which comes from a +-- separate place e.g. for associated type defaults.) +checkValidTyFamEqn :: TyCon -- ^ of the type family + -> [Type] -- ^ Type patterns + -> Type -- ^ Rhs + -> TcM () +checkValidTyFamEqn fam_tc typats rhs + = do { checkValidTypePats fam_tc typats + + -- Check for oversaturated visible kind arguments in a type family + -- equation. + -- See Note [Oversaturated type family equations] + ; when (isTypeFamilyTyCon fam_tc) $ + case drop (tyConArity fam_tc) typats of + [] -> pure () + spec_arg:_ -> + addErr (TcRnOversaturatedVisibleKindArg spec_arg) + + -- The argument patterns, and RHS, are all boxed tau types + -- E.g Reject type family F (a :: k1) :: k2 + -- type instance F (forall a. a->a) = ... + -- type instance F Int# = ... + -- type instance F Int = forall a. a->a + -- type instance F Int = Int# + -- See #9357 + ; checkValidMonoType rhs + + -- We have a decidable instance unless otherwise permitted + ; undecidable_ok <- xoptM LangExt.UndecidableInstances + ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs)) + ; unless undecidable_ok $ + mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) } + +-- | Checks that an associated type family default: +-- +-- 1. Only consists of arguments that are bare type variables, and +-- +-- 2. Has a distinct type variable in each argument. +-- +-- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl". +checkValidAssocTyFamDeflt :: TyCon -- ^ of the type family + -> [Type] -- ^ Type patterns + -> TcM () +checkValidAssocTyFamDeflt fam_tc pats = + do { cpt_tvs <- zipWithM extract_tv pats pats_vis + ; check_all_distinct_tvs $ zip cpt_tvs pats_vis } + where + pats_vis :: [ForAllTyFlag] + pats_vis = tyConForAllTyFlags fam_tc pats + + -- Checks that a pattern on the LHS of a default is a type + -- variable. If so, return the underlying type variable, and if + -- not, throw an error. + -- See Note [Type-checking default assoc decls] + extract_tv :: Type -- The particular type pattern from which to + -- extrace its underlying type variable + -> ForAllTyFlag -- The visibility of the type pattern + -- (only used for error message purposes) + -> TcM TyVar + extract_tv pat pat_vis = + case getTyVar_maybe pat of + Just tv -> pure tv + Nothing -> failWithTc $ TcRnIllegalInstance + $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocDefault + $ AssocDefaultBadArgs fam_tc pats + $ AssocDefaultNonTyVarArg (pat, pat_vis) + + -- Checks that no type variables in an associated default declaration are + -- duplicated. If that is the case, throw an error. + -- See Note [Type-checking default assoc decls] + check_all_distinct_tvs :: + [(TyVar, ForAllTyFlag)] -- The type variable arguments in the associated + -- default declaration, along with their respective + -- visibilities (the latter are only used for error + -- message purposes) + -> TcM () + check_all_distinct_tvs cpt_tvs_vis = + let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in + traverse_ + (\d -> failWithTc $ TcRnIllegalInstance + $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocDefault + $ AssocDefaultBadArgs fam_tc pats + $ AssocDefaultDuplicateTyVars d) + dups + +checkFamInstRhs :: TyCon -> [Type] -- LHS + -> [(TyCon, [Type])] -- type family calls in RHS + -> [TcRnMessage] +-- Ensure that the type family instance terminates. Specifically: +-- ensure that each type family application in the RHS is +-- (TF1) a call to a stuck family like (TypeError ...) or Any +-- See Note [Stuck type families] in GHC.Tc.Utils.TcType +-- or (TF2) obeys the Paterson conditions, namely: +-- - strictly smaller than the lhs, +-- - mentions no type variable more often than the lhs, and +-- - does not contain any further type family applications +checkFamInstRhs lhs_tc lhs_tys famInsts + = mapMaybe check famInsts + where + lhs_size = pSizeTypes lhs_tys + check (tc, tys) + | not (isStuckTypeFamily tc) -- (TF1) + , Just pc_failure <- pSizeTypes tys `ltPatersonSize` lhs_size -- (TF2) + = Just $ TcRnPatersonCondFailure pc_failure InTyFamEquation (TyConApp lhs_tc lhs_tys) (TyConApp tc tys) + | otherwise + = Nothing + +----------------- + +-- | Perform scoping check on a type family equation. +-- +-- See 'TyFamEqnValidityInfo'. +checkTyFamEqnValidityInfo :: TyCon -> TyFamEqnValidityInfo -> TcM () +checkTyFamEqnValidityInfo fam_tc = \ case + NoVI -> return () + VI { vi_loc = loc + , vi_qtvs = qtvs + , vi_non_user_tvs = non_user_tvs + , vi_pats = pats + , vi_rhs = rhs } -> + setSrcSpan loc $ + checkFamPatBinders fam_tc qtvs non_user_tvs pats rhs + +-- | Check binders for a type or data family declaration. +-- +-- Specifically, this function checks for: +-- +-- - type variables used on the RHS but not bound (explicitly or implicitly) +-- in the LHS, +-- - variables bound by a forall in the LHS but not used in the RHS. +-- +-- See Note [Check type family instance binders]. +checkFamPatBinders :: TyCon + -> [TcTyVar] -- ^ Bound on LHS of family instance + -> TyVarSet -- ^ non-user-written tyvars + -> [TcType] -- ^ LHS patterns + -> TcType -- ^ RHS + -> TcM () +checkFamPatBinders fam_tc qtvs non_user_tvs pats rhs + = do { traceTc "checkFamPatBinders" $ + vcat [ debugPprType (mkTyConApp fam_tc pats) + , ppr (mkTyConApp fam_tc pats) + , text "rhs:" <+> ppr rhs + , text "qtvs:" <+> ppr qtvs + , text "rhs_fvs:" <+> ppr (fvVarSet rhs_fvs) + , text "cpt_tvs:" <+> ppr cpt_tvs + , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs + , text "bad_rhs_tvs:" <+> ppr bad_rhs_tvs + , text "bad_qtvs:" <+> ppr (map ifiqtv bad_qtvs) ] + + -- Check for implicitly-bound tyvars, mentioned on the + -- RHS but not bound on the LHS + -- data T = MkT (forall (a::k). blah) + -- data family D Int = MkD (forall (a::k). blah) + -- In both cases, 'k' is not bound on the LHS, but is used on the RHS + -- We catch the former in kcDeclHeader, and the latter right here + -- See Note [Check type family instance binders] + ; check_tvs (FamInstRHSOutOfScopeTyVars (Just (fam_tc, pats, dodgy_tvs))) + (map tyVarName bad_rhs_tvs) + + -- Check for explicitly forall'd variable that is not bound on LHS + -- data instance forall a. T Int = MkT Int + -- See Note [Unused explicitly bound variables in a family pattern] + -- See Note [Check type family instance binders] + ; check_tvs FamInstLHSUnusedBoundTyVars bad_qtvs + } + where + rhs_fvs = tyCoFVsOfType rhs + + cpt_tvs = tyCoVarsOfTypes pats + inj_cpt_tvs = fvVarSet $ injectiveVarsOfTypes False pats + -- The type variables that are in injective positions. + -- See Note [Dodgy binding sites in type family instances] + -- NB: The False above is irrelevant, as we never have type families in + -- patterns. + -- + -- NB: It's OK to use the nondeterministic `fvVarSet` function here, + -- since the order of `inj_cpt_tvs` is never revealed in an error + -- message. + + -- Bound but not used at all + bad_qtvs = mapMaybe bad_qtv_maybe qtvs + + bad_qtv_maybe qtv + | not_bound_in_pats + = let reason + | dodgy + = InvalidFamInstQTvDodgy + | used_in_rhs + = InvalidFamInstQTvNotBoundInPats + | otherwise + = InvalidFamInstQTvNotUsedInRHS + in Just $ InvalidFamInstQTv + { ifiqtv = qtv + , ifiqtv_user_written = not $ qtv `elemVarSet` non_user_tvs + , ifiqtv_reason = reason + } + | otherwise + = Nothing + where + not_bound_in_pats = not $ qtv `elemVarSet` inj_cpt_tvs + dodgy = not_bound_in_pats && qtv `elemVarSet` cpt_tvs + used_in_rhs = qtv `elemVarSet` fvVarSet rhs_fvs + + -- Used on RHS but not bound on LHS + bad_rhs_tvs = filterOut ((`elemVarSet` inj_cpt_tvs) <||> (`elem` qtvs)) (fvVarList rhs_fvs) + + dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs + + check_tvs mk_err tvs + = for_ (NE.nonEmpty tvs) $ \ ne_tvs@(tv0 :| _) -> + addErrAt (getSrcSpan tv0) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + mk_err ne_tvs + +-- | Checks that a list of type patterns is valid in a matching (LHS) +-- position of a class instances or type/data family instance. +-- +-- Specifically: +-- * All monotypes +-- * No type-family applications +checkValidTypePats :: TyCon -> [Type] -> TcM () +checkValidTypePats tc pat_ty_args + = do { -- Check that each of pat_ty_args is a monotype. + -- One could imagine generalising to allow + -- instance C (forall a. a->a) + -- but we don't know what all the consequences might be. + traverse_ checkValidMonoType pat_ty_args + + -- Ensure that no type family applications occur a type pattern + ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of + [] -> pure () + ((tf_is_invis_arg, tf_tc, tf_args):_) -> + failWithTc $ TcRnIllegalInstance $ + IllegalFamilyApplicationInInstance inst_ty + tf_is_invis_arg tf_tc tf_args } + where + inst_ty = mkTyConApp tc pat_ty_args + +------------------------- +checkConsistentFamInst :: AssocInstInfo + -> TyCon -- ^ Family tycon + -> CoAxBranch + -> TcM () +-- See Note [Checking consistent instantiation] + +checkConsistentFamInst NotAssociated _ _ + = return () + +checkConsistentFamInst (InClsInst { ai_class = clas + , ai_tyvars = inst_tvs + , ai_inst_env = mini_env }) + fam_tc branch + = do { traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs + , ppr arg_triples + , ppr mini_env + , ppr ax_tvs + , ppr ax_arg_tys + , ppr arg_triples ]) + -- Check that the associated type indeed comes from this class + -- See [Mismatched class methods and associated type families] + -- in TcInstDecls. + ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + InvalidAssoc $ InvalidAssocInstance $ + AssocNotInThisClass clas fam_tc + + ; check_match arg_triples + } + where + (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch + + arg_triples :: [(Type,Type, ForAllTyFlag)] + arg_triples = [ (cls_arg_ty, at_arg_ty, vis) + | (fam_tc_tv, vis, at_arg_ty) + <- zip3 (tyConTyVars fam_tc) + (tyConForAllTyFlags fam_tc ax_arg_tys) + ax_arg_tys + , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ] + + -- Fiddling around to arrange that wildcards unconditionally print as "_" + -- We only need to print the LHS, not the RHS at all + -- See Note [Printing conflicts with class header] + (tidy_env1, _) = tidyVarBndrs emptyTidyEnv inst_tvs + (tidy_env2, _) = tidyCoAxBndrsForUser tidy_env1 (ax_tvs \\ inst_tvs) + + mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv)) + tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOccFS (fsLit "_")) noSrcSpan + + -- For check_match, bind_me, see + -- Note [Matching in the consistent-instantiation check] + check_match :: [(Type,Type,ForAllTyFlag)] -> TcM () + check_match triples = go emptySubst emptySubst triples + + go _ _ [] = return () + go lr_subst rl_subst ((ty1,ty2,vis):triples) + | Just lr_subst1 <- tcMatchTyX_BM bind_me lr_subst ty1 ty2 + , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 + = go lr_subst1 rl_subst1 triples + | otherwise + = addErrTc $ TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocInstance + $ AssocTyVarsDontMatch vis fam_tc exp_tys act_tys + + -- Expected/actual family argument types (for error messages) + exp_tys = + [ case lookupVarEnv mini_env at_tv of + Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty + Nothing -> mk_wildcard at_tv + | at_tv <- tyConTyVars fam_tc ] + act_tys = tidyTypes tidy_env2 ax_arg_tys + + -- The /scoped/ type variables from the class-instance header + -- should not be alpha-renamed. Inferred ones can be. + no_bind_set = mkVarSet inst_tvs + bind_me tv _ty | tv `elemVarSet` no_bind_set = DontBindMe + | otherwise = BindMe + + +{- Note [Check type family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type family instance, we require (of course), type variables +used on the RHS are matched on the LHS. This is checked by +checkFamPatBinders. Here is an interesting example: + + type family T :: k + type instance T = (Nothing :: Maybe a) + +Upon a cursory glance, it may appear that the kind variable `a` is unbound +since there are no (visible) LHS patterns in `T`. However, there is an +*invisible* pattern due to the return kind, so inside of GHC, the instance +looks closer to this: + + type family T @k :: k + type instance T @(Maybe a) = (Nothing :: Maybe a) + +Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in +fact not unbound. Contrast that with this example (#13985) + + type instance T = Proxy (Nothing :: Maybe a) + +This would looks like this inside of GHC: + + type instance T @(*) = Proxy (Nothing :: Maybe a) + +So this time, `a` is neither bound by a visible nor invisible type pattern on +the LHS, so `a` would be reported as not in scope. + +Finally, here's one more brain-teaser (from #9574). In the example below: + + class Funct f where + type Codomain f :: * + instance Funct ('KProxy :: KProxy o) where + type Codomain 'KProxy = NatTr (Proxy :: o -> *) + +As it turns out, `o` is in scope in this example. That is because `o` is +bound by the kind signature of the LHS type pattern 'KProxy. To make this more +obvious, one can also write the instance like so: + + instance Funct ('KProxy :: KProxy o) where + type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *) + +Note [Dodgy binding sites in type family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example (from #7536): + + type T a = Int + type instance F (T a) = a + +This `F` instance is extremely fishy, since the RHS, `a`, purports to be +"bound" by the LHS pattern `T a`. "Bound" has scare quotes around it because +`T a` expands to `Int`, which doesn't mention at all, so it's as if one had +actually written: + + type instance F Int = a + +That is clearly bogus, so to reject this, we check that every type variable +that is mentioned on the RHS is /actually/ bound on the LHS. In other words, +we need to do something slightly more sophisticated that just compute the free +variables of the LHS patterns. + +It's tempting to just expand all type synonyms on the LHS and then compute +their free variables, but even that isn't sophisticated enough. After all, +an impish user could write the following (#17008): + + type family ConstType (a :: Type) :: Type where + ConstType _ = Type + + type family F (x :: ConstType a) :: Type where + F (x :: ConstType a) = a + +Just like in the previous example, the `a` on the RHS isn't actually bound +on the LHS, but this time a type family is responsible for the deception, not +a type synonym. + +We avoid both issues by requiring that all RHS type variables are mentioned +in injective positions on the left-hand side (by way of +`injectiveVarsOfTypes`). For instance, the `a` in `T a` is not in an injective +position, as `T` is not an injective type constructor, so we do not count that. +Similarly for the `a` in `ConstType a`. + +Note [Matching in the consistent-instantiation check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Matching the class-instance header to family-instance tyvars is +tricker than it sounds. Consider (#13972) + class C (a :: k) where + type T k :: Type + instance C Left where + type T (a -> Either a b) = Int + +Here there are no lexically-scoped variables from (C Left). +Yet the real class-instance header is C @(p -> Either @p @q)) (Left @p @q) +while the type-family instance is T (a -> Either @a @b) +So we allow alpha-renaming of variables that don't come +from the class-instance header. + +We track the lexically-scoped type variables from the +class-instance header in ai_tyvars. + +Here's another example (#14045a) + class C (a :: k) where + data S (a :: k) + instance C (z :: Bool) where + data S :: Bool -> Type where + +Again, there is no lexical connection, but we will get + class-instance header: C @Bool (z::Bool) + family instance S @Bool (a::Bool) + +When looking for mis-matches, we check left-to-right, +kinds first. If we look at types first, we'll fail to +suggest -fprint-explicit-kinds for a mis-match with + T @k vs T @Type +somewhere deep inside the type + +Note [Checking consistent instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #11450 for background discussion on this check. + + class C a b where + type T a x b + +With this class decl, if we have an instance decl + instance C ty1 ty2 where ... +then the type instance must look like + type T ty1 v ty2 = ... +with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'. +For example: + + instance C [p] Int + type T [p] y Int = (p,y,y) + +Note that + +* We used to allow completely different bound variables in the + associated type instance; e.g. + instance C [p] Int + type T [q] y Int = ... + But from GHC 8.2 onwards, we don't. It's much simpler this way. + See #11450. + +* When the class variable isn't used on the RHS of the type instance, + it's tempting to allow wildcards, thus + instance C [p] Int + type T [_] y Int = (y,y) + But it's awkward to do the test, and it doesn't work if the + variable is repeated: + instance C (p,p) Int + type T (_,_) y Int = (y,y) + Even though 'p' is not used on the RHS, we still need to use 'p' + on the LHS to establish the repeated pattern. So to keep it simple + we just require equality. + +* For variables in associated type families that are not bound by the class + itself, we do _not_ check if they are over-specific. In other words, + it's perfectly acceptable to have an instance like this: + + instance C [p] Int where + type T [p] (Maybe x) Int = x + + While the first and third arguments to T are required to be exactly [p] and + Int, respectively, since they are bound by C, the second argument is allowed + to be more specific than just a type variable. Furthermore, it is permissible + to define multiple equations for T that differ only in the non-class-bound + argument: + + instance C [p] Int where + type T [p] (Maybe x) Int = x + type T [p] (Either x y) Int = x -> y + + We once considered requiring that non-class-bound variables in associated + type family instances be instantiated with distinct type variables. However, + that requirement proved too restrictive in practice, as there were examples + of extremely simple associated type family instances that this check would + reject, and fixing them required tiresome boilerplate in the form of + auxiliary type families. For instance, you would have to define the above + example as: + + instance C [p] Int where + type T [p] x Int = CAux x + + type family CAux x where + CAux (Maybe x) = x + CAux (Either x y) = x -> y + + We decided that this restriction wasn't buying us much, so we opted not + to pursue that design (see also GHC #13398). + +Implementation + * Form the mini-envt from the class type variables a,b + to the instance decl types [p],Int: [a->[p], b->Int] + + * Look at the tyvars a,x,b of the type family constructor T + (it shares tyvars with the class C) + + * Apply the mini-evnt to them, and check that the result is + consistent with the instance types [p] y Int. (where y can be any type, as + it is not scoped over the class type variables. + +We make all the instance type variables scope over the +type instances, of course, which picks up non-obvious kinds. Eg + class Foo (a :: k) where + type F a + instance Foo (b :: k -> k) where + type F b = Int +Here the instance is kind-indexed and really looks like + type F (k->k) (b::k->k) = Int +But if the 'b' didn't scope, we would make F's instance too +poly-kinded. + +Note [Printing conflicts with class header] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's remarkably painful to give a decent error message for conflicts +with the class header. Consider + class C b where + type F a b c + instance C [b] where + type F x Int _ _ = ... + +Here we want to report a conflict between + Expected: F _ [b] _ + Actual: F x Int _ _ + +But if the type instance shadows the class variable like this +(rename/should_fail/T15828): + instance C [b] where + type forall b. F x (Tree b) _ _ = ... + +then we must use a fresh variable name + Expected: F _ [b] _ + Actual: F x [b1] _ _ + +Notice that: + - We want to print an underscore in the "Expected" type in + positions where the class header has no influence over the + parameter. Hence the fancy footwork in pp_expected_ty + + - Although the binders in the axiom are already tidy, we must + re-tidy them to get a fresh variable name when we shadow + + - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the + class-instance variables a second time, from 'a' to 'a1' say. + Remember, the ax_tvs of the axiom share identity with the + class-instance variables, inst_tvs.. + + - We use tidyCoAxBndrsForUser to get underscores rather than + _1, _2, etc in the axiom tyvars; see the definition of + tidyCoAxBndrsForUser + +This all seems absurdly complicated. + +Note [Unused explicitly bound variables in a family pattern] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Why is 'unusedExplicitForAllErr' not just a warning? + +Consider the following examples: + + type instance F a = Maybe b + type instance forall b. F a = Bool + type instance forall b. F a = Maybe b + +In every case, b is a type variable not determined by the LHS pattern. The +first is caught by the renamer, but we catch the last two here. Perhaps one +could argue that the second should be accepted, albeit with a warning, but +consider the fact that in a type family instance, there is no way to interact +with such a variable. At least with @x :: forall a. Int@ we can use visible +type application, like @x \@Bool 1@. (Of course it does nothing, but it is +permissible.) In the type family case, the only sensible explanation is that +the user has made a mistake -- thus we throw an error. + +Note [Oversaturated type family equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type family tycons have very rigid arities. We want to reject something like +this: + + type family Foo :: Type -> Type where + Foo x = ... + +Because Foo has arity zero (i.e., it doesn't bind anything to the left of the +double colon), we want to disallow any equation for Foo that has more than zero +arguments, such as `Foo x = ...`. The algorithm here is pretty simple: if an +equation has more arguments than the arity of the type family, reject. + +Things get trickier when visible kind application enters the picture. Consider +the following example: + + type family Bar (x :: j) :: forall k. Either j k where + Bar 5 @Symbol = ... + +The arity of Bar is two, since it binds two variables, `j` and `x`. But even +though Bar's equation has two arguments, it's still invalid. Imagine the same +equation in Core: + + Bar Nat 5 Symbol = ... + +Here, it becomes apparent that Bar is actually taking /three/ arguments! So +we can't just rely on a simple counting argument to reject +`Bar 5 @Symbol = ...`, since it only has two user-written arguments. +Moreover, there's one explicit argument (5) and one visible kind argument +(@Symbol), which matches up perfectly with the fact that Bar has one required +binder (x) and one specified binder (j), so that's not a valid way to detect +oversaturation either. + +To solve this problem in a robust way, we do the following: + +1. When kind-checking, we count the number of user-written *required* + arguments and check if there is an equal number of required tycon binders. + If not, reject. (See `wrongNumberOfParmsErr` in GHC.Tc.TyCl.) + + We perform this step during kind-checking, not during validity checking, + since we can give better error messages if we catch it early. +2. When validity checking, take all of the (Core) type patterns from on + equation, drop the first n of them (where n is the arity of the type family + tycon), and check if there are any types leftover. If so, reject. + + Why does this work? We know that after dropping the first n type patterns, + none of the leftover types can be required arguments, since step (1) would + have already caught that. Moreover, the only places where visible kind + applications should be allowed are in the first n types, since those are the + only arguments that can correspond to binding forms. Therefore, the + remaining arguments must correspond to oversaturated uses of visible kind + applications, which are precisely what we want to reject. + +Note that we only perform this check for type families, and not for data +families. This is because it is perfectly acceptable to oversaturate data +family instance equations: see Note [Arity of data families] in GHC.Core.FamInstEnv. + +************************************************************************ +* * + Telescope checking +* * +************************************************************************ + +Note [Bad TyCon telescopes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Now that we can mix type and kind variables, there are an awful lot of +ways to shoot yourself in the foot. Here are some. + + data SameKind :: k -> k -> * -- just to force unification + +1. data T1 a k (b :: k) (x :: SameKind a b) + +The problem here is that we discover that a and b should have the same +kind. But this kind mentions k, which is bound *after* a. +(Testcase: dependent/should_fail/BadTelescope) + +2. data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +Note that b is not bound. Yet its kind mentions a. Because we have +a nice rule that all implicitly bound variables come before others, +this is bogus. + +To catch these errors, we call checkTyConTelescope during kind-checking +datatype declarations. This checks for + +* Ill-scoped binders. From (1) and (2) above we can get putative + kinds like + T1 :: forall (a:k) (k:*) (b:k). SameKind a b -> * + where 'k' is mentioned a's kind before k is bound + + This is easy to check for: just look for + out-of-scope variables in the kind + +* We should arguably also check for ambiguous binders + but we don't. See Note [Ambiguous kind vars]. + +See also + * Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl. + * Note [Checking telescopes] in GHC.Tc.Types.Constraint discusses how + this check works for `forall x y z.` written in a type. + +Note [Ambiguous kind vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to be concerned about ambiguous binders. Suppose we have the kind + S1 :: forall k -> * -> * + S2 :: forall k. * -> * +Here S1 is OK, because k is Required, and at a use of S1 we will +see (S1 *) or (S1 (*->*)) or whatever. + +But S2 is /not/ OK because 'k' is Specfied (and hence invisible) and +we have no way (ever) to figure out how 'k' should be instantiated. +For example if we see (S2 Int), that tells us nothing about k's +instantiation. (In this case we'll instantiate it to Any, but that +seems wrong.) This is really the same test as we make for ambiguous +type in term type signatures. + +Now, it's impossible for a Specified variable not to occur +at all in the kind -- after all, it is Specified so it must have +occurred. (It /used/ to be possible; see tests T13983 and T7873. But +with the advent of the forall-or-nothing rule for kind variables, +those strange cases went away. See Note [forall-or-nothing rule] in +GHC.Hs.Type.) + +But one might worry about + type v k = * + S3 :: forall k. V k -> * +which appears to mention 'k' but doesn't really. Or + S4 :: forall k. F k -> * +where F is a type function. But we simply don't check for +those cases of ambiguity, yet anyway. The worst that can happen +is ambiguity at the call sites. + +Historical note: this test used to be called reportFloatingKvs. +-} + +-- | Check a list of binders to see if they make a valid telescope. +-- See Note [Bad TyCon telescopes] +type TelescopeAcc + = ( TyVarSet -- Bound earlier in the telescope + , Bool -- At least one binder occurred (in a kind) before + -- it was bound in the telescope. E.g. + ) -- T :: forall (a::k) k. blah + +checkTyConTelescope :: TyCon -> TcM () +checkTyConTelescope tc + | bad_scope + = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] + addErr $ TcRnBadTyConTelescope tc + + | otherwise + = return () + where + tcbs = tyConBinders tc + + (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs + + add_one :: TelescopeAcc -> TyConBinder -> TelescopeAcc + add_one (bound, bad_scope) tcb + = ( bound `extendVarSet` tv + , bad_scope || not (isEmptyVarSet (fkvs `minusVarSet` bound)) ) + where + tv = binderVar tcb + fkvs = tyCoVarsOfType (tyVarKind tv) diff --git a/GHC/Tc/Zonk/Env.hs b/GHC/Tc/Zonk/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Zonk/Env.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoPolyKinds #-} + +-- | The 'ZonkEnv' zonking environment, and the 'ZonkT' and 'ZonkBndrT' +-- monad transformers, for the final zonking to type in "GHC.Tc.Zonk.Type". +-- +-- See Note [Module structure for zonking] in GHC.Tc.Zonk.Type. +module GHC.Tc.Zonk.Env + ( -- * The 'ZonkEnv' + ZonkEnv(..), getZonkEnv + , ZonkFlexi(..) + , initZonkEnv + + -- * The 'ZonkT' and 'ZonkBndrT' zonking monad transformers + , ZonkT(ZonkT,runZonkT), ZonkBndrT(..) + + -- ** Going between 'ZonkT' and 'ZonkBndrT' + , runZonkBndrT + , noBinders, don'tBind + + -- ** Modifying and extending the 'ZonkEnv' in 'ZonkBndrT' + , setZonkType + , extendZonkEnv + , extendIdZonkEnv, extendIdZonkEnvRec + , extendTyZonkEnv + + ) + where + +import GHC.Prelude + +import GHC.Core.TyCo.Rep ( Type ) +import GHC.Types.Var ( TyCoVar, Var, TyVar ) + +import GHC.Types.Var ( Id, isTyCoVar ) +import GHC.Types.Var.Env + +import GHC.Utils.Monad.Codensity +import GHC.Utils.Outputable + +import Control.Monad.Fix ( MonadFix(..) ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Trans.Class ( MonadTrans(..) ) +import Data.Coerce ( coerce ) +import Data.IORef ( IORef, newIORef ) +import Data.List ( partition ) + +import GHC.Exts ( oneShot ) + +-------------------------------------------------------------------------------- + +-- | See Note [The ZonkEnv] +data ZonkEnv + = ZonkEnv { ze_flexi :: !ZonkFlexi + , ze_tv_env :: TyCoVarEnv TyCoVar + , ze_id_env :: IdEnv Id + , ze_meta_tv_env :: IORef (TyVarEnv Type) } + +-- | How should we handle unfilled unification variables in the zonker? +-- +-- See Note [Un-unified unification variables] +data ZonkFlexi + = DefaultFlexi -- ^ Default unbound unification variables to Any + + | SkolemiseFlexi -- ^ Skolemise unbound unification variables + (IORef [TyVar]) -- See Note [Zonking the LHS of a RULE] + -- Records the tyvars thus skolemised + + | RuntimeUnkFlexi -- ^ Used in the GHCi debugger + + | NoFlexi -- ^ Panic on unfilled meta-variables + -- See Note [Error on unconstrained meta-variables] + -- in GHC.Tc.Utils.TcMType + +instance Outputable ZonkEnv where + ppr (ZonkEnv { ze_tv_env = tv_env + , ze_id_env = id_env }) + = text "ZE" <+> braces (vcat + [ text "ze_tv_env =" <+> ppr tv_env + , text "ze_id_env =" <+> ppr id_env ]) + +{- Note [The ZonkEnv] +~~~~~~~~~~~~~~~~~~~~~ +* ze_flexi :: ZonkFlexi says what to do with a + unification variable that is still un-unified. + See Note [Un-unified unification variables] + +* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site + of a tyvar or covar, we zonk the kind right away and add a mapping + to the env. This prevents re-zonking the kind at every + occurrence. But this is *just* an optimisation. + +* ze_id_env : IdEnv Id promotes sharing among Ids, by making all + occurrences of the Id point to a single zonked copy, built at the + binding site. + + Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec. + In a mutually recursive group + rec { f = ...g...; g = ...f... } + we want the occurrence of g to point to the one zonked Id for g, + and the same for f. + + Because it is knot-tied, we must be careful to consult it lazily. + +* ze_meta_tv_env: see Note [Sharing when zonking to Type] + + +Notes: + * We must be careful never to put coercion variables (which are Ids, + after all) in the knot-tied ze_id_env, because coercions can + appear in types, and we sometimes inspect a zonked type in + the GHC.Tc.Zonk.Type module. [Question: where, precisely?] + + * An obvious suggestion would be to have one VarEnv Var to + replace both ze_id_env and ze_tv_env, but that doesn't work + because of the knot-tying stuff mentioned above. + +Note [Un-unified unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we do if we find a Flexi unification variable? +There are three possibilities: + +* DefaultFlexi: this is the common case, in situations like + length @alpha ([] @alpha) + It really doesn't matter what type we choose for alpha. But + we must choose a type! We can't leave mutable unification + variables floating around: after typecheck is complete, every + type variable occurrence must have a binding site. + + So we default it to 'Any' of the right kind. + + All this works for both type and kind variables (indeed + the two are the same thing). + +* SkolemiseFlexi: is a special case for the LHS of RULES. + See Note [Zonking the LHS of a RULE] + +* RuntimeUnkFlexi: is a special case for the GHCi debugger. + It's a way to have a variable that is not a mutable + unification variable, but doesn't have a binding site + either. + +* NoFlexi: See Note [Error on unconstrained meta-variables] + in GHC.Tc.Utils.TcMType. This mode will panic on unfilled + meta-variables. +-} + +-- | A reader monad over 'ZonkEnv', for zonking computations which +-- don't modify the 'ZonkEnv' (e.g. don't bind any variables). +-- +-- Use 'ZonkBndrT' when you need to modify the 'ZonkEnv' (e.g. to bind +-- a variable). +newtype ZonkT m a = ZonkT' { runZonkT :: ZonkEnv -> m a } + +{- Note [Instances for ZonkT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Below, we derive the following instances by hand: + + newtype ZonkT m a = ZonkT { runZonkT :: ZonkEnv -> m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix) + via ReaderT ZonkEnv m + deriving MonadTrans + via ReaderT ZonkEnv + +Why? Two reasons: + + 1. To use oneShot. See Note [The one-shot state monad trick] in GHC.Utils.Monad. + 2. To be strict in the ZonkEnv. This allows us to worker-wrapper functions, + passing them individual fields of the ZonkEnv instead of the whole record. + When this happens, we avoid allocating a ZonkEnv, which is a win. +-} + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +{-# COMPLETE ZonkT #-} +pattern ZonkT :: forall m a. (ZonkEnv -> m a) -> ZonkT m a +pattern ZonkT m <- ZonkT' m + where + ZonkT m = ZonkT' (oneShot m) + +-- See Note [Instances for ZonkT] +instance Functor m => Functor (ZonkT m) where + fmap f (ZonkT g) = ZonkT $ \ !env -> fmap f (g env) + a <$ ZonkT g = ZonkT $ \ !env -> a <$ g env + {-# INLINE fmap #-} + {-# INLINE (<$) #-} + +-- See Note [Instances for ZonkT] +instance Applicative m => Applicative (ZonkT m) where + pure a = ZonkT (\ !_ -> pure a) + ZonkT f <*> ZonkT x = ZonkT (\ !env -> f env <*> x env ) + ZonkT m *> f = ZonkT (\ !env -> m env *> runZonkT f env) + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + {-# INLINE (*>) #-} + +-- See Note [Instances for ZonkT] +instance Monad m => Monad (ZonkT m) where + ZonkT m >>= f = + ZonkT (\ !env -> do { r <- m env + ; runZonkT (f r) env }) + (>>) = (*>) + {-# INLINE (>>=) #-} + {-# INLINE (>>) #-} + +-- See Note [Instances for ZonkT] +instance MonadIO m => MonadIO (ZonkT m) where + liftIO f = ZonkT (\ !_ -> liftIO f) + {-# INLINE liftIO #-} + +-- See Note [Instances for ZonkT] +instance MonadTrans ZonkT where + lift ma = ZonkT $ \ !_ -> ma + {-# INLINE lift #-} + +-- See Note [Instances for ZonkT] +instance MonadFix m => MonadFix (ZonkT m) where + mfix f = ZonkT $ \ !r -> mfix $ oneShot $ \ a -> runZonkT (f a) r + {-# INLINE mfix #-} + +-- | Zonk binders, bringing them into scope in the inner computation. +-- +-- Can be thought of as a state monad transformer @StateT ZonkEnv m a@, +-- but written in continuation-passing style. +-- +-- See Note [Continuation-passing style for zonking]. +newtype ZonkBndrT m a = ZonkBndrT { runZonkBndrT' :: forall r. (a -> ZonkT m r) -> ZonkT m r } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix) + via Codensity (ZonkT m) + -- See GHC.Utils.Monad.Codensity for the instance definitions. + -- See Note [Continuation-passing style for zonking] for why we use + -- continuation-passing style instead of a direct state monad. + +{- Note [Continuation-passing style for zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While zonking, we sometimes need to modify the ZonkEnv. For example, when +zonking a binder with zonkTyBndrX, we extend the type variable ZonkEnv. + +We could use direct state passing: + + zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar) + zonkTyBndrX ze tv = + do { tv' <- ... ze tv + ; let ze' = extendTyZonkEnv ze tv' + ; return (ze', tv') } + +but we can avoid allocating pairs by using continuation-passing style instead, +for example: + + zonkTyBndrX :: (ZonkEnv -> TcTyVar -> TcM r) -> ZonkEnv -> TcM r + zonkTyBndrX k ze = + do { tv' <- ... ze tv + ; let ze' = extendTyZonkEnv ze tv + ; k ze' tv' } + +We thus define: + + newtype ZonkBndrT m a = + ZonkBndrT { runZonkBndrT :: forall r. (a -> ZonkT m r) -> ZonkT m r } + +which is the type of continuation-passing computations over ZonkT m = ReaderT ZonkEnv m. +We thus have: + + zonkTyBndrX :: TcTyVar -> ZonkBndrT TcM TyVar + +which expresses the fact that zonkTyBndrX takes in a TcTyVar, returns a TyVar, +modifying the ZonkEnv state in the process. We can build computations out of it +by using runZonkBndrT and nesting. For example, zonking a type synonym: + + zonkTySynRHS :: [TcTyConBinder] -> [TcTyVar] -> ZonkT TcM ([TyConBinder], [TyVar]) + zonkTySynRHS tc_bndrs rhs_tc_ty = + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { rhs_ty <- zonkTcTypeToTypeX rhs_tc_ty + ; return (bndrs, rhs_ty) } + +This is known as the codensity transformation, where + + newtype Codensity m a = Codensity { forall r. (a -> m r) -> m r } + +expresses continuation-passing computations in the monad m. + +Codensity (ReaderT s m) naturally corresponds to StateT s (Codensity m), and +the instances for Codensity reflect that, e.g. + + traverse :: (a -> ZonkBndrT m b) -> t a -> ZonkBndrT m (t b) + +naturally behaves like mapAccumLM, accumulating changes to the ZonkEnv as +we go. +-} + +-- | Zonk some binders and run the continuation. +-- +-- Example: +-- +-- > zonk (ForAllTy (Bndr tv vis) body_ty) +-- > = runZonkBndrT (zonkTyBndrX tv) $ \ tv' -> +-- > do { body_ty' <- zonkTcTypeToTypeX body_ty +-- > ; return (ForAllTy (Bndr tv' vis) body_ty') } +-- +-- See Note [Continuation-passing style for zonking]. +runZonkBndrT :: ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r +runZonkBndrT (ZonkBndrT k) f = k (oneShot f) +{-# INLINE runZonkBndrT #-} + +-- | Embed a computation that doesn't modify the 'ZonkEnv' into 'ZonkBndrT'. +noBinders :: Monad m => ZonkT m a -> ZonkBndrT m a +noBinders z = coerce $ toCodensity z +{-# INLINE noBinders #-} + +-- | Run a nested computation that modifies the 'ZonkEnv', +-- without affecting the outer environment. +don'tBind :: Monad m => ZonkBndrT m a -> ZonkT m a +don'tBind (ZonkBndrT k) = fromCodensity (Codensity k) +{-# INLINE don'tBind #-} + +initZonkEnv :: MonadIO m => ZonkFlexi -> ZonkT m b -> m b +initZonkEnv flexi thing_inside + = do { mtv_env_ref <- liftIO $ newIORef emptyVarEnv + ; let ze = ZonkEnv { ze_flexi = flexi + , ze_tv_env = emptyVarEnv + , ze_id_env = emptyVarEnv + , ze_meta_tv_env = mtv_env_ref } + + ; runZonkT thing_inside ze } +{-# INLINEABLE initZonkEnv #-} -- so it can be specialised + +nestZonkEnv :: (ZonkEnv -> ZonkEnv) -> ZonkBndrT m () +nestZonkEnv f = ZonkBndrT $ \ k -> + case k () of + ZonkT g -> ZonkT (g . f) +{-# INLINE nestZonkEnv #-} + +getZonkEnv :: Monad m => ZonkT m ZonkEnv +getZonkEnv = ZonkT return +{-# INLINE getZonkEnv #-} + +-- | Extend the knot-tied environment. +extendIdZonkEnvRec :: [Var] -> ZonkBndrT m () +extendIdZonkEnvRec ids = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_id_env = id_env }) -> + -- NB: Don't look at the var to decide which env't to put it in. That + -- would end up knot-tying all the env'ts. + ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } + -- Given coercion variables will actually end up here. That's OK though: + -- coercion variables are never looked up in the knot-tied env't, so zonking + -- them simply doesn't get optimised. No one gets hurt. An improvement (?) + -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the + -- recursive groups. But perhaps the time it takes to do the analysis is + -- more than the savings. + +extendZonkEnv :: [Var] -> ZonkBndrT m () +extendZonkEnv vars = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) -> + ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars] + , ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } + where + (tycovars, ids) = partition isTyCoVar vars + +extendIdZonkEnv :: Var -> ZonkBndrT m () +extendIdZonkEnv id = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_id_env = id_env }) -> + ze { ze_id_env = extendVarEnv id_env id id } + +extendTyZonkEnv :: TyVar -> ZonkBndrT m () +extendTyZonkEnv tv = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_tv_env = ty_env }) -> + ze { ze_tv_env = extendVarEnv ty_env tv tv } + +setZonkType :: ZonkFlexi -> ZonkT m a -> ZonkT m a +setZonkType flexi (ZonkT f) = ZonkT $ \ ze -> + f $ ze { ze_flexi = flexi } diff --git a/GHC/Tc/Zonk/Monad.hs b/GHC/Tc/Zonk/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Zonk/Monad.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +-- | The 'ZonkM' monad, a stripped down 'TcM', used when zonking within +-- the typechecker in "GHC.Tc.Zonk.TcType". +-- +-- See Note [Module structure for zonking] in GHC.Tc.Zonk.Type. +module GHC.Tc.Zonk.Monad + ( -- * The 'ZonkM' monad, a stripped down 'TcM' for zonking + ZonkM(ZonkM,runZonkM) + , ZonkGblEnv(..), getZonkGblEnv, getZonkTcLevel + + -- ** Logging within 'ZonkM' + , traceZonk + + ) + where + +import GHC.Prelude + +import GHC.Driver.Flags ( DumpFlag(Opt_D_dump_tc_trace) ) + +import GHC.Types.SrcLoc ( SrcSpan ) + +import GHC.Tc.Types.BasicTypes ( TcBinderStack ) +import GHC.Tc.Utils.TcType ( TcLevel ) + +import GHC.Utils.Logger +import GHC.Utils.Outputable + +import Control.Monad ( when ) +import Control.Monad.IO.Class ( MonadIO(..) ) + +import GHC.Exts ( oneShot ) + +-------------------------------------------------------------------------------- + +-- | Information needed by the 'ZonkM' monad, which is a slimmed down version +-- of 'TcM' with just enough information for zonking. +data ZonkGblEnv + = ZonkGblEnv + { zge_logger :: Logger -- needed for traceZonk + , zge_name_ppr_ctx :: NamePprCtx -- '' + , zge_src_span :: SrcSpan -- needed for skolemiseUnboundMetaTyVar + , zge_tc_level :: TcLevel -- '' + , zge_binder_stack :: TcBinderStack -- needed for tcInitTidyEnv + } + +-- | A stripped down version of 'TcM' which is sufficient for zonking types. +newtype ZonkM a = ZonkM' { runZonkM :: ZonkGblEnv -> IO a } +{- +NB: we write the following instances by hand: + +-- deriving (Functor, Applicative, Monad, MonadIO) +-- via ReaderT ZonkGblEnv IO + +See Note [Instances for ZonkT] in GHC.Tc.Zonk.Env for the reasoning: + + - oneShot annotations, + - strictness annotations to enable worker-wrapper. +-} + +{-# COMPLETE ZonkM #-} +pattern ZonkM :: forall a. (ZonkGblEnv -> IO a) -> ZonkM a +pattern ZonkM m <- ZonkM' m + where + ZonkM m = ZonkM' (oneShot m) +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad + +instance Functor ZonkM where + fmap f (ZonkM g) = ZonkM $ \ !env -> fmap f (g env) + a <$ ZonkM g = ZonkM $ \ !env -> a <$ g env + {-# INLINE fmap #-} + {-# INLINE (<$) #-} +instance Applicative ZonkM where + pure a = ZonkM (\ !_ -> pure a) + ZonkM f <*> ZonkM x = ZonkM (\ !env -> f env <*> x env ) + ZonkM m *> f = ZonkM (\ !env -> m env *> runZonkM f env) + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + {-# INLINE (*>) #-} + +instance Monad ZonkM where + ZonkM m >>= f = + ZonkM (\ !env -> do { r <- m env + ; runZonkM (f r) env }) + (>>) = (*>) + {-# INLINE (>>=) #-} + {-# INLINE (>>) #-} + +instance MonadIO ZonkM where + liftIO f = ZonkM (\ !_ -> f) + {-# INLINE liftIO #-} + +getZonkGblEnv :: ZonkM ZonkGblEnv +getZonkGblEnv = ZonkM return +{-# INLINE getZonkGblEnv #-} + +getZonkTcLevel :: ZonkM TcLevel +getZonkTcLevel = ZonkM (\env -> return (zge_tc_level env)) + +-- | Same as 'traceTc', but for the 'ZonkM' monad. +traceZonk :: String -> SDoc -> ZonkM () +traceZonk herald doc = ZonkM $ + \ ( ZonkGblEnv { zge_logger = !logger, zge_name_ppr_ctx = ppr_ctx }) -> + do { let sty = mkDumpStyle ppr_ctx + flag = Opt_D_dump_tc_trace + title = "" + msg = hang (text herald) 2 doc + ; when (logHasDumpFlag logger flag) $ + logDumpFile logger sty flag title FormatText msg + } +{-# INLINE traceZonk #-} + -- see Note [INLINE conditional tracing utilities] in GHC.Tc.Utils.Monad diff --git a/GHC/Tc/Zonk/TcType.hs b/GHC/Tc/Zonk/TcType.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Zonk/TcType.hs @@ -0,0 +1,818 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 +-} + +-- | Zonking types within the typechecker. +-- +-- Distinct from the final zonking pass in "GHC.Tc.Zonk.Type"; +-- see Note [Module structure for zonking] in GHC.Tc.Zonk.Type. +module GHC.Tc.Zonk.TcType + ( -- * Zonking (within the typechecker) + + -- ** The 'ZonkM' monad and 'ZonkGblEnv' + module GHC.Tc.Zonk.Monad + + -- ** Zonking types + , zonkTcType, zonkTcTypes, zonkScaledTcType + , zonkTcTyVar, zonkTcTyVars + , zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars + , zonkInvisTVBinder + , zonkCo + + -- ** Zonking 'TyCon's + , zonkTcTyCon + + -- *** FreeVars + , zonkTcTypeAndFV, zonkTyCoVarsAndFV, zonkTyCoVarsAndFVList + , zonkDTyCoVarSetAndFV + + -- ** Zonking 'CoVar's and 'Id's + , zonkId, zonkCoVar, zonkTyCoVar, zonkTyCoVarKind, zonkTyCoVarBndrKind + + -- ** Zonking skolem info + , zonkSkolemInfo, zonkSkolemInfoAnon + + -- ** Zonking constraints + , zonkCt, zonkWC, zonkSimples, zonkImplication + + -- * Rewriter sets + , zonkRewriterSet, zonkCtRewriterSet, zonkCtEvRewriterSet + + -- * Coercion holes + , isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe + + + -- * Tidying + , tcInitTidyEnv, tcInitOpenTidyEnv + , tidyCt, tidyEvVar, tidyDelayedError + + -- ** Zonk & tidy + , zonkTidyTcType, zonkTidyTcTypes + , zonkTidyOrigin, zonkTidyOrigins + , zonkTidyFRRInfos + + -- * Writing to metavariables + , writeMetaTyVar, writeMetaTyVarRef + + -- * Handling coercion holes + , checkCoercionHole + + ) + where + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set + +import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Types.TcRef +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.Monad + +import GHC.Core.InstEnv (ClsInst(is_tys)) +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Tidy +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Predicate + +import GHC.Utils.Constants +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Misc +import GHC.Utils.Monad ( mapAccumLM ) +import GHC.Utils.Panic + +import GHC.Data.Bag +import GHC.Data.Pair + +import Data.Semigroup +import Data.Maybe + +{- ********************************************************************* +* * + Writing to metavariables +* * +************************************************************************ +-} + +-- | Write into a currently-empty MetaTyVar. +-- +-- Works with both type and kind variables. +writeMetaTyVar :: HasDebugCallStack + => TcTyVar -- ^ the type varfiable to write to + -> TcType -- ^ the type to write into the mutable reference + -> ZonkM () +writeMetaTyVar tyvar ty + | not debugIsOn + = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty + +-- Everything from here on only happens if DEBUG is on + | not (isTcTyVar tyvar) + = massertPpr False (text "Writing to non-tc tyvar" <+> ppr tyvar) + + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar + = writeMetaTyVarRef tyvar ref ty + + | otherwise + = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar) +{-# INLINE writeMetaTyVar #-} -- See NOTE [Inlining writeMetaTyVar] + +-- | Write into the 'MetaDetails' mutable references of a 'MetaTv'. +writeMetaTyVarRef :: HasDebugCallStack + => TcTyVar -- ^ for debug assertions only; + -> TcRef MetaDetails -- ^ ref cell must be for the same tyvar + -> TcType -- ^ the type to write to the mutable reference + -> ZonkM () +writeMetaTyVarRef tyvar ref ty + | not debugIsOn + = do { traceZonk "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) + <+> text ":=" <+> ppr ty) + ; writeTcRef ref (Indirect ty) } + + -- Everything from here on only happens if DEBUG is on + -- Need to zonk 'ty' because we may only recently have promoted + -- its free meta-tyvars (see GHC.Tc.Utils.Unify.checkPromoteFreeVars) + | otherwise + = do { meta_details <- readTcRef ref; + -- Zonk kinds to allow the error check to work + ; zonked_tv_kind <- zonkTcType tv_kind + ; zonked_ty <- zonkTcType ty + ; let zonked_ty_kind = typeKind zonked_ty + zonked_ty_lvl = tcTypeLevel zonked_ty + level_check_ok = not (zonked_ty_lvl `strictlyDeeperThan` tv_lvl) + level_check_msg = ppr zonked_ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty $$ ppr zonked_ty + kind_check_ok = zonked_ty_kind `eqType` zonked_tv_kind + -- Note [Extra-constraint holes in partial type signatures] in GHC.Tc.Gen.HsType + + kind_msg = hang (text "Ill-kinded update to meta tyvar") + 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) + <+> text ":=" + <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) ) + + ; traceZonk "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) + + -- Check for double updates + ; massertPpr (isFlexi meta_details) (double_upd_msg meta_details) + + -- Check for level OK + ; massertPpr level_check_ok level_check_msg + + -- Check Kinds ok + ; massertPpr kind_check_ok kind_msg + + -- Do the write + ; writeTcRef ref (Indirect ty) } + where + tv_kind = tyVarKind tyvar + + tv_lvl = tcTyVarLevel tyvar + + + double_upd_msg details = hang (text "Double update of meta tyvar") + 2 (ppr tyvar $$ ppr details) +{-# INLINE writeMetaTyVarRef #-} -- See NOTE [Inlining writeMetaTyVar] + +{- NOTE [Inlining writeMetaTyVar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +writeMetaTyVar is defined in the ZonkM monad, but it is often used within +TcM with the following idiom: + + liftZonkM $ writeMetaTyVar tv ty + +Using liftZonkM within TcM generally means extracting out a ZonkGblEnv +from the TcM monad to pass to the inner ZonkM computation (see the definition +of liftZonkM). This can cause writeMetaTyVar to allocate a ZonkGblEnv, which we +would much rather avoid! +Instead, we should directly pass the bits of the ZonkGblEnv that writeMetaTyVar +needs (the Logger and NamePprCtxt, which are needed for the traceZonk call +in writeMetaTyVar). This is achieved by inlining writeMetaTyVar and writeMetaTyVarRef. +These functions just wrap writeTcRef, with some extra tracing +(and some assertions if running in debug mode), so it's fine to inline them. + +See for example test T5631, which regresses without this change. +-} + +{- +************************************************************************ +* * + Zonking -- the main work-horses: zonkTcType, zonkTcTyVar +* * +************************************************************************ +-} + +zonkScaledTcType :: Scaled TcType -> ZonkM (Scaled TcType) +zonkScaledTcType (Scaled m ty) + = Scaled <$> zonkTcType m <*> zonkTcType ty + +-- For unbound, mutable tyvars, zonkType uses the function given to it +-- For tyvars bound at a for-all, zonkType zonks them to an immutable +-- type variable and zonks the kind too +zonkTcType :: TcType -> ZonkM TcType +zonkTcTypes :: [TcType] -> ZonkM [TcType] +zonkCo :: Coercion -> ZonkM Coercion +(zonkTcType, zonkTcTypes, zonkCo, _) + = mapTyCo zonkTcTypeMapper + where + -- A suitable TyCoMapper for zonking a type during type-checking, + -- before all metavars are filled in. + zonkTcTypeMapper :: TyCoMapper () ZonkM + zonkTcTypeMapper = TyCoMapper + { tcm_tyvar = const zonkTcTyVar + , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv) + , tcm_hole = hole + , tcm_tycobinder = \ _env tcv _vis k -> zonkTyCoVarKind tcv >>= k () + , tcm_tycon = zonkTcTyCon } + where + hole :: () -> CoercionHole -> ZonkM Coercion + hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) + = do { contents <- readTcRef ref + ; case contents of + Just co -> do { co' <- zonkCo co + ; checkCoercionHole cv co' } + Nothing -> do { cv' <- zonkCoVar cv + ; return $ HoleCo (hole { ch_co_var = cv' }) } } + +zonkTcTyCon :: TcTyCon -> ZonkM TcTyCon +-- Only called on TcTyCons +-- A non-poly TcTyCon may have unification +-- variables that need zonking, but poly ones cannot +zonkTcTyCon tc + | isMonoTcTyCon tc = do { tck' <- zonkTcType (tyConKind tc) + ; return (setTcTyConKind tc tck') } + | otherwise = return tc + +zonkTcTyVar :: TcTyVar -> ZonkM TcType +-- Simply look through all Flexis +zonkTcTyVar tv + | isTcTyVar tv + = case tcTyVarDetails tv of + SkolemTv {} -> zonk_kind_and_return + RuntimeUnk {} -> zonk_kind_and_return + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> zonk_kind_and_return + Indirect ty -> do { zty <- zonkTcType ty + ; writeTcRef ref (Indirect zty) + -- See Note [Sharing in zonking] + ; return zty } } + + | otherwise -- coercion variable + = zonk_kind_and_return + where + zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv + ; return (mkTyVarTy z_tv) } + +-- Variant that assumes that any result of zonking is still a TyVar. +-- Should be used only on skolems and TyVarTvs +zonkTcTyVarsToTcTyVars :: HasDebugCallStack => [TcTyVar] -> ZonkM [TcTyVar] +zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar + +zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> ZonkM TcTyVar +zonkTcTyVarToTcTyVar tv + = do { ty <- zonkTcTyVar tv + ; let tv' = case getTyVar_maybe ty of + Just tv' -> tv' + Nothing -> pprPanic "zonkTcTyVarToTcTyVar" + (ppr tv $$ ppr ty) + ; return tv' } + +zonkInvisTVBinder :: VarBndr TcTyVar spec -> ZonkM (VarBndr TcTyVar spec) +zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTcTyVar tv + ; return (Bndr tv' spec) } + +{- ********************************************************************* +* * + Zonking types +* * +********************************************************************* -} + +zonkTcTypeAndFV :: TcType -> ZonkM DTyCoVarSet +-- Zonk a type and take its free variables +-- With kind polymorphism it can be essential to zonk *first* +-- so that we find the right set of free variables. Eg +-- forall k1. forall (a:k2). a +-- where k2:=k1 is in the substitution. We don't want +-- k2 to look free in this type! +zonkTcTypeAndFV ty + = tyCoVarsOfTypeDSet <$> zonkTcType ty + +zonkTyCoVar :: TyCoVar -> ZonkM TcType +-- Works on TyVars and TcTyVars +zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv + | isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv + | otherwise = assertPpr (isCoVar tv) (ppr tv) $ + mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv + -- Hackily, when typechecking type and class decls + -- we have TyVars in scope added (only) in + -- GHC.Tc.Gen.HsType.bindTyClTyVars, but it seems + -- painful to make them into TcTyVars there + +zonkTyCoVarsAndFV :: TyCoVarSet -> ZonkM TyCoVarSet +zonkTyCoVarsAndFV tycovars + = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars) + -- It's OK to use nonDetEltsUniqSet here because we immediately forget about + -- the ordering by turning it into a nondeterministic set and the order + -- of zonking doesn't matter for determinism. + +zonkDTyCoVarSetAndFV :: DTyCoVarSet -> ZonkM DTyCoVarSet +zonkDTyCoVarSetAndFV tycovars + = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars) + +-- Takes a list of TyCoVars, zonks them and returns a +-- deterministically ordered list of their free variables. +zonkTyCoVarsAndFVList :: [TyCoVar] -> ZonkM [TyCoVar] +zonkTyCoVarsAndFVList tycovars + = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars + +zonkTcTyVars :: [TcTyVar] -> ZonkM [TcType] +zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars + +----------------- Types +zonkTyCoVarKind :: TyCoVar -> ZonkM TyCoVar +zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) + ; return (setTyVarKind tv kind') } + +zonkTyCoVarBndrKind :: VarBndr TyCoVar flag -> ZonkM (VarBndr TyCoVar flag) +zonkTyCoVarBndrKind (Bndr tv flag) = + do { tv' <- zonkTyCoVarKind tv + ; return (Bndr tv' flag) } + +-- | zonkId is used *during* typechecking just to zonk the 'Id''s type +zonkId :: TcId -> ZonkM TcId +zonkId id = updateIdTypeAndMultM zonkTcType id + +zonkCoVar :: CoVar -> ZonkM CoVar +zonkCoVar = zonkId + +{- +************************************************************************ +* * + Coercion holes +* * +************************************************************************ +-} + +-- | Debugging-only! Check that a coercion is appropriate for filling a +-- hole. (The hole itself is needed only for printing.) +-- +-- Always returns the checked coercion, but this return value is necessary +-- so that the input coercion is forced only when the output is forced. +checkCoercionHole :: CoVar -> Coercion -> ZonkM Coercion +checkCoercionHole cv co + | debugIsOn + = do { cv_ty <- zonkTcType (varType cv) + -- co is already zonked, but cv might not be + ; return $ + assertPpr (ok cv_ty) + (text "Bad coercion hole" <+> + ppr cv Outputable.<> colon + <+> vcat [ ppr t1, ppr t2, ppr role, ppr cv_ty ]) + co } + | otherwise + = return co + + where + (Pair t1 t2, role) = coercionKindRole co + ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty + = t1 `eqType` cv_t1 + && t2 `eqType` cv_t2 + && role == eqRelRole cv_rel + | otherwise + = False + + +{- +************************************************************************ +* * + Zonking constraints +* * +************************************************************************ +-} + +zonkImplication :: Implication -> ZonkM Implication +zonkImplication implic@(Implic { ic_skols = skols + , ic_given = given + , ic_wanted = wanted + , ic_info = info }) + = do { skols' <- mapM zonkTyCoVarKind skols -- Need to zonk their kinds! + -- as #7230 showed + ; given' <- mapM zonkEvVar given + ; info' <- zonkSkolemInfoAnon info + ; wanted' <- zonkWCRec wanted + ; return (implic { ic_skols = skols' + , ic_given = given' + , ic_wanted = wanted' + , ic_info = info' }) } + +zonkEvVar :: EvVar -> ZonkM EvVar +zonkEvVar var = updateIdTypeAndMultM zonkTcType var + + +zonkWC :: WantedConstraints -> ZonkM WantedConstraints +zonkWC wc = zonkWCRec wc + +zonkWCRec :: WantedConstraints -> ZonkM WantedConstraints +zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_errors = errs }) + = do { simple' <- zonkSimples simple + ; implic' <- mapBagM zonkImplication implic + ; errs' <- mapBagM zonkDelayedError errs + ; return (WC { wc_simple = simple', wc_impl = implic', wc_errors = errs' }) } + +zonkSimples :: Cts -> ZonkM Cts +zonkSimples cts = do { cts' <- mapBagM zonkCt cts + ; traceZonk "zonkSimples done:" (ppr cts') + ; return cts' } + +zonkDelayedError :: DelayedError -> ZonkM DelayedError +zonkDelayedError (DE_Hole hole) + = DE_Hole <$> zonkHole hole +zonkDelayedError (DE_NotConcrete err) + = DE_NotConcrete <$> zonkNotConcreteError err +zonkDelayedError (DE_Multiplicity mult_co loc) + = DE_Multiplicity <$> zonkCo mult_co <*> pure loc + +zonkHole :: Hole -> ZonkM Hole +zonkHole hole@(Hole { hole_ty = ty }) + = do { ty' <- zonkTcType ty + ; return (hole { hole_ty = ty' }) } + +zonkNotConcreteError :: NotConcreteError -> ZonkM 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 -> ZonkM FixedRuntimeRepOrigin +zonkFRROrigin (FixedRuntimeRepOrigin ty orig) + = do { ty' <- zonkTcType ty + ; return $ FixedRuntimeRepOrigin ty' orig } + +{- Note [zonkCt behaviour] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +zonkCt tries to maintain the canonical form of a Ct. For example, + - a CDictCan should stay a CDictCan; + - a CIrredCan should stay a CIrredCan with its cc_reason flag intact + +Why?, for example: +- For CDictCan, the @GHC.Tc.Solver.expandSuperClasses@ step, which runs after the + simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use, + constraints are zonked before being passed to the plugin. This means if we + don't preserve a canonical form, @expandSuperClasses@ fails to expand + superclasses. This is what happened in #11525. + +- For CIrredCan we want to see if a constraint is insoluble with insolubleWC + +On the other hand, we change CEqCan to CNonCanonical, because of all of +CEqCan's invariants, which can break during zonking. (Example: a ~R alpha, where +we have alpha := N Int, where N is a newtype.) Besides, the constraint +will be canonicalised again, so there is little benefit in keeping the +CEqCan structure. + +NB: Constraints are always rewritten etc by the canonicaliser in +GHC.Tc.Solver.Solve.solveCt even if they come in as CDictCan. Only canonical +constraints that are actually in the inert set carry all the guarantees. So it +is okay if zonkCt creates e.g. a CDictCan where the cc_tyars are /not/ fully +reduced. +-} + +zonkCt :: Ct -> ZonkM Ct +-- See Note [zonkCt behaviour] +zonkCt (CDictCan dict@(DictCt { di_ev = ev, di_tys = args })) + = do { ev' <- zonkCtEvidence ev + ; args' <- mapM zonkTcType args + ; return (CDictCan (dict { di_ev = ev', di_tys = args' })) } + +zonkCt (CEqCan (EqCt { eq_ev = ev })) + = mkNonCanonical <$> zonkCtEvidence ev + +zonkCt (CIrredCan ir@(IrredCt { ir_ev = ev })) -- Preserve the ir_reason flag + = do { ev' <- zonkCtEvidence ev + ; return (CIrredCan (ir { ir_ev = ev' })) } + +zonkCt ct + = do { fl' <- zonkCtEvidence (ctEvidence ct) + ; return (mkNonCanonical fl') } + +zonkCtEvidence :: CtEvidence -> ZonkM CtEvidence +-- Zonks the ctev_pred and the ctev_rewriters; but not ctev_evar +-- For ctev_rewriters, see (WRW2) in Note [Wanteds rewrite Wanteds] +zonkCtEvidence (CtGiven (GivenCt { ctev_pred = pred, ctev_evar = var, ctev_loc = loc })) + = do { pred' <- zonkTcType pred + ; return (CtGiven (GivenCt { ctev_pred = pred', ctev_evar = var, ctev_loc = loc })) } +zonkCtEvidence (CtWanted wanted@(WantedCt { ctev_pred = pred, ctev_rewriters = rws })) + = do { pred' <- zonkTcType pred + ; rws' <- zonkRewriterSet rws + ; return (CtWanted (wanted { ctev_pred = pred', ctev_rewriters = rws' })) } + +zonkSkolemInfo :: SkolemInfo -> ZonkM SkolemInfo +zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk + +zonkSkolemInfoAnon :: SkolemInfoAnon -> ZonkM SkolemInfoAnon +zonkSkolemInfoAnon (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty + ; return (SigSkol cx ty' tv_prs) } +zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys + ; return (InferSkol ntys') } + where + do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } +zonkSkolemInfoAnon skol_info = return skol_info + +{- Note [Sharing in zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + alpha :-> beta :-> gamma :-> ty +where the ":->" means that the unification variable has been +filled in with Indirect. Then when zonking alpha, it'd be nice +to short-circuit beta too, so we end up with + alpha :-> zty + beta :-> zty + gamma :-> zty +where zty is the zonked version of ty. That way, if we come across +beta later, we'll have less work to do. (And indeed the same for +alpha.) + +This is easily achieved: just overwrite (Indirect ty) with (Indirect +zty). Non-systematic perf comparisons suggest that this is a modest +win. + +But c.f Note [Sharing when zonking to Type] in GHC.Tc.Zonk.Type. + +%************************************************************************ +%* * + Zonking rewriter sets +* * +************************************************************************ +-} + +zonkCtRewriterSet :: Ct -> ZonkM Ct +zonkCtRewriterSet ct + | isGivenCt ct + = return ct + | otherwise + = case ct of + CEqCan eq@(EqCt { eq_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CEqCan (eq { eq_ev = ev' })) } + CIrredCan ir@(IrredCt { ir_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CIrredCan (ir { ir_ev = ev' })) } + CDictCan di@(DictCt { di_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CDictCan (di { di_ev = ev' })) } + CQuantCan {} -> return ct + CNonCanonical ev -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CNonCanonical ev') } + +zonkCtEvRewriterSet :: CtEvidence -> ZonkM CtEvidence +zonkCtEvRewriterSet ev@(CtGiven {}) + = return ev +zonkCtEvRewriterSet ev@(CtWanted wtd) + = do { rewriters' <- zonkRewriterSet (ctEvRewriters ev) + ; return (CtWanted $ setWantedCtEvRewriters wtd rewriters') } + +-- | Zonk a rewriter set; if a coercion hole in the set has been filled, +-- find all the free un-filled coercion holes in the coercion that fills it +zonkRewriterSet :: RewriterSet -> ZonkM RewriterSet +zonkRewriterSet (RewriterSet set) + = nonDetStrictFoldUniqSet go (return emptyRewriterSet) set + -- This does not introduce non-determinism, because the only + -- monadic action is to read, and the combining function is + -- commutative + where + go :: CoercionHole -> ZonkM RewriterSet -> ZonkM RewriterSet + go hole m_acc = unionRewriterSet <$> check_hole hole <*> m_acc + + check_hole :: CoercionHole -> ZonkM RewriterSet + check_hole hole + = do { m_co <- unpackCoercionHole_maybe hole + ; case m_co of + Nothing -> return (unitRewriterSet hole) -- Not filled + Just co -> unUCHM (check_co co) } -- Filled: look inside + + 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 :: ZonkM RewriterSet } + +instance Semigroup UnfilledCoercionHoleMonoid where + UCHM l <> UCHM r = UCHM (unionRewriterSet <$> l <*> r) + +instance Monoid UnfilledCoercionHoleMonoid where + mempty = UCHM (return emptyRewriterSet) + + +{- +************************************************************************ +* * + Checking for coercion holes +* * +************************************************************************ +-} + +-- | Is a coercion hole filled in? +isFilledCoercionHole :: CoercionHole -> ZonkM Bool +isFilledCoercionHole (CoercionHole { ch_ref = ref }) + = isJust <$> readTcRef ref + +-- | Retrieve the contents of a coercion hole. Panics if the hole +-- is unfilled +unpackCoercionHole :: CoercionHole -> ZonkM Coercion +unpackCoercionHole hole + = do { contents <- unpackCoercionHole_maybe hole + ; case contents of + Just co -> return co + Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } + +-- | Retrieve the contents of a coercion hole, if it is filled +unpackCoercionHole_maybe :: CoercionHole -> ZonkM (Maybe Coercion) +unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref + + +{- +%************************************************************************ +%* * + Tidying +* * +************************************************************************ +-} + +tcInitTidyEnv :: ZonkM TidyEnv +-- We initialise the "tidy-env", used for tidying types before printing, +-- by building a reverse map from the in-scope type variables to the +-- OccName that the programmer originally used for them +tcInitTidyEnv + = do { ZonkGblEnv { zge_binder_stack = bndrs } <- getZonkGblEnv + ; go emptyTidyEnv bndrs } + where + go (env, subst) [] + = return (env, subst) + go (env, subst) (b : bs) + | TcTvBndr name tyvar <- b + = do { let (env', occ') = tidyOccName env (nameOccName name) + name' = tidyNameOcc name occ' + tyvar1 = setTyVarName tyvar name' + ; tyvar2 <- zonkTcTyVarToTcTyVar tyvar1 + -- Be sure to zonk here! Tidying applies to zonked + -- types, so if we don't zonk we may create an + -- ill-kinded type (#14175) + ; go (env', extendVarEnv subst tyvar tyvar2) bs } + | otherwise + = go (env, subst) bs + +-- | Get a 'TidyEnv' that includes mappings for all vars free in the given +-- type. Useful when tidying open types. +tcInitOpenTidyEnv :: [TyCoVar] -> ZonkM TidyEnv +tcInitOpenTidyEnv tvs + = do { env1 <- tcInitTidyEnv + ; return (tidyFreeTyCoVars env1 tvs) } + +zonkTidyTcType :: TidyEnv -> TcType -> ZonkM (TidyEnv, TcType) +zonkTidyTcType env ty = do { ty' <- zonkTcType ty + ; return (tidyOpenTypeX env ty') } + +zonkTidyTcTypes :: TidyEnv -> [TcType] -> ZonkM (TidyEnv, [TcType]) +zonkTidyTcTypes = zonkTidyTcTypes' [] + where zonkTidyTcTypes' zs env [] = return (env, reverse zs) + zonkTidyTcTypes' zs env (ty:tys) + = do { (env', ty') <- zonkTidyTcType env ty + ; zonkTidyTcTypes' (ty':zs) env' tys } + +zonkTidyOrigin :: TidyEnv -> CtOrigin -> ZonkM (TidyEnv, CtOrigin) +zonkTidyOrigin env (GivenOrigin skol_info) + = do { skol_info1 <- zonkSkolemInfoAnon skol_info + ; let skol_info2 = tidySkolemInfoAnon env skol_info1 + ; return (env, GivenOrigin skol_info2) } +zonkTidyOrigin env (GivenSCOrigin skol_info sc_depth blocked) + = do { skol_info1 <- zonkSkolemInfoAnon skol_info + ; let skol_info2 = tidySkolemInfoAnon env skol_info1 + ; return (env, GivenSCOrigin skol_info2 sc_depth blocked) } +zonkTidyOrigin env (ScOrigin (IsQC pred orig) nkd) + = do { (env1, pred') <- zonkTidyTcType env pred + ; return (env1, ScOrigin (IsQC pred' orig) nkd) } +zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act + , uo_expected = exp }) + = do { (env1, act') <- zonkTidyTcType env act + ; (env2, exp') <- zonkTidyTcType env1 exp + ; return ( env2, orig { uo_actual = act' + , uo_expected = exp' }) } +zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k) + = do { (env1, ty1') <- zonkTidyTcType env ty1 + ; (env2, ty2') <- zonkTidyTcType env1 ty2 + ; (env3, orig') <- zonkTidyOrigin env2 orig + ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } +zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) + = do { (env1, p1') <- zonkTidyTcType env p1 + ; (env2, o1') <- zonkTidyOrigin env1 o1 + ; (env3, p2') <- zonkTidyTcType env2 p2 + ; (env4, o2') <- zonkTidyOrigin env3 o2 + ; return (env4, FunDepOrigin1 p1' o1' l1 p2' o2' l2) } +zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) + = do { (env1, p1') <- zonkTidyTcType env p1 + ; (env2, p2') <- zonkTidyTcType env1 p2 + ; (env3, o1') <- zonkTidyOrigin env2 o1 + ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } +zonkTidyOrigin env (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) + = do { (env1, pred1') <- zonkTidyTcType env pred1 + ; (env2, orig1') <- zonkTidyOrigin env1 orig1 + ; (env3, pred2') <- zonkTidyTcType env2 pred2 + ; (env4, orig2') <- zonkTidyOrigin env3 orig2 + ; return (env4, InjTFOrigin1 pred1' orig1' loc1 pred2' orig2' loc2) } +zonkTidyOrigin env (CycleBreakerOrigin orig) + = do { (env1, orig') <- zonkTidyOrigin env orig + ; return (env1, CycleBreakerOrigin orig') } +zonkTidyOrigin env (InstProvidedOrigin mod cls_inst) + = do { (env1, is_tys') <- mapAccumLM zonkTidyTcType env (is_tys cls_inst) + ; return (env1, InstProvidedOrigin mod (cls_inst {is_tys = is_tys'})) } +zonkTidyOrigin env (WantedSuperclassOrigin pty orig) + = do { (env1, pty') <- zonkTidyTcType env pty + ; (env2, orig') <- zonkTidyOrigin env1 orig + ; return (env2, WantedSuperclassOrigin pty' orig') } +zonkTidyOrigin env orig = return (env, orig) + +zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> ZonkM (TidyEnv, [CtOrigin]) +zonkTidyOrigins = mapAccumLM zonkTidyOrigin + +zonkTidyFRRInfos :: TidyEnv + -> [FixedRuntimeRepErrorInfo] + -> ZonkM (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 + , frr_info_other_origin = mb_other_orig + } : tys) + = do { (env, ty) <- zonkTidyTcType env ty + ; (env, mb_not_conc) <- go_mb_not_conc env mb_not_conc + ; (env, mb_other_orig) <- + case mb_other_orig of + Nothing -> return (env, Nothing) + Just o -> do { (env', o') <- zonkTidyOrigin env o; return (env', Just o') } + ; let info = FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig + , frr_info_not_concrete = mb_not_conc + , frr_info_other_origin = mb_other_orig } + ; 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 $ tidyFreeTyCoVarX env tv + ; (env, ty) <- zonkTidyTcType env ty + ; return (env, Just (tv, ty)) } + +---------------- +tidyCt :: TidyEnv -> Ct -> Ct +-- Used only in error reporting +tidyCt env = updCtEvidence (tidyCtEvidence env) + +tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence + -- NB: we do not tidy the ctev_evar field because we don't + -- show it in error messages +tidyCtEvidence env ctev + = setCtEvPredType ctev (tidyOpenType env (ctEvPred ctev)) + -- tidyOpenType: for (beta ~ (forall a. a->a), don't gratuitously + -- rename the 'forall a' just because of an 'a' in scope somewhere + -- else entirely. + +tidyHole :: TidyEnv -> Hole -> Hole +tidyHole env h@(Hole { hole_ty = ty }) + = h { hole_ty = tidyOpenType env ty } + -- tidyOpenType: for, say, (b -> (forall a. a->a)), don't gratuitously + -- rename the 'forall a' just because of an 'a' in scope somewhere + -- else entirely. + +tidyDelayedError :: TidyEnv -> DelayedError -> DelayedError +tidyDelayedError env (DE_Hole hole) = DE_Hole $ tidyHole env hole +tidyDelayedError env (DE_NotConcrete err) = DE_NotConcrete $ tidyConcreteError env err +tidyDelayedError env (DE_Multiplicity mult_co loc) + = DE_Multiplicity (tidyCo env mult_co) loc + +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 + -- No need for tidyOpenType because all the free tyvars are already tidied + +---------------- +tidyEvVar :: TidyEnv -> EvVar -> EvVar +tidyEvVar env var = updateIdTypeAndMult (tidyType env) var + -- No need for tidyOpenType because all the free tyvars are already tidied diff --git a/GHC/Tc/Zonk/Type.hs b/GHC/Tc/Zonk/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Zonk/Type.hs @@ -0,0 +1,1954 @@ +{-# LANGUAGE GADTs #-} + +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 +-} + +-- | Final zonking to 'Type'. See Note [Zonking to Type]. +-- +-- Distinct from the intra-typechecker zonking in "GHC.Tc.Zonk.TcType"; +-- see Note [Module structure for zonking]. +module GHC.Tc.Zonk.Type ( + -- * Zonking + -- | For a description of "zonking", see Note [What is zonking?]. + ZonkTcM, + zonkTopDecls, zonkTopExpr, zonkTopLExpr, + zonkTopBndrs, + zonkTyVarBindersX, zonkTyVarBinderX, + zonkTyBndrX, zonkTyBndrsX, + zonkTcTypeToType, zonkTcTypeToTypeX, + zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, + zonkTyVarOcc, + zonkCoToCo, + zonkEvBinds, zonkTcEvBinds, + zonkTcMethInfoToMethInfoX, + lookupTyVarX, + + -- ** 'ZonkEnv', and the 'ZonkT' and 'ZonkBndrT' monad transformers + module GHC.Tc.Zonk.Env, + + -- * Tidying + tcInitTidyEnv, tcInitOpenTidyEnv, + + + ) where + +import GHC.Prelude + +import GHC.Builtin.Types + +import GHC.Core.TyCo.Ppr ( pprTyVar ) + +import GHC.Hs + +import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.TcRef +import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) +import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr ) +import GHC.Tc.Types.Evidence +import GHC.Tc.Errors.Types +import GHC.Tc.Zonk.Env +-- Very little shared code between GHC.Tc.Zonk.TcType and GHC.Tc.Zonk.Type. +-- See Note [Module structure for zonking] +import GHC.Tc.Zonk.TcType + ( tcInitTidyEnv, tcInitOpenTidyEnv + , writeMetaTyVarRef + , checkCoercionHole + , zonkCoVar ) + +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCon + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Panic + +import GHC.Core.Multiplicity +import GHC.Core +import GHC.Core.Predicate + +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Types.TypeEnv +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM +import GHC.Types.TyThing + +import GHC.Tc.Types.BasicTypes + +import GHC.Data.Maybe +import GHC.Data.Bag + +import Control.Monad +import Control.Monad.Trans.Class ( lift ) +import Data.List.NonEmpty ( NonEmpty ) +import Data.Foldable ( toList ) + +{- Note [What is zonking?] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC relies heavily on mutability in the typechecker for efficient operation. +For this reason, throughout much of the type checking process, meta type +variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable +variables (known as TcRefs). + +Zonking is the process of replacing each such mutable variable with a Type. +This involves traversing the entire type expression, but the interesting part, +replacing the mutable variables, occurs in zonkTyVarOcc. + +There are two ways to zonk a Type, using one of two entirely separate zonkers, +that share essentially no code: + +* GHC.Tc.Zonk.TcType.zonkTcType, which is used /during/ type checking: + * It leaves unfilled metavars untouched, so the resulting Type can contain TcTyVars + * It is only defined for Type and Coercion, not for HsExpr + * It works in a very stripped-down monad, ZonkM, make it clear that it uses + very few effects (for example, it can't throw errors). + +* GHC.Tc.Zonk.Type.zonkTcTypeToType, is used /after/ typechecking is complete: + * It always returns a Type with no remaining TcTyVars; no meta-tyvars remain. + * It does defaulting, replacing an unconstrained TcTyVar with Any, or failing + (determined by the ZonkFlexi parameter used; see GHC.Tc.Zonk.Type.commitFlexi). + * It works over HsExpr and HsBinds as well as Type and Coercion. As part of this, + it also removes the mutable variables in evidence bindings. + * It works in the full TcM monad, augmented with an environment. + More precisely, it uses ZonkTcM and ZonkBndrTcM, which augment TcM with a + ZonkEnv environment using the zonking monad transformers ZonkT and ZonkBndrT + (see Note [The ZonkEnv] in GHC.Tc.Zonk.Env). + + Why TcM rather than a smaller monad? See Note [Using TcM for zonking to Type]. + +Note [Module structure for zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As remarked in Note [What is zonking?], there are really two different zonkers; +we have GHC.Tc.Zonk.TcType for zonking within the typechecker and +GHC.Tc.Zonk.Type for the final zonking pass. + +The code relating to zonking is thus split up across the following modules: + + I. Zonking within the typechecker + 1. GHC.Tc.Zonk.Monad + 2. GHC.Tc.Zonk.TcType + + II. Final zonking to Type + 1. GHC.Tc.Zonk.Env + 2. GHC.Tc.Zonk.Type + +I.1. GHC.Tc.Zonk.Monad - the ZonkM monad + + GHC.Tc.Zonk.Monad defines the ZonkM monad, which is a stripped down version + of TcM which has just enough information to be able to zonk types. + + This is the monad used for zonking inside the typechecker, + as used in GHC.Tc.Zonk.TcType. + + Crucially, it never errors. It is the monad we use when reporting errors + (see ErrCtxt), and it would be quite bad if we could error in the middle + of reporting an error! + +I.2. GHC.Tc.Zonk.TcType - zonking types in the typechecker + + GHC.Tc.Zonk.TcType contains code for zonking types and constraints, for use + within the typechecker. It uses the ZonkM monad. + For example, it defines: + + zonkTcType :: TcType -> ZonkM TcType + zonkCt :: Ct -> ZonkM Ct + +II.1. GHC.Tc.Zonk.Env - the ZonkEnv and ZonkT/ZonkBndrT monad transformers + + GHC.Tc.Zonk.Env defines the the ZonkT and ZonkBndrT monad transformers. + These are essentially "ReaderT ZonkEnv" and "StateT ZonkEnv", except + that ZonkBndrT use continuation-passing style instead of an explicit state. + See Note [The ZonkEnv] in GHC.Tc.Zonk.Env. + + These are used for the final zonking to type, in GHC.Tc.Zonk.Type. + +II.2. GHC.Tc.Zonk.Type - final zonking to type + + GHC.Tc.Zonk.Type is concerned with the "final zonking" pass, after we finish + typechecking. It zonks not only types, but terms. It uses the monads + + type ZonkTcM = ZonkT TcM + type ZonkBndrTcM = ZonkBndrTcM + + for example: + + zonkTyBndrX :: TcTyVar -> ZonkBndrTcM TyVar + zonkTcTypeToTypeX :: TcType -> ZonkT TcM Type + +Note that ZonkTcM does a lot more things than ZonkM: + + - it uses a separate ZonkEnv state to accumulate zonked type + (see Note [The ZonkEnv] in GHC.Tc.Zonk.Env) + - it defaults type variables, + (see Note [Un-unified unification variables] in GHC.Tc.Zonk.Env) + - turns TcTyVars into TyVars, + - ... + +This means that there is essentially no code shared between "GHC.Tc.Zonk.TcType" +and "GHC.Tc.Zonk.Type'; they're really two different zonkers. + +Note [Zonking to Type] +~~~~~~~~~~~~~~~~~~~~~~ +Zonking to Type is a final zonking pass done *after* typechecking. +It runs over the bindings + + a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc + b) convert unbound TcTyVar to Void + c) convert each TcId to an Id by zonking its type + +The type variables are converted by binding mutable tyvars to immutable ones +and then zonking as normal. + +The Ids are converted by binding them in the normal Tc envt; that +way we maintain sharing; eg an Id is zonked at its binding site and they +all occurrences of that Id point to the common zonked copy + +It's all pretty boring stuff, because HsSyn is such a large type, and +the environment manipulation is tiresome. + +Note [Sharing when zonking to Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: + + In GHC.Tc.Zonk.TcType.zonkTcTyVar, we short-circuit (Indirect ty) to + (Indirect zty), see Note [Sharing in zonking] in GHC.Tc.Zonk.TcType. + But we /can't/ do this when zonking a TcType to a Type (#15552, esp comment:3). + Suppose we have + + alpha -> alpha + where + alpha is already unified: + alpha := T{tc-tycon} Int -> Int + and T is knot-tied + + By "knot-tied" I mean that the occurrence of T is currently a TcTyCon, + but the global env contains a mapping "T" :-> T{knot-tied-tc}. See + Note [Type checking recursive type and class declarations] in + GHC.Tc.TyCl. + + Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow + the same path as Note [Sharing in zonking] in GHC.Tc.Zonk.TcType, we'll + update alpha to + alpha := T{knot-tied-tc} Int -> Int + + But alas, if we encounter alpha for a /second/ time, we end up + looking at T{knot-tied-tc} and fall into a black hole. The whole + point of zonkTcTypeToType is that it produces a type full of + knot-tied tycons, and you must not look at the result!! + + To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not + the same as zonkTcTypeToType. (If we distinguished TcType from + Type, this issue would have been a type error!) + +Solutions: (see #15552 for other variants) + +One possible solution is simply not to do the short-circuiting. +That has less sharing, but maybe sharing is rare. And indeed, +that usually turns out to be viable from a perf point of view + +But zonkTyVarOcc implements something a bit better + +* ZonkEnv contains ze_meta_tv_env, which maps + from a MetaTyVar (unification variable) + to a Type (not a TcType) + +* In zonkTyVarOcc, we check this map to see if we have zonked + this variable before. If so, use the previous answer; if not + zonk it, and extend the map. + +* The map is of course stateful, held in a TcRef. (That is unlike + the treatment of lexically-scoped variables in ze_tv_env and + ze_id_env.) + +* In zonkTyVarOcc we read the TcRef to look up the unification + variable: + - if we get a hit we use the zonked result; + - if not, in zonk_meta we see if the variable is `Indirect ty`, + zonk that, and update the map (in finish_meta) + But Nota Bene that the "update map" step must re-read the TcRef + (or, more precisely, use updTcRef) because the zonking of the + `Indirect ty` may have added lots of stuff to the map. See + #19668 for an example where this made an asymptotic difference! + +Is it worth the extra work of carrying ze_meta_tv_env? Some +non-systematic perf measurements suggest that compiler allocation is +reduced overall (by 0.5% or so) but compile time really doesn't +change. But in some cases it makes a HUGE difference: see test +T9198 and #19668. So yes, it seems worth it. + +Note [Using TcM for zonking to Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The main zonking monads currently wrap TcM, because we need access to +the full TcM monad in order to expand typed TH splices. +See zonkExpr (HsTypedSplice s _) = ... + +After the Typed TH plan has been implemented, this should no longer be necessary, +and we should be able to use a stripped down monad, similar to the ZonkM monad +which we use for zonking within the typechecker (but we will need a place to +accumulate errors). + +Note [Inlining ZonkBndrT computations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Computations that use the ZonkBndrT monad transformer must be inlined: +ZonkBndrT uses continuation-passing style; failing to inline means applying +an unknown continuation (unknown function call), which prevents many +optimisations from taking place. + +See test cases T14683, which regresses without these changes. +-} + +-- Why do we use TcM below? See Note [Using TcM for zonking to Type] + +-- | Zonking monad for a computation that zonks to Type, reading from a 'ZonkEnv' +-- but not extending or modifying it. +-- +-- See Note [Zonking to Type]. +type ZonkTcM = ZonkT TcM + +-- | Zonking monad for a computation that zonks to Type, reading from +-- and extending or modifying a 'ZonkEnv'. +-- +-- See Note [Zonking to Type]. +type ZonkBndrTcM = ZonkBndrT TcM + +wrapLocZonkMA :: (a -> ZonkTcM b) -> GenLocated (EpAnn ann) a + -> ZonkTcM (GenLocated (EpAnn ann) b) +wrapLocZonkMA fn (L loc a) = ZonkT $ \ ze -> + setSrcSpanA loc $ + do { b <- runZonkT (fn a) ze + ; return (L loc b) } + +wrapLocZonkBndrMA :: (a -> ZonkBndrTcM b) -> GenLocated (EpAnn ann) a + -> ZonkBndrTcM (GenLocated (EpAnn ann) b) +wrapLocZonkBndrMA fn (L loc a) = ZonkBndrT $ \ k -> ZonkT $ \ ze -> + setSrcSpanA loc $ + runZonkT ( runZonkBndrT (fn a) $ \ b -> k (L loc b) ) ze + +-------------------------------------------------------------------------------- + +zonkTyBndrsX :: [TcTyVar] -> ZonkBndrTcM [TcTyVar] +zonkTyBndrsX = traverse zonkTyBndrX +{-# INLINE zonkTyBndrsX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyBndrX :: TcTyVar -> ZonkBndrTcM TyVar +-- This guarantees to return a TyVar (not a TcTyVar) +-- then we add it to the envt, so all occurrences are replaced +-- +-- It does not clone: the new TyVar has the sane Name +-- as the old one. This important when zonking the +-- TyVarBndrs of a TyCon, whose Names may scope. +zonkTyBndrX tv + = assertPpr (isImmutableTyVar tv) (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) $ + do { ki <- noBinders $ zonkTcTypeToTypeX (tyVarKind tv) + -- Internal names tidy up better, for iface files. + ; let tv' = mkTyVar (tyVarName tv) ki + ; extendTyZonkEnv tv' + ; return tv' } +{-# INLINE zonkTyBndrX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyVarBindersX :: [VarBndr TcTyVar vis] + -> ZonkBndrTcM [VarBndr TyVar vis] +zonkTyVarBindersX = traverse zonkTyVarBinderX +{-# INLINE zonkTyVarBindersX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyVarBinderX :: VarBndr TcTyVar vis + -> ZonkBndrTcM (VarBndr TyVar vis) +-- Takes a TcTyVar and guarantees to return a TyVar +zonkTyVarBinderX (Bndr tv vis) + = do { tv' <- zonkTyBndrX tv + ; return (Bndr tv' vis) } +{-# INLINE zonkTyVarBinderX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyVarOcc :: HasDebugCallStack => TcTyVar -> ZonkTcM Type +zonkTyVarOcc tv + = do { ZonkEnv { ze_tv_env = tv_env, ze_flexi = zonk_flexi } <- getZonkEnv + + ; let lookup_in_tv_env -- Look up in the env just as we do for Ids + = case lookupVarEnv tv_env tv of + Nothing -> -- TyVar/SkolemTv/RuntimeUnk that isn't in the ZonkEnv + -- This can happen for RuntimeUnk variables (which + -- should stay as RuntimeUnk), but I think it should + -- not happen for SkolemTv. + mkTyVarTy <$> updateTyVarKindM zonkTcTypeToTypeX tv + + Just tv' -> return (mkTyVarTy tv') + + zonk_meta ref Flexi + = do { kind <- zonkTcTypeToTypeX (tyVarKind tv) + ; ty <- lift $ commitFlexi zonk_flexi tv kind + + ; lift $ liftZonkM $ writeMetaTyVarRef tv ref ty -- Belt and braces + ; finish_meta ty } + + zonk_meta _ (Indirect ty) + = do { zty <- zonkTcTypeToTypeX ty + ; finish_meta zty } + + finish_meta ty + = do { extendMetaEnv tv ty + ; return ty } + + ; if isTcTyVar tv + then case tcTyVarDetails tv of + SkolemTv {} -> lookup_in_tv_env + RuntimeUnk {} -> lookup_in_tv_env + MetaTv { mtv_ref = ref } + -> do { mb_ty <- lookupMetaTv tv + -- See Note [Sharing when zonking to Type] + ; case mb_ty of + Just ty -> return ty + Nothing -> do { mtv_details <- readTcRef ref + ; zonk_meta ref mtv_details } } + + -- This should never really happen; + -- TyVars should not occur in the typechecker + else lookup_in_tv_env } + +extendMetaEnv :: TcTyVar -> Type -> ZonkTcM () +extendMetaEnv tv ty = + ZonkT $ \ ( ZonkEnv { ze_meta_tv_env = mtv_env_ref } ) -> + updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty) + +lookupMetaTv :: TcTyVar -> ZonkTcM (Maybe Type) +lookupMetaTv tv = + ZonkT $ \ ( ZonkEnv { ze_meta_tv_env = mtv_env_ref } ) -> + do { mtv_env <- readTcRef mtv_env_ref + ; return $ lookupVarEnv mtv_env tv } + +lookupTyVarX :: TcTyVar -> ZonkTcM TyVar +lookupTyVarX tv + = do { ZonkEnv { ze_tv_env = tv_env } <- getZonkEnv + ; let !res = case lookupVarEnv tv_env tv of + Just tv -> tv + Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env) + ; return res } + +commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type +commitFlexi NoFlexi tv zonked_kind + = pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind) + +commitFlexi (SkolemiseFlexi tvs_ref) tv zonked_kind + = do { let skol_tv = mkTyVar (tyVarName tv) zonked_kind + ; updTcRef tvs_ref (skol_tv :) + ; return (mkTyVarTy skol_tv) } + +commitFlexi RuntimeUnkFlexi tv zonked_kind + = do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv) + ; return (mkTyVarTy (mkTcTyVar (tyVarName tv) zonked_kind RuntimeUnk)) } + -- This is where RuntimeUnks are born: + -- otherwise-unconstrained unification variables are + -- turned into RuntimeUnks as they leave the + -- typechecker's monad + +commitFlexi DefaultFlexi tv zonked_kind + -- Normally, RuntimeRep variables are defaulted in GHC.Tc.Utils.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 } + | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv + = do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin) + ; return (anyTypeOfKind zonked_kind) } + | otherwise + = do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv) + -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4) + ; newZonkAnyType zonked_kind } + +zonkCoVarOcc :: CoVar -> ZonkTcM Coercion +zonkCoVarOcc cv + = do { ZonkEnv { ze_tv_env = tyco_env } <- getZonkEnv + -- don't look in the knot-tied env + ; case lookupVarEnv tyco_env cv of + Just cv' -> return $ mkCoVarCo cv' + _ -> mkCoVarCo <$> (lift $ liftZonkM $ zonkCoVar cv) } + +zonkCoHole :: CoercionHole -> ZonkTcM Coercion +zonkCoHole hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) + = do { contents <- readTcRef ref + ; case contents of + Just co -> do { co' <- zonkCoToCo co + ; lift $ liftZonkM $ checkCoercionHole cv co' } + + -- This next case should happen only in the presence of + -- (undeferred) type errors. Originally, I put in a panic + -- here, but that caused too many uses of `failIfErrsM`. + Nothing -> do { lift $ traceTc "Zonking unfilled coercion hole" (ppr hole) + ; cv' <- lift $ liftZonkM $ zonkCoVar cv + ; return $ mkCoVarCo cv' } } + -- This will be an out-of-scope variable, but keeping + -- this as a coercion hole led to #15787 + +zonk_tycomapper :: TyCoMapper ZonkEnv TcM +zonk_tycomapper = TyCoMapper + { tcm_tyvar = \ env tv -> runZonkT (zonkTyVarOcc tv) env + , tcm_covar = \ env cv -> runZonkT (zonkCoVarOcc cv) env + , tcm_hole = \ env co -> runZonkT (zonkCoHole co) env + , tcm_tycobinder = \ env tcv _vis k -> flip runZonkT env $ + runZonkBndrT (zonkTyBndrX tcv) $ + \ tcv' -> ZonkT $ \ env' -> (k env' tcv') + , tcm_tycon = \ tc -> zonkTcTyConToTyCon tc + } + +-- Zonk a TyCon by changing a TcTyCon to a regular TyCon +zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon +zonkTcTyConToTyCon tc + | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc) + ; case thing of + ATyCon real_tc -> return real_tc + _ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) } + | otherwise = return tc -- it's already zonked + +-- | Confused by zonking? See Note [What is zonking?] in "GHC.Tc.Zonk.Type". +zonkTcTypeToType :: TcType -> TcM Type +zonkTcTypeToType ty = initZonkEnv DefaultFlexi $ zonkTcTypeToTypeX ty + +zonkScaledTcTypeToTypeX :: Scaled TcType -> ZonkTcM (Scaled TcType) +zonkScaledTcTypeToTypeX (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX m + <*> zonkTcTypeToTypeX ty + +zonkTcTypeToTypeX :: TcType -> ZonkTcM Type +zonkTcTypesToTypesX :: [TcType] -> ZonkTcM [Type] +zonkCoToCo :: Coercion -> ZonkTcM Coercion +(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo) + = case mapTyCoX zonk_tycomapper of + (zty, ztys, zco, _) -> + (ZonkT . flip zty, ZonkT . flip ztys, ZonkT . flip zco) + +zonkScaledTcTypesToTypesX :: [Scaled TcType] -> ZonkTcM [Scaled Type] +zonkScaledTcTypesToTypesX scaled_tys = + mapM zonkScaledTcTypeToTypeX scaled_tys + + +zonkEnvIds :: ZonkEnv -> TypeEnv +zonkEnvIds (ZonkEnv { ze_id_env = id_env }) + = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env] + -- It's OK to use nonDetEltsUFM here because we forget the ordering + -- immediately by creating a TypeEnv + +zonkLIdOcc :: LocatedN TcId -> ZonkTcM (LocatedN Id) +zonkLIdOcc = traverse zonkIdOcc + +zonkIdOcc :: TcId -> ZonkTcM Id +-- Ids defined in this module should be in the envt; +-- ignore others. (Actually, data constructors are also +-- not LocalVars, even when locally defined, but that is fine.) +-- (Also foreign-imported things aren't currently in the ZonkEnv; +-- that's ok because they don't need zonking.) +-- +-- Actually, Template Haskell works in 'chunks' of declarations, and +-- an earlier chunk won't be in the 'env' that the zonking phase +-- carries around. Instead it'll be in the tcg_gbl_env, already fully +-- zonked. There's no point in looking it up there (except for error +-- checking), and it's not conveniently to hand; hence the simple +-- 'orElse' case in the LocalVar branch. +-- +-- Even without template splices, in module Main, the checking of +-- 'main' is done as a separate chunk. +zonkIdOcc id + | isLocalVar id = + do { ZonkEnv { ze_id_env = id_env } <- getZonkEnv + ; return $ lookupVarEnv id_env id `orElse` id } + | otherwise + = return id + +zonkIdOccs :: [TcId] -> ZonkTcM [Id] +zonkIdOccs ids = traverse zonkIdOcc ids + +-- zonkIdBndr is used *after* typechecking to get the Id's type +-- to its final form. The TyVarEnv give +zonkIdBndrX :: TcId -> ZonkBndrTcM Id +zonkIdBndrX v + = do { id <- noBinders $ zonkIdBndr v + ; extendIdZonkEnv id + ; return id } +{-# INLINE zonkIdBndrX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkIdBndr :: TcId -> ZonkTcM Id +zonkIdBndr v + = do { Scaled w' ty' <- zonkScaledTcTypeToTypeX (idScaledType v) + ; return $ setIdMult (setIdType v ty') w' } + +zonkIdBndrs :: [TcId] -> ZonkTcM [Id] +zonkIdBndrs ids = mapM zonkIdBndr ids + +zonkTopBndrs :: [TcId] -> TcM [Id] +zonkTopBndrs ids = initZonkEnv DefaultFlexi $ zonkIdBndrs ids + +zonkFieldOcc :: FieldOcc GhcTc -> ZonkTcM (FieldOcc GhcTc) +zonkFieldOcc (FieldOcc lbl (L l sel)) + = FieldOcc lbl . L l <$> zonkIdBndr sel + +zonkEvBndrsX :: [EvVar] -> ZonkBndrTcM [EvVar] +zonkEvBndrsX = traverse zonkEvBndrX +{-# INLINE zonkEvBndrsX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkEvBndrX :: EvVar -> ZonkBndrTcM EvVar +-- Works for dictionaries and coercions +zonkEvBndrX var + = do { var' <- noBinders $ zonkEvBndr var + ; extendZonkEnv [var'] + ; return var' } +{-# INLINE zonkEvBndr #-} -- See Note [Inlining ZonkBndrT computations] + +zonkEvBndr :: EvVar -> ZonkTcM EvVar +-- Works for dictionaries and coercions +-- Does not extend the ZonkEnv +zonkEvBndr var + = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX) var + +{- +zonkEvVarOcc :: EvVar -> ZonkTcM EvTerm +zonkEvVarOcc env v + | isCoVar v + = EvCoercion <$> zonkCoVarOcc env v + | otherwise + = return (EvId $ zonkIdOcc env v) +-} + +zonkCoreBndrX :: Var -> ZonkBndrTcM Var +zonkCoreBndrX v + | isId v = zonkIdBndrX v + | otherwise = zonkTyBndrX v +{-# INLINE zonkCoreBndrX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkCoreBndrsX :: [Var] -> ZonkBndrTcM [Var] +zonkCoreBndrsX = traverse zonkCoreBndrX +{-# INLINE zonkCoreBndrsX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc) +zonkTopExpr e = initZonkEnv DefaultFlexi $ zonkExpr e + +zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc) +zonkTopLExpr e = initZonkEnv DefaultFlexi $ zonkLExpr e + +zonkTopDecls :: Bag EvBind + -> LHsBinds GhcTc + -> [LRuleDecl GhcTc] -> [LTcSpecPrag] + -> [LForeignDecl GhcTc] + -> TcM (TypeEnv, + Bag EvBind, + LHsBinds GhcTc, + [LForeignDecl GhcTc], + [LTcSpecPrag], + [LRuleDecl GhcTc]) +zonkTopDecls ev_binds binds rules imp_specs fords + = initZonkEnv DefaultFlexi $ + runZonkBndrT (zonkEvBinds ev_binds) $ \ ev_binds' -> + runZonkBndrT (zonkRecMonoBinds binds) $ \ binds' -> + -- Top level is implicitly recursive + do { rules' <- zonkRules rules + ; specs' <- zonkLTcSpecPrags imp_specs + ; fords' <- zonkForeignExports fords + ; ty_env <- zonkEnvIds <$> getZonkEnv + ; return (ty_env, ev_binds', binds', fords', specs', rules') } + + +--------------------------------------------- +zonkLocalBinds :: HsLocalBinds GhcTc + -> ZonkBndrTcM (HsLocalBinds GhcTc) +zonkLocalBinds (EmptyLocalBinds x) + = return (EmptyLocalBinds x) + +zonkLocalBinds (HsValBinds _ (ValBinds {})) + = panic "zonkLocalBinds" -- Not in typechecker output + +zonkLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) + = do { new_binds <- traverse go binds + ; return (HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) } + where + go (r,b) + = do { b' <- zonkRecMonoBinds b + ; return (r,b') } + +zonkLocalBinds (HsIPBinds x (IPBinds dict_binds binds )) = do + new_binds <- noBinders $ mapM (wrapLocZonkMA zonk_ip_bind) binds + extendIdZonkEnvRec [ n | (L _ (IPBind n _ _)) <- new_binds] + new_dict_binds <- zonkTcEvBinds dict_binds + return $ HsIPBinds x (IPBinds new_dict_binds new_binds) + where + zonk_ip_bind (IPBind dict_id n e) + = do dict_id' <- zonkIdBndr dict_id + e' <- zonkLExpr e + return (IPBind dict_id' n e') + +--------------------------------------------- +zonkRecMonoBinds :: LHsBinds GhcTc -> ZonkBndrTcM (LHsBinds GhcTc) +zonkRecMonoBinds binds + = mfix $ \ new_binds -> + do { extendIdZonkEnvRec (collectHsBindsBinders CollNoDictBinders new_binds) + ; noBinders $ zonkMonoBinds binds } + +--------------------------------------------- +zonkMonoBinds :: LHsBinds GhcTc -> ZonkTcM (LHsBinds GhcTc) +zonkMonoBinds binds = mapM zonk_lbind binds + +zonk_lbind :: LHsBind GhcTc -> ZonkTcM (LHsBind GhcTc) +zonk_lbind = wrapLocZonkMA zonk_bind + +zonk_bind :: HsBind GhcTc -> ZonkTcM (HsBind GhcTc) +zonk_bind bind@(PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_mult = mult_ann + , pat_ext = (ty, ticks)}) + = do { new_pat <- don'tBind $ zonkPat pat -- Env already extended + ; new_grhss <- zonkGRHSs zonkLExpr grhss + ; new_ty <- zonkTcTypeToTypeX ty + ; new_mult <- zonkMultAnn mult_ann + ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss + , pat_mult = new_mult + , pat_ext = (new_ty, ticks) }) } + +zonk_bind (VarBind { var_ext = x + , var_id = var, var_rhs = expr }) + = do { new_var <- zonkIdBndr var + ; new_expr <- zonkLExpr expr + ; return (VarBind { var_ext = x + , var_id = new_var + , var_rhs = new_expr }) } + +zonk_bind bind@(FunBind { fun_id = L loc var + , fun_matches = ms + , fun_ext = (co_fn, ticks) }) + = do { new_var <- zonkIdBndr var + ; runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn -> + do { new_ms <- zonkMatchGroup zonkLExpr ms + ; return (bind { fun_id = L loc new_var + , fun_matches = new_ms + , fun_ext = (new_co_fn, ticks) }) } } + +zonk_bind (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 ) $ + runZonkBndrT (zonkTyBndrsX tyvars ) $ \ new_tyvars -> + runZonkBndrT (zonkEvBndrsX evs ) $ \ new_evs -> + runZonkBndrT (zonkTcEvBinds_s ev_binds) $ \ new_ev_binds -> + do { (new_val_bind, new_exports) <- mfix $ \ ~(new_val_binds, new_exports) -> + let new_bndrs = collectHsBindsBinders CollNoDictBinders new_val_binds + ++ map abe_poly new_exports + -- Tie the knot with the `abe_poly` binders too, since they + -- may be mentioned in the `abe_prags` of the `exports` + in runZonkBndrT (extendIdZonkEnvRec new_bndrs) $ \ _ -> + do { new_val_binds <- mapM zonk_val_bind val_binds + ; new_exports <- mapM zonk_export exports + ; return (new_val_binds, new_exports) + } + ; return $ XHsBindsLR $ + AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs + , abs_ev_binds = new_ev_binds + , abs_exports = new_exports, abs_binds = new_val_bind + , abs_sig = has_sig } } + where + zonk_val_bind lbind + | has_sig + , (L loc bind@(FunBind { fun_id = (L mloc mono_id) + , fun_matches = ms + , fun_ext = (co_fn, ticks) })) <- lbind + = do { new_mono_id <- updateIdTypeAndMultM zonkTcTypeToTypeX mono_id + -- Specifically /not/ zonkIdBndr; we do not want to + -- complain about a representation-polymorphic binder + ; runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn -> + do { new_ms <- zonkMatchGroup zonkLExpr ms + ; return $ L loc $ + bind { fun_id = L mloc new_mono_id + , fun_matches = new_ms + , fun_ext = (new_co_fn, ticks) } } } + | otherwise + = zonk_lbind lbind -- The normal case + + zonk_export :: ABExport -> ZonkTcM ABExport + zonk_export (ABE{ abe_wrap = wrap + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = prags }) + = do new_poly_id <- zonkIdBndr poly_id + new_wrap <- don'tBind $ zonkCoFn wrap + new_prags <- zonkSpecPrags prags + new_mono_id <- zonkIdOcc mono_id + return (ABE{ abe_wrap = new_wrap + , abe_poly = new_poly_id + , abe_mono = new_mono_id + , abe_prags = new_prags }) + +zonk_bind (PatSynBind x bind@(PSB { psb_id = L loc id + , psb_args = details + , psb_def = lpat + , psb_dir = dir })) + = do { id' <- zonkIdBndr id + ; runZonkBndrT (zonkPat lpat) $ \ lpat' -> + do { details' <- zonkPatSynDetails details + ; dir' <- zonkPatSynDir dir + ; return $ PatSynBind x $ + bind { psb_id = L loc id' + , psb_args = details' + , psb_def = lpat' + , psb_dir = dir' } } } + +zonkMultAnn :: HsMultAnn GhcTc -> ZonkTcM (HsMultAnn GhcTc) +zonkMultAnn (HsUnannotated mult) + = do { mult' <- zonkTcTypeToTypeX mult + ; return (HsUnannotated mult') } +zonkMultAnn (HsLinearAnn mult) + = do { mult' <- zonkTcTypeToTypeX mult + ; return (HsLinearAnn mult') } +zonkMultAnn (HsExplicitMult mult hs_ty) + = do { mult' <- zonkTcTypeToTypeX mult + ; return (HsExplicitMult mult' hs_ty) } + +zonkPatSynDetails :: HsPatSynDetails GhcTc + -> ZonkTcM (HsPatSynDetails GhcTc) +zonkPatSynDetails (PrefixCon as) + = PrefixCon <$> traverse zonkLIdOcc as +zonkPatSynDetails (InfixCon a1 a2) + = InfixCon <$> zonkLIdOcc a1 <*> zonkLIdOcc a2 +zonkPatSynDetails (RecCon flds) + = RecCon <$> mapM zonkPatSynField flds + +zonkPatSynField :: RecordPatSynField GhcTc -> ZonkTcM (RecordPatSynField GhcTc) +zonkPatSynField (RecordPatSynField x y) = + RecordPatSynField <$> zonkFieldOcc x <*> zonkLIdOcc y + +zonkPatSynDir :: HsPatSynDir GhcTc + -> ZonkTcM (HsPatSynDir GhcTc) +zonkPatSynDir Unidirectional = return Unidirectional +zonkPatSynDir ImplicitBidirectional = return ImplicitBidirectional +zonkPatSynDir (ExplicitBidirectional mg) = ExplicitBidirectional <$> zonkMatchGroup zonkLExpr mg + +zonkSpecPrags :: TcSpecPrags -> ZonkTcM TcSpecPrags +zonkSpecPrags IsDefaultMethod = return IsDefaultMethod +zonkSpecPrags (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags ps + ; return (SpecPrags ps') } + +zonkLTcSpecPrags :: [LTcSpecPrag] -> ZonkTcM [LTcSpecPrag] +zonkLTcSpecPrags ps + = mapM zonk_prag ps + where + zonk_prag (L loc (SpecPrag id co_fn inl)) + = do { co_fn' <- don'tBind $ zonkCoFn co_fn + ; id' <- zonkIdOcc id + ; return (L loc (SpecPrag id' co_fn' inl)) } + zonk_prag (L loc prag@(SpecPragE { spe_fn_id = poly_id + , spe_bndrs = bndrs + , spe_call = spec_e })) + = do { poly_id' <- zonkIdOcc poly_id + + ; skol_tvs_ref <- lift $ newTcRef [] + ; setZonkType (SkolemiseFlexi skol_tvs_ref) $ + -- SkolemiseFlexi: see Note [Free tyvars on rule LHS] + + runZonkBndrT (zonkCoreBndrsX bndrs) $ \ bndrs' -> + do { spec_e' <- zonkLExpr spec_e + ; skol_tvs <- lift $ readTcRef skol_tvs_ref + ; return (L loc (prag { spe_fn_id = poly_id' + , spe_bndrs = skol_tvs ++ bndrs' + , spe_call = spec_e' + })) + }} + +{- +************************************************************************ +* * +\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} +* * +************************************************************************ +-} + +zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> MatchGroup GhcTc (LocatedA (body GhcTc)) + -> ZonkTcM (MatchGroup GhcTc (LocatedA (body GhcTc))) +zonkMatchGroup zBody (MG { mg_alts = L l ms + , mg_ext = MatchGroupTc arg_tys res_ty origin + }) + = do { ms' <- mapM (zonkMatch zBody) ms + ; arg_tys' <- zonkScaledTcTypesToTypesX arg_tys + ; res_ty' <- zonkTcTypeToTypeX res_ty + ; return (MG { mg_alts = L l ms' + , mg_ext = MatchGroupTc arg_tys' res_ty' origin + }) } + +zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> LMatch GhcTc (LocatedA (body GhcTc)) + -> ZonkTcM (LMatch GhcTc (LocatedA (body GhcTc))) +zonkMatch zBody (L loc match@(Match { m_pats = L l pats + , m_grhss = grhss })) + = runZonkBndrT (zonkPats pats) $ \ new_pats -> + do { new_grhss <- zonkGRHSs zBody grhss + ; return (L loc (match { m_pats = L l new_pats, m_grhss = new_grhss })) } + +------------------------------------------------------------------------- +zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> GRHSs GhcTc (LocatedA (body GhcTc)) + -> ZonkTcM (GRHSs GhcTc (LocatedA (body GhcTc))) + +zonkGRHSs zBody (GRHSs x grhss binds) = + runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> + do { new_grhss <- mapM (wrapLocZonkMA zonk_grhs) grhss + ; return (GRHSs x new_grhss new_binds) } + where + zonk_grhs (GRHS xx guarded rhs) = + runZonkBndrT (zonkStmts zonkLExpr guarded) $ \ new_guarded -> + GRHS xx new_guarded <$> zBody rhs + +{- +************************************************************************ +* * +\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} +* * +************************************************************************ +-} + +zonkLExprs :: [LHsExpr GhcTc] -> ZonkTcM [LHsExpr GhcTc] +zonkLExpr :: LHsExpr GhcTc -> ZonkTcM (LHsExpr GhcTc) +zonkExpr :: HsExpr GhcTc -> ZonkTcM (HsExpr GhcTc) + +zonkLExprs exprs = mapM zonkLExpr exprs +zonkLExpr expr = wrapLocZonkMA zonkExpr expr + +zonkExpr (HsVar x (L l id)) + = assertPpr (isNothing (isDataConId_maybe id)) (ppr id) $ + do { id' <- zonkIdOcc id + ; return (HsVar x (L l id')) } + +zonkExpr (HsHole (h, her)) + = do her' <- zonk_her her + return (HsHole (h, her')) + where + zonk_her :: HoleExprRef -> ZonkTcM HoleExprRef + zonk_her (HER ref ty u) + = do updTcRefM ref zonkEvTerm + ty' <- zonkTcTypeToTypeX ty + return (HER ref ty' u) + +zonkExpr (HsIPVar x _) = dataConCantHappen x + +zonkExpr (HsOverLabel x _) = dataConCantHappen x + +zonkExpr (HsLit x (XLit (HsRat f ty))) + = do new_ty <- zonkTcTypeToTypeX ty + return (HsLit x (XLit $ HsRat f new_ty)) + +zonkExpr (HsLit x lit) + = return (HsLit x lit) + +zonkExpr (HsOverLit x lit) + = do { lit' <- zonkOverLit lit + ; return (HsOverLit x lit') } + +zonkExpr (HsLam x lam_variant matches) + = do new_matches <- zonkMatchGroup zonkLExpr matches + return (HsLam x lam_variant new_matches) + +zonkExpr (HsApp x e1 e2) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + return (HsApp x new_e1 new_e2) + +zonkExpr (HsAppType ty e t) + = do new_e <- zonkLExpr e + new_ty <- zonkTcTypeToTypeX ty + return (HsAppType new_ty new_e t) + -- NB: the type is an HsType; can't zonk that! + +zonkExpr (HsTypedBracket hsb_tc body) + = (\x -> HsTypedBracket x body) <$> zonkBracket hsb_tc + +zonkExpr (HsUntypedBracket hsb_tc body) + = (\x -> HsUntypedBracket x body) <$> zonkBracket hsb_tc + +zonkExpr (HsTypedSplice s _) = ZonkT (\ _ -> runTopSplice s) >>= zonkExpr + +zonkExpr (HsUntypedSplice x _) = dataConCantHappen x + +zonkExpr (OpApp x _ _ _) = dataConCantHappen x + +zonkExpr (NegApp x expr op) + = runZonkBndrT (zonkSyntaxExpr op) $ \ new_op -> + do { new_expr <- zonkLExpr expr + ; return (NegApp x new_expr new_op) } + +zonkExpr (HsPar x e) + = do { new_e <- zonkLExpr e + ; return (HsPar x new_e) } + +zonkExpr (SectionL x _ _) = dataConCantHappen x +zonkExpr (SectionR x _ _) = dataConCantHappen x +zonkExpr (ExplicitTuple x tup_args boxed) + = do { new_tup_args <- mapM zonk_tup_arg tup_args + ; return (ExplicitTuple x new_tup_args boxed) } + where + zonk_tup_arg (Present x e) = do { e' <- zonkLExpr e + ; return (Present x e') } + zonk_tup_arg (Missing t) = do { t' <- zonkScaledTcTypeToTypeX t + ; return (Missing t') } + + +zonkExpr (ExplicitSum args alt arity expr) + = do new_args <- mapM zonkTcTypeToTypeX args + new_expr <- zonkLExpr expr + return (ExplicitSum new_args alt arity new_expr) + +zonkExpr (HsCase x expr ms) + = do new_expr <- zonkLExpr expr + new_ms <- zonkMatchGroup zonkLExpr ms + return (HsCase x new_expr new_ms) + +zonkExpr (HsIf x e1 e2 e3) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + new_e3 <- zonkLExpr e3 + return (HsIf x new_e1 new_e2 new_e3) + +zonkExpr (HsMultiIf ty alts) + = do { alts' <- mapM (wrapLocZonkMA zonk_alt) alts + ; ty' <- zonkTcTypeToTypeX ty + ; return $ HsMultiIf ty' alts' } + where zonk_alt (GRHS x guard expr) + = runZonkBndrT (zonkStmts zonkLExpr guard) $ \ guard' -> + do { expr' <- zonkLExpr expr + ; return $ GRHS x guard' expr' } + +zonkExpr (HsLet x binds expr) + = runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> + do { new_expr <- zonkLExpr expr + ; return (HsLet x new_binds new_expr) } + +zonkExpr (HsDo ty do_or_lc (L l stmts)) + = do new_stmts <- don'tBind $ zonkStmts zonkLExpr stmts + new_ty <- zonkTcTypeToTypeX ty + return (HsDo new_ty do_or_lc (L l new_stmts)) + +zonkExpr (ExplicitList ty exprs) + = do new_ty <- zonkTcTypeToTypeX ty + new_exprs <- zonkLExprs exprs + return (ExplicitList new_ty new_exprs) + +zonkExpr expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) + = do { new_con_expr <- zonkExpr con_expr + ; new_rbinds <- zonkRecFields rbinds + ; return (expr { rcon_ext = new_con_expr + , rcon_flds = new_rbinds }) } + +zonkExpr (ExprWithTySig _ e ty) + = do { e' <- zonkLExpr e + ; return (ExprWithTySig noExtField e' ty) } + +zonkExpr (ArithSeq expr wit info) + = do { new_expr <- zonkExpr expr + ; runZonkBndrT (zonkWit wit) $ \ new_wit -> + do { new_info <- zonkArithSeq info + ; return (ArithSeq new_expr new_wit new_info) } } + where zonkWit Nothing = return Nothing + zonkWit (Just fln) = Just <$> zonkSyntaxExpr fln + +zonkExpr (HsPragE x prag expr) + = do new_expr <- zonkLExpr expr + return (HsPragE x prag new_expr) + +-- arrow notation extensions +zonkExpr (HsProc x pat body) + = runZonkBndrT (zonkPat pat) $ \ new_pat -> + do { new_body <- zonkCmdTop body + ; return (HsProc x new_pat new_body) } + +-- StaticPointers extension +zonkExpr (HsStatic (fvs, ty) expr) + = do new_ty <- zonkTcTypeToTypeX ty + HsStatic (fvs, new_ty) <$> zonkLExpr expr + +zonkExpr (HsEmbTy x _) = dataConCantHappen x +zonkExpr (HsQual x _ _) = dataConCantHappen x +zonkExpr (HsForAll x _ _) = dataConCantHappen x +zonkExpr (HsFunArr x _ _ _) = dataConCantHappen x + +zonkExpr (XExpr (WrapExpr co_fn expr)) + = runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn -> + do new_expr <- zonkExpr expr + return (XExpr (WrapExpr new_co_fn new_expr)) + +zonkExpr (XExpr (ExpandedThingTc thing e)) + = do e' <- zonkExpr e + return $ XExpr (ExpandedThingTc thing e') + + +zonkExpr (XExpr (ConLikeTc con tvs tys)) + = XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys + where + zonk_scale (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX 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 (XExpr (HsRecSelTc (FieldOcc occ (L l v)))) + = do { v' <- zonkIdOcc v + ; return (XExpr (HsRecSelTc (FieldOcc occ (L l v')))) } + +zonkExpr (RecordUpd x _ _) = dataConCantHappen x +zonkExpr (HsGetField x _ _) = dataConCantHappen x +zonkExpr (HsProjection x _) = dataConCantHappen x +zonkExpr e@(XExpr (HsTick {})) = pprPanic "zonkExpr" (ppr e) +zonkExpr e@(XExpr (HsBinTick {})) = pprPanic "zonkExpr" (ppr e) + +------------------------------------------------------------------------- +{- +Note [Skolems in zonkSyntaxExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider rebindable syntax with something like + + (>>=) :: (forall x. blah) -> (forall y. blah') -> blah'' + +The x and y become skolems that are in scope when type-checking the +arguments to the bind. This means that we must extend the ZonkEnv with +these skolems when zonking the arguments to the bind. But the skolems +are different between the two arguments, and so we should theoretically +carry around different environments to use for the different arguments. + +However, this becomes a logistical nightmare, especially in dealing with +the more exotic Stmt forms. So, we simplify by making the critical +assumption that the uniques of the skolems are different. (This assumption +is justified by the use of newUnique in GHC.Tc.Utils.TcMType.instSkolTyCoVarX.) +Now, we can safely just extend one environment. +-} + +-- See Note [Skolems in zonkSyntaxExpr] +zonkSyntaxExpr :: SyntaxExpr GhcTc + -> ZonkBndrTcM (SyntaxExpr GhcTc) +zonkSyntaxExpr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + = do { res_wrap' <- zonkCoFn res_wrap + ; expr' <- noBinders $ zonkExpr expr + ; arg_wraps' <- traverse zonkCoFn arg_wraps + ; return SyntaxExprTc { syn_expr = expr' + , syn_arg_wraps = arg_wraps' + , syn_res_wrap = res_wrap' } } +zonkSyntaxExpr NoSyntaxExprTc = return NoSyntaxExprTc + +------------------------------------------------------------------------- + +zonkLCmd :: LHsCmd GhcTc -> ZonkTcM (LHsCmd GhcTc) +zonkCmd :: HsCmd GhcTc -> ZonkTcM (HsCmd GhcTc) + +zonkLCmd cmd = wrapLocZonkMA zonkCmd cmd + +zonkCmd (XCmd (HsWrap w cmd)) + = runZonkBndrT (zonkCoFn w) $ \ w' -> + do { cmd' <- zonkCmd cmd + ; return (XCmd (HsWrap w' cmd')) } +zonkCmd (HsCmdArrApp ty e1 e2 ho rl) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + new_ty <- zonkTcTypeToTypeX ty + return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) + +zonkCmd (HsCmdArrForm x op fixity args) + = do new_op <- zonkLExpr op + new_args <- mapM zonkCmdTop args + return (HsCmdArrForm x new_op fixity new_args) + +zonkCmd (HsCmdApp x c e) + = do new_c <- zonkLCmd c + new_e <- zonkLExpr e + return (HsCmdApp x new_c new_e) + +zonkCmd (HsCmdPar x c) + = do new_c <- zonkLCmd c + return (HsCmdPar x new_c) + +zonkCmd (HsCmdCase x expr ms) + = do new_expr <- zonkLExpr expr + new_ms <- zonkMatchGroup zonkLCmd ms + return (HsCmdCase x new_expr new_ms) + +zonkCmd (HsCmdLam x lam_variant ms) + = do new_ms <- zonkMatchGroup zonkLCmd ms + return (HsCmdLam x lam_variant new_ms) + +zonkCmd (HsCmdIf x eCond ePred cThen cElse) + = runZonkBndrT (zonkSyntaxExpr eCond) $ \ new_eCond -> + do { new_ePred <- zonkLExpr ePred + ; new_cThen <- zonkLCmd cThen + ; new_cElse <- zonkLCmd cElse + ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } + +zonkCmd (HsCmdLet x binds cmd) + = runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> + do new_cmd <- zonkLCmd cmd + return (HsCmdLet x new_binds new_cmd) + +zonkCmd (HsCmdDo ty (L l stmts)) + = do new_stmts <- don'tBind $ zonkStmts zonkLCmd stmts + new_ty <- zonkTcTypeToTypeX ty + return (HsCmdDo new_ty (L l new_stmts)) + + + +zonkCmdTop :: LHsCmdTop GhcTc -> ZonkTcM (LHsCmdTop GhcTc) +zonkCmdTop cmd = wrapLocZonkMA (zonk_cmd_top) cmd + +zonk_cmd_top :: HsCmdTop GhcTc -> ZonkTcM (HsCmdTop GhcTc) +zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) + = do new_cmd <- zonkLCmd cmd + new_stack_tys <- zonkTcTypeToTypeX stack_tys + new_ty <- zonkTcTypeToTypeX ty + new_ids <- mapSndM zonkExpr ids + + massert (definitelyLiftedType new_stack_tys) + -- desugarer assumes that this is not representation-polymorphic... + -- but indeed it should always be lifted due to the typing + -- rules for arrows + + return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) + +------------------------------------------------------------------------- +zonkCoFn :: HsWrapper -> ZonkBndrTcM HsWrapper +zonkCoFn WpHole = return WpHole +zonkCoFn (WpCompose c1 c2) = do { c1' <- zonkCoFn c1 + ; c2' <- zonkCoFn c2 + ; return (WpCompose c1' c2') } +zonkCoFn (WpFun c1 c2 t1) = do { c1' <- zonkCoFn c1 + ; c2' <- zonkCoFn c2 + ; t1' <- noBinders $ zonkScaledTcTypeToTypeX t1 + ; return (WpFun c1' c2' t1') } +zonkCoFn (WpCast co) = WpCast <$> noBinders (zonkCoToCo co) +zonkCoFn (WpEvLam ev) = WpEvLam <$> zonkEvBndrX ev +zonkCoFn (WpEvApp arg) = WpEvApp <$> noBinders (zonkEvTerm arg) +zonkCoFn (WpTyLam tv) = assert (isImmutableTyVar tv) $ + WpTyLam <$> zonkTyBndrX tv +zonkCoFn (WpTyApp ty) = WpTyApp <$> noBinders (zonkTcTypeToTypeX ty) +zonkCoFn (WpLet bs) = WpLet <$> zonkTcEvBinds bs + +------------------------------------------------------------------------- +zonkOverLit :: HsOverLit GhcTc -> ZonkTcM (HsOverLit GhcTc) +zonkOverLit lit@(OverLit {ol_ext = x@OverLitTc { ol_witness = e, ol_type = ty } }) + = do { ty' <- zonkTcTypeToTypeX ty + ; e' <- zonkExpr e + ; return (lit { ol_ext = x { ol_witness = e' + , ol_type = ty' } }) } + +------------------------------------------------------------------------- +zonkBracket :: HsBracketTc -> ZonkTcM HsBracketTc +zonkBracket (HsBracketTc hsb_thing ty wrap bs) + = do wrap' <- traverse zonkQuoteWrap wrap + bs' <- mapM zonk_b bs + new_ty <- zonkTcTypeToTypeX ty + return (HsBracketTc hsb_thing new_ty wrap' bs') + where + zonkQuoteWrap (QuoteWrapper ev ty) = do + ev' <- zonkIdOcc ev + ty' <- zonkTcTypeToTypeX ty + return (QuoteWrapper ev' ty') + + zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr e + return (PendingTcSplice n e') + +------------------------------------------------------------------------- +zonkArithSeq :: ArithSeqInfo GhcTc -> ZonkTcM (ArithSeqInfo GhcTc) + +zonkArithSeq (From e) + = do new_e <- zonkLExpr e + return (From new_e) + +zonkArithSeq (FromThen e1 e2) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + return (FromThen new_e1 new_e2) + +zonkArithSeq (FromTo e1 e2) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + return (FromTo new_e1 new_e2) + +zonkArithSeq (FromThenTo e1 e2 e3) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + new_e3 <- zonkLExpr e3 + return (FromThenTo new_e1 new_e2 new_e3) + +------------------------------------------------------------------------- +zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> [LStmt GhcTc (LocatedA (body GhcTc))] + -> ZonkBndrTcM [LStmt GhcTc (LocatedA (body GhcTc))] +zonkStmts _ [] = return [] +zonkStmts zBody (s:ss) = do { s' <- wrapLocZonkBndrMA (zonkStmt zBody) s + ; ss' <- zonkStmts zBody ss + ; return (s' : ss') } + +zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> Stmt GhcTc (LocatedA (body GhcTc)) + -> ZonkBndrTcM (Stmt GhcTc (LocatedA (body GhcTc))) +zonkStmt _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) + = do { new_bind_op <- zonkSyntaxExpr bind_op + ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX bind_ty + ; new_stmts_w_bndrs <- noBinders $ mapM zonk_branch stmts_w_bndrs + + -- Add in the binders after we're done with all the branches. + ; let new_binders = [ b | ParStmtBlock _ _ bs _ <- toList new_stmts_w_bndrs + , b <- bs ] + ; extendIdZonkEnvRec new_binders + ; new_mzip <- noBinders $ zonkExpr mzip_op + ; return (ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)} + where + zonk_branch :: ParStmtBlock GhcTc GhcTc + -> ZonkTcM (ParStmtBlock GhcTc GhcTc) + zonk_branch (ParStmtBlock x stmts bndrs return_op) + = runZonkBndrT (zonkStmts zonkLExpr stmts) $ \ new_stmts -> + runZonkBndrT (zonkSyntaxExpr return_op) $ \ new_return -> + do { new_bndrs <- zonkIdOccs bndrs + ; return (ParStmtBlock x new_stmts new_bndrs new_return) } + +zonkStmt zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs + , recS_rec_ids = rvs + , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id + , recS_bind_fn = bind_id + , recS_ext = + RecStmtTc { recS_bind_ty = bind_ty + , recS_later_rets = later_rets + , recS_rec_rets = rec_rets + , recS_ret_ty = ret_ty} }) + = do { new_bind_id <- zonkSyntaxExpr bind_id + ; new_mfix_id <- zonkSyntaxExpr mfix_id + ; new_ret_id <- zonkSyntaxExpr ret_id + ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX bind_ty + ; new_rvs <- noBinders $ zonkIdBndrs rvs + ; new_lvs <- noBinders $ zonkIdBndrs lvs + ; new_ret_ty <- noBinders $ zonkTcTypeToTypeX ret_ty + + -- Zonk the ret-expressions in an environment that + -- has the polymorphic bindings + ; rec_stmt <- noBinders $ don'tBind $ + do { extendIdZonkEnvRec new_rvs + ; new_segStmts <- zonkStmts zBody segStmts + ; new_later_rets <- noBinders $ mapM zonkExpr later_rets + ; new_rec_rets <- noBinders $ mapM zonkExpr rec_rets + ; return $ + RecStmt { recS_stmts = noLocA new_segStmts + , recS_later_ids = new_lvs + , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id + , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id + , recS_ext = RecStmtTc + { recS_bind_ty = new_bind_ty + , recS_later_rets = new_later_rets + , recS_rec_rets = new_rec_rets + , recS_ret_ty = new_ret_ty } } } + + -- Only the lvs are needed + ; extendIdZonkEnvRec new_lvs + ; return rec_stmt } + +zonkStmt zBody (BodyStmt ty body then_op guard_op) + = do { new_then_op <- zonkSyntaxExpr then_op + ; new_guard_op <- zonkSyntaxExpr guard_op + ; new_body <- noBinders $ zBody body + ; new_ty <- noBinders $ zonkTcTypeToTypeX ty + ; return $ BodyStmt new_ty new_body new_then_op new_guard_op } + +zonkStmt zBody (LastStmt x body noret ret_op) + = noBinders $ runZonkBndrT (zonkSyntaxExpr ret_op) $ \ new_ret -> + do { new_body <- zBody body + ; return $ LastStmt x new_body noret new_ret } + +zonkStmt _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op + , trS_ext = bind_arg_ty + , trS_fmap = liftM_op }) + = do { bind_op' <- zonkSyntaxExpr bind_op + ; bind_arg_ty' <- noBinders $ zonkTcTypeToTypeX bind_arg_ty + ; stmts' <- zonkStmts zonkLExpr stmts + ; by' <- noBinders $ traverse zonkLExpr by + ; using' <- noBinders $ zonkLExpr using + ; return_op' <- zonkSyntaxExpr return_op + ; liftM_op' <- noBinders $ zonkExpr liftM_op + ; binderMap' <- mapM zonkBinderMapEntry binderMap + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' + , trS_by = by', trS_form = form, trS_using = using' + , trS_ret = return_op', trS_bind = bind_op' + , trS_ext = bind_arg_ty' + , trS_fmap = liftM_op' }) } + where + zonkBinderMapEntry (oldBinder, newBinder) = do + oldBinder' <- noBinders $ zonkIdOcc oldBinder + newBinder' <- zonkIdBndrX newBinder + return (oldBinder', newBinder') + +zonkStmt _ (LetStmt x binds) + = LetStmt x <$> zonkLocalBinds binds + +zonkStmt zBody (BindStmt xbs pat body) + = do { new_bind <- zonkSyntaxExpr (xbstc_bindOp xbs) + ; new_w <- noBinders $ zonkTcTypeToTypeX (xbstc_boundResultMult xbs) + ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX (xbstc_boundResultType xbs) + ; new_body <- noBinders $ zBody body + ; new_fail <- case xbstc_failOp xbs of + Nothing -> return Nothing + Just fail_op -> fmap Just <$> noBinders $ don'tBind (zonkSyntaxExpr fail_op) + + ; new_pat <- zonkPat pat + ; return $ + BindStmt + (XBindStmtTc + { xbstc_bindOp = new_bind + , xbstc_boundResultType = new_bind_ty + , xbstc_boundResultMult = new_w + , xbstc_failOp = new_fail + }) + new_pat new_body } + +-- Scopes: join > ops (in reverse order) > pats (in forward order) +-- > rest of stmts +zonkStmt _zBody (XStmtLR (ApplicativeStmt body_ty args mb_join)) + = do { new_mb_join <- zonk_join mb_join + ; new_args <- zonk_args args + ; new_body_ty <- noBinders $ zonkTcTypeToTypeX body_ty + ; return $ XStmtLR $ ApplicativeStmt new_body_ty new_args new_mb_join } + where + zonk_join Nothing = return Nothing + zonk_join (Just j) = Just <$> zonkSyntaxExpr j + + get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc + get_pat (_, ApplicativeArgOne _ pat _ _) = pat + get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat + + replace_pat :: LPat GhcTc + -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody) + = (op, ApplicativeArgOne fail_op pat a isBody) + replace_pat pat (op, ApplicativeArgMany x a b _ c) + = (op, ApplicativeArgMany x a b pat c) + + zonk_args args + = do { new_args_rev <- zonk_args_rev (reverse args) + ; new_pats <- zonkPats (map get_pat args) + ; return $ zipWithEqual replace_pat + new_pats (reverse new_args_rev) } + + -- these need to go backward, because if any operators are higher-rank, + -- later operators may introduce skolems that are in scope for earlier + -- arguments + zonk_args_rev ((op, arg) : args) + = do { new_op <- zonkSyntaxExpr op + ; new_arg <- noBinders $ zonk_arg arg + ; new_args <- zonk_args_rev args + ; return $ (new_op, new_arg) : new_args } + zonk_args_rev [] = return [] + + zonk_arg (ApplicativeArgOne fail_op pat expr isBody) + = do { new_expr <- zonkLExpr expr + ; new_fail <- forM fail_op $ don'tBind . zonkSyntaxExpr + ; return (ApplicativeArgOne new_fail pat new_expr isBody) } + zonk_arg (ApplicativeArgMany x stmts ret pat ctxt) + = runZonkBndrT (zonkStmts zonkLExpr stmts) $ \ new_stmts -> + do { new_ret <- zonkExpr ret + ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) } + +------------------------------------------------------------------------- +zonkRecFields :: HsRecordBinds GhcTc -> ZonkTcM (HsRecordBinds GhcTc) +zonkRecFields (HsRecFields x flds dd) + = do { flds' <- mapM zonk_rbind flds + ; return (HsRecFields x flds' dd) } + where + zonk_rbind (L l fld) + = do { new_id <- wrapLocZonkMA zonkFieldOcc (hfbLHS fld) + ; new_expr <- zonkLExpr (hfbRHS fld) + ; return (L l (fld { hfbLHS = new_id + , hfbRHS = new_expr })) } + +{- +************************************************************************ +* * +\subsection[BackSubst-Pats]{Patterns} +* * +************************************************************************ +-} + + +zonkPat :: LPat GhcTc -> ZonkBndrTcM (LPat GhcTc) +-- Extend the environment as we go, because it's possible for one +-- pattern to bind something that is used in another (inside or +-- to the right) +zonkPat pat = wrapLocZonkBndrMA zonk_pat pat + +zonk_pat :: Pat GhcTc -> ZonkBndrTcM (Pat GhcTc) +zonk_pat (ParPat x p) + = do { p' <- zonkPat p + ; return (ParPat x p') } + +zonk_pat (WildPat ty) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (WildPat ty') } + +zonk_pat (VarPat x (L l v)) + = do { v' <- zonkIdBndrX v + ; return (VarPat x (L l v')) } + +zonk_pat (LazyPat x pat) + = do { pat' <- zonkPat pat + ; return (LazyPat x pat') } + +zonk_pat (BangPat x pat) + = do { pat' <- zonkPat pat + ; return (BangPat x pat') } + +zonk_pat (AsPat x (L loc v) pat) + = do { v' <- zonkIdBndrX v + ; pat' <- zonkPat pat + ; return (AsPat x (L loc v') pat') } + +zonk_pat (ViewPat ty expr pat) + = do { expr' <- noBinders $ zonkLExpr expr + ; pat' <- zonkPat pat + ; ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (ViewPat ty' expr' pat') } + +zonk_pat (ListPat ty pats) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; pats' <- zonkPats pats + ; return (ListPat ty' pats') } + +zonk_pat (TuplePat tys pats boxed) + = do { tys' <- noBinders $ mapM zonkTcTypeToTypeX tys + ; pats' <- zonkPats pats + ; return (TuplePat tys' pats' boxed) } + +zonk_pat (OrPat ty pats) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; pats' <- zonkPats pats + ; return (OrPat ty' pats') } + +zonk_pat (SumPat tys pat alt arity ) + = do { tys' <- noBinders $ mapM zonkTcTypeToTypeX tys + ; pat' <- zonkPat pat + ; return (SumPat tys' pat' alt arity) } + +zonk_pat p@(ConPat { pat_args = args + , pat_con_ext = p'@(ConPatTc + { cpt_tvs = tyvars + , cpt_dicts = evs + , cpt_binds = binds + , cpt_wrap = wrapper + , cpt_arg_tys = tys + }) + }) + = assert (all isImmutableTyVar tyvars) $ + do { new_tys <- noBinders $ mapM zonkTcTypeToTypeX tys + ; new_tyvars <- zonkTyBndrsX tyvars + -- Must zonk the existential variables, because their + -- /kind/ need potential zonking. + -- cf typecheck/should_compile/tc221.hs + ; new_evs <- zonkEvBndrsX evs + ; new_binds <- zonkTcEvBinds binds + ; new_wrapper <- zonkCoFn wrapper + ; new_args <- zonkConStuff args + ; pure $ p + { pat_args = new_args + , pat_con_ext = p' + { cpt_arg_tys = new_tys + , cpt_tvs = new_tyvars + , cpt_dicts = new_evs + , cpt_binds = new_binds + , cpt_wrap = new_wrapper + } + } + } + +zonk_pat (LitPat x lit) = return (LitPat x lit) + +zonk_pat (SigPat ty pat hs_ty) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; pat' <- zonkPat pat + ; return (SigPat ty' pat' hs_ty) } + +zonk_pat (NPat ty (L l lit) mb_neg eq_expr) + = do { eq_expr' <- zonkSyntaxExpr eq_expr + ; mb_neg' <- case mb_neg of + Nothing -> return Nothing + Just n -> Just <$> zonkSyntaxExpr n + ; noBinders $ + do { lit' <- zonkOverLit lit + ; ty' <- zonkTcTypeToTypeX ty + ; return (NPat ty' (L l lit') mb_neg' eq_expr') } } + +zonk_pat (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) + = do { e1' <- zonkSyntaxExpr e1 + ; e2' <- zonkSyntaxExpr e2 + ; lit1' <- noBinders $ zonkOverLit lit1 + ; lit2' <- noBinders $ zonkOverLit lit2 + ; ty' <- noBinders $ zonkTcTypeToTypeX ty + ; n' <- zonkIdBndrX n + ; return (NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } + +zonk_pat (EmbTyPat ty tp) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (EmbTyPat ty' tp) } + +zonk_pat (InvisPat ty tp) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (InvisPat ty' tp) } + +zonk_pat (XPat ext) = case ext of + { ExpansionPat orig pat-> + do { pat' <- zonk_pat pat + ; return $ XPat $ ExpansionPat orig pat' } + ; CoPat co_fn pat ty -> + do { co_fn' <- zonkCoFn co_fn + ; pat' <- zonkPat (noLocA pat) + ; ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (XPat $ CoPat co_fn' (unLoc pat') ty') + } } + +zonk_pat pat = pprPanic "zonk_pat" (ppr pat) + +--------------------------- +zonkConStuff :: HsConPatDetails GhcTc + -> ZonkBndrTcM (HsConPatDetails GhcTc) +zonkConStuff (PrefixCon pats) + = do { pats' <- zonkPats pats + ; return (PrefixCon pats') } + +zonkConStuff (InfixCon p1 p2) + = do { p1' <- zonkPat p1 + ; p2' <- zonkPat p2 + ; return (InfixCon p1' p2') } + +zonkConStuff (RecCon (HsRecFields x rpats dd)) + = do { pats' <- zonkPats (map (hfbRHS . unLoc) rpats) + ; let rpats' = zipWith (\(L l rp) p' -> + L l (rp { hfbRHS = p' })) + rpats pats' + ; return (RecCon (HsRecFields x rpats' dd)) } + -- Field selectors have declared types; hence no zonking + +--------------------------- +zonkPats :: Traversable f => f (LPat GhcTc) -> ZonkBndrTcM (f (LPat GhcTc)) +zonkPats = traverse zonkPat +{-# SPECIALISE zonkPats :: [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc] #-} +{-# SPECIALISE zonkPats :: NonEmpty (LPat GhcTc) -> ZonkBndrTcM (NonEmpty (LPat GhcTc)) #-} + +{- +************************************************************************ +* * +\subsection[BackSubst-Foreign]{Foreign exports} +* * +************************************************************************ +-} + +zonkForeignExports :: [LForeignDecl GhcTc] + -> ZonkTcM [LForeignDecl GhcTc] +zonkForeignExports ls = mapM (wrapLocZonkMA zonkForeignExport) ls + +zonkForeignExport :: ForeignDecl GhcTc -> ZonkTcM (ForeignDecl GhcTc) +zonkForeignExport (ForeignExport { fd_name = i, fd_e_ext = co + , fd_fe = spec }) + = do { i' <- zonkLIdOcc i + ; return (ForeignExport { fd_name = i' + , fd_sig_ty = undefined, fd_e_ext = co + , fd_fe = spec }) } +zonkForeignExport for_imp + = return for_imp -- Foreign imports don't need zonking + +zonkRules :: [LRuleDecl GhcTc] -> ZonkTcM [LRuleDecl GhcTc] +zonkRules rs = mapM (wrapLocZonkMA zonkRule) rs + +zonkRule :: RuleDecl GhcTc -> ZonkTcM (RuleDecl GhcTc) +zonkRule rule@(HsRule { rd_bndrs = bndrs + , rd_lhs = lhs + , rd_rhs = rhs }) + = do { skol_tvs_ref <- lift $ newTcRef [] + ; setZonkType (SkolemiseFlexi skol_tvs_ref) $ + -- setZonkType: see Note [Free tyvars on rule LHS] + zonkRuleBndrs bndrs $ \ new_bndrs -> + do { new_lhs <- zonkLExpr lhs + ; skol_tvs <- lift $ readTcRef skol_tvs_ref + ; new_rhs <- setZonkType DefaultFlexi $ zonkLExpr rhs + ; return $ rule { rd_bndrs = add_tvs skol_tvs new_bndrs + , rd_lhs = new_lhs + , rd_rhs = new_rhs } } } + where + add_tvs :: [TyVar] -> RuleBndrs GhcTc -> RuleBndrs GhcTc + add_tvs tvs rbs@(RuleBndrs { rb_ext = bndrs }) = rbs { rb_ext = tvs ++ bndrs } + + +zonkRuleBndrs :: RuleBndrs GhcTc -> (RuleBndrs GhcTc -> ZonkTcM a) -> ZonkTcM a +zonkRuleBndrs rb@(RuleBndrs { rb_ext = bndrs }) thing_inside + = runZonkBndrT (traverse zonk_it bndrs) $ \ new_bndrs -> + thing_inside (rb { rb_ext = new_bndrs }) + where + zonk_it v + | isId v = zonkIdBndrX v + | otherwise = assert (isImmutableTyVar v) $ + zonkTyBndrX v + -- We may need to go inside the kind of v and zonk there! + +{- Note [Free tyvars on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = C + + foo :: T a -> Int + foo C = 1 + + {-# RULES "myrule" foo C = 1 #-} + +After type checking the LHS becomes (foo alpha (C alpha)), where alpha +is an unbound meta-tyvar. The zonker in GHC.Tc.Zonk.Type is careful not to +turn the free alpha into Any (as it usually does). Instead we want to quantify +over it. Here is how: + +* We set the ze_flexi field of ZonkEnv to (SkolemiseFlexi ref), to tell the + zonker to zonk a Flexi meta-tyvar to a TyVar, not to Any. See the + SkolemiseFlexi case of `commitFlexi`. + +* Here (ref :: TcRef [TyVar]) collects the type variables thus skolemised; + again see `commitFlexi`. + +* When zonking a RULE, in `zonkRule` we + - make a fresh ref-cell to collect the skolemised type variables, + - zonk the binders and LHS with ze_flexi = SkolemiseFlexi ref + - read the ref-cell to get all the skolemised TyVars + - add them to the binders + +All this applies for SPECIALISE pragmas too. + +Wrinkles: + +(FTV1) We just add the new tyvars to the front of the binder-list, but + that may make the list not be in dependency order. Example (T12925): + the existing list is [k:Type, b:k], and we add (a:k) to the front. + Also we just collect the new skolemised type variables in any old order, + so they may not be ordered with respect to each other. +-} + +{- +************************************************************************ +* * + Constraints and evidence +* * +************************************************************************ +-} + +zonkEvTerm :: EvTerm -> ZonkTcM EvTerm +zonkEvTerm (EvExpr e) + = EvExpr <$> zonkCoreExpr e +zonkEvTerm (EvTypeable ty ev) + = EvTypeable <$> zonkTcTypeToTypeX ty <*> zonkEvTypeable ev +zonkEvTerm (EvFun { et_tvs = tvs, et_given = evs + , et_binds = ev_binds, et_body = body_id }) + = runZonkBndrT (zonkTyBndrsX tvs) $ \ new_tvs -> + runZonkBndrT (zonkEvBndrsX evs) $ \ new_evs -> + runZonkBndrT (zonkTcEvBinds ev_binds) $ \ new_ev_binds -> + do { new_body_id <- zonkIdOcc body_id + ; return (EvFun { et_tvs = new_tvs, et_given = new_evs + , et_binds = new_ev_binds, et_body = new_body_id }) } + +zonkCoreExpr :: CoreExpr -> ZonkTcM CoreExpr +zonkCoreExpr (Var v) + | isCoVar v + = Coercion <$> zonkCoVarOcc v + | otherwise + = Var <$> zonkIdOcc v +zonkCoreExpr (Lit l) + = return $ Lit l +zonkCoreExpr (Coercion co) + = Coercion <$> zonkCoToCo co +zonkCoreExpr (Type ty) + = Type <$> zonkTcTypeToTypeX ty + +zonkCoreExpr (Cast e co) + = Cast <$> zonkCoreExpr e <*> zonkCoToCo co +zonkCoreExpr (Tick t e) + = Tick t <$> zonkCoreExpr e -- Do we need to zonk in ticks? + +zonkCoreExpr (App e1 e2) + = App <$> zonkCoreExpr e1 <*> zonkCoreExpr e2 +zonkCoreExpr (Lam v e) + = runZonkBndrT (zonkCoreBndrX v) $ \ v' -> + Lam v' <$> zonkCoreExpr e +zonkCoreExpr (Let bind e) + = runZonkBndrT (zonkCoreBind bind) $ \ bind' -> + Let bind' <$> zonkCoreExpr e +zonkCoreExpr (Case scrut b ty alts) + = do { scrut' <- zonkCoreExpr scrut + ; ty' <- zonkTcTypeToTypeX ty + ; runZonkBndrT (zonkIdBndrX b) $ \ b' -> + do { alts' <- mapM zonkCoreAlt alts + ; return $ Case scrut' b' ty' alts' } } + +zonkCoreAlt :: CoreAlt -> ZonkTcM CoreAlt +zonkCoreAlt (Alt dc bndrs rhs) + = runZonkBndrT (zonkCoreBndrsX bndrs) $ \ bndrs' -> + do { rhs' <- zonkCoreExpr rhs + ; return $ Alt dc bndrs' rhs' } + +zonkCoreBind :: CoreBind -> ZonkBndrTcM CoreBind +zonkCoreBind (NonRec v e) + = do { (v',e') <- noBinders $ zonkCorePair (v,e) + ; extendIdZonkEnv v' + ; return (NonRec v' e') } +zonkCoreBind (Rec pairs) + = do pairs' <- mfix go + return $ Rec pairs' + where + go new_pairs = do + extendIdZonkEnvRec (map fst new_pairs) + noBinders $ mapM zonkCorePair pairs + +zonkCorePair :: (CoreBndr, CoreExpr) -> ZonkTcM (CoreBndr, CoreExpr) +zonkCorePair (v,e) = + do { v' <- zonkIdBndr v + ; e' <- zonkCoreExpr e + ; return (v',e') } + +zonkEvTypeable :: EvTypeable -> ZonkTcM EvTypeable +zonkEvTypeable (EvTypeableTyCon tycon e) + = do { e' <- mapM zonkEvTerm e + ; return $ EvTypeableTyCon tycon e' } +zonkEvTypeable (EvTypeableTyApp t1 t2) + = do { t1' <- zonkEvTerm t1 + ; t2' <- zonkEvTerm t2 + ; return (EvTypeableTyApp t1' t2') } +zonkEvTypeable (EvTypeableTrFun tm t1 t2) + = do { tm' <- zonkEvTerm tm + ; t1' <- zonkEvTerm t1 + ; t2' <- zonkEvTerm t2 + ; return (EvTypeableTrFun tm' t1' t2') } +zonkEvTypeable (EvTypeableTyLit t1) + = do { t1' <- zonkEvTerm t1 + ; return (EvTypeableTyLit t1') } + +zonkTcEvBinds_s :: [TcEvBinds] -> ZonkBndrTcM [TcEvBinds] +zonkTcEvBinds_s bs = do { bs' <- traverse zonk_tc_ev_binds bs + ; return ([EvBinds (unionManyBags bs')]) } + +zonkTcEvBinds :: TcEvBinds -> ZonkBndrTcM TcEvBinds +zonkTcEvBinds bs = do { bs' <- zonk_tc_ev_binds bs + ; return (EvBinds bs') } + +zonk_tc_ev_binds :: TcEvBinds -> ZonkBndrTcM (Bag EvBind) +zonk_tc_ev_binds (TcEvBinds var) = zonkEvBindsVar var +zonk_tc_ev_binds (EvBinds bs) = zonkEvBinds bs + +zonkEvBindsVar :: EvBindsVar -> ZonkBndrTcM (Bag EvBind) +zonkEvBindsVar (EvBindsVar { ebv_binds = ref }) + = do { bs <- readTcRef ref + ; zonkEvBinds (evBindMapBinds bs) } +zonkEvBindsVar (CoEvBindsVar {}) = return emptyBag + +zonkEvBinds :: Bag EvBind -> ZonkBndrTcM (Bag EvBind) +zonkEvBinds binds + = {-# SCC "zonkEvBinds" #-} + mfix $ \ new_binds -> + do { extendIdZonkEnvRec (collect_ev_bndrs new_binds) + ; noBinders $ mapBagM zonkEvBind binds } + where + collect_ev_bndrs :: Bag EvBind -> [EvVar] + collect_ev_bndrs = foldr add [] + add (EvBind { eb_lhs = var }) vars = var : vars + +zonkEvBind :: EvBind -> ZonkTcM EvBind +zonkEvBind bind@(EvBind { eb_lhs = var, eb_rhs = term }) + = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr var + + -- Optimise the common case of Refl coercions + -- See Note [Optimise coercion zonking] + -- This has a very big effect on some programs (eg #5030) + + ; term' <- case getEqPredTys_maybe (idType var') of + Just (r, ty1, ty2) | ty1 `eqType` ty2 + -> return (evCoercion (mkReflCo r ty1)) + _other -> zonkEvTerm term + + ; return (bind { eb_lhs = var', eb_rhs = term' }) } + +{- Note [Optimise coercion zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When optimising evidence binds we may come across situations where +a coercion looks like + cv = ReflCo ty +or cv1 = cv2 +where the type 'ty' is big. In such cases it is a waste of time to zonk both + * The variable on the LHS + * The coercion on the RHS +Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just +use Refl on the right, ignoring the actual coercion on the RHS. + +This can have a very big effect, because the constraint solver sometimes does go +to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf #5030) +-} + +zonkTcMethInfoToMethInfoX :: TcMethInfo -> ZonkTcM MethInfo +zonkTcMethInfoToMethInfoX (name, ty, gdm_spec) + = do { ty' <- zonkTcTypeToTypeX ty + ; gdm_spec' <- zonk_gdm gdm_spec + ; return (name, ty', gdm_spec') } + where + zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType)) + -> ZonkTcM (Maybe (DefMethSpec (SrcSpan, Type))) + zonk_gdm Nothing = return Nothing + zonk_gdm (Just VanillaDM) = return (Just VanillaDM) + zonk_gdm (Just (GenericDM (loc, ty))) + = do { ty' <- zonkTcTypeToTypeX ty + ; return (Just (GenericDM (loc, ty'))) } + +--------------------------------------- +{- Note [Zonking the LHS of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS] + +We need to gather the type variables mentioned on the LHS so we can +quantify over them. Example: + data T a = C + + foo :: T a -> Int + foo C = 1 + + {-# RULES "myrule" foo C = 1 #-} + +After type checking the LHS becomes (foo alpha (C alpha)) and we do +not want to zap the unbound meta-tyvar 'alpha' to Any, because that +limits the applicability of the rule. Instead, we want to quantify +over it! + +We do this in two stages. + +* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We + do this by using zonkTvSkolemising as the UnboundTyVarZonker in the + ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a + UnboundTyVarZonker.) + +* In GHC.HsToCore.Binds, we quantify over it. See GHC.HsToCore.Binds + Note [Free tyvars on rule LHS] + +Quantifying here is awkward because (a) the data type is big and (b) +finding the free type vars of an expression is necessarily monadic +operation. (consider /\a -> f @ b, where b is side-effected to a) +-} + diff --git a/GHC/ThToHs.hs b/GHC/ThToHs.hs new file mode 100644 --- /dev/null +++ b/GHC/ThToHs.hs @@ -0,0 +1,2471 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingVia #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +This module converts Template Haskell syntax into Hs syntax +-} + +module GHC.ThToHs + ( convertToHsExpr + , convertToPat + , convertToHsDecls + , convertToHsType + , thRdrNameGuesses + ) +where + +import GHC.Prelude hiding (init, last, tail) + +import GHC.Hs as Hs +import GHC.Tc.Errors.Types +import GHC.Types.Name.Cache +import GHC.Types.Name.Reader +import qualified GHC.Types.Name as Name +import GHC.Unit.Module +import GHC.Parser.PostProcess +import GHC.Types.Name.Occurrence as OccName +import GHC.Types.SrcLoc +import GHC.Core.Type as Hs +import qualified GHC.Core.Coercion as Coercion ( Role(..) ) +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim( fUNTyCon ) +import GHC.Types.Basic as Hs +import GHC.Types.Fixity as Hs +import GHC.Types.ForeignCall +import GHC.Types.Unique +import GHC.Types.SourceText +import GHC.Utils.Lexeme +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Panic + +import GHC.Data.EnumSet (EnumSet) +import qualified GHC.Data.EnumSet as EnumSet +import qualified GHC.LanguageExtensions as LangExt + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import qualified Data.ByteString as BS +import Control.Monad( unless ) +import Data.Bifunctor (first) +import Data.Foldable (for_) +import Data.List.NonEmpty( NonEmpty (..), nonEmpty ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe( catMaybes, isNothing ) +import Data.Word (Word64) +import GHC.Boot.TH.Syntax as TH +import Foreign.ForeignPtr +import Foreign.Ptr +import System.IO.Unsafe + +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict + + +------------------------------------------------------------------- +-- The external interface + +convertToHsDecls :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> [TH.Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs] +convertToHsDecls exts origin loc ds = + initCvt exts origin loc $ fmap catMaybes (mapM cvt_dec ds) + where + cvt_dec d = + wrapMsg (ConvDec d) $ cvtDec d + +convertToHsExpr :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Exp -> Either RunSpliceFailReason (LHsExpr GhcPs) +convertToHsExpr exts origin loc e + = initCvt exts origin loc $ wrapMsg (ConvExp e) $ cvtl e + +convertToPat :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Pat -> Either RunSpliceFailReason (LPat GhcPs) +convertToPat exts origin loc p + = initCvt exts origin loc $ wrapMsg (ConvPat p) $ cvtPat p + +convertToHsType :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Type -> Either RunSpliceFailReason (LHsType GhcPs) +convertToHsType exts origin loc t + = initCvt exts origin loc $ wrapMsg (ConvType t) $ cvtType t + +------------------------------------------------------------------- + +-- Reader context for CvtM +data CvtCtx = + CvtCtx { cvt_origin :: !Origin + , cvt_listTuplePuns :: !Bool } + +-- State of CvtM +type CvtSt = SrcSpan + +newtype CvtM' err a = CvtM { unCvtM :: CvtCtx -> CvtSt -> Either err (a, SrcSpan) } + deriving (Functor, Applicative, Monad) via ReaderT CvtCtx (StateT CvtSt (Either err)) + -- Push down the Origin (that is configurable by + -- -fenable-th-splice-warnings) and source location; + -- Can fail, with a single error message + +type CvtM = CvtM' ConversionFailReason + +-- NB: If the conversion succeeds with (Right x), there should +-- be no exception values hiding in x +-- Reason: so a (head []) in TH code doesn't subsequently +-- make GHC crash when it tries to walk the generated tree + +-- Use the SrcSpan everywhere, for lack of anything better. +-- See Note [Source locations within TH splices]. + +-- | Return first success or first error. +-- +-- Primary case should be the first because it +-- would determine returned error message +orOnFail :: CvtM' err a -> CvtM' err a -> CvtM' err a +m1 `orOnFail` m2 = CvtM $ \ctx l -> choose (unCvtM m1 ctx l) (unCvtM m2 ctx l) + where + choose r@Right{} _ = r + choose _ r@Right{} = r + choose err@Left{} _ = err + +infixl 3 `orOnFail` -- The same fixity as for <|> + +mapCvtMError :: (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a +mapCvtMError f m = CvtM $ \origin loc -> first f $ unCvtM m origin loc + +initCvt :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> CvtM' err a -> Either err a +initCvt exts origin loc m = fmap fst (unCvtM m ctx loc) + where ctx = CvtCtx { cvt_origin = origin + , cvt_listTuplePuns = listTuplePuns } + listTuplePuns = EnumSet.member LangExt.ListTuplePuns exts + +force :: a -> CvtM () +force a = a `seq` return () + +failWith :: ConversionFailReason -> CvtM a +failWith m = CvtM (\_ _ -> Left m) + +getOrigin :: CvtM Origin +getOrigin = CvtM (\ctx s -> Right (cvt_origin ctx,s)) + +getListTuplePuns :: CvtM Bool +getListTuplePuns = CvtM (\ctx s -> Right (cvt_listTuplePuns ctx,s)) + +getL :: CvtM SrcSpan +getL = CvtM (\_ loc -> Right (loc,loc)) + +-- NB: This is only used in conjunction with LineP pragmas. +-- See Note [Source locations within TH splices]. +setL :: SrcSpan -> CvtM () +setL loc = CvtM (\_ _ -> Right ((), loc)) + +returnLA :: (NoAnn ann) => e -> CvtM (LocatedAn ann e) +returnLA x = CvtM (\_ loc -> Right (L (noAnnSrcSpan loc) x, loc)) + +returnJustLA :: a -> CvtM (Maybe (LocatedA a)) +returnJustLA = fmap Just . returnLA + +wrapParLA :: (NoAnn ann) => (LocatedAn ann a -> b) -> a -> CvtM b +wrapParLA add_par x = CvtM (\_ loc -> Right (add_par (L (noAnnSrcSpan loc) x), loc)) + +wrapMsg :: ThingBeingConverted -> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a +wrapMsg what = mapCvtMError (ConversionFail what) + +wrapL :: CvtM a -> CvtM (Located a) +wrapL m = do + loc <- getL + fmap (L loc) m + +wrapGL :: HasAnnotation e => CvtM a -> CvtM (GenLocated e a) +wrapGL m = do + loc <- getL + fmap (L (noAnnSrcSpan loc)) m + +wrapLN :: CvtM a -> CvtM (LocatedN a) +wrapLN = wrapGL + +wrapLA :: CvtM a -> CvtM (LocatedA a) +wrapLA = wrapGL + +{- +Note [Source locations within TH splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a TH splice such as $(x), where `x` evaluates to `id True`. What +source locations should we use for subexpressions within the splice, such as +`id` and `True`? We basically have two options: + +1. Don't give anything within the splice a SrcSpan. That is, use the `noLoc` + everywhere. +2. Give everything within the splice the same `SrcSpan` as where the splice + occurs (i.e., where $(x) occurs). + +We implement option (2) for the following reasons: + +* We want SrcSpans on binding locations so that variables bound in the + spliced-in declarations get a location that at least relates to the splice + point. + +* Generally speaking, having *some* SrcSpan for each sub-expression in the AST + in better than having no SrcSpan at all. This extra information can be useful + for programs that walk over the AST directly. + +Because of our choice of option (2), we are very careful not to use the noLoc +function anywhere in GHC.ThToHs. Instead, we thread around a SrcSpan in CvtM +and allow retrieving the SrcSpan through combinators such as getL, returnLA, +wrapParLA, etc. + +Note that CvtM is actually a *state* monad vis-à-vis SrcSpan, not just a +reader monad. This is because LineP pragmas can change the source location +within a splice—see testsuite/tests/th/TH_linePragma.hs for an example. This +is a bit unusual, since it changes the source location from that of the splice +point to that of the code being spliced in. Nevertheless, LineP is *the* reason +why CvtM is a state monad. +-} + +------------------------------------------------------------------- +cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] +cvtDecs = fmap catMaybes . mapM cvtDec + +cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs)) +cvtDec (TH.ValD pat body ds) + | TH.VarP s <- pat + = do { s' <- vNameN s + ; cl' <- cvtClause (mkPrefixFunRhs s' noAnn) (Clause [] body ds) + ; th_origin <- getOrigin + ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] } + + | otherwise + = do { pat' <- cvtPat pat + ; body' <- cvtGuard body + ; ds' <- cvtLocalDecs WhereClause ds + ; returnJustLA $ Hs.ValD noExtField $ + PatBind { pat_lhs = pat' + , pat_rhs = GRHSs emptyComments body' ds' + , pat_ext = noExtField + , pat_mult = HsUnannotated EpPatBind + } } + +cvtDec (TH.FunD nm cls) + | null cls + = failWith $ FunBindLacksEquations nm + | otherwise + = do { nm' <- vNameN nm + ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm' noAnn)) cls + ; th_origin <- getOrigin + ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' } + +cvtDec (TH.SigD nm typ) + = do { nm' <- vNameN nm + ; ty' <- cvtSigType typ + ; returnJustLA $ Hs.SigD noExtField + (TypeSig noAnn [nm'] (mkHsWildCardBndrs ty')) } + +cvtDec (TH.KiSigD nm ki) + = do { nm' <- tconNameN nm + ; ki' <- cvtSigKind ki + ; let sig' = StandaloneKindSig noAnn nm' ki' + ; returnJustLA $ Hs.KindSigD noExtField sig' } + +cvtDec (TH.InfixD fx th_ns_spec nm) + -- Fixity signatures are allowed for variables, constructors, and types + -- the renamer automatically looks for types during renaming, even when + -- the RdrName says it's a variable or a constructor. So, just assume + -- it's a variable or constructor and proceed. + = do { nm' <- vcNameN nm + ; returnJustLA (Hs.SigD noExtField (FixSig noAnn + (FixitySig ns_spec [nm'] (cvtFixity fx)))) } + where + ns_spec = case th_ns_spec of + TH.NoNamespaceSpecifier -> Hs.NoNamespaceSpecifier + TH.TypeNamespaceSpecifier -> Hs.TypeNamespaceSpecifier noAnn + TH.DataNamespaceSpecifier -> Hs.DataNamespaceSpecifier noAnn + +cvtDec (TH.DefaultD tys) + = do { tys' <- traverse cvtType tys + ; returnJustLA (Hs.DefD noExtField $ DefaultDecl noAnn Nothing tys') } + +cvtDec (PragmaD prag) + = cvtPragmaD prag + +cvtDec (TySynD tc tvs rhs) + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs + ; rhs' <- cvtType rhs + ; returnJustLA $ TyClD noExtField $ + SynDecl { tcdSExt = noAnn, tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdRhs = rhs' } } + +cvtDec (DataD ctxt tc tvs ksig constrs derivs) + = cvtDataDec ctxt tc tvs ksig constrs derivs + +cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) + = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs + ; ksig' <- cvtKind `traverse` ksig + ; con' <- cvtDataDefnCons False ksig $ NewTypeCon constr + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ext = noAnn + , dd_cType = Nothing + , dd_ctxt = mkHsContextMaybe ctxt' + , dd_kindSig = ksig' + , dd_cons = con' + , dd_derivs = derivs' } + ; returnJustLA $ TyClD noExtField $ + DataDecl { tcdDExt = noExtField + , tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdDataDefn = defn } } + +cvtDec (TypeDataD tc tvs ksig constrs) + = cvtTypeDataDec tc tvs ksig constrs + +cvtDec (ClassD ctxt cl tvs fds decs) + = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs + ; fds' <- mapM cvt_fundep fds + ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs ClssDecl decs + ; unless (null adts') + (failWith $ DefaultDataInstDecl adts') + ; returnJustLA $ TyClD noExtField $ + ClassDecl { tcdCExt = (noAnn, EpNoLayout, NoAnnSortKey) + , tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' + , tcdMeths = binds' + , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] } + -- no docs in TH ^^ + } + +cvtDec (InstanceD o ctxt ty decs) + = do { (binds', sigs', fams', ats', adts') <- cvt_ci_decs InstanceDecl decs + ; for_ (nonEmpty fams') $ \ bad_fams -> + failWith (IllegalDeclaration InstanceDecl $ IllegalFamDecls bad_fams) + ; ctxt' <- cvtContext funPrec ctxt + ; (L loc ty') <- cvtType ty + ; let inst_ty' = L loc $ mkHsImplicitSigType $ + mkHsQualTy ctxt loc ctxt' $ L loc ty' + ; returnJustLA $ InstD noExtField $ ClsInstD noExtField $ + ClsInstDecl { cid_ext = (Nothing, noAnn, NoAnnSortKey), cid_poly_ty = inst_ty' + , cid_binds = binds' + , cid_sigs = Hs.mkClassOpSigs sigs' + , cid_tyfam_insts = ats', cid_datafam_insts = adts' + , cid_overlap_mode + = fmap (L (l2l loc) . overlap) o } } + where + overlap pragma = + case pragma of + TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "{-# OVERLAPS") + TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "{-# OVERLAPPABLE") + TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "{-# OVERLAPPING") + TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "{-# INCOHERENT") + + + + +cvtDec (ForeignD ford) + = do { ford' <- cvtForD ford + ; returnJustLA $ ForD noExtField ford' } + +cvtDec (DataFamilyD tc tvs kind) + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs + ; result <- cvtMaybeKindToFamilyResultSig kind + ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $ + FamilyDecl noAnn DataFamily TopLevel tc' tvs' Prefix result Nothing } + +cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) + = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys + ; ksig' <- cvtKind `traverse` ksig + ; cons' <- cvtDataDefnCons False ksig $ DataTypeCons False constrs + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ext = noAnn + , dd_cType = Nothing + , dd_ctxt = mkHsContextMaybe ctxt' + , dd_kindSig = ksig' + , dd_cons = cons' + , dd_derivs = derivs' } + + ; returnJustLA $ InstD noExtField $ DataFamInstD + { dfid_ext = noExtField + , dfid_inst = DataFamInstDecl { dfid_eqn = + FamEqn { feqn_ext = noAnn + , feqn_tycon = tc' + , feqn_bndrs = bndrs' + , feqn_pats = typats' + , feqn_rhs = defn + , feqn_fixity = Prefix } }}} + +cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) + = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys + ; ksig' <- cvtKind `traverse` ksig + ; con' <- cvtDataDefnCons False ksig $ NewTypeCon constr + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ext = noAnn + , dd_cType = Nothing + , dd_ctxt = mkHsContextMaybe ctxt' + , dd_kindSig = ksig' + , dd_cons = con' + , dd_derivs = derivs' } + ; returnJustLA $ InstD noExtField $ DataFamInstD + { dfid_ext = noExtField + , dfid_inst = DataFamInstDecl { dfid_eqn = + FamEqn { feqn_ext = noAnn + , feqn_tycon = tc' + , feqn_bndrs = bndrs' + , feqn_pats = typats' + , feqn_rhs = defn + , feqn_fixity = Prefix } }}} + +cvtDec (TySynInstD eqn) + = do { (L _ eqn') <- cvtTySynEqn eqn + ; returnJustLA $ InstD noExtField $ TyFamInstD + { tfid_ext = noExtField + , tfid_inst = TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = eqn' } }} + +cvtDec (OpenTypeFamilyD head) + = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head + ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $ + FamilyDecl noAnn OpenTypeFamily TopLevel tc' tyvars' Prefix result' injectivity' + } + +cvtDec (ClosedTypeFamilyD head eqns) + = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head + ; eqns' <- mapM cvtTySynEqn eqns + ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $ + FamilyDecl noAnn (ClosedTypeFamily (Just eqns')) TopLevel tc' tyvars' Prefix + result' injectivity' } + +cvtDec (TH.RoleAnnotD tc roles) + = do { tc' <- tconNameN tc + ; roles' <- traverse (returnLA . cvtRole) roles + ; returnJustLA + $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') } + +cvtDec (TH.StandaloneDerivD ds cxt ty) + = do { cxt' <- cvtContext funPrec cxt + ; ds' <- traverse cvtDerivStrategy ds + ; (L loc ty') <- cvtType ty + ; let inst_ty' = L loc $ mkHsImplicitSigType $ + mkHsQualTy cxt loc cxt' $ L loc ty' + ; returnJustLA $ DerivD noExtField $ + DerivDecl { deriv_ext = (Nothing, noAnn) + , deriv_strategy = ds' + , deriv_type = mkHsWildCardBndrs inst_ty' + , deriv_overlap_mode = Nothing } } + +cvtDec (TH.DefaultSigD nm typ) + = do { nm' <- vNameN nm + ; ty' <- cvtSigType typ + ; returnJustLA $ Hs.SigD noExtField + $ ClassOpSig noAnn True [nm'] ty'} + +cvtDec (TH.PatSynD nm args dir pat) + = do { nm' <- cNameN nm + ; args' <- cvtArgs args + ; dir' <- cvtDir nm' dir + ; pat' <- cvtPat pat + ; returnJustLA $ Hs.ValD noExtField $ PatSynBind noExtField $ + PSB noAnn nm' args' pat' dir' } + where + cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameN args + cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameN a1 <*> vNameN a2 + cvtArgs (TH.RecordPatSyn sels) + = do { let mk_fld = fldNameN (nameBase nm) + ; sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . mk_fld) sels + ; vars' <- mapM (vNameN . mkNameS . nameBase) sels + ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' } + + -- cvtDir :: LocatedN RdrName -> (PatSynDir -> CvtM (HsPatSynDir RdrName)) + cvtDir _ Unidir = return Unidirectional + cvtDir _ ImplBidir = return ImplicitBidirectional + cvtDir n (ExplBidir cls) = + do { ms <- mapM (cvtClause (mkPrefixFunRhs n noAnn)) cls + ; th_origin <- getOrigin + ; wrapParLA (ExplicitBidirectional . mkMatchGroup th_origin) ms } + +cvtDec (TH.PatSynSigD nm ty) + = do { nm' <- cNameN nm + ; ty' <- cvtPatSynSigTy ty + ; returnJustLA $ Hs.SigD noExtField $ PatSynSig noAnn [nm'] ty'} + +-- Implicit parameter bindings are handled in cvtLocalDecs and +-- cvtImplicitParamBind. They are not allowed in any other scope, so +-- reaching this case indicates an error. +cvtDec (TH.ImplicitParamBindD _ _) + = failWith InvalidImplicitParamBinding + +-- Convert a @data@ declaration. +cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis] + -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause] + -> CvtM (Maybe (LHsDecl GhcPs)) +cvtDataDec = cvtGenDataDec False + +-- Convert a @type data@ declaration. +-- These have neither contexts nor derived clauses. +-- See Note [Type data declarations] in GHC.Rename.Module. +cvtTypeDataDec :: TH.Name -> [TH.TyVarBndr TH.BndrVis] -> Maybe TH.Kind -> [TH.Con] + -> CvtM (Maybe (LHsDecl GhcPs)) +cvtTypeDataDec tc tvs ksig constrs + = cvtGenDataDec True [] tc tvs ksig constrs [] + +-- Convert a @data@ or @type data@ declaration (flagged by the Bool arg). +-- See Note [Type data declarations] in GHC.Rename.Module. +cvtGenDataDec :: Bool -> TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis] + -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause] + -> CvtM (Maybe (LHsDecl GhcPs)) +cvtGenDataDec type_data ctxt tc tvs ksig constrs derivs + = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs + ; ksig' <- cvtKind `traverse` ksig + ; cons' <- cvtDataDefnCons type_data ksig $ + DataTypeCons type_data constrs + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ext = noAnn + , dd_cType = Nothing + , dd_ctxt = mkHsContextMaybe ctxt' + , dd_kindSig = ksig' + , dd_cons = cons' + , dd_derivs = derivs' } + ; returnJustLA $ TyClD noExtField $ + DataDecl { tcdDExt = noExtField + , tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdDataDefn = defn } } + +-- Convert a set of data constructors. +cvtDataDefnCons :: + Bool -> Maybe TH.Kind -> + DataDefnCons TH.Con -> CvtM (DataDefnCons (LConDecl GhcPs)) +cvtDataDefnCons type_data ksig constrs + = do { let isGadtCon (GadtC _ _ _) = True + isGadtCon (RecGadtC _ _ _) = True + isGadtCon (ForallC _ _ c) = isGadtCon c + isGadtCon _ = False + isGadtDecl = all isGadtCon constrs + isH98Decl = all (not . isGadtCon) constrs + -- A constructor in a @data@ or @newtype@ declaration is + -- a data constructor. A constructor in a @type data@ + -- declaration is a type constructor. + -- See Note [Type data declarations] in GHC.Rename.Module. + con_name + | type_data = tconNameN + | otherwise = cNameN + ; unless (isGadtDecl || isH98Decl) + (failWith CannotMixGADTConsWith98Cons) + ; unless (isNothing ksig || isGadtDecl) + (failWith KindSigsOnlyAllowedOnGADTs) + + ; let first_datacon = + case firstDataDefnCon constrs of + Nothing -> panic "cvtDataDefnCons: empty list of constructors" + Just con -> con + first_datacon_name = + case get_cons_names first_datacon of + [] -> panic "cvtDataDefnCons: data constructor with no names" + c:_ -> c + ; mapM (cvtConstr first_datacon_name con_name) constrs } + +---------------- +cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs) +cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) + = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs + ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs mb_bndrs' + ; (head_ty, args) <- split_ty_app lhs + ; case head_ty of + ConT nm -> do { nm' <- tconNameN nm + ; rhs' <- cvtType rhs + ; let args' = map wrap_tyarg args + ; returnLA + $ FamEqn { feqn_ext = noAnn + , feqn_tycon = nm' + , feqn_bndrs = outer_bndrs + , feqn_pats = args' + , feqn_fixity = Prefix + , feqn_rhs = rhs' } } + InfixT t1 nm t2 -> do { nm' <- tconNameN nm + ; args' <- mapM cvtType [t1,t2] + ; rhs' <- cvtType rhs + ; returnLA + $ FamEqn { feqn_ext = noAnn + , feqn_tycon = nm' + , feqn_bndrs = outer_bndrs + , feqn_pats = + (map (HsValArg noExtField) args') ++ args + , feqn_fixity = Hs.Infix + , feqn_rhs = rhs' } } + _ -> failWith $ InvalidTyFamInstLHS lhs + } + +---------------- +cvt_ci_decs :: THDeclDescriptor -> [TH.Dec] + -> CvtM (LHsBinds GhcPs, + [LSig GhcPs], + [LFamilyDecl GhcPs], + [LTyFamInstDecl GhcPs], + [LDataFamInstDecl GhcPs]) +-- Convert the declarations inside a class or instance decl +-- ie signatures, bindings, and associated types +cvt_ci_decs declDescr decs + = do { decs' <- cvtDecs decs + ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs' + ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs' + ; let (sigs', prob_binds') = partitionWith is_sig no_ats' + ; let (binds', prob_fams') = partitionWith is_bind prob_binds' + ; let (fams', bads) = partitionWith is_fam_decl prob_fams' + ; for_ (nonEmpty bads) $ \ bad_decls -> + failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls) + ; return (binds', sigs', fams', ats', adts') } + +---------------- +cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis] + -> CvtM ( LHsContext GhcPs + , LocatedN RdrName + , LHsQTyVars GhcPs) +cvt_tycl_hdr cxt tc tvs + = do { cxt' <- cvtContext funPrec cxt + ; tc' <- tconNameN tc + ; tvs' <- cvtTvs tvs + ; return (cxt', tc', mkHsQTvs tvs') + } + +cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type + -> CvtM ( LHsContext GhcPs + , LocatedN RdrName + , HsOuterFamEqnTyVarBndrs GhcPs + , HsFamEqnPats GhcPs) +cvt_datainst_hdr cxt bndrs tys + = do { cxt' <- cvtContext funPrec cxt + ; bndrs' <- traverse (mapM cvt_tv) bndrs + ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs bndrs' + ; (head_ty, args) <- split_ty_app tys + ; case head_ty of + ConT nm -> do { nm' <- tconNameN nm + ; let args' = map wrap_tyarg args + ; return (cxt', nm', outer_bndrs, args') } + InfixT t1 nm t2 -> do { nm' <- tconNameN nm + ; args' <- mapM cvtType [t1,t2] + ; return (cxt', nm', outer_bndrs, + ((map (HsValArg noExtField) args') ++ args)) } + _ -> failWith $ InvalidTypeInstanceHeader tys } + +---------------- +cvt_tyfam_head :: TypeFamilyHead + -> CvtM ( LocatedN RdrName + , LHsQTyVars GhcPs + , Hs.LFamilyResultSig GhcPs + , Maybe (Hs.LInjectivityAnn GhcPs)) + +cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) + = do { (_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars + ; result' <- cvtFamilyResultSig result + ; injectivity' <- traverse cvtInjectivityAnnotation injectivity + ; return (tc', tyvars', result', injectivity') } + +------------------------------------------------------------------- +-- Partitioning declarations +------------------------------------------------------------------- + +is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs) +is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d) +is_fam_decl decl = Right decl + +is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs) +is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) + = Left (L loc d) +is_tyfam_inst decl + = Right decl + +is_datafam_inst :: LHsDecl GhcPs + -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs) +is_datafam_inst (L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) + = Left (L loc d) +is_datafam_inst decl + = Right decl + +is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs) +is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig) +is_sig decl = Right decl + +is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs) +is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind) +is_bind decl = Right decl + +is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec +is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) +is_ip_bind decl = Right decl + +--------------------------------------------------- +-- Data types +--------------------------------------------------- + +cvtConstr :: TH.Name -- ^ name of first constructor of parent type + -> (TH.Name -> CvtM (LocatedN RdrName)) -- ^ convert constructor name + -> TH.Con -> CvtM (LConDecl GhcPs) + +cvtConstr _ do_con_name (NormalC c strtys) + = do { c' <- do_con_name c + ; tys' <- mapM cvt_arg strtys + ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon tys') } + +cvtConstr parent_con do_con_name (RecC c varstrtys) + = do { c' <- do_con_name c + ; args' <- mapM (cvt_id_arg parent_con) varstrtys + ; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args' + ; returnLA con_decl } + +cvtConstr _ do_con_name (InfixC st1 c st2) + = do { c' <- do_con_name c + ; st1' <- cvt_arg st1 + ; st2' <- cvt_arg st2 + ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing + (InfixCon st1' st2') } + +cvtConstr parent_con do_con_name (ForallC tvs ctxt con) + = do { tvs' <- cvtTvs tvs + ; ctxt' <- cvtContext funPrec ctxt + ; L _ con' <- cvtConstr parent_con do_con_name con + ; returnLA $ add_forall tvs' ctxt' con' } + where + add_cxt lcxt Nothing = mkHsContextMaybe lcxt + add_cxt (L loc cxt1) (Just (L _ cxt2)) + = Just (L loc (cxt1 ++ cxt2)) + + -- Nested foralls end up flattened (see tests/th/GadtConSigs_th_dump1.stderr) + -- but it doesn't seem to matter. + add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs + -> ConDecl GhcPs -> ConDecl GhcPs + add_forall tvs' cxt' con@(ConDeclGADT { con_outer_bndrs = L l outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = cxt }) + = con { con_outer_bndrs = L l outer_bndrs' + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = add_cxt cxt' cxt } + where + outer_bndrs' + | null all_tvs = mkHsOuterImplicit + | otherwise = mkHsOuterExplicit noAnn all_tvs + + all_tvs = tvs' ++ outer_exp_tvs + + outer_exp_tvs = hsOuterExplicitBndrs outer_bndrs + + add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt }) + = con { con_forall = not (null all_tvs) + , con_ex_tvs = all_tvs + , con_mb_cxt = add_cxt cxt' cxt } + where + all_tvs = tvs' ++ ex_tvs + +cvtConstr _ do_con_name (GadtC c strtys ty) = case nonEmpty c of + Nothing -> failWith GadtNoCons + Just c -> do + { c' <- mapM do_con_name c + ; args <- mapM cvt_arg strtys + ; ty' <- cvtType ty + ; mk_gadt_decl c' (PrefixConGADT noExtField args) ty'} + +cvtConstr parent_con do_con_name (RecGadtC c varstrtys ty) = case nonEmpty c of + Nothing -> failWith RecGadtNoCons + Just c -> do + { c' <- mapM do_con_name c + ; ty' <- cvtType ty + ; rec_flds <- mapM (cvt_id_arg parent_con) varstrtys + ; lrec_flds <- returnLA rec_flds + ; mk_gadt_decl c' (RecConGADT noAnn lrec_flds) ty' } + +mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs + -> CvtM (LConDecl GhcPs) +mk_gadt_decl names args res_ty + = do outer_bndrs <- returnLA mkHsOuterImplicit + returnLA $ ConDeclGADT + { con_g_ext = noAnn + , con_names = names + , con_outer_bndrs = outer_bndrs + , con_inner_bndrs = [] + , con_mb_cxt = Nothing + , con_g_args = args + , con_res_ty = res_ty + , con_doc = Nothing } + +cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness +cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack +cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack +cvtSrcUnpackedness SourceUnpack = SrcUnpack + +cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness +cvtSrcStrictness NoSourceStrictness = NoSrcStrict +cvtSrcStrictness SourceLazy = SrcLazy +cvtSrcStrictness SourceStrict = SrcStrict + +cvt_arg :: (TH.Bang, TH.Type) -> CvtM (HsConDeclField GhcPs) +cvt_arg (Bang su ss, ty) + = do { ty'' <- cvtType ty + ; let ty' = parenthesizeHsType appPrec ty'' + su' = cvtSrcUnpackedness su + ss' = cvtSrcStrictness ss + ; return $ CDF noAnn su' ss' (HsUnannotated (EpColon noAnn)) ty' Nothing } + +cvt_id_arg :: TH.Name -- ^ parent constructor name + -> (TH.Name, TH.Bang, TH.Type) -> CvtM (LHsConDeclRecField GhcPs) +cvt_id_arg parent_con (i, str, ty) + = do { L li i' <- fldNameN (nameBase parent_con) i + ; ty' <- cvt_arg (str,ty) + ; returnLA $ HsConDeclRecField + { cdrf_ext = noExtField + , cdrf_names + = [L (l2l li) $ FieldOcc noExtField (L li i')] + , cdrf_spec = ty' } } + +cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) +cvtDerivs cs = do { mapM cvtDerivClause cs } + +cvt_fundep :: TH.FunDep -> CvtM (LHsFunDep GhcPs) +cvt_fundep (TH.FunDep xs ys) = do { xs' <- mapM tNameN xs + ; ys' <- mapM tNameN ys + ; returnLA (Hs.FunDep noAnn xs' ys') } + + +------------------------------------------ +-- Foreign declarations +------------------------------------------ + +cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs) +cvtForD (ImportF callconv safety from nm ty) = + do { ls <- getL + ; let l = l2l ls + ; if -- the prim and javascript calling conventions do not support headers + -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess + | callconv == TH.Prim || callconv == TH.JavaScript + -> mk_imp (CImport (L l $ quotedSourceText from) (L l (cvt_conv callconv)) (L l safety') Nothing + (CFunction (StaticTarget (SourceText fromtxt) + fromtxt Nothing + True))) + | Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety') + (mkFastString (TH.nameBase nm)) + from (L ls $ quotedSourceText from) + -> mk_imp impspec + | otherwise + -> failWith $ InvalidCCallImpent from } + where + fromtxt = mkFastString from + mk_imp impspec + = do { nm' <- vNameN nm + ; ty' <- cvtSigType ty + ; return (ForeignImport { fd_i_ext = noAnn + , fd_name = nm' + , fd_sig_ty = ty' + , fd_fi = impspec }) + } + safety' = case safety of + Unsafe -> PlayRisky + Safe -> PlaySafe + Interruptible -> PlayInterruptible + +cvtForD (ExportF callconv as nm ty) + = do { nm' <- vNameN nm + ; ty' <- cvtSigType ty + ; ls <- getL + ; let l = l2l ls + ; let astxt = mkFastString as + ; let e = CExport (L l (SourceText astxt)) (L l (CExportStatic (SourceText astxt) + astxt + (cvt_conv callconv))) + ; return $ ForeignExport { fd_e_ext = noAnn + , fd_name = nm' + , fd_sig_ty = ty' + , fd_fe = e } } + +cvt_conv :: TH.Callconv -> CCallConv +cvt_conv TH.CCall = CCallConv +cvt_conv TH.StdCall = StdCallConv +cvt_conv TH.CApi = CApiConv +cvt_conv TH.Prim = PrimCallConv +cvt_conv TH.JavaScript = JavaScriptCallConv + +------------------------------------------ +-- Pragmas +------------------------------------------ + +cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs)) +cvtPragmaD (InlineP nm inline rm phases) + = do { -- NB: Use vcNameN here, which works for both the variable namespace + -- (e.g., `INLINE`d functions) and the constructor namespace + -- (e.g., `INLINE`d pattern synonyms, cf. #23203) + nm' <- vcNameN nm + ; let dflt = dfltActivation inline + ; let src TH.NoInline = fsLit "{-# NOINLINE" + src TH.Inline = fsLit "{-# INLINE" + src TH.Inlinable = fsLit "{-# INLINABLE" + ; let ip = InlinePragma { inl_src = toSrcTxt inline + , inl_inline = cvtInline inline (toSrcTxt inline) + , inl_rule = cvtRuleMatch rm + , inl_act = cvtPhases phases dflt + , inl_sat = Nothing } + where + toSrcTxt a = SourceText $ src a + ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip } + +cvtPragmaD (OpaqueP nm) + = do { nm' <- vNameN nm + ; let ip = InlinePragma { inl_src = srcTxt + , inl_inline = Opaque srcTxt + , inl_rule = Hs.FunLike + , inl_act = NeverActive + , inl_sat = Nothing } + where + srcTxt = SourceText $ fsLit "{-# OPAQUE" + ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip } + +cvtPragmaD (SpecialiseInstP ty) + = do { ty' <- cvtSigType ty + ; returnJustLA $ Hs.SigD noExtField $ + SpecInstSig (noAnn, (SourceText $ fsLit "{-# SPECIALISE")) ty' } + +cvtPragmaD (SpecialiseEP ty_bndrs tm_bndrs exp inline phases) + = do { ty_bndrs' <- traverse cvtTvs ty_bndrs + ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs + ; let ip = cvtInlinePhases inline phases + ; exp' <- cvtl exp + ; let bndrs' = RuleBndrs { rb_ext = noAnn, rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' } + ; returnJustLA $ Hs.SigD noExtField $ + SpecSigE noAnn bndrs' exp' ip + } + +cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) + = do { let nm' = mkFastString nm + ; rd_name' <- returnLA nm' + ; let act = cvtPhases phases AlwaysActive + ; ty_bndrs' <- traverse cvtTvs ty_bndrs + ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs + ; lhs' <- cvtl lhs + ; rhs' <- cvtl rhs + ; rule <- returnLA $ + HsRule { rd_ext = (noAnn, quotedSourceText nm) + , rd_name = rd_name' + , rd_act = act + , rd_bndrs = RuleBndrs { rb_ext = noAnn, rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' } + , rd_lhs = lhs' + , rd_rhs = rhs' } + ; returnJustLA $ Hs.RuleD noExtField + $ HsRules { rds_ext = (noAnn, SourceText $ fsLit "{-# RULES") + , rds_rules = [rule] } + + } + +cvtPragmaD (AnnP target exp) + = do { exp' <- cvtl exp + ; target' <- case target of + ModuleAnnotation -> return ModuleAnnProvenance + TypeAnnotation n -> do + n' <- tconName n + wrapParLA TypeAnnProvenance n' + ValueAnnotation n -> do + n' <- vcName n + wrapParLA ValueAnnProvenance n' + ; returnJustLA $ Hs.AnnD noExtField + $ HsAnnotation (noAnn, (SourceText $ fsLit "{-# 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' <- mapM cNameN cls + ; mty' <- traverse tconNameN mty + ; returnJustLA $ Hs.SigD noExtField + $ CompleteMatchSig (noAnn, NoSourceText) cls' mty' } +cvtPragmaD (SCCP nm str) = do + nm' <- vcNameN nm + str' <- traverse (\s -> + returnLA $ StringLiteral NoSourceText (mkFastString s) Nothing) str + returnJustLA $ Hs.SigD noExtField + $ SCCFunSig (noAnn, SourceText $ fsLit "{-# SCC") nm' str' + +dfltActivation :: TH.Inline -> Activation +dfltActivation TH.NoInline = NeverActive +dfltActivation _ = AlwaysActive + +cvtInline :: TH.Inline -> SourceText -> Hs.InlineSpec +cvtInline TH.NoInline srcText = Hs.NoInline srcText +cvtInline TH.Inline srcText = Hs.Inline srcText +cvtInline TH.Inlinable srcText = Hs.Inlinable srcText + +cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo +cvtRuleMatch TH.ConLike = Hs.ConLike +cvtRuleMatch TH.FunLike = Hs.FunLike + +cvtPhases :: TH.Phases -> Activation -> Activation +cvtPhases AllPhases dflt = dflt +cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i +cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i + +cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) +cvtRuleBndr (RuleVar n) + = do { n' <- vNameN n + ; returnLA $ Hs.RuleBndr noAnn n' } +cvtRuleBndr (TypedRuleVar n ty) + = do { n' <- vNameN n + ; ty' <- cvtType ty + ; returnLA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' } + +cvtInlinePhases :: Maybe Inline -> Phases -> InlinePragma +cvtInlinePhases inline phases = + let src TH.NoInline = fsLit "{-# SPECIALISE NOINLINE" + src TH.Inline = fsLit "{-# SPECIALISE INLINE" + src TH.Inlinable = fsLit "{-# SPECIALISE INLINE" + (inline', dflt, srcText) = case inline of + Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1, + toSrcTxt inline1) + Nothing -> (NoUserInlinePrag, AlwaysActive, + SourceText $ fsLit "{-# SPECIALISE") + where + toSrcTxt a = SourceText $ src a + in InlinePragma { inl_src = srcText + , inl_inline = inline' + , inl_rule = Hs.FunLike + , inl_act = cvtPhases phases dflt + , inl_sat = Nothing } + +--------------------------------------------------- +-- Declarations +--------------------------------------------------- + +cvtLocalDecs :: THDeclDescriptor -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) +cvtLocalDecs declDescr ds + = case partitionWith is_ip_bind ds of + ([], []) -> return (EmptyLocalBinds noExtField) + ([], _) -> do + ds' <- cvtDecs ds + let (binds, prob_sigs) = partitionWith is_bind ds' + let (sigs, bads) = partitionWith is_sig prob_sigs + for_ (nonEmpty bads) $ \ bad_decls -> + failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls) + return (HsValBinds noAnn (ValBinds NoAnnSortKey binds sigs)) + (ip_binds, []) -> do + binds <- mapM (uncurry cvtImplicitParamBind) ip_binds + return (HsIPBinds noAnn (IPBinds noExtField binds)) + ((_:_), (_:_)) -> + failWith ImplicitParamsWithOtherBinds + +cvtClause :: HsMatchContextPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) +cvtClause ctxt (Clause ps body wheres) + = do { ps' <- cvtPats ps + ; let pps = map (parenthesizePat appPrec) ps' + ; g' <- cvtGuard body + ; ds' <- cvtLocalDecs WhereClause wheres + ; returnLA $ Hs.Match noExtField ctxt (noLocA pps) (GRHSs emptyComments g' ds') } + +cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) +cvtImplicitParamBind n e = do + n' <- wrapL (ipName n) + e' <- cvtl e + returnLA (IPBind noAnn (reLoc n') e') + +------------------------------------------------------------------- +-- Expressions +------------------------------------------------------------------- + +cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) +cvtl e = wrapLA (cvt e) + where + cvt (VarE s) = do { s' <- vName s; wrapParLA mkHsVar s' } + cvt (ConE s) = do { s' <- dName s; wrapParLA mkHsVar s' } + cvt (LitE l) + | overloadedLit l = go cvtOverLit (HsOverLit noExtField) + (hsOverLitNeedsParens appPrec) + | otherwise = go cvtLit (HsLit noExtField) + (hsLitNeedsParens appPrec) + where + go :: (Lit -> CvtM (l GhcPs)) + -> (l GhcPs -> HsExpr GhcPs) + -> (l GhcPs -> Bool) + -> CvtM (HsExpr GhcPs) + go cvt_lit mk_expr is_compound_lit = do + l' <- cvt_lit l + let e' = mk_expr l' + if is_compound_lit l' then wrapParLA gHsPar e' else pure e' + cvt (AppE e1 e2) = do { e1' <- parenthesizeHsExpr opPrec <$> cvtl e1 + ; e2' <- parenthesizeHsExpr appPrec <$> cvtl e2 + ; return $ HsApp noExtField e1' e2' } + cvt (AppTypeE e t) = do { e' <- parenthesizeHsExpr opPrec <$> cvtl e + ; t' <- parenthesizeHsType appPrec <$> cvtType t + ; return $ HsAppType noAnn e' + $ mkHsWildCardBndrs t' } + cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its + -- own expression to avoid pretty-printing + -- oddities that can result from zero-argument + -- lambda expressions. See #13856. + cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e + ; let pats = map (parenthesizePat appPrec) ps' + ; th_origin <- getOrigin + ; wrapParLA (HsLam noAnn LamSingle . mkMatchGroup th_origin) + [mkSimpleMatch (LamAlt LamSingle) (noLocA pats) e']} + cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch $ LamAlt LamCase) ms + ; th_origin <- getOrigin + ; wrapParLA (HsLam noAnn LamCase . mkMatchGroup th_origin) ms' + } + cvt (LamCasesE ms) + | null ms = failWith CasesExprWithoutAlts + | otherwise = do { ms' <- mapM (cvtClause $ LamAlt LamCases) ms + ; th_origin <- getOrigin + ; wrapParLA (HsLam noAnn LamCases . mkMatchGroup th_origin) ms' + } + cvt (TupE es) = cvt_tup es Boxed + cvt (UnboxedTupE es) = cvt_tup es Unboxed + cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e + ; unboxedSumChecks alt arity + ; return $ ExplicitSum noAnn alt arity e'} + cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; + ; return $ mkHsIf x' y' z' noAnn } + cvt (MultiIfE alts) = case nonEmpty alts of + Nothing -> failWith MultiWayIfWithoutAlts + Just alts -> HsMultiIf noAnn <$> traverse cvtpair alts + cvt (LetE ds e) = do { ds' <- cvtLocalDecs LetExpression ds + ; e' <- cvtl e; return $ HsLet noAnn ds' e'} + cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms + ; th_origin <- getOrigin + ; wrapParLA (HsCase noAnn e' . mkMatchGroup th_origin) ms' } + cvt (DoE m ss) = cvtHsDo (DoExpr (mk_mod <$> m)) ss + cvt (MDoE m ss) = cvtHsDo (MDoExpr (mk_mod <$> m)) ss + cvt (CompE ss) = cvtHsDo ListComp ss + cvt (ArithSeqE dd) = do { dd' <- cvtDD dd + ; return $ ArithSeq noAnn Nothing dd' } + cvt (ListE xs) + | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s) + ; return (HsLit noExtField l') } + -- Note [Converting strings] + | otherwise = do { xs' <- mapM cvtl xs + ; return $ ExplicitList noAnn xs' + } + + -- Infix expressions + cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $ + do { x' <- cvtl x + ; s' <- cvtl s + ; y' <- cvtl y + ; let px = parenthesizeHsExpr opPrec x' + py = parenthesizeHsExpr opPrec y' + ; wrapParLA gHsPar + $ OpApp noExtField px s' py } + -- Parenthesise both arguments and result, + -- to ensure this operator application does + -- does not get re-associated + -- See Note [Operator association] + cvt (InfixE Nothing s (Just y)) = ensureValidOpExp s $ + do { s' <- cvtl s; y' <- cvtl y + ; wrapParLA gHsPar $ + SectionR noExtField s' y' } + -- See Note [Sections in HsSyn] in GHC.Hs.Expr + cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $ + do { x' <- cvtl x; s' <- cvtl s + ; wrapParLA gHsPar $ + SectionL noExtField x' s' } + + cvt (InfixE Nothing s Nothing ) = ensureValidOpExp s $ + do { s' <- cvtl s + ; return $ gHsPar s' } + -- Can I indicate this is an infix thing? + -- Note [Dropping constructors] + + cvt (UInfixE x s y) = ensureValidOpExp s $ + do { x' <- cvtl x + ; let x'' = case unLoc x' of + OpApp {} -> x' + _ -> mkLHsPar x' + ; cvtOpApp x'' s y } -- Note [Converting UInfix] + + cvt (ParensE e) = do { e' <- cvtl e; return $ gHsPar e' } + cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtSigType t + ; let pe = parenthesizeHsExpr sigPrec e' + ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') } + cvt (RecConE c flds) = do { c' <- cNameN c + ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds + ; return $ mkRdrRecordCon c' (HsRecFields noExtField flds' Nothing) noAnn } + cvt (RecUpdE e flds) = do { e' <- cvtl e + ; flds' + <- mapM (cvtFld (wrapParLA mkFieldOcc)) + flds + ; return $ RecordUpd noAnn e' $ + RegularRecUpdFields + { xRecUpdFields = noExtField + , recUpdFields = flds' } } + cvt (StaticE e) = fmap (HsStatic noAnn) $ cvtl e + cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is + -- important, because UnboundVarE may contain + -- constructor names - see #14627. + { s' <- vcName s + ; wrapParLA mkHsVar s' } + cvt (LabelE s) = return $ HsOverLabel NoSourceText (fsLit s) + cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } + cvt (GetFieldE exp f) = do { e' <- cvtl exp + ; return $ HsGetField noExtField e' + (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) } + cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap + (DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString . fsLit) xs + cvt (TypedSpliceE e) = do { e' <- parenthesizeHsExpr appPrec <$> cvtl e + ; return $ HsTypedSplice noExtField (HsTypedSpliceExpr noAnn e') } + cvt (TypedBracketE e) = do { e' <- cvtl e + ; return $ HsTypedBracket noAnn e' } + cvt (TypeE t) = do { t' <- cvtType t + ; return $ HsEmbTy noAnn (mkHsWildCardBndrs t') } + cvt (ConstrainedE ctx body) = do { ctx' <- mapM cvtl ctx + ; body' <- cvtl body + ; return $ HsQual noExtField (L noAnn ctx') body' } + cvt (ForallE tvs body) = + do { tvs' <- cvtTvs tvs + ; body' <- cvtl body + ; let tele = setTelescopeBndrsNameSpace varName $ + mkHsForAllInvisTele noAnn tvs' + ; return $ HsForAll noExtField tele body' } + cvt (ForallVisE tvs body) = + do { tvs' <- cvtTvs tvs + ; body' <- cvtl body + ; let tele = setTelescopeBndrsNameSpace varName $ + mkHsForAllVisTele noAnn tvs' + ; return $ HsForAll noExtField tele body' } + +{- | #16895 Ensure an infix expression's operator is a variable/constructor. +Consider this example: + + $(uInfixE [|1|] [|id id|] [|2|]) + +This infix expression is obviously ill-formed so we use this helper function +to reject such programs outright. + +The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp` +in Language.Haskell.TH.Ppr from the template-haskell library. +-} +ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a +ensureValidOpExp (VarE _n) m = m +ensureValidOpExp (ConE _n) m = m +ensureValidOpExp (UnboundVarE _n) m = m +ensureValidOpExp _e _m = failWith NonVarInInfixExpr + +{- Note [Dropping constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we drop constructors from the input, we must insert parentheses around the +argument. For example: + + UInfixE x * (AppE (InfixE (Just y) + Nothing) z) + +If we convert the InfixE expression to an operator section but don't insert +parentheses, the above expression would be reassociated to + + OpApp (OpApp x * y) + z + +which we don't want. +-} + +cvtFld :: (RdrName -> CvtM t) -> (TH.Name, TH.Exp) + -> CvtM (LHsFieldBind GhcPs (LocatedA t) (LHsExpr GhcPs)) +cvtFld f (v,e) + = do { v' <- vNameL v + ; lhs' <- traverse f v' + ; e' <- cvtl e + ; returnLA $ HsFieldBind { hfbAnn = noAnn + , hfbLHS = la2la lhs' + , hfbRHS = e' + , hfbPun = False} } + +cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) +cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } +cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' } +cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } +cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } + +cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs) +cvt_tup es boxity = do { let cvtl_maybe Nothing = return (missingTupArg noAnn) + cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e) + ; es' <- mapM cvtl_maybe es + ; return $ ExplicitTuple + noAnn + es' + boxity } + +{- Note [Operator association] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must be quite careful about adding parens: + * Infix (UInfix ...) op arg Needs parens round the first arg + * Infix (Infix ...) op arg Needs parens round the first arg + * UInfix (UInfix ...) op arg No parens for first arg + * UInfix (Infix ...) op arg Needs parens round first arg + + +Note [Converting UInfix] +~~~~~~~~~~~~~~~~~~~~~~~~ +When converting @UInfixE@, @UInfixP@, @UInfixT@, and @PromotedUInfixT@ values, +we want to readjust the trees to reflect the fixities of the underlying +operators: + + UInfixE x * (UInfixE y + z) ---> (x * y) + z + +This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and +@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be +completely right-biased for types and left-biased for everything else. So we +left-bias the trees of @UInfixP@ and @UInfixE@ and right-bias the trees of +@UInfixT@ and @PromotedUnfixT@. + +Sample input: + + UInfixE + (UInfixE x op1 y) + op2 + (UInfixE z op3 w) + +Sample output: + + OpApp + (OpApp + (OpApp x op1 y) + op2 + z) + op3 + w + +The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this +biasing. +-} + +{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. +The produced tree of infix expressions will be left-biased, provided @x@ is. + +We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis +is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that +this holds for both branches (of @cvtOpApp@), provided we assume it holds for +the recursive calls to @cvtOpApp@. + +When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased +since we have already run @cvtl@ on it. +-} +cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs) +cvtOpApp x op1 (UInfixE y op2 z) + = do { l <- wrapLA $ cvtOpApp x op1 y + ; cvtOpApp l op2 z } +cvtOpApp x op y + = do { op' <- cvtl op + ; y' <- cvtl y + ; return (OpApp noExtField x op' y') } + +------------------------------------- +-- Do notation and statements +------------------------------------- + +cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs) +cvtHsDo do_or_lc stmts = case nonEmpty stmts of + Nothing -> failWith EmptyStmtListInDoBlock + Just stmts -> do + { stmts' <- traverse cvtStmt stmts + ; let stmts'' = NE.init stmts' + last' = NE.last stmts' + + ; last'' <- case last' of + (L loc (BodyStmt _ body _ _)) + -> return (L loc (mkLastStmt body)) + _ -> failWith (bad_last last') + + ; wrapParLA (HsDo noAnn do_or_lc) (stmts'' ++ [last'']) } + where + bad_last stmt = IllegalLastStatement do_or_lc stmt + +cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)] +cvtStmts = mapM cvtStmt + +cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) +cvtStmt (NoBindS e) = do { e' <- cvtl e; returnLA $ mkBodyStmt e' } +cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnLA $ mkPsBindStmt noAnn p' e' } +cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs LetBinding ds + ; returnLA $ LetStmt noAnn ds' } +cvtStmt (TH.ParS dss) = case nonEmpty dss of + Nothing -> failWith EmptyParStmt + Just dss -> do + { dss' <- mapM cvt_one dss + ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr } + where + cvt_one ds = do { ds' <- cvtStmts ds + ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) } +cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss + ; rec_stmt <- wrapParLA (mkRecStmt noAnn) ss' + ; returnLA rec_stmt } + +cvtMatch :: HsMatchContextPs -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) +cvtMatch ctxt (TH.Match p body decs) + = do { p' <- cvtPat p + ; let lp = case p' of + (L loc SigPat{}) -> L loc (gParPat p') -- #14875 + _ -> p' + ; g' <- cvtGuard body + ; decs' <- cvtLocalDecs WhereClause decs + ; returnLA $ Hs.Match noExtField ctxt (noLocA [lp]) (GRHSs emptyComments g' decs') } + +cvtGuard :: TH.Body -> CvtM (NonEmpty (LGRHS GhcPs (LHsExpr GhcPs))) +cvtGuard (GuardedB pairs) = case nonEmpty pairs of + Nothing -> failWith EmptyGuard + Just pairs -> traverse cvtpair pairs +cvtGuard (NormalB e) = do { e' <- cvtl e + ; g' <- returnLA $ GRHS noAnn [] e'; return (g' :| []) } + +cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) +cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs + ; g' <- returnLA $ mkBodyStmt ge' + ; returnLA $ GRHS noAnn [g'] rhs' } +cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs + ; returnLA $ GRHS noAnn gs' rhs' } + +cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) +cvtOverLit (IntegerL i) + = do { force i; return $ mkHsIntegral (mkIntegralLit i) } +cvtOverLit (RationalL r) + = do { force r; return $ mkHsFractional (mkTHFractionalLit r) } +cvtOverLit (StringL s) + = do { let { s' = mkFastString s } + ; force s' + ; return $ mkHsIsString (quotedSourceText s) s' + } +cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" +-- An Integer is like an (overloaded) '3' in a Haskell source program +-- Similarly 3.5 for fractionals + +{- Note [Converting strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to +a string literal for "xy". Of course, we might hope to get +(LitE (StringL "xy")), but not always, and allCharLs fails quickly +if it isn't a literal string +-} + +allCharLs :: [TH.Exp] -> Maybe String +-- Note [Converting strings] +-- NB: only fire up this setup for a non-empty list, else +-- there's a danger of returning "" for [] :: [Int]! +allCharLs xs + = case xs of + LitE (CharL c) : ys -> go [c] ys + _ -> Nothing + where + go cs [] = Just (reverse cs) + go cs (LitE (CharL c) : ys) = go (c:cs) ys + go _ _ = Nothing + +cvtLit :: Lit -> CvtM (HsLit GhcPs) +cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } +cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } +cvtLit (FloatPrimL f) + = do { force f; return $ HsFloatPrim noExtField (mkTHFractionalLit f) } +cvtLit (DoublePrimL f) + = do { force f; return $ HsDoublePrim noExtField (mkTHFractionalLit f) } +cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } +cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } +cvtLit (StringL s) = do { let { s' = mkFastString s } + ; force s' + ; return $ HsString (quotedSourceText s) s' } +cvtLit (StringPrimL s) = do { let { !s' = BS.pack s } + ; return $ HsStringPrim NoSourceText s' } +cvtLit (BytesPrimL (Bytes fptr off sz)) = do + let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr -> + BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz) + force bs + return $ HsStringPrim NoSourceText bs +cvtLit _ = panic "Convert.cvtLit: Unexpected literal" + -- cvtLit should not be called on IntegerL, RationalL + -- That precondition is established right here in + -- "GHC.ThToHs", hence panic + +quotedSourceText :: String -> SourceText +quotedSourceText s = SourceText $ fsLit $ "\"" ++ s ++ "\"" + +cvtPats :: Traversable f => f (TH.Pat) -> CvtM (f (Hs.LPat GhcPs)) +cvtPats pats = mapM cvtPat pats +{-# SPECIALISE cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs] #-} +{-# SPECIALISE cvtPats :: NonEmpty (TH.Pat) -> CvtM (NonEmpty (Hs.LPat GhcPs)) #-} + +cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs) +cvtPat pat = wrapLA (cvtp pat) + +cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) +cvtp (TH.LitP l) + | overloadedLit l = do { l' <- cvtOverLit l + ; l'' <- returnLA l' + ; return (mkNPat l'' Nothing noAnn) } + -- Not right for negative patterns; + -- need to think about that! + | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } +cvtp (TH.VarP s) = do { s' <- vName s + ; wrapParLA (Hs.VarPat noExtField) s' } +cvtp (TupP ps) = do { ps' <- cvtPats ps + ; return $ TuplePat noAnn ps' Boxed } +cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps + ; return $ TuplePat noAnn ps' Unboxed } +cvtp (UnboxedSumP p alt arity) + = do { p' <- cvtPat p + ; unboxedSumChecks alt arity + ; return $ SumPat noAnn p' alt arity } +cvtp (ConP s ts ps) = do { s' <- dNameN s + ; ps' <- cvtPats (map InvisP ts ++ ps) + ; let pps = map (parenthesizePat appPrec) ps' + ; return $ ConPat + { pat_con_ext = noAnn + , pat_con = s' + , pat_args = PrefixCon pps + } + } +cvtp (InfixP p1 s p2) = do { s' <- dNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2 + ; wrapParLA gParPat $ + ConPat + { pat_con_ext = noAnn + , pat_con = s' + , pat_args = InfixCon + (parenthesizePat opPrec p1') + (parenthesizePat opPrec p2') + } + } + -- See Note [Operator association] +cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] +cvtp (ParensP p) = do { p' <- cvtPat p; + ; case unLoc p' of -- may be wrapped ConPatIn + ParPat {} -> return $ unLoc p' + _ -> return $ gParPat p' } +cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noAnn p' } +cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noAnn p' } +cvtp (TH.AsP s p) = do { s' <- vNameN s; p' <- cvtPat p + ; return $ AsPat noAnn s' p' } +cvtp TH.WildP = return $ WildPat noExtField +cvtp (RecP c fs) = do { c' <- cNameN c; fs' <- mapM cvtPatFld fs + ; return $ ConPat + { pat_con_ext = noAnn + , pat_con = c' + , pat_args = Hs.RecCon $ HsRecFields noExtField fs' Nothing + } + } +cvtp (ListP ps) = do { ps' <- cvtPats ps + ; return + $ ListPat noAnn ps'} +cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t + ; let pp = parenthesizePat sigPrec p' + ; return $ SigPat noAnn pp (mkHsPatSigType noAnn t') } +cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p + ; wrapParLA gParPat $ ViewPat noAnn e' p'} +cvtp (TypeP t) = do { t' <- cvtType t + ; return $ EmbTyPat noAnn (mkHsTyPat t') } +cvtp (InvisP t) = do { t' <- parenthesizeHsType appPrec <$> cvtType t + ; pure (InvisPat noAnnSpecified (mkHsTyPat t'))} +cvtp (OrP ps) = do { ps' <- cvtPats ps + ; pure (OrPat noExtField ps')} + +noAnnSpecified :: XInvisPat GhcPs +noAnnSpecified = (noAnn, Hs.SpecifiedSpec) + +cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) +cvtPatFld (s,p) + = do { L ls s' <- vNameN s + ; p' <- cvtPat p + ; returnLA $ HsFieldBind { hfbAnn = noAnn + , hfbLHS + = L (l2l ls) $ mkFieldOcc (L (l2l ls) s') + , hfbRHS = p' + , hfbPun = False} } + +{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. +The produced tree of infix patterns will be left-biased, provided @x@ is. + +See the @cvtOpApp@ documentation for how this function works. +-} +cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs) +cvtOpAppP x op1 (UInfixP y op2 z) + = do { l <- wrapLA $ cvtOpAppP x op1 y + ; cvtOpAppP l op2 z } +cvtOpAppP x op y + = do { op' <- cNameN op + ; y' <- cvtPat y + ; return $ ConPat + { pat_con_ext = noAnn + , pat_con = op' + , pat_args = InfixCon x y' + } + } + +----------------------------------------------------------- +-- Types and type variables + +class CvtFlag flag flag' | flag -> flag' where + cvtFlag :: flag -> flag' + +instance CvtFlag () () where + cvtFlag () = () + +instance CvtFlag TH.Specificity Hs.Specificity where + cvtFlag TH.SpecifiedSpec = Hs.SpecifiedSpec + cvtFlag TH.InferredSpec = Hs.InferredSpec + +instance CvtFlag TH.BndrVis (HsBndrVis GhcPs) where + cvtFlag TH.BndrReq = HsBndrRequired noExtField + cvtFlag TH.BndrInvis = HsBndrInvisible noAnn + +cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs] +cvtTvs tvs = mapM cvt_tv tvs + +cvt_tv :: CvtFlag flag flag' => (TH.TyVarBndr flag) -> CvtM (LHsTyVarBndr flag' GhcPs) +cvt_tv (TH.PlainTV nm fl) + = do { nm' <- tNameN nm + ; let fl' = cvtFlag fl + ; returnLA $ HsTvb { tvb_ext = noAnn + , tvb_flag = fl' + , tvb_var = HsBndrVar noExtField nm' + , tvb_kind = HsBndrNoKind noExtField } } +cvt_tv (TH.KindedTV nm fl ki) + = do { nm' <- tNameN nm + ; let fl' = cvtFlag fl + ; ki' <- cvtKind ki + ; returnLA $ HsTvb { tvb_ext = noAnn + , tvb_flag = fl' + , tvb_var = HsBndrVar noExtField nm' + , tvb_kind = HsBndrKind noExtField ki' } } + +cvtRole :: TH.Role -> Maybe Coercion.Role +cvtRole TH.NominalR = Just Coercion.Nominal +cvtRole TH.RepresentationalR = Just Coercion.Representational +cvtRole TH.PhantomR = Just Coercion.Phantom +cvtRole TH.InferR = Nothing + +cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs) +cvtContext p tys = do { preds' <- mapM cvtPred tys + ; parenthesizeHsContext p <$> returnLA preds' } + +cvtPred :: TH.Pred -> CvtM (LHsType GhcPs) +cvtPred = cvtType + +cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs) +cvtDerivClauseTys tys + = do { tys' <- mapM cvtSigType tys + -- Since TH.Cxt doesn't indicate the presence or absence of + -- parentheses in a deriving clause, we have to choose between + -- DctSingle and DctMulti somewhat arbitrarily. We opt to use DctMulti + -- unless the TH.Cxt is a singleton list whose type is a bare type + -- constructor with no arguments. + ; case tys' of + [ty'@(L l (HsSig { sig_bndrs = HsOuterImplicit{} + , sig_body = L _ (HsTyVar _ NotPromoted _) }))] + -> return $ L (l2l l) $ DctSingle noExtField ty' + _ -> returnLA $ DctMulti noExtField tys' } + +cvtDerivClause :: TH.DerivClause + -> CvtM (LHsDerivingClause GhcPs) +cvtDerivClause (TH.DerivClause ds tys) + = do { tys' <- cvtDerivClauseTys tys + ; ds' <- traverse cvtDerivStrategy ds + ; returnLA $ HsDerivingClause noAnn ds' tys' } + +cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs) +cvtDerivStrategy TH.StockStrategy = returnLA (Hs.StockStrategy noAnn) +cvtDerivStrategy TH.AnyclassStrategy = returnLA (Hs.AnyclassStrategy noAnn) +cvtDerivStrategy TH.NewtypeStrategy = returnLA (Hs.NewtypeStrategy noAnn) +cvtDerivStrategy (TH.ViaStrategy ty) = do + ty' <- cvtSigType ty + returnLA $ Hs.ViaStrategy (XViaStrategyPs noAnn ty') + +cvtType :: TH.Type -> CvtM (LHsType GhcPs) +cvtType = cvtTypeKind TypeLevel + +cvtSigType :: TH.Type -> CvtM (LHsSigType GhcPs) +cvtSigType = cvtSigTypeKind TypeLevel + +-- | Convert a Template Haskell 'Type' to an 'LHsSigType'. To avoid duplicating +-- the logic in 'cvtTypeKind' here, we simply reuse 'cvtTypeKind' and perform +-- surgery on the 'LHsType' it returns to turn it into an 'LHsSigType'. +cvtSigTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsSigType GhcPs) +cvtSigTypeKind typeOrKind ty = do + ty' <- cvtTypeKind typeOrKind ty + pure $ hsTypeToHsSigType $ parenthesizeHsType sigPrec ty' + +cvtTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsType GhcPs) +cvtTypeKind typeOrKind ty + = do { (head_ty, tys') <- split_ty_app ty + ; let m_normals = mapM extract_normal tys' + where extract_normal (HsValArg _ ty) = Just ty + extract_normal _ = Nothing + + ; case head_ty of + TupleT n + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> returnLA (HsTupleTy noAnn HsBoxedOrConstraintTuple normals) + | otherwise + -> do { tuple_tc <- returnLA $ getRdrName $ tupleTyCon Boxed n + ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' } + UnboxedTupleT n + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> returnLA (HsTupleTy noAnn HsUnboxedTuple normals) + | otherwise + -> do { tuple_tc <- returnLA $ getRdrName $ tupleTyCon Unboxed n + ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' } + UnboxedSumT n + | n < 2 + -> failWith $ IllegalSumArity n + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> returnLA (HsSumTy noAnn normals) + | otherwise + -> do { sum_tc <- returnLA $ getRdrName $ sumTyCon n + ; mk_apps (HsTyVar noAnn NotPromoted sum_tc) tys' } + ArrowT + | Just normals <- m_normals + , [x',y'] <- normals -> do + x'' <- case unLoc x' of + HsFunTy{} -> returnLA (HsParTy noAnn x') + HsForAllTy{} -> returnLA (HsParTy noAnn x') -- #14646 + HsQualTy{} -> returnLA (HsParTy noAnn x') -- #15324 + _ -> return $ + parenthesizeHsType sigPrec x' + let y'' = parenthesizeHsType sigPrec y' + returnLA (HsFunTy noExtField (HsUnannotated (EpArrow noAnn)) x'' y'') + | otherwise + -> do { fun_tc <- returnLA $ getRdrName unrestrictedFunTyCon + ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' } + MulArrowT + | Just normals <- m_normals + , [w',x',y'] <- normals -> do + x'' <- case unLoc x' of + HsFunTy{} -> returnLA (HsParTy noAnn x') + HsForAllTy{} -> returnLA (HsParTy noAnn x') -- #14646 + HsQualTy{} -> returnLA (HsParTy noAnn x') -- #15324 + _ -> return $ + parenthesizeHsType sigPrec x' + let y'' = parenthesizeHsType sigPrec y' + w'' = hsTypeToArrow w' + returnLA (HsFunTy noExtField w'' x'' y'') + | otherwise + -> do { fun_tc <- returnLA $ getRdrName fUNTyCon + ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' } + ListT + | Just normals <- m_normals + , [x'] <- normals -> + returnLA (HsListTy noAnn x') + | otherwise + -> do { list_tc <- returnLA $ getRdrName listTyCon + ; mk_apps (HsTyVar noAnn NotPromoted list_tc) tys' } + + VarT nm -> do { nm' <- tNameN nm + ; mk_apps (HsTyVar noAnn NotPromoted nm') tys' } + ConT nm -> do { nm' <- tconName nm + ; let prom = name_promotedness nm' + ; lnm' <- returnLA nm' + ; mk_apps (HsTyVar noAnn prom lnm') tys'} + + ForallT tvs cxt ty + | null tys' + -> do { tvs' <- cvtTvs tvs + ; cxt' <- cvtContext funPrec cxt + ; ty' <- cvtType ty + ; loc <- getL + ; let loc' = noAnnSrcSpan loc + ; let tele = mkHsForAllInvisTele noAnn tvs' + hs_ty = mkHsForAllTy loc' tele rho_ty + rho_ty = mkHsQualTy cxt loc' cxt' ty' + + ; return hs_ty } + + ForallVisT tvs ty + | null tys' + -> do { tvs' <- cvtTvs tvs + ; ty' <- cvtType ty + ; loc <- getL + ; let loc' = noAnnSrcSpan loc + ; let tele = mkHsForAllVisTele noAnn tvs' + ; pure $ mkHsForAllTy loc' tele ty' } + + SigT ty ki + -> do { ty' <- cvtType ty + ; ki' <- cvtKind ki + ; mk_apps (HsKindSig noAnn ty' ki') tys' + } + + LitT lit + -> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys' + + WildCardT + -> mk_apps (mkAnonWildCardTy noAnn) tys' + + InfixT t1 s t2 + -> do { s' <- tconName s + ; t1' <- cvtType t1 + ; t2' <- cvtType t2 + ; let prom = name_promotedness s' + ; ls' <- returnLA s' + ; mk_apps + (HsTyVar noAnn prom ls') + ([HsValArg noExtField t1', HsValArg noExtField t2'] ++ tys') + } + + UInfixT t1 s t2 + -> do { s' <- tconNameN s + ; t2' <- cvtType t2 + ; t <- cvtOpAppT NotPromoted t1 s' t2' + ; mk_apps (unLoc t) tys' + } -- Note [Converting UInfix] + + PromotedInfixT t1 s t2 + -> do { s' <- cNameN s + ; t1' <- cvtType t1 + ; t2' <- cvtType t2 + ; mk_apps + (HsTyVar noAnn IsPromoted s') + ([HsValArg noExtField t1', HsValArg noExtField t2'] ++ tys') + } + + PromotedUInfixT t1 s t2 + -> do { s' <- cNameN s + ; t2' <- cvtType t2 + ; t <- cvtOpAppT IsPromoted t1 s' t2' + ; mk_apps (unLoc t) tys' + } -- Note [Converting UInfix] + + ParensT t + -> do { t' <- cvtType t + ; mk_apps (HsParTy noAnn t') tys' + } + + PromotedT nm -> do { nm' <- cNameN nm + ; mk_apps (HsTyVar noAnn IsPromoted nm') + tys' } + -- Promoted data constructor; hence cName + + PromotedTupleT n + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> returnLA (HsExplicitTupleTy noAnn IsPromoted normals) + | otherwise + -> do { tuple_tc <- returnLA $ getRdrName $ tupleDataCon Boxed n + ; mk_apps (HsTyVar noAnn IsPromoted tuple_tc) tys' } + + PromotedNilT + -> mk_apps (HsExplicitListTy noAnn IsPromoted []) tys' + + PromotedConsT -- See Note [Representing concrete syntax in types] + -- in GHC.Internal.TH.Syntax + | Just normals <- m_normals + , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals + -> returnLA (HsExplicitListTy noAnn ip (ty1:tys2)) + | otherwise + -> do { cons_tc <- returnLA $ getRdrName consDataCon + ; mk_apps (HsTyVar noAnn IsPromoted cons_tc) tys' } + + StarT + -> do { type_tc <- returnLA $ getRdrName liftedTypeKindTyCon + ; mk_apps (HsTyVar noAnn NotPromoted type_tc) tys' } + + ConstraintT + -> do { constraint_tc <- returnLA $ getRdrName constraintKindTyCon + ; mk_apps (HsTyVar noAnn NotPromoted constraint_tc) tys' } + + EqualityT + | Just normals <- m_normals + , [x',y'] <- normals -> + let px = parenthesizeHsType opPrec x' + py = parenthesizeHsType opPrec y' + in do { eq_tc <- returnLA eqTyCon_RDR + ; returnLA (HsOpTy noExtField NotPromoted px eq_tc py) } + -- The long-term goal is to remove the above case entirely and + -- subsume it under the case for InfixT. See #15815, comment:6, + -- for more details. + + | otherwise -> + do { eq_tc <- returnLA eqTyCon_RDR + ; mk_apps (HsTyVar noAnn NotPromoted eq_tc) tys' } + ImplicitParamT n t + -> do { n' <- wrapL $ ipName n + ; t' <- cvtType t + ; returnLA (HsIParamTy noAnn (reLoc n') t') + } + + _ -> failWith (MalformedType typeOrKind ty) + } + +hsTypeToArrow :: LHsType GhcPs -> HsMultAnn GhcPs +hsTypeToArrow w = case unLoc w of + HsTyVar _ _ (L _ (isExact_maybe -> Just n)) + | n == oneDataConName -> HsLinearAnn noAnn + | n == manyDataConName -> HsUnannotated (EpArrow noAnn) + _ -> HsExplicitMult (noAnn, EpArrow noAnn) w + +-- ConT/InfixT can contain both data constructor (i.e., promoted) names and +-- other (i.e, unpromoted) names, as opposed to PromotedT, which can only +-- contain data constructor names. See #15572/#17394. We use this function to +-- determine whether to mark a name as promoted/unpromoted when dealing with +-- ConT/InfixT. +name_promotedness :: RdrName -> Hs.PromotionFlag +name_promotedness nm + | isRdrDataCon nm = IsPromoted + | otherwise = NotPromoted + +-- | Constructs an application of a type to arguments passed in a list. +mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs) +mk_apps head_ty type_args = do + head_ty' <- returnLA head_ty + -- We must parenthesize the function type in case of an explicit + -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there + -- _must_ be parentheses around `Maybe :: Type -> Type`. + let phead_ty :: LHsType GhcPs + phead_ty = parenthesizeHsType sigPrec head_ty' + + go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs) + go [] = pure head_ty' + go (arg:args) = + case arg of + HsValArg _ ty -> + do p_ty <- add_parens ty + mk_apps (HsAppTy noExtField phead_ty p_ty) args + HsTypeArg at ki -> + do p_ki <- add_parens ki + mk_apps (HsAppKindTy at phead_ty p_ki) args + HsArgPar _ -> mk_apps (HsParTy noAnn phead_ty) args + + go type_args + where + -- See Note [Adding parens for splices] + add_parens lt@(L _ t) + | hsTypeNeedsParens appPrec t = returnLA (HsParTy noAnn lt) + | otherwise = return lt + +wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs +wrap_tyarg (HsValArg x ty) = HsValArg x $ parenthesizeHsType appPrec ty +wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki +wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized + +-- --------------------------------------------------------------------- +{- +Note [Adding parens for splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The hsSyn representation of parsed source explicitly contains all the original +parens, as written in the source. + +When a Template Haskell (TH) splice is evaluated, the original splice is first +renamed and type checked and then finally converted to core in +GHC.HsToCore.Quote. This core is then run in the TH engine, and the result +comes back as a TH AST. + +In the process, all parens are stripped out, as they are not needed. + +This Convert module then converts the TH AST back to hsSyn AST. + +In order to pretty-print this hsSyn AST, parens need to be added back at certain +points so that the code is readable with its original meaning. + +So scattered through "GHC.ThToHs" are various points where parens are added. + +See (among other closed issues) https://gitlab.haskell.org/ghc/ghc/issues/14289 +-} +-- --------------------------------------------------------------------- + +split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs]) +split_ty_app ty = go ty [] + where + go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg noExtField a':as') } + go (AppKindT ty ki) as' = do { ki' <- cvtKind ki + ; go ty (HsTypeArg noAnn ki' : as') } + go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') } + go f as = return (f,as) + +cvtTyLit :: TH.TyLit -> HsTyLit (GhcPass p) +cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i +cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) +cvtTyLit (TH.CharTyLit c) = HsCharTy NoSourceText c + +{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator +application @x `op` y@. The produced tree of infix types will be right-biased, +provided @y@ is. + +See the @cvtOpApp@ documentation for how this function works. +-} +cvtOpAppT :: PromotionFlag -> TH.Type -> LocatedN RdrName -> LHsType GhcPs -> CvtM (LHsType GhcPs) +cvtOpAppT prom (UInfixT x op2 y) op1 z + = do { op2' <- tconNameN op2 + ; l <- cvtOpAppT prom y op1 z + ; cvtOpAppT NotPromoted x op2' l } +cvtOpAppT prom (PromotedUInfixT x op2 y) op1 z + = do { op2' <- cNameN op2 + ; l <- cvtOpAppT prom y op1 z + ; cvtOpAppT IsPromoted x op2' l } +cvtOpAppT prom x op y + = do { x' <- cvtType x + ; returnLA (mkHsOpTy prom x' op y) } + +cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) +cvtKind = cvtTypeKind KindLevel + +cvtSigKind :: TH.Kind -> CvtM (LHsSigType GhcPs) +cvtSigKind = cvtSigTypeKind KindLevel + +-- | Convert Maybe Kind to a type family result signature. Used with data +-- families where naming of the result is not possible (thus only kind or no +-- signature is possible). +cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind + -> CvtM (LFamilyResultSig GhcPs) +cvtMaybeKindToFamilyResultSig Nothing = returnLA (Hs.NoSig noExtField) +cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki + ; returnLA (Hs.KindSig noExtField ki') } + +-- | Convert type family result signature. Used with both open and closed type +-- families. +cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs) +cvtFamilyResultSig TH.NoSig = returnLA (Hs.NoSig noExtField) +cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki + ; returnLA (Hs.KindSig noExtField ki') } +cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr + ; returnLA (Hs.TyVarSig noExtField tv) } + +-- | Convert injectivity annotation of a type family. +cvtInjectivityAnnotation :: TH.InjectivityAnn + -> CvtM (Hs.LInjectivityAnn GhcPs) +cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) + = do { annLHS' <- tNameN annLHS + ; annRHS' <- mapM tNameN annRHS + ; returnLA (Hs.InjectivityAnn noAnn annLHS' annRHS') } + +cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs) +-- pattern synonym types are of peculiar shapes, which is why we treat +-- them separately from regular types; +-- see Note [Pattern synonym type signatures and Template Haskell] +cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) + | null exis, null provs = cvtSigType (ForallT univs reqs ty) + | null univs, null reqs = do { ty' <- cvtType (ForallT exis provs ty) + ; ctxt' <- returnLA [] + ; cxtTy <- wrapParLA mkHsImplicitSigType $ + HsQualTy { hst_ctxt = ctxt' + , hst_xqual = noExtField + , hst_body = ty' } + ; returnLA cxtTy } + | null reqs = do { univs' <- cvtTvs univs + ; ty' <- cvtType (ForallT exis provs ty) + ; ctxt' <- returnLA [] + ; let cxtTy = HsQualTy { hst_ctxt = ctxt' + , hst_xqual = noExtField + , hst_body = ty' } + ; forTy <- wrapParLA (mkHsExplicitSigType noAnn univs') cxtTy + ; returnLA forTy } + | otherwise = cvtSigType (ForallT univs reqs (ForallT exis provs ty)) +cvtPatSynSigTy ty = cvtSigType ty + +----------------------------------------------------------- +cvtFixity :: TH.Fixity -> Hs.Fixity +cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir) + where + cvt_dir TH.InfixL = Hs.InfixL + cvt_dir TH.InfixR = Hs.InfixR + cvt_dir TH.InfixN = Hs.InfixN + +----------------------------------------------------------- + + +----------------------------------------------------------- +-- some useful things + +overloadedLit :: Lit -> Bool +-- True for literals that Haskell treats as overloaded +overloadedLit (IntegerL _) = True +overloadedLit (RationalL _) = True +overloadedLit _ = False + +-- Checks that are performed when converting unboxed sum expressions and +-- patterns alike. +unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM () +unboxedSumChecks alt arity + | alt > arity + = failWith $ SumAltArityExceeded alt arity + | alt <= 0 + = failWith $ IllegalSumAlt alt + | arity < 2 + = failWith $ IllegalSumArity arity + | otherwise + = return () + +-- | If passed an empty list of 'LHsTyVarBndr's, this simply returns the +-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy' +-- using the provided 'LHsQTyVars' and 'LHsType'. +mkHsForAllTy :: SrcSpanAnnA + -- ^ The location of the returned 'LHsType' if it needs an + -- explicit forall + -> HsForAllTelescope GhcPs + -- ^ The converted type variable binders + -> LHsType GhcPs + -- ^ The converted rho type + -> LHsType GhcPs + -- ^ The complete type, quantified with a forall if necessary +mkHsForAllTy loc tele rho_ty + | no_tvs = rho_ty + | otherwise = L loc $ HsForAllTy { hst_tele = tele + , hst_xforall = noExtField + , hst_body = rho_ty } + where + no_tvs = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> null bndrs + HsForAllInvis { hsf_invis_bndrs = bndrs } -> null bndrs + +-- | If passed an empty 'TH.Cxt', this simply returns the third argument +-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided +-- 'LHsContext' and 'LHsType'. + +-- It's important that we don't build an HsQualTy if the context is empty, +-- as the pretty-printer for HsType _always_ prints contexts, even if +-- they're empty. See #13183. +mkHsQualTy :: TH.Cxt + -- ^ The original Template Haskell context + -> SrcSpanAnnA + -- ^ The location of the returned 'LHsType' if it needs an + -- explicit context + -> LHsContext GhcPs + -- ^ The converted context + -> LHsType GhcPs + -- ^ The converted tau type + -> LHsType GhcPs + -- ^ The complete type, qualified with a context if necessary +mkHsQualTy ctxt loc ctxt' ty + | null ctxt = ty + | otherwise = L loc $ HsQualTy { hst_xqual = noExtField + , hst_ctxt = ctxt' + , hst_body = ty } + +-- | @'mkHsContextMaybe' lc@ returns 'Nothing' if @lc@ is empty and @'Just' lc@ +-- otherwise. +-- +-- This is much like 'mkHsQualTy', except that it returns a +-- @'Maybe' ('LHsContext' 'GhcPs')@. This is used specifically for constructing +-- superclasses, datatype contexts (#20011), and contexts in GADT constructor +-- types (#20590). We wish to avoid using @'Just' []@ in the case of an empty +-- contexts, as the pretty-printer always prints 'Just' contexts, even if +-- they're empty. +mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs) +mkHsContextMaybe lctxt@(L _ ctxt) + | null ctxt = Nothing + | otherwise = Just lctxt + +mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs +mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit (mkHsOuterExplicit noAnn) + +-------------------------------------------------------------------- +-- Turning Name back into RdrName +-------------------------------------------------------------------- + +-- variable names +vNameN, cNameN, vcNameN, tNameN, tconNameN, dNameN :: TH.Name -> CvtM (LocatedN RdrName) +vNameL :: TH.Name -> CvtM (LocatedA RdrName) +vName, cName, vcName, tName, tconName, dName :: TH.Name -> CvtM RdrName + +-- Variable names +vNameN n = wrapLN (vName n) +vNameL n = wrapLA (vName n) +vName n = cvtName OccName.varName n + +-- Constructor function names; this is Haskell source, hence srcDataName +cNameN n = wrapLN (cName n) +cName n = cvtName OccName.dataName n + +-- Type or data constructor name +dNameN n = wrapLN (dName n) +dName n = cName n `orOnFail` tconName n + +-- Variable *or* constructor names; check by looking at the first char +vcNameN n = wrapLN (vcName n) +vcName n = if isVarName n then vName n else cName n + +-- Type variable names +tNameN n = wrapLN (tName n) +tName n = cvtName OccName.tvName n + +-- Type Constructor names +tconNameN n = wrapLN (tconName n) +tconName n = cvtName OccName.tcClsName n + +-- Field names +fldName :: String -> TH.Name -> CvtM RdrName +fldName con n = cvtName (OccName.fieldName $ fsLit con) n + +fldNameN :: String -> TH.Name -> CvtM (LocatedN RdrName) +fldNameN con n = wrapLN (fldName con n) + +ipName :: String -> CvtM HsIPName +ipName n + = do { unless (okVarOcc n) (failWith (IllegalOccName OccName.varName n)) + ; return (HsIPName (fsLit n)) } + +cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName +cvtName ctxt_ns (TH.Name occ flavour) + | not (okOcc ctxt_ns occ_str) = failWith (IllegalOccName ctxt_ns occ_str) + | otherwise + = do { loc <- getL + ; listTuplePuns <- getListTuplePuns + ; let rdr_name = thRdrName listTuplePuns loc ctxt_ns occ_str flavour + ; force rdr_name + ; return rdr_name } + where + occ_str = TH.occString occ + +okOcc :: OccName.NameSpace -> String -> Bool +okOcc ns str + | OccName.isVarNameSpace ns = okVarOcc str + | OccName.isDataConNameSpace ns = okConOcc str + | otherwise = okTcOcc str + +-- Determine the name space of a name in a type +-- +isVarName :: TH.Name -> Bool +isVarName (TH.Name occ _) + = case TH.occString occ of + "" -> False + (c:_) -> startsVarId c || startsVarSym c + +thRdrName :: Bool -> SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName +-- This turns a TH Name into a RdrName; used for both binders and occurrences +-- See Note [Binders in Template Haskell] +-- The passed-in name space tells what the context is expecting; +-- use it unless the TH name knows what name-space it comes +-- from, in which case use the latter +-- +-- We pass in a SrcSpan (gotten from the monad) because this function +-- is used for *binders* and if we make an Exact Name we want it +-- to have a binding site inside it. (cf #5434) +-- +-- ToDo: we may generate silly RdrNames, by passing a name space +-- that doesn't match the string, like VarName ":+", +-- which will give confusing error messages later +-- +-- The strict applications ensure that any buried exceptions get forced +thRdrName listTuplePuns loc ctxt_ns th_occ th_name + = case th_name of + TH.NameG th_ns pkg mod -> thOrigOrExactRdrName th_occ th_ns pkg mod + TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ + TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc) + TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc) + TH.NameS -> thUnqualRdrName listTuplePuns occ + where + occ :: OccName.OccName + occ = mk_occ ctxt_ns th_occ + +{- thOrigRdrName converts /original names/ in TH to their GHC representation. + +An original name is the canonical (Module, OccName) pair (where Module also +includes package/unit info) that (a) uniquely and (b) unambiguously identifies a +top-level binding. For example, ghc-prim:GHC.Types.List is the original name of +the list type []. + +To be more precise, + a) "uniquely" means that there's exactly one original name for each top-level + binding, which makes it different from a qualified name. + Qualified names permit reexports and module aliases: + + import Data.List as L + + xs :: L.List a -- L is a module alias for Data.List + xs :: Data.List.List a -- Data.List reexports GHC.Types.List + + Only ghc-prim:GHC.Types.List constitutes List's original name because + GHC.Types is the original module where we find the type declaration: + + data List a = [] | a : List a -- in ghc-prim:GHC.Types + + b) "unambiguously" means that the original name contains sufficient + information to identify the top-level binding in all possible contexts. + + For example, ghc-prim:GHC.Types.List remains valid even if the user + declares their own List type. + +In TH, original names arise from name quotation, e.g. + + 'Just ==> ghc-internal:GHC.Internal.Maybe.Just + ''ReaderT ==> transformers:Control.Monad.Trans.Reader.ReaderT + ''[] ==> ghc-prim:GHC.Types.List (with ListTuplePuns) + +NB. You likely want to use thOrigOrExactRdrName instead of thOrigRdrName. +-} +thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName +thOrigRdrName occ th_ns pkg mod = (mkOrig $! mod') $! occ' + where + occ' = mk_occ (mk_ghc_ns th_ns) occ + mod' = mkModule (mk_pkg pkg) (mk_mod mod) + +{- Note [Pretty-printing known original names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An original name is a pair (Module, OccName), and normally we would pretty-print +it using the M.x syntax, e.g. "GHC.Types.Int" or "GHC.Internal.Base.ord". +However, this approach creates two problems (test case: th/T13776): + + 1) Illegal quantification of built-in syntax, e.g. the nil data constructor [] + would be printed as GHC.Types.[], which is not valid Haskell syntax + + 2) Ignoring ListTuplePuns. e.g. the type constructor (,) would be + printed as GHC.Tuple.Tuple2, even though the user would prefer to see (,) + +The pretty-printer for Name has special cases to deal with this, but the one for +Orig RdrNames does not. Trying to fix this directly in the Outputable RdrName instance +creates nasty module cycles. Instead, we work around the issue by avoiding the +problematic Orig names altogether, converting them to Exact names as early as +possible. +-} + +-- thOrigOrExactRdrName is a variant of thOrigRdrName that returns Exact names +-- instead of known Orig names. +-- +-- See Note [Pretty-printing known original names] for the rationale. +thOrigOrExactRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName +thOrigOrExactRdrName occ th_ns pkg mod = knownOrigToExactRdrName (thOrigRdrName occ th_ns pkg mod) + +-- Convert known Orig names to Exact names, leaving all other names intact. +knownOrigToExactRdrName :: RdrName -> RdrName +knownOrigToExactRdrName (Orig mod occ) + | Just name <- isKnownOrigName_maybe mod occ + = Exact name +knownOrigToExactRdrName rdr = rdr + +-- Return an exact RdrName if we're dealing with built-in syntax. +-- The user might have written (NameS "(,,)"), for example. +thUnqualRdrName :: Bool -> OccName.OccName -> RdrName +thUnqualRdrName listTuplePuns occ = + case isBuiltInOcc_maybe listTuplePuns occ of + Just name -> nameRdrName $! name + Nothing -> mkRdrUnqual $! occ + +thRdrNameGuesses :: Bool -> TH.Name -> [RdrName] +thRdrNameGuesses listTuplePuns (TH.Name occ flavour) + -- This special case for NameG ensures that we don't generate duplicates in the output list + | TH.NameG th_ns pkg mod <- flavour = [ thOrigOrExactRdrName occ_str th_ns pkg mod ] + | otherwise = [ thRdrName listTuplePuns noSrcSpan gns occ_str flavour + | gns <- guessed_nss] + where + -- guessed_ns are the name spaces guessed from looking at the TH name + guessed_nss + | isLexCon occ_txt = [OccName.tcName, OccName.dataName] + | isLexVarSym occ_txt = [OccName.tcName, OccName.varName] -- #23525 + | otherwise = [OccName.varName, OccName.tvName] + occ_str = TH.occString occ + occ_txt = mkFastString occ_str + +-- The packing and unpacking is rather turgid :-( +mk_occ :: OccName.NameSpace -> String -> OccName.OccName +mk_occ ns occ = OccName.mkOccName ns occ + +mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace +mk_ghc_ns TH.DataName = OccName.dataName +mk_ghc_ns TH.TcClsName = OccName.tcClsName +mk_ghc_ns TH.VarName = OccName.varName +mk_ghc_ns (TH.FldName con) = OccName.fieldName (fsLit con) + +mk_mod :: TH.ModName -> ModuleName +mk_mod mod = mkModuleName (TH.modString mod) + +mk_pkg :: TH.PkgName -> Unit +mk_pkg pkg = stringToUnit (TH.pkgString pkg) + +mk_uniq :: Word64 -> Unique +mk_uniq u = mkUniqueGrimily u + +{- +Note [Binders in Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this TH term construction: + do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name + ; x2 <- TH.newName "x" -- Builds a NameU + ; x3 <- TH.newName "x" + + ; let x = mkName "x" -- mkName :: String -> TH.Name + -- Builds a NameS + + ; return (LamE (..pattern [x1,x2]..) $ + LamE (VarPat x3) $ + ..tuple (x1,x2,x3,x)) } + +It represents the term \[x1,x2]. \x3. (x1,x2,x3,x) + +a) We don't want to complain about "x" being bound twice in + the pattern [x1,x2] +b) We don't want x3 to shadow the x1,x2 +c) We *do* want 'x' (dynamically bound with mkName) to bind + to the innermost binding of "x", namely x3. +d) When pretty printing, we want to print a unique with x1,x2 + etc, else they'll all print as "x" which isn't very helpful + +When we convert all this to HsSyn, the TH.Names are converted with +thRdrName. To achieve (b) we want the binders to be Exact RdrNames. +Achieving (a) is a bit awkward, because + - We must check for duplicate and shadowed names on Names, + not RdrNames, *after* renaming. + See Note [Collect binders only after renaming] in GHC.Hs.Utils + + - But to achieve (a) we must distinguish between the Exact + RdrNames arising from TH and the Unqual RdrNames that would + come from a user writing \[x,x] -> blah + +So in Convert.thRdrName we translate + TH Name RdrName + -------------------------------------------------------- + NameU (arising from newName) --> Exact (Name{ System }) + NameS (arising from mkName) --> Unqual + +Notice that the NameUs generate *System* Names. Then, when +figuring out shadowing and duplicates, we can filter out +System Names. + +This use of System Names fits with other uses of System Names, eg for +temporary variables "a". Since there are lots of things called "a" we +usually want to print the name with the unique, and that is indeed +the way System Names are printed. + +There's a small complication of course; see Note [Looking up Exact +RdrNames] in GHC.Rename.Env. +-} + +{- +Note [Pattern synonym type signatures and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In general, the type signature of a pattern synonym + + pattern P x1 x2 .. xn = + +is of the form + + forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t + +with the following parts: + + 1) the (possibly empty lists of) universally quantified type + variables `univs` and required constraints `reqs` on them. + 2) the (possibly empty lists of) existentially quantified type + variables `exis` and the provided constraints `provs` on them. + 3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1, + x2, .., xn, respectively + 4) the type `t` of , mentioning only universals from `univs`. + +Due to the two forall quantifiers and constraint contexts (either of +which might be empty), pattern synonym type signatures are treated +specially in `GHC.HsToCore.Quote`, `GHC.ThToHs`, and +`GHC.Tc.Gen.Splice`: + + (a) When desugaring a pattern synonym from HsSyn to TH.Dec in + `GHC.HsToCore.Quote`, we represent its *full* type signature in TH, i.e.: + + ForallT univs reqs (ForallT exis provs ty) + (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) + + (b) When converting pattern synonyms from TH.Dec to HsSyn in + `GHC.ThToHs`, we convert their TH type signatures back to an + appropriate Haskell pattern synonym type of the form + + forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t + + where initial empty `univs` type variables or an empty `reqs` + constraint context are represented *explicitly* as `() =>`. + + (c) When reifying a pattern synonym in `GHC.Tc.Gen.Splice`, we always + return its *full* type, i.e.: + + ForallT univs reqs (ForallT exis provs ty) + (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) + +The key point is to always represent a pattern synonym's *full* type +in cases (a) and (c) to make it clear which of the two forall +quantifiers and/or constraint contexts are specified, and which are +not. See GHC's user's guide on pattern synonyms for more information +about pattern synonym type signatures. + +-} diff --git a/GHC/Types/Annotations.hs b/GHC/Types/Annotations.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Annotations.hs @@ -0,0 +1,144 @@ +-- | +-- Support for source code annotation feature of GHC. That is the ANN pragma. +-- +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +{-# LANGUAGE DeriveFunctor #-} +module GHC.Types.Annotations ( + -- * Main Annotation data types + Annotation(..), AnnPayload, + AnnTarget(..), CoreAnnTarget, + + -- * AnnEnv for collecting and querying Annotations + AnnEnv, + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, + findAnns, findAnnsByTypeRep, + deserializeAnns + ) where + +import GHC.Prelude + +import GHC.Utils.Binary +import GHC.Unit.Module ( Module ) +import GHC.Unit.Module.Env +import GHC.Types.Name.Env +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Serialized + +import Control.Monad +import Data.Maybe +import Data.Typeable +import Data.Word ( Word8 ) +import Control.DeepSeq + +-- | Represents an annotation after it has been sufficiently desugared from +-- it's initial form of 'GHC.Hs.Decls.AnnDecl' +data Annotation = Annotation { + ann_target :: CoreAnnTarget, -- ^ The target of the annotation + ann_value :: AnnPayload + } + +type AnnPayload = Serialized -- ^ The "payload" of an annotation + -- allows recovery of its value at a given type, + -- and can be persisted to an interface file + +-- | An annotation target +data AnnTarget name + = NamedTarget name -- ^ We are annotating something with a name: + -- a type or identifier + | ModuleTarget Module -- ^ We are annotating a particular module + deriving (Functor) + +-- | The kind of annotation target found in the middle end of the compiler +type CoreAnnTarget = AnnTarget Name + +instance Outputable name => Outputable (AnnTarget name) where + ppr (NamedTarget nm) = text "Named target" <+> ppr nm + ppr (ModuleTarget mod) = text "Module target" <+> ppr mod + +instance Binary name => Binary (AnnTarget name) where + put_ bh (NamedTarget a) = do + putByte bh 0 + put_ bh a + put_ bh (ModuleTarget a) = do + putByte bh 1 + put_ bh a + get bh = do + h <- getByte bh + case h of + 0 -> liftM NamedTarget $ get bh + _ -> liftM ModuleTarget $ get bh + +instance NFData name => NFData (AnnTarget name) where + rnf (NamedTarget n) = rnf n + rnf (ModuleTarget m) = rnf m + +instance Outputable Annotation where + ppr ann = ppr (ann_target ann) + +-- | A collection of annotations +data AnnEnv = MkAnnEnv { ann_mod_env :: !(ModuleEnv [AnnPayload]) + , ann_name_env :: !(NameEnv [AnnPayload]) + } + +-- | An empty annotation environment. +emptyAnnEnv :: AnnEnv +emptyAnnEnv = MkAnnEnv emptyModuleEnv emptyNameEnv + +-- | Construct a new annotation environment that contains the list of +-- annotations provided. +mkAnnEnv :: [Annotation] -> AnnEnv +mkAnnEnv = extendAnnEnvList emptyAnnEnv + +-- | Add the given annotation to the environment. +extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv +extendAnnEnvList env = + foldl' extendAnnEnv env + +extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv +extendAnnEnv (MkAnnEnv mod_env name_env) (Annotation tgt payload) = + case tgt of + NamedTarget name -> MkAnnEnv mod_env (extendNameEnv_C (++) name_env name [payload]) + ModuleTarget mod -> MkAnnEnv (extendModuleEnvWith (++) mod_env mod [payload]) name_env + +-- | Union two annotation environments. +plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv +plusAnnEnv a b = + MkAnnEnv { ann_mod_env = plusModuleEnv_C (++) (ann_mod_env a) (ann_mod_env b) + , ann_name_env = plusNameEnv_C (++) (ann_name_env a) (ann_name_env b) + } + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] +findAnns deserialize env + = mapMaybe (fromSerialized deserialize) . findAnnPayloads env + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] +findAnnsByTypeRep env target tyrep + = [ ws | Serialized tyrep' ws <- findAnnPayloads env target + , tyrep' == tyrep ] + +-- | Find payloads for the given 'CoreAnnTarget' in an 'AnnEnv'. +findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload] +findAnnPayloads env target = + case target of + ModuleTarget mod -> lookupWithDefaultModuleEnv (ann_mod_env env) [] mod + NamedTarget name -> fromMaybe [] $ lookupNameEnv (ann_name_env env) name + +-- | Deserialize all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a]) +deserializeAnns deserialize env + = ( mapModuleEnv deserAnns (ann_mod_env env) + , mapNameEnv deserAnns (ann_name_env env) + ) + where deserAnns = mapMaybe (fromSerialized deserialize) + diff --git a/GHC/Types/Avail.hs b/GHC/Types/Avail.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Avail.hs @@ -0,0 +1,268 @@ + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE PatternSynonyms #-} +-- +-- (c) The University of Glasgow +-- + +module GHC.Types.Avail ( + Avails, + AvailInfo(..), + availsToNameSet, + availsToNameEnv, + availExportsDecl, + availName, + availNames, + availSubordinateNames, + stableAvailCmp, + plusAvail, + trimAvail, + filterAvail, + filterAvails, + nubAvails, + sortAvails, + DetOrdAvails(DetOrdAvails, getDetOrdAvails, DefinitelyDeterministicAvails), + emptyDetOrdAvails + ) where + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set + +import GHC.Utils.Binary +import GHC.Data.List.SetOps +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) + +import Control.DeepSeq +import Data.Data ( Data ) +import Data.Functor.Classes ( liftCompare ) +import Data.List ( find, sortBy ) +import qualified Data.Semigroup as S + +-- ----------------------------------------------------------------------------- +-- The AvailInfo type + +-- | Records what things are \"available\", i.e. in scope +data AvailInfo + + -- | An ordinary identifier in scope, or a field label without a parent type + -- (see Note [Representing pattern synonym fields in AvailInfo]). + = Avail Name + + -- | A type or class in scope + -- + -- The __AvailTC Invariant__: If the type or class is itself to be in scope, + -- it must be /first/ in this list. Thus, typically: + -- + -- > AvailTC Eq [Eq, ==, \/=] + | AvailTC + Name -- ^ The name of the type or class + [Name] -- ^ The available pieces of type or class + + deriving Data + +-- | A collection of 'AvailInfo' - several things that are \"available\" +type Avails = [AvailInfo] + +-- | Occurrences of Avails in interface files must be deterministically ordered +-- to guarantee interface file determinism. +-- +-- We guarantee a deterministic order by either using the order explicitly +-- given by the user (e.g. in an explicit constructor export list) or instead +-- by sorting the avails with 'sortAvails'. +newtype DetOrdAvails = DefinitelyDeterministicAvails { getDetOrdAvails :: Avails } + deriving newtype (Binary, Outputable, NFData) + +instance Eq DetOrdAvails where + a1 == a2 = compare a1 a2 == EQ +instance Ord DetOrdAvails where + compare (DetOrdAvails a1) (DetOrdAvails a2) = go a1 a2 + where + go [] [] = EQ + go _ [] = LT + go [] _ = GT + go (a:as) (b:bs) = + case (a, b) of + (Avail {}, AvailTC {}) -> LT + (AvailTC{}, Avail {}) -> GT + (Avail n1, Avail n2) -> stableNameCmp n1 n2 S.<> go as bs + (AvailTC n1 m1s, AvailTC n2 m2s) -> + stableNameCmp n1 n2 S.<> foldMap (uncurry stableNameCmp) (zip m1s m2s) S.<> go as bs + +-- | It's always safe to match on 'DetOrdAvails' +pattern DetOrdAvails :: Avails -> DetOrdAvails +pattern DetOrdAvails x <- DefinitelyDeterministicAvails x +{-# COMPLETE DetOrdAvails #-} + +{- Note [Representing pattern synonym fields in AvailInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record pattern synonym fields cannot be represented using AvailTC like fields of +normal record types, because they do not always have a parent type constructor. +So we represent them using the Avail constructor. + +Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration + + pattern MkFoo{f} = Bar f + +gives rise to the AvailInfo + + Avail MkFoo, Avail f + +However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in +an export list, then whenever `f` is imported the parent will be `T`, +represented as + + AvailTC T [ T, MkFoo, f ] +-} + +-- | Compare lexicographically +stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering +stableAvailCmp (Avail c1) (Avail c2) = c1 `stableNameCmp` c2 +stableAvailCmp (Avail {}) (AvailTC {}) = LT +stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableNameCmp ns ms +stableAvailCmp (AvailTC {}) (Avail {}) = GT + +-- ----------------------------------------------------------------------------- +-- Operations on AvailInfo + +availsToNameSet :: [AvailInfo] -> NameSet +availsToNameSet avails = foldr add emptyNameSet avails + where add avail set = extendNameSetList set (availNames avail) + +availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo +availsToNameEnv avails = foldr add emptyNameEnv avails + where add avail env = extendNameEnvList env + (zip (availNames avail) (repeat avail)) + +-- | Does this 'AvailInfo' export the parent decl? This depends on the +-- invariant that the parent is first if it appears at all. +availExportsDecl :: AvailInfo -> Bool +availExportsDecl (AvailTC ty_name names) + | n : _ <- names = ty_name == n + | otherwise = False +availExportsDecl _ = True + +-- | Just the main name made available, i.e. not the available pieces +-- of type or class brought into scope by the 'AvailInfo' +availName :: AvailInfo -> Name +availName (Avail n) = n +availName (AvailTC n _) = n + +-- | Names and fields made available by the availability information. +availNames :: AvailInfo -> [Name] +availNames (Avail c) = [c] +availNames (AvailTC _ cs) = cs + +-- | Names and fields made available by the availability information, other than +-- the main decl itself. +availSubordinateNames :: AvailInfo -> [Name] +availSubordinateNames (Avail {}) = [] +availSubordinateNames avail@(AvailTC _ ns) + | availExportsDecl avail = tail ns + | otherwise = ns + +-- | Sort 'Avails'/'AvailInfo's +sortAvails :: Avails -> DetOrdAvails +sortAvails = DefinitelyDeterministicAvails . sortBy stableAvailCmp . map sort_subs + where + sort_subs :: AvailInfo -> AvailInfo + sort_subs (Avail n) = Avail n + sort_subs (AvailTC n []) = AvailTC n [] + sort_subs (AvailTC n (m:ms)) + | n == m + = AvailTC n (m:sortBy stableNameCmp ms) + | otherwise + = AvailTC n (sortBy stableNameCmp (m:ms)) + -- Maintain the AvailTC Invariant + +-- ----------------------------------------------------------------------------- +-- Utility + +plusAvail :: AvailInfo -> AvailInfo -> AvailInfo +plusAvail a1 a2 + | debugIsOn && availName a1 /= availName a2 + = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2]) +plusAvail a1@(Avail {}) (Avail {}) = a1 +plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2 +plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1 +plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2)) + = case (n1 == s1, n2 == s2) of -- Maintain invariant the parent is first + (True,True) -> AvailTC n1 (s1 : (ss1 `unionListsOrd` ss2)) + (True,False) -> AvailTC n1 (s1 : (ss1 `unionListsOrd` (s2:ss2))) + (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionListsOrd` ss2)) + (False,False) -> AvailTC n1 ((s1:ss1) `unionListsOrd` (s2:ss2)) +plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2]) + +-- | trims an 'AvailInfo' to keep only a single name +trimAvail :: AvailInfo -> Name -> AvailInfo +trimAvail avail@(Avail {}) _ = avail +trimAvail avail@(AvailTC n ns) m = case find (== m) ns of + Just c -> AvailTC n [c] + Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr m]) + +-- | filters 'AvailInfo's by the given predicate +filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] +filterAvails keep avails = foldr (filterAvail keep) [] avails + +-- | filters an 'AvailInfo' by the given predicate +filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] +filterAvail keep ie rest = + case ie of + Avail c | keep c -> ie : rest + | otherwise -> rest + AvailTC tc cs -> + let cs' = filter keep cs + in if null cs' then rest else AvailTC tc cs' : rest + + +-- | Combines 'AvailInfo's from the same family +-- 'avails' may have several items with the same availName +-- E.g import Ix( Ix(..), index ) +-- will give Ix(Ix,index,range) and Ix(index) +-- We want to combine these; plusAvail does that +nubAvails :: [AvailInfo] -> [AvailInfo] +nubAvails avails = eltsDNameEnv (foldl' add emptyDNameEnv avails) + where + add env avail = extendDNameEnv_C plusAvail env (availName avail) avail + +-- ----------------------------------------------------------------------------- +-- Printing + +instance Outputable AvailInfo where + ppr = pprAvail + +pprAvail :: AvailInfo -> SDoc +pprAvail (Avail n) + = ppr n +pprAvail (AvailTC n ns) + = ppr n <> braces (pprWithCommas ppr ns) + +instance Binary AvailInfo where + put_ bh (Avail aa) = do + putByte bh 0 + put_ bh aa + put_ bh (AvailTC ab ac) = do + putByte bh 1 + put_ bh ab + put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (Avail aa) + _ -> do ab <- get bh + ac <- get bh + return (AvailTC ab ac) + +instance NFData AvailInfo where + rnf (Avail n) = rnf n + rnf (AvailTC a b) = rnf a `seq` rnf b + +-- | Create an empty DetOrdAvails +emptyDetOrdAvails :: DetOrdAvails +emptyDetOrdAvails = DefinitelyDeterministicAvails [] diff --git a/GHC/Types/Basic.hs b/GHC/Types/Basic.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Basic.hs @@ -0,0 +1,2464 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 + +\section[BasicTypes]{Miscellaneous types} + +This module defines a miscellaneously collection of very simple +types that + +\begin{itemize} +\item have no other obvious home +\item don't depend on any other complicated types +\item are used in more than one "part" of the compiler +\end{itemize} +-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable PromotionFlag, Binary PromotionFlag, Outputable Boxity, Binay Boxity +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} + +module GHC.Types.Basic ( + LeftOrRight(..), + pickLR, + + ConTag, ConTagZ, fIRST_TAG, + + Arity, VisArity, RepArity, JoinArity, FullArgCount, + JoinPointHood(..), isJoinPoint, + + Alignment, mkAlignment, alignmentOf, alignmentBytes, + + PromotionFlag(..), isPromoted, + FunctionOrData(..), + + RecFlag(..), isRec, isNonRec, boolToRecFlag, + Origin(..), isGenerated, DoPmc(..), requiresPMC, + GenReason(..), isDoExpansionGenerated, doExpansionFlavour, + doExpansionOrigin, + + RuleName, pprRuleName, + + TopLevelFlag(..), isTopLevel, isNotTopLevel, + + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, hasNonCanonicalFlag, + + Boxity(..), isBoxed, + + CbvMark(..), isMarkedCbv, + + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, + starPrec, appPrec, maxPrec, + maybeParen, + + TupleSort(..), tupleSortBoxity, boxityTupleSort, + tupleParens, + + UnboxedTupleOrSum(..), unboxedTupleOrSumExtension, + sumParens, pprAlternative, + + -- ** The OneShotInfo type + OneShotInfo(..), + noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, + bestOneShot, worstOneShot, + + OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc, + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, + isNoOccInfo, strongLoopBreaker, weakLoopBreaker, + + InsideLam(..), + BranchCount, oneBranch, + InterestingCxt(..), + TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, + isAlwaysTailCalled, + + EP(..), + + DefMethSpec(..), + SwapFlag(..), flipSwap, unSwap, notSwapped, isSwapped, pickSwap, + + CompilerPhase(..), PhaseNum, beginPhase, nextPhase, laterPhase, + + Activation(..), isActive, competesWith, + isNeverActive, isAlwaysActive, activeInFinalPhase, activeInInitialPhase, + activateAfterInitial, activateDuringFinal, activeAfter, + + RuleMatchInfo(..), isConLike, isFunLike, + InlineSpec(..), noUserInlineSpec, + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, + neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, + isInlinePragma, isInlinablePragma, isNoInlinePragma, isOpaquePragma, + isAnyInlinePragma, alwaysInlineConLikePragma, + inlinePragmaSource, + inlinePragmaName, inlineSpecSource, + inlinePragmaSpec, inlinePragmaSat, + inlinePragmaActivation, inlinePragmaRuleMatchInfo, + setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, + pprInline, pprInlineDebug, + + UnfoldingSource(..), isStableSource, isStableUserSource, + isStableSystemSource, isCompulsorySource, + + SuccessFlag(..), succeeded, failed, successIf, + + IntWithInf, infinity, treatZeroAsInf, subWithInf, mkIntWithInf, intGtLimit, + + TypeOrKind(..), isTypeLevel, isKindLevel, + + Levity(..), mightBeLifted, mightBeUnlifted, + TypeOrConstraint(..), + + TyConFlavour(..), TypeOrData(..), NewOrData(..), tyConFlavourAssoc_maybe, + + NonStandardDefaultingStrategy(..), + DefaultingStrategy(..), defaultNonStandardTyVars, + + ForeignSrcLang (..), + + ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels + ) where + +import GHC.Prelude + +import GHC.ForeignSrcLang +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Binary +import GHC.Types.SourceText +import qualified GHC.LanguageExtensions as LangExt +import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted) +import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag) +import {-# SOURCE #-} Language.Haskell.Syntax.Expr (HsDoFlavour) +import Control.DeepSeq ( NFData(..) ) +import Data.Data +import Data.Maybe +import qualified Data.Semigroup as Semi + +import Language.Haskell.Syntax.ImpExp +{- +************************************************************************ +* * + Binary choice +* * +********************************************************************* -} + +data LeftOrRight = CLeft | CRight + deriving( Eq, Data, Ord ) + +pickLR :: LeftOrRight -> (a,a) -> a +pickLR CLeft (l,_) = l +pickLR CRight (_,r) = r + +instance Outputable LeftOrRight where + ppr CLeft = text "Left" + ppr CRight = text "Right" + +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } + +instance NFData LeftOrRight where + rnf CLeft = () + rnf CRight = () + + + +{- +************************************************************************ +* * +\subsection[Arity]{Arity} +* * +************************************************************************ +-} + +-- | The number of value arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has arity 0 +-- \x -> fib x has arity 1 +-- See also Note [Definition of arity] in "GHC.Core.Opt.Arity" +type Arity = Int + +-- | Syntactic (visibility) arity, i.e. the number of visible arguments. +-- See Note [Visibility and arity] +type VisArity = Int + +-- | Representation Arity +-- +-- The number of represented arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has representation arity 0 +-- \x -> fib x has representation arity 1 +-- \(# x, y #) -> fib (x + y) has representation arity 2 +type RepArity = Int + +-- | The number of arguments that a join point takes. Unlike the arity of a +-- function, this is a purely syntactic property and is fixed when the join +-- point is created (or converted from a value). Both type and value arguments +-- are counted. +type JoinArity = Int + +-- | FullArgCount is the number of type or value arguments in an application, +-- or the number of type or value binders in a lambda. Note: it includes +-- both type and value arguments! +type FullArgCount = Int + +{- Note [Visibility and arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Arity is the number of arguments that a function expects. In a curried language +like Haskell, there is more than one way to count those arguments. + +* `Arity` is the classic notion of arity, concerned with evalution, so it counts + the number of /value/ arguments that need to be supplied before evaluation can + take place, as described in notes + Note [Definition of arity] in GHC.Core.Opt.Arity + Note [Arity and function types] in GHC.Types.Id.Info + + Examples: + Int has arity == 0 + Int -> Int has arity <= 1 + Int -> Bool -> Int has arity <= 2 + We write (<=) rather than (==) as sometimes evaluation can occur before all + value arguments are supplied, depending on the actual function definition. + + This evaluation-focused notion of arity ignores type arguments, so: + forall a. a has arity == 0 + forall a. a -> a has arity <= 1 + forall a b. a -> b -> a has arity <= 2 + This is true regardless of ForAllTyFlag, so the arity is also unaffected by + (forall {a}. ty) or (forall a -> ty). + + Class dictionaries count towards the arity, as they are passed at runtime + forall a. (Num a) => a has arity <= 1 + forall a. (Num a) => a -> a has arity <= 2 + forall a b. (Num a, Ord b) => a -> b -> a has arity <= 4 + +* `VisArity` is the syntactic notion of arity. It is the number of /visible/ + arguments, i.e. arguments that occur visibly in the source code. + + In a function call `f x y z`, we can confidently say that f's vis-arity >= 3, + simply because we see three arguments [x,y,z]. We write (>=) rather than (==) + as this could be a partial application. + + At definition sites, we can acquire an underapproximation of vis-arity by + counting the patterns on the LHS, e.g. `f a b = rhs` has vis-arity >= 2. + The actual vis-arity can be higher if there is a lambda on the RHS, + e.g. `f a b = \c -> rhs`. + + If we look at the types, we can observe the following + * function arrows (a -> b) add to the vis-arity + * visible foralls (forall a -> b) add to the vis-arity + * constraint arrows (a => b) do not affect the vis-arity + * invisible foralls (forall a. b) do not affect the vis-arity + + This means that ForAllTyFlag matters for VisArity (in contrast to Arity), + while the type/value distinction is unimportant (again in contrast to Arity). + + Examples: + Int -- vis-arity == 0 (no args) + Int -> Int -- vis-arity == 1 (1 funarg) + forall a. a -> a -- vis-arity == 1 (1 funarg) + forall a. Num a => a -> a -- vis-arity == 1 (1 funarg) + forall a -> Num a => a -- vis-arity == 1 (1 req tyarg, 0 funargs) + forall a -> a -> a -- vis-arity == 2 (1 req tyarg, 1 funarg) + Int -> forall a -> Int -- vis-arity == 2 (1 funarg, 1 req tyarg) + + Wrinkle: with TypeApplications and TypeAbstractions, it is possible to visibly + bind and pass invisible arguments, e.g. `f @a x = ...` or `f @Int 42`. Those + @-prefixed arguments are ignored for the purposes of vis-arity. +-} + +{- +************************************************************************ +* * + Constructor tags +* * +************************************************************************ +-} + +-- | A *zero-indexed* constructor tag +type ConTagZ = Int + +fIRST_TAG :: ConTag +-- ^ Tags are allocated from here for real constructors +-- or for superclass selectors +fIRST_TAG = 1 + +{- +************************************************************************ +* * +\subsection[Alignment]{Alignment} +* * +************************************************************************ +-} + +-- | A power-of-two alignment +newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord) + +-- Builds an alignment, throws on non power of 2 input. This is not +-- ideal, but convenient for internal use and better then silently +-- passing incorrect data. +mkAlignment :: Int -> Alignment +mkAlignment n + | n == 1 = Alignment 1 + | n == 2 = Alignment 2 + | n == 4 = Alignment 4 + | n == 8 = Alignment 8 + | n == 16 = Alignment 16 + | n == 32 = Alignment 32 + | n == 64 = Alignment 64 + | n == 128 = Alignment 128 + | n == 256 = Alignment 256 + | n == 512 = Alignment 512 + | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512" + +-- Calculates an alignment of a number. x is aligned at N bytes means +-- the remainder from x / N is zero. Currently, interested in N <= 8, +-- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX +-- context. +alignmentOf :: Int -> Alignment +alignmentOf x = case x .&. 7 of + 0 -> Alignment 8 + 4 -> Alignment 4 + 2 -> Alignment 2 + _ -> Alignment 1 + +instance Outputable Alignment where + ppr (Alignment m) = ppr m + +instance OutputableP env Alignment where + pdoc _ = ppr + +{- +************************************************************************ +* * + One-shot information +* * +************************************************************************ +-} + +{- +Note [OneShotInfo overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Lambda-bound Ids (and only lambda-bound Ids) may be decorated with +one-shot info. The idea is that if we see + (\x{one-shot}. e) +it means that this lambda will only be applied once. In particular +that means we can float redexes under the lambda without losing +work. For example, consider + let t = expensive in + (\x{one-shot}. case t of { True -> ...; False -> ... }) + +Because it's a one-shot lambda, we can safely inline t, giving + (\x{one_shot}. case of + { True -> ...; False -> ... }) + +Moving parts: + +* Usage analysis, performed as part of demand-analysis, finds + out whether functions call their argument once. Consider + f g x = Just (case g x of { ... }) + + Here 'f' is lazy in 'g', but it guarantees to call it no + more than once. So g will get a C(1,U) usage demand. + +* Occurrence analysis propagates this usage information + (in the demand signature of a function) to its calls. + Example, given 'f' above + f (\x.e) blah + + Since f's demand signature says it has a C(1,U) usage demand on its + first argument, the occurrence analyser sets the \x to be one-shot. + This is done via the occ_one_shots field of OccEnv. + +* Float-in and float-out take account of one-shot-ness + +* Occurrence analysis doesn't set "inside-lam" for occurrences inside + a one-shot lambda + +Other notes + +* A one-shot lambda can use its argument many times. To elaborate + the example above + let t = expensive in + (\x{one-shot}. case t of { True -> x+x; False -> x*x }) + + Here the '\x' is one-shot, which justifies inlining 't', + but x is used many times. That's absolutely fine. + +* It's entirely possible to have + (\x{one-shot}. \y{many-shot}. e) + + For example + let t = expensive + g = \x -> let v = x+t in + \y -> x + v + in map (g 5) xs + + Here the `\x` is a one-shot binder: `g` is applied to one argument + exactly once. And because the `\x` is one-shot, it would be fine to + float that `let t = expensive` binding inside the `\x`. + + But the `\y` is most definitely not one-shot! +-} + +-- | If the 'Id' is a lambda-bound variable then it may have lambda-bound +-- variable info. Sometimes we know whether the lambda binding this variable +-- is a "one-shot" lambda; that is, whether it is applied at most once. +-- +-- This information may be useful in optimisation, as computations may +-- safely be floated inside such a lambda without risk of duplicating +-- work. +-- +-- See also Note [OneShotInfo overview] above. +data OneShotInfo + = NoOneShotInfo -- ^ No information + | OneShotLam -- ^ The lambda is applied at most once. + deriving (Eq) + +-- | It is always safe to assume that an 'Id' has no lambda-bound variable information +noOneShotInfo :: OneShotInfo +noOneShotInfo = NoOneShotInfo + +isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool +isOneShotInfo OneShotLam = True +isOneShotInfo _ = False + +hasNoOneShotInfo NoOneShotInfo = True +hasNoOneShotInfo _ = False + +worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo +worstOneShot NoOneShotInfo _ = NoOneShotInfo +worstOneShot OneShotLam os = os + +bestOneShot NoOneShotInfo os = os +bestOneShot OneShotLam _ = OneShotLam + +pprOneShotInfo :: OneShotInfo -> SDoc +pprOneShotInfo NoOneShotInfo = text "NoOS" +pprOneShotInfo OneShotLam = text "OneShot" + +instance Outputable OneShotInfo where + ppr = pprOneShotInfo + +{- +************************************************************************ +* * + Swap flag +* * +************************************************************************ +-} + +data SwapFlag + = NotSwapped -- Args are: actual, expected + | IsSwapped -- Args are: expected, actual + deriving( Eq ) + +instance Outputable SwapFlag where + ppr IsSwapped = text "Is-swapped" + ppr NotSwapped = text "Not-swapped" + +flipSwap :: SwapFlag -> SwapFlag +flipSwap IsSwapped = NotSwapped +flipSwap NotSwapped = IsSwapped + +isSwapped :: SwapFlag -> Bool +isSwapped IsSwapped = True +isSwapped NotSwapped = False + +notSwapped :: SwapFlag -> Bool +notSwapped NotSwapped = True +notSwapped IsSwapped = False + +pickSwap :: SwapFlag -> a -> a -> a +pickSwap NotSwapped a _ = a +pickSwap IsSwapped _ b = b + +unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b +unSwap NotSwapped f a b = f a b +unSwap IsSwapped f a b = f b a + + +{- ********************************************************************* +* * + Promotion flag +* * +********************************************************************* -} + +instance Outputable PromotionFlag where + ppr NotPromoted = text "NotPromoted" + ppr IsPromoted = text "IsPromoted" + +instance Binary PromotionFlag where + put_ bh NotPromoted = putByte bh 0 + put_ bh IsPromoted = putByte bh 1 + + get bh = do + n <- getByte bh + case n of + 0 -> return NotPromoted + 1 -> return IsPromoted + _ -> fail "Binary(IsPromoted): fail)" + +{- +************************************************************************ +* * +\subsection[FunctionOrData]{FunctionOrData} +* * +************************************************************************ +-} + +data FunctionOrData = IsFunction | IsData + deriving (Eq, Ord, Data) + +instance Outputable FunctionOrData where + ppr IsFunction = text "(function)" + ppr IsData = text "(data)" + +instance Binary FunctionOrData where + put_ bh IsFunction = putByte bh 0 + put_ bh IsData = putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> return IsFunction + 1 -> return IsData + _ -> panic "Binary FunctionOrData" + +instance NFData FunctionOrData where + rnf IsFunction = () + rnf IsData = () + +{- +************************************************************************ +* * + Rules +* * +************************************************************************ +-} + +type RuleName = FastString + +pprRuleName :: RuleName -> SDoc +pprRuleName rn = doubleQuotes (ftext rn) + + +{- +************************************************************************ +* * +\subsection[Top-level/local]{Top-level/not-top level flag} +* * +************************************************************************ +-} + +data TopLevelFlag + = TopLevel + | NotTopLevel + deriving Data + +isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool + +isNotTopLevel NotTopLevel = True +isNotTopLevel TopLevel = False + +isTopLevel TopLevel = True +isTopLevel NotTopLevel = False + +instance Outputable TopLevelFlag where + ppr TopLevel = text "" + ppr NotTopLevel = text "" + +{- +************************************************************************ +* * + Boxity flag +* * +************************************************************************ +-} + +instance Outputable Boxity where + ppr Boxed = text "Boxed" + ppr Unboxed = text "Unboxed" + +instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool + put_ bh = put_ bh . isBoxed + get bh = do + b <- get bh + pure $ if b then Boxed else Unboxed + +{- +************************************************************************ +* * + Call by value flag +* * +************************************************************************ +-} + +-- | Should an argument be passed evaluated *and* tagged. +data CbvMark = MarkedCbv | NotMarkedCbv + deriving Eq + +instance Outputable CbvMark where + ppr MarkedCbv = text "!" + ppr NotMarkedCbv = text "~" + +instance Binary CbvMark where + put_ bh NotMarkedCbv = putByte bh 0 + put_ bh MarkedCbv = putByte bh 1 + get bh = + do h <- getByte bh + case h of + 0 -> return NotMarkedCbv + 1 -> return MarkedCbv + _ -> panic "Invalid binary format" + +instance NFData CbvMark where + rnf MarkedCbv = () + rnf NotMarkedCbv = () + + +isMarkedCbv :: CbvMark -> Bool +isMarkedCbv MarkedCbv = True +isMarkedCbv NotMarkedCbv = False + + +{- +************************************************************************ +* * + Recursive/Non-Recursive flag +* * +************************************************************************ +-} + +-- | Recursivity Flag +data RecFlag = Recursive + | NonRecursive + deriving( Eq, Data ) + +isRec :: RecFlag -> Bool +isRec Recursive = True +isRec NonRecursive = False + +isNonRec :: RecFlag -> Bool +isNonRec Recursive = False +isNonRec NonRecursive = True + +boolToRecFlag :: Bool -> RecFlag +boolToRecFlag True = Recursive +boolToRecFlag False = NonRecursive + +instance Outputable RecFlag where + ppr Recursive = text "Recursive" + ppr NonRecursive = text "NonRecursive" + +instance Binary RecFlag where + put_ bh Recursive = + putByte bh 0 + put_ bh NonRecursive = + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> return Recursive + _ -> return NonRecursive + +{- +************************************************************************ +* * + Code origin +* * +************************************************************************ +-} + +-- | Was this piece of code user-written or generated by the compiler? +-- +-- See Note [Generated code and pattern-match checking]. +data Origin = FromSource + | Generated GenReason DoPmc + deriving( Eq, Data ) + +isGenerated :: Origin -> Bool +isGenerated Generated{} = True +isGenerated FromSource = False + +-- | This metadata stores the information as to why was the piece of code generated +-- It is useful for generating the right error context +-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` +data GenReason = DoExpansion HsDoFlavour + | OtherExpansion + deriving (Eq, Data) + +instance Outputable GenReason where + ppr DoExpansion{} = text "DoExpansion" + ppr OtherExpansion = text "OtherExpansion" + +doExpansionFlavour :: Origin -> Maybe HsDoFlavour +doExpansionFlavour (Generated (DoExpansion f) _) = Just f +doExpansionFlavour _ = Nothing + +-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` +isDoExpansionGenerated :: Origin -> Bool +isDoExpansionGenerated = isJust . doExpansionFlavour + +-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` +doExpansionOrigin :: HsDoFlavour -> Origin +doExpansionOrigin f = Generated (DoExpansion f) DoPmc + -- It is important that we perfrom PMC + -- on the expressions generated by do statements + -- to get the right pattern match checker warnings + -- See `GHC.HsToCore.Pmc.pmcMatches` + +instance Outputable Origin where + ppr FromSource = text "FromSource" + ppr (Generated reason pmc) = text "Generated" <+> ppr reason <+> ppr pmc + +-- | Whether to run pattern-match checks in generated code. +-- +-- See Note [Generated code and pattern-match checking]. +data DoPmc = SkipPmc + | DoPmc + deriving( Eq, Data ) + +instance Outputable DoPmc where + ppr SkipPmc = text "SkipPmc" + ppr DoPmc = text "DoPmc" + +-- | Does this 'Origin' require us to run pattern-match checking, +-- or should we skip these checks? +-- +-- See Note [Generated code and pattern-match checking]. +requiresPMC :: Origin -> Bool +requiresPMC (Generated _ SkipPmc) = False +requiresPMC _ = True + +{- Note [Generated code and pattern-match checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some parts of the compiler generate code that is then typechecked. For example: + + - the XXExprGhcRn mechanism described in Note [Rebindable syntax and XXExprGhcRn] + in GHC.Hs.Expr, + - the deriving mechanism. + +It is usually the case that we want to avoid generating error messages that +refer to generated code. The way this is handled is that we mark certain +parts of the AST as being generated (using the Origin datatype); this is then +used to set the tcl_in_gen_code flag in TcLclEnv, as explained in +Note [Error contexts in generated code] in GHC.Tc.Utils.Monad. + +Being in generated code is usually taken to mean we should also skip doing +pattern-match checking, but not always. For example, when desugaring a record +update (as described in Note [Record Updates] in GHC.Tc.Gen.Expr), we still want +to do pattern-match checking, in order to report incomplete record updates +(failing to do so lead to #23250). So, for a 'Generated' 'Origin', we keep track +of whether we should do pattern-match checks; see the calls of the requiresPMC +function (e.g. isMatchContextPmChecked and needToRunPmCheck in GHC.HsToCore.Pmc.Utils). +-} + +{- +************************************************************************ +* * + Instance overlap flag +* * +************************************************************************ +-} + +-- | The semantics allowed for overlapping instances for a particular +-- instance. See Note [Safe Haskell isSafeOverlap] in GHC.Core.InstEnv for a +-- explanation of the `isSafeOverlap` field. +-- + +data OverlapFlag = OverlapFlag + { overlapMode :: OverlapMode + , isSafeOverlap :: Bool + } deriving (Eq, Data) + +setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag +setOverlapModeMaybe f Nothing = f +setOverlapModeMaybe f (Just m) = f { overlapMode = m } + +hasIncoherentFlag :: OverlapMode -> Bool +hasIncoherentFlag mode = + case mode of + Incoherent _ -> True + NonCanonical _ -> True + _ -> False + +hasOverlappableFlag :: OverlapMode -> Bool +hasOverlappableFlag mode = + case mode of + Overlappable _ -> True + Overlaps _ -> True + Incoherent _ -> True + NonCanonical _ -> True + _ -> False + +hasOverlappingFlag :: OverlapMode -> Bool +hasOverlappingFlag mode = + case mode of + Overlapping _ -> True + Overlaps _ -> True + Incoherent _ -> True + NonCanonical _ -> True + _ -> False + +hasNonCanonicalFlag :: OverlapMode -> Bool +hasNonCanonicalFlag = \case + NonCanonical{} -> True + _ -> False + +data OverlapMode -- See Note [Rules for instance lookup] in GHC.Core.InstEnv + = NoOverlap SourceText + -- See Note [Pragma source text] + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + + | Overlapping SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + + | Overlaps SourceText + -- See Note [Pragma source text] + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent SourceText + -- See Note [Pragma source text] + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv" + + | NonCanonical SourceText + -- ^ Behave like Incoherent, but the instance choice is observable + -- by the program behaviour. See Note [Coherence and specialisation: overview]. + -- + -- We don't have surface syntax for the distinction between + -- Incoherent and NonCanonical instances; instead, the flag + -- `-f{no-}specialise-incoherents` (on by default) controls + -- whether `INCOHERENT` instances are regarded as Incoherent or + -- NonCanonical. + + deriving (Eq, Data) + + +instance Outputable OverlapFlag where + ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) + +instance NFData OverlapFlag where + rnf (OverlapFlag mode safe) = rnf mode `seq` rnf safe + +instance Outputable OverlapMode where + ppr (NoOverlap _) = empty + ppr (Overlappable _) = text "[overlappable]" + ppr (Overlapping _) = text "[overlapping]" + ppr (Overlaps _) = text "[overlap ok]" + ppr (Incoherent _) = text "[incoherent]" + ppr (NonCanonical _) = text "[noncanonical]" + +instance NFData OverlapMode where + rnf (NoOverlap s) = rnf s + rnf (Overlappable s) = rnf s + rnf (Overlapping s) = rnf s + rnf (Overlaps s) = rnf s + rnf (Incoherent s) = rnf s + rnf (NonCanonical s) = rnf s + +instance Binary OverlapMode where + put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s + put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s + put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s + put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s + put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s + put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s + get bh = do + h <- getByte bh + case h of + 0 -> (get bh) >>= \s -> return $ NoOverlap s + 1 -> (get bh) >>= \s -> return $ Overlaps s + 2 -> (get bh) >>= \s -> return $ Incoherent s + 3 -> (get bh) >>= \s -> return $ Overlapping s + 4 -> (get bh) >>= \s -> return $ Overlappable s + 5 -> (get bh) >>= \s -> return $ NonCanonical s + _ -> panic ("get OverlapMode" ++ show h) + + +instance Binary OverlapFlag where + put_ bh flag = do put_ bh (overlapMode flag) + put_ bh (isSafeOverlap flag) + get bh = do + h <- get bh + b <- get bh + return OverlapFlag { overlapMode = h, isSafeOverlap = b } + +pprSafeOverlap :: Bool -> SDoc +pprSafeOverlap True = text "[safe]" +pprSafeOverlap False = empty + +{- +************************************************************************ +* * + Precedence +* * +************************************************************************ +-} + +-- | A general-purpose pretty-printing precedence type. +newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) +-- See Note [Precedence in types] + +topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec, maxPrec :: PprPrec +topPrec = PprPrec 0 -- No parens +sigPrec = PprPrec 1 -- Explicit type signatures +funPrec = PprPrec 2 -- Function args; no parens for constructor apps + -- See [Type operator precedence] for why both + -- funPrec and opPrec exist. +opPrec = PprPrec 2 -- Infix operator +starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *) + -- See Note [Star kind precedence] +appPrec = PprPrec 4 -- Constructor args; no parens for atomic +maxPrec = appPrec -- Maximum precendence + +maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty + +{- Note [Precedence in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Many pretty-printing functions have type + ppr_ty :: PprPrec -> Type -> SDoc + +The PprPrec gives the binding strength of the context. For example, in + T ty1 ty2 +we will pretty-print 'ty1' and 'ty2' with the call + (ppr_ty appPrec ty) +to indicate that the context is that of an argument of a TyConApp. + +We use this consistently for Type and HsType. + +Note [Type operator precedence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't keep the fixity of type operators in the operator. So the +pretty printer follows the following precedence order: + + TyConPrec Type constructor application + TyOpPrec/FunPrec Operator application and function arrow + +We have funPrec and opPrec to represent the precedence of function +arrow and type operators respectively, but currently we implement +funPrec == opPrec, so that we don't distinguish the two. Reason: +it's hard to parse a type like + a ~ b => c * d -> e - f + +By treating opPrec = funPrec we end up with more parens + (a ~ b) => (c * d) -> (e - f) + +But the two are different constructors of PprPrec so we could make +(->) bind more or less tightly if we wanted. + +Note [Star kind precedence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We parenthesize the (*) kind to avoid two issues: + +1. Printing invalid or incorrect code. + For example, instead of type F @(*) x = x + GHC used to print type F @* x = x + However, (@*) is a type operator, not a kind application. + +2. Printing kinds that are correct but hard to read. + Should Either * Int be read as Either (*) Int + or as (*) Either Int ? + This depends on whether -XStarIsType is enabled, but it would be + easier if we didn't have to check for the flag when reading the code. + +At the same time, we cannot parenthesize (*) blindly. +Consider this Haskell98 kind: ((* -> *) -> *) -> * +With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*) + +The solution is to assign a special precedence to (*), 'starPrec', which is +higher than 'funPrec' but lower than 'appPrec': + + F * * * becomes F (*) (*) (*) + F A * B becomes F A (*) B + Proxy * becomes Proxy (*) + a * -> * becomes a (*) -> * +-} + +{- +************************************************************************ +* * + Tuples +* * +************************************************************************ +-} + +data TupleSort + = BoxedTuple + | UnboxedTuple + | ConstraintTuple + deriving( Eq, Data, Ord ) + +instance Outputable TupleSort where + ppr ts = text $ + case ts of + BoxedTuple -> "BoxedTuple" + UnboxedTuple -> "UnboxedTuple" + ConstraintTuple -> "ConstraintTuple" + +instance Binary TupleSort where + put_ bh BoxedTuple = putByte bh 0 + put_ bh UnboxedTuple = putByte bh 1 + put_ bh ConstraintTuple = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return BoxedTuple + 1 -> return UnboxedTuple + _ -> return ConstraintTuple + +instance NFData TupleSort where + rnf BoxedTuple = () + rnf UnboxedTuple = () + rnf ConstraintTuple = () + + +tupleSortBoxity :: TupleSort -> Boxity +tupleSortBoxity BoxedTuple = Boxed +tupleSortBoxity UnboxedTuple = Unboxed +tupleSortBoxity ConstraintTuple = Boxed + +boxityTupleSort :: Boxity -> TupleSort +boxityTupleSort Boxed = BoxedTuple +boxityTupleSort Unboxed = UnboxedTuple + +tupleParens :: TupleSort -> SDoc -> SDoc +tupleParens BoxedTuple p = parens p +tupleParens UnboxedTuple p = text "(#" <+> p <+> text "#)" +tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) + = ifPprDebug (text "(%" <+> p <+> text "%)") + (parens p) + +{- +************************************************************************ +* * + Sums +* * +************************************************************************ +-} + +sumParens :: SDoc -> SDoc +sumParens p = text "(#" <+> p <+> text "#)" + +-- | Pretty print an alternative in an unboxed sum e.g. "| a | |". +pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use + -> a -- ^ The things to be pretty printed + -> ConTag -- ^ Alternative (one-based) + -> Arity -- ^ Arity + -> SDoc -- ^ 'SDoc' where the alternative havs been pretty + -- printed and finally packed into a paragraph. +pprAlternative pp x alt arity = + fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) + +-- | Are we dealing with an unboxed tuple or an unboxed sum? +-- +-- Used when validity checking, see 'check_ubx_tuple_or_sum'. +data UnboxedTupleOrSum + = UnboxedTupleType + | UnboxedSumType + deriving Eq + +instance Outputable UnboxedTupleOrSum where + ppr UnboxedTupleType = text "UnboxedTupleType" + ppr UnboxedSumType = text "UnboxedSumType" + +unboxedTupleOrSumExtension :: UnboxedTupleOrSum -> LangExt.Extension +unboxedTupleOrSumExtension UnboxedTupleType = LangExt.UnboxedTuples +unboxedTupleOrSumExtension UnboxedSumType = LangExt.UnboxedSums + +{- +************************************************************************ +* * +\subsection[Generic]{Generic flag} +* * +************************************************************************ + +This is the "Embedding-Projection pair" datatype, it contains +two pieces of code (normally either RenamedExpr's or Id's) +If we have a such a pair (EP from to), the idea is that 'from' and 'to' +represents functions of type + + from :: T -> Tring + to :: Tring -> T + +And we should have + + to (from x) = x + +T and Tring are arbitrary, but typically T is the 'main' type while +Tring is the 'representation' type. (This just helps us remember +whether to use 'from' or 'to'. +-} + +-- | Embedding Projection pair +data EP a = EP { fromEP :: a, -- :: T -> Tring + toEP :: a } -- :: Tring -> T + +{- +Embedding-projection pairs are used in several places: + +First of all, each type constructor has an EP associated with it, the +code in EP converts (datatype T) from T to Tring and back again. + +Secondly, when we are filling in Generic methods (in the typechecker, +tcMethodBinds), we are constructing bimaps by induction on the structure +of the type of the method signature. + + +************************************************************************ +* * +\subsection{Occurrence information} +* * +************************************************************************ + +Note [OccInfo] +~~~~~~~~~~~~~ +The OccInfo data type is used exclusively by the simplifier, but it appears in a +SubstResult, which is currently defined in GHC.Types.Var.Env, which is pretty +near the base of the module hierarchy. So it seemed simpler to put the defn of +OccInfo here, safely at the bottom. + +Note that `OneOcc` doesn't meant that it occurs /syntactially/ only once; it +means that it is /used/ only once. It might occur syntactically many times. +For example, in (case x of A -> y; B -> y; C -> True), +* `y` is used only once +* but it occurs syntactically twice + +-} + +-- | identifier Occurrence Information +data OccInfo -- See Note [OccInfo] + = ManyOccs { occ_tail :: !TailCallInfo } + -- ^ There are many occurrences, or unknown occurrences + + | IAmDead -- ^ Marks unused variables. Sometimes useful for + -- lambda and case-bound variables. + + | OneOcc { occ_in_lam :: !InsideLam + , occ_n_br :: {-# UNPACK #-} !BranchCount + , occ_int_cxt :: !InterestingCxt + , occ_tail :: !TailCallInfo } + -- ^ Occurs exactly once (per branch), not inside a rule + + -- | This identifier breaks a loop of mutually recursive functions. The field + -- marks whether it is only a loop breaker due to a reference in a rule + | IAmALoopBreaker { occ_rules_only :: !RulesOnly + , occ_tail :: !TailCallInfo } + -- Note [LoopBreaker OccInfo] + deriving (Eq) + +type RulesOnly = Bool + +type BranchCount = Int + -- For OneOcc, the BranchCount says how many syntactic occurrences there are + -- At the moment we really only check for 1 or >1, but in principle + -- we could pay attention to how *many* occurrences there are + -- (notably in postInlineUnconditionally). + -- But meanwhile, Ints are very efficiently represented. + +oneBranch :: BranchCount +oneBranch = 1 + +{- +Note [LoopBreaker OccInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + IAmALoopBreaker True <=> A "weak" or rules-only loop breaker + Do not preInlineUnconditionally + + IAmALoopBreaker False <=> A "strong" loop breaker + Do not inline at all + +See OccurAnal Note [Weak loop breakers] +-} + +noOccInfo :: OccInfo +noOccInfo = ManyOccs { occ_tail = NoTailCallInfo } + +isNoOccInfo :: OccInfo -> Bool +isNoOccInfo ManyOccs { occ_tail = NoTailCallInfo } = True +isNoOccInfo _ = False + +isManyOccs :: OccInfo -> Bool +isManyOccs ManyOccs{} = True +isManyOccs _ = False + +seqOccInfo :: OccInfo -> () +seqOccInfo occ = occ `seq` () + +----------------- +-- | Interesting Context +data InterestingCxt + = IsInteresting + -- ^ Function: is applied + -- Data value: scrutinised by a case with at least one non-DEFAULT branch + | NotInteresting + deriving (Eq) + +-- | If there is any 'interesting' identifier occurrence, then the +-- aggregated occurrence info of that identifier is considered interesting. +instance Semi.Semigroup InterestingCxt where + NotInteresting <> x = x + IsInteresting <> _ = IsInteresting + +instance Monoid InterestingCxt where + mempty = NotInteresting + mappend = (Semi.<>) + +----------------- +-- | Inside Lambda +data InsideLam + = IsInsideLam + -- ^ Occurs inside a non-linear lambda + -- Substituting a redex for this occurrence is + -- dangerous because it might duplicate work. + | NotInsideLam + deriving (Eq) + +-- | If any occurrence of an identifier is inside a lambda, then the +-- occurrence info of that identifier marks it as occurring inside a lambda +instance Semi.Semigroup InsideLam where + NotInsideLam <> x = x + IsInsideLam <> _ = IsInsideLam + +instance Monoid InsideLam where + mempty = NotInsideLam + mappend = (Semi.<>) + +----------------- +data TailCallInfo + = AlwaysTailCalled {-# UNPACK #-} !JoinArity -- See Note [TailCallInfo] + | NoTailCallInfo + deriving (Eq) + +tailCallInfo :: OccInfo -> TailCallInfo +tailCallInfo IAmDead = NoTailCallInfo +tailCallInfo other = occ_tail other + +zapOccTailCallInfo :: OccInfo -> OccInfo +zapOccTailCallInfo IAmDead = IAmDead +zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo } + +isAlwaysTailCalled :: OccInfo -> Bool +isAlwaysTailCalled occ + = case tailCallInfo occ of AlwaysTailCalled{} -> True + NoTailCallInfo -> False + +instance Outputable TailCallInfo where + ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ] + ppr _ = empty + +----------------- +strongLoopBreaker, weakLoopBreaker :: OccInfo +strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo +weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo + +isWeakLoopBreaker :: OccInfo -> Bool +isWeakLoopBreaker (IAmALoopBreaker{}) = True +isWeakLoopBreaker _ = False + +isStrongLoopBreaker :: OccInfo -> Bool +isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True + -- Loop-breaker that breaks a non-rule cycle +isStrongLoopBreaker _ = False + +isDeadOcc :: OccInfo -> Bool +isDeadOcc IAmDead = True +isDeadOcc _ = False + +isOneOcc :: OccInfo -> Bool +isOneOcc (OneOcc {}) = True +isOneOcc _ = False + +zapFragileOcc :: OccInfo -> OccInfo +-- Keep only the most robust data: deadness, loop-breaker-hood +zapFragileOcc (OneOcc {}) = noOccInfo +zapFragileOcc occ = zapOccTailCallInfo occ + +instance Outputable OccInfo where + -- only used for debugging; never parsed. KSW 1999-07 + ppr (ManyOccs tails) = pprShortTailCallInfo tails + ppr IAmDead = text "Dead" + ppr (IAmALoopBreaker rule_only tails) + = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails + where + pp_ro | rule_only = char '!' + | otherwise = empty + ppr (OneOcc inside_lam one_branch int_cxt tail_info) + = text "Once" <> pp_lam inside_lam <> ppr one_branch <> pp_args int_cxt <> pp_tail + where + pp_lam IsInsideLam = char 'L' + pp_lam NotInsideLam = empty + pp_args IsInteresting = char '!' + pp_args NotInteresting = empty + pp_tail = pprShortTailCallInfo tail_info + +pprShortTailCallInfo :: TailCallInfo -> SDoc +pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) +pprShortTailCallInfo NoTailCallInfo = empty + +{- +Note [TailCallInfo] +~~~~~~~~~~~~~~~~~~~ +The occurrence analyser determines what can be made into a join point, but it +doesn't change the binder into a JoinId because then it would be inconsistent +with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to +change the IdDetails. + +The AlwaysTailCalled marker actually means slightly more than simply that the +function is always tail-called. See Note [Invariants on join points]. + +This info is quite fragile and should not be relied upon unless the occurrence +analyser has *just* run. Use 'Id.idJoinPointHood' for the permanent state of +the join-point-hood of a binder; a join id itself will not be marked +AlwaysTailCalled. + +Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that +being tail-called would mean that the variable could only appear once per branch +(thus getting a `OneOcc { }` occurrence info), but a join +point can also be invoked from other join points, not just from case branches: + + let j1 x = ... + j2 y = ... j1 z {- tail call -} ... + in case w of + A -> j1 v + B -> j2 u + C -> j2 q + +Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get +ManyOccs and j2 will get `OneOcc { occ_n_br = 2 }`. + +************************************************************************ +* * + Default method specification +* * +************************************************************************ + +The DefMethSpec enumeration just indicates what sort of default method +is used for a class. It is generated from source code, and present in +interface files; it is converted to Class.DefMethInfo before begin put in a +Class object. +-} + +-- | Default Method Specification +data DefMethSpec ty + = VanillaDM -- Default method given with polymorphic code + | GenericDM ty -- Default method given with code of this type + +instance Outputable (DefMethSpec ty) where + ppr VanillaDM = text "{- Has default method -}" + ppr (GenericDM {}) = text "{- Has generic default method -}" + +{- +************************************************************************ +* * +\subsection{Success flag} +* * +************************************************************************ +-} + +data SuccessFlag = Succeeded | Failed + +instance Semigroup SuccessFlag where + Failed <> _ = Failed + _ <> Failed = Failed + _ <> _ = Succeeded + + +instance Outputable SuccessFlag where + ppr Succeeded = text "Succeeded" + ppr Failed = text "Failed" + +successIf :: Bool -> SuccessFlag +successIf True = Succeeded +successIf False = Failed + +succeeded, failed :: SuccessFlag -> Bool +succeeded Succeeded = True +succeeded Failed = False + +failed Succeeded = False +failed Failed = True + +{- +************************************************************************ +* * +\subsection{Activation} +* * +************************************************************************ + +When a rule or inlining is active + +Note [Compiler phases] +~~~~~~~~~~~~~~~~~~~~~~ +The CompilerPhase says which phase the simplifier is running in: + +* InitialPhase: before all user-visible phases + +* Phase 2,1,0: user-visible phases; the phase number + controls rule ordering an inlining. + +* FinalPhase: used for all subsequent simplifier + runs. By delaying inlining of wrappers to FinalPhase we can + ensure that RULE have a good chance to fire. See + Note [Wrapper activation] in GHC.Core.Opt.WorkWrap + + NB: FinalPhase is run repeatedly, not just once. + + NB: users don't have access to InitialPhase or FinalPhase. + They write {-# INLINE[n] f #-}, meaning (Phase n) + +The phase sequencing is done by GHC.Opt.Simplify.Driver +-} + +-- | Phase Number +type PhaseNum = Int -- Compilation phase + -- Phases decrease towards zero + -- Zero is the last phase + +data CompilerPhase + = InitialPhase -- The first phase -- number = infinity! + | Phase PhaseNum -- User-specificable phases + | FinalPhase -- The last phase -- number = -infinity! + deriving Eq + +instance Outputable CompilerPhase where + ppr (Phase n) = int n + ppr InitialPhase = text "InitialPhase" + ppr FinalPhase = text "FinalPhase" + +-- See Note [Pragma source text] +data Activation + = AlwaysActive + | ActiveBefore SourceText PhaseNum -- Active only *strictly before* this phase + | ActiveAfter SourceText PhaseNum -- Active in this phase and later + | FinalActive -- Active in final phase only + | NeverActive + deriving( Eq, Data ) + -- Eq used in comparing rules in GHC.Hs.Decls + +beginPhase :: Activation -> CompilerPhase +-- First phase in which the Activation is active +-- or FinalPhase if it is never active +beginPhase AlwaysActive = InitialPhase +beginPhase (ActiveBefore {}) = InitialPhase +beginPhase (ActiveAfter _ n) = Phase n +beginPhase FinalActive = FinalPhase +beginPhase NeverActive = FinalPhase + +activeAfter :: CompilerPhase -> Activation +-- (activeAfter p) makes an Activation that is active in phase p and after +-- Invariant: beginPhase (activeAfter p) = p +activeAfter InitialPhase = AlwaysActive +activeAfter (Phase n) = ActiveAfter NoSourceText n +activeAfter FinalPhase = FinalActive + +nextPhase :: CompilerPhase -> CompilerPhase +-- Tells you the next phase after this one +-- Currently we have just phases [2,1,0,FinalPhase,FinalPhase,...] +-- Where FinalPhase means GHC's internal simplification steps +-- after all rules have run +nextPhase InitialPhase = Phase 2 +nextPhase (Phase 0) = FinalPhase +nextPhase (Phase n) = Phase (n-1) +nextPhase FinalPhase = FinalPhase + +laterPhase :: CompilerPhase -> CompilerPhase -> CompilerPhase +-- Returns the later of two phases +laterPhase (Phase n1) (Phase n2) = Phase (n1 `min` n2) +laterPhase InitialPhase p2 = p2 +laterPhase FinalPhase _ = FinalPhase +laterPhase p1 InitialPhase = p1 +laterPhase _ FinalPhase = FinalPhase + +activateAfterInitial :: Activation +-- Active in the first phase after the initial phase +activateAfterInitial = activeAfter (nextPhase InitialPhase) + +activateDuringFinal :: Activation +-- Active in the final simplification phase (which is repeated) +activateDuringFinal = FinalActive + +isActive :: CompilerPhase -> Activation -> Bool +isActive InitialPhase act = activeInInitialPhase act +isActive (Phase p) act = activeInPhase p act +isActive FinalPhase act = activeInFinalPhase act + +activeInInitialPhase :: Activation -> Bool +activeInInitialPhase AlwaysActive = True +activeInInitialPhase (ActiveBefore {}) = True +activeInInitialPhase _ = False + +activeInPhase :: PhaseNum -> Activation -> Bool +activeInPhase _ AlwaysActive = True +activeInPhase _ NeverActive = False +activeInPhase _ FinalActive = False +activeInPhase p (ActiveAfter _ n) = p <= n +activeInPhase p (ActiveBefore _ n) = p > n + +activeInFinalPhase :: Activation -> Bool +activeInFinalPhase AlwaysActive = True +activeInFinalPhase FinalActive = True +activeInFinalPhase (ActiveAfter {}) = True +activeInFinalPhase _ = False + +isNeverActive, isAlwaysActive :: Activation -> Bool +isNeverActive NeverActive = True +isNeverActive _ = False + +isAlwaysActive AlwaysActive = True +isAlwaysActive _ = False + +competesWith :: Activation -> Activation -> Bool +-- See Note [Competing activations] +competesWith AlwaysActive _ = True + +competesWith NeverActive _ = False +competesWith _ NeverActive = False + +competesWith FinalActive FinalActive = True +competesWith FinalActive _ = False + +competesWith (ActiveBefore {}) AlwaysActive = True +competesWith (ActiveBefore {}) FinalActive = False +competesWith (ActiveBefore {}) (ActiveBefore {}) = True +competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b + +competesWith (ActiveAfter {}) AlwaysActive = False +competesWith (ActiveAfter {}) FinalActive = True +competesWith (ActiveAfter {}) (ActiveBefore {}) = False +competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b + +{- Note [Competing activations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes a RULE and an inlining may compete, or two RULES. +See Note [Rules and inlining/other rules] in GHC.HsToCore. + +We say that act1 "competes with" act2 iff + act1 is active in the phase when act2 *becomes* active +NB: remember that phases count *down*: 2, 1, 0! + +It's too conservative to ensure that the two are never simultaneously +active. For example, a rule might be always active, and an inlining +might switch on in phase 2. We could switch off the rule, but it does +no harm. +-} + + +{- ********************************************************************* +* * + InlinePragma, InlineSpec, RuleMatchInfo +* * +********************************************************************* -} + + +data InlinePragma -- Note [InlinePragma] + = InlinePragma + { inl_src :: SourceText -- See Note [Pragma source text] + , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] + + , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n + -- explicit (non-type, non-dictionary) args + -- That is, inl_sat describes the number of *source-code* + -- arguments the thing must be applied to. We add on the + -- number of implicit, dictionary arguments when making + -- the Unfolding, and don't look at inl_sat further + + , inl_act :: Activation -- Says during which phases inlining is allowed + -- See Note [inl_inline and inl_act] + + , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? + } deriving( Eq, Data ) + +-- | Rule Match Information +data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] + | FunLike + deriving( Eq, Data, Show ) + -- Show needed for GHC.Parser.Lexer + +-- | Inline Specification +data InlineSpec -- What the user's INLINE pragma looked like + = Inline SourceText -- User wrote INLINE + | Inlinable SourceText -- User wrote INLINABLE + | NoInline SourceText -- User wrote NOINLINE + | Opaque SourceText -- User wrote OPAQUE + -- Each of the above keywords is accompanied with + -- a string of type SourceText written by the user + | NoUserInlinePrag -- User did not write any of INLINE/INLINABLE/NOINLINE + -- e.g. in `defaultInlinePragma` or when created by CSE + deriving( Eq, Data, Show ) + -- Show needed for GHC.Parser.Lexer + +{- Note [InlinePragma] +~~~~~~~~~~~~~~~~~~~~~~ +This data type mirrors what you can write in an INLINE or NOINLINE pragma in +the source program. + +If you write nothing at all, you get defaultInlinePragma: + inl_inline = NoUserInlinePrag + inl_act = AlwaysActive + inl_rule = FunLike + +It's not possible to get that combination by *writing* something, so +if an Id has defaultInlinePragma it means the user didn't specify anything. + +If inl_inline = Inline or Inlineable, then the Id should have a stable unfolding. + +If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair + +Note [inl_inline and inl_act] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* inl_inline says what the user wrote: did they say INLINE, NOINLINE, + INLINABLE, OPAQUE, or nothing at all + +* inl_act says in what phases the unfolding is active or inactive + E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1 + If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1 + If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1 + So note that inl_act does not say what pragma you wrote: it just + expresses its consequences + +* inl_act just says when the unfolding is active; it doesn't say what + to inline. If you say INLINE f, then f's inl_act will be AlwaysActive, + but in addition f will get a "stable unfolding" with UnfoldingGuidance + that tells the inliner to be pretty eager about it. + +Note [CONLIKE pragma] +~~~~~~~~~~~~~~~~~~~~~ +The ConLike constructor of a RuleMatchInfo is aimed at the following. +Consider first + {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} + g b bs = let x = b:bs in ..x...x...(r x)... +Now, the rule applies to the (r x) term, because GHC "looks through" +the definition of 'x' to see that it is (b:bs). + +Now consider + {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} + g v = let x = f v in ..x...x...(r x)... +Normally the (r x) would *not* match the rule, because GHC would be +scared about duplicating the redex (f v), so it does not "look +through" the bindings. + +However the CONLIKE modifier says to treat 'f' like a constructor in +this situation, and "look through" the unfolding for x. So (r x) +fires, yielding (f (v+1)). + +This is all controlled with a user-visible pragma: + {-# NOINLINE CONLIKE [1] f #-} + +The main effects of CONLIKE are: + + - The occurrence analyser (OccAnal) and simplifier (Simplify) treat + CONLIKE thing like constructors, by ANF-ing them + + - New function GHC.Core.Utils.exprIsExpandable is like exprIsCheap, but + additionally spots applications of CONLIKE functions + + - A CoreUnfolding has a field that caches exprIsExpandable + + - The rule matcher consults this field. See + Note [Expanding variables] in GHC.Core.Rules. + +Note [OPAQUE pragma] +~~~~~~~~~~~~~~~~~~~~ +Suppose a function `f` is marked {-# OPAQUE f #-}. Then every call of `f` +should remain a call of `f` throughout optimisation; it should not be turned +into a call of a name-mangled variant of `f` (e.g by worker/wrapper). + +The motivation for the OPAQUE pragma is discussed in GHC proposal 0415: +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0415-opaque-pragma.rst +Basically it boils down to the desire of GHC API users and GHC RULE writers for +calls to certain binders to be left completely untouched by GHCs optimisations. + +What this entails at the time of writing, is that for every binder annotated +with the OPAQUE pragma we: + +* Do not do worker/wrapper via cast W/W: + See the guard in GHC.Core.Opt.Simplify.tryCastWorkerWrapper + +* Do not any worker/wrapper after demand/CPR analysis. To that end add a guard + in GHC.Core.Opt.WorkWrap.tryWW to disable worker/wrapper + +* It is important that the demand signature and CPR signature do not lie, else + clients of the function will believe that it has the CPR property etc. But it + won't, because we've disabled worker/wrapper. To avoid the signatures lying: + * Strip boxity information from the demand signature + in GHC.Core.Opt.DmdAnal.finaliseArgBoxities + See Note [The OPAQUE pragma and avoiding the reboxing of arguments] + * Strip CPR information from the CPR signature + in GHC.Core.Opt.CprAnal.cprAnalBind + See Note [The OPAQUE pragma and avoiding the reboxing of results] + +* Do create specialised versions of the function in + * Specialise: see GHC.Core.Opt.Specialise.specCalls + * SpecConstr: see GHC.Core.Opt.SpecConstr.specialise + Both are accomplished easily: these passes already skip NOINLINE + functions with NeverActive activation, and an OPAQUE function is + also NeverActive. + +At the moment of writing, the major difference between the NOINLINE pragma and +the OPAQUE pragma is that binders annoted with the NOINLINE pragma _are_ W/W +transformed (see also Note [Worker/wrapper for NOINLINE functions]) where +binders annoted with the OPAQUE pragma are _not_ W/W transformed. + +Future "name-mangling" optimisations should respect the OPAQUE pragma and +update the list of moving parts referenced in this note. + +-} + +isConLike :: RuleMatchInfo -> Bool +isConLike ConLike = True +isConLike _ = False + +isFunLike :: RuleMatchInfo -> Bool +isFunLike FunLike = True +isFunLike _ = False + +noUserInlineSpec :: InlineSpec -> Bool +noUserInlineSpec NoUserInlinePrag = True +noUserInlineSpec _ = False + +defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma + :: InlinePragma +defaultInlinePragma = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" + , inl_act = AlwaysActive + , inl_rule = FunLike + , inl_inline = NoUserInlinePrag + , inl_sat = Nothing } + +alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline (inlinePragmaSource defaultInlinePragma) } +neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } + +alwaysInlineConLikePragma :: InlinePragma +alwaysInlineConLikePragma = alwaysInlinePragma { inl_rule = ConLike } + +inlinePragmaSpec :: InlinePragma -> InlineSpec +inlinePragmaSpec = inl_inline + +inlinePragmaSource :: InlinePragma -> SourceText +inlinePragmaSource prag = inlineSpecSource (inl_inline prag) + +inlineSpecSource :: InlineSpec -> SourceText +inlineSpecSource spec = case spec of + Inline x -> x + Inlinable y -> y + NoInline z -> z + Opaque q -> q + NoUserInlinePrag -> NoSourceText + +-- A DFun has an always-active inline activation so that +-- exprIsConApp_maybe can "see" its unfolding +-- (However, its actual Unfolding is a DFunUnfolding, which is +-- never inlined other than via exprIsConApp_maybe.) +dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive + , inl_rule = ConLike } + +isDefaultInlinePragma :: InlinePragma -> Bool +isDefaultInlinePragma (InlinePragma { inl_act = activation + , inl_rule = match_info + , inl_inline = inline }) + = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info + +isInlinePragma :: InlinePragma -> Bool +isInlinePragma prag = case inl_inline prag of + Inline _ -> True + _ -> False + +isInlinablePragma :: InlinePragma -> Bool +isInlinablePragma prag = case inl_inline prag of + Inlinable _ -> True + _ -> False + +isNoInlinePragma :: InlinePragma -> Bool +isNoInlinePragma prag = case inl_inline prag of + NoInline _ -> True + _ -> False + +isAnyInlinePragma :: InlinePragma -> Bool +-- INLINE or INLINABLE +isAnyInlinePragma prag = case inl_inline prag of + Inline _ -> True + Inlinable _ -> True + _ -> False + +isOpaquePragma :: InlinePragma -> Bool +isOpaquePragma prag = case inl_inline prag of + Opaque _ -> True + _ -> False + +inlinePragmaSat :: InlinePragma -> Maybe Arity +inlinePragmaSat = inl_sat + +inlinePragmaActivation :: InlinePragma -> Activation +inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation + +inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo +inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info + +setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma +setInlinePragmaActivation prag activation = prag { inl_act = activation } + +setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma +setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } + +instance Outputable Activation where + ppr AlwaysActive = empty + ppr NeverActive = brackets (text "~") + ppr (ActiveBefore _ n) = brackets (char '~' <> int n) + ppr (ActiveAfter _ n) = brackets (int n) + ppr FinalActive = text "[final]" + +instance Binary Activation where + put_ bh NeverActive = + putByte bh 0 + put_ bh FinalActive = + putByte bh 1 + put_ bh AlwaysActive = + putByte bh 2 + put_ bh (ActiveBefore src aa) = do + putByte bh 3 + put_ bh src + put_ bh aa + put_ bh (ActiveAfter src ab) = do + putByte bh 4 + put_ bh src + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> return NeverActive + 1 -> return FinalActive + 2 -> return AlwaysActive + 3 -> do src <- get bh + aa <- get bh + return (ActiveBefore src aa) + _ -> do src <- get bh + ab <- get bh + return (ActiveAfter src ab) + +instance NFData Activation where + rnf = \case + AlwaysActive -> () + NeverActive -> () + ActiveBefore src aa -> rnf src `seq` rnf aa + ActiveAfter src ab -> rnf src `seq` rnf ab + FinalActive -> () + +instance Outputable RuleMatchInfo where + ppr ConLike = text "CONLIKE" + ppr FunLike = text "FUNLIKE" + +instance Binary RuleMatchInfo where + put_ bh FunLike = putByte bh 0 + put_ bh ConLike = putByte bh 1 + get bh = do + h <- getByte bh + if h == 1 then return ConLike + else return FunLike + +instance NFData RuleMatchInfo where + rnf = \case + ConLike -> () + FunLike -> () + +instance Outputable InlineSpec where + ppr (Inline src) = text "INLINE" <+> pprWithSourceText src empty + ppr (NoInline src) = text "NOINLINE" <+> pprWithSourceText src empty + ppr (Inlinable src) = text "INLINABLE" <+> pprWithSourceText src empty + ppr (Opaque src) = text "OPAQUE" <+> pprWithSourceText src empty + ppr NoUserInlinePrag = empty + +instance Binary InlineSpec where + put_ bh NoUserInlinePrag = putByte bh 0 + put_ bh (Inline s) = do putByte bh 1 + put_ bh s + put_ bh (Inlinable s) = do putByte bh 2 + put_ bh s + put_ bh (NoInline s) = do putByte bh 3 + put_ bh s + put_ bh (Opaque s) = do putByte bh 4 + put_ bh s + + get bh = do h <- getByte bh + case h of + 0 -> return NoUserInlinePrag + 1 -> do + s <- get bh + return (Inline s) + 2 -> do + s <- get bh + return (Inlinable s) + 3 -> do + s <- get bh + return (NoInline s) + _ -> do + s <- get bh + return (Opaque s) + +instance NFData InlineSpec where + rnf = \case + Inline s -> rnf s + NoInline s -> rnf s + Inlinable s -> rnf s + Opaque s -> rnf s + NoUserInlinePrag -> () + +instance Outputable InlinePragma where + ppr = pprInline + +instance Binary InlinePragma where + put_ bh (InlinePragma s a b c d) = do + put_ bh s + put_ bh a + put_ bh b + put_ bh c + put_ bh d + + get bh = do + s <- get bh + a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (InlinePragma s a b c d) + +instance NFData InlinePragma where + rnf (InlinePragma s a b c d) = rnf s `seq` rnf a `seq` rnf b `seq` rnf c `seq` rnf d + +-- | Outputs string for pragma name for any of INLINE/INLINABLE/NOINLINE. This +-- differs from the Outputable instance for the InlineSpec type where the pragma +-- name string as well as the accompanying SourceText (if any) is printed. +inlinePragmaName :: InlineSpec -> SDoc +inlinePragmaName (Inline _) = text "INLINE" +inlinePragmaName (Inlinable _) = text "INLINABLE" +inlinePragmaName (NoInline _) = text "NOINLINE" +inlinePragmaName (Opaque _) = text "OPAQUE" +inlinePragmaName NoUserInlinePrag = empty + +-- | Pretty-print without displaying the user-specified 'InlineSpec'. +pprInline :: InlinePragma -> SDoc +pprInline = pprInline' True + +-- | Pretty-print including the user-specified 'InlineSpec'. +pprInlineDebug :: InlinePragma -> SDoc +pprInlineDebug = pprInline' False + +pprInline' :: Bool -- True <=> do not display the inl_inline field + -> InlinePragma + -> SDoc +pprInline' emptyInline (InlinePragma + { inl_inline = inline, + inl_act = activation, + inl_rule = info, + inl_sat = mb_arity }) + = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info + where + pp_inl x = if emptyInline then empty else inlinePragmaName x + + pp_act Inline {} AlwaysActive = empty + pp_act NoInline {} NeverActive = empty + pp_act Opaque {} NeverActive = empty + pp_act _ act = ppr act + + pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) + | otherwise = empty + pp_info | isFunLike info = empty + | otherwise = ppr info + + +{- ********************************************************************* +* * + UnfoldingSource +* * +********************************************************************* -} + +data UnfoldingSource + = -- See also Note [Historical note: unfoldings for wrappers] + VanillaSrc -- The current rhs of the function + -- Replace uf_tmpl each time around + + -- See Note [Stable unfoldings] in GHC.Core + | StableUserSrc -- From a user-specified INLINE or INLINABLE pragma + | StableSystemSrc -- From a wrapper, or system-generated unfolding + + | CompulsorySrc -- Something that *has* no binding, so you *must* inline it + -- Only a few primop-like things have this property + -- (see "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding). + -- Inline absolutely always, however boring the context. + +isStableUserSource :: UnfoldingSource -> Bool +isStableUserSource StableUserSrc = True +isStableUserSource _ = False + +isStableSystemSource :: UnfoldingSource -> Bool +isStableSystemSource StableSystemSrc = True +isStableSystemSource _ = False + +isCompulsorySource :: UnfoldingSource -> Bool +isCompulsorySource CompulsorySrc = True +isCompulsorySource _ = False + +isStableSource :: UnfoldingSource -> Bool +isStableSource CompulsorySrc = True +isStableSource StableSystemSrc = True +isStableSource StableUserSrc = True +isStableSource VanillaSrc = False + +instance Binary UnfoldingSource where + put_ bh CompulsorySrc = putByte bh 0 + put_ bh StableUserSrc = putByte bh 1 + put_ bh StableSystemSrc = putByte bh 2 + put_ bh VanillaSrc = putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> return CompulsorySrc + 1 -> return StableUserSrc + 2 -> return StableSystemSrc + _ -> return VanillaSrc + +instance NFData UnfoldingSource where + rnf = \case + CompulsorySrc -> () + StableUserSrc -> () + StableSystemSrc -> () + VanillaSrc -> () + +instance Outputable UnfoldingSource where + ppr CompulsorySrc = text "Compulsory" + ppr StableUserSrc = text "StableUser" + ppr StableSystemSrc = text "StableSystem" + ppr VanillaSrc = text "" + +{- +************************************************************************ +* * + IntWithInf +* * +************************************************************************ + +Represents an integer or positive infinity + +-} + +-- | An integer or infinity +data IntWithInf = Int {-# UNPACK #-} !Int + | Infinity + deriving Eq + +-- | A representation of infinity +infinity :: IntWithInf +infinity = Infinity + +instance Ord IntWithInf where + compare Infinity Infinity = EQ + compare (Int _) Infinity = LT + compare Infinity (Int _) = GT + compare (Int a) (Int b) = a `compare` b + +instance Outputable IntWithInf where + ppr Infinity = char '∞' + ppr (Int n) = int n + +instance Num IntWithInf where + (+) = plusWithInf + (*) = mulWithInf + + abs Infinity = Infinity + abs (Int n) = Int (abs n) + + signum Infinity = Int 1 + signum (Int n) = Int (signum n) + + fromInteger = Int . fromInteger + + (-) = panic "subtracting IntWithInfs" + +intGtLimit :: Int -> IntWithInf -> Bool +intGtLimit _ Infinity = False +intGtLimit n (Int m) = n > m + +-- | Add two 'IntWithInf's +plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf +plusWithInf Infinity _ = Infinity +plusWithInf _ Infinity = Infinity +plusWithInf (Int a) (Int b) = Int (a + b) + +-- | Multiply two 'IntWithInf's +mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf +mulWithInf Infinity _ = Infinity +mulWithInf _ Infinity = Infinity +mulWithInf (Int a) (Int b) = Int (a * b) + +-- | Subtract an 'Int' from an 'IntWithInf' +subWithInf :: IntWithInf -> Int -> IntWithInf +subWithInf Infinity _ = Infinity +subWithInf (Int a) b = Int (a - b) + +-- | Turn a positive number into an 'IntWithInf', where 0 represents infinity +treatZeroAsInf :: Int -> IntWithInf +treatZeroAsInf 0 = Infinity +treatZeroAsInf n = Int n + +-- | Inject any integer into an 'IntWithInf' +mkIntWithInf :: Int -> IntWithInf +mkIntWithInf = Int + +{- ********************************************************************* +* * + Types vs Kinds +* * +********************************************************************* -} + +-- | Flag to see whether we're type-checking terms or kind-checking types +data TypeOrKind = TypeLevel | KindLevel + deriving Eq + +instance Outputable TypeOrKind where + ppr TypeLevel = text "TypeLevel" + ppr KindLevel = text "KindLevel" + +isTypeLevel :: TypeOrKind -> Bool +isTypeLevel TypeLevel = True +isTypeLevel KindLevel = False + +isKindLevel :: TypeOrKind -> Bool +isKindLevel TypeLevel = False +isKindLevel KindLevel = True + +{- ********************************************************************* +* * + Levity and TypeOrConstraint +* * +********************************************************************* -} + +{- The types `Levity` and `TypeOrConstraint` are internal to GHC. + They have the same shape as the eponymous types in the library + ghc-prim:GHC.Types + but they aren't the same types -- after all, they are defined in a + different module. +-} + +data Levity + = Lifted + | Unlifted + deriving (Data,Eq,Ord,Show) + +instance Outputable Levity where + ppr Lifted = text "Lifted" + ppr Unlifted = text "Unlifted" + +instance Binary Levity where + put_ bh = \case + Lifted -> putByte bh 0 + Unlifted -> putByte bh 1 + get bh = getByte bh >>= \case + 0 -> pure Lifted + _ -> pure Unlifted + +mightBeLifted :: Maybe Levity -> Bool +mightBeLifted (Just Unlifted) = False +mightBeLifted _ = True + +mightBeUnlifted :: Maybe Levity -> Bool +mightBeUnlifted (Just Lifted) = False +mightBeUnlifted _ = True + +data TypeOrConstraint + = TypeLike | ConstraintLike + deriving( Eq, Ord, Data ) + +instance Binary TypeOrConstraint where + put_ bh = \case + TypeLike -> putByte bh 0 + ConstraintLike -> putByte bh 1 + get bh = getByte bh >>= \case + 0 -> pure TypeLike + 1 -> pure ConstraintLike + _ -> panic "TypeOrConstraint.get: invalid value" + +instance NFData TypeOrConstraint where + rnf = \case + TypeLike -> () + ConstraintLike -> () + +{- ********************************************************************* +* * + TyConFlavour +* * +********************************************************************* -} + +-- | Paints a picture of what a 'TyCon' represents, in broad strokes. +-- This is used towards more informative error messages. +data TyConFlavour tc + = ClassFlavour + | TupleFlavour Boxity + | SumFlavour + | DataTypeFlavour + | NewtypeFlavour + | AbstractTypeFlavour + | OpenFamilyFlavour TypeOrData (Maybe tc) -- Just tc <=> (tc == associated class) + | ClosedTypeFamilyFlavour + | TypeSynonymFlavour + | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. + | PromotedDataConFlavour + deriving (Eq, Data, Functor) + +instance Outputable (TyConFlavour tc) where + ppr = text . go + where + go ClassFlavour = "class" + go (TupleFlavour boxed) | isBoxed boxed = "tuple" + | otherwise = "unboxed tuple" + go SumFlavour = "unboxed sum" + go DataTypeFlavour = "data type" + go NewtypeFlavour = "newtype" + go AbstractTypeFlavour = "abstract type" + go (OpenFamilyFlavour type_or_data mb_par) + = assoc ++ t_or_d ++ " family" + where + assoc = if isJust mb_par then "associated " else "" + t_or_d = case type_or_data of + IAmType -> "type" + IAmData new_or_data -> + case new_or_data of + DataType -> "data" + NewType -> "newtype" + go ClosedTypeFamilyFlavour = "type family" + go TypeSynonymFlavour = "type synonym" + go BuiltInTypeFlavour = "built-in type" + go PromotedDataConFlavour = "promoted data constructor" + + +-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour +tyConFlavourAssoc_maybe :: TyConFlavour tc -> Maybe tc +tyConFlavourAssoc_maybe (OpenFamilyFlavour _ mb_parent) = mb_parent +tyConFlavourAssoc_maybe _ = Nothing + +-- | Whether something is a type or a data declaration, +-- e.g. a type family or a data family. +data TypeOrData + = IAmData !NewOrData + | IAmType + deriving (Eq, Data) + +-- | When we only care whether a data-type declaration is `data` or `newtype`, +-- but not what constructors it has. +data NewOrData + = NewType -- ^ @newtype Blah ...@ + | DataType -- ^ @data Blah ...@ + deriving ( Eq, Data ) -- Needed because Demand derives Eq + +instance Outputable TypeOrData where + ppr (IAmData newOrData) = ppr newOrData + ppr IAmType = text "type" + +instance Outputable NewOrData where + ppr = \case + NewType -> text "newtype" + DataType -> text "data" + +{- ********************************************************************* +* * + Defaulting options +* * +********************************************************************* -} + +{- Note [Type variable defaulting options] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is an overview of the current type variable defaulting mechanisms, +in the order in which they happen. + +GHC.Tc.Utils.TcMType.defaultTyVar + + This is a built-in defaulting mechanism for the following type variables: + + (1) kind variables with -XNoPolyKinds, + (2) type variables of kind 'RuntimeRep' default to 'LiftedRep', + of kind 'Levity' to 'Lifted', and of kind 'Multiplicity' to 'Many'. + + It is used in many situations: + + - inferring a type (e.g. a declaration with no type signature or a + partial type signature), in 'GHC.Tc.Solver.simplifyInfer', + - simplifying top-level constraints in 'GHC.Tc.Solver.simplifyTop', + - kind checking a CUSK in 'GHC.Tc.Gen.kcCheckDeclHeader_cusk', + - 'GHC.Tc.TyCl.generaliseTcTyCon', + - type checking type family and data family instances, + in 'GHC.Tc.TyCl.tcTyFamInstEqnGuts' and 'GHC.Tc.TyCl.Instance.tcDataFamInstHeader' + respectively, + - type-checking rules in 'GHC.Tc.Gen.tcRule', + - kind generalisation in 'GHC.Tc.Gen.HsType.kindGeneralizeSome' + and 'GHC.Tc.Gen.HsType.kindGeneralizeAll'. + + Different situations call for a different defaulting strategy, + so 'defaultTyVar' takes a strategy parameter which determines which + type variables to default. + Currently, this strategy is set as follows: + + - Kind variables: + - with -XNoPolyKinds, these must be defaulted. This includes kind variables + of kind 'RuntimeRep', 'Levity' and 'Multiplicity'. + Test case: T20584. + - with -XPolyKinds, behave as if they were type variables (see below). + - Type variables of kind 'RuntimeRep', 'Levity' or 'Multiplicity' + - in type and data families instances, these are not defaulted. + Test case: T17536. + - otherwise: default variables of these three kinds. This ensures + that in a program such as + + foo :: forall a. a -> a + foo x = x + + we continue to infer `a :: Type`. + + Note that the strategy is set in two steps: callers of 'defaultTyVars' only + specify whether to default type variables of "non-standard" kinds + (that is, of kinds 'RuntimeRep'/'Levity'/'Multiplicity'). Then 'defaultTyVars' + determines which variables are type variables and which are kind variables, + and if the user has asked for -XNoPolyKinds we default the kind variables. + +GHC.Tc.Solver.defaultTyVarTcS + + This is a built-in defaulting mechanism that happens after + the constraint solver has run, in 'GHC.Tc.Solver.simplifyTopWanteds'. + + It only defaults type (and kind) variables of kind 'RuntimeRep', + 'Levity', 'Multiplicity'. + + It is not configurable, neither by options nor by the user. + +GHC.Tc.Solver.applyDefaultingRules + + This is typeclass defaulting, and includes defaulting plugins. + It happens right after 'defaultTyVarTcS' in 'GHC.Tc.Solver.simplifyTopWanteds'. + It is user configurable, using default declarations (/plugins). + +GHC.Iface.Type.defaultIfaceTyVarsOfKind + + This is a built-in defaulting mechanism that only applies when pretty-printing. + It defaults 'RuntimeRep'/'Levity' variables unless -fprint-explicit-runtime-reps is enabled, + and 'Multiplicity' variables unless -XLinearTypes is enabled. + +-} + +-- | Specify whether to default type variables of kind 'RuntimeRep'/'Levity'/'Multiplicity'. +data NonStandardDefaultingStrategy + -- | Default type variables of the given kinds: + -- + -- - default 'RuntimeRep' variables to 'LiftedRep' + -- - default 'Levity' variables to 'Lifted' + -- - default 'Multiplicity' variables to 'Many' + = DefaultNonStandardTyVars + -- | Try not to default type variables of the kinds 'RuntimeRep'/'Levity'/'Multiplicity'. + -- + -- Note that these might get defaulted anyway, if they are kind variables + -- and `-XNoPolyKinds` is enabled. + | TryNotToDefaultNonStandardTyVars + +-- | Specify whether to default kind variables, and type variables +-- of kind 'RuntimeRep'/'Levity'/'Multiplicity'. +data DefaultingStrategy + -- | Default kind variables: + -- + -- - default kind variables of kind 'Type' to 'Type', + -- - default 'RuntimeRep'/'Levity'/'Multiplicity' kind variables + -- to 'LiftedRep'/'Lifted'/'Many', respectively. + -- + -- When this strategy is used, it means that we have determined that + -- the variables we are considering defaulting are all kind variables. + -- + -- Usually, we pass this option when -XNoPolyKinds is enabled. + = DefaultKindVars + -- | Default (or don't default) non-standard variables, of kinds + -- 'RuntimeRep', 'Levity' and 'Multiplicity'. + | NonStandardDefaulting NonStandardDefaultingStrategy + +defaultNonStandardTyVars :: DefaultingStrategy -> Bool +defaultNonStandardTyVars DefaultKindVars = True +defaultNonStandardTyVars (NonStandardDefaulting DefaultNonStandardTyVars) = True +defaultNonStandardTyVars (NonStandardDefaulting TryNotToDefaultNonStandardTyVars) = False + +instance Outputable NonStandardDefaultingStrategy where + ppr DefaultNonStandardTyVars = text "DefaultOnlyNonStandardTyVars" + ppr TryNotToDefaultNonStandardTyVars = text "TryNotToDefaultNonStandardTyVars" + +instance Outputable DefaultingStrategy where + ppr DefaultKindVars = text "DefaultKindVars" + ppr (NonStandardDefaulting ns) = text "NonStandardDefaulting" <+> ppr ns + +-- | ImportLevel + +data ImportLevel = NormalLevel | SpliceLevel | QuoteLevel deriving (Eq, Ord, Data, Show, Enum, Bounded) + +instance Outputable ImportLevel where + ppr NormalLevel = text "normal" + ppr SpliceLevel = text "splice" + ppr QuoteLevel = text "quote" + +deriving via (EnumBinary ImportLevel) instance Binary ImportLevel + +allImportLevels :: [ImportLevel] +allImportLevels = [minBound..maxBound] + +convImportLevel :: ImportDeclLevelStyle -> ImportLevel +convImportLevel (LevelStylePre level) = convImportLevelSpec level +convImportLevel (LevelStylePost level) = convImportLevelSpec level +convImportLevel NotLevelled = NormalLevel + +convImportLevelSpec :: ImportDeclLevel -> ImportLevel +convImportLevelSpec ImportDeclQuote = QuoteLevel +convImportLevelSpec ImportDeclSplice = SpliceLevel diff --git a/GHC/Types/CompleteMatch.hs b/GHC/Types/CompleteMatch.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/CompleteMatch.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | COMPLETE signature +module GHC.Types.CompleteMatch + ( CompleteMatchX(..) + , CompleteMatch, CompleteMatches + , DsCompleteMatch, DsCompleteMatches + , mkCompleteMatch, vanillaCompleteMatch + , completeMatchAppliesAtType + ) where + +import GHC.Prelude +import GHC.Core.TyCo.Rep +import GHC.Types.Unique +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.Type ( splitTyConApp_maybe ) +import GHC.Types.Name ( Name ) +import GHC.Types.Unique.DSet +import GHC.Utils.Outputable + +type CompleteMatch = CompleteMatchX Name +type DsCompleteMatch = CompleteMatchX ConLike + +type CompleteMatches = [CompleteMatch] +type DsCompleteMatches = [DsCompleteMatch] + +-- | A list of conlikes which represents a complete pattern match. +-- These arise from @COMPLETE@ signatures. +-- See also Note [Implementation of COMPLETE pragmas]. +data CompleteMatchX con = CompleteMatch + { cmConLikes :: UniqDSet con -- ^ The set of constructor names + , cmResultTyCon :: Maybe Name -- ^ The optional, concrete result TyCon name the set applies to + } + deriving Eq + +mkCompleteMatch :: UniqDSet con -> Maybe Name -> CompleteMatchX con +mkCompleteMatch nms mb_tc = CompleteMatch { cmConLikes = nms, cmResultTyCon = mb_tc } + +vanillaCompleteMatch :: UniqDSet con -> CompleteMatchX con +vanillaCompleteMatch nms = mkCompleteMatch nms Nothing + +instance Outputable con => Outputable (CompleteMatchX con) where + ppr (CompleteMatch cls mty) = case mty of + Nothing -> ppr cls + Just ty -> ppr cls <> text "@" <> parens (ppr ty) + +-- | Does this 'COMPLETE' set apply at this type? +-- +-- See the part about "result type constructors" in +-- Note [Implementation of COMPLETE pragmas] in GHC.HsToCore.Pmc.Solver. +completeMatchAppliesAtType :: Type -> CompleteMatchX con -> Bool +completeMatchAppliesAtType ty cm = all @Maybe ty_matches (getUnique <$> cmResultTyCon cm) + where + ty_matches :: Unique -> Bool + ty_matches sig_tc + | Just (tc, _arg_tys) <- splitTyConApp_maybe ty + , tc `hasKey` sig_tc + || sig_tc `is_family_ty_con_of` tc + -- #24326: sig_tc might be the data Family TyCon of the representation + -- TyCon tc -- this CompleteMatch still applies + = True + | otherwise + = False + fam_tc `is_family_ty_con_of` repr_tc = + case fst <$> tyConFamInst_maybe repr_tc of + Just tc -> tc `hasKey` fam_tc + Nothing -> False diff --git a/GHC/Types/CostCentre.hs b/GHC/Types/CostCentre.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/CostCentre.hs @@ -0,0 +1,422 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module GHC.Types.CostCentre ( + -- All abstract except to friend: ParseIface.y + CostCentre(..), CcName, CCFlavour, + mkCafFlavour, mkExprCCFlavour, mkDeclCCFlavour, mkHpcCCFlavour, + mkLateCCFlavour, mkCallerCCFlavour, + getAllCAFsCC, + + pprCostCentre, + CostCentreStack, + pprCostCentreStack, + CollectedCCs, emptyCollectedCCs, collectCC, + currentCCS, dontCareCCS, + isCurrentCCS, + maybeSingletonCCS, + + mkUserCC, mkAutoCC, mkAllCafsCC, + mkSingletonCCS, + isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, + + pprCostCentreCore, + costCentreUserName, costCentreUserNameFS, + costCentreSrcSpan, + + cmpCostCentre -- used for removing dups in a list + ) where + +import GHC.Prelude + +import GHC.Utils.Binary +import GHC.Types.Var +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Types.Unique +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Data.FastString +import GHC.Types.CostCentre.State +import Control.DeepSeq + +import Data.Data + +----------------------------------------------------------------------------- +-- Cost Centres + +-- | A Cost Centre is a single @{-# SCC #-}@ annotation. + +data CostCentre + = NormalCC { + cc_flavour :: CCFlavour, + -- ^ Two cost centres may have the same name and + -- module but different SrcSpans, so we need a way to + -- distinguish them easily and give them different + -- object-code labels. So every CostCentre has an + -- associated flavour that indicates how it was + -- generated, and flavours that allow multiple instances + -- of the same name and module have a deterministic 0-based + -- index. + cc_name :: CcName, -- ^ Name of the cost centre itself + cc_mod :: Module, -- ^ Name of module defining this CC. + cc_loc :: SrcSpan + } + + | AllCafsCC { + cc_mod :: Module, -- Name of module defining this CC. + cc_loc :: SrcSpan + } + deriving Data + +type CcName = FastString + +data IndexedCCFlavour + = ExprCC -- ^ Explicitly annotated expression + | DeclCC -- ^ Explicitly annotated declaration + | HpcCC -- ^ Generated by HPC for coverage + | LateCC -- ^ Annotated by the one of the prof-last* passes. + | CallerCC -- ^ Annotated by the one of the prof-last* passes. + deriving (Eq,Ord,Data,Enum) +-- | The flavour of a cost centre. +-- +-- Index fields represent 0-based indices giving source-code ordering of +-- centres with the same module, name, and flavour. +data CCFlavour = CafCC -- ^ Auto-generated top-level thunk, they all go into the same bucket + | IndexedCC !IndexedCCFlavour !CostCentreIndex -- ^ Explicitly annotated expression + deriving (Eq, Ord, Data) + +-- Construct a CC flavour +mkCafFlavour :: CCFlavour +mkCafFlavour = CafCC +mkExprCCFlavour :: CostCentreIndex -> CCFlavour +mkExprCCFlavour idx = IndexedCC ExprCC idx +mkDeclCCFlavour :: CostCentreIndex -> CCFlavour +mkDeclCCFlavour idx = IndexedCC DeclCC idx +mkHpcCCFlavour :: CostCentreIndex -> CCFlavour +mkHpcCCFlavour idx = IndexedCC HpcCC idx +mkLateCCFlavour :: CostCentreIndex -> CCFlavour +mkLateCCFlavour idx = IndexedCC LateCC idx +mkCallerCCFlavour :: CostCentreIndex -> CCFlavour +mkCallerCCFlavour idx = IndexedCC CallerCC idx + +-- | Extract the index from a flavour +flavourIndex :: CCFlavour -> Int +flavourIndex CafCC = 0 +flavourIndex (IndexedCC _flav x) = unCostCentreIndex x + +instance Eq CostCentre where + c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } + +instance Ord CostCentre where + compare = cmpCostCentre + +cmpCostCentre :: CostCentre -> CostCentre -> Ordering + +cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) + = m1 `compare` m2 + +cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1} + NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2} + -- first key is module name, then centre name, then flavour + = mconcat + [ m1 `compare` m2 + , n1 `lexicalCompareFS` n2 -- compare lexically to avoid non-determinism + , f1 `compare` f2 + ] + +cmpCostCentre other_1 other_2 + = let + tag1 = tag_CC other_1 + tag2 = tag_CC other_2 + in + if tag1 < tag2 then LT else GT + where + tag_CC :: CostCentre -> Int + tag_CC (NormalCC {}) = 0 + tag_CC (AllCafsCC {}) = 1 + + +----------------------------------------------------------------------------- +-- Predicates on CostCentre + +isCafCC :: CostCentre -> Bool +isCafCC (AllCafsCC {}) = True +isCafCC (NormalCC {cc_flavour = CafCC}) = True +isCafCC _ = False + +-- | Is this a cost-centre which records scc counts +isSccCountCC :: CostCentre -> Bool +isSccCountCC cc | isCafCC cc = False + | otherwise = True + +-- | Is this a cost-centre which can be sccd ? +sccAbleCC :: CostCentre -> Bool +sccAbleCC cc | isCafCC cc = False + | otherwise = True + +ccFromThisModule :: CostCentre -> Module -> Bool +ccFromThisModule cc m = cc_mod cc == m + + +----------------------------------------------------------------------------- +-- Building cost centres + +mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre +mkUserCC cc_name mod loc flavour + = NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc, + cc_flavour = flavour + } + +mkAutoCC :: Id -> Module -> CostCentre +mkAutoCC id mod + = NormalCC { cc_name = str, cc_mod = mod, + cc_loc = nameSrcSpan (getName id), + cc_flavour = CafCC + } + where + name = getName id + -- beware: only external names are guaranteed to have unique + -- Occnames. If the name is not external, we must append its + -- Unique. + -- See bug #249, tests prof001, prof002, also #2411 + str | isExternalName name = occNameFS (getOccName id) + | otherwise = concatFS [occNameFS (getOccName id), + fsLit "_", + mkFastString (show (getUnique name))] +mkAllCafsCC :: Module -> SrcSpan -> CostCentre +mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } + +----------------------------------------------------------------------------- +-- Cost Centre Stacks + +-- | A Cost Centre Stack is something that can be attached to a closure. +-- This is either: +-- +-- * the current cost centre stack (CCCS) +-- * a pre-defined cost centre stack (there are several +-- pre-defined CCSs, see below). + +data CostCentreStack + = CurrentCCS -- Pinned on a let(rec)-bound + -- thunk/function/constructor, this says that the + -- cost centre to be attached to the object, when it + -- is allocated, is whatever is in the + -- current-cost-centre-stack register. + + | DontCareCCS -- We need a CCS to stick in static closures + -- (for data), but we *don't* expect them to + -- accumulate any costs. But we still need + -- the placeholder. This CCS is it. + + | SingletonCCS CostCentre + + deriving (Eq, Ord) -- needed for Ord on CLabel + + +-- synonym for triple which describes the cost centre info in the generated +-- code for a module. +type CollectedCCs + = ( [CostCentre] -- local cost-centres that need to be decl'd + , [CostCentreStack] -- pre-defined "singleton" cost centre stacks + ) + +emptyCollectedCCs :: CollectedCCs +emptyCollectedCCs = ([], []) + +collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs +collectCC cc ccs (c, cs) = (cc : c, ccs : cs) + +currentCCS, dontCareCCS :: CostCentreStack + +currentCCS = CurrentCCS +dontCareCCS = DontCareCCS + +----------------------------------------------------------------------------- +-- Predicates on Cost-Centre Stacks + +isCurrentCCS :: CostCentreStack -> Bool +isCurrentCCS CurrentCCS = True +isCurrentCCS _ = False + +isCafCCS :: CostCentreStack -> Bool +isCafCCS (SingletonCCS cc) = isCafCC cc +isCafCCS _ = False + +maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre +maybeSingletonCCS (SingletonCCS cc) = Just cc +maybeSingletonCCS _ = Nothing + +mkSingletonCCS :: CostCentre -> CostCentreStack +mkSingletonCCS cc = SingletonCCS cc + + +----------------------------------------------------------------------------- +-- Printing Cost Centre Stacks. + +-- The outputable instance for CostCentreStack prints the CCS as a C +-- expression. + +instance Outputable CostCentreStack where + ppr = pprCostCentreStack + +pprCostCentreStack :: IsLine doc => CostCentreStack -> doc +pprCostCentreStack CurrentCCS = text "CCCS" +pprCostCentreStack DontCareCCS = text "CCS_DONT_CARE" +pprCostCentreStack (SingletonCCS cc) = pprCostCentre cc <> text "_ccs" +{-# SPECIALISE pprCostCentreStack :: CostCentreStack -> SDoc #-} +{-# SPECIALISE pprCostCentreStack :: CostCentreStack -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +----------------------------------------------------------------------------- +-- Printing Cost Centres +-- +-- There are several different ways in which we might want to print a +-- cost centre: +-- +-- - the name of the cost centre, for profiling output (a C string) +-- - the label, i.e. C label for cost centre in .hc file. +-- - the debugging name, for output in -ddump things +-- - the interface name, for printing in _scc_ exprs in iface files. +-- +-- The last 3 are derived from costCentreStr below. The first is given +-- by costCentreName. + +instance Outputable CostCentre where + ppr = pprCostCentre + +pprCostCentre :: IsLine doc => CostCentre -> doc +pprCostCentre cc = docWithStyle (ppCostCentreLbl cc) + (\_ -> ftext (costCentreUserNameFS cc)) +{-# SPECIALISE pprCostCentre :: CostCentre -> SDoc #-} +{-# SPECIALISE pprCostCentre :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- Printing in Core +pprCostCentreCore :: CostCentre -> SDoc +pprCostCentreCore (AllCafsCC {cc_mod = m}) + = text "__sccC" <+> braces (ppr m) +pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n, + cc_mod = m, cc_loc = loc}) + = text "__scc" <+> braces (hsep [ + ppr m <> char '.' <> ftext n, + pprFlavourCore flavour, + whenPprDebug (ppr loc) + ]) + +-- ^ Print a flavour in Core +pprFlavourCore :: CCFlavour -> SDoc +pprFlavourCore CafCC = text "__C" +pprFlavourCore f = pprIdxCore $ flavourIndex f + +-- ^ Print a flavour's index in Core +pprIdxCore :: Int -> SDoc +pprIdxCore 0 = empty +pprIdxCore idx = whenPprDebug $ ppr idx + +-- Printing as a C label +ppCostCentreLbl :: IsLine doc => CostCentre -> doc +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = pprModule m <> text "_CAFs_cc" +ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) + = pprModule m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> + ppFlavourLblComponent f <> text "_cc" +{-# SPECIALISE ppCostCentreLbl :: CostCentre -> SDoc #-} +{-# SPECIALISE ppCostCentreLbl :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- ^ Print the flavour component of a C label +ppFlavourLblComponent :: IsLine doc => CCFlavour -> doc +ppFlavourLblComponent CafCC = text "CAF" +ppFlavourLblComponent (IndexedCC flav i) = + case flav of + ExprCC -> text "EXPR" <> ppIdxLblComponent i + DeclCC -> text "DECL" <> ppIdxLblComponent i + HpcCC -> text "HPC" <> ppIdxLblComponent i + LateCC -> text "LATECC" <> ppIdxLblComponent i + CallerCC -> text "CALLERCC" <> ppIdxLblComponent i +{-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> SDoc #-} +{-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- ^ Print the flavour index component of a C label +ppIdxLblComponent :: IsLine doc => CostCentreIndex -> doc +ppIdxLblComponent n = + case unCostCentreIndex n of + 0 -> empty + n -> int n +{-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> SDoc #-} +{-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- This is the name to go in the user-displayed string, +-- recorded in the cost centre declaration +costCentreUserName :: CostCentre -> String +costCentreUserName = unpackFS . costCentreUserNameFS + +costCentreUserNameFS :: CostCentre -> FastString +costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" +costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf}) + = case is_caf of + CafCC -> mkFastString "CAF:" `appendFS` name + _ -> name + +costCentreSrcSpan :: CostCentre -> SrcSpan +costCentreSrcSpan = cc_loc + +instance Binary CCFlavour where + put_ bh CafCC = + putByte bh 0 + put_ bh (IndexedCC flav i) = do + putByte bh 1 + let !flav_index = fromEnum flav + put_ bh flav_index + put_ bh i + get bh = do + h <- getByte bh + case h of + 0 -> return CafCC + _ -> do + IndexedCC <$> (toEnum <$> get bh) <*> get bh + +instance Binary CostCentre where + put_ bh (NormalCC aa ab ac _ad) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh (AllCafsCC ae _af) = do + putByte bh 1 + put_ bh ae + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + ac <- get bh + return (NormalCC aa ab ac noSrcSpan) + _ -> do ae <- get bh + return (AllCafsCC ae noSrcSpan) + + -- We ignore the SrcSpans in CostCentres when we serialise them, + -- and set the SrcSpans to noSrcSpan when deserialising. This is + -- ok, because we only need the SrcSpan when declaring the + -- CostCentre in the original module, it is not used by importing + -- modules. + +instance NFData CostCentre where + rnf (NormalCC aa ab ac ad) = rnf aa `seq` rnf ab `seq` rnf ac `seq` rnf ad + rnf (AllCafsCC ae ad) = rnf ae `seq` rnf ad + +instance NFData CCFlavour where + rnf CafCC = () + rnf (IndexedCC flav i) = rnf flav `seq` rnf i + +instance NFData IndexedCCFlavour where + rnf ExprCC = () + rnf DeclCC = () + rnf HpcCC = () + rnf LateCC = () + rnf CallerCC = () + +getAllCAFsCC :: Module -> (CostCentre, CostCentreStack) +getAllCAFsCC this_mod = + let + span = mkGeneralSrcSpan (mkFastString "") -- XXX do better + all_cafs_cc = mkAllCafsCC this_mod span + all_cafs_ccs = mkSingletonCCS all_cafs_cc + in + (all_cafs_cc, all_cafs_ccs) + diff --git a/GHC/Types/CostCentre/State.hs b/GHC/Types/CostCentre/State.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/CostCentre/State.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Types.CostCentre.State + ( CostCentreState + , newCostCentreState + , CostCentreIndex + , unCostCentreIndex + , getCCIndex + ) +where + +import GHC.Prelude +import GHC.Data.FastString +import GHC.Data.FastString.Env + +import Data.Data +import GHC.Utils.Binary +import Control.DeepSeq + +-- | Per-module state for tracking cost centre indices. +-- +-- See documentation of 'GHC.Types.CostCentre.cc_flavour' for more details. +newtype CostCentreState = CostCentreState (FastStringEnv Int) + +-- | Initialize cost centre state. +newCostCentreState :: CostCentreState +newCostCentreState = CostCentreState emptyFsEnv + +-- | An index into a given cost centre module,name,flavour set +newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int } + deriving (Eq, Ord, Data, Binary) + +instance NFData CostCentreIndex where + rnf (CostCentreIndex i) = rnf i + +-- | Get a new index for a given cost centre name. +getCCIndex :: FastString + -> CostCentreState + -> (CostCentreIndex, CostCentreState) +getCCIndex nm (CostCentreState m) = + (CostCentreIndex idx, CostCentreState m') + where + m_idx = lookupFsEnv m nm + idx = maybe 0 id m_idx + m' = extendFsEnv m nm (idx + 1) diff --git a/GHC/Types/Cpr.hs b/GHC/Types/Cpr.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Cpr.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Types for the Constructed Product Result lattice. +-- "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils" +-- are its primary customers via 'GHC.Types.Id.idCprSig'. +module GHC.Types.Cpr ( + Cpr (ConCpr), topCpr, botCpr, flatConCpr, asConCpr, + CprType (..), topCprType, botCprType, flatConCprType, + lubCprType, applyCprTy, abstractCprTy, trimCprTy, + UnpackConFieldsResult (..), unpackConFieldsCpr, + CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, + seqCprSig, prependArgsCprSig + ) where + +import GHC.Prelude + +import GHC.Core.DataCon +import GHC.Types.Basic +import GHC.Utils.Binary +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- +-- * Cpr +-- + +data Cpr + = BotCpr + | ConCpr_ !ConTag ![Cpr] + -- ^ The number of field Cprs equals 'dataConRepArity'. + -- If all of them are top, better use 'FlatConCpr', as ensured by the pattern + -- synonym 'ConCpr'. + | FlatConCpr !ConTag + -- ^ @FlatConCpr tag@ is an efficient encoding for @'ConCpr_' tag [TopCpr..]@. + -- Purely for compiler perf. Can be constructed with 'ConCpr'. + | TopCpr + deriving Eq + +pattern ConCpr :: ConTag -> [Cpr] -> Cpr +pattern ConCpr t cs <- ConCpr_ t cs where + ConCpr t cs + | all (== TopCpr) cs = FlatConCpr t + | otherwise = ConCpr_ t cs +{-# COMPLETE BotCpr, TopCpr, FlatConCpr, ConCpr #-} + +viewConTag :: Cpr -> Maybe ConTag +viewConTag (FlatConCpr t) = Just t +viewConTag (ConCpr t _) = Just t +viewConTag _ = Nothing +{-# INLINE viewConTag #-} + +lubCpr :: Cpr -> Cpr -> Cpr +lubCpr BotCpr cpr = cpr +lubCpr cpr BotCpr = cpr +lubCpr (FlatConCpr t1) (viewConTag -> Just t2) + | t1 == t2 = FlatConCpr t1 +lubCpr (viewConTag -> Just t1) (FlatConCpr t2) + | t1 == t2 = FlatConCpr t2 +lubCpr (ConCpr t1 cs1) (ConCpr t2 cs2) + | t1 == t2 = ConCpr t1 (lubFieldCprs cs1 cs2) +lubCpr _ _ = TopCpr + +lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr] +lubFieldCprs as bs + | as `equalLength` bs = zipWith lubCpr as bs + | otherwise = [] + +topCpr :: Cpr +topCpr = TopCpr + +botCpr :: Cpr +botCpr = BotCpr + +flatConCpr :: ConTag -> Cpr +flatConCpr t = FlatConCpr t + +trimCpr :: Cpr -> Cpr +trimCpr BotCpr = botCpr +trimCpr _ = topCpr + +asConCpr :: Cpr -> Maybe (ConTag, [Cpr]) +asConCpr (ConCpr t cs) = Just (t, cs) +asConCpr (FlatConCpr t) = Just (t, []) +asConCpr TopCpr = Nothing +asConCpr BotCpr = Nothing + +seqCpr :: Cpr -> () +seqCpr (ConCpr _ cs) = foldr (seq . seqCpr) () cs +seqCpr _ = () + +-- +-- * CprType +-- + +-- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper. +data CprType + = CprType + { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression + -- eats before returning the 'ct_cpr' + , ct_cpr :: !Cpr -- ^ 'Cpr' eventually unleashed when applied to + -- 'ct_arty' arguments + } + +instance Eq CprType where + a == b = ct_cpr a == ct_cpr b + && (ct_arty a == ct_arty b || ct_cpr a == topCpr) + +topCprType :: CprType +topCprType = CprType 0 topCpr + +botCprType :: CprType +botCprType = CprType 0 botCpr + +flatConCprType :: ConTag -> CprType +flatConCprType con_tag = CprType { ct_arty = 0, ct_cpr = flatConCpr con_tag } + +lubCprType :: CprType -> CprType -> CprType +lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2) + -- The arity of bottom CPR types can be extended arbitrarily. + | cpr1 == botCpr && n1 <= n2 = ty2 + | cpr2 == botCpr && n2 <= n1 = ty1 + -- There might be non-bottom CPR types with mismatching arities. + -- Consider test DmdAnalGADTs. We want to return top in these cases. + | n1 == n2 = CprType n1 (lubCpr cpr1 cpr2) + | otherwise = topCprType + +applyCprTy :: CprType -> Arity -> CprType +applyCprTy (CprType n res) k + | n >= k = CprType (n-k) res + | res == botCpr = botCprType + | otherwise = topCprType + +abstractCprTy :: CprType -> CprType +abstractCprTy (CprType n res) + | res == topCpr = topCprType + | otherwise = CprType (n+1) res + +trimCprTy :: CprType -> CprType +trimCprTy (CprType arty res) = CprType arty (trimCpr res) + +-- | The result of 'unpackConFieldsCpr'. +data UnpackConFieldsResult + = AllFieldsSame !Cpr + | ForeachField ![Cpr] + +-- | Unpacks a 'ConCpr'-shaped 'Cpr' and returns the field 'Cpr's wrapped in a +-- 'ForeachField'. Otherwise, it returns 'AllFieldsSame' with the appropriate +-- 'Cpr' to assume for each field. +-- +-- The use of 'UnpackConFieldsResult' allows O(1) space for the common, +-- non-'ConCpr' case. +unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult +unpackConFieldsCpr dc (ConCpr t cs) + | t == dataConTag dc, cs `lengthIs` dataConRepArity dc + = ForeachField cs +unpackConFieldsCpr _ BotCpr = AllFieldsSame BotCpr +unpackConFieldsCpr _ _ = AllFieldsSame TopCpr +{-# INLINE unpackConFieldsCpr #-} + +seqCprTy :: CprType -> () +seqCprTy (CprType _ cpr) = seqCpr cpr + +-- | The arity of the wrapped 'CprType' is the arity at which it is safe +-- to unleash. See Note [Understanding DmdType and DmdSig] in "GHC.Types.Demand" +newtype CprSig = CprSig { getCprSig :: CprType } + deriving (Eq, Binary) + +-- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig' +-- unleashable at that arity. See Note [Understanding DmdType and DmdSig] in +-- "GHC.Types.Demand" +mkCprSigForArity :: Arity -> CprType -> CprSig +mkCprSigForArity arty ty@(CprType n _) + | arty /= n = topCprSig -- Trim on arity mismatch + | otherwise = CprSig ty + +topCprSig :: CprSig +topCprSig = CprSig topCprType + +isTopCprSig :: CprSig -> Bool +isTopCprSig (CprSig ty) = ct_cpr ty == topCpr + +mkCprSig :: Arity -> Cpr -> CprSig +mkCprSig arty cpr = CprSig (CprType arty cpr) + +seqCprSig :: CprSig -> () +seqCprSig (CprSig ty) = seqCprTy ty + +prependArgsCprSig :: Arity -> CprSig -> CprSig +-- ^ Add extra value args to CprSig +prependArgsCprSig n_extra cpr_sig@(CprSig (CprType arity cpr)) + | n_extra == 0 = cpr_sig + | otherwise = assertPpr (n_extra > 0) (ppr n_extra) $ + CprSig (CprType (arity + n_extra) cpr) + +-- | BNF: +-- +-- > cpr ::= '' -- TopCpr +-- > | n -- FlatConCpr n +-- > | n '(' cpr1 ',' cpr2 ',' ... ')' -- ConCpr n [cpr1,cpr2,...] +-- > | 'b' -- BotCpr +-- +-- Examples: +-- * `f x = f x` has result CPR `b` +-- * `1(1,)` is a valid (nested) 'Cpr' denotation for `(I# 42#, f 42)`. +instance Outputable Cpr where + ppr TopCpr = empty + ppr (FlatConCpr n) = int n + ppr (ConCpr n cs) = int n <> parens (pprWithCommas ppr cs) + ppr BotCpr = char 'b' + +-- | BNF: +-- +-- > cpr_ty ::= cpr -- short form if arty == 0 +-- > | '\' arty '.' cpr -- if arty > 0 +-- +-- Examples: +-- * `f x y z = f x y z` has denotation `\3.b` +-- * `g !x = (x+1, x+2)` has denotation `\1.1(1,1)`. +instance Outputable CprType where + ppr (CprType arty res) + | 0 <- arty = ppr res + | otherwise = char '\\' <> ppr arty <> char '.' <> ppr res + +-- | Only print the CPR result +instance Outputable CprSig where + ppr (CprSig ty) = ppr (ct_cpr ty) + +instance Binary Cpr where + put_ bh TopCpr = putByte bh 0 + put_ bh BotCpr = putByte bh 1 + put_ bh (FlatConCpr n) = putByte bh 2 *> put_ bh n + put_ bh (ConCpr n cs) = putByte bh 3 *> put_ bh n *> put_ bh cs + get bh = do + h <- getByte bh + case h of + 0 -> return TopCpr + 1 -> return BotCpr + 2 -> FlatConCpr <$> get bh + 3 -> ConCpr <$> get bh <*> get bh + _ -> pprPanic "Binary Cpr: Invalid tag" (int (fromIntegral h)) + +instance Binary CprType where + put_ bh (CprType arty cpr) = put_ bh arty *> put_ bh cpr + get bh = CprType <$> get bh <*> get bh diff --git a/GHC/Types/DefaultEnv.hs b/GHC/Types/DefaultEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/DefaultEnv.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Types.DefaultEnv + ( ClassDefaults (..) + , DefaultProvenance (..) + , DefaultEnv + , emptyDefaultEnv + , isEmptyDefaultEnv + , defaultEnv + , unitDefaultEnv + , lookupDefaultEnv + , filterDefaultEnv + , defaultList + , plusDefaultEnv + , mkDefaultEnv + , insertDefaultEnv + , isHaskell2010Default + ) +where + +import GHC.Core.Class (Class (className)) +import GHC.Prelude +import GHC.Hs.Extension (GhcRn) +import GHC.Tc.Utils.TcType (Type) +import GHC.Types.Name (Name, nameUnique, stableNameCmp) +import GHC.Types.Name.Env +import GHC.Types.Unique.FM (lookupUFM_Directly) +import GHC.Types.SrcLoc (SrcSpan) +import GHC.Unit.Module.Warnings (WarningTxt) +import GHC.Unit.Types (Module) +import GHC.Utils.Outputable + +import Data.Data (Data) +import Data.List (sortBy) +import Data.Function (on) + +-- See Note [Named default declarations] in GHC.Tc.Gen.Default + +-- | Default environment mapping class name @Name@ to their default type lists +-- +-- NB: this includes Haskell98 default declarations, at the 'Num' key. +type DefaultEnv = NameEnv ClassDefaults + +{- Note [DefaultProvenance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each `ClassDefault` is annotated with its `DefaultProvenance`, which +says where the default came from. Specifically +* `DP_Local loc h98`: the default came from an explicit `default` declaration in the module + being compiled, at location `loc`, and the boolean `h98` indicates whether + it was from a Haskell 98 default declaration (e.g. `default (Int, Double)`). +* `DP_Imported M`: the default was imported, it is explicitly exported by module `M`. +* `DP_Builtin`: the default was automatically provided by GHC. + see Note [Builtin class defaults] in GHC.Tc.Utils.Env + +These annotations are used to disambiguate multiple defaults for the same class. +For example, consider the following modules: + + module M( default C ) where { default C( ... ) } + module M2( default C) where { import M } + module N( default C () where { default C(... ) } + + module A where { import M2 } + module B where { import M2; import N } + module A1 where { import N; default C ( ... ) } + module B2 where { default C ( ... ); default C ( ... ) } + +When compiling N, the default for C is annotated with DP_Local loc. +When compiling M2, the default for C is annotated with DP_Local M. +When compiling A, the default for C is annotated with DP_Imported M2. + +Cases we needed to disambiguate: + * Compiling B, two defaults for C: DP_Imported M2, DP_Imported N. + * Compiling A1, two defaults for C: DP_Imported N, DP_Local loc. + * Compiling B2, two defaults for C: DP_Local loc1, DP_Local loc2. + +For how we disambiguate these cases, +See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module. +-} + +-- | The provenance of a collection of default types for a class. +-- see Note [DefaultProvenance] for more details +data DefaultProvenance + -- | A locally defined default declaration. + = DP_Local + { defaultDeclLoc :: SrcSpan -- ^ The 'SrcSpan' of the default declaration + , defaultDeclH98 :: Bool -- ^ Is this a Haskell 98 default declaration? + } + -- | Built-in class defaults. + | DP_Builtin + -- | Imported class defaults. + | DP_Imported Module -- ^ The module from which the defaults were imported + deriving (Eq, Data) + +instance Outputable DefaultProvenance where + ppr (DP_Local loc h98) = ppr loc <> (if h98 then text " (H98)" else empty) + ppr DP_Builtin = text "built-in" + ppr (DP_Imported mod) = ppr mod + +isHaskell2010Default :: DefaultProvenance -> Bool +isHaskell2010Default = \case + DP_Local { defaultDeclH98 = isH98 } -> isH98 + DP_Builtin -> True + DP_Imported {} -> False + +-- | Defaulting type assignments for the given class. +data ClassDefaults + = ClassDefaults { cd_class :: Class -- ^ The class whose defaults are being defined + , cd_types :: [Type] + , cd_provenance :: DefaultProvenance + -- ^ Where the defaults came from + -- see Note [Default exports] in GHC.Tc.Gen.Export + , cd_warn :: Maybe (WarningTxt GhcRn) + -- ^ Warning emitted when the default is used + } + deriving Data + +instance Outputable ClassDefaults where + ppr ClassDefaults {cd_class = cls, cd_types = tys} = text "default" <+> ppr cls + <+> parens (interpp'SP tys) + +emptyDefaultEnv :: DefaultEnv +emptyDefaultEnv = emptyNameEnv + +isEmptyDefaultEnv :: DefaultEnv -> Bool +isEmptyDefaultEnv = isEmptyNameEnv + +unitDefaultEnv :: ClassDefaults -> DefaultEnv +unitDefaultEnv d = unitNameEnv (className $ cd_class d) d + +defaultEnv :: [ClassDefaults] -> DefaultEnv +defaultEnv = mkNameEnvWith (className . cd_class) + +defaultList :: DefaultEnv -> [ClassDefaults] +defaultList = sortBy (stableNameCmp `on` className . cd_class) . nonDetNameEnvElts + -- sortBy recovers determinism + +insertDefaultEnv :: ClassDefaults -> DefaultEnv -> DefaultEnv +insertDefaultEnv d env = extendNameEnv env (className $ cd_class d) d + +lookupDefaultEnv :: DefaultEnv -> Name -> Maybe ClassDefaults +lookupDefaultEnv env = lookupUFM_Directly env . nameUnique + +filterDefaultEnv :: (ClassDefaults -> Bool) -> DefaultEnv -> DefaultEnv +filterDefaultEnv = filterNameEnv + +plusDefaultEnv :: DefaultEnv -> DefaultEnv -> DefaultEnv +plusDefaultEnv = plusNameEnv + +-- | Create a 'DefaultEnv' from a list of (Name, ClassDefaults) pairs +-- it is useful if we don't want to poke into the 'ClassDefaults' structure +-- to get the 'Name' of the class, it can be problematic, see #25858 +mkDefaultEnv :: [(Name, ClassDefaults)] -> DefaultEnv +mkDefaultEnv = mkNameEnv diff --git a/GHC/Types/Demand.hs b/GHC/Types/Demand.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Demand.hs @@ -0,0 +1,2810 @@ + +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE PatternSynonyms #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +-- | A language to express the evaluation context of an expression as a +-- 'Demand' and track how an expression evaluates free variables and arguments +-- in turn as a 'DmdType'. +-- +-- Lays out the abstract domain for "GHC.Core.Opt.DmdAnal". +module GHC.Types.Demand ( + -- * Demands + Boxity(..), + Card(C_00, C_01, C_0N, C_10, C_11, C_1N), CardNonAbs, CardNonOnce, + Demand(AbsDmd, BotDmd, (:*)), + SubDemand(Prod, Poly), mkProd, viewProd, + -- ** Algebra + absDmd, topDmd, botDmd, seqDmd, topSubDmd, + -- *** Least upper bound + lubCard, lubDmd, lubSubDmd, + -- *** Greatest lower bound + glbCard, + -- *** Plus + plusCard, plusDmd, plusSubDmd, + -- *** Multiply + multCard, multDmd, multSubDmd, + -- ** Predicates on @Card@inalities and @Demand@s + isAbs, isAtMostOnce, isStrict, + isAbsDmd, isAtMostOnceDmd, isStrUsedDmd, isStrictDmd, + isTopDmd, isWeakDmd, onlyBoxedArguments, + -- ** Special demands + evalDmd, + -- *** Demands used in PrimOp signatures + lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd, + -- ** Other @Demand@ operations + oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, floatifyDmd, + peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, strictCallArity, + mkWorkerDemand, subDemandIfEvaluated, + -- ** Extracting one-shot information + callCards, argOneShots, argsOneShots, saturatedByOneShots, + -- ** Manipulating Boxity of a Demand + unboxDeeplyDmd, + + -- * Divergence + Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv, + + -- * Demand environments + DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs, + multDmdEnv, reuseEnv, + + -- * Demand types + DmdType(..), dmdTypeDepth, + -- ** Algebra + nopDmdType, botDmdType, + lubDmdType, plusDmdType, multDmdType, discardArgDmds, + -- ** Other operations + peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException, + + -- * Demand signatures + DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, mkVanillaDmdSig, + splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig, + nopSig, botSig, isNopSig, isBottomingSig, isDeadEndSig, isDeadEndAppSig, + trimBoxityDmdSig, transferArgBoxityDmdSig, + + -- ** Handling arity adjustments + prependArgsDmdSig, etaConvertDmdSig, + + -- * Demand transformers from demand signatures + DmdTransformer, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig, + + -- * Trim to a type shape + TypeShape(..), trimToType, trimBoxity, + + -- * @seq@ing stuff + seqDemand, seqDemandList, seqDmdType, seqDmdSig, + + -- * Zapping usage information + zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Unique.FM +import GHC.Types.Basic +import GHC.Data.Maybe ( orElse ) + +import GHC.Core.Type ( Type, isTerminatingType ) +import GHC.Core.DataCon ( splitDataProductType_maybe, StrictnessMark, isMarkedStrict ) +import GHC.Core.Multiplicity ( scaledThing ) + +import GHC.Utils.Binary +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Coerce (coerce) +import Data.Function + +{- +************************************************************************ +* * + Boxity: Whether the box of something is used +* * +************************************************************************ +-} + +{- Note [Strictness and Unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If an argument is used strictly by the function body, we may use use +call-by-value instead of call-by-need for that argument. What's more, we may +unbox an argument that is used strictly, discarding the box at the call site. +This can reduce allocations of the program drastically if the box really isn't +needed in the function body. Here's an example: +``` +even :: Int -> Bool +even (I# 0) = True +even (I# 1) = False +even (I# n) = even (I# (n -# 2)) +``` +All three code paths of 'even' are (a) strict in the argument, and (b) +immediately discard the boxed 'Int'. Now if we have a call site like +`even (I# 42)`, then it would be terrible to allocate the 'I#' box for the +argument only to tear it apart immediately in the body of 'even'! Hence, +worker/wrapper will allocate a wrapper for 'even' that not only uses +call-by-value for the argument (e.g., `case I# 42 of b { $weven b }`), but also +*unboxes* the argument, resulting in +``` +even :: Int -> Bool +even (I# n) = $weven n +$weven :: Int# -> Bool +$weven 0 = True +$weven 1 = False +$weven n = $weven (n -# 2) +``` +And now the box in `even (I# 42)` will cancel away after inlining the wrapper. + +As far as the permission to unbox is concerned, *evaluatedness* of the argument +is the important trait. Unboxing implies eager evaluation of an argument and +we don't want to change the termination properties of the function. One way +to ensure that is to unbox strict arguments only, but strictness is only a +sufficient condition for evaluatedness. +See Note [Unboxing evaluated arguments] in "GHC.Core.Opt.DmdAnal", where +we manage to unbox *strict fields* of unboxed arguments that the function is not +actually strict in, simply by realising that those fields have to be evaluated. + +Note [Boxity analysis] +~~~~~~~~~~~~~~~~~~~~~~ +Alas, we don't want to unbox *every* strict argument +(as Note [Strictness and Unboxing] might suggest). +Here's an example (from T19871): +``` +data Huge = H Bool Bool ... Bool +ann :: Huge -> (Bool, Huge) +ann h@(Huge True _ ... _) = (False, h) +ann h = (True, h) +``` +Unboxing 'h' yields +``` +$wann :: Bool -> Bool -> ... -> Bool -> (Bool, Huge) +$wann True b2 ... bn = (False, Huge True b2 ... bn) +$wann b1 b2 ... bn = (True, Huge b1 b2 ... bn) +``` +The pair constructor really needs its fields boxed. But '$wann' doesn't get +passed 'h' anymore, only its components! Ergo it has to reallocate the 'Huge' +box, in a process called "reboxing". After w/w, call sites like +`case ... of Just h -> ann h` pay for the allocation of the additional box. +In earlier versions of GHC we simply accepted that reboxing would sometimes +happen, but we found some cases where it made a big difference: #19407, for +example. + +We therefore perform a simple syntactic boxity analysis that piggy-backs on +demand analysis in order to determine whether the box of a strict argument is +always discarded in the function body, in which case we can pass it unboxed +without risking regressions such as in 'ann' above. But as soon as one use needs +the box, we want Boxed to win over any Unboxed uses. + +The demand signature (cf. Note [Demand notation]) will say whether it uses +its arguments boxed or unboxed. Indeed it does so for every sub-component of +the argument demand. Here's an example: +``` +f :: (Int, Int) -> Bool +f (a, b) = even (a + b) -- demand signature: <1!P(1!L,1!L)> +``` +The '!' indicates places where we want to unbox, the lack thereof indicates the +box is used by the function. Boxity flags are part of the 'Poly' and 'Prod' +'SubDemand's, see Note [Why Boxity in SubDemand and not in Demand?]. +The given demand signature says "Unbox the pair and then nestedly unbox its +two fields". By contrast, the demand signature of 'ann' above would look like +<1P(1L,L,...,L)>, lacking any '!'. + +A demand signature like <1P(1!L)> -- Boxed outside but Unboxed in the field -- +doesn't make a lot of sense, as we can never unbox the field without unboxing +the containing record. See Note [Finalising boxity for demand signatures] in +"GHC.Core.Opt.DmdAnal" for how we avoid to spread this and other kinds of +misinformed boxities. + +Due to various practical reasons, Boxity Analysis is not conservative at times. +Here are reasons for too much optimism: + + * Note [Function body boxity and call sites] is an observation about when it is + beneficial to unbox a parameter that is returned from a function. + Note [Unboxed demand on function bodies returning small products] derives + a heuristic from the former Note, pretending that all call sites of a + function need returned small products Unboxed. + * Note [Boxity for bottoming functions] in DmdAnal makes all bottoming + functions unbox their arguments, incurring reboxing in code paths that will + diverge anyway. In turn we get more unboxing in hot code paths. + +Boxity analysis fixes a number of issues: #19871, #19407, #4267, #16859, #18907, #13331 + +Note [Function body boxity and call sites] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (from T5949) +``` +f n p = case n of + 0 -> p :: (a, b) + _ -> f (n-1) p +-- Worker/wrapper split if we decide to unbox: +$wf n x y = case n of + 0 -> (# x, y #) + _ -> $wf (n-1) x y +f n (x,y) = case $wf n x y of (# r, s #) -> (r,s) +``` +When is it better to /not/ to unbox 'p'? That depends on the callers of 'f'! +If all call sites + + 1. Wouldn't need to allocate fresh boxes for 'p', and + 2. Needed the result pair of 'f' boxed + +Only then we'd see an increase in allocation resulting from unboxing. But as +soon as only one of (1) or (2) holds, it really doesn't matter if 'f' unboxes +'p' (and its result, it's important that CPR follows suit). For example +``` +res = ... case f m (field t) of (r1,r2) -> ... -- (1) holds +arg = ... [ f m (x,y) ] ... -- (2) holds +``` +Because one of the boxes in the call site can cancel away: +``` +res = ... case field1 t of (x1,x2) -> + case field2 t of (y1,y2) -> + case $wf x1 x2 y1 y2 of (#r1,r2#) -> ... +arg = ... [ case $wf x1 x2 y1 y2 of (#r1,r2#) -> (r1,r2) ] ... +``` +And when call sites neither have arg boxes (1) nor need the result boxed (2), +then hesitating to unbox means /more/ allocation in the call site because of the +need for fresh argument boxes. + +Summary: If call sites that satisfy both (1) and (2) occur more often than call +sites that satisfy neither condition, then it's best /not/ to unbox 'p'. + +Note [Unboxed demand on function bodies returning small products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Boxity analysis] achieves its biggest wins when we avoid reboxing huge +records. But when we return small products from a function, we often get faster +programs by pretending that the caller unboxes the result. Long version: + +Observation: Big record arguments (e.g., DynFlags) tend to be modified much less + frequently than small records (e.g., Int). +Result: Big records tend to be passed around boxed (unmodified) much more + frequently than small records. +Consequence: The larger the record, the more likely conditions (1) and (2) from + Note [Function body boxity and call sites] are met, in which case + unboxing returned parameters leads to reboxing. + +So we put an Unboxed demand on function bodies returning small products and a +Boxed demand on the others. What is regarded a small product is controlled by +the -fdmd-unbox-width flag. + +This also manages to unbox functions like +``` +sum z [] = z +sum (I# n) ((I# x):xs) = sum (I# (n +# x)) xs +``` +where we can unbox 'z' on the grounds that it's but a small box anyway. That in +turn means that the I# allocation in the recursive call site can cancel away and +we get a non-allocating loop, nice and tight. +Note that this is the typical case in "Observation" above: A small box is +unboxed, modified, the result reboxed for the recursive call. + +Originally, this came up in binary-trees' check' function and #4267 which +(similarly) features a strict fold over a tree. We'd also regress in join004 and +join007 if we didn't assume an optimistic Unboxed demand on the function body. +T17932 features a (non-recursive) function that returns a large record, e.g., +``` +flags (Options f x) = `seq` f +``` +and here we won't unbox 'f' because it has 5 fields (which is larger than the +default -fdmd-unbox-width threshold). + +Why not focus on putting Unboxed demands on *all recursive* function? +Then we'd unbox +``` +flags 0 (Options f x) = `seq` f +flags n o = flags (n-1) o +``` +and that seems hardly useful. +(NB: Similar to 'f' from Note [Preserving Boxity of results is rarely a win], +but there we only had 2 fields.) + +What about the Boxity of *fields* of a small, returned box? Consider +``` +sumIO :: Int -> Int -> IO Int +sumIO 0 !z = return z -- What DmdAnal sees: sumIO 0 z s = z `seq` (# s, z #) +sumIO n !z = sumIO (n-1) (z+n) +``` +We really want 'z' to unbox here. Yet its use in the returned unboxed pair +is fundamentally a Boxed one! CPR would manage to unbox it, but DmdAnal runs +before that. There is an Unboxed use in the recursive call to 'go' though. +But 'IO Int' returns a small product, and 'Int' is a small product itself. +So we'll put the RHS of 'sumIO' under sub-demand '!P(L,L!P(L))', indicating that +*if* we evaluate 'z', we don't need the box later on. And indeed the bang will +evaluate `z`, so we conclude with a total demand of `1!P(L)` on `z` and unbox +it. + +Unlike for recursive functions, where we can often speed up the loop by +unboxing at the cost of a bit of reboxing in the base case, the wins for +non-recursive functions quickly turn into losses when unboxing too deeply. +That happens in T11545, T18109 and T18174. Therefore, we deeply unbox recursive +function bodies but only shallowly unbox non-recursive function bodies (governed +by the max_depth variable). + +The implementation is in 'GHC.Core.Opt.DmdAnal.unboxWhenSmall'. It is quite +vital, guarding for regressions in test cases like #2387, #3586, #16040, #5075 +and #19871. + +Note that this is fundamentally working around a phase problem, namely that the +results of boxity analysis depend on CPR analysis (and vice versa, of course). + +Note [unboxedWins] +~~~~~~~~~~~~~~~~~~ +We used to use '_unboxedWins' below in 'lubBoxity', which was too optimistic. + +While it worked around some shortcomings of the phase separation between Boxity +analysis and CPR analysis, it was a gross hack which caused regressions itself +that needed all kinds of fixes and workarounds. Examples (from #21119): + + * As #20767 says, L and B were no longer top and bottom of our lattice + * In #20746 we unboxed huge Handle types that were never needed boxed in the + first place. See Note [deferAfterPreciseException]. + * It also caused unboxing of huge records where we better shouldn't, for + example in T19871.absent. + * It became impossible to work with when implementing !7599, mostly due to the + chaos that results from #20767. + +Conclusion: We should use 'boxedWins' in 'lubBoxity', #21119. +Fortunately, we could come up with a number of better mechanisms to make up for +the sometimes huge regressions that would have otherwise incured: + +1. A beefed up Note [Unboxed demand on function bodies returning small products] + that works recursively fixes most regressions. It's a bit unsound, but + pretty well-behaved. +2. We saw bottoming functions spoil boxity in some less severe cases and + countered that with Note [Boxity for bottoming functions]. + +-} + +boxedWins :: Boxity -> Boxity -> Boxity +boxedWins Unboxed Unboxed = Unboxed +boxedWins _ !_ = Boxed + +_unboxedWins :: Boxity -> Boxity -> Boxity +-- See Note [unboxedWins] +_unboxedWins Boxed Boxed = Boxed +_unboxedWins _ !_ = Unboxed + +lubBoxity :: Boxity -> Boxity -> Boxity +-- See Note [Boxity analysis] for the lattice. +lubBoxity = boxedWins + +{- +************************************************************************ +* * + Card: Combining Strictness and Usage +* * +************************************************************************ +-} + +{- Note [Evaluation cardinalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand analyser uses an (abstraction of) /evaluation cardinality/ of type +Card, to specify how many times a term is evaluated. A Card C_lu +represents an /interval/ of possible cardinalities [l..u], meaning + +* Evaluated /at least/ 'l' times (strictness). + Hence 'l' is either 0 (lazy) + or 1 (strict) + +* Evaluated /at most/ 'u' times (usage). + Hence 'u' is either 0 (not used at all), + or 1 (used at most once) + or n (no information) + +Intervals describe sets, so the underlying lattice is the powerset lattice. + +Usually l<=u, but we also have C_10, the interval [1,0], the empty interval, +denoting the empty set. This is the bottom element of the lattice. + +See Note [Demand notation] for the notation we use for each of the constructors. + +Note [Bit vector representation for Card] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While the 6 inhabitants of Card admit an efficient representation as an +enumeration, implementing operations such as lubCard, plusCard and multCard +leads to unreasonably bloated code. This was the old defn for lubCard, for +example: + + -- Handle C_10 (bot) + lubCard C_10 n = n -- bot + lubCard n C_10 = n -- bot + -- Handle C_0N (top) + lubCard C_0N _ = C_0N -- top + lubCard _ C_0N = C_0N -- top + -- Handle C_11 + lubCard C_00 C_11 = C_01 -- {0} ∪ {1} = {0,1} + lubCard C_11 C_00 = C_01 -- {0} ∪ {1} = {0,1} + lubCard C_11 n = n -- {1} is a subset of all other intervals + lubCard n C_11 = n -- {1} is a subset of all other intervals + -- Handle C_1N + lubCard C_1N C_1N = C_1N -- reflexivity + lubCard _ C_1N = C_0N -- {0} ∪ {1,n} = top + lubCard C_1N _ = C_0N -- {0} ∪ {1,n} = top + -- Handle C_01 + lubCard C_01 _ = C_01 -- {0} ∪ {0,1} = {0,1} + lubCard _ C_01 = C_01 -- {0} ∪ {0,1} = {0,1} + -- Handle C_00 + lubCard C_00 C_00 = C_00 -- reflexivity + +There's a much more compact way to encode these operations if Card is +represented not as distinctly denoted intervals, but as the subset of the set +of all cardinalities {0,1,n} instead. We represent such a subset as a bit vector +of length 3 (which fits in an Int). That's actually pretty common for such +powerset lattices. +There's one bit per denoted cardinality that is set iff that cardinality is part +of the denoted set, with n being the most significand bit (index 2) and 0 being +represented by the least significand bit (index 0). + +How does that help? Well, for one, lubCard just becomes + + lubCard (Card a) (Card b) = Card (a .|. b) + +The other operations, 'plusCard' and 'multCard', become significantly more +tricky, but immensely more compact. It's all straight-line code with a few bit +twiddling instructions now! + +Note [Algebraic specification for plusCard and multCard] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The representation change in Note [Bit vector representation for Card] admits +very dense definitions of 'plusCard' and 'multCard' in terms of bit twiddling, +but the connection to the algebraic operations they implement is lost. +It's helpful to have a written specification of what 'plusCard' and 'multCard' +here that says what they should compute. + + * plusCard: a@[l1,u1] + b@[l2,u2] = r@[l1+l2,u1+u2]. + - In terms of sets, 0 ∈ r iff 0 ∈ a and 0 ∈ b. + Examples: set in C_00 + C_00, C_01 + C_0N, but not in C_10 + C_00 + - In terms of sets, 1 ∈ r iff 1 ∈ a or 1 ∈ b. + Examples: set in C_01 + C_00, C_0N + C_0N, but not in C_10 + C_00 + - In terms of sets, n ∈ r iff n ∈ a or n ∈ b, or (1 ∈ a and 1 ∈ b), + so not unlike add with carry. + Examples: set in C_01 + C_01, C_01 + C_0N, but not in C_10 + C_01 + - Handy special cases: + o 'plusCard C_10' bumps up the strictness of its argument, just like + 'lubCard C_00' lazifies it, without touching upper bounds. + See also 'strictifyCard' + o Similarly, 'plusCard C_0N' discards usage information + (incl. absence) but leaves strictness alone. + + * multCard: a@[l1,u1] * b@[l2,u2] = r@[l1*l2,u1*u2]. + - In terms of sets, 0 ∈ r iff 0 ∈ a or 0 ∈ b. + Examples: set in C_00 * C_10, C_01 * C_1N, but not in C_10 * C_1N + - In terms of sets, 1 ∈ r iff 1 ∈ a and 1 ∈ b. + Examples: set in C_01 * C_01, C_01 * C_1N, but not in C_11 * C_10 + - In terms of sets, n ∈ r iff 1 ∈ r and (n ∈ a or n ∈ b). + Examples: set in C_1N * C_01, C_1N * C_0N, but not in C_10 * C_1N + - Handy special cases: + o 'multCard C_1N c' is the same as 'plusCard c c' and + drops used-once info. But unlike 'plusCard C_0N', it leaves absence + and strictness. + o 'multCard C_01' drops strictness info, like 'lubCard C_00'. + o 'multCard C_0N' does both; it discards all strictness and used-once + info and retains only absence info. +-} + + +-- | Describes an interval of /evaluation cardinalities/. +-- See Note [Evaluation cardinalities] +-- See Note [Bit vector representation for Card] +newtype Card = Card Int + deriving Eq + +-- | A subtype of 'Card' for which the upper bound is never 0 (no 'C_00' or +-- 'C_10'). The only four inhabitants are 'C_01', 'C_0N', 'C_11', 'C_1N'. +-- Membership can be tested with 'isCardNonAbs'. +-- See 'D' and 'Call' for use sites and explanation. +type CardNonAbs = Card + +-- | A subtype of 'Card' for which the upper bound is never 1 (no 'C_01' or +-- 'C_11'). The only four inhabitants are 'C_00', 'C_0N', 'C_10', 'C_1N'. +-- Membership can be tested with 'isCardNonOnce'. +-- See 'Poly' for use sites and explanation. +type CardNonOnce = Card + +-- | Absent, {0}. Pretty-printed as A. +pattern C_00 :: Card +pattern C_00 = Card 0b001 +-- | Bottom, {}. Pretty-printed as A. +pattern C_10 :: Card +pattern C_10 = Card 0b000 +-- | Strict and used once, {1}. Pretty-printed as 1. +pattern C_11 :: Card +pattern C_11 = Card 0b010 +-- | Used at most once, {0,1}. Pretty-printed as M. +pattern C_01 :: Card +pattern C_01 = Card 0b011 +-- | Strict and used (possibly) many times, {1,n}. Pretty-printed as S. +pattern C_1N :: Card +pattern C_1N = Card 0b110 +-- | Every possible cardinality; the top element, {0,1,n}. Pretty-printed as L. +pattern C_0N :: Card +pattern C_0N = Card 0b111 + +{-# COMPLETE C_00, C_01, C_0N, C_10, C_11, C_1N :: Card #-} + +_botCard, topCard :: Card +_botCard = C_10 +topCard = C_0N + +-- | True <=> lower bound is 1. +isStrict :: Card -> Bool +-- See Note [Bit vector representation for Card] +isStrict (Card c) = c .&. 0b001 == 0 -- simply check 0 bit is not set + +-- | True <=> upper bound is 0. +isAbs :: Card -> Bool +-- See Note [Bit vector representation for Card] +isAbs (Card c) = c .&. 0b110 == 0 -- simply check 1 and n bit are not set + +-- | True <=> upper bound is 1. +isAtMostOnce :: Card -> Bool +-- See Note [Bit vector representation for Card] +isAtMostOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set + +-- | Is this a 'CardNonAbs'? +isCardNonAbs :: Card -> Bool +isCardNonAbs = not . isAbs + +-- | Is this a 'CardNonOnce'? +isCardNonOnce :: Card -> Bool +isCardNonOnce n = isAbs n || not (isAtMostOnce n) + +-- | Intersect with [0,1]. +oneifyCard :: Card -> Card +oneifyCard = glbCard C_01 + +-- | Intersect with [1,n]. The same as @'plusCard' 'C_10'@. +strictifyCard :: Card -> Card +strictifyCard = glbCard C_1N + +-- | Denotes '∪' on 'Card'. +lubCard :: Card -> Card -> Card +-- See Note [Bit vector representation for Card] +lubCard (Card a) (Card b) = Card (a .|. b) -- main point of the bit-vector encoding! + +-- | Denotes '∩' on 'Card'. +glbCard :: Card -> Card -> Card +-- See Note [Bit vector representation for Card] +glbCard (Card a) (Card b) = Card (a .&. b) + +-- | Denotes '+' on lower and upper bounds of 'Card'. +plusCard :: Card -> Card -> Card +-- See Note [Algebraic specification for plusCard and multCard] +plusCard (Card a) (Card b) + = Card (bit0 .|. bit1 .|. bitN) + where + bit0 = (a .&. b) .&. 0b001 + bit1 = (a .|. b) .&. 0b010 + bitN = ((a .|. b) .|. shiftL (a .&. b) 1) .&. 0b100 + +-- | Denotes '*' on lower and upper bounds of 'Card'. +multCard :: Card -> Card -> Card +-- See Note [Algebraic specification for plusCard and multCard] +multCard (Card a) (Card b) + = Card (bit0 .|. bit1 .|. bitN) + where + bit0 = (a .|. b) .&. 0b001 + bit1 = (a .&. b) .&. 0b010 + bitN = (a .|. b) .&. shiftL bit1 1 .&. 0b100 + +{- +************************************************************************ +* * + Demand: Evaluation contexts +* * +************************************************************************ +-} + +-- | A demand describes +-- +-- * How many times a variable is evaluated, via a 'Card'inality, and +-- * How deep its value was evaluated in turn, via a 'SubDemand'. +-- +-- See also Note [Demand notation] +-- and Note [Demand examples]. +-- +-- This data type is quite similar to `'Scaled' 'SubDemand'`, but it's scaled +-- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of +-- which could be used to infer uniqueness types. Also we treat 'AbsDmd' and +-- 'BotDmd' specially, as the concept of a 'SubDemand' doesn't apply when there +-- isn't any evaluation at all. If you don't care, simply use '(:*)'. +data Demand + = BotDmd + -- ^ A bottoming demand, produced by a diverging function ('C_10'), hence there is no + -- 'SubDemand' that describes how it was evaluated. + + | AbsDmd + -- ^ An absent demand: Evaluated exactly 0 times ('C_00'), hence there is no + -- 'SubDemand' that describes how it was evaluated. + + | D !CardNonAbs !SubDemand + -- ^ Don't use this internal data constructor; use '(:*)' instead. + -- Since BotDmd deals with 'C_10' and AbsDmd deals with 'C_00', the + -- cardinality component is CardNonAbs + deriving Eq + +-- | Only meant to be used in the pattern synonym below! +viewDmdPair :: Demand -> (Card, SubDemand) +viewDmdPair BotDmd = (C_10, botSubDmd) +viewDmdPair AbsDmd = (C_00, botSubDmd) +viewDmdPair (D n sd) = (n, sd) + +-- | @c :* sd@ is a demand that says \"evaluated @c@ times, and any trace in +-- which it is evaluated will evaluate at least as deep as @sd@\". +-- +-- Matching on this pattern synonym is a complete match. +-- If the matched demand was 'AbsDmd', it will match as @C_00 :* seqSubDmd@. +-- If the matched demand was 'BotDmd', it will match as @C_10 :* botSubDmd@. +-- The builder of this pattern synonym simply /discards/ the 'SubDemand' if the +-- 'Card' was absent and returns 'AbsDmd' or 'BotDmd' instead. It will assert +-- that the discarded sub-demand was 'seqSubDmd' and 'botSubDmd', respectively. +-- +-- Call sites should consider whether they really want to look at the +-- 'SubDemand' of an absent demand and match on 'AbsDmd' and/or 'BotDmd' +-- otherwise. Really, any other 'SubDemand' would be allowed and +-- might work better, depending on context. +pattern (:*) :: HasDebugCallStack => Card -> SubDemand -> Demand +pattern n :* sd <- (viewDmdPair -> (n, sd)) where + C_10 :* sd = BotDmd & assertPpr (sd == botSubDmd) (text "B /=" <+> ppr sd) + C_00 :* sd = AbsDmd & assertPpr (sd == botSubDmd) (text "A /=" <+> ppr sd) + n :* sd = D n sd & assertPpr (isCardNonAbs n) (ppr n $$ ppr sd) +{-# COMPLETE (:*) #-} + +-- | A sub-demand describes an /evaluation context/ (in the sense of an +-- operational semantics), e.g. how deep the denoted thing is going to be +-- evaluated. See 'Demand' for examples. +-- +-- See Note [SubDemand denotes at least one evaluation] for a more detailed +-- description of what a sub-demand means. +-- +-- See Note [Demand notation] for the extensively used short-hand notation. +-- See also Note [Why Boxity in SubDemand and not in Demand?]. +data SubDemand + = Poly !Boxity !CardNonOnce + -- ^ Polymorphic demand, the denoted thing is evaluated arbitrarily deep, + -- with the specified cardinality at every level. The 'Boxity' applies only + -- to the outer evaluation context as well as all inner evaluation context. + -- See Note [Boxity in Poly] for why we want it to carry 'Boxity'. + -- Expands to 'Call' via 'viewCall' and to 'Prod' via 'viewProd'. + -- + -- @Poly b n@ is semantically equivalent to @Prod b [n :* Poly b n, ...] + -- or @Call n (Poly Boxed n)@. 'viewCall' and 'viewProd' do these rewrites. + -- + -- In Note [Demand notation]: @L === P(L,L,...)@ and @L === C(L)@, + -- @B === P(B,B,...)@ and @B === C(B)@, + -- @!A === !P(A,A,...)@ and @!A === C(A)@, + -- and so on. + -- + -- We'll only see 'Poly' with 'C_10' (B), 'C_00' (A), 'C_0N' (L) and sometimes + -- 'C_1N' (S) through 'plusSubDmd', never 'C_01' (M) or 'C_11' (1) (grep the + -- source code). Hence 'CardNonOnce', which is closed under 'lub' and 'plus'. + -- + -- Why doesn't this constructor simply carry a 'Demand' instead of its fields? + -- See Note [Call SubDemand vs. evaluation Demand]. + | Call !CardNonAbs !SubDemand + -- ^ @Call n sd@ describes the evaluation context of @n@ function + -- applications (with one argument), where the result of each call is + -- evaluated according to @sd@. + -- @sd@ describes program traces in which the denoted thing was called at all, + -- see Note [SubDemand denotes at least one evaluation]. + -- That Note also explains why it doesn't make sense for @n@ to be absent, + -- hence we forbid it with 'CardNonAbs'. Absent call demands can still be + -- expressed with 'Poly'. + -- Used only for values of function type. Use the smart constructor 'mkCall' + -- whenever possible! + | Prod !Boxity ![Demand] + -- ^ @Prod b ds@ describes the evaluation context of a case scrutinisation + -- on an expression of product type, where the product components are + -- evaluated according to @ds@. The 'Boxity' @b@ says whether or not the box + -- of the product was used. + +-- | We have to respect Poly rewrites through 'viewCall' and 'viewProd'. +instance Eq SubDemand where + d1 == d2 = case d1 of + Prod b1 ds1 + | Just (b2, ds2) <- viewProd (length ds1) d2 -> b1 == b2 && ds1 == ds2 + Call n1 sd1 + | Just (n2, sd2) <- viewCall d2 -> n1 == n2 && sd1 == sd2 + Poly b1 n1 + | Poly b2 n2 <- d2 -> b1 == b2 && n1 == n2 + _ -> False + +topSubDmd, botSubDmd, seqSubDmd :: SubDemand +topSubDmd = Poly Boxed C_0N +botSubDmd = Poly Unboxed C_10 +seqSubDmd = Poly Unboxed C_00 + +-- | The uniform field demand when viewing a 'Poly' as a 'Prod', as in +-- 'viewProd'. +polyFieldDmd :: Boxity -> CardNonOnce -> Demand +polyFieldDmd _ C_00 = AbsDmd +polyFieldDmd _ C_10 = BotDmd +polyFieldDmd Boxed C_0N = topDmd +polyFieldDmd b n = n :* Poly b n & assertPpr (isCardNonOnce n) (ppr n) + +-- | A smart constructor for 'Prod', applying rewrite rules along the semantic +-- equality @Prod b [n :* Poly Boxed n, ...] === Poly b n@, simplifying to +-- 'Poly' 'SubDemand's when possible. Examples: +-- +-- * Rewrites @P(L,L)@ (e.g., arguments @Boxed@, @[L,L]@) to @L@ +-- * Rewrites @!P(L!L,L!L)@ (e.g., arguments @Unboxed@, @[L!L,L!L]@) to @!L@ +-- * Does not rewrite @P(1L)@, @P(L!L)@, @!P(L)@ or @P(L,A)@ +-- +mkProd :: Boxity -> [Demand] -> SubDemand +mkProd b ds + | all (== AbsDmd) ds = Poly b C_00 + | all (== BotDmd) ds = Poly b C_10 + | dmd@(n :* Poly b2 m):_ <- ds + , n == m -- don't rewrite P(SL) to S + , b == b2 -- don't rewrite P(S!S) to !S + , all (== dmd) ds -- don't rewrite P(L,A) to L + = Poly b n + | otherwise = Prod b ds + +-- | @viewProd n sd@ interprets @sd@ as a 'Prod' of arity @n@, expanding 'Poly' +-- demands as necessary. +viewProd :: Arity -> SubDemand -> Maybe (Boxity, [Demand]) +-- It's quite important that this function is optimised well; +-- it is used by lubSubDmd and plusSubDmd. +viewProd n (Prod b ds) + | ds `lengthIs` n = Just (b, ds) +-- Note the strict application to replicate: This makes sure we don't allocate +-- a thunk for it, inlines it and lets case-of-case fire at call sites. +viewProd n (Poly b card) + | let !ds = replicate n $! polyFieldDmd b card + = Just (b, ds) +viewProd _ _ + = Nothing +{-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation + -- for Arity. Otherwise, #18304 bites us. + +-- | A smart constructor for 'Call', applying rewrite rules along the semantic +-- equality @Call C_0N (Poly C_0N) === Poly C_0N@, simplifying to 'Poly' 'SubDemand's +-- when possible. +mkCall :: CardNonAbs -> SubDemand -> SubDemand +--mkCall C_1N sd@(Poly Boxed C_1N) = sd -- NO! #21085 strikes. See Note [mkCall and plusSubDmd] +mkCall C_0N sd@(Poly Boxed C_0N) = sd +mkCall n sd = assertPpr (isCardNonAbs n) (ppr n $$ ppr sd) $ + Call n sd + +-- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' subdemands as +-- necessary. +viewCall :: SubDemand -> Maybe (Card, SubDemand) +viewCall (Call n sd) = Just (n :: Card, sd) +viewCall (Poly _ n) + | isAbs n = Just (n :: Card, botSubDmd) + | otherwise = Just (n :: Card, Poly Boxed n) +viewCall _ = Nothing + +topDmd, absDmd, botDmd, seqDmd :: Demand +topDmd = C_0N :* topSubDmd +absDmd = AbsDmd +botDmd = BotDmd +seqDmd = C_11 :* seqSubDmd + +-- | Sets 'Boxity' to 'Unboxed' for non-'Call' sub-demands and recurses into 'Prod'. +unboxDeeplySubDmd :: SubDemand -> SubDemand +unboxDeeplySubDmd (Poly _ n) = Poly Unboxed n +unboxDeeplySubDmd (Prod _ ds) = mkProd Unboxed (strictMap unboxDeeplyDmd ds) +unboxDeeplySubDmd call@Call{} = call + +-- | Sets 'Boxity' to 'Unboxed' for the 'Demand', recursing into 'Prod's. +-- Don't recurse into lazy arguments; see GHC.Core.Opt.DmdAnal +-- Note [No lazy, Unboxed demands in demand signature] +unboxDeeplyDmd :: Demand -> Demand +unboxDeeplyDmd AbsDmd = AbsDmd +unboxDeeplyDmd BotDmd = BotDmd +unboxDeeplyDmd dmd@(D n sd) | isStrict n = D n (unboxDeeplySubDmd sd) + | otherwise = dmd + + +multDmd :: Card -> Demand -> Demand +multDmd C_11 dmd = dmd -- An optimisation +-- The following four lines make sure that we rewrite to AbsDmd and BotDmd +-- whenever the leading cardinality is absent (C_00 or C_10). +-- Otherwise it may happen that the SubDemand is not 'botSubDmd', triggering +-- the assertion in `:*`. +-- Example: `multDmd B 1L = BA`, so with an inner `seqSubDmd`. Our lattice +-- allows us to always rewrite this to proper BotDmd and we maintain the +-- invariant that this is indeed the case. +multDmd C_00 _ = AbsDmd +multDmd _ AbsDmd = AbsDmd +multDmd C_10 (D n _) = if isStrict n then BotDmd else AbsDmd +multDmd n BotDmd = if isStrict n then BotDmd else AbsDmd +-- See Note [SubDemand denotes at least one evaluation] for the strictifyCard +multDmd n (D m sd) = multCard n m :* multSubDmd (strictifyCard n) sd + +multSubDmd :: Card -> SubDemand -> SubDemand +multSubDmd C_11 sd = sd -- An optimisation, for when sd is a deep Prod +-- The following three equations don't have an impact on Demands, only on +-- Boxity. They are needed so that we don't trigger the assertions in `:*` +-- when called from `multDmd`. +multSubDmd C_00 _ = seqSubDmd -- Otherwise `multSubDmd A L == A /= !A` +multSubDmd C_10 (Poly _ n) = if isStrict n then botSubDmd else seqSubDmd -- Otherwise `multSubDmd B L == B /= !B` +multSubDmd C_10 (Call n _) = if isStrict n then botSubDmd else seqSubDmd -- Otherwise we'd call `mkCall` with absent cardinality +multSubDmd n (Poly b m) = Poly b (multCard n m) +multSubDmd n (Call n' sd) = mkCall (multCard n n') sd +multSubDmd n (Prod b ds) = mkProd b (strictMap (multDmd n) ds) + +lazifyIfStrict :: Card -> SubDemand -> SubDemand +lazifyIfStrict n sd = multSubDmd (glbCard C_01 n) sd + +-- | Denotes '∪' on 'Demand'. +lubDmd :: Demand -> Demand -> Demand +lubDmd BotDmd dmd2 = dmd2 +lubDmd dmd1 BotDmd = dmd1 +lubDmd (n1 :* sd1) (n2 :* sd2) = -- pprTraceWith "lubDmd" (\it -> ppr (n1:*sd1) $$ ppr (n2:*sd2) $$ ppr it) $ + lubCard n1 n2 :* lubSubDmd sd1 sd2 + +lubSubDmd :: SubDemand -> SubDemand -> SubDemand +-- Shortcuts for neutral and absorbing elements. +-- Below we assume that Boxed always wins. +lubSubDmd (Poly Unboxed C_10) sd = sd +lubSubDmd sd (Poly Unboxed C_10) = sd +lubSubDmd sd@(Poly Boxed C_0N) _ = sd +lubSubDmd _ sd@(Poly Boxed C_0N) = sd +-- Handle Prod +lubSubDmd (Prod b1 ds1) (Poly b2 n2) + | let !d = polyFieldDmd b2 n2 + = mkProd (lubBoxity b1 b2) (strictMap (lubDmd d) ds1) +lubSubDmd (Prod b1 ds1) (Prod b2 ds2) + | equalLength ds1 ds2 + = mkProd (lubBoxity b1 b2) (strictZipWith lubDmd ds1 ds2) +-- Handle Call +lubSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) = + mkCall (lubCard n1 n2) (lubSubDmd sd1 sd2) +-- Handle Poly +lubSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubCard n1 n2) +-- Other Poly case by commutativity +lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1 +-- Otherwise (Call `lub` Prod) return Top +lubSubDmd _ _ = topSubDmd + +-- | Denotes '+' on 'Demand'. +plusDmd :: Demand -> Demand -> Demand +plusDmd AbsDmd dmd2 = dmd2 +plusDmd dmd1 AbsDmd = dmd1 +plusDmd (n1 :* sd1) (n2 :* sd2) = -- pprTraceWith "plusDmd" (\it -> ppr (n1:*sd1) $$ ppr (n2:*sd2) $$ ppr it) $ + -- Why lazify? See Note [SubDemand denotes at least one evaluation] + -- and also Note [Unrealised opportunity in plusDmd] which applies when both + -- n1 and n2 are lazy already + plusCard n1 n2 :* plusSubDmd (lazifyIfStrict n1 sd1) (lazifyIfStrict n2 sd2) + +plusSubDmd :: SubDemand -> SubDemand -> SubDemand +-- Shortcuts for neutral and absorbing elements. +-- Below we assume that Boxed always wins. +plusSubDmd (Poly Unboxed C_00) sd = sd +plusSubDmd sd (Poly Unboxed C_00) = sd +plusSubDmd sd@(Poly Boxed C_1N) _ = sd +plusSubDmd _ sd@(Poly Boxed C_1N) = sd +-- Handle Prod +plusSubDmd (Prod b1 ds1) (Poly b2 n2) + | let !d = polyFieldDmd b2 n2 + = mkProd (lubBoxity b1 b2) (strictMap (plusDmd d) ds1) +plusSubDmd (Prod b1 ds1) (Prod b2 ds2) + | equalLength ds1 ds2 + = mkProd (lubBoxity b1 b2) (strictZipWith plusDmd ds1 ds2) +-- Handle Call +plusSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) = + mkCall (plusCard n1 n2) (lubSubDmd sd1 sd2) +-- Handle Poly +plusSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (plusCard n1 n2) +-- Other Poly case by commutativity +plusSubDmd sd1@Poly{} sd2 = plusSubDmd sd2 sd1 +-- Otherwise (Call `plus` Prod) return Top +plusSubDmd _ _ = topSubDmd + +-- | Used to suppress pretty-printing of an uninformative demand +isTopDmd :: Demand -> Bool +isTopDmd dmd = dmd == topDmd + +isAbsDmd :: Demand -> Bool +isAbsDmd (n :* _) = isAbs n + +-- | Contrast with isStrictUsedDmd. See Note [Strict demands] +isStrictDmd :: Demand -> Bool +isStrictDmd (n :* _) = isStrict n + +-- | Not absent and used strictly. See Note [Strict demands] +isStrUsedDmd :: Demand -> Bool +isStrUsedDmd (n :* _) = isStrict n && not (isAbs n) + +-- | Is the value used at most once? +isAtMostOnceDmd :: Demand -> Bool +isAtMostOnceDmd (n :* _) = isAtMostOnce n + +-- | We try to avoid tracking weak free variable demands in strictness +-- signatures for analysis performance reasons. +-- See Note [Lazy and unleashable free variables] in "GHC.Core.Opt.DmdAnal". +isWeakDmd :: Demand -> Bool +isWeakDmd dmd@(n :* _) = not (isStrict n) && is_plus_idem_dmd dmd + where + -- @is_plus_idem_* thing@ checks whether @thing `plus` thing = thing@, + -- e.g. if @thing@ is idempotent wrt. to @plus@. + -- is_plus_idem_card n = plusCard n n == n + is_plus_idem_card = isCardNonOnce + -- is_plus_idem_dmd dmd = plusDmd dmd dmd == dmd + is_plus_idem_dmd AbsDmd = True + is_plus_idem_dmd BotDmd = True + is_plus_idem_dmd (n :* sd) = is_plus_idem_card n && is_plus_idem_sub_dmd sd + -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd + is_plus_idem_sub_dmd (Poly _ n) = assert (isCardNonOnce n) True + is_plus_idem_sub_dmd (Prod _ ds) = all is_plus_idem_dmd ds + is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n + +evalDmd :: Demand +evalDmd = C_1N :* topSubDmd + +-- | First argument of 'GHC.Exts.maskAsyncExceptions#': @1C(1,L)@. +-- Called exactly once. +strictOnceApply1Dmd :: Demand +strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd + +-- | First argument of 'GHC.Exts.atomically#': @SC(S,L)@. +-- Called at least once, possibly many times. +strictManyApply1Dmd :: Demand +strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd + +-- | First argument of catch#: @MC(1,L)@. +-- Evaluates its arg lazily, but then applies it exactly once to one argument. +lazyApply1Dmd :: Demand +lazyApply1Dmd = C_01 :* mkCall C_11 topSubDmd + +-- | Second argument of catch#: @MC(1,C(1,L))@. +-- Evaluates its arg lazily, but then applies it exactly once to two arguments. +lazyApply2Dmd :: Demand +lazyApply2Dmd = C_01 :* mkCall C_11 (mkCall C_11 topSubDmd) + +-- | Make a 'Demand' evaluated at-most-once. +oneifyDmd :: Demand -> Demand +oneifyDmd AbsDmd = AbsDmd +oneifyDmd BotDmd = BotDmd +oneifyDmd (n :* sd) = oneifyCard n :* sd + +-- | Make a 'Demand' evaluated at-least-once (e.g. strict). +strictifyDmd :: Demand -> Demand +strictifyDmd = plusDmd seqDmd + +-- | If the argument is a guaranteed-terminating type +-- (i.e. a non-newtype dictionary) give it strict demand. +-- This is sound because terminating types can't be bottom: +-- See GHC.Core Note [NON-BOTTOM-DICTS invariant] +-- Also split the product type & demand and recur in order to similarly +-- strictify the argument's contained used non-newtype superclass dictionaries. +-- We use the demand as our recursive measure to guarantee termination. +strictifyDictDmd :: Type -> Demand -> Demand +strictifyDictDmd ty (n :* Prod b ds) + | not (isAbs n) + , isTerminatingType ty + , Just (_tc, _arg_tys, _data_con, field_tys) <- splitDataProductType_maybe ty + = C_1N :* mkProd b (zipWith strictifyDictDmd (map scaledThing field_tys) ds) + -- main idea: ensure it's strict +strictifyDictDmd _ dmd = dmd + +-- | Make a 'Demand' lazy. +lazifyDmd :: Demand -> Demand +lazifyDmd = multDmd C_01 + +-- | Adjust the demand on a binding that may float outwards +-- See Note [Floatifying demand info when floating] +floatifyDmd :: Demand -> Demand +floatifyDmd = multDmd C_0N + +-- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C(1,d)@. +mkCalledOnceDmd :: SubDemand -> SubDemand +mkCalledOnceDmd sd = mkCall C_11 sd + +-- | @mkCalledOnceDmds n d@ returns @C(1,C1...C(1,d))@ where there are @n@ @C1@'s. +mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand +mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity + +-- | Peels one call level from the sub-demand, and also returns how many +-- times we entered the lambda body. +peelCallDmd :: SubDemand -> (Card, SubDemand) +peelCallDmd sd = viewCall sd `orElse` (topCard, topSubDmd) + +-- Peels multiple nestings of 'Call' sub-demands and also returns +-- whether it was unsaturated in the form of a 'Card'inality, denoting +-- how many times the lambda body was entered. +-- See Note [Demands from unsaturated function calls]. +peelManyCalls :: Arity -> SubDemand -> (Card, SubDemand) +peelManyCalls k sd = go k C_11 sd + where + go 0 !n !sd = (n, sd) + go k !n (viewCall -> Just (m, sd)) = go (k-1) (n `multCard` m) sd + go _ _ _ = (topCard, topSubDmd) +{-# INLINE peelManyCalls #-} -- so that the pair cancels away in a `fst _` context + +strictCallArity :: SubDemand -> Arity +strictCallArity sd = go 0 sd + where + go n (Call card sd) | isStrict card = go (n+1) sd + go n _ = n + +-- | Extract the 'SubDemand' of a 'Demand'. +-- PRECONDITION: The SubDemand must be used in a context where the expression +-- denoted by the Demand is under evaluation. +subDemandIfEvaluated :: Demand -> SubDemand +subDemandIfEvaluated (_ :* sd) = sd + +-- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap +mkWorkerDemand :: Int -> Demand +mkWorkerDemand n = C_01 :* go n + where go 0 = topSubDmd + go n = mkCall C_01 $ go (n-1) + +argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]] +-- ^ See Note [Computing one-shot info] +argsOneShots (DmdSig (DmdType _ arg_ds)) n_val_args + | unsaturated_call = [] + | otherwise = go arg_ds + where + unsaturated_call = arg_ds `lengthExceeds` n_val_args + + go [] = [] + go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds + + -- Avoid list tail like [ [], [], [] ] + cons [] [] = [] + cons a as = a:as + +argOneShots :: Demand -- ^ depending on saturation + -> [OneShotInfo] +-- ^ See Note [Computing one-shot info] +argOneShots AbsDmd = [] -- This defn conflicts with 'saturatedByOneShots', +argOneShots BotDmd = [] -- according to which we should return + -- @repeat OneShotLam@ here... +argOneShots (_ :* sd) = map go (callCards sd) + where + go n | isAtMostOnce n = OneShotLam + | otherwise = NoOneShotInfo + +-- | See Note [Computing one-shot info] +callCards :: SubDemand -> [Card] +callCards (Call n sd) = n : callCards sd +callCards (Poly _ _n) = [] -- n is never C_01 or C_11 so we may as well stop here +callCards Prod{} = [] + +-- | +-- @saturatedByOneShots n C(M,C(M,...)) = True@ +-- <=> +-- There are at least n nested C(M,..) calls. +-- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap +saturatedByOneShots :: Int -> Demand -> Bool +saturatedByOneShots _ AbsDmd = True +saturatedByOneShots _ BotDmd = True +saturatedByOneShots n (_ :* sd) = isAtMostOnce $ fst $ peelManyCalls n sd + +{- Note [Strict demands] +~~~~~~~~~~~~~~~~~~~~~~~~ +'isStrUsedDmd' returns true only of demands that are + both strict + and used + +In particular, it is False for (i.e. strict and not used, +cardinality C_10), which can and does arise in, say (#7319) + f x = raise# +Then 'x' is not used, so f gets strictness -> . +Now the w/w generates + fx = let x = absentError "unused" + in raise +At this point we really don't want to convert to + fx = case absentError "unused" of x -> raise +Since the program is going to diverge, this swaps one error for another, +but it's really a bad idea to *ever* evaluate an absent argument. +In #7319 we get + T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] + +Note [SubDemand denotes at least one evaluation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a demand `n :* sd` on a binding `let x = e in `. +(Similarly, a call sub-demand `Cn(sd)` on a lambda `\_. e`). +While `n` describes how *often* `x` had been evaluated in , +the sub-demand `sd` describes how *deep* `e` has been evaluated, under the +following + + PREMISE: *for all program traces where `x` had been evaluated at all* + +That is, `sd` disregards all program traces where `x` had not been evaluated, +because it can't describe the depth of an evaluation that never happened. +NB: The Premise only makes a difference for lower bounds/strictness. +Upper bounds/usage are unaffected by adding or leaving out evaluations that +never happen. + +The Premise comes into play when we have lazy Demands. For example, if `x` was +demanded with `LP(SL,A)`, so perhaps the full expression was + let x = (e1, e2) in (x `seq` fun y `seq` case x of (a,b) -> a, True) +then `x` will be evaluated lazily, but in any trace in which `x` is evaluated, +the pair in its RHS will ultimately be evaluated deeply with sub-demand +`P(SL,A)`. That means that `e1` is ultimately evaluated strictly, even though +evaluation of the field does not directly follow the eval of `x` due to the +intermittent call `fun y`. + +How does the additional strictness help? The long version is the list of +examples at the end of this Note (as procured in #21081 and #18903). +The short version is + + * We get to take advantage of call-by-value/let-to-case in more situations, + as for e1 above. See example "More let-to-case" below. + * Note [Eta reduction based on evaluation context] applies in more situations. + See example "More eta reduction" below. + * We get to unbox more results, see example "More CPR" below. + +It seems like we don't give up anything in return. Indeed that is the case: + + * If we dropped the Premise, then a lazy `n` in `nP(m..)` would always force + `m` to be lazy, too. That is quite redundant! It seems wasteful not to use + the lower bound of `m` for something more useful. So indeed we give up on + nothing in return for some nice wins. + * Even if `n` is absent (so the Premise does hold for no trace whatsoever), + it's pretty easy to describe how `e` was evaluated. Answer: 'botSubDmd'. + We use it when expanding 'Absent' and 'Bottom' demands in 'viewDmdPair' as + well as when expanding absent 'Poly's to 'Call' sub-demands in 'viewCall'. + +Of course, we now have to maintain the Premise when we unpack and rebuild +Demands. For strict demands, we know that the Premise indeed always holds for +any program trace abstracted over, whereas we have to be careful for lazy +demands. + +In particular, when doing `plusDmd` we have to *lazify* the nested SubDemand +if the outer cardinality is lazy. E.g., + LP(SL) + SP(L) = (L+S)P((M*SL)+L) = SP(L+L) = SP(L) +Multiplying with `M`/`C_01` is the "lazify" part here and is implemented in +`lazifyIfStrict`. Example proving that point: + d2 :: + d2 x y = y `seq` (case x of (a,b) -> a, True) + -- What is the demand on x in (d2 x x)? NOT SP(SL)!! + +We used to apply the same reasoning to Call SubDemands `Cn(sd)` in `plusSubDmd`, +but that led to #21717, because different calls return different heap objects. +See Note [Call SubDemand vs. evaluation Demand]. + +There are a couple more examples that improve in T21081. +Here is a selection of those examples demonstrating the usefulness of The +Premise: + + * "More let-to-case" (from testcase T21081): + ```hs + f :: (Bool, Bool) -> (Bool, Bool) + f pr = (case pr of (a,b) -> a /= b, True) + g :: Int -> (Bool, Bool) + g x = let y = let z = odd x in (z,z) in f y + ``` + Although `f` is lazy in `pr`, we could case-bind `z` because it is always + evaluated when `y` is evaluated. So we give `pr` demand `LP(SL,SL)` + (most likely with better upper bounds/usage) and demand analysis then + infers a strict demand for `z`. + + * "More eta reduction" (from testcase T21081): + ```hs + myfoldl :: (a -> b -> a) -> a -> [b] -> a + myfoldl f z [] = z + myfoldl f !z (x:xs) = myfoldl (\a b -> f a b) (f z x) xs + ``` + Here, we can give `f` a demand of `LC(S,C(1,L))` (instead of the lazier + `LC(L,C(1,L))`) which says "Whenever `f` is evaluated (lazily), it is also + called with two arguments". + And Note [Eta reduction based on evaluation context] means we can rewrite + `\a b -> f a b` to `f` in the call site of `myfoldl`. Nice! + + * "More CPR" (from testcase T18903): + ```hs + h :: Int -> Int + h m = + let g :: Int -> (Int,Int) + g 1 = (m, 0) + g n = (2 * n, 2 `div` n) + {-# NOINLINE g #-} + in case m of + 1 -> 0 + 2 -> snd (g m) + _ -> uncurry (+) (g m) + ``` + We want to give `g` the demand `MC(1,P(MP(L),1P(L)))`, so we see that in each + call site of `g`, we are strict in the second component of the returned + pair. That in turn means that Nested CPR can unbox the result of the + division even though it might throw. + +Note [Unrealised opportunity in plusDmd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall the lazification of SubDemands happening in `plusDmd` as described in +Note [SubDemand denotes at least one evaluation]. + +We *could* do better when both Demands are lazy already. Example + (fun 1, fun 2) +Both args put Demand SC(S,L) on `fun`. The lazy pair arg context lazifies +this to LC(S,L), and it would be reasonable to report this Demand on `fun` for +the entire pair expression; after all, `fun` is called whenever it is evaluated. +But our definition of `plusDmd` will compute + LC(S,L) + LC(S,L) = (L+L)(M*C(S,L) + M*C(S,L)) = L(C(L,L)) = L +Which is clearly less precise. +Doing better here could mean to `lub` when both demands are lazy, e.g., + LC(S,L) + LC(S,L) = (L+L)(C(S,L) ⊔ C(S,L)) = L(C(S,L)) +Indeed that's what we did at one point between 9.4 and 9.6 after !7599, but it +means that we need a function `lubPlusSubDmd` that lubs on lower bounds but +plus'es upper bounds, implying maintenance challenges and complicated +explanations. + +Plus, NoFib says that this special case doesn't bring all that much +(geom. mean +0.0% counted instructions), so we don't bother anymore. + +Note [Call SubDemand vs. evaluation Demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Although both evaluation Demands and Call SubDemands carry a (Card,SubDemand) +pair, their interpretation is quite different. Example: + + f x = fst x * snd x + -- f :: , because 1P(1L,A)+1P(A,1L) = SP(1L,1L) + g x = fst (x 1) * snd (x 2) + -- g :: , because 1C(1,P(1L,A))+1C(1,P(A,1L)) = SC(S,P(ML,ML)) + +The point about this example is that both demands have P(A,1L)/P(1L,A) as +sub-expressions, but when these sub-demands occur + + 1. under an evaluation demand, we combine with `plusSubDmd` + 2. whereas under a Call sub-demand, we combine with `lubSubDmd` + +And thus (1) yields a stricter demand on the pair components than (2). + +In #21717 we saw that we really need lub in (2), because otherwise we make an +unsound prediction in `g (\n -> if n == 1 then (1,1) else (bot,2))`; we'd say +that the `bot` expression is always evaluated, when it clearly is not. +Operationally, every call to `g` gives back a potentially distinct, +heap-allocated pair with potentially different contents, and we must `lubSubDmd` +over all such calls to approximate how any of those pairs might be used. + +That is in stark contrast to f's argument `x`: Operationally, every eval of +`x` must yield the same pair and `f` evaluates both components of that pair. +The theorem "every eval of `x` returns the same heap object" is a very strong +MUST-alias property and we capitalise on that by using `plusSubDmd` in (1). + +And indeed we *must* use `plusSubDmd` in (1) for sound upper bounds in an +analysis that assumes call-by-need (as opposed to the weaker call-by-name) for +let bindings. Consider + + h x = fst x * fst x + -- h :: + +And the expression `let a=1; p=(a,a)} in h p`. Here, *although* the RHS of `p` +is only evaluated once under call-by-need, `a` is still evaluated twice. +If we had used `lubSubDmd`, we'd see SP(1L,A) and the 1L unsoundly says "exactly +once". + +If the analysis had assumed call-by-name, it would be sound to say "a is used +once in p": p is used multiple times and hence so would a, as if p was a +function. So using `plusSubDmd` does not only yield better strictness, it is +also "holding up the other end of the bargain" of the call-by-need assumption +for upper bounds. + +(To SG's knowledge, the distinction between call-by-name and call-by-need does +not matter for strictness analysis/lower bounds, thus it would be sound to use +`lubSubDmd` all the time there.) + +Note [mkCall and plusSubDmd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never rewrite a strict, non-absent Call sub-demand like C(S,S) to a +polymorphic sub-demand like S, otherwise #21085 strikes. Consider the +following inequality (would also for M and 1 instead of L and S, but we forbid +such Polys): + + L+S = S = C(S,S) < C(S,L) = C(L,L)+C(S,S) + +Note that L=C(L,L). If we also had S=C(S,S), we'd be in trouble: Now +`plusSubDmd` would no longer maintain the equality relation on sub-demands, +much less monotonicity. Bad! + +Clearly, `n <= Cn(n)` is unproblematic, as is `n >= Cn(n)` for any `n` +except 1 and S. But `C(S,S) >= S` would mean trouble, because then we'd get +the problematic `C(S,S) = S`. We have just established that `S < C(S,S)`! +As such, the rewrite C(S,S) to S is anti-monotone and we forbid it, first +and foremost in `mkCall` (which is the only place that rewrites Cn(n) to n). + +Crisis and #21085 averted! + +Note [Computing one-shot info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a call + f (\pqr. e1) (\xyz. e2) e3 +where f has usage signature + +Then argsOneShots returns a [[OneShotInfo]] of + [[OneShot,NoOneShotInfo,OneShot], [OneShot]] +The occurrence analyser propagates this one-shot infor to the +binders \pqr and \xyz; +see Note [Sources of one-shot information] in GHC.Core.Opt.OccurAnal. + +Note [Boxity in Poly] +~~~~~~~~~~~~~~~~~~~~~ +To support Note [Boxity analysis], it makes sense that 'Prod' carries a +'Boxity'. But why does 'Poly' have to carry a 'Boxity', too? Shouldn't all +'Poly's be 'Boxed'? Couldn't we simply use 'Prod Unboxed' when we need to +express an unboxing demand? + +'botSubDmd' (B) needs to be the bottom of the lattice, so it needs to be an +Unboxed demand (and deeply, at that). Similarly, 'seqSubDmd' (A) is an Unboxed +demand. So why not say that Polys with absent cardinalities have Unboxed boxity? +That doesn't work, because we also need the boxed equivalents. Here's an example +for A (function 'absent' in T19871): +``` +f _ True = 1 +f a False = a `seq` 2 + -- demand on a: MA, the A is short for `Poly Boxed C_00` + +g a = a `seq` f a True + -- demand on a: SA, which is `Poly Boxed C_00` + +h True p = g p -- SA on p (inherited from g) +h False p@(x,y) = x+y -- S!P(1!L,1!L) on p +``` +If A is treated as Unboxed, we get reboxing in the call site to 'g'. +So we obviously would need a Boxed variant of A. Rather than introducing a lot +of special cases, we just carry the Boxity in 'Poly'. Plus, we could most likely +find examples like the above for any other cardinality. + +Note [Why Boxity in SubDemand and not in Demand?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #19871, we started out by storing 'Boxity' in 'SubDemand', in the 'Prod' +constructor only. But then we found that we weren't able to express the unboxing +'seqSubDmd', because that one really is a `Poly C_00` sub-demand. +We then tried to store the Boxity in 'Demand' instead, for these reasons: + + 1. The whole boxity-of-seq business comes to a satisfying conclusion + 2. Putting Boxity in the SubDemand is weird to begin with, because it + describes the box and not its fields, just as the evaluation cardinality + of a Demand describes how often the box is used. It makes more sense that + Card and Boxity travel together. Also the alternative would have been to + store Boxity with Poly, which is even weirder and more redundant. + +But then we regressed in T7837 (grep #19871 for boring specifics), which needed +to transfer an ambient unboxed *demand* on a dictionary selector to its argument +dictionary, via a 'Call' sub-demand `C(1,sd)`, as +Note [Demand transformer for a dictionary selector] explains. Annoyingly, +the boxity info has to be stored in the *sub-demand* `sd`! There's no demand +to store the boxity in. So we bit the bullet and now we store Boxity in +'SubDemand', both in 'Prod' *and* 'Poly'. See also Note [Boxity in Poly]. + +Note [Demand transformer for data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the expression (x,y) with sub-demand P(SL,A). What is the demand on +x,y? Obviously `x` is used strictly, and `y` not at all. So we want to +decompose a product demand, and feed its components demands into the +arguments. That is the job of dmdTransformDataConSig. More precisely, + + * it gets the demand on the data constructor itself; + in the above example that is C(1,C(1,P(SL,A))) + * it returns the demands on the arguments; + in the above example that is [SL, A] + +When the data constructor worker has strict fields, an additional seq +will be inserted for each field (see (SFC3) in Note [Strict fields in Core]). +Hence we add an additional `seqDmd` for each strict field to emulate +field eval insertion. + +For example, consider `data SP a b = MkSP !a !b` and expression `MkSP x y`, +with the same sub-demand P(SL,A). +The strict fields bump up the strictness; we'd get [SL,1!A] for the field +demands. Note that the first demand was unaffected by the seq, whereas +the second, previously absent demand became `seqDmd` exactly. +-} + +{- ********************************************************************* +* * + Divergence: Whether evaluation surely diverges +* * +********************************************************************* -} + +-- | 'Divergence' characterises whether something surely diverges. +-- Models a subset lattice of the following exhaustive set of divergence +-- results: +-- +-- [n] nontermination (e.g. loops) +-- [i] throws imprecise exception +-- [p] throws precise exception +-- [c] converges (reduces to WHNF). +-- +-- The different lattice elements correspond to different subsets, indicated by +-- juxtaposition of indicators (e.g. __nc__ definitely doesn't throw an +-- exception, and may or may not reduce to WHNF). +-- +-- @ +-- Dunno (nipc) +-- | +-- ExnOrDiv (nip) +-- | +-- Diverges (ni) +-- @ +-- +-- As you can see, we don't distinguish __n__ and __i__. +-- See Note [Precise exceptions and strictness analysis] for why __p__ is so +-- special compared to __i__. +data Divergence + = Diverges -- ^ Definitely throws an imprecise exception or diverges. + | ExnOrDiv -- ^ Definitely throws a *precise* exception, an imprecise + -- exception or diverges. Never converges, hence 'isDeadEndDiv'! + -- See scenario 1 in Note [Precise exceptions and strictness analysis]. + | Dunno -- ^ Might diverge, throw any kind of exception or converge. + deriving Eq + +lubDivergence :: Divergence -> Divergence -> Divergence +lubDivergence Diverges div = div +lubDivergence div Diverges = div +lubDivergence ExnOrDiv ExnOrDiv = ExnOrDiv +lubDivergence _ _ = Dunno +-- This needs to commute with defaultFvDmd, i.e. +-- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2 +-- (See Note [Default demand on free variables and arguments] for why) + +-- | See Note [Asymmetry of plusDmdType], which concludes that 'plusDivergence' +-- needs to be symmetric. +-- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@. +-- But that regresses in too many places (every infinite loop, basically) to be +-- worth it and is only relevant in higher-order scenarios +-- (e.g. Divergence of @f (throwIO blah)@). +-- So 'plusDivergence' currently is 'glbDivergence', really. +plusDivergence :: Divergence -> Divergence -> Divergence +plusDivergence Dunno Dunno = Dunno +plusDivergence Diverges _ = Diverges +plusDivergence _ Diverges = Diverges +plusDivergence _ _ = ExnOrDiv + +-- | In a non-strict scenario, we might not force the Divergence, in which case +-- we might converge, hence Dunno. +multDivergence :: Card -> Divergence -> Divergence +multDivergence n _ | not (isStrict n) = Dunno +multDivergence _ d = d + +topDiv, exnDiv, botDiv :: Divergence +topDiv = Dunno +exnDiv = ExnOrDiv +botDiv = Diverges + +-- | True if the 'Divergence' indicates that evaluation will not return. +-- See Note [Dead ends]. +isDeadEndDiv :: Divergence -> Bool +isDeadEndDiv Diverges = True +isDeadEndDiv ExnOrDiv = True +isDeadEndDiv Dunno = False + +-- See Notes [Default demand on free variables and arguments] +-- and Scenario 1 in [Precise exceptions and strictness analysis] +defaultFvDmd :: Divergence -> Demand +defaultFvDmd Dunno = absDmd +defaultFvDmd ExnOrDiv = absDmd -- This is the whole point of ExnOrDiv! +defaultFvDmd Diverges = botDmd -- Diverges + +defaultArgDmd :: Divergence -> Demand +-- TopRes and BotRes are polymorphic, so that +-- BotRes === (Bot -> BotRes) === ... +-- TopRes === (Top -> TopRes) === ... +-- This function makes that concrete +-- Also see Note [Default demand on free variables and arguments] +defaultArgDmd Dunno = topDmd +-- NB: not botDmd! We don't want to mask the precise exception by forcing the +-- argument. But it is still absent. +defaultArgDmd ExnOrDiv = absDmd +defaultArgDmd Diverges = botDmd + +{- Note [Precise vs imprecise exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An exception is considered to be /precise/ when it is thrown by the 'raiseIO#' +primop. It follows that all other primops (such as 'raise#' or +division-by-zero) throw /imprecise/ exceptions. Note that the actual type of +the exception thrown doesn't have any impact! + +GHC undertakes some effort not to apply an optimisation that would mask a +/precise/ exception with some other source of nontermination, such as genuine +divergence or an imprecise exception, so that the user can reliably +intercept the precise exception with a catch handler before and after +optimisations. + +See also the wiki page on precise exceptions: +https://gitlab.haskell.org/ghc/ghc/wikis/exceptions/precise-exceptions +Section 5 of "Tackling the awkward squad" talks about semantic concerns. +Imprecise exceptions are actually more interesting than precise ones (which are +fairly standard) from the perspective of semantics. See the paper "A Semantics +for Imprecise Exceptions" for more details. + +Note [Dead ends] +~~~~~~~~~~~~~~~~ +We call an expression that either diverges or throws a precise or imprecise +exception a "dead end". We used to call such an expression just "bottoming", +but with the measures we take to preserve precise exception semantics +(see Note [Precise exceptions and strictness analysis]), that is no longer +accurate: 'exnDiv' is no longer the bottom of the Divergence lattice. + +Yet externally to demand analysis, we mostly care about being able to drop dead +code etc., which is all due to the property that such an expression never +returns, hence we consider throwing a precise exception to be a dead end. +See also 'isDeadEndDiv'. + +Note [Precise exceptions and strictness analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have to take care to preserve precise exception semantics in strictness +analysis (#17676). There are two scenarios that need careful treatment. + +The fixes were discussed at +https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions + +Recall that raiseIO# raises a *precise* exception, in contrast to raise# which +raises an *imprecise* exception. See Note [Precise vs imprecise exceptions]. + +Scenario 1: Precise exceptions in case alternatives +--------------------------------------------------- +Unlike raise# (which returns botDiv), we want raiseIO# to return exnDiv. +Here's why. Consider this example from #13380 (similarly #17676): + f x y | x>0 = raiseIO# Exc + | y>0 = return 1 + | otherwise = return 2 +Is 'f' strict in 'y'? One might be tempted to say yes! But that plays fast and +loose with the precise exception; after optimisation, (f 42 (error "boom")) +turns from throwing the precise Exc to throwing the imprecise user error +"boom". So, the defaultFvDmd of raiseIO# should be lazy (topDmd), which can be +achieved by giving it divergence exnDiv. +See Note [Default demand on free variables and arguments]. + +Why don't we just give it topDiv instead of introducing exnDiv? +Because then the simplifier will fail to discard raiseIO#'s continuation in + case raiseIO# x s of { (# s', r #) -> } +which we'd like to optimise to + case raiseIO# x s of {} +Hence we came up with exnDiv. The default FV demand of exnDiv is lazy (and +its default arg dmd is absent), but otherwise (in terms of 'isDeadEndDiv') it +behaves exactly as botDiv, so that dead code elimination works as expected. +This is tracked by T13380b. + +Scenario 2: Precise exceptions in case scrutinees +------------------------------------------------- +Consider (more complete examples in #148, #1592, testcase strun003) + + case foo x s of { (# s', r #) -> y } + +Is this strict in 'y'? Often not! If @foo x s@ might throw a precise exception +(ultimately via raiseIO#), then we must not force 'y', which may fail to +terminate or throw an imprecise exception, until we have performed @foo x s@. + +So we have to 'deferAfterPreciseException' (which 'lub's with 'exnDmdType' to +model the exceptional control flow) when @foo x s@ may throw a precise +exception. Motivated by T13380{d,e,f}. +See Note [Which scrutinees may throw precise exceptions] in "GHC.Core.Opt.DmdAnal". + +We have to be careful not to discard dead-end Divergence from case +alternatives, though (#18086): + + m = putStrLn "foo" >> error "bar" + +'m' should still have 'exnDiv', which is why it is not sufficient to lub with +'nopDmdType' (which has 'topDiv') in 'deferAfterPreciseException'. + +Historical Note: This used to be called the "IO hack". But that term is rather +a bad fit because +1. It's easily confused with the "State hack", which also affects IO. +2. Neither "IO" nor "hack" is a good description of what goes on here, which + is deferring strictness results after possibly throwing a precise exception. + The "hack" is probably not having to defer when we can prove that the + expression may not throw a precise exception (increasing precision of the + analysis), but that's just a favourable guess. + +Note [Side-effects and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Due to historic reasons and the continued effort not to cause performance +regressions downstream, Strictness Analysis is currently prone to discarding +observable side-effects (other than precise exceptions, see +Note [Precise exceptions and strictness analysis]) in some cases. For example, + f :: MVar () -> Int -> IO Int + f mv x = putMVar mv () >> (x `seq` return x) +The call to `putMVar` is an observable side-effect. Yet, Strictness Analysis +currently concludes that `f` is strict in `x` and uses call-by-value. +That means `f mv (error "boom")` will error out with the imprecise exception +rather performing the side-effect. + +This is a conscious violation of the semantics described in the paper +"a semantics for imprecise exceptions"; so it would be great if we could +identify the offending primops and extend the idea in +Note [Which scrutinees may throw precise exceptions] to general side-effects. + +Unfortunately, the existing has-side-effects classification for primops is +too conservative, listing `writeMutVar#` and even `readMutVar#` as +side-effecting. That is due to #3207. A possible way forward is described in +#17900, but no effort has been so far towards a resolution. + +Note [Exceptions and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to smart about catching exceptions, but we aren't anymore. +See #14998 for the way it's resolved at the moment. + +Here's a historic breakdown: + +Apparently, exception handling prim-ops didn't use to have any special +strictness signatures, thus defaulting to nopSig, which assumes they use their +arguments lazily. Joachim was the first to realise that we could provide richer +information. Thus, in 0558911f91c (Dec 13), he added signatures to +primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call +their argument, which is useful information for usage analysis. Still with a +'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine. + +In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a +'strictApply1Dmd' leads to substantial performance gains. That was at the cost +of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in +28638dfe79e (Dec 15). + +Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, +Ben opened #11222. Simon made the demand analyser "understand catch" in +9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call +its argument strictly, but also swallow any thrown exceptions in +'multDivergence'. This was realized by extending the 'Str' constructor of +'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and +adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element +between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, +so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). + +This left the other variants like 'catchRetry#' having 'catchArgDmd', which is +where #14998 picked up. Item 1 was concerned with measuring the impact of also +making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that +there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7 +(Apr 18). There was a lot of dead code resulting from that change, that we +removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and +removed any code that was dealing with the peculiarities. + +Where did the speed-ups vanish to? In #14998, item 3 established that +turning 'catch#' strict in its first argument didn't bring back any of the +alleged performance benefits. Item 2 of that ticket finally found out that it +was entirely due to 'catchException's new (since #11555) definition, which +was simply + + catchException !io handler = catch io handler + +While 'catchException' is arguably the saner semantics for 'catch', it is an +internal helper function in "GHC.IO". Its use in +"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences: +Remove the bang and you find the regressions we originally wanted to avoid with +'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO". + +So history keeps telling us that the only possibly correct strictness annotation +for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really +is not strict in its argument: Just try this in GHCi + + :set -XScopedTypeVariables + import Control.Exception + catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") + +Any analysis that assumes otherwise will be broken in some way or another +(beyond `-fno-pedantic-bottoms`). + +But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a +subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is +only used by `raiseIO#` in order to preserve precise exceptions by strictness +analysis, while not impacting the ability to eliminate dead code. +See Note [Precise exceptions and strictness analysis]. + +Note [Default demand on free variables and arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Free variables not mentioned in the environment of a 'DmdType' +are demanded according to the demand type's Divergence: + * In a Diverges (botDiv) context, that demand is botDmd + (strict and absent). + * In all other contexts, the demand is absDmd (lazy and absent). +This is recorded in 'defaultFvDmd'. + +Similarly, we can eta-expand demand types to get demands on excess arguments +not accounted for in the type, by consulting 'defaultArgDmd': + * In a Diverges (botDiv) context, that demand is again botDmd. + * In a ExnOrDiv (exnDiv) context, that demand is absDmd: We surely diverge + before evaluating the excess argument, but don't want to eagerly evaluate + it (cf. Note [Precise exceptions and strictness analysis]). + * In a Dunno context (topDiv), the demand is topDmd, because + it's perfectly possible to enter the additional lambda and evaluate it + in unforeseen ways (so, not absent). + +Note [Bottom CPR iff Dead-Ending Divergence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both CPR analysis and Demand analysis handle recursive functions by doing +fixed-point iteration. To find the *least* (e.g., most informative) fixed-point, +iteration starts with the bottom element of the semantic domain. Diverging +functions generally have the bottom element as their least fixed-point. + +One might think that CPR analysis and Demand analysis then agree in when a +function gets a bottom denotation. E.g., whenever it has 'botCpr', it should +also have 'botDiv'. But that is not the case, because strictness analysis has to +be careful around precise exceptions, see Note [Precise vs imprecise exceptions]. + +So Demand analysis gives some diverging functions 'exnDiv' (which is *not* the +bottom element) when the CPR signature says 'botCpr', and that's OK. Here's an +example (from #18086) where that is the case: + +ioTest :: IO () +ioTest = do + putStrLn "hi" + undefined + +However, one can loosely say that we give a function 'botCpr' whenever its +'Divergence' is 'exnDiv' or 'botDiv', i.e., dead-ending. But that's just +a consequence of fixed-point iteration, it's not important that they agree. + +************************************************************************ +* * + Demand environments and types +* * +************************************************************************ +-} + +-- Subject to Note [Default demand on free variables and arguments] +-- | Captures the result of an evaluation of an expression, by +-- +-- * Listing how the free variables of that expression have been evaluated +-- ('de_fvs') +-- * Saying whether or not evaluation would surely diverge ('de_div') +-- +-- See Note [Demand env Equality]. +data DmdEnv = DE { de_fvs :: !(VarEnv Demand), de_div :: !Divergence } + +instance Eq DmdEnv where + DE fv1 div1 == DE fv2 div2 + = div1 == div2 && canonicalise div1 fv1 == canonicalise div2 fv2 + where + canonicalise div fv = filterUFM (/= defaultFvDmd div) fv + +mkEmptyDmdEnv :: Divergence -> DmdEnv +mkEmptyDmdEnv div = DE emptyVarEnv div + +-- | Build a potentially terminating 'DmdEnv' from a finite map that says what +-- has been evaluated so far +mkTermDmdEnv :: VarEnv Demand -> DmdEnv +mkTermDmdEnv fvs = DE fvs topDiv + +nopDmdEnv :: DmdEnv +nopDmdEnv = mkEmptyDmdEnv topDiv + +botDmdEnv :: DmdEnv +botDmdEnv = mkEmptyDmdEnv botDiv + +exnDmdEnv :: DmdEnv +exnDmdEnv = mkEmptyDmdEnv exnDiv + +lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv +lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div + where + -- See Note [Demand env Equality] + lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) + lub_div = lubDivergence d1 d2 + +addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv +addVarDmdEnv env@(DE fvs div) id dmd + = DE (extendVarEnv fvs id (dmd `plusDmd` lookupDmdEnv env id)) div + +plusDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv +plusDmdEnv (DE fv1 d1) (DE fv2 d2) + -- In contrast to Note [Asymmetry of plusDmdType], this function is symmetric. + | isEmptyVarEnv fv2, defaultFvDmd d2 == absDmd + = DE fv1 (d1 `plusDivergence` d2) -- a very common case that is much more efficient + | isEmptyVarEnv fv1, defaultFvDmd d1 == absDmd + = DE fv2 (d1 `plusDivergence` d2) -- another very common case that is much more efficient + | otherwise + = DE (plusVarEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)) + (d1 `plusDivergence` d2) + +-- | 'DmdEnv' is a monoid via 'plusDmdEnv' and 'nopDmdEnv'; this is its 'msum' +plusDmdEnvs :: [DmdEnv] -> DmdEnv +plusDmdEnvs = foldl1WithDefault' nopDmdEnv plusDmdEnv + +multDmdEnv :: Card -> DmdEnv -> DmdEnv +multDmdEnv C_11 env = env +multDmdEnv C_00 _ = nopDmdEnv +multDmdEnv n (DE fvs div) = DE (mapVarEnv (multDmd n) fvs) (multDivergence n div) + +reuseEnv :: DmdEnv -> DmdEnv +reuseEnv = multDmdEnv C_1N + +lookupDmdEnv :: DmdEnv -> Id -> Demand +-- See Note [Default demand on free variables and arguments] +lookupDmdEnv (DE fv div) id = lookupVarEnv fv id `orElse` defaultFvDmd div + +delDmdEnv :: DmdEnv -> Id -> DmdEnv +delDmdEnv (DE fv div) id = DE (fv `delVarEnv` id) div + +-- | Characterises how an expression +-- +-- * Evaluates its free variables ('dt_env') including divergence info +-- * Evaluates its arguments ('dt_args') +-- +data DmdType + = DmdType + { dt_env :: !DmdEnv -- ^ Demands on free variables. + -- See Note [Demand type Divergence] + , dt_args :: ![Demand] -- ^ Demand on arguments + } + +-- | See Note [Demand env Equality]. +instance Eq DmdType where + DmdType env1 ds1 == DmdType env2 ds2 + = ds1 == ds2 -- cheap checks first + && env1 == env2 + +-- | Compute the least upper bound of two 'DmdType's elicited /by the same +-- incoming demand/! +lubDmdType :: DmdType -> DmdType -> DmdType +lubDmdType d1 d2 = DmdType lub_fv lub_ds + where + n = max (dmdTypeDepth d1) (dmdTypeDepth d2) + (DmdType fv1 ds1) = etaExpandDmdType n d1 + (DmdType fv2 ds2) = etaExpandDmdType n d2 + lub_ds = zipWithEqual lubDmd ds1 ds2 + lub_fv = lubDmdEnv fv1 fv2 + +discardArgDmds :: DmdType -> DmdEnv +discardArgDmds (DmdType fv _) = fv + +plusDmdType :: DmdType -> DmdEnv -> DmdType +plusDmdType (DmdType fv ds) fv' + -- See Note [Asymmetry of plusDmdType] + -- 'DmdEnv' forms a (monoidal) action on 'DmdType' via this operation. + = DmdType (plusDmdEnv fv fv') ds + +botDmdType :: DmdType +botDmdType = DmdType botDmdEnv [] + +-- | The demand type of doing nothing (lazy, absent, no Divergence +-- information). Note that it is ''not'' the top of the lattice (which would be +-- "may use everything"), so it is (no longer) called topDmdType. +nopDmdType :: DmdType +nopDmdType = DmdType nopDmdEnv [] + +-- | The demand type of an unspecified expression that is guaranteed to +-- throw a (precise or imprecise) exception or diverge. +exnDmdType :: DmdType +exnDmdType = DmdType exnDmdEnv [] + +dmdTypeDepth :: DmdType -> Arity +dmdTypeDepth = length . dt_args + +-- | This makes sure we can use the demand type with n arguments after eta +-- expansion, where n must not be lower than the demand types depth. +-- It appends the argument list with the correct 'defaultArgDmd'. +etaExpandDmdType :: Arity -> DmdType -> DmdType +etaExpandDmdType n d@DmdType{dt_args = ds, dt_env = env} + | n == depth = d + | n > depth = d{dt_args = inc_ds} + | otherwise = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d) + where depth = length ds + -- Arity increase: + -- * Demands on FVs are still valid + -- * Demands on args also valid, plus we can extend with defaultArgDmd + -- as appropriate for the given Divergence + -- * Divergence is still valid: + -- - A dead end after 2 arguments stays a dead end after 3 arguments + -- - The remaining case is Dunno, which is already topDiv + inc_ds = take n (ds ++ repeat (defaultArgDmd (de_div env))) + +-- | A conservative approximation for a given 'DmdType' in case of an arity +-- decrease. Currently, it's just nopDmdType. +decreaseArityDmdType :: DmdType -> DmdType +decreaseArityDmdType _ = nopDmdType + +splitDmdTy :: DmdType -> (Demand, DmdType) +-- Split off one function argument +-- We already have a suitable demand on all +-- free vars, so no need to add more! +splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args}) +splitDmdTy ty@DmdType{dt_env=env} = (defaultArgDmd (de_div env), ty) + +multDmdType :: Card -> DmdType -> DmdType +multDmdType C_11 dmd_ty = dmd_ty -- a vital optimisation for T25196 +multDmdType n (DmdType fv args) + = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $ + DmdType (multDmdEnv n fv) + (strictMap (multDmd n) args) + +peelFV :: DmdType -> Var -> (DmdType, Demand) +peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) + (DmdType fv' ds, dmd) + where + -- Force these arguments so that old `Env` is not retained. + !fv' = fv `delDmdEnv` id + !dmd = lookupDmdEnv fv id + +addDemand :: Demand -> DmdType -> DmdType +addDemand dmd (DmdType fv ds) = DmdType fv (dmd:ds) + +findIdDemand :: DmdType -> Var -> Demand +findIdDemand (DmdType fv _) id = lookupDmdEnv fv id + +-- | When e is evaluated after executing an IO action that may throw a precise +-- exception, we act as if there is an additional control flow path that is +-- taken if e throws a precise exception. The demand type of this control flow +-- path +-- * is lazy and absent ('topDmd') and boxed in all free variables and arguments +-- * has 'exnDiv' 'Divergence' result +-- See Note [Precise exceptions and strictness analysis] +-- +-- So we can simply take a variant of 'nopDmdType', 'exnDmdType'. +-- Why not 'nopDmdType'? Because then the result of 'e' can never be 'exnDiv'! +-- That means failure to drop dead-ends, see #18086. +deferAfterPreciseException :: DmdType -> DmdType +deferAfterPreciseException = lubDmdType exnDmdType + +{- Note [deferAfterPreciseException] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The big picture is in Note [Precise exceptions and strictness analysis] +The idea is that we want to treat + case of (# s', r #) -> rhs + +as if it was + case of + Just (# s', r #) -> rhs + Nothing -> error + +That is, the I/O operation might throw an exception, so that 'rhs' never +gets reached. For example, we don't want to be strict in the strict free +variables of 'rhs'. + +So we have the simple definition + deferAfterPreciseException = lubDmdType (DmdType emptyDmdEnv [] exnDiv) + +Historically, when we had `lubBoxity = _unboxedWins` (see Note [unboxedWins]), +we had a more complicated definition for deferAfterPreciseException to make sure +it preserved boxity in its argument. That was needed for code like + case of + (# s', r) -> f x + +which uses `x` *boxed*. If we `lub`bed it with `(DmdType emptyDmdEnv [] exnDiv)` +we'd get an *unboxed* demand on `x` (because we let Unboxed win), +which led to #20746. Nowadays with `lubBoxity = boxedWins` we don't need +the complicated definition. + +Note [Demand type Divergence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In contrast to DmdSigs, DmdTypes are elicited under a specific incoming demand. +This is described in detail in Note [Understanding DmdType and DmdSig]. +Here, we'll focus on what that means for a DmdType's Divergence in a higher-order +scenario. + +Consider + err x y = x `seq` y `seq` error (show x) +this has a strictness signature of + <1L><1L>b +meaning that we don't know what happens when we call err in weaker contexts than +C(1,C(1,L)), like @err `seq` ()@ (1A) and @err 1 `seq` ()@ (C(S,A)). We +may not unleash the botDiv, hence assume topDiv. Of course, in +@err 1 2 `seq` ()@ the incoming demand C(S,C(S,A)) is strong enough and we see +that the expression diverges. + +Now consider a function + f g = g 1 2 +with signature , and the expression + f err `seq` () +now f puts a strictness demand of C(1,C(1,L)) onto its argument, which is unleashed +on err via the App rule. In contrast to weaker head strictness, this demand is +strong enough to unleash err's signature and hence we see that the whole +expression diverges! + +Note [Demand env Equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What is the difference between the Demand env {x->A} and {}? +Answer: There is none! They have the exact same semantics, because any var that +is not mentioned in 'de_fvs' implicitly has demand 'defaultFvDmd', based on +the divergence of the demand env 'de_div'. +Similarly, b{x->B, y->A} is the same as b{y->A}, because the default FV +demand of BotDiv is B. But neither is equal to b{}, because y has demand B in +the latter, not A as before. + +The Eq instance of DmdEnv must reflect that, otherwise we can get into monotonicity +issues during fixed-point iteration ({x->A} /= {} /= {x->A} /= ...). +It does so by filtering out any default FV demands prior to comparing 'de_fvs'. + +Note that 'lubDmdEnv' maintains this kind of equality by using 'plusVarEnv_CD', +involving 'defaultFvDmd' for any entries present in one 'de_fvs' but not the +other. + +Note [Asymmetry of plusDmdType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'plus' for DmdTypes is *asymmetrical*, because there can only one +be one type contributing argument demands! For example, given (e1 e2), we get +a DmdType dt1 for e1, use its arg demand to analyse e2 giving dt2, and then do +(dt1 `plusType` dt2). Similarly with + case e of { p -> rhs } +we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then +compute (dt_rhs `plusType` dt_scrut). + +We + 1. combine the information on the free variables, + 2. take the demand on arguments from the first argument + 3. combine the termination results, as in plusDivergence. + +Since we don't use argument demands of the second argument anyway, 'plus's +second argument is just a 'PlusDmdType'. + +But note that the argument demand types are not guaranteed to be observed in +left to right order. For example, analysis of a case expression will pass the +demand type for the alts as the left argument and the type for the scrutinee as +the right argument. Also, it is not at all clear if there is such an order; +consider the LetUp case, where the RHS might be forced at any point while +evaluating the let body. +Therefore, it is crucial that 'plusDivergence' is symmetric! + +Note [Demands from unsaturated function calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a demand transformer d1 -> d2 -> r for f. +If a sufficiently detailed demand is fed into this transformer, +e.g arising from "f x1 x2" in a strict, use-once context, +then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for +the free variable environment) and furthermore the result information r is the +one we want to use. + +An anonymous lambda is also an unsaturated function all (needs one argument, +none given), so this applies to that case as well. + +But the demand fed into f might be less than C(1,C(1,L)). Then we have to +'multDmdType' the announced demand type. Examples: + * Not strict enough, e.g. C(1,C(1,L)): + - We have to multiply all argument and free variable demands with C_01, + zapping strictness. + - We have to multiply divergence with C_01. If r says that f Diverges for sure, + then this holds when the demand guarantees that two arguments are going to + be passed. If the demand is lower, we may just as well converge. + If we were tracking definite convergence, than that would still hold under + a weaker demand than expected by the demand transformer. + * Used more than once, e.g. C(S,C(1,L)): + - Multiply with C_1N. Even if f puts a used-once demand on any of its argument + or free variables, if we call f multiple times, we may evaluate this + argument or free variable multiple times. + +In dmdTransformSig, we call peelManyCalls to find out the 'Card'inality with +which we have to multiply and then call multDmdType with that. + +Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use +peelCallDmd, which peels only one level, but also returns the demand put on the +body of the function. +-} + + +{- +************************************************************************ +* * + Demand signatures +* * +************************************************************************ + +Note [DmdSig: demand signatures, and demand-sig arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also + * Note [Demand signatures semantically] + * Note [Understanding DmdType and DmdSig] + +In a let-bound Id we record its demand signature. +In principle, this demand signature is a demand transformer, mapping +a demand on the Id into a DmdType, which gives + a) the free vars of the Id's value + b) the Id's arguments + c) an indication of the result of applying + the Id to its arguments + +However, in fact we store in the Id an extremely emasculated demand +transformer, namely + a single DmdType +(Nevertheless we dignify DmdSig as a distinct type.) + +The DmdSig for an Id is a semantic thing. Suppose a function `f` has a DmdSig of + DmdSig (DmdType (fv_dmds,res) [d1..dn]) +Here `n` is called the "demand-sig arity" of the DmdSig. The signature means: + * If you apply `f` to n arguments (the demand-sig-arity) + * then you can unleash demands d1..dn on the arguments + * and demands fv_dmds on the free variables. +Also see Note [Demand type Divergence] for the meaning of a Divergence in a +demand signature. + +If `f` is applied to fewer value arguments than its demand-sig arity, it means +that the demand on the function at a call site is weaker than the vanilla call +demand, used for signature inference. Therefore we place a top demand on all +arguments. + +For example, the demand transformer described by the demand signature + DmdSig (DmdType {x -> <1L>} <1P(L,L)>) +says that when the function is applied to two arguments, it +unleashes demand 1L on the free var x, A on the first arg, +and 1P(L,L) on the second. + +If this same function is applied to one arg, all we can say is that it +uses x with 1L, and its arg with demand 1P(L,L). + +Note [Demand signatures semantically] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand analysis interprets expressions in the abstract domain of demand +transformers. Given a (sub-)demand that denotes the evaluation context, the +abstract transformer of an expression gives us back a demand type denoting +how other things (like arguments and free vars) were used when the expression +was evaluated. Here's an example: + + f x y = + if x + expensive + then \z -> z + y * ... + else \z -> z * ... + +The abstract transformer (let's call it F_e) of the if expression (let's +call it e) would transform an incoming (undersaturated!) head sub-demand A +into a demand type like {x-><1L>,y->}. In pictures: + + SubDemand ---F_e---> DmdType + {x-><1L>,y->} + +Let's assume that the demand transformers we compute for an expression are +correct wrt. to some concrete semantics for Core. How do demand signatures fit +in? They are strange beasts, given that they come with strict rules when to +it's sound to unleash them. + +Fortunately, we can formalise the rules with Galois connections. Consider +f's strictness signature, {}<1L>. It's a single-point approximation of +the actual abstract transformer of f's RHS for arity 2. So, what happens is that +we abstract *once more* from the abstract domain we already are in, replacing +the incoming Demand by a simple lattice with two elements denoting incoming +arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom +element). Here's the diagram: + + A_2 -----f_f----> DmdType + ^ | + | α γ | + | v + SubDemand --F_f----> DmdType + +With + α(C(1,C(1,_))) = >=2 + α(_) = <2 + γ(ty) = ty +and F_f being the abstract transformer of f's RHS and f_f being the abstracted +abstract transformer computable from our demand signature simply by + + f_f(>=2) = {}<1L> + f_f(<2) = multDmdType C_0N {}<1L> + +where multDmdType makes a proper top element out of the given demand type. + +In practice, the A_n domain is not just a simple Bool, but a Card, which is +exactly the Card with which we have to multDmdType. The Card for arity n +is computed by calling @peelManyCalls n@, which corresponds to α above. + +Note [Understanding DmdType and DmdSig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand types are sound approximations of an expression's semantics relative to +the incoming demand we put the expression under. Consider the following +expression: + + \x y -> x `seq` (y, 2*x) + +Here is a table with demand types resulting from different incoming demands we +put that expression under. Note the monotonicity; a stronger incoming demand +yields a more precise demand type: + + incoming sub-demand | demand type + -------------------------------- + P(A) | {} + C(1,C(1,P(L))) | <1P(L)>{} + C(1,C(1,1P(1P(L),A))) | <1P(A)>{} + +Note that in the first example, the depth of the demand type was *higher* than +the arity of the incoming call demand due to the anonymous lambda. +The converse is also possible and happens when we unleash demand signatures. +In @f x y@, the incoming call demand on f has arity 2. But if all we have is a +demand signature with depth 1 for @f@ (which we can safely unleash, see below), +the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1. + +So: Demand types are elicited by putting an expression under an incoming (call) +demand, the arity of which can be lower or higher than the depth of the +resulting demand type. +In contrast, a demand signature summarises a function's semantics *without* +immediately specifying the incoming demand it was produced under. Despite StrSig +being a newtype wrapper around DmdType, it actually encodes two things: + + * The threshold (i.e., minimum arity) to unleash the signature + * A demand type that is sound to unleash when the minimum arity requirement is + met. + +Here comes the subtle part: The threshold is encoded in the demand-sig arity! +So in mkDmdSigForArity we make sure to trim the list of argument demands to the +given threshold arity. Call sites will make sure that this corresponds to the +arity of the call demand that elicited the wrapped demand type. See also +Note [DmdSig: demand signatures, and demand-sig arity] +-} + +-- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe +-- to unleash. Better construct this through 'mkDmdSigForArity'. +-- See Note [Understanding DmdType and DmdSig] +newtype DmdSig + = DmdSig DmdType + deriving Eq + +-- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig' +-- unleashable at that arity. See Note [Understanding DmdType and DmdSig]. +mkDmdSigForArity :: Arity -> DmdType -> DmdSig +mkDmdSigForArity threshold_arity dmd_ty@(DmdType fvs args) + | threshold_arity < dmdTypeDepth dmd_ty + = DmdSig $ DmdType (fvs { de_div = topDiv }) (take threshold_arity args) + | otherwise + = DmdSig (etaExpandDmdType threshold_arity dmd_ty) + +mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig +mkClosedDmdSig ds div = mkDmdSigForArity (length ds) (DmdType (mkEmptyDmdEnv div) ds) + +mkVanillaDmdSig :: Arity -> Divergence -> DmdSig +mkVanillaDmdSig ar div = mkClosedDmdSig (replicate ar topDmd) div + +splitDmdSig :: DmdSig -> ([Demand], Divergence) +splitDmdSig (DmdSig (DmdType env dmds)) = (dmds, de_div env) + +dmdSigDmdEnv :: DmdSig -> DmdEnv +dmdSigDmdEnv (DmdSig (DmdType env _)) = env + +hasDemandEnvSig :: DmdSig -> Bool +hasDemandEnvSig = not . isEmptyVarEnv . de_fvs . dmdSigDmdEnv + +botSig :: DmdSig +botSig = DmdSig botDmdType + +nopSig :: DmdSig +nopSig = DmdSig nopDmdType + +isNopSig :: DmdSig -> Bool +isNopSig (DmdSig ty) = ty == nopDmdType + +-- | True if the signature diverges or throws an exception in a saturated call. +-- See Note [Dead ends]. +isDeadEndSig :: DmdSig -> Bool +isDeadEndSig (DmdSig (DmdType env _)) = isDeadEndDiv (de_div env) + +-- | True if the signature diverges or throws an imprecise exception in a saturated call. +-- NB: In constrast to 'isDeadEndSig' this returns False for 'exnDiv'. +-- See Note [Dead ends] +-- and Note [Precise vs imprecise exceptions]. +isBottomingSig :: DmdSig -> Bool +isBottomingSig (DmdSig (DmdType env _)) = de_div env == botDiv + +-- | True when the signature indicates all arguments are boxed +onlyBoxedArguments :: DmdSig -> Bool +onlyBoxedArguments (DmdSig (DmdType _ dmds)) = all demandIsBoxed dmds + where + demandIsBoxed BotDmd = True + demandIsBoxed AbsDmd = True + demandIsBoxed (_ :* sd) = subDemandIsboxed sd + + subDemandIsboxed (Poly Unboxed _) = False + subDemandIsboxed (Poly _ _) = True + subDemandIsboxed (Call _ sd) = subDemandIsboxed sd + subDemandIsboxed (Prod Unboxed _) = False + subDemandIsboxed (Prod _ ds) = all demandIsBoxed ds + +-- | Returns true if an application to n value args would diverge or throw an +-- exception. +-- +-- If a function having 'botDiv' is applied to a less number of arguments than +-- its syntactic arity, we cannot say for sure that it is going to diverge. +-- Hence this function conservatively returns False in that case. +-- See Note [Dead ends]. +isDeadEndAppSig :: DmdSig -> Int -> Bool +isDeadEndAppSig (DmdSig (DmdType env ds)) n + = isDeadEndDiv (de_div env) && not (lengthExceeds ds n) + +trimBoxityDmdEnv :: DmdEnv -> DmdEnv +trimBoxityDmdEnv (DE fvs div) = DE (mapVarEnv trimBoxity fvs) div + +trimBoxityDmdType :: DmdType -> DmdType +trimBoxityDmdType (DmdType env ds) = + DmdType (trimBoxityDmdEnv env) (map trimBoxity ds) + +trimBoxityDmdSig :: DmdSig -> DmdSig +trimBoxityDmdSig = coerce trimBoxityDmdType + +-- | Transfers the boxity of the left arg to the demand structure of the right +-- arg. This only makes sense if applied to new and old demands of the same +-- value. +transferBoxity :: Demand -> Demand -> Demand +transferBoxity from to = go_dmd from to + where + go_dmd (from_n :* from_sd) to_dmd@(to_n :* to_sd) + | isAbs from_n || isAbs to_n = to_dmd + | otherwise = case (from_sd, to_sd) of + (Poly from_b _, Poly _ to_c) -> + to_n :* Poly from_b to_c + (_, Prod _ to_ds) + | Just (from_b, from_ds) <- viewProd (length to_ds) from_sd + -> to_n :* mkProd from_b (strictZipWith go_dmd from_ds to_ds) + (Prod from_b from_ds, _) + | Just (_, to_ds) <- viewProd (length from_ds) to_sd + -> to_n :* mkProd from_b (strictZipWith go_dmd from_ds to_ds) + _ -> trimBoxity to_dmd + +transferArgBoxityDmdType :: DmdType -> DmdType -> DmdType +transferArgBoxityDmdType _from@(DmdType _ from_ds) to@(DmdType to_env to_ds) + | equalLength from_ds to_ds + = -- pprTraceWith "transfer" (\r -> ppr _from $$ ppr to $$ ppr r) $ + DmdType to_env -- Only arg boxity! See Note [Don't change boxity without worker/wrapper] + (zipWith transferBoxity from_ds to_ds) + | otherwise + = trimBoxityDmdType to + +transferArgBoxityDmdSig :: DmdSig -> DmdSig -> DmdSig +transferArgBoxityDmdSig = coerce transferArgBoxityDmdType + +prependArgsDmdSig :: Int -> DmdSig -> DmdSig +-- ^ Add extra ('topDmd') arguments to a strictness signature. +-- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument +-- demands. This is used by FloatOut. +prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds)) + | new_args == 0 = sig + | dmd_ty == nopDmdType = sig + | otherwise = DmdSig (DmdType env dmds') + where + dmds' = assertPpr (new_args > 0) (ppr new_args) $ + replicate new_args topDmd ++ dmds + +etaConvertDmdSig :: Arity -> DmdSig -> DmdSig +-- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to +-- the former (when the Simplifier identifies a new join points, for example). +-- In contrast to 'prependArgsDmdSig', this /appends/ extra arg demands if +-- necessary. +-- This works by looking at the 'DmdType' (which was produced under a call +-- demand for the old arity) and trying to transfer as many facts as we can to +-- the call demand of new arity. +-- An arity increase (resulting in a stronger incoming demand) can retain much +-- of the info, while an arity decrease (a weakening of the incoming demand) +-- must fall back to a conservative default. +etaConvertDmdSig arity (DmdSig dmd_ty) + | arity < dmdTypeDepth dmd_ty = DmdSig $ decreaseArityDmdType dmd_ty + | otherwise = DmdSig $ etaExpandDmdType arity dmd_ty + +{- +************************************************************************ +* * + Demand transformers +* * +************************************************************************ +-} + +-- | A /demand transformer/ is a monotone function from an incoming evaluation +-- context ('SubDemand') to a 'DmdType', describing how the denoted thing +-- (i.e. expression, function) uses its arguments and free variables, and +-- whether it diverges. +-- +-- See Note [Understanding DmdType and DmdSig] +-- and Note [DmdSig: demand signatures, and demand-sig arity] +type DmdTransformer = SubDemand -> DmdType + +-- | Extrapolate a demand signature ('DmdSig') into a 'DmdTransformer'. +-- +-- Given a function's 'DmdSig' and a 'SubDemand' for the evaluation context, +-- return how the function evaluates its free variables and arguments. +dmdTransformSig :: DmdSig -> DmdTransformer +dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds)) sd + = multDmdType (fst $ peelManyCalls (length arg_ds) sd) dmd_ty + -- see Note [Demands from unsaturated function calls] + -- and Note [DmdSig: demand signatures, and demand-sig arity] + +-- | A special 'DmdTransformer' for data constructors that feeds product +-- demands into the constructor arguments. +dmdTransformDataConSig :: [StrictnessMark] -> DmdTransformer +-- See Note [Demand transformer for data constructors] +dmdTransformDataConSig str_marks sd = case viewProd arity body_sd of + Just (_, dmds) -> mk_body_ty n dmds + Nothing -> nopDmdType + where + arity = length str_marks + (n, body_sd) = peelManyCalls arity sd + mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds) + bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd) + | otherwise = multDmd n dmd + str_field_dmd = seqDmd -- See the bit about strict fields + -- in Note [Demand transformer for data constructors] + +-- | A special 'DmdTransformer' for dictionary selectors that feeds the demand +-- on the result into the indicated dictionary component (if saturated). +-- See Note [Demand transformer for a dictionary selector]. +dmdTransformDictSelSig :: DmdSig -> DmdTransformer + + +dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* dict_dmd])) call_sd + -- NB: dict_dmd comes from the demand signature of the class-op + -- which is created in GHC.Types.Id.Make.mkDictSelId + | (n, sd') <- peelCallDmd call_sd + , Prod _ sig_ds <- dict_dmd + = multDmdType n $ + DmdType nopDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] + | otherwise + = nopDmdType -- See Note [Demand transformer for a dictionary selector] + where + enhance _ AbsDmd = AbsDmd + enhance _ BotDmd = BotDmd + enhance sd' _dmd_var = C_11 :* sd' -- This is the one! + -- C_11, because we multiply with n above + +dmdTransformDictSelSig sig sd = pprPanic "dmdTransformDictSelSig: no args" (ppr sig $$ ppr sd) + +{- +Note [Demand transformer for a dictionary selector] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a superclass selector 'sc_sel' and a class method +selector 'op_sel', and a function that uses both, like this + +-- Strictness sig: 1P(1,A) +sc_sel (x,y) = x + +-- Strictness sig: 1P(A,1) +op_sel (p,q)= q + +f d v = op_sel (sc_sel d) v + +What do we learn about the demand on 'd'? Alas, we see only the +demand from 'sc_sel', namely '1P(1,A)'. We /don't/ see that 'd' really has a nested +demand '1P(1P(A,1C(1,1)),A)'. On the other hand, if we inlined the two selectors +we'd have + +f d x = case d of (x,_) -> + case x of (_,q) -> + q v + +If we analyse that, we'll get a richer, nested demand on 'd'. + +We want to behave /as if/ we'd inlined 'op_sel' and 'sc_sel'. We can do this +easily by building a richer demand transformer for dictionary selectors than +is expressible by a regular demand signature. +And that is what 'dmdTransformDictSelSig' does: it transforms the demand on the +result to a demand on the (single) argument. + +How does it do that? +If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' +into the appropriate field of the dictionary. What *is* the appropriate field? +We just look at the strictness signature of the class op, which will be +something like: P(AAA1AAAAA). Then replace the '1' (or any other non-absent +demand, really) by the demand 'd'. The '1' acts as if it was a demand variable, +the whole signature really means `\d. P(AAAdAAAAA)` for any incoming +demand 'd'. + +NB: even unary classes behave as if there was a data constructor, and so do +not need special handling here. See Note [Unary class magic] in GHC.Core.TyCon. +-} + +zapDmdEnv :: DmdEnv -> DmdEnv +zapDmdEnv (DE _ div) = mkEmptyDmdEnv div + +-- | Remove the demand environment from the signature. +zapDmdEnvSig :: DmdSig -> DmdSig +zapDmdEnvSig (DmdSig (DmdType env ds)) = DmdSig (DmdType (zapDmdEnv env) ds) + +zapUsageDemand :: Demand -> Demand +-- Remove the usage info, but not the strictness info, from the demand +zapUsageDemand = kill_usage $ KillFlags + { kf_abs = True + , kf_used_once = True + , kf_called_once = True + } + +-- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the demand +zapUsedOnceDemand :: Demand -> Demand +zapUsedOnceDemand = kill_usage $ KillFlags + { kf_abs = False + , kf_used_once = True + , kf_called_once = False + } + +-- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness +-- signature +zapUsedOnceSig :: DmdSig -> DmdSig +zapUsedOnceSig (DmdSig (DmdType env ds)) + = DmdSig (DmdType env (map zapUsedOnceDemand ds)) + +data KillFlags = KillFlags + { kf_abs :: Bool + , kf_used_once :: Bool + , kf_called_once :: Bool + } + +kill_usage_card :: KillFlags -> Card -> Card +kill_usage_card kfs C_00 | kf_abs kfs = C_0N +kill_usage_card kfs C_10 | kf_abs kfs = C_1N +kill_usage_card kfs C_01 | kf_used_once kfs = C_0N +kill_usage_card kfs C_11 | kf_used_once kfs = C_1N +kill_usage_card _ n = n + +kill_usage :: KillFlags -> Demand -> Demand +kill_usage _ AbsDmd = AbsDmd +kill_usage _ BotDmd = BotDmd +kill_usage kfs (n :* sd) = kill_usage_card kfs n :* kill_usage_sd kfs sd + +kill_usage_sd :: KillFlags -> SubDemand -> SubDemand +kill_usage_sd kfs (Call n sd) + | kf_called_once kfs = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd) + | otherwise = mkCall n (kill_usage_sd kfs sd) +kill_usage_sd kfs (Prod b ds) = mkProd b (map (kill_usage kfs) ds) +kill_usage_sd _ sd = sd + +{- ********************************************************************* +* * + TypeShape and demand trimming +* * +********************************************************************* -} + + +data TypeShape -- See Note [Trimming a demand to a type] + -- in GHC.Core.Opt.DmdAnal + = TsFun TypeShape + | TsProd [TypeShape] + | TsUnk + +trimToType :: Demand -> TypeShape -> Demand +-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal +trimToType AbsDmd _ = AbsDmd +trimToType BotDmd _ = BotDmd +trimToType (n :* sd) ts + = n :* go sd ts + where + go (Prod b ds) (TsProd tss) + | equalLength ds tss = mkProd b (zipWith trimToType ds tss) + go (Call n sd) (TsFun ts) = mkCall n (go sd ts) + go sd@Poly{} _ = sd + go _ _ = topSubDmd + +-- | Drop all boxity +trimBoxity :: Demand -> Demand +trimBoxity AbsDmd = AbsDmd +trimBoxity BotDmd = BotDmd +trimBoxity (n :* sd) = n :* go sd + where + go (Poly _ n) = Poly Boxed n + go (Prod _ ds) = mkProd Boxed (map trimBoxity ds) + go (Call n sd) = mkCall n $ go sd + +{- +************************************************************************ +* * + 'seq'ing demands +* * +************************************************************************ +-} + +seqDemand :: Demand -> () +seqDemand AbsDmd = () +seqDemand BotDmd = () +seqDemand (_ :* sd) = seqSubDemand sd + +seqSubDemand :: SubDemand -> () +seqSubDemand (Prod _ ds) = seqDemandList ds +seqSubDemand (Call _ sd) = seqSubDemand sd +seqSubDemand (Poly _ _) = () + +seqDemandList :: [Demand] -> () +seqDemandList = foldr (seq . seqDemand) () + +seqDmdType :: DmdType -> () +seqDmdType (DmdType env ds) = + seqDmdEnv env `seq` seqDemandList ds `seq` () + +seqDmdEnv :: DmdEnv -> () +seqDmdEnv (DE fvs _) = seqEltsUFM seqDemand fvs + +seqDmdSig :: DmdSig -> () +seqDmdSig (DmdSig ty) = seqDmdType ty + +{- +************************************************************************ +* * + Outputable and Binary instances +* * +************************************************************************ +-} + +-- Just for debugging purposes. +instance Show Card where + show C_00 = "C_00" + show C_01 = "C_01" + show C_0N = "C_0N" + show C_10 = "C_10" + show C_11 = "C_11" + show C_1N = "C_1N" + +{- Note [Demand notation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note should be kept up to date with the documentation of `-fstrictness` +in the user's guide. + +For pretty-printing demands, we use quite a compact notation with some +abbreviations. Here's the BNF: + + card ::= B {} + | A {0} + | M {0,1} + | L {0,1,n} + | 1 {1} + | S {1,n} + + box ::= ! Unboxed + | Boxed + + d ::= card sd The :* constructor, just juxtaposition + | card abbreviation: Same as "card card" + + sd ::= box card @Poly box card@ + | box P(d,d,..) @Prod box [d1,d2,..]@ + | Ccard(sd) @Call card sd@ + +So, L can denote a 'Card', polymorphic 'SubDemand' or polymorphic 'Demand', +but it's always clear from context which "overload" is meant. It's like +return-type inference of e.g. 'read'. + +An example of the demand syntax is 1!P(1!L,A), the demand of fst's argument. +See Note [Demand examples] for more examples and their semantics. + +This is the syntax for demand signatures: + + div ::= topDiv + | x exnDiv + | b botDiv + + sig ::= {x->dx,y->dy,z->dz...}...div + ^ ^ ^ ^ ^ ^ + | | | | | | + | \---+---+------/ | + | | | + demand on free demand on divergence + variables arguments information + (omitted if empty) (omitted if + no information) + +Note [Demand examples] +~~~~~~~~~~~~~~~~~~~~~~ +Here are some examples of the demand notation, specified in Note [Demand notation], +in action. In each case we give the demand on the variable `x`. + +Demand on x Example Explanation + 1!A seq x y Evaluates `x` exactly once (`1`), but not + any deeper (`A`), and discards the box (`!`). + S!A seq x (seq x y) Twice the previous demand; hence eval'd + more than once (`S` for strict). + 1!P(1!L,A) fst x Evaluates pair `x` exactly once, first + component exactly once. No info that (`L`). + Second component is absent. Discards boxes (`!`). + 1P(1L,A) opq_fst x Like fst, but all boxes are retained. + SP(1!L,A) opq_seq x (fst x) Two evals of x but exactly one of its first component. + Box of x retained, but box of first component discarded. + 1!C(1,L) x $ 3 Evals x exactly once ( 1 ) and calls it + exactly once ( C(1,_) ). No info on how the + result is evaluated ( L ). + MC(M,L) maybe y x Evals x at most once ( 1 ) and calls it at + most once ( C(1,_) ). No info on how the + result is evaluated ( L ). + LP(SL,A) map (+ fst x) Evals x lazily and multiple times ( L ), + but when it is evaluated, the first + component is evaluated (strictly) as well. + +In the examples above, `opq_fst` is an opaque wrapper around `fst`, i.e. + + opq_fst = fst + {-# OPAQUE opq_fst #-} + +Similarly for `seq`. The effect of an OPAQUE pragma is that it discards any +boxity flags in the demand signature, as described in Note [OPAQUE pragma]. +-} + +-- | See Note [Demand notation] +-- Current syntax was discussed in #19016. +instance Outputable Card where + ppr C_00 = char 'A' -- "Absent" + ppr C_01 = char 'M' -- "Maybe" + ppr C_0N = char 'L' -- "Lazy" + ppr C_11 = char '1' -- "exactly 1" + ppr C_1N = char 'S' -- "Strict" + ppr C_10 = char 'B' -- "Bottom" + +-- | See Note [Demand notation] +instance Outputable Demand where + ppr AbsDmd = char 'A' + ppr BotDmd = char 'B' + ppr (C_0N :* Poly Boxed C_0N) = char 'L' -- Print LL as just L + ppr (C_1N :* Poly Boxed C_1N) = char 'S' -- Dito SS + ppr (n :* sd) = ppr n <> ppr sd + +-- | See Note [Demand notation] +instance Outputable SubDemand where + ppr (Poly b n) = pp_boxity b <> ppr n + ppr (Call n sd) = char 'C' <> parens (ppr n <> comma <> ppr sd) + ppr (Prod b ds) = pp_boxity b <> char 'P' <> parens (fields ds) + where + fields [] = empty + fields [x] = ppr x + fields (x:xs) = ppr x <> char ',' <> fields xs + +pp_boxity :: Boxity -> SDoc +pp_boxity Unboxed = char '!' +pp_boxity _ = empty + +instance Outputable Divergence where + ppr Diverges = char 'b' -- for (b)ottom + ppr ExnOrDiv = char 'x' -- for e(x)ception + ppr Dunno = empty + +instance Outputable DmdEnv where + ppr (DE fvs div) + = ppr div <> if null fv_elts then empty + else braces (fsep (map pp_elt fv_elts)) + where + pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + fv_elts = nonDetUFMToList fvs + -- It's OK to use nonDetUFMToList here because we only do it for + -- pretty printing + +instance Outputable DmdType where + ppr (DmdType fv ds) + = hcat (map (angleBrackets . ppr) ds) <> ppr fv + +instance Outputable DmdSig where + ppr (DmdSig ty) = ppr ty + +instance Outputable TypeShape where + ppr TsUnk = text "TsUnk" + ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) + ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) + +instance Binary Card where + put_ bh C_00 = putByte bh 0 + put_ bh C_01 = putByte bh 1 + put_ bh C_0N = putByte bh 2 + put_ bh C_11 = putByte bh 3 + put_ bh C_1N = putByte bh 4 + put_ bh C_10 = putByte bh 5 + get bh = do + h <- getByte bh + case h of + 0 -> return C_00 + 1 -> return C_01 + 2 -> return C_0N + 3 -> return C_11 + 4 -> return C_1N + 5 -> return C_10 + _ -> pprPanic "Binary:Card" (ppr (fromIntegral h :: Int)) + +instance Binary Demand where + put_ bh (n :* sd) = put_ bh n *> case n of + C_00 -> return () + C_10 -> return () + _ -> put_ bh sd + get bh = get bh >>= \n -> case n of + C_00 -> return AbsDmd + C_10 -> return BotDmd + _ -> (n :*) <$> get bh + +instance Binary SubDemand where + put_ bh (Poly b sd) = putByte bh 0 *> put_ bh b *> put_ bh sd + put_ bh (Call n sd) = putByte bh 1 *> put_ bh n *> put_ bh sd + put_ bh (Prod b ds) = putByte bh 2 *> put_ bh b *> put_ bh ds + get bh = do + h <- getByte bh + case h of + 0 -> Poly <$> get bh <*> get bh + 1 -> mkCall <$> get bh <*> get bh + 2 -> Prod <$> get bh <*> get bh + _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int)) + +instance Binary Divergence where + put_ bh Dunno = putByte bh 0 + put_ bh ExnOrDiv = putByte bh 1 + put_ bh Diverges = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return Dunno + 1 -> return ExnOrDiv + 2 -> return Diverges + _ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int)) + +instance Binary DmdEnv where + -- Ignore VarEnv when spitting out the DmdType + put_ bh (DE _ d) = put_ bh d + get bh = DE emptyVarEnv <$> get bh + +instance Binary DmdType where + put_ bh (DmdType fv ds) = put_ bh fv *> put_ bh ds + get bh = DmdType <$> get bh <*> get bh + +instance Binary DmdSig where + put_ bh (DmdSig aa) = put_ bh aa + get bh = DmdSig <$> get bh diff --git a/GHC/Types/Error.hs b/GHC/Types/Error.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Error.hs @@ -0,0 +1,921 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} + +module GHC.Types.Error + ( -- * Messages + Messages + , mkMessages + , getMessages + , emptyMessages + , isEmptyMessages + , singleMessage + , addMessage + , unionMessages + , unionManyMessages + , filterMessages + , MsgEnvelope (..) + + -- * Classifying Messages + + , MessageClass (..) + , Severity (..) + , Diagnostic (..) + , UnknownDiagnostic (..) + , UnknownDiagnosticFor + , mkSimpleUnknownDiagnostic + , mkUnknownDiagnostic + , embedUnknownDiagnostic + , DiagnosticMessage (..) + , DiagnosticReason (WarningWithFlag, ..) + , ResolvedDiagnosticReason(..) + , mkPlainDiagnostic + , mkPlainError + , mkDecoratedDiagnostic + , mkDecoratedError + + , pprDiagnostic + + , HasDefaultDiagnosticOpts(..) + , defaultDiagnosticOpts + , NoDiagnosticOpts(..) + + -- * Hints and refactoring actions + , GhcHint (..) + , AvailableBindings(..) + , LanguageExtensionHint(..) + , suggestExtension + , suggestExtensionWithInfo + , suggestExtensions + , suggestExtensionsWithInfo + , suggestAnyExtension + , suggestAnyExtensionWithInfo + , useExtensionInOrderTo + , noHints + + -- * Rendering Messages + + , SDoc + , DecoratedSDoc (unDecorated) + , mkDecorated, mkSimpleDecorated + , unionDecoratedSDoc + , mapDecoratedSDoc + + , pprMessageBag + , mkLocMessage + , mkLocMessageWarningGroups + , getCaretDiagnostic + -- * Queries + , isIntrinsicErrorMessage + , isExtrinsicErrorMessage + , isWarningMessage + , getErrorMessages + , getWarningMessages + , partitionMessages + , errorsFound + , errorsOrFatalWarningsFound + + -- * Diagnostic codes + , DiagnosticCode(..) + ) +where + +import GHC.Prelude + +import GHC.Driver.Flags + +import GHC.Data.Bag +import GHC.IO (catchException) +import GHC.Utils.Outputable as Outputable +import qualified GHC.Utils.Ppr.Colour as Col +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Hint +import GHC.Data.FastString (unpackFS) +import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) + +import GHC.Types.Hint.Ppr () -- Outputable instance +import GHC.Unit.Module.Warnings (WarningCategory(..)) + +import GHC.Utils.Json +import GHC.Utils.Panic + +import GHC.Version (cProjectVersion) +import Data.Bifunctor +import Data.Foldable ( fold, toList ) +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified Data.List.NonEmpty as NE +import Data.List ( intercalate ) +import Data.Maybe ( maybeToList ) +import Data.Typeable ( Typeable ) +import Numeric.Natural ( Natural ) +import Text.Printf ( printf ) + +{- Note [Messages] +~~~~~~~~~~~~~~~~~~ +We represent the 'Messages' as a single bag of warnings and errors. + +The reason behind that is that there is a fluid relationship between errors +and warnings and we want to be able to promote or demote errors and warnings +based on certain flags (e.g. -Werror, -fdefer-type-errors or +-XPartialTypeSignatures). More specifically, every diagnostic has a +'DiagnosticReason', but a warning 'DiagnosticReason' might be associated with +'SevError', in the case of -Werror. + +We rely on the 'Severity' to distinguish between a warning and an error. + +'WarningMessages' and 'ErrorMessages' are for now simple type aliases to +retain backward compatibility, but in future iterations these can be either +parameterised over an 'e' message type (to make type signatures a bit more +declarative) or removed altogether. +-} + +-- | A collection of messages emitted by GHC during error reporting. A +-- diagnostic message is typically a warning or an error. See Note [Messages]. +-- +-- /INVARIANT/: All the messages in this collection must be relevant, i.e. +-- their 'Severity' should /not/ be 'SevIgnore'. The smart constructor +-- 'mkMessages' will filter out any message which 'Severity' is 'SevIgnore'. +newtype Messages e = Messages { getMessages :: Bag (MsgEnvelope e) } + deriving newtype (Semigroup, Monoid) + deriving stock (Functor, Foldable, Traversable) + +emptyMessages :: Messages e +emptyMessages = Messages emptyBag + +mkMessages :: Bag (MsgEnvelope e) -> Messages e +mkMessages = Messages . filterBag interesting + where + interesting :: MsgEnvelope e -> Bool + interesting = (/=) SevIgnore . errMsgSeverity + +isEmptyMessages :: Messages e -> Bool +isEmptyMessages (Messages msgs) = isEmptyBag msgs + +singleMessage :: MsgEnvelope e -> Messages e +singleMessage e = addMessage e emptyMessages + +instance Diagnostic e => Outputable (Messages e) where + ppr msgs = braces (vcat (map ppr_one (bagToList (getMessages msgs)))) + where + ppr_one :: MsgEnvelope e -> SDoc + ppr_one envelope = + vcat [ text "Resolved:" <+> ppr (errMsgReason envelope), + pprDiagnostic (errMsgDiagnostic envelope) + ] + +instance (Diagnostic e) => ToJson (Messages e) where + json msgs = JSArray . toList $ json <$> getMessages msgs + +{- Note [Discarding Messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Discarding a 'SevIgnore' message from 'addMessage' and 'unionMessages' is just +an optimisation, as GHC would /also/ suppress any diagnostic which severity is +'SevIgnore' before printing the message: See for example 'putLogMsg' and +'defaultLogAction'. + +-} + +-- | Adds a 'Message' to the input collection of messages. +-- See Note [Discarding Messages]. +addMessage :: MsgEnvelope e -> Messages e -> Messages e +addMessage x (Messages xs) + | SevIgnore <- errMsgSeverity x = Messages xs + | otherwise = Messages (x `consBag` xs) + +-- | Joins two collections of messages together. +-- See Note [Discarding Messages]. +unionMessages :: Messages e -> Messages e -> Messages e +unionMessages (Messages msgs1) (Messages msgs2) = + Messages (msgs1 `unionBags` msgs2) + +-- | Joins many 'Messages's together +unionManyMessages :: Foldable f => f (Messages e) -> Messages e +unionManyMessages = fold + +filterMessages :: (MsgEnvelope e -> Bool) -> Messages e -> Messages e +filterMessages f (Messages msgs) = + Messages (filterBag f msgs) + +-- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the +-- invariant that the input '[SDoc]' needs to be rendered /decorated/ into its +-- final form, where the typical case would be adding bullets between each +-- elements of the list. The type of decoration depends on the formatting +-- function used, but in practice GHC uses the 'formatBulleted'. +newtype DecoratedSDoc = Decorated { unDecorated :: [SDoc] } + +-- | Creates a new 'DecoratedSDoc' out of a list of 'SDoc'. +mkDecorated :: [SDoc] -> DecoratedSDoc +mkDecorated = Decorated + +-- | Creates a new 'DecoratedSDoc' out of a single 'SDoc' +mkSimpleDecorated :: SDoc -> DecoratedSDoc +mkSimpleDecorated doc = Decorated [doc] + +-- | Joins two 'DecoratedSDoc' together. The resulting 'DecoratedSDoc' +-- will have a number of entries which is the sum of the lengths of +-- the input. +unionDecoratedSDoc :: DecoratedSDoc -> DecoratedSDoc -> DecoratedSDoc +unionDecoratedSDoc (Decorated s1) (Decorated s2) = + Decorated (s1 `mappend` s2) + +-- | Apply a transformation function to all elements of a 'DecoratedSDoc'. +mapDecoratedSDoc :: (SDoc -> SDoc) -> DecoratedSDoc -> DecoratedSDoc +mapDecoratedSDoc f (Decorated s1) = + Decorated (map f s1) + +class HasDefaultDiagnosticOpts opts where + defaultOpts :: opts + + +defaultDiagnosticOpts :: forall opts . HasDefaultDiagnosticOpts (DiagnosticOpts opts) => DiagnosticOpts opts +defaultDiagnosticOpts = defaultOpts @(DiagnosticOpts opts) + + + + +-- | A class identifying a diagnostic. +-- Dictionary.com defines a diagnostic as: +-- +-- \"a message output by a computer diagnosing an error in a computer program, +-- computer system, or component device\". +-- +-- A 'Diagnostic' carries the /actual/ description of the message (which, in +-- GHC's case, it can be an error or a warning) and the /reason/ why such +-- message was generated in the first place. +class (Outputable (DiagnosticHint a), HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where + + -- | Type of configuration options for the diagnostic. + type DiagnosticOpts a + + -- | Type of hint this diagnostic can provide. + -- By default, this is 'GhcHint'. + type DiagnosticHint a + type DiagnosticHint a = GhcHint + + -- | Extract the error message text from a 'Diagnostic'. + diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc + + -- | Extract the reason for this diagnostic. For warnings, + -- a 'DiagnosticReason' includes the warning flag. + diagnosticReason :: a -> DiagnosticReason + + -- | Extract any hints a user might use to repair their + -- code to avoid this diagnostic. + diagnosticHints :: a -> [DiagnosticHint a] + + -- | Get the 'DiagnosticCode' associated with this 'Diagnostic'. + -- This can return 'Nothing' for at least two reasons: + -- + -- 1. The message might be from a plugin that does not supply codes. + -- 2. The message might not yet have been assigned a code. See the + -- 'Diagnostic' instance for 'DiagnosticMessage'. + -- + -- Ideally, case (2) would not happen, but because + -- some errors in GHC still use the old system of just writing the + -- error message in-place (instead of using a dedicated error type + -- and constructor), we do not have error codes for all errors. + -- #18516 tracks our progress toward this goal. + diagnosticCode :: a -> Maybe DiagnosticCode + +-- | An existential wrapper around an unknown diagnostic. +data UnknownDiagnostic opts hint where + UnknownDiagnostic :: (Diagnostic a, Typeable a) + => (opts -> DiagnosticOpts a) -- Inject the options of the outer context + -- into the options for the wrapped diagnostic. + -> (DiagnosticHint a -> hint) + -> a + -> UnknownDiagnostic opts hint + +type UnknownDiagnosticFor a = UnknownDiagnostic (DiagnosticOpts a) (DiagnosticHint a) + +instance (HasDefaultDiagnosticOpts opts, Outputable hint) => Diagnostic (UnknownDiagnostic opts hint) where + type DiagnosticOpts (UnknownDiagnostic opts _) = opts + type DiagnosticHint (UnknownDiagnostic _ hint) = hint + diagnosticMessage opts (UnknownDiagnostic f _ diag) = diagnosticMessage (f opts) diag + diagnosticReason (UnknownDiagnostic _ _ diag) = diagnosticReason diag + diagnosticHints (UnknownDiagnostic _ f diag) = map f (diagnosticHints diag) + diagnosticCode (UnknownDiagnostic _ _ diag) = diagnosticCode diag + +-- A fallback 'DiagnosticOpts' which can be used when there are no options +-- for a particular diagnostic. +data NoDiagnosticOpts = NoDiagnosticOpts +instance HasDefaultDiagnosticOpts NoDiagnosticOpts where + defaultOpts = NoDiagnosticOpts + +-- | Make a "simple" unknown diagnostic which doesn't have any configuration options +-- and the same hint. +mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) => + a -> UnknownDiagnostic b (DiagnosticHint a) +mkSimpleUnknownDiagnostic = UnknownDiagnostic (const NoDiagnosticOpts) id + +-- | Make an unknown diagnostic which uses the same options and hint +-- as the context it will be embedded into. +mkUnknownDiagnostic :: (Typeable a, Diagnostic a) => + a -> UnknownDiagnosticFor a +mkUnknownDiagnostic = UnknownDiagnostic id id + +-- | Embed a more complicated diagnostic which requires a potentially different options type. +embedUnknownDiagnostic :: (Diagnostic a, Typeable a) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts (DiagnosticHint a) +embedUnknownDiagnostic f = UnknownDiagnostic f id + +-------------------------------------------------------------------------------- + +pprDiagnostic :: forall e . Diagnostic e => e -> SDoc +pprDiagnostic e = vcat [ ppr (diagnosticReason e) + , nest 2 (vcat (unDecorated (diagnosticMessage opts e))) ] + where opts = defaultDiagnosticOpts @e + + +-- | A generic 'Diagnostic' message, without any further classification or +-- provenance: By looking at a 'DiagnosticMessage' we don't know neither +-- /where/ it was generated nor how to interpret its payload (as it's just a +-- structured document). All we can do is to print it out and look at its +-- 'DiagnosticReason'. +data DiagnosticMessage = DiagnosticMessage + { diagMessage :: !DecoratedSDoc + , diagReason :: !DiagnosticReason + , diagHints :: [GhcHint] + } + +instance Diagnostic DiagnosticMessage where + type DiagnosticOpts DiagnosticMessage = NoDiagnosticOpts + diagnosticMessage _ = diagMessage + diagnosticReason = diagReason + diagnosticHints = diagHints + diagnosticCode _ = Nothing + +-- | Helper function to use when no hints can be provided. Currently this function +-- can be used to construct plain 'DiagnosticMessage' and add hints to them, but +-- once #18516 will be fully executed, the main usage of this function would be in +-- the implementation of the 'diagnosticHints' typeclass method, to report the fact +-- that a particular 'Diagnostic' has no hints. +noHints :: [GhcHint] +noHints = mempty + +mkPlainDiagnostic :: DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage +mkPlainDiagnostic rea hints doc = DiagnosticMessage (mkSimpleDecorated doc) rea hints + +-- | Create an error 'DiagnosticMessage' holding just a single 'SDoc' +mkPlainError :: [GhcHint] -> SDoc -> DiagnosticMessage +mkPlainError hints doc = DiagnosticMessage (mkSimpleDecorated doc) ErrorWithoutFlag hints + +-- | Create a 'DiagnosticMessage' from a list of bulleted SDocs and a 'DiagnosticReason' +mkDecoratedDiagnostic :: DiagnosticReason -> [GhcHint] -> [SDoc] -> DiagnosticMessage +mkDecoratedDiagnostic rea hints docs = DiagnosticMessage (mkDecorated docs) rea hints + +-- | Create an error 'DiagnosticMessage' from a list of bulleted SDocs +mkDecoratedError :: [GhcHint] -> [SDoc] -> DiagnosticMessage +mkDecoratedError hints docs = DiagnosticMessage (mkDecorated docs) ErrorWithoutFlag hints + +-- | The reason /why/ a 'Diagnostic' was emitted in the first place. +-- Diagnostic messages are born within GHC with a very precise reason, which +-- can be completely statically-computed (i.e. this is an error or a warning +-- no matter what), or influenced by the specific state of the 'DynFlags' at +-- the moment of the creation of a new 'Diagnostic'. For example, a parsing +-- error is /always/ going to be an error, whereas a 'WarningWithoutFlag +-- Opt_WarnUnusedImports' might turn into an error due to '-Werror' or +-- '-Werror=warn-unused-imports'. Interpreting a 'DiagnosticReason' together +-- with its associated 'Severity' gives us the full picture. +data DiagnosticReason + = WarningWithoutFlag + -- ^ Born as a warning. + | WarningWithFlags !(NE.NonEmpty WarningFlag) + -- ^ Warning was enabled with the flag. + | WarningWithCategory !WarningCategory + -- ^ Warning was enabled with a custom category. + | ErrorWithoutFlag + -- ^ Born as an error. + deriving (Eq, Show) + +-- | Like a 'DiagnosticReason', but resolved against a specific set of `DynFlags` to +-- work out which warning flag actually enabled this warning. +newtype ResolvedDiagnosticReason + = ResolvedDiagnosticReason { resolvedDiagnosticReason :: DiagnosticReason } + +-- | The single warning case 'DiagnosticReason' is very common. +pattern WarningWithFlag :: WarningFlag -> DiagnosticReason +pattern WarningWithFlag w = WarningWithFlags (w :| []) + +{- Note [Warnings controlled by multiple flags] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Diagnostics that started life as flag-controlled warnings have a +'diagnosticReason' of 'WarningWithFlags', giving the flags that control the +warning. Usually there is only one flag, but in a few cases multiple flags +apply. Where there are more than one, they are listed highest-priority first. + +For example, the same exported binding may give rise to a warning if either +`-Wmissing-signatures` or `-Wmissing-exported-signatures` is enabled. Here +`-Wmissing-signatures` has higher priority, because we want to mention it if +before are enabled. See `missingSignatureWarningFlags` for the specific logic +in this case. + +When reporting such a warning to the user, it is important to mention the +correct flag (e.g. `-Wmissing-signatures` if it is enabled, or +`-Wmissing-exported-signatures` if only the latter is enabled). Thus +`diag_reason_severity` filters the `DiagnosticReason` based on the currently +active `DiagOpts`. For a `WarningWithFlags` it returns only the flags that are +enabled; it leaves other `DiagnosticReason`s unchanged. This is then wrapped +in a `ResolvedDiagnosticReason` newtype which records that this filtering has +taken place. + +If we have `-Wmissing-signatures -Werror=missing-exported-signatures` we want +the error to mention `-Werror=missing-exported-signatures` (even though +`-Wmissing-signatures` would normally take precedence). Thus if there are any +fatal warnings, `diag_reason_severity` returns those alone. + +The `MsgEnvelope` stores the filtered `ResolvedDiagnosticReason` listing only the +relevant flags for subsequent display. + + +Side note: we do not treat `-Wmissing-signatures` as a warning group that +includes `-Wmissing-exported-signatures`, because + + (a) this would require us to provide a flag for the complement, and + + (b) currently, in `-Wmissing-exported-signatures -Wno-missing-signatures`, the + latter option does not switch off the former. +-} + +instance Outputable DiagnosticReason where + ppr = \case + WarningWithoutFlag -> text "WarningWithoutFlag" + WarningWithFlags wf -> text ("WarningWithFlags " ++ show wf) + WarningWithCategory cat -> text "WarningWithCategory" <+> ppr cat + ErrorWithoutFlag -> text "ErrorWithoutFlag" + +instance Outputable ResolvedDiagnosticReason where + ppr = ppr . resolvedDiagnosticReason + +-- | An envelope for GHC's facts about a running program, parameterised over the +-- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics. +-- +-- To say things differently, GHC emits /diagnostics/ about the running +-- program, each of which is wrapped into a 'MsgEnvelope' that carries +-- specific information like where the error happened, etc. Finally, multiple +-- 'MsgEnvelope's are aggregated into 'Messages' that are returned to the +-- user. +data MsgEnvelope e = MsgEnvelope + { errMsgSpan :: SrcSpan + -- ^ The SrcSpan is used for sorting errors into line-number order + , errMsgContext :: NamePprCtx + , errMsgDiagnostic :: e + , errMsgSeverity :: Severity + , errMsgReason :: ResolvedDiagnosticReason + -- ^ The actual reason caused this message + -- + -- See Note [Warnings controlled by multiple flags] + } deriving (Functor, Foldable, Traversable) + +-- | The class for a diagnostic message. The main purpose is to classify a +-- message within GHC, to distinguish it from a debug/dump message vs a proper +-- diagnostic, for which we include a 'DiagnosticReason'. +data MessageClass + = MCOutput + | MCFatal + | MCInteractive + + | MCDump + -- ^ Log message intended for compiler developers + -- No file\/line\/column stuff + + | MCInfo + -- ^ Log messages intended for end users. + -- No file\/line\/column stuff. + + | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) + -- ^ Diagnostics from the compiler. This constructor is very powerful as + -- it allows the construction of a 'MessageClass' with a completely + -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, + -- users are encouraged to use the 'mkMCDiagnostic' smart constructor + -- instead. Use this constructor directly only if you need to construct + -- and manipulate diagnostic messages directly, for example inside + -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when + -- emitting compiler diagnostics, use the smart constructor. + -- + -- The @Maybe 'DiagnosticCode'@ field carries a code (if available) for + -- this diagnostic. If you are creating a message not tied to any + -- error-message type, then use Nothing. In the long run, this really + -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. + +{- +Note [Suppressing Messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'SevIgnore' constructor is used to generate messages for diagnostics which +are meant to be suppressed and not reported to the user: the classic example +are warnings for which the user didn't enable the corresponding 'WarningFlag', +so GHC shouldn't print them. + +A different approach would be to extend the zoo of 'mkMsgEnvelope' functions +to return a 'Maybe (MsgEnvelope e)', so that we won't need to even create the +message to begin with. Both approaches have been evaluated, but we settled on +the "SevIgnore one" for a number of reasons: + +* It's less invasive to deal with; +* It plays slightly better with deferred diagnostics (see 'GHC.Tc.Errors') as + for those we need to be able to /always/ produce a message (so that is + reported at runtime); +* It gives us more freedom: we can still decide to drop a 'SevIgnore' message + at leisure, or we can decide to keep it around until the last moment. Maybe + in the future we would need to turn a 'SevIgnore' into something else, for + example to "unsuppress" diagnostics if a flag is set: with this approach, we + have more leeway to accommodate new features. + +-} + + +-- | Used to describe warnings and errors +-- o The message has a file\/line\/column heading, +-- plus "warning:" or "error:", +-- added by mkLocMessage +-- o With 'SevIgnore' the message is suppressed +-- o Output is intended for end users +data Severity + = SevIgnore + -- ^ Ignore this message, for example in + -- case of suppression of warnings users + -- don't want to see. See Note [Suppressing Messages] + | SevWarning + | SevError + deriving (Eq, Ord, Show) + +instance Outputable Severity where + ppr = \case + SevIgnore -> text "SevIgnore" + SevWarning -> text "SevWarning" + SevError -> text "SevError" + +instance ToJson Severity where + json SevIgnore = JSString "Ignore" + json SevWarning = JSString "Warning" + json SevError = JSString "Error" + +instance ToJson MessageClass where + json MCOutput = JSString "MCOutput" + json MCFatal = JSString "MCFatal" + json MCInteractive = JSString "MCInteractive" + json MCDump = JSString "MCDump" + json MCInfo = JSString "MCInfo" + json (MCDiagnostic sev reason code) = + JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code) + +instance ToJson DiagnosticCode where + json c = JSInt (fromIntegral (diagnosticCodeNumber c)) + +{- Note [Diagnostic Message JSON Schema] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The below instance of ToJson must conform to the JSON schema +specified in docs/users_guide/diagnostics-as-json-schema-1_1.json. +When the schema is altered, please bump the version. +If the content is altered in a backwards compatible way, +update the minor version (e.g. 1.3 ~> 1.4). +If the content is breaking, update the major version (e.g. 1.3 ~> 2.0). +When updating the schema, replace the above file and name it appropriately with +the version appended, and change the documentation of the -fdiagnostics-as-json +flag to reflect the new schema. +To learn more about JSON schemas, check out the below link: +https://json-schema.org +-} + +schemaVersion :: String +schemaVersion = "1.1" +-- See Note [Diagnostic Message JSON Schema] before editing! +instance Diagnostic e => ToJson (MsgEnvelope e) where + json m = JSObject $ [ + ("version", JSString schemaVersion), + ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion), + ("span", json $ errMsgSpan m), + ("severity", json $ errMsgSeverity m), + ("code", maybe JSNull json (diagnosticCode diag)), + ("message", JSArray $ map renderToJSString diagMsg), + ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ] + ++ [ ("reason", reasonJson) + | reasonJson <- maybeToList $ usefulReasonJson_maybe (errMsgReason m) ] + where + diag = errMsgDiagnostic m + opts = defaultDiagnosticOpts @e + ctx = defaultSDocContext { + sdocStyle = mkErrStyle (errMsgContext m) + , sdocCanUseUnicode = True + -- Using Unicode makes it easier to consume the JSON output, + -- e.g. a suggestion to use foldl' will be displayed as + -- \u2018foldl'\u2019, which is not easily confused with + -- the quoted ‘foldl’ (note: no tick). + } + diagMsg = filter (not . isEmpty ctx) (unDecorated (diagnosticMessage (opts) diag)) + renderToJSString :: SDoc -> JsonDoc + renderToJSString = JSString . (renderWithContext ctx) + + usefulReasonJson_maybe :: ResolvedDiagnosticReason -> Maybe JsonDoc + usefulReasonJson_maybe (ResolvedDiagnosticReason rea) = + case rea of + WarningWithoutFlag -> Nothing + ErrorWithoutFlag -> Nothing + WarningWithFlags flags -> + Just $ JSObject + [ ("flags", JSArray $ map (JSString . NE.head . warnFlagNames) (NE.toList flags)) + ] + WarningWithCategory (WarningCategory cat) -> + Just $ JSObject + [ ("category", JSString $ unpackFS cat) + ] + +instance Show (MsgEnvelope DiagnosticMessage) where + show = showMsgEnvelope + +-- | Shows an 'MsgEnvelope'. Only use this for debugging. +showMsgEnvelope :: forall a . Diagnostic a => MsgEnvelope a -> String +showMsgEnvelope err = + renderWithContext defaultSDocContext (vcat (unDecorated . (diagnosticMessage (defaultDiagnosticOpts @a)) $ errMsgDiagnostic err)) + +pprMessageBag :: Bag SDoc -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + +mkLocMessage + :: MessageClass -- ^ What kind of message? + -> SrcSpan -- ^ location + -> SDoc -- ^ message + -> SDoc +mkLocMessage = mkLocMessageWarningGroups True + +-- | Make an error message with location info, specifying whether to show +-- warning groups (if applicable). +mkLocMessageWarningGroups + :: Bool -- ^ Print warning groups (if applicable)? + -> MessageClass -- ^ What kind of message? + -> SrcSpan -- ^ location + -> SDoc -- ^ message + -> SDoc + -- Always print the location, even if it is unhelpful. Error messages + -- are supposed to be in a standard format, and one without a location + -- would look strange. Better to say explicitly "". +mkLocMessageWarningGroups show_warn_groups msg_class locn msg + = sdocOption sdocColScheme $ \col_scheme -> + let locn' = sdocOption sdocErrorSpans $ \case + True -> ppr locn + False -> ppr (srcSpanStart locn) + + msg_colour = getMessageClassColour msg_class col_scheme + col = coloured msg_colour . text + + msg_title = coloured msg_colour $ + case msg_class of + MCDiagnostic SevError _ _ -> text "error" + MCDiagnostic SevWarning _ _ -> text "warning" + MCFatal -> text "fatal" + _ -> empty + + warning_flag_doc = + case msg_class of + MCDiagnostic sev reason _code + | Just msg <- flag_msg sev (resolvedDiagnosticReason reason) + -> brackets msg + _ -> empty + + ppr_with_hyperlink code = + -- this is a bit hacky, but we assume that if the terminal supports colors + -- then it should also support links + sdocOption (\ ctx -> sdocPrintErrIndexLinks ctx) $ + \ use_hyperlinks -> + if use_hyperlinks + then ppr $ LinkedDiagCode code + else ppr code + + code_doc = + case msg_class of + MCDiagnostic _ _ (Just code) -> brackets (ppr_with_hyperlink code) + _ -> empty + + flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc + flag_msg SevIgnore _ = Nothing + -- The above can happen when displaying an error message + -- in a log file, e.g. with -ddump-tc-trace. It should not + -- happen otherwise, though. + flag_msg SevError WarningWithoutFlag = Just (col "-Werror") + flag_msg SevError (WarningWithFlags (wflag :| _)) = + let name = NE.head (warnFlagNames wflag) in + Just $ col ("-W" ++ name) <+> warn_flag_grp (smallestWarningGroups wflag) + <> comma + <+> col ("Werror=" ++ name) + flag_msg SevError (WarningWithCategory cat) = + Just $ coloured msg_colour (text "-W" <> ppr cat) + <+> warn_flag_grp smallestWarningGroupsForCategory + <> comma + <+> coloured msg_colour (text "-Werror=" <> ppr cat) + flag_msg SevError ErrorWithoutFlag = Nothing + flag_msg SevWarning WarningWithoutFlag = Nothing + flag_msg SevWarning (WarningWithFlags (wflag :| _)) = + let name = NE.head (warnFlagNames wflag) in + Just (col ("-W" ++ name) <+> warn_flag_grp (smallestWarningGroups wflag)) + flag_msg SevWarning (WarningWithCategory cat) = + Just (coloured msg_colour (text "-W" <> ppr cat) + <+> warn_flag_grp smallestWarningGroupsForCategory) + flag_msg SevWarning ErrorWithoutFlag = + pprPanic "SevWarning with ErrorWithoutFlag" $ + vcat [ text "locn:" <+> ppr locn + , text "msg:" <+> ppr msg ] + + warn_flag_grp groups + | show_warn_groups, not (null groups) + = text $ "(in " ++ intercalate ", " (map (("-W"++) . warningGroupName) groups) ++ ")" + | otherwise = empty + + -- Add prefixes, like Foo.hs:34: warning: + -- + header = locn' <> colon <+> + msg_title <> colon <+> + code_doc <+> warning_flag_doc + + in coloured (Col.sMessage col_scheme) + (hang (coloured (Col.sHeader col_scheme) header) 4 + msg) + +getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour +getMessageClassColour (MCDiagnostic SevError _reason _code) = Col.sError +getMessageClassColour (MCDiagnostic SevWarning _reason _code) = Col.sWarning +getMessageClassColour MCFatal = Col.sFatal +getMessageClassColour _ = const mempty + +getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc +getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty +getCaretDiagnostic msg_class (RealSrcSpan span _) = + caretDiagnostic <$> getSrcLine (srcSpanFile span) row + where + getSrcLine fn i = + getLine i (unpackFS fn) + `catchException` \(_ :: IOError) -> + pure Nothing + + getLine i fn = do + -- StringBuffer has advantages over readFile: + -- (a) no lazy IO, otherwise IO exceptions may occur in pure code + -- (b) always UTF-8, rather than some system-dependent encoding + -- (Haskell source code must be UTF-8 anyway) + content <- hGetStringBuffer fn + case atLine i content of + Just at_line -> pure $ + case lines (fix <$> lexemeToString at_line (len at_line)) of + srcLine : _ -> Just srcLine + _ -> Nothing + _ -> pure Nothing + + -- allow user to visibly see that their code is incorrectly encoded + -- (StringBuffer.nextChar uses \0 to represent undecodable characters) + fix '\0' = '\xfffd' + fix c = c + + row = srcSpanStartLine span + rowStr = show row + multiline = row /= srcSpanEndLine span + + caretDiagnostic Nothing = empty + caretDiagnostic (Just srcLineWithNewline) = + sdocOption sdocColScheme$ \col_scheme -> + let sevColour = getMessageClassColour msg_class col_scheme + marginColour = Col.sMargin col_scheme + in + coloured marginColour (text marginSpace) <> + text ("\n") <> + coloured marginColour (text marginRow) <> + text (" " ++ srcLinePre) <> + coloured sevColour (text srcLineSpan) <> + text (srcLinePost ++ "\n") <> + coloured marginColour (text marginSpace) <> + coloured sevColour (text (" " ++ caretLine)) + + where + + -- expand tabs in a device-independent manner #13664 + expandTabs tabWidth i s = + case s of + "" -> "" + '\t' : cs -> replicate effectiveWidth ' ' ++ + expandTabs tabWidth (i + effectiveWidth) cs + c : cs -> c : expandTabs tabWidth (i + 1) cs + where effectiveWidth = tabWidth - i `mod` tabWidth + + srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline) + + start = srcSpanStartCol span - 1 + end | multiline = length srcLine + | otherwise = srcSpanEndCol span - 1 + width = max 1 (end - start) + + marginWidth = length rowStr + marginSpace = replicate marginWidth ' ' ++ " |" + marginRow = rowStr ++ " |" + + (srcLinePre, srcLineRest) = splitAt start srcLine + (srcLineSpan, srcLinePost) = splitAt width srcLineRest + + caretEllipsis | multiline = "..." + | otherwise = "" + caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis + +-- +-- Queries +-- + +{- Note [Intrinsic And Extrinsic Failures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We distinguish between /intrinsic/ and /extrinsic/ failures. We classify in +the former category those diagnostics which are /essentially/ failures, and +their nature can't be changed. This is the case for 'ErrorWithoutFlag'. We +classify as /extrinsic/ all those diagnostics (like fatal warnings) which are +born as warnings but which are still failures under particular 'DynFlags' +settings. It's important to be aware of such logic distinction, because when +we are inside the typechecker or the desugarer, we are interested about +intrinsic errors, and to bail out as soon as we find one of them. Conversely, +if we find an /extrinsic/ one, for example because a particular 'WarningFlag' +makes a warning into an error, we /don't/ want to bail out, that's still not the +right time to do so: Rather, we want to first collect all the diagnostics, and +later classify and report them appropriately (in the driver). +-} + +-- | Returns 'True' if this is, intrinsically, a failure. See +-- Note [Intrinsic And Extrinsic Failures]. +isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool +isIntrinsicErrorMessage = (==) ErrorWithoutFlag . resolvedDiagnosticReason . errMsgReason + +isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool +isWarningMessage = not . isIntrinsicErrorMessage + +-- | Are there any hard errors here? -Werror warnings are /not/ detected. If +-- you want to check for -Werror warnings, use 'errorsOrFatalWarningsFound'. +errorsFound :: Diagnostic e => Messages e -> Bool +errorsFound (Messages msgs) = any isIntrinsicErrorMessage msgs + +-- | Returns 'True' if the envelope contains a message that will stop +-- compilation: either an intrinsic error or a fatal (-Werror) warning +isExtrinsicErrorMessage :: MsgEnvelope e -> Bool +isExtrinsicErrorMessage = (==) SevError . errMsgSeverity + +-- | Are there any errors or -Werror warnings here? +errorsOrFatalWarningsFound :: Messages e -> Bool +errorsOrFatalWarningsFound (Messages msgs) = any isExtrinsicErrorMessage msgs + +getWarningMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e) +getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs + +getErrorMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e) +getErrorMessages (Messages xs) = fst $ partitionBag isIntrinsicErrorMessage xs + +-- | Partitions the 'Messages' and returns a tuple which first element are the +-- warnings, and the second the errors. +partitionMessages :: Diagnostic e => Messages e -> (Messages e, Messages e) +partitionMessages (Messages xs) = bimap Messages Messages (partitionBag isWarningMessage xs) + +---------------------------------------------------------------- +-- -- +-- Definition of diagnostic codes -- +-- -- +---------------------------------------------------------------- + +-- | A diagnostic code is a namespaced numeric identifier +-- unique to the given diagnostic (error or warning). +-- +-- All diagnostic codes defined within GHC are given the +-- GHC namespace. +-- +-- See Note [Diagnostic codes] in GHC.Types.Error.Codes. +data DiagnosticCode = + DiagnosticCode + { diagnosticCodeNameSpace :: String + -- ^ diagnostic code prefix (e.g. "GHC") + , diagnosticCodeNumber :: Natural + -- ^ the actual diagnostic code + } + deriving ( Eq, Ord ) + +instance Show DiagnosticCode where + show (DiagnosticCode prefix c) = + prefix ++ "-" ++ printf "%05d" c + -- pad the numeric code to have at least 5 digits + +instance Outputable DiagnosticCode where + ppr code = text (show code) + +-- | A newtype that is a witness to the `-fprint-error-index-links` flag. It +-- alters the @Outputable@ instance to emit @DiagnosticCode@ as ANSI hyperlinks +-- to the HF error index +newtype LinkedDiagCode = LinkedDiagCode DiagnosticCode + +instance Outputable LinkedDiagCode where + ppr (LinkedDiagCode d@DiagnosticCode{}) = linkEscapeCode d + +-- | Wrap the link in terminal escape codes specified by OSC 8. +linkEscapeCode :: DiagnosticCode -> SDoc +linkEscapeCode d = text "\ESC]8;;" <> hfErrorLink d -- make the actual link + <> text "\ESC\\" <> ppr d <> text "\ESC]8;;\ESC\\" -- the rest is the visible text + +-- | create a link to the HF error index given an error code. +hfErrorLink :: DiagnosticCode -> SDoc +hfErrorLink errorCode = text "https://errors.haskell.org/messages/" <> ppr errorCode diff --git a/GHC/Types/Error/Codes.hs b/GHC/Types/Error/Codes.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Error/Codes.hs @@ -0,0 +1,1471 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Defines diagnostic codes for the diagnostics emitted by GHC. +-- +-- A diagnostic code is a numeric unique identifier for a diagnostic. +-- See Note [Diagnostic codes]. +module GHC.Types.Error.Codes + ( -- * General diagnostic code infrastructure + DiagnosticCodeNameSpace(NameSpaceTag, DiagnosticCodeFor, ConRecursIntoFor) + , Outdated + , constructorCode, constructorCodes + -- * GHC diagnostic codes + , GHC, GhcDiagnosticCode, ConRecursInto + ) + where + +import GHC.Prelude + +import GHC.Core.InstEnv ( LookupInstanceErrReason ) +import GHC.Hs.Extension ( GhcRn ) +import GHC.Types.Error ( DiagnosticCode(..), UnknownDiagnostic (..) + , diagnosticCode, UnknownDiagnosticFor ) + +import GHC.Iface.Errors.Types +import GHC.Driver.Errors.Types ( DriverMessage ) +import GHC.Parser.Errors.Types ( PsMessage, PsHeaderMessage ) +import GHC.HsToCore.Errors.Types ( DsMessage, UselessSpecialisePragmaReason ) +import GHC.Tc.Errors.Types +import GHC.Unit.Module.Warnings ( WarningTxt ) +import GHC.Utils.Panic.Plain + +-- Import all the structured error data types +import GHC.Driver.Errors.Types ( GhcMessage ) + +import Data.Kind ( Type, Constraint ) +import GHC.Exts ( proxy# ) +import GHC.Generics +import GHC.TypeLits ( Symbol, KnownSymbol, symbolVal' + , TypeError, ErrorMessage(..) ) +import GHC.TypeNats ( Nat, KnownNat, natVal' ) + +import Data.Map.Strict ( Map ) +import qualified Data.Map.Strict as Map + + +{- Note [Diagnostic codes] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every time a new diagnostic (error or warning) is introduced to GHC, +it is assigned a new numeric code, which has never been used before. + +To ensure uniqueness across GHC versions, we proceed as follows: + + - all diagnostic codes are defined in a single module, GHC.Types.Error.Codes. + - uniqueness of diagnostic codes is ensured by the use of an injective type family, + GhcDiagnosticCode, + - a diagnostic code never gets deleted from the GhcDiagnosticCode type family + in GHC.Types.Error.Codes, even if it is no longer used. + Older versions of GHC might still display the code, and we don't want that + old code to get confused with the error code of a different, new, error message.* + +Note that this module also provides a 'DiagnosticCodeNameSpace' typeclass which +allows diagnostic codes to be emitted in different namespaces than the GHC +namespace; see Note [Diagnostic code namespaces]. + +[Instructions for adding a new diagnostic code] + + After adding a constructor to a diagnostic datatype, such as PsMessage, + TcRnMessage, DsMessage or DriverMessage, you can add corresponding + diagnostic codes as follows: + + a. To give a single diagnostic code to the constructor, simply add a + type family equation to GHC.Error.Codes.GhcDiagnosticCode, e.g.: + + GhcDiagnosticCode "MyNewErrorConstructor" = 12345 + + You can obtain new randomly-generated error codes by using + https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain + + You will get a type error if you try to use an error code that is already + used by another constructor. + + b. If you instead require more granular diagnostic codes, add a type family + equation to GHC.Error.Codes.ConRecursInto, specifying which argument + to recur into to obtain an diagnostic code. + + For example, the 'TcRnCannotDeriveInstance' constructor is associated + with several diagnostic codes, depending on the value of the argument of + type 'DeriveInstanceErrReason'. This is achieved as follows: + + - The equation + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + says to recur into the argument of type 'DeriveInstanceErrReason' + to get a diagnostic code. + + - The equations + GhcDiagnosticCode "DerivErrNotWellKinded" = 62016 + GhcDiagnosticCode "DerivErrSafeHaskellGenericInst" = 07214 + GhcDiagnosticCode "DerivErrDerivingViaWrongKind" = 63174 + ... + give the diagnostic codes for the various constructors of DeriveInstanceErrReason. + These are added following the procedure in (a). + + Never remove a return value from the 'GhcDiagnosticCode' type family! + Outdated error messages must still be tracked to ensure uniqueness + of diagnostic codes across GHC versions. Instead, you should wrap the + return value in the 'Outdated' type synonym. The presence of this type synonym + is used by the 'codes' test to determine which diagnostic codes to check + for testsuite coverage. +-} + +{- ********************************************************************* +* * + DiagnosticCode infrastructure +* * +********************************************************************* -} + +{- Note [Diagnostic code namespaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The machinery for GHC diagnostic codes described in Note [Diagnostic codes] +works for other namespaces than the GHC namespaces; one example is GHCi-specific +diagnostic codes. + +To achieve this, we parametrise all the machinery over a namespace type-level +argument, using the 'DiagnosticCodeNameSpace' class. +To provide diagnostic codes, one needs to supply an instance of this class, +which means supplying the following pieces of information: + + - a type that represents the namespace, e.g. `data GHC` can be used to + represent the GHC namespace, + - a type family equation for 'NameSpaceTag', e.g. 'NameSpaceTag GHC = "GHC"', + - a diagnostic code type family, e.g. 'DiagnosticCodeFor GHC con = GhcDiagnosticCode con', + - a type family that specifies how to recur into constructor arguments, + e.g. 'ConRecursIntoFor GHC con = ConRecursInto con'. + +This allows any tool that imports the GHC library to re-use the diagnostic +code machinery that GHC uses. +-} + +-- | A constraint for a namespace which has its own diagnostic codes. +-- +-- See Note [Diagnostic code namespaces]. +type DiagnosticCodeNameSpace :: Type -> Constraint +class DiagnosticCodeNameSpace namespace where + -- | The symbolic tag for a namespace. + type NameSpaceTag namespace = (r :: Symbol) | r -> namespace + -- NB: the injectivity annotation ensures uniqueness of namespaces, + -- e.g. it prevents two different namespaces from using the same symbolic tag. + -- | A diagnostic code in a given namespace. + type DiagnosticCodeFor namespace (c :: Symbol) :: Nat + -- | Specify that one should recur into an argument of a constructor + -- in order to obtain a diagnostic code. See Note [Diagnostic codes]. + type ConRecursIntoFor namespace (c :: Symbol) :: Maybe Type + +-- | Use this type synonym to mark a diagnostic code as outdated. +-- +-- The presence of this type synonym is used by the 'codes' test to determine +-- which diagnostic codes to check for testsuite coverage. +type Outdated a = a + +-- | This function obtains a diagnostic code by looking up the constructor +-- name using generics, and using the 'DiagnosticCode' type family. +constructorCode :: forall namespace diag + . (Generic diag, GDiagnosticCode namespace (Rep diag)) + => diag -> Maybe DiagnosticCode +constructorCode diag = gdiagnosticCode @namespace (from diag) + +-- | This function computes all diagnostic codes that occur inside a given +-- type using generics and the 'DiagnosticCode' type family. +-- +-- For example, if @T = MkT1 | MkT2@, @GhcDiagnosticCode \"MkT1\" = 123@ and +-- @GhcDiagnosticCode \"MkT2\" = 456@, then we will get +-- > constructorCodes @GHC @T = fromList [ (DiagnosticCode "GHC" 123, \"MkT1\"), (DiagnosticCode "GHC" 456, \"MkT2\") ] +constructorCodes :: forall namespace diag + . (Generic diag, GDiagnosticCodes namespace '[diag] (Rep diag)) + => Map DiagnosticCode String +constructorCodes = gdiagnosticCodes @namespace @'[diag] @(Rep diag) + -- See Note [diagnosticCodes: don't recur into already-seen types] + -- for the @'[diag] type argument. + +{- ********************************************************************* +* * + The GhcDiagnosticCode type family +* * +********************************************************************* -} + +-- | The GHC namespace for diagnostic codes. +data GHC +instance DiagnosticCodeNameSpace GHC where + type instance NameSpaceTag GHC = "GHC" + type instance DiagnosticCodeFor GHC con = GhcDiagnosticCode con + type instance ConRecursIntoFor GHC con = ConRecursInto con + +-- | Type family computing the numeric diagnostic code for a given error message constructor. +-- +-- Its injectivity annotation ensures uniqueness of error codes. +-- +-- Never remove a return value from this type family! Outdated error messages must still +-- be tracked here to ensure uniqueness of diagnostic codes across GHC versions. +-- +-- See Note [Diagnostic codes] in GHC.Types.Error. +type GhcDiagnosticCode :: Symbol -> Nat +type family GhcDiagnosticCode c = n | n -> c where + + -- Desugarer diagnostic codes + GhcDiagnosticCode "DsEmptyEnumeration" = 10190 + GhcDiagnosticCode "DsIdentitiesFound" = 04214 + GhcDiagnosticCode "DsOverflowedLiterals" = 97441 + GhcDiagnosticCode "DsRedundantBangPatterns" = 38520 + GhcDiagnosticCode "DsOverlappingPatterns" = 53633 + GhcDiagnosticCode "DsInaccessibleRhs" = 94210 + GhcDiagnosticCode "DsMaxPmCheckModelsReached" = 61505 + GhcDiagnosticCode "DsNonExhaustivePatterns" = 62161 + GhcDiagnosticCode "DsTopLevelBindsNotAllowed" = 48099 + GhcDiagnosticCode "DsOrphanRule" = 58181 + GhcDiagnosticCode "DsRuleLhsTooComplicated" = 69441 + GhcDiagnosticCode "DsRuleIgnoredDueToConstructor" = 00828 + GhcDiagnosticCode "DsRuleBindersNotBound" = 40548 + GhcDiagnosticCode "DsLazyPatCantBindVarsOfUnliftedType" = 17879 + GhcDiagnosticCode "DsNotYetHandledByTH" = 65904 + GhcDiagnosticCode "DsAggregatedViewExpressions" = 19551 + GhcDiagnosticCode "DsUnbangedStrictPatterns" = 21030 + GhcDiagnosticCode "DsCannotMixPolyAndUnliftedBindings" = 20036 + GhcDiagnosticCode "DsWrongDoBind" = 08838 + GhcDiagnosticCode "DsUnusedDoBind" = 81995 + GhcDiagnosticCode "DsRecBindsNotAllowedForUnliftedTys" = 20185 + GhcDiagnosticCode "DsRuleMightInlineFirst" = 95396 + GhcDiagnosticCode "DsAnotherRuleMightFireFirst" = 87502 + GhcDiagnosticCode "DsIncompleteRecordSelector" = 17335 + + -- Constructors of 'UselessSpecialisePragmaReason' + GhcDiagnosticCode "UselessSpecialiseForClassMethodSelector" = 93315 + GhcDiagnosticCode "UselessSpecialiseForNoInlineFunction" = 38524 + GhcDiagnosticCode "UselessSpecialiseNoSpecialisation" = 66582 + + -- Parser diagnostic codes + GhcDiagnosticCode "PsErrParseLanguagePragma" = 68686 + GhcDiagnosticCode "PsErrUnsupportedExt" = 46537 + GhcDiagnosticCode "PsErrParseOptionsPragma" = 24342 + GhcDiagnosticCode "PsErrUnknownOptionsPragma" = 04924 + GhcDiagnosticCode "PsWarnBidirectionalFormatChars" = 03272 + GhcDiagnosticCode "PsWarnTab" = 94817 + GhcDiagnosticCode "PsWarnTransitionalLayout" = 93617 + GhcDiagnosticCode "PsWarnOperatorWhitespaceExtConflict" = 47082 + GhcDiagnosticCode "PsWarnOperatorWhitespace" = 40798 + GhcDiagnosticCode "PsWarnHaddockInvalidPos" = 94458 + GhcDiagnosticCode "PsWarnHaddockIgnoreMulti" = 05641 + GhcDiagnosticCode "PsWarnStarBinder" = 21887 + GhcDiagnosticCode "PsWarnStarIsType" = 39567 + GhcDiagnosticCode "PsWarnUnrecognisedPragma" = 42044 + GhcDiagnosticCode "PsWarnMisplacedPragma" = 28007 + GhcDiagnosticCode "PsWarnImportPreQualified" = 07924 + GhcDiagnosticCode "PsWarnViewPatternSignatures" = 00834 + GhcDiagnosticCode "PsErrLexer" = 21231 + GhcDiagnosticCode "PsErrCmmLexer" = 75725 + GhcDiagnosticCode "PsErrCmmParser" = 09848 + GhcDiagnosticCode "PsErrParse" = 58481 + GhcDiagnosticCode "PsErrTypeAppWithoutSpace" = 84077 + GhcDiagnosticCode "PsErrLazyPatWithoutSpace" = 27207 + GhcDiagnosticCode "PsErrBangPatWithoutSpace" = 95644 + GhcDiagnosticCode "PsErrInvalidInfixHole" = 45106 + GhcDiagnosticCode "PsErrExpectedHyphen" = 44524 + GhcDiagnosticCode "PsErrSpaceInSCC" = 76176 + GhcDiagnosticCode "PsErrEmptyDoubleQuotes" = 11861 + GhcDiagnosticCode "PsErrLambdaCase" = 51179 + GhcDiagnosticCode "PsErrEmptyLambda" = 71614 + GhcDiagnosticCode "PsErrLinearFunction" = 31574 + GhcDiagnosticCode "PsErrMultiWayIf" = 28985 + GhcDiagnosticCode "PsErrOverloadedRecordUpdateNotEnabled" = 82135 + GhcDiagnosticCode "PsErrNumUnderscores" = 62330 + GhcDiagnosticCode "PsErrIllegalBangPattern" = 79767 + GhcDiagnosticCode "PsErrOverloadedRecordDotInvalid" = 26832 + GhcDiagnosticCode "PsErrIllegalPatSynExport" = 89515 + GhcDiagnosticCode "PsErrOverloadedRecordUpdateNoQualifiedFields" = 94863 + GhcDiagnosticCode "PsErrExplicitForall" = 25955 + GhcDiagnosticCode "PsErrIllegalQualifiedDo" = 40280 + GhcDiagnosticCode "PsErrQualifiedDoInCmd" = 54089 + GhcDiagnosticCode "PsErrRecordSyntaxInPatSynDecl" = 28021 + GhcDiagnosticCode "PsErrEmptyWhereInPatSynDecl" = 13248 + GhcDiagnosticCode "PsErrInvalidWhereBindInPatSynDecl" = 24737 + GhcDiagnosticCode "PsErrNoSingleWhereBindInPatSynDecl" = 65536 + GhcDiagnosticCode "PsErrDeclSpliceNotAtTopLevel" = 08451 + GhcDiagnosticCode "PsErrMultipleNamesInStandaloneKindSignature" = 42569 + GhcDiagnosticCode "PsErrIllegalExplicitNamespace" = 47007 + GhcDiagnosticCode "PsErrUnallowedPragma" = 85314 + GhcDiagnosticCode "PsErrImportPostQualified" = 87491 + GhcDiagnosticCode "PsErrImportQualifiedTwice" = 05661 + GhcDiagnosticCode "PsErrSpliceOrQuoteTwice" = 26105 + GhcDiagnosticCode "PsErrIllegalImportBundleForm" = 81284 + GhcDiagnosticCode "PsErrInvalidRuleActivationMarker" = 50396 + GhcDiagnosticCode "PsErrMissingBlock" = 16849 + GhcDiagnosticCode "PsErrUnsupportedBoxedSumExpr" = 09550 + GhcDiagnosticCode "PsErrUnsupportedBoxedSumPat" = 16863 + GhcDiagnosticCode "PsErrUnexpectedQualifiedConstructor" = 73413 + GhcDiagnosticCode "PsErrTupleSectionInPat" = 09646 + GhcDiagnosticCode "PsErrOpFewArgs" = 24180 + GhcDiagnosticCode "PsErrVarForTyCon" = 18208 + GhcDiagnosticCode "PsErrMalformedEntityString" = 26204 + GhcDiagnosticCode "PsErrDotsInRecordUpdate" = 70712 + GhcDiagnosticCode "PsErrInvalidDataCon" = 46574 + GhcDiagnosticCode "PsErrInvalidInfixDataCon" = 30670 + GhcDiagnosticCode "PsErrIllegalPromotionQuoteDataCon" = 80236 + GhcDiagnosticCode "PsErrUnpackDataCon" = 40845 + GhcDiagnosticCode "PsErrUnexpectedKindAppInDataCon" = 83653 + GhcDiagnosticCode "PsErrInvalidRecordCon" = 08195 + GhcDiagnosticCode "PsErrIllegalUnboxedStringInPat" = 69925 + GhcDiagnosticCode "PsErrIllegalUnboxedFloatingLitInPat" = 76595 + GhcDiagnosticCode "PsErrDoNotationInPat" = 06446 + GhcDiagnosticCode "PsErrIfThenElseInPat" = 45696 + GhcDiagnosticCode "PsErrLambdaCaseInPat" = Outdated 07636 + GhcDiagnosticCode "PsErrCaseInPat" = 53786 + GhcDiagnosticCode "PsErrLetInPat" = 78892 + GhcDiagnosticCode "PsErrLambdaInPat" = 00482 + GhcDiagnosticCode "PsErrArrowExprInPat" = 04584 + GhcDiagnosticCode "PsErrArrowCmdInPat" = 98980 + GhcDiagnosticCode "PsErrArrowCmdInExpr" = 66043 + GhcDiagnosticCode "PsErrViewPatInExpr" = Outdated 66228 + GhcDiagnosticCode "PsErrOrPatInExpr" = 66718 + GhcDiagnosticCode "PsErrLambdaCmdInFunAppCmd" = 12178 + GhcDiagnosticCode "PsErrCaseCmdInFunAppCmd" = 92971 + GhcDiagnosticCode "PsErrLambdaCaseCmdInFunAppCmd" = Outdated 47171 + GhcDiagnosticCode "PsErrIfCmdInFunAppCmd" = 97005 + GhcDiagnosticCode "PsErrLetCmdInFunAppCmd" = 70526 + GhcDiagnosticCode "PsErrDoCmdInFunAppCmd" = 77808 + GhcDiagnosticCode "PsErrDoInFunAppExpr" = 52095 + GhcDiagnosticCode "PsErrMDoInFunAppExpr" = 67630 + GhcDiagnosticCode "PsErrLambdaInFunAppExpr" = 06074 + GhcDiagnosticCode "PsErrCaseInFunAppExpr" = 25037 + GhcDiagnosticCode "PsErrLambdaCaseInFunAppExpr" = Outdated 77182 + GhcDiagnosticCode "PsErrLetInFunAppExpr" = 90355 + GhcDiagnosticCode "PsErrIfInFunAppExpr" = 01239 + GhcDiagnosticCode "PsErrProcInFunAppExpr" = 04807 + GhcDiagnosticCode "PsErrMalformedTyOrClDecl" = 47568 + GhcDiagnosticCode "PsErrIllegalWhereInDataDecl" = 36952 + GhcDiagnosticCode "PsErrIllegalDataTypeContext" = 87429 + GhcDiagnosticCode "PsErrPrimStringInvalidChar" = 43080 + GhcDiagnosticCode "PsErrSuffixAT" = 33856 + GhcDiagnosticCode "PsErrPrecedenceOutOfRange" = 25078 + GhcDiagnosticCode "PsErrSemiColonsInCondExpr" = 75254 + GhcDiagnosticCode "PsErrSemiColonsInCondCmd" = 18910 + GhcDiagnosticCode "PsErrAtInPatPos" = 08382 + GhcDiagnosticCode "PsErrParseErrorOnInput" = 66418 + GhcDiagnosticCode "PsErrMalformedDecl" = 85316 + GhcDiagnosticCode "PsErrNotADataCon" = 25742 + GhcDiagnosticCode "PsErrInferredTypeVarNotAllowed" = 57342 + GhcDiagnosticCode "PsErrIllegalTraditionalRecordSyntax" = 65719 + GhcDiagnosticCode "PsErrParseErrorInCmd" = 03790 + GhcDiagnosticCode "PsErrInPat" = 07626 + GhcDiagnosticCode "PsErrIllegalRoleName" = 09009 + GhcDiagnosticCode "PsErrInvalidTypeSignature" = 94426 + GhcDiagnosticCode "PsErrUnexpectedTypeInDecl" = 77878 + GhcDiagnosticCode "PsErrInvalidPackageName" = 21926 + GhcDiagnosticCode "PsErrParseRightOpSectionInPat" = 72516 + GhcDiagnosticCode "PsErrIllegalGadtRecordMultiplicity" = 37475 + GhcDiagnosticCode "PsErrInvalidCApiImport" = 72744 + GhcDiagnosticCode "PsErrMultipleConForNewtype" = 05380 + GhcDiagnosticCode "PsErrUnicodeCharLooksLike" = 31623 + GhcDiagnosticCode "PsErrInvalidPun" = 52943 + GhcDiagnosticCode "PsErrIllegalOrPat" = 29847 + GhcDiagnosticCode "PsErrTypeSyntaxInPat" = 32181 + GhcDiagnosticCode "PsErrSpecExprMultipleTypeAscription" = 62037 + GhcDiagnosticCode "PsWarnSpecMultipleTypeAscription" = 73026 + GhcDiagnosticCode "PsWarnPatternNamespaceSpecifier" = 68383 + + -- Driver diagnostic codes + GhcDiagnosticCode "DriverMissingHomeModules" = 32850 + GhcDiagnosticCode "DriverUnknownHiddenModules" = 38189 + GhcDiagnosticCode "DriverUnknownReexportedModules" = 68286 + GhcDiagnosticCode "DriverUnusedPackages" = 42258 + GhcDiagnosticCode "DriverUnnecessarySourceImports" = 88907 + GhcDiagnosticCode "DriverDuplicatedModuleDeclaration" = 29235 + GhcDiagnosticCode "DriverModuleNotFound" = 82272 + GhcDiagnosticCode "DriverFileModuleNameMismatch" = 28623 + GhcDiagnosticCode "DriverUnexpectedSignature" = 66004 + GhcDiagnosticCode "DriverFileNotFound" = 49196 + GhcDiagnosticCode "DriverStaticPointersNotSupported" = 77799 + GhcDiagnosticCode "DriverBackpackModuleNotFound" = 19971 + GhcDiagnosticCode "DriverUserDefinedRuleIgnored" = 56147 + GhcDiagnosticCode "DriverMixedSafetyImport" = 70172 + GhcDiagnosticCode "DriverCannotLoadInterfaceFile" = 37141 + GhcDiagnosticCode "DriverInferredSafeModule" = 58656 + GhcDiagnosticCode "DriverMarkedTrustworthyButInferredSafe" = 19244 + GhcDiagnosticCode "DriverInferredSafeImport" = 82658 + GhcDiagnosticCode "DriverCannotImportUnsafeModule" = 44360 + GhcDiagnosticCode "DriverMissingSafeHaskellMode" = 29747 + GhcDiagnosticCode "DriverPackageNotTrusted" = 08674 + GhcDiagnosticCode "DriverCannotImportFromUntrustedPackage" = 75165 + GhcDiagnosticCode "DriverRedirectedNoMain" = 95379 + GhcDiagnosticCode "DriverHomePackagesNotClosed" = 03271 + GhcDiagnosticCode "DriverInconsistentDynFlags" = 74335 + GhcDiagnosticCode "DriverSafeHaskellIgnoredExtension" = 98887 + GhcDiagnosticCode "DriverPackageTrustIgnored" = 83552 + GhcDiagnosticCode "DriverUnrecognisedFlag" = 93741 + GhcDiagnosticCode "DriverDeprecatedFlag" = 53692 + GhcDiagnosticCode "DriverModuleGraphCycle" = 92213 + GhcDiagnosticCode "DriverInstantiationNodeInDependencyGeneration" = 74284 + GhcDiagnosticCode "DriverNoConfiguredLLVMToolchain" = 66599 + + -- Constraint solver diagnostic codes + GhcDiagnosticCode "BadTelescope" = 97739 + GhcDiagnosticCode "UserTypeError" = 64725 + GhcDiagnosticCode "UnsatisfiableError" = 22250 + GhcDiagnosticCode "ReportHoleError" = 88464 + GhcDiagnosticCode "FixedRuntimeRepError" = 55287 + GhcDiagnosticCode "ExpectingMoreArguments" = 81325 + GhcDiagnosticCode "UnboundImplicitParams" = 91416 + GhcDiagnosticCode "AmbiguityPreventsSolvingCt" = 78125 + GhcDiagnosticCode "CannotResolveInstance" = 39999 + GhcDiagnosticCode "OverlappingInstances" = 43085 + GhcDiagnosticCode "UnsafeOverlap" = 36705 + GhcDiagnosticCode "MultiplicityCoercionsNotSupported" = 59840 + -- Type mismatch errors + GhcDiagnosticCode "BasicMismatch" = 18872 + GhcDiagnosticCode "TypeEqMismatch" = 83865 + GhcDiagnosticCode "CouldNotDeduce" = 05617 + + -- Variable unification errors + GhcDiagnosticCode "CannotUnifyWithPolytype" = 91028 + GhcDiagnosticCode "OccursCheck" = 27958 + GhcDiagnosticCode "SkolemEscape" = 46956 + GhcDiagnosticCode "DifferentTyVars" = 25897 + GhcDiagnosticCode "RepresentationalEq" = 10283 + + -- Typechecker/renamer diagnostic codes + GhcDiagnosticCode "TcRnSolverDepthError" = 40404 + GhcDiagnosticCode "TcRnRedundantConstraints" = 30606 + GhcDiagnosticCode "TcRnInaccessibleCode" = 40564 + GhcDiagnosticCode "TcRnInaccessibleCoAxBranch" = 28129 + GhcDiagnosticCode "TcRnTypeDoesNotHaveFixedRuntimeRep" = 18478 + GhcDiagnosticCode "TcRnImplicitLift" = 00846 + GhcDiagnosticCode "TcRnUnusedPatternBinds" = 61367 + GhcDiagnosticCode "TcRnDodgyExports" = 75356 + GhcDiagnosticCode "TcRnMissingImportList" = 77037 + GhcDiagnosticCode "TcRnUnsafeDueToPlugin" = 01687 + GhcDiagnosticCode "TcRnModMissingRealSrcSpan" = 84170 + GhcDiagnosticCode "TcRnIdNotExportedFromModuleSig" = 44188 + GhcDiagnosticCode "TcRnIdNotExportedFromLocalSig" = 50058 + GhcDiagnosticCode "TcRnShadowedName" = 63397 + GhcDiagnosticCode "TcRnInvalidWarningCategory" = 53573 + GhcDiagnosticCode "TcRnDuplicateWarningDecls" = 00711 + GhcDiagnosticCode "TcRnSimplifierTooManyIterations" = 95822 + GhcDiagnosticCode "TcRnIllegalPatSynDecl" = 82077 + GhcDiagnosticCode "TcRnLinearPatSyn" = 15172 + GhcDiagnosticCode "TcRnEmptyRecordUpdate" = 20825 + GhcDiagnosticCode "TcRnIllegalFieldPunning" = 44287 + GhcDiagnosticCode "TcRnIllegalWildcardsInRecord" = 37132 + GhcDiagnosticCode "TcRnIllegalWildcardInType" = 65507 + GhcDiagnosticCode "TcRnIllegalNamedWildcardInTypeArgument" = 93411 + GhcDiagnosticCode "TcRnIllegalImplicitTyVarInTypeArgument" = 80557 + GhcDiagnosticCode "TcRnIllegalPunnedVarOccInTypeArgument" = 09591 + GhcDiagnosticCode "TcRnDuplicateFieldName" = 85524 + GhcDiagnosticCode "TcRnIllegalViewPattern" = 22406 + GhcDiagnosticCode "TcRnCharLiteralOutOfRange" = 17268 + GhcDiagnosticCode "TcRnIllegalWildcardsInConstructor" = 47217 + GhcDiagnosticCode "TcRnIgnoringAnnotations" = 66649 + GhcDiagnosticCode "TcRnAnnotationInSafeHaskell" = 68934 + GhcDiagnosticCode "TcRnInvalidTypeApplication" = 95781 + GhcDiagnosticCode "TcRnTagToEnumMissingValArg" = 36495 + GhcDiagnosticCode "TcRnTagToEnumUnspecifiedResTy" = 08522 + GhcDiagnosticCode "TcRnTagToEnumResTyNotAnEnum" = 49356 + GhcDiagnosticCode "TcRnTagToEnumResTyTypeData" = 96189 + GhcDiagnosticCode "TcRnArrowIfThenElsePredDependsOnResultTy" = 55868 + GhcDiagnosticCode "TcRnIllegalHsBootOrSigDecl" = 58195 + GhcDiagnosticCode "TcRnRecursivePatternSynonym" = 72489 + GhcDiagnosticCode "TcRnPartialTypeSigTyVarMismatch" = 88793 + GhcDiagnosticCode "TcRnPartialTypeSigBadQuantifier" = 94185 + GhcDiagnosticCode "TcRnMissingSignature" = 38417 + GhcDiagnosticCode "TcRnPolymorphicBinderMissingSig" = 64414 + GhcDiagnosticCode "TcRnOverloadedSig" = 16675 + GhcDiagnosticCode "TcRnTupleConstraintInst" = 69012 + GhcDiagnosticCode "TcRnUserTypeError" = 47403 + GhcDiagnosticCode "TcRnConstraintInKind" = 01259 + GhcDiagnosticCode "TcRnUnboxedTupleOrSumTypeFuncArg" = 19590 + GhcDiagnosticCode "TcRnLinearFuncInKind" = 13218 + GhcDiagnosticCode "TcRnForAllEscapeError" = 31147 + GhcDiagnosticCode "TcRnVDQInTermType" = 51580 + GhcDiagnosticCode "TcRnBadQuantPredHead" = 02550 + GhcDiagnosticCode "TcRnIllegalTupleConstraint" = 77539 + GhcDiagnosticCode "TcRnNonTypeVarArgInConstraint" = 80003 + GhcDiagnosticCode "TcRnIllegalImplicitParam" = 75863 + GhcDiagnosticCode "TcRnIllegalConstraintSynonymOfKind" = 75844 + GhcDiagnosticCode "TcRnOversaturatedVisibleKindArg" = 45474 + GhcDiagnosticCode "TcRnForAllRankErr" = 91510 + GhcDiagnosticCode "TcRnMonomorphicBindings" = 55524 + GhcDiagnosticCode "TcRnOrphanInstance" = 90177 + GhcDiagnosticCode "TcRnFunDepConflict" = 46208 + GhcDiagnosticCode "TcRnDupInstanceDecls" = 59692 + GhcDiagnosticCode "TcRnConflictingFamInstDecls" = 34447 + GhcDiagnosticCode "TcRnFamInstNotInjective" = 05175 + GhcDiagnosticCode "TcRnBangOnUnliftedType" = 55666 + GhcDiagnosticCode "TcRnLazyBangOnUnliftedType" = 71444 + GhcDiagnosticCode "TcRnPatSynBundledWithNonDataCon" = 66775 + GhcDiagnosticCode "TcRnPatSynBundledWithWrongType" = 66025 + GhcDiagnosticCode "TcRnDupeModuleExport" = 51876 + GhcDiagnosticCode "TcRnExportedModNotImported" = 90973 + GhcDiagnosticCode "TcRnNullExportedModule" = 64649 + GhcDiagnosticCode "TcRnMissingExportList" = 85401 + GhcDiagnosticCode "TcRnExportHiddenComponents" = 94558 + GhcDiagnosticCode "TcRnExportHiddenDefault" = 74775 + GhcDiagnosticCode "TcRnDuplicateExport" = 47854 + GhcDiagnosticCode "TcRnDuplicateNamedDefaultExport" = 31584 + GhcDiagnosticCode "TcRnExportedParentChildMismatch" = 88993 + GhcDiagnosticCode "TcRnConflictingExports" = 69158 + GhcDiagnosticCode "TcRnDuplicateFieldExport" = 97219 + GhcDiagnosticCode "TcRnAmbiguousFieldInUpdate" = 56428 + GhcDiagnosticCode "TcRnAmbiguousRecordUpdate" = 02256 + GhcDiagnosticCode "TcRnMissingFields" = 20125 + GhcDiagnosticCode "TcRnFieldUpdateInvalidType" = 63055 + GhcDiagnosticCode "TcRnMissingStrictFields" = 95909 + GhcDiagnosticCode "TcRnStaticFormNotClosed" = 88431 + GhcDiagnosticCode "TcRnIllegalStaticExpression" = 23800 + GhcDiagnosticCode "TcRnUselessTypeable" = 90584 + GhcDiagnosticCode "TcRnDerivingDefaults" = 20042 + GhcDiagnosticCode "TcRnNonUnaryTypeclassConstraint" = 73993 + GhcDiagnosticCode "TcRnPartialTypeSignatures" = 60661 + GhcDiagnosticCode "TcRnLazyGADTPattern" = 87005 + GhcDiagnosticCode "TcRnArrowProcGADTPattern" = 64525 + GhcDiagnosticCode "TcRnTypeEqualityOutOfScope" = 12003 + GhcDiagnosticCode "TcRnTypeEqualityRequiresOperators" = 58520 + GhcDiagnosticCode "TcRnIllegalTypeOperator" = 62547 + GhcDiagnosticCode "TcRnGADTMonoLocalBinds" = 58008 + GhcDiagnosticCode "TcRnIncorrectNameSpace" = 31891 + GhcDiagnosticCode "TcRnNoRebindableSyntaxRecordDot" = 65945 + GhcDiagnosticCode "TcRnNoFieldPunsRecordDot" = 57365 + GhcDiagnosticCode "TcRnListComprehensionDuplicateBinding" = 81232 + GhcDiagnosticCode "TcRnLastStmtNotExpr" = 55814 + GhcDiagnosticCode "TcRnUnexpectedStatementInContext" = 42026 + GhcDiagnosticCode "TcRnSectionWithoutParentheses" = 95880 + GhcDiagnosticCode "TcRnIllegalImplicitParameterBindings" = 50730 + GhcDiagnosticCode "TcRnIllegalTupleSection" = 59155 + GhcDiagnosticCode "TcRnTermNameInType" = 37479 + GhcDiagnosticCode "TcRnUnexpectedKindVar" = 12875 + GhcDiagnosticCode "TcRnNegativeNumTypeLiteral" = 93632 + GhcDiagnosticCode "TcRnUnusedQuantifiedTypeVar" = 54180 + GhcDiagnosticCode "TcRnMissingRoleAnnotation" = 65490 + + GhcDiagnosticCode "TcRnUntickedPromotedThing" = 49957 + GhcDiagnosticCode "TcRnIllegalBuiltinSyntax" = 39716 + GhcDiagnosticCode "TcRnForeignImportPrimExtNotSet" = 49692 + GhcDiagnosticCode "TcRnForeignImportPrimSafeAnn" = 26133 + GhcDiagnosticCode "TcRnForeignFunctionImportAsValue" = 76251 + GhcDiagnosticCode "TcRnFunPtrImportWithoutAmpersand" = 57989 + GhcDiagnosticCode "TcRnIllegalForeignDeclBackend" = 03355 + GhcDiagnosticCode "TcRnUnsupportedCallConv" = 01245 + GhcDiagnosticCode "TcRnInvalidCIdentifier" = 95774 + GhcDiagnosticCode "TcRnExpectedValueId" = 01570 + GhcDiagnosticCode "TcRnRecSelectorEscapedTyVar" = 55876 + GhcDiagnosticCode "TcRnPatSynNotBidirectional" = 16444 + GhcDiagnosticCode "TcRnIllegalDerivingItem" = 11913 + GhcDiagnosticCode "TcRnUnexpectedAnnotation" = 18932 + GhcDiagnosticCode "TcRnIllegalRecordSyntax" = 89246 + GhcDiagnosticCode "TcRnInvalidVisibleKindArgument" = 20967 + GhcDiagnosticCode "TcRnTooManyBinders" = 05989 + GhcDiagnosticCode "TcRnDifferentNamesForTyVar" = 17370 + GhcDiagnosticCode "TcRnDisconnectedTyVar" = 59738 + GhcDiagnosticCode "TcRnInvalidReturnKind" = 55233 + GhcDiagnosticCode "TcRnClassKindNotConstraint" = 80768 + GhcDiagnosticCode "TcRnMatchesHaveDiffNumArgs" = 91938 + GhcDiagnosticCode "TcRnCannotBindScopedTyVarInPatSig" = 46131 + GhcDiagnosticCode "TcRnCannotBindTyVarsInPatBind" = 48361 + GhcDiagnosticCode "TcRnTooManyTyArgsInConPattern" = Outdated 01629 + GhcDiagnosticCode "TcRnMultipleInlinePragmas" = 96665 + GhcDiagnosticCode "TcRnUnexpectedPragmas" = 88293 + GhcDiagnosticCode "TcRnNonOverloadedSpecialisePragma" = 35827 + GhcDiagnosticCode "TcRnSpecialiseNotVisible" = 85337 + GhcDiagnosticCode "TcRnDifferentExportWarnings" = 92878 + GhcDiagnosticCode "TcRnIncompleteExportWarnings" = 94721 + GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl" = 50649 + GhcDiagnosticCode "TcRnOrPatBindsVariables" = 81303 + GhcDiagnosticCode "TcRnIllegalKind" = 64861 + GhcDiagnosticCode "TcRnUnexpectedPatSigType" = 74097 + GhcDiagnosticCode "TcRnIllegalKindSignature" = 91382 + GhcDiagnosticCode "TcRnDataKindsError" = 68567 + + GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods" = 93006 + GhcDiagnosticCode "TcRnHsigFixityMismatch" = 93007 + GhcDiagnosticCode "TcRnHsigMissingModuleExport" = 93011 + GhcDiagnosticCode "TcRnBadGenericMethod" = 59794 + GhcDiagnosticCode "TcRnWarningMinimalDefIncomplete" = 13511 + GhcDiagnosticCode "TcRnDefaultMethodForPragmaLacksBinding" = 28587 + GhcDiagnosticCode "TcRnIgnoreSpecialisePragmaOnDefMethod" = 72520 + GhcDiagnosticCode "TcRnBadMethodErr" = 46284 + GhcDiagnosticCode "TcRnIllegalTypeData" = 15013 + GhcDiagnosticCode "TcRnTypeDataForbids" = 67297 + GhcDiagnosticCode "TcRnUnsatisfiedMinimalDef" = 06201 + GhcDiagnosticCode "TcRnMisplacedInstSig" = 06202 + GhcDiagnosticCode "TcRnCapturedTermName" = 54201 + GhcDiagnosticCode "TcRnBindingOfExistingName" = 58805 + GhcDiagnosticCode "TcRnMultipleFixityDecls" = 50419 + GhcDiagnosticCode "TcRnIllegalPatternSynonymDecl" = 41507 + GhcDiagnosticCode "TcRnIllegalClassBinding" = 69248 + GhcDiagnosticCode "TcRnOrphanCompletePragma" = 93961 + GhcDiagnosticCode "TcRnEmptyCase" = 48010 + GhcDiagnosticCode "TcRnNonStdGuards" = 59119 + GhcDiagnosticCode "TcRnDuplicateSigDecl" = 31744 + GhcDiagnosticCode "TcRnMisplacedSigDecl" = 87866 + GhcDiagnosticCode "TcRnUnexpectedDefaultSig" = 40700 + GhcDiagnosticCode "TcRnDuplicateMinimalSig" = 85346 + GhcDiagnosticCode "TcRnSpecSigShape" = 93944 + GhcDiagnosticCode "TcRnLoopySuperclassSolve" = Outdated 36038 + GhcDiagnosticCode "TcRnUnexpectedStandaloneDerivingDecl" = 95159 + GhcDiagnosticCode "TcRnUnusedVariableInRuleDecl" = 65669 + GhcDiagnosticCode "TcRnUnexpectedStandaloneKindSig" = 45906 + GhcDiagnosticCode "TcRnIllegalRuleLhs" = 63294 + GhcDiagnosticCode "TcRnRuleLhsEqualities" = 53522 + GhcDiagnosticCode "TcRnDuplicateRoleAnnot" = 97170 + GhcDiagnosticCode "TcRnDuplicateKindSig" = 43371 + GhcDiagnosticCode "TcRnIllegalDerivStrategy" = 87139 + GhcDiagnosticCode "TcRnIllegalMultipleDerivClauses" = 30281 + GhcDiagnosticCode "TcRnNoDerivStratSpecified" = 55631 + GhcDiagnosticCode "TcRnStupidThetaInGadt" = 18403 + GhcDiagnosticCode "TcRnShadowedTyVarNameInFamResult" = 99412 + GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond" = 88333 + GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond" = 48254 + GhcDiagnosticCode "TcRnBadlyLevelled" = 28914 + GhcDiagnosticCode "TcRnBadlyLevelledType" = 86357 + GhcDiagnosticCode "TcRnStageRestriction" = Outdated 18157 + GhcDiagnosticCode "TcRnTyThingUsedWrong" = 10969 + GhcDiagnosticCode "TcRnCannotDefaultKindVar" = 79924 + GhcDiagnosticCode "TcRnUninferrableTyVar" = 16220 + GhcDiagnosticCode "TcRnSkolemEscape" = 71451 + GhcDiagnosticCode "TcRnPatSynEscapedCoercion" = 88986 + GhcDiagnosticCode "TcRnPatSynExistentialInResult" = 33973 + GhcDiagnosticCode "TcRnPatSynArityMismatch" = 18365 + GhcDiagnosticCode "TcRnTyFamDepsDisabled" = 43991 + GhcDiagnosticCode "TcRnAbstractClosedTyFamDecl" = 60012 + GhcDiagnosticCode "TcRnPartialFieldSelector" = 82712 + GhcDiagnosticCode "TcRnHasFieldResolvedIncomplete" = 86894 + GhcDiagnosticCode "TcRnSuperclassCycle" = 29210 + GhcDiagnosticCode "TcRnDefaultSigMismatch" = 72771 + GhcDiagnosticCode "TcRnTyFamResultDisabled" = 44012 + GhcDiagnosticCode "TcRnCommonFieldResultTypeMismatch" = 31004 + GhcDiagnosticCode "TcRnCommonFieldTypeMismatch" = 91827 + GhcDiagnosticCode "TcRnDataConParentTypeMismatch" = 45219 + GhcDiagnosticCode "TcRnGADTsDisabled" = 23894 + GhcDiagnosticCode "TcRnExistentialQuantificationDisabled" = 25709 + GhcDiagnosticCode "TcRnGADTDataContext" = 61072 + GhcDiagnosticCode "TcRnMultipleConForNewtype" = 16409 + GhcDiagnosticCode "TcRnKindSignaturesDisabled" = 49378 + GhcDiagnosticCode "TcRnEmptyDataDeclsDisabled" = 32478 + GhcDiagnosticCode "TcRnRoleMismatch" = 29178 + GhcDiagnosticCode "TcRnRoleCountMismatch" = 54298 + GhcDiagnosticCode "TcRnIllegalRoleAnnotation" = 77192 + GhcDiagnosticCode "TcRnRoleAnnotationsDisabled" = 17779 + GhcDiagnosticCode "TcRnIncoherentRoles" = 18273 + GhcDiagnosticCode "TcRnTypeSynonymCycle" = 97522 + GhcDiagnosticCode "TcRnSelfImport" = 43281 + GhcDiagnosticCode "TcRnNoExplicitImportList" = 16029 + GhcDiagnosticCode "TcRnSafeImportsDisabled" = 26971 + GhcDiagnosticCode "TcRnDeprecatedModule" = 15328 + GhcDiagnosticCode "TcRnCompatUnqualifiedImport" = Outdated 82347 + GhcDiagnosticCode "TcRnRedundantSourceImport" = 54478 + GhcDiagnosticCode "TcRnDuplicateDecls" = 29916 + GhcDiagnosticCode "TcRnPackageImportsDisabled" = 10032 + GhcDiagnosticCode "TcRnIllegalDataCon" = 78448 + GhcDiagnosticCode "TcRnNestedForallsContexts" = 71492 + GhcDiagnosticCode "TcRnRedundantRecordWildcard" = 15932 + GhcDiagnosticCode "TcRnUnusedRecordWildcard" = 83475 + GhcDiagnosticCode "TcRnUnusedName" = 40910 + GhcDiagnosticCode "TcRnQualifiedBinder" = 28329 + GhcDiagnosticCode "TcRnInvalidRecordField" = 53822 + GhcDiagnosticCode "TcRnTupleTooLarge" = 94803 + GhcDiagnosticCode "TcRnCTupleTooLarge" = 89347 + GhcDiagnosticCode "TcRnIllegalInferredTyVars" = 54832 + GhcDiagnosticCode "TcRnAmbiguousName" = 87543 + GhcDiagnosticCode "TcRnBindingNameConflict" = 10498 + GhcDiagnosticCode "NonCanonicalMonoid" = 50928 + GhcDiagnosticCode "NonCanonicalMonad" = 22705 + GhcDiagnosticCode "TcRnDefaultedExceptionContext" = 46235 + GhcDiagnosticCode "TcRnImplicitImportOfPrelude" = 20540 + GhcDiagnosticCode "TcRnMissingMain" = 67120 + GhcDiagnosticCode "TcRnGhciUnliftedBind" = 17999 + GhcDiagnosticCode "TcRnGhciMonadLookupFail" = 44990 + GhcDiagnosticCode "TcRnArityMismatch" = 27346 + GhcDiagnosticCode "TcRnSimplifiableConstraint" = 62412 + GhcDiagnosticCode "TcRnIllegalQuasiQuotes" = 77343 + GhcDiagnosticCode "TcRnImplicitRhsQuantification" = 16382 + GhcDiagnosticCode "TcRnBadTyConTelescope" = 87279 + GhcDiagnosticCode "TcRnPatersonCondFailure" = 22979 + GhcDiagnosticCode "TcRnDeprecatedInvisTyArgInConPat" = Outdated 69797 + GhcDiagnosticCode "TcRnInvalidDefaultedTyVar" = 45625 + GhcDiagnosticCode "TcRnIllegalTermLevelUse" = 01928 + GhcDiagnosticCode "TcRnNamespacedWarningPragmaWithoutFlag" = 14995 + GhcDiagnosticCode "TcRnNamespacedFixitySigWithoutFlag" = 78534 + GhcDiagnosticCode "TcRnOutOfArityTyVar" = 84925 + GhcDiagnosticCode "TcRnIllformedTypePattern" = 88754 + GhcDiagnosticCode "TcRnIllegalTypePattern" = 70206 + GhcDiagnosticCode "TcRnIllformedTypeArgument" = 29092 + GhcDiagnosticCode "TcRnIllegalTypeExpr" = 35499 + GhcDiagnosticCode "TcRnUnexpectedTypeSyntaxInTerms" = 31244 + GhcDiagnosticCode "TcRnTypeApplicationsDisabled" = 23482 + + -- TcRnIllegalInvisibleTypePattern + GhcDiagnosticCode "InvisPatWithoutFlag" = 78249 + GhcDiagnosticCode "InvisPatNoForall" = 14964 + GhcDiagnosticCode "InvisPatMisplaced" = 11983 + + -- PatSynInvalidRhsReason + GhcDiagnosticCode "PatSynNotInvertible" = 69317 + GhcDiagnosticCode "PatSynUnboundVar" = 28572 + + -- TcRnBadFieldAnnotation/BadFieldAnnotationReason + GhcDiagnosticCode "LazyFieldsDisabled" = 81601 + GhcDiagnosticCode "UnpackWithoutStrictness" = 10107 + GhcDiagnosticCode "UnusableUnpackPragma" = 40091 + + -- TcRnRoleValidationFailed/RoleInferenceFailedReason + GhcDiagnosticCode "TyVarRoleMismatch" = 22221 + GhcDiagnosticCode "TyVarMissingInEnv" = 99991 + GhcDiagnosticCode "BadCoercionRole" = 92834 + + -- TcRnClassExtensionDisabled/DisabledClassExtension + GhcDiagnosticCode "MultiParamDisabled" = 28349 + GhcDiagnosticCode "FunDepsDisabled" = 15708 + GhcDiagnosticCode "ConstrainedClassMethodsDisabled" = 25079 + + -- TcRnTyFamsDisabled/TyFamsDisabledReason + GhcDiagnosticCode "TyFamsDisabledFamily" = 39191 + GhcDiagnosticCode "TyFamsDisabledInstance" = 06206 + GhcDiagnosticCode "TcRnPrecedenceParsingError" = 88747 + GhcDiagnosticCode "TcRnSectionPrecedenceError" = 46878 + + -- HsigShapeMismatchReason + GhcDiagnosticCode "HsigShapeSortMismatch" = 93008 + GhcDiagnosticCode "HsigShapeNotUnifiable" = 93009 + + -- Invisible binders + GhcDiagnosticCode "TcRnIllegalInvisTyVarBndr" = 58589 + GhcDiagnosticCode "TcRnIllegalWildcardTyVarBndr" = 12211 + GhcDiagnosticCode "TcRnInvalidInvisTyVarBndr" = 57916 + GhcDiagnosticCode "TcRnInvisBndrWithoutSig" = 92337 + + -- IllegalNewtypeReason + GhcDiagnosticCode "DoesNotHaveSingleField" = 23517 + GhcDiagnosticCode "IsNonLinear" = 38291 + GhcDiagnosticCode "IsGADT" = 89498 + GhcDiagnosticCode "HasConstructorContext" = 17440 + GhcDiagnosticCode "HasExistentialTyVar" = 07525 + GhcDiagnosticCode "HasStrictnessAnnotation" = 04049 + + -- TcRnBadRecordUpdate + GhcDiagnosticCode "NoConstructorHasAllFields" = 14392 + GhcDiagnosticCode "MultiplePossibleParents" = 99339 + GhcDiagnosticCode "InvalidTyConParent" = 33238 + + -- BadImport + GhcDiagnosticCode "BadImportNotExported" = 61689 + GhcDiagnosticCode "BadImportAvailDataCon" = 35373 + GhcDiagnosticCode "BadImportNotExportedSubordinates" = 10237 + GhcDiagnosticCode "BadImportNonTypeSubordinates" = 51433 + GhcDiagnosticCode "BadImportNonDataSubordinates" = 46557 + GhcDiagnosticCode "BadImportAvailTyCon" = 56449 + GhcDiagnosticCode "BadImportAvailVar" = 12112 + + -- TcRnPragmaWarning + GhcDiagnosticCode "WarningTxt" = 63394 + GhcDiagnosticCode "DeprecatedTxt" = 68441 + + -- TcRnRunSliceFailure/ConversionFail + GhcDiagnosticCode "IllegalOccName" = 55017 + GhcDiagnosticCode "SumAltArityExceeded" = 68444 + GhcDiagnosticCode "IllegalSumAlt" = 63966 + GhcDiagnosticCode "IllegalSumArity" = 97721 + GhcDiagnosticCode "MalformedType" = 28709 + GhcDiagnosticCode "IllegalLastStatement" = 47373 + GhcDiagnosticCode "KindSigsOnlyAllowedOnGADTs" = 40746 + GhcDiagnosticCode "IllegalDeclaration" = 23882 + GhcDiagnosticCode "CannotMixGADTConsWith98Cons" = 24104 + GhcDiagnosticCode "EmptyStmtListInDoBlock" = 34949 + GhcDiagnosticCode "NonVarInInfixExpr" = 99831 + GhcDiagnosticCode "MultiWayIfWithoutAlts" = 63930 + GhcDiagnosticCode "CasesExprWithoutAlts" = 91745 + GhcDiagnosticCode "ImplicitParamsWithOtherBinds" = 42974 + GhcDiagnosticCode "InvalidCCallImpent" = 60220 + GhcDiagnosticCode "RecGadtNoCons" = 18816 + GhcDiagnosticCode "GadtNoCons" = 38140 + GhcDiagnosticCode "InvalidTypeInstanceHeader" = 37056 + GhcDiagnosticCode "InvalidTyFamInstLHS" = 78486 + GhcDiagnosticCode "InvalidImplicitParamBinding" = 51603 + GhcDiagnosticCode "DefaultDataInstDecl" = 39639 + GhcDiagnosticCode "FunBindLacksEquations" = 52078 + GhcDiagnosticCode "EmptyGuard" = 45149 + GhcDiagnosticCode "EmptyParStmt" = 95595 + + -- TcRnDodgyImports/DodgyImportsReason + GhcDiagnosticCode "DodgyImportsEmptyParent" = 99623 + + -- TcRnImportLookup/ImportLookupReason + GhcDiagnosticCode "ImportLookupQualified" = 48795 + GhcDiagnosticCode "ImportLookupIllegal" = 14752 + GhcDiagnosticCode "ImportLookupAmbiguous" = 92057 + + -- TcRnUnusedImport/UnusedImportReason + GhcDiagnosticCode "UnusedImportNone" = 66111 + GhcDiagnosticCode "UnusedImportSome" = 38856 + + -- TcRnIllegalInstance + GhcDiagnosticCode "IllegalFamilyApplicationInInstance" = 73138 + + -- TcRnIllegalClassInstance/IllegalClassInstanceReason + GhcDiagnosticCode "IllegalSpecialClassInstance" = 97044 + GhcDiagnosticCode "IllegalInstanceFailsCoverageCondition" = 21572 + + -- IllegalInstanceHead + GhcDiagnosticCode "InstHeadAbstractClass" = 51758 + GhcDiagnosticCode "InstHeadNonClassHead" = 53946 + GhcDiagnosticCode "InstHeadTySynArgs" = 93557 + GhcDiagnosticCode "InstHeadNonTyVarArgs" = 48406 + GhcDiagnosticCode "InstHeadMultiParam" = 91901 + + -- IllegalHasFieldInstance + GhcDiagnosticCode "IllegalHasFieldInstanceNotATyCon" = 88994 + GhcDiagnosticCode "IllegalHasFieldInstanceFamilyTyCon" = 70743 + GhcDiagnosticCode "IllegalHasFieldInstanceTyConHasFields" = 43406 + GhcDiagnosticCode "IllegalHasFieldInstanceTyConHasField" = 30836 + + -- TcRnIllegalFamilyInstance/IllegalFamilyInstanceReason + GhcDiagnosticCode "NotAFamilyTyCon" = 06204 + GhcDiagnosticCode "NotAnOpenFamilyTyCon" = 06207 + GhcDiagnosticCode "FamilyCategoryMismatch" = 52347 + GhcDiagnosticCode "FamilyArityMismatch" = 12985 + GhcDiagnosticCode "TyFamNameMismatch" = 88221 + GhcDiagnosticCode "FamInstRHSOutOfScopeTyVars" = 53634 + GhcDiagnosticCode "FamInstLHSUnusedBoundTyVars" = 30337 + + -- InvalidAssocInstance + GhcDiagnosticCode "AssocInstanceMissing" = 08585 + GhcDiagnosticCode "AssocInstanceNotInAClass" = 06205 + GhcDiagnosticCode "AssocNotInThisClass" = 38351 + GhcDiagnosticCode "AssocNoClassTyVar" = 55912 + GhcDiagnosticCode "AssocTyVarsDontMatch" = 95424 + + -- InvalidAssocDefault + GhcDiagnosticCode "AssocDefaultNotAssoc" = 78822 + GhcDiagnosticCode "AssocMultipleDefaults" = 59128 + + -- AssocDefaultBadArgs + GhcDiagnosticCode "AssocDefaultNonTyVarArg" = 41522 + GhcDiagnosticCode "AssocDefaultDuplicateTyVars" = 48178 + + -- Diagnostic codes for the foreign function interface + GhcDiagnosticCode "NotADataType" = 31136 + GhcDiagnosticCode "NewtypeDataConNotInScope" = 72317 + GhcDiagnosticCode "UnliftedFFITypesNeeded" = 10964 + GhcDiagnosticCode "NotABoxedMarshalableTyCon" = 89401 + GhcDiagnosticCode "ForeignLabelNotAPtr" = 26070 + GhcDiagnosticCode "NotSimpleUnliftedType" = 43510 + GhcDiagnosticCode "NotBoxedKindAny" = 64097 + GhcDiagnosticCode "ForeignDynNotPtr" = 27555 + GhcDiagnosticCode "SafeHaskellMustBeInIO" = 57638 + GhcDiagnosticCode "IOResultExpected" = 41843 + GhcDiagnosticCode "UnexpectedNestedForall" = 92994 + GhcDiagnosticCode "LinearTypesNotAllowed" = 57396 + GhcDiagnosticCode "OneArgExpected" = 91490 + GhcDiagnosticCode "AtLeastOneArgExpected" = 07641 + + -- Interface errors + GhcDiagnosticCode "BadSourceImport" = 64852 + GhcDiagnosticCode "HomeModError" = 58427 + GhcDiagnosticCode "DynamicHashMismatchError" = 54709 + GhcDiagnosticCode "CouldntFindInFiles" = 94559 + GhcDiagnosticCode "GenericMissing" = 87110 + GhcDiagnosticCode "MissingPackageFiles" = 22211 + GhcDiagnosticCode "MissingPackageWayFiles" = 88719 + GhcDiagnosticCode "ModuleSuggestion" = 61948 + GhcDiagnosticCode "MultiplePackages" = 45102 + GhcDiagnosticCode "NoUnitIdMatching" = 51294 + GhcDiagnosticCode "NotAModule" = 35235 + GhcDiagnosticCode "Can'tFindNameInInterface" = 83249 + GhcDiagnosticCode "CircularImport" = 75429 + GhcDiagnosticCode "HiModuleNameMismatchWarn" = 53693 + GhcDiagnosticCode "ExceptionOccurred" = 47808 + + -- Out of scope errors + GhcDiagnosticCode "NotInScope" = 76037 + GhcDiagnosticCode "NotARecordField" = 22385 + GhcDiagnosticCode "NoExactName" = 97784 + GhcDiagnosticCode "SameName" = 81573 + GhcDiagnosticCode "MissingBinding" = 44432 + GhcDiagnosticCode "NoTopLevelBinding" = 10173 + GhcDiagnosticCode "UnknownSubordinate" = 54721 + GhcDiagnosticCode "NotInScopeTc" = 76329 + + -- Diagnostic codes for deriving + GhcDiagnosticCode "DerivErrNotWellKinded" = 62016 + GhcDiagnosticCode "DerivErrSafeHaskellGenericInst" = 07214 + GhcDiagnosticCode "DerivErrDerivingViaWrongKind" = 63174 + GhcDiagnosticCode "DerivErrNoEtaReduce" = 38996 + GhcDiagnosticCode "DerivErrBootFileFound" = 30903 + GhcDiagnosticCode "DerivErrDataConsNotAllInScope" = 54540 + GhcDiagnosticCode "DerivErrGNDUsedOnData" = 10333 + GhcDiagnosticCode "DerivErrNullaryClasses" = 04956 + GhcDiagnosticCode "DerivErrLastArgMustBeApp" = 28323 + GhcDiagnosticCode "DerivErrNoFamilyInstance" = 82614 + GhcDiagnosticCode "DerivErrNotStockDeriveable" = 00158 + GhcDiagnosticCode "DerivErrHasAssociatedDatatypes" = 34611 + GhcDiagnosticCode "DerivErrNewtypeNonDeriveableClass" = 82023 + GhcDiagnosticCode "DerivErrCannotEtaReduceEnough" = 26557 + GhcDiagnosticCode "DerivErrOnlyAnyClassDeriveable" = 23244 + GhcDiagnosticCode "DerivErrNotDeriveable" = 38178 + GhcDiagnosticCode "DerivErrNotAClass" = 63388 + GhcDiagnosticCode "DerivErrNoConstructors" = 64560 + GhcDiagnosticCode "DerivErrLangExtRequired" = 86639 + GhcDiagnosticCode "DerivErrDunnoHowToDeriveForType" = 48959 + GhcDiagnosticCode "DerivErrMustBeEnumType" = 30750 + GhcDiagnosticCode "DerivErrMustHaveExactlyOneConstructor" = 37542 + GhcDiagnosticCode "DerivErrMustHaveSomeParameters" = 45539 + GhcDiagnosticCode "DerivErrMustNotHaveClassContext" = 16588 + GhcDiagnosticCode "DerivErrBadConstructor" = 16437 + GhcDiagnosticCode "DerivErrGenerics" = 30367 + GhcDiagnosticCode "DerivErrEnumOrProduct" = 58291 + + -- Diagnostic codes for instance lookup + GhcDiagnosticCode "LookupInstErrNotExact" = 10372 + GhcDiagnosticCode "LookupInstErrFlexiVar" = 10373 + GhcDiagnosticCode "LookupInstErrNotFound" = 10374 + + -- Diagnostic codes for default declarations and type defaulting + GhcDiagnosticCode "TcRnMultipleDefaultDeclarations" = 99565 + GhcDiagnosticCode "TcRnIllegalDefaultClass" = 26555 + GhcDiagnosticCode "TcRnIllegalNamedDefault" = 55756 + GhcDiagnosticCode "TcRnBadDefaultType" = 88933 + GhcDiagnosticCode "TcRnWarnDefaulting" = 18042 + GhcDiagnosticCode "TcRnWarnClashingDefaultImports" = 77007 + + -- TcRnEmptyStmtsGroupError/EmptyStatementGroupErrReason + GhcDiagnosticCode "EmptyStmtsGroupInParallelComp" = 41242 + GhcDiagnosticCode "EmptyStmtsGroupInTransformListComp" = 92693 + GhcDiagnosticCode "EmptyStmtsGroupInDoNotation" = 82311 + GhcDiagnosticCode "EmptyStmtsGroupInArrowNotation" = 19442 + + -- HsBoot and Hsig errors + GhcDiagnosticCode "MissingBootDefinition" = 63610 + GhcDiagnosticCode "MissingBootExport" = 91999 + GhcDiagnosticCode "MissingBootInstance" = 79857 + GhcDiagnosticCode "BadReexportedBootThing" = 12424 + GhcDiagnosticCode "BootMismatchedIdTypes" = 11890 + GhcDiagnosticCode "BootMismatchedTyCons" = 15843 + + -- TH errors + GhcDiagnosticCode "TypedTHWithPolyType" = 94642 + GhcDiagnosticCode "SplicePolymorphicLocalVar" = 06568 + GhcDiagnosticCode "SpliceThrewException" = 87897 + GhcDiagnosticCode "InvalidTopDecl" = 52886 + GhcDiagnosticCode "NonExactName" = 77923 + GhcDiagnosticCode "AddInvalidCorePlugin" = 86463 + GhcDiagnosticCode "AddDocToNonLocalDefn" = 67760 + GhcDiagnosticCode "FailedToLookupThInstName" = 49530 + GhcDiagnosticCode "CannotReifyInstance" = 30384 + GhcDiagnosticCode "CannotReifyOutOfScopeThing" = 24922 + GhcDiagnosticCode "CannotReifyThingNotInTypeEnv" = 79890 + GhcDiagnosticCode "NoRolesAssociatedWithThing" = 65923 + GhcDiagnosticCode "CannotRepresentType" = 75721 + GhcDiagnosticCode "ReportCustomQuasiError" = 39584 + GhcDiagnosticCode "MismatchedSpliceType" = 45108 + GhcDiagnosticCode "IllegalTHQuotes" = 62558 + GhcDiagnosticCode "IllegalTHSplice" = 26759 + GhcDiagnosticCode "NestedTHBrackets" = 59185 + GhcDiagnosticCode "AddTopDeclsUnexpectedDeclarationSplice" = 17599 + GhcDiagnosticCode "BadImplicitSplice" = 25277 + GhcDiagnosticCode "QuotedNameWrongStage" = Outdated 57695 + GhcDiagnosticCode "IllegalStaticFormInSplice" = 12219 + + -- Zonker messages + GhcDiagnosticCode "ZonkerCannotDefaultConcrete" = 52083 + + -- Promotion errors + GhcDiagnosticCode "ClassPE" = 86934 + GhcDiagnosticCode "TyConPE" = 85413 + GhcDiagnosticCode "PatSynPE" = 70349 + GhcDiagnosticCode "FamDataConPE" = 64578 + GhcDiagnosticCode "ConstrainedDataConPE" = 28374 + GhcDiagnosticCode "RecDataConPE" = 56753 + GhcDiagnosticCode "TermVariablePE" = 45510 + GhcDiagnosticCode "TypeVariablePE" = 47557 + + -- To generate new random numbers: + -- https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain + -- + -- NB: never remove a return value from this type family! + -- We need to ensure uniquess of diagnostic codes across GHC versions, + -- and this includes outdated diagnostic codes for errors that GHC + -- no longer reports. These are mostly collected below, but for ease + -- of rebasing it is often better to simply declare a constructor outdated + -- without moving it down here. + + GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl" = Outdated 12222 + GhcDiagnosticCode "TcRnNoClassInstHead" = Outdated 56538 + -- The above two are subsumed by InstHeadNonClassHead [GHC-53946] + + GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = Outdated 40027 + GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = Outdated 69639 + GhcDiagnosticCode "TcRnMixedSelectors" = Outdated 40887 + GhcDiagnosticCode "TcRnBadBootFamInstDecl" = Outdated 06203 + GhcDiagnosticCode "TcRnBindInBootFile" = Outdated 11247 + GhcDiagnosticCode "TcRnUnexpectedTypeSplice" = Outdated 39180 + GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl" = Outdated 45054 + GhcDiagnosticCode "TcRnUnpromotableThing" = Outdated 88634 + GhcDiagnosticCode "UntouchableVariable" = Outdated 34699 + GhcDiagnosticCode "TcRnBindVarAlreadyInScope" = Outdated 69710 + GhcDiagnosticCode "TcRnBindMultipleVariables" = Outdated 92957 + GhcDiagnosticCode "TcRnHsigNoIface" = Outdated 93010 + GhcDiagnosticCode "TcRnInterfaceLookupError" = Outdated 52243 + GhcDiagnosticCode "TcRnForallIdentifier" = Outdated 64088 + GhcDiagnosticCode "TypeApplicationInPattern" = Outdated 17916 + +{- ********************************************************************* +* * + Recurring into an argument +* * +********************************************************************* -} + +-- | Some constructors of diagnostic datatypes don't have +-- corresponding error codes, because we recur inside them. +-- +-- For example, we don't have an error code for the +-- 'TcRnCannotDeriveInstance' constructor of 'TcRnMessage', +-- because we recur into the 'DeriveInstanceErrReason' to obtain +-- an error code. +-- +-- This type family keeps track of such constructors. +type ConRecursInto :: Symbol -> Maybe Type +type family ConRecursInto con where + + ---------------------------------- + -- Constructors of GhcMessage + + ConRecursInto "GhcDriverMessage" = 'Just DriverMessage + ConRecursInto "GhcPsMessage" = 'Just PsMessage + ConRecursInto "GhcTcRnMessage" = 'Just TcRnMessage + ConRecursInto "GhcDsMessage" = 'Just DsMessage + ConRecursInto "GhcUnknownMessage" = 'Just (UnknownDiagnosticFor GhcMessage) + + ---------------------------------- + -- Constructors of DriverMessage + + ConRecursInto "DriverUnknownMessage" = 'Just (UnknownDiagnosticFor DriverMessage) + ConRecursInto "DriverPsHeaderMessage" = 'Just PsMessage + ConRecursInto "DriverInterfaceError" = 'Just IfaceMessage + + ConRecursInto "CantFindErr" = 'Just CantFindInstalled + ConRecursInto "CantFindInstalledErr" = 'Just CantFindInstalled + + ConRecursInto "CantFindInstalled" = 'Just CantFindInstalledReason + + ConRecursInto "BadIfaceFile" = 'Just ReadInterfaceError + ConRecursInto "FailedToLoadDynamicInterface" = 'Just ReadInterfaceError + + ---------------------------------- + -- Constructors of PsMessage + + ConRecursInto "PsUnknownMessage" = 'Just (UnknownDiagnosticFor PsMessage) + ConRecursInto "PsHeaderMessage" = 'Just PsHeaderMessage + + ---------------------------------- + -- Constructors of DsMessage + + ConRecursInto "DsUselessSpecialisePragma" = 'Just UselessSpecialisePragmaReason + + ---------------------------------- + -- Constructors of TcRnMessage + + ConRecursInto "TcRnUnknownMessage" = 'Just (UnknownDiagnosticFor TcRnMessage) + + -- Recur into TcRnMessageWithInfo to get the underlying TcRnMessage + ConRecursInto "TcRnMessageWithInfo" = 'Just TcRnMessageDetailed + ConRecursInto "TcRnMessageDetailed" = 'Just TcRnMessage + ConRecursInto "TcRnWithHsDocContext" = 'Just TcRnMessage + + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + ConRecursInto "TcRnLookupInstance" = 'Just LookupInstanceErrReason + ConRecursInto "TcRnPragmaWarning" = 'Just (WarningTxt GhcRn) + ConRecursInto "TcRnNotInScope" = 'Just NotInScopeError + ConRecursInto "TcRnIllegalNewtype" = 'Just IllegalNewtypeReason + ConRecursInto "TcRnHsigShapeMismatch" = 'Just HsigShapeMismatchReason + ConRecursInto "TcRnPatSynInvalidRhs" = 'Just PatSynInvalidRhsReason + ConRecursInto "TcRnBadRecordUpdate" = 'Just BadRecordUpdateReason + ConRecursInto "TcRnBadFieldAnnotation" = 'Just BadFieldAnnotationReason + ConRecursInto "TcRnRoleValidationFailed" = 'Just RoleValidationFailedReason + ConRecursInto "TcRnClassExtensionDisabled" = 'Just DisabledClassExtension + ConRecursInto "TcRnTyFamsDisabled" = 'Just TyFamsDisabledReason + ConRecursInto "TcRnDodgyImports" = 'Just DodgyImportsReason + ConRecursInto "DodgyImportsHiding" = 'Just ImportLookupReason + ConRecursInto "TcRnImportLookup" = 'Just ImportLookupReason + ConRecursInto "TcRnUnusedImport" = 'Just UnusedImportReason + ConRecursInto "TcRnNonCanonicalDefinition" = 'Just NonCanonicalDefinition + ConRecursInto "TcRnIllegalInstance" = 'Just IllegalInstanceReason + ConRecursInto "TcRnIllegalInvisibleTypePattern" = 'Just BadInvisPatReason + + -- Illegal instance reasons + ConRecursInto "IllegalClassInstance" = 'Just IllegalClassInstanceReason + ConRecursInto "IllegalFamilyInstance" = 'Just IllegalFamilyInstanceReason + + -- Illegal class instance reasons + + ConRecursInto "IllegalInstanceHead" = 'Just IllegalInstanceHeadReason + ConRecursInto "IllegalHasFieldInstance" = 'Just IllegalHasFieldInstance + + -- Illegal family instance reasons + + ConRecursInto "InvalidAssoc" = 'Just InvalidAssoc + ConRecursInto "InvalidAssocInstance" = 'Just InvalidAssocInstance + ConRecursInto "InvalidAssocDefault" = 'Just InvalidAssocDefault + ConRecursInto "AssocDefaultBadArgs" = 'Just AssocDefaultBadArgs + + -- + -- TH errors + ConRecursInto "TcRnTHError" = 'Just THError + ConRecursInto "THSyntaxError" = 'Just THSyntaxError + ConRecursInto "THNameError" = 'Just THNameError + ConRecursInto "THReifyError" = 'Just THReifyError + ConRecursInto "TypedTHError" = 'Just TypedTHError + ConRecursInto "THSpliceFailed" = 'Just SpliceFailReason + ConRecursInto "RunSpliceFailure" = 'Just RunSpliceFailReason + ConRecursInto "ConversionFail" = 'Just ConversionFailReason + ConRecursInto "AddTopDeclsError" = 'Just AddTopDeclsError + ConRecursInto "AddTopDeclsRunSpliceFailure" = 'Just RunSpliceFailReason + + -- Interface file errors + + ConRecursInto "TcRnInterfaceError" = 'Just IfaceMessage + ConRecursInto "Can'tFindInterface" = 'Just MissingInterfaceError + + -- HsBoot and Hsig errors + ConRecursInto "TcRnBootMismatch" = 'Just BootMismatch + ConRecursInto "MissingBootThing" = 'Just MissingBootThing + ConRecursInto "BootMismatch" = 'Just BootMismatchWhat + + -- Zonker errors + ConRecursInto "TcRnZonkerMessage" = 'Just ZonkerMessage + + ------------------ + -- FFI errors + + ConRecursInto "TcRnIllegalForeignType" = 'Just IllegalForeignTypeReason + -- IllegalForeignTypeReason: recur into TypeCannotBeMarshaled for the reason + ConRecursInto "TypeCannotBeMarshaled" = 'Just TypeCannotBeMarshaledReason + + ------------------ + -- Solver reports + + -- Recur inside TcRnSolverReport to get the underlying TcSolverReportMsg + ConRecursInto "TcRnSolverReport" = 'Just SolverReportWithCtxt + ConRecursInto "SolverReportWithCtxt" = 'Just TcSolverReportMsg + ConRecursInto "TcReportWithInfo" = 'Just TcSolverReportMsg + + -- Recur inside CannotUnifyVariable to get the underlying reason + ConRecursInto "CannotUnifyVariable" = 'Just CannotUnifyVariableReason + + -- Recur inside Mismatch to get the underlying reason + ConRecursInto "Mismatch" = 'Just MismatchMsg + + -- Recur inside empty statements groups to get the underlying statements block + ConRecursInto "TcRnEmptyStmtsGroup" = 'Just EmptyStatementGroupErrReason + ---------------------------------- + -- Constructors of DsMessage + + ConRecursInto "DsUnknownMessage" = 'Just (UnknownDiagnosticFor DsMessage) + + ---------------------------------- + -- Constructors of ImportLookupBad + ConRecursInto "ImportLookupBad" = 'Just BadImportKind + + ConRecursInto "TcRnUnpromotableThing" = 'Just PromotionErr + ---------------------------------- + -- Any other constructors: don't recur, instead directly + -- use the constructor name for the error code. + + ConRecursInto _ = 'Nothing + +{- ********************************************************************* +* * + Generics machinery +* * +********************************************************************* -} + +{- Note [Diagnostic codes using generics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Diagnostic codes for GHC are specified at the type-level using the injective +type family 'GhcDiagnosticCode'. This ensures uniqueness of diagnostic +codes, giving quick feedback (in the form of a type error). + +Using this type family, we need to obtain corresponding value-level +functions, e.g. + + diagnosticCode :: TcRnMessage -> DiagnosticCode + diagnosticCode diag = case diag of + TcRnInaccessibleCode {} -> ghcDiagnosticCode 40564 + TcRnTypeDoesNotHaveFixedRuntimeRep {} -> ghcDiagnosticCode 18478 + TcRnCannotDeriveInstance _ _ _ _ reason -> + case reason of + DerivErrNotWellKinded {} -> ghcDiagnosticCode 62016 + DerivErrNotAClass {} -> ghcDiagnosticCode 63388 + ... + ... + +For some constructors, such as 'TcRnInaccessibleCode', we directly get a +diagnostic code, using the 'GhcDiagnosticCode' type family. For other +constructors, such as 'TcRnCannotDeriveInstance', we instead recur into an +argument (in this case 'DeriveInstanceErrReason') to obtain a diagnostic code. + +To achieve this, we use a variant of the 'typed' lens from 'generic-lens' +(we only need a getter, not a setter): + + - Using GHC.Generics, we obtain the type-level structure + of diagnostic types, as sums of products, with extra metadata. + - The 'ConRecursInto' type family declares when we should + recur into an argument of the constructor instead of using + the constructor name itself for the diagnostic code. + - To decide whether to recur, in the generic representation, + we must look at all factors of a product to see if there is + a type we should recur into. We look at the left branch + first, and decide whether to recur into it using the + HasTypeQ type family. + - The two different behaviours are controlled by two main instances (*) and (**). + - (*) directly uses the constructor name, by using the 'DiagnosticCodeFor' + type family. The 'KnownConstructor' context (ERR2) on the instance provides + a custom error message in case of a missing diagnostic code, which points + GHC contributors to the documentation explaining how to add diagnostic codes + for their diagnostics. + - (**) recurses into a subtype, when we have a type family equation such as: + + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + + In this case, for the constructor 'TcRnCannotDeriveInstance', we recur into the + type 'DeriveInstanceErrReason'. + The overlapping instance (ERR1) provides an error message in case a constructor + does not have the type specified by the 'ConRecursInto' type family. +-} + +-- | Use the generic representation of a type to retrieve the +-- diagnostic code, using 'DiagnosticCodeFor namespace' type family. +-- +-- See Note [Diagnostic codes using generics] in GHC.Types.Error.Codes. +type GDiagnosticCode :: Type -> (Type -> Type) -> Constraint +class GDiagnosticCode namespace f where + gdiagnosticCode :: f a -> Maybe DiagnosticCode +-- | Use the generic representation of a type to retrieve the collection +-- of all diagnostic codes it can give rise to. +type GDiagnosticCodes :: Type -> [Type] -> (Type -> Type) -> Constraint +class GDiagnosticCodes namespace seen f where + gdiagnosticCodes :: Map DiagnosticCode String + +type ConstructorCode :: Type -> Symbol -> (Type -> Type) -> Maybe Type -> Constraint +class ConstructorCode namespace con f recur where + gconstructorCode :: f a -> Maybe DiagnosticCode +type ConstructorCodes :: Type -> Symbol -> (Type -> Type) -> [Type] -> Maybe Type -> Constraint +class ConstructorCodes namespace con f seen recur where + gconstructorCodes :: Map DiagnosticCode String + +-- If we recur into the 'UnknownDiagnostic' existential datatype, +-- unwrap the existential and obtain the error code. +instance {-# OVERLAPPING #-} + ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts hint) + , HasType namespace (UnknownDiagnostic opts hint) con f ) + => ConstructorCode namespace con f ('Just (UnknownDiagnostic opts hint)) where + gconstructorCode diag = case getType @namespace @(UnknownDiagnostic opts hint) @con @f diag of + UnknownDiagnostic _ _ diag -> diagnosticCode diag +instance {-# OVERLAPPING #-} + ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts hint) ) + => ConstructorCodes namespace con f seen ('Just (UnknownDiagnostic opts hint)) where + gconstructorCodes = Map.empty + +-- | (*) Base instance: use the diagnostic code for this constructor in this namespace. +instance (KnownNameSpace namespace, KnownConstructor namespace con, KnownSymbol con) + => ConstructorCode namespace con f 'Nothing where + gconstructorCode _ = Just $ DiagnosticCode (symbolVal' @(NameSpaceTag namespace) proxy#) $ natVal' @(DiagnosticCodeFor namespace con) proxy# +instance ( KnownNameSpace namespace, KnownConstructor namespace con, KnownSymbol con) => ConstructorCodes namespace con f seen 'Nothing where + gconstructorCodes = + Map.singleton + (DiagnosticCode (symbolVal' @(NameSpaceTag namespace) proxy#) $ natVal' @(DiagnosticCodeFor namespace con) proxy#) + (symbolVal' @con proxy#) + +-- | (**) Recursive instance: recur into the given type. +instance ( ConRecursIntoFor namespace con ~ 'Just ty, HasType namespace ty con f + , Generic ty, GDiagnosticCode namespace (Rep ty) ) + => ConstructorCode namespace con f ('Just ty) where + gconstructorCode diag = gdiagnosticCode @namespace (from $ getType @namespace @ty @con @f diag) +instance ( ConRecursIntoFor namespace con ~ 'Just ty, HasType namespace ty con f + , Generic ty, GDiagnosticCodes namespace (Insert ty seen) (Rep ty) + , Seen seen ty ) + => ConstructorCodes namespace con f seen ('Just ty) where + gconstructorCodes = + -- See Note [diagnosticCodes: don't recur into already-seen types] + if wasSeen @seen @ty + then Map.empty + else gdiagnosticCodes @namespace @(Insert ty seen) @(Rep ty) + +instance (ConstructorCode namespace con f recur, recur ~ ConRecursIntoFor namespace con, KnownSymbol con) + => GDiagnosticCode namespace (M1 i ('MetaCons con x y) f) where + gdiagnosticCode (M1 x) = gconstructorCode @namespace @con @f @recur x +instance (ConstructorCodes namespace con f seen recur, recur ~ ConRecursIntoFor namespace con, KnownSymbol con) + => GDiagnosticCodes namespace seen (M1 i ('MetaCons con x y) f) where + gdiagnosticCodes = gconstructorCodes @namespace @con @f @seen @recur + +-- Handle sum types (the diagnostic types are sums of constructors). +instance (GDiagnosticCode namespace f, GDiagnosticCode namespace g) => GDiagnosticCode namespace (f :+: g) where + gdiagnosticCode (L1 x) = gdiagnosticCode @namespace @f x + gdiagnosticCode (R1 y) = gdiagnosticCode @namespace @g y +instance (GDiagnosticCodes namespace seen f, GDiagnosticCodes namespace seen g) => GDiagnosticCodes namespace seen (f :+: g) where + gdiagnosticCodes = Map.union (gdiagnosticCodes @namespace @seen @f) (gdiagnosticCodes @namespace @seen @g) + +-- Discard metadata we don't need. +instance GDiagnosticCode namespace f + => GDiagnosticCode namespace (M1 i ('MetaData nm mod pkg nt) f) where + gdiagnosticCode (M1 x) = gdiagnosticCode @namespace @f x +instance GDiagnosticCodes namespace seen f + => GDiagnosticCodes namespace seen (M1 i ('MetaData nm mod pkg nt) f) where + gdiagnosticCodes = gdiagnosticCodes @namespace @seen @f + +-- | Decide whether to pick the left or right branch +-- when deciding how to recurse into a product. +type family HasTypeQ (ty :: Type) f :: Maybe Type where + HasTypeQ typ (M1 _ _ (K1 _ typ)) + = 'Just typ + HasTypeQ typ (M1 _ _ x) + = HasTypeQ typ x + HasTypeQ typ (l :*: r) + = Alt (HasTypeQ typ l) (HasTypeQ typ r) + HasTypeQ typ (l :+: r) + = Both (HasTypeQ typ l) (HasTypeQ typ r) + HasTypeQ typ (K1 _ _) + = 'Nothing + HasTypeQ typ U1 + = 'Nothing + HasTypeQ typ V1 + = 'Nothing + +type family Both (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where + Both ('Just a) ('Just a) = 'Just a + +type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where + Alt ('Just a) _ = 'Just a + Alt _ b = b + +type HasType :: Type -> Type -> Symbol -> (Type -> Type) -> Constraint +class HasType namespace ty orig f where + getType :: f a -> ty + +instance HasType namespace ty orig (M1 i s (K1 x ty)) where + getType (M1 (K1 x)) = x +instance HasTypeProd namespace ty (HasTypeQ ty f) orig f g => HasType namespace ty orig (f :*: g) where + getType = getTypeProd @namespace @ty @(HasTypeQ ty f) @orig + +-- The lr parameter tells us whether to pick the left or right +-- branch in a product, and is computed using 'HasTypeQ'. +-- +-- If it's @Just l@, then we have found the type in the left branch, +-- so use that. Otherwise, look in the right branch. +class HasTypeProd namespace ty lr orig f g where + getTypeProd :: (f :*: g) a -> ty + +-- Pick the left branch. +instance HasType namespace ty orig f => HasTypeProd namespace ty ('Just l) orig f g where + getTypeProd (x :*: _) = getType @namespace @ty @orig @f x + +-- Pick the right branch. +instance HasType namespace ty orig g => HasTypeProd namespace ty 'Nothing orig f g where + getTypeProd (_ :*: y) = getType @namespace @ty @orig @g y + +{- Note [diagnosticCodes: don't recur into already-seen types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When traversing through the Generic representation of a datatype to compute all +of the corresponding error codes, we need to keep track of types we have already +seen in order to avoid a runtime loop. + +For example, TcRnMessage is defined recursively in terms of itself: + + data TcRnMessage where + ... + TcRnMessageWithInfo :: !UnitState + -> !TcRnMessageDetailed -- contains a TcRnMessage + -> TcRnMessage + +If we naively computed the collection of error codes, we would get a computation +of the form + + diagnosticCodes @TcRnMessage = ... `Map.union` constructorCodes "TcRnMessageWithInfo" + constructorCodes "TcRnMessageWithInfo" = diagnosticCodes @TcRnMessage + +This would cause an infinite loop. We thus keep track of a list of types we +have already encountered, and when we recur into a type we have already +encountered, we simply skip taking that union (see (**)). + +Note that 'constructorCodes' starts by marking the initial type itself as "seen", +which precisely avoids the loop above when calling 'constructorCodes @TcRnMessage'. +-} + +type Seen :: [Type] -> Type -> Constraint +class Seen seen ty where + wasSeen :: Bool +instance Seen '[] ty where + wasSeen = False +instance {-# OVERLAPPING #-} Seen (ty ': tys) ty where + wasSeen = True +instance Seen tys ty => Seen (ty' ': tys) ty where + wasSeen = wasSeen @tys @ty + +type Insert :: Type -> [Type] -> [Type] +type family Insert ty tys where + Insert ty '[] = '[ty] + Insert ty (ty ': tys) = ty ': tys + Insert ty (ty' ': tys) = ty' ': Insert ty tys + +{- ********************************************************************* +* * + Custom type errors for diagnostic codes +* * +********************************************************************* -} + +-- (ERR1) Improve error messages for recurring into an argument. +instance {-# OVERLAPPABLE #-} + TypeError + ( 'Text "The constructor '" ':<>: 'Text orig ':<>: 'Text "'" + ':$$: 'Text "does not have any argument of type '" ':<>: 'ShowType ty ':<>: 'Text "'." + ':$$: 'Text "" + ':$$: 'Text "This is likely due to an incorrect type family equation:" + ':$$: 'Text " ConRecursIntoFor " ':<>: 'ShowType namespace ':<>: Text " \"" ':<>: 'Text orig ':<>: 'Text "\" = " ':<>: 'ShowType ty ) + => HasType namespace ty orig f where + getType = panic "getType: unreachable" + +-- (ERR2) Improve error messages for missing 'GhcDiagnosticCode' equations. +type KnownConstructor :: Type -> Symbol -> Constraint +type family KnownConstructor namespace con where + KnownConstructor namespace con = + KnownNatOrErr + ( TypeError + ( 'Text "Missing " ':<>: 'ShowType namespace ':<>: Text " diagnostic code for constructor " + ':<>: 'Text "'" ':<>: 'Text con ':<>: 'Text "'." + ':$$: 'Text "" + ':$$: 'Text "Note [Diagnostic codes] in GHC.Types.Error.Codes" + ':$$: 'Text "contains instructions for adding a new diagnostic code." + ) + ) + (DiagnosticCodeFor namespace con) + +type KnownNatOrErr :: Constraint -> Nat -> Constraint +type KnownNatOrErr err n = (Assert err n, KnownNat n) + +-- (ERR3) Improve error messages for invalid namespaces. +type KnownNameSpace :: Type -> Constraint +type family KnownNameSpace namespace where + KnownNameSpace namespace = + ValidNameSpaceOrErr + ( TypeError + ( 'Text "Please provide a 'DiagnosticCodeNameSpace' instance for " ':<>: 'ShowType namespace ':<>: Text "," + ':$$: 'Text "including an associated type family equation for 'NameSpaceTag'." + ) + ) + (NameSpaceTag namespace) + +type ValidNameSpaceOrErr :: Constraint -> Symbol -> Constraint +type ValidNameSpaceOrErr err s = (Assert err s, KnownSymbol s) + +-- Detecting a stuck type family using a data family. +-- See https://blog.csongor.co.uk/report-stuck-families/. +type Assert :: Constraint -> k -> Constraint +type family Assert err n where + Assert _ Dummy = Dummy + Assert _ n = () +data family Dummy :: k diff --git a/GHC/Types/FieldLabel.hs b/GHC/Types/FieldLabel.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/FieldLabel.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable FieldLabelString + +{- +% +% (c) Adam Gundry 2013-2015 +% + +Note [FieldLabel] +~~~~~~~~~~~~~~~~~ +This module defines the representation of FieldLabels as stored in +TyCons. As well as a selector name, these have some extra structure +to support the DuplicateRecordFields and NoFieldSelectors extensions. + +In the normal case (with NoDuplicateRecordFields and FieldSelectors), +a datatype like + + data T = MkT { foo :: Int } + +has + + FieldLabel { flHasDuplicateRecordFields = NoDuplicateRecordFields + , flHasFieldSelector = FieldSelectors + , flSelector = foo }. + +If DuplicateRecordFields is enabled, however, the same declaration instead gives + + FieldLabel { flHasDuplicateRecordFields = DuplicateRecordFields + , flHasFieldSelector = FieldSelectors + , flSelector = foo }. + +We need to keep track of whether FieldSelectors or DuplicateRecordFields were +enabled when a record field was defined, as they affect name resolution and +shadowing of record fields, as explained in Note [NoFieldSelectors] in GHC.Types.Name.Reader +and Note [Reporting duplicate local declarations] in GHC.Rename.Names. +-} + +module GHC.Types.FieldLabel + ( FieldLabelEnv + , FieldLabel(..), flLabel + , DuplicateRecordFields(..) + , FieldSelectors(..) + , flIsOverloaded + ) +where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Types.Name + +import GHC.Data.FastString.Env +import GHC.Types.Unique (Uniquable(..)) +import GHC.Utils.Outputable +import GHC.Utils.Binary + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.DeepSeq +import Data.Bool +import Data.Data + +-- | A map from labels to all the auxiliary information +type FieldLabelEnv = DFastStringEnv FieldLabel + +-- | Fields in an algebraic record type; see Note [FieldLabel]. +data FieldLabel = FieldLabel { + flHasDuplicateRecordFields :: DuplicateRecordFields, + -- ^ Was @DuplicateRecordFields@ on in the defining module for this datatype? + flHasFieldSelector :: FieldSelectors, + -- ^ Was @FieldSelectors@ enabled in the defining module for this datatype? + -- See Note [NoFieldSelectors] in GHC.Rename.Env + flSelector :: Name + -- ^ The 'Name' of the selector function, which uniquely identifies + -- the field label. + } + deriving (Data, Eq) + +-- | User-visible label of a field. +flLabel :: FieldLabel -> FieldLabelString +flLabel = FieldLabelString . occNameFS . nameOccName . flSelector + +instance HasOccName FieldLabel where + occName = nameOccName . flSelector + +instance Outputable FieldLabel where + ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl)) + <> ppr (flHasDuplicateRecordFields fl) + <> ppr (flHasFieldSelector fl)) + +instance Outputable FieldLabelString where + ppr (FieldLabelString l) = ppr l + +instance Uniquable FieldLabelString where + getUnique (FieldLabelString fs) = getUnique fs + +-- | Flag to indicate whether the DuplicateRecordFields extension is enabled. +data DuplicateRecordFields + = DuplicateRecordFields -- ^ Fields may be duplicated in a single module + | NoDuplicateRecordFields -- ^ Fields must be unique within a module (the default) + deriving (Show, Eq, Data) + +instance Binary DuplicateRecordFields where + put_ bh f = put_ bh (f == DuplicateRecordFields) + get bh = bool NoDuplicateRecordFields DuplicateRecordFields <$> get bh + +instance Outputable DuplicateRecordFields where + ppr DuplicateRecordFields = text "+dup" + ppr NoDuplicateRecordFields = text "-dup" + +instance NFData DuplicateRecordFields where + rnf DuplicateRecordFields = () + rnf NoDuplicateRecordFields = () + + +-- | Flag to indicate whether the FieldSelectors extension is enabled. +data FieldSelectors + = FieldSelectors -- ^ Selector functions are available (the default) + | NoFieldSelectors -- ^ Selector functions are not available + deriving (Show, Eq, Data) + +instance Binary FieldSelectors where + put_ bh f = put_ bh (f == FieldSelectors) + get bh = bool NoFieldSelectors FieldSelectors <$> get bh + +instance Outputable FieldSelectors where + ppr FieldSelectors = text "+sel" + ppr NoFieldSelectors = text "-sel" + +instance NFData FieldSelectors where + rnf FieldSelectors = () + rnf NoFieldSelectors = () + +-- | We need the @Binary Name@ constraint here even though there is an instance +-- defined in "GHC.Types.Name", because the we have a SOURCE import, so the +-- instance is not in scope. And the instance cannot be added to Name.hs-boot +-- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name". +instance Binary Name => Binary FieldLabel where + put_ bh (FieldLabel aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + aa <- get bh + ab <- get bh + ac <- get bh + return (FieldLabel aa ab ac) + +flIsOverloaded :: FieldLabel -> Bool +flIsOverloaded fl = + flHasDuplicateRecordFields fl == DuplicateRecordFields + || flHasFieldSelector fl == NoFieldSelectors diff --git a/GHC/Types/Fixity.hs b/GHC/Types/Fixity.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Fixity.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} -- For re-export of GHC.Hs.Basic instances + +-- | Fixity +module GHC.Types.Fixity + ( Fixity (..) + , FixityDirection (..) + , LexicalFixity (..) + , maxPrecedence + , minPrecedence + , defaultFixity + , negateFixity + , funTyFixity + , compareFixity + , module GHC.Hs.Basic + ) +where + +import GHC.Prelude + +import Language.Haskell.Syntax.Basic (LexicalFixity(..), FixityDirection(..), Fixity(..) ) +import GHC.Hs.Basic () -- For instances only + +------------------------ + +maxPrecedence, minPrecedence :: Int +maxPrecedence = 9 +minPrecedence = 0 + +defaultFixity :: Fixity +defaultFixity = Fixity maxPrecedence InfixL + +negateFixity, funTyFixity :: Fixity +-- Wired-in fixities +negateFixity = Fixity 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity (-1) InfixR -- Fixity of '->', see #15235 + +{- +Consider + +\begin{verbatim} + a `op1` b `op2` c +\end{verbatim} +@(compareFixity op1 op2)@ tells which way to arrange application, or +whether there's an error. +-} + +compareFixity :: Fixity -> Fixity + -> (Bool, -- Error please + Bool) -- Associate to the right: a op1 (b op2 c) +compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) + = case prec1 `compare` prec2 of + GT -> left + LT -> right + EQ -> case (dir1, dir2) of + (InfixR, InfixR) -> right + (InfixL, InfixL) -> left + _ -> error_please + where + right = (False, True) + left = (False, False) + error_please = (True, False) diff --git a/GHC/Types/Fixity/Env.hs b/GHC/Types/Fixity/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Fixity/Env.hs @@ -0,0 +1,45 @@ +module GHC.Types.Fixity.Env + ( FixityEnv + , FixItem (..) + , emptyFixityEnv + , lookupFixity + , mkIfaceFixCache + , emptyIfaceFixCache + ) +where + +import GHC.Prelude + +import GHC.Types.Fixity +import GHC.Types.Name +import GHC.Types.Name.Env + +import GHC.Utils.Outputable + +-- | Fixity environment mapping names to their fixities +type FixityEnv = NameEnv FixItem + +-- | Fixity information for an 'Name'. We keep the OccName in the range +-- so that we can generate an interface from it +data FixItem = FixItem OccName Fixity + +instance Outputable FixItem where + ppr (FixItem occ fix) = ppr fix <+> ppr occ + +emptyFixityEnv :: FixityEnv +emptyFixityEnv = emptyNameEnv + +lookupFixity :: FixityEnv -> Name -> Fixity +lookupFixity env n = case lookupNameEnv env n of + Just (FixItem _ fix) -> fix + Nothing -> defaultFixity + +-- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface' +mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity +mkIfaceFixCache pairs + = \n -> lookupOccEnv env n + where + env = mkOccEnv pairs + +emptyIfaceFixCache :: OccName -> Maybe Fixity +emptyIfaceFixCache _ = Nothing diff --git a/GHC/Types/ForeignCall.hs b/GHC/Types/ForeignCall.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/ForeignCall.hs @@ -0,0 +1,376 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Foreign]{Foreign calls} +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.ForeignCall ( + ForeignCall(..), isSafeForeignCall, + Safety(..), playSafe, playInterruptible, + + CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, + CCallSpec(..), + CCallTarget(..), isDynamicTarget, + CCallConv(..), defaultCCallConv, ccallConvAttribute, + + Header(..), CType(..), + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Utils.Binary +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Unit.Module +import GHC.Types.SourceText ( SourceText, pprWithSourceText ) + +import Data.Char +import Data.Data + +import Control.DeepSeq (NFData(..)) + +{- +************************************************************************ +* * +\subsubsection{Data types} +* * +************************************************************************ +-} + +newtype ForeignCall = CCall CCallSpec + deriving Eq + +isSafeForeignCall :: ForeignCall -> Bool +isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe + +-- We may need more clues to distinguish foreign calls +-- but this simple printer will do for now +instance Outputable ForeignCall where + ppr (CCall cc) = ppr cc + +data Safety + = PlaySafe -- ^ Might invoke Haskell GC, or do a call back, or + -- switch threads, etc. So make sure things are + -- tidy before the call. Additionally, in the threaded + -- RTS we arrange for the external call to be executed + -- by a separate OS thread, i.e., _concurrently_ to the + -- execution of other Haskell threads. + + | PlayInterruptible -- ^ Like PlaySafe, but additionally + -- the worker thread running this foreign call may + -- be unceremoniously killed, so it must be scheduled + -- on an unbound thread. + + | PlayRisky -- ^ None of the above can happen; the call will return + -- without interacting with the runtime system at all. + -- Specifically: + -- + -- * No GC + -- * No call backs + -- * No blocking + -- * No precise exceptions + -- + deriving ( Eq, Show, Data, Enum ) + -- Show used just for Show Lex.Token, I think + +instance Outputable Safety where + ppr PlaySafe = text "safe" + ppr PlayInterruptible = text "interruptible" + ppr PlayRisky = text "unsafe" + +playSafe :: Safety -> Bool +playSafe PlaySafe = True +playSafe PlayInterruptible = True +playSafe PlayRisky = False + +playInterruptible :: Safety -> Bool +playInterruptible PlayInterruptible = True +playInterruptible _ = False + +{- +************************************************************************ +* * +\subsubsection{Calling C} +* * +************************************************************************ +-} + +data CExportSpec + = CExportStatic -- foreign export ccall foo :: ty + SourceText -- of the CLabelString. + -- See Note [Pragma source text] in "GHC.Types.SourceText" + CLabelString -- C Name of exported function + CCallConv + deriving Data + +data CCallSpec + = CCallSpec CCallTarget -- What to call + CCallConv -- Calling convention to use. + Safety + deriving( Eq ) + +-- The call target: + +-- | How to call a particular function in C-land. +data CCallTarget + -- An "unboxed" ccall# to named function in a particular package. + = StaticTarget + SourceText -- of the CLabelString. + -- See Note [Pragma source text] in "GHC.Types.SourceText" + CLabelString -- C-land name of label. + + (Maybe Unit) -- What package the function is in. + -- If Nothing, then it's taken to be in the current package. + -- Note: This information is only used for PrimCalls on Windows. + -- See CLabel.labelDynamic and CoreToStg.coreToStgApp + -- for the difference in representation between PrimCalls + -- and ForeignCalls. If the CCallTarget is representing + -- a regular ForeignCall then it's safe to set this to Nothing. + + -- The first argument of the import is the name of a function pointer (an Addr#). + -- Used when importing a label as "foreign import ccall "dynamic" ..." + Bool -- True => really a function + -- False => a value; only + -- allowed in CAPI imports + | DynamicTarget + + deriving( Eq, Data ) + +isDynamicTarget :: CCallTarget -> Bool +isDynamicTarget DynamicTarget = True +isDynamicTarget _ = False + +{- +Stuff to do with calling convention: + +ccall: Caller allocates parameters, *and* deallocates them. + +See: http://www.programmersheaven.com/2/Calling-conventions +-} + +-- any changes here should be replicated in the Callconv type in template haskell +data CCallConv + = CCallConv + | CApiConv + | StdCallConv + | PrimCallConv + | JavaScriptCallConv + deriving (Show, Eq, Data, Enum) + +instance Outputable CCallConv where + ppr StdCallConv = text "stdcall" + ppr CCallConv = text "ccall" + ppr CApiConv = text "capi" + ppr PrimCallConv = text "prim" + ppr JavaScriptCallConv = text "javascript" + +defaultCCallConv :: CCallConv +defaultCCallConv = CCallConv + +{- +Generate the gcc attribute corresponding to the given +calling convention (used by PprAbsC): +-} + +ccallConvAttribute :: CCallConv -> SDoc +ccallConvAttribute StdCallConv = panic "ccallConvAttribute StdCallConv" +ccallConvAttribute CCallConv = empty +ccallConvAttribute CApiConv = empty +ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" +ccallConvAttribute JavaScriptCallConv = empty + +type CLabelString = FastString -- A C label, completely unencoded + +pprCLabelString :: CLabelString -> SDoc +pprCLabelString lbl = ftext lbl + +isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label +isCLabelString lbl + = all ok (unpackFS lbl) + where + ok c = isAlphaNum c || c == '_' || c == '.' || c == '@' + -- The '.' appears in e.g. "foo.so" in the + -- module part of a ExtName. Maybe it should be separate + +-- Printing into C files: + +instance Outputable CExportSpec where + ppr (CExportStatic _ str _) = pprCLabelString str + +instance Outputable CCallSpec where + ppr (CCallSpec fun cconv safety) + = hcat [ whenPprDebug callconv, ppr_fun fun, text " ::" ] + where + callconv = text "{-" <> ppr cconv <> text "-}" + + gc_suf | playSafe safety = text "_safe" + | otherwise = text "_unsafe" + + ppr_fun (StaticTarget st lbl mPkgId isFun) + = (if isFun then text "__ffi_static_ccall" + else text "__ffi_static_ccall_value") + <> gc_suf + <+> (case mPkgId of + Nothing -> empty + Just pkgId -> ppr pkgId) + <> text ":" + <> ppr lbl + <+> (pprWithSourceText st empty) + + ppr_fun DynamicTarget + = text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\"" + +-- The filename for a C header file +-- See Note [Pragma source text] in "GHC.Types.SourceText" +data Header = Header SourceText FastString + deriving (Eq, Data) + +instance Outputable Header where + ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) + +-- | A C type, used in CAPI FFI calls +data CType = CType SourceText -- See Note [Pragma source text] in "GHC.Types.SourceText" + (Maybe Header) -- header to include for this type + (SourceText,FastString) -- the type itself + deriving (Eq, Data) + +instance Outputable CType where + ppr (CType stp mh (stct,ct)) + = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc + <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" + where hDoc = case mh of + Nothing -> empty + Just h -> ppr h + +{- +************************************************************************ +* * +\subsubsection{Misc} +* * +************************************************************************ +-} + +instance Binary ForeignCall where + put_ bh (CCall aa) = put_ bh aa + get bh = do aa <- get bh; return (CCall aa) + +instance Binary Safety where + put_ bh PlaySafe = + putByte bh 0 + put_ bh PlayInterruptible = + putByte bh 1 + put_ bh PlayRisky = + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return PlaySafe + 1 -> return PlayInterruptible + _ -> return PlayRisky + +instance Binary CExportSpec where + put_ bh (CExportStatic ss aa ab) = do + put_ bh ss + put_ bh aa + put_ bh ab + get bh = do + ss <- get bh + aa <- get bh + ab <- get bh + return (CExportStatic ss aa ab) + +instance Binary CCallSpec where + put_ bh (CCallSpec aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + aa <- get bh + ab <- get bh + ac <- get bh + return (CCallSpec aa ab ac) + +instance Binary CCallTarget where + put_ bh (StaticTarget ss aa ab ac) = do + putByte bh 0 + put_ bh ss + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh DynamicTarget = + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do ss <- get bh + aa <- get bh + ab <- get bh + ac <- get bh + return (StaticTarget ss aa ab ac) + _ -> return DynamicTarget + +instance Binary CCallConv where + put_ bh CCallConv = + putByte bh 0 + put_ bh StdCallConv = + putByte bh 1 + put_ bh PrimCallConv = + putByte bh 2 + put_ bh CApiConv = + putByte bh 3 + put_ bh JavaScriptCallConv = + putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> return CCallConv + 1 -> return StdCallConv + 2 -> return PrimCallConv + 3 -> return CApiConv + _ -> return JavaScriptCallConv + +instance Binary CType where + put_ bh (CType s mh fs) = do put_ bh s + put_ bh mh + put_ bh fs + get bh = do s <- get bh + mh <- get bh + fs <- get bh + return (CType s mh fs) + +instance Binary Header where + put_ bh (Header s h) = put_ bh s >> put_ bh h + get bh = do s <- get bh + h <- get bh + return (Header s h) + +instance NFData ForeignCall where + rnf (CCall c) = rnf c + +instance NFData Safety where + rnf PlaySafe = () + rnf PlayInterruptible = () + rnf PlayRisky = () + +instance NFData CCallSpec where + rnf (CCallSpec t c s) = rnf t `seq` rnf c `seq` rnf s + +instance NFData CCallTarget where + rnf (StaticTarget s a b c) = rnf s `seq` rnf a `seq` rnf b `seq` rnf c + rnf DynamicTarget = () + +instance NFData CCallConv where + rnf CCallConv = () + rnf StdCallConv = () + rnf PrimCallConv = () + rnf CApiConv = () + rnf JavaScriptCallConv = () + +instance NFData CType where + rnf (CType s mh fs) = rnf s `seq` rnf mh `seq` rnf fs + +instance NFData Header where + rnf (Header s h) = rnf s `seq` rnf h diff --git a/GHC/Types/ForeignStubs.hs b/GHC/Types/ForeignStubs.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/ForeignStubs.hs @@ -0,0 +1,92 @@ +-- | Foreign export stubs +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeApplications #-} +module GHC.Types.ForeignStubs + ( ForeignStubs (..) + , CHeader(..) + , CStub(..) + , initializerCStub + , finalizerCStub + , appendStubC + ) +where + +import {-# SOURCE #-} GHC.Cmm.CLabel + +import GHC.Platform +import GHC.Utils.Outputable +import Data.List ((++)) +import Data.Monoid +import Data.Semigroup +import Data.Coerce + +data CStub = CStub { getCStub :: SDoc + , getInitializers :: [CLabel] + -- ^ Initializers to be run at startup + -- See Note [Initializers and finalizers in Cmm] in + -- "GHC.Cmm.InitFini". + , getFinalizers :: [CLabel] + -- ^ Finalizers to be run at shutdown + } + +emptyCStub :: CStub +emptyCStub = CStub empty [] [] + +instance Monoid CStub where + mempty = emptyCStub + +instance Semigroup CStub where + CStub a0 b0 c0 <> CStub a1 b1 c1 = + CStub (a0 $$ a1) (b0 ++ b1) (c0 ++ c1) + +functionCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub +functionCStub platform clbl declarations body = + CStub body' [] [] + where + body' = vcat + [ declarations + , hsep [text "void", pprCLabel platform clbl, text "(void)"] + , braces body + ] + +-- | @initializerCStub fn_nm decls body@ is a 'CStub' containing C initializer +-- function (e.g. an entry of the @.init_array@ section) named +-- @fn_nm@ with the given body and the given set of declarations. +initializerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub +initializerCStub platform clbl declarations body = + functionCStub platform clbl declarations body + `mappend` CStub empty [clbl] [] + +-- | @finalizerCStub fn_nm decls body@ is a 'CStub' containing C finalizer +-- function (e.g. an entry of the @.fini_array@ section) named +-- @fn_nm@ with the given body and the given set of declarations. +finalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub +finalizerCStub platform clbl declarations body = + functionCStub platform clbl declarations body + `mappend` CStub empty [] [clbl] + +newtype CHeader = CHeader { getCHeader :: SDoc } + +instance Monoid CHeader where + mempty = CHeader empty + mconcat = coerce (vcat @SDoc) + +instance Semigroup CHeader where + (<>) = coerce (($$) @SDoc) + +-- | Foreign export stubs +data ForeignStubs + = NoStubs + -- ^ We don't have any stubs + | ForeignStubs CHeader CStub + -- ^ There are some stubs. Parameters: + -- + -- 1) Header file prototypes for + -- "foreign exported" functions + -- + -- 2) C stubs to use when calling + -- "foreign exported" functions + +appendStubC :: ForeignStubs -> CStub -> ForeignStubs +appendStubC NoStubs c_code = ForeignStubs mempty c_code +appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c `mappend` c_code) diff --git a/GHC/Types/GREInfo.hs b/GHC/Types/GREInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/GREInfo.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Renamer-level information about 'Name's. +-- +-- Renamer equivalent of 'TyThing'. +module GHC.Types.GREInfo where + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Types.FieldLabel +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.DeepSeq ( NFData(..), deepseq ) + +import Data.Data ( Data ) +import Data.List.NonEmpty ( NonEmpty ) +import qualified Data.List.NonEmpty as NonEmpty + +{-********************************************************************** +* * + GREInfo +* * +************************************************************************ + +Note [GREInfo] +~~~~~~~~~~~~~~ +In the renamer, we sometimes need a bit more information about a 'Name', e.g. +whether it is a type constructor, class, data constructor, record field, etc. + +For example, when typechecking record construction, the renamer needs to look +up the fields of the data constructor being used (see e.g. GHC.Rename.Pat.rnHsRecFields). +Extra information also allows us to provide better error messages when a fatal +error occurs in the renamer, as it allows us to distinguish classes, type families, +type synonyms, etc. + +For imported Names, we have access to the full type information in the form of +a TyThing (although see Note [Retrieving the GREInfo from interfaces]). +However, for Names in the module currently being renamed, we don't +yet have full information. Instead of using TyThing, we use the GREInfo type, +and this information gets affixed to each element in the GlobalRdrEnv. + +This allows us to treat imported and local Names in a consistent manner: +always look at the GREInfo. + +Note [Retrieving the GREInfo from interfaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a TyThing, we can easily compute the corresponding GREInfo: this is +done in GHC.Types.TyThing.tyThingGREInfo. + +However, one often needs to produce GlobalRdrElts (and thus their GREInfos) +directly after loading interface files, before they are typechecked. For example: + + - GHC.Tc.Module.tcRnModuleTcRnM first calls tcRnImports, which starts off + calling rnImports which transitively calls filterImports. That function + is responsible for coughing up GlobalRdrElts (and their GREInfos) obtained + from interfaces, but we will only typecheck the interfaces after we have + finished processing the imports (see e.g. the logic at the start of tcRnImports + which sets eps_is_boot, which decides whether we should look in the boot + or non-boot interface for any particular module). + - GHC.Tc.Utils.Backpack.mergeSignatures first loads the relevant signature + interfaces to merge them, but only later on does it typecheck them. + +In both of these examples, what's important is that we **lazily** produce the +GREInfo: it should only be consulted once the interfaces have been typechecked, +which will add the necessary information to the type-level environment. +In particular, the respective functions 'filterImports' and 'mergeSignatures' +should NOT force the gre_info field. + +We delay the loading of interfaces by making the gre_info field of 'GlobalRdrElt' +a thunk which, when forced, loads the interface, looks up the 'Name' in the type +environment to get its associated TyThing, and computes the GREInfo from that. +See 'GHC.Rename.Env.lookupGREInfo'. + +A possible alternative design would be to change the AvailInfo datatype to also +store GREInfo. We currently don't do that, as this would mean that every time +an interface re-exports something it has to also provide its GREInfo, which +could lead to bloat. + +Note [Forcing GREInfo] +~~~~~~~~~~~~~~~~~~~~~~ +The GREInfo field of a GlobalRdrElt needs to be lazy, as explained in +Note [Retrieving the GREInfo from interfaces]. For imported things, this field +is usually a thunk which looks up the GREInfo in a type environment +(see GHC.Rename.Env.lookupGREInfo). + +We thus need to be careful not to introduce space leaks: such thunks could end +up retaining old type environments, which would violate invariant (5) of +Note [GHC Heap Invariants] in GHC.Driver.Make. This can happen, for example, +when reloading in GHCi (see e.g. test T15369, which can trigger the ghci leak check +if we're not careful). + +A naive approach is to simply deeply force the whole GlobalRdrEnv. However, +forcing the GREInfo thunks can force the loading of interface files which we +otherwise might not need to load, so it leads to wasted work. + +Instead, whenever we are about to store the GlobalRdrEnv somewhere (such as +in ModDetails), we dehydrate it by stripping away the GREInfo field, turning it +into (). See 'forceGlobalRdrEnv' and its cousin 'hydrateGlobalRdrEnv', +as well as Note [IfGlobalRdrEnv] in GHC.Types.Name.Reader. + +Search for references to this note in the code for illustration. +-} + +-- | Information about a 'Name' that is pertinent to the renamer. +-- +-- See Note [GREInfo] +data GREInfo + -- | A variable (an 'Id' or a 'TyVar') + = Vanilla + -- | An unbound GRE... could be anything + | UnboundGRE + -- | 'TyCon' + | IAmTyCon !(TyConFlavour Name) + -- | 'ConLike' + | IAmConLike !ConInfo + -- ^ The constructor fields. + -- See Note [Local constructor info in the renamer]. + -- | Record field + | IAmRecField !RecFieldInfo + + deriving Data + + +plusGREInfo :: GREInfo -> GREInfo -> GREInfo +plusGREInfo Vanilla Vanilla = Vanilla +plusGREInfo UnboundGRE UnboundGRE = UnboundGRE +plusGREInfo (IAmTyCon {}) info2@(IAmTyCon {}) = info2 +plusGREInfo (IAmConLike {}) info2@(IAmConLike {}) = info2 +plusGREInfo (IAmRecField {}) info2@(IAmRecField {}) = info2 +plusGREInfo info1 info2 = pprPanic "plusInfo" $ + vcat [ text "info1:" <+> ppr info1 + , text "info2:" <+> ppr info2 ] + +instance Outputable GREInfo where + ppr Vanilla = text "Vanilla" + ppr UnboundGRE = text "UnboundGRE" + ppr (IAmTyCon flav) + = text "TyCon" <+> ppr flav + ppr (IAmConLike info) + = text "ConLike" <+> ppr info + ppr (IAmRecField info) + = text "RecField" <+> ppr info + +{-********************************************************************** +* * + Constructor info +* * +************************************************************************ + +Note [Local constructor info in the renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [GREInfo], information pertinent to the renamer is +stored using the GREInfo datatype. What information do we need about constructors? + +Consider the following example: + + data T = T1 { x, y :: Int } + | T2 { x :: Int } + | T3 + | T4 Int Bool + +We need to know: +* The fields of the data constructor, so that + - We can complain if you say `T1 { v = 3 }`, where `v` is not a field of `T1` + See the following call stack + * GHC.Rename.Expr.rnExpr (RecordCon case) + * GHC.Rename.Pat.rnHsRecFields + * GHC.Rename.Env.lookupRecFieldOcc + - Ditto if you pattern match on `T1 { v = x }`. + See the following call stack + * GHC.Rename.Pat.rnHsRecPatsAndThen + * GHC.Rename.Pat.rnHsRecFields + * GHC.Rename.Env.lookupRecFieldOcc + - We can fill in the dots if you say `T1 {..}` in construction or pattern matching + See GHC.Rename.Pat.rnHsRecFields.rn_dotdot + + This information is stored in ConFieldInfo. + +* Whether the constructor is nullary. + We need to know this to accept `T2 {..}`, and `T3 {..}`, but reject `T4 {..}`, + in both construction and pattern matching. + See GHC.Rename.Pat.rnHsRecFields.rn_dotdot + and Note [Nullary constructors and empty record wildcards] + + This information is stored in ConFieldInfo. + +* Whether the constructor is a data constructor or a pattern synonym, and, + if it is a data constructor, what are the other data constructors of the + parent type. This is used for computing irrefutability of pattern matches + when deciding how to desugar do blocks (whether to use a fail operation). + See GHC.Hs.Pat.isIrrefutableHsPat. + + This information is stored in ConLikeInfo. + +Note [Nullary constructors and empty record wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A nullary constructor is one with no arguments. +For example, both `data T = MkT` and `data T = MkT {}` are nullary. + +For consistency and TH convenience, it was agreed that a `{..}` +match or usage on nullary constructors would be accepted. +This is done as as per https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0496-empty-record-wildcards.rst +-} + +-- | Information known to the renamer about a data constructor or pattern synonym. +-- +-- See Note [Local constructor info in the renamer]. +data ConInfo + = ConInfo + { conLikeInfo :: !ConLikeInfo + , conFieldInfo :: !ConFieldInfo + } + deriving stock Eq + deriving Data + +-- | Whether a constructor is a data constructor or a pattern synonym. +-- +-- See Note [Local constructor info in the renamer]. +data ConLikeInfo + = ConIsData + { conLikeDataCons :: [Name] + -- ^ All the 'DataCon's of the parent 'TyCon', + -- including the 'ConLike' itself. + -- + -- Used in 'GHC.Hs.Pat.isIrrefutableHsPat'. + } + | ConIsPatSyn + deriving stock Eq + deriving Data + +instance NFData ConInfo where + rnf (ConInfo a b) = rnf a `seq` rnf b + +instance NFData ConLikeInfo where + rnf (ConIsData a) = rnf a + rnf ConIsPatSyn = () + + +-- | Information about the record fields of a constructor. +-- +-- See Note [Local constructor info in the renamer] +data ConFieldInfo + = ConHasRecordFields (NonEmpty FieldLabel) + | ConHasPositionalArgs + | ConIsNullary + deriving stock Eq + deriving Data + +instance NFData ConFieldInfo where + rnf ConIsNullary = () + rnf ConHasPositionalArgs = () + rnf (ConHasRecordFields flds) = rnf flds + +mkConInfo :: ConLikeInfo -> VisArity -> [FieldLabel] -> ConInfo +mkConInfo con_ty n flds = + ConInfo { conLikeInfo = con_ty + , conFieldInfo = mkConFieldInfo n flds } + +mkConFieldInfo :: Arity -> [FieldLabel] -> ConFieldInfo +mkConFieldInfo 0 _ = ConIsNullary +mkConFieldInfo _ fields = maybe ConHasPositionalArgs ConHasRecordFields + $ NonEmpty.nonEmpty fields + +conInfoFields :: ConInfo -> [FieldLabel] +conInfoFields = conFieldInfoFields . conFieldInfo + +conFieldInfoFields :: ConFieldInfo -> [FieldLabel] +conFieldInfoFields (ConHasRecordFields fields) = NonEmpty.toList fields +conFieldInfoFields ConHasPositionalArgs = [] +conFieldInfoFields ConIsNullary = [] + +instance Outputable ConInfo where + ppr (ConInfo { conLikeInfo = con_ty, conFieldInfo = fld_info }) + = text "ConInfo" <+> braces + (text "con_ty:" <+> ppr con_ty <> comma + <+> text "fields:" <+> ppr fld_info) + +instance Outputable ConLikeInfo where + ppr (ConIsData cons) = text "ConIsData" <+> parens (ppr cons) + ppr ConIsPatSyn = text "ConIsPatSyn" + +instance Outputable ConFieldInfo where + ppr ConIsNullary = text "ConIsNullary" + ppr ConHasPositionalArgs = text "ConHasPositionalArgs" + ppr (ConHasRecordFields fieldLabels) = + text "ConHasRecordFields" <+> braces (ppr fieldLabels) + +-- | The 'Name' of a 'ConLike'. +-- +-- Useful when we are in the renamer and don't yet have a full 'DataCon' or +-- 'PatSyn' to hand. +data ConLikeName + = DataConName { conLikeName_Name :: !Name } + | PatSynName { conLikeName_Name :: !Name } + deriving (Eq, Data) + +instance NamedThing ConLikeName where + getName = conLikeName_Name + +instance Outputable ConLikeName where + ppr = ppr . conLikeName_Name + +instance OutputableBndr ConLikeName where + pprInfixOcc con = pprInfixName (conLikeName_Name con) + pprPrefixOcc con = pprPrefixName (conLikeName_Name con) + +instance Uniquable ConLikeName where + getUnique = getUnique . conLikeName_Name + +instance NFData ConLikeName where + rnf = rnf . conLikeName_Name + +{-********************************************************************** +* * + Record field info +* * +**********************************************************************-} + +data RecFieldInfo + = RecFieldInfo + { recFieldLabel :: !FieldLabel + , recFieldCons :: !(UniqSet ConLikeName) + -- ^ The constructors which have this field label. + -- Always non-empty. + -- + -- NB: these constructors will always share a single parent, + -- as the field label disambiguates between parents in the presence + -- of duplicate record fields. + } + deriving (Eq, Data) + +instance NFData RecFieldInfo where + rnf (RecFieldInfo lbl cons) + = rnf lbl `seq` nonDetStrictFoldUniqSet deepseq () cons + +instance Outputable RecFieldInfo where + ppr (RecFieldInfo { recFieldLabel = fl, recFieldCons = cons }) + = text "RecFieldInfo" <+> braces + (text "recFieldLabel:" <+> ppr fl <> comma + <+> text "recFieldCons:" <+> pprWithCommas ppr (nonDetEltsUniqSet cons)) diff --git a/GHC/Types/Hint.hs b/GHC/Types/Hint.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Hint.hs @@ -0,0 +1,698 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module GHC.Types.Hint ( + GhcHint(..) + , AvailableBindings(..) + , InstantiationSuggestion(..) + , LanguageExtensionHint(..) + , ImportItemSuggestion(..) + , ImportSuggestion(..) + , HowInScope(..) + , SimilarName(..) + , StarIsType(..) + , UntickedPromotedThing(..) + , AssumedDerivingStrategy(..) + , SigLike(..) + , pprUntickedConstructor, isBareSymbol + , suggestExtension + , suggestExtensionWithInfo + , suggestExtensions + , suggestExtensionsWithInfo + , suggestAnyExtension + , suggestAnyExtensionWithInfo + , useExtensionInOrderTo + , noStarIsTypeHints + ) where + +import Language.Haskell.Syntax.Expr (LHsExpr) +import Language.Haskell.Syntax (LPat, LIdP, LHsSigType, LHsSigWcType, Sig) + +import GHC.Prelude + +import qualified Data.List.NonEmpty as NE + +import qualified GHC.LanguageExtensions as LangExt +import GHC.Unit.Module (ModuleName, Module) +import GHC.Unit.Module.Imported (ImportedModsVal) +import GHC.Hs.Extension (GhcTc, GhcRn, GhcPs) +import GHC.Core.Class (Class) +import GHC.Core.Coercion +import GHC.Core.FamInstEnv (FamFlavor) +import GHC.Core.TyCon (TyCon) +import GHC.Core.Type (Type) +import GHC.Types.Fixity (LexicalFixity(..)) +import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName) +import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec) +import GHC.Types.SrcLoc (SrcSpan) +import GHC.Types.Basic (Activation, RuleName) +import GHC.Parser.Errors.Basic +import GHC.Utils.Outputable +import GHC.Data.FastString (fsLit, FastString) + +import Data.Typeable ( Typeable ) +import Data.Map.Strict (Map) + +-- | The bindings we have available in scope when +-- suggesting an explicit type signature. +data AvailableBindings + = NamedBindings (NE.NonEmpty Name) + | UnnamedBinding + -- ^ An unknown binding (i.e. too complicated to turn into a 'Name') + + +data LanguageExtensionHint + = -- | Suggest to enable the input extension. This is the hint that + -- GHC emits if this is not a \"known\" fix, i.e. this is GHC giving + -- its best guess on what extension might be necessary to make a + -- certain program compile. For example, GHC might suggests to + -- enable 'BlockArguments' when the user simply formatted incorrectly + -- the input program, so GHC here is trying to be as helpful as + -- possible. + -- If the input 'SDoc' is not empty, it will contain some extra + -- information about the why the extension is required, but + -- it's totally irrelevant/redundant for IDEs and other tools. + SuggestSingleExtension !SDoc !LangExt.Extension + -- | Suggest to enable the input extensions. The list + -- is to be intended as /disjunctive/ i.e. the user is + -- suggested to enable /any/ of the extensions listed. If + -- the input 'SDoc' is not empty, it will contain some extra + -- information about the why the extensions are required, but + -- it's totally irrelevant/redundant for IDEs and other tools. + | SuggestAnyExtension !SDoc [LangExt.Extension] + -- | Suggest to enable the input extensions. The list + -- is to be intended as /conjunctive/ i.e. the user is + -- suggested to enable /all/ the extensions listed. If + -- the input 'SDoc' is not empty, it will contain some extra + -- information about the why the extensions are required, but + -- it's totally irrelevant/redundant for IDEs and other tools. + | SuggestExtensions !SDoc [LangExt.Extension] + -- | Suggest to enable the input extension in order to fix + -- a certain problem. This is the suggestion that GHC emits when + -- is more-or-less clear \"what's going on\". For example, if + -- both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are + -- turned on, the right thing to do is to enabled 'DerivingStrategies', + -- so in contrast to 'SuggestSingleExtension' GHC will be a bit more + -- \"imperative\" (i.e. \"Use X Y Z in order to ... \"). + -- If the input 'SDoc' is not empty, it will contain some extra + -- information about the why the extensions are required, but + -- it's totally irrelevant/redundant for IDEs and other tools. + | SuggestExtensionInOrderTo !SDoc !LangExt.Extension + +-- | Suggests a single extension without extra user info. +suggestExtension :: LangExt.Extension -> GhcHint +suggestExtension ext = SuggestExtension (SuggestSingleExtension empty ext) + +-- | Like 'suggestExtension' but allows supplying extra info for the user. +suggestExtensionWithInfo :: SDoc -> LangExt.Extension -> GhcHint +suggestExtensionWithInfo extraInfo ext = SuggestExtension (SuggestSingleExtension extraInfo ext) + +-- | Suggests to enable /every/ extension in the list. +suggestExtensions :: [LangExt.Extension] -> GhcHint +suggestExtensions exts = SuggestExtension (SuggestExtensions empty exts) + +-- | Like 'suggestExtensions' but allows supplying extra info for the user. +suggestExtensionsWithInfo :: SDoc -> [LangExt.Extension] -> GhcHint +suggestExtensionsWithInfo extraInfo exts = SuggestExtension (SuggestExtensions extraInfo exts) + +-- | Suggests to enable /any/ extension in the list. +suggestAnyExtension :: [LangExt.Extension] -> GhcHint +suggestAnyExtension exts = SuggestExtension (SuggestAnyExtension empty exts) + +-- | Like 'suggestAnyExtension' but allows supplying extra info for the user. +suggestAnyExtensionWithInfo :: SDoc -> [LangExt.Extension] -> GhcHint +suggestAnyExtensionWithInfo extraInfo exts = SuggestExtension (SuggestAnyExtension extraInfo exts) + +useExtensionInOrderTo :: SDoc -> LangExt.Extension -> GhcHint +useExtensionInOrderTo extraInfo ext = SuggestExtension (SuggestExtensionInOrderTo extraInfo ext) + +-- | A type for hints emitted by GHC. +-- A /hint/ suggests a possible way to deal with a particular warning or error. +data GhcHint + = + {-| An \"unknown\" hint. This type constructor allows arbitrary + -- hints to be embedded. The typical use case would be GHC plugins + -- willing to emit hints alongside their custom diagnostics. + -} + forall a. (Outputable a, Typeable a) => UnknownHint a + {-| Suggests adding a particular language extension. GHC will do its best trying + to guess when the user is using the syntax of a particular language extension + without having the relevant extension enabled. + + Example: If the user uses the keyword \"mdo\" (and we are in a monadic block), but + the relevant extension is not enabled, GHC will emit a 'SuggestExtension RecursiveDo'. + + Test case(s): parser/should_fail/T12429, parser/should_fail/T8501c, + parser/should_fail/T18251e, ... (and many more) + + -} + | SuggestExtension !LanguageExtensionHint + {-| Suggests possible corrections of a misspelled pragma. Its argument + represents all applicable suggestions. + + Example: {-# LNGUAGE BangPatterns #-} + + Test case(s): parser/should_compile/T21589 + -} + | SuggestCorrectPragmaName ![String] + {-| Suggests that a monadic code block is probably missing a \"do\" keyword. + + Example: + main = + putStrLn "hello" + putStrLn "world" + + Test case(s): parser/should_fail/T8501a, parser/should_fail/readFail007, + parser/should_fail/InfixAppPatErr, parser/should_fail/T984 + -} + | SuggestMissingDo + {-| Suggests that a \"let\" expression is needed in a \"do\" block. + + Test cases: None (that explicitly test this particular hint is emitted). + -} + | SuggestLetInDo + {-| Suggests to add an \".hsig\" signature file to the Cabal manifest. + + Triggered by: 'GHC.Driver.Errors.Types.DriverUnexpectedSignature', if Cabal + is being used. + + Example: See comment of 'DriverUnexpectedSignature'. + + Test case(s): driver/T12955 + + -} + | SuggestAddSignatureCabalFile !ModuleName + {-| Suggests to explicitly list the instantiations for the signatures in + the GHC invocation command. + + Triggered by: 'GHC.Driver.Errors.Types.DriverUnexpectedSignature', if Cabal + is /not/ being used. + + Example: See comment of 'DriverUnexpectedSignature'. + + Test case(s): driver/T12955 + -} + | SuggestSignatureInstantiations !ModuleName [InstantiationSuggestion] + {-| Suggests to use spaces instead of tabs. + + Triggered by: 'GHC.Parser.Errors.Types.PsWarnTab'. + + Examples: None + Test Case(s): None + -} + | SuggestUseSpaces + {-| Suggests adding a whitespace after the given symbol. + + Examples: None + Test Case(s): parser/should_compile/T18834a.hs + -} + | SuggestUseWhitespaceAfter !OperatorWhitespaceSymbol + {-| Suggests adding a whitespace around the given operator symbol, + as it might be repurposed as special syntax by a future language extension. + The second parameter is how such operator occurred, if in a prefix, suffix + or tight infix position. + + Triggered by: 'GHC.Parser.Errors.Types.PsWarnOperatorWhitespace'. + + Example: + h a b = a+b -- not OK, no spaces around '+'. + + Test Case(s): parser/should_compile/T18834b.hs + -} + | SuggestUseWhitespaceAround !String !OperatorWhitespaceOccurrence + {-| Suggests wrapping an expression in parentheses + + Examples: None + Test Case(s): None + -} + | SuggestParentheses + {-| Suggests to increase the -fmax-pmcheck-models limit for the pattern match checker. + + Triggered by: 'GHC.HsToCore.Errors.Types.DsMaxPmCheckModelsReached' + + Test case(s): pmcheck/should_compile/TooManyDeltas + pmcheck/should_compile/TooManyDeltas + pmcheck/should_compile/T11822 + -} + | SuggestIncreaseMaxPmCheckModels + {-| Suggests adding a type signature, typically to resolve ambiguity or help GHC inferring types. + + -} + | SuggestAddTypeSignatures AvailableBindings + {-| Suggests to explicitly discard the result of a monadic action by binding the result to + the '_' wilcard. + + Example: + main = do + _ <- getCurrentTime + + -} + | SuggestBindToWildcard !(LHsExpr GhcTc) + + | SuggestAddInlineOrNoInlinePragma !Var !Activation + + | SuggestAddPhaseToCompetingRule !RuleName + {-| Suggests adding an identifier to the export list of a signature. + -} + | SuggestAddToHSigExportList !Name !(Maybe Module) + {-| Suggests increasing the limit for the number of iterations in the simplifier. + -} + | SuggestIncreaseSimplifierIterations + {-| Suggests to explicitly import 'Type' from the 'Data.Kind' module, because + using "*" to mean 'Data.Kind.Type' relies on the StarIsType extension, which + will become deprecated in the future. + + Triggered by: 'GHC.Parser.Errors.Types.PsWarnStarIsType' + Example: None + Test case(s): wcompat-warnings/WCompatWarningsOn.hs + + -} + | SuggestUseTypeFromDataKind (Maybe RdrName) + + {-| Suggests placing the 'qualified' keyword /after/ the module name. + + Triggered by: 'GHC.Parser.Errors.Types.PsWarnImportPreQualified' + Example: None + Test case(s): module/mod184.hs + + -} + | SuggestQualifiedAfterModuleName + + {-| Suggests using TemplateHaskell quotation syntax. + + Triggered by: 'GHC.Parser.Errors.Types.PsErrEmptyDoubleQuotes' only if TemplateHaskell + is enabled. + Example: None + Test case(s): parser/should_fail/T13450TH.hs + + -} + | SuggestThQuotationSyntax + + {-| Suggests alternative roles in case we found an illegal one. + + Triggered by: 'GHC.Parser.Errors.Types.PsErrIllegalRoleName' + Example: None + Test case(s): roles/should_fail/Roles7.hs + + -} + | SuggestRoles [Role] + + {-| Suggests qualifying the '*' operator in modules where StarIsType is enabled. + + Triggered by: 'GHC.Parser.Errors.Types.PsWarnStarBinder' + Test case(s): warnings/should_compile/StarBinder.hs + -} + | SuggestQualifyStarOperator + + {-| Suggests that for a type signature 'M.x :: ...' the qualifier should be omitted + in order to be accepted by GHC. + + Triggered by: 'GHC.Parser.Errors.Types.PsErrInvalidTypeSignature' + Test case(s): module/mod98 + -} + | SuggestTypeSignatureRemoveQualifier + + {-| Suggests to move an orphan instance (for a typeclass or a type or data + family), or to newtype-wrap it. + + Triggered by: 'GHC.Tc.Errors.Types.TcRnOrphanInstance' + Test cases(s): warnings/should_compile/T9178 + typecheck/should_compile/T4912 + indexed-types/should_compile/T22717_fam_orph + -} + | SuggestFixOrphanInst + { isFamilyInstance :: Maybe FamFlavor } + -- ^ Whether this is a family instance (of the given 'FamFlavor'), + -- or a class instance ('Nothing'). + + {-| Suggests to use a standalone deriving declaration when GHC + can't derive a typeclass instance in a trivial way. + + Triggered by: 'GHC.Tc.Errors.Types.DerivBadErrConstructor' + Test cases(s): typecheck/should_fail/tcfail086 + -} + | SuggestAddStandaloneDerivation + + {-| Suggests to add a standalone kind signature when GHC + can't perform kind inference. + + Triggered by: 'GHC.Tc.Errors.Types.TcRnInvisBndrWithoutSig' + Test case(s): typecheck/should_fail/T22560_fail_d + -} + | SuggestAddStandaloneKindSignature Name + + {-| Suggests the user to fill in the wildcard constraint to + disambiguate which constraint that is. + + Example: + deriving instance _ => Eq (Foo f a) + + Triggered by: 'GHC.Tc.Errors.Types.DerivBadErrConstructor' + Test cases(s): partial-sigs/should_fail/T13324_fail2 + -} + | SuggestFillInWildcardConstraint + + {-| Suggests to use the appropriate Template Haskell tick: + a single tick for a term-level 'NameSpace', or a double tick + for a type-level 'NameSpace'. + + Triggered by: 'GHC.Tc.Errors.Types.TcRnIncorrectNameSpace'. + -} + | SuggestAppropriateTHTick NameSpace + + {-| Suggests enabling -ddump-splices to help debug an issue + when a 'Name' is not in scope or is used in multiple + different namespaces (e.g. both as a data constructor + and a type constructor). + + Concomitant with 'NoExactName' or 'SameName' errors, + see e.g. "GHC.Rename.Env.lookupExactOcc_either". + Test cases: T5971, T7241, T13937. + -} + | SuggestDumpSlices + + {-| Suggests adding a tick to refer to something which has been + promoted to the type level, e.g. a data constructor. + + Test cases: T9778, T19984. + -} + | SuggestAddTick UntickedPromotedThing + + {-| Something is split off from its corresponding declaration. + For example, a datatype is given a role declaration + in a different module. + + Test cases: T495, T8485, T2713, T5533. + -} + | SuggestMoveToDeclarationSite + SigLike -- ^ fixity declaration, role annotation, type signature, ... + RdrName -- ^ the 'RdrName' for the declaration site + + {-| Suggest a similar name that the user might have meant, + e.g. suggest 'traverse' when the user has written @travrese@. + + Test case: mod73. + -} + | SuggestSimilarNames RdrName (NE.NonEmpty SimilarName) + + {-| Remind the user that the field selector has been suppressed + because of -XNoFieldSelectors. + + Test cases: NFSSuppressed, records-nofieldselectors. + -} + | RemindFieldSelectorSuppressed + { suppressed_selector :: RdrName + , suppressed_parents :: [Name] } + + {-| Suggest importing from a module, removing a @hiding@ clause, + or explain to the user that we couldn't find a module + with the given 'ModuleName'. + + Test cases: mod28, mod36, mod87, mod114, ... + -} + | ImportSuggestion OccName ImportSuggestion + + {-| Found a pragma in the body of a module, suggest placing it in the header. + -} + | SuggestPlacePragmaInHeader + {-| Suggest using pattern matching syntax for a non-bidirectional pattern synonym + + Test cases: patsyn/should_fail/record-exquant + typecheck/should_fail/T3176 + -} + | SuggestPatternMatchingSyntax + {-| Suggest tips for making a definition visible for the purpose of writing + a SPECIALISE pragma for it in a different module. + + Test cases: none + -} + | SuggestSpecialiseVisibilityHints Name + + {-| Suggest renaming implicitly quantified type variable in case it + captures a term's name. + -} + | SuggestRenameTypeVariable + + | SuggestExplicitBidiPatSyn Name (LPat GhcRn) [LIdP GhcRn] + + {-| Suggest enabling one of the SafeHaskell modes Safe, Unsafe or + Trustworthy. + -} + | SuggestSafeHaskell + + {-| Suggest removing a record wildcard from a pattern when it doesn't + bind anything useful. + -} + | SuggestRemoveRecordWildcard + {-| Suggest moving a method implementation to a different instance to its + superclass that defines the canonical version of the method. + -} + | SuggestMoveNonCanonicalDefinition + Name -- ^ move the implementation from this method + Name -- ^ ... to this method + String -- ^ Documentation URL + + {-| Suggest to increase the solver maximum reduction depth -} + | SuggestIncreaseReductionDepth + + {-| Suggest removing a method implementation when a superclass defines the + canonical version of that method. + -} + | SuggestRemoveNonCanonicalDefinition + Name -- ^ method with non-canonical implementation + Name -- ^ possible other method to use as the RHS instead + String -- ^ Documentation URL + {-| Suggest eta-reducing a type synonym used in the implementation + of abstract data. -} + | SuggestEtaReduceAbsDataTySyn TyCon + {-| Remind the user that there is no field of a type and name in the record, + constructors are in the usual order $x$, $r$, $a$ -} + | RemindRecordMissingField FastString Type Type + {-| Suggest binding the type variable on the LHS of the type declaration + -} + | SuggestBindTyVarOnLhs RdrName + + {-| Suggest using an anonymous wildcard instead of a named wildcard -} + | SuggestAnonymousWildcard + + {-| Suggest explicitly quantifying a type variable instead of relying on implicit quantification -} + | SuggestExplicitQuantification RdrName + + {-| Suggest binding explicitly; e.g data T @k (a :: F k) = .... -} + | SuggestBindTyVarExplicitly Name + + {-| Suggest a default declaration; e.g @default Cls (Ty1, Ty2)@ -} + | SuggestDefaultDeclaration Class [Type] + + {-| Suggest using explicit deriving strategies for a deriving clause. + + Triggered by: 'GHC.Tc.Errors.Types.TcRnNoDerivingClauseStrategySpecified'. + + See comment of 'TcRnNoDerivingClauseStrategySpecified' for context. + -} + | SuggestExplicitDerivingClauseStrategies + (Map AssumedDerivingStrategy [LHsSigType GhcRn]) + -- ^ Those deriving clauses that we assumed a particular strategy for. + + {-| Suggest using an explicit deriving strategy for a standalone deriving instance. + + Triggered by: 'GHC.Tc.Errors.Types.TcRnNoStandaloneDerivingStrategySpecified'. + + See comment of 'TcRnNoStandaloneDerivingStrategySpecified' for context. + -} + | SuggestExplicitStandaloneDerivingStrategy + AssumedDerivingStrategy -- ^ The deriving strategy we assumed + (LHsSigWcType GhcRn) -- ^ The instance signature (e.g 'Show a => Show (T a)') + + {-| Suggest add parens to pattern `e -> p :: t` -} + | SuggestParenthesizePatternRHS + + {-| Suggest splitting up a SPECIALISE pragmas with multiple type ascriptions + into several individual SPECIALISE pragmas. + -} + | SuggestSplittingIntoSeveralSpecialisePragmas + + {-| Suggest using the `data` keyword -} + | SuggestDataKeyword + +-- | The deriving strategy that was assumed when not explicitly listed in the +-- source. This is used solely by the missing-deriving-strategies warning. +-- There's no `Via` case because we never assume that. +data AssumedDerivingStrategy + = AssumedStockStrategy + | AssumedAnyclassStrategy + | AssumedNewtypeStrategy + deriving (Eq, Ord) + +instance Outputable AssumedDerivingStrategy where + ppr AssumedStockStrategy = text "stock" + ppr AssumedAnyclassStrategy = text "anyclass" + ppr AssumedNewtypeStrategy = text "newtype" + +-- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated +-- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way +-- to instantiate a particular signature, where the first argument is +-- the signature name and the second is the module where the signature +-- was defined. +-- Example: +-- +-- src/MyStr.hsig:2:11: error: +-- Unexpected signature: ‘MyStr’ +-- (Try passing -instantiated-with="MyStr=" +-- replacing as necessary.) +data InstantiationSuggestion = InstantiationSuggestion !ModuleName !Module + +data ImportItemSuggestion = + ImportItemRemoveType + | ImportItemRemoveData + | ImportItemRemovePattern + | ImportItemRemoveSubordinateType (NE.NonEmpty OccName) + | ImportItemRemoveSubordinateData (NE.NonEmpty OccName) + | ImportItemAddType + -- Why no 'ImportItemAddData'? Because the suggestion to add 'data' is + -- represented by the 'ImportDataCon' constructor of 'ImportSuggestion'. + +-- | Suggest how to fix an import. +data ImportSuggestion + -- | Some module exports what we want, but we aren't explicitly importing it. + = CouldImportFrom (NE.NonEmpty (Module, ImportedModsVal)) + -- | Some module exports what we want, but we are explicitly hiding it. + | CouldUnhideFrom (NE.NonEmpty (Module, ImportedModsVal)) + -- | The module exports what we want, but the import item requires modification. + | CouldChangeImportItem ModuleName ImportItemSuggestion + -- | Suggest importing a data constructor to bring it into scope + | ImportDataCon + -- | Where to suggest importing the 'DataCon' from. + { ies_suggest_import_from :: Maybe ModuleName + -- | Whether to suggest the use of the 'pattern' keyword. + , ies_suggest_pattern_keyword :: Bool + -- | Whether to suggest the use of the 'data' keyword. + , ies_suggest_data_keyword :: Bool + -- | The 'OccName' of the parent of the data constructor. + , ies_parent :: OccName } + +-- | Explain how something is in scope. +data HowInScope + -- | It was locally bound at this particular source location. + = LocallyBoundAt SrcSpan + -- | It was imported by this particular import declaration. + | ImportedBy ImpDeclSpec + +data SimilarName + = SimilarName Name + | SimilarRdrName RdrName (Maybe HowInScope) + +-- | Some kind of signature, such as a fixity signature, standalone +-- kind signature, COMPLETE pragma, role annotation, etc. +data SigLike + = SigLikeSig (Sig GhcPs) + | SigLikeStandaloneKindSig + | SigLikeFixitySig + | SigLikeDeprecation + | SigLikeRoleAnnotation + +-- | Something is promoted to the type-level without a promotion tick. +data UntickedPromotedThing + = UntickedConstructor LexicalFixity Name + | UntickedExplicitList + +pprUntickedConstructor :: LexicalFixity -> Name -> SDoc +pprUntickedConstructor fixity nm = + case fixity of + Prefix -> pprPrefixVar is_op ppr_nm -- e.g. (:) and '(:) + Infix -> pprInfixVar is_op ppr_nm -- e.g. `Con` and '`Con` + where + ppr_nm = ppr nm + is_op = isSymOcc (nameOccName nm) + +-- | Whether a constructor name is printed out as a bare symbol, e.g. @:@. +-- +-- True for symbolic names in infix position. +-- +-- Used for pretty-printing. +isBareSymbol :: LexicalFixity -> Name -> Bool +isBareSymbol fixity nm + | isSymOcc (nameOccName nm) + , Infix <- fixity + = True + | otherwise + = False + +-------------------------------------------------------------------------------- + +-- | Whether '*' is a synonym for 'Data.Kind.Type'. +data StarIsType + = StarIsNotType + | StarIsType + +-- | Display info about the treatment of '*' under NoStarIsType. +-- +-- With StarIsType, three properties of '*' hold: +-- +-- (a) it is not an infix operator +-- (b) it is always in scope +-- (c) it is a synonym for Data.Kind.Type +-- +-- However, the user might not know that they are working on a module with +-- NoStarIsType and write code that still assumes (a), (b), and (c), which +-- actually do not hold in that module. +-- +-- Violation of (a) shows up in the parser. For instance, in the following +-- examples, we have '*' not applied to enough arguments: +-- +-- data A :: * +-- data F :: * -> * +-- +-- Violation of (b) or (c) show up in the renamer and the typechecker +-- respectively. For instance: +-- +-- type K = Either * Bool +-- +-- This will parse differently depending on whether StarIsType is enabled, +-- but it will parse nonetheless. With NoStarIsType it is parsed as a type +-- operator, thus we have ((*) Either Bool). Now there are two cases to +-- consider: +-- +-- 1. There is no definition of (*) in scope. In this case the renamer will +-- fail to look it up. This is a violation of assumption (b). +-- +-- 2. There is a definition of the (*) type operator in scope (for example +-- coming from GHC.TypeNats). In this case the user will get a kind +-- mismatch error. This is a violation of assumption (c). +-- +-- The user might unknowingly be working on a module with NoStarIsType +-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a +-- hint whenever an assumption about '*' is violated. Unfortunately, it is +-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). +-- +-- 'noStarIsTypeHints' returns appropriate hints to the user depending on the +-- extensions enabled in the module and the name that triggered the error. +-- That is, if we have NoStarIsType and the error is related to '*' or its +-- Unicode variant, we will suggest using 'Data.Kind.Type'; otherwise we won't +-- suggest anything. +noStarIsTypeHints :: StarIsType -> RdrName -> [GhcHint] +noStarIsTypeHints is_star_type rdr_name + -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to + -- take star_is_type as input? Why not refactor? + -- + -- The reason is that `sdocOption sdocStarIsType` would indicate that + -- StarIsType is enabled in the module that tries to load the problematic + -- definition, not in the module that is being loaded. + -- + -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint + -- must be displayed even if we load this definition from a module (or GHCi) + -- with StarIsType enabled! + -- + | isUnqualStar + , StarIsNotType <- is_star_type + = [SuggestUseTypeFromDataKind (Just rdr_name)] + | otherwise + = [] + where + -- Does rdr_name look like the user might have meant the '*' kind by it? + -- We focus on unqualified stars specifically, because qualified stars are + -- treated as type operators even under StarIsType. + isUnqualStar + | Unqual occName <- rdr_name + = let fs = occNameFS occName + in fs == fsLit "*" || fs == fsLit "★" + | otherwise = False diff --git a/GHC/Types/Hint/Ppr.hs b/GHC/Types/Hint/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Hint/Ppr.hs @@ -0,0 +1,451 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wno-orphans #-} {- instance Outputable GhcHint -} + +module GHC.Types.Hint.Ppr ( + perhapsAsPat, pprSigLike + -- also, and more interesting: instance Outputable GhcHint + ) where + +import GHC.Prelude + +import GHC.Parser.Errors.Basic +import GHC.Types.Hint + +import GHC.Core.FamInstEnv (FamFlavor(..)) +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep ( mkVisFunTyMany ) +import GHC.Hs.Expr () -- instance Outputable +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace) +import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine) +import GHC.Unit.Module.Imported (ImportedModsVal(..)) +import GHC.Unit.Types +import GHC.Utils.Outputable + +import GHC.Driver.Flags + +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map + +import qualified GHC.LanguageExtensions as LangExt +import GHC.Hs.Binds (hsSigDoc) + +instance Outputable GhcHint where + ppr = \case + UnknownHint m + -> ppr m + SuggestExtension extHint + -> case extHint of + SuggestSingleExtension extraUserInfo ext -> + ("Perhaps you intended to use" <+> extension_with_implied ext) + $$ extraUserInfo + SuggestAnyExtension extraUserInfo exts -> + (enable "any" <+> unquotedListWith "or" (map implied exts)) + $$ extraUserInfo + SuggestExtensions extraUserInfo exts -> + (enable "all" <+> unquotedListWith "and" (map implied exts)) + $$ extraUserInfo + SuggestExtensionInOrderTo extraUserInfo ext -> + ("Use" <+> extension_with_implied ext) + $$ extraUserInfo + where extension_with_implied ext = "the" <+> quotes (ppr ext) <+> "extension" <+> pprImpliedExtensions ext + implied ext = quotes (ppr ext) <+> pprImpliedExtensions ext + enable any_or_all = "Enable" <+> any_or_all <+> "of the following extensions" <> colon + SuggestCorrectPragmaName suggestions + -> text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) + SuggestMissingDo + -> text "Possibly caused by a missing 'do'?" + SuggestLetInDo + -> text "Perhaps you need a 'let' in a 'do' block?" + $$ text "e.g. 'let x = 5' instead of 'x = 5'" + SuggestAddSignatureCabalFile pi_mod_name + -> text "Try adding" <+> quotes (ppr pi_mod_name) + <+> text "to the" + <+> quotes (text "signatures") + <+> text "field in your Cabal file." + SuggestSignatureInstantiations pi_mod_name suggestions + -> let suggested_instantiated_with = + hcat (punctuate comma $ + [ ppr k <> text "=" <> ppr v + | InstantiationSuggestion k v <- suggestions + ]) + in text "Try passing -instantiated-with=\"" <> + suggested_instantiated_with <> text "\"" $$ + text "replacing <" <> ppr pi_mod_name <> text "> as necessary." + SuggestUseSpaces + -> text "Please use spaces instead." + SuggestUseWhitespaceAfter sym + -> text "Add whitespace after the" + <+> quotes (pprOperatorWhitespaceSymbol sym) <> char '.' + SuggestUseWhitespaceAround sym _occurrence + -> text "Add whitespace around" <+> quotes (text sym) <> char '.' + SuggestParentheses + -> text "Use parentheses." + SuggestIncreaseMaxPmCheckModels + -> text "Increase the limit or resolve the warnings to suppress this message." + SuggestAddTypeSignatures bindings + -> case bindings of + -- This might happen when we have bindings which are /too complicated/, + -- see for example 'DsCannotMixPolyAndUnliftedBindings' in 'GHC.HsToCore.Errors.Types'. + -- In this case, we emit a generic message. + UnnamedBinding -> text "Add a type signature." + NamedBindings (x NE.:| xs) -> + let nameList = case xs of + [] -> quotes . ppr $ x + _ -> pprWithCommas (quotes . ppr) xs <+> text "and" <+> quotes (ppr x) + in hsep [ text "Consider giving" + , nameList + , text "a type signature"] + SuggestBindToWildcard rhs + -> hang (text "Suppress this warning by saying") 2 (quotes $ text "_ <-" <+> ppr rhs) + SuggestAddInlineOrNoInlinePragma lhs_id rule_act + -> vcat [ text "Add an INLINE[n] or NOINLINE[n] pragma for" <+> quotes (ppr lhs_id) + , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) + ] + SuggestAddPhaseToCompetingRule bad_rule + -> vcat [ text "Add phase [n] or [~n] to the competing rule" + , whenPprDebug (ppr bad_rule) ] + SuggestIncreaseSimplifierIterations + -> text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" + SuggestUseTypeFromDataKind mb_rdr_name + -> text "Use" <+> quotes (text "Type") + <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." + $$ + maybe empty + (\rdr_name -> + text "NB: with NoStarIsType, " <> quotes (ppr rdr_name) + <+> text "is treated as a regular type operator.") + mb_rdr_name + + SuggestQualifiedAfterModuleName + -> text "Place" <+> quotes (text "qualified") + <+> text "after the module name." + SuggestThQuotationSyntax + -> vcat [ text "Perhaps you intended to use quotation syntax of TemplateHaskell," + , text "but the type variable or constructor is missing" + ] + SuggestRoles nearby + -> case nearby of + [] -> empty + [r] -> text "Perhaps you meant" <+> quotes (ppr r) + -- will this last case ever happen?? + _ -> hang (text "Perhaps you meant one of these:") + 2 (pprWithCommas (quotes . ppr) nearby) + SuggestQualifyStarOperator + -> text "To use (or export) this operator in" + <+> text "modules with StarIsType," + $$ text " including the definition module, you must qualify it." + SuggestTypeSignatureRemoveQualifier + -> text "Perhaps you meant to omit the qualifier" + SuggestAddToHSigExportList _name mb_mod + -> let header = text "Try adding it to the export list of" + in case mb_mod of + Nothing -> header <+> text "the hsig file." + Just mod -> header <+> ppr (moduleName mod) <> text "'s hsig file." + SuggestFixOrphanInst { isFamilyInstance = mbFamFlavor } + -> vcat [ text "Move the instance declaration to the module of the" <+> what <+> text "or of the type, or" + , text "wrap the type with a newtype and declare the instance on the new type." + ] + where + what = case mbFamFlavor of + Nothing -> text "class" + Just SynFamilyInst -> text "type family" + Just (DataFamilyInst {}) -> text "data family" + SuggestAddStandaloneDerivation + -> text "Use a standalone deriving declaration instead" + SuggestAddStandaloneKindSignature name + -> text "Add a standalone kind signature for" <+> quotes (ppr name) + SuggestFillInWildcardConstraint + -> text "Fill in the wildcard constraint yourself" + SuggestAppropriateTHTick ns + -> text "Perhaps use a" <+> how_many <+> text "tick" + where + how_many + | isValNameSpace ns = text "single" + | otherwise = text "double" + SuggestDumpSlices + -> vcat [ text "If you bound a unique Template Haskell name (NameU)" + , text "perhaps via newName," + , text "then -ddump-splices might be useful." ] + SuggestAddTick (UntickedConstructor fixity name) + -> hsep [ text "Use" + , char '\'' <> con + , text "instead of" + , con <> mb_dot ] + where + con = pprUntickedConstructor fixity name + mb_dot + | isBareSymbol fixity name + -- A final dot can be confusing for a symbol without parens, e.g. + -- + -- * Use ': instead of :. + = empty + | otherwise + = dot + + SuggestAddTick UntickedExplicitList + -> text "Add a promotion tick, e.g." <+> text "'[x,y,z]" <> dot + SuggestMoveToDeclarationSite sig rdr_name + -> text "Move the" <+> pprSigLike sig <+> text "to the declaration site of" + <+> quotes (ppr rdr_name) <> dot + SuggestSimilarNames tried_rdr_name similar_names + -> case similar_names of + n NE.:| [] -> text "Perhaps use" <+> pp_item n + _ -> sep [ text "Perhaps use one of these:" + , nest 2 (pprWithCommas pp_item $ NE.toList similar_names) ] + where + tried_ns = occNameSpace $ rdrNameOcc tried_rdr_name + pp_item = pprSimilarName tried_ns + RemindFieldSelectorSuppressed rdr_name parents + -> text "Notice that" <+> quotes (ppr rdr_name) + <+> text "is a field selector" <+> whose + $$ text "that has been suppressed by NoFieldSelectors." + where + -- parents may be empty if this is a pattern synonym field without a selector + whose | null parents = empty + | otherwise = text "belonging to the type" <> plural parents + <+> pprQuotedList parents + ImportSuggestion occ_name import_suggestion + -> pprImportSuggestion occ_name import_suggestion + SuggestPlacePragmaInHeader + -> text "Perhaps you meant to place it in the module header?" + $$ text "The module header is the section at the top of the file, before the" <+> quotes (text "module") <+> text "keyword" + SuggestPatternMatchingSyntax + -> text "Use pattern-matching syntax instead" + SuggestSpecialiseVisibilityHints name + -> text "Make sure" <+> ppr mod <+> text "is compiled with -O and that" + <+> quotes (ppr name) <+> text "has an INLINABLE pragma" + where + mod = nameModule name + SuggestRenameTypeVariable + -> text "Consider renaming the type variable." + SuggestExplicitBidiPatSyn name pat args + -> hang (text "Instead use an explicitly bidirectional" + <+> text "pattern synonym, e.g.") + 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow + <+> ppr pat <+> text "where") + 2 (pp_name <+> pp_args <+> equals <+> text "...")) + where + pp_name = ppr name + pp_args = hsep (map ppr args) + SuggestSafeHaskell + -> text "Enable Safe Haskell through either Safe, Trustworthy or Unsafe." + SuggestRemoveRecordWildcard + -> text "Omit the" <+> quotes (text "..") + SuggestIncreaseReductionDepth -> + 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)" ] + SuggestMoveNonCanonicalDefinition lhs rhs refURL -> + text "Move definition from" <+> + quotes (pprPrefixUnqual rhs) <+> + text "to" <+> quotes (pprPrefixUnqual lhs) $$ + text "See also:" <+> text refURL + SuggestRemoveNonCanonicalDefinition lhs rhs refURL -> + text "Either remove definition for" <+> + quotes (pprPrefixUnqual lhs) <+> text "(recommended)" <+> + text "or define as" <+> + quotes (pprPrefixUnqual lhs <+> text "=" <+> pprPrefixUnqual rhs) $$ + text "See also:" <+> text refURL + SuggestEtaReduceAbsDataTySyn tc + -> text "If possible, eta-reduce the type synonym" <+> ppr_tc <+> text "so that it is nullary." + where ppr_tc = quotes (ppr $ tyConName tc) + RemindRecordMissingField x r a -> + text "NB: There is no field selector" <+> ppr_sel + <+> text "in scope for record type" <+> ppr_r + where ppr_sel = quotes (ftext x <+> dcolon <+> ppr_arr_r_a) + ppr_arr_r_a = ppr $ mkVisFunTyMany r a + ppr_r = quotes $ ppr r + SuggestBindTyVarOnLhs tv + -> text "Bind" <+> quotes (ppr tv) <+> text "on the LHS of the type declaration" + SuggestAnonymousWildcard + -> text "Use an anonymous wildcard" <+> quotes (text "_") + SuggestExplicitQuantification tv + -> hsep [ text "Use an explicit", quotes (text "forall") + , text "to quantify over", quotes (ppr tv) ] + SuggestBindTyVarExplicitly tv + -> text "bind" <+> quotes (ppr tv) + <+> text "explicitly with" <+> quotes (char '@' <> ppr tv) + SuggestDefaultDeclaration cls tys + -> hang (text "Consider declaring") + 2 (text "default" <+> ppr cls <+> parens (pprWithCommas ppr tys)) + SuggestExplicitDerivingClauseStrategies assumed_derivings -> + hang + (text "Use explicit deriving strategies:") + 2 + (vcat $ map pp_derivings (Map.toList assumed_derivings)) + where + pp_derivings (strat, preds) = + hsep [text "deriving", ppr strat, parens (pprWithCommas ppr preds)] + SuggestExplicitStandaloneDerivingStrategy strat deriv_sig -> + hang + (text "Use an explicit deriving strategy:") + 2 + (hsep [text "deriving", ppr strat, text "instance", ppr deriv_sig]) + SuggestParenthesizePatternRHS + -> text "Parenthesize the RHS of the view pattern" + SuggestSplittingIntoSeveralSpecialisePragmas + -> text "Split the SPECIALISE pragma into multiple pragmas, one for each type signature" + SuggestDataKeyword + -> text "Use the" <+> quotes (text "data") <+> "keyword instead." + +perhapsAsPat :: SDoc +perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" + +-- | Pretty-print an 'ImportSuggestion'. +pprImportSuggestion :: OccName -> ImportSuggestion -> SDoc +pprImportSuggestion occ_name (CouldImportFrom mods) + | (mod, imv) NE.:| [] <- mods + = fsep + [ text "Add" + , quotes (ppr occ_name) + , text "to the import list" + , text "in the import of" + , quotes (ppr mod) + , parens (text "at" <+> ppr (imv_span imv)) <> dot + ] + | otherwise + = fsep + [ text "Add" + , quotes (ppr occ_name) + , text "to one of these import lists:" + ] + $$ + nest 2 (vcat + [ quotes (ppr mod) <+> parens (text "at" <+> ppr (imv_span imv)) + | (mod,imv) <- NE.toList mods + ]) +pprImportSuggestion occ_name (CouldUnhideFrom mods) + | (mod, imv) NE.:| [] <- mods + = fsep + [ text "Remove" + , quotes (ppr occ_name) + , text "from the explicit hiding list" + , text "in the import of" + , quotes (ppr mod) + , parens (text "at" <+> ppr (imv_span imv)) <> dot + ] + | otherwise + = fsep + [ text "Remove" + , quotes (ppr occ_name) + , text "from the hiding clauses" + , text "in one of these imports:" + ] + $$ + nest 2 (vcat + [ quotes (ppr mod) <+> parens (text "at" <+> ppr (imv_span imv)) + | (mod,imv) <- NE.toList mods + ]) +pprImportSuggestion occ_name (CouldChangeImportItem mod kw) + = case kw of + ImportItemRemoveType -> remove "type" + ImportItemRemoveData -> remove "data" + ImportItemRemovePattern -> remove "pattern" + ImportItemRemoveSubordinateType nontype1 -> remove_subordinate "type" (NE.toList nontype1) + ImportItemRemoveSubordinateData nondata1 -> remove_subordinate "data" (NE.toList nondata1) + ImportItemAddType -> add "type" + where + parens_sp d = parens (space <> d <> space) + remove kw = + vcat [ text "Remove the" <+> quotes (text kw) + <+> text "keyword from the import statement:" + , nest 2 $ text "import" <+> ppr mod <+> import_list ] + where + import_list = parens_sp (pprPrefixOcc occ_name) + add kw = + vcat [ text "Add the" <+> quotes (text kw) + <+> text "keyword to the import statement:" + , nest 2 $ text "import" <+> ppr mod <+> import_list ] + where + import_list = parens_sp (text kw <+> pprPrefixOcc occ_name) + remove_subordinate kw sub_occs = + vcat [ text "Remove the" <+> quotes (text kw) + <+> text "keyword" <> plural sub_occs + <+> text "from the subordinate import item" <> plural sub_occs <> colon + , nest 2 $ text "import" <+> ppr mod <+> import_list ] + where + parent_item + | isSymOcc occ_name = text "type" <+> pprPrefixOcc occ_name + | otherwise = pprPrefixOcc occ_name + import_list = parens_sp (parent_item <+> sub_import_list) + sub_import_list = parens_sp (hsep (punctuate comma (map pprPrefixOcc sub_occs))) +pprImportSuggestion dc_occ (ImportDataCon { ies_suggest_import_from = Nothing + , ies_parent = parent_occ} ) + = text "Import the data constructor" <+> quotes (ppr dc_occ) <+> + text "of" <+> quotes (ppr parent_occ) +pprImportSuggestion dc_occ (ImportDataCon { ies_suggest_import_from = Just mod + , ies_suggest_pattern_keyword = suggest_pattern + , ies_suggest_data_keyword = suggest_data + , ies_parent = parent_occ }) + = vcat $ basic_suggestion + ++ (if suggest_pattern then pattern_suggestion else []) + ++ (if suggest_data then data_suggestion else []) + where + basic_suggestion = + [ text "Use" + , nest 2 $ import_stmt (pprPrefixOcc parent_occ <> parens_sp (pprPrefixOcc dc_occ)) + , text "or" + , nest 2 $ import_stmt (pprPrefixOcc parent_occ <> text "(..)") + ] + pattern_suggestion = + [ text "or" + , nest 2 $ import_stmt (text "pattern" <+> pprPrefixOcc dc_occ) + ] + data_suggestion = + [ text "or" + , nest 2 $ import_stmt (text "data" <+> pprPrefixOcc dc_occ) + ] + import_stmt sub = text "import" <+> ppr mod <+> parens_sp sub + parens_sp d = parens (space <> d <> space) + +-- | Pretty-print a 'SimilarName'. +pprSimilarName :: NameSpace -> SimilarName -> SDoc +pprSimilarName _ (SimilarName name) + = quotes (ppr name) <+> parens (pprDefinedAt name) +pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope) + = pp_ns rdr_name <+> quotes (ppr rdr_name) <+> loc + where + loc = case how_in_scope of + Nothing -> empty + Just scope -> case scope of + LocallyBoundAt loc -> + case loc of + UnhelpfulSpan l -> parens (ppr l) + RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) + ImportedBy is -> + parens (text "imported from" <+> ppr (moduleName $ is_mod is)) + pp_ns :: RdrName -> SDoc + pp_ns rdr | ns /= tried_ns = pprNameSpace ns + | otherwise = empty + where ns = rdrNameSpace rdr + +pprImpliedExtensions :: LangExt.Extension -> SDoc +pprImpliedExtensions extension = case implied of + [] -> empty + xs -> parens $ "implied by" <+> unquotedListWith "and" xs + where implied = map (quotes . ppr) + . filter (\ext -> extensionDeprecation ext == ExtensionNotDeprecated) + $ [impl | (impl, On orig) <- impliedXFlags, orig == extension] + +pprPrefixUnqual :: Name -> SDoc +pprPrefixUnqual name = + pprPrefixOcc (getOccName name) + +pprSigLike :: SigLike -> SDoc +pprSigLike = \case + SigLikeSig sig -> + hsSigDoc sig + SigLikeStandaloneKindSig -> + text "standalone kind signature" + SigLikeDeprecation -> + text "deprecation" + SigLikeFixitySig -> + text "fixity signature" + SigLikeRoleAnnotation -> + text "role annotation" diff --git a/GHC/Types/HpcInfo.hs b/GHC/Types/HpcInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/HpcInfo.hs @@ -0,0 +1,21 @@ +-- | Haskell Program Coverage (HPC) support +module GHC.Types.HpcInfo + ( HpcInfo (..) + , emptyHpcInfo + ) +where + +import GHC.Prelude + +-- | Information about a modules use of Haskell Program Coverage +data HpcInfo + = HpcInfo + { hpcInfoTickCount :: Int + , hpcInfoHash :: Int + } + | NoHpcInfo + + +emptyHpcInfo :: HpcInfo +emptyHpcInfo = NoHpcInfo + diff --git a/GHC/Types/IPE.hs b/GHC/Types/IPE.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/IPE.hs @@ -0,0 +1,52 @@ +module GHC.Types.IPE ( + DCMap, + ClosureMap, + InfoTableProvMap(..), + emptyInfoTableProvMap, + IpeSourceLocation +) where + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Data.FastString +import GHC.Types.SrcLoc +import GHC.Core.DataCon + +import GHC.Types.Unique.DFM +import GHC.Core.Type +import Data.List.NonEmpty +import GHC.Cmm.CLabel (CLabel) +import qualified Data.Map.Strict as Map + +-- | Position and information about an info table. +-- For return frames these are the contents of a 'CoreSyn.SourceNote'. +type IpeSourceLocation = (RealSrcSpan, LexicalFastString) + +-- | A map from a 'Name' to the best approximate source position that +-- name arose from. +type ClosureMap = UniqDFM Name -- The binding + (Name, (Type, Maybe IpeSourceLocation)) + -- The best approximate source position. + -- (rendered type, source position, source note + -- label) + +-- | A map storing all the different uses of a specific data constructor and the +-- approximate source position that usage arose from. +-- The 'Int' is an incrementing identifier which distinguishes each usage +-- of a constructor in a module. It is paired with the source position +-- the constructor was used at, if possible and a string which names +-- the source location. This is the same information as is the payload +-- for the 'GHC.Core.SourceNote' constructor. +type DCMap = UniqDFM DataCon (DataCon, NonEmpty (Int, Maybe IpeSourceLocation)) + +type InfoTableToSourceLocationMap = Map.Map CLabel (Maybe IpeSourceLocation) + +data InfoTableProvMap = InfoTableProvMap + { provDC :: DCMap + , provClosure :: ClosureMap + , provInfoTables :: InfoTableToSourceLocationMap + } + +emptyInfoTableProvMap :: InfoTableProvMap +emptyInfoTableProvMap = InfoTableProvMap emptyUDFM emptyUDFM Map.empty diff --git a/GHC/Types/Id.hs b/GHC/Types/Id.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Id.hs @@ -0,0 +1,1116 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Id]{@Ids@: Value and constructor identifiers} +-} + + + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types" +-- +-- * 'GHC.Types.Name.Reader.RdrName': see "GHC.Types.Name.Reader#name_types" +-- +-- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types" +-- +-- * 'GHC.Types.Id.Id' represents names that not only have a 'GHC.Types.Name.Name' but also a +-- 'GHC.Core.TyCo.Rep.Type' and some additional details (a 'GHC.Types.Id.Info.IdInfo' and +-- one of LocalIdDetails or GlobalIdDetails) that are added, +-- modified and inspected by various compiler passes. These 'GHC.Types.Var.Var' names +-- may either be global or local, see "GHC.Types.Var#globalvslocal" +-- +-- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types" + +module GHC.Types.Id ( + -- * The main types + Var, Id, isId, + + -- * In and Out variants + InVar, InId, + OutVar, OutId, + + -- ** Simple construction + mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, + mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, + mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId, + mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, + mkUserLocal, mkUserLocalOrCoVar, + mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, + mkScaledTemplateLocal, + mkWorkerId, + + -- ** Taking an Id apart + idName, idType, idMult, idScaledType, idUnique, idInfo, idDetails, + recordSelectorTyCon, + recordSelectorTyCon_maybe, + + -- ** Modifying an Id + setIdName, setIdUnique, GHC.Types.Id.setIdType, setIdMult, + updateIdTypeButNotMult, updateIdTypeAndMult, updateIdTypeAndMultM, + setIdExported, setIdNotExported, + globaliseId, localiseId, + setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, + zapLamIdInfo, floatifyIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, + zapIdUsedOnceInfo, zapIdTailCallInfo, + zapFragileIdInfo, zapIdDmdSig, zapStableUnfolding, + transferPolyIdInfo, scaleIdBy, scaleVarBy, + + -- ** Predicates on Ids + isImplicitId, isDeadBinder, + isStrictId, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, isNaughtyRecordSelector, + isPatSynRecordSelector, + isDataConRecordSelector, + isClassOpId, + isClassOpId_maybe, isDFunId, + isPrimOpId, isPrimOpId_maybe, + isFCallId, isFCallId_maybe, + isDataConWorkId, isDataConWorkId_maybe, + isDataConWrapId, isDataConWrapId_maybe, dataConWrapUnfolding_maybe, + isDataConId, isDataConId_maybe, + idDataCon, + isConLikeId, isWorkerLikeId, isDeadEndId, idIsFrom, + hasNoBinding, + + -- ** Join variables + JoinId, JoinPointHood, + isJoinId, idJoinPointHood, idJoinArity, + asJoinId, asJoinId_maybe, zapJoinId, + + -- ** Inline pragma stuff + idInlinePragma, setInlinePragma, modifyInlinePragma, + idInlineActivation, setInlineActivation, idRuleMatchInfo, + + -- ** One-shot lambdas + setOneShotLambda, clearOneShotLambda, + updOneShotInfo, setIdOneShotInfo, + + -- ** Reading 'IdInfo' fields + idArity, + idCallArity, idFunRepArity, + idSpecialisation, idCoreRules, idHasRules, + idCafInfo, idLFInfo_maybe, + idOneShotInfo, + idOccInfo, + + IdUnfoldingFun, idUnfolding, realIdUnfolding, + alwaysActiveUnfoldingFun, whenActiveUnfoldingFun, noUnfoldingFun, + + -- ** Writing 'IdInfo' fields + setIdUnfolding, zapIdUnfolding, setCaseBndrEvald, + setIdArity, + setIdCallArity, + + setIdSpecialisation, + setIdCafInfo, + setIdOccInfo, zapIdOccInfo, + setIdLFInfo, + + setIdDemandInfo, + setIdDmdSig, + setIdCprSig, + setIdCbvMarks, + idCbvMarks_maybe, + idCbvMarkArity, + asWorkerLikeId, asNonWorkerLikeId, + + idDemandInfo, + idDmdSig, + idCprSig, + + idTagSig_maybe, + setIdTagSig + ) where + +import GHC.Prelude + +import GHC.Types.Id.Info +import GHC.Types.Basic + +-- Imported and re-exported +import GHC.Types.Var( Id, CoVar, JoinId, + InId, InVar, + OutId, OutVar, + idInfo, idDetails, setIdDetails, globaliseId, idMult, + isId, isLocalId, isGlobalId, isExportedId, + setIdMult, updateIdTypeAndMult, updateIdTypeButNotMult, updateIdTypeAndMultM) +import qualified GHC.Types.Var as Var + +import GHC.Core ( CoreExpr, CoreRule, Unfolding(..), IdUnfoldingFun + , isStableUnfolding, isCompulsoryUnfolding, isEvaldUnfolding + , hasSomeUnfolding, noUnfolding, evaldUnfolding ) +import GHC.Core.Type +import GHC.Core.Predicate( isCoVarType ) +import GHC.Core.DataCon +import GHC.Core.Class +import GHC.Core.Multiplicity + +import GHC.Types.RepType +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Name +import GHC.Types.ForeignCall +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.Supply + +import GHC.Stg.EnforceEpt.TagSig + +import GHC.Unit.Module +import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) +import GHC.Builtin.Uniques (mkBuiltinUnique) + +import GHC.Data.Maybe +import GHC.Data.FastString + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setIdUnfolding`, + `setIdArity`, + `setIdCallArity`, + `setIdOccInfo`, + `setIdOneShotInfo`, + + `setIdSpecialisation`, + `setInlinePragma`, + `setInlineActivation`, + `idCafInfo`, + + `setIdDemandInfo`, + `setIdDmdSig`, + `setIdCprSig`, + + `asJoinId`, + `asJoinId_maybe`, + `setIdCbvMarks` + +{- +************************************************************************ +* * +\subsection{Basic Id manipulation} +* * +************************************************************************ +-} + +idName :: Id -> Name +idName = Var.varName + +idUnique :: Id -> Unique +idUnique = Var.varUnique + +idType :: Id -> Kind +idType = Var.varType + +idScaledType :: Id -> Scaled Type +idScaledType id = Scaled (idMult id) (idType id) + +scaleIdBy :: Mult -> Id -> Id +scaleIdBy m id = setIdMult id (m `mkMultMul` idMult id) + +-- | Like 'scaleIdBy', but skips non-Ids. Useful for scaling +-- a mixed list of ids and tyvars. +scaleVarBy :: Mult -> Var -> Var +scaleVarBy m id + | isId id = scaleIdBy m id + | otherwise = id + +setIdName :: Id -> Name -> Id +setIdName = Var.setVarName + +setIdUnique :: Id -> Unique -> Id +setIdUnique = Var.setVarUnique + +-- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and +-- reduce space usage +setIdType :: Id -> Type -> Id +setIdType id ty = seqType ty `seq` Var.setVarType id ty + +setIdExported :: Id -> Id +setIdExported = Var.setIdExported + +setIdNotExported :: Id -> Id +setIdNotExported = Var.setIdNotExported + +localiseId :: Id -> Id +-- Make an Id with the same unique and type as the +-- incoming Id, but with an *Internal* Name and *LocalId* flavour +localiseId id + | assert (isId id) $ isLocalId id && isInternalName name + = id + | otherwise + = Var.mkLocalVar (idDetails id) (localiseName name) (Var.idMult id) (idType id) (idInfo id) + where + name = idName id + +lazySetIdInfo :: Id -> IdInfo -> Id +lazySetIdInfo = Var.lazySetIdInfo + +setIdInfo :: Id -> IdInfo -> Id +setIdInfo id info = info `seq` (lazySetIdInfo id info) + -- Try to avoid space leaks by seq'ing + +modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id +modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) + +-- maybeModifyIdInfo tries to avoid unnecessary thrashing +maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id +maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info +maybeModifyIdInfo Nothing id = id + +-- maybeModifyIdInfo tries to avoid unnecessary thrashing +maybeModifyIdDetails :: Maybe IdDetails -> Id -> Id +maybeModifyIdDetails (Just new_details) id = setIdDetails id new_details +maybeModifyIdDetails Nothing id = id + +{- +************************************************************************ +* * +\subsection{Simple Id construction} +* * +************************************************************************ + +Absolutely all Ids are made by mkId. It is just like Var.mkId, +but in addition it pins free-tyvar-info onto the Id's type, +where it can easily be found. + +Note [Free type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we cached the free type variables of the type of an Id +at the root of the type in a TyNote. The idea was to avoid repeating +the free-type-variable calculation. But it turned out to slow down +the compiler overall. I don't quite know why; perhaps finding free +type variables of an Id isn't all that common whereas applying a +substitution (which changes the free type variables) is more common. +Anyway, we removed it in March 2008. +-} + +-- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var.Var#globalvslocal" +mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId = Var.mkGlobalVar + +-- | Make a global 'Id' without any extra information at all +mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id +mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo + +-- | Make a global 'Id' with no global information but some generic 'IdInfo' +mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id +mkVanillaGlobalWithInfo nm = + assertPpr (not $ isFieldNameSpace $ nameNameSpace nm) + (text "mkVanillaGlobalWithInfo called on record field:" <+> ppr nm) $ + mkGlobalId VanillaId nm + +-- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" +mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id +mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo + +-- | Make a local CoVar +mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar +mkLocalCoVar name ty + = assert (isCoVarType ty) $ + Var.mkLocalVar CoVarId name ManyTy ty vanillaIdInfo + +-- | Like 'mkLocalId', but checks the type to see if it should make a covar +mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id +mkLocalIdOrCoVar name w ty + -- We should assert (eqType w Many) in the isCoVarType case. + -- However, currently this assertion does not hold. + -- In tests with -fdefer-type-errors, such as T14584a, + -- we create a linear 'case' where the scrutinee is a coercion + -- (see castBottomExpr). This problem is covered by #17291. + | isCoVarType ty = mkLocalCoVar name ty + | otherwise = mkLocalId name w ty + + -- proper ids only; no covars! +mkLocalIdWithInfo :: HasDebugCallStack => Name -> Mult -> Type -> IdInfo -> Id +mkLocalIdWithInfo name w ty info = + Var.mkLocalVar VanillaId name w (assert (not (isCoVarType ty)) ty) info + -- Note [Free type variables] + +-- | Create a local 'Id' that is marked as exported. +-- This prevents things attached to it from being removed as dead code. +-- See Note [Exported LocalIds] +mkExportedLocalId :: IdDetails -> Name -> Type -> Id +mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo + -- Note [Free type variables] + +mkExportedVanillaId :: Name -> Type -> Id +mkExportedVanillaId name ty = + assertPpr (not $ isFieldNameSpace $ nameNameSpace name) + (text "mkExportedVanillaId called on record field:" <+> ppr name) $ + Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo + -- Note [Free type variables] + + +-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") +-- that are created by the compiler out of thin air +mkSysLocal :: FastString -> Unique -> Mult -> Type -> Id +mkSysLocal fs uniq w ty = assert (not (isCoVarType ty)) $ + mkLocalId (mkSystemVarName uniq fs) w ty + +-- | Like 'mkSysLocal', but checks to see if we have a covar type +mkSysLocalOrCoVar :: FastString -> Unique -> Mult -> Type -> Id +mkSysLocalOrCoVar fs uniq w ty + = mkLocalIdOrCoVar (mkSystemVarName uniq fs) w ty + +mkSysLocalM :: MonadUnique m => FastString -> Mult -> Type -> m Id +mkSysLocalM fs w ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq w ty)) + +mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Mult -> Type -> m Id +mkSysLocalOrCoVarM fs w ty + = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq w ty)) + +-- | Create a user local 'Id'. These are local 'Id's (see "GHC.Types.Var#globalvslocal") with a name and location that the user might recognize +mkUserLocal :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id +mkUserLocal occ uniq w ty loc = assert (not (isCoVarType ty)) $ + mkLocalId (mkInternalName uniq occ loc) w ty + +-- | Like 'mkUserLocal', but checks if we have a coercion type +mkUserLocalOrCoVar :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id +mkUserLocalOrCoVar occ uniq w ty loc + = mkLocalIdOrCoVar (mkInternalName uniq occ loc) w ty + +{- +Make some local @Ids@ for a template @CoreExpr@. These have bogus +@Uniques@, but that's OK because the templates are supposed to be +instantiated before use. +-} + +-- | Workers get local names. "CoreTidy" will externalise these if necessary +mkWorkerId :: Unique -> Id -> Type -> Id +mkWorkerId uniq unwrkr ty + = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ManyTy ty + +-- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings +mkTemplateLocal :: Int -> Type -> Id +mkTemplateLocal i ty = mkScaledTemplateLocal i (unrestricted ty) + +mkScaledTemplateLocal :: Int -> Scaled Type -> Id +mkScaledTemplateLocal i (Scaled w ty) = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) w ty + -- "OrCoVar" since this is used in a superclass selector, + -- and "~" and "~~" have coercion "superclasses". + +-- | Create a template local for a series of types +mkTemplateLocals :: [Type] -> [Id] +mkTemplateLocals = mkTemplateLocalsNum 1 + +-- | Create a template local for a series of type, but start from a specified template local +mkTemplateLocalsNum :: Int -> [Type] -> [Id] +mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys + +{- Note [Exported LocalIds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use mkExportedLocalId for things like + - Dictionary functions (DFunId) + - Wrapper and matcher Ids for pattern synonyms + - Default methods for classes + - Pattern-synonym matcher and builder Ids + - etc + +They marked as "exported" in the sense that they should be kept alive +even if apparently unused in other bindings, and not dropped as dead +code by the occurrence analyser. (But "exported" here does not mean +"brought into lexical scope by an import declaration". Indeed these +things are always internal Ids that the user never sees.) + +It's very important that they are *LocalIds*, not GlobalIds, for lots +of reasons: + + * We want to treat them as free variables for the purpose of + dependency analysis (e.g. GHC.Core.FVs.exprFreeVars). + + * Look them up in the current substitution when we come across + occurrences of them (in Subst.lookupIdSubst). Lacking this we + can get an out-of-date unfolding, which can in turn make the + simplifier go into an infinite loop (#9857) + + * Ensure that for dfuns that the specialiser does not float dict uses + above their defns, which would prevent good simplifications happening. + + * The strictness analyser treats a occurrence of a GlobalId as + imported and assumes it contains strictness in its IdInfo, which + isn't true if the thing is bound in the same module as the + occurrence. + +In CoreTidy we must make all these LocalIds into GlobalIds, so that in +importing modules (in --make mode) we treat them as properly global. +That is what is happening in, say tidy_insts in GHC.Iface.Tidy. + +************************************************************************ +* * +\subsection{Special Ids} +* * +************************************************************************ +-} + +-- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. +recordSelectorTyCon :: Id -> RecSelParent +recordSelectorTyCon id + = case recordSelectorTyCon_maybe id of + Just parent -> parent + _ -> panic "recordSelectorTyCon" + +recordSelectorTyCon_maybe :: Id -> Maybe RecSelParent +recordSelectorTyCon_maybe id + = case Var.idDetails id of + RecSelId { sel_tycon = parent } -> Just parent + _ -> Nothing + +isRecordSelector :: Id -> Bool +isNaughtyRecordSelector :: Id -> Bool +isPatSynRecordSelector :: Id -> Bool +isDataConRecordSelector :: Id -> Bool +isPrimOpId :: Id -> Bool +isFCallId :: Id -> Bool +isDataConWorkId :: Id -> Bool +isDataConWrapId :: Id -> Bool +isDFunId :: Id -> Bool +isClassOpId :: Id -> Bool + +isClassOpId_maybe :: Id -> Maybe Class +isPrimOpId_maybe :: Id -> Maybe PrimOp +isFCallId_maybe :: Id -> Maybe ForeignCall +isDataConWorkId_maybe :: Id -> Maybe DataCon +isDataConWrapId_maybe :: Id -> Maybe DataCon + +isRecordSelector id = case Var.idDetails id of + RecSelId {} -> True + _ -> False + +isDataConRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelData _} -> True + _ -> False + +isPatSynRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelPatSyn _} -> True + _ -> False + +isNaughtyRecordSelector id = case Var.idDetails id of + RecSelId { sel_naughty = n } -> n + _ -> False + +isClassOpId id = case Var.idDetails id of + ClassOpId {} -> True + _other -> False + +isClassOpId_maybe id = case Var.idDetails id of + ClassOpId cls _ -> Just cls + _other -> Nothing + +isPrimOpId id = case Var.idDetails id of + PrimOpId {} -> True + _ -> False + +isDFunId id = case Var.idDetails id of + DFunId {} -> True + _ -> False + +isPrimOpId_maybe id = case Var.idDetails id of + PrimOpId op _ -> Just op + _ -> Nothing + +isFCallId id = case Var.idDetails id of + FCallId _ -> True + _ -> False + +isFCallId_maybe id = case Var.idDetails id of + FCallId call -> Just call + _ -> Nothing + +isDataConWorkId id = case Var.idDetails id of + DataConWorkId _ -> True + _ -> False + +isDataConWorkId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + _ -> Nothing + +isDataConWrapId id = case Var.idDetails id of + DataConWrapId _ -> True + _ -> False + +isDataConWrapId_maybe id = case Var.idDetails id of + DataConWrapId con -> Just con + _ -> Nothing + +dataConWrapUnfolding_maybe :: Id -> Maybe CoreExpr +dataConWrapUnfolding_maybe id + | DataConWrapId {} <- idDetails id + , CoreUnfolding { uf_tmpl = unf } <- realIdUnfolding id + = Just unf + | otherwise + = Nothing + +isDataConId_maybe :: Id -> Maybe DataCon +isDataConId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + DataConWrapId con -> Just con + _ -> Nothing + +isDataConId :: Id -> Bool +isDataConId id = case Var.idDetails id of + DataConWorkId {} -> True + DataConWrapId {} -> True + _ -> False + +-- | An Id for which we might require all callers to pass strict arguments properly tagged + evaluated. +-- +-- See Note [CBV Function Ids] +isWorkerLikeId :: Id -> Bool +isWorkerLikeId id = case Var.idDetails id of + WorkerLikeId _ -> True + JoinId _ Just{} -> True + _ -> False + +isJoinId :: Var -> Bool +-- It is convenient in GHC.Core.Opt.SetLevels.lvlMFE to apply isJoinId +-- to the free vars of an expression, so it's convenient +-- if it returns False for type variables +isJoinId id + | isId id = case Var.idDetails id of + JoinId {} -> True + _ -> False + | otherwise = False + +-- | Doesn't return strictness marks +idJoinPointHood :: Var -> JoinPointHood +idJoinPointHood id + | isId id = case Var.idDetails id of + JoinId arity _marks -> JoinPoint arity + _ -> NotJoinPoint + | otherwise = NotJoinPoint + +idDataCon :: Id -> DataCon +-- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. +-- +-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker +idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) + +hasNoBinding :: Id -> Bool +-- ^ Returns @True@ of an 'Id' which may not have a +-- binding, even though it is defined in this module. + +-- Data constructor workers used to be things of this kind, but they aren't any +-- more. Instead, we inject a binding for them at the CorePrep stage. The +-- exception to this is unboxed tuples and sums datacons, which definitely have +-- no binding +hasNoBinding id = case Var.idDetails id of + +-- TEMPORARILY make all primops hasNoBinding, to avoid #20155 +-- The goal is to understand #20155 and revert to the commented out version + PrimOpId _ _ -> True -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps +-- PrimOpId _ lev_poly -> lev_poly -- TEMPORARILY commented out + + FCallId _ -> True + DataConWorkId dc -> isUnboxedTupleDataCon dc + || isUnboxedSumDataCon dc + || isUnaryClassDataCon dc + -- Unary class dictionary constructors are eliminated + -- See Note [Unary class magic] in GHC.Core.TyCon + _ -> isCompulsoryUnfolding (realIdUnfolding id) + -- Note: this function must be very careful not to force + -- any of the fields that aren't the 'uf_src' field of + -- the 'Unfolding' of the 'Id'. This is because these fields are computed + -- in terms of the 'uf_tmpl' field, which is not available + -- until we have finished Core Lint for the unfolding, which calls 'hasNoBinding' + -- in 'checkCanEtaExpand'. + -- + -- In particular, calling 'idUnfolding' rather than 'realIdUnfolding' here can + -- force the 'uf_tmpl' field, because 'trimUnfolding' forces the 'uf_is_value' field, + -- and this field is usually computed in terms of the 'uf_tmpl' field, + -- so we will force that as well. + -- + -- See Note [Lazily checking Unfoldings] in GHC.IfaceToCore. + +isImplicitId :: Id -> Bool +-- ^ 'isImplicitId' tells whether an 'Id's info is implied by other +-- declarations, so we don't need to put its signature in an interface +-- file, even if it's mentioned in some other interface unfolding. +isImplicitId id + = case Var.idDetails id of + FCallId {} -> True + ClassOpId {} -> True + PrimOpId {} -> True + DataConWorkId {} -> True + DataConWrapId {} -> True + -- These are implied by their type or class decl; + -- remember that all type and class decls appear in the interface file. + -- The dfun id is not an implicit Id; it must *not* be omitted, because + -- it carries version info for the instance decl + _ -> False + +idIsFrom :: Module -> Id -> Bool +idIsFrom mod id = nameIsLocalOrFrom mod (idName id) + +isDeadBinder :: Id -> Bool +isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) + | otherwise = False -- TyVars count as not dead + +{- +************************************************************************ +* * + Join variables +* * +************************************************************************ +-} + +idJoinArity :: JoinId -> JoinArity +idJoinArity id = case idJoinPointHood id of + JoinPoint ar -> ar + NotJoinPoint -> pprPanic "idJoinArity" (ppr id) + +asJoinId :: Id -> JoinArity -> JoinId +asJoinId id arity = warnPprTrace (not (isLocalId id)) + "global id being marked as join var" (ppr id) $ + warnPprTrace (not (is_vanilla_or_join id)) + "asJoinId" + (ppr id <+> pprIdDetails (idDetails id)) $ + id `setIdDetails` JoinId arity (idCbvMarks_maybe id) + where + is_vanilla_or_join id = case Var.idDetails id of + VanillaId -> True + -- Can workers become join ids? Yes! + WorkerLikeId {} -> pprTraceDebug "asJoinId (call by value function)" (ppr id) True + JoinId {} -> True + _ -> False + +zapJoinId :: Id -> Id +-- May be a regular id already +zapJoinId jid | isJoinId jid = zapIdTailCallInfo (newIdDetails `seq` jid `setIdDetails` newIdDetails) + -- Core Lint may complain if still marked + -- as AlwaysTailCalled + | otherwise = jid + where + newIdDetails = case idDetails jid of + -- We treat join points as CBV functions. Even after they are floated out. + -- See Note [Use CBV semantics only for join points and workers] + JoinId _ (Just marks) -> WorkerLikeId marks + JoinId _ Nothing -> WorkerLikeId [] + _ -> panic "zapJoinId: newIdDetails can only be used if Id was a join Id." + + +asJoinId_maybe :: Id -> JoinPointHood -> Id +asJoinId_maybe id (JoinPoint arity) = asJoinId id arity +asJoinId_maybe id NotJoinPoint = zapJoinId id + +{- +************************************************************************ +* * +\subsection{IdInfo stuff} +* * +************************************************************************ +-} + + --------------------------------- + -- ARITY +idArity :: Id -> Arity +idArity id = arityInfo (idInfo id) + +setIdArity :: Id -> Arity -> Id +setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id + +idCallArity :: Id -> Arity +idCallArity id = callArityInfo (idInfo id) + +setIdCallArity :: Id -> Arity -> Id +setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id + +-- | This function counts all arguments post-unarisation, which includes +-- arguments with no runtime representation -- see Note [Unarisation and arity] +idFunRepArity :: Id -> RepArity +idFunRepArity x = countFunRepArgs (idArity x) (idType x) + +-- | Returns true if an application to n args diverges or throws an exception +-- See Note [Dead ends] in "GHC.Types.Demand". +isDeadEndId :: Var -> Bool +isDeadEndId v + | isId v = isDeadEndSig (idDmdSig v) + | otherwise = False + +-- | Accesses the 'Id''s 'dmdSigInfo'. +idDmdSig :: Id -> DmdSig +idDmdSig id = dmdSigInfo (idInfo id) + +setIdDmdSig :: Id -> DmdSig -> Id +setIdDmdSig id sig = modifyIdInfo (`setDmdSigInfo` sig) id + +idCprSig :: Id -> CprSig +idCprSig id = cprSigInfo (idInfo id) + +setIdCprSig :: Id -> CprSig -> Id +setIdCprSig id sig = modifyIdInfo (\info -> setCprSigInfo info sig) id + +zapIdDmdSig :: Id -> Id +zapIdDmdSig id = modifyIdInfo (`setDmdSigInfo` nopSig) id + +-- | `isStrictId` says whether either +-- (a) the 'Id' has a strict demand placed on it or +-- (b) definitely has a \"strict type\", such that it can always be +-- evaluated strictly (i.e an unlifted type) +-- We need to check (b) as well as (a), because when the demand for the +-- given `id` hasn't been computed yet but `id` has a strict +-- type, we still want `isStrictId id` to be `True`. +-- Returns False if the type is levity polymorphic; False is always safe. +isStrictId :: Id -> Bool +isStrictId id + | assertPpr (isId id) (text "isStrictId: not an id: " <+> ppr id) $ + isJoinId id = False + | otherwise = isStrictType (idType id) || + isStrUsedDmd (idDemandInfo id) + -- Take the best of both strictnesses - old and new + +idTagSig_maybe :: Id -> Maybe TagSig +idTagSig_maybe = tagSig . idInfo + +--------------------------------- +-- UNFOLDING + +-- | Returns the 'Id's unfolding, but does not expose the unfolding of a strong +-- loop breaker. See 'unfoldingInfo'. +-- +-- If you really want the unfolding of a strong loopbreaker, call 'realIdUnfolding'. +idUnfolding :: IdUnfoldingFun +idUnfolding id = unfoldingInfo (idInfo id) + +noUnfoldingFun :: IdUnfoldingFun +noUnfoldingFun _id = noUnfolding + +-- | Returns an unfolding only if +-- (a) not a strong loop breaker and +-- (b) always active +alwaysActiveUnfoldingFun :: IdUnfoldingFun +alwaysActiveUnfoldingFun id + | isAlwaysActive (idInlineActivation id) = idUnfolding id + | otherwise = noUnfolding + +-- | Returns an unfolding only if +-- (a) not a strong loop breaker and +-- (b) active in according to is_active +whenActiveUnfoldingFun :: (Activation -> Bool) -> IdUnfoldingFun +whenActiveUnfoldingFun is_active id + | is_active (idInlineActivation id) = idUnfolding id + | otherwise = NoUnfolding + +realIdUnfolding :: Id -> Unfolding +-- ^ Expose the unfolding if there is one, including for loop breakers +realIdUnfolding id = realUnfoldingInfo (idInfo id) + +setIdUnfolding :: Id -> Unfolding -> Id +setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id + +idDemandInfo :: Id -> Demand +idDemandInfo id = demandInfo (idInfo id) + +setIdDemandInfo :: Id -> Demand -> Id +setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id + +setIdTagSig :: Id -> TagSig -> Id +setIdTagSig id sig = modifyIdInfo (`setTagSig` sig) id + +-- | If all marks are NotMarkedStrict we just set nothing. +setIdCbvMarks :: Id -> [CbvMark] -> Id +setIdCbvMarks id marks + | not (any isMarkedCbv marks) = id + | otherwise = + -- pprTrace "setMarks:" (ppr id <> text ":" <> ppr marks) $ + case idDetails id of + -- good ol (likely worker) function + VanillaId -> id `setIdDetails` (WorkerLikeId trimmedMarks) + JoinId arity _ -> id `setIdDetails` (JoinId arity (Just trimmedMarks)) + -- Updating an existing call by value function. + WorkerLikeId _ -> id `setIdDetails` (WorkerLikeId trimmedMarks) + -- Do nothing for these + RecSelId{} -> id + DFunId{} -> id + _ -> pprTrace "setIdCbvMarks: Unable to set cbv marks for" (ppr id $$ + text "marks:" <> ppr marks $$ + text "idDetails:" <> ppr (idDetails id)) id + + where + -- (Currently) no point in passing args beyond the arity unlifted. + -- We would have to eta expand all call sites to (length marks). + -- Perhaps that's sensible but for now be conservative. + -- Similarly we don't need any lazy marks at the end of the list. + -- This way the length of the list is always exactly number of arguments + -- that must be visible to CodeGen. See See Note [CBV Function Ids] + -- for more details. + trimmedMarks = dropWhileEndLE (not . isMarkedCbv) $ take (idArity id) marks + +idCbvMarks_maybe :: Id -> Maybe [CbvMark] +idCbvMarks_maybe id = case idDetails id of + WorkerLikeId marks -> Just marks + JoinId _arity marks -> marks + _ -> Nothing + +-- Id must be called with at least this arity in order to allow arguments to +-- be passed unlifted. +idCbvMarkArity :: Id -> Arity +idCbvMarkArity fn = maybe 0 length (idCbvMarks_maybe fn) + +-- | Remove any cbv marks on arguments from a given Id. +asNonWorkerLikeId :: Id -> Id +asNonWorkerLikeId id = + let details = case idDetails id of + WorkerLikeId{} -> Just $ VanillaId + JoinId arity Just{} -> Just $ JoinId arity Nothing + _ -> Nothing + in maybeModifyIdDetails details id + +-- | Turn this id into a WorkerLikeId if possible. +asWorkerLikeId :: Id -> Id +asWorkerLikeId id = + let details = case idDetails id of + WorkerLikeId{} -> Nothing + JoinId _arity Just{} -> Nothing + JoinId arity Nothing -> Just (JoinId arity (Just [])) + VanillaId -> Just $ WorkerLikeId [] + _ -> Nothing + in maybeModifyIdDetails details id + +setCaseBndrEvald :: StrictnessMark -> Id -> Id +-- Used for variables bound by a case expressions, both the case-binder +-- itself, and any pattern-bound variables that are argument of a +-- strict constructor. It just marks the variable as already-evaluated, +-- so that (for example) a subsequent 'seq' can be dropped +setCaseBndrEvald str id + | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding + | otherwise = id + +-- | Similar to trimUnfolding, but also removes evaldness info. +zapIdUnfolding :: Id -> Id +zapIdUnfolding v + | isId v, hasSomeUnfolding (idUnfolding v) = setIdUnfolding v noUnfolding + | otherwise = v + + --------------------------------- + -- SPECIALISATION + +-- See Note [Specialisations and RULES in IdInfo] in GHC.Types.Id.Info + +idSpecialisation :: Id -> RuleInfo +idSpecialisation id = ruleInfo (idInfo id) + +idCoreRules :: Id -> [CoreRule] +idCoreRules id = ruleInfoRules (idSpecialisation id) + +idHasRules :: Id -> Bool +idHasRules id = not (isEmptyRuleInfo (idSpecialisation id)) + +setIdSpecialisation :: Id -> RuleInfo -> Id +setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id + + --------------------------------- + -- CAF INFO +idCafInfo :: Id -> CafInfo +idCafInfo id = cafInfo (idInfo id) + +setIdCafInfo :: Id -> CafInfo -> Id +setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id + + --------------------------------- + -- Lambda form info + +idLFInfo_maybe :: Id -> Maybe LambdaFormInfo +idLFInfo_maybe = lfInfo . idInfo + +setIdLFInfo :: Id -> LambdaFormInfo -> Id +setIdLFInfo id lf = modifyIdInfo (`setLFInfo` lf) id + + --------------------------------- + -- Occurrence INFO +idOccInfo :: Id -> OccInfo +idOccInfo id = occInfo (idInfo id) + +setIdOccInfo :: Id -> OccInfo -> Id +setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id + +zapIdOccInfo :: Id -> Id +zapIdOccInfo b = b `setIdOccInfo` noOccInfo + +{- + --------------------------------- + -- INLINING +The inline pragma tells us to be very keen to inline this Id, but it's still +OK not to if optimisation is switched off. +-} + +idInlinePragma :: Id -> InlinePragma +idInlinePragma id = inlinePragInfo (idInfo id) + +setInlinePragma :: Id -> InlinePragma -> Id +setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id + +modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id +modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id + +idInlineActivation :: Id -> Activation +idInlineActivation id = inlinePragmaActivation (idInlinePragma id) + +setInlineActivation :: Id -> Activation -> Id +setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) + +idRuleMatchInfo :: Id -> RuleMatchInfo +idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) + +isConLikeId :: Id -> Bool +isConLikeId id = isConLike (idRuleMatchInfo id) + +{- + --------------------------------- + -- ONE-SHOT LAMBDAS +-} + +idOneShotInfo :: Id -> OneShotInfo +idOneShotInfo id = oneShotInfo (idInfo id) + +setOneShotLambda :: Id -> Id +setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id + +clearOneShotLambda :: Id -> Id +clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id + +setIdOneShotInfo :: Id -> OneShotInfo -> Id +setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id + +updOneShotInfo :: Id -> OneShotInfo -> Id +-- Combine the info in the Id with new info +updOneShotInfo id one_shot + | OneShotLam <- one_shot + , NoOneShotInfo <- idOneShotInfo id + = setIdOneShotInfo id OneShotLam + | otherwise + = id + +-- The OneShotLambda functions simply fiddle with the IdInfo flag +-- But watch out: this may change the type of something else +-- f = \x -> e +-- If we change the one-shot-ness of x, f's type changes + +-- Replaces the id info if the zapper returns @Just idinfo@ +zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id +zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id + +zapLamIdInfo :: Id -> Id +zapLamIdInfo = zapInfo zapLamInfo + +zapFragileIdInfo :: Id -> Id +zapFragileIdInfo = zapInfo zapFragileInfo + +floatifyIdDemandInfo :: Id -> Id +-- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels +floatifyIdDemandInfo = zapInfo floatifyDemandInfo + +zapIdUsageInfo :: Id -> Id +zapIdUsageInfo = zapInfo zapUsageInfo + +zapIdUsageEnvInfo :: Id -> Id +zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo + +zapIdUsedOnceInfo :: Id -> Id +zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo + +zapIdTailCallInfo :: Id -> Id +zapIdTailCallInfo = zapInfo zapTailCallInfo + +zapStableUnfolding :: Id -> Id +zapStableUnfolding id + | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding + | otherwise = id + +{- +Note [transferPolyIdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This transfer is used in three places: + FloatOut (long-distance let-floating) + GHC.Core.Opt.Simplify.Utils.abstractFloats (short-distance let-floating) + StgLiftLams (selectively lambda-lift local functions to top-level) + +Consider the short-distance let-floating: + + f = /\a. let g = rhs in ... + +Then if we float thus + + g' = /\a. rhs + f = /\a. ...[g' a/g].... + +we *do not* want to lose g's + * strictness information + * arity + * inline pragma (though that is bit more debatable) + * occurrence info + +Mostly this is just an optimisation, but it's *vital* to +transfer the occurrence info. Consider + + NonRec { f = /\a. let Rec { g* = ..g.. } in ... } + +where the '*' means 'LoopBreaker'. Then if we float we must get + + Rec { g'* = /\a. ...(g' a)... } + NonRec { f = /\a. ...[g' a/g]....} + +where g' is also marked as LoopBreaker. If not, terrible things +can happen if we re-simplify the binding (and the Simplifier does +sometimes simplify a term twice); see #4345. + +It's not so simple to retain + * worker info + * rules +so we simply discard those. Sooner or later this may bite us. + +If we abstract wrt one or more *value* binders, we must modify the +arity and strictness info before transferring it. E.g. + f = \x. e +--> + g' = \y. \x. e + + substitute (g' y) for g +Notice that g' has an arity one more than the original g +-} + +transferPolyIdInfo :: Id -- Original Id + -> [Var] -- Abstract wrt these variables + -> Id -- New Id + -> Id +transferPolyIdInfo old_id abstract_wrt new_id + = modifyIdInfo transfer new_id `setIdCbvMarks` new_cbv_marks + where + arity_increase = count isId abstract_wrt -- Arity increases by the + -- number of value binders + + old_info = idInfo old_id + old_arity = arityInfo old_info + old_inline_prag = inlinePragInfo old_info + old_occ_info = occInfo old_info + new_arity = old_arity + arity_increase + new_occ_info = zapOccTailCallInfo old_occ_info + + old_strictness = dmdSigInfo old_info + new_strictness = prependArgsDmdSig arity_increase old_strictness + old_cpr = cprSigInfo old_info + new_cpr = prependArgsCprSig arity_increase old_cpr + + old_cbv_marks = fromMaybe (replicate old_arity NotMarkedCbv) (idCbvMarks_maybe old_id) + abstr_cbv_marks = mapMaybe getMark abstract_wrt + new_cbv_marks = abstr_cbv_marks ++ old_cbv_marks + + getMark v + | not (isId v) + = Nothing + | isId v + , isEvaldUnfolding (idUnfolding v) + , mightBeLiftedType (idType v) + = Just MarkedCbv + | otherwise = Just NotMarkedCbv + transfer new_info = new_info `setArityInfo` new_arity + `setInlinePragInfo` old_inline_prag + `setOccInfo` new_occ_info + `setDmdSigInfo` new_strictness + `setCprSigInfo` new_cpr diff --git a/GHC/Types/Id.hs-boot b/GHC/Types/Id.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/Id.hs-boot @@ -0,0 +1,6 @@ +module GHC.Types.Id where + +import {-# SOURCE #-} GHC.Types.Name +import {-# SOURCE #-} GHC.Types.Var + +idName :: Id -> Name diff --git a/GHC/Types/Id/Info.hs b/GHC/Types/Id/Info.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Id/Info.hs @@ -0,0 +1,957 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} + +(And a pretty good illustration of quite a few things wrong with +Haskell. [WDP 94/11]) +-} + +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Types.Id.Info ( + -- * The IdDetails type + IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, + JoinArity, isJoinIdDetails_maybe, + + RecSelParent(..), recSelParentName, recSelFirstConName, + recSelParentCons, idDetailsConcreteTvs, + RecSelInfo(..), conLikesRecSelInfo, + + -- * The IdInfo type + IdInfo, -- Abstract + vanillaIdInfo, noCafIdInfo, + + -- ** The OneShotInfo type + OneShotInfo(..), + oneShotInfo, noOneShotInfo, hasNoOneShotInfo, + setOneShotInfo, + + -- ** Zapping various forms of Info + zapLamInfo, zapFragileInfo, + lazifyDemandInfo, floatifyDemandInfo, + zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, + zapTailCallInfo, zapCallArityInfo, trimUnfolding, + + -- ** The ArityInfo type + ArityInfo, + unknownArity, + arityInfo, setArityInfo, ppArityInfo, + + callArityInfo, setCallArityInfo, + + -- ** Demand and strictness Info + dmdSigInfo, setDmdSigInfo, + cprSigInfo, setCprSigInfo, + demandInfo, setDemandInfo, pprStrictness, + + -- ** Unfolding Info + realUnfoldingInfo, unfoldingInfo, setUnfoldingInfo, hasInlineUnfolding, + + -- ** The InlinePragInfo type + InlinePragInfo, + inlinePragInfo, setInlinePragInfo, + + -- ** The OccInfo type + OccInfo(..), + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, + occInfo, setOccInfo, + + InsideLam(..), BranchCount, + + TailCallInfo(..), + tailCallInfo, isAlwaysTailCalled, + + -- ** The RuleInfo type + RuleInfo(..), + emptyRuleInfo, + isEmptyRuleInfo, ruleInfoFreeVars, + ruleInfoRules, setRuleInfoHead, + ruleInfo, setRuleInfo, tagSigInfo, + + -- ** The CAFInfo type + CafInfo(..), + ppCafInfo, mayHaveCafRefs, + cafInfo, setCafInfo, + + -- ** The LambdaFormInfo type + LambdaFormInfo, + lfInfo, setLFInfo, setTagSig, + + tagSig, + + -- ** Tick-box Info + TickBoxOp(..), TickBoxId, + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Class +import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Type (mkTyConApp) +import GHC.Core.PatSyn +import GHC.Core.ConLike +import GHC.Types.ForeignCall +import GHC.Unit.Module +import GHC.Types.Demand +import GHC.Types.Cpr +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars, noConcreteTyVars ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Stg.EnforceEpt.TagSig +import GHC.StgToCmm.Types (LambdaFormInfo) + +import Data.Data ( Data ) +import Data.Word +import Data.List as List( partition ) + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setRuleInfo`, + `setArityInfo`, + `setInlinePragInfo`, + `setUnfoldingInfo`, + `setOneShotInfo`, + `setOccInfo`, + `setCafInfo`, + `setDmdSigInfo`, + `setCprSigInfo`, + `setDemandInfo`, + `setLFInfo` +{- +************************************************************************ +* * + IdDetails +* * +************************************************************************ +-} + +-- | Identifier Details +-- +-- The 'IdDetails' of an 'Id' give stable, and necessary, +-- information about the Id. +data IdDetails + = VanillaId + + -- | The 'Id' for a record selector + | RecSelId + { sel_tycon :: RecSelParent + , sel_fieldLabel :: FieldLabel + , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: + -- data T = forall a. MkT { x :: a } + -- See Note [Naughty record selectors] in GHC.Tc.TyCl + , sel_cons :: RecSelInfo + -- Partiality info, cached here based on the RecSelParent. + } + + | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ + | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ + + -- [the only reasons we need to know is so that + -- a) to support isImplicitId + -- b) when desugaring a RecordCon we can get + -- from the Id back to the data con] + + | ClassOpId -- ^ The 'Id' is a superclass selector or class operation + Class -- for this class + Bool -- True <=> given a non-bottom dictionary, the class op will + -- definitely return a non-bottom result + -- and Note [exprOkForSpeculation and type classes] + -- in GHC.Core.Utils + + -- | A representation-polymorphic pseudo-op. + | RepPolyId + { id_concrete_tvs :: ConcreteTyVars } + -- ^ Which type variables of this representation-polymorphic 'Id + -- should be instantiated to concrete type variables? + -- + -- See Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. + + -- | The 'Id' is for a primitive operator. + | PrimOpId + { id_primop :: PrimOp + , id_concrete_tvs :: ConcreteTyVars } + -- ^ Which type variables of this primop should be instantiated + -- to concrete type variables? + -- + -- Only ever non-empty when the PrimOp has representation-polymorphic + -- type variables. + -- + -- See Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. + + | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. + -- Type will be simple: no type families, newtypes, etc + + | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) + + | DFunId Bool -- ^ A dictionary function. + -- Bool = True <=> the class has only one method, so may be + -- implemented with a newtype, so it might be bad + -- to be strict on this dictionary + + | CoVarId -- ^ A coercion variable + -- This only covers /un-lifted/ coercions, of type + -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants + | JoinId JoinArity (Maybe [CbvMark]) + -- ^ An 'Id' for a join point taking n arguments + -- Note [Join points] in "GHC.Core" + -- Can also work as a WorkerLikeId if given `CbvMark`s. + -- See Note [CBV Function Ids] + -- The [CbvMark] is always empty (and ignored) until after Tidy. + | WorkerLikeId [CbvMark] + -- ^ An 'Id' for a worker like function, which might expect some arguments to be + -- passed both evaluated and tagged. + -- Worker like functions are create by W/W and SpecConstr and we can expect that they + -- aren't used unapplied. + -- See Note [CBV Function Ids] + -- See Note [EPT enforcement] + -- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current + -- module. + +data RecSelInfo + = RSI { rsi_def :: [ConLike] -- Record selector defined for these + , rsi_undef :: [ConLike] -- Record selector not defined for these + } + +idDetailsConcreteTvs :: IdDetails -> ConcreteTyVars +idDetailsConcreteTvs = \ case + PrimOpId _ conc_tvs -> conc_tvs + RepPolyId conc_tvs -> conc_tvs + DataConWorkId dc -> dataConConcreteTyVars dc + DataConWrapId dc -> dataConConcreteTyVars dc + _ -> noConcreteTyVars + +-- | The ConLikes that have *all* the given fields +conLikesRecSelInfo :: [ConLike] -> [FieldLabelString] -> RecSelInfo +conLikesRecSelInfo con_likes lbls + = RSI { rsi_def = defs, rsi_undef = undefs } + where + !(defs,undefs) = List.partition has_flds con_likes + + has_flds dc = all (has_fld dc) lbls + has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) + + +{- Note [CBV Function Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A WorkerLikeId essentially allows us to constrain the calling convention +for the given Id. Each such Id carries with it a list of CbvMarks +with each element representing a value argument. Arguments who have +a matching `MarkedCbv` entry in the list need to be passed evaluated+*properly tagged*. + +CallByValueFunIds give us additional expressiveness which we use to improve +runtime. This is all part of the EPT enforcement work. See also Note [EPT enforcement]. + +They allows us to express the fact that an argument is not only evaluated to WHNF once we +entered it's RHS but also that an lifted argument is already *properly tagged* once we jump +into the RHS. +This means when e.g. branching on such an argument the RHS doesn't needed to perform +an eval check to ensure the argument isn't an indirection. All seqs on such an argument in +the functions body become no-ops as well. + +The invariants around the arguments of call by value function like Ids are then: + +* In any call `(f e1 .. en)`, if `f`'s i'th argument is marked `MarkedCbv`, + then the caller must ensure that the i'th argument + * points directly to the value (and hence is certainly evaluated before the call) + * is a properly tagged pointer to that value + +* The following functions (and only these functions) have `CbvMarks`: + * Any `WorkerLikeId` + * Some `JoinId` bindings. + +This works analogous to the EPT Invariant. See also Note [EPT enforcement]. + +To make this work what we do is: +* During W/W and SpecConstr any worker/specialized binding we introduce + is marked as a worker binding by `asWorkerLikeId`. +* W/W and SpecConstr further set OtherCon[] unfoldings on arguments which + represent contents of a strict fields. +* During Tidy we look at all bindings. + For any callByValueLike Id and join point we mark arguments as cbv if they + Are strict. We don't do so for regular bindings. + See Note [Use CBV semantics only for join points and workers] for why. + We might have made some ids rhs *more* strict in order to make their arguments + be passed CBV. See Note [Call-by-value for worker args] for why. +* During CorePrep calls to CallByValueFunIds are eta expanded. +* During Stg CodeGen: + * When we see a call to a callByValueLike Id: + * We check if all arguments marked to be passed unlifted are already tagged. + * If they aren't we will wrap the call in case expressions which will evaluate+tag + these arguments before jumping to the function. +* During Cmm codeGen: + * When generating code for the RHS of a StrictWorker binding + we omit tag checks when using arguments marked as tagged. + +We only use this for workers and specialized versions of SpecConstr +But we also check other functions during tidy and potentially turn some of them into +call by value functions and mark some of their arguments as call-by-value by looking at +argument unfoldings. + +NB: I choose to put the information into a new Id constructor since these are loaded +at all optimization levels. This makes it trivial to ensure the additional +calling convention demands are available at all call sites. Putting it into +IdInfo would require us at the very least to always decode the IdInfo +just to decide if we need to throw it away or not after. + +Note [Use CBV semantics only for join points and workers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A function with cbv-semantics requires arguments to be visible +and if no arguments are visible requires us to eta-expand it's +call site. That is for a binding with three cbv arguments like +`w[WorkerLikeId[!,!,!]]` we would need to eta expand undersaturated +occurrences like `map w xs` into `map (\x1 x2 x3 -> w x1 x2 x3) xs. + +In experiments it turned out that the code size increase of doing so +can outweigh the performance benefits of doing so. +So we only do this for join points, workers and +specialized functions (from SpecConstr). +Join points are naturally always called saturated so +this problem can't occur for them. +For workers and specialized functions there are also always at least +some applied arguments as we won't inline the wrapper/apply their rule +if there are unapplied occurrences like `map f xs`. +-} + +-- | Parent of a record selector function. +-- +-- Either the parent 'TyCon' or 'PatSyn' depending +-- on the origin of the record selector. +-- +-- For a data family, this is the /instance/ 'TyCon', +-- **not** the family 'TyCon'. +data RecSelParent + -- | Parent of a data constructor record field. + -- + -- For a data family, this is the /instance/ 'TyCon'. + = RecSelData TyCon + -- | Parent of a pattern synonym record field: + -- the 'PatSyn' itself. + | RecSelPatSyn PatSyn + deriving (Eq, Data) + +recSelParentName :: RecSelParent -> Name +recSelParentName (RecSelData tc) = tyConName tc +recSelParentName (RecSelPatSyn ps) = patSynName ps + +recSelFirstConName :: RecSelParent -> Name +recSelFirstConName (RecSelData tc) = dataConName $ head $ tyConDataCons tc +recSelFirstConName (RecSelPatSyn ps) = patSynName ps + +recSelParentCons :: RecSelParent -> [ConLike] +recSelParentCons (RecSelData tc) + | isAlgTyCon tc + = map RealDataCon $ visibleDataCons + $ algTyConRhs tc + | otherwise + = [] +recSelParentCons (RecSelPatSyn ps) = [PatSynCon ps] + +instance Outputable RecSelParent where + ppr p = case p of + RecSelData tc + | Just (parent_tc, tys) <- tyConFamInst_maybe tc + -> ppr (mkTyConApp parent_tc tys) + | otherwise + -> ppr tc + RecSelPatSyn ps + -> ppr ps + +-- | Just a synonym for 'CoVarId'. Written separately so it can be +-- exported in the hs-boot file. +coVarDetails :: IdDetails +coVarDetails = CoVarId + +-- | Check if an 'IdDetails' says 'CoVarId'. +isCoVarDetails :: IdDetails -> Bool +isCoVarDetails CoVarId = True +isCoVarDetails _ = False + +isJoinIdDetails_maybe :: IdDetails -> Maybe (JoinArity, (Maybe [CbvMark])) +isJoinIdDetails_maybe (JoinId join_arity marks) = Just (join_arity, marks) +isJoinIdDetails_maybe _ = Nothing + +instance Outputable IdDetails where + ppr = pprIdDetails + +pprIdDetails :: IdDetails -> SDoc +pprIdDetails VanillaId = empty +pprIdDetails other = brackets (pp other) + where + pp VanillaId = panic "pprIdDetails" + pp (WorkerLikeId dmds) = text "StrictWorker" <> parens (ppr dmds) + pp (DataConWorkId _) = text "DataCon" + pp (DataConWrapId _) = text "DataConWrapper" + pp (ClassOpId {}) = text "ClassOp" + pp (RepPolyId {}) = text "RepPolyId" + pp (PrimOpId {}) = text "PrimOp" + pp (FCallId _) = text "ForeignCall" + pp (TickBoxOpId _) = text "TickBoxOp" + pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") + pp (RecSelId { sel_naughty = is_naughty }) + = brackets $ text "RecSel" <> + ppWhen is_naughty (text "(naughty)") + pp CoVarId = text "CoVarId" + pp (JoinId arity marks) = text "JoinId" <> parens (int arity) <> parens (ppr marks) + +{- +************************************************************************ +* * +\subsection{The main IdInfo type} +* * +************************************************************************ +-} + +-- | Identifier Information +-- +-- An 'IdInfo' gives /optional/ information about an 'Id'. If +-- present it never lies, but it may not be present, in which case there +-- is always a conservative assumption which can be made. +-- +-- Two 'Id's may have different info even though they have the same +-- 'Unique' (and are hence the same 'Id'); for example, one might lack +-- the properties attached to the other. +-- +-- Most of the 'IdInfo' gives information about the value, or definition, of +-- the 'Id', independent of its usage. Exceptions to this +-- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'. +-- +-- Performance note: when we update 'IdInfo', we have to reallocate this +-- entire record, so it is a good idea not to let this data structure get +-- too big. +data IdInfo + = IdInfo { + ruleInfo :: RuleInfo, + -- ^ Specialisations of the 'Id's function which exist. + -- See Note [Specialisations and RULES in IdInfo] + realUnfoldingInfo :: Unfolding, + -- ^ The 'Id's unfolding + inlinePragInfo :: InlinePragma, + -- ^ Any inline pragma attached to the 'Id' + occInfo :: OccInfo, + -- ^ How the 'Id' occurs in the program + dmdSigInfo :: DmdSig, + -- ^ A strictness signature. Describes how a function uses its arguments + -- See Note [idArity varies independently of dmdTypeDepth] + -- in GHC.Core.Opt.DmdAnal + cprSigInfo :: CprSig, + -- ^ Information on whether the function will ultimately return a + -- freshly allocated constructor. + demandInfo :: Demand, + -- ^ ID demand information + bitfield :: {-# UNPACK #-} !BitField, + -- ^ Bitfield packs CafInfo, OneShotInfo, arity info, and + -- call arity info in one 64-bit word. Packing these fields reduces size + -- of `IdInfo` from 12 words to 7 words and reduces residency by almost + -- 4% in some programs. See #17497 and associated MR. + -- + -- See documentation of the getters for what these packed fields mean. + lfInfo :: !(Maybe LambdaFormInfo), + -- ^ If lfInfo = Just info, then the `info` is guaranteed /correct/. + -- If lfInfo = Nothing, then we do not have a `LambdaFormInfo` for this Id, + -- so (for imported Ids) we make a conservative version. + -- See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure + -- For locally-defined Ids other than DataCons, the `lfInfo` field is always Nothing. + -- See also Note [LFInfo of DataCon workers and wrappers] + + -- See documentation of the getters for what these packed fields mean. + tagSig :: !(Maybe TagSig) + } + +-- | Encodes arities, OneShotInfo, CafInfo. +-- From least-significant to most-significant bits: +-- +-- - Bit 0 (1): OneShotInfo +-- - Bit 1 (1): CafInfo +-- - Bit 2 (1): unused +-- - Bits 3-32(30): Call Arity info +-- - Bits 33-62(30): Arity info +-- +newtype BitField = BitField Word64 + +emptyBitField :: BitField +emptyBitField = BitField 0 + +bitfieldGetOneShotInfo :: BitField -> OneShotInfo +bitfieldGetOneShotInfo (BitField bits) = + if testBit bits 0 then OneShotLam else NoOneShotInfo + +bitfieldGetCafInfo :: BitField -> CafInfo +bitfieldGetCafInfo (BitField bits) = + if testBit bits 1 then NoCafRefs else MayHaveCafRefs + +bitfieldGetCallArityInfo :: BitField -> ArityInfo +bitfieldGetCallArityInfo (BitField bits) = + fromIntegral (bits `shiftR` 3) .&. ((1 `shiftL` 30) - 1) + +bitfieldGetArityInfo :: BitField -> ArityInfo +bitfieldGetArityInfo (BitField bits) = + fromIntegral (bits `shiftR` 33) + +bitfieldSetOneShotInfo :: OneShotInfo -> BitField -> BitField +bitfieldSetOneShotInfo info (BitField bits) = + case info of + NoOneShotInfo -> BitField (clearBit bits 0) + OneShotLam -> BitField (setBit bits 0) + +bitfieldSetCafInfo :: CafInfo -> BitField -> BitField +bitfieldSetCafInfo info (BitField bits) = + case info of + MayHaveCafRefs -> BitField (clearBit bits 1) + NoCafRefs -> BitField (setBit bits 1) + +bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField +bitfieldSetCallArityInfo info bf@(BitField bits) = + assert (info < 2^(30 :: Int) - 1) $ + bitfieldSetArityInfo (bitfieldGetArityInfo bf) $ + BitField ((fromIntegral info `shiftL` 3) .|. (bits .&. 0b111)) + +bitfieldSetArityInfo :: ArityInfo -> BitField -> BitField +bitfieldSetArityInfo info (BitField bits) = + assert (info < 2^(30 :: Int) - 1) $ + BitField ((fromIntegral info `shiftL` 33) .|. (bits .&. ((1 `shiftL` 33) - 1))) + +-- Getters + +-- | Info about a lambda-bound variable, if the 'Id' is one +oneShotInfo :: IdInfo -> OneShotInfo +oneShotInfo = bitfieldGetOneShotInfo . bitfield + +-- | 'Id' arity, as computed by "GHC.Core.Opt.Arity". Specifies how many arguments +-- this 'Id' has to be applied to before it does any meaningful work. +arityInfo :: IdInfo -> ArityInfo +arityInfo = bitfieldGetArityInfo . bitfield + +-- | 'Id' CAF info +cafInfo :: IdInfo -> CafInfo +cafInfo = bitfieldGetCafInfo . bitfield + +-- | How this is called. This is the number of arguments to which a binding can +-- be eta-expanded without losing any sharing. n <=> all calls have at least n +-- arguments +callArityInfo :: IdInfo -> ArityInfo +callArityInfo = bitfieldGetCallArityInfo . bitfield + +tagSigInfo :: IdInfo -> Maybe TagSig +tagSigInfo = tagSig + +-- Setters + +setRuleInfo :: IdInfo -> RuleInfo -> IdInfo +setRuleInfo info sp = sp `seq` info { ruleInfo = sp } +setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo +setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } +setOccInfo :: IdInfo -> OccInfo -> IdInfo +setOccInfo info oc = oc `seq` info { occInfo = oc } + -- Try to avoid space leaks by seq'ing + +-- | Essentially returns the 'realUnfoldingInfo' field, but does not expose the +-- unfolding of a strong loop breaker. +-- +-- This is the right thing to call if you plan to decide whether an unfolding +-- will inline. +unfoldingInfo :: IdInfo -> Unfolding +unfoldingInfo info + | isStrongLoopBreaker (occInfo info) = trimUnfolding $ realUnfoldingInfo info + | otherwise = realUnfoldingInfo info + +setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo +setUnfoldingInfo info uf + = -- We don't seq the unfolding, as we generate intermediate + -- unfoldings which are just thrown away, so evaluating them is a + -- waste of time. + -- seqUnfolding uf `seq` + info { realUnfoldingInfo = uf } + +hasInlineUnfolding :: IdInfo -> Bool +-- ^ True of a /non-loop-breaker/ Id that has a /stable/ unfolding that is +-- (a) always inlined; that is, with an `UnfWhen` guidance, or +-- (b) a DFunUnfolding which never needs to be inlined +hasInlineUnfolding info = isInlineUnfolding (unfoldingInfo info) + +setArityInfo :: IdInfo -> ArityInfo -> IdInfo +setArityInfo info ar = + info { bitfield = bitfieldSetArityInfo ar (bitfield info) } + +setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo +setCallArityInfo info ar = + info { bitfield = bitfieldSetCallArityInfo ar (bitfield info) } + +setCafInfo :: IdInfo -> CafInfo -> IdInfo +setCafInfo info caf = + info { bitfield = bitfieldSetCafInfo caf (bitfield info) } + +setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo +setLFInfo info lf = info { lfInfo = Just lf } + +setTagSig :: IdInfo -> TagSig -> IdInfo +setTagSig info sig = info { tagSig = Just sig } + +setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo +setOneShotInfo info lb = + info { bitfield = bitfieldSetOneShotInfo lb (bitfield info) } + +setDemandInfo :: IdInfo -> Demand -> IdInfo +setDemandInfo info dd = dd `seq` info { demandInfo = dd } + +setDmdSigInfo :: IdInfo -> DmdSig -> IdInfo +setDmdSigInfo info dd = dd `seq` info { dmdSigInfo = dd } + +setCprSigInfo :: IdInfo -> CprSig -> IdInfo +setCprSigInfo info cpr = cpr `seq` info { cprSigInfo = cpr } + +-- | Basic 'IdInfo' that carries no useful information whatsoever +vanillaIdInfo :: IdInfo +vanillaIdInfo + = IdInfo { + ruleInfo = emptyRuleInfo, + realUnfoldingInfo = noUnfolding, + inlinePragInfo = defaultInlinePragma, + occInfo = noOccInfo, + demandInfo = topDmd, + dmdSigInfo = nopSig, + cprSigInfo = topCprSig, + bitfield = bitfieldSetCafInfo vanillaCafInfo $ + bitfieldSetArityInfo unknownArity $ + bitfieldSetCallArityInfo unknownArity $ + bitfieldSetOneShotInfo NoOneShotInfo $ + emptyBitField, + lfInfo = Nothing, + tagSig = Nothing + } + +-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references +noCafIdInfo :: IdInfo +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs + -- Used for built-in type Ids in GHC.Types.Id.Make. + +{- +************************************************************************ +* * +\subsection[arity-IdInfo]{Arity info about an @Id@} +* * +************************************************************************ + +For locally-defined Ids, the code generator maintains its own notion +of their arities; so it should not be asking... (but other things +besides the code-generator need arity info!) + +Note [Arity and function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The arity of an 'Id' must never exceed the number of arguments that +can be read off from the 'Id's type, possibly after expanding newtypes. + +Examples: + + f1 :: forall a. a -> a + + idArity f1 <= 1: only one value argument, of type 'a' + + f2 :: forall a. Show a => Int -> a + + idArity f2 <= 2: two value arguments, of types 'Show a' and 'Int'. + + + newtype Id a = MkId a + f3 :: forall b. Id (Int -> b) + + idArity f3 <= 1: there is one value argument, of type 'Int', hidden under the newtype. + + newtype RecFun = MkRecFun (Int -> RecFun) + f4 :: RecFun + + no constraint on the arity of f4: we can unwrap as many layers of the newtype as we want, + to get arbitrarily many arguments of type 'Int'. +-} + + +-- | Arity Information +-- +-- An 'ArityInfo' of @n@ tells us that partial application of this +-- 'Id' to up to @n-1@ value arguments does essentially no work. +-- +-- That is not necessarily the same as saying that it has @n@ leading +-- lambdas, because coerces may get in the way. +-- +-- The arity might increase later in the compilation process, if +-- an extra lambda floats up to the binding site. +-- +-- /Invariant:/ the 'Arity' of an 'Id' must never exceed the number of +-- value arguments that appear in the type of the 'Id'. +-- See Note [Arity and function types]. +type ArityInfo = Arity + +-- | It is always safe to assume that an 'Id' has an arity of 0 +unknownArity :: Arity +unknownArity = 0 + +ppArityInfo :: Int -> SDoc +ppArityInfo 0 = empty +ppArityInfo n = hsep [text "Arity", int n] + +{- +************************************************************************ +* * +\subsection{Inline-pragma information} +* * +************************************************************************ +-} + +-- | Inline Pragma Information +-- +-- Tells when the inlining is active. +-- When it is active the thing may be inlined, depending on how +-- big it is. +-- +-- If there was an @INLINE@ pragma, then as a separate matter, the +-- RHS will have been made to look small with a Core inline 'Note' +-- +-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves +-- entirely as a way to inhibit inlining until we want it +type InlinePragInfo = InlinePragma + +{- +************************************************************************ +* * + Strictness +* * +************************************************************************ +-} + +pprStrictness :: DmdSig -> SDoc +pprStrictness sig = ppr sig + +{- +************************************************************************ +* * + RuleInfo +* * +************************************************************************ + +Note [Specialisations and RULES in IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, a GlobalId has an *empty* RuleInfo. All their +RULES are contained in the globally-built rule-base. In principle, +one could attach the to M.f the RULES for M.f that are defined in M. +But we don't do that for instance declarations and so we just treat +them all uniformly. + +The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is +just for convenience really. + +However, LocalIds may have non-empty RuleInfo. We treat them +differently because: + a) they might be nested, in which case a global table won't work + b) the RULE might mention free variables, which we use to keep things alive + +In GHC.Iface.Tidy, when the LocalId becomes a GlobalId, its RULES are stripped off +and put in the global list. +-} + +-- | Rule Information +-- +-- Records the specializations of this 'Id' that we know about +-- in the form of rewrite 'CoreRule's that target them +data RuleInfo + = RuleInfo + [CoreRule] + DVarSet -- Locally-defined free vars of *both* LHS and RHS + -- of rules. I don't think it needs to include the + -- ru_fn though. + -- Note [Rule dependency info] in "GHC.Core.Opt.OccurAnal" + +-- | Assume that no specializations exist: always safe +emptyRuleInfo :: RuleInfo +emptyRuleInfo = RuleInfo [] emptyDVarSet + +isEmptyRuleInfo :: RuleInfo -> Bool +isEmptyRuleInfo (RuleInfo rs _) = null rs + +-- | Retrieve the locally-defined free variables of both the left and +-- right hand sides of the specialization rules +ruleInfoFreeVars :: RuleInfo -> DVarSet +ruleInfoFreeVars (RuleInfo _ fvs) = fvs + +ruleInfoRules :: RuleInfo -> [CoreRule] +ruleInfoRules (RuleInfo rules _) = rules + +-- | Change the name of the function the rule is keyed on all of the 'CoreRule's +setRuleInfoHead :: Name -> RuleInfo -> RuleInfo +setRuleInfoHead fn (RuleInfo rules fvs) + = RuleInfo (map (setRuleIdName fn) rules) fvs + +{- +************************************************************************ +* * +\subsection[CG-IdInfo]{Code generator-related information} +* * +************************************************************************ +-} + +-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs). + +-- | Constant applicative form Information +-- +-- Records whether an 'Id' makes Constant Applicative Form references +data CafInfo + = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: + -- + -- 1. A function or static constructor + -- that refers to one or more CAFs, or + -- + -- 2. A real live CAF + + | NoCafRefs -- ^ A function or static constructor + -- that refers to no CAFs. + deriving (Eq, Ord) + +-- | Assumes that the 'Id' has CAF references: definitely safe +vanillaCafInfo :: CafInfo +vanillaCafInfo = MayHaveCafRefs + +mayHaveCafRefs :: CafInfo -> Bool +mayHaveCafRefs MayHaveCafRefs = True +mayHaveCafRefs _ = False + +instance Outputable CafInfo where + ppr = ppCafInfo + +ppCafInfo :: CafInfo -> SDoc +ppCafInfo NoCafRefs = text "NoCafRefs" +ppCafInfo MayHaveCafRefs = empty + +{- +************************************************************************ +* * +\subsection{Bulk operations on IdInfo} +* * +************************************************************************ +-} + +-- | This is used to remove information on lambda binders that we have +-- setup as part of a lambda group, assuming they will be applied all at once, +-- but turn out to be part of an unsaturated lambda as in e.g: +-- +-- > (\x1. \x2. e) arg1 +zapLamInfo :: IdInfo -> Maybe IdInfo +zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) + | is_safe_occ occ && is_safe_dmd demand + = Nothing + | otherwise + = Just (info {occInfo = safe_occ, demandInfo = topDmd}) + where + -- The "unsafe" occ info is the ones that say I'm not in a lambda + -- because that might not be true for an unsaturated lambda + is_safe_occ occ | isAlwaysTailCalled occ = False + is_safe_occ (OneOcc { occ_in_lam = NotInsideLam }) = False + is_safe_occ _other = True + + safe_occ = case occ of + OneOcc{} -> occ { occ_in_lam = IsInsideLam + , occ_tail = NoTailCallInfo } + IAmALoopBreaker{} + -> occ { occ_tail = NoTailCallInfo } + _other -> occ + + is_safe_dmd dmd = not (isStrUsedDmd dmd) + +-- | Lazify (remove the top-level demand, only) the demand in `IdInfo` +-- Keep nested demands; see Note [Floatifying demand info when floating] +-- in GHC.Core.Opt.SetLevels +lazifyDemandInfo :: IdInfo -> Maybe IdInfo +lazifyDemandInfo info@(IdInfo { demandInfo = dmd }) + = Just (info {demandInfo = lazifyDmd dmd }) + +-- | Floatify the demand in `IdInfo` +-- But keep /nested/ demands; see Note [Floatifying demand info when floating] +-- in GHC.Core.Opt.SetLevels +floatifyDemandInfo :: IdInfo -> Maybe IdInfo +floatifyDemandInfo info@(IdInfo { demandInfo = dmd }) + = Just (info {demandInfo = floatifyDmd dmd }) + +-- | Remove usage (but not strictness) info on the `IdInfo` +zapUsageInfo :: IdInfo -> Maybe IdInfo +zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) + +-- | Remove usage environment info from the strictness signature on the 'IdInfo' +zapUsageEnvInfo :: IdInfo -> Maybe IdInfo +zapUsageEnvInfo info + | hasDemandEnvSig (dmdSigInfo info) + = Just (info {dmdSigInfo = zapDmdEnvSig (dmdSigInfo info)}) + | otherwise + = Nothing + +zapUsedOnceInfo :: IdInfo -> Maybe IdInfo +zapUsedOnceInfo info + = Just $ info { dmdSigInfo = zapUsedOnceSig (dmdSigInfo info) + , demandInfo = zapUsedOnceDemand (demandInfo info) } + +zapFragileInfo :: IdInfo -> Maybe IdInfo +-- ^ Zap info that depends on free variables +zapFragileInfo info@(IdInfo { occInfo = occ, realUnfoldingInfo = unf }) + = new_unf `seq` -- The unfolding field is not (currently) strict, so we + -- force it here to avoid a (zapFragileUnfolding unf) thunk + -- which might leak space + Just (info `setRuleInfo` emptyRuleInfo + `setUnfoldingInfo` new_unf + `setOccInfo` zapFragileOcc occ) + where + new_unf = zapFragileUnfolding unf + +zapFragileUnfolding :: Unfolding -> Unfolding +-- ^ Zaps any core unfolding, but /preserves/ evaluated-ness, +-- i.e. an unfolding of OtherCon +zapFragileUnfolding unf + -- N.B. isEvaldUnfolding catches *both* OtherCon [] *and* core unfoldings + -- representing values. + | isEvaldUnfolding unf = evaldUnfolding + | otherwise = noUnfolding + +trimUnfolding :: Unfolding -> Unfolding +-- Squash all unfolding info, preserving only evaluated-ness +trimUnfolding unf | isEvaldUnfolding unf = evaldUnfolding + | otherwise = noUnfolding + +zapTailCallInfo :: IdInfo -> Maybe IdInfo +zapTailCallInfo info + = case occInfo info of + occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ) + | otherwise -> Nothing + where + safe_occ = occ { occ_tail = NoTailCallInfo } + +zapCallArityInfo :: IdInfo -> IdInfo +zapCallArityInfo info = setCallArityInfo info 0 + +{- +************************************************************************ +* * +\subsection{TickBoxOp} +* * +************************************************************************ +-} + +type TickBoxId = Int + +-- | Tick box for Hpc-style coverage +data TickBoxOp + = TickBox Module {-# UNPACK #-} !TickBoxId + +instance Outputable TickBoxOp where + ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) diff --git a/GHC/Types/Id/Info.hs-boot b/GHC/Types/Id/Info.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/Id/Info.hs-boot @@ -0,0 +1,11 @@ +module GHC.Types.Id.Info where +import GHC.Prelude +import GHC.Utils.Outputable +data IdInfo +data IdDetails + +vanillaIdInfo :: IdInfo +coVarDetails :: IdDetails +isCoVarDetails :: IdDetails -> Bool +pprIdDetails :: IdDetails -> SDoc + diff --git a/GHC/Types/Id/Make.hs b/GHC/Types/Id/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Id/Make.hs @@ -0,0 +1,2495 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + + +This module contains definitions for the IdInfo for things that +have a standard form, namely: + +- data constructors +- record selectors +- method and superclass selectors +- primitive operations +-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE DataKinds #-} + +module GHC.Types.Id.Make ( + mkDictFunId, mkDictSelId, mkDictSelRhs, + + mkFCallId, + + wrapNewTypeBody, unwrapNewTypeBody, wrapFamInstBody, + DataConBoxer(..), vanillaDataConBoxer, + mkDataConRep, mkDataConWorkId, + DataConBangOpts (..), BangOpts (..), + unboxedUnitExpr, + + -- And some particular Ids; see below for why they are wired in + wiredInIds, ghcPrimIds, + realWorldPrimId, + voidPrimId, voidArgId, + nullAddrId, seqId, lazyId, lazyIdKey, + coercionTokenId, coerceId, + proxyHashId, + nospecId, nospecIdName, + noinlineId, noinlineIdName, + noinlineConstraintId, noinlineConstraintIdName, + coerceName, leftSectionName, rightSectionName, + pcRepPolyId, + + mkRepPolyIdConcreteTyVars, + ) where + +import GHC.Prelude + +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Builtin.Names + +import GHC.Core +import GHC.Core.Opt.Arity( typeOneShot ) +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.TyCo.Rep +import GHC.Core.FamInstEnv +import GHC.Core.Predicate( isUnaryClass ) +import GHC.Core.Coercion +import GHC.Core.Reduction +import GHC.Core.Make +import GHC.Core.FVs ( mkRuleInfo ) +import GHC.Core.Utils ( exprType, mkCast, coreAltsType ) +import GHC.Core.Unfold.Make +import GHC.Core.SimpleOpt +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Core.DataCon + +import GHC.Types.Literal +import GHC.Types.SourceText +import GHC.Types.RepType ( countFunRepArgs, typePrimRep ) +import GHC.Types.Name.Set +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.ForeignCall +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Unique.Supply +import GHC.Types.Basic hiding ( SuccessFlag(..) ) +import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike, tyVarName) + +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType as TcType + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.FastString +import GHC.Data.List.SetOps +import Data.List ( zipWith4 ) + +-- A bit of a shame we must import these here +import GHC.StgToCmm.Types (LambdaFormInfo(..)) +import GHC.Runtime.Heap.Layout (ArgDescr(ArgUnknown)) + +{- +************************************************************************ +* * +\subsection{Wired in Ids} +* * +************************************************************************ + +Note [Wired-in Ids] +~~~~~~~~~~~~~~~~~~~ +A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId') +rather than by looking it up its name in some environment or fetching +it from an interface file. + +There are several reasons why an Id might appear in the wiredInIds: + +* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)] + +* magicIds: see Note [magicIds] + +* errorIds, defined in GHC.Core.Make. + These error functions (e.g. rUNTIME_ERROR_ID) are wired in + because the desugarer generates code that mentions them directly + +In all cases except ghcPrimIds, there is a definition site in a +library module, which may be called (e.g. in higher order situations); +but the wired-in version means that the details are never read from +that module's interface file; instead, the full definition is right +here. + +Note [ghcPrimIds (aka pseudoops)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ghcPrimIds + + * Are exported from GHC.Prim (see ghcPrimExports, used in ghcPrimInterface) + See Note [GHC.Prim] in primops.txt.pp for the remaining items in GHC.Prim. + + * Can't be defined in Haskell, and hence no Haskell binding site, + but have perfectly reasonable unfoldings in Core + + * Either have a CompulsoryUnfolding (hence always inlined), or + of an EvaldUnfolding and void representation (e.g. realWorldPrimId) + + * Are (or should be) defined in primops.txt.pp as 'pseudoop' + Reason: that's how we generate documentation for them + +Note [magicIds] +~~~~~~~~~~~~~~~ +The magicIds + + * Are exported from GHC.Magic + + * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs). + This definition at least generates Haddock documentation for them. + + * May or may not have a CompulsoryUnfolding. + + * But have some special behaviour that can't be done via an + unfolding from an interface file. + + * May have IdInfo that differs from what would be imported from GHC.Magic.hi. + For example, 'lazy' gets a lazy strictness signature, per Note [lazyId magic]. + + The two remaining identifiers in GHC.Magic, runRW# and inline, are not + listed in magicIds: they have special behavior but they can be known-key and + not wired-in. + Similarly for GHC.Internal.IO.seq# and GHC.Internal.Exts.considerAccessible. + runRW#: see Note [Simplification of runRW#] in Prep, + runRW# code in Simplifier, Note [Linting of runRW#]. + seq#: see Note [seq# magic] + inline: see Note [inlineId magic] + considerAccessible: see Note [considerAccessible] +-} + +wiredInIds :: [Id] +wiredInIds + = magicIds + ++ ghcPrimIds + ++ errorIds -- Defined in GHC.Core.Make + +magicIds :: [Id] -- See Note [magicIds] +magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId] + +ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] +ghcPrimIds + = [ realWorldPrimId + , voidPrimId + , nullAddrId + , seqId + , coerceId + , proxyHashId + , leftSectionId + , rightSectionId + ] + +{- +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ + +The wrapper for a constructor is an ordinary top-level binding that evaluates +any strict args, unboxes any args that are going to be flattened, and calls +the worker. + +We're going to build a constructor that looks like: + + data (Data a, C b) => T a b = T1 !a !Int b + + T1 = /\ a b -> + \d1::Data a, d2::C b -> + \p q r -> case p of { p -> + case q of { q -> + Con T1 [a,b] [p,q,r]}} + +Notice that + +* d2 is thrown away --- a context in a data decl is used to make sure + one *could* construct dictionaries at the site the constructor + is used, but the dictionary isn't actually used. + +* We have to check that we can construct Data dictionaries for + the types a and Int. Once we've done that we can throw d1 away too. + +* We use (case p of q -> ...) to evaluate p, rather than "seq" because + all that matters is that the arguments are evaluated. "seq" is + very careful to preserve evaluation order, which we don't need + to be here. + + You might think that we could simply give constructors some strictness + info, like PrimOps, and let CoreToStg do the let-to-case transformation. + But we don't do that because in the case of primops and functions strictness + is a *property* not a *requirement*. In the case of constructors we need to + do something active to evaluate the argument. + + Making an explicit case expression allows the simplifier to eliminate + it in the (common) case where the constructor arg is already evaluated. + +Note [Wrappers for data instance tycons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of data instances, the wrapper also applies the coercion turning +the representation type into the family instance type to cast the result of +the wrapper. For example, consider the declarations + + data family Map k :: * -> * + data instance Map (a, b) v = MapPair (Map a (Pair b v)) + +The tycon to which the datacon MapPair belongs gets a unique internal +name of the form :R123Map, and we call it the representation tycon. +In contrast, Map is the family tycon (accessible via +tyConFamInst_maybe). A coercion allows you to move between +representation and family type. It is accessible from :R123Map via +tyConFamilyCoercion_maybe and has kind + + Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} + +The wrapper and worker of MapPair get the types + + -- Wrapper + $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v + $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) + + -- Worker + MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + +This coercion is conditionally applied by wrapFamInstBody. + +It's a bit more complicated if the data instance is a GADT as well! + + data instance T [a] where + T1 :: forall b. b -> T [Maybe b] + +Hence we translate to + + -- Wrapper + $WT1 :: forall b. b -> T [Maybe b] + $WT1 b v = T1 (Maybe b) b (Maybe b) v + `cast` sym (Co7T (Maybe b)) + + -- Worker + T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c + + -- Coercion from family type to representation type + Co7T a :: T [a] ~ :R7T a + +Newtype instances through an additional wrinkle into the mix. Consider the +following example (adapted from #15318, comment:2): + + data family T a + newtype instance T [a] = MkT [a] + +Within the newtype instance, there are three distinct types at play: + +1. The newtype's underlying type, [a]. +2. The instance's representation type, TList a (where TList is the + representation tycon). +3. The family type, T [a]. + +We need two coercions in order to cast from (1) to (3): + +(a) A newtype coercion axiom: + + axiom coTList a :: TList a ~ [a] + + (Where TList is the representation tycon of the newtype instance.) + +(b) A data family instance coercion axiom: + + axiom coT a :: T [a] ~ TList a + +When we translate the newtype instance to Core, we obtain: + + -- Wrapper + $WMkT :: forall a. [a] -> T [a] + $WMkT a x = MkT a x |> Sym (coT a) + + -- Worker + MkT :: forall a. [a] -> TList [a] + MkT a x = x |> Sym (coTList a) + +Unlike for data instances, the worker for a newtype instance is actually an +executable function which expands to a cast, but otherwise, the general +strategy is essentially the same as for data instances. Also note that we have +a wrapper, which is unusual for a newtype, but we make GHC produce one anyway +for symmetry with the way data instances are handled. + +Note [Newtype datacons] +~~~~~~~~~~~~~~~~~~~~~~~ +The "data constructor" for a newtype should have no existentials. It's +not quite a "vanilla" data constructor, because the newtype arising from + class C a => D a +looks like + newtype T:D a = C:D (C a) +so the data constructor for T:C has a single argument, namely the +predicate (C a). That ends up in the dcOtherTheta for the data con, +which makes it not vanilla. So the assert just tests for existentials. +The rest is checked by having a singleton arg_tys. + +Note [Newtype workers] +~~~~~~~~~~~~~~~~~~~~~~ +A newtype does not really have a worker. Instead, newtype constructors +just unfold into a cast. But we need *something* for, say, MkAge to refer +to. So, we do this: + +* The Id used as the newtype worker will have a compulsory unfolding to + a cast. See Note [Compulsory newtype unfolding] + +* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId, + as those have special treatment in the back end. + +* There is no top-level binding, because the compulsory unfolding + means that it will be inlined (to a cast) at every call site. + +We probably should have a NewtypeWorkId, but these Ids disappear as soon as +we desugar anyway, so it seems a step too far. + +Note [Compulsory newtype unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Newtype wrappers, just like workers, have compulsory unfoldings. +This is needed so that two optimizations involving newtypes have the same +effect whether a wrapper is present or not: + +(1) Case-of-known constructor. + See Note [beta-reduction in exprIsConApp_maybe]. + +(2) Matching against the map/coerce RULE. Suppose we have the RULE + + {-# RULE "map/coerce" map coerce = ... #-} + + As described in Note [Getting the map/coerce RULE to work], + the occurrence of 'coerce' is transformed into: + + {-# RULE "map/coerce" forall (c :: T1 ~R# T2). + map ((\v -> v) `cast` c) = ... #-} + + We'd like 'map Age' to match the LHS. For this to happen, Age + must be unfolded, otherwise we'll be stuck. This is tested in T16208. + +It also allows for the possibility of representation-polymorphic newtypes +with wrappers (with -XUnliftedNewtypes): + + newtype N (a :: TYPE r) = MkN a + +With -XUnliftedNewtypes, this is allowed -- even though MkN is representation- +polymorphic. It's OK because MkN evaporates in the compiled code, becoming +just a cast. That is, it has a compulsory unfolding. As long as its +argument is not representation-polymorphic (which it can't be, according to +Note [Representation polymorphism invariants] in GHC.Core), and it's saturated, +no representation-polymorphic code ends up in the code generator. +The saturation condition is effectively checked in +GHC.Tc.Gen.Head.rejectRepPolyNewtypes. + +However, if we make a *wrapper* for a newtype, we get into trouble. +In that case, we generate a forbidden representation-polymorphic +binding, and we must then ensure that it is always instantiated +at a representation-monomorphic type. + +The solution is simple, though: just make the newtype wrappers +as ephemeral as the newtype workers. In other words, give the wrappers +compulsory unfoldings and no bindings. The compulsory unfolding is given +in wrap_unf in mkDataConRep, and the lack of a binding happens in +GHC.Iface.Tidy.getTyConImplicitBinds, where we say that a newtype has no +implicit bindings. + +Note [Records and linear types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All the fields, in a record constructor, are linear, because there is no syntax +to specify the type of record field. There will be (see the proposal +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst#records-and-projections +), but it isn't implemented yet. + +Projections of records can't be linear: + + data Foo = MkFoo { a :: A, b :: B } + +If we had + + a :: Foo %1 -> A + +We could write + + bad :: A %1 -> B %1 -> A + bad x y = a (MkFoo { a=x, b=y }) + +There is an exception: if `b` (more generally all the fields besides `a`) is +unrestricted, then is perfectly possible to have a linear projection. Such a +linear projection has as simple definition. + + data Bar = MkBar { c :: C, d % Many :: D } + + c :: Bar %1 -> C + c MkBar{ c=x, d=_} = x + +The `% Many` syntax, for records, does not exist yet. But there is one important +special case which already happens: when there is a single field (usually a +newtype). + + newtype Baz = MkBaz { unbaz :: E } + +unbaz could be linear. And, in fact, it is linear in the proposal design. + +However, this hasn't been implemented yet. + +************************************************************************ +* * +\subsection{Dictionary selectors} +* * +************************************************************************ + +Selecting a field for a dictionary. If there is just one field, then +there's nothing to do. + +Dictionary selectors may get nested forall-types. Thus: + + class Foo a where + op :: forall b. Ord b => a -> b -> b + +Then the top-level type for op is + + op :: forall a. Foo a => + forall b. Ord b => + a -> b -> b + +Note [Type classes and linear types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Constraints, in particular type classes, don't have attached linearity +information. Implicitly, they are all unrestricted. See the linear types proposal, +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst . + +When translating to core `C => ...` is always translated to an unrestricted +arrow `C % Many -> ...`. + +Therefore there is no loss of generality if we make all selectors unrestricted. + +-} + +mkDictSelId :: Name -- Name of one of the *value* selectors + -- (dictionary superclass or method) + -> Class -> Id +-- Important: see Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance +mkDictSelId name clas + = mkGlobalId (ClassOpId clas terminating) name sel_ty info + where + tycon = classTyCon clas + sel_names = map idName (classAllSelIds clas) + [data_con] = tyConDataCons tycon + tyvars = dataConUserTyVarBinders data_con + n_ty_args = length tyvars + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name + + pred_ty = mkClassPred clas (mkTyVarTys (binderVars tyvars)) + res_ty = scaledThing (getNth arg_tys val_index) + sel_ty = mkForAllTys tyvars $ + mkFunctionType ManyTy pred_ty res_ty + -- See Note [Type classes and linear types] + + terminating = isTerminatingType res_ty || definitelyUnliftedType res_ty + -- If the field is unlifted, it can't be bottom + -- Ditto if it's a terminating type + + base_info = noCafIdInfo + `setArityInfo` 1 + `setDmdSigInfo` strict_sig + `setCprSigInfo` topCprSig + + info = base_info `setRuleInfo` mkRuleInfo [rule] + -- No unfolding for a dictionary selector; the RULE does the work, + -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance + + -- This is the built-in rule that goes + -- op (dfT d1 d2) ---> opT d1 d2 + rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` + occNameFS (getOccName name) + , ru_fn = name + , ru_nargs = n_ty_args + 1 + , ru_try = dictSelRule val_index n_ty_args } + + -- The strictness signature is of the form U(AAAVAAAA) -> T + -- where the V depends on which item we are selecting + -- It's worth giving one, so that absence info etc is generated + -- even if the selector isn't inlined, which of course it isn't! + + strict_sig = mkClosedDmdSig [arg_dmd] topDiv + arg_dmd = C_1N :* mkProd Unboxed dict_field_dmds + where + -- The evalDmd below is just a placeholder and will be replaced in + -- GHC.Types.Demand.dmdTransformDictSel + dict_field_dmds = [ if name == sel_name then evalDmd else absDmd + | sel_name <- sel_names ] + +mkDictSelRhs :: Class + -> Int -- 0-indexed selector among (superclasses ++ methods) + -> CoreExpr +-- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance +mkDictSelRhs clas val_index + = mkLams tyvars (Lam dict_id rhs_body) + where + tycon = classTyCon clas + [data_con] = tyConDataCons tycon + tyvars = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + + the_arg_id = getNth arg_ids val_index + pred = mkClassPred clas (mkTyVarTys tyvars) + dict_id = mkTemplateLocal 1 pred + arg_ids = mkTemplateLocalsNum 2 (map scaledThing arg_tys) + + rhs_body | isUnaryClass clas -- Just having one sel_id isn't enough! + -- E.g. class (a ~# b) => a ~ b where {} + , let sel_ids = classAllSelIds clas + = assertPpr (val_index == 0) (ppr clas) $ + assertPpr (length sel_ids == 1) (ppr clas) $ + Var (head sel_ids) `mkTyApps` mkTyVarTys tyvars `App` Var dict_id + | otherwise + = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con) + arg_ids (varToCoreExpr the_arg_id) + -- varToCoreExpr needed for equality superclass selectors + -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } + +dictSelRule :: Int -> Arity -> RuleFun +-- Tries to persuade the argument to look like a constructor +-- application, using exprIsConApp_maybe, and then selects +-- from it +-- sel_i t1..tk (D t1..tk op1 ... opm) = opi +-- +-- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance +dictSelRule val_index n_ty_args _ in_scope_env _ args + | (dict_arg : _) <- drop n_ty_args args + , Just (_, floats, _, _, con_args) + <- exprIsConApp_maybe in_scope_env dict_arg + = Just (wrapFloats floats $ getNth con_args val_index) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Data constructors +* * +************************************************************************ +-} + +mkDataConWorkId :: Name -> DataCon -> Id +mkDataConWorkId wkr_name data_con + | isNewTyCon tycon -- See Note [Newtype workers] + = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_info + + | otherwise + = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info + + where + tycon = dataConTyCon data_con -- The representation TyCon + wkr_ty = dataConRepType data_con + univ_tvs = dataConUnivTyVars data_con + ex_tcvs = dataConExTyCoVars data_con + arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys + str_marks = dataConRepStrictness data_con + + ----------- Workers for data types -------------- + alg_wkr_info = noCafIdInfo + `setArityInfo` wkr_arity + `setInlinePragInfo` wkr_inline_prag + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + -- even if arity = 0 + `setDmdSigInfo` wkr_sig + -- Workers eval their strict fields + -- See Note [Strict fields in Core] + `setLFInfo` wkr_lf_info + + wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike } + wkr_arity = dataConRepArity data_con + + wkr_sig = mkClosedDmdSig wkr_dmds topDiv + wkr_dmds = map mk_dmd str_marks + mk_dmd MarkedStrict = evalDmd + mk_dmd NotMarkedStrict = topDmd + + -- See Note [LFInfo of DataCon workers and wrappers] + wkr_lf_info + | wkr_arity == 0 = LFCon data_con + | otherwise = LFReEntrant TopLevel (countFunRepArgs wkr_arity wkr_ty) True ArgUnknown + -- LFInfo stores post-unarisation arity + + ----------- Workers for newtypes -------------- + nt_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` 1 -- Arity 1 + `setInlinePragInfo` dataConWrapperInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding newtype_rhs + `setLFInfo` (panic "mkDataConWorkId: no LFInfo for newtype worker ids") + -- See W1 in Note [LFInfo of DataCon workers and wrappers] + + id_arg1 = mkScaledTemplateLocal 1 (head arg_tys) + res_ty_args = mkTyCoVarTys univ_tvs + newtype_rhs = assertPpr (null ex_tcvs && isSingleton arg_tys) (ppr data_con) $ + -- Note [Newtype datacons] + mkLams univ_tvs $ Lam id_arg1 $ + wrapNewTypeBody tycon res_ty_args (Var id_arg1) + +{- +Note [LFInfo of DataCon workers and wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure, it's +crucial that saturated data con applications are given an LFInfo of `LFCon`. + +Since for data constructors we never serialise the worker and the wrapper (only +the data type declaration), we never serialise their lambda form info either. + +Therefore, when making data constructors workers and wrappers, we construct a +correct `LFInfo` for them right away, and put it it in the `lfInfo` field of the +worker/wrapper Id, ensuring that: + + The `lfInfo` field of a DataCon worker or wrapper is always populated with the correct LFInfo. + +How do we construct a /correct/ LFInfo for workers and wrappers? +(Remember: `LFCon` means "a saturated constructor application") + +(1) Data constructor workers and wrappers with arity > 0 are unambiguously + functions and should be given `LFReEntrant`, regardless of the runtime + relevance of the arguments. For example: + `Just :: a -> Maybe a` is given `LFReEntrant`, + `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too. + +(2) A datacon /worker/ with zero arity is trivially fully saturated -- it takes + no arguments whatsoever (not even zero-width args), so it is given `LFCon`. + +(3) Perhaps surprisingly, a datacon /wrapper/ can be an `LFCon`. See Wrinkle (W1) below. + A datacon /wrapper/ with zero arity must be a fully saturated application of + the worker to zero-width arguments only (which are dropped after unarisation), + and therefore is also given `LFCon`. + +For example, consider the following data constructors: + + data T1 a where + TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a + + data T2 a where + TCon2 :: {-# UNPACK #-} !() -> T2 a + + data T3 a where + TCon3 :: T3 '[] + +`TCon1`'s wrapper has a lifted argument, which is non-zero-width, while the +worker has an unlifted equality argument, which is zero-width. + +`TCon2`'s wrapper has a lifted argument, which is non-zero-width, while the +worker has no arguments. + +Wrinkle (W1). Perhaps surprisingly, it is possible for the /wrapper/ to be an +`LFCon` even though the /worker/ is not. Consider `T3` above. Here is the +Core representation of the worker and wrapper: + + $WTCon3 :: T3 '[] -- Wrapper + $WTCon3 = TCon3 @[] -- A saturated constructor application: LFCon + + TCon3 :: forall (a :: * -> *). (a ~# []) => T a -- Worker + TCon3 = /\a. \(co :: a~#[]). TCon3 co -- A function: LFReEntrant + +For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they +both have arity == 1. + +For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1 +while the worker is `LFCon` since its arity == 0 + +For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the +worker `LFReEntrant` since its arity == 1 + +One might think we could give *workers* with only zero-width-args the `LFCon` +LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`. +However, these workers are unambiguously functions +-- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct. +See also the discussion in #23158. + +Wrinkles: + +(W1) Why do we panic when generating `LFInfo` for newtype workers and wrappers? + + We don't generate code for newtype workers/wrappers, so we should never have to + look at their LFInfo (and in general we can't; they may be representation-polymorphic). + +See also the Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] +in GHC.StgToCmm.Types. + +------------------------------------------------- +-- Data constructor representation +-- +-- This is where we decide how to wrap/unwrap the +-- constructor fields +-- +-------------------------------------------------- +-} + +type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) + -- Unbox: bind rep vars by decomposing src var + +data Boxer = UnitBox | Boxer (Subst -> UniqSM ([Var], CoreExpr)) + -- Box: build src arg using these rep vars + +-- | Data Constructor Boxer +newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) + -- Bind these src-level vars, returning the + -- rep-level vars to bind in the pattern + +vanillaDataConBoxer :: DataConBoxer +-- No transformation on arguments needed +vanillaDataConBoxer = DCB (\_tys args -> return (args, [])) + +{- +Note [Inline partially-applied constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We allow the wrapper to inline when partially applied to avoid +boxing values unnecessarily. For example, consider + + data Foo a = Foo !Int a + + instance Traversable Foo where + traverse f (Foo i a) = Foo i <$> f a + +This desugars to + + traverse f foo = case foo of + Foo i# a -> let i = I# i# + in map ($WFoo i) (f a) + +If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`. +But if we inline the wrapper, we get + + map (\a. case i of I# i# a -> Foo i# a) (f a) + +and now case-of-known-constructor eliminates the redundant allocation. + +-} + +data DataConBangOpts + = FixedBangOpts [HsImplBang] + -- ^ Used for imported data constructors + -- See Note [Bangs on imported data constructors] + | SrcBangOpts !BangOpts + +data BangOpts = BangOpts + { bang_opt_strict_data :: !Bool -- ^ Strict fields by default + , bang_opt_unbox_disable :: !Bool -- ^ Disable automatic field unboxing (e.g. if we aren't optimising) + , bang_opt_unbox_strict :: !Bool -- ^ Unbox strict fields + , bang_opt_unbox_small :: !Bool -- ^ Unbox small strict fields + } + +mkDataConRep :: DataConBangOpts + -> FamInstEnvs + -> Name + -> DataCon + -> UniqSM (DataConRep, [HsImplBang], [StrictnessMark]) +mkDataConRep dc_bang_opts fam_envs wrap_name data_con + | not wrapper_reqd + = return (NoDataConRep, arg_ibangs, rep_strs) + + | otherwise + = do { wrap_args <- mapM (newLocal (fsLit "conrep")) wrap_arg_tys + ; wrap_body <- mk_rep_app (dropList stupid_theta wrap_args `zip` dropList eq_spec unboxers) + initial_wrap_app + -- Drop the stupid theta arguments, as per + -- Note [Instantiating stupid theta] in GHC.Core.DataCon. + + ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info + wrap_info = noCafIdInfo + `setArityInfo` wrap_arity + -- It's important to specify the arity, so that partial + -- applications are treated as values + `setInlinePragInfo` wrap_prag + `setUnfoldingInfo` wrap_unf + `setDmdSigInfo` wrap_sig + -- We need to get the CAF info right here because GHC.Iface.Tidy + -- does not tidy the IdInfo of implicit bindings (like the wrapper) + -- so it not make sure that the CAF info is sane + `setLFInfo` wrap_lf_info + + -- The signature is purely for passes like the Simplifier, not for + -- DmdAnal itself; see Note [DmdAnal for DataCon wrappers]. + wrap_sig = mkClosedDmdSig wrap_arg_dmds topDiv + + -- See Note [LFInfo of DataCon workers and wrappers] + wrap_lf_info + | wrap_arity == 0 = LFCon data_con + -- See W1 in Note [LFInfo of DataCon workers and wrappers] + | isNewTyCon tycon = panic "mkDataConRep: we shouldn't look at LFInfo for newtype wrapper ids" + | otherwise = LFReEntrant TopLevel (countFunRepArgs wrap_arity wrap_ty) True ArgUnknown + -- LFInfo stores post-unarisation arity + + wrap_arg_dmds = + replicate (length theta) topDmd ++ map mk_dmd arg_ibangs + -- Don't forget the dictionary arguments when building + -- the strictness signature (#14290). + + mk_dmd str | isBanged str = evalDmd + | otherwise = topDmd + + wrap_prag = dataConWrapperInlinePragma + `setInlinePragmaActivation` activateDuringFinal + -- See Note [Activation for data constructor wrappers] + + -- The wrapper will usually be inlined (see wrap_unf), so its + -- strictness and CPR info is usually irrelevant. But this is + -- not always the case; GHC may choose not to inline it. In + -- particular, the wrapper constructor is not inlined inside + -- an INLINE rhs or when it is not applied to any arguments. + -- See Note [Inline partially-applied constructor wrappers] + -- Passing Nothing here allows the wrapper to inline when + -- unsaturated. + wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs + -- See Note [Compulsory newtype unfolding] + | otherwise = mkDataConUnfolding wrap_rhs + wrap_rhs = mkCoreTyLams wrap_tvbs $ + mkCoreLams wrap_args $ + wrapFamInstBody tycon res_ty_args $ + wrap_body + + ; return (DCR { dcr_wrap_id = wrap_id + , dcr_boxer = mk_boxer boxers + , dcr_arg_tys = rep_tys } + , arg_ibangs, rep_strs) } + + where + (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) + = dataConFullSig data_con + stupid_theta = dataConStupidTheta data_con + wrap_tvbs = dataConUserTyVarBinders data_con + res_ty_args = dataConResRepTyArgs data_con + + tycon = dataConTyCon data_con -- The representation TyCon (not family) + wrap_ty = dataConWrapperType data_con + ev_tys = eqSpecPreds eq_spec ++ theta + all_arg_tys = map unrestricted ev_tys ++ orig_arg_tys + ev_ibangs = map (const HsLazy) ev_tys + orig_bangs = dataConSrcBangs data_con + + wrap_arg_tys = (map unrestricted $ stupid_theta ++ theta) ++ orig_arg_tys + wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys + -- The wrap_args are the arguments *other than* the eq_spec + -- Because we are going to apply the eq_spec args manually in the + -- wrapper + + new_tycon = isNewTyCon tycon + arg_ibangs + | new_tycon + = map (const HsLazy) orig_arg_tys -- See Note [HsImplBangs for newtypes] + -- orig_arg_tys should be a singleton, but + -- if a user declared a wrong newtype we + -- detect this later (see test T2334A) + | otherwise + = case dc_bang_opts of + SrcBangOpts bang_opts -> zipWith (dataConSrcToImplBang bang_opts fam_envs) + orig_arg_tys orig_bangs + FixedBangOpts bangs -> bangs + + (rep_tys_w_strs, wrappers) + = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs)) + + (unboxers, boxers) = unzip wrappers + (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) + + -- This is True if the data constructor or class dictionary constructor + -- needs a wrapper. This wrapper is injected into the program later in the + -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy, + -- along with the accompanying implementation in getTyConImplicitBinds. + wrapper_reqd + | isTypeDataTyCon tycon + -- `type data` declarations never have data-constructor wrappers + -- Their data constructors only live at the type level, in the + -- form of PromotedDataCon, and therefore do not need wrappers. + -- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module. + = False + + | isUnaryClassTyCon tycon -- See (UCM8) in Note [Unary class magic] + = False -- in GHC.Core.TyCon + + | otherwise + = (not new_tycon + -- (Most) newtypes have only a worker, with the exception + -- of some newtypes written with GADT syntax. + -- See dataConUserTyVarsNeedWrapper below. + && (any isUnpacked (ev_ibangs ++ arg_ibangs))) + -- Some unboxing (includes eq_spec) + + || isFamInstTyCon tycon -- Cast result + + || dataConUserTyVarBindersNeedWrapper data_con + -- If the data type was written with GADT syntax and + -- orders the type variables differently from what the + -- worker expects, it needs a data con wrapper to reorder + -- the type variables. + -- See Note [Data con wrappers and GADT syntax]. + -- + -- NB: All GADTs return true from this function, but there + -- is one exception that we must check below. + + || not (null stupid_theta) + -- If the data constructor has a datatype context, + -- we need a wrapper in order to drop the stupid arguments. + -- See Note [Instantiating stupid theta] in GHC.Core.DataCon. + + initial_wrap_app = Var (dataConWorkId data_con) + `mkTyApps` res_ty_args + `mkVarApps` ex_tvs + `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec + + mk_boxer :: [Boxer] -> DataConBoxer + mk_boxer boxers = DCB (\ ty_args src_vars -> + do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars + subst1 = zipTvSubst univ_tvs ty_args + subst2 = foldl2 extendTvSubstWithClone subst1 ex_tvs ex_vars + ; (rep_ids, binds) <- go subst2 boxers term_vars + ; return (ex_vars ++ rep_ids, binds) } ) + + go _ [] src_vars = assertPpr (null src_vars) (ppr data_con) $ return ([], []) + go subst (UnitBox : boxers) (src_var : src_vars) + = do { (rep_ids2, binds) <- go subst boxers src_vars + ; return (src_var : rep_ids2, binds) } + go subst (Boxer boxer : boxers) (src_var : src_vars) + = do { (rep_ids1, arg) <- boxer subst + ; (rep_ids2, binds) <- go subst boxers src_vars + ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } + go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) + + mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr + mk_rep_app [] con_app + = return con_app + mk_rep_app ((wrap_arg, unboxer) : prs) con_app + = do { (rep_ids, unbox_fn) <- unboxer wrap_arg + ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) + ; return (unbox_fn expr) } + + +dataConWrapperInlinePragma :: InlinePragma +-- See Note [DataCon wrappers are conlike] +dataConWrapperInlinePragma = alwaysInlineConLikePragma + +{- Note [Activation for data constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Activation on a data constructor wrapper allows it to inline only in FinalPhase. +This way rules have a chance to fire if they mention a data constructor on +the left + RULE "foo" f (K a b) = ... +Since the LHS of rules are simplified with InitialPhase, we won't +inline the wrapper on the LHS either. + +On the other hand, this means that exprIsConApp_maybe must be able to deal +with wrappers so that case-of-constructor is not delayed; see +Note [exprIsConApp_maybe on data constructors with wrappers] for details. + +It used to activate in phases 2 (afterInitial) and later, but it makes it +awkward to write a RULE[1] with a constructor on the left: it would work if a +constructor has no wrapper, but whether a constructor has a wrapper depends, for +instance, on the order of type argument of that constructors. Therefore changing +the order of type argument could make previously working RULEs fail. + +See also https://gitlab.haskell.org/ghc/ghc/issues/15840 . + +Note [DataCon wrappers are conlike] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DataCon workers are clearly ConLike --- they are the “Con” in +“ConLike”, after all --- but what about DataCon wrappers? Should they +be marked ConLike, too? + +Yes, absolutely! As described in Note [CONLIKE pragma] in +GHC.Types.Basic, isConLike influences GHC.Core.Utils.exprIsExpandable, +which is used by both RULE matching and the case-of-known-constructor +optimization. It’s crucial that both of those things can see +applications of DataCon wrappers: + + * User-defined RULEs match on wrappers, not workers, so we might + need to look through an unfolding built from a DataCon wrapper to + determine if a RULE matches. + + * Likewise, if we have something like + let x = $WC a b in ... case x of { C y z -> e } ... + we still want to apply case-of-known-constructor. + +Therefore, it’s important that we consider DataCon wrappers conlike. +This is especially true now that we don’t inline DataCon wrappers +until the final simplifier phase; see Note [Activation for data +constructor wrappers]. + +For further reading, see: + * Note [Conlike is interesting] in GHC.Core.Op.Simplify.Utils + * Note [Lone variables] in GHC.Core.Unfold + * Note [exprIsConApp_maybe on data constructors with wrappers] + in GHC.Core.SimpleOpt + * #18012 + +Note [Bangs on imported data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs +from imported modules. + +- Nothing <=> use HsSrcBangs +- Just bangs <=> use HsImplBangs + +For imported types we can't work it all out from the HsSrcBangs, +because we want to be very sure to follow what the original module +(where the data type was declared) decided, and that depends on what +flags were enabled when it was compiled. So we record the decisions in +the interface file. + +The HsImplBangs passed are in 1-1 correspondence with the +dataConOrigArgTys of the DataCon. + +Note [Data con wrappers and unlifted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Int# + +We certainly do not want to make a wrapper + $WMkT x = case x of y { DEFAULT -> MkT y } + +For a start, it's still to generate a no-op. But worse, since wrappers +are currently injected at TidyCore, we don't even optimise it away! +So the stupid case expression stays there. This actually happened for +the Integer data type (see #1600 comment:66)! + +Note [Data con wrappers and GADT syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two very similar data types: + + data T1 a b = MkT1 b + + data T2 a b where + MkT2 :: forall b a. b -> T2 a b + +Despite their similar appearance, T2 will have a data con wrapper but T1 will +not. What sets them apart? The types of their constructors, which are: + + MkT1 :: forall a b. b -> T1 a b + MkT2 :: forall b a. b -> T2 a b + +MkT2's use of GADT syntax allows it to permute the order in which `a` and `b` +would normally appear. See Note [DataCon user type variable binders] in GHC.Core.DataCon +for further discussion on this topic. + +The worker data cons for T1 and T2, however, both have types such that `a` is +expected to come before `b` as arguments. Because MkT2 permutes this order, it +needs a data con wrapper to swizzle around the type variables to be in the +order the worker expects. + +A somewhat surprising consequence of this is that *newtypes* can have data con +wrappers! After all, a newtype can also be written with GADT syntax: + + newtype T3 a b where + MkT3 :: forall b a. b -> T3 a b + +Again, this needs a wrapper data con to reorder the type variables. It does +mean that this newtype constructor requires another level of indirection when +being called, but the inliner should make swift work of that. + +Note [HsImplBangs for newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the time, we use the dataConSrctoImplBang function to decide what +strictness/unpackedness to use for the fields of a data type constructor. But +there is an exception to this rule: newtype constructors. You might not think +that newtypes would pose a challenge, since newtypes are seemingly forbidden +from having strictness annotations in the first place. But consider this +(from #16141): + + {-# LANGUAGE StrictData #-} + {-# OPTIONS_GHC -O #-} + newtype T a b where + MkT :: forall b a. Int -> T a b + +Because StrictData (plus optimization) is enabled, invoking +dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#! +This would be disastrous, since the wrapper for `MkT` uses a coercion involving +Int, not Int#. + +Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the +case of a newtype constructor, we simply hardcode its dcr_bangs field to +[HsLazy]. +-} + +------------------------- + +-- | Conjure a fresh local binder. +newLocal :: FastString -- ^ a string which will form part of the 'Var'\'s name + -> Scaled Type -- ^ the type of the 'Var' + -> UniqSM Var +newLocal name_stem (Scaled w ty) = + mkSysLocalOrCoVarM name_stem w ty + -- We should not have "OrCoVar" here, this is a bug (#17545) + + +-- | Unpack/Strictness decisions from source module. +-- +-- This function should only ever be invoked for data constructor fields, and +-- never on the field of a newtype constructor. +-- See @Note [HsImplBangs for newtypes]@. +dataConSrcToImplBang + :: BangOpts + -> FamInstEnvs + -> Scaled Type + -> HsSrcBang + -> HsImplBang + +dataConSrcToImplBang bang_opts fam_envs arg_ty + (HsSrcBang ann unpk NoSrcStrict) + | bang_opt_strict_data bang_opts -- StrictData => strict field + = dataConSrcToImplBang bang_opts fam_envs arg_ty + (HsSrcBang ann unpk SrcStrict) + | otherwise -- no StrictData => lazy field + = HsLazy + +dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) + = HsLazy + +dataConSrcToImplBang bang_opts fam_envs arg_ty + (HsSrcBang _ unpk_prag SrcStrict) + | isUnliftedType (scaledThing arg_ty) + -- NB: non-newtype data constructors can't have representation-polymorphic fields + -- so this is OK. + = HsLazy -- For !Int#, say, use HsLazy + -- See Note [Data con wrappers and unlifted types] + + | let mb_co = topNormaliseType_maybe fam_envs (scaledThing arg_ty) + -- Unwrap type families and newtypes + arg_ty' = case mb_co of + { Just redn -> scaledSet arg_ty (reductionReducedType redn) + ; Nothing -> arg_ty } + , shouldUnpackArgTy bang_opts unpk_prag fam_envs arg_ty' + = if bang_opt_unbox_disable bang_opts + then HsStrict True -- Not unpacking because of -O0 + -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon + else case mb_co of + Nothing -> HsUnpack Nothing + Just redn -> HsUnpack (Just $ reductionCoercion redn) + + | otherwise -- Record the strict-but-no-unpack decision + = HsStrict False + +-- | Wrappers/Workers and representation following Unpack/Strictness +-- decisions +dataConArgRep + :: Scaled Type + -> HsImplBang + -> ([(Scaled Type,StrictnessMark)] -- Rep types + ,(Unboxer,Boxer)) + +dataConArgRep arg_ty HsLazy + = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) + +dataConArgRep arg_ty (HsStrict _) + = ([(arg_ty, MarkedStrict)], (unitUnboxer, unitBoxer)) -- Seqs are inserted in STG + +dataConArgRep arg_ty (HsUnpack Nothing) + = dataConArgUnpack arg_ty + +dataConArgRep (Scaled w _) (HsUnpack (Just co)) + | let co_rep_ty = coercionRKind co + , (rep_tys, wrappers) <- dataConArgUnpack (Scaled w co_rep_ty) + = (rep_tys, wrapCo co co_rep_ty wrappers) + + +------------------------- +wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) +wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty + = (unboxer, boxer) + where + unboxer arg_id = do { rep_id <- newLocal (fsLit "cowrap_unbx") (Scaled (idMult arg_id) rep_ty) + ; (rep_ids, rep_fn) <- unbox_rep rep_id + ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) + ; return (rep_ids, Let co_bind . rep_fn) } + boxer = Boxer $ \ subst -> + do { (rep_ids, rep_expr) + <- case box_rep of + UnitBox -> do { rep_id <- newLocal (fsLit "cowrap_bx") (linear $ TcType.substTy subst rep_ty) + ; return ([rep_id], Var rep_id) } + Boxer boxer -> boxer subst + ; let sco = substCoUnchecked subst co + ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } + +------------------------ +unitUnboxer :: Unboxer +unitUnboxer v = return ([v], \e -> e) + +unitBoxer :: Boxer +unitBoxer = UnitBox + +------------------------- + +{- Note [UNPACK for sum types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a data type D, for example: + data D = D1 [Int] [Bool] + | D2 + +and another data type which unpacks a field of type D: + data U a = MkU {-# UNPACK #-} !D + {-# UNPACK #-} !(a,a) + {-# UNPACK #-} !D + +Then the wrapper and worker for MkU have these types + + -- Wrapper + $WMkU :: D -> (a,a) -> D -> U a + + -- Worker + MkU :: (# (# [Int],[Bool] #) | (# #) #) + -> a + -> a + -> (# (# [Int],[Bool] #) | (# #) #) + -> U a + +For each unpacked /sum/-type argument, the worker gets one argument. +But for each unpacked /product/-type argument, the worker gets N +arguments (here two). + +Why treat them differently? See Note [Why sums and products are treated differently]. + +The wrapper $WMkU looks like this: + + $WMkU :: D -> (a,a) -> D -> U a + $WMkU x1 y x2 + = case (case x1 of { + D1 a b -> (# (# a,b #) | #) + D2 -> (# | (# #) #) }) of { x1_ubx -> + case y of { (y1, y2) -> + case (case x2 of { + D1 a b -> (# (# a,b #) | #) + D2 -> (# | (# #) #) }) of { x2_ubx -> + MkU x1_ubx y1 y2 x2_ubx + +Notice the nested case needed for sums. + +This different treatment for sums and product is implemented in +dataConArgUnpackSum and dataConArgUnpackProduct respectively. + +Note [Why sums and products are treated differently] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can we handle sums like products, with each wrapper argument +occupying multiple argument slots in the worker? No: for a sum +type the number of argument slots varies, and that's exactly what +unboxed sums are designed for. + +Can we handle products like sums, with each wrapper argument occupying +exactly one argument slot (and unboxed tuple) in the worker? Yes, +we could. For example + data P = MkP {-# UNPACK #-} !Q + data Q = MkQ {-# NOUNPACK #-} !Int + {-# NOUNPACK #-} Int + +Currently could unpack P thus, taking two slots in the worker + $WMkP :: Q -> P + $WMkP x = case x of { MkQ a b -> MkP a b } + MkP :: Int -> Int -> P -- Worker + +We could instead do this (uniformly with sums) + + $WMkP1 :: Q -> P + $WMkP1 x = case (case x of { MkQ a b -> (# a, b #) }) of ubx_x + MkP1 ubx_x + MkP1 :: (# Int, Int #) -> P -- Worker + +The representation of MkP and MkP1 would be identical (a constructor +with two fields). + +BUT, with MkP (as with every data constructor) we record its argument +strictness as a bit-vector, actually [StrictnessMark] + MkP strictness: SL +This information is used in Core to record which fields are sure to +be evaluated. (Look for calls to dataConRepStrictness.) E.g. in Core + case v of MkP x y -> ........ + +Alas, with MkP1 this information is hidden by the unboxed pair, +In Core there will be an auxiliary case expression to take apart the pair: + case v of MkP1 xy -> case xy of (# x,y #) -> ... +And now we have no easy way to know that x is evaluated in the "...". + +Fixing this might be possible, but it'd be tricky. So we avoid the +problem entirely by treating sums and products differently here. +-} + +dataConArgUnpack + :: Scaled Type + -> ( [(Scaled Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) +dataConArgUnpack scaledTy@(Scaled _ arg_ty) + | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty + = assert (not (isNewTyCon tc)) $ + case tyConDataCons tc of + [con] -> dataConArgUnpackProduct scaledTy tc_args con + cons -> dataConArgUnpackSum scaledTy tc_args cons + | otherwise + = pprPanic "dataConArgUnpack" (ppr arg_ty) + -- An interface file specified Unpacked, but we couldn't unpack it + +dataConArgUnpackProduct + :: Scaled Type + -> [Type] + -> DataCon + -> ( [(Scaled Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) +dataConArgUnpackProduct (Scaled arg_mult _) tc_args con = + assert (null (dataConExTyCoVars con)) $ + -- Note [Unpacking GADTs and existentials] + let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args + in ( rep_tys `zip` dataConRepStrictness con + , ( \ arg_id -> + do { rep_ids <- mapM (newLocal (fsLit "unbx")) rep_tys + ; let r_mult = idMult arg_id + ; let rep_ids' = map (scaleIdBy r_mult) rep_ids + ; let unbox_fn body + = mkSingleAltCase (Var arg_id) arg_id + (DataAlt con) rep_ids' body + ; return (rep_ids, unbox_fn) } + , Boxer $ \ subst -> + do { rep_ids <- mapM (newLocal (fsLit "bx") . TcType.substScaledTyUnchecked subst) rep_tys + ; return (rep_ids, Var (dataConWorkId con) + `mkTyApps` (substTysUnchecked subst tc_args) + `mkVarApps` rep_ids ) } ) ) + +dataConArgUnpackSum + :: Scaled Type + -> [Type] + -> [DataCon] + -> ( [(Scaled Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) +dataConArgUnpackSum (Scaled arg_mult arg_ty) tc_args cons = + ( [ (sum_ty, MarkedStrict) ] -- The idea: Unpacked variant will + -- be one field only, and the type of the + -- field will be an unboxed sum. + , ( unboxer, boxer ) ) + where + !ubx_sum_arity = length cons + src_tys = map (\con -> map scaledThing $ dataConInstArgTys con tc_args) cons + sum_alt_tys = map mkUbxSumAltTy src_tys + sum_ty_unscaled = mkSumTy sum_alt_tys + sum_ty = Scaled arg_mult sum_ty_unscaled + newLocal' fs = newLocal fs . Scaled arg_mult + + -- See Note [UNPACK for sum types] + unboxer :: Unboxer + unboxer arg_id = do + con_arg_binders <- mapM (mapM (newLocal' (fsLit "unbx"))) src_tys + ubx_sum_bndr <- newLocal (fsLit "unbx") sum_ty + + let + mk_ubx_sum_alt :: Int -> DataCon -> [Var] -> CoreAlt + mk_ubx_sum_alt alt con [bndr] = Alt (DataAlt con) [bndr] + (mkCoreUnboxedSum ubx_sum_arity alt sum_alt_tys (Var bndr)) + + mk_ubx_sum_alt alt con bndrs = + let tuple = mkCoreUnboxedTuple (map Var bndrs) + in Alt (DataAlt con) bndrs (mkCoreUnboxedSum ubx_sum_arity alt sum_alt_tys tuple ) + + ubx_sum :: CoreExpr + ubx_sum = + let alts = zipWith3 mk_ubx_sum_alt [ 1 .. ] cons con_arg_binders + in Case (Var arg_id) arg_id (coreAltsType alts) alts + + unbox_fn :: CoreExpr -> CoreExpr + unbox_fn body = + mkSingleAltCase ubx_sum ubx_sum_bndr DEFAULT [] body + + return ([ubx_sum_bndr], unbox_fn) + + boxer :: Boxer + boxer = Boxer $ \ subst -> do + unboxed_field_id <- newLocal' (fsLit "bx") (TcType.substTy subst sum_ty_unscaled) + tuple_bndrs <- mapM (newLocal' (fsLit "bx") . TcType.substTy subst) sum_alt_tys + + let tc_args' = substTys subst tc_args + arg_ty' = substTy subst arg_ty + + con_arg_binders <- + mapM (mapM (newLocal' (fsLit "bx")) . map (TcType.substTy subst)) src_tys + + let mk_sum_alt :: Int -> DataCon -> Var -> [Var] -> CoreAlt + mk_sum_alt alt con _ [datacon_bndr] = + ( Alt (DataAlt (sumDataCon alt ubx_sum_arity)) [datacon_bndr] + (Var (dataConWorkId con) `mkTyApps` tc_args' + `mkVarApps` [datacon_bndr] )) + + mk_sum_alt alt con tuple_bndr datacon_bndrs = + ( Alt (DataAlt (sumDataCon alt ubx_sum_arity)) [tuple_bndr] ( + Case (Var tuple_bndr) tuple_bndr arg_ty' + [ Alt (DataAlt (tupleDataCon Unboxed (length datacon_bndrs))) datacon_bndrs + (Var (dataConWorkId con) `mkTyApps` tc_args' + `mkVarApps` datacon_bndrs ) ] )) + + return ( [unboxed_field_id], + Case (Var unboxed_field_id) unboxed_field_id arg_ty' + (zipWith4 mk_sum_alt [ 1 .. ] cons tuple_bndrs con_arg_binders) ) + +-- | Every alternative of an unboxed sum has exactly one field, and we use +-- unboxed tuples when we need more than one field. This generates an unboxed +-- tuple when necessary, to be used in unboxed sum alts. +mkUbxSumAltTy :: [Type] -> Type +mkUbxSumAltTy [ty] = ty +mkUbxSumAltTy tys = mkTupleTy Unboxed tys + +shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool +-- True if we ought to unpack the UNPACK the argument type +-- See Note [Recursive unboxing] +-- We look "deeply" inside rather than relying on the DataCons +-- we encounter on the way, because otherwise we might well +-- end up relying on ourselves! +shouldUnpackArgTy bang_opts prag fam_envs arg_ty + | Just data_cons <- unpackable_type_datacons (scaledThing arg_ty) + , all ok_con data_cons -- Returns True only if we can't get a + -- loop involving these data cons + , should_unpack prag arg_ty data_cons -- ...hence the call to dataConArgUnpack in + -- should_unpack won't loop + -- See Wrinkle (W1b) of Note [Recursive unboxing] for this loopy stuff + = True + + | otherwise + = False + where + ok_con :: DataCon -> Bool -- True <=> OK to unpack + ok_con top_con -- False <=> not safe + = ok_args emptyNameSet top_con + where + top_con_name = getName top_con + + ok_args dcs con + = all (ok_arg dcs) $ + (dataConOrigArgTys con `zip` dataConSrcBangs con) + -- NB: dataConSrcBangs gives the *user* request; + -- We'd get a black hole if we used dataConImplBangs + + ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool + ok_arg dcs (Scaled _ ty, HsSrcBang _ unpack_prag str_prag) + | strict_field str_prag + , Just data_cons <- unpackable_type_datacons (topNormaliseType fam_envs ty) + , should_unpack_conservative unpack_prag data_cons -- Wrinkle (W3) + = all (ok_rec_con dcs) data_cons -- of Note [Recursive unboxing] + | otherwise + = True -- NB True here, in contrast to False at top level + + -- See Note [Recursive unboxing] + -- * Do not look at the HsImplBangs to `con`; see Wrinkle (W1a) + -- * For the "at the root" comments see Wrinkle (W2) + ok_rec_con dcs con + | dc_name == top_con_name = False -- Recursion at the root + | dc_name `elemNameSet` dcs = True -- Not at the root + | otherwise = ok_args (dcs `extendNameSet` dc_name) con + where + dc_name = getName con + + strict_field :: SrcStrictness -> Bool + -- True <=> strict field + strict_field NoSrcStrict = bang_opt_strict_data bang_opts + strict_field SrcStrict = True + strict_field SrcLazy = False + + -- Determine whether we ought to unpack a field, + -- based on user annotations if present. + -- A conservative version of should_unpack that doesn't look at how + -- many fields the field would unpack to... because that leads to a loop. + -- "Conservative" = err on the side of saying "yes". + should_unpack_conservative :: SrcUnpackedness -> [DataCon] -> Bool + should_unpack_conservative SrcNoUnpack _ = False -- {-# NOUNPACK #-} + should_unpack_conservative SrcUnpack _ = True -- {-# NOUNPACK #-} + should_unpack_conservative NoSrcUnpack dcs = not (is_sum dcs) + -- is_sum: we never unpack sums without a pragma; otherwise be conservative + + -- Determine whether we ought to unpack a field, + -- based on user annotations if present, and heuristics if not. + should_unpack :: SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool + should_unpack prag arg_ty data_cons = + case prag of + SrcNoUnpack -> False -- {-# NOUNPACK #-} + SrcUnpack -> True -- {-# UNPACK #-} + NoSrcUnpack -- No explicit unpack pragma, so use heuristics + | is_sum data_cons + -> False -- Don't unpack sum types automatically, but they can + -- be unpacked with an explicit source UNPACK. + | otherwise -- Wrinkle (W4) of Note [Recursive unboxing] + -> bang_opt_unbox_strict bang_opts + || (bang_opt_unbox_small bang_opts + && is_small_rep) -- See Note [Unpack one-wide fields] + where + (rep_tys, _) = dataConArgUnpack arg_ty + + -- Takes in the list of reps used to represent the dataCon after it's unpacked + -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields] + is_small_rep = + let -- Neccesary to look through unboxed tuples. + prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys + -- And then get the actual size of the unpacked constructor. + rep_size = sum $ map primRepSizeW64_B prim_reps + in rep_size <= 8 + + is_sum :: [DataCon] -> Bool + -- We never unpack sum types automatically + -- (Product types, we do. Empty types are weeded out by unpackable_type_datacons.) + is_sum (_:_:_) = True + is_sum _ = False + + + +unpackable_type_datacons :: Type -> Maybe [DataCon] +-- Given a type already assumed to have been normalized by topNormaliseType, +-- unpackable_type_datacons (T ty1 .. tyn) = Just datacons +-- iff the type can be unpacked (see Note [Unpacking GADTs and existentials]) +-- and `datacons` are the data constructors of T +unpackable_type_datacons ty + | Just (tc, _) <- splitTyConApp_maybe ty + , not (isNewTyCon tc) + -- isNewTyCon: even though `ty` has been normalised, whic includes looking + -- through newtypes, it could still be a /recursive/ newtype, so we must + -- check for that case + , Just cons <- tyConDataCons_maybe tc + , unpackable_cons cons + = Just cons + | otherwise + = Nothing + where + unpackable_cons :: [DataCon] -> Bool + -- True if we can unpack a value of type (T t1 .. tn), + -- where T is an algebraic data type with these constructors + -- See Note [Unpacking GADTs and existentials] + unpackable_cons [] -- Don't unpack nullary sums; no need. + = False -- They already take zero bits; see (UC0) + + unpackable_cons [con] -- Exactly one data constructor; see (UC1) + = null (dataConExTyCoVars con) + + unpackable_cons cons -- More than one data constructor; see (UC2) + = all isVanillaDataCon cons + +{- +Note [Unpacking GADTs and existentials] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can we unpack a value of an algebraic data type T? For example + data D a = MkD {-# UNPACK #-} (T a) +Can we unpack that (T a) field? + +Three cases to consider in `unpackable_cons` + +(UC0) No data constructors; a nullary sum type. This already takes zero + bits so there is no point in unpacking it. + +(UC1) Single-constructor types (products). We can just represent it by + its fields. For example, if `T` is defined as: + data T a = MkT a a Int + then we can unpack it as follows. The worker for MkD takes three unpacked fields: + data D a = MkD a a Int + $MkD :: T a -> D a + $MkD (MkT a1 a2 i) = MkD a1 a2 i + + We currently /can't/ do this if T has existentially-bound type variables, + hence: null (dataConExTyCoVars con) in `unpackable_cons`. + But see also (UC3) below. + + But we /can/ do it for (some) GADTs, such as: + data Equal a b where { Equal :: Equal a a } + data Wom a where { Wom1 :: Int -> Wom Bool } + We will get a MkD constructor that includes some coercion arguments, + but that is fine. See #14978. We still can't accommodate existentials, + but these particular examples don't use existentials. + +(UC2) Multi-constructor types, e.g. + data T a = T1 a | T2 Int a + Here we unpack the field to an unboxed sum type, thus: + data D a = MkD (# a | (# Int, a #) #) + + However, now we can't deal with GADTs at all, because we'd need an + unboxed sum whose component was a unboxed tuple, whose component(s) + have kind (CONSTRAINT r); and that's not well-kinded. Hence the + all isVanillaDataCon + condition in `unpackable_cons`. See #25672. + +(UC3) For single-constructor types, with some more plumbing we could + allow existentials. e.g. + data T a = forall b. MkT a (b->Int) b + could unpack to + data D a = forall b. MkD a (b->Int) b + $MkD :: T a -> D a + $MkD (MkT @b x f y) = MkD @b x f y + Eminently possible, but more plumbing needed. + + +Note [Unpack one-wide fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The flag UnboxSmallStrictFields ensures that any field that can +(safely) be unboxed to a word-sized unboxed field, should be so unboxed. +For example: + + data A = A Int# + newtype B = B A + data C = C !B + data D = D !C + data E = E !() + data F = F !D + data G = G !F !F + +All of these should have an Int# as their representation, except +G which should have two Int#s. + +However + + data T = T !(S Int) + data S = S !a + +Here we can represent T with an Int#. + +Special care has to be taken to make sure we don't mistake fields with unboxed +tuple/sum rep or very large reps. See #22309 + +For consistency we unpack anything that fits into 8 bytes on a 64-bit platform, +even when compiling for 32bit platforms. This way unpacking decisions will be the +same for 32bit and 64bit systems. To do so we use primRepSizeW64_B instead of +primRepSizeB. See also the tests in test case T22309. + +Note [Recursive unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data R = MkR {-# UNPACK #-} !S Int + data S = MkS {-# UNPACK #-} !Int +The representation arguments of MkR are the *representation* arguments +of S (plus Int); the rep args of MkS are Int#. This is all fine. + +But be careful not to try to unbox this! + data T = MkT {-# UNPACK #-} !T Int +Because then we'd get an infinite number of arguments. + +Note that it's the *argument* type that matters. This is fine: + data S = MkS S !Int +because Int is non-recursive. + +Wrinkles: + +(W1a) We have to be careful that the compiler doesn't go into a loop! + First, we must not look at the HsImplBang decisions of data constructors + in the same mutually recursive group. E.g. + data S = MkS {-# UNPACK #-} !T Int + data T = MkT {-# UNPACK #-} !S Int + Each of S and T must decide /independently/ whether to unpack + and they had better not both say yes. So they must both say no. + (We could detect when we leave the group, and /then/ we can rely on + HsImplBangs; but that requires more plumbing.) + +(W1b) Here is another way the compiler might go into a loop (test T23307b): + data data T = MkT !S Int + data S = MkS !T + Suppose we call `shouldUnpackArgTy` on the !S arg of `T`. In `should_unpack` + we ask if the number of fields that `MkS` unpacks to is small enough + (via rep_tys `lengthAtMost` 1). But how many field /does/ `MkS` unpack + to? Well it depends on the unpacking decision we make for `MkS`, which + in turn depends on `MkT`, which we are busy deciding. Black holes beckon. + + So we /first/ call `ok_con` on `MkS` (and `ok_con` is conservative; + see `should_unpack_conservative`), and only /then/ call `should_unpack`. + Tricky! + +(W2) As #23307 shows, we /do/ want to unpack the second arg of the Yes + data constructor in this example, despite the recursion in List: + data Stream a = Cons a !(Stream a) + data Unconsed a = Unconsed a !(Stream a) + data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a) + When looking at + {-# UNPACK #-} (Unconsed a) + we can take Unconsed apart, but then get into a loop with Stream. + That's fine: we can still take Unconsed apart. It's only if we + have a loop /at the root/ that we must not unpack. + +(W3) Moreover (W2) can apply even if there is a recursive loop: + data List a = Nil | Cons {-# UNPACK #-} !(Unconsed a) + data Unconsed a = Unconsed a !(List a) + Here there is mutual recursion between `Unconsed` and `List`; and yet + we can unpack the field of `Cons` because we will not unpack the second + field of `Unconsed`: we never unpack a sum type without an explicit + pragma (see should_unpack). + +(W4) Consider + data T = MkT !Wombat + data Wombat = MkW {-# UNPACK #-} !S Int + data S = MkS {-# NOUNPACK #-} !Wombat Int + Suppose we are deciding whether to unpack the first field of MkT, by + calling (shouldUnpackArgTy Wombat). Then we'll try to unpack the !S field + of MkW, and be stopped by the {-# NOUNPACK #-}, and all is fine; we can + unpack MkT. + + If that NOUNPACK had been a UNPACK, though, we'd get a loop, and would + decide not to unpack the Wombat field of MkT. + + But what if there was no pragma in `data S`? Then we /still/ decide not + to unpack the Wombat field of MkT (at least when auto-unpacking is on), + because we don't know for sure which decision will be taken for the + Wombat field of MkS. + + TL;DR when there is no pragma, behave as if there was a UNPACK, at least + when auto-unpacking is on. See `should_unpack` in `shouldUnpackArgTy`. + + +************************************************************************ +* * + Wrapping and unwrapping newtypes and type families +* * +************************************************************************ +-} + +wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +-- The wrapper for the data constructor for a newtype looks like this: +-- newtype T a = MkT (a,Int) +-- MkT :: forall a. (a,Int) -> T a +-- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) +-- where CoT is the coercion TyCon associated with the newtype +-- +-- The call (wrapNewTypeBody T [a] e) returns the +-- body of the wrapper, namely +-- e `cast` (CoT [a]) +-- +-- If a coercion constructor is provided in the newtype, then we use +-- it, otherwise the wrap/unwrap are both no-ops + +wrapNewTypeBody tycon args result_expr + = assert (isNewTyCon tycon) $ + mkCast result_expr (mkSymCo co) + where + co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] + +-- When unwrapping, we do *not* apply any family coercion, because this will +-- be done via a CoPat by the type checker. We have to do it this way as +-- computing the right type arguments for the coercion requires more than just +-- a splitting operation (cf, GHC.Tc.Gen.Pat.tcConPat). + +unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +unwrapNewTypeBody tycon args result_expr + = assert (isNewTyCon tycon) $ + mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) + +-- If the type constructor is a representation type of a data instance, wrap +-- the expression into a cast adjusting the expression type, which is an +-- instance of the representation type, to the corresponding instance of the +-- family instance type. +-- See Note [Wrappers for data instance tycons] +wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +wrapFamInstBody tycon args body + | Just co_con <- tyConFamilyCoercion_maybe tycon + = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args [])) + | otherwise + = body + +{- +************************************************************************ +* * +* Foreign calls +* * +************************************************************************ +-} + +-- For each ccall we manufacture a separate CCallOpId, giving it +-- a fresh unique, a type that is correct for this particular ccall, +-- and a CCall structure that gives the correct details about calling +-- convention etc. +-- +-- The *name* of this Id is a local name whose OccName gives the full +-- details of the ccall, type and all. This means that the interface +-- file reader can reconstruct a suitable Id + +mkFCallId :: Unique -> ForeignCall -> Type -> Id +mkFCallId uniq fcall ty + = assert (noFreeVarsOfType ty) $ + -- A CCallOpId should have no free type variables; + -- when doing substitutions won't substitute over it + mkGlobalId (FCallId fcall) name ty info + where + occ_str = renderWithContext defaultSDocContext (braces (ppr fcall <+> ppr ty)) + -- The "occurrence name" of a ccall is the full info about the + -- ccall; it is encoded, but may have embedded spaces etc! + + name = mkFCallName uniq (mkFastString occ_str) + + info = noCafIdInfo + `setArityInfo` arity + `setDmdSigInfo` strict_sig + `setCprSigInfo` topCprSig + + (bndrs, _) = tcSplitPiTys ty + arity = count isAnonPiTyBinder bndrs + strict_sig = mkVanillaDmdSig arity topDiv + -- the call does not claim to be strict in its arguments, since they + -- may be lifted (foreign import prim) and the called code doesn't + -- necessarily force them. See #11076. +{- +************************************************************************ +* * +\subsection{DictFuns and default methods} +* * +************************************************************************ + +Note [Dict funs and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dict funs and default methods are *not* ImplicitIds. Their definition +involves user-written code, so we can't figure out their strictness etc +based on fixed info, as we can for constructors and record selectors (say). + +NB: See also Note [Exported LocalIds] in GHC.Types.Id +-} + +mkDictFunId :: Name -- Name to use for the dict fun; + -> [TyVar] + -> ThetaType + -> Class + -> [Type] + -> Id +-- Implements the DFun Superclass Invariant (see GHC.Tc.TyCl.Instance) +-- See Note [Dict funs and default methods] + +mkDictFunId dfun_name tvs theta clas tys + = mkExportedLocalId (DFunId is_unary) + dfun_name + dfun_ty + where + is_unary = isUnaryClass clas + dfun_ty = TcType.tcMkDFunSigmaTy tvs theta (mkClassPred clas tys) + +{- +************************************************************************ +* * +\subsection{Un-definable} +* * +************************************************************************ + +These Ids can't be defined in Haskell. They could be defined in +unfoldings in the wired-in GHC.Prim interface file, but we'd have to +ensure that they were definitely, definitely inlined, because there is +no curried identifier for them. That's what mkCompulsoryUnfolding +does. Alternatively, we could add the definitions to mi_decls of ghcPrimIface +but it's not clear if this would be simpler. + +coercionToken# is not listed in ghcPrimIds, since its type uses (~#) +which is not supposed to be used in expressions (GHC throws an assertion +failure when trying.) +-} + + +nullAddrName, seqName, + realWorldName, voidPrimIdName, coercionTokenName, + coerceName, proxyName, + leftSectionName, rightSectionName :: Name +nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId +voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId +coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId +coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId +proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId +leftSectionName = mkWiredInIdName gHC_PRIM (fsLit "leftSection") leftSectionKey leftSectionId +rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId + +-- Names listed in magicIds; see Note [magicIds] +lazyIdName, oneShotName, nospecIdName :: Name +lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId +oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId +nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId + +------------------------------------------------ +proxyHashId :: Id +proxyHashId + = pcMiscPrelId proxyName ty + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings] + where + -- proxy# :: forall {k} (a:k). Proxy# k a + -- + -- The visibility of the `k` binder is Inferred to match the type of the + -- Proxy data constructor (#16293). + [kv,tv] = mkTemplateKiTyVar liftedTypeKind (\x -> [x]) + kv_ty = mkTyVarTy kv + tv_ty = mkTyVarTy tv + ty = mkInfForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty + +------------------------------------------------ +nullAddrId :: Id +-- nullAddr# :: Addr# +-- The reason it is here is because we don't provide +-- a way to write this literal in Haskell. +nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) + +------------------------------------------------ +seqId :: Id -- See Note [seqId magic] +seqId = pcRepPolyId seqName ty concs info + where + info = noCafIdInfo `setInlinePragInfo` inline_prag + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setArityInfo` arity + + inline_prag + = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter + NoSourceText 0 + -- Make 'seq' not inline-always, so that simpleOptExpr + -- (see GHC.Core.Subst.simple_app) won't inline 'seq' on the + -- LHS of rules. That way we can have rules for 'seq'; + -- see Note [seqId magic] + + -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b + ty = + mkInfForAllTy runtimeRep2TyVar + $ mkSpecForAllTys [alphaTyVar, openBetaTyVar] + $ mkVisFunTyMany alphaTy (mkVisFunTyMany openBetaTy openBetaTy) + + [x,y] = mkTemplateLocals [alphaTy, openBetaTy] + rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ + Case (Var x) x openBetaTy [Alt DEFAULT [] (Var y)] + + concs = mkRepPolyIdConcreteTyVars + [ ((openBetaTy, mkArgPos 2 Top), runtimeRep2TyVar)] + + arity = 2 + +------------------------------------------------ +lazyId :: Id -- See Note [lazyId magic] +lazyId = pcMiscPrelId lazyIdName ty info + where + info = noCafIdInfo + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) + +------------------------------------------------ +noinlineIdName, noinlineConstraintIdName :: Name +noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") + noinlineIdKey noinlineId +noinlineConstraintIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinlineConstraint") + noinlineConstraintIdKey noinlineConstraintId + +noinlineId :: Id -- See Note [noinlineId magic] +noinlineId = pcMiscPrelId noinlineIdName ty info + where + info = noCafIdInfo + ty = mkSpecForAllTys [alphaTyVar] $ + mkVisFunTyMany alphaTy alphaTy + +noinlineConstraintId :: Id -- See Note [noinlineId magic] +noinlineConstraintId = pcMiscPrelId noinlineConstraintIdName ty info + where + info = noCafIdInfo + ty = mkSpecForAllTys [alphaConstraintTyVar] $ + mkFunTy visArgConstraintLike ManyTy alphaTy alphaConstraintTy + +------------------------------------------------ +nospecId :: Id -- See Note [nospecId magic] +nospecId = pcMiscPrelId nospecIdName ty info + where + info = noCafIdInfo + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) + +oneShotId :: Id -- See Note [oneShot magic] +oneShotId = pcRepPolyId oneShotName ty concs info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setArityInfo` arity + -- oneShot :: forall {r1 r2} (a :: TYPE r1) (b :: TYPE r2). (a -> b) -> (a -> b) + ty = mkInfForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar ] $ + mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ] $ + mkVisFunTyMany fun_ty fun_ty + fun_ty = mkVisFunTyMany openAlphaTy openBetaTy + [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] + x' = setOneShotLambda x -- Here is the magic bit! + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar + , body, x'] $ + Var body `App` Var x' + arity = 2 + + concs = mkRepPolyIdConcreteTyVars + [((openAlphaTy, mkArgPos 2 Top), runtimeRep1TyVar)] + +---------------------------------------------------------------------- +{- Note [Wired-in Ids for rebindable syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions leftSectionId, rightSectionId are +wired in here ONLY because they are used in a representation-polymorphic way +by the rebindable syntax mechanism. See GHC.Rename.Expr +Note [Handling overloaded and rebindable constructs]. + +Alas, we can't currently give Haskell definitions for +representation-polymorphic functions. + +They have Compulsory unfoldings, so that the representation polymorphism +does not linger for long. +-} + +-- See Note [Left and right sections] in GHC.Rename.Expr +-- See Note [Wired-in Ids for rebindable syntax] +-- leftSection :: forall r1 r2 n (a::TYPE r1) (b::TYPE r2). +-- (a %n-> b) -> a %n-> b +-- leftSection f x = f x +-- Important that it is eta-expanded, so that (leftSection undefined `seq` ()) +-- is () and not undefined +-- Important that is is multiplicity-polymorphic (test linear/should_compile/OldList) +leftSectionId :: Id +leftSectionId = pcRepPolyId leftSectionName ty concs info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setArityInfo` arity + ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar, multiplicityTyVar1] $ + mkSpecForAllTys [openAlphaTyVar, openBetaTyVar] $ + exprType body + [f,x] = mkTemplateLocals [mkVisFunTy mult openAlphaTy openBetaTy, openAlphaTy] + + mult = mkTyVarTy multiplicityTyVar1 :: Mult + xmult = setIdMult x mult + + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, multiplicityTyVar1 + , openAlphaTyVar, openBetaTyVar ] body + body = mkLams [f,xmult] $ App (Var f) (Var xmult) + arity = 2 + + concs = mkRepPolyIdConcreteTyVars + [((openAlphaTy, mkArgPos 2 Top), runtimeRep1TyVar)] + +-- See Note [Left and right sections] in GHC.Rename.Expr +-- See Note [Wired-in Ids for rebindable syntax] +-- rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3). +-- (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c +-- rightSection f y x = f x y +-- Again, multiplicity polymorphism is important +rightSectionId :: Id +rightSectionId = pcRepPolyId rightSectionName ty concs info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setArityInfo` arity + ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar,runtimeRep3TyVar + , multiplicityTyVar1, multiplicityTyVar2 ] $ + mkSpecForAllTys [openAlphaTyVar, openBetaTyVar, openGammaTyVar ] $ + exprType body + mult1 = mkTyVarTy multiplicityTyVar1 + mult2 = mkTyVarTy multiplicityTyVar2 + + [f,x,y] = mkTemplateLocals [ mkScaledFunTys [ Scaled mult1 openAlphaTy + , Scaled mult2 openBetaTy ] openGammaTy + , openAlphaTy, openBetaTy ] + xmult = setIdMult x mult1 + ymult = setIdMult y mult2 + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar + , multiplicityTyVar1, multiplicityTyVar2 + , openAlphaTyVar, openBetaTyVar, openGammaTyVar ] body + body = mkLams [f,ymult,xmult] $ mkVarApps (Var f) [xmult,ymult] + arity = 3 + + concs = + mkRepPolyIdConcreteTyVars + [ ((openAlphaTy, mkArgPos 3 Top), runtimeRep1TyVar) + , ((openBetaTy , mkArgPos 2 Top), runtimeRep2TyVar)] + +-------------------------------------------------------------------------------- + +coerceId :: Id +coerceId = pcRepPolyId coerceName ty concs info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setArityInfo` 2 + eqRTy = mkTyConApp coercibleTyCon [ tYPE_r, a, b ] + eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE_r, tYPE_r, a, b ] + ty = mkInvisForAllTys [ Bndr rv InferredSpec + , Bndr av SpecifiedSpec + , Bndr bv SpecifiedSpec ] $ + mkInvisFunTy eqRTy $ + mkVisFunTyMany a b + + bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy + (\r -> [mkTYPEapp r, mkTYPEapp r]) + + [r, a, b] = mkTyVarTys bndrs + tYPE_r = mkTYPEapp r + + [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] + rhs = mkLams (bndrs ++ [eqR, x]) $ + mkWildCase (Var eqR) (unrestricted eqRTy) b $ + [Alt (DataAlt coercibleDataCon) [eq] (Cast (Var x) (mkCoVarCo eq))] + + concs = mkRepPolyIdConcreteTyVars + [((mkTyVarTy av, mkArgPos 1 Top), rv)] + +{- +Note [seqId magic] +~~~~~~~~~~~~~~~~~~ +'GHC.Prim.seq' is special in several ways. + +a) Its fixity is set in GHC.Iface.Load.ghcPrimIface + +b) It has quite a bit of desugaring magic. + See GHC.HsToCore.Utils Note [Desugaring seq] (1) and (2) and (3) + +c) There is some special rule handing: Note [User-defined RULES for seq] + +Historical note: + In GHC.Tc.Gen.Expr we used to need a special typing rule for 'seq', to handle calls + whose second argument had an unboxed type, e.g. x `seq` 3# + + However, with representation polymorphism we can now give seq the type + seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b + which handles this case without special treatment in the typechecker. + +Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Roman found situations where he had + case (f n) of _ -> e +where he knew that f (which was strict in n) would terminate if n did. +Notice that the result of (f n) is discarded. So it makes sense to +transform to + case n of _ -> e + +Rather than attempt some general analysis to support this, I've added +enough support that you can do this using a rewrite rule: + + RULE "f/seq" forall n. seq (f n) = seq n + +You write that rule. When GHC sees a case expression that discards +its result, it mentally transforms it to a call to 'seq' and looks for +a RULE. (This is done in GHC.Core.Opt.Simplify.trySeqRules.) As usual, the +correctness of the rule is up to you. + +VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. +If we wrote + RULE "f/seq" forall n e. seq (f n) e = seq n e +with rule arity 2, then two bad things would happen: + + - The magical desugaring done in Note [seqId magic] item (b) + for saturated application of 'seq' would turn the LHS into + a case expression! + + - The code in GHC.Core.Opt.Simplify.rebuildCase would need to actually supply + the value argument, which turns out to be awkward. + +See also: Note [User-defined RULES for seq] in GHC.Core.Opt.Simplify. + + +Note [lazyId magic] +~~~~~~~~~~~~~~~~~~~ +lazy :: forall a. a -> a + +'lazy' is used to make sure that a sub-expression, and its free variables, +are truly used call-by-need, with no code motion. Key examples: + +* pseq: pseq a b = a `seq` lazy b + We want to make sure that the free vars of 'b' are not evaluated + before 'a', even though the expression is plainly strict in 'b'. + +* catch: catch a b = catch# (lazy a) b + Again, it's clear that 'a' will be evaluated strictly (and indeed + applied to a state token) but we want to make sure that any exceptions + arising from the evaluation of 'a' are caught by the catch (see + #11555). + +Implementing 'lazy' is a bit tricky: + +* It must not have a strictness signature: by being a built-in Id, + all the info about lazyId comes from here, not from GHC.Magic.hi. + This is important, because the strictness analyser will spot it as + strict! + +* It must not have an unfolding: it gets "inlined" by a HACK in + CorePrep. It's very important to do this inlining *after* unfoldings + are exposed in the interface file. Otherwise, the unfolding for + (say) pseq in the interface file will not mention 'lazy', so if we + inline 'pseq' we'll totally miss the very thing that 'lazy' was + there for in the first place. See #3259 for a real world + example. + +* Suppose CorePrep sees (catch# (lazy e) b). At all costs we must + avoid using call by value here: + case e of r -> catch# r b + Avoiding that is the whole point of 'lazy'. So in CorePrep (which + generate the 'case' expression for a call-by-value call) we must + spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let' + instead. + +* lazyId is defined in GHC.Base, so we don't *have* to inline it. If it + appears un-applied, we'll end up just calling it. + +Note [noinlineId magic] +~~~~~~~~~~~~~~~~~~~~~~~ +'noinline' is used to make sure that a function f is never inlined, +e.g., as in 'noinline f x'. We won't inline f because we never inline +lone variables (see Note [Lone variables] in GHC.Core.Unfold + +You might think that we could implement noinline like this: + {-# NOINLINE #-} + noinline :: forall a. a -> a + noinline x = x + +But actually we give 'noinline' a wired-in name for three distinct reasons: + +1. We don't want to leave a (useless) call to noinline in the final program, + to be executed at runtime. So we have a little bit of magic to + optimize away 'noinline' after we are done running the simplifier. + This is done in GHC.CoreToStg.Prep.cpeApp. + +2. 'noinline' sometimes gets inserted automatically when we serialize an + expression to the interface format, in GHC.CoreToIface.toIfaceVar. + See Note [Inlining and hs-boot files] in GHC.CoreToIface + +3. Given foo :: Eq a => [a] -> Bool, the expression + noinline foo x xs + where x::Int, will naturally desugar to + noinline @Int (foo @Int dEqInt) x xs + But now it's entirely possible that (foo @Int dEqInt) will inline foo, + since 'foo' is no longer a lone variable -- see #18995 + + Solution: in the desugarer, rewrite + noinline (f x y) ==> noinline f x y + This is done in the `noinlineId` case of `GHC.HsToCore.Expr.ds_app_var` + This is only needed for noinlineId, not noInlineConstraintId (wrinkle + (W1) below), because the latter never shows up in user code. + +Wrinkles + +(W1) Sometimes case (2) above needs to apply `noinline` to a type of kind + Constraint; e.g. + noinline @(Eq Int) $dfEqInt + We don't have type-or-kind polymorphism, so we simply have two `inline` + Ids, namely `noinlineId` and `noinlineConstraintId`. + +(W2) Note that noinline as currently implemented can hide some simplifications + since it hides strictness from the demand analyser. Specifically, the + demand analyser will treat 'noinline f x' as lazy in 'x', even if the + demand signature of 'f' specifies that it is strict in its argument. We + considered fixing this this by adding a special case to the demand + analyser to address #16588. However, the special case seemed like a large + and expensive hammer to address a rare case and consequently we rather + opted to use a more minimal solution. + +Note [nospecId magic] +~~~~~~~~~~~~~~~~~~~~~ +The 'nospec' magic Id is used to ensure to make a value opaque to the typeclass +specialiser. In CorePrep, we inline 'nospec', turning (nospec e) into e. +Note that this happens *after* unfoldings are exposed in the interface file. +This is crucial: otherwise, we could import an unfolding in which +'nospec' has been inlined (= erased), and we would lose the benefit. + +'nospec' is used: + +* In the implementation of 'withDict': we insert 'nospec' so that the + typeclass specialiser doesn't assume any two evidence terms of the + same type are equal. See Note [withDict] in GHC.Tc.Instance.Class, + and see test case T21575b for an example. + +* To defeat the specialiser when we have incoherent instances. + See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv. + +Note [seq# magic] +~~~~~~~~~~~~~~~~~ +The purpose of the magic Id (See Note [magicIds]) + + seq# :: forall a s . a -> State# s -> (# State# s, a #) + +is to elevate evaluation of its argument `a` into an observable side effect. +This implies that GHC's optimisations must preserve the evaluation "exactly +here", in the state thread. + +The main use of seq# is to implement `evaluate` + + evaluate :: a -> IO a + evaluate a = IO $ \s -> seq# a s + +Its (NOINLINE) definition in GHC.Magic is simply + + seq# a s = let !a' = lazy a in (# s, a' #) + +Things to note + +(SEQ1) + It must be NOINLINE, because otherwise the eval !a' would be decoupled from + the state token s, and GHC's optimisations, in particular strictness analysis, + would happily move the eval around. + + However, we *do* inline saturated applications of seq# in CorePrep, where + evaluation order is fixed; see the implementation notes below. + This is one reason why we need seq# to be known-key. + +(SEQ2) + The use of `lazy` ensures that strictness analysis does not see the eval + that takes place, so the final demand signature is , not <1L>. + This is important for a definition like + + foo x y = evaluate y >> evaluate x + + Although both y and x are ultimately evaluated, the user made it clear + they want to evaluate y *before* x. + But if strictness analysis sees the evals, it infers foo as strict in + both parameters. This strictness would be exploited in the backend by + picking a call-by-value calling convention for foo, one that would evaluate + x *before* y. Nononono! + + Because the definition of seq# uses `lazy`, it must live in a different module + (GHC.Internal.IO); otherwise strictness analysis uses its own strictness + signature for the definition of `lazy` instead of the one we wire in. + +(SEQ3) + Why does seq# return the value? Consider + let x = e in + case seq# x s of (# _, x' #) -> ... x' ... case x' of __DEFAULT -> ... + Here, we could simply use x instead of x', but doing so would + introduce an unnecessary indirection and tag check at runtime; + also we can attach an evaldUnfolding to x' to discard any + subsequent evals such as the `case x' of __DEFAULT`. + +(SEQ4) + T15226 demonstrates that we want to discard ok-for-discard seq#s. That is, + simplify `case seq# s of (# s', _ #) -> rhs[s']` to `rhs[s]`. + You might wonder whether the Simplifier could do this. But see the excellent + example in #24334 (immortalised as test T24334) for why it should be done in + CorePrep. + +Implementing seq#. The compiler has magic for `seq#` in + +- GHC.CoreToStg.Prep.cpeRhsE: Implement (SEQ4). + +- Simplify.addEvals records evaluated-ness for the result (cf. (SEQ3)); see + Note [Adding evaluatedness info to pattern-bound variables] + in GHC.Core.Opt.Simplify.Iteration + +- GHC.Core.Opt.DmdAnal.exprMayThrowPreciseException: + Historically, seq# used to be a primop, and the majority of primops + should return False in exprMayThrowPreciseException, so we do the same + for seq# for back compat. + +- GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g., + + seq# (f 13) s + ==> + case f 13 of sat of __DEFAULT -> (# s, sat #) + + This is implemented in `cpeApp`, not unlike Note [runRW magic]. + We are only inlining seq#, leaving opportunities for case-of-known-con + behind that are easily picked up by Unarise: + + case seq# f 13 s of (# s', r #) -> rhs + ==> {Prep} + case f 13 of sat of __DEFAULT -> case (# s, sat #) of (# s', r #) -> rhs + ==> {Unarise} + case f 13 of sat of __DEFAULT -> rhs[s/s',sat/r] + + Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`. + That's OK, because the telescope of Floats always stays in the same order + and won't be floated out of binders, so all guarantees of evaluation order + provided by seq# are upheld. + +Note [oneShot magic] +~~~~~~~~~~~~~~~~~~~~ +In the context of making left-folds fuse somewhat okish (see ticket #7994 +and Note [Left folds via right fold]) it was determined that it would be useful +if library authors could explicitly tell the compiler that a certain lambda is +called at most once. The oneShot function allows that. + +'oneShot' is representation-polymorphic, i.e. the type variables can refer +to unlifted types as well (#10744); e.g. + oneShot (\x:Int# -> x +# 1#) + +Like most magic functions it has a compulsory unfolding, so there is no need +for a real definition somewhere. We have one in GHC.Magic for the convenience +of putting the documentation there. + +It uses `setOneShotLambda` on the lambda's binder. That is the whole magic: + +A typical call looks like + oneShot (\y. e) +after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get + (\f \x[oneshot]. f x) (\y. e) + --> \x[oneshot]. ((\y.e) x) + --> \x[oneshot] e[x/y] +which is what we want. + +Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. + +Wrinkles: +(OS1) It is only effective if the one-shot info survives as long as possible; in + particular it must make it into the interface in unfoldings. See Note [Preserve + OneShotInfo] in GHC.Core.Tidy. + +(OS2) (oneShot (error "urk")) rewrites to + \x[oneshot]. error "urk" x + thereby hiding the `error` under a lambda, which might be surprising, + particularly if you have `-fpedantic-bottoms` on. See #24296. + + +------------------------------------------------------------- +@realWorld#@ used to be a magic literal, \tr{void#}. If things get +nasty as-is, change it back to a literal (@Literal@). + +voidArgId is a Local Id used simply as an argument in functions +where we just want an arg to avoid having a thunk of unlifted type. +E.g. + x = \ void :: Void# -> (# p, q #) + +This comes up in strictness analysis + +Note [evaldUnfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The evaldUnfolding makes it look that some primitive value is +evaluated, which in turn makes Simplify.interestingArg return True, +which in turn makes INLINE things applied to said value likely to be +inlined. +-} + +realWorldPrimId :: Id -- :: State# RealWorld +realWorldPrimId = pcMiscPrelId realWorldName id_ty + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setOneShotInfo` typeOneShot id_ty) + where + id_ty = realWorldStatePrimTy + +voidPrimId :: Id -- Global constant :: Void# + -- The type Void# is now the same as (# #) (ticket #18441), + -- this identifier just signifies the (# #) datacon + -- and is kept for backwards compatibility. + -- We cannot define it in normal Haskell, since it's + -- a top-level unlifted value. +voidPrimId = pcMiscPrelId voidPrimIdName unboxedUnitTy + (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding unboxedUnitExpr) + +unboxedUnitExpr :: CoreExpr +unboxedUnitExpr = Var (dataConWorkId unboxedUnitDataCon) + +voidArgId :: Id -- Local lambda-bound :: Void# +voidArgId = mkSysLocal (fsLit "void") voidArgIdKey ManyTy unboxedUnitTy + +coercionTokenId :: Id -- :: () ~# () +coercionTokenId -- See Note [Coercion tokens] in "GHC.CoreToStg" + = pcMiscPrelId coercionTokenName + (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy]) + noCafIdInfo + +pcMiscPrelId :: Name -> Type -> IdInfo -> Id +pcMiscPrelId name ty info + = mkVanillaGlobalWithInfo name ty info + +pcRepPolyId :: Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id +pcRepPolyId name ty conc_tvs info = + mkGlobalId (RepPolyId $ conc_tvs name) name ty info + +-- | Directly specify which outer forall'd type variables of a +-- representation-polymorphic 'Id' such become concrete metavariables when +-- instantiated. +mkRepPolyIdConcreteTyVars :: [((Type, Position Neg), TyVar)] + -- ^ ((ty, pos), tv) + -- 'ty' is the type on which the representation-polymorphism + -- check is done + -- 'tv' is the type variable we are checking for concreteness + -- (usually the kind of 'ty') + -- 'pos' is the position of 'ty' in the + -- type of the 'Id' + -> Name -- ^ 'Name' of the rep-poly 'Id' + -> ConcreteTyVars +mkRepPolyIdConcreteTyVars vars nm = + mkNameEnv [ (tyVarName tv, mk_conc_frr ty pos) + | ((ty,pos), tv) <- vars ] + where + mk_conc_frr ty pos = + ConcreteFRR $ FixedRuntimeRepOrigin ty + $ FRRRepPolyId nm RepPolyFunction pos diff --git a/GHC/Types/Id/Make.hs-boot b/GHC/Types/Id/Make.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/Id/Make.hs-boot @@ -0,0 +1,10 @@ +module GHC.Types.Id.Make where +import GHC.Types.Name( Name ) +import GHC.Types.Var( Id ) +import GHC.Core.Class( Class ) +import {-# SOURCE #-} GHC.Core.DataCon( DataCon ) + +data DataConBoxer + +mkDataConWorkId :: Name -> DataCon -> Id +mkDictSelId :: Name -> Class -> Id diff --git a/GHC/Types/Literal.hs b/GHC/Types/Literal.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Literal.hs @@ -0,0 +1,1131 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +-} + +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Core literals +module GHC.Types.Literal + ( + -- * Main data type + Literal(..) -- Exported to ParseIface + , LitNumType(..) + + -- ** Creating Literals + , mkLitInt, mkLitIntWrap, mkLitIntWrapC, mkLitIntUnchecked + , mkLitWord, mkLitWordWrap, mkLitWordWrapC, mkLitWordUnchecked + , mkLitInt8, mkLitInt8Wrap, mkLitInt8Unchecked + , mkLitWord8, mkLitWord8Wrap, mkLitWord8Unchecked + , mkLitInt16, mkLitInt16Wrap, mkLitInt16Unchecked + , mkLitWord16, mkLitWord16Wrap, mkLitWord16Unchecked + , mkLitInt32, mkLitInt32Wrap, mkLitInt32Unchecked + , mkLitWord32, mkLitWord32Wrap, mkLitWord32Unchecked + , mkLitInt64, mkLitInt64Wrap, mkLitInt64Unchecked + , mkLitWord64, mkLitWord64Wrap, mkLitWord64Unchecked + , mkLitFloat, mkLitDouble + , mkLitChar, mkLitString + , mkLitBigNat + , mkLitNumber, mkLitNumberWrap, mkLitNumberMaybe + + -- ** Operations on Literals + , literalType + , pprLiteral + , litNumIsSigned + , litNumRange + , litNumCheckRange + , litNumWrap + , litNumCoerce + , litNumNarrow + , litNumBitSize + , isMinBound + , isMaxBound + + -- ** Predicates on Literals and their contents + , litIsDupable, litIsTrivial, litIsLifted + , inCharRange + , isZeroLit, isOneLit + , litFitsInChar + , litValue, mapLitValue + , isLitValue_maybe, isLitRubbish + + -- ** Coercions + , narrowInt8Lit, narrowInt16Lit, narrowInt32Lit, narrowInt64Lit + , narrowWord8Lit, narrowWord16Lit, narrowWord32Lit, narrowWord64Lit + , convertToIntLit, convertToWordLit + , charToIntLit, intToCharLit + , floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit + , nullAddrLit, floatToDoubleLit, doubleToFloatLit + ) where + +import GHC.Prelude + +import GHC.Builtin.Types.Prim +import GHC.Core.Type( Type, RuntimeRepType, mkForAllTy, mkTyVarTy, typeOrConstraintKind ) +import GHC.Core.TyCo.Compare( nonDetCmpType ) +import GHC.Types.Var +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Basic +import GHC.Utils.Binary +import GHC.Settings.Constants +import GHC.Platform +import GHC.Utils.Panic +import GHC.Utils.Encoding + +import Data.ByteString (ByteString) +import Data.Int +import Data.Word +import Data.Char +import Data.Data ( Data ) +import GHC.Exts( isTrue#, dataToTag#, (<#) ) +import Numeric ( fromRat ) +import Control.DeepSeq + +{- +************************************************************************ +* * +\subsection{Literals} +* * +************************************************************************ +-} + +-- | So-called 'Literal's are one of: +-- +-- * An unboxed numeric literal or floating-point literal which is presumed +-- to be surrounded by appropriate constructors (@Int#@, etc.), so that +-- the overall thing makes sense. +-- +-- We maintain the invariant that the 'Integer' in the 'LitNumber' +-- constructor is actually in the (possibly target-dependent) range. +-- The mkLit{Int,Word}*Wrap smart constructors ensure this by applying +-- the target machine's wrapping semantics. Use these in situations +-- where you know the wrapping semantics are correct. +-- +-- * The literal derived from the label mentioned in a \"foreign label\" +-- declaration ('LitLabel') +-- +-- * A 'LitRubbish' to be used in place of values that are never used. +-- +-- * A character +-- * A string +-- * The NULL pointer +-- +data Literal + = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with + -- 'mkLitChar' + + | LitNumber !LitNumType !Integer + -- ^ Any numeric literal that can be + -- internally represented with an Integer. + + | LitString !ByteString -- ^ A string-literal: stored and emitted + -- UTF-8 encoded, we'll arrange to decode it + -- at runtime. Also emitted with a @\'\\0\'@ + -- terminator. Create with 'mkLitString' + + | LitNullAddr -- ^ The @NULL@ pointer, the only pointer value + -- that can be represented as a Literal. Create + -- with 'nullAddrLit' + + | LitRubbish -- ^ A nonsense value; See Note [Rubbish literals]. + TypeOrConstraint -- t_or_c: whether this is a type or a constraint + RuntimeRepType -- rr: a type of kind RuntimeRep + -- The type of the literal is forall (a::TYPE rr). a + -- or forall (a::CONSTRAINT rr). a + -- + -- INVARIANT: the Type has no free variables + -- and so substitution etc can ignore it + + | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' + | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' + + | LitLabel FastString FunctionOrData + -- ^ A label literal. Parameters: + -- + -- 1) The name of the symbol mentioned in the + -- declaration + -- + -- 2) Flag indicating whether the symbol + -- references a function or a data + deriving Data + +-- | Numeric literal type +data LitNumType + = LitNumBigNat -- ^ @Bignat@ (see Note [BigNum literals]) + | LitNumInt -- ^ @Int#@ - according to target machine + | LitNumInt8 -- ^ @Int8#@ - exactly 8 bits + | LitNumInt16 -- ^ @Int16#@ - exactly 16 bits + | LitNumInt32 -- ^ @Int32#@ - exactly 32 bits + | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits + | LitNumWord -- ^ @Word#@ - according to target machine + | LitNumWord8 -- ^ @Word8#@ - exactly 8 bits + | LitNumWord16 -- ^ @Word16#@ - exactly 16 bits + | LitNumWord32 -- ^ @Word32#@ - exactly 32 bits + | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits + deriving (Data,Enum,Eq,Ord) + +-- | Indicate if a numeric literal type supports negative numbers +litNumIsSigned :: LitNumType -> Bool +litNumIsSigned nt = case nt of + LitNumBigNat -> False + LitNumInt -> True + LitNumInt8 -> True + LitNumInt16 -> True + LitNumInt32 -> True + LitNumInt64 -> True + LitNumWord -> False + LitNumWord8 -> False + LitNumWord16 -> False + LitNumWord32 -> False + LitNumWord64 -> False + +-- | Number of bits +litNumBitSize :: Platform -> LitNumType -> Maybe Word +litNumBitSize platform nt = case nt of + LitNumBigNat -> Nothing + LitNumInt -> Just (fromIntegral (platformWordSizeInBits platform)) + LitNumInt8 -> Just 8 + LitNumInt16 -> Just 16 + LitNumInt32 -> Just 32 + LitNumInt64 -> Just 64 + LitNumWord -> Just (fromIntegral (platformWordSizeInBits platform)) + LitNumWord8 -> Just 8 + LitNumWord16 -> Just 16 + LitNumWord32 -> Just 32 + LitNumWord64 -> Just 64 + +instance Binary LitNumType where + put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) + get bh = do + h <- getByte bh + return (toEnum (fromIntegral h)) + +instance NFData LitNumType where + rnf (LitNumBigNat) = () + rnf (LitNumInt) = () + rnf (LitNumInt8) = () + rnf (LitNumInt16) = () + rnf (LitNumInt32) = () + rnf (LitNumInt64) = () + rnf (LitNumWord) = () + rnf (LitNumWord8) = () + rnf (LitNumWord16) = () + rnf (LitNumWord32) = () + rnf (LitNumWord64) = () + + +{- +Note [BigNum literals] +~~~~~~~~~~~~~~~~~~~~~~ +GHC supports 2 kinds of arbitrary precision numbers (a.k.a BigNum): + + * data Natural = NS Word# | NB BigNat# + + * data Integer = IS Int# | IN BigNat# | IP BigNat# + +In the past, we had Core constructors to represent Integer and Natural literals. +These literals were then lowered into their real Core representation only in +Core prep. The issue with this approach is that literals have two +representations and we have to ensure that we handle them the same everywhere +(in every optimisation, etc.). + +For example (0 :: Integer) was representable in Core with both: + + Lit (LitNumber LitNumInteger 0) -- literal + App (Var integerISDataCon) (Lit (LitNumber LitNumInt 0)) -- real representation + +Nowadays we always use the real representation for Integer and Natural literals. +However we still have two representations for BigNat# literals. BigNat# literals +are still lowered in Core prep into a call to a constructor function (BigNat# is +ByteArray# and we don't have ByteArray# literals yet so we have to build them at +runtime). + +Note [String literals] +~~~~~~~~~~~~~~~~~~~~~~ +String literals are UTF-8 encoded and stored into ByteStrings in the following +ASTs: Haskell, Core, Stg, Cmm. TH can also emit ByteString based string literals +with the BytesPrimL constructor (see #14741). + +It wasn't true before as [Word8] was used in Cmm AST and in TH which was quite +bad for performance with large strings (see #16198 and #14741). + +To include string literals into output objects, the assembler code generator has +to embed the UTF-8 encoded binary blob. See Note [Embedding large binary blobs] +for more details. + +-} + +instance Binary Literal where + put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa + put_ bh (LitString ab) = do putByte bh 1; put_ bh ab + put_ bh (LitNullAddr) = putByte bh 2 + put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah + put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai + put_ bh (LitLabel aj fod) + = do putByte bh 5 + put_ bh aj + put_ bh fod + put_ bh (LitNumber nt i) + = do putByte bh 6 + put_ bh nt + put_ bh i + put_ _ lit@(LitRubbish {}) = pprPanic "Binary LitRubbish" (ppr lit) + -- We use IfaceLitRubbish; see Note [Rubbish literals], item (6) + + get bh = do + h <- getByte bh + case h of + 0 -> do + aa <- get bh + return (LitChar aa) + 1 -> do + ab <- get bh + return (LitString ab) + 2 -> return (LitNullAddr) + 3 -> do + ah <- get bh + return (LitFloat ah) + 4 -> do + ai <- get bh + return (LitDouble ai) + 5 -> do + aj <- get bh + fod <- get bh + return (LitLabel aj fod) + 6 -> do + nt <- get bh + i <- get bh + return (LitNumber nt i) + _ -> pprPanic "Binary:Literal" (int (fromIntegral h)) + +instance NFData Literal where + rnf (LitChar c) = rnf c + rnf (LitNumber nt i) = rnf nt `seq` rnf i + rnf (LitString s) = rnf s + rnf LitNullAddr = () + rnf (LitFloat r) = rnf r + rnf (LitDouble r) = rnf r + rnf (LitLabel l1 k2) = rnf l1 `seq` rnf k2 + rnf (LitRubbish {}) = () -- LitRubbish is not contained within interface files. + -- See Note [Rubbish literals]. + +instance Outputable Literal where + ppr = pprLiteral id + +instance Eq Literal where + a == b = compare a b == EQ + +-- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in +-- 'GHC.Data.TrieMap.CoreMap'. +instance Ord Literal where + compare = cmpLit + +{- + Construction + ~~~~~~~~~~~~ +-} + +{- Note [Word/Int underflow/overflow] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and +unsigned integral types): "All arithmetic is performed modulo 2^n, where n is +the number of bits in the type." + +GHC stores Word# and Int# constant values as Integer. Core optimizations such +as constant folding must ensure that the Integer value remains in the valid +target Word/Int range (see #13172). The following functions are used to +ensure this. + +Note that we *don't* warn the user about overflow. It's not done at runtime +either, and compilation of completely harmless things like + ((124076834 :: Word32) + (2147483647 :: Word32)) +doesn't yield a warning. Instead we simply squash the value into the *target* +Int/Word range. +-} + +-- | Make a literal number using wrapping semantics if the value is out of +-- bound. +mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Literal +mkLitNumberWrap platform nt i = LitNumber nt $ mkLitNumberWrap' platform nt i + +-- | Make a literal number using wrapping semantics if the value is out of +-- bound. +mkLitNumberWrap' :: Platform -> LitNumType -> Integer -> Integer +mkLitNumberWrap' platform nt i = case nt of + LitNumInt -> case platformWordSize platform of + PW4 -> wrap @Int32 + PW8 -> wrap @Int64 + LitNumWord -> case platformWordSize platform of + PW4 -> wrap @Word32 + PW8 -> wrap @Word64 + LitNumInt8 -> wrap @Int8 + LitNumInt16 -> wrap @Int16 + LitNumInt32 -> wrap @Int32 + LitNumInt64 -> wrap @Int64 + LitNumWord8 -> wrap @Word8 + LitNumWord16 -> wrap @Word16 + LitNumWord32 -> wrap @Word32 + LitNumWord64 -> wrap @Word64 + LitNumBigNat + | i < 0 -> panic "mkLitNumberWrap: trying to create a negative BigNat" + | otherwise -> i + where + wrap :: forall a. (Integral a, Num a) => Integer + wrap = toInteger (fromIntegral i :: a) + +-- | Wrap a literal number according to its type using wrapping semantics. +litNumWrap :: Platform -> Literal -> Literal +litNumWrap platform (LitNumber nt i) = mkLitNumberWrap platform nt i +litNumWrap _ l = pprPanic "litNumWrap" (ppr l) + +-- | Coerce a literal number into another using wrapping semantics. +litNumCoerce :: LitNumType -> Platform -> Literal -> Literal +litNumCoerce pt platform (LitNumber _nt i) = mkLitNumberWrap platform pt i +litNumCoerce _ _ l = pprPanic "litNumWrapCoerce: not a number" (ppr l) + +-- | Narrow a literal number by converting it into another number type and then +-- converting it back to its original type. +litNumNarrow :: LitNumType -> Platform -> Literal -> Literal +litNumNarrow pt platform (LitNumber nt i) + = mkLitNumberWrap platform nt . mkLitNumberWrap' platform pt $ i +litNumNarrow _ _ l = pprPanic "litNumNarrow: invalid literal" (ppr l) + + +-- | Check that a given number is in the range of a numeric literal +litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool +litNumCheckRange platform nt i = + maybe True (i >=) m_lower && + maybe True (i <=) m_upper + where + (m_lower, m_upper) = litNumRange platform nt + +-- | Get the literal range +litNumRange :: Platform -> LitNumType -> (Maybe Integer, Maybe Integer) +litNumRange platform nt = case nt of + LitNumInt -> (Just (platformMinInt platform), Just (platformMaxInt platform)) + LitNumWord -> (Just 0, Just (platformMaxWord platform)) + LitNumInt8 -> bounded_range @Int8 + LitNumInt16 -> bounded_range @Int16 + LitNumInt32 -> bounded_range @Int32 + LitNumInt64 -> bounded_range @Int64 + LitNumWord8 -> bounded_range @Word8 + LitNumWord16 -> bounded_range @Word16 + LitNumWord32 -> bounded_range @Word32 + LitNumWord64 -> bounded_range @Word64 + LitNumBigNat -> (Just 0, Nothing) + where + bounded_range :: forall a . (Integral a, Bounded a) => (Maybe Integer,Maybe Integer) + bounded_range = case boundedRange @a of + (mi,ma) -> (Just mi, Just ma) + +-- | Create a numeric 'Literal' of the given type +mkLitNumber :: Platform -> LitNumType -> Integer -> Literal +mkLitNumber platform nt i = + assertPpr (litNumCheckRange platform nt i) (integer i) + (LitNumber nt i) + +-- | Create a numeric 'Literal' of the given type if it is in range +mkLitNumberMaybe :: Platform -> LitNumType -> Integer -> Maybe Literal +mkLitNumberMaybe platform nt i + | litNumCheckRange platform nt i = Just (LitNumber nt i) + | otherwise = Nothing + +-- | Creates a 'Literal' of type @Int#@ +mkLitInt :: Platform -> Integer -> Literal +mkLitInt platform x = assertPpr (platformInIntRange platform x) (integer x) + (mkLitIntUnchecked x) + +-- | Creates a 'Literal' of type @Int#@. +-- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] +mkLitIntWrap :: Platform -> Integer -> Literal +mkLitIntWrap platform i = mkLitNumberWrap platform LitNumInt i + +-- | Creates a 'Literal' of type @Int#@ without checking its range. +mkLitIntUnchecked :: Integer -> Literal +mkLitIntUnchecked i = LitNumber LitNumInt i + +-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating +-- overflow. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the overflow flag will be set. +-- See Note [Word/Int underflow/overflow] +mkLitIntWrapC :: Platform -> Integer -> (Literal, Bool) +mkLitIntWrapC platform i = (LitNumber LitNumInt i', i /= i') + where + i' = mkLitNumberWrap' platform LitNumInt i + +-- | Creates a 'Literal' of type @Word#@ +mkLitWord :: Platform -> Integer -> Literal +mkLitWord platform x = assertPpr (platformInWordRange platform x) (integer x) + (mkLitWordUnchecked x) + +-- | Creates a 'Literal' of type @Word#@. +-- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] +mkLitWordWrap :: Platform -> Integer -> Literal +mkLitWordWrap platform i = mkLitNumberWrap platform LitNumWord i + +-- | Creates a 'Literal' of type @Word#@ without checking its range. +mkLitWordUnchecked :: Integer -> Literal +mkLitWordUnchecked i = LitNumber LitNumWord i + +-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating +-- carry. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the carry flag will be set. +-- See Note [Word/Int underflow/overflow] +mkLitWordWrapC :: Platform -> Integer -> (Literal, Bool) +mkLitWordWrapC platform i = (LitNumber LitNumWord i', i /= i') + where + i' = mkLitNumberWrap' platform LitNumWord i + +-- | Creates a 'Literal' of type @Int8#@ +mkLitInt8 :: Integer -> Literal +mkLitInt8 x = assertPpr (inBoundedRange @Int8 x) (integer x) (mkLitInt8Unchecked x) + +-- | Creates a 'Literal' of type @Int8#@. +-- If the argument is out of the range, it is wrapped. +mkLitInt8Wrap :: Integer -> Literal +mkLitInt8Wrap i = mkLitInt8Unchecked (toInteger (fromIntegral i :: Int8)) + +-- | Creates a 'Literal' of type @Int8#@ without checking its range. +mkLitInt8Unchecked :: Integer -> Literal +mkLitInt8Unchecked i = LitNumber LitNumInt8 i + +-- | Creates a 'Literal' of type @Word8#@ +mkLitWord8 :: Integer -> Literal +mkLitWord8 x = assertPpr (inBoundedRange @Word8 x) (integer x) (mkLitWord8Unchecked x) + +-- | Creates a 'Literal' of type @Word8#@. +-- If the argument is out of the range, it is wrapped. +mkLitWord8Wrap :: Integer -> Literal +mkLitWord8Wrap i = mkLitWord8Unchecked (toInteger (fromIntegral i :: Word8)) + +-- | Creates a 'Literal' of type @Word8#@ without checking its range. +mkLitWord8Unchecked :: Integer -> Literal +mkLitWord8Unchecked i = LitNumber LitNumWord8 i + +-- | Creates a 'Literal' of type @Int16#@ +mkLitInt16 :: Integer -> Literal +mkLitInt16 x = assertPpr (inBoundedRange @Int16 x) (integer x) (mkLitInt16Unchecked x) + +-- | Creates a 'Literal' of type @Int16#@. +-- If the argument is out of the range, it is wrapped. +mkLitInt16Wrap :: Integer -> Literal +mkLitInt16Wrap i = mkLitInt16Unchecked (toInteger (fromIntegral i :: Int16)) + +-- | Creates a 'Literal' of type @Int16#@ without checking its range. +mkLitInt16Unchecked :: Integer -> Literal +mkLitInt16Unchecked i = LitNumber LitNumInt16 i + +-- | Creates a 'Literal' of type @Word16#@ +mkLitWord16 :: Integer -> Literal +mkLitWord16 x = assertPpr (inBoundedRange @Word16 x) (integer x) (mkLitWord16Unchecked x) + +-- | Creates a 'Literal' of type @Word16#@. +-- If the argument is out of the range, it is wrapped. +mkLitWord16Wrap :: Integer -> Literal +mkLitWord16Wrap i = mkLitWord16Unchecked (toInteger (fromIntegral i :: Word16)) + +-- | Creates a 'Literal' of type @Word16#@ without checking its range. +mkLitWord16Unchecked :: Integer -> Literal +mkLitWord16Unchecked i = LitNumber LitNumWord16 i + +-- | Creates a 'Literal' of type @Int32#@ +mkLitInt32 :: Integer -> Literal +mkLitInt32 x = assertPpr (inBoundedRange @Int32 x) (integer x) (mkLitInt32Unchecked x) + +-- | Creates a 'Literal' of type @Int32#@. +-- If the argument is out of the range, it is wrapped. +mkLitInt32Wrap :: Integer -> Literal +mkLitInt32Wrap i = mkLitInt32Unchecked (toInteger (fromIntegral i :: Int32)) + +-- | Creates a 'Literal' of type @Int32#@ without checking its range. +mkLitInt32Unchecked :: Integer -> Literal +mkLitInt32Unchecked i = LitNumber LitNumInt32 i + +-- | Creates a 'Literal' of type @Word32#@ +mkLitWord32 :: Integer -> Literal +mkLitWord32 x = assertPpr (inBoundedRange @Word32 x) (integer x) (mkLitWord32Unchecked x) + +-- | Creates a 'Literal' of type @Word32#@. +-- If the argument is out of the range, it is wrapped. +mkLitWord32Wrap :: Integer -> Literal +mkLitWord32Wrap i = mkLitWord32Unchecked (toInteger (fromIntegral i :: Word32)) + +-- | Creates a 'Literal' of type @Word32#@ without checking its range. +mkLitWord32Unchecked :: Integer -> Literal +mkLitWord32Unchecked i = LitNumber LitNumWord32 i + +-- | Creates a 'Literal' of type @Int64#@ +mkLitInt64 :: Integer -> Literal +mkLitInt64 x = assertPpr (inBoundedRange @Int64 x) (integer x) (mkLitInt64Unchecked x) + +-- | Creates a 'Literal' of type @Int64#@. +-- If the argument is out of the range, it is wrapped. +mkLitInt64Wrap :: Integer -> Literal +mkLitInt64Wrap i = mkLitInt64Unchecked (toInteger (fromIntegral i :: Int64)) + +-- | Creates a 'Literal' of type @Int64#@ without checking its range. +mkLitInt64Unchecked :: Integer -> Literal +mkLitInt64Unchecked i = LitNumber LitNumInt64 i + +-- | Creates a 'Literal' of type @Word64#@ +mkLitWord64 :: Integer -> Literal +mkLitWord64 x = assertPpr (inBoundedRange @Word64 x) (integer x) (mkLitWord64Unchecked x) + +-- | Creates a 'Literal' of type @Word64#@. +-- If the argument is out of the range, it is wrapped. +mkLitWord64Wrap :: Integer -> Literal +mkLitWord64Wrap i = mkLitWord64Unchecked (toInteger (fromIntegral i :: Word64)) + +-- | Creates a 'Literal' of type @Word64#@ without checking its range. +mkLitWord64Unchecked :: Integer -> Literal +mkLitWord64Unchecked i = LitNumber LitNumWord64 i + +-- | Creates a 'Literal' of type @Float#@ +mkLitFloat :: Rational -> Literal +mkLitFloat = LitFloat + +-- | Creates a 'Literal' of type @Double#@ +mkLitDouble :: Rational -> Literal +mkLitDouble = LitDouble + +-- | Creates a 'Literal' of type @Char#@ +mkLitChar :: Char -> Literal +mkLitChar = LitChar + +-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to +-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ +mkLitString :: String -> Literal +-- stored UTF-8 encoded +mkLitString [] = LitString mempty +mkLitString s = LitString (utf8EncodeByteString s) + +mkLitBigNat :: Integer -> Literal +mkLitBigNat x = assertPpr (x >= 0) (integer x) + (LitNumber LitNumBigNat x) + +isLitRubbish :: Literal -> Bool +isLitRubbish (LitRubbish {}) = True +isLitRubbish _ = False + +inBoundedRange :: forall a. (Bounded a, Integral a) => Integer -> Bool +inBoundedRange x = x >= toInteger (minBound :: a) && + x <= toInteger (maxBound :: a) + +boundedRange :: forall a. (Bounded a, Integral a) => (Integer,Integer) +boundedRange = (toInteger (minBound :: a), toInteger (maxBound :: a)) + +isMinBound :: Platform -> Literal -> Bool +isMinBound _ (LitChar c) = c == minBound +isMinBound platform (LitNumber nt i) = case nt of + LitNumInt -> i == platformMinInt platform + LitNumInt8 -> i == toInteger (minBound :: Int8) + LitNumInt16 -> i == toInteger (minBound :: Int16) + LitNumInt32 -> i == toInteger (minBound :: Int32) + LitNumInt64 -> i == toInteger (minBound :: Int64) + LitNumWord -> i == 0 + LitNumWord8 -> i == 0 + LitNumWord16 -> i == 0 + LitNumWord32 -> i == 0 + LitNumWord64 -> i == 0 + LitNumBigNat -> i == 0 +isMinBound _ _ = False + +isMaxBound :: Platform -> Literal -> Bool +isMaxBound _ (LitChar c) = c == maxBound +isMaxBound platform (LitNumber nt i) = case nt of + LitNumInt -> i == platformMaxInt platform + LitNumInt8 -> i == toInteger (maxBound :: Int8) + LitNumInt16 -> i == toInteger (maxBound :: Int16) + LitNumInt32 -> i == toInteger (maxBound :: Int32) + LitNumInt64 -> i == toInteger (maxBound :: Int64) + LitNumWord -> i == platformMaxWord platform + LitNumWord8 -> i == toInteger (maxBound :: Word8) + LitNumWord16 -> i == toInteger (maxBound :: Word16) + LitNumWord32 -> i == toInteger (maxBound :: Word32) + LitNumWord64 -> i == toInteger (maxBound :: Word64) + LitNumBigNat -> False +isMaxBound _ _ = False + +inCharRange :: Char -> Bool +inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR + +-- | Tests whether the literal represents a zero of whatever type it is +isZeroLit :: Literal -> Bool +isZeroLit (LitNumber _ 0) = True +isZeroLit (LitFloat 0) = True +isZeroLit (LitDouble 0) = True +isZeroLit _ = False + +-- | Tests whether the literal represents a one of whatever type it is +isOneLit :: Literal -> Bool +isOneLit (LitNumber _ 1) = True +isOneLit (LitFloat 1) = True +isOneLit (LitDouble 1) = True +isOneLit _ = False + +-- | Returns the 'Integer' contained in the 'Literal', for when that makes +-- sense, i.e. for 'Char' and numbers. +litValue :: Literal -> Integer +litValue l = case isLitValue_maybe l of + Just x -> x + Nothing -> pprPanic "litValue" (ppr l) + +-- | Returns the 'Integer' contained in the 'Literal', for when that makes +-- sense, i.e. for 'Char' and numbers. +isLitValue_maybe :: Literal -> Maybe Integer +isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c +isLitValue_maybe (LitNumber _ i) = Just i +isLitValue_maybe _ = Nothing + +-- | Apply a function to the 'Integer' contained in the 'Literal', for when that +-- makes sense, e.g. for 'Char' and numbers. +-- For fixed-size integral literals, the result will be wrapped in accordance +-- with the semantics of the target type. +-- See Note [Word/Int underflow/overflow] +mapLitValue :: Platform -> (Integer -> Integer) -> Literal -> Literal +mapLitValue _ f (LitChar c) = mkLitChar (fchar c) + where fchar = chr . fromInteger . f . toInteger . ord +mapLitValue platform f (LitNumber nt i) = mkLitNumberWrap platform nt (f i) +mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) + +{- + Coercions + ~~~~~~~~~ +-} + +charToIntLit, intToCharLit, + floatToIntLit, intToFloatLit, + doubleToIntLit, intToDoubleLit, + floatToDoubleLit, doubleToFloatLit + :: Literal -> Literal + +-- | Narrow a literal number (unchecked result range) +narrowLit' :: forall a. Integral a => LitNumType -> Literal -> Literal +narrowLit' nt' (LitNumber _ i) = LitNumber nt' (toInteger (fromInteger i :: a)) +narrowLit' _ l = pprPanic "narrowLit" (ppr l) + +narrowInt8Lit, narrowInt16Lit, narrowInt32Lit, narrowInt64Lit, + narrowWord8Lit, narrowWord16Lit, narrowWord32Lit, narrowWord64Lit :: Literal -> Literal +narrowInt8Lit = narrowLit' @Int8 LitNumInt8 +narrowInt16Lit = narrowLit' @Int16 LitNumInt16 +narrowInt32Lit = narrowLit' @Int32 LitNumInt32 +narrowInt64Lit = narrowLit' @Int64 LitNumInt64 +narrowWord8Lit = narrowLit' @Word8 LitNumWord8 +narrowWord16Lit = narrowLit' @Word16 LitNumWord16 +narrowWord32Lit = narrowLit' @Word32 LitNumWord32 +narrowWord64Lit = narrowLit' @Word64 LitNumWord64 + +-- | Extend or narrow a fixed-width literal (e.g. 'Int16#') to a target +-- word-sized literal ('Int#' or 'Word#'). Narrowing can only happen on 32-bit +-- architectures when we convert a 64-bit literal into a 32-bit one. +convertToWordLit, convertToIntLit :: Platform -> Literal -> Literal +convertToWordLit platform (LitNumber _nt i) = mkLitWordWrap platform i +convertToWordLit _platform l = pprPanic "convertToWordLit" (ppr l) +convertToIntLit platform (LitNumber _nt i) = mkLitIntWrap platform i +convertToIntLit _platform l = pprPanic "convertToIntLit" (ppr l) + +charToIntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) +charToIntLit l = pprPanic "charToIntLit" (ppr l) +intToCharLit (LitNumber _ i) = LitChar (chr (fromInteger i)) +intToCharLit l = pprPanic "intToCharLit" (ppr l) + +floatToIntLit (LitFloat f) = mkLitIntUnchecked (truncate f) +floatToIntLit l = pprPanic "floatToIntLit" (ppr l) +intToFloatLit (LitNumber _ i) = LitFloat (fromInteger i) +intToFloatLit l = pprPanic "intToFloatLit" (ppr l) + +doubleToIntLit (LitDouble f) = mkLitIntUnchecked (truncate f) +doubleToIntLit l = pprPanic "doubleToIntLit" (ppr l) +intToDoubleLit (LitNumber _ i) = LitDouble (fromInteger i) +intToDoubleLit l = pprPanic "intToDoubleLit" (ppr l) + +floatToDoubleLit (LitFloat f) = LitDouble f +floatToDoubleLit l = pprPanic "floatToDoubleLit" (ppr l) +doubleToFloatLit (LitDouble d) = LitFloat d +doubleToFloatLit l = pprPanic "doubleToFloatLit" (ppr l) + +nullAddrLit :: Literal +nullAddrLit = LitNullAddr + +{- + Predicates + ~~~~~~~~~~ +-} + +-- | True if there is absolutely no penalty to duplicating the literal. +-- False principally of strings. +-- +-- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would +-- blow up code sizes. Not only this, it's also unsafe. +-- +-- Consider a program that wants to traverse a string. One way it might do this +-- is to first compute the Addr# pointing to the end of the string, and then, +-- starting from the beginning, bump a pointer using eqAddr# to determine the +-- end. For instance, +-- +-- @ +-- -- Given pointers to the start and end of a string, count how many zeros +-- -- the string contains. +-- countZeros :: Addr# -> Addr# -> -> Int +-- countZeros start end = go start 0 +-- where +-- go off n +-- | off `addrEq#` end = n +-- | otherwise = go (off `plusAddr#` 1) n' +-- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1 +-- | otherwise = n +-- @ +-- +-- Consider what happens if we considered strings to be trivial (and therefore +-- duplicable) and emitted a call like @countZeros "hello"# ("hello"# +-- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same +-- string, meaning that an iteration like the above would blow up terribly. +-- This is what happened in #12757. +-- +-- Ultimately the solution here is to make primitive strings a bit more +-- structured, ensuring that the compiler can't inline in ways that will break +-- user code. One approach to this is described in #8472. +litIsTrivial :: Literal -> Bool +-- c.f. GHC.Core.Utils.exprIsTrivial +litIsTrivial (LitString _) = False +litIsTrivial (LitNumber nt _) = case nt of + LitNumBigNat -> False + LitNumInt -> True + LitNumInt8 -> True + LitNumInt16 -> True + LitNumInt32 -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord8 -> True + LitNumWord16 -> True + LitNumWord32 -> True + LitNumWord64 -> True +litIsTrivial _ = True + +-- | True if code space does not go bad if we duplicate this literal +litIsDupable :: Platform -> Literal -> Bool +-- c.f. GHC.Core.Utils.exprIsDupable +litIsDupable platform x = case x of + LitNumber nt i -> case nt of + LitNumBigNat -> i <= platformMaxWord platform * 8 -- arbitrary, reasonable + LitNumInt -> True + LitNumInt8 -> True + LitNumInt16 -> True + LitNumInt32 -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord8 -> True + LitNumWord16 -> True + LitNumWord32 -> True + LitNumWord64 -> True + LitString _ -> False + _ -> True + +litFitsInChar :: Literal -> Bool +litFitsInChar (LitNumber _ i) = i >= toInteger (ord minBound) + && i <= toInteger (ord maxBound) +litFitsInChar _ = False + +litIsLifted :: Literal -> Bool +litIsLifted (LitNumber nt _) = case nt of + LitNumBigNat -> True + LitNumInt -> False + LitNumInt8 -> False + LitNumInt16 -> False + LitNumInt32 -> False + LitNumInt64 -> False + LitNumWord -> False + LitNumWord8 -> False + LitNumWord16 -> False + LitNumWord32 -> False + LitNumWord64 -> False +litIsLifted _ = False + -- Even RUBBISH[LiftedRep] is unlifted, as rubbish values are always evaluated. + +{- + Types + ~~~~~ +-} + +-- | Find the Haskell 'Type' the literal occupies +literalType :: Literal -> Type +literalType LitNullAddr = addrPrimTy +literalType (LitChar _) = charPrimTy +literalType (LitString _) = addrPrimTy +literalType (LitFloat _) = floatPrimTy +literalType (LitDouble _) = doublePrimTy +literalType (LitLabel _ _) = addrPrimTy +literalType (LitNumber lt _) = case lt of + LitNumBigNat -> byteArrayPrimTy + LitNumInt -> intPrimTy + LitNumInt8 -> int8PrimTy + LitNumInt16 -> int16PrimTy + LitNumInt32 -> int32PrimTy + LitNumInt64 -> int64PrimTy + LitNumWord -> wordPrimTy + LitNumWord8 -> word8PrimTy + LitNumWord16 -> word16PrimTy + LitNumWord32 -> word32PrimTy + LitNumWord64 -> word64PrimTy + +-- LitRubbish: see Note [Rubbish literals] +literalType (LitRubbish torc rep) + = mkForAllTy (Bndr a Inferred) (mkTyVarTy a) + where + a = mkTemplateKindVar (typeOrConstraintKind torc rep) + +{- + Comparison + ~~~~~~~~~~ +-} + +cmpLit :: Literal -> Literal -> Ordering +cmpLit (LitChar a) (LitChar b) = a `compare` b +cmpLit (LitString a) (LitString b) = a `compare` b +cmpLit (LitNullAddr) (LitNullAddr) = EQ +cmpLit (LitFloat a) (LitFloat b) = a `compare` b +cmpLit (LitDouble a) (LitDouble b) = a `compare` b +cmpLit (LitLabel a _) (LitLabel b _) = a `lexicalCompareFS` b +cmpLit (LitNumber nt1 a) (LitNumber nt2 b) + = (nt1 `compare` nt2) `mappend` (a `compare` b) +cmpLit (LitRubbish tc1 b1) (LitRubbish tc2 b2) = (tc1 `compare` tc2) `mappend` + (b1 `nonDetCmpType` b2) +cmpLit lit1 lit2 + | isTrue# (dataToTag# lit1 <# dataToTag# lit2) = LT + | otherwise = GT + +{- + Printing + ~~~~~~~~ +* See Note [Printing of literals in Core] +-} + +pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc +pprLiteral _ (LitChar c) = pprPrimChar c +pprLiteral _ (LitString s) = pprHsBytes s +pprLiteral _ (LitNullAddr) = text "__NULL" +pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix +pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix +pprLiteral _ (LitNumber nt i) + = case nt of + LitNumBigNat -> integer i + LitNumInt -> pprPrimInt i + LitNumInt8 -> pprPrimInt8 i + LitNumInt16 -> pprPrimInt16 i + LitNumInt32 -> pprPrimInt32 i + LitNumInt64 -> pprPrimInt64 i + LitNumWord -> pprPrimWord i + LitNumWord8 -> pprPrimWord8 i + LitNumWord16 -> pprPrimWord16 i + LitNumWord32 -> pprPrimWord32 i + LitNumWord64 -> pprPrimWord64 i +pprLiteral add_par (LitLabel l fod) = + add_par (text "__label" <+> pprHsString l <+> ppr fod) +pprLiteral _ (LitRubbish torc rep) + = text "RUBBISH" <> pp_tc <> parens (ppr rep) + where + pp_tc = case torc of + TypeLike -> empty + ConstraintLike -> text "[c]" + +{- +Note [Printing of literals in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function `add_par` is used to wrap parenthesis around labels (`LitLabel`), +if they occur in a context requiring an atomic thing (for example function +application). + +Although not all Core literals would be valid Haskell, we are trying to stay +as close as possible to Haskell syntax in the printing of Core, to make it +easier for a Haskell user to read Core. + +To that end: + * We do print parenthesis around negative `LitInteger`, because we print + `LitInteger` using plain number literals (no prefix or suffix), and plain + number literals in Haskell require parenthesis in contexts like function + application (i.e. `1 - -1` is not valid Haskell). + + * We don't print parenthesis around other (negative) literals, because they + aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's + parser). + +Literal Output Output if context requires + an atom (if different) +------- ------- ---------------------- +LitChar 'a'# +LitString "aaa"# +LitNullAddr "__NULL" +LitInt -1# +LitIntN -1#N +LitWord 1## +LitWordN 1##N +LitFloat -1.0# +LitDouble -1.0## +LitBigNat 1 +LitLabel "__label" ... ("__label" ...) +LitRubbish "RUBBISH[...]" + +Note [Rubbish literals] +~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes, we need to cough up a rubbish value of a certain type that is used +in place of dead code we thus aim to eliminate. The value of a dead occurrence +has no effect on the dynamic semantics of the program, so we can pick any value +of the same representation. + +Exploiting the results of absence analysis in worker/wrapper is a scenario where +we need such a rubbish value, see examples in Note [Absent fillers] in +GHC.Core.Opt.WorkWrap.Utils. + +It's completely undefined what the *value* of a rubbish value is, e.g., we could +pick @0#@ for @Int#@ or @42#@; it mustn't matter where it's inserted into a Core +program. We embed these rubbish values in the 'LitRubbish' case of the 'Literal' +data type. Here are the moving parts: + +1. Source Haskell: No way to produce rubbish lits in source syntax. Purely + an IR feature. + +2. Core: 'LitRubbish' carries a `Type` of kind RuntimeRep, + describing the runtime representation of the literal (is it a + pointer, an unboxed Double#, or whatever). + + We have it that `RUBBISH[rr]` has type `forall (a :: TYPE rr). a`. + See the `LitRubbish` case of `literalType`. + + The function GHC.Core.Make.mkLitRubbish makes a Core rubbish literal of + a given type. It obeys the following invariants: + + INVARIANT 1: 'rr' has no free variables. Main reason: we don't need to run + substitutions and free variable finders over Literal. The rules around + levity/runtime-rep polymorphism naturally uphold this invariant. + + INVARIANT 2: we never make a rubbish literal of type (a ~# b). Reason: + see Note [Core type and coercion invariant] in GHC.Core. We can't substitute + a LitRubbish inside a coercion, so it's best not to make one. They are zero + width anyway, so passing absent ones around costs nothing. If we wanted + an absent filler of type (a ~# b) we should use (Coercion (UnivCo ...)), + but it doesn't seem worth making a new UnivCoProvenance for this purpose. + + This is sad, though: see #18983. + +3. STG: The type app in `RUBBISH[IntRep] @Int# :: Int#` is erased and we get + the (untyped) 'StgLit' `RUBBISH[IntRep] :: Int#` in STG. + + It's treated mostly opaque, with the exception of the Unariser, where we + take apart a case scrutinisation on, or arg occurrence of, e.g., + `RUBBISH[TupleRep[IntRep,DoubleRep]]` (which may stand in for `(# Int#, Double# #)`) + into its sub-parts `RUBBISH[IntRep]` and `RUBBISH[DoubleRep]`, similar to + unboxed tuples. + + See 'unariseLiteral_maybe' and also Note [Post-unarisation invariants]. + +4. Cmm: We translate 'LitRubbish' to their actual rubbish value in 'cgLit'. + The particulars are boring, and only matter when debugging illicit use of + a rubbish value; see Modes of failure below. + +5. Bytecode: In GHC.ByteCode.Asm we just lower it as a 0 literal, because it's + all boxed to the host GC anyway. + +6. IfaceSyn: `Literal` is part of `IfaceSyn`, but `Type` really isn't. So in + the passage from Core to Iface we put LitRubbish into its own IfaceExpr data + constructor, IfaceLitRubbish. The remaining constructors of Literal are + fine as IfaceSyn. + +Wrinkles + +a) Why do we put the `Type` (of kind RuntimeRep) inside the literal? Could + we not instead /apply/ the literal to that RuntimeRep? Alas no, because + then LitRubbish :: forall (rr::RuntimeRep) (a::TYPE rr). a + and that's an ill-formed type because its kind is `TYPE rr`, which escapes + the binding site of `rr`. Annoying. + +b) A rubbish literal is not bottom, and replies True to exprOkForSpeculation. + For unboxed types there is no bottom anyway. If we have + let (x::Int#) = RUBBISH[IntRep] @Int# + we want to convert that to a case! We want to leave it as a let, and + probably discard it as dead code soon after because x is unused. + +c) We can see a rubbish literal at the head of an application chain. + Most obviously, pretty much every rubbish literal is the head of a + type application e.g. `RUBBISH[IntRep] @Int#`. But see also + Note [How a rubbish literal can be the head of an application] + +c) Literal is in Ord, because (and only because) we use Ord on AltCon when + building a TypeMap. Annoying. We use `nonDetCmpType` here; the + non-determinism won't matter because it's only used in TrieMap. + Moreover, rubbish literals should not appear in patterns anyway. + +d) Why not lower LitRubbish in CoreToStg? Because it enables us to use + LitRubbish when unarising unboxed sums in the future, and it allows + rubbish values of e.g. VecRep, for which we can't cough up dummy + values in STG. + +Modes of failure +---------------- +Suppose there is a bug in GHC, and a rubbish value is used after all. That is +undefined behavior, of course, but let us list a few examples for failure modes: + + a) For an value of unboxed numeric type like `Int#`, we just use a silly + value like 42#. The error might propagate indefinitely, hence we better + pick a rather unique literal. Same for Word, Floats, Char and VecRep. + b) For AddrRep (like String lits), we emit a null pointer, resulting in a + definitive segfault when accessed. + c) For boxed values, unlifted or not, we use a pointer to a fixed closure, + like `()`, so that the GC has a pointer to follow. + If we use that pointer as an 'Array#', we will likely access fields of the + array that don't exist, and a seg-fault is likely, but not guaranteed. + If we use that pointer as `Either Int Bool`, we might try to access the + 'Int' field of the 'Left' constructor (which has the same ConTag as '()'), + which doesn't exists. In the best case, we'll find an invalid pointer in its + position and get a seg-fault, in the worst case the error manifests only one + or two indirections later. + +Note [How a rubbish literal can be the head of an application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#19824): + + h :: T3 -> Int -> blah + h _ (I# n) = ... + + f :: (T1 -> T2 -> T3) -> T4 -> blah + f g x = ....(h (g n s) x)... + +Demand analysis finds that h does not use its first argument, and w/w's h to + + {-# INLINE h #-} + h a b = case b of I# n -> $wh n + +Demand analysis also finds that f does not use its first arg, +so the worker for f look like + + $wf x = let g = RUBBISH in + ....(h (g n s) x)... + +Now we inline g to get: + + $wf x = ....(h (RUBBISH n s) x)... + +And lo, until we inline `h`, we have that application of +RUBBISH in $wf's RHS. But surely `h` will inline? Not if the +arguments look boring. Well, RUBBISH doesn't look boring. But it +could be a bit more complicated like + f g x = let t = ...(g n s)... + in ...(h t x)... + +and now the call looks more boring. Anyway, the point is that we +might reasonably see RUBBISH at the head of an application chain. + +It would be fine to rewrite + RUBBISH @(ta->tb->tr) a b ---> RUBBISH @tr +but we don't currently do so. + +It is NOT ok to discard the entire continuation: + case RUBBISH @ty of DEFAULT -> blah +does not return RUBBISH! +-} diff --git a/GHC/Types/Meta.hs b/GHC/Types/Meta.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Meta.hs @@ -0,0 +1,86 @@ +-- | Metaprogramming types +module GHC.Types.Meta + ( MetaRequest(..) + , MetaHook + , MetaResult -- data constructors not exported to ensure correct response type + , metaRequestE + , metaRequestP + , metaRequestT + , metaRequestD + , metaRequestAW + ) +where + +import GHC.Prelude + +import GHC.Serialized ( Serialized ) + +import GHC.Hs +import GHC.Utils.Outputable +import GHC.Utils.Panic + + +-- | The supported metaprogramming result types +data MetaRequest + = MetaE (LHsExpr GhcPs -> MetaResult) + | MetaP (LPat GhcPs -> MetaResult) + | MetaT (LHsType GhcPs -> MetaResult) + | MetaD ([LHsDecl GhcPs] -> MetaResult) + | MetaAW (Serialized -> MetaResult) + +-- | data constructors not exported to ensure correct result type +data MetaResult + = MetaResE (LHsExpr GhcPs) + | MetaResP (LPat GhcPs) + | MetaResT (LHsType GhcPs) + | MetaResD [LHsDecl GhcPs] + | MetaResAW Serialized + +instance Outputable MetaResult where + ppr (MetaResE e) = text "MetaResE" <> braces (ppr e) + ppr (MetaResP p) = text "MetaResP" <> braces (ppr p) + ppr (MetaResT t) = text "MetaResT" <> braces (ppr t) + ppr (MetaResD d) = text "MetaResD" <> braces (ppr d) + ppr (MetaResAW aw) = text "MetaResAW" <> braces (ppr aw) + +-- These unMetaResE ext panics will triger if the MetaHook doesn't +-- take an expression to an expression, pattern to pattern etc. +-- +-- ToDo: surely this could be expressed in the type system? +unMetaResE :: MetaResult -> LHsExpr GhcPs +unMetaResE (MetaResE e) = e +unMetaResE mr = pprPanic "unMetaResE" (ppr mr) + +unMetaResP :: MetaResult -> LPat GhcPs +unMetaResP (MetaResP p) = p +unMetaResP mr = pprPanic "unMetaResP" (ppr mr) + +unMetaResT :: MetaResult -> LHsType GhcPs +unMetaResT (MetaResT t) = t +unMetaResT mr = pprPanic "unMetaResT" (ppr mr) + +unMetaResD :: MetaResult -> [LHsDecl GhcPs] +unMetaResD (MetaResD d) = d +unMetaResD mr = pprPanic "unMetaResD" (ppr mr) + +unMetaResAW :: MetaResult -> Serialized +unMetaResAW (MetaResAW aw) = aw +unMetaResAW mr = pprPanic "unMetaResAW" (ppr mr) + +type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult + +metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs) +metaRequestE h = fmap unMetaResE . h (MetaE MetaResE) + +metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs) +metaRequestP h = fmap unMetaResP . h (MetaP MetaResP) + +metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs) +metaRequestT h = fmap unMetaResT . h (MetaT MetaResT) + +metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs] +metaRequestD h = fmap unMetaResD . h (MetaD MetaResD) + +metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized +metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW) + diff --git a/GHC/Types/Name.hs b/GHC/Types/Name.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name.hs @@ -0,0 +1,909 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- instance NFData FieldLabel + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Name]{@Name@: to transmit name info from renamer to typechecker} +-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types" +-- +-- * 'GHC.Types.Name.Reader.RdrName': see "GHC.Types.Name.Reader#name_types" +-- +-- * 'GHC.Types.Name.Name' is the type of names that have had their scoping and +-- binding resolved. They have an 'OccName' but also a 'GHC.Types.Unique.Unique' +-- that disambiguates Names that have the same 'OccName' and indeed is used for all +-- 'Name' comparison. Names also contain information about where they originated +-- from, see "GHC.Types.Name#name_sorts" +-- +-- * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types" +-- +-- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types" +-- +-- #name_sorts# +-- Names are one of: +-- +-- * External, if they name things declared in other modules. Some external +-- Names are wired in, i.e. they name primitives defined in the compiler itself +-- +-- * Internal, if they name things in the module being compiled. Some internal +-- Names are system names, if they are names manufactured by the compiler + +module GHC.Types.Name ( + -- * The main types + Name, -- Abstract + BuiltInSyntax(..), + + -- ** Creating 'Name's + mkSystemName, mkSystemNameAt, + mkInternalName, mkClonedInternalName, mkDerivedInternalName, + mkSystemVarName, mkSysTvName, + mkFCallName, + mkExternalName, mkWiredInName, + + -- ** Manipulating and deconstructing 'Name's + nameUnique, setNameUnique, + nameOccName, nameNameSpace, nameModule, nameModule_maybe, + setNameLoc, + tidyNameOcc, + localiseName, + namePun_maybe, + + pprName, pprName_userQual, + nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, + pprFullName, pprFullNameWithUnique, pprTickyName, + + -- ** Predicates on 'Name's + isSystemName, isInternalName, isExternalName, + isTyVarName, isTyConName, isDataConName, + isValName, isVarName, isDynLinkName, isFieldName, + isWiredInName, isWiredIn, isBuiltInSyntax, isTupleTyConName, + isSumTyConName, + isUnboxedTupleDataConLikeName, + isHoleName, + wiredInNameTyThing_maybe, + nameIsLocalOrFrom, nameIsExternalOrFrom, nameIsHomePackage, + nameIsHomePackageImport, nameIsFromExternalPackage, + stableNameCmp, + + -- * Class 'NamedThing' and overloaded friends + NamedThing(..), + getSrcLoc, getSrcSpan, getOccString, getOccFS, + + pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified, + nameStableString, + + -- Re-export the OccName stuff + module GHC.Types.Name.Occurrence + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Types.TyThing ( TyThing ) +import {-# SOURCE #-} GHC.Builtin.Types ( listTyCon ) + +import GHC.Platform +import GHC.Types.Name.Occurrence +import GHC.Unit.Module +import GHC.Unit.Home +import GHC.Types.FieldLabel +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Binary +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.OldList (intersperse) + +import Control.DeepSeq +import Data.Data +import qualified Data.Semigroup as S +import GHC.Types.Basic (Boxity(Boxed, Unboxed)) +import GHC.Builtin.Uniques ( isTupleTyConUnique, isCTupleTyConUnique, + isSumTyConUnique, isTupleDataConLikeUnique ) + +{- +************************************************************************ +* * +\subsection[Name-datatype]{The @Name@ datatype, and name construction} +* * +************************************************************************ +-} + +-- | A unique, unambiguous name for something, containing information about where +-- that thing originated. +data Name = Name + { n_sort :: NameSort + -- ^ What sort of name it is + + , n_occ :: OccName + -- ^ Its occurrence name. + -- + -- NOTE: kept lazy to allow known names to be known constructor applications + -- and to inline better. See Note [Fast comparison for built-in Names] + + , n_uniq :: {-# UNPACK #-} !Unique + -- ^ Its unique. + + , n_loc :: !SrcSpan + -- ^ Definition site + -- + -- NOTE: we make the n_loc field strict to eliminate some potential + -- (and real!) space leaks, due to the fact that we don't look at + -- the SrcLoc in a Name all that often. + } + +-- See Note [About the NameSorts] +data NameSort + = External Module + -- Either an import from another module + -- or a top-level name + -- See Note [About the NameSorts] + + | WiredIn Module TyThing BuiltInSyntax + -- A variant of External, for wired-in things + + | Internal -- A user-defined local Id or TyVar + -- defined in the module being compiled + -- See Note [About the NameSorts] + + | System -- A system-defined Id or TyVar. Typically the + -- OccName is very uninformative (like 's') + +instance Outputable NameSort where + ppr (External _) = text "external" + ppr (WiredIn _ _ _) = text "wired-in" + ppr Internal = text "internal" + ppr System = text "system" + +instance NFData Name where + rnf Name{..} = rnf n_sort `seq` rnf n_occ `seq` n_uniq `seq` rnf n_loc + +-- Needs NFData Name, so the instance is here to avoid cyclic imports. +instance NFData FieldLabel where + rnf (FieldLabel a b c) = rnf a `seq` rnf b `seq` rnf c + +instance NFData NameSort where + rnf (External m) = rnf m + rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () + -- XXX this is a *lie*, we're not going to rnf the TyThing, but + -- since the TyThings for WiredIn Names are all static they can't + -- be hiding space leaks or errors. + rnf Internal = () + rnf System = () + +-- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, +-- which have special syntactic forms. They aren't in scope +-- as such. +data BuiltInSyntax = BuiltInSyntax | UserSyntax + +{- +Note [Fast comparison for built-in Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this wired-in Name in GHC.Builtin.Names: + + int8TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int8") int8TyConKey + +Ultimately this turns into something like: + + int8TyConName = Name gHC_INTERNAL_INT (mkOccName ..."Int8") int8TyConKey + +So a comparison like `x == int8TyConName` will turn into `getUnique x == +int8TyConKey`, nice and efficient. But if the `n_occ` field is strict, that +definition will look like: + + int8TyConName = case (mkOccName..."Int8") of occ -> + Name gHC_INTERNAL_INT occ int8TyConKey + +and now the comparison will not optimise. This matters even more when there are +numerous comparisons (see #19386): + +if | tc == int8TyCon -> ... + | tc == int16TyCon -> ... + ...etc... + +when we would like to get a single multi-branched case. + +TL;DR: we make the `n_occ` field lazy. +-} + +{- +Note [About the NameSorts] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Initially: + * All types, classes, data constructors get External Names + * Top-level Ids (including locally-defined ones) get External Names, + * All other local (non-top-level) Ids get Internal names + +2. In the Tidy phase (GHC.Iface.Tidy): + * An Id that is "externally-visible" is given an External Name, + even if the name was Internal up to that point + * An Id that is not externally visible is given an Internal Name. + even if the name was External up to that point + See GHC.Iface.Tidy.tidyTopName + + An Id is externally visible if it is mentioned in the interface file; e.g. + - it is exported + - it is mentioned in an unfolding + See GHC.Iface.Tidy.chooseExternalIds + +3. In any invocation of GHC, an External Name for "M.x" has one and only one + unique. This unique association is ensured via the Name Cache; + see Note [The Name Cache] in GHC.Iface.Env. + +4. In code generation, things with a External name are given C static + labels, so they finally appear in the .o file's symbol table. They + appear in the symbol table in the form M.n. That is why + externally-visible things are made External (see (2) above). + + +5. A System Name differs in the following ways: + a) has unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible + + Before anything gets printed in interface files or output code, it's + fed through a 'tidy' processor, which zaps the OccNames to have + unique names; and converts all sys-locals to user locals + If any desugarer sys-locals have survived that far, they get changed to + "ds1", "ds2", etc. + +6. A WiredIn Name is used for things (Id, TyCon) that are fully known to the compiler, + not read from an interface file. E.g. Bool, True, Int, Float, and many others. + + A WiredIn Name contains contains a TyThing, so we don't have to look it up. + + The BuiltInSyntax flag => It's a syntactic form, not "in scope" (e.g. []) + All built-in syntax things are WiredIn. +-} + +instance HasOccName Name where + occName = nameOccName + +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameNameSpace :: Name -> NameSpace +nameModule :: HasDebugCallStack => Name -> Module +nameSrcLoc :: Name -> SrcLoc +nameSrcSpan :: Name -> SrcSpan + +nameUnique name = n_uniq name +nameOccName name = n_occ name +nameNameSpace name = occNameSpace (n_occ name) +nameSrcLoc name = srcSpanStart (n_loc name) +nameSrcSpan name = n_loc name + +{- +************************************************************************ +* * +\subsection{Predicates on names} +* * +************************************************************************ +-} + +isInternalName :: Name -> Bool +isExternalName :: Name -> Bool +isSystemName :: Name -> Bool +isWiredInName :: Name -> Bool + +isWiredInName (Name {n_sort = WiredIn _ _ _}) = True +isWiredInName _ = False + +isWiredIn :: NamedThing thing => thing -> Bool +isWiredIn = isWiredInName . getName + +wiredInNameTyThing_maybe :: Name -> Maybe TyThing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing +wiredInNameTyThing_maybe _ = Nothing + +isBuiltInSyntax :: Name -> Bool +isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True +isBuiltInSyntax _ = False + +isTupleTyConName :: Name -> Bool +isTupleTyConName = isJust . isTupleTyConUnique . getUnique + +isSumTyConName :: Name -> Bool +isSumTyConName = isJust . isSumTyConUnique . getUnique + +-- | This matches a datacon as well as its worker and promoted tycon. +isUnboxedTupleDataConLikeName :: Name -> Bool +isUnboxedTupleDataConLikeName n + | Just (Unboxed, _) <- isTupleDataConLikeUnique (getUnique n) = True + | otherwise = False + +isExternalName (Name {n_sort = External _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _}) = True +isExternalName _ = False + +isInternalName name = not (isExternalName name) + +isHoleName :: Name -> Bool +isHoleName = isHoleModule . nameModule + +-- | Will the 'Name' come from a dynamically linked package? +isDynLinkName :: Platform -> Module -> Name -> Bool +isDynLinkName platform this_mod name + | Just mod <- nameModule_maybe name + -- Issue #8696 - when GHC is dynamically linked, it will attempt + -- to load the dynamic dependencies of object files at compile + -- time for things like QuasiQuotes or + -- TemplateHaskell. Unfortunately, this interacts badly with + -- intra-package linking, because we don't generate indirect + -- (dynamic) symbols for intra-package calls. This means that if a + -- module with an intra-package call is loaded without its + -- dependencies, then GHC fails to link. + -- + -- In the mean time, always force dynamic indirections to be + -- generated: when the module name isn't the module being + -- compiled, references are dynamic. + = case platformOS platform of + -- On Windows the hack for #8696 makes it unlinkable. + -- As the entire setup of the code from Cmm down to the RTS expects + -- the use of trampolines for the imported functions only when + -- doing intra-package linking, e.g. referring to a symbol defined in the same + -- package should not use a trampoline. + -- I much rather have dynamic TH not supported than the entire Dynamic linking + -- not due to a hack. + -- Also not sure this would break on Windows anyway. + OSMinGW32 -> moduleUnit mod /= moduleUnit this_mod + + -- For the other platforms, still perform the hack + _ -> mod /= this_mod + + | otherwise = False -- no, it is not even an external name + + +nameModule name = + nameModule_maybe name `orElse` + pprPanic "nameModule" (ppr (n_sort name) <+> ppr name) + +nameModule_maybe :: Name -> Maybe Module +nameModule_maybe (Name { n_sort = External mod}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod +nameModule_maybe _ = Nothing + +is_interactive_or_from :: Module -> Module -> Bool +is_interactive_or_from from mod = from == mod || isInteractiveModule mod + +-- Return the pun for a name if available. +-- Used for pretty-printing under ListTuplePuns. +-- Arity 1 is skipped here because unary tuples have no prefix representation, +-- since that is occupied by the unit tuple. +namePun_maybe :: Name -> Maybe FastString +namePun_maybe name + | getUnique name == getUnique listTyCon = Just (fsLit "[]") + + | Just (boxity, ar) <- isTupleTyConUnique (getUnique name) + , ar /= 1 + = let (lpar, rpar) = case boxity of + Boxed -> ("(", ")") + Unboxed -> ("(#", "#)") + in Just (fsLit $ lpar ++ commas ar ++ rpar) + + | Just ar <- isCTupleTyConUnique (getUnique name) + , ar /= 1 + = Just (fsLit $ "(" ++ commas ar ++ ")") + -- constraint tuples look just like boxed tuples + + | Just ar <- isSumTyConUnique (getUnique name) + = Just (fsLit $ "(# " ++ bars ar ++ " #)") + where + commas ar = replicate (ar-1) ',' + bars ar = intersperse ' ' (replicate (ar-1) '|') + +namePun_maybe _ = Nothing + +nameIsLocalOrFrom :: Module -> Name -> Bool +-- ^ Returns True if the name is +-- (a) Internal +-- (b) External but from the specified module +-- (c) External but from the 'interactive' package +-- +-- The key idea is that +-- False means: the entity is defined in some other module +-- you can find the details (type, fixity, instances) +-- in some interface file +-- those details will be stored in the EPT or HPT +-- +-- True means: the entity is defined in this module or earlier in +-- the GHCi session +-- you can find details (type, fixity, instances) in the +-- TcGblEnv or TcLclEnv +-- +-- The isInteractiveModule part is because successive interactions of a GHCi session +-- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come +-- from the magic 'interactive' package; and all the details are kept in the +-- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. +-- See Note [The interactive package] in "GHC.Runtime.Context" + +nameIsLocalOrFrom from name + | Just mod <- nameModule_maybe name = is_interactive_or_from from mod + | otherwise = True + +nameIsExternalOrFrom :: Module -> Name -> Bool +-- ^ Returns True if the name is external or from the 'interactive' package +-- See documentation of `nameIsLocalOrFrom` function +nameIsExternalOrFrom from name + | Just mod <- nameModule_maybe name = is_interactive_or_from from mod + | otherwise = False + +nameIsHomePackage :: Module -> Name -> Bool +-- True if the Name is defined in module of this package +nameIsHomePackage this_mod + = \nm -> case n_sort nm of + External nm_mod -> moduleUnit nm_mod == this_pkg + WiredIn nm_mod _ _ -> moduleUnit nm_mod == this_pkg + Internal -> True + System -> False + where + this_pkg = moduleUnit this_mod + +nameIsHomePackageImport :: Module -> Name -> Bool +-- True if the Name is defined in module of this package +-- /other than/ the this_mod +nameIsHomePackageImport this_mod + = \nm -> case nameModule_maybe nm of + Nothing -> False + Just nm_mod -> nm_mod /= this_mod + && moduleUnit nm_mod == this_pkg + where + this_pkg = moduleUnit this_mod + +-- | Returns True if the Name comes from some other package: neither this +-- package nor the interactive package. +nameIsFromExternalPackage :: HomeUnit -> Name -> Bool +nameIsFromExternalPackage home_unit name + | Just mod <- nameModule_maybe name + , notHomeModule home_unit mod -- Not the current unit + , not (isInteractiveModule mod) -- Not the 'interactive' package + = True + | otherwise + = False + +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) + +isTyConName :: Name -> Bool +isTyConName name = isTcOcc (nameOccName name) + +isDataConName :: Name -> Bool +isDataConName name = isDataOcc (nameOccName name) + +isValName :: Name -> Bool +isValName name = isValOcc (nameOccName name) + +isVarName :: Name -> Bool +isVarName = isVarOcc . nameOccName + +isFieldName :: Name -> Bool +isFieldName = isFieldOcc . nameOccName + +isSystemName (Name {n_sort = System}) = True +isSystemName _ = False + +{- +************************************************************************ +* * +\subsection{Making names} +* * +************************************************************************ +-} + +-- | Create a name which is (for now at least) local to the current module and hence +-- does not need a 'Module' to disambiguate it from other 'Name's +mkInternalName :: Unique -> OccName -> SrcSpan -> Name +mkInternalName uniq occ loc = Name { n_uniq = uniq + , n_sort = Internal + , n_occ = occ + , n_loc = loc } + -- NB: You might worry that after lots of huffing and + -- puffing we might end up with two local names with distinct + -- uniques, but the same OccName. Indeed we can, but that's ok + -- * the insides of the compiler don't care: they use the Unique + -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the + -- uniques if you get confused + -- * for interface files we tidyCore first, which makes + -- the OccNames distinct when they need to be + +mkClonedInternalName :: Unique -> Name -> Name +mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = uniq, n_sort = Internal + , n_occ = occ, n_loc = loc } + +mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name +mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = uniq, n_sort = Internal + , n_occ = derive_occ occ, n_loc = loc } + +-- | Create a name which definitely originates in the given module +mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name +{-# INLINE mkExternalName #-} +-- WATCH OUT! External Names should be in the Name Cache +-- (see Note [The Name Cache] in GHC.Iface.Env), so don't just call mkExternalName +-- with some fresh unique without populating the Name Cache +mkExternalName uniq mod occ loc + = Name { n_uniq = uniq, n_sort = External mod, + n_occ = occ, n_loc = loc } + +-- | Create a name which is actually defined by the compiler itself +mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name +{-# INLINE mkWiredInName #-} +mkWiredInName mod occ uniq thing built_in + = Name { n_uniq = uniq, + n_sort = WiredIn mod thing built_in, + n_occ = occ, n_loc = wiredInSrcSpan } + +-- | Create a name brought into being by the compiler +mkSystemName :: Unique -> OccName -> Name +mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan + +mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name +mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System + , n_occ = occ, n_loc = loc } + +mkSystemVarName :: Unique -> FastString -> Name +mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) + +mkSysTvName :: Unique -> FastString -> Name +mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) + +-- | Make a name for a foreign call +mkFCallName :: Unique -> FastString -> Name +mkFCallName uniq str = mkInternalName uniq (mkVarOccFS str) noSrcSpan + -- The encoded string completely describes the ccall + +-- When we renumber/rename things, we need to be +-- able to change a Name's Unique to match the cached +-- one in the thing it's the name of. If you know what I mean. +setNameUnique :: Name -> Unique -> Name +setNameUnique name uniq = name {n_uniq = uniq} + +-- This is used for hsigs: we want to use the name of the originally exported +-- entity, but edit the location to refer to the reexport site +setNameLoc :: Name -> SrcSpan -> Name +setNameLoc name loc = name {n_loc = loc} + +tidyNameOcc :: Name -> OccName -> Name +-- We set the OccName of a Name when tidying +-- In doing so, we change System --> Internal, so that when we print +-- it we don't get the unique by default. It's tidy now! +tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} +tidyNameOcc name occ = name { n_occ = occ } + +-- | Make the 'Name' into an internal name, regardless of what it was to begin with +localiseName :: Name -> Name +localiseName n = n { n_sort = Internal } + +{- +************************************************************************ +* * +\subsection{Hashing and comparison} +* * +************************************************************************ +-} + +cmpName :: Name -> Name -> Ordering +cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2 + +-- | Compare Names lexicographically +-- This only works for Names that originate in the source code or have been +-- tidied. +stableNameCmp :: Name -> Name -> Ordering +stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) + (Name { n_sort = s2, n_occ = occ2 }) + = sort_cmp s1 s2 S.<> compare occ1 occ2 + -- The ordinary compare on OccNames is lexicographic + where + -- Later constructors are bigger + sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 + sort_cmp (External {}) _ = LT + sort_cmp (WiredIn {}) (External {}) = GT + sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 + sort_cmp (WiredIn {}) _ = LT + sort_cmp Internal (External {}) = GT + sort_cmp Internal (WiredIn {}) = GT + sort_cmp Internal Internal = EQ + sort_cmp Internal System = LT + sort_cmp System System = EQ + sort_cmp System _ = GT + +{- +************************************************************************ +* * +\subsection[Name-instances]{Instance declarations} +* * +************************************************************************ +-} + +-- | The same comments as for `Name`'s `Ord` instance apply. +instance Eq Name where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +-- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which +-- means that the ordering is not stable across deserialization or rebuilds. +-- +-- See `nonDetCmpUnique` for further information, and #15240 for a bug +-- caused by improper use of this instance. + +-- For a deterministic lexicographic ordering, use `stableNameCmp`. +instance Ord Name where + compare = cmpName + +instance Uniquable Name where + getUnique = nameUnique + +instance NamedThing Name where + getName n = n + +instance Data Name where + -- don't traverse? + toConstr _ = abstractConstr "Name" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Name" + +{- +************************************************************************ +* * +\subsection{Binary} +* * +************************************************************************ +-} + +-- | Assumes that the 'Name' is a non-binding one. See +-- 'GHC.Iface.Syntax.putIfaceTopBndr' and 'GHC.Iface.Syntax.getIfaceTopBndr' for +-- serializing binding 'Name's. See 'UserData' for the rationale for this +-- distinction. +instance Binary Name where + put_ bh name = + case findUserDataWriter Proxy bh of + tbl -> putEntry tbl bh name + + get bh = + case findUserDataReader Proxy bh of + tbl -> getEntry tbl bh + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} + +instance Outputable Name where + ppr name = pprName name + +instance OutputableBndr Name where + pprBndr _ name = pprName name + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + +pprName :: forall doc. IsLine doc => Name -> doc +pprName = pprName_userQual Nothing + +pprName_userQual :: forall doc. IsLine doc => Maybe ModuleName -> Name -> doc +pprName_userQual user_qual name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) + = docWithStyle codeDoc normalDoc + where + codeDoc = case sort of + WiredIn mod _ _ -> pprModule mod <> char '_' <> z_occ + External mod -> pprModule mod <> char '_' <> z_occ + -- In code style, always qualify + -- ToDo: maybe we could print all wired-in things unqualified + -- in code style, to reduce symbol table bloat? + System -> pprUniqueAlways uniq + Internal -> pprUniqueAlways uniq + z_occ = ztext $ zEncodeFS $ occNameMangledFS occ + + normalDoc sty = + getPprDebug $ \debug -> + sdocOption sdocListTuplePuns $ \listTuplePuns -> + handlePuns listTuplePuns (namePun_maybe name) $ + case sort of + WiredIn mod _ builtin -> pprExternal debug sty uniq mod user_qual occ True builtin + External mod -> pprExternal debug sty uniq mod user_qual occ False UserSyntax + System -> pprSystem debug sty uniq occ + Internal -> pprInternal debug sty uniq occ + + handlePuns :: Bool -> Maybe FastString -> SDoc -> SDoc + handlePuns True (Just pun) _ = ftext pun + handlePuns _ _ r = r +{-# SPECIALISE pprName :: Name -> SDoc #-} +{-# SPECIALISE pprName :: Name -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Print fully qualified name (with unit-id and module, but no unique) +pprFullName :: Module -> Name -> SDoc +pprFullName this_mod Name{n_sort = sort, n_occ = occ} = + let mod = case sort of + WiredIn m _ _ -> m + External m -> m + System -> this_mod + Internal -> this_mod + in ftext (unitIdFS (moduleUnitId mod)) + <> colon <> ftext (moduleNameFS $ moduleName mod) + <> dot <> ftext (occNameFS occ) + +-- | Print fully qualified name (with unit-id and module, with the unique) +pprFullNameWithUnique :: Module -> Name -> SDoc +pprFullNameWithUnique this_mod Name{n_sort = sort, n_uniq = u, n_occ = occ} = + let mod = case sort of + WiredIn m _ _ -> m + External m -> m + System -> this_mod + Internal -> this_mod + in ftext (unitIdFS (moduleUnitId mod)) + <> colon <> ftext (moduleNameFS $ moduleName mod) + <> dot <> ftext (occNameFS occ) <> text "_" <> pprUniqueAlways u + +-- | Print a ticky ticky styled name +-- +-- Module argument is the module to use for internal and system names. When +-- printing the name in a ticky profile, the module name is included even for +-- local things. However, ticky uses the format "x (M)" rather than "M.x". +-- Hence, this function provides a separation from normal styling. +pprTickyName :: Module -> Name -> SDoc +pprTickyName this_mod name + | isInternalName name = pprName name <+> parens (ppr this_mod) + | otherwise = pprName name + +-- | Print the string of Name unqualifiedly directly. +pprNameUnqualified :: Name -> SDoc +pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ + +pprExternal :: Bool -> PprStyle -> Unique + -> Module -- ^ module the 'Name' is defined in + -> Maybe ModuleName -- ^ user module qualification + -> OccName + -> Bool -- ^ wired-in? + -> BuiltInSyntax + -> SDoc +pprExternal debug sty uniq mod user_qual occ is_wired is_builtin + | debug = pp_mod <> ppr_occ_name occ + <> braces (hsep [if is_wired then text "(w)" else empty, + pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax + | otherwise = + if isHoleModule mod + then case qualName sty mod user_qual occ of + NameUnqual -> ppr_occ_name occ + _ -> braces (pprModuleName (moduleName mod) <> dot <> ppr_occ_name occ) + else pprModulePrefix sty mod user_qual occ <> ppr_occ_name occ + where + pp_mod = ppUnlessOption sdocSuppressModulePrefixes + (pprModule mod <> dot) + +pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprInternal debug sty uniq occ + | debug = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq + -- For debug dumps, we're not necessarily dumping + -- tidied code, so we need to print the uniques. + | otherwise = ppr_occ_name occ -- User style + +-- Like Internal, except that we only omit the unique in Iface style +pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprSystem debug _sty uniq occ + | debug = ppr_occ_name occ <> ppr_underscore_unique uniq + <> braces (pprNameSpaceBrief (occNameSpace occ)) + | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq + -- If the tidy phase hasn't run, the OccName + -- is unlikely to be informative (like 's'), + -- so print the unique + + +pprModulePrefix :: PprStyle -> Module -> Maybe ModuleName -> OccName -> SDoc +-- Print the "M." part of a name, based on whether it's in scope or not +-- See Note [Printing original names] in GHC.Types.Name.Ppr +pprModulePrefix sty mod user_qual occ = ppUnlessOption sdocSuppressModulePrefixes $ + case qualName sty mod user_qual occ of -- See Outputable.QualifyName: + NameQual modname -> pprModuleName modname <> dot -- Name is in scope + NameNotInScope1 -> pprModule mod <> dot -- Not in scope + NameNotInScope2 -> pprUnit (moduleUnit mod) <> colon -- Module not in + <> pprModuleName (moduleName mod) <> dot -- scope either + NameUnqual -> empty -- In scope unqualified + +pprUnique :: Unique -> SDoc +-- Print a unique unless we are suppressing them +pprUnique uniq + = ppUnlessOption sdocSuppressUniques $ + pprUniqueAlways uniq + +ppr_underscore_unique :: Unique -> SDoc +-- Print an underscore separating the name from its unique +-- But suppress it if we aren't printing the uniques anyway +ppr_underscore_unique uniq + = ppUnlessOption sdocSuppressUniques $ + char '_' <> pprUniqueAlways uniq + +ppr_occ_name :: OccName -> SDoc +ppr_occ_name occ = ftext (occNameFS occ) + -- Don't use pprOccName; instead, just print the string of the OccName; + -- we print the namespace in the debug stuff above + +-- Prints (if mod information is available) "Defined at " or +-- "Defined in " information for a Name. +pprDefinedAt :: Name -> SDoc +pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name + +pprNameDefnLoc :: Name -> SDoc +-- Prints "at " or +-- or "in " depending on what info is available +pprNameDefnLoc name + = case nameSrcLoc name of + -- nameSrcLoc rather than nameSrcSpan + -- It seems less cluttered to show a location + -- rather than a span for the definition point + RealSrcLoc s _ -> text "at" <+> ppr s + UnhelpfulLoc s + | isInternalName name || isSystemName name + -> text "at" <+> ftext s + | otherwise + -> text "in" <+> quotes (ppr (nameModule name)) + + +-- | Get a string representation of a 'Name' that's unique and stable +-- across recompilations. Used for deterministic generation of binds for +-- derived instances. +-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String" +nameStableString :: Name -> String +nameStableString Name{..} = + nameSortStableString n_sort ++ "$" ++ occNameString n_occ + +nameSortStableString :: NameSort -> String +nameSortStableString System = "$_sys" +nameSortStableString Internal = "$_in" +nameSortStableString (External mod) = moduleStableString mod +nameSortStableString (WiredIn mod _ _) = moduleStableString mod + +{- +************************************************************************ +* * +\subsection{Overloaded functions related to Names} +* * +************************************************************************ +-} + +-- | A class allowing convenient access to the 'Name' of various datatypes +class NamedThing a where + getOccName :: a -> OccName + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method + +instance NamedThing e => NamedThing (Located e) where + getName = getName . unLoc + +getSrcLoc :: NamedThing a => a -> SrcLoc +getSrcSpan :: NamedThing a => a -> SrcSpan +getOccString :: NamedThing a => a -> String +getOccFS :: NamedThing a => a -> FastString + +getSrcLoc = nameSrcLoc . getName +getSrcSpan = nameSrcSpan . getName +getOccString = occNameString . getOccName +getOccFS = occNameFS . getOccName + +pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc +-- See Outputable.pprPrefixVar, pprInfixVar; +-- add parens or back-quotes as appropriate +pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) + +pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc +pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr thing) + where + name = getName thing diff --git a/GHC/Types/Name.hs-boot b/GHC/Types/Name.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/Name.hs-boot @@ -0,0 +1,31 @@ +module GHC.Types.Name ( + module GHC.Types.Name, + module GHC.Types.Name.Occurrence +) where + +import GHC.Prelude (Eq, Bool) +import {-# SOURCE #-} GHC.Types.Name.Occurrence +import GHC.Types.Unique +import GHC.Utils.Outputable +import Data.Data (Data) +import Control.DeepSeq (NFData) + +data Name + +instance Eq Name +instance Data Name +instance Uniquable Name +instance Outputable Name +instance NFData Name + +class NamedThing a where + getOccName :: a -> OccName + getName :: a -> Name + + getOccName n = nameOccName (getName n) + +nameUnique :: Name -> Unique +setNameUnique :: Name -> Unique -> Name +nameOccName :: Name -> OccName +tidyNameOcc :: Name -> OccName -> Name +isFieldName :: Name -> Bool diff --git a/GHC/Types/Name/Cache.hs b/GHC/Types/Name/Cache.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Cache.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE RankNTypes #-} + +-- | The Name Cache +module GHC.Types.Name.Cache + ( NameCache (..) + , newNameCache + , newNameCacheWith + , initNameCache + , takeUniqFromNameCache + , updateNameCache' + , updateNameCache + + -- * OrigNameCache + , OrigNameCache + , lookupOrigNameCache + , extendOrigNameCache' + , extendOrigNameCache + + -- * Known-key names + , knownKeysOrigNameCache + , isKnownOrigName_maybe + ) +where + +import GHC.Prelude + +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Unique.Supply +import GHC.Builtin.Types +import GHC.Builtin.Names +import GHC.Builtin.Utils + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Applicative +import Control.Concurrent.MVar +import Control.Monad + +{- + +Note [The Name Cache] +~~~~~~~~~~~~~~~~~~~~~ +The Name Cache makes sure that, during any invocation of GHC, each +External Name "M.x" has one, and only one globally-agreed Unique. + +* The first time we come across M.x we make up a Unique and record that + association in the Name Cache. + +* When we come across "M.x" again, we look it up in the Name Cache, + and get a hit. + +The functions newGlobalBinder, allocateGlobalBinder do the main work. +When you make an External name, you should probably be calling one +of them. + +Names in a NameCache are always stored as a Global, and have the SrcLoc of their +binding locations. Actually that's not quite right. When we first encounter +the original name, we might not be at its binding site (e.g. we are reading an +interface file); so we give it 'noSrcLoc' then. Later, when we find its binding +site, we fix it up. + + +Note [Built-in syntax and the OrigNameCache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Built-in syntax refers to names that are always in scope and can't be imported +or exported. Such names come in two varieties: + +* Simple names (finite): `[]`, `:`, `->` +* Families of names (infinite): + * boxed tuples `()`, `(,)`, `(,,)`, `(,,,)`, ... + * unboxed tuples `(##)`, `(#,#)`, `(#,,#)`, ... + * unboxed sum type syntax `(#|#)`, `(#||#)`, `(#|||#)`, ... + * unboxed sum data syntax `(#_|#)`, `(#|_#)`, `(#_||#), ... + +Concretely, a built-in name is a WiredIn Name that has a BuiltInSyntax flag. + +Historically, GHC used to avoid putting any built-in syntax in the OrigNameCache +to avoid dealing with infinite families of names (tuples and sums). This measure +has become inadequate with the introduction of NoListTuplePuns (GHC Proposal #475). +Nowadays tuples and sums also use Names that are WiredIn, but are not BuiltInSyntax: + +* boxed tuples (tycons): Unit, Solo, Tuple2, Tuple3, Tuple4, ... +* unboxed tuples (tycons): Unit#, Solo#, Tuple2#, Tuple3#, Tuple4#, ... +* constraint tuples (tycons): CUnit, CSolo, CTuple2, CTuple3, CTuple4, ... +* one-tuples (datacons): MkSolo, MkSolo# + +We can't put infinitely many names in a finite data structure (OrigNameCache). +So we deal with them in lookupOrigNameCache by means of isInfiniteFamilyOrigName_maybe. + +At the same time, simple finite built-in names (`[]`, `:`, `->`) can be put in +the OrigNameCache without any issues (they end up there because they're +knownKeyNames). It doesn't matter that they're built-in syntax. + +One might wonder: what's the point of having any built-in syntax in the +OrigNameCache at all? Good question; after all, + 1) The parser emits built-in and punned syntax directly as Exact RdrNames + 2) Template Haskell conversion (GHC.ThToHs) matches on built-in and punned + syntax directly to immediately produce Exact names (GHC.ThToHs.thRdrName) + 3) Loading of interface files encodes names via Uniques, as detailed in + Note [Symbol table representation of names] in GHC.Iface.Binary + +It turns out that we end up looking up built-in syntax in the cache when we +generate Haddock documentation. E.g. if we don't find tuple data constructors +there, hyperlinks won't work as expected. Test case: haddockHtmlTest (Bug923.hs) +-} + +-- | The NameCache makes sure that there is just one Unique assigned for +-- each original name; i.e. (module-name, occ-name) pair and provides +-- something of a lookup mechanism for those names. +data NameCache = NameCache + { nsUniqChar :: {-# UNPACK #-} !Char + , nsNames :: {-# UNPACK #-} !(MVar OrigNameCache) + } + +-- | Per-module cache of original 'OccName's given 'Name's +type OrigNameCache = ModuleEnv (OccEnv Name) + +takeUniqFromNameCache :: NameCache -> IO Unique +takeUniqFromNameCache (NameCache c _) = uniqFromTag c + +lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name +lookupOrigNameCache nc mod occ = lookup_infinite <|> lookup_normal + where + -- See Note [Known-key names], 3(c) in GHC.Builtin.Names + -- and Note [Infinite families of known-key names] + lookup_infinite = isInfiniteFamilyOrigName_maybe mod occ + lookup_normal = do + occ_env <- lookupModuleEnv nc mod + lookupOccEnv occ_env occ + +extendOrigNameCache' :: OrigNameCache -> Name -> OrigNameCache +extendOrigNameCache' nc name + = assertPpr (isExternalName name) (ppr name) $ + extendOrigNameCache nc (nameModule name) (nameOccName name) name + +extendOrigNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache +extendOrigNameCache nc mod occ name + = extendModuleEnvWith combine nc mod (unitOccEnv occ name) + where + combine _ occ_env = extendOccEnv occ_env occ name + +-- | Initialize a new name cache +newNameCache :: IO NameCache +newNameCache = newNameCacheWith 'r' knownKeysOrigNameCache + +-- | This is a version of `newNameCache` that lets you supply your +-- own unique tag and set of known key names. This can go wrong if the tag +-- supplied is one reserved by GHC for internal purposes. See #26055 for +-- an example. +-- +-- Use `newNameCache` when possible. +newNameCacheWith :: Char -> OrigNameCache -> IO NameCache +newNameCacheWith c nc = NameCache c <$> newMVar nc + +-- | This takes a tag for uniques to be generated and the list of knownKeyNames +-- These must be initialized properly to ensure that names generated from this +-- NameCache do not conflict with known key names. +-- +-- Use `newNameCache` or `newNameCacheWith` instead +{-# DEPRECATED initNameCache "Use newNameCache or newNameCacheWith instead" #-} +initNameCache :: Char -> [Name] -> IO NameCache +initNameCache c names = newNameCacheWith c (initOrigNames names) + +initOrigNames :: [Name] -> OrigNameCache +initOrigNames names = foldl' extendOrigNameCache' emptyModuleEnv names + +-- | Update the name cache with the given function +updateNameCache' + :: NameCache + -> (OrigNameCache -> IO (OrigNameCache, c)) -- The updating function + -> IO c +updateNameCache' (NameCache _c nc) upd_fn = modifyMVar' nc upd_fn + +-- this should be in `base` +modifyMVar' :: MVar a -> (a -> IO (a,b)) -> IO b +modifyMVar' m f = modifyMVar m $ f >=> \c -> fst c `seq` pure c + +-- | Update the name cache with the given function +-- +-- Additionally, it ensures that the given Module and OccName are evaluated. +-- If not, chaos can ensue: +-- we read the name-cache +-- then pull on mod (say) +-- which does some stuff that modifies the name cache +-- This did happen, with tycon_mod in GHC.IfaceToCore.tcIfaceAlt (DataAlt..) +updateNameCache + :: NameCache + -> Module + -> OccName + -> (OrigNameCache -> IO (OrigNameCache, c)) + -> IO c +updateNameCache name_cache !_mod !_occ upd_fn + = updateNameCache' name_cache upd_fn + +{-# NOINLINE knownKeysOrigNameCache #-} +knownKeysOrigNameCache :: OrigNameCache +knownKeysOrigNameCache = initOrigNames knownKeyNames + +isKnownOrigName_maybe :: Module -> OccName -> Maybe Name +isKnownOrigName_maybe = lookupOrigNameCache knownKeysOrigNameCache diff --git a/GHC/Types/Name/Env.hs b/GHC/Types/Name/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Env.hs @@ -0,0 +1,218 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[NameEnv]{@NameEnv@: name environments} +-} + +module GHC.Types.Name.Env ( + -- * Var, Id and TyVar environments (maps) + NameEnv, + + -- ** Manipulating these environments + mkNameEnv, mkNameEnvWith, + fromUniqMap, + emptyNameEnv, isEmptyNameEnv, + unitNameEnv, nonDetNameEnvElts, + extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, + extendNameEnvList, extendNameEnvList_C, + filterNameEnv, anyNameEnv, + mapMaybeNameEnv, + extendNameEnvListWith, + plusNameEnv, plusNameEnv_C, plusNameEnv_CD, plusNameEnv_CD2, alterNameEnv, + plusNameEnvList, plusNameEnvListWith, + lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, + elemNameEnv, mapNameEnv, disjointNameEnv, + seqEltsNameEnv, + + DNameEnv, + + emptyDNameEnv, + isEmptyDNameEnv, + lookupDNameEnv, + delFromDNameEnv, filterDNameEnv, + mapDNameEnv, + adjustDNameEnv, alterDNameEnv, extendDNameEnv, + eltsDNameEnv, extendDNameEnv_C, + plusDNameEnv_C, + foldDNameEnv, + nonDetStrictFoldDNameEnv, + -- ** Dependency analysis + depAnal + ) where + +import GHC.Prelude + +import GHC.Data.Graph.Directed +import GHC.Types.Name +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique.Map +import GHC.Data.Maybe + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +{- +Note [depAnal determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +depAnal is deterministic provided it gets the nodes in a deterministic order. +The order of lists that get_defs and get_uses return doesn't matter, as these +are only used to construct the edges, and stronglyConnCompFromEdgedVertices is +deterministic even when the edges are not in deterministic order as explained +in Note [Deterministic SCC] in GHC.Data.Graph.Directed. +-} + +depAnal :: forall node. + (node -> [Name]) -- Defs + -> (node -> [Name]) -- Uses + -> [node] + -> [SCC node] +-- Perform dependency analysis on a group of definitions, +-- where each definition may define more than one Name +-- +-- The get_defs and get_uses functions are called only once per node +depAnal get_defs get_uses nodes + = stronglyConnCompFromEdgedVerticesUniq graph_nodes + where + graph_nodes = (map mk_node keyed_nodes) :: [Node Int node] + keyed_nodes = nodes `zip` [(1::Int)..] + mk_node (node, key) = + let !edges = (mapMaybe (lookupNameEnv key_map) (get_uses node)) + in DigraphNode node key edges + + key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it + key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +-- | Name Environment +type NameEnv a = UniqFM Name a -- Domain is Name + +emptyNameEnv :: NameEnv a +isEmptyNameEnv :: NameEnv a -> Bool +mkNameEnv :: [(Name,a)] -> NameEnv a +mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a +fromUniqMap :: UniqMap Name a -> NameEnv a +nonDetNameEnvElts :: NameEnv a -> [a] +alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a +extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b +extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_CD :: (a->a->a) -> NameEnv a -> a -> NameEnv a -> a -> NameEnv a +plusNameEnv_CD2 :: (Maybe a->Maybe a->a) -> NameEnv a -> NameEnv a -> NameEnv a +plusNameEnvList :: [NameEnv a] -> NameEnv a +plusNameEnvListWith :: (a->a->a) -> [NameEnv a] -> NameEnv a +extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a +extendNameEnvListWith :: (a -> Name) -> NameEnv a -> [a] -> NameEnv a +extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +lookupNameEnv_NF :: NameEnv a -> Name -> a +filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt +mapMaybeNameEnv :: (a -> Maybe b) -> NameEnv a -> NameEnv b +anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool +mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 +disjointNameEnv :: NameEnv a -> NameEnv a -> Bool +seqEltsNameEnv :: (elt -> ()) -> NameEnv elt -> () + +nonDetNameEnvElts x = nonDetEltsUFM x +emptyNameEnv = emptyUFM +isEmptyNameEnv = isNullUFM +unitNameEnv x y = unitUFM x y +extendNameEnv x y z = addToUFM x y z +extendNameEnvList x l = addListToUFM x l +extendNameEnvListWith f x l = addListToUFM x (map (\a -> (f a, a)) l) +lookupNameEnv x y = lookupUFM x y +alterNameEnv = alterUFM +mkNameEnv l = listToUFM l +mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a)) +fromUniqMap = mapUFM snd . getUniqMap +elemNameEnv x y = elemUFM x y +plusNameEnv x y = plusUFM x y +plusNameEnv_C f x y = plusUFM_C f x y +{-# INLINE plusNameEnv_CD #-} +plusNameEnv_CD f x d y b = plusUFM_CD f x d y b +plusNameEnv_CD2 f x y = plusUFM_CD2 f x y +{-# INLINE plusNameEnvList #-} +plusNameEnvList xs = plusUFMList xs +{-# INLINE plusNameEnvListWith #-} +plusNameEnvListWith f xs = plusUFMListWith f xs +extendNameEnv_C f x y z = addToUFM_C f x y z +mapNameEnv f x = mapUFM f x +extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b +extendNameEnvList_C x y z = addListToUFM_C x y z +delFromNameEnv x y = delFromUFM x y +delListFromNameEnv x y = delListFromUFM x y +filterNameEnv x y = filterUFM x y +mapMaybeNameEnv x y = mapMaybeUFM x y +anyNameEnv f x = nonDetFoldUFM ((||) . f) False x +disjointNameEnv x y = disjointUFM x y +seqEltsNameEnv seqElt x = seqEltsUFM seqElt x + +lookupNameEnv_NF env n = expectJust (lookupNameEnv env n) + +-- | Deterministic Name Environment +-- +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why +-- we need DNameEnv. +type DNameEnv a = UniqDFM Name a + +emptyDNameEnv :: DNameEnv a +emptyDNameEnv = emptyUDFM + +isEmptyDNameEnv :: DNameEnv a -> Bool +isEmptyDNameEnv = isNullUDFM + +lookupDNameEnv :: DNameEnv a -> Name -> Maybe a +lookupDNameEnv = lookupUDFM + +delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a +delFromDNameEnv = delFromUDFM + +filterDNameEnv :: (a -> Bool) -> DNameEnv a -> DNameEnv a +filterDNameEnv = filterUDFM + +mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b +mapDNameEnv = mapUDFM + +adjustDNameEnv :: (a -> a) -> DNameEnv a -> Name -> DNameEnv a +adjustDNameEnv = adjustUDFM + +alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a +alterDNameEnv = alterUDFM + +extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a +extendDNameEnv = addToUDFM + +extendDNameEnv_C :: (a -> a -> a) -> DNameEnv a -> Name -> a -> DNameEnv a +extendDNameEnv_C = addToUDFM_C + +eltsDNameEnv :: DNameEnv a -> [a] +eltsDNameEnv = eltsUDFM + +foldDNameEnv :: (a -> b -> b) -> b -> DNameEnv a -> b +foldDNameEnv = foldUDFM + +plusDNameEnv_C :: (elt -> elt -> elt) -> DNameEnv elt -> DNameEnv elt -> DNameEnv elt +plusDNameEnv_C = plusUDFM_C + +nonDetStrictFoldDNameEnv :: (a -> b -> b) -> b -> DNameEnv a -> b +nonDetStrictFoldDNameEnv = nonDetStrictFoldUDFM + diff --git a/GHC/Types/Name/Occurrence.hs b/GHC/Types/Name/Occurrence.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Occurrence.hs @@ -0,0 +1,1357 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'GHC.Types.Name.Occurrence.OccName' represents names as strings with just a little more information: +-- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or +-- data constructors +-- +-- * 'GHC.Types.Name.Reader.RdrName': see "GHC.Types.Name.Reader#name_types" +-- +-- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types" +-- +-- * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types" +-- +-- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types" + +module GHC.Types.Name.Occurrence ( + -- * The 'NameSpace' type + NameSpace, -- Abstract + + -- ** Construction + -- $real_vs_source_data_constructors + tcName, clsName, tcClsName, dataName, varName, fieldName, + tvName, srcDataName, + + -- ** Pretty Printing + pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, + + -- * The 'OccName' type + OccName, -- Abstract, instance of Outputable + pprOccName, occNameMangledFS, + + -- ** Construction + mkOccName, mkOccNameFS, + mkVarOcc, mkVarOccFS, + mkRecFieldOcc, mkRecFieldOccFS, + mkDataOcc, mkDataOccFS, + mkTyVarOcc, mkTyVarOccFS, + mkTcOcc, mkTcOccFS, + mkClsOcc, mkClsOccFS, + mkDFunOcc, + setOccNameSpace, + demoteOccName, demoteOccTcClsName, demoteOccTvName, + promoteOccName, + varToRecFieldOcc, + recFieldToVarOcc, + HasOccName(..), + + -- ** Derived 'OccName's + isDerivedOccName, + mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc, + mkNewTyCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, + mkClassDataConOcc, mkDictOcc, mkIPOcc, + mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, + mkGenR, mkGen1R, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, + mkSuperDictSelOcc, mkSuperDictAuxOcc, + mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, + mkInstTyCoOcc, mkEqPredCoOcc, + mkTyConRepOcc, + + -- ** Deconstruction + occNameFS, occNameString, occNameSpace, + + isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + isFieldOcc, fieldOcc_maybe, + parenSymOcc, startsWithUnderscore, isUnderscore, + + isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, + isFieldNameSpace, isTermVarOrFieldNameSpace, + + -- * The 'OccEnv' type + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, + mapOccEnv, strictMapOccEnv, + mapMaybeOccEnv, + lookupOccEnv, lookupOccEnv_AllNameSpaces, + lookupOccEnv_WithFields, lookupFieldsOccEnv, + mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, + nonDetOccEnvElts, nonDetFoldOccEnv, + plusOccEnv, plusOccEnv_C, + extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, + alterOccEnv, minusOccEnv, minusOccEnv_C, minusOccEnv_C_Ns, + sizeOccEnv, + pprOccEnv, forceOccEnv, + intersectOccEnv_C, + + -- * The 'OccSet' type + OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, + extendOccSetList, + unionOccSets, unionManyOccSets, elemOccSet, + isEmptyOccSet, + + -- * Dealing with main + mainOcc, ppMainFn, + + -- * Tidying up + TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, trimTidyOccEnv, + tidyOccName, avoidClashesOccEnv, delTidyOccEnvList, + + -- FsEnv + FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv + ) where + +import GHC.Prelude + +import GHC.Builtin.Uniques +import GHC.Utils.Misc +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Data.FastString +import GHC.Data.FastString.Env +import GHC.Utils.Outputable +import GHC.Utils.Lexeme +import GHC.Utils.Binary +import GHC.Utils.Panic.Plain + +import Control.DeepSeq +import Data.Char +import Data.Data +import qualified Data.Semigroup as S +import GHC.Exts( Int(I#), dataToTag# ) + +{- +************************************************************************ +* * +\subsection{Name space} +* * +************************************************************************ +-} + +data NameSpace + -- | Variable name space (including "real" data constructors). + = VarName + -- | Record field namespace for the given record. + | FldName + { fldParent :: !FastString + -- ^ The textual name of the parent of the field. + -- + -- - For a field of a datatype, this is the name of the first constructor + -- of the datatype (regardless of whether this constructor has this field). + -- - For a field of a pattern synonym, this is the name of the pattern synonym. + } + -- | "Source" data constructor namespace. + | DataName + -- | Type variable namespace. + | TvName + -- | Type constructor and class namespace. + | TcClsName + -- Haskell has type constructors and classes in the same namespace, for now. + deriving Eq + +instance Ord NameSpace where + compare ns1 ns2 = + case compare (I# (dataToTag# ns1)) (I# (dataToTag# ns2)) of + LT -> LT + GT -> GT + EQ + | FldName { fldParent = p1 } <- ns1 + , FldName { fldParent = p2 } <- ns2 + -> lexicalCompareFS p1 p2 + | otherwise + -> EQ + +instance Uniquable NameSpace where + getUnique (FldName fs) = mkFldNSUnique fs + getUnique VarName = varNSUnique + getUnique DataName = dataNSUnique + getUnique TvName = tvNSUnique + getUnique TcClsName = tcNSUnique + +instance NFData NameSpace where + rnf VarName = () + rnf (FldName par) = rnf par + rnf DataName = () + rnf TvName = () + rnf TcClsName = () + +{- +Note [Data Constructors] +~~~~~~~~~~~~~~~~~~~~~~~~ +see also: Note [Data Constructor Naming] in GHC.Core.DataCon + +$real_vs_source_data_constructors +There are two forms of data constructor: + + [Source data constructors] The data constructors mentioned in Haskell source code + + [Real data constructors] The data constructors of the representation type, which may not be the same as the source type + +For example: + +> data T = T !(Int, Int) + +The source datacon has type @(Int, Int) -> T@ +The real datacon has type @Int -> Int -> T@ + +GHC chooses a representation based on the strictness etc. + +Note [Record field namespacing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record fields have a separate namespace from variables, to support +DuplicateRecordFields, e.g. in + + data X = MkX { fld :: Int } + data Y = MkY { fld :: Bool } + + f x = x { fld = 3 } + g y = y { fld = False } + +we want the two occurrences of "fld" to refer to the field names associated with +the corresponding data type. + +The namespace for a record field is as follows: + + - for a data type, it is the textual name of the first constructor of the + datatype, whether this constructor has this field or not; + - for a pattern synonym, it is the textual name of the pattern synonym itself. + +Record fields are initially parsed as variables, but the renamer resolves their +namespace in GHC.Rename.Names.newRecordFieldLabel, which is called when renaming +record data declarations and record pattern synonym declarations. + +To illustrate the namespacing, consider the record field "fld" in the following datatype + + data instance A Int Bool Char + = MkA1 | MkA2 { fld :: Int } | MkA3 { bar :: Bool, fld :: Int } + +Its namespace is `FldName "MkA1"`. This is a convention used throughout GHC +to circumvent the fact that we don't have a way to refer to the type constructor +"A Int Bool Char" in the renamer, as data family instances only get given +'Name's in the typechecker. +-} + +tcName, clsName, tcClsName :: NameSpace +dataName, srcDataName :: NameSpace +tvName, varName :: NameSpace + +-- Though type constructors and classes are in the same name space now, +-- the NameSpace type is abstract, so we can easily separate them later +tcName = TcClsName -- Type constructors +clsName = TcClsName -- Classes +tcClsName = TcClsName -- Not sure which! + +dataName = DataName +srcDataName = DataName -- Haskell-source data constructors should be + -- in the Data name space + +tvName = TvName +varName = VarName + +fieldName :: FastString -> NameSpace +fieldName = FldName + +isDataConNameSpace :: NameSpace -> Bool +isDataConNameSpace DataName = True +isDataConNameSpace _ = False + +isTcClsNameSpace :: NameSpace -> Bool +isTcClsNameSpace TcClsName = True +isTcClsNameSpace _ = False + +isTvNameSpace :: NameSpace -> Bool +isTvNameSpace TvName = True +isTvNameSpace _ = False + +isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors +isVarNameSpace TvName = True +isVarNameSpace VarName = True +isVarNameSpace (FldName {}) = True +isVarNameSpace _ = False + +-- | Is this a term variable or field name namespace? +isTermVarOrFieldNameSpace :: NameSpace -> Bool +isTermVarOrFieldNameSpace VarName = True +isTermVarOrFieldNameSpace (FldName {}) = True +isTermVarOrFieldNameSpace _ = False + +isValNameSpace :: NameSpace -> Bool +isValNameSpace DataName = True +isValNameSpace VarName = True +isValNameSpace (FldName {}) = True +isValNameSpace _ = False + +isFieldNameSpace :: NameSpace -> Bool +isFieldNameSpace (FldName {}) = True +isFieldNameSpace _ = False + +pprNameSpace :: NameSpace -> SDoc +pprNameSpace DataName = text "data constructor" +pprNameSpace VarName = text "variable" +pprNameSpace TvName = text "type variable" +pprNameSpace TcClsName = text "type constructor or class" +pprNameSpace (FldName p) = text "record field of" <+> ftext p + +pprNonVarNameSpace :: NameSpace -> SDoc +pprNonVarNameSpace VarName = empty +pprNonVarNameSpace ns = pprNameSpace ns + +pprNameSpaceBrief :: NameSpace -> SDoc +pprNameSpaceBrief DataName = char 'd' +pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief TvName = text "tv" +pprNameSpaceBrief TcClsName = text "tc" +pprNameSpaceBrief (FldName {}) = text "fld" + +-- | 'demoteNameSpace' lowers the 'NameSpace' to the term-level, if possible. +-- +-- See Note [Demotion] in GHC.Rename.Env. +demoteNameSpace :: NameSpace -> Maybe NameSpace +demoteNameSpace VarName = Nothing +demoteNameSpace DataName = Nothing +demoteNameSpace TvName = Just VarName +demoteNameSpace TcClsName = Just DataName +demoteNameSpace (FldName {}) = Nothing + +demoteTcClsNameSpace :: NameSpace -> Maybe NameSpace +demoteTcClsNameSpace VarName = Nothing +demoteTcClsNameSpace DataName = Nothing +demoteTcClsNameSpace TvName = Nothing +demoteTcClsNameSpace TcClsName = Just DataName +demoteTcClsNameSpace (FldName {}) = Nothing + +-- demoteTvNameSpace lowers the NameSpace of a type variable. +-- See Note [Demotion] in GHC.Rename.Env. +demoteTvNameSpace :: NameSpace -> Maybe NameSpace +demoteTvNameSpace TvName = Just VarName +demoteTvNameSpace VarName = Nothing +demoteTvNameSpace DataName = Nothing +demoteTvNameSpace TcClsName = Nothing +demoteTvNameSpace (FldName {}) = Nothing + +-- promoteNameSpace promotes the NameSpace as follows. +-- See Note [Promotion] in GHC.Rename.Env. +promoteNameSpace :: NameSpace -> Maybe NameSpace +promoteNameSpace DataName = Just TcClsName +promoteNameSpace VarName = Just TvName +promoteNameSpace TcClsName = Nothing +promoteNameSpace TvName = Nothing +promoteNameSpace (FldName {}) = Nothing + +{- +************************************************************************ +* * +\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} +* * +************************************************************************ +-} + +-- | Occurrence Name +-- +-- In this context that means: +-- "classified (i.e. as a type name, value name, etc) but not qualified +-- and not yet resolved" +data OccName = OccName + { occNameSpace :: !NameSpace + , occNameFS :: !FastString + } + +instance Eq OccName where + (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 + +instance Ord OccName where + -- Compares lexicographically, *not* by Unique of the string + compare (OccName sp1 s1) (OccName sp2 s2) = + lexicalCompareFS s1 s2 S.<> compare sp1 sp2 + +instance Data OccName where + -- don't traverse? + toConstr _ = abstractConstr "OccName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "OccName" + +instance HasOccName OccName where + occName = id + +instance NFData OccName where + rnf x = x `seq` () + +{- +************************************************************************ +* * +\subsection{Printing} +* * +************************************************************************ +-} + +instance Outputable OccName where + ppr = pprOccName + +instance OutputableBndr OccName where + pprBndr _ = ppr + pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) + pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) + +pprOccName :: IsLine doc => OccName -> doc +pprOccName (OccName sp occ) + = docWithStyle (ztext (zEncodeFS occ)) + (\_ -> ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp))) +{-# SPECIALIZE pprOccName :: OccName -> SDoc #-} +{-# SPECIALIZE pprOccName :: OccName -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +-- | Mangle field names to avoid duplicate symbols. +-- +-- See Note [Mangling OccNames]. +occNameMangledFS :: OccName -> FastString +occNameMangledFS (OccName ns fs) = + case ns of + -- Fields need to include the constructor, to ensure that we don't define + -- duplicate symbols when using DuplicateRecordFields. + FldName con -> concatFS [fsLit "$fld:", con, ":", fs] + -- Otherwise, we can ignore the namespace, as there is no risk of name + -- clashes. + _ -> fs + +{- Note [Mangling OccNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When generating a symbol for a Name, we usually discard the NameSpace entirely +(see GHC.Types.Name.pprName). This is because clashes are usually not possible, +e.g. a variable and a data constructor can't clash because data constructors +start with a capital letter or a colon, while variables never do. + +However, record field names, in the presence of DuplicateRecordFields, need this +disambiguation. So, for a record field like + + data A = MkA { foo :: Int } + +we generate the symbol $fld:MkA:foo. We use the constructor 'MkA' to disambiguate, +and not the TyCon A as one might naively expect: this is explained in +Note [Record field namespacing]. +-} + +{- +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +mkOccName :: NameSpace -> String -> OccName +mkOccName occ_sp str = OccName occ_sp (mkFastString str) + +mkOccNameFS :: NameSpace -> FastString -> OccName +mkOccNameFS occ_sp fs = OccName occ_sp fs + +mkVarOcc :: String -> OccName +mkVarOcc s = mkOccName varName s + +mkVarOccFS :: FastString -> OccName +mkVarOccFS fs = mkOccNameFS varName fs + +mkRecFieldOcc :: FastString -> String -> OccName +mkRecFieldOcc dc = mkOccName (fieldName dc) + +mkRecFieldOccFS :: FastString -> FastString -> OccName +mkRecFieldOccFS dc = mkOccNameFS (fieldName dc) + +varToRecFieldOcc :: HasDebugCallStack => FastString -> OccName -> OccName +varToRecFieldOcc dc (OccName ns s) = + assert makes_sense $ mkRecFieldOccFS dc s + where + makes_sense = case ns of + VarName -> True + FldName {} -> True + -- NB: it's OK to change the parent data constructor, + -- see e.g. test T23220 in which we construct with TH + -- a datatype using the fields of a different datatype. + _ -> False + +recFieldToVarOcc :: HasDebugCallStack => OccName -> OccName +recFieldToVarOcc (OccName _ns s) = mkVarOccFS s + +mkDataOcc :: String -> OccName +mkDataOcc = mkOccName dataName + +mkDataOccFS :: FastString -> OccName +mkDataOccFS = mkOccNameFS dataName + +mkTyVarOcc :: String -> OccName +mkTyVarOcc = mkOccName tvName + +mkTyVarOccFS :: FastString -> OccName +mkTyVarOccFS fs = mkOccNameFS tvName fs + +mkTcOcc :: String -> OccName +mkTcOcc = mkOccName tcName + +mkTcOccFS :: FastString -> OccName +mkTcOccFS = mkOccNameFS tcName + +mkClsOcc :: String -> OccName +mkClsOcc = mkOccName clsName + +mkClsOccFS :: FastString -> OccName +mkClsOccFS = mkOccNameFS clsName + +-- demoteOccName lowers the Namespace of OccName. +-- See Note [Demotion] in GHC.Rename.Env. +demoteOccName :: OccName -> Maybe OccName +demoteOccName (OccName space name) = do + space' <- demoteNameSpace space + return $ OccName space' name + +demoteOccTcClsName :: OccName -> Maybe OccName +demoteOccTcClsName (OccName space name) = do + space' <- demoteTcClsNameSpace space + return $ OccName space' name + +demoteOccTvName :: OccName -> Maybe OccName +demoteOccTvName (OccName space name) = do + space' <- demoteTvNameSpace space + return $ OccName space' name + +-- promoteOccName promotes the NameSpace of OccName. +-- See Note [Promotion] in GHC.Rename.Env. +promoteOccName :: OccName -> Maybe OccName +promoteOccName (OccName space name) = do + promoted_space <- promoteNameSpace space + let tyop = isTvNameSpace promoted_space && isLexVarSym name + space' = if tyop then tcClsName else promoted_space -- special case for type operators (#24570) + return $ OccName space' name + +{- | Other names in the compiler add additional information to an OccName. +This class provides a consistent way to access the underlying OccName. -} +class HasOccName name where + occName :: name -> OccName + +{- +************************************************************************ +* * + Environments +* * +************************************************************************ + +OccEnvs are used for the GlobalRdrEnv and for the envts in ModIface. + +Note [OccEnv] +~~~~~~~~~~~~~ +An OccEnv is a map keyed on OccName. Recall that an OccEnv consists of two +components: + + - a namespace, + - a textual name (in the form of a FastString). + +In general, for a given textual name, there is only one appropriate namespace. +However, sometimes we do get an occurrence that belongs to several namespaces: + + - Symbolic identifiers such as (:+) can belong to both the data constructor and + type constructor/class namespaces. + - With duplicate record fields, a field name can belong to several different + namespaces, one for each parent datatype (or pattern synonym). + +So we represent an OccEnv as a nested data structure + + FastStringEnv (UniqFM NameSpace a) + +in which we can first look up the textual name, and then choose which of the +namespaces are relevant. This supports the two main uses of OccEnvs: + + 1. One wants to look up a specific OccName in the environment, at a specific + namespace. One looks up the textual name, and then the namespace. + 2. One wants to look up something, but isn't sure in advance of the namespace. + So one looks up the textual name, and then can decide what to do based on + the returned map of namespaces. + +This data structure isn't performance critical in most situations, but some +improvements to its performance that might be worth it are as follows: + + A. Use a tailor-made data structure for a map keyed on NameSpaces. + + Recall that we have: + + data IntMap a = Bin !Int !Int !(IntMap a) !(IntMap a) + | Tip !Key a + | Nil + + This is already pretty efficient for singletons, but we don't need the + empty case (as we would simply omit the parent key in the OccEnv instead + of storing an empty inner map). + + B. Always ensure the inner map (keyed on namespaces) is evaluated, i.e. + is never a thunk. For this, we would need to use strict operations on + the outer FastStringEnv (but we'd keep using lazy operations on the inner + UniqFM). +-} + +-- | A map keyed on 'OccName'. See Note [OccEnv]. +newtype OccEnv a = MkOccEnv (FastStringEnv (UniqFM NameSpace a)) + deriving Functor + +-- | The empty 'OccEnv'. +emptyOccEnv :: OccEnv a +emptyOccEnv = MkOccEnv emptyFsEnv + +-- | A singleton 'OccEnv'. +unitOccEnv :: OccName -> a -> OccEnv a +unitOccEnv (OccName ns s) a = MkOccEnv $ unitFsEnv s (unitUFM ns a) + +-- | Add a single element to an 'OccEnv'. +extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnv (MkOccEnv as) (OccName ns s) a = + MkOccEnv $ extendFsEnv_C plusUFM as s (unitUFM ns a) + +-- | Extend an 'OccEnv' by a list. +-- +-- 'OccName's later on in the list override earlier 'OccName's. +extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +extendOccEnvList = foldl' $ \ env (occ, a) -> extendOccEnv env occ a + +-- | Look an element up in an 'OccEnv'. +lookupOccEnv :: OccEnv a -> OccName -> Maybe a +lookupOccEnv (MkOccEnv as) (OccName ns s) + = do { m <- lookupFsEnv as s + ; lookupUFM m ns } + +-- | Lookup an element in an 'OccEnv', ignoring 'NameSpace's entirely. +lookupOccEnv_AllNameSpaces :: OccEnv a -> OccName -> [a] +lookupOccEnv_AllNameSpaces (MkOccEnv as) (OccName _ s) + = case lookupFsEnv as s of + Nothing -> [] + Just r -> nonDetEltsUFM r + +-- | Lookup an element in an 'OccEnv', looking in the record field +-- namespace for a variable. +lookupOccEnv_WithFields :: OccEnv a -> OccName -> [a] +lookupOccEnv_WithFields env occ = + case lookupOccEnv env occ of + Nothing -> fieldGREs + Just gre -> gre : fieldGREs + where + fieldGREs + -- If the 'OccName' is a variable, also look up + -- in the record field namespaces. + | isVarOcc occ + = lookupFieldsOccEnv env (occNameFS occ) + | otherwise + = [] + +-- | Look up all the record fields that match with the given 'FastString' +-- in an 'OccEnv'. +lookupFieldsOccEnv :: OccEnv a -> FastString -> [a] +lookupFieldsOccEnv (MkOccEnv as) fld = + case lookupFsEnv as fld of + Nothing -> [] + Just flds -> nonDetEltsUFM $ filter_flds flds + -- NB: non-determinism is OK: in practice we will either end up resolving + -- to a single field or throwing an error. + where + filter_flds = filterUFM_Directly (\ uniq _ -> isFldNSUnique uniq) + +-- | Create an 'OccEnv' from a list. +-- +-- 'OccName's later on in the list override earlier 'OccName's. +mkOccEnv :: [(OccName,a)] -> OccEnv a +mkOccEnv = extendOccEnvList emptyOccEnv + +-- | Create an 'OccEnv' from a list, combining different values +-- with the same 'OccName' using the combining function. +mkOccEnv_C :: (a -> a -> a) -- ^ old -> new -> result + -> [(OccName,a)] + -> OccEnv a +mkOccEnv_C f elts + = MkOccEnv $ foldl' g emptyFsEnv elts + where + g env (OccName ns s, a) = + extendFsEnv_C (plusUFM_C $ flip f) env s (unitUFM ns a) + +-- | Compute whether there is a value keyed by the given 'OccName'. +elemOccEnv :: OccName -> OccEnv a -> Bool +elemOccEnv (OccName ns s) (MkOccEnv as) + = case lookupFsEnv as s of + Nothing -> False + Just m -> ns `elemUFM` m + +-- | Fold over an 'OccEnv'. Non-deterministic, unless the folding function +-- is commutative (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@). +nonDetFoldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +nonDetFoldOccEnv f b0 (MkOccEnv as) = + nonDetFoldFsEnv (flip $ nonDetFoldUFM f) b0 as + +-- | Obtain the elements of an 'OccEnv'. +-- +-- The resulting order is non-deterministic. +nonDetOccEnvElts :: OccEnv a -> [a] +nonDetOccEnvElts = nonDetFoldOccEnv (:) [] + +-- | Union of two 'OccEnv's, right-biased. +plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv (MkOccEnv env1) (MkOccEnv env2) + = MkOccEnv $ plusFsEnv_C plusUFM env1 env2 + +-- | Union of two 'OccEnv's with a combining function. +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv_C f (MkOccEnv env1) (MkOccEnv env2) + = MkOccEnv $ plusFsEnv_C (plusUFM_C f) env1 env2 + +-- | Map over an 'OccEnv' ('Functor' instance). +mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b +mapOccEnv = fmap + +-- | 'mapMaybe' for b 'OccEnv'. +mapMaybeOccEnv :: (a -> Maybe b) -> OccEnv a -> OccEnv b +mapMaybeOccEnv f (MkOccEnv env) + = MkOccEnv $ mapMaybeUFM g env + where + g as = + case mapMaybeUFM f as of + m' | isNullUFM m' -> Nothing + | otherwise -> Just m' + +-- | Add a single element to an 'OccEnv', using a different function whether +-- the 'OccName' already exists or not. +extendOccEnv_Acc :: forall a b + . (a->b->b) -- ^ add to existing + -> (a->b) -- ^ new element + -> OccEnv b -- ^ old + -> OccName -> a -- ^ new + -> OccEnv b +extendOccEnv_Acc f g (MkOccEnv env) (OccName ns s) = + MkOccEnv . extendFsEnv_Acc f' g' env s + where + f' :: a -> UniqFM NameSpace b -> UniqFM NameSpace b + f' a bs = alterUFM (Just . \ case { Nothing -> g a ; Just b -> f a b }) bs ns + g' a = unitUFM ns (g a) + +-- | Delete one element from an 'OccEnv'. +delFromOccEnv :: forall a. OccEnv a -> OccName -> OccEnv a +delFromOccEnv (MkOccEnv env1) (OccName ns s) = + MkOccEnv $ alterFsEnv f env1 s + where + f :: Maybe (UniqFM NameSpace a) -> Maybe (UniqFM NameSpace a) + f Nothing = Nothing + f (Just m) = + case delFromUFM m ns of + m' | isNullUFM m' -> Nothing + | otherwise -> Just m' + +-- | Delete multiple elements from an 'OccEnv'. +delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a +delListFromOccEnv = foldl' delFromOccEnv + +-- | Filter out all elements in an 'OccEnv' using a predicate. +filterOccEnv :: forall a. (a -> Bool) -> OccEnv a -> OccEnv a +filterOccEnv f (MkOccEnv env) = + MkOccEnv $ mapMaybeFsEnv g env + where + g :: UniqFM NameSpace a -> Maybe (UniqFM NameSpace a) + g ms = + case filterUFM f ms of + m' | isNullUFM m' -> Nothing + | otherwise -> Just m' + +-- | Alter an 'OccEnv', adding or removing an element at the given key. +alterOccEnv :: forall a. (Maybe a -> Maybe a) -> OccEnv a -> OccName -> OccEnv a +alterOccEnv f (MkOccEnv env) (OccName ns s) = + MkOccEnv $ alterFsEnv g env s + where + g :: Maybe (UniqFM NameSpace a) -> Maybe (UniqFM NameSpace a) + g Nothing = fmap (unitUFM ns) (f Nothing) + g (Just m) = + case alterUFM f m ns of + m' | isNullUFM m' -> Nothing + | otherwise -> Just m' + +intersectOccEnv_C :: (a -> b -> c) -> OccEnv a -> OccEnv b -> OccEnv c +intersectOccEnv_C f (MkOccEnv as) (MkOccEnv bs) + = MkOccEnv $ intersectUFM_C (intersectUFM_C f) as bs + +-- | Remove elements of the first 'OccEnv' that appear in the second 'OccEnv'. +minusOccEnv :: OccEnv a -> OccEnv b -> OccEnv a +minusOccEnv = minusOccEnv_C_Ns minusUFM + +-- | Alters (replaces or removes) those elements of the first 'OccEnv' that are +-- mentioned in the second 'OccEnv'. +-- +-- Same idea as 'Data.Map.differenceWith'. +minusOccEnv_C :: (a -> b -> Maybe a) + -> OccEnv a -> OccEnv b -> OccEnv a +minusOccEnv_C f = minusOccEnv_C_Ns (minusUFM_C f) + +minusOccEnv_C_Ns :: forall a b + . (UniqFM NameSpace a -> UniqFM NameSpace b -> UniqFM NameSpace a) + -> OccEnv a -> OccEnv b -> OccEnv a +minusOccEnv_C_Ns f (MkOccEnv as) (MkOccEnv bs) = + MkOccEnv $ minusUFM_C g as bs + where + g :: UniqFM NameSpace a -> UniqFM NameSpace b -> Maybe (UniqFM NameSpace a) + g as bs = + let m = f as bs + in if isNullUFM m + then Nothing + else Just m + +sizeOccEnv :: OccEnv a -> Int +sizeOccEnv (MkOccEnv as) = + nonDetStrictFoldUFM (\ m !acc -> acc + sizeUFM m) 0 as + +instance Outputable a => Outputable (OccEnv a) where + ppr x = pprOccEnv ppr x + +pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc +pprOccEnv ppr_elt (MkOccEnv env) + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elts) <- nonDetUFMToList env + , elt <- nonDetEltsUFM elts ] + +instance NFData a => NFData (OccEnv a) where + rnf = forceOccEnv rnf + +-- | Map over an 'OccEnv' strictly. +strictMapOccEnv :: (a -> b) -> OccEnv a -> OccEnv b +strictMapOccEnv f (MkOccEnv as) = + MkOccEnv $ strictMapFsEnv (strictMapUFM f) as + +-- | Force an 'OccEnv' with the provided function. +forceOccEnv :: (a -> ()) -> OccEnv a -> () +forceOccEnv nf (MkOccEnv fs) = seqEltsUFM (seqEltsUFM nf) fs + +-------------------------------------------------------------------------------- + +newtype OccSet = OccSet (FastStringEnv (UniqSet NameSpace)) + +emptyOccSet :: OccSet +unitOccSet :: OccName -> OccSet +mkOccSet :: [OccName] -> OccSet +extendOccSet :: OccSet -> OccName -> OccSet +extendOccSetList :: OccSet -> [OccName] -> OccSet +unionOccSets :: OccSet -> OccSet -> OccSet +unionManyOccSets :: [OccSet] -> OccSet +elemOccSet :: OccName -> OccSet -> Bool +isEmptyOccSet :: OccSet -> Bool + +emptyOccSet = OccSet emptyFsEnv +unitOccSet (OccName ns s) = OccSet $ unitFsEnv s (unitUniqSet ns) +mkOccSet = extendOccSetList emptyOccSet +extendOccSet (OccSet occs) (OccName ns s) = OccSet $ extendFsEnv occs s (unitUniqSet ns) +extendOccSetList = foldl' extendOccSet +unionOccSets (OccSet xs) (OccSet ys) = OccSet $ plusFsEnv_C unionUniqSets xs ys +unionManyOccSets = foldl' unionOccSets emptyOccSet +elemOccSet (OccName ns s) (OccSet occs) = maybe False (elementOfUniqSet ns) $ lookupFsEnv occs s +isEmptyOccSet (OccSet occs) = isNullUFM occs + +{- +************************************************************************ +* * +\subsection{Predicates and taking them apart} +* * +************************************************************************ +-} + +occNameString :: OccName -> String +occNameString (OccName _ s) = unpackFS s + +setOccNameSpace :: NameSpace -> OccName -> OccName +setOccNameSpace sp (OccName _ occ) = OccName sp occ + +isVarOcc, isTvOcc, isTcOcc, isDataOcc, isFieldOcc :: OccName -> Bool + +isVarOcc (OccName VarName _) = True +isVarOcc _ = False + +isTvOcc (OccName TvName _) = True +isTvOcc _ = False + +isTcOcc (OccName TcClsName _) = True +isTcOcc _ = False + +isFieldOcc (OccName (FldName {}) _) = True +isFieldOcc _ = False + +fieldOcc_maybe :: OccName -> Maybe FastString +fieldOcc_maybe (OccName (FldName con) _) = Just con +fieldOcc_maybe _ = Nothing + +-- | /Value/ 'OccNames's are those that are either in +-- the variable, field name or data constructor namespaces +isValOcc :: OccName -> Bool +isValOcc (OccName VarName _) = True +isValOcc (OccName DataName _) = True +isValOcc (OccName (FldName {}) _) = True +isValOcc _ = False + +isDataOcc (OccName DataName _) = True +isDataOcc _ = False + +-- | Test if the 'OccName' is a data constructor that starts with +-- a symbol (e.g. @:@, or @[]@) +isDataSymOcc :: OccName -> Bool +isDataSymOcc (OccName DataName s) = isLexConSym s +isDataSymOcc _ = False +-- Pretty inefficient! + +-- | Test if the 'OccName' is that for any operator (whether +-- it is a data constructor or variable or whatever) +isSymOcc :: OccName -> Bool +isSymOcc (OccName ns s) = case ns of + DataName -> isLexConSym s + TcClsName -> isLexSym s + VarName -> isLexSym s + TvName -> isLexSym s + FldName {} -> isLexSym s +-- Pretty inefficient! + +parenSymOcc :: OccName -> SDoc -> SDoc +-- ^ Wrap parens around an operator +parenSymOcc occ doc | isSymOcc occ = parens doc + | otherwise = doc + +startsWithUnderscore :: OccName -> Bool +-- ^ Haskell 98 encourages compilers to suppress warnings about unused +-- names in a pattern if they start with @_@: this implements that test +startsWithUnderscore occ = case unpackFS (occNameFS occ) of + '_':_ -> True + _ -> False + +isUnderscore :: OccName -> Bool +isUnderscore occ = occNameFS occ == fsLit "_" + +{- +************************************************************************ +* * +\subsection{Making system names} +* * +************************************************************************ + +Here's our convention for splitting up the interface file name space: + + d... dictionary identifiers + (local variables, so no name-clash worries) + +All of these other OccNames contain a mixture of alphabetic +and symbolic characters, and hence cannot possibly clash with +a user-written type or function name + + $f... Dict-fun identifiers (from inst decls) + $dmop Default method for 'op' + $pnC n'th superclass selector for class C + $wf Worker for function 'f' + $sf.. Specialised version of f + D:C Data constructor for dictionary for class C + NTCo:T Coercion connecting newtype T with its representation type + TFCo:R Coercion connecting a data family to its representation type R + +In encoded form these appear as Zdfxxx etc + + :... keywords (export:, letrec: etc.) +--- I THINK THIS IS WRONG! + +This knowledge is encoded in the following functions. + +@mk_deriv@ generates an @OccName@ from the prefix and a string. +NB: The string must already be encoded! +-} + +-- | Build an 'OccName' derived from another 'OccName'. +-- +-- Note that the pieces of the name are passed in as a @[FastString]@ so that +-- the whole name can be constructed with a single 'concatFS', minimizing +-- unnecessary intermediate allocations. +mk_deriv :: NameSpace + -> FastString -- ^ A prefix which distinguishes one sort of + -- derived name from another + -> [FastString] -- ^ The name we are deriving from in pieces which + -- will be concatenated. + -> OccName +mk_deriv occ_sp sys_prefix str = + mkOccNameFS occ_sp (concatFS $ sys_prefix : str) + +isDerivedOccName :: OccName -> Bool +-- ^ Test for definitions internally generated by GHC. This predicate +-- is used to suppress printing of internal definitions in some debug prints +isDerivedOccName occ = + case occNameString occ of + '$':c:_ | isAlphaNum c -> True -- E.g. $wfoo + c:':':_ | isAlphaNum c -> True -- E.g. N:blah newtype coercions + _other -> False + +isDefaultMethodOcc :: OccName -> Bool +isDefaultMethodOcc occ = + case occNameString occ of + '$':'d':'m':_ -> True + _ -> False + +-- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding? +-- This is needed as these bindings are renamed differently. +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +isTypeableBindOcc :: OccName -> Bool +isTypeableBindOcc occ = + case occNameString occ of + '$':'t':'c':_ -> True -- mkTyConRepOcc + '$':'t':'r':_ -> True -- Module binding + _ -> False + +mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, + mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, + mkGenR, mkGen1R, + mkDataConWorkerOcc, mkNewTyCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkDataTOcc, mkDataCOcc, + mkTyConRepOcc + :: OccName -> OccName + +-- These derived variables have a prefix that no Haskell value could have +mkDataConWrapperOcc = mk_simple_deriv varName "$W" +mkWorkerOcc = mk_simple_deriv varName "$w" +mkMatcherOcc = mk_simple_deriv varName "$m" +mkBuilderOcc = mk_simple_deriv varName "$b" +mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkClassOpAuxOcc = mk_simple_deriv varName "$c" +mkDictOcc = mk_simple_deriv varName "$d" +mkIPOcc = mk_simple_deriv varName "$i" +mkSpecOcc = mk_simple_deriv varName "$s" +mkForeignExportOcc = mk_simple_deriv varName "$f" +mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible +mkClassDataConOcc = mk_simple_deriv dataName "C:" -- Data con for a class +mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes +mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions +mkEqPredCoOcc = mk_simple_deriv tcName "$co" + +-- Used in derived instances for the names of auxiliary bindings. +-- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. +mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" +mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" +mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" +mkDataTOcc = mk_simple_deriv varName "$t" +mkDataCOcc = mk_simple_deriv varName "$c" + +-- TyConRepName stuff; see Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable +mkTyConRepOcc occ = mk_simple_deriv varName prefix occ + where + prefix | isDataOcc occ = "$tc'" + | otherwise = "$tc" + +-- Generic deriving mechanism +mkGenR = mk_simple_deriv tcName "Rep_" +mkGen1R = mk_simple_deriv tcName "Rep1_" + +mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName +mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] + +-- Data constructor workers are made by setting the name space +-- of the data constructor OccName (which should be a DataName) +-- to VarName +mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ + +mkSuperDictAuxOcc :: Int -> OccName -> OccName +mkSuperDictAuxOcc index cls_tc_occ + = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ] + +mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 + -> OccName -- ^ Class, e.g. @Ord@ + -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ +mkSuperDictSelOcc index cls_tc_occ + = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ] + +mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' + -> OccName -- ^ Local name, e.g. @sat@ + -> OccName -- ^ Nice unique version, e.g. @$L23sat@ +mkLocalOcc uniq occ + = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ] + -- The Unique might print with characters + -- that need encoding (e.g. 'z'!) + +-- | Derive a name for the representation type constructor of a +-- @data@\/@newtype@ instance. +mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ @R:Map@ +mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str) + +mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. + -- Only used in debug mode, for extra clarity + -> Bool -- ^ Is this a hs-boot instance DFun? + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ E.g. @$f3OrdMaybe@ + +-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real +-- thing when we compile the mother module. Reason: we don't know exactly +-- what the mother module will call it. + +mkDFunOcc info_str is_boot set + = chooseUniqueOcc VarName (prefix ++ info_str) set + where + prefix | is_boot = "$fx" + | otherwise = "$f" + +{- +Sometimes we need to pick an OccName that has not already been used, +given a set of in-use OccNames. +-} + +chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName +chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) + where + loop occ n + | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) + | otherwise = occ + +{- +We used to add a '$m' to indicate a method, but that gives rise to bad +error messages from the type checker when we print the function name or pattern +of an instance-decl binding. Why? Because the binding is zapped +to use the method name in place of the selector name. +(See GHC.Tc.TyCl.Class.tcMethodBind) + +The way it is now, -ddump-xx output may look confusing, but +you can always say -dppr-debug to get the uniques. + +However, we *do* have to zap the first character to be lower case, +because overloaded constructors (blarg) generate methods too. +And convert to VarName space + +e.g. a call to constructor MkFoo where + data (Ord a) => Foo a = MkFoo a + +If this is necessary, we do it by prefixing '$m'. These +guys never show up in error messages. What a hack. +-} + +mkMethodOcc :: OccName -> OccName +mkMethodOcc occ@(OccName VarName _) = occ +mkMethodOcc occ = mk_simple_deriv varName "$m" occ + +{- +************************************************************************ +* * +\subsection{Tidying them up} +* * +************************************************************************ + +Before we print chunks of code we like to rename it so that +we don't have to print lots of silly uniques in it. But we mustn't +accidentally introduce name clashes! So the idea is that we leave the +OccName alone unless it accidentally clashes with one that is already +in scope; if so, we tack on '1' at the end and try again, then '2', and +so on till we find a unique one. + +There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' +because that isn't a single lexeme. So we encode it to 'lle' and *then* +tack on the '1', if necessary. + +Note [TidyOccEnv] +~~~~~~~~~~~~~~~~~ +type TidyOccEnv = UniqFM FastString Int + +* Domain = The OccName's FastString. These FastStrings are "taken"; + make sure that we don't re-use + +* Int, n = A plausible starting point for new guesses + There is no guarantee that "FSn" is available; + you must look that up in the TidyOccEnv. But + it's a good place to start looking. + +* When looking for a renaming for "foo2" we strip off the "2" and start + with "foo". Otherwise if we tidy twice we get silly names like foo23. + + However, if it started with digits at the end, we always make a name + with digits at the end, rather than shortening "foo2" to just "foo", + even if "foo" is unused. Reasons: + - Plain "foo" might be used later + - We use trailing digits to subtly indicate a unification variable + in typechecker error message; see TypeRep.tidyTyVarBndr + +We have to take care though! Consider a machine-generated module (#10370) + module Foo where + a1 = e1 + a2 = e2 + ... + a2000 = e2000 +Then "a1", "a2" etc are all marked taken. But now if we come across "a7" again, +we have to do a linear search to find a free one, "a2001". That might just be +acceptable once. But if we now come across "a8" again, we don't want to repeat +that search. + +So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for +starting the search; and we make sure to update the starting point for "a" +after we allocate a new one. + + +Note [Tidying multiple names at once] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + > :t (id,id,id) + +Every id contributes a type variable to the type signature, and all of them are +"a". If we tidy them one by one, we get + + (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a) + +which is a bit unfortunate, as it unfairly renames only two of them. What we +would like to see is + + (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1) + +To achieve this, the function avoidClashesOccEnv can be used to prepare the +TidyEnv, by “blocking” every name that occurs twice in the map. This way, none +of the "a"s will get the privilege of keeping this name, and all of them will +get a suitable number by tidyOccName. Thus + + avoidNameClashesOccEnv ["a" :-> 7] ["b", "a", "c", "b", "a"] + = ["a" :-> 7, "b" :-> 1] + +Here +* "a" is already the TidyOccEnv, and so is unaffected +* "b" occurs twice, so is blocked by adding "b" :-> 1 +* "c" occurs only once, and so is not affected. + +This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs +for an example where this is used. + +This is #12382. + +-} + +type TidyOccEnv = UniqFM FastString Int -- The in-scope OccNames + -- See Note [TidyOccEnv] + +emptyTidyOccEnv :: TidyOccEnv +emptyTidyOccEnv = emptyUFM + +initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! +initTidyOccEnv = foldl' add emptyUFM + where + add env (OccName _ fs) = addToUFM env fs 1 + +delTidyOccEnvList :: TidyOccEnv -> [OccName] -> TidyOccEnv +delTidyOccEnvList env occs = env `delListFromUFM` map occNameFS occs + +-- see Note [Tidying multiple names at once] +avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv +avoidClashesOccEnv env occs = go env emptyUFM occs + where + go env _ [] = env + go env seenOnce ((OccName _ fs):occs) + | fs `elemUFM` env = go env seenOnce occs + | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce occs + | otherwise = go env (addToUFM seenOnce fs ()) occs + +tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) +tidyOccName env occ@(OccName occ_sp fs) + | not (fs `elemUFM` env) + = -- Desired OccName is free, so use it, + -- and record in 'env' that it's no longer available + (addToUFM env fs 1, occ) + + | otherwise + = case lookupUFM env base1 of + Nothing -> (addToUFM env base1 2, OccName occ_sp base1) + Just n -> find 1 n + where + base :: String -- Drop trailing digits (see Note [TidyOccEnv]) + base = dropWhileEndLE isDigit (unpackFS fs) + base1 = mkFastString (base ++ "1") + + find !k !n + = case elemUFM new_fs env of + True -> find (k+1 :: Int) (n+k) + -- By using n+k, the n argument to find goes + -- 1, add 1, add 2, add 3, etc which + -- moves at quadratic speed through a dense patch + + False -> (new_env, OccName occ_sp new_fs) + where + new_fs = mkFastString (base ++ show n) + new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) + -- Update: base1, so that next time we'll start where we left off + -- new_fs, so that we know it is taken + -- If they are the same (n==1), the former wins + -- See Note [TidyOccEnv] + +trimTidyOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv +-- Restrict the env to just the [OccName] +trimTidyOccEnv env vs + = foldl' add emptyUFM vs + where + add :: TidyOccEnv -> OccName -> TidyOccEnv + add so_far (OccName _ fs) + = case lookupUFM env fs of + Just n -> addToUFM so_far fs n + Nothing -> so_far + +{- +************************************************************************ +* * + Utilies for "main" +* * +************************************************************************ +-} + +mainOcc :: OccName +mainOcc = mkVarOccFS (fsLit "main") + +ppMainFn :: OccName -> SDoc +ppMainFn main_occ + | main_occ == mainOcc + = text "IO action" <+> quotes (ppr main_occ) + | otherwise + = text "main IO action" <+> quotes (ppr main_occ) + +{- +************************************************************************ +* * + Binary instance + Here rather than in GHC.Iface.Binary because OccName is abstract +* * +************************************************************************ +-} + +instance Binary NameSpace where + put_ bh VarName = + putByte bh 0 + put_ bh DataName = + putByte bh 1 + put_ bh TvName = + putByte bh 2 + put_ bh TcClsName = + putByte bh 3 + put_ bh (FldName parent) = do + putByte bh 4 + put_ bh parent + get bh = do + h <- getByte bh + case h of + 0 -> return VarName + 1 -> return DataName + 2 -> return TvName + 3 -> return TcClsName + _ -> do + parent <- get bh + return $ FldName { fldParent = parent } + +instance Binary OccName where + put_ bh (OccName aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (OccName aa ab) diff --git a/GHC/Types/Name/Occurrence.hs-boot b/GHC/Types/Name/Occurrence.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Occurrence.hs-boot @@ -0,0 +1,11 @@ +module GHC.Types.Name.Occurrence where + +import GHC.Data.FastString ( FastString ) + +data OccName + +class HasOccName name where + occName :: name -> OccName + +occNameFS :: OccName -> FastString +mkVarOccFS :: FastString -> OccName diff --git a/GHC/Types/Name/Ppr.hs b/GHC/Types/Name/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Ppr.hs @@ -0,0 +1,255 @@ + + +module GHC.Types.Name.Ppr + ( mkNamePprCtx + , mkQualModule + , mkQualPackage + , pkgQual + ) +where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Unit +import GHC.Unit.Env +import qualified GHC.Unit.Home.Graph as HUG + +import GHC.Types.Name +import GHC.Types.Name.Reader + + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Builtin.Types.Prim ( fUNTyConName ) +import GHC.Builtin.Types +import Data.Maybe (isJust) + + +{- +Note [Printing original names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deciding how to print names is pretty tricky. We are given a name +P:M.T, where P is the package name, M is the defining module, and T is +the occurrence name, and we have to decide in which form to display +the name given a GlobalRdrEnv describing the current scope. + +Ideally we want to display the name in the form in which it is in +scope. However, the name might not be in scope at all, and that's +where it gets tricky. Here are the cases: + + 1. T uniquely maps to P:M.T ---> "T" NameUnqual + 2. There is an X for which X.T + uniquely maps to P:M.T ---> "X.T" NameQual X + 3. There is no binding for "M.T" ---> "M.T" NameNotInScope1 + 4. Otherwise ---> "P:M.T" NameNotInScope2 + +(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at +all. In these cases we still want to refer to the name as "M.T", *but* +"M.T" might mean something else in the current scope (e.g. if there's +an "import X as M"), so to avoid confusion we avoid using "M.T" if +there's already a binding for it. Instead we write P:M.T. + +There's one further subtlety: in case (3), what if there are two +things around, P1:M.T and P2:M.T? Then we don't want to print both of +them as M.T! However only one of the modules P1:M and P2:M can be +exposed (say P2), so we use M.T for that, and P1:M.T for the other one. +This is handled by the qual_mod component of NamePprCtx, inside +the (ppr mod) of case (3), in Name.pprModulePrefix + +Note [Printing unit ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the old days, original names were tied to PackageIds, which directly +corresponded to the entities that users wrote in Cabal files, and were perfectly +suitable for printing when we need to disambiguate packages. However, with +instantiated units, the situation can be different: if the key is instantiated +with some holes, we should try to give the user some more useful information. +-} + +-- | Creates some functions that work out the best ways to format +-- names for the user according to a set of heuristics. +mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx +mkNamePprCtx ptc unit_env env + = QueryQualify + (mkQualName env) + (mkQualModule unit_state unit_env) + (mkQualPackage unit_state) + (mkPromTick ptc env) + where + unit_state = ue_homeUnitState unit_env + +mkQualName :: Outputable info => GlobalRdrEnvX info -> QueryQualifyName +mkQualName env = qual_name where + qual_name mod user_qual occ + + -- Use the user-written qualification, if that's unambiguous. + | Just qual <- user_qual + , let user_rdr = mkRdrQual qual occ + , [gre] <- lookupGRE env $ LookupRdrName user_rdr SameNameSpace + , right_name gre + = NameQual qual + + -- If there's a GRE that's in scope + -- unqualified with 'occ' AND that entity is + -- the right one, then use the unqualified name + | [gre] <- unqual_gres + , right_name gre + = NameUnqual + + | [] <- unqual_gres + , pretendNameIsInScopeForPpr + , not (isDerivedOccName occ) + = NameUnqual -- See Note [pretendNameIsInScopeForPpr] + + | [gre] <- qual_gres + = NameQual (greQualModName gre) + + | null qual_gres + = if null $ lookupGRE env $ + LookupRdrName (mkRdrQual (moduleName mod) occ) SameNameSpace + then NameNotInScope1 + else NameNotInScope2 + + | otherwise + = NameNotInScope1 -- Can happen if 'f' is bound twice in the module + -- Eg f = True; g = 0; f = False + where + is_name :: Name -> Bool + is_name name = assertPpr (isExternalName name) (ppr name) $ + nameModule name == mod && nameOccName name == occ + + -- See Note [pretendNameIsInScopeForPpr] + pretendNameIsInScopeForPpr :: Bool + pretendNameIsInScopeForPpr = + any is_name + [ liftedTypeKindTyConName + , constraintKindTyConName + , heqTyConName + , coercibleTyConName + , eqTyConName + , tYPETyConName + , fUNTyConName, unrestrictedFunTyConName + , oneDataConName + , listTyConName + , manyDataConName + , soloDataConName ] + || isJust (isTupleTyOrigName_maybe mod occ) + || isJust (isSumTyOrigName_maybe mod occ) + + right_name gre = greDefinitionModule gre == Just mod + unqual_gres = lookupGRE env (LookupRdrName (mkRdrUnqual occ) SameNameSpace) + qual_gres = filter right_name (lookupGRE env (LookupOccName occ SameNameSpace)) + + -- we can mention a module P:M without the P: qualifier iff + -- "import M" would resolve unambiguously to P:M. (if P is the + -- current package we can just assume it is unqualified). + +mkPromTick :: PromotionTickContext -> GlobalRdrEnvX info -> QueryPromotionTick +mkPromTick ptc env + | ptcPrintRedundantPromTicks ptc = alwaysPrintPromTick + | otherwise = print_prom_tick + where + print_prom_tick (PromotedItemListSyntax (IsEmptyOrSingleton eos)) = + -- Ticked: '[], '[x] + -- Unticked: [x,y], [x,y,z], and so on + ptcListTuplePuns ptc && eos + print_prom_tick PromotedItemTupleSyntax = + ptcListTuplePuns ptc + print_prom_tick (PromotedItemDataCon occ) + | isPunnedDataConName occ -- '[], '(,), ''(,,) + = ptcListTuplePuns ptc + + | Just occ' <- promoteOccName occ + , [] <- lookupGRE env (LookupRdrName (mkRdrUnqual occ') SameNameSpace) + = -- Could not find a corresponding type name in the environment, + -- so the data name is unambiguous. Promotion tick not needed. + False + | otherwise = True + +isPunnedDataConName :: OccName -> Bool +isPunnedDataConName occ = + isDataOcc occ && case unpackFS (occNameFS occ) of + '[':_ -> True + '(':_ -> True + _ -> False + +{- Note [pretendNameIsInScopeForPpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c.f. Note [pretendNameIsInScope] in GHC.Builtin.Names +Normally, a name is printed unqualified if it's in scope and unambiguous: + ghci> :t not + not :: Bool -> Bool + +Out of scope names are qualified: + ghci> import Prelude hiding (Bool) + ghci> :t not + not :: GHC.Types.Bool -> GHC.Types.Bool + +And so are ambiguous names: + ghci> data Bool + ghci> :t not + not :: Prelude.Bool -> Prelude.Bool + +However, these rules alone would lead to excessive qualification: + ghci> :k Functor + Functor :: (GHC.Types.Type -> GHC.Types.Type) -> GHC.Types.Constraint + +Even if the user has not imported Data.Kind, we would rather print: + Functor :: (Type -> Type) -> Constraint + +So we maintain a list of names for which we only require that they are +unambiguous. It reduces the amount of qualification in GHCi output and error +messages thus improving readability. + +One potential problem here is that external tooling that relies on parsing GHCi +output (e.g. Emacs mode for Haskell) requires names to be properly qualified to +make sense of the output (see #11208). So extend this list with care. + +Side note (int-index): + This function is distinct from GHC.Bulitin.Names.pretendNameIsInScope (used + when filtering out instances), and perhaps we could unify them by taking a + union, but I have not looked into what that would entail. +-} + +-- | Creates a function for formatting modules based on two heuristics: +-- (1) if the module is the current module, don't qualify, and (2) if there +-- is only one exposed package which exports this module, don't qualify. +mkQualModule :: UnitState -> UnitEnv -> QueryQualifyModule +mkQualModule unit_state unitEnv mod + -- Check whether the unit of the module is in the HomeUnitGraph. + -- If it is, then we consider this 'mod' to be "local" and don't + -- want to qualify it. + | HUG.memberHugUnit (moduleUnit mod) (ue_home_unit_graph unitEnv) = False + + | [(_, pkgconfig)] <- lookup, + mkUnit pkgconfig == moduleUnit mod + -- this says: we are given a module P:M, is there just one exposed package + -- that exposes a module M, and is it package P? + = False + + | otherwise = True + where lookup = lookupModuleInAllUnits unit_state (moduleName mod) + +-- | Creates a function for formatting packages based on two heuristics: +-- (1) don't qualify if the package in question is "main", and (2) only qualify +-- with a unit id if the package ID would be ambiguous. +mkQualPackage :: UnitState -> QueryQualifyPackage +mkQualPackage pkgs uid + | uid == mainUnit || uid == interactiveUnit + -- Skip the lookup if it's main, since it won't be in the package + -- database! + = False + | Just pkgid <- mb_pkgid + , searchPackageId pkgs pkgid `lengthIs` 1 + -- this says: we are given a package pkg-0.1@MMM, are there only one + -- exposed packages whose package ID is pkg-0.1? + = False + | otherwise + = True + where mb_pkgid = fmap unitPackageId (lookupUnit pkgs uid) + +-- | A function which only qualifies package names if necessary; but +-- qualifies all other identifiers. +pkgQual :: UnitState -> NamePprCtx +pkgQual pkgs = alwaysQualify { queryQualifyPackage = mkQualPackage pkgs } diff --git a/GHC/Types/Name/Reader.hs b/GHC/Types/Name/Reader.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Reader.hs @@ -0,0 +1,2231 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types" +-- +-- * 'GHC.Types.Name.Reader.RdrName' is the type of names that come directly from the parser. They +-- have not yet had their scoping and binding resolved by the renamer and can be +-- thought of to a first approximation as an 'GHC.Types.Name.Occurrence.OccName' with an optional module +-- qualifier +-- +-- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types" +-- +-- * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types" +-- +-- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types" + +module GHC.Types.Name.Reader ( + -- * The main type + RdrName(..), -- Constructors exported only to GHC.Iface.Binary + + -- ** Construction + mkRdrUnqual, mkRdrQual, + mkUnqual, mkVarUnqual, mkQual, mkOrig, + nameRdrName, getRdrName, + + -- ** Destruction + rdrNameOcc, rdrNameSpace, + demoteRdrName, demoteRdrNameTcCls, demoteRdrNameTv, + promoteRdrName, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + + -- ** Preserving user-written qualification + WithUserRdr(..), noUserRdr, unLocWithUserRdr, userRdrName, + + -- * Local mapping of 'RdrName' to 'Name.Name' + LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, + lookupLocalRdrEnv, lookupLocalRdrOcc, + elemLocalRdrEnv, inLocalRdrEnvScope, + localRdrEnvElts, minusLocalRdrEnv, minusLocalRdrEnvList, + + -- * Global mapping of 'RdrName' to 'GlobalRdrElt's + GlobalRdrEnvX, GlobalRdrEnv, IfGlobalRdrEnv, + emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + extendGlobalRdrEnv, greOccName, + pprGlobalRdrEnv, globalRdrEnvElts, globalRdrEnvLocal, + + -- ** Looking up 'GlobalRdrElt's + FieldsOrSelectors(..), filterFieldGREs, allowGRE, + + LookupGRE(..), lookupGRE, + WhichGREs(.., AllRelevantGREs, RelevantGREsFOS), + greIsRelevant, + + lookupGRE_Name, + lookupGRE_FieldLabel, + getGRE_NameQualifier_maybes, + transformGREs, pickGREs, pickGREsModExp, pickLevelZeroGRE, + + -- * GlobalRdrElts + availFromGRE, + greRdrNames, greSrcSpan, greQualModName, + gresToAvailInfo, + greDefinitionModule, greDefinitionSrcSpan, + greFieldLabel_maybe, + + -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' + GlobalRdrEltX(..), GlobalRdrElt, IfGlobalRdrElt, FieldGlobalRdrElt, + greName, greNameSpace, greParent, greInfo, + plusGRE, insertGRE, + forceGlobalRdrEnv, hydrateGlobalRdrEnv, + isLocalGRE, isImportedGRE, isRecFldGRE, + fieldGREInfo, + isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE, + unQualOK, qualSpecOK, unQualSpecOK, + pprNameProvenance, + mkGRE, mkExactGRE, mkLocalGRE, mkLocalVanillaGRE, mkLocalTyConGRE, + mkLocalConLikeGRE, mkLocalFieldGREs, + gresToNameSet, greLevels, + + -- ** Shadowing + greClashesWith, shadowNames, + + -- ** Information attached to a 'GlobalRdrElt' + ConLikeName(..), + GREInfo(..), RecFieldInfo(..), + plusGREInfo, + recFieldConLike_maybe, recFieldInfo_maybe, + fieldGRE_maybe, fieldGRELabel, + + -- ** Parent information + Parent(..), ParentGRE(..), greParent_maybe, + mkParent, availParent, + ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + importSpecLoc, importSpecModule, importSpecLevel, isExplicitItem, bestImport, + ImportLevel(..), + + -- * Utils + opIsAt, + + ) where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.Maybe + +import GHC.Types.Avail +import GHC.Types.Basic +import GHC.Types.GREInfo +import GHC.Types.FieldLabel +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.PkgQual +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Builtin.Uniques ( isFldNSUnique ) +import GHC.Types.ThLevelIndex +import qualified Data.Set as Set + +import GHC.Unit.Module + +import GHC.Utils.Misc as Utils +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Binary + +import Control.DeepSeq +import Control.Monad ( guard , (>=>) ) +import Data.Data +import Data.List ( sort ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Semigroup as S +import System.IO.Unsafe ( unsafePerformIO ) + +{- +************************************************************************ +* * +\subsection{The main data type} +* * +************************************************************************ +-} + +-- | Reader Name +-- +-- Do not use the data constructors of RdrName directly: prefer the family +-- of functions that creates them, such as 'mkRdrUnqual' +-- +-- - Note: A Located RdrName will only have API Annotations if it is a +-- compound one, +-- e.g. +-- +-- > `bar` +-- > ( ~ ) +-- +data RdrName + = Unqual OccName + -- ^ Unqualified name + -- + -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ Qualified name + -- + -- A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ Original name + -- + -- An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ Exact name + -- + -- We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving Data + +{- +************************************************************************ +* * +\subsection{Simple functions} +* * +************************************************************************ +-} + +instance HasOccName RdrName where + occName = rdrNameOcc + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + +rdrNameSpace :: RdrName -> NameSpace +rdrNameSpace = occNameSpace . rdrNameOcc + +-- | 'demoteRdrName' attempts to lowers the 'NameSpace' of a 'RdrName' +-- to the term-level. +-- +-- See Note [Demotion] in GHC.Rename.Env +demoteRdrName :: RdrName -> Maybe RdrName +demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) +demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) +demoteRdrName (Orig _ _) = Nothing +demoteRdrName (Exact _) = Nothing + +demoteRdrNameTcCls :: RdrName -> Maybe RdrName +demoteRdrNameTcCls (Unqual occ) = fmap Unqual (demoteOccTcClsName occ) +demoteRdrNameTcCls (Qual m occ) = fmap (Qual m) (demoteOccTcClsName occ) +demoteRdrNameTcCls (Orig _ _) = Nothing +demoteRdrNameTcCls (Exact _) = Nothing + +demoteRdrNameTv :: RdrName -> Maybe RdrName +demoteRdrNameTv (Unqual occ) = fmap Unqual (demoteOccTvName occ) +demoteRdrNameTv (Qual m occ) = fmap (Qual m) (demoteOccTvName occ) +demoteRdrNameTv (Orig _ _) = Nothing +demoteRdrNameTv (Exact _) = Nothing + +-- promoteRdrName promotes the NameSpace of RdrName. +-- See Note [Promotion] in GHC.Rename.Env. +promoteRdrName :: RdrName -> Maybe RdrName +promoteRdrName (Unqual occ) = fmap Unqual (promoteOccName occ) +promoteRdrName (Qual m occ) = fmap (Qual m) (promoteOccName occ) +promoteRdrName (Orig _ _) = Nothing +promoteRdrName (Exact _) = Nothing + + -- These two are the basic constructors +mkRdrUnqual :: OccName -> RdrName +mkRdrUnqual occ = Unqual occ + +mkRdrQual :: ModuleName -> OccName -> RdrName +mkRdrQual mod occ = Qual mod occ + +mkOrig :: Module -> OccName -> RdrName +mkOrig mod occ = Orig mod occ + +--------------- + -- These two are used when parsing source files + -- They do encode the module and occurrence names +mkUnqual :: NameSpace -> FastString -> RdrName +mkUnqual sp n = Unqual (mkOccNameFS sp n) + +mkVarUnqual :: FastString -> RdrName +mkVarUnqual n = Unqual (mkVarOccFS n) + +-- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and +-- the 'OccName' are taken from the first and second elements of the tuple respectively +mkQual :: NameSpace -> (FastString, FastString) -> RdrName +mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) + +getRdrName :: NamedThing thing => thing -> RdrName +getRdrName name = nameRdrName (getName name) + +nameRdrName :: Name -> RdrName +nameRdrName name = Exact name +-- Keep the Name even for Internal names, so that the +-- unique is still there for debug printing, particularly +-- of Types (which are converted to IfaceTypes before printing) + +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModule n) (nameOccName n) + | otherwise = Unqual (nameOccName n) + +isRdrDataCon :: RdrName -> Bool +isRdrTyVar :: RdrName -> Bool +isRdrTc :: RdrName -> Bool + +isRdrDataCon rn = isDataOcc (rdrNameOcc rn) +isRdrTyVar rn = isTvOcc (rdrNameOcc rn) +isRdrTc rn = isTcOcc (rdrNameOcc rn) + +isSrcRdrName :: RdrName -> Bool +isSrcRdrName (Unqual _) = True +isSrcRdrName (Qual _ _) = True +isSrcRdrName _ = False + +isUnqual :: RdrName -> Bool +isUnqual (Unqual _) = True +isUnqual _ = False + +isQual :: RdrName -> Bool +isQual (Qual _ _) = True +isQual _ = False + +isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) +isQual_maybe (Qual m n) = Just (m,n) +isQual_maybe _ = Nothing + +isOrig :: RdrName -> Bool +isOrig (Orig _ _) = True +isOrig _ = False + +isOrig_maybe :: RdrName -> Maybe (Module, OccName) +isOrig_maybe (Orig m n) = Just (m,n) +isOrig_maybe _ = Nothing + +isExact :: RdrName -> Bool +isExact (Exact _) = True +isExact _ = False + +isExact_maybe :: RdrName -> Maybe Name +isExact_maybe (Exact n) = Just n +isExact_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Outputable RdrName where + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ + ppr (Qual mod occ) = ppr mod <> dot <> ppr occ + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ) + +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <> ppr n + | otherwise = ppr n + + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + +instance Eq RdrName where + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + _ == _ = False + +instance Ord RdrName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact _) _ = LT + + compare (Unqual _) (Exact _) = GT + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 + compare (Qual _ _) (Orig _ _) = LT + + compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 + compare (Orig _ _) _ = GT + +{- +************************************************************************ +* * + LocalRdrEnv +* * +************************************************************************ +-} + +{- Note [LocalRdrEnv] +~~~~~~~~~~~~~~~~~~~~~ +The LocalRdrEnv is used to store local bindings (let, where, lambda, case). + +* It is keyed by OccName, because we never use it for qualified names. + +* It maps the OccName to a Name. That Name is almost always an + Internal Name, but (hackily) it can be External too for top-level + pattern bindings. See Note [bindLocalNames for an External name] + in GHC.Rename.Pat + +* We keep the current mapping (lre_env), *and* the set of all Names in + scope (lre_in_scope). Reason: see Note [Splicing Exact names] in + GHC.Rename.Env. +-} + +-- | Local Reader Environment +-- See Note [LocalRdrEnv] +data LocalRdrEnv = LRE { lre_env :: OccEnv Name + , lre_in_scope :: NameSet } + +instance Outputable LocalRdrEnv where + ppr (LRE {lre_env = env, lre_in_scope = ns}) + = hang (text "LocalRdrEnv {") + 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env + , text "in_scope =" + <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) + ] <+> char '}') + where + ppr_elt name = parens (ppr (nameOccName name)) <+> ppr name + -- So we can see if the keys line up correctly + +emptyLocalRdrEnv :: LocalRdrEnv +emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv + , lre_in_scope = emptyNameSet } + +extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv +-- See Note [LocalRdrEnv] +extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name + = lre { lre_env = extendOccEnv env (nameOccName name) name + , lre_in_scope = extendNameSet ns name } + +extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv +-- See Note [LocalRdrEnv] +extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names + = lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] + , lre_in_scope = extendNameSetList ns names } + +lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name +lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr + | Unqual occ <- rdr + = lookupOccEnv env occ + + -- See Note [Local bindings with Exact Names] + | Exact name <- rdr + , name `elemNameSet` ns + = Just name + + | otherwise + -- As per the Haskell report (www.haskell.org/onlinereport/haskell2010/haskellch5.html#x11-980005), + -- qualified names can only refer to: + -- + -- - imported names, or + -- - top-level declarations in the current module. + -- + -- Thus, looking up in the LocalRdrEnv using a Qual or Orig RdrName will + -- always fail. + = Nothing + +lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name +lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ + +elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool +elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) + = case rdr_name of + Unqual occ -> occ `elemOccEnv` env + Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Qual {} -> False + Orig {} -> False + +localRdrEnvElts :: LocalRdrEnv -> [Name] +localRdrEnvElts (LRE { lre_env = env }) = nonDetOccEnvElts env + +inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool +-- This is the point of the NameSet +inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns + +minusLocalRdrEnv :: LocalRdrEnv -> OccEnv a -> LocalRdrEnv +minusLocalRdrEnv lre@(LRE { lre_env = env }) occs + = lre { lre_env = minusOccEnv env occs } + +minusLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv +minusLocalRdrEnvList lre@(LRE { lre_env = env }) occs + = lre { lre_env = delListFromOccEnv env occs } + +{- +Note [Local bindings with Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Template Haskell we can make local bindings that have Exact Names. +Computing shadowing etc may use elemLocalRdrEnv (at least it certainly +does so in GHC.Rename.HsType.bindHsQTyVars), so for an Exact Name we must consult +the in-scope-name-set. + + +************************************************************************ +* * + GlobalRdrEnv +* * +************************************************************************ +-} + +-- | Global Reader Environment +type GlobalRdrEnv = GlobalRdrEnvX GREInfo +-- ^ Keyed by 'OccName'; when looking up a qualified name +-- we look up the 'OccName' part, and then check the 'Provenance' +-- to see if the appropriate qualification is valid. This +-- saves routinely doubling the size of the env by adding both +-- qualified and unqualified names to the domain. +-- +-- The list in the codomain is required because there may be name clashes +-- These only get reported on lookup, not on construction +-- +-- INVARIANT 1: All the members of the list have distinct +-- 'gre_name' fields; that is, no duplicate Names +-- +-- INVARIANT 2: Imported provenance => Name is an ExternalName +-- However LocalDefs can have an InternalName. This +-- happens only when type-checking a [d| ... |] Template +-- Haskell quotation; see this note in GHC.Rename.Names +-- Note [Top-level Names in Template Haskell decl quotes] +-- +-- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then +-- greOccName gre = occ + +-- | A 'GlobalRdrEnv' in which the 'GlobalRdrElt's don't have any 'GREInfo' +-- attached to them. This is useful to avoid space leaks, see Note [IfGlobalRdrEnv]. +type IfGlobalRdrEnv = GlobalRdrEnvX () + +-- | Parametrises 'GlobalRdrEnv' over the presence or absence of 'GREInfo'. +-- +-- See Note [IfGlobalRdrEnv]. +type GlobalRdrEnvX info = OccEnv [GlobalRdrEltX info] + +-- | Global Reader Element +-- +-- Something in scope in the renamer; usually a member of the 'GlobalRdrEnv'. +-- See Note [GlobalRdrElt provenance]. + +type GlobalRdrElt = GlobalRdrEltX GREInfo + +-- | A 'GlobalRdrElt' in which we stripped out the 'GREInfo' field, +-- in order to avoid space leaks. +-- +-- See Note [IfGlobalRdrEnv]. +type IfGlobalRdrElt = GlobalRdrEltX () + +-- | Global Reader Element +-- +-- Something in scope in the renamer; usually a member of the 'GlobalRdrEnv'. +-- See Note [GlobalRdrElt provenance]. +-- +-- Why do we parametrise over the 'gre_info' field? See Note [IfGlobalRdrEnv]. +data GlobalRdrEltX info + = GRE { gre_name :: !Name + , gre_par :: !Parent -- ^ See Note [Parents] + , gre_lcl :: !Bool -- ^ True <=> the thing was defined locally + , gre_imp :: !(Bag ImportSpec) -- ^ In scope through these imports + -- See Note [GlobalRdrElt provenance] for the relation between gre_lcl and gre_imp. + + , gre_info :: info + -- ^ Information the renamer knows about this particular 'Name'. + -- + -- Careful about forcing this field! Forcing it can trigger + -- the loading of interface files. + -- + -- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. + } deriving (Data) + +instance NFData a => NFData (GlobalRdrEltX a) where + rnf (GRE name par _ imp info) = rnf name `seq` rnf par `seq` rnf imp `seq` rnf info + + +{- Note [IfGlobalRdrEnv] +~~~~~~~~~~~~~~~~~~~~~~~~ +Information pertinent to the renamer about a 'Name' is stored in the fields of +'GlobalRdrElt'. The 'gre_info' field, described in Note [GREInfo] in GHC.Types.GREInfo, +is a bit special: as Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo +describes, for imported 'Name's it is usually obtained by a look up in a type environment, +and forcing can cause the interface file for the module defining the 'Name' to be +loaded. As described in Note [Forcing GREInfo] in GHC.Types.GREInfo, keeping it +a thunk can cause space leaks, while forcing it can cause extra work to be done. +So it's best to discard it when we don't need it, for example when we are about +to store it in a 'ModIface'. + +We thus parametrise 'GlobalRdrElt' (and 'GlobalRdrEnv') over the presence or +absence of the 'GREInfo' field. + + - When we are about to stash the 'GlobalRdrElt' in a long-lived data structure, + e.g. a 'ModIface', we force it by setting all the 'GREInfo' fields to '()'. + See 'forceGlobalRdrEnv'. + - To go back the other way, we use 'hydrateGlobalRdrEnv', which sets the + 'gre_info' fields back to lazy lookups. + +This parametrisation also helps ensure that we don't accidentally force the +GREInfo field (which can cause unnecessary loading of interface files). +In particular, the 'lookupGRE' function is statically guaranteed to not consult +the 'GREInfo' field when using 'SameNameSpace', which is important +as we sometimes need to use this function with an 'IfaceGlobalRdrEnv' in which +the 'GREInfo' fields have been stripped. +-} + +-- | A 'FieldGlobalRdrElt' is a 'GlobalRdrElt' +-- in which the 'gre_info' field is 'IAmRecField'. +type FieldGlobalRdrElt = GlobalRdrElt + +greName :: GlobalRdrEltX info -> Name +greName = gre_name + +greNameSpace :: GlobalRdrEltX info -> NameSpace +greNameSpace = nameNameSpace . greName + +greParent :: GlobalRdrEltX info -> Parent +greParent = gre_par + +greInfo :: GlobalRdrElt -> GREInfo +greInfo = gre_info + +greLevels :: GlobalRdrEltX info -> Set.Set ImportLevel +greLevels g = + if gre_lcl g then Set.singleton NormalLevel + else Set.fromList (bagToList (fmap (is_level . is_decl) (gre_imp g))) + +-- | See Note [Parents] +data Parent = NoParent + | ParentIs { par_is :: !Name } + deriving (Eq, Data) + +instance Outputable Parent where + ppr NoParent = empty + ppr (ParentIs n) = text "parent:" <> ppr n + +instance NFData Parent where + rnf NoParent = () + rnf (ParentIs n) = rnf n + +plusParent :: Parent -> Parent -> Parent +-- See Note [Combining parents] +plusParent p1@(ParentIs _) p2 = hasParent p1 p2 +plusParent p1 p2@(ParentIs _) = hasParent p2 p1 +plusParent NoParent NoParent = NoParent + +hasParent :: Parent -> Parent -> Parent +#if defined(DEBUG) +hasParent p NoParent = p +hasParent p p' + | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree +#endif +hasParent p _ = p + + +{- Note [GlobalRdrElt provenance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", +i.e. how the Name came to be in scope. It can be in scope in one of the following +three ways: + + A. The Name was locally bound, in the current module. + gre_lcl = True + + The renamer adds this Name to the GlobalRdrEnv after renaming the binding. + See the calls to "extendGlobalRdrEnvRn" in GHC.Rename.Module.rnSrcDecls. + + B. The Name was imported + gre_imp = Just imps <=> brought into scope by the imports "imps" + + The renamer adds this Name to the GlobalRdrEnv after processing the imports. + See GHC.Rename.Names.filterImports and GHC.Tc.Module.tcRnImports. + + C. We followed an exact reference (i.e. an Exact or Orig RdrName) + gre_lcl = False, gre_imp = Nothing + + In this case, we directly fetch a Name and its GREInfo from direct reference. + We don't add it to the GlobalRdrEnv. See "GHC.Rename.Env.lookupExactOrOrig". + +It is just about possible to have *both* gre_lcl = True and gre_imp = Just imps. +This can happen with module loops: a Name is defined locally in A, and also +brought into scope by importing a module that SOURCE-imported A. + +Example (#7672): + + A.hs-boot module A where + data T + + B.hs module B(Decl.T) where + import {-# SOURCE #-} qualified A as Decl + + A.hs module A where + import qualified B + data T = Z | S B.T + +In A.hs, 'T' is locally bound, *and* imported as B.T. + + +Note [Parents] +~~~~~~~~~~~~~~~~~ +The children of a Name are the things that are abbreviated by the ".." notation +in export lists. + +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Parent Children +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + data T Data constructors + Record-field ids + + data family T Data constructors and record-field ids + of all visible data instances of T + + class C Class operations + Associated type constructors + +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Constructor Meaning +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NoParent Not bundled with a type constructor. + ParentIs n Bundled with the type constructor corresponding to n. + +Pattern synonym constructors (and their record fields, if any) are unusual: +their gre_par is NoParent in the module in which they are defined. However, a +pattern synonym can be bundled with a type constructor on export, in which case +whenever the pattern synonym is imported the gre_par will be ParentIs. + +Thus the gre_name and gre_par fields are independent, because a normal datatype +introduces FieldGlobalRdrElts using ParentIs, but a record pattern synonym can +introduce FieldGlobalRdrElts that use NoParent. (In the past we represented +fields using an additional constructor of the Parent type, which could not +adequately represent this situation.) See also +Note [Representing pattern synonym fields in AvailInfo] in GHC.Types.Avail. + +Note [Combining parents] +~~~~~~~~~~~~~~~~~~~~~~~~ +With an associated type we might have + module M where + class C a where + data T a + op :: T a -> a + instance C Int where + data T Int = TInt + instance C Bool where + data T Bool = TBool + +Then: C is the parent of T + T is the parent of TInt and TBool +So: in an export list + C(..) is short for C( op, T ) + T(..) is short for T( TInt, TBool ) + +Module M exports everything, so its exports will be + AvailTC C [C,T,op] + AvailTC T [T,TInt,TBool] +On import we convert to GlobalRdrElt and then combine +those. For T that will mean we have + one GRE with Parent C + one GRE with NoParent +That's why plusParent picks the "best" case. +-} + +mkGRE :: (Name -> Maybe ImportSpec) -> GREInfo -> Parent -> Name -> GlobalRdrElt +mkGRE prov_fn info par n = + case prov_fn n of + -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = par + , gre_lcl = True, gre_imp = emptyBag + , gre_info = info } + Just is -> GRE { gre_name = n, gre_par = par + , gre_lcl = False, gre_imp = unitBag is + , gre_info = info } + +mkExactGRE :: Name -> GREInfo -> GlobalRdrElt +mkExactGRE nm info = + GRE { gre_name = nm, gre_par = NoParent + , gre_lcl = False, gre_imp = emptyBag + , gre_info = info } + +mkLocalGRE :: GREInfo -> Parent -> Name -> GlobalRdrElt +mkLocalGRE = mkGRE (const Nothing) + +mkLocalVanillaGRE :: Parent -> Name -> GlobalRdrElt +mkLocalVanillaGRE = mkLocalGRE Vanilla + +-- | Create a local 'GlobalRdrElt' for a 'TyCon'. +mkLocalTyConGRE :: TyConFlavour Name + -> Name + -> GlobalRdrElt +mkLocalTyConGRE flav nm = mkLocalGRE (IAmTyCon flav) par nm + where + par = case tyConFlavourAssoc_maybe flav of + Nothing -> NoParent + Just p -> ParentIs p + +mkLocalConLikeGRE :: Parent -> (ConLikeName, ConInfo) -> GlobalRdrElt +mkLocalConLikeGRE p (con_nm, con_info) = + mkLocalGRE (IAmConLike con_info) p (conLikeName_Name con_nm ) + +mkLocalFieldGREs :: Parent -> [(ConLikeName, ConInfo)] -> [GlobalRdrElt] +mkLocalFieldGREs p cons = + [ mkLocalGRE (IAmRecField fld_info) p fld_nm + | (S.Arg fld_nm fl, fl_cons) <- flds + , let fld_info = RecFieldInfo { recFieldLabel = fl + , recFieldCons = fl_cons } ] + where + -- We are given a map taking a constructor to its fields, but we want + -- a map taking a field to the constructors which have it. + -- We thus need to convert [(Con, [Field])] into [(Field, [Con])]. + flds = Map.toList + $ Map.fromListWith unionUniqSets + [ (S.Arg (flSelector fl) fl, unitUniqSet con) + | (con, con_info) <- cons + , ConInfo _ (ConHasRecordFields fls) <- [con_info] + , fl <- NE.toList fls ] + +instance HasOccName (GlobalRdrEltX info) where + occName = greOccName + +greOccName :: GlobalRdrEltX info -> OccName +greOccName ( GRE { gre_name = nm } ) = nameOccName nm + +-- | The SrcSpan of the name pointed to by the GRE. +greDefinitionSrcSpan :: GlobalRdrEltX info -> SrcSpan +greDefinitionSrcSpan = nameSrcSpan . greName + +-- | The module in which the name pointed to by the GRE is defined. +greDefinitionModule :: GlobalRdrEltX info -> Maybe Module +greDefinitionModule = nameModule_maybe . greName + +greQualModName :: Outputable info => GlobalRdrEltX info -> ModuleName +-- Get a suitable module qualifier for the GRE +-- (used in mkPrintUnqualified) +-- Precondition: the gre_name is always External +greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + | lcl, Just mod <- greDefinitionModule gre = moduleName mod + | Just is <- headMaybe iss = is_as (is_decl is) + | otherwise = pprPanic "greQualModName" (ppr gre) + +greRdrNames :: GlobalRdrEltX info -> [RdrName] +greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } + = bagToList $ (if lcl then unitBag unqual else emptyBag) `unionBags` concatMapBag do_spec (mapBag is_decl iss) + where + occ = greOccName gre + unqual = Unqual occ + do_spec decl_spec + | is_qual decl_spec = unitBag qual + | otherwise = listToBag [unqual,qual] + where qual = Qual (is_as decl_spec) occ + +-- the SrcSpan that pprNameProvenance prints out depends on whether +-- the Name is defined locally or not: for a local definition the +-- definition site is used, otherwise the location of the import +-- declaration. We want to sort the export locations in +-- exportClashErr by this SrcSpan, we need to extract it: +greSrcSpan :: Outputable info => GlobalRdrEltX info -> SrcSpan +greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } ) + | lcl = greDefinitionSrcSpan gre + | Just is <- headMaybe iss = is_dloc (is_decl is) + | otherwise = pprPanic "greSrcSpan" (ppr gre) + +mkParent :: Name -> AvailInfo -> Parent +mkParent _ (Avail _) = NoParent +mkParent n (AvailTC m _) | n == m = NoParent + | otherwise = ParentIs m + +availParent :: AvailInfo -> Parent +availParent (AvailTC m _) = ParentIs m +availParent (Avail {}) = NoParent + + +greParent_maybe :: GlobalRdrEltX info -> Maybe Name +greParent_maybe gre = case gre_par gre of + NoParent -> Nothing + ParentIs n -> Just n + +gresToNameSet :: [GlobalRdrEltX info] -> NameSet +gresToNameSet gres = foldr add emptyNameSet gres + where add gre set = extendNameSet set (greName gre) + +-- | Takes a list of distinct GREs and folds them +-- into AvailInfos. This is more efficient than mapping each individual +-- GRE to an AvailInfo and then folding using `plusAvail`, but needs the +-- uniqueness assumption. +gresToAvailInfo :: forall info. [GlobalRdrEltX info] -> [AvailInfo] +gresToAvailInfo gres + = nonDetNameEnvElts avail_env + where + avail_env :: NameEnv AvailInfo -- Keyed by the parent + (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres + + add :: (NameEnv AvailInfo, NameSet) + -> GlobalRdrEltX info + -> (NameEnv AvailInfo, NameSet) + add (env, done) gre + | name `elemNameSet` done + = (env, done) -- Don't insert twice into the AvailInfo + | otherwise + = ( extendNameEnv_Acc comb availFromGRE env key gre + , done `extendNameSet` name ) + where + name = greName gre + key = case greParent_maybe gre of + Just parent -> parent + Nothing -> greName gre + + -- We want to insert the child `k` into a list of children but + -- need to maintain the invariant that the parent is first. + -- + -- We also use the invariant that `k` is not already in `ns`. + insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] + insertChildIntoChildren _ [] k = [k] + insertChildIntoChildren p (n:ns) k + | p == k = k:n:ns + | otherwise = n:k:ns + + comb :: GlobalRdrEltX info -> AvailInfo -> AvailInfo + comb _ (Avail n) = Avail n -- Duplicated name, should not happen + comb gre (AvailTC m ns) + = case gre_par gre of + NoParent -> AvailTC m (greName gre:ns) -- Not sure this ever happens + ParentIs {} -> AvailTC m (insertChildIntoChildren m ns (greName gre)) + +availFromGRE :: GlobalRdrEltX info -> AvailInfo +availFromGRE (GRE { gre_name = child, gre_par = parent }) + = case parent of + ParentIs p + -> AvailTC p [child] + NoParent + | isTyConName child -- NB: don't force the GREInfo field unnecessarily. + -> AvailTC child [child] + | otherwise + -> Avail child + +emptyGlobalRdrEnv :: GlobalRdrEnvX info +emptyGlobalRdrEnv = emptyOccEnv + +globalRdrEnvElts :: GlobalRdrEnvX info -> [GlobalRdrEltX info] +globalRdrEnvElts env = nonDetFoldOccEnv (++) [] env + +globalRdrEnvLocal :: GlobalRdrEnvX info -> GlobalRdrEnvX info +globalRdrEnvLocal = mapOccEnv (filter isLocalGRE) + +-- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to +-- avoid space leaks. +-- See Note [Forcing GREInfo] in GHC.Types.GREInfo. +forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv +forceGlobalRdrEnv rdrs = + strictMapOccEnv (strictMap (\ gre -> gre { gre_info = ()})) rdrs + +-- | Hydrate a previously dehydrated 'GlobalRdrEnv', +-- by (lazily!) looking up the 'GREInfo' using the provided function. +-- +-- See Note [Forcing GREInfo] in GHC.Types.GREInfo. +hydrateGlobalRdrEnv :: forall info noInfo + . (Name -> IO info) + -> GlobalRdrEnvX noInfo -> GlobalRdrEnvX info +hydrateGlobalRdrEnv f = mapOccEnv (fmap g) + where + g gre = gre { gre_info = unsafePerformIO $ f (greName gre) } + -- NB: use unsafePerformIO to delay the lookup until it is forced. + -- See also 'GHC.Rename.Env.lookupGREInfo'. + +instance Outputable info => Outputable (GlobalRdrEltX info) where + ppr gre = hang (ppr (greName gre) <+> ppr (gre_par gre) <+> ppr (gre_info gre)) + 2 (pprNameProvenance gre) + +pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc +pprGlobalRdrEnv locals_only env + = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (text "(locals only)") + <+> lbrace + , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- nonDetOccEnvElts env ] + <+> rbrace) ] + where + remove_locals gres | locals_only = filter isLocalGRE gres + | otherwise = gres + pp [] = empty + pp gres@(gre:_) = hang (ppr occ <> colon) + 2 (vcat (map ppr gres)) + where + occ = nameOccName (greName gre) + +{- +Note [NoFieldSelectors] +~~~~~~~~~~~~~~~~~~~~~~~ +The NoFieldSelectors extension allows record fields to be defined without +bringing the corresponding selector functions into scope. However, such fields +may still be used in contexts such as record construction, pattern matching or +update. This requires us to distinguish contexts in which selectors are required +from those in which any field may be used. For example: + + {-# LANGUAGE NoFieldSelectors #-} + module M (T(foo), foo) where -- T(foo) refers to the field, + -- unadorned foo to the value binding + data T = MkT { foo :: Int } + foo = () + + bar = foo -- refers to the value binding, field ignored + + module N where + import M (T(..)) + baz = MkT { foo = 3 } -- refers to the field + oops = foo -- an error: the field is in scope but the value binding is not + +Each 'FieldLabel' indicates (in the 'flHasFieldSelector' field) whether the +FieldSelectors extension was enabled in the defining module. This allows them +to be filtered out by 'filterFieldGREs'. + +Even when NoFieldSelectors is in use, we still generate selector functions +internally. For example, the expression + getField @"foo" t +or (with dot-notation) + t.foo +extracts the `foo` field of t::T, and hence needs the selector function +(see Note [HasField instances] in GHC.Tc.Instance.Class). + +In many of the name lookup functions in this module we pass a FieldsOrSelectors +value, indicating what we are looking for: + + * WantNormal: fields are in scope only if they have an accompanying selector + function, e.g. we are looking up a variable in an expression + (lookupExprOccRn). + + * WantBoth: any name or field will do, regardless of whether the selector + function is available, e.g. record updates (lookupRecUpdFields) with + NoDisambiguateRecordFields. + + * WantField: any field will do, regardless of whether the selector function is + available, but ignoring any non-field names, e.g. record updates + (lookupRecUpdFields with DisambiguateRecordFields. + +----------------------------------------------------------------------------------- + Context FieldsOrSelectors +----------------------------------------------------------------------------------- + Record construction/pattern match WantField, but unless DisambiguateRecordFields + e.g. MkT { foo = 3 } is in effect, also look up using WantBoth + Record update, e.g. e { foo = 3 } to report when a non-field clashes with a field. + + :info in GHCi WantBoth + + Variable occurrence in expression WantNormal + Type variable, data constructor + Pretty much everything else +----------------------------------------------------------------------------------- +-} + +fieldGRE_maybe :: GlobalRdrElt -> Maybe FieldGlobalRdrElt +fieldGRE_maybe gre = do + guard (isRecFldGRE gre) + return gre + +fieldGRELabel :: HasDebugCallStack => FieldGlobalRdrElt -> FieldLabel +fieldGRELabel = recFieldLabel . fieldGREInfo + +fieldGREInfo :: HasDebugCallStack => FieldGlobalRdrElt -> RecFieldInfo +fieldGREInfo gre + = assertPpr (isRecFldGRE gre) (ppr gre) $ + case greInfo gre of + IAmRecField info -> info + info -> pprPanic "fieldGREInfo" $ + vcat [ text "gre_name:" <+> ppr (greName gre) + , text "info:" <+> ppr info ] + +recFieldConLike_maybe :: HasDebugCallStack => GlobalRdrElt -> Maybe ConInfo +recFieldConLike_maybe gre = + case greInfo gre of + IAmConLike info -> Just info + _ -> Nothing + +recFieldInfo_maybe :: HasDebugCallStack => GlobalRdrElt -> Maybe RecFieldInfo +recFieldInfo_maybe gre = + case greInfo gre of + IAmRecField info -> assertPpr (isRecFldGRE gre) (ppr gre) $ Just info + _ -> Nothing + +-- | When looking up GREs, we may or may not want to include fields that were +-- defined in modules with @NoFieldSelectors@ enabled. See Note +-- [NoFieldSelectors]. +data FieldsOrSelectors + = WantNormal -- ^ Include normal names, and fields with selectors, but + -- ignore fields without selectors. + | WantBoth -- ^ Include normal names and all fields (regardless of whether + -- they have selectors). + | WantField -- ^ Include only fields, with or without selectors, ignoring + -- any non-fields in scope. + deriving (Eq, Show) + +filterFieldGREs :: FieldsOrSelectors -> [GlobalRdrElt] -> [GlobalRdrElt] +filterFieldGREs WantBoth = id +filterFieldGREs fos = filter (allowGRE fos) + +allowGRE :: FieldsOrSelectors -> GlobalRdrElt -> Bool +allowGRE WantBoth _ + = True +allowGRE WantNormal gre + -- NB: we only need to consult the GREInfo for record field GREs, + -- to check whether they define field selectors. + -- By checking 'isRecFldGRE' first, which only consults the NameSpace, + -- we avoid forcing the GREInfo for things that aren't record fields. + | isRecFldGRE gre + = flHasFieldSelector (fieldGRELabel gre) == FieldSelectors + | otherwise + = True +allowGRE WantField gre + = isRecFldGRE gre + +-- | A parent of a child, in contexts like import/export lists, class and +-- instance declarations, etc. +-- +-- Not simply a 'GlobalRdrElt', because we don't always have a full +-- 'GlobalRdrElt' to hand (e.g. in 'GHC.Rename.Env.lookupInstDeclBndr'). +data ParentGRE + = ParentGRE + { parentGRE_name :: Name + , parentGRE_info :: GREInfo + } + +instance Outputable ParentGRE where + ppr (ParentGRE name info) = ppr name <+> parens (ppr info) + +instance Eq ParentGRE where + ParentGRE name1 _ == ParentGRE name2 _ = name1 == name2 + +-- | What should we look up in a 'GlobalRdrEnv'? Should we only look up +-- names with the exact same 'OccName', or do we allow different 'NameSpace's? +-- +-- Depending on the answer, we might need more or less information from the +-- 'GlobalRdrEnv', e.g. if we want to include matching record fields we need +-- to know if the corresponding record fields define field selectors, for which +-- we need to consult the 'GREInfo'. This is why this datatype is a GADT. +-- +-- See Note [IfGlobalRdrEnv]. +data LookupGRE info where + -- | Look for this specific 'OccName', with the exact same 'NameSpace', + -- in the 'GlobalRdrEnv'. + LookupOccName :: OccName -- ^ the 'OccName' to look up + -> WhichGREs info + -- ^ information about other relevant 'NameSpace's + -> LookupGRE info + + -- | Look up the 'OccName' of this 'RdrName' in the 'GlobalRdrEnv', + -- filtering out those whose qualification matches that of the 'RdrName'. + -- + -- Lookup returns an empty result for 'Exact' or 'Orig' 'RdrName's. + LookupRdrName :: RdrName -- ^ the 'RdrName' to look up + -> WhichGREs info + -- ^ information about other relevant 'NameSpace's + -> LookupGRE info + + -- | Look for 'GRE's with the same unique as the given 'Name' + -- in the 'GlobalRdrEnv'. + LookupExactName + :: { lookupExactName :: Name + -- ^ the 'Name' to look up + , lookInAllNameSpaces :: Bool + -- ^ whether to look in *all* 'NameSpace's, or just + -- in the 'NameSpace' of the 'Name' + -- See Note [Template Haskell ambiguity] + } + -> LookupGRE info + + -- | Look up children 'GlobalRdrElt's with a given 'Parent'. + LookupChildren + :: ParentGRE -- ^ the parent + -> OccName -- ^ the child 'OccName' to look up + -> LookupGRE GREInfo + +-- | How should we look up in a 'GlobalRdrEnv'? +-- Which 'NameSpace's are considered relevant for a given lookup? +data WhichGREs info where + -- | Only consider 'GlobalRdrElt's with the exact 'NameSpace' we look up. + SameNameSpace :: WhichGREs info + -- | Allow 'GlobalRdrElt's with different 'NameSpace's, e.g. allow looking up + -- record fields from the variable 'NameSpace', or looking up a 'TyCon' from + -- the data constructor 'NameSpace'. + RelevantGREs + :: { includeFieldSelectors :: !FieldsOrSelectors + -- ^ how should we handle looking up variables? + -- + -- - should we include record fields defined with @-XNoFieldSelectors@? + -- - should we include non-fields? + -- + -- See Note [NoFieldSelectors]. + , lookupVariablesForFields :: !Bool + -- ^ when looking up a record field, should we also look up plain variables? + , lookupTyConsAsWell :: !Bool + -- ^ when looking up a variable, field or data constructor, should we + -- also try the type constructor 'NameSpace'? + } + -> WhichGREs GREInfo + +instance Outputable (WhichGREs info) where + ppr SameNameSpace = text "SameNameSpace" + ppr (RelevantGREs { includeFieldSelectors = sel + , lookupVariablesForFields = vars + , lookupTyConsAsWell = tcs_too }) + = braces $ hsep + [ text "RelevantGREs" + , text (show sel) + , if vars then text "[vars]" else empty + , if tcs_too then text "[tcs]" else empty ] + +-- | Look up as many possibly relevant 'GlobalRdrElt's as possible. +pattern AllRelevantGREs :: WhichGREs GREInfo +pattern AllRelevantGREs = + RelevantGREs { includeFieldSelectors = WantBoth + , lookupVariablesForFields = True + , lookupTyConsAsWell = True } + +-- | Look up relevant GREs, taking into account the interaction between the +-- variable and field 'NameSpace's as determined by the 'FieldsOrSelector' +-- argument. +pattern RelevantGREsFOS :: FieldsOrSelectors -> WhichGREs GREInfo +pattern RelevantGREsFOS fos <- RelevantGREs { includeFieldSelectors = fos } + where + RelevantGREsFOS fos = + RelevantGREs { includeFieldSelectors = fos + , lookupVariablesForFields = fos == WantBoth + , lookupTyConsAsWell = False } + +-- | After looking up something with the given 'NameSpace', is the resulting +-- 'GlobalRdrElt' we have obtained relevant, according to the 'RelevantGREs' +-- specification of which 'NameSpace's are relevant? +greIsRelevant :: WhichGREs GREInfo -- ^ specification of which 'GlobalRdrElt's to consider relevant + -> NameSpace -- ^ the 'NameSpace' of the thing we are looking up + -> GlobalRdrElt -- ^ the 'GlobalRdrElt' we have looked up, in a + -- potentially different 'NameSpace' than we wanted + -> Bool +greIsRelevant which_gres ns gre + | ns == other_ns + = True + | otherwise + = case which_gres of + SameNameSpace -> False + RelevantGREs { includeFieldSelectors = fos + , lookupVariablesForFields = vars_for_flds + , lookupTyConsAsWell = tycons_too } + | ns == varName + -> (isFieldNameSpace other_ns && allowGRE fos gre) || tc_too + | isFieldNameSpace ns + -> vars_for_flds && + ( other_ns == varName + || (isFieldNameSpace other_ns && allowGRE fos gre) + || tc_too ) + | isDataConNameSpace ns + -> tc_too + | otherwise + -> False + where + tc_too = tycons_too && isTcClsNameSpace other_ns + where + other_ns = greNameSpace gre + +{- Note [childGREPriority] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are currently two places in the compiler where we look up GlobalRdrElts +which have a given Parent. These are the two calls to lookupSubBndrOcc_helper: + + A. Looking up children in an export item, e.g. + + module M ( T(MkT, D) ) where { data T = MkT; data D = D } + + B. Looking up binders in a class or instance declaration, e.g. + the operator +++ in the fixity declaration: + + class C a where { type (+++) :: a -> a ->; infixl 6 +++ } + (+++) :: Int -> Int -> Int; (+++) = (+) + +In these two situations, there are two metrics for finding the "best" +'GlobalRdrElt' that a particular 'OccName' resolves to: + + - does the resolved 'GlobalRdrElt' have the correct parent? + - does the resolved 'GlobalRdrElt' have the same 'NameSpace' as the 'OccName'? + +To resolve a children export item, we proceed by first prioritising GREs which +have the correct parent, and then break ties by looking at 'NameSpace's. + +Test cases: + - T11970: pattern synonyms, classes etc + - T10816, T23664, T24037: fixity declarations for associated types + - T20427: promoted data constructors and TypeData +-} + +-- | Scoring priority function for looking up children 'GlobalRdrElt'. +-- +-- The returned score orders by 'Parent' first and then by 'NameSpace', +-- with higher priorities having lower numbers. +-- +-- See Note [childGREPriority]. +childGREPriority :: ParentGRE -- ^ wanted parent + -> NameSpace -- ^ what 'NameSpace' are we originally looking in? + -> GlobalRdrElt + -- ^ the result of looking up; it might be in a different + -- 'NameSpace', which is used to determine the score + -- (in the second component) + -> Maybe (Int, Int) +childGREPriority (ParentGRE wanted_parent parent_info) wanted_ns child_gre = + (parent_prio, ) <$> child_ns_prio + + where + child_ns = greNameSpace child_gre + + -- Is the parent a class? Only class TyCons can have children that + -- are in the TcCls NameSpace (associated types). + is_class_parent = + case parent_info of + IAmTyCon ClassFlavour -> True + _ -> False + + -- Pick out the possible 'NameSpace's in order of priority. + child_ns_prio :: Maybe Int + child_ns_prio + | child_ns == wanted_ns + + -- Is it OK to have a child in this NameSpace? + -- + -- If it's in the TcCls NameSpace, then the parent must be a class, + -- unless the child is a promoted data constructor (which can happen + -- when exporting a TypeData declaration, see T20427). + , not (isTcClsNameSpace child_ns) || is_class_parent || child_is_data + = Just 0 + | isTermVarOrFieldNameSpace wanted_ns + , isTermVarOrFieldNameSpace child_ns + = Just 0 + | isValNameSpace wanted_ns + , is_class_parent && isTcClsNameSpace child_ns + -- When looking up children, we sometimes want a value name + -- to resolve to a type constructor. + -- For example, for an infix declaration "infixr 3 +!" or "infix 2 `Fun`" + -- inside a class declaration, we want to account for the possibility + -- that the identifier refers to an associated type (type constructor + -- NameSpace), when otherwise "+!" would be in the term-level variable + -- NameSpace, and "Fun" would be in the term-level data constructor + -- NameSpace. See tests T10816, T23664, T24037. + = Just 1 + | wanted_ns == tcName + , child_is_data + = Just $ + -- For classes we de-prioritise data constructors; + -- otherwise we prioritise them. + if is_class_parent + then 1 + else -1 + | otherwise + = Nothing + + parent_prio :: Int + parent_prio = + case greParent child_gre of + ParentIs other_parent + | other_parent == wanted_parent + -> 0 + | otherwise + -- The parent is wrong, so give this a low priority. + -- Don't return 'Nothing': if there are no other options, this + -- allows us to report an incorrect parent to the user, as opposed + -- to an out-of-scope error. + -> 1 + NoParent -> + -- Higher priority than having the wrong parent entirely, + -- but same priority as having the right parent. Why? See T25892: + -- + -- module M1 where + -- data D = K + -- module M2 (D(M2.K)) where + -- import qualified M1 + -- pattern K = M1.K + -- + -- Here, we do not want the data constructor M1.K to take priority + -- over the pattern synonym M2.K that we are trying to bundle. + 0 + + child_is_data = + case greInfo child_gre of + IAmConLike{} -> True + IAmTyCon PromotedDataConFlavour -> True + _ -> child_ns == dataName + +-- | Look something up in the Global Reader Environment. +-- +-- The 'LookupGRE' argument specifies what to look up, and in particular +-- whether there should there be any lee-way if the 'NameSpace's don't +-- exactly match. +lookupGRE :: GlobalRdrEnvX info -> LookupGRE info -> [GlobalRdrEltX info] +lookupGRE env = \case + LookupOccName occ which_gres -> + case which_gres of + SameNameSpace -> + concat $ lookupOccEnv env occ + rel@(RelevantGREs{}) -> + filter (greIsRelevant rel (occNameSpace occ)) $ + concat $ lookupOccEnv_AllNameSpaces env occ + LookupRdrName rdr rel -> + pickGREs rdr $ lookupGRE env (LookupOccName (rdrNameOcc rdr) rel) + LookupExactName { lookupExactName = nm + , lookInAllNameSpaces = all_ns } -> + [ gre | gre <- lkup, greName gre == nm ] + where + occ = nameOccName nm + lkup | all_ns = concat $ lookupOccEnv_AllNameSpaces env occ + | otherwise = fromMaybe [] $ lookupOccEnv env occ + LookupChildren parent child_occ -> + let ns = occNameSpace child_occ + all_gres = concat $ lookupOccEnv_AllNameSpaces env child_occ + in highestPriorityGREs (childGREPriority parent ns) all_gres + +-- | Collect the 'GlobalRdrElt's with the highest priority according +-- to the given function (lower value <=> higher priority). +-- +-- This allows us to first look in e.g. the data 'NameSpace', and then fall back +-- to the type/class 'NameSpace'. +highestPriorityGREs :: forall gre prio + . Ord prio + => (gre -> Maybe prio) + -- ^ priority function + -- lower value <=> higher priority + -> [gre] -> [gre] +highestPriorityGREs priority gres = + take_highest_prio $ NE.group $ sort + [ S.Arg prio gre + | gre <- gres + , prio <- maybeToList $ priority gre ] + where + take_highest_prio :: [NE.NonEmpty (S.Arg prio gre)] -> [gre] + take_highest_prio [] = [] + take_highest_prio (fs:_) = map (\ (S.Arg _ gre) -> gre) $ NE.toList fs +{-# INLINEABLE highestPriorityGREs #-} + +-- | Look for precisely this 'Name' in the environment, +-- in the __same 'NameSpace'__ as the 'Name'. +-- +-- This tests whether it is in scope, ignoring anything +-- else that might be in scope which doesn't have the same 'Unique'. +lookupGRE_Name :: Outputable info => GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info) +lookupGRE_Name env name = + case lookupGRE env (LookupExactName { lookupExactName = name + , lookInAllNameSpaces = False }) of + [] -> Nothing + [gre] -> Just gre + gres -> pprPanic "lookupGRE_Name" + (ppr name $$ ppr (nameOccName name) $$ ppr gres) + -- See INVARIANT 1 on GlobalRdrEnv + +-- | Look for a particular record field selector in the environment. +lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe FieldGlobalRdrElt +lookupGRE_FieldLabel env fl = + case lookupGRE_Name env (flSelector fl) of + Nothing -> Nothing + Just gre -> + assertPpr (isRecFldGRE gre) + (vcat [ text "lookupGre_FieldLabel:" <+> ppr fl ]) $ + Just gre + +getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] +-- Returns all the qualifiers by which 'x' is in scope +-- Nothing means "the unqualified version is in scope" +-- [] means the thing is not in scope at all +getGRE_NameQualifier_maybes env name + = case lookupGRE_Name env name of + Just gre -> [qualifier_maybe gre] + Nothing -> [] + where + qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) + | lcl = Nothing + | otherwise = Just $ map (is_as . is_decl) (bagToList iss) + +-- | Is this 'GlobalRdrElt' defined locally? +isLocalGRE :: GlobalRdrEltX info -> Bool +isLocalGRE (GRE { gre_lcl = lcl }) = lcl + +-- | Is this 'GlobalRdrElt' imported? +-- +-- Not just the negation of 'isLocalGRE', because it might be an Exact or +-- Orig name reference. See Note [GlobalRdrElt provenance]. +isImportedGRE :: GlobalRdrEltX info -> Bool +isImportedGRE (GRE { gre_imp = imps }) = not $ isEmptyBag imps + +-- | Is this a record field GRE? +-- +-- Important: does /not/ consult the 'GreInfo' field. +isRecFldGRE :: GlobalRdrEltX info -> Bool +isRecFldGRE (GRE { gre_name = nm }) = isFieldName nm + +isDuplicateRecFldGRE :: GlobalRdrElt -> Bool +-- ^ Is this a record field defined with DuplicateRecordFields? +isDuplicateRecFldGRE = + maybe False ((DuplicateRecordFields ==) . flHasDuplicateRecordFields) . greFieldLabel_maybe + +isNoFieldSelectorGRE :: GlobalRdrElt -> Bool +-- ^ Is this a record field defined with NoFieldSelectors? +-- (See Note [NoFieldSelectors] in GHC.Rename.Env) +isNoFieldSelectorGRE = + maybe False ((NoFieldSelectors ==) . flHasFieldSelector) . greFieldLabel_maybe + +isFieldSelectorGRE :: GlobalRdrElt -> Bool +-- ^ Is this a record field defined with FieldSelectors? +-- (See Note [NoFieldSelectors] in GHC.Rename.Env) +isFieldSelectorGRE = + maybe False ((FieldSelectors ==) . flHasFieldSelector) . greFieldLabel_maybe + +greFieldLabel_maybe :: GlobalRdrElt -> Maybe FieldLabel +-- ^ Returns the field label of this GRE, if it has one +greFieldLabel_maybe = fmap fieldGRELabel . fieldGRE_maybe + +unQualOK :: GlobalRdrEltX info -> Bool +-- ^ Test if an unqualified version of this thing would be in scope +unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) + | lcl = True + | otherwise = any unQualSpecOK iss + +{- Note [GRE filtering] +~~~~~~~~~~~~~~~~~~~~~~~ +(pickGREs rdr gres) takes a list of GREs which have the same OccName +as 'rdr', say "x". It does two things: + +(a) filters the GREs to a subset that are in scope + * Qualified, as 'M.x' if want_qual is Qual M _ + * Unqualified, as 'x' if want_unqual is Unqual _ + +(b) for that subset, filter the provenance field (gre_lcl and gre_imp) + to ones that brought it into scope qualified or unqualified resp. + +Example: + module A ( f ) where + import qualified Foo( f ) + import Baz( f ) + f = undefined + +Let's suppose that Foo.f and Baz.f are the same entity really, but the local +'f' is different, so there will be two GREs matching "f": + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] + +The use of "f" in the export list is ambiguous because it's in scope +from the local def and the import Baz(f); but *not* the import qualified Foo. +pickGREs returns two GRE + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Bar ] + +Now the "ambiguous occurrence" message can correctly report how the +ambiguity arises. +-} + +pickGREs :: RdrName -> [GlobalRdrEltX info] -> [GlobalRdrEltX info] +-- ^ Takes a list of GREs which have the right OccName 'x' +-- Pick those GREs that are in scope +-- * Qualified, as 'M.x' if want_qual is Qual M _ +-- * Unqualified, as 'x' if want_unqual is Unqual _ +-- +-- Return each such GRE, with its ImportSpecs filtered, to reflect +-- how it is in scope qualified or unqualified respectively. +-- See Note [GRE filtering] +pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres +pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres +pickGREs _ _ = [] -- I don't think this actually happens + +pickUnqualGRE :: GlobalRdrEltX info -> Maybe (GlobalRdrEltX info) +pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + | not lcl, null iss' = Nothing + | otherwise = Just (gre { gre_imp = iss' }) + where + iss' = filterBag unQualSpecOK iss + +pickQualGRE :: ModuleName -> GlobalRdrEltX info -> Maybe (GlobalRdrEltX info) +pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + | not lcl', null iss' = Nothing + | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) + where + iss' = filterBag (qualSpecOK mod) iss + lcl' = lcl && name_is_from mod + + name_is_from :: ModuleName -> Bool + name_is_from mod = case greDefinitionModule gre of + Just n_mod -> moduleName n_mod == mod + Nothing -> False + +pickGREsModExp :: ModuleName -> [GlobalRdrEltX info] -> [(GlobalRdrEltX info,GlobalRdrEltX info)] +-- ^ Pick GREs that are in scope *both* qualified *and* unqualified +-- Return each GRE that is, as a pair +-- (qual_gre, unqual_gre) +-- These two GREs are the original GRE with imports filtered to express how +-- it is in scope qualified an unqualified respectively +-- +-- Used only for the 'module M' item in export list; +-- see 'GHC.Tc.Gen.Export.exports_from_avail' +-- This function also only chooses GREs which are at level zero. +pickGREsModExp mod gres = mapMaybe (pickLevelZeroGRE >=> pickBothGRE mod) gres + +pickLevelZeroGRE :: GlobalRdrEltX info -> Maybe (GlobalRdrEltX info) +pickLevelZeroGRE gre = + if NormalLevel `Set.member` greLevels gre + then Just gre + else Nothing + +-- | isBuiltInSyntax filter out names for built-in syntax They +-- just clutter up the environment (esp tuples), and the +-- parser will generate Exact RdrNames for them, so the +-- cluttered envt is no use. Really, it's only useful for +-- GHC.Base and GHC.Tuple. +pickBothGRE :: ModuleName -> GlobalRdrEltX info -> Maybe (GlobalRdrEltX info, GlobalRdrEltX info) +pickBothGRE mod gre + | isBuiltInSyntax (greName gre) + = Nothing + | Just gre1 <- pickQualGRE mod gre + , Just gre2 <- pickUnqualGRE gre + = Just (gre1, gre2) + | otherwise + = Nothing + +-- Building GlobalRdrEnvs + +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 + +mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv +mkGlobalRdrEnv gres + = foldr add emptyGlobalRdrEnv gres + where + add gre env = extendOccEnv_Acc insertGRE Utils.singleton env + (greOccName gre) + gre + +insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] +insertGRE new_g [] = [new_g] +insertGRE new_g (old_g : old_gs) + | greName new_g == greName old_g + = new_g `plusGRE` old_g : old_gs + | otherwise + = old_g : insertGRE new_g old_gs + +plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt +-- Used when the gre_name fields match +plusGRE g1 g2 + = GRE { gre_name = gre_name g1 + , gre_lcl = gre_lcl g1 || gre_lcl g2 + , gre_imp = gre_imp g1 `unionBags` gre_imp g2 + , gre_par = gre_par g1 `plusParent` gre_par g2 + , gre_info = gre_info g1 `plusGREInfo` gre_info g2 } + +transformGREs :: (GlobalRdrElt -> GlobalRdrElt) + -> [OccName] + -> GlobalRdrEnv -> GlobalRdrEnv +-- ^ Apply a transformation function to the GREs for these OccNames +transformGREs trans_gre occs rdr_env + = foldr trans rdr_env occs + where + trans occ env + = case lookupOccEnv env occ of + Just gres -> extendOccEnv env occ (map trans_gre gres) + Nothing -> env + +extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv +extendGlobalRdrEnv env gre + = extendOccEnv_Acc insertGRE Utils.singleton env + (greOccName gre) gre + +{- Note [GlobalRdrEnv shadowing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before adding new names to the GlobalRdrEnv we nuke some existing entries; +this is "shadowing". The actual work is done by GHC.Types.Name.Reader.shadowNames. +Suppose + + env' = shadowNames env { f } `extendGlobalRdrEnv` { M.f } + +Then: + * Looking up (Unqual f) in env' should succeed, returning M.f, + even if env contains existing unqualified bindings for f. + They are shadowed + + * Looking up (Qual M.f) in env' should succeed, returning M.f + + * Looking up (Qual X.f) in env', where X /= M, should be the same as + looking up (Qual X.f) in env. + + That is, shadowNames does /not/ delete earlier qualified bindings + +There are two reasons for shadowing: + +* The GHCi REPL + + - Ids bought into scope on the command line (eg let x = True) have + External Names, like Ghci4.x. We want a new binding for 'x' (say) + to override the existing binding for 'x'. Example: + + ghci> :load M -- Brings `x` and `M.x` into scope + ghci> x + ghci> "Hello" + ghci> M.x + ghci> "hello" + ghci> let x = True -- Shadows `x` + ghci> x -- The locally bound `x` + -- NOT an ambiguous reference + ghci> True + ghci> M.x -- M.x is still in scope! + ghci> "Hello" + + So when we add `x = True` we must not delete the `M.x` from the + `GlobalRdrEnv`; rather we just want to make it "qualified only"; + hence the `set_qual` in `shadowNames`. See also Note + [Interactively-bound Ids in GHCi] in GHC.Runtime.Context + + - Data types also have External Names, like Ghci4.T; but we still want + 'T' to mean the newly-declared 'T', not an old one. + +* Nested Template Haskell declaration brackets + See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names + + Consider a TH decl quote: + module M where + f x = h [d| f = ...f...M.f... |] + We must shadow the outer unqualified binding of 'f', else we'll get + a complaint when extending the GlobalRdrEnv, saying that there are + two bindings for 'f'. There are several tricky points: + + - This shadowing applies even if the binding for 'f' is in a + where-clause, and hence is in the *local* RdrEnv not the *global* + RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. + + - The External Name M.f from the enclosing module must certainly + still be available. So we don't nuke it entirely; we just make + it seem like qualified import. + + - We only shadow *External* names (which come from the main module), + or from earlier GHCi commands. Do not shadow *Internal* names + because in the bracket + [d| class C a where f :: a + f = 4 |] + rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the + class decl, and *separately* extend the envt with the value binding. + At that stage, the class op 'f' will have an Internal name. + +Wrinkle [Shadowing namespaces] + + In the following GHCi session: + + > data A = MkA { foo :: Int } + > foo = False + > bar = foo + + We expect the variable 'foo' to shadow the record field 'foo', even though + they are in separate namespaces, so that the occurrence of 'foo' in the body + of 'bar' is not ambiguous. + +-} + +shadowNames :: Bool -- ^ discard names that are only available qualified? + -> GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +-- Remove certain old GREs that share the same OccName as this new Name. +-- See Note [GlobalRdrEnv shadowing] for details +shadowNames drop_only_qualified env new_gres = minusOccEnv_C_Ns do_shadowing env new_gres + where + + do_shadowing :: UniqFM NameSpace [GlobalRdrElt] + -> UniqFM NameSpace [GlobalRdrElt] + -> UniqFM NameSpace [GlobalRdrElt] + do_shadowing olds news = + -- Start off by accumulating all 'NameSpace's shadowed + -- by the entire collection of new GREs. + let shadowed_gres :: ShadowedGREs + shadowed_gres = + nonDetFoldUFM (\ gres shads -> foldMap greShadowedNameSpaces gres S.<> shads) + mempty news + + -- Then shadow the old 'GlobalRdrElt's, now that we know which 'NameSpace's + -- should be shadowed. + shadow_list :: Unique -> [GlobalRdrElt] -> Maybe [GlobalRdrElt] + shadow_list old_ns old_gres = + case namespace_is_shadowed old_ns shadowed_gres of + IsNotShadowed -> Just old_gres + IsShadowed -> guard_nonEmpty $ mapMaybe shadow old_gres + IsShadowedIfFieldSelector -> + guard_nonEmpty $ + mapMaybe (\ old_gre -> if isFieldSelectorGRE old_gre then shadow old_gre else Just old_gre) + old_gres + + -- Now do all of the shadowing in a single go. This avoids traversing + -- the old GlobalRdrEnv multiple times over. + in mapMaybeWithKeyUFM shadow_list olds + + guard_nonEmpty :: [a] -> Maybe [a] + guard_nonEmpty xs | null xs = Nothing + | otherwise = Just xs + + -- Shadow a single GRE, by either qualifying it or removing it entirely. + shadow :: GlobalRdrElt-> Maybe GlobalRdrElt + shadow old_gre@(GRE { gre_lcl = lcl, gre_imp = iss }) = + case greDefinitionModule old_gre of + Nothing -> Just old_gre -- Old name is Internal; do not shadow + Just old_mod + | null iss' -- Nothing remains + || drop_only_qualified + -> Nothing + + | otherwise + -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) + + where + iss' = lcl_imp `unionBags` mapBag set_qual iss + lcl_imp | lcl = unitBag $ mk_fake_imp_spec old_gre old_mod + | otherwise = emptyBag + + mk_fake_imp_spec old_gre old_mod -- Urgh! + = ImpSpec id_spec ImpAll + where + old_mod_name = moduleName old_mod + id_spec = ImpDeclSpec { is_mod = old_mod + , is_as = old_mod_name + , is_pkg_qual = NoPkgQual + , is_qual = True + , is_level = NormalLevel -- MP: Not 100% sure this is correct + , is_isboot = NotBoot + , is_dloc = greDefinitionSrcSpan old_gre } + + set_qual :: ImportSpec -> ImportSpec + set_qual is = is { is_decl = (is_decl is) { is_qual = True } } + +-- | @greClashesWith new_gre old_gre@ computes whether @new_gre@ clashes +-- with @old_gre@ (assuming they both have the same underlying 'occNameFS'). +greClashesWith :: GlobalRdrElt -> (GlobalRdrElt -> Bool) +greClashesWith new_gre old_gre = + old_gre `greIsShadowed` greShadowedNameSpaces new_gre + +-- | Is the given 'GlobalRdrElt' shadowed, as specified by the 'ShadowedNameSpace's? +greIsShadowed :: GlobalRdrElt -> ShadowedGREs -> Bool +greIsShadowed old_gre shadowed = + case getUnique old_ns `namespace_is_shadowed` shadowed of + IsShadowed -> True + IsNotShadowed -> False + IsShadowedIfFieldSelector -> isFieldSelectorGRE old_gre + where + old_ns = occNameSpace $ greOccName old_gre + + +-- | Whether a 'GlobalRdrElt' is definitely shadowed, definitely not shadowed, +-- or conditionally shadowed based on more information beyond the 'NameSpace'. +data IsShadowed + -- | The GRE is not shadowed. + = IsNotShadowed + -- | The GRE is shadowed. + | IsShadowed + -- | The GRE is shadowed iff it is a record field GRE + -- which defines a field selector (i.e. FieldSelectors is enabled in its + -- defining module). + | IsShadowedIfFieldSelector + +-- | Internal function: is a 'GlobalRdrElt' with the 'NameSpace' with given +-- 'Unique' shadowed by the specified 'ShadowedGREs'? +namespace_is_shadowed :: Unique -> ShadowedGREs -> IsShadowed +namespace_is_shadowed old_ns (ShadowedGREs shadowed_nonflds shadowed_flds) + | isFldNSUnique old_ns + = case shadowed_flds of + ShadowAllFieldGREs -> IsShadowed + ShadowFieldSelectorsAnd shadowed + | old_ns `elemUniqSet_Directly` shadowed + -> IsShadowed + | otherwise + -> IsShadowedIfFieldSelector + ShadowFieldNameSpaces shadowed + | old_ns `elemUniqSet_Directly` shadowed + -> IsShadowed + | otherwise + -> IsNotShadowed + | old_ns `elemUniqSet_Directly` shadowed_nonflds + = IsShadowed + | otherwise + = IsNotShadowed + +-- | What are all the 'GlobalRdrElt's that are shadowed by this new 'GlobalRdrElt'? +greShadowedNameSpaces :: GlobalRdrElt -> ShadowedGREs +greShadowedNameSpaces gre = ShadowedGREs shadowed_nonflds shadowed_flds + where + ns = occNameSpace $ greOccName gre + !shadowed_nonflds + | isFieldNameSpace ns + -- A new record field shadows variables if it defines a field selector. + = if isFieldSelectorGRE gre + then unitUniqSet varName + else emptyUniqSet + | otherwise + = unitUniqSet ns + !shadowed_flds + | ns == varName + -- A new variable shadows record fields with field selectors. + = ShadowFieldSelectorsAnd emptyUniqSet + | isFieldNameSpace ns + -- A new record field shadows record fields unless it is a duplicate record field. + = if isDuplicateRecFldGRE gre + then ShadowFieldNameSpaces (unitUniqSet ns) + -- NB: we must still shadow fields with the same constructor name. + else ShadowAllFieldGREs + | otherwise + = ShadowFieldNameSpaces emptyUniqSet + +-- | A description of which 'GlobalRdrElt's are shadowed. +data ShadowedGREs + = ShadowedGREs + { shadowedNonFieldNameSpaces :: !(UniqSet NameSpace) + -- ^ These specific non-field 'NameSpace's are shadowed. + , shadowedFieldGREs :: !ShadowedFieldGREs + -- ^ These field 'GlobalRdrElt's are shadowed. + } + +-- | A description of which record field 'GlobalRdrElt's are shadowed. +data ShadowedFieldGREs + -- | All field 'GlobalRdrElt's are shadowed. + = ShadowAllFieldGREs + -- | Record field GREs defining field selectors, as well as those + -- with the explicitly specified field 'NameSpace's, are shadowed. + | ShadowFieldSelectorsAnd { shadowedFieldNameSpaces :: !(UniqSet NameSpace) } + -- | These specific field 'NameSpace's are shadowed. + | ShadowFieldNameSpaces { shadowedFieldNameSpaces :: !(UniqSet NameSpace) } + +instance Monoid ShadowedFieldGREs where + mempty = ShadowFieldNameSpaces { shadowedFieldNameSpaces = emptyUniqSet } + +instance Semigroup ShadowedFieldGREs where + ShadowAllFieldGREs <> _ = ShadowAllFieldGREs + _ <> ShadowAllFieldGREs = ShadowAllFieldGREs + ShadowFieldSelectorsAnd ns1 <> ShadowFieldSelectorsAnd ns2 = + ShadowFieldSelectorsAnd (ns1 S.<> ns2) + ShadowFieldSelectorsAnd ns1 <> ShadowFieldNameSpaces ns2 = + ShadowFieldSelectorsAnd (ns1 S.<> ns2) + ShadowFieldNameSpaces ns1 <> ShadowFieldSelectorsAnd ns2 = + ShadowFieldSelectorsAnd (ns1 S.<> ns2) + ShadowFieldNameSpaces ns1 <> ShadowFieldNameSpaces ns2 = + ShadowFieldNameSpaces (ns1 S.<> ns2) + +instance Monoid ShadowedGREs where + mempty = + ShadowedGREs + { shadowedNonFieldNameSpaces = emptyUniqSet + , shadowedFieldGREs = mempty } + +instance Semigroup ShadowedGREs where + ShadowedGREs nonflds1 flds1 <> ShadowedGREs nonflds2 flds2 = + ShadowedGREs (nonflds1 S.<> nonflds2) (flds1 S.<> flds2) + +{- +************************************************************************ +* * + ImportSpec +* * +************************************************************************ +-} + +-- | Import Specification +-- +-- The 'ImportSpec' of something says how it came to be imported +-- It's quite elaborate so that we can give accurate unused-name warnings. +data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec, + is_item :: !ImpItemSpec } + deriving( Eq, Data ) + +instance NFData ImportSpec where + rnf = rwhnf -- All fields are strict, so we don't need to do anything + +-- | Import Declaration Specification +-- +-- Describes a particular import declaration and is +-- shared among all the 'Provenance's for that decl +data ImpDeclSpec + = ImpDeclSpec { + is_mod :: !Module, -- ^ Module imported, e.g. @import Muggle@ + -- Note the @Muggle@ may well not be + -- the defining module for this thing! + + -- TODO: either should be Module, or there + -- should be a Maybe UnitId here too. + is_as :: !ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_pkg_qual :: !PkgQual, -- ^ Was this a package import? + is_qual :: !Bool, -- ^ Was this import qualified? + is_dloc :: !SrcSpan, -- ^ The location of the entire import declaration + is_isboot :: !IsBootInterface, -- ^ Was this a SOURCE import? + is_level :: !ImportLevel -- ^ Was this import level modified? splice/quote +-1 + } deriving (Eq, Data) + + + +instance NFData ImpDeclSpec where + rnf = rwhnf -- Already strict in all fields + + +instance Binary ImpDeclSpec where + put_ bh (ImpDeclSpec mod as pkg_qual qual _dloc isboot isstage) = do + put_ bh mod + put_ bh as + put_ bh pkg_qual + put_ bh qual + put_ bh isboot + put_ bh (fromEnum isstage) + + get bh = do + mod <- get bh + as <- get bh + pkg_qual <- get bh + qual <- get bh + isboot <- get bh + isstage <- toEnum <$> get bh + return (ImpDeclSpec mod as pkg_qual qual noSrcSpan isboot isstage) + +-- | Import Item Specification +-- +-- Describes import info a particular Name +data ImpItemSpec + = ImpAll -- ^ The import had no import list, + -- or had a hiding list + + | ImpSome { + is_explicit :: !Bool, + is_iloc :: !SrcSpan -- Location of the import item + } -- ^ The import had an import list. + -- The 'is_explicit' field is @True@ iff the thing was named + -- /explicitly/ in the import specs rather + -- than being imported as part of a "..." group. Consider: + -- + -- > import C( T(..) ) + -- + -- Here the constructors of @T@ are not named explicitly; + -- only @T@ is named explicitly. + deriving (Eq, Data) + +bestImport :: NE.NonEmpty ImportSpec -> ImportSpec +-- See Note [Choosing the best import declaration] +bestImport iss = NE.head $ NE.sortBy best iss + where + best :: ImportSpec -> ImportSpec -> Ordering + -- Less means better + -- Unqualified always wins over qualified; then + -- import-all wins over import-some; then + -- earlier declaration wins over later + best (ImpSpec { is_item = item1, is_decl = d1 }) + (ImpSpec { is_item = item2, is_decl = d2 }) + = (is_qual d1 `compare` is_qual d2) S.<> best_item item1 item2 S.<> + SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2) + + best_item :: ImpItemSpec -> ImpItemSpec -> Ordering + best_item ImpAll ImpAll = EQ + best_item ImpAll (ImpSome {}) = LT + best_item (ImpSome {}) ImpAll = GT + best_item (ImpSome { is_explicit = e1 }) + (ImpSome { is_explicit = e2 }) = e1 `compare` e2 + -- False < True, so if e1 is explicit and e2 is not, we get GT + +{- Note [Choosing the best import declaration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When reporting unused import declarations we use the following rules. + (see [wiki:commentary/compiler/unused-imports]) + +Say that an import-item is either + * an entire import-all decl (eg import Foo), or + * a particular item in an import list (eg import Foo( ..., x, ...)). +The general idea is that for each /occurrence/ of an imported name, we will +attribute that use to one import-item. Once we have processed all the +occurrences, any import items with no uses attributed to them are unused, +and are warned about. More precisely: + +1. For every RdrName in the program text, find its GlobalRdrElt. + +2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one + the "chosen import-item", and mark it "used". This is done + by 'bestImport' + +3. After processing all the RdrNames, bleat about any + import-items that are unused. + This is done in GHC.Rename.Names.warnUnusedImportDecls. + +The function 'bestImport' returns the dominant import among the +ImportSpecs it is given, implementing Step 2. We say import-item A +dominates import-item B if we choose A over B. In general, we try to +choose the import that is most likely to render other imports +unnecessary. Here is the dominance relationship we choose: + + a) import Foo dominates import qualified Foo. + + b) import Foo dominates import Foo(x). + + c) Otherwise choose the textually first one. + +Rationale for (a). Consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + x + +The unqualified 'x' can only come from import #2. The qualified 'M.x' +could come from either, but bestImport picks import #2, because it is +more likely to be useful in other imports, as indeed it is in this +case (see #5211 for a concrete example). + +But the rules are not perfect; consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + M.y + +The M.x will use import #2, but M.y can only use import #1. +-} + + +unQualSpecOK :: ImportSpec -> Bool +-- ^ Is in scope unqualified? +unQualSpecOK is = not (is_qual (is_decl is)) + +qualSpecOK :: ModuleName -> ImportSpec -> Bool +-- ^ Is in scope qualified with the given module? +qualSpecOK mod is = mod == is_as (is_decl is) + +importSpecLoc :: ImportSpec -> SrcSpan +importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl +importSpecLoc (ImpSpec _ item) = is_iloc item + +importSpecModule :: ImportSpec -> ModuleName +importSpecModule = moduleName . is_mod . is_decl + +importSpecLevel :: ImportSpec -> ImportLevel +importSpecLevel = is_level . is_decl + +isExplicitItem :: ImpItemSpec -> Bool +isExplicitItem ImpAll = False +isExplicitItem (ImpSome {is_explicit = exp}) = exp + +pprNameProvenance :: GlobalRdrEltX info -> SDoc +-- ^ Print out one place where the name was define/imported +-- (With -dppr-debug, print them all) +pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) + = ifPprDebug (vcat pp_provs) + (head pp_provs) + where + pp_provs = pp_lcl ++ map pp_is (bagToList iss) + pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] + else [] + pp_is is = sep [ppr is, ppr_defn_site is name] + +-- If we know the exact definition point (which we may do with GHCi) +-- then show that too. But not if it's just "imported from X". +ppr_defn_site :: ImportSpec -> Name -> SDoc +ppr_defn_site imp_spec name + | same_module && not (isGoodSrcSpan loc) + = empty -- Nothing interesting to say + | otherwise + = parens $ hang (text "and originally defined" <+> pp_mod) + 2 (pprLoc loc) + where + loc = nameSrcSpan name + defining_mod = assertPpr (isExternalName name) (ppr name) $ nameModule name + same_module = importSpecModule imp_spec == moduleName defining_mod + pp_mod | same_module = empty + | otherwise = text "in" <+> quotes (ppr defining_mod) + + +instance Outputable ImportSpec where + ppr imp_spec + = text "imported" <+> qual + <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) + <+> level_ppr + <+> pprLoc (importSpecLoc imp_spec) + where + qual | is_qual (is_decl imp_spec) = text "qualified" + | otherwise = empty + + level = thLevelIndexFromImportLevel (is_level (is_decl imp_spec)) + level_ppr + | level == topLevelIndex = empty + | otherwise = text "at" <+> ppr level + + +pprLoc :: SrcSpan -> SDoc +pprLoc (RealSrcSpan s _) = text "at" <+> ppr s +pprLoc (UnhelpfulSpan {}) = empty + +-- | Indicate if the given name is the "@" operator +opIsAt :: RdrName -> Bool +opIsAt e = e == mkUnqual varName (fsLit "@") + + +-------------------------------------------------------------------------------- +-- Preserving user-written qualification + +-- | 'WithUserRdr' allows us to keep track of the original user-written +-- 'RdrName', and in particular, any user-written module qualification. +-- +-- See Note [IdOcc] in Language.Haskell.Syntax.Extension. +data WithUserRdr a = WithUserRdr RdrName a + deriving stock (Functor, Foldable, Traversable) + +instance NamedThing a => NamedThing (WithUserRdr a) where + getName (WithUserRdr _rdr a) = getName a +instance Outputable (WithUserRdr Name) where + ppr (WithUserRdr rdr name) = + pprName_userQual (rdrQual_maybe rdr) name +instance OutputableBndr (WithUserRdr Name) where + pprBndr _ (WithUserRdr rdr name) = + pprName_userQual (rdrQual_maybe rdr) name + pprInfixOcc :: WithUserRdr Name -> SDoc + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + +unLocWithUserRdr :: GenLocated l (WithUserRdr a) -> a +unLocWithUserRdr (L _ (WithUserRdr _ a)) = a + +noUserRdr :: Name -> WithUserRdr Name +noUserRdr n = WithUserRdr (nameRdrName n) n + +userRdrName :: WithUserRdr Name -> RdrName +userRdrName (WithUserRdr rdr _) = rdr + +rdrQual_maybe :: RdrName -> Maybe ModuleName +rdrQual_maybe = \case + Qual q _ -> Just q + _ -> Nothing + +-------------------------------------------------------------------------------- diff --git a/GHC/Types/Name/Set.hs b/GHC/Types/Name/Set.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Set.hs @@ -0,0 +1,226 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +-} + + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Types.Name.Set ( + -- * Names set type + NameSet, + + -- ** Manipulating these sets + emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, + minusNameSet, elemNameSet, extendNameSet, extendNameSetList, + delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet, + intersectsNameSet, disjointNameSet, intersectNameSet, + nameSetAny, nameSetAll, nameSetElemsStable, + + -- * Free variables + FreeVars, + + -- ** Manipulating sets of free variables + isEmptyFVs, emptyFVs, plusFVs, plusFV, + mkFVs, addOneFV, unitFV, delFV, delFVs, + intersectFVs, intersectsFVs, + + -- * Defs and uses + Defs, Uses, DefUse, DefUses, + + -- ** Manipulating defs and uses + emptyDUs, usesOnly, mkDUs, plusDU, + findUses, duDefs, duUses, allUses, + + -- * Non-CAFfy names + NonCaffySet(..) + ) where + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Data.OrdList +import GHC.Types.Unique.Set +import Data.List (sortBy) + +{- +************************************************************************ +* * +\subsection[Sets of names} +* * +************************************************************************ +-} + +type NameSet = UniqSet Name + +emptyNameSet :: NameSet +unitNameSet :: Name -> NameSet +extendNameSetList :: NameSet -> [Name] -> NameSet +extendNameSet :: NameSet -> Name -> NameSet +mkNameSet :: [Name] -> NameSet +unionNameSet :: NameSet -> NameSet -> NameSet +unionNameSets :: [NameSet] -> NameSet +minusNameSet :: NameSet -> NameSet -> NameSet +elemNameSet :: Name -> NameSet -> Bool +isEmptyNameSet :: NameSet -> Bool +delFromNameSet :: NameSet -> Name -> NameSet +delListFromNameSet :: NameSet -> [Name] -> NameSet +filterNameSet :: (Name -> Bool) -> NameSet -> NameSet +intersectNameSet :: NameSet -> NameSet -> NameSet +intersectsNameSet :: NameSet -> NameSet -> Bool +disjointNameSet :: NameSet -> NameSet -> Bool +-- ^ True if there is a non-empty intersection. +-- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty + +isEmptyNameSet = isEmptyUniqSet +emptyNameSet = emptyUniqSet +unitNameSet = unitUniqSet +mkNameSet = mkUniqSet +extendNameSetList = addListToUniqSet +extendNameSet = addOneToUniqSet +unionNameSet = unionUniqSets +unionNameSets = unionManyUniqSets +minusNameSet = minusUniqSet +elemNameSet = elementOfUniqSet +delFromNameSet = delOneFromUniqSet +filterNameSet = filterUniqSet +intersectNameSet = intersectUniqSets +disjointNameSet = disjointUniqSets + +delListFromNameSet set ns = foldl' delFromNameSet set ns + +intersectsNameSet s1 s2 = not (s1 `disjointNameSet` s2) + +nameSetAny :: (Name -> Bool) -> NameSet -> Bool +nameSetAny = uniqSetAny + +nameSetAll :: (Name -> Bool) -> NameSet -> Bool +nameSetAll = uniqSetAll + +-- | Get the elements of a NameSet with some stable ordering. +-- This only works for Names that originate in the source code or have been +-- tidied. +-- See Note [Deterministic UniqFM] to learn about nondeterminism +nameSetElemsStable :: NameSet -> [Name] +nameSetElemsStable ns = + sortBy stableNameCmp $ nonDetEltsUniqSet ns + -- It's OK to use nonDetEltsUniqSet here because we immediately sort + -- with stableNameCmp + +{- +************************************************************************ +* * +\subsection{Free variables} +* * +************************************************************************ + +These synonyms are useful when we are thinking of free variables +-} + +type FreeVars = NameSet + +plusFV :: FreeVars -> FreeVars -> FreeVars +addOneFV :: FreeVars -> Name -> FreeVars +unitFV :: Name -> FreeVars +emptyFVs :: FreeVars +plusFVs :: [FreeVars] -> FreeVars +mkFVs :: [Name] -> FreeVars +delFV :: Name -> FreeVars -> FreeVars +delFVs :: [Name] -> FreeVars -> FreeVars +intersectFVs :: FreeVars -> FreeVars -> FreeVars +intersectsFVs :: FreeVars -> FreeVars -> Bool + +isEmptyFVs :: NameSet -> Bool +isEmptyFVs = isEmptyNameSet +emptyFVs = emptyNameSet +plusFVs = unionNameSets +plusFV = unionNameSet +mkFVs = mkNameSet +addOneFV = extendNameSet +unitFV = unitNameSet +delFV n s = delFromNameSet s n +delFVs ns s = delListFromNameSet s ns +intersectFVs = intersectNameSet +intersectsFVs = intersectsNameSet + +{- +************************************************************************ +* * + Defs and uses +* * +************************************************************************ +-} + +-- | A set of names that are defined somewhere +type Defs = NameSet + +-- | A set of names that are used somewhere +type Uses = NameSet + +-- | @(Just ds, us) =>@ The use of any member of the @ds@ +-- implies that all the @us@ are used too. +-- Also, @us@ may mention @ds@. +-- +-- @Nothing =>@ Nothing is defined in this group, but +-- nevertheless all the uses are essential. +-- Used for instance declarations, for example +type DefUse = (Maybe Defs, Uses) + +-- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' +-- In a single (def, use) pair, the defs also scope over the uses +type DefUses = OrdList DefUse + +emptyDUs :: DefUses +emptyDUs = nilOL + +usesOnly :: Uses -> DefUses +usesOnly uses = unitOL (Nothing, uses) + +mkDUs :: [(Defs,Uses)] -> DefUses +mkDUs pairs = toOL [(Just defs, uses) | (defs,uses) <- pairs] + +plusDU :: DefUses -> DefUses -> DefUses +plusDU = appOL + +duDefs :: DefUses -> Defs +duDefs dus = foldr get emptyNameSet dus + where + get (Nothing, _u1) d2 = d2 + get (Just d1, _u1) d2 = d1 `unionNameSet` d2 + +allUses :: DefUses -> Uses +-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned +allUses dus = foldr get emptyNameSet dus + where + get (_d1, u1) u2 = u1 `unionNameSet` u2 + +duUses :: DefUses -> Uses +-- ^ Collect all 'Uses', regardless of whether the group is itself used, +-- but remove 'Defs' on the way +duUses dus = foldr get emptyNameSet dus + where + get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses) + `minusNameSet` defs + +findUses :: DefUses -> Uses -> Uses +-- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. +-- The result is a superset of the input 'Uses'; and includes things defined +-- in the input 'DefUses' (but only if they are used) +findUses dus uses + = foldr get uses dus + where + get (Nothing, rhs_uses) uses + = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses + | defs `intersectsNameSet` uses -- Used + || nameSetAny (startsWithUnderscore . nameOccName) defs + -- At least one starts with an "_", + -- so treat the group as used + = rhs_uses `unionNameSet` uses + | otherwise -- No def is used + = uses + +-- | 'Id's which have no CAF references. This is a result of analysis of C--. +-- It is always safe to use an empty 'NonCaffySet'. TODO Refer to Note. +newtype NonCaffySet = NonCaffySet { ncs_nameSet :: NameSet } + deriving (Semigroup, Monoid) diff --git a/GHC/Types/Name/Shape.hs b/GHC/Types/Name/Shape.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Shape.hs @@ -0,0 +1,256 @@ + + +module GHC.Types.Name.Shape + ( NameShape(..) + , emptyNameShape + , mkNameShape + , extendNameShape + , nameShapeExports + , substNameShape + , maybeSubstNameShape + ) +where + +import GHC.Prelude + +import GHC.Driver.Env + +import GHC.Unit.Module + +import GHC.Types.Avail +import GHC.Types.Name +import GHC.Types.Name.Env + +import GHC.Tc.Utils.Monad +import GHC.Iface.Env +import GHC.Tc.Errors.Types + +import GHC.Utils.Panic.Plain + +import Control.Monad + +-- Note [NameShape] +-- ~~~~~~~~~~~~~~~~ +-- When we write a declaration in a signature, e.g., data T, we +-- ascribe to it a *name variable*, e.g., {m.T}. This +-- name variable may be substituted with an actual original +-- name when the signature is implemented (or even if we +-- merge the signature with one which reexports this entity +-- from another module). + +-- When we instantiate a signature m with a module M, +-- we also need to substitute over names. To do so, we must +-- compute the *name substitution* induced by the *exports* +-- of the module in question. A NameShape represents +-- such a name substitution for a single module instantiation. +-- The "shape" in the name comes from the fact that the computation +-- of a name substitution is essentially the *shaping pass* from +-- Backpack'14, but in a far more restricted form. + +-- The name substitution for an export list is easy to explain. If we are +-- filling the module variable , given an export N of the form +-- M.n or {m'.n} (where n is an OccName), the induced name +-- substitution is from {m.n} to N. So, for example, if we have +-- A=impl:B, and the exports of impl:B are impl:B.f and +-- impl:C.g, then our name substitution is {A.f} to impl:B.f +-- and {A.g} to impl:C.g + + + + +-- The 'NameShape' type is defined in GHC.Tc.Types, because GHC.Tc.Types +-- needs to refer to NameShape, and having GHC.Tc.Types import +-- NameShape (even by SOURCE) would cause a large number of +-- modules to be pulled into the DynFlags cycle. +{- +data NameShape = NameShape { + ns_mod_name :: ModuleName, + ns_exports :: [AvailInfo], + ns_map :: OccEnv Name + } +-} + +-- NB: substitution functions need 'HscEnv' since they need the name cache +-- to allocate new names if we change the 'Module' of a 'Name' + +-- | Create an empty 'NameShape' (i.e., the renaming that +-- would occur with an implementing module with no exports) +-- for a specific hole @mod_name@. +emptyNameShape :: ModuleName -> NameShape +emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv + +-- | Create a 'NameShape' corresponding to an implementing +-- module for the hole @mod_name@ that exports a list of 'AvailInfo's. +mkNameShape :: ModuleName -> [AvailInfo] -> NameShape +mkNameShape mod_name as = + NameShape mod_name as $ mkOccEnv $ do + a <- as + n <- availName a : availNames a + return (occName n, n) + +-- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's +-- with Backpack style mix-in linking. This is used solely when merging +-- signatures together: we successively merge the exports of each +-- signature until we have the final, full exports of the merged signature. +-- +-- What makes this operation nontrivial is what we are supposed to do when +-- we want to merge in an export for M.T when we already have an existing +-- export {H.T}. What should happen in this case is that {H.T} should be +-- unified with @M.T@: we've determined a more *precise* identity for the +-- export at 'OccName' @T@. +-- +-- Note that we don't do unrestricted unification: only name holes from +-- @ns_mod_name ns@ are flexible. This is because we have a much more +-- restricted notion of shaping than in Backpack'14: we do shaping +-- *as* we do type-checking. Thus, once we shape a signature, its +-- exports are *final* and we're not allowed to refine them further, +extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either HsigShapeMismatchReason NameShape) +extendNameShape hsc_env ns as = + case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of + Left err -> return (Left err) + Right nsubst -> do + as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns) + as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as + let new_avails = mergeAvails as1 as2 + return . Right $ ns { + ns_exports = new_avails, + -- TODO: stop repeatedly rebuilding the OccEnv + ns_map = mkOccEnv $ do + a <- new_avails + n <- availName a : availNames a + return (occName n, n) + } + +-- | The export list associated with this 'NameShape' (i.e., what +-- the exports of an implementing module which induces this 'NameShape' +-- would be.) +nameShapeExports :: NameShape -> [AvailInfo] +nameShapeExports = ns_exports + +-- | Given a 'Name', substitute it according to the 'NameShape' implied +-- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module +-- exports @M.T@. +substNameShape :: NameShape -> Name -> Name +substNameShape ns n | nameModule n == ns_module ns + , Just n' <- lookupOccEnv (ns_map ns) (occName n) + = n' + | otherwise + = n + +-- | Like 'substNameShape', but returns @Nothing@ if no substitution +-- works. +maybeSubstNameShape :: NameShape -> Name -> Maybe Name +maybeSubstNameShape ns n + | nameModule n == ns_module ns + = lookupOccEnv (ns_map ns) (occName n) + | otherwise + = Nothing + +-- | The 'Module' of any 'Name's a 'NameShape' has action over. +ns_module :: NameShape -> Module +ns_module = mkHoleModule . ns_mod_name + +{- +************************************************************************ +* * + Name substitutions +* * +************************************************************************ +-} + +-- | Substitution on @{A.T}@. We enforce the invariant that the +-- 'nameModule' of keys of this map have 'moduleUnit' @hole@ +-- (meaning that if we have a hole substitution, the keys of the map +-- are never affected.) Alternatively, this is isomorphic to +-- @Map ('ModuleName', 'OccName') 'Name'@. +type ShNameSubst = NameEnv Name + +-- NB: In this module, we actually only ever construct 'ShNameSubst' +-- at a single 'ModuleName'. But 'ShNameSubst' is more convenient to +-- work with. + +-- | Substitute names in a 'Name'. +substName :: ShNameSubst -> Name -> Name +substName env n | Just n' <- lookupNameEnv env n = n' + | otherwise = n + +-- | Substitute names in an 'AvailInfo'. This has special behavior +-- for type constructors, where it is sufficient to substitute the 'availName' +-- to induce a substitution on 'availNames'. +substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo +substNameAvailInfo _ env (Avail gre) = + return $ Avail (substName env gre) +substNameAvailInfo hsc_env env (AvailTC n ns) = + let mb_mod = fmap nameModule (lookupNameEnv env n) + in AvailTC (substName env n) <$> mapM (setName hsc_env mb_mod) ns + +setName :: HscEnv -> Maybe Module -> Name -> IO Name +setName hsc_env mb_mod nm = initIfaceLoad hsc_env (setNameModule mb_mod nm) + +{- +************************************************************************ +* * + AvailInfo merging +* * +************************************************************************ +-} + +-- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have +-- already been unified ('uAvailInfos'). +mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo] +mergeAvails as1 as2 = + let mkNE as = mkNameEnv [(availName a, a) | a <- as] + in nonDetNameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2)) + +{- +************************************************************************ +* * + AvailInfo unification +* * +************************************************************************ +-} + +-- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@, +-- with only name holes from @flexi@ unifiable (all other name holes rigid.) +uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either HsigShapeMismatchReason ShNameSubst +uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $ + let mkOE as = mkOccEnv [(nameOccName n, a) | a <- as, n <- availNames a] + in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv + (nonDetOccEnvElts $ intersectOccEnv_C (,) (mkOE as1) (mkOE as2)) + -- Edward: I have to say, this is pretty clever. + +-- | Unify two 'AvailInfo's, given an existing substitution @subst@, +-- with only name holes from @flexi@ unifiable (all other name holes rigid.) +uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo + -> Either HsigShapeMismatchReason ShNameSubst +uAvailInfo flexi subst (Avail n1) (Avail n2) + = uName flexi subst n1 n2 +uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) + = uName flexi subst n1 n2 +uAvailInfo _ _ a1 a2 = Left $ HsigShapeSortMismatch a1 a2 + +-- | Unify two 'Name's, given an existing substitution @subst@, +-- with only name holes from @flexi@ unifiable (all other name holes rigid.) +uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either HsigShapeMismatchReason ShNameSubst +uName flexi subst n1 n2 + | n1 == n2 = Right subst + | isFlexi n1 = uHoleName flexi subst n1 n2 + | isFlexi n2 = uHoleName flexi subst n2 n1 + | otherwise = Left (HsigShapeNotUnifiable n1 n2 (isHoleName n1 || isHoleName n2)) + where + isFlexi n = isHoleName n && moduleName (nameModule n) == flexi + +-- | Unify a name @h@ which 'isHoleName' with another name, given an existing +-- substitution @subst@, with only name holes from @flexi@ unifiable (all +-- other name holes rigid.) +uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name + -> Either HsigShapeMismatchReason ShNameSubst +uHoleName flexi subst h n = + assert (isHoleName h) $ + case lookupNameEnv subst h of + Just n' -> uName flexi subst n' n + -- Do a quick check if the other name is substituted. + Nothing | Just n' <- lookupNameEnv subst n -> + assert (isHoleName n) $ uName flexi subst h n' + | otherwise -> + Right (extendNameEnv subst h n) diff --git a/GHC/Types/PkgQual.hs b/GHC/Types/PkgQual.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/PkgQual.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Types.PkgQual where + +import GHC.Prelude +import GHC.Types.SourceText +import GHC.Unit.Types +import GHC.Utils.Binary +import GHC.Utils.Outputable + +import Data.Data + +-- | Package-qualifier as it was parsed +data RawPkgQual + = NoRawPkgQual -- ^ No package qualifier + | RawPkgQual StringLiteral -- ^ Raw package qualifier string. + deriving (Data) + +-- | Package-qualifier after renaming +-- +-- Renaming detects if "this" or the unit-id of the home-unit was used as a +-- package qualifier. +data PkgQual + = NoPkgQual -- ^ No package qualifier + | ThisPkg !UnitId -- ^ Import from home-unit + | OtherPkg !UnitId -- ^ Import from another unit + deriving (Data, Ord, Eq) + +instance Outputable RawPkgQual where + ppr = \case + NoRawPkgQual -> empty + RawPkgQual (StringLiteral st p _) + -> pprWithSourceText st (doubleQuotes (ftext p)) + +instance Outputable PkgQual where + ppr = \case + NoPkgQual -> empty + ThisPkg u -> doubleQuotes (ppr u) + OtherPkg u -> doubleQuotes (ppr u) + +instance Binary PkgQual where + put_ bh NoPkgQual = putByte bh 0 + put_ bh (ThisPkg u) = do + putByte bh 1 + put_ bh u + put_ bh (OtherPkg u) = do + putByte bh 2 + put_ bh u + + get bh = do + tag <- getByte bh + case tag of + 0 -> return NoPkgQual + 1 -> do u <- get bh + return (ThisPkg u) + 2 -> do u <- get bh + return (OtherPkg u) + _ -> fail "instance Binary PkgQual: Invalid tag" diff --git a/GHC/Types/ProfAuto.hs b/GHC/Types/ProfAuto.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/ProfAuto.hs @@ -0,0 +1,15 @@ +module GHC.Types.ProfAuto + ( ProfAuto (..) + ) +where + +import GHC.Prelude + +-- | What kind of {-# SCC #-} to add automatically +data ProfAuto + = NoProfAuto -- ^ no SCC annotations added + | ProfAutoAll -- ^ top-level and nested functions are annotated + | ProfAutoTop -- ^ top-level functions annotated only + | ProfAutoExports -- ^ exported functions annotated only + | ProfAutoCalls -- ^ annotate call-sites + deriving (Eq,Enum, Show) diff --git a/GHC/Types/RepType.hs b/GHC/Types/RepType.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/RepType.hs @@ -0,0 +1,704 @@ + +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Types.RepType + ( + -- * Code generator views onto Types + UnaryType, NvUnaryType, isNvUnaryRep, + unwrapType, + + -- * Predicates on types + isZeroBitTy, + + -- * Type representation for the code generator + typePrimRep, typePrimRep1, typePrimRepU, + runtimeRepPrimRep, + PrimRep(..), primRepToRuntimeRep, primRepToType, + countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, + tyConPrimRep, + runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, + + -- * Unboxed sum representation type + ubxSumRepType, layoutUbxSum, repSlotTy, SlotTy (..), + slotPrimRep, primRepSlot, + + -- * Is this type known to be data? + mightBeFunTy + + ) where + +import GHC.Prelude + +import GHC.Types.Basic (Arity, RepArity) +import GHC.Core.DataCon +import GHC.Core.Coercion +import GHC.Core.TyCon +import GHC.Core.TyCon.RecWalk +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind + , vecRepDataConTyCon + , liftedRepTy, unliftedRepTy + , intRepDataConTy + , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy + , wordRepDataConTy + , word16RepDataConTy, word8RepDataConTy, word32RepDataConTy, word64RepDataConTy + , addrRepDataConTy + , floatRepDataConTy, doubleRepDataConTy + , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy + , vec64DataConTy + , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy + , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy + , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy + , doubleElemRepDataConTy ) + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List (sort) +import qualified Data.IntSet as IS + +{- ********************************************************************** +* * + Representation types +* * +********************************************************************** -} + +type NvUnaryType = Type +type UnaryType = Type + -- Both are always a value type; i.e. its kind is TYPE rr + -- for some rr; moreover the rr is never a variable. + -- + -- NvUnaryType : never an unboxed tuple or sum, or void + -- + -- UnaryType : never an unboxed tuple or sum; + -- can be Void# or (# #) + +isNvUnaryRep :: [PrimRep] -> Bool +isNvUnaryRep [_] = True +isNvUnaryRep _ = False + +-- | Gets rid of the stuff that prevents us from understanding the +-- runtime representation of a type. Including: +-- 1. Casts +-- 2. Newtypes +-- 3. Foralls +-- 4. Synonyms +-- But not type/data families, because we don't have the envs to hand. +unwrapType :: Type -> Type +unwrapType ty + | Just (_, unwrapped) + <- topNormaliseTypeX stepper mappend inner_ty + = unwrapped + | otherwise + = inner_ty + where + inner_ty = go ty + + go t | Just t' <- coreView t = go t' + go (ForAllTy _ t) = go t + go (CastTy t _) = go t + go t = t + + -- cf. Coercion.unwrapNewTypeStepper + stepper rec_nts tc tys + | Just (ty', _) <- instNewTyCon_maybe tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' (go ty') () + Nothing -> NS_Abort -- infinite newtypes + | otherwise + = NS_Done + +-- | Count the arity of a function post-unarisation, including zero-width arguments. +-- +-- The post-unarisation arity may be larger than the arity of the original +-- function type. See Note [Unarisation]. +countFunRepArgs :: Arity -> Type -> RepArity +countFunRepArgs 0 _ + = 0 +countFunRepArgs n ty + | FunTy _ _ arg res <- unwrapType ty + = (length (typePrimRep arg) `max` 1) + + countFunRepArgs (n - 1) res + -- If typePrimRep returns [] that means a void arg, + -- and we count 1 for that + | otherwise + = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) + +countConRepArgs :: DataCon -> RepArity +countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc) + where + go :: Arity -> Type -> RepArity + go 0 _ + = 0 + go n ty + | FunTy _ _ arg res <- unwrapType ty + = length (typePrimRep arg) + go (n - 1) res + | otherwise + = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) + +dataConRuntimeRepStrictness :: HasDebugCallStack => DataCon -> [StrictnessMark] +-- ^ Give the demands on the arguments of a +-- Core constructor application (Con dc args) at runtime. +-- Assumes the constructor is not levity polymorphic. For example +-- unboxed tuples won't work. +dataConRuntimeRepStrictness dc = + + -- pprTrace "dataConRuntimeRepStrictness" (ppr dc $$ ppr (dataConRepArgTys dc)) $ + + let repMarks = dataConRepStrictness dc + repTys = map irrelevantMult $ dataConRepArgTys dc + in -- todo: assert dc != unboxedTuple/unboxedSum + go repMarks repTys [] + where + go (mark:marks) (ty:types) out_marks + = case reps of + -- Zero-width argument, mark is irrelevant at runtime. + [] -> -- pprTrace "VoidTy" (ppr ty) $ + go marks types out_marks + -- Single rep argument, e.g. Int + -- Keep mark as-is + [_] -> go marks types (mark:out_marks) + -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #) + -- Make up one non-strict mark per runtime argument. + _ -> go marks types ((replicate (length reps) NotMarkedStrict)++out_marks) + where + reps = typePrimRep ty + go [] [] out_marks = reverse out_marks + go _m _t _o = pprPanic "dataConRuntimeRepStrictness2" (ppr dc $$ ppr _m $$ ppr _t $$ ppr _o) + +-- | True if the type has zero width. +isZeroBitTy :: HasDebugCallStack => Type -> Bool +isZeroBitTy = null . typePrimRep + + +{- ********************************************************************** +* * + Unboxed sums + See Note [Translating unboxed sums to unboxed tuples] in GHC.Stg.Unarise +* * +********************************************************************** -} + +type SortedSlotTys = [SlotTy] + +-- | Given the arguments of a sum type constructor application, +-- return the unboxed sum rep type. +-- +-- E.g. +-- +-- (# Int# | Maybe Int | (# Int#, Float# #) #) +-- +-- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`, +-- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot] +-- +-- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head +-- of the list we have the slot for the tag. +ubxSumRepType :: [[PrimRep]] -> NonEmpty SlotTy +ubxSumRepType constrs0 + -- These first two cases never classify an actual unboxed sum, which always + -- has at least two disjuncts. But it could happen if a user writes, e.g., + -- forall (a :: TYPE (SumRep [IntRep])). ... + -- which could never be instantiated. We still don't want to panic. + | constrs0 `lengthLessThan` 2 + = WordSlot :| [] + + | otherwise + = let + combine_alts :: [SortedSlotTys] -- slots of constructors + -> SortedSlotTys -- final slots + combine_alts constrs = foldl' merge [] constrs + + merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys + merge existing_slots [] + = existing_slots + merge [] needed_slots + = needed_slots + merge (es : ess) (s : ss) + | Just s' <- s `fitsIn` es + = -- found a slot, use it + s' : merge ess ss + | s < es + = -- we need a new slot and this is the right place for it + s : merge (es : ess) ss + | otherwise + = -- keep searching for a slot + es : merge ess (s : ss) + + -- Nesting unboxed tuples and sums is OK, so we need to flatten first. + rep :: [PrimRep] -> SortedSlotTys + rep ty = sort (map primRepSlot ty) + + sumRep = WordSlot :| combine_alts (map rep constrs0) + -- WordSlot: for the tag of the sum + in + sumRep + +layoutUbxSum :: HasDebugCallStack + => SortedSlotTys -- Layout of sum. Does not include tag. + -- We assume that they are in increasing order + -> [SlotTy] -- Slot types of things we want to map to locations in the + -- sum layout + -> [Int] -- Where to map 'things' in the sum layout +layoutUbxSum sum_slots0 arg_slots0 = + go arg_slots0 IS.empty + where + go :: [SlotTy] -> IS.IntSet -> [Int] + go [] _ + = [] + go (arg : args) used + = let slot_idx = findSlot arg 0 sum_slots0 used + in slot_idx : go args (IS.insert slot_idx used) + + findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int + findSlot arg slot_idx (slot : slots) useds + | not (IS.member slot_idx useds) + , Just slot == arg `fitsIn` slot + = slot_idx + | otherwise + = findSlot arg (slot_idx + 1) slots useds + findSlot _ _ [] _ + = pprPanic "findSlot" (text "Can't find slot" $$ text "sum_slots:" <> ppr sum_slots0 + $$ text "arg_slots:" <> ppr arg_slots0 ) + +-------------------------------------------------------------------------------- + +-- We have 3 kinds of slots: +-- +-- - Pointer slot: Only shared between actual pointers to Haskell heap (i.e. +-- boxed objects). These come in two variants: Lifted and unlifted (see +-- #19645). +-- +-- - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep. +-- +-- - Float slots: Shared between floating point types. +-- +-- - Void slots: Shared between void types. Not used in sums. +-- +-- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit +-- values, so that we can pack things more tightly. +data SlotTy = PtrLiftedSlot | PtrUnliftedSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot | VecSlot Int PrimElemRep + deriving (Eq, Ord) + -- Constructor order is important! If slot A could fit into slot B + -- then slot A must occur first. E.g. FloatSlot before DoubleSlot + -- + -- We are assuming that WordSlot is smaller than or equal to Word64Slot + -- (would not be true on a 128-bit machine) + +instance Outputable SlotTy where + ppr PtrLiftedSlot = text "PtrLiftedSlot" + ppr PtrUnliftedSlot = text "PtrUnliftedSlot" + ppr Word64Slot = text "Word64Slot" + ppr WordSlot = text "WordSlot" + ppr DoubleSlot = text "DoubleSlot" + ppr FloatSlot = text "FloatSlot" + ppr (VecSlot n e) = text "VecSlot" <+> ppr n <+> ppr e + +repSlotTy :: [PrimRep] -> Maybe SlotTy +repSlotTy reps = case reps of + [] -> Nothing + [rep] -> Just (primRepSlot rep) + _ -> pprPanic "repSlotTy" (ppr reps) + +primRepSlot :: PrimRep -> SlotTy +primRepSlot (BoxedRep mlev) = case mlev of + Nothing -> panic "primRepSlot: levity polymorphic BoxedRep" + Just Lifted -> PtrLiftedSlot + Just Unlifted -> PtrUnliftedSlot +primRepSlot IntRep = WordSlot +primRepSlot Int8Rep = WordSlot +primRepSlot Int16Rep = WordSlot +primRepSlot Int32Rep = WordSlot +primRepSlot Int64Rep = Word64Slot +primRepSlot WordRep = WordSlot +primRepSlot Word8Rep = WordSlot +primRepSlot Word16Rep = WordSlot +primRepSlot Word32Rep = WordSlot +primRepSlot Word64Rep = Word64Slot +primRepSlot AddrRep = WordSlot +primRepSlot FloatRep = FloatSlot +primRepSlot DoubleRep = DoubleSlot +primRepSlot (VecRep n e) = VecSlot n e + +slotPrimRep :: SlotTy -> PrimRep +slotPrimRep PtrLiftedSlot = BoxedRep (Just Lifted) +slotPrimRep PtrUnliftedSlot = BoxedRep (Just Unlifted) +slotPrimRep Word64Slot = Word64Rep +slotPrimRep WordSlot = WordRep +slotPrimRep DoubleSlot = DoubleRep +slotPrimRep FloatSlot = FloatRep +slotPrimRep (VecSlot n e) = VecRep n e + +-- | Returns the bigger type if one fits into the other. (commutative) +-- +-- Note that lifted and unlifted pointers are *not* in a fits-in relation for +-- the reasons described in Note [Don't merge lifted and unlifted slots] in +-- GHC.Stg.Unarise. +fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy +fitsIn ty1 ty2 + | ty1 == ty2 + = Just ty1 + | isWordSlot ty1 && isWordSlot ty2 + = Just (max ty1 ty2) + | otherwise + = Nothing + -- We used to share slots between Float/Double but currently we can't easily + -- covert between float/double in a way that is both work free and safe. + -- So we put them in different slots. + -- See Note [Casting slot arguments] + where + isWordSlot Word64Slot = True + isWordSlot WordSlot = True + isWordSlot _ = False + + + +{- ********************************************************************** +* * + PrimRep +* * +************************************************************************* + +Note [RuntimeRep and PrimRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes the relationship between GHC.Types.RuntimeRep +(of levity/representation polymorphism fame) and GHC.Core.TyCon.PrimRep, +as these types are closely related. + +A "primitive entity" is one that can be + * stored in one register + * manipulated with one machine instruction + + +Examples include: + * a 32-bit integer + * a 32-bit float + * a 64-bit float + * a machine address (heap pointer), etc. + * a quad-float (on a machine with SIMD register and instructions) + * ...etc... + +The "representation or a primitive entity" specifies what kind of register is +needed and how many bits are required. The data type GHC.Core.TyCon.PrimRep +enumerates all the possibilities. + +data PrimRep + = LiftedRep -- ^ Lifted pointer + | UnliftedRep -- ^ Unlifted pointer + | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value + ...etc... + | VecRep Int PrimElemRep -- ^ SIMD fixed-width vector + +The Haskell source language is a bit more flexible: a single value may need multiple PrimReps. +For example + + utup :: (# Int, Int #) -> Bool + utup x = ... + +Here x :: (# Int, Int #), and that takes two registers, and two instructions to move around. +Unboxed sums are similar. + +Every Haskell expression e has a type ty, whose kind is of form TYPE rep + e :: ty :: TYPE rep +where rep :: RuntimeRep. Here rep describes the runtime representation for e's value, +but RuntimeRep has some extra cases: + +data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type + | TupleRep [RuntimeRep] -- ^ An unboxed tuple of the given reps + | SumRep [RuntimeRep] -- ^ An unboxed sum of the given reps + | BoxedRep Levity -- ^ boxed; represented by a pointer + | IntRep -- ^ signed, word-sized value + ...etc... +data Levity = Lifted + | Unlifted + +It's all in 1-1 correspondence with PrimRep except for TupleRep and SumRep, +which describe unboxed products and sums respectively. RuntimeRep is defined +in the library ghc-prim:GHC.Types. It is also "wired-in" to GHC: see +GHC.Builtin.Types.runtimeRepTyCon. The unarisation pass, in GHC.Stg.Unarise, transforms the +program, so that every variable has a type that has a PrimRep. For +example, unarisation transforms our utup function above, to take two Int +arguments instead of one (# Int, Int #) argument. + +Also, note that boxed types are represented slightly differently in RuntimeRep +and PrimRep. PrimRep just has the nullary LiftedRep and UnliftedRep data +constructors. RuntimeRep has a BoxedRep data constructor, which accepts a +Levity. The subtle distinction is that since BoxedRep can accept a variable +argument, RuntimeRep can talk about levity polymorphic types. PrimRep, by +contrast, cannot. + +See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]. + +Note [VoidRep] +~~~~~~~~~~~~~~ +PrimRep is used to denote one primitive representation. +Because of unboxed tuples and sums, the representation of a value +in general is a list of PrimReps. (See also Note [RuntimeRep and PrimRep].) + +For example: + typePrimRep Int# = [IntRep] + typePrimRep Int = [LiftedRep] + typePrimRep (# Int#, Int# #) = [IntRep,IntRep] + typePrimRep (# #) = [] + typePrimRep (State# s) = [] + +After the unariser, all identifiers have at most one PrimRep +(that is, the [PrimRep] for each identifier is empty or a singleton list). +More precisely: typePrimRep1 will succeed (not crash) on every binder +and argument type. +(See Note [Post-unarisation invariants] in GHC.Stg.Unarise.) + +Thus, we have + +1. typePrimRep :: Type -> [PrimRep] + which returns the list + +2. typePrimRepU :: Type -> PrimRep + which asserts that the type has exactly one PrimRep and returns it + +3. typePrimRep1 :: Type -> PrimOrVoidRep + data PrimOrVoidRep = VoidRep | NVRep PrimRep + which asserts that the type either has exactly one PrimRep or is void. + +Likewise, we have idPrimRepU and idPrimRep1, stgArgRepU and stgArgRep1, +which have analogous preconditions. + +Note [Getting from RuntimeRep to PrimRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +General info on RuntimeRep and PrimRep is in Note [RuntimeRep and PrimRep]. + +How do we get from an Id to the list or PrimReps used to store it? We get +the Id's type ty (using idType), then ty's kind ki (using typeKind), then +pattern-match on ki to extract rep (in kindPrimRep), then extract the PrimRep +from the RuntimeRep (in runtimeRepPrimRep). + +We now must convert the RuntimeRep to a list of PrimReps. Let's look at two +examples: + + 1. x :: Int# + 2. y :: (# Int, Word# #) + +With these types, we can extract these kinds: + + 1. Int# :: TYPE IntRep + 2. (# Int, Word# #) :: TYPE (TupleRep [LiftedRep, WordRep]) + +In the end, we will get these PrimReps: + + 1. [IntRep] + 2. [LiftedRep, WordRep] + +It would thus seem that we should have a function somewhere of +type `RuntimeRep -> [PrimRep]`. This doesn't work though: when we +look at the argument of TYPE, we get something of type Type (of course). +RuntimeRep exists in the user's program, but not in GHC as such. +Instead, we must decompose the Type of kind RuntimeRep into tycons and +extract the PrimReps from the TyCons. This is what runtimeRepPrimRep does: +it takes a Type and returns a [PrimRep] + +runtimeRepPrimRep works by using tyConRuntimeRepInfo. That function +should be passed the TyCon produced by promoting one of the constructors +of RuntimeRep into type-level data. The RuntimeRep promoted datacons are +associated with a RuntimeRepInfo (stored directly in the PromotedDataCon +constructor of TyCon, field promDcRepInfo). +This pairing happens in GHC.Builtin.Types. A RuntimeRepInfo +usually(*) contains a function from [Type] to [PrimRep]: the [Type] are +the arguments to the promoted datacon. These arguments are necessary +for the TupleRep and SumRep constructors, so that this process can recur, +producing a flattened list of PrimReps. Calling this extracted function +happens in runtimeRepPrimRep; the functions themselves are defined in +tupleRepDataCon and sumRepDataCon, both in GHC.Builtin.Types. + +The (*) above is to support vector representations. RuntimeRep refers +to VecCount and VecElem, whose promoted datacons have nuggets of information +related to vectors; these form the other alternatives for RuntimeRepInfo. + +Returning to our examples, the Types we get (after stripping off TYPE) are + + 1. TyConApp (PromotedDataCon "IntRep") [] + 2. TyConApp (PromotedDataCon "TupleRep") + [TyConApp (PromotedDataCon ":") + [ TyConApp (AlgTyCon "RuntimeRep") [] + , TyConApp (PromotedDataCon "LiftedRep") [] + , TyConApp (PromotedDataCon ":") + [ TyConApp (AlgTyCon "RuntimeRep") [] + , TyConApp (PromotedDataCon "WordRep") [] + , TyConApp (PromotedDataCon "'[]") + [TyConApp (AlgTyCon "RuntimeRep") []]]]] + +runtimeRepPrimRep calls tyConRuntimeRepInfo on (PromotedDataCon "IntRep"), resp. +(PromotedDataCon "TupleRep"), extracting a function that will produce the PrimReps. +In example 1, this function is passed an empty list (the empty list of args to IntRep) +and returns the PrimRep IntRep. (See the definition of runtimeRepSimpleDataCons in +GHC.Builtin.Types and its helper function mk_runtime_rep_dc.) Example 2 passes the promoted +list as the one argument to the extracted function. The extracted function is defined +as prim_rep_fun within tupleRepDataCon in GHC.Builtin.Types. It takes one argument, decomposes +the promoted list (with extractPromotedList), and then recurses back to runtimeRepPrimRep +to process the LiftedRep and WordRep, concatenating the results. + +-} + +-- | Discovers the primitive representation of a 'Type'. Returns +-- a list of 'PrimRep': it's a list because of the possibility of +-- no runtime representation (void) or multiple (unboxed tuple/sum) +-- See also Note [Getting from RuntimeRep to PrimRep] +typePrimRep :: HasDebugCallStack => Type -> [PrimRep] +typePrimRep ty = kindPrimRep (text "typePrimRep" <+> + parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) + (typeKind ty) + +-- | Discovers the primitive representation of a 'Type'. Returns +-- a list of 'PrimRep': it's a list because of the possibility of +-- no runtime representation (void) or multiple (unboxed tuple/sum) +-- See also Note [Getting from RuntimeRep to PrimRep] +-- Returns Nothing if rep can't be determined. Eg. levity polymorphic types. +typePrimRep_maybe :: Type -> Maybe [PrimRep] +typePrimRep_maybe ty = kindPrimRep_maybe (typeKind ty) + +-- | Like 'typePrimRep', but assumes that there is at most one 'PrimRep' output; +-- an empty list of PrimReps becomes a VoidRep. +-- This assumption holds after unarise, see Note [Post-unarisation invariants]. +-- Before unarise it may or may not hold. +-- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] +typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimOrVoidRep +typePrimRep1 ty = case typePrimRep ty of + [] -> VoidRep + [rep] -> NVRep rep + _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) + +typePrimRepU :: HasDebugCallStack => NvUnaryType -> PrimRep +typePrimRepU ty = case typePrimRep ty of + [rep] -> rep + _ -> pprPanic "typePrimRepU" (ppr ty $$ ppr (typePrimRep ty)) + +-- | Find the runtime representation of a 'TyCon'. Defined here to +-- avoid module loops. Returns a list of the register shapes necessary. +-- See also Note [Getting from RuntimeRep to PrimRep] +tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep] +tyConPrimRep tc + = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) + res_kind + where + res_kind = tyConResKind tc + +-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's +-- of values of types of this kind. +-- See also Note [Getting from RuntimeRep to PrimRep] +kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] +kindPrimRep doc ki + | Just runtime_rep <- kindRep_maybe ki + = runtimeRepPrimRep doc runtime_rep +kindPrimRep doc ki + = pprPanic "kindPrimRep" (ppr ki $$ doc) + +-- NB: We could implement the partial methods by calling into the maybe +-- variants here. But then both would need to pass around the doc argument. + +-- | Take a kind (of shape `TYPE rr` or `CONSTRAINT rr`) and produce the 'PrimRep's +-- of values of types of this kind. +-- See also Note [Getting from RuntimeRep to PrimRep] +-- Returns Nothing if rep can't be determined. Eg. levity polymorphic types. +kindPrimRep_maybe :: HasDebugCallStack => Kind -> Maybe [PrimRep] +kindPrimRep_maybe ki + | Just (_torc, rep) <- sORTKind_maybe ki + = runtimeRepPrimRep_maybe rep + | otherwise + = pprPanic "kindPrimRep" (ppr ki) + +-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that +-- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. +-- The @[PrimRep]@ is the final runtime representation /after/ unarisation. +runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] +runtimeRepPrimRep doc rr_ty + | Just rr_ty' <- coreView rr_ty + = runtimeRepPrimRep doc rr_ty' + | TyConApp rr_dc args <- rr_ty + , RuntimeRep fun <- tyConPromDataConInfo rr_dc + = fun args + | otherwise + = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) + +-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that +-- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. +-- The @[PrimRep]@ is the final runtime representation /after/ unarisation. +-- +-- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types. +runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep] +runtimeRepPrimRep_maybe rr_ty + | Just rr_ty' <- coreView rr_ty + = runtimeRepPrimRep_maybe rr_ty' + | TyConApp rr_dc args <- rr_ty + , RuntimeRep fun <- tyConPromDataConInfo rr_dc + = Just $! fun args + | otherwise + = Nothing + +-- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep +primRepToRuntimeRep :: PrimRep -> RuntimeRepType +primRepToRuntimeRep rep = case rep of + BoxedRep mlev -> case mlev of + Nothing -> panic "primRepToRuntimeRep: levity polymorphic BoxedRep" + Just Lifted -> liftedRepTy + Just Unlifted -> unliftedRepTy + IntRep -> intRepDataConTy + Int8Rep -> int8RepDataConTy + Int16Rep -> int16RepDataConTy + Int32Rep -> int32RepDataConTy + Int64Rep -> int64RepDataConTy + WordRep -> wordRepDataConTy + Word8Rep -> word8RepDataConTy + Word16Rep -> word16RepDataConTy + Word32Rep -> word32RepDataConTy + Word64Rep -> word64RepDataConTy + AddrRep -> addrRepDataConTy + FloatRep -> floatRepDataConTy + DoubleRep -> doubleRepDataConTy + VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem'] + where + n' = case n of + 2 -> vec2DataConTy + 4 -> vec4DataConTy + 8 -> vec8DataConTy + 16 -> vec16DataConTy + 32 -> vec32DataConTy + 64 -> vec64DataConTy + _ -> pprPanic "Disallowed VecCount" (ppr n) + + elem' = case elem of + Int8ElemRep -> int8ElemRepDataConTy + Int16ElemRep -> int16ElemRepDataConTy + Int32ElemRep -> int32ElemRepDataConTy + Int64ElemRep -> int64ElemRepDataConTy + Word8ElemRep -> word8ElemRepDataConTy + Word16ElemRep -> word16ElemRepDataConTy + Word32ElemRep -> word32ElemRepDataConTy + Word64ElemRep -> word64ElemRepDataConTy + FloatElemRep -> floatElemRepDataConTy + DoubleElemRep -> doubleElemRepDataConTy + +-- | Convert a PrimRep back to a Type. Used only in the unariser to give types +-- to fresh Ids. Really, only the type's representation matters. +-- See also Note [RuntimeRep and PrimRep] +primRepToType :: PrimRep -> Type +primRepToType = anyTypeOfKind . mkTYPEapp . primRepToRuntimeRep + +-------------- +mightBeFunTy :: Type -> Bool +-- Return False only if we are *sure* it's a data type +-- Look through newtypes etc as much as possible. Used to +-- decide if we need to enter a closure via a slow call. +-- +-- AK: It would be nice to figure out and document the difference +-- between this and isFunTy at some point. +mightBeFunTy ty + -- Currently ghc has no unlifted functions. + | definitelyUnliftedType ty + = False + | [BoxedRep _] <- typePrimRep ty + , Just tc <- tyConAppTyCon_maybe (unwrapType ty) + , isBoxedDataTyCon tc + = False + | otherwise + = True diff --git a/GHC/Types/SafeHaskell.hs b/GHC/Types/SafeHaskell.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/SafeHaskell.hs @@ -0,0 +1,100 @@ +-- | This stuff here is related to supporting the Safe Haskell extension, +-- primarily about storing under what trust type a module has been compiled. +module GHC.Types.SafeHaskell + ( IsSafeImport + , SafeHaskellMode(..) + , IfaceTrustInfo + , getSafeMode + , setSafeMode + , noIfaceTrustInfo + ) +where + +import GHC.Prelude + +import GHC.Utils.Binary +import GHC.Utils.Outputable +import Control.DeepSeq + +import Data.Word + + +-- | Is an import a safe import? +type IsSafeImport = Bool + +-- | The various Safe Haskell modes +data SafeHaskellMode + = Sf_None -- ^ inferred unsafe + | Sf_Unsafe -- ^ declared and checked + | Sf_Trustworthy -- ^ declared and checked + | Sf_Safe -- ^ declared and checked + | Sf_SafeInferred -- ^ inferred as safe + | Sf_Ignore -- ^ @-fno-safe-haskell@ state + deriving (Eq) + +instance NFData SafeHaskellMode where + rnf x = case x of + Sf_None -> () + Sf_Unsafe -> () + Sf_Trustworthy -> () + Sf_Safe -> () + Sf_SafeInferred -> () + Sf_Ignore -> () + +instance Show SafeHaskellMode where + show Sf_None = "None" + show Sf_Unsafe = "Unsafe" + show Sf_Trustworthy = "Trustworthy" + show Sf_Safe = "Safe" + show Sf_SafeInferred = "Safe-Inferred" + show Sf_Ignore = "Ignore" + +instance Outputable SafeHaskellMode where + ppr = text . show + +-- | Safe Haskell information for 'ModIface' +-- Simply a wrapper around SafeHaskellMode to separate iface and flags +newtype IfaceTrustInfo = TrustInfo SafeHaskellMode + +instance NFData IfaceTrustInfo where + rnf (TrustInfo shm) = rnf shm + + +getSafeMode :: IfaceTrustInfo -> SafeHaskellMode +getSafeMode (TrustInfo x) = x + +setSafeMode :: SafeHaskellMode -> IfaceTrustInfo +setSafeMode = TrustInfo + +noIfaceTrustInfo :: IfaceTrustInfo +noIfaceTrustInfo = setSafeMode Sf_None + +trustInfoToNum :: IfaceTrustInfo -> Word8 +trustInfoToNum it + = case getSafeMode it of + Sf_None -> 0 + Sf_Unsafe -> 1 + Sf_Trustworthy -> 2 + Sf_Safe -> 3 + Sf_SafeInferred -> 4 + Sf_Ignore -> 0 + +numToTrustInfo :: Word8 -> IfaceTrustInfo +numToTrustInfo 0 = setSafeMode Sf_None +numToTrustInfo 1 = setSafeMode Sf_Unsafe +numToTrustInfo 2 = setSafeMode Sf_Trustworthy +numToTrustInfo 3 = setSafeMode Sf_Safe +numToTrustInfo 4 = setSafeMode Sf_SafeInferred +numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" + +instance Outputable IfaceTrustInfo where + ppr (TrustInfo Sf_None) = text "none" + ppr (TrustInfo Sf_Ignore) = text "none" + ppr (TrustInfo Sf_Unsafe) = text "unsafe" + ppr (TrustInfo Sf_Trustworthy) = text "trustworthy" + ppr (TrustInfo Sf_Safe) = text "safe" + ppr (TrustInfo Sf_SafeInferred) = text "safe-inferred" + +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) diff --git a/GHC/Types/SaneDouble.hs b/GHC/Types/SaneDouble.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/SaneDouble.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +-- | Double datatype with saner instances +module GHC.Types.SaneDouble + ( SaneDouble (..) + ) +where + +import GHC.Prelude +import GHC.Utils.Binary +import GHC.Float (castDoubleToWord64, castWord64ToDouble) + +-- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' +-- that becomes a 'NaN', see instances for details on sanity. +newtype SaneDouble = SaneDouble + { unSaneDouble :: Double + } + deriving (Fractional, Num) + +instance Eq SaneDouble where + (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y) + +instance Ord SaneDouble where + compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y) + where fromNaN z | isNaN z = Nothing + | otherwise = Just z + +instance Show SaneDouble where + show (SaneDouble x) = show x + +-- we need to preserve NaN and infinities, unfortunately the Binary instance for +-- Double does not do this +instance Binary SaneDouble where + put_ bh (SaneDouble d) + | isNaN d = putByte bh 1 + | isInfinite d && d > 0 = putByte bh 2 + | isInfinite d && d < 0 = putByte bh 3 + | isNegativeZero d = putByte bh 4 + | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d) + get bh = getByte bh >>= \case + 1 -> pure $ SaneDouble (0 / 0) + 2 -> pure $ SaneDouble (1 / 0) + 3 -> pure $ SaneDouble ((-1) / 0) + 4 -> pure $ SaneDouble (-0) + 5 -> SaneDouble . castWord64ToDouble <$> get bh + n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n) + diff --git a/GHC/Types/SourceError.hs b/GHC/Types/SourceError.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/SourceError.hs @@ -0,0 +1,76 @@ +-- | Source errors +module GHC.Types.SourceError + ( SourceError (..) + , mkSrcErr + , srcErrorMessages + , throwErrors + , throwOneError + , handleSourceError + ) +where + +import GHC.Prelude +import GHC.Types.Error +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Exception +import GHC.Utils.Error (pprMsgEnvelopeBagWithLocDefault) +import GHC.Utils.Outputable + +import GHC.Driver.Errors.Ppr () -- instance Diagnostic GhcMessage +import GHC.Driver.Errors.Types + +import Control.Monad.Catch as MC (MonadCatch, catch) + +mkSrcErr :: Messages GhcMessage -> SourceError +mkSrcErr = SourceError + +srcErrorMessages :: SourceError -> Messages GhcMessage +srcErrorMessages (SourceError msgs) = msgs + +throwErrors :: MonadIO io => Messages GhcMessage -> io a +throwErrors = liftIO . throwIO . mkSrcErr + +throwOneError :: MonadIO io => MsgEnvelope GhcMessage -> io a +throwOneError = throwErrors . singleMessage + +-- | A source error is an error that is caused by one or more errors in the +-- source code. A 'SourceError' is thrown by many functions in the +-- compilation pipeline. Inside GHC these errors are merely printed via +-- 'log_action', but API clients may treat them differently, for example, +-- insert them into a list box. If you want the default behaviour, use the +-- idiom: +-- +-- > handleSourceError printExceptionAndWarnings $ do +-- > ... api calls that may fail ... +-- +-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'. +-- This list may be empty if the compiler failed due to @-Werror@ +-- ('Opt_WarnIsError'). +-- +-- See 'printExceptionAndWarnings' for more information on what to take care +-- of when writing a custom error handler. +newtype SourceError = SourceError (Messages GhcMessage) + +instance Show SourceError where + -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics + -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions. + -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'. + show (SourceError msgs) = + renderWithContext defaultSDocContext + . vcat + . pprMsgEnvelopeBagWithLocDefault + . getMessages + $ msgs + +instance Exception SourceError + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleSourceError :: (MonadCatch m) => + (SourceError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleSourceError handler act = + MC.catch act (\(e :: SourceError) -> handler e) + diff --git a/GHC/Types/SourceFile.hs b/GHC/Types/SourceFile.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/SourceFile.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE PatternSynonyms #-} + +module GHC.Types.SourceFile + ( HscSource(HsBootFile, HsigFile, ..) + , HsBootOrSig(..) + , hscSourceToIsBoot + , isHsBootOrSig + , isHsBootFile, isHsigFile + , hscSourceString + ) +where + +import GHC.Prelude +import GHC.Utils.Binary +import GHC.Unit.Types +import Control.DeepSeq + +{- Note [HscSource types] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There are three types of source file for Haskell code: + + * HsSrcFile is an ordinary hs file which contains code, + + * HsBootFile is an hs-boot file, which is used to break + recursive module imports (there will always be an + HsSrcFile associated with it), and + + * HsigFile is an hsig file, which contains only type + signatures and is used to specify signatures for + modules. + +Syntactically, hs-boot files and hsig files are quite similar: they +only include type signatures and must be associated with an +actual HsSrcFile. isHsBootOrSig allows us to abstract over code +which is indifferent to which. However, there are some important +differences, mostly owing to the fact that hsigs are proper +modules (you `import Sig` directly) whereas HsBootFiles are +temporary placeholders (you `import {-# SOURCE #-} Mod). +When we finish compiling the true implementation of an hs-boot, +we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the +other hand, is never replaced (in particular, we *cannot* use the +HomeModInfo of the original HsSrcFile backing the signature, since it +will export too many symbols.) + +Additionally, while HsSrcFile is the only Haskell file +which has *code*, we do generate .o files for HsigFile, because +this is how the recompilation checker figures out if a file +needs to be recompiled. These are fake object files which +should NOT be linked against. +-} + +data HsBootOrSig + = HsBoot -- ^ .hs-boot file + | Hsig -- ^ .hsig file + deriving (Eq, Ord, Show) + +instance NFData HsBootOrSig where + rnf HsBoot = () + rnf Hsig = () + +data HscSource + -- | .hs file + = HsSrcFile + -- | .hs-boot or .hsig file + | HsBootOrSig !HsBootOrSig + deriving (Eq, Ord, Show) + +{-# COMPLETE HsSrcFile, HsBootFile, HsigFile #-} +pattern HsBootFile, HsigFile :: HscSource +pattern HsBootFile = HsBootOrSig HsBoot +pattern HsigFile = HsBootOrSig Hsig + +-- | Tests if an 'HscSource' is a boot file, primarily for constructing elements +-- of 'BuildModule'. We conflate signatures and modules because they are bound +-- in the same namespace; only boot interfaces can be disambiguated with +-- `import {-# SOURCE #-}`. +hscSourceToIsBoot :: HscSource -> IsBootInterface +hscSourceToIsBoot HsBootFile = IsBoot +hscSourceToIsBoot _ = NotBoot + +instance NFData HscSource where + rnf HsSrcFile = () + rnf (HsBootOrSig h) = rnf h + +instance Binary HscSource where + put_ bh HsSrcFile = putByte bh 0 + put_ bh HsBootFile = putByte bh 1 + put_ bh HsigFile = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return HsSrcFile + 1 -> return HsBootFile + _ -> return HsigFile + +hscSourceString :: HscSource -> String +hscSourceString HsSrcFile = "" +hscSourceString HsBootFile = "[boot]" +hscSourceString HsigFile = "[sig]" + +-- See Note [HscSource types] +isHsBootOrSig :: HscSource -> Bool +isHsBootOrSig (HsBootOrSig _) = True +isHsBootOrSig HsSrcFile = False + +isHsBootFile :: HscSource -> Bool +isHsBootFile HsBootFile = True +isHsBootFile _ = False + +isHsigFile :: HscSource -> Bool +isHsigFile HsigFile = True +isHsigFile _ = False diff --git a/GHC/Types/SourceText.hs b/GHC/Types/SourceText.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/SourceText.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Source text +-- +-- Keeping Source Text for source to source conversions +-- +module GHC.Types.SourceText + ( SourceText (..) + , pprWithSourceText + + -- * Literals + , IntegralLit(..) + , FractionalLit(..) + , StringLiteral(..) + , negateIntegralLit + , negateFractionalLit + , mkIntegralLit + , mkTHFractionalLit, rationalFromFractionalLit + , integralFractionalLit, mkSourceFractionalLit + , FractionalExponentBase(..) + + -- Used by the pm checker. + , fractionalLitFromRational + , mkFractionalLit + + ) +where + +import GHC.Prelude + +import GHC.Data.FastString + +import GHC.Utils.Outputable +import GHC.Utils.Binary +import GHC.Utils.Panic + +import Data.Function (on) +import Data.Data +import GHC.Real ( Ratio(..) ) +import GHC.Types.SrcLoc +import Control.DeepSeq + +{- +Note [Pragma source text] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer does a case-insensitive match for pragmas, as well as +accepting both UK and US spelling variants. + +So + + {-# SPECIALISE #-} + {-# SPECIALIZE #-} + {-# Specialize #-} + +will all generate ITspec_prag token for the start of the pragma. + +In order to be able to do source to source conversions, the original +source text for the token needs to be preserved, hence the +`SourceText` field. + +So the lexer will then generate + + ITspec_prag "{ -# SPECIALISE" + ITspec_prag "{ -# SPECIALIZE" + ITspec_prag "{ -# Specialize" + +for the cases above. + [without the space between '{' and '-', otherwise this comment won't parse] + + +Note [Literal source text] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer/parser converts literals from their original source text +versions to an appropriate internal representation. This is a problem +for tools doing source to source conversions, so the original source +text is stored in literals where this can occur. + +Motivating examples for HsLit + + HsChar '\n' == '\x20' + HsCharPrim '\x41'# == 'A'# + HsString "\x20\x41" == " A" + HsStringPrim "\x20"# == " "# + HsInt 001 == 1 + HsIntPrim 002# == 2# + HsWordPrim 003## == 3## + HsInt64Prim 004#Int64 == 4#Int64 + HsWord64Prim 005#Word64 == 5#Word64 + HsInteger 006 == 6 + +For OverLitVal + + HsIntegral 003 == 0x003 + HsIsString "\x41nd" == "And" +-} + + -- Note [Literal source text],[Pragma source text] +data SourceText + = SourceText FastString + | NoSourceText + -- ^ For when code is generated, e.g. TH, + -- deriving. The pretty printer will then make + -- its own representation of the item. + deriving (Data, Show, Eq ) + +instance Outputable SourceText where + ppr (SourceText s) = text "SourceText" <+> ftext s + ppr NoSourceText = text "NoSourceText" + +instance NFData SourceText where + rnf = \case + SourceText s -> rnf s + NoSourceText -> () + +instance Binary SourceText where + put_ bh NoSourceText = putByte bh 0 + put_ bh (SourceText s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return NoSourceText + 1 -> do + s <- get bh + return (SourceText s) + _ -> panic $ "Binary SourceText:" ++ show h + +-- | Special combinator for showing string literals. +pprWithSourceText :: SourceText -> SDoc -> SDoc +pprWithSourceText NoSourceText d = d +pprWithSourceText (SourceText src) _ = ftext src + +------------------------------------------------ +-- Literals +------------------------------------------------ + +-- | Integral Literal +-- +-- Used (instead of Integer) to represent negative zegative zero which is +-- required for NegativeLiterals extension to correctly parse `-0::Double` +-- as negative zero. See also #13211. +data IntegralLit = IL + { il_text :: SourceText + , il_neg :: Bool -- See Note [Negative zero] in GHC.Rename.Pat + , il_value :: Integer + } + deriving (Data, Show) + +mkIntegralLit :: Integral a => a -> IntegralLit +mkIntegralLit i = IL { il_text = SourceText (fsLit $ show i_integer) + , il_neg = i < 0 + , il_value = i_integer } + where + i_integer :: Integer + i_integer = toInteger i + +negateIntegralLit :: IntegralLit -> IntegralLit +negateIntegralLit (IL text neg value) + = case text of + SourceText (unconsFS -> Just ('-',src)) -> IL (SourceText src) False (negate value) + SourceText src -> IL (SourceText ('-' `consFS` src)) True (negate value) + NoSourceText -> IL NoSourceText (not neg) (negate value) + +-- | Fractional Literal +-- +-- Used (instead of Rational) to represent exactly the floating point literal that we +-- encountered in the user's source program. This allows us to pretty-print exactly what +-- the user wrote, which is important e.g. for floating point numbers that can't represented +-- as Doubles (we used to via Double for pretty-printing). See also #2245. +-- Note [FractionalLit representation] in GHC.HsToCore.Match.Literal +-- The actual value then is: sign * fl_signi * (fl_exp_base^fl_exp) +-- where sign = if fl_neg then (-1) else 1 +-- +-- For example FL { fl_neg = True, fl_signi = 5.3, fl_exp = 4, fl_exp_base = Base10 } +-- denotes -5300 + +data FractionalLit = FL + { fl_text :: SourceText -- ^ How the value was written in the source + , fl_neg :: Bool -- See Note [Negative zero] + , fl_signi :: Rational -- The significand component of the literal + , fl_exp :: Integer -- The exponent component of the literal + , fl_exp_base :: FractionalExponentBase -- See Note [fractional exponent bases] + } + deriving (Data, Show) + -- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on + +-- See Note [FractionalLit representation] in GHC.HsToCore.Match.Literal +data FractionalExponentBase + = Base2 -- Used in hex fractional literals + | Base10 + deriving (Eq, Ord, Data, Show) + +mkFractionalLit :: SourceText -> Bool -> Rational -> Integer -> FractionalExponentBase + -> FractionalLit +mkFractionalLit = FL + +mkRationalWithExponentBase :: Rational -> Integer -> FractionalExponentBase -> Rational +mkRationalWithExponentBase i e feb = i * (eb ^^ e) + where eb = case feb of Base2 -> 2 ; Base10 -> 10 + +fractionalLitFromRational :: Rational -> FractionalLit +fractionalLitFromRational r = FL { fl_text = NoSourceText + , fl_neg = r < 0 + , fl_signi = r + , fl_exp = 0 + , fl_exp_base = Base10 } + +rationalFromFractionalLit :: FractionalLit -> Rational +rationalFromFractionalLit (FL _ _ i e expBase) = + mkRationalWithExponentBase i e expBase + +mkTHFractionalLit :: Rational -> FractionalLit +mkTHFractionalLit r = FL { fl_text = SourceText (fsLit $ show (realToFrac r::Double)) + -- Converting to a Double here may technically lose + -- precision (see #15502). We could alternatively + -- convert to a Rational for the most accuracy, but + -- it would cause Floats and Doubles to be displayed + -- strangely, so we opt not to do this. (In contrast + -- to mkIntegralLit, where we always convert to an + -- Integer for the highest accuracy.) + , fl_neg = r < 0 + , fl_signi = r + , fl_exp = 0 + , fl_exp_base = Base10 } + +negateFractionalLit :: FractionalLit -> FractionalLit +negateFractionalLit (FL text neg i e eb) + = case text of + SourceText (unconsFS -> Just ('-',src)) + -> FL (SourceText src) False (negate i) e eb + SourceText src -> FL (SourceText ('-' `consFS` src)) True (negate i) e eb + NoSourceText -> FL NoSourceText (not neg) (negate i) e eb + +-- | The integer should already be negated if it's negative. +integralFractionalLit :: Bool -> Integer -> FractionalLit +integralFractionalLit neg i = FL { fl_text = SourceText (fsLit $ show i) + , fl_neg = neg + , fl_signi = i :% 1 + , fl_exp = 0 + , fl_exp_base = Base10 } + +-- | The arguments should already be negated if they are negative. +mkSourceFractionalLit :: String -> Bool -> Integer -> Integer + -> FractionalExponentBase + -> FractionalLit +mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText $ fsLit str) b (r :% 1) i ff + +{- Note [fractional exponent bases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For hexadecimal rationals of +the form 0x0.3p10 the exponent is given on base 2 rather than +base 10. These are the only options, hence the sum type. See also #15646. +-} + + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) + +instance Eq IntegralLit where + (==) = (==) `on` il_value + +instance Ord IntegralLit where + compare = compare `on` il_value + +instance Outputable IntegralLit where + ppr (IL (SourceText src) _ _) = ftext src + ppr (IL NoSourceText _ value) = text (show value) + + +-- | Compare fractional lits with small exponents for value equality but +-- large values for syntactic equality. +compareFractionalLit :: FractionalLit -> FractionalLit -> Ordering +compareFractionalLit fl1 fl2 + | fl_exp fl1 < 100 && fl_exp fl2 < 100 && fl_exp fl1 >= -100 && fl_exp fl2 >= -100 + = rationalFromFractionalLit fl1 `compare` rationalFromFractionalLit fl2 + | otherwise = (compare `on` (\x -> (fl_signi x, fl_exp x, fl_exp_base x))) fl1 fl2 + +-- | Be wary of using this instance to compare for equal *values* when exponents are +-- large. The same value expressed in different syntactic form won't compare as equal when +-- any of the exponents is >= 100. +instance Eq FractionalLit where + (==) fl1 fl2 = case compare fl1 fl2 of + EQ -> True + _ -> False + +-- | Be wary of using this instance to compare for equal *values* when exponents are +-- large. The same value expressed in different syntactic form won't compare as equal when +-- any of the exponents is >= 100. +instance Ord FractionalLit where + compare = compareFractionalLit + +instance Outputable FractionalLit where + ppr (fl@(FL {})) = + pprWithSourceText (fl_text fl) $ + rational $ mkRationalWithExponentBase (fl_signi fl) (fl_exp fl) (fl_exp_base fl) + +-- | A String Literal in the source, including its original raw format for use by +-- source to source manipulation tools. +data StringLiteral = StringLiteral + { sl_st :: SourceText, -- literal raw source. + -- See Note [Literal source text] + sl_fs :: FastString, -- literal string value + sl_tc :: Maybe NoCommentsLocation + -- Location of + -- possible + -- trailing comma + -- AZ: if we could have a LocatedA + -- StringLiteral we would not need sl_tc, but + -- that would cause import loops. + } deriving Data + +instance Eq StringLiteral where + (StringLiteral _ a _) == (StringLiteral _ b _) = a == b + +instance Outputable StringLiteral where + ppr sl = pprWithSourceText (sl_st sl) (doubleQuotes $ ftext $ sl_fs sl) diff --git a/GHC/Types/SptEntry.hs b/GHC/Types/SptEntry.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/SptEntry.hs @@ -0,0 +1,16 @@ +module GHC.Types.SptEntry + ( SptEntry(..) + ) +where + +import GHC.Types.Var ( Id ) +import GHC.Fingerprint.Type ( Fingerprint ) +import GHC.Utils.Outputable + +-- | An entry to be inserted into a module's static pointer table. +-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". +data SptEntry = SptEntry Id Fingerprint + +instance Outputable SptEntry where + ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr + diff --git a/GHC/Types/SrcLoc.hs b/GHC/Types/SrcLoc.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/SrcLoc.hs @@ -0,0 +1,981 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +-- (c) The University of Glasgow, 1992-2006 + +-- | This module contains types that relate to the positions of things +-- in source files, and allow tagging of those things with locations +module GHC.Types.SrcLoc ( + -- * SrcLoc + RealSrcLoc, -- Abstract + SrcLoc(..), + + -- ** Constructing SrcLoc + mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, + leftmostColumn, + + noSrcLoc, -- "I'm sorry, I haven't a clue" + generatedSrcLoc, -- Code generated within the compiler + interactiveSrcLoc, -- Code from an interactive session + + advanceSrcLoc, + advanceBufPos, + + -- ** Unsafely deconstructing SrcLoc + -- These are dubious exports, because they crash on some inputs + srcLocFile, -- return the file name part + srcLocLine, -- return the line part + srcLocCol, -- return the column part + + -- * SrcSpan + RealSrcSpan, -- Abstract + SrcSpan(..), + UnhelpfulSpanReason(..), + + -- ** Constructing SrcSpan + mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, + noSrcSpan, generatedSrcSpan, isGeneratedSrcSpan, + wiredInSrcSpan, -- Something wired into the compiler + interactiveSrcSpan, + srcLocSpan, realSrcLocSpan, + combineSrcSpans, + srcSpanFirstCharacter, + + -- ** Deconstructing SrcSpan + srcSpanStart, srcSpanEnd, + realSrcSpanStart, realSrcSpanEnd, + srcSpanFileName_maybe, + pprUserRealSpan, pprUnhelpfulSpanReason, + pprUserSpan, + unhelpfulSpanFS, + srcSpanToRealSrcSpan, + + -- ** Unsafely deconstructing SrcSpan + -- These are dubious exports, because they crash on some inputs + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + + -- ** Predicates on SrcSpan + isGoodSrcSpan, isOneLineSpan, isZeroWidthSpan, + containsSpan, isNoSrcSpan, + + -- ** Predicates on RealSrcSpan + isPointRealSpan, + + -- * StringBuffer locations + BufPos(..), + getBufPos, + BufSpan(..), + getBufSpan, + removeBufSpan, + combineBufSpans, + + -- * Located + Located, + RealLocated, + GenLocated(..), + + -- ** Constructing Located + noLoc, + mkGeneralLocated, + + -- ** Deconstructing Located + getLoc, unLoc, + unRealSrcSpan, getRealSrcSpan, + pprLocated, + pprLocatedAlways, + + -- ** Combining and comparing Located values + eqLocated, cmpLocated, cmpBufSpan, + combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost_smallest, + spans, isSubspanOf, isRealSubspanOf, + sortLocated, sortRealLocated, + lookupSrcLoc, lookupSrcSpan, + + -- * Parser locations + PsLoc(..), + PsSpan(..), + PsLocated, + advancePsLoc, + mkPsSpan, + psSpanStart, + psSpanEnd, + mkSrcSpanPs, + combineRealSrcSpans, + psLocatedToLocated, + + -- * Exact print locations + EpaLocation'(..), NoCommentsLocation, NoComments(..), + DeltaPos(..), deltaPos, getDeltaLine, + ) where + +import GHC.Prelude + +import GHC.Utils.Misc +import GHC.Utils.Json +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.FastString +import qualified GHC.Data.Strict as Strict + +import Control.DeepSeq +import Data.Data +import Data.List (sortBy, intercalate) +import Data.Function (on) +import qualified Data.Map as Map +import qualified Data.Semigroup as S + +{- +************************************************************************ +* * +\subsection[SrcLoc-SrcLocations]{Source-location information} +* * +************************************************************************ + +We keep information about the {\em definition} point for each entity; +this is the obvious stuff: +-} + +-- | Real Source Location +-- +-- Represents a single point within a file +data RealSrcLoc + = SrcLoc LexicalFastString -- A precise location (file name) + {-# UNPACK #-} !Int -- line number, begins at 1 + {-# UNPACK #-} !Int -- column number, begins at 1 + deriving (Eq, Ord) + +-- | 0-based offset identifying the raw location in the 'StringBuffer'. +-- +-- The lexer increments the 'BufPos' every time a character (UTF-8 code point) +-- is read from the input buffer. As UTF-8 is a variable-length encoding and +-- 'StringBuffer' needs a byte offset for indexing, a 'BufPos' cannot be used +-- for indexing. +-- +-- The parser guarantees that 'BufPos' are monotonic. See #17632. This means +-- that syntactic constructs that appear later in the 'StringBuffer' are guaranteed to +-- have a higher 'BufPos'. Contrast that with 'RealSrcLoc', which does *not* make the +-- analogous guarantee about higher line/column numbers. +-- +-- This is due to #line and {-# LINE ... #-} pragmas that can arbitrarily +-- modify 'RealSrcLoc'. Notice how 'setSrcLoc' and 'resetAlrLastLoc' in +-- "GHC.Parser.Lexer" update 'PsLoc', modifying 'RealSrcLoc' but preserving +-- 'BufPos'. +-- +-- Monotonicity makes 'BufPos' useful to determine the order in which syntactic +-- elements appear in the source. Consider this example (haddockA041 in the test suite): +-- +-- haddockA041.hs +-- {-# LANGUAGE CPP #-} +-- -- | Module header documentation +-- module Comments_and_CPP_include where +-- #include "IncludeMe.hs" +-- +-- IncludeMe.hs: +-- -- | Comment on T +-- data T = MkT -- ^ Comment on MkT +-- +-- After the C preprocessor runs, the 'StringBuffer' will contain a program that +-- looks like this (unimportant lines at the beginning removed): +-- +-- # 1 "haddockA041.hs" +-- {-# LANGUAGE CPP #-} +-- -- | Module header documentation +-- module Comments_and_CPP_include where +-- # 1 "IncludeMe.hs" 1 +-- -- | Comment on T +-- data T = MkT -- ^ Comment on MkT +-- # 7 "haddockA041.hs" 2 +-- +-- The line pragmas inserted by CPP make the error messages more informative. +-- The downside is that we can't use RealSrcLoc to determine the ordering of +-- syntactic elements. +-- +-- With RealSrcLoc, we have the following location information recorded in the AST: +-- * The module name is located at haddockA041.hs:3:8-31 +-- * The Haddock comment "Comment on T" is located at IncludeMe:1:1-17 +-- * The data declaration is located at IncludeMe.hs:2:1-32 +-- +-- Is the Haddock comment located between the module name and the data +-- declaration? This is impossible to tell because the locations are not +-- comparable; they even refer to different files. +-- +-- On the other hand, with 'BufPos', we have the following location information: +-- * The module name is located at 846-870 +-- * The Haddock comment "Comment on T" is located at 898-915 +-- * The data declaration is located at 916-928 +-- +-- Aside: if you're wondering why the numbers are so high, try running +-- @ghc -E haddockA041.hs@ +-- and see the extra fluff that CPP inserts at the start of the file. +-- +-- For error messages, 'BufPos' is not useful at all. On the other hand, this is +-- exactly what we need to determine the order of syntactic elements: +-- 870 < 898, therefore the Haddock comment appears *after* the module name. +-- 915 < 916, therefore the Haddock comment appears *before* the data declaration. +-- +-- We use 'BufPos' in in GHC.Parser.PostProcess.Haddock to associate Haddock +-- comments with parts of the AST using location information (#17544). +newtype BufPos = BufPos { bufPos :: Int } + deriving (Eq, Ord, Show, Data, NFData) + + +-- | Source Location +data SrcLoc + = RealSrcLoc !RealSrcLoc !(Strict.Maybe BufPos) -- See Note [Why Maybe BufPos] + | UnhelpfulLoc !FastString -- Just a general indication + deriving (Eq, Show) + +{- +************************************************************************ +* * +\subsection[SrcLoc-access-fns]{Access functions} +* * +************************************************************************ +-} + +mkSrcLoc :: FastString -> Int -> Int -> SrcLoc +mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Strict.Nothing + +mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc +mkRealSrcLoc x line col = SrcLoc (LexicalFastString x) line col + +-- | Indentation level is 1-indexed, so the leftmost column is 1. +leftmostColumn :: Int +leftmostColumn = 1 + +getBufPos :: SrcLoc -> Strict.Maybe BufPos +getBufPos (RealSrcLoc _ mbpos) = mbpos +getBufPos (UnhelpfulLoc _) = Strict.Nothing + +-- | Built-in "bad" 'SrcLoc' values for particular locations +noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc +noSrcLoc = UnhelpfulLoc (fsLit "") +generatedSrcLoc = UnhelpfulLoc (fsLit "") +interactiveSrcLoc = UnhelpfulLoc (fsLit "") + +-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location +mkGeneralSrcLoc :: FastString -> SrcLoc +mkGeneralSrcLoc = UnhelpfulLoc + +-- | Gives the filename of the 'RealSrcLoc' +srcLocFile :: RealSrcLoc -> FastString +srcLocFile (SrcLoc (LexicalFastString fname) _ _) = fname + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocLine :: RealSrcLoc -> Int +srcLocLine (SrcLoc _ l _) = l + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocCol :: RealSrcLoc -> Int +srcLocCol (SrcLoc _ _ c) = c + +-- | Move the 'SrcLoc' down by one line if the character is a newline, +-- to the next 8-char tabstop if it is a tab, and across by one +-- character in any other case +advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc +advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 +advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (advance_tabstop c) +advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) + +advance_tabstop :: Int -> Int +advance_tabstop c = ((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1 + +advanceBufPos :: BufPos -> BufPos +advanceBufPos (BufPos i) = BufPos (i+1) + +{- +************************************************************************ +* * +\subsection[SrcLoc-instances]{Instance declarations for various names} +* * +************************************************************************ +-} + +sortLocated :: [Located a] -> [Located a] +sortLocated = sortBy (leftmost_smallest `on` getLoc) + +sortRealLocated :: [RealLocated a] -> [RealLocated a] +sortRealLocated = sortBy (compare `on` getLoc) + +lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a +lookupSrcLoc (RealSrcLoc l _) = Map.lookup l +lookupSrcLoc (UnhelpfulLoc _) = const Nothing + +lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a +lookupSrcSpan (RealSrcSpan l _) = Map.lookup l +lookupSrcSpan (UnhelpfulSpan _) = const Nothing + +instance Outputable RealSrcLoc where + ppr (SrcLoc (LexicalFastString src_path) src_line src_col) + = hcat [ pprFastFilePath src_path <> colon + , int src_line <> colon + , int src_col ] + +-- I don't know why there is this style-based difference +-- if userStyle sty || debugStyle sty then +-- hcat [ pprFastFilePath src_path, char ':', +-- int src_line, +-- char ':', int src_col +-- ] +-- else +-- hcat [text "{-# LINE ", int src_line, space, +-- char '\"', pprFastFilePath src_path, text " #-}"] + +instance Outputable SrcLoc where + ppr (RealSrcLoc l _) = ppr l + ppr (UnhelpfulLoc s) = ftext s + +instance Data RealSrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "RealSrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "RealSrcSpan" + +instance Data SrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "SrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "SrcSpan" + +{- +************************************************************************ +* * +\subsection[SrcSpan]{Source Spans} +* * +************************************************************************ +-} + +{- | +A 'RealSrcSpan' delimits a portion of a text file. It could be represented +by a pair of (line,column) coordinates, but in fact we optimise +slightly by using more compact representations for single-line and +zero-length spans, both of which are quite common. + +The end position is defined to be the column /after/ the end of the +span. That is, a span of (1,1)-(1,2) is one character long, and a +span of (1,1)-(1,1) is zero characters long. +-} + +-- | Real Source Span +data RealSrcSpan + = RealSrcSpan' + { srcSpanFile :: !FastString, + srcSpanSLine :: {-# UNPACK #-} !Int, + srcSpanSCol :: {-# UNPACK #-} !Int, + srcSpanELine :: {-# UNPACK #-} !Int, + srcSpanECol :: {-# UNPACK #-} !Int + } + deriving Eq + +data BufSpan = + BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } + deriving (Eq, Ord, Show, Data) + +instance NFData BufSpan where + rnf (BufSpan a1 a2) = rnf a1 `seq` rnf a2 + +instance Semigroup BufSpan where + BufSpan start1 end1 <> BufSpan start2 end2 = + BufSpan (min start1 start2) (max end1 end2) + +-- | Source Span +-- +-- A 'SrcSpan' identifies either a specific portion of a text file +-- or a human-readable description of a location. +data SrcSpan = + RealSrcSpan !RealSrcSpan !(Strict.Maybe BufSpan) -- See Note [Why Maybe BufPos] + | UnhelpfulSpan !UnhelpfulSpanReason + + deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we + -- derive Show for Token + +data UnhelpfulSpanReason + = UnhelpfulNoLocationInfo + | UnhelpfulWiredIn + | UnhelpfulInteractive + | UnhelpfulGenerated + | UnhelpfulOther !FastString + deriving (Eq, Show) + +removeBufSpan :: SrcSpan -> SrcSpan +removeBufSpan (RealSrcSpan s _) = RealSrcSpan s Strict.Nothing +removeBufSpan s = s + +{- Note [Why Maybe BufPos] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan). +Why the Maybe? + +Surely, the lexer can always fill in the buffer position, and it guarantees to do so. +However, sometimes the SrcLoc/SrcSpan is constructed in a different context +where the buffer location is not available, and then we use Nothing instead of +a fake value like BufPos (-1). + +Perhaps the compiler could be re-engineered to pass around BufPos more +carefully and never discard it, and this 'Maybe' could be removed. If you're +interested in doing so, you may find this ripgrep query useful: + + rg "RealSrc(Loc|Span).*?Nothing" + +For example, it is not uncommon to whip up source locations for e.g. error +messages, constructing a SrcSpan without a BufSpan. +-} + +instance ToJson SrcSpan where + json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] + json (RealSrcSpan rss _) = json rss + +instance ToJson RealSrcSpan where + json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)), + ("start", start), + ("end", end) + ] + where start = JSObject [ ("line", JSInt srcSpanSLine), + ("column", JSInt srcSpanSCol) ] + end = JSObject [ ("line", JSInt srcSpanELine), + ("column", JSInt srcSpanECol) ] + +instance NFData RealSrcSpan where + rnf (RealSrcSpan' file line col endLine endCol) = rnf file `seq` rnf line `seq` rnf col `seq` rnf endLine `seq` rnf endCol + +instance NFData SrcSpan where + rnf (RealSrcSpan a1 a2) = rnf a1 `seq` rnf a2 + rnf (UnhelpfulSpan a1) = rnf a1 + +instance NFData UnhelpfulSpanReason where + rnf (UnhelpfulNoLocationInfo) = () + rnf (UnhelpfulWiredIn) = () + rnf (UnhelpfulInteractive) = () + rnf (UnhelpfulGenerated) = () + rnf (UnhelpfulOther a1) = rnf a1 + +getBufSpan :: SrcSpan -> Strict.Maybe BufSpan +getBufSpan (RealSrcSpan _ mbspan) = mbspan +getBufSpan (UnhelpfulSpan _) = Strict.Nothing + +-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty +noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan +noSrcSpan = UnhelpfulSpan UnhelpfulNoLocationInfo +wiredInSrcSpan = UnhelpfulSpan UnhelpfulWiredIn +interactiveSrcSpan = UnhelpfulSpan UnhelpfulInteractive +generatedSrcSpan = UnhelpfulSpan UnhelpfulGenerated + +isGeneratedSrcSpan :: SrcSpan -> Bool +isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True +isGeneratedSrcSpan _ = False + +isNoSrcSpan :: SrcSpan -> Bool +isNoSrcSpan (UnhelpfulSpan UnhelpfulNoLocationInfo) = True +isNoSrcSpan _ = False + +-- | Create a "bad" 'SrcSpan' that has not location information +mkGeneralSrcSpan :: FastString -> SrcSpan +mkGeneralSrcSpan = UnhelpfulSpan . UnhelpfulOther + +-- | Create a 'SrcSpan' corresponding to a single point +srcLocSpan :: SrcLoc -> SrcSpan +srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str) +srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb) + +realSrcLocSpan :: RealSrcLoc -> RealSrcSpan +realSrcLocSpan (SrcLoc (LexicalFastString file) line col) = RealSrcSpan' file line col line col + +-- | Create a 'SrcSpan' between two points in a file +mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan +mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 + where + line1 = srcLocLine loc1 + line2 = srcLocLine loc2 + col1 = srcLocCol loc1 + col2 = srcLocCol loc2 + file = srcLocFile loc1 + +-- | 'True' if the span is known to straddle only one line. +isOneLineRealSpan :: RealSrcSpan -> Bool +isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _) + = line1 == line2 + +-- | 'True' if the span is a single point +isPointRealSpan :: RealSrcSpan -> Bool +isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) + = line1 == line2 && col1 == col2 + +-- | Create a 'SrcSpan' between two points in a file +mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan +mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan (UnhelpfulOther str) +mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str) +mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) + = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2) + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Returns UnhelpfulSpan if the files differ. +combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful +combineSrcSpans l (UnhelpfulSpan _) = l +combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) + | srcSpanFile span1 == srcSpanFile span2 + = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) + | otherwise = UnhelpfulSpan $ + UnhelpfulOther (fsLit "") + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Assumes the "file" part is the same in both inputs +combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan +combineRealSrcSpans span1 span2 + = RealSrcSpan' file line_start col_start line_end col_end + where + (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) + (srcSpanStartLine span2, srcSpanStartCol span2) + (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) + (srcSpanEndLine span2, srcSpanEndCol span2) + file = srcSpanFile span1 + +combineBufSpans :: BufSpan -> BufSpan -> BufSpan +combineBufSpans span1 span2 = BufSpan start end + where + start = min (bufSpanStart span1) (bufSpanStart span2) + end = max (bufSpanEnd span1) (bufSpanEnd span2) + + +-- | Convert a SrcSpan into one that represents only its first character +srcSpanFirstCharacter :: SrcSpan -> SrcSpan +srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l +srcSpanFirstCharacter (RealSrcSpan span mbspan) = + RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan) + where + loc1@(SrcLoc f l c) = realSrcSpanStart span + loc2 = SrcLoc f l (c+1) + mkBufSpan bspan = + let bpos1@(BufPos i) = bufSpanStart bspan + bpos2 = BufPos (i+1) + in BufSpan bpos1 bpos2 + +{- +************************************************************************ +* * +\subsection[SrcSpan-predicates]{Predicates} +* * +************************************************************************ +-} + +-- | Test if a 'SrcSpan' is "good", i.e. has precise location information +isGoodSrcSpan :: SrcSpan -> Bool +isGoodSrcSpan (RealSrcSpan _ _) = True +isGoodSrcSpan (UnhelpfulSpan _) = False + +isOneLineSpan :: SrcSpan -> Bool +-- ^ True if the span is known to straddle only one line. +-- For "bad" 'SrcSpan', it returns False +isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s +isOneLineSpan (UnhelpfulSpan _) = False + +isZeroWidthSpan :: SrcSpan -> Bool +-- ^ True if the span has a width of zero, as returned for "virtual" +-- semicolons in the lexer. +-- For "bad" 'SrcSpan', it returns False +isZeroWidthSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s + && srcSpanStartCol s == srcSpanEndCol s +isZeroWidthSpan (UnhelpfulSpan _) = False + +-- | Tests whether the first span "contains" the other span, meaning +-- that it covers at least as much source code. True where spans are equal. +containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool +containsSpan s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + <= (srcSpanStartLine s2, srcSpanStartCol s2) + && (srcSpanEndLine s1, srcSpanEndCol s1) + >= (srcSpanEndLine s2, srcSpanEndCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + -- We check file equality last because it is (presumably?) least + -- likely to fail. +{- +%************************************************************************ +%* * +\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} +* * +************************************************************************ +-} + +srcSpanStartLine :: RealSrcSpan -> Int +srcSpanEndLine :: RealSrcSpan -> Int +srcSpanStartCol :: RealSrcSpan -> Int +srcSpanEndCol :: RealSrcSpan -> Int + +srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l +srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l +srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l +srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c + +{- +************************************************************************ +* * +\subsection[SrcSpan-access-fns]{Access functions} +* * +************************************************************************ +-} + +-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanStart :: SrcSpan -> SrcLoc +srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) +srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) + +-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanEnd :: SrcSpan -> SrcLoc +srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) +srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) + +realSrcSpanStart :: RealSrcSpan -> RealSrcLoc +realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) + (srcSpanStartLine s) + (srcSpanStartCol s) + +realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc +realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) + (srcSpanEndLine s) + (srcSpanEndCol s) + +-- | Obtains the filename for a 'SrcSpan' if it is "good" +srcSpanFileName_maybe :: SrcSpan -> Maybe FastString +srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) +srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing + +srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan +srcSpanToRealSrcSpan (RealSrcSpan ss _) = Just ss +srcSpanToRealSrcSpan _ = Nothing + +{- +************************************************************************ +* * +\subsection[SrcSpan-instances]{Instances} +* * +************************************************************************ +-} + +-- We want to order RealSrcSpans first by the start point, then by the +-- end point. +instance Ord RealSrcSpan where + compare = on compare realSrcSpanStart S.<> on compare realSrcSpanEnd + +instance Show RealSrcLoc where + show (SrcLoc filename row col) + = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col + +-- Show is used by GHC.Parser.Lexer, because we derive Show for Token +instance Show RealSrcSpan where + show span@(RealSrcSpan' file sl sc el ec) + | isPointRealSpan span + = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc]) + + | isOneLineRealSpan span + = "SrcSpanOneLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,ec]) + + | otherwise + = "SrcSpanMultiLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,el,ec]) + + +instance Outputable RealSrcSpan where + ppr span = pprUserRealSpan True span + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- text (showUserRealSpan True span) +-- else +-- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, +-- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] + +instance Outputable SrcSpan where + ppr span = pprUserSpan True span + +instance Outputable UnhelpfulSpanReason where + ppr = pprUnhelpfulSpanReason + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- pprUserSpan True span +-- else +-- case span of +-- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" +-- RealSrcSpan s -> ppr s + +unhelpfulSpanFS :: UnhelpfulSpanReason -> FastString +unhelpfulSpanFS r = case r of + UnhelpfulOther s -> s + UnhelpfulNoLocationInfo -> fsLit "" + UnhelpfulWiredIn -> fsLit "" + UnhelpfulInteractive -> fsLit "" + UnhelpfulGenerated -> fsLit "" + +pprUnhelpfulSpanReason :: UnhelpfulSpanReason -> SDoc +pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r) + +pprUserSpan :: Bool -> SrcSpan -> SDoc +pprUserSpan _ (UnhelpfulSpan r) = pprUnhelpfulSpanReason r +pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s + +pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc +pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _) + | isPointRealSpan span + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int col ] + +pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) + | isOneLineRealSpan span + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int scol + , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ] + -- For single-character or point spans, we just + -- output the starting column number + +pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , parens (int sline <> comma <> int scol) + , char '-' + , parens (int eline <> comma <> int ecol') ] + where + ecol' = if ecol == 0 then ecol else ecol - 1 + +{- +************************************************************************ +* * +\subsection[Located]{Attaching SrcSpans to things} +* * +************************************************************************ +-} + +-- | We attach SrcSpans to lots of things, so let's have a datatype for it. +data GenLocated l e = L l e + deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable) +instance (NFData l, NFData e) => NFData (GenLocated l e) where + rnf (L l e) = rnf l `seq` rnf e + +type Located = GenLocated SrcSpan +type RealLocated = GenLocated RealSrcSpan + +unLoc :: GenLocated l e -> e +unLoc (L _ e) = e + +getLoc :: GenLocated l e -> l +getLoc (L l _) = l + +noLoc :: e -> Located e +noLoc e = L noSrcSpan e + +mkGeneralLocated :: String -> e -> Located e +mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e + +combineLocs :: Located a -> Located b -> SrcSpan +combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) + +-- | Combine locations from two 'Located' things and add them to a third thing +addCLoc :: Located a -> Located b -> c -> Located c +addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c + +-- not clear whether to add a general Eq instance, but this is useful sometimes: + +-- | Tests whether the two located things are equal +eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool +eqLocated a b = unLoc a == unLoc b + +-- not clear whether to add a general Ord instance, but this is useful sometimes: + +-- | Tests the ordering of the two located things +cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering +cmpLocated a b = unLoc a `compare` unLoc b + +-- | Compare the 'BufSpan' of two located things. +-- +-- Precondition: both operands have an associated 'BufSpan'. +cmpBufSpan :: HasDebugCallStack => Located a -> Located a -> Ordering +cmpBufSpan (L l1 _) (L l2 _) + | Strict.Just a <- getBufSpan l1 + , Strict.Just b <- getBufSpan l2 + = compare a b + + | otherwise = panic "cmpBufSpan: no BufSpan" + +instance (Outputable e) => Outputable (Located e) where + ppr (L l e) = -- GenLocated: + -- Print spans without the file name etc + whenPprDebug (braces (pprUserSpan False l)) + $$ ppr e +instance (Outputable e) => Outputable (GenLocated RealSrcSpan e) where + ppr (L l e) = -- GenLocated: + -- Print spans without the file name etc + whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Strict.Nothing))) + $$ ppr e + + +pprLocated :: (Outputable l, Outputable e) => GenLocated l e -> SDoc +pprLocated (L l e) = + -- Print spans without the file name etc + whenPprDebug (braces (ppr l)) + $$ ppr e + +-- | Always prints the location, even without -dppr-debug +pprLocatedAlways :: (Outputable l, Outputable e) => GenLocated l e -> SDoc +pprLocatedAlways (L l e) = + braces (ppr l) + $$ ppr e + +{- +************************************************************************ +* * +\subsection{Ordering SrcSpans for InteractiveUI} +* * +************************************************************************ +-} + +-- | Strategies for ordering 'SrcSpan's +leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering +rightmost_smallest = compareSrcSpanBy (flip compare) +leftmost_smallest = compareSrcSpanBy compare +leftmost_largest = compareSrcSpanBy $ + on compare realSrcSpanStart S.<> flip (on compare realSrcSpanEnd) + +compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering +compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b +compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT +compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT +compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ + +-- | Determines whether a span encloses a given line and column index +spans :: SrcSpan -> (Int, Int) -> Bool +spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" +spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span + where loc = mkRealSrcLoc (srcSpanFile span) l c + +-- | Determines whether a span is enclosed by another one +isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other + -> SrcSpan -- ^ The span it may be enclosed by + -> Bool +isSubspanOf (RealSrcSpan src _) (RealSrcSpan parent _) = isRealSubspanOf src parent +isSubspanOf _ _ = False + +-- | Determines whether a span is enclosed by another one +isRealSubspanOf :: RealSrcSpan -- ^ The span that may be enclosed by the other + -> RealSrcSpan -- ^ The span it may be enclosed by + -> Bool +isRealSubspanOf src parent + | srcSpanFile parent /= srcSpanFile src = False + | otherwise = realSrcSpanStart parent <= realSrcSpanStart src && + realSrcSpanEnd parent >= realSrcSpanEnd src + +getRealSrcSpan :: RealLocated a -> RealSrcSpan +getRealSrcSpan (L l _) = l + +unRealSrcSpan :: RealLocated a -> a +unRealSrcSpan (L _ e) = e + + +-- | A location as produced by the parser. Consists of two components: +-- +-- * The location in the file, adjusted for #line and {-# LINE ... #-} pragmas (RealSrcLoc) +-- * The location in the string buffer (BufPos) with monotonicity guarantees (see #17632) +data PsLoc + = PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos } + deriving (Eq, Ord, Show) + +data PsSpan + = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan } + deriving (Eq, Ord, Show, Data) + +type PsLocated = GenLocated PsSpan + +psLocatedToLocated :: PsLocated a -> Located a +psLocatedToLocated (L sp a) = L (mkSrcSpanPs sp) a + +advancePsLoc :: PsLoc -> Char -> PsLoc +advancePsLoc (PsLoc real_loc buf_loc) c = + PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc) + +mkPsSpan :: PsLoc -> PsLoc -> PsSpan +mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) = PsSpan (mkRealSrcSpan r1 r2) (BufSpan b1 b2) + +psSpanStart :: PsSpan -> PsLoc +psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b) + +psSpanEnd :: PsSpan -> PsLoc +psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b) + +mkSrcSpanPs :: PsSpan -> SrcSpan +mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b) + +-- --------------------------------------------------------------------- +-- The following section contains basic types related to exact printing. +-- See https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for +-- details. +-- This is only s subset, to prevent import loops. The balance are in +-- GHC.Parser.Annotation +-- --------------------------------------------------------------------- + + +-- | The anchor for an exact print annotation. The Parser inserts the +-- @'EpaSpan'@ variant, giving the exact location of the original item +-- in the parsed source. This can be replaced by the @'EpaDelta'@ +-- version, to provide a position for the item relative to the end of +-- the previous item in the source. This is useful when editing an +-- AST prior to exact printing the changed one. +-- The EpaDelta also contains the original @'SrcSpan'@ for use by +-- tools wanting to manipulate the AST after converting it using +-- ghc-exactprint' @'makeDeltaAst'@. + +data EpaLocation' a = EpaSpan !SrcSpan + | EpaDelta !SrcSpan !DeltaPos !a + deriving (Data,Eq,Show) + +type NoCommentsLocation = EpaLocation' NoComments + +data NoComments = NoComments + deriving (Data,Eq,Ord,Show) + +-- | Spacing between output items when exact printing. It captures +-- the spacing from the current print position on the page to the +-- position required for the thing about to be printed. This is +-- either on the same line in which case is is simply the number of +-- spaces to emit, or it is some number of lines down, with a given +-- column offset. The exact printing algorithm keeps track of the +-- column offset pertaining to the current anchor position, so the +-- `deltaColumn` is the additional spaces to add in this case. See +-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for +-- details. +data DeltaPos + = SameLine { deltaColumn :: !Int } + | DifferentLine + { deltaLine :: !Int, -- ^ deltaLine should always be > 0 + deltaColumn :: !Int + } deriving (Show,Eq,Ord,Data) + +-- | Smart constructor for a 'DeltaPos'. It preserves the invariant +-- that for the 'DifferentLine' constructor 'deltaLine' is always > 0. +deltaPos :: Int -> Int -> DeltaPos +deltaPos l c = case l of + 0 -> SameLine c + _ -> DifferentLine l c + +getDeltaLine :: DeltaPos -> Int +getDeltaLine (SameLine _) = 0 +getDeltaLine (DifferentLine r _) = r + +instance Outputable NoComments where + ppr NoComments = text "NoComments" + +instance (Outputable a) => Outputable (EpaLocation' a) where + ppr (EpaSpan r) = text "EpaSpan" <+> ppr r + ppr (EpaDelta s d cs) = text "EpaDelta" <+> ppr s <+> ppr d <+> ppr cs + +instance Outputable DeltaPos where + ppr (SameLine c) = text "SameLine" <+> ppr c + ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c diff --git a/GHC/Types/Target.hs b/GHC/Types/Target.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Target.hs @@ -0,0 +1,70 @@ +module GHC.Types.Target + ( Target(..) + , TargetId(..) + , InputFileBuffer + , pprTarget + , pprTargetId + ) +where + +import GHC.Prelude +import GHC.Driver.Phases ( Phase ) +import GHC.Unit +import GHC.Data.StringBuffer ( StringBuffer ) +import GHC.Utils.Outputable + +import Data.Time + +-- | A compilation target. +-- +-- A target may be supplied with the actual text of the +-- module. If so, use this instead of the file contents (this +-- is for use in an IDE where the file hasn't been saved by +-- the user yet). +-- +-- These fields are strict because Targets are long lived. +data Target + = Target { + targetId :: !TargetId, -- ^ module or filename + targetAllowObjCode :: !Bool, -- ^ object code allowed? + targetUnitId :: !UnitId, -- ^ id of the unit this target is part of + targetContents :: !(Maybe (InputFileBuffer, UTCTime)) + -- ^ Optional in-memory buffer containing the source code GHC should + -- use for this target instead of reading it from disk. + -- + -- Since GHC version 8.10 modules which require preprocessors such as + -- Literate Haskell or CPP to run are also supported. + -- + -- If a corresponding source file does not exist on disk this will + -- result in a 'SourceError' exception if @targetId = TargetModule _@ + -- is used. However together with @targetId = TargetFile _@ GHC will + -- not complain about the file missing. + } + +data TargetId + = TargetModule !ModuleName + -- ^ A module name: search for the file + | TargetFile !FilePath !(Maybe Phase) + -- ^ A filename: preprocess & parse it to find the module name. + -- If specified, the Phase indicates how to compile this file + -- (which phase to start from). Nothing indicates the starting phase + -- should be determined from the suffix of the filename. + deriving Eq + +type InputFileBuffer = StringBuffer + + +pprTarget :: Target -> SDoc +pprTarget Target { targetUnitId = uid, targetId = id, targetAllowObjCode = obj } = + (if obj then empty else char '*') <> ppr uid <> colon <> pprTargetId id + +instance Outputable Target where + ppr = pprTarget + +pprTargetId :: TargetId -> SDoc +pprTargetId (TargetModule m) = ppr m +pprTargetId (TargetFile f _) = text f + +instance Outputable TargetId where + ppr = pprTargetId + diff --git a/GHC/Types/ThLevelIndex.hs b/GHC/Types/ThLevelIndex.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/ThLevelIndex.hs @@ -0,0 +1,36 @@ +module GHC.Types.ThLevelIndex where + +import GHC.Prelude +import GHC.Utils.Outputable +import GHC.Types.Basic ( ImportLevel(..) ) +import Data.Data + +-- | The integer which represents the level +newtype ThLevelIndex = ThLevelIndex Int deriving (Eq, Ord, Data) + -- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice + -- Incremented when going inside a bracket, + -- decremented when going inside a splice + +instance Outputable ThLevelIndex where + ppr (ThLevelIndex i) = int i + +incThLevelIndex :: ThLevelIndex -> ThLevelIndex +incThLevelIndex (ThLevelIndex i) = ThLevelIndex (i + 1) + +decThLevelIndex :: ThLevelIndex -> ThLevelIndex +decThLevelIndex (ThLevelIndex i) = ThLevelIndex (i - 1) + +topLevelIndex :: ThLevelIndex +topLevelIndex = ThLevelIndex 0 + +spliceLevelIndex :: ThLevelIndex +spliceLevelIndex = decThLevelIndex topLevelIndex + +quoteLevelIndex :: ThLevelIndex +quoteLevelIndex = incThLevelIndex topLevelIndex + +-- | Convert a 'GHC.Types.Basic.ImportLevel' to a 'ThLevelIndex' +thLevelIndexFromImportLevel :: ImportLevel -> ThLevelIndex +thLevelIndexFromImportLevel NormalLevel = topLevelIndex +thLevelIndexFromImportLevel SpliceLevel = spliceLevelIndex +thLevelIndexFromImportLevel QuoteLevel = quoteLevelIndex diff --git a/GHC/Types/Tickish.hs b/GHC/Types/Tickish.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Tickish.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +module GHC.Types.Tickish ( + GenTickish(..), + CoreTickish, StgTickish, CmmTickish, + XTickishId, + tickishCounts, + TickishScoping(..), + tickishScoped, + tickishScopesLike, + tickishFloatable, + tickishCanSplit, + mkNoCount, + mkNoScope, + tickishIsCode, + isProfTick, + TickishPlacement(..), + tickishPlace, + tickishContains, + + -- * Breakpoint tick identifiers + BreakpointId(..), BreakTickIndex +) where + +import GHC.Prelude +import GHC.Data.FastString +import Control.DeepSeq + +import GHC.Core.Type + +import GHC.Unit.Module + +import GHC.Types.CostCentre +import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) +import GHC.Types.Var + +import GHC.Utils.Panic + +import Language.Haskell.Syntax.Extension ( NoExtField ) + +import Data.Data +import GHC.Utils.Outputable (Outputable (ppr), text, (<+>)) + +{- ********************************************************************* +* * + Ticks +* * +************************************************************************ +-} + +-- | Allows attaching extra information to points in expressions + +{- | Used as a data type index for the GenTickish annotations. + See Note [Tickish passes] + -} +data TickishPass + = TickishPassCore + | TickishPassStg + | TickishPassCmm + +{- + Note [Tickish passes] + ~~~~~~~~~~~~~~~~~~~~~ + Tickish annotations store different information depending on + where they are used. Here's a summary of the differences + between the passes. + + - CoreTickish: Haskell and Core + The tickish annotations store the free variables of + breakpoints. + + - StgTickish: Stg + The GHCi bytecode generator (GHC.StgToByteCode) needs + to know the type of each breakpoint in addition to its + free variables. Since we cannot compute the type from + an STG expression, the tickish annotations store the + type of breakpoints in addition to the free variables. + + - CmmTickish: Cmm + Breakpoints are unsupported and no free variables or + type are stored. + -} + +type family XBreakpoint (pass :: TickishPass) +type instance XBreakpoint 'TickishPassCore = NoExtField +-- | Keep track of the type of breakpoints in STG, for GHCi +type instance XBreakpoint 'TickishPassStg = Type +type instance XBreakpoint 'TickishPassCmm = NoExtField + +type family XTickishId (pass :: TickishPass) +type instance XTickishId 'TickishPassCore = Id +type instance XTickishId 'TickishPassStg = Id +type instance XTickishId 'TickishPassCmm = NoExtField + +type CoreTickish = GenTickish 'TickishPassCore +type StgTickish = GenTickish 'TickishPassStg +-- | Tickish in Cmm context (annotations only) +type CmmTickish = GenTickish 'TickishPassCmm + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data GenTickish pass = + -- | An @{-# SCC #-}@ profiling annotation, either automatically + -- added by the desugarer as a result of -auto-all, or added by + -- the user. + ProfNote { + profNoteCC :: CostCentre, -- ^ the cost centre + + profNoteCount :: !Bool, -- ^ bump the entry count? + profNoteScope :: !Bool -- ^ scopes over the enclosed expression + -- (i.e. not just a tick) + -- Invariant: the False/False case never happens + } + + -- | A "tick" used by HPC to track the execution of each + -- subexpression in the original source code. + | HpcTick { + tickModule :: Module, + tickId :: !Int + } + + -- | A breakpoint for the GHCi debugger. This behaves like an HPC + -- tick, but has a list of free variables which will be available + -- for inspection in GHCi when the program stops at the breakpoint. + -- + -- NB. we must take account of these Ids when (a) counting free variables, + -- and (b) substituting (don't substitute for them) + | Breakpoint + { breakpointExt :: XBreakpoint pass + , breakpointId :: !BreakpointId + , breakpointFVs :: [XTickishId pass] + -- ^ the order of this list is important: + -- it matches the order of the lists in the + -- appropriate entry in 'GHC.ByteCode.Types.ModBreaks'. + -- + -- Careful about substitution! See + -- Note [substTickish] in "GHC.Core.Subst". + } + + -- | A source note. + -- + -- Source notes are pure annotations: Their presence should neither + -- influence compilation nor execution. The semantics are given by + -- causality: The presence of a source note means that a local + -- change in the referenced source code span will possibly provoke + -- the generated code to change. On the flip-side, the functionality + -- of annotated code *must* be invariant against changes to all + -- source code *except* the spans referenced in the source notes + -- (see "Causality of optimized Haskell" paper for details). + -- + -- Therefore extending the scope of any given source note is always + -- valid. Note that it is still undesirable though, as this reduces + -- their usefulness for debugging and profiling. Therefore we will + -- generally try only to make use of this property where it is + -- necessary to enable optimizations. + | SourceNote + { sourceSpan :: RealSrcSpan -- ^ Source covered + , sourceName :: LexicalFastString -- ^ Name for source location + -- (uses same names as CCs) + } + +deriving instance Eq (GenTickish 'TickishPassCore) +deriving instance Ord (GenTickish 'TickishPassCore) +deriving instance Data (GenTickish 'TickishPassCore) + +deriving instance Data (GenTickish 'TickishPassStg) + +deriving instance Eq (GenTickish 'TickishPassCmm) +deriving instance Ord (GenTickish 'TickishPassCmm) +deriving instance Data (GenTickish 'TickishPassCmm) + +-------------------------------------------------------------------------------- +-- Tick breakpoint index +-------------------------------------------------------------------------------- + +-- | Breakpoint tick index +-- newtype BreakTickIndex = BreakTickIndex Int +-- deriving (Eq, Ord, Data, Ix, NFData, Outputable) +type BreakTickIndex = Int + +-- | Breakpoint identifier. +-- +-- Indexes into the structures in the @'ModBreaks'@ created during desugaring +-- (after inserting the breakpoint ticks in the expressions). +-- See Note [Breakpoint identifiers] +data BreakpointId = BreakpointId + { bi_tick_mod :: !Module -- ^ Breakpoint tick module + , bi_tick_index :: !BreakTickIndex -- ^ Breakpoint tick index + } + deriving (Eq, Ord, Data) + +instance Outputable BreakpointId where + ppr BreakpointId{bi_tick_mod, bi_tick_index} = + text "BreakpointId" <+> ppr bi_tick_mod <+> ppr bi_tick_index + +instance NFData BreakpointId where + rnf BreakpointId{bi_tick_mod, bi_tick_index} = + rnf bi_tick_mod `seq` rnf bi_tick_index + +-------------------------------------------------------------------------------- + +-- | A "counting tick" (where tickishCounts is True) is one that +-- counts evaluations in some way. We cannot discard a counting tick, +-- and the compiler should preserve the number of counting ticks as +-- far as possible. +-- +-- However, we still allow the simplifier to increase or decrease +-- sharing, so in practice the actual number of ticks may vary, except +-- that we never change the value from zero to non-zero or vice versa. +tickishCounts :: GenTickish pass -> Bool +tickishCounts n@ProfNote{} = profNoteCount n +tickishCounts HpcTick{} = True +tickishCounts Breakpoint{} = True +tickishCounts _ = False + + +-- | Specifies the scoping behaviour of ticks. This governs the +-- behaviour of ticks that care about the covered code and the cost +-- associated with it. Important for ticks relating to profiling. +data TickishScoping = + -- | No scoping: The tick does not care about what code it + -- covers. Transformations can freely move code inside as well as + -- outside without any additional annotation obligations + NoScope + + -- | Soft scoping: We want all code that is covered to stay + -- covered. Note that this scope type does not forbid + -- transformations from happening, as long as all results of + -- the transformations are still covered by this tick or a copy of + -- it. For example + -- + -- let x = tick<...> (let y = foo in bar) in baz + -- ===> + -- let x = tick<...> bar; y = tick<...> foo in baz + -- + -- Is a valid transformation as far as "bar" and "foo" is + -- concerned, because both still are scoped over by the tick. + -- + -- Note though that one might object to the "let" not being + -- covered by the tick any more. However, we are generally lax + -- with this - constant costs don't matter too much, and given + -- that the "let" was effectively merged we can view it as having + -- lost its identity anyway. + -- + -- Also note that this scoping behaviour allows floating a tick + -- "upwards" in pretty much any situation. For example: + -- + -- case foo of x -> tick<...> bar + -- ==> + -- tick<...> case foo of x -> bar + -- + -- While this is always legal, we want to make a best effort to + -- only make us of this where it exposes transformation + -- opportunities. + | SoftScope + + -- | Cost centre scoping: We don't want any costs to move to other + -- cost-centre stacks. This means we not only want no code or cost + -- to get moved out of their cost centres, but we also object to + -- code getting associated with new cost-centre ticks - or + -- changing the order in which they get applied. + -- + -- A rule of thumb is that we don't want any code to gain new + -- annotations. However, there are notable exceptions, for + -- example: + -- + -- let f = \y -> foo in tick<...> ... (f x) ... + -- ==> + -- tick<...> ... foo[x/y] ... + -- + -- In-lining lambdas like this is always legal, because inlining a + -- function does not change the cost-centre stack when the + -- function is called. + | CostCentreScope + + deriving (Eq) + +-- | Returns the intended scoping rule for a Tickish +tickishScoped :: GenTickish pass -> TickishScoping +tickishScoped n@ProfNote{} + | profNoteScope n = CostCentreScope + | otherwise = NoScope +tickishScoped HpcTick{} = NoScope +tickishScoped Breakpoint{} = CostCentreScope + -- Breakpoints are scoped: eventually we're going to do call + -- stacks, but also this helps prevent the simplifier from moving + -- breakpoints around and changing their result type (see #1531). +tickishScoped SourceNote{} = SoftScope + +-- | Returns whether the tick scoping rule is at least as permissive +-- as the given scoping rule. +tickishScopesLike :: GenTickish pass -> TickishScoping -> Bool +tickishScopesLike t scope = tickishScoped t `like` scope + where NoScope `like` _ = True + _ `like` NoScope = False + SoftScope `like` _ = True + _ `like` SoftScope = False + CostCentreScope `like` _ = True + +-- | Returns @True@ for ticks that can be floated upwards easily even +-- where it might change execution counts, such as: +-- +-- Just (tick<...> foo) +-- ==> +-- tick<...> (Just foo) +-- +-- This is a combination of @tickishSoftScope@ and +-- @tickishCounts@. Note that in principle splittable ticks can become +-- floatable using @mkNoTick@ -- even though there's currently no +-- tickish for which that is the case. +tickishFloatable :: GenTickish pass -> Bool +tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t) + +-- | Returns @True@ for a tick that is both counting /and/ scoping and +-- can be split into its (tick, scope) parts using 'mkNoScope' and +-- 'mkNoTick' respectively. +tickishCanSplit :: GenTickish pass -> Bool +tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True} + = True +tickishCanSplit _ = False + +mkNoCount :: GenTickish pass -> GenTickish pass +mkNoCount n | not (tickishCounts n) = n + | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!" +mkNoCount n@ProfNote{} = let n' = n {profNoteCount = False} + in assert (profNoteCount n) n' +mkNoCount _ = panic "mkNoCount: Undefined split!" + +mkNoScope :: GenTickish pass -> GenTickish pass +mkNoScope n | tickishScoped n == NoScope = n + | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!" +mkNoScope n@ProfNote{} = let n' = n {profNoteScope = False} + in assert (profNoteCount n) n' +mkNoScope _ = panic "mkNoScope: Undefined split!" + +-- | Return @True@ if this source annotation compiles to some backend +-- code. Without this flag, the tickish is seen as a simple annotation +-- that does not have any associated evaluation code. +-- +-- What this means that we are allowed to disregard the tick if doing +-- so means that we can skip generating any code in the first place. A +-- typical example is top-level bindings: +-- +-- foo = tick<...> \y -> ... +-- ==> +-- foo = \y -> tick<...> ... +-- +-- Here there is just no operational difference between the first and +-- the second version. Therefore code generation should simply +-- translate the code as if it found the latter. +tickishIsCode :: GenTickish pass -> Bool +tickishIsCode SourceNote{} = False +tickishIsCode _tickish = True -- all the rest for now + +isProfTick :: GenTickish pass -> Bool +isProfTick ProfNote{} = True +isProfTick _ = False + +-- | Governs the kind of expression that the tick gets placed on when +-- annotating for example using @mkTick@. If we find that we want to +-- put a tickish on an expression ruled out here, we try to float it +-- inwards until we find a suitable expression. +data TickishPlacement = + + -- | Place ticks exactly on run-time expressions. We can still + -- move the tick through pure compile-time constructs such as + -- other ticks, casts or type lambdas. This is the most + -- restrictive placement rule for ticks, as all tickishs have in + -- common that they want to track runtime processes. The only + -- legal placement rule for counting ticks. + -- NB: We generally try to move these as close to the relevant + -- runtime expression as possible. This means they get pushed through + -- tyoe arguments. E.g. we create `(tick f) @Bool` instead of `tick (f @Bool)`. + PlaceRuntime + + -- | As @PlaceRuntime@, but we float the tick through all + -- lambdas. This makes sense where there is little difference + -- between annotating the lambda and annotating the lambda's code. + | PlaceNonLam + + -- | In addition to floating through lambdas, cost-centre style + -- tickishs can also be moved from constructors, non-function + -- variables and literals. For example: + -- + -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ... + -- + -- Neither the constructor application, the variable or the + -- literal are likely to have any cost worth mentioning. And even + -- if y names a thunk, the call would not care about the + -- evaluation context. Therefore removing all annotations in the + -- above example is safe. + | PlaceCostCentre + + deriving (Eq,Show) + +instance Outputable TickishPlacement where + ppr = text . show + +-- | Placement behaviour we want for the ticks +tickishPlace :: GenTickish pass -> TickishPlacement +tickishPlace n@ProfNote{} + | profNoteCount n = PlaceRuntime + | otherwise = PlaceCostCentre +tickishPlace HpcTick{} = PlaceRuntime +tickishPlace Breakpoint{} = PlaceRuntime +tickishPlace SourceNote{} = PlaceNonLam + +-- | Returns whether one tick "contains" the other one, therefore +-- making the second tick redundant. +tickishContains :: Eq (GenTickish pass) + => GenTickish pass -> GenTickish pass -> Bool +tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2) + = containsSpan sp1 sp2 && n1 == n2 + -- compare the String last +tickishContains t1 t2 + = t1 == t2 diff --git a/GHC/Types/TyThing.hs b/GHC/Types/TyThing.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/TyThing.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE LambdaCase #-} + +-- | A global typecheckable-thing, essentially anything that has a name. +module GHC.Types.TyThing + ( TyThing (..) + , MonadThings (..) + , mkATyCon + , mkAnId + , pprShortTyThing + , pprTyThingCategory + , tyThingCategory + , implicitTyThings + , implicitConLikeThings + , implicitClassThings + , implicitTyConThings + , implicitCoTyCon + , isImplicitTyThing + , tyThingParent_maybe + , tyThingsTyCoVars + , tyThingLocalGREs, tyThingGREInfo + , tyThingTyCon + , tyThingCoAxiom + , tyThingDataCon + , tyThingConLike + , tyThingId + ) +where + +import GHC.Prelude + +import GHC.Types.GREInfo +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Unique.Set + +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.PatSyn +import GHC.Core.TyCo.FVs +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import Control.Monad ( liftM ) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class + +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.List ( intersect ) + + +{- +Note [ATyCon for classes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Both classes and type constructors are represented in the type environment +as ATyCon. You can tell the difference, and get to the class, with + isClassTyCon :: TyCon -> Bool + tyConClass_maybe :: TyCon -> Maybe Class +The Class and its associated TyCon have the same Name. +-} + +-- | A global typecheckable-thing, essentially anything that has a name. +-- Not to be confused with a 'TcTyThing', which is also a typecheckable +-- thing but in the *local* context. See "GHC.Tc.Utils.Env" for how to retrieve +-- a 'TyThing' given a 'Name'. +data TyThing + = AnId Id + | AConLike ConLike + | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] + | ACoAxiom (CoAxiom Branched) + +instance Outputable TyThing where + ppr = pprShortTyThing + +instance NamedThing TyThing where -- Can't put this with the type + getName (AnId id) = getName id -- decl, because the DataCon instance + getName (ATyCon tc) = getName tc -- isn't visible there + getName (ACoAxiom cc) = getName cc + getName (AConLike cl) = conLikeName cl + +mkATyCon :: TyCon -> TyThing +mkATyCon = ATyCon + +mkAnId :: Id -> TyThing +mkAnId = AnId + +pprShortTyThing :: TyThing -> SDoc +-- c.f. GHC.Types.TyThing.Ppr.pprTyThing, which prints all the details +pprShortTyThing thing + = pprTyThingCategory thing <+> quotes (ppr (getName thing)) + +pprTyThingCategory :: TyThing -> SDoc +pprTyThingCategory = text . capitalise . tyThingCategory + +tyThingCategory :: TyThing -> String +tyThingCategory (ATyCon tc) + | isClassTyCon tc = "class" + | otherwise = "type constructor" +tyThingCategory (ACoAxiom _) = "coercion axiom" +tyThingCategory (AnId _) = "identifier" +tyThingCategory (AConLike (RealDataCon _)) = "data constructor" +tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" + + + +{- +Note [Implicit TyThings] +~~~~~~~~~~~~~~~~~~~~~~~~ + DEFINITION: An "implicit" TyThing is one that does not have its own + IfaceDecl in an interface file. Instead, its binding in the type + environment is created as part of typechecking the IfaceDecl for + some other thing. + +Examples: + * All DataCons are implicit, because they are generated from the + IfaceDecl for the data/newtype. Ditto class methods. + + * Record selectors are *not* implicit, because they get their own + free-standing IfaceDecl. See Note [Record selectors] in + GHC.Tc.TyCl.Utils. + + * Associated data/type families are implicit because they are + included in the IfaceDecl of the parent class. (NB: the + IfaceClass decl happens to use IfaceDecl recursively for the + associated types, but that's irrelevant here.) + + * Dictionary function Ids are not implicit. + + * Axioms for newtypes are implicit (same as above), but axioms + for data/type family instances are *not* implicit (like DFunIds). +-} + +-- | Determine the 'TyThing's brought into scope by another 'TyThing' +-- /other/ than itself. For example, Id's don't have any implicit TyThings +-- as they just bring themselves into scope, but classes bring their +-- dictionary datatype, type constructor and some selector functions into +-- scope, just for a start! + +-- N.B. the set of TyThings returned here *must* match the set of +-- names returned by 'GHC.Iface.Load.ifaceDeclImplicitBndrs', in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in 'GHC.IfaceToCore.tc_iface_decl_fingerprint' (see +-- Note [Tricky iface loop]) +-- The order of the list does not matter. +implicitTyThings :: TyThing -> [TyThing] +implicitTyThings (AnId _) = [] +implicitTyThings (ACoAxiom _cc) = [] +implicitTyThings (ATyCon tc) = implicitTyConThings tc +implicitTyThings (AConLike cl) = implicitConLikeThings cl + +implicitConLikeThings :: ConLike -> [TyThing] +implicitConLikeThings (RealDataCon dc) + = dataConImplicitTyThings dc + +implicitConLikeThings (PatSynCon {}) + = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher + -- are not "implicit"; they are simply new top-level bindings, + -- and they have their own declaration in an interface file + -- Unless a record pat syn when there are implicit selectors + -- They are still not included here as `implicitConLikeThings` is + -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked + -- by `tcTopValBinds`. + +implicitClassThings :: Class -> [TyThing] +implicitClassThings cl + = -- Does not include default methods, because those Ids may have + -- their own pragmas, unfoldings etc, not derived from the Class object + + -- associated types + -- No recursive call for the classATs, because they + -- are only the family decls; they have no implicit things + map ATyCon (classATs cl) ++ + + -- superclass and operation selectors + map AnId (classAllSelIds cl) + +implicitTyConThings :: TyCon -> [TyThing] +implicitTyConThings tc + = class_stuff ++ + -- fields (names of selectors) + + -- (possibly) implicit newtype axioms + -- or type family axioms + implicitCoTyCon tc ++ + + -- for each data constructor in order, + -- the constructor and associated implicit 'Id's + datacon_stuff + -- NB. record selectors are *not* implicit, they have fully-fledged + -- bindings that pass through the compilation pipeline as normal. + where + class_stuff = case tyConClass_maybe tc of + Nothing -> [] + Just cl -> implicitClassThings cl + + -- For each data constructor in order, + -- the constructor, worker, and (possibly) wrapper + -- + -- If the data constructor is in a "type data" declaration, + -- promote it to the type level now. + -- See Note [Type data declarations] in GHC.Rename.Module. + datacon_stuff :: [TyThing] + datacon_stuff + | isTypeDataTyCon tc = [ATyCon (promoteDataCon dc) | dc <- cons] + | otherwise + = [ty_thing | dc <- cons, + ty_thing <- AConLike (RealDataCon dc) : + dataConImplicitTyThings dc] + + cons :: [DataCon] + cons = tyConDataCons tc + +-- For newtypes and closed type families (only) add the implicit coercion tycon +implicitCoTyCon :: TyCon -> [TyThing] +implicitCoTyCon tc + | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] + | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc + = [ACoAxiom co] + | otherwise = [] + +-- | Returns @True@ if there should be no interface-file declaration +-- for this thing on its own: either it is built-in, or it is part +-- of some other declaration, or it is generated implicitly by some +-- other declaration. +isImplicitTyThing :: TyThing -> Bool +isImplicitTyThing (AConLike cl) = case cl of + RealDataCon {} -> True + PatSynCon {} -> False +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax + +-- | tyThingParent_maybe x returns (Just p) +-- when pprTyThingInContext should print a declaration for p +-- (albeit with some "..." in it) when asked to show x +-- It returns the *immediate* parent. So a datacon returns its tycon +-- but the tycon could be the associated type of a class, so it in turn +-- might have a parent. +tyThingParent_maybe :: TyThing -> Maybe TyThing +tyThingParent_maybe (AConLike cl) = case cl of + RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) + PatSynCon{} -> Nothing +tyThingParent_maybe (ATyCon tc) + | -- Special case for `type data` data constructors. They appear as an + -- ATyCon (not ADataCon) but we want to display them here as if they were + -- a DataCon (i.e. with the parent declaration) (#22817). + -- See Note [Type data declarations] in GHC.Rename.Module. + Just dc <- isPromotedDataCon_maybe tc + , let parent_tc = dataConTyCon dc + , isTypeDataTyCon parent_tc + = Just (ATyCon parent_tc) + | Just tc <- tyConAssoc_maybe tc + = Just (ATyCon tc) + | otherwise + = Nothing +tyThingParent_maybe (AnId id) = case idDetails id of + RecSelId { sel_tycon = RecSelData tc } -> + Just (ATyCon tc) + RecSelId { sel_tycon = RecSelPatSyn ps } -> + Just (AConLike (PatSynCon ps)) + ClassOpId cls _ -> + Just (ATyCon (classTyCon cls)) + _other -> Nothing +tyThingParent_maybe _other = Nothing + +tyThingsTyCoVars :: [TyThing] -> TyCoVarSet +tyThingsTyCoVars tts = + unionVarSets $ map ttToVarSet tts + where + ttToVarSet (AnId id) = tyCoVarsOfType $ idType id + ttToVarSet (AConLike cl) = case cl of + RealDataCon dc -> tyCoVarsOfType $ dataConRepType dc + PatSynCon{} -> emptyVarSet + ttToVarSet (ATyCon tc) + = case tyConClass_maybe tc of + Just cls -> (mkVarSet . fst . classTvsFds) cls + Nothing -> tyCoVarsOfType $ tyConKind tc + ttToVarSet (ACoAxiom _) = emptyVarSet + +-- | The 'GlobalRdrElt's that a 'TyThing' should bring into scope. +-- Used to build the 'GlobalRdrEnv' for the InteractiveContext. +tyThingLocalGREs :: TyThing -> [GlobalRdrElt] +tyThingLocalGREs ty_thing = + case ty_thing of + ATyCon t + | Just c <- tyConClass_maybe t + -> myself NoParent + : ( map (mkLocalVanillaGRE (ParentIs $ className c) . getName) (classMethods c) + ++ map tc_GRE (classATs c) ) + | otherwise + -> let dcs = tyConDataCons t + par = ParentIs $ tyConName t + mk_nm = DataConName . dataConName + in myself NoParent + : map (dc_GRE par) dcs + ++ + mkLocalFieldGREs par + [ (mk_nm dc, con_info) + | dc <- dcs + , let con_info = conLikeConInfo (RealDataCon dc) ] + AConLike con -> + let (par, cons_flds) = case con of + PatSynCon {} -> + (NoParent, [(conLikeConLikeName con, conLikeConInfo con)]) + -- NB: NoParent for local pattern synonyms, as per + -- Note [Parents] in GHC.Types.Name.Reader. + RealDataCon dc1 -> + (ParentIs $ tyConName $ dataConTyCon dc1 + , [ (DataConName $ dataConName $ dc, ConInfo conInfo (ConHasRecordFields (fld :| flds))) + | dc <- tyConDataCons $ dataConTyCon dc1 + -- Go through all the data constructors of the parent TyCon, + -- to ensure that all the record fields have the correct set + -- of parent data constructors. See #23546. + , let con_info = conLikeConInfo (RealDataCon dc) + , ConInfo conInfo (ConHasRecordFields flds0) <- [con_info] + , let flds1 = NE.toList flds0 `intersect` dataConFieldLabels dc + , fld:flds <- [flds1] + ]) + in myself par : mkLocalFieldGREs par cons_flds + AnId id + | RecSelId { sel_tycon = RecSelData tc } <- idDetails id + -> [ myself (ParentIs $ tyConName tc) ] + -- Fallback to NoParent for PatSyn record selectors, + -- as per Note [Parents] in GHC.Types.Name.Reader. + _ -> [ myself NoParent ] + where + tc_GRE :: TyCon -> GlobalRdrElt + tc_GRE at = mkLocalTyConGRE + (fmap tyConName $ tyConFlavour at) + (tyConName at) + dc_GRE :: Parent -> DataCon -> GlobalRdrElt + dc_GRE par dc = + let con_info = conLikeConInfo (RealDataCon dc) + in mkLocalConLikeGRE par (DataConName $ dataConName dc, con_info) + myself :: Parent -> GlobalRdrElt + myself p = mkLocalGRE (tyThingGREInfo ty_thing) p (getName ty_thing) + +-- | Obtain information pertinent to the renamer about a particular 'TyThing'. +-- +-- This extracts out renamer information from typechecker information. +tyThingGREInfo :: TyThing -> GREInfo +tyThingGREInfo = \case + AConLike con -> IAmConLike $ conLikeConInfo con + AnId id -> case idDetails id of + RecSelId { sel_tycon = parent, sel_fieldLabel = fl } -> + let relevant_cons = case parent of + RecSelPatSyn ps -> unitUniqSet $ PatSynName (patSynName ps) + RecSelData tc -> + let dcs = map RealDataCon $ tyConDataCons tc in + case rsi_def (conLikesRecSelInfo dcs [flLabel fl]) of + [] -> pprPanic "tyThingGREInfo: no DataCons with this FieldLabel" $ + vcat [ text "id:" <+> ppr id + , text "fl:" <+> ppr fl + , text "dcs:" <+> ppr dcs ] + cons -> mkUniqSet $ map conLikeConLikeName cons + in IAmRecField $ + RecFieldInfo + { recFieldLabel = fl + , recFieldCons = relevant_cons } + _ -> Vanilla + ATyCon tc -> + IAmTyCon (fmap tyConName $ tyConFlavour tc) + _ -> Vanilla + +-- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise +tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon +tyThingTyCon (ATyCon tc) = tc +tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) + +-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise +tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched +tyThingCoAxiom (ACoAxiom ax) = ax +tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (ppr other) + +-- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise +tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon +tyThingDataCon (AConLike (RealDataCon dc)) = dc +tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) + +-- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing. +-- Panics otherwise +tyThingConLike :: HasDebugCallStack => TyThing -> ConLike +tyThingConLike (AConLike dc) = dc +tyThingConLike other = pprPanic "tyThingConLike" (ppr other) + +-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise +tyThingId :: HasDebugCallStack => TyThing -> Id +tyThingId (AnId id) = id +tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc +tyThingId other = pprPanic "tyThingId" (ppr other) + +-- | Class that abstracts out the common ability of the monads in GHC +-- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides +-- a number of related convenience functions for accessing particular +-- kinds of 'TyThing' +class Monad m => MonadThings m where + lookupThing :: Name -> m TyThing + + lookupId :: Name -> m Id + lookupId = liftM tyThingId . lookupThing + + lookupDataCon :: Name -> m DataCon + lookupDataCon = liftM tyThingDataCon . lookupThing + + lookupTyCon :: Name -> m TyCon + lookupTyCon = liftM tyThingTyCon . lookupThing + +-- Instance used in GHC.HsToCore.Quote +instance MonadThings m => MonadThings (ReaderT s m) where + lookupThing = lift . lookupThing diff --git a/GHC/Types/TyThing.hs-boot b/GHC/Types/TyThing.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/TyThing.hs-boot @@ -0,0 +1,8 @@ +module GHC.Types.TyThing where + +import {-# SOURCE #-} GHC.Core.TyCon +import {-# SOURCE #-} GHC.Types.Var + +data TyThing +mkATyCon :: TyCon -> TyThing +mkAnId :: Id -> TyThing diff --git a/GHC/Types/TyThing/Ppr.hs b/GHC/Types/TyThing/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/TyThing/Ppr.hs @@ -0,0 +1,204 @@ +----------------------------------------------------------------------------- +-- +-- Pretty-printing TyThings +-- +-- (c) The GHC Team 2005 +-- +----------------------------------------------------------------------------- + + +module GHC.Types.TyThing.Ppr ( + pprTyThing, + pprTyThingInContext, + pprTyThingLoc, + pprTyThingInContextLoc, + pprTyThingHdr, + pprFamInst + ) where + +import GHC.Prelude + +import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe ) +import GHC.Types.Name + +import GHC.Core.Type ( ForAllTyFlag(..), mkTyVarBinders ) +import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) +import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) +import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp ) + +import GHC.Iface.Decl ( tyThingToIfaceDecl ) +import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) + , showToHeader, pprIfaceDecl ) + +import GHC.Utils.Outputable + +import Data.Maybe ( isJust ) + +-- ----------------------------------------------------------------------------- +-- Pretty-printing entities that we get from the GHC API + +{- Note [Pretty printing via Iface syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our general plan for pretty-printing + - Types + - TyCons + - Classes + - Pattern synonyms + ...etc... + +is to convert them to Iface syntax, and pretty-print that. For example + - pprType converts a Type to an IfaceType, and pretty prints that. + - pprTyThing converts the TyThing to an IfaceDecl, + and pretty prints that. + +So Iface syntax plays a dual role: + - it's the internal version of an interface files + - it's used for pretty-printing + +Why do this? + +* A significant reason is that we need to be able + to pretty-print Iface syntax (to display Foo.hi), and it was a + pain to duplicate masses of pretty-printing goop, esp for + Type and IfaceType. + +* When pretty-printing (a type, say), we want to tidy (with + tidyType) to avoids having (forall a a. blah) where the two + a's have different uniques. + + Alas, for type constructors, TyCon, tidying does not work well, + because a TyCon includes DataCons which include Types, which mention + TyCons. And tidying can't tidy a mutually recursive data structure + graph, only trees. + +* Interface files contains fast-strings, not uniques, so the very same + tidying must take place when we convert to IfaceDecl. E.g. + GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon, + Class etc) to an IfaceDecl. + + Bottom line: IfaceDecls are already 'tidy', so it's straightforward + to print them. + +* An alternative I once explored was to ensure that TyCons get type + variables with distinct print-names. That's ok for type variables + but less easy for kind variables. Processing data type declarations + is already so complicated that I don't think it's sensible to add + the extra requirement that it generates only "pretty" types and + kinds. + +Consequences: + +- Iface syntax (and IfaceType) must contain enough information to + print nicely. Hence, for example, the IfaceAppArgs type, which + allows us to suppress invisible kind arguments in types + (see Note [Suppressing invisible arguments] in GHC.Iface.Type) + +- In a few places we have info that is used only for pretty-printing, + and is totally ignored when turning Iface syntax back into Core + (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon + stores a [IfaceAxBranch] that is used only for pretty-printing. + +- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type + +See #7730, #8776 for details -} + +-------------------- +-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location. +pprFamInst :: FamInst -> SDoc +-- * For data instances we go via pprTyThing of the representational TyCon, +-- because there is already much cleverness associated with printing +-- data type declarations that I don't want to duplicate +-- * For type instances we print directly here; there is no TyCon +-- to give to pprTyThing +-- +-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes + +pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc }) + = pprTyThingInContextLoc (ATyCon rep_tc) + +pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom + , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs }) + = showWithLoc (pprDefinedAt (getName axiom)) $ + hang (text "type instance" + <+> pprUserForAll (mkTyVarBinders Specified tvs) + -- See Note [Printing foralls in type family instances] + -- in GHC.Iface.Type + <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) + 2 (equals <+> ppr rhs) + +---------------------------- +-- | Pretty-prints a 'TyThing' with its defining location. +pprTyThingLoc :: TyThing -> SDoc +pprTyThingLoc tyThing + = showWithLoc (pprDefinedAt (getName tyThing)) + (pprTyThing showToHeader tyThing) + +-- | Pretty-prints the 'TyThing' header. For functions and data constructors +-- the function is equivalent to 'pprTyThing' but for type constructors +-- and classes it prints only the header part of the declaration. +pprTyThingHdr :: TyThing -> SDoc +pprTyThingHdr = pprTyThing showToHeader + +-- | Pretty-prints a 'TyThing' in context: that is, if the entity +-- is a data constructor, record selector, or class method, then +-- the entity's parent declaration is pretty-printed with irrelevant +-- parts omitted. +pprTyThingInContext :: ShowSub -> TyThing -> SDoc +pprTyThingInContext show_sub thing + = case parents thing of + -- If there are no parents print everything. + [] -> print_it Nothing thing + -- If `thing` has a parent, print the parent and only its child `thing` + thing':rest -> let subs = map getOccName (thing:rest) + filt = (`elem` subs) + in print_it (Just filt) thing' + where + parents = go + where + go thing = + case tyThingParent_maybe thing of + Just parent -> parent : go parent + Nothing -> [] + + print_it :: Maybe (OccName -> Bool) -> TyThing -> SDoc + print_it mb_filt thing = + pprTyThing (show_sub { ss_how_much = ShowSome mb_filt (AltPpr Nothing) }) thing + +-- | Like 'pprTyThingInContext', but adds the defining location. +pprTyThingInContextLoc :: TyThing -> SDoc +pprTyThingInContextLoc tyThing + = showWithLoc (pprDefinedAt (getName tyThing)) + (pprTyThingInContext showToHeader tyThing) + +-- | Pretty-prints a 'TyThing'. +pprTyThing :: ShowSub -> TyThing -> SDoc +-- We pretty-print 'TyThing' via 'IfaceDecl' +-- See Note [Pretty printing via Iface syntax] +pprTyThing ss ty_thing + = sdocOption sdocLinearTypes $ \show_linear_types -> + pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing) + where + ss' = case ss_how_much ss of + ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' } + ShowSome filt (AltPpr Nothing) -> ss { ss_how_much = ShowSome filt ppr' } + _ -> ss + + ppr' = AltPpr $ ppr_bndr $ getName ty_thing + + ppr_bndr :: Name -> Maybe (OccName -> SDoc) + ppr_bndr name + | isBuiltInSyntax name || isJust (namePun_maybe name) + = Nothing + | otherwise + = case nameModule_maybe name of + Just mod -> Just $ \occ -> getPprStyle $ \sty -> + pprModulePrefix sty mod Nothing occ <> ppr occ + Nothing -> warnPprTrace True "pprTyThing" (ppr name) Nothing + -- Nothing is unexpected here; TyThings have External names + +showWithLoc :: SDoc -> SDoc -> SDoc +showWithLoc loc doc + = hang doc 2 (char '\t' <> comment <+> loc) + -- The tab tries to make them line up a bit + where + comment = text "--" diff --git a/GHC/Types/TyThing/Ppr.hs-boot b/GHC/Types/TyThing/Ppr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/TyThing/Ppr.hs-boot @@ -0,0 +1,11 @@ +module GHC.Types.TyThing.Ppr ( + pprTyThing, + pprTyThingInContext + ) where + +import GHC.Iface.Type ( ShowSub ) +import GHC.Types.TyThing ( TyThing ) +import GHC.Utils.Outputable ( SDoc ) + +pprTyThing :: ShowSub -> TyThing -> SDoc +pprTyThingInContext :: ShowSub -> TyThing -> SDoc diff --git a/GHC/Types/TypeEnv.hs b/GHC/Types/TypeEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/TypeEnv.hs @@ -0,0 +1,95 @@ +module GHC.Types.TypeEnv + ( TypeEnv + , emptyTypeEnv + , lookupTypeEnv + , mkTypeEnv + , typeEnvFromEntities + , mkTypeEnvWithImplicits + , extendTypeEnv + , extendTypeEnvList + , extendTypeEnvWithIds + , plusTypeEnv + , typeEnvElts + , typeEnvTyCons + , typeEnvIds + , typeEnvPatSyns + , typeEnvDataCons + , typeEnvCoAxioms + , typeEnvClasses + ) +where + +import GHC.Prelude + +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.FamInstEnv +import GHC.Core.PatSyn +import GHC.Core.TyCon + +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var +import GHC.Types.TyThing + +-- | A map from 'Name's to 'TyThing's, constructed by typechecking +-- local declarations or interface files +type TypeEnv = NameEnv TyThing + +emptyTypeEnv :: TypeEnv +typeEnvElts :: TypeEnv -> [TyThing] +typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched] +typeEnvIds :: TypeEnv -> [Id] +typeEnvPatSyns :: TypeEnv -> [PatSyn] +typeEnvDataCons :: TypeEnv -> [DataCon] +typeEnvClasses :: TypeEnv -> [Class] +lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing + +emptyTypeEnv = emptyNameEnv +typeEnvElts env = nonDetNameEnvElts env +typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] +typeEnvIds env = [id | AnId id <- typeEnvElts env] +typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env] +typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env] +typeEnvClasses env = [cl | tc <- typeEnvTyCons env, + Just cl <- [tyConClass_maybe tc]] + +mkTypeEnv :: [TyThing] -> TypeEnv +mkTypeEnv things = extendTypeEnvList emptyTypeEnv things + +mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv +mkTypeEnvWithImplicits things = + mkTypeEnv things + `plusNameEnv` + mkTypeEnv (concatMap implicitTyThings things) + +typeEnvFromEntities :: [Id] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv +typeEnvFromEntities ids tcs patsyns famInsts = + mkTypeEnv ( map AnId ids + ++ map ATyCon all_tcs + ++ concatMap implicitTyConThings all_tcs + ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts + ++ map (AConLike . PatSynCon) patsyns + ) + where + all_tcs = tcs ++ famInstsRepTyCons famInsts + +lookupTypeEnv = lookupNameEnv + +-- Extend the type environment +extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv +extendTypeEnv env thing = extendNameEnv env (getName thing) thing + +extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv +extendTypeEnvList env things = foldl' extendTypeEnv env things + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] + +plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv +plusTypeEnv env1 env2 = plusNameEnv env1 env2 diff --git a/GHC/Types/Unique.hs b/GHC/Types/Unique.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique.hs @@ -0,0 +1,356 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +@Uniques@ are used to distinguish entities in the compiler (@Ids@, +@Classes@, etc.) from each other. Thus, @Uniques@ are the basic +comparison key in the compiler. + +If there is any single operation that needs to be fast, it is @Unique@ + +comparison. Unsurprisingly, there is quite a bit of huff-and-puff +directed to that end. + +Some of the other hair in this code is to be able to use a +``splittable @UniqueSupply@'' if requested/possible (not standard +Haskell). +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module GHC.Types.Unique ( + -- * Main data types + Unique, Uniquable(..), + uNIQUE_BITS, + + -- ** Constructors, destructors and operations on 'Unique's + hasKey, + + pprUniqueAlways, + + mkTag, + mkUniqueGrimily, + mkUniqueIntGrimily, + getKey, + mkUnique, unpkUnique, + mkUniqueInt, + eqUnique, ltUnique, + incrUnique, stepUnique, + + newTagUnique, + nonDetCmpUnique, + isValidKnownKeyUnique, + + -- ** Local uniques + -- | These are exposed exclusively for use by 'GHC.Types.Var.Env.uniqAway', which + -- has rather peculiar needs. See Note [Local uniques]. + mkLocalUnique, minLocalUnique, maxLocalUnique, + ) where + +#include "Unique.h" + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Word64 (intToWord64, word64ToInt) + +-- just for implementing a fast [0,61) -> Char function +import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) + +import GHC.Word ( Word64 ) +import Data.Char ( chr, ord ) + +import Language.Haskell.Syntax.Module.Name + +{- +************************************************************************ +* * +\subsection[Unique-type]{@Unique@ type and operations} +* * +************************************************************************ + +Note [Uniques and tags] +~~~~~~~~~~~~~~~~~~~~~~~~ +A `Unique` in GHC is a 64 bit value composed of two pieces: +* A "tag", of width `UNIQUE_TAG_BITS`, in the high order bits +* A number, of width `uNIQUE_BITS`, which fills up the remainder of the Word64 + +The tag is typically an ASCII character. It is typically used to make it easier +to distinguish uniques constructed by different parts of the compiler. +There is a (potentially incomplete) list of unique tags used given in +GHC.Builtin.Uniques. See Note [Uniques for wired-in prelude things and known tags] + +`mkUnique` constructs a `Unique` from its pieces + mkUnique :: Char -> Word64 -> Unique + +-} + +-- | Unique identifier. +-- +-- The type of unique identifiers that are used in many places in GHC +-- for fast ordering and equality tests. You should generate these with +-- the functions from the 'UniqSupply' module +-- +-- These are sometimes also referred to as \"keys\" in comments in GHC. +newtype Unique = MkUnique Word64 + +{-# INLINE uNIQUE_BITS #-} +uNIQUE_BITS :: Int +uNIQUE_BITS = 64 - UNIQUE_TAG_BITS + +{- +Now come the functions which construct uniques from their pieces, and vice versa. +The stuff about unique *supplies* is handled further down this module. +-} + +unpkUnique :: Unique -> (Char, Word64) -- The reverse + +mkUniqueGrimily :: Word64 -> Unique -- A trap-door for UniqSupply +getKey :: Unique -> Word64 -- for Var + +incrUnique :: Unique -> Unique +stepUnique :: Unique -> Word64 -> Unique +newTagUnique :: Unique -> Char -> Unique + +mkUniqueGrimily = MkUnique + +{-# INLINE getKey #-} +getKey (MkUnique x) = x + +incrUnique (MkUnique i) = MkUnique (i + 1) +stepUnique (MkUnique i) n = MkUnique (i + n) + +mkLocalUnique :: Word64 -> Unique +mkLocalUnique i = mkUnique 'X' i + +minLocalUnique :: Unique +minLocalUnique = mkLocalUnique 0 + +maxLocalUnique :: Unique +maxLocalUnique = mkLocalUnique uniqueMask + +-- newTagUnique changes the "domain" of a unique to a different char +newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u + +-- | Bitmask that has zeros for the tag bits and ones for the rest. +uniqueMask :: Word64 +uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1 + +-- | Put the character in the highest bits of the Word64. +-- This may truncate the character to UNIQUE_TAG_BITS. +-- This function is used in @`mkSplitUniqSupply`@ so that it can +-- precompute and share the tag part of the uniques it generates. +mkTag :: Char -> Word64 +mkTag c = intToWord64 (ord c) `shiftL` uNIQUE_BITS + +-- pop the Char in the top 8 bits of the Unique(Supply) + +-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM + +-- and as long as the Char fits in 8 bits, which we assume anyway! + +mkUnique :: Char -> Word64 -> Unique -- Builds a unique from pieces +-- EXPORTED and used only in GHC.Builtin.Uniques +mkUnique c i + = MkUnique (tag .|. bits) + where + tag = mkTag c + bits = i .&. uniqueMask + +mkUniqueInt :: Char -> Int -> Unique +mkUniqueInt c i = mkUnique c (intToWord64 i) + +mkUniqueIntGrimily :: Int -> Unique +mkUniqueIntGrimily = MkUnique . intToWord64 + +unpkUnique (MkUnique u) + = let + -- The potentially truncating use of fromIntegral here is safe + -- because the argument is just the tag bits after shifting. + tag = chr (word64ToInt (u `shiftR` uNIQUE_BITS)) + i = u .&. uniqueMask + in + (tag, i) + +-- | The interface file symbol-table encoding assumes that known-key uniques fit +-- in 30-bits; verify this. +-- +-- See Note [Symbol table representation of names] in "GHC.Iface.Binary" for details. +isValidKnownKeyUnique :: Unique -> Bool +isValidKnownKeyUnique u = + case unpkUnique u of + (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) + +{- +************************************************************************ +* * +\subsection[Uniquable-class]{The @Uniquable@ class} +* * +************************************************************************ +-} + +-- | Class of things that we can obtain a 'Unique' from +class Uniquable a where + getUnique :: a -> Unique + +hasKey :: Uniquable a => a -> Unique -> Bool +x `hasKey` k = getUnique x == k + +instance Uniquable FastString where + getUnique fs = mkUniqueIntGrimily (uniqueOfFS fs) + +instance Uniquable Int where + getUnique i = mkUniqueIntGrimily i + +instance Uniquable Word64 where + getUnique i = mkUniqueGrimily i + +instance Uniquable ModuleName where + getUnique (ModuleName nm) = getUnique nm + + +{- +************************************************************************ +* * +\subsection[Unique-instances]{Instance declarations for @Unique@} +* * +************************************************************************ + +And the whole point (besides uniqueness) is fast equality. We don't +use `deriving' because we want {\em precise} control of ordering +(equality on @Uniques@ is v common). +-} + +-- Note [Unique Determinism] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The order of allocated @Uniques@ is not stable across rebuilds. +-- The main reason for that is that typechecking interface files pulls +-- @Uniques@ from @UniqSupply@ and the interface file for the module being +-- currently compiled can, but doesn't have to exist. +-- +-- It gets more complicated if you take into account that the interface +-- files are loaded lazily and that building multiple files at once has to +-- work for any subset of interface files present. When you add parallelism +-- this makes @Uniques@ hopelessly random. +-- +-- As such, to get deterministic builds, the order of the allocated +-- @Uniques@ should not affect the final result. +-- see also wiki/deterministic-builds +-- +-- Note [Unique Determinism and code generation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The goal of the deterministic builds (wiki/deterministic-builds, #4012) +-- is to get ABI compatible binaries given the same inputs and environment. +-- The motivation behind that is that if the ABI doesn't change the +-- binaries can be safely reused. +-- +-- Besides ABI/interface determinism, we also guarantee bit-for-bit identical +-- binaries (when -fobject-determinism is given), also known as object +-- determinism (#12935) +-- +-- To achieve this, we must take care to non-determinism in the code +-- generation, and, in particular, guarantee that the existing uniques are +-- renamed deterministically and new ones are produced deterministically too. +-- The overview of object determinism is given by Note [Object determinism]. +-- References to this note identify code where the unique determinism may +-- impact object determinism more specifically. + +eqUnique :: Unique -> Unique -> Bool +eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 + +ltUnique :: Unique -> Unique -> Bool +ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2 + +-- Provided here to make it explicit at the call-site that it can +-- introduce non-determinism. +-- See Note [Unique Determinism] +-- See Note [No Ord for Unique] +nonDetCmpUnique :: Unique -> Unique -> Ordering +nonDetCmpUnique (MkUnique u1) (MkUnique u2) + = if u1 == u2 then EQ else if u1 < u2 then LT else GT + +{- +Note [No Ord for Unique] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [Unique Determinism] the relative order of Uniques +is nondeterministic. To prevent from accidental use the Ord Unique +instance has been removed. +This makes it easier to maintain deterministic builds, but comes with some +drawbacks. +The biggest drawback is that Maps keyed by Uniques can't directly be used. +The alternatives are: + + 1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which + 2) Create a newtype wrapper based on Unique ordering where nondeterminism + is controlled. See GHC.Unit.Module.Env.ModuleEnv + 3) Change the algorithm to use nonDetCmpUnique and document why it's still + deterministic + 4) Use TrieMap as done in GHC.Cmm.CommonBlockElim.groupByLabel +-} + +instance Eq Unique where + a == b = eqUnique a b + a /= b = not (eqUnique a b) + +instance Uniquable Unique where + getUnique u = u + +-- We do sometimes make strings with @Uniques@ in them: + +showUnique :: Unique -> String +showUnique uniq + = tagStr ++ w64ToBase62 u + where + (tag, u) = unpkUnique uniq + -- Avoid emitting non-printable characters in pretty uniques. + -- See #25989. + tagStr + | tag < 'A' || tag > 'z' = show (ord tag) ++ "_" + | otherwise = [tag] + +pprUniqueAlways :: IsLine doc => Unique -> doc +-- The "always" means regardless of -dsuppress-uniques +-- It replaces the old pprUnique to remind callers that +-- they should consider whether they want to consult +-- Opt_SuppressUniques +pprUniqueAlways u + = text (showUnique u) +{-# SPECIALIZE pprUniqueAlways :: Unique -> SDoc #-} +{-# SPECIALIZE pprUniqueAlways :: Unique -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +instance Outputable Unique where + ppr = pprUniqueAlways + +instance Show Unique where + show uniq = showUnique uniq + +{- +************************************************************************ +* * +\subsection[Utils-base62]{Base-62 numbers} +* * +************************************************************************ + +A character-stingy way to read/write numbers (notably Uniques). +The ``62-its'' are \tr{[0-9a-zA-Z]}. +Code stolen from Lennart. +-} + +w64ToBase62 :: Word64 -> String +w64ToBase62 n_ = go n_ "" + where + -- The potentially truncating uses of fromIntegral here are safe + -- because the argument is guaranteed to be less than 62 in both cases. + go n cs | n < 62 + = let !c = chooseChar62 (word64ToInt n) in c : cs + | otherwise + = go q (c : cs) where (!q, r) = quotRem n 62 + !c = chooseChar62 (word64ToInt r) + + chooseChar62 :: Int -> Char + {-# INLINE chooseChar62 #-} + chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n) + chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# diff --git a/GHC/Types/Unique/DFM.hs b/GHC/Types/Unique/DFM.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/DFM.hs @@ -0,0 +1,509 @@ +{- +(c) Bartosz Nitka, Facebook, 2015 + +UniqDFM: Specialised deterministic finite maps, for things with @Uniques@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +This is very similar to @UniqFM@, the major difference being that the order of +folding is not dependent on @Unique@ ordering, giving determinism. +Currently the ordering is determined by insertion order. + +See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ ordering +is not deterministic. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wall #-} + +module GHC.Types.Unique.DFM ( + -- * Unique-keyed deterministic mappings + UniqDFM, -- abstract type + + -- ** Manipulating those mappings + emptyUDFM, + unitUDFM, + addToUDFM, + addToUDFM_C, + addToUDFM_C_Directly, + addToUDFM_Directly, + addListToUDFM, + delFromUDFM, + delListFromUDFM, + adjustUDFM, + adjustUDFM_Directly, + alterUDFM, + mapUDFM, + mapMaybeUDFM, + mapMUDFM, + plusUDFM, + plusUDFM_C, plusUDFM_CK, + lookupUDFM, lookupUDFM_Directly, + elemUDFM, + foldUDFM, foldWithKeyUDFM, + eltsUDFM, + filterUDFM, filterUDFM_Directly, + isNullUDFM, + sizeUDFM, + intersectUDFM, udfmIntersectUFM, + disjointUDFM, disjointUdfmUfm, + equalKeysUDFM, + minusUDFM, + listToUDFM, listToUDFM_Directly, + listToUDFM_C_Directly, + udfmMinusUFM, ufmMinusUDFM, + partitionUDFM, + udfmRestrictKeys, + udfmRestrictKeysSet, + anyUDFM, allUDFM, + pprUniqDFM, pprUDFM, + + udfmToList, + udfmToUfm, + nonDetStrictFoldUDFM, + unsafeCastUDFMKey, + alwaysUnsafeUfmToUdfm, + ) where + +import GHC.Prelude + +import GHC.Types.Unique ( Uniquable(..), Unique, getKey, mkUniqueGrimily ) +import GHC.Utils.Outputable + +import qualified GHC.Data.Word64Map.Strict as MS +import qualified GHC.Data.Word64Map as M +import Data.Data +import Data.Functor.Classes (Eq1 (..)) +import Data.List (sortBy) +import Data.Function (on) +import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM) +import Unsafe.Coerce +import qualified GHC.Data.Word64Set as W + +-- Note [Deterministic UniqFM] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A @UniqDFM@ is just like @UniqFM@ with the following additional +-- property: the function `udfmToList` returns the elements in some +-- deterministic order not depending on the Unique key for those elements. +-- +-- If the client of the map performs operations on the map in deterministic +-- order then `udfmToList` returns them in deterministic order. +-- +-- There is an implementation cost: each element is given a serial number +-- as it is added, and `udfmToList` sorts its result by this serial +-- number. So you should only use `UniqDFM` if you need the deterministic +-- property. +-- +-- `foldUDFM` also preserves determinism. +-- +-- Normal @UniqFM@ when you turn it into a list will use +-- Data.IntMap.toList function that returns the elements in the order of +-- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with +-- with a list ordered by @Uniques@. +-- The order of @Uniques@ is known to be not stable across rebuilds. +-- See Note [Unique Determinism] in GHC.Types.Unique. +-- +-- +-- There's more than one way to implement this. The implementation here tags +-- every value with the insertion time that can later be used to sort the +-- values when asked to convert to a list. +-- +-- An alternative would be to have +-- +-- data UniqDFM ele = UDFM (M.IntMap ele) [ele] +-- +-- where the list determines the order. This makes deletion tricky as we'd +-- only accumulate elements in that list, but makes merging easier as you +-- can just merge both structures independently. +-- Deletion can probably be done in amortized fashion when the size of the +-- list is twice the size of the set. + +-- | A type of values tagged with insertion time +data TaggedVal val = + TaggedVal + !val + {-# UNPACK #-} !Int -- ^ insertion time + deriving stock (Data, Functor, Foldable, Traversable) + +taggedFst :: TaggedVal val -> val +taggedFst (TaggedVal v _) = v + +taggedSnd :: TaggedVal val -> Int +taggedSnd (TaggedVal _ i) = i + +instance Eq val => Eq (TaggedVal val) where + (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2 + +-- | Type of unique deterministic finite maps +-- +-- The key is just here to keep us honest. It's always safe +-- to use a single type as key. +-- If two types don't overlap in their uniques it's also safe +-- to index the same map at multiple key types. But this is +-- very much discouraged. +data UniqDFM key ele = + UDFM + !(M.Word64Map (TaggedVal ele)) -- A map where keys are Unique's values and + -- values are tagged with insertion time. + -- The invariant is that all the tags will + -- be distinct within a single map + {-# UNPACK #-} !Int -- Upper bound on the values' insertion + -- time. See Note [Overflow on plusUDFM] + deriving (Data, Functor) + +-- | Deterministic, in O(n log n). +instance Foldable (UniqDFM key) where + foldr = foldUDFM + +-- | Deterministic, in O(n log n). +instance Traversable (UniqDFM key) where + traverse f = fmap listToUDFM_Directly + . traverse (\(u,a) -> (u,) <$> f a) + . udfmToList + +emptyUDFM :: UniqDFM key elt +emptyUDFM = UDFM M.empty 0 + +unitUDFM :: Uniquable key => key -> elt -> UniqDFM key elt +unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1 + +-- The new binding always goes to the right of existing ones +addToUDFM :: Uniquable key => UniqDFM key elt -> key -> elt -> UniqDFM key elt +addToUDFM m k v = addToUDFM_Directly m (getUnique k) v + +-- The new binding always goes to the right of existing ones +addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt +addToUDFM_Directly (UDFM m i) u v + = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + where + tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i + -- Keep the old tag, but insert the new value + -- This means that udfmToList typically returns elements + -- in the order of insertion, rather than the reverse + + -- It is quite critical that the strict insertWith is used as otherwise + -- the combination function 'tf' is not forced and both old values are retained + -- in the map. + +addToUDFM_C_Directly + :: (elt -> elt -> elt) -- old -> new -> result + -> UniqDFM key elt + -> Unique -> elt + -> UniqDFM key elt +addToUDFM_C_Directly f (UDFM m i) u v + = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + where + tf (TaggedVal new_v _) (TaggedVal old_v old_i) + = TaggedVal (f old_v new_v) old_i + -- Flip the arguments, because M.insertWith uses (new->old->result) + -- but f needs (old->new->result) + -- Like addToUDFM_Directly, keep the old tag + +addToUDFM_C + :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result + -> UniqDFM key elt -- old + -> key -> elt -- new + -> UniqDFM key elt -- result +addToUDFM_C f m k v = addToUDFM_C_Directly f m (getUnique k) v + +addListToUDFM :: Uniquable key => UniqDFM key elt -> [(key,elt)] -> UniqDFM key elt +addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) +{-# INLINEABLE addListToUDFM #-} + +addListToUDFM_Directly :: UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt +addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v) +{-# INLINEABLE addListToUDFM_Directly #-} + +addListToUDFM_Directly_C + :: (elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt +addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_C_Directly f m k v) +{-# INLINEABLE addListToUDFM_Directly_C #-} + +-- | Like 'addListToUDFM_Directly_C' but also passes the unique key to the combine function +addListToUDFM_Directly_CK + :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt +addListToUDFM_Directly_CK f = foldl' (\m (k, v) -> addToUDFM_C_Directly (f k) m k v) +{-# INLINEABLE addListToUDFM_Directly_CK #-} + +delFromUDFM :: Uniquable key => UniqDFM key elt -> key -> UniqDFM key elt +delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i + +plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft_C f udfml udfmr + | otherwise = insertUDFMIntoLeft_C f udfmr udfml + +-- | Like 'plusUDFM_C' but the combine function also receives the unique key +plusUDFM_CK :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +plusUDFM_CK f udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft_CK f udfml udfmr + | otherwise = insertUDFMIntoLeft_CK f udfmr udfml + + +-- Note [Overflow on plusUDFM] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- There are multiple ways of implementing plusUDFM. +-- The main problem that needs to be solved is overlap on times of +-- insertion between different keys in two maps. +-- Consider: +-- +-- A = fromList [(a, (x, 1))] +-- B = fromList [(b, (y, 1))] +-- +-- If you merge them naively you end up with: +-- +-- C = fromList [(a, (x, 1)), (b, (y, 1))] +-- +-- Which loses information about ordering and brings us back into +-- non-deterministic world. +-- +-- The solution I considered before would increment the tags on one of the +-- sets by the upper bound of the other set. The problem with this approach +-- is that you'll run out of tags for some merge patterns. +-- Say you start with A with upper bound 1, you merge A with A to get A' and +-- the upper bound becomes 2. You merge A' with A' and the upper bound +-- doubles again. After 64 merges you overflow. +-- This solution would have the same time complexity as plusUFM, namely O(n+m). +-- +-- The solution I ended up with has time complexity of +-- O(m log m + m * min (n+m, W)) where m is the smaller set. +-- It simply inserts the elements of the smaller set into the larger +-- set in the order that they were inserted into the smaller set. That's +-- O(m log m) for extracting the elements from the smaller set in the +-- insertion order and O(m * min(n+m, W)) to insert them into the bigger +-- set. + +plusUDFM :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft udfml udfmr + | otherwise = insertUDFMIntoLeft udfmr udfml + +insertUDFMIntoLeft :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr + +insertUDFMIntoLeft_C + :: (elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +insertUDFMIntoLeft_C f udfml udfmr = + addListToUDFM_Directly_C f udfml $ udfmToList udfmr + +-- | Like 'insertUDFMIntoLeft_C', but the merge function also receives the unique key +insertUDFMIntoLeft_CK + :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +insertUDFMIntoLeft_CK f udfml udfmr = + addListToUDFM_Directly_CK f udfml $ udfmToList udfmr + +lookupUDFM :: Uniquable key => UniqDFM key elt -> key -> Maybe elt +lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m + +lookupUDFM_Directly :: UniqDFM key elt -> Unique -> Maybe elt +lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m + +elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool +elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m + +-- | Performs a deterministic fold over the UniqDFM. +-- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a +{-# INLINE foldUDFM #-} +-- This INLINE prevents a regression in !10568 +foldUDFM k z m = foldr k z (eltsUDFM m) + +-- | Like 'foldUDFM' but the function also receives a key +foldWithKeyUDFM :: (Unique -> elt -> a -> a) -> a -> UniqDFM key elt -> a +{-# INLINE foldWithKeyUDFM #-} +-- This INLINE was copied from foldUDFM +foldWithKeyUDFM k z m = foldr (uncurry k) z (udfmToList m) + +-- | Performs a nondeterministic strict fold over the UniqDFM. +-- It's O(n), same as the corresponding function on `UniqFM`. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a +nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m + where + k' acc (TaggedVal v _) = k v acc + +eltsUDFM :: UniqDFM key elt -> [elt] +{-# INLINE eltsUDFM #-} +-- The INLINE makes it a good producer (from the map) +eltsUDFM (UDFM m _i) = map taggedFst (sort_it m) + +sort_it :: M.Word64Map (TaggedVal elt) -> [TaggedVal elt] +sort_it m = sortBy (compare `on` taggedSnd) (M.elems m) + +filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt +filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i + +filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt +filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i + where + p' k (TaggedVal v _) = p (mkUniqueGrimily k) v + +udfmRestrictKeys :: UniqDFM key elt -> UniqDFM key elt2 -> UniqDFM key elt +udfmRestrictKeys (UDFM a i) (UDFM b _) = UDFM (M.restrictKeys a (M.keysSet b)) i + +udfmRestrictKeysSet :: UniqDFM key elt -> W.Word64Set -> UniqDFM key elt +udfmRestrictKeysSet (UDFM val_set i) set = + let key_set = set + in UDFM (M.restrictKeys val_set key_set) i + +-- | Converts `UniqDFM` to a list, with elements in deterministic order. +-- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +udfmToList :: UniqDFM key elt -> [(Unique, elt)] +udfmToList (UDFM m _i) = + [ (mkUniqueGrimily k, taggedFst v) + | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] + +-- Determines whether two 'UniqDFM's contain the same keys. +equalKeysUDFM :: UniqDFM key a -> UniqDFM key b -> Bool +equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2 + +isNullUDFM :: UniqDFM key elt -> Bool +isNullUDFM (UDFM m _) = M.null m + +sizeUDFM :: UniqDFM key elt -> Int +sizeUDFM (UDFM m _i) = M.size m + +intersectUDFM :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i + -- M.intersection is left biased, that means the result will only have + -- a subset of elements from the left set, so `i` is a good upper bound. + +udfmIntersectUFM :: UniqDFM key elt1 -> UniqFM key elt2 -> UniqDFM key elt1 +udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i + -- M.intersection is left biased, that means the result will only have + -- a subset of elements from the left set, so `i` is a good upper bound. + +disjointUDFM :: UniqDFM key elt -> UniqDFM key elt -> Bool +disjointUDFM (UDFM x _i) (UDFM y _j) = M.disjoint x y + +disjointUdfmUfm :: UniqDFM key elt -> UniqFM key elt2 -> Bool +disjointUdfmUfm (UDFM x _i) y = M.disjoint x (ufmToIntMap y) + +minusUDFM :: UniqDFM key elt1 -> UniqDFM key elt2 -> UniqDFM key elt1 +minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i + -- M.difference returns a subset of a left set, so `i` is a good upper + -- bound. + +udfmMinusUFM :: UniqDFM key elt1 -> UniqFM key elt2 -> UniqDFM key elt1 +udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i + -- M.difference returns a subset of a left set, so `i` is a good upper + -- bound. + +ufmMinusUDFM :: UniqFM key elt1 -> UniqDFM key elt2 -> UniqFM key elt1 +ufmMinusUDFM x (UDFM y _i) = unsafeIntMapToUFM (M.difference (ufmToIntMap x) y) + +-- | Partition UniqDFM into two UniqDFMs according to the predicate +partitionUDFM :: (elt -> Bool) -> UniqDFM key elt -> (UniqDFM key elt, UniqDFM key elt) +partitionUDFM p (UDFM m i) = + case M.partition (p . taggedFst) m of + (left, right) -> (UDFM left i, UDFM right i) + +-- | Delete a list of elements from a UniqDFM +delListFromUDFM :: Uniquable key => UniqDFM key elt -> [key] -> UniqDFM key elt +delListFromUDFM = foldl' delFromUDFM + +-- | This allows for lossy conversion from UniqDFM to UniqFM +udfmToUfm :: UniqDFM key elt -> UniqFM key elt +udfmToUfm (UDFM m _i) = unsafeIntMapToUFM (M.map taggedFst m) + +listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM key elt +listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM + +listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM key elt +listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM + +listToUDFM_C_Directly :: (elt -> elt -> elt) -> [(Unique, elt)] -> UniqDFM key elt +listToUDFM_C_Directly f = foldl' (\m (u, v) -> addToUDFM_C_Directly f m u v) emptyUDFM + +-- | Apply a function to a particular element +adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM key elt -> key -> UniqDFM key elt +adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i + +-- | Apply a function to a particular element +adjustUDFM_Directly :: (elt -> elt) -> UniqDFM key elt -> Unique -> UniqDFM key elt +adjustUDFM_Directly f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey k) m) i + +-- | The expression (alterUDFM f k map) alters value x at k, or absence +-- thereof. alterUDFM can be used to insert, delete, or update a value in +-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are +-- more efficient. +alterUDFM + :: Uniquable key + => (Maybe elt -> Maybe elt) -- How to adjust + -> UniqDFM key elt -- old + -> key -- new + -> UniqDFM key elt -- result +alterUDFM f (UDFM m i) k = + UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) + where + alterf Nothing = inject $ f Nothing + alterf (Just (TaggedVal v _)) = inject $ f (Just v) + inject Nothing = Nothing + inject (Just v) = Just $ TaggedVal v i + +-- | Map a function over every value in a UniqDFM +mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 +mapUDFM f (UDFM m i) = UDFM (MS.map (fmap f) m) i +-- Critical this is strict map, otherwise you get a big space leak when reloading +-- in GHCi because all old ModDetails are retained (see pruneHomePackageTable). +-- Modify with care. + +{-# INLINEABLE mapMUDFM #-} +-- | 'mapM' for a 'UniqDFM'. +mapMUDFM :: Monad m => (elt1 -> m elt2) -> UniqDFM key elt1 -> m (UniqDFM key elt2) +mapMUDFM f (UDFM m i) = do + m' <- traverse (traverse f) m + return $ UDFM m' i + +mapMaybeUDFM :: forall elt1 elt2 key. + (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 +mapMaybeUDFM f (UDFM m i) = UDFM (M.mapMaybe (traverse f) m) i + +anyUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool +anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m + +allUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool +allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m + +-- This should not be used in committed code, provided for convenience to +-- make ad-hoc conversions when developing +alwaysUnsafeUfmToUdfm :: UniqFM key elt -> UniqDFM key elt +alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList + +-- | Cast the key domain of a UniqFM. +-- +-- As long as the domains don't overlap in their uniques +-- this is safe. +unsafeCastUDFMKey :: UniqDFM key1 elt -> UniqDFM key2 elt +unsafeCastUDFMKey = unsafeCoerce -- Only phantom parameter changes so + -- this is safe and avoids reallocation. + +-- Output-ery + +instance Outputable a => Outputable (UniqDFM key a) where + ppr ufm = pprUniqDFM ppr ufm + +pprUniqDFM :: (a -> SDoc) -> UniqDFM key a -> SDoc +pprUniqDFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elt) <- udfmToList ufm ] + +pprUDFM :: UniqDFM key a -- ^ The things to be pretty printed + -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUDFM ufm pp = pp (eltsUDFM ufm) diff --git a/GHC/Types/Unique/DSM.hs b/GHC/Types/Unique/DSM.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/DSM.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE UnboxedTuples, PatternSynonyms, DerivingVia #-} +module GHC.Types.Unique.DSM + ( + -- * Threading a deterministic supply + DUniqSupply + , UniqDSM(UDSM) + , DUniqResult + , pattern DUniqResult + + -- ** UniqDSM and DUniqSupply operations + , getUniqueDSM + , runUniqueDSM + , takeUniqueFromDSupply + , initDUniqSupply + + -- ** Tag operations + , newTagDUniqSupply + , getTagDUniqSupply + + -- * A transfomer threading a deterministic supply + , UniqDSMT(UDSMT) + + -- ** UniqDSMT operations + , runUDSMT + , withDUS + , hoistUDSMT + , liftUDSMT + + -- ** Tags + , setTagUDSMT + + -- * Monad class for deterministic supply threading + , MonadGetUnique(..) + , MonadUniqDSM(..) + + ) + where + +import GHC.Exts (oneShot) +import GHC.Prelude +import GHC.Word +import Control.Monad.Fix +import GHC.Types.Unique +import qualified GHC.Utils.Monad.State.Strict as Strict +import qualified GHC.Types.Unique.Supply as USM +import Control.Monad.IO.Class + +{- +Note [Deterministic Uniques in the CG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC produces fully deterministic object code. To achieve this, there is a key +pass (detRenameCmmGroup) which renames all non-deterministic uniques in +the Cmm code right after StgToCmm. See Note [Object determinism] for the big +picture and some details. + +The code generation pipeline that processes this renamed, deterministic, Cmm, +however, may still need to generate new uniques. If we were to resort to the +non-deterministic unique supply used in the rest of the compiler, our renaming +efforts would be for naught. + +Therefore, after having renamed Cmm deterministically, we must ensure that all +uniques created by the code generation pipeline use a deterministic source of uniques. +Most often, this means don't use `UniqSM` in the Cmm passes, use `UniqDSM`: + +`UniqDSM` is a pure state monad with an incrementing counter from which we +source new uniques. Unlike `UniqSM`, there's no way to `split` the supply, but +it turns out this was rarely really needed for code generation and migrating +from UniqSM to UniqDSM was easy. + +Secondly, the `DUniqSupply` used to run a `UniqDSM` must be threaded through +all passes to guarantee uniques in different passes are unique amongst them +altogether. +Specifically, the same `DUniqSupply` must be threaded through the CG Streaming +pipeline, starting with Driver.Main calling `StgToCmm.codeGen`, `cmmPipeline`, +`cmmToRawCmm`, and `codeOutput` in sequence. + +To thread resources through the `Stream` abstraction, we use the `UniqDSMT` +transformer on top of `IO` as the Monad underlying the Stream. `UniqDSMT` will +thread the `DUniqSupply` through every pass applied to the `Stream`, for every +element. We use @type CgStream = Stream (UniqDSMT IO)@ for the Stream used in +code generation which that carries through the deterministic unique supply. + +Unlike non-deterministic unique supplies which can be split into supplies using +different tags, or where a new supply with a new tag can be brought from the +void, a `DUniqSupply` needs to be sampled iteratively. To use a different tag +during a specific pass (to more easily identify uniques created in it), the tag +should be manually set and then reset on the unique supply. There's also the +auxiliary `setTagUDSMT` which sets the tag for all uniques supplied in the given +action, and resets it implicitly. + +See also Note [Object determinism] in GHC.StgToCmm +-} + +-- See Note [Deterministic Uniques in the CG] +newtype DUniqSupply = DUS Word64 -- supply uniques iteratively +type DUniqResult result = (# result, DUniqSupply #) + +pattern DUniqResult :: a -> DUniqSupply -> (# a, DUniqSupply #) +pattern DUniqResult x y = (# x, y #) +{-# COMPLETE DUniqResult #-} + +-- | A monad which just gives the ability to obtain 'Unique's deterministically. +-- There's no splitting. +newtype UniqDSM result = UDSM' { unUDSM :: DUniqSupply -> DUniqResult result } + deriving (Functor, Applicative, Monad) via (Strict.State DUniqSupply) + +instance MonadFix UniqDSM where + mfix m = UDSM (\us0 -> let (r,us1) = runUniqueDSM us0 (m r) in DUniqResult r us1) + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern UDSM :: (DUniqSupply -> DUniqResult a) -> UniqDSM a +pattern UDSM m <- UDSM' m + where + UDSM m = UDSM' (oneShot $ \s -> m s) +{-# COMPLETE UDSM #-} + +getUniqueDSM :: UniqDSM Unique +getUniqueDSM = UDSM (\(DUS us0) -> DUniqResult (mkUniqueGrimily us0) (DUS $ us0+1)) + +takeUniqueFromDSupply :: DUniqSupply -> (Unique, DUniqSupply) +takeUniqueFromDSupply d = + case unUDSM getUniqueDSM d of + DUniqResult x y -> (x, y) + +-- | Initialize a deterministic unique supply with the given Tag and initial unique. +initDUniqSupply :: Char -> Word64 -> DUniqSupply +initDUniqSupply c firstUniq = + let !tag = mkTag c + in DUS (tag .|. firstUniq) + +runUniqueDSM :: DUniqSupply -> UniqDSM a -> (a, DUniqSupply) +runUniqueDSM ds (UDSM f) = + case f ds of + DUniqResult uq us -> (uq, us) + +-- | Set the tag of uniques generated from this deterministic unique supply +newTagDUniqSupply :: Char -> DUniqSupply -> DUniqSupply +newTagDUniqSupply c (DUS w) = DUS $ getKey $ newTagUnique (mkUniqueGrimily w) c + +-- | Get the tag uniques generated from this deterministic unique supply would have +getTagDUniqSupply :: DUniqSupply -> Char +getTagDUniqSupply (DUS w) = fst $ unpkUnique (mkUniqueGrimily w) + +-- | Get a unique from a monad that can access a unique supply. +-- +-- Crucially, because 'MonadGetUnique' doesn't allow you to get the +-- 'UniqSupply' (unlike 'MonadUnique'), an instance such as 'UniqDSM' can use a +-- deterministic unique supply to return deterministic uniques without allowing +-- for the 'UniqSupply' to be shared. +class Monad m => MonadGetUnique m where + getUniqueM :: m Unique + +instance MonadGetUnique UniqDSM where + getUniqueM = getUniqueDSM + +-- non deterministic instance +instance MonadGetUnique USM.UniqSM where + getUniqueM = USM.getUniqueM + +-------------------------------------------------------------------------------- +-- UniqDSMT +-------------------------------------------------------------------------------- + +-- | Transformer version of 'UniqDSM' to use when threading a deterministic +-- uniq supply over a Monad. Specifically, it is used in the `Stream` of Cmm +-- decls. +newtype UniqDSMT m result = UDSMT' (DUniqSupply -> m (result, DUniqSupply)) + deriving (Functor) + +-- Similar to GHC.Utils.Monad.State.Strict, using Note [The one-shot state monad trick] +-- Using the one-shot trick is necessary for performance. +-- Using transfomer's strict `StateT` regressed some performance tests in 1-2%. +-- The one-shot trick here fixes those regressions. + +pattern UDSMT :: (DUniqSupply -> m (result, DUniqSupply)) -> UniqDSMT m result +pattern UDSMT m <- UDSMT' m + where + UDSMT m = UDSMT' (oneShot $ \s -> m s) +{-# COMPLETE UDSMT #-} + +instance Monad m => Applicative (UniqDSMT m) where + pure x = UDSMT $ \s -> pure (x, s) + UDSMT f <*> UDSMT x = UDSMT $ \s0 -> do + (f', s1) <- f s0 + (x', s2) <- x s1 + pure (f' x', s2) + +instance Monad m => Monad (UniqDSMT m) where + UDSMT x >>= f = UDSMT $ \s0 -> do + (x', s1) <- x s0 + case f x' of UDSMT y -> y s1 + +instance MonadIO m => MonadIO (UniqDSMT m) where + liftIO x = UDSMT $ \s -> (,s) <$> liftIO x + +instance Monad m => MonadGetUnique (UniqDSMT m) where + getUniqueM = UDSMT $ \us -> do + let (u, us') = takeUniqueFromDSupply us + return (u, us') + +-- | Set the tag of the running @UniqDSMT@ supply to the given tag and run an action with it. +-- All uniques produced in the given action will use this tag, until the tag is changed +-- again. +setTagUDSMT :: Monad m => Char {-^ Tag -} -> UniqDSMT m a -> UniqDSMT m a +setTagUDSMT tag (UDSMT act) = UDSMT $ \us -> do + let origtag = getTagDUniqSupply us + new_us = newTagDUniqSupply tag us + (a, us') <- act new_us + let us'_origtag = newTagDUniqSupply origtag us' + -- restore original tag + return (a, us'_origtag) + +-- | Like 'runUniqueDSM' but for 'UniqDSMT' +runUDSMT :: DUniqSupply -> UniqDSMT m a -> m (a, DUniqSupply) +runUDSMT dus (UDSMT st) = st dus + +-- | Lift an IO action that depends on, and threads through, a unique supply +-- into UniqDSMT IO. +withDUS :: (DUniqSupply -> IO (a, DUniqSupply)) -> UniqDSMT IO a +withDUS f = UDSMT $ \us -> do + (a, us') <- liftIO (f us) + return (a, us') + +-- | Change the monad underyling an applied @UniqDSMT@, i.e. transform a +-- @UniqDSMT m@ into a @UniqDSMT n@ given @m ~> n@. +hoistUDSMT :: (forall x. m x -> n x) -> UniqDSMT m a -> UniqDSMT n a +hoistUDSMT nt (UDSMT m) = UDSMT $ \s -> nt (m s) + +-- | Lift a monadic action @m a@ into an @UniqDSMT m a@ +liftUDSMT :: Functor m => m a -> UniqDSMT m a +liftUDSMT m = UDSMT $ \s -> (,s) <$> m + +-------------------------------------------------------------------------------- +-- MonadUniqDSM +-------------------------------------------------------------------------------- + +class (Monad m) => MonadUniqDSM m where + -- | Lift a pure 'UniqDSM' action into a 'MonadUniqDSM' such as 'UniqDSMT' + liftUniqDSM :: UniqDSM a -> m a + +instance MonadUniqDSM UniqDSM where + liftUniqDSM = id + +instance Monad m => MonadUniqDSM (UniqDSMT m) where + liftUniqDSM act = UDSMT $ \us -> pure $ runUniqueDSM us act diff --git a/GHC/Types/Unique/DSet.hs b/GHC/Types/Unique/DSet.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/DSet.hs @@ -0,0 +1,157 @@ +-- (c) Bartosz Nitka, Facebook, 2015 + +-- | +-- Specialised deterministic sets, for things with @Uniques@ +-- +-- Based on 'UniqDFM's (as you would expect). +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why we need it. +-- +-- Basically, the things need to be in class 'Uniquable'. + +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.Unique.DSet ( + -- * Unique set type + UniqDSet, -- type synonym for UniqFM a + getUniqDSet, + pprUniqDSet, + + -- ** Manipulating these sets + delOneFromUniqDSet, delListFromUniqDSet, + emptyUniqDSet, + unitUniqDSet, + mkUniqDSet, + addOneToUniqDSet, addListToUniqDSet, + unionUniqDSets, unionManyUniqDSets, + minusUniqDSet, uniqDSetMinusUniqSet, + intersectUniqDSets, uniqDSetIntersectUniqSet, + nonDetStrictFoldUniqDSet, + elementOfUniqDSet, + filterUniqDSet, + sizeUniqDSet, + isEmptyUniqDSet, + lookupUniqDSet, + uniqDSetToList, + partitionUniqDSet, + mapUniqDSet, strictFoldUniqDSet, mapMUniqDSet + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Types.Unique.DFM +import GHC.Types.Unique.Set +import GHC.Types.Unique + +import Data.Coerce +import Data.Data + +-- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here. +-- Beyond preserving invariants, we may also want to 'override' typeclass +-- instances. + +newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a a} + deriving (Data) + +emptyUniqDSet :: UniqDSet a +emptyUniqDSet = UniqDSet emptyUDFM + +unitUniqDSet :: Uniquable a => a -> UniqDSet a +unitUniqDSet x = UniqDSet (unitUDFM x x) + +mkUniqDSet :: Uniquable a => [a] -> UniqDSet a +mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet + +-- The new element always goes to the right of existing ones. +addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a +addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x) + +addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +addListToUniqDSet = foldl' addOneToUniqDSet + +delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a +delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s + +delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s + +unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a +unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t) + +unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a +unionManyUniqDSets [] = emptyUniqDSet +unionManyUniqDSets (x:xs) = foldl' unionUniqDSets x xs + +minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a +minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t) + +uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet a -> UniqDSet a +uniqDSetMinusUniqSet xs ys + = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys)) + +intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a +intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t) + +uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet a -> UniqDSet a +uniqDSetIntersectUniqSet xs ys + = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys)) + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b +nonDetStrictFoldUniqDSet f acc (UniqDSet s) = nonDetStrictFoldUDFM f acc s + +elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool +elementOfUniqDSet k = elemUDFM k . getUniqDSet + +filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a +filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s) + +sizeUniqDSet :: UniqDSet a -> Int +sizeUniqDSet = sizeUDFM . getUniqDSet + +isEmptyUniqDSet :: UniqDSet a -> Bool +isEmptyUniqDSet = isNullUDFM . getUniqDSet + +lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a +lookupUniqDSet = lookupUDFM . getUniqDSet + +uniqDSetToList :: UniqDSet a -> [a] +uniqDSetToList = eltsUDFM . getUniqDSet + +partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) +partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet + +-- See Note [UniqSet invariant] in GHC.Types.Unique.Set +mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b +mapUniqDSet f (UniqDSet m) = UniqDSet $ unsafeCastUDFMKey $ mapUDFM f m + -- Simply apply `f` to each element, retaining all the structure unchanged. + -- The identification of keys and elements prevents a derived Functor + -- instance, but `unsafeCastUDFMKey` makes it possible to apply the strict + -- mapping from DFM. + +-- | Like 'mapUniqDSet' but for 'mapM'. Assumes the function we are mapping +-- over the 'UniqDSet' does not modify uniques, as per +-- Note [UniqSet invariant] in GHC.Types.Unique.Set. +mapMUniqDSet :: (Monad m, Uniquable b) => (a -> m b) -> UniqDSet a -> m (UniqDSet b) +mapMUniqDSet f (UniqDSet m) = UniqDSet . unsafeCastUDFMKey <$> mapMUDFM f m +{-# INLINEABLE mapMUniqDSet #-} + +strictFoldUniqDSet :: (a -> r -> r) -> r -> UniqDSet a -> r +strictFoldUniqDSet k r s = foldl' (\ !r e -> k e r) r $ + uniqDSetToList s + +-- Two 'UniqDSet's are considered equal if they contain the same +-- uniques. +instance Eq (UniqDSet a) where + UniqDSet a == UniqDSet b = equalKeysUDFM a b + +getUniqDSet :: UniqDSet a -> UniqDFM a a +getUniqDSet = getUniqDSet' + +instance Outputable a => Outputable (UniqDSet a) where + ppr = pprUniqDSet ppr + +pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc +pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList diff --git a/GHC/Types/Unique/FM.hs b/GHC/Types/Unique/FM.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/FM.hs @@ -0,0 +1,607 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +UniqFM: Specialised finite maps, for things with @Uniques@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +(A similar thing to @UniqSet@, as opposed to @Set@.) + +The interface is based on @FiniteMap@s, but the implementation uses +@Data.IntMap@, which is both maintained and faster than the past +implementation (see commit log). + +The @UniqFM@ interface maps directly to Data.IntMap, only +``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased +and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order +of arguments of combining function. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wall #-} + +module GHC.Types.Unique.FM ( + -- * Unique-keyed mappings + UniqFM, -- abstract type + NonDetUniqFM(..), -- wrapper for opting into nondeterminism + + -- ** Manipulating those mappings + emptyUFM, + unitUFM, + unitDirectlyUFM, + zipToUFM, + listToUFM, + listToUFM_Directly, + listToUFM_C, + listToIdentityUFM, + addToUFM,addToUFM_C,addToUFM_Acc,addToUFM_L, + addListToUFM,addListToUFM_C, + addToUFM_Directly, + addListToUFM_Directly, + adjustUFM, alterUFM, alterUFM_Directly, + adjustUFM_Directly, + delFromUFM, + delFromUFM_Directly, + delListFromUFM, + delListFromUFM_Directly, + plusUFM, + plusUFM_C, + plusUFM_CD, + plusUFM_CD2, + mergeUFM, + plusMaybeUFM_C, + plusUFMList, + plusUFMListWith, + sequenceUFMList, + minusUFM, + minusUFM_C, + intersectUFM, + intersectUFM_C, + disjointUFM, + equalKeysUFM, + diffUFM, + nonDetStrictFoldUFM, nonDetFoldUFM, nonDetStrictFoldUFM_DirectlyM, + nonDetFoldWithKeyUFM, + nonDetStrictFoldUFM_Directly, + anyUFM, allUFM, seqEltsUFM, + mapUFM, mapUFM_Directly, strictMapUFM, + mapMaybeUFM, mapMaybeUFM_sameUnique, mapMaybeWithKeyUFM, + elemUFM, elemUFM_Directly, + filterUFM, filterUFM_Directly, partitionUFM, + sizeUFM, + isNullUFM, + lookupUFM, lookupUFM_Directly, + lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, + nonDetEltsUFM, nonDetKeysUFM, + ufmToSet_Directly, + nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM, + unsafeCastUFMKey, + pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM + ) where + +import GHC.Prelude + +import GHC.Types.Unique ( Uniquable(..), Unique, getKey, mkUniqueGrimily ) +import GHC.Utils.Outputable +import GHC.Utils.Panic.Plain +import qualified GHC.Data.Word64Map as M +import qualified GHC.Data.Word64Map.Strict as MS +import qualified GHC.Data.Word64Set as S +import Data.Data +import qualified Data.Semigroup as Semi +import Data.Functor.Classes (Eq1 (..)) +import Data.Coerce + +-- | A finite map from @uniques@ of one type to +-- elements in another type. +-- +-- The key is just here to keep us honest. It's always safe +-- to use a single type as key. +-- If two types don't overlap in their uniques it's also safe +-- to index the same map at multiple key types. But this is +-- very much discouraged. +newtype UniqFM key ele = UFM (M.Word64Map ele) + deriving (Data, Eq, Functor) + -- Nondeterministic Foldable and Traversable instances are accessible through + -- use of the 'NonDetUniqFM' wrapper. + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism. + +emptyUFM :: UniqFM key elt +emptyUFM = UFM M.empty + +isNullUFM :: UniqFM key elt -> Bool +isNullUFM (UFM m) = M.null m + +unitUFM :: Uniquable key => key -> elt -> UniqFM key elt +unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v) + +-- when you've got the Unique already +unitDirectlyUFM :: Unique -> elt -> UniqFM key elt +unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) + +-- zipToUFM ks vs = listToUFM (zip ks vs) +-- This function exists because it's a common case (#18535), and +-- it's inefficient to first build a list of pairs, and then immediately +-- take it apart. Astonishingly, fusing this one list away reduces total +-- compiler allocation by more than 10% (in T12545, see !3935) +-- Note that listToUFM (zip ks vs) performs similarly, but +-- the explicit recursion avoids relying too much on fusion. +zipToUFM :: Uniquable key => [key] -> [elt] -> UniqFM key elt +zipToUFM ks vs = assert (length ks == length vs ) innerZip emptyUFM ks vs + where + innerZip ufm (k:kList) (v:vList) = innerZip (addToUFM ufm k v) kList vList + innerZip ufm _ _ = ufm + +listToUFM :: Uniquable key => [(key,elt)] -> UniqFM key elt +listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM +{-# INLINEABLE listToUFM #-} + +listToUFM_Directly :: [(Unique, elt)] -> UniqFM key elt +listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM +{-# INLINEABLE listToUFM_Directly #-} + +listToIdentityUFM :: Uniquable key => [key] -> UniqFM key key +listToIdentityUFM = foldl' (\m x -> addToUFM m x x) emptyUFM + +listToUFM_C + :: Uniquable key + => (elt -> elt -> elt) + -> [(key, elt)] + -> UniqFM key elt +listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM +{-# INLINEABLE listToUFM_C #-} + +addToUFM :: Uniquable key => UniqFM key elt -> key -> elt -> UniqFM key elt +addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) + +addListToUFM :: Uniquable key => UniqFM key elt -> [(key,elt)] -> UniqFM key elt +addListToUFM = foldl' (\m (k, v) -> addToUFM m k v) + +addListToUFM_Directly :: UniqFM key elt -> [(Unique,elt)] -> UniqFM key elt +addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v) + +addToUFM_Directly :: UniqFM key elt -> Unique -> elt -> UniqFM key elt +addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) + +addToUFM_C + :: Uniquable key + => (elt -> elt -> elt) -- ^ old -> new -> result + -> UniqFM key elt -- ^ old + -> key -> elt -- ^ new + -> UniqFM key elt -- ^ result +-- Arguments of combining function of M.insertWith and addToUFM_C are flipped. +addToUFM_C f (UFM m) k v = + UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) + +addToUFM_Acc + :: Uniquable key + => (elt -> elts -> elts) -- Add to existing + -> (elt -> elts) -- New element + -> UniqFM key elts -- old + -> key -> elt -- new + -> UniqFM key elts -- result +addToUFM_Acc exi new (UFM m) k v = + UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) + +-- | Add an element, returns previous lookup result and new map. If +-- old element doesn't exist, add the passed element directly, +-- otherwise compute the element to add using the passed function. +addToUFM_L + :: Uniquable key + => (key -> elt -> elt -> elt) -- ^ key,old,new + -> key + -> elt -- new + -> UniqFM key elt + -> (Maybe elt, UniqFM key elt) -- ^ old, result +addToUFM_L f k v (UFM m) = + coerce $ + M.insertLookupWithKey + (\_ _n _o -> f k _o _n) + (getKey $ getUnique k) + v + m + +alterUFM + :: Uniquable key + => (Maybe elt -> Maybe elt) -- ^ How to adjust + -> UniqFM key elt -- ^ old + -> key -- ^ new + -> UniqFM key elt -- ^ result +alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) + +alterUFM_Directly + :: (Maybe elt -> Maybe elt) -- ^ How to adjust + -> UniqFM key elt -- ^ old + -> Unique -- ^ new + -> UniqFM key elt -- ^ result +alterUFM_Directly f (UFM m) k = UFM (M.alter f (getKey k) m) + +-- | Add elements to the map, combining existing values with inserted ones using +-- the given function. +addListToUFM_C + :: Uniquable key + => (elt -> elt -> elt) + -> UniqFM key elt -> [(key,elt)] + -> UniqFM key elt +addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) + +adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM key elt -> key -> UniqFM key elt +adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) + +adjustUFM_Directly :: (elt -> elt) -> UniqFM key elt -> Unique -> UniqFM key elt +adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) + +delFromUFM :: Uniquable key => UniqFM key elt -> key -> UniqFM key elt +delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) + +delListFromUFM :: (Uniquable key, Foldable f) => UniqFM key elt -> f key -> UniqFM key elt +delListFromUFM = foldl' delFromUFM +{-# INLINE delListFromUFM #-} + +delListFromUFM_Directly :: Foldable f => UniqFM key elt -> f Unique -> UniqFM key elt +delListFromUFM_Directly = foldl' delFromUFM_Directly +{-# INLINE delListFromUFM_Directly #-} + +delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt +delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) + +-- Bindings in right argument shadow those in the left +plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt +-- M.union is left-biased, plusUFM should be right-biased. +plusUFM (UFM x) (UFM y) = UFM (M.union y x) + -- Note (M.union y x), with arguments flipped + -- M.union is left-biased, plusUFM should be right-biased. + +plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt +plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) + +-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the +-- combinding function and `d1` resp. `d2` as the default value if +-- there is no entry in `m1` reps. `m2`. The domain is the union of +-- the domains of `m1` and `m2`. +-- +-- IMPORTANT NOTE: This function strictly applies the modification function +-- and forces the result unlike most the other functions in this module. +-- +-- Representative example: +-- +-- @ +-- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 +-- == {A: f 1 42, B: f 2 3, C: f 23 4 } +-- @ +{-# INLINE plusUFM_CD #-} +plusUFM_CD + :: (elta -> eltb -> eltc) + -> UniqFM key elta -- map X + -> elta -- default for X + -> UniqFM key eltb -- map Y + -> eltb -- default for Y + -> UniqFM key eltc +plusUFM_CD f (UFM xm) dx (UFM ym) dy + = UFM $ MS.mergeWithKey + (\_ x y -> Just (x `f` y)) + (MS.map (\x -> x `f` dy)) + (MS.map (\y -> dx `f` y)) + xm ym + +-- | `plusUFM_CD2 f m1 m2` merges the maps using `f` as the combining +-- function. Unlike `plusUFM_CD`, a missing value is not defaulted: it is +-- instead passed as `Nothing` to `f`. `f` can never have both its arguments +-- be `Nothing`. +-- +-- IMPORTANT NOTE: This function strictly applies the modification function +-- and forces the result. +-- +-- `plusUFM_CD2 f m1 m2` is the same as `plusUFM_CD f (mapUFM Just m1) Nothing +-- (mapUFM Just m2) Nothing`. +plusUFM_CD2 + :: (Maybe elta -> Maybe eltb -> eltc) + -> UniqFM key elta -- map X + -> UniqFM key eltb -- map Y + -> UniqFM key eltc +plusUFM_CD2 f (UFM xm) (UFM ym) + = UFM $ MS.mergeWithKey + (\_ x y -> Just (Just x `f` Just y)) + (MS.map (\x -> Just x `f` Nothing)) + (MS.map (\y -> Nothing `f` Just y)) + xm ym + +mergeUFM + :: (elta -> eltb -> Maybe eltc) + -> (UniqFM key elta -> UniqFM key eltc) -- map X + -> (UniqFM key eltb -> UniqFM key eltc) -- map Y + -> UniqFM key elta + -> UniqFM key eltb + -> UniqFM key eltc +mergeUFM f g h (UFM xm) (UFM ym) + = UFM $ MS.mergeWithKey + (\_ x y -> (x `f` y)) + (coerce g) + (coerce h) + xm ym + +plusMaybeUFM_C :: (elt -> elt -> Maybe elt) + -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt +plusMaybeUFM_C f (UFM xm) (UFM ym) + = UFM $ M.mergeWithKey + (\_ x y -> x `f` y) + id + id + xm ym + +plusUFMList :: [UniqFM key elt] -> UniqFM key elt +plusUFMList = foldl' plusUFM emptyUFM + +plusUFMListWith :: (elt -> elt -> elt) -> [UniqFM key elt] -> UniqFM key elt +plusUFMListWith f xs = unsafeIntMapToUFM $ M.unionsWith f (map ufmToIntMap xs) + +sequenceUFMList :: forall key elt. [UniqFM key elt] -> UniqFM key [elt] +sequenceUFMList = foldr (plusUFM_CD2 cons) emptyUFM + where + cons :: Maybe elt -> Maybe [elt] -> [elt] + cons (Just x) (Just ys) = x : ys + cons Nothing (Just ys) = ys + cons (Just x) Nothing = [x] + cons Nothing Nothing = [] + +minusUFM :: UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1 +minusUFM (UFM x) (UFM y) = UFM (M.difference x y) + +-- | @minusUFC_C f map1 map2@ returns @map1@, except that every mapping @key +-- |-> value1@ in @map1@ that shares a key with a mapping @key |-> value2@ in +-- @map2@ is altered by @f@: @value1@ is replaced by @f value1 value2@, where +-- 'Just' means that the new value is used and 'Nothing' means that the mapping +-- is deleted. +minusUFM_C :: (elt1 -> elt2 -> Maybe elt1) -> UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1 +minusUFM_C f (UFM x) (UFM y) = UFM (M.differenceWith f x y) + +intersectUFM :: UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1 +intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) + +intersectUFM_C + :: (elt1 -> elt2 -> elt3) + -> UniqFM key elt1 + -> UniqFM key elt2 + -> UniqFM key elt3 +intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) + +disjointUFM :: UniqFM key elt1 -> UniqFM key elt2 -> Bool +disjointUFM (UFM x) (UFM y) = M.disjoint x y + +-- | Fold over a 'UniqFM'. +-- +-- Non-deterministic, unless the folding function is commutative +-- (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@). +nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a +nonDetFoldUFM f z (UFM m) = M.foldr f z m + +-- | Like 'nonDetFoldUFM', but with the 'Unique' key as well. +nonDetFoldWithKeyUFM :: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a +nonDetFoldWithKeyUFM f z (UFM m) = M.foldrWithKey f' z m + where + f' k e a = f (mkUniqueGrimily k) e a + +mapUFM :: (elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 +mapUFM f (UFM m) = UFM (M.map f m) + +mapMaybeUFM :: (elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2 +mapMaybeUFM = mapMaybeUFM_sameUnique + +-- | Like 'Data.Map.mapMaybe', but you must ensure the passed-in function does +-- not modify the unique. +mapMaybeUFM_sameUnique :: (elt1 -> Maybe elt2) -> UniqFM key1 elt1 -> UniqFM key2 elt2 +mapMaybeUFM_sameUnique f (UFM m) = UFM (M.mapMaybe f m) + +mapMaybeWithKeyUFM :: (Unique -> elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2 +mapMaybeWithKeyUFM f (UFM m) = UFM (M.mapMaybeWithKey (f . mkUniqueGrimily) m) + +mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 +mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . mkUniqueGrimily) m) + +strictMapUFM :: (a -> b) -> UniqFM k a -> UniqFM k b +strictMapUFM f (UFM a) = UFM $ MS.map f a + +filterUFM :: (elt -> Bool) -> UniqFM key elt -> UniqFM key elt +filterUFM p (UFM m) = UFM (M.filter p m) + +filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM key elt -> UniqFM key elt +filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . mkUniqueGrimily) m) + +partitionUFM :: (elt -> Bool) -> UniqFM key elt -> (UniqFM key elt, UniqFM key elt) +partitionUFM p (UFM m) = + case M.partition p m of + (left, right) -> (UFM left, UFM right) + +sizeUFM :: UniqFM key elt -> Int +sizeUFM (UFM m) = M.size m + +elemUFM :: Uniquable key => key -> UniqFM key elt -> Bool +elemUFM k (UFM m) = M.member (getKey $ getUnique k) m + +elemUFM_Directly :: Unique -> UniqFM key elt -> Bool +elemUFM_Directly u (UFM m) = M.member (getKey u) m + +lookupUFM :: Uniquable key => UniqFM key elt -> key -> Maybe elt +lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m + +-- when you've got the Unique already +lookupUFM_Directly :: UniqFM key elt -> Unique -> Maybe elt +lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m + +lookupWithDefaultUFM :: Uniquable key => UniqFM key elt -> elt -> key -> elt +lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m + +lookupWithDefaultUFM_Directly :: UniqFM key elt -> elt -> Unique -> elt +lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m + +ufmToSet_Directly :: UniqFM key elt -> S.Word64Set +ufmToSet_Directly (UFM m) = M.keysSet m + +anyUFM :: (elt -> Bool) -> UniqFM key elt -> Bool +anyUFM p (UFM m) = M.foldr ((||) . p) False m + +allUFM :: (elt -> Bool) -> UniqFM key elt -> Bool +allUFM p (UFM m) = M.foldr ((&&) . p) True m + +seqEltsUFM :: (elt -> ()) -> UniqFM key elt -> () +seqEltsUFM seqElt = nonDetFoldUFM (\v rest -> seqElt v `seq` rest) () + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetEltsUFM :: UniqFM key elt -> [elt] +nonDetEltsUFM (UFM m) = M.elems m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetKeysUFM :: UniqFM key elt -> [Unique] +nonDetKeysUFM (UFM m) = map mkUniqueGrimily $ M.keys m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a +nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m +{-# INLINE nonDetStrictFoldUFM #-} + +-- | In essence foldM +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +{-# INLINE nonDetStrictFoldUFM_DirectlyM #-} -- Allow specialization +nonDetStrictFoldUFM_DirectlyM :: (Monad m) => (Unique -> b -> elt -> m b) -> b -> UniqFM key elt -> m b +nonDetStrictFoldUFM_DirectlyM f z0 (UFM xs) = M.foldrWithKey c return xs z0 + -- See Note [List fusion and continuations in 'c'] + where c u x k z = f (mkUniqueGrimily u) z x >>= k + {-# INLINE c #-} + +nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a +nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (mkUniqueGrimily i) x z') z m +{-# INLINE nonDetStrictFoldUFM_Directly #-} + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetUFMToList :: UniqFM key elt -> [(Unique, elt)] +nonDetUFMToList (UFM m) = map (\(k, v) -> (mkUniqueGrimily k, v)) $ M.toList m + +-- | A wrapper around 'UniqFM' with the sole purpose of informing call sites +-- that the provided 'Foldable' and 'Traversable' instances are +-- nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" to learn about determinism. +newtype NonDetUniqFM key ele = NonDetUniqFM { getNonDet :: UniqFM key ele } + deriving (Functor) + +-- | Inherently nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" to learn about determinism. +instance forall key. Foldable (NonDetUniqFM key) where + foldr f z (NonDetUniqFM (UFM m)) = foldr f z m + +-- | Inherently nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" to learn about determinism. +instance forall key. Traversable (NonDetUniqFM key) where + traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m + +ufmToIntMap :: UniqFM key elt -> M.Word64Map elt +ufmToIntMap (UFM m) = m + +unsafeIntMapToUFM :: M.Word64Map elt -> UniqFM key elt +unsafeIntMapToUFM = UFM + +-- | Cast the key domain of a UniqFM. +-- +-- As long as the domains don't overlap in their uniques +-- this is safe. +unsafeCastUFMKey :: UniqFM key1 elt -> UniqFM key2 elt +unsafeCastUFMKey (UFM m) = UFM m + +-- Determines whether two 'UniqFM's contain the same keys. +equalKeysUFM :: UniqFM key a -> UniqFM key b -> Bool +equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 + +-- | An edit on type @a@, relating an element of a container (like an entry in a +-- map or a line in a file) before and after. +data Edit a + = Removed !a -- ^ Element was removed from the container + | Added !a -- ^ Element was added to the container + | Changed !a !a -- ^ Element was changed. Carries the values before and after + deriving Eq + +instance Outputable a => Outputable (Edit a) where + ppr (Removed a) = text "-" <> ppr a + ppr (Added a) = text "+" <> ppr a + ppr (Changed l r) = ppr l <> text "->" <> ppr r + +-- A very convient function to have for debugging: +-- | Computes the diff of two 'UniqFM's in terms of 'Edit's. +-- Equal points will not be present in the result map at all. +diffUFM :: Eq a => UniqFM key a -> UniqFM key a -> UniqFM key (Edit a) +diffUFM = mergeUFM both (mapUFM Removed) (mapUFM Added) + where + both x y | x == y = Nothing + | otherwise = Just $! Changed x y + +-- Instances + +instance Semi.Semigroup (UniqFM key a) where + (<>) = plusUFM + +instance Monoid (UniqFM key a) where + mempty = emptyUFM + mappend = (Semi.<>) + +-- Output-ery + +instance Outputable a => Outputable (UniqFM key a) where + ppr ufm = pprUniqFM ppr ufm + +pprUniqFM :: (a -> SDoc) -> UniqFM key a -> SDoc +pprUniqFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elt) <- nonDetUFMToList ufm ] + -- It's OK to use nonDetUFMToList here because we only use it for + -- pretty-printing. + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetEltsUFM. +pprUFM :: UniqFM key a -- ^ The things to be pretty printed + -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUFM ufm pp = pp (nonDetEltsUFM ufm) + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetUFMToList. +pprUFMWithKeys + :: UniqFM key a -- ^ The things to be pretty printed + -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm) + +-- | Determines the pluralisation suffix appropriate for the length of a set +-- in the same way that plural from Outputable does for lists. +pluralUFM :: UniqFM key a -> SDoc +pluralUFM ufm + | sizeUFM ufm == 1 = empty + | otherwise = char 's' diff --git a/GHC/Types/Unique/Map.hs b/GHC/Types/Unique/Map.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/Map.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -Wall #-} + +-- Like 'UniqFM', these are maps for keys which are Uniquable. +-- Unlike 'UniqFM', these maps also remember their keys, which +-- makes them a much better drop in replacement for 'Data.Map.Map'. +-- +-- Key preservation is right-biased. +module GHC.Types.Unique.Map ( + UniqMap(..), + emptyUniqMap, + isNullUniqMap, + unitUniqMap, + listToUniqMap, + listToUniqMap_C, + addToUniqMap, + addListToUniqMap, + addToUniqMap_C, + addToUniqMap_Acc, + addToUniqMap_L, + alterUniqMap, + addListToUniqMap_C, + adjustUniqMap, + delFromUniqMap, + delListFromUniqMap, + plusUniqMap, + plusUniqMap_C, + plusMaybeUniqMap_C, + plusUniqMapList, + plusUniqMapListWith, + minusUniqMap, + intersectUniqMap, + intersectUniqMap_C, + disjointUniqMap, + mapUniqMap, + filterUniqMap, + filterWithKeyUniqMap, + partitionUniqMap, + sizeUniqMap, + elemUniqMap, + nonDetKeysUniqMap, + nonDetEltsUniqMap, + lookupUniqMap, + lookupWithDefaultUniqMap, + anyUniqMap, + allUniqMap, + nonDetUniqMapToList, + nonDetUniqMapToKeySet, + nonDetFoldUniqMap + -- Non-deterministic functions omitted +) where + +import GHC.Prelude + +import GHC.Types.Unique.FM + +import GHC.Types.Unique +import GHC.Utils.Outputable + +import Data.Semigroup as Semi ( Semigroup(..) ) +import Data.Coerce +import Data.Maybe +import Data.Data +import Control.DeepSeq + +import Data.Set (Set, fromList) + +-- | Maps indexed by 'Uniquable' keys +newtype UniqMap k a = UniqMap { getUniqMap :: UniqFM k (k, a) } + deriving (Data, Eq, Functor) +type role UniqMap nominal representational + +instance Semigroup (UniqMap k a) where + (<>) = plusUniqMap + +instance Monoid (UniqMap k a) where + mempty = emptyUniqMap + mappend = (Semi.<>) + +instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where + ppr (UniqMap m) = + brackets $ fsep $ punctuate comma $ + [ ppr k <+> text "->" <+> ppr v + | (k, v) <- nonDetEltsUFM m ] + +instance (NFData k, NFData a) => NFData (UniqMap k a) where + rnf (UniqMap fm) = seqEltsUFM rnf fm + +liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a) +liftC f (_, v) (k', v') = (k', f v v') + +emptyUniqMap :: UniqMap k a +emptyUniqMap = UniqMap emptyUFM + +isNullUniqMap :: UniqMap k a -> Bool +isNullUniqMap (UniqMap m) = isNullUFM m + +unitUniqMap :: Uniquable k => k -> a -> UniqMap k a +unitUniqMap k v = UniqMap (unitUFM k (k, v)) + +listToUniqMap :: Uniquable k => [(k,a)] -> UniqMap k a +listToUniqMap kvs = UniqMap (listToUFM [ (k,(k,v)) | (k,v) <- kvs]) + +listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k,a)] -> UniqMap k a +listToUniqMap_C f kvs = UniqMap $ + listToUFM_C (liftC f) [ (k,(k,v)) | (k,v) <- kvs] + +addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a +addToUniqMap (UniqMap m) k v = UniqMap $ addToUFM m k (k, v) + +addListToUniqMap :: Uniquable k => UniqMap k a -> [(k,a)] -> UniqMap k a +addListToUniqMap (UniqMap m) kvs = UniqMap $ + addListToUFM m [(k,(k,v)) | (k,v) <- kvs] + +addToUniqMap_C :: Uniquable k + => (a -> a -> a) + -> UniqMap k a + -> k + -> a + -> UniqMap k a +addToUniqMap_C f (UniqMap m) k v = UniqMap $ + addToUFM_C (liftC f) m k (k, v) + +addToUniqMap_Acc :: Uniquable k + => (b -> a -> a) + -> (b -> a) + -> UniqMap k a + -> k + -> b + -> UniqMap k a +addToUniqMap_Acc exi new (UniqMap m) k0 v0 = UniqMap $ + addToUFM_Acc (\b (k, v) -> (k, exi b v)) + (\b -> (k0, new b)) + m k0 v0 + +-- | Add an element, returns previous lookup result and new map. If +-- old element doesn't exist, add the passed element directly, +-- otherwise compute the element to add using the passed function. +addToUniqMap_L :: Uniquable k + => (k -> a -> a -> a) -- key,old,new + -> k + -> a -- new + -> UniqMap k a + -> (Maybe a, UniqMap k a) +addToUniqMap_L f k v (UniqMap m) = case addToUFM_L + (\_k (_, _o) (_, _n) -> (_k, f _k _o _n)) + k + (k, v) + m of + (_maybe, _ufm) -> (snd <$> _maybe, UniqMap _ufm) + +alterUniqMap :: Uniquable k + => (Maybe a -> Maybe a) + -> UniqMap k a + -> k + -> UniqMap k a +alterUniqMap f (UniqMap m) k = UniqMap $ + alterUFM (fmap (k,) . f . fmap snd) m k + +addListToUniqMap_C + :: Uniquable k + => (a -> a -> a) + -> UniqMap k a + -> [(k, a)] + -> UniqMap k a +addListToUniqMap_C f (UniqMap m) kvs = UniqMap $ + addListToUFM_C (liftC f) m + [(k,(k,v)) | (k,v) <- kvs] + +adjustUniqMap + :: Uniquable k + => (a -> a) + -> UniqMap k a + -> k + -> UniqMap k a +adjustUniqMap f (UniqMap m) k = UniqMap $ + adjustUFM (\(_,v) -> (k,f v)) m k + +delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a +delFromUniqMap (UniqMap m) k = UniqMap $ delFromUFM m k + +delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a +delListFromUniqMap (UniqMap m) ks = UniqMap $ delListFromUFM m ks + +plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a +plusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ plusUFM m1 m2 + +plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a +plusUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ + plusUFM_C (liftC f) m1 m2 + +plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a +plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ + plusMaybeUFM_C (\(_, v) (k', v') -> fmap (k',) (f v v')) m1 m2 + +plusUniqMapList :: [UniqMap k a] -> UniqMap k a +plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs) + +plusUniqMapListWith :: (a -> a -> a) -> [UniqMap k a] -> UniqMap k a +plusUniqMapListWith f xs = UniqMap $ plusUFMListWith go (coerce xs) + where + -- l and r keys will be identical so we choose the former + go (l_key, l) (_r, r) = (l_key, f l r) +{-# INLINE plusUniqMapListWith #-} + +minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a +minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2 + +intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a +intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2 + +-- | Intersection with a combining function. +intersectUniqMap_C :: (a -> b -> c) -> UniqMap k a -> UniqMap k b -> UniqMap k c +intersectUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM_C (\(k, a) (_, b) -> (k, f a b)) m1 m2 +{-# INLINE intersectUniqMap #-} + +disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool +disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2 + +mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b +mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance + +filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a +filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m + +filterWithKeyUniqMap :: (k -> a -> Bool) -> UniqMap k a -> UniqMap k a +filterWithKeyUniqMap f (UniqMap m) = UniqMap $ filterUFM (uncurry f) m + +partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a) +partitionUniqMap f (UniqMap m) = + coerce $ partitionUFM (f . snd) m + +sizeUniqMap :: UniqMap k a -> Int +sizeUniqMap (UniqMap m) = sizeUFM m + +elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool +elemUniqMap k (UniqMap m) = elemUFM k m + +lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a +lookupUniqMap (UniqMap m) k = fmap snd (lookupUFM m k) + +lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a +lookupWithDefaultUniqMap (UniqMap m) a k = fromMaybe a (fmap snd (lookupUFM m k)) + +anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool +anyUniqMap f (UniqMap m) = anyUFM (f . snd) m + +allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool +allUniqMap f (UniqMap m) = allUFM (f . snd) m + +nonDetUniqMapToList :: UniqMap k a -> [(k, a)] +nonDetUniqMapToList (UniqMap m) = nonDetEltsUFM m +{-# INLINE nonDetUniqMapToList #-} + +nonDetUniqMapToKeySet :: Ord k => UniqMap k a -> Set k +nonDetUniqMapToKeySet m = fromList (nonDetKeysUniqMap m) + +nonDetKeysUniqMap :: UniqMap k a -> [k] +nonDetKeysUniqMap m = map fst (nonDetUniqMapToList m) +{-# INLINE nonDetKeysUniqMap #-} + +nonDetEltsUniqMap :: UniqMap k a -> [a] +nonDetEltsUniqMap m = map snd (nonDetUniqMapToList m) +{-# INLINE nonDetEltsUniqMap #-} + +nonDetFoldUniqMap :: ((k, a) -> b -> b) -> b -> UniqMap k a -> b +nonDetFoldUniqMap go z (UniqMap m) = nonDetFoldUFM go z m +{-# INLINE nonDetFoldUniqMap #-} diff --git a/GHC/Types/Unique/MemoFun.hs b/GHC/Types/Unique/MemoFun.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/MemoFun.hs @@ -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 diff --git a/GHC/Types/Unique/SDFM.hs b/GHC/Types/Unique/SDFM.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/SDFM.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ApplicativeDo #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Like a 'UniqDFM', but maintains equivalence classes of keys sharing the +-- same entry. See 'UniqSDFM'. +module GHC.Types.Unique.SDFM ( + -- * Unique-keyed, /shared/, deterministic mappings + UniqSDFM, + + emptyUSDFM, + lookupUSDFM, + equateUSDFM, addToUSDFM, + traverseUSDFM + ) where + +import GHC.Prelude + +import GHC.Types.Unique +import GHC.Types.Unique.DFM +import GHC.Utils.Outputable + +-- | Either @Indirect x@, meaning the value is represented by that of @x@, or +-- an @Entry@ containing containing the actual value it represents. +data Shared key ele + = Indirect !key + | Entry !ele + +-- | A 'UniqDFM' whose domain is /sets/ of 'Unique's, each of which share a +-- common value of type @ele@. +-- Every such set (\"equivalence class\") has a distinct representative +-- 'Unique'. Supports merging the entries of multiple such sets in a union-find +-- like fashion. +-- +-- An accurate model is that of @[(Set key, Maybe ele)]@: A finite mapping from +-- sets of @key@s to possibly absent entries @ele@, where the sets don't overlap. +-- Example: +-- @ +-- m = [({u1,u3}, Just ele1), ({u2}, Just ele2), ({u4,u7}, Nothing)] +-- @ +-- On this model we support the following main operations: +-- +-- * @'lookupUSDFM' m u3 == Just ele1@, @'lookupUSDFM' m u4 == Nothing@, +-- @'lookupUSDFM' m u5 == Nothing@. +-- * @'equateUSDFM' m u1 u3@ is a no-op, but +-- @'equateUSDFM' m u1 u2@ merges @{u1,u3}@ and @{u2}@ to point to +-- @Just ele2@ and returns the old entry of @{u1,u3}@, @Just ele1@. +-- * @'addToUSDFM' m u3 ele4@ sets the entry of @{u1,u3}@ to @Just ele4@. +-- +-- As well as a few means for traversal/conversion to list. +newtype UniqSDFM key ele + = USDFM { unUSDFM :: UniqDFM key (Shared key ele) } + +emptyUSDFM :: UniqSDFM key ele +emptyUSDFM = USDFM emptyUDFM + +lookupReprAndEntryUSDFM :: Uniquable key => UniqSDFM key ele -> key -> (key, Maybe ele) +lookupReprAndEntryUSDFM (USDFM env) = go + where + go x = case lookupUDFM env x of + Nothing -> (x, Nothing) + Just (Indirect y) -> go y + Just (Entry ele) -> (x, Just ele) + +-- | @lookupSUDFM env x@ looks up an entry for @x@, looking through all +-- 'Indirect's until it finds a shared 'Entry'. +-- +-- Examples in terms of the model (see 'UniqSDFM'): +-- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u3 == Just ele1 +-- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u4 == Nothing +-- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Nothing)] u2 == Nothing +lookupUSDFM :: Uniquable key => UniqSDFM key ele -> key -> Maybe ele +lookupUSDFM usdfm x = snd (lookupReprAndEntryUSDFM usdfm x) + +-- | @equateUSDFM env x y@ makes @x@ and @y@ point to the same entry, +-- thereby merging @x@'s class with @y@'s. +-- If both @x@ and @y@ are in the domain of the map, then @y@'s entry will be +-- chosen as the new entry and @x@'s old entry will be returned. +-- +-- Examples in terms of the model (see 'UniqSDFM'): +-- >>> equateUSDFM [] u1 u2 == (Nothing, [({u1,u2}, Nothing)]) +-- >>> equateUSDFM [({u1,u3}, Just ele1)] u3 u4 == (Nothing, [({u1,u3,u4}, Just ele1)]) +-- >>> equateUSDFM [({u1,u3}, Just ele1)] u4 u3 == (Nothing, [({u1,u3,u4}, Just ele1)]) +-- >>> equateUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u3 u2 == (Just ele1, [({u2,u1,u3}, Just ele2)]) +equateUSDFM + :: Uniquable key => UniqSDFM key ele -> key -> key -> (Maybe ele, UniqSDFM key ele) +equateUSDFM usdfm@(USDFM env) x y = + case (lu x, lu y) of + ((x', _) , (y', _)) + | getUnique x' == getUnique y' -> (Nothing, usdfm) -- nothing to do + ((x', _) , (y', Nothing)) -> (Nothing, set_indirect y' x') + ((x', mb_ex), (y', _)) -> (mb_ex, set_indirect x' y') + where + lu = lookupReprAndEntryUSDFM usdfm + set_indirect a b = USDFM $ addToUDFM env a (Indirect b) + +-- | @addToUSDFM env x a@ sets the entry @x@ is associated with to @a@, +-- thereby modifying its whole equivalence class. +-- +-- Examples in terms of the model (see 'UniqSDFM'): +-- >>> addToUSDFM [] u1 ele1 == [({u1}, Just ele1)] +-- >>> addToUSDFM [({u1,u3}, Just ele1)] u3 ele2 == [({u1,u3}, Just ele2)] +addToUSDFM :: Uniquable key => UniqSDFM key ele -> key -> ele -> UniqSDFM key ele +addToUSDFM usdfm@(USDFM env) x v = + USDFM $ addToUDFM env (fst (lookupReprAndEntryUSDFM usdfm x)) (Entry v) + +traverseUSDFM :: forall key a b f. Applicative f => (a -> f b) -> UniqSDFM key a -> f (UniqSDFM key b) +traverseUSDFM f = fmap (USDFM . listToUDFM_Directly) . traverse g . udfmToList . unUSDFM + where + g :: (Unique, Shared key a) -> f (Unique, Shared key b) + g (u, Indirect y) = pure (u,Indirect y) + g (u, Entry a) = do + a' <- f a + pure (u,Entry a') + +instance (Outputable key, Outputable ele) => Outputable (Shared key ele) where + ppr (Indirect x) = ppr x + ppr (Entry a) = ppr a + +instance (Outputable key, Outputable ele) => Outputable (UniqSDFM key ele) where + ppr (USDFM env) = ppr env diff --git a/GHC/Types/Unique/Set.hs b/GHC/Types/Unique/Set.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/Set.hs @@ -0,0 +1,315 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[UniqSet]{Specialised sets, for things with @Uniques@} + +Based on @UniqFMs@ (as you would expect). + +Basically, the things need to be in class @Uniquable@. +-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.Unique.Set ( + -- * Unique set type + UniqSet, -- type synonym for UniqFM a + getUniqSet, + pprUniqSet, + + -- ** Manipulating these sets + emptyUniqSet, + unitUniqSet, + mkUniqSet, + addOneToUniqSet, addListToUniqSet, + delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, + delListFromUniqSet_Directly, + unionUniqSets, unionManyUniqSets, + minusUniqSet, uniqSetMinusUFM, uniqSetMinusUDFM, + intersectUniqSets, + disjointUniqSets, + restrictUniqSetToUFM, + uniqSetAny, uniqSetAll, + elementOfUniqSet, + elemUniqSet_Directly, + filterUniqSet, + filterUniqSet_Directly, + sizeUniqSet, + isEmptyUniqSet, + lookupUniqSet, + lookupUniqSet_Directly, + partitionUniqSet, + mapUniqSet, + unsafeUFMToUniqSet, + nonDetEltsUniqSet, + nonDetKeysUniqSet, + nonDetStrictFoldUniqSet, + mapMaybeUniqSet_sameUnique, + + -- UniqueSet + UniqueSet(..), + nullUniqueSet, + sizeUniqueSet, + memberUniqueSet, + emptyUniqueSet, + singletonUniqueSet, + insertUniqueSet, + deleteUniqueSet, + differenceUniqueSet, + unionUniqueSet, + unionsUniqueSet, + intersectionUniqueSet, + isSubsetOfUniqueSet, + filterUniqueSet, + foldlUniqueSet, + foldrUniqueSet, + elemsUniqueSet, + fromListUniqueSet, + ) where + +import GHC.Prelude + +import GHC.Types.Unique.DFM +import GHC.Types.Unique.FM +import GHC.Types.Unique +import Data.Coerce +import GHC.Utils.Outputable +import Data.Data +import qualified Data.Semigroup as Semi +import Control.DeepSeq +import qualified GHC.Data.Word64Set as S + +-- Note [UniqSet invariant] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- UniqSet has the following invariant: +-- The keys in the map are the uniques of the values +-- It means that to implement mapUniqSet you have to update +-- both the keys and the values. + +-- | Set of Uniquable values +newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a a} + deriving (Data, Semi.Semigroup, Monoid) + +instance NFData a => NFData (UniqSet a) where + rnf = forceUniqSet rnf + +emptyUniqSet :: UniqSet a +emptyUniqSet = UniqSet emptyUFM + +unitUniqSet :: Uniquable a => a -> UniqSet a +unitUniqSet x = UniqSet $ unitUFM x x + +mkUniqSet :: Uniquable a => [a] -> UniqSet a +mkUniqSet = foldl' addOneToUniqSet emptyUniqSet +{-# INLINEABLE mkUniqSet #-} + +addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) + +addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +addListToUniqSet = foldl' addOneToUniqSet +{-# INLINEABLE addListToUniqSet #-} + +delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) + +delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a +delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u) + +delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l) +{-# INLINEABLE delListFromUniqSet #-} + +delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a +delListFromUniqSet_Directly (UniqSet s) l = + UniqSet (delListFromUFM_Directly s l) +{-# INLINEABLE delListFromUniqSet_Directly #-} + +unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) + +unionManyUniqSets :: [UniqSet a] -> UniqSet a +unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet + +minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a +minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) + +intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) + +disjointUniqSets :: UniqSet a -> UniqSet a -> Bool +disjointUniqSets (UniqSet s) (UniqSet t) = disjointUFM s t + +restrictUniqSetToUFM :: UniqSet key -> UniqFM key b -> UniqSet key +restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m) + +uniqSetMinusUFM :: UniqSet key -> UniqFM key b -> UniqSet key +uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t) + +uniqSetMinusUDFM :: UniqSet key -> UniqDFM key b -> UniqSet key +uniqSetMinusUDFM (UniqSet s) t = UniqSet (ufmMinusUDFM s t) + +elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool +elementOfUniqSet a (UniqSet s) = elemUFM a s + +elemUniqSet_Directly :: Unique -> UniqSet a -> Bool +elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s + +filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a +filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s) + +filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt +filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s) + +partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) +partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s) + +uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool +uniqSetAny p (UniqSet s) = anyUFM p s + +uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool +uniqSetAll p (UniqSet s) = allUFM p s + +sizeUniqSet :: UniqSet a -> Int +sizeUniqSet (UniqSet s) = sizeUFM s + +isEmptyUniqSet :: UniqSet a -> Bool +isEmptyUniqSet (UniqSet s) = isNullUFM s + +-- | What's the point you might ask? We might have changed an object +-- without it's key changing. In which case this lookup makes sense. +lookupUniqSet :: Uniquable key => UniqSet key -> key -> Maybe key +lookupUniqSet (UniqSet s) k = lookupUFM s k + +lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a +lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetEltsUniqSet :: UniqSet elt -> [elt] +nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet' + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetKeysUniqSet :: UniqSet elt -> [Unique] +nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet' + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a +nonDetStrictFoldUniqSet c n (UniqSet s) = nonDetStrictFoldUFM c n s + +-- See Note [UniqSet invariant] +mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b +mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet + +-- | Like 'Data.Set.mapMaybe', but you must ensure the passed in function +-- does not change the 'Unique'. +mapMaybeUniqSet_sameUnique :: (a -> Maybe b) -> UniqSet a -> UniqSet b +mapMaybeUniqSet_sameUnique f (UniqSet a) = UniqSet $ mapMaybeUFM_sameUnique f a + +-- Two 'UniqSet's are considered equal if they contain the same +-- uniques. +instance Eq (UniqSet a) where + UniqSet a == UniqSet b = equalKeysUFM a b + +getUniqSet :: UniqSet a -> UniqFM a a +getUniqSet = getUniqSet' + +-- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ +-- assuming, without checking, that it maps each 'Unique' to a value +-- that has that 'Unique'. See Note [UniqSet invariant]. +unsafeUFMToUniqSet :: UniqFM a a -> UniqSet a +unsafeUFMToUniqSet = UniqSet + +instance Outputable a => Outputable (UniqSet a) where + ppr = pprUniqSet ppr + +pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc +-- It's OK to use nonDetUFMToList here because we only use it for +-- pretty-printing. +pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet + +forceUniqSet :: (a -> ()) -> UniqSet a -> () +forceUniqSet f (UniqSet fm) = seqEltsUFM f fm + +-------------------------------------------------------- +-- UniqueSet +-------------------------------------------------------- + +-- | Set of Unique values +-- +-- Similar to 'UniqSet Unique' but with a more compact representation. +newtype UniqueSet = US { unUniqueSet :: S.Word64Set } + deriving (Eq, Ord, Show, Semigroup, Monoid) + +{-# INLINE nullUniqueSet #-} +nullUniqueSet :: UniqueSet -> Bool +nullUniqueSet (US s) = S.null s + +{-# INLINE sizeUniqueSet #-} +sizeUniqueSet :: UniqueSet -> Int +sizeUniqueSet (US s) = S.size s + +{-# INLINE memberUniqueSet #-} +memberUniqueSet :: Unique -> UniqueSet -> Bool +memberUniqueSet k (US s) = S.member (getKey k) s + +{-# INLINE emptyUniqueSet #-} +emptyUniqueSet :: UniqueSet +emptyUniqueSet = US S.empty + +{-# INLINE singletonUniqueSet #-} +singletonUniqueSet :: Unique -> UniqueSet +singletonUniqueSet k = US (S.singleton (getKey k)) + +{-# INLINE insertUniqueSet #-} +insertUniqueSet :: Unique -> UniqueSet -> UniqueSet +insertUniqueSet k (US s) = US (S.insert (getKey k) s) + +{-# INLINE deleteUniqueSet #-} +deleteUniqueSet :: Unique -> UniqueSet -> UniqueSet +deleteUniqueSet k (US s) = US (S.delete (getKey k) s) + +{-# INLINE unionUniqueSet #-} +unionUniqueSet :: UniqueSet -> UniqueSet -> UniqueSet +unionUniqueSet (US x) (US y) = US (S.union x y) + +{-# INLINE unionsUniqueSet #-} +unionsUniqueSet :: [UniqueSet] -> UniqueSet +unionsUniqueSet xs = US (S.unions (map unUniqueSet xs)) + +{-# INLINE differenceUniqueSet #-} +differenceUniqueSet :: UniqueSet -> UniqueSet -> UniqueSet +differenceUniqueSet (US x) (US y) = US (S.difference x y) + +{-# INLINE intersectionUniqueSet #-} +intersectionUniqueSet :: UniqueSet -> UniqueSet -> UniqueSet +intersectionUniqueSet (US x) (US y) = US (S.intersection x y) + +{-# INLINE isSubsetOfUniqueSet #-} +isSubsetOfUniqueSet :: UniqueSet -> UniqueSet -> Bool +isSubsetOfUniqueSet (US x) (US y) = S.isSubsetOf x y + +{-# INLINE filterUniqueSet #-} +filterUniqueSet :: (Unique -> Bool) -> UniqueSet -> UniqueSet +filterUniqueSet f (US s) = US (S.filter (f . mkUniqueGrimily) s) + +{-# INLINE foldlUniqueSet #-} +foldlUniqueSet :: (a -> Unique -> a) -> a -> UniqueSet -> a +foldlUniqueSet k z (US s) = S.foldl' (\a b -> k a (mkUniqueGrimily b)) z s + +{-# INLINE foldrUniqueSet #-} +foldrUniqueSet :: (Unique -> b -> b) -> b -> UniqueSet -> b +foldrUniqueSet k z (US s) = S.foldr (k . mkUniqueGrimily) z s + +{-# INLINE elemsUniqueSet #-} +elemsUniqueSet :: UniqueSet -> [Unique] +elemsUniqueSet (US s) = map mkUniqueGrimily (S.elems s) + +{-# INLINE fromListUniqueSet #-} +fromListUniqueSet :: [Unique] -> UniqueSet +fromListUniqueSet ks = US (S.fromList (map getKey ks)) diff --git a/GHC/Types/Unique/Supply.hs b/GHC/Types/Unique/Supply.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/Supply.hs @@ -0,0 +1,381 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnboxedTuples #-} + +module GHC.Types.Unique.Supply ( + -- * Main data type + UniqSupply, -- Abstractly + + -- ** Operations on supplies + uniqFromSupply, uniqsFromSupply, -- basic ops + takeUniqFromSupply, uniqFromTag, + + mkSplitUniqSupply, + splitUniqSupply, listSplitUniqSupply, + + -- * Unique supply monad and its abstraction + UniqSM, MonadUnique(..), + + -- ** Operations on the monad + initUs, initUs_, + + -- * Set supply strategy + initUniqSupply + ) where + +import GHC.Prelude + +import GHC.Types.Unique +import GHC.Utils.Panic.Plain + +import GHC.IO + +import GHC.Utils.Monad +import Control.Monad +import Data.Word +import GHC.Exts( Ptr(..), noDuplicate#, oneShot ) +import Foreign.Storable +import GHC.Utils.Monad.State.Strict as Strict + +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS != 64 +#define NO_FETCH_ADD +#endif + +#if defined(NO_FETCH_ADD) +import GHC.Exts ( atomicCasWord64Addr#, eqWord64#, readWord64OffAddr# ) +#else +import GHC.Exts( fetchAddWordAddr#, word64ToWord# ) +#endif + +import GHC.Exts ( Addr#, State#, Word64#, RealWorld ) +import GHC.Int ( Int(..) ) +import GHC.Word( Word64(..) ) +import GHC.Exts( plusWord64#, int2Word#, wordToWord64# ) + +{- +************************************************************************ +* * +\subsection{Splittable Unique supply: @UniqSupply@} +* * +************************************************************************ +-} + +{- Note [How the unique supply works] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea (due to Lennart Augustsson) is that a UniqSupply is +lazily-evaluated infinite tree. + +* At each MkSplitUniqSupply node is a unique Word64, and two + sub-trees (see data UniqSupply) + +* takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) + returns the unique Word64 and one of the sub-trees + +* splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) + returns the two sub-trees + +* When you poke on one of the thunks, it does a foreign call + to get a fresh Word64 from a thread-safe counter, and returns + a fresh MkSplitUniqSupply node. This has to be as efficient + as possible: it should allocate only + * The fresh node + * A thunk for each sub-tree + +Note [How unique supplies are used] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The general design (used throughout GHC) is to: + +* For creating new uniques either a UniqSupply is used and threaded through + or for monadic code a MonadUnique instance might conjure up uniques using + `uniqFromTag`. +* Different parts of the compiler will use a UniqSupply or MonadUnique instance + with a specific tag. This way the different parts of the compiler will + generate uniques with different tags. + +If different code shares the same tag then care has to be taken that all uniques +still get distinct numbers. Usually this is done by relying on genSym which +has *one* counter per GHC invocation that is relied on by all calls to it. +But using something like the address for pinned objects works as well and in fact is done +for fast strings. + +This is important for example in the simplifier. Most passes of the simplifier use +the same tag 's'. However in some places we create a unique supply using `mkSplitUniqSupply` +and thread it through the code, while in GHC.Core.Opt.Simplify.Monad we use the +`instance MonadUnique SimplM`, which uses `mkSplitUniqSupply` in getUniqueSupplyM +and `uniqFromTag` in getUniqueM. + +Ultimately all these boil down to each new unique consisting of the tag and the result from +a call to `genSym`. The latter producing a distinct number for each invocation ensuring +uniques are distinct. + +Note [Optimising the unique supply] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The inner loop of mkSplitUniqSupply is a function closure + + mk_supply s0 = + case noDuplicate# s0 of { s1 -> + case unIO genSym s1 of { (# s2, u #) -> + case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s2 of { (# s3, x #) -> + case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s3 of { (# s4, y #) -> + (# s4, MkSplitUniqSupply (tag .|. u) x y #) + }}}} + +It's a classic example of an IO action that is captured and then called +repeatedly (see #18238 for some discussion). It mustn't allocate! The test +perf/should_run/UniqLoop keeps track of this loop. Watch it carefully. + +We used to write it as: + + mk_supply :: IO UniqSupply + mk_supply = unsafeInterleaveIO $ + genSym >>= \ u -> + mk_supply >>= \ s1 -> + mk_supply >>= \ s2 -> + return (MkSplitUniqSupply (tag .|. u) s1 s2) + +and to rely on -fno-state-hack, full laziness and inlining to get the same +result. It was very brittle and required enabling -fno-state-hack globally. So +it has been rewritten using lower level constructs to explicitly state what we +want. + +Note [Optimising use of unique supplies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When it comes to having a way to generate new Uniques +there are generally three ways to deal with this: + +For pure code the only good approach is to take an UniqSupply +as argument. Then thread it through the code splitting it +for sub-passes or when creating uniques. +The code for this is about as optimized as it gets, but we can't +get around the need to allocate one `UniqSupply` for each Unique +we need. + +For code in IO we can improve on this by threading only the *tag* +we are going to use for Uniques. Using `uniqFromTag` to +generate uniques as needed. This gets rid of the overhead of +allocating a new UniqSupply for each unique generated. It also avoids +frequent state updates when the Unique/Tag is part of the state in a +state monad. + +For monadic code in IO which always uses the same tag we can go further +and hardcode the tag into the MonadUnique instance. On top of all the +benefits of threading the tag this *also* has the benefit of avoiding +the tag getting captured in thunks, or being passed around at runtime. +It does however come at the cost of having to use a fixed tag for all +code run in this Monad. The tag is mostly cosmetic: See Note [Uniques and tags]. + +NB: It's *not* an optimization to pass around the UniqSupply inside an +IORef instead of the tag. While this would avoid frequent state updates +it still requires allocating one UniqSupply per Unique. On top of some +overhead for reading/writing to/from the IORef. + +All of this hinges on the assumption that UniqSupply and +uniqFromTag use the same source of distinct numbers (`genSym`) which +allows both to be used at the same time, with the same tag, while still +ensuring distinct uniques. +One might consider this fact to be an "accident". But GHC worked like this +as far back as source control history goes. It also allows the later two +optimizations to be used. So it seems safe to depend on this fact. + +-} + + +-- | Unique Supply +-- +-- A value of type 'UniqSupply' is unique, and it can +-- supply /one/ distinct 'Unique'. Also, from the supply, one can +-- also manufacture an arbitrary number of further 'UniqueSupply' values, +-- which will be distinct from the first and from all others. +data UniqSupply + = MkSplitUniqSupply {-# UNPACK #-} !Word64 -- make the Unique with this + UniqSupply UniqSupply + -- when split => these two supplies + +mkSplitUniqSupply :: Char -> IO UniqSupply +-- ^ Create a unique supply out of thin air. +-- The "tag" (Char) supplied is mostly cosmetic, making it easier +-- to figure out where a Unique was born. See Note [Uniques and tags]. +-- +-- The payload part of the Uniques allocated from this UniqSupply are +-- guaranteed distinct wrt all other supplies, regardless of their "tag". +-- This is achieved by allocating the payload part from +-- a single source of Uniques, namely `genSym`, shared across +-- all UniqSupply's. + +-- See Note [How the unique supply works] +-- See Note [Optimising the unique supply] +mkSplitUniqSupply c + = unsafeDupableInterleaveIO (IO mk_supply) + + where + !tag = mkTag c + + -- Here comes THE MAGIC: see Note [How the unique supply works] + -- This is one of the most hammered bits in the whole compiler + -- See Note [Optimising the unique supply] + -- NB: Use noDuplicate# for thread-safety. + mk_supply s0 = + case noDuplicate# s0 of { s1 -> + case unIO genSym s1 of { (# s2, u #) -> + -- deferred IO computations + case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s2 of { (# s3, x #) -> + case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s3 of { (# s4, y #) -> + (# s4, MkSplitUniqSupply (tag .|. u) x y #) + }}}} + +#if defined(NO_FETCH_ADD) +-- GHC currently does not provide this operation on 32-bit platforms, +-- hence the CAS-based implementation. +fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld + -> (# State# RealWorld, Word64# #) +fetchAddWord64Addr# = go + where + go ptr inc s0 = + case readWord64OffAddr# ptr 0# s0 of + (# s1, n0 #) -> + case atomicCasWord64Addr# ptr n0 (n0 `plusWord64#` inc) s1 of + (# s2, res #) + | 1# <- res `eqWord64#` n0 -> (# s2, n0 #) + | otherwise -> go ptr inc s2 +#else +fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld + -> (# State# RealWorld, Word64# #) +fetchAddWord64Addr# addr inc s0 = + case fetchAddWordAddr# addr (word64ToWord# inc) s0 of + (# s1, res #) -> (# s1, wordToWord64# res #) +#endif + +genSym :: IO Word64 +genSym = do + let !mask = (1 `unsafeShiftL` uNIQUE_BITS) - 1 + let !(Ptr counter) = ghc_unique_counter64 + I# inc# <- peek ghc_unique_inc + let !inc = wordToWord64# (int2Word# inc#) + u <- IO $ \s1 -> case fetchAddWord64Addr# counter inc s1 of + (# s2, val #) -> + let !u = W64# (val `plusWord64#` inc) .&. mask + in (# s2, u #) +#if defined(DEBUG) + -- Uh oh! We will overflow next time a unique is requested. + -- (Note that if the increment isn't 1 we may miss this check) + massert (u /= mask) +#endif + return u + +foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64 +foreign import ccall unsafe "&ghc_unique_inc" ghc_unique_inc :: Ptr Int + +initUniqSupply :: Word64 -> Int -> IO () +initUniqSupply counter inc = do + poke ghc_unique_counter64 counter + poke ghc_unique_inc inc + +uniqFromTag :: Char -> IO Unique +uniqFromTag !tag + = do { uqNum <- genSym + ; return $! mkUnique tag uqNum } +{-# NOINLINE uniqFromTag #-} -- We'll unbox everything, but we don't want to inline it + +splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) +-- ^ Build two 'UniqSupply' from a single one, each of which +-- can supply its own 'Unique'. +listSplitUniqSupply :: UniqSupply -> [UniqSupply] +-- ^ Create an infinite list of 'UniqSupply' from a single one +uniqFromSupply :: UniqSupply -> Unique +-- ^ Obtain the 'Unique' from this particular 'UniqSupply' +uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite +-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply +takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) +-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply + +splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) +listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 + +uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n +uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 +takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) + +{-# INLINE splitUniqSupply #-} + +{- +************************************************************************ +* * +\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} +* * +************************************************************************ +-} + +type UniqResult result = (# result, UniqSupply #) + +pattern UniqResult :: a -> b -> (# a, b #) +pattern UniqResult x y = (# x, y #) +{-# COMPLETE UniqResult #-} + +-- | A monad which just gives the ability to obtain 'Unique's +newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } + deriving (Functor, Applicative, Monad) via (Strict.State UniqSupply) + +-- | Smart constructor for 'UniqSM', as described in Note [The one-shot state +-- monad trick]. +mkUniqSM :: (UniqSupply -> UniqResult a) -> UniqSM a +mkUniqSM f = USM (oneShot f) +{-# INLINE mkUniqSM #-} + +-- TODO: try to get rid of this instance +instance MonadFail UniqSM where + fail = panic + +-- | Run the 'UniqSM' action, returning the final 'UniqSupply' +initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) +initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) } + +-- | Run the 'UniqSM' action, discarding the final 'UniqSupply' +initUs_ :: UniqSupply -> UniqSM a -> a +initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r } + +liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) +liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1) + +instance MonadFix UniqSM where + mfix m = mkUniqSM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1) + +getUs :: UniqSM UniqSupply +getUs = mkUniqSM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2) + +-- | A monad for generating unique identifiers +class Monad m => MonadUnique m where + -- | Get a new UniqueSupply + getUniqueSupplyM :: m UniqSupply + -- | Get a new unique identifier + getUniqueM :: m Unique + -- | Get an infinite list of new unique identifiers + getUniquesM :: m [Unique] + + -- This default definition of getUniqueM, while correct, is not as + -- efficient as it could be since it needlessly generates and throws away + -- an extra Unique. For your instances consider providing an explicit + -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. + getUniqueM = liftM uniqFromSupply getUniqueSupplyM + getUniquesM = liftM uniqsFromSupply getUniqueSupplyM + +instance MonadUnique UniqSM where + getUniqueSupplyM = getUs + getUniqueM = getUniqueUs + getUniquesM = getUniquesUs + +getUniqueUs :: UniqSM Unique +getUniqueUs = mkUniqSM (\us0 -> case takeUniqFromSupply us0 of + (u,us1) -> UniqResult u us1) + +getUniquesUs :: UniqSM [Unique] +getUniquesUs = mkUniqSM (\us0 -> case splitUniqSupply us0 of + (us1,us2) -> UniqResult (uniqsFromSupply us1) us2) diff --git a/GHC/Types/Var.hs b/GHC/Types/Var.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Var.hs @@ -0,0 +1,1233 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{@Vars@: Variables} +-} + +{-# LANGUAGE MultiWayIf, PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE DeriveFunctor #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types" +-- +-- * 'GHC.Types.Name.Reader.RdrName': see "GHC.Types.Name.Reader#name_types" +-- +-- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types" +-- +-- * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types" +-- +-- * 'GHC.Types.Var.Var' is a synonym for the 'GHC.Types.Id.Id' type but it may additionally +-- potentially contain type variables, which have a 'GHC.Core.TyCo.Rep.Kind' +-- rather than a 'GHC.Core.TyCo.Rep.Type' and only contain some extra +-- details during typechecking. +-- +-- These 'Var' names may either be global or local, see "GHC.Types.Var#globalvslocal" +-- +-- #globalvslocal# +-- Global 'Id's and 'Var's are those that are imported or correspond +-- to a data constructor, primitive operation, or record selectors. +-- Local 'Id's and 'Var's are those bound within an expression +-- (e.g. by a lambda) or at the top level of the module being compiled. + +module GHC.Types.Var ( + -- * The main data type and synonyms + Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId, + TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar, + + -- * In and Out variants + InVar, InCoVar, InId, InTyVar, InTyCoVar, + OutVar, OutCoVar, OutId, OutTyVar, OutTyCoVar, + + -- ** Taking 'Var's apart + varName, varUnique, varType, + varMultMaybe, idMult, + + -- ** Modifying 'Var's + setVarName, setVarUnique, setVarType, + updateVarType, updateVarTypeM, + + -- ** Constructing, taking apart, modifying 'Id's + mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, + idInfo, idDetails, + lazySetIdInfo, setIdDetails, globaliseId, + setIdExported, setIdNotExported, setIdMult, + updateIdTypeButNotMult, + updateIdTypeAndMult, updateIdTypeAndMultM, + + -- ** Predicates + isId, isTyVar, isTcTyVar, + isLocalVar, isLocalId, isLocalId_maybe, isCoVar, isNonCoVarId, isTyCoVar, + isGlobalId, isExportedId, + mustHaveLocalBinding, + + -- * ForAllTyFlags + ForAllTyFlag(Invisible,Required,Specified,Inferred), + Specificity(..), + isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isInferredForAllTyFlag, + isSpecifiedForAllTyFlag, + coreTyLamForAllTyFlag, + + -- * FunTyFlag + FunTyFlag(..), isVisibleFunArg, isInvisibleFunArg, isFUNArg, + mkFunTyFlag, visArg, invisArg, + visArgTypeLike, visArgConstraintLike, + invisArgTypeLike, invisArgConstraintLike, + funTyFlagArgTypeOrConstraint, funTyFlagResultTypeOrConstraint, + TypeOrConstraint(..), -- Re-export this: it's an argument of FunTyFlag + + -- * PiTyBinder + PiTyBinder(..), PiTyVarBinder, + isInvisiblePiTyBinder, isInvisibleAnonPiTyBinder, + isVisiblePiTyBinder, + isTyBinder, isNamedPiTyBinder, isAnonPiTyBinder, + namedPiTyBinder_maybe, anonPiTyBinderType_maybe, piTyBinderType, + + -- * TyVar's + VarBndr(..), ForAllTyBinder, TyVarBinder, + InvisTyBinder, InvisTVBinder, ReqTyBinder, ReqTVBinder, + binderVar, binderVars, binderFlag, binderFlags, binderType, + mkForAllTyBinder, mkForAllTyBinders, + mkTyVarBinder, mkTyVarBinders, + isVisibleForAllTyBinder, isInvisibleForAllTyBinder, isTyVarBinder, + tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders, + mapVarBndr, mapVarBndrs, + + -- ** ExportFlag + ExportFlag(..), + + -- ** Constructing TyVar's + mkTyVar, mkTcTyVar, + + -- ** Taking 'TyVar's apart + tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, + + -- ** Modifying 'TyVar's + setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, + updateTyVarKindM, + + nonDetCmpVar + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind, Mult, Scaled, scaledThing ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr( pprKind ) +import {-# SOURCE #-} GHC.Tc.Utils.TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTvUnk ) +import {-# SOURCE #-} GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails, + vanillaIdInfo, pprIdDetails ) +import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) +import GHC.Types.Name hiding (varName) +import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique + , nonDetCmpUnique ) +import GHC.Types.Basic( TypeOrConstraint(..) ) +import GHC.Utils.Misc +import GHC.Utils.Binary +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Hs.Specificity () +import Language.Haskell.Syntax.Specificity +import Control.DeepSeq + +import Data.Data + +{- +************************************************************************ +* * + Synonyms +* * +************************************************************************ +-- These synonyms are here and not in Id because otherwise we need a very +-- large number of SOURCE imports of "GHC.Types.Id" :-( +-} + +-- | Identifier +type Id = Var -- A term-level identifier + -- predicate: isId + +-- | Coercion Variable +type CoVar = Id -- See Note [Evidence: EvIds and CoVars] + -- predicate: isCoVar + +-- | +type NcId = Id -- A term-level (value) variable that is + -- /not/ an (unlifted) coercion + -- predicate: isNonCoVarId + +-- | Type or kind Variable +type TyVar = Var -- Type *or* kind variable (historical) + +-- | Type or Kind Variable +type TKVar = Var -- Type *or* kind variable (historical) + +-- | Type variable that might be a metavariable +type TcTyVar = Var + +-- | Type Variable +type TypeVar = Var -- Definitely a type variable + +-- | Kind Variable +type KindVar = Var -- Definitely a kind variable + -- See Note [Kind and type variables] + +-- See Note [Evidence: EvIds and CoVars] +-- | Evidence Identifier +type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar + +-- | Evidence Variable +type EvVar = EvId -- ...historical name for EvId + +-- | Dictionary Function Identifier +type DFunId = Id -- A dictionary function + +-- | Dictionary Identifier +type DictId = EvId -- A dictionary variable + +-- | Implicit parameter Identifier +type IpId = EvId -- A term-level implicit parameter + +-- | Equality Variable +type EqVar = EvId -- Boxed equality evidence +type JoinId = Id -- A join variable + +-- | Type or Coercion Variable +type TyCoVar = Id -- Type, *or* coercion variable + -- predicate: isTyCoVar + + +{- Many passes apply a substitution, and it's very handy to have type + synonyms to remind us whether or not the substitution has been applied -} + +type InVar = Var +type InTyVar = TyVar +type InCoVar = CoVar +type InTyCoVar = TyCoVar +type InId = Id +type OutVar = Var +type OutTyVar = TyVar +type OutCoVar = CoVar +type OutTyCoVar = TyCoVar +type OutId = Id + + + +{- Note [Evidence: EvIds and CoVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* An EvId (evidence Id) is a term-level evidence variable + (dictionary, implicit parameter, or equality). Could be boxed or unboxed. + +* DictId, IpId, and EqVar are synonyms when we know what kind of + evidence we are talking about. For example, an EqVar has type (t1 ~ t2). + +* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2) + +Note [Kind and type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before kind polymorphism, TyVar were used to mean type variables. Now +they are used to mean kind *or* type variables. KindVar is used when we +know for sure that it is a kind variable. In future, we might want to +go over the whole compiler code to use: + - TKVar to mean kind or type variables + - TypeVar to mean type variables only + - KindVar to mean kind variables + + +************************************************************************ +* * +\subsection{The main data type declarations} +* * +************************************************************************ + + +Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a +@Type@, and an @IdInfo@ (non-essential info about it, e.g., +strictness). The essential info about different kinds of @Vars@ is +in its @VarDetails@. +-} + +-- | Variable +-- +-- Essentially a typed 'Name', that may also contain some additional information +-- about the 'Var' and its use sites. +data Var + = TyVar { -- Type and kind variables + -- see Note [Kind and type variables] + varName :: !Name, + realUnique :: {-# UNPACK #-} !Unique, + -- ^ Key for fast comparison + -- Identical to the Unique in the name, + -- cached here for speed + varType :: Kind -- ^ The type or kind of the 'Var' in question + } + + | TcTyVar { -- Used only during type inference + -- Used for kind variables during + -- inference, as well + varName :: !Name, + realUnique :: {-# UNPACK #-} !Unique, + varType :: Kind, + tc_tv_details :: TcTyVarDetails + } + + | Id { + varName :: !Name, + realUnique :: {-# UNPACK #-} !Unique, + varType :: Type, + varMult :: Mult, -- See Note [Multiplicity of let binders] + idScope :: IdScope, + id_details :: IdDetails, -- Stable, doesn't change + id_info :: IdInfo } -- Unstable, updated by simplifier + +-- | Identifier Scope +data IdScope -- See Note [GlobalId/LocalId] + = GlobalId + | LocalId ExportFlag + +data ExportFlag -- See Note [ExportFlag on binders] + = NotExported -- ^ Not exported: may be discarded as dead code. + | Exported -- ^ Exported: kept alive + +{- Note [ExportFlag on binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An ExportFlag of "Exported" on a top-level binder says "keep this +binding alive; do not drop it as dead code". This transitively +keeps alive all the other top-level bindings that this binding refers +to. This property is persisted all the way down the pipeline, so that +the binding will be compiled all the way to object code, and its +symbols will appear in the linker symbol table. + +However, note that this use of "exported" is quite different to the +export list on a Haskell module. Setting the ExportFlag on an Id does +/not/ mean that if you import the module (in Haskell source code) you +will see this Id. Of course, things that appear in the export list +of the source Haskell module do indeed have their ExportFlag set. +But many other things, such as dictionary functions, are kept alive +by having their ExportFlag set, even though they are not exported +in the source-code sense. + +We should probably use a different term for ExportFlag, like +KeepAlive. + +Note [GlobalId/LocalId] +~~~~~~~~~~~~~~~~~~~~~~~ +A GlobalId is + * always a constant (top-level) + * imported, or data constructor, or primop, or record selector + * has a Unique that is globally unique across the whole + GHC invocation (a single invocation may compile multiple modules) + * never treated as a candidate by the free-variable finder; + it's a constant! + +A LocalId is + * bound within an expression (lambda, case, local let(rec)) + * or defined at top level in the module being compiled + * always treated as a candidate by the free-variable finder + +In the output of CoreTidy, top level Ids are all GlobalIds, which are then +serialised into interface files. Do note however that CorePrep may introduce new +LocalIds for local floats (even at the top level). These will be visible in STG +and end up in generated code. + +Note [Multiplicity of let binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Core, let-binders' multiplicity is always completely determined by syntax: +a recursive let will always have multiplicity Many (it's a prerequisite for +being recursive), and non-recursive let doesn't have a conventional multiplicity, +instead they act, for the purpose of multiplicity, as an alias for their +right-hand side. + +Therefore, the `varMult` field of identifier is only used by binders in lambda +and case expressions. In a let expression the `varMult` field holds an +arbitrary value which will (and must!) be ignored. +-} + +instance Outputable Var where + ppr var = docWithStyle ppr_code ppr_normal + where + -- don't display debug info with Code style (#25255) + ppr_code = ppr (varName var) + ppr_normal sty = sdocOption sdocSuppressVarKinds $ \supp_var_kinds -> + getPprDebug $ \debug -> + let + ppr_var = case var of + (TyVar {}) + | debug + -> brackets (text "tv") + + (TcTyVar {tc_tv_details = d}) + | dumpStyle sty || debug + -> brackets (pprTcTyVarDetails d) + + (Id { idScope = s, id_details = d }) + | debug + -> brackets (ppr_id_scope s <> pprIdDetails d) + + _ -> empty + in if + | debug && (not supp_var_kinds) + -> parens (ppr (varName var) <+> ppr (varMultMaybe var) + <+> ppr_var <+> + dcolon <+> pprKind (tyVarKind var)) + | otherwise + -> ppr (varName var) <> ppr_var + +ppr_id_scope :: IdScope -> SDoc +ppr_id_scope GlobalId = text "gid" +ppr_id_scope (LocalId Exported) = text "lidx" +ppr_id_scope (LocalId NotExported) = text "lid" + +instance NamedThing Var where + getName = varName + +instance Uniquable Var where + getUnique = varUnique + +instance Eq Var where + a == b = realUnique a == realUnique b + +instance Ord Var where + a <= b = getKey (realUnique a) <= getKey (realUnique b) + a < b = getKey (realUnique a) < getKey (realUnique b) + a >= b = getKey (realUnique a) >= getKey (realUnique b) + a > b = getKey (realUnique a) > getKey (realUnique b) + a `compare` b = a `nonDetCmpVar` b + +-- | Compare Vars by their Uniques. +-- This is what Ord Var does, provided here to make it explicit at the +-- call-site that it can introduce non-determinism. +-- See Note [Unique Determinism] +nonDetCmpVar :: Var -> Var -> Ordering +nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b + +instance Data Var where + -- don't traverse? + toConstr _ = abstractConstr "Var" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Var" + +instance HasOccName Var where + occName = nameOccName . varName + +varUnique :: Var -> Unique +varUnique var = realUnique var + +varMultMaybe :: Id -> Maybe Mult +varMultMaybe (Id { varMult = mult }) = Just mult +varMultMaybe _ = Nothing + +idMult :: HasDebugCallStack => Id -> Mult +idMult (Id { varMult = mult }) = mult +idMult non_id = pprPanic "idMult" (ppr non_id) + +setVarUnique :: Var -> Unique -> Var +setVarUnique var uniq + = var { realUnique = uniq, + varName = setNameUnique (varName var) uniq } + +setVarName :: Var -> Name -> Var +setVarName var new_name + = var { realUnique = getUnique new_name, + varName = new_name } + +setVarType :: Var -> Type -> Var +setVarType id ty = id { varType = ty } + +-- | Update a 'Var's type. Does not update the /multiplicity/ +-- stored in an 'Id', if any. Because of the possibility for +-- abuse, ASSERTs that there is no multiplicity to update. +updateVarType :: (Type -> Type) -> Var -> Var +updateVarType upd var + = case var of + Id { id_details = details } -> assert (isCoVarDetails details) $ + result + _ -> result + where + result = var { varType = upd (varType var) } + +-- | Update a 'Var's type monadically. Does not update the /multiplicity/ +-- stored in an 'Id', if any. Because of the possibility for +-- abuse, ASSERTs that there is no multiplicity to update. +updateVarTypeM :: Monad m => (Type -> m Type) -> Var -> m Var +updateVarTypeM upd var + = case var of + Id { id_details = details } -> assert (isCoVarDetails details) $ + result + _ -> result + where + result = do { ty' <- upd (varType var) + ; return (var { varType = ty' }) } + +{- ********************************************************************* +* * +* FunTyFlag +* * +********************************************************************* -} + +-- | The non-dependent version of 'ForAllTyFlag'. +-- See Note [FunTyFlag] +-- Appears here partly so that it's together with its friends ForAllTyFlag +-- and ForallVisFlag, but also because it is used in IfaceType, rather +-- early in the compilation chain +data FunTyFlag + = FTF_T_T -- (->) Type -> Type + | FTF_T_C -- (-=>) Type -> Constraint + | FTF_C_T -- (=>) Constraint -> Type + | FTF_C_C -- (==>) Constraint -> Constraint + deriving (Eq, Ord, Data) + +instance Outputable FunTyFlag where + ppr FTF_T_T = text "[->]" + ppr FTF_T_C = text "[-=>]" + ppr FTF_C_T = text "[=>]" + ppr FTF_C_C = text "[==>]" + +instance Binary FunTyFlag where + put_ bh FTF_T_T = putByte bh 0 + put_ bh FTF_T_C = putByte bh 1 + put_ bh FTF_C_T = putByte bh 2 + put_ bh FTF_C_C = putByte bh 3 + + get bh = do + h <- getByte bh + case h of + 0 -> return FTF_T_T + 1 -> return FTF_T_C + 2 -> return FTF_C_T + _ -> return FTF_C_C + +instance NFData FunTyFlag where + rnf FTF_T_T = () + rnf FTF_T_C = () + rnf FTF_C_T = () + rnf FTF_C_C = () + +mkFunTyFlag :: TypeOrConstraint -> TypeOrConstraint -> FunTyFlag +mkFunTyFlag TypeLike torc = visArg torc +mkFunTyFlag ConstraintLike torc = invisArg torc + +visArg :: TypeOrConstraint -> FunTyFlag +visArg TypeLike = FTF_T_T +visArg ConstraintLike = FTF_T_C + +visArgTypeLike :: FunTyFlag +visArgTypeLike = FTF_T_T + +visArgConstraintLike :: FunTyFlag +visArgConstraintLike = FTF_T_C + +invisArg :: TypeOrConstraint -> FunTyFlag +invisArg TypeLike = FTF_C_T +invisArg ConstraintLike = FTF_C_C + +invisArgTypeLike :: FunTyFlag +invisArgTypeLike = FTF_C_T + +invisArgConstraintLike :: FunTyFlag +invisArgConstraintLike = FTF_C_C + +isInvisibleFunArg :: FunTyFlag -> Bool +isInvisibleFunArg af = not (isVisibleFunArg af) + +isVisibleFunArg :: FunTyFlag -> Bool +isVisibleFunArg FTF_T_T = True +isVisibleFunArg FTF_T_C = True +isVisibleFunArg _ = False + +isFUNArg :: FunTyFlag -> Bool +-- This one, FUN, or (->), has an extra multiplicity argument +isFUNArg FTF_T_T = True +isFUNArg _ = False + +funTyFlagArgTypeOrConstraint :: FunTyFlag -> TypeOrConstraint +-- Whether it /takes/ a type or a constraint +funTyFlagArgTypeOrConstraint FTF_T_T = TypeLike +funTyFlagArgTypeOrConstraint FTF_T_C = TypeLike +funTyFlagArgTypeOrConstraint _ = ConstraintLike + +funTyFlagResultTypeOrConstraint :: FunTyFlag -> TypeOrConstraint +-- Whether it /returns/ a type or a constraint +funTyFlagResultTypeOrConstraint FTF_T_T = TypeLike +funTyFlagResultTypeOrConstraint FTF_C_T = TypeLike +funTyFlagResultTypeOrConstraint _ = ConstraintLike + +{- Note [FunTyFlag] +~~~~~~~~~~~~~~~~~~~~~ +FunTyFlag is used principally in the FunTy constructor of Type. + FunTy FTF_T_T t1 t2 means t1 -> t2 + FunTy FTF_C_T t1 t2 means t1 => t2 + FunTy FTF_T_C t1 t2 means t1 -=> t2 + FunTy FTF_C_C t1 t2 means t1 ==> t2 + +However, the FunTyFlag in a FunTy is just redundant, cached +information. In (FunTy { ft_af = af, ft_arg = t1, ft_res = t2 }) + --------------------------------------------- + (isPredTy t1) (isPredTy ty) FunTyFlag + --------------------------------------------- + False False FTF_T_T + False True FTF_T_C + True False FTF_C_T + True True FTF_C_C +where isPredTy is defined in GHC.Core.Predicate, and sees if t1's +kind is Constraint. See GHC.Core.Type.chooseFunTyFlag, and +GHC.Core.Predicate Note [Types for coercions, predicates, and evidence] + +The term (Lam b e) doesn't carry an FunTyFlag; instead it uses +mkFunctionType when we want to get its types; see mkLamType. This is +just an engineering choice; we could cache here too if we wanted. + +Why bother with all this? After all, we are in Core, where (=>) and +(->) behave the same. We maintain this distinction throughout Core so +that we can cheaply and conveniently determine +* How to print a type +* How to split up a type: tcSplitSigmaTy +* How to specialise it (over type classes; GHC.Core.Opt.Specialise) + +For the specialisation point, consider +(\ (d :: Ord a). blah). We want to give it type + (Ord a => blah_ty) +with a fat arrow; that is, using mkInvisFunTy, not mkVisFunTy. +Why? Because the /specialiser/ treats dictionary arguments specially. +Suppose we do w/w on 'foo', thus (#11272, #6056) + foo :: Ord a => Int -> blah + foo a d x = case x of I# x' -> $wfoo @a d x' + + $wfoo :: Ord a => Int# -> blah + +Now, at a call we see (foo @Int dOrdInt). The specialiser will +specialise this to $sfoo, where + $sfoo :: Int -> blah + $sfoo x = case x of I# x' -> $wfoo @Int dOrdInt x' + +Now we /must/ also specialise $wfoo! But it wasn't user-written, +and has a type built with mkLamTypes. + +Conclusion: the easiest thing is to make mkLamType build + (c => ty) +when the argument is a predicate type. See GHC.Core.TyCo.Rep +Note [Types for coercions, predicates, and evidence] +-} + +{- ********************************************************************* +* * +* VarBndr, ForAllTyBinder +* * +********************************************************************* -} + +{- Note [The VarBndr type and its uses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +VarBndr is polymorphic in both var and visibility fields. +Currently there are nine different uses of 'VarBndr': + +* Var.ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag + Binder of a forall-type; see ForAllTy in GHC.Core.TyCo.Rep + +* Var.TyVarBinder = VarBndr TyVar ForAllTyFlag + Subset of ForAllTyBinder when we are sure the binder is a TyVar + +* Var.InvisTVBinder = VarBndr TyVar Specificity + Specialised form of TyVarBinder, when ForAllTyFlag = Invisible s + See GHC.Core.Type.splitForAllInvisTVBinders + +* Var.ReqTVBinder = VarBndr TyVar () + Specialised form of TyVarBinder, when ForAllTyFlag = Required + See GHC.Core.Type.splitForAllReqTVBinders + This one is barely used + +* TyCon.TyConBinder = VarBndr TyVar TyConBndrVis + Binders of a TyCon; see TyCon in GHC.Core.TyCon + +* IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ForAllTyFlag +* IfaceType.IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity +* IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +-} + +data VarBndr var argf = Bndr var argf + -- See Note [The VarBndr type and its uses] + deriving( Data, Eq, Ord) + +-- | Variable Binder +-- +-- A 'ForAllTyBinder' is the binder of a ForAllTy +-- It's convenient to define this synonym here rather its natural +-- home in "GHC.Core.TyCo.Rep", because it's used in GHC.Core.DataCon.hs-boot +-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] +-- +-- A 'TyVarBinder' is a binder with only TyVar +type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag +type InvisTyBinder = VarBndr TyCoVar Specificity +type ReqTyBinder = VarBndr TyCoVar () + +type TyVarBinder = VarBndr TyVar ForAllTyFlag +type InvisTVBinder = VarBndr TyVar Specificity +type ReqTVBinder = VarBndr TyVar () + +tyVarSpecToBinders :: [VarBndr a Specificity] -> [VarBndr a ForAllTyFlag] +tyVarSpecToBinders = map tyVarSpecToBinder + +tyVarSpecToBinder :: VarBndr a Specificity -> VarBndr a ForAllTyFlag +tyVarSpecToBinder (Bndr tv vis) = Bndr tv (Invisible vis) + +tyVarReqToBinders :: [VarBndr a ()] -> [VarBndr a ForAllTyFlag] +tyVarReqToBinders = map tyVarReqToBinder + +tyVarReqToBinder :: VarBndr a () -> VarBndr a ForAllTyFlag +tyVarReqToBinder (Bndr tv _) = Bndr tv Required + +isVisibleForAllTyBinder :: ForAllTyBinder -> Bool +isVisibleForAllTyBinder (Bndr _ vis) = isVisibleForAllTyFlag vis + +isInvisibleForAllTyBinder :: ForAllTyBinder -> Bool +isInvisibleForAllTyBinder (Bndr _ vis) = isInvisibleForAllTyFlag vis + +binderVar :: VarBndr tv argf -> tv +binderVar (Bndr v _) = v + +binderVars :: [VarBndr tv argf] -> [tv] +binderVars tvbs = map binderVar tvbs + +binderFlag :: VarBndr tv argf -> argf +binderFlag (Bndr _ argf) = argf + +binderFlags :: [VarBndr tv argf] -> [argf] +binderFlags tvbs = map binderFlag tvbs + +binderType :: VarBndr TyCoVar argf -> Type +binderType (Bndr tv _) = varType tv + +isTyVarBinder :: VarBndr TyCoVar vis -> Bool +isTyVarBinder (Bndr tcv _) = isTyVar tcv + +-- | Make a named binder +mkForAllTyBinder :: vis -> TyCoVar -> VarBndr TyCoVar vis +mkForAllTyBinder vis var = Bndr var vis + +-- | Make a named binder +-- 'var' should be a type variable +mkTyVarBinder :: vis -> TyVar -> VarBndr TyVar vis +mkTyVarBinder vis var + = assert (isTyVar var) $ + Bndr var vis + +-- | Make many named binders +mkForAllTyBinders :: vis -> [TyCoVar] -> [VarBndr TyCoVar vis] +mkForAllTyBinders vis = map (mkForAllTyBinder vis) + +-- | Make many named binders +-- Input vars should be type variables +mkTyVarBinders :: vis -> [TyVar] -> [VarBndr TyVar vis] +mkTyVarBinders vis = map (mkTyVarBinder vis) + +mapVarBndr :: (var -> var') -> (VarBndr var flag) -> (VarBndr var' flag) +mapVarBndr f (Bndr v fl) = Bndr (f v) fl + +mapVarBndrs :: (var -> var') -> [VarBndr var flag] -> [VarBndr var' flag] +mapVarBndrs f = map (mapVarBndr f) + +instance Outputable tv => Outputable (VarBndr tv ForAllTyFlag) where + ppr (Bndr v Required) = ppr v + ppr (Bndr v Specified) = char '@' <> ppr v + ppr (Bndr v Inferred) = braces (ppr v) + +instance Outputable tv => Outputable (VarBndr tv Specificity) where + ppr = ppr . tyVarSpecToBinder + +instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where + put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } + + get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } + +instance (NFData tv, NFData vis) => NFData (VarBndr tv vis) where + rnf (Bndr tv vis) = rnf tv `seq` rnf vis + +instance NamedThing tv => NamedThing (VarBndr tv flag) where + getName (Bndr tv _) = getName tv + + +{- ********************************************************************** +* * + PiTyBinder +* * +********************************************************************** -} + +-- | A 'PiTyBinder' represents an argument to a function. PiTyBinders can be +-- dependent ('Named') or nondependent ('Anon'). They may also be visible or +-- not. See Note [PiTyBinders] +data PiTyBinder + = Named ForAllTyBinder -- A type-lambda binder, with a ForAllTyFlag + | Anon (Scaled Type) FunTyFlag -- A term-lambda binder. Type here can be CoercionTy. + -- The arrow is described by the FunTyFlag + deriving Data + +instance Outputable PiTyBinder where + ppr (Anon ty af) = ppr af <+> ppr ty + ppr (Named (Bndr v Required)) = ppr v + ppr (Named (Bndr v Specified)) = char '@' <> ppr v + ppr (Named (Bndr v Inferred)) = braces (ppr v) + +-- | 'PiTyVarBinder' is like 'PiTyBinder', but there can only be 'TyVar' +-- in the 'Named' field. +type PiTyVarBinder = PiTyBinder + +-- | Does this binder bind an invisible argument? +isInvisiblePiTyBinder :: PiTyBinder -> Bool +isInvisiblePiTyBinder (Named (Bndr _ vis)) = isInvisibleForAllTyFlag vis +isInvisiblePiTyBinder (Anon _ af) = isInvisibleFunArg af + +isInvisibleAnonPiTyBinder :: PiTyBinder -> Bool +isInvisibleAnonPiTyBinder (Named {}) = False +isInvisibleAnonPiTyBinder (Anon _ af) = isInvisibleFunArg af + +-- | Does this binder bind a visible argument? +isVisiblePiTyBinder :: PiTyBinder -> Bool +isVisiblePiTyBinder = not . isInvisiblePiTyBinder + +isNamedPiTyBinder :: PiTyBinder -> Bool +isNamedPiTyBinder (Named {}) = True +isNamedPiTyBinder (Anon {}) = False + +namedPiTyBinder_maybe :: PiTyBinder -> Maybe TyCoVar +namedPiTyBinder_maybe (Named tv) = Just $ binderVar tv +namedPiTyBinder_maybe _ = Nothing + +-- | Does this binder bind a variable that is /not/ erased? Returns +-- 'True' for anonymous binders. +isAnonPiTyBinder :: PiTyBinder -> Bool +isAnonPiTyBinder (Named {}) = False +isAnonPiTyBinder (Anon {}) = True + +-- | Extract a relevant type, if there is one. +anonPiTyBinderType_maybe :: PiTyBinder -> Maybe Type +anonPiTyBinderType_maybe (Named {}) = Nothing +anonPiTyBinderType_maybe (Anon ty _) = Just (scaledThing ty) + +-- | If its a named binder, is the binder a tyvar? +-- Returns True for nondependent binder. +-- This check that we're really returning a *Ty*Binder (as opposed to a +-- coercion binder). That way, if/when we allow coercion quantification +-- in more places, we'll know we missed updating some function. +isTyBinder :: PiTyBinder -> Bool +isTyBinder (Named bnd) = isTyVarBinder bnd +isTyBinder _ = True + +piTyBinderType :: PiTyBinder -> Type +piTyBinderType (Named (Bndr tv _)) = varType tv +piTyBinderType (Anon ty _) = scaledThing ty + +{- Note [PiTyBinders] +~~~~~~~~~~~~~~~~~~~ +But a type like + forall a. Maybe a -> forall b. (a,b) -> b + +can be decomposed to a telescope of type [PiTyBinder], using splitPiTys. +That function splits off all leading foralls and arrows, giving + ([Named a, Anon (Maybe a), Named b, Anon (a,b)], b) + +A PiTyBinder represents the type of binders -- that is, the type of an +argument to a Pi-type. GHC Core currently supports two different +Pi-types: + + * Anon ty1 fun_flag: a non-dependent function type, + written with ->, e.g. ty1 -> ty2 + represented as FunTy ty1 ty2. These are + lifted to Coercions with the corresponding FunCo. + + * Named (Var tv forall_flag) + A dependent compile-time-only polytype, + written with forall, e.g. forall (a:*). ty + represented as ForAllTy (Bndr a v) ty + +Both forms of Pi-types classify terms/types that take an argument. In other +words, if `x` is either a function or a polytype, `x arg` makes sense +(for an appropriate `arg`). + +Wrinkles + +* The Anon constructor of PiTyBinder contains a FunTyFlag. Since + the PiTyBinder really only describes the /argument/ it should perhaps + only have a TypeOrConstraint rather than a full FunTyFlag. But it's + very convenient to have the full FunTyFlag, say in mkPiTys, so that's + what we do. + + +Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A ForAllTy (used for both types and kinds) contains a ForAllTyBinder. + Each ForAllTyBinder + Bndr a tvis + is equipped with tvis::ForAllTyFlag, which says whether or not arguments + for this binder should be visible (explicit) in source Haskell. + +* A TyCon contains a list of TyConBinders. Each TyConBinder + Bndr a cvis + is equipped with cvis::TyConBndrVis, which says whether or not type + and kind arguments for this TyCon should be visible (explicit) in + source Haskell. + +This table summarises the visibility rules: +--------------------------------------------------------------------------------------- +| Occurrences look like this +| GHC displays type as in Haskell source code +|-------------------------------------------------------------------------------------- +| Bndr a tvis :: ForAllTyBinder, in the binder of ForAllTy for a term +| tvis :: ForAllTyFlag +| tvis = Inferred: f :: forall {a}. type Arg not allowed: f + f :: forall {co}. type Arg not allowed: f +| tvis = Specified: f :: forall a. type Arg optional: f or f @Int +| tvis = Required: f :: forall k -> type Arg required: f (type Int) +| +| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon +| cvis :: TyConBndrVis +| cvis = AnonTCB: T :: kind -> kind Required: T * +| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T +| T :: forall {co}. kind Arg not allowed: T +| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T +| cvis = NamedTCB Required: T :: forall k -> kind Required: T * +--------------------------------------------------------------------------------------- + +[1] In types, in the Specified case, it would make sense to allow + optional kind applications, thus (T @*), but we have not + yet implemented that + +---- In term declarations ---- + +* Inferred. Function defn, with no signature: f1 x = x + We infer f1 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because it doesn't appear in any + user-written signature for f1 + +* Specified. Function defn, with signature (implicit forall): + f2 :: a -> a; f2 x = x + So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified + even though 'a' is not bound in the source code by an explicit forall + +* Specified. Function defn, with signature (explicit forall): + f3 :: forall a. a -> a; f3 x = x + So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified + +* Required. Function defn, with signature (explicit forall): + f4 :: forall a -> a -> a; f4 (type _) x = x + So f4 gets the type f4 :: forall a -> a -> a, with 'a' Required + This is the experimental RequiredTypeArguments extension, + see GHC Proposal #281 "Visible forall in types of terms" + +* Inferred. Function defn, with signature (explicit forall), marked as inferred: + f5 :: forall {a}. a -> a; f5 x = x + So f5 gets the type f5 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because the user marked it as such, even though it does appear + in the user-written signature for f5 + +* Inferred/Specified. Function signature with inferred kind polymorphism. + f6 :: a b -> Int + So 'f6' gets the type f6 :: forall {k} (a :: k -> Type) (b :: k). a b -> Int + Here 'k' is Inferred (it's not mentioned in the type), + but 'a' and 'b' are Specified. + +* Specified. Function signature with explicit kind polymorphism + f7 :: a (b :: k) -> Int + This time 'k' is Specified, because it is mentioned explicitly, + so we get f7 :: forall (k :: Type) (a :: k -> Type) (b :: k). a b -> Int + +* Similarly pattern synonyms: + Inferred - from inferred types (e.g. no pattern type signature) + - or from inferred kind polymorphism + +---- In type declarations ---- + +* Inferred (k) + data T1 a b = MkT1 (a b) + Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * + The kind variable 'k' is Inferred, since it is not mentioned + + Note that 'a' and 'b' correspond to /Anon/ PiTyBinders in T1's kind, + and Anon binders don't have a visibility flag. (Or you could think + of Anon having an implicit Required flag.) + +* Specified (k) + data T2 (a::k->*) b = MkT (a b) + Here T's kind is T :: forall (k:*). (k->*) -> k -> * + The kind variable 'k' is Specified, since it is mentioned in + the signature. + +* Required (k) + data T k (a::k->*) b = MkT (a b) + Here T's kind is T :: forall k:* -> (k->*) -> k -> * + The kind is Required, since it bound in a positional way in T's declaration + Every use of T must be explicitly applied to a kind + +* Inferred (k1), Specified (k) + data T a b (c :: k) = MkT (a b) (Proxy c) + Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * + So 'k' is Specified, because it appears explicitly, + but 'k1' is Inferred, because it does not + +Generally, in the list of TyConBinders for a TyCon, + +* Inferred arguments always come first +* Specified, Anon and Required can be mixed + +e.g. + data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... + +Here Foo's TyConBinders are + [Required 'a', Specified 'b', Anon] +and its kind prints as + Foo :: forall a -> forall b. (a -> b -> Type) -> Type + +See also Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + +---- Printing ----- + + We print forall types with enough syntax to tell you their visibility + flag. But this is not source Haskell, and these types may not all + be parsable. + + Specified: a list of Specified binders is written between `forall` and `.`: + const :: forall a b. a -> b -> a + + Inferred: like Specified, but every binder is written in braces: + f :: forall {k} (a :: k). S k a -> Int + + Required: binders are put between `forall` and `->`: + T :: forall k -> * + +---- Other points ----- + +* In classic Haskell, all named binders (that is, the type variables in + a polymorphic function type f :: forall a. a -> a) have been Inferred. + +* Inferred variables correspond to "generalized" variables from the + Visible Type Applications paper (ESOP'16). +-} + + + +{- +************************************************************************ +* * +* Type and kind variables * +* * +************************************************************************ +-} + +tyVarName :: TyVar -> Name +tyVarName = varName + +tyVarKind :: TyVar -> Kind +tyVarKind = varType + +setTyVarUnique :: TyVar -> Unique -> TyVar +setTyVarUnique = setVarUnique + +setTyVarName :: TyVar -> Name -> TyVar +setTyVarName = setVarName + +setTyVarKind :: TyVar -> Kind -> TyVar +setTyVarKind tv k = tv {varType = k} + +updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar +updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} + +updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar +updateTyVarKindM update tv + = do { k' <- update (tyVarKind tv) + ; return $ tv {varType = k'} } + +mkTyVar :: Name -> Kind -> TyVar +mkTyVar name kind = TyVar { varName = name + , realUnique = nameUnique name + , varType = kind + } + +mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar +mkTcTyVar name kind details + = -- NB: 'kind' may be a coercion kind; cf, 'GHC.Tc.Utils.TcMType.newMetaCoVar' + TcTyVar { varName = name, + realUnique = nameUnique name, + varType = kind, + tc_tv_details = details + } + +tcTyVarDetails :: TyVar -> TcTyVarDetails +-- See Note [TcTyVars and TyVars in the typechecker] in GHC.Tc.Utils.TcType +tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details +-- MP: This should never happen, but it does. Future work is to turn this into a panic. +tcTyVarDetails (TyVar {}) = vanillaSkolemTvUnk +tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var)) + +setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar +setTcTyVarDetails tv details = tv { tc_tv_details = details } + +{- +%************************************************************************ +%* * +\subsection{Ids} +* * +************************************************************************ +-} + +idInfo :: HasDebugCallStack => Id -> IdInfo +idInfo (Id { id_info = info }) = info +idInfo other = pprPanic "idInfo" (ppr other) + +idDetails :: HasCallStack => Id -> IdDetails +idDetails (Id { id_details = details }) = details +idDetails other = pprPanic "idDetails" (ppr other) + +-- The next three have a 'Var' suffix even though they always build +-- Ids, because "GHC.Types.Id" uses 'mkGlobalId' etc with different types +mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalVar details name ty info + = mk_id name manyDataConTy ty GlobalId details info + -- There is no support for linear global variables yet. They would require + -- being checked at link-time, which can be useful, but is not a priority. + +mkLocalVar :: IdDetails -> Name -> Mult -> Type -> IdInfo -> Id +mkLocalVar details name w ty info + = mk_id name w ty (LocalId NotExported) details info + +mkCoVar :: Name -> Type -> CoVar +-- Coercion variables have no IdInfo +mkCoVar name ty = mk_id name manyDataConTy ty (LocalId NotExported) coVarDetails vanillaIdInfo + +-- | Exported 'Var's will not be removed as dead code +mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkExportedLocalVar details name ty info + = mk_id name manyDataConTy ty (LocalId Exported) details info + -- There is no support for exporting linear variables. See also [mkGlobalVar] + +mk_id :: Name -> Mult -> Type -> IdScope -> IdDetails -> IdInfo -> Id +mk_id name !w ty scope details info + = Id { varName = name, + realUnique = nameUnique name, + varMult = w, + varType = ty, + idScope = scope, + id_details = details, + id_info = info } + +------------------- +lazySetIdInfo :: Id -> IdInfo -> Var +lazySetIdInfo id info = id { id_info = info } + +setIdDetails :: Id -> IdDetails -> Id +setIdDetails id details = id { id_details = details } + +globaliseId :: Id -> Id +-- ^ If it's a local, make it global +globaliseId id = id { idScope = GlobalId } + +setIdExported :: Id -> Id +-- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors +-- and class operations, which are born as global 'Id's and automatically exported +setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } +setIdExported id@(Id { idScope = GlobalId }) = id +setIdExported tv = pprPanic "setIdExported" (ppr tv) + +setIdNotExported :: Id -> Id +-- ^ We can only do this to LocalIds +setIdNotExported id = assert (isLocalId id) $ + id { idScope = LocalId NotExported } + +----------------------- +updateIdTypeButNotMult :: (Type -> Type) -> Id -> Id +updateIdTypeButNotMult f id = id { varType = f (varType id) } + + +updateIdTypeAndMult :: (Type -> Type) -> Id -> Id +updateIdTypeAndMult f id@(Id { varType = ty + , varMult = mult }) + = id { varType = ty' + , varMult = mult' } + where + !ty' = f ty + !mult' = f mult +updateIdTypeAndMult _ other = pprPanic "updateIdTypeAndMult" (ppr other) + +updateIdTypeAndMultM :: Monad m => (Type -> m Type) -> Id -> m Id +updateIdTypeAndMultM f id@(Id { varType = ty + , varMult = mult }) + = do { !ty' <- f ty + ; !mult' <- f mult + ; return (id { varType = ty', varMult = mult' }) } +updateIdTypeAndMultM _ other = pprPanic "updateIdTypeAndMultM" (ppr other) + +setIdMult :: Id -> Mult -> Id +setIdMult id !r | isId id = id { varMult = r } + | otherwise = pprPanic "setIdMult" (ppr id <+> ppr r) + +{- +************************************************************************ +* * +\subsection{Predicates over variables} +* * +************************************************************************ +-} + +-- | Is this a type-level (i.e., computationally irrelevant, thus erasable) +-- variable? Satisfies @isTyVar = not . isId@. +isTyVar :: Var -> Bool -- True of both TyVar and TcTyVar +isTyVar (TyVar {}) = True +isTyVar (TcTyVar {}) = True +isTyVar _ = False + +isTcTyVar :: Var -> Bool -- True of TcTyVar only +isTcTyVar (TcTyVar {}) = True +isTcTyVar _ = False + +isTyCoVar :: Var -> Bool +isTyCoVar v = isTyVar v || isCoVar v + +-- | Is this a value-level (i.e., computationally relevant) 'Id'entifier? +-- Satisfies @isId = not . isTyVar@. +isId :: Var -> Bool +isId (Id {}) = True +isId _ = False + +-- | Is this a coercion variable? +-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. +isCoVar :: Var -> Bool +isCoVar (Id { id_details = details }) = isCoVarDetails details +isCoVar _ = False + +-- | Is this a term variable ('Id') that is /not/ a coercion variable? +-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. +isNonCoVarId :: Var -> Bool +isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details) +isNonCoVarId _ = False + +isLocalId :: Var -> Bool +isLocalId (Id { idScope = LocalId _ }) = True +isLocalId _ = False + +isLocalId_maybe :: Var -> Maybe ExportFlag +isLocalId_maybe (Id { idScope = LocalId ef }) = Just ef +isLocalId_maybe _ = Nothing + +-- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's +-- These are the variables that we need to pay attention to when finding free +-- variables, or doing dependency analysis. +isLocalVar :: Var -> Bool +isLocalVar v = not (isGlobalId v) + +isGlobalId :: Var -> Bool +isGlobalId (Id { idScope = GlobalId }) = True +isGlobalId _ = False + +-- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's +-- that must have a binding in this module. The converse +-- is not quite right: there are some global 'Id's that must have +-- bindings, such as record selectors. But that doesn't matter, +-- because it's only used for assertions +mustHaveLocalBinding :: Var -> Bool +mustHaveLocalBinding var = isLocalVar var + +-- | 'isExportedIdVar' means \"don't throw this away\" +isExportedId :: Var -> Bool +isExportedId (Id { idScope = GlobalId }) = True +isExportedId (Id { idScope = LocalId Exported}) = True +isExportedId _ = False diff --git a/GHC/Types/Var.hs-boot b/GHC/Types/Var.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/Var.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE NoPolyKinds #-} +module GHC.Types.Var where + +import {-# SOURCE #-} GHC.Types.Name +import Language.Haskell.Syntax.Specificity (Specificity, ForAllTyFlag) + +data FunTyFlag +data Var +instance NamedThing Var +data VarBndr var argf +type TyVar = Var +type Id = Var +type TyCoVar = Id +type TcTyVar = Var +type InvisTVBinder = VarBndr TyVar Specificity +type TyVarBinder = VarBndr TyVar ForAllTyFlag diff --git a/GHC/Types/Var/Env.hs b/GHC/Types/Var/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Var/Env.hs @@ -0,0 +1,703 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Types.Var.Env ( + -- * Var, Id and TyVar environments (maps) + VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv, + + -- ** Manipulating these environments + emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, + elemVarEnv, disjointVarEnv, anyVarEnv, + extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, + extendVarEnvList, + plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, + plusVarEnvList, alterVarEnv, + delVarEnvList, delVarEnv, + minusVarEnv, + lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, + lookupVarEnv_Directly, + mapVarEnv, zipVarEnv, + modifyVarEnv, modifyVarEnv_Directly, + isEmptyVarEnv, + elemVarEnvByKey, + filterVarEnv, restrictVarEnv, + partitionVarEnv, varEnvDomain, + nonDetStrictFoldVarEnv_Directly, + + -- * Deterministic Var environments (maps) + DVarEnv, DIdEnv, DTyVarEnv, + + -- ** Manipulating these environments + emptyDVarEnv, mkDVarEnv, + dVarEnvElts, + extendDVarEnv, extendDVarEnv_C, + extendDVarEnvList, + lookupDVarEnv, elemDVarEnv, + isEmptyDVarEnv, foldDVarEnv, nonDetStrictFoldDVarEnv, + mapDVarEnv, filterDVarEnv, + modifyDVarEnv, + alterDVarEnv, + plusDVarEnv, plusDVarEnv_C, + unitDVarEnv, + delDVarEnv, + delDVarEnvList, + minusDVarEnv, + partitionDVarEnv, + anyDVarEnv, + + -- * The InScopeSet type + InScopeSet(..), + + -- ** Operations on InScopeSets + emptyInScopeSet, mkInScopeSet, mkInScopeSetList, delInScopeSet, + extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, + getInScopeVars, lookupInScope, lookupInScope_Directly, + unionInScope, elemInScopeSet, uniqAway, + varSetInScope, + unsafeGetFreshLocalUnique, + + -- * The RnEnv2 type + RnEnv2, + + -- ** Operations on RnEnv2s + mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, + rnOccL, rnOccR, inRnEnvL, inRnEnvR, anyInRnEnvR, + rnOccL_maybe, rnOccR_maybe, + rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, + delBndrL, delBndrR, delBndrsL, delBndrsR, + extendRnInScopeSetList, + rnEtaL, rnEtaR, + rnInScope, rnInScopeSet, lookupRnInScope, + rnEnvL, rnEnvR, + + -- * TidyEnv and its operation + TidyEnv, + emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList, + mapMaybeDVarEnv + ) where + +import GHC.Prelude +import qualified GHC.Data.Word64Map.Strict as Word64Map -- TODO: Move this to UniqFM + +import GHC.Types.Name.Occurrence +import GHC.Types.Name +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Data.Graph.UnVar -- UnVarSet +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Data.Maybe +import GHC.Utils.Outputable + +{- +************************************************************************ +* * + In-scope sets +* * +************************************************************************ +-} + +-- | A set of variables that are in scope at some point. +-- +-- Note that this is a /superset/ of the variables that are currently in scope. +-- See Note [The InScopeSet invariant]. +-- +-- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides +-- the motivation for this abstraction. +newtype InScopeSet = InScope VarSet + -- Note [Lookups in in-scope set] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We store a VarSet here, but we use this for lookups rather than just + -- membership tests. Typically the InScopeSet contains the canonical + -- version of the variable (e.g. with an informative unfolding), so this + -- lookup is useful (see, for instance, Note [In-scope set as a + -- substitution]). + + -- Note [The InScopeSet invariant] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- The InScopeSet must include every in-scope variable, but it may also + -- include other variables. + + -- Its principal purpose is to provide a set of variables to be avoided + -- when creating a fresh identifier (fresh in the sense that it does not + -- "shadow" any in-scope binding). To do this we simply have to find one that + -- does not appear in the InScopeSet. This is done by the key function + -- GHC.Types.Var.Env.uniqAway. + + -- See "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 + -- for more detailed motivation. #20419 has further discussion. + + +instance Outputable InScopeSet where + ppr (InScope s) = + text "InScope" <+> + braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) + -- It's OK to use nonDetEltsUniqSet here because it's + -- only for pretty printing + -- In-scope sets get big, and with -dppr-debug + -- the output is overwhelming + +emptyInScopeSet :: InScopeSet +emptyInScopeSet = InScope emptyVarSet + +getInScopeVars :: InScopeSet -> VarSet +getInScopeVars (InScope vs) = vs + +mkInScopeSet :: VarSet -> InScopeSet +mkInScopeSet in_scope = InScope in_scope + +mkInScopeSetList :: [Var] -> InScopeSet +mkInScopeSetList vs = InScope (mkVarSet vs) + +extendInScopeSet :: InScopeSet -> Var -> InScopeSet +extendInScopeSet (InScope in_scope) v + = InScope (extendVarSet in_scope v) + +extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet +extendInScopeSetList (InScope in_scope) vs + = InScope $ foldl' extendVarSet in_scope vs + +extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet +extendInScopeSetSet (InScope in_scope) vs + = InScope (in_scope `unionVarSet` vs) + +delInScopeSet :: InScopeSet -> Var -> InScopeSet +delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v) + +elemInScopeSet :: Var -> InScopeSet -> Bool +elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope + +-- | Look up a variable the 'InScopeSet'. This lets you map from +-- the variable's identity (unique) to its full value. +lookupInScope :: InScopeSet -> Var -> Maybe Var +lookupInScope (InScope in_scope) v = lookupVarSet in_scope v + +lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var +lookupInScope_Directly (InScope in_scope) uniq + = lookupVarSet_Directly in_scope uniq + +unionInScope :: InScopeSet -> InScopeSet -> InScopeSet +unionInScope (InScope s1) (InScope s2) + = InScope (s1 `unionVarSet` s2) + +varSetInScope :: VarSet -> InScopeSet -> Bool +varSetInScope vars (InScope s1) = vars `subVarSet` s1 + +{- +Note [Local uniques] +~~~~~~~~~~~~~~~~~~~~ +Sometimes one must create conjure up a unique which is unique in a particular +context (but not necessarily globally unique). For instance, one might need to +create a fresh local identifier which does not shadow any of the locally +in-scope variables. For this we purpose we provide 'uniqAway'. + +'uniqAway' is implemented in terms of the 'unsafeGetFreshLocalUnique' +operation, which generates an unclaimed 'Unique' from an 'InScopeSet'. To +ensure that we do not conflict with uniques allocated by future allocations +from 'UniqSupply's, Uniques generated by 'unsafeGetFreshLocalUnique' are +allocated into a dedicated region of the unique space (namely the X tag). + +Note that one must be quite carefully when using uniques generated in this way +since they are only locally unique. In particular, two successive calls to +'uniqAway' on the same 'InScopeSet' will produce the same unique. + -} + +-- | @uniqAway in_scope v@ finds a unique that is not used in the +-- in-scope set, and gives that to v. See Note [Local uniques] and +-- Note [The InScopeSet invariant]. +uniqAway :: InScopeSet -> Var -> Var +-- It starts with v's current unique, of course, in the hope that it won't +-- have to change, and thereafter uses the successor to the last derived unique +-- found in the in-scope set. +uniqAway in_scope var + | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one + | otherwise = var -- Nothing to do + +uniqAway' :: InScopeSet -> Var -> Var +-- This one *always* makes up a new variable +uniqAway' in_scope var + = setVarUnique var (unsafeGetFreshLocalUnique in_scope) + +-- | @unsafeGetFreshUnique in_scope@ finds a unique that is not in-scope in the +-- given 'InScopeSet'. This must be used very carefully since one can very easily +-- introduce non-unique 'Unique's this way. See Note [Local uniques]. +unsafeGetFreshLocalUnique :: InScopeSet -> Unique +unsafeGetFreshLocalUnique (InScope set) + | Just (uniq,_) <- Word64Map.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set) + , let uniq' = mkLocalUnique uniq + , not $ uniq' `ltUnique` minLocalUnique + = incrUnique uniq' + + | otherwise + = minLocalUnique + +{- +************************************************************************ +* * + Dual renaming +* * +************************************************************************ +-} + +-- | Rename Environment 2 +-- +-- When we are comparing (or matching) types or terms, we are faced with +-- \"going under\" corresponding binders. E.g. when comparing: +-- +-- > \x. e1 ~ \y. e2 +-- +-- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of +-- things we must be careful of. In particular, @x@ might be free in @e2@, or +-- y in @e1@. So the idea is that we come up with a fresh binder that is free +-- in neither, and rename @x@ and @y@ respectively. That means we must maintain: +-- +-- 1. A renaming for the left-hand expression +-- +-- 2. A renaming for the right-hand expressions +-- +-- 3. An in-scope set +-- +-- Furthermore, when matching, we want to be able to have an 'occurs check', +-- to prevent: +-- +-- > \x. f ~ \y. y +-- +-- matching with [@f@ -> @y@]. So for each expression we want to know that set of +-- locally-bound variables. That is precisely the domain of the mappings 1. +-- and 2., but we must ensure that we always extend the mappings as we go in. +-- +-- All of this information is bundled up in the 'RnEnv2' +data RnEnv2 + = RV2 { envL :: VarEnv Var -- Renaming for Left term + , envR :: VarEnv Var -- Renaming for Right term + , in_scope :: InScopeSet } -- In scope in left or right terms + +-- The renamings envL and envR are *guaranteed* to contain a binding +-- for every variable bound as we go into the term, even if it is not +-- renamed. That way we can ask what variables are locally bound +-- (inRnEnvL, inRnEnvR) + +mkRnEnv2 :: InScopeSet -> RnEnv2 +mkRnEnv2 vars = RV2 { envL = emptyVarEnv + , envR = emptyVarEnv + , in_scope = vars } + +extendRnInScopeSetList :: RnEnv2 -> [Var] -> RnEnv2 +extendRnInScopeSetList env vs + | null vs = env + | otherwise = env { in_scope = extendInScopeSetList (in_scope env) vs } + +rnInScope :: Var -> RnEnv2 -> Bool +rnInScope x env = x `elemInScopeSet` in_scope env + +rnInScopeSet :: RnEnv2 -> InScopeSet +rnInScopeSet = in_scope + +-- | Retrieve the left mapping +rnEnvL :: RnEnv2 -> VarEnv Var +rnEnvL = envL + +-- | Retrieve the right mapping +rnEnvR :: RnEnv2 -> VarEnv Var +rnEnvR = envR + +rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 +-- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length +rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR + +rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 +-- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, +-- and binder @bR@ in the Right term. +-- It finds a new binder, @new_b@, +-- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ +rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR + +rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but returns the new variable as well as the +-- new environment. +-- Postcondition: the type of the returned Var is that of bR +rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR + = (RV2 { envL = extendVarEnv envL bL new_b -- See Note + , envR = extendVarEnv envR bR new_b -- [Rebinding] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + -- Find a new binder not in scope in either term + -- To avoid calling `uniqAway`, we try bL's Unique + -- But we always return a Var whose type is that of bR + new_b | not (bR `elemInScopeSet` in_scope) = bR + | not (bL `elemInScopeSet` in_scope) = bR `setVarUnique` varUnique bL + | otherwise = uniqAway' in_scope bR + + -- Note [Rebinding] + -- ~~~~~~~~~~~~~~~~ + -- If the new var is the same as the old one, note that + -- the extendVarEnv *replaces* any current renaming + -- E.g. (\x. \x. ...) ~ (\y. \z. ...) + -- + -- envL envR in_scope + -- Inside \x \y { [x->y], [y->y], {y} } + -- \x \z { [x->z], [y->y, z->z], {y,z} } + -- The envL binding [x->y] is replaced by [x->z] + +rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the left +-- side only. +rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = envR + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the right +-- side only. +rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envR = extendVarEnv envR bR new_b + , envL = envL + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndrL' but used for eta expansion +-- See Note [Eta expansion] +rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used for eta expansion +-- See Note [Eta expansion] +rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] + , envR = extendVarEnv envR bR new_b + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 +delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } +delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } + +delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 +delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } +delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } + +rnOccL, rnOccR :: RnEnv2 -> Var -> Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v +rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v + +rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v +rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v + +inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool +-- ^ Tells whether a variable is locally bound +inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env +inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env + +-- | `anyInRnEnvR env set` == `any (inRnEnvR rn_env) (toList set)` +-- but lazy in the second argument if the right side of the env is empty. +anyInRnEnvR :: RnEnv2 -> VarSet -> Bool +anyInRnEnvR (RV2 { envR = env }) vs + -- Avoid allocating the predicate if we deal with an empty env. + | isEmptyVarEnv env = False + | otherwise = anyVarSet (`elemVarEnv` env) vs + +lookupRnInScope :: RnEnv2 -> Var -> Var +lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v + +nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 +-- ^ Wipe the left or right side renaming +nukeRnEnvL env = env { envL = emptyVarEnv } +nukeRnEnvR env = env { envR = emptyVarEnv } + +rnSwap :: RnEnv2 -> RnEnv2 +-- ^ swap the meaning of left and right +rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope }) + = RV2 { envL = envR, envR = envL, in_scope = in_scope } + +{- +Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~ +When matching + (\x.M) ~ N +we rename x to x' with, where x' is not in scope in +either term. Then we want to behave as if we'd seen + (\x'.M) ~ (\x'.N x') +Since x' isn't in scope in N, the form (\x'. N x') doesn't +capture any variables in N. But we must nevertheless extend +the envR with a binding [x' -> x'], to support the occurs check. +For example, if we don't do this, we can get silly matches like + forall a. (\y.a) ~ v +succeeding with [a -> v y], which is bogus of course. + + +************************************************************************ +* * + Tidying +* * +************************************************************************ +-} + +-- | Tidy Environment +-- +-- When tidying up print names, we keep a mapping of in-scope occ-names +-- (the 'TidyOccEnv') and a Var-to-Var of the current renamings +type TidyEnv = (TidyOccEnv, VarEnv Var) + +emptyTidyEnv :: TidyEnv +emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) + +mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv +mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv) + +delTidyEnvList :: TidyEnv -> [Var] -> TidyEnv +delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env') + where + occ_env' = occ_env `delTidyOccEnvList` map getOccName vs + var_env' = var_env `delVarEnvList` vs + +{- +************************************************************************ +* * + VarEnv +* * +************************************************************************ +-} + +-- We would like this to be `UniqFM Var elt` +-- but the code uses various key types. +-- So for now make it explicitly untyped + +-- | Variable Environment +type VarEnv elt = UniqFM Var elt + +-- | Identifier Environment +type IdEnv elt = UniqFM Id elt + +-- | Type Variable Environment +type TyVarEnv elt = UniqFM Var elt + +-- | Type or Coercion Variable Environment +type TyCoVarEnv elt = UniqFM TyCoVar elt + +-- | Coercion Variable Environment +type CoVarEnv elt = UniqFM CoVar elt + +emptyVarEnv :: VarEnv a +mkVarEnv :: [(Var, a)] -> VarEnv a +mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a +zipVarEnv :: [Var] -> [a] -> VarEnv a +unitVarEnv :: Var -> a -> VarEnv a +alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a +extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b +plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +plusVarEnvList :: [VarEnv a] -> VarEnv a +extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a +varEnvDomain :: VarEnv elt -> UnVarSet + +partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) +-- | Only keep variables contained in the VarSet +restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a +delVarEnvList :: Foldable f => VarEnv a -> f Var -> VarEnv a +delVarEnv :: VarEnv a -> Var -> VarEnv a +minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a +plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a +plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a +mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b +modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a + +isEmptyVarEnv :: VarEnv a -> Bool +lookupVarEnv :: VarEnv a -> Var -> Maybe a +lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a +filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a +anyVarEnv :: (elt -> Bool) -> UniqFM key elt -> Bool +lookupVarEnv_NF :: VarEnv a -> Var -> a +lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a +elemVarEnv :: Var -> VarEnv a -> Bool +elemVarEnvByKey :: Unique -> VarEnv a -> Bool +disjointVarEnv :: VarEnv a -> VarEnv a -> Bool +nonDetStrictFoldVarEnv_Directly :: (Unique -> a -> r -> r) -> r -> VarEnv a -> r + +elemVarEnv = elemUFM +elemVarEnvByKey = elemUFM_Directly +disjointVarEnv = disjointUFM +alterVarEnv = alterUFM +extendVarEnv = addToUFM +extendVarEnv_C = addToUFM_C +extendVarEnv_Acc = addToUFM_Acc +extendVarEnvList = addListToUFM +plusVarEnv_C = plusUFM_C +plusVarEnv_CD = plusUFM_CD +plusMaybeVarEnv_C = plusMaybeUFM_C +delVarEnvList = delListFromUFM +-- INLINE due to polymorphism +{-# INLINE delVarEnvList #-} +delVarEnv = delFromUFM +minusVarEnv = minusUFM +plusVarEnv = plusUFM +plusVarEnvList = plusUFMList +-- lookupVarEnv is very hot (in part due to being called by substTyVar), +-- if it's not inlined than the mere allocation of the Just constructor causes +-- perf benchmarks to regress by 2% in some cases. See #21159, !7638 and containers#821 +-- for some more explanation about what exactly went wrong. +{-# INLINE lookupVarEnv #-} +lookupVarEnv = lookupUFM +lookupVarEnv_Directly = lookupUFM_Directly +filterVarEnv = filterUFM +anyVarEnv = anyUFM +lookupWithDefaultVarEnv = lookupWithDefaultUFM +mapVarEnv = mapUFM +mkVarEnv = listToUFM +mkVarEnv_Directly= listToUFM_Directly +emptyVarEnv = emptyUFM +unitVarEnv = unitUFM +isEmptyVarEnv = isNullUFM +partitionVarEnv = partitionUFM +varEnvDomain = domUFMUnVarSet +nonDetStrictFoldVarEnv_Directly = nonDetStrictFoldUFM_Directly + + +restrictVarEnv env vs = filterUFM_Directly keep env + where + keep u _ = u `elemVarSetByKey` vs + +zipVarEnv tyvars tys = mkVarEnv (zipEqual tyvars tys) +lookupVarEnv_NF env id = case lookupVarEnv env id of + Just xx -> xx + Nothing -> panic "lookupVarEnv_NF: Nothing" + + +{- +@modifyVarEnv@: Look up a thing in the VarEnv, +then mash it with the modify function, and put it back. +-} + +modifyVarEnv mangle_fn env key + = case (lookupVarEnv env key) of + Nothing -> env + Just xx -> extendVarEnv env key (mangle_fn xx) + +modifyVarEnv_Directly :: (a -> a) -> UniqFM key a -> Unique -> UniqFM key a +modifyVarEnv_Directly mangle_fn env key + = case (lookupUFM_Directly env key) of + Nothing -> env + Just xx -> addToUFM_Directly env key (mangle_fn xx) + +{- +************************************************************************ +* * + Deterministic VarEnv (DVarEnv) +* * +************************************************************************ +-} +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need +-- DVarEnv. + +-- | Deterministic Variable Environment +type DVarEnv elt = UniqDFM Var elt + +-- | Deterministic Identifier Environment +-- Sadly not always indexed by Id, but it is in the common case. +type DIdEnv elt = UniqDFM Var elt + +-- | Deterministic Type Variable Environment +type DTyVarEnv elt = UniqDFM TyVar elt + +emptyDVarEnv :: DVarEnv a +emptyDVarEnv = emptyUDFM + +dVarEnvElts :: DVarEnv a -> [a] +dVarEnvElts = eltsUDFM + +mkDVarEnv :: [(Var, a)] -> DVarEnv a +mkDVarEnv = listToUDFM + +extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a +extendDVarEnv = addToUDFM + +minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a +minusDVarEnv = minusUDFM + +lookupDVarEnv :: DVarEnv a -> Var -> Maybe a +lookupDVarEnv = lookupUDFM + +foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b +foldDVarEnv = foldUDFM + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b +nonDetStrictFoldDVarEnv = nonDetStrictFoldUDFM + +mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b +mapDVarEnv = mapUDFM + +filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a +filterDVarEnv = filterUDFM + +mapMaybeDVarEnv :: (a -> Maybe b) -> DVarEnv a -> DVarEnv b +mapMaybeDVarEnv f = mapMaybeUDFM f + +alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a +alterDVarEnv = alterUDFM + +plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a +plusDVarEnv = plusUDFM + +plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a +plusDVarEnv_C = plusUDFM_C + +unitDVarEnv :: Var -> a -> DVarEnv a +unitDVarEnv = unitUDFM + +delDVarEnv :: DVarEnv a -> Var -> DVarEnv a +delDVarEnv = delFromUDFM + +delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a +delDVarEnvList = delListFromUDFM + +isEmptyDVarEnv :: DVarEnv a -> Bool +isEmptyDVarEnv = isNullUDFM + +elemDVarEnv :: Var -> DVarEnv a -> Bool +elemDVarEnv = elemUDFM + +extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a +extendDVarEnv_C = addToUDFM_C + +modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a +modifyDVarEnv mangle_fn env key + = case (lookupDVarEnv env key) of + Nothing -> env + Just xx -> extendDVarEnv env key (mangle_fn xx) + +partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a) +partitionDVarEnv = partitionUDFM + +extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a +extendDVarEnvList = addListToUDFM + +anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool +anyDVarEnv = anyUDFM diff --git a/GHC/Types/Var/Set.hs b/GHC/Types/Var/Set.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Var/Set.hs @@ -0,0 +1,366 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + + + +module GHC.Types.Var.Set ( + -- * Var, Id and TyVar set types + VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet, + + -- ** Manipulating these sets + emptyVarSet, unitVarSet, mkVarSet, + extendVarSet, extendVarSetList, + elemVarSet, subVarSet, + unionVarSet, unionVarSets, mapUnionVarSet, + intersectVarSet, intersectsVarSet, disjointVarSet, + isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, + minusVarSet, filterVarSet, mapVarSet, + anyVarSet, allVarSet, + transCloVarSet, fixVarSet, + lookupVarSet_Directly, lookupVarSet, lookupVarSetByName, + sizeVarSet, seqVarSet, + elemVarSetByKey, partitionVarSet, + pluralVarSet, pprVarSet, + nonDetStrictFoldVarSet, + + -- * Deterministic Var set types + DVarSet, DIdSet, DTyVarSet, DCoVarSet, DTyCoVarSet, + + -- ** Manipulating these sets + emptyDVarSet, unitDVarSet, mkDVarSet, + extendDVarSet, extendDVarSetList, + elemDVarSet, dVarSetElems, subDVarSet, + unionDVarSet, unionDVarSets, mapUnionDVarSet, + intersectDVarSet, dVarSetIntersectVarSet, + intersectsDVarSet, disjointDVarSet, + isEmptyDVarSet, delDVarSet, delDVarSetList, + minusDVarSet, + nonDetStrictFoldDVarSet, + filterDVarSet, mapDVarSet, strictFoldDVarSet, + dVarSetMinusVarSet, anyDVarSet, allDVarSet, + transCloDVarSet, + sizeDVarSet, seqDVarSet, + partitionDVarSet, + dVarSetToVarSet, + ) where + +import GHC.Prelude + +import GHC.Types.Var ( Var, TyVar, CoVar, TyCoVar, Id ) +import GHC.Types.Unique +import GHC.Types.Name ( Name ) +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet +import GHC.Types.Unique.FM( disjointUFM, pluralUFM, pprUFM ) +import GHC.Types.Unique.DFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM ) +import GHC.Utils.Outputable (SDoc) + +-- | A non-deterministic Variable Set +-- +-- A non-deterministic set of variables. +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why it's not +-- deterministic and why it matters. Use DVarSet if the set eventually +-- gets converted into a list or folded over in a way where the order +-- changes the generated code, for example when abstracting variables. +type VarSet = UniqSet Var + +-- | Identifier Set +type IdSet = UniqSet Id + +-- | Type Variable Set +type TyVarSet = UniqSet TyVar + +-- | Coercion Variable Set +type CoVarSet = UniqSet CoVar + +-- | Type or Coercion Variable Set +type TyCoVarSet = UniqSet TyCoVar + +emptyVarSet :: VarSet +intersectVarSet :: VarSet -> VarSet -> VarSet +unionVarSet :: VarSet -> VarSet -> VarSet +unionVarSets :: [VarSet] -> VarSet + +mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet +-- ^ map the function over the list, and union the results + +unitVarSet :: Var -> VarSet +extendVarSet :: VarSet -> Var -> VarSet +extendVarSetList:: VarSet -> [Var] -> VarSet +elemVarSet :: Var -> VarSet -> Bool +delVarSet :: VarSet -> Var -> VarSet +delVarSetList :: VarSet -> [Var] -> VarSet +minusVarSet :: VarSet -> VarSet -> VarSet +isEmptyVarSet :: VarSet -> Bool +mkVarSet :: [Var] -> VarSet +lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var +lookupVarSet :: VarSet -> Var -> Maybe Var + -- Returns the set element, which may be + -- (==) to the argument, but not the same as +lookupVarSetByName :: VarSet -> Name -> Maybe Var +sizeVarSet :: VarSet -> Int +filterVarSet :: (Var -> Bool) -> VarSet -> VarSet + +delVarSetByKey :: VarSet -> Unique -> VarSet +elemVarSetByKey :: Unique -> VarSet -> Bool +partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) + +emptyVarSet = emptyUniqSet +unitVarSet = unitUniqSet +extendVarSet = addOneToUniqSet +extendVarSetList= addListToUniqSet +intersectVarSet = intersectUniqSets + +intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection +disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection +subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second + -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; + -- ditto disjointVarSet, subVarSet + +unionVarSet = unionUniqSets +unionVarSets = unionManyUniqSets +elemVarSet = elementOfUniqSet +minusVarSet = minusUniqSet +delVarSet = delOneFromUniqSet +delVarSetList = delListFromUniqSet +isEmptyVarSet = isEmptyUniqSet +mkVarSet = mkUniqSet +lookupVarSet_Directly = lookupUniqSet_Directly +lookupVarSet = lookupUniqSet +lookupVarSetByName set name = lookupUniqSet_Directly set (getUnique name) +sizeVarSet = sizeUniqSet +filterVarSet = filterUniqSet +delVarSetByKey = delOneFromUniqSet_Directly +elemVarSetByKey = elemUniqSet_Directly +partitionVarSet = partitionUniqSet + +mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs + +-- See comments with type signatures +intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) +disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2) +subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) + +anyVarSet :: (Var -> Bool) -> VarSet -> Bool +anyVarSet = uniqSetAny + +allVarSet :: (Var -> Bool) -> VarSet -> Bool +allVarSet = uniqSetAll + +mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b +mapVarSet = mapUniqSet + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldVarSet :: (Var -> a -> a) -> a -> VarSet -> a +nonDetStrictFoldVarSet = nonDetStrictFoldUniqSet + +fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set + -> VarSet -> VarSet +-- (fixVarSet f s) repeatedly applies f to the set s, +-- until it reaches a fixed point. +fixVarSet fn vars + | new_vars `subVarSet` vars = vars + | otherwise = fixVarSet fn new_vars + where + new_vars = fn vars + +transCloVarSet :: (VarSet -> VarSet) + -- Map some variables in the set to + -- extra variables that should be in it + -> VarSet -> VarSet +-- (transCloVarSet f s) repeatedly applies f to new candidates, adding any +-- new variables to s that it finds thereby, until it reaches a fixed point. +-- +-- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) +-- for efficiency, so that the test can be batched up. +-- It's essential that fn will work fine if given new candidates +-- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 +-- Use fixVarSet if the function needs to see the whole set all at once +transCloVarSet fn seeds + = go seeds seeds + where + go :: VarSet -- Accumulating result + -> VarSet -- Work-list; un-processed subset of accumulating result + -> VarSet + -- Specification: go acc vs = acc `union` transClo fn vs + + go acc candidates + | isEmptyVarSet new_vs = acc + | otherwise = go (acc `unionVarSet` new_vs) new_vs + where + new_vs = fn candidates `minusVarSet` acc + +seqVarSet :: VarSet -> () +seqVarSet s = s `seq` () + +-- | Determines the pluralisation suffix appropriate for the length of a set +-- in the same way that plural from Outputable does for lists. +pluralVarSet :: VarSet -> SDoc +pluralVarSet = pluralUFM . getUniqSet + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetEltsUFM. +-- Passing a list to the pretty-printing function allows the caller +-- to decide on the order of Vars (eg. toposort them) without them having +-- to use nonDetEltsUFM at the call site. This prevents from let-binding +-- non-deterministically ordered lists and reusing them where determinism +-- matters. +pprVarSet :: VarSet -- ^ The things to be pretty printed + -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the + -- elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprVarSet = pprUFM . getUniqSet + +-- Deterministic VarSet +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need +-- DVarSet. + +-- | Deterministic Variable Set +type DVarSet = UniqDSet Var + +-- | Deterministic Identifier Set +type DIdSet = UniqDSet Id + +-- | Deterministic Type Variable Set +type DTyVarSet = UniqDSet TyVar + +-- | Deterministic Coercion Variable Set +type DCoVarSet = UniqDSet CoVar + +-- | Deterministic Type or Coercion Variable Set +type DTyCoVarSet = UniqDSet TyCoVar + +emptyDVarSet :: DVarSet +emptyDVarSet = emptyUniqDSet + +unitDVarSet :: Var -> DVarSet +unitDVarSet = unitUniqDSet + +mkDVarSet :: [Var] -> DVarSet +mkDVarSet = mkUniqDSet + +-- The new element always goes to the right of existing ones. +extendDVarSet :: DVarSet -> Var -> DVarSet +extendDVarSet = addOneToUniqDSet + +elemDVarSet :: Var -> DVarSet -> Bool +elemDVarSet = elementOfUniqDSet + +dVarSetElems :: DVarSet -> [Var] +dVarSetElems = uniqDSetToList + +subDVarSet :: DVarSet -> DVarSet -> Bool +subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2) + +unionDVarSet :: DVarSet -> DVarSet -> DVarSet +unionDVarSet = unionUniqDSets + +unionDVarSets :: [DVarSet] -> DVarSet +unionDVarSets = unionManyUniqDSets + +-- | Map the function over the list, and union the results +mapUnionDVarSet :: (a -> DVarSet) -> [a] -> DVarSet +mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs + +intersectDVarSet :: DVarSet -> DVarSet -> DVarSet +intersectDVarSet = intersectUniqDSets + +dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet +dVarSetIntersectVarSet = uniqDSetIntersectUniqSet + +-- | True if empty intersection +disjointDVarSet :: DVarSet -> DVarSet -> Bool +disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2) + +-- | True if non-empty intersection +intersectsDVarSet :: DVarSet -> DVarSet -> Bool +intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2) + +isEmptyDVarSet :: DVarSet -> Bool +isEmptyDVarSet = isEmptyUniqDSet + +delDVarSet :: DVarSet -> Var -> DVarSet +delDVarSet = delOneFromUniqDSet + +minusDVarSet :: DVarSet -> DVarSet -> DVarSet +minusDVarSet = minusUniqDSet + +dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet +dVarSetMinusVarSet = uniqDSetMinusUniqSet + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a +nonDetStrictFoldDVarSet = nonDetStrictFoldUniqDSet + +anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool +anyDVarSet p = anyUDFM p . getUniqDSet + +allDVarSet :: (Var -> Bool) -> DVarSet -> Bool +allDVarSet p = allUDFM p . getUniqDSet + +mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b +mapDVarSet = mapUniqDSet + +strictFoldDVarSet :: (a -> r -> r) -> r -> UniqDSet a -> r +strictFoldDVarSet = strictFoldUniqDSet + +filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet +filterDVarSet = filterUniqDSet + +sizeDVarSet :: DVarSet -> Int +sizeDVarSet = sizeUniqDSet + +-- | Partition DVarSet according to the predicate given +partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet) +partitionDVarSet = partitionUniqDSet + +-- | Delete a list of variables from DVarSet +delDVarSetList :: DVarSet -> [Var] -> DVarSet +delDVarSetList = delListFromUniqDSet + +seqDVarSet :: DVarSet -> () +seqDVarSet s = s `seq` () + +-- | Add a list of variables to DVarSet +extendDVarSetList :: DVarSet -> [Var] -> DVarSet +extendDVarSetList = addListToUniqDSet + +-- | Convert a DVarSet to a VarSet by forgetting the order of insertion +dVarSetToVarSet :: DVarSet -> VarSet +dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm . getUniqDSet + +-- | transCloVarSet for DVarSet +transCloDVarSet :: (DVarSet -> DVarSet) + -- Map some variables in the set to + -- extra variables that should be in it + -> DVarSet -> DVarSet +-- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any +-- new variables to s that it finds thereby, until it reaches a fixed point. +-- +-- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) +-- for efficiency, so that the test can be batched up. +-- It's essential that fn will work fine if given new candidates +-- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 +transCloDVarSet fn seeds + = go seeds seeds + where + go :: DVarSet -- Accumulating result + -> DVarSet -- Work-list; un-processed subset of accumulating result + -> DVarSet + -- Specification: go acc vs = acc `union` transClo fn vs + + go acc candidates + | isEmptyDVarSet new_vs = acc + | otherwise = go (acc `unionDVarSet` new_vs) new_vs + where + new_vs = fn candidates `minusDVarSet` acc diff --git a/GHC/Unit.hs b/GHC/Unit.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE FlexibleInstances #-} + +-- | Units are library components from Cabal packages compiled and installed in +-- a database +module GHC.Unit + ( module GHC.Unit.Types + , module GHC.Unit.Info + , module GHC.Unit.Parser + , module GHC.Unit.State + , module GHC.Unit.Module + , module GHC.Unit.Home + ) +where + +import GHC.Unit.Types +import GHC.Unit.Info +import GHC.Unit.Parser +import GHC.Unit.Module +import GHC.Unit.Home +import GHC.Unit.State + +{- +Note [About units] +~~~~~~~~~~~~~~~~~~ +Haskell users are used to manipulating Cabal packages. These packages are +identified by: + - a package name :: String + - a package version :: Version + - (a revision number, when they are registered on Hackage) + +Cabal packages may contain several components (libraries, programs, +testsuites). In GHC we are mostly interested in libraries because those are +the components that can be depended upon by other components. Components in a +package are identified by their component name. Historically only one library +component was allowed per package, hence it didn't need a name. For this +reason, component name may be empty for one library component in each +package: + - a component name :: Maybe String + +UnitId +------ + +Cabal libraries can be compiled in various ways (different compiler options +or Cabal flags, different dependencies, etc.), hence using package name, +package version and component name isn't enough to identify a built library. +We use another identifier called UnitId: + + package name \ + package version | ________ + component name | hash of all this ==> | UnitId | + Cabal flags | -------- + compiler options | + dependencies' UnitId / + +Fortunately GHC doesn't have to generate these UnitId: they are provided by +external build tools (e.g. Cabal) with `-this-unit-id` command-line parameter. + +UnitIds are important because they are used to generate internal names +(symbols, etc.). + +Wired-in units +-------------- + +Certain libraries (ghc-prim, base, etc.) are known to the compiler and to the +RTS as they provide some basic primitives. Hence UnitIds of wired-in libraries +are fixed. Instead of letting Cabal choose the UnitId for these libraries, their +.cabal file uses the following stanza to force it to a specific value: + + ghc-options: -this-unit-id ghc-prim -- taken from ghc-prim.cabal + +The RTS also uses entities of wired-in units by directly referring to symbols +such as "base_GHCziIOziException_heapOverflow_closure" where the prefix is +the UnitId of "base" unit. + +Unit databases +-------------- + +Units are stored in databases in order to be reused by other codes: + + UnitKey ---> UnitInfo { exposed modules, package name, package version + component name, various file paths, + dependencies :: [UnitKey], etc. } + +Because of the wired-in units described above, we can't exactly use UnitIds +as UnitKeys in the database: if we did this, we could only have a single unit +(compiled library) in the database for each wired-in library. As we want to +support databases containing several different units for the same wired-in +library, we do this: + + * for non wired-in units: + * UnitId = UnitKey = Identifier (hash) computed by Cabal + + * for wired-in units: + * UnitKey = Identifier computed by Cabal (just like for non wired-in units) + * UnitId = unit-id specified with -this-unit-id command-line flag + +We can expose several units to GHC via the `package-id ` command-line +parameter. We must use the UnitKeys of the units so that GHC can find them in +the database. + +During unit loading, GHC replaces UnitKeys with UnitIds. It identifies wired +units by their package name (stored in their UnitInfo) and uses wired-in UnitIds +for them. + +For example, knowing that "base", "ghc-prim" and "rts" are wired-in units, the +following dependency graph expressed with database UnitKeys will be transformed +into a similar graph expressed with UnitIds: + + UnitKeys + ~~~~~~~~ ----------> rts-1.0-hashABC <-- + | | + | | + foo-2.0-hash123 --> base-4.1-hashXYZ ---> ghc-prim-0.5.3-hashUVW + + UnitIds + ~~~~~~~ ---------------> rts <-- + | | + | | + foo-2.0-hash123 --> base ---------------> ghc-prim + + +Note that "foo-2.0-hash123" isn't wired-in so its UnitId is the same as its UnitKey. + + +Module signatures / indefinite units / instantiated units +--------------------------------------------------------- + +GHC distinguishes two kinds of units: + + * definite units: + * units without module holes and with definite dependencies + * can be compiled into machine code (.o/.a/.so/.dll/...) + + * indefinite units: + * units with some module holes or with some indefinite dependencies + * can only be type-checked + +Module holes are constrained by module signatures (.hsig files). Module +signatures are a kind of interface (similar to .hs-boot files). They are used in +place of some real code. GHC allows modules from other units to be used to fill +these module holes: the process is called "unit/module instantiation". The +instantiating module may either be a concrete module or a module signature. In +the latter case, the signatures are merged to form a new one. + +You can think of this as polymorphism at the module level: module signatures +give constraints on the "type" of module that can be used to fill the hole +(where "type" means types of the exported module entities, etc.). + +Module signatures contain enough information (datatypes, abstract types, type +synonyms, classes, etc.) to typecheck modules depending on them but not +enough to compile them. As such, indefinite units found in databases only +provide module interfaces (the .hi ones this time), not object code. + +Unit instantiation / on-the-fly instantiation +--------------------------------------------- + +Indefinite units can be instantiated with modules from other units. The +instantiating units can also be instantiated themselves (if there are +indefinite) and so on. + +On-the-fly unit instantiation is a tricky optimization explained in +http://blog.ezyang.com/2016/08/optimizing-incremental-compilation +Here is a summary: + + 1. Indefinite units can only be type-checked, not compiled into real code. + Type-checking produces interface files (.hi) which are incomplete for code + generation (they lack unfoldings, etc.) but enough to perform type-checking + of units depending on them. + + 2. Type-checking an instantiated unit is cheap as we only have to merge + interface files (.hi) of the instantiated unit and of the instantiating + units, hence it can be done on-the-fly. Interface files of the dependencies + can be concrete or produced on-the-fly recursively. + + 3. When we compile a unit, we mustn't use interfaces produced by the + type-checker (on-the-fly or not) for the instantiated unit dependencies + because they lack some information. + + 4. When we type-check an indefinite unit, we must be consistent about the + interfaces we use for each dependency: only those produced by the + type-checker (on-the-fly or not) or only those produced after a full + compilation, but not both at the same time. + + It can be tricky if we have the following kind of dependency graph: + + X (indefinite) ------> D (definite, compiled) -----> I (instantiated, definite, compiled) + |----------------------------------------------------^ + + Suppose we want to type-check unit X which depends on unit I and D: + * I is definite and compiled: we have compiled .hi files for its modules on disk + * I is instantiated: it is cheap to produce type-checker .hi files for its modules on-the-fly + + But we must not do: + + X (indefinite) ------> D (definite, compiled) -----> I (instantiated, definite, compiled) + |--------------------------------------------------> I (instantiated on-the-fly) + + ==> inconsistent module interfaces for I + + Nor: + + X (indefinite) ------> D (definite, compiled) -------v + |--------------------------------------------------> I (instantiated on-the-fly) + + ==> D's interfaces may refer to things that only exist in I's *compiled* interfaces + + An alternative would be to store both type-checked and compiled interfaces + for every compiled non-instantiated unit (instantiated unit can be done + on-the-fly) so that we could use type-checked interfaces of D in the + example above. But it would increase compilation time and unit size. + + +The 'Unit' datatype represents a unit which may have been instantiated +on-the-fly: + + data Unit = RealUnit DefUnitId -- use compiled interfaces on disk + | VirtUnit InstantiatedUnit -- use on-the-fly instantiation + +'InstantiatedUnit' has two interesting fields: + + * instUnitInstanceOf :: UnitId + -- ^ the indefinite unit that is instantiated + + * instUnitInsts :: [(ModuleName,(Unit,ModuleName)] + -- ^ a list of instantiations, where an instantiation is: + (module hole name, (instantiating unit, instantiating module name)) + +A 'VirtUnit' may be indefinite or definite, it depends on whether some holes +remain in the instantiated unit OR in the instantiating units (recursively). +Having a fully instantiated (i.e. definite) virtual unit can lead to some issues +if there is a matching compiled unit in the preload closure. See Note [VirtUnit +to RealUnit improvement] + +Unit database and indefinite units +---------------------------------- + +We don't store partially instantiated units in the unit database. Units in the +database are either: + + * definite (fully instantiated or without holes): in this case we have + *compiled* module interfaces (.hi) and object codes (.o/.a/.so/.dll/...). + + * fully indefinite (not instantiated at all): in this case we only have + *type-checked* module interfaces (.hi). + +Note that indefinite units are stored as an instantiation of themselves where +each instantiating module is a module variable (see Note [Representation of +module/name variables]). E.g. + + "xyz" (UnitKey) ---> UnitInfo { instanceOf = "xyz" + , instantiatedWith = [A=,B=...] + , ... + } + +Note that non-instantiated units are also stored as an instantiation of +themselves. It is a reminiscence of previous terminology (when "instanceOf" was +"componentId"). E.g. + + "xyz" (UnitKey) ---> UnitInfo { instanceOf = "xyz" + , instantiatedWith = [] + , ... + } + +TODO: We should probably have `instanceOf :: Maybe UnitId` instead. + + +Note [Pretty-printing UnitId] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When we pretty-print a UnitId for the user, we try to map it back to its origin +package name, version and component to print "package-version:component" instead +of some hash. How to retrieve these information from a UnitId? + +Solution 0: ask for a UnitState to be passed each time we want to pretty-print a +SDoc so that the Outputable instance for UnitId could retrieve the information +from it. That what we used in the past: a DynFlags was passed and the UnitState +was retrieved from it. This is wrong for several reasons: + + 1. The UnitState is accessed when the message is printed, not when it is + generated. So we could imagine that the UnitState could have changed + in-between. Especially if we want to allow unit unloading. + + 2. We want GHC to support several independent sessions at once, hence + several UnitState. This approach supposes there is a unique UnitState + (the one given at printing-time), moreover a UnitId doesn't indicate + which UnitState it comes from (think about statically defined UnitId for + wired-in units). + +Solution 1: an obvious approach would be to store the required information in +the UnitId itself. However it doesn't work because some UnitId are defined +statically for wired-in units and the same UnitId can map to different units in +different contexts. This solution would make wired-in units harder to deal with. + +Solution 2: another approach would be to thread the UnitState to all places +where a UnitId is pretty-printed and to retrieve the information from the +UnitState only when needed. It would mean that UnitId couldn't have an +Outputable instance as it would need an additional UnitState parameter to be +printed. It means that many other types couldn't have an Outputable instance +either: Unit, Module, Name, InstEnv, etc. Too many to make this solution +feasible. + +Solution 3: the approach we use is a compromise between solutions 0 and 2: the +appropriate UnitState has to be threaded close enough to the function generating +the SDoc so that the latter can use `pprWithUnitState` to set the UnitState to +fetch information from. However the UnitState doesn't have to be threaded +explicitly all the way down to the point where the UnitId itself is printed: +instead the Outputable instance of UnitId fetches the "sdocUnitIdForUser" +field in the SDocContext to pretty-print. + + 1. We can still have Outputable instances for common types (Module, Unit, + Name, etc.) + + 2. End-users don't have to pass a UnitState (via a DynFlags) to print a SDoc. + + 3. By default "sdocUnitIdForUser" prints the UnitId hash. In case of a bug + (i.e. GHC doesn't correctly call `pprWithUnitState` before pretty-printing a + UnitId), that's what will be shown to the user so it's no big deal. + + +Note [VirtUnit to RealUnit improvement] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Over the course of instantiating VirtUnits on the fly while typechecking an +indefinite library, we may end up with a fully instantiated VirtUnit. I.e. +one that could be compiled and installed in the database. During +type-checking we generate a virtual UnitId for it, say "abc". + +Now the question is: do we have a matching installed unit in the database? +Suppose we have one with UnitId "xyz" (provided by Cabal so we don't know how +to generate it). The trouble is that if both units end up being used in the +same type-checking session, their names won't match (e.g. "abc:M.X" vs +"xyz:M.X"). + +As we want them to match we just replace the virtual unit with the installed +one: for some reason this is called "improvement". + +There is one last niggle: improvement based on the unit database means +that we might end up developing on a unit that is not transitively +depended upon by the units the user specified directly via command line +flags. This could lead to strange and difficult to understand bugs if those +instantiations are out of date. The solution is to only improve a +unit id if the new unit id is part of the 'preloadClosure'; i.e., the +closure of all the units which were explicitly specified. + +Note [Representation of module/name variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In our ICFP'16, we use to represent module holes, and {A.T} to represent +name holes. This could have been represented by adding some new cases +to the core data types, but this would have made the existing 'moduleName' +and 'moduleUnit' partial, which would have required a lot of modifications +to existing code. + +Instead, we use a fake "hole" unit: + + ===> hole:A + {A.T} ===> hole:A.T + +This encoding is quite convenient, but it is also a bit dangerous too, +because if you have a 'hole:A' you need to know if it's actually a +'Module' or just a module stored in a 'Name'; these two cases must be +treated differently when doing substitutions. 'renameHoleModule' +and 'renameHoleUnit' assume they are NOT operating on a +'Name'; 'NameShape' handles name substitutions exclusively. + +-} diff --git a/GHC/Unit/Env.hs b/GHC/Unit/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Env.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | A 'UnitEnv' provides the complete interface into everything that is loaded +-- into a GHC session, including the 'HomeUnitGraph' for mapping home units to their +-- 'HomePackageTable's (which store information about all home modules), and +-- the 'ExternalPackageState' which provides access to all external packages +-- loaded. +-- +-- This module is meant to be imported as @UnitEnv@ when calling @insertHpt@: +-- +-- @ +-- import GHC.Unit.Env (UnitEnv, HomeUnitGraph, HomeUnitEnv) +-- import GHC.Unit.Env as UnitEnv +-- @ +-- +-- Here is an overview of how the UnitEnv, ModuleGraph, HUG, HPT, and EPS interact: +-- +-- @ +-- ┌────────────────┐┌────────────────────┐┌───────────┐ +-- │HomePackageTable││ExternalPackageState││ModuleGraph│ +-- └┬───────────────┘└┬───────────────────┘└┬──────────┘ +-- ┌▽────────────┐ │ │ +-- │HomeUnitGraph│ │ │ +-- └┬────────────┘ │ │ +-- ┌▽─────────────────▽─────────────────────▽┐ +-- │UnitEnv │ +-- └┬─────────────-──────────────────────────┘ +-- │ +-- │ +-- ┌▽──────────────────────────────────────▽┐ +-- │HscEnv │ +-- └────────────────────────────────────────┘ +-- @ +-- +-- The 'UnitEnv' references the 'HomeUnitGraph' (with all the home unit +-- modules), the 'ExternalPackageState' (information about all +-- non-home/external units), and the 'ModuleGraph' (which describes the +-- relationship between the modules being compiled). +-- The 'HscEnv' references this 'UnitEnv'. +-- The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. +module GHC.Unit.Env + ( UnitEnv (..) + , initUnitEnv + , ueEPS -- Not really needed, get directly type families and rule base! + , updateHug + -- * Unit Env helper functions + , ue_currentHomeUnitEnv + , ue_hpt + , ue_setActiveUnit + , ue_currentUnit + , ue_findHomeUnitEnv + , ue_unitHomeUnit + , ue_unitHomeUnit_maybe + , ue_updateHomeUnitEnv + , ue_all_home_unit_ids + , ue_unsafeHomeUnit + + -- * HUG Re-export + , HomeUnitGraph + , HomeUnitEnv (..) + + -- * Invariants + , assertUnitEnvInvariant + -- * Preload units info + , preloadUnitsInfo + , preloadUnitsInfo' + -- * Home Module functions + , isUnitEnvInstalledModule + + -------------------------------------------------------------------------------- + -- WIP above + -------------------------------------------------------------------------------- + + -- * Operations on the UnitEnv + , renameUnitId + + -- ** Modifying the current active home unit + , insertHpt + , ue_setFlags + + -- * Queries + + -- ** Queries on the current active home unit + , ue_homeUnitState + , ue_unit_dbs + , ue_homeUnit + , ue_unitFlags + + -- ** Reachability + , ue_transitiveHomeDeps + + -------------------------------------------------------------------------------- + -- Harder queries for the whole UnitEnv + -------------------------------------------------------------------------------- + + -- ** Instances, rules, type fams, annotations, etc.. + -- + -- | The @hug@ prefix means the function returns only things found in home + -- units. + , hugCompleteSigs + , hugAllInstances + , hugAllAnns + + -- * Legacy API + -- + -- | This API is deprecated! + , ue_units + ) +where + +import GHC.Prelude +import qualified Data.Set as Set + +import GHC.Unit.External +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Unit.Types +import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable +import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv) +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Module.Graph + +import GHC.Platform +import GHC.Settings +import GHC.Data.Maybe +import GHC.Utils.Misc (HasDebugCallStack) +import GHC.Driver.DynFlags +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Types.Annotations +import GHC.Types.CompleteMatch +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv + +-------------------------------------------------------------------------------- +-- The hard queries +-------------------------------------------------------------------------------- + +-- | Find all the instance declarations (of classes and families) from +-- the Home Package Table filtered by the provided predicate function. +hugAllInstances :: UnitEnv -> IO (InstEnv, [FamInst]) +hugAllInstances = HUG.allInstances . ue_home_unit_graph + +-- | Find all the annotations in all home units +hugAllAnns :: UnitEnv -> IO AnnEnv +hugAllAnns = HUG.allAnns . ue_home_unit_graph + +-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across +-- all home units. +hugCompleteSigs :: UnitEnv -> IO CompleteMatches +hugCompleteSigs = HUG.allCompleteSigs . ue_home_unit_graph + +-------------------------------------------------------------------------------- +-- UnitEnv +-------------------------------------------------------------------------------- + +data UnitEnv = UnitEnv + { ue_eps :: {-# UNPACK #-} !ExternalUnitCache + -- ^ Information about the currently loaded external packages. + -- This is mutable because packages will be demand-loaded during + -- a compilation run as required. + + , ue_current_unit :: UnitId + + , ue_module_graph :: ModuleGraph + -- ^ The module graph of the current session + -- See Note [Downsweep and the ModuleGraph] for when this is constructed. + + , ue_home_unit_graph :: !HomeUnitGraph + -- See Note [Multiple Home Units] + + , ue_platform :: !Platform + -- ^ Platform + + , ue_namever :: !GhcNameVersion + -- ^ GHC name/version (used for dynamic library suffix) + } + +ueEPS :: UnitEnv -> IO ExternalPackageState +ueEPS = eucEPS . ue_eps + +initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv +initUnitEnv cur_unit hug namever platform = do + eps <- initExternalUnitCache + return $ UnitEnv + { ue_eps = eps + , ue_home_unit_graph = hug + , ue_module_graph = emptyMG + , ue_current_unit = cur_unit + , ue_platform = platform + , ue_namever = namever + } + +updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv +updateHug = ue_updateHUG + +-- ----------------------------------------------------------------------------- +-- Extracting information from the packages in scope +-- ----------------------------------------------------------------------------- + +-- Many of these functions take a list of packages: in those cases, +-- the list is expected to contain the "dependent packages", +-- i.e. those packages that were found to be depended on by the +-- current module/program. These can be auto or non-auto packages, it +-- doesn't really matter. The list is always combined with the list +-- of preload (command-line) packages to determine which packages to +-- use. + +-- | Lookup 'UnitInfo' for every preload unit from the UnitState, for every unit +-- used to instantiate the home unit, and for every unit explicitly passed in +-- the given list of UnitId. +preloadUnitsInfo' :: UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo] +preloadUnitsInfo' unit_env ids0 = all_infos + where + unit_state = HUG.homeUnitEnv_units (ue_currentHomeUnitEnv unit_env) + ids = ids0 ++ inst_ids + inst_ids = case ue_homeUnit unit_env of + Nothing -> [] + Just home_unit + -- An indefinite package will have insts to HOLE, + -- which is not a real package. Don't look it up. + -- Fixes #14525 + | isHomeUnitIndefinite home_unit -> [] + | otherwise -> map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) + pkg_map = unitInfoMap unit_state + preload = preloadUnits unit_state + + all_pkgs = closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing) + all_infos = map (unsafeLookupUnitId unit_state) <$> all_pkgs + + +-- | Lookup 'UnitInfo' for every preload unit from the UnitState and for every +-- unit used to instantiate the home unit. +preloadUnitsInfo :: UnitEnv -> MaybeErr UnitErr [UnitInfo] +preloadUnitsInfo unit_env = preloadUnitsInfo' unit_env [] + +-- -- | Test if the module comes from the home unit +isUnitEnvInstalledModule :: UnitEnv -> InstalledModule -> Bool +isUnitEnvInstalledModule ue m = maybe False (`isHomeInstalledModule` m) hu + where + hu = ue_unitHomeUnit_maybe (moduleUnit m) ue + +-- ------------------------------------------------------- +-- Operations on arbitrary elements of the home unit graph +-- ------------------------------------------------------- + +ue_findHomeUnitEnv :: HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv +ue_findHomeUnitEnv uid e = case HUG.lookupHugUnitId uid (ue_home_unit_graph e) of + Nothing -> pprPanic "Unit unknown to the internal unit environment" + $ text "unit (" <> ppr uid <> text ")" + $$ ppr (HUG.allUnits (ue_home_unit_graph e)) + Just hue -> hue + +-- ------------------------------------------------------- +-- Query and modify UnitState of active unit in HomeUnitEnv +-- ------------------------------------------------------- + +ue_homeUnitState :: HasDebugCallStack => UnitEnv -> UnitState +ue_homeUnitState = HUG.homeUnitEnv_units . ue_currentHomeUnitEnv + +ue_unit_dbs :: UnitEnv -> Maybe [UnitDatabase UnitId] +ue_unit_dbs = HUG.homeUnitEnv_unit_dbs . ue_currentHomeUnitEnv + +-- ------------------------------------------------------- +-- Query and modify Home Package Table in HomeUnitEnv +-- ------------------------------------------------------- + +-- | Get the /current home unit/'s package table +ue_hpt :: HasDebugCallStack => UnitEnv -> HomePackageTable +ue_hpt = HUG.homeUnitEnv_hpt . ue_currentHomeUnitEnv + +-- | Inserts a 'HomeModInfo' at the given 'ModuleName' on the +-- 'HomePackageTable' of the /current unit/ being compiled. +insertHpt :: HasDebugCallStack => HomeModInfo -> UnitEnv -> IO () +insertHpt hmi e = do + HUG.addHomeModInfoToHug hmi (ue_home_unit_graph e) + +ue_updateHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv +ue_updateHUG f e = ue_updateUnitHUG f e + +ue_updateUnitHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv +ue_updateUnitHUG f ue_env = ue_env { ue_home_unit_graph = f (ue_home_unit_graph ue_env)} + +-- ------------------------------------------------------- +-- Query and modify DynFlags in HomeUnitEnv +-- ------------------------------------------------------- + +ue_unitFlags :: HasDebugCallStack => UnitId -> UnitEnv -> DynFlags +ue_unitFlags uid ue_env = HUG.homeUnitEnv_dflags $ ue_findHomeUnitEnv uid ue_env + +-- | Sets the 'DynFlags' of the /current unit/ being compiled to the given ones +ue_setFlags :: HasDebugCallStack => DynFlags -> UnitEnv -> UnitEnv +ue_setFlags dflags env = + env + { ue_home_unit_graph = HUG.updateUnitFlags + (ue_currentUnit env) + (const dflags) + (ue_home_unit_graph env) + } + +-- ------------------------------------------------------- +-- Query and modify home units in HomeUnitEnv +-- ------------------------------------------------------- + +ue_homeUnit :: UnitEnv -> Maybe HomeUnit +ue_homeUnit = HUG.homeUnitEnv_home_unit . ue_currentHomeUnitEnv + +ue_unsafeHomeUnit :: UnitEnv -> HomeUnit +ue_unsafeHomeUnit ue = case ue_homeUnit ue of + Nothing -> panic "ue_unsafeHomeUnit: No home unit" + Just h -> h + +ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit +ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid + +ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit +ue_unitHomeUnit_maybe uid ue_env = + HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env) + +-- ------------------------------------------------------- +-- Query and modify the currently active unit +-- ------------------------------------------------------- + +ue_currentHomeUnitEnv :: HasDebugCallStack => UnitEnv -> HomeUnitEnv +ue_currentHomeUnitEnv e = + case HUG.lookupHugUnitId (ue_currentUnit e) (ue_home_unit_graph e) of + Just unitEnv -> unitEnv + Nothing -> pprPanic "packageNotFound" $ + (ppr $ ue_currentUnit e) $$ ppr (HUG.allUnits (ue_home_unit_graph e)) + +ue_setActiveUnit :: UnitId -> UnitEnv -> UnitEnv +ue_setActiveUnit u ue_env = assertUnitEnvInvariant $ ue_env + { ue_current_unit = u + } + +ue_currentUnit :: UnitEnv -> UnitId +ue_currentUnit = ue_current_unit + + +ue_updateHomeUnitEnv :: (HomeUnitEnv -> HomeUnitEnv) -> UnitId -> UnitEnv -> UnitEnv +ue_updateHomeUnitEnv f uid e = e + { ue_home_unit_graph = HUG.unitEnv_adjust f uid $ ue_home_unit_graph e + } + +ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId +ue_all_home_unit_ids = HUG.allUnits . ue_home_unit_graph + +-- | Rename a unit id in the internal unit env. +-- +-- @'renameUnitId' oldUnit newUnit UnitEnv@, it is assumed that the 'oldUnit' exists in the home units map, +-- otherwise we panic. +-- The 'DynFlags' associated with the home unit will have its field 'homeUnitId' set to 'newUnit'. +renameUnitId :: HasDebugCallStack => UnitId -> UnitId -> UnitEnv -> UnitEnv +renameUnitId oldUnit newUnit unitEnv = + case HUG.renameUnitId oldUnit newUnit (ue_home_unit_graph unitEnv) of + Nothing -> + pprPanic "Tried to rename unit, but it didn't exist" + $ text "Rename old unit \"" <> ppr oldUnit <> text "\" to \""<> ppr newUnit <> text "\"" + $$ nest 2 (ppr $ HUG.allUnits (ue_home_unit_graph unitEnv)) + Just newHug -> + let + activeUnit :: UnitId + !activeUnit = if ue_currentUnit unitEnv == oldUnit + then newUnit + else ue_currentUnit unitEnv + + in + unitEnv + { ue_current_unit = activeUnit + , ue_home_unit_graph = + HUG.updateUnitFlags + newUnit + (\df -> df{ homeUnitId_ = newUnit }) + newHug + } + +-- --------------------------------------------- +-- Transitive closure +-- --------------------------------------------- + +ue_transitiveHomeDeps :: UnitId -> UnitEnv -> [UnitId] +ue_transitiveHomeDeps uid e = + case HUG.transitiveHomeDeps uid (ue_home_unit_graph e) of + Nothing -> pprPanic "Unit unknown to the internal unit environment" + $ text "unit (" <> ppr uid <> text ")" + $$ ppr (HUG.allUnits $ ue_home_unit_graph e) + Just deps -> deps + +-- --------------------------------------------- +-- Asserts to enforce invariants for the UnitEnv +-- --------------------------------------------- + +-- FIXME: Shouldn't this be a proper assertion only used in debug mode? +assertUnitEnvInvariant :: HasDebugCallStack => UnitEnv -> UnitEnv +assertUnitEnvInvariant u = + case HUG.lookupHugUnitId (ue_current_unit u) (ue_home_unit_graph u) of + Just _ -> u + Nothing -> + pprPanic "invariant" (ppr (ue_current_unit u) $$ ppr (HUG.allUnits (ue_home_unit_graph u))) + +-- ----------------------------------------------------------------------------- +-- Pretty output functions +-- ----------------------------------------------------------------------------- + +-- pprUnitEnvGraph :: UnitEnv -> IO SDoc +-- pprUnitEnvGraph env = do +-- hugDoc <- HUG.pprHomeUnitGraph $ ue_home_unit_graph env +-- return $ text "pprInternalUnitMap" $$ nest 2 hugDoc + +{- +Note [Multiple Home Units] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of multiple home units is quite simple. Instead of allowing one +home unit, you can multiple home units + +The flow: + +1. Dependencies between units are specified between each other in the normal manner, + a unit is identified by the -this-unit-id flag and dependencies specified by + the normal -package-id flag. +2. Downsweep is augmented to know to know how to look for dependencies in any home unit. +3. The rest of the compiler is modified appropriately to offset paths to the right places. +4. --make mode can parallelise between home units and multiple units are allowed to produce linkables. + +Closure Property +---------------- + +You must perform a clean cut of the dependency graph. + +> Any dependency which is not a home unit must not (transitively) depend on a home unit. + +For example, if you have three packages p, q and r, then if p depends on q which +depends on r then it is illegal to load both p and r as home units but not q, +because q is a dependency of the home unit p which depends on another home unit r. + +Offsetting Paths +---------------- + +The main complication to the implementation is to do with offsetting paths appropriately. +For a long time it has been assumed that GHC will execute in the top-directory for a unit, +normally where the .cabal file is and all paths are interpreted relative to there. +When you have multiple home units then it doesn't make sense to pick one of these +units to choose as the base-unit, and you can't robustly change directories when +using parallelism. + +Therefore there is an option `-working-directory`, which tells GHC where the relative +paths for each unit should be interpreted relative to. For example, if you specify +`-working-dir a -ib`, then GHC will offset the relative path `b`, by `a`, and look for +source files in `a/b`. The same thing happens for any path passed on the command line. + +A non-exhaustive list is + +* -i +* -I +* -odir/-hidir/-outputdir/-stubdir/-hiedir +* Target files passed on the command line + +There is also a template-haskell function, makeRelativeToProject, which uses the `-working-directory` option +in order to allow users to offset their own relative paths. + +-} + +-------------------------------------------------------------------------------- +-- * Legacy API +-------------------------------------------------------------------------------- + +{-# DEPRECATED ue_units "Renamed to ue_homeUnitState because of confusion between units(tate) and unit(s) plural" #-} +ue_units :: HasDebugCallStack => UnitEnv -> UnitState +ue_units = ue_homeUnitState + diff --git a/GHC/Unit/External.hs b/GHC/Unit/External.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/External.hs @@ -0,0 +1,187 @@ +module GHC.Unit.External + ( ExternalUnitCache (..) + , initExternalUnitCache + , eucEPS + , ExternalPackageState (..) + , initExternalPackageState + , EpsStats(..) + , addEpsInStats + , PackageTypeEnv + , PackageIfaceTable + , PackageInstEnv + , PackageFamInstEnv + , PackageRuleBase + , PackageCompleteMatches + , emptyPackageIfaceTable + ) +where + +import GHC.Prelude + +import GHC.Unit +import GHC.Unit.Module.ModIface + +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv ( InstEnv, emptyInstEnv ) +import GHC.Core.Opt.ConstantFold +import GHC.Core.Rules ( RuleBase, mkRuleBase) + +import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv ) +import GHC.Types.CompleteMatch +import GHC.Types.DefaultEnv (DefaultEnv) +import GHC.Types.TypeEnv +import GHC.Types.Unique.DSet + +import GHC.Linker.Types (Linkable) + +import Data.IORef + + +type PackageTypeEnv = TypeEnv +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv +type PackageFamInstEnv = FamInstEnv +type PackageAnnEnv = AnnEnv +type PackageCompleteMatches = CompleteMatches + +-- | Helps us find information about modules in the imported packages +type PackageIfaceTable = ModuleEnv ModIface + -- Domain = modules in the imported packages + +-- | Constructs an empty PackageIfaceTable +emptyPackageIfaceTable :: PackageIfaceTable +emptyPackageIfaceTable = emptyModuleEnv + +-- | Information about the currently loaded external packages. +-- This is mutable because packages will be demand-loaded during +-- a compilation run as required. +newtype ExternalUnitCache = ExternalUnitCache + { euc_eps :: IORef ExternalPackageState + } + +initExternalUnitCache :: IO ExternalUnitCache +initExternalUnitCache = ExternalUnitCache <$> newIORef initExternalPackageState + +eucEPS :: ExternalUnitCache -> IO ExternalPackageState +eucEPS = readIORef . euc_eps + +initExternalPackageState :: ExternalPackageState +initExternalPackageState = EPS + { eps_is_boot = emptyInstalledModuleEnv + , eps_PIT = emptyPackageIfaceTable + , eps_free_holes = emptyInstalledModuleEnv + , eps_PTE = emptyTypeEnv + , eps_iface_bytecode = emptyModuleEnv + , 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 + } + , eps_defaults = emptyModuleEnv + } + + +-- | Information about other packages that we have slurped in by reading +-- their interface files +data ExternalPackageState + = EPS { + eps_is_boot :: !(InstalledModuleEnv ModuleNameWithIsBoot), + -- ^ In OneShot mode (only), home-package modules + -- accumulate in the external package state, and are + -- sucked in lazily. For these home-pkg modules + -- (only) we need to record which are boot modules. + -- We set this field after loading all the + -- explicitly-imported interfaces, but before doing + -- anything else + -- + -- The 'ModuleName' part is not necessary, but it's useful for + -- debug prints, and it's convenient because this field comes + -- direct from 'GHC.Tc.Utils.imp_dep_mods' + + eps_PIT :: !PackageIfaceTable, + -- ^ The 'ModIface's for modules in external packages + -- whose interfaces we have opened. + -- The declarations in these interface files are held in the + -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules' + -- fields of this record, not in the 'mi_decls' fields of the + -- interface we have sucked in. + -- + -- What /is/ in the PIT is: + -- + -- * The Module + -- + -- * Fingerprint info + -- + -- * Its exports + -- + -- * Fixities + -- + -- * Deprecations and warnings + + eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName), + -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on + -- the 'eps_PIT' for this information, EXCEPT that when + -- we do dependency analysis, we need to look at the + -- 'Dependencies' of our imports to determine what their + -- precise free holes are ('moduleFreeHolesPrecise'). We + -- don't want to repeatedly reread in the interface + -- for every import, so cache it here. When the PIT + -- gets filled in we can drop these entries. + + eps_PTE :: !PackageTypeEnv, + -- ^ Result of typechecking all the external package + -- interface files we have sucked in. The domain of + -- the mapping is external-package modules + + -- | If an interface was written with @-fwrite-if-simplified-core@, this + -- will contain an IO action that compiles bytecode from core bindings. + -- + -- See Note [Interface Files with Core Definitions] + eps_iface_bytecode :: !(ModuleEnv (IO Linkable)), + + eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated + -- from all the external-package modules + eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated + -- from all the external-package modules + eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated + -- from all the external-package modules + eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated + -- from all the external-package modules + eps_complete_matches :: !PackageCompleteMatches, + -- ^ The total 'CompleteMatches' accumulated + -- from all the external-package modules + + eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external + -- packages, keyed off the module that declared them + + eps_stats :: !EpsStats, -- ^ Statistics about what was loaded from external packages + eps_defaults :: !(ModuleEnv DefaultEnv) -- ^ Default declarations exported by external packages + } + +-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. +-- \"In\" means stuff that is just /read/ from interface files, +-- \"Out\" means actually sucked in and type-checked +data EpsStats = EpsStats { n_ifaces_in + , n_decls_in, n_decls_out + , n_rules_in, n_rules_out + , n_insts_in, n_insts_out :: !Int } + +addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats +-- ^ Add stats for one newly-read interface +addEpsInStats stats n_decls n_insts n_rules + = stats { n_ifaces_in = n_ifaces_in stats + 1 + , n_decls_in = n_decls_in stats + n_decls + , n_insts_in = n_insts_in stats + n_insts + , n_rules_in = n_rules_in stats + n_rules } + diff --git a/GHC/Unit/Finder.hs b/GHC/Unit/Finder.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Finder.hs @@ -0,0 +1,797 @@ +{- +(c) The University of Glasgow, 2000-2006 + +-} + + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Module finder +module GHC.Unit.Finder ( + FindResult(..), + InstalledFindResult(..), + FinderOpts(..), + FinderCache(..), + initFinderCache, + findImportedModule, + findImportedModuleWithIsBoot, + findPluginModule, + findExactModule, + findHomeModule, + findExposedPackageModule, + mkHomeModLocation, + mkHomeModLocation2, + mkHiOnlyModLocation, + mkHiPath, + mkObjPath, + addModuleToFinder, + addHomeModuleToFinder, + mkStubPaths, + + findObjectLinkableMaybe, + findObjectLinkable, + ) where + +import GHC.Prelude + +import GHC.Platform.Ways + +import GHC.Data.OsPath + +import GHC.Unit.Env +import GHC.Unit.Types +import GHC.Unit.Module +import GHC.Unit.Home +import GHC.Unit.Home.Graph (UnitEnvGraph) +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.State +import GHC.Unit.Finder.Types + +import qualified GHC.Data.ShortText as ST + +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic + +import GHC.Linker.Types +import GHC.Types.PkgQual +import GHC.Types.SourceFile + +import GHC.Fingerprint +import Data.IORef +import System.Directory.OsPath +import Control.Applicative ((<|>)) +import Control.Monad +import Data.Time +import qualified Data.Map as M +import GHC.Driver.Env +import GHC.Driver.Config.Finder +import qualified Data.Set as Set +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified System.OsPath as OsPath +import qualified Data.List.NonEmpty as NE + +type FileExt = OsString -- Filename extension +type BaseName = OsPath -- Basename of file + +-- ----------------------------------------------------------------------------- +-- The Finder + +-- The Finder provides a thin filesystem abstraction to the rest of +-- the compiler. For a given module, it can tell you where the +-- source, interface, and object files for that module live. + +-- It does *not* know which particular package a module lives in. Use +-- Packages.lookupModuleInAllUnits for that. + +-- ----------------------------------------------------------------------------- +-- The finder's cache + +{- +[Note: Monotonic addToFinderCache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +addToFinderCache is only used by functions that return the cached value +if there is one, or by functions that always write an InstalledFound value. +Without multithreading it is then safe to always directly write the value +without checking the previously cached value. + +However, with multithreading, it is possible that another function has +written a value into cache between the lookup and the addToFinderCache call. +in this case we should check to not overwrite an InstalledFound with an +InstalledNotFound. +-} + +initFinderCache :: IO FinderCache +initFinderCache = do + mod_cache <- newIORef emptyInstalledModuleEnv + file_cache <- newIORef M.empty + let flushFinderCaches :: UnitEnv -> IO () + flushFinderCaches ue = do + atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) + atomicModifyIORef' file_cache $ \_ -> (M.empty, ()) + where + is_ext mod _ = not (isUnitEnvInstalledModule ue mod) + + addToFinderCache :: InstalledModule -> InstalledFindResult -> IO () + addToFinderCache key val = + atomicModifyIORef' mod_cache $ \c -> + case (lookupInstalledModuleEnv c key, val) of + -- Don't overwrite an InstalledFound with an InstalledNotFound + -- See [Note Monotonic addToFinderCache] + (Just InstalledFound{}, InstalledNotFound{}) -> (c, ()) + _ -> (extendInstalledModuleEnv c key val, ()) + + lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult) + lookupFinderCache key = do + c <- readIORef mod_cache + return $! lookupInstalledModuleEnv c key + + lookupFileCache :: FilePath -> IO Fingerprint + lookupFileCache key = do + c <- readIORef file_cache + case M.lookup key c of + Nothing -> do + hash <- getFileHash key + atomicModifyIORef' file_cache $ \c -> (M.insert key hash c, ()) + return hash + Just fp -> return fp + return FinderCache{..} + +-- ----------------------------------------------------------------------------- +-- The three external entry points + + +-- | Locate a module that was imported by the user. We have the +-- module's name, and possibly a package name. Without a package +-- name, this function will use the search path and the known exposed +-- packages to find the module, if a package is specified then only +-- that package is searched for the module. + +findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult +findImportedModule hsc_env mod pkg_qual = + 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 pkg_qual + +findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult +findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do + res <- findImportedModule hsc_env mod pkg_qual + case (res, is_boot) of + (Found loc mod, IsBoot) -> return (Found (addBootSuffixLocn loc) mod) + _ -> return res + +findImportedModuleNoHsc + :: FinderCache + -> FinderOpts + -> UnitEnv + -> Maybe HomeUnit + -> ModuleName + -> PkgQual + -> IO FindResult +findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = + case mb_pkg of + NoPkgQual -> unqual_import + ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import + | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) + | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) + OtherPkg _ -> pkg_import + where + all_opts = case mhome_unit of + Nothing -> other_fopts + Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts + + + home_import = case mhome_unit of + Just home_unit -> findHomeModule fc fopts home_unit mod_name + Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit") + + + home_pkg_import (uid, opts) + -- If the module is reexported, then look for it as if it was from the perspective + -- of that package which reexports it. + | Just real_mod_name <- mod_name `M.lookup` finder_reexportedModules opts = + findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual + | mod_name `Set.member` finder_hiddenModules opts = + return (mkHomeHidden uid) + | otherwise = + findHomePackageModule fc opts uid mod_name + + -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as + -- that is not the same!! home_import is first because we need to look within ourselves + -- first before looking at the packages in order. + any_home_import = foldr1 orIfNotFound (home_import:| map home_pkg_import other_fopts) + + pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg + + unqual_import = any_home_import + `orIfNotFound` + findExposedPackageModule fc fopts units mod_name NoPkgQual + + units = case mhome_unit of + Nothing -> ue_homeUnitState ue + Just home_unit -> HUG.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. +findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult +findPluginModuleNoHsc fc fopts units (Just home_unit) mod_name = + findHomeModule fc fopts home_unit mod_name + `orIfNotFound` + findExposedPluginPackageModule fc fopts units mod_name +findPluginModuleNoHsc fc fopts units Nothing mod_name = + findExposedPluginPackageModule fc fopts units mod_name + +findPluginModule :: HscEnv -> ModuleName -> IO FindResult +findPluginModule hsc_env mod_name = do + let fc = hsc_FC hsc_env + let units = hsc_units hsc_env + let mhome_unit = hsc_home_unit_maybe hsc_env + findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mhome_unit mod_name + + +-- | A version of findExactModule which takes the exact parts of the HscEnv it needs +-- directly. +findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult +findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do + res <- case mhome_unit of + Just home_unit + | isHomeInstalledModule home_unit mod + -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod) + | Just home_fopts <- HUG.unitEnv_lookup_maybe (moduleUnit mod) other_fopts + -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod) + _ -> findPackageModule fc unit_state fopts mod + case (res, is_boot) of + (InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc)) + _ -> return res + + +-- | Locate a specific 'Module'. The purpose of this function is to +-- create a 'ModLocation' for a given 'Module', that is to find out +-- where the files associated with this module live. It is used when +-- reading the interface for a module mentioned by another interface, +-- for example (a "system import"). +findExactModule :: HscEnv -> InstalledModule -> IsBootInterface -> IO InstalledFindResult +findExactModule hsc_env mod is_boot = do + let dflags = hsc_dflags hsc_env + let fc = hsc_FC hsc_env + let unit_state = hsc_units hsc_env + let home_unit = hsc_home_unit_maybe hsc_env + let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) + findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot + + +-- ----------------------------------------------------------------------------- +-- Helpers + +-- | Given a monadic actions @this@ and @or_this@, first execute +-- @this@. If the returned 'FindResult' is successful, return +-- it; otherwise, execute @or_this@. If both failed, this function +-- also combines their failure messages in a reasonable way. +orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult +orIfNotFound this or_this = do + res <- this + case res of + NotFound { fr_paths = paths1, fr_mods_hidden = mh1 + , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 } + -> do res2 <- or_this + case res2 of + NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 + , fr_pkgs_hidden = ph2, fr_unusables = u2 + , fr_suggestions = s2 } + -> return (NotFound { fr_paths = paths1 ++ paths2 + , fr_pkg = mb_pkg2 -- snd arg is the package search + , fr_mods_hidden = mh1 ++ mh2 + , fr_pkgs_hidden = ph1 ++ ph2 + , fr_unusables = u1 ++ u2 + , fr_suggestions = s1 ++ s2 }) + _other -> return res2 + _other -> return res + +-- | Helper function for 'findHomeModule': this function wraps an IO action +-- which would look up @mod_name@ in the file system (the home package), +-- and first consults the 'hsc_FC' cache to see if the lookup has already +-- been done. Otherwise, do the lookup (with the IO action) and save +-- the result in the finder cache and the module location cache (if it +-- was successful.) +homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult +homeSearchCache fc home_unit mod_name do_this = do + let mod = mkModule home_unit mod_name + modLocationCache fc mod do_this + +findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult +findExposedPackageModule fc fopts units mod_name mb_pkg = + findLookupResult fc fopts + $ lookupModuleWithSuggestions units mod_name mb_pkg + +findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult +findExposedPluginPackageModule fc fopts units mod_name = + findLookupResult fc fopts + $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual + +findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult +findLookupResult fc fopts r = case r of + LookupFound m pkg_conf -> do + let im = fst (getModuleInstantiation m) + r' <- findPackageModule_ fc fopts im (fst pkg_conf) + case r' of + -- TODO: ghc -M is unlikely to do the right thing + -- with just the location of the thing that was + -- instantiated; you probably also need all of the + -- implicit locations from the instances + InstalledFound loc -> return (Found loc m) + InstalledNoPackage _ -> return (NoPackage (moduleUnit m)) + InstalledNotFound fp _ -> return (NotFound{ fr_paths = fmap unsafeDecodeUtf fp, fr_pkg = Just (moduleUnit m) + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = [] + , fr_suggestions = []}) + LookupMultiple rs -> + return (FoundMultiple rs) + LookupHidden pkg_hiddens mod_hiddens -> + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens + , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens + , fr_unusables = [] + , fr_suggestions = [] }) + LookupUnusable unusable -> + let unusables' = map get_unusable unusable + get_unusable (_, ModUnusable r) = r + get_unusable (_, r) = + pprPanic "findLookupResult: unexpected origin" (ppr r) + in return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = unusables' + , fr_suggestions = [] }) + LookupNotFound suggest -> do + let suggest' + | finder_enableSuggestions fopts = suggest + | otherwise = [] + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = [] + , fr_suggestions = suggest' }) + +modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult +modLocationCache fc mod do_this = do + m <- lookupFinderCache fc mod + case m of + Just result -> return result + Nothing -> do + result <- do_this + addToFinderCache fc mod result + return result + +addModuleToFinder :: FinderCache -> Module -> ModLocation -> HscSource -> IO () +addModuleToFinder fc mod loc src_flavour = do + let imod = toUnitId <$> mod + unless (src_flavour == HsBootFile) $ + addToFinderCache fc imod (InstalledFound loc) + +-- This returns a module because it's more convenient for users +addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> HscSource -> IO Module +addHomeModuleToFinder fc home_unit mod_name loc src_flavour = do + let mod = mkHomeInstalledModule home_unit mod_name + unless (src_flavour == HsBootFile) $ + addToFinderCache fc mod (InstalledFound loc) + return (mkHomeModule home_unit mod_name) + +-- ----------------------------------------------------------------------------- +-- The internal workers + +findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult +findHomeModule fc fopts home_unit mod_name = do + let uid = homeUnitAsUnit home_unit + r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name + return $ case r of + InstalledFound loc -> Found loc (mkHomeModule home_unit mod_name) + InstalledNoPackage _ -> NoPackage uid -- impossible + InstalledNotFound fps _ -> NotFound { + fr_paths = fmap unsafeDecodeUtf fps, + fr_pkg = Just uid, + fr_mods_hidden = [], + fr_pkgs_hidden = [], + fr_unusables = [], + fr_suggestions = [] + } + +mkHomeHidden :: UnitId -> FindResult +mkHomeHidden uid = + NotFound { fr_paths = [] + , fr_pkg = Just (RealUnit (Definite uid)) + , fr_mods_hidden = [RealUnit (Definite uid)] + , fr_pkgs_hidden = [] + , fr_unusables = [] + , fr_suggestions = []} + +findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult +findHomePackageModule fc fopts home_unit mod_name = do + let uid = RealUnit (Definite home_unit) + r <- findInstalledHomeModule fc fopts home_unit mod_name + return $ case r of + InstalledFound loc -> Found loc (mkModule uid mod_name) + InstalledNoPackage _ -> NoPackage uid -- impossible + InstalledNotFound fps _ -> NotFound { + fr_paths = fmap unsafeDecodeUtf fps, + fr_pkg = Just uid, + fr_mods_hidden = [], + fr_pkgs_hidden = [], + fr_unusables = [], + fr_suggestions = [] + } + + +-- | Implements the search for a module name in the home package only. Calling +-- this function directly is usually *not* what you want; currently, it's used +-- as a building block for the following operations: +-- +-- 1. When you do a normal package lookup, we first check if the module +-- is available in the home module, before looking it up in the package +-- database. +-- +-- 2. When you have a package qualified import with package name "this", +-- we shortcut to the home module. +-- +-- 3. When we look up an exact 'Module', if the unit id associated with +-- the module is the current home module do a look up in the home module. +-- +-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to +-- call this.) +findInstalledHomeModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO InstalledFindResult +findInstalledHomeModule fc fopts home_unit mod_name = do + homeSearchCache fc home_unit mod_name $ + let + maybe_working_dir = finder_workingDirectory fopts + home_path = case maybe_working_dir of + Nothing -> finder_importPaths fopts + Just fp -> augmentImports fp (finder_importPaths fopts) + hi_dir_path = + case finder_hiDir fopts of + Just hiDir -> case maybe_working_dir of + Nothing -> [hiDir] + Just fp -> [fp hiDir] + Nothing -> home_path + hisuf = finder_hiSuf fopts + mod = mkModule home_unit mod_name + + source_exts = + [ (os "hs", mkHomeModLocationSearched fopts mod_name $ os "hs") + , (os "lhs", mkHomeModLocationSearched fopts mod_name $ os "lhs") + , (os "hsig", mkHomeModLocationSearched fopts mod_name $ os "hsig") + , (os "lhsig", mkHomeModLocationSearched fopts mod_name $ os "lhsig") + ] + + -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that + -- when hiDir field is set in dflags, we know to look there (see #16500) + hi_exts = [ (hisuf, mkHomeModHiOnlyLocation fopts mod_name) + , (addBootSuffix hisuf, mkHomeModHiOnlyLocation fopts mod_name) + ] + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi and .hi-boot files only. + (search_dirs, exts) + | finder_lookupHomeInterfaces fopts = (hi_dir_path, hi_exts) + | otherwise = (home_path, source_exts) + in searchPathExts search_dirs mod exts + +-- | Prepend the working directory to the search path. +augmentImports :: OsPath -> [OsPath] -> [OsPath] +augmentImports _work_dir [] = [] +augmentImports work_dir (fp:fps) + | OsPath.isAbsolute fp = fp : augmentImports work_dir fps + | otherwise = (work_dir fp) : augmentImports work_dir fps + +-- | Search for a module in external packages only. +findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult +findPackageModule fc unit_state fopts mod = do + let pkg_id = moduleUnit mod + case lookupUnitId unit_state pkg_id of + Nothing -> return (InstalledNoPackage pkg_id) + Just u -> findPackageModule_ fc fopts mod u + +-- | Look up the interface file associated with module @mod@. This function +-- requires a few invariants to be upheld: (1) the 'Module' in question must +-- be the module identifier of the *original* implementation of a module, +-- not a reexport (this invariant is upheld by "GHC.Unit.State") and (2) +-- the 'UnitInfo' must be consistent with the unit id in the 'Module'. +-- The redundancy is to avoid an extra lookup in the package state +-- for the appropriate config. +findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -> IO InstalledFindResult +findPackageModule_ fc fopts mod pkg_conf = do + massertPpr (moduleUnit mod == unitId pkg_conf) + (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf)) + modLocationCache fc mod $ + let + tag = waysBuildTag (finder_ways fopts) + + -- hi-suffix for packages depends on the build tag. + package_hisuf | null tag = os "hi" + | otherwise = os (tag ++ "_hi") + + package_dynhisuf = os $ waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi" + + mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf package_dynhisuf + + import_dirs = map (unsafeEncodeUtf . 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 = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod) + loc = mk_hi_loc one basename + in return $ InstalledFound loc + _otherwise -> + searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] + +-- ----------------------------------------------------------------------------- +-- General path searching + +searchPathExts :: [OsPath] -- paths to search + -> InstalledModule -- module name + -> [ ( + FileExt, -- suffix + OsPath -> BaseName -> ModLocation -- action + ) + ] + -> IO InstalledFindResult + +searchPathExts paths mod exts = search to_search + where + basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod) + + to_search :: [(OsPath, ModLocation)] + to_search = [ (file, fn path basename) + | path <- paths, + (ext,fn) <- exts, + let base | path == os "." = basename + | otherwise = path basename + file = base <.> ext + ] + + search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod))) + + search ((file, loc) : rest) = do + b <- doesFileExist file + if b + then return $ InstalledFound loc + else search rest + +mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt + -> OsPath -> BaseName -> ModLocation +mkHomeModLocationSearched fopts mod suff path basename = + mkHomeModLocation2 fopts mod (path basename) suff + + +-- ----------------------------------------------------------------------------- +-- Constructing a home module location + +-- This is where we construct the ModLocation for a module in the home +-- package, for which we have a source file. It is called from three +-- places: +-- +-- (a) Here in the finder, when we are searching for a module to import, +-- using the search path (-i option). +-- +-- (b) The compilation manager, when constructing the ModLocation for +-- a "root" module (a source file named explicitly on the command line +-- or in a :load command in GHCi). +-- +-- (c) The driver in one-shot mode, when we need to construct a +-- ModLocation for a source file named on the command-line. +-- +-- Parameters are: +-- +-- mod +-- The name of the module +-- +-- path +-- (a): The search path component where the source file was found. +-- (b) and (c): "." +-- +-- src_basename +-- (a): (moduleNameSlashes mod) +-- (b) and (c): The filename of the source file, minus its extension +-- +-- ext +-- The filename extension of the source file (usually "hs" or "lhs"). + +mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> FileExt -> HscSource -> ModLocation +mkHomeModLocation dflags mod src_basename ext hsc_src = + let loc = mkHomeModLocation2 dflags mod src_basename ext + in case hsc_src of + HsBootFile -> addBootSuffixLocnOut loc + _ -> loc + +mkHomeModLocation2 :: FinderOpts + -> ModuleName + -> OsPath -- Of source module, without suffix + -> FileExt -- Suffix + -> ModLocation +mkHomeModLocation2 fopts mod src_basename ext = + let mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod + + obj_fn = mkObjPath fopts src_basename mod_basename + dyn_obj_fn = mkDynObjPath fopts src_basename mod_basename + hi_fn = mkHiPath fopts src_basename mod_basename + dyn_hi_fn = mkDynHiPath fopts src_basename mod_basename + hie_fn = mkHiePath fopts src_basename mod_basename + + in (OsPathModLocation{ ml_hs_file_ospath = Just (src_basename <.> ext), + ml_hi_file_ospath = hi_fn, + ml_dyn_hi_file_ospath = dyn_hi_fn, + ml_obj_file_ospath = obj_fn, + ml_dyn_obj_file_ospath = dyn_obj_fn, + ml_hie_file_ospath = hie_fn }) + +mkHomeModHiOnlyLocation :: FinderOpts + -> ModuleName + -> OsPath + -> BaseName + -> ModLocation +mkHomeModHiOnlyLocation fopts mod path basename = + let loc = mkHomeModLocation2 fopts mod (path basename) mempty + in loc { ml_hs_file_ospath = 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 -> FileExt -> FileExt -> OsPath -> OsPath + -> 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 OsPathModLocation{ ml_hs_file_ospath = Nothing, + ml_hi_file_ospath = 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_ospath = dyn_obj_fn, + -- MP: TODO + ml_dyn_hi_file_ospath = full_basename <.> dynhisuf, + ml_obj_file_ospath = obj_fn, + ml_hie_file_ospath = hie_fn + } + +-- | Constructs the filename of a .o file for a given source file. +-- Does /not/ check whether the .o file exists +mkObjPath + :: FinderOpts + -> OsPath -- the filename of the source file, minus the extension + -> OsPath -- the module name with dots replaced by slashes + -> OsPath +mkObjPath fopts basename mod_basename = obj_basename <.> osuf + where + odir = finder_objectDir fopts + osuf = finder_objectSuf fopts + + obj_basename | Just dir <- odir = dir mod_basename + | otherwise = basename + +-- | Constructs the filename of a .dyn_o file for a given source file. +-- Does /not/ check whether the .dyn_o file exists +mkDynObjPath + :: FinderOpts + -> OsPath -- the filename of the source file, minus the extension + -> OsPath -- the module name with dots replaced by slashes + -> OsPath +mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf + where + odir = finder_objectDir fopts + dynosuf = finder_dynObjectSuf fopts + + obj_basename | Just dir <- odir = dir mod_basename + | otherwise = basename + + +-- | Constructs the filename of a .hi file for a given source file. +-- Does /not/ check whether the .hi file exists +mkHiPath + :: FinderOpts + -> OsPath -- the filename of the source file, minus the extension + -> OsPath -- the module name with dots replaced by slashes + -> OsPath +mkHiPath fopts basename mod_basename = hi_basename <.> hisuf + where + hidir = finder_hiDir fopts + hisuf = finder_hiSuf fopts + + hi_basename | Just dir <- hidir = dir mod_basename + | otherwise = basename + +-- | Constructs the filename of a .dyn_hi file for a given source file. +-- Does /not/ check whether the .dyn_hi file exists +mkDynHiPath + :: FinderOpts + -> OsPath -- the filename of the source file, minus the extension + -> OsPath -- the module name with dots replaced by slashes + -> OsPath +mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf + where + hidir = finder_hiDir fopts + dynhisuf = finder_dynHiSuf fopts + + hi_basename | Just dir <- hidir = dir mod_basename + | otherwise = basename + +-- | Constructs the filename of a .hie file for a given source file. +-- Does /not/ check whether the .hie file exists +mkHiePath + :: FinderOpts + -> OsPath -- the filename of the source file, minus the extension + -> OsPath -- the module name with dots replaced by slashes + -> OsPath +mkHiePath fopts basename mod_basename = hie_basename <.> hiesuf + where + hiedir = finder_hieDir fopts + hiesuf = finder_hieSuf fopts + + hie_basename | Just dir <- hiedir = dir mod_basename + | otherwise = basename + + + +-- ----------------------------------------------------------------------------- +-- Filenames of the stub files + +-- We don't have to store these in ModLocations, because they can be derived +-- from other available information, and they're only rarely needed. + +-- | Compute the file name of a header file for foreign stubs, using either the +-- directory explicitly specified in the command line option @-stubdir@, or the +-- directory of the module's source file. +-- +-- When compiling bytecode from interface Core bindings, @ModLocation@ does not +-- contain a source file path, so the header isn't written. +-- This doesn't have an impact, since we cannot support headers importing +-- Haskell symbols defined in bytecode for TH whatsoever at the moment. +mkStubPaths + :: FinderOpts + -> ModuleName + -> ModLocation + -> Maybe OsPath +mkStubPaths fopts mod location = do + stub_basename <- in_stub_dir <|> src_basename + pure (stub_basename `mappend` os "_stub" <.> os "h") + where + in_stub_dir = ( mod_basename) <$> (finder_stubDir fopts) + + mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod + src_basename = OsPath.dropExtension <$> ml_hs_file_ospath location + +-- ----------------------------------------------------------------------------- +-- findLinkable isn't related to the other stuff in here, +-- but there's no other obvious place for it + +findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) +findObjectLinkableMaybe mod locn + = do let obj_fn = ml_obj_file locn + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + +-- Make an object linkable when we know the object file exists, and we know +-- its modification time. +findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable +findObjectLinkable mod obj_fn obj_time = + pure (Linkable obj_time mod (NE.singleton (DotO obj_fn ModuleObject))) + -- We used to look for _stub.o files here, but that was a bug (#706) + -- Now GHC merges the stub.o into the main .o (#3687) + diff --git a/GHC/Unit/Finder/Types.hs b/GHC/Unit/Finder/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Finder/Types.hs @@ -0,0 +1,115 @@ +module GHC.Unit.Finder.Types + ( FinderCache (..) + , FinderCacheState + , FileCacheState + , FindResult (..) + , InstalledFindResult (..) + , FinderOpts(..) + ) +where + +import GHC.Prelude +import GHC.Unit +import GHC.Data.OsPath +import qualified Data.Map as M +import GHC.Fingerprint +import GHC.Platform.Ways +import GHC.Unit.Env + +import GHC.Data.FastString +import qualified Data.Set as Set + +-- | The 'FinderCache' maps modules to the result of +-- searching for that module. It records the results of searching for +-- modules along the search path. On @:load@, we flush the entire +-- contents of this cache. +-- +type FinderCacheState = InstalledModuleEnv InstalledFindResult +type FileCacheState = M.Map FilePath Fingerprint +data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO () + -- ^ remove all the home modules from the cache; package modules are + -- assumed to not move around during a session; also flush the file hash + -- cache. + , addToFinderCache :: InstalledModule -> InstalledFindResult -> IO () + -- ^ Add a found location to the cache for the module. + , lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult) + -- ^ Look for a location in the cache. + , lookupFileCache :: FilePath -> IO Fingerprint + -- ^ Look for the hash of a file in the cache. This should add it to the + -- cache. If the file doesn't exist, raise an IOException. + } + +data InstalledFindResult + = InstalledFound ModLocation + | InstalledNoPackage UnitId + | InstalledNotFound [OsPath] (Maybe UnitId) + +-- | The result of searching for an imported module. +-- +-- NB: FindResult manages both user source-import lookups +-- (which can result in 'Module') as well as direct imports +-- for interfaces (which always result in 'InstalledModule'). +data FindResult + = Found ModLocation Module + -- ^ The module was found + | NoPackage Unit + -- ^ The requested unit was not found + | FoundMultiple [(Module, ModuleOrigin)] + -- ^ _Error_: both in multiple packages + + -- | Not found + | NotFound + { fr_paths :: [FilePath] -- ^ Places where I looked + + , fr_pkg :: Maybe Unit -- ^ Just p => module is in this unit's + -- manifest, but couldn't find the + -- .hi file + + , fr_mods_hidden :: [Unit] -- ^ Module is in these units, + -- but the *module* is hidden + + , fr_pkgs_hidden :: [Unit] -- ^ Module is in these units, + -- but the *unit* is hidden + + -- | Module is in these units, but it is unusable + , fr_unusables :: [UnusableUnit] + + , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules + } + +-- | Locations and information the finder cares about. +-- +-- Should be taken from 'DynFlags' via 'initFinderOpts'. +data FinderOpts = FinderOpts + { finder_importPaths :: [OsPath] + -- ^ Where are we allowed to look for Modules and Source files + , finder_lookupHomeInterfaces :: Bool + -- ^ When looking up a home module: + -- + -- * 'True': search interface files (e.g. in '-c' mode) + -- * 'False': search source files (e.g. in '--make' mode) + + , finder_bypassHiFileCheck :: Bool + -- ^ Don't check that an imported interface file actually exists + -- if it can only be at one location. The interface will be reported + -- as `InstalledFound` even if the file doesn't exist, so this is + -- only useful in specific cases (e.g. to generate dependencies + -- with `ghc -M`) + , finder_ways :: Ways + , finder_enableSuggestions :: Bool + -- ^ If we encounter unknown modules, should we suggest modules + -- that have a similar name. + , finder_workingDirectory :: Maybe OsPath + , finder_thisPackageName :: Maybe FastString + , finder_hiddenModules :: Set.Set ModuleName + , finder_reexportedModules :: M.Map ModuleName ModuleName -- Reverse mapping, if you are looking for this name then look for this module. + , finder_hieDir :: Maybe OsPath + , finder_hieSuf :: OsString + , finder_hiDir :: Maybe OsPath + , finder_hiSuf :: OsString + , finder_dynHiSuf :: OsString + , finder_objectDir :: Maybe OsPath + , finder_objectSuf :: OsString + , finder_dynObjectSuf :: OsString + , finder_stubDir :: Maybe OsPath + } diff --git a/GHC/Unit/Home.hs b/GHC/Unit/Home.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Home.hs @@ -0,0 +1,219 @@ +-- | The home unit is the unit (i.e. compiled package) that contains the module +-- we are compiling/typechecking. +module GHC.Unit.Home + ( GenHomeUnit (..) + , HomeUnit + , homeUnitId + , homeUnitInstantiations + , homeUnitInstanceOf + , homeUnitInstanceOfMaybe + , homeUnitAsUnit + , homeUnitMap + -- * Predicates + , isHomeUnitIndefinite + , isHomeUnitDefinite + , isHomeUnitInstantiating + , isHomeUnit + , isHomeUnitId + , isHomeUnitInstanceOf + , isHomeModule + , isHomeInstalledModule + , notHomeUnitId + , notHomeModule + , notHomeModuleMaybe + , notHomeInstalledModule + , notHomeInstalledModuleMaybe + -- * Helpers + , mkHomeModule + , mkHomeInstalledModule + , homeModuleInstantiation + , homeModuleNameInstantiation + ) +where + +import GHC.Prelude +import GHC.Unit.Types +import Data.Maybe + +import Language.Haskell.Syntax.Module.Name + +-- | Information about the home unit (i.e., the until that will contain the +-- modules we are compiling) +-- +-- The unit identifier of the instantiating units is left open to allow +-- switching from UnitKey (what is provided by the user) to UnitId (internal +-- unit identifier) with `homeUnitMap`. +-- +-- TODO: this isn't implemented yet. UnitKeys are still converted too early into +-- UnitIds in GHC.Unit.State.readUnitDataBase +data GenHomeUnit u + = DefiniteHomeUnit UnitId (Maybe (u, GenInstantiations u)) + -- ^ Definite home unit (i.e. that we can compile). + -- + -- Nothing: not an instantiated unit + -- Just (i,insts): made definite by instantiating "i" with "insts" + + | IndefiniteHomeUnit UnitId (GenInstantiations u) + -- ^ Indefinite home unit (i.e. that we can only typecheck) + -- + -- All the holes are instantiated with fake modules from the Hole unit. + -- See Note [Representation of module/name variables] in "GHC.Unit" + +type HomeUnit = GenHomeUnit UnitId + +-- | Return home unit id +homeUnitId :: GenHomeUnit u -> UnitId +homeUnitId (DefiniteHomeUnit u _) = u +homeUnitId (IndefiniteHomeUnit u _) = u + +-- | Return home unit instantiations +homeUnitInstantiations :: GenHomeUnit u -> GenInstantiations u +homeUnitInstantiations (DefiniteHomeUnit _ Nothing) = [] +homeUnitInstantiations (DefiniteHomeUnit _ (Just (_,is))) = is +homeUnitInstantiations (IndefiniteHomeUnit _ is) = is + +-- | Return the unit id of the unit that is instantiated by the home unit. +-- +-- E.g. if home unit = q[A=p:B,...] we return q. +-- +-- If the home unit is not an instance of another unit, we return its own unit +-- id (it is an instance of itself if you will). +homeUnitInstanceOf :: HomeUnit -> UnitId +homeUnitInstanceOf h = fromMaybe (homeUnitId h) (homeUnitInstanceOfMaybe h) + +-- | Return the unit id of the unit that is instantiated by the home unit. +-- +-- E.g. if home unit = q[A=p:B,...] we return (Just q). +-- +-- If the home unit is not an instance of another unit, we return Nothing. +homeUnitInstanceOfMaybe :: GenHomeUnit u -> Maybe u +homeUnitInstanceOfMaybe (DefiniteHomeUnit _ (Just (u,_))) = Just u +homeUnitInstanceOfMaybe _ = Nothing + +-- | Return the home unit as a normal unit. +-- +-- We infer from the home unit itself the kind of unit we create: +-- 1. If the home unit is definite, we must be compiling so we return a real +-- unit. The definite home unit may be the result of a unit instantiation, +-- say `p = q[A=r:X]`. In this case we could have returned a virtual unit +-- `q[A=r:X]` but it's not what the clients of this function expect, +-- especially because `p` is lost when we do this. The unit id of a virtual +-- unit is made up internally so `unitId(q[A=r:X])` is not equal to `p`. +-- +-- 2. If the home unit is indefinite we can only create a virtual unit from +-- it. It's ok because we must be only typechecking the home unit so we won't +-- produce any code object that rely on the unit id of this virtual unit. +homeUnitAsUnit :: HomeUnit -> Unit +homeUnitAsUnit (DefiniteHomeUnit u _) = RealUnit (Definite u) +homeUnitAsUnit (IndefiniteHomeUnit u is) = mkVirtUnit u is + +-- | Map over the unit identifier for instantiating units +homeUnitMap :: IsUnitId v => (u -> v) -> GenHomeUnit u -> GenHomeUnit v +homeUnitMap _ (DefiniteHomeUnit u Nothing) = DefiniteHomeUnit u Nothing +homeUnitMap f (DefiniteHomeUnit u (Just (i,is))) = DefiniteHomeUnit u (Just (f i, mapInstantiations f is)) +homeUnitMap f (IndefiniteHomeUnit u is) = IndefiniteHomeUnit u (mapInstantiations f is) + +---------------------------- +-- Predicates +---------------------------- + +-- | Test if we are type-checking an indefinite unit +-- +-- (if it is not, we should never use on-the-fly renaming) +isHomeUnitIndefinite :: GenHomeUnit u -> Bool +isHomeUnitIndefinite (DefiniteHomeUnit {}) = False +isHomeUnitIndefinite (IndefiniteHomeUnit {}) = True + +-- | Test if we are compiling a definite unit +-- +-- (if it is, we should never use on-the-fly renaming) +isHomeUnitDefinite :: GenHomeUnit u -> Bool +isHomeUnitDefinite (DefiniteHomeUnit {}) = True +isHomeUnitDefinite (IndefiniteHomeUnit {}) = False + +-- | Test if we are compiling by instantiating a definite unit +isHomeUnitInstantiating :: GenHomeUnit u -> Bool +isHomeUnitInstantiating u = + isHomeUnitDefinite u && not (null (homeUnitInstantiations u)) + +-- | Test if the unit is the home unit +isHomeUnit :: HomeUnit -> Unit -> Bool +isHomeUnit hu u = u == homeUnitAsUnit hu + +-- | Test if the unit-id is the home unit-id +isHomeUnitId :: GenHomeUnit u -> UnitId -> Bool +isHomeUnitId hu uid = uid == homeUnitId hu + +-- | Test if the unit-id is not the home unit-id +notHomeUnitId :: Maybe (GenHomeUnit u) -> UnitId -> Bool +notHomeUnitId Nothing _ = True +notHomeUnitId (Just hu) uid = not (isHomeUnitId hu uid) + +-- | Test if the home unit is an instance of the given unit-id +isHomeUnitInstanceOf :: HomeUnit -> UnitId -> Bool +isHomeUnitInstanceOf hu u = homeUnitInstanceOf hu == u + +-- | Test if the module comes from the home unit +isHomeModule :: HomeUnit -> Module -> Bool +isHomeModule hu m = isHomeUnit hu (moduleUnit m) + +-- | Test if the module comes from the home unit +isHomeInstalledModule :: GenHomeUnit u -> InstalledModule -> Bool +isHomeInstalledModule hu m = isHomeUnitId hu (moduleUnit m) + + +-- | Test if a module doesn't come from the given home unit +notHomeInstalledModule :: GenHomeUnit u -> InstalledModule -> Bool +notHomeInstalledModule hu m = not (isHomeInstalledModule hu m) + +-- | Test if a module doesn't come from the given home unit +notHomeInstalledModuleMaybe :: Maybe (GenHomeUnit u) -> InstalledModule -> Bool +notHomeInstalledModuleMaybe mh m = fromMaybe True $ fmap (`notHomeInstalledModule` m) mh + + +-- | Test if a module doesn't come from the given home unit +notHomeModule :: HomeUnit -> Module -> Bool +notHomeModule hu m = not (isHomeModule hu m) + +-- | Test if a module doesn't come from the given home unit +notHomeModuleMaybe :: Maybe HomeUnit -> Module -> Bool +notHomeModuleMaybe mh m = fromMaybe True $ fmap (`notHomeModule` m) mh + +---------------------------- +-- helpers +---------------------------- + +-- | Make a module in home unit +mkHomeModule :: HomeUnit -> ModuleName -> Module +mkHomeModule hu = mkModule (homeUnitAsUnit hu) + +-- | Make a module in home unit +mkHomeInstalledModule :: GenHomeUnit u -> ModuleName -> InstalledModule +mkHomeInstalledModule hu = mkModule (homeUnitId hu) + +-- | Return the module that is used to instantiate the given home module name. +-- If the ModuleName doesn't refer to a signature, return the actual home +-- module. +-- +-- E.g., the instantiating module of @A@ in @p[A=q[]:B]@ is @q[]:B@. +-- the instantiating module of @A@ in @p@ is @p:A@. +homeModuleNameInstantiation :: HomeUnit -> ModuleName -> Module +homeModuleNameInstantiation hu mod_name = + case lookup mod_name (homeUnitInstantiations hu) of + Nothing -> mkHomeModule hu mod_name + Just mod -> mod + +-- | Return the module that is used to instantiate the given home module. +-- +-- If the given module isn't a module hole, return the actual home module. +-- +-- E.g., the instantiating module of @p:A@ in @p[A=q[]:B]@ is @q[]:B@. +-- the instantiating module of @r:A@ in @p[A=q[]:B]@ is @r:A@. +-- the instantiating module of @p:A@ in @p@ is @p:A@. +-- the instantiating module of @r:A@ in @p@ is @r:A@. +homeModuleInstantiation :: Maybe HomeUnit -> Module -> Module +homeModuleInstantiation mhu mod + | Just hu <- mhu + , isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod) + | otherwise = mod + diff --git a/GHC/Unit/Home/Graph.hs b/GHC/Unit/Home/Graph.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Home/Graph.hs @@ -0,0 +1,381 @@ +-- | A 'HomeUnitGraph' (HUG) collects information about all the home units. +-- Crucially, each node in a 'HomeUnitGraph' includes a 'HomePackageTable'. +-- +-- Often, we don't want to query just a single 'HomePackageTable', but rather all +-- 'HomePackageTable's of all home units. +-- +-- This module is responsible for maintaining this bridge between querying all +-- home units vs querying the home package table directly. Think 'lookupHug' vs +-- 'lookupHpt', 'hugAllInstances' vs 'hptAllInstances', where the @hug@ version +-- replies with information from all home units, and the @hpt@ version with +-- information pertaining to a single home unit. +-- +-- Meant to be imported qualified as @HUG@. +-- Example usage: +-- +-- @ +-- import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv) +-- import qualified GHC.Unit.Home.Graph as HUG +-- usage = ... HUG.insertHug hug uid modname modinfo ... +-- @ +module GHC.Unit.Home.Graph + ( HomeUnitGraph + , HomeUnitEnv(..) + , mkHomeUnitEnv + + -- * Operations + , addHomeModInfoToHug + , restrictHug + , renameUnitId + , allUnits + , updateUnitFlags + + -- ** Lookups + , lookupHug + , lookupHugByModule + , lookupHugUnit + , lookupHugUnitId + , lookupAllHug + , memberHugUnit + , memberHugUnitId + -- ** Reachability + , transitiveHomeDeps + + -- * Very important queries + , allInstances + , allFamInstances + , allAnns + , allCompleteSigs + + -- * Utilities + , hugSCCs + , hugFromList + + -- ** Printing + , pprHomeUnitGraph + , pprHomeUnitEnv + + -- * Auxiliary internal structure + , UnitEnvGraph(..) + , unitEnv_lookup_maybe + , unitEnv_foldWithKey + , unitEnv_singleton + , unitEnv_adjust + , unitEnv_keys + , unitEnv_insert + , unitEnv_new + , unitEnv_lookup + , unitEnv_traverseWithKey + , unitEnv_assocs + ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Unit.Home +import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.State +import GHC.Utils.Monad (mapMaybeM) +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Core.FamInstEnv + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import GHC.Data.Maybe +import GHC.Data.Graph.Directed + +import GHC.Types.Annotations +import GHC.Types.CompleteMatch +import GHC.Core.InstEnv + + +-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across +-- all home units. +allCompleteSigs :: HomeUnitGraph -> IO CompleteMatches +allCompleteSigs hug = foldr go (pure []) hug where + go hue = liftA2 (++) (hptCompleteSigs (homeUnitEnv_hpt hue)) + +-- | Find all the instance declarations (of classes and families) from +-- the Home Package Table filtered by the provided predicate function. +-- Used in @tcRnImports@, to select the instances that are in the +-- transitive closure of imports from the currently compiled module. +allInstances :: HomeUnitGraph -> IO (InstEnv, [FamInst]) +allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where + go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b')) + (hptAllInstances (homeUnitEnv_hpt hue)) + +allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv) +allFamInstances hug = foldr go (pure emptyModuleEnv) hug where + go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue)) + +allAnns :: HomeUnitGraph -> IO AnnEnv +allAnns hug = foldr go (pure emptyAnnEnv) hug where + go hue = liftA2 plusAnnEnv (hptAllAnnotations (homeUnitEnv_hpt hue)) + +-------------------------------------------------------------------------------- +-- HomeUnitGraph (HUG) +-------------------------------------------------------------------------------- + +type HomeUnitGraph = UnitEnvGraph HomeUnitEnv + +data HomeUnitEnv = HomeUnitEnv + { homeUnitEnv_units :: !UnitState + -- ^ External units + + , homeUnitEnv_unit_dbs :: !(Maybe [UnitDatabase UnitId]) + -- ^ Stack of unit databases for the target platform. + -- + -- This field is populated with the result of `initUnits`. + -- + -- 'Nothing' means the databases have never been read from disk. + -- + -- Usually we don't reload the databases from disk if they are + -- cached, even if the database flags changed! + + , homeUnitEnv_dflags :: DynFlags + -- ^ The dynamic flag settings + , homeUnitEnv_hpt :: HomePackageTable + -- ^ The home package table describes already-compiled + -- home-package modules, /excluding/ the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so homeUnitEnv_hpt is empty. All other + -- modules count as \"external-package\" modules. + -- However, even in GHCi mode, hi-boot interfaces are + -- demand-loaded into the external-package table.) + -- + -- 'homeUnitEnv_hpt' is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by @--make@ + -- but not actually below the current module in the dependency + -- graph. + -- + -- (This changes a previous invariant: changed Jan 05.) + + , homeUnitEnv_home_unit :: !(Maybe HomeUnit) + -- ^ Home-unit + } + +mkHomeUnitEnv :: UnitState -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv +mkHomeUnitEnv us dbs dflags hpt home_unit = HomeUnitEnv + { homeUnitEnv_units = us + , homeUnitEnv_unit_dbs = dbs + , homeUnitEnv_dflags = dflags + , homeUnitEnv_hpt = hpt + , homeUnitEnv_home_unit = home_unit + } + +-------------------------------------------------------------------------------- +-- * Operations on HUG +-------------------------------------------------------------------------------- + +-- | Add an entry to the 'HomePackageTable' under the unit of that entry. +addHomeModInfoToHug :: HomeModInfo -> HomeUnitGraph -> IO () +addHomeModInfoToHug hmi hug = + case unitEnv_lookup_maybe hmi_unit hug of + Nothing -> pprPanic "addHomeInfoToHug" (ppr hmi_mod) + Just hue -> do + addHomeModInfoToHpt hmi (homeUnitEnv_hpt hue) + where + hmi_mod :: Module + hmi_mod = mi_module (hm_iface hmi) + hmi_unit = toUnitId (moduleUnit hmi_mod) + +-- | Thin each HPT variable to only contain keys from the given dependencies. +-- This is used at the end of upsweep to make sure that only completely successfully loaded +-- modules are visible for subsequent operations. +restrictHug :: [(UnitId, [HomeModInfo])] -> HomeUnitGraph -> IO () +restrictHug deps hug = unitEnv_foldWithKey (\k uid hue -> restrict_one uid hue >> k) (return ()) hug + where + deps_map = Map.fromList deps + restrict_one uid hue = + restrictHpt (homeUnitEnv_hpt hue) (Map.findWithDefault [] uid deps_map) + +-- | Rename a unit id in the 'HomeUnitGraph' +-- +-- @'renameUnitId' oldUnit newUnit hug@, if @oldUnit@ is not found in @hug@, returns 'Nothing'. +-- If it exists, the result maps @newUnit@ to the 'HomeUnitEnv' of the +-- @oldUnit@ (and @oldUnit@ is removed from @hug@) +renameUnitId :: UnitId -> UnitId -> HomeUnitGraph -> Maybe HomeUnitGraph +renameUnitId oldUnit newUnit hug = case unitEnv_lookup_maybe oldUnit hug of + Nothing -> Nothing + Just oldHue -> pure $ + unitEnv_insert newUnit oldHue $ + unitEnv_delete oldUnit hug + +-- | Retrieve all 'UnitId's of units in the 'HomeUnitGraph'. +allUnits :: HomeUnitGraph -> Set.Set UnitId +allUnits = unitEnv_keys + +-- | Set the 'DynFlags' of the 'HomeUnitEnv' for unit in the 'HomeModuleGraph' +updateUnitFlags :: UnitId -> (DynFlags -> DynFlags) -> HomeUnitGraph -> HomeUnitGraph +updateUnitFlags uid f = unitEnv_adjust update uid + where + update hue = hue { homeUnitEnv_dflags = f (homeUnitEnv_dflags hue) } + +-------------------------------------------------------------------------------- +-- ** Reachability +-------------------------------------------------------------------------------- + +-- | Compute the transitive closure of a unit in the 'HomeUnitGraph'. +-- If the argument unit is not present in the graph returns Nothing. +transitiveHomeDeps :: UnitId -> HomeUnitGraph -> Maybe [UnitId] +transitiveHomeDeps uid hug = case lookupHugUnitId uid hug of + Nothing -> Nothing + Just hue -> Just $ + Set.toList (loop (Set.singleton uid) (homeUnitDepends (homeUnitEnv_units hue))) + where + loop acc [] = acc + loop acc (uid:uids) + | uid `Set.member` acc = loop acc uids + | otherwise = + let hue = homeUnitDepends + . homeUnitEnv_units + . expectJust + $ lookupHugUnitId uid hug + in loop (Set.insert uid acc) (hue ++ uids) + +-------------------------------------------------------------------------------- +-- ** Lookups +-------------------------------------------------------------------------------- + +-- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' given its +-- 'UnitId' and 'ModuleName' (via the 'HomePackageTable' of the corresponding unit) +lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> IO (Maybe HomeModInfo) +lookupHug hug uid mod = do + case unitEnv_lookup_maybe uid hug of + Nothing -> pure Nothing + Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod + +-- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' (via the 'HomePackageTable' of the corresponding unit) +lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo) +lookupHugByModule mod hug = + case lookupHugUnit (moduleUnit mod) hug of + Nothing -> pure Nothing + Just env -> lookupHptByModule (homeUnitEnv_hpt env) mod + +-- | Lookup all 'HomeModInfo' that have the same 'ModuleName' as the given 'ModuleName'. +-- 'ModuleName's are not unique in the case of multiple home units, so there can be +-- more than one possible 'HomeModInfo'. +-- +-- You should always prefer 'lookupHug' and 'lookupHugByModule' when possible. +lookupAllHug :: HomeUnitGraph -> ModuleName -> IO [HomeModInfo] +lookupAllHug hug mod = mapMaybeM (\uid -> lookupHug hug uid mod) (Set.toList $ unitEnv_keys hug) + +-- | Lookup a 'HomeUnitEnv' by 'UnitId' in a 'HomeUnitGraph' +lookupHugUnitId :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv +lookupHugUnitId = unitEnv_lookup_maybe + +-- | Check whether the 'UnitId' is present in the 'HomeUnitGraph' +memberHugUnitId :: UnitId -> HomeUnitGraph -> Bool +memberHugUnitId u = isJust . lookupHugUnitId u + +-- | Lookup up the 'HomeUnitEnv' by the 'Unit' in the 'HomeUnitGraph'. +-- If the 'Unit' can be turned into a 'UnitId', we behave identical to 'lookupHugUnitId'. +-- +-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's +lookupHugUnit :: Unit -> HomeUnitGraph -> Maybe HomeUnitEnv +lookupHugUnit unit hug = + if isHoleUnit unit + then Nothing + else lookupHugUnitId (toUnitId unit) hug + +-- | Check whether the 'Unit' is present in the 'HomeUnitGraph' +-- +-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's +memberHugUnit :: Unit -> HomeUnitGraph -> Bool +memberHugUnit u = isJust . lookupHugUnit u + +-------------------------------------------------------------------------------- +-- * Internal representation map +-------------------------------------------------------------------------------- +-- Note: we purposefully do not export functions like "elems" to maintain a +-- good clean interface with the HUG. + +type UnitEnvGraphKey = UnitId + +newtype UnitEnvGraph v = UnitEnvGraph + { unitEnv_graph :: Map UnitEnvGraphKey v + } deriving (Functor, Foldable, Traversable) + +unitEnv_new :: Map UnitEnvGraphKey v -> UnitEnvGraph v +unitEnv_new m = + UnitEnvGraph + { unitEnv_graph = m + } + +unitEnv_insert :: UnitEnvGraphKey -> v -> UnitEnvGraph v -> UnitEnvGraph v +unitEnv_insert unitId env unitEnv = unitEnv + { unitEnv_graph = Map.insert unitId env (unitEnv_graph unitEnv) + } + +unitEnv_delete :: UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v +unitEnv_delete uid unitEnv = + unitEnv + { unitEnv_graph = Map.delete uid (unitEnv_graph unitEnv) + } + +unitEnv_adjust :: (v -> v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v +unitEnv_adjust f uid unitEnv = unitEnv + { unitEnv_graph = Map.adjust f uid (unitEnv_graph unitEnv) + } + +unitEnv_singleton :: UnitEnvGraphKey -> v -> UnitEnvGraph v +unitEnv_singleton active m = UnitEnvGraph + { unitEnv_graph = Map.singleton active m + } + +unitEnv_lookup_maybe :: UnitEnvGraphKey -> UnitEnvGraph v -> Maybe v +unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env) + +unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey +unitEnv_keys env = Map.keysSet (unitEnv_graph env) + +unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b +unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g + +unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v +unitEnv_lookup u env = expectJust $ unitEnv_lookup_maybe u env + +unitEnv_traverseWithKey :: Applicative f => (UnitEnvGraphKey -> a -> f b) -> UnitEnvGraph a -> f (UnitEnvGraph b) +unitEnv_traverseWithKey f unitEnv = + UnitEnvGraph <$> Map.traverseWithKey f (unitEnv_graph unitEnv) + +unitEnv_assocs :: UnitEnvGraph a -> [(UnitEnvGraphKey, a)] +unitEnv_assocs (UnitEnvGraph x) = Map.assocs x + +-------------------------------------------------------------------------------- +-- * Utilities +-------------------------------------------------------------------------------- + +hugSCCs :: HomeUnitGraph -> [SCC UnitId] +hugSCCs hug = sccs where + mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId + mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue)) + nodes = map mkNode (Map.toList $ unitEnv_graph hug) + + sccs = stronglyConnCompFromEdgedVerticesOrd nodes + +hugFromList :: [(UnitId, HomeUnitEnv)] -> HomeUnitGraph +hugFromList = UnitEnvGraph . Map.fromList + +pprHomeUnitGraph :: HomeUnitGraph -> IO SDoc +pprHomeUnitGraph unitEnv = do + docs <- mapM (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv + return $ vcat docs + +pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> IO SDoc +pprHomeUnitEnv uid env = do + hptDoc <- pprHPT $ homeUnitEnv_hpt env + return $ + ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->" + $$ nest 4 hptDoc + diff --git a/GHC/Unit/Home/ModInfo.hs b/GHC/Unit/Home/ModInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Home/ModInfo.hs @@ -0,0 +1,109 @@ +-- | Info about modules in the "home" unit. +-- Stored in a 'HomePackageTable'. +module GHC.Unit.Home.ModInfo + ( + HomeModInfo (..) + , HomeModLinkable(..) + , homeModInfoObject + , homeModInfoByteCode + , emptyHomeModInfoLinkable + , justBytecode + , justObjects + , bytecodeAndObjects + ) +where + +import GHC.Prelude + +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModDetails + +import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic + + +-- | Information about modules in the package being compiled +data HomeModInfo = HomeModInfo + { hm_iface :: !ModIface + -- ^ The basic loaded interface file: every loaded module has one of + -- these, even if it is imported from another package + + , hm_details :: ModDetails + -- ^ Extra information that has been created from the 'ModIface' for + -- the module, typically during typechecking + + -- This field is LAZY because a ModDetails is constructed by knot tying. + + , hm_linkable :: !HomeModLinkable + -- ^ The actual artifact we would like to link to access things in + -- this module. See Note [Home module build products] + -- + -- 'hm_linkable' might be empty: + -- + -- 1. If this is an .hs-boot module + -- + -- 2. Temporarily during compilation if we pruned away + -- the old linkable because it was out of date. + -- + -- When re-linking a module ('GHC.Driver.Main.HscNoRecomp'), we construct the + -- 'HomeModInfo' by building a new 'ModDetails' from the old + -- 'ModIface' (only). + } + +homeModInfoByteCode :: HomeModInfo -> Maybe Linkable +homeModInfoByteCode = homeMod_bytecode . hm_linkable + +homeModInfoObject :: HomeModInfo -> Maybe Linkable +homeModInfoObject = homeMod_object . hm_linkable + +emptyHomeModInfoLinkable :: HomeModLinkable +emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing + +-- See Note [Home module build products] +data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable) + , homeMod_object :: !(Maybe Linkable) } + +instance Outputable HomeModLinkable where + ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2 + +justBytecode :: Linkable -> HomeModLinkable +justBytecode lm = + assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm) + $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm } + +justObjects :: Linkable -> HomeModLinkable +justObjects lm = + assertPpr (linkableIsNativeCodeOnly lm) (ppr lm) + $ emptyHomeModInfoLinkable { homeMod_object = Just lm } + +bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable +bytecodeAndObjects bc o = + assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o) + (HomeModLinkable (Just bc) (Just o)) + + +{- +Note [Home module build products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When compiling a home module we can produce some combination of the following +build products. + +1. A byte code linkable, for use with the byte code interpreter. +2. An object file linkable, for linking a final executable or the byte code interpreter + +What we have produced is recorded in the `HomeModLinkable` type. In the case +that these linkables are produced they are stored in the relevant field so that +subsequent modules can retrieve and use them as necessary. + +* `-fbyte-code` will *only* produce a byte code linkable. This is the default in GHCi. +* `-fobject-code` will *only* produce an object file linkable. This is the default in -c and --make mode. +* `-fbyte-code-and-object-code` produces both a byte-code and object file linkable. So both fields are populated. + +Why would you want to produce both an object file and byte code linkable? If you +also want to use `-fprefer-byte-code` then you should probably also use this +flag to make sure that byte code is generated for your modules. + +-} diff --git a/GHC/Unit/Home/PackageTable.hs b/GHC/Unit/Home/PackageTable.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Home/PackageTable.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE LambdaCase #-} +-- | The 'HomePackageTable' (HPT) contains information about all modules that are part +-- of a home package. At its core, the information for each module is a +-- 'HomeModInfo'. +-- +-- During upsweep, the HPT is a monotonically increasing data structure: it +-- only ever gets extended by inserting modules which are loaded and for which +-- we discover the information required to construct a 'ModInfo'. +-- +-- There should only ever exist one single HPT for any given home unit. It's +-- crucial we don't accidentally leak HPTs (e.g. by filtering it, which used to +-- happen -- #25511), so the HPT is mutable and only its reference should be shared. +-- This is alright because the modules don't change throughout compilation. +-- +-- :::WARNING::: +-- If you intend to change this interface, consider carefully whether you are +-- exposing memory-leak footguns which may end up being misused in the compiler +-- eventually. For instance, if you really, really, end up needing a way to take +-- a snapshot of the IORef (think: do you really need to?), at least make +-- obvious in the name like `snapshotCopyHpt`. +-- +-- Or, do you really need a function to traverse all modules in the HPT? It is +-- often better to keep the computation internal to this module, such as in +-- 'hptCollectObjects'... +module GHC.Unit.Home.PackageTable + ( + HomePackageTable(..) + , emptyHomePackageTable + + -- * Lookups in the HPT + , lookupHpt + , lookupHptByModule + + -- * Extending the HPT + , addHomeModInfoToHpt + , addHomeModInfosToHpt + + -- * Restrict the HPT + , restrictHpt + + -- * Queries about home modules + , hptCompleteSigs + , hptAllInstances + , hptAllFamInstances + , hptAllAnnotations + + -- ** More Traversal-based queries + , hptCollectDependencies + , hptCollectObjects + , hptCollectModules + + -- ** Memory dangerous queries + , concatHpt + + -- * Utilities + , pprHPT + + -- * Internals + -- + -- | These provide access to the internals of the HomePackageTable to + -- facilitate existing workflows that used the previous API. For instance, + -- if you were listing out all elements or merging, you can keep doing so by reading + -- the internal IO ref and then using the moduleenv contents directly. + -- + -- In GHC itself these should be avoided, and other uses should justify why + -- it is not sufficient to go through the intended insert-only API. + , hptInternalTableRef + , hptInternalTableFromRef + + -- * Legacy API + -- + -- | This API is deprecated and meant to be removed. + , addToHpt + , addListToHpt + ) where + +import GHC.Prelude +import GHC.Data.Maybe + +import Data.IORef +import Control.Monad ((<$!>)) +import qualified Data.Set as Set + +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv +import GHC.Linker.Types +import GHC.Types.Annotations +import GHC.Types.CompleteMatch +import GHC.Types.Unique.DFM +import GHC.Unit.Home.ModInfo +import GHC.Unit.Module +import GHC.Unit.Module.Deps +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Utils.Outputable +import GHC.Types.Unique (getUnique, getKey) +import qualified GHC.Data.Word64Set as W64 + +-- | Helps us find information about modules in the home package +newtype HomePackageTable = HPT { + + table :: IORef (DModuleNameEnv HomeModInfo) + -- ^ Domain = modules in this home unit + -- + -- This is an IORef because we want to avoid leaking HPTs (see the particularly bad #25511). + -- Moreover, the HPT invariant allows mutability in this table without compromising thread safety or soundness. + -- To recall: + -- A query to the HPT should depend only on data relevant to that query, such that + -- there being more or less unrelated entries in the HPT does not influence the result in any way. + -- + -- Note that the HPT increases monotonically, except at certain barrier + -- points like when 'restrictHpt' is called. At these barriers, it is safe + -- to temporarily violate the HPT monotonicity. + -- + -- The elements of this table may be updated (e.g. on rehydration). + } + +-- | Create a new 'HomePackageTable'. +-- +-- Be careful not to share it across e.g. different units, since it uses a +-- mutable variable under the hood to keep the monotonically increasing list of +-- loaded modules. +emptyHomePackageTable :: IO HomePackageTable +-- romes:todo: use a MutableArray directly? +emptyHomePackageTable = do + table <- newIORef emptyUDFM + return HPT{table} + +-------------------------------------------------------------------------------- +-- * Lookups in the HPT +-------------------------------------------------------------------------------- + +-- | Lookup the 'HomeModInfo' of a module in the HPT, given its name. +lookupHpt :: HomePackageTable -> ModuleName -> IO (Maybe HomeModInfo) +lookupHpt HPT{table=hpt} mn = (`lookupUDFM` mn) <$!> readIORef hpt + +-- | Lookup the 'HomeModInfo' of a 'Module' in the HPT. +lookupHptByModule :: HomePackageTable -> Module -> IO (Maybe HomeModInfo) +lookupHptByModule hpt mod + = -- The HPT is indexed by ModuleName, not Module, + -- we must check for a hit on the right Module + lookupHpt hpt (moduleName mod) >>= pure . \case + Just hm | mi_module (hm_iface hm) == mod -> Just hm + _otherwise -> Nothing + +-------------------------------------------------------------------------------- +-- * Extending the HPT +-------------------------------------------------------------------------------- + +-- | Add a new module to the HPT. +-- +-- An HPT is a monotonically increasing data structure, holding information about loaded modules in a package. +-- This is the main function by which the HPT is extended or updated. +-- +-- When the module of the inserted 'HomeModInfo' does not exist, a new entry in +-- the HPT is created for that module name. +-- When the module already has an entry, inserting a new one entry in the HPT +-- will always overwrite the existing entry for that module. +addHomeModInfoToHpt :: HomeModInfo -> HomePackageTable -> IO () +addHomeModInfoToHpt hmi hpt = addToHpt hpt (moduleName (mi_module (hm_iface hmi))) hmi + +{-# DEPRECATED addToHpt "Deprecated in favour of 'addHomeModInfoToHpt', as the module at which a 'HomeModInfo' is inserted should always be derived from the 'HomeModInfo' itself." #-} +-- After deprecation cycle, move `addToHpt` to a `where` clause inside `addHomeModInfoToHpt`. +addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> IO () +addToHpt HPT{table=hptr} mn hmi = do + atomicModifyIORef' hptr (\hpt -> (addToUDFM hpt mn hmi, ())) + -- If the key already existed in the map, this insertion is overwriting + -- the HMI of a previously loaded module (likely in rehydration). + +-- | 'addHomeModInfoToHpt' for multiple module infos. +addHomeModInfosToHpt :: HomePackageTable -> [HomeModInfo] -> IO () +addHomeModInfosToHpt hpt = mapM_ (flip addHomeModInfoToHpt hpt) + +-- | Thin each HPT variable to only contain keys from the given dependencies. +-- This is used at the end of upsweep to make sure that only completely successfully loaded +-- modules are visible for subsequent operations. +-- +-- This is an exception to the invariant of the HPT -- that it grows +-- monotonically, never removing entries -- which is safe as long as it is only +-- called at barrier points, such as the end of upsweep, when all threads are +-- done and we want to clean up failed entries. +restrictHpt :: HomePackageTable -> [HomeModInfo] -> IO () +restrictHpt HPT{table=hptr} hmis = + let key_set = map (getKey . getUnique . hmi_mod) hmis + hmi_mod hmi = moduleName (mi_module (hm_iface hmi)) + in atomicModifyIORef' hptr (\hpt -> (udfmRestrictKeysSet hpt (W64.fromList key_set), ())) + +{-# DEPRECATED addListToHpt "Deprecated in favour of 'addHomeModInfosToHpt', as the module at which a 'HomeModInfo' is inserted should always be derived from the 'HomeModInfo' itself." #-} +-- After deprecation cycle, remove. +addListToHpt :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> IO () +addListToHpt hpt = mapM_ (uncurry (addToHpt hpt)) + +---------------------------------------------------------------------------------- +---- * Queries +---------------------------------------------------------------------------------- + +-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present in all +-- modules from this unit's HPT. +hptCompleteSigs :: HomePackageTable -> IO CompleteMatches +hptCompleteSigs = concatHpt (md_complete_matches . hm_details) + +-- | Find all the instance declarations (of classes and families) from this Home Package Table +hptAllInstances :: HomePackageTable -> IO (InstEnv, [FamInst]) +hptAllInstances hpt = do + hits <- flip concatHpt hpt $ \mod_info -> do + let details = hm_details mod_info + return (md_insts details, md_fam_insts details) + let (insts, famInsts) = unzip hits + return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) + +-- | Find all the family instance declarations from the HPT +hptAllFamInstances :: HomePackageTable -> IO (ModuleEnv FamInstEnv) +hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiFamInstEnv hmi)]) + where + hmiModule = mi_module . hm_iface + hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv + . md_fam_insts . hm_details + +-- | All annotations from the HPT +hptAllAnnotations :: HomePackageTable -> IO AnnEnv +hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details) + + +-------------------------------------------------------------------------------- +-- * Traversal-based queries +-------------------------------------------------------------------------------- + +-- | Collect the immediate dependencies of all modules in the HPT into a Set. +-- The immediate dependencies are given by the iface as @'dep_direct_pkgs' . 'mi_deps'@. +-- +-- Note: This should be a query on the 'ModuleGraph', since we don't really +-- ever want to collect *all* dependencies. The current caller of this function +-- currently takes all dependencies only to then filter them with an ad-hoc transitive closure check. +-- See #25639 +hptCollectDependencies :: HomePackageTable -> IO (Set.Set (IfaceImportLevel, UnitId)) +hptCollectDependencies HPT{table} = do + hpt <- readIORef table + return $ + foldr (Set.union . dep_direct_pkgs . mi_deps . hm_iface) Set.empty hpt + +-- | Collect the linkable object of all modules in the HPT. +-- The linkable objects are given by @'homeModInfoObject'@. +-- +-- $O(n)$ in the number of modules in the HPT. +hptCollectObjects :: HomePackageTable -> IO [Linkable] +hptCollectObjects HPT{table} = do + hpt <- readIORef table + return $ + foldr ((:) . expectJust . homeModInfoObject) [] hpt + +-- | Collect all module ifaces in the HPT +-- +-- $O(n)$ in the number of modules in the HPT. +hptCollectModules :: HomePackageTable -> IO [Module] +hptCollectModules HPT{table} = do + hpt <- readIORef table + return $ + foldr ((:) . mi_module . hm_iface) [] hpt + +-------------------------------------------------------------------------------- +-- * Utilities +-------------------------------------------------------------------------------- + +-- | Pretty print a 'HomePackageTable'. +-- +-- Make sure you really do need to print the whole HPT before infusing too much +-- code with IO. +-- +-- For instance, in the HUG, it suffices to print the unit-keys present in the +-- unit map in failed lookups. +pprHPT :: HomePackageTable -> IO SDoc +-- A bit arbitrary for now +pprHPT HPT{table=hptr} = do + hpt <- readIORef hptr + return $! + pprUDFM hpt $ \hms -> + vcat [ ppr (mi_module (hm_iface hm)) + | hm <- hms ] + +---------------------------------------------------------------------------------- +-- THE TYPE OF FOOTGUNS WE DON'T WANT TO EXPOSE +---------------------------------------------------------------------------------- + +-- eltsHpt :: HomePackageTable -> [HomeModInfo] +-- filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable +-- mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable +-- delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable +-- listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable +-- listHMIToHpt :: [HomeModInfo] -> HomePackageTable + +---------------------------------------------------------------------------------- +-- Would be fine, but may lead to linearly traversing the HPT unnecessarily +-- (e.g. `lastLoadedKey` superseded bad usages) +---------------------------------------------------------------------------------- + +-- allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool +-- allHpt = allUDFM + +-- anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool +-- anyHpt = anyUDFM + +---------------------------------------------------------------------------------- +-- Would be ok to expose this function very /careful/ with the argument function +---------------------------------------------------------------------------------- + +-- | Like @concatMap f . 'eltsHpt'@, but filters out all 'HomeModInfo' for which +-- @f@ returns the empty list before doing the sort inherent to 'eltsUDFM'. +-- +-- If this function is ever exposed from the HPT module, make sure the +-- argument function doesn't introduce leaks. +concatHpt :: (HomeModInfo -> [a]) -> HomePackageTable -> IO [a] +concatHpt f HPT{table} = do + hpt <- readIORef table + return $ concat . eltsUDFM . mapMaybeUDFM g $ hpt + where + g hmi = case f hmi of { [] -> Nothing; as -> Just as } + +-------------------------------------------------------------------------------- +-- * Internals (see haddocks!) +-------------------------------------------------------------------------------- + +-- | Gets the internal 'IORef' which holds the 'HomeModInfo's of this HPT. +-- Use with care. +hptInternalTableRef :: HomePackageTable -> IORef (DModuleNameEnv HomeModInfo) +hptInternalTableRef = table + +-- | Construct a HomePackageTable from the IORef. +-- Use with care, only if you can really justify going around the intended insert-only API. +hptInternalTableFromRef :: IORef (DModuleNameEnv HomeModInfo) -> IO HomePackageTable +hptInternalTableFromRef ref = do + return HPT { + table = ref + } + diff --git a/GHC/Unit/Info.hs b/GHC/Unit/Info.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Info.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-} + +-- | Info about installed units (compiled libraries) +module GHC.Unit.Info + ( GenericUnitInfo (..) + , GenUnitInfo + , UnitInfo + , UnitKey (..) + , UnitKeyInfo + , mkUnitKeyInfo + , mapUnitInfo + , mkUnitPprInfo + + , mkUnit + + , PackageId(..) + , PackageName(..) + , Version(..) + , unitPackageNameString + , unitPackageIdString + , pprUnitInfo + + , collectIncludeDirs + , collectExtraCcOpts + , collectLibraryDirs + , collectFrameworks + , collectFrameworksDirs + , unitHsLibs + ) +where + +import GHC.Prelude +import GHC.Platform.Ways + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Types.Unique + +import GHC.Data.FastString +import qualified GHC.Data.ShortText as ST + +import GHC.Unit.Module as Module +import GHC.Unit.Ppr +import GHC.Unit.Database + +import GHC.Settings + +import Data.Version +import Data.Bifunctor +import Data.List (isPrefixOf, stripPrefix) + + +-- | Information about an installed unit +-- +-- We parameterize on the unit identifier: +-- * UnitKey: identifier used in the database (cf 'UnitKeyInfo') +-- * UnitId: identifier used to generate code (cf 'UnitInfo') +-- +-- These two identifiers are different for wired-in packages. See Note [About +-- units] in "GHC.Unit" +type GenUnitInfo unit = GenericUnitInfo PackageId PackageName unit ModuleName (GenModule (GenUnit unit)) + +-- | Information about an installed unit (units are identified by their database +-- UnitKey) +type UnitKeyInfo = GenUnitInfo UnitKey + +-- | Information about an installed unit (units are identified by their internal +-- UnitId) +type UnitInfo = GenUnitInfo UnitId + +-- | Convert a DbUnitInfo (read from a package database) into `UnitKeyInfo` +mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo +mkUnitKeyInfo = mapGenericUnitInfo + mkUnitKey' + mkPackageIdentifier' + mkPackageName' + mkModuleName' + mkModule' + where + mkPackageIdentifier' = PackageId . mkFastStringByteString + mkPackageName' = PackageName . mkFastStringByteString + mkUnitKey' = UnitKey . mkFastStringByteString + mkModuleName' = mkModuleNameFS . mkFastStringByteString + mkVirtUnitKey' i = case i of + DbInstUnitId cid insts -> mkVirtUnit (mkUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts) + DbUnitId uid -> RealUnit (Definite (mkUnitKey' uid)) + mkModule' m = case m of + DbModule uid n -> mkModule (mkVirtUnitKey' uid) (mkModuleName' n) + DbModuleVar n -> mkHoleModule (mkModuleName' n) + +-- | Map over the unit parameter +mapUnitInfo :: IsUnitId v => (u -> v) -> GenUnitInfo u -> GenUnitInfo v +mapUnitInfo f = mapGenericUnitInfo + f -- unit identifier + id -- package identifier + id -- package name + id -- module name + (fmap (mapGenUnit f)) -- instantiating modules + +newtype PackageId = PackageId FastString deriving (Eq) +newtype PackageName = PackageName + { unPackageName :: FastString + } + deriving (Eq) + +instance Uniquable PackageId where + getUnique (PackageId n) = getUnique n + +instance Uniquable PackageName where + getUnique (PackageName n) = getUnique n + +instance Outputable PackageId where + ppr (PackageId str) = ftext str + +instance Outputable PackageName where + ppr (PackageName str) = ftext str + +unitPackageIdString :: GenUnitInfo u -> String +unitPackageIdString pkg = unpackFS str + where + PackageId str = unitPackageId pkg + +unitPackageNameString :: GenUnitInfo u -> String +unitPackageNameString pkg = unpackFS str + where + PackageName str = unitPackageName pkg + +pprUnitInfo :: UnitInfo -> SDoc +pprUnitInfo GenericUnitInfo {..} = + vcat [ + field "name" (ppr unitPackageName), + field "version" (text (showVersion unitPackageVersion)), + field "id" (ppr unitId), + field "exposed" (ppr unitIsExposed), + field "exposed-modules" (ppr unitExposedModules), + field "hidden-modules" (fsep (map ppr unitHiddenModules)), + field "trusted" (ppr unitIsTrusted), + field "import-dirs" (fsep (map (text . ST.unpack) unitImportDirs)), + field "library-dirs" (fsep (map (text . ST.unpack) unitLibraryDirs)), + field "dynamic-library-dirs" (fsep (map (text . ST.unpack) unitLibraryDynDirs)), + field "hs-libraries" (fsep (map (text . ST.unpack) unitLibraries)), + field "extra-libraries" (fsep (map (text . ST.unpack) unitExtDepLibsSys)), + field "extra-ghci-libraries" (fsep (map (text . ST.unpack) unitExtDepLibsGhc)), + field "include-dirs" (fsep (map (text . ST.unpack) unitIncludeDirs)), + field "includes" (fsep (map (text . ST.unpack) unitIncludes)), + field "depends" (fsep (map ppr unitDepends)), + field "cc-options" (fsep (map (text . ST.unpack) unitCcOptions)), + field "ld-options" (fsep (map (text . ST.unpack) unitLinkerOptions)), + field "framework-dirs" (fsep (map (text . ST.unpack) unitExtDepFrameworkDirs)), + field "frameworks" (fsep (map (text . ST.unpack) unitExtDepFrameworks)), + field "haddock-interfaces" (fsep (map (text . ST.unpack) unitHaddockInterfaces)), + field "haddock-html" (fsep (map (text . ST.unpack) unitHaddockHTMLs)) + ] + where + field name body = text name <> colon <+> nest 4 body + +-- | Make a `Unit` from a `UnitInfo` +-- +-- If the unit is definite, make a `RealUnit` from `unitId` field. +-- +-- If the unit is indefinite, make a `VirtUnit` from `unitInstanceOf` and +-- `unitInstantiations` fields. Note that in this case we don't keep track of +-- `unitId`. It can be retrieved later with "improvement", i.e. matching on +-- `unitInstanceOf/unitInstantiations` fields (see Note [About units] in +-- GHC.Unit). +mkUnit :: UnitInfo -> Unit +mkUnit p + | unitIsIndefinite p = mkVirtUnit (unitInstanceOf p) (unitInstantiations p) + | otherwise = RealUnit (Definite (unitId p)) + +-- | Create a UnitPprInfo from a UnitInfo +mkUnitPprInfo :: (u -> FastString) -> GenUnitInfo u -> UnitPprInfo +mkUnitPprInfo ufs i = UnitPprInfo + (ufs (unitId i)) + (unitPackageNameString i) + (unitPackageVersion i) + ((unpackFS . unPackageName) <$> unitComponentName i) + +-- | Find all the include directories in the given units +collectIncludeDirs :: [UnitInfo] -> [FilePath] +collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps)) + +-- | Find all the C-compiler options in the given units +collectExtraCcOpts :: [UnitInfo] -> [String] +collectExtraCcOpts ps = map ST.unpack (concatMap unitCcOptions ps) + +-- | Find all the library directories in the given units for the given ways +collectLibraryDirs :: Ways -> [UnitInfo] -> [FilePath] +collectLibraryDirs ws = ordNub . filter notNull . concatMap (libraryDirsForWay ws) + +-- | Find all the frameworks in the given units +collectFrameworks :: [UnitInfo] -> [String] +collectFrameworks ps = map ST.unpack (concatMap unitExtDepFrameworks ps) + +-- | Find all the package framework paths in these and the preload packages +collectFrameworksDirs :: [UnitInfo] -> [String] +collectFrameworksDirs ps = map ST.unpack (ordNub (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps))) + +-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. +libraryDirsForWay :: Ways -> UnitInfo -> [String] +libraryDirsForWay ws + | hasWay ws WayDyn = map ST.unpack . unitLibraryDynDirs + | otherwise = map ST.unpack . unitLibraryDirs + +unitHsLibs :: GhcNameVersion -> Ways -> UnitInfo -> [String] +unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p) + where + ways1 = removeWay WayDyn ways0 + -- the name of a shared library is libHSfoo-ghc.so + -- we leave out the _dyn, because it is superfluous + + tag = waysTag (fullWays ways1) + rts_tag = waysTag ways1 + + mkDynName x + | not (ways0 `hasWay` WayDyn) = x + | "HS" `isPrefixOf` x = x ++ dynLibSuffix namever + -- For non-Haskell libraries, we use the name "Cfoo". The .a + -- file is libCfoo.a, and the .so is libfoo.so. That way the + -- linker knows what we mean for the vanilla (-lCfoo) and dyn + -- (-lfoo) ways. We therefore need to strip the 'C' off here. + | Just x' <- stripPrefix "C" x = x' + | otherwise + = panic ("Don't understand library name " ++ x) + + -- Add _thr and other rts suffixes to packages named + -- `rts` or `rts-1.0`. Why both? Traditionally the rts + -- package is called `rts` only. However the tooling + -- usually expects a package name to have a version. + -- As such we will gradually move towards the `rts-1.0` + -- package name, at which point the `rts` package name + -- will eventually be unused. + -- + -- This change elevates the need to add custom hooks + -- and handling specifically for the `rts` package. + addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) + addSuffix rts@"HSrts-1.0.3" = rts ++ (expandTag rts_tag) + addSuffix other_lib = other_lib ++ (expandTag tag) + + expandTag t | null t = "" + | otherwise = '_':t diff --git a/GHC/Unit/Module.hs b/GHC/Unit/Module.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +{- +(c) The University of Glasgow, 2004-2006 + + +Module +~~~~~~~~~~ +Simply the name of a module, represented as a FastString. +These are Uniquable, hence we can build Maps with Modules as +the keys. +-} + +module GHC.Unit.Module + ( module GHC.Unit.Types + + -- * The ModuleName type + , module Language.Haskell.Syntax.Module.Name + + -- * The ModLocation type + , module GHC.Unit.Module.Location + + -- * ModuleEnv + , module GHC.Unit.Module.Env + + -- * Generalization + , getModuleInstantiation + , getUnitInstantiations + , uninstantiateInstantiatedUnit + , uninstantiateInstantiatedModule + + -- * The Module type + , mkHoleModule + , isHoleModule + , stableModuleCmp + , moduleStableString + , moduleIsDefinite + , HasModule(..) + , ContainsModule(..) + , installedModuleEq + ) where + +import GHC.Prelude + +import GHC.Types.Unique.DSet +import GHC.Unit.Types +import GHC.Unit.Module.Location +import GHC.Unit.Module.Env + +import Language.Haskell.Syntax.Module.Name + +import Data.Semigroup + +-- | A 'Module' is definite if it has no free holes. +moduleIsDefinite :: Module -> Bool +moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles + +-- | Get a string representation of a 'Module' that's unique and stable +-- across recompilations. +-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal" +moduleStableString :: Module -> String +moduleStableString Module{..} = + "$" ++ unitString moduleUnit ++ "$" ++ moduleNameString moduleName + + +-- | This gives a stable ordering, as opposed to the Ord instance which +-- gives an ordering based on the 'Unique's of the components, which may +-- not be stable from run to run of the compiler. +stableModuleCmp :: Module -> Module -> Ordering +stableModuleCmp (Module p1 n1) (Module p2 n2) = stableUnitCmp p1 p2 <> stableModuleNameCmp n1 n2 + +class ContainsModule t where + extractModule :: t -> Module + +class HasModule m where + getModule :: m Module + + +-- | Test if a 'Module' corresponds to a given 'InstalledModule', +-- modulo instantiation. +installedModuleEq :: InstalledModule -> Module -> Bool +installedModuleEq imod mod = + fst (getModuleInstantiation mod) == imod + + +{- +************************************************************************ +* * + Hole substitutions +* * +************************************************************************ +-} + +-- | Given a possibly on-the-fly instantiated module, split it into +-- a 'Module' that we definitely can find on-disk, as well as an +-- instantiation if we need to instantiate it on the fly. If the +-- instantiation is @Nothing@ no on-the-fly renaming is needed. +getModuleInstantiation :: Module -> (InstalledModule, Maybe InstantiatedModule) +getModuleInstantiation m = + let (uid, mb_iuid) = getUnitInstantiations (moduleUnit m) + in (Module uid (moduleName m), + fmap (\iuid -> Module iuid (moduleName m)) mb_iuid) + +-- | Return the unit-id this unit is an instance of and the module instantiations (if any). +getUnitInstantiations :: Unit -> (UnitId, Maybe InstantiatedUnit) +getUnitInstantiations (VirtUnit iuid) = (instUnitInstanceOf iuid, Just iuid) +getUnitInstantiations (RealUnit (Definite uid)) = (uid, Nothing) +getUnitInstantiations (HoleUnit {}) = error "Hole unit" + +-- | Remove instantiations of the given instantiated unit +uninstantiateInstantiatedUnit :: InstantiatedUnit -> InstantiatedUnit +uninstantiateInstantiatedUnit u = + mkInstantiatedUnit (instUnitInstanceOf u) + (map (\(m,_) -> (m, mkHoleModule m)) + (instUnitInsts u)) + +-- | Remove instantiations of the given module instantiated unit +uninstantiateInstantiatedModule :: InstantiatedModule -> InstantiatedModule +uninstantiateInstantiatedModule (Module uid n) = Module (uninstantiateInstantiatedUnit uid) n + +-- | Test if a Module is not instantiated +isHoleModule :: GenModule (GenUnit u) -> Bool +isHoleModule (Module HoleUnit _) = True +isHoleModule _ = False + +-- | Create a hole Module +mkHoleModule :: ModuleName -> GenModule (GenUnit u) +mkHoleModule = Module HoleUnit diff --git a/GHC/Unit/Module/Deps.hs b/GHC/Unit/Module/Deps.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Deps.hs @@ -0,0 +1,669 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE DerivingVia #-} +-- | Dependencies and Usage of a module +module GHC.Unit.Module.Deps + ( Dependencies(dep_direct_mods + , dep_direct_pkgs + , dep_sig_mods + , dep_trusted_pkgs + , dep_orphs + , dep_plugin_pkgs + , dep_finsts + , dep_boot_mods + , Dependencies) + , dep_orphs_update + , dep_finsts_update + , mkDependencies + , noDependencies + , pprDeps + , Usage (..) + , HomeModImport (..) + , HomeModImportedAvails (..) + , ImportAvails (..) + , IfaceImportLevel(..) + , tcImportLevel + ) +where + +import GHC.Prelude + +import GHC.Data.FastString + +import GHC.Types.Avail +import GHC.Types.SafeHaskell +import GHC.Types.Name +import GHC.Types.Basic + +import GHC.Unit.Module.Imported +import GHC.Unit.Module +import GHC.Unit.Home +import GHC.Unit.State + +import GHC.Utils.Fingerprint +import GHC.Utils.Binary +import GHC.Utils.Outputable + +import Data.List (sortBy, sort, partition) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Bifunctor +import Control.DeepSeq +import GHC.Types.Name.Set + + + +-- | Dependency information about ALL modules and packages below this one +-- in the import hierarchy. This is the serialisable version of `ImportAvails`. +-- +-- Invariant: the dependencies of a module @M@ never includes @M@. +-- +-- Invariant: none of the lists contain duplicates. +-- +-- Invariant: lists are ordered canonically (e.g. using stableModuleCmp) +-- +-- See Note [Transitive Information in Dependencies] +data Dependencies = Deps + { dep_direct_mods_ :: Set (IfaceImportLevel, UnitId, ModuleNameWithIsBoot) + -- ^ All home-package modules which are directly imported by this one. + -- This may include modules from other units when using multiple home units + + , dep_direct_pkgs_ :: Set (IfaceImportLevel, UnitId) + -- ^ All packages directly imported by this module + -- I.e. packages to which this module's direct imports belong. + -- Does not include other home units when using multiple home units. + -- Modules from these units will go in `dep_direct_mods` + + , dep_plugin_pkgs_ :: Set UnitId + -- ^ All units needed for plugins + + ------------------------------------ + -- Transitive information below here + + , dep_sig_mods_ :: ![ModuleName] + -- ^ Transitive closure of hsig files in the home package + + + , dep_trusted_pkgs_ :: Set UnitId + -- Packages which we are required to trust + -- when the module is imported as a safe import + -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names + + , dep_boot_mods_ :: Set (UnitId, ModuleNameWithIsBoot) + -- ^ All modules which have boot files below this one, and whether we + -- should use the boot file or not. + -- This information is only used to populate the eps_is_boot field. + -- See Note [Structure of dep_boot_mods] + + , dep_orphs_ :: [Module] + -- ^ Transitive closure of orphan modules (whether + -- home or external pkg). + -- + -- (Possible optimization: don't include family + -- instance orphans as they are anyway included in + -- 'dep_finsts'. But then be careful about code + -- which relies on dep_orphs having the complete list!) + -- This does NOT include us, unlike 'imp_orphs'. + + , dep_finsts_ :: [Module] + -- ^ Transitive closure of depended upon modules which + -- contain family instances (whether home or external). + -- This is used by 'checkFamInstConsistency'. This + -- does NOT include us, unlike 'imp_finsts'. See Note + -- [The type family instance consistency story]. + + } + deriving( Eq ) + -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints + -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies. + +pattern Dependencies :: Set (IfaceImportLevel, UnitId, ModuleNameWithIsBoot) + -> Set (IfaceImportLevel, UnitId) + -> Set UnitId + -> [ModuleName] + -> Set UnitId + -> Set (UnitId, ModuleNameWithIsBoot) + -> [Module] + -> [Module] + -> Dependencies +pattern Dependencies {dep_direct_mods, dep_direct_pkgs, dep_plugin_pkgs, dep_sig_mods, dep_trusted_pkgs, dep_boot_mods, dep_orphs, dep_finsts} + <- Deps {dep_direct_mods_ = dep_direct_mods + , dep_direct_pkgs_ = dep_direct_pkgs + , dep_plugin_pkgs_ = dep_plugin_pkgs + , dep_sig_mods_ = dep_sig_mods + , dep_trusted_pkgs_ = dep_trusted_pkgs + , dep_boot_mods_ = dep_boot_mods + , dep_orphs_ = dep_orphs + , dep_finsts_ = dep_finsts} +{-# COMPLETE Dependencies #-} + +instance NFData Dependencies where + rnf (Deps dmods dpkgs ppkgs hsigms tps bmods orphs finsts) + = rnf dmods + `seq` rnf dpkgs + `seq` rnf ppkgs + `seq` rnf hsigms + `seq` rnf tps + `seq` rnf bmods + `seq` rnf orphs + `seq` rnf finsts + `seq` () + +newtype IfaceImportLevel = IfaceImportLevel ImportLevel + deriving (Eq, Ord) + deriving Binary via EnumBinary ImportLevel + +tcImportLevel :: IfaceImportLevel -> ImportLevel +tcImportLevel (IfaceImportLevel lvl) = lvl + +instance NFData IfaceImportLevel where + rnf (IfaceImportLevel lvl) = case lvl of + NormalLevel -> () + QuoteLevel -> () + SpliceLevel -> () + +instance Outputable IfaceImportLevel where + ppr (IfaceImportLevel lvl) = ppr lvl + + +-- | Extract information from the rename and typecheck phases to produce +-- a dependencies information for the module being compiled. +-- +-- The fourth argument is a list of plugin modules. +mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies +mkDependencies home_unit mod imports plugin_mods = + let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods + plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins) + all_direct_mods = foldr (\(s, mn) m -> extendInstalledModuleEnv m mn (s, (GWIB (moduleName mn) NotBoot))) + (imp_direct_dep_mods imports) + (map (fmap (fmap toUnitId) . (Set.singleton SpliceLevel,)) home_plugins) + + modDepsElts_source :: Ord a => InstalledModuleEnv a -> Set.Set (InstalledModule, a) + modDepsElts_source = Set.fromList . installedModuleEnvElts + -- It's OK to use nonDetEltsUFM here because sorting by module names + -- restores determinism + + modDepsElts :: Ord a => InstalledModuleEnv (Set.Set ImportLevel, a) -> Set.Set (IfaceImportLevel, UnitId, a) + modDepsElts e = Set.fromList [ (IfaceImportLevel s, moduleUnit im, a) | (im, (ss,a)) <- installedModuleEnvElts e, s <- Set.toList ss] + + direct_mods = modDepsElts (delInstalledModuleEnv all_direct_mods (toUnitId <$> mod)) + -- M.hi-boot can be in the imp_dep_mods, but we must remove + -- it before recording the modules on which this one depends! + -- (We want to retain M.hi-boot in imp_dep_mods so that + -- loadHiBootInterface can see if M's direct imports depend + -- on M.hi-boot, and hence that we should do the hi-boot consistency + -- check.) + + dep_orphs = filter (/= mod) (imp_orphs imports) + -- We must also remove self-references from imp_orphs. See + -- Note [Module self-dependency] + + direct_pkgs = Set.map (\(lvl, uid) -> (IfaceImportLevel lvl, uid)) (imp_dep_direct_pkgs imports) + + -- Set the packages required to be Safe according to Safe Haskell. + -- See Note [Tracking Trust Transitively] in GHC.Rename.Names + trust_pkgs = imp_trust_pkgs imports + + -- If there's a non-boot import, then it shadows the boot import + -- coming from the dependencies + source_mods = first moduleUnit `Set.map` modDepsElts_source (imp_boot_mods imports) + + sig_mods = filter (/= (moduleName mod)) $ imp_sig_mods imports + + in Deps { dep_direct_mods_ = direct_mods + , dep_direct_pkgs_ = direct_pkgs + , dep_plugin_pkgs_ = plugin_units + , dep_sig_mods_ = sort sig_mods + , dep_trusted_pkgs_ = trust_pkgs + , dep_boot_mods_ = source_mods + , dep_orphs_ = sortBy stableModuleCmp dep_orphs + , dep_finsts_ = sortBy stableModuleCmp (imp_finsts imports) + -- sort to get into canonical order + -- NB. remember to use lexicographic ordering + } + +-- | Update module dependencies containing orphans (used by Backpack) +dep_orphs_update :: Monad m => Dependencies -> ([Module] -> m [Module]) -> m Dependencies +dep_orphs_update deps f = do + r <- f (dep_orphs deps) + pure (deps { dep_orphs_ = sortBy stableModuleCmp r }) + +-- | Update module dependencies containing family instances (used by Backpack) +dep_finsts_update :: Monad m => Dependencies -> ([Module] -> m [Module]) -> m Dependencies +dep_finsts_update deps f = do + r <- f (dep_finsts deps) + pure (deps { dep_finsts_ = sortBy stableModuleCmp r }) + +instance Binary Dependencies where + put_ bh deps = do put_ bh (dep_direct_mods deps) + put_ bh (dep_direct_pkgs deps) + put_ bh (dep_plugin_pkgs deps) + put_ bh (dep_trusted_pkgs deps) + put_ bh (dep_sig_mods deps) + put_ bh (dep_boot_mods deps) + put_ bh (dep_orphs deps) + put_ bh (dep_finsts deps) + + get bh = do dms <- get bh + dps <- get bh + plugin_pkgs <- get bh + tps <- get bh + hsigms <- get bh + sms <- get bh + os <- get bh + fis <- get bh + return (Deps { dep_direct_mods_ = dms + , dep_direct_pkgs_ = dps + , dep_plugin_pkgs_ = plugin_pkgs + , dep_sig_mods_ = hsigms + , dep_boot_mods_ = sms + , dep_trusted_pkgs_ = tps + , dep_orphs_ = os, + dep_finsts_ = fis }) + +noDependencies :: Dependencies +noDependencies = Deps + { dep_direct_mods_ = Set.empty + , dep_direct_pkgs_ = Set.empty + , dep_plugin_pkgs_ = Set.empty + , dep_sig_mods_ = [] + , dep_boot_mods_ = Set.empty + , dep_trusted_pkgs_ = Set.empty + , dep_orphs_ = [] + , dep_finsts_ = [] + } + +-- | Pretty-print unit dependencies +pprDeps :: UnitState -> Dependencies -> SDoc +pprDeps unit_state (Deps { dep_direct_mods_ = dmods + , dep_boot_mods_ = bmods + , dep_plugin_pkgs_ = plgns + , dep_orphs_ = orphs + , dep_direct_pkgs_ = pkgs + , dep_trusted_pkgs_ = tps + , dep_finsts_ = finsts + }) + = pprWithUnitState unit_state $ + vcat [text "direct module dependencies:" <+> ppr_set ppr_mod dmods, + text "boot module dependencies:" <+> ppr_set ppr bmods, + text "direct package dependencies:" <+> ppr_set ppr pkgs, + text "plugin package dependencies:" <+> ppr_set ppr plgns, + if null tps + then empty + else text "trusted package dependencies:" <+> ppr_set ppr tps, + text "orphans:" <+> fsep (map ppr orphs), + text "family instance modules:" <+> fsep (map ppr finsts) + ] + where + ppr_mod (_, uid, (GWIB mod IsBoot)) = ppr uid <> colon <> ppr mod <+> text "[boot]" + ppr_mod (lvl, uid, (GWIB mod NotBoot)) = ppr lvl <+> ppr uid <> colon <> ppr mod + + ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc + ppr_set w = fsep . fmap w . Set.toAscList + +-- | Records modules for which changes may force recompilation of this module +-- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance +-- +-- This differs from Dependencies. A module X may be in the dep_mods of this +-- module (via an import chain) but if we don't use anything from X it won't +-- appear in our Usage +data Usage + -- | Module from another package + = UsagePackageModule { + usg_mod :: Module, + -- ^ External package module depended on + usg_mod_hash :: Fingerprint, + -- ^ Cached module ABI fingerprint (corresponds to mi_mod_hash) + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } + -- | Module from the current package + | UsageHomeModule { + usg_mod_name :: ModuleName, + -- ^ Name of the module + usg_unit_id :: UnitId, + -- ^ UnitId of the HomeUnit the module is from + usg_mod_hash :: Fingerprint, + -- ^ Cached module ABI fingerprint (corresponds to mi_mod_hash). + -- This may be out dated after recompilation was avoided, but is + -- still used as a fast initial check for change during + -- recompilation avoidance. + usg_entities :: [(OccName,Fingerprint)], + -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. + -- NB: usages are for parent names only, e.g. type constructors + -- but not the associated data constructors. + usg_exports :: Maybe HomeModImport, + -- ^ What we depend on from the exports of the module; + -- see 'HomeModImport'. + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } + -- | A file upon which the module depends, e.g. a CPP #include, or using TH's + -- 'addDependentFile' + | UsageFile { + usg_file_path :: FastString, + -- ^ External file dependency. From a CPP #include or TH + -- addDependentFile. Should be absolute. + usg_file_hash :: Fingerprint, + -- ^ 'Fingerprint' of the file contents. + + usg_file_label :: Maybe String + -- ^ An optional string which is used in recompilation messages if + -- file in question has changed. + + -- Note: We don't consider things like modification timestamps + -- here, because there's no reason to recompile if the actual + -- contents don't change. This previously lead to odd + -- recompilation behaviors; see #8114 + } + | UsageHomeModuleInterface { + usg_mod_name :: ModuleName + -- ^ Name of the module + , usg_unit_id :: UnitId + -- ^ UnitId of the HomeUnit the module is from + , usg_iface_hash :: Fingerprint + -- ^ The *interface* hash of the module, not the ABI hash. + -- This changes when anything about the interface (and hence the + -- module) has changed. + + -- UsageHomeModuleInterface is *only* used for recompilation + -- checking when using TemplateHaskell in the interpreter (where + -- some modules are loaded as BCOs). + + } + -- | A requirement which was merged into this one. + | UsageMergedRequirement { + usg_mod :: Module, + usg_mod_hash :: Fingerprint + } + deriving( Eq ) + -- The export list field is (Just v) if we depend on the export list: + -- i.e. we imported the module directly, whether or not we + -- enumerated the things we imported, or just imported + -- everything + -- We need to recompile if M's exports change, because + -- if the import was import M, we might now have a name clash + -- in the importing module. + -- if the import was import M(x) M might no longer export x + -- The only way we don't depend on the export list is if we have + -- import M() + -- And of course, for modules that aren't imported directly we don't + -- depend on their export lists + +instance NFData Usage where + rnf (UsagePackageModule mod hash safe) = rnf mod `seq` rnf hash `seq` rnf safe `seq` () + rnf (UsageHomeModule mod uid hash entities exports safe) = rnf mod `seq` rnf uid `seq` rnf hash `seq` rnf entities `seq` rnf exports `seq` rnf safe `seq` () + rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` () + rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` () + rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` () + +instance Binary Usage where + put_ bh usg@UsagePackageModule{} = do + putByte bh 0 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageHomeModule{} = do + putByte bh 1 + put_ bh (usg_mod_name usg) + put_ bh (usg_unit_id usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_exports usg) + put_ bh (usg_entities usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageFile{} = do + putByte bh 2 + put_ bh (usg_file_path usg) + put_ bh (usg_file_hash usg) + put_ bh (usg_file_label usg) + + put_ bh usg@UsageMergedRequirement{} = do + putByte bh 3 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + + put_ bh usg@UsageHomeModuleInterface{} = do + putByte bh 4 + put_ bh (usg_mod_name usg) + put_ bh (usg_unit_id usg) + put_ bh (usg_iface_hash usg) + + get bh = do + h <- getByte bh + case h of + 0 -> do + nm <- get bh + mod <- get bh + safe <- get bh + return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } + 1 -> do + nm <- get bh + uid <- get bh + mod <- get bh + exps <- get bh + ents <- get bh + safe <- get bh + return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, usg_unit_id = uid, + usg_exports = exps, usg_entities = ents, usg_safe = safe } + 2 -> do + fp <- get bh + hash <- get bh + label <- get bh + return UsageFile { usg_file_path = fp, usg_file_hash = hash, usg_file_label = label } + 3 -> do + mod <- get bh + hash <- get bh + return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } + 4 -> do + mod <- get bh + uid <- get bh + hash <- get bh + return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash } + i -> error ("Binary.get(Usage): " ++ show i) + +-- | Records the imports that we depend on from a home module, +-- for recompilation checking. +-- +-- See Note [When to recompile when export lists change?] in GHC.Iface.Recomp. +data HomeModImport + = HomeModImport + -- | Hash of orphans, dependencies, orphans of dependencies etc... + -- + -- See Note [Orphan-like hash]. + -- + -- If this changes, we definitely need to recompile. + { hmiu_orphanLikeHash :: Fingerprint + -- | The avails we are importing; see 'HomeModImportedAvails'. + , hmiu_importedAvails :: HomeModImportedAvails + } + deriving stock Eq + +-- | Records all the 'Avail's we are importing from a home module. +data HomeModImportedAvails + -- | All import lists are explicit import lists, but some identifiers + -- may still be implicitly imported, e.g. @import M(a, b, T(..))@. + -- + -- In this case, recompilation is keyed by the names we are importing, + -- with their 'Avail' structure. + = HMIA_Explicit + { hmia_imported_avails :: DetOrdAvails + -- ^ The avails we are importing + , hmia_parents_with_implicits :: NameSet + -- ^ The 'Name's of all 'AvailTC' imports which + -- implicitly import children + } + -- | One import is a whole module import, or a @import module M hiding(..)@ + -- import. + -- + -- In this case, recompilation is keyed on the hash of the exported avails + -- of the module we are importing. + | HMIA_Implicit + { hmia_exportedAvailsHash :: Fingerprint + -- ^ The export avails hash of the module we are importing + } + deriving stock Eq + +instance Outputable HomeModImport where + ppr (HomeModImport orphan_like imp_avails) = + braces (text "orphan_like:" <+> ppr orphan_like <+> text ", imported avails:" <+> ppr imp_avails) +instance Outputable HomeModImportedAvails where + ppr (HMIA_Explicit avails implicit_parents) = + braces (text "explicit:" <+> ppr avails <+> text ", implicit_parents:" <+> ppr implicit_parents) + ppr (HMIA_Implicit hash) = braces (text "implicit:" <+> ppr hash) +instance NFData HomeModImport where + rnf (HomeModImport a b) = rnf a `seq` rnf b `seq` () +instance NFData HomeModImportedAvails where + rnf (HMIA_Explicit avails implicit_parents) = rnf avails `seq` rnf implicit_parents + rnf (HMIA_Implicit hash) = rnf hash +instance Binary HomeModImport where + put_ bh (HomeModImport a b) = put_ bh a >> put_ bh b + get bh = do + a <- get bh + b <- get bh + return $ HomeModImport a b +instance Binary HomeModImportedAvails where + put_ bh (HMIA_Explicit avails implicit_parents) = + putByte bh 0 >> put_ bh avails >> put_ bh (nameSetElemsStable implicit_parents) + put_ bh (HMIA_Implicit hash ) = putByte bh 1 >> put_ bh hash + get bh = do + tag <- getByte bh + case tag of + 0 -> HMIA_Explicit <$> get bh <*> (mkNameSet <$> get bh) + 1 -> HMIA_Implicit <$> get bh + _ -> error ("Binary.get(HomeModImportedAvails): " ++ show tag) + +{- Note [Transitive Information in Dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is important to be careful what information we put in 'Dependencies' because +ultimately it ends up serialised in an interface file. Interface files must always +be kept up-to-date with the state of the world, so if `Dependencies` needs to be updated +then the module had to be recompiled just to update `Dependencies`. + +Before #16885, the dependencies used to contain the transitive closure of all +home modules. Therefore, if you added an import somewhere low down in the home package +it would recompile nearly every module in your project, just to update this information. + +Now, we are a bit more careful about what we store and +explicitly store transitive information only if it is really needed. + +~ Direct Information + +* dep_direct_mods - Directly imported home package modules +* dep_direct_pkgs - Directly imported packages +* dep_plgins - Directly used plugins + +~ Transitive Information + +Some features of the compiler require transitive information about what is currently +being compiled, so that is explicitly stored separately in the form they need. + +* dep_trusted_pkgs - Only used for the -fpackage-trust feature +* dep_boot_mods - Only used to populate eps_is_boot in -c mode +* dep_orphs - Modules with orphan instances +* dep_finsts - Modules with type family instances + +Important note: If you add some transitive information to the interface file then +you need to make sure recompilation is triggered when it could be out of date. +The correct way to do this is to include the transitive information in the export +hash of the module. The export hash is computed in `GHC.Iface.Recomp.addFingerprints`. +-} + +{- +Note [Structure of dep_boot_deps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In `-c` mode we always need to know whether to load the normal or boot version of +an interface file, and this can't be determined from just looking at the direct imports. + +Consider modules with dependencies: + +``` +A -(S)-> B +A -> C -> B -(S)-> B +``` + +Say when compiling module `A` that we need to load the interface for `B`, do we load +`B.hi` or `B.hi-boot`? Well, `A` does directly {-# SOURCE #-} import B, so you might think +that we would load the `B.hi-boot` file, however this is wrong because `C` imports +`B` normally. Therefore in the interface file for `C` we still need to record that +there is a hs-boot file for `B` below it but that we now want `B.hi` rather than +`B.hi-boot`. When `C` is imported, the fact that it needs `B.hi` clobbers the `{- SOURCE -}` +import for `B`. + +Therefore in mod_boot_deps we store the names of any modules which have hs-boot files, +and whether we want to import the .hi or .hi-boot version of the interface file. + +If you get this wrong, then GHC fails to compile, so there is a test but you might +not make it that far if you get this wrong! + +Question: does this happen even across packages? +No: if I need to load the interface for module X from package P I always look for p:X.hi. + +-} + +-- | 'ImportAvails' summarises what was imported from where, irrespective of +-- whether the imported things are actually used or not. It is used: +-- +-- * when processing the export list, +-- +-- * when constructing usage info for the interface file, +-- +-- * to identify the list of directly imported modules for initialisation +-- purposes and for optimised overlap checking of family instances, +-- +-- * when figuring out what things are really unused +-- +data ImportAvails + = ImportAvails { + imp_mods :: ImportedMods, + -- = ModuleEnv [ImportedModsVal], + -- ^ Domain is all directly-imported modules + -- + -- See the documentation on ImportedModsVal in + -- "GHC.Unit.Module.Imported" for the meaning of the fields. + -- + -- We need a full ModuleEnv rather than a ModuleNameEnv here, + -- because we might be importing modules of the same name from + -- different packages. (currently not the case, but might be in the + -- future). + + imp_direct_dep_mods :: InstalledModuleEnv (Set.Set ImportLevel, ModuleNameWithIsBoot), + -- ^ Home-package modules directly imported by the module being compiled. + + imp_dep_direct_pkgs :: Set (ImportLevel, UnitId), + -- ^ Packages directly needed by the module being compiled + + imp_trust_own_pkg :: Bool, + -- ^ Do we require that our own package is trusted? + -- This is to handle efficiently the case where a Safe module imports + -- a Trustworthy module that resides in the same package as it. + -- See Note [Trust Own Package] in "GHC.Rename.Names" + + -- Transitive information below here + + imp_trust_pkgs :: Set UnitId, + -- ^ This records the + -- packages the current module needs to trust for Safe Haskell + -- compilation to succeed. A package is required to be trusted if + -- we are dependent on a trustworthy module in that package. + -- See Note [Tracking Trust Transitively] in "GHC.Rename.Names" + + imp_boot_mods :: InstalledModuleEnv ModuleNameWithIsBoot, + -- ^ Domain is all modules which have hs-boot files, and whether + -- we should import the boot version of interface file. Only used + -- in one-shot mode to populate eps_is_boot. + + imp_sig_mods :: [ModuleName], + -- ^ Signature modules below this one + + imp_orphs :: [Module], + -- ^ Orphan modules below us in the import tree (and maybe including + -- us for imported modules) + + imp_finsts :: [Module] + -- ^ Family instance modules below us in the import tree (and maybe + -- including us for imported modules) + } diff --git a/GHC/Unit/Module/Env.hs b/GHC/Unit/Module/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Env.hs @@ -0,0 +1,285 @@ +-- | Module environment +module GHC.Unit.Module.Env + ( -- * Module mappings + ModuleEnv + , elemModuleEnv, extendModuleEnv, extendModuleEnvList + , extendModuleEnvList_C, plusModuleEnv_C + , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv + , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv + , alterModuleEnv + , partitionModuleEnv + , moduleEnvKeys, moduleEnvElts, moduleEnvToList + , unitModuleEnv, isEmptyModuleEnv + , extendModuleEnvWith, filterModuleEnv, mapMaybeModuleEnv + + -- * ModuleName mappings + , ModuleNameEnv, DModuleNameEnv + + -- * Sets of Modules + , ModuleSet + , emptyModuleSet, mkModuleSet, moduleSetElts + , extendModuleSet, extendModuleSetList, delModuleSet + , elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet + , unitModuleSet, isEmptyModuleSet + , unionManyModuleSets + + -- * InstalledModuleEnv + , InstalledModuleEnv + , emptyInstalledModuleEnv + , lookupInstalledModuleEnv + , extendInstalledModuleEnv + , filterInstalledModuleEnv + , delInstalledModuleEnv + , mergeInstalledModuleEnv + , plusInstalledModuleEnv + , installedModuleEnvElts + ) +where + +import GHC.Prelude + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Unit.Types +import Data.List (sortBy, sort) +import Data.Ord + +import Data.Coerce +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Semigroup as S +import qualified GHC.Data.FiniteMap as Map +import GHC.Utils.Outputable + +import Language.Haskell.Syntax.Module.Name + +-- | A map keyed off of 'Module's +newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) + +instance Outputable a => Outputable (ModuleEnv a) where + ppr (ModuleEnv m) = ppr m + +{- +Note [ModuleEnv performance and determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To prevent accidental reintroduction of nondeterminism the Ord instance +for Module was changed to not depend on Unique ordering and to use the +lexicographic order. This is potentially expensive, but when measured +there was no difference in performance. + +To be on the safe side and not pessimize ModuleEnv uses nondeterministic +ordering on Module and normalizes by doing the lexicographic sort when +turning the env to a list. +See Note [Unique Determinism] for more information about the source of +nondeterminism and Note [Deterministic UniqFM] for explanation of why +it matters for maps. +-} + +newtype NDModule = NDModule { unNDModule :: Module } + deriving Eq + -- A wrapper for Module with faster nondeterministic Ord. + -- Don't export, See [ModuleEnv performance and determinism] + -- +instance Outputable NDModule where + ppr (NDModule a) = ppr a + +instance Ord NDModule where + compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = + (getUnique p1 `nonDetCmpUnique` getUnique p2) S.<> + (getUnique n1 `nonDetCmpUnique` getUnique n2) + +filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a +filterModuleEnv f (ModuleEnv e) = + ModuleEnv (Map.filterWithKey (f . unNDModule) e) + +mapMaybeModuleEnv :: (Module -> a -> Maybe b) -> ModuleEnv a -> ModuleEnv b +mapMaybeModuleEnv f (ModuleEnv e) = + ModuleEnv (Map.mapMaybeWithKey (f . unNDModule) e) + +elemModuleEnv :: Module -> ModuleEnv a -> Bool +elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e + +extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e) + +extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a + -> ModuleEnv a +extendModuleEnvWith f (ModuleEnv e) m x = + ModuleEnv (Map.insertWith f (NDModule m) x e) + +extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a +extendModuleEnvList (ModuleEnv e) xs = + ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e) + +extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] + -> ModuleEnv a +extendModuleEnvList_C f (ModuleEnv e) xs = + ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e) + +plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = + ModuleEnv (Map.unionWith f e1 e2) + +delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a +delModuleEnvList (ModuleEnv e) ms = + ModuleEnv (Map.deleteList (map NDModule ms) e) + +delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a +delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e) + +plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) + +lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e + +lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a +lookupWithDefaultModuleEnv (ModuleEnv e) x m = + Map.findWithDefault x (NDModule m) e + +mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b +mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) + +partitionModuleEnv :: (a -> Bool) -> ModuleEnv a -> (ModuleEnv a, ModuleEnv a) +partitionModuleEnv f (ModuleEnv e) = (ModuleEnv a, ModuleEnv b) + where + (a,b) = Map.partition f e + +alterModuleEnv :: (Maybe a -> Maybe a) -> Module -> ModuleEnv a -> ModuleEnv a +alterModuleEnv f m (ModuleEnv e) = ModuleEnv (Map.alter f (NDModule m) e) + +mkModuleEnv :: [(Module, a)] -> ModuleEnv a +mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) + +emptyModuleEnv :: ModuleEnv a +emptyModuleEnv = ModuleEnv Map.empty + +moduleEnvKeys :: ModuleEnv a -> [Module] +moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e + -- See Note [ModuleEnv performance and determinism] + +moduleEnvElts :: ModuleEnv a -> [a] +moduleEnvElts e = map snd $ moduleEnvToList e + -- See Note [ModuleEnv performance and determinism] + +moduleEnvToList :: ModuleEnv a -> [(Module, a)] +moduleEnvToList (ModuleEnv e) = + sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e] + -- See Note [ModuleEnv performance and determinism] + +unitModuleEnv :: Module -> a -> ModuleEnv a +unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x) + +isEmptyModuleEnv :: ModuleEnv a -> Bool +isEmptyModuleEnv (ModuleEnv e) = Map.null e + +-- | A set of 'Module's +type ModuleSet = Set NDModule + +mkModuleSet :: [Module] -> ModuleSet +mkModuleSet = Set.fromList . coerce + +extendModuleSet :: ModuleSet -> Module -> ModuleSet +extendModuleSet s m = Set.insert (NDModule m) s + +extendModuleSetList :: ModuleSet -> [Module] -> ModuleSet +extendModuleSetList s ms = foldl' (coerce . flip Set.insert) s ms + +emptyModuleSet :: ModuleSet +emptyModuleSet = Set.empty + +isEmptyModuleSet :: ModuleSet -> Bool +isEmptyModuleSet = Set.null + +moduleSetElts :: ModuleSet -> [Module] +moduleSetElts = sort . coerce . Set.toList + +elemModuleSet :: Module -> ModuleSet -> Bool +elemModuleSet = Set.member . coerce + +intersectModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +intersectModuleSet = coerce Set.intersection + +minusModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +minusModuleSet = coerce Set.difference + +delModuleSet :: ModuleSet -> Module -> ModuleSet +delModuleSet = coerce (flip Set.delete) + +unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +unionModuleSet = coerce Set.union + +unionManyModuleSets :: [ModuleSet] -> ModuleSet +unionManyModuleSets = coerce (Set.unions :: [Set NDModule] -> Set NDModule) + +unitModuleSet :: Module -> ModuleSet +unitModuleSet = coerce Set.singleton + +{- +A ModuleName has a Unique, so we can build mappings of these using +UniqFM. +-} + +-- | A map keyed off of 'ModuleName's (actually, their 'Unique's) +type ModuleNameEnv elt = UniqFM ModuleName elt + + +-- | A map keyed off of 'ModuleName's (actually, their 'Unique's) +-- Has deterministic folds and can be deterministically converted to a list +type DModuleNameEnv elt = UniqDFM ModuleName elt + + +-------------------------------------------------------------------- +-- InstalledModuleEnv +-------------------------------------------------------------------- + +-- | A map keyed off of 'InstalledModule' +newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) + +instance Outputable elt => Outputable (InstalledModuleEnv elt) where + ppr (InstalledModuleEnv env) = ppr env + + +emptyInstalledModuleEnv :: InstalledModuleEnv a +emptyInstalledModuleEnv = InstalledModuleEnv Map.empty + +lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a +lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e + +extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a +extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e) + +filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a +filterInstalledModuleEnv f (InstalledModuleEnv e) = + InstalledModuleEnv (Map.filterWithKey f e) + +delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a +delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) + +installedModuleEnvElts :: InstalledModuleEnv a -> [(InstalledModule, a)] +installedModuleEnvElts (InstalledModuleEnv e) = Map.assocs e + +mergeInstalledModuleEnv + :: (elta -> eltb -> Maybe eltc) + -> (InstalledModuleEnv elta -> InstalledModuleEnv eltc) -- map X + -> (InstalledModuleEnv eltb -> InstalledModuleEnv eltc) -- map Y + -> InstalledModuleEnv elta + -> InstalledModuleEnv eltb + -> InstalledModuleEnv eltc +mergeInstalledModuleEnv f g h (InstalledModuleEnv xm) (InstalledModuleEnv ym) + = InstalledModuleEnv $ Map.mergeWithKey + (\_ x y -> (x `f` y)) + (coerce g) + (coerce h) + xm ym + +plusInstalledModuleEnv :: (elt -> elt -> elt) + -> InstalledModuleEnv elt + -> InstalledModuleEnv elt + -> InstalledModuleEnv elt +plusInstalledModuleEnv f (InstalledModuleEnv xm) (InstalledModuleEnv ym) = + InstalledModuleEnv $ Map.unionWith f xm ym + diff --git a/GHC/Unit/Module/Graph.hs b/GHC/Unit/Module/Graph.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Graph.hs @@ -0,0 +1,1049 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveTraversable #-} + +-- | A module graph should be constructed once and never change from there onwards. +-- +-- The only operations should be for building the 'ModuleGraph' +-- (once and for all -- no update-like/insert-like functions) +-- and querying the structure in various ways, e.g. to determine reachability. +-- +-- We should avoid exposing fields like 'mg_mss' since it may be a footgun +-- trying to use the nodes directly... We do still expose it, but it feels like +-- all its use cases would be better served by a more proper ModuleGraph +-- abstraction +module GHC.Unit.Module.Graph + ( + -- * Construct a module graph + -- + -- | A module graph should be constructed once by downsweep and never modified. + ModuleGraph(..) + , emptyMG + , mkModuleGraph + , mkModuleGraphChecked + + -- * Invariant checking + , checkModuleGraph + , ModuleGraphInvariantError(..) + + -- * Nodes in a module graph + -- + -- | The user-facing nodes in a module graph are 'ModuleGraphNode's. + -- There are a few things which we can query out of each 'ModuleGraphNode': + -- + -- - 'mgNodeDependencies' gets the immediate dependencies of this node + -- - 'mgNodeUnitId' returns the 'UnitId' of that node + -- - 'mgNodeModSum' extracts the 'ModSummary' of a node if exists + , ModuleGraphNode(..) + , mgNodeDependencies + , mgNodeIsModule + , mgNodeUnitId + + , ModuleNodeEdge(..) + , mkModuleEdge + , mkNormalEdge + + , ModuleNodeInfo(..) + , moduleNodeInfoModule + , moduleNodeInfoUnitId + , moduleNodeInfoMnwib + , moduleNodeInfoModuleName + , moduleNodeInfoModNodeKeyWithUid + , moduleNodeInfoHscSource + , moduleNodeInfoLocation + , isBootModuleNodeInfo + -- * Module graph operations + , lengthMG + , isEmptyMG + -- ** 'ModSummary' operations + -- + -- | A couple of operations on the module graph allow access to the + -- 'ModSummary's of the modules in it contained. + -- + -- In particular, 'mapMG' and 'mapMGM' allow updating these 'ModSummary's + -- (without changing the 'ModuleGraph' structure itself!). + -- 'mgModSummaries' lists out all 'ModSummary's, and + -- 'mgLookupModule' looks up a 'ModSummary' for a given module. + , mapMG, mgMapM + , mgModSummaries + , mgLookupModule + , mgLookupModuleName + , mgHasHoles + , showModMsg + + -- ** Reachability queries + -- + -- | A module graph explains the structure and relationship between the + -- modules being compiled. Often times, this structure is relevant to + -- answer reachability queries -- is X reachable from Y; or, what is the + -- transitive closure of Z? + , mgReachable + , mgReachableLoop + , mgQuery + , ZeroScopeKey(..) + , mgQueryZero + , mgQueryMany + , mgQueryManyZero + , mgMember + + -- ** Other operations + -- + -- | These operations allow more-internal-than-ideal access to the + -- ModuleGraph structure. Ideally, we could restructure the code using + -- these functions to avoid deconstructing/reconstructing the ModuleGraph + -- and instead extend the "proper interface" of the ModuleGraph to achieve + -- what is currently done but through a better abstraction. + , mgModSummaries' + , moduleGraphNodes + , moduleGraphModulesBelow -- needed for 'hptSomeThingsBelowUs', + -- but I think we could be more clever and cache + -- the graph-ixs of boot modules to efficiently + -- filter them out of the returned list. + -- hptInstancesBelow is re-doing that work every + -- time it's called. + , filterToposortToModules + , moduleGraphNodesZero + , StageSummaryNode + , stageSummaryNodeSummary + , stageSummaryNodeKey + , mkStageDeps + + -- * Keys into the 'ModuleGraph' + , NodeKey(..) + , mkNodeKey + , nodeKeyUnitId + , nodeKeyModName + , ModNodeKey + , ModNodeKeyWithUid(..) + , mnkToModule + , moduleToMnk + , mnkToInstalledModule + , installedModuleToMnk + , mnkIsBoot + , msKey + , mnKey + , miKey + + , ImportLevel(..) + + -- ** Internal node representation + -- + -- | 'SummaryNode' is the internal representation for each node stored in + -- the graph. It's not immediately clear to me why users do depend on them. + , SummaryNode + , summaryNodeSummary + , summaryNodeKey + + ) +where + +import GHC.Prelude +import GHC.Platform + +import GHC.Data.Maybe +import Data.Either +import GHC.Data.Graph.Directed +import GHC.Data.Graph.Directed.Reachability + +import GHC.Driver.Backend +import GHC.Driver.DynFlags + +import GHC.Types.SourceFile ( hscSourceString, isHsigFile, HscSource(..)) +import GHC.Types.Basic + +import GHC.Unit.Module.ModSummary +import GHC.Unit.Types +import GHC.Utils.Outputable +import GHC.Unit.Module.ModIface +import GHC.Utils.Misc ( partitionWith ) + +import System.FilePath +import qualified Data.Map as Map +import GHC.Types.Unique.DSet +import qualified Data.Set as Set +import Data.Set (Set) +import GHC.Unit.Module +import GHC.Unit.Module.ModNodeKey +import GHC.Unit.Module.Stage +import GHC.Linker.Static.Utils + +import Data.Bifunctor +import Data.Function +import Data.List (sort) +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified Data.List.NonEmpty as NE +import Control.Monad +import qualified GHC.LanguageExtensions as LangExt + +-- | A '@ModuleGraph@' contains all the nodes from the home package (only). See +-- '@ModuleGraphNode@' for information about the nodes. +-- +-- Modules need to be compiled. hs-boots need to be typechecked before +-- the associated "real" module so modules with {-# SOURCE #-} imports can be +-- built. Instantiations also need to be typechecked to ensure that the module +-- fits the signature. Substantiation typechecking is roughly comparable to the +-- check that the module and its hs-boot agree. +-- +-- The graph is not necessarily stored in topologically-sorted order. Use +-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. +data ModuleGraph = ModuleGraph + { mg_mss :: [ModuleGraphNode] + , mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) + , mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) + , mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode) + + -- `mg_graph` and `mg_loop_graph` cached transitive dependency calculations + -- so that a lot of work is not repeated whenever the transitive + -- dependencies need to be calculated (for example, hptInstances). + -- + --- - `mg_graph` is a reachability index constructed from a module + -- graph /with/ boot nodes (which make the graph acyclic), and + -- + --- * `mg_loop_graph` is a reachability index for the graph /without/ + -- hs-boot nodes, that may be cyclic. + + , mg_has_holes :: !Bool + -- Cached computation, whether any of the ModuleGraphNode are isHoleModule, + -- This is only used for a hack in GHC.Iface.Load to do with backpack, please + -- remove this at the earliest opportunity. + } + +-- | Why do we ever need to construct empty graphs? Is it because of one shot mode? +emptyMG :: ModuleGraph +emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) + (graphReachability emptyGraph, const Nothing) + (graphReachability emptyGraph, const Nothing) + False + +-- | Construct a module graph. This function should be the only entry point for +-- building a 'ModuleGraph', since it is supposed to be built once and never modified. +-- +-- If you ever find the need to build a 'ModuleGraph' iteratively, don't +-- add insert and update functions to the API since they become footguns. +-- Instead, design an API that allows iterative construction without posterior +-- modification, perhaps like what is done for building arrays from mutable +-- arrays. +mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph +mkModuleGraph = foldr (flip extendMG) emptyMG + +-- | A version of mkModuleGraph that checks the module graph for invariants. +mkModuleGraphChecked :: [ModuleGraphNode] -> Either [ModuleGraphInvariantError] ModuleGraph +mkModuleGraphChecked nodes = + let mg = mkModuleGraph nodes + in case checkModuleGraph mg of + [] -> Right mg + errors -> Left errors + +-------------------------------------------------------------------------------- +-- * Module Graph Nodes +-------------------------------------------------------------------------------- + +-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'. +-- Edges between nodes mark dependencies arising from module imports +-- and dependencies arising from backpack instantiations. +data ModuleGraphNode + -- | Instantiation nodes track the instantiation of other units + -- (backpack dependencies) with the holes (signatures) of the current package. + = InstantiationNode UnitId InstantiatedUnit + -- | There is a module node for each module being built. + -- A node is either fixed or can be compiled. + -- - Fixed modules are not compiled, the artifacts are just loaded from disk. + -- It is up to your to make sure the artifacts are up to date and available. + -- - Compile modules are compiled from source if needed. + | ModuleNode [ModuleNodeEdge] ModuleNodeInfo + -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit. + | LinkNode [NodeKey] UnitId + -- | Package dependency + | UnitNode [UnitId] UnitId + + +data ModuleNodeEdge = ModuleNodeEdge { edgeLevel :: ImportLevel + , edgeTargetKey :: NodeKey } + +mkModuleEdge :: ImportLevel -> NodeKey -> ModuleNodeEdge +mkModuleEdge level key = ModuleNodeEdge level key + +-- | A 'normal' edge in the graph which isn't offset by an import stage. +mkNormalEdge :: NodeKey -> ModuleNodeEdge +mkNormalEdge = mkModuleEdge NormalLevel + +instance Outputable ModuleNodeEdge where + ppr (ModuleNodeEdge level key) = + let level_str = case level of + NormalLevel -> "" + SpliceLevel -> "(S)" + QuoteLevel -> "(Q)" + in text level_str <> ppr key + +data ModuleGraphInvariantError = + FixedNodeDependsOnCompileNode ModNodeKeyWithUid [NodeKey] + | DuplicateModuleNodeKey NodeKey + | DependencyNotInGraph NodeKey [NodeKey] + deriving (Eq, Ord) + +instance Outputable ModuleGraphInvariantError where + ppr = \case + FixedNodeDependsOnCompileNode key bad_deps -> + text "Fixed node" <+> ppr key <+> text "depends on compile nodes" <+> ppr bad_deps + DuplicateModuleNodeKey k -> + text "Duplicate module node key" <+> ppr k + DependencyNotInGraph from to -> + text "Dependency not in graph" <+> ppr from <+> text "->" <+> ppr to + +-- Used for invariant checking. Is a NodeKey fixed or compilable? +data ModuleNodeType = MN_Fixed | MN_Compile + +instance Outputable ModuleNodeType where + ppr = \case + MN_Fixed -> text "Fixed" + MN_Compile -> text "Compile" + +moduleNodeType :: ModuleGraphNode -> ModuleNodeType +moduleNodeType (ModuleNode _ (ModuleNodeCompile _)) = MN_Compile +moduleNodeType (ModuleNode _ (ModuleNodeFixed _ _)) = MN_Fixed +moduleNodeType (UnitNode {}) = MN_Fixed +moduleNodeType _ = MN_Compile + +checkModuleGraph :: ModuleGraph -> [ModuleGraphInvariantError] +checkModuleGraph ModuleGraph{..} = + mapMaybe (checkFixedModuleInvariant node_types) mg_mss + ++ mapMaybe (checkAllDependenciesInGraph node_types) mg_mss + ++ duplicate_errs + where + duplicate_errs = rights (Map.elems node_types) + + node_types :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + node_types = Map.fromListWithKey go [ (mkNodeKey n, Left (moduleNodeType n)) | n <- mg_mss ] + where + -- Multiple nodes with the same key are not allowed. + go :: NodeKey -> Either ModuleNodeType ModuleGraphInvariantError + -> Either ModuleNodeType ModuleGraphInvariantError + -> Either ModuleNodeType ModuleGraphInvariantError + go k _ _ = Right (DuplicateModuleNodeKey k) + +-- | Check that all dependencies in the graph are present in the node_types map. +-- This is a helper function used by checkModuleGraph. +checkAllDependenciesInGraph :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + -> ModuleGraphNode + -> Maybe ModuleGraphInvariantError +checkAllDependenciesInGraph node_types node = + let nodeKey = mkNodeKey node + deps = mgNodeDependencies False node + missingDeps = filter (\dep -> not (Map.member dep node_types)) deps + in if null missingDeps + then Nothing + else Just (DependencyNotInGraph nodeKey missingDeps) + + +-- | Check if for the fixed module node invariant: +-- +-- Fixed nodes can only depend on other fixed nodes. +checkFixedModuleInvariant :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + -> ModuleGraphNode + -> Maybe ModuleGraphInvariantError +checkFixedModuleInvariant node_types node = case node of + ModuleNode deps (ModuleNodeFixed key _) -> + let check_node dep = case Map.lookup dep node_types of + -- Dependency is not fixed + Just (Left MN_Compile) -> Just dep + _ -> Nothing + bad_deps = mapMaybe check_node (map edgeTargetKey deps) + in if null bad_deps + then Nothing + else Just (FixedNodeDependsOnCompileNode key bad_deps) + + _ -> Nothing + + +{- Note [Module Types in the ModuleGraph] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Modules can be one of two different types in the module graph. + +1. ModuleNodeCompile, modules with source files we can compile. +2. ModuleNodeFixed, modules which we presume are already compiled and available. + +The ModuleGraph can contain a combination of these two types of nodes but must +obey the invariant that Fixed nodes only depend on other Fixed nodes. This invariant +can be checked by the `checkModuleGraph` function, but it's +the responsibility of the code constructing the ModuleGraph to ensure it is upheld. + +At the moment, when using --make mode, GHC itself will only use `ModuleNodeCompile` nodes. + +In oneshot mode, we don't have access to the source files of dependencies but sometimes need to know +information about the module graph still (for example, getLinkDeps). + +In theory, the whole compiler will work if an API program uses ModuleNodeFixed nodes, and +there is a simple test in FixedNodes, which can be extended in future to cover +any missing cases. + +-} +data ModuleNodeInfo = ModuleNodeFixed ModNodeKeyWithUid ModLocation + | ModuleNodeCompile ModSummary + +-- | Extract the Module from a ModuleNodeInfo +moduleNodeInfoModule :: ModuleNodeInfo -> Module +moduleNodeInfoModule (ModuleNodeFixed key _) = mnkToModule key +moduleNodeInfoModule (ModuleNodeCompile ms) = ms_mod ms + +-- | Extract the ModNodeKeyWithUid from a ModuleNodeInfo +moduleNodeInfoModNodeKeyWithUid :: ModuleNodeInfo -> ModNodeKeyWithUid +moduleNodeInfoModNodeKeyWithUid (ModuleNodeFixed key _) = key +moduleNodeInfoModNodeKeyWithUid (ModuleNodeCompile ms) = msKey ms + +-- | Extract the HscSource from a ModuleNodeInfo, if we can determine it. +moduleNodeInfoHscSource :: ModuleNodeInfo -> Maybe HscSource +moduleNodeInfoHscSource (ModuleNodeFixed _ _) = Nothing +moduleNodeInfoHscSource (ModuleNodeCompile ms) = Just (ms_hsc_src ms) + +-- | Extract the ModLocation from a ModuleNodeInfo +moduleNodeInfoLocation :: ModuleNodeInfo -> ModLocation +moduleNodeInfoLocation (ModuleNodeFixed _ loc) = loc +moduleNodeInfoLocation (ModuleNodeCompile ms) = ms_location ms + +-- | Extract the IsBootInterface from a ModuleNodeInfo +isBootModuleNodeInfo :: ModuleNodeInfo -> IsBootInterface +isBootModuleNodeInfo (ModuleNodeFixed mnwib _) = mnkIsBoot mnwib +isBootModuleNodeInfo (ModuleNodeCompile ms) = isBootSummary ms + +-- | Extract the ModuleName from a ModuleNodeInfo +moduleNodeInfoModuleName :: ModuleNodeInfo -> ModuleName +moduleNodeInfoModuleName m = moduleName (moduleNodeInfoModule m) + +moduleNodeInfoUnitId :: ModuleNodeInfo -> UnitId +moduleNodeInfoUnitId (ModuleNodeFixed key _) = mnkUnitId key +moduleNodeInfoUnitId (ModuleNodeCompile ms) = ms_unitid ms + +moduleNodeInfoMnwib :: ModuleNodeInfo -> ModuleNameWithIsBoot +moduleNodeInfoMnwib (ModuleNodeFixed key _) = mnkModuleName key +moduleNodeInfoMnwib (ModuleNodeCompile ms) = ms_mnwib ms + +-- | 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. +mgNodeDependencies :: Bool -> ModuleGraphNode -> [NodeKey] +mgNodeDependencies drop_hs_boot_nodes = \case + LinkNode deps _uid -> deps + InstantiationNode uid iuid -> + [ NodeKey_Module (ModNodeKeyWithUid (GWIB mod NotBoot) uid) | mod <- uniqDSetToList (instUnitHoles iuid) ] + ++ [ NodeKey_ExternalUnit (instUnitInstanceOf iuid) ] + ModuleNode deps _ms -> + map (drop_hs_boot . edgeTargetKey) deps + UnitNode deps _ -> map NodeKey_ExternalUnit deps + where + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature + | otherwise = IsBoot + + drop_hs_boot (NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (NodeKey_Module (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid)) + drop_hs_boot x = x + +mgNodeIsModule :: ModuleGraphNode -> Maybe ModuleNodeInfo +mgNodeIsModule (InstantiationNode {}) = Nothing +mgNodeIsModule (LinkNode {}) = Nothing +mgNodeIsModule (ModuleNode _ ms) = Just ms +mgNodeIsModule (UnitNode {}) = Nothing + +mgNodeUnitId :: ModuleGraphNode -> UnitId +mgNodeUnitId mgn = + case mgn of + InstantiationNode uid _iud -> uid + ModuleNode _ ms -> toUnitId (moduleUnit (moduleNodeInfoModule ms)) + LinkNode _ uid -> uid + UnitNode _ uid -> uid + +instance Outputable ModuleGraphNode where + ppr = \case + InstantiationNode _ iuid -> ppr iuid + ModuleNode nks ms -> ppr (mnKey ms) <+> ppr nks + LinkNode uid _ -> text "LN:" <+> ppr uid + UnitNode _ uid -> text "P:" <+> ppr uid + +instance Eq ModuleGraphNode where + (==) = (==) `on` mkNodeKey + +instance Ord ModuleGraphNode where + compare = compare `on` mkNodeKey + +-------------------------------------------------------------------------------- +-- * Module Graph operations +-------------------------------------------------------------------------------- +-- | Returns the number of nodes in a 'ModuleGraph' +lengthMG :: ModuleGraph -> Int +lengthMG = length . mg_mss + +isEmptyMG :: ModuleGraph -> Bool +isEmptyMG = null . mg_mss + +-------------------------------------------------------------------------------- +-- ** ModSummaries +-------------------------------------------------------------------------------- + +-- | Map a function 'f' over all the 'ModSummaries'. +-- To preserve invariants, 'f' can't change the isBoot status. +mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph +mapMG f mg@ModuleGraph{..} = mg + { mg_mss = flip fmap mg_mss $ \case + InstantiationNode uid iuid -> InstantiationNode uid iuid + LinkNode uid nks -> LinkNode uid nks + ModuleNode deps (ModuleNodeFixed key loc) -> ModuleNode deps (ModuleNodeFixed key loc) + ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms)) + UnitNode deps uid -> UnitNode deps uid + } + +-- | Map a function 'f' over all the 'ModSummaries', in 'IO'. +-- To preserve invariants, 'f' can't change the isBoot status. +mgMapM :: (ModuleNodeInfo -> IO ModuleNodeInfo) -> ModuleGraph -> IO ModuleGraph +mgMapM f mg@ModuleGraph{..} = do + mss' <- forM mg_mss $ \case + InstantiationNode uid iuid -> pure $ InstantiationNode uid iuid + LinkNode uid nks -> pure $ LinkNode uid nks + ModuleNode deps ms -> ModuleNode deps <$> (f ms) + UnitNode deps uid -> pure $ UnitNode deps uid + return $ mg { mg_mss = mss' } + + +mgModSummaries :: ModuleGraph -> [ModSummary] +mgModSummaries mg = [ m | ModuleNode _ (ModuleNodeCompile m) <- mgModSummaries' mg ] + +-- | Look up a non-boot ModSummary in the ModuleGraph. +-- +-- Careful: Linear in the size of the module graph +-- MP: This should probably be level aware +mgLookupModule :: ModuleGraph -> Module -> Maybe ModuleNodeInfo +mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss + where + go (ModuleNode _ ms) + | NotBoot <- isBootModuleNodeInfo ms + , moduleNodeInfoModule ms == m + = Just ms + go _ = Nothing + +-- | Lookup up a 'ModuleNameWithIsBoot' in the 'ModuleGraph'. +-- +-- Multiple nodes in the 'ModuleGraph' can have the same 'ModuleName' +-- and 'IsBootInterface'. +-- +-- Careful: Linear in the size of the module graph. +mgLookupModuleName :: ModuleGraph -> ModuleNameWithIsBoot -> [ModuleNodeInfo] +mgLookupModuleName ModuleGraph{..} m = mapMaybe go mg_mss + where + go (ModuleNode _ ms) + | moduleNodeInfoMnwib ms == m + = Just ms + go _ = Nothing + +mgMember :: ModuleGraph -> NodeKey -> Bool +mgMember graph k = isJust $ snd (mg_graph graph) k + +-- | A function you should not need to use, or desire to use. Only used +-- in one place, `GHC.Iface.Load` to facilitate a misimplementation in Backpack. +mgHasHoles :: ModuleGraph -> Bool +mgHasHoles ModuleGraph{..} = mg_has_holes + +-------------------------------------------------------------------------------- +-- ** Reachability +-------------------------------------------------------------------------------- + +-- | Return all nodes reachable from the given 'NodeKey'. +-- +-- @Nothing@ if the key couldn't be found in the graph. +mgReachable :: ModuleGraph -> NodeKey -> Maybe [ModuleGraphNode] +mgReachable mg nk = map summaryNodeSummary <$> modules_below where + (td_map, lookup_node) = mg_graph mg + modules_below = + allReachable td_map <$> lookup_node nk + +-- | Things which are reachable if hs-boot files are ignored. Used by 'getLinkDeps' +mgReachableLoop :: ModuleGraph -> [NodeKey] -> [ModuleGraphNode] +mgReachableLoop mg nk = map summaryNodeSummary modules_below where + (td_map, lookup_node) = mg_loop_graph mg + modules_below = + allReachableMany td_map (mapMaybe lookup_node nk) + + +-- | @'mgQueryZero' g root b@ answers the question: can we reach @b@ from @root@ +-- in the module graph @g@, only using normal (level 0) imports? +mgQueryZero :: ModuleGraph + -> ZeroScopeKey + -> ZeroScopeKey + -> Bool +mgQueryZero mg nka nkb = isReachable td_map na nb where + (td_map, lookup_node) = mg_zero_graph mg + na = expectJust $ lookup_node nka + nb = expectJust $ lookup_node nkb + + +-- | Reachability Query. +-- +-- @mgQuery(g, a, b)@ asks: +-- Can we reach @b@ from @a@ in graph @g@? +-- +-- Both @a@ and @b@ must be in @g@. +mgQuery :: ModuleGraph -- ^ @g@ + -> NodeKey -- ^ @a@ + -> NodeKey -- ^ @b@ + -> Bool -- ^ @b@ is reachable from @a@ +mgQuery mg nka nkb = isReachable td_map na nb where + (td_map, lookup_node) = mg_graph mg + na = expectJust $ lookup_node nka + nb = expectJust $ lookup_node nkb + +-- | Many roots reachability Query. +-- +-- @mgQuery(g, roots, b)@ asks: +-- Can we reach @b@ from any of the @roots@ in graph @g@? +-- +-- Node @b@ must be in @g@. +mgQueryMany :: ModuleGraph -- ^ @g@ + -> [NodeKey] -- ^ @roots@ + -> NodeKey -- ^ @b@ + -> Bool -- ^ @b@ is reachable from @roots@ +mgQueryMany mg roots nkb = isReachableMany td_map nroots nb where + (td_map, lookup_node) = mg_graph mg + nroots = mapMaybe lookup_node roots + nb = expectJust $ lookup_node nkb + +-- | Many roots reachability Query. +-- +-- @mgQuery(g, roots, b)@ asks: +-- Can we reach @b@ from any of the @roots@ in graph @g@, only using normal (level 0) imports? +-- +-- Node @b@ must be in @g@. +mgQueryManyZero :: ModuleGraph -- ^ @g@ + -> [ZeroScopeKey] -- ^ @roots@ + -> ZeroScopeKey -- ^ @b@ + -> Bool -- ^ @b@ is reachable from @roots@ +mgQueryManyZero mg roots nkb = isReachableMany td_map nroots nb where + (td_map, lookup_node) = mg_zero_graph mg + nroots = mapMaybe lookup_node roots + nb = expectJust $ lookup_node (pprTrace "mg" (ppr nkb) nkb) + +-------------------------------------------------------------------------------- +-- ** Other operations (read haddocks on export list) +-------------------------------------------------------------------------------- + +mgModSummaries' :: ModuleGraph -> [ModuleGraphNode] +mgModSummaries' = mg_mss + +-- | Turn a list of graph nodes into an efficient queriable graph. +-- The first boolean parameter indicates whether nodes corresponding to hs-boot files +-- should be collapsed into their relevant hs nodes. +moduleGraphNodes :: Bool + -> [ModuleGraphNode] + -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = + (graphFromEdgedVerticesUniq nodes, lookup_node) + where + -- Map from module to extra boot summary dependencies which need to be merged in + (boot_summaries, nodes) = bimap Map.fromList id $ partitionWith go numbered_summaries + + where + go (s, key) = + case s of + ModuleNode __deps ms | isBootModuleNodeInfo ms == IsBoot, drop_hs_boot_nodes + -- Using nodeDependencies here converts dependencies on other + -- boot files to dependencies on dependencies on non-boot files. + -> Left (moduleNodeInfoModule ms, mgNodeDependencies drop_hs_boot_nodes s) + _ -> normal_case + where + normal_case = + let lkup_key = moduleNodeInfoModule <$> mgNodeIsModule s + extra = (lkup_key >>= \key -> Map.lookup key boot_summaries) + + in Right $ DigraphNode s key $ out_edge_keys $ + (fromMaybe [] extra + ++ mgNodeDependencies drop_hs_boot_nodes s) + + numbered_summaries = zip summaries [1..] + + lookup_node :: NodeKey -> Maybe SummaryNode + lookup_node key = Map.lookup key (unNodeMap node_map) + + lookup_key :: NodeKey -> Maybe Int + lookup_key = fmap summaryNodeKey . lookup_node + + node_map :: NodeMap SummaryNode + node_map = NodeMap $ + Map.fromList [ (mkNodeKey s, node) + | node <- nodes + , let s = summaryNodeSummary node + ] + + out_edge_keys :: [NodeKey] -> [Int] + out_edge_keys = mapMaybe lookup_key + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- IsBoot; else False + + +-- | This function returns all the modules belonging to the home-unit that can +-- be reached by following the given dependencies. Additionally, if both the +-- boot module and the non-boot module can be reached, it only returns the +-- non-boot one. +moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid +moduleGraphModulesBelow mg uid mn = filtered_mods [ mn | NodeKey_Module mn <- modules_below] + where + modules_below = maybe [] (map mkNodeKey) (mgReachable mg (NodeKey_Module (ModNodeKeyWithUid mn uid))) + filtered_mods = Set.fromDistinctAscList . filter_mods . sort + + -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list + -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a + -- linear sweep with a window of size 2 to remove boot modules for which we + -- have the corresponding non-boot. + filter_mods = \case + (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs) + | m1 == m2 && uid1 == uid2 -> + let !r' = case b1 of + NotBoot -> r1 + IsBoot -> r2 + in r' : filter_mods rs + | otherwise -> r1 : filter_mods (r2:rs) + rs -> rs + +-- | This function filters out all the instantiation nodes from each SCC of a +-- topological sort. Use this with care, as the resulting "strongly connected components" +-- may not really be strongly connected in a direct way, as instantiations have been +-- removed. It would probably be best to eliminate uses of this function where possible. +filterToposortToModules + :: [SCC ModuleGraphNode] -> [SCC ModuleNodeInfo] +filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case + ModuleNode _deps node -> Just node + _ -> Nothing + where + -- This higher order function is somewhat bogus, + -- as the definition of "strongly connected component" + -- is not necessarily respected. + mapMaybeSCC :: (a -> Maybe b) -> SCC a -> Maybe (SCC b) + mapMaybeSCC f = \case + AcyclicSCC a -> AcyclicSCC <$> f a + CyclicSCC as -> case mapMaybe f as of + [] -> Nothing + [a] -> Just $ AcyclicSCC a + as -> Just $ CyclicSCC as + +-------------------------------------------------------------------------------- +-- * Keys into ModuleGraph +-------------------------------------------------------------------------------- + +data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit + | NodeKey_Module {-# UNPACK #-} !ModNodeKeyWithUid + | NodeKey_Link !UnitId + | NodeKey_ExternalUnit !UnitId + deriving (Eq, Ord) + +instance Outputable NodeKey where + ppr (NodeKey_Unit iu) = ppr iu + ppr (NodeKey_Module mk) = ppr mk + ppr (NodeKey_Link uid) = ppr uid + ppr (NodeKey_ExternalUnit uid) = ppr uid + +mkNodeKey :: ModuleGraphNode -> NodeKey +mkNodeKey = \case + InstantiationNode _ iu -> NodeKey_Unit iu + ModuleNode _ x -> NodeKey_Module $ mnKey x + LinkNode _ uid -> NodeKey_Link uid + UnitNode _ uid -> NodeKey_ExternalUnit uid + +nodeKeyUnitId :: NodeKey -> UnitId +nodeKeyUnitId (NodeKey_Unit iu) = instUnitInstanceOf iu +nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk +nodeKeyUnitId (NodeKey_Link uid) = uid +nodeKeyUnitId (NodeKey_ExternalUnit uid) = uid + +nodeKeyModName :: NodeKey -> Maybe ModuleName +nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk) +nodeKeyModName _ = Nothing + +msKey :: ModSummary -> ModNodeKeyWithUid +msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms) + +mnKey :: ModuleNodeInfo -> ModNodeKeyWithUid +mnKey (ModuleNodeFixed key _) = key +mnKey (ModuleNodeCompile ms) = msKey ms + +miKey :: ModIface -> ModNodeKeyWithUid +miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi))) + +type ModNodeKey = ModuleNameWithIsBoot + +-------------------------------------------------------------------------------- +-- ** Internal node representation (exposed) +-------------------------------------------------------------------------------- + +type SummaryNode = Node Int ModuleGraphNode + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey = node_key + +summaryNodeSummary :: SummaryNode -> ModuleGraphNode +summaryNodeSummary = node_payload + +-------------------------------------------------------------------------------- +-- * Misc utilities +-------------------------------------------------------------------------------- + +showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc +showModMsg dflags _ (LinkNode {}) = + let staticLink = case ghcLink dflags of + LinkStaticLib -> True + _ -> False + + platform = targetPlatform dflags + arch_os = platformArchOS platform + exe_file = exeFileName arch_os staticLink (outputFile_ dflags) + in text exe_file +showModMsg _ _ (UnitNode _deps uid) = ppr uid +showModMsg _ _ (InstantiationNode _uid indef_unit) = + ppr $ instUnitInstanceOf indef_unit +showModMsg dflags recomp (ModuleNode _ mni) = + if gopt Opt_HideSourcePaths dflags + then text mod_str + else hsep $ + [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') + , char '(' + , text (moduleNodeInfoSource mni) <> char ',' + , moduleNodeInfoExtraMessage dflags recomp mni, char ')' ] + where + mod_str = moduleNameString (moduleName (moduleNodeInfoModule mni)) ++ + moduleNodeInfoBootString mni + +-- | Extra information about a 'ModuleNodeInfo' to display in the progress message. +moduleNodeInfoExtraMessage :: DynFlags -> Bool -> ModuleNodeInfo -> SDoc +moduleNodeInfoExtraMessage dflags recomp (ModuleNodeCompile mod_summary) = + let dyn_file = normalise $ msDynObjFilePath mod_summary + obj_file = normalise $ msObjFilePath mod_summary + files = obj_file + :| [ dyn_file | gopt Opt_BuildDynamicToo dflags ] + ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ] + in case backendSpecialModuleSource (backend dflags) recomp of + Just special -> text special + Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (NE.map text files) +moduleNodeInfoExtraMessage _ _ (ModuleNodeFixed {}) = text "fixed" + + +-- | The source location of the module node to show to the user. +moduleNodeInfoSource :: ModuleNodeInfo -> FilePath +moduleNodeInfoSource (ModuleNodeCompile ms) = normalise $ msHsFilePath ms +moduleNodeInfoSource (ModuleNodeFixed _ loc) = normalise $ ml_hi_file loc + +-- | The extra info about a module [boot] or [sig] to display. +moduleNodeInfoBootString :: ModuleNodeInfo -> String +moduleNodeInfoBootString (ModuleNodeCompile ms) = hscSourceString (ms_hsc_src ms) +moduleNodeInfoBootString mn@(ModuleNodeFixed {}) = + hscSourceString (case isBootModuleNodeInfo mn of + IsBoot -> HsBootFile + NotBoot -> HsSrcFile) + +-------------------------------------------------------------------------------- +-- * Internal methods for module graph +-- +-- These are *really* meant to be internal! +-- Don't expose them without careful consideration about the invariants +-- described in the export list haddocks. +-------------------------------------------------------------------------------- + +newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a } + deriving (Functor, Traversable, Foldable) + +-- | Transitive dependencies, including SOURCE edges +mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) +mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False + +-- | Transitive dependencies, ignoring SOURCE edges +mkTransLoopDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) +mkTransLoopDeps = first cyclicGraphReachability . moduleGraphNodes True + +-- | Transitive dependencies, but only following "normal" level 0 imports. +-- This graph can be used to query what the transitive dependencies of a particular +-- level are within a module. +mkTransZeroDeps :: [ModuleGraphNode] -> (ReachabilityIndex ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode) +mkTransZeroDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodesZero + +-- | Transitive dependencies, but with the stage that each module is required at. +mkStageDeps :: [ModuleGraphNode] -> (ReachabilityIndex StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode) +mkStageDeps = first cyclicGraphReachability . moduleGraphNodesStages + +type ZeroSummaryNode = Node Int ZeroScopeKey + +zeroSummaryNodeKey :: ZeroSummaryNode -> Int +zeroSummaryNodeKey = node_key + +zeroSummaryNodeSummary :: ZeroSummaryNode -> ZeroScopeKey +zeroSummaryNodeSummary = node_payload + +-- | The 'ZeroScopeKey' indicates the different scopes which we can refer to in a zero-scope query. +data ZeroScopeKey = ModuleScope ModNodeKeyWithUid ImportLevel | UnitScope UnitId + deriving (Eq, Ord) + +instance Outputable ZeroScopeKey where + ppr (ModuleScope mk il) = text "ModuleScope" <+> ppr mk <+> ppr il + ppr (UnitScope uid) = text "UnitScope" <+> ppr uid + +-- | Turn a list of graph nodes into an efficient queriable graph. +-- This graph only has edges between level-0 imports +-- +-- This query answers the question. If I am looking at level n in module M then which +-- modules are visible? +-- +-- If you are looking at level -1 then the reachable modules are those imported at splice and +-- then any modules those modules import at zero. (Ie the zero scope for those modules) +moduleGraphNodesZero :: + [ModuleGraphNode] + -> (Graph ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode) +moduleGraphNodesZero summaries = + (graphFromEdgedVerticesUniq nodes, lookup_node) + where + nodes = mapMaybe go numbered_summaries + + where + go :: (((ModuleGraphNode, ImportLevel)), Int) -> Maybe ZeroSummaryNode + go (((ModuleNode nks ms), s), key) = Just $ + DigraphNode (ModuleScope (mnKey ms) s) key $ out_edge_keys $ + mapMaybe (classifyDeps s) nks + go (((UnitNode uids uid), _s), key) = + Just $ DigraphNode (UnitScope uid) key (mapMaybe lookup_key $ map UnitScope uids) + go _ = Nothing + + -- This is the key part, a dependency edge also depends on the NormalLevel scope of an import. + classifyDeps s (ModuleNodeEdge il (NodeKey_Module k)) | s == il = Just (ModuleScope k NormalLevel) + classifyDeps s (ModuleNodeEdge il (NodeKey_ExternalUnit u)) | s == il = Just (UnitScope u) + classifyDeps _ _ = Nothing + + numbered_summaries :: [((ModuleGraphNode, ImportLevel), Int)] + numbered_summaries = zip (([(s, l) | s <- summaries, l <- [SpliceLevel, QuoteLevel, NormalLevel]])) [0..] + + lookup_node :: ZeroScopeKey -> Maybe ZeroSummaryNode + lookup_node key = Map.lookup key node_map + + lookup_key :: ZeroScopeKey -> Maybe Int + lookup_key = fmap zeroSummaryNodeKey . lookup_node + + node_map :: Map.Map ZeroScopeKey ZeroSummaryNode + node_map = + Map.fromList [ (s, node) + | node <- nodes + , let s = zeroSummaryNodeSummary node + ] + + out_edge_keys :: [ZeroScopeKey] -> [Int] + out_edge_keys = mapMaybe lookup_key + +type StageSummaryNode = Node Int (NodeKey, ModuleStage) + +stageSummaryNodeKey :: StageSummaryNode -> Int +stageSummaryNodeKey = node_key + +stageSummaryNodeSummary :: StageSummaryNode -> (NodeKey, ModuleStage) +stageSummaryNodeSummary = node_payload + +-- | Turn a list of graph nodes into an efficient queriable graph. +-- This graph has edges between modules and the stage they are required at. +-- +-- This graph can be used to answer the query, if I am compiling a module at stage +-- S, then what modules do I need at which stages for that? +-- Used by 'downsweep' in order to determine which modules need code generation if you +-- are using 'TemplateHaskell'. +-- +-- The rules for this query can be read in more detail in the Explicit Level Imports proposal. +-- Briefly: +-- * If NoImplicitStagePersistence then Quote/Splice/Normal imports offset the required stage +-- * If ImplicitStagePersistence and TemplateHaskell then imported module are needed at all stages. +-- * Otherwise, an imported module is just needed at the normal stage. +-- +-- * A module using TemplateHaskellQuotes required at C stage is also required at R +-- stage. +moduleGraphNodesStages :: + [ModuleGraphNode] + -> (Graph StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode) +moduleGraphNodesStages summaries = + (graphFromEdgedVerticesUniq nodes, lookup_node) + where + nodes = map go numbered_summaries + + where + go :: (((ModuleGraphNode, ModuleStage)), Int) -> StageSummaryNode + go (s, key) = normal_case s + where + normal_case :: (ModuleGraphNode, ModuleStage) -> StageSummaryNode + normal_case ((m@(ModuleNode nks ms), s)) = + DigraphNode ((mkNodeKey m, s)) key $ out_edge_keys $ + selfEdges ms s (mkNodeKey m) ++ concatMap (classifyDeps ms s) nks + normal_case (m, s) = + DigraphNode (mkNodeKey m, s) key (out_edge_keys . map (, s) $ mgNodeDependencies False m) + + isExplicitStageMS :: ModSummary -> Bool + isExplicitStageMS ms = not (xopt LangExt.ImplicitStagePersistence (ms_hspp_opts ms)) + + isTemplateHaskellQuotesMS :: ModSummary -> Bool + isTemplateHaskellQuotesMS ms = xopt LangExt.TemplateHaskellQuotes (ms_hspp_opts ms) + + -- Accounting for persistence within a module. + -- If a module is required @ C and it persists an idenfifier, it's also required + -- at R. + selfEdges (ModuleNodeCompile ms) s self_key + | not (isExplicitStageMS ms) + && (isTemplateHaskellQuotesMS ms + || isTemplateHaskellOrQQNonBoot ms) + = [(self_key, s') | s' <- onlyFutureStages s] + selfEdges _ _ _ = [] + + -- Case 1. No implicit stage persistnce is enabled + classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge il k) + | isExplicitStageMS ms = case il of + SpliceLevel -> [(k, decModuleStage s)] + NormalLevel -> [(k, s)] + QuoteLevel -> [(k, incModuleStage s)] + -- Case 2a. TemplateHaskellQuotes case (section 5.6 in the paper) + classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge _ k) + | not (isExplicitStageMS ms) + , not (isTemplateHaskellOrQQNonBoot ms) + , isTemplateHaskellQuotesMS ms + = [(k, s') | s' <- nowAndFutureStages s] + -- Case 2b. Template haskell is enabled, with implicit stage persistence + classifyDeps (ModuleNodeCompile ms) _ (ModuleNodeEdge _ k) + | isTemplateHaskellOrQQNonBoot ms + , not (isExplicitStageMS ms) = + [(k, s) | s <- allStages] + -- Case 3. No template haskell, therefore no additional dependencies. + classifyDeps _ s (ModuleNodeEdge _ k) = [(k, s)] + + + numbered_summaries :: [((ModuleGraphNode, ModuleStage), Int)] + numbered_summaries = zip (([(s, l) | s <- summaries, l <- allStages])) [0..] + + lookup_node :: (NodeKey, ModuleStage) -> Maybe StageSummaryNode + lookup_node key = Map.lookup key node_map + + lookup_key :: (NodeKey, ModuleStage) -> Maybe Int + lookup_key = fmap stageSummaryNodeKey . lookup_node + + node_map :: Map.Map (NodeKey, ModuleStage) StageSummaryNode + node_map = + Map.fromList [ (s, node) + | node <- nodes + , let s = stageSummaryNodeSummary node + ] + + out_edge_keys :: [(NodeKey, ModuleStage)] -> [Int] + out_edge_keys = mapMaybe lookup_key + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- IsBoot; else False + + +-- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is +-- not an element of the ModuleGraph. +extendMG :: ModuleGraph -> ModuleGraphNode -> ModuleGraph +extendMG ModuleGraph{..} node = + ModuleGraph + { mg_mss = node : mg_mss + , mg_graph = mkTransDeps (node : mg_mss) + , mg_loop_graph = mkTransLoopDeps (node : mg_mss) + , mg_zero_graph = mkTransZeroDeps (node : mg_mss) + , mg_has_holes = mg_has_holes || maybe False isHsigFile (moduleNodeInfoHscSource =<< mgNodeIsModule node) + } + diff --git a/GHC/Unit/Module/Imported.hs b/GHC/Unit/Module/Imported.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Imported.hs @@ -0,0 +1,60 @@ +module GHC.Unit.Module.Imported + ( ImportedMods + , ImportedBy (..) + , ImportedModsVal (..) + , importedByUser + ) +where + +import GHC.Prelude + +import GHC.Unit.Module + +import GHC.Types.Name.Reader +import GHC.Types.SafeHaskell +import GHC.Types.SrcLoc +import Data.Map (Map) + +-- | Records the modules directly imported by a module for extracting e.g. +-- usage information, and also to give better error message +type ImportedMods = Map Module [ImportedBy] + -- We don't want to use a `ModuleEnv` since it would leak a non-deterministic + -- order to the interface files when passed as a list to `mkUsageInfo`. + +-- | If a module was "imported" by the user, we associate it with +-- more detailed usage information 'ImportedModsVal'; a module +-- imported by the system only gets used for usage information. +data ImportedBy + = ImportedByUser ImportedModsVal + | ImportedBySystem + +importedByUser :: [ImportedBy] -> [ImportedModsVal] +importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys +importedByUser (ImportedBySystem : bys) = importedByUser bys +importedByUser [] = [] + +data ImportedModsVal = ImportedModsVal + { imv_name :: ModuleName + -- ^ The name the module is imported with + + , imv_span :: SrcSpan + -- ^ the source span of the whole import + + , imv_is_safe :: IsSafeImport + -- ^ whether this is a safe import + + , imv_is_level :: ImportLevel + -- ^ the level the module is imported at (splice, quote, or normal) + + , imv_is_hiding :: Bool + -- ^ whether this is an "hiding" import + + , imv_all_exports :: !GlobalRdrEnv + -- ^ all the things the module could provide. + -- + -- NB. BangPattern here: otherwise this leaks. (#15111) + + , imv_qualified :: Bool + -- ^ whether this is a qualified import + } + diff --git a/GHC/Unit/Module/Location.hs b/GHC/Unit/Module/Location.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Location.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +-- | Module location +module GHC.Unit.Module.Location + ( ModLocation + ( .. + , ml_hs_file + , ml_hi_file + , ml_dyn_hi_file + , ml_obj_file + , ml_dyn_obj_file + , ml_hie_file + ) + , pattern ModLocation + , addBootSuffix + , addBootSuffixLocn + , addBootSuffixLocnOut + , removeBootSuffix + , mkFileSrcSpan + ) +where + +import GHC.Prelude + +import GHC.Data.OsPath +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Data.FastString (mkFastString) + +import qualified System.OsString as OsString + +-- | Module Location +-- +-- Where a module lives on the file system: the actual locations +-- of the .hs, .hi, .dyn_hi, .o, .dyn_o and .hie files, if we have them. +-- +-- For a module in another unit, the ml_hs_file_ospath and ml_obj_file_ospath components of +-- ModLocation are undefined. +-- +-- The locations specified by a ModLocation may or may not +-- correspond to actual files yet: for example, even if the object +-- file doesn't exist, the ModLocation still contains the path to +-- where the object file will reside if/when it is created. +-- +-- The paths of anything which can affect recompilation should be placed inside +-- ModLocation. +-- +-- When a ModLocation is created none of the filepaths will have -boot suffixes. +-- This is because in --make mode the ModLocation is put in the finder cache which +-- is indexed by ModuleName, when a ModLocation is retrieved from the FinderCache +-- the boot suffixes are appended. +-- The other case is in -c mode, there the ModLocation immediately gets given the +-- boot suffixes in mkOneShotModLocation. + +data ModLocation + = OsPathModLocation { + ml_hs_file_ospath :: Maybe OsPath, + -- ^ The source file, if we have one. Package modules + -- probably don't have source files. + + ml_hi_file_ospath :: OsPath, + -- ^ Where the .hi file is, whether or not it exists + -- yet. Always of form foo.hi, even if there is an + -- hi-boot file (we add the -boot suffix later) + + ml_dyn_hi_file_ospath :: OsPath, + -- ^ Where the .dyn_hi file is, whether or not it exists + -- yet. + + ml_obj_file_ospath :: OsPath, + -- ^ Where the .o file is, whether or not it exists yet. + -- (might not exist either because the module hasn't + -- been compiled yet, or because it is part of a + -- unit with a .a file) + + ml_dyn_obj_file_ospath :: OsPath, + -- ^ Where the .dy file is, whether or not it exists + -- yet. + + ml_hie_file_ospath :: OsPath + -- ^ Where the .hie file is, whether or not it exists + -- yet. + } deriving Show + +instance Outputable ModLocation where + ppr = text . show + +-- | Add the @-boot@ suffix to .hs, .hi and .o files +addBootSuffix :: OsPath -> OsPath +addBootSuffix path = path `mappend` os "-boot" + +-- | Remove the @-boot@ suffix to .hs, .hi and .o files +removeBootSuffix :: OsPath -> OsPath +removeBootSuffix pathWithBootSuffix = + case OsString.stripSuffix (os "-boot") pathWithBootSuffix of + Just path -> path + Nothing -> error "removeBootSuffix: no -boot suffix" + +-- | Add the @-boot@ suffix to all file paths associated with the module +addBootSuffixLocn :: ModLocation -> ModLocation +addBootSuffixLocn locn + = addBootSuffixLocnOut locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn) } + +-- | Add the @-boot@ suffix to all output file paths associated with the +-- module, not including the input file itself +addBootSuffixLocnOut :: ModLocation -> ModLocation +addBootSuffixLocnOut locn + = locn { ml_hi_file_ospath = addBootSuffix (ml_hi_file_ospath locn) + , ml_dyn_hi_file_ospath = addBootSuffix (ml_dyn_hi_file_ospath locn) + , ml_obj_file_ospath = addBootSuffix (ml_obj_file_ospath locn) + , ml_dyn_obj_file_ospath = addBootSuffix (ml_dyn_obj_file_ospath locn) + , ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn) + } + +-- | Compute a 'SrcSpan' from a 'ModLocation'. +mkFileSrcSpan :: ModLocation -> SrcSpan +mkFileSrcSpan mod_loc + = case ml_hs_file mod_loc of + Just file_path -> mkGeneralSrcSpan (mkFastString file_path) + Nothing -> interactiveSrcSpan -- Presumably + +-- ---------------------------------------------------------------------------- +-- Helpers for backwards compatibility +-- ---------------------------------------------------------------------------- + +{-# COMPLETE ModLocation #-} + +pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation +pattern ModLocation + { ml_hs_file + , ml_hi_file + , ml_dyn_hi_file + , ml_obj_file + , ml_dyn_obj_file + , ml_hie_file + } <- OsPathModLocation + { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file) + , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file) + , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file) + , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file) + , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file) + , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file) + } where + ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file + = OsPathModLocation + { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file + , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file + , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file + , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file + , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file + , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file + } diff --git a/GHC/Unit/Module/ModDetails.hs b/GHC/Unit/Module/ModDetails.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/ModDetails.hs @@ -0,0 +1,56 @@ +module GHC.Unit.Module.ModDetails + ( ModDetails (..) + , emptyModDetails + ) +where + +import GHC.Core ( CoreRule ) +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv ( InstEnv, emptyInstEnv ) + +import GHC.Types.Avail +import GHC.Types.CompleteMatch +import GHC.Types.DefaultEnv +import GHC.Types.TypeEnv +import GHC.Types.Annotations ( Annotation ) + +-- | The 'ModDetails' is essentially a cache for information in the 'ModIface' +-- for home modules only. Information relating to packages will be loaded into +-- global environments in 'ExternalPackageState'. +data ModDetails = ModDetails + { -- The next two fields are created by the typechecker + md_exports :: [AvailInfo] + , md_types :: !TypeEnv + -- ^ Local type environment for this particular module + -- Includes Ids, TyCons, PatSyns + + , md_defaults :: !DefaultEnv + -- ^ default declarations exported by this module + + , md_insts :: InstEnv + -- ^ 'DFunId's for the instances in this module + + , md_fam_insts :: ![FamInst] + , md_rules :: ![CoreRule] + -- ^ Domain may include 'Id's from other modules + + , md_anns :: ![Annotation] + -- ^ Annotations present in this module: currently + -- they only annotate things also declared in this module + + , md_complete_matches :: CompleteMatches + -- ^ Complete match pragmas for this module + } + +-- | Constructs an empty ModDetails +emptyModDetails :: ModDetails +emptyModDetails = ModDetails + { md_types = emptyTypeEnv + , md_exports = [] + , md_defaults = emptyDefaultEnv + , md_insts = emptyInstEnv + , md_rules = [] + , md_fam_insts = [] + , md_anns = [] + , md_complete_matches = [] + } diff --git a/GHC/Unit/Module/ModGuts.hs b/GHC/Unit/Module/ModGuts.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/ModGuts.hs @@ -0,0 +1,148 @@ +module GHC.Unit.Module.ModGuts + ( ModGuts (..) + , mg_mnwib + , CgGuts (..) + ) +where + +import GHC.Prelude + +import GHC.HsToCore.Breakpoints +import GHC.ForeignSrcLang + +import GHC.Hs + +import GHC.Unit +import GHC.Unit.Module.Deps +import GHC.Unit.Module.Warnings + +import GHC.Core.InstEnv ( InstEnv, ClsInst ) +import GHC.Core.FamInstEnv +import GHC.Core ( CoreProgram, CoreRule ) +import GHC.Core.TyCon +import GHC.Core.PatSyn + +import GHC.Linker.Types ( SptEntry(..) ) + +import GHC.Types.Annotations ( Annotation ) +import GHC.Types.Avail +import GHC.Types.CompleteMatch +import GHC.Types.DefaultEnv ( DefaultEnv ) +import GHC.Types.Fixity.Env +import GHC.Types.ForeignStubs +import GHC.Types.HpcInfo +import GHC.Types.Name.Reader +import GHC.Types.Name.Set (NameSet) +import GHC.Types.SafeHaskell +import GHC.Types.SourceFile ( HscSource(..), hscSourceToIsBoot ) +import GHC.Types.SrcLoc +import GHC.Types.CostCentre + +import Data.Set (Set) + + +-- | A ModGuts is carried through the compiler, accumulating stuff as it goes +-- There is only one ModGuts at any time, the one for the module +-- being compiled right now. Once it is compiled, a 'ModIface' and +-- 'ModDetails' are extracted and the ModGuts is discarded. +data ModGuts + = ModGuts { + mg_module :: !Module, -- ^ Module being compiled + mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module + mg_loc :: SrcSpan, -- ^ For error messages from inner passes + mg_exports :: ![AvailInfo], -- ^ What it exports + mg_deps :: !Dependencies, -- ^ What it depends on, directly or + -- otherwise + mg_usages :: !(Maybe [Usage]), -- ^ What was used? Used for interfaces. + + mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment + + -- These fields all describe the things **declared in this module** + mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module. + -- Used for creating interface files. + mg_tcs :: ![TyCon], -- ^ TyCons declared in this module + -- (includes TyCons for classes) + mg_defaults :: !DefaultEnv , -- ^ Class defaults exported from this module + mg_insts :: ![ClsInst], -- ^ Class instances declared in this module + mg_fam_insts :: ![FamInst], + -- ^ Family instances declared in this module + mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module + mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains + -- See Note [Overall plumbing for rules] in "GHC.Core.Rules" + mg_binds :: !CoreProgram, -- ^ Bindings for this module + mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module + mg_foreign_files :: ![(ForeignSrcLang, FilePath)], + -- ^ Files to be compiled with the C compiler + mg_warns :: !(Warnings GhcRn), -- ^ Warnings declared in the module + mg_anns :: [Annotation], -- ^ Annotations declared in this module + mg_complete_matches :: CompleteMatches, -- ^ Complete Matches + mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module + mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module + + -- The next two fields are unusual, because they give instance + -- environments for *all* modules in the home package, including + -- this module, rather than for *just* this module. + -- Reason: when looking up an instance we don't want to have to + -- look at each module in the home package in turn + mg_inst_env :: InstEnv, -- ^ Class instance environment for + -- /home-package/ modules (including this + -- one); c.f. 'tcg_inst_env' + mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance environment for + -- /home-package/ modules (including this + -- one); c.f. 'tcg_fam_inst_env' + mg_boot_exports :: !NameSet, -- Things that are also export via hs-boot file + + mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode + mg_trust_pkg :: Bool, -- ^ Do we need to trust our + -- own package for Safe Haskell? + -- See Note [Trust Own Package] + -- in "GHC.Rename.Names" + + mg_docs :: !(Maybe Docs) -- ^ Documentation. + } + +mg_mnwib :: ModGuts -> ModuleNameWithIsBoot +mg_mnwib mg = GWIB (moduleName (mg_module mg)) (hscSourceToIsBoot (mg_hsc_src mg)) + +-- The ModGuts takes on several slightly different forms: +-- +-- After simplification, the following fields change slightly: +-- mg_rules Orphan rules only (local ones now attached to binds) +-- mg_binds With rules attached + +--------------------------------------------------------- +-- The Tidy pass forks the information about this module: +-- * one lot goes to interface file generation (ModIface) +-- and later compilations (ModDetails) +-- * the other lot goes to code generation (CgGuts) + +-- | A restricted form of 'ModGuts' for code generation purposes +data CgGuts + = CgGuts { + cg_module :: !Module, + -- ^ Module being compiled + + cg_tycons :: [TyCon], + -- ^ Algebraic data types (including ones that started + -- life as classes); generate constructors and info + -- tables. Includes newtypes, just for the benefit of + -- External Core + + cg_binds :: CoreProgram, + -- ^ The tidied main bindings, including + -- previously-implicit bindings for record and class + -- selectors, and data constructor wrappers. But *not* + -- data constructor workers; reason: we regard them + -- as part of the code-gen of tycons + + cg_ccs :: [CostCentre], -- List of cost centres used in bindings and rules + cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs + cg_foreign_files :: ![(ForeignSrcLang, FilePath)], + cg_dep_pkgs :: !(Set UnitId), -- ^ Dependent packages, used to + -- generate #includes for C code gen + cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints + cg_spt_entries :: [SptEntry] + -- ^ Static pointer table entries for static forms defined in + -- the module. + -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable" + } diff --git a/GHC/Unit/Module/ModIface.hs b/GHC/Unit/Module/ModIface.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/ModIface.hs @@ -0,0 +1,1276 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} + +module GHC.Unit.Module.ModIface + ( ModIface + , ModIface_ + ( mi_mod_info + , mi_module + , mi_sig_of + , mi_hsc_src + , mi_iface_hash + , mi_deps + , mi_public + , mi_exports + , mi_fixities + , mi_warns + , mi_anns + , mi_decls + , mi_defaults + , mi_simplified_core + , mi_top_env + , mi_insts + , mi_fam_insts + , mi_rules + , mi_trust + , mi_trust_pkg + , mi_complete_matches + , mi_docs + , mi_abi_hashes + , mi_ext_fields + , mi_hi_bytes + , mi_self_recomp_info + , mi_fix_fn + , mi_decl_warn_fn + , mi_export_warn_fn + , mi_hash_fn + ) + , pattern ModIface + , set_mi_mod_info + , set_mi_module + , set_mi_sig_of + , set_mi_hsc_src + , set_mi_self_recomp + , set_mi_hi_bytes + , set_mi_deps + , set_mi_exports + , set_mi_fixities + , set_mi_warns + , set_mi_anns + , set_mi_insts + , set_mi_fam_insts + , set_mi_rules + , set_mi_decls + , set_mi_defaults + , set_mi_simplified_core + , set_mi_top_env + , set_mi_trust + , set_mi_trust_pkg + , set_mi_complete_matches + , set_mi_docs + , set_mi_abi_hashes + , set_mi_ext_fields + , set_mi_caches + , set_mi_decl_warn_fn + , set_mi_export_warn_fn + , set_mi_fix_fn + , set_mi_hash_fn + , completePartialModIface + , IfaceBinHandle(..) + , PartialModIface + , IfaceAbiHashes (..) + , IfaceSelfRecomp (..) + , IfaceCache (..) + , IfaceSimplifiedCore (..) + , withSelfRecomp + , IfaceDeclExts + , IfaceAbiHashesExts + , IfaceExport + , IfacePublic_(..) + , IfacePublic + , PartialIfacePublic + , IfaceModInfo(..) + , WhetherHasOrphans + , WhetherHasFamInst + , IfaceTopEnv (..) + , IfaceImport(..) + , mi_boot + , mi_fix + , mi_semantic_module + , mi_mod_info_semantic_module + , mi_free_holes + , mi_mnwib + , mi_flag_hash + , mi_opt_hash + , mi_hpc_hash + , mi_plugin_hash + , mi_src_hash + , mi_usages + , mi_mod_hash + , mi_orphan + , mi_finsts + , mi_export_avails_hash + , mi_orphan_like_hash + , mi_orphan_hash + , renameFreeHoles + , emptyPartialModIface + , emptyFullModIface + , mkIfaceHashCache + , emptyIfaceHashCache + , forceModIface + ) +where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Iface.Syntax +import GHC.Iface.Flags +import GHC.Iface.Ext.Fields +import GHC.Iface.Recomp.Types + +import GHC.Unit +import GHC.Unit.Module.Deps +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.WholeCoreBindings (IfaceForeign (..)) + + +import GHC.Types.Avail +import GHC.Types.Fixity +import GHC.Types.Fixity.Env +import GHC.Types.Name +import GHC.Types.SafeHaskell +import GHC.Types.SourceFile +import GHC.Types.Unique.DSet +import GHC.Types.Unique.FM + +import GHC.Data.Maybe +import qualified GHC.Data.Strict as Strict + +import GHC.Utils.Fingerprint +import GHC.Utils.Binary + +import Control.DeepSeq +import Control.Exception + + +{- Note [Interface file stages] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Interface files have two possible stages. + +* A partial stage built from the result of the core pipeline. +* A fully instantiated form. Which also includes fingerprints and + potentially information provided by backends. + +We can build a full interface file two ways: +* Directly from a partial one: + Then we omit backend information and mostly compute fingerprints. +* From a partial one + information produced by a backend. + Then we store the provided information and fingerprint both. +-} + +type PartialModIface = ModIface_ 'ModIfaceCore +type ModIface = ModIface_ 'ModIfaceFinal + +type PartialIfacePublic = IfacePublic_ 'ModIfaceCore +type IfacePublic = IfacePublic_ 'ModIfaceFinal + +-- | Extends a PartialModIface with hashes of the ABI. +-- +-- * The mi_mod_hash is the hash of the entire ABI +-- * THe other fields are more specific hashes of parts of the ABI +data IfaceAbiHashes = IfaceAbiHashes + { mi_abi_mod_hash :: !Fingerprint + -- ^ Hash of the ABI only + , mi_abi_orphan :: !WhetherHasOrphans + -- ^ Whether this module has orphans + , mi_abi_finsts :: !WhetherHasFamInst + -- ^ Whether this module has family instances. See Note [The type family + -- instance consistency story]. + , mi_abi_export_avails_hash :: !Fingerprint + -- ^ Hash of the exported avails (does not include e.g. instances) + , mi_abi_orphan_like_hash :: !Fingerprint + -- ^ Orphans, together with (non-orphan) type family instances of + -- dependencies and a few other things; see Note [Orphan-like hash]. + -- + -- If this changes, we must recompile due to the impact + -- on instance resolution. + , mi_abi_orphan_hash :: !Fingerprint + -- ^ Hash for orphan rules, class and family instances combined + -- NOT transitive + } + +data IfaceCache = IfaceCache + { mi_cache_decl_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn)) + -- ^ Cached lookup for 'mi_warns' for declaration deprecations + , mi_cache_export_warn_fn :: !(Name -> Maybe (WarningTxt GhcRn)) + -- ^ Cached lookup for 'mi_warns' for export deprecations + , mi_cache_fix_fn :: !(OccName -> Maybe Fixity) + -- ^ Cached lookup for 'mi_fixities' + , mi_cache_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint)) + -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that + -- the thing isn't in decls. It's useful to know that when seeing if we are + -- up to date wrt. the old interface. The 'OccName' is the parent of the + -- name, if it has one. + } + +data ModIfacePhase + = ModIfaceCore + -- ^ Partial interface built based on output of core pipeline. + | ModIfaceFinal + +-- | Selects a IfaceDecl representation. +-- For fully instantiated interfaces we also maintain +-- a fingerprint, which is used for recompilation checks. +type family IfaceDeclExts (phase :: ModIfacePhase) = decl | decl -> phase where + IfaceDeclExts 'ModIfaceCore = IfaceDecl + IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) + +type family IfaceAbiHashesExts (phase :: ModIfacePhase) = bk | bk -> phase where + IfaceAbiHashesExts 'ModIfaceCore = () + IfaceAbiHashesExts 'ModIfaceFinal = IfaceAbiHashes + +-- | In-memory byte array representation of a 'ModIface'. +-- +-- See Note [Sharing of ModIface] for why we need this. +data IfaceBinHandle (phase :: ModIfacePhase) where + -- | A partial 'ModIface' cannot be serialised to disk. + PartialIfaceBinHandle :: IfaceBinHandle 'ModIfaceCore + -- | Optional 'FullBinData' that can be serialised to disk directly. + -- + -- See Note [Private fields in ModIface] for when this fields needs to be cleared + -- (e.g., set to 'Nothing'). + FullIfaceBinHandle :: !(Strict.Maybe FullBinData) -> IfaceBinHandle 'ModIfaceFinal + + +withSelfRecomp :: ModIface_ phase -> r -> (IfaceSelfRecomp -> r) -> r +withSelfRecomp iface nk jk = + case mi_self_recomp_info iface of + Nothing -> nk + Just x -> jk x + + + +-- | A 'ModIface' summarises everything we know +-- about a compiled module. +-- +-- See Note [Structure of ModIface] for information about what belongs in each field. +-- +-- See Note [Strictness in ModIface] to learn about why all the fields are lazy. +-- +-- See Note [Private fields in ModIface] to learn why we don't export any of the +-- fields. +data ModIface_ (phase :: ModIfacePhase) + = PrivateModIface { + mi_hi_bytes_ :: !(IfaceBinHandle phase), + -- ^ A serialised in-memory buffer of this 'ModIface'. + -- If this handle is given, we can avoid serialising the 'ModIface' + -- when writing this 'ModIface' to disk, and write this buffer to disk instead. + -- See Note [Sharing of ModIface]. + mi_iface_hash_ :: Fingerprint, -- A hash of the whole interface + + mi_mod_info_ :: IfaceModInfo, + -- ^ Meta information about the module the interface file is for + + mi_deps_ :: Dependencies, + -- ^ The dependencies of the module. This is + -- consulted for directly-imported modules, but not + -- for anything else (hence lazy) + -- MP: Needs to be refactored (#25844) + + mi_public_ :: IfacePublic_ phase, + -- ^ The parts of interface which are used by other modules when + -- importing this module. The main, original part of an interface. + + + mi_self_recomp_ :: Maybe IfaceSelfRecomp, + -- ^ Information needed for checking self-recompilation. + -- See Note [Self recompilation information in interface files] + + mi_simplified_core_ :: Maybe IfaceSimplifiedCore, + -- ^ The part of the interface written when `-fwrite-if-simplified-core` is enabled. + -- These parts are used to restart bytecode generation. + + mi_docs_ :: Maybe Docs, + -- ^ Docstrings and related data for use by haddock, the ghci + -- @:doc@ command, and other tools. + -- + -- @Just _@ @<=>@ the module was built with @-haddock@. + + mi_top_env_ :: IfaceTopEnv, + -- ^ Just enough information to reconstruct the top level environment in + -- the /original source/ code for this module. which + -- is NOT the same as mi_exports, nor mi_decls (which + -- may contains declarations for things not actually + -- defined by the user). Used for GHCi and for inspecting + -- the contents of modules via the GHC API only. + + mi_ext_fields_ :: ExtensibleFields + -- ^ Additional optional fields, where the Map key represents + -- the field name, resulting in a (size, serialized data) pair. + -- Because the data is intended to be serialized through the + -- internal `Binary` class (increasing compatibility with types + -- using `Name` and `FastString`, such as HIE), this format is + -- chosen over `ByteString`s. + } + +-- | Meta information about the module the interface file is for +data IfaceModInfo = IfaceModInfo { + mi_mod_info_module :: Module, -- ^ Name of the module we are for + mi_mod_info_sig_of :: Maybe Module, -- ^ Are we a sig of another mod? + mi_mod_info_hsc_src :: HscSource -- ^ Boot? Signature? +} + +-- | The public interface of a module which are used by other modules when importing this module. +-- The ABI of a module. +data IfacePublic_ phase = IfacePublic { + mi_exports_ :: [IfaceExport], + -- ^ Exports + -- Kept sorted by (mod,occ), to make version comparisons easier + -- Records the modules that are the declaration points for things + -- exported by this module, and the 'OccName's of those things + + mi_fixities_ :: [(OccName,Fixity)], + -- ^ Fixities + -- NOT STRICT! we read this field lazily from the interface file + + mi_warns_ :: IfaceWarnings, + -- ^ Warnings + -- NOT STRICT! we read this field lazily from the interface file + + mi_anns_ :: [IfaceAnnotation], + -- ^ Annotations + -- NOT STRICT! we read this field lazily from the interface file + + + mi_decls_ :: [IfaceDeclExts phase], + -- ^ Type, class and variable declarations + -- The hash of an Id changes if its fixity or deprecations change + -- (as well as its type of course) + -- Ditto data constructors, class operations, except that + -- the hash of the parent class/tycon changes + + + mi_defaults_ :: [IfaceDefault], + -- ^ default declarations exported by the module + + + -- Instance declarations and rules + mi_insts_ :: [IfaceClsInst], -- ^ Sorted class instance + mi_fam_insts_ :: [IfaceFamInst], -- ^ Sorted family instances + mi_rules_ :: [IfaceRule], -- ^ Sorted rules + + + mi_trust_ :: IfaceTrustInfo, + -- ^ Safe Haskell Trust information for this module. + + mi_trust_pkg_ :: Bool, + -- ^ Do we require the package this module resides in be trusted + -- to trust this module? This is used for the situation where a + -- module is Safe (so doesn't require the package be trusted + -- itself) but imports some trustworthy modules from its own + -- package (which does require its own package be trusted). + -- See Note [Trust Own Package] in GHC.Rename.Names + mi_complete_matches_ :: [IfaceCompleteMatch], + -- ^ {-# COMPLETE #-} declarations + + mi_caches_ :: IfaceCache, + -- ^ Cached lookups of some parts of mi_public + + mi_abi_hashes_ :: (IfaceAbiHashesExts phase) + -- ^ Either `()` or `IfaceAbiHashes` for + -- a fully instantiated interface. + -- These fields are hashes of different parts of the public interface. +} + +mkIfacePublic :: [IfaceExport] + -> [IfaceDeclExts 'ModIfaceFinal] + -> [(OccName, Fixity)] + -> IfaceWarnings + -> [IfaceAnnotation] + -> [IfaceDefault] + -> [IfaceClsInst] + -> [IfaceFamInst] + -> [IfaceRule] + -> IfaceTrustInfo + -> Bool + -> [IfaceCompleteMatch] + -> IfaceAbiHashes + -> IfacePublic +mkIfacePublic exports decls fixities warns anns defaults insts fam_insts rules trust trust_pkg complete_matches abi_hashes = IfacePublic { + mi_exports_ = exports, + mi_decls_ = decls, + mi_fixities_ = fixities, + mi_warns_ = warns, + mi_anns_ = anns, + mi_defaults_ = defaults, + mi_insts_ = insts, + mi_fam_insts_ = fam_insts, + mi_rules_ = rules, + mi_trust_ = trust, + mi_trust_pkg_ = trust_pkg, + mi_complete_matches_ = complete_matches, + mi_caches_ = IfaceCache { + mi_cache_decl_warn_fn = mkIfaceDeclWarnCache $ fromIfaceWarnings warns, + mi_cache_export_warn_fn = mkIfaceExportWarnCache $ fromIfaceWarnings warns, + mi_cache_fix_fn = mkIfaceFixCache fixities, + mi_cache_hash_fn = mkIfaceHashCache decls + }, + mi_abi_hashes_ = abi_hashes +} + +-- | The information needed to restart bytecode generation. +-- Enabled by `-fwrite-if-simplified-core`. +data IfaceSimplifiedCore = IfaceSimplifiedCore { + mi_sc_extra_decls :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] + -- ^ Extra variable definitions which are **NOT** exposed but when + -- combined with mi_decls allows us to restart code generation. + -- See Note [Interface Files with Core Definitions] and Note [Interface File with Core: Sharing RHSs] + , mi_sc_foreign :: IfaceForeign + -- ^ Foreign stubs and files to supplement 'mi_extra_decls_'. + -- See Note [Foreign stubs and TH bytecode linking] +} + +-- Enough information to reconstruct the top level environment for a module +data IfaceTopEnv + = IfaceTopEnv + { ifaceTopExports :: DetOrdAvails -- ^ all top level things in this module, including unexported stuff + , ifaceImports :: [IfaceImport] -- ^ all the imports in this module + } + +instance NFData IfaceTopEnv where + rnf (IfaceTopEnv a b) = rnf a `seq` rnf b + +instance Binary IfaceTopEnv where + put_ bh (IfaceTopEnv exports imports) = do + put_ bh exports + put_ bh imports + get bh = do + exports <- get bh + imports <- get bh + return (IfaceTopEnv exports imports) + + +{- +Note [Structure of ModIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ModIface structure is divided into several logical parts: + +1. mi_mod_info: Basic module metadata (name, version, etc.) + +2. mi_public: The public interface of the module, which includes: + - Exports, declarations, fixities, warnings, annotations + - Class and type family instances + - Rewrite rules and COMPLETE pragmas + - Safe Haskell and package trust information + - ABI hashes for recompilation checking + +4. mi_self_recomp: Information needed for self-recompilation checking + (see Note [Self recompilation information in interface files]) + +5. mi_simplified_core: Optional simplified Core for bytecode generation + (only present when -fwrite-if-simplified-core is enabled) + +6. mi_docs: Optional documentation (only present when -haddock is enabled) + +7. mi_top_env: Information about the top-level environment of the original source + +8. mi_ext_fields: Additional fields for extensibility + +This structure helps organize the interface data according to its purpose and usage +patterns. Different parts of the compiler use different fields. By separating them +logically in the interface we can arrange to only deserialize the fields that are needed. + +Note [Strictness in ModIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The ModIface is the Haskell representation of an interface (.hi) file. + +* During compilation we write out ModIface values to disk for files + that we have just compiled +* For packages that we depend on we load the ModIface from disk. + +All fields in the ModIface are deliberately lazy because when we read +an interface file we don't always need all the parts. For example, an +interface file contains information about documentation which is often +not needed during compilation. This is achieved using the lazyPut/lazyGet pair. +If the field was strict then we would pointlessly load this information into memory. + +On the other hand, if we create a ModIface but **don't** write it to +disk then to avoid space leaks we need to make sure to deepseq all these lazy fields +because the ModIface might live for a long time (for instance in a GHCi session). +That's why in GHC.Driver.Main.hscMaybeWriteIface there is the call to +forceModIface. +-} + +mi_flag_hash :: ModIface_ phase -> Maybe (FingerprintWithValue IfaceDynFlags) +mi_flag_hash = fmap mi_sr_flag_hash . mi_self_recomp_ + +mi_opt_hash :: ModIface_ phase -> Maybe Fingerprint +mi_opt_hash = fmap mi_sr_opt_hash . mi_self_recomp_ + +mi_hpc_hash :: ModIface_ phase -> Maybe Fingerprint +mi_hpc_hash = fmap mi_sr_hpc_hash . mi_self_recomp_ + +mi_src_hash :: ModIface_ phase -> Maybe Fingerprint +mi_src_hash = fmap mi_sr_src_hash . mi_self_recomp_ + +mi_usages :: ModIface_ phase -> Maybe [Usage] +mi_usages = fmap mi_sr_usages . mi_self_recomp_ + +mi_plugin_hash :: ModIface_ phase -> Maybe Fingerprint +mi_plugin_hash = fmap mi_sr_plugin_hash . mi_self_recomp_ + +-- | Accessor for the module hash of the ABI from a ModIface. +mi_mod_hash :: ModIface -> Fingerprint +mi_mod_hash iface = mi_abi_mod_hash (mi_abi_hashes iface) + +-- | Accessor for whether this module has orphans from a ModIface. +mi_orphan :: ModIface -> WhetherHasOrphans +mi_orphan iface = mi_abi_orphan (mi_abi_hashes iface) + +-- | Accessor for whether this module has family instances from a ModIface. +mi_finsts :: ModIface -> WhetherHasFamInst +mi_finsts iface = mi_abi_finsts (mi_abi_hashes iface) + +-- | Accessor for the hash of exported avails. +mi_export_avails_hash :: ModIface -> Fingerprint +mi_export_avails_hash iface = mi_abi_export_avails_hash (mi_abi_hashes iface) + +-- | Accessor for the hash of orphans and dependencies. +-- +-- See Note [Orphan-like hash]. +mi_orphan_like_hash :: ModIface -> Fingerprint +mi_orphan_like_hash iface = mi_abi_orphan_like_hash (mi_abi_hashes iface) + +-- | Accessor for the hash of orphan rules, class and family instances combined from a ModIface. +mi_orphan_hash :: ModIface -> Fingerprint +mi_orphan_hash iface = mi_abi_orphan_hash (mi_abi_hashes iface) + +-- | Old-style accessor for whether or not the ModIface came from an hs-boot +-- file. +mi_boot :: ModIface -> IsBootInterface +mi_boot iface = if mi_hsc_src iface == HsBootFile + then IsBoot + else NotBoot + +mi_mnwib :: ModIface -> ModuleNameWithIsBoot +mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface) + +-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be +-- found, 'defaultFixity' is returned instead. +mi_fix :: ModIface -> OccName -> Fixity +mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity + +-- | The semantic module for this interface; e.g., if it's a interface +-- for a signature, if 'mi_module' is @p[A=]:A@, 'mi_semantic_module' +-- will be @@. +mi_mod_info_semantic_module :: IfaceModInfo -> Module +mi_mod_info_semantic_module iface = case mi_mod_info_sig_of iface of + Nothing -> mi_mod_info_module iface + Just mod -> mod + +mi_semantic_module :: ModIface_ a -> Module +mi_semantic_module iface = mi_mod_info_semantic_module (mi_mod_info iface) + +-- | The "precise" free holes, e.g., the signatures that this +-- 'ModIface' depends on. +mi_free_holes :: ModIface -> UniqDSet ModuleName +mi_free_holes iface = + case getModuleInstantiation (mi_module iface) of + (_, Just indef) + -- A mini-hack: we rely on the fact that 'renameFreeHoles' + -- drops things that aren't holes. + -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef)) + _ -> emptyUniqDSet + where + cands = dep_sig_mods $ mi_deps iface + +-- | Given a set of free holes, and a unit identifier, rename +-- the free holes according to the instantiation of the unit +-- identifier. For example, if we have A and B free, and +-- our unit identity is @p[A=,B=impl:B]@, the renamed free +-- holes are just C. +renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName +renameFreeHoles fhs insts = + unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs)) + where + hmap = listToUFM insts + lookup_impl mod_name + | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod + -- It wasn't actually a hole + | otherwise = emptyUniqDSet + +-- See Note [Strictness in ModIface] about where we use lazyPut vs put +instance Binary ModIface where + put_ bh (PrivateModIface + { mi_hi_bytes_ = _hi_bytes, -- We don't serialise the 'mi_hi_bytes_', as it itself + -- may contain an in-memory byte array buffer for this + -- 'ModIface'. If we used 'put_' on this 'ModIface', then + -- we likely have a good reason, and do not want to reuse + -- the byte array. + -- See Note [Private fields in ModIface] + mi_mod_info_ = mod_info, + mi_iface_hash_ = iface_hash, + mi_deps_ = deps, + mi_public_ = public, + mi_top_env_ = top_env, + mi_docs_ = docs, + mi_ext_fields_ = _ext_fields, -- Don't `put_` this in the instance so we + -- can deal with it's pointer in the header + -- when we write the actual file + mi_self_recomp_ = self_recomp, + mi_simplified_core_ = simplified_core + }) = do + put_ bh mod_info + put_ bh iface_hash + lazyPut bh deps + lazyPut bh public + lazyPut bh top_env + lazyPutMaybe bh docs + lazyPutMaybe bh self_recomp + lazyPutMaybe bh simplified_core + + get bh = do + mod_info <- get bh + iface_hash <- get bh + deps <- lazyGet bh + public <- lazyGet bh + top_env <- lazyGet bh + docs <- lazyGetMaybe bh + self_recomp <- lazyGetMaybe bh + simplified_core <- lazyGetMaybe bh + + return (PrivateModIface { + mi_mod_info_ = mod_info, + mi_iface_hash_ = iface_hash, + mi_deps_ = deps, + mi_public_ = public, + mi_simplified_core_ = simplified_core, + mi_docs_ = docs, + mi_top_env_ = top_env, + mi_self_recomp_ = self_recomp, + -- placeholder because this is dealt + -- with specially when the file is read + mi_ext_fields_ = emptyExtensibleFields, + -- We can't populate this field here, as we are + -- missing the 'mi_ext_fields_' field, which is + -- handled in 'getIfaceWithExtFields'. + mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing + }) + +instance Binary IfaceModInfo where + put_ bh (IfaceModInfo { mi_mod_info_module = mod + , mi_mod_info_sig_of = sig_of + , mi_mod_info_hsc_src = hsc_src + }) = do + put_ bh mod + put_ bh sig_of + put_ bh hsc_src + + get bh = do + mod <- get bh + sig_of <- get bh + hsc_src <- get bh + return (IfaceModInfo { mi_mod_info_module = mod + , mi_mod_info_sig_of = sig_of + , mi_mod_info_hsc_src = hsc_src + }) + + +instance Binary (IfacePublic_ 'ModIfaceFinal) where + put_ bh (IfacePublic { mi_exports_ = exports + , mi_decls_ = decls + , mi_fixities_ = fixities + , mi_warns_ = warns + , mi_anns_ = anns + , mi_defaults_ = defaults + , mi_insts_ = insts + , mi_fam_insts_ = fam_insts + , mi_rules_ = rules + , mi_trust_ = trust + , mi_trust_pkg_ = trust_pkg + , mi_complete_matches_ = complete_matches + , mi_abi_hashes_ = abi_hashes + }) = do + + lazyPut bh exports + lazyPut bh decls + lazyPut bh fixities + lazyPut bh warns + lazyPut bh anns + lazyPut bh defaults + lazyPut bh insts + lazyPut bh fam_insts + lazyPut bh rules + lazyPut bh trust + lazyPut bh trust_pkg + lazyPut bh complete_matches + lazyPut bh abi_hashes + + get bh = do + exports <- lazyGet bh + decls <- lazyGet bh + fixities <- lazyGet bh + warns <- lazyGet bh + anns <- lazyGet bh + defaults <- lazyGet bh + insts <- lazyGet bh + fam_insts <- lazyGet bh + rules <- lazyGet bh + trust <- lazyGet bh + trust_pkg <- lazyGet bh + complete_matches <- lazyGet bh + abi_hashes <- lazyGet bh + return (mkIfacePublic exports decls fixities warns anns defaults insts fam_insts rules trust trust_pkg complete_matches abi_hashes) + +instance Binary IfaceAbiHashes where + put_ bh (IfaceAbiHashes { mi_abi_mod_hash = mod_hash + , mi_abi_orphan = orphan + , mi_abi_finsts = hasFamInsts + , mi_abi_export_avails_hash = vis_hash + , mi_abi_orphan_like_hash = invis_hash + , mi_abi_orphan_hash = orphan_hash + }) = do + put_ bh mod_hash + put_ bh orphan + put_ bh hasFamInsts + put_ bh vis_hash + put_ bh invis_hash + put_ bh orphan_hash + get bh = do + mod_hash <- get bh + orphan <- get bh + hasFamInsts <- get bh + vis_hash <- get bh + invis_hash <- get bh + orphan_hash <- get bh + return $ IfaceAbiHashes { + mi_abi_mod_hash = mod_hash, + mi_abi_orphan = orphan, + mi_abi_finsts = hasFamInsts, + mi_abi_export_avails_hash = vis_hash, + mi_abi_orphan_like_hash = invis_hash, + mi_abi_orphan_hash = orphan_hash + } + +instance Binary IfaceSimplifiedCore where + put_ bh (IfaceSimplifiedCore eds fs) = do + put_ bh eds + put_ bh fs + + get bh = do + eds <- get bh + fs <- get bh + return (IfaceSimplifiedCore eds fs) + +emptyPartialModIface :: Module -> PartialModIface +emptyPartialModIface mod + = PrivateModIface + { mi_mod_info_ = emptyIfaceModInfo mod, + mi_iface_hash_ = fingerprint0, + mi_hi_bytes_ = PartialIfaceBinHandle, + mi_deps_ = noDependencies, + mi_public_ = emptyPublicModIface (), + mi_simplified_core_ = Nothing, + mi_top_env_ = IfaceTopEnv emptyDetOrdAvails [] , + mi_docs_ = Nothing, + mi_self_recomp_ = Nothing, + mi_ext_fields_ = emptyExtensibleFields + + } + +emptyIfaceModInfo :: Module -> IfaceModInfo +emptyIfaceModInfo mod = IfaceModInfo + { mi_mod_info_module = mod + , mi_mod_info_sig_of = Nothing + , mi_mod_info_hsc_src = HsSrcFile + } + + +emptyPublicModIface :: IfaceAbiHashesExts phase -> IfacePublic_ phase +emptyPublicModIface abi_hashes = IfacePublic + { mi_exports_ = [] + , mi_decls_ = [] + , mi_fixities_ = [] + , mi_warns_ = IfWarnSome [] [] + , mi_anns_ = [] + , mi_defaults_ = [] + , mi_insts_ = [] + , mi_fam_insts_ = [] + , mi_rules_ = [] + , mi_abi_hashes_ = abi_hashes + , mi_trust_ = noIfaceTrustInfo + , mi_trust_pkg_ = False + , mi_caches_ = emptyModIfaceCache + , mi_complete_matches_ = [] + } + +emptyModIfaceCache :: IfaceCache +emptyModIfaceCache = IfaceCache { + mi_cache_decl_warn_fn = emptyIfaceWarnCache, + mi_cache_export_warn_fn = emptyIfaceWarnCache, + mi_cache_fix_fn = emptyIfaceFixCache, + mi_cache_hash_fn = emptyIfaceHashCache +} + +emptyIfaceBackend :: IfaceAbiHashes +emptyIfaceBackend = IfaceAbiHashes + { mi_abi_mod_hash = fingerprint0, + mi_abi_orphan = False, + mi_abi_finsts = False, + mi_abi_export_avails_hash = fingerprint0, + mi_abi_orphan_like_hash = fingerprint0, + mi_abi_orphan_hash = fingerprint0 + } + +emptyFullModIface :: Module -> ModIface +emptyFullModIface mod = + (emptyPartialModIface mod) + { mi_public_ = emptyPublicModIface emptyIfaceBackend + , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing + } + + +-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' +mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] + -> (OccName -> Maybe (OccName, Fingerprint)) +mkIfaceHashCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldl' add_decl emptyOccEnv pairs + add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d) + where + add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash) + +emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) +emptyIfaceHashCache _occ = Nothing + +-- ModIface is completely forced since it will live in memory for a long time. +-- If forcing it uses a lot of memory, then store less things in ModIface. +instance ( NFData (IfaceAbiHashesExts (phase :: ModIfacePhase)) + , NFData (IfaceDeclExts (phase :: ModIfacePhase)) + ) => NFData (ModIface_ phase) where + rnf (PrivateModIface a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) + = (a1 :: IfaceBinHandle phase) + `seq` rnf a2 + `seq` rnf a3 + `seq` rnf a4 + `seq` rnf a5 + `seq` rnf a6 + `seq` rnf a7 + `seq` rnf a8 + `seq` rnf a9 + `seq` rnf a10 + +instance NFData IfaceModInfo where + rnf (IfaceModInfo a1 a2 a3) + = rnf a1 + `seq` rnf a2 + `seq` rnf a3 + + +instance NFData IfaceSimplifiedCore where + rnf (IfaceSimplifiedCore eds fs) = rnf eds `seq` rnf fs + +instance NFData IfaceAbiHashes where + rnf (IfaceAbiHashes a1 a2 a3 a4 a5 a6) + = rnf a1 + `seq` rnf a2 + `seq` rnf a3 + `seq` rnf a4 + `seq` rnf a5 + `seq` rnf a6 + +instance (NFData (IfaceAbiHashesExts phase), NFData (IfaceDeclExts phase)) => NFData (IfacePublic_ phase) where + rnf (IfacePublic a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) + = rnf a1 + `seq` rnf a2 + `seq` rnf a3 + `seq` rnf a4 + `seq` rnf a5 + `seq` rnf a6 + `seq` rnf a7 + `seq` rnf a8 + `seq` rnf a9 + `seq` rnf a10 + `seq` rnf a11 + `seq` rnf a12 + `seq` rnf a13 + `seq` rnf a14 + +instance NFData IfaceCache where + rnf (IfaceCache a1 a2 a3 a4) + = rnf a1 + `seq` rnf a2 + `seq` rnf a3 + `seq` rnf a4 + + + +forceModIface :: ModIface -> IO () +forceModIface iface = () <$ (evaluate $ force iface) + +-- | Records whether a module has orphans. An \"orphan\" is one of: +-- +-- * An instance declaration in a module other than the definition +-- module for one of the type constructors or classes in the instance head +-- +-- * A rewrite rule in a module other than the one defining +-- the function in the head of the rule +-- +type WhetherHasOrphans = Bool + +-- | Does this module define family instances? +type WhetherHasFamInst = Bool + +-- ---------------------------------------------------------------------------- +-- Modify a 'ModIface'. +-- ---------------------------------------------------------------------------- + +{- +Note [Private fields in ModIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The fields of 'ModIface' are private, e.g., not exported, to make the API +impossible to misuse. A 'ModIface' can be "compressed" in-memory using +'shareIface', which serialises the 'ModIface' to an in-memory buffer. +This has the advantage of reducing memory usage of 'ModIface', reducing the +overall memory usage of GHC. +See Note [Sharing of ModIface]. + +This in-memory buffer can be reused, if and only if the 'ModIface' is not +modified after it has been "compressed"/shared via 'shareIface'. Instead of +serialising 'ModIface', we simply write the in-memory buffer to disk directly. + +However, we can't rely that a 'ModIface' isn't modified after 'shareIface' has +been called. Thus, we make all fields of 'ModIface' private and modification +only happens via exported update functions, such as 'set_mi_decls'. +These functions unconditionally clear any in-memory buffer if used, forcing us +to serialise the 'ModIface' to disk again. +-} + +-- | Given a 'PartialModIface', turn it into a 'ModIface' by completing +-- missing fields. +completePartialModIface :: PartialModIface + -> Fingerprint + -> [(Fingerprint, IfaceDecl)] + -> Maybe IfaceSimplifiedCore + -> IfaceAbiHashes + -> IfaceCache + -> ModIface +completePartialModIface partial iface_hash decls extra_decls final_exts cache = partial + { mi_public_ = completePublicModIface decls final_exts cache (mi_public_ partial) + , mi_simplified_core_ = extra_decls + , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing + , mi_iface_hash_ = iface_hash + } + where + +-- | Given a 'PartialIfacePublic', turn it into an 'IfacePublic' by completing +-- missing fields. +completePublicModIface :: [(Fingerprint, IfaceDecl)] + -> IfaceAbiHashes + -> IfaceCache + -> PartialIfacePublic + -> IfacePublic +completePublicModIface decls abi_hashes cache partial = partial + { mi_decls_ = decls + , mi_abi_hashes_ = abi_hashes + , mi_caches_ = cache + } + +set_mi_mod_info :: IfaceModInfo -> ModIface_ phase -> ModIface_ phase +set_mi_mod_info val iface = clear_mi_hi_bytes $ iface { mi_mod_info_ = val } + +set_mi_self_recomp :: Maybe IfaceSelfRecomp-> ModIface_ phase -> ModIface_ phase +set_mi_self_recomp val iface = clear_mi_hi_bytes $ iface { mi_self_recomp_ = val } + +set_mi_hi_bytes :: IfaceBinHandle phase -> ModIface_ phase -> ModIface_ phase +set_mi_hi_bytes val iface = iface { mi_hi_bytes_ = val } + +set_mi_deps :: Dependencies -> ModIface_ phase -> ModIface_ phase +set_mi_deps val iface = clear_mi_hi_bytes $ iface { mi_deps_ = val } + +set_mi_public :: (IfacePublic_ phase -> IfacePublic_ phase) -> ModIface_ phase -> ModIface_ phase +set_mi_public f iface = clear_mi_hi_bytes $ iface { mi_public_ = f (mi_public_ iface) } + +set_mi_simplified_core :: Maybe IfaceSimplifiedCore -> ModIface_ phase -> ModIface_ phase +set_mi_simplified_core val iface = clear_mi_hi_bytes $ iface { mi_simplified_core_ = val } + +set_mi_top_env :: IfaceTopEnv -> ModIface_ phase -> ModIface_ phase +set_mi_top_env val iface = clear_mi_hi_bytes $ iface { mi_top_env_ = val } + +set_mi_docs :: Maybe Docs -> ModIface_ phase -> ModIface_ phase +set_mi_docs val iface = clear_mi_hi_bytes $ iface { mi_docs_ = val } + +set_mi_ext_fields :: ExtensibleFields -> ModIface_ phase -> ModIface_ phase +set_mi_ext_fields val iface = clear_mi_hi_bytes $ iface { mi_ext_fields_ = val } + +{- Settings for mi_public interface fields -} + +set_mi_exports :: [IfaceExport] -> ModIface_ phase -> ModIface_ phase +set_mi_exports val = set_mi_public (\iface -> iface { mi_exports_ = val }) + +set_mi_fixities :: [(OccName, Fixity)] -> ModIface_ phase -> ModIface_ phase +set_mi_fixities val = set_mi_public (\iface -> iface { mi_fixities_ = val }) + +set_mi_warns :: IfaceWarnings -> ModIface_ phase -> ModIface_ phase +set_mi_warns val = set_mi_public (\iface -> iface { mi_warns_ = val }) + +set_mi_anns :: [IfaceAnnotation] -> ModIface_ phase -> ModIface_ phase +set_mi_anns val = set_mi_public (\iface -> iface { mi_anns_ = val }) + +set_mi_insts :: [IfaceClsInst] -> ModIface_ phase -> ModIface_ phase +set_mi_insts val = set_mi_public (\iface -> iface { mi_insts_ = val }) + +set_mi_fam_insts :: [IfaceFamInst] -> ModIface_ phase -> ModIface_ phase +set_mi_fam_insts val = set_mi_public (\iface -> iface { mi_fam_insts_ = val }) + +set_mi_rules :: [IfaceRule] -> ModIface_ phase -> ModIface_ phase +set_mi_rules val = set_mi_public (\iface -> iface { mi_rules_ = val }) + +set_mi_decls :: [IfaceDeclExts phase] -> ModIface_ phase -> ModIface_ phase +set_mi_decls val = set_mi_public (\iface -> iface { mi_decls_ = val }) + +set_mi_defaults :: [IfaceDefault] -> ModIface_ phase -> ModIface_ phase +set_mi_defaults val = set_mi_public (\iface -> iface { mi_defaults_ = val }) + +set_mi_trust :: IfaceTrustInfo -> ModIface_ phase -> ModIface_ phase +set_mi_trust val = set_mi_public (\iface -> iface { mi_trust_ = val }) + +set_mi_trust_pkg :: Bool -> ModIface_ phase -> ModIface_ phase +set_mi_trust_pkg val = set_mi_public (\iface -> iface { mi_trust_pkg_ = val }) + +set_mi_complete_matches :: [IfaceCompleteMatch] -> ModIface_ phase -> ModIface_ phase +set_mi_complete_matches val = set_mi_public (\iface -> iface { mi_complete_matches_ = val }) + +set_mi_abi_hashes :: IfaceAbiHashesExts phase -> ModIface_ phase -> ModIface_ phase +set_mi_abi_hashes val = set_mi_public (\iface -> iface { mi_abi_hashes_ = val }) + +{- Setters for mi_caches interface fields -} + +set_mi_decl_warn_fn :: (OccName -> Maybe (WarningTxt GhcRn)) -> ModIface_ phase -> ModIface_ phase +set_mi_decl_warn_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_decl_warn_fn = val } }) + +set_mi_export_warn_fn :: (Name -> Maybe (WarningTxt GhcRn)) -> ModIface_ phase -> ModIface_ phase +set_mi_export_warn_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_export_warn_fn = val } }) + +set_mi_fix_fn :: (OccName -> Maybe Fixity) -> ModIface_ phase -> ModIface_ phase +set_mi_fix_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_fix_fn = val } }) + +set_mi_hash_fn :: (OccName -> Maybe (OccName, Fingerprint)) -> ModIface_ phase -> ModIface_ phase +set_mi_hash_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_hash_fn = val } }) + +set_mi_caches :: IfaceCache -> ModIface_ phase -> ModIface_ phase +set_mi_caches val = set_mi_public (\iface -> iface { mi_caches_ = val }) + +{- + +-} + +{- Setters for mi_mod_info interface fields -} + +set_mi_module :: Module -> ModIface_ phase -> ModIface_ phase +set_mi_module val = set_mi_mod_info_field (\info -> info { mi_mod_info_module = val }) + +set_mi_sig_of :: Maybe Module -> ModIface_ phase -> ModIface_ phase +set_mi_sig_of val = set_mi_mod_info_field (\info -> info { mi_mod_info_sig_of = val }) + +set_mi_hsc_src :: HscSource -> ModIface_ phase -> ModIface_ phase +set_mi_hsc_src val = set_mi_mod_info_field (\info -> info { mi_mod_info_hsc_src = val }) + +-- | Helper function for setting fields in mi_mod_info_ +set_mi_mod_info_field :: (IfaceModInfo -> IfaceModInfo) -> ModIface_ phase -> ModIface_ phase +set_mi_mod_info_field f iface = clear_mi_hi_bytes $ iface { mi_mod_info_ = f (mi_mod_info_ iface) } + + + + +-- | Invalidate any byte array buffer we might have. +clear_mi_hi_bytes :: ModIface_ phase -> ModIface_ phase +clear_mi_hi_bytes iface = iface + { mi_hi_bytes_ = case mi_hi_bytes iface of + PartialIfaceBinHandle -> PartialIfaceBinHandle + FullIfaceBinHandle _ -> FullIfaceBinHandle Strict.Nothing + } + +-- ---------------------------------------------------------------------------- +-- 'ModIface' pattern synonyms to keep breakage low. +-- ---------------------------------------------------------------------------- + +{- +Note [Inline Pattern synonym of ModIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The introduction of the 'ModIface' pattern synonym originally caused an increase +in allocated bytes in multiple performance tests. +In some benchmarks, it was a 2~3% increase. + +Without {-# INLINE ModIface #-}, the generated core reveals the reason for this increase. +We show the core for the 'mi_module' record selector: + +@ + mi_module + = \ @phase iface -> $w$mModIface iface mi_module1 + + $w$mModIface + = \ @phase iface cont -> + case iface of + { PrivateModIface a b ... z -> + cont + a + b + ... + z + } + + mi_module1 + = \ @phase + a + _ + ... + _ -> + a +@ + +Thus, we can see the '$w$mModIface' is not inlined, leading to an increase in +the allocated bytes. + +However, with the pragma, the correct core is generated: + +@ + mi_module = mi_module_ +@ + +-} + +-- See Note [Inline Pattern synonym of ModIface] for why we have all these +-- inline pragmas. +{-# INLINE mi_mod_info #-} +{-# INLINE mi_iface_hash #-} +{-# INLINE mi_module #-} +{-# INLINE mi_sig_of #-} +{-# INLINE mi_hsc_src #-} +{-# INLINE mi_deps #-} +{-# INLINE mi_public #-} +{-# INLINE mi_exports #-} +{-# INLINE mi_fixities #-} +{-# INLINE mi_warns #-} +{-# INLINE mi_anns #-} +{-# INLINE mi_decls #-} +{-# INLINE mi_simplified_core #-} +{-# INLINE mi_defaults #-} +{-# INLINE mi_top_env #-} +{-# INLINE mi_insts #-} +{-# INLINE mi_fam_insts #-} +{-# INLINE mi_rules #-} +{-# INLINE mi_trust #-} +{-# INLINE mi_trust_pkg #-} +{-# INLINE mi_complete_matches #-} +{-# INLINE mi_docs #-} +{-# INLINE mi_abi_hashes #-} +{-# INLINE mi_ext_fields #-} +{-# INLINE mi_hi_bytes #-} +{-# INLINE mi_self_recomp_info #-} +{-# INLINE mi_fix_fn #-} +{-# INLINE mi_hash_fn #-} +{-# INLINE mi_decl_warn_fn #-} +{-# INLINE mi_export_warn_fn #-} +{-# INLINE ModIface #-} +{-# COMPLETE ModIface #-} + +pattern ModIface :: + IfaceModInfo + -> Module + -> Maybe Module + -> HscSource + -> Fingerprint + -> Dependencies + -> IfacePublic_ phase + -> [IfaceExport] + -> [(OccName, Fixity)] + -> IfaceWarnings + -> [IfaceAnnotation] + -> [IfaceDeclExts phase] + -> Maybe IfaceSimplifiedCore + -> [IfaceDefault] + -> IfaceTopEnv + -> [IfaceClsInst] + -> [IfaceFamInst] + -> [IfaceRule] + -> IfaceTrustInfo + -> Bool + -> [IfaceCompleteMatch] + -> Maybe Docs + -> IfaceAbiHashesExts phase + -> ExtensibleFields + -> IfaceBinHandle phase + -> Maybe IfaceSelfRecomp + -> (OccName -> Maybe Fixity) + -> (OccName -> Maybe (OccName, Fingerprint)) + -> (OccName -> Maybe (WarningTxt GhcRn)) + -> (Name -> Maybe (WarningTxt GhcRn)) -> + ModIface_ phase +pattern ModIface + { mi_mod_info + , mi_module + , mi_sig_of + , mi_hsc_src + , mi_iface_hash + , mi_deps + , mi_public + , mi_exports + , mi_fixities + , mi_warns + , mi_anns + , mi_decls + , mi_simplified_core + , mi_defaults + , mi_top_env + , mi_insts + , mi_fam_insts + , mi_rules + , mi_trust + , mi_trust_pkg + , mi_complete_matches + , mi_docs + , mi_abi_hashes + , mi_ext_fields + , mi_hi_bytes + , mi_self_recomp_info + , mi_fix_fn + , mi_hash_fn + , mi_decl_warn_fn + , mi_export_warn_fn + } <- PrivateModIface + { mi_mod_info_ = mi_mod_info@IfaceModInfo { mi_mod_info_module = mi_module + , mi_mod_info_sig_of = mi_sig_of + , mi_mod_info_hsc_src = mi_hsc_src } + , mi_iface_hash_ = mi_iface_hash + , mi_deps_ = mi_deps + , mi_public_ = mi_public@IfacePublic { + mi_exports_ = mi_exports + , mi_fixities_ = mi_fixities + , mi_warns_ = mi_warns + , mi_anns_ = mi_anns + , mi_decls_ = mi_decls + , mi_defaults_ = mi_defaults + , mi_insts_ = mi_insts + , mi_fam_insts_ = mi_fam_insts + , mi_rules_ = mi_rules + , mi_trust_ = mi_trust + , mi_trust_pkg_ = mi_trust_pkg + , mi_complete_matches_ = mi_complete_matches + , mi_caches_ = IfaceCache { + mi_cache_decl_warn_fn = mi_decl_warn_fn, + mi_cache_export_warn_fn = mi_export_warn_fn, + mi_cache_fix_fn = mi_fix_fn, + mi_cache_hash_fn = mi_hash_fn + } + , mi_abi_hashes_ = mi_abi_hashes + } + , mi_docs_ = mi_docs + , mi_ext_fields_ = mi_ext_fields + , mi_hi_bytes_ = mi_hi_bytes + , mi_self_recomp_ = mi_self_recomp_info + , mi_simplified_core_ = mi_simplified_core + , mi_top_env_ = mi_top_env + } diff --git a/GHC/Unit/Module/ModNodeKey.hs b/GHC/Unit/Module/ModNodeKey.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/ModNodeKey.hs @@ -0,0 +1,35 @@ +module GHC.Unit.Module.ModNodeKey + ( ModNodeKeyWithUid(..) + , mnkToModule + , moduleToMnk + , mnkIsBoot + , mnkToInstalledModule + , installedModuleToMnk + ) where + +import GHC.Prelude +import GHC.Utils.Outputable +import GHC.Unit.Types + +data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot + , mnkUnitId :: !UnitId } deriving (Eq, Ord) + +mnkToModule :: ModNodeKeyWithUid -> Module +mnkToModule (ModNodeKeyWithUid mnwib uid) = Module (RealUnit (Definite uid)) (gwib_mod mnwib) + +mnkToInstalledModule :: ModNodeKeyWithUid -> InstalledModule +mnkToInstalledModule (ModNodeKeyWithUid mnwib uid) = Module uid (gwib_mod mnwib) + +-- | Already InstalledModules are always NotBoot +installedModuleToMnk :: InstalledModule -> ModNodeKeyWithUid +installedModuleToMnk mod = ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnit mod) + +moduleToMnk :: Module -> IsBootInterface -> ModNodeKeyWithUid +moduleToMnk mod is_boot = ModNodeKeyWithUid (GWIB (moduleName mod) is_boot) (moduleUnitId mod) + +mnkIsBoot :: ModNodeKeyWithUid -> IsBootInterface +mnkIsBoot (ModNodeKeyWithUid mnwib _) = gwib_isBoot mnwib + +instance Outputable ModNodeKeyWithUid where + ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib + diff --git a/GHC/Unit/Module/ModSummary.hs b/GHC/Unit/Module/ModSummary.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/ModSummary.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE TupleSections #-} + +-- | A ModSummary is a node in the compilation manager's dependency graph +-- (ModuleGraph) +module GHC.Unit.Module.ModSummary + ( ModSummary (..) + , ms_unitid + , ms_installed_mod + , ms_mod_name + , ms_imps + , ms_plugin_imps + , ms_mnwib + , ms_home_srcimps + , ms_home_imps + , msHiFilePath + , msDynHiFilePath + , msHsFilePath + , msObjFilePath + , msDynObjFilePath + , msHsFileOsPath + , msHiFileOsPath + , msDynHiFileOsPath + , msObjFileOsPath + , msDynObjFileOsPath + , msDeps + , isBootSummary + , isTemplateHaskellOrQQNonBoot + , findTarget + ) +where + +import GHC.Prelude + +import qualified GHC.LanguageExtensions as LangExt +import GHC.Hs + +import GHC.Driver.DynFlags + +import GHC.Unit.Types +import GHC.Unit.Module + +import GHC.Types.SourceFile ( HscSource(..), hscSourceString ) +import GHC.Types.SrcLoc +import GHC.Types.Target +import GHC.Types.PkgQual +import GHC.Types.Basic + +import GHC.Data.Maybe +import GHC.Data.OsPath (OsPath) +import GHC.Data.StringBuffer ( StringBuffer ) + +import GHC.Utils.Fingerprint +import GHC.Utils.Outputable + +import Data.Time + + +-- | Data for a module node in a 'ModuleGraph'. Module nodes of the module graph +-- are one of: +-- +-- * A regular Haskell source module +-- * A hi-boot source module +-- +data ModSummary + = ModSummary { + ms_mod :: Module, + -- ^ Identity of the module + ms_hsc_src :: HscSource, + -- ^ The module source either plain Haskell, hs-boot, or hsig + ms_location :: ModLocation, + -- ^ Location of the various files belonging to the module + ms_hs_hash :: Fingerprint, + -- ^ Content hash of source file + ms_obj_date :: Maybe UTCTime, + -- ^ Timestamp of object, if we have one + ms_dyn_obj_date :: !(Maybe UTCTime), + -- ^ Timestamp of dynamic object, if we have one + ms_iface_date :: Maybe UTCTime, + -- ^ Timestamp of hi file, if we have one + -- See Note [When source is considered modified] and #9243 + ms_hie_date :: Maybe UTCTime, + -- ^ Timestamp of hie file, if we have one + ms_srcimps :: [Located ModuleName], + -- ^ Source imports of the module + ms_textual_imps :: [(ImportLevel, PkgQual, Located ModuleName)], + -- ^ Non-source imports of the module from the module *text* + ms_parsed_mod :: Maybe HsParsedModule, + -- ^ The parsed, nonrenamed source, if we have it. This is also + -- used to support "inline module syntax" in Backpack files. + ms_hspp_file :: FilePath, + -- ^ Filename of preprocessed source file + ms_hspp_opts :: DynFlags, + -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@ + -- pragmas in the modules source code + ms_hspp_buf :: Maybe StringBuffer + -- ^ The actual preprocessed source, if we have it + } + +ms_unitid :: ModSummary -> UnitId +ms_unitid = toUnitId . moduleUnit . ms_mod + +ms_installed_mod :: ModSummary -> InstalledModule +ms_installed_mod = fst . getModuleInstantiation . ms_mod + +ms_mod_name :: ModSummary -> ModuleName +ms_mod_name = moduleName . ms_mod + +-- | Textual imports, plus plugin imports but not SOURCE imports. +ms_imps :: ModSummary -> [(ImportLevel, PkgQual, Located ModuleName)] +ms_imps ms = ms_textual_imps ms ++ ms_plugin_imps ms + +-- | Plugin imports +ms_plugin_imps :: ModSummary -> [(ImportLevel, PkgQual, Located ModuleName)] +ms_plugin_imps ms = map ((SpliceLevel, NoPkgQual,) . noLoc) (pluginModNames (ms_hspp_opts ms)) + +-- | All of the (possibly) home module imports from the given list that is to +-- say, each of these module names could be a home import if an appropriately +-- named file existed. (This is in contrast to package qualified imports, which +-- are guaranteed not to be home imports.) +home_imps :: [(ImportLevel, PkgQual, Located ModuleName)] -> [(ImportLevel, PkgQual, Located ModuleName)] +home_imps imps = filter (maybe_home . pq) imps + where maybe_home NoPkgQual = True + maybe_home (ThisPkg _) = True + maybe_home (OtherPkg _) = False + + pq (_, p, _) = p + +-- | Like 'ms_home_imps', but for SOURCE imports. +ms_home_srcimps :: ModSummary -> ([Located ModuleName]) +-- [] here because source imports can only refer to the current package. +ms_home_srcimps = ms_srcimps + +-- | All of the (possibly) home module imports from a +-- 'ModSummary'; that is to say, each of these module names +-- could be a home import if an appropriately named file +-- existed. (This is in contrast to package qualified +-- imports, which are guaranteed not to be home imports.) +ms_home_imps :: ModSummary -> ([(ImportLevel, PkgQual, Located ModuleName)]) +ms_home_imps = home_imps . ms_imps + +-- The ModLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. + +-- The ModLocation is stable over successive up-sweeps in GHCi, wheres +-- the ms_hs_hash and imports can, of course, change + +msHsFilePath, msDynHiFilePath, msHiFilePath, msObjFilePath, msDynObjFilePath :: ModSummary -> FilePath +msHsFilePath ms = expectJust (ml_hs_file (ms_location ms)) +msHiFilePath ms = ml_hi_file (ms_location ms) +msDynHiFilePath ms = ml_dyn_hi_file (ms_location ms) +msObjFilePath ms = ml_obj_file (ms_location ms) +msDynObjFilePath ms = ml_dyn_obj_file (ms_location ms) + +msHsFileOsPath, msDynHiFileOsPath, msHiFileOsPath, msObjFileOsPath, msDynObjFileOsPath :: ModSummary -> OsPath +msHsFileOsPath ms = expectJust (ml_hs_file_ospath (ms_location ms)) +msHiFileOsPath ms = ml_hi_file_ospath (ms_location ms) +msDynHiFileOsPath ms = ml_dyn_hi_file_ospath (ms_location ms) +msObjFileOsPath ms = ml_obj_file_ospath (ms_location ms) +msDynObjFileOsPath ms = ml_dyn_obj_file_ospath (ms_location ms) + +-- | Did this 'ModSummary' originate from a hs-boot file? +isBootSummary :: ModSummary -> IsBootInterface +isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot + +isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool +isTemplateHaskellOrQQNonBoot ms = + (xopt LangExt.TemplateHaskell (ms_hspp_opts ms) + || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) && + (isBootSummary ms == NotBoot) + +ms_mnwib :: ModSummary -> ModuleNameWithIsBoot +ms_mnwib ms = GWIB (ms_mod_name ms) (isBootSummary ms) + +-- | Returns the dependencies of the ModSummary s. +msDeps :: ModSummary -> ([(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]) +msDeps s = [ (NormalLevel, NoPkgQual, d) -- Source imports are always NormalLevel + | m <- ms_home_srcimps s + , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot } + ] + ] + ++ [ (stage, pkg, (GWIB { gwib_mod = m, gwib_isBoot = NotBoot })) + | (stage, pkg, m) <- ms_imps s + ] + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_hash = " <> text (show (ms_hs_hash ms)), + text "ms_mod =" <+> ppr (ms_mod ms) + <> text (hscSourceString (ms_hsc_src ms)) <> comma, + text "unit =" <+> ppr (ms_unitid ms), + text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +-- | Find the first target in the provided list which matches the specified +-- 'ModSummary'. +findTarget :: ModSummary -> [Target] -> Maybe Target +findTarget ms ts = + case filter (matches ms) ts of + [] -> Nothing + (t:_) -> Just t + where + summary `matches` Target { targetId = TargetModule m, targetUnitId = unitId } + = ms_mod_name summary == m && ms_unitid summary == unitId + summary `matches` Target { targetId = TargetFile f _, targetUnitId = unitid } + | Just f' <- ml_hs_file (ms_location summary) + = f == f' && ms_unitid summary == unitid + _ `matches` _ + = False + diff --git a/GHC/Unit/Module/Stage.hs b/GHC/Unit/Module/Stage.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Stage.hs @@ -0,0 +1,85 @@ +module GHC.Unit.Module.Stage ( ModuleStage(..) + , allStages + , nowAndFutureStages + , onlyFutureStages + , minStage + , maxStage + , zeroStage + , decModuleStage + , incModuleStage + ) where + +import GHC.Prelude +import GHC.Utils.Outputable + +{- Note [Stage vs Level] +~~~~~~~~~~~~~~~~~~~~~~~~ + +Modules are compiled at a specific stage. Levels within a module are interpreted +as offsets to the specific stage at which the module is being compiled. + +* A **level** is a typechecking concept. The type checker performs level checking + to ensure that the evaluation can proceed in a well-staged manner. +* A **stage** is an operational construct. The execution of the program happens + in stages. + +GHC at the moment knows about two stages, a module is either compiled for +compile time (*C*) or runtime (*R*), with *C* before *R*. Then: + +* The main module is compiled for `R`. + +* A normal import does not shift the stage at which the dependent module is required. + +* If a module `M` splice imports module `A`, then compiling `M` at stage + *R* requires compiling module `A` at stage *C*. + +* If a module `N` quote imports module `B`, then compiling `N` at stage + *C* requires compiling module `B` at stage *R*. + +The compiler can then choose appropiately how modules needed at `C` are compiled +and how modules needed at `R` are compiled. + +For example: + +* In `-fno-code` mode, `C` modules may be compiled in dynamic way, but `R` modules + are not compiled at all. +* When using a profiled GHC. `C` modules must be compiled in profiled way but `R` modules + will be compiled in static way. + +Further structure as needed by cross-compilation settings may require more stages. + +-} + +-- The order of these constructors is important for definitions such as +-- 'futureStages'. +data ModuleStage = CompileStage | RunStage deriving (Eq, Ord, Enum, Bounded) + +allStages :: [ModuleStage] +allStages = [minBound .. maxBound] + +nowAndFutureStages :: ModuleStage -> [ModuleStage] +nowAndFutureStages cur_st = [cur_st .. ] + +onlyFutureStages :: ModuleStage -> [ModuleStage] +onlyFutureStages cur_st | cur_st == maxBound = [] +onlyFutureStages cur_st = [succ cur_st .. ] + +minStage :: ModuleStage +minStage = minBound + +maxStage :: ModuleStage +maxStage = maxBound + +instance Outputable ModuleStage where + ppr CompileStage = text "compile" + ppr RunStage = text "run" + +zeroStage :: ModuleStage +zeroStage = RunStage + +decModuleStage, incModuleStage :: ModuleStage -> ModuleStage +incModuleStage RunStage = RunStage +incModuleStage CompileStage = RunStage + +decModuleStage RunStage = CompileStage +decModuleStage CompileStage = RunStage diff --git a/GHC/Unit/Module/Status.hs b/GHC/Unit/Module/Status.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Status.hs @@ -0,0 +1,50 @@ +module GHC.Unit.Module.Status + ( HscBackendAction(..), HscRecompStatus (..) + ) +where + +import GHC.Prelude + +import GHC.Unit +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface + +import GHC.Utils.Fingerprint +import GHC.Utils.Outputable +import GHC.Unit.Home.ModInfo + +-- | Status of a module in incremental compilation +data HscRecompStatus + -- | Nothing to do because code already exists. + = HscUpToDate ModIface HomeModLinkable + -- | Recompilation of module, or update of interface is required. Optionally + -- pass the old interface hash to avoid updating the existing interface when + -- it has not changed. + | HscRecompNeeded (Maybe Fingerprint) + +-- | Action to perform in backend compilation +data HscBackendAction + -- | Update the boot and signature file results. + = HscUpdate ModIface + -- | Recompile this module. + | HscRecomp + { hscs_guts :: CgGuts + -- ^ Information for the code generator. + , hscs_mod_location :: !ModLocation + -- ^ Module info + , hscs_partial_iface :: !PartialModIface + -- ^ Partial interface + , hscs_old_iface_hash :: !(Maybe Fingerprint) + -- ^ Old interface hash for this compilation, if an old interface file + -- exists. Pass to `hscMaybeWriteIface` when writing the interface to + -- avoid updating the existing interface when the interface isn't + -- changed. + } + +instance Outputable HscRecompStatus where + ppr HscUpToDate{} = text "HscUpToDate" + ppr HscRecompNeeded{} = text "HscRecompNeeded" + +instance Outputable HscBackendAction where + ppr (HscUpdate mi) = text "Update:" <+> (ppr (mi_module mi)) + ppr (HscRecomp _ ml _mi _mf) = text "Recomp:" <+> ppr ml diff --git a/GHC/Unit/Module/Warnings.hs b/GHC/Unit/Module/Warnings.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Warnings.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Warnings for a module +module GHC.Unit.Module.Warnings + ( WarningCategory(..) + , mkWarningCategory + , defaultWarningCategory + , validWarningCategory + , InWarningCategory(..) + , fromWarningCategory + + , WarningCategorySet + , emptyWarningCategorySet + , completeWarningCategorySet + , nullWarningCategorySet + , elemWarningCategorySet + , insertWarningCategorySet + , deleteWarningCategorySet + + , Warnings (..) + , WarningTxt (..) + , LWarningTxt + , DeclWarnOccNames + , ExportWarnNames + , warningTxtCategory + , warningTxtMessage + , warningTxtSame + , pprWarningTxtForMsg + , emptyWarn + , mkIfaceDeclWarnCache + , mkIfaceExportWarnCache + , emptyIfaceWarnCache + , insertWarnDecls + , insertWarnExports + ) +where + +import GHC.Prelude + +import GHC.Data.FastString (FastString, mkFastString, unpackFS) +import GHC.Types.SourceText +import GHC.Types.Name.Occurrence +import GHC.Types.Name.Env +import GHC.Types.Name (Name) +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Hs.Doc +import GHC.Hs.Extension +import GHC.Parser.Annotation + +import GHC.Utils.Outputable +import GHC.Utils.Binary +import GHC.Unicode + +import Language.Haskell.Syntax.Extension + +import Data.Data +import Data.List (isPrefixOf) +import GHC.Generics ( Generic ) +import Control.DeepSeq + + +{- +Note [Warning categories] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See GHC Proposal 541 for the design of the warning categories feature: +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-warning-pragmas-with-categories.rst + +A WARNING pragma may be annotated with a category such as "x-partial" written +after the 'in' keyword, like this: + + {-# WARNING in "x-partial" head "This function is partial..." #-} + +This is represented by the 'Maybe (Located WarningCategory)' field in +'WarningTxt'. The parser will accept an arbitrary string as the category name, +then the renamer (in 'rnWarningTxt') will check it contains only valid +characters, so we can generate a nicer error message than a parse error. + +The corresponding warnings can then be controlled with the -Wx-partial, +-Wno-x-partial, -Werror=x-partial and -Wwarn=x-partial flags. Such a flag is +distinguished from an 'unrecognisedWarning' by the flag parser testing +'validWarningCategory'. The 'x-' prefix means we can still usually report an +unrecognised warning where the user has made a mistake. + +A DEPRECATED pragma may not have a user-defined category, and is always treated +as belonging to the special category 'deprecations'. Similarly, a WARNING +pragma without a category belongs to the 'deprecations' category. +Thus the '-Wdeprecations' flag will enable all of the following: + + {-# WARNING in "deprecations" foo "This function is deprecated..." #-} + {-# WARNING foo "This function is deprecated..." #-} + {-# DEPRECATED foo "This function is deprecated..." #-} + +The '-Wwarnings-deprecations' flag is supported for backwards compatibility +purposes as being equivalent to '-Wdeprecations'. + +The '-Wextended-warnings' warning group collects together all warnings with +user-defined categories, so they can be enabled or disabled +collectively. Moreover they are treated as being part of other warning groups +such as '-Wdefault' (see 'warningGroupIncludesExtendedWarnings'). + +'DynFlags' and 'DiagOpts' each contain a set of enabled and a set of fatal +warning categories, just as they do for the finite enumeration of 'WarningFlag's +built in to GHC. These are represented as 'WarningCategorySet's to allow for +the possibility of them being infinite. + +-} + +data InWarningCategory + = InWarningCategory + { iwc_in :: !(EpToken "in"), + iwc_st :: !SourceText, + iwc_wc :: (LocatedE WarningCategory) + } deriving Data + +fromWarningCategory :: WarningCategory -> InWarningCategory +fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc) + + +-- See Note [Warning categories] +newtype WarningCategory = WarningCategory FastString + deriving stock Data + deriving newtype (Binary, Eq, Outputable, Show, Uniquable, NFData) + +mkWarningCategory :: FastString -> WarningCategory +mkWarningCategory = WarningCategory + +-- | The @deprecations@ category is used for all DEPRECATED pragmas and for +-- WARNING pragmas that do not specify a category. +defaultWarningCategory :: WarningCategory +defaultWarningCategory = mkWarningCategory (mkFastString "deprecations") + +-- | Is this warning category allowed to appear in user-defined WARNING pragmas? +-- It must either be the known category @deprecations@, or be a custom category +-- that begins with @x-@ and contains only valid characters (letters, numbers, +-- apostrophes and dashes). +validWarningCategory :: WarningCategory -> Bool +validWarningCategory cat@(WarningCategory c) = + cat == defaultWarningCategory || ("x-" `isPrefixOf` s && all is_allowed s) + where + s = unpackFS c + is_allowed c = isAlphaNum c || c == '\'' || c == '-' + + +-- | A finite or infinite set of warning categories. +-- +-- Unlike 'WarningFlag', there are (in principle) infinitely many warning +-- categories, so we cannot necessarily enumerate all of them. However the set +-- is constructed by adding or removing categories one at a time, so we can +-- represent it as either a finite set of categories, or a cofinite set (where +-- we store the complement). +data WarningCategorySet = + FiniteWarningCategorySet (UniqSet WarningCategory) + -- ^ The set of warning categories is the given finite set. + | CofiniteWarningCategorySet (UniqSet WarningCategory) + -- ^ The set of warning categories is infinite, so the constructor stores + -- its (finite) complement. + +-- | The empty set of warning categories. +emptyWarningCategorySet :: WarningCategorySet +emptyWarningCategorySet = FiniteWarningCategorySet emptyUniqSet + +-- | The set consisting of all possible warning categories. +completeWarningCategorySet :: WarningCategorySet +completeWarningCategorySet = CofiniteWarningCategorySet emptyUniqSet + +-- | Is this set empty? +nullWarningCategorySet :: WarningCategorySet -> Bool +nullWarningCategorySet (FiniteWarningCategorySet s) = isEmptyUniqSet s +nullWarningCategorySet CofiniteWarningCategorySet{} = False + +-- | Does this warning category belong to the set? +elemWarningCategorySet :: WarningCategory -> WarningCategorySet -> Bool +elemWarningCategorySet c (FiniteWarningCategorySet s) = c `elementOfUniqSet` s +elemWarningCategorySet c (CofiniteWarningCategorySet s) = not (c `elementOfUniqSet` s) + +-- | Insert an element into a warning category set. +insertWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet +insertWarningCategorySet c (FiniteWarningCategorySet s) = FiniteWarningCategorySet (addOneToUniqSet s c) +insertWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (delOneFromUniqSet s c) + +-- | Delete an element from a warning category set. +deleteWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet +deleteWarningCategorySet c (FiniteWarningCategorySet s) = FiniteWarningCategorySet (delOneFromUniqSet s c) +deleteWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (addOneToUniqSet s c) + +type LWarningTxt pass = XRec pass (WarningTxt pass) + +-- | Warning Text +-- +-- reason/explanation from a WARNING or DEPRECATED pragma +data WarningTxt pass + = WarningTxt + (Maybe (LocatedE InWarningCategory)) + -- ^ Warning category attached to this WARNING pragma, if any; + -- see Note [Warning categories] + SourceText + [LocatedE (WithHsDocIdentifiers StringLiteral pass)] + | DeprecatedTxt + SourceText + [LocatedE (WithHsDocIdentifiers StringLiteral pass)] + deriving Generic + +-- | To which warning category does this WARNING or DEPRECATED pragma belong? +-- See Note [Warning categories]. +warningTxtCategory :: WarningTxt pass -> WarningCategory +warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _ _ (L _ cat)))) _ _) = cat +warningTxtCategory _ = defaultWarningCategory + +-- | The message that the WarningTxt was specified to output +warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)] +warningTxtMessage (WarningTxt _ _ m) = m +warningTxtMessage (DeprecatedTxt _ m) = m + +-- | True if the 2 WarningTxts have the same category and messages +warningTxtSame :: WarningTxt p1 -> WarningTxt p2 -> Bool +warningTxtSame w1 w2 + = warningTxtCategory w1 == warningTxtCategory w2 + && literal_message w1 == literal_message w2 + && same_type + where + literal_message :: WarningTxt p -> [StringLiteral] + literal_message = map (hsDocString . unLoc) . warningTxtMessage + same_type | DeprecatedTxt {} <- w1, DeprecatedTxt {} <- w2 = True + | WarningTxt {} <- w1, WarningTxt {} <- w2 = True + | otherwise = False + +deriving instance Eq InWarningCategory + +deriving instance (Eq (IdP pass)) => Eq (WarningTxt pass) +deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) + +type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP + +instance Outputable InWarningCategory where + ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt) + + +instance Outputable (WarningTxt pass) where + ppr (WarningTxt mcat lsrc ws) + = case lsrc of + NoSourceText -> pp_ws ws + SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" + where + ctg_doc = maybe empty (\ctg -> ppr ctg) mcat + + + ppr (DeprecatedTxt lsrc ds) + = case lsrc of + NoSourceText -> pp_ws ds + SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" + +pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc +pp_ws [l] = ppr $ unLoc l +pp_ws ws + = text "[" + <+> vcat (punctuate comma (map (ppr . unLoc) ws)) + <+> text "]" + + +pprWarningTxtForMsg :: WarningTxt p -> SDoc +pprWarningTxtForMsg (WarningTxt _ _ ws) + = doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ws)) +pprWarningTxtForMsg (DeprecatedTxt _ ds) + = text "Deprecated:" <+> + doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ds)) + + +-- | Warning information from a module +data Warnings pass + = WarnSome (DeclWarnOccNames pass) -- ^ Names deprecated (may be empty) + (ExportWarnNames pass) -- ^ Exports deprecated (may be empty) + | WarnAll (WarningTxt pass) -- ^ Whole module deprecated + + -- For the module-specific names only an OccName is needed because + -- (1) a deprecation always applies to a binding + -- defined in the module in which the deprecation appears. + -- (2) deprecations are only reported outside the defining module. + -- this is important because, otherwise, if we saw something like + -- + -- {-# DEPRECATED f "" #-} + -- f = ... + -- h = f + -- g = let f = undefined in f + -- + -- we'd need more information than an OccName to know to say something + -- about the use of f in h but not the use of the locally bound f in g + -- + -- however, because we only report about deprecations from the outside, + -- and a module can only export one value called f, + -- an OccName suffices. + -- + -- this is in contrast with fixity declarations, where we need to map + -- a Name to its fixity declaration. + -- + -- For export deprecations we need to know where the symbol comes from, since + -- we need to be able to check if the deprecated export that was imported is + -- the same thing as imported by another import, which would not trigger + -- a deprecation message. + +-- | Deprecated declarations +type DeclWarnOccNames pass = [(OccName, WarningTxt pass)] + +-- | Names that are deprecated as exports +type ExportWarnNames pass = [(Name, WarningTxt pass)] + +deriving instance Eq (IdP pass) => Eq (Warnings pass) + +emptyWarn :: Warnings p +emptyWarn = WarnSome [] [] + +-- | Constructs the cache for the 'mi_decl_warn_fn' field of a 'ModIface' +mkIfaceDeclWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p) +mkIfaceDeclWarnCache (WarnAll t) = \_ -> Just t +mkIfaceDeclWarnCache (WarnSome vs _) = lookupOccEnv (mkOccEnv vs) + +-- | Constructs the cache for the 'mi_export_warn_fn' field of a 'ModIface' +mkIfaceExportWarnCache :: Warnings p -> Name -> Maybe (WarningTxt p) +mkIfaceExportWarnCache (WarnAll _) = const Nothing -- We do not want a double report of the module deprecation +mkIfaceExportWarnCache (WarnSome _ ds) = lookupNameEnv (mkNameEnv ds) + +emptyIfaceWarnCache :: name -> Maybe (WarningTxt p) +emptyIfaceWarnCache _ = Nothing + +insertWarnDecls :: Warnings p -- ^ Existing warnings + -> [(OccName, WarningTxt p)] -- ^ New declaration deprecations + -> Warnings p -- ^ Updated warnings +insertWarnDecls ws@(WarnAll _) _ = ws +insertWarnDecls (WarnSome wns wes) wns' = WarnSome (wns ++ wns') wes + +insertWarnExports :: Warnings p -- ^ Existing warnings + -> [(Name, WarningTxt p)] -- ^ New export deprecations + -> Warnings p -- ^ Updated warnings +insertWarnExports ws@(WarnAll _) _ = ws +insertWarnExports (WarnSome wns wes) wes' = WarnSome wns (wes ++ wes') diff --git a/GHC/Unit/Module/WholeCoreBindings.hs b/GHC/Unit/Module/WholeCoreBindings.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/WholeCoreBindings.hs @@ -0,0 +1,503 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module GHC.Unit.Module.WholeCoreBindings where + +import GHC.Cmm.CLabel +import GHC.Driver.DynFlags (DynFlags (targetPlatform), initSDocContext) +import GHC.ForeignSrcLang (ForeignSrcLang (..)) +import GHC.Iface.Syntax +import GHC.Prelude +import GHC.Types.ForeignStubs +import GHC.Unit.Module.Location +import GHC.Unit.Types (Module) +import GHC.Utils.Binary +import GHC.Utils.Error (debugTraceMsg) +import GHC.Utils.Logger (Logger) +import GHC.Utils.Outputable +import GHC.Utils.Panic (panic, pprPanic) +import GHC.Utils.TmpFs + +import Control.DeepSeq (NFData (..)) +import Data.Traversable (for) +import Data.Word (Word8) +import Data.Maybe (fromMaybe) +import System.FilePath (takeExtension) + +{- +Note [Interface Files with Core Definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A interface file can optionally contain the definitions of all core bindings, this +is enabled by the flag `-fwrite-if-simplified-core`. +This provides everything needed in addition to the normal ModIface and ModDetails +to restart compilation after typechecking to generate bytecode. The `wcb_bindings` field +is stored in the normal interface file and the other fields populated whilst loading +the interface file. + +The lifecycle of a WholeCoreBindings typically proceeds as follows: + +1. The ModIface which contains mi_extra_decls is loaded from disk. A linkable is + created (which is headed by the `CoreBindings` constructor). This is an unhydrated set of bindings which + is currently unsuitable for linking, but at the point it is loaded, the ModIface + hasn't been hydrated yet (See Note [Hydrating Modules]) either so the CoreBindings constructor allows the delaying of converting + the WholeCoreBindings into a proper Linkable (if we ever do that). The CoreBindings constructor also + allows us to convert the WholeCoreBindings into multiple different linkables if we so desired. + +2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCOs linkable. This step combines together + all the necessary information from a ModIface, ModDetails and WholeCoreBindings in order to + create the linkable. The linkable created is a "LazyBCOs" linkable, which + was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazily. + Using the `BCOs` constructor directly here leads to the bytecode being forced + too eagerly. + +3. Then when bytecode is needed, the LazyBCOs value is inspected and unpacked and + the linkable is used as before. + +The flag `-fwrite-if-simplified-core` determines whether the extra information is written +to an interface file. The program which is written is the core bindings of the module +after whatever simplification the user requested has been performed. So the simplified core bindings +of the interface file agree with the optimisation level as reported by the interface +file. + +The lifecycle differs beyond laziness depending on the provenance of a module. +In all cases, the main consumer for interface bytecode is 'get_link_deps', which +traverses a splice's or GHCi expression's dependencies and collects the needed +build artifacts, which can be objects or bytecode, depending on the build +settings. + +1. In make mode, all eligible modules are part of the dependency graph. + Their interfaces are loaded unconditionally and in dependency order by the + compilation manager, and each module's bytecode is prepared before its + dependents are compiled, in one of two ways: + + - If the interface file for a module is missing or out of sync with its + source, it is recompiled and bytecode is generated directly and + immediately, not involving 'WholeCoreBindings' (in 'runHscBackendPhase'). + + - If the interface file is up to date, no compilation is performed, and a + lazy thunk generating bytecode from interface Core bindings is created in + 'compileOne'', which will only be compiled if a downstream module contains + a splice that depends on it, as described above. + + In both cases, the bytecode 'Linkable' is stored in a 'HomeModLinkable' in + the Home Unit Graph, lazy or not. + +2. In oneshot mode, which compiles individual modules without a shared home unit + graph, a previously compiled module is not reprocessed as described for make + mode above. + When 'get_link_deps' encounters a dependency on a local module, it requests + its bytecode from the External Package State, who loads the interface + on-demand. + + Since the EPS stores interfaces for all package dependencies in addition to + local modules in oneshot mode, it has a substantial memory footprint. + We try to curtail that by extracting important data into specialized fields + in the EPS, and retaining only a few fields of 'ModIface' by overwriting the + others with bottom values. + + In order to avoid keeping around all of the interface's components needed for + compiling bytecode, we instead store an IO action in 'eps_iface_bytecode'. + When 'get_link_deps' evaluates this action, the result is not retained in the + EPS, but stored in 'LoaderState', where it may eventually get evicted to free + up the memory. + This IO action retains the dehydrated Core bindings from the interface in its + closure. + Like the bytecode 'Linkable' stored in 'LoaderState', this is preferable to + storing the intermediate representation as rehydrated Core bindings, since + the latter have a significantly greater memory footprint. + +Note [Size of Interface Files with Core Definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +How much overhead does `-fwrite-if-simplified-core` add to a typical interface file? +As an experiment I compiled the `Cabal` library and `ghc` library (Aug 22) with + +| Project | .hi | .hi (fat) | .o | +| --------| ---- | --------- | -- | +| ghc | 32M | 68M | 127M | +| Cabal | 3.2M | 9.8M | 14M | + +So the interface files gained in size but the end result was still smaller than +the object files. + +-} + +data WholeCoreBindings = WholeCoreBindings + { wcb_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -- ^ serialised tidied core bindings. + , wcb_module :: Module -- ^ The module which the bindings are for + , wcb_mod_location :: ModLocation -- ^ The location where the sources reside. + -- | Stubs for foreign declarations and files added via + -- 'GHC.Internal.TH.Syntax.addForeignFilePath'. + , wcb_foreign :: IfaceForeign + } + +{- +Note [Foreign stubs and TH bytecode linking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Foreign declarations may introduce additional build products called "stubs" that +contain wrappers for the exposed functions. +For example, consider a foreign import of a C function named @main_loop@ from +the file @bindings.h@ in the module @CLibrary@: + +@ +foreign import capi "bindings.h main_loop" mainLoop :: IO Int +@ + +GHC will generate a snippet of C code containing a wrapper: + +@ +#include "bindings.h" +HsInt ghczuwrapperZC0ZCmainZCCLibraryZCmainzuloop(void) {return main_loop();} +@ + +Wrappers like these are generated as 'ForeignStubs' by the desugarer in +'dsForeign' and stored in the various @*Guts@ types; until they are compiled to +temporary object files in 'runHscBackendPhase' during code generation and +ultimately merged into the final object file for the module, @CLibrary.o@. + +This creates some problems with @-fprefer-byte-code@, which allows splices to +execute bytecode instead of native code for dependencies that provide it. +Usually, when some TH code depends on @CLibrary@, the linker would look for +@CLibrary.o@ and load that before executing the splice, but with this flag, it +will first attempt to load bytecode from @CLibrary.hi@ and compile it in-memory. + +Problem 1: + +Code for splices is loaded from interfaces in the shape of Core bindings +(see 'WholeCoreBindings'), rather than from object files. +Those Core bindings are intermediate build products that do not contain the +module's stubs, since those are separated from the Haskell code before Core is +generated and only compiled and linked into the final object when native code is +generated. + +Therefore, stubs have to be stored separately in interface files. +Unfortunately, the type 'ForeignStubs' contains 'CLabel', which is a huge type +with several 'Unique's used mainly by C--. +Luckily, the only constructor used for foreign stubs is 'ModuleLabel', which +contains the name of a foreign declaration's initializer, if it has one. +So we convert a 'CLabel' to 'CStubLabel' in 'encodeIfaceForeign' and store only +the simplified data. + +Problem 2: + +Given module B, which contains a splice that executes code from module A, both +in the home package, consider these different circumstances: + +1. In make mode, both modules are recompiled +2. In make mode, only B is recompiled +3. In oneshot mode, B is compiled + +In case 1, 'runHscBackendPhase' directly generates bytecode from the 'CgGuts' +that the main pipeline produced and stores it in the 'HomeModLinkable' that is +one of its build products. +The stubs are merged into a single object and added to the 'HomeModLinkable' in +'hscGenBackendPipeline'. + +In case 2, 'hscRecompStatus' short-circuits the pipeline while checking A, since +the module is up to date. +Nevertheless, it calls 'checkByteCode', which extracts Core bindings from A's +interface and adds them to the 'HomeModLinkable'. +No stubs are generated in this case, since the desugarer wasn't run! + +In both of these cases, 'compileOne'' proceeds to call 'initWholeCoreBindings', +applied to the 'HomeModLinkable', to compile Core bindings (lazily) to bytecode, +which is then written back to the 'HomeModLinkable'. +If the 'HomeModLinkable' already contains bytecode (case 1), this is a no-op. +Otherwise, the stub objects from the interface are compiled to objects in +'generateByteCode' and added to the 'HomeModLinkable' as well. + +Case 3 is not implemented yet (!13042). + +Problem 3: + +In all three cases, the final step before splice execution is linking. + +The function 'getLinkDeps' is responsible for assembling all of a splice's +dependencies, looking up imported modules in the HPT and EPS, collecting all +'HomeModLinkable's and object files that it can find. + +However, since splices are executed in the interpreter, the 'Way' of the current +build may differ from the interpreter's. +For example, the current GHC invocation might be building a static binary, but +the internal interpreter requires dynamic linking; or profiling might be +enabled. +To adapt to the interpreter's 'Way', 'getLinkDeps' substitutes all object files' +extensions with that corresponding to that 'Way' – e.g. changing @.o@ to +@.dyn_o@, which requires dependencies to be built with @-dynamic[-too]@, which +in turn is enforced after downsweep in 'GHC.Driver.Make.enableCodeGenWhen'. + +This doesn't work for stub objects, though – they are compiled to temporary +files with mismatching names, so simply switching out the suffix would refer to +a nonexisting file. +Even if that wasn't an issue, they are compiled for the session's 'Way', not its +associated module's, so the dynamic variant wouldn't be available when building +only static outputs. + +To mitigate this, we instead build foreign objects specially for the +interpreter, updating the build flags in 'compile_for_interpreter' to use the +interpreter's way. + +Problem 4: + +Foreign code may have dependencies on Haskell code. + +Both foreign exports and @StaticPointers@ produce stubs that contain @extern@ +declarations of values referring to STG closures. +When those stub objects are loaded, the undefined symbols need to be provided to +the linker. + +I have no insight into how this works, and whether we could provide the memory +address of a BCO as a ccall symbol while linking, so it's unclear at the moment +what to do about this. + +In addition to that, those objects would also have to be loaded _after_ +bytecode, and therefore 'DotO' would have to be marked additionally to separate +them from those that are loaded before. +If mutual dependencies between BCOs and foreign code are possible, this will be +much more diffcult though. + +Problem 5: + +TH allows splices to add arbitrary files as additional linker inputs. + +Using the method `qAddForeignFilePath`, a foreign source file or a precompiled +object file can be added to the current modules dependencies. +These files will be processed by the pipeline and linked into the final object. + +Since the files may be temporarily created from a string, we have to read their +contents in 'encodeIfaceForeign' and store them in the interface as well, and +write them to temporary files when loading bytecode in 'decodeIfaceForeign'. +-} + +-- | Wrapper for avoiding a dependency on 'Binary' and 'NFData' in 'CLabel'. +newtype IfaceCLabel = IfaceCLabel CStubLabel + +instance Binary IfaceCLabel where + get bh = do + csl_is_initializer <- get bh + csl_module <- get bh + csl_name <- get bh + pure (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name}) + + put_ bh (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name}) = do + put_ bh csl_is_initializer + put_ bh csl_module + put_ bh csl_name + +instance NFData IfaceCLabel where + rnf (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name}) = + rnf csl_is_initializer `seq` rnf csl_module `seq` rnf csl_name + +instance Outputable IfaceCLabel where + ppr (IfaceCLabel l) = ppr l + +-- | Simplified encoding of 'GHC.Types.ForeignStubs.ForeignStubs' for interface +-- serialization. +-- +-- See Note [Foreign stubs and TH bytecode linking] +data IfaceCStubs = + IfaceCStubs { + header :: String, + source :: String, + initializers :: [IfaceCLabel], + finalizers :: [IfaceCLabel] + } + +instance Outputable IfaceCStubs where + ppr IfaceCStubs {header, source, initializers, finalizers} = + vcat [ + hang (text "header:") 2 (vcat (text <$> lines header)), + hang (text "source:") 2 (vcat (text <$> lines source)), + hang (text "initializers:") 2 (ppr initializers), + hang (text "finalizers:") 2 (ppr finalizers) + ] + +-- | 'Binary' 'put_' for 'ForeignSrcLang'. +binary_put_ForeignSrcLang :: WriteBinHandle -> ForeignSrcLang -> IO () +binary_put_ForeignSrcLang bh lang = + put_ @Word8 bh $ case lang of + LangC -> 0 + LangCxx -> 1 + LangObjc -> 2 + LangObjcxx -> 3 + LangAsm -> 4 + LangJs -> 5 + RawObject -> 6 + +-- | 'Binary' 'get' for 'ForeignSrcLang'. +binary_get_ForeignSrcLang :: ReadBinHandle -> IO ForeignSrcLang +binary_get_ForeignSrcLang bh = do + b <- getByte bh + pure $ case b of + 0 -> LangC + 1 -> LangCxx + 2 -> LangObjc + 3 -> LangObjcxx + 4 -> LangAsm + 5 -> LangJs + 6 -> RawObject + _ -> panic "invalid Binary value for ForeignSrcLang" + +instance Binary IfaceCStubs where + get bh = do + header <- get bh + source <- get bh + initializers <- get bh + finalizers <- get bh + pure IfaceCStubs {..} + + put_ bh IfaceCStubs {..} = do + put_ bh header + put_ bh source + put_ bh initializers + put_ bh finalizers + +instance NFData IfaceCStubs where + rnf IfaceCStubs {..} = + rnf header + `seq` + rnf source + `seq` + rnf initializers + `seq` + rnf finalizers + +-- | A source file added from Template Haskell using 'qAddForeignFilePath', for +-- storage in interfaces. +-- +-- See Note [Foreign stubs and TH bytecode linking] +data IfaceForeignFile = + IfaceForeignFile { + -- | The language is specified by the user. + lang :: ForeignSrcLang, + + -- | The contents of the file, which will be written to a temporary file + -- when loaded from an interface. + source :: String, + + -- | The extension used by the user is preserved, to avoid confusing + -- external tools with an unexpected @.c@ file or similar. + extension :: FilePath + } + +instance Outputable IfaceForeignFile where + ppr IfaceForeignFile {lang, source} = + hang (text (show lang) <> colon) 2 (vcat (text <$> lines source)) + +instance Binary IfaceForeignFile where + get bh = do + lang <- binary_get_ForeignSrcLang bh + source <- get bh + extension <- get bh + pure IfaceForeignFile {lang, source, extension} + + put_ bh IfaceForeignFile {lang, source, extension} = do + binary_put_ForeignSrcLang bh lang + put_ bh source + put_ bh extension + +instance NFData IfaceForeignFile where + rnf IfaceForeignFile {lang, source, extension} = + lang `seq` rnf source `seq` rnf extension + +data IfaceForeign = + IfaceForeign { + stubs :: Maybe IfaceCStubs, + files :: [IfaceForeignFile] + } + +instance Outputable IfaceForeign where + ppr IfaceForeign {stubs, files} = + hang (text "stubs:") 2 (maybe (text "empty") ppr stubs) $$ + vcat (ppr <$> files) + +emptyIfaceForeign :: IfaceForeign +emptyIfaceForeign = IfaceForeign {stubs = Nothing, files = []} + +-- | Convert foreign stubs and foreign files to a format suitable for writing to +-- interfaces. +-- +-- See Note [Foreign stubs and TH bytecode linking] +encodeIfaceForeign :: + Logger -> + DynFlags -> + ForeignStubs -> + [(ForeignSrcLang, FilePath)] -> + IO IfaceForeign +encodeIfaceForeign logger dflags foreign_stubs lang_paths = do + files <- read_foreign_files + stubs <- encode_stubs foreign_stubs + let iff = IfaceForeign {stubs, files} + debugTraceMsg logger 3 $ + hang (text "Encoding foreign data for iface:") 2 (ppr iff) + pure iff + where + -- We can't just store the paths, since files may have been generated with + -- GHC session lifetime in 'GHC.Internal.TH.Syntax.addForeignSource'. + read_foreign_files = + for lang_paths $ \ (lang, path) -> do + source <- readFile path + pure IfaceForeignFile {lang, source, extension = takeExtension path} + + encode_stubs = \case + NoStubs -> + pure Nothing + ForeignStubs (CHeader header) (CStub source inits finals) -> + pure $ Just IfaceCStubs { + header = render header, + source = render source, + initializers = encode_label <$> inits, + finalizers = encode_label <$> finals + } + + encode_label clabel = + fromMaybe (invalid_label clabel) (IfaceCLabel <$> cStubLabel clabel) + + invalid_label clabel = + pprPanic + "-fwrite-if-simplified-core is incompatible with this foreign stub:" + (pprCLabel (targetPlatform dflags) clabel) + + render = renderWithContext (initSDocContext dflags PprCode) + +-- | Decode serialized foreign stubs and foreign files. +-- +-- See Note [Foreign stubs and TH bytecode linking] +decodeIfaceForeign :: + Logger -> + TmpFs -> + TempDir -> + IfaceForeign -> + IO (ForeignStubs, [(ForeignSrcLang, FilePath)]) +decodeIfaceForeign logger tmpfs tmp_dir iff@IfaceForeign {stubs, files} = do + debugTraceMsg logger 3 $ + hang (text "Decoding foreign data from iface:") 2 (ppr iff) + lang_paths <- for files $ \ IfaceForeignFile {lang, source, extension} -> do + f <- newTempName logger tmpfs tmp_dir TFL_GhcSession extension + writeFile f source + pure (lang, f) + pure (maybe NoStubs decode_stubs stubs, lang_paths) + where + decode_stubs IfaceCStubs {header, source, initializers, finalizers} = + ForeignStubs + (CHeader (text header)) + (CStub (text source) (labels initializers) (labels finalizers)) + + labels ls = [fromCStubLabel l | IfaceCLabel l <- ls] + +instance Binary IfaceForeign where + get bh = do + stubs <- get bh + files <- get bh + pure IfaceForeign {stubs, files} + + put_ bh IfaceForeign {stubs, files} = do + put_ bh stubs + put_ bh files + +instance NFData IfaceForeign where + rnf IfaceForeign {stubs, files} = rnf stubs `seq` rnf files diff --git a/GHC/Unit/Parser.hs b/GHC/Unit/Parser.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Parser.hs @@ -0,0 +1,58 @@ +-- | Parsers for unit/module identifiers +module GHC.Unit.Parser + ( parseUnit + , parseUnitId + , parseHoleyModule + , parseModSubst + ) +where + +import GHC.Prelude + +import GHC.Unit.Types +import GHC.Data.FastString + +import qualified Text.ParserCombinators.ReadP as Parse +import Text.ParserCombinators.ReadP (ReadP, (<++)) +import Data.Char (isAlphaNum) + +import Language.Haskell.Syntax.Module.Name (ModuleName, parseModuleName) + +parseUnit :: ReadP Unit +parseUnit = parseVirtUnitId <++ parseDefUnitId + where + parseVirtUnitId = do + uid <- parseUnitId + insts <- parseModSubst + return (mkVirtUnit uid insts) + parseDefUnitId = do + s <- parseUnitId + return (RealUnit (Definite s)) + +parseUnitId :: ReadP UnitId +parseUnitId = do + s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") + return (UnitId (mkFastString s)) + +parseHoleyModule :: ReadP Module +parseHoleyModule = parseModuleVar <++ parseModule + where + parseModuleVar = do + _ <- Parse.char '<' + modname <- parseModuleName + _ <- Parse.char '>' + return (Module HoleUnit modname) + parseModule = do + uid <- parseUnit + _ <- Parse.char ':' + modname <- parseModuleName + return (Module uid modname) + +parseModSubst :: ReadP [(ModuleName, Module)] +parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') + . flip Parse.sepBy (Parse.char ',') + $ do k <- parseModuleName + _ <- Parse.char '=' + v <- parseHoleyModule + return (k, v) + diff --git a/GHC/Unit/Ppr.hs b/GHC/Unit/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Ppr.hs @@ -0,0 +1,36 @@ +-- | Unit identifier pretty-printing +module GHC.Unit.Ppr + ( UnitPprInfo (..) + ) +where + +import GHC.Prelude +import GHC.Data.FastString +import GHC.Utils.Outputable +import Data.Version + +-- | Subset of UnitInfo: just enough to pretty-print a unit-id +-- +-- Instead of printing the unit-id which may contain a hash, we print: +-- package-version:componentname +-- +data UnitPprInfo = UnitPprInfo + { unitPprId :: FastString -- ^ Identifier + , unitPprPackageName :: String -- ^ Source package name + , unitPprPackageVersion :: Version -- ^ Source package version + , unitPprComponentName :: Maybe String -- ^ Component name + } + +instance Outputable UnitPprInfo where + ppr pprinfo = getPprDebug $ \debug -> + if debug + then ftext (unitPprId pprinfo) + else text $ mconcat + [ unitPprPackageName pprinfo + , case unitPprPackageVersion pprinfo of + Version [] [] -> "" + version -> "-" ++ showVersion version + , case unitPprComponentName pprinfo of + Nothing -> "" + Just cname -> ":" ++ cname + ] diff --git a/GHC/Unit/State.hs b/GHC/Unit/State.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/State.hs @@ -0,0 +1,2276 @@ +-- (c) The University of Glasgow, 2006 + +{-# LANGUAGE LambdaCase #-} + +-- | Unit manipulation +module GHC.Unit.State ( + module GHC.Unit.Info, + + -- * Reading the package config, and processing cmdline args + UnitState(..), + PreloadUnitClosure, + UnitDatabase (..), + UnitErr (..), + emptyUnitState, + initUnits, + readUnitDatabases, + readUnitDatabase, + getUnitDbRefs, + resolveUnitDatabase, + listUnitInfo, + + -- * Querying the package config + UnitInfoMap, + lookupUnit, + lookupUnit', + unsafeLookupUnit, + lookupUnitId, + lookupUnitId', + unsafeLookupUnitId, + + lookupPackageName, + resolvePackageImport, + improveUnit, + searchPackageId, + listVisibleModuleNames, + lookupModuleInAllUnits, + lookupModuleWithSuggestions, + lookupModulePackage, + lookupPluginModuleWithSuggestions, + requirementMerges, + LookupResult(..), + ModuleSuggestion(..), + ModuleOrigin(..), + UnusableUnit(..), + UnusableUnitReason(..), + pprReason, + + closeUnitDeps, + closeUnitDeps', + mayThrowUnitErr, + + -- * Module hole substitution + ShHoleSubst, + renameHoleUnit, + renameHoleModule, + renameHoleUnit', + renameHoleModule', + instUnitToUnit, + instModuleToModule, + + -- * Pretty-printing + pprFlag, + pprUnits, + pprUnitsSimple, + pprUnitIdForUser, + pprUnitInfoForUser, + pprModuleMap, + pprWithUnitState, + pprRawUnitIds, + + -- * Utils + unwireUnit) +where + +import GHC.Prelude + +import GHC.Driver.DynFlags + +import GHC.Platform +import GHC.Platform.Ways + +import GHC.Unit.Database +import GHC.Unit.Info +import GHC.Unit.Ppr +import GHC.Unit.Types +import GHC.Unit.Module +import GHC.Unit.Home + +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet +import GHC.Types.Unique.Map +import GHC.Types.Unique +import GHC.Types.PkgQual + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe + +import System.Environment ( getEnv ) +import GHC.Data.FastString +import qualified GHC.Data.ShortText as ST +import GHC.Utils.Logger +import GHC.Utils.Error +import GHC.Utils.Exception + +import System.Directory +import System.FilePath as FilePath +import Control.Monad +import Data.Graph (stronglyConnComp, SCC(..)) +import Data.Char ( toUpper ) +import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn ) +import Data.Set (Set) +import Data.Monoid (First(..)) +import qualified Data.Semigroup as Semigroup +import qualified Data.Set as Set +import Control.Applicative + +-- --------------------------------------------------------------------------- +-- The Unit state + +-- The unit state is computed by 'initUnits', and kept in HscEnv. +-- It is influenced by various command-line flags: +-- +-- * @-package \@ and @-package-id \@ cause @\@ to become exposed. +-- If @-hide-all-packages@ was not specified, these commands also cause +-- all other packages with the same name to become hidden. +-- +-- * @-hide-package \@ causes @\@ to become hidden. +-- +-- * (there are a few more flags, check below for their semantics) +-- +-- The unit state has the following properties. +-- +-- * Let @exposedUnits@ be the set of packages thus exposed. +-- Let @depExposedUnits@ be the transitive closure from @exposedUnits@ of +-- their dependencies. +-- +-- * When searching for a module from a preload import declaration, +-- only the exposed modules in @exposedUnits@ are valid. +-- +-- * When searching for a module from an implicit import, all modules +-- from @depExposedUnits@ are valid. +-- +-- * When linking in a compilation manager mode, we link in packages the +-- program depends on (the compiler knows this list by the +-- time it gets to the link step). Also, we link in all packages +-- which were mentioned with preload @-package@ flags on the command-line, +-- or are a transitive dependency of same, or are \"base\"\/\"rts\". +-- The reason for this is that we might need packages which don't +-- contain any Haskell modules, and therefore won't be discovered +-- by the normal mechanism of dependency tracking. + +-- Notes on DLLs +-- ~~~~~~~~~~~~~ +-- When compiling module A, which imports module B, we need to +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure +-- When compiling A, we record in B's Module value whether it's +-- in a different DLL, by setting the DLL flag. + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + + -- | Module is unavailable because the unit is unusable. + | ModUnusable !UnusableUnit + + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigUnit :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [UnitInfo] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [UnitInfo] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +-- | A unusable unit module origin +data UnusableUnit = UnusableUnit + { uuUnit :: !Unit -- ^ Unusable unit + , uuReason :: !UnusableUnitReason -- ^ Reason + , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModUnusable _) = text "unusable module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . mkUnit) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . mkUnit) res)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is exposed, and +-- also its 'UnitInfo'. +fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Semigroup ModuleOrigin where + x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + g Nothing x = x + g x Nothing = x + + x <> y = pprPanic "ModOrigin: module origin mismatch" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend = (Semigroup.<>) + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModUnusable _) = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False + +type PreloadUnitClosure = UniqSet UnitId + +-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. +type VisibilityMap = UniqMap Unit UnitVisibility + +-- | 'UnitVisibility' records the various aspects of visibility of a particular +-- 'Unit'. +data UnitVisibility = UnitVisibility + { uv_expose_all :: Bool + -- ^ Should all modules in exposed-modules should be dumped into scope? + , uv_renamings :: [(ModuleName, ModuleName)] + -- ^ Any custom renamings that should bring extra 'ModuleName's into + -- scope. + , uv_package_name :: First FastString + -- ^ The package name associated with the 'Unit'. This is used + -- to implement legacy behavior where @-package foo-0.1@ implicitly + -- hides any packages named @foo@ + , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) + -- ^ The signatures which are contributed to the requirements context + -- from this unit ID. + , uv_explicit :: Maybe PackageArg + -- ^ Whether or not this unit was explicitly brought into scope, + -- as opposed to implicitly via the 'exposed' fields in the + -- package database (when @-hide-all-packages@ is not passed.) + } + +instance Outputable UnitVisibility where + ppr (UnitVisibility { + uv_expose_all = b, + uv_renamings = rns, + uv_package_name = First mb_pn, + uv_requirements = reqs, + uv_explicit = explicit + }) = ppr (b, rns, mb_pn, reqs, explicit) + +instance Semigroup UnitVisibility where + uv1 <> uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) + , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 + } + +instance Monoid UnitVisibility where + mempty = UnitVisibility + { uv_expose_all = False + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = emptyUniqMap + , uv_explicit = Nothing + } + mappend = (Semigroup.<>) + + +-- | Unit configuration +data UnitConfig = UnitConfig + { unitConfigPlatformArchOS :: !ArchOS -- ^ Platform arch and OS + , unitConfigWays :: !Ways -- ^ Ways to use + + , unitConfigAllowVirtual :: !Bool -- ^ Allow virtual units + -- ^ Do we allow the use of virtual units instantiated on-the-fly (see + -- Note [About units] in GHC.Unit). This should only be true when we are + -- type-checking an indefinite unit (not producing any code). + + , unitConfigProgramName :: !String + -- ^ Name of the compiler (e.g. "GHC", "GHCJS"). Used to fetch environment + -- variables such as "GHC[JS]_PACKAGE_PATH". + + , unitConfigGlobalDB :: !FilePath -- ^ Path to global DB + , unitConfigGHCDir :: !FilePath -- ^ Main GHC dir: contains settings, etc. + , unitConfigDBName :: !String -- ^ User DB name (e.g. "package.conf.d") + + , unitConfigAutoLink :: ![UnitId] -- ^ Units to link automatically (e.g. base, rts) + , unitConfigDistrustAll :: !Bool -- ^ Distrust all units by default + , unitConfigHideAll :: !Bool -- ^ Hide all units by default + , unitConfigHideAllPlugins :: !Bool -- ^ Hide all plugins units by default + + , unitConfigDBCache :: Maybe [UnitDatabase UnitId] + -- ^ Cache of databases to use, in the order they were specified on the + -- command line (later databases shadow earlier ones). + -- If Nothing, databases will be found using `unitConfigFlagsDB`. + + -- command-line flags + , unitConfigFlagsDB :: [PackageDBFlag] -- ^ Unit databases flags + , unitConfigFlagsExposed :: [PackageFlag] -- ^ Exposed units + , unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units + , unitConfigFlagsTrusted :: [TrustFlag] -- ^ Trusted units + , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units + , unitConfigHomeUnits :: Set.Set UnitId + } + +initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig +initUnitConfig dflags cached_dbs home_units = + let !hu_id = homeUnitId_ dflags + !hu_instanceof = homeUnitInstanceOf_ dflags + !hu_instantiations = homeUnitInstantiations_ dflags + + autoLink + | not (gopt Opt_AutoLinkPackages dflags) = [] + -- By default we add base, ghc-internal and rts to the preload units (when they are + -- found in the unit database) except when we are building them + -- + -- Since "base" is not wired in, then the unit-id is discovered + -- from the settings file by default, but can be overriden by power-users + -- by specifying `-base-unit-id` flag. + | otherwise = filter (hu_id /=) [baseUnitId dflags, ghcInternalUnitId, rtsUnitId] + + -- if the home unit is indefinite, it means we are type-checking it only + -- (not producing any code). Hence we can use virtual units instantiated + -- on-the-fly. See Note [About units] in GHC.Unit + allow_virtual_units = case (hu_instanceof, hu_instantiations) of + (Just u, is) -> u == hu_id && any (isHoleModule . snd) is + _ -> False + + in UnitConfig + { unitConfigPlatformArchOS = platformArchOS (targetPlatform dflags) + , unitConfigProgramName = programName dflags + , unitConfigWays = ways dflags + , unitConfigAllowVirtual = allow_virtual_units + + , unitConfigGlobalDB = globalPackageDatabasePath dflags + , unitConfigGHCDir = topDir dflags + , unitConfigDBName = "package.conf.d" + + , unitConfigAutoLink = autoLink + , unitConfigDistrustAll = gopt Opt_DistrustAllPackages dflags + , unitConfigHideAll = gopt Opt_HideAllPackages dflags + , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags + + , unitConfigDBCache = cached_dbs + , unitConfigFlagsDB = map (offsetPackageDb (workingDirectory dflags)) $ packageDBFlags dflags + , unitConfigFlagsExposed = packageFlags dflags + , unitConfigFlagsIgnored = ignorePackageFlags dflags + , unitConfigFlagsTrusted = trustFlags dflags + , unitConfigFlagsPlugins = pluginPackageFlags dflags + , unitConfigHomeUnits = home_units + + } + + where + offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag + offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | isRelative p = PackageDB (PkgDbPath (offset p)) + offsetPackageDb _ p = p + + +-- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and +-- its 'ModuleOrigin'). +-- +-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one +-- origin for a given 'Module' + +type ModuleNameProvidersMap = + UniqMap ModuleName (UniqMap Module ModuleOrigin) + +data UnitState = UnitState { + -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted + -- so that only valid units are here. 'UnitInfo' reflects + -- what was stored *on disk*, except for the 'trusted' flag, which + -- is adjusted at runtime. (In particular, some units in this map + -- may have the 'exposed' flag be 'False'.) + unitInfoMap :: UnitInfoMap, + + -- | The set of transitively reachable units according + -- to the explicitly provided command line arguments. + -- A fully instantiated VirtUnit may only be replaced by a RealUnit from + -- this set. + -- See Note [VirtUnit to RealUnit improvement] + preloadClosure :: PreloadUnitClosure, + + -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same + -- package name (e.g. different instantiations), then we return one of them... + -- This is used when users refer to packages in Backpack includes. + -- And also to resolve package qualifiers with the PackageImports extension. + packageNameMap :: UniqFM PackageName UnitId, + + -- | A mapping from database unit keys to wired in unit ids. + wireMap :: UniqMap UnitId UnitId, + + -- | A mapping from wired in unit ids to unit keys from the database. + unwireMap :: UniqMap UnitId UnitId, + + -- | The units we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a unit + -- is always mentioned before the units it depends on. + preloadUnits :: [UnitId], + + -- | Units which we explicitly depend on (from a command line flag). + -- We'll use this to generate version macros and the unused packages warning. The + -- original flag which was used to bring the unit into scope is recorded for the + -- -Wunused-packages warning. + explicitUnits :: [(Unit, Maybe PackageArg)], + + homeUnitDepends :: [UnitId], + + -- | This is a full map from 'ModuleName' to all modules which may possibly + -- be providing it. These providers may be hidden (but we'll still want + -- to report them in error messages), or it may be an ambiguous import. + moduleNameProvidersMap :: !ModuleNameProvidersMap, + + -- | A map, like 'moduleNameProvidersMap', but controlling plugin visibility. + pluginModuleNameProvidersMap :: !ModuleNameProvidersMap, + + -- | A map saying, for each requirement, what interfaces must be merged + -- together when we use them. For example, if our dependencies + -- are @p[A=\]@ and @q[A=\,B=r[C=\]:B]@, then the interfaces + -- to merge for A are @p[A=\]:A@, @q[A=\,B=r[C=\]:B]:A@ + -- and @r[C=\]:C@. + -- + -- There's an entry in this map for each hole in our home library. + requirementContext :: UniqMap ModuleName [InstantiatedModule], + + -- | Indicate if we can instantiate units on-the-fly. + -- + -- This should only be true when we are type-checking an indefinite unit. + -- See Note [About units] in GHC.Unit. + allowVirtualUnits :: !Bool + } + +emptyUnitState :: UnitState +emptyUnitState = UnitState { + unitInfoMap = emptyUniqMap, + preloadClosure = emptyUniqSet, + packageNameMap = emptyUFM, + wireMap = emptyUniqMap, + unwireMap = emptyUniqMap, + preloadUnits = [], + explicitUnits = [], + homeUnitDepends = [], + moduleNameProvidersMap = emptyUniqMap, + pluginModuleNameProvidersMap = emptyUniqMap, + requirementContext = emptyUniqMap, + allowVirtualUnits = False + } + +-- | Unit database +data UnitDatabase unit = UnitDatabase + { unitDatabasePath :: FilePath + , unitDatabaseUnits :: [GenUnitInfo unit] + } + +instance Outputable u => Outputable (UnitDatabase u) where + ppr (UnitDatabase fp _u) = text "DB:" <+> text fp + +type UnitInfoMap = UniqMap UnitId UnitInfo + +-- | Find the unit we know about with the given unit, if any +lookupUnit :: UnitState -> Unit -> Maybe UnitInfo +lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) (preloadClosure pkgs) + +-- | A more specialized interface, which doesn't require a 'UnitState' (so it +-- can be used while we're initializing 'DynFlags') +-- +-- Parameters: +-- * a boolean specifying whether or not to look for on-the-fly renamed interfaces +-- * a 'UnitInfoMap' +-- * a 'PreloadUnitClosure' +lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo +lookupUnit' allowOnTheFlyInst pkg_map closure u = case u of + HoleUnit -> error "Hole unit" + RealUnit i -> lookupUniqMap pkg_map (unDefinite i) + VirtUnit i + | allowOnTheFlyInst + -> -- lookup UnitInfo of the indefinite unit to be instantiated and + -- instantiate it on-the-fly + fmap (renameUnitInfo pkg_map closure (instUnitInsts i)) + (lookupUniqMap pkg_map (instUnitInstanceOf i)) + + | otherwise + -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite + -- units. Even if they are real, installed units, they can't use the + -- `RealUnit` constructor (it is reserved for definite units) so we use + -- the `VirtUnit` constructor. + lookupUniqMap pkg_map (virtualUnitId i) + +-- | Find the unit we know about with the given unit id, if any +lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo +lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid + +-- | Find the unit we know about with the given unit id, if any +lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo +lookupUnitId' db uid = lookupUniqMap db uid + + +-- | Looks up the given unit in the unit state, panicking if it is not found +unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo +unsafeLookupUnit state u = case lookupUnit state u of + Just info -> info + Nothing -> pprPanic "unsafeLookupUnit" (ppr u) + +-- | Looks up the given unit id in the unit state, panicking if it is not found +unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo +unsafeLookupUnitId state uid = case lookupUnitId state uid of + Just info -> info + Nothing -> pprPanic "unsafeLookupUnitId" (ppr uid) + + +-- | Find the unit we know about with the given package name (e.g. @foo@), if any +-- (NB: there might be a locally defined unit name which overrides this) +-- This function is unsafe to use in general because it doesn't respect package +-- visibility. +lookupPackageName :: UnitState -> PackageName -> Maybe UnitId +lookupPackageName pkgstate n = lookupUFM (packageNameMap pkgstate) n + +-- | Search for units with a given package ID (e.g. \"foo-0.1\") +searchPackageId :: UnitState -> PackageId -> [UnitInfo] +searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId) + (listUnitInfo pkgstate) + +-- | Find the UnitId which an import qualified by a package import comes from. +-- Compared to 'lookupPackageName', this function correctly accounts for visibility, +-- renaming and thinning. +resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId +resolvePackageImport unit_st mn pn = do + -- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc) + providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn + -- 2. Get the UnitIds of the candidates + let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers + -- 3. Get the package names of the candidates + let candidates_units = map (\ui -> ((unitPackageName ui), unitId ui)) + $ mapMaybe (\uid -> lookupUniqMap (unitInfoMap unit_st) uid) candidates_uid + -- 4. Check to see if the PackageName helps us disambiguate any candidates. + lookup pn candidates_units + + where + + -- Get the UnitId from which a visible identifier is from + to_uid :: (Module, ModuleOrigin) -> [UnitId] + to_uid (mod, ModOrigin mo re_exps _ _) = + case mo of + -- Available directly, but also potentially from re-exports + Just True -> (toUnitId (moduleUnit mod)) : map unitId re_exps + -- Just available from these re-exports + _ -> map unitId re_exps + to_uid _ = [] + +-- | Create a Map UnitId UnitInfo +-- +-- For each instantiated unit, we add two map keys: +-- * the real unit id +-- * the virtual unit id made from its instantiation +-- +-- We do the same thing for fully indefinite units (which are "instantiated" +-- with module holes). +-- +mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap +mkUnitInfoMap infos = foldl' add emptyUniqMap infos + where + mkVirt p = virtualUnitId (mkInstantiatedUnit (unitInstanceOf p) (unitInstantiations p)) + add pkg_map p + | not (null (unitInstantiations p)) + = addToUniqMap (addToUniqMap pkg_map (mkVirt p) p) + (unitId p) p + | otherwise + = addToUniqMap pkg_map (unitId p) p + +-- | Get a list of entries from the unit database. NB: be careful with +-- this function, although all units in this map are "visible", this +-- does not imply that the exposed-modules of the unit are available +-- (they may have been thinned or renamed). +listUnitInfo :: UnitState -> [UnitInfo] +listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) + +-- ---------------------------------------------------------------------------- +-- Loading the unit db files and building up the unit state + +-- | Read the unit database files, and sets up various internal tables of +-- unit information, according to the unit-related flags on the +-- command-line (@-package@, @-hide-package@ etc.) +-- +-- 'initUnits' can be called again subsequently after updating the +-- 'packageFlags' field of the 'DynFlags', and it will update the +-- 'unitState' in 'DynFlags'. +initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) +initUnits logger dflags cached_dbs home_units = do + + let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () + + (unit_state,dbs) <- withTiming logger (text "initializing unit database") + forceUnitInfoMap + $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units) + + putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map" + FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) + $ pprModuleMap (moduleNameProvidersMap unit_state)) + + let home_unit = mkHomeUnit unit_state + (homeUnitId_ dflags) + (homeUnitInstanceOf_ dflags) + (homeUnitInstantiations_ dflags) + + -- Try to find platform constants + -- + -- See Note [Platform constants] in GHC.Platform + mconstants <- if homeUnitId_ dflags == rtsUnitId + then do + -- we're building the RTS! Lookup DerivedConstants.h in the include paths + lookupPlatformConstants (includePathsGlobal (includePaths dflags)) + else + -- lookup the DerivedConstants.h header bundled with the RTS unit. We + -- don't fail if we can't find the RTS unit as it can be a valid (but + -- uncommon) case, e.g. building a C utility program (not depending on the + -- RTS) before building the RTS. In any case, we will fail later on if we + -- really need to use the platform constants but they have not been loaded. + case lookupUnitId unit_state rtsUnitId of + Nothing -> return Nothing + Just info -> lookupPlatformConstants (fmap ST.unpack (unitIncludeDirs info)) + + return (dbs,unit_state,home_unit,mconstants) + +mkHomeUnit + :: UnitState + -> UnitId -- ^ Home unit id + -> Maybe UnitId -- ^ Home unit instance of + -> [(ModuleName, Module)] -- ^ Home unit instantiations + -> HomeUnit +mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ = + let + -- Some wired units can be used to instantiate the home unit. We need to + -- replace their unit keys with their wired unit ids. + wmap = wireMap unit_state + hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_ + in case (hu_instanceof, hu_instantiations) of + (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing + (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") + (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with") + (Just u, is) + -- detect fully indefinite units: all their instantiations are hole + -- modules and the home unit id is the same as the instantiating unit + -- id (see Note [About units] in GHC.Unit) + | all (isHoleModule . snd) is && u == hu_id + -> IndefiniteHomeUnit u is + -- otherwise it must be that we (fully) instantiate an indefinite unit + -- to make it definite. + -- TODO: error when the unit is partially instantiated?? + | otherwise + -> DefiniteHomeUnit hu_id (Just (u, is)) + +-- ----------------------------------------------------------------------------- +-- Reading the unit database(s) + +readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId] +readUnitDatabases logger cfg = do + conf_refs <- getUnitDbRefs cfg + confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs + mapM (readUnitDatabase logger cfg) confs + + +getUnitDbRefs :: UnitConfig -> IO [PkgDbRef] +getUnitDbRefs cfg = do + let system_conf_refs = [UserPkgDb, GlobalPkgDb] + + e_pkg_path <- tryIO (getEnv $ map toUpper (unitConfigProgramName cfg) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | Just (xs, x) <- snocView path, isSearchPathSeparator x + -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs + | otherwise + -> map PkgDbPath (splitSearchPath path) + + -- Apply the package DB-related flags from the command line to get the + -- final list of package DBs. + -- + -- Notes on ordering: + -- * The list of flags is reversed (later ones first) + -- * We work with the package DB list in "left shadows right" order + -- * and finally reverse it at the end, to get "right shadows left" + -- + return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg)) + where + doFlag (PackageDB p) dbs = p : dbs + doFlag NoUserPackageDB dbs = filter isNotUser dbs + doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs + doFlag ClearPackageDBs _ = [] + + isNotUser UserPkgDb = False + isNotUser _ = True + + isNotGlobal GlobalPkgDb = False + isNotGlobal _ = True + +-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' +-- when the user database filepath is expected but the latter doesn't exist. +-- +-- NB: This logic is reimplemented in Cabal, so if you change it, +-- make sure you update Cabal. (Or, better yet, dump it in the +-- compiler info so Cabal can use the info.) +resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath) +resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg) +resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do + dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg) + let pkgconf = dir unitConfigDBName cfg + exist <- tryMaybeT $ doesDirectoryExist pkgconf + if exist then return pkgconf else mzero +resolveUnitDatabase _ (PkgDbPath name) = return $ Just name + +readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId) +readUnitDatabase logger cfg conf_file = do + isdir <- doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then readDirStyleUnitInfo conf_file + else do + isfile <- doesFileExist conf_file + if isfile + then do + mpkgs <- tryReadOldFileStyleUnitInfo + case mpkgs of + Just pkgs -> return pkgs + Nothing -> throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ conf_file + + let + -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot + conf_file' = dropTrailingPathSeparator conf_file + top_dir = unitConfigGHCDir cfg + pkgroot = takeDirectory conf_file' + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) + proto_pkg_configs + -- + return $ UnitDatabase conf_file' pkg_configs1 + where + readDirStyleUnitInfo conf_dir = do + let filename = conf_dir "package.cache" + cache_exists <- doesFileExist filename + if cache_exists + then do + debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename + readPackageDbForGhc filename + else do + -- If there is no package.cache file, we check if the database is not + -- empty by inspecting if the directory contains any .conf file. If it + -- does, something is wrong and we fail. Otherwise we assume that the + -- database is empty. + debugTraceMsg logger 2 $ text "There is no package.cache in" + <+> text conf_dir + <> text ", checking if the database is empty" + db_empty <- all (not . isSuffixOf ".conf") + <$> getDirectoryContents conf_dir + if db_empty + then do + debugTraceMsg logger 3 $ text "There are no .conf files in" + <+> text conf_dir <> text ", treating" + <+> text "package database as empty" + return [] + else + throwGhcExceptionIO $ InstallationError $ + "there is no package.cache in " ++ conf_dir ++ + " even though package database is not empty" + + + -- Single-file style package dbs have been deprecated for some time, but + -- it turns out that Cabal was using them in one place. So this is a + -- workaround to allow older Cabal versions to use this newer ghc. + -- We check if the file db contains just "[]" and if so, we look for a new + -- dir-style db in conf_file.d/, ie in a dir next to the given file. + -- We cannot just replace the file with a new dir style since Cabal still + -- assumes it's a file and tries to overwrite with 'writeFile'. + -- ghc-pkg also cooperates with this workaround. + tryReadOldFileStyleUnitInfo = do + content <- readFile conf_file `catchIO` \_ -> return "" + if take 2 content == "[]" + then do + let conf_dir = conf_file <.> "d" + direxists <- doesDirectoryExist conf_dir + if direxists + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) + liftM Just (readDirStyleUnitInfo conf_dir) + else return (Just []) -- ghc-pkg will create it when it's updated + else return Nothing + +distrustAllUnits :: [UnitInfo] -> [UnitInfo] +distrustAllUnits pkgs = map distrust pkgs + where + distrust pkg = pkg{ unitIsTrusted = False } + +mungeUnitInfo :: FilePath -> FilePath + -> UnitInfo -> UnitInfo +mungeUnitInfo top_dir pkgroot = + mungeDynLibFields + . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot) + +mungeDynLibFields :: UnitInfo -> UnitInfo +mungeDynLibFields pkg = + pkg { + unitLibraryDynDirs = case unitLibraryDynDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + +-- ----------------------------------------------------------------------------- +-- Modify our copy of the unit database based on trust flags, +-- -trust and -distrust. + +applyTrustFlag + :: UnitPrecedenceMap + -> UnusableUnits + -> [UnitInfo] + -> TrustFlag + -> MaybeErr UnitErr [UnitInfo] +applyTrustFlag prec_map unusable pkgs flag = + case flag of + -- we trust all matching packages. Maybe should only trust first one? + -- and leave others the same or set them untrusted + TrustPackage str -> + case selectPackages prec_map (PackageArg str) pkgs unusable of + Left ps -> Failed (TrustFlagErr flag ps) + Right (ps,qs) -> Succeeded (map trust ps ++ qs) + where trust p = p {unitIsTrusted=True} + + DistrustPackage str -> + case selectPackages prec_map (PackageArg str) pkgs unusable of + Left ps -> Failed (TrustFlagErr flag ps) + Right (ps,qs) -> Succeeded (distrustAllUnits ps ++ qs) + +applyPackageFlag + :: UnitPrecedenceMap + -> UnitInfoMap + -> PreloadUnitClosure + -> UnusableUnits + -> Bool -- if False, if you expose a package, it implicitly hides + -- any previously exposed packages with the same name + -> [UnitInfo] + -> VisibilityMap -- Initially exposed + -> PackageFlag -- flag to apply + -> MaybeErr UnitErr VisibilityMap -- Now exposed + +applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag = + case flag of + ExposePackage _ arg (ModRenaming b rns) -> + case findPackages prec_map pkg_map closure arg pkgs unusable of + Left ps -> Failed (PackageFlagErr flag ps) + Right (p:_) -> Succeeded vm' + where + n = fsPackageName p + + -- If a user says @-unit-id p[A=]@, this imposes + -- a requirement on us: whatever our signature A is, + -- it must fulfill all of p[A=]:A's requirements. + -- This method is responsible for computing what our + -- inherited requirements are. + reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid + | otherwise = emptyUniqMap + + collectHoles uid = case uid of + HoleUnit -> emptyUniqMap + RealUnit {} -> emptyUniqMap -- definite units don't have holes + VirtUnit indef -> + let local = [ unitUniqMap + (moduleName mod) + (Set.singleton $ Module indef mod_name) + | (mod_name, mod) <- instUnitInsts indef + , isHoleModule mod ] + recurse = [ collectHoles (moduleUnit mod) + | (_, mod) <- instUnitInsts indef ] + in plusUniqMapListWith Set.union $ local ++ recurse + + uv = UnitVisibility + { uv_expose_all = b + , uv_renamings = rns + , uv_package_name = First (Just n) + , uv_requirements = reqs + , uv_explicit = Just arg + } + vm' = addToUniqMap_C mappend vm_cleared (mkUnit p) uv + -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` + -- (or if p-0.1 was registered in the pkgdb as exposed: True), + -- the second package flag would override the first one and you + -- would only see p-0.2 in exposed modules. This is good for + -- usability. + -- + -- However, with thinning and renaming (or Backpack), there might be + -- situations where you legitimately want to see two versions of a + -- package at the same time, and this behavior would make it + -- impossible to do so. So we decided that if you pass + -- -hide-all-packages, this should turn OFF the overriding behavior + -- where an exposed package hides all other packages with the same + -- name. This should not affect Cabal at all, which only ever + -- exposes one package at a time. + -- + -- NB: Why a variable no_hide_others? We have to apply this logic to + -- -plugin-package too, and it's more consistent if the switch in + -- behavior is based off of + -- -hide-all-packages/-hide-all-plugin-packages depending on what + -- flag is in question. + vm_cleared | no_hide_others = vm + -- NB: renamings never clear + | (_:_) <- rns = vm + | otherwise = filterWithKeyUniqMap + (\k uv -> k == mkUnit p + || First (Just n) /= uv_package_name uv) vm + _ -> panic "applyPackageFlag" + + HidePackage str -> + case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of + Left ps -> Failed (PackageFlagErr flag ps) + Right ps -> Succeeded $ foldl' delFromUniqMap vm (map mkUnit ps) + +-- | Like 'selectPackages', but doesn't return a list of unmatched +-- packages. Furthermore, any packages it returns are *renamed* +-- if the 'UnitArg' has a renaming associated with it. +findPackages :: UnitPrecedenceMap + -> UnitInfoMap + -> PreloadUnitClosure + -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + [UnitInfo] +findPackages prec_map pkg_map closure arg pkgs unusable + = let ps = mapMaybe (finder arg) pkgs + in if null ps + then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) + (nonDetEltsUniqMap unusable)) + else Right (sortByPreference prec_map ps) + where + finder (PackageArg str) p + = if matchingStr str p + then Just p + else Nothing + finder (UnitIdArg uid) p + = case uid of + RealUnit (Definite iuid) + | iuid == unitId p + -> Just p + VirtUnit inst + | instUnitInstanceOf inst == unitId p + -> Just (renameUnitInfo pkg_map closure (instUnitInsts inst) p) + _ -> Nothing + +selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + ([UnitInfo], [UnitInfo]) +selectPackages prec_map arg pkgs unusable + = let matches = matching arg + (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (nonDetEltsUniqMap unusable)) + else Right (sortByPreference prec_map ps, rest) + +-- | Rename a 'UnitInfo' according to some module instantiation. +renameUnitInfo :: UnitInfoMap -> PreloadUnitClosure -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo +renameUnitInfo pkg_map closure insts conf = + let hsubst = listToUFM insts + smod = renameHoleModule' pkg_map closure hsubst + new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) + in conf { + unitInstantiations = new_insts, + unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) + (unitExposedModules conf) + } + + +-- A package named on the command line can either include the +-- version, or just the name if it is unambiguous. +matchingStr :: String -> UnitInfo -> Bool +matchingStr str p + = str == unitPackageIdString p + || str == unitPackageNameString p + +matchingId :: UnitId -> UnitInfo -> Bool +matchingId uid p = uid == unitId p + +matching :: PackageArg -> UnitInfo -> Bool +matching (PackageArg str) = matchingStr str +matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid +matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case + +-- | This sorts a list of packages, putting "preferred" packages first. +-- See 'compareByPreference' for the semantics of "preference". +sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) + +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking +-- which should be "active". Here is the order of preference: +-- +-- 1. First, prefer the latest version +-- 2. If the versions are the same, prefer the package that +-- came in the latest package database. +-- +-- Pursuant to #12518, we could change this policy to, for example, remove +-- the version preference, meaning that we would always prefer the units +-- in later unit database. +compareByPreference + :: UnitPrecedenceMap + -> UnitInfo + -> UnitInfo + -> Ordering +compareByPreference prec_map pkg pkg' + = case comparing unitPackageVersion pkg pkg' of + GT -> GT + EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) + , Just prec' <- lookupUniqMap prec_map (unitId pkg') + -- Prefer the unit from the later DB flag (i.e., higher + -- precedence) + -> compare prec prec' + | otherwise + -> EQ + LT -> LT + +comparing :: Ord a => (t -> a) -> t -> t -> Ordering +comparing f a b = f a `compare` f b + +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + HidePackage p -> text "-hide-package " <> text p + ExposePackage doc _ _ -> text doc + +pprTrustFlag :: TrustFlag -> SDoc +pprTrustFlag flag = case flag of + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +type WiringMap = UniqMap UnitId UnitId + +findWiredInUnits + :: Logger + -> UnitPrecedenceMap + -> [UnitInfo] -- database + -> VisibilityMap -- info on what units are visible + -- for wired in selection + -> IO ([UnitInfo], -- unit database updated for wired in + WiringMap) -- map from unit id to wired identity + +findWiredInUnits logger prec_map pkgs vis_map = do + -- Now we must find our wired-in units, and rename them to + -- their canonical names (eg. base-1.0 ==> base), as described + -- in Note [Wired-in units] in GHC.Unit.Types + let + matches :: UnitInfo -> UnitId -> Bool + pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) + findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] + where + all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] + + try ps = case sortByPreference prec_map ps of + p:_ -> Just <$> pick p + _ -> pure Nothing + + notfound = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " not found." + return Nothing + pick :: UnitInfo -> IO (UnitId, UnitInfo) + pick pkg = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " mapped to " + <> ppr (unitId pkg) + return (wired_pkg, pkg) + + + mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + + wiredInMap :: UniqMap UnitId UnitId + wiredInMap = listToUniqMap + [ (unitId realUnitInfo, wiredInUnitId) + | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs + , not (unitIsIndefinite realUnitInfo) + ] + + updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs + where upd_pkg pkg + | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg) + = pkg { unitId = wiredInUnitId + , unitInstanceOf = wiredInUnitId + -- every non instantiated unit is an instance of + -- itself (required by Backpack...) + -- + -- See Note [About units] in GHC.Unit + } + | otherwise + = pkg + upd_deps pkg = pkg { + unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), + unitExposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (unitExposedModules pkg) + } + + + return (updateWiredInDependencies pkgs, wiredInMap) + +-- Helper functions for rewiring Module and Unit. These +-- rewrite Units of modules in wired-in packages to the form known to the +-- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. +-- +-- For instance, base-4.9.0.0 will be rewritten to just base, to match +-- what appears in GHC.Builtin.Names. + +upd_wired_in_mod :: WiringMap -> Module -> Module +upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WiringMap -> Unit -> Unit +upd_wired_in_uid wiredInMap u = case u of + HoleUnit -> HoleUnit + RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) + VirtUnit indef_uid -> + VirtUnit $ mkInstantiatedUnit + (instUnitInstanceOf indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) + +upd_wired_in :: WiringMap -> UnitId -> UnitId +upd_wired_in wiredInMap key + | Just key' <- lookupUniqMap wiredInMap key = key' + | otherwise = key + +updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap +updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList wiredInMap) + where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of + Nothing -> vm + Just r -> addToUniqMap (delFromUniqMap vm (RealUnit (Definite from))) + (RealUnit (Definite to)) r + + -- ---------------------------------------------------------------------------- + +-- | The reason why a unit is unusable. +data UnusableUnitReason + = -- | We ignored it explicitly using @-ignore-package@. + IgnoredWithFlag + -- | This unit transitively depends on a unit that was never present + -- in any of the provided databases. + | BrokenDependencies [UnitId] + -- | This unit transitively depends on a unit involved in a cycle. + -- Note that the list of 'UnitId' reports the direct dependencies + -- of this unit that (transitively) depended on the cycle, and not + -- the actual cycle itself (which we report separately at high verbosity.) + | CyclicDependencies [UnitId] + -- | This unit transitively depends on a unit which was ignored. + | IgnoredDependencies [UnitId] + -- | This unit transitively depends on a unit which was + -- shadowed by an ABI-incompatible unit. + | ShadowedDependencies [UnitId] + +instance Outputable UnusableUnitReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) + ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) + ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) + ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) + +type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) + +pprReason :: SDoc -> UnusableUnitReason -> SDoc +pprReason pref reason = case reason of + IgnoredWithFlag -> + pref <+> text "ignored due to an -ignore-package flag" + BrokenDependencies deps -> + pref <+> text "unusable due to missing dependencies:" $$ + nest 2 (hsep (map ppr deps)) + CyclicDependencies deps -> + pref <+> text "unusable due to cyclic dependencies:" $$ + nest 2 (hsep (map ppr deps)) + IgnoredDependencies deps -> + pref <+> text ("unusable because the -ignore-package flag was used to " ++ + "ignore at least one of its dependencies:") $$ + nest 2 (hsep (map ppr deps)) + ShadowedDependencies deps -> + pref <+> text "unusable due to shadowed dependencies:" $$ + nest 2 (hsep (map ppr deps)) + +reportCycles :: Logger -> [SCC UnitInfo] -> IO () +reportCycles logger sccs = mapM_ report sccs + where + report (AcyclicSCC _) = return () + report (CyclicSCC vs) = + debugTraceMsg logger 2 $ + text "these packages are involved in a cycle:" $$ + nest 2 (hsep (map (ppr . unitId) vs)) + +reportUnusable :: Logger -> UnusableUnits -> IO () +reportUnusable logger pkgs = mapM_ report (nonDetUniqMapToList pkgs) + where + report (ipid, (_, reason)) = + debugTraceMsg logger 2 $ + pprReason + (text "package" <+> ppr ipid <+> text "is") reason + +-- ---------------------------------------------------------------------------- +-- +-- Utilities on the database +-- + +-- | A reverse dependency index, mapping an 'UnitId' to +-- the 'UnitId's which have a dependency on it. +type RevIndex = UniqMap UnitId [UnitId] + +-- | Compute the reverse dependency index of a unit database. +reverseDeps :: UnitInfoMap -> RevIndex +reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db + where + go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex + go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) + go' from r to = addToUniqMap_C (++) r to [from] + +-- | Given a list of 'UnitId's to remove, a database, +-- and a reverse dependency index (as computed by 'reverseDeps'), +-- remove those units, plus any units which depend on them. +-- Returns the pruned database, as well as a list of 'UnitInfo's +-- that was removed. +removeUnits :: [UnitId] -> RevIndex + -> UnitInfoMap + -> (UnitInfoMap, [UnitInfo]) +removeUnits uids index m = go uids (m,[]) + where + go [] (m,pkgs) = (m,pkgs) + go (uid:uids) (m,pkgs) + | Just pkg <- lookupUniqMap m uid + = case lookupUniqMap index uid of + Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) + Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) + | otherwise + = go uids (m,pkgs) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' +-- which correspond to units that do not exist in the index. +depsNotAvailable :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in +-- 'unitAbiDepends' which correspond to units that do not exist, OR have +-- mismatching ABIs. +depsAbiMismatch :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg + where + abiMatch (dep_uid, abi) + | Just dep_pkg <- lookupUniqMap pkg_map dep_uid + = unitAbiHash dep_pkg == abi + | otherwise + = False + +-- ----------------------------------------------------------------------------- +-- Ignore units + +ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits +ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) + where + doit (IgnorePackage str) = + case partition (matchingStr str) pkgs of + (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) + | p <- ps ] + -- missing unit is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + +-- ---------------------------------------------------------------------------- +-- +-- Merging databases +-- + +-- | For each unit, a mapping from uid -> i indicates that this +-- unit was brought into GHC by the ith @-package-db@ flag on +-- the command line. We use this mapping to make sure we prefer +-- units that were defined later on the command line, if there +-- is an ambiguity. +type UnitPrecedenceMap = UniqMap UnitId Int + +-- | Given a list of databases, merge them together, where +-- units with the same unit id in later databases override +-- earlier ones. This does NOT check if the resulting database +-- makes sense (that's done by 'validateDatabase'). +mergeDatabases :: Logger -> [UnitDatabase UnitId] + -> IO (UnitInfoMap, UnitPrecedenceMap) +mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] + where + merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do + debugTraceMsg logger 2 $ + text "loading package database" <+> text db_path + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg logger 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" + return (pkg_map', prec_map') + where + db_map = mk_pkg_map db + mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) + + -- The set of UnitIds which appear in both db and pkgs. These are the + -- ones that get overridden. Compute this just to give some + -- helpful debug messages at -v2 + override_set :: Set UnitId + override_set = Set.intersection (nonDetUniqMapToKeySet db_map) + (nonDetUniqMapToKeySet pkg_map) + + -- Now merge the sets together (NB: in case of duplicate, + -- first argument preferred) + pkg_map' :: UnitInfoMap + pkg_map' = pkg_map `plusUniqMap` db_map + + prec_map' :: UnitPrecedenceMap + prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) + +-- | Validates a database, removing unusable units from it +-- (this includes removing units that the user has explicitly +-- ignored.) Our general strategy: +-- +-- 1. Remove all broken units (dangling dependencies) +-- 2. Remove all units that are cyclic +-- 3. Apply ignore flags +-- 4. Remove all units which have deps with mismatching ABIs +-- +validateDatabase :: UnitConfig -> UnitInfoMap + -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) +validateDatabase cfg pkg_map1 = + (pkg_map5, unusable, sccs) + where + ignore_flags = reverse (unitConfigFlagsIgnored cfg) + + -- Compute the reverse dependency index + index = reverseDeps pkg_map1 + + -- Helper function + mk_unusable mk_err dep_matcher m uids = + listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) + | pkg <- uids + ] + + -- Find broken units + directly_broken = filter (not . null . depsNotAvailable pkg_map1) + (nonDetEltsUniqMap pkg_map1) + (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 + unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken + + -- Find recursive units + sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) + | pkg <- nonDetEltsUniqMap pkg_map2 ] + getCyclicSCC (CyclicSCC vs) = map unitId vs + getCyclicSCC (AcyclicSCC _) = [] + (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 + unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic + + -- Apply ignore flags + directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) + (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 + unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored + + -- Knock out units whose dependencies don't agree with ABI + -- (i.e., got invalidated due to shadowing) + directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) + (nonDetEltsUniqMap pkg_map4) + (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 + unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed + + -- combine all unusables. The order is important for shadowing. + -- plusUniqMapList folds using plusUFM which is right biased (opposite of + -- Data.Map.union) so the head of the list should be the least preferred + unusable = plusUniqMapList [ unusable_shadowed + , unusable_cyclic + , unusable_broken + , unusable_ignored + , directly_ignored + ] + +-- ----------------------------------------------------------------------------- +-- When all the command-line options are in, we can process our unit +-- settings and populate the unit state. + +mkUnitState + :: Logger + -> UnitConfig + -> IO (UnitState,[UnitDatabase UnitId]) +mkUnitState logger cfg = do +{- + Plan. + + There are two main steps for making the package state: + + 1. We want to build a single, unified package database based + on all of the input databases, which upholds the invariant that + there is only one package per any UnitId and there are no + dangling dependencies. We'll do this by merging, and + then successively filtering out bad dependencies. + + a) Merge all the databases together. + If an input database defines unit ID that is already in + the unified database, that package SHADOWS the existing + package in the current unified database. Note that + order is important: packages defined later in the list of + command line arguments shadow those defined earlier. + + b) Remove all packages with missing dependencies, or + mutually recursive dependencies. + + b) Remove packages selected by -ignore-package from input database + + c) Remove all packages which depended on packages that are now + shadowed by an ABI-incompatible package + + d) report (with -v) any packages that were removed by steps 1-3 + + 2. We want to look at the flags controlling package visibility, + and build a mapping of what module names are in scope and + where they live. + + a) on the final, unified database, we apply -trust/-distrust + flags directly, modifying the database so that the 'trusted' + field has the correct value. + + b) we use the -package/-hide-package flags to compute a + visibility map, stating what packages are "exposed" for + the purposes of computing the module map. + * if any flag refers to a package which was removed by 1-5, then + we can give an error message explaining why + * if -hide-all-packages was not specified, this step also + hides packages which are superseded by later exposed packages + * this step is done TWICE if -plugin-package/-hide-all-plugin-packages + are used + + c) based on the visibility map, we pick wired packages and rewrite + them to have the expected unitId. + + d) finally, using the visibility map and the package database, + we build a mapping saying what every in scope module name points to. +-} + + -- if databases have not been provided, read the database flags + raw_dbs <- case unitConfigDBCache cfg of + Nothing -> readUnitDatabases logger cfg + Just dbs -> return dbs + + -- distrust all units if the flag is set + let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) } + dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs + | otherwise = raw_dbs + + + -- This, and the other reverse's that you will see, are due to the fact that + -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order + -- than they are on the command line. + let raw_other_flags = reverse (unitConfigFlagsExposed cfg) + (hpt_flags, other_flags) = partition (selectHptFlag (unitConfigHomeUnits cfg)) raw_other_flags + debugTraceMsg logger 2 $ + text "package flags" <+> ppr other_flags + + let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags + + -- Merge databases together, without checking validity + (pkg_map1, prec_map) <- mergeDatabases logger dbs + + -- Now that we've merged everything together, prune out unusable + -- packages. + let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 + + reportCycles logger sccs + reportUnusable logger unusable + + -- Apply trust flags (these flags apply regardless of whether + -- or not packages are visible or not) + pkgs1 <- mayThrowUnitErr + $ foldM (applyTrustFlag prec_map unusable) + (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg)) + let prelim_pkg_db = mkUnitInfoMap pkgs1 + + -- + -- Calculate the initial set of units from package databases, prior to any package flags. + -- + -- Conceptually, we select the latest versions of all valid (not unusable) *packages* + -- (not units). This is empty if we have -hide-all-packages. + -- + -- Then we create an initial visibility map with default visibilities for all + -- exposed, definite units which belong to the latest valid packages. + -- + let preferLater unit unit' = + case compareByPreference prec_map unit unit' of + GT -> unit + _ -> unit' + addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit + -- This is the set of maximally preferable packages. In fact, it is a set of + -- most preferable *units* keyed by package name, which act as stand-ins in + -- for "a package in a database". We use units here because we don't have + -- "a package in a database" as a type currently. + mostPreferablePackageReps = if unitConfigHideAll cfg + then emptyUDFM + else foldl' addIfMorePreferable emptyUDFM pkgs1 + -- When exposing units, we want to consider all of those in the most preferable + -- packages. We can implement that by looking for units that are equi-preferable + -- with the most preferable unit for package. Being equi-preferable means that + -- they must be in the same database, with the same version, and the same package name. + -- + -- We must take care to consider all these units and not just the most + -- preferable one, otherwise we can end up with problems like #16228. + mostPreferable u = + case lookupUDFM mostPreferablePackageReps (fsPackageName u) of + Nothing -> False + Just u' -> compareByPreference prec_map u u' == EQ + vis_map1 = foldl' (\vm p -> + -- Note: we NEVER expose indefinite packages by + -- default, because it's almost assuredly not + -- what you want (no mix-in linking has occurred). + if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p + then addToUniqMap vm (mkUnit p) + UnitVisibility { + uv_expose_all = True, + uv_renamings = [], + uv_package_name = First (Just (fsPackageName p)), + uv_requirements = emptyUniqMap, + uv_explicit = Nothing + } + else vm) + emptyUniqMap pkgs1 + + -- + -- Compute a visibility map according to the command-line flags (-package, + -- -hide-package). This needs to know about the unusable packages, since if a + -- user tries to enable an unusable package, we should let them know. + -- + vis_map2 <- mayThrowUnitErr + $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable + (unitConfigHideAll cfg) pkgs1) + vis_map1 other_flags + + -- + -- Sort out which packages are wired in. This has to be done last, since + -- it modifies the unit ids of wired in packages, but when we process + -- package arguments we need to key against the old versions. + -- + (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2 + let pkg_db = mkUnitInfoMap pkgs2 + + -- Update the visibility map, so we treat wired packages as visible. + let vis_map = updateVisibilityMap wired_map vis_map2 + + let hide_plugin_pkgs = unitConfigHideAllPlugins cfg + plugin_vis_map <- + case unitConfigFlagsPlugins cfg of + -- common case; try to share the old vis_map + [] | not hide_plugin_pkgs -> return vis_map + | otherwise -> return emptyUniqMap + _ -> do let plugin_vis_map1 + | hide_plugin_pkgs = emptyUniqMap + -- Use the vis_map PRIOR to wired in, + -- because otherwise applyPackageFlag + -- won't work. + | otherwise = vis_map2 + plugin_vis_map2 + <- mayThrowUnitErr + $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable + hide_plugin_pkgs pkgs1) + plugin_vis_map1 + (reverse (unitConfigFlagsPlugins cfg)) + -- Updating based on wired in packages is mostly + -- good hygiene, because it won't matter: no wired in + -- package has a compiler plugin. + -- TODO: If a wired in package had a compiler plugin, + -- and you tried to pick different wired in packages + -- with the plugin flags and the normal flags... what + -- would happen? I don't know! But this doesn't seem + -- likely to actually happen. + return (updateVisibilityMap wired_map plugin_vis_map2) + + let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p) + | p <- pkgs2 + ] + -- The explicitUnits accurately reflects the set of units we have turned + -- on; as such, it also is the only way one can come up with requirements. + -- The requirement context is directly based off of this: we simply + -- look for nested unit IDs that are directly fed holes: the requirements + -- of those units are precisely the ones we need to track + let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map] + req_ctx = mapUniqMap (Set.toList) + $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map)) + + + -- + -- Here we build up a set of the packages mentioned in -package + -- flags on the command line; these are called the "preload" + -- packages. we link these packages in eagerly. The preload set + -- should contain at least rts & base, which is why we pretend that + -- the command line contains -package rts & -package base. + -- + -- NB: preload IS important even for type-checking, because we + -- need the correct include path to be set. + -- + let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map) + + -- add default preload units if they can be found in the db + basicLinkedUnits = fmap (RealUnit . Definite) + $ filter (flip elemUniqMap pkg_db) + $ unitConfigAutoLink cfg + preload3 = ordNub $ (basicLinkedUnits ++ preload1) + + -- Close the preload packages with their dependencies + dep_preload <- mayThrowUnitErr + $ closeUnitDeps pkg_db + $ zip (map toUnitId preload3) (repeat Nothing) + + let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map + mod_map2 = mkUnusableModuleNameProvidersMap unusable + mod_map = mod_map2 `plusUniqMap` mod_map1 + + -- Force the result to avoid leaking input parameters + let !state = UnitState + { preloadUnits = dep_preload + , explicitUnits = explicit_pkgs + , homeUnitDepends = Set.toList home_unit_deps + , unitInfoMap = pkg_db + , preloadClosure = emptyUniqSet + , moduleNameProvidersMap = mod_map + , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map + , packageNameMap = pkgname_map + , wireMap = wired_map + , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + , requirementContext = req_ctx + , allowVirtualUnits = unitConfigAllowVirtual cfg + } + return (state, raw_dbs) + +selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool +selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True +selectHptFlag _ _ = False + +selectHomeUnits :: Set.Set UnitId -> [PackageFlag] -> Set.Set UnitId +selectHomeUnits home_units flags = foldl' go Set.empty flags + where + go :: Set.Set UnitId -> PackageFlag -> Set.Set UnitId + go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = Set.insert (toUnitId uid) cur + -- MP: This does not yet support thinning/renaming + go cur _ = cur + + +-- | Given a wired-in 'Unit', "unwire" it into the 'Unit' +-- that it was recorded as in the package database. +unwireUnit :: UnitState -> Unit -> Unit +unwireUnit state uid@(RealUnit (Definite def_uid)) = + maybe uid (RealUnit . Definite) (lookupUniqMap (unwireMap state) def_uid) +unwireUnit _ uid = uid + +-- ----------------------------------------------------------------------------- +-- | Makes the mapping from ModuleName to package info + +-- Slight irritation: we proceed by leafing through everything +-- in the installed package database, which makes handling indefinite +-- packages a bit bothersome. + +mkModuleNameProvidersMap + :: Logger + -> UnitConfig + -> UnitInfoMap + -> PreloadUnitClosure + -> VisibilityMap + -> ModuleNameProvidersMap +mkModuleNameProvidersMap logger cfg pkg_map closure vis_map = + -- What should we fold on? Both situations are awkward: + -- + -- * Folding on the visibility map means that we won't create + -- entries for packages that aren't mentioned in vis_map + -- (e.g., hidden packages, causing #14717) + -- + -- * Folding on pkg_map is awkward because if we have an + -- Backpack instantiation, we need to possibly add a + -- package from pkg_map multiple times to the actual + -- ModuleNameProvidersMap. Also, we don't really want + -- definite package instantiations to show up in the + -- list of possibilities. + -- + -- So what will we do instead? We'll extend vis_map with + -- entries for every definite (for non-Backpack) and + -- indefinite (for Backpack) package, so that we get the + -- hidden entries we need. + nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended + where + vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map + + default_vis = listToUniqMap + [ (mkUnit pkg, mempty) + | (_, pkg) <- nonDetUniqMapToList pkg_map + -- Exclude specific instantiations of an indefinite + -- package + , unitIsIndefinite pkg || null (unitInstantiations pkg) + ] + + emptyMap = emptyUniqMap + setOrigins m os = fmap (const os) m + extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap + = addListTo modmap theBindings + where + pkg = unit_lookup uid + + theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)] + theBindings = newBindings b rns + + newBindings :: Bool + -> [(ModuleName, ModuleName)] + -> [(ModuleName, UniqMap Module ModuleOrigin)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) + -> (ModuleName, UniqMap Module ModuleOrigin) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (renderWithContext + (log_default_user_context (logFlags logger)) + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)] + es e = do + (m, exposedReexport) <- exposed_mods + let (pk', m', origin') = + case exposedReexport of + Nothing -> (pk, m, fromExposedModules e) + Just (Module pk' m') -> + (pk', m', fromReexportedModules e pkg) + return (m, mkModMap pk' m' origin') + + esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin) + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] + + pk = mkUnit pkg + unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map closure uid + `orElse` pprPanic "unit_lookup" (ppr uid) + + exposed_mods = unitExposedModules pkg + hidden_mods = unitHiddenModules pkg + +-- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. +mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap +mkUnusableModuleNameProvidersMap unusables = + nonDetFoldUniqMap extend_modmap emptyUniqMap unusables + where + extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings + where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)] + bindings = exposed ++ hidden + + origin_reexport = ModUnusable (UnusableUnit unit reason True) + origin_normal = ModUnusable (UnusableUnit unit reason False) + unit = mkUnit unit_info + + exposed = map get_exposed exposed_mods + hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods] + + -- with re-exports, c:Foo can be reexported from two (or more) + -- unusable packages: + -- Foo -> a:Foo (unusable reason A) -> c:Foo + -- -> b:Foo (unusable reason B) -> c:Foo + -- + -- We must be careful to not record the following (#21097): + -- Foo -> c:Foo (unusable reason A) + -- -> c:Foo (unusable reason B) + -- But: + -- Foo -> a:Foo (unusable reason A) + -- -> b:Foo (unusable reason B) + -- + get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport) + get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal) + -- in the reexport case, we create a virtual module that doesn't + -- exist but we don't care as it's only used as a key in the map. + + exposed_mods = unitExposedModules unit_info + hidden_mods = unitHiddenModules unit_info + +-- | Add a list of key/value pairs to a nested map. +-- +-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks +-- when reloading modules in GHCi (see #4029). This ensures that each +-- value is forced before installing into the map. +addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) + => UniqMap k1 (UniqMap k2 a) + -> [(k1, UniqMap k2 a)] + -> UniqMap k1 (UniqMap k2 a) +addListTo = foldl' merge + where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v + +-- | Create a singleton module mapping +mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin +mkModMap pkg mod = unitUniqMap (mkModule pkg mod) + + +-- ----------------------------------------------------------------------------- +-- Package Utils + +-- | Takes a 'ModuleName', and if the module is in any package returns +-- list of modules which take that name. +lookupModuleInAllUnits :: UnitState + -> ModuleName + -> [(Module, UnitInfo)] +lookupModuleInAllUnits pkgs m + = case lookupModuleWithSuggestions pkgs m NoPkgQual of + LookupFound a b -> [(a,fst b)] + LookupMultiple rs -> map f rs + where f (m,_) = (m, expectJust (lookupUnit pkgs (moduleUnit m))) + _ -> [] + +-- | The result of performing a lookup +data LookupResult = + -- | Found the module uniquely, nothing else to do + LookupFound Module (UnitInfo, ModuleOrigin) + -- | Multiple modules with the same name in scope + | LookupMultiple [(Module, ModuleOrigin)] + -- | No modules found, but there were some hidden ones with + -- an exact name match. First is due to package hidden, second + -- is due to module being hidden + | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] + -- | No modules found, but there were some unusable ones with + -- an exact name match + | LookupUnusable [(Module, ModuleOrigin)] + -- | Nothing found, here are some suggested different names + | LookupNotFound [ModuleSuggestion] -- suggestions + +data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin + | SuggestHidden ModuleName Module ModuleOrigin + +lookupModuleWithSuggestions :: UnitState + -> ModuleName + -> PkgQual + -> LookupResult +lookupModuleWithSuggestions pkgs + = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) + +-- | The package which the module **appears** to come from, this could be +-- the one which reexports the module from it's original package. This function +-- is currently only used for -Wunused-packages +lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo] +lookupModulePackage pkgs mn mfs = + case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of + LookupFound _ (orig_unit, origin) -> + case origin of + ModOrigin {fromOrigUnit, fromExposedReexport} -> + case fromOrigUnit of + -- Just True means, the import is available from its original location + Just True -> + pure [orig_unit] + -- Otherwise, it must be available from a reexport + _ -> pure fromExposedReexport + + _ -> Nothing + + _ -> Nothing + +lookupPluginModuleWithSuggestions :: UnitState + -> ModuleName + -> PkgQual + -> LookupResult +lookupPluginModuleWithSuggestions pkgs + = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs) + +lookupModuleWithSuggestions' :: UnitState + -> ModuleNameProvidersMap + -> ModuleName + -> PkgQual + -> LookupResult +lookupModuleWithSuggestions' pkgs mod_map m mb_pn + = case lookupUniqMap mod_map m of + Nothing -> LookupNotFound suggestions + Just xs -> + case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of + ([], [], [], []) -> LookupNotFound suggestions + (_, _, _, [(m, o)]) -> LookupFound m (mod_unit m, o) + (_, _, _, exposed@(_:_)) -> LookupMultiple exposed + ([], [], unusable@(_:_), []) -> LookupUnusable unusable + (hidden_pkg, hidden_mod, _, []) -> + LookupHidden hidden_pkg hidden_mod + where + classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) = + let origin = filterOrigin mb_pn (mod_unit m) origin0 + x = (m, origin) + in case origin of + ModHidden + -> (hidden_pkg, x:hidden_mod, unusable, exposed) + ModUnusable _ + -> (hidden_pkg, hidden_mod, x:unusable, exposed) + _ | originEmpty origin + -> (hidden_pkg, hidden_mod, unusable, exposed) + | originVisible origin + -> (hidden_pkg, hidden_mod, unusable, x:exposed) + | otherwise + -> (x:hidden_pkg, hidden_mod, unusable, exposed) + + unit_lookup p = lookupUnit pkgs p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) + mod_unit = unit_lookup . moduleUnit + + -- Filters out origins which are not associated with the given package + -- qualifier. No-op if there is no package qualifier. Test if this + -- excluded all origins with 'originEmpty'. + filterOrigin :: PkgQual + -> UnitInfo + -> ModuleOrigin + -> ModuleOrigin + filterOrigin NoPkgQual _ o = o + filterOrigin (ThisPkg _) _ o = o + filterOrigin (OtherPkg u) pkg o = + let match_pkg p = u == unitId p + in case o of + ModHidden + | match_pkg pkg -> ModHidden + | otherwise -> mempty + ModUnusable _ + | match_pkg pkg -> o + | otherwise -> mempty + ModOrigin { fromOrigUnit = e, fromExposedReexport = res, + fromHiddenReexport = rhs } + -> ModOrigin + { fromOrigUnit = if match_pkg pkg then e else Nothing + , fromExposedReexport = filter match_pkg res + , fromHiddenReexport = filter match_pkg rhs + , fromPackageFlag = False -- always excluded + } + + suggestions = fuzzyLookup (moduleNameString m) all_mods + + all_mods :: [(String, ModuleSuggestion)] -- All modules + all_mods = sortBy (comparing fst) $ + [ (moduleNameString m, suggestion) + | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs) + , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e) + ] + getSuggestion name (mod, origin) = + (if originVisible origin then SuggestVisible else SuggestHidden) + name mod origin + +listVisibleModuleNames :: UnitState -> [ModuleName] +listVisibleModuleNames state = + map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state))) + where visible (_, ms) = anyUniqMap originVisible ms + +-- | Takes a list of UnitIds (and their "parent" dependency, used for error +-- messages), and returns the list with dependencies included, in reverse +-- dependency order (a units appears before those it depends on). +closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] +closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps + +-- | Similar to closeUnitDeps but takes a list of already loaded units as an +-- additional argument. +closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] +closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps + +-- | Add a UnitId and those it depends on (recursively) to the given list of +-- UnitIds if they are not already in it. Return a list in reverse dependency +-- order (a unit appears before those it depends on). +-- +-- The UnitId is looked up in the given UnitInfoMap (to find its dependencies). +-- It it's not found, the optional parent unit is used to return a more precise +-- error message ("dependency of "). +add_unit :: UnitInfoMap + -> [UnitId] + -> UnitId + -> Maybe UnitId + -> MaybeErr UnitErr [UnitId] +add_unit pkg_map ps p mb_parent + | p `elem` ps = return ps -- Check if we've already added this unit + | otherwise = case lookupUnitId' pkg_map p of + Nothing -> Failed (CloseUnitErr p mb_parent) + Just info -> do + -- Add the unit's dependents also + ps' <- foldM add_unit_key ps (unitDepends info) + return (p : ps') + where + add_unit_key xs key + = add_unit pkg_map xs key (Just p) + +data UnitErr + = CloseUnitErr !UnitId !(Maybe UnitId) + | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)] + | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)] + +mayThrowUnitErr :: MaybeErr UnitErr a -> IO a +mayThrowUnitErr = \case + Failed e -> throwGhcExceptionIO + $ CmdLineError + $ renderWithContext defaultSDocContext + $ withPprStyle defaultUserStyle + $ ppr e + Succeeded a -> return a + +instance Outputable UnitErr where + ppr = \case + CloseUnitErr p mb_parent + -> (text "unknown unit:" <+> ppr p) + <> case mb_parent of + Nothing -> Outputable.empty + Just parent -> space <> parens (text "dependency of" + <+> ftext (unitIdFS parent)) + PackageFlagErr flag reasons + -> flag_err (pprFlag flag) reasons + + TrustFlagErr flag reasons + -> flag_err (pprTrustFlag flag) reasons + where + flag_err flag_doc reasons = + text "cannot satisfy " + <> flag_doc + <> (if null reasons then Outputable.empty else text ": ") + $$ nest 4 (vcat (map ppr_reason reasons) $$ + text "(use -v for more information)") + + ppr_reason (p, reason) = + pprReason (ppr (unitId p) <+> text "is") reason + +-- | Return this list of requirement interfaces that need to be merged +-- to form @mod_name@, or @[]@ if this is not a requirement. +requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule] +requirementMerges pkgstate mod_name = + fromMaybe [] (lookupUniqMap (requirementContext pkgstate) mod_name) + +-- ----------------------------------------------------------------------------- + +-- | Pretty-print a UnitId for the user. +-- +-- Cabal packages may contain several components (programs, libraries, etc.). +-- As far as GHC is concerned, installed package components ("units") are +-- identified by an opaque UnitId string provided by Cabal. As the string +-- contains a hash, we don't want to display it to users so GHC queries the +-- database to retrieve some infos about the original source package (name, +-- version, component name). +-- +-- Instead we want to display: packagename-version[:componentname] +-- +-- Component name is only displayed if it isn't the default library +-- +-- To do this we need to query a unit database. +pprUnitIdForUser :: UnitState -> UnitId -> SDoc +pprUnitIdForUser state uid@(UnitId fs) = + case lookupUnitPprInfo state uid of + Nothing -> ftext fs -- we didn't find the unit at all + Just i -> ppr i + +pprUnitInfoForUser :: UnitInfo -> SDoc +pprUnitInfoForUser info = ppr (mkUnitPprInfo unitIdFS info) + +lookupUnitPprInfo :: UnitState -> UnitId -> Maybe UnitPprInfo +lookupUnitPprInfo state uid = fmap (mkUnitPprInfo unitIdFS) (lookupUnitId state uid) + +-- ----------------------------------------------------------------------------- +-- Displaying packages + +-- | Show (very verbose) package info +pprUnits :: UnitState -> SDoc +pprUnits = pprUnitsWith pprUnitInfo + +pprUnitsWith :: (UnitInfo -> SDoc) -> UnitState -> SDoc +pprUnitsWith pprIPI pkgstate = + vcat (intersperse (text "---") (map pprIPI (listUnitInfo pkgstate))) + +-- | Show simplified unit info. +-- +-- The idea is to only print package id, and any information that might +-- be different from the package databases (exposure, trust) +pprUnitsSimple :: UnitState -> SDoc +pprUnitsSimple = pprUnitsWith pprIPI + where pprIPI ipi = let i = unitIdFS (unitId ipi) + e = if unitIsExposed ipi then text "E" else text " " + t = if unitIsTrusted ipi then text "T" else text " " + in e <> t <> text " " <> ftext i + +-- | Show the mapping of modules to where they come from. +pprModuleMap :: ModuleNameProvidersMap -> SDoc +pprModuleMap mod_map = + vcat (map pprLine (nonDetUniqMapToList mod_map)) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) + pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc + pprEntry m (m',o) + | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +fsPackageName :: UnitInfo -> FastString +fsPackageName info = fs + where + PackageName fs = unitPackageName info + + +-- | Given a fully instantiated 'InstantiatedUnit', improve it into a +-- 'RealUnit' if we can find it in the package database. +improveUnit :: UnitState -> Unit -> Unit +improveUnit state u = improveUnit' (unitInfoMap state) (preloadClosure state) u + +-- | Given a fully instantiated 'InstantiatedUnit', improve it into a +-- 'RealUnit' if we can find it in the package database. +improveUnit' :: UnitInfoMap -> PreloadUnitClosure -> Unit -> Unit +improveUnit' _ _ uid@(RealUnit _) = uid -- short circuit +improveUnit' pkg_map closure uid = + -- Do NOT lookup indefinite ones, they won't be useful! + case lookupUnit' False pkg_map closure uid of + Nothing -> uid + Just pkg -> + -- Do NOT improve if the indefinite unit id is not + -- part of the closure unique set. See + -- Note [VirtUnit to RealUnit improvement] + if unitId pkg `elementOfUniqSet` closure + then mkUnit pkg + else uid + +-- | Check the database to see if we already have an installed unit that +-- corresponds to the given 'InstantiatedUnit'. +-- +-- Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged or +-- references a matching installed unit. +-- +-- See Note [VirtUnit to RealUnit improvement] +instUnitToUnit :: UnitState -> InstantiatedUnit -> Unit +instUnitToUnit state iuid = + -- NB: suppose that we want to compare the instantiated + -- unit p[H=impl:H] against p+abcd (where p+abcd + -- happens to be the existing, installed version of + -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] + -- VirtUnit, they won't compare equal; only + -- after improvement will the equality hold. + improveUnit state $ VirtUnit iuid + + +-- | Substitution on module variables, mapping module names to module +-- identifiers. +type ShHoleSubst = ModuleNameEnv Module + +-- | Substitutes holes in a 'Module'. NOT suitable for being called +-- directly on a 'nameModule', see Note [Representation of module/name variables]. +-- @p[A=\]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; +-- similarly, @\@ maps to @q():A@. +renameHoleModule :: UnitState -> ShHoleSubst -> Module -> Module +renameHoleModule state = renameHoleModule' (unitInfoMap state) (preloadClosure state) + +-- | Substitutes holes in a 'Unit', suitable for renaming when +-- an include occurs; see Note [Representation of module/name variables]. +-- +-- @p[A=\]@ maps to @p[A=\]@ with @A=\@. +renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit +renameHoleUnit state = renameHoleUnit' (unitInfoMap state) (preloadClosure state) + +-- | Like 'renameHoleModule', but requires only 'ClosureUnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleModule' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map closure env m + | not (isHoleModule m) = + let uid = renameHoleUnit' pkg_map closure env (moduleUnit m) + in mkModule uid (moduleName m) + | Just m' <- lookupUFM env (moduleName m) = m' + -- NB m = , that's what's in scope. + | otherwise = m + +-- | Like 'renameHoleUnit, but requires only 'ClosureUnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleUnit' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Unit -> Unit +renameHoleUnit' pkg_map closure env uid = + case uid of + (VirtUnit + InstantiatedUnit{ instUnitInstanceOf = cid + , instUnitInsts = insts + , instUnitHoles = fh }) + -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) + then uid + -- Functorially apply the substitution to the instantiation, + -- then check the 'ClosureUnitInfoMap' to see if there is + -- a compiled version of this 'InstantiatedUnit' we can improve to. + -- See Note [VirtUnit to RealUnit improvement] + else improveUnit' pkg_map closure $ + mkVirtUnit cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map closure env v)) insts) + _ -> uid + +-- | Injects an 'InstantiatedModule' to 'Module' (see also +-- 'instUnitToUnit'. +instModuleToModule :: UnitState -> InstantiatedModule -> Module +instModuleToModule pkgstate (Module iuid mod_name) = + mkModule (instUnitToUnit pkgstate iuid) mod_name + +-- | Print unit-ids with UnitInfo found in the given UnitState +pprWithUnitState :: UnitState -> SDoc -> SDoc +pprWithUnitState state = updSDocContext (\ctx -> ctx + { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs) + }) + +-- | Print raw unit-ids, without removing the hash +pprRawUnitIds :: SDoc -> SDoc +pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext }) diff --git a/GHC/Unit/Types.hs b/GHC/Unit/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Types.hs @@ -0,0 +1,718 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Unit & Module types +-- +-- This module is used to resolve the loops between Unit and Module types +-- (Module references a Unit and vice-versa). +module GHC.Unit.Types + ( -- * Modules + GenModule (..) + , Module + , InstalledModule + , HomeUnitModule + , InstantiatedModule + , mkModule + , moduleUnitId + , pprModule + , pprInstantiatedModule + , moduleFreeHoles + + -- * Units + , IsUnitId + , GenUnit (..) + , Unit + , UnitId (..) + , UnitKey (..) + , GenInstantiatedUnit (..) + , InstantiatedUnit + , DefUnitId + , Instantiations + , GenInstantiations + , mkInstantiatedUnit + , mkInstantiatedUnitHash + , mkVirtUnit + , mapGenUnit + , mapInstantiations + , unitFreeModuleHoles + , fsToUnit + , unitFS + , unitString + , toUnitId + , virtualUnitId + , stringToUnit + , stableUnitCmp + , unitIsDefinite + , isHoleUnit + , pprUnit + + -- * Unit Ids + , unitIdString + , stringToUnitId + + -- * Utils + , Definite (..) + + -- * Wired-in units + , ghcInternalUnitId + , rtsUnitId + , mainUnitId + , thisGhcUnitId + , interactiveUnitId + , interactiveGhciUnitId + , interactiveSessionUnitId + + , ghcInternalUnit + , rtsUnit + , mainUnit + , thisGhcUnit + , interactiveUnit + , interactiveGhciUnit + , interactiveSessionUnit + + , isInteractiveModule + , wiredInUnitIds + + -- * Boot modules + , IsBootInterface (..) + , GenWithIsBoot (..) + , ModuleNameWithIsBoot + , ModuleWithIsBoot + ) +where + +import GHC.Prelude + +import GHC.Types.Unique +import GHC.Types.Unique.DSet +import GHC.Utils.Binary +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Encoding +import GHC.Utils.Fingerprint +import GHC.Utils.Misc +import GHC.Settings.Config (cProjectUnitId) + +import Control.DeepSeq (NFData(..)) +import Data.Data +import Data.List (sortBy) +import Data.Function +import Data.Bifunctor +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS.Char8 + +import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.ImpExp (IsBootInterface(..)) + +--------------------------------------------------------------------- +-- MODULES +--------------------------------------------------------------------- + +-- | A generic module is a pair of a unit identifier and a 'ModuleName'. +data GenModule unit = Module + { moduleUnit :: !unit -- ^ Unit the module belongs to + , moduleName :: !ModuleName -- ^ Module name (e.g. A.B.C) + } + deriving (Eq,Ord,Data,Functor) + +-- | A Module is a pair of a 'Unit' and a 'ModuleName'. +type Module = GenModule Unit + +moduleUnitId :: Module -> UnitId +moduleUnitId = toUnitId . moduleUnit + +-- | A 'InstalledModule' is a 'Module' whose unit is identified with an +-- 'UnitId'. +type InstalledModule = GenModule UnitId + +-- | A 'HomeUnitModule' is like an 'InstalledModule' but we expect to find it in +-- one of the home units rather than the package database. +type HomeUnitModule = GenModule UnitId + +-- | An `InstantiatedModule` is a 'Module' whose unit is identified with an `InstantiatedUnit`. +type InstantiatedModule = GenModule InstantiatedUnit + + +mkModule :: u -> ModuleName -> GenModule u +mkModule = Module + +instance Uniquable Module where + getUnique (Module p n) = getUnique (unitFS p `appendFS` moduleNameFS n) + +instance Binary a => Binary (GenModule a) where + put_ bh (Module p n) = put_ bh p >> put_ bh n + -- Module has strict fields, so use $! in order not to allocate a thunk + get bh = do p <- get bh; n <- get bh; return $! Module p n + +instance NFData (GenModule a) where + rnf (Module unit name) = unit `seq` name `seq` () + +instance Outputable Module where + ppr = pprModule + +instance Outputable InstalledModule where + ppr (Module p n) = + ppr p <> char ':' <> pprModuleName n + +instance Outputable InstantiatedModule where + ppr = pprInstantiatedModule + +instance Outputable InstantiatedUnit where + ppr = pprInstantiatedUnit + +pprInstantiatedUnit :: InstantiatedUnit -> SDoc +pprInstantiatedUnit uid = + -- getPprStyle $ \sty -> + pprUnitId cid <> + (if not (null insts) -- pprIf + then + brackets (hcat + (punctuate comma $ + [ pprModuleName modname <> text "=" <> pprModule m + | (modname, m) <- insts])) + else empty) + where + cid = instUnitInstanceOf uid + insts = instUnitInsts uid + +-- | Class for types that are used as unit identifiers (UnitKey, UnitId, Unit) +-- +-- We need this class because we create new unit ids for virtual units (see +-- VirtUnit) and they have to to be made from units with different kinds of +-- identifiers. +class IsUnitId u where + unitFS :: u -> FastString + +instance IsUnitId UnitKey where + unitFS (UnitKey fs) = fs + +instance IsUnitId UnitId where + unitFS (UnitId fs) = fs + +instance IsUnitId u => IsUnitId (GenUnit u) where + unitFS (VirtUnit x) = instUnitFS x + unitFS (RealUnit (Definite x)) = unitFS x + unitFS HoleUnit = holeFS + +pprModule :: IsLine doc => Module -> doc +pprModule mod@(Module p n) = docWithStyle code doc + where + code = (if p == mainUnit + then empty -- never qualify the main package in code + else ztext (zEncodeFS (unitFS p)) <> char '_') + <> pprModuleName n + doc sty + | qualModule sty mod = + case p of + HoleUnit -> angleBrackets (pprModuleName n) + _ -> pprUnit p <> char ':' <> pprModuleName n + | otherwise = + pprModuleName n +{-# SPECIALIZE pprModule :: Module -> SDoc #-} +{-# SPECIALIZE pprModule :: Module -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +pprInstantiatedModule :: InstantiatedModule -> SDoc +pprInstantiatedModule (Module uid m) = + ppr uid <> char ':' <> ppr m + +--------------------------------------------------------------------- +-- UNITS +--------------------------------------------------------------------- + +-- | A unit key in the database +newtype UnitKey = UnitKey FastString + +-- | A unit identifier identifies a (possibly partially) instantiated library. +-- It is primarily used as part of 'Module', which in turn is used in 'Name', +-- which is used to give names to entities when typechecking. +-- +-- There are two possible forms for a 'Unit': +-- +-- 1) It can be a 'RealUnit', in which case we just have a 'DefUnitId' that +-- uniquely identifies some fully compiled, installed library we have on disk. +-- +-- 2) It can be an 'VirtUnit'. When we are typechecking a library with missing +-- holes, we may need to instantiate a library on the fly (in which case we +-- don't have any on-disk representation.) In that case, you have an +-- 'InstantiatedUnit', which explicitly records the instantiation, so that we +-- can substitute over it. +data GenUnit uid + = RealUnit !(Definite uid) + -- ^ Installed definite unit (either a fully instantiated unit or a closed unit) + + | VirtUnit {-# UNPACK #-} !(GenInstantiatedUnit uid) + -- ^ Virtual unit instantiated on-the-fly. It may be definite if all the + -- holes are instantiated but we don't have code objects for it. + + | HoleUnit + -- ^ Fake hole unit + +-- | An instantiated unit. +-- +-- It identifies an indefinite library (with holes) that has been instantiated. +-- +-- This unit may be indefinite or not (i.e. with remaining holes or not). If it +-- is definite, we don't know if it has already been compiled and installed in a +-- database. Nevertheless, we have a mechanism called "improvement" to try to +-- match a fully instantiated unit with existing compiled and installed units: +-- see Note [VirtUnit to RealUnit improvement]. +-- +-- An indefinite unit identifier pretty-prints to something like +-- @p[H=,A=aimpl:A>]@ (@p@ is the 'UnitId', and the +-- brackets enclose the module substitution). +data GenInstantiatedUnit unit + = InstantiatedUnit { + -- | A private, uniquely identifying representation of + -- an InstantiatedUnit. This string is completely private to GHC + -- and is just used to get a unique. + instUnitFS :: !FastString, + -- | Cached unique of 'unitFS'. + instUnitKey :: !Unique, + -- | The (indefinite) unit being instantiated. + instUnitInstanceOf :: !unit, + -- | The sorted (by 'ModuleName') instantiations of this unit. + instUnitInsts :: !(GenInstantiations unit), + -- | A cache of the free module holes of 'instUnitInsts'. + -- This lets us efficiently tell if a 'InstantiatedUnit' has been + -- fully instantiated (empty set of free module holes) + -- and whether or not a substitution can have any effect. + instUnitHoles :: UniqDSet ModuleName + } + +type Unit = GenUnit UnitId +type InstantiatedUnit = GenInstantiatedUnit UnitId + +type GenInstantiations unit = [(ModuleName,GenModule (GenUnit unit))] +type Instantiations = GenInstantiations UnitId + +holeUnique :: Unique +holeUnique = getUnique holeFS + +holeFS :: FastString +holeFS = fsLit "" + +isHoleUnit :: GenUnit u -> Bool +isHoleUnit HoleUnit = True +isHoleUnit _ = False + + +instance Eq (GenInstantiatedUnit unit) where + u1 == u2 = instUnitKey u1 == instUnitKey u2 + +instance Ord (GenInstantiatedUnit unit) where + u1 `compare` u2 = instUnitFS u1 `lexicalCompareFS` instUnitFS u2 + +instance Binary InstantiatedUnit where + put_ bh indef = do + put_ bh (instUnitInstanceOf indef) + put_ bh (instUnitInsts indef) + get bh = do + cid <- get bh + insts <- get bh + let fs = mkInstantiatedUnitHash cid insts + -- InstantiatedUnit has strict fields, so use $! in order not to allocate a thunk + return $! InstantiatedUnit { + instUnitInstanceOf = cid, + instUnitInsts = insts, + instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + instUnitFS = fs, + instUnitKey = getUnique fs + } + +instance IsUnitId u => Eq (GenUnit u) where + uid1 == uid2 = unitUnique uid1 == unitUnique uid2 + +instance IsUnitId u => Uniquable (GenUnit u) where + getUnique = unitUnique + +instance Ord Unit where + nm1 `compare` nm2 = stableUnitCmp nm1 nm2 + +instance Data Unit where + -- don't traverse? + toConstr _ = abstractConstr "Unit" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Unit" + +instance NFData Unit where + rnf x = x `seq` () + +-- | Compares unit ids lexically, rather than by their 'Unique's +stableUnitCmp :: Unit -> Unit -> Ordering +stableUnitCmp p1 p2 = unitFS p1 `lexicalCompareFS` unitFS p2 + +instance Outputable Unit where + ppr pk = pprUnit pk + +pprUnit :: Unit -> SDoc +pprUnit (RealUnit (Definite d)) = pprUnitId d +pprUnit (VirtUnit uid) = pprInstantiatedUnit uid +pprUnit HoleUnit = ftext holeFS + +instance Show Unit where + show = unitString + +-- Performance: would prefer to have a NameCache like thing +instance Binary Unit where + put_ bh (RealUnit def_uid) = do + putByte bh 0 + put_ bh def_uid + put_ bh (VirtUnit indef_uid) = do + putByte bh 1 + put_ bh indef_uid + put_ bh HoleUnit = + putByte bh 2 + get bh = do b <- getByte bh + u <- case b of + 0 -> fmap RealUnit (get bh) + 1 -> fmap VirtUnit (get bh) + _ -> pure HoleUnit + -- Unit has strict fields that need forcing; otherwise we allocate a thunk. + pure $! u + +-- | Retrieve the set of free module holes of a 'Unit'. +unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName +unitFreeModuleHoles (VirtUnit x) = instUnitHoles x +unitFreeModuleHoles (RealUnit _) = emptyUniqDSet +unitFreeModuleHoles HoleUnit = emptyUniqDSet + +-- | Calculate the free holes of a 'Module'. If this set is non-empty, +-- this module was defined in an indefinite library that had required +-- signatures. +-- +-- If a module has free holes, that means that substitutions can operate on it; +-- if it has no free holes, substituting over a module has no effect. +moduleFreeHoles :: GenModule (GenUnit u) -> UniqDSet ModuleName +moduleFreeHoles (Module HoleUnit name) = unitUniqDSet name +moduleFreeHoles (Module u _ ) = unitFreeModuleHoles u + + +-- | Create a new 'GenInstantiatedUnit' given an explicit module substitution. +mkInstantiatedUnit :: IsUnitId u => u -> GenInstantiations u -> GenInstantiatedUnit u +mkInstantiatedUnit cid insts = + InstantiatedUnit { + instUnitInstanceOf = cid, + instUnitInsts = sorted_insts, + instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + instUnitFS = fs, + instUnitKey = getUnique fs + } + where + fs = mkInstantiatedUnitHash cid sorted_insts + sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts + + +-- | Smart constructor for instantiated GenUnit +mkVirtUnit :: IsUnitId u => u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u +mkVirtUnit uid [] = RealUnit $ Definite uid +mkVirtUnit uid insts = VirtUnit $ mkInstantiatedUnit uid insts + +-- | Generate a uniquely identifying hash (internal unit-id) for an instantiated +-- unit. +-- +-- This is a one-way function. If the indefinite unit has not been instantiated at all, we return its unit-id. +-- +-- This hash is completely internal to GHC and is not used for symbol names or +-- file paths. It is different from the hash Cabal would produce for the same +-- instantiated unit. +mkInstantiatedUnitHash :: IsUnitId u => u -> [(ModuleName, GenModule (GenUnit u))] -> FastString +mkInstantiatedUnitHash cid sorted_holes = + mkFastStringByteString + . fingerprintUnitId (bytesFS (unitFS cid)) + $ hashInstantiations sorted_holes + +-- | Generate a hash for a sorted module instantiation. +hashInstantiations :: IsUnitId u => [(ModuleName, GenModule (GenUnit u))] -> Fingerprint +hashInstantiations sorted_holes = + fingerprintByteString + . BS.concat $ do + (m, b) <- sorted_holes + [ bytesFS (moduleNameFS m), BS.Char8.singleton ' ', + bytesFS (unitFS (moduleUnit b)), BS.Char8.singleton ':', + bytesFS (moduleNameFS (moduleName b)), BS.Char8.singleton '\n'] + +fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString +fingerprintUnitId prefix (Fingerprint a b) + = BS.concat + $ [ prefix + , BS.Char8.singleton '-' + , BS.Char8.pack (toBase62Padded a) + , BS.Char8.pack (toBase62Padded b) ] + +unitUnique :: IsUnitId u => GenUnit u -> Unique +unitUnique (VirtUnit x) = instUnitKey x +unitUnique (RealUnit (Definite x)) = getUnique (unitFS x) +unitUnique HoleUnit = holeUnique + +-- | Create a new simple unit identifier from a 'FastString'. Internally, +-- this is primarily used to specify wired-in unit identifiers. +fsToUnit :: FastString -> Unit +fsToUnit = RealUnit . Definite . UnitId + +unitString :: IsUnitId u => u -> String +unitString = unpackFS . unitFS + +stringToUnit :: String -> Unit +stringToUnit = fsToUnit . mkFastString + +-- | Map over the unit type of a 'GenUnit' +mapGenUnit :: IsUnitId v => (u -> v) -> GenUnit u -> GenUnit v +mapGenUnit f = go + where + go gu = case gu of + HoleUnit -> HoleUnit + RealUnit d -> RealUnit (fmap f d) + VirtUnit i -> + VirtUnit $ mkInstantiatedUnit + (f (instUnitInstanceOf i)) + (fmap (second (fmap go)) (instUnitInsts i)) + +-- | Map over the unit identifier of unit instantiations. +mapInstantiations :: IsUnitId v => (u -> v) -> GenInstantiations u -> GenInstantiations v +mapInstantiations f = map (second (fmap (mapGenUnit f))) + +-- | Return the UnitId of the Unit. For on-the-fly instantiated units, return +-- the UnitId of the indefinite unit this unit is an instance of. +toUnitId :: Unit -> UnitId +toUnitId (RealUnit (Definite iuid)) = iuid +toUnitId (VirtUnit indef) = instUnitInstanceOf indef +toUnitId HoleUnit = error "Hole unit" + +-- | Return the virtual UnitId of an on-the-fly instantiated unit. +virtualUnitId :: InstantiatedUnit -> UnitId +virtualUnitId i = UnitId (instUnitFS i) + +-- | A 'Unit' is definite if it has no free holes. +unitIsDefinite :: Unit -> Bool +unitIsDefinite = isEmptyUniqDSet . unitFreeModuleHoles + +--------------------------------------------------------------------- +-- UNIT IDs +--------------------------------------------------------------------- + +-- | A UnitId identifies a built library in a database and is used to generate +-- unique symbols, etc. It's usually of the form: +-- +-- pkgname-1.2:libname+hash +-- +-- These UnitId are provided to us via the @-this-unit-id@ flag. +-- +-- The library in question may be definite or indefinite; if it is indefinite, +-- none of the holes have been filled (we never install partially instantiated +-- libraries as we can cheaply instantiate them on-the-fly, cf VirtUnit). Put +-- another way, an installed unit id is either fully instantiated, or not +-- instantiated at all. +newtype UnitId = UnitId + { unitIdFS :: FastString + -- ^ The full hashed unit identifier, including the component id + -- and the hash. + } + deriving (Data) + +instance NFData UnitId where + rnf (UnitId fs) = rnf fs `seq` () + +instance Binary UnitId where + put_ bh (UnitId fs) = put_ bh fs + get bh = do fs <- get bh; return (UnitId fs) + +instance Eq UnitId where + uid1 == uid2 = getUnique uid1 == getUnique uid2 + +instance Ord UnitId where + -- we compare lexically to avoid non-deterministic output when sets of + -- unit-ids are printed (dependencies, etc.) + u1 `compare` u2 = unitIdFS u1 `lexicalCompareFS` unitIdFS u2 + +instance Uniquable UnitId where + getUnique = getUnique . unitIdFS + +instance Outputable UnitId where + ppr = pprUnitId + +pprUnitId :: UnitId -> SDoc +pprUnitId (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) + +-- | A 'DefUnitId' is an 'UnitId' with the invariant that +-- it only refers to a definite library; i.e., one we have generated +-- code for. +type DefUnitId = Definite UnitId + +unitIdString :: UnitId -> String +unitIdString = unpackFS . unitIdFS + +stringToUnitId :: String -> UnitId +stringToUnitId = UnitId . mkFastString + +--------------------------------------------------------------------- +-- UTILS +--------------------------------------------------------------------- + +-- | A definite unit (i.e. without any free module hole) +newtype Definite unit = Definite { unDefinite :: unit } + deriving (Functor) + deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId) + +--------------------------------------------------------------------- +-- WIRED-IN UNITS +--------------------------------------------------------------------- + +{- +Note [Wired-in units] +~~~~~~~~~~~~~~~~~~~~~ + +Certain packages are known to the compiler, in that we know about certain +entities that reside in these packages, and the compiler needs to +declare static Modules and Names that refer to these packages. Hence +the wired-in packages can't include version numbers in their package UnitId, +since we don't want to bake the version numbers of these packages into GHC. + +So here's the plan. Wired-in units are still versioned as +normal in the packages database, and you can still have multiple +versions of them installed. To the user, everything looks normal. + +However, for each invocation of GHC, only a single instance of each wired-in +package will be recognised (the desired one is selected via +@-package@\/@-hide-package@), and GHC will internally pretend that it has the +*unversioned* 'UnitId', including in .hi files and object file symbols. + +Unselected versions of wired-in packages will be ignored, as will any other +package that depends directly or indirectly on it (much as if you +had used @-ignore-package@). + +The affected packages are compiled with, e.g., @-this-unit-id base@, so that +the symbols in the object files have the unversioned unit id in their name. + +Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. + +-} + +ghcInternalUnitId, rtsUnitId, + mainUnitId, thisGhcUnitId, interactiveUnitId, interactiveGhciUnitId, interactiveSessionUnitId :: UnitId + +ghcInternalUnit, rtsUnit, + mainUnit, thisGhcUnit, interactiveUnit, interactiveGhciUnit, interactiveSessionUnit :: Unit + +ghcInternalUnitId = UnitId (fsLit "ghc-internal") +rtsUnitId = UnitId (fsLit "rts") +thisGhcUnitId = UnitId (fsLit cProjectUnitId) -- See Note [GHC's Unit Id] +interactiveUnitId = UnitId (fsLit "interactive") +interactiveGhciUnitId = UnitId (fsLit "interactive-ghci") +interactiveSessionUnitId = UnitId (fsLit "interactive-session") + +ghcInternalUnit = RealUnit (Definite ghcInternalUnitId) +rtsUnit = RealUnit (Definite rtsUnitId) +thisGhcUnit = RealUnit (Definite thisGhcUnitId) +interactiveUnit = RealUnit (Definite interactiveUnitId) +interactiveGhciUnit = RealUnit (Definite interactiveGhciUnitId) +interactiveSessionUnit = RealUnit (Definite interactiveSessionUnitId) + +-- | This is the package Id for the current program. It is the default +-- package Id if you don't specify a package name. We don't add this prefix +-- to symbol names, since there can be only one main package per program. +mainUnitId = UnitId (fsLit "main") +mainUnit = RealUnit (Definite mainUnitId) + +isInteractiveModule :: Module -> Bool +isInteractiveModule mod = moduleUnit mod == interactiveUnit + +wiredInUnitIds :: [UnitId] +wiredInUnitIds = + [ ghcInternalUnitId + , rtsUnitId + ] + -- NB: ghc is no longer part of the wired-in units since its unit-id, given + -- by hadrian or cabal, is no longer overwritten and now matches both the + -- cProjectUnitId defined in build-time-generated module GHC.Version, and + -- the unit key. + -- + -- See also Note [About units], taking into consideration ghc is still a + -- wired-in unit but whose unit-id no longer needs special handling because + -- we take care that it matches the unit key. + +{- +Note [GHC's Unit Id] +~~~~~~~~~~~~~~~~~~~~ +Previously, the unit-id of ghc-the-library was fixed as `ghc`. +This was done primarily because the compiler must know the unit-id of +some packages (including ghc) a-priori to define wired-in names. + +However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed +to `ghc` might result in subtle bugs when different ghc's interact. + +A good example of this is having GHC_A load a plugin compiled by GHC_B, +where GHC_A and GHC_B are linked to ghc-libraries that are ABI +incompatible. Without a distinction between the unit-id of the ghc library +GHC_A is linked against and the ghc library the plugin it is loading was +compiled against, we can't check compatibility. + +Now, we give a better unit-id to ghc (`ghc-version-hash`) by + +(1) Not setting -this-unit-id fixed to `ghc` in `ghc.cabal`, but rather by having + (1.1) Hadrian pass the new unit-id with -this-unit-id for stage0-1 + (1.2) Cabal pass the unit-id it computes to ghc, which it already does by default + +(2) Adding a definition to `GHC.Settings.Config` whose value is the new +unit-id. This is crucial to define the wired-in name of the GHC unit +(`thisGhcUnitId`) which *must* match the value of the -this-unit-id flag. +(Where `GHC.Settings.Config` is a module generated by the build system which, +be it either hadrian or cabal, knows exactly the unit-id it passed with -this-unit-id) + +Note that we also ensure the ghc's unit key matches its unit id, both when +hadrian or cabal is building ghc. This way, we no longer need to add `ghc` to +the WiringMap, and that's why 'wiredInUnitIds' no longer includes +'thisGhcUnitId'. +-} + +--------------------------------------------------------------------- +-- Boot Modules +--------------------------------------------------------------------- + +-- Note [Boot Module Naming] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Why is this section here? After all, these modules are supposed to be about +-- ways of referring to modules, not modules themselves. Well, the "bootness" of +-- a module is in a way part of its name, because 'import {-# SOURCE #-} Foo' +-- references the boot module in particular while 'import Foo' references the +-- regular module. Backpack signatures live in the normal module namespace (no +-- special import), so they don't matter here. When dealing with the modules +-- themselves, however, one should use not 'IsBoot' or conflate signatures and +-- modules in opposition to boot interfaces. Instead, one should use +-- 'DriverPhases.HscSource'. See Note [HscSource types]. + +-- | This data type just pairs a value 'mod' with an IsBootInterface flag. In +-- practice, 'mod' is usually a @Module@ or @ModuleName@'. +data GenWithIsBoot mod = GWIB + { gwib_mod :: mod + , gwib_isBoot :: IsBootInterface + } deriving ( Eq, Ord, Show + , Functor, Foldable, Traversable + ) + -- the Ord instance must ensure that we first sort by Module and then by + -- IsBootInterface: this is assumed to perform filtering of non-boot modules, + -- e.g. in GHC.Driver.Env.hptModulesBelow + +instance NFData mod => NFData (GenWithIsBoot mod) where + rnf (GWIB mod isBoot) = rnf mod `seq` rnf isBoot `seq` () + +type ModuleNameWithIsBoot = GenWithIsBoot ModuleName + +type ModuleWithIsBoot = GenWithIsBoot Module + +instance Binary a => Binary (GenWithIsBoot a) where + put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do + put_ bh gwib_mod + put_ bh gwib_isBoot + get bh = do + gwib_mod <- get bh + gwib_isBoot <- get bh + pure $ GWIB { gwib_mod, gwib_isBoot } + +instance Outputable a => Outputable (GenWithIsBoot a) where + ppr (GWIB { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of + IsBoot -> [ text "{-# SOURCE #-}" ] + NotBoot -> [] diff --git a/GHC/Unit/Types.hs-boot b/GHC/Unit/Types.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Unit/Types.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE KindSignatures #-} +module GHC.Unit.Types where + +-- No Prelude. See Note [Exporting pprTrace from GHC.Prelude] +import Language.Haskell.Syntax.Module.Name (ModuleName) +import Data.Kind (Type) + +data UnitId +data GenModule (unit :: Type) +data GenUnit (uid :: Type) + +type Module = GenModule Unit +type Unit = GenUnit UnitId + +moduleName :: GenModule a -> ModuleName +moduleUnit :: GenModule a -> a diff --git a/GHC/Utils/Asm.hs b/GHC/Utils/Asm.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Asm.hs @@ -0,0 +1,22 @@ +-- | Various utilities used in generating assembler. +-- +-- These are used not only by the native code generator, but also by the +-- "GHC.Driver.Pipeline" +module GHC.Utils.Asm + ( sectionType + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Utils.Outputable + +-- | Generate a section type (e.g. @\@progbits@). See #13937. +sectionType :: IsLine doc + => Platform -- ^ Target platform + -> String -- ^ section type + -> doc -- ^ pretty assembler fragment +sectionType platform ty = + case platformArch platform of + ArchARM{} -> char '%' <> text ty + _ -> char '@' <> text ty diff --git a/GHC/Utils/Binary.hs b/GHC/Utils/Binary.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Binary.hs @@ -0,0 +1,2165 @@ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ + +module GHC.Utils.Binary + ( {-type-} Bin, RelBin(..), getRelBin, + {-class-} Binary(..), + {-type-} ReadBinHandle, WriteBinHandle, + SymbolTable, Dictionary, + + BinData(..), dataHandle, handleData, + unsafeUnpackBinBuffer, + + openBinMem, +-- closeBin, + + seekBinWriter, + seekBinReader, + seekBinReaderRel, + tellBinReader, + tellBinWriter, + castBin, + withBinBuffer, + freezeWriteHandle, + shrinkBinBuffer, + thawReadHandle, + + foldGet, foldGet', + + writeBinMem, + readBinMem, + readBinMemN, + + putAt, getAt, + putAtRel, + forwardPut, forwardPut_, forwardGet, + forwardPutRel, forwardPutRel_, forwardGetRel, + + -- * For writing instances + putByte, + getByte, + putByteString, + getByteString, + + -- * Variable length encodings + putULEB128, + getULEB128, + putSLEB128, + getSLEB128, + + -- * Fixed length encoding + FixedLengthEncoding(..), + + -- * Lazy Binary I/O + lazyGet, + lazyPut, + lazyGet', + lazyPut', + lazyGetMaybe, + lazyPutMaybe, + + -- * EnumBinary + EnumBinary(..), + + -- * User data + ReaderUserData, getReaderUserData, setReaderUserData, noReaderUserData, + WriterUserData, getWriterUserData, setWriterUserData, noWriterUserData, + mkWriterUserData, mkReaderUserData, + newReadState, newWriteState, + addReaderToUserData, addWriterToUserData, + findUserDataReader, findUserDataWriter, + -- * Binary Readers & Writers + BinaryReader(..), BinaryWriter(..), + mkWriter, mkReader, + SomeBinaryReader, SomeBinaryWriter, + mkSomeBinaryReader, mkSomeBinaryWriter, + -- * Tables + ReaderTable(..), + WriterTable(..), + -- * String table ("dictionary") + initFastStringReaderTable, initFastStringWriterTable, + putDictionary, getDictionary, putFS, + FSTable(..), getDictFastString, putDictFastString, + -- * Generic deduplication table + GenericSymbolTable(..), + initGenericSymbolTable, + getGenericSymtab, putGenericSymTab, + getGenericSymbolTable, putGenericSymbolTable, + -- * Newtype wrappers + BinSpan(..), BinSrcSpan(..), BinLocated(..), + -- * Newtypes for types that have canonically more than one valid encoding + BindingName(..), + simpleBindingNameWriter, + simpleBindingNameReader, + FullBinData(..), freezeBinHandle, thawBinHandle, putFullBinData, + BinArray, + + -- * FingerprintWithValue + FingerprintWithValue(..) + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Module.Name (ModuleName(..)) +import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) + +import {-# SOURCE #-} GHC.Types.Name (Name) +import GHC.Data.FastString +import GHC.Data.TrieMap +import GHC.Utils.Panic.Plain +import GHC.Types.Unique.FM +import GHC.Data.FastMutInt +import GHC.Utils.Fingerprint +import GHC.Types.SrcLoc +import GHC.Types.Unique +import qualified GHC.Data.Strict as Strict +import GHC.Utils.Outputable( JoinPointHood(..) ) + +import Control.DeepSeq +import Control.Monad ( when, (<$!>), unless, forM_, void ) +import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void) +import Data.Array +import Data.Array.IO +import Data.Array.Unsafe +import Data.ByteString (ByteString, copy) +import Data.Coerce +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString.Short.Internal as SBS +import Data.IORef +import Data.Char ( ord, chr ) +import Data.List.NonEmpty ( NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy +import Data.Set ( Set ) +import qualified Data.Set as Set +import Data.Time +import Data.List (unfoldr) +import System.IO as IO +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO.Error ( mkIOError, eofErrorType ) +import Type.Reflection ( Typeable, SomeTypeRep(..) ) +import qualified Type.Reflection as Refl +import GHC.Real ( Ratio(..) ) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import GHC.ForeignPtr ( unsafeWithForeignPtr ) + +import Unsafe.Coerce (unsafeCoerce) + +type BinArray = ForeignPtr Word8 + + +--------------------------------------------------------------- +-- BinData +--------------------------------------------------------------- + +data BinData = BinData Int BinArray + +instance NFData BinData where + rnf (BinData sz _) = rnf sz + +instance Binary BinData where + put_ bh (BinData sz dat) = do + put_ bh sz + putPrim bh sz $ \dest -> + unsafeWithForeignPtr dat $ \orig -> + copyBytes dest orig sz + -- + get bh = do + sz <- get bh + dat <- mallocForeignPtrBytes sz + getPrim bh sz $ \orig -> + unsafeWithForeignPtr dat $ \dest -> + copyBytes dest orig sz + return (BinData sz dat) + +dataHandle :: BinData -> IO ReadBinHandle +dataHandle (BinData size bin) = do + ixr <- newFastMutInt 0 + return (ReadBinMem noReaderUserData ixr size bin) + +handleData :: WriteBinHandle -> IO BinData +handleData (WriteBinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr + +--------------------------------------------------------------- +-- FullBinData +--------------------------------------------------------------- + +-- | 'FullBinData' stores a slice to a 'BinArray'. +-- +-- It requires less memory than 'ReadBinHandle', and can be constructed from +-- a 'ReadBinHandle' via 'freezeBinHandle' and turned back into a +-- 'ReadBinHandle' using 'thawBinHandle'. +-- Additionally, the byte array slice can be put into a 'WriteBinHandle' without extra +-- conversions via 'putFullBinData'. +data FullBinData = FullBinData + { fbd_readerUserData :: ReaderUserData + -- ^ 'ReaderUserData' that can be used to resume reading. + , fbd_off_s :: {-# UNPACK #-} !Int + -- ^ start offset + , fbd_off_e :: {-# UNPACK #-} !Int + -- ^ end offset + , fbd_size :: {-# UNPACK #-} !Int + -- ^ total buffer size + , fbd_buffer :: {-# UNPACK #-} !BinArray + } + +-- Equality and Ord assume that two distinct buffers are different, even if they compare the same things. +instance Eq FullBinData where + (FullBinData _ b c d e) == (FullBinData _ b1 c1 d1 e1) = b == b1 && c == c1 && d == d1 && e == e1 + +instance Ord FullBinData where + compare (FullBinData _ b c d e) (FullBinData _ b1 c1 d1 e1) = + compare b b1 `mappend` compare c c1 `mappend` compare d d1 `mappend` compare e e1 + +-- | Write the 'FullBinData' slice into the 'WriteBinHandle'. +putFullBinData :: WriteBinHandle -> FullBinData -> IO () +putFullBinData bh (FullBinData _ o1 o2 _sz ba) = do + let sz = o2 - o1 + putPrim bh sz $ \dest -> + unsafeWithForeignPtr (ba `plusForeignPtr` o1) $ \orig -> + copyBytes dest orig sz + +-- | Freeze a 'ReadBinHandle' and a start index into a 'FullBinData'. +-- +-- 'FullBinData' stores a slice starting from the 'Bin a' location to the current +-- offset of the 'ReadBinHandle'. +freezeBinHandle :: ReadBinHandle -> Bin a -> IO FullBinData +freezeBinHandle (ReadBinMem user_data ixr sz binr) (BinPtr start) = do + ix <- readFastMutInt ixr + pure (FullBinData user_data start ix sz binr) + +-- | Turn the 'FullBinData' into a 'ReadBinHandle', setting the 'ReadBinHandle' +-- offset to the start of the 'FullBinData' and restore the 'ReaderUserData' that was +-- obtained from 'freezeBinHandle'. +thawBinHandle :: FullBinData -> IO ReadBinHandle +thawBinHandle (FullBinData user_data ix _end sz ba) = do + ixr <- newFastMutInt ix + return $ ReadBinMem user_data ixr sz ba + +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + +-- | A write-only handle that can be used to serialise binary data into a buffer. +-- +-- The buffer is an unboxed binary array. +data WriteBinHandle + = WriteBinMem { + wbm_userData :: WriterUserData, + -- ^ User data for writing binary outputs. + -- Allows users to overwrite certain 'Binary' instances. + -- This is helpful when a non-canonical 'Binary' instance is required, + -- such as in the case of 'Name'. + wbm_off_r :: !FastMutInt, -- ^ the current offset + wbm_sz_r :: !FastMutInt, -- ^ size of the array (cached) + wbm_arr_r :: !(IORef BinArray) -- ^ the array (bounds: (0,size-1)) + } + +-- | A read-only handle that can be used to deserialise binary data from a buffer. +-- +-- The buffer is an unboxed binary array. +data ReadBinHandle + = ReadBinMem { + rbm_userData :: ReaderUserData, + -- ^ User data for reading binary inputs. + -- Allows users to overwrite certain 'Binary' instances. + -- This is helpful when a non-canonical 'Binary' instance is required, + -- such as in the case of 'Name'. + rbm_off_r :: !FastMutInt, -- ^ the current offset + rbm_sz_r :: !Int, -- ^ size of the array (cached) + rbm_arr_r :: !BinArray -- ^ the array (bounds: (0,size-1)) + } + +getReaderUserData :: ReadBinHandle -> ReaderUserData +getReaderUserData bh = rbm_userData bh + +getWriterUserData :: WriteBinHandle -> WriterUserData +getWriterUserData bh = wbm_userData bh + +setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle +setWriterUserData bh us = bh { wbm_userData = us } + +setReaderUserData :: ReadBinHandle -> ReaderUserData -> ReadBinHandle +setReaderUserData bh us = bh { rbm_userData = us } + +-- | Add 'SomeBinaryReader' as a known binary decoder. +-- If a 'BinaryReader' for the associated type already exists in 'ReaderUserData', +-- it is overwritten. +addReaderToUserData :: forall a. Typeable a => BinaryReader a -> ReadBinHandle -> ReadBinHandle +addReaderToUserData reader bh = bh + { rbm_userData = (rbm_userData bh) + { ud_reader_data = + let + typRep = Refl.typeRep @a + in + Map.insert (SomeTypeRep typRep) (SomeBinaryReader typRep reader) (ud_reader_data (rbm_userData bh)) + } + } + +-- | Add 'SomeBinaryWriter' as a known binary encoder. +-- If a 'BinaryWriter' for the associated type already exists in 'WriterUserData', +-- it is overwritten. +addWriterToUserData :: forall a . Typeable a => BinaryWriter a -> WriteBinHandle -> WriteBinHandle +addWriterToUserData writer bh = bh + { wbm_userData = (wbm_userData bh) + { ud_writer_data = + let + typRep = Refl.typeRep @a + in + Map.insert (SomeTypeRep typRep) (SomeBinaryWriter typRep writer) (ud_writer_data (wbm_userData bh)) + } + } + +-- | Get access to the underlying buffer. +withBinBuffer :: WriteBinHandle -> (ByteString -> IO a) -> IO a +withBinBuffer (WriteBinMem _ ix_r _ arr_r) action = do + ix <- readFastMutInt ix_r + arr <- readIORef arr_r + action $ BS.fromForeignPtr arr 0 ix + +unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle +unsafeUnpackBinBuffer (BS.BS arr len) = do + ix_r <- newFastMutInt 0 + return (ReadBinMem noReaderUserData ix_r len arr) + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + +newtype Bin a = BinPtr Int + deriving (Eq, Ord, Show, Bounded) + +-- | Like a 'Bin' but is used to store relative offset pointers. +-- Relative offset pointers store a relative location, but also contain an +-- anchor that allow to obtain the absolute offset. +data RelBin a = RelBin + { relBin_anchor :: {-# UNPACK #-} !(Bin a) + -- ^ Absolute position from where we read 'relBin_offset'. + , relBin_offset :: {-# UNPACK #-} !(RelBinPtr a) + -- ^ Relative offset to 'relBin_anchor'. + -- The absolute position of the 'RelBin' is @relBin_anchor + relBin_offset@ + } + deriving (Eq, Ord, Show, Bounded) + +-- | A 'RelBinPtr' is like a 'Bin', but contains a relative offset pointer +-- instead of an absolute offset. +newtype RelBinPtr a = RelBinPtr (Bin a) + deriving (Eq, Ord, Show, Bounded) + +castBin :: Bin a -> Bin b +castBin (BinPtr i) = BinPtr i + +-- | Read a relative offset location and wrap it in 'RelBin'. +-- +-- The resulting 'RelBin' can be translated into an absolute offset location using +-- 'makeAbsoluteBin' +getRelBin :: ReadBinHandle -> IO (RelBin a) +getRelBin bh = do + start <- tellBinReader bh + off <- get bh + pure $ RelBin start off + +makeAbsoluteBin :: RelBin a -> Bin a +makeAbsoluteBin (RelBin (BinPtr !start) (RelBinPtr (BinPtr !offset))) = + BinPtr $ start + offset + +makeRelativeBin :: RelBin a -> RelBinPtr a +makeRelativeBin (RelBin _ offset) = offset + +toRelBin :: Bin (RelBinPtr a) -> Bin a -> RelBin a +toRelBin (BinPtr !start) (BinPtr !goal) = + RelBin (BinPtr start) (RelBinPtr $ BinPtr $ goal - start) + +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + +-- | Do not rely on instance sizes for general types, +-- we use variable length encoding for many of them. +class Binary a where + put_ :: WriteBinHandle -> a -> IO () + put :: WriteBinHandle -> a -> IO (Bin a) + get :: ReadBinHandle -> IO a + + -- define one of put_, put. Use of put_ is recommended because it + -- is more likely that tail-calls can kick in, and we rarely need the + -- position return value. + put_ bh a = do _ <- put bh a; return () + put bh a = do p <- tellBinWriter bh; put_ bh a; return p + +putAt :: Binary a => WriteBinHandle -> Bin a -> a -> IO () +putAt bh p x = do seekBinWriter bh p; put_ bh x; return () + +putAtRel :: WriteBinHandle -> Bin (RelBinPtr a) -> Bin a -> IO () +putAtRel bh from to = putAt bh from (makeRelativeBin $ toRelBin from to) + +getAt :: Binary a => ReadBinHandle -> Bin a -> IO a +getAt bh p = do seekBinReader bh p; get bh + +openBinMem :: Int -> IO WriteBinHandle +openBinMem size + | size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0" + | otherwise = do + arr <- mallocForeignPtrBytes size + arr_r <- newIORef arr + ix_r <- newFastMutInt 0 + sz_r <- newFastMutInt size + return WriteBinMem + { wbm_userData = noWriterUserData + , wbm_off_r = ix_r + , wbm_sz_r = sz_r + , wbm_arr_r = arr_r + } + +-- | Freeze the given 'WriteBinHandle' and turn it into an equivalent 'ReadBinHandle'. +-- +-- The current offset of the 'WriteBinHandle' is maintained in the new 'ReadBinHandle'. +freezeWriteHandle :: WriteBinHandle -> IO ReadBinHandle +freezeWriteHandle wbm = do + rbm_off_r <- newFastMutInt =<< readFastMutInt (wbm_off_r wbm) + rbm_sz_r <- readFastMutInt (wbm_sz_r wbm) + rbm_arr_r <- readIORef (wbm_arr_r wbm) + pure $ ReadBinMem + { rbm_userData = noReaderUserData + , rbm_off_r = rbm_off_r + , rbm_sz_r = rbm_sz_r + , rbm_arr_r = rbm_arr_r + } + +-- | Copy the BinBuffer to a new BinBuffer which is exactly the right size. +-- This performs a copy of the underlying buffer. +-- The buffer may be truncated if the offset is not at the end of the written +-- output. +-- +-- UserData is also discarded during the copy +-- You should just use this when translating a Put handle into a Get handle. +shrinkBinBuffer :: WriteBinHandle -> IO ReadBinHandle +shrinkBinBuffer bh = withBinBuffer bh $ \bs -> do + unsafeUnpackBinBuffer (copy bs) + +thawReadHandle :: ReadBinHandle -> IO WriteBinHandle +thawReadHandle rbm = do + wbm_off_r <- newFastMutInt =<< readFastMutInt (rbm_off_r rbm) + wbm_sz_r <- newFastMutInt (rbm_sz_r rbm) + wbm_arr_r <- newIORef (rbm_arr_r rbm) + pure $ WriteBinMem + { wbm_userData = noWriterUserData + , wbm_off_r = wbm_off_r + , wbm_sz_r = wbm_sz_r + , wbm_arr_r = wbm_arr_r + } + +tellBinWriter :: WriteBinHandle -> IO (Bin a) +tellBinWriter (WriteBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +tellBinReader :: ReadBinHandle -> IO (Bin a) +tellBinReader (ReadBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +seekBinWriter :: WriteBinHandle -> Bin a -> IO () +seekBinWriter h@(WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do + sz <- readFastMutInt sz_r + if (p > sz) + then do expandBin h p; writeFastMutInt ix_r p + else writeFastMutInt ix_r p + +-- | 'seekBinNoExpandWriter' moves the index pointer to the location pointed to +-- by 'Bin a'. +-- This operation may 'panic', if the pointer location is out of bounds of the +-- buffer of 'BinHandle'. +seekBinNoExpandWriter :: WriteBinHandle -> Bin a -> IO () +seekBinNoExpandWriter (WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do + sz <- readFastMutInt sz_r + if (p > sz) + then panic "seekBinNoExpandWriter: seek out of range" + else writeFastMutInt ix_r p + +-- | SeekBin but without calling expandBin +seekBinReader :: ReadBinHandle -> Bin a -> IO () +seekBinReader (ReadBinMem _ ix_r sz_r _) (BinPtr !p) = do + if (p > sz_r) + then panic "seekBinReader: seek out of range" + else writeFastMutInt ix_r p + +seekBinReaderRel :: ReadBinHandle -> RelBin a -> IO () +seekBinReaderRel (ReadBinMem _ ix_r sz_r _) relBin = do + let (BinPtr !p) = makeAbsoluteBin relBin + if (p > sz_r) + then panic "seekBinReaderRel: seek out of range" + else writeFastMutInt ix_r p + +writeBinMem :: WriteBinHandle -> FilePath -> IO () +writeBinMem (WriteBinMem _ ix_r _ arr_r) fn = do + h <- openBinaryFile fn WriteMode + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix + hClose h + +readBinMem :: FilePath -> IO ReadBinHandle +readBinMem filename = do + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + readBinMem_ filesize h + +readBinMemN :: Int -> FilePath -> IO (Maybe ReadBinHandle) +readBinMemN size filename = do + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + if filesize < size + then pure Nothing + else Just <$> readBinMem_ size h + +readBinMem_ :: Int -> Handle -> IO ReadBinHandle +readBinMem_ filesize h = do + arr <- mallocForeignPtrBytes filesize + count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize + when (count /= filesize) $ + error ("Binary.readBinMem: only read " ++ show count ++ " bytes") + ix_r <- newFastMutInt 0 + return ReadBinMem + { rbm_userData = noReaderUserData + , rbm_off_r = ix_r + , rbm_sz_r = filesize + , rbm_arr_r = arr + } + +-- expand the size of the array to include a specified offset +expandBin :: WriteBinHandle -> Int -> IO () +expandBin (WriteBinMem _ _ sz_r arr_r) !off = do + !sz <- readFastMutInt sz_r + let !sz' = getSize sz + arr <- readIORef arr_r + arr' <- mallocForeignPtrBytes sz' + withForeignPtr arr $ \old -> + withForeignPtr arr' $ \new -> + copyBytes new old sz + writeFastMutInt sz_r sz' + writeIORef arr_r arr' + where + getSize :: Int -> Int + getSize !sz + | sz > off + = sz + | otherwise + = getSize (sz * 2) + +foldGet + :: Binary a + => Word -- n elements + -> ReadBinHandle + -> b -- initial accumulator + -> (Word -> a -> b -> IO b) + -> IO b +foldGet n bh init_b f = go 0 init_b + where + go i b + | i == n = return b + | otherwise = do + a <- get bh + b' <- f i a b + go (i+1) b' + +foldGet' + :: Binary a + => Word -- n elements + -> ReadBinHandle + -> b -- initial accumulator + -> (Word -> a -> b -> IO b) + -> IO b +{-# INLINE foldGet' #-} +foldGet' n bh init_b f = go 0 init_b + where + go i !b + | i == n = return b + | otherwise = do + !a <- get bh + b' <- f i a b + go (i+1) b' + + +-- ----------------------------------------------------------------------------- +-- Low-level reading/writing of bytes + +-- | Takes a size and action writing up to @size@ bytes. +-- After the action has run advance the index to the buffer +-- by size bytes. +putPrim :: WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () +putPrim h@(WriteBinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix + size > sz) $ + expandBin h (ix + size) + arr <- readIORef arr_r + unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix) + writeFastMutInt ix_r (ix + size) + +-- -- | Similar to putPrim but advances the index by the actual number of +-- -- bytes written. +-- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO () +-- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do +-- ix <- readFastMutInt ix_r +-- sz <- readFastMutInt sz_r +-- when (ix + size > sz) $ +-- expandBin h (ix + size) +-- arr <- readIORef arr_r +-- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) +-- writeFastMutInt ix_r (ix + written) + +getPrim :: ReadBinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a +getPrim (ReadBinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + when (ix + size > sz_r) $ + ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) + w <- unsafeWithForeignPtr arr_r $ \p -> f (p `plusPtr` ix) + -- This is safe WRT #17760 as we we guarantee that the above line doesn't + -- diverge + writeFastMutInt ix_r (ix + size) + return w + +putWord8 :: WriteBinHandle -> Word8 -> IO () +putWord8 h !w = putPrim h 1 (\op -> poke op w) + +getWord8 :: ReadBinHandle -> IO Word8 +getWord8 h = getPrim h 1 peek + +putWord16 :: WriteBinHandle -> Word16 -> IO () +putWord16 h w = putPrim h 2 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) + pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) + ) + +getWord16 :: ReadBinHandle -> IO Word16 +getWord16 h = getPrim h 2 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + return $! w0 `shiftL` 8 .|. w1 + ) + +putWord32 :: WriteBinHandle -> Word32 -> IO () +putWord32 h w = putPrim h 4 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) + pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) + pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) + pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) + ) + +getWord32 :: ReadBinHandle -> IO Word32 +getWord32 h = getPrim h 4 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + w2 <- fromIntegral <$> peekElemOff op 2 + w3 <- fromIntegral <$> peekElemOff op 3 + + return $! (w0 `shiftL` 24) .|. + (w1 `shiftL` 16) .|. + (w2 `shiftL` 8) .|. + w3 + ) + +putWord64 :: WriteBinHandle -> Word64 -> IO () +putWord64 h w = putPrim h 8 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) + pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) + pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) + pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) + pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) + pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) + pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) + pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) + ) + +getWord64 :: ReadBinHandle -> IO Word64 +getWord64 h = getPrim h 8 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + w2 <- fromIntegral <$> peekElemOff op 2 + w3 <- fromIntegral <$> peekElemOff op 3 + w4 <- fromIntegral <$> peekElemOff op 4 + w5 <- fromIntegral <$> peekElemOff op 5 + w6 <- fromIntegral <$> peekElemOff op 6 + w7 <- fromIntegral <$> peekElemOff op 7 + + return $! (w0 `shiftL` 56) .|. + (w1 `shiftL` 48) .|. + (w2 `shiftL` 40) .|. + (w3 `shiftL` 32) .|. + (w4 `shiftL` 24) .|. + (w5 `shiftL` 16) .|. + (w6 `shiftL` 8) .|. + w7 + ) + +putByte :: WriteBinHandle -> Word8 -> IO () +putByte bh !w = putWord8 bh w + +getByte :: ReadBinHandle -> IO Word8 +getByte h = getWord8 h + +-- ----------------------------------------------------------------------------- +-- Encode numbers in LEB128 encoding. +-- Requires one byte of space per 7 bits of data. +-- +-- There are signed and unsigned variants. +-- Do NOT use the unsigned one for signed values, at worst it will +-- result in wrong results, at best it will lead to bad performance +-- when coercing negative values to an unsigned type. +-- +-- We mark them as SPECIALIZE as it's extremely critical that they get specialized +-- to their specific types. +-- +-- TODO: Each use of putByte performs a bounds check, +-- we should use putPrimMax here. However it's quite hard to return +-- the number of bytes written into putPrimMax without allocating an +-- Int for it, while the code below does not allocate at all. +-- So we eat the cost of the bounds check instead of increasing allocations +-- for now. + +-- Unsigned numbers +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int16 -> IO () #-} +putULEB128 :: forall a. (Integral a, FiniteBits a) => WriteBinHandle -> a -> IO () +putULEB128 bh w = +#if defined(DEBUG) + (if w < 0 then panic "putULEB128: Signed number" else id) $ +#endif + go w + where + go :: a -> IO () + go w + | w <= (127 :: a) + = putByte bh (fromIntegral w :: Word8) + | otherwise = do + -- bit 7 (8th bit) indicates more to come. + let !byte = setBit (fromIntegral w) 7 :: Word8 + putByte bh byte + go (w `unsafeShiftR` 7) + +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word64 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word32 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word16 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int64 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int32 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int16 #-} +getULEB128 :: forall a. (Integral a, FiniteBits a) => ReadBinHandle -> IO a +getULEB128 bh = + go 0 0 + where + go :: Int -> a -> IO a + go shift w = do + b <- getByte bh + let !hasMore = testBit b 7 + let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a + if hasMore + then do + go (shift+7) val + else + return $! val + +-- Signed numbers +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-} +putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO () +putSLEB128 bh initial = go initial + where + go :: a -> IO () + go val = do + let !byte = fromIntegral (clearBit val 7) :: Word8 + let !val' = val `unsafeShiftR` 7 + let !signBit = testBit byte 6 + let !done = + -- Unsigned value, val' == 0 and last value can + -- be discriminated from a negative number. + ((val' == 0 && not signBit) || + -- Signed value, + (val' == -1 && signBit)) + + let !byte' = if done then byte else setBit byte 7 + putByte bh byte' + + unless done $ go val' + +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word64 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word32 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word16 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int64 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int32 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int16 #-} +getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => ReadBinHandle -> IO a +getSLEB128 bh = do + (val,shift,signed) <- go 0 0 + if signed && (shift < finiteBitSize val ) + then return $! ((complement 0 `unsafeShiftL` shift) .|. val) + else return val + where + go :: Int -> a -> IO (a,Int,Bool) + go shift val = do + byte <- getByte bh + let !byteVal = fromIntegral (clearBit byte 7) :: a + let !val' = val .|. (byteVal `unsafeShiftL` shift) + let !more = testBit byte 7 + let !shift' = shift+7 + if more + then go (shift') val' + else do + let !signed = testBit byte 6 + return (val',shift',signed) + +-- ----------------------------------------------------------------------------- +-- Fixed length encoding instances + +-- Sometimes words are used to represent a certain bit pattern instead +-- of a number. Using FixedLengthEncoding we will write the pattern as +-- is to the interface file without the variable length encoding we usually +-- apply. + +-- | Encode the argument in its full length. This is different from many default +-- binary instances which make no guarantee about the actual encoding and +-- might do things using variable length encoding. +newtype FixedLengthEncoding a + = FixedLengthEncoding { unFixedLength :: a } + deriving (Eq,Ord,Show) + +instance Binary (FixedLengthEncoding Word8) where + put_ h (FixedLengthEncoding x) = putByte h x + get h = FixedLengthEncoding <$> getByte h + +instance Binary (FixedLengthEncoding Word16) where + put_ h (FixedLengthEncoding x) = putWord16 h x + get h = FixedLengthEncoding <$> getWord16 h + +instance Binary (FixedLengthEncoding Word32) where + put_ h (FixedLengthEncoding x) = putWord32 h x + get h = FixedLengthEncoding <$> getWord32 h + +instance Binary (FixedLengthEncoding Word64) where + put_ h (FixedLengthEncoding x) = putWord64 h x + get h = FixedLengthEncoding <$> getWord64 h + +-- ----------------------------------------------------------------------------- +-- Primitive Word writes + +instance Binary Word8 where + put_ bh !w = putWord8 bh w + get = getWord8 + +instance Binary Word16 where + put_ = putULEB128 + get = getULEB128 + +instance Binary Word32 where + put_ = putULEB128 + get = getULEB128 + +instance Binary Word64 where + put_ = putULEB128 + get = getULEB128 + +-- ----------------------------------------------------------------------------- +-- Primitive Int writes + +instance Binary Int8 where + put_ h w = put_ h (fromIntegral w :: Word8) + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + put_ = putSLEB128 + get = getSLEB128 + +instance Binary Int32 where + put_ = putSLEB128 + get = getSLEB128 + +instance Binary Int64 where + put_ h w = putSLEB128 h w + get h = getSLEB128 h + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + put_ _ () = return () + get _ = return () + +instance Binary Bool where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) + +instance Binary Char where + put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) + +instance Binary Int where + put_ bh i = put_ bh (fromIntegral i :: Int64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) + +instance Binary a => Binary [a] where + put_ bh l = do + let len = length l + put_ bh len + mapM_ (put_ bh) l + get bh = do + len <- get bh :: IO Int -- Int is variable length encoded so only + -- one byte for small lists. + let loop 0 = return [] + loop n = do a <- get bh; as <- loop (n-1); return (a:as) + loop len + +-- | This instance doesn't rely on the determinism of the keys' 'Ord' instance, +-- so it works e.g. for 'Name's too. +instance (Binary a, Ord a) => Binary (Set a) where + put_ bh s = put_ bh (Set.toAscList s) + get bh = Set.fromAscList <$> get bh + +instance Binary a => Binary (NonEmpty a) where + put_ bh = put_ bh . NonEmpty.toList + get bh = NonEmpty.fromList <$> get bh + +instance (Ix a, Binary a, Binary b) => Binary (Array a b) where + put_ bh arr = do + put_ bh $ bounds arr + put_ bh $ elems arr + get bh = do + bounds <- get bh + xs <- get bh + return $ listArray bounds xs + +instance (Binary a, Binary b) => Binary (a,b) where + put_ bh (a,b) = do put_ bh a; put_ bh b + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where + put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where + put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + return (a,b,c,d,e,f) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where + put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + g <- get bh + return (a,b,c,d,e,f,g) + +instance Binary a => Binary (Maybe a) where + put_ bh Nothing = putByte bh 0 + put_ bh (Just a) = do putByte bh 1; put_ bh a + get bh = do h <- getWord8 bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +instance Binary a => Binary (Strict.Maybe a) where + put_ bh Strict.Nothing = putByte bh 0 + put_ bh (Strict.Just a) = do putByte bh 1; put_ bh a + get bh = + do h <- getWord8 bh + case h of + 0 -> return Strict.Nothing + _ -> do x <- get bh; return (Strict.Just x) + +instance (Binary a, Binary b) => Binary (Either a b) where + put_ bh (Left a) = do putByte bh 0; put_ bh a + put_ bh (Right b) = do putByte bh 1; put_ bh b + get bh = do h <- getWord8 bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +instance Binary UTCTime where + put_ bh u = do put_ bh (utctDay u) + put_ bh (utctDayTime u) + get bh = do day <- get bh + dayTime <- get bh + return $ UTCTime { utctDay = day, utctDayTime = dayTime } + +instance Binary Day where + put_ bh d = put_ bh (toModifiedJulianDay d) + get bh = do i <- get bh + return $ ModifiedJulianDay { toModifiedJulianDay = i } + +instance Binary DiffTime where + put_ bh dt = put_ bh (toRational dt) + get bh = do r <- get bh + return $ fromRational r + +instance Binary JoinPointHood where + put_ bh NotJoinPoint = putByte bh 0 + put_ bh (JoinPoint ar) = do + putByte bh 1 + put_ bh ar + get bh = do + h <- getByte bh + case h of + 0 -> return NotJoinPoint + _ -> do { ar <- get bh; return (JoinPoint ar) } + +newtype EnumBinary a = EnumBinary { unEnumBinary :: a } +instance Enum a => Binary (EnumBinary a) where + put_ bh (EnumBinary x) = put_ bh (fromEnum x) + get bh = do x <- get bh + return $ EnumBinary (toEnum x) + + +instance Binary IsBootInterface where + put_ bh ib = put_ bh (case ib of + IsBoot -> True + NotBoot -> False) + get bh = do x <- get bh + return $ case x of + True -> IsBoot + False -> NotBoot + +{- +Finally - a reasonable portable Integer instance. + +We used to encode values in the Int32 range as such, +falling back to a string of all things. In either case +we stored a tag byte to discriminate between the two cases. + +This made some sense as it's highly portable but also not very +efficient. + +However GHC stores a surprisingly large number of large Integer +values. In the examples looked at between 25% and 50% of Integers +serialized were outside of the Int32 range. + +Consider a value like `2724268014499746065`, some sort of hash +actually generated by GHC. +In the old scheme this was encoded as a list of 19 chars. This +gave a size of 77 Bytes, one for the length of the list and 76 +since we encode chars as Word32 as well. + +We can easily do better. The new plan is: + +* Start with a tag byte + * 0 => Int64 (LEB128 encoded) + * 1 => Negative large integer + * 2 => Positive large integer +* Followed by the value: + * Int64 is encoded as usual + * Large integers are encoded as a list of bytes (Word8). + We use Data.Bits which defines a bit order independent of the representation. + Values are stored LSB first. + +This means our example value `2724268014499746065` is now only 10 bytes large. +* One byte tag +* One byte for the length of the [Word8] list. +* 8 bytes for the actual date. + +The new scheme also does not depend in any way on +architecture specific details. + +We still use this scheme even with LEB128 available, +as it has less overhead for truly large numbers. (> maxBound :: Int64) + +The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal +-} + +instance Binary Integer where + put_ bh i + | i >= lo64 && i <= hi64 = do + putWord8 bh 0 + put_ bh (fromIntegral i :: Int64) + | otherwise = do + if i < 0 + then putWord8 bh 1 + else putWord8 bh 2 + put_ bh (unroll $ abs i) + where + lo64 = fromIntegral (minBound :: Int64) + hi64 = fromIntegral (maxBound :: Int64) + get bh = do + int_kind <- getWord8 bh + case int_kind of + 0 -> fromIntegral <$!> (get bh :: IO Int64) + -- Large integer + 1 -> negate <$!> getInt + 2 -> getInt + _ -> panic "Binary Integer - Invalid byte" + where + getInt :: IO Integer + getInt = roll <$!> (get bh :: IO [Word8]) + +unroll :: Integer -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: [Word8] -> Integer +roll = foldl' unstep 0 . reverse + where + unstep a b = a `shiftL` 8 .|. fromIntegral b + + + {- + -- This code is currently commented out. + -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for + -- discussion. + + put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) + put_ bh (J# s# a#) = do + putByte bh 1 + put_ bh (I# s#) + let sz# = sizeofByteArray# a# -- in *bytes* + put_ bh (I# sz#) -- in *bytes* + putByteArray bh a# sz# + + get bh = do + b <- getByte bh + case b of + 0 -> do (I# i#) <- get bh + return (S# i#) + _ -> do (I# s#) <- get bh + sz <- get bh + (BA a#) <- getByteArray bh sz + return (J# s# a#) + +putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () +putByteArray bh a s# = loop 0# + where loop n# + | n# ==# s# = return () + | otherwise = do + putByte bh (indexByteArray a n#) + loop (n# +# 1#) + +getByteArray :: BinHandle -> Int -> IO ByteArray +getByteArray bh (I# sz) = do + (MBA arr) <- newByteArray sz + let loop n + | n ==# sz = return () + | otherwise = do + w <- getByte bh + writeByteArray arr n w + loop (n +# 1#) + loop 0# + freezeByteArray arr + -} + +{- +data ByteArray = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () +writeByteArray arr i (W8# w) = IO $ \s -> + case writeWord8Array# arr i w s of { s -> + (# s, () #) } + +indexByteArray :: ByteArray# -> Int# -> Word8 +indexByteArray a# n# = W8# (indexWord8Array# a# n#) + +-} +instance (Binary a) => Binary (Ratio a) where + put_ bh (a :% b) = do put_ bh a; put_ bh b + get bh = do a <- get bh; b <- get bh; return (a :% b) + +-- Instance uses fixed-width encoding to allow inserting +-- Bin placeholders in the stream. +instance Binary (Bin a) where + put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) + get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) + +-- Instance uses fixed-width encoding to allow inserting +-- Bin placeholders in the stream. +instance Binary (RelBinPtr a) where + put_ bh (RelBinPtr i) = put_ bh i + get bh = RelBinPtr <$> get bh + +-- ----------------------------------------------------------------------------- +-- Forward reading/writing + +-- | @'forwardPut' put_A put_B@ outputs A after B but allows A to be read before B +-- by using a forward reference. +forwardPut :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b) +forwardPut bh put_A put_B = do + -- write placeholder pointer to A + pre_a <- tellBinWriter bh + put_ bh pre_a + + -- write B + r_b <- put_B + + -- update A's pointer + a <- tellBinWriter bh + putAt bh pre_a a + seekBinNoExpandWriter bh a + + -- write A + r_a <- put_A r_b + pure (r_a,r_b) + +forwardPut_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO () +forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B + +-- | Read a value stored using a forward reference +-- +-- The forward reference is expected to be an absolute offset. +forwardGet :: ReadBinHandle -> IO a -> IO a +forwardGet bh get_A = do + -- read forward reference + p <- get bh -- a BinPtr + -- store current position + p_a <- tellBinReader bh + -- go read the forward value, then seek back + seekBinReader bh p + r <- get_A + seekBinReader bh p_a + pure r + +-- | @'forwardPutRel' put_A put_B@ outputs A after B but allows A to be read before B +-- by using a forward reference. +-- +-- This forward reference is a relative offset that allows us to skip over the +-- result of 'put_A'. +forwardPutRel :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b) +forwardPutRel bh put_A put_B = do + -- write placeholder pointer to A + pre_a <- tellBinWriter bh + put_ bh pre_a + + -- write B + r_b <- put_B + + -- update A's pointer + a <- tellBinWriter bh + putAtRel bh pre_a a + seekBinNoExpandWriter bh a + + -- write A + r_a <- put_A r_b + pure (r_a,r_b) + +-- | Like 'forwardGetRel', but discard the result. +forwardPutRel_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO () +forwardPutRel_ bh put_A put_B = void $ forwardPutRel bh put_A put_B + +-- | Read a value stored using a forward reference. +-- +-- The forward reference is expected to be a relative offset. +forwardGetRel :: ReadBinHandle -> IO a -> IO a +forwardGetRel bh get_A = do + -- read forward reference + p <- getRelBin bh + -- store current position + p_a <- tellBinReader bh + -- go read the forward value, then seek back + seekBinReader bh $ makeAbsoluteBin p + r <- get_A + seekBinReader bh p_a + pure r + +-- ----------------------------------------------------------------------------- +-- Lazy reading/writing + +lazyPut :: Binary a => WriteBinHandle -> a -> IO () +lazyPut = lazyPut' put_ + +lazyGet :: Binary a => ReadBinHandle -> IO a +lazyGet = lazyGet' get + +lazyPut' :: (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO () +lazyPut' f bh a = do + -- output the obj with a ptr to skip over it: + pre_a <- tellBinWriter bh + put_ bh pre_a -- save a slot for the ptr + f bh a -- dump the object + q <- tellBinWriter bh -- q = ptr to after object + putAtRel bh pre_a q -- fill in slot before a with ptr to q + seekBinWriter bh q -- finally carry on writing at q + +lazyGet' :: (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a +lazyGet' f bh = do + p <- getRelBin bh -- a BinPtr + p_a <- tellBinReader bh + a <- unsafeInterleaveIO $ do + -- NB: Use a fresh rbm_off_r variable in the child thread, for thread + -- safety. + off_r <- newFastMutInt 0 + let bh' = bh { rbm_off_r = off_r } + seekBinReader bh' p_a + f bh' + seekBinReader bh (makeAbsoluteBin p) -- skip over the object for now + return a + +-- | Serialize the constructor strictly but lazily serialize a value inside a +-- 'Just'. +-- +-- This way we can check for the presence of a value without deserializing the +-- value itself. +lazyPutMaybe :: Binary a => WriteBinHandle -> Maybe a -> IO () +lazyPutMaybe bh Nothing = putWord8 bh 0 +lazyPutMaybe bh (Just x) = do + putWord8 bh 1 + lazyPut bh x + +-- | Deserialize a value serialized by 'lazyPutMaybe'. +lazyGetMaybe :: Binary a => ReadBinHandle -> IO (Maybe a) +lazyGetMaybe bh = do + h <- getWord8 bh + case h of + 0 -> pure Nothing + _ -> Just <$> lazyGet bh + +-- ----------------------------------------------------------------------------- +-- UserData +-- ----------------------------------------------------------------------------- + +-- Note [Binary UserData] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- Information we keep around during interface file +-- serialization/deserialization. Namely we keep the functions for serializing +-- and deserializing 'Name's and 'FastString's. We do this because we actually +-- use serialization in two distinct settings, +-- +-- * When serializing interface files themselves +-- +-- * When computing the fingerprint of an IfaceDecl (which we computing by +-- hashing its Binary serialization) +-- +-- These two settings have different needs while serializing Names: +-- +-- * Names in interface files are serialized via a symbol table (see Note +-- [Symbol table representation of names] in "GHC.Iface.Binary"). +-- +-- * During fingerprinting a binding Name is serialized as the OccName and a +-- non-binding Name is serialized as the fingerprint of the thing they +-- represent. See Note [Fingerprinting IfaceDecls] for further discussion. +-- + +-- | Newtype to serialise binding names differently to non-binding 'Name'. +-- See Note [Binary UserData] +newtype BindingName = BindingName { getBindingName :: Name } + deriving ( Eq ) + +simpleBindingNameWriter :: BinaryWriter Name -> BinaryWriter BindingName +simpleBindingNameWriter = coerce + +simpleBindingNameReader :: BinaryReader Name -> BinaryReader BindingName +simpleBindingNameReader = coerce + +-- | Existential for 'BinaryWriter' with a type witness. +data SomeBinaryWriter = forall a . SomeBinaryWriter (Refl.TypeRep a) (BinaryWriter a) + +-- | Existential for 'BinaryReader' with a type witness. +data SomeBinaryReader = forall a . SomeBinaryReader (Refl.TypeRep a) (BinaryReader a) + +-- | UserData required to serialise symbols for interface files. +-- +-- See Note [Binary UserData] +data WriterUserData = + WriterUserData { + ud_writer_data :: Map SomeTypeRep SomeBinaryWriter + -- ^ A mapping from a type witness to the 'Writer' for the associated type. + -- This is a 'Map' because microbenchmarks indicated this is more efficient + -- than other representations for less than ten elements. + -- + -- Considered representations: + -- + -- * [(TypeRep, SomeBinaryWriter)] + -- * bytehash (on hackage) + -- * Map TypeRep SomeBinaryWriter + } + +-- | UserData required to deserialise symbols for interface files. +-- +-- See Note [Binary UserData] +data ReaderUserData = + ReaderUserData { + ud_reader_data :: Map SomeTypeRep SomeBinaryReader + -- ^ A mapping from a type witness to the 'Reader' for the associated type. + -- This is a 'Map' because microbenchmarks indicated this is more efficient + -- than other representations for less than ten elements. + -- + -- Considered representations: + -- + -- * [(TypeRep, SomeBinaryReader)] + -- * bytehash (on hackage) + -- * Map TypeRep SomeBinaryReader + } + +mkWriterUserData :: [SomeBinaryWriter] -> WriterUserData +mkWriterUserData caches = noWriterUserData + { ud_writer_data = Map.fromList $ map (\cache@(SomeBinaryWriter typRep _) -> (SomeTypeRep typRep, cache)) caches + } + +mkReaderUserData :: [SomeBinaryReader] -> ReaderUserData +mkReaderUserData caches = noReaderUserData + { ud_reader_data = Map.fromList $ map (\cache@(SomeBinaryReader typRep _) -> (SomeTypeRep typRep, cache)) caches + } + +mkSomeBinaryWriter :: forall a . Refl.Typeable a => BinaryWriter a -> SomeBinaryWriter +mkSomeBinaryWriter cb = SomeBinaryWriter (Refl.typeRep @a) cb + +mkSomeBinaryReader :: forall a . Refl.Typeable a => BinaryReader a -> SomeBinaryReader +mkSomeBinaryReader cb = SomeBinaryReader (Refl.typeRep @a) cb + +newtype BinaryReader s = BinaryReader + { getEntry :: ReadBinHandle -> IO s + } deriving (Functor) + +newtype BinaryWriter s = BinaryWriter + { putEntry :: WriteBinHandle -> s -> IO () + } + +mkWriter :: (WriteBinHandle -> s -> IO ()) -> BinaryWriter s +mkWriter f = BinaryWriter + { putEntry = f + } + +mkReader :: (ReadBinHandle -> IO s) -> BinaryReader s +mkReader f = BinaryReader + { getEntry = f + } + +-- | Find the 'BinaryReader' for the 'Binary' instance for the type identified by 'Proxy a'. +-- +-- If no 'BinaryReader' has been configured before, this function will panic. +findUserDataReader :: forall a . Refl.Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a +findUserDataReader query bh = + case Map.lookup (Refl.someTypeRep query) (ud_reader_data $ getReaderUserData bh) of + Nothing -> panic $ "Failed to find BinaryReader for the key: " ++ show (Refl.someTypeRep query) + Just (SomeBinaryReader _ (reader :: BinaryReader x)) -> + unsafeCoerce @(BinaryReader x) @(BinaryReader a) reader + -- This 'unsafeCoerce' could be written safely like this: + -- + -- @ + -- Just (SomeBinaryReader _ (reader :: BinaryReader x)) -> + -- case testEquality (typeRep @a) tyRep of + -- Just Refl -> coerce @(BinaryReader x) @(BinaryReader a) reader + -- Nothing -> panic $ "Invariant violated" + -- @ + -- + -- But it comes at a slight performance cost and this function is used in + -- binary serialisation hot loops, thus, we prefer the small performance boost over + -- the additional type safety. + +-- | Find the 'BinaryWriter' for the 'Binary' instance for the type identified by 'Proxy a'. +-- +-- If no 'BinaryWriter' has been configured before, this function will panic. +findUserDataWriter :: forall a . Refl.Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a +findUserDataWriter query bh = + case Map.lookup (Refl.someTypeRep query) (ud_writer_data $ getWriterUserData bh) of + Nothing -> panic $ "Failed to find BinaryWriter for the key: " ++ show (Refl.someTypeRep query) + Just (SomeBinaryWriter _ (writer :: BinaryWriter x)) -> + unsafeCoerce @(BinaryWriter x) @(BinaryWriter a) writer + -- This 'unsafeCoerce' could be written safely like this: + -- + -- @ + -- Just (SomeBinaryWriter tyRep (writer :: BinaryWriter x)) -> + -- case testEquality (typeRep @a) tyRep of + -- Just Refl -> coerce @(BinaryWriter x) @(BinaryWriter a) writer + -- Nothing -> panic $ "Invariant violated" + -- @ + -- + -- But it comes at a slight performance cost and this function is used in + -- binary serialisation hot loops, thus, we prefer the small performance boost over + -- the additional type safety. + + +noReaderUserData :: ReaderUserData +noReaderUserData = ReaderUserData + { ud_reader_data = Map.empty + } + +noWriterUserData :: WriterUserData +noWriterUserData = WriterUserData + { ud_writer_data = Map.empty + } + +newReadState :: (ReadBinHandle -> IO Name) -- ^ how to deserialize 'Name's + -> (ReadBinHandle -> IO FastString) + -> ReaderUserData +newReadState get_name get_fs = + mkReaderUserData + [ mkSomeBinaryReader $ mkReader get_name + , mkSomeBinaryReader $ mkReader @BindingName (coerce get_name) + , mkSomeBinaryReader $ mkReader get_fs + ] + +newWriteState :: (WriteBinHandle -> Name -> IO ()) + -- ^ how to serialize non-binding 'Name's + -> (WriteBinHandle -> Name -> IO ()) + -- ^ how to serialize binding 'Name's + -> (WriteBinHandle -> FastString -> IO ()) + -> WriterUserData +newWriteState put_non_binding_name put_binding_name put_fs = + mkWriterUserData + [ mkSomeBinaryWriter $ mkWriter (\bh name -> put_binding_name bh (getBindingName name)) + , mkSomeBinaryWriter $ mkWriter put_non_binding_name + , mkSomeBinaryWriter $ mkWriter put_fs + ] + +-- ---------------------------------------------------------------------------- +-- Types for lookup and deduplication tables. +-- ---------------------------------------------------------------------------- + +-- | A 'ReaderTable' describes how to deserialise a table from disk, +-- and how to create a 'BinaryReader' that looks up values in the deduplication table. +data ReaderTable a = ReaderTable + { getTable :: ReadBinHandle -> IO (SymbolTable a) + -- ^ Deserialise a list of elements into a 'SymbolTable'. + , mkReaderFromTable :: SymbolTable a -> BinaryReader a + -- ^ Given the table from 'getTable', create a 'BinaryReader' + -- that reads values only from the 'SymbolTable'. + } + +-- | A 'WriterTable' is an interface any deduplication table can implement to +-- describe how the table can be written to disk. +newtype WriterTable = WriterTable + { putTable :: WriteBinHandle -> IO Int + -- ^ Serialise a table to disk. Returns the number of written elements. + } + +-- ---------------------------------------------------------------------------- +-- Common data structures for constructing and maintaining lookup tables for +-- binary serialisation and deserialisation. +-- ---------------------------------------------------------------------------- + +-- | The 'GenericSymbolTable' stores a mapping from already seen elements to an index. +-- If an element wasn't seen before, it is added to the mapping together with a fresh +-- index. +-- +-- 'GenericSymbolTable' is a variant of a 'BinSymbolTable' that is polymorphic in the table implementation. +-- As such it can be used with any container that implements the 'TrieMap' type class. +-- +-- While 'GenericSymbolTable' is similar to the 'BinSymbolTable', it supports storing tree-like +-- structures such as 'Type' and 'IfaceType' more efficiently. +-- +data GenericSymbolTable m = GenericSymbolTable + { gen_symtab_next :: !FastMutInt + -- ^ The next index to use. + , gen_symtab_map :: !(IORef (m Int)) + -- ^ Given a symbol, find the symbol and return its index. + , gen_symtab_to_write :: !(IORef [Key m]) + -- ^ Reversed list of values to write into the buffer. + -- This is an optimisation, as it allows us to write out quickly all + -- newly discovered values that are discovered when serialising 'Key m' + -- to disk. + } + +-- | Initialise a 'GenericSymbolTable', initialising the index to '0'. +initGenericSymbolTable :: TrieMap m => IO (GenericSymbolTable m) +initGenericSymbolTable = do + symtab_next <- newFastMutInt 0 + symtab_map <- newIORef emptyTM + symtab_todo <- newIORef [] + pure $ GenericSymbolTable + { gen_symtab_next = symtab_next + , gen_symtab_map = symtab_map + , gen_symtab_to_write = symtab_todo + } + +-- | Serialise the 'GenericSymbolTable' to disk. +-- +-- Since 'GenericSymbolTable' stores tree-like structures, such as 'IfaceType', +-- serialising an element can add new elements to the mapping. +-- Thus, 'putGenericSymbolTable' first serialises all values, and then checks whether any +-- new elements have been discovered. If so, repeat the loop. +putGenericSymbolTable :: forall m. (TrieMap m) => GenericSymbolTable m -> (WriteBinHandle -> Key m -> IO ()) -> WriteBinHandle -> IO Int +{-# INLINE putGenericSymbolTable #-} +putGenericSymbolTable gen_sym_tab serialiser bh = do + putGenericSymbolTable bh + where + symtab_next = gen_symtab_next gen_sym_tab + symtab_to_write = gen_symtab_to_write gen_sym_tab + putGenericSymbolTable :: WriteBinHandle -> IO Int + putGenericSymbolTable bh = do + let loop = do + vs <- atomicModifyIORef' symtab_to_write (\a -> ([], a)) + case vs of + [] -> readFastMutInt symtab_next + todo -> do + mapM_ (\n -> serialiser bh n) (reverse todo) + loop + snd <$> + (forwardPutRel bh (const $ readFastMutInt symtab_next >>= put_ bh) $ + loop) + +-- | Read the elements of a 'GenericSymbolTable' from disk into a 'SymbolTable'. +getGenericSymbolTable :: forall a . (ReadBinHandle -> IO a) -> ReadBinHandle -> IO (SymbolTable a) +getGenericSymbolTable deserialiser bh = do + sz <- forwardGetRel bh (get bh) :: IO Int + mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a) + forM_ [0..(sz-1)] $ \i -> do + f <- deserialiser bh + writeArray mut_arr i f + unsafeFreeze mut_arr + +-- | Write an element 'Key m' to the given 'WriteBinHandle'. +-- +-- If the element was seen before, we simply write the index of that element to the +-- 'WriteBinHandle'. If we haven't seen it before, we add the element to +-- the 'GenericSymbolTable', increment the index, and return this new index. +putGenericSymTab :: (TrieMap m) => GenericSymbolTable m -> WriteBinHandle -> Key m -> IO () +{-# INLINE putGenericSymTab #-} +putGenericSymTab GenericSymbolTable{ + gen_symtab_map = symtab_map_ref, + gen_symtab_next = symtab_next, + gen_symtab_to_write = symtab_todo } + bh val = do + symtab_map <- readIORef symtab_map_ref + case lookupTM val symtab_map of + Just off -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt symtab_next + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! insertTM val off symtab_map + atomicModifyIORef symtab_todo (\todo -> (val : todo, ())) + put_ bh (fromIntegral off :: Word32) + +-- | Read a value from a 'SymbolTable'. +getGenericSymtab :: Binary a => SymbolTable a -> ReadBinHandle -> IO a +getGenericSymtab symtab bh = do + i :: Word32 <- get bh + return $! symtab ! fromIntegral i + +--------------------------------------------------------- +-- The Dictionary +--------------------------------------------------------- + +-- | A 'SymbolTable' of 'FastString's. +type Dictionary = SymbolTable FastString + +initFastStringReaderTable :: IO (ReaderTable FastString) +initFastStringReaderTable = do + return $ + ReaderTable + { getTable = getDictionary + , mkReaderFromTable = \tbl -> mkReader (getDictFastString tbl) + } + +initFastStringWriterTable :: IO (WriterTable, BinaryWriter FastString) +initFastStringWriterTable = do + dict_next_ref <- newFastMutInt 0 + dict_map_ref <- newIORef emptyUFM + let bin_dict = + FSTable + { fs_tab_next = dict_next_ref + , fs_tab_map = dict_map_ref + } + let put_dict bh = do + fs_count <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh fs_count dict_map + pure fs_count + + return + ( WriterTable + { putTable = put_dict + } + , mkWriter $ putDictFastString bin_dict + ) + +putDictionary :: WriteBinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO () +putDictionary bh sz dict = do + put_ bh sz + mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) + -- It's OK to use nonDetEltsUFM here because the elements have indices + -- that array uses to create order + +getDictionary :: ReadBinHandle -> IO Dictionary +getDictionary bh = do + sz <- get bh :: IO Int + mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString) + forM_ [0..(sz-1)] $ \i -> do + fs <- getFS bh + writeArray mut_arr i fs + unsafeFreeze mut_arr + +getDictFastString :: Dictionary -> ReadBinHandle -> IO FastString +getDictFastString dict bh = do + j <- get bh + return $! (dict ! fromIntegral (j :: Word32)) + +putDictFastString :: FSTable -> WriteBinHandle -> FastString -> IO () +putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh + +allocateFastString :: FSTable -> FastString -> IO Word32 +allocateFastString FSTable { fs_tab_next = j_r + , fs_tab_map = out_r + } f = do + out <- readIORef out_r + let !uniq = getUnique f + case lookupUFM_Directly out uniq of + Just (j, _) -> return (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM_Directly out uniq (j, f) + return (fromIntegral j :: Word32) + +-- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to +-- avoid a collision and copy to avoid a dependency. +data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use + , fs_tab_map :: !(IORef (UniqFM FastString (Int,FastString))) + -- indexed by FastString + } + + +--------------------------------------------------------- +-- The Symbol Table +--------------------------------------------------------- + +-- | Symbols that are read from disk. +-- The 'SymbolTable' index starts on '0'. +type SymbolTable a = Array Int a + +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + +putFS :: WriteBinHandle -> FastString -> IO () +putFS bh fs = putSBS bh $ fastStringToShortByteString fs + +getFS :: ReadBinHandle -> IO FastString +getFS bh = do + l <- get bh :: IO Int + getPrim bh l (\src -> pure $! mkFastStringBytes src l ) + +-- | Put a ByteString without its length (can't be read back without knowing the +-- length!) +putByteString :: WriteBinHandle -> ByteString -> IO () +putByteString bh bs = + BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do + putPrim bh l (\op -> copyBytes op (castPtr ptr) l) + +-- | Get a ByteString whose length is known +getByteString :: ReadBinHandle -> Int -> IO ByteString +getByteString bh l = + BS.create l $ \dest -> do + getPrim bh l (\src -> copyBytes dest src l) + +putSBS :: WriteBinHandle -> SBS.ShortByteString -> IO () +putSBS bh sbs = do + let l = SBS.length sbs + put_ bh l + putPrim bh l (\p -> SBS.copyToPtr sbs 0 p l) + + +getSBS :: ReadBinHandle -> IO SBS.ShortByteString +getSBS bh = do + l <- get bh :: IO Int + getPrim bh l (\src -> SBS.createFromPtr src l) + +putBS :: WriteBinHandle -> ByteString -> IO () +putBS bh bs = + BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do + put_ bh l + putPrim bh l (\op -> copyBytes op (castPtr ptr) l) + +getBS :: ReadBinHandle -> IO ByteString +getBS bh = do + l <- get bh :: IO Int + BS.create l $ \dest -> do + getPrim bh l (\src -> copyBytes dest src l) + +instance Binary SBS.ShortByteString where + put_ bh f = putSBS bh f + get bh = getSBS bh + +instance Binary ByteString where + put_ bh f = putBS bh f + get bh = getBS bh + +instance Binary FastString where + put_ bh f = + case findUserDataWriter (Proxy :: Proxy FastString) bh of + tbl -> putEntry tbl bh f + + get bh = + case findUserDataReader (Proxy :: Proxy FastString) bh of + tbl -> getEntry tbl bh + +deriving instance Binary NonDetFastString +deriving instance Binary LexicalFastString + +instance Binary Fingerprint where + put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 + get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) + +instance Binary ModuleName where + put_ bh (ModuleName fs) = put_ bh fs + get bh = do fs <- get bh; return (ModuleName fs) + +-- instance Binary TupleSort where +-- put_ bh BoxedTuple = putByte bh 0 +-- put_ bh UnboxedTuple = putByte bh 1 +-- put_ bh ConstraintTuple = putByte bh 2 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return BoxedTuple +-- 1 -> do return UnboxedTuple +-- _ -> do return ConstraintTuple + +-- instance Binary Activation where +-- put_ bh NeverActive = do +-- putByte bh 0 +-- put_ bh FinalActive = do +-- putByte bh 1 +-- put_ bh AlwaysActive = do +-- putByte bh 2 +-- put_ bh (ActiveBefore src aa) = do +-- putByte bh 3 +-- put_ bh src +-- put_ bh aa +-- put_ bh (ActiveAfter src ab) = do +-- putByte bh 4 +-- put_ bh src +-- put_ bh ab +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return NeverActive +-- 1 -> do return FinalActive +-- 2 -> do return AlwaysActive +-- 3 -> do src <- get bh +-- aa <- get bh +-- return (ActiveBefore src aa) +-- _ -> do src <- get bh +-- ab <- get bh +-- return (ActiveAfter src ab) + +-- instance Binary InlinePragma where +-- put_ bh (InlinePragma s a b c d) = do +-- put_ bh s +-- put_ bh a +-- put_ bh b +-- put_ bh c +-- put_ bh d + +-- get bh = do +-- s <- get bh +-- a <- get bh +-- b <- get bh +-- c <- get bh +-- d <- get bh +-- return (InlinePragma s a b c d) + +-- instance Binary RuleMatchInfo where +-- put_ bh FunLike = putByte bh 0 +-- put_ bh ConLike = putByte bh 1 +-- get bh = do +-- h <- getByte bh +-- if h == 1 then return ConLike +-- else return FunLike + +-- instance Binary InlineSpec where +-- put_ bh NoUserInlinePrag = putByte bh 0 +-- put_ bh Inline = putByte bh 1 +-- put_ bh Inlinable = putByte bh 2 +-- put_ bh NoInline = putByte bh 3 + +-- get bh = do h <- getByte bh +-- case h of +-- 0 -> return NoUserInlinePrag +-- 1 -> return Inline +-- 2 -> return Inlinable +-- _ -> return NoInline + +-- instance Binary RecFlag where +-- put_ bh Recursive = do +-- putByte bh 0 +-- put_ bh NonRecursive = do +-- putByte bh 1 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return Recursive +-- _ -> do return NonRecursive + +-- instance Binary OverlapMode where +-- put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s +-- put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s +-- put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s +-- put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s +-- put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> (get bh) >>= \s -> return $ NoOverlap s +-- 1 -> (get bh) >>= \s -> return $ Overlaps s +-- 2 -> (get bh) >>= \s -> return $ Incoherent s +-- 3 -> (get bh) >>= \s -> return $ Overlapping s +-- 4 -> (get bh) >>= \s -> return $ Overlappable s +-- _ -> panic ("get OverlapMode" ++ show h) + + +-- instance Binary OverlapFlag where +-- put_ bh flag = do put_ bh (overlapMode flag) +-- put_ bh (isSafeOverlap flag) +-- get bh = do +-- h <- get bh +-- b <- get bh +-- return OverlapFlag { overlapMode = h, isSafeOverlap = b } + +-- instance Binary FixityDirection where +-- put_ bh InfixL = do +-- putByte bh 0 +-- put_ bh InfixR = do +-- putByte bh 1 +-- put_ bh InfixN = do +-- putByte bh 2 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return InfixL +-- 1 -> do return InfixR +-- _ -> do return InfixN + +-- instance Binary Fixity where +-- put_ bh (Fixity src aa ab) = do +-- put_ bh src +-- put_ bh aa +-- put_ bh ab +-- get bh = do +-- src <- get bh +-- aa <- get bh +-- ab <- get bh +-- return (Fixity src aa ab) + +-- instance Binary WarningTxt where +-- put_ bh (WarningTxt s w) = do +-- putByte bh 0 +-- put_ bh s +-- put_ bh w +-- put_ bh (DeprecatedTxt s d) = do +-- putByte bh 1 +-- put_ bh s +-- put_ bh d + +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do s <- get bh +-- w <- get bh +-- return (WarningTxt s w) +-- _ -> do s <- get bh +-- d <- get bh +-- return (DeprecatedTxt s d) + +-- instance Binary StringLiteral where +-- put_ bh (StringLiteral st fs _) = do +-- put_ bh st +-- put_ bh fs +-- get bh = do +-- st <- get bh +-- fs <- get bh +-- return (StringLiteral st fs Nothing) + +newtype BinLocated a = BinLocated { unBinLocated :: Located a } + +instance Binary a => Binary (BinLocated a) where + put_ bh (BinLocated (L l x)) = do + put_ bh $ BinSrcSpan l + put_ bh x + + get bh = do + l <- unBinSrcSpan <$> get bh + x <- get bh + return $ BinLocated (L l x) + +newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan } + +-- See Note [Source Location Wrappers] +instance Binary BinSpan where + put_ bh (BinSpan ss) = do + put_ bh (srcSpanFile ss) + put_ bh (srcSpanStartLine ss) + put_ bh (srcSpanStartCol ss) + put_ bh (srcSpanEndLine ss) + put_ bh (srcSpanEndCol ss) + + get bh = do + f <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc) + (mkRealSrcLoc f el ec)) + +instance Binary UnhelpfulSpanReason where + put_ bh r = case r of + UnhelpfulNoLocationInfo -> putByte bh 0 + UnhelpfulWiredIn -> putByte bh 1 + UnhelpfulInteractive -> putByte bh 2 + UnhelpfulGenerated -> putByte bh 3 + UnhelpfulOther fs -> putByte bh 4 >> put_ bh fs + + get bh = do + h <- getByte bh + case h of + 0 -> return UnhelpfulNoLocationInfo + 1 -> return UnhelpfulWiredIn + 2 -> return UnhelpfulInteractive + 3 -> return UnhelpfulGenerated + _ -> UnhelpfulOther <$> get bh + +newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan } + +-- See Note [Source Location Wrappers] +instance Binary BinSrcSpan where + put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do + putByte bh 0 + -- BufSpan doesn't ever get serialised because the positions depend + -- on build location. + put_ bh $ BinSpan ss + + put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> do BinSpan ss <- get bh + return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing) + _ -> do s <- get bh + return $ BinSrcSpan (UnhelpfulSpan s) + + +{- +Note [Source Location Wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Source locations are banned from interface files, to +prevent filepaths affecting interface hashes. + +Unfortunately, we can't remove all binary instances, +as they're used to serialise .hie files, and we don't +want to break binary compatibility. + +To this end, the Bin[Src]Span newtypes wrappers were +introduced to prevent accidentally serialising a +source location as part of a larger structure. +-} + +-------------------------------------------------------------------------------- +-- Instances for the containers package +-------------------------------------------------------------------------------- + +instance (Binary v) => Binary (IntMap v) where + put_ bh m = put_ bh (IntMap.toAscList m) + get bh = IntMap.fromAscList <$> get bh + + +{- Note [FingerprintWithValue] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +FingerprintWithValue is a wrapper which allows us to store a fingerprint and +optionally the value which was used to create the fingerprint. + +This is useful for storing information in interface files, where we want to +store the fingerprint of the interface file, but also the value which was used +to create the fingerprint (e.g. the DynFlags). + +The wrapper is useful to ensure that the fingerprint can be read quickly without +having to deserialise the value itself. +-} + +-- | A wrapper which allows us to store a fingerprint and optionally the value which +-- was used to create the fingerprint. +data FingerprintWithValue a = FingerprintWithValue !Fingerprint (Maybe a) + deriving Functor + +instance Binary a => Binary (FingerprintWithValue a) where + put_ bh (FingerprintWithValue fp val) = do + put_ bh fp + lazyPutMaybe bh val + + get bh = do + fp <- get bh + val <- lazyGetMaybe bh + return $ FingerprintWithValue fp val + +instance NFData a => NFData (FingerprintWithValue a) where + rnf (FingerprintWithValue fp mflags) + = rnf fp `seq` rnf mflags `seq` () diff --git a/GHC/Utils/Binary/Typeable.hs b/GHC/Utils/Binary/Typeable.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Binary/Typeable.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} + +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +{-# OPTIONS_GHC -Wno-orphans -Wincomplete-patterns #-} + +-- | Orphan Binary instances for Data.Typeable stuff +module GHC.Utils.Binary.Typeable + ( getSomeTypeRep + ) +where + +import GHC.Prelude + +import GHC.Utils.Binary + +import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..)) +import GHC.Exts (Levity(Lifted, Unlifted)) +import GHC.Serialized + +import Foreign +import Type.Reflection +import Type.Reflection.Unsafe +import Data.Kind (Type) + + +instance Binary TyCon where + put_ bh tc = do + put_ bh (tyConPackage tc) + put_ bh (tyConModule tc) + put_ bh (tyConName tc) + put_ bh (tyConKindArgs tc) + put_ bh (tyConKindRep tc) + get bh = + mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh + +getSomeTypeRep :: ReadBinHandle -> IO SomeTypeRep +getSomeTypeRep bh = do + tag <- get bh :: IO Word8 + case tag of + 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type) + 1 -> do con <- get bh :: IO TyCon + ks <- get bh :: IO [SomeTypeRep] + return $ SomeTypeRep $ mkTrCon con ks + 2 -> do SomeTypeRep f <- getSomeTypeRep bh + SomeTypeRep x <- getSomeTypeRep bh + case typeRepKind f of + Fun arg res -> + case arg `eqTypeRep` typeRepKind x of + Just HRefl -> + case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> return $ SomeTypeRep $ mkTrApp f x + _ -> failure "Kind mismatch in type application" [] + _ -> failure "Kind mismatch in type application" + [ " Found argument of kind: " ++ show (typeRepKind x) + , " Where the constructor: " ++ show f + , " Expects kind: " ++ show arg + ] + _ -> failure "Applied non-arrow" + [ " Applied type: " ++ show f + , " To argument: " ++ show x + ] + _ -> failure "Invalid SomeTypeRep" [] + where + failure description info = + fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ] + ++ map (" "++) info + +instance Binary SomeTypeRep where + put_ bh (SomeTypeRep rep) = putTypeRep bh rep + get = getSomeTypeRep + +instance Typeable a => Binary (TypeRep (a :: k)) where + put_ = putTypeRep + get bh = do + SomeTypeRep rep <- getSomeTypeRep bh + case rep `eqTypeRep` expected of + Just HRefl -> pure rep + Nothing -> fail $ unlines + [ "Binary: Type mismatch" + , " Deserialized type: " ++ show rep + , " Expected type: " ++ show expected + ] + where expected = typeRep :: TypeRep a + + +instance Binary VecCount where + put_ bh = putByte bh . fromIntegral . fromEnum + get bh = toEnum . fromIntegral <$> getByte bh + +instance Binary VecElem where + put_ bh = putByte bh . fromIntegral . fromEnum + get bh = toEnum . fromIntegral <$> getByte bh + +instance Binary RuntimeRep where + put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b + put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps + put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps + put_ bh (BoxedRep Lifted) = putByte bh 3 + put_ bh (BoxedRep Unlifted) = putByte bh 4 + put_ bh IntRep = putByte bh 5 + put_ bh WordRep = putByte bh 6 + put_ bh Int64Rep = putByte bh 7 + put_ bh Word64Rep = putByte bh 8 + put_ bh AddrRep = putByte bh 9 + put_ bh FloatRep = putByte bh 10 + put_ bh DoubleRep = putByte bh 11 + put_ bh Int8Rep = putByte bh 12 + put_ bh Word8Rep = putByte bh 13 + put_ bh Int16Rep = putByte bh 14 + put_ bh Word16Rep = putByte bh 15 + put_ bh Int32Rep = putByte bh 16 + put_ bh Word32Rep = putByte bh 17 + + get bh = do + tag <- getByte bh + case tag of + 0 -> VecRep <$> get bh <*> get bh + 1 -> TupleRep <$> get bh + 2 -> SumRep <$> get bh + 3 -> pure (BoxedRep Lifted) + 4 -> pure (BoxedRep Unlifted) + 5 -> pure IntRep + 6 -> pure WordRep + 7 -> pure Int64Rep + 8 -> pure Word64Rep + 9 -> pure AddrRep + 10 -> pure FloatRep + 11 -> pure DoubleRep + 12 -> pure Int8Rep + 13 -> pure Word8Rep + 14 -> pure Int16Rep + 15 -> pure Word16Rep + 16 -> pure Int32Rep + 17 -> pure Word32Rep + _ -> fail "Binary.putRuntimeRep: invalid tag" + +instance Binary KindRep where + put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k + put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr + put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b + put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b + put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r + put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r + + get bh = do + tag <- getByte bh + case tag of + 0 -> KindRepTyConApp <$> get bh <*> get bh + 1 -> KindRepVar <$> get bh + 2 -> KindRepApp <$> get bh <*> get bh + 3 -> KindRepFun <$> get bh <*> get bh + 4 -> KindRepTYPE <$> get bh + 5 -> KindRepTypeLit <$> get bh <*> get bh + _ -> fail "Binary.putKindRep: invalid tag" + +instance Binary TypeLitSort where + put_ bh TypeLitSymbol = putByte bh 0 + put_ bh TypeLitNat = putByte bh 1 + put_ bh TypeLitChar = putByte bh 2 + get bh = do + tag <- getByte bh + case tag of + 0 -> pure TypeLitSymbol + 1 -> pure TypeLitNat + 2 -> pure TypeLitChar + _ -> fail "Binary.putTypeLitSort: invalid tag" + +putTypeRep :: WriteBinHandle -> TypeRep a -> IO () +putTypeRep bh rep -- Handle Type specially since it's so common + | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) + = put_ bh (0 :: Word8) +putTypeRep bh (Con' con ks) = do + put_ bh (1 :: Word8) + put_ bh con + put_ bh ks +putTypeRep bh (App f x) = do + put_ bh (2 :: Word8) + putTypeRep bh f + putTypeRep bh x + +instance Binary Serialized where + put_ bh (Serialized the_type bytes) = do + put_ bh the_type + put_ bh bytes + get bh = do + the_type <- get bh + bytes <- get bh + return (Serialized the_type bytes) diff --git a/GHC/Utils/BufHandle.hs b/GHC/Utils/BufHandle.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/BufHandle.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- +-- Fast write-buffered Handles +-- +-- (c) The University of Glasgow 2005-2006 +-- +-- This is a simple abstraction over Handles that offers very fast write +-- buffering, but without the thread safety that Handles provide. It's used +-- to save time in GHC.Utils.Ppr.printDoc. +-- +----------------------------------------------------------------------------- + +module GHC.Utils.BufHandle ( + BufHandle(..), + newBufHandle, + bPutChar, + bPutStr, + bPutFS, + bPutFZS, + bPutPtrString, + bPutReplicate, + bFlush, + ) where + +import GHC.Prelude.Basic + +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import Control.Monad ( when ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Unsafe as BS +import Data.Char ( ord ) +import Foreign +import Foreign.C.String +import System.IO + +-- for RULES +import GHC.Exts (unpackCString#, unpackNBytes#, Int(..)) +import GHC.Ptr (Ptr(..)) + +-- ----------------------------------------------------------------------------- + +data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) + {-#UNPACK#-}!FastMutInt + Handle + +newBufHandle :: Handle -> IO BufHandle +newBufHandle hdl = do + ptr <- mallocBytes buf_size + r <- newFastMutInt 0 + return (BufHandle ptr r hdl) + +buf_size :: Int +buf_size = 8192 + +bPutChar :: BufHandle -> Char -> IO () +bPutChar b@(BufHandle buf r hdl) !c = do + i <- readFastMutInt r + if (i >= buf_size) + then do hPutBuf hdl buf buf_size + writeFastMutInt r 0 + bPutChar b c + else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) + writeFastMutInt r (i+1) + +-- Equivalent of the text/str, text/unpackNBytes#, text/[] rules +-- in GHC.Utils.Ppr. +{-# RULES "hdoc/str" + forall a h. bPutStr h (unpackCString# a) = bPutPtrString h (mkPtrString# a) + #-} +{-# RULES "hdoc/unpackNBytes#" + forall p n h. bPutStr h (unpackNBytes# p n) = bPutPtrString h (PtrString (Ptr p) (I# n)) + #-} +{-# RULES "hdoc/[]#" + forall h. bPutStr h [] = return () + #-} + +{-# NOINLINE [0] bPutStr #-} -- Give the RULE a chance to fire + -- It must wait till after phase 1 when + -- the unpackCString first is manifested + +bPutStr :: BufHandle -> String -> IO () +bPutStr (BufHandle buf r hdl) !str = do + i <- readFastMutInt r + loop str i + where loop "" !i = do writeFastMutInt r i; return () + loop (c:cs) !i + | i >= buf_size = do + hPutBuf hdl buf buf_size + loop (c:cs) 0 + | otherwise = do + pokeElemOff buf i (fromIntegral (ord c)) + loop cs (i+1) + +bPutFS :: BufHandle -> FastString -> IO () +bPutFS b fs = bPutBS b $ bytesFS fs + +bPutFZS :: BufHandle -> FastZString -> IO () +bPutFZS b fs = bPutBS b $ fastZStringToByteString fs + +bPutBS :: BufHandle -> ByteString -> IO () +bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b + +bPutCStringLen :: BufHandle -> CStringLen -> IO () +bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do + i <- readFastMutInt r + if (i + len) >= buf_size + then do hPutBuf hdl buf i + writeFastMutInt r 0 + if (len >= buf_size) + then hPutBuf hdl ptr len + else bPutCStringLen b cstr + else do + copyBytes (buf `plusPtr` i) ptr len + writeFastMutInt r (i + len) + +bPutPtrString :: BufHandle -> PtrString -> IO () +bPutPtrString b@(BufHandle buf r hdl) l@(PtrString a len) = l `seq` do + i <- readFastMutInt r + if (i+len) >= buf_size + then do hPutBuf hdl buf i + writeFastMutInt r 0 + if (len >= buf_size) + then hPutBuf hdl a len + else bPutPtrString b l + else do + copyBytes (buf `plusPtr` i) a len + writeFastMutInt r (i+len) + +-- | Replicate an 8-bit character +bPutReplicate :: BufHandle -> Int -> Char -> IO () +bPutReplicate (BufHandle buf r hdl) len c = do + i <- readFastMutInt r + let oc = fromIntegral (ord c) + if (i+len) < buf_size + then do + fillBytes (buf `plusPtr` i) oc len + writeFastMutInt r (i+len) + else do + -- flush the current buffer + when (i /= 0) $ hPutBuf hdl buf i + if (len < buf_size) + then do + fillBytes buf oc len + writeFastMutInt r len + else do + -- fill a full buffer + fillBytes buf oc buf_size + -- flush it as many times as necessary + let go n | n >= buf_size = do + hPutBuf hdl buf buf_size + go (n-buf_size) + | otherwise = writeFastMutInt r n + go len + +bFlush :: BufHandle -> IO () +bFlush (BufHandle buf r hdl) = do + i <- readFastMutInt r + when (i > 0) $ hPutBuf hdl buf i + free buf + return () diff --git a/GHC/Utils/CliOption.hs b/GHC/Utils/CliOption.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/CliOption.hs @@ -0,0 +1,27 @@ +module GHC.Utils.CliOption + ( Option (..) + , showOpt + ) where + +import GHC.Prelude + +-- ----------------------------------------------------------------------------- +-- Command-line options + +-- | When invoking external tools as part of the compilation pipeline, we +-- pass these a sequence of options on the command-line. Rather than +-- just using a list of Strings, we use a type that allows us to distinguish +-- between filepaths and 'other stuff'. The reason for this is that +-- this type gives us a handle on transforming filenames, and filenames only, +-- to whatever format they're expected to be on a particular platform. +data Option + = FileOption -- an entry that _contains_ filename(s) / filepaths. + String -- a non-filepath prefix that shouldn't be + -- transformed (e.g., "/out=") + String -- the filepath/filename portion + | Option String + deriving ( Eq ) + +showOpt :: Option -> String +showOpt (FileOption pre f) = pre ++ f +showOpt (Option s) = s diff --git a/GHC/Utils/Constants.hs b/GHC/Utils/Constants.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Constants.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} + +module GHC.Utils.Constants + ( debugIsOn + , ghciSupported + , isWindowsHost + , isDarwinHost + ) +where + +import GHC.Prelude.Basic + +{- + +These booleans are global constants, set by CPP flags. They allow us to +recompile a single module (this one) to change whether or not debug output +appears. They sometimes let us avoid even running CPP elsewhere. + +It's important that the flags are literal constants (True/False). Then, +with -0, tests of the flags in other modules will simplify to the correct +branch of the conditional, thereby dropping debug code altogether when +the flags are off. +-} + +ghciSupported :: Bool +#if defined(HAVE_INTERNAL_INTERPRETER) +ghciSupported = True +#else +ghciSupported = False +#endif + +debugIsOn :: Bool +#if defined(DEBUG) +debugIsOn = True +#else +debugIsOn = False +#endif + +isWindowsHost :: Bool +#if defined(mingw32_HOST_OS) +isWindowsHost = True +#else +isWindowsHost = False +#endif + +isDarwinHost :: Bool +#if defined(darwin_HOST_OS) +isDarwinHost = True +#else +isDarwinHost = False +#endif diff --git a/GHC/Utils/Containers/Internal/BitUtil.hs b/GHC/Utils/Containers/Internal/BitUtil.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Containers/Internal/BitUtil.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Utils.Containers.Internal.BitUtil +-- Copyright : (c) Clark Gaebel 2012 +-- (c) Johan Tibel 2012 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Portability : portable +----------------------------------------------------------------------------- +-- +-- = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. + +module GHC.Utils.Containers.Internal.BitUtil + ( bitcount + , highestBitMask + , shiftLL + , shiftRL + ) where + +import GHC.Prelude.Basic +import Data.Word + +{---------------------------------------------------------------------- + [bitcount] as posted by David F. Place to haskell-cafe on April 11, 2006, + based on the code on + http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan, + where the following source is given: + Published in 1988, the C Programming Language 2nd Ed. (by Brian W. + Kernighan and Dennis M. Ritchie) mentions this in exercise 2-9. On April + 19, 2006 Don Knuth pointed out to me that this method "was first published + by Peter Wegner in CACM 3 (1960), 322. (Also discovered independently by + Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)" +----------------------------------------------------------------------} + +bitcount :: Int -> Word64 -> Int +bitcount a x = a + popCount x +{-# INLINE bitcount #-} + +-- The highestBitMask implementation is based on +-- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2 +-- which has been put in the public domain. + +-- | Return a word where only the highest bit is set. +highestBitMask :: Word64 -> Word64 +highestBitMask w = shiftLL 1 (63 - countLeadingZeros w) +{-# INLINE highestBitMask #-} + +-- Right and left logical shifts. +shiftRL, shiftLL :: Word64 -> Int -> Word64 +shiftRL = unsafeShiftR +shiftLL = unsafeShiftL diff --git a/GHC/Utils/Containers/Internal/StrictPair.hs b/GHC/Utils/Containers/Internal/StrictPair.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Containers/Internal/StrictPair.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} + +-- | A strict pair + +module GHC.Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where + +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + +default () + +-- | The same as a regular Haskell pair, but +-- +-- @ +-- (x :*: _|_) = (_|_ :*: y) = _|_ +-- @ +data StrictPair a b = !a :*: !b + +infixr 1 :*: + +-- | Convert a strict pair to a standard pair. +toPair :: StrictPair a b -> (a, b) +toPair (x :*: y) = (x, y) +{-# INLINE toPair #-} diff --git a/GHC/Utils/Error.hs b/GHC/Utils/Error.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Error.hs @@ -0,0 +1,629 @@ +{-# LANGUAGE ViewPatterns #-} + +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[ErrsUtils]{Utilities for error reporting} +-} + +module GHC.Utils.Error ( + -- * Basic types + Validity'(..), Validity, andValid, allValid, getInvalids, + Severity(..), + + -- * Messages + Diagnostic(..), + MsgEnvelope(..), + MessageClass(..), + SDoc, + DecoratedSDoc(unDecorated), + Messages, + mkMessages, unionMessages, + errorsFound, isEmptyMessages, + + -- ** Formatting + pprMessageBag, pprMsgEnvelopeBagWithLoc, pprMsgEnvelopeBagWithLocDefault, + pprMessages, + pprLocMsgEnvelope, pprLocMsgEnvelopeDefault, + formatBulleted, + + -- ** Construction + DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt, + emptyMessages, mkDecorated, mkLocMessage, + mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, + mkErrorMsgEnvelope, + mkMCDiagnostic, errorDiagnostic, diagReasonSeverity, + + mkPlainError, + mkPlainDiagnostic, + mkDecoratedError, + mkDecoratedDiagnostic, + noHints, + + -- * Utilities + getCaretDiagnostic, + + -- * Issuing messages during compilation + putMsg, printInfoForUser, printOutputForUser, + logInfo, logOutput, + errorMsg, + fatalErrorMsg, + compilationProgressMsg, + showPass, + withTiming, withTimingSilent, + debugTraceMsg, + ghcExit, + prettyPrintGhcErrors, + traceCmd, + traceSystoolCommand, + + sortMsgBag + ) where + +import GHC.Prelude + +import GHC.Driver.Flags + +import GHC.Data.Bag +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.EnumSet (EnumSet) + +import GHC.Utils.Exception +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Logger +import GHC.Types.Error +import GHC.Types.SrcLoc as SrcLoc +import GHC.Unit.Module.Warnings + +import System.Exit ( ExitCode(..), exitWith ) +import Data.List ( sortBy ) +import Data.Function +import Debug.Trace +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Catch as MC (handle) +import GHC.Conc ( getAllocationCounter ) +import System.CPUTime +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE + +data DiagOpts = DiagOpts + { diag_warning_flags :: !(EnumSet WarningFlag) -- ^ Enabled warnings + , diag_fatal_warning_flags :: !(EnumSet WarningFlag) -- ^ Fatal warnings + , diag_custom_warning_categories :: !WarningCategorySet -- ^ Enabled custom warning categories + , diag_fatal_custom_warning_categories :: !WarningCategorySet -- ^ Fatal custom warning categories + , diag_warn_is_error :: !Bool -- ^ Treat warnings as errors + , diag_reverse_errors :: !Bool -- ^ Reverse error reporting order + , diag_max_errors :: !(Maybe Int) -- ^ Max reported error count + , diag_ppr_ctx :: !SDocContext -- ^ Error printing context + } + +emptyDiagOpts :: DiagOpts +emptyDiagOpts = + DiagOpts + { diag_warning_flags = EnumSet.empty + , diag_fatal_warning_flags = EnumSet.empty + , diag_custom_warning_categories = emptyWarningCategorySet + , diag_fatal_custom_warning_categories = emptyWarningCategorySet + , diag_warn_is_error = False + , diag_reverse_errors = False + , diag_max_errors = Nothing + , diag_ppr_ctx = defaultSDocContext + } + +diag_wopt :: WarningFlag -> DiagOpts -> Bool +diag_wopt wflag opts = wflag `EnumSet.member` diag_warning_flags opts + +diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool +diag_fatal_wopt wflag opts = wflag `EnumSet.member` diag_fatal_warning_flags opts + +diag_wopt_custom :: WarningCategory -> DiagOpts -> Bool +diag_wopt_custom wflag opts = wflag `elemWarningCategorySet` diag_custom_warning_categories opts + +diag_fatal_wopt_custom :: WarningCategory -> DiagOpts -> Bool +diag_fatal_wopt_custom wflag opts = wflag `elemWarningCategorySet` diag_fatal_custom_warning_categories opts + +-- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of +-- the 'DiagOpts. This function /has/ to be called when a diagnostic is constructed, +-- i.e. with a 'DiagOpts \"snapshot\" taken as close as possible to where a +-- particular diagnostic message is built, otherwise the computed 'Severity' might +-- not be correct, due to the mutable nature of the 'DynFlags' in GHC. +-- +-- +diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity +diagReasonSeverity opts reason = fst (diag_reason_severity opts reason) + +-- Like the diagReasonSeverity but the second half of the pair is a small +-- ReasolvedDiagnosticReason which would cause the diagnostic to be triggered with the +-- same severity. +-- +-- See Note [Warnings controlled by multiple flags] +-- +diag_reason_severity :: DiagOpts -> DiagnosticReason -> (Severity, ResolvedDiagnosticReason) +diag_reason_severity opts reason = fmap ResolvedDiagnosticReason $ case reason of + WarningWithFlags wflags -> case wflags' of + [] -> (SevIgnore, reason) + w : ws -> case wflagsE of + [] -> (SevWarning, WarningWithFlags (w :| ws)) + e : es -> (SevError, WarningWithFlags (e :| es)) + where + wflags' = NE.filter (\wflag -> diag_wopt wflag opts) wflags + wflagsE = filter (\wflag -> diag_fatal_wopt wflag opts) wflags' + + WarningWithCategory wcat + | not (diag_wopt_custom wcat opts) -> (SevIgnore, reason) + | diag_fatal_wopt_custom wcat opts -> (SevError, reason) + | otherwise -> (SevWarning, reason) + WarningWithoutFlag + | diag_warn_is_error opts -> (SevError, reason) + | otherwise -> (SevWarning, reason) + ErrorWithoutFlag + -> (SevError, reason) + +-- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the +-- 'DiagOpts'. +mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass +mkMCDiagnostic opts reason code = MCDiagnostic sev reason' code + where + (sev, reason') = diag_reason_severity opts reason + +-- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the +-- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag' and there is no diagnostic code. +errorDiagnostic :: MessageClass +errorDiagnostic = MCDiagnostic SevError (ResolvedDiagnosticReason ErrorWithoutFlag) Nothing + +-- +-- Creating MsgEnvelope(s) +-- + +mk_msg_envelope + :: Diagnostic e + => Severity + -> SrcSpan + -> NamePprCtx + -> ResolvedDiagnosticReason + -> e + -> MsgEnvelope e +mk_msg_envelope severity locn name_ppr_ctx reason err + = MsgEnvelope { errMsgSpan = locn + , errMsgContext = name_ppr_ctx + , errMsgDiagnostic = err + , errMsgSeverity = severity + , errMsgReason = reason + } + +-- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location. +-- If you know your 'Diagnostic' is an error, consider using 'mkErrorMsgEnvelope', +-- which does not require looking at the 'DiagOpts' +mkMsgEnvelope + :: Diagnostic e + => DiagOpts + -> SrcSpan + -> NamePprCtx + -> e + -> MsgEnvelope e +mkMsgEnvelope opts locn name_ppr_ctx err + = mk_msg_envelope sev locn name_ppr_ctx reason err + where + (sev, reason) = diag_reason_severity opts (diagnosticReason err) + +-- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location. +-- Precondition: the diagnostic is, in fact, an error. That is, +-- @diagnosticReason msg == ErrorWithoutFlag@. +mkErrorMsgEnvelope :: Diagnostic e + => SrcSpan + -> NamePprCtx + -> e + -> MsgEnvelope e +mkErrorMsgEnvelope locn name_ppr_ctx msg = + assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn name_ppr_ctx (ResolvedDiagnosticReason ErrorWithoutFlag) msg + +-- | Variant that doesn't care about qualified/unqualified names. +mkPlainMsgEnvelope :: Diagnostic e + => DiagOpts + -> SrcSpan + -> e + -> MsgEnvelope e +mkPlainMsgEnvelope opts locn msg = + mkMsgEnvelope opts locn alwaysQualify msg + +-- | Variant of 'mkPlainMsgEnvelope' which can be used when we are /sure/ we +-- are constructing a diagnostic with a 'ErrorWithoutFlag' reason. +mkPlainErrorMsgEnvelope :: Diagnostic e + => SrcSpan + -> e + -> MsgEnvelope e +mkPlainErrorMsgEnvelope locn msg = + mk_msg_envelope SevError locn alwaysQualify (ResolvedDiagnosticReason ErrorWithoutFlag) msg + +------------------------- +data Validity' a + = IsValid -- ^ Everything is fine + | NotValid a -- ^ A problem, and some indication of why + deriving Functor + +-- | Monomorphic version of @Validity'@ specialised for 'SDoc's. +type Validity = Validity' SDoc + +andValid :: Validity' a -> Validity' a -> Validity' a +andValid IsValid v = v +andValid v _ = v + +-- | If they aren't all valid, return the first +allValid :: [Validity' a] -> Validity' a +allValid [] = IsValid +allValid (v : vs) = v `andValid` allValid vs + +getInvalids :: [Validity' a] -> [a] +getInvalids vs = [d | NotValid d <- vs] + +-- ----------------------------------------------------------------------------- +-- Collecting up messages for later ordering and printing. + +---------------- +-- | Formats the input list of structured document, where each element of the list gets a bullet. +formatBulleted :: DecoratedSDoc -> SDoc +formatBulleted (unDecorated -> docs) + = sdocWithContext $ \ctx -> case msgs ctx of + [] -> Outputable.empty + [msg] -> msg + xs -> vcat $ map starred xs + where + msgs ctx = filter (not . Outputable.isEmpty ctx) docs + starred = (bullet<+>) + +pprMessages :: Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc +pprMessages e = vcat . pprMsgEnvelopeBagWithLoc e . getMessages + +pprMsgEnvelopeBagWithLoc :: Diagnostic e => DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc] +pprMsgEnvelopeBagWithLoc e bag = [ pprLocMsgEnvelope e item | item <- sortMsgBag Nothing bag ] + +-- | Print the messages with the suitable default configuration, usually not what you want but sometimes you don't really +-- care about what the configuration is (for example, if the message is in a panic). +pprMsgEnvelopeBagWithLocDefault :: forall e . Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] +pprMsgEnvelopeBagWithLocDefault bag = [ pprLocMsgEnvelopeDefault item | item <- sortMsgBag Nothing bag ] + +pprLocMsgEnvelopeDefault :: forall e . Diagnostic e => MsgEnvelope e -> SDoc +pprLocMsgEnvelopeDefault = pprLocMsgEnvelope (defaultDiagnosticOpts @e) + +pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc +pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s + , errMsgDiagnostic = e + , errMsgSeverity = sev + , errMsgContext = name_ppr_ctx + , errMsgReason = reason }) + = withErrStyle name_ppr_ctx $ + mkLocMessage + (MCDiagnostic sev reason (diagnosticCode e)) + s + (formatBulleted $ diagnosticMessage opts e) + +sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e] +sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList + where + cmp + | Just opts <- mopts + , diag_reverse_errors opts + = SrcLoc.rightmost_smallest + | otherwise + = SrcLoc.leftmost_smallest + maybeLimit + | Just opts <- mopts + , Just err_limit <- diag_max_errors opts + = take err_limit + | otherwise + = id + +ghcExit :: Logger -> Int -> IO () +ghcExit logger val + | val == 0 = exitWith ExitSuccess + | otherwise = do errorMsg logger (text "\nCompilation had errors\n\n") + exitWith (ExitFailure val) + +-- ----------------------------------------------------------------------------- +-- Outputting messages from the compiler + +errorMsg :: Logger -> SDoc -> IO () +errorMsg logger msg + = logMsg logger errorDiagnostic noSrcSpan $ + withPprStyle defaultErrStyle msg + +fatalErrorMsg :: Logger -> SDoc -> IO () +fatalErrorMsg logger msg = + logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg + +compilationProgressMsg :: Logger -> SDoc -> IO () +compilationProgressMsg logger msg = do + let logflags = logFlags logger + let str = renderWithContext (log_default_user_context logflags) (text "GHC progress: " <> msg) + traceEventIO str + when (logVerbAtLeast logger 1) $ + logOutput logger $ withPprStyle defaultUserStyle msg + +showPass :: Logger -> String -> IO () +showPass logger what = + when (logVerbAtLeast logger 2) $ + logInfo logger $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon) + +data PrintTimings = PrintTimings | DontPrintTimings + deriving (Eq, Show) + +-- | Time a compilation phase. +-- +-- When timings are enabled (e.g. with the @-v2@ flag), the allocations +-- and CPU time used by the phase will be reported to stderr. Consider +-- a typical usage: +-- @withTiming getDynFlags (text "simplify") force PrintTimings pass@. +-- When timings are enabled the following costs are included in the +-- produced accounting, +-- +-- - The cost of executing @pass@ to a result @r@ in WHNF +-- - The cost of evaluating @force r@ to WHNF (e.g. @()@) +-- +-- The choice of the @force@ function depends upon the amount of forcing +-- desired; the goal here is to ensure that the cost of evaluating the result +-- is, to the greatest extent possible, included in the accounting provided by +-- 'withTiming'. Often the pass already sufficiently forces its result during +-- construction; in this case @const ()@ is a reasonable choice. +-- In other cases, it is necessary to evaluate the result to normal form, in +-- which case something like @Control.DeepSeq.rnf@ is appropriate. +-- +-- To avoid adversely affecting compiler performance when timings are not +-- requested, the result is only forced when timings are enabled. +-- +-- See Note [withTiming] for more. +withTiming :: MonadIO m + => Logger + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTiming logger what force action = + withTiming' logger what force PrintTimings action + +-- | Same as 'withTiming', but doesn't print timings in the +-- console (when given @-vN@, @N >= 2@ or @-ddump-timings@). +-- +-- See Note [withTiming] for more. +withTimingSilent + :: MonadIO m + => Logger + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTimingSilent logger what force action = + withTiming' logger what force DontPrintTimings action + +-- | Worker for 'withTiming' and 'withTimingSilent'. +withTiming' :: MonadIO m + => Logger + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> PrintTimings -- ^ Whether to print the timings + -> m a -- ^ The body of the phase to be timed + -> m a +withTiming' logger what force_result prtimings action + = if logVerbAtLeast logger 2 || logHasDumpFlag logger Opt_D_dump_timings + then do when printTimingsNotDumpToFile $ liftIO $ + logInfo logger $ withPprStyle defaultUserStyle $ + text "***" <+> what <> colon + let ctx = log_default_user_context (logFlags logger) + alloc0 <- liftIO getAllocationCounter + start <- liftIO getCPUTime + eventBegins ctx what + recordAllocs alloc0 + !r <- action + () <- pure $ force_result r + eventEnds ctx what + end <- liftIO getCPUTime + alloc1 <- liftIO getAllocationCounter + recordAllocs alloc1 + -- recall that allocation counter counts down + let alloc = alloc0 - alloc1 + time = realToFrac (end - start) * 1e-9 + + when (logVerbAtLeast logger 2 && printTimingsNotDumpToFile) + $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle + (text "!!!" <+> what <> colon <+> text "finished in" + <+> doublePrec 2 time + <+> text "milliseconds" + <> comma + <+> text "allocated" + <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) + <+> text "megabytes") + + whenPrintTimings $ + putDumpFileMaybe logger Opt_D_dump_timings "" FormatText + $ text $ showSDocOneLine ctx + $ hsep [ what <> colon + , text "alloc=" <> ppr alloc + , text "time=" <> doublePrec 3 time + ] + pure r + else action + + where whenPrintTimings = + liftIO . when printTimings + + printTimings = + prtimings == PrintTimings + + -- Avoid both printing to console and dumping to a file (#20316). + printTimingsNotDumpToFile = + printTimings + && not (log_dump_to_file (logFlags logger)) + + recordAllocs alloc = + liftIO $ traceMarkerIO $ "GHC:allocs:" ++ show alloc + + eventBegins ctx w = do + let doc = eventBeginsDoc ctx w + whenPrintTimings $ traceMarkerIO doc + liftIO $ traceEventIO doc + + eventEnds ctx w = do + let doc = eventEndsDoc ctx w + whenPrintTimings $ traceMarkerIO doc + liftIO $ traceEventIO doc + + eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w + eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w + +debugTraceMsg :: Logger -> Int -> SDoc -> IO () +debugTraceMsg logger val msg = + when (log_verbosity (logFlags logger) >= val) $ + logInfo logger (withPprStyle defaultDumpStyle msg) +{-# INLINE debugTraceMsg #-} -- see Note [INLINE conditional tracing utilities] + +putMsg :: Logger -> SDoc -> IO () +putMsg logger msg = logInfo logger (withPprStyle defaultUserStyle msg) + +printInfoForUser :: Logger -> NamePprCtx -> SDoc -> IO () +printInfoForUser logger name_ppr_ctx msg + = logInfo logger (withUserStyle name_ppr_ctx AllTheWay msg) + +printOutputForUser :: Logger -> NamePprCtx -> SDoc -> IO () +printOutputForUser logger name_ppr_ctx msg + = logOutput logger (withUserStyle name_ppr_ctx AllTheWay msg) + +logInfo :: Logger -> SDoc -> IO () +logInfo logger msg = logMsg logger MCInfo noSrcSpan msg + +-- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' +logOutput :: Logger -> SDoc -> IO () +logOutput logger msg = logMsg logger MCOutput noSrcSpan msg + + +prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a +prettyPrintGhcErrors logger = do + let ctx = log_default_user_context (logFlags logger) + MC.handle $ \e -> case e of + PprPanic str doc -> + pprDebugAndThen ctx panic (text str) doc + PprSorry str doc -> + pprDebugAndThen ctx sorry (text str) doc + PprProgramError str doc -> + pprDebugAndThen ctx pgmError (text str) doc + _ -> liftIO $ throwIO e + +-- | Trace a command (when verbosity level >= 3) +traceCmd :: Logger -> String -> String -> IO a -> IO a +traceCmd logger phase_name cmd_line action = do + showPass logger phase_name + let + cmd_doc = text cmd_line + handle_exn exn = do + debugTraceMsg logger 2 (char '\n') + debugTraceMsg logger 2 (text "Failed:" <+> cmd_doc <+> text (show exn)) + throwGhcExceptionIO (ProgramError (show exn)) + debugTraceMsg logger 3 cmd_doc + loggerTraceFlush logger + -- And run it! + action `catchIO` handle_exn + + +-- * Tracing utility + +-- | Record in the eventlog when the given tool command starts +-- and finishes, prepending the given 'String' with +-- \"systool:\", to easily be able to collect and process +-- all the systool events. +-- +-- For those events to show up in the eventlog, you need +-- to run GHC with @-v2@ or @-ddump-timings@. +traceSystoolCommand :: Logger -> String -> IO a -> IO a +traceSystoolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ()) + + +{- Note [withTiming] +~~~~~~~~~~~~~~~~~~~~ + +For reference: + + withTiming + :: MonadIO + => m DynFlags -- how to get the DynFlags + -> SDoc -- label for the computation we're timing + -> (a -> ()) -- how to evaluate the result + -> PrintTimings -- whether to report the timings when passed + -- -v2 or -ddump-timings + -> m a -- computation we're timing + -> m a + +withTiming lets you run an action while: + +(1) measuring the CPU time it took and reporting that on stderr + (when PrintTimings is passed), +(2) emitting start/stop events to GHC's event log, with the label + given as an argument. + +Evaluation of the result +------------------------ + +'withTiming' takes as an argument a function of type 'a -> ()', whose purpose is +to evaluate the result "sufficiently". A given pass might return an 'm a' for +some monad 'm' and result type 'a', but where the 'a' is complex enough +that evaluating it to WHNF barely scratches its surface and leaves many +complex and time-consuming computations unevaluated. Those would only be +forced by the next pass, and the time needed to evaluate them would be +mis-attributed to that next pass. A more appropriate function would be +one that deeply evaluates the result, so as to assign the time spent doing it +to the pass we're timing. + +Note: as hinted at above, the time spent evaluating the application of the +forcing function to the result is included in the timings reported by +'withTiming'. + +How we use it +------------- + +We measure the time and allocations of various passes in GHC's pipeline by just +wrapping the whole pass with 'withTiming'. This also materializes by having +a label for each pass in the eventlog, where each pass is executed in one go, +during a continuous time window. + +However, from STG onwards, the pipeline uses streams to emit groups of +STG/Cmm/etc declarations one at a time, and process them until we get to +assembly code generation. This means that the execution of those last few passes +is interleaved and that we cannot measure how long they take by just wrapping +the whole thing with 'withTiming'. Instead we wrap the processing of each +individual stream element, all along the codegen pipeline, using the appropriate +label for the pass to which this processing belongs. That generates a lot more +data but allows us to get fine-grained timings about all the passes and we can +easily compute totals with tools like ghc-events-analyze (see below). + + +Producing an eventlog for GHC +----------------------------- + +You can produce an eventlog when compiling, for instance, hello.hs by simply +running: + + If GHC was built by Hadrian: + $ _build/stage1/bin/ghc -ddump-timings hello.hs -o hello +RTS -l + + If GHC was built with Make: + $ inplace/bin/ghc-stage2 -ddump-timing hello.hs -o hello +RTS -l + +You could alternatively use -v (with N >= 2) instead of -ddump-timings, +to ask GHC to report timings (on stderr and the eventlog). + +This will write the eventlog to ./ghc.eventlog in both cases. You can then +visualize it or look at the totals for each label by using ghc-events-analyze, +threadscope or any other eventlog consumer. Illustrating with +ghc-events-analyze: + + $ ghc-events-analyze --timed --timed-txt --totals \ + --start "GHC:started:" --stop "GHC:finished:" \ + ghc.eventlog + +This produces ghc.timed.txt (all event timestamps), ghc.timed.svg (visualisation +of the execution through the various labels) and ghc.totals.txt (total time +spent in each label). + +-} diff --git a/GHC/Utils/Exception.hs b/GHC/Utils/Exception.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Exception.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# LANGUAGE ConstraintKinds #-} + +module GHC.Utils.Exception + ( + module CE, + module GHC.Utils.Exception + ) + where + +import GHC.Prelude.Basic + +import GHC.IO (catchException) +import Control.Exception as CE hiding (assert) +import Control.Monad.IO.Class +import Control.Monad.Catch + +-- Monomorphised versions of exception-handling utilities +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO = catchException + +handleIO :: (IOException -> IO a) -> IO a -> IO a +handleIO = flip catchIO + +tryIO :: IO a -> IO (Either IOException a) +tryIO = CE.try + +type ExceptionMonad m = (MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) diff --git a/GHC/Utils/FV.hs b/GHC/Utils/FV.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/FV.hs @@ -0,0 +1,202 @@ +{- +(c) Bartosz Nitka, Facebook 2015 + +-} + +-- | Utilities for efficiently and deterministically computing free variables. +module GHC.Utils.FV ( + -- * Deterministic free vars computations + FV, InterestingVarFun, + + -- * Running the computations + fvVarList, fvVarSet, fvDVarSet, + + -- ** Manipulating those computations + unitFV, + emptyFV, + mkFVs, + unionFV, + unionsFV, + delFV, + delFVs, + filterFV, + mapUnionFV, + fvDVarSetSome, + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Var.Set + +-- | Predicate on possible free variables: returns @True@ iff the variable is +-- interesting +type InterestingVarFun = Var -> Bool + +-- Note [Deterministic FV] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- When computing free variables, the order in which you get them affects +-- the results of floating and specialization. If you use UniqFM to collect +-- them and then turn that into a list, you get them in nondeterministic +-- order as described in Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. + +-- A naive algorithm for free variables relies on merging sets of variables. +-- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log +-- factor. It's cheaper to incrementally add to a list and use a set to check +-- for duplicates. +type FV = InterestingVarFun -- Used for filtering sets as we build them + -> VarSet -- Locally bound variables + -> VarAcc -- Accumulator + -> VarAcc + +type VarAcc = ([Var], VarSet) -- List to preserve ordering and set to check for membership, + -- so that the list doesn't have duplicates + -- For explanation of why using `VarSet` is not deterministic see + -- Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. + +-- Note [FV naming conventions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- To get the performance and determinism that FV provides, FV computations +-- need to built up from smaller FV computations and then evaluated with +-- one of `fvVarList`, `fvDVarSet` That means the functions +-- returning FV need to be exported. +-- +-- The conventions are: +-- +-- a) non-deterministic functions: +-- * a function that returns VarSet +-- e.g. `tyVarsOfType` +-- b) deterministic functions: +-- * a worker that returns FV +-- e.g. `tyFVsOfType` +-- * a function that returns [Var] +-- e.g. `tyVarsOfTypeList` +-- * a function that returns DVarSet +-- e.g. `tyVarsOfTypeDSet` +-- +-- Where tyVarsOfType, tyVarsOfTypeList, tyVarsOfTypeDSet are implemented +-- in terms of the worker evaluated with fvVarSet, fvVarList, fvDVarSet +-- respectively. + +-- | Run a free variable computation, returning a list of distinct free +-- variables in deterministic order and a non-deterministic set containing +-- those variables. +fvVarAcc :: FV -> ([Var], VarSet) +fvVarAcc fv = fv (const True) emptyVarSet ([], emptyVarSet) + +-- | Run a free variable computation, returning a list of distinct free +-- variables in deterministic order. +fvVarList :: FV -> [Var] +fvVarList = fst . fvVarAcc + +-- | Run a free variable computation, returning a deterministic set of free +-- variables. Note that this is just a wrapper around the version that +-- returns a deterministic list. If you need a list you should use +-- `fvVarList`. +fvDVarSet :: FV -> DVarSet +fvDVarSet = mkDVarSet . fvVarList + +-- | Run a free variable computation, returning a non-deterministic set of +-- free variables. Don't use if the set will be later converted to a list +-- and the order of that list will impact the generated code. +fvVarSet :: FV -> VarSet +fvVarSet = snd . fvVarAcc + +-- Note [FV eta expansion] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- Let's consider an eta-reduced implementation of freeVarsOf using FV: +-- +-- freeVarsOf (App a b) = freeVarsOf a `unionFV` freeVarsOf b +-- +-- If GHC doesn't eta-expand it, after inlining unionFV we end up with +-- +-- freeVarsOf = \x -> +-- case x of +-- App a b -> \fv_cand in_scope acc -> +-- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc +-- +-- which has to create a thunk, resulting in more allocations. +-- +-- On the other hand if it is eta-expanded: +-- +-- freeVarsOf (App a b) fv_cand in_scope acc = +-- (freeVarsOf a `unionFV` freeVarsOf b) fv_cand in_scope acc +-- +-- after inlining unionFV we have: +-- +-- freeVarsOf = \x fv_cand in_scope acc -> +-- case x of +-- App a b -> +-- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc +-- +-- which saves allocations. +-- +-- GHC when presented with knowledge about all the call sites, correctly +-- eta-expands in this case. Unfortunately due to the fact that freeVarsOf gets +-- exported to be composed with other functions, GHC doesn't have that +-- information and has to be more conservative here. +-- +-- Hence functions that get exported and return FV need to be manually +-- eta-expanded. See also #11146. + +-- | Add a variable - when free, to the returned free variables. +-- Ignores duplicates and respects the filtering function. +unitFV :: Id -> FV +unitFV var fv_cand in_scope acc@(have, haveSet) + | var `elemVarSet` in_scope = acc + | var `elemVarSet` haveSet = acc + | fv_cand var = (var:have, extendVarSet haveSet var) + | otherwise = acc +{-# INLINE unitFV #-} + +-- | Return no free variables. +emptyFV :: FV +emptyFV _ _ acc = acc +{-# INLINE emptyFV #-} + +-- | Union two free variable computations. +unionFV :: FV -> FV -> FV +unionFV fv1 fv2 fv_cand in_scope acc = + fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc +{-# INLINE unionFV #-} + +-- | Mark the variable as not free by putting it in scope. +delFV :: Var -> FV -> FV +delFV var fv fv_cand !in_scope acc = + fv fv_cand (extendVarSet in_scope var) acc +{-# INLINE delFV #-} + +-- | Mark many free variables as not free. +delFVs :: VarSet -> FV -> FV +delFVs vars fv fv_cand !in_scope acc = + fv fv_cand (in_scope `unionVarSet` vars) acc +{-# INLINE delFVs #-} + +-- | Filter a free variable computation. +filterFV :: InterestingVarFun -> FV -> FV +filterFV fv_cand2 fv fv_cand1 in_scope acc = + fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc +{-# INLINE filterFV #-} + +-- | Map a free variable computation over a list and union the results. +mapUnionFV :: (a -> FV) -> [a] -> FV +mapUnionFV _f [] _fv_cand _in_scope acc = acc +mapUnionFV f (a:as) fv_cand in_scope acc = + mapUnionFV f as fv_cand in_scope $! f a fv_cand in_scope $! acc +{-# INLINABLE mapUnionFV #-} + +-- | Union many free variable computations. +unionsFV :: [FV] -> FV +unionsFV fvs fv_cand in_scope acc = mapUnionFV id fvs fv_cand in_scope acc +{-# INLINE unionsFV #-} + +-- | Add multiple variables - when free, to the returned free variables. +-- Ignores duplicates and respects the filtering function. +mkFVs :: [Var] -> FV +mkFVs vars fv_cand in_scope acc = + mapUnionFV unitFV vars fv_cand in_scope acc +{-# INLINE mkFVs #-} + +fvDVarSetSome :: InterestingVarFun -> FV -> DVarSet +fvDVarSetSome interesting_var fv = + mkDVarSet $ fst $ fv interesting_var emptyVarSet ([], emptyVarSet) diff --git a/GHC/Utils/Fingerprint.hs b/GHC/Utils/Fingerprint.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Fingerprint.hs @@ -0,0 +1,50 @@ + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- ---------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- +-- Fingerprints for recompilation checking and ABI versioning. +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance +-- +-- ---------------------------------------------------------------------------- + +module GHC.Utils.Fingerprint ( + readHexFingerprint, + fingerprintByteString, + -- * Re-exported from GHC.Fingerprint + Fingerprint(..), fingerprint0, + fingerprintFingerprints, + fingerprintData, + fingerprintString, + fingerprintStrings, + getFileHash + ) where + +import GHC.Prelude.Basic + +import Foreign +import GHC.IO +import Numeric ( readHex ) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +import GHC.Fingerprint + +-- useful for parsing the output of 'md5sum', should we want to do that. +readHexFingerprint :: String -> Fingerprint +readHexFingerprint s = Fingerprint w1 w2 + where (s1,s2) = splitAt 16 s + [(w1,"")] = readHex s1 + [(w2,"")] = readHex (take 16 s2) + +fingerprintByteString :: BS.ByteString -> Fingerprint +fingerprintByteString bs = unsafeDupablePerformIO $ + BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len + +-- See Note [Repeated -optP hashing] +fingerprintStrings :: [String] -> Fingerprint +fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss diff --git a/GHC/Utils/GlobalVars.hs b/GHC/Utils/GlobalVars.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/GlobalVars.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +-- | Do not use global variables! +-- +-- Global variables are a hack. Do not use them if you can help it. +module GHC.Utils.GlobalVars + ( v_unsafeHasPprDebug + , v_unsafeHasNoDebugOutput + , v_unsafeHasNoStateHack + , unsafeHasPprDebug + , unsafeHasNoDebugOutput + , unsafeHasNoStateHack + + , global + , consIORef + , globalM + , sharedGlobal + , sharedGlobalM + ) +where + +import GHC.Prelude.Basic + +import GHC.Conc.Sync ( sharedCAF ) + +import System.IO.Unsafe +import Data.IORef +import Foreign (Ptr) + +#define GLOBAL_VAR(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = global (value); + +#define GLOBAL_VAR_M(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = globalM (value); + + +#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = sharedGlobal (value) (accessor); \ +foreign import ccall unsafe saccessor \ + accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); + +#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = sharedGlobalM (value) (accessor); \ +foreign import ccall unsafe saccessor \ + accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); + + + +SHARED_GLOBAL_VAR( v_unsafeHasPprDebug + , getOrSetLibHSghcGlobalHasPprDebug + , "getOrSetLibHSghcGlobalHasPprDebug" + , False + , Bool ) +SHARED_GLOBAL_VAR( v_unsafeHasNoDebugOutput + , getOrSetLibHSghcGlobalHasNoDebugOutput + , "getOrSetLibHSghcGlobalHasNoDebugOutput" + , False + , Bool ) +SHARED_GLOBAL_VAR( v_unsafeHasNoStateHack + , getOrSetLibHSghcGlobalHasNoStateHack + , "getOrSetLibHSghcGlobalHasNoStateHack" + , False + , Bool ) + +unsafeHasPprDebug :: Bool +unsafeHasPprDebug = unsafePerformIO $ readIORef v_unsafeHasPprDebug + +unsafeHasNoDebugOutput :: Bool +unsafeHasNoDebugOutput = unsafePerformIO $ readIORef v_unsafeHasNoDebugOutput + +unsafeHasNoStateHack :: Bool +unsafeHasNoStateHack = unsafePerformIO $ readIORef v_unsafeHasNoStateHack + +{- +************************************************************************ +* * + Globals and the RTS +* * +************************************************************************ + +When a plugin is loaded, it currently gets linked against a *newly +loaded* copy of the GHC package. This would not be a problem, except +that the new copy has its own mutable state that is not shared with +that state that has already been initialized by the original GHC +package. + +(Note that if the GHC executable was dynamically linked this +wouldn't be a problem, because we could share the GHC library it +links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) + +The solution is to make use of @sharedCAF@ through @sharedGlobal@ +for globals that are shared between multiple copies of ghc packages. +-} + +-- Global variables: + +global :: a -> IORef a +global a = unsafePerformIO (newIORef a) + +consIORef :: IORef [a] -> a -> IO () +consIORef var x = + atomicModifyIORef' var (\xs -> (x:xs,())) + +globalM :: IO a -> IORef a +globalM ma = unsafePerformIO (ma >>= newIORef) + +-- Shared global variables: + +sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a +sharedGlobal a get_or_set = unsafePerformIO $ + newIORef a >>= flip sharedCAF get_or_set + +sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a +sharedGlobalM ma get_or_set = unsafePerformIO $ + ma >>= newIORef >>= flip sharedCAF get_or_set diff --git a/GHC/Utils/IO/Unsafe.hs b/GHC/Utils/IO/Unsafe.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/IO/Unsafe.hs @@ -0,0 +1,20 @@ +{- +(c) The University of Glasgow, 2000-2006 +-} + +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +module GHC.Utils.IO.Unsafe + ( inlinePerformIO, + ) +where + +import GHC.Prelude.Basic () + +import GHC.Exts +import GHC.IO (IO(..)) + +-- Just like unsafeDupablePerformIO, but we inline it. +{-# INLINE inlinePerformIO #-} +inlinePerformIO :: IO a -> a +inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r diff --git a/GHC/Utils/Json.hs b/GHC/Utils/Json.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Json.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +module GHC.Utils.Json where + +import GHC.Prelude + +import GHC.Utils.Outputable +import Data.Char +import Numeric + +-- | Simple data type to represent JSON documents. +data JsonDoc where + JSNull :: JsonDoc + JSBool :: Bool -> JsonDoc + JSInt :: Int -> JsonDoc + JSString :: String -> JsonDoc + -- ^ The 'String' is unescaped + JSArray :: [JsonDoc] -> JsonDoc + JSObject :: [(String, JsonDoc)] -> JsonDoc + + +-- This is simple and slow as it is only used for error reporting +renderJSON :: JsonDoc -> SDoc +renderJSON d = + case d of + JSNull -> text "null" + JSBool b -> if b then text "true" else text "false" + JSInt n -> ppr n + JSString s -> doubleQuotes $ text $ escapeJsonString s + JSArray as -> brackets $ pprList renderJSON as + JSObject fs -> braces $ pprList renderField fs + where + renderField :: (String, JsonDoc) -> SDoc + renderField (s, j) = doubleQuotes (text s) <> colon <> renderJSON j + + pprList pp xs = hcat (punctuate comma (map pp xs)) + +escapeJsonString :: String -> String +escapeJsonString = concatMap escapeChar + where + escapeChar '\b' = "\\b" + escapeChar '\f' = "\\f" + escapeChar '\n' = "\\n" + escapeChar '\r' = "\\r" + escapeChar '\t' = "\\t" + escapeChar '"' = "\\\"" + escapeChar '\\' = "\\\\" + escapeChar c | isControl c || fromEnum c >= 0x7f = uni_esc c + escapeChar c = [c] + + uni_esc c = "\\u" ++ (pad 4 (showHex (fromEnum c) "")) + + pad n cs | len < n = replicate (n-len) '0' ++ cs + | otherwise = cs + where len = length cs + +class ToJson a where + json :: a -> JsonDoc + +instance ToJson String where + json = JSString + +instance ToJson Int where + json = JSInt diff --git a/GHC/Utils/Lexeme.hs b/GHC/Utils/Lexeme.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Lexeme.hs @@ -0,0 +1,240 @@ +-- (c) The GHC Team +-- +-- Functions to evaluate whether or not a string is a valid identifier. +-- There is considerable overlap between the logic here and the logic +-- in GHC.Parser.Lexer, but sadly there seems to be no way to merge them. + +module GHC.Utils.Lexeme ( + -- * Lexical characteristics of Haskell names + + -- | Use these functions to figure what kind of name a 'FastString' + -- represents; these functions do /not/ check that the identifier + -- is valid. + + isLexCon, isLexVar, isLexId, isLexSym, + isLexConId, isLexConSym, isLexVarId, isLexVarSym, + startsVarSym, startsVarId, startsConSym, startsConId, + + -- * Validating identifiers + + -- | These functions (working over plain old 'String's) check + -- to make sure that the identifier is valid. + okVarOcc, okConOcc, okTcOcc, + okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc + + -- Some of the exports above are not used within GHC, but may + -- be of value to GHC API users. + + ) where + +import GHC.Prelude + +import GHC.Data.FastString + +import Data.Char +import qualified Data.Set as Set + +import GHC.Lexeme + +{- + +************************************************************************ +* * + Lexical categories +* * +************************************************************************ + +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. + +Note [Classification of generated names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some names generated for internal use can show up in debugging output, +e.g. when using -ddump-simpl. These generated names start with a $ +but should still be pretty-printed using prefix notation. We make sure +this is the case in isLexVarSym by only classifying a name as a symbol +if all its characters are symbols, not just its first one. +-} + +isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool + +isLexCon cs = isLexConId cs || isLexConSym cs +isLexVar cs = isLexVarId cs || isLexVarSym cs + +isLexId cs = isLexConId cs || isLexVarId cs +isLexSym cs = isLexConSym cs || isLexVarSym cs + +------------- +isLexConId cs = case unpackFS cs of -- Prefix type or data constructors + [] -> False -- e.g. "Foo", "[]", "(,)" + c:_ -> cs == fsLit "[]" || startsConId c + +isLexVarId cs = case unpackFS cs of -- Ordinary prefix identifiers + [] -> False -- e.g. "x", "_x" + c:_ -> startsVarId c + +isLexConSym cs = case unpackFS cs of -- Infix type or data constructors + [] -> False -- e.g. ":-:", ":", "->" + c:_ -> cs == fsLit "->" || startsConSym c + +isLexVarSym fs -- Infix identifiers e.g. "+" + | fs == (fsLit "~R#") = True + | otherwise + = case (if nullFS fs then [] else unpackFS fs) of + [] -> False + (c:cs) -> startsVarSym c && all isVarSymChar cs + -- See Note [Classification of generated names] + +{- + +************************************************************************ +* * + Detecting valid names for Template Haskell +* * +************************************************************************ + +-} + +---------------------- +-- External interface +---------------------- + +-- | Is this an acceptable variable name? +okVarOcc :: String -> Bool +okVarOcc str@(c:_) + | startsVarId c + = okVarIdOcc str + | startsVarSym c + = okVarSymOcc str +okVarOcc _ = False + +-- | Is this an acceptable constructor name? +okConOcc :: String -> Bool +okConOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | str == "[]" + = True +okConOcc _ = False + +-- | Is this an acceptable type name? +okTcOcc :: String -> Bool +okTcOcc "[]" = True +okTcOcc "->" = True +okTcOcc "~" = True +okTcOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | startsVarSym c + = okVarSymOcc str +okTcOcc _ = False + +-- | Is this an acceptable alphanumeric variable name, assuming it starts +-- with an acceptable letter? +okVarIdOcc :: String -> Bool +okVarIdOcc str = okIdOcc str && + -- admit "_" as a valid identifier. Required to support typed + -- holes in Template Haskell. See #10267 + (str == "_" || not (str `Set.member` reservedIds)) + +-- | Is this an acceptable symbolic variable name, assuming it starts +-- with an acceptable character? +okVarSymOcc :: String -> Bool +okVarSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) && + not (isDashes str) + +-- | Is this an acceptable alphanumeric constructor name, assuming it +-- starts with an acceptable letter? +okConIdOcc :: String -> Bool +okConIdOcc str = okIdOcc str || + is_tuple_name1 True str || + -- Is it a boxed tuple... + is_tuple_name1 False str || + -- ...or an unboxed tuple (#12407)... + is_sum_name1 str + -- ...or an unboxed sum (#12514)? + where + -- check for tuple name, starting at the beginning + is_tuple_name1 True ('(' : rest) = is_tuple_name2 True rest + is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest + is_tuple_name1 _ _ = False + + -- check for tuple tail + is_tuple_name2 True ")" = True + is_tuple_name2 False "#)" = True + is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest + is_tuple_name2 boxed (ws : rest) + | isSpace ws = is_tuple_name2 boxed rest + is_tuple_name2 _ _ = False + + -- check for sum name, starting at the beginning + is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest + is_sum_name1 _ = False + + -- check for sum tail, only allowing at most one underscore + is_sum_name2 _ "#)" = True + is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest + is_sum_name2 False ('_' : rest) = is_sum_name2 True rest + is_sum_name2 underscore (ws : rest) + | isSpace ws = is_sum_name2 underscore rest + is_sum_name2 _ _ = False + +-- | Is this an acceptable symbolic constructor name, assuming it +-- starts with an acceptable character? +okConSymOcc :: String -> Bool +okConSymOcc ":" = True +okConSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) + +---------------------- +-- Internal functions +---------------------- + +-- | Is this string an acceptable id, possibly with a suffix of hashes, +-- but not worrying about case or clashing with reserved words? +okIdOcc :: String -> Bool +okIdOcc str + = let hashes = dropWhile okIdChar str in + all (== '#') hashes -- -XMagicHash allows a suffix of hashes + -- of course, `all` says "True" to an empty list + +-- | Is this character acceptable in an identifier (after the first letter)? +-- See alexGetByte in GHC.Parser.Lexer +okIdChar :: Char -> Bool +okIdChar c = case generalCategory c of + UppercaseLetter -> True + LowercaseLetter -> True + TitlecaseLetter -> True + ModifierLetter -> True -- See #10196 + OtherLetter -> True -- See #1103 + NonSpacingMark -> True -- See #7650 + DecimalNumber -> True + OtherNumber -> True -- See #4373 + _ -> c == '\'' || c == '_' + +-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report, +-- plus the GHC-specific @forall@ keyword (see GHC Proposal #281). +reservedIds :: Set.Set String +reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" + , "do", "else", "forall", "foreign", "if", "import" + , "in", "infix", "infixl", "infixr", "instance" + , "let", "module", "newtype", "of", "then", "type" + , "where", "_" ] + +-- | All reserved operators. Taken from section 2.4 of the 2010 Report, +-- excluding @\@@ and @~@ that are allowed by GHC (see GHC Proposal #229). +reservedOps :: Set.Set String +reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" + , "=>" ] + +-- | Does this string contain only dashes and has at least 2 of them? +isDashes :: String -> Bool +isDashes ('-' : '-' : rest) = all (== '-') rest +isDashes _ = False diff --git a/GHC/Utils/Logger.hs b/GHC/Utils/Logger.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Logger.hs @@ -0,0 +1,674 @@ +{-# LANGUAGE RankNTypes #-} + +-- | Logger +-- +-- The Logger is an configurable entity that is used by the compiler to output +-- messages on the console (stdout, stderr) and in dump files. +-- +-- The behaviour of default Logger returned by `initLogger` can be modified with +-- hooks. The compiler itself uses hooks in multithreaded code (--make) and it +-- is also probably used by ghc-api users (IDEs, etc.). +-- +-- In addition to hooks, the Logger supports LogFlags: basically a subset of the +-- command-line flags that control the logger behaviour at a higher level than +-- hooks. +-- +-- 1. Hooks are used to define how to generate a info/warning/error/dump messages +-- 2. LogFlags are used to decide when and how to generate messages +-- +module GHC.Utils.Logger + ( Logger + , HasLogger (..) + , ContainsLogger (..) + + -- * Logger setup + , initLogger + , LogAction + , LogJsonAction + , DumpAction + , TraceAction + , DumpFormat (..) + + -- ** Hooks + , popLogHook + , pushLogHook + , popJsonLogHook + , pushJsonLogHook + , popDumpHook + , pushDumpHook + , popTraceHook + , pushTraceHook + , makeThreadSafe + + -- ** Flags + , LogFlags (..) + , defaultLogFlags + , log_dopt + , log_set_dopt + , setLogFlags + , updateLogFlags + , logFlags + , logHasDumpFlag + , logVerbAtLeast + + -- * Logging + , putLogMsg + , defaultLogAction + , defaultLogActionWithHandles + , defaultLogJsonAction + , defaultLogActionHPrintDoc + , defaultLogActionHPutStrDoc + , logMsg + , logJsonMsg + , logDumpMsg + + -- * Dumping + , defaultDumpAction + , putDumpFile + , putDumpFileMaybe + , putDumpFileMaybe' + , withDumpFileHandle + , touchDumpFile + , logDumpFile + + -- * Tracing + , defaultTraceAction + , putTraceMsg + , loggerTraceFlushUpdate + , loggerTraceFlush + , logTraceMsg + ) +where + +import GHC.Prelude +import GHC.Driver.Flags +import GHC.Types.Error +import GHC.Types.SrcLoc + +import qualified GHC.Utils.Ppr as Pretty +import GHC.Utils.Outputable +import GHC.Utils.Json +import GHC.Utils.Panic + +import GHC.Data.EnumSet (EnumSet) +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.FastString + +import System.Directory +import System.FilePath ( takeDirectory, () ) +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Data.List (stripPrefix) +import Data.Time +import System.IO +import Control.Monad +import Control.Concurrent.MVar +import System.IO.Unsafe +import Debug.Trace (trace) +import GHC.Platform.Ways + +--------------------------------------------------------------- +-- Log flags +--------------------------------------------------------------- + +-- | Logger flags +data LogFlags = LogFlags + { log_default_user_context :: SDocContext + , log_default_dump_context :: SDocContext + , log_dump_flags :: !(EnumSet DumpFlag) -- ^ Dump flags + , log_show_caret :: !Bool -- ^ Show caret in diagnostics + , log_diagnostics_as_json :: !Bool -- ^ Format diagnostics as JSON + , log_show_warn_groups :: !Bool -- ^ Show warning flag groups + , log_enable_timestamps :: !Bool -- ^ Enable timestamps + , log_dump_to_file :: !Bool -- ^ Enable dump to file + , log_dump_dir :: !(Maybe FilePath) -- ^ Dump directory + , log_dump_prefix :: !FilePath -- ^ Normal dump path ("basename.") + , log_dump_prefix_override :: !(Maybe FilePath) -- ^ Overriden dump path + , log_with_ways :: !Bool -- ^ Use different dump files names for different ways + , log_enable_debug :: !Bool -- ^ Enable debug output + , log_verbosity :: !Int -- ^ Verbosity level + , log_ways :: !(Maybe Ways) -- ^ Current ways (to name dump files) + } + +-- | Default LogFlags +defaultLogFlags :: LogFlags +defaultLogFlags = LogFlags + { log_default_user_context = defaultSDocContext + , log_default_dump_context = defaultSDocContext + , log_dump_flags = EnumSet.empty + , log_show_caret = True + , log_diagnostics_as_json = False + , log_show_warn_groups = True + , log_enable_timestamps = True + , log_dump_to_file = False + , log_dump_dir = Nothing + , log_dump_prefix = "" + , log_dump_prefix_override = Nothing + , log_with_ways = True + , log_enable_debug = False + , log_verbosity = 0 + , log_ways = Nothing + } + +-- | Test if a DumpFlag is enabled +log_dopt :: DumpFlag -> LogFlags -> Bool +log_dopt = getDumpFlagFrom log_verbosity log_dump_flags + +-- | Enable a DumpFlag +log_set_dopt :: DumpFlag -> LogFlags -> LogFlags +log_set_dopt f logflags = logflags { log_dump_flags = EnumSet.insert f (log_dump_flags logflags) } + +-- | Test if a DumpFlag is set +logHasDumpFlag :: Logger -> DumpFlag -> Bool +logHasDumpFlag logger f = log_dopt f (logFlags logger) + +-- | Test if verbosity is >= to the given value +logVerbAtLeast :: Logger -> Int -> Bool +logVerbAtLeast logger v = log_verbosity (logFlags logger) >= v + +-- | Update LogFlags +updateLogFlags :: Logger -> (LogFlags -> LogFlags) -> Logger +updateLogFlags logger f = setLogFlags logger (f (logFlags logger)) + +-- | Set LogFlags +setLogFlags :: Logger -> LogFlags -> Logger +setLogFlags logger flags = logger { logFlags = flags } + + +--------------------------------------------------------------- +-- Logger +--------------------------------------------------------------- + +type LogAction = LogFlags + -> MessageClass + -> SrcSpan + -> SDoc + -> IO () + +type LogJsonAction = LogFlags + -> MessageClass + -> JsonDoc + -> IO () + +type DumpAction = LogFlags + -> PprStyle + -> DumpFlag + -> String + -> DumpFormat + -> SDoc + -> IO () + +type TraceAction a = LogFlags -> String -> SDoc -> a -> a + +-- | Format of a dump +-- +-- Dump formats are loosely defined: dumps may contain various additional +-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint +-- (e.g. for syntax highlighters). +data DumpFormat + = FormatHaskell -- ^ Haskell + | FormatCore -- ^ Core + | FormatSTG -- ^ STG + | FormatByteCode -- ^ ByteCode + | FormatCMM -- ^ Cmm + | FormatASM -- ^ Assembly code + | FormatC -- ^ C code/header + | FormatLLVM -- ^ LLVM bytecode + | FormatJS -- ^ JavaScript code + | FormatText -- ^ Unstructured dump + deriving (Show,Eq) + +-- | A set of the dump files to which we have written thusfar. Each dump file +-- has a corresponding MVar to ensure that a dump file has at most one active +-- writer at a time, avoiding interleaved output. +type DumpCache = MVar (Map FilePath (MVar ())) + +data Logger = Logger + { log_hook :: [LogAction -> LogAction] + -- ^ Log hooks stack + + , json_log_hook :: [LogJsonAction -> LogJsonAction] + -- ^ Json log hooks stack + + , dump_hook :: [DumpAction -> DumpAction] + -- ^ Dump hooks stack + + , trace_hook :: forall a. [TraceAction a -> TraceAction a] + -- ^ Trace hooks stack + + , generated_dumps :: DumpCache + -- ^ Already dumped files (to append instead of overwriting them) + + , trace_flush :: IO () + -- ^ Flush the trace buffer + + , logFlags :: !LogFlags + -- ^ Logger flags + } + +-- | Set the trace flushing function +-- +-- The currently set trace flushing function is passed to the updating function +loggerTraceFlushUpdate :: Logger -> (IO () -> IO ()) -> Logger +loggerTraceFlushUpdate logger upd = logger { trace_flush = upd (trace_flush logger) } + +-- | Calls the trace flushing function +loggerTraceFlush :: Logger -> IO () +loggerTraceFlush logger = trace_flush logger + +-- | Default trace flushing function (flush stderr) +defaultTraceFlush :: IO () +defaultTraceFlush = hFlush stderr + +initLogger :: IO Logger +initLogger = do + dumps <- newMVar Map.empty + return $ Logger + { log_hook = [] + , json_log_hook = [] + , dump_hook = [] + , trace_hook = [] + , generated_dumps = dumps + , trace_flush = defaultTraceFlush + , logFlags = defaultLogFlags + } + +-- | Log something +putLogMsg :: Logger -> LogAction +putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) + +-- | Log a JsonDoc +putJsonLogMsg :: Logger -> LogJsonAction +putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger) + +-- | Dump something +putDumpFile :: Logger -> DumpAction +putDumpFile logger = + let + fallback = putLogMsg logger + dumps = generated_dumps logger + deflt = defaultDumpAction dumps fallback + in foldr ($) deflt (dump_hook logger) + +-- | Trace something +putTraceMsg :: Logger -> TraceAction a +putTraceMsg logger = foldr ($) defaultTraceAction (trace_hook logger) + + +-- | Push a log hook +pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger +pushLogHook h logger = logger { log_hook = h:log_hook logger } + +-- | Pop a log hook +popLogHook :: Logger -> Logger +popLogHook logger = case log_hook logger of + [] -> panic "popLogHook: empty hook stack" + _:hs -> logger { log_hook = hs } + +-- | Push a json log hook +pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger +pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger } + +popJsonLogHook :: Logger -> Logger +popJsonLogHook logger = case json_log_hook logger of + [] -> panic "popJsonLogHook: empty hook stack" + _:hs -> logger { json_log_hook = hs} + +-- | Push a dump hook +pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger +pushDumpHook h logger = logger { dump_hook = h:dump_hook logger } + +-- | Pop a dump hook +popDumpHook :: Logger -> Logger +popDumpHook logger = case dump_hook logger of + [] -> panic "popDumpHook: empty hook stack" + _:hs -> logger { dump_hook = hs } + +-- | Push a trace hook +pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger +pushTraceHook h logger = logger { trace_hook = h:trace_hook logger } + +-- | Pop a trace hook +popTraceHook :: Logger -> Logger +popTraceHook logger = case trace_hook logger of + [] -> panic "popTraceHook: empty hook stack" + _ -> logger { trace_hook = tail (trace_hook logger) } + +-- | Make the logger thread-safe +makeThreadSafe :: Logger -> IO Logger +makeThreadSafe logger = do + lock <- newMVar () + let + with_lock :: forall a. IO a -> IO a + with_lock act = withMVar lock (const act) + + log action logflags msg_class loc doc = + with_lock (action logflags msg_class loc doc) + + dmp action logflags sty opts str fmt doc = + with_lock (action logflags sty opts str fmt doc) + + trc :: forall a. TraceAction a -> TraceAction a + trc action logflags str doc v = + unsafePerformIO (with_lock (return $! action logflags str doc v)) + + return $ pushLogHook log + $ pushDumpHook dmp + $ pushTraceHook trc + $ logger + +-- See Note [JSON Error Messages] +defaultLogJsonAction :: LogJsonAction +defaultLogJsonAction logflags msg_class jsdoc = + case msg_class of + MCOutput -> printOut msg + MCDump -> printOut (msg $$ blankLine) + MCInteractive -> putStrSDoc msg + MCInfo -> printErrs msg + MCFatal -> printErrs msg + MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message + MCDiagnostic _sev _rea _code -> printErrs msg + where + printOut = defaultLogActionHPrintDoc logflags False stdout + printErrs = defaultLogActionHPrintDoc logflags False stderr + putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout + msg = renderJSON jsdoc + +-- See Note [JSON Error Messages] +-- this is to be removed +jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction +jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message +jsonLogActionWithHandle out logflags msg_class srcSpan msg + = + defaultLogActionHPutStrDoc logflags True out + (withPprStyle PprCode (doc $$ text "")) + where + str = renderWithContext (log_default_user_context logflags) msg + doc = renderJSON $ + JSObject [ ( "span", spanToDumpJSON srcSpan ) + , ( "doc" , JSString str ) + , ( "messageClass", json msg_class ) + ] + spanToDumpJSON :: SrcSpan -> JsonDoc + spanToDumpJSON s = case s of + (RealSrcSpan rss _) -> JSObject [ ("file", json file) + , ("startLine", json $ srcSpanStartLine rss) + , ("startCol", json $ srcSpanStartCol rss) + , ("endLine", json $ srcSpanEndLine rss) + , ("endCol", json $ srcSpanEndCol rss) + ] + where file = unpackFS $ srcSpanFile rss + UnhelpfulSpan _ -> JSNull + +-- | The default 'LogAction' prints to 'stdout' and 'stderr'. +-- +-- To replicate the default log action behaviour with different @out@ and @err@ +-- handles, see 'defaultLogActionWithHandles'. +defaultLogAction :: LogAction +defaultLogAction = defaultLogActionWithHandles stdout stderr + +-- | The default 'LogAction' parametrized over the standard output and standard error handles. +-- Allows clients to replicate the log message formatting of GHC with custom handles. +defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction +defaultLogActionWithHandles out err logflags msg_class srcSpan msg + | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg + | otherwise = case msg_class of + MCOutput -> printOut msg + MCDump -> printOut (msg $$ blankLine) + MCInteractive -> putStrSDoc msg + MCInfo -> printErrs msg + MCFatal -> printErrs msg + MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message + MCDiagnostic _sev _rea _code -> printDiagnostics + where + printOut = defaultLogActionHPrintDoc logflags False out + printErrs = defaultLogActionHPrintDoc logflags False err + putStrSDoc = defaultLogActionHPutStrDoc logflags False out + -- Pretty print the warning flag, if any (#10752) + message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg + + printDiagnostics = do + caretDiagnostic <- + if log_show_caret logflags + then getCaretDiagnostic msg_class srcSpan + else pure empty + printErrs $ getPprStyle $ \style -> + withPprStyle (setStyleColoured True style) + (message $+$ caretDiagnostic $+$ blankLine) + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + +-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. +defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () +defaultLogActionHPrintDoc logflags asciiSpace h d + = defaultLogActionHPutStrDoc logflags asciiSpace h (d $$ text "") + +-- | The boolean arguments let's the pretty printer know if it can optimize indent +-- by writing ascii ' ' characters without going through decoding. +defaultLogActionHPutStrDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () +defaultLogActionHPutStrDoc logflags asciiSpace h d + -- Don't add a newline at the end, so that successive + -- calls to this log-action can output all on the same line + = printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d + +-- +-- Note [JSON Error Messages] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- When the user requests the compiler output to be dumped as json +-- we used to collect them all in an IORef and then print them at the end. +-- This doesn't work very well with GHCi. (See #14078) So instead we now +-- use the simpler method of just outputting a JSON document inplace to +-- stdout. +-- +-- Before the compiler calls log_action, it has already turned the `ErrMsg` +-- into a formatted message. This means that we lose some possible +-- information to provide to the user but refactoring log_action is quite +-- invasive as it is called in many places. So, for now I left it alone +-- and we can refine its behaviour as users request different output. +-- +-- The recent work here replaces the purpose of flag -ddump-json with +-- -fdiagnostics-as-json. For temporary backwards compatibility while +-- -ddump-json is being deprecated, `jsonLogAction` has been added in, but +-- it should be removed along with -ddump-json. Similarly, the guard in +-- `defaultLogAction` should be removed. This cleanup is tracked in #24113. + +-- | Default action for 'dumpAction' hook +defaultDumpAction :: DumpCache -> LogAction -> DumpAction +defaultDumpAction dumps log_action logflags sty flag title _fmt doc = + dumpSDocWithStyle dumps log_action sty logflags flag title doc + +-- | Write out a dump. +-- +-- If --dump-to-file is set then this goes to a file. +-- otherwise emit to stdout (via the LogAction parameter). +-- +-- When @hdr@ is empty, we print in a more compact format (no separators and +-- blank lines) +dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> LogFlags -> DumpFlag -> String -> SDoc -> IO () +dumpSDocWithStyle dumps log_action sty logflags flag hdr doc = + withDumpFileHandle dumps logflags flag writeDump + where + -- write dump to file + writeDump (Just handle) = do + doc' <- if null hdr + then return doc + else do timeStamp <- if log_enable_timestamps logflags + then (text . show) <$> getCurrentTime + else pure empty + let d = timeStamp + $$ blankLine + $$ doc + return $ mkDumpDoc hdr d + -- When we dump to files we use UTF8. Which allows ascii spaces. + defaultLogActionHPrintDoc logflags True handle (withPprStyle sty doc') + + -- write the dump to stdout + writeDump Nothing = do + let (doc', msg_class) + | null hdr = (doc, MCOutput) + | otherwise = (mkDumpDoc hdr doc, MCDump) + log_action logflags msg_class noSrcSpan (withPprStyle sty doc') + + +-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a +-- file, otherwise 'Nothing'. +withDumpFileHandle :: DumpCache -> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO () +withDumpFileHandle dumps logflags flag action = do + let dump_ways = log_ways logflags + let mFile = chooseDumpFile logflags dump_ways flag + case mFile of + Just fileName -> do + lock <- modifyMVar dumps $ \gd -> + case Map.lookup fileName gd of + Nothing -> do + lock <- newMVar () + let gd' = Map.insert fileName lock gd + -- ensure that file exists so we can append to it + createDirectoryIfMissing True (takeDirectory fileName) + writeFile fileName "" + return (gd', lock) + Just lock -> do + return (gd, lock) + + let withLock k = withMVar lock $ \() -> k >> return () + withLock $ withFile fileName AppendMode $ \handle -> do + -- We do not want the dump file to be affected by + -- environment variables, but instead to always use + -- UTF8. See: + -- https://gitlab.haskell.org/ghc/ghc/issues/10762 + hSetEncoding handle utf8 + + action (Just handle) + Nothing -> action Nothing + +-- | Choose where to put a dump file based on LogFlags and DumpFlag +chooseDumpFile :: LogFlags -> Maybe Ways -> DumpFlag -> Maybe FilePath +chooseDumpFile logflags ways flag + | log_dump_to_file logflags || forced_to_file + = Just $ setDir (getPrefix ++ way_infix ++ dump_suffix) + + | otherwise + = Nothing + where + way_infix = case ways of + _ | not (log_with_ways logflags) -> "" + Nothing -> "" + Just ws + | null ws || null (waysTag ws) -> "" + | otherwise -> waysTag ws ++ "." + (forced_to_file, dump_suffix) = case flag of + -- -dth-dec-file dumps expansions of TH + -- splices into MODULE.th.hs even when + -- -ddump-to-file isn't set + Opt_D_th_dec_file -> (True, "th.hs") + _ -> (False, default_suffix) + + -- build a suffix from the flag name + -- e.g. -ddump-asm => ".dump-asm" + default_suffix = map (\c -> if c == '_' then '-' else c) $ + let str = show flag + in case stripPrefix "Opt_D_" str of + Just x -> x + Nothing -> panic ("chooseDumpFile: bad flag name: " ++ str) + + getPrefix + -- dump file location is being forced + -- by the -ddump-file-prefix flag. + | Just prefix <- log_dump_prefix_override logflags + = prefix + -- dump file locations, module specified to [modulename] set by + -- GHC.Driver.Pipeline.runPipeline; non-module specific, e.g. Chasing dependencies, + -- to 'non-module' by default. + | otherwise + = log_dump_prefix logflags + setDir f = case log_dump_dir logflags of + Just d -> d f + Nothing -> f + + + +-- | Default action for 'traceAction' hook +defaultTraceAction :: TraceAction a +defaultTraceAction logflags title doc x = + if not (log_enable_debug logflags) + then x + else trace (renderWithContext (log_default_dump_context logflags) + (sep [text title, nest 2 doc])) x + + +-- | Log something +logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () +logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg + +logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO () +logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d) + +-- | Dump something +logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +logDumpFile logger = putDumpFile logger (logFlags logger) + +-- | Log a trace message +logTraceMsg :: Logger -> String -> SDoc -> a -> a +logTraceMsg logger hdr doc a = putTraceMsg logger (logFlags logger) hdr doc a + +-- | Log a dump message (not a dump file) +logDumpMsg :: Logger -> String -> SDoc -> IO () +logDumpMsg logger hdr doc = logMsg logger MCDump noSrcSpan + (withPprStyle defaultDumpStyle + (mkDumpDoc hdr doc)) + +mkDumpDoc :: String -> SDoc -> SDoc +mkDumpDoc hdr doc + = vcat [blankLine, + line <+> text hdr <+> line, + doc, + blankLine] + where + line = text "====================" + + +-- | Dump if the given DumpFlag is set +putDumpFileMaybe :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +putDumpFileMaybe logger = putDumpFileMaybe' logger alwaysQualify +{-# INLINE putDumpFileMaybe #-} -- see Note [INLINE conditional tracing utilities] + +-- | Dump if the given DumpFlag is set +-- +-- Unlike 'putDumpFileMaybe', has a NamePprCtx argument +putDumpFileMaybe' + :: Logger + -> NamePprCtx + -> DumpFlag + -> String + -> DumpFormat + -> SDoc + -> IO () +putDumpFileMaybe' logger name_ppr_ctx flag hdr fmt doc + = when (logHasDumpFlag logger flag) $ + logDumpFile' logger name_ppr_ctx flag hdr fmt doc +{-# INLINE putDumpFileMaybe' #-} -- see Note [INLINE conditional tracing utilities] + + +logDumpFile' :: Logger -> NamePprCtx -> DumpFlag + -> String -> DumpFormat -> SDoc -> IO () +{-# NOINLINE logDumpFile' #-} +-- NOINLINE: Now we are past the conditional, into the "cold" path, +-- don't inline, to reduce code size at the call site +-- See Note [INLINE conditional tracing utilities] +logDumpFile' logger name_ppr_ctx flag hdr fmt doc + = logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr fmt doc + +-- | Ensure that a dump file is created even if it stays empty +touchDumpFile :: Logger -> DumpFlag -> IO () +touchDumpFile logger flag = + withDumpFileHandle (generated_dumps logger) (logFlags logger) flag (const (return ())) + +class HasLogger m where + getLogger :: m Logger + +class ContainsLogger t where + extractLogger :: t -> Logger + diff --git a/GHC/Utils/Misc.hs b/GHC/Utils/Misc.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Misc.hs @@ -0,0 +1,1464 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Highly random utility functions +-- +module GHC.Utils.Misc ( + -- * Miscellaneous higher-order functions + applyWhen, nTimes, const2, + + -- * General list processing + zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + stretchZipWith, zipWithAndUnzip, zipAndUnzip, + + filterByList, filterByLists, partitionByList, + + unzipWith, + + mapFst, mapSnd, chkAppend, + mapAndUnzip, mapAndUnzip3, mapAndUnzip4, + filterOut, partitionWith, partitionWithM, + + dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, + + foldl2, count, countWhile, all2, any2, all2Prefix, all3Prefix, + foldr1WithDefault, foldl1WithDefault', + + lengthExceeds, lengthIs, lengthIsNot, + lengthAtLeast, lengthAtMost, lengthLessThan, + listLengthCmp, atLength, + equalLength, compareLength, leLength, ltLength, + + isSingleton, only, expectOnly, GHC.Utils.Misc.singleton, + notNull, expectNonEmpty, snocView, + + holes, + + changeLast, + + whenNonEmpty, + + mergeListsBy, + isSortedBy, + + -- Foldable generalised functions, + + mapMaybe', + + -- * Tuples + fstOf3, sndOf3, thdOf3, + fstOf4, sndOf4, + fst3, snd3, third3, + uncurry3, + + -- * List operations controlled by another list + takeList, dropList, splitAtList, split, + dropTail, capitalise, + + -- * Sorting + sortWith, minWith, nubSort, ordNub, ordNubOn, + + -- * Comparisons + isEqual, + removeSpaces, + (<&&>), (<||>), + + -- * Edit distance + fuzzyMatch, fuzzyLookup, + + -- * Transitive closures + transitiveClosure, + + -- * Strictness + seqList, strictMap, strictZipWith, strictZipWith3, + + -- * Module names + looksLikeModuleName, + looksLikePackageName, + + -- * Integers + exactLog2, + + -- * Floating point + readRational, + readSignificandExponentPair, + readHexRational, + readHexSignificandExponentPair, + + -- * IO-ish utilities + doesDirNameExist, + getModificationUTCTime, + modificationTimeIfExists, + fileHashIfExists, + withAtomicRename, + + -- * Filenames and paths + Suffix, + splitLongestPrefix, + escapeSpaces, + Direction(..), reslash, + makeRelativeTo, + + -- * Utils for defining Data instances + abstractConstr, abstractDataType, mkNoRepType, + + -- * Utils for printing C code + charToC, + + -- * Hashing + hashString, + + -- * Call stacks + HasCallStack, + HasDebugCallStack, + ) where + +import GHC.Prelude.Basic hiding ( head, init, last, tail ) +import qualified GHC.Prelude.Basic as Partial ( head ) + +import GHC.Utils.Exception +import GHC.Utils.Panic.Plain +import GHC.Utils.Constants +import GHC.Utils.Fingerprint + +import Data.Data +import qualified Data.List as List +import Data.List.NonEmpty ( NonEmpty(..), last, nonEmpty ) + +import GHC.Exts hiding (toList) +import GHC.Stack (HasCallStack) +import GHC.Data.List + +import Control.Monad ( guard ) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import System.IO.Error as IO ( isDoesNotExistError ) +import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) +import System.FilePath + +import Data.Bifunctor ( first, second ) +import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper + , isHexDigit, digitToInt ) +import Data.Foldable ( Foldable (toList) ) +import Data.Int +import Data.Ratio ( (%) ) +import Data.Ord ( comparing ) +import Data.Word +import qualified Data.IntMap as IM +import qualified Data.Set as Set + +import Data.Time + +{- +************************************************************************ +* * +\subsection{Miscellaneous higher-order functions} +* * +************************************************************************ +-} + +-- | Apply a function iff some condition is met. +applyWhen :: Bool -> (a -> a) -> a -> a +applyWhen True f x = f x +applyWhen _ _ x = x + +-- | Apply a function @n@ times to a given value. +nTimes :: Int -> (a -> a) -> (a -> a) +nTimes 0 _ = id +nTimes 1 f = f +nTimes n f = f . nTimes (n-1) f + +const2 :: a -> b -> c -> a +const2 x _ _ = x + +fstOf3 :: (a,b,c) -> a +sndOf3 :: (a,b,c) -> b +thdOf3 :: (a,b,c) -> c +fstOf3 (a,_,_) = a +sndOf3 (_,b,_) = b +thdOf3 (_,_,c) = c + +fstOf4 :: (a,b,c,d) -> a +sndOf4 :: (a,b,c,d) -> b +fstOf4 (a,_,_,_) = a +sndOf4 (_,b,_,_) = b + +fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) +fst3 f (a, b, c) = (f a, b, c) + +snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) +snd3 f (a, b, c) = (a, f b, c) + +third3 :: (c -> d) -> (a, b, c) -> (a, b, d) +third3 f (a, b, c) = (a, b, f c) + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c + +{- +************************************************************************ +* * +\subsection[Utils-lists]{General list processing} +* * +************************************************************************ +-} + +filterOut :: (a->Bool) -> [a] -> [a] +-- ^ Like filter, only it reverses the sense of the test +filterOut p = filter (not . p) + +partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) +-- ^ Uses a function to determine which of two output lists an input element should join +partitionWith _ [] = ([],[]) +partitionWith f (x:xs) = case f x of + Left b -> (b:bs, cs) + Right c -> (bs, c:cs) + where (bs,cs) = partitionWith f xs + +partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c]) +-- ^ Monadic version of `partitionWith` +partitionWithM _ [] = return ([], []) +partitionWithM f (x:xs) = do + y <- f x + (bs, cs) <- partitionWithM f xs + case y of + Left b -> return (b:bs, cs) + Right c -> return (bs, c:cs) +{-# INLINEABLE partitionWithM #-} + +chkAppend :: [a] -> [a] -> [a] +-- Checks for the second argument being empty +-- Used in situations where that situation is common +chkAppend xs ys + | null ys = xs + | otherwise = xs ++ ys + +{- +A paranoid @zip@ (and some @zipWith@ friends) that checks the lists +are of equal length. Alastair Reid thinks this should only happen if +DEBUGging on; hey, why not? +-} + +zipEqual :: HasDebugCallStack => [a] -> [b] -> [(a,b)] +zipWithEqual :: HasDebugCallStack => (a->b->c) -> [a]->[b]->[c] +zipWith3Equal :: HasDebugCallStack => (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith4Equal :: HasDebugCallStack => (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] + +#if !defined(DEBUG) +zipEqual = zip +zipWithEqual = zipWith +zipWith3Equal = zipWith3 +zipWith4Equal = List.zipWith4 +#else +zipEqual [] [] = [] +zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs +zipEqual _ _ = panic "zipEqual: unequal lists" + +zipWithEqual z (a:as) (b:bs)= z a b : zipWithEqual z as bs +zipWithEqual _ [] [] = [] +zipWithEqual _ _ _ = panic "zipWithEqual: unequal lists" + +zipWith3Equal z (a:as) (b:bs) (c:cs) + = z a b c : zipWith3Equal z as bs cs +zipWith3Equal _ [] [] [] = [] +zipWith3Equal _ _ _ _ = panic "zipWith3Equal: unequal lists" + +zipWith4Equal z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4Equal z as bs cs ds +zipWith4Equal _ [] [] [] [] = [] +zipWith4Equal _ _ _ _ _ = panic "zipWith4Equal: unequal lists" +#endif + +-- | 'filterByList' takes a list of Bools and a list of some elements and +-- filters out these elements for which the corresponding value in the list of +-- Bools is False. This function does not check whether the lists have equal +-- length. +filterByList :: [Bool] -> [a] -> [a] +filterByList (True:bs) (x:xs) = x : filterByList bs xs +filterByList (False:bs) (_:xs) = filterByList bs xs +filterByList _ _ = [] + +-- | 'filterByLists' takes a list of Bools and two lists as input, and +-- outputs a new list consisting of elements from the last two input lists. For +-- each Bool in the list, if it is 'True', then it takes an element from the +-- former list. If it is 'False', it takes an element from the latter list. +-- The elements taken correspond to the index of the Bool in its list. +-- For example: +-- +-- @ +-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" +-- @ +-- +-- This function does not check whether the lists have equal length. +filterByLists :: [Bool] -> [a] -> [a] -> [a] +filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys +filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys +filterByLists _ _ _ = [] + +-- | 'partitionByList' takes a list of Bools and a list of some elements and +-- partitions the list according to the list of Bools. Elements corresponding +-- to 'True' go to the left; elements corresponding to 'False' go to the right. +-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ +-- This function does not check whether the lists have equal +-- length; when one list runs out, the function stops. +partitionByList :: [Bool] -> [a] -> ([a], [a]) +partitionByList = go [] [] + where + go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs + go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs + go trues falses _ _ = (reverse trues, reverse falses) + +stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] +-- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in +-- the places where @p@ returns @True@ + +stretchZipWith _ _ _ [] _ = [] +stretchZipWith p z f (x:xs) ys + | p x = f x z : stretchZipWith p z f xs ys + | otherwise = case ys of + [] -> [] + (y:ys) -> f x y : stretchZipWith p z f xs ys + +mapFst :: Functor f => (a->c) -> f(a,b) -> f(c,b) +mapSnd :: Functor f => (b->c) -> f(a,b) -> f(a,c) + +mapFst = fmap . first +mapSnd = fmap . second + +zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) +zipWithAndUnzip f (a:as) (b:bs) + = let (r1, r2) = f a b + (rs1, rs2) = zipWithAndUnzip f as bs + in + (r1:rs1, r2:rs2) +zipWithAndUnzip _ _ _ = ([],[]) + +-- | This has the effect of making the two lists have equal length by dropping +-- the tail of the longer one. +zipAndUnzip :: [a] -> [b] -> ([a],[b]) +zipAndUnzip (a:as) (b:bs) + = let (rs1, rs2) = zipAndUnzip as bs + in + (a:rs1, b:rs2) +zipAndUnzip _ _ = ([],[]) + +-- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: +-- +-- @ +-- atLength atLenPred atEndPred ls n +-- | n < 0 = atLenPred ls +-- | length ls < n = atEndPred (n - length ls) +-- | otherwise = atLenPred (drop n ls) +-- @ +atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) + -- NB: arg passed to this function may be [] + -> b -- Called when length ls < n + -> [a] + -> Int + -> b +atLength atLenPred atEnd ls0 n0 + | n0 < 0 = atLenPred ls0 + | otherwise = go n0 ls0 + where + -- go's first arg n >= 0 + go 0 ls = atLenPred ls + go _ [] = atEnd -- n > 0 here + go n (_:xs) = go (n-1) xs + +-- Some special cases of atLength: + +-- | @(lengthExceeds xs n) = (length xs > n)@ +lengthExceeds :: [a] -> Int -> Bool +lengthExceeds lst n + | n < 0 + = True + | otherwise + = atLength notNull False lst n + +-- | @(lengthAtLeast xs n) = (length xs >= n)@ +lengthAtLeast :: [a] -> Int -> Bool +lengthAtLeast = atLength (const True) False + +-- | @(lengthIs xs n) = (length xs == n)@ +lengthIs :: [a] -> Int -> Bool +lengthIs lst n + | n < 0 + = False + | otherwise + = atLength null False lst n + +-- | @(lengthIsNot xs n) = (length xs /= n)@ +lengthIsNot :: [a] -> Int -> Bool +lengthIsNot lst n + | n < 0 = True + | otherwise = atLength notNull True lst n + +-- | @(lengthAtMost xs n) = (length xs <= n)@ +lengthAtMost :: [a] -> Int -> Bool +lengthAtMost lst n + | n < 0 + = False + | otherwise + = atLength null True lst n + +-- | @(lengthLessThan xs n) == (length xs < n)@ +lengthLessThan :: [a] -> Int -> Bool +lengthLessThan = atLength (const False) True + +listLengthCmp :: [a] -> Int -> Ordering +listLengthCmp = atLength atLen atEnd + where + atEnd = LT -- Not yet seen 'n' elts, so list length is < n. + + atLen [] = EQ + atLen _ = GT + +equalLength :: [a] -> [b] -> Bool +-- ^ True if length xs == length ys +equalLength [] [] = True +equalLength (_:xs) (_:ys) = equalLength xs ys +equalLength _ _ = False + +compareLength :: [a] -> [b] -> Ordering +compareLength [] [] = EQ +compareLength (_:xs) (_:ys) = compareLength xs ys +compareLength [] _ = LT +compareLength _ [] = GT + +leLength :: [a] -> [b] -> Bool +-- ^ True if length xs <= length ys +leLength xs ys = case compareLength xs ys of + LT -> True + EQ -> True + GT -> False + +ltLength :: [a] -> [b] -> Bool +-- ^ True if length xs < length ys +ltLength xs ys = case compareLength xs ys of + LT -> True + EQ -> False + GT -> False + +---------------------------- +singleton :: a -> [a] +singleton x = [x] + +isSingleton :: [a] -> Bool +isSingleton [_] = True +isSingleton _ = False + +notNull :: Foldable f => f a -> Bool +notNull = not . null + +-- | Utility function to go from a singleton list to it's element. +-- +-- Wether or not the argument is a singleton list is only checked +-- in debug builds. +only :: [a] -> a +#if defined(DEBUG) +only [a] = a +#else +only (a:_) = a +#endif +only _ = panic "Util: only" + +-- | Extract the single element of a list and panic with the given message if +-- there are more elements or the list was empty. +-- Like 'expectJust', but for lists. +expectOnly :: HasCallStack => [a] -> a +-- always enable the call stack to get the location even on non-debug builds +{-# INLINE expectOnly #-} +#if defined(DEBUG) +expectOnly [a] = a +#else +expectOnly (a:_) = a +#endif +expectOnly _ = panic "expectOnly" + +-- | Compute all the ways of removing a single element from a list. +-- +-- > holes [1,2,3] = [(1, [2,3]), (2, [1,3]), (3, [1,2])] +holes :: [a] -> [(a, [a])] +holes [] = [] +holes (x:xs) = (x, xs) : mapSnd (x:) (holes xs) + +-- | Replace the last element of a list with another element. +changeLast :: [a] -> a -> [a] +changeLast [] _ = panic "changeLast" +changeLast [_] x = [x] +changeLast (x:xs) x' = x : changeLast xs x' + +-- | Like @expectJust msg . nonEmpty@; a better alternative to 'NE.fromList'. +expectNonEmpty :: HasCallStack => [a] -> NonEmpty a +-- always enable the call stack to get the location even on non-debug builds +{-# INLINE expectNonEmpty #-} +expectNonEmpty (x:xs) = x:|xs +expectNonEmpty [] = expectNonEmptyPanic + +expectNonEmptyPanic :: HasCallStack => a +expectNonEmptyPanic = panic "expectNonEmpty" +{-# NOINLINE expectNonEmptyPanic #-} + +whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () +whenNonEmpty [] _ = pure () +whenNonEmpty (x:xs) f = f (x :| xs) + +-- | Merge an unsorted list of sorted lists, for example: +-- +-- > mergeListsBy compare [ [2,5,15], [1,10,100] ] = [1,2,5,10,15,100] +-- +-- \( O(n \log{} k) \) +mergeListsBy :: forall a. (a -> a -> Ordering) -> [[a]] -> [a] +mergeListsBy cmp lists | debugIsOn, not (all sorted lists) = + -- When debugging is on, we check that the input lists are sorted. + panic "mergeListsBy: input lists must be sorted" + where sorted = isSortedBy cmp +mergeListsBy cmp all_lists = merge_lists all_lists + where + -- Implements "Iterative 2-Way merge" described at + -- https://en.wikipedia.org/wiki/K-way_merge_algorithm + + -- Merge two sorted lists into one in O(n). + merge2 :: [a] -> [a] -> [a] + merge2 [] ys = ys + merge2 xs [] = xs + merge2 (x:xs) (y:ys) = + case cmp x y of + GT -> y : merge2 (x:xs) ys + _ -> x : merge2 xs (y:ys) + + -- Merge the first list with the second, the third with the fourth, and so + -- on. The output has half as much lists as the input. + merge_neighbours :: [[a]] -> [[a]] + merge_neighbours [] = [] + merge_neighbours [xs] = [xs] + merge_neighbours (xs : ys : lists) = + merge2 xs ys : merge_neighbours lists + + -- Since 'merge_neighbours' halves the amount of lists in each iteration, + -- we perform O(log k) iteration. Each iteration is O(n). The total running + -- time is therefore O(n log k). + merge_lists :: [[a]] -> [a] + merge_lists lists = + case merge_neighbours lists of + [] -> [] + [xs] -> xs + lists' -> merge_lists lists' + +isSortedBy :: (a -> a -> Ordering) -> [a] -> Bool +isSortedBy cmp = sorted + where + sorted [] = True + sorted [_] = True + sorted (x:y:xs) = cmp x y /= GT && sorted (y:xs) +{- +************************************************************************ +* * +\subsubsection{Sort utils} +* * +************************************************************************ +-} + +minWith :: Ord b => (a -> b) -> [a] -> a +minWith get_key xs = assert (not (null xs) ) + Partial.head (sortWith get_key xs) + +nubSort :: Ord a => [a] -> [a] +nubSort = Set.toAscList . Set.fromList + +-- | Remove duplicates but keep elements in order. +-- O(n * log n) +ordNub :: Ord a => [a] -> [a] +ordNub xs = ordNubOn id xs + +-- | Remove duplicates but keep elements in order. +-- O(n * log n) +ordNubOn :: Ord b => (a -> b) -> [a] -> [a] +ordNubOn f xs + = go Set.empty xs + where + go _ [] = [] + go s (x:xs) + | Set.member (f x) s = go s xs + | otherwise = x : go (Set.insert (f x) s) xs + + +{- +************************************************************************ +* * +\subsection[Utils-transitive-closure]{Transitive closure} +* * +************************************************************************ + +This algorithm for transitive closure is straightforward, albeit quadratic. +-} + +transitiveClosure :: (a -> [a]) -- Successor function + -> (a -> a -> Bool) -- Equality predicate + -> [a] + -> [a] -- The transitive closure + +transitiveClosure succ eq xs + = go [] xs + where + go done [] = done + go done (x:xs) | x `is_in` done = go done xs + | otherwise = go (x:done) (succ x ++ xs) + + _ `is_in` [] = False + x `is_in` (y:ys) | eq x y = True + | otherwise = x `is_in` ys + +{- +************************************************************************ +* * +\subsection[Utils-accum]{Accumulating} +* * +************************************************************************ + +A combination of foldl with zip. It works with equal length lists. +-} + +foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc +foldl2 _ z [] [] = z +foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs +foldl2 _ _ _ _ = panic "Util: foldl2" + +all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool +-- True if the lists are the same length, and +-- all corresponding elements satisfy the predicate +all2 _ [] [] = True +all2 p (x:xs) (y:ys) = p x y && all2 p xs ys +all2 _ _ _ = False + +any2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool +-- True if any of the corresponding elements satisfy the predicate +-- Unlike `all2`, this ignores excess elements of the other list +any2 p (x:xs) (y:ys) = p x y || any2 p xs ys +any2 _ _ _ = False + +all2Prefix :: forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool +-- ^ `all2Prefix p xs ys` is a fused version of `and $ zipWith2 p xs ys`. +-- (It generates good code nonetheless.) +-- So if one list is shorter than the other, `p` is assumed to be `True` for the +-- suffix. +all2Prefix p = foldr k z + where + k :: a -> ([b] -> Bool) -> [b] -> Bool + k x go ys' = case ys' of + (y:ys'') -> p x y && go ys'' + _ -> True + z :: [b] -> Bool + z _ = True +{-# INLINE all2Prefix #-} + +all3Prefix :: forall a b c. (a -> b -> c -> Bool) -> [a] -> [b] -> [c] -> Bool +-- ^ `all3Prefix p xs ys zs` is a fused version of `and $ zipWith3 p xs ys zs`. +-- (It generates good code nonetheless.) +-- So if one list is shorter than the others, `p` is assumed to be `True` for +-- the suffix. +all3Prefix p = foldr k z + where + k :: a -> ([b] -> [c] -> Bool) -> [b] -> [c] -> Bool + k x go ys' zs' = case (ys',zs') of + (y:ys'',z:zs'') -> p x y z && go ys'' zs'' + _ -> False + z :: [b] -> [c] -> Bool + z _ _ = True +{-# INLINE all3Prefix #-} + +-- Count the number of times a predicate is true + +count :: (a -> Bool) -> [a] -> Int +count p = go 0 + where go !n [] = n + go !n (x:xs) | p x = go (n+1) xs + | otherwise = go n xs + +countWhile :: (a -> Bool) -> [a] -> Int +-- Length of an /initial prefix/ of the list satisfying p +countWhile p = go 0 + where go !n (x:xs) | p x = go (n+1) xs + go !n _ = n + +{- +@splitAt@, @take@, and @drop@ but with length of another +list giving the break-off point: +-} + +takeList :: [b] -> [a] -> [a] +-- (takeList as bs) trims bs to the be same length +-- as as, unless as is longer in which case it's a no-op +takeList [] _ = [] +takeList (_:xs) ls = + case ls of + [] -> [] + (y:ys) -> y : takeList xs ys + +dropList :: [b] -> [a] -> [a] +dropList [] xs = xs +dropList _ xs@[] = xs +dropList (_:xs) (_:ys) = dropList xs ys + + +-- | Given two lists xs and ys, return `splitAt (length xs) ys`. +splitAtList :: [b] -> [a] -> ([a], [a]) +splitAtList xs ys = go 0# xs ys + where + -- we are careful to avoid allocating when there are no leftover + -- arguments: in this case we can return "ys" directly (cf #18535) + -- + -- We make `xs` strict because in the general case `ys` isn't `[]` so we + -- will have to evaluate `xs` anyway. + go _ !_ [] = (ys, []) -- length ys <= length xs + go n [] bs = (take (I# n) ys, bs) -- = splitAt n ys + go n (_:as) (_:bs) = go (n +# 1#) as bs + +-- | drop from the end of a list +dropTail :: Int -> [a] -> [a] +-- Specification: dropTail n = reverse . drop n . reverse +-- Better implementation due to Joachim Breitner +-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html +dropTail n xs + = go (drop n xs) xs + where + go (_:ys) (x:xs) = x : go ys xs + go _ _ = [] -- Stop when ys runs out + -- It'll always run out before xs does + +-- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, +-- but is lazy in the elements and strict in the spine. For reasonably short lists, +-- such as path names and typical lines of text, dropWhileEndLE is generally +-- faster than dropWhileEnd. Its advantage is magnified when the predicate is +-- expensive--using dropWhileEndLE isSpace to strip the space off a line of text +-- is generally much faster than using dropWhileEnd isSpace for that purpose. +-- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse +-- Pay attention to the short-circuit (&&)! The order of its arguments is the only +-- difference between dropWhileEnd and dropWhileEndLE. +dropWhileEndLE :: (a -> Bool) -> [a] -> [a] +dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] + +-- | @spanEnd p l == reverse (span p (reverse l))@. The first list +-- returns actually comes after the second list (when you look at the +-- input list). +spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) +spanEnd p l = go l [] [] l + where go yes _rev_yes rev_no [] = (yes, reverse rev_no) + go yes rev_yes rev_no (x:xs) + | p x = go yes (x : rev_yes) rev_no xs + | otherwise = go xs [] (x : rev_yes ++ rev_no) xs + +-- | Get the last two elements in a list. +{-# INLINE last2 #-} +last2 :: [a] -> Maybe (a,a) +last2 = uncurry (liftA2 (,)) . List.foldl' (\(_,x2) x -> (x2, Just x)) (Nothing, Nothing) + +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe (x:xs) = Just $ last (x:|xs) + +-- | @onJust x m f@ applies f to the value inside the Just or returns the default. +onJust :: b -> Maybe a -> (a->b) -> b +onJust dflt = flip (maybe dflt) + +-- | Split a list into its last element and the initial part of the list. +-- @snocView xs = Just (init xs, last xs)@ for non-empty lists. +-- @snocView xs = Nothing@ otherwise. +-- Unless both parts of the result are guaranteed to be used +-- prefer separate calls to @last@ + @init@. +-- If you are guaranteed to use both, this will +-- be more efficient. +snocView :: [a] -> Maybe ([a],a) +snocView = fmap go . nonEmpty + where + go :: NonEmpty a -> ([a],a) + go (x:|xs) = case nonEmpty xs of + Nothing -> ([],x) + Just xs -> case go xs of !(xs', x') -> (x:xs', x') + +split :: Char -> String -> [String] +split c s = case rest of + [] -> [chunk] + _:rest -> chunk : split c rest + where (chunk, rest) = break (==c) s + +-- | Convert a word to title case by capitalising the first letter +capitalise :: String -> String +capitalise [] = [] +capitalise (c:cs) = toUpper c : cs + + +{- +************************************************************************ +* * +\subsection[Utils-comparison]{Comparisons} +* * +************************************************************************ +-} + +isEqual :: Ordering -> Bool +-- Often used in (isEqual (a `compare` b)) +isEqual GT = False +isEqual EQ = True +isEqual LT = False + +removeSpaces :: String -> String +removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace + +-- Boolean operators lifted to Applicative +(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool +(<&&>) = liftA2 (&&) +infixr 3 <&&> -- same as (&&) + +(<||>) :: Applicative f => f Bool -> f Bool -> f Bool +(<||>) = liftA2 (||) +infixr 2 <||> -- same as (||) + +{- +************************************************************************ +* * +\subsection{Edit distance} +* * +************************************************************************ +-} + +-- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. +-- See: . +-- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing +-- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). +-- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and +-- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation +restrictedDamerauLevenshteinDistance :: String -> String -> Int +restrictedDamerauLevenshteinDistance str1 str2 + = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + where + m = length str1 + n = length str2 + +restrictedDamerauLevenshteinDistanceWithLengths + :: Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + | m <= n + = if n <= 32 -- n must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 + + | otherwise + = if m <= 32 -- m must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 + +restrictedDamerauLevenshteinDistance' + :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 + | [] <- str1 = n + | otherwise = extractAnswer $ + List.foldl' (restrictedDamerauLevenshteinDistanceWorker + (matchVectors str1) top_bit_mask vector_mask) + (0, 0, m_ones, 0, m) str2 + where + m_ones@vector_mask = (2 ^ m) - 1 + top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy + extractAnswer (_, _, _, _, distance) = distance + +restrictedDamerauLevenshteinDistanceWorker + :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv + -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) +restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask + (pm, d0, vp, vn, distance) char2 + = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ + seq pm' $ seq d0' $ seq vp' $ seq vn' $ + seq distance'' $ seq char2 $ + (pm', d0', vp', vn', distance'') + where + pm' = IM.findWithDefault 0 (ord char2) str1_mvs + + d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) + .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn + -- No need to mask the shiftL because of the restricted range of pm + + hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) + hn' = d0' .&. vp + + hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask + hn'_shift = (hn' `shiftL` 1) .&. vector_mask + vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) + vn' = d0' .&. hp'_shift + + distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance + distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' + +sizedComplement :: Bits bv => bv -> bv -> bv +sizedComplement vector_mask vect = vector_mask `xor` vect + +matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv +matchVectors = snd . List.foldl' go (0 :: Int, IM.empty) + where + go (ix, im) char = let ix' = ix + 1 + im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im + in seq ix' $ seq im' $ (ix', im') + +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Word32 -> Int -> Int -> String -> String -> Int #-} +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Integer -> Int -> Int -> String -> String -> Int #-} + +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Word32 -> Word32 -> Word32 + -> (Word32, Word32, Word32, Word32, Int) + -> Char -> (Word32, Word32, Word32, Word32, Int) #-} +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Integer -> Integer -> Integer + -> (Integer, Integer, Integer, Integer, Int) + -> Char -> (Integer, Integer, Integer, Integer, Int) #-} + +{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} +{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} + +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} + +fuzzyMatch :: String -> [String] -> [String] +fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] + +-- | Search for possible matches to the users input in the given list, +-- returning a small number of ranked results +fuzzyLookup :: String -> [(String,a)] -> [a] +fuzzyLookup user_entered possibilities + = map fst $ take mAX_RESULTS $ List.sortBy (comparing snd) + [ (poss_val, sort_key) + | (poss_str, poss_val) <- possibilities + , let distance = restrictedDamerauLevenshteinDistance poss_str user_entered + , distance <= fuzzy_threshold + , let sort_key = (distance, length poss_str, poss_str) + ] + where + -- Work out an appropriate match threshold: + -- We report a candidate if its edit distance is <= the threshold, + -- The threshold is set to about a quarter of the # of characters the user entered + -- Length Threshold + -- 1 0 -- Don't suggest *any* candidates + -- 2 1 -- for single-char identifiers + -- 3 1 + -- 4 1 + -- 5 1 + -- 6 2 + -- + -- Candidates with the same distance are sorted by their length. We also + -- use the actual string as the third sorting criteria the sort key to get + -- deterministic output, even if the input may have depended on the uniques + -- in question + fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) + mAX_RESULTS = 3 + +{- +************************************************************************ +* * +\subsection[Utils-pairs]{Pairs} +* * +************************************************************************ +-} + +unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] +unzipWith = fmap . uncurry + +seqList :: [a] -> b -> b +seqList [] b = b +seqList (x:xs) b = x `seq` seqList xs b + +strictMap :: (a -> b) -> [a] -> [b] +strictMap _ [] = [] +strictMap f (x:xs) = + let + !x' = f x + !xs' = strictMap f xs + in + x' : xs' + +strictZipWith :: (a -> b -> c) -> [a] -> [b] -> [c] +strictZipWith _ [] _ = [] +strictZipWith _ _ [] = [] +strictZipWith f (x:xs) (y:ys) = + let + !x' = f x y + !xs' = strictZipWith f xs ys + in + x' : xs' + +strictZipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] +strictZipWith3 _ [] _ _ = [] +strictZipWith3 _ _ [] _ = [] +strictZipWith3 _ _ _ [] = [] +strictZipWith3 f (x:xs) (y:ys) (z:zs) = + let + !x' = f x y z + !xs' = strictZipWith3 f xs ys zs + in + x' : xs' + + +-- Module names: + +looksLikeModuleName :: String -> Bool +looksLikeModuleName [] = False +looksLikeModuleName (c:cs) = isUpper c && go cs + where go [] = True + go ('.':cs) = looksLikeModuleName cs + go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs + +-- Similar to 'parse' for Distribution.Package.PackageName, +-- but we don't want to depend on Cabal. +looksLikePackageName :: String -> Bool +looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-' + +----------------------------------------------------------------------------- +-- Integers + +-- | Determine the $\log_2$ of exact powers of 2 +exactLog2 :: Integer -> Maybe Integer +exactLog2 x + | x <= 0 = Nothing + | x > fromIntegral (maxBound :: Int32) = Nothing + | x' .&. (-x') /= x' = Nothing + | otherwise = Just (fromIntegral c) + where + x' = fromIntegral x :: Int32 + c = countTrailingZeros x' + +{- +-- ----------------------------------------------------------------------------- +-- Floats +-} + +readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" +readRational__ r = do + ((i, e), t) <- readSignificandExponentPair__ r + return ((i%1)*10^^e, t) + +readRational :: String -> Rational -- NB: *does* handle a leading "-" +readRational top_s + = case top_s of + '-' : xs -> negate (read_me xs) + xs -> read_me xs + where + read_me s + = case (do { (x,"") <- readRational__ s ; return x }) of + [x] -> x + [] -> error ("readRational: no parse:" ++ top_s) + _ -> error ("readRational: ambiguous parse:" ++ top_s) + + +readSignificandExponentPair__ :: ReadS (Integer, Integer) -- NB: doesn't handle leading "-" +readSignificandExponentPair__ r = do + (n,d,s) <- readFix r + (k,t) <- readExp s + let pair = (n, toInteger (k - d)) + return (pair, t) + where + readFix r = do + (ds,s) <- lexDecDigits r + (ds',t) <- lexDotDigits s + return (read (toList ds++ds'), length ds', t) + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = return (0,s) + + readExp' ('+':s) = readDec s + readExp' ('-':s) = do (k,t) <- readDec s + return (-k,t) + readExp' s = readDec s + + readDec s = do + (ds,r) <- nonnull isDigit s + return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], + r) + + lexDecDigits = nonnull isDigit + + lexDotDigits ('.':s) = return (span' isDigit s) + lexDotDigits s = return ("",s) + + nonnull p s = do (c:cs,t) <- return (span' p s) + return (c:|cs,t) + + span' _ xs@[] = (xs, xs) + span' p xs@(x:xs') + | x == '_' = span' p xs' -- skip "_" (#14473) + | p x = let (ys,zs) = span' p xs' in (x:ys,zs) + | otherwise = ([],xs) + +-- | Parse a string into a significand and exponent. +-- A trivial example might be: +-- ghci> readSignificandExponentPair "1E2" +-- (1,2) +-- In a more complex case we might return a exponent different than that +-- which the user wrote. This is needed in order to use a Integer significand. +-- ghci> readSignificandExponentPair "-1.11E5" +-- (-111,3) +readSignificandExponentPair :: String -> (Integer, Integer) -- NB: *does* handle a leading "-" +readSignificandExponentPair top_s + = case top_s of + '-' : xs -> let (i, e) = read_me xs in (-i, e) + xs -> read_me xs + where + read_me s + = case (do { (x,"") <- readSignificandExponentPair__ s ; return x }) of + [x] -> x + [] -> error ("readSignificandExponentPair: no parse:" ++ top_s) + _ -> error ("readSignificandExponentPair: ambiguous parse:" ++ top_s) + + +readHexRational :: String -> Rational +readHexRational str = + case str of + '-' : xs -> negate (readMe xs) + xs -> readMe xs + where + readMe as = + case readHexRational__ as of + Just n -> n + _ -> error ("readHexRational: no parse:" ++ str) + + +readHexRational__ :: String -> Maybe Rational +readHexRational__ ('0' : x : rest) + | x == 'X' || x == 'x' = + do let (front,rest2) = span' isHexDigit rest + guard (not (null front)) + let frontNum = steps 16 0 front + case rest2 of + '.' : rest3 -> + do let (back,rest4) = span' isHexDigit rest3 + guard (not (null back)) + let backNum = steps 16 frontNum back + exp1 = -4 * length back + case rest4 of + p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps) + _ -> return (mk backNum exp1) + p : ps | isExp p -> fmap (mk frontNum) (getExp ps) + _ -> Nothing + + where + isExp p = p == 'p' || p == 'P' + + getExp ('+' : ds) = dec ds + getExp ('-' : ds) = fmap negate (dec ds) + getExp ds = dec ds + + mk :: Integer -> Int -> Rational + mk n e = fromInteger n * 2^^e + + dec cs = case span' isDigit cs of + (ds,"") | not (null ds) -> Just (steps 10 0 ds) + _ -> Nothing + + steps base n ds = List.foldl' (step base) n ds + step base n d = base * n + fromIntegral (digitToInt d) + + span' _ xs@[] = (xs, xs) + span' p xs@(x:xs') + | x == '_' = span' p xs' -- skip "_" (#14473) + | p x = let (ys,zs) = span' p xs' in (x:ys,zs) + | otherwise = ([],xs) + +readHexRational__ _ = Nothing + +-- | Parse a string into a significand and exponent according to +-- the "Hexadecimal Floats in Haskell" proposal. +-- A trivial example might be: +-- ghci> readHexSignificandExponentPair "0x1p+1" +-- (1,1) +-- Behaves similar to readSignificandExponentPair but the base is 16 +-- and numbers are given in hexadecimal: +-- ghci> readHexSignificandExponentPair "0xAp-4" +-- (10,-4) +-- ghci> readHexSignificandExponentPair "0x1.2p3" +-- (18,-1) +readHexSignificandExponentPair :: String -> (Integer, Integer) +readHexSignificandExponentPair str = + case str of + '-' : xs -> let (i, e) = readMe xs in (-i, e) + xs -> readMe xs + where + readMe as = + case readHexSignificandExponentPair__ as of + Just n -> n + _ -> error ("readHexSignificandExponentPair: no parse:" ++ str) + + +readHexSignificandExponentPair__ :: String -> Maybe (Integer, Integer) +readHexSignificandExponentPair__ ('0' : x : rest) + | x == 'X' || x == 'x' = + do let (front,rest2) = span' isHexDigit rest + guard (not (null front)) + let frontNum = steps 16 0 front + case rest2 of + '.' : rest3 -> + do let (back,rest4) = span' isHexDigit rest3 + guard (not (null back)) + let backNum = steps 16 frontNum back + exp1 = -4 * length back + case rest4 of + p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps) + _ -> return (mk backNum exp1) + p : ps | isExp p -> fmap (mk frontNum) (getExp ps) + _ -> Nothing + + where + isExp p = p == 'p' || p == 'P' + + getExp ('+' : ds) = dec ds + getExp ('-' : ds) = fmap negate (dec ds) + getExp ds = dec ds + + mk :: Integer -> Int -> (Integer, Integer) + mk n e = (n, fromIntegral e) + + dec cs = case span' isDigit cs of + (ds,"") | not (null ds) -> Just (steps 10 0 ds) + _ -> Nothing + + steps base n ds = foldl' (step base) n ds + step base n d = base * n + fromIntegral (digitToInt d) + + span' _ xs@[] = (xs, xs) + span' p xs@(x:xs') + | x == '_' = span' p xs' -- skip "_" (#14473) + | p x = let (ys,zs) = span' p xs' in (x:ys,zs) + | otherwise = ([],xs) + +readHexSignificandExponentPair__ _ = Nothing + + +----------------------------------------------------------------------------- +-- Verify that the 'dirname' portion of a FilePath exists. +-- +doesDirNameExist :: FilePath -> IO Bool +doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath) + +----------------------------------------------------------------------------- +-- Backwards compatibility definition of getModificationTime + +getModificationUTCTime :: FilePath -> IO UTCTime +getModificationUTCTime = getModificationTime + +-- -------------------------------------------------------------- +-- check existence & modification time at the same time + +modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) +modificationTimeIfExists f = + (do t <- getModificationUTCTime f; return (Just t)) + `catchIO` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +-- -------------------------------------------------------------- +-- check existence & hash at the same time + +fileHashIfExists :: FilePath -> IO (Maybe Fingerprint) +fileHashIfExists f = + (do t <- getFileHash f; return (Just t)) + `catchIO` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +-- -------------------------------------------------------------- +-- atomic file writing by writing to a temporary file first (see #14533) +-- +-- This should be used in all cases where GHC writes files to disk +-- and uses their modification time to skip work later, +-- as otherwise a partially written file (e.g. due to crash or Ctrl+C) +-- also results in a skip. + +withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a +withAtomicRename targetFile f = do + -- The temp file must be on the same file system (mount) as the target file + -- to result in an atomic move on most platforms. + -- The standard way to ensure that is to place it into the same directory. + -- This can still be fooled when somebody mounts a different file system + -- at just the right time, but that is not a case we aim to cover here. + let temp = targetFile <.> "tmp" + res <- f temp + liftIO $ renameFile temp targetFile + return res + +-- -------------------------------------------------------------- +-- split a string at the last character where 'pred' is True, +-- returning a pair of strings. The first component holds the string +-- up (but not including) the last character for which 'pred' returned +-- True, the second whatever comes after (but also not including the +-- last character). +-- +-- If 'pred' returns False for all characters in the string, the original +-- string is returned in the first component (and the second one is just +-- empty). +splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) +splitLongestPrefix str pred = case r_pre of + [] -> (str, []) + _:r_pre' -> (reverse r_pre', reverse r_suf) + -- 'tail' drops the char satisfying 'pred' + where (r_suf, r_pre) = break pred (reverse str) + +escapeSpaces :: String -> String +escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" + +type Suffix = String + +-------------------------------------------------------------- +-- * Search path +-------------------------------------------------------------- + +data Direction = Forwards | Backwards + +reslash :: Direction -> FilePath -> FilePath +reslash d = f + where f ('/' : xs) = slash : f xs + f ('\\' : xs) = slash : f xs + f (x : xs) = x : f xs + f "" = "" + slash = case d of + Forwards -> '/' + Backwards -> '\\' + +makeRelativeTo :: FilePath -> FilePath -> FilePath +this `makeRelativeTo` that = directory thisFilename + where (thisDirectory, thisFilename) = splitFileName this + thatDirectory = dropFileName that + directory = joinPath $ f (splitPath thisDirectory) + (splitPath thatDirectory) + + f (x : xs) (y : ys) + | x == y = f xs ys + f xs ys = replicate (length ys) ".." ++ xs + +{- +************************************************************************ +* * +\subsection[Utils-Data]{Utils for defining Data instances} +* * +************************************************************************ + +These functions helps us to define Data instances for abstract types. +-} + +abstractConstr :: String -> Constr +abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix + +abstractDataType :: String -> DataType +abstractDataType n = mkDataType n [abstractConstr n] + +{- +************************************************************************ +* * +\subsection[Utils-C]{Utils for printing C code} +* * +************************************************************************ +-} + +charToC :: Word8 -> String +charToC w = + case chr (fromIntegral w) of + '\"' -> "\\\"" + '\'' -> "\\\'" + '\\' -> "\\\\" + c | c >= ' ' && c <= '~' -> [c] + | otherwise -> ['\\', + chr (ord '0' + ord c `div` 64), + chr (ord '0' + ord c `div` 8 `mod` 8), + chr (ord '0' + ord c `mod` 8)] + +{- +************************************************************************ +* * +\subsection[Utils-Hashing]{Utils for hashing} +* * +************************************************************************ +-} + +-- | A sample hash function for Strings. We keep multiplying by the +-- golden ratio and adding. The implementation is: +-- +-- > hashString = foldl' f golden +-- > where f m c = fromIntegral (ord c) * magic + hashInt32 m +-- > magic = 0xdeadbeef +-- +-- Where hashInt32 works just as hashInt shown above. +-- +-- Knuth argues that repeated multiplication by the golden ratio +-- will minimize gaps in the hash space, and thus it's a good choice +-- for combining together multiple keys to form one. +-- +-- Here we know that individual characters c are often small, and this +-- produces frequent collisions if we use ord c alone. A +-- particular problem are the shorter low ASCII and ISO-8859-1 +-- character strings. We pre-multiply by a magic twiddle factor to +-- obtain a good distribution. In fact, given the following test: +-- +-- > testp :: Int32 -> Int +-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls +-- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] +-- > hs = foldl' f golden +-- > f m c = fromIntegral (ord c) * k + hashInt32 m +-- > n = 100000 +-- +-- We discover that testp magic = 0. +hashString :: String -> Int32 +hashString = foldl' f golden + where f m c = fromIntegral (ord c) * magic + hashInt32 m + magic = fromIntegral (0xdeadbeef :: Word32) + +golden :: Int32 +golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 +-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 +-- but that has bad mulHi properties (even adding 2^32 to get its inverse) +-- Whereas the above works well and contains no hash duplications for +-- [-32767..65536] + +-- | A sample (and useful) hash function for Int32, +-- implemented by extracting the uppermost 32 bits of the 64-bit +-- result of multiplying by a 33-bit constant. The constant is from +-- Knuth, derived from the golden ratio: +-- +-- > golden = round ((sqrt 5 - 1) * 2^32) +-- +-- We get good key uniqueness on small inputs +-- (a problem with previous versions): +-- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 +-- +hashInt32 :: Int32 -> Int32 +hashInt32 x = mulHi x golden + x + +-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply +mulHi :: Int32 -> Int32 -> Int32 +mulHi a b = fromIntegral (r `shiftR` 32) + where r :: Int64 + r = fromIntegral a * fromIntegral b + +-- | A call stack constraint, but only when 'isDebugOn'. +#if defined(DEBUG) +type HasDebugCallStack = HasCallStack +#else +type HasDebugCallStack = (() :: Constraint) +#endif + +mapMaybe' :: Foldable f => (a -> Maybe b) -> f a -> [b] +mapMaybe' f = foldr g [] + where + g x rest + | Just y <- f x = y : rest + | otherwise = rest + +foldr1WithDefault :: Foldable f => a -> (a -> a -> a) -> f a -> a +foldr1WithDefault defaultA f xs = case nonEmpty (toList xs) of + Nothing -> defaultA + Just (xs1 :: NonEmpty a) -> foldr1 f xs1 +{-# SPECIALIZE foldr1WithDefault :: a -> (a -> a -> a) -> [a] -> a #-} + +foldl1WithDefault' :: Foldable f => a -> (a -> a -> a) -> f a -> a +foldl1WithDefault' defaultA f xs = case nonEmpty (toList xs) of + Nothing -> defaultA + Just (xs1 :: NonEmpty a) -> foldl1' f xs1 +{-# SPECIALIZE foldl1WithDefault' :: a -> (a -> a -> a) -> [a] -> a #-} diff --git a/GHC/Utils/Monad.hs b/GHC/Utils/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Monad.hs @@ -0,0 +1,459 @@ +{-# LANGUAGE MonadComprehensions #-} + +-- | Utilities related to Monad and Applicative classes +-- Mostly for backwards compatibility. + +module GHC.Utils.Monad + ( Applicative(..) + , (<$>) + + , MonadFix(..) + , MonadIO(..) + + , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM + , zipWith3MNE + , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M + , mapAccumLM + , mapSndM + , concatMapM + , mapMaybeM + , anyM, allM, orM + , foldlM, foldlM_, foldrM, foldMapM + , whenM, unlessM + , filterOutM + , partitionM + ) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import GHC.Prelude + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.State.Strict (StateT (..)) +import Data.Foldable (sequenceA_, foldlM, foldrM) +import Data.List (unzip4, unzip5, zipWith4) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Monoid (Ap (Ap, getAp)) +import Data.Tuple (swap) + +------------------------------------------------------------------------------- +-- Common functions +-- These are used throughout the compiler +------------------------------------------------------------------------------- + +{- + +Note [Inline @zipWithNM@ functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The inline principle for 'zipWith3M', 'zipWith4M' and 'zipWith3M_' is the same +as for 'zipWithM' and 'zipWithM_' in "Control.Monad", see +Note [Fusion for zipN/zipWithN] in GHC/List.hs for more details. + +The 'zipWithM'/'zipWithM_' functions are inlined so that the `zipWith` and +`sequenceA` functions with which they are defined have an opportunity to fuse. + +Furthermore, 'zipWith3M'/'zipWith4M' and 'zipWith3M_' have been explicitly +rewritten in a non-recursive way similarly to 'zipWithM'/'zipWithM_', and for +more than just uniformity: after [D5241](https://phabricator.haskell.org/D5241) +for issue #14037, all @zipN@/@zipWithN@ functions fuse, meaning +'zipWith3M'/'zipWIth4M' and 'zipWith3M_'@ now behave like 'zipWithM' and +'zipWithM_', respectively, with regards to fusion. + +As such, since there are not any differences between 2-ary 'zipWithM'/ +'zipWithM_' and their n-ary counterparts below aside from the number of +arguments, the `INLINE` pragma should be replicated in the @zipWithNM@ +functions below as well. + +-} + +zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] +{-# INLINE zipWith3M #-} +-- Inline so that fusion with 'zipWith3' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith3M f xs ys zs = sequenceA (zipWith3 f xs ys zs) + +zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () +{-# INLINE zipWith3M_ #-} +-- Inline so that fusion with 'zipWith4' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith3M_ f xs ys zs = sequenceA_ (zipWith3 f xs ys zs) + +zipWith4M :: Monad m => (a -> b -> c -> d -> m e) + -> [a] -> [b] -> [c] -> [d] -> m [e] +{-# INLINE zipWith4M #-} +-- Inline so that fusion with 'zipWith5' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith4M f xs ys ws zs = sequenceA (zipWith4 f xs ys ws zs) + +zipWithAndUnzipM :: Monad m + => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) +{-# INLINABLE zipWithAndUnzipM #-} -- this allows specialization to a given monad +zipWithAndUnzipM f (x:xs) (y:ys) + = do { (c, d) <- f x y + ; (cs, ds) <- zipWithAndUnzipM f xs ys + ; return (c:cs, d:ds) } +zipWithAndUnzipM _ _ _ = return ([], []) + +-- | 'zipWith3M' for 'NonEmpty' lists. +zipWith3MNE :: Monad m + => (a -> b -> c -> m d) + -> NonEmpty a -> NonEmpty b -> NonEmpty c -> m (NonEmpty d) +zipWith3MNE f ~(x :| xs) ~(y :| ys) ~(z :| zs) + = do { w <- f x y z + ; ws <- zipWith3M f xs ys zs + ; return $ w :| ws } + +{- + +Note [Inline @mapAndUnzipNM@ functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The inline principle is the same as 'mapAndUnzipM' in "Control.Monad". +The 'mapAndUnzipM' function is inlined so that the `unzip` and `traverse` +functions with which it is defined have an opportunity to fuse, see +Note [Inline @unzipN@ functions] in Data/OldList.hs for more details. + +Furthermore, the @mapAndUnzipNM@ functions have been explicitly rewritten in a +non-recursive way similarly to 'mapAndUnzipM', and for more than just +uniformity: after [D5249](https://phabricator.haskell.org/D5249) for Trac +ticket #14037, all @unzipN@ functions fuse, meaning 'mapAndUnzip3M', +'mapAndUnzip4M' and 'mapAndUnzip5M' now behave like 'mapAndUnzipM' with regards +to fusion. + +As such, since there are not any differences between 2-ary 'mapAndUnzipM' and +its n-ary counterparts below aside from the number of arguments, the `INLINE` +pragma should be replicated in the @mapAndUnzipNM@ functions below as well. + +-} + +-- | mapAndUnzipM for triples +mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) +{-# INLINE mapAndUnzip3M #-} +-- Inline so that fusion with 'unzip3' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip3M f xs = unzip3 <$> traverse f xs + +mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e]) +{-# INLINE mapAndUnzip4M #-} +-- Inline so that fusion with 'unzip4' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip4M f xs = unzip4 <$> traverse f xs + +mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f]) +{-# INLINE mapAndUnzip5M #-} +-- Inline so that fusion with 'unzip5' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip5M f xs = unzip5 <$> traverse f xs + +-- TODO: mapAccumLM is used in many places. Surely most of +-- these don't actually want to be lazy. We should add a strict +-- variant and use it where appropriate. + +-- | Monadic version of mapAccumL +mapAccumLM :: (Monad m, Traversable t) + => (acc -> x -> m (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> t x -- ^ inputs + -> m (acc, t y) -- ^ final state, outputs +{-# INLINE [1] mapAccumLM #-} +-- INLINE pragma. mapAccumLM is called in inner loops. Like 'map', +-- we inline it so that we can take advantage of knowing 'f'. +-- This makes a few percent difference (in compiler allocations) +-- when compiling perf/compiler/T9675 +mapAccumLM f s = fmap swap . flip runStateT s . traverse f' + where + f' = StateT . (fmap . fmap) swap . flip f +{-# RULES "mapAccumLM/List" mapAccumLM = mapAccumLM_List #-} +{-# RULES "mapAccumLM/NonEmpty" mapAccumLM = mapAccumLM_NonEmpty #-} + +mapAccumLM_List + :: Monad m + => (acc -> x -> m (acc, y)) + -> acc -> [x] -> m (acc, [y]) +{-# INLINE mapAccumLM_List #-} +mapAccumLM_List f s = go s + where + go s (x:xs) = do + (s1, x') <- f s x + (s2, xs') <- go s1 xs + return (s2, x' : xs') + go s [] = return (s, []) + +mapAccumLM_NonEmpty + :: Monad m + => (acc -> x -> m (acc, y)) + -> acc -> NonEmpty x -> m (acc, NonEmpty y) +{-# INLINE mapAccumLM_NonEmpty #-} +mapAccumLM_NonEmpty f s (x:|xs) = + [(s2, x':|xs') | (s1, x') <- f s x, (s2, xs') <- mapAccumLM_List f s1 xs] + +-- | Monadic version of mapSnd +mapSndM :: (Applicative m, Traversable f) => (b -> m c) -> f (a,b) -> m (f (a,c)) +mapSndM = traverse . traverse + +-- | Monadic version of concatMap +concatMapM :: (Monad m, Traversable f) => (a -> m [b]) -> f a -> m [b] +concatMapM f xs = liftM concat (mapM f xs) +{-# INLINE concatMapM #-} +-- It's better to inline to inline this than to specialise +-- concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] +-- Inlining cuts compiler allocation by around 1% + +-- | Applicative version of mapMaybe +mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = foldr g (pure []) + where g a = liftA2 (maybe id (:)) (f a) + +-- | Monadic version of 'any', aborts the computation at the first @True@ value +anyM :: (Monad m, Foldable f) => (a -> m Bool) -> f a -> m Bool +anyM f = foldr (orM . f) (pure False) + +-- | Monad version of 'all', aborts the computation at the first @False@ value +allM :: (Monad m, Foldable f) => (a -> m Bool) -> f a -> m Bool +allM f = foldr (andM . f) (pure True) + +-- | Monadic version of or +orM :: Monad m => m Bool -> m Bool -> m Bool +orM m1 m2 = m1 >>= \x -> if x then return True else m2 + +-- | Monadic version of and +andM :: Monad m => m Bool -> m Bool -> m Bool +andM m1 m2 = m1 >>= \x -> if x then m2 else return False + +-- | Monadic version of foldl that discards its result +foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () +foldlM_ = foldM_ + +-- | Monadic version of 'foldMap' +foldMapM :: (Applicative m, Foldable t, Monoid b) => (a -> m b) -> t a -> m b +foldMapM f = getAp <$> foldMap (Ap . f) + +-- | Monadic version of @when@, taking the condition in the monad +whenM :: Monad m => m Bool -> m () -> m () +whenM mb thing = do { b <- mb + ; when b thing } + +-- | Monadic version of @unless@, taking the condition in the monad +unlessM :: Monad m => m Bool -> m () -> m () +unlessM condM acc = do { cond <- condM + ; unless cond acc } + +-- | Like 'filterM', only it reverses the sense of the test. +filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] +filterOutM p = + foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) + +-- | Monadic version of @partition@ +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = pure ([], []) +partitionM f (x:xs) = do + res <- f x + (as,bs) <- partitionM f xs + pure ([x | res]++as, [x | not res]++bs) + +{- Note [The one-shot state monad trick] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Summary: many places in GHC use a state monad, and we really want those +functions to be eta-expanded (#18202). + +The problem +~~~~~~~~~~~ +Consider + newtype M a = MkM (State -> (State, a)) + + instance Monad M where + mf >>= k = MkM (\s -> case mf of MkM f -> + case f s of (s',r) -> + case k r of MkM g -> + g s') + + fooM :: Int -> M Int + fooM x = g y >>= \r -> h r + where + y = expensive x + +Now suppose you say (repeat 20 (fooM 4)), where + repeat :: Int -> M Int -> M Int +performs its argument n times. You would expect (expensive 4) to be +evaluated only once, not 20 times. So foo should have arity 1 (not 2); +it should look like this (modulo casts) + + fooM x = let y = expensive x in + \s -> case g y of ... + +But creating and then repeating, a monadic computation is rare. If you +/aren't/ re-using (M a) value, it's /much/ more efficient to make +foo have arity 2, thus: + + fooM x s = case g (expensive x) of ... + +Why more efficient? Because now foo takes its argument both at once, +rather than one at a time, creating a heap-allocated function closure. See +https://www.joachim-breitner.de/blog/763-Faster_Winter_5__Eta-Expanding_ReaderT +for a very good explanation of the issue which led to these optimisations +into GHC. + +The trick +~~~~~~~~~ +With state monads like M the general case is that we *aren't* reusing +(M a) values so it is much more efficient to avoid allocating a +function closure for them. So the state monad trick is a way to keep +the monadic syntax but to make GHC eta-expand functions like `fooM`. +To do that we use the "oneShot" magic function. + +Here is the trick: + * Define a "smart constructor" + mkM :: (State -> (State,a)) -> M a + mkM f = MkM (oneShot m) + + * Never call MkM directly, as a constructor. Instead, always call mkM. + +And that's it! The magic 'oneShot' function does this transformation: + oneShot (\s. e) ==> \s{os}. e +which pins a one-shot flag {os} onto the binder 's'. That tells GHC +that it can assume the lambda is called only once, and thus can freely +float computations in and out of the lambda. + +To be concrete, let's see what happens to fooM: + + fooM = \x. g (expensive x) >>= \r -> h r + = \x. let mf = g (expensive x) + k = \r -> h r + in MkM (oneShot (\s -> case mf of MkM' f -> + case f s of (s',r) -> + case k r of MkM' g -> + g s')) + -- The MkM' are just newtype casts nt_co + = \x. let mf = g (expensive x) + k = \r -> h r + in (\s{os}. case (mf |> nt_co) s of (s',r) -> + (k r) |> nt_co s') + |> sym nt_co + + -- Crucial step: float let-bindings into that \s{os} + = \x. (\s{os}. case (g (expensive x) |> nt_co) s of (s',r) -> + h r |> nt_co s') + |> sym nt_co + +and voila! fooM has arity 2. + +The trick is very similar to the built-in "state hack" +(see Note [The state-transformer hack] in "GHC.Core.Opt.Arity") but is +applicable on a monad-by-monad basis under programmer control. + +Using pattern synonyms +~~~~~~~~~~~~~~~~~~~~~~ +Using a smart constructor is fine, but there is no way to check that we +have found *all* uses, especially if the uses escape a single module. +A neat (but more sophisticated) alternative is to use pattern synonyms: + + -- We rename the existing constructor. + newtype M a = MkM' (State -> (State, a)) + + -- The pattern has the old constructor name. + pattern MkM f <- MkM' f + where + MkM f = MkM' (oneShot f) + +Now we can simply grep to check that there are no uses of MkM' +/anywhere/, to guarantee that we have not missed any. (Using the +smart constructor alone we still need the data constructor in +patterns.) That's the advantage of the pattern-synonym approach, but +it is more elaborate. + +The pattern synonym approach is due to Sebastian Graf (#18238) + +Do note that for monads for multiple arguments more than one oneShot +function might be required. For example in FCode we use: + + newtype FCode a = FCode' { doFCode :: StgToCmmConfig -> CgState -> (a, CgState) } + + pattern FCode :: (StgToCmmConfig -> CgState -> (a, CgState)) + -> FCode a + pattern FCode m <- FCode' m + where + FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state)) + +Note [INLINE pragmas and (>>)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A nasty gotcha is described in #20008. In brief, be careful if you get (>>) via +its default method: + + instance Applicative M where + pure a = MkM (\s -> (s, a)) + (<*>) = ap + + instance Monad UM where + {-# INLINE (>>=) #-} + m >>= k = MkM (\s -> blah) + +Here we define (>>), via its default method, in terms of (>>=). If you do this, +be sure to put an INLINE pragma on (>>=), as above. That tells it to inline +(>>=) in the RHS of (>>), even when it is applied to only two arguments, which +in turn conveys the one-shot info from (>>=) to (>>). Lacking the INLINE, GHC +may eta-expand (>>), and with a non-one-shot lambda. #20008 has more discussion. + +Derived instances +~~~~~~~~~~~~~~~~~ +One caveat of both approaches is that derived instances don't use the smart +constructor /or/ the pattern synonym. So they won't benefit from the automatic +insertion of "oneShot". + + data M a = MkM' (State -> (State,a)) + deriving (Functor) <-- Functor implementation will use MkM'! + +Conclusion: don't use 'derviving' in these cases. + +Multi-shot actions (cf #18238) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes we really *do* want computations to be shared! Remember our +example (repeat 20 (fooM 4)). See Note [multiShotIO] in GHC.Types.Unique.Supply + +We can force fooM to have arity 1 using multiShot: + + fooM :: Int -> M Int + fooM x = multiShotM (g y >>= \r -> h r) + where + y = expensive x + + multiShotM :: M a -> M a + {-# INLINE multiShotM #-} + multiShotM (MkM m) = MkM (\s -> inline m s) + -- Really uses the data constructor, + -- not the smart constructor! + +Now we can see how fooM optimises (ignoring casts) + + multiShotM (g y >>= \r -> h r) + ==> {inline (>>=)} + multiShotM (\s{os}. case g y s of ...) + ==> {inline multiShotM} + let m = \s{os}. case g y s of ... + in \s. inline m s + ==> {inline m} + \s. (\s{os}. case g y s of ...) s + ==> \s. case g y s of ... + +and voila! the one-shot flag has gone. It's possible that y has been +replaced by (expensive x), but full laziness should pull it back out. +(This part seems less robust.) + +The magic `inline` function does two things +* It prevents eta reduction. If we wrote just + multiShotIO (IO m) = IO (\s -> m s) + the lambda would eta-reduce to 'm' and all would be lost. + +* It helps ensure that 'm' really does inline. + +Note that 'inline' evaporates in phase 0. See Note [inlineId magic] +in GHC.Core.Opt.ConstantFold.match_inline. + +The INLINE pragma on multiShotM is very important, else the +'inline' call will evaporate when compiling the module that +defines 'multiShotM', before it is ever exported. +-} diff --git a/GHC/Utils/Monad/Codensity.hs b/GHC/Utils/Monad/Codensity.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Monad/Codensity.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module GHC.Utils.Monad.Codensity + ( Codensity(..), toCodensity, fromCodensity ) + where + +import Data.Kind ( Type ) + +import GHC.Prelude +import GHC.Exts ( oneShot ) + +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Concurrent.MVar ( newEmptyMVar, readMVar, putMVar ) +import Control.Exception +import GHC.IO.Exception +import GHC.IO.Unsafe ( unsafeDupableInterleaveIO ) + +-------------------------------------------------------------------------------- + +type Codensity :: (Type -> Type) -> Type -> Type +newtype Codensity m a = Codensity { runCodensity :: forall r. (a -> m r) -> m r } +instance Functor (Codensity k) where + fmap f (Codensity m) = Codensity $ oneShot (\k -> m $ oneShot (\x -> k $ f x)) + {-# INLINE fmap #-} +instance Applicative (Codensity f) where + pure x = Codensity $ oneShot (\k -> k x) + {-# INLINE pure #-} + Codensity f <*> Codensity g = + Codensity $ oneShot (\bfr -> f $ oneShot (\ab -> g $ oneShot (\x -> bfr (ab x)))) + {-# INLINE (<*>) #-} +instance Monad (Codensity f) where + return = pure + {-# INLINE return #-} + m >>= k = + Codensity $ oneShot (\c -> runCodensity m $ oneShot (\a -> runCodensity (k a) c)) + {-# INLINE (>>=) #-} +instance MonadTrans Codensity where + lift m = Codensity $ oneShot (m >>=) + {-# INLINE lift #-} +instance MonadIO m => MonadIO (Codensity m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} +instance MonadIO m => MonadFix (Codensity m) where + mfix f = Codensity $ oneShot $ \ k -> do + promise <- liftIO $ newEmptyMVar + ans <- liftIO $ unsafeDupableInterleaveIO + $ readMVar promise + `catch` + (\ BlockedIndefinitelyOnMVar -> throwIO FixIOException) + runCodensity (f ans) $ oneShot $ \ a -> do + liftIO $ putMVar promise a + k a + {-# INLINE mfix #-} + +toCodensity :: Monad m => m a -> Codensity m a +toCodensity m = Codensity $ oneShot (m >>=) +{-# INLINE toCodensity #-} + +fromCodensity :: Monad m => Codensity m a -> m a +fromCodensity c = runCodensity c return +{-# INLINE fromCodensity #-} diff --git a/GHC/Utils/Monad/State/Strict.hs b/GHC/Utils/Monad/State/Strict.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Monad/State/Strict.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | A state monad which is strict in its state. +module GHC.Utils.Monad.State.Strict + ( -- * The State monad + State(State, State' {- for deriving via purposes only -}) + , state + , evalState + , execState + , runState + -- * Operations + , get + , gets + , put + , modify + ) where + +import GHC.Prelude + +import GHC.Exts (oneShot) + +{- Note [Strict State monad] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A State monad can be strict in many ways. Which kind of strictness do we mean? + +First of, since we represent the result pair as an unboxed pair, this State +monad is strict in the sense of "Control.Monad.Trans.State.Strict": The +computations and the sequencing there-of (through 'Applicative and 'Monad' +instances) are forced strictly. + +Beyond the manual unboxing of one level (which CPR could achieve similarly, +yet perhaps a bit less reliably), our 'State' is even stricter than the +transformers version: +It's also strict in the state `s` (but still lazy in the value `a`). What this +means is that whenever callers examine the state component (perhaps through +'runState'), they will find that the `s` has already been evaluated. + +This additional strictness maintained in a single place, by the ubiquitous +'State' pattern synonym, by forcing the state component *after* any state action +has been run. The INVARIANT is: + +> Any `s` that makes it into the unboxed pair representation is evaluated. + +This invariant has another nice effect: Because the evaluatedness is quite +apparent, Nested CPR will try to unbox the state component `s` nestedly if +feasible. Detecting evaluatedness of nested components is a necessary +condition for Nested CPR to trigger; see the user's guide entry on that: +https://ghc.gitlab.haskell.org/ghc/doc/users_guide/using-optimisation.html#ghc-flag--fcpr-anal + +Note that this doesn't have any effects on whether Nested CPR will unbox the `a` +component (which is still lazy by default). The user still has to use the +`return $!` idiom from the user's guide to encourage Nested CPR to unbox the `a` +result of a stateful computation. +-} + +-- | A state monad which is strict in the state `s`, but lazy in the value `a`. +-- +-- See Note [Strict State monad] for the particular notion of strictness and +-- implementation details. +newtype State s a = State' { runState' :: s -> (# a, s #) } + +pattern State :: (s -> (# a, s #)) + -> State s a + +-- This pattern synonym makes the monad eta-expand, +-- which as a very beneficial effect on compiler performance +-- See #18202. +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +-- It also implements the particular notion of strictness of this monad; +-- see Note [Strict State monad]. +pattern State m <- State' m + where + State m = State' (oneShot $ \s -> forceState (m s)) + +-- | Forces the state component of the unboxed representation pair of 'State'. +-- See Note [Strict State monad]. This is The Place doing the forcing! +forceState :: (# a, s #) -> (# a, s #) +forceState (# a, !s #) = (# a, s #) + +-- See Note [The one-shot state monad trick] for why we don't derive this. +instance Functor (State s) where + fmap f m = State $ \s -> case runState' m s of (# x, s' #) -> (# f x, s' #) + {-# INLINE fmap #-} + +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'' #) }} + m *> n = State $ \s -> + case runState' m s of { (# _, s' #) -> + case runState' n s' of { (# x, s'' #) -> + (# x, s'' #) }} + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + {-# INLINE (*>) #-} + +instance Monad (State s) where + m >>= n = State $ \s -> case runState' m s of + (# r, !s' #) -> runState' (n r) s' + (>>) = (*>) + {-# INLINE (>>=) #-} + {-# INLINE (>>) #-} + +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') diff --git a/GHC/Utils/Outputable.hs b/GHC/Utils/Outputable.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Outputable.hs @@ -0,0 +1,1984 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE FlexibleContexts #-} + +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-1998 +-} + +-- | This module defines classes and functions for pretty-printing. It also +-- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. +-- +-- The interface to this module is very similar to the standard Hughes-PJ pretty printing +-- module, except that it exports a number of additional functions that are rarely used, +-- and works over the 'SDoc' type. +module GHC.Utils.Outputable ( + -- * Type classes + Outputable(..), OutputableBndr(..), OutputableP(..), + BindingSite(..), JoinPointHood(..), isJoinPoint, + + IsOutput(..), IsLine(..), IsDoc(..), + HLine, HDoc, + + -- * Pretty printing combinators + SDoc, runSDoc, PDoc(..), + docToSDoc, + interppSP, interpp'SP, interpp'SP', + pprQuotedList, pprWithCommas, pprWithSemis, + unquotedListWith, pprUnquotedSet, + quotedListWithOr, quotedListWithNor, quotedListWithAnd, + pprWithBars, + spaceIfSingleQuote, + isEmpty, nest, + ptext, + int, intWithCommas, integer, word64, word, float, double, rational, doublePrec, + parens, cparen, brackets, braces, quotes, quote, quoteIfPunsEnabled, + doubleQuotes, angleBrackets, + semi, comma, colon, dcolon, space, equals, dot, vbar, + arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, + lambda, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, + blankLine, forAllLit, bullet, + ($+$), + cat, fcat, + hang, hangNotEmpty, punctuate, punctuateFinal, + ppWhen, ppUnless, ppWhenOption, ppUnlessOption, + speakNth, speakN, speakNOf, plural, singular, pluralSet, + isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave, + itOrThey, + unicodeSyntax, + + coloured, keyword, + + -- * Converting 'SDoc' into strings and outputting it + printSDoc, printSDocLn, + bufLeftRenderSDoc, + pprCode, + showSDocOneLine, + showSDocUnsafe, + showPprUnsafe, + renderWithContext, + pprDebugAndThen, + + pprInfixVar, pprPrefixVar, + pprHsChar, pprHsString, pprHsBytes, + + primFloatSuffix, primCharSuffix, primDoubleSuffix, + primInt8Suffix, primWord8Suffix, + primInt16Suffix, primWord16Suffix, + primInt32Suffix, primWord32Suffix, + primInt64Suffix, primWord64Suffix, + primIntSuffix, primWordSuffix, + + pprPrimChar, pprPrimInt, pprPrimWord, + pprPrimInt8, pprPrimWord8, + pprPrimInt16, pprPrimWord16, + pprPrimInt32, pprPrimWord32, + pprPrimInt64, pprPrimWord64, + + pprFastFilePath, pprFilePathString, + + pprModuleName, + + -- * Controlling the style in which output is printed + PprStyle(..), NamePprCtx(..), + QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, QueryPromotionTick, + PromotedItem(..), IsEmptyOrSingleton(..), isListEmptyOrSingleton, + PromotionTickContext(..), + reallyAlwaysQualify, reallyAlwaysQualifyNames, + alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, + neverQualify, neverQualifyNames, neverQualifyModules, + alwaysQualifyPackages, neverQualifyPackages, + alwaysPrintPromTick, + QualifyName(..), queryQual, + sdocOption, + updSDocContext, + SDocContext (..), sdocWithContext, + defaultSDocContext, traceSDocContext, + getPprStyle, withPprStyle, setStyleColoured, + pprDeeper, pprDeeperList, pprSetDepth, + codeStyle, userStyle, dumpStyle, + qualName, qualModule, qualPackage, promTick, + mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, + mkUserStyle, cmdlineParserStyle, Depth(..), + withUserStyle, withErrStyle, + + ifPprDebug, whenPprDebug, getPprDebug, + + bPutHDoc + ) where + +import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) + +import GHC.Prelude.Basic + +import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName ) +import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) + +import GHC.Utils.BufHandle (BufHandle, bPutChar, bPutStr, bPutFS, bPutFZS) +import GHC.Data.FastString +import qualified GHC.Utils.Ppr as Pretty +import qualified GHC.Utils.Ppr.Colour as Col +import GHC.Utils.Ppr ( Doc, Mode(..) ) +import GHC.Utils.Panic.Plain (assert) +import GHC.Serialized +import GHC.LanguageExtensions (Extension) +import GHC.Utils.GlobalVars( unsafeHasPprDebug ) +import GHC.Utils.Misc (lastMaybe, snocView) + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char +import qualified Data.Map as M +import Data.Int +import qualified Data.IntMap as IM +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet +import qualified GHC.Data.Word64Set as Word64Set +import Data.String +import Data.Word +import System.IO ( Handle ) +import System.FilePath +import Text.Printf +import Numeric (showFFloat) +import Data.Graph (SCC(..)) +import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup (Arg(..)) +import qualified Data.List.NonEmpty as NEL +import Data.Time ( UTCTime ) +import Data.Time.Format.ISO8601 +import Data.Void +import Control.DeepSeq (NFData(rnf)) + +import GHC.Fingerprint +import GHC.Show ( showMultiLineString ) +import GHC.Utils.Exception +import GHC.Exts (oneShot) + +{- +************************************************************************ +* * +\subsection{The @PprStyle@ data type} +* * +************************************************************************ +-} + +data PprStyle + = PprUser NamePprCtx Depth Coloured + -- Pretty-print in a way that will make sense to the + -- ordinary user; must be very close to Haskell + -- syntax, etc. + -- Assumes printing tidied code: non-system names are + -- printed without uniques. + + | PprDump NamePprCtx + -- For -ddump-foo; less verbose than in ppr-debug mode, but more than PprUser + -- Does not assume tidied code: non-external names + -- are printed with uniques. + + | PprCode -- ^ Print code; either C or assembler + +data Depth + = AllTheWay + | PartWay Int -- ^ 0 => stop + | DefaultDepth -- ^ Use 'sdocDefaultDepth' field as depth + +data Coloured + = Uncoloured + | Coloured + +-- ----------------------------------------------------------------------------- +-- Printing original names + +-- | When printing code that contains original names, we need to map the +-- original names back to something the user understands. This is the +-- purpose of the triple of functions that gets passed around +-- when rendering 'SDoc'. +data NamePprCtx = QueryQualify { + queryQualifyName :: QueryQualifyName, + queryQualifyModule :: QueryQualifyModule, + queryQualifyPackage :: QueryQualifyPackage, + queryPromotionTick :: QueryPromotionTick +} + +-- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify +-- it. +type QueryQualifyName = Module -> Maybe ModuleName -> OccName -> QualifyName + +-- | For a given module, we need to know whether to print it with +-- a package name to disambiguate it. +type QueryQualifyModule = Module -> Bool + +-- | For a given package, we need to know whether to print it with +-- the component id to disambiguate it. +type QueryQualifyPackage = Unit -> Bool + +-- | Given a promoted data constructor, +-- decide whether to print a tick to disambiguate the namespace. +type QueryPromotionTick = PromotedItem -> Bool + +-- | Flags that affect whether a promotion tick is printed. +data PromotionTickContext = + PromTickCtx { + ptcListTuplePuns :: !Bool, + ptcPrintRedundantPromTicks :: !Bool + } + +data PromotedItem = + PromotedItemListSyntax IsEmptyOrSingleton -- '[x] + | PromotedItemTupleSyntax -- '(x, y) + | PromotedItemDataCon OccName -- 'MkT + +newtype IsEmptyOrSingleton = IsEmptyOrSingleton Bool + +isListEmptyOrSingleton :: [a] -> IsEmptyOrSingleton +isListEmptyOrSingleton xs = + IsEmptyOrSingleton $ case xs of + [] -> True + [_] -> True + _ -> False + +-- See Note [Printing original names] in GHC.Types.Name.Ppr +data QualifyName -- Given P:M.T + = NameUnqual -- It's in scope unqualified as "T" + -- OR nothing called "T" is in scope + + | NameQual ModuleName -- It's in scope qualified as "X.T" + + | NameNotInScope1 -- It's not in scope at all, but M.T is not bound + -- in the current scope, so we can refer to it as "M.T" + + | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in + -- the current scope, so we must refer to it as "P:M.T" + +instance Outputable QualifyName where + ppr NameUnqual = text "NameUnqual" + ppr (NameQual _mod) = text "NameQual" -- can't print the mod without module loops :( + ppr NameNotInScope1 = text "NameNotInScope1" + ppr NameNotInScope2 = text "NameNotInScope2" + +reallyAlwaysQualifyNames :: QueryQualifyName +reallyAlwaysQualifyNames _ _ _ = NameNotInScope2 + +-- | NB: This won't ever show package IDs +alwaysQualifyNames :: QueryQualifyName +alwaysQualifyNames m _ _ = NameQual (moduleName m) + +neverQualifyNames :: QueryQualifyName +neverQualifyNames _ _ _ = NameUnqual + +alwaysQualifyModules :: QueryQualifyModule +alwaysQualifyModules _ = True + +neverQualifyModules :: QueryQualifyModule +neverQualifyModules _ = False + +alwaysQualifyPackages :: QueryQualifyPackage +alwaysQualifyPackages _ = True + +neverQualifyPackages :: QueryQualifyPackage +neverQualifyPackages _ = False + +alwaysPrintPromTick :: QueryPromotionTick +alwaysPrintPromTick _ = True + +reallyAlwaysQualify, alwaysQualify, neverQualify :: NamePprCtx +reallyAlwaysQualify + = QueryQualify reallyAlwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages + alwaysPrintPromTick +alwaysQualify = QueryQualify alwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages + alwaysPrintPromTick +neverQualify = QueryQualify neverQualifyNames + neverQualifyModules + neverQualifyPackages + alwaysPrintPromTick + +defaultUserStyle :: PprStyle +defaultUserStyle = mkUserStyle neverQualify AllTheWay + +defaultDumpStyle :: PprStyle + -- Print without qualifiers to reduce verbosity, unless -dppr-debug +defaultDumpStyle = PprDump neverQualify + +mkDumpStyle :: NamePprCtx -> PprStyle +mkDumpStyle name_ppr_ctx = PprDump name_ppr_ctx + +-- | Default style for error messages, when we don't know NamePprCtx +-- It's a bit of a hack because it doesn't take into account what's in scope +-- Only used for desugarer warnings, and typechecker errors in interface sigs +defaultErrStyle :: PprStyle +defaultErrStyle = mkErrStyle neverQualify + +-- | Style for printing error messages +mkErrStyle :: NamePprCtx -> PprStyle +mkErrStyle name_ppr_ctx = mkUserStyle name_ppr_ctx DefaultDepth + +cmdlineParserStyle :: PprStyle +cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay + +mkUserStyle :: NamePprCtx -> Depth -> PprStyle +mkUserStyle name_ppr_ctx depth = PprUser name_ppr_ctx depth Uncoloured + +withUserStyle :: NamePprCtx -> Depth -> SDoc -> SDoc +withUserStyle name_ppr_ctx depth doc = withPprStyle (PprUser name_ppr_ctx depth Uncoloured) doc + +withErrStyle :: NamePprCtx -> SDoc -> SDoc +withErrStyle name_ppr_ctx doc = + withPprStyle (mkErrStyle name_ppr_ctx) doc + +setStyleColoured :: Bool -> PprStyle -> PprStyle +setStyleColoured col style = + case style of + PprUser q d _ -> PprUser q d c + _ -> style + where + c | col = Coloured + | otherwise = Uncoloured + +instance Outputable PprStyle where + ppr (PprUser {}) = text "user-style" + ppr (PprCode {}) = text "code-style" + ppr (PprDump {}) = text "dump-style" + +{- +Orthogonal to the above printing styles are (possibly) some +command-line flags that affect printing (often carried with the +style). The most likely ones are variations on how much type info is +shown. + +The following test decides whether or not we are actually generating +code (either C or assembly), or generating interface files. + +************************************************************************ +* * +\subsection{The @SDoc@ data type} +* * +************************************************************************ +-} + +-- | Represents a pretty-printable document. +-- +-- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc', +-- or 'renderWithContext'. Avoid calling 'runSDoc' directly as it breaks the +-- abstraction layer. +newtype SDoc = SDoc' (SDocContext -> Doc) + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +{-# COMPLETE SDoc #-} +pattern SDoc :: (SDocContext -> Doc) -> SDoc +pattern SDoc m <- SDoc' m + where + SDoc m = SDoc' (oneShot m) + +runSDoc :: SDoc -> (SDocContext -> Doc) +runSDoc (SDoc m) = m + +data SDocContext = SDC + { sdocStyle :: !PprStyle + , sdocColScheme :: !Col.Scheme + , sdocLastColour :: !Col.PprColour + -- ^ The most recently used colour. + -- This allows nesting colours. + , sdocShouldUseColor :: !Bool + , sdocDefaultDepth :: !Int + , sdocLineLength :: !Int + , sdocCanUseUnicode :: !Bool + -- ^ True if Unicode encoding is supported + -- and not disabled by GHC_NO_UNICODE environment variable + , sdocPrintErrIndexLinks :: !Bool + , sdocHexWordLiterals :: !Bool + , sdocPprDebug :: !Bool + , sdocPrintUnicodeSyntax :: !Bool + , sdocPrintCaseAsLet :: !Bool + , sdocPrintTypecheckerElaboration :: !Bool + , sdocPrintAxiomIncomps :: !Bool + , sdocPrintExplicitKinds :: !Bool + , sdocPrintExplicitCoercions :: !Bool + , sdocPrintExplicitRuntimeReps :: !Bool + , sdocPrintExplicitForalls :: !Bool + , sdocPrintPotentialInstances :: !Bool + , sdocPrintEqualityRelations :: !Bool + , sdocSuppressTicks :: !Bool + , sdocSuppressTypeSignatures :: !Bool + , sdocSuppressTypeApplications :: !Bool + , sdocSuppressIdInfo :: !Bool + , sdocSuppressCoercions :: !Bool + , sdocSuppressCoercionTypes :: !Bool + , sdocSuppressUnfoldings :: !Bool + , sdocSuppressVarKinds :: !Bool + , sdocSuppressUniques :: !Bool + , sdocSuppressModulePrefixes :: !Bool + , sdocSuppressStgExts :: !Bool + , sdocSuppressStgReps :: !Bool + , sdocErrorSpans :: !Bool + , sdocStarIsType :: !Bool + , sdocLinearTypes :: !Bool + , sdocListTuplePuns :: !Bool + , sdocPrintTypeAbbreviations :: !Bool + , sdocUnitIdForUser :: !(FastString -> SDoc) + -- ^ Used to map UnitIds to more friendly "package-version:component" + -- strings while pretty-printing. + -- + -- Use `GHC.Unit.State.pprWithUnitState` to set it. Users should never + -- have to set it to pretty-print SDocs emitted by GHC, otherwise it's a + -- bug. It's an internal field used to thread the UnitState so that the + -- Outputable instance of UnitId can use it. + -- + -- See Note [Pretty-printing UnitId] in "GHC.Unit" for more details. + -- + -- Note that we use `FastString` instead of `UnitId` to avoid boring + -- module inter-dependency issues. + } + +instance IsString SDoc where + fromString = text + +-- The lazy programmer's friend. +instance Outputable SDoc where + ppr = id + +-- | Default pretty-printing options +defaultSDocContext :: SDocContext +defaultSDocContext = SDC + { sdocStyle = defaultDumpStyle + , sdocColScheme = Col.defaultScheme + , sdocLastColour = Col.colReset + , sdocShouldUseColor = False + , sdocDefaultDepth = 5 + , sdocLineLength = 100 + , sdocCanUseUnicode = False + , sdocPrintErrIndexLinks = False + , sdocHexWordLiterals = False + , sdocPprDebug = False + , sdocPrintUnicodeSyntax = False + , sdocPrintCaseAsLet = False + , sdocPrintTypecheckerElaboration = False + , sdocPrintAxiomIncomps = False + , sdocPrintExplicitKinds = False + , sdocPrintExplicitCoercions = False + , sdocPrintExplicitRuntimeReps = False + , sdocPrintExplicitForalls = False + , sdocPrintPotentialInstances = False + , sdocPrintEqualityRelations = False + , sdocSuppressTicks = False + , sdocSuppressTypeSignatures = False + , sdocSuppressTypeApplications = False + , sdocSuppressIdInfo = False + , sdocSuppressCoercions = False + , sdocSuppressCoercionTypes = False + , sdocSuppressUnfoldings = False + , sdocSuppressVarKinds = False + , sdocSuppressUniques = False + , sdocSuppressModulePrefixes = False + , sdocSuppressStgExts = False + , sdocSuppressStgReps = True + , sdocErrorSpans = False + , sdocStarIsType = False + , sdocLinearTypes = False + , sdocListTuplePuns = True + , sdocPrintTypeAbbreviations = True + , sdocUnitIdForUser = ftext + } + +traceSDocContext :: SDocContext +-- Used for pprTrace, when we want to see lots of info +traceSDocContext = defaultSDocContext + { sdocPprDebug = unsafeHasPprDebug + , sdocPrintTypecheckerElaboration = True + , sdocPrintExplicitKinds = True + , sdocPrintExplicitCoercions = True + , sdocPrintExplicitRuntimeReps = True + , sdocPrintExplicitForalls = True + , sdocPrintEqualityRelations = True + } + +withPprStyle :: PprStyle -> SDoc -> SDoc +{-# INLINE CONLIKE withPprStyle #-} +withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} + +pprDeeper :: SDoc -> SDoc +pprDeeper d = SDoc $ \ctx -> case sdocStyle ctx of + PprUser q depth c -> + let deeper 0 = Pretty.text "..." + deeper n = runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c} + in case depth of + DefaultDepth -> deeper (sdocDefaultDepth ctx) + PartWay n -> deeper n + AllTheWay -> runSDoc d ctx + _ -> runSDoc d ctx + + +-- | Truncate a list that is longer than the current depth. +pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc +pprDeeperList f ds + | null ds = f [] + | otherwise = SDoc work + where + work ctx@SDC{sdocStyle=PprUser q depth c} + | DefaultDepth <- depth + = work (ctx { sdocStyle = PprUser q (PartWay (sdocDefaultDepth ctx)) c }) + | PartWay 0 <- depth + = Pretty.text "..." + | PartWay n <- depth + = let + go _ [] = [] + go i (d:ds) | i >= n = [text "...."] + | otherwise = d : go (i+1) ds + in runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c} + work other_ctx = runSDoc (f ds) other_ctx + +pprSetDepth :: Depth -> SDoc -> SDoc +pprSetDepth depth doc = SDoc $ \ctx -> + case ctx of + SDC{sdocStyle=PprUser q _ c} -> + runSDoc doc ctx{sdocStyle = PprUser q depth c} + _ -> + runSDoc doc ctx + +getPprStyle :: (PprStyle -> SDoc) -> SDoc +{-# INLINE CONLIKE getPprStyle #-} +getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx + +sdocWithContext :: (SDocContext -> SDoc) -> SDoc +{-# INLINE CONLIKE sdocWithContext #-} +sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx + +sdocOption :: (SDocContext -> a) -> (a -> SDoc) -> SDoc +{-# INLINE CONLIKE sdocOption #-} +sdocOption f g = sdocWithContext (g . f) + +updSDocContext :: (SDocContext -> SDocContext) -> SDoc -> SDoc +{-# INLINE CONLIKE updSDocContext #-} +updSDocContext upd doc + = SDoc $ \ctx -> runSDoc doc (upd ctx) + +qualName :: PprStyle -> QueryQualifyName +qualName (PprUser q _ _) mod user_qual occ = queryQualifyName q mod user_qual occ +qualName (PprDump q) mod user_qual occ = queryQualifyName q mod user_qual occ +qualName _other mod _ _ = NameQual (moduleName mod) + +qualModule :: PprStyle -> QueryQualifyModule +qualModule (PprUser q _ _) m = queryQualifyModule q m +qualModule (PprDump q) m = queryQualifyModule q m +qualModule _other _m = True + +qualPackage :: PprStyle -> QueryQualifyPackage +qualPackage (PprUser q _ _) m = queryQualifyPackage q m +qualPackage (PprDump q) m = queryQualifyPackage q m +qualPackage _other _m = True + +promTick :: PprStyle -> QueryPromotionTick +promTick (PprUser q _ _) occ = queryPromotionTick q occ +promTick (PprDump q) occ = queryPromotionTick q occ +promTick _ _ = True + +queryQual :: PprStyle -> NamePprCtx +queryQual s = QueryQualify (qualName s) + (qualModule s) + (qualPackage s) + (promTick s) + +codeStyle :: PprStyle -> Bool +codeStyle PprCode = True +codeStyle _ = False + +dumpStyle :: PprStyle -> Bool +dumpStyle (PprDump {}) = True +dumpStyle _other = False + +userStyle :: PprStyle -> Bool +userStyle (PprUser {}) = True +userStyle _other = False + +-- | Indicate if -dppr-debug mode is enabled +getPprDebug :: IsOutput doc => (Bool -> doc) -> doc +{-# INLINE CONLIKE getPprDebug #-} +getPprDebug d = docWithContext $ \ctx -> d (sdocPprDebug ctx) + +-- | Says what to do with and without -dppr-debug +ifPprDebug :: IsOutput doc => doc -> doc -> doc +{-# INLINE CONLIKE ifPprDebug #-} +ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no + +-- | Says what to do with -dppr-debug; without, return empty +whenPprDebug :: IsOutput doc => doc -> doc -- Empty for non-debug style +{-# INLINE CONLIKE whenPprDebug #-} +whenPprDebug d = ifPprDebug d empty + +-- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the +-- terminal doesn't get screwed up by the ANSI color codes if an exception +-- is thrown during pretty-printing. +printSDoc :: SDocContext -> Mode -> Handle -> SDoc -> IO () +printSDoc ctx mode handle doc = + Pretty.printDoc_ mode cols handle (runSDoc doc ctx) + `finally` + Pretty.printDoc_ mode cols handle + (runSDoc (coloured Col.colReset empty) ctx) + where + cols = sdocLineLength ctx + +-- | Like 'printSDoc' but appends an extra newline. +printSDocLn :: SDocContext -> Mode -> Handle -> SDoc -> IO () +printSDocLn ctx mode handle doc = + printSDoc ctx mode handle (doc $$ text "") + +-- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that +-- outputs to a 'BufHandle'. +bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO () +bufLeftRenderSDoc ctx bufHandle doc = + Pretty.bufLeftRender bufHandle (runSDoc doc ctx) + +pprCode :: SDoc -> SDoc +{-# INLINE CONLIKE pprCode #-} +pprCode d = withPprStyle PprCode d + +renderWithContext :: SDocContext -> SDoc -> String +renderWithContext ctx sdoc + = let s = Pretty.style{ Pretty.mode = PageMode False, + Pretty.lineLength = sdocLineLength ctx } + in Pretty.renderStyle s $ runSDoc sdoc ctx + +-- This shows an SDoc, but on one line only. It's cheaper than a full +-- showSDoc, designed for when we're getting results like "Foo.bar" +-- and "foo{uniq strictness}" so we don't want fancy layout anyway. +showSDocOneLine :: SDocContext -> SDoc -> String +showSDocOneLine ctx d + = let s = Pretty.style{ Pretty.mode = OneLineMode, + Pretty.lineLength = sdocLineLength ctx } in + Pretty.renderStyle s $ + runSDoc d ctx + +showSDocUnsafe :: SDoc -> String +showSDocUnsafe sdoc = renderWithContext defaultSDocContext sdoc + +showPprUnsafe :: Outputable a => a -> String +showPprUnsafe a = renderWithContext defaultSDocContext (ppr a) + + +pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a +pprDebugAndThen ctx cont heading pretty_msg + = cont (renderWithContext ctx doc) + where + doc = withPprStyle defaultDumpStyle (sep [heading, nest 2 pretty_msg]) + + +isEmpty :: SDocContext -> SDoc -> Bool +isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True}) + +docToSDoc :: Doc -> SDoc +docToSDoc d = SDoc (\_ -> d) + +ptext :: PtrString -> SDoc +int :: IsLine doc => Int -> doc +integer :: IsLine doc => Integer -> doc +word :: Integer -> SDoc +word64 :: IsLine doc => Word64 -> doc +float :: IsLine doc => Float -> doc +double :: IsLine doc => Double -> doc +rational :: Rational -> SDoc + +{-# INLINE CONLIKE ptext #-} +ptext s = docToSDoc $ Pretty.ptext s +{-# INLINE CONLIKE int #-} +int n = text $ show n +{-# INLINE CONLIKE integer #-} +integer n = text $ show n +{-# INLINE CONLIKE float #-} +float n = text $ show n +{-# INLINE CONLIKE double #-} +double n = text $ show n +{-# INLINE CONLIKE rational #-} +rational n = text $ show n + -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr +{-# INLINE CONLIKE word64 #-} +word64 n = text $ show n +{-# INLINE CONLIKE word #-} +word n = sdocOption sdocHexWordLiterals $ \case + True -> docToSDoc $ Pretty.hex n + False -> docToSDoc $ Pretty.integer n + +-- | @doublePrec p n@ shows a floating point number @n@ with @p@ +-- digits of precision after the decimal point. +doublePrec :: Int -> Double -> SDoc +doublePrec p n = text (showFFloat (Just p) n "") + +quotes, quote :: SDoc -> SDoc +parens, brackets, braces, doubleQuotes, angleBrackets :: IsLine doc => doc -> doc + +{-# INLINE CONLIKE parens #-} +parens d = char '(' <> d <> char ')' +{-# INLINE CONLIKE braces #-} +braces d = char '{' <> d <> char '}' +{-# INLINE CONLIKE brackets #-} +brackets d = char '[' <> d <> char ']' +{-# INLINE CONLIKE quote #-} +quote d = SDoc $ Pretty.quote . runSDoc d +{-# INLINE CONLIKE doubleQuotes #-} +doubleQuotes d = char '"' <> d <> char '"' +{-# INLINE CONLIKE angleBrackets #-} +angleBrackets d = char '<' <> d <> char '>' + +cparen :: Bool -> SDoc -> SDoc +{-# INLINE CONLIKE cparen #-} +cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d + +quoteIfPunsEnabled :: SDoc -> SDoc +quoteIfPunsEnabled doc = + sdocOption sdocListTuplePuns $ \case + True -> quote doc + False -> doc + +-- 'quotes' encloses something in single quotes... +-- but it omits them if the thing begins or ends in a single quote +-- so that we don't get `foo''. Instead we just have foo'. +quotes d = sdocOption sdocCanUseUnicode $ \case + True -> char '‘' <> d <> char '’' + False -> SDoc $ \sty -> + let pp_d = runSDoc d sty + str = show pp_d + in case str of + [] -> Pretty.quotes pp_d + '\'' : _ -> pp_d + _ | Just '\'' <- lastMaybe str -> pp_d + | otherwise -> Pretty.quotes pp_d + +blankLine, dcolon, arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, + larrowtt, lambda :: SDoc + +blankLine = docToSDoc Pretty.emptyText +dcolon = unicodeSyntax (char '∷') (text "::") +arrow = unicodeSyntax (char '→') (text "->") +lollipop = unicodeSyntax (char '⊸') (text "%1 ->") +larrow = unicodeSyntax (char '←') (text "<-") +darrow = unicodeSyntax (char '⇒') (text "=>") +arrowt = unicodeSyntax (char '⤚') (text ">-") +larrowt = unicodeSyntax (char '⤙') (text "-<") +arrowtt = unicodeSyntax (char '⤜') (text ">>-") +larrowtt = unicodeSyntax (char '⤛') (text "-<<") +lambda = unicodeSyntax (char 'λ') (char '\\') + +semi, comma, colon, equals, space, underscore, dot, vbar :: IsLine doc => doc +lparen, rparen, lbrack, rbrack, lbrace, rbrace :: IsLine doc => doc +semi = char ';' +comma = char ',' +colon = char ':' +equals = char '=' +space = char ' ' +underscore = char '_' +dot = char '.' +vbar = char '|' +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' + +forAllLit :: SDoc +forAllLit = unicodeSyntax (char '∀') (text "forall") + +bullet :: SDoc +bullet = unicode (char '•') (char '*') + +unicodeSyntax :: SDoc -> SDoc -> SDoc +unicodeSyntax unicode plain = + sdocOption sdocCanUseUnicode $ \can_use_unicode -> + sdocOption sdocPrintUnicodeSyntax $ \print_unicode_syntax -> + if can_use_unicode && print_unicode_syntax + then unicode + else plain + +unicode :: SDoc -> SDoc -> SDoc +unicode unicode plain = sdocOption sdocCanUseUnicode $ \case + True -> unicode + False -> plain + +nest :: Int -> SDoc -> SDoc +-- ^ Indent 'SDoc' some specified amount +($+$) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together vertically + +{-# INLINE CONLIKE nest #-} +nest n d = SDoc $ Pretty.nest n . runSDoc d +{-# INLINE CONLIKE ($+$) #-} +($+$) d1 d2 = SDoc $ \ctx -> (Pretty.$+$) (runSDoc d1 ctx) (runSDoc d2 ctx) + +cat :: [SDoc] -> SDoc +-- ^ A paragraph-fill combinator. It's much like sep, only it +-- keeps fitting things on one line until it can't fit any more. +fcat :: [SDoc] -> SDoc +-- ^ This behaves like 'fsep', but it uses '<>' for horizontal composition rather than '<+>' + + +-- Inline all those wrappers to help ensure we create lists of Doc, not of SDoc +-- later applied to the same SDocContext. It helps the worker/wrapper +-- transformation extracting only the required fields from the SDocContext. +{-# INLINE CONLIKE cat #-} +cat ds = SDoc $ \ctx -> Pretty.cat [runSDoc d ctx | d <- ds] +{-# INLINE CONLIKE fcat #-} +fcat ds = SDoc $ \ctx -> Pretty.fcat [runSDoc d ctx | d <- ds] + +hang :: SDoc -- ^ The header + -> Int -- ^ Amount to indent the hung body + -> SDoc -- ^ The hung body, indented and placed below the header + -> SDoc +{-# INLINE CONLIKE hang #-} +hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) + +-- | This behaves like 'hang', but does not indent the second document +-- when the header is empty. +hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc +{-# INLINE CONLIKE hangNotEmpty #-} +hangNotEmpty d1 n d2 = + SDoc $ \ctx -> Pretty.hangNotEmpty (runSDoc d1 ctx) n (runSDoc d2 ctx) + +punctuate :: IsLine doc + => doc -- ^ The punctuation + -> [doc] -- ^ The list that will have punctuation added between every adjacent pair of elements + -> [doc] -- ^ Punctuated list +punctuate _ [] = [] +punctuate p (d:ds) = go d ds + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es + +-- | Punctuate a list, e.g. with commas and dots. +-- +-- > sep $ punctuateFinal comma dot [text "ab", text "cd", text "ef"] +-- > ab, cd, ef. +punctuateFinal :: IsLine doc + => doc -- ^ The interstitial punctuation + -> doc -- ^ The final punctuation + -> [doc] -- ^ The list that will have punctuation added between every adjacent pair of elements + -> [doc] -- ^ Punctuated list +punctuateFinal _ _ [] = [] +punctuateFinal p q (d:ds) = go d ds + where + go d [] = [d <> q] + go d (e:es) = (d <> p) : go e es + +ppWhen, ppUnless :: IsOutput doc => Bool -> doc -> doc +{-# INLINE CONLIKE ppWhen #-} +ppWhen True doc = doc +ppWhen False _ = empty + +{-# INLINE CONLIKE ppUnless #-} +ppUnless True _ = empty +ppUnless False doc = doc + +{-# INLINE CONLIKE ppWhenOption #-} +ppWhenOption :: (SDocContext -> Bool) -> SDoc -> SDoc +ppWhenOption f doc = sdocOption f $ \case + True -> doc + False -> empty + +{-# INLINE CONLIKE ppUnlessOption #-} +ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc +ppUnlessOption f doc = sdocOption f $ \case + True -> empty + False -> doc + +-- | Apply the given colour\/style for the argument. +-- +-- Only takes effect if colours are enabled. +coloured :: Col.PprColour -> SDoc -> SDoc +coloured col sdoc = sdocOption sdocShouldUseColor $ \case + True -> SDoc $ \case + ctx@SDC{ sdocLastColour = lastCol, sdocStyle = PprUser _ _ Coloured } -> + let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in + Pretty.zeroWidthText (Col.renderColour col) + Pretty.<> runSDoc sdoc ctx' + Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol) + ctx -> runSDoc sdoc ctx + False -> sdoc + +keyword :: SDoc -> SDoc +keyword = coloured Col.colBold + +----------------------------------------------------------------------- +-- The @Outputable@ class +----------------------------------------------------------------------- + +-- | Class designating that some type has an 'SDoc' representation +class Outputable a where + ppr :: a -> SDoc + +-- There's no Outputable for Char; it's too easy to use Outputable +-- on String and have ppr "hello" rendered as "h,e,l,l,o". + +instance Outputable Void where + ppr _ = text "<>" + +instance Outputable Bool where + ppr True = text "True" + ppr False = text "False" + +instance Outputable Ordering where + ppr LT = text "LT" + ppr EQ = text "EQ" + ppr GT = text "GT" + +instance Outputable Int8 where + ppr n = integer $ fromIntegral n + +instance Outputable Int16 where + ppr n = integer $ fromIntegral n + +instance Outputable Int32 where + ppr n = integer $ fromIntegral n + +instance Outputable Int64 where + ppr n = integer $ fromIntegral n + +instance Outputable Int where + ppr n = int n + +instance Outputable Integer where + ppr n = integer n + +instance Outputable Word8 where + ppr n = integer $ fromIntegral n + +instance Outputable Word16 where + ppr n = integer $ fromIntegral n + +instance Outputable Word32 where + ppr n = integer $ fromIntegral n + +instance Outputable Word64 where + ppr n = integer $ fromIntegral n + +instance Outputable Word where + ppr n = integer $ fromIntegral n + +instance Outputable Float where + ppr f = float f + +instance Outputable Double where + ppr f = double f + +instance Outputable () where + ppr _ = text "()" + +instance Outputable UTCTime where + ppr = text . formatShow iso8601Format + +instance (Outputable a) => Outputable [a] where + ppr xs = brackets (pprWithCommas ppr xs) + +instance (Outputable a) => Outputable (NonEmpty a) where + ppr = ppr . NEL.toList + +instance (Outputable a, Outputable b) => Outputable (Arg a b) where + ppr (Arg a b) = text "Arg" <+> ppr a <+> ppr b + +instance (Outputable a) => Outputable (Set a) where + ppr s = braces (pprWithCommas ppr (Set.toList s)) + +instance Outputable Word64Set.Word64Set where + ppr s = braces (pprWithCommas ppr (Word64Set.toList s)) + +instance Outputable IntSet.IntSet where + ppr s = braces (pprWithCommas ppr (IntSet.toList s)) + +instance (Outputable a, Outputable b) => Outputable (a, b) where + ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) + +instance Outputable a => Outputable (Maybe a) where + ppr Nothing = text "Nothing" + ppr (Just x) = text "Just" <+> ppr x + +instance (Outputable a, Outputable b) => Outputable (Either a b) where + ppr (Left x) = text "Left" <+> ppr x + ppr (Right y) = text "Right" <+> ppr y + +-- ToDo: may not be used +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where + ppr (x,y,z) = + parens (sep [ppr x <> comma, + ppr y <> comma, + ppr z ]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d) => + Outputable (a, b, c, d) where + ppr (a,b,c,d) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => + Outputable (a, b, c, d, e) where + ppr (a,b,c,d,e) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => + Outputable (a, b, c, d, e, f) where + ppr (a,b,c,d,e,f) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => + Outputable (a, b, c, d, e, f, g) where + ppr (a,b,c,d,e,f,g) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f <> comma, + ppr g]) + +instance Outputable FastString where + ppr fs = ftext fs -- Prints an unadorned string, + -- no double quotes or anything + +deriving newtype instance Outputable NonDetFastString +deriving newtype instance Outputable LexicalFastString + +instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where + ppr m = ppr (M.toList m) + +instance (Outputable elt) => Outputable (IM.IntMap elt) where + ppr m = ppr (IM.toList m) + +instance Outputable Fingerprint where + ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) + +instance Outputable a => Outputable (SCC a) where + ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) + ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) + +instance Outputable Serialized where + ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) + +instance Outputable Extension where + ppr = text . show + +instance Outputable ModuleName where + ppr = pprModuleName + + +pprModuleName :: IsLine doc => ModuleName -> doc +pprModuleName (ModuleName nm) = + docWithStyle (ztext (zEncodeFS nm)) (\_ -> ftext nm) +{-# SPECIALIZE pprModuleName :: ModuleName -> SDoc #-} +{-# SPECIALIZE pprModuleName :: ModuleName -> HLine #-} -- see Note [SPECIALIZE to HDoc] + +----------------------------------------------------------------------- +-- The @OutputableP@ class +----------------------------------------------------------------------- + +-- Note [The OutputableP class] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- SDoc has become the common type to +-- * display messages in the terminal +-- * dump outputs (Cmm, Asm, C, etc.) +-- * return messages to ghc-api clients +-- +-- SDoc is a kind of state Monad: SDoc ~ State SDocContext Doc +-- I.e. to render a SDoc, a SDocContext must be provided. +-- +-- SDocContext contains legit rendering options (e.g., line length, color and +-- unicode settings). Sadly SDocContext ended up also being used to thread +-- values that were considered bothersome to thread otherwise: +-- * current HomeModule: to decide if module names must be printed qualified +-- * current UnitState: to print unit-ids as "packagename-version:component" +-- * target platform: to render labels, instructions, etc. +-- * selected backend: to display CLabel as C labels or Asm labels +-- +-- In fact the whole compiler session state that is DynFlags was passed in +-- SDocContext and these values were retrieved from it. +-- +-- The Outputable class makes SDoc creation easy for many values by providing +-- the ppr method: +-- +-- class Outputable a where +-- ppr :: a -> SDoc +-- +-- Almost every type is Outputable in the compiler and it seems great because it +-- is similar to the Show class. But it's a fallacious simplicity because `SDoc` +-- needs a `SDocContext` to be transformed into a renderable `Doc`: who is going +-- to provide the SDocContext with the correct values in it? +-- +-- E.g. if a SDoc is returned in an exception, how could we know the home +-- module at the time it was thrown? +-- +-- A workaround is to pass dummy values (no home module, empty UnitState) at SDoc +-- rendering time and to hope that the code that produced the SDoc has updated +-- the SDocContext with meaningful values (e.g. using withPprStyle or +-- pprWithUnitState). If the context isn't correctly updated, a dummy value is +-- used and the printed result isn't what we expected. Note that the compiler +-- doesn't help us finding spots where we need to update the SDocContext. +-- +-- In some cases we can't pass a dummy value because we can't create one. For +-- example, how can we create a dummy Platform value? In the old days, GHC only +-- supported a single Platform set when it was built, so we could use it without +-- any risk of mistake. But now GHC starts supporting several Platform in the +-- same session so it becomes an issue. We could be tempted to use the +-- workaround described above by using "undefined" as a dummy Platform value. +-- However in this case, if we forget to update it we will get a runtime +-- error/crash. We could use "Maybe Platform" and die with a better error +-- message at places where we really really need to know if we are on Windows or +-- not, or if we use 32- or 64-bit. Still the compiler would not help us in +-- finding spots where to update the context with a valid Platform. +-- +-- So finally here comes the OutputableP class: +-- +-- class OutputableP env a where +-- pdoc :: env -> a -> SDoc +-- +-- OutputableP forces us to thread an environment necessary to print a value. +-- For now we only use it to thread a Platform environment, so we have several +-- "Outputable Platform XYZ" instances. In the future we could imagine using a +-- Has class to retrieve a value from a generic environment to make the code +-- more composable. E.g.: +-- +-- instance Has Platform env => OutputableP env XYZ where +-- pdoc env a = ... (getter env :: Platform) +-- +-- A drawback of this approach over Outputable is that we have to thread an +-- environment explicitly to use "pdoc" and it's more cumbersome. But it's the +-- price to pay to have some help from the compiler to ensure that we... thread +-- an environment down to the places where we need it, i.e. where SDoc are +-- created (not rendered). On the other hand, it makes life easier for SDoc +-- renderers as they only have to deal with pretty-printing related options in +-- SDocContext. +-- +-- TODO: +-- +-- 1) we could use OutputableP to thread a UnitState and replace the Outputable +-- instance of UnitId with: +-- +-- instance OutputableP UnitState UnitId where ... +-- +-- This would allow the removal of the `sdocUnitIdForUser` field. +-- +-- Be warned: I've tried to do it, but there are A LOT of other Outputable +-- instances depending on UnitId's one. In particular: +-- UnitId <- Unit <- Module <- Name <- Var <- Core.{Type,Expr} <- ... +-- +-- 2) Use it to pass the HomeModule (but I fear it will be as difficult as for +-- UnitId). +-- +-- + +-- | Outputable class with an additional environment value +-- +-- See Note [The OutputableP class] +class OutputableP env a where + pdoc :: env -> a -> SDoc + +-- | Wrapper for types having a Outputable instance when an OutputableP instance +-- is required. +newtype PDoc a = PDoc a + +instance Outputable a => OutputableP env (PDoc a) where + pdoc _ (PDoc a) = ppr a + +instance OutputableP env a => OutputableP env [a] where + pdoc env xs = ppr (fmap (pdoc env) xs) + +instance OutputableP env a => OutputableP env (Maybe a) where + pdoc env xs = ppr (fmap (pdoc env) xs) + +instance OutputableP env () where + pdoc _ _ = ppr () + +instance (OutputableP env a, OutputableP env b) => OutputableP env (a, b) where + pdoc env (a,b) = ppr (pdoc env a, pdoc env b) + +instance (OutputableP env a, OutputableP env b, OutputableP env c) => OutputableP env (a, b, c) where + pdoc env (a,b,c) = ppr (pdoc env a, pdoc env b, pdoc env c) + + +instance (OutputableP env key, OutputableP env elt) => OutputableP env (M.Map key elt) where + pdoc env m = ppr $ fmap (\(x,y) -> (pdoc env x, pdoc env y)) $ M.toList m + +instance OutputableP env a => OutputableP env (SCC a) where + pdoc env scc = ppr (fmap (pdoc env) scc) + +instance OutputableP env SDoc where + pdoc _ x = x + +instance (OutputableP env a) => OutputableP env (Set a) where + pdoc env s = braces (fsep (punctuate comma (map (pdoc env) (Set.toList s)))) + +instance OutputableP env Void where + pdoc _ = \ case + +{- +************************************************************************ +* * +\subsection{The @OutputableBndr@ class} +* * +************************************************************************ +-} + +-- | When we print a binder, we often want to print its type too. +-- The @OutputableBndr@ class encapsulates this idea. +class Outputable a => OutputableBndr a where + pprBndr :: BindingSite -> a -> SDoc + pprBndr _b x = ppr x + + pprPrefixOcc, pprInfixOcc :: a -> SDoc + -- Print an occurrence of the name, suitable either in the + -- prefix position of an application, thus (f a b) or ((+) x) + -- or infix position, thus (a `f` b) or (x + y) + + bndrIsJoin_maybe :: a -> JoinPointHood + bndrIsJoin_maybe _ = NotJoinPoint + -- When pretty-printing we sometimes want to find + -- whether the binder is a join point. You might think + -- we could have a function of type (a->Var), but Var + -- isn't available yet, alas + +-- | 'BindingSite' is used to tell the thing that prints binder what +-- language construct is binding the identifier. This can be used +-- to decide how much info to print. +-- Also see Note [Binding-site specific printing] in "GHC.Core.Ppr" +data BindingSite + = LambdaBind -- ^ The x in (\x. e) + | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... } + | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... } + | LetBind -- ^ The x in (let x = rhs in e) + deriving Eq + +data JoinPointHood + = JoinPoint {-# UNPACK #-} !Int -- The JoinArity (but an Int here because + | NotJoinPoint -- synonym JoinArity is defined in Types.Basic) + deriving( Eq ) + +isJoinPoint :: JoinPointHood -> Bool +isJoinPoint (JoinPoint {}) = True +isJoinPoint NotJoinPoint = False + +instance Outputable JoinPointHood where + ppr NotJoinPoint = text "NotJoinPoint" + ppr (JoinPoint arity) = text "JoinPoint" <> parens (ppr arity) + +instance NFData JoinPointHood where + rnf x = x `seq` () + +{- +************************************************************************ +* * +\subsection{Random printing helpers} +* * +************************************************************************ +-} + +-- We have 31-bit Chars and will simply use Show instances of Char and String. + +-- | Special combinator for showing character literals. +pprHsChar :: Char -> SDoc +pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) + | otherwise = text (show c) + +-- | Special combinator for showing string literals. +pprHsString :: FastString -> SDoc +pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) + +-- | Special combinator for showing bytestring literals. +pprHsBytes :: ByteString -> SDoc +pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs + in vcat (map text (showMultiLineString escaped)) <> char '#' + where escape :: Word8 -> String + escape w = let c = chr (fromIntegral w) + in if isAscii c + then [c] + else '\\' : show w + +-- Postfix modifiers for unboxed literals. +-- See Note [Printing of literals in Core] in "GHC.Types.Literal". +primCharSuffix, primFloatSuffix, primDoubleSuffix, + primIntSuffix, primWordSuffix, + primInt8Suffix, primWord8Suffix, + primInt16Suffix, primWord16Suffix, + primInt32Suffix, primWord32Suffix, + primInt64Suffix, primWord64Suffix + :: SDoc +primCharSuffix = char '#' +primFloatSuffix = char '#' +primIntSuffix = char '#' +primDoubleSuffix = text "##" +primWordSuffix = text "##" +primInt8Suffix = text "#Int8" +primWord8Suffix = text "#Word8" +primInt16Suffix = text "#Int16" +primWord16Suffix = text "#Word16" +primInt32Suffix = text "#Int32" +primWord32Suffix = text "#Word32" +primInt64Suffix = text "#Int64" +primWord64Suffix = text "#Word64" + +-- | Special combinator for showing unboxed literals. +pprPrimChar :: Char -> SDoc +pprPrimInt, pprPrimWord, + pprPrimInt8, pprPrimWord8, + pprPrimInt16, pprPrimWord16, + pprPrimInt32, pprPrimWord32, + pprPrimInt64, pprPrimWord64 + :: Integer -> SDoc +pprPrimChar c = pprHsChar c <> primCharSuffix +pprPrimInt i = integer i <> primIntSuffix +pprPrimWord w = word w <> primWordSuffix +pprPrimInt8 i = integer i <> primInt8Suffix +pprPrimInt16 i = integer i <> primInt16Suffix +pprPrimInt32 i = integer i <> primInt32Suffix +pprPrimInt64 i = integer i <> primInt64Suffix +pprPrimWord8 w = word w <> primWord8Suffix +pprPrimWord16 w = word w <> primWord16Suffix +pprPrimWord32 w = word w <> primWord32Suffix +pprPrimWord64 w = word w <> primWord64Suffix + +--------------------- +-- Put a name in parens if it's an operator +pprPrefixVar :: Bool -> SDoc -> SDoc +pprPrefixVar is_operator pp_v + | is_operator = parens pp_v + | otherwise = pp_v + +-- Put a name in backquotes if it's not an operator +pprInfixVar :: Bool -> SDoc -> SDoc +pprInfixVar is_operator pp_v + | is_operator = pp_v + | otherwise = char '`' <> pp_v <> char '`' + +--------------------- +pprFastFilePath :: FastString -> SDoc +pprFastFilePath path = text $ normalise $ unpackFS path + +-- | Normalise, escape and render a string representing a path +-- +-- e.g. "c:\\whatever" +pprFilePathString :: IsLine doc => FilePath -> doc +pprFilePathString path = doubleQuotes $ text (escape (normalise path)) + where + escape [] = [] + escape ('\\':xs) = '\\':'\\':escape xs + escape (x:xs) = x:escape xs +{-# SPECIALIZE pprFilePathString :: FilePath -> SDoc #-} +{-# SPECIALIZE pprFilePathString :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc] + +{- +************************************************************************ +* * +\subsection{Other helper functions} +* * +************************************************************************ +-} + +pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- comma-separated and finally packed into a paragraph. +pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) + +pprWithSemis :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- semicolon-separated and finally packed into a paragraph. +pprWithSemis pp xs = fsep (punctuate semi (map pp xs)) + +pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- bar-separated and finally packed into a paragraph. +pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) + +-- Prefix the document with a space if it starts with a single quote. +-- See Note [Printing promoted type constructors] in GHC.Iface.Type +spaceIfSingleQuote :: SDoc -> SDoc +spaceIfSingleQuote (SDoc m) = + SDoc $ \ctx -> + let (mHead, d) = Pretty.docHead (m ctx) + in if mHead == Just '\'' + then Pretty.space Pretty.<> d + else d + +-- | Returns the separated concatenation of the pretty printed things. +interppSP :: Outputable a => [a] -> SDoc +interppSP xs = sep (map ppr xs) + +-- | Returns the comma-separated concatenation of the pretty printed things. +interpp'SP :: Outputable a => [a] -> SDoc +interpp'SP xs = interpp'SP' ppr xs + +interpp'SP' :: (a -> SDoc) -> [a] -> SDoc +interpp'SP' f xs = sep (punctuate comma (map f xs)) + +-- | Returns the comma-separated concatenation of the quoted pretty printed things. +-- +-- > [x,y,z] ==> `x', `y', `z' +pprQuotedList :: Outputable a => [a] -> SDoc +pprQuotedList = quotedList . map ppr + + +pprUnquotedSet :: Outputable a => Set.Set a -> SDoc +pprUnquotedSet set = + case Set.toList set of + [] -> braces empty + [x] -> ppr x + xs -> braces (fsep (punctuate comma (map ppr xs))) + + +quotedList :: [SDoc] -> SDoc +quotedList xs = fsep (punctuate comma (map quotes xs)) + +quotedListWithOr :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' or `z' +quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs) +quotedListWithOr xs = quotedList xs + +quotedListWithNor :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' nor `z' +quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) +quotedListWithNor xs = quotedList xs + +quotedListWithAnd :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' and `z' +quotedListWithAnd xs@(_:_:_) = quotedList (init xs) <+> text "and" <+> quotes (last xs) +quotedListWithAnd xs = quotedList xs + + +unquotedListWith :: SDoc -> [SDoc] -> SDoc +-- "whatever" [x,y,z] ==> x, y whatever z +unquotedListWith d xs + | Just (fs@(_:_), l) <- snocView xs = unquotedList fs <+> d <+> l + | otherwise = unquotedList xs + where + unquotedList = fsep . punctuate comma + +{- +************************************************************************ +* * +\subsection{Printing numbers verbally} +* * +************************************************************************ +-} + +intWithCommas :: Integral a => a -> SDoc +-- Prints a big integer with commas, eg 345,821 +intWithCommas n + | n < 0 = char '-' <> intWithCommas (-n) + | q == 0 = int (fromIntegral r) + | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r) + where + (q,r) = n `quotRem` 1000 + zeroes | r >= 100 = empty + | r >= 10 = char '0' + | otherwise = text "00" + +-- | Converts an integer to a verbal index: +-- +-- > speakNth 1 = text "first" +-- > speakNth 5 = text "fifth" +-- > speakNth 21 = text "21st" +speakNth :: Int -> SDoc +speakNth 1 = text "first" +speakNth 2 = text "second" +speakNth 3 = text "third" +speakNth 4 = text "fourth" +speakNth 5 = text "fifth" +speakNth 6 = text "sixth" +speakNth n = hcat [ int n, text suffix ] + where + suffix | n <= 20 = "th" -- 11,12,13 are non-std + | last_dig == 1 = "st" + | last_dig == 2 = "nd" + | last_dig == 3 = "rd" + | otherwise = "th" + + last_dig = n `rem` 10 + +-- | Converts an integer to a verbal multiplicity: +-- +-- > speakN 0 = text "none" +-- > speakN 5 = text "five" +-- > speakN 10 = text "10" +speakN :: Int -> SDoc +speakN 0 = text "none" -- E.g. "they have none" +speakN 1 = text "one" -- E.g. "they have one" +speakN 2 = text "two" +speakN 3 = text "three" +speakN 4 = text "four" +speakN 5 = text "five" +speakN 6 = text "six" +speakN n = int n + +-- | Converts an integer and object description to a statement about the +-- multiplicity of those objects: +-- +-- > speakNOf 0 (text "melon") = text "no melons" +-- > speakNOf 1 (text "melon") = text "one melon" +-- > speakNOf 3 (text "melon") = text "three melons" +speakNOf :: Int -> SDoc -> SDoc +speakNOf 0 d = text "no" <+> d <> char 's' +speakNOf 1 d = text "one" <+> d -- E.g. "one argument" +speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" + +-- | Determines the pluralisation suffix appropriate for the length of a list: +-- +-- > plural [] = char 's' +-- > plural ["Hello"] = empty +-- > plural ["Hello", "World"] = char 's' +plural :: [a] -> SDoc +plural [_] = empty -- a bit frightening, but there you are +plural _ = char 's' + +-- | Like 'plural', but for sets. +pluralSet :: Set.Set a -> SDoc +pluralSet set = plural (Set.toList set) + +-- | Determines the singular verb suffix appropriate for the length of a list: +-- +-- > singular [] = empty +-- > singular["Hello"] = char 's' +-- > singular ["Hello", "World"] = empty +singular :: [a] -> SDoc +singular [_] = char 's' +singular _ = empty + +-- | Determines the form of to be appropriate for the length of a list: +-- +-- > isOrAre [] = text "are" +-- > isOrAre ["Hello"] = text "is" +-- > isOrAre ["Hello", "World"] = text "are" +isOrAre :: [a] -> SDoc +isOrAre [_] = text "is" +isOrAre _ = text "are" + +-- | Determines the form of to do appropriate for the length of a list: +-- +-- > doOrDoes [] = text "do" +-- > doOrDoes ["Hello"] = text "does" +-- > doOrDoes ["Hello", "World"] = text "do" +doOrDoes :: [a] -> SDoc +doOrDoes [_] = text "does" +doOrDoes _ = text "do" + +-- | Determines the form of possessive appropriate for the length of a list: +-- +-- > itsOrTheir [x] = text "its" +-- > itsOrTheir [x,y] = text "their" +-- > itsOrTheir [] = text "their" -- probably avoid this +itsOrTheir :: [a] -> SDoc +itsOrTheir [_] = text "its" +itsOrTheir _ = text "their" + +-- | 'it' or 'they', depeneding on the length of the list. +-- +-- > itOrThey [x] = text "it" +-- > itOrThey [x,y] = text "they" +-- > itOrThey [] = text "they" -- probably avoid this +itOrThey :: [a] -> SDoc +itOrThey [_] = text "it" +itOrThey _ = text "they" + + +-- | Determines the form of subject appropriate for the length of a list: +-- +-- > thisOrThese [x] = text "This" +-- > thisOrThese [x,y] = text "These" +-- > thisOrThese [] = text "These" -- probably avoid this +thisOrThese :: [a] -> SDoc +thisOrThese [_] = text "This" +thisOrThese _ = text "These" + +-- | @"has"@ or @"have"@ depending on the length of a list. +hasOrHave :: [a] -> SDoc +hasOrHave [_] = text "has" +hasOrHave _ = text "have" + +{- Note [SDoc versus HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The SDoc type is used pervasively throughout the compiler to represent pretty- +printable output. Almost all text written by GHC, from the Haskell types and +expressions included in error messages to debug dumps, is assembled using SDoc. +SDoc is nice because it handles multiline layout in a semi-automatic fashion, +enabling printed expressions to wrap to fit a given line width while correctly +indenting the following lines to preserve alignment. + +SDoc’s niceties necessarily have some performance cost, but this is normally +okay, as printing output is rarely a performance bottleneck. However, one +notable exception to this is code generation: GHC must sometimes write +megabytes’ worth of generated assembly when compiling a single module, in which +case the overhead of SDoc has a significant cost (see #21853 for some numbers). +Moreover, generated assembly does not have the complex layout requirements of +pretty-printed Haskell code, so using SDoc does not buy us much, anyway. + +Nevertheless, we do still want to be able to share some logic between writing +assembly and pretty-printing. For example, the logic for printing basic block +labels (GHC.Cmm.CLabel.pprCLabel) is nontrivial, so we want to have a single +implementation that can be used both when generating code and when generating +Cmm dumps. This is where HDoc comes in: HDoc provides a subset of the SDoc +interface, but it is implemented in a far more efficient way, writing directly +to a `Handle` (via a `BufHandle`) without building any intermediate structures. +We can then use typeclasses to parameterize functions like `pprCLabel` over the +printing implementation. + +One might imagine this would result in one IsDoc typeclass, and two instances, +one for SDoc and one for HDoc. However, in fact, we need two *variants* of HDoc, +as described in Note [HLine versus HDoc], and this gives rise to a small +typeclass hierarchy consisting of IsOutput, IsLine, and IsDoc; +see Note [The outputable class hierarchy] for details. + +Note [HLine versus HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [SDoc versus HDoc], HDoc does not support any of the layout +niceties of SDoc for efficiency. However, this presents a small problem if we +want to be compatible with the SDoc API, as expressions like + + text "foo" <+> (text "bar" $$ text "baz") + +are expected to produce + + foo bar + baz + +which requires tracking line widths to know how far to indent the second line. +We can’t throw out vertical composition altogether, as we need to be able to +construct multiline HDocs, but we *can* restrict vertical composition to +concatenating whole lines at a time, as this is all that is necessary to +generate assembly in the code generator. + +To implement this restriction, we provide two distinct types: HLine and HDoc. +As their names suggests, an HLine represents a single line of output, while an +HDoc represents a multiline document. Atoms formed from `char` and `text` begin +their lives as HLines, which can be horizontally (but not vertically) composed: + + char :: Char -> HLine + text :: String -> HLine + (<+>) :: HLine -> HLine -> HLine + +Once a line has been fully assembled, it can be “locked up” into a single-line +HDoc via `line`, and HDocs can be vertically (but not horizontally) composed: + + line :: HLine -> HDoc + ($$) :: HLine -> HLine -> HLine + +Note that, at runtime, HLine and HDoc use exactly the same representation. This +distinction only exists in the type system to rule out the cases we don’t want +to have to handle. + +Note [The outputable class hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [SDoc versus HDoc], we want to be able to parameterize over +the choice of printing implementation when implementing common bits of printing +logic. However, as described in Note [HLine versus HDoc], we also want to +distinguish code that does single-line printing from code that does multi-line +printing. Therefore, code that is parameterized over the choice of printer must +respect this single- versus multi-line distinction. This naturally leads to two +typeclasses: + + class IsLine doc where + char :: Char -> doc + text :: String -> doc + (<>) :: doc -> doc -> doc + ... + + class IsLine (Line doc) => IsDoc doc where + type Line doc = r | r -> doc + line :: Line doc -> doc + ($$) :: doc -> doc -> doc + ... + +These classes support the following instances: + + instance IsLine SDoc + instance IsLine SDoc where + type Line SDoc = SDoc + + instance IsLine HLine + instance IsDoc HDoc where + type Line HDoc = HLine + +However, we run into a new problem: we provide many useful combinators on docs +that don’t care at all about the single-/multi-line distinction. For example, +ppWhen and ppUnless provide conditional logic, and docWithContext provides +access to the ambient SDocContext. Given the above classes, we would need two +variants of each of these combinators: + + ppWhenL :: IsLine doc => Bool -> doc -> doc + ppWhenL c d = if c then d else emptyL + + ppWhenD :: IsDoc doc => Bool -> doc -> doc + ppWhenD c d = if c then d else emptyD + +This is a needlessly annoying distinction, so we introduce a common superclass, +IsOutput, that allows these combinators to be generic over both variants: + + class IsOutput doc where + empty :: doc + docWithContext :: (SDocContext -> doc) -> doc + docWithStyle :: doc -> (PprStyle -> SDoc) -> doc + + class IsOutput doc => IsLine doc + class (IsOutput doc, IsLine (Line doc)) => IsDoc doc + +In practice, IsOutput isn’t used explicitly very often, but it makes code that +uses the combinators derived from it significantly less noisy. + +Note [SPECIALIZE to HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The IsLine and IsDoc classes are useful to share printing logic between code +that uses SDoc and code that uses HDoc, but we must take some care when doing +so. Much HDoc’s efficiency comes from GHC’s ability to optimize code that uses +it to eliminate unnecessary indirection, but the HDoc primitives must be inlined +before these opportunities can be exposed. Therefore, we want to explicitly +request that GHC generate HDoc (or HLine) specializations of any polymorphic +printing functions used by the code generator. + +In code generators (CmmToAsm.{AArch64,PPC,X86}.Ppr) we add a specialize +pragma just to the entry point pprNatCmmDecl, to avoid cluttering +the entire module. Because specialization is transitive, this makes sure +that other functions in that module are specialized too. + +Note [dualLine and dualDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The IsLine and IsDoc classes provide the dualLine and dualDoc methods, +respectively, which have the following types: + + dualLine :: IsLine doc => SDoc -> HLine -> doc + dualDoc :: IsDoc doc => SDoc -> HDoc -> doc + +These are effectively a form of type-`case`, selecting between each of their two +arguments depending on the type they are instantiated at. They serve as a +“nuclear option” for code that is, for some reason or another, unreasonably +difficult to make completely equivalent under both printer implementations. + +These operations should generally be avoided, as they can result in surprising +changes in behavior when the printer implementation is changed. +Right now, they are used only when outputting debugging comments in +codegen, as it is difficult to adapt that code to use HLine and not necessary. + +Use these operations wisely. + +Note [docWithStyle] +~~~~~~~~~~~~~~~~~~~ +Sometimes when printing, we consult the printing style. This can be done +with 'docWithStyle c f'. This is similar to 'docWithContext (f . sdocStyle)', +but: +* For code style, 'docWithStyle c f' will return 'c'. +* For other styles, 'docWithStyle c f', will call 'f style', but expect + an SDoc rather than doc. This removes the need to write code polymorphic + in SDoc and HDoc, since the latter is used only for code style. +-} + +-- | Represents a single line of output that can be efficiently printed directly +-- to a 'System.IO.Handle' (actually a 'BufHandle'). +-- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details. +newtype HLine = HLine' { runHLine :: SDocContext -> BufHandle -> IO () } + +-- | Represents a (possibly empty) sequence of lines that can be efficiently +-- printed directly to a 'System.IO.Handle' (actually a 'BufHandle'). +-- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details. +newtype HDoc = HDoc' { runHDoc :: SDocContext -> BufHandle -> IO () } + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern HLine :: (SDocContext -> BufHandle -> IO ()) -> HLine +pattern HLine f <- HLine' f + where HLine f = HLine' (oneShot (\ctx -> oneShot (\h -> f ctx h))) +{-# COMPLETE HLine #-} + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern HDoc :: (SDocContext -> BufHandle -> IO ()) -> HDoc +pattern HDoc f <- HDoc' f + where HDoc f = HDoc' (oneShot (\ctx -> oneShot (\h -> f ctx h))) +{-# COMPLETE HDoc #-} + +bPutHDoc :: BufHandle -> SDocContext -> HDoc -> IO () +bPutHDoc h ctx (HDoc f) = assert (codeStyle (sdocStyle ctx)) (f ctx h) + +-- | A superclass for 'IsLine' and 'IsDoc' that provides an identity, 'empty', +-- as well as access to the shared 'SDocContext'. +-- +-- See Note [The outputable class hierarchy] for more details. +class IsOutput doc where + empty :: doc + docWithContext :: (SDocContext -> doc) -> doc + docWithStyle :: doc -> (PprStyle -> SDoc) -> doc -- see Note [docWithStyle] + +-- | A class of types that represent a single logical line of text, with support +-- for horizontal composition. +-- +-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for +-- more details. +class IsOutput doc => IsLine doc where + char :: Char -> doc + text :: String -> doc + ftext :: FastString -> doc + ztext :: FastZString -> doc + + -- | Join two @doc@s together horizontally without a gap. + (<>) :: doc -> doc -> doc + -- | Join two @doc@s together horizontally with a gap between them. + (<+>) :: doc -> doc -> doc + -- | Separate: is either like 'hsep' or like 'vcat', depending on what fits. + sep :: [doc] -> doc + -- | A paragraph-fill combinator. It's much like 'sep', only it keeps fitting + -- things on one line until it can't fit any more. + fsep :: [doc] -> doc + + -- | Concatenate @doc@s horizontally without gaps. + hcat :: [doc] -> doc + hcat docs = foldr (<>) empty docs + {-# INLINE CONLIKE hcat #-} + + -- | Concatenate @doc@s horizontally with a space between each one. + hsep :: [doc] -> doc + hsep docs = foldr (<+>) empty docs + {-# INLINE CONLIKE hsep #-} + + -- | Prints as either the given 'SDoc' or the given 'HLine', depending on + -- which type the result is instantiated to. This should generally be avoided; + -- see Note [dualLine and dualDoc] for details. + dualLine :: SDoc -> HLine -> doc + + +-- | A class of types that represent a multiline document, with support for +-- vertical composition. +-- +-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for +-- more details. +class (IsOutput doc, IsLine (Line doc)) => IsDoc doc where + type Line doc = r | r -> doc + line :: Line doc -> doc + + -- | Join two @doc@s together vertically. If there is no vertical overlap it + -- "dovetails" the two onto one line. + ($$) :: doc -> doc -> doc + + lines_ :: [Line doc] -> doc + lines_ = vcat . map line + {-# INLINE CONLIKE lines_ #-} + + -- | Concatenate @doc@s vertically with dovetailing. + vcat :: [doc] -> doc + vcat ls = foldr ($$) empty ls + {-# INLINE CONLIKE vcat #-} + + -- | Prints as either the given 'SDoc' or the given 'HDoc', depending on + -- which type the result is instantiated to. This should generally be avoided; + -- see Note [dualLine and dualDoc] for details. + dualDoc :: SDoc -> HDoc -> doc + +instance IsOutput SDoc where + empty = docToSDoc $ Pretty.empty + {-# INLINE CONLIKE empty #-} + docWithContext = sdocWithContext + {-# INLINE docWithContext #-} + docWithStyle c f = sdocWithContext (\ctx -> let sty = sdocStyle ctx + in if codeStyle sty then c + else f sty) + -- see Note [docWithStyle] + {-# INLINE CONLIKE docWithStyle #-} + +instance IsLine SDoc where + char c = docToSDoc $ Pretty.char c + {-# INLINE CONLIKE char #-} + text s = docToSDoc $ Pretty.text s + {-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire + ftext s = docToSDoc $ Pretty.ftext s + {-# INLINE CONLIKE ftext #-} + ztext s = docToSDoc $ Pretty.ztext s + {-# INLINE CONLIKE ztext #-} + (<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE (<>) #-} + (<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE (<+>) #-} + hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE hcat #-} + hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE hsep #-} + sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE sep #-} + fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE fsep #-} + dualLine s _ = s + {-# INLINE CONLIKE dualLine #-} + +instance IsDoc SDoc where + type Line SDoc = SDoc + line = id + {-# INLINE line #-} + lines_ = vcat + {-# INLINE lines_ #-} + + ($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE ($$) #-} + vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE vcat #-} + dualDoc s _ = s + {-# INLINE CONLIKE dualDoc #-} + +instance IsOutput HLine where + empty = HLine (\_ _ -> pure ()) + {-# INLINE empty #-} + docWithContext f = HLine $ \ctx h -> runHLine (f ctx) ctx h + {-# INLINE CONLIKE docWithContext #-} + docWithStyle c _ = c -- see Note [docWithStyle] + {-# INLINE CONLIKE docWithStyle #-} + +instance IsOutput HDoc where + empty = HDoc (\_ _ -> pure ()) + {-# INLINE empty #-} + docWithContext f = HDoc $ \ctx h -> runHDoc (f ctx) ctx h + {-# INLINE CONLIKE docWithContext #-} + docWithStyle c _ = c -- see Note [docWithStyle] + {-# INLINE CONLIKE docWithStyle #-} + +instance IsLine HLine where + char c = HLine (\_ h -> bPutChar h c) + {-# INLINE CONLIKE char #-} + text str = HLine (\_ h -> bPutStr h str) + {-# INLINE CONLIKE text #-} + ftext fstr = HLine (\_ h -> bPutFS h fstr) + {-# INLINE CONLIKE ftext #-} + ztext fstr = HLine (\_ h -> bPutFZS h fstr) + {-# INLINE CONLIKE ztext #-} + + HLine f <> HLine g = HLine (\ctx h -> f ctx h *> g ctx h) + {-# INLINE CONLIKE (<>) #-} + f <+> g = f <> char ' ' <> g + {-# INLINE CONLIKE (<+>) #-} + sep = hsep + {-# INLINE sep #-} + fsep = hsep + {-# INLINE fsep #-} + + dualLine _ h = h + {-# INLINE CONLIKE dualLine #-} + +instance IsDoc HDoc where + type Line HDoc = HLine + line (HLine f) = HDoc (\ctx h -> f ctx h *> bPutChar h '\n') + {-# INLINE CONLIKE line #-} + HDoc f $$ HDoc g = HDoc (\ctx h -> f ctx h *> g ctx h) + {-# INLINE CONLIKE ($$) #-} + dualDoc _ h = h + {-# INLINE CONLIKE dualDoc #-} diff --git a/GHC/Utils/Panic.hs b/GHC/Utils/Panic.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Panic.hs @@ -0,0 +1,340 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP Project, Glasgow University, 1992-2000 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables, LambdaCase #-} + +#include + +-- | Defines basic functions for printing error messages. +-- +-- It's hard to put these functions anywhere else without causing +-- some unnecessary loops in the module dependency graph. +module GHC.Utils.Panic + ( -- * GHC exception type + GhcException(..) + , showGhcException + , showGhcExceptionUnsafe + , throwGhcException + , throwGhcExceptionIO + , handleGhcException + + -- * Command error throwing patterns + , pprPanic + , panicDoc + , sorryDoc + , pgmErrorDoc + + -- ** Assertions + , assertPprPanic + , assertPpr + , assertPprMaybe + , assertPprM + , massertPpr + + -- * Call stacks + , callStackDoc + , prettyCallStackDoc + + -- * Exception utilities + , Exception.Exception(..) + , showException + , safeShowException + , try + , tryMost + , throwTo + , withSignalHandlers + , module GHC.Utils.Panic.Plain + ) +where + +import GHC.Prelude.Basic +import GHC.Stack + +import GHC.Utils.Outputable +import GHC.Utils.Panic.Plain +import GHC.Utils.Constants + +import GHC.Utils.Exception as Exception + +import Control.Monad.IO.Class +import qualified Control.Monad.Catch as MC +import Control.Concurrent +import Data.Typeable ( cast ) +import System.IO.Unsafe + +#if !defined(mingw32_HOST_OS) +import System.Posix.Signals as S +#endif + +#if defined(mingw32_HOST_OS) +import GHC.ConsoleHandler as S +#endif + +import System.Mem.Weak ( deRefWeak ) + +-- | GHC's own exception type +-- error messages all take the form: +-- +-- @ +-- \: \ +-- @ +-- +-- If the location is on the command line, or in GHC itself, then +-- \="ghc". All of the error types below correspond to +-- a \ of "ghc", except for ProgramError (where the string is +-- assumed to contain a location already, so we don't print one). + +data GhcException + -- | Some other fatal signal (SIGHUP,SIGTERM) + = Signal Int + + -- | Prints the short usage msg after the error + | UsageError String + + -- | A problem with the command line arguments, but don't print usage. + | CmdLineError String + + -- | The 'impossible' happened. + | Panic String + | PprPanic String SDoc + + -- | The user tickled something that's known not to work yet, + -- but we're not counting it as a bug. + | Sorry String + | PprSorry String SDoc + + -- | An installation problem. + | InstallationError String + + -- | An error in the user's code, probably. + | ProgramError String + | PprProgramError String SDoc + +instance Exception GhcException where + fromException (SomeException e) + | Just ge <- cast e = Just ge + | Just pge <- cast e = Just $ + case pge of + PlainSignal n -> Signal n + PlainUsageError str -> UsageError str + PlainCmdLineError str -> CmdLineError str + PlainPanic str -> Panic str + PlainSorry str -> Sorry str + PlainInstallationError str -> InstallationError str + PlainProgramError str -> ProgramError str + | otherwise = Nothing + + -- Explicitly omit ExceptionContext since we generally don't + -- want backtraces and other context in GHC's user errors. + displayException exc = showGhcExceptionUnsafe exc "" + +instance Show GhcException where + showsPrec _ e = showGhcExceptionUnsafe e + +-- | Show an exception as a string. +showException :: Exception e => e -> String +showException = show + +-- | Show an exception which can possibly throw other exceptions. +-- Used when displaying exception thrown within TH code. +safeShowException :: Exception e => e -> IO String +safeShowException e = do + -- ensure the whole error message is evaluated inside try + r <- try (return $! forceList (showException e)) + case r of + Right msg -> return msg + Left e' -> safeShowException (e' :: SomeException) + where + forceList [] = [] + forceList xs@(x : xt) = x `seq` forceList xt `seq` xs + +-- | Append a description of the given exception to this string. +-- +-- Note that this uses 'defaultSDocContext', which doesn't use the options +-- set by the user via DynFlags. +showGhcExceptionUnsafe :: GhcException -> ShowS +showGhcExceptionUnsafe = showGhcException defaultSDocContext + +-- | Append a description of the given exception to this string. +showGhcException :: SDocContext -> GhcException -> ShowS +showGhcException ctx = showPlainGhcException . \case + Signal n -> PlainSignal n + UsageError str -> PlainUsageError str + CmdLineError str -> PlainCmdLineError str + Panic str -> PlainPanic str + Sorry str -> PlainSorry str + InstallationError str -> PlainInstallationError str + ProgramError str -> PlainProgramError str + + PprPanic str sdoc -> PlainPanic $ + concat [str, "\n\n", renderWithContext ctx sdoc] + PprSorry str sdoc -> PlainProgramError $ + concat [str, "\n\n", renderWithContext ctx sdoc] + PprProgramError str sdoc -> PlainProgramError $ + concat [str, "\n\n", renderWithContext ctx sdoc] + +throwGhcException :: HasCallStack => GhcException -> a +throwGhcException = Exception.throw + +throwGhcExceptionIO :: GhcException -> IO a +throwGhcExceptionIO = Exception.throwIO + +handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a +handleGhcException = MC.handle + +-- | Throw an exception saying "bug in GHC" with a callstack +pprPanic :: HasCallStack => String -> SDoc -> a +pprPanic s doc = withFrozenCallStack $ panicDoc s (doc $$ callStackDoc) + +-- | Throw an exception saying "bug in GHC" +panicDoc :: HasCallStack => String -> SDoc -> a +panicDoc x doc = withFrozenCallStack $ throwGhcException (PprPanic x doc) + +-- | Throw an exception saying "this isn't finished yet" +sorryDoc :: String -> SDoc -> a +sorryDoc x doc = throwGhcException (PprSorry x doc) + +-- | Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) +pgmErrorDoc :: String -> SDoc -> a +pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) + +-- | Like try, but pass through UserInterrupt and Panic exceptions. +-- Used when we want soft failures when reading interface files, for example. +-- TODO: I'm not entirely sure if this is catching what we really want to catch +tryMost :: IO a -> IO (Either SomeException a) +tryMost action = do r <- try action + case r of + Left se -> + case fromException se of + -- Some GhcException's we rethrow, + Just (Signal _) -> throwIO se + Just (Panic _) -> throwIO se + -- others we return + Just _ -> return (Left se) + Nothing -> + case fromException se of + -- All IOExceptions are returned + Just (_ :: IOException) -> + return (Left se) + -- Anything else is rethrown + Nothing -> throwIO se + Right v -> return (Right v) + +-- | We use reference counting for signal handlers +{-# NOINLINE signalHandlersRefCount #-} +#if !defined(mingw32_HOST_OS) +signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler + ,S.Handler,S.Handler)) +#else +signalHandlersRefCount :: MVar (Word, Maybe S.Handler) +#endif +signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing) + + +-- | Temporarily install standard signal handlers for catching ^C, which just +-- throw an exception in the current thread. +withSignalHandlers :: ExceptionMonad m => m a -> m a +#if !defined(HAVE_SIGNAL_H) +-- No signal functionality exist on the host platform (e.g. on +-- wasm32-wasi), so don't attempt to set up signal handlers +withSignalHandlers = id +#else +withSignalHandlers act = do + main_thread <- liftIO myThreadId + wtid <- liftIO (mkWeakThreadId main_thread) + + let + interrupt = do + r <- deRefWeak wtid + case r of + Nothing -> return () + Just t -> throwTo t UserInterrupt + +#if !defined(mingw32_HOST_OS) + let installHandlers = do + let installHandler' a b = installHandler a b Nothing + hdlQUIT <- installHandler' sigQUIT (Catch interrupt) + hdlINT <- installHandler' sigINT (Catch interrupt) + -- see #3656; in the future we should install these automatically for + -- all Haskell programs in the same way that we install a ^C handler. + let fatal_signal n = throwTo main_thread (Signal (fromIntegral n)) + hdlHUP <- installHandler' sigHUP (Catch (fatal_signal sigHUP)) + hdlTERM <- installHandler' sigTERM (Catch (fatal_signal sigTERM)) + return (hdlQUIT,hdlINT,hdlHUP,hdlTERM) + + let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do + _ <- installHandler sigQUIT hdlQUIT Nothing + _ <- installHandler sigINT hdlINT Nothing + _ <- installHandler sigHUP hdlHUP Nothing + _ <- installHandler sigTERM hdlTERM Nothing + return () +#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 () + + let installHandlers = installHandler (Catch sig_handler) + let uninstallHandlers = installHandler -- directly install the old handler +#endif + + -- install signal handlers if necessary + let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case + (0,Nothing) -> do + hdls <- installHandlers + return (1,Just hdls) + (c,oldHandlers) -> return (c+1,oldHandlers) + + -- uninstall handlers if necessary + let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case + (1,Just hdls) -> do + _ <- uninstallHandlers hdls + return (0,Nothing) + (c,oldHandlers) -> return (c-1,oldHandlers) + + mayInstallHandlers + act `MC.finally` mayUninstallHandlers +#endif + +callStackDoc :: HasCallStack => SDoc +callStackDoc = prettyCallStackDoc callStack + +prettyCallStackDoc :: CallStack -> SDoc +prettyCallStackDoc cs = + hang (text "Call stack:") + 4 (vcat $ map text $ lines (prettyCallStack cs)) + +-- | Panic with an assertion failure, recording the given file and +-- line number. Should typically be accessed with the ASSERT family of macros +assertPprPanic :: HasCallStack => SDoc -> a +assertPprPanic msg = withFrozenCallStack (pprPanic "ASSERT failed!" msg) + + +assertPpr :: HasCallStack => Bool -> SDoc -> a -> a +{-# INLINE assertPpr #-} +assertPpr cond msg a = + if debugIsOn && not cond + then withFrozenCallStack (assertPprPanic msg) + else a + +assertPprMaybe :: HasCallStack => Maybe SDoc -> a -> a +{-# INLINE assertPprMaybe #-} +assertPprMaybe mb_msg a + | debugIsOn, Just msg <- mb_msg = withFrozenCallStack (assertPprPanic msg) + | otherwise = a + +massertPpr :: (HasCallStack, Applicative m) => Bool -> SDoc -> m () +{-# INLINE massertPpr #-} +massertPpr cond msg = withFrozenCallStack (assertPpr cond msg (pure ())) + +assertPprM :: (HasCallStack, Monad m) => m Bool -> SDoc -> m () +{-# INLINE assertPprM #-} +assertPprM mcond msg = withFrozenCallStack (mcond >>= \cond -> massertPpr cond msg) diff --git a/GHC/Utils/Panic/Plain.hs b/GHC/Utils/Panic/Plain.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Panic/Plain.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE ScopedTypeVariables, LambdaCase #-} + +-- | Defines a simple exception type and utilities to throw it. The +-- 'PlainGhcException' type is a subset of the 'GHC.Utils.Panic.GhcException' +-- type. It omits the exception constructors that involve +-- pretty-printing via 'GHC.Utils.Outputable.SDoc'. +-- +-- The reason for this is to avoid import cycles / use of boot files. +-- "GHC.Utils.Outputable" has many transitive dependencies. +-- To throw exceptions from these modules, the functions here can be used +-- without introducing import cycles. +module GHC.Utils.Panic.Plain + ( PlainGhcException(..) + , showPlainGhcException + + , panic, sorry, pgmError + , cmdLineError, cmdLineErrorIO + , assertPanic + , assert, assertM, massert + ) where + +import GHC.Settings.Config +import GHC.Utils.Constants +import GHC.Utils.Exception as Exception +import GHC.Stack +import GHC.Prelude.Basic + +import Control.Monad (when) +import System.IO.Unsafe + +-- | This type is very similar to 'GHC.Utils.Panic.GhcException', but it omits +-- the constructors that involve pretty-printing via +-- 'GHC.Utils.Outputable.SDoc'. Due to the implementation of 'fromException' +-- for 'GHC.Utils.Panic.GhcException', this type can be caught as a +-- 'GHC.Utils.Panic.GhcException'. +-- +-- Note that this should only be used for throwing exceptions, not for +-- catching, as 'GHC.Utils.Panic.GhcException' will not be converted to this +-- type when catching. +data PlainGhcException + -- | Some other fatal signal (SIGHUP,SIGTERM) + = PlainSignal Int + + -- | Prints the short usage msg after the error + | PlainUsageError String + + -- | A problem with the command line arguments, but don't print usage. + | PlainCmdLineError String + + -- | The 'impossible' happened. + | PlainPanic String + + -- | The user tickled something that's known not to work yet, + -- but we're not counting it as a bug. + | PlainSorry String + + -- | An installation problem. + | PlainInstallationError String + + -- | An error in the user's code, probably. + | PlainProgramError String + +instance Exception PlainGhcException + +instance Show PlainGhcException where + showsPrec _ e = showPlainGhcException e + +-- | Short usage information to display when we are given the wrong cmd line arguments. +short_usage :: String +short_usage = "Usage: For basic information, try the `--help' option." + +-- | Append a description of the given exception to this string. +showPlainGhcException :: PlainGhcException -> ShowS +showPlainGhcException = + \case + PlainSignal n -> showString "signal: " . shows n + PlainUsageError str -> showString str . showChar '\n' . showString short_usage + PlainCmdLineError str -> showString str + PlainPanic s -> panicMsg (showString s) + PlainSorry s -> sorryMsg (showString s) + PlainInstallationError str -> showString str + PlainProgramError str -> showString str + where + sorryMsg :: ShowS -> ShowS + sorryMsg s = + showString "sorry! (unimplemented feature or known bug)\n" + . showString (" GHC version " ++ cProjectVersion ++ ":\n\t") + . s . showString "\n" + + panicMsg :: ShowS -> ShowS + panicMsg s = + showString "panic! (the 'impossible' happened)\n" + . showString (" GHC version " ++ cProjectVersion ++ ":\n\t") + . s . showString "\n\n" + . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n" + +throwPlainGhcException :: PlainGhcException -> a +throwPlainGhcException = Exception.throw + +-- | Panics and asserts. +panic, sorry, pgmError :: HasCallStack => String -> a +panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic x) + +sorry x = throwPlainGhcException (PlainSorry x) +pgmError x = throwPlainGhcException (PlainProgramError x) + +cmdLineError :: String -> a +cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO + +cmdLineErrorIO :: String -> IO a +cmdLineErrorIO x = throwPlainGhcException (PlainCmdLineError x) + +-- | Throw a failed assertion exception for a given filename and line number. +assertPanic :: String -> Int -> a +assertPanic file line = + Exception.throw (Exception.AssertionFailed + ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) + +-- | Throw a failed assertion exception taking the location information +-- from 'HasCallStack' evidence. +assertPanic' :: HasCallStack => a +assertPanic' = + Exception.throw + $ Exception.AssertionFailed + $ "ASSERT failed!\n" ++ withFrozenCallStack doc + where + -- TODO: Drop CallStack when exception backtrace functionality + -- can be assumed of bootstrap compiler. + doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack) + +assert :: HasCallStack => Bool -> a -> a +{-# INLINE assert #-} +assert cond a = + if debugIsOn && not cond + then withFrozenCallStack assertPanic' + else a + +massert :: (HasCallStack, Applicative m) => Bool -> m () +{-# INLINE massert #-} +massert cond = withFrozenCallStack (assert cond (pure ())) + +assertM :: (HasCallStack, Monad m) => m Bool -> m () +{-# INLINE assertM #-} +assertM mcond + | debugIsOn = withFrozenCallStack $ do + res <- mcond + when (not res) assertPanic' + | otherwise = return () diff --git a/GHC/Utils/Ppr.hs b/GHC/Utils/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Ppr.hs @@ -0,0 +1,1191 @@ +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Utils.Ppr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : David Terei +-- Stability : stable +-- Portability : portable +-- +-- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators +-- +-- Based on /The Design of a Pretty-printing Library/ +-- in Advanced Functional Programming, +-- Johan Jeuring and Erik Meijer (eds), LNCS 925 +-- +-- +----------------------------------------------------------------------------- + +{- +Note [Differences between libraries/pretty and compiler/GHC/Utils/Ppr.hs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For historical reasons, there are two different copies of `Pretty` in the GHC +source tree: + * `libraries/pretty` is a submodule containing + https://github.com/haskell/pretty. This is the `pretty` library as released + on hackage. It is used by several other libraries in the GHC source tree + (e.g. template-haskell and Cabal). + * `compiler/GHC/Utils/Ppr.hs` (this module). It is used by GHC only. + +There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and +https://gitlab.haskell.org/ghc/ghc/issues/10735 to try to get rid of GHC's copy +of Pretty. + +Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following +major differences: + * GHC's copy uses `Faststring` for performance reasons. + * GHC's copy has received a backported bugfix for #12227, which was + released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside", + https://github.com/haskell/pretty/pull/35). + +Other differences are minor. Both copies define some extra functions and +instances not defined in the other copy. To see all differences, do this in a +ghc git tree: + + $ cd libraries/pretty + $ git checkout v1.1.2.0 + $ cd - + $ vimdiff compiler/GHC/Utils/Ppr.hs \ + libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs + +For parity with `pretty-1.1.2.1`, the following two `pretty` commits would +have to be backported: + * "Resolve foldr-strictness stack overflow bug" + (307b8173f41cd776eae8f547267df6d72bff2d68) + * "Special-case reduce for horiz/vert" + (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c) +This has not been done sofar, because these commits seem to cause more +allocation in the compiler (see thomie's comments in +https://github.com/haskell/pretty/pull/9). +-} + +module GHC.Utils.Ppr ( + + -- * The document type + Doc, TextDetails(..), + + -- * Constructing documents + + -- ** Converting values into documents + char, text, ftext, ptext, ztext, sizedText, zeroWidthText, emptyText, + int, integer, float, double, rational, hex, + + -- ** Simple derived documents + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + -- ** Wrapping documents in delimiters + parens, brackets, braces, quotes, squotes, quote, doubleQuotes, + maybeParens, + + -- ** Combining documents + empty, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + nest, + hang, hangNotEmpty, punctuate, + + -- * Predicates on documents + isEmpty, + docHead, + + -- * Rendering documents + + -- ** Rendering with a particular style + Style(..), + style, + renderStyle, + Mode(..), + + -- ** General rendering + fullRender, txtPrinter, + + -- ** GHC-specific rendering + printDoc, printDoc_, + bufLeftRender, printLeftRender -- performance hack + + ) where + +import GHC.Prelude.Basic hiding (error) +import Control.Applicative ((<|>)) + +import GHC.Utils.BufHandle +import GHC.Data.FastString +import GHC.Utils.Panic.Plain +import System.IO +import Numeric (showHex) + +--for a RULES +import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) ) +import GHC.Ptr ( Ptr(..) ) + +-- --------------------------------------------------------------------------- +-- The Doc calculus + +{- +Laws for $$ +~~~~~~~~~~~ + (x $$ y) $$ z = x $$ (y $$ z) + empty $$ x = x + x $$ empty = x + + ...ditto $+$... + +Laws for <> +~~~~~~~~~~~ + (x <> y) <> z = x <> (y <> z) + empty <> x = empty + x <> empty = x + + ...ditto <+>... + +Laws for text +~~~~~~~~~~~~~ + text s <> text t = text (s++t) + text "" <> x = x, if x non-empty + +** because of law n6, t2 only holds if x doesn't +** start with `nest'. + + +Laws for nest +~~~~~~~~~~~~~ + nest 0 x = x + nest k (nest k' x) = nest (k+k') x + nest k (x <> y) = nest k x <> nest k y + nest k (x $$ y) = nest k x $$ nest k y + nest k empty = empty + x <> nest k y = x <> y, if x non-empty + +** Note the side condition on ! It is this that +** makes it OK for empty to be a left unit for <>. + +Miscellaneous +~~~~~~~~~~~~~ + (text s <> x) $$ y = text s <> ((text "" <> x) $$ + nest (-length s) y) + + (x $$ y) <> z = x $$ (y <> z) + if y non-empty + + +Laws for list versions +~~~~~~~~~~~~~~~~~~~~~~ + sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... + + nest k (sep ps) = sep (map (nest k) ps) + ...ditto hsep, hcat, vcat, fill... + +Laws for oneLiner +~~~~~~~~~~~~~~~~~ + oneLiner (nest k p) = nest k (oneLiner p) + oneLiner (x <> y) = oneLiner x <> oneLiner y + +You might think that the following version of would +be neater: + +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ + nest (-length s) y) + +But it doesn't work, for if x=empty, we would have + + text s $$ y = text s <> (empty $$ nest (-length s) y) + = text s <> nest (-length s) y +-} + +-- --------------------------------------------------------------------------- +-- Operator fixity + +infixl 6 <> +infixl 6 <+> +infixl 5 $$, $+$ + + +-- --------------------------------------------------------------------------- +-- The Doc data type + +-- | The abstract type of documents. +-- A Doc represents a *set* of layouts. A Doc with +-- no occurrences of Union or NoDoc represents just one layout. +data Doc + = Empty -- empty + | NilAbove Doc -- text "" $$ x + | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x + | Nest {-# UNPACK #-} !Int Doc -- nest k x + | Union Doc Doc -- ul `union` ur + | NoDoc -- The empty set of documents + | Beside Doc Bool Doc -- True <=> space between + | Above Doc Bool Doc -- True <=> never overlap + +{- +Here are the invariants: + +1) The argument of NilAbove is never Empty. Therefore + a NilAbove occupies at least two lines. + +2) The argument of @TextBeside@ is never @Nest@. + +3) The layouts of the two arguments of @Union@ both flatten to the same + string. + +4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. + +5) A @NoDoc@ may only appear on the first line of the left argument of an + union. Therefore, the right argument of an union can never be equivalent + to the empty set (@NoDoc@). + +6) An empty document is always represented by @Empty@. It can't be + hidden inside a @Nest@, or a @Union@ of two @Empty@s. + +7) The first line of every layout in the left argument of @Union@ is + longer than the first line of any layout in the right argument. + (1) ensures that the left argument has a first line. In view of + (3), this invariant means that the right argument must have at + least two lines. + +Notice the difference between + * NoDoc (no documents) + * Empty (one empty document; no height and no width) + * text "" (a document containing the empty string; + one line high, but has no width) +-} + + +-- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. +type RDoc = Doc + +-- | The TextDetails data type +-- +-- A TextDetails represents a fragment of text that will be +-- output at some point. +data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment + | Str String -- ^ A whole String fragment + | PStr FastString -- a hashed string + | ZStr FastZString -- a z-encoded string + | LStr {-# UNPACK #-} !PtrString + -- a '\0'-terminated array of bytes + | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char + -- a repeated character (e.g., ' ') + +instance Show Doc where + showsPrec _ doc cont = fullRender (mode style) (lineLength style) + (ribbonsPerLine style) + txtPrinter cont doc + + +-- --------------------------------------------------------------------------- +-- Values and Predicates on GDocs and TextDetails + +-- | A document of height and width 1, containing a literal character. +char :: Char -> Doc +char c = textBeside_ (Chr c) 1 Empty + +-- | A document of height 1 containing a literal string. +-- 'text' satisfies the following laws: +-- +-- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ +-- +-- * @'text' \"\" '<>' x = x@, if @x@ non-empty +-- +-- The side condition on the last law is necessary because @'text' \"\"@ +-- has height 1, while 'empty' has no height. +text :: String -> Doc +text s = textBeside_ (Str s) (length s) Empty +{-# NOINLINE [0] text #-} -- Give the RULE a chance to fire + -- It must wait till after phase 1 when + -- the unpackCString first is manifested + +-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the +-- intermediate packing/unpacking of the string. +{-# RULES "text/str" + forall a. text (unpackCString# a) = ptext (mkPtrString# a) + #-} +{-# RULES "text/unpackNBytes#" + forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n)) + #-} + +-- Empty strings are desugared into [] (not "unpackCString#..."), hence they are +-- not matched by the text/str rule above. +{-# RULES "text/[]" + text [] = emptyText + #-} + +ftext :: FastString -> Doc +ftext s = textBeside_ (PStr s) (lengthFS s) Empty + +ptext :: PtrString -> Doc +ptext s = textBeside_ (LStr s) (lengthPS s) Empty + +ztext :: FastZString -> Doc +ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty + +-- | Some text with any width. (@text s = sizedText (length s) s@) +sizedText :: Int -> String -> Doc +sizedText l s = textBeside_ (Str s) l Empty + +-- | Some text, but without any width. Use for non-printing text +-- such as a HTML or Latex tags +zeroWidthText :: String -> Doc +zeroWidthText = sizedText 0 + +-- | Empty text (one line high but no width). (@emptyText = text ""@) +emptyText :: Doc +emptyText = sizedText 0 [] + -- defined as a CAF. Sharing occurs especially via the text/[] rule above. + -- Every use of `text ""` in user code should be replaced with this. + +-- | The empty document, with no height and no width. +-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere +-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. +empty :: Doc +empty = Empty + +-- | Returns 'True' if the document is empty +isEmpty :: Doc -> Bool +isEmpty Empty = True +isEmpty _ = False + +-- | Get the first character of a document. We also return a new document, +-- equivalent to the original one but faster to render. Use it to avoid work +-- duplication. +docHead :: Doc -> (Maybe Char, Doc) +docHead d = (headChar, rdoc) + where + rdoc = reduceDoc d + headChar = go rdoc + + go :: RDoc -> Maybe Char + go (Union p q) = go (first p q) + go (Nest _ p) = go p + go Empty = Nothing + go (NilAbove _) = Just '\n' + go (TextBeside td _ p) = go_td td <|> go p + go NoDoc = error "docHead: NoDoc" + go (Above {}) = error "docHead: Above" + go (Beside {}) = error "docHead: Beside" + + go_td :: TextDetails -> Maybe Char + go_td (Chr c) = Just c + go_td (Str s) = go_str s + go_td (PStr s) = go_str (unpackFS s) -- O(1) because unpackFS is lazy + go_td (ZStr s) = go_str (zStringTakeN 1 s) + go_td (LStr s) = go_str (unpackPtrStringTakeN 1 s) + go_td (RStr n c) = if n > 0 then Just c else Nothing + + go_str :: String -> Maybe Char + go_str [] = Nothing + go_str (c:_) = Just c + +{- +Q: What is the reason for negative indentation (i.e. argument to indent + is < 0) ? + +A: +This indicates an error in the library client's code. +If we compose a <> b, and the first line of b is more indented than some +other lines of b, the law (<> eats nests) may cause the pretty +printer to produce an invalid layout: + +doc |0123345 +------------------ +d1 |a...| +d2 |...b| + |c...| + +d1<>d2 |ab..| + c|....| + +Consider a <> b, let `s' be the length of the last line of `a', `k' the +indentation of the first line of b, and `k0' the indentation of the +left-most line b_i of b. + +The produced layout will have negative indentation if `k - k0 > s', as +the first line of b will be put on the (s+1)th column, effectively +translating b horizontally by (k-s). Now if the i^th line of b has an +indentation k0 < (k-s), it is translated out-of-page, causing +`negative indentation'. +-} + + +semi :: Doc -- ^ A ';' character +comma :: Doc -- ^ A ',' character +colon :: Doc -- ^ A ':' character +space :: Doc -- ^ A space character +equals :: Doc -- ^ A '=' character +lparen :: Doc -- ^ A '(' character +rparen :: Doc -- ^ A ')' character +lbrack :: Doc -- ^ A '[' character +rbrack :: Doc -- ^ A ']' character +lbrace :: Doc -- ^ A '{' character +rbrace :: Doc -- ^ A '}' character +semi = char ';' +comma = char ',' +colon = char ':' +space = char ' ' +equals = char '=' +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' + +spaceText, nlText :: TextDetails +spaceText = Chr ' ' +nlText = Chr '\n' + +int :: Int -> Doc -- ^ @int n = text (show n)@ +integer :: Integer -> Doc -- ^ @integer n = text (show n)@ +float :: Float -> Doc -- ^ @float n = text (show n)@ +double :: Double -> Doc -- ^ @double n = text (show n)@ +rational :: Rational -> Doc -- ^ @rational n = text (show n)@ +hex :: Integer -> Doc -- ^ See Note [Print Hexadecimal Literals] +int n = text (show n) +integer n = text (show n) +float n = text (show n) +double n = text (show n) +rational n = text (show n) +hex n = text ('0' : 'x' : padded) + where + str = showHex n "" + strLen = max 1 (length str) + len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int) + padded = replicate (len - strLen) '0' ++ str + +parens :: Doc -> Doc -- ^ Wrap document in @(...)@ +brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ +braces :: Doc -> Doc -- ^ Wrap document in @{...}@ +quotes :: Doc -> Doc -- ^ Wrap document in @\`...\'@ +squotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ +quote :: Doc -> Doc +doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ +quotes p = char '`' <> p <> char '\'' +squotes p = char '\'' <> p <> char '\'' +quote p = char '\'' <> p +doubleQuotes p = char '"' <> p <> char '"' +parens p = char '(' <> p <> char ')' +brackets p = char '[' <> p <> char ']' +braces p = char '{' <> p <> char '}' + +{- +Note [Print Hexadecimal Literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Relevant discussions: + * Phabricator: https://phabricator.haskell.org/D4465 + * GHC Trac: https://gitlab.haskell.org/ghc/ghc/issues/14872 + +There is a flag `-dhex-word-literals` that causes literals of +type `Word#` or `Word64#` to be displayed in hexadecimal instead +of decimal when dumping GHC core. It also affects the presentation +of these in GHC's error messages. Additionally, the hexadecimal +encoding of these numbers is zero-padded so that its length is +a power of two. As an example of what this does, +consider the following haskell file `Literals.hs`: + + module Literals where + + alpha :: Int + alpha = 100 + 200 + + beta :: Word -> Word + beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202 + +We get the following dumped core when we compile on a 64-bit +machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all +-dhex-word-literals literals.hs: + + ==================== Tidy Core ==================== + + ... omitted for brevity ... + + -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} + alpha + alpha = I# 300# + + -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0} + beta + beta + = \ x_aYE -> + case x_aYE of { W# x#_a1v0 -> + W# + (plusWord# + (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##) + 0x0202##) + } + +Notice that the word literals are in hexadecimals and that they have +been padded with zeroes so that their lengths are 16, 8, and 4, respectively. + +-} + +-- | Apply 'parens' to 'Doc' if boolean is true. +maybeParens :: Bool -> Doc -> Doc +maybeParens False = id +maybeParens True = parens + +-- --------------------------------------------------------------------------- +-- Structural operations on GDocs + +-- | Perform some simplification of a built up @GDoc@. +reduceDoc :: Doc -> RDoc +reduceDoc (Beside p g q) = p `seq` g `seq` (beside p g $! reduceDoc q) +reduceDoc (Above p g q) = p `seq` g `seq` (above p g $! reduceDoc q) +reduceDoc p = p + +-- | List version of '<>'. +hcat :: [Doc] -> Doc +hcat = reduceAB . foldr (beside_' False) empty + +-- | List version of '<+>'. +hsep :: [Doc] -> Doc +hsep = reduceAB . foldr (beside_' True) empty + +-- | List version of '$$'. +vcat :: [Doc] -> Doc +vcat = reduceAB . foldr (above_' False) empty + +-- | Nest (or indent) a document by a given number of positions +-- (which may also be negative). 'nest' satisfies the laws: +-- +-- * @'nest' 0 x = x@ +-- +-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ +-- +-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ +-- +-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ +-- +-- * @'nest' k 'empty' = 'empty'@ +-- +-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty +-- +-- The side condition on the last law is needed because +-- 'empty' is a left identity for '<>'. +nest :: Int -> Doc -> Doc +nest k p = mkNest k (reduceDoc p) + +-- | @hang d1 n d2 = sep [d1, nest n d2]@ +hang :: Doc -> Int -> Doc -> Doc +hang d1 n d2 = sep [d1, nest n d2] + +-- | Apply 'hang' to the arguments if the first 'Doc' is not empty. +hangNotEmpty :: Doc -> Int -> Doc -> Doc +hangNotEmpty d1 n d2 = if isEmpty d1 + then d2 + else hang d1 n d2 + +-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ +punctuate :: Doc -> [Doc] -> [Doc] +punctuate _ [] = [] +punctuate p (x:xs) = go x xs + where go y [] = [y] + go y (z:zs) = (y <> p) : go z zs + +-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it +mkNest :: Int -> Doc -> Doc +mkNest k _ | k `seq` False = undefined +mkNest k (Nest k1 p) = mkNest (k + k1) p +mkNest _ NoDoc = NoDoc +mkNest _ Empty = Empty +mkNest 0 p = p +mkNest k p = nest_ k p + +-- mkUnion checks for an empty document +mkUnion :: Doc -> Doc -> Doc +mkUnion Empty _ = Empty +mkUnion p q = p `union_` q + +beside_' :: Bool -> Doc -> Doc -> Doc +beside_' _ p Empty = p +beside_' g p q = Beside p g q + +above_' :: Bool -> Doc -> Doc -> Doc +above_' _ p Empty = p +above_' g p q = Above p g q + +reduceAB :: Doc -> Doc +reduceAB (Above Empty _ q) = q +reduceAB (Beside Empty _ q) = q +reduceAB doc = doc + +nilAbove_ :: RDoc -> RDoc +nilAbove_ = NilAbove + +-- Arg of a TextBeside is always an RDoc +textBeside_ :: TextDetails -> Int -> RDoc -> RDoc +textBeside_ = TextBeside + +nest_ :: Int -> RDoc -> RDoc +nest_ = Nest + +union_ :: RDoc -> RDoc -> RDoc +union_ = Union + + +-- --------------------------------------------------------------------------- +-- Vertical composition @$$@ + +-- | Above, except that if the last line of the first argument stops +-- at least one position before the first line of the second begins, +-- these two lines are overlapped. For example: +-- +-- > text "hi" $$ nest 5 (text "there") +-- +-- lays out as +-- +-- > hi there +-- +-- rather than +-- +-- > hi +-- > there +-- +-- '$$' is associative, with identity 'empty', and also satisfies +-- +-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. +-- +($$) :: Doc -> Doc -> Doc +p $$ q = above_ p False q + +-- | Above, with no overlapping. +-- '$+$' is associative, with identity 'empty'. +($+$) :: Doc -> Doc -> Doc +p $+$ q = above_ p True q + +above_ :: Doc -> Bool -> Doc -> Doc +above_ p _ Empty = p +above_ Empty _ q = q +above_ p g q = Above p g q + +above :: Doc -> Bool -> RDoc -> RDoc +above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) +above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) +above p g q = aboveNest p g 0 (reduceDoc q) + +-- Specification: aboveNest p g k q = p $g$ (nest k q) +aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc +aboveNest _ _ k _ | k `seq` False = undefined +aboveNest NoDoc _ _ _ = NoDoc +aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` + aboveNest p2 g k q + +aboveNest Empty _ k q = mkNest k q +aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) + -- p can't be Empty, so no need for mkNest + +aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) +aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest + where + !k1 = k - sl + rest = case p of + Empty -> nilAboveNest g k1 q + _ -> aboveNest p g k1 q +aboveNest (Above {}) _ _ _ = error "aboveNest Above" +aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" + +-- Specification: text s <> nilaboveNest g k q +-- = text s <> (text "" $g$ nest k q) +nilAboveNest :: Bool -> Int -> RDoc -> RDoc +nilAboveNest _ k _ | k `seq` False = undefined +nilAboveNest _ _ Empty = Empty + -- Here's why the "text s <>" is in the spec! +nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q +nilAboveNest g k q | not g && k > 0 -- No newline if no overlap + = textBeside_ (RStr k ' ') k q + | otherwise -- Put them really above + = nilAbove_ (mkNest k q) + + +-- --------------------------------------------------------------------------- +-- Horizontal composition @<>@ + +-- We intentionally avoid Data.Monoid.(<>) here due to interactions of +-- Data.Monoid.(<>) and (<+>). See +-- http://www.haskell.org/pipermail/libraries/2011-November/017066.html + +-- | Beside. +-- '<>' is associative, with identity 'empty'. +(<>) :: Doc -> Doc -> Doc +p <> q = beside_ p False q + +-- | Beside, separated by space, unless one of the arguments is 'empty'. +-- '<+>' is associative, with identity 'empty'. +(<+>) :: Doc -> Doc -> Doc +p <+> q = beside_ p True q + +beside_ :: Doc -> Bool -> Doc -> Doc +beside_ p _ Empty = p +beside_ Empty _ q = q +beside_ p g q = Beside p g q + +-- Specification: beside g p q = p q +beside :: Doc -> Bool -> RDoc -> RDoc +beside NoDoc _ _ = NoDoc +beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q +beside Empty _ q = q +beside (Nest k p) g q = nest_ k $! beside p g q +beside p@(Beside p1 g1 q1) g2 q2 + | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 + | otherwise = beside (reduceDoc p) g2 q2 +beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q +beside (NilAbove p) g q = nilAbove_ $! beside p g q +beside (TextBeside s sl p) g q = textBeside_ s sl rest + where + rest = case p of + Empty -> nilBeside g q + _ -> beside p g q + +-- Specification: text "" <> nilBeside g p +-- = text "" p +nilBeside :: Bool -> RDoc -> RDoc +nilBeside _ Empty = Empty -- Hence the text "" in the spec +nilBeside g (Nest _ p) = nilBeside g p +nilBeside g p | g = textBeside_ spaceText 1 p + | otherwise = p + + +-- --------------------------------------------------------------------------- +-- Separate, @sep@ + +-- Specification: sep ps = oneLiner (hsep ps) +-- `union` +-- vcat ps + +-- | Either 'hsep' or 'vcat'. +sep :: [Doc] -> Doc +sep = sepX True -- Separate with spaces + +-- | Either 'hcat' or 'vcat'. +cat :: [Doc] -> Doc +cat = sepX False -- Don't + +sepX :: Bool -> [Doc] -> Doc +sepX _ [] = empty +sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps + + +-- Specification: sep1 g k ys = sep (x : map (nest k) ys) +-- = oneLiner (x nest k (hsep ys)) +-- `union` x $$ nest k (vcat ys) +sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc +sep1 _ _ k _ | k `seq` False = undefined +sep1 _ NoDoc _ _ = NoDoc +sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` + aboveNest q False k (reduceDoc (vcat ys)) + +sep1 g Empty k ys = mkNest k (sepX g ys) +sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) + +sep1 _ (NilAbove p) k ys = nilAbove_ + (aboveNest p False k (reduceDoc (vcat ys))) +sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) +sep1 _ (Above {}) _ _ = error "sep1 Above" +sep1 _ (Beside {}) _ _ = error "sep1 Beside" + +-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys +-- Called when we have already found some text in the first item +-- We have to eat up nests +sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc +sepNB g (Nest _ p) k ys + = sepNB g p k ys -- Never triggered, because of invariant (2) +sepNB g Empty k ys + = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + nilAboveNest False k (reduceDoc (vcat ys)) + where + rest | g = hsep ys + | otherwise = hcat ys +sepNB g p k ys + = sep1 g p k ys + + +-- --------------------------------------------------------------------------- +-- @fill@ + +-- | \"Paragraph fill\" version of 'cat'. +fcat :: [Doc] -> Doc +fcat = fill False + +-- | \"Paragraph fill\" version of 'sep'. +fsep :: [Doc] -> Doc +fsep = fill True + +-- Specification: +-- +-- fill g docs = fillIndent 0 docs +-- +-- fillIndent k [] = [] +-- fillIndent k [p] = p +-- fillIndent k (p1:p2:ps) = +-- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) +-- (remove_nests (oneLiner p2) : ps) +-- `Union` +-- (p1 $*$ nest (-k) (fillIndent 0 ps)) +-- +-- $*$ is defined for layouts (not Docs) as +-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 +-- | otherwise = layout1 $+$ layout2 + +fill :: Bool -> [Doc] -> RDoc +fill _ [] = empty +fill g (p:ps) = fill1 g (reduceDoc p) 0 ps + +fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc +fill1 _ _ k _ | k `seq` False = undefined +fill1 _ NoDoc _ _ = NoDoc +fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` + aboveNest q False k (fill g ys) +fill1 g Empty k ys = mkNest k (fill g ys) +fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) +fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) +fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) +fill1 _ (Above {}) _ _ = error "fill1 Above" +fill1 _ (Beside {}) _ _ = error "fill1 Beside" + +fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc +fillNB _ _ k _ | k `seq` False = undefined +fillNB g (Nest _ p) k ys = fillNB g p k ys + -- Never triggered, because of invariant (2) +fillNB _ Empty _ [] = Empty +fillNB g Empty k (Empty:ys) = fillNB g Empty k ys +fillNB g Empty k (y:ys) = fillNBE g k y ys +fillNB g p k ys = fill1 g p k ys + + +fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc +fillNBE g k y ys + = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + `mkUnion` nilAboveNest False k (fill g (y:ys)) + where k' = if g then k - 1 else k + +elideNest :: Doc -> Doc +elideNest (Nest _ d) = d +elideNest d = d + +-- --------------------------------------------------------------------------- +-- Selecting the best layout + +best :: Int -- Line length + -> Int -- Ribbon length + -> RDoc + -> RDoc -- No unions in here! +best w0 r = get w0 + where + get :: Int -- (Remaining) width of line + -> Doc -> Doc + get w _ | w == 0 && False = undefined + get _ Empty = Empty + get _ NoDoc = NoDoc + get w (NilAbove p) = nilAbove_ (get w p) + get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) + get w (Nest k p) = nest_ k (get (w - k) p) + get w (p `Union` q) = nicest w r (get w p) (get w q) + get _ (Above {}) = error "best get Above" + get _ (Beside {}) = error "best get Beside" + + get1 :: Int -- (Remaining) width of line + -> Int -- Amount of first line already eaten up + -> Doc -- This is an argument to TextBeside => eat Nests + -> Doc -- No unions in here! + + get1 w _ _ | w == 0 && False = undefined + get1 _ _ Empty = Empty + get1 _ _ NoDoc = NoDoc + get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) + get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) + get1 w sl (Nest _ p) = get1 w sl p + get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + (get1 w sl q) + get1 _ _ (Above {}) = error "best get1 Above" + get1 _ _ (Beside {}) = error "best get1 Beside" + +nicest :: Int -> Int -> Doc -> Doc -> Doc +nicest !w !r = nicest1 w r 0 + +nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc +nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p + | otherwise = q + +fits :: Int -- Space available + -> Doc + -> Bool -- True if *first line* of Doc fits in space available +fits n _ | n < 0 = False +fits _ NoDoc = False +fits _ Empty = True +fits _ (NilAbove _) = True +fits n (TextBeside _ sl p) = fits (n - sl) p +fits _ (Above {}) = error "fits Above" +fits _ (Beside {}) = error "fits Beside" +fits _ (Union {}) = error "fits Union" +fits _ (Nest {}) = error "fits Nest" + +-- | @first@ returns its first argument if it is non-empty, otherwise its second. +first :: Doc -> Doc -> Doc +first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused + | otherwise = q + +nonEmptySet :: Doc -> Bool +nonEmptySet NoDoc = False +nonEmptySet (_ `Union` _) = True +nonEmptySet Empty = True +nonEmptySet (NilAbove _) = True +nonEmptySet (TextBeside _ _ p) = nonEmptySet p +nonEmptySet (Nest _ p) = nonEmptySet p +nonEmptySet (Above {}) = error "nonEmptySet Above" +nonEmptySet (Beside {}) = error "nonEmptySet Beside" + +-- @oneLiner@ returns the one-line members of the given set of @GDoc@s. +oneLiner :: Doc -> Doc +oneLiner NoDoc = NoDoc +oneLiner Empty = Empty +oneLiner (NilAbove _) = NoDoc +oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) +oneLiner (Nest k p) = nest_ k (oneLiner p) +oneLiner (p `Union` _) = oneLiner p +oneLiner (Above {}) = error "oneLiner Above" +oneLiner (Beside {}) = error "oneLiner Beside" + + +-- --------------------------------------------------------------------------- +-- Rendering + +-- | A rendering style. +data Style + = Style { mode :: Mode -- ^ The rendering mode + , lineLength :: Int -- ^ Length of line, in chars + , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length + } + +-- | The default style (@mode=PageMode False, lineLength=100, ribbonsPerLine=1.5@). +style :: Style +style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode False } + +-- | Rendering mode. +data Mode = PageMode { asciiSpace :: Bool } -- ^ Normal + | ZigZagMode -- ^ With zig-zag cuts + | LeftMode -- ^ No indentation, infinitely long lines + | OneLineMode -- ^ All on one line + +-- | Can we output an ascii space character for spaces? +-- Mostly true, but not for e.g. UTF16 +-- See Note [putSpaces optimizations] for why we bother +-- to track this. +hasAsciiSpace :: Mode -> Bool +hasAsciiSpace mode = + case mode of + PageMode asciiSpace -> asciiSpace + _ -> False + +-- | Render the @Doc@ to a String using the given @Style@. +renderStyle :: Style -> Doc -> String +renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) + txtPrinter "" + +-- | Default TextDetails printer +txtPrinter :: TextDetails -> String -> String +txtPrinter (Chr c) s = c:s +txtPrinter (Str s1) s2 = s1 ++ s2 +txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 +txtPrinter (ZStr s1) s2 = zString s1 ++ s2 +txtPrinter (LStr s1) s2 = unpackPtrString s1 ++ s2 +txtPrinter (RStr n c) s2 = replicate n c ++ s2 + +-- | The general rendering interface. +fullRender :: Mode -- ^ Rendering mode + -> Int -- ^ Line length + -> Float -- ^ Ribbons per line + -> (TextDetails -> a -> a) -- ^ What to do with text + -> a -- ^ What to do at the end + -> Doc -- ^ The document + -> a -- ^ Result +fullRender OneLineMode _ _ txt end doc + = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) +fullRender LeftMode _ _ txt end doc + = easyDisplay nlText first txt end (reduceDoc doc) + +fullRender m lineLen ribbons txt rest doc + = display m lineLen ribbonLen txt rest doc' + where + doc' = best bestLineLen ribbonLen (reduceDoc doc) + + bestLineLen, ribbonLen :: Int + ribbonLen = round (fromIntegral lineLen / ribbons) + bestLineLen = case m of + ZigZagMode -> maxBound + _ -> lineLen + +easyDisplay :: TextDetails + -> (Doc -> Doc -> Doc) + -> (TextDetails -> a -> a) + -> a + -> Doc + -> a +easyDisplay nlSpaceText choose txt end + = lay + where + lay NoDoc = error "easyDisplay: NoDoc" + lay (Union p q) = lay (choose p q) + lay (Nest _ p) = lay p + lay Empty = end + lay (NilAbove p) = nlSpaceText `txt` lay p + lay (TextBeside s _ p) = s `txt` lay p + lay (Above {}) = error "easyDisplay Above" + lay (Beside {}) = error "easyDisplay Beside" + +display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a +display m !page_width !ribbon_width txt end doc + = case page_width - ribbon_width of { gap_width -> + case gap_width `quot` 2 of { shift -> + let + lay k _ | k `seq` False = undefined + lay k (Nest k1 p) = lay (k + k1) p + lay _ Empty = end + lay k (NilAbove p) = nlText `txt` lay k p + lay k (TextBeside s sl p) + = case m of + ZigZagMode | k >= gap_width + -> nlText `txt` ( + Str (replicate shift '/') `txt` ( + nlText `txt` + lay1 (k - shift) s sl p )) + + | k < 0 + -> nlText `txt` ( + Str (replicate shift '\\') `txt` ( + nlText `txt` + lay1 (k + shift) s sl p )) + + _ -> lay1 k s sl p + lay _ (Above {}) = error "display lay Above" + lay _ (Beside {}) = error "display lay Beside" + lay _ NoDoc = error "display lay NoDoc" + lay _ (Union {}) = error "display lay Union" + + lay1 !k s !sl p = let !r = k + sl + in indent k (s `txt` lay2 r p) + + lay2 k _ | k `seq` False = undefined + lay2 k (NilAbove p) = nlText `txt` lay k p + lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p + lay2 k (Nest _ p) = lay2 k p + lay2 _ Empty = end + lay2 _ (Above {}) = error "display lay2 Above" + lay2 _ (Beside {}) = error "display lay2 Beside" + lay2 _ NoDoc = error "display lay2 NoDoc" + lay2 _ (Union {}) = error "display lay2 Union" + + indent !n r = RStr n ' ' `txt` r + in + lay 0 doc + }} + +printDoc :: Mode -> Int -> Handle -> Doc -> IO () +-- printDoc adds a newline to the end +printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") + +{- Note [putSpaces optimizations] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When using dump flags a lot of what we are dumping ends up being whitespace. +This is especially true for Core/Stg dumps. Enough so that it's worth optimizing. + +Especially in the common case of writing to an UTF8 or similarly encoded file +where space is equal to ascii space we use hPutBuf to write a preallocated +buffer to the file. This avoids a fair bit of allocation. + +For other cases we fall back to the old and slow path for simplicity. + +-} + +printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () +-- printDoc_ does not add a newline at the end, so that +-- successive calls can output stuff on the same line +-- Rather like putStr vs putStrLn +printDoc_ LeftMode _ hdl doc + = do { printLeftRender hdl doc; hFlush hdl } +printDoc_ mode pprCols hdl doc + = do { fullRender mode pprCols 1.5 put done doc ; + hFlush hdl } + where + put (Chr c) next = hPutChar hdl c >> next + put (Str s) next = hPutStr hdl s >> next + put (PStr s) next = hPutStr hdl (unpackFS s) >> next + -- NB. not hPutFS, we want this to go through + -- the I/O library's encoding layer. (#3398) + put (ZStr s) next = hPutFZS hdl s >> next + put (LStr s) next = hPutPtrString hdl s >> next + put (RStr n c) next + | c == ' ' + = putSpaces n >> next + | otherwise + = hPutStr hdl (replicate n c) >> next + putSpaces n + -- If we use ascii spaces we are allowed to use hPutBuf + -- See Note [putSpaces optimizations] + | hasAsciiSpace mode + , n <= 100 + = hPutBuf hdl (Ptr spaces') n + | hasAsciiSpace mode + , n > 100 + = hPutBuf hdl (Ptr spaces') 100 >> putSpaces (n-100) + + | otherwise = hPutStr hdl (replicate n ' ') + + done = return () -- hPutChar hdl '\n' + -- 100 spaces, so we avoid the allocation of replicate n ' ' + spaces' = " "# + + + -- some versions of hPutBuf will barf if the length is zero +hPutPtrString :: Handle -> PtrString -> IO () +hPutPtrString _handle (PtrString _ 0) = return () +hPutPtrString handle (PtrString a l) = hPutBuf handle a l + +-- Printing output in LeftMode is performance critical: it's used when +-- dumping C and assembly output, so we allow ourselves a few dirty +-- hacks: +-- +-- (1) we specialise fullRender for LeftMode with IO output. +-- +-- (2) we add a layer of buffering on top of Handles. Handles +-- don't perform well with lots of hPutChars, which is mostly +-- what we're doing here, because Handles have to be thread-safe +-- and async exception-safe. We only have a single thread and don't +-- care about exceptions, so we add a layer of fast buffering +-- over the Handle interface. + +printLeftRender :: Handle -> Doc -> IO () +printLeftRender hdl doc = do + b <- newBufHandle hdl + bufLeftRender b doc + bFlush b + +bufLeftRender :: BufHandle -> Doc -> IO () +bufLeftRender b doc = layLeft b (reduceDoc doc) + +layLeft :: BufHandle -> Doc -> IO () +layLeft !_ NoDoc = error "layLeft: NoDoc" +layLeft b (Union p q) = layLeft b $! first p q +layLeft b (Nest _ p) = layLeft b $! p +layLeft b Empty = bPutChar b '\n' +layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p +layLeft b (TextBeside s _ p) = put b s >> layLeft b p + where + put !b (Chr c) = bPutChar b c + put b (Str s) = bPutStr b s + put b (PStr s) = bPutFS b s + put b (ZStr s) = bPutFZS b s + put b (LStr s) = bPutPtrString b s + put b (RStr n c) = bPutReplicate b n c +layLeft _ _ = panic "layLeft: Unhandled case" + +-- Define error=panic, for easier comparison with libraries/pretty. +error :: String -> a +error = panic diff --git a/GHC/Utils/Ppr/Colour.hs b/GHC/Utils/Ppr/Colour.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Ppr/Colour.hs @@ -0,0 +1,106 @@ +module GHC.Utils.Ppr.Colour where +import GHC.Prelude.Basic + +import Data.Maybe (fromMaybe) +import GHC.Data.Bool +import Data.Semigroup as Semi + +-- | A colour\/style for use with 'coloured'. +newtype PprColour = PprColour { renderColour :: String } + +instance Semi.Semigroup PprColour where + PprColour s1 <> PprColour s2 = PprColour (s1 <> s2) + +-- | Allow colours to be combined (e.g. bold + red); +-- In case of conflict, right side takes precedence. +instance Monoid PprColour where + mempty = PprColour mempty + mappend = (<>) + +renderColourAfresh :: PprColour -> String +renderColourAfresh c = renderColour (colReset `mappend` c) + +colCustom :: String -> PprColour +colCustom "" = mempty +colCustom s = PprColour ("\27[" ++ s ++ "m") + +colReset :: PprColour +colReset = colCustom "0" + +colBold :: PprColour +colBold = colCustom ";1" + +colBlackFg :: PprColour +colBlackFg = colCustom "30" + +colRedFg :: PprColour +colRedFg = colCustom "31" + +colGreenFg :: PprColour +colGreenFg = colCustom "32" + +colYellowFg :: PprColour +colYellowFg = colCustom "33" + +colBlueFg :: PprColour +colBlueFg = colCustom "34" + +colMagentaFg :: PprColour +colMagentaFg = colCustom "35" + +colCyanFg :: PprColour +colCyanFg = colCustom "36" + +colWhiteFg :: PprColour +colWhiteFg = colCustom "37" + +data Scheme = + Scheme + { sHeader :: PprColour + , sMessage :: PprColour + , sWarning :: PprColour + , sError :: PprColour + , sFatal :: PprColour + , sMargin :: PprColour + } + +defaultScheme :: Scheme +defaultScheme = + Scheme + { sHeader = mempty + , sMessage = colBold + , sWarning = colBold `mappend` colMagentaFg + , sError = colBold `mappend` colRedFg + , sFatal = colBold `mappend` colRedFg + , sMargin = colBold `mappend` colBlueFg + } + +-- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@ +-- environment variable). +parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme) +parseScheme "always" (_, cs) = (Always, cs) +parseScheme "auto" (_, cs) = (Auto, cs) +parseScheme "never" (_, cs) = (Never, cs) +parseScheme input (b, cs) = + ( b + , Scheme + { sHeader = fromMaybe (sHeader cs) (lookup "header" table) + , sMessage = fromMaybe (sMessage cs) (lookup "message" table) + , sWarning = fromMaybe (sWarning cs) (lookup "warning" table) + , sError = fromMaybe (sError cs) (lookup "error" table) + , sFatal = fromMaybe (sFatal cs) (lookup "fatal" table) + , sMargin = fromMaybe (sMargin cs) (lookup "margin" table) + } + ) + where + split :: Char -> String -> [String] + split c s = case break (==c) s of + (chunk,[]) -> [chunk] + (chunk,_:rest) -> chunk : split c rest + + table = do + w <- split ':' input + let (k, v') = break (== '=') w + case v' of + '=' : v -> return (k, colCustom v) + _ -> [] diff --git a/GHC/Utils/TmpFs.hs b/GHC/Utils/TmpFs.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/TmpFs.hs @@ -0,0 +1,496 @@ +{-# LANGUAGE CPP #-} + +-- | Temporary file-system management +module GHC.Utils.TmpFs + ( TmpFs + , initTmpFs + , forkTmpFsFrom + , mergeTmpFsInto + , PathsToClean(..) + , emptyPathsToClean + , TempFileLifetime(..) + , TempDir (..) + , cleanTempDirs + , cleanTempFiles + , cleanCurrentModuleTempFiles + , keepCurrentModuleTempFiles + , addFilesToClean + , changeTempFilesLifetime + , newTempName + , newTempLibName + , newTempSubDir + , withSystemTempDirectory + , withTempDirectory + ) +where + +import GHC.Prelude + +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Exception as Exception +import GHC.Driver.Phases + +import Data.List (partition) +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.IORef +import System.Directory +import System.FilePath +import System.IO.Error + +#if !defined(mingw32_HOST_OS) +import qualified System.Posix.Internals +#endif + +-- | Temporary file-system +data TmpFs = TmpFs + { tmp_dirs_to_clean :: IORef (Map FilePath FilePath) + -- ^ Maps system temporary directory (passed via settings or DynFlags) to + -- an actual temporary directory for this process. + -- + -- It's a Map probably to support changing the system temporary directory + -- over time. + -- + -- Shared with forked TmpFs. + + , tmp_next_suffix :: IORef Int + -- ^ The next available suffix to uniquely name a temp file, updated + -- atomically. + -- + -- Shared with forked TmpFs. + + , tmp_dir_prefix :: String + + , tmp_files_to_clean :: IORef PathsToClean + -- ^ Files to clean (per session or per module) + -- + -- Not shared with forked TmpFs. + , tmp_subdirs_to_clean :: IORef PathsToClean + -- ^ Subdirs to clean (per session or per module) + -- + -- Not shared with forked TmpFs. + } + +-- | A collection of paths that must be deleted before ghc exits. +data PathsToClean = PathsToClean + { ptcGhcSession :: !(Set FilePath) + -- ^ Paths that will be deleted at the end of runGhc(T) + + , ptcCurrentModule :: !(Set FilePath) + -- ^ Paths that will be deleted the next time + -- 'cleanCurrentModuleTempFiles' is called, or otherwise at the end of + -- the session. + } + +-- | Used when a temp file is created. This determines which component Set of +-- PathsToClean will get the temp file +data TempFileLifetime + = TFL_CurrentModule + -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the + -- end of upweep_mod + | TFL_GhcSession + -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of + -- runGhc(T) + deriving (Show) + +newtype TempDir = TempDir FilePath + +-- | An empty PathsToClean +emptyPathsToClean :: PathsToClean +emptyPathsToClean = PathsToClean Set.empty Set.empty + +-- | Merge two PathsToClean +mergePathsToClean :: PathsToClean -> PathsToClean -> PathsToClean +mergePathsToClean x y = PathsToClean + { ptcGhcSession = Set.union (ptcGhcSession x) (ptcGhcSession y) + , ptcCurrentModule = Set.union (ptcCurrentModule x) (ptcCurrentModule y) + } + +-- | Initialise an empty TmpFs +initTmpFs :: IO TmpFs +initTmpFs = do + files <- newIORef emptyPathsToClean + subdirs <- newIORef emptyPathsToClean + dirs <- newIORef Map.empty + next <- newIORef 0 + return $ TmpFs + { tmp_files_to_clean = files + , tmp_subdirs_to_clean = subdirs + , tmp_dirs_to_clean = dirs + , tmp_next_suffix = next + , tmp_dir_prefix = "tmp" + } + +-- | Initialise an empty TmpFs sharing unique numbers and per-process temporary +-- directories with the given TmpFs +-- +-- It's not safe to use the subdirs created by the original TmpFs with the +-- forked one. Use @newTempSubDir@ to create new subdirs instead. +forkTmpFsFrom :: TmpFs -> IO TmpFs +forkTmpFsFrom old = do + files <- newIORef emptyPathsToClean + subdirs <- newIORef emptyPathsToClean + counter <- newIORef 0 + prefix <- newTempSuffix old + + + return $ TmpFs + { tmp_files_to_clean = files + , tmp_subdirs_to_clean = subdirs + , tmp_dirs_to_clean = tmp_dirs_to_clean old + , tmp_next_suffix = counter + , tmp_dir_prefix = prefix + } + +-- | Merge the first TmpFs into the second. +-- +-- The first TmpFs is returned emptied. +mergeTmpFsInto :: TmpFs -> TmpFs -> IO () +mergeTmpFsInto src dst = do + src_files <- atomicModifyIORef' (tmp_files_to_clean src) (\s -> (emptyPathsToClean, s)) + src_subdirs <- atomicModifyIORef' (tmp_subdirs_to_clean src) (\s -> (emptyPathsToClean, s)) + atomicModifyIORef' (tmp_files_to_clean dst) (\s -> (mergePathsToClean src_files s, ())) + atomicModifyIORef' (tmp_subdirs_to_clean dst) (\s -> (mergePathsToClean src_subdirs s, ())) + + +cleanTempDirs :: Logger -> TmpFs -> IO () +cleanTempDirs logger tmpfs + = mask_ + $ do let ref = tmp_dirs_to_clean tmpfs + ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) + removeTmpDirs logger (Map.elems ds) + +-- | Delete all paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@. +cleanTempFiles :: Logger -> TmpFs -> IO () +cleanTempFiles logger tmpfs + = mask_ + $ do removeWith (removeTmpFiles logger) (tmp_files_to_clean tmpfs) + removeWith (removeTmpSubdirs logger) (tmp_subdirs_to_clean tmpfs) + where + removeWith remove ref = do + to_delete <- atomicModifyIORef' ref $ + \PathsToClean + { ptcCurrentModule = cm_paths + , ptcGhcSession = gs_paths + } -> ( emptyPathsToClean + , Set.toList cm_paths ++ Set.toList gs_paths) + remove to_delete + +-- | Keep all the paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@ +-- that have lifetime TFL_CurrentModule. This function is used when `-keep-tmp-files` is +-- used in an OPTIONS_GHC pragma. +-- This function removes the temporary file from the TmpFs so we no longer remove +-- it at the env when cleanTempFiles is called. +keepCurrentModuleTempFiles :: HasCallStack => Logger -> TmpFs -> IO () +keepCurrentModuleTempFiles logger tmpfs + = mask_ + $ do to_keep_files <- keep (tmp_files_to_clean tmpfs) + to_keep_subdirs <- keep (tmp_subdirs_to_clean tmpfs) + -- Remove any folders which contain any files we want to keep from the + -- directories we are tracking. A new temporary directory will be created + -- the next time a temporary file is needed (by perhaps another module). + keepDirs (to_keep_files ++ to_keep_subdirs) (tmp_dirs_to_clean tmpfs) + where + keepDirs keeps ref = do + let keep_dirs = Set.fromList (map takeDirectory keeps) + atomicModifyIORef' ref $ \m -> (Map.filter (\fp -> fp `Set.notMember` keep_dirs) m, ()) + + keep ref = do + to_keep <- atomicModifyIORef' ref $ + \ptc@PathsToClean{ptcCurrentModule = cm_paths} -> + (ptc {ptcCurrentModule = Set.empty}, Set.toList cm_paths) + debugTraceMsg logger 2 (text "Keeping:" <+> hsep (map text to_keep)) + return to_keep + +-- | Delete all paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@ +-- That have lifetime TFL_CurrentModule. +-- If a file must be cleaned eventually, but must survive a +-- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession. +cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO () +cleanCurrentModuleTempFiles logger tmpfs + = mask_ + $ do removeWith (removeTmpFiles logger) (tmp_files_to_clean tmpfs) + removeWith (removeTmpSubdirs logger) (tmp_subdirs_to_clean tmpfs) + where + removeWith remove ref = do + to_delete <- atomicModifyIORef' ref $ + \ptc@PathsToClean{ptcCurrentModule = cm_paths} -> + (ptc {ptcCurrentModule = Set.empty}, Set.toList cm_paths) + remove to_delete + +-- | Ensure that new_files are cleaned on the next call of +-- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime. +-- If any of new_files are already tracked, they will have their lifetime +-- updated. +addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO () +addFilesToClean tmpfs lifetime new_files = + addToClean (tmp_files_to_clean tmpfs) lifetime new_files + +addSubdirsToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO () +addSubdirsToClean tmpfs lifetime new_subdirs = + addToClean (tmp_subdirs_to_clean tmpfs) lifetime new_subdirs + +addToClean :: IORef PathsToClean -> TempFileLifetime -> [FilePath] -> IO () +addToClean ref lifetime new_filepaths = modifyIORef' ref $ + \PathsToClean + { ptcCurrentModule = cm_paths + , ptcGhcSession = gs_paths + } -> case lifetime of + TFL_CurrentModule -> PathsToClean + { ptcCurrentModule = cm_paths `Set.union` new_filepaths_set + , ptcGhcSession = gs_paths `Set.difference` new_filepaths_set + } + TFL_GhcSession -> PathsToClean + { ptcCurrentModule = cm_paths `Set.difference` new_filepaths_set + , ptcGhcSession = gs_paths `Set.union` new_filepaths_set + } + where + new_filepaths_set = Set.fromList new_filepaths + +-- | Update the lifetime of files already being tracked. If any files are +-- not being tracked they will be discarded. +changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO () +changeTempFilesLifetime tmpfs lifetime files = do + PathsToClean + { ptcCurrentModule = cm_paths + , ptcGhcSession = gs_paths + } <- readIORef (tmp_files_to_clean tmpfs) + let old_set = case lifetime of + TFL_CurrentModule -> gs_paths + TFL_GhcSession -> cm_paths + existing_files = [f | f <- files, f `Set.member` old_set] + addFilesToClean tmpfs lifetime existing_files + +-- Return a unique numeric temp file suffix +newTempSuffix :: TmpFs -> IO String +newTempSuffix tmpfs = do + n <- atomicModifyIORef' (tmp_next_suffix tmpfs) $ \n -> (n+1,n) + return $ tmp_dir_prefix tmpfs ++ "_" ++ show n + + +-- Find a temporary name that doesn't already exist. +newTempName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix -> IO FilePath +newTempName logger tmpfs tmp_dir lifetime extn + = do d <- getTempDir logger tmpfs tmp_dir + findTempName (d "ghc_") -- See Note [Deterministic base name] + where + findTempName :: FilePath -> IO FilePath + findTempName prefix + = do suffix <- newTempSuffix tmpfs + let filename = prefix ++ suffix <.> extn + b <- doesFileExist filename + if b then findTempName prefix + else do -- clean it up later + addFilesToClean tmpfs lifetime [filename] + return filename + +-- | Create a new temporary subdirectory that doesn't already exist +-- The temporary subdirectory is automatically removed at the end of the +-- GHC session, but its contents aren't. Make sure to leave the directory +-- empty before the end of the session, either by removing content +-- directly or by using @addFilesToClean@. +-- +-- If the created subdirectory is not empty, it will not be removed (along +-- with its parent temporary directory) and a warning message will be +-- printed at verbosity 2 and higher. +newTempSubDir :: Logger -> TmpFs -> TempDir -> IO FilePath +newTempSubDir logger tmpfs tmp_dir + = do d <- getTempDir logger tmpfs tmp_dir + findTempDir (d "ghc_") + where + findTempDir :: FilePath -> IO FilePath + findTempDir prefix + = do suffix <- newTempSuffix tmpfs + let name = prefix ++ suffix + b <- doesDirectoryExist name + if b then findTempDir prefix + else (do + createDirectory name + addSubdirsToClean tmpfs TFL_GhcSession [name] + return name) + `Exception.catchIO` \e -> if isAlreadyExistsError e + then findTempDir prefix else ioError e + +newTempLibName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix + -> IO (FilePath, FilePath, String) +newTempLibName logger tmpfs tmp_dir lifetime extn + = do d <- getTempDir logger tmpfs tmp_dir + findTempName d ("ghc_") + where + findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) + findTempName dir prefix + = do suffix <- newTempSuffix tmpfs -- See Note [Deterministic base name] + let libname = prefix ++ suffix + filename = dir "lib" ++ libname <.> extn + b <- doesFileExist filename + if b then findTempName dir prefix + else do -- clean it up later + addFilesToClean tmpfs lifetime [filename] + return (filename, dir, libname) + + +-- Return our temporary directory within tmp_dir, creating one if we +-- don't have one yet. +getTempDir :: Logger -> TmpFs -> TempDir -> IO FilePath +getTempDir logger tmpfs (TempDir tmp_dir) = do + mapping <- readIORef dir_ref + case Map.lookup tmp_dir mapping of + Nothing -> do + pid <- getProcessID + let prefix = tmp_dir "ghc" ++ show pid ++ "_" + mask_ $ mkTempDir prefix + Just dir -> return dir + where + dir_ref = tmp_dirs_to_clean tmpfs + + mkTempDir :: FilePath -> IO FilePath + mkTempDir prefix = do + suffix <- newTempSuffix tmpfs + let our_dir = prefix ++ suffix + + -- 1. Speculatively create our new directory. + createDirectory our_dir + + -- 2. Update the tmp_dirs_to_clean mapping unless an entry already exists + -- (i.e. unless another thread beat us to it). + their_dir <- atomicModifyIORef' dir_ref $ \mapping -> + case Map.lookup tmp_dir mapping of + Just dir -> (mapping, Just dir) + Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing) + + -- 3. If there was an existing entry, return it and delete the + -- directory we created. Otherwise return the directory we created. + case their_dir of + Nothing -> do + debugTraceMsg logger 2 $ + text "Created temporary directory:" <+> text our_dir + return our_dir + Just dir -> do + removeDirectory our_dir + return dir + `Exception.catchIO` \e -> if isAlreadyExistsError e + then mkTempDir prefix else ioError e + +{- Note [Deterministic base name] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The filename of temporary files, especially the basename of C files, can end +up in the output in some form, e.g. as part of linker debug information. In the +interest of bit-wise exactly reproducible compilation (#4012), the basename of +the temporary file no longer contains random information (it used to contain +the process id). + +This is ok, as the temporary directory used contains the pid (see getTempDir). + +In addition to this, multiple threads can race against each other creating temporary +files. Therefore we supply a prefix when creating temporary files, when a thread is +forked, each thread must be given an TmpFs with a unique prefix. This is achieved +by forkTmpFsFrom creating a fresh prefix from the parent TmpFs. +-} + +manyWithTrace :: Logger -> String -> ([FilePath] -> IO ()) -> [FilePath] -> IO () +manyWithTrace _ _ _ [] = pure () -- do silent nothing on zero filepaths +manyWithTrace logger phase act paths + = traceCmd logger phase ("Deleting: " ++ unwords paths) (act paths) + +removeTmpDirs :: Logger -> [FilePath] -> IO () +removeTmpDirs logger + = manyWithTrace logger "Deleting temp dirs" + (mapM_ (removeWith logger removeDirectory)) + +removeTmpSubdirs :: Logger -> [FilePath] -> IO () +removeTmpSubdirs logger + = manyWithTrace logger "Deleting temp subdirs" + (mapM_ (removeWith logger removeDirectory)) + +removeTmpFiles :: Logger -> [FilePath] -> IO () +removeTmpFiles logger fs + = warnNon $ + manyWithTrace logger "Deleting temp files" + (mapM_ (removeWith logger removeFile)) deletees + where + -- Flat out refuse to delete files that are likely to be source input + -- files (is there a worse bug than having a compiler delete your source + -- files?) + -- + -- Deleting source files is a sign of a bug elsewhere, so prominently flag + -- the condition. + warnNon act + | null non_deletees = act + | otherwise = do + putMsg logger (text "WARNING - NOT deleting source files:" + <+> hsep (map text non_deletees)) + act + + (non_deletees, deletees) = partition isHaskellUserSrcFilename fs + +removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO () +removeWith logger remover f = remover f `Exception.catchIO` + (\e -> + let msg = if isDoesNotExistError e + then text "Warning: deleting non-existent" <+> text f + else text "Warning: exception raised when deleting" + <+> text f <> colon + $$ text (show e) + in debugTraceMsg logger 2 msg + ) + +#if defined(mingw32_HOST_OS) +-- relies on Int == Int32 on Windows +foreign import ccall unsafe "_getpid" getProcessID :: IO Int +#else +getProcessID :: IO Int +getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral +#endif + +-- The following three functions are from the `temporary` package. + +-- | Create and use a temporary directory in the system standard temporary +-- directory. +-- +-- Behaves exactly the same as 'withTempDirectory', except that the parent +-- temporary directory will be that returned by 'getTemporaryDirectory'. +withSystemTempDirectory :: String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> IO a) -- ^ Callback that can use the directory + -> IO a +withSystemTempDirectory template action = + getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action + + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +withTempDirectory :: FilePath -- ^ Temp directory to create the directory in + -> String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> IO a) -- ^ Callback that can use the directory + -> IO a +withTempDirectory targetDir template = + Exception.bracket + (createTempDirectory targetDir template) + (ignoringIOErrors . removeDirectoryRecursive) + +ignoringIOErrors :: IO () -> IO () +ignoringIOErrors ioe = ioe `Exception.catchIO` const (return ()) + + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- getProcessID + findTempName pid + where findTempName x = do + let path = dir template ++ show x + createDirectory path + return path + `Exception.catchIO` \e -> if isAlreadyExistsError e + then findTempName (x+1) else ioError e diff --git a/GHC/Utils/Touch.hs b/GHC/Utils/Touch.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Touch.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP #-} + +module GHC.Utils.Touch (touch) where + +import GHC.Prelude + +#if defined(mingw32_HOST_OS) +import System.Win32.File +import System.Win32.Time +#else +import System.Posix.Files +import System.Posix.IO +#endif + +-- | Set the mtime of the given file to the current time. +touch :: FilePath -> IO () +touch file = do +#if defined(mingw32_HOST_OS) + hdl <- createFile file gENERIC_WRITE fILE_SHARE_NONE Nothing oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL Nothing + t <- getSystemTimeAsFileTime + setFileTime hdl Nothing Nothing (Just t) + closeHandle hdl +#else + let oflags = defaultFileFlags { noctty = True, creat = Just 0o666 } + fd <- openFd file WriteOnly oflags + touchFd fd + closeFd fd +#endif diff --git a/GHC/Utils/Trace.hs b/GHC/Utils/Trace.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Trace.hs @@ -0,0 +1,103 @@ +-- | Tracing utilities +module GHC.Utils.Trace + ( pprTrace + , pprTraceM + , pprTraceDebug + , pprTraceIt + , pprTraceWith + , pprSTrace + , pprTraceException + , warnPprTrace + , warnPprTraceM + , pprTraceUserWarning + , trace + ) +where + +{- Note [Exporting pprTrace from GHC.Prelude] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For our own sanity we want to export pprTrace from GHC.Prelude. +Since calls to traces should never be performance sensitive it's okay for these +to be source imports/exports. However we still need to make sure that all +transitive imports from Trace.hs-boot do not import GHC.Prelude. + +To get there we import the basic GHC.Prelude.Basic prelude instead of GHC.Prelude +within the transitive dependencies of Trace.hs +-} + +import GHC.Prelude.Basic +import GHC.Utils.Outputable +import GHC.Utils.Exception +import GHC.Utils.Panic +import GHC.Utils.GlobalVars +import GHC.Utils.Constants +import GHC.Stack + +import Debug.Trace (trace) +import Control.Monad.IO.Class + +-- | If debug output is on, show some 'SDoc' on the screen +pprTrace :: String -> SDoc -> a -> a +pprTrace str doc x + | unsafeHasNoDebugOutput = x + | otherwise = pprDebugAndThen traceSDocContext trace (text str) doc x + +pprTraceM :: Applicative f => String -> SDoc -> f () +pprTraceM str doc = pprTrace str doc (pure ()) + +pprTraceDebug :: String -> SDoc -> a -> a +pprTraceDebug str doc x + | debugIsOn && unsafeHasPprDebug = pprTrace str doc x + | otherwise = x + +-- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@. +-- This allows you to print details from the returned value as well as from +-- ambient variables. +pprTraceWith :: String -> (a -> SDoc) -> a -> a +pprTraceWith desc f x = pprTrace desc (f x) x + +-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@ +pprTraceIt :: Outputable a => String -> a -> a +pprTraceIt desc x = pprTraceWith desc ppr x + +-- | @pprTraceException desc x action@ runs action, printing a message +-- if it throws an exception. +pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a +pprTraceException heading doc = + handleGhcException $ \exc -> liftIO $ do + putStrLn $ renderWithContext defaultSDocContext + $ withPprStyle defaultDumpStyle + $ sep [text heading, nest 2 doc] + throwGhcExceptionIO exc + +-- | If debug output is on, show some 'SDoc' on the screen along +-- with a call stack when available. +pprSTrace :: HasCallStack => SDoc -> a -> a +pprSTrace doc = pprTrace "" (doc $$ traceCallStackDoc) + +-- | Just warn about an assertion failure, recording the given file and line number. +warnPprTrace :: HasCallStack => Bool -> String -> SDoc -> a -> a +warnPprTrace _ _s _ x | not debugIsOn = x +warnPprTrace _ _s _msg x | unsafeHasNoDebugOutput = x +warnPprTrace False _s _msg x = x +warnPprTrace True s msg x + = pprDebugAndThen traceSDocContext trace (text "WARNING:") + (text s $$ msg $$ withFrozenCallStack traceCallStackDoc ) + x + +warnPprTraceM :: (Applicative f, HasCallStack) => Bool -> String -> SDoc -> f () +warnPprTraceM b s doc = withFrozenCallStack warnPprTrace b s doc (pure ()) + +-- | For when we want to show the user a non-fatal WARNING so that they can +-- report a GHC bug, but don't want to panic. +pprTraceUserWarning :: HasCallStack => SDoc -> a -> a +pprTraceUserWarning msg x + | unsafeHasNoDebugOutput = x + | otherwise = pprDebugAndThen traceSDocContext trace (text "WARNING:") + (msg $$ withFrozenCallStack traceCallStackDoc ) + x + +traceCallStackDoc :: HasCallStack => SDoc +traceCallStackDoc = + hang (text "Call stack:") + 4 (vcat $ map text $ lines (prettyCallStack callStack)) diff --git a/GHC/Utils/Unique.hs b/GHC/Utils/Unique.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Unique.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} + +{- Work around #23537 + +On 32 bit systems, GHC's codegen around 64 bit numbers used to be incomplete +before GHC 9.10. This led to panics mentioning missing cases in iselExpr64. +Now that GHC uses Word64 for its uniques, these panics have started popping up +whenever a unique is compared to many other uniques in one function. As a +workaround we use these two functions which are not inlined, on 32 bit systems +and if compiled with versions before GHC 9.9, thus preventing the panics. +-} + +module GHC.Utils.Unique (sameUnique, anyOfUnique) where + +#include "MachDeps.h" + +import GHC.Prelude.Basic (Bool, Eq((==)), Foldable(elem)) +import GHC.Types.Unique (Unique, Uniquable (getUnique)) + + +#if WORD_SIZE_IN_BITS == 32 && !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) +{-# NOINLINE sameUnique #-} +#else +{-# INLINE sameUnique #-} +#endif +sameUnique :: Uniquable a => a -> a -> Bool +sameUnique x y = getUnique x == getUnique y + +#if WORD_SIZE_IN_BITS == 32 && !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) +{-# NOINLINE anyOfUnique #-} +#else +{-# INLINE anyOfUnique #-} +#endif +anyOfUnique :: Uniquable a => a -> [Unique] -> Bool +anyOfUnique tc xs = getUnique tc `elem` xs diff --git a/GHC/Utils/Word64.hs b/GHC/Utils/Word64.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Word64.hs @@ -0,0 +1,20 @@ +module GHC.Utils.Word64 ( + intToWord64, + word64ToInt, + truncateWord64ToWord32, + ) where + +import GHC.Prelude +import GHC.Utils.Panic.Plain (assert) +import GHC.Utils.Misc (HasDebugCallStack) + +import Data.Word + +intToWord64 :: HasDebugCallStack => Int -> Word64 +intToWord64 x = assert (0 <= x) (fromIntegral x) + +word64ToInt :: HasDebugCallStack => Word64 -> Int +word64ToInt x = assert (x <= fromIntegral (maxBound :: Int)) (fromIntegral x) + +truncateWord64ToWord32 :: Word64 -> Word32 +truncateWord64ToWord32 = fromIntegral diff --git a/GHC/Wasm/ControlFlow.hs b/GHC/Wasm/ControlFlow.hs new file mode 100644 --- /dev/null +++ b/GHC/Wasm/ControlFlow.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds, GADTs, RankNTypes, KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} + +module GHC.Wasm.ControlFlow + ( WasmControl(..), (<>), pattern WasmIf + , BrTableInterval(..), inclusiveInterval + + , WasmType, WasmTypeTag(..) + , TypeList(..) + , WasmFunctionType(..) + ) +where + +import GHC.Prelude + +import GHC.CmmToAsm.Wasm.Types +import GHC.Utils.Panic + +{-| +Module : GHC.Wasm.ControlFlow +Description : Representation of control-flow portion of the WebAssembly instruction set +-} + +inclusiveInterval :: Integer -> Integer -> BrTableInterval +inclusiveInterval lo hi + | lo <= hi = let count = hi - lo + 1 + in BrTableInterval lo count + | otherwise = panic "GHC.Wasm.ControlFlow: empty interval" + +(<>) :: forall s e pre mid post + . WasmControl s e pre mid + -> WasmControl s e mid post + -> WasmControl s e pre post +(<>) = WasmSeq +-- N.B. Fallthrough can't be optimized away because of type checking. + + + +-- Syntactic sugar. +pattern WasmIf :: WasmFunctionType pre post + -> e + -> WasmControl s e pre post + -> WasmControl s e pre post + -> WasmControl s e pre post + +pattern WasmIf ty e t f = + WasmPush TagI32 e `WasmSeq` WasmIfTop ty t f diff --git a/GHC/Wasm/ControlFlow/FromCmm.hs b/GHC/Wasm/ControlFlow/FromCmm.hs new file mode 100644 --- /dev/null +++ b/GHC/Wasm/ControlFlow/FromCmm.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +module GHC.Wasm.ControlFlow.FromCmm + ( structuredControl + ) +where + +import GHC.Prelude hiding (succ) + +import Data.Function +import Data.List (sortBy) +import qualified Data.Tree as Tree + +import GHC.Cmm +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dominators +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Reducibility +import GHC.Cmm.Switch + +import GHC.Data.Graph.Collapse (MonadUniqDSM (liftUniqDSM)) +import GHC.CmmToAsm.Wasm.Types + +import GHC.Platform +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr + , pprWithCommas + ) + +import GHC.Wasm.ControlFlow + + +{-| +Module : GHC.Wasm.ControlFlow.FromCmm +Description : Translation of (reducible) Cmm control flow to WebAssembly + +Code in this module can translate any _reducible_ Cmm control-flow +graph to the structured control flow that is required by WebAssembly. +The algorithm is subtle and is described in detail in a draft paper +to be found at https://www.cs.tufts.edu/~nr/pubs/relooper.pdf. +-} + +--------------------- Abstraction of Cmm control flow ----------------------- + +-- | Abstracts the kind of control flow we understand how to convert. +-- A block can be left in one of four ways: +-- +-- * Unconditionally +-- +-- * Conditionally on a predicate of type `e` +-- +-- * To a location determined by the value of a scrutinee of type `e` +-- +-- * Not at all. + +data ControlFlow e = Unconditional Label + | Conditional e Label Label + | Switch { _scrutinee :: e + , _range :: BrTableInterval + , _targets :: [Maybe Label] -- from 0 + , _defaultTarget :: Maybe Label + } + | TailCall e + +flowLeaving :: Platform -> CmmBlock -> ControlFlow CmmExpr +flowLeaving platform b = + case lastNode b of + CmmBranch l -> Unconditional l + CmmCondBranch c t f _ -> Conditional c t f + CmmSwitch e targets -> + let (offset, target_labels) = switchTargetsToTable targets + (lo, hi) = switchTargetsRange targets + default_label = switchTargetsDefault targets + scrutinee = smartExtend platform $ smartPlus platform e offset + range = inclusiveInterval (lo+toInteger offset) (hi+toInteger offset) + in Switch scrutinee range target_labels default_label + CmmCall { cml_target = e } -> TailCall e + _ -> panic "flowLeaving: unreachable" + +----------------------- Evaluation contexts ------------------------------ + +-- | The syntactic constructs in which Wasm code may be contained. +-- A list of these constructs represents an evaluation context, +-- which is used to determined what level of `br` instruction +-- reaches a given label. + +data ContainingSyntax + = BlockFollowedBy Label + | LoopHeadedBy Label + | IfThenElse (Maybe Label) -- ^ Carries the label that follows `if...end`, if any + +matchesFrame :: Label -> ContainingSyntax -> Bool +matchesFrame label (BlockFollowedBy l) = label == l +matchesFrame label (LoopHeadedBy l) = label == l +matchesFrame label (IfThenElse (Just l)) = label == l +matchesFrame _ _ = False + +data Context = Context { enclosing :: [ContainingSyntax] + , fallthrough :: Maybe Label -- the label can + -- be reached just by "falling through" + -- the hole + } + +instance Outputable Context where + ppr c | Just l <- fallthrough c = + pprWithCommas ppr (enclosing c) <+> text "fallthrough to" <+> ppr l + | otherwise = pprWithCommas ppr (enclosing c) + +emptyContext :: Context +emptyContext = Context [] Nothing + +inside :: ContainingSyntax -> Context -> Context +withFallthrough :: Context -> Label -> Context + +inside frame c = c { enclosing = frame : enclosing c } +withFallthrough c l = c { fallthrough = Just l } + +type CmmActions = Block CmmNode O O + +type FT pre post = WasmFunctionType pre post + +returns :: FT '[] '[ 'I32] +doesn'tReturn :: FT '[] '[] + +returns = WasmFunctionType TypeListNil (TypeListCons TagI32 TypeListNil) +doesn'tReturn = WasmFunctionType TypeListNil TypeListNil + +emptyPost :: FT pre post -> Bool +emptyPost (WasmFunctionType _ TypeListNil) = True +emptyPost _ = False + +----------------------- Translation ------------------------------ + +-- | Convert a Cmm CFG to WebAssembly's structured control flow. + +structuredControl :: forall expr stmt m . + MonadUniqDSM m + => Platform -- ^ needed for offset calculation + -> (Label -> CmmExpr -> m expr) -- ^ translator for expressions + -> (Label -> CmmActions -> m stmt) -- ^ translator for straight-line code + -> CmmGraph -- ^ CFG to be translated + -> m (WasmControl stmt expr '[] '[ 'I32]) +structuredControl platform txExpr txBlock g' = do + gwd :: GraphWithDominators CmmNode <- + liftUniqDSM $ asReducible $ graphWithDominators g' + + let + g :: CmmGraph + g = gwd_graph gwd + + dominatorTree :: Tree.Tree CmmBlock-- Dominator tree in which children are sorted + -- with highest reverse-postorder number first + dominatorTree = fmap blockLabeled $ sortTree $ gwdDominatorTree gwd + + doTree :: FT '[] post -> Tree.Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post) + nodeWithin :: forall post . + FT '[] post -> CmmBlock -> [Tree.Tree CmmBlock] -> Maybe Label + -> Context -> m (WasmControl stmt expr '[] post) + doBranch :: FT '[] post -> Label -> Label -> Context -> m (WasmControl stmt expr '[] post) + + doTree fty (Tree.Node x children) context = + let codeForX = nodeWithin fty x selectedChildren Nothing + in if isLoopHeader x then + WasmLoop fty <$> codeForX loopContext + else + codeForX context + where selectedChildren = case lastNode x of + CmmSwitch {} -> children + -- N.B. Unlike `if`, translation of Switch uses only labels. + _ -> filter hasMergeRoot children + loopContext = LoopHeadedBy (entryLabel x) `inside` context + hasMergeRoot = isMergeNode . Tree.rootLabel + + nodeWithin fty x (y_n:ys) (Just zlabel) context = + WasmBlock fty <$> nodeWithin fty x (y_n:ys) Nothing context' + where context' = BlockFollowedBy zlabel `inside` context + nodeWithin fty x (y_n:ys) Nothing context = + nodeWithin doesn'tReturn x ys (Just ylabel) (context `withFallthrough` ylabel) <<>> + doTree fty y_n context + where ylabel = treeEntryLabel y_n + nodeWithin fty x [] (Just zlabel) context + | not (generatesIf x) = + WasmBlock fty <$> nodeWithin fty x [] Nothing context' + where context' = BlockFollowedBy zlabel `inside` context + nodeWithin fty x [] maybeMarks context = + translationOfX context + where xlabel = entryLabel x + + translationOfX :: Context -> m (WasmControl stmt expr '[] post) + translationOfX context = + (WasmActions <$> txBlock xlabel (nodeBody x)) <<>> + case flowLeaving platform x of + Unconditional l -> doBranch fty xlabel l context + Conditional e t f -> + WasmIf fty + <$> txExpr xlabel e + <*> doBranch fty xlabel t (IfThenElse maybeMarks `inside` context) + <*> doBranch fty xlabel f (IfThenElse maybeMarks `inside` context) + TailCall e -> WasmTailCall <$> txExpr xlabel e + Switch e range targets default' -> + WasmBrTable <$> txExpr xlabel e + <$~> range + <$~> map switchIndex targets + <$~> switchIndex default' + where switchIndex :: Maybe Label -> Int + switchIndex Nothing = 0 -- arbitrary; GHC won't go here + switchIndex (Just lbl) = index lbl (enclosing context) + + doBranch fty from to context + | to `elem` fallthrough context && emptyPost fty = pure WasmFallthrough + -- optimization: `br` is not needed, but it typechecks + -- only if nothing is expected to be left on the stack + + | isBackward from to = pure $ WasmBr i -- continue + | isMergeLabel to = pure $ WasmBr i -- exit + | otherwise = doTree fty (subtreeAt to) context -- inline the code here + where i = index to (enclosing context) + + generatesIf :: CmmBlock -> Bool + generatesIf x = case flowLeaving platform x of Conditional {} -> True + _ -> False + + ---- everything else is utility functions + + treeEntryLabel :: Tree.Tree CmmBlock -> Label + treeEntryLabel = entryLabel . Tree.rootLabel + + sortTree :: Tree.Tree Label -> Tree.Tree Label + -- Sort highest rpnum first + sortTree (Tree.Node label children) = + Tree.Node label $ sortBy (flip compare `on` (rpnum . Tree.rootLabel)) $ + map sortTree children + + subtreeAt :: Label -> Tree.Tree CmmBlock + blockLabeled :: Label -> CmmBlock + rpnum :: Label -> RPNum-- reverse postorder number of the labeled block + isMergeLabel :: Label -> Bool + isMergeNode :: CmmBlock -> Bool + isLoopHeader :: CmmBlock -> Bool-- identify loop headers + -- all nodes whose immediate dominator is the given block. + -- They are produced with the largest RP number first, + -- so the largest RP number is pushed on the context first. + dominates :: Label -> Label -> Bool + -- Domination relation (not just immediate domination) + + blockmap :: LabelMap CmmBlock + GMany NothingO blockmap NothingO = g_graph g + + blockLabeled l = findLabelIn l blockmap + + rpblocks :: [CmmBlock] + rpblocks = revPostorderFrom blockmap (g_entry g) + + foldEdges :: forall a . (Label -> Label -> a -> a) -> a -> a + foldEdges f a = + foldl (\a (from, to) -> f from to a) + a + [(entryLabel from, to) | from <- rpblocks, to <- successors from] + + isMergeLabel l = setMember l mergeBlockLabels + isMergeNode = isMergeLabel . entryLabel + + isBackward :: Label -> Label -> Bool + isBackward from to = rpnum to <= rpnum from -- self-edge counts as a backward edge + + subtreeAt label = findLabelIn label subtrees + subtrees :: LabelMap (Tree.Tree CmmBlock) + subtrees = addSubtree mapEmpty dominatorTree + where addSubtree map t@(Tree.Node root children) = + foldl addSubtree (mapInsert (entryLabel root) t map) children + + mergeBlockLabels :: LabelSet + -- N.B. A block is a merge node if it is where control flow merges. + -- That means it is entered by multiple control-flow edges, _except_ + -- back edges don't count. There must be multiple paths that enter the + -- block _without_ passing through the block itself. + mergeBlockLabels = + setFromList [entryLabel n | n <- rpblocks, big (forwardPreds (entryLabel n))] + where big [] = False + big [_] = False + big (_ : _ : _) = True + + forwardPreds :: Label -> [Label] -- reachable predecessors of reachable blocks, + -- via forward edges only + forwardPreds = \l -> mapFindWithDefault [] l predmap + where predmap :: LabelMap [Label] + predmap = foldEdges addForwardEdge mapEmpty + addForwardEdge from to pm + | isBackward from to = pm + | otherwise = addToList (from :) to pm + + isLoopHeader = isHeaderLabel . entryLabel + isHeaderLabel = (`setMember` headers) -- loop headers + where headers :: LabelSet + headers = foldMap headersPointedTo blockmap + headersPointedTo block = + setFromList [label | label <- successors block, + dominates label (entryLabel block)] + + index :: Label -> [ContainingSyntax] -> Int + index _ [] = panic "destination label not in evaluation context" + index label (frame : context) + | label `matchesFrame` frame = 0 + | otherwise = 1 + index label context + + rpnum = gwdRPNumber gwd + dominates lbl blockname = + lbl == blockname || dominatorsMember lbl (gwdDominatorsOf gwd blockname) + + doTree returns dominatorTree emptyContext + +nodeBody :: CmmBlock -> CmmActions +nodeBody (BlockCC _first middle _last) = middle + +-- | A CmmSwitch scrutinee may have any width, but a br_table operand +-- must be exactly word sized, hence the extension here. (#22871) +smartExtend :: Platform -> CmmExpr -> CmmExpr +smartExtend p e | w0 == w1 = e + | otherwise = CmmMachOp (MO_UU_Conv w0 w1) [e] + where + w0 = cmmExprWidth p e + w1 = wordWidth p + +smartPlus :: Platform -> CmmExpr -> Int -> CmmExpr +smartPlus _ e 0 = e +smartPlus platform e k = + CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger k) width)] + where width = cmmExprWidth platform e + +addToList :: ([a] -> [a]) -> Label -> LabelMap [a] -> LabelMap [a] +addToList consx = mapAlter add + where add Nothing = Just (consx []) + add (Just xs) = Just (consx xs) + +------------------------------------------------------------------ +--- everything below here is for diagnostics in case of panic + +instance Outputable ContainingSyntax where + ppr (BlockFollowedBy l) = text "node" <+> ppr l + ppr (LoopHeadedBy l) = text "loop" <+> ppr l + ppr (IfThenElse l) = text "if-then-else" <+> ppr l + +findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a +findLabelIn lbl = mapFindWithDefault failed lbl + where failed = + pprPanic "label not found in control-flow graph" (ppr lbl) + + +infixl 4 <$~> +(<$~>) :: Functor m => m (a -> b) -> a -> m b +(<$~>) f x = fmap ($ x) f + +(<<>>) :: forall m s e pre mid post + . Applicative m + => m (WasmControl s e pre mid) + -> m (WasmControl s e mid post) + -> m (WasmControl s e pre post) +(<<>>) = liftA2 (<>) diff --git a/HsVersions.h b/HsVersions.h deleted file mode 100644 --- a/HsVersions.h +++ /dev/null @@ -1,69 +0,0 @@ -#ifndef HSVERSIONS_H -#define HSVERSIONS_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 - -/* Useful in the headers that we share with the RTS */ -#define COMPILING_GHC 1 - -/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */ -#include "ghc_boot_platform.h" - -/* Pull in the autoconf defines (HAVE_FOO), but don't include - * ghcconfig.h, because that will include ghcplatform.h which has the - * wrong platform settings for the compiler (it has the platform - * settings for the target plat instead). */ -#include "ghcautoconf.h" - -#define GLOBAL_VAR(name,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = Util.global (value); - -#define GLOBAL_VAR_M(name,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = Util.globalM (value); - - -#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = Util.sharedGlobal (value) (accessor); \ -foreign import ccall unsafe saccessor \ - accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); - -#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = Util.sharedGlobalM (value) (accessor); \ -foreign import ccall unsafe saccessor \ - accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); - - -#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else -#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else -#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $ - --- Examples: Assuming flagSet :: String -> m Bool --- --- do { c <- getChar; MASSERT( isUpper c ); ... } --- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... } --- do { str <- getStr; ASSERTM( flagSet str ); .. } --- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. } --- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. } -#define MASSERT(e) ASSERT(e) return () -#define MASSERT2(e,msg) ASSERT2(e,msg) return () -#define ASSERTM(e) do { bool <- e; MASSERT(bool) } -#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) } -#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () } - -#endif /* HsVersions.h */ - diff --git a/Language/Haskell/Syntax.hs b/Language/Haskell/Syntax.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax.hs @@ -0,0 +1,87 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{Haskell abstract syntax definition} + +This module glues together the pieces of the Haskell abstract syntax, +which is declared in the various \tr{Hs*} modules. This module, +therefore, is almost nothing but re-exporting. +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension +-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* +module Language.Haskell.Syntax ( + module Language.Haskell.Syntax.Binds, + module Language.Haskell.Syntax.Decls, + module Language.Haskell.Syntax.Expr, + module Language.Haskell.Syntax.ImpExp, + module Language.Haskell.Syntax.Lit, + module Language.Haskell.Syntax.Module.Name, + module Language.Haskell.Syntax.Pat, + module Language.Haskell.Syntax.Type, + module Language.Haskell.Syntax.Extension, + ModuleName(..), HsModule(..) +) where + +import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Binds +import Language.Haskell.Syntax.Expr +import Language.Haskell.Syntax.ImpExp +import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.Lit +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Pat +import Language.Haskell.Syntax.Type + +import Data.Maybe (Maybe) + +{- +Note [Language.Haskell.Syntax.* Hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Why are these modules not 'GHC.Hs.*', or some other 'GHC.*'? The answer +is that they are to be separated from GHC and put into another package, +in accordance with the final goals of Trees That Grow. (See Note [Trees +That Grow] in 'Language.Haskell.Syntax.Extension'.) In short, the +'Language.Haskell.Syntax.*' tree should be entirely GHC-independent. +GHC-specific stuff related to source-language syntax should be in +'GHC.Hs.*'. + +We cannot move them to the separate package yet, but by giving them +names like so, we hope to remind others that the goal is to factor them +out, and therefore dependencies on the rest of GHC should never be +added, only removed. + +For more details, see +https://gitlab.haskell.org/ghc/ghc/-/wikis/implementing-trees-that-grow +-} + +-- | Haskell Module +-- +-- All we actually declare here is the top-level structure for a module. +data HsModule p + = HsModule { + hsmodExt :: XCModule p, + -- ^ HsModule extension point + hsmodName :: Maybe (XRec p ModuleName), + -- ^ @Nothing@: \"module X where\" is omitted (in which case the next + -- field is Nothing too) + hsmodExports :: Maybe (XRec p [LIE p]), + -- ^ Export list + -- + -- - @Nothing@: export list omitted, so export everything + -- + -- - @Just []@: export /nothing/ + -- + -- - @Just [...]@: as you would expect... + hsmodImports :: [LImportDecl p], + hsmodDecls :: [LHsDecl p] + -- ^ Type, class, value, and interface signature decls + } + | XModule !(XXModule p) diff --git a/Language/Haskell/Syntax/Basic.hs b/Language/Haskell/Syntax/Basic.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Basic.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +module Language.Haskell.Syntax.Basic where + +import Data.Data (Data) +import Data.Eq +import Data.Ord +import Data.Bool +import Prelude + +import GHC.Data.FastString (FastString) +import Control.DeepSeq + +{- +************************************************************************ +* * +Boxity +* * +************************************************************************ +-} + +data Boxity + = Boxed + | Unboxed + deriving( Eq, Data ) + +isBoxed :: Boxity -> Bool +isBoxed Boxed = True +isBoxed Unboxed = False + +{- +************************************************************************ +* * +Counts and indices +* * +************************************************************************ +-} + +-- | The width of an unboxed sum +type SumWidth = Int + +-- | A *one-index* constructor tag +-- +-- Type of the tags associated with each constructor possibility or superclass +-- selector +type ConTag = Int + +{- +************************************************************************ +* * +Field Labels +* * +************************************************************************ +-} + +-- | Field labels are just represented as strings; +-- they are not necessarily unique (even within a module) +newtype FieldLabelString = FieldLabelString { field_label:: FastString } + deriving (Data, Eq, NFData) + +{- +************************************************************************ +* * +Field Labels +* * +************************************************************************ +-} + +-- | See Note [Roles] in GHC.Core.Coercion +-- +-- Order of constructors matters: the Ord instance coincides with the *super*typing +-- relation on roles. +data Role = Nominal | Representational | Phantom + deriving (Eq, Ord, Data) + +{- +************************************************************************ +* * +Source Strictness and Unpackedness +* * +************************************************************************ +-} + +-- | Source Strictness +-- +-- What strictness annotation the user wrote +data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' + | SrcStrict -- ^ Strict, ie '!' + | NoSrcStrict -- ^ no strictness annotation + deriving (Eq, Data) + +-- | Source Unpackedness +-- +-- What unpackedness the user requested +data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified + | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified + | NoSrcUnpack -- ^ no unpack pragma + deriving (Eq, Data) + +{- +************************************************************************ +* * +Fixity +* * +************************************************************************ +-} + +-- | Captures the fixity of declarations as they are parsed. This is not +-- necessarily the same as the fixity declaration, as the normal fixity may be +-- overridden using parens or backticks. +data LexicalFixity = Prefix | Infix deriving (Eq, Data) + +data FixityDirection + = InfixL + | InfixR + | InfixN + deriving (Eq, Data) + +instance NFData FixityDirection where + rnf InfixL = () + rnf InfixR = () + rnf InfixN = () + +data Fixity = Fixity Int FixityDirection + deriving (Eq, Data) + +instance NFData Fixity where + rnf (Fixity i d) = rnf i `seq` rnf d `seq` () diff --git a/Language/Haskell/Syntax/Binds.hs b/Language/Haskell/Syntax/Binds.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Binds.hs @@ -0,0 +1,543 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension +{-# LANGUAGE ViewPatterns #-} + + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[HsBinds]{Abstract syntax: top-level bindings and signatures} + +Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. +-} + +-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* +module Language.Haskell.Syntax.Binds where + +import {-# SOURCE #-} Language.Haskell.Syntax.Expr + ( LHsExpr + , MatchGroup + , GRHSs ) +import {-# SOURCE #-} Language.Haskell.Syntax.Pat( LPat ) +import Language.Haskell.Syntax.BooleanFormula (LBooleanFormula) +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Type +import Language.Haskell.Syntax.Basic ( Fixity ) + +import GHC.Types.Basic (InlinePragma) +import GHC.Types.SourceText (StringLiteral) + +import Data.Bool +import Data.Maybe + +{- +************************************************************************ +* * +\subsection{Bindings: @BindGroup@} +* * +************************************************************************ + +Global bindings (where clauses) +-} + +-- During renaming, we need bindings where the left-hand sides +-- have been renamed but the right-hand sides have not. +-- Other than during renaming, these will be the same. + +-- | Haskell Local Bindings +type HsLocalBinds id = HsLocalBindsLR id id + +-- | Located Haskell local bindings +type LHsLocalBinds id = XRec id (HsLocalBinds id) + +-- | Haskell Local Bindings with separate Left and Right identifier types +-- +-- Bindings in a 'let' expression +-- or a 'where' clause +data HsLocalBindsLR idL idR + = HsValBinds + (XHsValBinds idL idR) + (HsValBindsLR idL idR) + -- ^ Haskell Value Bindings + + -- There should be no pattern synonyms in the HsValBindsLR + -- These are *local* (not top level) bindings + -- The parser accepts them, however, leaving the + -- renamer to report them + + | HsIPBinds + (XHsIPBinds idL idR) + (HsIPBinds idR) + -- ^ Haskell Implicit Parameter Bindings + + | EmptyLocalBinds (XEmptyLocalBinds idL idR) + -- ^ Empty Local Bindings + + | XHsLocalBindsLR + !(XXHsLocalBindsLR idL idR) + +type LHsLocalBindsLR idL idR = XRec idL (HsLocalBindsLR idL idR) + + +-- | Haskell Value Bindings +type HsValBinds id = HsValBindsLR id id + +-- | Haskell Value bindings with separate Left and Right identifier types +-- (not implicit parameters) +-- Used for both top level and nested bindings +-- May contain pattern synonym bindings +data HsValBindsLR idL idR + = -- | Value Bindings In + -- + -- Before renaming RHS; idR is always RdrName + -- Not dependency analysed + -- Recursive by default + ValBinds + (XValBinds idL idR) + (LHsBindsLR idL idR) [LSig idR] + + -- | Value Bindings Out + -- + -- After renaming RHS; idR can be Name or Id Dependency analysed, + -- later bindings in the list may depend on earlier ones. + | XValBindsLR + !(XXValBindsLR idL idR) + +-- --------------------------------------------------------------------- + +-- | Located Haskell Binding +type LHsBind id = LHsBindLR id id + +-- | Located Haskell Bindings +type LHsBinds id = LHsBindsLR id id + +-- | Haskell Binding +type HsBind id = HsBindLR id id + +-- | Located Haskell Bindings with separate Left and Right identifier types +type LHsBindsLR idL idR = [LHsBindLR idL idR] + +-- | Located Haskell Binding with separate Left and Right identifier types +type LHsBindLR idL idR = XRec idL (HsBindLR idL idR) + +{- Note [FunBind vs PatBind] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +The distinction between FunBind and PatBind is a bit subtle. FunBind covers +patterns which resemble function bindings and simple variable bindings. + + f x = e + f !x = e + f = e + !x = e -- FunRhs has SrcStrict + x `f` y = e -- FunRhs has Infix + +The actual patterns and RHSs of a FunBind are encoding in fun_matches. +The m_ctxt field of each Match in fun_matches will be FunRhs and carries +two bits of information about the match, + + * The mc_fixity field on each Match describes the fixity of the + function binder in that match. E.g. this is legal: + f True False = e1 + True `f` True = e2 + + * The mc_strictness field is used /only/ for nullary FunBinds: ones + with one Match, which has no pats. For these, it describes whether + the match is decorated with a bang (e.g. `!x = e`). + +By contrast, PatBind represents data constructor patterns, as well as a few +other interesting cases. Namely, + + Just x = e + (x) = e + x :: Ty = e + +Note [Multiplicity annotations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Multiplicity annotations are stored in the pat_mult field on PatBinds, +represented by the HsMultAnn data type + + HsNoMultAnn <=> no annotation in the source file + HsPct1Ann <=> the %1 annotation + HsMultAnn <=> the %t annotation, where `t` is some type + +In case of HsNoMultAnn the typechecker infers a multiplicity. + +We don't need to store a multiplicity on FunBinds: +- let %1 x = … is parsed as a PatBind. So we don't need an annotation before + typechecking. +- the multiplicity that the typechecker infers is stored in the binder's Var for + the desugarer to use. It's only relevant for strict FunBinds, see Wrinkle 1 in + Note [Desugar Strict binds] in GHC.HsToCore.Binds as, in Core, let expressions + don't have multiplicity annotations. +-} + +-- | Haskell Binding with separate Left and Right id's +data HsBindLR idL idR + = -- | Function-like Binding + -- + -- FunBind is used for both functions @f x = e@ + -- and variables @f = \x -> e@ + -- and strict variables @!x = x + 1@ + -- + -- Reason 1: Special case for type inference: see 'GHC.Tc.Gen.Bind.tcMonoBinds'. + -- + -- Reason 2: Instance decls can only have FunBinds, which is convenient. + -- If you change this, you'll need to change e.g. rnMethodBinds + -- + -- But note that the form @f :: a->a = ...@ + -- parses as a pattern binding, just like + -- @(f :: a -> a) = ... @ + -- + -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their + -- 'MatchContext'. See Note [FunBind vs PatBind] for + -- details about the relationship between FunBind and PatBind. + FunBind { + + fun_ext :: XFunBind idL idR, + + fun_id :: LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr + + fun_matches :: MatchGroup idR (LHsExpr idR) -- ^ The payload + + } + + -- | Pattern Binding + -- + -- The pattern is never a simple variable; + -- That case is done by FunBind. + -- See Note [FunBind vs PatBind] for details about the + -- relationship between FunBind and PatBind. + | PatBind { + pat_ext :: XPatBind idL idR, + pat_lhs :: LPat idL, + pat_mult :: HsMultAnn idL, + -- ^ See Note [Multiplicity annotations]. + pat_rhs :: GRHSs idR (LHsExpr idR) + } + + -- | Variable Binding + -- + -- Dictionary binding and suchlike. + -- All VarBinds are introduced by the type checker + | VarBind { + var_ext :: XVarBind idL idR, + var_id :: IdP idL, + var_rhs :: LHsExpr idR -- ^ Located only for consistency + } + + -- | Patterns Synonym Binding + | PatSynBind + (XPatSynBind idL idR) + (PatSynBind idL idR) + + | XHsBindsLR !(XXHsBindsLR idL idR) + + +-- | Pattern Synonym binding +data PatSynBind idL idR + = PSB { psb_ext :: XPSB idL idR, + psb_id :: LIdP idL, -- ^ Name of the pattern synonym + psb_args :: HsPatSynDetails idR, -- ^ Formal parameter names + psb_def :: LPat idR, -- ^ Right-hand side + psb_dir :: HsPatSynDir idR -- ^ Directionality + } + | XPatSynBind !(XXPatSynBind idL idR) + +{- +************************************************************************ +* * + Implicit parameter bindings +* * +************************************************************************ +-} + +-- | Haskell Implicit Parameter Bindings +data HsIPBinds id + = IPBinds + (XIPBinds id) + [LIPBind id] + -- TcEvBinds -- Only in typechecker output; binds + -- -- uses of the implicit parameters + | XHsIPBinds !(XXHsIPBinds id) + + +-- | Located Implicit Parameter Binding +type LIPBind id = XRec id (IPBind id) + +-- | Implicit parameter bindings. +data IPBind id + = IPBind + (XCIPBind id) + (XRec id HsIPName) + (LHsExpr id) + | XIPBind !(XXIPBind id) + +{- +************************************************************************ +* * +\subsection{@Sig@: type signatures and value-modifying user pragmas} +* * +************************************************************************ + +It is convenient to lump ``value-modifying'' user-pragmas (e.g., +``specialise this function to these four types...'') in with type +signatures. Then all the machinery to move them into place, etc., +serves for both. +-} + +-- | Located Signature +type LSig pass = XRec pass (Sig pass) + +-- | Signatures and pragmas +data Sig pass + = -- | An ordinary type signature + -- + -- > f :: Num a => a -> a + -- + -- After renaming, this list of Names contains the named + -- wildcards brought into scope by this signature. For a signature + -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@ + -- untouched, and the named wildcard @_a@ is then replaced with + -- fresh meta vars in the type. Their names are stored in the type + -- signature that brought them into scope, in this third field to be + -- more specific. + TypeSig + (XTypeSig pass) + [LIdP pass] -- LHS of the signature; e.g. f,g,h :: blah + (LHsSigWcType pass) -- RHS of the signature; can have wildcards + + -- | A pattern synonym type signature + -- + -- > pattern Single :: () => (Show a) => a -> [a] + | PatSynSig (XPatSynSig pass) [LIdP pass] (LHsSigType pass) + -- P :: forall a b. Req => Prov => ty + + -- | A signature for a class method + -- False: ordinary class-method signature + -- True: generic-default class method signature + -- e.g. class C a where + -- op :: a -> a -- Ordinary + -- default op :: Eq a => a -> a -- Generic default + -- No wildcards allowed here + | ClassOpSig (XClassOpSig pass) Bool [LIdP pass] (LHsSigType pass) + + -- | An ordinary fixity declaration + -- + -- > infixl 8 *** + | FixSig (XFixSig pass) (FixitySig pass) + + -- | An inline pragma + -- + -- > {#- INLINE f #-} + | InlineSig (XInlineSig pass) + (LIdP pass) -- Function name + InlinePragma -- Never defaultInlinePragma + + -- | An old-form specialisation pragma + -- + -- > {-# SPECIALISE f :: Int -> Int #-} + -- + -- NB: this constructor is deprecated and will be removed in GHC 9.18 (#25540) + | SpecSig (XSpecSig pass) + (LIdP pass) -- Specialise a function or datatype ... + [LHsSigType pass] -- ... to these types + InlinePragma -- The pragma on SPECIALISE_INLINE form. + -- If it's just defaultInlinePragma, then we said + -- SPECIALISE, not SPECIALISE_INLINE + + -- | A new-form specialisation pragma (see GHC Proposal #493) + -- e.g. {-# SPECIALISE f @Int 1 :: Int -> Int #-} + -- See Note [Overview of SPECIALISE pragmas] + | SpecSigE (XSpecSigE pass) + (RuleBndrs pass) + (LHsExpr pass) -- Expression to specialise + InlinePragma + -- The expression should be of form + -- f a1 ... an [ :: sig ] + -- with an optional type signature + + -- | A specialisation pragma for instance declarations only + -- + -- > {-# SPECIALISE instance Eq [Int] #-} + -- + -- (Class tys); should be a specialisation of the + -- current instance declaration + | SpecInstSig (XSpecInstSig pass) (LHsSigType pass) + + -- | A minimal complete definition pragma + -- + -- > {-# MINIMAL a | (b, c | (d | e)) #-} + | MinimalSig (XMinimalSig pass) (LBooleanFormula pass) + + -- | A "set cost centre" pragma for declarations + -- + -- > {-# SCC funName #-} + -- + -- or + -- + -- > {-# SCC funName "cost_centre_name" #-} + + | SCCFunSig (XSCCFunSig pass) + (LIdP pass) -- Function name + (Maybe (XRec pass StringLiteral)) + -- | A complete match pragma + -- + -- > {-# COMPLETE C, D [:: T] #-} + -- + -- Used to inform the pattern match checker about additional + -- complete matchings which, for example, arise from pattern + -- synonym definitions. + | CompleteMatchSig (XCompleteMatchSig pass) + [LIdP pass] + (Maybe (LIdP pass)) + | XSig !(XXSig pass) + +-- | Located Fixity Signature +type LFixitySig pass = XRec pass (FixitySig pass) + +-- | Fixity Signature +data FixitySig pass = FixitySig (XFixitySig pass) [LIdP pass] Fixity + | XFixitySig !(XXFixitySig pass) + +isFixityLSig :: forall p. UnXRec p => LSig p -> Bool +isFixityLSig (unXRec @p -> FixSig {}) = True +isFixityLSig _ = False + +isTypeLSig :: forall p. UnXRec p => LSig p -> Bool -- Type signatures +isTypeLSig (unXRec @p -> TypeSig {}) = True +isTypeLSig (unXRec @p -> ClassOpSig {}) = True +isTypeLSig (unXRec @p -> XSig {}) = True +isTypeLSig _ = False + +isSpecLSig :: forall p. UnXRec p => LSig p -> Bool +isSpecLSig (unXRec @p -> SpecSig {}) = True +isSpecLSig (unXRec @p -> SpecSigE {}) = True +isSpecLSig _ = False + +isSpecInstLSig :: forall p. UnXRec p => LSig p -> Bool +isSpecInstLSig (unXRec @p -> SpecInstSig {}) = True +isSpecInstLSig _ = False + +isPragLSig :: forall p. UnXRec p => LSig p -> Bool +-- Identifies pragmas +isPragLSig (unXRec @p -> SpecSig {}) = True +isPragLSig (unXRec @p -> SpecSigE {}) = True +isPragLSig (unXRec @p -> InlineSig {}) = True +isPragLSig (unXRec @p -> SCCFunSig {}) = True +isPragLSig (unXRec @p -> CompleteMatchSig {}) = True +isPragLSig _ = False + +isInlineLSig :: forall p. UnXRec p => LSig p -> Bool +-- Identifies inline pragmas +isInlineLSig (unXRec @p -> InlineSig {}) = True +isInlineLSig _ = False + +isMinimalLSig :: forall p. UnXRec p => LSig p -> Bool +isMinimalLSig (unXRec @p -> MinimalSig {}) = True +isMinimalLSig _ = False + +isSCCFunSig :: forall p. UnXRec p => LSig p -> Bool +isSCCFunSig (unXRec @p -> SCCFunSig {}) = True +isSCCFunSig _ = False + +isCompleteMatchSig :: forall p. UnXRec p => LSig p -> Bool +isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True +isCompleteMatchSig _ = False + +{- ********************************************************************* +* * + Rule binders +* * +********************************************************************* -} + +data RuleBndrs pass = RuleBndrs + { rb_ext :: XCRuleBndrs pass + -- After typechecking rb_ext contains /all/ the quantified variables + -- both term variables and type varibles + , rb_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)] + -- ^ User-written forall'd type vars; preserved for pretty-printing + , rb_tmvs :: [LRuleBndr (NoGhcTc pass)] + -- ^ User-written forall'd term vars; preserved for pretty-printing + } + | XRuleBndrs !(XXRuleBndrs pass) + +-- | Located Rule Binder +type LRuleBndr pass = XRec pass (RuleBndr pass) + +-- | Rule Binder +data RuleBndr pass + = RuleBndr (XCRuleBndr pass) (LIdP pass) + | RuleBndrSig (XRuleBndrSig pass) (LIdP pass) (HsPatSigType pass) + | XRuleBndr !(XXRuleBndr pass) + -- ^ + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose' + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + +collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass] +collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] + +{- +************************************************************************ +* * +\subsection[PatSynBind]{A pattern synonym definition} +* * +************************************************************************ +-} + +-- | Haskell Pattern Synonym Details +type HsPatSynDetails pass = HsConDetails (LIdP pass) [RecordPatSynField pass] + +-- See Note [Record PatSyn Fields] +-- | Record Pattern Synonym Field +data RecordPatSynField pass + = RecordPatSynField + { recordPatSynField :: FieldOcc pass + -- ^ Field label visible in rest of the file + , recordPatSynPatVar :: LIdP pass + -- ^ Filled in by renamer, the name used internally by the pattern + } + + +{- +Note [Record PatSyn Fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider the following two pattern synonyms. + + pattern P x y = ([x,True], [y,'v']) + pattern Q{ x, y } =([x,True], [y,'v']) + +In P, we just have two local binders, x and y. + +In Q, we have local binders but also top-level record selectors + x :: ([Bool], [Char]) -> Bool + y :: ([Bool], [Char]) -> Char + +Both are recorded in the `RecordPatSynField`s for `x` and `y`: +* recordPatSynField: the top-level record selector +* recordPatSynPatVar: the local `x`, bound only in the RHS of the pattern synonym. + +It would make sense to support record-like syntax + + pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) + +when we have a different name for the local and top-level binder, +making the distinction between the two names clear. + +-} + +-- | Haskell Pattern Synonym Direction +data HsPatSynDir id + = Unidirectional + | ImplicitBidirectional + | ExplicitBidirectional (MatchGroup id (LHsExpr id)) diff --git a/Language/Haskell/Syntax/BooleanFormula.hs b/Language/Haskell/Syntax/BooleanFormula.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/BooleanFormula.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE QuantifiedConstraints #-} + +module Language.Haskell.Syntax.BooleanFormula( + BooleanFormula(..), LBooleanFormula, + mkVar, mkFalse, mkTrue, mkBool, mkAnd, mkOr + ) where + +import Prelude hiding ( init, last ) +import Data.List ( nub ) +import Language.Haskell.Syntax.Extension (XRec, UnXRec (..), LIdP) + + +-- types +type LBooleanFormula p = XRec p (BooleanFormula p) +data BooleanFormula p = Var (LIdP p) | And [LBooleanFormula p] | Or [LBooleanFormula p] + | Parens (LBooleanFormula p) + +-- instances +deriving instance (Eq (LIdP p), Eq (LBooleanFormula p)) => Eq (BooleanFormula p) + +-- smart constructors +-- see note [Simplification of BooleanFormulas] +mkVar :: LIdP p -> BooleanFormula p +mkVar = Var + +mkFalse, mkTrue :: BooleanFormula p +mkFalse = Or [] +mkTrue = And [] + +-- Convert a Bool to a BooleanFormula +mkBool :: Bool -> BooleanFormula p +mkBool False = mkFalse +mkBool True = mkTrue + +-- Make a conjunction, and try to simplify +mkAnd :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p +mkAnd = maybe mkFalse (mkAnd' . nub . concat) . mapM fromAnd + where + -- See Note [Simplification of BooleanFormulas] + fromAnd :: LBooleanFormula p -> Maybe [LBooleanFormula p] + fromAnd bf = case unXRec @p bf of + (And xs) -> Just xs + -- assume that xs are already simplified + -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs + (Or []) -> Nothing + -- in case of False we bail out, And [..,mkFalse,..] == mkFalse + _ -> Just [bf] + mkAnd' [x] = unXRec @p x + mkAnd' xs = And xs + +mkOr :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p +mkOr = maybe mkTrue (mkOr' . nub . concat) . mapM fromOr + where + -- See Note [Simplification of BooleanFormulas] + fromOr bf = case unXRec @p bf of + (Or xs) -> Just xs + (And []) -> Nothing + _ -> Just [bf] + mkOr' [x] = unXRec @p x + mkOr' xs = Or xs diff --git a/Language/Haskell/Syntax/Decls.hs b/Language/Haskell/Syntax/Decls.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Decls.hs @@ -0,0 +1,1593 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension +{-# LANGUAGE ViewPatterns #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/@type@AQUA Project, Glasgow University, 1992-1998 +-} + +-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* + +-- | Abstract syntax of global declarations. +-- +-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, +-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. +module Language.Haskell.Syntax.Decls ( + -- * Toplevel declarations + HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..), + HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, + NewOrData(..), DataDefnCons(..), dataDefnConsNewOrData, + isTypeDataDefnCons, firstDataDefnCon, + StandaloneKindSig(..), LStandaloneKindSig, + + -- ** Class or type declarations + TyClDecl(..), LTyClDecl, + TyClGroup(..), + isClassDecl, isDataDecl, isSynDecl, + isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, + isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, + FamilyDecl(..), LFamilyDecl, + + -- ** Instance declarations + InstDecl(..), LInstDecl, FamilyInfo(..), familyInfoTyConFlavour, + TyFamInstDecl(..), LTyFamInstDecl, + TyFamDefltDecl, LTyFamDefltDecl, + DataFamInstDecl(..), LDataFamInstDecl, + FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsFamEqnPats, + LClsInstDecl, ClsInstDecl(..), + + -- ** Standalone deriving declarations + DerivDecl(..), LDerivDecl, + -- ** Deriving strategies + DerivStrategy(..), LDerivStrategy, + -- ** @RULE@ declarations + LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl, + RuleBndr(..),LRuleBndr, + collectRuleBndrSigTys, + -- ** @default@ declarations + DefaultDecl(..), LDefaultDecl, + -- ** Template haskell declaration splice + SpliceDecoration(..), + SpliceDecl(..), LSpliceDecl, + -- ** Foreign function interface declarations + ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), + CImportSpec(..), + -- ** Data-constructor declarations + ConDecl(..), LConDecl, + HsConDeclH98Details, + HsConDeclGADTDetails(..), XPrefixConGADT, XRecConGADT, XXConDeclGADTDetails, + -- ** Document comments + DocDecl(..), LDocDecl, docDeclDoc, + -- ** Deprecations + WarnDecl(..), LWarnDecl, + WarnDecls(..), LWarnDecls, + -- ** Annotations + AnnDecl(..), LAnnDecl, + AnnProvenance(..), annProvenanceName_maybe, + -- ** Role annotations + RoleAnnotDecl(..), LRoleAnnotDecl, + -- ** Injective type families + FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn, + + -- * Grouping + HsGroup(..) + ) where + +-- friends: +import {-# SOURCE #-} Language.Haskell.Syntax.Expr + ( HsExpr, HsUntypedSplice ) + -- Because Expr imports Decls via HsBracket + +import Language.Haskell.Syntax.Binds +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Type +import Language.Haskell.Syntax.Basic (Role, LexicalFixity) +import Language.Haskell.Syntax.Specificity (Specificity) + +import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation + ,TyConFlavour(..), TypeOrData(..), NewOrData(..)) +import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) + +import GHC.Unit.Module.Warnings (WarningTxt) + +import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST + +import Control.Monad +import Control.Exception (assert) +import Data.Data hiding (TyCon, Fixity, Infix) +import Data.Maybe +import Data.String +import Data.Eq +import Data.Int +import Data.Bool +import Prelude (Show) +import Data.Foldable +import Data.Traversable +import Data.List.NonEmpty (NonEmpty (..)) + +{- +************************************************************************ +* * +\subsection[HsDecl]{Declarations} +* * +************************************************************************ +-} + +type LHsDecl p = XRec p (HsDecl p) + -- ^ When in a list this may have + +-- | A Haskell Declaration +data HsDecl p + = TyClD (XTyClD p) (TyClDecl p) -- ^ Type or Class Declaration + | InstD (XInstD p) (InstDecl p) -- ^ Instance declaration + | DerivD (XDerivD p) (DerivDecl p) -- ^ Deriving declaration + | ValD (XValD p) (HsBind p) -- ^ Value declaration + | SigD (XSigD p) (Sig p) -- ^ Signature declaration + | KindSigD (XKindSigD p) (StandaloneKindSig p) -- ^ Standalone kind signature + | DefD (XDefD p) (DefaultDecl p) -- ^ 'default' declaration + | ForD (XForD p) (ForeignDecl p) -- ^ Foreign declaration + | WarningD (XWarningD p) (WarnDecls p) -- ^ Warning declaration + | AnnD (XAnnD p) (AnnDecl p) -- ^ Annotation declaration + | RuleD (XRuleD p) (RuleDecls p) -- ^ Rule declaration + | SpliceD (XSpliceD p) (SpliceDecl p) -- ^ Splice declaration + -- (Includes quasi-quotes) + | DocD (XDocD p) (DocDecl p) -- ^ Documentation comment + -- declaration + | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration + | XHsDecl !(XXHsDecl p) + +{- +Note [Top-level fixity signatures in an HsGroup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An `HsGroup p` stores every top-level fixity declarations in one of two places: + +1. hs_fixds :: [LFixitySig p] + + This stores fixity signatures for top-level declarations (e.g., functions, + data constructors, classes, type families, etc.) as well as fixity + signatures for class methods written outside of the class, as in this + example: + + infixl 4 `m1` + class C1 a where + m1 :: a -> a -> a + +2. hs_tyclds :: [TyClGroup p] + + Each type class can be found in a TyClDecl inside a TyClGroup, and that + TyClDecl stores the fixity signatures for its methods written inside of the + class, as in this example: + + class C2 a where + infixl 4 `m2` + m2 :: a -> a -> a + +The story for fixity signatures for class methods is made slightly complicated +by the fact that they can appear both inside and outside of the class itself, +and both forms of fixity signatures are considered top-level. This matters +in `GHC.Rename.Module.rnSrcDecls`, which must create a fixity environment out +of all top-level fixity signatures before doing anything else. Therefore, +`rnSrcDecls` must be aware of both (1) and (2) above. The +`hsGroupTopLevelFixitySigs` function is responsible for collecting this +information from an `HsGroup`. + +One might wonder why we even bother separating top-level fixity signatures +into two places at all. That is, why not just take the fixity signatures +from `hs_tyclds` and put them into `hs_fixds` so that they are all in one +location? This ends up causing problems for `GHC.HsToCore.Quote.repTopDs`, +which translates each fixity signature in `hs_fixds` and `hs_tyclds` into a +Template Haskell `Dec`. If there are any duplicate signatures between the two +fields, this will result in an error (#17608). +-} + +-- | Haskell Group +-- +-- A 'HsDecl' is categorised into a 'HsGroup' before being +-- fed to the renamer. +data HsGroup p + = HsGroup { + hs_ext :: XCHsGroup p, + hs_valds :: HsValBinds p, + hs_splcds :: [LSpliceDecl p], + + hs_tyclds :: [TyClGroup p], + -- A list of mutually-recursive groups; + -- This includes `InstDecl`s as well; + -- Parser generates a singleton list; + -- renamer does dependency analysis + + hs_derivds :: [LDerivDecl p], + + hs_fixds :: [LFixitySig p], + -- A list of fixity signatures defined for top-level + -- declarations and class methods (defined outside of the class + -- itself). + -- See Note [Top-level fixity signatures in an HsGroup] + + hs_defds :: [LDefaultDecl p], + hs_fords :: [LForeignDecl p], + hs_warnds :: [LWarnDecls p], + hs_annds :: [LAnnDecl p], + hs_ruleds :: [LRuleDecls p], + + hs_docs :: [LDocDecl p] + } + | XHsGroup !(XXHsGroup p) + + +-- | Located Splice Declaration +type LSpliceDecl pass = XRec pass (SpliceDecl pass) + +-- | Splice Declaration +data SpliceDecl p + = SpliceDecl -- Top level splice + (XSpliceDecl p) + (XRec p (HsUntypedSplice p)) + SpliceDecoration -- Whether $( ) variant found, for pretty printing + | XSpliceDecl !(XXSpliceDecl p) + +-- | A splice can appear with various decorations wrapped around it. This data +-- type captures explicitly how it was originally written, for use in the pretty +-- printer. +data SpliceDecoration + = DollarSplice -- ^ $splice + | BareSplice -- ^ bare splice + deriving (Data, Eq, Show) + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ + +Note [The Naming story] +~~~~~~~~~~~~~~~~~~~~~~~ +Here is the story about the implicit names that go with type, class, +and instance decls. It's a bit tricky, so pay attention! + +"Implicit" (or "system") binders +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Each data type decl defines + a worker name for each constructor + to-T and from-T convertors + Each class decl defines + a tycon for the class + a data constructor for that tycon + the worker for that constructor + a selector for each superclass + +All have occurrence names that are derived uniquely from their parent +declaration. + +None of these get separate definitions in an interface file; they are +fully defined by the data or class decl. But they may *occur* in +interface files, of course. Any such occurrence must haul in the +relevant type or class decl. + +Plan of attack: + - Ensure they "point to" the parent data/class decl + when loading that decl from an interface file + (See RnHiFiles.getSysBinders) + + - When typechecking the decl, we build the implicit TyCons and Ids. + When doing so we look them up in the name cache (GHC.Rename.Env.lookupSysName), + to ensure correct module and provenance is set + +These are the two places that we have to conjure up the magic derived +names. (The actual magic is in GHC.Types.Name.Occurrence.mkWorkerOcc, etc.) + +Default methods +~~~~~~~~~~~~~~~ + - Occurrence name is derived uniquely from the method name + E.g. $dmmax + + - If there is a default method name at all, it's recorded in + the ClassOpSig (in GHC.Hs.Binds), in the DefMethInfo field. + (DefMethInfo is defined in GHC.Core.Class) + +Source-code class decls and interface-code class decls are treated subtly +differently, which has given me a great deal of confusion over the years. +Here's the deal. (We distinguish the two cases because source-code decls +have (Just binds) in the tcdMeths field, whereas interface decls have Nothing. + +In *source-code* class declarations: + + - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName + This is done by GHC.Parser.PostProcess.mkClassOpSigDM + + - The renamer renames it to a Name + + - During typechecking, we generate a binding for each $dm for + which there's a programmer-supplied default method: + class Foo a where + op1 :: + op2 :: + op1 = ... + We generate a binding for $dmop1 but not for $dmop2. + The Class for Foo has a Nothing for op2 and + a Just ($dm_op1, VanillaDM) for op1. + The Name for $dmop2 is simply discarded. + +In *interface-file* class declarations: + - When parsing, we see if there's an explicit programmer-supplied default method + because there's an '=' sign to indicate it: + class Foo a where + op1 = :: -- NB the '=' + op2 :: + We use this info to generate a DefMeth with a suitable RdrName for op1, + and a NoDefMeth for op2 + - The interface file has a separate definition for $dmop1, with unfolding etc. + - The renamer renames it to a Name. + - The renamer treats $dmop1 as a free variable of the declaration, so that + the binding for $dmop1 will be sucked in. (See RnHsSyn.tyClDeclFVs) + This doesn't happen for source code class decls, because they *bind* the default method. + +Dictionary functions +~~~~~~~~~~~~~~~~~~~~ +Each instance declaration gives rise to one dictionary function binding. + +The type checker makes up new source-code instance declarations +(e.g. from 'deriving' or generic default methods --- see +GHC.Tc.TyCl.Instance.tcInstDecls1). So we can't generate the names for +dictionary functions in advance (we don't know how many we need). + +On the other hand for interface-file instance declarations, the decl +specifies the name of the dictionary function, and it has a binding elsewhere +in the interface file: + instance {Eq Int} = dEqInt + dEqInt :: {Eq Int} + +So again we treat source code and interface file code slightly differently. + +Source code: + - Source code instance decls have a Nothing in the (Maybe name) field + (see data InstDecl below) + + - The typechecker makes up a Local name for the dict fun for any source-code + instance decl, whether it comes from a source-code instance decl, or whether + the instance decl is derived from some other construct (e.g. 'deriving'). + + - The occurrence name it chooses is derived from the instance decl (just for + documentation really) --- e.g. dNumInt. Two dict funs may share a common + occurrence name, but will have different uniques. E.g. + instance Foo [Int] where ... + instance Foo [Bool] where ... + These might both be dFooList + + - The CoreTidy phase externalises the name, and ensures the occurrence name is + unique (this isn't special to dict funs). So we'd get dFooList and dFooList1. + + - We can take this relaxed approach (changing the occurrence name later) + because dict fun Ids are not captured in a TyCon or Class (unlike default + methods, say). Instead, they are kept separately in the InstEnv. This + makes it easy to adjust them after compiling a module. (Once we've finished + compiling that module, they don't change any more.) + + +Interface file code: + - The instance decl gives the dict fun name, so the InstDecl has a (Just name) + in the (Maybe name) field. + + - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we + suck in the dfun binding +-} + +-- | Located Declaration of a Type or Class +type LTyClDecl pass = XRec pass (TyClDecl pass) + +-- | A type or class declaration. +data TyClDecl pass + = -- | @type/data family T :: *->*@ + FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass } + + | -- | @type@ declaration + SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renamer, FVs + , tcdLName :: LIdP pass -- ^ Type constructor + , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an + -- associated type these + -- include outer binders + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration + , tcdRhs :: LHsType pass } -- ^ RHS of type declaration + + | -- | @data@ declaration + DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs + , tcdLName :: LIdP pass -- ^ Type constructor + , tcdTyVars :: LHsQTyVars pass -- ^ Type variables + -- See Note [TyVar binders for associated decls] + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration + , tcdDataDefn :: HsDataDefn pass } + + | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs + tcdCtxt :: Maybe (LHsContext pass), -- ^ Context... + tcdLName :: LIdP pass, -- ^ Name of the class + tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables + tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration + tcdFDs :: [LHsFunDep pass], -- ^ Functional deps + tcdSigs :: [LSig pass], -- ^ Methods' signatures + tcdMeths :: LHsBinds pass, -- ^ Default methods + tcdATs :: [LFamilyDecl pass], -- ^ Associated types; + tcdATDefs :: [LTyFamDefltDecl pass], -- ^ Associated type defaults + tcdDocs :: [LDocDecl pass] -- ^ Haddock docs + } + | XTyClDecl !(XXTyClDecl pass) + +data FunDep pass + = FunDep (XCFunDep pass) + [LIdP pass] + [LIdP pass] + | XFunDep !(XXFunDep pass) + +type LHsFunDep pass = XRec pass (FunDep pass) + +{- Note [TyVar binders for associated decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For an /associated/ data, newtype, or type-family decl, the LHsQTyVars +/includes/ outer binders. For example + class T a where + data D a c + type F a b :: * + type F a b = a -> a +Here the data decl for 'D', and type-family decl for 'F', both include 'a' +in their LHsQTyVars (tcdTyVars and fdTyVars resp). + +Ditto any implicit binders in the hsq_implicit field of the LHSQTyVars. + +The idea is that the associated type is really a top-level decl in its +own right. However we are careful to use the same name 'a', so that +we can match things up. + +c.f. Note [Associated type tyvar names] in GHC.Core.Class + Note [Family instance declaration binders] +-} + +{- Note [Class EpLayout] +~~~~~~~~~~~~~~~~~~~~~~~~ +The EpLayout is used to associate Haddock comments with parts of the declaration. +Compare the following examples: + + class C a where + f :: a -> Int + -- ^ comment on f + + class C a where + f :: a -> Int + -- ^ comment on C + +Notice how "comment on f" and "comment on C" differ only by indentation level. +Thus we have to record the indentation level of the class declarations. + +See also Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock +-} + +-- Simple classifiers for TyClDecl +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- | @True@ <=> argument is a @data@\/@newtype@ +-- declaration. +isDataDecl :: TyClDecl pass -> Bool +isDataDecl (DataDecl {}) = True +isDataDecl _other = False + +-- | type or type instance declaration +isSynDecl :: TyClDecl pass -> Bool +isSynDecl (SynDecl {}) = True +isSynDecl _other = False + +-- | type class +isClassDecl :: TyClDecl pass -> Bool +isClassDecl (ClassDecl {}) = True +isClassDecl _ = False + +-- | type/data family declaration +isFamilyDecl :: TyClDecl pass -> Bool +isFamilyDecl (FamDecl {}) = True +isFamilyDecl _other = False + +-- | type family declaration +isTypeFamilyDecl :: TyClDecl pass -> Bool +isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of + OpenTypeFamily -> True + ClosedTypeFamily {} -> True + _ -> False +isTypeFamilyDecl _ = False + +-- | open type family info +isOpenTypeFamilyInfo :: FamilyInfo pass -> Bool +isOpenTypeFamilyInfo OpenTypeFamily = True +isOpenTypeFamilyInfo _ = False + +-- | closed type family info +isClosedTypeFamilyInfo :: FamilyInfo pass -> Bool +isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True +isClosedTypeFamilyInfo _ = False + +-- | data family declaration +isDataFamilyDecl :: TyClDecl pass -> Bool +isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True +isDataFamilyDecl _other = False + +-- Dealing with names + +{- Note [CUSKs: complete user-supplied kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We kind-check declarations differently if they have a complete, user-supplied +kind signature (CUSK). This is because we can safely generalise a CUSKed +declaration before checking all of the others, supporting polymorphic recursion. +See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy +and #9200 for lots of discussion of how we got here. + +The detection of CUSKs is enabled by the -XCUSKs extension, switched off by default +in GHC2021 and on in Haskell98/2010. +Under -XNoCUSKs, all declarations are treated as if they have no CUSK. +See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst + +PRINCIPLE: + a type declaration has a CUSK iff we could produce a separate kind signature + for it, just like a type signature for a function, + looking only at the header of the declaration. + +Examples: + * data T1 (a :: *->*) (b :: *) = .... + -- Has CUSK; equivalent to T1 :: (*->*) -> * -> * + + * data T2 a b = ... + -- No CUSK; we do not want to guess T2 :: * -> * -> * + -- because the full decl might be data T a b = MkT (a b) + + * data T3 (a :: k -> *) (b :: *) = ... + -- CUSK; equivalent to T3 :: (k -> *) -> * -> * + -- We lexically generalise over k to get + -- T3 :: forall k. (k -> *) -> * -> * + -- The generalisation is here is purely lexical, just like + -- f3 :: a -> a + -- means + -- f3 :: forall a. a -> a + + * data T4 (a :: j k) = ... + -- CUSK; equivalent to T4 :: j k -> * + -- which we lexically generalise to T4 :: forall j k. j k -> * + -- and then, if PolyKinds is on, we further generalise to + -- T4 :: forall kk (j :: kk -> *) (k :: kk). j k -> * + -- Again this is exactly like what happens as the term level + -- when you write + -- f4 :: forall a b. a b -> Int + +NOTE THAT + * A CUSK does /not/ mean that everything about the kind signature is + fully specified by the user. Look at T4 and f4: we had to do kind + inference to figure out the kind-quantification. But in both cases + (T4 and f4) that inference is done looking /only/ at the header of T4 + (or signature for f4), not at the definition thereof. + + * The CUSK completely fixes the kind of the type constructor, forever. + + * The precise rules, for each declaration form, for whether a declaration + has a CUSK are given in the user manual section "Complete user-supplied + kind signatures and polymorphic recursion". But they simply implement + PRINCIPLE above. + + * Open type families are interesting: + type family T5 a b :: * + There simply /is/ no accompanying declaration, so that info is all + we'll ever get. So we it has a CUSK by definition, and we default + any un-fixed kind variables to *. + + * Associated types are a bit tricker: + class C6 a where + type family T6 a b :: * + op :: a Int -> Int + Here C6 does not have a CUSK (in fact we ultimately discover that + a :: * -> *). And hence neither does T6, the associated family, + because we can't fix its kind until we have settled C6. Another + way to say it: unlike a top-level, we /may/ discover more about + a's kind from C6's definition. + + * A data definition with a top-level :: must explicitly bind all + kind variables to the right of the ::. See test + dependent/should_compile/KindLevels, which requires this + case. (Naturally, any kind variable mentioned before the :: should + not be bound after it.) + + This last point is much more debatable than the others; see + #15142 comment:22 + + Because this is fiddly to check, there is a field in the DataDeclRn + structure (included in a DataDecl after the renamer) that stores whether + or not the declaration has a CUSK. +-} + + +{- ********************************************************************* +* * + TyClGroup + Strongly connected components of + type, class, instance, and role declarations +* * +********************************************************************* -} + +{- Note [TyClGroups and dependency analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A TyClGroup represents a strongly connected component of type/class/instance +decls, together with the role annotations and standalone kind signatures for the +type/class declarations. + +The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order +sequence of strongly-connected components. + +Invariants + * The type and class declarations, group_tyclds, may lexically depend + on each other, or earlier TyClGroups, but not on later ones + + * The role annotations, group_roles, are role-annotations for some or + all of the types and classes in group_tyclds (only). + + * The instance declarations, group_instds, may (and usually will) + lexically depend on group_tyclds, or on earlier TyClGroups, but + not on later ones. + +See Note [Dependency analysis of type and class decls] in GHC.Rename.Module +for more info. +-} + +-- | Type or Class Group +data TyClGroup pass -- See Note [TyClGroups and dependency analysis] + = TyClGroup { group_ext :: XCTyClGroup pass + , group_tyclds :: [LTyClDecl pass] + , group_roles :: [LRoleAnnotDecl pass] + , group_kisigs :: [LStandaloneKindSig pass] + , group_instds :: [LInstDecl pass] } + | XTyClGroup !(XXTyClGroup pass) + + +{- ********************************************************************* +* * + Data and type family declarations +* * +********************************************************************* -} + +{- Note [FamilyResultSig] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +This data type represents the return signature of a type family. Possible +values are: + + * NoSig - the user supplied no return signature: + type family Id a where ... + + * KindSig - the user supplied the return kind: + type family Id a :: * where ... + + * TyVarSig - user named the result with a type variable and possibly + provided a kind signature for that variable: + type family Id a = r where ... + type family Id a = (r :: *) where ... + + Naming result of a type family is required if we want to provide + injectivity annotation for a type family: + type family Id a = r | r -> a where ... + +See also: Note [Injectivity annotation] + +Note [Injectivity annotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A user can declare a type family to be injective: + + type family Id a = r | r -> a where ... + + * The part after the "|" is called "injectivity annotation". + * "r -> a" part is called "injectivity condition"; at the moment terms + "injectivity annotation" and "injectivity condition" are synonymous + because we only allow a single injectivity condition. + * "r" is the "LHS of injectivity condition". LHS can only contain the + variable naming the result of a type family. + + * "a" is the "RHS of injectivity condition". RHS contains space-separated + type and kind variables representing the arguments of a type + family. Variables can be omitted if a type family is not injective in + these arguments. Example: + type family Foo a b c = d | d -> a c where ... + +Note that: + (a) naming of type family result is required to provide injectivity + annotation + (b) for associated types if the result was named then injectivity annotation + is mandatory. Otherwise result type variable is indistinguishable from + associated type default. + +It is possible that in the future this syntax will be extended to support +more complicated injectivity annotations. For example we could declare that +if we know the result of Plus and one of its arguments we can determine the +other argument: + + type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ... + +Here injectivity annotation would consist of two comma-separated injectivity +conditions. + +See also Note [Injective type families] in GHC.Core.TyCon +-} + +-- | Located type Family Result Signature +type LFamilyResultSig pass = XRec pass (FamilyResultSig pass) + +-- | type Family Result Signature +data FamilyResultSig pass = -- see Note [FamilyResultSig] + NoSig (XNoSig pass) + | KindSig (XCKindSig pass) (LHsKind pass) + | TyVarSig (XTyVarSig pass) (LHsTyVarBndr () pass) + | XFamilyResultSig !(XXFamilyResultSig pass) + + + +-- | Located type Family Declaration +type LFamilyDecl pass = XRec pass (FamilyDecl pass) + +-- | type Family Declaration +data FamilyDecl pass = FamilyDecl + { fdExt :: XCFamilyDecl pass + , fdInfo :: FamilyInfo pass -- type/data, closed/open + , fdTopLevel :: TopLevelFlag -- used for printing only + , fdLName :: LIdP pass -- type constructor + , fdTyVars :: LHsQTyVars pass -- type variables + -- See Note [TyVar binders for associated decls] + , fdFixity :: LexicalFixity -- Fixity used in the declaration + , fdResultSig :: LFamilyResultSig pass -- result signature + , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann + } + | XFamilyDecl !(XXFamilyDecl pass) + +-- | Located Injectivity Annotation +type LInjectivityAnn pass = XRec pass (InjectivityAnn pass) + +-- | If the user supplied an injectivity annotation it is represented using +-- InjectivityAnn. At the moment this is a single injectivity condition - see +-- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity +-- condition. `[Located name]` stores the RHS of injectivity condition. Example: +-- +-- type family Foo a b c = r | r -> a c where ... +-- +-- This will be represented as "InjectivityAnn `r` [`a`, `c`]" +data InjectivityAnn pass + = InjectivityAnn (XCInjectivityAnn pass) + (LIdP pass) [LIdP pass] + | XInjectivityAnn !(XXInjectivityAnn pass) + +data FamilyInfo pass + = DataFamily + | OpenTypeFamily + -- | 'Nothing' if we're in an hs-boot file and the user + -- said "type family Foo x where .." + | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) + +familyInfoTyConFlavour + :: Maybe tc -- ^ Just cls <=> this is an associated family of class cls + -> FamilyInfo pass + -> TyConFlavour tc +familyInfoTyConFlavour mb_parent_tycon info = + case info of + DataFamily -> OpenFamilyFlavour (IAmData DataType) mb_parent_tycon + OpenTypeFamily -> OpenFamilyFlavour IAmType mb_parent_tycon + ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) + -- See Note [Closed type family mb_parent_tycon] + ClosedTypeFamilyFlavour + +{- Note [Closed type family mb_parent_tycon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's no way to write a closed type family inside a class declaration: + + class C a where + type family F a where -- error: parse error on input ‘where’ + +In fact, it is not clear what the meaning of such a declaration would be. +Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. +-} + +{- ********************************************************************* +* * + Data types and data constructors +* * +********************************************************************* -} + +-- | Haskell Data type Definition +data HsDataDefn pass -- The payload of a data type defn + -- Used *both* for vanilla data declarations, + -- *and* for data family instances + = -- | Declares a data type or newtype, giving its constructors + -- @ + -- data/newtype T a = + -- data/newtype instance T [a] = + -- @ + HsDataDefn { dd_ext :: XCHsDataDefn pass, + dd_ctxt :: Maybe (LHsContext pass), -- ^ Context + dd_cType :: Maybe (XRec pass CType), + dd_kindSig:: Maybe (LHsKind pass), + -- ^ Optional kind signature. + -- + -- @(Just k)@ for a GADT-style @data@, + -- or @data instance@ decl, with explicit kind sig + -- + -- Always @Nothing@ for H98-syntax decls + + dd_cons :: DataDefnCons (LConDecl pass), + -- ^ Data constructors + -- + -- For @data T a = T1 | T2 a@ + -- the 'LConDecl's all have 'ConDeclH98'. + -- For @data T a where { T1 :: T a }@ + -- the 'LConDecls' all have 'ConDeclGADT'. + + dd_derivs :: HsDeriving pass -- ^ Optional 'deriving' clause + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + } + | XHsDataDefn !(XXHsDataDefn pass) + +-- | Haskell Deriving clause +type HsDeriving pass = [LHsDerivingClause pass] + -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is + -- plural because one can specify multiple deriving clauses using the + -- @-XDerivingStrategies@ language extension. + -- + -- The list of 'LHsDerivingClause's corresponds to exactly what the user + -- requested to derive, in order. If no deriving clauses were specified, + -- the list is empty. + +type LHsDerivingClause pass = XRec pass (HsDerivingClause pass) + +-- | A single @deriving@ clause of a data declaration. +data HsDerivingClause pass + -- See Note [Deriving strategies] in GHC.Tc.Deriv + = HsDerivingClause + { deriv_clause_ext :: XCHsDerivingClause pass + , deriv_clause_strategy :: Maybe (LDerivStrategy pass) + -- ^ The user-specified strategy (if any) to use when deriving + -- 'deriv_clause_tys'. + , deriv_clause_tys :: LDerivClauseTys pass + -- ^ The types to derive. + } + | XHsDerivingClause !(XXHsDerivingClause pass) + +type LDerivClauseTys pass = XRec pass (DerivClauseTys pass) + +-- | The types mentioned in a single @deriving@ clause. This can come in two +-- forms, 'DctSingle' or 'DctMulti', depending on whether the types are +-- surrounded by enclosing parentheses or not. These parentheses are +-- semantically different than 'HsParTy'. For example, @deriving ()@ means +-- \"derive zero classes\" rather than \"derive an instance of the 0-tuple\". +-- +-- 'DerivClauseTys' use 'LHsSigType' because @deriving@ clauses can mention +-- type variables that aren't bound by the datatype, e.g. +-- +-- > data T b = ... deriving (C [a]) +-- +-- should produce a derived instance for @C [a] (T b)@. +data DerivClauseTys pass + = -- | A @deriving@ clause with a single type. Moreover, that type can only + -- be a type constructor without any arguments. + -- + -- Example: @deriving Eq@ + DctSingle (XDctSingle pass) (LHsSigType pass) + + -- | A @deriving@ clause with a comma-separated list of types, surrounded + -- by enclosing parentheses. + -- + -- Example: @deriving (Eq, C a)@ + | DctMulti (XDctMulti pass) [LHsSigType pass] + + | XDerivClauseTys !(XXDerivClauseTys pass) + +-- | Located Standalone Kind Signature +type LStandaloneKindSig pass = XRec pass (StandaloneKindSig pass) + +data StandaloneKindSig pass + = StandaloneKindSig (XStandaloneKindSig pass) + (LIdP pass) -- Why a single binder? See #16754 + (LHsSigType pass) -- Why not LHsSigWcType? See Note [Wildcards in standalone kind signatures] + | XStandaloneKindSig !(XXStandaloneKindSig pass) + +{- Note [Wildcards in standalone kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Standalone kind signatures enable polymorphic recursion, and it is unclear how +to reconcile this with partial type signatures, so we disallow wildcards in +them. + +We reject wildcards in 'rnStandaloneKindSignature' by returning False for +'StandaloneKindSigCtx' in 'wildCardsAllowed'. + +The alternative design is to have special treatment for partial standalone kind +signatures, much like we have special treatment for partial type signatures in +terms. However, partial standalone kind signatures are not a proper replacement +for CUSKs, so this would be a separate feature. +-} + +-- | Whether a data-type declaration is @data@ or @newtype@, and its constructors. +data DataDefnCons a + = NewTypeCon -- @newtype N x = MkN blah@ + a -- Info about the single data constructor @MkN@ + + | DataTypeCons + Bool -- True <=> type data T x = ... + -- See Note [Type data declarations] in GHC.Rename.Module + -- False <=> data T x = ... + [a] -- The (possibly empty) list of data constructors + deriving ( Eq, Data, Foldable, Functor, Traversable ) -- Needed because Demand derives Eq + +dataDefnConsNewOrData :: DataDefnCons a -> NewOrData +dataDefnConsNewOrData = \ case + NewTypeCon {} -> NewType + DataTypeCons {} -> DataType + +-- | Are the constructors within a @type data@ declaration? +-- See Note [Type data declarations] in GHC.Rename.Module. +isTypeDataDefnCons :: DataDefnCons a -> Bool +isTypeDataDefnCons (NewTypeCon _) = False +isTypeDataDefnCons (DataTypeCons is_type_data _) = is_type_data + +-- | Retrieve the first data constructor in a 'DataDefnCons' (if one exists). +firstDataDefnCon :: DataDefnCons a -> Maybe a +firstDataDefnCon (NewTypeCon con) = Just con +firstDataDefnCon (DataTypeCons _ cons) = listToMaybe cons + +-- | Located data Constructor Declaration +type LConDecl pass = XRec pass (ConDecl pass) + +-- | +-- +-- @ +-- data T b = forall a. Eq a => MkT a b +-- MkT :: forall b a. Eq a => MkT a b +-- +-- data T b where +-- MkT1 :: Int -> T Int +-- +-- data T = Int `MkT` Int +-- | MkT2 +-- +-- data T a where +-- Int `MkT` Int :: T Int +-- @ + +-- | data Constructor Declaration +data ConDecl pass + = ConDeclGADT + { con_g_ext :: XConDeclGADT pass + , con_names :: NonEmpty (LIdP pass) + -- The following fields describe the type after the '::' + -- See Note [GADT abstract syntax] + , con_outer_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass) + -- ^ The outermost type variable binders, be they explicit or implicit; + -- cf. HsSigType that also stores the outermost sig_bndrs separately + -- from the forall telescopes in sig_body. + -- See Note [Representing type signatures] in Language.Haskell.Syntax.Type + , con_inner_bndrs :: [HsForAllTelescope pass] + -- ^ The forall telescopes other than the outermost invisible forall. + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix + , con_res_ty :: LHsType pass -- ^ Result type + + , con_doc :: Maybe (LHsDoc pass) -- ^ A possible Haddock + -- comment. + } + + | ConDeclH98 + { con_ext :: XConDeclH98 pass + , con_name :: LIdP pass + + , con_forall :: Bool + -- ^ True <=> explicit user-written forall + -- e.g. data T a = forall b. MkT b (b->a) + -- con_ex_tvs = {b} + -- False => con_ex_tvs is empty + , con_ex_tvs :: [LHsTyVarBndr Specificity pass] -- ^ Existentials only + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclH98Details pass -- ^ Arguments; can be infix + + , con_doc :: Maybe (LHsDoc pass) -- ^ A possible Haddock comment. + } + | XConDecl !(XXConDecl pass) + +{- Note [GADT abstract syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The types of both forms of GADT constructors are very structured, as they +must consist of the quantified type variables (if provided), followed by the +context (if provided), followed by the argument types (if provided), followed +by the result type. (See "Wrinkle: No nested foralls or contexts" below for +more discussion on the restrictions imposed here.) As a result, instead of +storing the type of a GADT constructor as a single LHsType, we split it up +into its constituent components for easier access. + +There are two broad ways to classify GADT constructors: + +* Record-syntax constructors. For example: + + data T a where + K :: forall a. Ord a => { x :: [a], ... } -> T a + +* Prefix constructors, which do not use record syntax. For example: + + data T a where + K :: forall a. Ord a => [a] -> ... -> T a + +This distinction is recorded in the `con_args :: HsConDetails pass`, which +tracks if we're dealing with a RecCon or PrefixCon. It is easy to distinguish +the two in the AST since record GADT constructors use HsRecTy. This distinction +is made in GHC.Parser.PostProcess.mkGadtDecl. + +It is worth elaborating a bit more on the process of splitting the argument +types of a GADT constructor, since there are some non-obvious details involved. +While splitting the argument types of a record GADT constructor is easy (they +are stored in an HsRecTy), splitting the arguments of a prefix GADT constructor +is trickier. The basic idea is that we must split along the outermost function +arrows ((->) and (%1 ->)) in the type, which GHC.Hs.Type.splitHsFunType +accomplishes. But what about type operators? Consider: + + C :: a :*: b -> a :*: b -> a :+: b + +This could parse in many different ways depending on the precedences of each +type operator. In particular, if (:*:) were to have lower precedence than (->), +then it could very well parse like this: + + a :*: ((b -> a) :*: ((b -> a) :+: b))) + +This would give the false impression that the whole type is part of one large +return type, with no arguments. Note that we do not fully resolve the exact +precedences of each user-defined type operator until the renamer, so this a +more difficult task for the parser. + +Fortunately, there is no risk of the above happening. GHC's parser gives +special treatment to function arrows, and as a result, they are always parsed +with a lower precedence than any other type operator. As a result, the type +above is actually parsed like this: + + (a :*: b) -> ((a :*: b) -> (a :+: b)) + +While we won't know the exact precedences of (:*:) and (:+:) until the renamer, +all we are concerned about in the parser is identifying the overall shape of +the argument and result types, which we can accomplish by piggybacking on the +special treatment given to function arrows. In a future where function arrows +aren't given special status in the parser, we will likely have to modify +GHC.Parser.PostProcess.mkHsOpTyPV to preserve this trick. + +----- +-- Wrinkle: No nested foralls or contexts +----- + +GADT constructors provide some freedom to change the order of foralls in their +types (see Note [DataCon user type variable binders] in GHC.Core.DataCon), but +this freedom is still limited. GADTs still require that all quantification +occurs "prenex". That is, any explicitly quantified type variables must occur +at the front of the GADT type, followed by any contexts, followed by the body of +the GADT type, in precisely that order. For instance: + + data T where + MkT1 :: forall a b. (Eq a, Eq b) => a -> b -> T + -- OK + MkT2 :: forall a. Eq a => forall b. a -> b -> T + -- Rejected, `forall b` is nested + MkT3 :: forall a b. Eq a => Eq b => a -> b -> T + -- Rejected, `Eq b` is nested + MkT4 :: Int -> forall a. a -> T + -- Rejected, `forall a` is nested + MkT5 :: forall a. Int -> Eq a => a -> T + -- Rejected, `Eq a` is nested + MkT6 :: (forall a. a -> T) + -- Rejected, `forall a` is nested due to the surrounding parentheses + MkT7 :: (Eq a => a -> t) + -- Rejected, `Eq a` is nested due to the surrounding parentheses + +For the full details, see the "Formal syntax for GADTs" section of the GHC +User's Guide. GHC enforces that GADT constructors do not have nested `forall`s +or contexts in two parts: + +1. GHC, in the process of splitting apart a GADT's type, + extracts out the leading `forall` and context (if they are provided). To + accomplish this splitting, the renamer uses the + GHC.Hs.Type.splitLHsGADTPrefixTy function, which is careful not to remove + parentheses surrounding the leading `forall` or context (as these + parentheses can be syntactically significant). If the third result returned + by splitLHsGADTPrefixTy contains any `forall`s or contexts, then they must + be nested, so they will be rejected. + + Note that this step applies to both prefix and record GADTs alike, as they + both have syntax which permits `forall`s and contexts. The difference is + where this step happens: + + * For prefix GADTs, this happens in the renamer (in rnConDecl), as we cannot + split until after the type operator fixities have been resolved. + * For record GADTs, this happens in the parser (in mkGadtDecl). +2. If the GADT type is prefix, the renamer (in the ConDeclGADTPrefixPs case of + rnConDecl) will then check for nested `forall`s/contexts in the body of a + prefix GADT type, after it has determined what all of the argument types are. + This step is necessary to catch examples like MkT4 above, where the nested + quantification occurs after a visible argument type. +-} + +-- | The arguments in a Haskell98-style data constructor. +type HsConDeclH98Details pass + = HsConDetails (HsConDeclField pass) (XRec pass [LHsConDeclRecField pass]) +-- The Void argument to HsConDetails here is a reflection of the fact that +-- type applications are not allowed in data constructor declarations. + +-- | The arguments in a GADT constructor. Unlike Haskell98-style constructors, +-- GADT constructors cannot be declared with infix syntax. As a result, we do +-- not use 'HsConDetails' here, as 'InfixCon' would be an unrepresentable +-- state. (There is a notion of infix GADT constructors for the purposes of +-- derived Show instances—see Note [Infix GADT constructors] in +-- GHC.Tc.TyCl—but that is an orthogonal concern.) +data HsConDeclGADTDetails pass + = PrefixConGADT !(XPrefixConGADT pass) [HsConDeclField pass] + | RecConGADT !(XRecConGADT pass) (XRec pass [LHsConDeclRecField pass]) + | XConDeclGADTDetails !(XXConDeclGADTDetails pass) + +type family XPrefixConGADT p +type family XRecConGADT p +type family XXConDeclGADTDetails p + +{- +************************************************************************ +* * + Instance declarations +* * +************************************************************************ + +Note [Type family instance declarations in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The data type FamEqn represents one equation of a type family instance. +Aside from the pass, it is also parameterised over another field, feqn_rhs. +feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType +(for type family instances). + +Type family instances also include associated type family default equations. +That is because a default for a type family looks like this: + + class C a where + type family F a b :: Type + type F c d = (c,d) -- Default instance + +The default declaration is really just a `type instance` declaration, but one +with particularly simple patterns: they must all be distinct type variables. +That's because we will instantiate it (in an instance declaration for `C`) if +we don't give an explicit instance for `F`. Note that the names of the +variables don't need to match those of the class: it really is like a +free-standing `type instance` declaration. +-} + +----------------- Type synonym family instances ------------- + +-- | Located Type Family Instance Equation +type LTyFamInstEqn pass = XRec pass (TyFamInstEqn pass) + +-- | HsFamEqnPats represents patterns on the left-hand side of a type instance, +-- e.g. `type instance F @k (a :: k) = a` has patterns `@k` and `(a :: k)`. +-- +-- HsFamEqnPats used to be called HsTyPats but it was renamed to avoid confusion +-- with a different notion of type patterns, see #23657. +type HsFamEqnPats pass = [LHsTypeArg pass] + +{- Note [Family instance declaration binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The feqn_pats field of FamEqn (family instance equation) stores the LHS type +(and kind) patterns. Any type (and kind) variables contained +in these type patterns are bound in the feqn_bndrs field. +Note that in particular: + +* The feqn_bndrs *include* any anonymous wildcards. For example + type instance F a _ = a + The feqn_bndrs will be HsOuterImplicit {a, _}. Remember that each separate + wildcard '_' gets its own unique. In this context wildcards behave just like + an ordinary type variable, only anonymous. + +* The feqn_bndrs *include* type variables that are already in scope + + Eg class C s t where + type F t p :: * + instance C w (a,b) where + type F (a,b) x = x->a + The feqn_bndrs of the F decl is HsOuterImplicit {a,b,x}, even though the + F decl is nested inside the 'instance' decl. + + However after the renamer, the uniques will match up: + instance C w7 (a8,b9) where + type F (a8,b9) x10 = x10->a8 + so that we can compare the type pattern in the 'instance' decl and + in the associated 'type' decl + +c.f. Note [TyVar binders for associated decls] +-} + +-- | Type Family Instance Equation +type TyFamInstEqn pass = FamEqn pass (LHsType pass) + -- Here, the @pats@ are type patterns (with kind and type bndrs). + -- See Note [Family instance declaration binders] + +-- | Type family default declarations. +-- A convenient synonym for 'TyFamInstDecl'. +-- See @Note [Type family instance declarations in HsSyn]@. +type TyFamDefltDecl = TyFamInstDecl + +-- | Located type family default declarations. +type LTyFamDefltDecl pass = XRec pass (TyFamDefltDecl pass) + +-- | Located Type Family Instance Declaration +type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass) + +-- | Type Family Instance Declaration +data TyFamInstDecl pass + = TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl pass + , tfid_eqn :: TyFamInstEqn pass } + | XTyFamInstDecl !(XXTyFamInstDecl pass) + +----------------- Data family instances ------------- + +-- | Located Data Family Instance Declaration +type LDataFamInstDecl pass = XRec pass (DataFamInstDecl pass) + +-- | Data Family Instance Declaration +newtype DataFamInstDecl pass + = DataFamInstDecl { dfid_eqn :: FamEqn pass (HsDataDefn pass) } + +----------------- Family instances (common types) ------------- + +-- | Family Equation +-- +-- One equation in a type family instance declaration, data family instance +-- declaration, or type family default. +-- See Note [Type family instance declarations in HsSyn] +-- See Note [Family instance declaration binders] +data FamEqn pass rhs + = FamEqn + { feqn_ext :: XCFamEqn pass rhs + , feqn_tycon :: LIdP pass + , feqn_bndrs :: HsOuterFamEqnTyVarBndrs pass -- ^ Optional quantified type vars + , feqn_pats :: HsFamEqnPats pass + , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration + , feqn_rhs :: rhs + } + | XFamEqn !(XXFamEqn pass rhs) + +----------------- Class instances ------------- + +-- | Located Class Instance Declaration +type LClsInstDecl pass = XRec pass (ClsInstDecl pass) + +-- | Class Instance Declaration +data ClsInstDecl pass + = ClsInstDecl + { cid_ext :: XCClsInstDecl pass + , cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. + , cid_binds :: LHsBinds pass -- Class methods + , cid_sigs :: [LSig pass] -- User-supplied pragmatic info + , cid_tyfam_insts :: [LTyFamInstDecl pass] -- Type family instances + , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances + , cid_overlap_mode :: Maybe (XRec pass OverlapMode) + } + | XClsInstDecl !(XXClsInstDecl pass) + +----------------- Instances of all kinds ------------- + +-- | Located Instance Declaration +type LInstDecl pass = XRec pass (InstDecl pass) + +-- | Instance Declaration +data InstDecl pass -- Both class and family instances + = ClsInstD + { cid_d_ext :: XClsInstD pass + , cid_inst :: ClsInstDecl pass } + | DataFamInstD -- data family instance + { dfid_ext :: XDataFamInstD pass + , dfid_inst :: DataFamInstDecl pass } + | TyFamInstD -- type family instance + { tfid_ext :: XTyFamInstD pass + , tfid_inst :: TyFamInstDecl pass } + | XInstDecl !(XXInstDecl pass) + +{- +************************************************************************ +* * +\subsection[DerivDecl]{A stand-alone instance deriving declaration} +* * +************************************************************************ +-} + +-- | Located stand-alone 'deriving instance' declaration +type LDerivDecl pass = XRec pass (DerivDecl pass) + +-- | Stand-alone 'deriving instance' declaration +data DerivDecl pass = DerivDecl + { deriv_ext :: XCDerivDecl pass + , deriv_type :: LHsSigWcType pass + -- ^ The instance type to derive. + -- + -- It uses an 'LHsSigWcType' because the context is allowed to be a + -- single wildcard: + -- + -- > deriving instance _ => Eq (Foo a) + -- + -- Which signifies that the context should be inferred. + + -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer. + + , deriv_strategy :: Maybe (LDerivStrategy pass) + , deriv_overlap_mode :: Maybe (XRec pass OverlapMode) + } + | XDerivDecl !(XXDerivDecl pass) + +{- +************************************************************************ +* * + Deriving strategies +* * +************************************************************************ +-} + +-- | A 'Located' 'DerivStrategy'. +type LDerivStrategy pass = XRec pass (DerivStrategy pass) + +-- | Which technique the user explicitly requested when deriving an instance. +data DerivStrategy pass + -- See Note [Deriving strategies] in GHC.Tc.Deriv + = StockStrategy (XStockStrategy pass) + -- ^ GHC's \"standard\" strategy, which is to implement a + -- custom instance for the data type. This only works + -- for certain types that GHC knows about (e.g., 'Eq', + -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled, + -- etc.) + | AnyclassStrategy (XAnyClassStrategy pass) -- ^ @-XDeriveAnyClass@ + | NewtypeStrategy (XNewtypeStrategy pass) -- ^ @-XGeneralizedNewtypeDeriving@ + | ViaStrategy (XViaStrategy pass) + -- ^ @-XDerivingVia@ + + +{- +************************************************************************ +* * +\subsection[DefaultDecl]{A @default@ declaration} +* * +************************************************************************ +-} + +-- | Located Default Declaration +type LDefaultDecl pass = XRec pass (DefaultDecl pass) + +-- See Note [Named default declarations] in GHC.Tc.Gen.Default +-- | Default Declaration +data DefaultDecl pass + = DefaultDecl + { defd_ext :: XCDefaultDecl pass + , defd_class :: Maybe (LIdP pass) -- Nothing in absence of NamedDefaults + , defd_defaults :: [LHsType pass] } + | XDefaultDecl !(XXDefaultDecl pass) + +{- +************************************************************************ +* * +\subsection{Foreign function interface declaration} +* * +************************************************************************ +-} + +-- foreign declarations are distinguished as to whether they define or use a +-- Haskell name +-- +-- * the Boolean value indicates whether the pre-standard deprecated syntax +-- has been used + +-- | Located Foreign Declaration +type LForeignDecl pass = XRec pass (ForeignDecl pass) + +-- | Foreign Declaration +data ForeignDecl pass + = ForeignImport + { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty + , fd_name :: LIdP pass -- defines this name + , fd_sig_ty :: LHsSigType pass -- sig_ty + , fd_fi :: ForeignImport pass } + + | ForeignExport + { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty + , fd_name :: LIdP pass -- uses this name + , fd_sig_ty :: LHsSigType pass -- sig_ty + , fd_fe :: ForeignExport pass } + | XForeignDecl !(XXForeignDecl pass) + +{- + In both ForeignImport and ForeignExport: + sig_ty is the type given in the Haskell code + rep_ty is the representation for this type, i.e. with newtypes + coerced away and type functions evaluated. + Thus if the declaration is valid, then rep_ty will only use types + such as Int and IO that we know how to make foreign calls with. +-} + +-- Specification Of an imported external entity in dependence on the calling +-- convention +-- +data ForeignImport pass = -- import of a C entity + -- + -- * the two strings specifying a header file or library + -- may be empty, which indicates the absence of a + -- header or object specification (both are not used + -- in the case of `CWrapper' and when `CFunction' + -- has a dynamic target) + -- + -- * the calling convention is irrelevant for code + -- generation in the case of `CLabel', but is needed + -- for pretty printing + -- + -- * `Safety' is irrelevant for `CLabel' and `CWrapper' + -- + CImport (XCImport pass) + (XRec pass CCallConv) -- ccall + (XRec pass Safety) -- interruptible, safe or unsafe + (Maybe Header) -- name of C header + CImportSpec -- details of the C entity + | XForeignImport !(XXForeignImport pass) + +-- details of an external C entity +-- +data CImportSpec = CLabel CLabelString -- import address of a C label + | CFunction CCallTarget -- static or dynamic function + | CWrapper -- wrapper to expose closures + -- (former f.e.d.) + deriving Data + +-- specification of an externally exported entity in dependence on the calling +-- convention +-- +data ForeignExport pass = CExport (XCExport pass) (XRec pass CExportSpec) -- contains the calling convention + | XForeignExport !(XXForeignExport pass) + + +{- +************************************************************************ +* * +\subsection{Rewrite rules} +* * +************************************************************************ +-} + +-- | Located Rule Declarations +type LRuleDecls pass = XRec pass (RuleDecls pass) + +-- | Rule Declarations +data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass + , rds_rules :: [LRuleDecl pass] } + | XRuleDecls !(XXRuleDecls pass) + +-- | Located Rule Declaration +type LRuleDecl pass = XRec pass (RuleDecl pass) + +-- | Rule Declaration +data RuleDecl pass + = HsRule -- Source rule + { rd_ext :: XHsRule pass + -- ^ After renamer, free-vars from the LHS and RHS + , rd_name :: XRec pass RuleName + -- ^ Note [Pragma source text] in "GHC.Types.SourceText" + , rd_act :: Activation + , rd_bndrs :: RuleBndrs pass + , rd_lhs :: XRec pass (HsExpr pass) + , rd_rhs :: XRec pass (HsExpr pass) + } + | XRuleDecl !(XXRuleDecl pass) + +{- +************************************************************************ +* * +\subsection[DocDecl]{Document comments} +* * +************************************************************************ +-} + +-- | Located Documentation comment Declaration +type LDocDecl pass = XRec pass (DocDecl pass) + +-- | Documentation comment Declaration +data DocDecl pass + = DocCommentNext (LHsDoc pass) + | DocCommentPrev (LHsDoc pass) + | DocCommentNamed String (LHsDoc pass) + | DocGroup Int (LHsDoc pass) + +deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass) + +docDeclDoc :: DocDecl pass -> LHsDoc pass +docDeclDoc (DocCommentNext d) = d +docDeclDoc (DocCommentPrev d) = d +docDeclDoc (DocCommentNamed _ d) = d +docDeclDoc (DocGroup _ d) = d + +{- +************************************************************************ +* * +\subsection[DeprecDecl]{Deprecations} +* * +************************************************************************ + +We use exported entities for things to deprecate. +-} + +-- | Located Warning Declarations +type LWarnDecls pass = XRec pass (WarnDecls pass) + +-- | Warning pragma Declarations +data WarnDecls pass = Warnings { wd_ext :: XWarnings pass + , wd_warnings :: [LWarnDecl pass] + } + | XWarnDecls !(XXWarnDecls pass) + +-- | Located Warning pragma Declaration +type LWarnDecl pass = XRec pass (WarnDecl pass) + +-- | Warning pragma Declaration +data WarnDecl pass = Warning (XWarning pass) [LIdP pass] (WarningTxt pass) + | XWarnDecl !(XXWarnDecl pass) + + +{- +************************************************************************ +* * +\subsection[AnnDecl]{Annotations} +* * +************************************************************************ +-} + +-- | Located Annotation Declaration +type LAnnDecl pass = XRec pass (AnnDecl pass) + +-- | Annotation Declaration +data AnnDecl pass = HsAnnotation + (XHsAnnotation pass) + (AnnProvenance pass) (XRec pass (HsExpr pass)) + | XAnnDecl !(XXAnnDecl pass) + +-- | Annotation Provenance +data AnnProvenance pass = ValueAnnProvenance (LIdP pass) + | TypeAnnProvenance (LIdP pass) + | ModuleAnnProvenance +-- deriving instance Functor AnnProvenance +-- deriving instance Foldable AnnProvenance +-- deriving instance Traversable AnnProvenance +-- deriving instance (Data pass) => Data (AnnProvenance pass) + +annProvenanceName_maybe :: forall p. UnXRec p => AnnProvenance p -> Maybe (IdP p) +annProvenanceName_maybe (ValueAnnProvenance (unXRec @p -> name)) = Just name +annProvenanceName_maybe (TypeAnnProvenance (unXRec @p -> name)) = Just name +annProvenanceName_maybe ModuleAnnProvenance = Nothing + +{- +************************************************************************ +* * +\subsection[RoleAnnot]{Role annotations} +* * +************************************************************************ +-} + +-- | Located Role Annotation Declaration +type LRoleAnnotDecl pass = XRec pass (RoleAnnotDecl pass) + +-- See #8185 for more info about why role annotations are +-- top-level declarations +-- | Role Annotation Declaration +data RoleAnnotDecl pass + = RoleAnnotDecl (XCRoleAnnotDecl pass) + (LIdP pass) -- type constructor + [XRec pass (Maybe Role)] -- optional annotations + | XRoleAnnotDecl !(XXRoleAnnotDecl pass) diff --git a/Language/Haskell/Syntax/Expr.hs b/Language/Haskell/Syntax/Expr.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Expr.hs @@ -0,0 +1,1515 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* + +-- | Abstract Haskell syntax for expressions. +module Language.Haskell.Syntax.Expr where + +import Language.Haskell.Syntax.Basic +import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Pat +import Language.Haskell.Syntax.Lit +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name (ModuleName) +import Language.Haskell.Syntax.Type +import Language.Haskell.Syntax.Binds + +-- others: +import GHC.Types.SourceText (StringLiteral) + +import GHC.Data.FastString (FastString) + +-- libraries: +import Data.Data hiding (Fixity(..)) +import Data.Bool +import Data.Eq +import Data.Maybe +import Data.List.NonEmpty ( NonEmpty ) + +{- Note [RecordDotSyntax field updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The extensions @OverloadedRecordDot@ @OverloadedRecordUpdate@ together +enable record updates like @a{foo.bar.baz = 1}@. Introducing this +syntax slightly complicates parsing. This note explains how it's done. + +In the event a record is being constructed or updated, it's this +production that's in play: +@ +aexp1 -> aexp1 '{' fbinds '}' { + ... + mkHsRecordPV ... $1 (snd $3) +} +@ +@fbinds@ is a list of field bindings. @mkHsRecordPV@ is a function of +the @DisambECP b@ typeclass, see Note [Ambiguous syntactic +categories]. + +The "normal" rules for an @fbind@ are: +@ +fbind + : qvar '=' texp + | qvar +@ +These rules compute values of @LHsRecField GhcPs (Located b)@. They +apply in the context of record construction, record updates, record +patterns and record expressions. That is, @b@ ranges over @HsExpr +GhcPs@, @HsPat GhcPs@ and @HsCmd GhcPs@. + +When @OverloadedRecordDot@ and @OverloadedRecordUpdate@ are both +enabled, two additional @fbind@ rules are admitted: +@ + | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp + | field TIGHT_INFIX_PROJ fieldToUpdate +@ + +These rules only make sense when parsing record update expressions +(that is, patterns and commands cannot be parsed by these rules and +neither record constructions). + +The results of these new rules cannot be represented by @LHsRecField +GhcPs (LHsExpr GhcPs)@ values as the type is defined today. We +minimize modifying existing code by having these new rules calculate +@LHsRecProj GhcPs (LHsExpr GhcPs)@ ("record projection") values +instead: +@ +newtype FieldLabelStrings = FieldLabelStrings [XRec p (DotFieldOcc p)] +type RecProj arg = HsFieldBind FieldLabelStrings arg +type LHsRecProj p arg = XRec p (RecProj arg) +@ + +The @fbind@ rule is then given the type @fbind :: { forall b. +DisambECP b => PV (Fbind b) }@ accommodating both alternatives: +@ +type Fbind b = Either + (LHsRecField GhcPs (LocatedA b)) + ( LHsRecProj GhcPs (LocatedA b)) +@ + +In @data HsExpr p@, the @RecordUpd@ constuctor indicates regular +updates vs. projection updates by means of the @rupd_flds@ member +type, an @Either@ instance: +@ + | RecordUpd + { rupd_ext :: XRecordUpd p + , rupd_expr :: LHsExpr p + , rupd_flds :: Either [LHsRecUpdField p] [LHsRecUpdProj p] + } +@ +Here, +@ +type RecUpdProj p = RecProj p (LHsExpr p) +type LHsRecUpdProj p = XRec p (RecUpdProj p) +@ +and @Left@ values indicating regular record update, @Right@ values +updates desugared to @setField@s. + +If @OverloadedRecordUpdate@ is enabled, any updates parsed as +@LHsRecField GhcPs@ values are converted to @LHsRecUpdProj GhcPs@ +values (see function @mkRdrRecordUpd@ in 'GHC.Parser.PostProcess'). +-} + +-- | RecordDotSyntax field updates + +type LFieldLabelStrings p = XRec p (FieldLabelStrings p) + +newtype FieldLabelStrings p = + FieldLabelStrings (NonEmpty (XRec p (DotFieldOcc p))) + +-- Field projection updates (e.g. @foo.bar.baz = 1@). See Note +-- [RecordDotSyntax field updates]. +type RecProj p arg = HsFieldBind (LFieldLabelStrings p) arg + +-- The phantom type parameter @p@ is for symmetry with @LHsRecField p +-- arg@ in the definition of @data Fbind@ (see GHC.Parser.Process). +type LHsRecProj p arg = XRec p (RecProj p arg) + +-- These two synonyms are used in the definition of syntax @RecordUpd@ +-- below. +type RecUpdProj p = RecProj p (LHsExpr p) +type LHsRecUpdProj p = XRec p (RecUpdProj p) + +-- | Haskell Record Update Fields. +data LHsRecUpdFields p where + -- | A regular (non-overloaded) record update. + RegularRecUpdFields + :: { xRecUpdFields :: XLHsRecUpdLabels p + , recUpdFields :: [LHsRecUpdField p p] } + -> LHsRecUpdFields p + -- | An overloaded record update. + OverloadedRecUpdFields + :: { xOLRecUpdFields :: XLHsOLRecUpdLabels p + , olRecUpdFields :: [LHsRecUpdProj p] } + -> LHsRecUpdFields p + +{- +************************************************************************ +* * +\subsection{Expressions proper} +* * +************************************************************************ +-} + +-- * Expressions proper + +-- | Located Haskell Expression +type LHsExpr p = XRec p (HsExpr p) + +------------------------- +{- Note [NoSyntaxExpr] +~~~~~~~~~~~~~~~~~~~~~~ +Syntax expressions can be missing (NoSyntaxExprRn or NoSyntaxExprTc) +for several reasons: + + 1. As described in Note [Rebindable if] + + 2. In order to suppress "not in scope: xyz" messages when a bit of + rebindable syntax does not apply. For example, when using an irrefutable + pattern in a BindStmt, we don't need a `fail` operator. + + 3. Rebindable syntax might just not make sense. For example, a BodyStmt + contains the syntax for `guard`, but that's used only in monad comprehensions. + If we had more of a whiz-bang type system, we might be able to rule this + case out statically. +-} + +-- | Syntax Expression +-- +-- SyntaxExpr is represents the function used in interpreting rebindable +-- syntax. In the parser, we have no information to supply; in the renamer, +-- we have the name of the function (but see +-- Note [Monad fail : Rebindable syntax, overloaded strings] for a wrinkle) +-- and in the type-checker we have a more elaborate structure 'SyntaxExprTc'. +-- +-- In some contexts, rebindable syntax is not implemented, and so we have +-- constructors to represent that possibility in both the renamer and +-- typechecker instantiations. +-- +-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for +-- @(>>=)@, and then instantiated by the type checker with its type args +-- etc +type family SyntaxExpr p + +{- +Note [Record selectors in the AST] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is how record selectors are expressed in GHC's AST: + +Example data type + data T = MkT { size :: Int } + +Record selectors: + | GhcPs | GhcRn | GhcTc | +----------------------------------------------------------------------------------| +size (assuming one | HsVar | HsRecSel | HsRecSel | + 'size' in scope) | | | | +----------------------|--------------|----------------------|---------------------| +.size (assuming | HsProjection | getField @"size" | getField @"size" | + OverloadedRecordDot) | | | | +----------------------|--------------|----------------------|---------------------| +e.size (assuming | HsGetField | getField @"size" e | getField @"size" e | + OverloadedRecordDot) | | | | + +NB 1: DuplicateRecordFields makes no difference to the first row of +this table, except that if 'size' is a field of more than one data +type, then a naked use of the record selector 'size' may well be +ambiguous. You have to use a qualified name. And there is no way to do +this if both data types are declared in the same module. + +NB 2: The notation getField @"size" e is short for +HsApp (HsAppType (HsVar "getField") (HsWC (HsTyLit (HsStrTy "size")) [])) e. +We track the original parsed syntax via ExpandedThingRn. + +-} + +{- +Note [Non-overloaded record field selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT { x,y :: Int } + f r x = x + y r + +This parses with HsVar for x, y, r on the RHS of f. Later, the renamer +recognises that y in the RHS of f is really a record selector, and +changes it to a HsRecSel. In contrast x is locally bound, shadowing +the record selector, and stays as an HsVar. + +The renamer adds the Name of the record selector into the XCFieldOcc +extension field, The typechecker keeps HsRecSel as HsRecSel, and +transforms the record-selector Name to an Id. +-} + +{- Note [Types in terms] +~~~~~~~~~~~~~~~~~~~~~~~~ +Types-in-terms is a notion introduced by GHC Proposal #281. It refers +to the extension of term syntax (HsExpr in the AST, infixexp2 in Parser.y) +with constructs that previously could only occur at the type level: + + * Function arrows: a -> b + * Multiplicity-polymorphic function arrows: a %m -> b (LinearTypes) + * Constraint arrows: a => b + * Universal quantification: forall a. b + * Visible universal quantification: forall a -> b + +This syntax can't be used to construct a type at the term level because `Type` +is not inhabited by any terms. Its use is limited to required type arguments: + + -- Error: + t :: Type + t = (Int -> String) + -- Not supported by GHC, `tcExpr` emits `TcRnIllegalTypeExpr` + + -- OK: + s :: String + s = vfun (Int -> String) + -- Valid use in a required type argument, + -- see `expr_to_type` (GHC.Tc.Gen.App) + where + vfun :: forall t -> Typeable t => String + vfun t = show (typeRep @t) + +In GHC, types-in-terms are implemented by the following additions to the AST of +expressions and their grammar: + + -- Language/Haskell/Syntax/Expr.hs + data HsExpr p = + ... + | HsForAll (XForAll p) (HsForAllTelescope p) (LHsExpr p) + | HsQual (XQual p) (XRec p [LHsExpr p]) (LHsExpr p) + | HsFunArr (XFunArr p) (HsMultAnnOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p) + + -- GHC/Parser.y + infixexp2 :: { ECP } + : infixexp %shift { ... } + | infixexp '->' infixexp2 { ... } + | infixexp expmult '->' infixexp2 { ... } + | infixexp '->.' infixexp2 { ... } + | expcontext '=>' infixexp2 { ... } + | forall_telescope infixexp2 { ... } + +These constructors and non-terminals mirror those found in HsType + + HsType | HsExpr + -------------+----------- + HsForAllTy | HsForAll + HsFunTy | HsFunArr + HsQualTy | HsQual + +The resulting code duplication can be removed if we unify HsExpr and HsType +into one type (#25121). + +Per the proposal, the constituents of types-in-terms are parsed and renamed +as terms, and forall-bound variables inhabit the term namespace. Example: + + h = \a -> g (forall a. Maybe a) a + +To ensure that the `a` in `Maybe a` refers to the innermost binding (i.e. to the +forall-bound `a` and not to the lambda-bound `a`), we must consistently use the +term namespace `varName` throughout the expression. We set the correct namespace +using `setTelescopeBndrsNameSpace` in GHC.Parser.PostProcess and GHC.ThToHs. + +`exprCtOrigin` returns `Shouldn'tHappenOrigin` for types-in-terms because +they either undergo the T2T translation `expr_to_type` in `tcVDQ` or result +in `TcRnIllegalTypeExpr`. +-} + +-- | A Haskell expression. +data HsExpr p + = HsVar (XVar p) + (LIdOccP p) -- ^ Variable + -- See Note [Located RdrNames] + + | HsOverLabel (XOverLabel p) FastString + -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) + + | HsIPVar (XIPVar p) + HsIPName -- ^ Implicit parameter (not in use after typechecking) + | HsOverLit (XOverLitE p) + (HsOverLit p) -- ^ Overloaded literals + + | HsLit (XLitE p) + (HsLit p) -- ^ Simple (non-overloaded) literals + + -- | Lambda, Lambda-case, and Lambda-cases + | HsLam (XLam p) + HsLamVariant -- ^ Tells whether this is for lambda, \case, or \cases + (MatchGroup p (LHsExpr p)) + -- ^ LamSingle: one match of arity >= 1 + -- LamCase: many arity-1 matches + -- LamCases: many matches of uniform arity >= 1 + + | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application + + | HsAppType (XAppTypeE p) -- After typechecking: the type argument + (LHsExpr p) + (LHsWcType (NoGhcTc p)) -- ^ Visible type application + -- + -- Explicit type argument; e.g f @Int x y + -- NB: Has wildcards, but no implicit quantification + + -- | Operator applications: + -- NB Bracketed ops such as (+) come out as Vars. + + -- NB Sadly, we need an expr for the operator in an OpApp/Section since + -- the renamer may turn a HsVar into HsRecSel or HsHole. + + | OpApp (XOpApp p) + (LHsExpr p) -- left operand + (LHsExpr p) -- operator + (LHsExpr p) -- right operand + + -- | Negation operator. Contains the negated expression and the name + -- of 'negate' + | NegApp (XNegApp p) + (LHsExpr p) + (SyntaxExpr p) + + | HsPar (XPar p) + (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] + + | SectionL (XSectionL p) + (LHsExpr p) -- operand; see Note [Sections in HsSyn] + (LHsExpr p) -- operator + | SectionR (XSectionR p) + (LHsExpr p) -- operator; see Note [Sections in HsSyn] + (LHsExpr p) -- operand + + -- | Used for explicit tuples and sections thereof + + -- Note [ExplicitTuple] + | ExplicitTuple + (XExplicitTuple p) + [HsTupArg p] + Boxity + + -- | Used for unboxed sum types + | ExplicitSum + (XExplicitSum p) + ConTag -- Alternative (one-based) + SumWidth -- Sum arity + (LHsExpr p) + + | HsCase (XCase p) + (LHsExpr p) + (MatchGroup p (LHsExpr p)) + + | HsIf (XIf p) -- GhcPs: this is a Bool; False <=> do not use + -- rebindable syntax + (LHsExpr p) -- predicate + (LHsExpr p) -- then part + (LHsExpr p) -- else part + + -- | Multi-way if + | HsMultiIf (XMultiIf p) (NonEmpty (LGRHS p (LHsExpr p))) + + -- | let(rec) + | HsLet (XLet p) + (HsLocalBinds p) + (LHsExpr p) + + | HsDo (XDo p) -- Type of the whole expression + HsDoFlavour + (XRec p [ExprLStmt p]) -- "do":one or more stmts + + -- | Syntactic list: [a,b,c,...] + + -- See Note [Empty lists] + | ExplicitList + (XExplicitList p) -- Gives type of components of list + [LHsExpr p] + + -- | Record construction + | RecordCon + { rcon_ext :: XRecordCon p + , rcon_con :: XRec p (ConLikeP p) -- The constructor + , rcon_flds :: HsRecordBinds p } -- The fields + + -- | Record update + | RecordUpd + { rupd_ext :: XRecordUpd p + , rupd_expr :: LHsExpr p + , rupd_flds :: LHsRecUpdFields p + } + -- For a type family, the arg types are of the *instance* tycon, + -- not the family tycon + + -- | Record field selection e.g @z.x@. + + -- This case only arises when the OverloadedRecordDot langauge + -- extension is enabled. See Note [Record selectors in the AST]. + | HsGetField { + gf_ext :: XGetField p + , gf_expr :: LHsExpr p + , gf_field :: XRec p (DotFieldOcc p) + } + + -- | Record field selector. e.g. @(.x)@ or @(.x.y)@ + -- + -- This case only arises when the OverloadedRecordDot langauge + -- extensions is enabled. See Note [Record selectors in the AST]. + + | HsProjection { + proj_ext :: XProjection p + , proj_flds :: NonEmpty (DotFieldOcc p) + } + + -- | Expression with an explicit type signature. @e :: type@ + | ExprWithTySig + (XExprWithTySig p) + + (LHsExpr p) + (LHsSigWcType (NoGhcTc p)) + + -- | Arithmetic sequence + | ArithSeq + (XArithSeq p) + (Maybe (SyntaxExpr p)) + -- For OverloadedLists, the fromList witness + (ArithSeqInfo p) + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + + ----------------------------------------------------------- + -- MetaHaskell Extensions + + | HsTypedBracket (XTypedBracket p) (LHsExpr p) + | HsUntypedBracket (XUntypedBracket p) (HsQuote p) + | HsTypedSplice (XTypedSplice p) (HsTypedSplice p) -- `$$z` or `$$(f 4)` + | HsUntypedSplice (XUntypedSplice p) (HsUntypedSplice p) + + ----------------------------------------------------------- + -- Arrow notation extension + + -- | @proc@ notation for Arrows + | HsProc (XProc p) + (LPat p) -- arrow abstraction, proc + (LHsCmdTop p) -- body of the abstraction + -- always has an empty stack + + --------------------------------------- + -- static pointers extension + | HsStatic (XStatic p) -- Free variables of the body, and type after typechecking + (LHsExpr p) -- Body + + --------------------------------------- + -- Expressions annotated with pragmas, written as {-# ... #-} + | HsPragE (XPragE p) (HsPragE p) (LHsExpr p) + + -- Embed the syntax of types into expressions. + -- Used with @RequiredTypeArguments@, e.g. @fn (type (Int -> Bool))@. + | HsEmbTy (XEmbTy p) + (LHsWcType (NoGhcTc p)) + + -- | Holes in expressions, i.e. '_'. + -- See Note [Holes in expressions] in GHC.Tc.Types.Constraint. + | HsHole (XHole p) + + -- | Forall-types @forall tvs. t@ and @forall tvs -> t@. + -- Used with @RequiredTypeArguments@, e.g. @fn (forall a. Proxy a)@. + -- See Note [Types in terms] + | HsForAll (XForAll p) (HsForAllTelescope p) (LHsExpr p) + + -- Constrained types @ctx => t@. + -- Used with @RequiredTypeArguments@, e.g. @fn (Bounded a => a)@. + -- See Note [Types in terms] + | HsQual (XQual p) (XRec p [LHsExpr p]) (LHsExpr p) + + -- | Function types @a -> b@. + -- Used with @RequiredTypeArguments@, e.g. @fn (Int -> Bool)@. + -- See Note [Types in terms] + | HsFunArr (XFunArr p) (HsMultAnnOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p) + + | XExpr !(XXExpr p) + -- Note [Trees That Grow] in Language.Haskell.Syntax.Extension for the + -- general idea, and Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr + -- for an example of how we use it. + +-- --------------------------------------------------------------------- + +data DotFieldOcc p + = DotFieldOcc + { dfoExt :: XCDotFieldOcc p + , dfoLabel :: XRec p FieldLabelString + } + | XDotFieldOcc !(XXDotFieldOcc p) + +-- --------------------------------------------------------------------- + +-- | A pragma, written as {-# ... #-}, that may appear within an expression. +data HsPragE p + = HsPragSCC (XSCC p) + StringLiteral -- "set cost centre" SCC pragma + + | XHsPragE !(XXPragE p) + +-- | Located Haskell Tuple Argument +-- +-- 'HsTupArg' is used for tuple sections +-- @(,a,)@ is represented by +-- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@ +-- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@ +type LHsTupArg id = XRec id (HsTupArg id) + +-- | Haskell Tuple Argument +data HsTupArg id + = Present (XPresent id) (LHsExpr id) -- ^ The argument + | Missing (XMissing id) -- ^ The argument is missing, but this is its type + | XTupArg !(XXTupArg id) -- ^ Extension point; see Note [Trees That Grow] + -- in Language.Haskell.Syntax.Extension + +-- | Which kind of lambda case are we dealing with? +data HsLamVariant + = LamSingle -- ^ `\p -> e` + | LamCase -- ^ `\case pi -> ei ` + | LamCases -- ^ `\cases psi -> ei` + deriving (Data, Eq) + +{- +Note [Parens in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~ +HsPar (and ParPat in patterns, HsParTy in types) is used as follows + + * HsPar is required; the pretty printer does not add parens. + + * HsPars are respected when rearranging operator fixities. + So a * (b + c) means what it says (where the parens are an HsPar) + + * For ParPat and HsParTy the pretty printer does add parens but this should be + a no-op for ParsedSource, based on the pretty printer round trip feature + introduced in + https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c + + * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or + not they are strictly necessary. This should be addressed when #13238 is + completed, to be treated the same as HsPar. + + +Note [Sections in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~ +Sections should always appear wrapped in an HsPar, thus + HsPar (SectionR ...) +The parser parses sections in a wider variety of situations +(See Note [Parsing sections]), but the renamer checks for those +parens. This invariant makes pretty-printing easier; we don't need +a special case for adding the parens round sections. + +Note [Rebindable if] +~~~~~~~~~~~~~~~~~~~~ +The rebindable syntax for 'if' is a bit special, because when +rebindable syntax is *off* we do not want to treat + (if c then t else e) +as if it was an application (ifThenElse c t e). Why not? +Because we allow an 'if' to return *unboxed* results, thus + if blah then 3# else 4# +whereas that would not be possible using a all to a polymorphic function +(because you can't call a polymorphic function at an unboxed type). + +So we use NoSyntaxExpr to mean "use the old built-in typing rule". + +A further complication is that, in the `deriving` code, we never want +to use rebindable syntax. So, even in GhcPs, we want to denote whether +to use rebindable syntax or not. This is done via the type instance +for XIf GhcPs. + +Note [Record Update HsWrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a wrapper in RecordUpd which is used for the *required* +constraints for pattern synonyms. This wrapper is created in the +typechecking and is then directly used in the desugaring without +modification. + +For example, if we have the record pattern synonym P, + pattern P :: (Show a) => a -> Maybe a + pattern P{x} = Just x + + foo = (Just True) { x = False } +then `foo` desugars to something like + foo = case Just True of + P x -> P False +hence we need to provide the correct dictionaries to P's matcher on +the RHS so that we can build the expression. + +Note [Located RdrNames] +~~~~~~~~~~~~~~~~~~~~~~~ +A number of syntax elements have seemingly redundant locations +attached to them. This is deliberate, to allow transformations making +use of the exact print annotations to easily correlate a Located Name +in the RenamedSource with a Located RdrName in the ParsedSource. + +There are unfortunately enough differences between the ParsedSource +and the RenamedSource that the exact print annotations cannot be used +directly with RenamedSource, so this allows a simple mapping to be +used based on the location. + +Note [ExplicitTuple] +~~~~~~~~~~~~~~~~~~~~ +An ExplicitTuple is never just a data constructor like (,,,). +That is, the `[LHsTupArg p]` argument of `ExplicitTuple` has at least +one `Present` member (and is thus never empty). + +A tuple data constructor like () or (,,,) is parsed as an `HsVar`, not an +`ExplicitTuple`, and stays that way. This is important for two reasons: + + 1. We don't need -XTupleSections for (,,,) + 2. The type variables in (,,,) can be instantiated with visible type application. + That is, + + (,,) :: forall a b c. a -> b -> c -> (a,b,c) + (True,,) :: forall {b} {c}. b -> c -> (Bool,b,c) + + Note that the tuple section has *inferred* arguments, while the data + constructor has *specified* ones. + (See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + for background.) + +Sadly, the grammar for this is actually ambiguous, and it's only thanks to the +preference of a shift in a shift/reduce conflict that the parser works as this +Note details. Search for a reference to this Note in GHC.Parser for further +explanation. + +Note [Empty lists] +~~~~~~~~~~~~~~~~~~ +An empty list could be considered either a data constructor (stored with +HsVar) or an ExplicitList. This Note describes how empty lists flow through the +various phases and why. + +Parsing +------- +An empty list is parsed by the sysdcon nonterminal. It thus comes to life via +HsVar nilDataCon (defined in GHC.Builtin.Types). A freshly-parsed (HsExpr GhcPs) empty list +is never a ExplicitList. + +Renaming +-------- +If -XOverloadedLists is enabled, we must type-check the empty list as if it +were a call to fromListN. (This is true regardless of the setting of +-XRebindableSyntax.) This is very easy if the empty list is an ExplicitList, +but an annoying special case if it's an HsVar. So the renamer changes a +HsVar nilDataCon to an ExplicitList [], but only if -XOverloadedLists is on. +(Why not always? Read on, dear friend.) This happens in the HsVar case of rnExpr. + +Type-checking +------------- +We want to accept an expression like [] @Int. To do this, we must infer that +[] :: forall a. [a]. This is easy if [] is a HsVar with the right DataCon inside. +However, the type-checking for explicit lists works differently: [x,y,z] is never +polymorphic. Instead, we unify the types of x, y, and z together, and use the +unified type as the argument to the cons and nil constructors. Thus, treating +[] as an empty ExplicitList in the type-checker would prevent [] @Int from working. + +However, if -XOverloadedLists is on, then [] @Int really shouldn't be allowed: +it's just like fromListN 0 [] @Int. Since + fromListN :: forall list. IsList list => Int -> [Item list] -> list +that expression really should be rejected. Thus, the renamer's behaviour is +exactly what we want: treat [] as a datacon when -XNoOverloadedLists, and as +an empty ExplicitList when -XOverloadedLists. + +See also #13680, which requested [] @Int to work. +-} + + +{- +HsSyn records exactly where the user put parens, with HsPar. +So generally speaking we print without adding any parens. +However, some code is internally generated, and in some places +parens are absolutely required; so for these places we use +pprParendLExpr (but don't print double parens of course). + +For operator applications we don't add parens, because the operator +fixities should do the job, except in debug mode (-dppr-debug) so we +can see the structure of the parse tree. +-} + +{- +************************************************************************ +* * +\subsection{Commands (in arrow abstractions)} +* * +************************************************************************ + +We re-use HsExpr to represent these. +-} + +-- | Located Haskell Command (for arrow syntax) +type LHsCmd id = XRec id (HsCmd id) + +-- | Haskell Command (e.g. a "statement" in an Arrow proc block) +data HsCmd id + = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) + (XCmdArrApp id) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + + | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) + (XCmdArrForm id) + (LHsExpr id) -- The operator. + -- After type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + LexicalFixity -- Whether the operator appeared prefix or infix when + -- parsed. + [LHsCmdTop id] -- argument commands + + | HsCmdApp (XCmdApp id) + (LHsCmd id) + (LHsExpr id) + + -- | Lambda-case + -- + | HsCmdLam (XCmdLamCase id) HsLamVariant + (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's + + | HsCmdPar (XCmdPar id) + (LHsCmd id) -- parenthesised command + + | HsCmdCase (XCmdCase id) + (LHsExpr id) + (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's + + | HsCmdIf (XCmdIf id) + (SyntaxExpr id) -- cond function + (LHsExpr id) -- predicate + (LHsCmd id) -- then part + (LHsCmd id) -- else part + + | HsCmdLet (XCmdLet id) + (HsLocalBinds id) -- let(rec) + (LHsCmd id) + + | HsCmdDo (XCmdDo id) -- Type of the whole expression + (XRec id [CmdLStmt id]) + + | XCmd !(XXCmd id) -- Extension point; see Note [Trees That Grow] + -- in Language.Haskell.Syntax.Extension + + +-- | Haskell arrow application type. +data HsArrAppType + -- | First order arrow application '-<' + = HsHigherOrderApp + -- | Higher order arrow application '-<<' + | HsFirstOrderApp + deriving Data + +{- | Top-level command, introducing a new arrow. +This may occur inside a proc (where the stack is empty) or as an +argument of a command-forming operator. +-} + +-- | Located Haskell Top-level Command +type LHsCmdTop p = XRec p (HsCmdTop p) + +-- | Haskell Top-level Command +data HsCmdTop p + = HsCmdTop (XCmdTop p) + (LHsCmd p) + | XCmdTop !(XXCmdTop p) -- Extension point; see Note [Trees That Grow] + -- in Language.Haskell.Syntax.Extension + +----------------------- + +{- +************************************************************************ +* * +\subsection{Record binds} +* * +************************************************************************ +-} + +-- | Haskell Record Bindings +type HsRecordBinds p = HsRecFields p (LHsExpr p) + +{- +************************************************************************ +* * +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} +* * +************************************************************************ + +@Match@es are sets of pattern bindings and right hand sides for +functions, patterns or case branches. For example, if a function @g@ +is defined as: +\begin{verbatim} +g (x,y) = y +g ((x:ys),y) = y+1, +\end{verbatim} +then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. + +It is always the case that each element of an @[Match]@ list has the +same number of @pats@s inside it. This corresponds to saying that +a function defined by pattern matching must have the same number of +patterns in each equation. +-} + +data MatchGroup p body + = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result, and origin + , mg_alts :: XRec p [LMatch p body] + -- The alternatives, see Note [Empty mg_alts] for what it means if 'mg_alts' is empty. + } + -- The type is the type of the entire group + -- t1 -> ... -> tn -> tr + -- where there are n patterns + + | XMatchGroup !(XXMatchGroup p body) + +-- | Located Match +type LMatch id body = XRec id (Match id body) + +data Match p body + = Match { + m_ext :: XCMatch p body, + m_ctxt :: HsMatchContext (LIdP (NoGhcTc p)), -- See Note [m_ctxt in Match] + m_pats :: XRec p [LPat p], -- The patterns + m_grhss :: (GRHSs p body) + } + | XMatch !(XXMatch p body) + +{- +Note [m_ctxt in Match] +~~~~~~~~~~~~~~~~~~~~~~ +A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and +so on. + +In order to simplify tooling processing and pretty print output, the provenance +is captured in an HsMatchContext. + +This is particularly important for the exact print annotations for a +multi-equation FunBind. + +The parser initially creates a FunBind with a single Match in it for +every function definition it sees. + +These are then grouped together by getMonoBind into a single FunBind, +where all the Matches are combined. + +In the process, all the original FunBind fun_id's bar one are +discarded, including the locations. + +This causes a problem for source to source conversions via exact print +annotations, so the original fun_ids and infix flags are preserved in +the Match, when it originates from a FunBind. + +Example infix function definition requiring individual exact print +annotations + + (&&& ) [] [] = [] + xs &&& [] = xs + ( &&& ) [] ys = ys + + +Note [Empty mg_alts] +~~~~~~~~~~~~~~~~~~~~~~ +A `MatchGroup` for a function definition must have at least one alt, as it is not possible to +define a function by zero clauses — the compiler would consider this a missing definition, +rather than one with no clauses. + +However, a `MatchGroup` for a `case` or `\ case` expression may be empty, as such an expression +may have zero branches. (Note: A `\ cases` expression may not have zero branches; see GHC +proposal 302). + +Ergo, if we have no alts, it must be either a `case` or a `\ case` expression; such expressions +have match arity 1. + +-} + + +-- | Guarded Right-Hand Sides +-- +-- GRHSs are used both for pattern bindings and for Matches +data GRHSs p body + = GRHSs { + grhssExt :: XCGRHSs p body, + grhssGRHSs :: NonEmpty (LGRHS p body), -- ^ Guarded RHSs + grhssLocalBinds :: HsLocalBinds p -- ^ The where clause + } + | XGRHSs !(XXGRHSs p body) + +-- | Located Guarded Right-Hand Side +type LGRHS id body = XRec id (GRHS id body) + +-- | Guarded Right Hand Side. +data GRHS p body = GRHS (XCGRHS p body) + [GuardLStmt p] -- Guards + body -- Right hand side + | XGRHS !(XXGRHS p body) + +-- We know the list must have at least one @Match@ in it. + +{- +************************************************************************ +* * +\subsection{Do stmts and list comprehensions} +* * +************************************************************************ +-} + +-- | Located @do@ block Statement +type LStmt id body = XRec id (StmtLR id id body) + +-- | Located Statement with separate Left and Right id's +type LStmtLR idL idR body = XRec idL (StmtLR idL idR body) + +-- | @do@ block Statement +type Stmt id body = StmtLR id id body + +-- | Command Located Statement +type CmdLStmt id = LStmt id (LHsCmd id) + +-- | Command Statement +type CmdStmt id = Stmt id (LHsCmd id) + +-- | Expression Located Statement +type ExprLStmt id = LStmt id (LHsExpr id) + +-- | Expression Statement +type ExprStmt id = Stmt id (LHsExpr id) + +-- | Guard Located Statement +type GuardLStmt id = LStmt id (LHsExpr id) + +-- | Guard Statement +type GuardStmt id = Stmt id (LHsExpr id) + +-- | Ghci Located Statement +type GhciLStmt id = LStmt id (LHsExpr id) + +-- | Ghci Statement +type GhciStmt id = Stmt id (LHsExpr id) + +-- The SyntaxExprs in here are used *only* for do-notation and monad +-- comprehensions, which have rebindable syntax. Otherwise they are unused. +data StmtLR idL idR body -- body should always be (LHs**** idR) + = LastStmt -- Always the last Stmt in ListComp, MonadComp, + -- and (after the renamer, see GHC.Rename.Expr.checkLastStmt) DoExpr, MDoExpr + -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff + (XLastStmt idL idR body) + body + (Maybe Bool) -- Whether return was stripped + -- Just True <=> return with a dollar was stripped by ApplicativeDo + -- Just False <=> return without a dollar was stripped by ApplicativeDo + -- Nothing <=> Nothing was stripped + (SyntaxExpr idR) -- The return operator + -- The return operator is used only for MonadComp + -- For ListComp we use the baked-in 'return' + -- For DoExpr, MDoExpr, we don't apply a 'return' at all + -- See Note [Monad Comprehensions] + + | BindStmt (XBindStmt idL idR body) + -- ^ Post renaming has optional fail and bind / (>>=) operator. + -- Post typechecking, also has multiplicity of the argument + -- and the result type of the function passed to bind; + -- that is, (P, S) in (>>=) :: Q -> (R % P -> S) -> T + -- See Note [The type of bind in Stmts] + (LPat idL) + body + + | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type + -- of the RHS (used for arrows) + body -- See Note [BodyStmt] + (SyntaxExpr idR) -- The (>>) operator + (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp + -- See notes [Monad Comprehensions] + + | LetStmt (XLetStmt idL idR body) (HsLocalBindsLR idL idR) + + -- ParStmts only occur in a list/monad comprehension + | ParStmt (XParStmt idL idR body) -- Post typecheck, + -- S in (>>=) :: Q -> (R -> S) -> T + (NonEmpty (ParStmtBlock idL idR)) + (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions + (SyntaxExpr idR) -- The `>>=` operator + -- See notes [Monad Comprehensions] + -- After renaming, the ids are the binders + -- bound by the stmts and used after them + + | TransStmt { + trS_ext :: XTransStmt idL idR body, -- Post typecheck, + -- R in (>>=) :: Q -> (R -> S) -> T + trS_form :: TransForm, + trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' + -- which generates the tuples to be grouped + + trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map] + + trS_using :: LHsExpr idR, + trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) + -- Invariant: if trS_form = GroupBy, then grp_by = Just e + + trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for + -- the inner monad comprehensions + trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator + trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring + -- Only for 'group' forms + -- Just a simple HsExpr, because it's + -- too polymorphic for tcSyntaxOp + } -- See Note [Monad Comprehensions] + + -- Recursive statement (see Note [How RecStmt works] below) + | RecStmt + { recS_ext :: XRecStmt idL idR body + , recS_stmts :: XRec idR [LStmtLR idL idR body] + -- Assume XRec is the same for idL and idR, pick one arbitrarily + + -- The next two fields are only valid after renaming + , recS_later_ids :: [IdP idR] + -- The ids are a subset of the variables bound by the + -- stmts that are used in stmts that follow the RecStmt + + , recS_rec_ids :: [IdP idR] + -- Ditto, but these variables are the "recursive" ones, + -- that are used before they are bound in the stmts of + -- the RecStmt. + -- An Id can be in both groups + -- Both sets of Ids are (now) treated monomorphically + -- See Note [How RecStmt works] for why they are separate + + -- Rebindable syntax + , recS_bind_fn :: SyntaxExpr idR -- The bind function + , recS_ret_fn :: SyntaxExpr idR -- The return function + , recS_mfix_fn :: SyntaxExpr idR -- The mfix function + } + | XStmtLR !(XXStmtLR idL idR body) + +data TransForm -- The 'f' below is the 'using' function, 'e' is the by function + = ThenForm -- then f or then f by e (depending on trS_by) + | GroupForm -- then group using f or then group by e using f (depending on trS_by) + deriving Data + +-- | Parenthesised Statement Block +data ParStmtBlock idL idR + = ParStmtBlock + (XParStmtBlock idL idR) + [ExprLStmt idL] + [IdP idR] -- The variables to be returned + (SyntaxExpr idR) -- The return operator + | XParStmtBlock !(XXParStmtBlock idL idR) + +-- | The fail operator +-- +-- This is used for `.. <-` "bind statements" in do notation, including +-- non-monadic "binds" in applicative. +-- +-- The fail operator is 'Just expr' if it potentially fail monadically. if the +-- pattern match cannot fail, or shouldn't fail monadically (regular incomplete +-- pattern exception), it is 'Nothing'. +-- +-- See Note [Monad fail : Rebindable syntax, overloaded strings] for the type of +-- expression in the 'Just' case, and why it is so. +-- +-- See Note [Failing pattern matches in Stmts] for which contexts for +-- '@BindStmt@'s should use the monadic fail and which shouldn't. +type FailOperator id = Maybe (SyntaxExpr id) + +{- +Note [The type of bind in Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Stmts, notably BindStmt, keep the (>>=) bind operator. +We do NOT assume that it has type + (>>=) :: m a -> (a -> m b) -> m b +In some cases (see #303, #1537) it might have a more +exotic type, such as + (>>=) :: m i j a -> (a -> m j k b) -> m i k b +So we must be careful not to make assumptions about the type. +In particular, the monad may not be uniform throughout. + +Note [TransStmt binder map] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The [(idR,idR)] in a TransStmt behaves as follows: + + * Before renaming: [] + + * After renaming: + [ (x27,x27), ..., (z35,z35) ] + These are the variables + bound by the stmts to the left of the 'group' + and used either in the 'by' clause, + or in the stmts following the 'group' + Each item is a pair of identical variables. + + * After typechecking: + [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] + Each pair has the same unique, but different *types*. + +Note [BodyStmt] +~~~~~~~~~~~~~~~ +BodyStmts are a bit tricky, because what they mean +depends on the context. Consider the following contexts: + + A do expression of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E any_ty: do { ....; E; ... } + E :: m any_ty + Translation: E >> ... + + A list comprehensions of type [elt_ty] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E Bool: [ .. | .... E ] + [ .. | ..., E, ... ] + [ .. | .... | ..., E | ... ] + E :: Bool + Translation: if E then fail else ... + + A guard list, guarding a RHS of type rhs_ty + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... + E :: Bool + Translation: if E then fail else ... + + A monad comprehension of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E Bool: [ .. | .... E ] + E :: Bool + Translation: guard E >> ... + +Array comprehensions are handled like list comprehensions. + +Note [How RecStmt works] +~~~~~~~~~~~~~~~~~~~~~~~~ +Example: + HsDo [ BindStmt x ex + + , RecStmt { recS_rec_ids = [a, c] + , recS_stmts = [ BindStmt b (return (a,c)) + , LetStmt a = ...b... + , BindStmt c ec ] + , recS_later_ids = [a, b] + + , return (a b) ] + +Here, the RecStmt binds a,b,c; but + - Only a,b are used in the stmts *following* the RecStmt, + - Only a,c are used in the stmts *inside* the RecStmt + *before* their bindings + +Why do we need *both* rec_ids and later_ids? For monads they could be +combined into a single set of variables, but not for arrows. That +follows from the types of the respective feedback operators: + + mfix :: MonadFix m => (a -> m a) -> m a + loop :: ArrowLoop a => a (b,d) (c,d) -> a b c + +* For mfix, the 'a' covers the union of the later_ids and the rec_ids +* For 'loop', 'c' is the later_ids and 'd' is the rec_ids + +Note [Typing a RecStmt] +~~~~~~~~~~~~~~~~~~~~~~~ +A (RecStmt stmts) types as if you had written + + (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) -> + do { stmts + ; return (v1,..vn, r1, ..., rm) }) + +where v1..vn are the later_ids + r1..rm are the rec_ids + +Note [Monad Comprehensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Monad comprehensions require separate functions like 'return' and +'>>=' for desugaring. These functions are stored in the statements +used in monad comprehensions. For example, the 'return' of the 'LastStmt' +expression is used to lift the body of the monad comprehension: + + [ body | stmts ] + => + stmts >>= \bndrs -> return body + +In transform and grouping statements ('then ..' and 'then group ..') the +'return' function is required for nested monad comprehensions, for example: + + [ body | stmts, then f, rest ] + => + f [ env | stmts ] >>= \bndrs -> [ body | rest ] + +BodyStmts require the 'Control.Monad.guard' function for boolean +expressions: + + [ body | exp, stmts ] + => + guard exp >> [ body | stmts ] + +Parallel statements require the 'Control.Monad.Zip.mzip' function: + + [ body | stmts1 | stmts2 | .. ] + => + mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body + +In any other context than 'MonadComp', the fields for most of these +'SyntaxExpr's stay bottom. + + +Note [Applicative BodyStmt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt +as if it was a BindStmt with a wildcard pattern. For example, + + do + x <- A + B + return x + +is transformed as if it were + + do + x <- A + _ <- B + return x + +so it transforms to + + (\(x,_) -> x) <$> A <*> B + +But we have to remember when we treat a BodyStmt like a BindStmt, +because in error messages we want to emit the original syntax the user +wrote, not our internal representation. So ApplicativeArgOne has a +Bool flag that is True when the original statement was a BodyStmt, so +that we can pretty-print it correctly. +-} + + +{- +************************************************************************ +* * + Template Haskell quotation brackets +* * +************************************************************************ +-} + +{- +Note [Quasi-quote overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "quasi-quote" extension is described by Geoff Mainland's paper +"Why it's nice to be quoted: quasiquoting for Haskell" (Haskell +Workshop 2007). + +Briefly, one writes + [p| stuff |] +and the arbitrary string "stuff" gets parsed by the parser 'p', whose type +should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be defined in +another module, because we are going to run it here. It's a bit like an +/untyped/ TH splice where the parser is applied the "stuff" as a string, thus: + $(p "stuff") + +Notice that it's an /untyped/ TH splice: it can occur in patterns and types, as well +as in expressions; and it runs in the renamer. +-} + +-- | Haskell Splice +data HsUntypedSplice id + = HsUntypedSpliceExpr -- $z or $(f 4) + (XUntypedSpliceExpr id) + (LHsExpr id) + + | HsQuasiQuote -- See Note [Quasi-quote overview] + (XQuasiQuote id) + (LIdP id) -- The quoter (the bit between `[` and `|`) + (XRec id FastString) -- The enclosed string + + | XUntypedSplice !(XXUntypedSplice id) -- Extension point; see Note [Trees That Grow] + -- in Language.Haskell.Syntax.Extension + +data HsTypedSplice id + = HsTypedSpliceExpr (XTypedSpliceExpr id) (LHsExpr id) + | XTypedSplice !(XXTypedSplice id) + +-- | Haskell (Untyped) Quote = Expr + Pat + Type + Var +data HsQuote p + = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |] + | PatBr (XPatBr p) (LPat p) -- [p| pat |] + | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser + | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer + | TypBr (XTypBr p) (LHsType p) -- [t| type |] + | VarBr (XVarBr p) Bool (LIdP p) -- True: 'x, False: ''T + | XQuote !(XXQuote p) -- Extension point; see Note [Trees That Grow] + -- in Language.Haskell.Syntax.Extension + +{- +************************************************************************ +* * +\subsection{Enumerations and list comprehensions} +* * +************************************************************************ +-} + +-- | Arithmetic Sequence Information +data ArithSeqInfo id + = From (LHsExpr id) + | FromThen (LHsExpr id) + (LHsExpr id) + | FromTo (LHsExpr id) + (LHsExpr id) + | FromThenTo (LHsExpr id) + (LHsExpr id) + (LHsExpr id) +-- AZ: Should ArithSeqInfo have a TTG extension? + +{- +************************************************************************ +* * +\subsection{HsMatchCtxt} +* * +************************************************************************ +-} + +-- | Haskell Match Context +-- +-- Context of a pattern match. This is more subtle than it would seem. See +-- Note [FunBind vs PatBind]. +data HsMatchContext fn + = FunRhs + -- ^ A pattern matching on an argument of a + -- function binding + { mc_fun :: fn -- ^ function binder of @f@ + -- See Note [mc_fun field of FunRhs] + -- See #20415 for a long discussion about this field + , mc_fixity :: LexicalFixity -- ^ fixing of @f@ + , mc_strictness :: SrcStrictness -- ^ was @f@ banged? + -- See Note [FunBind vs PatBind] + , mc_an :: XFunRhs + } + | CaseAlt -- ^Patterns and guards in a case alternative + | LamAlt HsLamVariant -- ^Patterns and guards in @\@, @\case@ and @\cases@ + | IfAlt -- ^Guards of a multi-way if alternative + | ArrowMatchCtxt -- ^A pattern match inside arrow notation + HsArrowMatchContext + | PatBindRhs -- ^A pattern binding eg [y] <- e = e + | PatBindGuards -- ^Guards of pattern bindings, e.g., + -- (Just b) | Just _ <- x = e + -- | otherwise = e' + + | RecUpd -- ^Record update [used only in GHC.HsToCore.Expr to + -- tell matchWrapper what sort of + -- runtime error message to generate] + + | StmtCtxt (HsStmtContext fn) -- ^Pattern of a do-stmt, list comprehension, + -- pattern guard, etc + + | ThPatSplice -- ^A Template Haskell pattern splice + | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] + | PatSyn -- ^A pattern synonym declaration + | LazyPatCtx -- ^An irrefutable pattern + +{- Note [mc_fun field of FunRhs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsMatchContext is parameterised over `fn`, the function binder stored in `FunRhs`. +This makes pretty printing easy. + +In the use of `HsMatchContext` in `Match`, it is parameterised thus: + data Match p body = Match { m_ctxt :: HsMatchContext (LIdP (NoGhcTc p)), ... } +So in a Match, the mc_fun field `FunRhs` will be a `RdrName` in pass `GhcPs`, a `Name` +in `GhcRn`, and (importantly) still a `Name` in `GhcTc` -- not an `Id`. +See Note [NoGhcTc] in GHC.Hs.Extension. + +* Why a `Name` in the typechecker phase? Because: + * A `Name` is all we need, as it turns out. + * Using an `Id` involves knot-tying in the monad, which led to #22695. + +* Why a /located/ name? Because we want to record the location of the Id + on the LHS of /this/ match. See Note [m_ctxt in Match]. Example: + (&&&) [] [] = [] + xs &&& [] = xs + The two occurrences of `&&&` have different locations. + +* Why parameterise `HsMatchContext` over `fn` rather than over the pass `p`? + Because during typechecking (specifically GHC.Tc.Gen.Match.tcMatch) we need to convert + HsMatchContext (LIdP (NoGhcTc GhcRn)) --> HsMatchContext (LIdP (NoGhcTc GhcTc)) + With this parameterisation it's easy; if it was parametersed over `p` we'd need + a recursive traversal of the HsMatchContext. + +See #20415 for a long discussion. +-} + +-- | Haskell Statement Context. +data HsStmtContext fn + = HsDoStmt HsDoFlavour -- ^ Context for HsDo (do-notation and comprehensions) + | PatGuard (HsMatchContext fn) -- ^ Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext fn) -- ^ A branch of a parallel stmt + | TransStmtCtxt (HsStmtContext fn) -- ^ A branch of a transform stmt + | ArrowExpr -- ^ do-notation in an arrow-command context + +-- | Haskell arrow match context. +data HsArrowMatchContext + = ProcExpr -- ^ A proc expression + | ArrowCaseAlt -- ^ A case alternative inside arrow notation + | ArrowLamAlt HsLamVariant -- ^ A \, \case or \cases alternative inside arrow notation + +data HsDoFlavour + = DoExpr (Maybe ModuleName) -- ^[ModuleName.]do { ... } + | MDoExpr (Maybe ModuleName) -- ^[ModuleName.]mdo { ... } ie recursive do-expression + | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs + | ListComp + | MonadComp + deriving (Eq, Data) + +qualifiedDoModuleName_maybe :: HsStmtContext fn -> Maybe ModuleName +qualifiedDoModuleName_maybe ctxt = case ctxt of + HsDoStmt (DoExpr m) -> m + HsDoStmt (MDoExpr m) -> m + _ -> Nothing + +isPatSynCtxt :: HsMatchContext fn -> Bool +isPatSynCtxt ctxt = + case ctxt of + PatSyn -> True + _ -> False + +isComprehensionContext :: HsStmtContext fn -> Bool +-- Uses comprehension syntax [ e | quals ] +isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c +isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c +isComprehensionContext ArrowExpr = False +isComprehensionContext (PatGuard _) = False +isComprehensionContext (HsDoStmt flavour) = isDoComprehensionContext flavour + +isDoComprehensionContext :: HsDoFlavour -> Bool +isDoComprehensionContext GhciStmtCtxt = False +isDoComprehensionContext (DoExpr _) = False +isDoComprehensionContext (MDoExpr _) = False +isDoComprehensionContext ListComp = True +isDoComprehensionContext MonadComp = True + +-- | Is this a monadic context? +isMonadStmtContext :: HsStmtContext fn -> Bool +isMonadStmtContext (ParStmtCtxt ctxt) = isMonadStmtContext ctxt +isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt +isMonadStmtContext (HsDoStmt flavour) = isMonadDoStmtContext flavour +isMonadStmtContext (PatGuard _) = False +isMonadStmtContext ArrowExpr = False + +isMonadDoStmtContext :: HsDoFlavour -> Bool +isMonadDoStmtContext ListComp = False +isMonadDoStmtContext MonadComp = True +isMonadDoStmtContext DoExpr{} = True +isMonadDoStmtContext MDoExpr{} = True +isMonadDoStmtContext GhciStmtCtxt = True + +isMonadCompContext :: HsStmtContext fn -> Bool +isMonadCompContext (HsDoStmt flavour) = isMonadDoCompContext flavour +isMonadCompContext (ParStmtCtxt _) = False +isMonadCompContext (TransStmtCtxt _) = False +isMonadCompContext (PatGuard _) = False +isMonadCompContext ArrowExpr = False + +isMonadDoCompContext :: HsDoFlavour -> Bool +isMonadDoCompContext MonadComp = True +isMonadDoCompContext ListComp = False +isMonadDoCompContext GhciStmtCtxt = False +isMonadDoCompContext (DoExpr _) = False +isMonadDoCompContext (MDoExpr _) = False diff --git a/Language/Haskell/Syntax/Expr.hs-boot b/Language/Haskell/Syntax/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Expr.hs-boot @@ -0,0 +1,29 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} + +-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* +module Language.Haskell.Syntax.Expr where + +import Language.Haskell.Syntax.Extension ( XRec ) +import Data.Kind ( Type ) + +import Prelude (Eq) +import Data.Data (Data) + +type role HsExpr nominal +type role MatchGroup nominal nominal +type role GRHSs nominal nominal +type role HsUntypedSplice nominal +data HsExpr (i :: Type) +data HsUntypedSplice (i :: Type) +data MatchGroup (a :: Type) (body :: Type) +data GRHSs (a :: Type) (body :: Type) +type family SyntaxExpr (i :: Type) + +type LHsExpr a = XRec a (HsExpr a) + +data HsDoFlavour +instance Eq HsDoFlavour +instance Data HsDoFlavour diff --git a/Language/Haskell/Syntax/Extension.hs b/Language/Haskell/Syntax/Extension.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Extension.hs @@ -0,0 +1,782 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} -- for unXRec, etc. +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension + +-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* +module Language.Haskell.Syntax.Extension where + +-- This module captures the type families to precisely identify the extension +-- points for GHC.Hs syntax + +import Data.Type.Equality (type (~)) + +import Data.Data hiding ( Fixity ) +import Data.Kind (Type) + +import Data.Eq +import Data.Ord + +{- +Note [Trees That Grow] +~~~~~~~~~~~~~~~~~~~~~~ + +See https://gitlab.haskell.org/ghc/ghc/wikis/implementing-trees-that-grow + +The hsSyn AST is reused across multiple compiler passes. We also have the +Template Haskell AST, and the haskell-src-exts one (outside of GHC) + +Supporting multiple passes means the AST has various warts on it to cope with +the specifics for the phases, such as the 'ValBindsOut', 'ConPatOut', +'SigPatOut' etc. + +The growable AST will allow each of these variants to be captured explicitly, +such that they only exist in the given compiler pass AST, as selected by the +type parameter to the AST. + +In addition it will allow tool writers to define their own extensions to capture +additional information for the tool, in a natural way. + +A further goal is to provide a means to harmonise the Template Haskell and +haskell-src-exts ASTs as well. + +Wrinkle: In order to print out the AST, we need to know it is Outputable. +We also sometimes need to branch on the particular pass that we're in +(e.g. to print out type information once we know it). In order to allow +both of these actions, we define OutputableBndrId, which gathers the necessary +OutputableBndr and IsPass constraints. The use of this constraint in instances +generally requires UndecidableInstances. + +See also Note [IsPass] and Note [NoGhcTc] in GHC.Hs.Extension. + +-} + +-- | A placeholder type for TTG extension points that are not currently +-- used to represent any particular value. +-- +-- This should not be confused with 'DataConCantHappen', which are found in unused +-- extension /constructors/ and therefore should never be inhabited. In +-- contrast, 'NoExtField' is used in extension /points/ (e.g., as the field of +-- some constructor), so it must have an inhabitant to construct AST passes +-- that manipulate fields with that extension point as their type. +data NoExtField = NoExtField + deriving (Data,Eq,Ord) + +-- | Used when constructing a term with an unused extension point. +noExtField :: NoExtField +noExtField = NoExtField + +{- +Note [Constructor cannot occur] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some data constructors can't occur in certain phases; e.g. the output +of the type checker never has OverLabel. We signal this by +* setting the extension field to DataConCantHappen +* using dataConCantHappen in the cases that can't happen + +For example: + + type instance XOverLabel GhcTc = DataConCantHappen + + dsExpr :: HsExpr GhcTc -> blah + dsExpr (HsOverLabel x _) = dataConCantHappen x + +The function dataConCantHappen is defined thus: + dataConCantHappen :: DataConCantHappen -> a + dataConCantHappen x = case x of {} +(i.e. identically to Data.Void.absurd, but more helpfully named). +Remember DataConCantHappen is a type whose only element is bottom. + +This should not be confused with 'NoExtField', which are found in unused +extension /points/ (not /constructors/) and therefore can be inhabited. + +It would be better to omit the pattern match altogether, but we +can only do that if the extension field was strict (#18764). +See also [DataConCantHappen and strict fields]. +-} +data DataConCantHappen + deriving (Data,Eq,Ord) + +-- | Eliminate a 'DataConCantHappen'. See Note [Constructor cannot occur]. +dataConCantHappen :: DataConCantHappen -> a +dataConCantHappen x = case x of {} + +-- | GHC's L prefixed variants wrap their vanilla variant in this type family, +-- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not +-- interested in location information can define this as +-- @type instance XRec NoLocated a = a@. +-- See Note [XRec and SrcSpans in the AST] +type family XRec p a = r | r -> a + +type family Anno a = b -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation + +{- +Note [XRec and SrcSpans in the AST] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +XRec is meant to replace most of the uses of `Located` in the AST. It is another +extension point meant to make it easier for non-GHC applications to reuse the +AST for their own purposes, and not have to deal the hassle of (perhaps) useless +SrcSpans everywhere. + +instead of `Located (HsExpr p)` or similar types, we will now have `XRec p +(HsExpr p)` + +XRec allows annotating certain points in the AST with extra +information. This maybe be source spans (for GHC), nothing (for TH), +types (for HIE files), exact print annotations (for exactprint) or +anything else. + +This should hopefully bring us one step closer to sharing the AST between GHC +and TH. + +We use the `UnXRec`, `MapXRec` and `WrapXRec` type classes to aid us in writing +pass-polymorphic code that deals with `XRec`s +-} + +-- | We can strip off the XRec to access the underlying data. +-- See Note [XRec and SrcSpans in the AST] +class UnXRec p where + unXRec :: XRec p a -> a + +-- | We can map over the underlying type contained in an @XRec@ while preserving +-- the annotation as is. +class MapXRec p where + mapXRec :: (Anno a ~ Anno b) => (a -> b) -> XRec p a -> XRec p b +-- See Note [XRec and SrcSpans in the AST] +-- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation +-- AZ: Is there a way to not have Anno in this file, but still have MapXRec? +-- Perhaps define XRec with an additional b parameter, only used in Hs as (Anno b)? + +-- | The trivial wrapper that carries no additional information +-- See Note [XRec and SrcSpans in the AST] +class WrapXRec p a where + wrapXRec :: a -> XRec p a + +-- | Maps the "normal" id type for a given pass +type family IdP p + +type LIdP p = XRec p (IdP p) + +-- | Like 'IdP', except it keeps track of the user-written module qualification, +-- if any. +-- +-- See Note [IdOcc]. +type family IdOccP p +type LIdOccP p = XRec p (IdOccP p) + +{- Note [IdOcc] +~~~~~~~~~~~~~~~ +When possible, in error messages we would like to report identifiers with the +qualification that the user has written (provided this does not cause any +ambiguity). To do this, we record the user-written qualification in the +AST in the GhcRn stage. This is achieved with the 'WithUserRdr' data type. +Thus: + + - instead of using 'IdP', we use 'IdOccP', which wraps an 'IdP' in + 'WithUserRdr' at GhcRn pass, in: + - 'HsVar' + - 'HsTyVar' (which is used for 'TyCon's, not just type variables) + - 'HsOpTy' + - we also use 'ConLikeP' which wraps a 'Name' in 'WithUserRdr' at 'GhcRn' + pass, in: + - 'RecordCon' + - 'ConPat' + +This user-written module qualification is then consulted when pretty-printing +expressions, e.g. we have: + + - ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v + +and 'pprPrefixOcc' uses the 'OutputableBndr' instance for 'WithUserRdr'. +This happens in 'GHC.Types.Name.Ppr.mkQualName'. + +Test case: T25877. +-} + +-- ===================================================================== +-- Type families for the HsBinds extension points + +-- HsLocalBindsLR type families +type family XHsValBinds x x' +type family XHsIPBinds x x' +type family XEmptyLocalBinds x x' +type family XXHsLocalBindsLR x x' + +-- HsValBindsLR type families +type family XValBinds x x' +type family XXValBindsLR x x' + +-- HsBindLR type families +type family XFunBind x x' +type family XPatBind x x' +type family XVarBind x x' +type family XPatSynBind x x' +type family XXHsBindsLR x x' + +-- PatSynBind type families +type family XPSB x x' +type family XXPatSynBind x x' + +-- HsIPBinds type families +type family XIPBinds x +type family XXHsIPBinds x + +-- IPBind type families +type family XCIPBind x +type family XXIPBind x + +-- Sig type families +type family XTypeSig x +type family XPatSynSig x +type family XClassOpSig x +type family XIdSig x +type family XFixSig x +type family XInlineSig x +type family XSpecSig x +type family XSpecSigE x +type family XSpecInstSig x +type family XMinimalSig x +type family XSCCFunSig x +type family XCompleteMatchSig x +type family XXSig x + +-- FixitySig type families +type family XFixitySig x +type family XXFixitySig x + +-- StandaloneKindSig type families +type family XStandaloneKindSig x +type family XXStandaloneKindSig x + +-- ===================================================================== +-- Type families for the HsDecls extension points + +-- HsDecl type families +type family XTyClD x +type family XInstD x +type family XDerivD x +type family XValD x +type family XSigD x +type family XKindSigD x +type family XDefD x +type family XForD x +type family XWarningD x +type family XAnnD x +type family XRuleD x +type family XSpliceD x +type family XDocD x +type family XRoleAnnotD x +type family XXHsDecl x + +-- ------------------------------------- +-- HsGroup type families +type family XCHsGroup x +type family XXHsGroup x + +-- ------------------------------------- +-- SpliceDecl type families +type family XSpliceDecl x +type family XXSpliceDecl x + +-- ------------------------------------- +-- TyClDecl type families +type family XFamDecl x +type family XSynDecl x +type family XDataDecl x +type family XClassDecl x +type family XXTyClDecl x + +-- ------------------------------------- +-- FunDep type families +type family XCFunDep x +type family XXFunDep x + +-- ------------------------------------- +-- TyClGroup type families +type family XCTyClGroup x +type family XXTyClGroup x + +-- ------------------------------------- +-- FamilyResultSig type families +type family XNoSig x +type family XCKindSig x -- Clashes with XKindSig above +type family XTyVarSig x +type family XXFamilyResultSig x + +-- ------------------------------------- +-- FamilyDecl type families +type family XCFamilyDecl x +type family XXFamilyDecl x + +-- ------------------------------------- +-- HsDataDefn type families +type family XCHsDataDefn x +type family XXHsDataDefn x + +-- ------------------------------------- +-- HsDerivingClause type families +type family XCHsDerivingClause x +type family XXHsDerivingClause x + +-- ------------------------------------- +-- DerivClauseTys type families +type family XDctSingle x +type family XDctMulti x +type family XXDerivClauseTys x + +-- ------------------------------------- +-- ConDecl type families +type family XConDeclGADT x +type family XConDeclH98 x +type family XXConDecl x + +-- ------------------------------------- +-- FamEqn type families +type family XCFamEqn x r +type family XXFamEqn x r + +-- ------------------------------------- +-- TyFamInstDecl type families +type family XCTyFamInstDecl x +type family XXTyFamInstDecl x + +-- ------------------------------------- +-- ClsInstDecl type families +type family XCClsInstDecl x +type family XXClsInstDecl x + +-- ------------------------------------- +-- InstDecl type families +type family XClsInstD x +type family XDataFamInstD x +type family XTyFamInstD x +type family XXInstDecl x + +-- ------------------------------------- +-- DerivDecl type families +type family XCDerivDecl x +type family XXDerivDecl x + +-- ------------------------------------- +-- DerivStrategy type family +type family XStockStrategy x +type family XAnyClassStrategy x +type family XNewtypeStrategy x +type family XViaStrategy x + +-- ------------------------------------- +-- DefaultDecl type families +type family XCDefaultDecl x +type family XXDefaultDecl x + +-- ------------------------------------- +-- ForeignDecl type families +type family XForeignImport x +type family XForeignExport x +type family XXForeignDecl x +type family XCImport x +type family XXForeignImport x +type family XCExport x +type family XXForeignExport x + +-- ------------------------------------- +-- RuleDecls type families +type family XCRuleDecls x +type family XXRuleDecls x + +-- ------------------------------------- +-- RuleDecl type families +type family XHsRule x +type family XXRuleDecl x + +-- ------------------------------------- +-- RuleBndrs type families +type family XCRuleBndrs x +type family XXRuleBndrs x + +-- ------------------------------------- +-- RuleBndr type families +type family XCRuleBndr x +type family XRuleBndrSig x +type family XXRuleBndr x + +-- ------------------------------------- +-- WarnDecls type families +type family XWarnings x +type family XXWarnDecls x + +-- ------------------------------------- +-- WarnDecl type families +type family XWarning x +type family XXWarnDecl x + +-- ------------------------------------- +-- AnnDecl type families +type family XHsAnnotation x +type family XXAnnDecl x + +-- ------------------------------------- +-- RoleAnnotDecl type families +type family XCRoleAnnotDecl x +type family XXRoleAnnotDecl x + +-- ------------------------------------- +-- InjectivityAnn type families +type family XCInjectivityAnn x +type family XXInjectivityAnn x + +-- ===================================================================== +-- Type families for the HsModule extension points + +type family XCModule x +type family XXModule x + +-- ===================================================================== +-- Type families for the HsExpr extension points + +type family XVar x +type family XUnboundVar x +type family XRecSel x +type family XOverLabel x +type family XIPVar x +type family XOverLitE x +type family XLitE x +type family XLam x +type family XLamCase x +type family XApp x +type family XAppTypeE x +type family XOpApp x +type family XNegApp x +type family XPar x +type family XSectionL x +type family XSectionR x +type family XExplicitTuple x +type family XExplicitSum x +type family XCase x +type family XIf x +type family XMultiIf x +type family XLet x +type family XDo x +type family XExplicitList x +type family XRecordCon x +type family XRecordUpd x +type family XLHsRecUpdLabels x +type family XLHsOLRecUpdLabels x +type family XGetField x +type family XProjection x +type family XExprWithTySig x +type family XArithSeq x +type family XTypedBracket x +type family XUntypedBracket x +type family XTypedSplice x +type family XUntypedSplice x +type family XProc x +type family XStatic x +type family XTick x +type family XBinTick x +type family XPragE x +type family XEmbTy x +type family XHole x +type family XForAll x +type family XQual x +type family XFunArr x +type family XXExpr x + +-- ------------------------------------- +-- HsMatchContext type families +type family XFunRhs + +-- ------------------------------------- +-- DotFieldOcc type families +type family XCDotFieldOcc x +type family XXDotFieldOcc x + +-- ------------------------------------- +-- HsPragE type families +type family XSCC x +type family XXPragE x + +-- ------------------------------------- +-- HsTupArg type families +type family XPresent x +type family XMissing x +type family XXTupArg x + +-- ------------------------------------- +-- HsUntypedSplice type families +type family XUntypedSpliceExpr x +type family XTypedSpliceExpr x +type family XQuasiQuote x +type family XXUntypedSplice x + +-- HsTypedSplice type families +type family XXTypedSplice x + +-- ------------------------------------- +-- HsQuoteBracket type families +type family XExpBr x +type family XPatBr x +type family XDecBrL x +type family XDecBrG x +type family XTypBr x +type family XVarBr x +type family XXQuote x + +-- ------------------------------------- +-- HsCmdTop type families +type family XCmdTop x +type family XXCmdTop x + +-- ------------------------------------- +-- MatchGroup type families +type family XMG x b +type family XXMatchGroup x b + +-- ------------------------------------- +-- Match type families +type family XCMatch x b +type family XXMatch x b + +-- ------------------------------------- +-- GRHSs type families +type family XCGRHSs x b +type family XXGRHSs x b + +-- ------------------------------------- +-- GRHS type families +type family XCGRHS x b +type family XXGRHS x b + +-- ------------------------------------- +-- StmtLR type families +type family XLastStmt x x' b +type family XBindStmt x x' b +type family XBodyStmt x x' b +type family XLetStmt x x' b +type family XParStmt x x' b +type family XTransStmt x x' b +type family XRecStmt x x' b +type family XXStmtLR x x' b + +-- ------------------------------------- +-- HsCmd type families +type family XCmdArrApp x +type family XCmdArrForm x +type family XCmdApp x +type family XCmdLam x +type family XCmdPar x +type family XCmdCase x +type family XCmdLamCase x +type family XCmdIf x +type family XCmdLet x +type family XCmdDo x +type family XCmdWrap x +type family XXCmd x + +-- ------------------------------------- +-- ParStmtBlock type families +type family XParStmtBlock x x' +type family XXParStmtBlock x x' + +-- ===================================================================== +-- Type families for the HsLit extension points + +-- We define a type family for each extension point. This is based on prepending +-- 'X' to the constructor name, for ease of reference. +type family XHsChar x +type family XHsCharPrim x +type family XHsString x +type family XHsMultilineString x +type family XHsStringPrim x +type family XHsInt x +type family XHsIntPrim x +type family XHsWordPrim x +type family XHsInt8Prim x +type family XHsInt16Prim x +type family XHsInt32Prim x +type family XHsInt64Prim x +type family XHsWord8Prim x +type family XHsWord16Prim x +type family XHsWord32Prim x +type family XHsWord64Prim x +type family XHsFloatPrim x +type family XHsDoublePrim x +type family XXLit x + +-- ------------------------------------- +-- HsOverLit type families +type family XOverLit x +type family XXOverLit x + +-- ===================================================================== +-- Type families for the HsPat extension points + +type family XWildPat x +type family XVarPat x +type family XLazyPat x +type family XAsPat x +type family XParPat x +type family XBangPat x +type family XListPat x +type family XTuplePat x +type family XSumPat x +type family XOrPat x +type family XConPat x +type family XViewPat x +type family XSplicePat x +type family XLitPat x +type family XNPat x +type family XNPlusKPat x +type family XSigPat x +type family XEmbTyPat x +type family XInvisPat x +type family XCoPat x +type family XXPat x +type family XHsFieldBind x + +-- ===================================================================== +-- Type families for the HsTypes type families + + +-- ------------------------------------- +-- LHsQTyVars type families +type family XHsQTvs x +type family XXLHsQTyVars x + +-- ------------------------------------- +-- HsOuterTyVarBndrs type families +type family XHsOuterImplicit x +type family XHsOuterExplicit x flag +type family XXHsOuterTyVarBndrs x + +-- ------------------------------------- +-- HsSigType type families +type family XHsSig x +type family XXHsSigType x + +-- ------------------------------------- +-- HsWildCardBndrs type families +type family XHsWC x b +type family XXHsWildCardBndrs x b + +-- ------------------------------------- +-- HsPatSigType type families +type family XHsPS x +type family XXHsPatSigType x + +-- ------------------------------------- +-- HsTyPat type families +type family XHsTP x +type family XXHsTyPat x + +-- ------------------------------------- +-- HsType type families +type family XForAllTy x +type family XQualTy x +type family XTyVar x +type family XAppTy x +type family XAppKindTy x +type family XFunTy x +type family XListTy x +type family XTupleTy x +type family XSumTy x +type family XOpTy x +type family XParTy x +type family XIParamTy x +type family XStarTy x +type family XKindSig x +type family XSpliceTy x +type family XDocTy x +type family XExplicitListTy x +type family XExplicitTupleTy x +type family XTyLit x +type family XWildCardTy x +type family XXType x + +-- --------------------------------------------------------------------- +-- HsTyLit type families +type family XNumTy x +type family XStrTy x +type family XCharTy x +type family XXTyLit x + +-- --------------------------------------------------------------------- +-- HsForAllTelescope type families +type family XHsForAllVis x +type family XHsForAllInvis x +type family XXHsForAllTelescope x + +-- --------------------------------------------------------------------- +-- HsTyVarBndr type families +type family XTyVarBndr x +type family XXTyVarBndr x + +-- --------------------------------------------------------------------- +-- HsConDeclRecField type families +type family XConDeclRecField x +type family XXConDeclRecField x + +-- --------------------------------------------------------------------- +-- ConDeclField type families +type family XConDeclField x +type family XXConDeclField x + +-- --------------------------------------------------------------------- +-- FieldOcc type families +type family XCFieldOcc x +type family XXFieldOcc x + +-- ===================================================================== +-- Type families for the HsImpExp extension points + +-- ------------------------------------- +-- ImportDecl type families +type family XCImportDecl x +type family XXImportDecl x +type family ImportDeclPkgQual x -- stores the package qualifier in an import statement + +-- ------------------------------------- +-- IE type families +type family XIEVar x +type family XIEThingAbs x +type family XIEThingAll x +type family XIEThingWith x +type family XIEModuleContents x +type family XIEGroup x +type family XIEDoc x +type family XIEDocNamed x +type family XXIE x + +-- ------------------------------------- +-- IEWrappedName type families +type family XIEName p +type family XIEDefault p +type family XIEPattern p +type family XIEType p +type family XIEData p +type family XXIEWrappedName p + + + +-- ===================================================================== +-- Misc + +-- | See Note [NoGhcTc] in GHC.Hs.Extension. It has to be in this +-- module because it is used like an extension point (in the data definitions +-- of types that should be parameter-agnostic. +type family NoGhcTc (p :: Type) + +-- ===================================================================== +-- End of Type family definitions +-- ===================================================================== diff --git a/Language/Haskell/Syntax/ImpExp.hs b/Language/Haskell/Syntax/ImpExp.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/ImpExp.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Language.Haskell.Syntax.ImpExp ( module Language.Haskell.Syntax.ImpExp, IsBootInterface(..) ) where + +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) ) + +import Data.Eq (Eq) +import Data.Data (Data) +import Data.Bool (Bool) +import Data.Maybe (Maybe) +import Data.String (String) +import Data.Int (Int) + +import Control.DeepSeq +import {-# SOURCE #-} GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST + +{- +************************************************************************ +* * +Import and export declaration lists +* * +************************************************************************ + +One per import declaration in a module. +-} + +-- | Located Import Declaration +type LImportDecl pass = XRec pass (ImportDecl pass) + +-- | If/how an import is 'qualified'. +data ImportDeclQualifiedStyle + = QualifiedPre -- ^ 'qualified' appears in prepositive position. + | QualifiedPost -- ^ 'qualified' appears in postpositive position. + | NotQualified -- ^ Not qualified. + deriving (Eq, Data) + +data ImportDeclLevelStyle + = LevelStylePre ImportDeclLevel -- ^ 'splice' or 'quote' appears in prepositive position. + | LevelStylePost ImportDeclLevel -- ^ 'splice' or 'quote' appears in postpositive position. + | NotLevelled -- ^ Not levelled. + deriving (Eq, Data) + +data ImportDeclLevel = ImportDeclQuote | ImportDeclSplice deriving (Eq, Data) + +-- | Import Declaration +-- +-- A single Haskell @import@ declaration. +data ImportDecl pass + = ImportDecl { + ideclExt :: XCImportDecl pass, -- ^ Locations of keywords like @import@, @qualified@, etc. are captured here. + ideclName :: XRec pass ModuleName, -- ^ Module name. + ideclPkgQual :: ImportDeclPkgQual pass, -- ^ Package qualifier. + ideclSource :: IsBootInterface, -- ^ IsBoot \<=> {-\# SOURCE \#-} import + ideclLevelSpec :: ImportDeclLevelStyle, + ideclSafe :: Bool, -- ^ True => safe import + ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified. + ideclAs :: Maybe (XRec pass ModuleName), -- ^ as Module + ideclImportList :: Maybe (ImportListInterpretation, XRec pass [LIE pass]) + -- ^ Explicit import list (EverythingBut => hiding, names) + } + | XImportDecl !(XXImportDecl pass) + +-- | Whether the import list is exactly what to import, or whether @hiding@ was +-- used, and therefore everything but what was listed should be imported +data ImportListInterpretation = Exactly | EverythingBut + deriving (Eq, Data) + +instance NFData ImportListInterpretation where + rnf = rwhnf + +-- | Located Import or Export +type LIE pass = XRec pass (IE pass) + -- ^ When in a list this may have + +-- | A docstring attached to an export list item. +type ExportDoc pass = LHsDoc pass + +-- | Imported or exported entity. +data IE pass + = IEVar (XIEVar pass) (LIEWrappedName pass) (Maybe (ExportDoc pass)) + -- ^ Imported or exported variable + -- + -- @ + -- module Mod ( test ) + -- import Mod ( test ) + -- @ + + | IEThingAbs (XIEThingAbs pass) (LIEWrappedName pass) (Maybe (ExportDoc pass)) + -- ^ Imported or exported Thing with absent subordinate list + -- + -- The thing is a Class\/Type (can't tell) + -- + -- @ + -- module Mod ( Test ) + -- import Mod ( Test ) + -- @ + + -- See Note [Located RdrNames] in GHC.Hs.Expr + | IEThingAll (XIEThingAll pass) (LIEWrappedName pass) (Maybe (ExportDoc pass)) + -- ^ Imported or exported thing with wildcard subordinate list (e.g. @(..)@) + -- + -- The thing is a Class\/Type and the All refers to methods\/constructors + -- + -- @ + -- module Mod ( Test(..) ) + -- import Mod ( Test(..) ) + -- @ + + -- See Note [Located RdrNames] in GHC.Hs.Expr + | IEThingWith (XIEThingWith pass) + (LIEWrappedName pass) + IEWildcard + [LIEWrappedName pass] + (Maybe (ExportDoc pass)) + -- ^ Imported or exported thing with explicit subordinate list. + -- + -- The thing is a Class\/Type (can't tell) and the imported or exported things are + -- its children. + -- + -- @ + -- module Mod ( Test(f, g) ) + -- import Mod ( Test(f, g) ) + -- @ + | IEModuleContents (XIEModuleContents pass) (XRec pass ModuleName) + -- ^ Export of entire module. Can only occur in export list. + -- + -- @ + -- module Mod ( module Mod2 ) + -- @ + | IEGroup (XIEGroup pass) Int (LHsDoc pass) + -- ^ A Haddock section in an export list. + -- + -- @ + -- module Mod + -- ( -- * Section heading + -- ... + -- ) + -- @ + | IEDoc (XIEDoc pass) (LHsDoc pass) + -- ^ A bit of unnamed documentation. + -- + -- @ + -- module Mod + -- ( -- | Documentation + -- ... + -- ) + -- @ + | IEDocNamed (XIEDocNamed pass) String + -- ^ A reference to a named documentation chunk. + -- + -- @ + -- module Mod + -- ( -- $chunkName + -- ... + -- ) + -- @ + | XIE !(XXIE pass) + +-- | Wildcard in an import or export sublist, like the @..@ in +-- @import Mod ( T(Mk1, Mk2, ..) )@. +data IEWildcard + = NoIEWildcard -- ^ no wildcard in this list + | IEWildcard Int -- ^ wildcard after the given \# of items in this list + -- The @Int@ is in the range [0..n], where n is the length + -- of the list. + deriving (Eq, Data) + +-- | A name in an import or export specification which may have +-- adornments. Used primarily for accurate pretty printing of +-- ParsedSource, and API Annotation placement. +data IEWrappedName p + = IEName (XIEName p) (LIdP p) -- ^ unadorned name, e.g @myFun@ + | IEDefault (XIEDefault p) (LIdP p) -- ^ @default X ()@, see Note [Named default declarations] in GHC.Tc.Gen.Default + | IEPattern (XIEPattern p) (LIdP p) -- ^ @pattern X@ + | IEType (XIEType p) (LIdP p) -- ^ @type (:+:)@ + | IEData (XIEData p) (LIdP p) -- ^ @data (:+:)@ + | XIEWrappedName !(XXIEWrappedName p) + +-- | Located name with possible adornment +type LIEWrappedName p = XRec p (IEWrappedName p) diff --git a/Language/Haskell/Syntax/ImpExp/IsBoot.hs b/Language/Haskell/Syntax/ImpExp/IsBoot.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/ImpExp/IsBoot.hs @@ -0,0 +1,15 @@ +module Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) ) where + +import Prelude (Eq, Ord, Show) +import Data.Data (Data) +import Control.DeepSeq (NFData(..), rwhnf) + +-- | Indicates whether a module name is referring to a boot interface (hs-boot +-- file) or regular module (hs file). 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 IsBootInterface = NotBoot | IsBoot + deriving (Eq, Ord, Show, Data) + +instance NFData IsBootInterface where + rnf = rwhnf diff --git a/Language/Haskell/Syntax/Lit.hs b/Language/Haskell/Syntax/Lit.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Lit.hs @@ -0,0 +1,136 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* + +-- | Source-language literals +module Language.Haskell.Syntax.Lit where + +import Language.Haskell.Syntax.Extension + +import GHC.Types.SourceText (IntegralLit, FractionalLit, SourceText) + +import GHC.Data.FastString (FastString, lexicalCompareFS) + +import Data.ByteString (ByteString) +import Data.Data hiding ( Fixity ) +import Data.Bool +import Data.Ord +import Data.Eq +import Data.Char +import Prelude (Integer) + +{- +************************************************************************ +* * +\subsection[HsLit]{Literals} +* * +************************************************************************ +-} + +-- Note [Literal source text] in "GHC.Types.SourceText" for SourceText fields in +-- the following +-- Note [Trees That Grow] in "Language.Haskell.Syntax.Extension" for the Xxxxx +-- fields in the following +-- | Haskell Literal +data HsLit x + = HsChar (XHsChar x) {- SourceText -} Char + -- ^ Character + | HsCharPrim (XHsCharPrim x) {- SourceText -} Char + -- ^ Unboxed character + | HsString (XHsString x) {- SourceText -} FastString + -- ^ String + | HsMultilineString (XHsMultilineString x) {- SourceText -} FastString + -- ^ String + | HsStringPrim (XHsStringPrim x) {- SourceText -} !ByteString + -- ^ Packed bytes + | HsInt (XHsInt x) IntegralLit + -- ^ Genuinely an Int; arises from + -- "GHC.Tc.Deriv.Generate", and from TRANSLATION + | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer + -- ^ literal @Int#@ + | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer + -- ^ literal @Word#@ + | HsInt8Prim (XHsInt8Prim x) {- SourceText -} Integer + -- ^ literal @Int8#@ + | HsInt16Prim (XHsInt16Prim x) {- SourceText -} Integer + -- ^ literal @Int16#@ + | HsInt32Prim (XHsInt32Prim x) {- SourceText -} Integer + -- ^ literal @Int32#@ + | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer + -- ^ literal @Int64#@ + | HsWord8Prim (XHsWord8Prim x) {- SourceText -} Integer + -- ^ literal @Word8#@ + | HsWord16Prim (XHsWord16Prim x) {- SourceText -} Integer + -- ^ literal @Word16#@ + | HsWord32Prim (XHsWord32Prim x) {- SourceText -} Integer + -- ^ literal @Word32#@ + | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer + -- ^ literal @Word64#@ + | HsFloatPrim (XHsFloatPrim x) FractionalLit + -- ^ Unboxed Float + | HsDoublePrim (XHsDoublePrim x) FractionalLit + -- ^ Unboxed Double + | XLit !(XXLit x) + +instance (Eq (XXLit x)) => Eq (HsLit x) where + (HsChar _ x1) == (HsChar _ x2) = x1==x2 + (HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2 + (HsString _ x1) == (HsString _ x2) = x1==x2 + (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2 + (HsInt _ x1) == (HsInt _ x2) = x1==x2 + (HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2 + (HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2 + (HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2 + (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2 + (HsFloatPrim _ x1) == (HsFloatPrim _ x2) = x1==x2 + (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2 + (XLit x1) == (XLit x2) = x1==x2 + _ == _ = False + +-- | Haskell Overloaded Literal +data HsOverLit p + = OverLit { + ol_ext :: (XOverLit p), + ol_val :: OverLitVal} + + | XOverLit + !(XXOverLit p) + +-- Note [Literal source text] in "GHC.Types.SourceText" for SourceText fields in +-- the following +-- | Overloaded Literal Value +data OverLitVal + = HsIntegral !IntegralLit -- ^ Integer-looking literals; + | HsFractional !FractionalLit -- ^ Frac-looking literals + | HsIsString !SourceText !FastString -- ^ String-looking literals + deriving Data + +instance Eq OverLitVal where + (HsIntegral i1) == (HsIntegral i2) = i1 == i2 + (HsFractional f1) == (HsFractional f2) = f1 == f2 + (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 + _ == _ = False + +instance Ord OverLitVal where + compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2 + compare (HsIntegral _) (HsFractional _) = LT + compare (HsIntegral _) (HsIsString _ _) = LT + compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2 + compare (HsFractional _) (HsIntegral _) = GT + compare (HsFractional _) (HsIsString _ _) = LT + compare (HsIsString _ s1) (HsIsString _ s2) = s1 `lexicalCompareFS` s2 + compare (HsIsString _ _) (HsIntegral _) = GT + compare (HsIsString _ _) (HsFractional _) = GT diff --git a/Language/Haskell/Syntax/Module/Name.hs b/Language/Haskell/Syntax/Module/Name.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Module/Name.hs @@ -0,0 +1,61 @@ +module Language.Haskell.Syntax.Module.Name where + +import Prelude + +import Data.Char (isAlphaNum) +import Data.Data +import Control.DeepSeq +import qualified Text.ParserCombinators.ReadP as Parse +import System.FilePath + +import GHC.Data.FastString + +-- | A ModuleName is essentially a simple string, e.g. @Data.List@. +newtype ModuleName = ModuleName FastString deriving (Show, Eq) + +instance Data ModuleName where + -- don't traverse? + toConstr x = constr + where + constr = mkConstr (dataTypeOf x) "{abstract:ModuleName}" [] Prefix + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ModuleName" + +instance Ord ModuleName where + nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 + +instance NFData ModuleName where + rnf x = x `seq` () + +stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering +-- ^ Compares module names lexically, rather than by their 'Unique's +stableModuleNameCmp n1 n2 = moduleNameFS n1 `lexicalCompareFS` moduleNameFS n2 + +moduleNameFS :: ModuleName -> FastString +moduleNameFS (ModuleName mod) = mod + +moduleNameString :: ModuleName -> String +moduleNameString (ModuleName mod) = unpackFS mod + +mkModuleName :: String -> ModuleName +mkModuleName s = ModuleName (mkFastString s) + +mkModuleNameFS :: FastString -> ModuleName +mkModuleNameFS s = ModuleName s + +-- |Returns the string version of the module name, with dots replaced by slashes. +-- +moduleNameSlashes :: ModuleName -> String +moduleNameSlashes = dots_to_slashes . moduleNameString + where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) + +-- |Returns the string version of the module name, with dots replaced by colons. +-- +moduleNameColons :: ModuleName -> String +moduleNameColons = dots_to_colons . moduleNameString + where dots_to_colons = map (\c -> if c == '.' then ':' else c) + +parseModuleName :: Parse.ReadP ModuleName +parseModuleName = fmap mkModuleName + $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.'") + diff --git a/Language/Haskell/Syntax/Pat.hs b/Language/Haskell/Syntax/Pat.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Pat.hs @@ -0,0 +1,346 @@ + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension +{-# LANGUAGE DataKinds #-} +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PatSyntax]{Abstract Haskell syntax---patterns} +-} + +-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* +module Language.Haskell.Syntax.Pat ( + Pat(..), LPat, + ConLikeP, + isInvisArgPat, isInvisArgLPat, + isVisArgPat, isVisArgLPat, + + HsConPatDetails, hsConPatArgs, + takeHsConPatTyArgs, dropHsConPatTyArgs, + HsRecFields(..), XHsRecFields, HsFieldBind(..), LHsFieldBind, + HsRecField, LHsRecField, + HsRecUpdField, LHsRecUpdField, + RecFieldsDotDot(..) + ) where + +import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsUntypedSplice) + +-- friends: +import Language.Haskell.Syntax.Basic +import Language.Haskell.Syntax.Lit +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Type + +-- libraries: +import Data.Maybe +import Data.Functor +import Data.Foldable +import Data.Traversable +import Data.Bool +import Data.Data +import Data.Eq +import Data.Ord +import Data.Int +import Data.Function +import qualified Data.List +import Data.List.NonEmpty (NonEmpty) + +type LPat p = XRec p (Pat p) + +-- | Pattern +data Pat p + = ------------ Simple patterns --------------- + WildPat (XWildPat p) + -- ^ Wildcard Pattern, i.e. @_@ + + | VarPat (XVarPat p) + (LIdP p) + -- ^ Variable Pattern, e.g. @x@ + + -- See Note [Located RdrNames] in GHC.Hs.Expr + | LazyPat (XLazyPat p) + (LPat p) + -- ^ Lazy Pattern, e.g. @~x@ + | AsPat (XAsPat p) + (LIdP p) + (LPat p) + -- ^ As pattern, e.g. @x\@pat@ + | ParPat (XParPat p) + (LPat p) + -- ^ Parenthesised pattern, e.g. @(x)@ + + -- See Note [Parens in HsSyn] in GHC.Hs.Expr + | BangPat (XBangPat p) + (LPat p) + -- ^ Bang pattern, e.g. @!x@ + + ------------ Lists, tuples, arrays --------------- + | ListPat (XListPat p) + [LPat p] + -- ^ Syntactic List, e.g. @[x]@ or @[x,y]@. + -- Note that @[]@ and @(x:xs)@ patterns are both represented using 'ConPat'. + + | -- | Tuple pattern, e.g. @(x, y)@ (boxed tuples) or @(# x, y #)@ (requires @-XUnboxedTuples@) + TuplePat (XTuplePat p) -- ^ After typechecking, holds the types of the tuple components + [LPat p] -- ^ Tuple sub-patterns + Boxity + + -- You might think that the post typechecking Type was redundant, + -- because we can get the pattern type by getting the types of the + -- sub-patterns. + -- But it's essential + -- data T a where + -- T1 :: Int -> T Int + -- f :: (T a, a) -> Int + -- f (T1 x, z) = z + -- When desugaring, we must generate + -- f = /\a. \v::a. case v of (t::T a, w::a) -> + -- case t of (T1 (x::Int)) -> + -- Note the (w::a), NOT (w::Int), because we have not yet + -- refined 'a' to Int. So we must know that the second component + -- of the tuple is of type 'a' not Int. See selectMatchVar + -- (June 14: I'm not sure this comment is right; the sub-patterns + -- will be wrapped in CoPats, no?) + + | OrPat (XOrPat p) + (NonEmpty (LPat p)) + -- ^ Or Pattern, e.g. @(pat_1; ...; pat_n)@. Used by @-XOrPatterns@ + -- + -- @since 9.12.1 + + | SumPat (XSumPat p) -- after typechecker, types of the alternative + (LPat p) -- Sum sub-pattern + ConTag -- Alternative (one-based) + SumWidth -- Arity (INVARIANT: ≥ 2) + + -- ^ Anonymous sum pattern, e.g. @(# x | #)@. Used by @-XUnboxedSums@ + + ------------ Constructor patterns --------------- + | ConPat { + pat_con_ext :: XConPat p, + pat_con :: XRec p (ConLikeP p), + pat_args :: HsConPatDetails p + } + -- ^ Constructor Pattern, e.g. @()@, @[]@ or @Nothing@ + + ------------ View patterns --------------- + + | ViewPat (XViewPat p) + (LHsExpr p) + (LPat p) + -- ^ View Pattern, e.g. @someFun -> pat@. Used by @-XViewPatterns@ + + ------------ Pattern splices --------------- + + | SplicePat (XSplicePat p) + (HsUntypedSplice p) + -- ^ Splice Pattern, e.g. @$(pat)@ + + ------------ Literal and n+k patterns --------------- + | LitPat (XLitPat p) + (HsLit p) + -- ^ Literal Pattern + -- + -- Used for __non-overloaded__ literal patterns: + -- Int#, Char#, Int, Char, String, etc. + + | NPat (XNPat p) -- Overall type of pattern. Might be + -- different than the literal's type + -- if (==) or negate changes the type + (XRec p (HsOverLit p)) -- ALWAYS positive + (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for + -- negative patterns, Nothing + -- otherwise + (SyntaxExpr p) -- Equality checker, of type t->t->Bool + + -- ^ Natural Pattern, used for all overloaded literals, including overloaded Strings + -- with @-XOverloadedStrings@ + + | -- | n+k pattern, e.g. @n+1@, used by @-XNPlusKPatterns@ + NPlusKPat (XNPlusKPat p) -- Type of overall pattern + (LIdP p) -- n+k pattern + (XRec p (HsOverLit p)) -- It'll always be an HsIntegral + (HsOverLit p) -- See Note [NPlusK patterns] in GHC.Tc.Gen.Pat + -- NB: This could be (PostTc ...), but that induced a + -- a new hs-boot file. Not worth it. + + (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool + (SyntaxExpr p) -- Name of '-' (see GHC.Rename.Env.lookupSyntax) + + ------------ Pattern type signatures --------------- + + | SigPat (XSigPat p) -- After typechecker: Type + (LPat p) -- Pattern with a type signature + (HsPatSigType (NoGhcTc p)) -- Signature can bind both + -- kind and type vars + + -- ^ Pattern with a type signature, e.g. @x :: Int@ + + | -- | Embed the syntax of types into patterns, e.g. @fn (type t) = rhs@. + -- Enabled by @-XExplicitNamespaces@ in conjunction with @-XRequiredTypeArguments@. + EmbTyPat (XEmbTyPat p) + (HsTyPat (NoGhcTc p)) + + | InvisPat (XInvisPat p) (HsTyPat (NoGhcTc p)) + -- ^ Type abstraction which brings into scope type variables associated with invisible forall. + -- E.g. @fn \@t ... = rhs@. Used by @-XTypeAbstractions@. + + -- See Note [Invisible binders in functions] in GHC.Hs.Pat + + | -- | TTG Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension + XPat !(XXPat p) + +type family ConLikeP x + + +-- --------------------------------------------------------------------- + +isInvisArgPat :: Pat p -> Bool +isInvisArgPat InvisPat{} = True +isInvisArgPat _ = False + +isInvisArgLPat :: forall p. (UnXRec p) => LPat p -> Bool +isInvisArgLPat = isInvisArgPat . unXRec @p + +isVisArgPat :: Pat p -> Bool +isVisArgPat = not . isInvisArgPat + +isVisArgLPat :: forall p. (UnXRec p) => LPat p -> Bool +isVisArgLPat = isVisArgPat . unXRec @p + +-- | Haskell Constructor Pattern Details +type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) + +hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p] +hsConPatArgs (PrefixCon ps) = ps +hsConPatArgs (RecCon fs) = Data.List.map (hfbRHS . unXRec @p) (rec_flds fs) +hsConPatArgs (InfixCon p1 p2) = [p1,p2] + +takeHsConPatTyArgs :: forall p. (UnXRec p) => [LPat p] -> [HsTyPat (NoGhcTc p)] +takeHsConPatTyArgs (p : ps) + | InvisPat _ tp <- unXRec @p p + = tp : takeHsConPatTyArgs ps +takeHsConPatTyArgs _ = [] + +dropHsConPatTyArgs :: forall p. (UnXRec p) => [LPat p] -> [LPat p] +dropHsConPatTyArgs = Data.List.dropWhile (isInvisArgPat . unXRec @p) + +-- | Haskell Record Fields +-- +-- HsRecFields is used only for patterns and expressions (not data type +-- declarations) +data HsRecFields p arg -- A bunch of record fields + -- { x = 3, y = True } + -- Used for both expressions and patterns + = HsRecFields { rec_ext :: !(XHsRecFields p), + rec_flds :: [LHsRecField p arg], + rec_dotdot :: Maybe (XRec p RecFieldsDotDot) } -- Note [DotDot fields] + -- AZ:The XRec for LHsRecField makes the derivings fail. + -- deriving (Functor, Foldable, Traversable) + +type family XHsRecFields p + +-- | Newtype to be able to have a specific XRec instance for the Int in `rec_dotdot` +newtype RecFieldsDotDot = RecFieldsDotDot { unRecFieldsDotDot :: Int } + deriving (Data, Eq, Ord) + +-- Note [DotDot fields] +-- ~~~~~~~~~~~~~~~~~~~~ +-- The rec_dotdot field means this: +-- Nothing => the normal case +-- Just n => the group uses ".." notation, +-- +-- In the latter case: +-- +-- *before* renamer: rec_flds are exactly the n user-written fields +-- +-- *after* renamer: rec_flds includes *all* fields, with +-- the first 'n' being the user-written ones +-- and the remainder being 'filled in' implicitly + +-- | Located Haskell Record Field +type LHsFieldBind p id arg = XRec p (HsFieldBind id arg) + +-- | Located Haskell Record Field +type LHsRecField p arg = XRec p (HsRecField p arg) + +-- | Haskell Record Field +type HsRecField p arg = HsFieldBind (LFieldOcc p) arg + +-- | Located Haskell Record Update Field +type LHsRecUpdField p q = XRec p (HsRecUpdField p q) + +-- | Haskell Record Update Field +type HsRecUpdField p q = HsFieldBind (LFieldOcc p) (LHsExpr q) + +-- | Haskell Field Binding +data HsFieldBind lhs rhs = HsFieldBind { + hfbAnn :: XHsFieldBind lhs, + hfbLHS :: lhs, + hfbRHS :: rhs, -- ^ Filled in by renamer when punning + hfbPun :: Bool -- ^ Note [Punning] + } deriving (Functor, Foldable, Traversable) + + +-- Note [Punning] +-- ~~~~~~~~~~~~~~ +-- If you write T { x, y = v+1 }, the HsRecFields will be +-- HsRecField x x True ... +-- HsRecField y (v+1) False ... +-- That is, for "punned" field x is expanded (in the renamer) +-- to x=x; but with a punning flag so we can detect it later +-- (e.g. when pretty printing) +-- +-- If the original field was qualified, we un-qualify it, thus +-- T { A.x } means T { A.x = x } + + +-- Note [HsRecField and HsRecUpdField] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- A HsRecField (used for record construction and pattern matching) +-- contains an unambiguous occurrence of a field (i.e. a FieldOcc). +-- We can't just store the Name, because thanks to +-- DuplicateRecordFields this may not correspond to the label the user +-- wrote. +-- +-- A HsRecUpdField (used for record update) contains a potentially +-- ambiguous occurrence of a field (an AmbiguousFieldOcc). The +-- renamer will fill in the selector function if it can, but if the +-- selector is ambiguous the renamer will defer to the typechecker. +-- After the typechecker, a unique selector will have been determined. +-- +-- The renamer produces an Unambiguous result if it can, rather than +-- just doing the lookup in the typechecker, so that completely +-- unambiguous updates can be represented by 'GHC.HsToCore.Quote.repUpdFields'. +-- +-- For example, suppose we have: +-- +-- data S = MkS { x :: Int } +-- data T = MkT { x :: Int } +-- +-- f z = (z { x = 3 }) :: S +-- +-- The parsed HsRecUpdField corresponding to the record update will have: +-- +-- hfbLHS = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName +-- +-- After the renamer, this will become: +-- +-- hfbLHS = Ambiguous "x" noExtField :: AmbiguousFieldOcc Name +-- +-- (note that the Unambiguous constructor is not type-correct here). +-- The typechecker will determine the particular selector: +-- +-- hfbLHS = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id +-- +-- See also Note [Disambiguating record updates] in GHC.Rename.Pat. diff --git a/Language/Haskell/Syntax/Pat.hs-boot b/Language/Haskell/Syntax/Pat.hs-boot new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Pat.hs-boot @@ -0,0 +1,13 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} + +-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* +module Language.Haskell.Syntax.Pat where + +import Language.Haskell.Syntax.Extension ( XRec ) +import Data.Kind + +type role Pat nominal +data Pat (i :: Type) +type LPat i = XRec i (Pat i) diff --git a/Language/Haskell/Syntax/Specificity.hs b/Language/Haskell/Syntax/Specificity.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Specificity.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE MultiWayIf, PatternSynonyms #-} + +-- TODO Everthing in this module should be moved to +-- Language.Haskell.Syntax.Decls + +module Language.Haskell.Syntax.Specificity ( + -- * ForAllTyFlags + ForAllTyFlag(Invisible,Required,Specified,Inferred), + Specificity(..), + isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isInferredForAllTyFlag, + isSpecifiedForAllTyFlag, + coreTyLamForAllTyFlag, + ) where + +import Prelude + +import Data.Data + +-- | ForAllTyFlag +-- +-- Is something required to appear in source Haskell ('Required'), +-- permitted by request ('Specified') (visible type application), or +-- prohibited entirely from appearing in source Haskell ('Inferred')? +-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" +data ForAllTyFlag = Invisible !Specificity + | Required + deriving (Eq, Ord, Data) + -- (<) on ForAllTyFlag means "is less visible than" + +-- | Whether an 'Invisible' argument may appear in source Haskell. +data Specificity = InferredSpec + -- ^ the argument may not appear in source Haskell, it is + -- only inferred. + | SpecifiedSpec + -- ^ the argument may appear in source Haskell, but isn't + -- required. + deriving (Eq, Ord, Data) + +pattern Inferred, Specified :: ForAllTyFlag +pattern Inferred = Invisible InferredSpec +pattern Specified = Invisible SpecifiedSpec + +{-# COMPLETE Required, Specified, Inferred #-} + +-- | Does this 'ForAllTyFlag' classify an argument that is written in Haskell? +isVisibleForAllTyFlag :: ForAllTyFlag -> Bool +isVisibleForAllTyFlag af = not (isInvisibleForAllTyFlag af) + +-- | Does this 'ForAllTyFlag' classify an argument that is not written in Haskell? +isInvisibleForAllTyFlag :: ForAllTyFlag -> Bool +isInvisibleForAllTyFlag (Invisible {}) = True +isInvisibleForAllTyFlag Required = False + +isInferredForAllTyFlag :: ForAllTyFlag -> Bool +-- More restrictive than isInvisibleForAllTyFlag +isInferredForAllTyFlag (Invisible InferredSpec) = True +isInferredForAllTyFlag _ = False + +isSpecifiedForAllTyFlag :: ForAllTyFlag -> Bool +-- More restrictive than isInvisibleForAllTyFlag +isSpecifiedForAllTyFlag (Invisible SpecifiedSpec) = True +isSpecifiedForAllTyFlag _ = False + +coreTyLamForAllTyFlag :: ForAllTyFlag +-- ^ The ForAllTyFlag on a (Lam a e) term, where `a` is a type variable. +-- If you want other ForAllTyFlag, use a cast. +-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep +coreTyLamForAllTyFlag = Specified diff --git a/Language/Haskell/Syntax/Type.hs b/Language/Haskell/Syntax/Type.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Type.hs @@ -0,0 +1,1309 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] +{-# LANGUAGE LambdaCase #-} + -- in module Language.Haskell.Syntax.Extension +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +GHC.Hs.Type: Abstract syntax: user-defined types +-} + +-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* +module Language.Haskell.Syntax.Type ( + HsMultAnn, HsMultAnnOf(..), + XUnannotated, XLinearAnn, XExplicitMult, XXMultAnnOf, + + HsType(..), LHsType, HsKind, LHsKind, + HsBndrVis(..), XBndrRequired, XBndrInvisible, XXBndrVis, + HsBndrVar(..), XBndrVar, XBndrWildCard, XXBndrVar, + HsBndrKind(..), XBndrKind, XBndrNoKind, XXBndrKind, + isHsBndrInvisible, + isHsBndrWildCard, + HsForAllTelescope(..), + HsTyVarBndr(..), LHsTyVarBndr, + LHsQTyVars(..), + HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, + HsWildCardBndrs(..), + HsPatSigType(..), + HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType, + HsTyPat(..), LHsTyPat, + HsTupleSort(..), + HsContext, LHsContext, + HsTyLit(..), + HsIPName(..), hsIPNameFS, + HsArg(..), XValArg, XTypeArg, XArgPar, XXArg, + + LHsTypeArg, + + PromotionFlag(..), isPromoted, + + HsConDeclRecField(..), LHsConDeclRecField, + + HsConDetails(..), + HsConDeclField(..), + + FieldOcc(..), LFieldOcc, + + mapHsOuterImplicit, + hsQTvExplicit, + isHsKindedTyVar + ) where + +import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice ) + +import Language.Haskell.Syntax.Basic ( SrcStrictness, SrcUnpackedness ) +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Specificity + + +import GHC.Hs.Doc (LHsDoc) +import GHC.Data.FastString (FastString) +import GHC.Utils.Panic( panic ) + +import Data.Data hiding ( Fixity, Prefix, Infix ) +import Data.Maybe +import Data.Eq +import Data.Bool +import Data.Char +import Prelude (Integer) +import Data.Ord (Ord) +import Control.DeepSeq + +{- +************************************************************************ +* * +\subsection{Promotion flag} +* * +************************************************************************ +-} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + deriving ( Eq, Data, Ord ) + +isPromoted :: PromotionFlag -> Bool +isPromoted IsPromoted = True +isPromoted NotPromoted = False + +instance NFData PromotionFlag where + rnf NotPromoted = () + rnf IsPromoted = () + +{- +************************************************************************ +* * +\subsection{Data types} +* * +************************************************************************ + +This is the syntax for types as seen in type signatures. + +Note [HsBSig binder lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a binder (or pattern) decorated with a type or kind, + \ (x :: a -> a). blah + forall (a :: k -> *) (b :: k). blah +Then we use a LHsBndrSig on the binder, so that the +renamer can decorate it with the variables bound +by the pattern ('a' in the first example, 'k' in the second), +assuming that neither of them is in scope already +See also Note [Kind and type-variable binders] in GHC.Rename.HsType + +Note [HsType binders] +~~~~~~~~~~~~~~~~~~~~~ +The system for recording type and kind-variable binders in HsTypes +is a bit complicated. Here's how it works. + +* In a HsType, + HsForAllTy represents an /explicit, user-written/ 'forall' that + is nested within another HsType + e.g. forall a b. {...} or + forall a b -> {...} + + Note that top-level 'forall's are represented with a + different AST form. See the description of HsOuterTyVarBndrs + below. + HsQualTy represents an /explicit, user-written/ context + e.g. (Eq a, Show a) => ... + The context can be empty if that's what the user wrote + These constructors represent what the user wrote, no more + and no less. + +* The ForAllTelescope field of HsForAllTy represents whether a forall is + invisible (e.g., forall a b. {...}, with a dot) or visible + (e.g., forall a b -> {...}, with an arrow). + +* HsTyVarBndr describes a quantified type variable written by the + user. For example + f :: forall a (b :: *). blah + here 'a' and '(b::*)' are each a HsTyVarBndr. A HsForAllTy has + a list of LHsTyVarBndrs. + +* HsOuterTyVarBndrs is used to represent the outermost quantified type + variables in a type that obeys the forall-or-nothing rule. An + HsOuterTyVarBndrs can be one of the following: + + HsOuterImplicit (implicit quantification, added by renamer) + f :: a -> a -- Desugars to f :: forall {a}. a -> a + HsOuterExplicit (explicit user quantification): + f :: forall a. a -> a + + See Note [forall-or-nothing rule]. + +* An HsSigType is an LHsType with an accompanying HsOuterTyVarBndrs that + represents the presence (or absence) of its outermost 'forall'. + See Note [Representing type signatures]. + +* HsWildCardBndrs is a wrapper that binds the wildcard variables + of the wrapped thing. It is filled in by the renamer + f :: _a -> _ + The enclosing HsWildCardBndrs binds the wildcards _a and _. + +* HsSigPatType describes types that appear in pattern signatures and + the signatures of term-level binders in RULES. Like + HsWildCardBndrs/HsOuterTyVarBndrs, they track the names of wildcard + variables and implicitly bound type variables. Unlike + HsOuterTyVarBndrs, however, HsSigPatTypes do not obey the + forall-or-nothing rule. See Note [Pattern signature binders and scoping]. + +* The explicit presence of these wrappers specifies, in the HsSyn, + exactly where implicit quantification is allowed, and where + wildcards are allowed. + +* LHsQTyVars is used in data/class declarations, where the user gives + explicit *type* variable bindings, but we need to implicitly bind + *kind* variables. For example + class C (a :: k -> *) where ... + The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars + +Note [The wildcard story for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Types can have wildcards in them, to support partial type signatures, +like f :: Int -> (_ , _a) -> _a + +A wildcard in a type can be + + * An anonymous wildcard, + written '_' + In HsType this is represented by HsWildCardTy. + The renamer leaves it untouched, and it is later given a fresh + meta tyvar in the typechecker. + + * A named wildcard, + written '_a', '_foo', etc + In HsType this is represented by (HsTyVar "_a") + i.e. a perfectly ordinary type variable that happens + to start with an underscore + +Note carefully: + +* When NamedWildCards is off, type variables that start with an + underscore really /are/ ordinary type variables. And indeed, even + when NamedWildCards is on you can bind _a explicitly as an ordinary + type variable: + data T _a _b = MkT _b _a + Or even: + f :: forall _a. _a -> _b + Here _a is an ordinary forall'd binder, but (With NamedWildCards) + _b is a named wildcard. (See the comments in #10982) + +* Named wildcards are bound by the HsWildCardBndrs (for types that obey the + forall-or-nothing rule) and HsPatSigType (for type signatures in patterns + and term-level binders in RULES), which wrap types that are allowed to have + wildcards. Unnamed wildcards, however are left unchanged until typechecking, + where we give them fresh wild tyvars and determine whether or not to emit + hole constraints on each wildcard (we don't if it's a visible type/kind + argument or a type family pattern). See related notes + Note [Wildcards in visible kind application] and + Note [Wildcards in visible type application] in GHC.Tc.Gen.HsType. + +* After type checking is done, we report what types the wildcards + got unified with. + +Note [Ordering of implicit variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the advent of -XTypeApplications, GHC makes promises about the ordering +of implicit variable quantification. Specifically, we offer that implicitly +quantified variables (such as those in const :: a -> b -> a, without a `forall`) +will occur in left-to-right order of first occurrence. Here are a few examples: + + const :: a -> b -> a -- forall a b. ... + f :: Eq a => b -> a -> a -- forall a b. ... contexts are included + + type a <-< b = b -> a + g :: a <-< b -- forall a b. ... type synonyms matter + + class Functor f where + fmap :: (a -> b) -> f a -> f b -- forall f a b. ... + -- The f is quantified by the class, so only a and b are considered in fmap + +This simple story is complicated by the possibility of dependency: all variables +must come after any variables mentioned in their kinds. + + typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... + +The k comes first because a depends on k, even though the k appears later than +the a in the code. Thus, GHC does a *stable topological sort* on the variables. +By "stable", we mean that any two variables who do not depend on each other +preserve their existing left-to-right ordering. + +Implicitly bound variables are collected by the extract- family of functions +(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in GHC.Rename.HsType. +These functions thus promise to keep left-to-right ordering. +Look for pointers to this note to see the places where the action happens. + +Note that we also maintain this ordering in kind signatures. Even though +there's no visible kind application (yet), having implicit variables be +quantified in left-to-right order in kind signatures is nice since: + +* It's consistent with the treatment for type signatures. +* It can affect how types are displayed with -fprint-explicit-kinds (see + #15568 for an example), which is a situation where knowing the order in + which implicit variables are quantified can be useful. +* In the event that visible kind application is implemented, the order in + which we would expect implicit variables to be ordered in kinds will have + already been established. +-} + +-- | Located Haskell Context +type LHsContext pass = XRec pass (HsContext pass) + +-- | Haskell Context +type HsContext pass = [LHsType pass] + +-- | Located Haskell Type +type LHsType pass = XRec pass (HsType pass) + +-- | Haskell Kind +type HsKind pass = HsType pass + +-- | Located Haskell Kind +type LHsKind pass = XRec pass (HsKind pass) + +-------------------------------------------------- +-- LHsQTyVars +-- The explicitly-quantified binders in a data/type declaration + +-- | The type variable binders in an 'HsForAllTy'. +-- See also @Note [Variable Specificity and Forall Visibility]@ in +-- "GHC.Tc.Gen.HsType". +data HsForAllTelescope pass + = HsForAllVis -- ^ A visible @forall@ (e.g., @forall a -> {...}@). + -- These do not have any notion of specificity, so we use + -- '()' as a placeholder value. + { hsf_xvis :: XHsForAllVis pass + , hsf_vis_bndrs :: [LHsTyVarBndr () pass] + } + | HsForAllInvis -- ^ An invisible @forall@ (e.g., @forall a {b} c. {...}@), + -- where each binder has a 'Specificity'. + { hsf_xinvis :: XHsForAllInvis pass + , hsf_invis_bndrs :: [LHsTyVarBndr Specificity pass] + } + | XHsForAllTelescope !(XXHsForAllTelescope pass) + +-- | Located Haskell Type Variable Binder +type LHsTyVarBndr flag pass = XRec pass (HsTyVarBndr flag pass) + -- See Note [HsType binders] + +-- | Located Haskell Quantified Type Variables +data LHsQTyVars pass -- See Note [HsType binders] + = HsQTvs { hsq_ext :: XHsQTvs pass + + , hsq_explicit :: [LHsTyVarBndr (HsBndrVis pass) pass] + -- Explicit variables, written by the user + } + | XLHsQTyVars !(XXLHsQTyVars pass) + +hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass] +hsQTvExplicit (HsQTvs { hsq_explicit = explicit_tvs }) = explicit_tvs +hsQTvExplicit (XLHsQTyVars {}) = panic "hsQTvExplicit" + +------------------------------------------------ +-- HsOuterTyVarBndrs +-- Used to quantify the outermost type variable binders of a type that obeys +-- the forall-or-nothing rule. These are used to represent the outermost +-- quantification in: +-- * Type signatures (LHsSigType/LHsSigWcType) +-- * Patterns in a type/data family instance (HsFamEqnPats) +-- +-- We support two forms: +-- HsOuterImplicit (implicit quantification, added by renamer) +-- f :: a -> a -- Desugars to f :: forall {a}. a -> a +-- type instance F (a,b) = a->b +-- HsOuterExplicit (explicit user quantification): +-- f :: forall a. a -> a +-- type instance forall a b. F (a,b) = a->b +-- +-- In constrast, when the user writes /visible/ quanitification +-- T :: forall k -> k -> Type +-- we use use HsOuterImplicit, wrapped around a HsForAllTy +-- for the visible quantification +-- +-- See Note [forall-or-nothing rule] + +-- | The outermost type variables in a type that obeys the @forall@-or-nothing +-- rule. See @Note [forall-or-nothing rule]@. +data HsOuterTyVarBndrs flag pass + = HsOuterImplicit -- ^ Implicit forall, e.g., + -- @f :: a -> b -> b@ + { hso_ximplicit :: XHsOuterImplicit pass + } + | HsOuterExplicit -- ^ Explicit forall, e.g., + -- @f :: forall a b. a -> b -> b@ + { hso_xexplicit :: XHsOuterExplicit pass flag + , hso_bndrs :: [LHsTyVarBndr flag (NoGhcTc pass)] + } + | XHsOuterTyVarBndrs !(XXHsOuterTyVarBndrs pass) + +-- | Used for signatures, e.g., +-- +-- @ +-- f :: forall a {b}. blah +-- @ +-- +-- We use 'Specificity' for the 'HsOuterTyVarBndrs' @flag@ to allow +-- distinguishing between specified and inferred type variables. +type HsOuterSigTyVarBndrs = HsOuterTyVarBndrs Specificity + +-- | Used for type-family instance equations, e.g., +-- +-- @ +-- type instance forall a. F [a] = Tree a +-- @ +-- +-- The notion of specificity is irrelevant in type family equations, so we use +-- @()@ for the 'HsOuterTyVarBndrs' @flag@. +type HsOuterFamEqnTyVarBndrs = HsOuterTyVarBndrs () + +-- | Haskell Wildcard Binders +data HsWildCardBndrs pass thing + -- See Note [HsType binders] + -- See Note [The wildcard story for types] + = HsWC { hswc_ext :: XHsWC pass thing + -- after the renamer + -- Wild cards, only named + -- See Note [Wildcards in visible kind application] + + , hswc_body :: thing + -- Main payload (type or list of types) + -- If there is an extra-constraints wildcard, + -- it's still there in the hsc_body. + } + | XHsWildCardBndrs !(XXHsWildCardBndrs pass thing) + +-- | Types that can appear in pattern signatures, as well as the signatures for +-- term-level binders in RULES. +-- See @Note [Pattern signature binders and scoping]@. +-- +-- This is very similar to 'HsSigWcType', but with +-- slightly different semantics: see @Note [HsType binders]@. +-- See also @Note [The wildcard story for types]@. +data HsPatSigType pass + = HsPS { hsps_ext :: XHsPS pass -- ^ After renamer: 'HsPSRn' + , hsps_body :: LHsType pass -- ^ Main payload (the type itself) + } + | XHsPatSigType !(XXHsPatSigType pass) + +-- | Located Haskell Signature Type +type LHsSigType pass = XRec pass (HsSigType pass) -- Implicit only + +-- | Located Haskell Wildcard Type +type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only + +-- | Located Haskell Signature Wildcard Type +type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both + +data HsTyPat pass + = HsTP { hstp_ext :: XHsTP pass -- ^ After renamer: 'HsTyPatRn' + , hstp_body :: LHsType pass -- ^ Main payload (the type itself) + } + | XHsTyPat !(XXHsTyPat pass) + +type LHsTyPat pass = XRec pass (HsTyPat pass) + +-- | A type signature that obeys the @forall@-or-nothing rule. In other +-- words, an 'LHsType' that uses an 'HsOuterSigTyVarBndrs' to represent its +-- outermost type variable quantification. +-- See @Note [Representing type signatures]@. +data HsSigType pass + = HsSig { sig_ext :: XHsSig pass + , sig_bndrs :: HsOuterSigTyVarBndrs pass + , sig_body :: LHsType pass + } + | XHsSigType !(XXHsSigType pass) + +{- +Note [forall-or-nothing rule] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Free variables in signatures are usually bound in an implicit 'forall' at the +beginning of user-written signatures. However, if the signature has an +explicit, invisible forall at the beginning, this is disabled. This is referred +to as the forall-or-nothing rule. + +The idea is nested foralls express something which is only expressible +explicitly, while a top level forall could (usually) be replaced with an +implicit binding. Top-level foralls alone ("forall.") are therefore an +indication that the user is trying to be fastidious, so we don't implicitly +bind any variables. + +Note that this rule only applies to outermost /in/visible 'forall's, and not +outermost visible 'forall's. See #18660 for more on this point. + +Here are some concrete examples to demonstrate the forall-or-nothing rule in +action: + + type F1 :: a -> b -> b -- Legal; a,b are implicitly quantified. + -- Equivalently: forall a b. a -> b -> b + + type F2 :: forall a b. a -> b -> b -- Legal; explicitly quantified + + type F3 :: forall a. a -> b -> b -- Illegal; the forall-or-nothing rule says that + -- if you quantify a, you must also quantify b + + type F4 :: forall a -> b -> b -- Legal; the top quantifier (forall a) is a /visible/ + -- quantifier, so the "nothing" part of the forall-or-nothing + -- rule applies, and b is therefore implicitly quantified. + -- Equivalently: forall b. forall a -> b -> b + + type F5 :: forall b. forall a -> b -> c -- Illegal; the forall-or-nothing rule says that + -- if you quantify b, you must also quantify c + + type F6 :: forall a -> forall b. b -> c -- Legal: just like F4. + +For a complete list of all places where the forall-or-nothing rule applies, see +"The `forall`-or-nothing rule" section of the GHC User's Guide. + +Any type that obeys the forall-or-nothing rule is represented in the AST with +an HsOuterTyVarBndrs: + +* If the type has an outermost, invisible 'forall', it uses HsOuterExplicit, + which contains a list of the explicitly quantified type variable binders in + `hso_bndrs`. After typechecking, HsOuterExplicit also stores a list of the + explicitly quantified `InvisTVBinder`s in + `hso_xexplicit :: XHsOuterExplicit GhcTc`. + +* Otherwise, it uses HsOuterImplicit. HsOuterImplicit is used for different + things depending on the phase: + + * After parsing, it does not store anything in particular. + * After renaming, it stores the implicitly bound type variable `Name`s in + `hso_ximplicit :: XHsOuterImplicit GhcRn`. + * After typechecking, it stores the implicitly bound `TyVar`s in + `hso_ximplicit :: XHsOuterImplicit GhcTc`. + + NB: this implicit quantification is purely lexical: we bind any + type or kind variables that are not in scope. The type checker + may subsequently quantify over further kind variables. + See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig. + +HsOuterTyVarBndrs GhcTc is used in the typechecker as an intermediate data type +for storing the outermost TyVars/InvisTVBinders in a type. +See GHC.Tc.Gen.HsType.bindOuterTKBndrsX for an example of this. + +Note [Representing type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsSigType is used to represent an explicit user type signature. These are +used in a variety of places. Some examples include: + +* Type signatures (e.g., f :: a -> a) +* Standalone kind signatures (e.g., type G :: a -> a) +* GADT constructor types (e.g., data T where MkT :: a -> T) + +A HsSigType is the combination of an HsOuterSigTyVarBndrs and an LHsType: + +* The HsOuterSigTyVarBndrs binds the /explicitly/ quantified type variables + when the type signature has an outermost, user-written 'forall' (i.e, + the HsOuterExplicit constructor is used). If there is no outermost 'forall', + then it binds the /implicitly/ quantified type variables instead (i.e., + the HsOuterImplicit constructor is used). +* The LHsType represents the rest of the type. + +E.g. For a signature like + f :: forall k (a::k). blah +we get + HsSig { sig_bndrs = HsOuterExplicit { hso_bndrs = [k, (a :: k)] } + , sig_body = blah } + +Note [Pattern signature binders and scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the pattern signatures like those on `t` and `g` in: + + f = let h = \(t :: (b, b) -> + \(g :: forall a. a -> b) -> + ...(t :: (Int,Int))... + in woggle + +* The `b` in t's pattern signature is implicitly bound and scopes over + the signature and the body of the lambda. It stands for a type (any type); + indeed we subsequently discover that b=Int. + (See Note [TyVarTv] in GHC.Tc.Utils.TcMType for more on this point.) +* The `b` in g's pattern signature is an /occurrence/ of the `b` bound by + t's pattern signature. +* The `a` in `forall a` scopes only over the type `a -> b`, not over the body + of the lambda. +* There is no forall-or-nothing rule for pattern signatures, which is why the + type `forall a. a -> b` is permitted in `g`'s pattern signature, even though + `b` is not explicitly bound. See Note [forall-or-nothing rule]. + +Similar scoping rules apply to term variable binders in RULES, like in the +following example: + + {-# RULES "h" forall (t :: (b, b)) (g :: forall a. a -> b). h t g = ... #-} + +Just like in pattern signatures, the `b` in t's signature is implicitly bound +and scopes over the remainder of the RULE. As a result, the `b` in g's +signature is an occurrence. Moreover, the `a` in `forall a` scopes only over +the type `a -> b`, and the forall-or-nothing rule does not apply. + +While quite similar, RULE term binder signatures behave slightly differently +from pattern signatures in two ways: + +1. Unlike in pattern signatures, where type variables can stand for any type, + type variables in RULE term binder signatures are skolems. + See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType for + more on this point. + + In this sense, type variables in pattern signatures are quite similar to + named wildcards, as both can refer to arbitrary types. The main difference + lies in error reporting: if a named wildcard `_a` in a pattern signature + stands for Int, then by default GHC will emit a warning stating as much. + Changing `_a` to `a`, on the other hand, will cause it not to be reported. +2. In the `h` RULE above, only term variables are explicitly bound, so any free + type variables in the term variables' signatures are implicitly bound. + This is just like how the free type variables in pattern signatures are + implicitly bound. If a RULE explicitly binds both term and type variables, + however, then free type variables in term signatures are /not/ implicitly + bound. For example, this RULE would be ill scoped: + + {-# RULES "h2" forall b. forall (t :: (b, c)) (g :: forall a. a -> b). + h2 t g = ... #-} + + This is because `b` and `c` occur free in the signature for `t`, but only + `b` was explicitly bound, leaving `c` out of scope. If the RULE had started + with `forall b c.`, then it would have been accepted. + +The types in pattern signatures and RULE term binder signatures are represented +in the AST by HsSigPatType. From the renamer onward, the hsps_ext field (of +type HsPSRn) tracks the names of named wildcards and implicitly bound type +variables so that they can be brought into scope during renaming and +typechecking. + +Note [Lexically scoped type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ScopedTypeVariables extension does two things: + +* It allows the use of type signatures in patterns + (e.g., `f (x :: a -> a) = ...`). See + Note [Pattern signature binders and scoping] for more on this point. +* It brings lexically scoped type variables into scope for certain type + signatures with outermost invisible 'forall's. + +This Note concerns the latter bullet point. Per the +"Lexically scoped type variables" section of the GHC User's Guide, the +following forms of type signatures can have lexically scoped type variables: + +* In declarations with type signatures, e.g., + + f :: forall a. a -> a + f x = e @a + + Here, the 'forall a' brings 'a' into scope over the body of 'f'. + + Note that ScopedTypeVariables does /not/ interact with standalone kind + signatures, only type signatures. + +* In explicit type annotations in expressions, e.g., + + id @a :: forall a. a -> a + +* In instance declarations, e.g., + + instance forall a. C [a] where + m = e @a + + Note that unlike the examples above, the use of an outermost 'forall' isn't + required to bring 'a' into scope. That is, the following would also work: + + instance forall a. C [a] where + m = e @a + +Note that all of the types above obey the forall-or-nothing rule. As a result, +the places in the AST that can have lexically scoped type variables are a +subset of the places that use HsOuterTyVarBndrs +(See Note [forall-or-nothing rule].) + +Some other observations about lexically scoped type variables: + +* Only type variables bound by an /invisible/ forall can be lexically scoped. + See Note [hsScopedTvs and visible foralls]. +* The lexically scoped type variables may be a strict subset of the type + variables brought into scope by a type signature. + See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig. +-} + +mapHsOuterImplicit :: (XHsOuterImplicit pass -> XHsOuterImplicit pass) + -> HsOuterTyVarBndrs flag pass + -> HsOuterTyVarBndrs flag pass +mapHsOuterImplicit f (HsOuterImplicit{hso_ximplicit = imp}) = + HsOuterImplicit{hso_ximplicit = f imp} +mapHsOuterImplicit _ hso@(HsOuterExplicit{}) = hso +mapHsOuterImplicit _ hso@(XHsOuterTyVarBndrs{}) = hso + + +-------------------------------------------------- +-- | These names are used early on to store the names of implicit +-- parameters. They completely disappear after type-checking. +newtype HsIPName = HsIPName FastString + deriving( Eq, Data ) + +hsIPNameFS :: HsIPName -> FastString +hsIPNameFS (HsIPName n) = n + +-------------------------------------------------- + +-- | Haskell Type Variable Binder +-- See Note [Type variable binders] +data HsTyVarBndr flag pass + = HsTvb { tvb_ext :: XTyVarBndr pass + , tvb_flag :: flag + , tvb_var :: HsBndrVar pass + , tvb_kind :: HsBndrKind pass } + | XTyVarBndr + !(XXTyVarBndr pass) + +data HsBndrVis pass + = HsBndrRequired !(XBndrRequired pass) + -- Binder for a visible (required) variable: + -- type Dup a = (a, a) + -- ^^^ + + | HsBndrInvisible !(XBndrInvisible pass) + -- Binder for an invisible (specified) variable: + -- type KindOf @k (a :: k) = k + -- ^^^ + + | XBndrVis !(XXBndrVis pass) + +type family XBndrRequired p +type family XBndrInvisible p +type family XXBndrVis p + +isHsBndrInvisible :: HsBndrVis pass -> Bool +isHsBndrInvisible HsBndrInvisible{} = True +isHsBndrInvisible HsBndrRequired{} = False +isHsBndrInvisible (XBndrVis _) = False + +data HsBndrVar pass + = HsBndrVar !(XBndrVar pass) !(LIdP pass) + | HsBndrWildCard !(XBndrWildCard pass) + | XBndrVar !(XXBndrVar pass) + +type family XBndrVar p +type family XBndrWildCard p +type family XXBndrVar p + +isHsBndrWildCard :: HsBndrVar pass -> Bool +isHsBndrWildCard HsBndrWildCard{} = True +isHsBndrWildCard HsBndrVar{} = False +isHsBndrWildCard (XBndrVar _) = False + +data HsBndrKind pass + = HsBndrKind !(XBndrKind pass) (LHsKind pass) + | HsBndrNoKind !(XBndrNoKind pass) + | XBndrKind !(XXBndrKind pass) + +type family XBndrKind p +type family XBndrNoKind p +type family XXBndrKind p + +-- | Does this 'HsTyVarBndr' come with an explicit kind annotation? +isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool +isHsKindedTyVar (HsTvb { tvb_kind = kind }) = + case kind of + HsBndrKind _ _ -> True + HsBndrNoKind _ -> False + XBndrKind _ -> False +isHsKindedTyVar (XTyVarBndr {}) = False + + +{- Note [Type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type variable binders, represented by the HsTyVarBndr type, can occur in the +following contexts: + +1. On the left-hand sides of type/class declarations (TyClDecl) + + data D a b = ... -- data types (DataDecl) + newtype N a b = ... -- newtypes (DataDecl) + type T a b = ... -- type synonyms (SynDecl) + class C a b where ... -- classes (ClassDecl) + type family TF a b -- type families (FamDecl) + data family DF a b -- data families (FamDecl) + + The `a` and `b` in these examples are type variable binders. + +2. In forall telescopes (HsForAllTy and HsOuterTyVarBndrs) + + 2-Invis. forall {a} b. ... -- invisible forall (HsForAllInvis) + 2-Vis. forall a b -> ... -- visible forall (HsForAllVis) + + Again, `a` and `b` are type variable binders. + +3. In type family result signatures (FamilyResultSig), which are + part of the TypeFamilyDependencies extension + + type family F a = r | r -> a -- result sig (TyVarSig) + + The `r` immediately to the right of `=` is a type variable binder. + +4. In constructor patterns, as long as the conditions outlined in + Note [Type patterns: binders and unifiers] are satisfied + + fn (MkT @a @b x y) = ... -- invisible type arguments (InvisPat) + -- in constructor patterns (ConPat) + + Here, the `a` and `b` are type variable binders iff + `GHC.Tc.Gen.HsType.tyPatToBndr` returns `Just`. + +A type variable binder has three parts: + * flag (HsBndrVis, Specificity, or () -- depending on context) + * variable (HsBndrVar) + * kind (HsBndrKind) + +Details about each part: + +* The binder variable (HsBndrVar) is either a type variable name or a wildcard, + i.e. `a` vs `_` (HsBndrVar vs HsBndrWildCard). + +* The binder kind (HsBndrKind) stores the optional kind annotation, + i.e. `a` vs `a :: k` (HsBndrNoKind vs HsBndrKind). + +* The binder flag is instantiated to one of the following types, + depending on the context where it occurs (contexts 1..4 are listed above) + + (a) flag=HsBndrVis records `a` vs `@a` (HsBndrRequired vs HsBndrInvisible) + (used in contexts: 1) + (b) flag=Specificity records `a` vs `{a}` (SpecifiedSpec vs InferredSpec) + (used in contexts: 2-Invis) + (c) flag=() is used when there is no distinction to record + (used in contexts: 2-Vis, 3, 4) + +All in all, we have the following forms of type variable binders in the language + + a, (a :: k), @a, @(a :: k), {a}, {a :: k} + _, (_ :: k), @_, @(_ :: k) + +The forms {_}, {_ :: k} are representable but never valid, see +Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type -} + +-- | Haskell Type +data HsType pass + = HsForAllTy -- See Note [HsType binders] + { hst_xforall :: XForAllTy pass + , hst_tele :: HsForAllTelescope pass + -- Explicit, user-supplied 'forall a {b} c' + , hst_body :: LHsType pass -- body type + } + + | HsQualTy -- See Note [HsType binders] + { hst_xqual :: XQualTy pass + , hst_ctxt :: LHsContext pass -- Context C => blah + , hst_body :: LHsType pass } + + | HsTyVar (XTyVar pass) + PromotionFlag -- Whether explicitly promoted, + -- for the pretty printer + (LIdOccP pass) + -- Type variable, type constructor, or data constructor + -- see Note [Promotions (HsTyVar)] + -- See Note [Located RdrNames] in GHC.Hs.Expr + + | HsAppTy (XAppTy pass) + (LHsType pass) + (LHsType pass) + + | HsAppKindTy (XAppKindTy pass) -- type level type app + (LHsType pass) + (LHsKind pass) + + | HsFunTy (XFunTy pass) + (HsMultAnn pass) -- multiplicty annotations, includes the arrow + (LHsType pass) -- function type + (LHsType pass) + + | HsListTy (XListTy pass) + (LHsType pass) -- Element type + + | HsTupleTy (XTupleTy pass) + HsTupleSort + [LHsType pass] -- Element types (length gives arity) + + | HsSumTy (XSumTy pass) + [LHsType pass] -- Element types (length gives arity) + + | HsOpTy (XOpTy pass) + PromotionFlag -- Whether explicitly promoted, + -- for the pretty printer + (LHsType pass) (LIdOccP pass) (LHsType pass) + + | HsParTy (XParTy pass) + (LHsType pass) -- See Note [Parens in HsSyn] in GHC.Hs.Expr + -- Parenthesis preserved for the precedence re-arrangement in + -- GHC.Rename.HsType + -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! + + | HsIParamTy (XIParamTy pass) + (XRec pass HsIPName) -- (?x :: ty) + (LHsType pass) -- Implicit parameters as they occur in + -- contexts + -- ^ + -- > (?x :: ty) + + | HsStarTy (XStarTy pass) + Bool -- Is this the Unicode variant? + -- Note [HsStarTy] + + | HsKindSig (XKindSig pass) + (LHsType pass) -- (ty :: kind) + (LHsKind pass) -- A type with a kind signature + -- ^ + -- > (ty :: kind) + + | HsSpliceTy (XSpliceTy pass) + (HsUntypedSplice pass) -- Includes quasi-quotes + + | HsDocTy (XDocTy pass) + (LHsType pass) (LHsDoc pass) -- A documented type + + | HsExplicitListTy -- A promoted explicit list + (XExplicitListTy pass) + PromotionFlag -- whether explicitly promoted, for pretty printer + [LHsType pass] + + | HsExplicitTupleTy -- A promoted explicit tuple + (XExplicitTupleTy pass) + PromotionFlag -- whether explicitly promoted, for pretty printer + [LHsType pass] + + | HsTyLit (XTyLit pass) (HsTyLit pass) -- A promoted numeric literal. + + | HsWildCardTy (XWildCardTy pass) -- A type wildcard + -- See Note [The wildcard story for types] + + -- Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension + | XHsType + !(XXType pass) + + +-- | Haskell Type Literal +data HsTyLit pass + = HsNumTy (XNumTy pass) Integer + | HsStrTy (XStrTy pass) FastString + | HsCharTy (XCharTy pass) Char + | XTyLit !(XXTyLit pass) + +type HsMultAnn pass = HsMultAnnOf (LHsType (NoGhcTc pass)) pass + +-- | Denotes multiplicity annotations in the surface language. +-- The `mult` type argument is usually `LHsType (NoGhcTc pass)`, but when the annotation +-- is part of a type used in a term, it is `LHsExpr pass`. See Note [Types in terms]. +data HsMultAnnOf mult pass + = HsUnannotated !(XUnannotated mult pass) + -- ^ a -> b or a → b or { nm :: a } + + | HsLinearAnn !(XLinearAnn mult pass) + -- ^ a %1 -> b or a %1 → b, or a ⊸ b, or { nm %1 :: a } + + | HsExplicitMult !(XExplicitMult mult pass) !mult + -- ^ a %m -> b or a %m → b or { nm %m :: a } + -- (very much including `a %Many -> b`! + -- This is how the programmer wrote it). It is stored as an + -- `HsType` so as to preserve the syntax as written in the + -- program. + + | XMultAnnOf !(XXMultAnnOf mult pass) + +type family XUnannotated mult p +type family XLinearAnn mult p +type family XExplicitMult mult p +type family XXMultAnnOf mult p + +{- +Note [Unit tuples] +~~~~~~~~~~~~~~~~~~ +Consider the type + type instance F Int = () +We want to parse that "()" + as HsTupleTy HsBoxedOrConstraintTuple [], +NOT as HsTyVar unitTyCon + +Why? Because F might have kind (* -> Constraint), so we when parsing we +don't know if that tuple is going to be a constraint tuple or an ordinary +unit tuple. The HsTupleSort flag is specifically designed to deal with +that, but it has to work for unit tuples too. + +Note [Promotions (HsTyVar)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsTyVar: A name in a type or kind. + Here are the allowed namespaces for the name. + In a type: + Var: not allowed + Data: promoted data constructor + Tv: type variable + TcCls before renamer: type constructor, class constructor, or promoted data constructor + TcCls after renamer: type constructor or class constructor + In a kind: + Var, Data: not allowed + Tv: kind variable + TcCls: kind constructor or promoted type constructor + + The 'Promoted' field in an HsTyVar captures whether the type was promoted in + the source code by prefixing an apostrophe. + +Note [HsStarTy] +~~~~~~~~~~~~~~~ +When the StarIsType extension is enabled, we want to treat '*' and its Unicode +variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser +would mean that when we pretty-print it back, we don't know whether the user +wrote '*' or 'Type', and lose the parse/ppr roundtrip property. + +As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type') +and then desugar it to 'Data.Kind.Type' in the typechecker (see tcHsType). +When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not +involved. + + +Note [Promoted lists and tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice the difference between + HsListTy HsExplicitListTy + HsTupleTy HsExplicitListTupleTy + +E.g. f :: [Int] HsListTy + + g3 :: T '[] All these use + g2 :: T '[True] HsExplicitListTy + g1 :: T '[True,False] + g1a :: T [True,False] (can omit ' where unambiguous) + + kind of T :: [Bool] -> * This kind uses HsListTy! + +E.g. h :: (Int,Bool) HsTupleTy; f is a pair + k :: S '(True,False) HsExplicitTypleTy; S is indexed by + a type-level pair of booleans + kind of S :: (Bool,Bool) -> * This kind uses HsExplicitTupleTy + +Note [Distinguishing tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Apart from promotion, tuples can have one of three different kinds: + + x :: (Int, Bool) -- Regular boxed tuples + f :: Int# -> (# Int#, Int# #) -- Unboxed tuples + g :: (Eq a, Ord a) => a -- Constraint tuples + +For convenience, internally we use a single constructor for all of these, +namely HsTupleTy, but keep track of the tuple kind (in the first argument to +HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing, +because of the #. However, with -XConstraintKinds we can only distinguish +between constraint and boxed tuples during type checking, in general. Hence the +two constructors of HsTupleSort: + + HsUnboxedTuple -> Produced by the parser + HsBoxedOrConstraintTuple -> Could be a boxed or a constraint + tuple. Produced by the parser only, + disappears after type checking + +After typechecking, we use TupleSort (which clearly distinguishes between +constraint tuples and boxed tuples) rather than HsTupleSort. +-} + +-- | Haskell Tuple Sort +data HsTupleSort = HsUnboxedTuple + | HsBoxedOrConstraintTuple + deriving Data + +-- | Located Constructor Declaration Record Field +type LHsConDeclRecField pass = XRec pass (HsConDeclRecField pass) + +-- | Constructor Declaration Record Field +data HsConDeclRecField pass + = HsConDeclRecField { cdrf_ext :: XConDeclRecField pass, + cdrf_names :: [LFieldOcc pass], + -- ^ See Note [FieldOcc pass] + cdrf_spec :: HsConDeclField pass } + | XConDeclRecField !(XXConDeclRecField pass) + +-- | Describes the arguments to a data constructor. This is a common +-- representation for several constructor-related concepts, including: +-- +-- * The arguments in a Haskell98-style constructor declaration +-- (see 'HsConDeclH98Details' in "GHC.Hs.Decls"). +-- +-- * The arguments in constructor patterns in @case@/function definitions +-- (see 'HsConPatDetails' in "GHC.Hs.Pat"). +-- +-- * The left-hand side arguments in a pattern synonym binding +-- (see 'HsPatSynDetails' in "GHC.Hs.Binds"). +-- +-- One notable exception is the arguments in a GADT constructor, which uses +-- a separate data type entirely (see 'HsConDeclGADTDetails' in +-- "GHC.Hs.Decls"). This is because GADT constructors cannot be declared with +-- infix syntax, unlike the concepts above (#18844). +data HsConDetails arg rec + = PrefixCon [arg] -- C @t1 @t2 p1 p2 p3 + | RecCon rec -- C { x = p1, y = p2 } + | InfixCon arg arg -- p1 `C` p2 + deriving Data + +-- | Constructor declaration field specification, see Note [HsConDeclField on pass] +data HsConDeclField pass + = CDF { cdf_ext :: XConDeclField pass + -- ^ Extension point + + , cdf_unpack :: SrcUnpackedness + -- ^ UNPACK pragma if any + -- E.g. data T = MkT {-# UNPACK #-} Int + -- or data T where MtT :: {-# UNPACK #-} Int -> T + + , cdf_bang :: SrcStrictness + -- ^ User-specified strictness, if any + -- E.g. data T a = MkT !a + -- or data T a where MtT :: !a -> T a + + , cdf_multiplicity :: HsMultAnn pass + -- ^ User-specified multiplicity, if any + -- E.g. data T a = MkT { t %Many :: a } + -- or data T a where MtT :: a %1 -> T a + + , cdf_type :: LHsType pass + -- ^ The type of the field + + , cdf_doc :: Maybe (LHsDoc pass) + -- ^ Documentation for the field + -- F.e. this very piece of documentation + } + +{- Note [HsConDeclField on pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`HsConDeclField` is used to specify the type of a data single constructor argument for all of: +* Haskell-98 style declarations (with prefix, infix or record syntax) + e.g. data T1 a = MkT (Maybe a) !Int +* GADT-style declarations with arrow syntax + e.g. data T2 a where MkT :: Maybe a -> !Int -> T2 a +* GADT-style declarations with record syntax + e.g. data T3 a where MkT :: { x :: Maybe a, y :: !Int } -> T3 a + +Each argument type is decorated with any user-defined + a) UNPACK pragma `cdf_unpack` + b) strictness annotation `cdf_bang` + c) multiplicity annotation `cdf_multiplicity` + In the case of Haskell-98 style declarations, this only applies to record syntax. + d) documentation `cdf_doc` +-} + +----------------------- +-- A valid type must have a for-all at the top of the type, or of the fn arg +-- types + +--------------------- + +{- Note [Scoping of named wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: _a -> _a + f x = let g :: _a -> _a + g = ... + in ... + +Currently, for better or worse, the "_a" variables are all the same. So +although there is no explicit forall, the "_a" scopes over the definition. +I don't know if this is a good idea, but there it is. +-} + +{- Note [hsScopedTvs and visible foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ScopedTypeVariables can be defined in terms of a desugaring to TypeAbstractions +(GHC Proposals #155 and #448): + + fn :: forall a b c. tau(a,b,c) fn :: forall a b c. tau(a,b,c) + fn = defn(a,b,c) ==> fn @x @y @z = defn(x,y,z) + +That is, for every type variable of the leading `forall` in the type signature, +we add an invisible binder at the term level. + +This model does not extend to visible forall. (Visible forall is the one written +with an arrow instead of a dot, i.e. `forall a ->`. See GHC Proposal #281 and +the RequiredTypeArguments extension). Here is an example that demonstrates the +issue: + + vfn :: forall a b -> tau(a, b) + vfn = case of (p,q) -> \x y -> ... + +The `a` and `b` cannot scope over the equations of `vfn`. In particular, +`a` and `b` cannot be in scope in because those type variables +are bound by the `\x y ->`. + +Our solution is simple: ScopedTypeVariables has no effect on visible forall. +It follows naturally from the fact that ScopedTypeVariables is already subject +to several restrictions: + + 1. The type signature must be headed by an /explicit/ forall + * `f :: forall a. a -> blah` brings `a` into scope in the body + * `f :: a -> blah` does not + + 2. The forall is /not nested/ + * `f :: forall a b. blah` brings `a` and `b` into scope in the body + * `f :: forall a. forall b. blah` brings `a` but not `b` into scope in the body + +With the introduction of visible forall, we also introduce a third condition: + + 3. The forall has to be /invisible/ + * `f :: forall a b. blah` brings `a` and `b` into scope in the body + * `f :: forall a b -> blah` does not + +For example: + + f1 :: forall a. a -> a + f1 x = (x::a) -- OK: `a` is in scope in the body + + f2 :: forall a b. a -> b -> (a, b) + f2 x y = (x::a, y::b) -- OK: both `a` and `b` are in scope in the body + + f3 :: forall a. forall b. a -> b -> (a, b) + f3 x y = (x::a, y::b) -- Wrong: the `forall b.` is not the outermost forall + + f4 :: forall a -> a -> a + f4 t (x::t) = (x::a) -- Wrong: the `forall a ->` does not bring `a` into scope + +This design choice is reflected in the definition of HsOuterSigTyVarBndrs, which are +used in every place where ScopedTypeVariables takes effect: + + data HsOuterTyVarBndrs flag pass + = HsOuterImplicit { ... } + | HsOuterExplicit { ..., hso_bndrs :: [LHsTyVarBndr flag pass] } + | ... + type HsOuterSigTyVarBndrs = HsOuterTyVarBndrs Specificity + +The HsOuterExplicit constructor is only used in type signatures with outermost, +/invisible/ 'forall's. Any other type—including those with outermost, +/visible/ 'forall's—will use HsOuterImplicit. Therefore, when we determine +which type variables to bring into scope over the body of a function +(in hsScopedTvs), we /only/ bring the type variables bound by the hso_bndrs in +an HsOuterExplicit into scope. If we have an HsOuterImplicit instead, then we +do not bring any type variables into scope over the body of a function at all. +-} + +{- +************************************************************************ +* * + Decomposing HsTypes +* * +************************************************************************ +-} + +-- | Arguments in an expression/type after splitting +data HsArg p tm ty + = HsValArg !(XValArg p) tm -- Argument is an ordinary expression (f arg) + | HsTypeArg !(XTypeArg p) ty -- Argument is a visible type application (f @ty) + | HsArgPar !(XArgPar p) -- See Note [HsArgPar] + | XArg !(XXArg p) + +type family XValArg p +type family XTypeArg p +type family XArgPar p +type family XXArg p + +-- type level equivalent +type LHsTypeArg p = HsArg p (LHsType p) (LHsKind p) + +{- +Note [HsArgPar] +~~~~~~~~~~~~~~~ +A HsArgPar indicates that everything to the left of this in the argument list is +enclosed in parentheses together with the function itself. It is necessary so +that we can recreate the parenthesis structure in the original source after +typechecking the arguments. + +The SrcSpan is the span of the original HsPar + +((f arg1) arg2 arg3) results in an input argument list of +[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2] + +-} + + +{- +************************************************************************ +* * + FieldOcc +* * +************************************************************************ +-} + +-- | Located Field Occurrence +type LFieldOcc pass = XRec pass (FieldOcc pass) + +-- | Field Occurrence +-- +-- Represents an *occurrence* of a field. This may or may not be a +-- binding occurrence (e.g. this type is used in 'HsConDeclRecField' and +-- 'RecordPatSynField' which bind their fields, but also in +-- 'HsRecField' for record construction and patterns, which do not). +-- +-- We store both the 'RdrName' the user originally wrote, and after +-- the renamer we use the extension field to store the selector +-- function. See note [FieldOcc pass] +-- +-- There is a wrinkle in that update field occurances are sometimes +-- ambiguous during the rename stage. See note +-- [Ambiguous FieldOcc in record updates] to see how we currently +-- handle this. +data FieldOcc pass + = FieldOcc { + foExt :: XCFieldOcc pass + , foLabel :: LIdP pass + } + | XFieldOcc !(XXFieldOcc pass) +deriving instance ( + Eq (LIdP pass) + , Eq (XCFieldOcc pass) + , Eq (XXFieldOcc pass) + ) => Eq (FieldOcc pass) + +{- Note [FieldOcc pass] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The foLabel field of FieldOcc GhcRn contains the field name as the user wrote it. +After the renamer, a FieldOcc GhcTc has +- foExt field: A RdrName containing the original field label written by the user +- foLabel field: An Id for the field selector, whose OccName may have been mangled + to give it a globally unique identity. + +For example, when DuplicateRecordFields is enabled + + data T = MkT { x :: Int } + +gives + + FieldOcc "x" $sel:x:MkT. +-} + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} diff --git a/Language/Haskell/Syntax/Type.hs-boot b/Language/Haskell/Syntax/Type.hs-boot new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Type.hs-boot @@ -0,0 +1,26 @@ +module Language.Haskell.Syntax.Type where + +import Data.Bool +import Data.Eq +import Data.Ord + +import Control.DeepSeq + +{- +************************************************************************ +* * +\subsection{Promotion flag} +* * +************************************************************************ +-} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + +instance Eq PromotionFlag +instance Ord PromotionFlag +instance NFData PromotionFlag + +isPromoted :: PromotionFlag -> Bool diff --git a/MachRegs.h b/MachRegs.h new file mode 100644 --- /dev/null +++ b/MachRegs.h @@ -0,0 +1,229 @@ +/* ----------------------------------------------------------------------------- + * + * (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 + +/* ---------------------------------------------------------------------------- + Note [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_ for each that + is designated caller-saves in that machine's C calling convention. + NB: Caller-saved registers not mapped to a STG register don't + require a CALLER_SAVES_ define. + + As it stands, the only registers that are ever marked caller saves + are the RX, FX, DX, XMM 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. + -------------------------------------------------------------------------- */ + +/* Define STG <-> machine register mappings. */ +#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) + +#include "MachRegs/x86.h" + +#elif defined(MACHREGS_powerpc) + +#include "MachRegs/ppc.h" + +#elif defined(MACHREGS_arm) + +#include "MachRegs/arm32.h" + +#elif defined(MACHREGS_aarch64) + +#include "MachRegs/arm64.h" + +#elif defined(MACHREGS_s390x) + +#include "MachRegs/s390x.h" + +#elif defined(MACHREGS_riscv64) + +#include "MachRegs/riscv64.h" + +#elif defined(MACHREGS_wasm32) + +#include "MachRegs/wasm32.h" + +#elif defined(MACHREGS_loongarch64) + +#include "MachRegs/loongarch64.h" + +#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 && MAX_REAL_XMM_REG == 0 +#define NO_ARG_REGS +#else +#undef NO_ARG_REGS +#endif diff --git a/MachRegs/arm32.h b/MachRegs/arm32.h new file mode 100644 --- /dev/null +++ b/MachRegs/arm32.h @@ -0,0 +1,60 @@ +#pragma once + +/* ----------------------------------------------------------------------------- + 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 + ----------------------------------------------------------------------------- */ + +#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 diff --git a/MachRegs/arm64.h b/MachRegs/arm64.h new file mode 100644 --- /dev/null +++ b/MachRegs/arm64.h @@ -0,0 +1,64 @@ +#pragma once + + +/* ----------------------------------------------------------------------------- + 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 + + ----------------------------------------------------------------------------- */ + +#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 + +#define REG_XMM1 q4 +#define REG_XMM2 q5 + +#define CALLER_SAVES_XMM1 +#define CALLER_SAVES_XMM2 + diff --git a/MachRegs/loongarch64.h b/MachRegs/loongarch64.h new file mode 100644 --- /dev/null +++ b/MachRegs/loongarch64.h @@ -0,0 +1,48 @@ +#pragma once + +/* ----------------------------------------------------------------------------- + The loongarch64 register mapping + + Register | Role(s) | Call effect + ------------+-----------------------------------------+------------- + zero | Hard-wired zero | - + ra | Return address | caller-saved + tp | Thread pointer | - + sp | Stack pointer | callee-saved + a0,a1 | Arguments / return values | caller-saved + a2..a7 | Arguments | caller-saved + t0..t8 | - | caller-saved + u0 | Reserve | - + fp | Frame pointer | callee-saved + s0..s8 | - | callee-saved + fa0,fa1 | Arguments / return values | caller-saved + fa2..fa7 | Arguments | caller-saved + ft0..ft15 | - | caller-saved + fs0..fs7 | - | callee-saved + + Each general purpose register as well as each floating-point + register is 64 bits wide, also, the u0 register is called r21 in some cases. + + -------------------------------------------------------------------------- */ + +#define REG(x) __asm__("$" #x) + +#define REG_Base s0 +#define REG_Sp s1 +#define REG_Hp s2 +#define REG_R1 s3 +#define REG_R2 s4 +#define REG_R3 s5 +#define REG_R4 s6 +#define REG_R5 s7 +#define REG_SpLim s8 + +#define REG_F1 fs0 +#define REG_F2 fs1 +#define REG_F3 fs2 +#define REG_F4 fs3 + +#define REG_D1 fs4 +#define REG_D2 fs5 +#define REG_D3 fs6 +#define REG_D4 fs7 diff --git a/MachRegs/ppc.h b/MachRegs/ppc.h new file mode 100644 --- /dev/null +++ b/MachRegs/ppc.h @@ -0,0 +1,62 @@ +#pragma once + +/* ----------------------------------------------------------------------------- + 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! + -------------------------------------------------------------------------- */ + + +#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 diff --git a/MachRegs/riscv64.h b/MachRegs/riscv64.h new file mode 100644 --- /dev/null +++ b/MachRegs/riscv64.h @@ -0,0 +1,58 @@ +#pragma once + +/* ----------------------------------------------------------------------------- + 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. + + -------------------------------------------------------------------------- */ + +#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 diff --git a/MachRegs/s390x.h b/MachRegs/s390x.h new file mode 100644 --- /dev/null +++ b/MachRegs/s390x.h @@ -0,0 +1,72 @@ +#pragma once + +/* ----------------------------------------------------------------------------- + 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. + + -------------------------------------------------------------------------- */ + + +#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 diff --git a/MachRegs/wasm32.h b/MachRegs/wasm32.h new file mode 100644 --- /dev/null +++ b/MachRegs/wasm32.h @@ -0,0 +1,35 @@ +#pragma once + +#define REG_Base 0 + +#define REG_R1 1 +#define REG_R2 2 +#define REG_R3 3 +#define REG_R4 4 +#define REG_R5 5 +#define REG_R6 6 +#define REG_R7 7 +#define REG_R8 8 +#define REG_R9 9 +#define REG_R10 10 + +#define REG_F1 11 +#define REG_F2 12 +#define REG_F3 13 +#define REG_F4 14 +#define REG_F5 15 +#define REG_F6 16 + +#define REG_D1 17 +#define REG_D2 18 +#define REG_D3 19 +#define REG_D4 20 +#define REG_D5 21 +#define REG_D6 22 + +#define REG_L1 23 + +#define REG_Sp 24 +#define REG_SpLim 25 +#define REG_Hp 26 +#define REG_HpLim 27 diff --git a/MachRegs/x86.h b/MachRegs/x86.h new file mode 100644 --- /dev/null +++ b/MachRegs/x86.h @@ -0,0 +1,216 @@ +/* ----------------------------------------------------------------------------- + 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 Fn, Dn and XMMn to register xmmn. +This unfortunately conflicts with the C calling convention, where the first +argument and destination registers is xmm0, but the GHC calling convention in +LLVM starts with xmm1 instead (and we can't easily change that). + +The aliasing allows us to pass a function any combination of up to +six Float#, Double# or vector arguments without touching the stack +(when using the System V calling convention). +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 + +#endif /* MACHREGS_i386 || MACHREGS_x86_64 */ diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,164 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Main where + import Distribution.Simple -main = defaultMain +import Distribution.Simple.BuildPaths +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentName (ComponentName(CLibName)) +import Distribution.Types.LocalBuildInfo +import Distribution.Types.LibraryName (LibraryName(LMainLibName)) +import Distribution.Verbosity +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Simple.Setup +import Distribution.Simple.PackageIndex + +import System.IO +import System.Process +import System.Directory +import System.FilePath +import Control.Monad +import Data.Char +import qualified Data.Map as Map +import GHC.ResponseFile +import System.Environment + +main :: IO () +main = defaultMainWithHooks ghcHooks + where + ghcHooks = simpleUserHooks + { postConf = \args cfg pd lbi -> do + let verbosity = fromFlagOrDefault minBound (configVerbosity cfg) + ghcAutogen verbosity lbi + postConf simpleUserHooks args cfg pd lbi + } + +-- Mapping from primop-*.hs-incl file to command +primopIncls :: [(String,String)] +primopIncls = + [ ("primop-data-decl.hs-incl" , "--data-decl") + , ("primop-tag.hs-incl" , "--primop-tag") + , ("primop-list.hs-incl" , "--primop-list") + , ("primop-effects.hs-incl" , "--primop-effects") + , ("primop-out-of-line.hs-incl" , "--out-of-line") + , ("primop-commutable.hs-incl" , "--commutable") + , ("primop-code-size.hs-incl" , "--code-size") + , ("primop-strictness.hs-incl" , "--strictness") + , ("primop-is-work-free.hs-incl" , "--is-work-free") + , ("primop-is-cheap.hs-incl" , "--is-cheap") + , ("primop-fixity.hs-incl" , "--fixity") + , ("primop-primop-info.hs-incl" , "--primop-primop-info") + , ("primop-vector-uniques.hs-incl" , "--primop-vector-uniques") + , ("primop-vector-tys.hs-incl" , "--primop-vector-tys") + , ("primop-vector-tys-exports.hs-incl", "--primop-vector-tys-exports") + , ("primop-vector-tycons.hs-incl" , "--primop-vector-tycons") + , ("primop-docs.hs-incl" , "--wired-in-docs") + , ("primop-deprecations.hs-incl" , "--wired-in-deprecations") + ] + +ghcAutogen :: Verbosity -> LocalBuildInfo -> IO () +ghcAutogen verbosity lbi@LocalBuildInfo{pkgDescrFile,withPrograms,componentNameMap,installedPkgs} + = do + -- Get compiler/ root directory from the cabal file + let Just compilerRoot = takeDirectory <$> pkgDescrFile + + -- Require the necessary programs + (gcc ,withPrograms) <- requireProgram normal gccProgram withPrograms + (ghc ,withPrograms) <- requireProgram normal ghcProgram withPrograms + + settings <- read <$> getProgramOutput normal ghc ["--info"] + -- We are reinstalling GHC + -- Write primop-*.hs-incl + let hsCppOpts = case lookup "Haskell CPP flags" settings of + Just fs -> unescapeArgs fs + Nothing -> [] + primopsTxtPP = compilerRoot "GHC/Builtin/primops.txt.pp" + cppOpts = hsCppOpts ++ ["-P","-x","c"] + cppIncludes = map ("-I"++) [compilerRoot] + -- Preprocess primops.txt.pp + primopsStr <- getProgramOutput normal gcc (cppOpts ++ cppIncludes ++ [primopsTxtPP]) + -- Call genprimopcode to generate *.hs-incl + forM_ primopIncls $ \(file,command) -> do + contents <- readProcess "genprimopcode" [command] primopsStr + rewriteFileEx verbosity (buildDir lbi file) contents + + -- Write GHC.Platform.Constants + let platformConstantsPath = autogenPackageModulesDir lbi "GHC/Platform/Constants.hs" + targetOS = case lookup "target os" settings of + Nothing -> error "no target os in settings" + Just os -> os + createDirectoryIfMissingVerbose verbosity True (takeDirectory platformConstantsPath) + withTempFile (takeDirectory platformConstantsPath) "Constants_tmp.hs" $ \tmp h -> do + hClose h + callProcess "deriveConstants" ["--gen-haskell-type","-o",tmp,"--target-os",targetOS] + renameFile tmp platformConstantsPath + + let cProjectUnitId = case Map.lookup (CLibName LMainLibName) componentNameMap of + Just [LibComponentLocalBuildInfo{componentUnitId}] -> unUnitId componentUnitId + _ -> error "Couldn't find unique cabal library when building ghc" + + let cGhcInternalUnitId = case lookupPackageName installedPkgs (mkPackageName "ghc-internal") of + -- We assume there is exactly one copy of `ghc-internal` in our dependency closure + [(_,[packageInfo])] -> unUnitId $ installedUnitId packageInfo + _ -> error "Couldn't find unique ghc-internal library when building ghc" + + -- Write GHC.Settings.Config + configHsPath = autogenPackageModulesDir lbi "GHC/Settings/Config.hs" + configHs = generateConfigHs cProjectUnitId cGhcInternalUnitId settings + createDirectoryIfMissingVerbose verbosity True (takeDirectory configHsPath) + rewriteFileEx verbosity configHsPath configHs + +getSetting :: [(String,String)] -> String -> String -> Either String String +getSetting settings kh kr = go settings kr + where + go settings k = case lookup k settings of + Nothing -> Left (show k ++ " not found in settings: " ++ show settings) + Just v -> Right v + +generateConfigHs :: String -- ^ ghc's cabal-generated unit-id, which matches its package-id/key + -> String -- ^ ghc-internal's cabal-generated unit-id, which matches its package-id/key + -> [(String,String)] -> String +generateConfigHs cProjectUnitId cGhcInternalUnitId settings = either error id $ do + let getSetting' = getSetting $ (("cStage","2"):) settings + buildPlatform <- getSetting' "cBuildPlatformString" "Host platform" + hostPlatform <- getSetting' "cHostPlatformString" "Target platform" + cProjectName <- getSetting' "cProjectName" "Project name" + cBooterVersion <- getSetting' "cBooterVersion" "Project version" + cStage <- getSetting' "cStage" "cStage" + return $ unlines + [ "module GHC.Settings.Config" + , " ( module GHC.Version" + , " , cBuildPlatformString" + , " , cHostPlatformString" + , " , cProjectName" + , " , cBooterVersion" + , " , cStage" + , " , cProjectUnitId" + , " , cGhcInternalUnitId" + , " ) where" + , "" + , "import GHC.Prelude.Basic" + , "" + , "import GHC.Version" + , "" + , "cBuildPlatformString :: String" + , "cBuildPlatformString = " ++ show buildPlatform + , "" + , "cHostPlatformString :: String" + , "cHostPlatformString = " ++ show hostPlatform + , "" + , "cProjectName :: String" + , "cProjectName = " ++ show cProjectName + , "" + , "cBooterVersion :: String" + , "cBooterVersion = " ++ show cBooterVersion + , "" + , "cStage :: String" + , "cStage = show ("++ cStage ++ " :: Int)" + , "" + , "cProjectUnitId :: String" + , "cProjectUnitId = " ++ show cProjectUnitId + , "" + , "cGhcInternalUnitId :: String" + , "cGhcInternalUnitId = " ++ show cGhcInternalUnitId + ] diff --git a/autogen/CodeGen.Platform.hs b/autogen/CodeGen.Platform.hs deleted file mode 100644 --- a/autogen/CodeGen.Platform.hs +++ /dev/null @@ -1,1137 +0,0 @@ - -import CmmExpr -#if !(MACHREGS_i386 || MACHREGS_x86_64 || MACHREGS_sparc || MACHREGS_powerpc) -import Panic -#endif -import Reg - -#include "ghcautoconf.h" -#include "stg/MachRegs.h" - -#if MACHREGS_i386 || MACHREGS_x86_64 - -# if 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 MACHREGS_x86_64 -# define rax 0 -# define rbx 1 -# define rcx 2 -# define rdx 3 -# define rsi 4 -# define rdi 5 -# define rbp 6 -# define rsp 7 -# define r8 8 -# define r9 9 -# define r10 10 -# define r11 11 -# define r12 12 -# define r13 13 -# define r14 14 -# define r15 15 -# endif - -# define fake0 16 -# define fake1 17 -# define fake2 18 -# define fake3 19 -# define fake4 20 -# define fake5 21 - -# define xmm0 24 -# define xmm1 25 -# define xmm2 26 -# define xmm3 27 -# define xmm4 28 -# define xmm5 29 -# define xmm6 30 -# define xmm7 31 -# define xmm8 32 -# define xmm9 33 -# define xmm10 34 -# define xmm11 35 -# define xmm12 36 -# define xmm13 37 -# define xmm14 38 -# define xmm15 39 - -# define ymm0 40 -# define ymm1 41 -# define ymm2 42 -# define ymm3 43 -# define ymm4 44 -# define ymm5 45 -# define ymm6 46 -# define ymm7 47 -# define ymm8 48 -# define ymm9 49 -# define ymm10 50 -# define ymm11 51 -# define ymm12 52 -# define ymm13 53 -# define ymm14 54 -# define ymm15 55 - -# define zmm0 56 -# define zmm1 57 -# define zmm2 58 -# define zmm3 59 -# define zmm4 60 -# define zmm5 61 -# define zmm6 62 -# define zmm7 63 -# define zmm8 64 -# define zmm9 65 -# define zmm10 66 -# define zmm11 67 -# define zmm12 68 -# define zmm13 69 -# define zmm14 70 -# define zmm15 71 - --- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs. --- Since it's only used to check 'isJust', the actual values don't matter, thus --- I'm not sure if these are the correct numberings. --- Normally, the register names are just stringified as part of the REG() macro - -#elif MACHREGS_powerpc || MACHREGS_arm || 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 MACHREGS_aarch64 || 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 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 MACHREGS_sparc - -# define g0 0 -# define g1 1 -# define g2 2 -# define g3 3 -# define g4 4 -# define g5 5 -# define g6 6 -# define g7 7 - -# define o0 8 -# define o1 9 -# define o2 10 -# define o3 11 -# define o4 12 -# define o5 13 -# define o6 14 -# define o7 15 - -# define l0 16 -# define l1 17 -# define l2 18 -# define l3 19 -# define l4 20 -# define l5 21 -# define l6 22 -# define l7 23 - -# define i0 24 -# define i1 25 -# define i2 26 -# define i3 27 -# define i4 28 -# define i5 29 -# define i6 30 -# define i7 31 - -# define f0 32 -# define f1 33 -# define f2 34 -# define f3 35 -# define f4 36 -# define f5 37 -# define f6 38 -# define f7 39 -# define f8 40 -# define f9 41 -# define f10 42 -# define f11 43 -# define f12 44 -# define f13 45 -# define f14 46 -# define f15 47 -# define f16 48 -# define f17 49 -# define f18 50 -# define f19 51 -# define f20 52 -# define f21 53 -# define f22 54 -# define f23 55 -# define f24 56 -# define f25 57 -# define f26 58 -# define f27 59 -# define f28 60 -# define f29 61 -# define f30 62 -# define f31 63 - -#endif - -callerSaves :: GlobalReg -> Bool -#ifdef CALLER_SAVES_Base -callerSaves BaseReg = True -#endif -#ifdef CALLER_SAVES_R1 -callerSaves (VanillaReg 1 _) = True -#endif -#ifdef CALLER_SAVES_R2 -callerSaves (VanillaReg 2 _) = True -#endif -#ifdef CALLER_SAVES_R3 -callerSaves (VanillaReg 3 _) = True -#endif -#ifdef CALLER_SAVES_R4 -callerSaves (VanillaReg 4 _) = True -#endif -#ifdef CALLER_SAVES_R5 -callerSaves (VanillaReg 5 _) = True -#endif -#ifdef CALLER_SAVES_R6 -callerSaves (VanillaReg 6 _) = True -#endif -#ifdef CALLER_SAVES_R7 -callerSaves (VanillaReg 7 _) = True -#endif -#ifdef CALLER_SAVES_R8 -callerSaves (VanillaReg 8 _) = True -#endif -#ifdef CALLER_SAVES_R9 -callerSaves (VanillaReg 9 _) = True -#endif -#ifdef CALLER_SAVES_R10 -callerSaves (VanillaReg 10 _) = True -#endif -#ifdef CALLER_SAVES_F1 -callerSaves (FloatReg 1) = True -#endif -#ifdef CALLER_SAVES_F2 -callerSaves (FloatReg 2) = True -#endif -#ifdef CALLER_SAVES_F3 -callerSaves (FloatReg 3) = True -#endif -#ifdef CALLER_SAVES_F4 -callerSaves (FloatReg 4) = True -#endif -#ifdef CALLER_SAVES_F5 -callerSaves (FloatReg 5) = True -#endif -#ifdef CALLER_SAVES_F6 -callerSaves (FloatReg 6) = True -#endif -#ifdef CALLER_SAVES_D1 -callerSaves (DoubleReg 1) = True -#endif -#ifdef CALLER_SAVES_D2 -callerSaves (DoubleReg 2) = True -#endif -#ifdef CALLER_SAVES_D3 -callerSaves (DoubleReg 3) = True -#endif -#ifdef CALLER_SAVES_D4 -callerSaves (DoubleReg 4) = True -#endif -#ifdef CALLER_SAVES_D5 -callerSaves (DoubleReg 5) = True -#endif -#ifdef CALLER_SAVES_D6 -callerSaves (DoubleReg 6) = True -#endif -#ifdef CALLER_SAVES_L1 -callerSaves (LongReg 1) = True -#endif -#ifdef CALLER_SAVES_Sp -callerSaves Sp = True -#endif -#ifdef CALLER_SAVES_SpLim -callerSaves SpLim = True -#endif -#ifdef CALLER_SAVES_Hp -callerSaves Hp = True -#endif -#ifdef CALLER_SAVES_HpLim -callerSaves HpLim = True -#endif -#ifdef CALLER_SAVES_CCCS -callerSaves CCCS = True -#endif -#ifdef CALLER_SAVES_CurrentTSO -callerSaves CurrentTSO = True -#endif -#ifdef CALLER_SAVES_CurrentNursery -callerSaves CurrentNursery = True -#endif -callerSaves _ = False - -activeStgRegs :: [GlobalReg] -activeStgRegs = [ -#ifdef REG_Base - BaseReg -#endif -#ifdef REG_Sp - ,Sp -#endif -#ifdef REG_Hp - ,Hp -#endif -#ifdef REG_R1 - ,VanillaReg 1 VGcPtr -#endif -#ifdef REG_R2 - ,VanillaReg 2 VGcPtr -#endif -#ifdef REG_R3 - ,VanillaReg 3 VGcPtr -#endif -#ifdef REG_R4 - ,VanillaReg 4 VGcPtr -#endif -#ifdef REG_R5 - ,VanillaReg 5 VGcPtr -#endif -#ifdef REG_R6 - ,VanillaReg 6 VGcPtr -#endif -#ifdef REG_R7 - ,VanillaReg 7 VGcPtr -#endif -#ifdef REG_R8 - ,VanillaReg 8 VGcPtr -#endif -#ifdef REG_R9 - ,VanillaReg 9 VGcPtr -#endif -#ifdef REG_R10 - ,VanillaReg 10 VGcPtr -#endif -#ifdef REG_SpLim - ,SpLim -#endif -#if MAX_REAL_XMM_REG != 0 -#ifdef REG_F1 - ,FloatReg 1 -#endif -#ifdef REG_D1 - ,DoubleReg 1 -#endif -#ifdef REG_XMM1 - ,XmmReg 1 -#endif -#ifdef REG_YMM1 - ,YmmReg 1 -#endif -#ifdef REG_ZMM1 - ,ZmmReg 1 -#endif -#ifdef REG_F2 - ,FloatReg 2 -#endif -#ifdef REG_D2 - ,DoubleReg 2 -#endif -#ifdef REG_XMM2 - ,XmmReg 2 -#endif -#ifdef REG_YMM2 - ,YmmReg 2 -#endif -#ifdef REG_ZMM2 - ,ZmmReg 2 -#endif -#ifdef REG_F3 - ,FloatReg 3 -#endif -#ifdef REG_D3 - ,DoubleReg 3 -#endif -#ifdef REG_XMM3 - ,XmmReg 3 -#endif -#ifdef REG_YMM3 - ,YmmReg 3 -#endif -#ifdef REG_ZMM3 - ,ZmmReg 3 -#endif -#ifdef REG_F4 - ,FloatReg 4 -#endif -#ifdef REG_D4 - ,DoubleReg 4 -#endif -#ifdef REG_XMM4 - ,XmmReg 4 -#endif -#ifdef REG_YMM4 - ,YmmReg 4 -#endif -#ifdef REG_ZMM4 - ,ZmmReg 4 -#endif -#ifdef REG_F5 - ,FloatReg 5 -#endif -#ifdef REG_D5 - ,DoubleReg 5 -#endif -#ifdef REG_XMM5 - ,XmmReg 5 -#endif -#ifdef REG_YMM5 - ,YmmReg 5 -#endif -#ifdef REG_ZMM5 - ,ZmmReg 5 -#endif -#ifdef REG_F6 - ,FloatReg 6 -#endif -#ifdef REG_D6 - ,DoubleReg 6 -#endif -#ifdef REG_XMM6 - ,XmmReg 6 -#endif -#ifdef REG_YMM6 - ,YmmReg 6 -#endif -#ifdef REG_ZMM6 - ,ZmmReg 6 -#endif -#else /* MAX_REAL_XMM_REG == 0 */ -#ifdef REG_F1 - ,FloatReg 1 -#endif -#ifdef REG_F2 - ,FloatReg 2 -#endif -#ifdef REG_F3 - ,FloatReg 3 -#endif -#ifdef REG_F4 - ,FloatReg 4 -#endif -#ifdef REG_F5 - ,FloatReg 5 -#endif -#ifdef REG_F6 - ,FloatReg 6 -#endif -#ifdef REG_D1 - ,DoubleReg 1 -#endif -#ifdef REG_D2 - ,DoubleReg 2 -#endif -#ifdef REG_D3 - ,DoubleReg 3 -#endif -#ifdef REG_D4 - ,DoubleReg 4 -#endif -#ifdef REG_D5 - ,DoubleReg 5 -#endif -#ifdef REG_D6 - ,DoubleReg 6 -#endif -#endif /* MAX_REAL_XMM_REG == 0 */ - ] - -haveRegBase :: Bool -#ifdef 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 MACHREGS_i386 || MACHREGS_x86_64 || MACHREGS_sparc || MACHREGS_powerpc || MACHREGS_arm || MACHREGS_aarch64 -# ifdef REG_Base -globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) -# endif -# ifdef REG_R1 -globalRegMaybe (VanillaReg 1 _) = Just (RealRegSingle REG_R1) -# endif -# ifdef REG_R2 -globalRegMaybe (VanillaReg 2 _) = Just (RealRegSingle REG_R2) -# endif -# ifdef REG_R3 -globalRegMaybe (VanillaReg 3 _) = Just (RealRegSingle REG_R3) -# endif -# ifdef REG_R4 -globalRegMaybe (VanillaReg 4 _) = Just (RealRegSingle REG_R4) -# endif -# ifdef REG_R5 -globalRegMaybe (VanillaReg 5 _) = Just (RealRegSingle REG_R5) -# endif -# ifdef REG_R6 -globalRegMaybe (VanillaReg 6 _) = Just (RealRegSingle REG_R6) -# endif -# ifdef REG_R7 -globalRegMaybe (VanillaReg 7 _) = Just (RealRegSingle REG_R7) -# endif -# ifdef REG_R8 -globalRegMaybe (VanillaReg 8 _) = Just (RealRegSingle REG_R8) -# endif -# ifdef REG_R9 -globalRegMaybe (VanillaReg 9 _) = Just (RealRegSingle REG_R9) -# endif -# ifdef REG_R10 -globalRegMaybe (VanillaReg 10 _) = Just (RealRegSingle REG_R10) -# endif -# ifdef REG_F1 -globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) -# endif -# ifdef REG_F2 -globalRegMaybe (FloatReg 2) = Just (RealRegSingle REG_F2) -# endif -# ifdef REG_F3 -globalRegMaybe (FloatReg 3) = Just (RealRegSingle REG_F3) -# endif -# ifdef REG_F4 -globalRegMaybe (FloatReg 4) = Just (RealRegSingle REG_F4) -# endif -# ifdef REG_F5 -globalRegMaybe (FloatReg 5) = Just (RealRegSingle REG_F5) -# endif -# ifdef REG_F6 -globalRegMaybe (FloatReg 6) = Just (RealRegSingle REG_F6) -# endif -# ifdef REG_D1 -globalRegMaybe (DoubleReg 1) = -# if MACHREGS_sparc - Just (RealRegPair REG_D1 (REG_D1 + 1)) -# else - Just (RealRegSingle REG_D1) -# endif -# endif -# ifdef REG_D2 -globalRegMaybe (DoubleReg 2) = -# if MACHREGS_sparc - Just (RealRegPair REG_D2 (REG_D2 + 1)) -# else - Just (RealRegSingle REG_D2) -# endif -# endif -# ifdef REG_D3 -globalRegMaybe (DoubleReg 3) = -# if MACHREGS_sparc - Just (RealRegPair REG_D3 (REG_D3 + 1)) -# else - Just (RealRegSingle REG_D3) -# endif -# endif -# ifdef REG_D4 -globalRegMaybe (DoubleReg 4) = -# if MACHREGS_sparc - Just (RealRegPair REG_D4 (REG_D4 + 1)) -# else - Just (RealRegSingle REG_D4) -# endif -# endif -# ifdef REG_D5 -globalRegMaybe (DoubleReg 5) = -# if MACHREGS_sparc - Just (RealRegPair REG_D5 (REG_D5 + 1)) -# else - Just (RealRegSingle REG_D5) -# endif -# endif -# ifdef REG_D6 -globalRegMaybe (DoubleReg 6) = -# if MACHREGS_sparc - Just (RealRegPair REG_D6 (REG_D6 + 1)) -# else - Just (RealRegSingle REG_D6) -# endif -# endif -# if MAX_REAL_XMM_REG != 0 -# ifdef REG_XMM1 -globalRegMaybe (XmmReg 1) = Just (RealRegSingle REG_XMM1) -# endif -# ifdef REG_XMM2 -globalRegMaybe (XmmReg 2) = Just (RealRegSingle REG_XMM2) -# endif -# ifdef REG_XMM3 -globalRegMaybe (XmmReg 3) = Just (RealRegSingle REG_XMM3) -# endif -# ifdef REG_XMM4 -globalRegMaybe (XmmReg 4) = Just (RealRegSingle REG_XMM4) -# endif -# ifdef REG_XMM5 -globalRegMaybe (XmmReg 5) = Just (RealRegSingle REG_XMM5) -# endif -# ifdef REG_XMM6 -globalRegMaybe (XmmReg 6) = Just (RealRegSingle REG_XMM6) -# endif -# endif -# if MAX_REAL_YMM_REG != 0 -# ifdef REG_YMM1 -globalRegMaybe (YmmReg 1) = Just (RealRegSingle REG_YMM1) -# endif -# ifdef REG_YMM2 -globalRegMaybe (YmmReg 2) = Just (RealRegSingle REG_YMM2) -# endif -# ifdef REG_YMM3 -globalRegMaybe (YmmReg 3) = Just (RealRegSingle REG_YMM3) -# endif -# ifdef REG_YMM4 -globalRegMaybe (YmmReg 4) = Just (RealRegSingle REG_YMM4) -# endif -# ifdef REG_YMM5 -globalRegMaybe (YmmReg 5) = Just (RealRegSingle REG_YMM5) -# endif -# ifdef REG_YMM6 -globalRegMaybe (YmmReg 6) = Just (RealRegSingle REG_YMM6) -# endif -# endif -# if MAX_REAL_ZMM_REG != 0 -# ifdef REG_ZMM1 -globalRegMaybe (ZmmReg 1) = Just (RealRegSingle REG_ZMM1) -# endif -# ifdef REG_ZMM2 -globalRegMaybe (ZmmReg 2) = Just (RealRegSingle REG_ZMM2) -# endif -# ifdef REG_ZMM3 -globalRegMaybe (ZmmReg 3) = Just (RealRegSingle REG_ZMM3) -# endif -# ifdef REG_ZMM4 -globalRegMaybe (ZmmReg 4) = Just (RealRegSingle REG_ZMM4) -# endif -# ifdef REG_ZMM5 -globalRegMaybe (ZmmReg 5) = Just (RealRegSingle REG_ZMM5) -# endif -# ifdef REG_ZMM6 -globalRegMaybe (ZmmReg 6) = Just (RealRegSingle REG_ZMM6) -# endif -# endif -# ifdef REG_Sp -globalRegMaybe Sp = Just (RealRegSingle REG_Sp) -# endif -# ifdef REG_Lng1 -globalRegMaybe (LongReg 1) = Just (RealRegSingle REG_Lng1) -# endif -# ifdef REG_Lng2 -globalRegMaybe (LongReg 2) = Just (RealRegSingle REG_Lng2) -# endif -# ifdef REG_SpLim -globalRegMaybe SpLim = Just (RealRegSingle REG_SpLim) -# endif -# ifdef REG_Hp -globalRegMaybe Hp = Just (RealRegSingle REG_Hp) -# endif -# ifdef REG_HpLim -globalRegMaybe HpLim = Just (RealRegSingle REG_HpLim) -# endif -# ifdef REG_CurrentTSO -globalRegMaybe CurrentTSO = Just (RealRegSingle REG_CurrentTSO) -# endif -# ifdef REG_CurrentNursery -globalRegMaybe CurrentNursery = Just (RealRegSingle REG_CurrentNursery) -# endif -# ifdef REG_MachSp -globalRegMaybe MachSp = Just (RealRegSingle REG_MachSp) -# endif -globalRegMaybe _ = Nothing -#elif MACHREGS_NO_REGS -globalRegMaybe _ = Nothing -#else -globalRegMaybe = panic "globalRegMaybe not defined for this platform" -#endif - -freeReg :: RegNo -> Bool - -#if MACHREGS_i386 || MACHREGS_x86_64 - -# if MACHREGS_i386 -freeReg esp = False -- %esp is the C stack pointer -freeReg esi = False -- Note [esi/edi not allocatable] -freeReg edi = False -# endif -# if MACHREGS_x86_64 -freeReg rsp = False -- %rsp is the C stack pointer -# endif - -{- -Note [esi/edi 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 and edi are treated as not allocatable. --} - --- split patterns in two functions to prevent overlaps -freeReg r = freeRegBase r - -freeRegBase :: RegNo -> Bool -# ifdef REG_Base -freeRegBase REG_Base = False -# endif -# ifdef REG_Sp -freeRegBase REG_Sp = False -# endif -# ifdef REG_SpLim -freeRegBase REG_SpLim = False -# endif -# ifdef REG_Hp -freeRegBase REG_Hp = False -# endif -# ifdef 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 MACHREGS_powerpc - -freeReg 0 = False -- Used by code setting the back chain pointer - -- in stack reallocations on Linux - -- r0 is not usable in all insns so also reserved - -- on Darwin. -freeReg 1 = False -- The Stack Pointer -# if !MACHREGS_darwin --- most non-darwin powerpc OSes use r2 as a TOC pointer or something like that -freeReg 2 = False -freeReg 13 = False -- reserved for system thread ID on 64 bit --- at least linux in -fPIC relies on r30 in PLT stubs -freeReg 30 = False -{- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively. - For now we use r30 on 64 bit and r13 on 32 bit as a temporary register - in stack handling code. See compiler/nativeGen/PPC/Ppr.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. --} - -# endif -# ifdef REG_Base -freeReg REG_Base = False -# endif -# ifdef REG_R1 -freeReg REG_R1 = False -# endif -# ifdef REG_R2 -freeReg REG_R2 = False -# endif -# ifdef REG_R3 -freeReg REG_R3 = False -# endif -# ifdef REG_R4 -freeReg REG_R4 = False -# endif -# ifdef REG_R5 -freeReg REG_R5 = False -# endif -# ifdef REG_R6 -freeReg REG_R6 = False -# endif -# ifdef REG_R7 -freeReg REG_R7 = False -# endif -# ifdef REG_R8 -freeReg REG_R8 = False -# endif -# ifdef REG_R9 -freeReg REG_R9 = False -# endif -# ifdef REG_R10 -freeReg REG_R10 = False -# endif -# ifdef REG_F1 -freeReg REG_F1 = False -# endif -# ifdef REG_F2 -freeReg REG_F2 = False -# endif -# ifdef REG_F3 -freeReg REG_F3 = False -# endif -# ifdef REG_F4 -freeReg REG_F4 = False -# endif -# ifdef REG_F5 -freeReg REG_F5 = False -# endif -# ifdef REG_F6 -freeReg REG_F6 = False -# endif -# ifdef REG_D1 -freeReg REG_D1 = False -# endif -# ifdef REG_D2 -freeReg REG_D2 = False -# endif -# ifdef REG_D3 -freeReg REG_D3 = False -# endif -# ifdef REG_D4 -freeReg REG_D4 = False -# endif -# ifdef REG_D5 -freeReg REG_D5 = False -# endif -# ifdef REG_D6 -freeReg REG_D6 = False -# endif -# ifdef REG_Sp -freeReg REG_Sp = False -# endif -# ifdef REG_Su -freeReg REG_Su = False -# endif -# ifdef REG_SpLim -freeReg REG_SpLim = False -# endif -# ifdef REG_Hp -freeReg REG_Hp = False -# endif -# ifdef REG_HpLim -freeReg REG_HpLim = False -# endif -freeReg _ = True - -#elif 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 --} - -# ifdef REG_Base -freeReg REG_Base = False -# endif -# ifdef REG_R1 -freeReg REG_R1 = False -# endif -# ifdef REG_R2 -freeReg REG_R2 = False -# endif -# ifdef REG_R3 -freeReg REG_R3 = False -# endif -# ifdef REG_R4 -freeReg REG_R4 = False -# endif -# ifdef REG_R5 -freeReg REG_R5 = False -# endif -# ifdef REG_R6 -freeReg REG_R6 = False -# endif -# ifdef REG_R7 -freeReg REG_R7 = False -# endif -# ifdef REG_R8 -freeReg REG_R8 = False -# endif -# ifdef REG_R9 -freeReg REG_R9 = False -# endif -# ifdef REG_R10 -freeReg REG_R10 = False -# endif -# ifdef REG_F1 -freeReg REG_F1 = False -# endif -# ifdef REG_F2 -freeReg REG_F2 = False -# endif -# ifdef REG_F3 -freeReg REG_F3 = False -# endif -# ifdef REG_F4 -freeReg REG_F4 = False -# endif -# ifdef REG_F5 -freeReg REG_F5 = False -# endif -# ifdef REG_F6 -freeReg REG_F6 = False -# endif -# ifdef REG_D1 -freeReg REG_D1 = False -# endif -# ifdef REG_D1_2 -freeReg REG_D1_2 = False -# endif -# ifdef REG_D2 -freeReg REG_D2 = False -# endif -# ifdef REG_D2_2 -freeReg REG_D2_2 = False -# endif -# ifdef REG_D3 -freeReg REG_D3 = False -# endif -# ifdef REG_D3_2 -freeReg REG_D3_2 = False -# endif -# ifdef REG_D4 -freeReg REG_D4 = False -# endif -# ifdef REG_D4_2 -freeReg REG_D4_2 = False -# endif -# ifdef REG_D5 -freeReg REG_D5 = False -# endif -# ifdef REG_D5_2 -freeReg REG_D5_2 = False -# endif -# ifdef REG_D6 -freeReg REG_D6 = False -# endif -# ifdef REG_D6_2 -freeReg REG_D6_2 = False -# endif -# ifdef REG_Sp -freeReg REG_Sp = False -# endif -# ifdef REG_Su -freeReg REG_Su = False -# endif -# ifdef REG_SpLim -freeReg REG_SpLim = False -# endif -# ifdef REG_Hp -freeReg REG_Hp = False -# endif -# ifdef REG_HpLim -freeReg REG_HpLim = False -# endif -freeReg _ = True - -#else - -freeReg = panic "freeReg not defined for this platform" - -#endif - diff --git a/autogen/Config.hs b/autogen/Config.hs deleted file mode 100644 --- a/autogen/Config.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE CPP #-} -module Config where - -#include "ghc_boot_platform.h" - -data IntegerLibrary = IntegerGMP - | IntegerSimple - deriving Eq - -cBuildPlatformString :: String -cBuildPlatformString = BuildPlatform_NAME -cHostPlatformString :: String -cHostPlatformString = HostPlatform_NAME -cTargetPlatformString :: String -cTargetPlatformString = TargetPlatform_NAME - -cProjectName :: String -cProjectName = "The Glorious Glasgow Haskell Compilation System" -cProjectGitCommitId :: String -cProjectGitCommitId = "0156a3d815b784510a980621fdcb9c5b23826f1e" -cProjectVersion :: String -cProjectVersion = "8.2.2" -cProjectVersionInt :: String -cProjectVersionInt = "802" -cProjectPatchLevel :: String -cProjectPatchLevel = "2" -cProjectPatchLevel1 :: String -cProjectPatchLevel1 = "2" -cProjectPatchLevel2 :: String -cProjectPatchLevel2 = "" -cBooterVersion :: String -cBooterVersion = "8.0.2" -cStage :: String -cStage = show (STAGE :: Int) -cIntegerLibrary :: String -cIntegerLibrary = "integer-gmp" -cIntegerLibraryType :: IntegerLibrary -cIntegerLibraryType = IntegerGMP -cSupportsSplitObjs :: String -cSupportsSplitObjs = "YES" -cGhcWithInterpreter :: String -cGhcWithInterpreter = "YES" -cGhcWithNativeCodeGen :: String -cGhcWithNativeCodeGen = "YES" -cGhcWithSMP :: String -cGhcWithSMP = "YES" -cGhcRTSWays :: String -cGhcRTSWays = "l debug thr thr_debug thr_l thr_p dyn debug_dyn thr_dyn thr_debug_dyn l_dyn thr_l_dyn" -cGhcRtsWithLibdw :: Bool -cGhcRtsWithLibdw = False -cGhcEnableTablesNextToCode :: String -cGhcEnableTablesNextToCode = "YES" -cLeadingUnderscore :: String -cLeadingUnderscore = "NO" -cGHC_UNLIT_PGM :: String -cGHC_UNLIT_PGM = "unlit" -cGHC_SPLIT_PGM :: String -cGHC_SPLIT_PGM = "ghc-split" -cLibFFI :: Bool -cLibFFI = False -cGhcThreaded :: Bool -cGhcThreaded = True -cGhcDebugged :: Bool -cGhcDebugged = False diff --git a/autogen/GHCConstantsHaskellExports.hs b/autogen/GHCConstantsHaskellExports.hs deleted file mode 100644 --- a/autogen/GHCConstantsHaskellExports.hs +++ /dev/null @@ -1,125 +0,0 @@ - cONTROL_GROUP_CONST_291, - sTD_HDR_SIZE, - pROF_HDR_SIZE, - bLOCK_SIZE, - bLOCKS_PER_MBLOCK, - tICKY_BIN_COUNT, - oFFSET_StgRegTable_rR1, - oFFSET_StgRegTable_rR2, - oFFSET_StgRegTable_rR3, - oFFSET_StgRegTable_rR4, - oFFSET_StgRegTable_rR5, - oFFSET_StgRegTable_rR6, - oFFSET_StgRegTable_rR7, - oFFSET_StgRegTable_rR8, - oFFSET_StgRegTable_rR9, - oFFSET_StgRegTable_rR10, - oFFSET_StgRegTable_rF1, - oFFSET_StgRegTable_rF2, - oFFSET_StgRegTable_rF3, - oFFSET_StgRegTable_rF4, - oFFSET_StgRegTable_rF5, - oFFSET_StgRegTable_rF6, - oFFSET_StgRegTable_rD1, - oFFSET_StgRegTable_rD2, - oFFSET_StgRegTable_rD3, - oFFSET_StgRegTable_rD4, - oFFSET_StgRegTable_rD5, - oFFSET_StgRegTable_rD6, - oFFSET_StgRegTable_rXMM1, - oFFSET_StgRegTable_rXMM2, - oFFSET_StgRegTable_rXMM3, - oFFSET_StgRegTable_rXMM4, - oFFSET_StgRegTable_rXMM5, - oFFSET_StgRegTable_rXMM6, - oFFSET_StgRegTable_rYMM1, - oFFSET_StgRegTable_rYMM2, - oFFSET_StgRegTable_rYMM3, - oFFSET_StgRegTable_rYMM4, - oFFSET_StgRegTable_rYMM5, - oFFSET_StgRegTable_rYMM6, - oFFSET_StgRegTable_rZMM1, - oFFSET_StgRegTable_rZMM2, - oFFSET_StgRegTable_rZMM3, - oFFSET_StgRegTable_rZMM4, - oFFSET_StgRegTable_rZMM5, - oFFSET_StgRegTable_rZMM6, - oFFSET_StgRegTable_rL1, - oFFSET_StgRegTable_rSp, - oFFSET_StgRegTable_rSpLim, - oFFSET_StgRegTable_rHp, - oFFSET_StgRegTable_rHpLim, - oFFSET_StgRegTable_rCCCS, - oFFSET_StgRegTable_rCurrentTSO, - oFFSET_StgRegTable_rCurrentNursery, - oFFSET_StgRegTable_rHpAlloc, - oFFSET_stgEagerBlackholeInfo, - oFFSET_stgGCEnter1, - oFFSET_stgGCFun, - oFFSET_Capability_r, - oFFSET_bdescr_start, - oFFSET_bdescr_free, - oFFSET_bdescr_blocks, - oFFSET_bdescr_flags, - sIZEOF_CostCentreStack, - oFFSET_CostCentreStack_mem_alloc, - oFFSET_CostCentreStack_scc_count, - oFFSET_StgHeader_ccs, - oFFSET_StgHeader_ldvw, - sIZEOF_StgSMPThunkHeader, - oFFSET_StgEntCounter_allocs, - oFFSET_StgEntCounter_allocd, - oFFSET_StgEntCounter_registeredp, - oFFSET_StgEntCounter_link, - oFFSET_StgEntCounter_entry_count, - sIZEOF_StgUpdateFrame_NoHdr, - sIZEOF_StgMutArrPtrs_NoHdr, - oFFSET_StgMutArrPtrs_ptrs, - oFFSET_StgMutArrPtrs_size, - sIZEOF_StgSmallMutArrPtrs_NoHdr, - oFFSET_StgSmallMutArrPtrs_ptrs, - sIZEOF_StgArrBytes_NoHdr, - oFFSET_StgArrBytes_bytes, - oFFSET_StgTSO_alloc_limit, - oFFSET_StgTSO_cccs, - oFFSET_StgTSO_stackobj, - oFFSET_StgStack_sp, - oFFSET_StgStack_stack, - oFFSET_StgUpdateFrame_updatee, - oFFSET_StgFunInfoExtraFwd_arity, - sIZEOF_StgFunInfoExtraRev, - oFFSET_StgFunInfoExtraRev_arity, - mAX_SPEC_SELECTEE_SIZE, - mAX_SPEC_AP_SIZE, - mIN_PAYLOAD_SIZE, - mIN_INTLIKE, - mAX_INTLIKE, - mIN_CHARLIKE, - mAX_CHARLIKE, - mUT_ARR_PTRS_CARD_BITS, - mAX_Vanilla_REG, - mAX_Float_REG, - mAX_Double_REG, - mAX_Long_REG, - mAX_XMM_REG, - mAX_Real_Vanilla_REG, - mAX_Real_Float_REG, - mAX_Real_Double_REG, - mAX_Real_XMM_REG, - mAX_Real_Long_REG, - rESERVED_C_STACK_BYTES, - rESERVED_STACK_WORDS, - aP_STACK_SPLIM, - wORD_SIZE, - dOUBLE_SIZE, - cINT_SIZE, - cLONG_SIZE, - cLONG_LONG_SIZE, - bITMAP_BITS_SHIFT, - tAG_BITS, - wORDS_BIGENDIAN, - dYNAMIC_BY_DEFAULT, - lDV_SHIFT, - iLDV_CREATE_MASK, - iLDV_STATE_CREATE, - iLDV_STATE_USE, diff --git a/autogen/GHCConstantsHaskellType.hs b/autogen/GHCConstantsHaskellType.hs deleted file mode 100644 --- a/autogen/GHCConstantsHaskellType.hs +++ /dev/null @@ -1,134 +0,0 @@ -data PlatformConstants = PlatformConstants { - pc_platformConstants :: () - , pc_CONTROL_GROUP_CONST_291 :: Int - , pc_STD_HDR_SIZE :: Int - , pc_PROF_HDR_SIZE :: Int - , pc_BLOCK_SIZE :: Int - , pc_BLOCKS_PER_MBLOCK :: Int - , pc_TICKY_BIN_COUNT :: Int - , pc_OFFSET_StgRegTable_rR1 :: Int - , pc_OFFSET_StgRegTable_rR2 :: Int - , pc_OFFSET_StgRegTable_rR3 :: Int - , pc_OFFSET_StgRegTable_rR4 :: Int - , pc_OFFSET_StgRegTable_rR5 :: Int - , pc_OFFSET_StgRegTable_rR6 :: Int - , pc_OFFSET_StgRegTable_rR7 :: Int - , pc_OFFSET_StgRegTable_rR8 :: Int - , pc_OFFSET_StgRegTable_rR9 :: Int - , pc_OFFSET_StgRegTable_rR10 :: Int - , pc_OFFSET_StgRegTable_rF1 :: Int - , pc_OFFSET_StgRegTable_rF2 :: Int - , pc_OFFSET_StgRegTable_rF3 :: Int - , pc_OFFSET_StgRegTable_rF4 :: Int - , pc_OFFSET_StgRegTable_rF5 :: Int - , pc_OFFSET_StgRegTable_rF6 :: Int - , pc_OFFSET_StgRegTable_rD1 :: Int - , pc_OFFSET_StgRegTable_rD2 :: Int - , pc_OFFSET_StgRegTable_rD3 :: Int - , pc_OFFSET_StgRegTable_rD4 :: Int - , pc_OFFSET_StgRegTable_rD5 :: Int - , pc_OFFSET_StgRegTable_rD6 :: Int - , pc_OFFSET_StgRegTable_rXMM1 :: Int - , pc_OFFSET_StgRegTable_rXMM2 :: Int - , pc_OFFSET_StgRegTable_rXMM3 :: Int - , pc_OFFSET_StgRegTable_rXMM4 :: Int - , pc_OFFSET_StgRegTable_rXMM5 :: Int - , pc_OFFSET_StgRegTable_rXMM6 :: Int - , pc_OFFSET_StgRegTable_rYMM1 :: Int - , pc_OFFSET_StgRegTable_rYMM2 :: Int - , pc_OFFSET_StgRegTable_rYMM3 :: Int - , pc_OFFSET_StgRegTable_rYMM4 :: Int - , pc_OFFSET_StgRegTable_rYMM5 :: Int - , pc_OFFSET_StgRegTable_rYMM6 :: Int - , pc_OFFSET_StgRegTable_rZMM1 :: Int - , pc_OFFSET_StgRegTable_rZMM2 :: Int - , pc_OFFSET_StgRegTable_rZMM3 :: Int - , pc_OFFSET_StgRegTable_rZMM4 :: Int - , pc_OFFSET_StgRegTable_rZMM5 :: Int - , pc_OFFSET_StgRegTable_rZMM6 :: Int - , pc_OFFSET_StgRegTable_rL1 :: Int - , pc_OFFSET_StgRegTable_rSp :: Int - , pc_OFFSET_StgRegTable_rSpLim :: Int - , pc_OFFSET_StgRegTable_rHp :: Int - , pc_OFFSET_StgRegTable_rHpLim :: Int - , pc_OFFSET_StgRegTable_rCCCS :: Int - , pc_OFFSET_StgRegTable_rCurrentTSO :: Int - , pc_OFFSET_StgRegTable_rCurrentNursery :: Int - , pc_OFFSET_StgRegTable_rHpAlloc :: Int - , pc_OFFSET_stgEagerBlackholeInfo :: Int - , pc_OFFSET_stgGCEnter1 :: Int - , pc_OFFSET_stgGCFun :: Int - , pc_OFFSET_Capability_r :: Int - , pc_OFFSET_bdescr_start :: Int - , pc_OFFSET_bdescr_free :: Int - , pc_OFFSET_bdescr_blocks :: Int - , pc_OFFSET_bdescr_flags :: Int - , pc_SIZEOF_CostCentreStack :: Int - , pc_OFFSET_CostCentreStack_mem_alloc :: Int - , pc_REP_CostCentreStack_mem_alloc :: Int - , pc_OFFSET_CostCentreStack_scc_count :: Int - , pc_REP_CostCentreStack_scc_count :: Int - , pc_OFFSET_StgHeader_ccs :: Int - , pc_OFFSET_StgHeader_ldvw :: Int - , pc_SIZEOF_StgSMPThunkHeader :: Int - , pc_OFFSET_StgEntCounter_allocs :: Int - , pc_REP_StgEntCounter_allocs :: Int - , pc_OFFSET_StgEntCounter_allocd :: Int - , pc_REP_StgEntCounter_allocd :: Int - , pc_OFFSET_StgEntCounter_registeredp :: Int - , pc_OFFSET_StgEntCounter_link :: Int - , pc_OFFSET_StgEntCounter_entry_count :: Int - , pc_SIZEOF_StgUpdateFrame_NoHdr :: Int - , pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int - , pc_OFFSET_StgMutArrPtrs_ptrs :: Int - , pc_OFFSET_StgMutArrPtrs_size :: Int - , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int - , pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int - , pc_SIZEOF_StgArrBytes_NoHdr :: Int - , pc_OFFSET_StgArrBytes_bytes :: Int - , pc_OFFSET_StgTSO_alloc_limit :: Int - , pc_OFFSET_StgTSO_cccs :: Int - , pc_OFFSET_StgTSO_stackobj :: Int - , pc_OFFSET_StgStack_sp :: Int - , pc_OFFSET_StgStack_stack :: Int - , pc_OFFSET_StgUpdateFrame_updatee :: Int - , pc_OFFSET_StgFunInfoExtraFwd_arity :: Int - , pc_REP_StgFunInfoExtraFwd_arity :: Int - , pc_SIZEOF_StgFunInfoExtraRev :: Int - , pc_OFFSET_StgFunInfoExtraRev_arity :: Int - , pc_REP_StgFunInfoExtraRev_arity :: Int - , pc_MAX_SPEC_SELECTEE_SIZE :: Int - , pc_MAX_SPEC_AP_SIZE :: Int - , pc_MIN_PAYLOAD_SIZE :: Int - , pc_MIN_INTLIKE :: Int - , pc_MAX_INTLIKE :: Int - , pc_MIN_CHARLIKE :: Int - , pc_MAX_CHARLIKE :: Int - , pc_MUT_ARR_PTRS_CARD_BITS :: Int - , pc_MAX_Vanilla_REG :: Int - , pc_MAX_Float_REG :: Int - , pc_MAX_Double_REG :: Int - , pc_MAX_Long_REG :: Int - , pc_MAX_XMM_REG :: Int - , pc_MAX_Real_Vanilla_REG :: Int - , pc_MAX_Real_Float_REG :: Int - , pc_MAX_Real_Double_REG :: Int - , pc_MAX_Real_XMM_REG :: Int - , pc_MAX_Real_Long_REG :: Int - , pc_RESERVED_C_STACK_BYTES :: Int - , pc_RESERVED_STACK_WORDS :: Int - , pc_AP_STACK_SPLIM :: Int - , pc_WORD_SIZE :: Int - , pc_DOUBLE_SIZE :: Int - , pc_CINT_SIZE :: Int - , pc_CLONG_SIZE :: Int - , pc_CLONG_LONG_SIZE :: Int - , pc_BITMAP_BITS_SHIFT :: Int - , pc_TAG_BITS :: Int - , pc_WORDS_BIGENDIAN :: Bool - , pc_DYNAMIC_BY_DEFAULT :: Bool - , pc_LDV_SHIFT :: Int - , pc_ILDV_CREATE_MASK :: Integer - , pc_ILDV_STATE_CREATE :: Integer - , pc_ILDV_STATE_USE :: Integer - } deriving Read diff --git a/autogen/GHCConstantsHaskellWrappers.hs b/autogen/GHCConstantsHaskellWrappers.hs deleted file mode 100644 --- a/autogen/GHCConstantsHaskellWrappers.hs +++ /dev/null @@ -1,250 +0,0 @@ -cONTROL_GROUP_CONST_291 :: DynFlags -> Int -cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (sPlatformConstants (settings dflags)) -sTD_HDR_SIZE :: DynFlags -> Int -sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (sPlatformConstants (settings dflags)) -pROF_HDR_SIZE :: DynFlags -> Int -pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (sPlatformConstants (settings dflags)) -bLOCK_SIZE :: DynFlags -> Int -bLOCK_SIZE dflags = pc_BLOCK_SIZE (sPlatformConstants (settings dflags)) -bLOCKS_PER_MBLOCK :: DynFlags -> Int -bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (sPlatformConstants (settings dflags)) -tICKY_BIN_COUNT :: DynFlags -> Int -tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rR1 :: DynFlags -> Int -oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rR2 :: DynFlags -> Int -oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rR3 :: DynFlags -> Int -oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rR4 :: DynFlags -> Int -oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rR5 :: DynFlags -> Int -oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rR6 :: DynFlags -> Int -oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rR7 :: DynFlags -> Int -oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rR8 :: DynFlags -> Int -oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rR9 :: DynFlags -> Int -oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rR10 :: DynFlags -> Int -oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rF1 :: DynFlags -> Int -oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rF2 :: DynFlags -> Int -oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rF3 :: DynFlags -> Int -oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rF4 :: DynFlags -> Int -oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rF5 :: DynFlags -> Int -oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rF6 :: DynFlags -> Int -oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rD1 :: DynFlags -> Int -oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rD2 :: DynFlags -> Int -oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rD3 :: DynFlags -> Int -oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rD4 :: DynFlags -> Int -oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rD5 :: DynFlags -> Int -oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rD6 :: DynFlags -> Int -oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rL1 :: DynFlags -> Int -oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rSp :: DynFlags -> Int -oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rSpLim :: DynFlags -> Int -oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rHp :: DynFlags -> Int -oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rHpLim :: DynFlags -> Int -oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rCCCS :: DynFlags -> Int -oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int -oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int -oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (sPlatformConstants (settings dflags)) -oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int -oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (sPlatformConstants (settings dflags)) -oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int -oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (sPlatformConstants (settings dflags)) -oFFSET_stgGCEnter1 :: DynFlags -> Int -oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (sPlatformConstants (settings dflags)) -oFFSET_stgGCFun :: DynFlags -> Int -oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (sPlatformConstants (settings dflags)) -oFFSET_Capability_r :: DynFlags -> Int -oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (sPlatformConstants (settings dflags)) -oFFSET_bdescr_start :: DynFlags -> Int -oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (sPlatformConstants (settings dflags)) -oFFSET_bdescr_free :: DynFlags -> Int -oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (sPlatformConstants (settings dflags)) -oFFSET_bdescr_blocks :: DynFlags -> Int -oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (sPlatformConstants (settings dflags)) -oFFSET_bdescr_flags :: DynFlags -> Int -oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (sPlatformConstants (settings dflags)) -sIZEOF_CostCentreStack :: DynFlags -> Int -sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (sPlatformConstants (settings dflags)) -oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int -oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (sPlatformConstants (settings dflags)) -oFFSET_CostCentreStack_scc_count :: DynFlags -> Int -oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (sPlatformConstants (settings dflags)) -oFFSET_StgHeader_ccs :: DynFlags -> Int -oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (sPlatformConstants (settings dflags)) -oFFSET_StgHeader_ldvw :: DynFlags -> Int -oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (sPlatformConstants (settings dflags)) -sIZEOF_StgSMPThunkHeader :: DynFlags -> Int -sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (sPlatformConstants (settings dflags)) -oFFSET_StgEntCounter_allocs :: DynFlags -> Int -oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (sPlatformConstants (settings dflags)) -oFFSET_StgEntCounter_allocd :: DynFlags -> Int -oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (sPlatformConstants (settings dflags)) -oFFSET_StgEntCounter_registeredp :: DynFlags -> Int -oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (sPlatformConstants (settings dflags)) -oFFSET_StgEntCounter_link :: DynFlags -> Int -oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (sPlatformConstants (settings dflags)) -oFFSET_StgEntCounter_entry_count :: DynFlags -> Int -oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (sPlatformConstants (settings dflags)) -sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int -sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (sPlatformConstants (settings dflags)) -sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int -sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (sPlatformConstants (settings dflags)) -oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int -oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (sPlatformConstants (settings dflags)) -oFFSET_StgMutArrPtrs_size :: DynFlags -> Int -oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (sPlatformConstants (settings dflags)) -sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int -sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (sPlatformConstants (settings dflags)) -oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int -oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (sPlatformConstants (settings dflags)) -sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int -sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (sPlatformConstants (settings dflags)) -oFFSET_StgArrBytes_bytes :: DynFlags -> Int -oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (sPlatformConstants (settings dflags)) -oFFSET_StgTSO_alloc_limit :: DynFlags -> Int -oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (sPlatformConstants (settings dflags)) -oFFSET_StgTSO_cccs :: DynFlags -> Int -oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (sPlatformConstants (settings dflags)) -oFFSET_StgTSO_stackobj :: DynFlags -> Int -oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (sPlatformConstants (settings dflags)) -oFFSET_StgStack_sp :: DynFlags -> Int -oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (sPlatformConstants (settings dflags)) -oFFSET_StgStack_stack :: DynFlags -> Int -oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (sPlatformConstants (settings dflags)) -oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int -oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (sPlatformConstants (settings dflags)) -oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int -oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (sPlatformConstants (settings dflags)) -sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int -sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (sPlatformConstants (settings dflags)) -oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int -oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (sPlatformConstants (settings dflags)) -mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int -mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (sPlatformConstants (settings dflags)) -mAX_SPEC_AP_SIZE :: DynFlags -> Int -mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (sPlatformConstants (settings dflags)) -mIN_PAYLOAD_SIZE :: DynFlags -> Int -mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (sPlatformConstants (settings dflags)) -mIN_INTLIKE :: DynFlags -> Int -mIN_INTLIKE dflags = pc_MIN_INTLIKE (sPlatformConstants (settings dflags)) -mAX_INTLIKE :: DynFlags -> Int -mAX_INTLIKE dflags = pc_MAX_INTLIKE (sPlatformConstants (settings dflags)) -mIN_CHARLIKE :: DynFlags -> Int -mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (sPlatformConstants (settings dflags)) -mAX_CHARLIKE :: DynFlags -> Int -mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (sPlatformConstants (settings dflags)) -mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int -mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (sPlatformConstants (settings dflags)) -mAX_Vanilla_REG :: DynFlags -> Int -mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (sPlatformConstants (settings dflags)) -mAX_Float_REG :: DynFlags -> Int -mAX_Float_REG dflags = pc_MAX_Float_REG (sPlatformConstants (settings dflags)) -mAX_Double_REG :: DynFlags -> Int -mAX_Double_REG dflags = pc_MAX_Double_REG (sPlatformConstants (settings dflags)) -mAX_Long_REG :: DynFlags -> Int -mAX_Long_REG dflags = pc_MAX_Long_REG (sPlatformConstants (settings dflags)) -mAX_XMM_REG :: DynFlags -> Int -mAX_XMM_REG dflags = pc_MAX_XMM_REG (sPlatformConstants (settings dflags)) -mAX_Real_Vanilla_REG :: DynFlags -> Int -mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (sPlatformConstants (settings dflags)) -mAX_Real_Float_REG :: DynFlags -> Int -mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (sPlatformConstants (settings dflags)) -mAX_Real_Double_REG :: DynFlags -> Int -mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (sPlatformConstants (settings dflags)) -mAX_Real_XMM_REG :: DynFlags -> Int -mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (sPlatformConstants (settings dflags)) -mAX_Real_Long_REG :: DynFlags -> Int -mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (sPlatformConstants (settings dflags)) -rESERVED_C_STACK_BYTES :: DynFlags -> Int -rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (sPlatformConstants (settings dflags)) -rESERVED_STACK_WORDS :: DynFlags -> Int -rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (sPlatformConstants (settings dflags)) -aP_STACK_SPLIM :: DynFlags -> Int -aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (sPlatformConstants (settings dflags)) -wORD_SIZE :: DynFlags -> Int -wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags)) -dOUBLE_SIZE :: DynFlags -> Int -dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (sPlatformConstants (settings dflags)) -cINT_SIZE :: DynFlags -> Int -cINT_SIZE dflags = pc_CINT_SIZE (sPlatformConstants (settings dflags)) -cLONG_SIZE :: DynFlags -> Int -cLONG_SIZE dflags = pc_CLONG_SIZE (sPlatformConstants (settings dflags)) -cLONG_LONG_SIZE :: DynFlags -> Int -cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (sPlatformConstants (settings dflags)) -bITMAP_BITS_SHIFT :: DynFlags -> Int -bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (sPlatformConstants (settings dflags)) -tAG_BITS :: DynFlags -> Int -tAG_BITS dflags = pc_TAG_BITS (sPlatformConstants (settings dflags)) -wORDS_BIGENDIAN :: DynFlags -> Bool -wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (sPlatformConstants (settings dflags)) -dYNAMIC_BY_DEFAULT :: DynFlags -> Bool -dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (sPlatformConstants (settings dflags)) -lDV_SHIFT :: DynFlags -> Int -lDV_SHIFT dflags = pc_LDV_SHIFT (sPlatformConstants (settings dflags)) -iLDV_CREATE_MASK :: DynFlags -> Integer -iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (sPlatformConstants (settings dflags)) -iLDV_STATE_CREATE :: DynFlags -> Integer -iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (sPlatformConstants (settings dflags)) -iLDV_STATE_USE :: DynFlags -> Integer -iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (sPlatformConstants (settings dflags)) diff --git a/autogen/ghc_boot_platform.h b/autogen/ghc_boot_platform.h deleted file mode 100644 --- a/autogen/ghc_boot_platform.h +++ /dev/null @@ -1,33 +0,0 @@ -#ifndef __PLATFORM_H__ -#define __PLATFORM_H__ - -#define BuildPlatform_NAME "x86_64-unknown-linux" -#define HostPlatform_NAME "x86_64-unknown-linux" -#define TargetPlatform_NAME "x86_64-unknown-linux" - -#define x86_64_unknown_linux_BUILD 1 -#define x86_64_unknown_linux_HOST 1 -#define x86_64_unknown_linux_TARGET 1 - -#define x86_64_BUILD_ARCH 1 -#define x86_64_HOST_ARCH 1 -#define x86_64_TARGET_ARCH 1 -#define BUILD_ARCH "x86_64" -#define HOST_ARCH "x86_64" -#define TARGET_ARCH "x86_64" - -#define linux_BUILD_OS 1 -#define linux_HOST_OS 1 -#define linux_TARGET_OS 1 -#define BUILD_OS "linux" -#define HOST_OS "linux" -#define TARGET_OS "linux" - -#define unknown_BUILD_VENDOR 1 -#define unknown_HOST_VENDOR 1 -#define unknown_TARGET_VENDOR 1 -#define BUILD_VENDOR "unknown" -#define HOST_VENDOR "unknown" -#define TARGET_VENDOR "unknown" - -#endif /* __PLATFORM_H__ */ diff --git a/autogen/primop-can-fail.hs-incl b/autogen/primop-can-fail.hs-incl deleted file mode 100644 --- a/autogen/primop-can-fail.hs-incl +++ /dev/null @@ -1,178 +0,0 @@ -primOpCanFail IntQuotOp = True -primOpCanFail IntRemOp = True -primOpCanFail IntQuotRemOp = True -primOpCanFail WordQuotOp = True -primOpCanFail WordRemOp = True -primOpCanFail WordQuotRemOp = True -primOpCanFail WordQuotRem2Op = True -primOpCanFail DoubleDivOp = True -primOpCanFail DoubleLogOp = True -primOpCanFail DoubleAsinOp = True -primOpCanFail DoubleAcosOp = True -primOpCanFail FloatDivOp = True -primOpCanFail FloatLogOp = True -primOpCanFail FloatAsinOp = True -primOpCanFail FloatAcosOp = True -primOpCanFail ReadArrayOp = True -primOpCanFail WriteArrayOp = True -primOpCanFail IndexArrayOp = True -primOpCanFail CopyArrayOp = True -primOpCanFail CopyMutableArrayOp = True -primOpCanFail CloneArrayOp = True -primOpCanFail CloneMutableArrayOp = True -primOpCanFail FreezeArrayOp = True -primOpCanFail ThawArrayOp = True -primOpCanFail ReadSmallArrayOp = True -primOpCanFail WriteSmallArrayOp = True -primOpCanFail IndexSmallArrayOp = True -primOpCanFail CopySmallArrayOp = True -primOpCanFail CopySmallMutableArrayOp = True -primOpCanFail CloneSmallArrayOp = True -primOpCanFail CloneSmallMutableArrayOp = True -primOpCanFail FreezeSmallArrayOp = True -primOpCanFail ThawSmallArrayOp = True -primOpCanFail IndexByteArrayOp_Char = True -primOpCanFail IndexByteArrayOp_WideChar = True -primOpCanFail IndexByteArrayOp_Int = True -primOpCanFail IndexByteArrayOp_Word = True -primOpCanFail IndexByteArrayOp_Addr = True -primOpCanFail IndexByteArrayOp_Float = True -primOpCanFail IndexByteArrayOp_Double = True -primOpCanFail IndexByteArrayOp_StablePtr = True -primOpCanFail IndexByteArrayOp_Int8 = True -primOpCanFail IndexByteArrayOp_Int16 = True -primOpCanFail IndexByteArrayOp_Int32 = True -primOpCanFail IndexByteArrayOp_Int64 = True -primOpCanFail IndexByteArrayOp_Word8 = True -primOpCanFail IndexByteArrayOp_Word16 = True -primOpCanFail IndexByteArrayOp_Word32 = True -primOpCanFail IndexByteArrayOp_Word64 = True -primOpCanFail ReadByteArrayOp_Char = True -primOpCanFail ReadByteArrayOp_WideChar = True -primOpCanFail ReadByteArrayOp_Int = True -primOpCanFail ReadByteArrayOp_Word = True -primOpCanFail ReadByteArrayOp_Addr = True -primOpCanFail ReadByteArrayOp_Float = True -primOpCanFail ReadByteArrayOp_Double = True -primOpCanFail ReadByteArrayOp_StablePtr = True -primOpCanFail ReadByteArrayOp_Int8 = True -primOpCanFail ReadByteArrayOp_Int16 = True -primOpCanFail ReadByteArrayOp_Int32 = True -primOpCanFail ReadByteArrayOp_Int64 = True -primOpCanFail ReadByteArrayOp_Word8 = True -primOpCanFail ReadByteArrayOp_Word16 = True -primOpCanFail ReadByteArrayOp_Word32 = True -primOpCanFail ReadByteArrayOp_Word64 = True -primOpCanFail WriteByteArrayOp_Char = True -primOpCanFail WriteByteArrayOp_WideChar = True -primOpCanFail WriteByteArrayOp_Int = True -primOpCanFail WriteByteArrayOp_Word = True -primOpCanFail WriteByteArrayOp_Addr = True -primOpCanFail WriteByteArrayOp_Float = True -primOpCanFail WriteByteArrayOp_Double = True -primOpCanFail WriteByteArrayOp_StablePtr = True -primOpCanFail WriteByteArrayOp_Int8 = True -primOpCanFail WriteByteArrayOp_Int16 = True -primOpCanFail WriteByteArrayOp_Int32 = True -primOpCanFail WriteByteArrayOp_Int64 = True -primOpCanFail WriteByteArrayOp_Word8 = True -primOpCanFail WriteByteArrayOp_Word16 = True -primOpCanFail WriteByteArrayOp_Word32 = True -primOpCanFail WriteByteArrayOp_Word64 = True -primOpCanFail CopyByteArrayOp = True -primOpCanFail CopyMutableByteArrayOp = True -primOpCanFail CopyByteArrayToAddrOp = True -primOpCanFail CopyMutableByteArrayToAddrOp = True -primOpCanFail CopyAddrToByteArrayOp = True -primOpCanFail SetByteArrayOp = True -primOpCanFail AtomicReadByteArrayOp_Int = True -primOpCanFail AtomicWriteByteArrayOp_Int = True -primOpCanFail CasByteArrayOp_Int = True -primOpCanFail FetchAddByteArrayOp_Int = True -primOpCanFail FetchSubByteArrayOp_Int = True -primOpCanFail FetchAndByteArrayOp_Int = True -primOpCanFail FetchNandByteArrayOp_Int = True -primOpCanFail FetchOrByteArrayOp_Int = True -primOpCanFail FetchXorByteArrayOp_Int = True -primOpCanFail IndexArrayArrayOp_ByteArray = True -primOpCanFail IndexArrayArrayOp_ArrayArray = True -primOpCanFail ReadArrayArrayOp_ByteArray = True -primOpCanFail ReadArrayArrayOp_MutableByteArray = True -primOpCanFail ReadArrayArrayOp_ArrayArray = True -primOpCanFail ReadArrayArrayOp_MutableArrayArray = True -primOpCanFail WriteArrayArrayOp_ByteArray = True -primOpCanFail WriteArrayArrayOp_MutableByteArray = True -primOpCanFail WriteArrayArrayOp_ArrayArray = True -primOpCanFail WriteArrayArrayOp_MutableArrayArray = True -primOpCanFail CopyArrayArrayOp = True -primOpCanFail CopyMutableArrayArrayOp = True -primOpCanFail IndexOffAddrOp_Char = True -primOpCanFail IndexOffAddrOp_WideChar = True -primOpCanFail IndexOffAddrOp_Int = True -primOpCanFail IndexOffAddrOp_Word = True -primOpCanFail IndexOffAddrOp_Addr = True -primOpCanFail IndexOffAddrOp_Float = True -primOpCanFail IndexOffAddrOp_Double = True -primOpCanFail IndexOffAddrOp_StablePtr = True -primOpCanFail IndexOffAddrOp_Int8 = True -primOpCanFail IndexOffAddrOp_Int16 = True -primOpCanFail IndexOffAddrOp_Int32 = True -primOpCanFail IndexOffAddrOp_Int64 = True -primOpCanFail IndexOffAddrOp_Word8 = True -primOpCanFail IndexOffAddrOp_Word16 = True -primOpCanFail IndexOffAddrOp_Word32 = True -primOpCanFail IndexOffAddrOp_Word64 = True -primOpCanFail ReadOffAddrOp_Char = True -primOpCanFail ReadOffAddrOp_WideChar = True -primOpCanFail ReadOffAddrOp_Int = True -primOpCanFail ReadOffAddrOp_Word = True -primOpCanFail ReadOffAddrOp_Addr = True -primOpCanFail ReadOffAddrOp_Float = True -primOpCanFail ReadOffAddrOp_Double = True -primOpCanFail ReadOffAddrOp_StablePtr = True -primOpCanFail ReadOffAddrOp_Int8 = True -primOpCanFail ReadOffAddrOp_Int16 = True -primOpCanFail ReadOffAddrOp_Int32 = True -primOpCanFail ReadOffAddrOp_Int64 = True -primOpCanFail ReadOffAddrOp_Word8 = True -primOpCanFail ReadOffAddrOp_Word16 = True -primOpCanFail ReadOffAddrOp_Word32 = True -primOpCanFail ReadOffAddrOp_Word64 = True -primOpCanFail WriteOffAddrOp_Char = True -primOpCanFail WriteOffAddrOp_WideChar = True -primOpCanFail WriteOffAddrOp_Int = True -primOpCanFail WriteOffAddrOp_Word = True -primOpCanFail WriteOffAddrOp_Addr = True -primOpCanFail WriteOffAddrOp_Float = True -primOpCanFail WriteOffAddrOp_Double = True -primOpCanFail WriteOffAddrOp_StablePtr = True -primOpCanFail WriteOffAddrOp_Int8 = True -primOpCanFail WriteOffAddrOp_Int16 = True -primOpCanFail WriteOffAddrOp_Int32 = True -primOpCanFail WriteOffAddrOp_Int64 = True -primOpCanFail WriteOffAddrOp_Word8 = True -primOpCanFail WriteOffAddrOp_Word16 = True -primOpCanFail WriteOffAddrOp_Word32 = True -primOpCanFail WriteOffAddrOp_Word64 = True -primOpCanFail ReadMutVarOp = True -primOpCanFail WriteMutVarOp = True -primOpCanFail AtomicModifyMutVarOp = True -primOpCanFail ReallyUnsafePtrEqualityOp = True -primOpCanFail DataToTagOp = True -primOpCanFail (VecInsertOp _ _ _) = True -primOpCanFail (VecDivOp _ _ _) = True -primOpCanFail (VecQuotOp _ _ _) = True -primOpCanFail (VecRemOp _ _ _) = True -primOpCanFail (VecIndexByteArrayOp _ _ _) = True -primOpCanFail (VecReadByteArrayOp _ _ _) = True -primOpCanFail (VecWriteByteArrayOp _ _ _) = True -primOpCanFail (VecIndexOffAddrOp _ _ _) = True -primOpCanFail (VecReadOffAddrOp _ _ _) = True -primOpCanFail (VecWriteOffAddrOp _ _ _) = True -primOpCanFail (VecIndexScalarByteArrayOp _ _ _) = True -primOpCanFail (VecReadScalarByteArrayOp _ _ _) = True -primOpCanFail (VecWriteScalarByteArrayOp _ _ _) = True -primOpCanFail (VecIndexScalarOffAddrOp _ _ _) = True -primOpCanFail (VecReadScalarOffAddrOp _ _ _) = True -primOpCanFail (VecWriteScalarOffAddrOp _ _ _) = True -primOpCanFail _ = False diff --git a/autogen/primop-code-size.hs-incl b/autogen/primop-code-size.hs-incl deleted file mode 100644 --- a/autogen/primop-code-size.hs-incl +++ /dev/null @@ -1,48 +0,0 @@ -primOpCodeSize OrdOp = 0 -primOpCodeSize IntAddCOp = 2 -primOpCodeSize IntSubCOp = 2 -primOpCodeSize ChrOp = 0 -primOpCodeSize Int2WordOp = 0 -primOpCodeSize Word2IntOp = 0 -primOpCodeSize DoubleExpOp = primOpCodeSizeForeignCall -primOpCodeSize DoubleLogOp = primOpCodeSizeForeignCall -primOpCodeSize DoubleSqrtOp = primOpCodeSizeForeignCall -primOpCodeSize DoubleSinOp = primOpCodeSizeForeignCall -primOpCodeSize DoubleCosOp = primOpCodeSizeForeignCall -primOpCodeSize DoubleTanOp = primOpCodeSizeForeignCall -primOpCodeSize DoubleAsinOp = primOpCodeSizeForeignCall -primOpCodeSize DoubleAcosOp = primOpCodeSizeForeignCall -primOpCodeSize DoubleAtanOp = primOpCodeSizeForeignCall -primOpCodeSize DoubleSinhOp = primOpCodeSizeForeignCall -primOpCodeSize DoubleCoshOp = primOpCodeSizeForeignCall -primOpCodeSize DoubleTanhOp = primOpCodeSizeForeignCall -primOpCodeSize DoublePowerOp = primOpCodeSizeForeignCall -primOpCodeSize FloatExpOp = primOpCodeSizeForeignCall -primOpCodeSize FloatLogOp = primOpCodeSizeForeignCall -primOpCodeSize FloatSqrtOp = primOpCodeSizeForeignCall -primOpCodeSize FloatSinOp = primOpCodeSizeForeignCall -primOpCodeSize FloatCosOp = primOpCodeSizeForeignCall -primOpCodeSize FloatTanOp = primOpCodeSizeForeignCall -primOpCodeSize FloatAsinOp = primOpCodeSizeForeignCall -primOpCodeSize FloatAcosOp = primOpCodeSizeForeignCall -primOpCodeSize FloatAtanOp = primOpCodeSizeForeignCall -primOpCodeSize FloatSinhOp = primOpCodeSizeForeignCall -primOpCodeSize FloatCoshOp = primOpCodeSizeForeignCall -primOpCodeSize FloatTanhOp = primOpCodeSizeForeignCall -primOpCodeSize FloatPowerOp = primOpCodeSizeForeignCall -primOpCodeSize WriteArrayOp = 2 -primOpCodeSize CopyByteArrayOp = primOpCodeSizeForeignCall + 4 -primOpCodeSize CopyMutableByteArrayOp = primOpCodeSizeForeignCall + 4 -primOpCodeSize CopyByteArrayToAddrOp = primOpCodeSizeForeignCall + 4 -primOpCodeSize CopyMutableByteArrayToAddrOp = primOpCodeSizeForeignCall + 4 -primOpCodeSize CopyAddrToByteArrayOp = primOpCodeSizeForeignCall + 4 -primOpCodeSize SetByteArrayOp = primOpCodeSizeForeignCall + 4 -primOpCodeSize Addr2IntOp = 0 -primOpCodeSize Int2AddrOp = 0 -primOpCodeSize WriteMutVarOp = primOpCodeSizeForeignCall -primOpCodeSize TouchOp = 0 -primOpCodeSize ParOp = primOpCodeSizeForeignCall -primOpCodeSize SparkOp = primOpCodeSizeForeignCall -primOpCodeSize AddrToAnyOp = 0 -primOpCodeSize AnyToAddrOp = 0 -primOpCodeSize _ = primOpCodeSizeDefault diff --git a/autogen/primop-commutable.hs-incl b/autogen/primop-commutable.hs-incl deleted file mode 100644 --- a/autogen/primop-commutable.hs-incl +++ /dev/null @@ -1,28 +0,0 @@ -commutableOp CharEqOp = True -commutableOp CharNeOp = True -commutableOp IntAddOp = True -commutableOp IntMulOp = True -commutableOp IntMulMayOfloOp = True -commutableOp AndIOp = True -commutableOp OrIOp = True -commutableOp XorIOp = True -commutableOp IntEqOp = True -commutableOp IntNeOp = True -commutableOp WordAddOp = True -commutableOp WordAdd2Op = True -commutableOp WordMulOp = True -commutableOp WordMul2Op = True -commutableOp AndOp = True -commutableOp OrOp = True -commutableOp XorOp = True -commutableOp DoubleEqOp = True -commutableOp DoubleNeOp = True -commutableOp DoubleAddOp = True -commutableOp DoubleMulOp = True -commutableOp FloatEqOp = True -commutableOp FloatNeOp = True -commutableOp FloatAddOp = True -commutableOp FloatMulOp = True -commutableOp (VecAddOp _ _ _) = True -commutableOp (VecMulOp _ _ _) = True -commutableOp _ = False diff --git a/autogen/primop-data-decl.hs-incl b/autogen/primop-data-decl.hs-incl deleted file mode 100644 --- a/autogen/primop-data-decl.hs-incl +++ /dev/null @@ -1,451 +0,0 @@ -data PrimOp - = CharGtOp - | CharGeOp - | CharEqOp - | CharNeOp - | CharLtOp - | CharLeOp - | OrdOp - | IntAddOp - | IntSubOp - | IntMulOp - | IntMulMayOfloOp - | IntQuotOp - | IntRemOp - | IntQuotRemOp - | AndIOp - | OrIOp - | XorIOp - | NotIOp - | IntNegOp - | IntAddCOp - | IntSubCOp - | IntGtOp - | IntGeOp - | IntEqOp - | IntNeOp - | IntLtOp - | IntLeOp - | ChrOp - | Int2WordOp - | Int2FloatOp - | Int2DoubleOp - | Word2FloatOp - | Word2DoubleOp - | ISllOp - | ISraOp - | ISrlOp - | WordAddOp - | WordSubCOp - | WordAdd2Op - | WordSubOp - | WordMulOp - | WordMul2Op - | WordQuotOp - | WordRemOp - | WordQuotRemOp - | WordQuotRem2Op - | AndOp - | OrOp - | XorOp - | NotOp - | SllOp - | SrlOp - | Word2IntOp - | WordGtOp - | WordGeOp - | WordEqOp - | WordNeOp - | WordLtOp - | WordLeOp - | PopCnt8Op - | PopCnt16Op - | PopCnt32Op - | PopCnt64Op - | PopCntOp - | Clz8Op - | Clz16Op - | Clz32Op - | Clz64Op - | ClzOp - | Ctz8Op - | Ctz16Op - | Ctz32Op - | Ctz64Op - | CtzOp - | BSwap16Op - | BSwap32Op - | BSwap64Op - | BSwapOp - | Narrow8IntOp - | Narrow16IntOp - | Narrow32IntOp - | Narrow8WordOp - | Narrow16WordOp - | Narrow32WordOp - | DoubleGtOp - | DoubleGeOp - | DoubleEqOp - | DoubleNeOp - | DoubleLtOp - | DoubleLeOp - | DoubleAddOp - | DoubleSubOp - | DoubleMulOp - | DoubleDivOp - | DoubleNegOp - | DoubleFabsOp - | Double2IntOp - | Double2FloatOp - | DoubleExpOp - | DoubleLogOp - | DoubleSqrtOp - | DoubleSinOp - | DoubleCosOp - | DoubleTanOp - | DoubleAsinOp - | DoubleAcosOp - | DoubleAtanOp - | DoubleSinhOp - | DoubleCoshOp - | DoubleTanhOp - | DoublePowerOp - | DoubleDecode_2IntOp - | DoubleDecode_Int64Op - | FloatGtOp - | FloatGeOp - | FloatEqOp - | FloatNeOp - | FloatLtOp - | FloatLeOp - | FloatAddOp - | FloatSubOp - | FloatMulOp - | FloatDivOp - | FloatNegOp - | FloatFabsOp - | Float2IntOp - | FloatExpOp - | FloatLogOp - | FloatSqrtOp - | FloatSinOp - | FloatCosOp - | FloatTanOp - | FloatAsinOp - | FloatAcosOp - | FloatAtanOp - | FloatSinhOp - | FloatCoshOp - | FloatTanhOp - | FloatPowerOp - | Float2DoubleOp - | FloatDecode_IntOp - | NewArrayOp - | SameMutableArrayOp - | ReadArrayOp - | WriteArrayOp - | SizeofArrayOp - | SizeofMutableArrayOp - | IndexArrayOp - | UnsafeFreezeArrayOp - | UnsafeThawArrayOp - | CopyArrayOp - | CopyMutableArrayOp - | CloneArrayOp - | CloneMutableArrayOp - | FreezeArrayOp - | ThawArrayOp - | CasArrayOp - | NewSmallArrayOp - | SameSmallMutableArrayOp - | ReadSmallArrayOp - | WriteSmallArrayOp - | SizeofSmallArrayOp - | SizeofSmallMutableArrayOp - | IndexSmallArrayOp - | UnsafeFreezeSmallArrayOp - | UnsafeThawSmallArrayOp - | CopySmallArrayOp - | CopySmallMutableArrayOp - | CloneSmallArrayOp - | CloneSmallMutableArrayOp - | FreezeSmallArrayOp - | ThawSmallArrayOp - | CasSmallArrayOp - | NewByteArrayOp_Char - | NewPinnedByteArrayOp_Char - | NewAlignedPinnedByteArrayOp_Char - | MutableByteArrayIsPinnedOp - | ByteArrayIsPinnedOp - | ByteArrayContents_Char - | SameMutableByteArrayOp - | ShrinkMutableByteArrayOp_Char - | ResizeMutableByteArrayOp_Char - | UnsafeFreezeByteArrayOp - | SizeofByteArrayOp - | SizeofMutableByteArrayOp - | GetSizeofMutableByteArrayOp - | IndexByteArrayOp_Char - | IndexByteArrayOp_WideChar - | IndexByteArrayOp_Int - | IndexByteArrayOp_Word - | IndexByteArrayOp_Addr - | IndexByteArrayOp_Float - | IndexByteArrayOp_Double - | IndexByteArrayOp_StablePtr - | IndexByteArrayOp_Int8 - | IndexByteArrayOp_Int16 - | IndexByteArrayOp_Int32 - | IndexByteArrayOp_Int64 - | IndexByteArrayOp_Word8 - | IndexByteArrayOp_Word16 - | IndexByteArrayOp_Word32 - | IndexByteArrayOp_Word64 - | ReadByteArrayOp_Char - | ReadByteArrayOp_WideChar - | ReadByteArrayOp_Int - | ReadByteArrayOp_Word - | ReadByteArrayOp_Addr - | ReadByteArrayOp_Float - | ReadByteArrayOp_Double - | ReadByteArrayOp_StablePtr - | ReadByteArrayOp_Int8 - | ReadByteArrayOp_Int16 - | ReadByteArrayOp_Int32 - | ReadByteArrayOp_Int64 - | ReadByteArrayOp_Word8 - | ReadByteArrayOp_Word16 - | ReadByteArrayOp_Word32 - | ReadByteArrayOp_Word64 - | WriteByteArrayOp_Char - | WriteByteArrayOp_WideChar - | WriteByteArrayOp_Int - | WriteByteArrayOp_Word - | WriteByteArrayOp_Addr - | WriteByteArrayOp_Float - | WriteByteArrayOp_Double - | WriteByteArrayOp_StablePtr - | WriteByteArrayOp_Int8 - | WriteByteArrayOp_Int16 - | WriteByteArrayOp_Int32 - | WriteByteArrayOp_Int64 - | WriteByteArrayOp_Word8 - | WriteByteArrayOp_Word16 - | WriteByteArrayOp_Word32 - | WriteByteArrayOp_Word64 - | CopyByteArrayOp - | CopyMutableByteArrayOp - | CopyByteArrayToAddrOp - | CopyMutableByteArrayToAddrOp - | CopyAddrToByteArrayOp - | SetByteArrayOp - | AtomicReadByteArrayOp_Int - | AtomicWriteByteArrayOp_Int - | CasByteArrayOp_Int - | FetchAddByteArrayOp_Int - | FetchSubByteArrayOp_Int - | FetchAndByteArrayOp_Int - | FetchNandByteArrayOp_Int - | FetchOrByteArrayOp_Int - | FetchXorByteArrayOp_Int - | NewArrayArrayOp - | SameMutableArrayArrayOp - | UnsafeFreezeArrayArrayOp - | SizeofArrayArrayOp - | SizeofMutableArrayArrayOp - | IndexArrayArrayOp_ByteArray - | IndexArrayArrayOp_ArrayArray - | ReadArrayArrayOp_ByteArray - | ReadArrayArrayOp_MutableByteArray - | ReadArrayArrayOp_ArrayArray - | ReadArrayArrayOp_MutableArrayArray - | WriteArrayArrayOp_ByteArray - | WriteArrayArrayOp_MutableByteArray - | WriteArrayArrayOp_ArrayArray - | WriteArrayArrayOp_MutableArrayArray - | CopyArrayArrayOp - | CopyMutableArrayArrayOp - | AddrAddOp - | AddrSubOp - | AddrRemOp - | Addr2IntOp - | Int2AddrOp - | AddrGtOp - | AddrGeOp - | AddrEqOp - | AddrNeOp - | AddrLtOp - | AddrLeOp - | IndexOffAddrOp_Char - | IndexOffAddrOp_WideChar - | IndexOffAddrOp_Int - | IndexOffAddrOp_Word - | IndexOffAddrOp_Addr - | IndexOffAddrOp_Float - | IndexOffAddrOp_Double - | IndexOffAddrOp_StablePtr - | IndexOffAddrOp_Int8 - | IndexOffAddrOp_Int16 - | IndexOffAddrOp_Int32 - | IndexOffAddrOp_Int64 - | IndexOffAddrOp_Word8 - | IndexOffAddrOp_Word16 - | IndexOffAddrOp_Word32 - | IndexOffAddrOp_Word64 - | ReadOffAddrOp_Char - | ReadOffAddrOp_WideChar - | ReadOffAddrOp_Int - | ReadOffAddrOp_Word - | ReadOffAddrOp_Addr - | ReadOffAddrOp_Float - | ReadOffAddrOp_Double - | ReadOffAddrOp_StablePtr - | ReadOffAddrOp_Int8 - | ReadOffAddrOp_Int16 - | ReadOffAddrOp_Int32 - | ReadOffAddrOp_Int64 - | ReadOffAddrOp_Word8 - | ReadOffAddrOp_Word16 - | ReadOffAddrOp_Word32 - | ReadOffAddrOp_Word64 - | WriteOffAddrOp_Char - | WriteOffAddrOp_WideChar - | WriteOffAddrOp_Int - | WriteOffAddrOp_Word - | WriteOffAddrOp_Addr - | WriteOffAddrOp_Float - | WriteOffAddrOp_Double - | WriteOffAddrOp_StablePtr - | WriteOffAddrOp_Int8 - | WriteOffAddrOp_Int16 - | WriteOffAddrOp_Int32 - | WriteOffAddrOp_Int64 - | WriteOffAddrOp_Word8 - | WriteOffAddrOp_Word16 - | WriteOffAddrOp_Word32 - | WriteOffAddrOp_Word64 - | NewMutVarOp - | ReadMutVarOp - | WriteMutVarOp - | SameMutVarOp - | AtomicModifyMutVarOp - | CasMutVarOp - | CatchOp - | RaiseOp - | RaiseIOOp - | MaskAsyncExceptionsOp - | MaskUninterruptibleOp - | UnmaskAsyncExceptionsOp - | MaskStatus - | AtomicallyOp - | RetryOp - | CatchRetryOp - | CatchSTMOp - | Check - | NewTVarOp - | ReadTVarOp - | ReadTVarIOOp - | WriteTVarOp - | SameTVarOp - | NewMVarOp - | TakeMVarOp - | TryTakeMVarOp - | PutMVarOp - | TryPutMVarOp - | ReadMVarOp - | TryReadMVarOp - | SameMVarOp - | IsEmptyMVarOp - | DelayOp - | WaitReadOp - | WaitWriteOp - | ForkOp - | ForkOnOp - | KillThreadOp - | YieldOp - | MyThreadIdOp - | LabelThreadOp - | IsCurrentThreadBoundOp - | NoDuplicateOp - | ThreadStatusOp - | MkWeakOp - | MkWeakNoFinalizerOp - | AddCFinalizerToWeakOp - | DeRefWeakOp - | FinalizeWeakOp - | TouchOp - | MakeStablePtrOp - | DeRefStablePtrOp - | EqStablePtrOp - | MakeStableNameOp - | EqStableNameOp - | StableNameToIntOp - | CompactNewOp - | CompactResizeOp - | CompactContainsOp - | CompactContainsAnyOp - | CompactGetFirstBlockOp - | CompactGetNextBlockOp - | CompactAllocateBlockOp - | CompactFixupPointersOp - | CompactAdd - | CompactAddWithSharing - | CompactSize - | ReallyUnsafePtrEqualityOp - | ParOp - | SparkOp - | SeqOp - | GetSparkOp - | NumSparks - | DataToTagOp - | TagToEnumOp - | AddrToAnyOp - | AnyToAddrOp - | MkApUpd0_Op - | NewBCOOp - | UnpackClosureOp - | GetApStackValOp - | GetCCSOfOp - | GetCurrentCCSOp - | ClearCCSOp - | TraceEventOp - | TraceMarkerOp - | VecBroadcastOp PrimOpVecCat Length Width - | VecPackOp PrimOpVecCat Length Width - | VecUnpackOp PrimOpVecCat Length Width - | VecInsertOp PrimOpVecCat Length Width - | VecAddOp PrimOpVecCat Length Width - | VecSubOp PrimOpVecCat Length Width - | VecMulOp PrimOpVecCat Length Width - | VecDivOp PrimOpVecCat Length Width - | VecQuotOp PrimOpVecCat Length Width - | VecRemOp PrimOpVecCat Length Width - | VecNegOp PrimOpVecCat Length Width - | VecIndexByteArrayOp PrimOpVecCat Length Width - | VecReadByteArrayOp PrimOpVecCat Length Width - | VecWriteByteArrayOp PrimOpVecCat Length Width - | VecIndexOffAddrOp PrimOpVecCat Length Width - | VecReadOffAddrOp PrimOpVecCat Length Width - | VecWriteOffAddrOp PrimOpVecCat Length Width - | VecIndexScalarByteArrayOp PrimOpVecCat Length Width - | VecReadScalarByteArrayOp PrimOpVecCat Length Width - | VecWriteScalarByteArrayOp PrimOpVecCat Length Width - | VecIndexScalarOffAddrOp PrimOpVecCat Length Width - | VecReadScalarOffAddrOp PrimOpVecCat Length Width - | VecWriteScalarOffAddrOp PrimOpVecCat Length Width - | PrefetchByteArrayOp3 - | PrefetchMutableByteArrayOp3 - | PrefetchAddrOp3 - | PrefetchValueOp3 - | PrefetchByteArrayOp2 - | PrefetchMutableByteArrayOp2 - | PrefetchAddrOp2 - | PrefetchValueOp2 - | PrefetchByteArrayOp1 - | PrefetchMutableByteArrayOp1 - | PrefetchAddrOp1 - | PrefetchValueOp1 - | PrefetchByteArrayOp0 - | PrefetchMutableByteArrayOp0 - | PrefetchAddrOp0 - | PrefetchValueOp0 diff --git a/autogen/primop-fixity.hs-incl b/autogen/primop-fixity.hs-incl deleted file mode 100644 --- a/autogen/primop-fixity.hs-incl +++ /dev/null @@ -1,20 +0,0 @@ -primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL) -primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL) -primOpFixity IntMulOp = Just (Fixity NoSourceText 7 InfixL) -primOpFixity IntGtOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity IntGeOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity IntEqOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity IntNeOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity IntLtOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity IntLeOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity DoubleGtOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity DoubleGeOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity DoubleEqOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity DoubleNeOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity DoubleLtOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity DoubleLeOp = Just (Fixity NoSourceText 4 InfixN) -primOpFixity DoubleAddOp = Just (Fixity NoSourceText 6 InfixL) -primOpFixity DoubleSubOp = Just (Fixity NoSourceText 6 InfixL) -primOpFixity DoubleMulOp = Just (Fixity NoSourceText 7 InfixL) -primOpFixity DoubleDivOp = Just (Fixity NoSourceText 7 InfixL) -primOpFixity _ = Nothing diff --git a/autogen/primop-has-side-effects.hs-incl b/autogen/primop-has-side-effects.hs-incl deleted file mode 100644 --- a/autogen/primop-has-side-effects.hs-incl +++ /dev/null @@ -1,211 +0,0 @@ -primOpHasSideEffects NewArrayOp = True -primOpHasSideEffects ReadArrayOp = True -primOpHasSideEffects WriteArrayOp = True -primOpHasSideEffects UnsafeFreezeArrayOp = True -primOpHasSideEffects UnsafeThawArrayOp = True -primOpHasSideEffects CopyArrayOp = True -primOpHasSideEffects CopyMutableArrayOp = True -primOpHasSideEffects CloneArrayOp = True -primOpHasSideEffects CloneMutableArrayOp = True -primOpHasSideEffects FreezeArrayOp = True -primOpHasSideEffects ThawArrayOp = True -primOpHasSideEffects CasArrayOp = True -primOpHasSideEffects NewSmallArrayOp = True -primOpHasSideEffects ReadSmallArrayOp = True -primOpHasSideEffects WriteSmallArrayOp = True -primOpHasSideEffects UnsafeFreezeSmallArrayOp = True -primOpHasSideEffects UnsafeThawSmallArrayOp = True -primOpHasSideEffects CopySmallArrayOp = True -primOpHasSideEffects CopySmallMutableArrayOp = True -primOpHasSideEffects CloneSmallArrayOp = True -primOpHasSideEffects CloneSmallMutableArrayOp = True -primOpHasSideEffects FreezeSmallArrayOp = True -primOpHasSideEffects ThawSmallArrayOp = True -primOpHasSideEffects CasSmallArrayOp = True -primOpHasSideEffects NewByteArrayOp_Char = True -primOpHasSideEffects NewPinnedByteArrayOp_Char = True -primOpHasSideEffects NewAlignedPinnedByteArrayOp_Char = True -primOpHasSideEffects ShrinkMutableByteArrayOp_Char = True -primOpHasSideEffects ResizeMutableByteArrayOp_Char = True -primOpHasSideEffects UnsafeFreezeByteArrayOp = True -primOpHasSideEffects ReadByteArrayOp_Char = True -primOpHasSideEffects ReadByteArrayOp_WideChar = True -primOpHasSideEffects ReadByteArrayOp_Int = True -primOpHasSideEffects ReadByteArrayOp_Word = True -primOpHasSideEffects ReadByteArrayOp_Addr = True -primOpHasSideEffects ReadByteArrayOp_Float = True -primOpHasSideEffects ReadByteArrayOp_Double = True -primOpHasSideEffects ReadByteArrayOp_StablePtr = True -primOpHasSideEffects ReadByteArrayOp_Int8 = True -primOpHasSideEffects ReadByteArrayOp_Int16 = True -primOpHasSideEffects ReadByteArrayOp_Int32 = True -primOpHasSideEffects ReadByteArrayOp_Int64 = True -primOpHasSideEffects ReadByteArrayOp_Word8 = True -primOpHasSideEffects ReadByteArrayOp_Word16 = True -primOpHasSideEffects ReadByteArrayOp_Word32 = True -primOpHasSideEffects ReadByteArrayOp_Word64 = True -primOpHasSideEffects WriteByteArrayOp_Char = True -primOpHasSideEffects WriteByteArrayOp_WideChar = True -primOpHasSideEffects WriteByteArrayOp_Int = True -primOpHasSideEffects WriteByteArrayOp_Word = True -primOpHasSideEffects WriteByteArrayOp_Addr = True -primOpHasSideEffects WriteByteArrayOp_Float = True -primOpHasSideEffects WriteByteArrayOp_Double = True -primOpHasSideEffects WriteByteArrayOp_StablePtr = True -primOpHasSideEffects WriteByteArrayOp_Int8 = True -primOpHasSideEffects WriteByteArrayOp_Int16 = True -primOpHasSideEffects WriteByteArrayOp_Int32 = True -primOpHasSideEffects WriteByteArrayOp_Int64 = True -primOpHasSideEffects WriteByteArrayOp_Word8 = True -primOpHasSideEffects WriteByteArrayOp_Word16 = True -primOpHasSideEffects WriteByteArrayOp_Word32 = True -primOpHasSideEffects WriteByteArrayOp_Word64 = True -primOpHasSideEffects CopyByteArrayOp = True -primOpHasSideEffects CopyMutableByteArrayOp = True -primOpHasSideEffects CopyByteArrayToAddrOp = True -primOpHasSideEffects CopyMutableByteArrayToAddrOp = True -primOpHasSideEffects CopyAddrToByteArrayOp = True -primOpHasSideEffects SetByteArrayOp = True -primOpHasSideEffects AtomicReadByteArrayOp_Int = True -primOpHasSideEffects AtomicWriteByteArrayOp_Int = True -primOpHasSideEffects CasByteArrayOp_Int = True -primOpHasSideEffects FetchAddByteArrayOp_Int = True -primOpHasSideEffects FetchSubByteArrayOp_Int = True -primOpHasSideEffects FetchAndByteArrayOp_Int = True -primOpHasSideEffects FetchNandByteArrayOp_Int = True -primOpHasSideEffects FetchOrByteArrayOp_Int = True -primOpHasSideEffects FetchXorByteArrayOp_Int = True -primOpHasSideEffects NewArrayArrayOp = True -primOpHasSideEffects UnsafeFreezeArrayArrayOp = True -primOpHasSideEffects ReadArrayArrayOp_ByteArray = True -primOpHasSideEffects ReadArrayArrayOp_MutableByteArray = True -primOpHasSideEffects ReadArrayArrayOp_ArrayArray = True -primOpHasSideEffects ReadArrayArrayOp_MutableArrayArray = True -primOpHasSideEffects WriteArrayArrayOp_ByteArray = True -primOpHasSideEffects WriteArrayArrayOp_MutableByteArray = True -primOpHasSideEffects WriteArrayArrayOp_ArrayArray = True -primOpHasSideEffects WriteArrayArrayOp_MutableArrayArray = True -primOpHasSideEffects CopyArrayArrayOp = True -primOpHasSideEffects CopyMutableArrayArrayOp = True -primOpHasSideEffects ReadOffAddrOp_Char = True -primOpHasSideEffects ReadOffAddrOp_WideChar = True -primOpHasSideEffects ReadOffAddrOp_Int = True -primOpHasSideEffects ReadOffAddrOp_Word = True -primOpHasSideEffects ReadOffAddrOp_Addr = True -primOpHasSideEffects ReadOffAddrOp_Float = True -primOpHasSideEffects ReadOffAddrOp_Double = True -primOpHasSideEffects ReadOffAddrOp_StablePtr = True -primOpHasSideEffects ReadOffAddrOp_Int8 = True -primOpHasSideEffects ReadOffAddrOp_Int16 = True -primOpHasSideEffects ReadOffAddrOp_Int32 = True -primOpHasSideEffects ReadOffAddrOp_Int64 = True -primOpHasSideEffects ReadOffAddrOp_Word8 = True -primOpHasSideEffects ReadOffAddrOp_Word16 = True -primOpHasSideEffects ReadOffAddrOp_Word32 = True -primOpHasSideEffects ReadOffAddrOp_Word64 = True -primOpHasSideEffects WriteOffAddrOp_Char = True -primOpHasSideEffects WriteOffAddrOp_WideChar = True -primOpHasSideEffects WriteOffAddrOp_Int = True -primOpHasSideEffects WriteOffAddrOp_Word = True -primOpHasSideEffects WriteOffAddrOp_Addr = True -primOpHasSideEffects WriteOffAddrOp_Float = True -primOpHasSideEffects WriteOffAddrOp_Double = True -primOpHasSideEffects WriteOffAddrOp_StablePtr = True -primOpHasSideEffects WriteOffAddrOp_Int8 = True -primOpHasSideEffects WriteOffAddrOp_Int16 = True -primOpHasSideEffects WriteOffAddrOp_Int32 = True -primOpHasSideEffects WriteOffAddrOp_Int64 = True -primOpHasSideEffects WriteOffAddrOp_Word8 = True -primOpHasSideEffects WriteOffAddrOp_Word16 = True -primOpHasSideEffects WriteOffAddrOp_Word32 = True -primOpHasSideEffects WriteOffAddrOp_Word64 = True -primOpHasSideEffects NewMutVarOp = True -primOpHasSideEffects ReadMutVarOp = True -primOpHasSideEffects WriteMutVarOp = True -primOpHasSideEffects AtomicModifyMutVarOp = True -primOpHasSideEffects CasMutVarOp = True -primOpHasSideEffects CatchOp = True -primOpHasSideEffects RaiseOp = True -primOpHasSideEffects RaiseIOOp = True -primOpHasSideEffects MaskAsyncExceptionsOp = True -primOpHasSideEffects MaskUninterruptibleOp = True -primOpHasSideEffects UnmaskAsyncExceptionsOp = True -primOpHasSideEffects MaskStatus = True -primOpHasSideEffects AtomicallyOp = True -primOpHasSideEffects RetryOp = True -primOpHasSideEffects CatchRetryOp = True -primOpHasSideEffects CatchSTMOp = True -primOpHasSideEffects Check = True -primOpHasSideEffects NewTVarOp = True -primOpHasSideEffects ReadTVarOp = True -primOpHasSideEffects ReadTVarIOOp = True -primOpHasSideEffects WriteTVarOp = True -primOpHasSideEffects NewMVarOp = True -primOpHasSideEffects TakeMVarOp = True -primOpHasSideEffects TryTakeMVarOp = True -primOpHasSideEffects PutMVarOp = True -primOpHasSideEffects TryPutMVarOp = True -primOpHasSideEffects ReadMVarOp = True -primOpHasSideEffects TryReadMVarOp = True -primOpHasSideEffects IsEmptyMVarOp = True -primOpHasSideEffects DelayOp = True -primOpHasSideEffects WaitReadOp = True -primOpHasSideEffects WaitWriteOp = True -primOpHasSideEffects ForkOp = True -primOpHasSideEffects ForkOnOp = True -primOpHasSideEffects KillThreadOp = True -primOpHasSideEffects YieldOp = True -primOpHasSideEffects MyThreadIdOp = True -primOpHasSideEffects LabelThreadOp = True -primOpHasSideEffects IsCurrentThreadBoundOp = True -primOpHasSideEffects NoDuplicateOp = True -primOpHasSideEffects ThreadStatusOp = True -primOpHasSideEffects MkWeakOp = True -primOpHasSideEffects MkWeakNoFinalizerOp = True -primOpHasSideEffects AddCFinalizerToWeakOp = True -primOpHasSideEffects DeRefWeakOp = True -primOpHasSideEffects FinalizeWeakOp = True -primOpHasSideEffects TouchOp = True -primOpHasSideEffects MakeStablePtrOp = True -primOpHasSideEffects DeRefStablePtrOp = True -primOpHasSideEffects EqStablePtrOp = True -primOpHasSideEffects MakeStableNameOp = True -primOpHasSideEffects CompactNewOp = True -primOpHasSideEffects CompactResizeOp = True -primOpHasSideEffects CompactAllocateBlockOp = True -primOpHasSideEffects CompactFixupPointersOp = True -primOpHasSideEffects CompactAdd = True -primOpHasSideEffects CompactAddWithSharing = True -primOpHasSideEffects CompactSize = True -primOpHasSideEffects ParOp = True -primOpHasSideEffects SparkOp = True -primOpHasSideEffects GetSparkOp = True -primOpHasSideEffects NumSparks = True -primOpHasSideEffects NewBCOOp = True -primOpHasSideEffects TraceEventOp = True -primOpHasSideEffects TraceMarkerOp = True -primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True -primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True -primOpHasSideEffects (VecReadOffAddrOp _ _ _) = True -primOpHasSideEffects (VecWriteOffAddrOp _ _ _) = True -primOpHasSideEffects (VecReadScalarByteArrayOp _ _ _) = True -primOpHasSideEffects (VecWriteScalarByteArrayOp _ _ _) = True -primOpHasSideEffects (VecReadScalarOffAddrOp _ _ _) = True -primOpHasSideEffects (VecWriteScalarOffAddrOp _ _ _) = True -primOpHasSideEffects PrefetchByteArrayOp3 = True -primOpHasSideEffects PrefetchMutableByteArrayOp3 = True -primOpHasSideEffects PrefetchAddrOp3 = True -primOpHasSideEffects PrefetchValueOp3 = True -primOpHasSideEffects PrefetchByteArrayOp2 = True -primOpHasSideEffects PrefetchMutableByteArrayOp2 = True -primOpHasSideEffects PrefetchAddrOp2 = True -primOpHasSideEffects PrefetchValueOp2 = True -primOpHasSideEffects PrefetchByteArrayOp1 = True -primOpHasSideEffects PrefetchMutableByteArrayOp1 = True -primOpHasSideEffects PrefetchAddrOp1 = True -primOpHasSideEffects PrefetchValueOp1 = True -primOpHasSideEffects PrefetchByteArrayOp0 = True -primOpHasSideEffects PrefetchMutableByteArrayOp0 = True -primOpHasSideEffects PrefetchAddrOp0 = True -primOpHasSideEffects PrefetchValueOp0 = True -primOpHasSideEffects _ = False diff --git a/autogen/primop-list.hs-incl b/autogen/primop-list.hs-incl deleted file mode 100644 --- a/autogen/primop-list.hs-incl +++ /dev/null @@ -1,1070 +0,0 @@ - [CharGtOp - , CharGeOp - , CharEqOp - , CharNeOp - , CharLtOp - , CharLeOp - , OrdOp - , IntAddOp - , IntSubOp - , IntMulOp - , IntMulMayOfloOp - , IntQuotOp - , IntRemOp - , IntQuotRemOp - , AndIOp - , OrIOp - , XorIOp - , NotIOp - , IntNegOp - , IntAddCOp - , IntSubCOp - , IntGtOp - , IntGeOp - , IntEqOp - , IntNeOp - , IntLtOp - , IntLeOp - , ChrOp - , Int2WordOp - , Int2FloatOp - , Int2DoubleOp - , Word2FloatOp - , Word2DoubleOp - , ISllOp - , ISraOp - , ISrlOp - , WordAddOp - , WordSubCOp - , WordAdd2Op - , WordSubOp - , WordMulOp - , WordMul2Op - , WordQuotOp - , WordRemOp - , WordQuotRemOp - , WordQuotRem2Op - , AndOp - , OrOp - , XorOp - , NotOp - , SllOp - , SrlOp - , Word2IntOp - , WordGtOp - , WordGeOp - , WordEqOp - , WordNeOp - , WordLtOp - , WordLeOp - , PopCnt8Op - , PopCnt16Op - , PopCnt32Op - , PopCnt64Op - , PopCntOp - , Clz8Op - , Clz16Op - , Clz32Op - , Clz64Op - , ClzOp - , Ctz8Op - , Ctz16Op - , Ctz32Op - , Ctz64Op - , CtzOp - , BSwap16Op - , BSwap32Op - , BSwap64Op - , BSwapOp - , Narrow8IntOp - , Narrow16IntOp - , Narrow32IntOp - , Narrow8WordOp - , Narrow16WordOp - , Narrow32WordOp - , DoubleGtOp - , DoubleGeOp - , DoubleEqOp - , DoubleNeOp - , DoubleLtOp - , DoubleLeOp - , DoubleAddOp - , DoubleSubOp - , DoubleMulOp - , DoubleDivOp - , DoubleNegOp - , DoubleFabsOp - , Double2IntOp - , Double2FloatOp - , DoubleExpOp - , DoubleLogOp - , DoubleSqrtOp - , DoubleSinOp - , DoubleCosOp - , DoubleTanOp - , DoubleAsinOp - , DoubleAcosOp - , DoubleAtanOp - , DoubleSinhOp - , DoubleCoshOp - , DoubleTanhOp - , DoublePowerOp - , DoubleDecode_2IntOp - , DoubleDecode_Int64Op - , FloatGtOp - , FloatGeOp - , FloatEqOp - , FloatNeOp - , FloatLtOp - , FloatLeOp - , FloatAddOp - , FloatSubOp - , FloatMulOp - , FloatDivOp - , FloatNegOp - , FloatFabsOp - , Float2IntOp - , FloatExpOp - , FloatLogOp - , FloatSqrtOp - , FloatSinOp - , FloatCosOp - , FloatTanOp - , FloatAsinOp - , FloatAcosOp - , FloatAtanOp - , FloatSinhOp - , FloatCoshOp - , FloatTanhOp - , FloatPowerOp - , Float2DoubleOp - , FloatDecode_IntOp - , NewArrayOp - , SameMutableArrayOp - , ReadArrayOp - , WriteArrayOp - , SizeofArrayOp - , SizeofMutableArrayOp - , IndexArrayOp - , UnsafeFreezeArrayOp - , UnsafeThawArrayOp - , CopyArrayOp - , CopyMutableArrayOp - , CloneArrayOp - , CloneMutableArrayOp - , FreezeArrayOp - , ThawArrayOp - , CasArrayOp - , NewSmallArrayOp - , SameSmallMutableArrayOp - , ReadSmallArrayOp - , WriteSmallArrayOp - , SizeofSmallArrayOp - , SizeofSmallMutableArrayOp - , IndexSmallArrayOp - , UnsafeFreezeSmallArrayOp - , UnsafeThawSmallArrayOp - , CopySmallArrayOp - , CopySmallMutableArrayOp - , CloneSmallArrayOp - , CloneSmallMutableArrayOp - , FreezeSmallArrayOp - , ThawSmallArrayOp - , CasSmallArrayOp - , NewByteArrayOp_Char - , NewPinnedByteArrayOp_Char - , NewAlignedPinnedByteArrayOp_Char - , MutableByteArrayIsPinnedOp - , ByteArrayIsPinnedOp - , ByteArrayContents_Char - , SameMutableByteArrayOp - , ShrinkMutableByteArrayOp_Char - , ResizeMutableByteArrayOp_Char - , UnsafeFreezeByteArrayOp - , SizeofByteArrayOp - , SizeofMutableByteArrayOp - , GetSizeofMutableByteArrayOp - , IndexByteArrayOp_Char - , IndexByteArrayOp_WideChar - , IndexByteArrayOp_Int - , IndexByteArrayOp_Word - , IndexByteArrayOp_Addr - , IndexByteArrayOp_Float - , IndexByteArrayOp_Double - , IndexByteArrayOp_StablePtr - , IndexByteArrayOp_Int8 - , IndexByteArrayOp_Int16 - , IndexByteArrayOp_Int32 - , IndexByteArrayOp_Int64 - , IndexByteArrayOp_Word8 - , IndexByteArrayOp_Word16 - , IndexByteArrayOp_Word32 - , IndexByteArrayOp_Word64 - , ReadByteArrayOp_Char - , ReadByteArrayOp_WideChar - , ReadByteArrayOp_Int - , ReadByteArrayOp_Word - , ReadByteArrayOp_Addr - , ReadByteArrayOp_Float - , ReadByteArrayOp_Double - , ReadByteArrayOp_StablePtr - , ReadByteArrayOp_Int8 - , ReadByteArrayOp_Int16 - , ReadByteArrayOp_Int32 - , ReadByteArrayOp_Int64 - , ReadByteArrayOp_Word8 - , ReadByteArrayOp_Word16 - , ReadByteArrayOp_Word32 - , ReadByteArrayOp_Word64 - , WriteByteArrayOp_Char - , WriteByteArrayOp_WideChar - , WriteByteArrayOp_Int - , WriteByteArrayOp_Word - , WriteByteArrayOp_Addr - , WriteByteArrayOp_Float - , WriteByteArrayOp_Double - , WriteByteArrayOp_StablePtr - , WriteByteArrayOp_Int8 - , WriteByteArrayOp_Int16 - , WriteByteArrayOp_Int32 - , WriteByteArrayOp_Int64 - , WriteByteArrayOp_Word8 - , WriteByteArrayOp_Word16 - , WriteByteArrayOp_Word32 - , WriteByteArrayOp_Word64 - , CopyByteArrayOp - , CopyMutableByteArrayOp - , CopyByteArrayToAddrOp - , CopyMutableByteArrayToAddrOp - , CopyAddrToByteArrayOp - , SetByteArrayOp - , AtomicReadByteArrayOp_Int - , AtomicWriteByteArrayOp_Int - , CasByteArrayOp_Int - , FetchAddByteArrayOp_Int - , FetchSubByteArrayOp_Int - , FetchAndByteArrayOp_Int - , FetchNandByteArrayOp_Int - , FetchOrByteArrayOp_Int - , FetchXorByteArrayOp_Int - , NewArrayArrayOp - , SameMutableArrayArrayOp - , UnsafeFreezeArrayArrayOp - , SizeofArrayArrayOp - , SizeofMutableArrayArrayOp - , IndexArrayArrayOp_ByteArray - , IndexArrayArrayOp_ArrayArray - , ReadArrayArrayOp_ByteArray - , ReadArrayArrayOp_MutableByteArray - , ReadArrayArrayOp_ArrayArray - , ReadArrayArrayOp_MutableArrayArray - , WriteArrayArrayOp_ByteArray - , WriteArrayArrayOp_MutableByteArray - , WriteArrayArrayOp_ArrayArray - , WriteArrayArrayOp_MutableArrayArray - , CopyArrayArrayOp - , CopyMutableArrayArrayOp - , AddrAddOp - , AddrSubOp - , AddrRemOp - , Addr2IntOp - , Int2AddrOp - , AddrGtOp - , AddrGeOp - , AddrEqOp - , AddrNeOp - , AddrLtOp - , AddrLeOp - , IndexOffAddrOp_Char - , IndexOffAddrOp_WideChar - , IndexOffAddrOp_Int - , IndexOffAddrOp_Word - , IndexOffAddrOp_Addr - , IndexOffAddrOp_Float - , IndexOffAddrOp_Double - , IndexOffAddrOp_StablePtr - , IndexOffAddrOp_Int8 - , IndexOffAddrOp_Int16 - , IndexOffAddrOp_Int32 - , IndexOffAddrOp_Int64 - , IndexOffAddrOp_Word8 - , IndexOffAddrOp_Word16 - , IndexOffAddrOp_Word32 - , IndexOffAddrOp_Word64 - , ReadOffAddrOp_Char - , ReadOffAddrOp_WideChar - , ReadOffAddrOp_Int - , ReadOffAddrOp_Word - , ReadOffAddrOp_Addr - , ReadOffAddrOp_Float - , ReadOffAddrOp_Double - , ReadOffAddrOp_StablePtr - , ReadOffAddrOp_Int8 - , ReadOffAddrOp_Int16 - , ReadOffAddrOp_Int32 - , ReadOffAddrOp_Int64 - , ReadOffAddrOp_Word8 - , ReadOffAddrOp_Word16 - , ReadOffAddrOp_Word32 - , ReadOffAddrOp_Word64 - , WriteOffAddrOp_Char - , WriteOffAddrOp_WideChar - , WriteOffAddrOp_Int - , WriteOffAddrOp_Word - , WriteOffAddrOp_Addr - , WriteOffAddrOp_Float - , WriteOffAddrOp_Double - , WriteOffAddrOp_StablePtr - , WriteOffAddrOp_Int8 - , WriteOffAddrOp_Int16 - , WriteOffAddrOp_Int32 - , WriteOffAddrOp_Int64 - , WriteOffAddrOp_Word8 - , WriteOffAddrOp_Word16 - , WriteOffAddrOp_Word32 - , WriteOffAddrOp_Word64 - , NewMutVarOp - , ReadMutVarOp - , WriteMutVarOp - , SameMutVarOp - , AtomicModifyMutVarOp - , CasMutVarOp - , CatchOp - , RaiseOp - , RaiseIOOp - , MaskAsyncExceptionsOp - , MaskUninterruptibleOp - , UnmaskAsyncExceptionsOp - , MaskStatus - , AtomicallyOp - , RetryOp - , CatchRetryOp - , CatchSTMOp - , Check - , NewTVarOp - , ReadTVarOp - , ReadTVarIOOp - , WriteTVarOp - , SameTVarOp - , NewMVarOp - , TakeMVarOp - , TryTakeMVarOp - , PutMVarOp - , TryPutMVarOp - , ReadMVarOp - , TryReadMVarOp - , SameMVarOp - , IsEmptyMVarOp - , DelayOp - , WaitReadOp - , WaitWriteOp - , ForkOp - , ForkOnOp - , KillThreadOp - , YieldOp - , MyThreadIdOp - , LabelThreadOp - , IsCurrentThreadBoundOp - , NoDuplicateOp - , ThreadStatusOp - , MkWeakOp - , MkWeakNoFinalizerOp - , AddCFinalizerToWeakOp - , DeRefWeakOp - , FinalizeWeakOp - , TouchOp - , MakeStablePtrOp - , DeRefStablePtrOp - , EqStablePtrOp - , MakeStableNameOp - , EqStableNameOp - , StableNameToIntOp - , CompactNewOp - , CompactResizeOp - , CompactContainsOp - , CompactContainsAnyOp - , CompactGetFirstBlockOp - , CompactGetNextBlockOp - , CompactAllocateBlockOp - , CompactFixupPointersOp - , CompactAdd - , CompactAddWithSharing - , CompactSize - , ReallyUnsafePtrEqualityOp - , ParOp - , SparkOp - , SeqOp - , GetSparkOp - , NumSparks - , DataToTagOp - , TagToEnumOp - , AddrToAnyOp - , AnyToAddrOp - , MkApUpd0_Op - , NewBCOOp - , UnpackClosureOp - , GetApStackValOp - , GetCCSOfOp - , GetCurrentCCSOp - , ClearCCSOp - , TraceEventOp - , TraceMarkerOp - , (VecBroadcastOp IntVec 16 W8) - , (VecBroadcastOp IntVec 8 W16) - , (VecBroadcastOp IntVec 4 W32) - , (VecBroadcastOp IntVec 2 W64) - , (VecBroadcastOp IntVec 32 W8) - , (VecBroadcastOp IntVec 16 W16) - , (VecBroadcastOp IntVec 8 W32) - , (VecBroadcastOp IntVec 4 W64) - , (VecBroadcastOp IntVec 64 W8) - , (VecBroadcastOp IntVec 32 W16) - , (VecBroadcastOp IntVec 16 W32) - , (VecBroadcastOp IntVec 8 W64) - , (VecBroadcastOp WordVec 16 W8) - , (VecBroadcastOp WordVec 8 W16) - , (VecBroadcastOp WordVec 4 W32) - , (VecBroadcastOp WordVec 2 W64) - , (VecBroadcastOp WordVec 32 W8) - , (VecBroadcastOp WordVec 16 W16) - , (VecBroadcastOp WordVec 8 W32) - , (VecBroadcastOp WordVec 4 W64) - , (VecBroadcastOp WordVec 64 W8) - , (VecBroadcastOp WordVec 32 W16) - , (VecBroadcastOp WordVec 16 W32) - , (VecBroadcastOp WordVec 8 W64) - , (VecBroadcastOp FloatVec 4 W32) - , (VecBroadcastOp FloatVec 2 W64) - , (VecBroadcastOp FloatVec 8 W32) - , (VecBroadcastOp FloatVec 4 W64) - , (VecBroadcastOp FloatVec 16 W32) - , (VecBroadcastOp FloatVec 8 W64) - , (VecPackOp IntVec 16 W8) - , (VecPackOp IntVec 8 W16) - , (VecPackOp IntVec 4 W32) - , (VecPackOp IntVec 2 W64) - , (VecPackOp IntVec 32 W8) - , (VecPackOp IntVec 16 W16) - , (VecPackOp IntVec 8 W32) - , (VecPackOp IntVec 4 W64) - , (VecPackOp IntVec 64 W8) - , (VecPackOp IntVec 32 W16) - , (VecPackOp IntVec 16 W32) - , (VecPackOp IntVec 8 W64) - , (VecPackOp WordVec 16 W8) - , (VecPackOp WordVec 8 W16) - , (VecPackOp WordVec 4 W32) - , (VecPackOp WordVec 2 W64) - , (VecPackOp WordVec 32 W8) - , (VecPackOp WordVec 16 W16) - , (VecPackOp WordVec 8 W32) - , (VecPackOp WordVec 4 W64) - , (VecPackOp WordVec 64 W8) - , (VecPackOp WordVec 32 W16) - , (VecPackOp WordVec 16 W32) - , (VecPackOp WordVec 8 W64) - , (VecPackOp FloatVec 4 W32) - , (VecPackOp FloatVec 2 W64) - , (VecPackOp FloatVec 8 W32) - , (VecPackOp FloatVec 4 W64) - , (VecPackOp FloatVec 16 W32) - , (VecPackOp FloatVec 8 W64) - , (VecUnpackOp IntVec 16 W8) - , (VecUnpackOp IntVec 8 W16) - , (VecUnpackOp IntVec 4 W32) - , (VecUnpackOp IntVec 2 W64) - , (VecUnpackOp IntVec 32 W8) - , (VecUnpackOp IntVec 16 W16) - , (VecUnpackOp IntVec 8 W32) - , (VecUnpackOp IntVec 4 W64) - , (VecUnpackOp IntVec 64 W8) - , (VecUnpackOp IntVec 32 W16) - , (VecUnpackOp IntVec 16 W32) - , (VecUnpackOp IntVec 8 W64) - , (VecUnpackOp WordVec 16 W8) - , (VecUnpackOp WordVec 8 W16) - , (VecUnpackOp WordVec 4 W32) - , (VecUnpackOp WordVec 2 W64) - , (VecUnpackOp WordVec 32 W8) - , (VecUnpackOp WordVec 16 W16) - , (VecUnpackOp WordVec 8 W32) - , (VecUnpackOp WordVec 4 W64) - , (VecUnpackOp WordVec 64 W8) - , (VecUnpackOp WordVec 32 W16) - , (VecUnpackOp WordVec 16 W32) - , (VecUnpackOp WordVec 8 W64) - , (VecUnpackOp FloatVec 4 W32) - , (VecUnpackOp FloatVec 2 W64) - , (VecUnpackOp FloatVec 8 W32) - , (VecUnpackOp FloatVec 4 W64) - , (VecUnpackOp FloatVec 16 W32) - , (VecUnpackOp FloatVec 8 W64) - , (VecInsertOp IntVec 16 W8) - , (VecInsertOp IntVec 8 W16) - , (VecInsertOp IntVec 4 W32) - , (VecInsertOp IntVec 2 W64) - , (VecInsertOp IntVec 32 W8) - , (VecInsertOp IntVec 16 W16) - , (VecInsertOp IntVec 8 W32) - , (VecInsertOp IntVec 4 W64) - , (VecInsertOp IntVec 64 W8) - , (VecInsertOp IntVec 32 W16) - , (VecInsertOp IntVec 16 W32) - , (VecInsertOp IntVec 8 W64) - , (VecInsertOp WordVec 16 W8) - , (VecInsertOp WordVec 8 W16) - , (VecInsertOp WordVec 4 W32) - , (VecInsertOp WordVec 2 W64) - , (VecInsertOp WordVec 32 W8) - , (VecInsertOp WordVec 16 W16) - , (VecInsertOp WordVec 8 W32) - , (VecInsertOp WordVec 4 W64) - , (VecInsertOp WordVec 64 W8) - , (VecInsertOp WordVec 32 W16) - , (VecInsertOp WordVec 16 W32) - , (VecInsertOp WordVec 8 W64) - , (VecInsertOp FloatVec 4 W32) - , (VecInsertOp FloatVec 2 W64) - , (VecInsertOp FloatVec 8 W32) - , (VecInsertOp FloatVec 4 W64) - , (VecInsertOp FloatVec 16 W32) - , (VecInsertOp FloatVec 8 W64) - , (VecAddOp IntVec 16 W8) - , (VecAddOp IntVec 8 W16) - , (VecAddOp IntVec 4 W32) - , (VecAddOp IntVec 2 W64) - , (VecAddOp IntVec 32 W8) - , (VecAddOp IntVec 16 W16) - , (VecAddOp IntVec 8 W32) - , (VecAddOp IntVec 4 W64) - , (VecAddOp IntVec 64 W8) - , (VecAddOp IntVec 32 W16) - , (VecAddOp IntVec 16 W32) - , (VecAddOp IntVec 8 W64) - , (VecAddOp WordVec 16 W8) - , (VecAddOp WordVec 8 W16) - , (VecAddOp WordVec 4 W32) - , (VecAddOp WordVec 2 W64) - , (VecAddOp WordVec 32 W8) - , (VecAddOp WordVec 16 W16) - , (VecAddOp WordVec 8 W32) - , (VecAddOp WordVec 4 W64) - , (VecAddOp WordVec 64 W8) - , (VecAddOp WordVec 32 W16) - , (VecAddOp WordVec 16 W32) - , (VecAddOp WordVec 8 W64) - , (VecAddOp FloatVec 4 W32) - , (VecAddOp FloatVec 2 W64) - , (VecAddOp FloatVec 8 W32) - , (VecAddOp FloatVec 4 W64) - , (VecAddOp FloatVec 16 W32) - , (VecAddOp FloatVec 8 W64) - , (VecSubOp IntVec 16 W8) - , (VecSubOp IntVec 8 W16) - , (VecSubOp IntVec 4 W32) - , (VecSubOp IntVec 2 W64) - , (VecSubOp IntVec 32 W8) - , (VecSubOp IntVec 16 W16) - , (VecSubOp IntVec 8 W32) - , (VecSubOp IntVec 4 W64) - , (VecSubOp IntVec 64 W8) - , (VecSubOp IntVec 32 W16) - , (VecSubOp IntVec 16 W32) - , (VecSubOp IntVec 8 W64) - , (VecSubOp WordVec 16 W8) - , (VecSubOp WordVec 8 W16) - , (VecSubOp WordVec 4 W32) - , (VecSubOp WordVec 2 W64) - , (VecSubOp WordVec 32 W8) - , (VecSubOp WordVec 16 W16) - , (VecSubOp WordVec 8 W32) - , (VecSubOp WordVec 4 W64) - , (VecSubOp WordVec 64 W8) - , (VecSubOp WordVec 32 W16) - , (VecSubOp WordVec 16 W32) - , (VecSubOp WordVec 8 W64) - , (VecSubOp FloatVec 4 W32) - , (VecSubOp FloatVec 2 W64) - , (VecSubOp FloatVec 8 W32) - , (VecSubOp FloatVec 4 W64) - , (VecSubOp FloatVec 16 W32) - , (VecSubOp FloatVec 8 W64) - , (VecMulOp IntVec 16 W8) - , (VecMulOp IntVec 8 W16) - , (VecMulOp IntVec 4 W32) - , (VecMulOp IntVec 2 W64) - , (VecMulOp IntVec 32 W8) - , (VecMulOp IntVec 16 W16) - , (VecMulOp IntVec 8 W32) - , (VecMulOp IntVec 4 W64) - , (VecMulOp IntVec 64 W8) - , (VecMulOp IntVec 32 W16) - , (VecMulOp IntVec 16 W32) - , (VecMulOp IntVec 8 W64) - , (VecMulOp WordVec 16 W8) - , (VecMulOp WordVec 8 W16) - , (VecMulOp WordVec 4 W32) - , (VecMulOp WordVec 2 W64) - , (VecMulOp WordVec 32 W8) - , (VecMulOp WordVec 16 W16) - , (VecMulOp WordVec 8 W32) - , (VecMulOp WordVec 4 W64) - , (VecMulOp WordVec 64 W8) - , (VecMulOp WordVec 32 W16) - , (VecMulOp WordVec 16 W32) - , (VecMulOp WordVec 8 W64) - , (VecMulOp FloatVec 4 W32) - , (VecMulOp FloatVec 2 W64) - , (VecMulOp FloatVec 8 W32) - , (VecMulOp FloatVec 4 W64) - , (VecMulOp FloatVec 16 W32) - , (VecMulOp FloatVec 8 W64) - , (VecDivOp FloatVec 4 W32) - , (VecDivOp FloatVec 2 W64) - , (VecDivOp FloatVec 8 W32) - , (VecDivOp FloatVec 4 W64) - , (VecDivOp FloatVec 16 W32) - , (VecDivOp FloatVec 8 W64) - , (VecQuotOp IntVec 16 W8) - , (VecQuotOp IntVec 8 W16) - , (VecQuotOp IntVec 4 W32) - , (VecQuotOp IntVec 2 W64) - , (VecQuotOp IntVec 32 W8) - , (VecQuotOp IntVec 16 W16) - , (VecQuotOp IntVec 8 W32) - , (VecQuotOp IntVec 4 W64) - , (VecQuotOp IntVec 64 W8) - , (VecQuotOp IntVec 32 W16) - , (VecQuotOp IntVec 16 W32) - , (VecQuotOp IntVec 8 W64) - , (VecQuotOp WordVec 16 W8) - , (VecQuotOp WordVec 8 W16) - , (VecQuotOp WordVec 4 W32) - , (VecQuotOp WordVec 2 W64) - , (VecQuotOp WordVec 32 W8) - , (VecQuotOp WordVec 16 W16) - , (VecQuotOp WordVec 8 W32) - , (VecQuotOp WordVec 4 W64) - , (VecQuotOp WordVec 64 W8) - , (VecQuotOp WordVec 32 W16) - , (VecQuotOp WordVec 16 W32) - , (VecQuotOp WordVec 8 W64) - , (VecRemOp IntVec 16 W8) - , (VecRemOp IntVec 8 W16) - , (VecRemOp IntVec 4 W32) - , (VecRemOp IntVec 2 W64) - , (VecRemOp IntVec 32 W8) - , (VecRemOp IntVec 16 W16) - , (VecRemOp IntVec 8 W32) - , (VecRemOp IntVec 4 W64) - , (VecRemOp IntVec 64 W8) - , (VecRemOp IntVec 32 W16) - , (VecRemOp IntVec 16 W32) - , (VecRemOp IntVec 8 W64) - , (VecRemOp WordVec 16 W8) - , (VecRemOp WordVec 8 W16) - , (VecRemOp WordVec 4 W32) - , (VecRemOp WordVec 2 W64) - , (VecRemOp WordVec 32 W8) - , (VecRemOp WordVec 16 W16) - , (VecRemOp WordVec 8 W32) - , (VecRemOp WordVec 4 W64) - , (VecRemOp WordVec 64 W8) - , (VecRemOp WordVec 32 W16) - , (VecRemOp WordVec 16 W32) - , (VecRemOp WordVec 8 W64) - , (VecNegOp IntVec 16 W8) - , (VecNegOp IntVec 8 W16) - , (VecNegOp IntVec 4 W32) - , (VecNegOp IntVec 2 W64) - , (VecNegOp IntVec 32 W8) - , (VecNegOp IntVec 16 W16) - , (VecNegOp IntVec 8 W32) - , (VecNegOp IntVec 4 W64) - , (VecNegOp IntVec 64 W8) - , (VecNegOp IntVec 32 W16) - , (VecNegOp IntVec 16 W32) - , (VecNegOp IntVec 8 W64) - , (VecNegOp FloatVec 4 W32) - , (VecNegOp FloatVec 2 W64) - , (VecNegOp FloatVec 8 W32) - , (VecNegOp FloatVec 4 W64) - , (VecNegOp FloatVec 16 W32) - , (VecNegOp FloatVec 8 W64) - , (VecIndexByteArrayOp IntVec 16 W8) - , (VecIndexByteArrayOp IntVec 8 W16) - , (VecIndexByteArrayOp IntVec 4 W32) - , (VecIndexByteArrayOp IntVec 2 W64) - , (VecIndexByteArrayOp IntVec 32 W8) - , (VecIndexByteArrayOp IntVec 16 W16) - , (VecIndexByteArrayOp IntVec 8 W32) - , (VecIndexByteArrayOp IntVec 4 W64) - , (VecIndexByteArrayOp IntVec 64 W8) - , (VecIndexByteArrayOp IntVec 32 W16) - , (VecIndexByteArrayOp IntVec 16 W32) - , (VecIndexByteArrayOp IntVec 8 W64) - , (VecIndexByteArrayOp WordVec 16 W8) - , (VecIndexByteArrayOp WordVec 8 W16) - , (VecIndexByteArrayOp WordVec 4 W32) - , (VecIndexByteArrayOp WordVec 2 W64) - , (VecIndexByteArrayOp WordVec 32 W8) - , (VecIndexByteArrayOp WordVec 16 W16) - , (VecIndexByteArrayOp WordVec 8 W32) - , (VecIndexByteArrayOp WordVec 4 W64) - , (VecIndexByteArrayOp WordVec 64 W8) - , (VecIndexByteArrayOp WordVec 32 W16) - , (VecIndexByteArrayOp WordVec 16 W32) - , (VecIndexByteArrayOp WordVec 8 W64) - , (VecIndexByteArrayOp FloatVec 4 W32) - , (VecIndexByteArrayOp FloatVec 2 W64) - , (VecIndexByteArrayOp FloatVec 8 W32) - , (VecIndexByteArrayOp FloatVec 4 W64) - , (VecIndexByteArrayOp FloatVec 16 W32) - , (VecIndexByteArrayOp FloatVec 8 W64) - , (VecReadByteArrayOp IntVec 16 W8) - , (VecReadByteArrayOp IntVec 8 W16) - , (VecReadByteArrayOp IntVec 4 W32) - , (VecReadByteArrayOp IntVec 2 W64) - , (VecReadByteArrayOp IntVec 32 W8) - , (VecReadByteArrayOp IntVec 16 W16) - , (VecReadByteArrayOp IntVec 8 W32) - , (VecReadByteArrayOp IntVec 4 W64) - , (VecReadByteArrayOp IntVec 64 W8) - , (VecReadByteArrayOp IntVec 32 W16) - , (VecReadByteArrayOp IntVec 16 W32) - , (VecReadByteArrayOp IntVec 8 W64) - , (VecReadByteArrayOp WordVec 16 W8) - , (VecReadByteArrayOp WordVec 8 W16) - , (VecReadByteArrayOp WordVec 4 W32) - , (VecReadByteArrayOp WordVec 2 W64) - , (VecReadByteArrayOp WordVec 32 W8) - , (VecReadByteArrayOp WordVec 16 W16) - , (VecReadByteArrayOp WordVec 8 W32) - , (VecReadByteArrayOp WordVec 4 W64) - , (VecReadByteArrayOp WordVec 64 W8) - , (VecReadByteArrayOp WordVec 32 W16) - , (VecReadByteArrayOp WordVec 16 W32) - , (VecReadByteArrayOp WordVec 8 W64) - , (VecReadByteArrayOp FloatVec 4 W32) - , (VecReadByteArrayOp FloatVec 2 W64) - , (VecReadByteArrayOp FloatVec 8 W32) - , (VecReadByteArrayOp FloatVec 4 W64) - , (VecReadByteArrayOp FloatVec 16 W32) - , (VecReadByteArrayOp FloatVec 8 W64) - , (VecWriteByteArrayOp IntVec 16 W8) - , (VecWriteByteArrayOp IntVec 8 W16) - , (VecWriteByteArrayOp IntVec 4 W32) - , (VecWriteByteArrayOp IntVec 2 W64) - , (VecWriteByteArrayOp IntVec 32 W8) - , (VecWriteByteArrayOp IntVec 16 W16) - , (VecWriteByteArrayOp IntVec 8 W32) - , (VecWriteByteArrayOp IntVec 4 W64) - , (VecWriteByteArrayOp IntVec 64 W8) - , (VecWriteByteArrayOp IntVec 32 W16) - , (VecWriteByteArrayOp IntVec 16 W32) - , (VecWriteByteArrayOp IntVec 8 W64) - , (VecWriteByteArrayOp WordVec 16 W8) - , (VecWriteByteArrayOp WordVec 8 W16) - , (VecWriteByteArrayOp WordVec 4 W32) - , (VecWriteByteArrayOp WordVec 2 W64) - , (VecWriteByteArrayOp WordVec 32 W8) - , (VecWriteByteArrayOp WordVec 16 W16) - , (VecWriteByteArrayOp WordVec 8 W32) - , (VecWriteByteArrayOp WordVec 4 W64) - , (VecWriteByteArrayOp WordVec 64 W8) - , (VecWriteByteArrayOp WordVec 32 W16) - , (VecWriteByteArrayOp WordVec 16 W32) - , (VecWriteByteArrayOp WordVec 8 W64) - , (VecWriteByteArrayOp FloatVec 4 W32) - , (VecWriteByteArrayOp FloatVec 2 W64) - , (VecWriteByteArrayOp FloatVec 8 W32) - , (VecWriteByteArrayOp FloatVec 4 W64) - , (VecWriteByteArrayOp FloatVec 16 W32) - , (VecWriteByteArrayOp FloatVec 8 W64) - , (VecIndexOffAddrOp IntVec 16 W8) - , (VecIndexOffAddrOp IntVec 8 W16) - , (VecIndexOffAddrOp IntVec 4 W32) - , (VecIndexOffAddrOp IntVec 2 W64) - , (VecIndexOffAddrOp IntVec 32 W8) - , (VecIndexOffAddrOp IntVec 16 W16) - , (VecIndexOffAddrOp IntVec 8 W32) - , (VecIndexOffAddrOp IntVec 4 W64) - , (VecIndexOffAddrOp IntVec 64 W8) - , (VecIndexOffAddrOp IntVec 32 W16) - , (VecIndexOffAddrOp IntVec 16 W32) - , (VecIndexOffAddrOp IntVec 8 W64) - , (VecIndexOffAddrOp WordVec 16 W8) - , (VecIndexOffAddrOp WordVec 8 W16) - , (VecIndexOffAddrOp WordVec 4 W32) - , (VecIndexOffAddrOp WordVec 2 W64) - , (VecIndexOffAddrOp WordVec 32 W8) - , (VecIndexOffAddrOp WordVec 16 W16) - , (VecIndexOffAddrOp WordVec 8 W32) - , (VecIndexOffAddrOp WordVec 4 W64) - , (VecIndexOffAddrOp WordVec 64 W8) - , (VecIndexOffAddrOp WordVec 32 W16) - , (VecIndexOffAddrOp WordVec 16 W32) - , (VecIndexOffAddrOp WordVec 8 W64) - , (VecIndexOffAddrOp FloatVec 4 W32) - , (VecIndexOffAddrOp FloatVec 2 W64) - , (VecIndexOffAddrOp FloatVec 8 W32) - , (VecIndexOffAddrOp FloatVec 4 W64) - , (VecIndexOffAddrOp FloatVec 16 W32) - , (VecIndexOffAddrOp FloatVec 8 W64) - , (VecReadOffAddrOp IntVec 16 W8) - , (VecReadOffAddrOp IntVec 8 W16) - , (VecReadOffAddrOp IntVec 4 W32) - , (VecReadOffAddrOp IntVec 2 W64) - , (VecReadOffAddrOp IntVec 32 W8) - , (VecReadOffAddrOp IntVec 16 W16) - , (VecReadOffAddrOp IntVec 8 W32) - , (VecReadOffAddrOp IntVec 4 W64) - , (VecReadOffAddrOp IntVec 64 W8) - , (VecReadOffAddrOp IntVec 32 W16) - , (VecReadOffAddrOp IntVec 16 W32) - , (VecReadOffAddrOp IntVec 8 W64) - , (VecReadOffAddrOp WordVec 16 W8) - , (VecReadOffAddrOp WordVec 8 W16) - , (VecReadOffAddrOp WordVec 4 W32) - , (VecReadOffAddrOp WordVec 2 W64) - , (VecReadOffAddrOp WordVec 32 W8) - , (VecReadOffAddrOp WordVec 16 W16) - , (VecReadOffAddrOp WordVec 8 W32) - , (VecReadOffAddrOp WordVec 4 W64) - , (VecReadOffAddrOp WordVec 64 W8) - , (VecReadOffAddrOp WordVec 32 W16) - , (VecReadOffAddrOp WordVec 16 W32) - , (VecReadOffAddrOp WordVec 8 W64) - , (VecReadOffAddrOp FloatVec 4 W32) - , (VecReadOffAddrOp FloatVec 2 W64) - , (VecReadOffAddrOp FloatVec 8 W32) - , (VecReadOffAddrOp FloatVec 4 W64) - , (VecReadOffAddrOp FloatVec 16 W32) - , (VecReadOffAddrOp FloatVec 8 W64) - , (VecWriteOffAddrOp IntVec 16 W8) - , (VecWriteOffAddrOp IntVec 8 W16) - , (VecWriteOffAddrOp IntVec 4 W32) - , (VecWriteOffAddrOp IntVec 2 W64) - , (VecWriteOffAddrOp IntVec 32 W8) - , (VecWriteOffAddrOp IntVec 16 W16) - , (VecWriteOffAddrOp IntVec 8 W32) - , (VecWriteOffAddrOp IntVec 4 W64) - , (VecWriteOffAddrOp IntVec 64 W8) - , (VecWriteOffAddrOp IntVec 32 W16) - , (VecWriteOffAddrOp IntVec 16 W32) - , (VecWriteOffAddrOp IntVec 8 W64) - , (VecWriteOffAddrOp WordVec 16 W8) - , (VecWriteOffAddrOp WordVec 8 W16) - , (VecWriteOffAddrOp WordVec 4 W32) - , (VecWriteOffAddrOp WordVec 2 W64) - , (VecWriteOffAddrOp WordVec 32 W8) - , (VecWriteOffAddrOp WordVec 16 W16) - , (VecWriteOffAddrOp WordVec 8 W32) - , (VecWriteOffAddrOp WordVec 4 W64) - , (VecWriteOffAddrOp WordVec 64 W8) - , (VecWriteOffAddrOp WordVec 32 W16) - , (VecWriteOffAddrOp WordVec 16 W32) - , (VecWriteOffAddrOp WordVec 8 W64) - , (VecWriteOffAddrOp FloatVec 4 W32) - , (VecWriteOffAddrOp FloatVec 2 W64) - , (VecWriteOffAddrOp FloatVec 8 W32) - , (VecWriteOffAddrOp FloatVec 4 W64) - , (VecWriteOffAddrOp FloatVec 16 W32) - , (VecWriteOffAddrOp FloatVec 8 W64) - , (VecIndexScalarByteArrayOp IntVec 16 W8) - , (VecIndexScalarByteArrayOp IntVec 8 W16) - , (VecIndexScalarByteArrayOp IntVec 4 W32) - , (VecIndexScalarByteArrayOp IntVec 2 W64) - , (VecIndexScalarByteArrayOp IntVec 32 W8) - , (VecIndexScalarByteArrayOp IntVec 16 W16) - , (VecIndexScalarByteArrayOp IntVec 8 W32) - , (VecIndexScalarByteArrayOp IntVec 4 W64) - , (VecIndexScalarByteArrayOp IntVec 64 W8) - , (VecIndexScalarByteArrayOp IntVec 32 W16) - , (VecIndexScalarByteArrayOp IntVec 16 W32) - , (VecIndexScalarByteArrayOp IntVec 8 W64) - , (VecIndexScalarByteArrayOp WordVec 16 W8) - , (VecIndexScalarByteArrayOp WordVec 8 W16) - , (VecIndexScalarByteArrayOp WordVec 4 W32) - , (VecIndexScalarByteArrayOp WordVec 2 W64) - , (VecIndexScalarByteArrayOp WordVec 32 W8) - , (VecIndexScalarByteArrayOp WordVec 16 W16) - , (VecIndexScalarByteArrayOp WordVec 8 W32) - , (VecIndexScalarByteArrayOp WordVec 4 W64) - , (VecIndexScalarByteArrayOp WordVec 64 W8) - , (VecIndexScalarByteArrayOp WordVec 32 W16) - , (VecIndexScalarByteArrayOp WordVec 16 W32) - , (VecIndexScalarByteArrayOp WordVec 8 W64) - , (VecIndexScalarByteArrayOp FloatVec 4 W32) - , (VecIndexScalarByteArrayOp FloatVec 2 W64) - , (VecIndexScalarByteArrayOp FloatVec 8 W32) - , (VecIndexScalarByteArrayOp FloatVec 4 W64) - , (VecIndexScalarByteArrayOp FloatVec 16 W32) - , (VecIndexScalarByteArrayOp FloatVec 8 W64) - , (VecReadScalarByteArrayOp IntVec 16 W8) - , (VecReadScalarByteArrayOp IntVec 8 W16) - , (VecReadScalarByteArrayOp IntVec 4 W32) - , (VecReadScalarByteArrayOp IntVec 2 W64) - , (VecReadScalarByteArrayOp IntVec 32 W8) - , (VecReadScalarByteArrayOp IntVec 16 W16) - , (VecReadScalarByteArrayOp IntVec 8 W32) - , (VecReadScalarByteArrayOp IntVec 4 W64) - , (VecReadScalarByteArrayOp IntVec 64 W8) - , (VecReadScalarByteArrayOp IntVec 32 W16) - , (VecReadScalarByteArrayOp IntVec 16 W32) - , (VecReadScalarByteArrayOp IntVec 8 W64) - , (VecReadScalarByteArrayOp WordVec 16 W8) - , (VecReadScalarByteArrayOp WordVec 8 W16) - , (VecReadScalarByteArrayOp WordVec 4 W32) - , (VecReadScalarByteArrayOp WordVec 2 W64) - , (VecReadScalarByteArrayOp WordVec 32 W8) - , (VecReadScalarByteArrayOp WordVec 16 W16) - , (VecReadScalarByteArrayOp WordVec 8 W32) - , (VecReadScalarByteArrayOp WordVec 4 W64) - , (VecReadScalarByteArrayOp WordVec 64 W8) - , (VecReadScalarByteArrayOp WordVec 32 W16) - , (VecReadScalarByteArrayOp WordVec 16 W32) - , (VecReadScalarByteArrayOp WordVec 8 W64) - , (VecReadScalarByteArrayOp FloatVec 4 W32) - , (VecReadScalarByteArrayOp FloatVec 2 W64) - , (VecReadScalarByteArrayOp FloatVec 8 W32) - , (VecReadScalarByteArrayOp FloatVec 4 W64) - , (VecReadScalarByteArrayOp FloatVec 16 W32) - , (VecReadScalarByteArrayOp FloatVec 8 W64) - , (VecWriteScalarByteArrayOp IntVec 16 W8) - , (VecWriteScalarByteArrayOp IntVec 8 W16) - , (VecWriteScalarByteArrayOp IntVec 4 W32) - , (VecWriteScalarByteArrayOp IntVec 2 W64) - , (VecWriteScalarByteArrayOp IntVec 32 W8) - , (VecWriteScalarByteArrayOp IntVec 16 W16) - , (VecWriteScalarByteArrayOp IntVec 8 W32) - , (VecWriteScalarByteArrayOp IntVec 4 W64) - , (VecWriteScalarByteArrayOp IntVec 64 W8) - , (VecWriteScalarByteArrayOp IntVec 32 W16) - , (VecWriteScalarByteArrayOp IntVec 16 W32) - , (VecWriteScalarByteArrayOp IntVec 8 W64) - , (VecWriteScalarByteArrayOp WordVec 16 W8) - , (VecWriteScalarByteArrayOp WordVec 8 W16) - , (VecWriteScalarByteArrayOp WordVec 4 W32) - , (VecWriteScalarByteArrayOp WordVec 2 W64) - , (VecWriteScalarByteArrayOp WordVec 32 W8) - , (VecWriteScalarByteArrayOp WordVec 16 W16) - , (VecWriteScalarByteArrayOp WordVec 8 W32) - , (VecWriteScalarByteArrayOp WordVec 4 W64) - , (VecWriteScalarByteArrayOp WordVec 64 W8) - , (VecWriteScalarByteArrayOp WordVec 32 W16) - , (VecWriteScalarByteArrayOp WordVec 16 W32) - , (VecWriteScalarByteArrayOp WordVec 8 W64) - , (VecWriteScalarByteArrayOp FloatVec 4 W32) - , (VecWriteScalarByteArrayOp FloatVec 2 W64) - , (VecWriteScalarByteArrayOp FloatVec 8 W32) - , (VecWriteScalarByteArrayOp FloatVec 4 W64) - , (VecWriteScalarByteArrayOp FloatVec 16 W32) - , (VecWriteScalarByteArrayOp FloatVec 8 W64) - , (VecIndexScalarOffAddrOp IntVec 16 W8) - , (VecIndexScalarOffAddrOp IntVec 8 W16) - , (VecIndexScalarOffAddrOp IntVec 4 W32) - , (VecIndexScalarOffAddrOp IntVec 2 W64) - , (VecIndexScalarOffAddrOp IntVec 32 W8) - , (VecIndexScalarOffAddrOp IntVec 16 W16) - , (VecIndexScalarOffAddrOp IntVec 8 W32) - , (VecIndexScalarOffAddrOp IntVec 4 W64) - , (VecIndexScalarOffAddrOp IntVec 64 W8) - , (VecIndexScalarOffAddrOp IntVec 32 W16) - , (VecIndexScalarOffAddrOp IntVec 16 W32) - , (VecIndexScalarOffAddrOp IntVec 8 W64) - , (VecIndexScalarOffAddrOp WordVec 16 W8) - , (VecIndexScalarOffAddrOp WordVec 8 W16) - , (VecIndexScalarOffAddrOp WordVec 4 W32) - , (VecIndexScalarOffAddrOp WordVec 2 W64) - , (VecIndexScalarOffAddrOp WordVec 32 W8) - , (VecIndexScalarOffAddrOp WordVec 16 W16) - , (VecIndexScalarOffAddrOp WordVec 8 W32) - , (VecIndexScalarOffAddrOp WordVec 4 W64) - , (VecIndexScalarOffAddrOp WordVec 64 W8) - , (VecIndexScalarOffAddrOp WordVec 32 W16) - , (VecIndexScalarOffAddrOp WordVec 16 W32) - , (VecIndexScalarOffAddrOp WordVec 8 W64) - , (VecIndexScalarOffAddrOp FloatVec 4 W32) - , (VecIndexScalarOffAddrOp FloatVec 2 W64) - , (VecIndexScalarOffAddrOp FloatVec 8 W32) - , (VecIndexScalarOffAddrOp FloatVec 4 W64) - , (VecIndexScalarOffAddrOp FloatVec 16 W32) - , (VecIndexScalarOffAddrOp FloatVec 8 W64) - , (VecReadScalarOffAddrOp IntVec 16 W8) - , (VecReadScalarOffAddrOp IntVec 8 W16) - , (VecReadScalarOffAddrOp IntVec 4 W32) - , (VecReadScalarOffAddrOp IntVec 2 W64) - , (VecReadScalarOffAddrOp IntVec 32 W8) - , (VecReadScalarOffAddrOp IntVec 16 W16) - , (VecReadScalarOffAddrOp IntVec 8 W32) - , (VecReadScalarOffAddrOp IntVec 4 W64) - , (VecReadScalarOffAddrOp IntVec 64 W8) - , (VecReadScalarOffAddrOp IntVec 32 W16) - , (VecReadScalarOffAddrOp IntVec 16 W32) - , (VecReadScalarOffAddrOp IntVec 8 W64) - , (VecReadScalarOffAddrOp WordVec 16 W8) - , (VecReadScalarOffAddrOp WordVec 8 W16) - , (VecReadScalarOffAddrOp WordVec 4 W32) - , (VecReadScalarOffAddrOp WordVec 2 W64) - , (VecReadScalarOffAddrOp WordVec 32 W8) - , (VecReadScalarOffAddrOp WordVec 16 W16) - , (VecReadScalarOffAddrOp WordVec 8 W32) - , (VecReadScalarOffAddrOp WordVec 4 W64) - , (VecReadScalarOffAddrOp WordVec 64 W8) - , (VecReadScalarOffAddrOp WordVec 32 W16) - , (VecReadScalarOffAddrOp WordVec 16 W32) - , (VecReadScalarOffAddrOp WordVec 8 W64) - , (VecReadScalarOffAddrOp FloatVec 4 W32) - , (VecReadScalarOffAddrOp FloatVec 2 W64) - , (VecReadScalarOffAddrOp FloatVec 8 W32) - , (VecReadScalarOffAddrOp FloatVec 4 W64) - , (VecReadScalarOffAddrOp FloatVec 16 W32) - , (VecReadScalarOffAddrOp FloatVec 8 W64) - , (VecWriteScalarOffAddrOp IntVec 16 W8) - , (VecWriteScalarOffAddrOp IntVec 8 W16) - , (VecWriteScalarOffAddrOp IntVec 4 W32) - , (VecWriteScalarOffAddrOp IntVec 2 W64) - , (VecWriteScalarOffAddrOp IntVec 32 W8) - , (VecWriteScalarOffAddrOp IntVec 16 W16) - , (VecWriteScalarOffAddrOp IntVec 8 W32) - , (VecWriteScalarOffAddrOp IntVec 4 W64) - , (VecWriteScalarOffAddrOp IntVec 64 W8) - , (VecWriteScalarOffAddrOp IntVec 32 W16) - , (VecWriteScalarOffAddrOp IntVec 16 W32) - , (VecWriteScalarOffAddrOp IntVec 8 W64) - , (VecWriteScalarOffAddrOp WordVec 16 W8) - , (VecWriteScalarOffAddrOp WordVec 8 W16) - , (VecWriteScalarOffAddrOp WordVec 4 W32) - , (VecWriteScalarOffAddrOp WordVec 2 W64) - , (VecWriteScalarOffAddrOp WordVec 32 W8) - , (VecWriteScalarOffAddrOp WordVec 16 W16) - , (VecWriteScalarOffAddrOp WordVec 8 W32) - , (VecWriteScalarOffAddrOp WordVec 4 W64) - , (VecWriteScalarOffAddrOp WordVec 64 W8) - , (VecWriteScalarOffAddrOp WordVec 32 W16) - , (VecWriteScalarOffAddrOp WordVec 16 W32) - , (VecWriteScalarOffAddrOp WordVec 8 W64) - , (VecWriteScalarOffAddrOp FloatVec 4 W32) - , (VecWriteScalarOffAddrOp FloatVec 2 W64) - , (VecWriteScalarOffAddrOp FloatVec 8 W32) - , (VecWriteScalarOffAddrOp FloatVec 4 W64) - , (VecWriteScalarOffAddrOp FloatVec 16 W32) - , (VecWriteScalarOffAddrOp FloatVec 8 W64) - , PrefetchByteArrayOp3 - , PrefetchMutableByteArrayOp3 - , PrefetchAddrOp3 - , PrefetchValueOp3 - , PrefetchByteArrayOp2 - , PrefetchMutableByteArrayOp2 - , PrefetchAddrOp2 - , PrefetchValueOp2 - , PrefetchByteArrayOp1 - , PrefetchMutableByteArrayOp1 - , PrefetchAddrOp1 - , PrefetchValueOp1 - , PrefetchByteArrayOp0 - , PrefetchMutableByteArrayOp0 - , PrefetchAddrOp0 - , PrefetchValueOp0 - ] diff --git a/autogen/primop-out-of-line.hs-incl b/autogen/primop-out-of-line.hs-incl deleted file mode 100644 --- a/autogen/primop-out-of-line.hs-incl +++ /dev/null @@ -1,99 +0,0 @@ -primOpOutOfLine DoubleDecode_2IntOp = True -primOpOutOfLine DoubleDecode_Int64Op = True -primOpOutOfLine FloatDecode_IntOp = True -primOpOutOfLine NewArrayOp = True -primOpOutOfLine UnsafeThawArrayOp = True -primOpOutOfLine CopyArrayOp = True -primOpOutOfLine CopyMutableArrayOp = True -primOpOutOfLine CloneArrayOp = True -primOpOutOfLine CloneMutableArrayOp = True -primOpOutOfLine FreezeArrayOp = True -primOpOutOfLine ThawArrayOp = True -primOpOutOfLine CasArrayOp = True -primOpOutOfLine NewSmallArrayOp = True -primOpOutOfLine UnsafeThawSmallArrayOp = True -primOpOutOfLine CopySmallArrayOp = True -primOpOutOfLine CopySmallMutableArrayOp = True -primOpOutOfLine CloneSmallArrayOp = True -primOpOutOfLine CloneSmallMutableArrayOp = True -primOpOutOfLine FreezeSmallArrayOp = True -primOpOutOfLine ThawSmallArrayOp = True -primOpOutOfLine CasSmallArrayOp = True -primOpOutOfLine NewByteArrayOp_Char = True -primOpOutOfLine NewPinnedByteArrayOp_Char = True -primOpOutOfLine NewAlignedPinnedByteArrayOp_Char = True -primOpOutOfLine MutableByteArrayIsPinnedOp = True -primOpOutOfLine ByteArrayIsPinnedOp = True -primOpOutOfLine ShrinkMutableByteArrayOp_Char = True -primOpOutOfLine ResizeMutableByteArrayOp_Char = True -primOpOutOfLine NewArrayArrayOp = True -primOpOutOfLine CopyArrayArrayOp = True -primOpOutOfLine CopyMutableArrayArrayOp = True -primOpOutOfLine NewMutVarOp = True -primOpOutOfLine AtomicModifyMutVarOp = True -primOpOutOfLine CasMutVarOp = True -primOpOutOfLine CatchOp = True -primOpOutOfLine RaiseOp = True -primOpOutOfLine RaiseIOOp = True -primOpOutOfLine MaskAsyncExceptionsOp = True -primOpOutOfLine MaskUninterruptibleOp = True -primOpOutOfLine UnmaskAsyncExceptionsOp = True -primOpOutOfLine MaskStatus = True -primOpOutOfLine AtomicallyOp = True -primOpOutOfLine RetryOp = True -primOpOutOfLine CatchRetryOp = True -primOpOutOfLine CatchSTMOp = True -primOpOutOfLine Check = True -primOpOutOfLine NewTVarOp = True -primOpOutOfLine ReadTVarOp = True -primOpOutOfLine ReadTVarIOOp = True -primOpOutOfLine WriteTVarOp = True -primOpOutOfLine NewMVarOp = True -primOpOutOfLine TakeMVarOp = True -primOpOutOfLine TryTakeMVarOp = True -primOpOutOfLine PutMVarOp = True -primOpOutOfLine TryPutMVarOp = True -primOpOutOfLine ReadMVarOp = True -primOpOutOfLine TryReadMVarOp = True -primOpOutOfLine IsEmptyMVarOp = True -primOpOutOfLine DelayOp = True -primOpOutOfLine WaitReadOp = True -primOpOutOfLine WaitWriteOp = True -primOpOutOfLine ForkOp = True -primOpOutOfLine ForkOnOp = True -primOpOutOfLine KillThreadOp = True -primOpOutOfLine YieldOp = True -primOpOutOfLine MyThreadIdOp = True -primOpOutOfLine LabelThreadOp = True -primOpOutOfLine IsCurrentThreadBoundOp = True -primOpOutOfLine NoDuplicateOp = True -primOpOutOfLine ThreadStatusOp = True -primOpOutOfLine MkWeakOp = True -primOpOutOfLine MkWeakNoFinalizerOp = True -primOpOutOfLine AddCFinalizerToWeakOp = True -primOpOutOfLine DeRefWeakOp = True -primOpOutOfLine FinalizeWeakOp = True -primOpOutOfLine MakeStablePtrOp = True -primOpOutOfLine DeRefStablePtrOp = True -primOpOutOfLine MakeStableNameOp = True -primOpOutOfLine CompactNewOp = True -primOpOutOfLine CompactResizeOp = True -primOpOutOfLine CompactContainsOp = True -primOpOutOfLine CompactContainsAnyOp = True -primOpOutOfLine CompactGetFirstBlockOp = True -primOpOutOfLine CompactGetNextBlockOp = True -primOpOutOfLine CompactAllocateBlockOp = True -primOpOutOfLine CompactFixupPointersOp = True -primOpOutOfLine CompactAdd = True -primOpOutOfLine CompactAddWithSharing = True -primOpOutOfLine CompactSize = True -primOpOutOfLine GetSparkOp = True -primOpOutOfLine NumSparks = True -primOpOutOfLine MkApUpd0_Op = True -primOpOutOfLine NewBCOOp = True -primOpOutOfLine UnpackClosureOp = True -primOpOutOfLine GetApStackValOp = True -primOpOutOfLine ClearCCSOp = True -primOpOutOfLine TraceEventOp = True -primOpOutOfLine TraceMarkerOp = True -primOpOutOfLine _ = False diff --git a/autogen/primop-primop-info.hs-incl b/autogen/primop-primop-info.hs-incl deleted file mode 100644 --- a/autogen/primop-primop-info.hs-incl +++ /dev/null @@ -1,1069 +0,0 @@ -primOpInfo CharGtOp = mkCompare (fsLit "gtChar#") charPrimTy -primOpInfo CharGeOp = mkCompare (fsLit "geChar#") charPrimTy -primOpInfo CharEqOp = mkCompare (fsLit "eqChar#") charPrimTy -primOpInfo CharNeOp = mkCompare (fsLit "neChar#") charPrimTy -primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy -primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy -primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#") [] [charPrimTy] (intPrimTy) -primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy -primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy -primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy -primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy -primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy -primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy -primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#") [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) -primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy -primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy -primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy -primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy -primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy -primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#") [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) -primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#") [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) -primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy -primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy -primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy -primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy -primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy -primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy -primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#") [] [intPrimTy] (charPrimTy) -primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#") [] [intPrimTy] (wordPrimTy) -primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#") [] [intPrimTy] (floatPrimTy) -primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#") [] [intPrimTy] (doublePrimTy) -primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#") [] [wordPrimTy] (floatPrimTy) -primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#") [] [wordPrimTy] (doublePrimTy) -primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#") [] [intPrimTy, intPrimTy] (intPrimTy) -primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#") [] [intPrimTy, intPrimTy] (intPrimTy) -primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#") [] [intPrimTy, intPrimTy] (intPrimTy) -primOpInfo WordAddOp = mkDyadic (fsLit "plusWord#") wordPrimTy -primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy])) -primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) -primOpInfo WordSubOp = mkDyadic (fsLit "minusWord#") wordPrimTy -primOpInfo WordMulOp = mkDyadic (fsLit "timesWord#") wordPrimTy -primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) -primOpInfo WordQuotOp = mkDyadic (fsLit "quotWord#") wordPrimTy -primOpInfo WordRemOp = mkDyadic (fsLit "remWord#") wordPrimTy -primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) -primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#") [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) -primOpInfo AndOp = mkDyadic (fsLit "and#") wordPrimTy -primOpInfo OrOp = mkDyadic (fsLit "or#") wordPrimTy -primOpInfo XorOp = mkDyadic (fsLit "xor#") wordPrimTy -primOpInfo NotOp = mkMonadic (fsLit "not#") wordPrimTy -primOpInfo SllOp = mkGenPrimOp (fsLit "uncheckedShiftL#") [] [wordPrimTy, intPrimTy] (wordPrimTy) -primOpInfo SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#") [] [wordPrimTy, intPrimTy] (wordPrimTy) -primOpInfo Word2IntOp = mkGenPrimOp (fsLit "word2Int#") [] [wordPrimTy] (intPrimTy) -primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy -primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy -primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy -primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy -primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy -primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy -primOpInfo PopCnt8Op = mkMonadic (fsLit "popCnt8#") wordPrimTy -primOpInfo PopCnt16Op = mkMonadic (fsLit "popCnt16#") wordPrimTy -primOpInfo PopCnt32Op = mkMonadic (fsLit "popCnt32#") wordPrimTy -primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#") [] [wordPrimTy] (wordPrimTy) -primOpInfo PopCntOp = mkMonadic (fsLit "popCnt#") wordPrimTy -primOpInfo Clz8Op = mkMonadic (fsLit "clz8#") wordPrimTy -primOpInfo Clz16Op = mkMonadic (fsLit "clz16#") wordPrimTy -primOpInfo Clz32Op = mkMonadic (fsLit "clz32#") wordPrimTy -primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#") [] [wordPrimTy] (wordPrimTy) -primOpInfo ClzOp = mkMonadic (fsLit "clz#") wordPrimTy -primOpInfo Ctz8Op = mkMonadic (fsLit "ctz8#") wordPrimTy -primOpInfo Ctz16Op = mkMonadic (fsLit "ctz16#") wordPrimTy -primOpInfo Ctz32Op = mkMonadic (fsLit "ctz32#") wordPrimTy -primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#") [] [wordPrimTy] (wordPrimTy) -primOpInfo CtzOp = mkMonadic (fsLit "ctz#") wordPrimTy -primOpInfo BSwap16Op = mkMonadic (fsLit "byteSwap16#") wordPrimTy -primOpInfo BSwap32Op = mkMonadic (fsLit "byteSwap32#") wordPrimTy -primOpInfo BSwap64Op = mkMonadic (fsLit "byteSwap64#") wordPrimTy -primOpInfo BSwapOp = mkMonadic (fsLit "byteSwap#") wordPrimTy -primOpInfo Narrow8IntOp = mkMonadic (fsLit "narrow8Int#") intPrimTy -primOpInfo Narrow16IntOp = mkMonadic (fsLit "narrow16Int#") intPrimTy -primOpInfo Narrow32IntOp = mkMonadic (fsLit "narrow32Int#") intPrimTy -primOpInfo Narrow8WordOp = mkMonadic (fsLit "narrow8Word#") wordPrimTy -primOpInfo Narrow16WordOp = mkMonadic (fsLit "narrow16Word#") wordPrimTy -primOpInfo Narrow32WordOp = mkMonadic (fsLit "narrow32Word#") wordPrimTy -primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy -primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy -primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy -primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy -primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy -primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy -primOpInfo DoubleAddOp = mkDyadic (fsLit "+##") doublePrimTy -primOpInfo DoubleSubOp = mkDyadic (fsLit "-##") doublePrimTy -primOpInfo DoubleMulOp = mkDyadic (fsLit "*##") doublePrimTy -primOpInfo DoubleDivOp = mkDyadic (fsLit "/##") doublePrimTy -primOpInfo DoubleNegOp = mkMonadic (fsLit "negateDouble#") doublePrimTy -primOpInfo DoubleFabsOp = mkMonadic (fsLit "fabsDouble#") doublePrimTy -primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#") [] [doublePrimTy] (intPrimTy) -primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#") [] [doublePrimTy] (floatPrimTy) -primOpInfo DoubleExpOp = mkMonadic (fsLit "expDouble#") doublePrimTy -primOpInfo DoubleLogOp = mkMonadic (fsLit "logDouble#") doublePrimTy -primOpInfo DoubleSqrtOp = mkMonadic (fsLit "sqrtDouble#") doublePrimTy -primOpInfo DoubleSinOp = mkMonadic (fsLit "sinDouble#") doublePrimTy -primOpInfo DoubleCosOp = mkMonadic (fsLit "cosDouble#") doublePrimTy -primOpInfo DoubleTanOp = mkMonadic (fsLit "tanDouble#") doublePrimTy -primOpInfo DoubleAsinOp = mkMonadic (fsLit "asinDouble#") doublePrimTy -primOpInfo DoubleAcosOp = mkMonadic (fsLit "acosDouble#") doublePrimTy -primOpInfo DoubleAtanOp = mkMonadic (fsLit "atanDouble#") doublePrimTy -primOpInfo DoubleSinhOp = mkMonadic (fsLit "sinhDouble#") doublePrimTy -primOpInfo DoubleCoshOp = mkMonadic (fsLit "coshDouble#") doublePrimTy -primOpInfo DoubleTanhOp = mkMonadic (fsLit "tanhDouble#") doublePrimTy -primOpInfo DoublePowerOp = mkDyadic (fsLit "**##") doublePrimTy -primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#") [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy])) -primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#") [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) -primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy -primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy -primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy -primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy -primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy -primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy -primOpInfo FloatAddOp = mkDyadic (fsLit "plusFloat#") floatPrimTy -primOpInfo FloatSubOp = mkDyadic (fsLit "minusFloat#") floatPrimTy -primOpInfo FloatMulOp = mkDyadic (fsLit "timesFloat#") floatPrimTy -primOpInfo FloatDivOp = mkDyadic (fsLit "divideFloat#") floatPrimTy -primOpInfo FloatNegOp = mkMonadic (fsLit "negateFloat#") floatPrimTy -primOpInfo FloatFabsOp = mkMonadic (fsLit "fabsFloat#") floatPrimTy -primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#") [] [floatPrimTy] (intPrimTy) -primOpInfo FloatExpOp = mkMonadic (fsLit "expFloat#") floatPrimTy -primOpInfo FloatLogOp = mkMonadic (fsLit "logFloat#") floatPrimTy -primOpInfo FloatSqrtOp = mkMonadic (fsLit "sqrtFloat#") floatPrimTy -primOpInfo FloatSinOp = mkMonadic (fsLit "sinFloat#") floatPrimTy -primOpInfo FloatCosOp = mkMonadic (fsLit "cosFloat#") floatPrimTy -primOpInfo FloatTanOp = mkMonadic (fsLit "tanFloat#") floatPrimTy -primOpInfo FloatAsinOp = mkMonadic (fsLit "asinFloat#") floatPrimTy -primOpInfo FloatAcosOp = mkMonadic (fsLit "acosFloat#") floatPrimTy -primOpInfo FloatAtanOp = mkMonadic (fsLit "atanFloat#") floatPrimTy -primOpInfo FloatSinhOp = mkMonadic (fsLit "sinhFloat#") floatPrimTy -primOpInfo FloatCoshOp = mkMonadic (fsLit "coshFloat#") floatPrimTy -primOpInfo FloatTanhOp = mkMonadic (fsLit "tanhFloat#") floatPrimTy -primOpInfo FloatPowerOp = mkDyadic (fsLit "powerFloat#") floatPrimTy -primOpInfo Float2DoubleOp = mkGenPrimOp (fsLit "float2Double#") [] [floatPrimTy] (doublePrimTy) -primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#") [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) -primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#") [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#") [alphaTyVar] [mkArrayPrimTy alphaTy] (intPrimTy) -primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#") [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy])) -primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) -primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#") [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy) -primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) -primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#") [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy) -primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy])) -primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) -primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy) -primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) -primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) -primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) -primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#") [deltaTyVar] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) -primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) -primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#") [] [byteArrayPrimTy] (intPrimTy) -primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#") [] [byteArrayPrimTy] (addrPrimTy) -primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy) -primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) -primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy])) -primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#") [] [byteArrayPrimTy] (intPrimTy) -primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) -primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) -primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) -primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#") [] [byteArrayPrimTy, intPrimTy] (addrPrimTy) -primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#") [] [byteArrayPrimTy, intPrimTy] (floatPrimTy) -primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) -primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#") [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) -primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) -primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) -primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) -primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) -primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) -primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) -primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#") [deltaTyVar] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) -primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy) -primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) -primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#") [] [mkArrayArrayPrimTy] (intPrimTy) -primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy) -primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy) -primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy) -primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy])) -primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) -primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) -primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) -primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#") [deltaTyVar] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) -primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#") [] [addrPrimTy, addrPrimTy] (intPrimTy) -primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) -primOpInfo Addr2IntOp = mkGenPrimOp (fsLit "addr2Int#") [] [addrPrimTy] (intPrimTy) -primOpInfo Int2AddrOp = mkGenPrimOp (fsLit "int2Addr#") [] [intPrimTy] (addrPrimTy) -primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy -primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy -primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy -primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy -primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy -primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy -primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#") [] [addrPrimTy, intPrimTy] (charPrimTy) -primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#") [] [addrPrimTy, intPrimTy] (charPrimTy) -primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) -primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#") [] [addrPrimTy, intPrimTy] (floatPrimTy) -primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#") [] [addrPrimTy, intPrimTy] (doublePrimTy) -primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#") [alphaTyVar] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) -primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) -primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) -primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) -primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) -primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) -primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#") [deltaTyVar, alphaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) -primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#") [alphaTyVar, deltaTyVar] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy])) -primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo AtomicModifyMutVarOp = mkGenPrimOp (fsLit "atomicModifyMutVar#") [deltaTyVar, alphaTyVar, betaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkFunTy (alphaTy) (betaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, gammaTy])) -primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#") [alphaTyVar, betaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (betaTy) ((mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#") [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy) -primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#") [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])) -primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#") [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#") [alphaTyVar, betaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (betaTy) ((mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo Check = mkGenPrimOp (fsLit "check#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy])) -primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#") [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy])) -primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) -primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#") [alphaTyVar] [intPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) -primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#") [alphaTyVar] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#") [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) -primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#") [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#") [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#") [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#") [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) -primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#") [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) -primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#") [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#") [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy])) -primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#") [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))])) -primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#") [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy])) -primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#") [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#") [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy) -primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy])) -primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#") [alphaTyVar, betaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy) -primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#") [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy) -primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#") [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy])) -primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#") [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#") [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#") [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy])) -primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#") [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy])) -primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#") [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy])) -primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#") [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy])) -primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#") [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#") [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#") [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy])) -primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#") [alphaTyVar] [alphaTy, alphaTy] (intPrimTy) -primOpInfo ParOp = mkGenPrimOp (fsLit "par#") [alphaTyVar] [alphaTy] (intPrimTy) -primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#") [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#") [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#") [alphaTyVar] [alphaTy] (intPrimTy) -primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#") [alphaTyVar] [intPrimTy] (alphaTy) -primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#") [alphaTyVar] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy])) -primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy])) -primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#") [alphaTyVar] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy])) -primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#") [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy])) -primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#") [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, mkArrayPrimTy betaTy, byteArrayPrimTy])) -primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#") [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy])) -primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#") [deltaTyVar, alphaTyVar] [(mkFunTy (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#") [] [intPrimTy] (int8X16PrimTy) -primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#") [] [intPrimTy] (int16X8PrimTy) -primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#") [] [intPrimTy] (int32X4PrimTy) -primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#") [] [intPrimTy] (int64X2PrimTy) -primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#") [] [intPrimTy] (int8X32PrimTy) -primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#") [] [intPrimTy] (int16X16PrimTy) -primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#") [] [intPrimTy] (int32X8PrimTy) -primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#") [] [intPrimTy] (int64X4PrimTy) -primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#") [] [intPrimTy] (int8X64PrimTy) -primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#") [] [intPrimTy] (int16X32PrimTy) -primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#") [] [intPrimTy] (int32X16PrimTy) -primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#") [] [intPrimTy] (int64X8PrimTy) -primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#") [] [wordPrimTy] (word8X16PrimTy) -primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#") [] [wordPrimTy] (word16X8PrimTy) -primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#") [] [wordPrimTy] (word32X4PrimTy) -primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#") [] [wordPrimTy] (word64X2PrimTy) -primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#") [] [wordPrimTy] (word8X32PrimTy) -primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#") [] [wordPrimTy] (word16X16PrimTy) -primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#") [] [wordPrimTy] (word32X8PrimTy) -primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#") [] [wordPrimTy] (word64X4PrimTy) -primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#") [] [wordPrimTy] (word8X64PrimTy) -primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#") [] [wordPrimTy] (word16X32PrimTy) -primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#") [] [wordPrimTy] (word32X16PrimTy) -primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#") [] [wordPrimTy] (word64X8PrimTy) -primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#") [] [floatPrimTy] (floatX4PrimTy) -primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#") [] [doublePrimTy] (doubleX2PrimTy) -primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#") [] [floatPrimTy] (floatX8PrimTy) -primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#") [] [doublePrimTy] (doubleX4PrimTy) -primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#") [] [floatPrimTy] (floatX16PrimTy) -primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#") [] [doublePrimTy] (doubleX8PrimTy) -primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X16PrimTy) -primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X8PrimTy) -primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X4PrimTy) -primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy) -primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X32PrimTy) -primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X16PrimTy) -primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X8PrimTy) -primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy) -primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X64PrimTy) -primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X32PrimTy) -primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X16PrimTy) -primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy) -primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy) -primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy) -primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X4PrimTy) -primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy) -primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy) -primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy) -primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X8PrimTy) -primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy) -primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy) -primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy) -primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X16PrimTy) -primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy) -primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy) -primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy) -primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy) -primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy) -primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy) -primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy) -primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#") [] [int8X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#") [] [int16X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#") [] [int32X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#") [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#") [] [int8X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#") [] [int16X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#") [] [int32X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#") [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#") [] [int8X64PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#") [] [int16X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#") [] [int32X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#") [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#") [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#") [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#") [] [word32X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#") [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#") [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#") [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#") [] [word32X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#") [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#") [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#") [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#") [] [word32X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#") [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#") [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) -primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#") [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy])) -primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#") [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) -primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#") [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])) -primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#") [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) -primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#") [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])) -primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#") [] [int8X16PrimTy, intPrimTy, intPrimTy] (int8X16PrimTy) -primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#") [] [int16X8PrimTy, intPrimTy, intPrimTy] (int16X8PrimTy) -primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#") [] [int32X4PrimTy, intPrimTy, intPrimTy] (int32X4PrimTy) -primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#") [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy) -primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#") [] [int8X32PrimTy, intPrimTy, intPrimTy] (int8X32PrimTy) -primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#") [] [int16X16PrimTy, intPrimTy, intPrimTy] (int16X16PrimTy) -primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#") [] [int32X8PrimTy, intPrimTy, intPrimTy] (int32X8PrimTy) -primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#") [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy) -primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#") [] [int8X64PrimTy, intPrimTy, intPrimTy] (int8X64PrimTy) -primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#") [] [int16X32PrimTy, intPrimTy, intPrimTy] (int16X32PrimTy) -primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#") [] [int32X16PrimTy, intPrimTy, intPrimTy] (int32X16PrimTy) -primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#") [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy) -primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#") [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy) -primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#") [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy) -primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#") [] [word32X4PrimTy, wordPrimTy, intPrimTy] (word32X4PrimTy) -primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#") [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy) -primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#") [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy) -primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#") [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy) -primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#") [] [word32X8PrimTy, wordPrimTy, intPrimTy] (word32X8PrimTy) -primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#") [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy) -primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#") [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy) -primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#") [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy) -primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#") [] [word32X16PrimTy, wordPrimTy, intPrimTy] (word32X16PrimTy) -primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#") [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy) -primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#") [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy) -primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#") [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy) -primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#") [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy) -primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#") [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy) -primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#") [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy) -primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#") [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy) -primOpInfo (VecAddOp IntVec 16 W8) = mkDyadic (fsLit "plusInt8X16#") int8X16PrimTy -primOpInfo (VecAddOp IntVec 8 W16) = mkDyadic (fsLit "plusInt16X8#") int16X8PrimTy -primOpInfo (VecAddOp IntVec 4 W32) = mkDyadic (fsLit "plusInt32X4#") int32X4PrimTy -primOpInfo (VecAddOp IntVec 2 W64) = mkDyadic (fsLit "plusInt64X2#") int64X2PrimTy -primOpInfo (VecAddOp IntVec 32 W8) = mkDyadic (fsLit "plusInt8X32#") int8X32PrimTy -primOpInfo (VecAddOp IntVec 16 W16) = mkDyadic (fsLit "plusInt16X16#") int16X16PrimTy -primOpInfo (VecAddOp IntVec 8 W32) = mkDyadic (fsLit "plusInt32X8#") int32X8PrimTy -primOpInfo (VecAddOp IntVec 4 W64) = mkDyadic (fsLit "plusInt64X4#") int64X4PrimTy -primOpInfo (VecAddOp IntVec 64 W8) = mkDyadic (fsLit "plusInt8X64#") int8X64PrimTy -primOpInfo (VecAddOp IntVec 32 W16) = mkDyadic (fsLit "plusInt16X32#") int16X32PrimTy -primOpInfo (VecAddOp IntVec 16 W32) = mkDyadic (fsLit "plusInt32X16#") int32X16PrimTy -primOpInfo (VecAddOp IntVec 8 W64) = mkDyadic (fsLit "plusInt64X8#") int64X8PrimTy -primOpInfo (VecAddOp WordVec 16 W8) = mkDyadic (fsLit "plusWord8X16#") word8X16PrimTy -primOpInfo (VecAddOp WordVec 8 W16) = mkDyadic (fsLit "plusWord16X8#") word16X8PrimTy -primOpInfo (VecAddOp WordVec 4 W32) = mkDyadic (fsLit "plusWord32X4#") word32X4PrimTy -primOpInfo (VecAddOp WordVec 2 W64) = mkDyadic (fsLit "plusWord64X2#") word64X2PrimTy -primOpInfo (VecAddOp WordVec 32 W8) = mkDyadic (fsLit "plusWord8X32#") word8X32PrimTy -primOpInfo (VecAddOp WordVec 16 W16) = mkDyadic (fsLit "plusWord16X16#") word16X16PrimTy -primOpInfo (VecAddOp WordVec 8 W32) = mkDyadic (fsLit "plusWord32X8#") word32X8PrimTy -primOpInfo (VecAddOp WordVec 4 W64) = mkDyadic (fsLit "plusWord64X4#") word64X4PrimTy -primOpInfo (VecAddOp WordVec 64 W8) = mkDyadic (fsLit "plusWord8X64#") word8X64PrimTy -primOpInfo (VecAddOp WordVec 32 W16) = mkDyadic (fsLit "plusWord16X32#") word16X32PrimTy -primOpInfo (VecAddOp WordVec 16 W32) = mkDyadic (fsLit "plusWord32X16#") word32X16PrimTy -primOpInfo (VecAddOp WordVec 8 W64) = mkDyadic (fsLit "plusWord64X8#") word64X8PrimTy -primOpInfo (VecAddOp FloatVec 4 W32) = mkDyadic (fsLit "plusFloatX4#") floatX4PrimTy -primOpInfo (VecAddOp FloatVec 2 W64) = mkDyadic (fsLit "plusDoubleX2#") doubleX2PrimTy -primOpInfo (VecAddOp FloatVec 8 W32) = mkDyadic (fsLit "plusFloatX8#") floatX8PrimTy -primOpInfo (VecAddOp FloatVec 4 W64) = mkDyadic (fsLit "plusDoubleX4#") doubleX4PrimTy -primOpInfo (VecAddOp FloatVec 16 W32) = mkDyadic (fsLit "plusFloatX16#") floatX16PrimTy -primOpInfo (VecAddOp FloatVec 8 W64) = mkDyadic (fsLit "plusDoubleX8#") doubleX8PrimTy -primOpInfo (VecSubOp IntVec 16 W8) = mkDyadic (fsLit "minusInt8X16#") int8X16PrimTy -primOpInfo (VecSubOp IntVec 8 W16) = mkDyadic (fsLit "minusInt16X8#") int16X8PrimTy -primOpInfo (VecSubOp IntVec 4 W32) = mkDyadic (fsLit "minusInt32X4#") int32X4PrimTy -primOpInfo (VecSubOp IntVec 2 W64) = mkDyadic (fsLit "minusInt64X2#") int64X2PrimTy -primOpInfo (VecSubOp IntVec 32 W8) = mkDyadic (fsLit "minusInt8X32#") int8X32PrimTy -primOpInfo (VecSubOp IntVec 16 W16) = mkDyadic (fsLit "minusInt16X16#") int16X16PrimTy -primOpInfo (VecSubOp IntVec 8 W32) = mkDyadic (fsLit "minusInt32X8#") int32X8PrimTy -primOpInfo (VecSubOp IntVec 4 W64) = mkDyadic (fsLit "minusInt64X4#") int64X4PrimTy -primOpInfo (VecSubOp IntVec 64 W8) = mkDyadic (fsLit "minusInt8X64#") int8X64PrimTy -primOpInfo (VecSubOp IntVec 32 W16) = mkDyadic (fsLit "minusInt16X32#") int16X32PrimTy -primOpInfo (VecSubOp IntVec 16 W32) = mkDyadic (fsLit "minusInt32X16#") int32X16PrimTy -primOpInfo (VecSubOp IntVec 8 W64) = mkDyadic (fsLit "minusInt64X8#") int64X8PrimTy -primOpInfo (VecSubOp WordVec 16 W8) = mkDyadic (fsLit "minusWord8X16#") word8X16PrimTy -primOpInfo (VecSubOp WordVec 8 W16) = mkDyadic (fsLit "minusWord16X8#") word16X8PrimTy -primOpInfo (VecSubOp WordVec 4 W32) = mkDyadic (fsLit "minusWord32X4#") word32X4PrimTy -primOpInfo (VecSubOp WordVec 2 W64) = mkDyadic (fsLit "minusWord64X2#") word64X2PrimTy -primOpInfo (VecSubOp WordVec 32 W8) = mkDyadic (fsLit "minusWord8X32#") word8X32PrimTy -primOpInfo (VecSubOp WordVec 16 W16) = mkDyadic (fsLit "minusWord16X16#") word16X16PrimTy -primOpInfo (VecSubOp WordVec 8 W32) = mkDyadic (fsLit "minusWord32X8#") word32X8PrimTy -primOpInfo (VecSubOp WordVec 4 W64) = mkDyadic (fsLit "minusWord64X4#") word64X4PrimTy -primOpInfo (VecSubOp WordVec 64 W8) = mkDyadic (fsLit "minusWord8X64#") word8X64PrimTy -primOpInfo (VecSubOp WordVec 32 W16) = mkDyadic (fsLit "minusWord16X32#") word16X32PrimTy -primOpInfo (VecSubOp WordVec 16 W32) = mkDyadic (fsLit "minusWord32X16#") word32X16PrimTy -primOpInfo (VecSubOp WordVec 8 W64) = mkDyadic (fsLit "minusWord64X8#") word64X8PrimTy -primOpInfo (VecSubOp FloatVec 4 W32) = mkDyadic (fsLit "minusFloatX4#") floatX4PrimTy -primOpInfo (VecSubOp FloatVec 2 W64) = mkDyadic (fsLit "minusDoubleX2#") doubleX2PrimTy -primOpInfo (VecSubOp FloatVec 8 W32) = mkDyadic (fsLit "minusFloatX8#") floatX8PrimTy -primOpInfo (VecSubOp FloatVec 4 W64) = mkDyadic (fsLit "minusDoubleX4#") doubleX4PrimTy -primOpInfo (VecSubOp FloatVec 16 W32) = mkDyadic (fsLit "minusFloatX16#") floatX16PrimTy -primOpInfo (VecSubOp FloatVec 8 W64) = mkDyadic (fsLit "minusDoubleX8#") doubleX8PrimTy -primOpInfo (VecMulOp IntVec 16 W8) = mkDyadic (fsLit "timesInt8X16#") int8X16PrimTy -primOpInfo (VecMulOp IntVec 8 W16) = mkDyadic (fsLit "timesInt16X8#") int16X8PrimTy -primOpInfo (VecMulOp IntVec 4 W32) = mkDyadic (fsLit "timesInt32X4#") int32X4PrimTy -primOpInfo (VecMulOp IntVec 2 W64) = mkDyadic (fsLit "timesInt64X2#") int64X2PrimTy -primOpInfo (VecMulOp IntVec 32 W8) = mkDyadic (fsLit "timesInt8X32#") int8X32PrimTy -primOpInfo (VecMulOp IntVec 16 W16) = mkDyadic (fsLit "timesInt16X16#") int16X16PrimTy -primOpInfo (VecMulOp IntVec 8 W32) = mkDyadic (fsLit "timesInt32X8#") int32X8PrimTy -primOpInfo (VecMulOp IntVec 4 W64) = mkDyadic (fsLit "timesInt64X4#") int64X4PrimTy -primOpInfo (VecMulOp IntVec 64 W8) = mkDyadic (fsLit "timesInt8X64#") int8X64PrimTy -primOpInfo (VecMulOp IntVec 32 W16) = mkDyadic (fsLit "timesInt16X32#") int16X32PrimTy -primOpInfo (VecMulOp IntVec 16 W32) = mkDyadic (fsLit "timesInt32X16#") int32X16PrimTy -primOpInfo (VecMulOp IntVec 8 W64) = mkDyadic (fsLit "timesInt64X8#") int64X8PrimTy -primOpInfo (VecMulOp WordVec 16 W8) = mkDyadic (fsLit "timesWord8X16#") word8X16PrimTy -primOpInfo (VecMulOp WordVec 8 W16) = mkDyadic (fsLit "timesWord16X8#") word16X8PrimTy -primOpInfo (VecMulOp WordVec 4 W32) = mkDyadic (fsLit "timesWord32X4#") word32X4PrimTy -primOpInfo (VecMulOp WordVec 2 W64) = mkDyadic (fsLit "timesWord64X2#") word64X2PrimTy -primOpInfo (VecMulOp WordVec 32 W8) = mkDyadic (fsLit "timesWord8X32#") word8X32PrimTy -primOpInfo (VecMulOp WordVec 16 W16) = mkDyadic (fsLit "timesWord16X16#") word16X16PrimTy -primOpInfo (VecMulOp WordVec 8 W32) = mkDyadic (fsLit "timesWord32X8#") word32X8PrimTy -primOpInfo (VecMulOp WordVec 4 W64) = mkDyadic (fsLit "timesWord64X4#") word64X4PrimTy -primOpInfo (VecMulOp WordVec 64 W8) = mkDyadic (fsLit "timesWord8X64#") word8X64PrimTy -primOpInfo (VecMulOp WordVec 32 W16) = mkDyadic (fsLit "timesWord16X32#") word16X32PrimTy -primOpInfo (VecMulOp WordVec 16 W32) = mkDyadic (fsLit "timesWord32X16#") word32X16PrimTy -primOpInfo (VecMulOp WordVec 8 W64) = mkDyadic (fsLit "timesWord64X8#") word64X8PrimTy -primOpInfo (VecMulOp FloatVec 4 W32) = mkDyadic (fsLit "timesFloatX4#") floatX4PrimTy -primOpInfo (VecMulOp FloatVec 2 W64) = mkDyadic (fsLit "timesDoubleX2#") doubleX2PrimTy -primOpInfo (VecMulOp FloatVec 8 W32) = mkDyadic (fsLit "timesFloatX8#") floatX8PrimTy -primOpInfo (VecMulOp FloatVec 4 W64) = mkDyadic (fsLit "timesDoubleX4#") doubleX4PrimTy -primOpInfo (VecMulOp FloatVec 16 W32) = mkDyadic (fsLit "timesFloatX16#") floatX16PrimTy -primOpInfo (VecMulOp FloatVec 8 W64) = mkDyadic (fsLit "timesDoubleX8#") doubleX8PrimTy -primOpInfo (VecDivOp FloatVec 4 W32) = mkDyadic (fsLit "divideFloatX4#") floatX4PrimTy -primOpInfo (VecDivOp FloatVec 2 W64) = mkDyadic (fsLit "divideDoubleX2#") doubleX2PrimTy -primOpInfo (VecDivOp FloatVec 8 W32) = mkDyadic (fsLit "divideFloatX8#") floatX8PrimTy -primOpInfo (VecDivOp FloatVec 4 W64) = mkDyadic (fsLit "divideDoubleX4#") doubleX4PrimTy -primOpInfo (VecDivOp FloatVec 16 W32) = mkDyadic (fsLit "divideFloatX16#") floatX16PrimTy -primOpInfo (VecDivOp FloatVec 8 W64) = mkDyadic (fsLit "divideDoubleX8#") doubleX8PrimTy -primOpInfo (VecQuotOp IntVec 16 W8) = mkDyadic (fsLit "quotInt8X16#") int8X16PrimTy -primOpInfo (VecQuotOp IntVec 8 W16) = mkDyadic (fsLit "quotInt16X8#") int16X8PrimTy -primOpInfo (VecQuotOp IntVec 4 W32) = mkDyadic (fsLit "quotInt32X4#") int32X4PrimTy -primOpInfo (VecQuotOp IntVec 2 W64) = mkDyadic (fsLit "quotInt64X2#") int64X2PrimTy -primOpInfo (VecQuotOp IntVec 32 W8) = mkDyadic (fsLit "quotInt8X32#") int8X32PrimTy -primOpInfo (VecQuotOp IntVec 16 W16) = mkDyadic (fsLit "quotInt16X16#") int16X16PrimTy -primOpInfo (VecQuotOp IntVec 8 W32) = mkDyadic (fsLit "quotInt32X8#") int32X8PrimTy -primOpInfo (VecQuotOp IntVec 4 W64) = mkDyadic (fsLit "quotInt64X4#") int64X4PrimTy -primOpInfo (VecQuotOp IntVec 64 W8) = mkDyadic (fsLit "quotInt8X64#") int8X64PrimTy -primOpInfo (VecQuotOp IntVec 32 W16) = mkDyadic (fsLit "quotInt16X32#") int16X32PrimTy -primOpInfo (VecQuotOp IntVec 16 W32) = mkDyadic (fsLit "quotInt32X16#") int32X16PrimTy -primOpInfo (VecQuotOp IntVec 8 W64) = mkDyadic (fsLit "quotInt64X8#") int64X8PrimTy -primOpInfo (VecQuotOp WordVec 16 W8) = mkDyadic (fsLit "quotWord8X16#") word8X16PrimTy -primOpInfo (VecQuotOp WordVec 8 W16) = mkDyadic (fsLit "quotWord16X8#") word16X8PrimTy -primOpInfo (VecQuotOp WordVec 4 W32) = mkDyadic (fsLit "quotWord32X4#") word32X4PrimTy -primOpInfo (VecQuotOp WordVec 2 W64) = mkDyadic (fsLit "quotWord64X2#") word64X2PrimTy -primOpInfo (VecQuotOp WordVec 32 W8) = mkDyadic (fsLit "quotWord8X32#") word8X32PrimTy -primOpInfo (VecQuotOp WordVec 16 W16) = mkDyadic (fsLit "quotWord16X16#") word16X16PrimTy -primOpInfo (VecQuotOp WordVec 8 W32) = mkDyadic (fsLit "quotWord32X8#") word32X8PrimTy -primOpInfo (VecQuotOp WordVec 4 W64) = mkDyadic (fsLit "quotWord64X4#") word64X4PrimTy -primOpInfo (VecQuotOp WordVec 64 W8) = mkDyadic (fsLit "quotWord8X64#") word8X64PrimTy -primOpInfo (VecQuotOp WordVec 32 W16) = mkDyadic (fsLit "quotWord16X32#") word16X32PrimTy -primOpInfo (VecQuotOp WordVec 16 W32) = mkDyadic (fsLit "quotWord32X16#") word32X16PrimTy -primOpInfo (VecQuotOp WordVec 8 W64) = mkDyadic (fsLit "quotWord64X8#") word64X8PrimTy -primOpInfo (VecRemOp IntVec 16 W8) = mkDyadic (fsLit "remInt8X16#") int8X16PrimTy -primOpInfo (VecRemOp IntVec 8 W16) = mkDyadic (fsLit "remInt16X8#") int16X8PrimTy -primOpInfo (VecRemOp IntVec 4 W32) = mkDyadic (fsLit "remInt32X4#") int32X4PrimTy -primOpInfo (VecRemOp IntVec 2 W64) = mkDyadic (fsLit "remInt64X2#") int64X2PrimTy -primOpInfo (VecRemOp IntVec 32 W8) = mkDyadic (fsLit "remInt8X32#") int8X32PrimTy -primOpInfo (VecRemOp IntVec 16 W16) = mkDyadic (fsLit "remInt16X16#") int16X16PrimTy -primOpInfo (VecRemOp IntVec 8 W32) = mkDyadic (fsLit "remInt32X8#") int32X8PrimTy -primOpInfo (VecRemOp IntVec 4 W64) = mkDyadic (fsLit "remInt64X4#") int64X4PrimTy -primOpInfo (VecRemOp IntVec 64 W8) = mkDyadic (fsLit "remInt8X64#") int8X64PrimTy -primOpInfo (VecRemOp IntVec 32 W16) = mkDyadic (fsLit "remInt16X32#") int16X32PrimTy -primOpInfo (VecRemOp IntVec 16 W32) = mkDyadic (fsLit "remInt32X16#") int32X16PrimTy -primOpInfo (VecRemOp IntVec 8 W64) = mkDyadic (fsLit "remInt64X8#") int64X8PrimTy -primOpInfo (VecRemOp WordVec 16 W8) = mkDyadic (fsLit "remWord8X16#") word8X16PrimTy -primOpInfo (VecRemOp WordVec 8 W16) = mkDyadic (fsLit "remWord16X8#") word16X8PrimTy -primOpInfo (VecRemOp WordVec 4 W32) = mkDyadic (fsLit "remWord32X4#") word32X4PrimTy -primOpInfo (VecRemOp WordVec 2 W64) = mkDyadic (fsLit "remWord64X2#") word64X2PrimTy -primOpInfo (VecRemOp WordVec 32 W8) = mkDyadic (fsLit "remWord8X32#") word8X32PrimTy -primOpInfo (VecRemOp WordVec 16 W16) = mkDyadic (fsLit "remWord16X16#") word16X16PrimTy -primOpInfo (VecRemOp WordVec 8 W32) = mkDyadic (fsLit "remWord32X8#") word32X8PrimTy -primOpInfo (VecRemOp WordVec 4 W64) = mkDyadic (fsLit "remWord64X4#") word64X4PrimTy -primOpInfo (VecRemOp WordVec 64 W8) = mkDyadic (fsLit "remWord8X64#") word8X64PrimTy -primOpInfo (VecRemOp WordVec 32 W16) = mkDyadic (fsLit "remWord16X32#") word16X32PrimTy -primOpInfo (VecRemOp WordVec 16 W32) = mkDyadic (fsLit "remWord32X16#") word32X16PrimTy -primOpInfo (VecRemOp WordVec 8 W64) = mkDyadic (fsLit "remWord64X8#") word64X8PrimTy -primOpInfo (VecNegOp IntVec 16 W8) = mkMonadic (fsLit "negateInt8X16#") int8X16PrimTy -primOpInfo (VecNegOp IntVec 8 W16) = mkMonadic (fsLit "negateInt16X8#") int16X8PrimTy -primOpInfo (VecNegOp IntVec 4 W32) = mkMonadic (fsLit "negateInt32X4#") int32X4PrimTy -primOpInfo (VecNegOp IntVec 2 W64) = mkMonadic (fsLit "negateInt64X2#") int64X2PrimTy -primOpInfo (VecNegOp IntVec 32 W8) = mkMonadic (fsLit "negateInt8X32#") int8X32PrimTy -primOpInfo (VecNegOp IntVec 16 W16) = mkMonadic (fsLit "negateInt16X16#") int16X16PrimTy -primOpInfo (VecNegOp IntVec 8 W32) = mkMonadic (fsLit "negateInt32X8#") int32X8PrimTy -primOpInfo (VecNegOp IntVec 4 W64) = mkMonadic (fsLit "negateInt64X4#") int64X4PrimTy -primOpInfo (VecNegOp IntVec 64 W8) = mkMonadic (fsLit "negateInt8X64#") int8X64PrimTy -primOpInfo (VecNegOp IntVec 32 W16) = mkMonadic (fsLit "negateInt16X32#") int16X32PrimTy -primOpInfo (VecNegOp IntVec 16 W32) = mkMonadic (fsLit "negateInt32X16#") int32X16PrimTy -primOpInfo (VecNegOp IntVec 8 W64) = mkMonadic (fsLit "negateInt64X8#") int64X8PrimTy -primOpInfo (VecNegOp FloatVec 4 W32) = mkMonadic (fsLit "negateFloatX4#") floatX4PrimTy -primOpInfo (VecNegOp FloatVec 2 W64) = mkMonadic (fsLit "negateDoubleX2#") doubleX2PrimTy -primOpInfo (VecNegOp FloatVec 8 W32) = mkMonadic (fsLit "negateFloatX8#") floatX8PrimTy -primOpInfo (VecNegOp FloatVec 4 W64) = mkMonadic (fsLit "negateDoubleX4#") doubleX4PrimTy -primOpInfo (VecNegOp FloatVec 16 W32) = mkMonadic (fsLit "negateFloatX16#") floatX16PrimTy -primOpInfo (VecNegOp FloatVec 8 W64) = mkMonadic (fsLit "negateDoubleX8#") doubleX8PrimTy -primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#") [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#") [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#") [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#") [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#") [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#") [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#") [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#") [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#") [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#") [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#") [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#") [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#") [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#") [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#") [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#") [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#") [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#") [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#") [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#") [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#") [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#") [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#") [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#") [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#") [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#") [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#") [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy) -primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) -primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#") [] [addrPrimTy, intPrimTy] (int8X16PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#") [] [addrPrimTy, intPrimTy] (int16X8PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#") [] [addrPrimTy, intPrimTy] (int32X4PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#") [] [addrPrimTy, intPrimTy] (int64X2PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#") [] [addrPrimTy, intPrimTy] (int8X32PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#") [] [addrPrimTy, intPrimTy] (int16X16PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#") [] [addrPrimTy, intPrimTy] (int32X8PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#") [] [addrPrimTy, intPrimTy] (int64X4PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#") [] [addrPrimTy, intPrimTy] (int8X64PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#") [] [addrPrimTy, intPrimTy] (int16X32PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#") [] [addrPrimTy, intPrimTy] (int32X16PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#") [] [addrPrimTy, intPrimTy] (int64X8PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#") [] [addrPrimTy, intPrimTy] (word8X16PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#") [] [addrPrimTy, intPrimTy] (word16X8PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#") [] [addrPrimTy, intPrimTy] (word32X4PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#") [] [addrPrimTy, intPrimTy] (word64X2PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#") [] [addrPrimTy, intPrimTy] (word8X32PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#") [] [addrPrimTy, intPrimTy] (word16X16PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#") [] [addrPrimTy, intPrimTy] (word32X8PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#") [] [addrPrimTy, intPrimTy] (word64X4PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#") [] [addrPrimTy, intPrimTy] (word8X64PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#") [] [addrPrimTy, intPrimTy] (word16X32PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#") [] [addrPrimTy, intPrimTy] (word32X16PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#") [] [addrPrimTy, intPrimTy] (word64X8PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#") [] [addrPrimTy, intPrimTy] (floatX4PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX2PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#") [] [addrPrimTy, intPrimTy] (floatX8PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX4PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#") [] [addrPrimTy, intPrimTy] (floatX16PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX8PrimTy) -primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) -primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#") [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#") [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#") [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#") [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#") [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#") [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#") [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#") [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#") [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#") [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#") [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#") [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#") [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#") [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#") [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#") [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#") [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#") [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#") [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#") [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#") [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#") [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#") [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#") [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#") [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#") [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#") [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#") [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#") [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#") [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy) -primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) -primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#") [] [addrPrimTy, intPrimTy] (int8X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#") [] [addrPrimTy, intPrimTy] (int16X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#") [] [addrPrimTy, intPrimTy] (int32X4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#") [] [addrPrimTy, intPrimTy] (int64X2PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#") [] [addrPrimTy, intPrimTy] (int8X32PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#") [] [addrPrimTy, intPrimTy] (int16X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#") [] [addrPrimTy, intPrimTy] (int32X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#") [] [addrPrimTy, intPrimTy] (int64X4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#") [] [addrPrimTy, intPrimTy] (int8X64PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#") [] [addrPrimTy, intPrimTy] (int16X32PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#") [] [addrPrimTy, intPrimTy] (int32X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#") [] [addrPrimTy, intPrimTy] (int64X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#") [] [addrPrimTy, intPrimTy] (word8X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#") [] [addrPrimTy, intPrimTy] (word16X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#") [] [addrPrimTy, intPrimTy] (word32X4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#") [] [addrPrimTy, intPrimTy] (word64X2PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#") [] [addrPrimTy, intPrimTy] (word8X32PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#") [] [addrPrimTy, intPrimTy] (word16X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#") [] [addrPrimTy, intPrimTy] (word32X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#") [] [addrPrimTy, intPrimTy] (word64X4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#") [] [addrPrimTy, intPrimTy] (word8X64PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#") [] [addrPrimTy, intPrimTy] (word16X32PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#") [] [addrPrimTy, intPrimTy] (word32X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#") [] [addrPrimTy, intPrimTy] (word64X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#") [] [addrPrimTy, intPrimTy] (floatX4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#") [] [addrPrimTy, intPrimTy] (doubleX2PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#") [] [addrPrimTy, intPrimTy] (floatX8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#") [] [addrPrimTy, intPrimTy] (doubleX4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#") [] [addrPrimTy, intPrimTy] (floatX16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#") [] [addrPrimTy, intPrimTy] (doubleX8PrimTy) -primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) -primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) diff --git a/autogen/primop-strictness.hs-incl b/autogen/primop-strictness.hs-incl deleted file mode 100644 --- a/autogen/primop-strictness.hs-incl +++ /dev/null @@ -1,22 +0,0 @@ -primOpStrictness CatchOp = \ _arity -> mkClosedStrictSig [ lazyApply1Dmd - , lazyApply2Dmd - , topDmd] topRes -primOpStrictness RaiseOp = \ _arity -> mkClosedStrictSig [topDmd] exnRes -primOpStrictness RaiseIOOp = \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnRes -primOpStrictness MaskAsyncExceptionsOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes -primOpStrictness MaskUninterruptibleOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes -primOpStrictness UnmaskAsyncExceptionsOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes -primOpStrictness AtomicallyOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes -primOpStrictness RetryOp = \ _arity -> mkClosedStrictSig [topDmd] exnRes -primOpStrictness CatchRetryOp = \ _arity -> mkClosedStrictSig [ catchArgDmd - , lazyApply1Dmd - , topDmd ] topRes -primOpStrictness CatchSTMOp = \ _arity -> mkClosedStrictSig [ lazyApply1Dmd - , lazyApply2Dmd - , topDmd ] topRes -primOpStrictness DataToTagOp = \ _arity -> mkClosedStrictSig [evalDmd] topRes -primOpStrictness PrefetchValueOp3 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes -primOpStrictness PrefetchValueOp2 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes -primOpStrictness PrefetchValueOp1 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes -primOpStrictness PrefetchValueOp0 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes -primOpStrictness _ = \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes diff --git a/autogen/primop-tag.hs-incl b/autogen/primop-tag.hs-incl deleted file mode 100644 --- a/autogen/primop-tag.hs-incl +++ /dev/null @@ -1,1072 +0,0 @@ -maxPrimOpTag :: Int -maxPrimOpTag = 1069 -primOpTag :: PrimOp -> Int -primOpTag CharGtOp = 1 -primOpTag CharGeOp = 2 -primOpTag CharEqOp = 3 -primOpTag CharNeOp = 4 -primOpTag CharLtOp = 5 -primOpTag CharLeOp = 6 -primOpTag OrdOp = 7 -primOpTag IntAddOp = 8 -primOpTag IntSubOp = 9 -primOpTag IntMulOp = 10 -primOpTag IntMulMayOfloOp = 11 -primOpTag IntQuotOp = 12 -primOpTag IntRemOp = 13 -primOpTag IntQuotRemOp = 14 -primOpTag AndIOp = 15 -primOpTag OrIOp = 16 -primOpTag XorIOp = 17 -primOpTag NotIOp = 18 -primOpTag IntNegOp = 19 -primOpTag IntAddCOp = 20 -primOpTag IntSubCOp = 21 -primOpTag IntGtOp = 22 -primOpTag IntGeOp = 23 -primOpTag IntEqOp = 24 -primOpTag IntNeOp = 25 -primOpTag IntLtOp = 26 -primOpTag IntLeOp = 27 -primOpTag ChrOp = 28 -primOpTag Int2WordOp = 29 -primOpTag Int2FloatOp = 30 -primOpTag Int2DoubleOp = 31 -primOpTag Word2FloatOp = 32 -primOpTag Word2DoubleOp = 33 -primOpTag ISllOp = 34 -primOpTag ISraOp = 35 -primOpTag ISrlOp = 36 -primOpTag WordAddOp = 37 -primOpTag WordSubCOp = 38 -primOpTag WordAdd2Op = 39 -primOpTag WordSubOp = 40 -primOpTag WordMulOp = 41 -primOpTag WordMul2Op = 42 -primOpTag WordQuotOp = 43 -primOpTag WordRemOp = 44 -primOpTag WordQuotRemOp = 45 -primOpTag WordQuotRem2Op = 46 -primOpTag AndOp = 47 -primOpTag OrOp = 48 -primOpTag XorOp = 49 -primOpTag NotOp = 50 -primOpTag SllOp = 51 -primOpTag SrlOp = 52 -primOpTag Word2IntOp = 53 -primOpTag WordGtOp = 54 -primOpTag WordGeOp = 55 -primOpTag WordEqOp = 56 -primOpTag WordNeOp = 57 -primOpTag WordLtOp = 58 -primOpTag WordLeOp = 59 -primOpTag PopCnt8Op = 60 -primOpTag PopCnt16Op = 61 -primOpTag PopCnt32Op = 62 -primOpTag PopCnt64Op = 63 -primOpTag PopCntOp = 64 -primOpTag Clz8Op = 65 -primOpTag Clz16Op = 66 -primOpTag Clz32Op = 67 -primOpTag Clz64Op = 68 -primOpTag ClzOp = 69 -primOpTag Ctz8Op = 70 -primOpTag Ctz16Op = 71 -primOpTag Ctz32Op = 72 -primOpTag Ctz64Op = 73 -primOpTag CtzOp = 74 -primOpTag BSwap16Op = 75 -primOpTag BSwap32Op = 76 -primOpTag BSwap64Op = 77 -primOpTag BSwapOp = 78 -primOpTag Narrow8IntOp = 79 -primOpTag Narrow16IntOp = 80 -primOpTag Narrow32IntOp = 81 -primOpTag Narrow8WordOp = 82 -primOpTag Narrow16WordOp = 83 -primOpTag Narrow32WordOp = 84 -primOpTag DoubleGtOp = 85 -primOpTag DoubleGeOp = 86 -primOpTag DoubleEqOp = 87 -primOpTag DoubleNeOp = 88 -primOpTag DoubleLtOp = 89 -primOpTag DoubleLeOp = 90 -primOpTag DoubleAddOp = 91 -primOpTag DoubleSubOp = 92 -primOpTag DoubleMulOp = 93 -primOpTag DoubleDivOp = 94 -primOpTag DoubleNegOp = 95 -primOpTag DoubleFabsOp = 96 -primOpTag Double2IntOp = 97 -primOpTag Double2FloatOp = 98 -primOpTag DoubleExpOp = 99 -primOpTag DoubleLogOp = 100 -primOpTag DoubleSqrtOp = 101 -primOpTag DoubleSinOp = 102 -primOpTag DoubleCosOp = 103 -primOpTag DoubleTanOp = 104 -primOpTag DoubleAsinOp = 105 -primOpTag DoubleAcosOp = 106 -primOpTag DoubleAtanOp = 107 -primOpTag DoubleSinhOp = 108 -primOpTag DoubleCoshOp = 109 -primOpTag DoubleTanhOp = 110 -primOpTag DoublePowerOp = 111 -primOpTag DoubleDecode_2IntOp = 112 -primOpTag DoubleDecode_Int64Op = 113 -primOpTag FloatGtOp = 114 -primOpTag FloatGeOp = 115 -primOpTag FloatEqOp = 116 -primOpTag FloatNeOp = 117 -primOpTag FloatLtOp = 118 -primOpTag FloatLeOp = 119 -primOpTag FloatAddOp = 120 -primOpTag FloatSubOp = 121 -primOpTag FloatMulOp = 122 -primOpTag FloatDivOp = 123 -primOpTag FloatNegOp = 124 -primOpTag FloatFabsOp = 125 -primOpTag Float2IntOp = 126 -primOpTag FloatExpOp = 127 -primOpTag FloatLogOp = 128 -primOpTag FloatSqrtOp = 129 -primOpTag FloatSinOp = 130 -primOpTag FloatCosOp = 131 -primOpTag FloatTanOp = 132 -primOpTag FloatAsinOp = 133 -primOpTag FloatAcosOp = 134 -primOpTag FloatAtanOp = 135 -primOpTag FloatSinhOp = 136 -primOpTag FloatCoshOp = 137 -primOpTag FloatTanhOp = 138 -primOpTag FloatPowerOp = 139 -primOpTag Float2DoubleOp = 140 -primOpTag FloatDecode_IntOp = 141 -primOpTag NewArrayOp = 142 -primOpTag SameMutableArrayOp = 143 -primOpTag ReadArrayOp = 144 -primOpTag WriteArrayOp = 145 -primOpTag SizeofArrayOp = 146 -primOpTag SizeofMutableArrayOp = 147 -primOpTag IndexArrayOp = 148 -primOpTag UnsafeFreezeArrayOp = 149 -primOpTag UnsafeThawArrayOp = 150 -primOpTag CopyArrayOp = 151 -primOpTag CopyMutableArrayOp = 152 -primOpTag CloneArrayOp = 153 -primOpTag CloneMutableArrayOp = 154 -primOpTag FreezeArrayOp = 155 -primOpTag ThawArrayOp = 156 -primOpTag CasArrayOp = 157 -primOpTag NewSmallArrayOp = 158 -primOpTag SameSmallMutableArrayOp = 159 -primOpTag ReadSmallArrayOp = 160 -primOpTag WriteSmallArrayOp = 161 -primOpTag SizeofSmallArrayOp = 162 -primOpTag SizeofSmallMutableArrayOp = 163 -primOpTag IndexSmallArrayOp = 164 -primOpTag UnsafeFreezeSmallArrayOp = 165 -primOpTag UnsafeThawSmallArrayOp = 166 -primOpTag CopySmallArrayOp = 167 -primOpTag CopySmallMutableArrayOp = 168 -primOpTag CloneSmallArrayOp = 169 -primOpTag CloneSmallMutableArrayOp = 170 -primOpTag FreezeSmallArrayOp = 171 -primOpTag ThawSmallArrayOp = 172 -primOpTag CasSmallArrayOp = 173 -primOpTag NewByteArrayOp_Char = 174 -primOpTag NewPinnedByteArrayOp_Char = 175 -primOpTag NewAlignedPinnedByteArrayOp_Char = 176 -primOpTag MutableByteArrayIsPinnedOp = 177 -primOpTag ByteArrayIsPinnedOp = 178 -primOpTag ByteArrayContents_Char = 179 -primOpTag SameMutableByteArrayOp = 180 -primOpTag ShrinkMutableByteArrayOp_Char = 181 -primOpTag ResizeMutableByteArrayOp_Char = 182 -primOpTag UnsafeFreezeByteArrayOp = 183 -primOpTag SizeofByteArrayOp = 184 -primOpTag SizeofMutableByteArrayOp = 185 -primOpTag GetSizeofMutableByteArrayOp = 186 -primOpTag IndexByteArrayOp_Char = 187 -primOpTag IndexByteArrayOp_WideChar = 188 -primOpTag IndexByteArrayOp_Int = 189 -primOpTag IndexByteArrayOp_Word = 190 -primOpTag IndexByteArrayOp_Addr = 191 -primOpTag IndexByteArrayOp_Float = 192 -primOpTag IndexByteArrayOp_Double = 193 -primOpTag IndexByteArrayOp_StablePtr = 194 -primOpTag IndexByteArrayOp_Int8 = 195 -primOpTag IndexByteArrayOp_Int16 = 196 -primOpTag IndexByteArrayOp_Int32 = 197 -primOpTag IndexByteArrayOp_Int64 = 198 -primOpTag IndexByteArrayOp_Word8 = 199 -primOpTag IndexByteArrayOp_Word16 = 200 -primOpTag IndexByteArrayOp_Word32 = 201 -primOpTag IndexByteArrayOp_Word64 = 202 -primOpTag ReadByteArrayOp_Char = 203 -primOpTag ReadByteArrayOp_WideChar = 204 -primOpTag ReadByteArrayOp_Int = 205 -primOpTag ReadByteArrayOp_Word = 206 -primOpTag ReadByteArrayOp_Addr = 207 -primOpTag ReadByteArrayOp_Float = 208 -primOpTag ReadByteArrayOp_Double = 209 -primOpTag ReadByteArrayOp_StablePtr = 210 -primOpTag ReadByteArrayOp_Int8 = 211 -primOpTag ReadByteArrayOp_Int16 = 212 -primOpTag ReadByteArrayOp_Int32 = 213 -primOpTag ReadByteArrayOp_Int64 = 214 -primOpTag ReadByteArrayOp_Word8 = 215 -primOpTag ReadByteArrayOp_Word16 = 216 -primOpTag ReadByteArrayOp_Word32 = 217 -primOpTag ReadByteArrayOp_Word64 = 218 -primOpTag WriteByteArrayOp_Char = 219 -primOpTag WriteByteArrayOp_WideChar = 220 -primOpTag WriteByteArrayOp_Int = 221 -primOpTag WriteByteArrayOp_Word = 222 -primOpTag WriteByteArrayOp_Addr = 223 -primOpTag WriteByteArrayOp_Float = 224 -primOpTag WriteByteArrayOp_Double = 225 -primOpTag WriteByteArrayOp_StablePtr = 226 -primOpTag WriteByteArrayOp_Int8 = 227 -primOpTag WriteByteArrayOp_Int16 = 228 -primOpTag WriteByteArrayOp_Int32 = 229 -primOpTag WriteByteArrayOp_Int64 = 230 -primOpTag WriteByteArrayOp_Word8 = 231 -primOpTag WriteByteArrayOp_Word16 = 232 -primOpTag WriteByteArrayOp_Word32 = 233 -primOpTag WriteByteArrayOp_Word64 = 234 -primOpTag CopyByteArrayOp = 235 -primOpTag CopyMutableByteArrayOp = 236 -primOpTag CopyByteArrayToAddrOp = 237 -primOpTag CopyMutableByteArrayToAddrOp = 238 -primOpTag CopyAddrToByteArrayOp = 239 -primOpTag SetByteArrayOp = 240 -primOpTag AtomicReadByteArrayOp_Int = 241 -primOpTag AtomicWriteByteArrayOp_Int = 242 -primOpTag CasByteArrayOp_Int = 243 -primOpTag FetchAddByteArrayOp_Int = 244 -primOpTag FetchSubByteArrayOp_Int = 245 -primOpTag FetchAndByteArrayOp_Int = 246 -primOpTag FetchNandByteArrayOp_Int = 247 -primOpTag FetchOrByteArrayOp_Int = 248 -primOpTag FetchXorByteArrayOp_Int = 249 -primOpTag NewArrayArrayOp = 250 -primOpTag SameMutableArrayArrayOp = 251 -primOpTag UnsafeFreezeArrayArrayOp = 252 -primOpTag SizeofArrayArrayOp = 253 -primOpTag SizeofMutableArrayArrayOp = 254 -primOpTag IndexArrayArrayOp_ByteArray = 255 -primOpTag IndexArrayArrayOp_ArrayArray = 256 -primOpTag ReadArrayArrayOp_ByteArray = 257 -primOpTag ReadArrayArrayOp_MutableByteArray = 258 -primOpTag ReadArrayArrayOp_ArrayArray = 259 -primOpTag ReadArrayArrayOp_MutableArrayArray = 260 -primOpTag WriteArrayArrayOp_ByteArray = 261 -primOpTag WriteArrayArrayOp_MutableByteArray = 262 -primOpTag WriteArrayArrayOp_ArrayArray = 263 -primOpTag WriteArrayArrayOp_MutableArrayArray = 264 -primOpTag CopyArrayArrayOp = 265 -primOpTag CopyMutableArrayArrayOp = 266 -primOpTag AddrAddOp = 267 -primOpTag AddrSubOp = 268 -primOpTag AddrRemOp = 269 -primOpTag Addr2IntOp = 270 -primOpTag Int2AddrOp = 271 -primOpTag AddrGtOp = 272 -primOpTag AddrGeOp = 273 -primOpTag AddrEqOp = 274 -primOpTag AddrNeOp = 275 -primOpTag AddrLtOp = 276 -primOpTag AddrLeOp = 277 -primOpTag IndexOffAddrOp_Char = 278 -primOpTag IndexOffAddrOp_WideChar = 279 -primOpTag IndexOffAddrOp_Int = 280 -primOpTag IndexOffAddrOp_Word = 281 -primOpTag IndexOffAddrOp_Addr = 282 -primOpTag IndexOffAddrOp_Float = 283 -primOpTag IndexOffAddrOp_Double = 284 -primOpTag IndexOffAddrOp_StablePtr = 285 -primOpTag IndexOffAddrOp_Int8 = 286 -primOpTag IndexOffAddrOp_Int16 = 287 -primOpTag IndexOffAddrOp_Int32 = 288 -primOpTag IndexOffAddrOp_Int64 = 289 -primOpTag IndexOffAddrOp_Word8 = 290 -primOpTag IndexOffAddrOp_Word16 = 291 -primOpTag IndexOffAddrOp_Word32 = 292 -primOpTag IndexOffAddrOp_Word64 = 293 -primOpTag ReadOffAddrOp_Char = 294 -primOpTag ReadOffAddrOp_WideChar = 295 -primOpTag ReadOffAddrOp_Int = 296 -primOpTag ReadOffAddrOp_Word = 297 -primOpTag ReadOffAddrOp_Addr = 298 -primOpTag ReadOffAddrOp_Float = 299 -primOpTag ReadOffAddrOp_Double = 300 -primOpTag ReadOffAddrOp_StablePtr = 301 -primOpTag ReadOffAddrOp_Int8 = 302 -primOpTag ReadOffAddrOp_Int16 = 303 -primOpTag ReadOffAddrOp_Int32 = 304 -primOpTag ReadOffAddrOp_Int64 = 305 -primOpTag ReadOffAddrOp_Word8 = 306 -primOpTag ReadOffAddrOp_Word16 = 307 -primOpTag ReadOffAddrOp_Word32 = 308 -primOpTag ReadOffAddrOp_Word64 = 309 -primOpTag WriteOffAddrOp_Char = 310 -primOpTag WriteOffAddrOp_WideChar = 311 -primOpTag WriteOffAddrOp_Int = 312 -primOpTag WriteOffAddrOp_Word = 313 -primOpTag WriteOffAddrOp_Addr = 314 -primOpTag WriteOffAddrOp_Float = 315 -primOpTag WriteOffAddrOp_Double = 316 -primOpTag WriteOffAddrOp_StablePtr = 317 -primOpTag WriteOffAddrOp_Int8 = 318 -primOpTag WriteOffAddrOp_Int16 = 319 -primOpTag WriteOffAddrOp_Int32 = 320 -primOpTag WriteOffAddrOp_Int64 = 321 -primOpTag WriteOffAddrOp_Word8 = 322 -primOpTag WriteOffAddrOp_Word16 = 323 -primOpTag WriteOffAddrOp_Word32 = 324 -primOpTag WriteOffAddrOp_Word64 = 325 -primOpTag NewMutVarOp = 326 -primOpTag ReadMutVarOp = 327 -primOpTag WriteMutVarOp = 328 -primOpTag SameMutVarOp = 329 -primOpTag AtomicModifyMutVarOp = 330 -primOpTag CasMutVarOp = 331 -primOpTag CatchOp = 332 -primOpTag RaiseOp = 333 -primOpTag RaiseIOOp = 334 -primOpTag MaskAsyncExceptionsOp = 335 -primOpTag MaskUninterruptibleOp = 336 -primOpTag UnmaskAsyncExceptionsOp = 337 -primOpTag MaskStatus = 338 -primOpTag AtomicallyOp = 339 -primOpTag RetryOp = 340 -primOpTag CatchRetryOp = 341 -primOpTag CatchSTMOp = 342 -primOpTag Check = 343 -primOpTag NewTVarOp = 344 -primOpTag ReadTVarOp = 345 -primOpTag ReadTVarIOOp = 346 -primOpTag WriteTVarOp = 347 -primOpTag SameTVarOp = 348 -primOpTag NewMVarOp = 349 -primOpTag TakeMVarOp = 350 -primOpTag TryTakeMVarOp = 351 -primOpTag PutMVarOp = 352 -primOpTag TryPutMVarOp = 353 -primOpTag ReadMVarOp = 354 -primOpTag TryReadMVarOp = 355 -primOpTag SameMVarOp = 356 -primOpTag IsEmptyMVarOp = 357 -primOpTag DelayOp = 358 -primOpTag WaitReadOp = 359 -primOpTag WaitWriteOp = 360 -primOpTag ForkOp = 361 -primOpTag ForkOnOp = 362 -primOpTag KillThreadOp = 363 -primOpTag YieldOp = 364 -primOpTag MyThreadIdOp = 365 -primOpTag LabelThreadOp = 366 -primOpTag IsCurrentThreadBoundOp = 367 -primOpTag NoDuplicateOp = 368 -primOpTag ThreadStatusOp = 369 -primOpTag MkWeakOp = 370 -primOpTag MkWeakNoFinalizerOp = 371 -primOpTag AddCFinalizerToWeakOp = 372 -primOpTag DeRefWeakOp = 373 -primOpTag FinalizeWeakOp = 374 -primOpTag TouchOp = 375 -primOpTag MakeStablePtrOp = 376 -primOpTag DeRefStablePtrOp = 377 -primOpTag EqStablePtrOp = 378 -primOpTag MakeStableNameOp = 379 -primOpTag EqStableNameOp = 380 -primOpTag StableNameToIntOp = 381 -primOpTag CompactNewOp = 382 -primOpTag CompactResizeOp = 383 -primOpTag CompactContainsOp = 384 -primOpTag CompactContainsAnyOp = 385 -primOpTag CompactGetFirstBlockOp = 386 -primOpTag CompactGetNextBlockOp = 387 -primOpTag CompactAllocateBlockOp = 388 -primOpTag CompactFixupPointersOp = 389 -primOpTag CompactAdd = 390 -primOpTag CompactAddWithSharing = 391 -primOpTag CompactSize = 392 -primOpTag ReallyUnsafePtrEqualityOp = 393 -primOpTag ParOp = 394 -primOpTag SparkOp = 395 -primOpTag SeqOp = 396 -primOpTag GetSparkOp = 397 -primOpTag NumSparks = 398 -primOpTag DataToTagOp = 399 -primOpTag TagToEnumOp = 400 -primOpTag AddrToAnyOp = 401 -primOpTag AnyToAddrOp = 402 -primOpTag MkApUpd0_Op = 403 -primOpTag NewBCOOp = 404 -primOpTag UnpackClosureOp = 405 -primOpTag GetApStackValOp = 406 -primOpTag GetCCSOfOp = 407 -primOpTag GetCurrentCCSOp = 408 -primOpTag ClearCCSOp = 409 -primOpTag TraceEventOp = 410 -primOpTag TraceMarkerOp = 411 -primOpTag (VecBroadcastOp IntVec 16 W8) = 412 -primOpTag (VecBroadcastOp IntVec 8 W16) = 413 -primOpTag (VecBroadcastOp IntVec 4 W32) = 414 -primOpTag (VecBroadcastOp IntVec 2 W64) = 415 -primOpTag (VecBroadcastOp IntVec 32 W8) = 416 -primOpTag (VecBroadcastOp IntVec 16 W16) = 417 -primOpTag (VecBroadcastOp IntVec 8 W32) = 418 -primOpTag (VecBroadcastOp IntVec 4 W64) = 419 -primOpTag (VecBroadcastOp IntVec 64 W8) = 420 -primOpTag (VecBroadcastOp IntVec 32 W16) = 421 -primOpTag (VecBroadcastOp IntVec 16 W32) = 422 -primOpTag (VecBroadcastOp IntVec 8 W64) = 423 -primOpTag (VecBroadcastOp WordVec 16 W8) = 424 -primOpTag (VecBroadcastOp WordVec 8 W16) = 425 -primOpTag (VecBroadcastOp WordVec 4 W32) = 426 -primOpTag (VecBroadcastOp WordVec 2 W64) = 427 -primOpTag (VecBroadcastOp WordVec 32 W8) = 428 -primOpTag (VecBroadcastOp WordVec 16 W16) = 429 -primOpTag (VecBroadcastOp WordVec 8 W32) = 430 -primOpTag (VecBroadcastOp WordVec 4 W64) = 431 -primOpTag (VecBroadcastOp WordVec 64 W8) = 432 -primOpTag (VecBroadcastOp WordVec 32 W16) = 433 -primOpTag (VecBroadcastOp WordVec 16 W32) = 434 -primOpTag (VecBroadcastOp WordVec 8 W64) = 435 -primOpTag (VecBroadcastOp FloatVec 4 W32) = 436 -primOpTag (VecBroadcastOp FloatVec 2 W64) = 437 -primOpTag (VecBroadcastOp FloatVec 8 W32) = 438 -primOpTag (VecBroadcastOp FloatVec 4 W64) = 439 -primOpTag (VecBroadcastOp FloatVec 16 W32) = 440 -primOpTag (VecBroadcastOp FloatVec 8 W64) = 441 -primOpTag (VecPackOp IntVec 16 W8) = 442 -primOpTag (VecPackOp IntVec 8 W16) = 443 -primOpTag (VecPackOp IntVec 4 W32) = 444 -primOpTag (VecPackOp IntVec 2 W64) = 445 -primOpTag (VecPackOp IntVec 32 W8) = 446 -primOpTag (VecPackOp IntVec 16 W16) = 447 -primOpTag (VecPackOp IntVec 8 W32) = 448 -primOpTag (VecPackOp IntVec 4 W64) = 449 -primOpTag (VecPackOp IntVec 64 W8) = 450 -primOpTag (VecPackOp IntVec 32 W16) = 451 -primOpTag (VecPackOp IntVec 16 W32) = 452 -primOpTag (VecPackOp IntVec 8 W64) = 453 -primOpTag (VecPackOp WordVec 16 W8) = 454 -primOpTag (VecPackOp WordVec 8 W16) = 455 -primOpTag (VecPackOp WordVec 4 W32) = 456 -primOpTag (VecPackOp WordVec 2 W64) = 457 -primOpTag (VecPackOp WordVec 32 W8) = 458 -primOpTag (VecPackOp WordVec 16 W16) = 459 -primOpTag (VecPackOp WordVec 8 W32) = 460 -primOpTag (VecPackOp WordVec 4 W64) = 461 -primOpTag (VecPackOp WordVec 64 W8) = 462 -primOpTag (VecPackOp WordVec 32 W16) = 463 -primOpTag (VecPackOp WordVec 16 W32) = 464 -primOpTag (VecPackOp WordVec 8 W64) = 465 -primOpTag (VecPackOp FloatVec 4 W32) = 466 -primOpTag (VecPackOp FloatVec 2 W64) = 467 -primOpTag (VecPackOp FloatVec 8 W32) = 468 -primOpTag (VecPackOp FloatVec 4 W64) = 469 -primOpTag (VecPackOp FloatVec 16 W32) = 470 -primOpTag (VecPackOp FloatVec 8 W64) = 471 -primOpTag (VecUnpackOp IntVec 16 W8) = 472 -primOpTag (VecUnpackOp IntVec 8 W16) = 473 -primOpTag (VecUnpackOp IntVec 4 W32) = 474 -primOpTag (VecUnpackOp IntVec 2 W64) = 475 -primOpTag (VecUnpackOp IntVec 32 W8) = 476 -primOpTag (VecUnpackOp IntVec 16 W16) = 477 -primOpTag (VecUnpackOp IntVec 8 W32) = 478 -primOpTag (VecUnpackOp IntVec 4 W64) = 479 -primOpTag (VecUnpackOp IntVec 64 W8) = 480 -primOpTag (VecUnpackOp IntVec 32 W16) = 481 -primOpTag (VecUnpackOp IntVec 16 W32) = 482 -primOpTag (VecUnpackOp IntVec 8 W64) = 483 -primOpTag (VecUnpackOp WordVec 16 W8) = 484 -primOpTag (VecUnpackOp WordVec 8 W16) = 485 -primOpTag (VecUnpackOp WordVec 4 W32) = 486 -primOpTag (VecUnpackOp WordVec 2 W64) = 487 -primOpTag (VecUnpackOp WordVec 32 W8) = 488 -primOpTag (VecUnpackOp WordVec 16 W16) = 489 -primOpTag (VecUnpackOp WordVec 8 W32) = 490 -primOpTag (VecUnpackOp WordVec 4 W64) = 491 -primOpTag (VecUnpackOp WordVec 64 W8) = 492 -primOpTag (VecUnpackOp WordVec 32 W16) = 493 -primOpTag (VecUnpackOp WordVec 16 W32) = 494 -primOpTag (VecUnpackOp WordVec 8 W64) = 495 -primOpTag (VecUnpackOp FloatVec 4 W32) = 496 -primOpTag (VecUnpackOp FloatVec 2 W64) = 497 -primOpTag (VecUnpackOp FloatVec 8 W32) = 498 -primOpTag (VecUnpackOp FloatVec 4 W64) = 499 -primOpTag (VecUnpackOp FloatVec 16 W32) = 500 -primOpTag (VecUnpackOp FloatVec 8 W64) = 501 -primOpTag (VecInsertOp IntVec 16 W8) = 502 -primOpTag (VecInsertOp IntVec 8 W16) = 503 -primOpTag (VecInsertOp IntVec 4 W32) = 504 -primOpTag (VecInsertOp IntVec 2 W64) = 505 -primOpTag (VecInsertOp IntVec 32 W8) = 506 -primOpTag (VecInsertOp IntVec 16 W16) = 507 -primOpTag (VecInsertOp IntVec 8 W32) = 508 -primOpTag (VecInsertOp IntVec 4 W64) = 509 -primOpTag (VecInsertOp IntVec 64 W8) = 510 -primOpTag (VecInsertOp IntVec 32 W16) = 511 -primOpTag (VecInsertOp IntVec 16 W32) = 512 -primOpTag (VecInsertOp IntVec 8 W64) = 513 -primOpTag (VecInsertOp WordVec 16 W8) = 514 -primOpTag (VecInsertOp WordVec 8 W16) = 515 -primOpTag (VecInsertOp WordVec 4 W32) = 516 -primOpTag (VecInsertOp WordVec 2 W64) = 517 -primOpTag (VecInsertOp WordVec 32 W8) = 518 -primOpTag (VecInsertOp WordVec 16 W16) = 519 -primOpTag (VecInsertOp WordVec 8 W32) = 520 -primOpTag (VecInsertOp WordVec 4 W64) = 521 -primOpTag (VecInsertOp WordVec 64 W8) = 522 -primOpTag (VecInsertOp WordVec 32 W16) = 523 -primOpTag (VecInsertOp WordVec 16 W32) = 524 -primOpTag (VecInsertOp WordVec 8 W64) = 525 -primOpTag (VecInsertOp FloatVec 4 W32) = 526 -primOpTag (VecInsertOp FloatVec 2 W64) = 527 -primOpTag (VecInsertOp FloatVec 8 W32) = 528 -primOpTag (VecInsertOp FloatVec 4 W64) = 529 -primOpTag (VecInsertOp FloatVec 16 W32) = 530 -primOpTag (VecInsertOp FloatVec 8 W64) = 531 -primOpTag (VecAddOp IntVec 16 W8) = 532 -primOpTag (VecAddOp IntVec 8 W16) = 533 -primOpTag (VecAddOp IntVec 4 W32) = 534 -primOpTag (VecAddOp IntVec 2 W64) = 535 -primOpTag (VecAddOp IntVec 32 W8) = 536 -primOpTag (VecAddOp IntVec 16 W16) = 537 -primOpTag (VecAddOp IntVec 8 W32) = 538 -primOpTag (VecAddOp IntVec 4 W64) = 539 -primOpTag (VecAddOp IntVec 64 W8) = 540 -primOpTag (VecAddOp IntVec 32 W16) = 541 -primOpTag (VecAddOp IntVec 16 W32) = 542 -primOpTag (VecAddOp IntVec 8 W64) = 543 -primOpTag (VecAddOp WordVec 16 W8) = 544 -primOpTag (VecAddOp WordVec 8 W16) = 545 -primOpTag (VecAddOp WordVec 4 W32) = 546 -primOpTag (VecAddOp WordVec 2 W64) = 547 -primOpTag (VecAddOp WordVec 32 W8) = 548 -primOpTag (VecAddOp WordVec 16 W16) = 549 -primOpTag (VecAddOp WordVec 8 W32) = 550 -primOpTag (VecAddOp WordVec 4 W64) = 551 -primOpTag (VecAddOp WordVec 64 W8) = 552 -primOpTag (VecAddOp WordVec 32 W16) = 553 -primOpTag (VecAddOp WordVec 16 W32) = 554 -primOpTag (VecAddOp WordVec 8 W64) = 555 -primOpTag (VecAddOp FloatVec 4 W32) = 556 -primOpTag (VecAddOp FloatVec 2 W64) = 557 -primOpTag (VecAddOp FloatVec 8 W32) = 558 -primOpTag (VecAddOp FloatVec 4 W64) = 559 -primOpTag (VecAddOp FloatVec 16 W32) = 560 -primOpTag (VecAddOp FloatVec 8 W64) = 561 -primOpTag (VecSubOp IntVec 16 W8) = 562 -primOpTag (VecSubOp IntVec 8 W16) = 563 -primOpTag (VecSubOp IntVec 4 W32) = 564 -primOpTag (VecSubOp IntVec 2 W64) = 565 -primOpTag (VecSubOp IntVec 32 W8) = 566 -primOpTag (VecSubOp IntVec 16 W16) = 567 -primOpTag (VecSubOp IntVec 8 W32) = 568 -primOpTag (VecSubOp IntVec 4 W64) = 569 -primOpTag (VecSubOp IntVec 64 W8) = 570 -primOpTag (VecSubOp IntVec 32 W16) = 571 -primOpTag (VecSubOp IntVec 16 W32) = 572 -primOpTag (VecSubOp IntVec 8 W64) = 573 -primOpTag (VecSubOp WordVec 16 W8) = 574 -primOpTag (VecSubOp WordVec 8 W16) = 575 -primOpTag (VecSubOp WordVec 4 W32) = 576 -primOpTag (VecSubOp WordVec 2 W64) = 577 -primOpTag (VecSubOp WordVec 32 W8) = 578 -primOpTag (VecSubOp WordVec 16 W16) = 579 -primOpTag (VecSubOp WordVec 8 W32) = 580 -primOpTag (VecSubOp WordVec 4 W64) = 581 -primOpTag (VecSubOp WordVec 64 W8) = 582 -primOpTag (VecSubOp WordVec 32 W16) = 583 -primOpTag (VecSubOp WordVec 16 W32) = 584 -primOpTag (VecSubOp WordVec 8 W64) = 585 -primOpTag (VecSubOp FloatVec 4 W32) = 586 -primOpTag (VecSubOp FloatVec 2 W64) = 587 -primOpTag (VecSubOp FloatVec 8 W32) = 588 -primOpTag (VecSubOp FloatVec 4 W64) = 589 -primOpTag (VecSubOp FloatVec 16 W32) = 590 -primOpTag (VecSubOp FloatVec 8 W64) = 591 -primOpTag (VecMulOp IntVec 16 W8) = 592 -primOpTag (VecMulOp IntVec 8 W16) = 593 -primOpTag (VecMulOp IntVec 4 W32) = 594 -primOpTag (VecMulOp IntVec 2 W64) = 595 -primOpTag (VecMulOp IntVec 32 W8) = 596 -primOpTag (VecMulOp IntVec 16 W16) = 597 -primOpTag (VecMulOp IntVec 8 W32) = 598 -primOpTag (VecMulOp IntVec 4 W64) = 599 -primOpTag (VecMulOp IntVec 64 W8) = 600 -primOpTag (VecMulOp IntVec 32 W16) = 601 -primOpTag (VecMulOp IntVec 16 W32) = 602 -primOpTag (VecMulOp IntVec 8 W64) = 603 -primOpTag (VecMulOp WordVec 16 W8) = 604 -primOpTag (VecMulOp WordVec 8 W16) = 605 -primOpTag (VecMulOp WordVec 4 W32) = 606 -primOpTag (VecMulOp WordVec 2 W64) = 607 -primOpTag (VecMulOp WordVec 32 W8) = 608 -primOpTag (VecMulOp WordVec 16 W16) = 609 -primOpTag (VecMulOp WordVec 8 W32) = 610 -primOpTag (VecMulOp WordVec 4 W64) = 611 -primOpTag (VecMulOp WordVec 64 W8) = 612 -primOpTag (VecMulOp WordVec 32 W16) = 613 -primOpTag (VecMulOp WordVec 16 W32) = 614 -primOpTag (VecMulOp WordVec 8 W64) = 615 -primOpTag (VecMulOp FloatVec 4 W32) = 616 -primOpTag (VecMulOp FloatVec 2 W64) = 617 -primOpTag (VecMulOp FloatVec 8 W32) = 618 -primOpTag (VecMulOp FloatVec 4 W64) = 619 -primOpTag (VecMulOp FloatVec 16 W32) = 620 -primOpTag (VecMulOp FloatVec 8 W64) = 621 -primOpTag (VecDivOp FloatVec 4 W32) = 622 -primOpTag (VecDivOp FloatVec 2 W64) = 623 -primOpTag (VecDivOp FloatVec 8 W32) = 624 -primOpTag (VecDivOp FloatVec 4 W64) = 625 -primOpTag (VecDivOp FloatVec 16 W32) = 626 -primOpTag (VecDivOp FloatVec 8 W64) = 627 -primOpTag (VecQuotOp IntVec 16 W8) = 628 -primOpTag (VecQuotOp IntVec 8 W16) = 629 -primOpTag (VecQuotOp IntVec 4 W32) = 630 -primOpTag (VecQuotOp IntVec 2 W64) = 631 -primOpTag (VecQuotOp IntVec 32 W8) = 632 -primOpTag (VecQuotOp IntVec 16 W16) = 633 -primOpTag (VecQuotOp IntVec 8 W32) = 634 -primOpTag (VecQuotOp IntVec 4 W64) = 635 -primOpTag (VecQuotOp IntVec 64 W8) = 636 -primOpTag (VecQuotOp IntVec 32 W16) = 637 -primOpTag (VecQuotOp IntVec 16 W32) = 638 -primOpTag (VecQuotOp IntVec 8 W64) = 639 -primOpTag (VecQuotOp WordVec 16 W8) = 640 -primOpTag (VecQuotOp WordVec 8 W16) = 641 -primOpTag (VecQuotOp WordVec 4 W32) = 642 -primOpTag (VecQuotOp WordVec 2 W64) = 643 -primOpTag (VecQuotOp WordVec 32 W8) = 644 -primOpTag (VecQuotOp WordVec 16 W16) = 645 -primOpTag (VecQuotOp WordVec 8 W32) = 646 -primOpTag (VecQuotOp WordVec 4 W64) = 647 -primOpTag (VecQuotOp WordVec 64 W8) = 648 -primOpTag (VecQuotOp WordVec 32 W16) = 649 -primOpTag (VecQuotOp WordVec 16 W32) = 650 -primOpTag (VecQuotOp WordVec 8 W64) = 651 -primOpTag (VecRemOp IntVec 16 W8) = 652 -primOpTag (VecRemOp IntVec 8 W16) = 653 -primOpTag (VecRemOp IntVec 4 W32) = 654 -primOpTag (VecRemOp IntVec 2 W64) = 655 -primOpTag (VecRemOp IntVec 32 W8) = 656 -primOpTag (VecRemOp IntVec 16 W16) = 657 -primOpTag (VecRemOp IntVec 8 W32) = 658 -primOpTag (VecRemOp IntVec 4 W64) = 659 -primOpTag (VecRemOp IntVec 64 W8) = 660 -primOpTag (VecRemOp IntVec 32 W16) = 661 -primOpTag (VecRemOp IntVec 16 W32) = 662 -primOpTag (VecRemOp IntVec 8 W64) = 663 -primOpTag (VecRemOp WordVec 16 W8) = 664 -primOpTag (VecRemOp WordVec 8 W16) = 665 -primOpTag (VecRemOp WordVec 4 W32) = 666 -primOpTag (VecRemOp WordVec 2 W64) = 667 -primOpTag (VecRemOp WordVec 32 W8) = 668 -primOpTag (VecRemOp WordVec 16 W16) = 669 -primOpTag (VecRemOp WordVec 8 W32) = 670 -primOpTag (VecRemOp WordVec 4 W64) = 671 -primOpTag (VecRemOp WordVec 64 W8) = 672 -primOpTag (VecRemOp WordVec 32 W16) = 673 -primOpTag (VecRemOp WordVec 16 W32) = 674 -primOpTag (VecRemOp WordVec 8 W64) = 675 -primOpTag (VecNegOp IntVec 16 W8) = 676 -primOpTag (VecNegOp IntVec 8 W16) = 677 -primOpTag (VecNegOp IntVec 4 W32) = 678 -primOpTag (VecNegOp IntVec 2 W64) = 679 -primOpTag (VecNegOp IntVec 32 W8) = 680 -primOpTag (VecNegOp IntVec 16 W16) = 681 -primOpTag (VecNegOp IntVec 8 W32) = 682 -primOpTag (VecNegOp IntVec 4 W64) = 683 -primOpTag (VecNegOp IntVec 64 W8) = 684 -primOpTag (VecNegOp IntVec 32 W16) = 685 -primOpTag (VecNegOp IntVec 16 W32) = 686 -primOpTag (VecNegOp IntVec 8 W64) = 687 -primOpTag (VecNegOp FloatVec 4 W32) = 688 -primOpTag (VecNegOp FloatVec 2 W64) = 689 -primOpTag (VecNegOp FloatVec 8 W32) = 690 -primOpTag (VecNegOp FloatVec 4 W64) = 691 -primOpTag (VecNegOp FloatVec 16 W32) = 692 -primOpTag (VecNegOp FloatVec 8 W64) = 693 -primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 694 -primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 695 -primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 696 -primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 697 -primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 698 -primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 699 -primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 700 -primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 701 -primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 702 -primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 703 -primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 704 -primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 705 -primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 706 -primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 707 -primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 708 -primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 709 -primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 710 -primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 711 -primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 712 -primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 713 -primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 714 -primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 715 -primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 716 -primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 717 -primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 718 -primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 719 -primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 720 -primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 721 -primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 722 -primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 723 -primOpTag (VecReadByteArrayOp IntVec 16 W8) = 724 -primOpTag (VecReadByteArrayOp IntVec 8 W16) = 725 -primOpTag (VecReadByteArrayOp IntVec 4 W32) = 726 -primOpTag (VecReadByteArrayOp IntVec 2 W64) = 727 -primOpTag (VecReadByteArrayOp IntVec 32 W8) = 728 -primOpTag (VecReadByteArrayOp IntVec 16 W16) = 729 -primOpTag (VecReadByteArrayOp IntVec 8 W32) = 730 -primOpTag (VecReadByteArrayOp IntVec 4 W64) = 731 -primOpTag (VecReadByteArrayOp IntVec 64 W8) = 732 -primOpTag (VecReadByteArrayOp IntVec 32 W16) = 733 -primOpTag (VecReadByteArrayOp IntVec 16 W32) = 734 -primOpTag (VecReadByteArrayOp IntVec 8 W64) = 735 -primOpTag (VecReadByteArrayOp WordVec 16 W8) = 736 -primOpTag (VecReadByteArrayOp WordVec 8 W16) = 737 -primOpTag (VecReadByteArrayOp WordVec 4 W32) = 738 -primOpTag (VecReadByteArrayOp WordVec 2 W64) = 739 -primOpTag (VecReadByteArrayOp WordVec 32 W8) = 740 -primOpTag (VecReadByteArrayOp WordVec 16 W16) = 741 -primOpTag (VecReadByteArrayOp WordVec 8 W32) = 742 -primOpTag (VecReadByteArrayOp WordVec 4 W64) = 743 -primOpTag (VecReadByteArrayOp WordVec 64 W8) = 744 -primOpTag (VecReadByteArrayOp WordVec 32 W16) = 745 -primOpTag (VecReadByteArrayOp WordVec 16 W32) = 746 -primOpTag (VecReadByteArrayOp WordVec 8 W64) = 747 -primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 748 -primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 749 -primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 750 -primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 751 -primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 752 -primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 753 -primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 754 -primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 755 -primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 756 -primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 757 -primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 758 -primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 759 -primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 760 -primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 761 -primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 762 -primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 763 -primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 764 -primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 765 -primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 766 -primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 767 -primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 768 -primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 769 -primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 770 -primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 771 -primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 772 -primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 773 -primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 774 -primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 775 -primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 776 -primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 777 -primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 778 -primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 779 -primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 780 -primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 781 -primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 782 -primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 783 -primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 784 -primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 785 -primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 786 -primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 787 -primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 788 -primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 789 -primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 790 -primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 791 -primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 792 -primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 793 -primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 794 -primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 795 -primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 796 -primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 797 -primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 798 -primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 799 -primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 800 -primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 801 -primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 802 -primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 803 -primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 804 -primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 805 -primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 806 -primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 807 -primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 808 -primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 809 -primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 810 -primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 811 -primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 812 -primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 813 -primOpTag (VecReadOffAddrOp IntVec 16 W8) = 814 -primOpTag (VecReadOffAddrOp IntVec 8 W16) = 815 -primOpTag (VecReadOffAddrOp IntVec 4 W32) = 816 -primOpTag (VecReadOffAddrOp IntVec 2 W64) = 817 -primOpTag (VecReadOffAddrOp IntVec 32 W8) = 818 -primOpTag (VecReadOffAddrOp IntVec 16 W16) = 819 -primOpTag (VecReadOffAddrOp IntVec 8 W32) = 820 -primOpTag (VecReadOffAddrOp IntVec 4 W64) = 821 -primOpTag (VecReadOffAddrOp IntVec 64 W8) = 822 -primOpTag (VecReadOffAddrOp IntVec 32 W16) = 823 -primOpTag (VecReadOffAddrOp IntVec 16 W32) = 824 -primOpTag (VecReadOffAddrOp IntVec 8 W64) = 825 -primOpTag (VecReadOffAddrOp WordVec 16 W8) = 826 -primOpTag (VecReadOffAddrOp WordVec 8 W16) = 827 -primOpTag (VecReadOffAddrOp WordVec 4 W32) = 828 -primOpTag (VecReadOffAddrOp WordVec 2 W64) = 829 -primOpTag (VecReadOffAddrOp WordVec 32 W8) = 830 -primOpTag (VecReadOffAddrOp WordVec 16 W16) = 831 -primOpTag (VecReadOffAddrOp WordVec 8 W32) = 832 -primOpTag (VecReadOffAddrOp WordVec 4 W64) = 833 -primOpTag (VecReadOffAddrOp WordVec 64 W8) = 834 -primOpTag (VecReadOffAddrOp WordVec 32 W16) = 835 -primOpTag (VecReadOffAddrOp WordVec 16 W32) = 836 -primOpTag (VecReadOffAddrOp WordVec 8 W64) = 837 -primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 838 -primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 839 -primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 840 -primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 841 -primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 842 -primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 843 -primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 844 -primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 845 -primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 846 -primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 847 -primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 848 -primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 849 -primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 850 -primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 851 -primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 852 -primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 853 -primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 854 -primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 855 -primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 856 -primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 857 -primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 858 -primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 859 -primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 860 -primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 861 -primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 862 -primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 863 -primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 864 -primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 865 -primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 866 -primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 867 -primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 868 -primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 869 -primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 870 -primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 871 -primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 872 -primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 873 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 874 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 875 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 876 -primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 877 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 878 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 879 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 880 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 881 -primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 882 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 883 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 884 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 885 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 886 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 887 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 888 -primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 889 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 890 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 891 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 892 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 893 -primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 894 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 895 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 896 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 897 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 898 -primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 899 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 900 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 901 -primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 902 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 903 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 904 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 905 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 906 -primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 907 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 908 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 909 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 910 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 911 -primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 912 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 913 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 914 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 915 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 916 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 917 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 918 -primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 919 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 920 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 921 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 922 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 923 -primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 924 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 925 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 926 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 927 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 928 -primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 929 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 930 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 931 -primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 932 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 933 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 934 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 935 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 936 -primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 937 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 938 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 939 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 940 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 941 -primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 942 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 943 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 944 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 945 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 946 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 947 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 948 -primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 949 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 950 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 951 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 952 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 953 -primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 954 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 955 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 956 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 957 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 958 -primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 959 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 960 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 961 -primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 962 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 963 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 964 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 965 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 966 -primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 967 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 968 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 969 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 970 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 971 -primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 972 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 973 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 974 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 975 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 976 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 977 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 978 -primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 979 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 980 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 981 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 982 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 983 -primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 984 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 985 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 986 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 987 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 988 -primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 989 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 990 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 991 -primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 992 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 993 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 994 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 995 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 996 -primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 997 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 998 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 999 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1000 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1001 -primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1002 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1003 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1004 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1005 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1006 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1007 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1008 -primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1009 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1010 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1011 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1012 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1013 -primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1014 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1015 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1016 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1017 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1018 -primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1019 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1020 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1021 -primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1022 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1023 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1024 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1025 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1026 -primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1027 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1028 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1029 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1030 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1031 -primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1032 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1033 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1034 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1035 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1036 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1037 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1038 -primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1039 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1040 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1041 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1042 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1043 -primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1044 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1045 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1046 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1047 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1048 -primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1049 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1050 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1051 -primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1052 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1053 -primOpTag PrefetchByteArrayOp3 = 1054 -primOpTag PrefetchMutableByteArrayOp3 = 1055 -primOpTag PrefetchAddrOp3 = 1056 -primOpTag PrefetchValueOp3 = 1057 -primOpTag PrefetchByteArrayOp2 = 1058 -primOpTag PrefetchMutableByteArrayOp2 = 1059 -primOpTag PrefetchAddrOp2 = 1060 -primOpTag PrefetchValueOp2 = 1061 -primOpTag PrefetchByteArrayOp1 = 1062 -primOpTag PrefetchMutableByteArrayOp1 = 1063 -primOpTag PrefetchAddrOp1 = 1064 -primOpTag PrefetchValueOp1 = 1065 -primOpTag PrefetchByteArrayOp0 = 1066 -primOpTag PrefetchMutableByteArrayOp0 = 1067 -primOpTag PrefetchAddrOp0 = 1068 -primOpTag PrefetchValueOp0 = 1069 diff --git a/autogen/primop-vector-tycons.hs-incl b/autogen/primop-vector-tycons.hs-incl deleted file mode 100644 --- a/autogen/primop-vector-tycons.hs-incl +++ /dev/null @@ -1,30 +0,0 @@ - , int8X16PrimTyCon - , int16X8PrimTyCon - , int32X4PrimTyCon - , int64X2PrimTyCon - , int8X32PrimTyCon - , int16X16PrimTyCon - , int32X8PrimTyCon - , int64X4PrimTyCon - , int8X64PrimTyCon - , int16X32PrimTyCon - , int32X16PrimTyCon - , int64X8PrimTyCon - , word8X16PrimTyCon - , word16X8PrimTyCon - , word32X4PrimTyCon - , word64X2PrimTyCon - , word8X32PrimTyCon - , word16X16PrimTyCon - , word32X8PrimTyCon - , word64X4PrimTyCon - , word8X64PrimTyCon - , word16X32PrimTyCon - , word32X16PrimTyCon - , word64X8PrimTyCon - , floatX4PrimTyCon - , doubleX2PrimTyCon - , floatX8PrimTyCon - , doubleX4PrimTyCon - , floatX16PrimTyCon - , doubleX8PrimTyCon diff --git a/autogen/primop-vector-tys-exports.hs-incl b/autogen/primop-vector-tys-exports.hs-incl deleted file mode 100644 --- a/autogen/primop-vector-tys-exports.hs-incl +++ /dev/null @@ -1,30 +0,0 @@ - int8X16PrimTy, int8X16PrimTyCon, - int16X8PrimTy, int16X8PrimTyCon, - int32X4PrimTy, int32X4PrimTyCon, - int64X2PrimTy, int64X2PrimTyCon, - int8X32PrimTy, int8X32PrimTyCon, - int16X16PrimTy, int16X16PrimTyCon, - int32X8PrimTy, int32X8PrimTyCon, - int64X4PrimTy, int64X4PrimTyCon, - int8X64PrimTy, int8X64PrimTyCon, - int16X32PrimTy, int16X32PrimTyCon, - int32X16PrimTy, int32X16PrimTyCon, - int64X8PrimTy, int64X8PrimTyCon, - word8X16PrimTy, word8X16PrimTyCon, - word16X8PrimTy, word16X8PrimTyCon, - word32X4PrimTy, word32X4PrimTyCon, - word64X2PrimTy, word64X2PrimTyCon, - word8X32PrimTy, word8X32PrimTyCon, - word16X16PrimTy, word16X16PrimTyCon, - word32X8PrimTy, word32X8PrimTyCon, - word64X4PrimTy, word64X4PrimTyCon, - word8X64PrimTy, word8X64PrimTyCon, - word16X32PrimTy, word16X32PrimTyCon, - word32X16PrimTy, word32X16PrimTyCon, - word64X8PrimTy, word64X8PrimTyCon, - floatX4PrimTy, floatX4PrimTyCon, - doubleX2PrimTy, doubleX2PrimTyCon, - floatX8PrimTy, floatX8PrimTyCon, - doubleX4PrimTy, doubleX4PrimTyCon, - floatX16PrimTy, floatX16PrimTyCon, - doubleX8PrimTy, doubleX8PrimTyCon, diff --git a/autogen/primop-vector-tys.hs-incl b/autogen/primop-vector-tys.hs-incl deleted file mode 100644 --- a/autogen/primop-vector-tys.hs-incl +++ /dev/null @@ -1,180 +0,0 @@ -int8X16PrimTyConName :: Name -int8X16PrimTyConName = mkPrimTc (fsLit "Int8X16#") int8X16PrimTyConKey int8X16PrimTyCon -int8X16PrimTy :: Type -int8X16PrimTy = mkTyConTy int8X16PrimTyCon -int8X16PrimTyCon :: TyCon -int8X16PrimTyCon = pcPrimTyCon0 int8X16PrimTyConName (VecRep 16 Int8ElemRep) -int16X8PrimTyConName :: Name -int16X8PrimTyConName = mkPrimTc (fsLit "Int16X8#") int16X8PrimTyConKey int16X8PrimTyCon -int16X8PrimTy :: Type -int16X8PrimTy = mkTyConTy int16X8PrimTyCon -int16X8PrimTyCon :: TyCon -int16X8PrimTyCon = pcPrimTyCon0 int16X8PrimTyConName (VecRep 8 Int16ElemRep) -int32X4PrimTyConName :: Name -int32X4PrimTyConName = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon -int32X4PrimTy :: Type -int32X4PrimTy = mkTyConTy int32X4PrimTyCon -int32X4PrimTyCon :: TyCon -int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (VecRep 4 Int32ElemRep) -int64X2PrimTyConName :: Name -int64X2PrimTyConName = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon -int64X2PrimTy :: Type -int64X2PrimTy = mkTyConTy int64X2PrimTyCon -int64X2PrimTyCon :: TyCon -int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (VecRep 2 Int64ElemRep) -int8X32PrimTyConName :: Name -int8X32PrimTyConName = mkPrimTc (fsLit "Int8X32#") int8X32PrimTyConKey int8X32PrimTyCon -int8X32PrimTy :: Type -int8X32PrimTy = mkTyConTy int8X32PrimTyCon -int8X32PrimTyCon :: TyCon -int8X32PrimTyCon = pcPrimTyCon0 int8X32PrimTyConName (VecRep 32 Int8ElemRep) -int16X16PrimTyConName :: Name -int16X16PrimTyConName = mkPrimTc (fsLit "Int16X16#") int16X16PrimTyConKey int16X16PrimTyCon -int16X16PrimTy :: Type -int16X16PrimTy = mkTyConTy int16X16PrimTyCon -int16X16PrimTyCon :: TyCon -int16X16PrimTyCon = pcPrimTyCon0 int16X16PrimTyConName (VecRep 16 Int16ElemRep) -int32X8PrimTyConName :: Name -int32X8PrimTyConName = mkPrimTc (fsLit "Int32X8#") int32X8PrimTyConKey int32X8PrimTyCon -int32X8PrimTy :: Type -int32X8PrimTy = mkTyConTy int32X8PrimTyCon -int32X8PrimTyCon :: TyCon -int32X8PrimTyCon = pcPrimTyCon0 int32X8PrimTyConName (VecRep 8 Int32ElemRep) -int64X4PrimTyConName :: Name -int64X4PrimTyConName = mkPrimTc (fsLit "Int64X4#") int64X4PrimTyConKey int64X4PrimTyCon -int64X4PrimTy :: Type -int64X4PrimTy = mkTyConTy int64X4PrimTyCon -int64X4PrimTyCon :: TyCon -int64X4PrimTyCon = pcPrimTyCon0 int64X4PrimTyConName (VecRep 4 Int64ElemRep) -int8X64PrimTyConName :: Name -int8X64PrimTyConName = mkPrimTc (fsLit "Int8X64#") int8X64PrimTyConKey int8X64PrimTyCon -int8X64PrimTy :: Type -int8X64PrimTy = mkTyConTy int8X64PrimTyCon -int8X64PrimTyCon :: TyCon -int8X64PrimTyCon = pcPrimTyCon0 int8X64PrimTyConName (VecRep 64 Int8ElemRep) -int16X32PrimTyConName :: Name -int16X32PrimTyConName = mkPrimTc (fsLit "Int16X32#") int16X32PrimTyConKey int16X32PrimTyCon -int16X32PrimTy :: Type -int16X32PrimTy = mkTyConTy int16X32PrimTyCon -int16X32PrimTyCon :: TyCon -int16X32PrimTyCon = pcPrimTyCon0 int16X32PrimTyConName (VecRep 32 Int16ElemRep) -int32X16PrimTyConName :: Name -int32X16PrimTyConName = mkPrimTc (fsLit "Int32X16#") int32X16PrimTyConKey int32X16PrimTyCon -int32X16PrimTy :: Type -int32X16PrimTy = mkTyConTy int32X16PrimTyCon -int32X16PrimTyCon :: TyCon -int32X16PrimTyCon = pcPrimTyCon0 int32X16PrimTyConName (VecRep 16 Int32ElemRep) -int64X8PrimTyConName :: Name -int64X8PrimTyConName = mkPrimTc (fsLit "Int64X8#") int64X8PrimTyConKey int64X8PrimTyCon -int64X8PrimTy :: Type -int64X8PrimTy = mkTyConTy int64X8PrimTyCon -int64X8PrimTyCon :: TyCon -int64X8PrimTyCon = pcPrimTyCon0 int64X8PrimTyConName (VecRep 8 Int64ElemRep) -word8X16PrimTyConName :: Name -word8X16PrimTyConName = mkPrimTc (fsLit "Word8X16#") word8X16PrimTyConKey word8X16PrimTyCon -word8X16PrimTy :: Type -word8X16PrimTy = mkTyConTy word8X16PrimTyCon -word8X16PrimTyCon :: TyCon -word8X16PrimTyCon = pcPrimTyCon0 word8X16PrimTyConName (VecRep 16 Word8ElemRep) -word16X8PrimTyConName :: Name -word16X8PrimTyConName = mkPrimTc (fsLit "Word16X8#") word16X8PrimTyConKey word16X8PrimTyCon -word16X8PrimTy :: Type -word16X8PrimTy = mkTyConTy word16X8PrimTyCon -word16X8PrimTyCon :: TyCon -word16X8PrimTyCon = pcPrimTyCon0 word16X8PrimTyConName (VecRep 8 Word16ElemRep) -word32X4PrimTyConName :: Name -word32X4PrimTyConName = mkPrimTc (fsLit "Word32X4#") word32X4PrimTyConKey word32X4PrimTyCon -word32X4PrimTy :: Type -word32X4PrimTy = mkTyConTy word32X4PrimTyCon -word32X4PrimTyCon :: TyCon -word32X4PrimTyCon = pcPrimTyCon0 word32X4PrimTyConName (VecRep 4 Word32ElemRep) -word64X2PrimTyConName :: Name -word64X2PrimTyConName = mkPrimTc (fsLit "Word64X2#") word64X2PrimTyConKey word64X2PrimTyCon -word64X2PrimTy :: Type -word64X2PrimTy = mkTyConTy word64X2PrimTyCon -word64X2PrimTyCon :: TyCon -word64X2PrimTyCon = pcPrimTyCon0 word64X2PrimTyConName (VecRep 2 Word64ElemRep) -word8X32PrimTyConName :: Name -word8X32PrimTyConName = mkPrimTc (fsLit "Word8X32#") word8X32PrimTyConKey word8X32PrimTyCon -word8X32PrimTy :: Type -word8X32PrimTy = mkTyConTy word8X32PrimTyCon -word8X32PrimTyCon :: TyCon -word8X32PrimTyCon = pcPrimTyCon0 word8X32PrimTyConName (VecRep 32 Word8ElemRep) -word16X16PrimTyConName :: Name -word16X16PrimTyConName = mkPrimTc (fsLit "Word16X16#") word16X16PrimTyConKey word16X16PrimTyCon -word16X16PrimTy :: Type -word16X16PrimTy = mkTyConTy word16X16PrimTyCon -word16X16PrimTyCon :: TyCon -word16X16PrimTyCon = pcPrimTyCon0 word16X16PrimTyConName (VecRep 16 Word16ElemRep) -word32X8PrimTyConName :: Name -word32X8PrimTyConName = mkPrimTc (fsLit "Word32X8#") word32X8PrimTyConKey word32X8PrimTyCon -word32X8PrimTy :: Type -word32X8PrimTy = mkTyConTy word32X8PrimTyCon -word32X8PrimTyCon :: TyCon -word32X8PrimTyCon = pcPrimTyCon0 word32X8PrimTyConName (VecRep 8 Word32ElemRep) -word64X4PrimTyConName :: Name -word64X4PrimTyConName = mkPrimTc (fsLit "Word64X4#") word64X4PrimTyConKey word64X4PrimTyCon -word64X4PrimTy :: Type -word64X4PrimTy = mkTyConTy word64X4PrimTyCon -word64X4PrimTyCon :: TyCon -word64X4PrimTyCon = pcPrimTyCon0 word64X4PrimTyConName (VecRep 4 Word64ElemRep) -word8X64PrimTyConName :: Name -word8X64PrimTyConName = mkPrimTc (fsLit "Word8X64#") word8X64PrimTyConKey word8X64PrimTyCon -word8X64PrimTy :: Type -word8X64PrimTy = mkTyConTy word8X64PrimTyCon -word8X64PrimTyCon :: TyCon -word8X64PrimTyCon = pcPrimTyCon0 word8X64PrimTyConName (VecRep 64 Word8ElemRep) -word16X32PrimTyConName :: Name -word16X32PrimTyConName = mkPrimTc (fsLit "Word16X32#") word16X32PrimTyConKey word16X32PrimTyCon -word16X32PrimTy :: Type -word16X32PrimTy = mkTyConTy word16X32PrimTyCon -word16X32PrimTyCon :: TyCon -word16X32PrimTyCon = pcPrimTyCon0 word16X32PrimTyConName (VecRep 32 Word16ElemRep) -word32X16PrimTyConName :: Name -word32X16PrimTyConName = mkPrimTc (fsLit "Word32X16#") word32X16PrimTyConKey word32X16PrimTyCon -word32X16PrimTy :: Type -word32X16PrimTy = mkTyConTy word32X16PrimTyCon -word32X16PrimTyCon :: TyCon -word32X16PrimTyCon = pcPrimTyCon0 word32X16PrimTyConName (VecRep 16 Word32ElemRep) -word64X8PrimTyConName :: Name -word64X8PrimTyConName = mkPrimTc (fsLit "Word64X8#") word64X8PrimTyConKey word64X8PrimTyCon -word64X8PrimTy :: Type -word64X8PrimTy = mkTyConTy word64X8PrimTyCon -word64X8PrimTyCon :: TyCon -word64X8PrimTyCon = pcPrimTyCon0 word64X8PrimTyConName (VecRep 8 Word64ElemRep) -floatX4PrimTyConName :: Name -floatX4PrimTyConName = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon -floatX4PrimTy :: Type -floatX4PrimTy = mkTyConTy floatX4PrimTyCon -floatX4PrimTyCon :: TyCon -floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (VecRep 4 FloatElemRep) -doubleX2PrimTyConName :: Name -doubleX2PrimTyConName = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon -doubleX2PrimTy :: Type -doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon -doubleX2PrimTyCon :: TyCon -doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (VecRep 2 DoubleElemRep) -floatX8PrimTyConName :: Name -floatX8PrimTyConName = mkPrimTc (fsLit "FloatX8#") floatX8PrimTyConKey floatX8PrimTyCon -floatX8PrimTy :: Type -floatX8PrimTy = mkTyConTy floatX8PrimTyCon -floatX8PrimTyCon :: TyCon -floatX8PrimTyCon = pcPrimTyCon0 floatX8PrimTyConName (VecRep 8 FloatElemRep) -doubleX4PrimTyConName :: Name -doubleX4PrimTyConName = mkPrimTc (fsLit "DoubleX4#") doubleX4PrimTyConKey doubleX4PrimTyCon -doubleX4PrimTy :: Type -doubleX4PrimTy = mkTyConTy doubleX4PrimTyCon -doubleX4PrimTyCon :: TyCon -doubleX4PrimTyCon = pcPrimTyCon0 doubleX4PrimTyConName (VecRep 4 DoubleElemRep) -floatX16PrimTyConName :: Name -floatX16PrimTyConName = mkPrimTc (fsLit "FloatX16#") floatX16PrimTyConKey floatX16PrimTyCon -floatX16PrimTy :: Type -floatX16PrimTy = mkTyConTy floatX16PrimTyCon -floatX16PrimTyCon :: TyCon -floatX16PrimTyCon = pcPrimTyCon0 floatX16PrimTyConName (VecRep 16 FloatElemRep) -doubleX8PrimTyConName :: Name -doubleX8PrimTyConName = mkPrimTc (fsLit "DoubleX8#") doubleX8PrimTyConKey doubleX8PrimTyCon -doubleX8PrimTy :: Type -doubleX8PrimTy = mkTyConTy doubleX8PrimTyCon -doubleX8PrimTyCon :: TyCon -doubleX8PrimTyCon = pcPrimTyCon0 doubleX8PrimTyConName (VecRep 8 DoubleElemRep) diff --git a/autogen/primop-vector-uniques.hs-incl b/autogen/primop-vector-uniques.hs-incl deleted file mode 100644 --- a/autogen/primop-vector-uniques.hs-incl +++ /dev/null @@ -1,60 +0,0 @@ -int8X16PrimTyConKey :: Unique -int8X16PrimTyConKey = mkPreludeTyConUnique 300 -int16X8PrimTyConKey :: Unique -int16X8PrimTyConKey = mkPreludeTyConUnique 301 -int32X4PrimTyConKey :: Unique -int32X4PrimTyConKey = mkPreludeTyConUnique 302 -int64X2PrimTyConKey :: Unique -int64X2PrimTyConKey = mkPreludeTyConUnique 303 -int8X32PrimTyConKey :: Unique -int8X32PrimTyConKey = mkPreludeTyConUnique 304 -int16X16PrimTyConKey :: Unique -int16X16PrimTyConKey = mkPreludeTyConUnique 305 -int32X8PrimTyConKey :: Unique -int32X8PrimTyConKey = mkPreludeTyConUnique 306 -int64X4PrimTyConKey :: Unique -int64X4PrimTyConKey = mkPreludeTyConUnique 307 -int8X64PrimTyConKey :: Unique -int8X64PrimTyConKey = mkPreludeTyConUnique 308 -int16X32PrimTyConKey :: Unique -int16X32PrimTyConKey = mkPreludeTyConUnique 309 -int32X16PrimTyConKey :: Unique -int32X16PrimTyConKey = mkPreludeTyConUnique 310 -int64X8PrimTyConKey :: Unique -int64X8PrimTyConKey = mkPreludeTyConUnique 311 -word8X16PrimTyConKey :: Unique -word8X16PrimTyConKey = mkPreludeTyConUnique 312 -word16X8PrimTyConKey :: Unique -word16X8PrimTyConKey = mkPreludeTyConUnique 313 -word32X4PrimTyConKey :: Unique -word32X4PrimTyConKey = mkPreludeTyConUnique 314 -word64X2PrimTyConKey :: Unique -word64X2PrimTyConKey = mkPreludeTyConUnique 315 -word8X32PrimTyConKey :: Unique -word8X32PrimTyConKey = mkPreludeTyConUnique 316 -word16X16PrimTyConKey :: Unique -word16X16PrimTyConKey = mkPreludeTyConUnique 317 -word32X8PrimTyConKey :: Unique -word32X8PrimTyConKey = mkPreludeTyConUnique 318 -word64X4PrimTyConKey :: Unique -word64X4PrimTyConKey = mkPreludeTyConUnique 319 -word8X64PrimTyConKey :: Unique -word8X64PrimTyConKey = mkPreludeTyConUnique 320 -word16X32PrimTyConKey :: Unique -word16X32PrimTyConKey = mkPreludeTyConUnique 321 -word32X16PrimTyConKey :: Unique -word32X16PrimTyConKey = mkPreludeTyConUnique 322 -word64X8PrimTyConKey :: Unique -word64X8PrimTyConKey = mkPreludeTyConUnique 323 -floatX4PrimTyConKey :: Unique -floatX4PrimTyConKey = mkPreludeTyConUnique 324 -doubleX2PrimTyConKey :: Unique -doubleX2PrimTyConKey = mkPreludeTyConUnique 325 -floatX8PrimTyConKey :: Unique -floatX8PrimTyConKey = mkPreludeTyConUnique 326 -doubleX4PrimTyConKey :: Unique -doubleX4PrimTyConKey = mkPreludeTyConUnique 327 -floatX16PrimTyConKey :: Unique -floatX16PrimTyConKey = mkPreludeTyConUnique 328 -doubleX8PrimTyConKey :: Unique -doubleX8PrimTyConKey = mkPreludeTyConUnique 329 diff --git a/backpack/BkpSyn.hs b/backpack/BkpSyn.hs deleted file mode 100644 --- a/backpack/BkpSyn.hs +++ /dev/null @@ -1,83 +0,0 @@ --- | This is the syntax for bkp files which are parsed in 'ghc --backpack' --- mode. This syntax is used purely for testing purposes. - -module BkpSyn ( - -- * Backpack abstract syntax - HsUnitId(..), - LHsUnitId, - HsModuleSubst, - LHsModuleSubst, - HsModuleId(..), - LHsModuleId, - HsComponentId(..), - LHsUnit, HsUnit(..), - LHsUnitDecl, HsUnitDecl(..), - HsDeclType(..), - IncludeDecl(..), - LRenaming, Renaming(..), - ) where - -import HsSyn -import RdrName -import SrcLoc -import Outputable -import Module -import PackageConfig - -{- -************************************************************************ -* * - User syntax -* * -************************************************************************ --} - -data HsComponentId = HsComponentId { - hsPackageName :: PackageName, - hsComponentId :: ComponentId - } - -instance Outputable HsComponentId where - ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn - -data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n] -type LHsUnitId n = Located (HsUnitId n) - -type HsModuleSubst n = (Located ModuleName, LHsModuleId n) -type LHsModuleSubst n = Located (HsModuleSubst n) - -data HsModuleId n = HsModuleVar (Located ModuleName) - | HsModuleId (LHsUnitId n) (Located ModuleName) -type LHsModuleId n = Located (HsModuleId n) - --- | Top level @unit@ declaration in a Backpack file. -data HsUnit n = HsUnit { - hsunitName :: Located n, - hsunitBody :: [LHsUnitDecl n] - } -type LHsUnit n = Located (HsUnit n) - --- | A declaration in a package, e.g. a module or signature definition, --- or an include. -data HsDeclType = ModuleD | SignatureD -data HsUnitDecl n - = DeclD HsDeclType (Located ModuleName) (Maybe (Located (HsModule RdrName))) - | IncludeD (IncludeDecl n) -type LHsUnitDecl n = Located (HsUnitDecl n) - --- | An include of another unit -data IncludeDecl n = IncludeDecl { - idUnitId :: LHsUnitId n, - idModRenaming :: Maybe [ LRenaming ], - -- | Is this a @dependency signature@ include? If so, - -- we don't compile this include when we instantiate this - -- unit (as there should not be any modules brought into - -- scope.) - idSignatureInclude :: Bool - } - --- | Rename a module from one name to another. The identity renaming --- means that the module should be brought into scope. -data Renaming = Renaming { renameFrom :: Located ModuleName - , renameTo :: Maybe (Located ModuleName) } -type LRenaming = Located Renaming diff --git a/backpack/DriverBkp.hs b/backpack/DriverBkp.hs deleted file mode 100644 --- a/backpack/DriverBkp.hs +++ /dev/null @@ -1,823 +0,0 @@ -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} - --- | This is the driver for the 'ghc --backpack' mode, which --- is a reimplementation of the "package manager" bits of --- Backpack directly in GHC. The basic method of operation --- is to compile packages and then directly insert them into --- GHC's in memory database. --- --- The compilation products of this mode aren't really suitable --- for Cabal, because GHC makes up component IDs for the things --- it builds and doesn't serialize out the database contents. --- But it's still handy for constructing tests. - -module DriverBkp (doBackpack) where - -#include "HsVersions.h" - --- In a separate module because it hooks into the parser. -import BkpSyn - -import GHC hiding (Failed, Succeeded) -import Packages -import Parser -import Lexer -import GhcMonad -import DynFlags -import TcRnMonad -import TcRnDriver -import Module -import HscTypes -import StringBuffer -import FastString -import ErrUtils -import SrcLoc -import HscMain -import UniqFM -import UniqDFM -import Outputable -import Maybes -import HeaderInfo -import MkIface -import GhcMake -import UniqDSet -import PrelNames -import BasicTypes hiding (SuccessFlag(..)) -import Finder -import Util - -import qualified GHC.LanguageExtensions as LangExt - -import Panic -import Data.List -import System.Exit -import Control.Monad -import System.FilePath -import Data.Version - --- for the unification -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map - --- | Entry point to compile a Backpack file. -doBackpack :: [FilePath] -> Ghc () -doBackpack [src_filename] = do - -- Apply options from file to dflags - dflags0 <- getDynFlags - let dflags1 = dflags0 - src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename - (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts - modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags}) - -- Cribbed from: preprocessFile / DriverPipeline - liftIO $ checkProcessArgsResult dflags unhandled_flags - liftIO $ handleFlagWarnings dflags warns - -- TODO: Preprocessing not implemented - - buf <- liftIO $ hGetStringBuffer src_filename - let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great - case unP parseBackpack (mkPState dflags buf loc) of - PFailed span err -> do - liftIO $ throwOneError (mkPlainErrMsg dflags span err) - POk _ pkgname_bkp -> do - -- OK, so we have an LHsUnit PackageName, but we want an - -- LHsUnit HsComponentId. So let's rename it. - let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp - initBkpM src_filename bkp $ - forM_ (zip [1..] bkp) $ \(i, lunit) -> do - let comp_name = unLoc (hsunitName (unLoc lunit)) - msgTopPackage (i,length bkp) comp_name - innerBkpM $ do - let (cid, insts) = computeUnitId lunit - if null insts - then if cid == ComponentId (fsLit "main") - then compileExe lunit - else compileUnit cid [] - else typecheckUnit cid insts -doBackpack _ = - throwGhcException (CmdLineError "--backpack can only process a single file") - -computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)]) -computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) - where - cid = hsComponentId (unLoc (hsunitName unit)) - reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit))) - get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname - get_reqs (DeclD ModuleD _ _) = emptyUniqDSet - get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) = - unitIdFreeHoles (convertHsUnitId hsuid) - --- | Tiny enum for all types of Backpack operations we may do. -data SessionType - -- | A compilation operation which will result in a - -- runnable executable being produced. - = ExeSession - -- | A type-checking operation which produces only - -- interface files, no object files. - | TcSession - -- | A compilation operation which produces both - -- interface files and object files. - | CompSession - deriving (Eq) - --- | Create a temporary Session to do some sort of type checking or --- compilation. -withBkpSession :: ComponentId - -> [(ModuleName, Module)] - -> [(UnitId, ModRenaming)] - -> SessionType -- what kind of session are we doing - -> BkpM a -- actual action to run - -> BkpM a -withBkpSession cid insts deps session_type do_this = do - dflags <- getDynFlags - let (ComponentId cid_fs) = cid - is_primary = False - uid_str = unpackFS (hashUnitId cid insts) - cid_str = unpackFS cid_fs - -- There are multiple units in a single Backpack file, so we - -- need to separate out the results in those cases. Right now, - -- we follow this hierarchy: - -- $outputdir/$compid --> typecheck results - -- $outputdir/$compid/$unitid --> compile results - key_base p | Just f <- p dflags = f - | otherwise = "." - sub_comp p | is_primary = p - | otherwise = p cid_str - outdir p | CompSession <- session_type - -- Special case when package is definite - , not (null insts) = sub_comp (key_base p) uid_str - | otherwise = sub_comp (key_base p) - withTempSession (overHscDynFlags (\dflags -> - -- If we're type-checking an indefinite package, we want to - -- turn on interface writing. However, if the user also - -- explicitly passed in `-fno-code`, we DON'T want to write - -- interfaces unless the user also asked for `-fwrite-interface`. - (case session_type of - -- Make sure to write interfaces when we are type-checking - -- indefinite packages. - TcSession | hscTarget dflags /= HscNothing - -> flip gopt_set Opt_WriteInterface - | otherwise -> id - CompSession -> id - ExeSession -> id) $ - dflags { - hscTarget = case session_type of - TcSession -> HscNothing - _ -> hscTarget dflags, - thisUnitIdInsts_ = Just insts, - thisComponentId_ = Just cid, - thisInstalledUnitId = - case session_type of - TcSession -> newInstalledUnitId cid Nothing - -- No hash passed if no instances - _ | null insts -> newInstalledUnitId cid Nothing - | otherwise -> newInstalledUnitId cid (Just (hashUnitId cid insts)), - -- Setup all of the output directories according to our hierarchy - objectDir = Just (outdir objectDir), - hiDir = Just (outdir hiDir), - stubDir = Just (outdir stubDir), - -- Unset output-file for non exe builds - outputFile = if session_type == ExeSession - then outputFile dflags - else Nothing, - -- Clear the import path so we don't accidentally grab anything - importPaths = [], - -- Synthesized the flags - packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> - let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0) - in ExposePackage - (showSDoc dflags - (text "-unit-id" <+> ppr uid <+> ppr rn)) - (UnitIdArg uid) rn) deps - } )) $ do - dflags <- getSessionDynFlags - -- pprTrace "flags" (ppr insts <> ppr deps) $ return () - -- Calls initPackages - _ <- setSessionDynFlags dflags - do_this - -withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a -withBkpExeSession deps do_this = do - withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this - -getSource :: ComponentId -> BkpM (LHsUnit HsComponentId) -getSource cid = do - bkp_env <- getBkpEnv - case Map.lookup cid (bkp_table bkp_env) of - Nothing -> pprPanic "missing needed dependency" (ppr cid) - Just lunit -> return lunit - -typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () -typecheckUnit cid insts = do - lunit <- getSource cid - buildUnit TcSession cid insts lunit - -compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () -compileUnit cid insts = do - -- Let everyone know we're building this unit ID - msgUnitId (newUnitId cid insts) - lunit <- getSource cid - buildUnit CompSession cid insts lunit - --- | Compute the dependencies with instantiations of a syntactic --- HsUnit; e.g., wherever you see @dependency p[A=]@ in a --- unit file, return the 'UnitId' corresponding to @p[A=]@. --- The @include_sigs@ parameter controls whether or not we also --- include @dependency signature@ declarations in this calculation. --- --- Invariant: this NEVER returns InstalledUnitId. -hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)] -hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit) - where - get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig))) - | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)] - | otherwise = [] - where - go Nothing = ModRenaming True [] - go (Just lrns) = ModRenaming False (map convRn lrns) - where - convRn (L _ (Renaming (L _ from) Nothing)) = (from, from) - convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to) - get_dep _ = [] - -buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () -buildUnit session cid insts lunit = do - -- NB: include signature dependencies ONLY when typechecking. - -- If we're compiling, it's not necessary to recursively - -- compile a signature since it isn't going to produce - -- any object files. - let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit) - raw_deps = map fst deps_w_rns - dflags <- getDynFlags - -- The compilation dependencies are just the appropriately filled - -- in unit IDs which must be compiled before we can compile. - let hsubst = listToUFM insts - deps0 = map (renameHoleUnitId dflags hsubst) raw_deps - - -- Build dependencies OR make sure they make sense. BUT NOTE, - -- we can only check the ones that are fully filled; the rest - -- we have to defer until we've typechecked our local signature. - -- TODO: work this into GhcMake!! - forM_ (zip [1..] deps0) $ \(i, dep) -> - case session of - TcSession -> return () - _ -> compileInclude (length deps0) (i, dep) - - dflags <- getDynFlags - -- IMPROVE IT - let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0 - - mb_old_eps <- case session of - TcSession -> fmap Just getEpsGhc - _ -> return Nothing - - conf <- withBkpSession cid insts deps_w_rns session $ do - - dflags <- getDynFlags - mod_graph <- hsunitModuleGraph dflags (unLoc lunit) - -- pprTrace "mod_graph" (ppr mod_graph) $ return () - - msg <- mkBackpackMsg - ok <- load' LoadAllTargets (Just msg) mod_graph - when (failed ok) (liftIO $ exitWith (ExitFailure 1)) - - let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags - export_mod ms = (ms_mod_name ms, ms_mod ms) - -- Export everything! - mods = [ export_mod ms | ms <- mod_graph, ms_hsc_src ms == HsSrcFile ] - - -- Compile relevant only - hsc_env <- getSession - let home_mod_infos = eltsUDFM (hsc_HPT hsc_env) - linkables = map (expectJust "bkp link" . hm_linkable) - . filter ((==HsSrcFile) . mi_hsc_src . hm_iface) - $ home_mod_infos - getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) - obj_files = concatMap getOfiles linkables - - let compat_fs = (case cid of ComponentId fs -> fs) - compat_pn = PackageName compat_fs - - return InstalledPackageInfo { - -- Stub data - abiHash = "", - sourcePackageId = SourcePackageId compat_fs, - packageName = compat_pn, - packageVersion = makeVersion [0], - unitId = toInstalledUnitId (thisPackage dflags), - sourceLibName = Nothing, - componentId = cid, - instantiatedWith = insts, - -- Slight inefficiency here haha - exposedModules = map (\(m,n) -> (m,Just n)) mods, - hiddenModules = [], -- TODO: doc only - depends = case session of - -- Technically, we should state that we depend - -- on all the indefinite libraries we used to - -- typecheck this. However, this field isn't - -- really used for anything, so we leave it - -- blank for now. - TcSession -> [] - _ -> map (toInstalledUnitId . unwireUnitId dflags) - $ deps ++ [ moduleUnitId mod - | (_, mod) <- insts - , not (isHoleModule mod) ], - abiDepends = [], - ldOptions = case session of - TcSession -> [] - _ -> obj_files, - importDirs = [ hi_dir ], - exposed = False, - indefinite = case session of - TcSession -> True - _ -> False, - -- nope - hsLibraries = [], - extraLibraries = [], - extraGHCiLibraries = [], - libraryDynDirs = [], - libraryDirs = [], - frameworks = [], - frameworkDirs = [], - ccOptions = [], - includes = [], - includeDirs = [], - haddockInterfaces = [], - haddockHTMLs = [], - trusted = False - } - - - addPackage conf - case mb_old_eps of - Just old_eps -> updateEpsGhc_ (const old_eps) - _ -> return () - -compileExe :: LHsUnit HsComponentId -> BkpM () -compileExe lunit = do - msgUnitId mainUnitId - let deps_w_rns = hsunitDeps False (unLoc lunit) - deps = map fst deps_w_rns - -- no renaming necessary - forM_ (zip [1..] deps) $ \(i, dep) -> - compileInclude (length deps) (i, dep) - withBkpExeSession deps_w_rns $ do - dflags <- getDynFlags - mod_graph <- hsunitModuleGraph dflags (unLoc lunit) - msg <- mkBackpackMsg - ok <- load' LoadAllTargets (Just msg) mod_graph - when (failed ok) (liftIO $ exitWith (ExitFailure 1)) - -addPackage :: GhcMonad m => PackageConfig -> m () -addPackage pkg = do - dflags0 <- GHC.getSessionDynFlags - case pkgDatabase dflags0 of - Nothing -> panic "addPackage: called too early" - Just pkgs -> do let dflags = dflags0 { pkgDatabase = - Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) } - _ <- GHC.setSessionDynFlags dflags - -- By this time, the global ref has probably already - -- been forced, in which case doing this isn't actually - -- going to do you any good. - -- dflags <- GHC.getSessionDynFlags - -- liftIO $ setUnsafeGlobalDynFlags dflags - return () - --- Precondition: UnitId is NOT InstalledUnitId -compileInclude :: Int -> (Int, UnitId) -> BkpM () -compileInclude n (i, uid) = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - msgInclude (i, n) uid - -- Check if we've compiled it already - case lookupPackage dflags uid of - Nothing -> do - case splitUnitIdInsts uid of - (_, Just indef) -> - innerBkpM $ compileUnit (indefUnitIdComponentId indef) - (indefUnitIdInsts indef) - _ -> return () - Just _ -> return () - --- ---------------------------------------------------------------------------- --- Backpack monad - --- | Backpack monad is a 'GhcMonad' which also maintains a little extra state --- beyond the 'Session', c.f. 'BkpEnv'. -type BkpM = IOEnv BkpEnv - --- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv', --- because we are going to update the 'HscEnv' as we go. -data BkpEnv - = BkpEnv { - -- | The session - bkp_session :: Session, - -- | The filename of the bkp file we're compiling - bkp_filename :: FilePath, - -- | Table of source units which we know how to compile - bkp_table :: Map ComponentId (LHsUnit HsComponentId), - -- | When a package we are compiling includes another package - -- which has not been compiled, we bump the level and compile - -- that. - bkp_level :: Int - } - --- Blah, to get rid of the default instance for IOEnv --- TODO: just make a proper new monad for BkpM, rather than use IOEnv -instance {-# OVERLAPPING #-} HasDynFlags BkpM where - getDynFlags = fmap hsc_dflags getSession - -instance GhcMonad BkpM where - getSession = do - Session s <- fmap bkp_session getEnv - readMutVar s - setSession hsc_env = do - Session s <- fmap bkp_session getEnv - writeMutVar s hsc_env - --- | Get the current 'BkpEnv'. -getBkpEnv :: BkpM BkpEnv -getBkpEnv = getEnv - --- | Get the nesting level, when recursively compiling modules. -getBkpLevel :: BkpM Int -getBkpLevel = bkp_level `fmap` getBkpEnv - --- | Apply a function on 'DynFlags' on an 'HscEnv' -overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv -overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) } - --- | Run a 'BkpM' computation, with the nesting level bumped one. -innerBkpM :: BkpM a -> BkpM a -innerBkpM do_this = do - -- NB: withTempSession mutates, so we don't have to worry - -- about bkp_session being stale. - updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this - --- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot. -updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m () -updateEpsGhc_ f = do - hsc_env <- getSession - liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ())) - --- | Get the EPS from a 'GhcMonad'. -getEpsGhc :: GhcMonad m => m ExternalPackageState -getEpsGhc = do - hsc_env <- getSession - liftIO $ readIORef (hsc_EPS hsc_env) - --- | Run 'BkpM' in 'Ghc'. -initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a -initBkpM file bkp m = do - reifyGhc $ \session -> do - let env = BkpEnv { - bkp_session = session, - bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp], - bkp_filename = file, - bkp_level = 0 - } - runIOEnv env m - --- ---------------------------------------------------------------------------- --- Messaging - --- | Print a compilation progress message, but with indentation according --- to @level@ (for nested compilation). -backpackProgressMsg :: Int -> DynFlags -> String -> IO () -backpackProgressMsg level dflags msg = - compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg - --- | Creates a 'Messager' for Backpack compilation; this is basically --- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which --- handles indentation. -mkBackpackMsg :: BkpM Messager -mkBackpackMsg = do - level <- getBkpLevel - return $ \hsc_env mod_index recomp mod_summary -> - let dflags = hsc_dflags hsc_env - showMsg msg reason = - backpackProgressMsg level dflags $ - showModuleIndex mod_index ++ - msg ++ showModMsg dflags (hscTarget dflags) - (recompileRequired recomp) mod_summary - ++ reason - in case recomp of - MustCompile -> showMsg "Compiling " "" - UpToDate - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" - | otherwise -> return () - RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") - --- | 'PprStyle' for Backpack messages; here we usually want the module to --- be qualified (so we can tell how it was instantiated.) But we try not --- to qualify packages so we can use simple names for them. -backpackStyle :: DynFlags -> PprStyle -backpackStyle dflags = - mkUserStyle dflags - (QueryQualify neverQualifyNames - alwaysQualifyModules - neverQualifyPackages) AllTheWay - --- | Message when we initially process a Backpack unit. -msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () -msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do - dflags <- getDynFlags - level <- getBkpLevel - liftIO . backpackProgressMsg level dflags - $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn - --- | Message when we instantiate a Backpack unit. -msgUnitId :: UnitId -> BkpM () -msgUnitId pk = do - dflags <- getDynFlags - level <- getBkpLevel - liftIO . backpackProgressMsg level dflags - $ "Instantiating " ++ renderWithStyle dflags (ppr pk) - (backpackStyle dflags) - --- | Message when we include a Backpack unit. -msgInclude :: (Int,Int) -> UnitId -> BkpM () -msgInclude (i,n) uid = do - dflags <- getDynFlags - level <- getBkpLevel - liftIO . backpackProgressMsg level dflags - $ showModuleIndex (i, n) ++ "Including " ++ - renderWithStyle dflags (ppr uid) (backpackStyle dflags) - --- ---------------------------------------------------------------------------- --- Conversion from PackageName to HsComponentId - -type PackageNameMap a = Map PackageName a - --- For now, something really simple, since we're not actually going --- to use this for anything -unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId) -unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) - = (pn, HsComponentId pn (ComponentId fs)) - -packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId -packageNameMap units = Map.fromList (map unitDefines units) - -renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] -renameHsUnits dflags m units = map (fmap renameHsUnit) units - where - - renamePackageName :: PackageName -> HsComponentId - renamePackageName pn = - case Map.lookup pn m of - Nothing -> - case lookupPackageName dflags pn of - Nothing -> error "no package name" - Just cid -> HsComponentId pn cid - Just hscid -> hscid - - renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId - renameHsUnit u = - HsUnit { - hsunitName = fmap renamePackageName (hsunitName u), - hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u) - } - - renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId - renameHsUnitDecl (DeclD a b c) = DeclD a b c - renameHsUnitDecl (IncludeD idecl) = - IncludeD IncludeDecl { - idUnitId = fmap renameHsUnitId (idUnitId idecl), - idModRenaming = idModRenaming idecl, - idSignatureInclude = idSignatureInclude idecl - } - - renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId - renameHsUnitId (HsUnitId ln subst) - = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst) - - renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId - renameHsModuleSubst (lk, lm) - = (lk, fmap renameHsModuleId lm) - - renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId - renameHsModuleId (HsModuleVar lm) = HsModuleVar lm - renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm - -convertHsUnitId :: HsUnitId HsComponentId -> UnitId -convertHsUnitId (HsUnitId (L _ hscid) subst) - = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst) - -convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module) -convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m) - -convertHsModuleId :: HsModuleId HsComponentId -> Module -convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname -convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname - - - -{- -************************************************************************ -* * - Module graph construction -* * -************************************************************************ --} - --- | This is our version of GhcMake.downsweep, but with a few modifications: --- --- 1. Every module is required to be mentioned, so we don't do any funny --- business with targets or recursively grabbing dependencies. (We --- could support this in principle). --- 2. We support inline modules, whose summary we have to synthesize ourself. --- --- We don't bother trying to support GhcMake for now, it's more trouble --- than it's worth for inline modules. -hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph -hsunitModuleGraph dflags unit = do - let decls = hsunitBody unit - pn = hsPackageName (unLoc (hsunitName unit)) - - -- 1. Create a HsSrcFile/HsigFile summary for every - -- explicitly mentioned module/signature. - let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do - let hsc_src = case dt of - ModuleD -> HsSrcFile - SignatureD -> HsigFile - Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod - get_decl _ = return Nothing - nodes <- catMaybes `fmap` mapM get_decl decls - - -- 2. For each hole which does not already have an hsig file, - -- create an "empty" hsig file to induce compilation for the - -- requirement. - let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n) - | n <- nodes ] - req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) -> - let has_local = Map.member (mod_name, True) node_map - in if has_local - then return Nothing - else fmap Just $ summariseRequirement pn mod_name - - -- 3. Return the kaboodle - return (nodes ++ req_nodes) - -summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary -summariseRequirement pn mod_name = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - - let PackageName pn_fs = pn - location <- liftIO $ mkHomeModLocation2 dflags mod_name - (unpackFS pn_fs moduleNameSlashes mod_name) "hsig" - - env <- getBkpEnv - time <- liftIO $ getModificationUTCTime (bkp_filename env) - hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) - let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) - - mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location - - extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name - - return ModSummary { - ms_mod = mod, - ms_hsc_src = HsigFile, - ms_location = location, - ms_hs_date = time, - ms_obj_date = Nothing, - ms_iface_date = hi_timestamp, - ms_srcimps = [], - ms_textual_imps = extra_sig_imports, - ms_parsed_mod = Just (HsParsedModule { - hpm_module = L loc (HsModule { - hsmodName = Just (L loc mod_name), - hsmodExports = Nothing, - hsmodImports = [], - hsmodDecls = [], - hsmodDeprecMessage = Nothing, - hsmodHaddockModHeader = Nothing - }), - hpm_src_files = [], - hpm_annotations = (Map.empty, Map.empty) - }), - ms_hspp_file = "", -- none, it came inline - ms_hspp_opts = dflags, - ms_hspp_buf = Nothing - } - -summariseDecl :: PackageName - -> HscSource - -> Located ModuleName - -> Maybe (Located (HsModule RdrName)) - -> BkpM ModSummary -summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod -summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing - = do hsc_env <- getSession - let dflags = hsc_dflags hsc_env - -- TODO: this looks for modules in the wrong place - r <- liftIO $ summariseModule hsc_env - Map.empty -- GHC API recomp not supported - (hscSourceToIsBoot hsc_src) - lmodname - True -- Target lets you disallow, but not here - Nothing -- GHC API buffer support not supported - [] -- No exclusions - case r of - Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found")) - Just (Left err) -> throwOneError err - Just (Right summary) -> return summary - --- | Up until now, GHC has assumed a single compilation target per source file. --- Backpack files with inline modules break this model, since a single file --- may generate multiple output files. How do we decide to name these files? --- Should there only be one output file? This function our current heuristic, --- which is we make a "fake" module and use that. -hsModuleToModSummary :: PackageName - -> HscSource - -> ModuleName - -> Located (HsModule RdrName) - -> BkpM ModSummary -hsModuleToModSummary pn hsc_src modname - hsmod = do - let imps = hsmodImports (unLoc hsmod) - loc = getLoc hsmod - hsc_env <- getSession - -- Sort of the same deal as in DriverPipeline's getLocation - -- Use the PACKAGE NAME to find the location - let PackageName unit_fs = pn - dflags = hsc_dflags hsc_env - -- Unfortunately, we have to define a "fake" location in - -- order to appease the various code which uses the file - -- name to figure out where to put, e.g. object files. - -- To add insult to injury, we don't even actually use - -- these filenames to figure out where the hi files go. - -- A travesty! - location0 <- liftIO $ mkHomeModLocation2 dflags modname - (unpackFS unit_fs - moduleNameSlashes modname) - (case hsc_src of - HsigFile -> "hsig" - HsBootFile -> "hs-boot" - HsSrcFile -> "hs") - -- DANGEROUS: bootifying can POISON the module finder cache - let location = case hsc_src of - HsBootFile -> addBootSuffixLocn location0 - _ -> location0 - -- This duplicates a pile of logic in GhcMake - env <- getBkpEnv - time <- liftIO $ getModificationUTCTime (bkp_filename env) - hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) - - -- Also copied from 'getImports' - let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps - - -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) - ord_idecls - - implicit_prelude = xopt LangExt.ImplicitPrelude dflags - implicit_imports = mkPrelImports modname loc - implicit_prelude imps - convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) - - extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname - - let normal_imports = map convImport (implicit_imports ++ ordinary_imps) - required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports - - -- So that Finder can find it, even though it doesn't exist... - this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location - return ModSummary { - ms_mod = this_mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = (case hiDir dflags of - Nothing -> "" - Just d -> d) ".." moduleNameSlashes modname <.> "hi", - ms_hspp_opts = dflags, - ms_hspp_buf = Nothing, - ms_srcimps = map convImport src_idecls, - ms_textual_imps = normal_imports - -- We have to do something special here: - -- due to merging, requirements may end up with - -- extra imports - ++ extra_sig_imports - ++ required_by_imports, - -- This is our hack to get the parse tree to the right spot - ms_parsed_mod = Just (HsParsedModule { - hpm_module = hsmod, - hpm_src_files = [], -- TODO if we preprocessed it - hpm_annotations = (Map.empty, Map.empty) -- BOGUS - }), - ms_hs_date = time, - ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS - ms_iface_date = hi_timestamp - } - --- | Create a new, externally provided hashed unit id from --- a hash. -newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId -newInstalledUnitId (ComponentId cid_fs) (Just fs) - = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs) -newInstalledUnitId (ComponentId cid_fs) Nothing - = InstalledUnitId cid_fs diff --git a/backpack/NameShape.hs b/backpack/NameShape.hs deleted file mode 100644 --- a/backpack/NameShape.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE CPP #-} - -module NameShape( - NameShape(..), - emptyNameShape, - mkNameShape, - extendNameShape, - nameShapeExports, - substNameShape, - maybeSubstNameShape, - ) where - -#include "HsVersions.h" - -import Outputable -import HscTypes -import Module -import UniqFM -import Avail -import FieldLabel - -import Name -import NameEnv -import TcRnMonad -import Util -import IfaceEnv - -import Control.Monad - --- Note [NameShape] --- ~~~~~~~~~~~~~~~~ --- When we write a declaration in a signature, e.g., data T, we --- ascribe to it a *name variable*, e.g., {m.T}. This --- name variable may be substituted with an actual original --- name when the signature is implemented (or even if we --- merge the signature with one which reexports this entity --- from another module). - --- When we instantiate a signature m with a module M, --- we also need to substitute over names. To do so, we must --- compute the *name substitution* induced by the *exports* --- of the module in question. A NameShape represents --- such a name substitution for a single module instantiation. --- The "shape" in the name comes from the fact that the computation --- of a name substitution is essentially the *shaping pass* from --- Backpack'14, but in a far more restricted form. - --- The name substitution for an export list is easy to explain. If we are --- filling the module variable , given an export N of the form --- M.n or {m'.n} (where n is an OccName), the induced name --- substitution is from {m.n} to N. So, for example, if we have --- A=impl:B, and the exports of impl:B are impl:B.f and --- impl:C.g, then our name substitution is {A.f} to impl:B.f --- and {A.g} to impl:C.g - - - - --- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes --- needs to refer to NameShape, and having TcRnTypes import --- NameShape (even by SOURCE) would cause a large number of --- modules to be pulled into the DynFlags cycle. -{- -data NameShape = NameShape { - ns_mod_name :: ModuleName, - ns_exports :: [AvailInfo], - ns_map :: OccEnv Name - } --} - --- NB: substitution functions need 'HscEnv' since they need the name cache --- to allocate new names if we change the 'Module' of a 'Name' - --- | Create an empty 'NameShape' (i.e., the renaming that --- would occur with an implementing module with no exports) --- for a specific hole @mod_name@. -emptyNameShape :: ModuleName -> NameShape -emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv - --- | Create a 'NameShape' corresponding to an implementing --- module for the hole @mod_name@ that exports a list of 'AvailInfo's. -mkNameShape :: ModuleName -> [AvailInfo] -> NameShape -mkNameShape mod_name as = - NameShape mod_name as $ mkOccEnv $ do - a <- as - n <- availName a : availNamesWithSelectors a - return (occName n, n) - --- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's --- with Backpack style mix-in linking. This is used solely when merging --- signatures together: we successively merge the exports of each --- signature until we have the final, full exports of the merged signature. --- --- What makes this operation nontrivial is what we are supposed to do when --- we want to merge in an export for M.T when we already have an existing --- export {H.T}. What should happen in this case is that {H.T} should be --- unified with @M.T@: we've determined a more *precise* identity for the --- export at 'OccName' @T@. --- --- Note that we don't do unrestricted unification: only name holes from --- @ns_mod_name ns@ are flexible. This is because we have a much more --- restricted notion of shaping than in Backpack'14: we do shaping --- *as* we do type-checking. Thus, once we shape a signature, its --- exports are *final* and we're not allowed to refine them further, -extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape) -extendNameShape hsc_env ns as = - case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of - Left err -> return (Left err) - Right nsubst -> do - as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns) - as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as - let new_avails = mergeAvails as1 as2 - return . Right $ ns { - ns_exports = new_avails, - -- TODO: stop repeatedly rebuilding the OccEnv - ns_map = mkOccEnv $ do - a <- new_avails - n <- availName a : availNames a - return (occName n, n) - } - --- | The export list associated with this 'NameShape' (i.e., what --- the exports of an implementing module which induces this 'NameShape' --- would be.) -nameShapeExports :: NameShape -> [AvailInfo] -nameShapeExports = ns_exports - --- | Given a 'Name', substitute it according to the 'NameShape' implied --- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module --- exports @M.T@. -substNameShape :: NameShape -> Name -> Name -substNameShape ns n | nameModule n == ns_module ns - , Just n' <- lookupOccEnv (ns_map ns) (occName n) - = n' - | otherwise - = n - --- | Like 'substNameShape', but returns @Nothing@ if no substitution --- works. -maybeSubstNameShape :: NameShape -> Name -> Maybe Name -maybeSubstNameShape ns n - | nameModule n == ns_module ns - = lookupOccEnv (ns_map ns) (occName n) - | otherwise - = Nothing - --- | The 'Module' of any 'Name's a 'NameShape' has action over. -ns_module :: NameShape -> Module -ns_module = mkHoleModule . ns_mod_name - -{- -************************************************************************ -* * - Name substitutions -* * -************************************************************************ --} - --- | Substitution on @{A.T}@. We enforce the invariant that the --- 'nameModule' of keys of this map have 'moduleUnitId' @hole@ --- (meaning that if we have a hole substitution, the keys of the map --- are never affected.) Alternately, this is isomorphic to --- @Map ('ModuleName', 'OccName') 'Name'@. -type ShNameSubst = NameEnv Name - --- NB: In this module, we actually only ever construct 'ShNameSubst' --- at a single 'ModuleName'. But 'ShNameSubst' is more convenient to --- work with. - --- | Substitute names in a 'Name'. -substName :: ShNameSubst -> Name -> Name -substName env n | Just n' <- lookupNameEnv env n = n' - | otherwise = n - --- | Substitute names in an 'AvailInfo'. This has special behavior --- for type constructors, where it is sufficient to substitute the 'availName' --- to induce a substitution on 'availNames'. -substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo -substNameAvailInfo _ env (Avail n) = return (Avail (substName env n)) -substNameAvailInfo hsc_env env (AvailTC n ns fs) = - let mb_mod = fmap nameModule (lookupNameEnv env n) - in AvailTC (substName env n) - <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns - <*> mapM (setNameFieldSelector hsc_env mb_mod) fs - --- | Set the 'Module' of a 'FieldSelector' -setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel -setNameFieldSelector _ Nothing f = return f -setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do - sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel - return (FieldLabel l b sel') - -{- -************************************************************************ -* * - AvailInfo merging -* * -************************************************************************ --} - --- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have --- already been unified ('uAvailInfos'). -mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo] -mergeAvails as1 as2 = - let mkNE as = mkNameEnv [(availName a, a) | a <- as] - in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2)) - -{- -************************************************************************ -* * - AvailInfo unification -* * -************************************************************************ --} - --- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@, --- with only name holes from @flexi@ unifiable (all other name holes rigid.) -uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst -uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $ - let mkOE as = listToUFM $ do a <- as - n <- availNames a - return (nameOccName n, a) - in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv - (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2))) - -- Edward: I have to say, this is pretty clever. - --- | Unify two 'AvailInfo's, given an existing substitution @subst@, --- with only name holes from @flexi@ unifiable (all other name holes rigid.) -uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo - -> Either SDoc ShNameSubst -uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2 -uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2 -uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine" - <+> ppr a1 <+> text "with" <+> ppr a2 - <+> parens (text "one is a type, the other is a plain identifier") - --- | Unify two 'Name's, given an existing substitution @subst@, --- with only name holes from @flexi@ unifiable (all other name holes rigid.) -uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst -uName flexi subst n1 n2 - | n1 == n2 = Right subst - | isFlexi n1 = uHoleName flexi subst n1 n2 - | isFlexi n2 = uHoleName flexi subst n2 n1 - | otherwise = Left (text "While merging export lists, could not unify" - <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra) - where - isFlexi n = isHoleName n && moduleName (nameModule n) == flexi - extra | isHoleName n1 || isHoleName n2 - = text "Neither name variable originates from the current signature." - | otherwise - = empty - --- | Unify a name @h@ which 'isHoleName' with another name, given an existing --- substitution @subst@, with only name holes from @flexi@ unifiable (all --- other name holes rigid.) -uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name - -> Either SDoc ShNameSubst -uHoleName flexi subst h n = - ASSERT( isHoleName h ) - case lookupNameEnv subst h of - Just n' -> uName flexi subst n' n - -- Do a quick check if the other name is substituted. - Nothing | Just n' <- lookupNameEnv subst n -> - ASSERT( isHoleName n ) uName flexi subst h n' - | otherwise -> - Right (extendNameEnv subst h n) diff --git a/backpack/RnModIface.hs b/backpack/RnModIface.hs deleted file mode 100644 --- a/backpack/RnModIface.hs +++ /dev/null @@ -1,707 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} - --- | This module implements interface renaming, which is --- used to rewrite interface files on the fly when we --- are doing indefinite typechecking and need instantiations --- of modules which do not necessarily exist yet. - -module RnModIface( - rnModIface, - rnModExports, - tcRnModIface, - tcRnModExports, - ) where - -#include "HsVersions.h" - -import SrcLoc -import Outputable -import HscTypes -import Module -import UniqFM -import Avail -import IfaceSyn -import FieldLabel -import Var -import ErrUtils - -import Name -import TcRnMonad -import Util -import Fingerprint -import BasicTypes - --- a bit vexing -import {-# SOURCE #-} LoadIface -import DynFlags - -import qualified Data.Traversable as T - -import Bag -import Data.IORef -import NameShape -import IfaceEnv - -tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a -tcRnMsgMaybe do_this = do - r <- liftIO $ do_this - case r of - Left errs -> do - addMessages (emptyBag, errs) - failM - Right x -> return x - -tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface -tcRnModIface x y z = do - hsc_env <- getTopEnv - tcRnMsgMaybe $ rnModIface hsc_env x y z - -tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo] -tcRnModExports x y = do - hsc_env <- getTopEnv - tcRnMsgMaybe $ rnModExports hsc_env x y - -failWithRn :: SDoc -> ShIfM a -failWithRn doc = do - errs_var <- fmap sh_if_errs getGblEnv - dflags <- getDynFlags - errs <- readTcRef errs_var - -- TODO: maybe associate this with a source location? - writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc) - failM - --- | What we have is a generalized ModIface, which corresponds to --- a module that looks like p[A=]:B. We need a *specific* ModIface, e.g. --- p[A=q():A]:B (or maybe even p[A=]:B) which we load --- up (either to merge it, or to just use during typechecking). --- --- Suppose we have: --- --- p[A=]:M ==> p[A=q():A]:M --- --- Substitute all occurrences of with q():A (renameHoleModule). --- Then, for any Name of form {A.T}, replace the Name with --- the Name according to the exports of the implementing module. --- This works even for p[A=]:M, since we just read in the --- exports of B.hi, which is assumed to be ready now. --- --- This function takes an optional 'NameShape', which can be used --- to further refine the identities in this interface: suppose --- we read a declaration for {H.T} but we actually know that this --- should be Foo.T; then we'll also rename this (this is used --- when loading an interface to merge it into a requirement.) -rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape - -> ModIface -> IO (Either ErrorMessages ModIface) -rnModIface hsc_env insts nsubst iface = do - initRnIface hsc_env iface insts nsubst $ do - mod <- rnModule (mi_module iface) - sig_of <- case mi_sig_of iface of - Nothing -> return Nothing - Just x -> fmap Just (rnModule x) - exports <- mapM rnAvailInfo (mi_exports iface) - decls <- mapM rnIfaceDecl' (mi_decls iface) - insts <- mapM rnIfaceClsInst (mi_insts iface) - fams <- mapM rnIfaceFamInst (mi_fam_insts iface) - deps <- rnDependencies (mi_deps iface) - -- TODO: - -- mi_rules - -- mi_vect_info (LOW PRIORITY) - return iface { mi_module = mod - , mi_sig_of = sig_of - , mi_insts = insts - , mi_fam_insts = fams - , mi_exports = exports - , mi_decls = decls - , mi_deps = deps } - --- | Rename just the exports of a 'ModIface'. Useful when we're doing --- shaping prior to signature merging. -rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo]) -rnModExports hsc_env insts iface - = initRnIface hsc_env iface insts Nothing - $ mapM rnAvailInfo (mi_exports iface) - -rnDependencies :: Rename Dependencies -rnDependencies deps = do - orphs <- rnDepModules dep_orphs deps - finsts <- rnDepModules dep_finsts deps - return deps { dep_orphs = orphs, dep_finsts = finsts } - -rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module] -rnDepModules sel deps = do - hsc_env <- getTopEnv - hmap <- getHoleSubst - -- NB: It's not necessary to test if we're doing signature renaming, - -- because ModIface will never contain module reference for itself - -- in these dependencies. - fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do - dflags <- getDynFlags - let mod' = renameHoleModule dflags hmap mod - iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env - $ loadSysInterface (text "rnDepModule") mod' - return (mod' : sel (mi_deps iface)) - -{- -************************************************************************ -* * - ModIface substitution -* * -************************************************************************ --} - --- | Run a computation in the 'ShIfM' monad. -initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape - -> ShIfM a -> IO (Either ErrorMessages a) -initRnIface hsc_env iface insts nsubst do_this = do - errs_var <- newIORef emptyBag - let dflags = hsc_dflags hsc_env - hsubst = listToUFM insts - rn_mod = renameHoleModule dflags hsubst - env = ShIfEnv { - sh_if_module = rn_mod (mi_module iface), - sh_if_semantic_module = rn_mod (mi_semantic_module iface), - sh_if_hole_subst = listToUFM insts, - sh_if_shape = nsubst, - sh_if_errs = errs_var - } - -- Modeled off of 'initTc' - res <- initTcRnIf 'c' hsc_env env () $ tryM do_this - msgs <- readIORef errs_var - case res of - Left _ -> return (Left msgs) - Right r | not (isEmptyBag msgs) -> return (Left msgs) - | otherwise -> return (Right r) - --- | Environment for 'ShIfM' monads. -data ShIfEnv = ShIfEnv { - -- What we are renaming the ModIface to. It assumed that - -- the original mi_module of the ModIface is - -- @generalizeModule (mi_module iface)@. - sh_if_module :: Module, - -- The semantic module that we are renaming to - sh_if_semantic_module :: Module, - -- Cached hole substitution, e.g. - -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@ - sh_if_hole_subst :: ShHoleSubst, - -- An optional name substitution to be applied when renaming - -- the names in the interface. If this is 'Nothing', then - -- we just load the target interface and look at the export - -- list to determine the renaming. - sh_if_shape :: Maybe NameShape, - -- Mutable reference to keep track of errors (similar to 'tcl_errs') - sh_if_errs :: IORef ErrorMessages - } - -getHoleSubst :: ShIfM ShHoleSubst -getHoleSubst = fmap sh_if_hole_subst getGblEnv - -type ShIfM = TcRnIf ShIfEnv () -type Rename a = a -> ShIfM a - - -rnModule :: Rename Module -rnModule mod = do - hmap <- getHoleSubst - dflags <- getDynFlags - return (renameHoleModule dflags hmap mod) - -rnAvailInfo :: Rename AvailInfo -rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n -rnAvailInfo (AvailTC n ns fs) = do - -- Why don't we rnIfaceGlobal the availName itself? It may not - -- actually be exported by the module it putatively is from, in - -- which case we won't be able to tell what the name actually - -- is. But for the availNames they MUST be exported, so they - -- will rename fine. - ns' <- mapM rnIfaceGlobal ns - fs' <- mapM rnFieldLabel fs - case ns' ++ map flSelector fs' of - [] -> panic "rnAvailInfoEmpty AvailInfo" - (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do - n' <- setNameModule (Just (nameModule rep)) n - return (AvailTC n' ns' fs') - -rnFieldLabel :: Rename FieldLabel -rnFieldLabel (FieldLabel l b sel) = do - sel' <- rnIfaceGlobal sel - return (FieldLabel l b sel') - - - - --- | The key function. This gets called on every Name embedded --- inside a ModIface. Our job is to take a Name from some --- generalized unit ID p[A=, B=], and change --- it to the correct name for a (partially) instantiated unit --- ID, e.g. p[A=q[]:A, B=]. --- --- There are two important things to do: --- --- If a hole is substituted with a real module implementation, --- we need to look at that actual implementation to determine what --- the true identity of this name should be. We'll do this by --- loading that module's interface and looking at the mi_exports. --- --- However, there is one special exception: when we are loading --- the interface of a requirement. In this case, we may not have --- the "implementing" interface, because we are reading this --- interface precisely to "merge it in". --- --- External case: --- p[A=]:A (and thisUnitId is something else) --- We are loading this in order to determine B.hi! So --- don't load B.hi to find the exports. --- --- Local case: --- p[A=]:A (and thisUnitId is p[A=]) --- This should not happen, because the rename is not necessary --- in this case, but if it does we shouldn't load A.hi! --- --- Compare me with 'tcIfaceGlobal'! - --- In effect, this function needs compute the name substitution on the --- fly. What it has is the name that we would like to substitute. --- If the name is not a hole name {M.x} (e.g. isHoleModule) then --- no renaming can take place (although the inner hole structure must --- be updated to account for the hole module renaming.) -rnIfaceGlobal :: Name -> ShIfM Name -rnIfaceGlobal n = do - hsc_env <- getTopEnv - let dflags = hsc_dflags hsc_env - iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv - mb_nsubst <- fmap sh_if_shape getGblEnv - hmap <- getHoleSubst - let m = nameModule n - m' = renameHoleModule dflags hmap m - case () of - -- Did we encounter {A.T} while renaming p[A=]:A? If so, - -- do NOT assume B.hi is available. - -- In this case, rename {A.T} to {B.T} but don't look up exports. - _ | m' == iface_semantic_mod - , isHoleModule m' - -- NB: this could be Nothing for computeExports, we have - -- nothing to say. - -> do n' <- setNameModule (Just m') n - case mb_nsubst of - Nothing -> return n' - Just nsubst -> - case maybeSubstNameShape nsubst n' of - -- TODO: would love to have context - -- TODO: This will give an unpleasant message if n' - -- is a constructor; then we'll suggest adding T - -- but it won't work. - Nothing -> failWithRn $ vcat [ - text "The identifier" <+> ppr (occName n') <+> - text "does not exist in the local signature.", - parens (text "Try adding it to the export list of the hsig file.") - ] - Just n'' -> return n'' - -- Fastpath: we are renaming p[H=]:A.T, in which case the - -- export list is irrelevant. - | not (isHoleModule m) - -> setNameModule (Just m') n - -- The substitution was from to p[]:A. - -- But this does not mean {A.T} goes to p[]:A.T: - -- p[]:A may reexport T from somewhere else. Do the name - -- substitution. Furthermore, we need - -- to make sure we pick the accurate name NOW, - -- or we might accidentally reject a merge. - | otherwise - -> do -- Make sure we look up the local interface if substitution - -- went from to . - let m'' = if isHoleModule m' - -- Pull out the local guy!! - then mkModule (thisPackage dflags) (moduleName m') - else m' - iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env - $ loadSysInterface (text "rnIfaceGlobal") m'' - let nsubst = mkNameShape (moduleName m) (mi_exports iface) - case maybeSubstNameShape nsubst n of - Nothing -> failWithRn $ vcat [ - text "The identifier" <+> ppr (occName n) <+> - -- NB: report m' because it's more user-friendly - text "does not exist in the signature for" <+> ppr m', - parens (text "Try adding it to the export list in that hsig file.") - ] - Just n' -> return n' - --- | Rename an implicit name, e.g., a DFun or coercion axiom. --- Here is where we ensure that DFuns have the correct module as described in --- Note [rnIfaceNeverExported]. -rnIfaceNeverExported :: Name -> ShIfM Name -rnIfaceNeverExported name = do - hmap <- getHoleSubst - dflags <- getDynFlags - iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv - let m = renameHoleModule dflags hmap $ nameModule name - -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined. - MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m ) - setNameModule (Just m) name - --- Note [rnIfaceNeverExported] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- For the high-level overview, see --- Note [Handling never-exported TyThings under Backpack] --- --- When we see a reference to an entity that was defined in a signature, --- 'rnIfaceGlobal' relies on the identifier in question being part of the --- exports of the implementing 'ModIface', so that we can use the exports to --- decide how to rename the identifier. Unfortunately, references to 'DFun's --- and 'CoAxiom's will run into trouble under this strategy, because they are --- never exported. --- --- Let us consider first what should happen in the absence of promotion. In --- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside --- the signature *that is defining it* (as there are no Core terms in --- typechecked-only interface files, there's no way for a reference to occur --- besides from the defining 'ClsInst' or closed type family). Thus, --- it doesn't really matter what names we give the DFun/CoAxiom, as long --- as it's consistent between the declaration site and the use site. --- --- We have to make sure that these bogus names don't get propagated, --- but it is fine: see Note [Signature merging DFuns] for the fixups --- to the names we do before writing out the merged interface. --- (It's even easier for instantiation, since the DFuns all get --- dropped entirely; the instances are reexported implicitly.) --- --- Unfortunately, this strategy is not enough in the presence of promotion --- (see bug #13149), where modules which import the signature may make --- reference to their coercions. It's not altogether clear how to --- fix this case, but it is definitely a bug! - --- PILES AND PILES OF BOILERPLATE - --- | Rename an 'IfaceClsInst', with special handling for an associated --- dictionary function. -rnIfaceClsInst :: Rename IfaceClsInst -rnIfaceClsInst cls_inst = do - n <- rnIfaceGlobal (ifInstCls cls_inst) - tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst) - - dfun <- rnIfaceNeverExported (ifDFun cls_inst) - return cls_inst { ifInstCls = n - , ifInstTys = tys - , ifDFun = dfun - } - -rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon) -rnMaybeIfaceTyCon Nothing = return Nothing -rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc - -rnIfaceFamInst :: Rename IfaceFamInst -rnIfaceFamInst d = do - fam <- rnIfaceGlobal (ifFamInstFam d) - tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d) - axiom <- rnIfaceGlobal (ifFamInstAxiom d) - return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom } - -rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl) -rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl - -rnIfaceDecl :: Rename IfaceDecl -rnIfaceDecl d@IfaceId{} = do - name <- case ifIdDetails d of - IfDFunId -> rnIfaceNeverExported (ifName d) - _ | isDefaultMethodOcc (occName (ifName d)) - -> rnIfaceNeverExported (ifName d) - -- Typeable bindings. See Note [Grand plan for Typeable]. - _ | isTypeableBindOcc (occName (ifName d)) - -> rnIfaceNeverExported (ifName d) - | otherwise -> rnIfaceGlobal (ifName d) - ty <- rnIfaceType (ifType d) - details <- rnIfaceIdDetails (ifIdDetails d) - info <- rnIfaceIdInfo (ifIdInfo d) - return d { ifName = name - , ifType = ty - , ifIdDetails = details - , ifIdInfo = info - } -rnIfaceDecl d@IfaceData{} = do - name <- rnIfaceGlobal (ifName d) - binders <- mapM rnIfaceTyConBinder (ifBinders d) - ctxt <- mapM rnIfaceType (ifCtxt d) - cons <- rnIfaceConDecls (ifCons d) - parent <- rnIfaceTyConParent (ifParent d) - return d { ifName = name - , ifBinders = binders - , ifCtxt = ctxt - , ifCons = cons - , ifParent = parent - } -rnIfaceDecl d@IfaceSynonym{} = do - name <- rnIfaceGlobal (ifName d) - binders <- mapM rnIfaceTyConBinder (ifBinders d) - syn_kind <- rnIfaceType (ifResKind d) - syn_rhs <- rnIfaceType (ifSynRhs d) - return d { ifName = name - , ifBinders = binders - , ifResKind = syn_kind - , ifSynRhs = syn_rhs - } -rnIfaceDecl d@IfaceFamily{} = do - name <- rnIfaceGlobal (ifName d) - binders <- mapM rnIfaceTyConBinder (ifBinders d) - fam_kind <- rnIfaceType (ifResKind d) - fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d) - return d { ifName = name - , ifBinders = binders - , ifResKind = fam_kind - , ifFamFlav = fam_flav - } -rnIfaceDecl d@IfaceClass{} = do - name <- rnIfaceGlobal (ifName d) - binders <- mapM rnIfaceTyConBinder (ifBinders d) - body <- rnIfaceClassBody (ifBody d) - return d { ifName = name - , ifBinders = binders - , ifBody = body - } -rnIfaceDecl d@IfaceAxiom{} = do - name <- rnIfaceNeverExported (ifName d) - tycon <- rnIfaceTyCon (ifTyCon d) - ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d) - return d { ifName = name - , ifTyCon = tycon - , ifAxBranches = ax_branches - } -rnIfaceDecl d@IfacePatSyn{} = do - name <- rnIfaceGlobal (ifName d) - let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b - pat_matcher <- rnPat (ifPatMatcher d) - pat_builder <- T.traverse rnPat (ifPatBuilder d) - pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d) - pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d) - pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d) - pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d) - pat_args <- mapM rnIfaceType (ifPatArgs d) - pat_ty <- rnIfaceType (ifPatTy d) - return d { ifName = name - , ifPatMatcher = pat_matcher - , ifPatBuilder = pat_builder - , ifPatUnivBndrs = pat_univ_bndrs - , ifPatExBndrs = pat_ex_bndrs - , ifPatProvCtxt = pat_prov_ctxt - , ifPatReqCtxt = pat_req_ctxt - , ifPatArgs = pat_args - , ifPatTy = pat_ty - } - -rnIfaceClassBody :: Rename IfaceClassBody -rnIfaceClassBody IfAbstractClass = return IfAbstractClass -rnIfaceClassBody d@IfConcreteClass{} = do - ctxt <- mapM rnIfaceType (ifClassCtxt d) - ats <- mapM rnIfaceAT (ifATs d) - sigs <- mapM rnIfaceClassOp (ifSigs d) - return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs } - -rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav -rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs))) - = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n - <*> mapM rnIfaceAxBranch axs) -rnIfaceFamTyConFlav flav = pure flav - -rnIfaceAT :: Rename IfaceAT -rnIfaceAT (IfaceAT decl mb_ty) - = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty - -rnIfaceTyConParent :: Rename IfaceTyConParent -rnIfaceTyConParent (IfDataInstance n tc args) - = IfDataInstance <$> rnIfaceGlobal n - <*> rnIfaceTyCon tc - <*> rnIfaceTcArgs args -rnIfaceTyConParent IfNoParent = pure IfNoParent - -rnIfaceConDecls :: Rename IfaceConDecls -rnIfaceConDecls (IfDataTyCon ds) - = IfDataTyCon <$> mapM rnIfaceConDecl ds -rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d -rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon - -rnIfaceConDecl :: Rename IfaceConDecl -rnIfaceConDecl d = do - con_name <- rnIfaceGlobal (ifConName d) - con_ex_tvs <- mapM rnIfaceForAllBndr (ifConExTvs d) - let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t - con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d) - con_ctxt <- mapM rnIfaceType (ifConCtxt d) - con_arg_tys <- mapM rnIfaceType (ifConArgTys d) - con_fields <- mapM rnFieldLabel (ifConFields d) - let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co - rnIfaceBang bang = pure bang - con_stricts <- mapM rnIfaceBang (ifConStricts d) - return d { ifConName = con_name - , ifConExTvs = con_ex_tvs - , ifConEqSpec = con_eq_spec - , ifConCtxt = con_ctxt - , ifConArgTys = con_arg_tys - , ifConFields = con_fields - , ifConStricts = con_stricts - } - -rnIfaceClassOp :: Rename IfaceClassOp -rnIfaceClassOp (IfaceClassOp n ty dm) = - IfaceClassOp <$> rnIfaceGlobal n - <*> rnIfaceType ty - <*> rnMaybeDefMethSpec dm - -rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType)) -rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty -rnMaybeDefMethSpec mb = return mb - -rnIfaceAxBranch :: Rename IfaceAxBranch -rnIfaceAxBranch d = do - ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d) - lhs <- rnIfaceTcArgs (ifaxbLHS d) - rhs <- rnIfaceType (ifaxbRHS d) - return d { ifaxbTyVars = ty_vars - , ifaxbLHS = lhs - , ifaxbRHS = rhs } - -rnIfaceIdInfo :: Rename IfaceIdInfo -rnIfaceIdInfo NoInfo = pure NoInfo -rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is - -rnIfaceInfoItem :: Rename IfaceInfoItem -rnIfaceInfoItem (HsUnfold lb if_unf) - = HsUnfold lb <$> rnIfaceUnfolding if_unf -rnIfaceInfoItem i - = pure i - -rnIfaceUnfolding :: Rename IfaceUnfolding -rnIfaceUnfolding (IfCoreUnfold stable if_expr) - = IfCoreUnfold stable <$> rnIfaceExpr if_expr -rnIfaceUnfolding (IfCompulsory if_expr) - = IfCompulsory <$> rnIfaceExpr if_expr -rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr) - = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr -rnIfaceUnfolding (IfDFunUnfold bs ops) - = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops - -rnIfaceExpr :: Rename IfaceExpr -rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name) -rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl -rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty -rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co -rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args -rnIfaceExpr (IfaceLam lam_bndr expr) - = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr -rnIfaceExpr (IfaceApp fun arg) - = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg -rnIfaceExpr (IfaceCase scrut case_bndr alts) - = IfaceCase <$> rnIfaceExpr scrut - <*> pure case_bndr - <*> mapM rnIfaceAlt alts -rnIfaceExpr (IfaceECase scrut ty) - = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty -rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) - = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs) - <*> rnIfaceExpr body -rnIfaceExpr (IfaceLet (IfaceRec pairs) body) - = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) -> - (,) <$> rnIfaceLetBndr bndr - <*> rnIfaceExpr rhs) pairs) - <*> rnIfaceExpr body -rnIfaceExpr (IfaceCast expr co) - = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co -rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit) -rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty -rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr - -rnIfaceBndrs :: Rename [IfaceBndr] -rnIfaceBndrs = mapM rnIfaceBndr - -rnIfaceBndr :: Rename IfaceBndr -rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty) -rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceIdBndr <$> rnIfaceTvBndr tv_bndr - -rnIfaceTvBndr :: Rename IfaceTvBndr -rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind - -rnIfaceTyConBinder :: Rename IfaceTyConBinder -rnIfaceTyConBinder (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis - -rnIfaceAlt :: Rename IfaceAlt -rnIfaceAlt (conalt, names, rhs) - = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs - -rnIfaceConAlt :: Rename IfaceConAlt -rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ -rnIfaceConAlt alt = pure alt - -rnIfaceLetBndr :: Rename IfaceLetBndr -rnIfaceLetBndr (IfLetBndr fs ty info jpi) - = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi - -rnIfaceLamBndr :: Rename IfaceLamBndr -rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot - -rnIfaceCo :: Rename IfaceCoercion -rnIfaceCo (IfaceReflCo role ty) = IfaceReflCo role <$> rnIfaceType ty -rnIfaceCo (IfaceFunCo role co1 co2) - = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2 -rnIfaceCo (IfaceTyConAppCo role tc cos) - = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos -rnIfaceCo (IfaceAppCo co1 co2) - = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2 -rnIfaceCo (IfaceForAllCo bndr co1 co2) - = IfaceForAllCo <$> rnIfaceTvBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2 -rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl -rnIfaceCo (IfaceAxiomInstCo n i cs) - = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs -rnIfaceCo (IfaceUnivCo s r t1 t2) - = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2 -rnIfaceCo (IfaceSymCo c) - = IfaceSymCo <$> rnIfaceCo c -rnIfaceCo (IfaceTransCo c1 c2) - = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 -rnIfaceCo (IfaceInstCo c1 c2) - = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 -rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c -rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c -rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c -rnIfaceCo (IfaceAxiomRuleCo ax cos) - = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos -rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c -rnIfaceCo (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 - -rnIfaceTyCon :: Rename IfaceTyCon -rnIfaceTyCon (IfaceTyCon n info) - = IfaceTyCon <$> rnIfaceGlobal n <*> pure info - -rnIfaceExprs :: Rename [IfaceExpr] -rnIfaceExprs = mapM rnIfaceExpr - -rnIfaceIdDetails :: Rename IfaceIdDetails -rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b -rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b -rnIfaceIdDetails details = pure details - -rnIfaceType :: Rename IfaceType -rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n) -rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n) -rnIfaceType (IfaceAppTy t1 t2) - = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceType t2 -rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l) -rnIfaceType (IfaceFunTy t1 t2) - = IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2 -rnIfaceType (IfaceDFunTy t1 t2) - = IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2 -rnIfaceType (IfaceTupleTy s i tks) - = IfaceTupleTy s i <$> rnIfaceTcArgs tks -rnIfaceType (IfaceTyConApp tc tks) - = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceTcArgs tks -rnIfaceType (IfaceForAllTy tv t) - = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t -rnIfaceType (IfaceCoercionTy co) - = IfaceCoercionTy <$> rnIfaceCo co -rnIfaceType (IfaceCastTy ty co) - = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co - -rnIfaceForAllBndr :: Rename IfaceForAllBndr -rnIfaceForAllBndr (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis - -rnIfaceTcArgs :: Rename IfaceTcArgs -rnIfaceTcArgs (ITC_Invis t ts) = ITC_Invis <$> rnIfaceType t <*> rnIfaceTcArgs ts -rnIfaceTcArgs (ITC_Vis t ts) = ITC_Vis <$> rnIfaceType t <*> rnIfaceTcArgs ts -rnIfaceTcArgs ITC_Nil = pure ITC_Nil diff --git a/basicTypes/Avail.hs b/basicTypes/Avail.hs deleted file mode 100644 --- a/basicTypes/Avail.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE CPP #-} --- --- (c) The University of Glasgow --- - -#include "HsVersions.h" - -module Avail ( - Avails, - AvailInfo(..), - avail, - availsToNameSet, - availsToNameSetWithSelectors, - availsToNameEnv, - availName, availNames, availNonFldNames, - availNamesWithSelectors, - availFlds, - stableAvailCmp, - plusAvail, - trimAvail, - filterAvail, - filterAvails, - nubAvails - - - ) where - -import Name -import NameEnv -import NameSet - -import FieldLabel -import Binary -import ListSetOps -import Outputable -import Util - -import Data.List ( find ) -import Data.Function - --- ----------------------------------------------------------------------------- --- The AvailInfo type - --- | Records what things are "available", i.e. in scope -data AvailInfo = Avail Name -- ^ An ordinary identifier in scope - | AvailTC Name - [Name] - [FieldLabel] - -- ^ A type or class in scope. Parameters: - -- - -- 1) The name of the type or class - -- 2) The available pieces of type or class, - -- excluding field selectors. - -- 3) The record fields of the type - -- (see Note [Representing fields in AvailInfo]). - -- - -- The AvailTC Invariant: - -- * If the type or class is itself - -- to be in scope, it must be - -- *first* in this list. Thus, - -- typically: @AvailTC Eq [Eq, ==, \/=]@ - deriving( Eq ) - -- Equality used when deciding if the - -- interface has changed - --- | A collection of 'AvailInfo' - several things that are \"available\" -type Avails = [AvailInfo] - -{- -Note [Representing fields in AvailInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When -XDuplicateRecordFields is disabled (the normal case), a -datatype like - - data T = MkT { foo :: Int } - -gives rise to the AvailInfo - - AvailTC T [T, MkT] [FieldLabel "foo" False foo], - -whereas if -XDuplicateRecordFields is enabled it gives - - AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT] - -since the label does not match the selector name. - -The labels in a field list are not necessarily unique: -data families allow the same parent (the family tycon) to have -multiple distinct fields with the same label. For example, - - data family F a - data instance F Int = MkFInt { foo :: Int } - data instance F Bool = MkFBool { foo :: Bool} - -gives rise to - - AvailTC F [F, MkFInt, MkFBool] - [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" True $sel:foo:MkFBool]. - -Moreover, note that the flIsOverloaded flag need not be the same for -all the elements of the list. In the example above, this occurs if -the two data instances are defined in different modules, one with -`-XDuplicateRecordFields` enabled and one with it disabled. Thus it -is possible to have - - AvailTC F [F, MkFInt, MkFBool] - [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" False foo]. - -If the two data instances are defined in different modules, both -without `-XDuplicateRecordFields`, it will be impossible to export -them from the same module (even with `-XDuplicateRecordfields` -enabled), because they would be represented identically. The -workaround here is to enable `-XDuplicateRecordFields` on the defining -modules. --} - --- | Compare lexicographically -stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering -stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 -stableAvailCmp (Avail {}) (AvailTC {}) = LT -stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) = - (n `stableNameCmp` m) `thenCmp` - (cmpList stableNameCmp ns ms) `thenCmp` - (cmpList (stableNameCmp `on` flSelector) nfs mfs) -stableAvailCmp (AvailTC {}) (Avail {}) = GT - -avail :: Name -> AvailInfo -avail n = Avail n - --- ----------------------------------------------------------------------------- --- Operations on AvailInfo - -availsToNameSet :: [AvailInfo] -> NameSet -availsToNameSet avails = foldr add emptyNameSet avails - where add avail set = extendNameSetList set (availNames avail) - -availsToNameSetWithSelectors :: [AvailInfo] -> NameSet -availsToNameSetWithSelectors avails = foldr add emptyNameSet avails - where add avail set = extendNameSetList set (availNamesWithSelectors avail) - -availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo -availsToNameEnv avails = foldr add emptyNameEnv avails - where add avail env = extendNameEnvList env - (zip (availNames avail) (repeat avail)) - --- | Just the main name made available, i.e. not the available pieces --- of type or class brought into scope by the 'GenAvailInfo' -availName :: AvailInfo -> Name -availName (Avail n) = n -availName (AvailTC n _ _) = n - --- | All names made available by the availability information (excluding overloaded selectors) -availNames :: AvailInfo -> [Name] -availNames (Avail n) = [n] -availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ] - --- | All names made available by the availability information (including overloaded selectors) -availNamesWithSelectors :: AvailInfo -> [Name] -availNamesWithSelectors (Avail n) = [n] -availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs - --- | Names for non-fields made available by the availability information -availNonFldNames :: AvailInfo -> [Name] -availNonFldNames (Avail n) = [n] -availNonFldNames (AvailTC _ ns _) = ns - --- | Fields made available by the availability information -availFlds :: AvailInfo -> [FieldLabel] -availFlds (AvailTC _ _ fs) = fs -availFlds _ = [] - - --- ----------------------------------------------------------------------------- --- Utility - -plusAvail :: AvailInfo -> AvailInfo -> AvailInfo -plusAvail a1 a2 - | debugIsOn && availName a1 /= availName a2 - = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2]) -plusAvail a1@(Avail {}) (Avail {}) = a1 -plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2 -plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1 -plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2) - = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first - (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) - (fs1 `unionLists` fs2) - (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) - (fs1 `unionLists` fs2) - (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) - (fs1 `unionLists` fs2) - (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) - (fs1 `unionLists` fs2) -plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) - = AvailTC n1 ss1 (fs1 `unionLists` fs2) -plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) - = AvailTC n1 ss2 (fs1 `unionLists` fs2) -plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) - --- | trims an 'AvailInfo' to keep only a single name -trimAvail :: AvailInfo -> Name -> AvailInfo -trimAvail (Avail n) _ = Avail n -trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of - Just x -> AvailTC n [] [x] - Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] - --- | filters 'AvailInfo's by the given predicate -filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] -filterAvails keep avails = foldr (filterAvail keep) [] avails - --- | filters an 'AvailInfo' by the given predicate -filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] -filterAvail keep ie rest = - case ie of - Avail n | keep n -> ie : rest - | otherwise -> rest - AvailTC tc ns fs -> - let ns' = filter keep ns - fs' = filter (keep . flSelector) fs in - if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest - - --- | Combines 'AvailInfo's from the same family --- 'avails' may have several items with the same availName --- E.g import Ix( Ix(..), index ) --- will give Ix(Ix,index,range) and Ix(index) --- We want to combine these; addAvail does that -nubAvails :: [AvailInfo] -> [AvailInfo] -nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails) - where - add env avail = extendNameEnv_C plusAvail env (availName avail) avail - --- ----------------------------------------------------------------------------- --- Printing - -instance Outputable AvailInfo where - ppr = pprAvail - -pprAvail :: AvailInfo -> SDoc -pprAvail (Avail n) - = ppr n -pprAvail (AvailTC n ns fs) - = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi - , fsep (punctuate comma (map (ppr . flLabel) fs))]) - -instance Binary AvailInfo where - put_ bh (Avail aa) = do - putByte bh 0 - put_ bh aa - put_ bh (AvailTC ab ac ad) = do - putByte bh 1 - put_ bh ab - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Avail aa) - _ -> do ab <- get bh - ac <- get bh - ad <- get bh - return (AvailTC ab ac ad) diff --git a/basicTypes/BasicTypes.hs b/basicTypes/BasicTypes.hs deleted file mode 100644 --- a/basicTypes/BasicTypes.hs +++ /dev/null @@ -1,1511 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 - -\section[BasicTypes]{Miscellanous types} - -This module defines a miscellaneously collection of very simple -types that - -\begin{itemize} -\item have no other obvious home -\item don't depend on any other complicated types -\item are used in more than one "part" of the compiler -\end{itemize} --} - -{-# LANGUAGE DeriveDataTypeable #-} - -module BasicTypes( - Version, bumpVersion, initialVersion, - - LeftOrRight(..), - pickLR, - - ConTag, ConTagZ, fIRST_TAG, - - Arity, RepArity, JoinArity, - - Alignment, - - FunctionOrData(..), - - WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..), - - Fixity(..), FixityDirection(..), - defaultFixity, maxPrecedence, minPrecedence, - negateFixity, funTyFixity, - compareFixity, - LexicalFixity(..), - - RecFlag(..), isRec, isNonRec, boolToRecFlag, - Origin(..), isGenerated, - - RuleName, pprRuleName, - - TopLevelFlag(..), isTopLevel, isNotTopLevel, - - DerivStrategy(..), - - OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, - hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, - - Boxity(..), isBoxed, - - TyPrec(..), maybeParen, - - TupleSort(..), tupleSortBoxity, boxityTupleSort, - tupleParens, - - sumParens, pprAlternative, - - -- ** The OneShotInfo type - OneShotInfo(..), - noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, - bestOneShot, worstOneShot, - - OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc, - isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, - strongLoopBreaker, weakLoopBreaker, - - InsideLam, insideLam, notInsideLam, - OneBranch, oneBranch, notOneBranch, - InterestingCxt, - TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, - isAlwaysTailCalled, - - EP(..), - - DefMethSpec(..), - SwapFlag(..), flipSwap, unSwap, isSwapped, - - CompilerPhase(..), PhaseNum, - - Activation(..), isActive, isActiveIn, competesWith, - isNeverActive, isAlwaysActive, isEarlyActive, - - RuleMatchInfo(..), isConLike, isFunLike, - InlineSpec(..), isEmptyInlineSpec, - InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, - neverInlinePragma, dfunInlinePragma, - isDefaultInlinePragma, - isInlinePragma, isInlinablePragma, isAnyInlinePragma, - inlinePragmaSpec, inlinePragmaSat, - inlinePragmaActivation, inlinePragmaRuleMatchInfo, - setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, - pprInline, pprInlineDebug, - - SuccessFlag(..), succeeded, failed, successIf, - - FractionalLit(..), negateFractionalLit, integralFractionalLit, - - SourceText(..), pprWithSourceText, - - IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, - - SpliceExplicitFlag(..) - ) where - -import FastString -import Outputable -import SrcLoc ( Located,unLoc ) -import Data.Data hiding (Fixity, Prefix, Infix) -import Data.Function (on) - -{- -************************************************************************ -* * - Binary choice -* * -************************************************************************ --} - -data LeftOrRight = CLeft | CRight - deriving( Eq, Data ) - -pickLR :: LeftOrRight -> (a,a) -> a -pickLR CLeft (l,_) = l -pickLR CRight (_,r) = r - -instance Outputable LeftOrRight where - ppr CLeft = text "Left" - ppr CRight = text "Right" - -{- -************************************************************************ -* * -\subsection[Arity]{Arity} -* * -************************************************************************ --} - --- | The number of value arguments that can be applied to a value before it does --- "real work". So: --- fib 100 has arity 0 --- \x -> fib x has arity 1 --- See also Note [Definition of arity] in CoreArity -type Arity = Int - --- | Representation Arity --- --- The number of represented arguments that can be applied to a value before it does --- "real work". So: --- fib 100 has representation arity 0 --- \x -> fib x has representation arity 1 --- \(# x, y #) -> fib (x + y) has representation arity 2 -type RepArity = Int - --- | The number of arguments that a join point takes. Unlike the arity of a --- function, this is a purely syntactic property and is fixed when the join --- point is created (or converted from a value). Both type and value arguments --- are counted. -type JoinArity = Int - -{- -************************************************************************ -* * - Constructor tags -* * -************************************************************************ --} - --- | Constructor Tag --- --- Type of the tags associated with each constructor possibility or superclass --- selector -type ConTag = Int - --- | A *zero-indexed* constructor tag -type ConTagZ = Int - -fIRST_TAG :: ConTag --- ^ Tags are allocated from here for real constructors --- or for superclass selectors -fIRST_TAG = 1 - -{- -************************************************************************ -* * -\subsection[Alignment]{Alignment} -* * -************************************************************************ --} - -type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). - -{- -************************************************************************ -* * - One-shot information -* * -************************************************************************ --} - --- | If the 'Id' is a lambda-bound variable then it may have lambda-bound --- variable info. Sometimes we know whether the lambda binding this variable --- is a \"one-shot\" lambda; that is, whether it is applied at most once. --- --- This information may be useful in optimisation, as computations may --- safely be floated inside such a lambda without risk of duplicating --- work. -data OneShotInfo - = NoOneShotInfo -- ^ No information - | OneShotLam -- ^ The lambda is applied at most once. - deriving (Eq) - --- | It is always safe to assume that an 'Id' has no lambda-bound variable information -noOneShotInfo :: OneShotInfo -noOneShotInfo = NoOneShotInfo - -isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool -isOneShotInfo OneShotLam = True -isOneShotInfo _ = False - -hasNoOneShotInfo NoOneShotInfo = True -hasNoOneShotInfo _ = False - -worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo -worstOneShot NoOneShotInfo _ = NoOneShotInfo -worstOneShot OneShotLam os = os - -bestOneShot NoOneShotInfo os = os -bestOneShot OneShotLam _ = OneShotLam - -pprOneShotInfo :: OneShotInfo -> SDoc -pprOneShotInfo NoOneShotInfo = empty -pprOneShotInfo OneShotLam = text "OneShot" - -instance Outputable OneShotInfo where - ppr = pprOneShotInfo - -{- -************************************************************************ -* * - Swap flag -* * -************************************************************************ --} - -data SwapFlag - = NotSwapped -- Args are: actual, expected - | IsSwapped -- Args are: expected, actual - -instance Outputable SwapFlag where - ppr IsSwapped = text "Is-swapped" - ppr NotSwapped = text "Not-swapped" - -flipSwap :: SwapFlag -> SwapFlag -flipSwap IsSwapped = NotSwapped -flipSwap NotSwapped = IsSwapped - -isSwapped :: SwapFlag -> Bool -isSwapped IsSwapped = True -isSwapped NotSwapped = False - -unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b -unSwap NotSwapped f a b = f a b -unSwap IsSwapped f a b = f b a - -{- -************************************************************************ -* * -\subsection[FunctionOrData]{FunctionOrData} -* * -************************************************************************ --} - -data FunctionOrData = IsFunction | IsData - deriving (Eq, Ord, Data) - -instance Outputable FunctionOrData where - ppr IsFunction = text "(function)" - ppr IsData = text "(data)" - -{- -************************************************************************ -* * -\subsection[Version]{Module and identifier version numbers} -* * -************************************************************************ --} - -type Version = Int - -bumpVersion :: Version -> Version -bumpVersion v = v+1 - -initialVersion :: Version -initialVersion = 1 - -{- -************************************************************************ -* * - Deprecations -* * -************************************************************************ --} - --- | A String Literal in the source, including its original raw format for use by --- source to source manipulation tools. -data StringLiteral = StringLiteral - { sl_st :: SourceText, -- literal raw source. - -- See not [Literal source text] - sl_fs :: FastString -- literal string value - } deriving Data - -instance Eq StringLiteral where - (StringLiteral _ a) == (StringLiteral _ b) = a == b - -instance Outputable StringLiteral where - ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) - --- | Warning Text --- --- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt = WarningTxt (Located SourceText) - [Located StringLiteral] - | DeprecatedTxt (Located SourceText) - [Located StringLiteral] - deriving (Eq, Data) - -instance Outputable WarningTxt where - ppr (WarningTxt lsrc ws) - = case unLoc lsrc of - NoSourceText -> pp_ws ws - SourceText src -> text src <+> pp_ws ws <+> text "#-}" - - ppr (DeprecatedTxt lsrc ds) - = case unLoc lsrc of - NoSourceText -> pp_ws ds - SourceText src -> text src <+> pp_ws ds <+> text "#-}" - -pp_ws :: [Located StringLiteral] -> SDoc -pp_ws [l] = ppr $ unLoc l -pp_ws ws - = text "[" - <+> vcat (punctuate comma (map (ppr . unLoc) ws)) - <+> text "]" - - -pprWarningTxtForMsg :: WarningTxt -> SDoc -pprWarningTxtForMsg (WarningTxt _ ws) - = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) -pprWarningTxtForMsg (DeprecatedTxt _ ds) - = text "Deprecated:" <+> - doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) - -{- -************************************************************************ -* * - Rules -* * -************************************************************************ --} - -type RuleName = FastString - -pprRuleName :: RuleName -> SDoc -pprRuleName rn = doubleQuotes (ftext rn) - -{- -************************************************************************ -* * -\subsection[Fixity]{Fixity info} -* * -************************************************************************ --} - ------------------------- -data Fixity = Fixity SourceText Int FixityDirection - -- Note [Pragma source text] - deriving Data - -instance Outputable Fixity where - ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec] - -instance Eq Fixity where -- Used to determine if two fixities conflict - (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2 - ------------------------- -data FixityDirection = InfixL | InfixR | InfixN - deriving (Eq, Data) - -instance Outputable FixityDirection where - ppr InfixL = text "infixl" - ppr InfixR = text "infixr" - ppr InfixN = text "infix" - ------------------------- -maxPrecedence, minPrecedence :: Int -maxPrecedence = 9 -minPrecedence = 0 - -defaultFixity :: Fixity -defaultFixity = Fixity NoSourceText maxPrecedence InfixL - -negateFixity, funTyFixity :: Fixity --- Wired-in fixities -negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate -funTyFixity = Fixity NoSourceText 0 InfixR -- Fixity of '->' - -{- -Consider - -\begin{verbatim} - a `op1` b `op2` c -\end{verbatim} -@(compareFixity op1 op2)@ tells which way to arrange application, or -whether there's an error. --} - -compareFixity :: Fixity -> Fixity - -> (Bool, -- Error please - Bool) -- Associate to the right: a op1 (b op2 c) -compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) - = case prec1 `compare` prec2 of - GT -> left - LT -> right - EQ -> case (dir1, dir2) of - (InfixR, InfixR) -> right - (InfixL, InfixL) -> left - _ -> error_please - where - right = (False, True) - left = (False, False) - error_please = (True, False) - --- |Captures the fixity of declarations as they are parsed. This is not --- necessarily the same as the fixity declaration, as the normal fixity may be --- overridden using parens or backticks. -data LexicalFixity = Prefix | Infix deriving (Typeable,Data,Eq) - -instance Outputable LexicalFixity where - ppr Prefix = text "Prefix" - ppr Infix = text "Infix" - -{- -************************************************************************ -* * -\subsection[Top-level/local]{Top-level/not-top level flag} -* * -************************************************************************ --} - -data TopLevelFlag - = TopLevel - | NotTopLevel - -isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool - -isNotTopLevel NotTopLevel = True -isNotTopLevel TopLevel = False - -isTopLevel TopLevel = True -isTopLevel NotTopLevel = False - -instance Outputable TopLevelFlag where - ppr TopLevel = text "" - ppr NotTopLevel = text "" - -{- -************************************************************************ -* * - Boxity flag -* * -************************************************************************ --} - -data Boxity - = Boxed - | Unboxed - deriving( Eq, Data ) - -isBoxed :: Boxity -> Bool -isBoxed Boxed = True -isBoxed Unboxed = False - -instance Outputable Boxity where - ppr Boxed = text "Boxed" - ppr Unboxed = text "Unboxed" - -{- -************************************************************************ -* * - Recursive/Non-Recursive flag -* * -************************************************************************ --} - --- | Recursivity Flag -data RecFlag = Recursive - | NonRecursive - deriving( Eq, Data ) - -isRec :: RecFlag -> Bool -isRec Recursive = True -isRec NonRecursive = False - -isNonRec :: RecFlag -> Bool -isNonRec Recursive = False -isNonRec NonRecursive = True - -boolToRecFlag :: Bool -> RecFlag -boolToRecFlag True = Recursive -boolToRecFlag False = NonRecursive - -instance Outputable RecFlag where - ppr Recursive = text "Recursive" - ppr NonRecursive = text "NonRecursive" - -{- -************************************************************************ -* * - Code origin -* * -************************************************************************ --} - -data Origin = FromSource - | Generated - deriving( Eq, Data ) - -isGenerated :: Origin -> Bool -isGenerated Generated = True -isGenerated FromSource = False - -instance Outputable Origin where - ppr FromSource = text "FromSource" - ppr Generated = text "Generated" - -{- -************************************************************************ -* * - Deriving strategies -* * -************************************************************************ --} - --- | Which technique the user explicitly requested when deriving an instance. -data DerivStrategy - -- See Note [Deriving strategies] in TcDeriv - = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a - -- custom instance for the data type. This only works - -- for certain types that GHC knows about (e.g., 'Eq', - -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled, - -- etc.) - | AnyclassStrategy -- ^ @-XDeriveAnyClass@ - | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ - deriving (Eq, Data) - -instance Outputable DerivStrategy where - ppr StockStrategy = text "stock" - ppr AnyclassStrategy = text "anyclass" - ppr NewtypeStrategy = text "newtype" - -{- -************************************************************************ -* * - Instance overlap flag -* * -************************************************************************ --} - --- | The semantics allowed for overlapping instances for a particular --- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a --- explanation of the `isSafeOverlap` field. --- --- - 'ApiAnnotation.AnnKeywordId' : --- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or --- @'\{-\# OVERLAPPING'@ or --- @'\{-\# OVERLAPS'@ or --- @'\{-\# INCOHERENT'@, --- 'ApiAnnotation.AnnClose' @`\#-\}`@, - --- For details on above see note [Api annotations] in ApiAnnotation -data OverlapFlag = OverlapFlag - { overlapMode :: OverlapMode - , isSafeOverlap :: Bool - } deriving (Eq, Data) - -setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag -setOverlapModeMaybe f Nothing = f -setOverlapModeMaybe f (Just m) = f { overlapMode = m } - -hasIncoherentFlag :: OverlapMode -> Bool -hasIncoherentFlag mode = - case mode of - Incoherent _ -> True - _ -> False - -hasOverlappableFlag :: OverlapMode -> Bool -hasOverlappableFlag mode = - case mode of - Overlappable _ -> True - Overlaps _ -> True - Incoherent _ -> True - _ -> False - -hasOverlappingFlag :: OverlapMode -> Bool -hasOverlappingFlag mode = - case mode of - Overlapping _ -> True - Overlaps _ -> True - Incoherent _ -> True - _ -> False - -data OverlapMode -- See Note [Rules for instance lookup] in InstEnv - = NoOverlap SourceText - -- See Note [Pragma source text] - -- ^ This instance must not overlap another `NoOverlap` instance. - -- However, it may be overlapped by `Overlapping` instances, - -- and it may overlap `Overlappable` instances. - - - | Overlappable SourceText - -- See Note [Pragma source text] - -- ^ Silently ignore this instance if you find a - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instance Foo [Int] - -- instance {-# OVERLAPPABLE #-} Foo [a] - -- - -- Since the second instance has the Overlappable flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - - - | Overlapping SourceText - -- See Note [Pragma source text] - -- ^ Silently ignore any more general instances that may be - -- used to solve the constraint. - -- - -- Example: constraint (Foo [Int]) - -- instance {-# OVERLAPPING #-} Foo [Int] - -- instance Foo [a] - -- - -- Since the first instance has the Overlapping flag, - -- the second---more general---instance will be ignored (otherwise - -- it is ambiguous which to choose) - - - | Overlaps SourceText - -- See Note [Pragma source text] - -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. - - | Incoherent SourceText - -- See Note [Pragma source text] - -- ^ Behave like Overlappable and Overlapping, and in addition pick - -- an an arbitrary one if there are multiple matching candidates, and - -- don't worry about later instantiation - -- - -- Example: constraint (Foo [b]) - -- instance {-# INCOHERENT -} Foo [Int] - -- instance Foo [a] - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen. See also note [Incoherent instances] in InstEnv - - deriving (Eq, Data) - - -instance Outputable OverlapFlag where - ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) - -instance Outputable OverlapMode where - ppr (NoOverlap _) = empty - ppr (Overlappable _) = text "[overlappable]" - ppr (Overlapping _) = text "[overlapping]" - ppr (Overlaps _) = text "[overlap ok]" - ppr (Incoherent _) = text "[incoherent]" - -pprSafeOverlap :: Bool -> SDoc -pprSafeOverlap True = text "[safe]" -pprSafeOverlap False = empty - -{- -************************************************************************ -* * - Type precedence -* * -************************************************************************ --} - -data TyPrec -- See Note [Precedence in types] in TyCoRep.hs - = TopPrec -- No parens - | FunPrec -- Function args; no parens for tycon apps - | TyOpPrec -- Infix operator - | TyConPrec -- Tycon args; no parens for atomic - deriving( Eq, Ord ) - -maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty - -{- -************************************************************************ -* * - Tuples -* * -************************************************************************ --} - -data TupleSort - = BoxedTuple - | UnboxedTuple - | ConstraintTuple - deriving( Eq, Data ) - -tupleSortBoxity :: TupleSort -> Boxity -tupleSortBoxity BoxedTuple = Boxed -tupleSortBoxity UnboxedTuple = Unboxed -tupleSortBoxity ConstraintTuple = Boxed - -boxityTupleSort :: Boxity -> TupleSort -boxityTupleSort Boxed = BoxedTuple -boxityTupleSort Unboxed = UnboxedTuple - -tupleParens :: TupleSort -> SDoc -> SDoc -tupleParens BoxedTuple p = parens p -tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") -tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) - = sdocWithPprDebug $ \dbg -> if dbg - then text "(%" <+> p <+> ptext (sLit "%)") - else parens p - -{- -************************************************************************ -* * - Sums -* * -************************************************************************ --} - -sumParens :: SDoc -> SDoc -sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") - --- | Pretty print an alternative in an unboxed sum e.g. "| a | |". -pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use - -> a -- ^ The things to be pretty printed - -> ConTag -- ^ Alternative (one-based) - -> Arity -- ^ Arity - -> SDoc -- ^ 'SDoc' where the alternative havs been pretty - -- printed and finally packed into a paragraph. -pprAlternative pp x alt arity = - fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) - -{- -************************************************************************ -* * -\subsection[Generic]{Generic flag} -* * -************************************************************************ - -This is the "Embedding-Projection pair" datatype, it contains -two pieces of code (normally either RenamedExpr's or Id's) -If we have a such a pair (EP from to), the idea is that 'from' and 'to' -represents functions of type - - from :: T -> Tring - to :: Tring -> T - -And we should have - - to (from x) = x - -T and Tring are arbitrary, but typically T is the 'main' type while -Tring is the 'representation' type. (This just helps us remember -whether to use 'from' or 'to'. --} - --- | Embedding Projection pair -data EP a = EP { fromEP :: a, -- :: T -> Tring - toEP :: a } -- :: Tring -> T - -{- -Embedding-projection pairs are used in several places: - -First of all, each type constructor has an EP associated with it, the -code in EP converts (datatype T) from T to Tring and back again. - -Secondly, when we are filling in Generic methods (in the typechecker, -tcMethodBinds), we are constructing bimaps by induction on the structure -of the type of the method signature. - - -************************************************************************ -* * -\subsection{Occurrence information} -* * -************************************************************************ - -This data type is used exclusively by the simplifier, but it appears in a -SubstResult, which is currently defined in VarEnv, which is pretty near -the base of the module hierarchy. So it seemed simpler to put the -defn of OccInfo here, safely at the bottom --} - --- | identifier Occurrence Information -data OccInfo - = ManyOccs { occ_tail :: !TailCallInfo } - -- ^ There are many occurrences, or unknown occurrences - - | IAmDead -- ^ Marks unused variables. Sometimes useful for - -- lambda and case-bound variables. - - | OneOcc { occ_in_lam :: !InsideLam - , occ_one_br :: !OneBranch - , occ_int_cxt :: !InterestingCxt - , occ_tail :: !TailCallInfo } - -- ^ Occurs exactly once (per branch), not inside a rule - - -- | This identifier breaks a loop of mutually recursive functions. The field - -- marks whether it is only a loop breaker due to a reference in a rule - | IAmALoopBreaker { occ_rules_only :: !RulesOnly - , occ_tail :: !TailCallInfo } - -- Note [LoopBreaker OccInfo] - - deriving (Eq) - -type RulesOnly = Bool - -{- -Note [LoopBreaker OccInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - IAmALoopBreaker True <=> A "weak" or rules-only loop breaker - Do not preInlineUnconditionally - - IAmALoopBreaker False <=> A "strong" loop breaker - Do not inline at all - -See OccurAnal Note [Weak loop breakers] --} - -noOccInfo :: OccInfo -noOccInfo = ManyOccs { occ_tail = NoTailCallInfo } - -isManyOccs :: OccInfo -> Bool -isManyOccs ManyOccs{} = True -isManyOccs _ = False - -seqOccInfo :: OccInfo -> () -seqOccInfo occ = occ `seq` () - ------------------ --- | Interesting Context -type InterestingCxt = Bool -- True <=> Function: is applied - -- Data value: scrutinised by a case with - -- at least one non-DEFAULT branch - ------------------ --- | Inside Lambda -type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda - -- Substituting a redex for this occurrence is - -- dangerous because it might duplicate work. -insideLam, notInsideLam :: InsideLam -insideLam = True -notInsideLam = False - ------------------ -type OneBranch = Bool -- True <=> Occurs in only one case branch - -- so no code-duplication issue to worry about -oneBranch, notOneBranch :: OneBranch -oneBranch = True -notOneBranch = False - ------------------ -data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo] - | NoTailCallInfo - deriving (Eq) - -tailCallInfo :: OccInfo -> TailCallInfo -tailCallInfo IAmDead = NoTailCallInfo -tailCallInfo other = occ_tail other - -zapOccTailCallInfo :: OccInfo -> OccInfo -zapOccTailCallInfo IAmDead = IAmDead -zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo } - -isAlwaysTailCalled :: OccInfo -> Bool -isAlwaysTailCalled occ - = case tailCallInfo occ of AlwaysTailCalled{} -> True - NoTailCallInfo -> False - -instance Outputable TailCallInfo where - ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ] - ppr _ = empty - ------------------ -strongLoopBreaker, weakLoopBreaker :: OccInfo -strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo -weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo - -isWeakLoopBreaker :: OccInfo -> Bool -isWeakLoopBreaker (IAmALoopBreaker{}) = True -isWeakLoopBreaker _ = False - -isStrongLoopBreaker :: OccInfo -> Bool -isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True - -- Loop-breaker that breaks a non-rule cycle -isStrongLoopBreaker _ = False - -isDeadOcc :: OccInfo -> Bool -isDeadOcc IAmDead = True -isDeadOcc _ = False - -isOneOcc :: OccInfo -> Bool -isOneOcc (OneOcc {}) = True -isOneOcc _ = False - -zapFragileOcc :: OccInfo -> OccInfo --- Keep only the most robust data: deadness, loop-breaker-hood -zapFragileOcc (OneOcc {}) = noOccInfo -zapFragileOcc occ = zapOccTailCallInfo occ - -instance Outputable OccInfo where - -- only used for debugging; never parsed. KSW 1999-07 - ppr (ManyOccs tails) = pprShortTailCallInfo tails - ppr IAmDead = text "Dead" - ppr (IAmALoopBreaker rule_only tails) - = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails - where - pp_ro | rule_only = char '!' - | otherwise = empty - ppr (OneOcc inside_lam one_branch int_cxt tail_info) - = text "Once" <> pp_lam <> pp_br <> pp_args <> pp_tail - where - pp_lam | inside_lam = char 'L' - | otherwise = empty - pp_br | one_branch = empty - | otherwise = char '*' - pp_args | int_cxt = char '!' - | otherwise = empty - pp_tail = pprShortTailCallInfo tail_info - -pprShortTailCallInfo :: TailCallInfo -> SDoc -pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) -pprShortTailCallInfo NoTailCallInfo = empty - -{- -Note [TailCallInfo] -~~~~~~~~~~~~~~~~~~~ -The occurrence analyser determines what can be made into a join point, but it -doesn't change the binder into a JoinId because then it would be inconsistent -with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to -change the IdDetails. - -The AlwaysTailCalled marker actually means slightly more than simply that the -function is always tail-called. See Note [Invariants on join points]. - -This info is quite fragile and should not be relied upon unless the occurrence -analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of -the join-point-hood of a binder; a join id itself will not be marked -AlwaysTailCalled. - -Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that -being tail-called would mean that the variable could only appear once per branch -(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join -point can also be invoked from other join points, not just from case branches: - - let j1 x = ... - j2 y = ... j1 z {- tail call -} ... - in case w of - A -> j1 v - B -> j2 u - C -> j2 q - -Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get -ManyOccs and j2 will get `OneOcc { occ_one_br = True }`. - -************************************************************************ -* * - Default method specification -* * -************************************************************************ - -The DefMethSpec enumeration just indicates what sort of default method -is used for a class. It is generated from source code, and present in -interface files; it is converted to Class.DefMethInfo before begin put in a -Class object. --} - --- | Default Method Specification -data DefMethSpec ty - = VanillaDM -- Default method given with polymorphic code - | GenericDM ty -- Default method given with code of this type - -instance Outputable (DefMethSpec ty) where - ppr VanillaDM = text "{- Has default method -}" - ppr (GenericDM {}) = text "{- Has generic default method -}" - -{- -************************************************************************ -* * -\subsection{Success flag} -* * -************************************************************************ --} - -data SuccessFlag = Succeeded | Failed - -instance Outputable SuccessFlag where - ppr Succeeded = text "Succeeded" - ppr Failed = text "Failed" - -successIf :: Bool -> SuccessFlag -successIf True = Succeeded -successIf False = Failed - -succeeded, failed :: SuccessFlag -> Bool -succeeded Succeeded = True -succeeded Failed = False - -failed Succeeded = False -failed Failed = True - -{- -************************************************************************ -* * -\subsection{Source Text} -* * -************************************************************************ -Keeping Source Text for source to source conversions - -Note [Pragma source text] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The lexer does a case-insensitive match for pragmas, as well as -accepting both UK and US spelling variants. - -So - - {-# SPECIALISE #-} - {-# SPECIALIZE #-} - {-# Specialize #-} - -will all generate ITspec_prag token for the start of the pragma. - -In order to be able to do source to source conversions, the original -source text for the token needs to be preserved, hence the -`SourceText` field. - -So the lexer will then generate - - ITspec_prag "{ -# SPECIALISE" - ITspec_prag "{ -# SPECIALIZE" - ITspec_prag "{ -# Specialize" - -for the cases above. - [without the space between '{' and '-', otherwise this comment won't parse] - - -Note [Literal source text] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The lexer/parser converts literals from their original source text -versions to an appropriate internal representation. This is a problem -for tools doing source to source conversions, so the original source -text is stored in literals where this can occur. - -Motivating examples for HsLit - - HsChar '\n' == '\x20` - HsCharPrim '\x41`# == `A` - HsString "\x20\x41" == " A" - HsStringPrim "\x20"# == " "# - HsInt 001 == 1 - HsIntPrim 002# == 2# - HsWordPrim 003## == 3## - HsInt64Prim 004## == 4## - HsWord64Prim 005## == 5## - HsInteger 006 == 6 - -For OverLitVal - - HsIntegral 003 == 0x003 - HsIsString "\x41nd" == "And" --} - - -- Note [Literal source text],[Pragma source text] -data SourceText = SourceText String - | NoSourceText -- ^ For when code is generated, e.g. TH, - -- deriving. The pretty printer will then make - -- its own representation of the item. - deriving (Data, Show, Eq ) - -instance Outputable SourceText where - ppr (SourceText s) = text "SourceText" <+> text s - ppr NoSourceText = text "NoSourceText" - --- | Special combinator for showing string literals. -pprWithSourceText :: SourceText -> SDoc -> SDoc -pprWithSourceText NoSourceText d = d -pprWithSourceText (SourceText src) _ = text src - -{- -************************************************************************ -* * -\subsection{Activation} -* * -************************************************************************ - -When a rule or inlining is active --} - --- | Phase Number -type PhaseNum = Int -- Compilation phase - -- Phases decrease towards zero - -- Zero is the last phase - -data CompilerPhase - = Phase PhaseNum - | InitialPhase -- The first phase -- number = infinity! - -instance Outputable CompilerPhase where - ppr (Phase n) = int n - ppr InitialPhase = text "InitialPhase" - --- See note [Pragma source text] -data Activation = NeverActive - | AlwaysActive - | ActiveBefore SourceText PhaseNum - -- Active only *strictly before* this phase - | ActiveAfter SourceText PhaseNum - -- Active in this phase and later - deriving( Eq, Data ) - -- Eq used in comparing rules in HsDecls - --- | Rule Match Information -data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] - | FunLike - deriving( Eq, Data, Show ) - -- Show needed for Lexer.x - -data InlinePragma -- Note [InlinePragma] - = InlinePragma - { inl_src :: SourceText -- Note [Pragma source text] - , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] - - , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n - -- explicit (non-type, non-dictionary) args - -- That is, inl_sat describes the number of *source-code* - -- arguments the thing must be applied to. We add on the - -- number of implicit, dictionary arguments when making - -- the Unfolding, and don't look at inl_sat further - - , inl_act :: Activation -- Says during which phases inlining is allowed - -- See Note [inl_inline and inl_act] - - , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? - } deriving( Eq, Data ) - --- | Inline Specification -data InlineSpec -- What the user's INLINE pragma looked like - = Inline - | Inlinable - | NoInline - | EmptyInlineSpec -- Used in a place-holder InlinePragma in SpecPrag or IdInfo, - -- where there isn't any real inline pragma at all - deriving( Eq, Data, Show ) - -- Show needed for Lexer.x - -{- Note [InlinePragma] -~~~~~~~~~~~~~~~~~~~~~~ -This data type mirrors what you can write in an INLINE or NOINLINE pragma in -the source program. - -If you write nothing at all, you get defaultInlinePragma: - inl_inline = EmptyInlineSpec - inl_act = AlwaysActive - inl_rule = FunLike - -It's not possible to get that combination by *writing* something, so -if an Id has defaultInlinePragma it means the user didn't specify anything. - -If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. - -If you want to know where InlinePragmas take effect: Look in DsBinds.makeCorePair - -Note [inl_inline and inl_act] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* inl_inline says what the user wrote: did she say INLINE, NOINLINE, - INLINABLE, or nothing at all - -* inl_act says in what phases the unfolding is active or inactive - E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1 - If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1 - If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1 - So note that inl_act does not say what pragma you wrote: it just - expresses its consequences - -* inl_act just says when the unfolding is active; it doesn't say what - to inline. If you say INLINE f, then f's inl_act will be AlwaysActive, - but in addition f will get a "stable unfolding" with UnfoldingGuidance - that tells the inliner to be pretty eager about it. - -Note [CONLIKE pragma] -~~~~~~~~~~~~~~~~~~~~~ -The ConLike constructor of a RuleMatchInfo is aimed at the following. -Consider first - {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} - g b bs = let x = b:bs in ..x...x...(r x)... -Now, the rule applies to the (r x) term, because GHC "looks through" -the definition of 'x' to see that it is (b:bs). - -Now consider - {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} - g v = let x = f v in ..x...x...(r x)... -Normally the (r x) would *not* match the rule, because GHC would be -scared about duplicating the redex (f v), so it does not "look -through" the bindings. - -However the CONLIKE modifier says to treat 'f' like a constructor in -this situation, and "look through" the unfolding for x. So (r x) -fires, yielding (f (v+1)). - -This is all controlled with a user-visible pragma: - {-# NOINLINE CONLIKE [1] f #-} - -The main effects of CONLIKE are: - - - The occurrence analyser (OccAnal) and simplifier (Simplify) treat - CONLIKE thing like constructors, by ANF-ing them - - - New function coreUtils.exprIsExpandable is like exprIsCheap, but - additionally spots applications of CONLIKE functions - - - A CoreUnfolding has a field that caches exprIsExpandable - - - The rule matcher consults this field. See - Note [Expanding variables] in Rules.hs. --} - -isConLike :: RuleMatchInfo -> Bool -isConLike ConLike = True -isConLike _ = False - -isFunLike :: RuleMatchInfo -> Bool -isFunLike FunLike = True -isFunLike _ = False - -isEmptyInlineSpec :: InlineSpec -> Bool -isEmptyInlineSpec EmptyInlineSpec = True -isEmptyInlineSpec _ = False - -defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma - :: InlinePragma -defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_act = AlwaysActive - , inl_rule = FunLike - , inl_inline = EmptyInlineSpec - , inl_sat = Nothing } - -alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } -neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } - -inlinePragmaSpec :: InlinePragma -> InlineSpec -inlinePragmaSpec = inl_inline - --- A DFun has an always-active inline activation so that --- exprIsConApp_maybe can "see" its unfolding --- (However, its actual Unfolding is a DFunUnfolding, which is --- never inlined other than via exprIsConApp_maybe.) -dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive - , inl_rule = ConLike } - -isDefaultInlinePragma :: InlinePragma -> Bool -isDefaultInlinePragma (InlinePragma { inl_act = activation - , inl_rule = match_info - , inl_inline = inline }) - = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info - -isInlinePragma :: InlinePragma -> Bool -isInlinePragma prag = case inl_inline prag of - Inline -> True - _ -> False - -isInlinablePragma :: InlinePragma -> Bool -isInlinablePragma prag = case inl_inline prag of - Inlinable -> True - _ -> False - -isAnyInlinePragma :: InlinePragma -> Bool --- INLINE or INLINABLE -isAnyInlinePragma prag = case inl_inline prag of - Inline -> True - Inlinable -> True - _ -> False - -inlinePragmaSat :: InlinePragma -> Maybe Arity -inlinePragmaSat = inl_sat - -inlinePragmaActivation :: InlinePragma -> Activation -inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation - -inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info - -setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma -setInlinePragmaActivation prag activation = prag { inl_act = activation } - -setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma -setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } - -instance Outputable Activation where - ppr AlwaysActive = empty - ppr NeverActive = brackets (text "~") - ppr (ActiveBefore _ n) = brackets (char '~' <> int n) - ppr (ActiveAfter _ n) = brackets (int n) - -instance Outputable RuleMatchInfo where - ppr ConLike = text "CONLIKE" - ppr FunLike = text "FUNLIKE" - -instance Outputable InlineSpec where - ppr Inline = text "INLINE" - ppr NoInline = text "NOINLINE" - ppr Inlinable = text "INLINABLE" - ppr EmptyInlineSpec = empty - -instance Outputable InlinePragma where - ppr = pprInline - -pprInline :: InlinePragma -> SDoc -pprInline = pprInline' True - -pprInlineDebug :: InlinePragma -> SDoc -pprInlineDebug = pprInline' False - -pprInline' :: Bool -> InlinePragma -> SDoc -pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation - , inl_rule = info, inl_sat = mb_arity }) - = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info - where - pp_inl x = if emptyInline then empty else ppr x - - pp_act Inline AlwaysActive = empty - pp_act NoInline NeverActive = empty - pp_act _ act = ppr act - - pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) - | otherwise = empty - pp_info | isFunLike info = empty - | otherwise = ppr info - -isActive :: CompilerPhase -> Activation -> Bool -isActive InitialPhase AlwaysActive = True -isActive InitialPhase (ActiveBefore {}) = True -isActive InitialPhase _ = False -isActive (Phase p) act = isActiveIn p act - -isActiveIn :: PhaseNum -> Activation -> Bool -isActiveIn _ NeverActive = False -isActiveIn _ AlwaysActive = True -isActiveIn p (ActiveAfter _ n) = p <= n -isActiveIn p (ActiveBefore _ n) = p > n - -competesWith :: Activation -> Activation -> Bool --- See Note [Activation competition] -competesWith NeverActive _ = False -competesWith _ NeverActive = False -competesWith AlwaysActive _ = True - -competesWith (ActiveBefore {}) AlwaysActive = True -competesWith (ActiveBefore {}) (ActiveBefore {}) = True -competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b - -competesWith (ActiveAfter {}) AlwaysActive = False -competesWith (ActiveAfter {}) (ActiveBefore {}) = False -competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b - -{- Note [Competing activations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Sometimes a RULE and an inlining may compete, or two RULES. -See Note [Rules and inlining/other rules] in Desugar. - -We say that act1 "competes with" act2 iff - act1 is active in the phase when act2 *becomes* active -NB: remember that phases count *down*: 2, 1, 0! - -It's too conservative to ensure that the two are never simultaneously -active. For example, a rule might be always active, and an inlining -might switch on in phase 2. We could switch off the rule, but it does -no harm. --} - -isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool -isNeverActive NeverActive = True -isNeverActive _ = False - -isAlwaysActive AlwaysActive = True -isAlwaysActive _ = False - -isEarlyActive AlwaysActive = True -isEarlyActive (ActiveBefore {}) = True -isEarlyActive _ = False - --- | Fractional Literal --- --- Used (instead of Rational) to represent exactly the floating point literal that we --- encountered in the user's source program. This allows us to pretty-print exactly what --- the user wrote, which is important e.g. for floating point numbers that can't represented --- as Doubles (we used to via Double for pretty-printing). See also #2245. -data FractionalLit - = FL { fl_text :: String -- How the value was written in the source - , fl_value :: Rational -- Numeric value of the literal - } - deriving (Data, Show) - -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on - -negateFractionalLit :: FractionalLit -> FractionalLit -negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value } -negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value } - -integralFractionalLit :: Integer -> FractionalLit -integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i } - --- Comparison operations are needed when grouping literals --- for compiling pattern-matching (module MatchLit) - -instance Eq FractionalLit where - (==) = (==) `on` fl_value - -instance Ord FractionalLit where - compare = compare `on` fl_value - -instance Outputable FractionalLit where - ppr = text . fl_text - -{- -************************************************************************ -* * - IntWithInf -* * -************************************************************************ - -Represents an integer or positive infinity - --} - --- | An integer or infinity -data IntWithInf = Int {-# UNPACK #-} !Int - | Infinity - deriving Eq - --- | A representation of infinity -infinity :: IntWithInf -infinity = Infinity - -instance Ord IntWithInf where - compare Infinity Infinity = EQ - compare (Int _) Infinity = LT - compare Infinity (Int _) = GT - compare (Int a) (Int b) = a `compare` b - -instance Outputable IntWithInf where - ppr Infinity = char '∞' - ppr (Int n) = int n - -instance Num IntWithInf where - (+) = plusWithInf - (*) = mulWithInf - - abs Infinity = Infinity - abs (Int n) = Int (abs n) - - signum Infinity = Int 1 - signum (Int n) = Int (signum n) - - fromInteger = Int . fromInteger - - (-) = panic "subtracting IntWithInfs" - -intGtLimit :: Int -> IntWithInf -> Bool -intGtLimit _ Infinity = False -intGtLimit n (Int m) = n > m - --- | Add two 'IntWithInf's -plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf -plusWithInf Infinity _ = Infinity -plusWithInf _ Infinity = Infinity -plusWithInf (Int a) (Int b) = Int (a + b) - --- | Multiply two 'IntWithInf's -mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf -mulWithInf Infinity _ = Infinity -mulWithInf _ Infinity = Infinity -mulWithInf (Int a) (Int b) = Int (a * b) - --- | Turn a positive number into an 'IntWithInf', where 0 represents infinity -treatZeroAsInf :: Int -> IntWithInf -treatZeroAsInf 0 = Infinity -treatZeroAsInf n = Int n - --- | Inject any integer into an 'IntWithInf' -mkIntWithInf :: Int -> IntWithInf -mkIntWithInf = Int - -data SpliceExplicitFlag - = ExplicitSplice | -- ^ <=> $(f x y) - ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression - deriving Data diff --git a/basicTypes/ConLike.hs b/basicTypes/ConLike.hs deleted file mode 100644 --- a/basicTypes/ConLike.hs +++ /dev/null @@ -1,192 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[ConLike]{@ConLike@: Constructor-like things} --} - -{-# LANGUAGE CPP #-} - -module ConLike ( - ConLike(..) - , conLikeArity - , conLikeFieldLabels - , conLikeInstOrigArgTys - , conLikeExTyVars - , conLikeName - , conLikeStupidTheta - , conLikeWrapId_maybe - , conLikeImplBangs - , conLikeFullSig - , conLikeResTy - , conLikeFieldType - , conLikesWithFields - , conLikeIsInfix - ) where - -#include "HsVersions.h" - -import DataCon -import PatSyn -import Outputable -import Unique -import Util -import Name -import BasicTypes -import TyCoRep (Type, ThetaType) -import Var -import Type (mkTyConApp) - -import qualified Data.Data as Data - -{- -************************************************************************ -* * -\subsection{Constructor-like things} -* * -************************************************************************ --} - --- | A constructor-like thing -data ConLike = RealDataCon DataCon - | PatSynCon PatSyn - -{- -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq ConLike where - (==) = eqConLike - -eqConLike :: ConLike -> ConLike -> Bool -eqConLike x y = getUnique x == getUnique y - --- There used to be an Ord ConLike instance here that used Unique for ordering. --- It was intentionally removed to prevent determinism problems. --- See Note [Unique Determinism] in Unique. - -instance Uniquable ConLike where - getUnique (RealDataCon dc) = getUnique dc - getUnique (PatSynCon ps) = getUnique ps - -instance NamedThing ConLike where - getName (RealDataCon dc) = getName dc - getName (PatSynCon ps) = getName ps - -instance Outputable ConLike where - ppr (RealDataCon dc) = ppr dc - ppr (PatSynCon ps) = ppr ps - -instance OutputableBndr ConLike where - pprInfixOcc (RealDataCon dc) = pprInfixOcc dc - pprInfixOcc (PatSynCon ps) = pprInfixOcc ps - pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc - pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps - -instance Data.Data ConLike where - -- don't traverse? - toConstr _ = abstractConstr "ConLike" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "ConLike" - --- | Number of arguments -conLikeArity :: ConLike -> Arity -conLikeArity (RealDataCon data_con) = dataConSourceArity data_con -conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn - --- | Names of fields used for selectors -conLikeFieldLabels :: ConLike -> [FieldLabel] -conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con -conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn - --- | Returns just the instantiated /value/ argument types of a 'ConLike', --- (excluding dictionary args) -conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type] -conLikeInstOrigArgTys (RealDataCon data_con) tys = - dataConInstOrigArgTys data_con tys -conLikeInstOrigArgTys (PatSynCon pat_syn) tys = - patSynInstArgTys pat_syn tys - --- | Existentially quantified type variables -conLikeExTyVars :: ConLike -> [TyVar] -conLikeExTyVars (RealDataCon dcon1) = dataConExTyVars dcon1 -conLikeExTyVars (PatSynCon psyn1) = patSynExTyVars psyn1 - -conLikeName :: ConLike -> Name -conLikeName (RealDataCon data_con) = dataConName data_con -conLikeName (PatSynCon pat_syn) = patSynName pat_syn - --- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in: --- --- > data Eq a => T a = ... --- It is empty for `PatSynCon` as they do not allow such contexts. -conLikeStupidTheta :: ConLike -> ThetaType -conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con -conLikeStupidTheta (PatSynCon {}) = [] - --- | Returns the `Id` of the wrapper. This is also known as the builder in --- some contexts. The value is Nothing only in the case of unidirectional --- pattern synonyms. -conLikeWrapId_maybe :: ConLike -> Maybe Id -conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con -conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn - --- | Returns the strictness information for each constructor -conLikeImplBangs :: ConLike -> [HsImplBang] -conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con -conLikeImplBangs (PatSynCon pat_syn) = - replicate (patSynArity pat_syn) HsLazy - --- | Returns the type of the whole pattern -conLikeResTy :: ConLike -> [Type] -> Type -conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys -conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys - --- | The \"full signature\" of the 'ConLike' returns, in order: --- --- 1) The universally quantified type variables --- --- 2) The existentially quantified type variables --- --- 3) The equality specification --- --- 4) The provided theta (the constraints provided by a match) --- --- 5) The required theta (the constraints required for a match) --- --- 6) The original argument types (i.e. before --- any change of the representation of the type) --- --- 7) The original result type -conLikeFullSig :: ConLike - -> ([TyVar], [TyVar], [EqSpec] - , ThetaType, ThetaType, [Type], Type) -conLikeFullSig (RealDataCon con) = - let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con - -- Required theta is empty as normal data cons require no additional - -- constraints for a match - in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty) -conLikeFullSig (PatSynCon pat_syn) = - let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn - -- eqSpec is empty - in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty) - --- | Extract the type for any given labelled field of the 'ConLike' -conLikeFieldType :: ConLike -> FieldLabelString -> Type -conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label -conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label - - --- | The ConLikes that have *all* the given fields -conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike] -conLikesWithFields con_likes lbls = filter has_flds con_likes - where has_flds dc = all (has_fld dc) lbls - has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) - -conLikeIsInfix :: ConLike -> Bool -conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc -conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps diff --git a/basicTypes/ConLike.hs-boot b/basicTypes/ConLike.hs-boot deleted file mode 100644 --- a/basicTypes/ConLike.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -module ConLike where -import {-# SOURCE #-} DataCon (DataCon) -import {-# SOURCE #-} PatSyn (PatSyn) -import Name ( Name ) - -data ConLike = RealDataCon DataCon - | PatSynCon PatSyn - -conLikeName :: ConLike -> Name diff --git a/basicTypes/DataCon.hs b/basicTypes/DataCon.hs deleted file mode 100644 --- a/basicTypes/DataCon.hs +++ /dev/null @@ -1,1324 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[DataCon]{@DataCon@: Data Constructors} --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -module DataCon ( - -- * Main data types - DataCon, DataConRep(..), - SrcStrictness(..), SrcUnpackedness(..), - HsSrcBang(..), HsImplBang(..), - StrictnessMark(..), - ConTag, - - -- ** Equality specs - EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, - eqSpecPair, eqSpecPreds, - substEqSpec, filterEqSpec, - - -- ** Field labels - FieldLbl(..), FieldLabel, FieldLabelString, - - -- ** Type construction - mkDataCon, buildAlgTyCon, buildSynTyCon, fIRST_TAG, - - -- ** Type deconstruction - dataConRepType, dataConSig, dataConInstSig, dataConFullSig, - dataConName, dataConIdentity, dataConTag, dataConTyCon, - dataConOrigTyCon, dataConUserType, - dataConUnivTyVars, dataConUnivTyVarBinders, - dataConExTyVars, dataConExTyVarBinders, - dataConAllTyVars, - dataConEqSpec, dataConTheta, - dataConStupidTheta, - dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, - dataConInstOrigArgTys, dataConRepArgTys, - dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, - dataConSrcBangs, - dataConSourceArity, dataConRepArity, - dataConIsInfix, - dataConWorkId, dataConWrapId, dataConWrapId_maybe, - dataConImplicitTyThings, - dataConRepStrictness, dataConImplBangs, dataConBoxer, - - splitDataProductType_maybe, - - -- ** Predicates on DataCons - isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, - isUnboxedSumCon, - isVanillaDataCon, classDataCon, dataConCannotMatch, - isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, - specialPromotedDc, isLegacyPromotableDataCon, isLegacyPromotableTyCon, - - -- ** Promotion related functions - promoteDataCon - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} MkId( DataConBoxer ) -import Type -import ForeignCall ( CType ) -import Coercion -import Unify -import TyCon -import FieldLabel -import Class -import Name -import PrelNames -import Var -import Outputable -import ListSetOps -import Util -import BasicTypes -import FastString -import Module -import Binary -import UniqSet -import Unique( mkAlphaTyVarUnique ) - -import qualified Data.Data as Data -import Data.Char -import Data.Word -import Data.List( mapAccumL, find ) - -{- -Data constructor representation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following Haskell data type declaration - - data T = T !Int ![Int] - -Using the strictness annotations, GHC will represent this as - - data T = T Int# [Int] - -That is, the Int has been unboxed. Furthermore, the Haskell source construction - - T e1 e2 - -is translated to - - case e1 of { I# x -> - case e2 of { r -> - T x r }} - -That is, the first argument is unboxed, and the second is evaluated. Finally, -pattern matching is translated too: - - case e of { T a b -> ... } - -becomes - - case e of { T a' b -> let a = I# a' in ... } - -To keep ourselves sane, we name the different versions of the data constructor -differently, as follows. - - -Note [Data Constructor Naming] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Each data constructor C has two, and possibly up to four, Names associated with it: - - OccName Name space Name of Notes - --------------------------------------------------------------------------- - The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) - The "worker data con" C VarName Id The worker - The "wrapper data con" $WC VarName Id The wrapper - The "newtype coercion" :CoT TcClsName TyCon - -EVERY data constructor (incl for newtypes) has the former two (the -data con itself, and its worker. But only some data constructors have a -wrapper (see Note [The need for a wrapper]). - -Each of these three has a distinct Unique. The "data con itself" name -appears in the output of the renamer, and names the Haskell-source -data constructor. The type checker translates it into either the wrapper Id -(if it exists) or worker Id (otherwise). - -The data con has one or two Ids associated with it: - -The "worker Id", is the actual data constructor. -* Every data constructor (newtype or data type) has a worker - -* The worker is very like a primop, in that it has no binding. - -* For a *data* type, the worker *is* the data constructor; - it has no unfolding - -* For a *newtype*, the worker has a compulsory unfolding which - does a cast, e.g. - newtype T = MkT Int - The worker for MkT has unfolding - \\(x:Int). x `cast` sym CoT - Here CoT is the type constructor, witnessing the FC axiom - axiom CoT : T = Int - -The "wrapper Id", \$WC, goes as follows - -* Its type is exactly what it looks like in the source program. - -* It is an ordinary function, and it gets a top-level binding - like any other function. - -* The wrapper Id isn't generated for a data type if there is - nothing for the wrapper to do. That is, if its defn would be - \$wC = C - -Note [The need for a wrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Why might the wrapper have anything to do? Two reasons: - -* Unboxing strict fields (with -funbox-strict-fields) - data T = MkT !(Int,Int) - \$wMkT :: (Int,Int) -> T - \$wMkT (x,y) = MkT x y - Notice that the worker has two fields where the wapper has - just one. That is, the worker has type - MkT :: Int -> Int -> T - -* Equality constraints for GADTs - data T a where { MkT :: a -> T [a] } - - The worker gets a type with explicit equality - constraints, thus: - MkT :: forall a b. (a=[b]) => b -> T a - - The wrapper has the programmer-specified type: - \$wMkT :: a -> T [a] - \$wMkT a x = MkT [a] a [a] x - The third argument is a coercion - [a] :: [a]~[a] - -INVARIANT: the dictionary constructor for a class - never has a wrapper. - - -A note about the stupid context -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Data types can have a context: - - data (Eq a, Ord b) => T a b = T1 a b | T2 a - -and that makes the constructors have a context too -(notice that T2's context is "thinned"): - - T1 :: (Eq a, Ord b) => a -> b -> T a b - T2 :: (Eq a) => a -> T a b - -Furthermore, this context pops up when pattern matching -(though GHC hasn't implemented this, but it is in H98, and -I've fixed GHC so that it now does): - - f (T2 x) = x -gets inferred type - f :: Eq a => T a b -> a - -I say the context is "stupid" because the dictionaries passed -are immediately discarded -- they do nothing and have no benefit. -It's a flaw in the language. - - Up to now [March 2002] I have put this stupid context into the - type of the "wrapper" constructors functions, T1 and T2, but - that turned out to be jolly inconvenient for generics, and - record update, and other functions that build values of type T - (because they don't have suitable dictionaries available). - - So now I've taken the stupid context out. I simply deal with - it separately in the type checker on occurrences of a - constructor, either in an expression or in a pattern. - - [May 2003: actually I think this decision could evasily be - reversed now, and probably should be. Generics could be - disabled for types with a stupid context; record updates now - (H98) needs the context too; etc. It's an unforced change, so - I'm leaving it for now --- but it does seem odd that the - wrapper doesn't include the stupid context.] - -[July 04] With the advent of generalised data types, it's less obvious -what the "stupid context" is. Consider - C :: forall a. Ord a => a -> a -> T (Foo a) -Does the C constructor in Core contain the Ord dictionary? Yes, it must: - - f :: T b -> Ordering - f = /\b. \x:T b. - case x of - C a (d:Ord a) (p:a) (q:a) -> compare d p q - -Note that (Foo a) might not be an instance of Ord. - -************************************************************************ -* * -\subsection{Data constructors} -* * -************************************************************************ --} - --- | A data constructor --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', --- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma' - --- For details on above see note [Api annotations] in ApiAnnotation -data DataCon - = MkData { - dcName :: Name, -- This is the name of the *source data con* - -- (see "Note [Data Constructor Naming]" above) - dcUnique :: Unique, -- Cached from Name - dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's - - -- Running example: - -- - -- *** As declared by the user - -- data T a where - -- MkT :: forall x y. (x~y,Ord x) => x -> y -> T (x,y) - - -- *** As represented internally - -- data T a where - -- MkT :: forall a. forall x y. (a~(x,y),x~y,Ord x) => x -> y -> T a - -- - -- The next six fields express the type of the constructor, in pieces - -- e.g. - -- - -- dcUnivTyVars = [a] - -- dcExTyVars = [x,y] - -- dcEqSpec = [a~(x,y)] - -- dcOtherTheta = [x~y, Ord x] - -- dcOrigArgTys = [x,y] - -- dcRepTyCon = T - - -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS - -- FOR THE PARENT TyCon. (This is a change (Oct05): previously, vanilla - -- datacons guaranteed to have the same type variables as their parent TyCon, - -- but that seems ugly.) - - dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor - -- Its type is of form - -- forall a1..an . t1 -> ... tm -> T a1..an - -- No existentials, no coercions, nothing. - -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = [] - -- NB 1: newtypes always have a vanilla data con - -- NB 2: a vanilla constructor can still be declared in GADT-style - -- syntax, provided its type looks like the above. - -- The declaration format is held in the TyCon (algTcGadtSyntax) - - -- Universally-quantified type vars [a,b,c] - -- INVARIANT: length matches arity of the dcRepTyCon - -- INVARIANT: result type of data con worker is exactly (T a b c) - dcUnivTyVars :: [TyVarBinder], - - -- Existentially-quantified type vars [x,y] - dcExTyVars :: [TyVarBinder], - - -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames - -- Reason: less confusing, and easier to generate IfaceSyn - - dcEqSpec :: [EqSpec], -- Equalities derived from the result type, - -- _as written by the programmer_ - - -- This field allows us to move conveniently between the two ways - -- of representing a GADT constructor's type: - -- MkT :: forall a b. (a ~ [b]) => b -> T a - -- MkT :: forall b. b -> T [b] - -- Each equality is of the form (a ~ ty), where 'a' is one of - -- the universally quantified type variables - - -- The next two fields give the type context of the data constructor - -- (aside from the GADT constraints, - -- which are given by the dcExpSpec) - -- In GADT form, this is *exactly* what the programmer writes, even if - -- the context constrains only universally quantified variables - -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b - dcOtherTheta :: ThetaType, -- The other constraints in the data con's type - -- other than those in the dcEqSpec - - dcStupidTheta :: ThetaType, -- The context of the data type declaration - -- data Eq a => T a = ... - -- or, rather, a "thinned" version thereof - -- "Thinned", because the Report says - -- to eliminate any constraints that don't mention - -- tyvars free in the arg types for this constructor - -- - -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars - -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon - -- - -- "Stupid", because the dictionaries aren't used for anything. - -- Indeed, [as of March 02] they are no longer in the type of - -- the wrapper Id, because that makes it harder to use the wrap-id - -- to rebuild values after record selection or in generics. - - dcOrigArgTys :: [Type], -- Original argument types - -- (before unboxing and flattening of strict fields) - dcOrigResTy :: Type, -- Original result type, as seen by the user - -- NB: for a data instance, the original user result type may - -- differ from the DataCon's representation TyCon. Example - -- data instance T [a] where MkT :: a -> T [a] - -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 - - -- Now the strictness annotations and field labels of the constructor - dcSrcBangs :: [HsSrcBang], - -- See Note [Bangs on data constructor arguments] - -- - -- The [HsSrcBang] as written by the programmer. - -- - -- Matches 1-1 with dcOrigArgTys - -- Hence length = dataConSourceArity dataCon - - dcFields :: [FieldLabel], - -- Field labels for this constructor, in the - -- same order as the dcOrigArgTys; - -- length = 0 (if not a record) or dataConSourceArity. - - -- The curried worker function that corresponds to the constructor: - -- It doesn't have an unfolding; the code generator saturates these Ids - -- and allocates a real constructor when it finds one. - dcWorkId :: Id, - - -- Constructor representation - dcRep :: DataConRep, - - -- Cached; see Note [DataCon arities] - -- INVARIANT: dcRepArity == length dataConRepArgTys - -- INVARIANT: dcSourceArity == length dcOrigArgTys - dcRepArity :: Arity, - dcSourceArity :: Arity, - - -- Result type of constructor is T t1..tn - dcRepTyCon :: TyCon, -- Result tycon, T - - dcRepType :: Type, -- Type of the constructor - -- forall a x y. (a~(x,y), x~y, Ord x) => - -- x -> y -> T a - -- (this is *not* of the constructor wrapper Id: - -- see Note [Data con representation] below) - -- Notice that the existential type parameters come *second*. - -- Reason: in a case expression we may find: - -- case (e :: T t) of - -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... - -- It's convenient to apply the rep-type of MkT to 't', to get - -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t - -- and use that to check the pattern. Mind you, this is really only - -- used in CoreLint. - - - dcInfix :: Bool, -- True <=> declared infix - -- Used for Template Haskell and 'deriving' only - -- The actual fixity is stored elsewhere - - dcPromoted :: TyCon -- The promoted TyCon - -- See Note [Promoted data constructors] in TyCon - } - - -{- Note [TyVarBinders in DataCons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the TyVarBinders in a DataCon and PatSyn: - - * Each argument flag is Inferred or Specified. - None are Required. (A DataCon is a term-level function; see - Note [No Required TyBinder in terms] in TyCoRep.) - -Why do we need the TyVarBinders, rather than just the TyVars? So that -we can construct the right type for the DataCon with its foralls -attributed the correce visiblity. That in turn governs whether you -can use visible type application at a call of the data constructor. - -Note [DataCon arities] -~~~~~~~~~~~~~~~~~~~~~~ -dcSourceArity does not take constraints into account, -but dcRepArity does. For example: - MkT :: Ord a => a -> T a - dcSourceArity = 1 - dcRepArity = 2 --} - --- | Data Constructor Representation -data DataConRep - = NoDataConRep -- No wrapper - - | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens, - -- and constructs the representation - - , dcr_boxer :: DataConBoxer - - , dcr_arg_tys :: [Type] -- Final, representation argument types, - -- after unboxing and flattening, - -- and *including* all evidence args - - , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys - -- See also Note [Data-con worker strictness] in MkId.hs - - , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) - -- about the original arguments; 1-1 with orig_arg_tys - -- See Note [Bangs on data constructor arguments] - - } --- Algebraic data types always have a worker, and --- may or may not have a wrapper, depending on whether --- the wrapper does anything. --- --- Data types have a worker with no unfolding --- Newtypes just have a worker, which has a compulsory unfolding (just a cast) - --- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments - --- The wrapper (if it exists) takes dcOrigArgTys as its arguments --- The worker takes dataConRepArgTys as its arguments --- If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys - --- The 'NoDataConRep' case is important --- Not only is this efficient, --- but it also ensures that the wrapper is replaced --- by the worker (because it *is* the worker) --- even when there are no args. E.g. in --- f (:) x --- the (:) *is* the worker. --- This is really important in rule matching, --- (We could match on the wrappers, --- but that makes it less likely that rules will match --- when we bring bits of unfoldings together.) - -------------------------- - --- | Haskell Source Bang --- --- Bangs on data constructor arguments as the user wrote them in the --- source code. --- --- @(HsSrcBang _ SrcUnpack SrcLazy)@ and --- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we --- emit a warning (in checkValidDataCon) and treat it like --- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ -data HsSrcBang = - HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes - SrcUnpackedness - SrcStrictness - deriving Data.Data - --- | Haskell Implementation Bang --- --- Bangs of data constructor arguments as generated by the compiler --- after consulting HsSrcBang, flags, etc. -data HsImplBang - = HsLazy -- ^ Lazy field - | HsStrict -- ^ Strict but not unpacked field - | HsUnpack (Maybe Coercion) - -- ^ Strict and unpacked field - -- co :: arg-ty ~ product-ty HsBang - deriving Data.Data - --- | Source Strictness --- --- What strictness annotation the user wrote -data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' - | SrcStrict -- ^ Strict, ie '!' - | NoSrcStrict -- ^ no strictness annotation - deriving (Eq, Data.Data) - --- | Source Unpackedness --- --- What unpackedness the user requested -data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified - | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified - | NoSrcUnpack -- ^ no unpack pragma - deriving (Eq, Data.Data) - - - -------------------------- --- StrictnessMark is internal only, used to indicate strictness --- of the DataCon *worker* fields -data StrictnessMark = MarkedStrict | NotMarkedStrict - --- | An 'EqSpec' is a tyvar/type pair representing an equality made in --- rejigging a GADT constructor -data EqSpec = EqSpec TyVar - Type - --- | Make an 'EqSpec' -mkEqSpec :: TyVar -> Type -> EqSpec -mkEqSpec tv ty = EqSpec tv ty - -eqSpecTyVar :: EqSpec -> TyVar -eqSpecTyVar (EqSpec tv _) = tv - -eqSpecType :: EqSpec -> Type -eqSpecType (EqSpec _ ty) = ty - -eqSpecPair :: EqSpec -> (TyVar, Type) -eqSpecPair (EqSpec tv ty) = (tv, ty) - -eqSpecPreds :: [EqSpec] -> ThetaType -eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty - | EqSpec tv ty <- spec ] - --- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec --- is mapped in the substitution, it is mapped to a type variable, not --- a full type. -substEqSpec :: TCvSubst -> EqSpec -> EqSpec -substEqSpec subst (EqSpec tv ty) - = EqSpec tv' (substTy subst ty) - where - tv' = getTyVar "substEqSpec" (substTyVar subst tv) - --- | Filter out any TyBinders mentioned in an EqSpec -filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder] -filterEqSpec eq_spec - = filter not_in_eq_spec - where - not_in_eq_spec bndr = let var = binderVar bndr in - all (not . (== var) . eqSpecTyVar) eq_spec - -instance Outputable EqSpec where - ppr (EqSpec tv ty) = ppr (tv, ty) - -{- Note [Bangs on data constructor arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = MkT !Int {-# UNPACK #-} !Int Bool - -When compiling the module, GHC will decide how to represent -MkT, depending on the optimisation level, and settings of -flags like -funbox-small-strict-fields. - -Terminology: - * HsSrcBang: What the user wrote - Constructors: HsSrcBang - - * HsImplBang: What GHC decided - Constructors: HsLazy, HsStrict, HsUnpack - -* If T was defined in this module, MkT's dcSrcBangs field - records the [HsSrcBang] of what the user wrote; in the example - [ HsSrcBang _ NoSrcUnpack SrcStrict - , HsSrcBang _ SrcUnpack SrcStrict - , HsSrcBang _ NoSrcUnpack NoSrcStrictness] - -* However, if T was defined in an imported module, the importing module - must follow the decisions made in the original module, regardless of - the flag settings in the importing module. - Also see Note [Bangs on imported data constructors] in MkId - -* The dcr_bangs field of the dcRep field records the [HsImplBang] - If T was defined in this module, Without -O the dcr_bangs might be - [HsStrict, HsStrict, HsLazy] - With -O it might be - [HsStrict, HsUnpack _, HsLazy] - With -funbox-small-strict-fields it might be - [HsUnpack, HsUnpack _, HsLazy] - With -XStrictData it might be - [HsStrict, HsUnpack _, HsStrict] - -Note [Data con representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The dcRepType field contains the type of the representation of a constructor -This may differ from the type of the constructor *Id* (built -by MkId.mkDataConId) for two reasons: - a) the constructor Id may be overloaded, but the dictionary isn't stored - e.g. data Eq a => T a = MkT a a - - b) the constructor may store an unboxed version of a strict field. - -Here's an example illustrating both: - data Ord a => T a = MkT Int! a -Here - T :: Ord a => Int -> a -> T a -but the rep type is - Trep :: Int# -> a -> T a -Actually, the unboxed part isn't implemented yet! - - - -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq DataCon where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Uniquable DataCon where - getUnique = dcUnique - -instance NamedThing DataCon where - getName = dcName - -instance Outputable DataCon where - ppr con = ppr (dataConName con) - -instance OutputableBndr DataCon where - pprInfixOcc con = pprInfixName (dataConName con) - pprPrefixOcc con = pprPrefixName (dataConName con) - -instance Data.Data DataCon where - -- don't traverse? - toConstr _ = abstractConstr "DataCon" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "DataCon" - -instance Outputable HsSrcBang where - ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark - -instance Outputable HsImplBang where - ppr HsLazy = text "Lazy" - ppr (HsUnpack Nothing) = text "Unpacked" - ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) - ppr HsStrict = text "StrictNotUnpacked" - -instance Outputable SrcStrictness where - ppr SrcLazy = char '~' - ppr SrcStrict = char '!' - ppr NoSrcStrict = empty - -instance Outputable SrcUnpackedness where - ppr SrcUnpack = text "{-# UNPACK #-}" - ppr SrcNoUnpack = text "{-# NOUNPACK #-}" - ppr NoSrcUnpack = empty - -instance Outputable StrictnessMark where - ppr MarkedStrict = text "!" - ppr NotMarkedStrict = empty - -instance Binary SrcStrictness where - put_ bh SrcLazy = putByte bh 0 - put_ bh SrcStrict = putByte bh 1 - put_ bh NoSrcStrict = putByte bh 2 - - get bh = - do h <- getByte bh - case h of - 0 -> return SrcLazy - 1 -> return SrcStrict - _ -> return NoSrcStrict - -instance Binary SrcUnpackedness where - put_ bh SrcNoUnpack = putByte bh 0 - put_ bh SrcUnpack = putByte bh 1 - put_ bh NoSrcUnpack = putByte bh 2 - - get bh = - do h <- getByte bh - case h of - 0 -> return SrcNoUnpack - 1 -> return SrcUnpack - _ -> return NoSrcUnpack - --- | Compare strictness annotations -eqHsBang :: HsImplBang -> HsImplBang -> Bool -eqHsBang HsLazy HsLazy = True -eqHsBang HsStrict HsStrict = True -eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True -eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) - = eqType (coercionType c1) (coercionType c2) -eqHsBang _ _ = False - -isBanged :: HsImplBang -> Bool -isBanged (HsUnpack {}) = True -isBanged (HsStrict {}) = True -isBanged HsLazy = False - -isSrcStrict :: SrcStrictness -> Bool -isSrcStrict SrcStrict = True -isSrcStrict _ = False - -isSrcUnpacked :: SrcUnpackedness -> Bool -isSrcUnpacked SrcUnpack = True -isSrcUnpacked _ = False - -isMarkedStrict :: StrictnessMark -> Bool -isMarkedStrict NotMarkedStrict = False -isMarkedStrict _ = True -- All others are strict - -{- ********************************************************************* -* * -\subsection{Construction} -* * -********************************************************************* -} - --- | Build a new data constructor -mkDataCon :: Name - -> Bool -- ^ Is the constructor declared infix? - -> TyConRepName -- ^ TyConRepName for the promoted TyCon - -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user - -> [FieldLabel] -- ^ Field labels for the constructor, - -- if it is a record, otherwise empty - -> [TyVarBinder] -- ^ Universals. See Note [TyVarBinders in DataCons] - -> [TyVarBinder] -- ^ Existentials. - -- (These last two must be Named and Inferred/Specified) - -> [EqSpec] -- ^ GADT equalities - -> ThetaType -- ^ Theta-type occuring before the arguments proper - -> [Type] -- ^ Original argument types - -> Type -- ^ Original result type - -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' - -> TyCon -- ^ Representation type constructor - -> ThetaType -- ^ The "stupid theta", context of the data - -- declaration e.g. @data Eq a => T a ...@ - -> Id -- ^ Worker Id - -> DataConRep -- ^ Representation - -> DataCon - -- Can get the tag from the TyCon - -mkDataCon name declared_infix prom_info - arg_stricts -- Must match orig_arg_tys 1-1 - fields - univ_tvs ex_tvs - eq_spec theta - orig_arg_tys orig_res_ty rep_info rep_tycon - stupid_theta work_id rep --- Warning: mkDataCon is not a good place to check invariants. --- If the programmer writes the wrong result type in the decl, thus: --- data T a where { MkT :: S } --- then it's possible that the univ_tvs may hit an assertion failure --- if you pull on univ_tvs. This case is checked by checkValidDataCon, --- so the error is detected properly... it's just that asaertions here --- are a little dodgy. - - = con - where - is_vanilla = null ex_tvs && null eq_spec && null theta - con = MkData {dcName = name, dcUnique = nameUnique name, - dcVanilla = is_vanilla, dcInfix = declared_infix, - dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs, - dcEqSpec = eq_spec, - dcOtherTheta = theta, - dcStupidTheta = stupid_theta, - dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, - dcRepTyCon = rep_tycon, - dcSrcBangs = arg_stricts, - dcFields = fields, dcTag = tag, dcRepType = rep_ty, - dcWorkId = work_id, - dcRep = rep, - dcSourceArity = length orig_arg_tys, - dcRepArity = length rep_arg_tys, - dcPromoted = promoted } - - -- The 'arg_stricts' passed to mkDataCon are simply those for the - -- source-language arguments. We add extra ones for the - -- dictionary arguments right here. - - tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con - rep_arg_tys = dataConRepArgTys con - - rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ - mkFunTys rep_arg_tys $ - mkTyConApp rep_tycon (mkTyVarTys (binderVars univ_tvs)) - - -- See Note [Promoted data constructors] in TyCon - prom_tv_bndrs = [ mkNamedTyConBinder vis tv - | TvBndr tv vis <- filterEqSpec eq_spec univ_tvs ++ ex_tvs ] - - prom_arg_bndrs = mkCleanAnonTyConBinders prom_tv_bndrs (theta ++ orig_arg_tys) - prom_res_kind = orig_res_ty - promoted = mkPromotedDataCon con name prom_info - (prom_tv_bndrs ++ prom_arg_bndrs) - prom_res_kind roles rep_info - - roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ - map (const Representational) orig_arg_tys - -mkCleanAnonTyConBinders :: [TyConBinder] -> [Type] -> [TyConBinder] --- Make sure that the "anonymous" tyvars don't clash in --- name or unique with the universal/existential ones. --- Tiresome! And unnecessary because these tyvars are never looked at -mkCleanAnonTyConBinders tc_bndrs tys - = [ mkAnonTyConBinder (mkTyVar name ty) - | (name, ty) <- fresh_names `zip` tys ] - where - fresh_names = freshNames (map getName (binderVars tc_bndrs)) - -freshNames :: [Name] -> [Name] --- Make names whose Uniques and OccNames differ from --- those in the 'avoid' list -freshNames avoids - = [ mkSystemName uniq occ - | n <- [0..] - , let uniq = mkAlphaTyVarUnique n - occ = mkTyVarOccFS (mkFastString ('x' : show n)) - - , not (uniq `elementOfUniqSet` avoid_uniqs) - , not (occ `elemOccSet` avoid_occs) ] - - where - avoid_uniqs :: UniqSet Unique - avoid_uniqs = mkUniqSet (map getUnique avoids) - - avoid_occs :: OccSet - avoid_occs = mkOccSet (map getOccName avoids) - --- | The 'Name' of the 'DataCon', giving it a unique, rooted identification -dataConName :: DataCon -> Name -dataConName = dcName - --- | The tag used for ordering 'DataCon's -dataConTag :: DataCon -> ConTag -dataConTag = dcTag - --- | The type constructor that we are building via this data constructor -dataConTyCon :: DataCon -> TyCon -dataConTyCon = dcRepTyCon - --- | The original type constructor used in the definition of this data --- constructor. In case of a data family instance, that will be the family --- type constructor. -dataConOrigTyCon :: DataCon -> TyCon -dataConOrigTyCon dc - | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc - | otherwise = dcRepTyCon dc - --- | The representation type of the data constructor, i.e. the sort --- type that will represent values of this type at runtime -dataConRepType :: DataCon -> Type -dataConRepType = dcRepType - --- | Should the 'DataCon' be presented infix? -dataConIsInfix :: DataCon -> Bool -dataConIsInfix = dcInfix - --- | The universally-quantified type variables of the constructor -dataConUnivTyVars :: DataCon -> [TyVar] -dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = binderVars tvbs - --- | 'TyBinder's for the universally-quantified type variables -dataConUnivTyVarBinders :: DataCon -> [TyVarBinder] -dataConUnivTyVarBinders = dcUnivTyVars - --- | The existentially-quantified type variables of the constructor -dataConExTyVars :: DataCon -> [TyVar] -dataConExTyVars (MkData { dcExTyVars = tvbs }) = binderVars tvbs - --- | 'TyBinder's for the existentially-quantified type variables -dataConExTyVarBinders :: DataCon -> [TyVarBinder] -dataConExTyVarBinders = dcExTyVars - --- | Both the universal and existentiatial type variables of the constructor -dataConAllTyVars :: DataCon -> [TyVar] -dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs }) - = binderVars (univ_tvs ++ ex_tvs) - --- | Equalities derived from the result type of the data constructor, as written --- by the programmer in any GADT declaration. This includes *all* GADT-like --- equalities, including those written in by hand by the programmer. -dataConEqSpec :: DataCon -> [EqSpec] -dataConEqSpec (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = eq_spec ++ - [ spec -- heterogeneous equality - | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta - , tc `hasKey` heqTyConKey - , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of - (Just tv1, _) -> [mkEqSpec tv1 ty2] - (_, Just tv2) -> [mkEqSpec tv2 ty1] - _ -> [] - ] ++ - [ spec -- homogeneous equality - | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta - , tc `hasKey` eqTyConKey - , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of - (Just tv1, _) -> [mkEqSpec tv1 ty2] - (_, Just tv2) -> [mkEqSpec tv2 ty1] - _ -> [] - ] - - --- | The *full* constraints on the constructor type. -dataConTheta :: DataCon -> ThetaType -dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = eqSpecPreds eq_spec ++ theta - --- | Get the Id of the 'DataCon' worker: a function that is the "actual" --- constructor and has no top level binding in the program. The type may --- be different from the obvious one written in the source program. Panics --- if there is no such 'Id' for this 'DataCon' -dataConWorkId :: DataCon -> Id -dataConWorkId dc = dcWorkId dc - --- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" --- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'. --- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor --- and also for a newtype (whose constructor is inlined compulsorily) -dataConWrapId_maybe :: DataCon -> Maybe Id -dataConWrapId_maybe dc = case dcRep dc of - NoDataConRep -> Nothing - DCR { dcr_wrap_id = wrap_id } -> Just wrap_id - --- | Returns an Id which looks like the Haskell-source constructor by using --- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to --- the worker (see 'dataConWorkId') -dataConWrapId :: DataCon -> Id -dataConWrapId dc = case dcRep dc of - NoDataConRep-> dcWorkId dc -- worker=wrapper - DCR { dcr_wrap_id = wrap_id } -> wrap_id - --- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, --- the union of the 'dataConWorkId' and the 'dataConWrapId' -dataConImplicitTyThings :: DataCon -> [TyThing] -dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep }) - = [AnId work] ++ wrap_ids - where - wrap_ids = case rep of - NoDataConRep -> [] - DCR { dcr_wrap_id = wrap } -> [AnId wrap] - --- | The labels for the fields of this particular 'DataCon' -dataConFieldLabels :: DataCon -> [FieldLabel] -dataConFieldLabels = dcFields - --- | Extract the type for any given labelled field of the 'DataCon' -dataConFieldType :: DataCon -> FieldLabelString -> Type -dataConFieldType con label = case dataConFieldType_maybe con label of - Just (_, ty) -> ty - Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) - --- | Extract the label and type for any given labelled field of the --- 'DataCon', or return 'Nothing' if the field does not belong to it -dataConFieldType_maybe :: DataCon -> FieldLabelString - -> Maybe (FieldLabel, Type) -dataConFieldType_maybe con label - = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) - --- | Strictness/unpack annotations, from user; or, for imported --- DataCons, from the interface file --- The list is in one-to-one correspondence with the arity of the 'DataCon' - -dataConSrcBangs :: DataCon -> [HsSrcBang] -dataConSrcBangs = dcSrcBangs - --- | Source-level arity of the data constructor -dataConSourceArity :: DataCon -> Arity -dataConSourceArity (MkData { dcSourceArity = arity }) = arity - --- | Gives the number of actual fields in the /representation/ of the --- data constructor. This may be more than appear in the source code; --- the extra ones are the existentially quantified dictionaries -dataConRepArity :: DataCon -> Arity -dataConRepArity (MkData { dcRepArity = arity }) = arity - --- | Return whether there are any argument types for this 'DataCon's original source type --- See Note [DataCon arities] -isNullarySrcDataCon :: DataCon -> Bool -isNullarySrcDataCon dc = dataConSourceArity dc == 0 - --- | Return whether there are any argument types for this 'DataCon's runtime representation type --- See Note [DataCon arities] -isNullaryRepDataCon :: DataCon -> Bool -isNullaryRepDataCon dc = dataConRepArity dc == 0 - -dataConRepStrictness :: DataCon -> [StrictnessMark] --- ^ Give the demands on the arguments of a --- Core constructor application (Con dc args) -dataConRepStrictness dc = case dcRep dc of - NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] - DCR { dcr_stricts = strs } -> strs - -dataConImplBangs :: DataCon -> [HsImplBang] --- The implementation decisions about the strictness/unpack of each --- source program argument to the data constructor -dataConImplBangs dc - = case dcRep dc of - NoDataConRep -> replicate (dcSourceArity dc) HsLazy - DCR { dcr_bangs = bangs } -> bangs - -dataConBoxer :: DataCon -> Maybe DataConBoxer -dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer -dataConBoxer _ = Nothing - --- | The \"signature\" of the 'DataCon' returns, in order: --- --- 1) The result of 'dataConAllTyVars', --- --- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, implicit --- parameter - whatever) --- --- 3) The type arguments to the constructor --- --- 4) The /original/ result type of the 'DataCon' -dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) -dataConSig con@(MkData {dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (dataConAllTyVars con, dataConTheta con, arg_tys, res_ty) - -dataConInstSig - :: DataCon - -> [Type] -- Instantiate the *universal* tyvars with these types - -> ([TyVar], ThetaType, [Type]) -- Return instantiated existentials - -- theta and arg tys --- ^ Instantantiate the universal tyvars of a data con, --- returning the instantiated existentials, constraints, and args -dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs - , dcEqSpec = eq_spec, dcOtherTheta = theta - , dcOrigArgTys = arg_tys }) - univ_tys - = ( ex_tvs' - , substTheta subst (eqSpecPreds eq_spec ++ theta) - , substTys subst arg_tys) - where - univ_subst = zipTvSubst (binderVars univ_tvs) univ_tys - (subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst $ - binderVars ex_tvs - - --- | The \"full signature\" of the 'DataCon' returns, in order: --- --- 1) The result of 'dataConUnivTyVars' --- --- 2) The result of 'dataConExTyVars' --- --- 3) The GADT equalities --- --- 4) The result of 'dataConDictTheta' --- --- 5) The original argument types to the 'DataCon' (i.e. before --- any change of the representation of the type) --- --- 6) The original result type of the 'DataCon' -dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type) -dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, - dcEqSpec = eq_spec, dcOtherTheta = theta, - dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (binderVars univ_tvs, binderVars ex_tvs, eq_spec, theta, arg_tys, res_ty) - -dataConOrigResTy :: DataCon -> Type -dataConOrigResTy dc = dcOrigResTy dc - --- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: --- --- > data Eq a => T a = ... -dataConStupidTheta :: DataCon -> ThetaType -dataConStupidTheta dc = dcStupidTheta dc - -dataConUserType :: DataCon -> Type --- ^ The user-declared type of the data constructor --- in the nice-to-read form: --- --- > T :: forall a b. a -> b -> T [a] --- --- rather than: --- --- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c --- --- NB: If the constructor is part of a data instance, the result type --- mentions the family tycon, not the internal one. -dataConUserType (MkData { dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcOtherTheta = theta, dcOrigArgTys = arg_tys, - dcOrigResTy = res_ty }) - = mkForAllTys (filterEqSpec eq_spec univ_tvs) $ - mkForAllTys ex_tvs $ - mkFunTys theta $ - mkFunTys arg_tys $ - res_ty - --- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation --- NB: these INCLUDE any dictionary args --- but EXCLUDE the data-declaration context, which is discarded --- It's all post-flattening etc; this is a representation type -dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints - -- However, it can have a dcTheta (notably it can be a - -- class dictionary, with superclasses) - -> [Type] -- ^ Instantiated at these types - -> [Type] -dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs}) inst_tys - = ASSERT2( length univ_tvs == length inst_tys - , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) - ASSERT2( null ex_tvs, ppr dc ) - map (substTyWith (binderVars univ_tvs) inst_tys) (dataConRepArgTys dc) - --- | Returns just the instantiated /value/ argument types of a 'DataCon', --- (excluding dictionary args) -dataConInstOrigArgTys - :: DataCon -- Works for any DataCon - -> [Type] -- Includes existential tyvar args, but NOT - -- equality constraints or dicts - -> [Type] --- For vanilla datacons, it's all quite straightforward --- But for the call in MatchCon, we really do want just the value args -dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, - dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs}) inst_tys - = ASSERT2( length tyvars == length inst_tys - , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) - map (substTyWith tyvars inst_tys) arg_tys - where - tyvars = binderVars (univ_tvs ++ ex_tvs) - --- | Returns the argument types of the wrapper, excluding all dictionary arguments --- and without substituting for any type variables -dataConOrigArgTys :: DataCon -> [Type] -dataConOrigArgTys dc = dcOrigArgTys dc - --- | Returns the arg types of the worker, including *all* --- evidence, after any flattening has been done and without substituting for --- any type variables -dataConRepArgTys :: DataCon -> [Type] -dataConRepArgTys (MkData { dcRep = rep - , dcEqSpec = eq_spec - , dcOtherTheta = theta - , dcOrigArgTys = orig_arg_tys }) - = case rep of - NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys - DCR { dcr_arg_tys = arg_tys } -> arg_tys - --- | The string @package:module.name@ identifying a constructor, which is attached --- to its info table and used by the GHCi debugger and the heap profiler -dataConIdentity :: DataCon -> [Word8] --- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. -dataConIdentity dc = bytesFS (unitIdFS (moduleUnitId mod)) ++ - fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++ - fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name)) - where name = dataConName dc - mod = ASSERT( isExternalName name ) nameModule name - -isTupleDataCon :: DataCon -> Bool -isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc - -isUnboxedTupleCon :: DataCon -> Bool -isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc - -isUnboxedSumCon :: DataCon -> Bool -isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc - --- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors -isVanillaDataCon :: DataCon -> Bool -isVanillaDataCon dc = dcVanilla dc - --- | Should this DataCon be allowed in a type even without -XDataKinds? --- Currently, only Lifted & Unlifted -specialPromotedDc :: DataCon -> Bool -specialPromotedDc = isKindTyCon . dataConTyCon - --- | Was this datacon promotable before GHC 8.0? That is, is it promotable --- without -XTypeInType -isLegacyPromotableDataCon :: DataCon -> Bool -isLegacyPromotableDataCon dc - = null (dataConEqSpec dc) -- no GADTs - && null (dataConTheta dc) -- no context - && not (isFamInstTyCon (dataConTyCon dc)) -- no data instance constructors - && uniqSetAll isLegacyPromotableTyCon (tyConsOfType (dataConUserType dc)) - --- | Was this tycon promotable before GHC 8.0? That is, is it promotable --- without -XTypeInType -isLegacyPromotableTyCon :: TyCon -> Bool -isLegacyPromotableTyCon tc - = isVanillaAlgTyCon tc || - -- This returns True more often than it should, but it's quite painful - -- to make this fully accurate. And no harm is caused; we just don't - -- require -XTypeInType every time we need to. (We'll always require - -- -XDataKinds, though, so there's no standards-compliance issue.) - isFunTyCon tc || isKindTyCon tc - -classDataCon :: Class -> DataCon -classDataCon clas = case tyConDataCons (classTyCon clas) of - (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr - [] -> panic "classDataCon" - -dataConCannotMatch :: [Type] -> DataCon -> Bool --- Returns True iff the data con *definitely cannot* match a --- scrutinee of type (T tys) --- where T is the dcRepTyCon for the data con -dataConCannotMatch tys con - | null inst_theta = False -- Common - | all isTyVarTy tys = False -- Also common - | otherwise = typesCantMatch (concatMap predEqs inst_theta) - where - (_, inst_theta, _) = dataConInstSig con tys - - -- TODO: could gather equalities from superclasses too - predEqs pred = case classifyPredType pred of - EqPred NomEq ty1 ty2 -> [(ty1, ty2)] - ClassPred eq [_, ty1, ty2] - | eq `hasKey` eqTyConKey -> [(ty1, ty2)] - _ -> [] - -{- -%************************************************************************ -%* * - Promoting of data types to the kind level -* * -************************************************************************ - --} - -promoteDataCon :: DataCon -> TyCon -promoteDataCon (MkData { dcPromoted = tc }) = tc - -{- -************************************************************************ -* * -\subsection{Splitting products} -* * -************************************************************************ --} - --- | Extract the type constructor, type argument, data constructor and it's --- /representation/ argument types from a type if it is a product type. --- --- Precisely, we return @Just@ for any type that is all of: --- --- * Concrete (i.e. constructors visible) --- --- * Single-constructor --- --- * Not existentially quantified --- --- Whether the type is a @data@ type or a @newtype@ -splitDataProductType_maybe - :: Type -- ^ A product type, perhaps - -> Maybe (TyCon, -- The type constructor - [Type], -- Type args of the tycon - DataCon, -- The data constructor - [Type]) -- Its /representation/ arg types - - -- Rejecting existentials is conservative. Maybe some things - -- could be made to work with them, but I'm not going to sweat - -- it through till someone finds it's important. - -splitDataProductType_maybe ty - | Just (tycon, ty_args) <- splitTyConApp_maybe ty - , Just con <- isDataProductTyCon_maybe tycon - = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) - | otherwise - = Nothing - -{- -************************************************************************ -* * - Building an algebraic data type -* * -************************************************************************ - -buildAlgTyCon is here because it is called from TysWiredIn, which can -depend on this module, but not on BuildTyCl. --} - -buildAlgTyCon :: Name - -> [TyVar] -- ^ Kind variables and type variables - -> [Role] - -> Maybe CType - -> ThetaType -- ^ Stupid theta - -> AlgTyConRhs - -> Bool -- ^ True <=> was declared in GADT syntax - -> AlgTyConFlav - -> TyCon - -buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs - gadt_syn parent - = mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta - rhs parent gadt_syn - where - binders = mkTyConBindersPreferAnon ktvs liftedTypeKind - -buildSynTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> [Role] -> Type -> TyCon -buildSynTyCon name binders res_kind roles rhs - = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free - where - is_tau = isTauTy rhs - is_fam_free = isFamFreeTy rhs diff --git a/basicTypes/DataCon.hs-boot b/basicTypes/DataCon.hs-boot deleted file mode 100644 --- a/basicTypes/DataCon.hs-boot +++ /dev/null @@ -1,32 +0,0 @@ -module DataCon where -import Var( TyVar, TyVarBinder ) -import Name( Name, NamedThing ) -import {-# SOURCE #-} TyCon( TyCon ) -import FieldLabel ( FieldLabel ) -import Unique ( Uniquable ) -import Outputable ( Outputable, OutputableBndr ) -import BasicTypes (Arity) -import {-# SOURCE #-} TyCoRep ( Type, ThetaType ) - -data DataCon -data DataConRep -data EqSpec -filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder] - -dataConName :: DataCon -> Name -dataConTyCon :: DataCon -> TyCon -dataConUnivTyVarBinders :: DataCon -> [TyVarBinder] -dataConExTyVars :: DataCon -> [TyVar] -dataConExTyVarBinders :: DataCon -> [TyVarBinder] -dataConSourceArity :: DataCon -> Arity -dataConFieldLabels :: DataCon -> [FieldLabel] -dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] -dataConStupidTheta :: DataCon -> ThetaType -dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type) - -instance Eq DataCon -instance Uniquable DataCon -instance NamedThing DataCon -instance Outputable DataCon -instance OutputableBndr DataCon diff --git a/basicTypes/Demand.hs b/basicTypes/Demand.hs deleted file mode 100644 --- a/basicTypes/Demand.hs +++ /dev/null @@ -1,2174 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Demand]{@Demand@: A decoupled implementation of a demand domain} --} - -{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-} - -module Demand ( - StrDmd, UseDmd(..), Count, - - Demand, CleanDemand, getStrDmd, getUseDmd, - mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, - toCleanDmd, - absDmd, topDmd, botDmd, seqDmd, - lubDmd, bothDmd, - lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, - catchArgDmd, - isTopDmd, isAbsDmd, isSeqDmd, - peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, - addCaseBndrDmd, - - DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, - nopDmdType, botDmdType, mkDmdType, - addDemand, removeDmdTyArgs, - BothDmdArg, mkBothDmdArg, toBothDmdArg, - - DmdEnv, emptyDmdEnv, - peelFV, findIdDemand, - - DmdResult, CPRResult, - isBotRes, isTopRes, - topRes, botRes, exnRes, cprProdRes, - vanillaCprProdRes, cprSumRes, - appIsBottom, isBottomingSig, pprIfaceStrictSig, - trimCPRInfo, returnsCPR_maybe, - StrictSig(..), mkStrictSig, mkClosedStrictSig, - nopSig, botSig, exnSig, cprProdSig, - isTopSig, hasDemandEnvSig, - splitStrictSig, strictSigDmdEnv, - increaseStrictSigArity, - - seqDemand, seqDemandList, seqDmdType, seqStrictSig, - - evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, - splitDmdTy, splitFVs, - deferAfterIO, - postProcessUnsat, postProcessDmdType, - - splitProdDmd_maybe, peelCallDmd, mkCallDmd, mkWorkerDemand, - dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig, - argOneShots, argsOneShots, saturatedByOneShots, - trimToType, TypeShape(..), - - useCount, isUsedOnce, reuseEnv, - killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig, - zapUsedOnceDemand, zapUsedOnceSig, - strictifyDictDmd - - ) where - -#include "HsVersions.h" - -import DynFlags -import Outputable -import Var ( Var ) -import VarEnv -import UniqFM -import Util -import BasicTypes -import Binary -import Maybes ( orElse ) - -import Type ( Type, isUnliftedType ) -import TyCon ( isNewTyCon, isClassTyCon ) -import DataCon ( splitDataProductType_maybe ) - -{- -************************************************************************ -* * - Joint domain for Strictness and Absence -* * -************************************************************************ --} - -data JointDmd s u = JD { sd :: s, ud :: u } - deriving ( Eq, Show ) - -getStrDmd :: JointDmd s u -> s -getStrDmd = sd - -getUseDmd :: JointDmd s u -> u -getUseDmd = ud - --- Pretty-printing -instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where - ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u) - --- Well-formedness preserving constructors for the joint domain -mkJointDmd :: s -> u -> JointDmd s u -mkJointDmd s u = JD { sd = s, ud = u } - -mkJointDmds :: [s] -> [u] -> [JointDmd s u] -mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as - - -{- -************************************************************************ -* * - Strictness domain -* * -************************************************************************ - - Lazy - | - ExnStr x - - | - HeadStr - / \ - SCall SProd - \ / - HyperStr - -Note [Exceptions and strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Exceptions need rather careful treatment, especially because of 'catch' -('catch#'), 'catchSTM' ('catchSTM#'), and 'orElse' ('catchRetry#'). -See Trac #11555, #10712 and #13330, and for some more background, #11222. - -There are three main pieces. - -* The Termination type includes ThrowsExn, meaning "under the given - demand this expression either diverges or throws an exception". - - This is relatively uncontroversial. The primops raise# and - raiseIO# both return ThrowsExn; nothing else does. - -* An ArgStr has an ExnStr flag to say how to process the Termination - result of the argument. If the ExnStr flag is ExnStr, we squash - ThrowsExn to topRes. (This is done in postProcessDmdResult.) - -Here is the key example - - catchRetry# (\s -> retry# s) blah - -We analyse the argument (\s -> retry# s) with demand - Str ExnStr (SCall HeadStr) -i.e. with the ExnStr flag set. - - First we analyse the argument with the "clean-demand" (SCall - HeadStr), getting a DmdResult of ThrowsExn from the saturated - application of retry#. - - Then we apply the post-processing for the shell, squashing the - ThrowsExn to topRes. - -This also applies uniformly to free variables. Consider - - let r = \st -> retry# st - in catchRetry# (\s -> ...(r s')..) handler st - -If we give the first argument of catch a strict signature, we'll get a demand -'C(S)' for 'r'; that is, 'r' is definitely called with one argument, which -indeed it is. But when we post-process the free-var demands on catchRetry#'s -argument (in postProcessDmdEnv), we'll give 'r' a demand of (Str ExnStr (SCall -HeadStr)); and if we feed that into r's RHS (which would be reasonable) we'll -squash the retry just as if we'd inlined 'r'. - -* We don't try to get clever about 'catch#' and 'catchSTM#' at the moment. We -previously (#11222) tried to take advantage of the fact that 'catch#' calls its -first argument eagerly. See especially commit -9915b6564403a6d17651e9969e9ea5d7d7e78e7f. We analyzed that first argument with -a strict demand, and then performed a post-processing step at the end to change -ThrowsExn to TopRes. The trouble, I believe, is that to use this approach -correctly, we'd need somewhat different information about that argument. -Diverges, ThrowsExn (i.e., diverges or throws an exception), and Dunno are the -wrong split here. In order to evaluate part of the argument speculatively, -we'd need to know that it *does not throw an exception*. That is, that it -either diverges or succeeds. But we don't currently have a way to talk about -that. Abstractly and approximately, - -catch# m f s = case ORACLE m s of - DivergesOrSucceeds -> m s - Fails exc -> f exc s - -where the magical ORACLE determines whether or not (m s) throws an exception -when run, and if so which one. If we want, we can safely consider (catch# m f s) -strict in anything that both branches are strict in (by performing demand -analysis for 'catch#' in the same way we do for case). We could also safely -consider it strict in anything demanded by (m s) that is guaranteed not to -throw an exception under that demand, but I don't know if we have the means -to express that. - -My mind keeps turning to this model (not as an actual change to the type, but -as a way to think about what's going on in the analysis): - -newtype IO a = IO {unIO :: State# s -> (# s, (# SomeException | a #) #)} -instance Monad IO where - return a = IO $ \s -> (# s, (# | a #) #) - IO m >>= f = IO $ \s -> case m s of - (# s', (# e | #) #) -> (# s', e #) - (# s', (# | a #) #) -> unIO (f a) s -raiseIO# e s = (# s, (# e | #) #) -catch# m f s = case m s of - (# s', (# e | #) #) -> f e s' - res -> res - -Thinking about it this way seems likely to be productive for analyzing IO -exception behavior, but imprecise exceptions and asynchronous exceptions remain -quite slippery beasts. Can we incorporate them? I think we can. We can imagine -applying 'seq#' to evaluate @m s@, determining whether it throws an imprecise -or asynchronous exception or whether it succeeds or throws an IO exception. -This confines the peculiarities to 'seq#', which is indeed rather essentially -peculiar. --} - --- Vanilla strictness domain -data StrDmd - = HyperStr -- Hyper-strict - -- Bottom of the lattice - -- Note [HyperStr and Use demands] - - | SCall StrDmd -- Call demand - -- Used only for values of function type - - | SProd [ArgStr] -- Product - -- Used only for values of product type - -- Invariant: not all components are HyperStr (use HyperStr) - -- not all components are Lazy (use HeadStr) - - | HeadStr -- Head-Strict - -- A polymorphic demand: used for values of all types, - -- including a type variable - - deriving ( Eq, Show ) - -type ArgStr = Str StrDmd - -data Str s = Lazy -- Lazy - -- Top of the lattice - | Str ExnStr s - deriving ( Eq, Show ) - -data ExnStr -- See Note [Exceptions and strictness] - = VanStr -- "Vanilla" case, ordinary strictness - - | ExnStr -- (Str ExnStr d) means be strict like 'd' but then degrade - -- the Termination info ThrowsExn to Dunno - deriving( Eq, Show ) - --- Well-formedness preserving constructors for the Strictness domain -strBot, strTop :: ArgStr -strBot = Str VanStr HyperStr -strTop = Lazy - -mkSCall :: StrDmd -> StrDmd -mkSCall HyperStr = HyperStr -mkSCall s = SCall s - -mkSProd :: [ArgStr] -> StrDmd -mkSProd sx - | any isHyperStr sx = HyperStr - | all isLazy sx = HeadStr - | otherwise = SProd sx - -isLazy :: ArgStr -> Bool -isLazy Lazy = True -isLazy (Str {}) = False - -isHyperStr :: ArgStr -> Bool -isHyperStr (Str _ HyperStr) = True -isHyperStr _ = False - --- Pretty-printing -instance Outputable StrDmd where - ppr HyperStr = char 'B' - ppr (SCall s) = char 'C' <> parens (ppr s) - ppr HeadStr = char 'S' - ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) - -instance Outputable ArgStr where - ppr (Str x s) = (case x of VanStr -> empty; ExnStr -> char 'x') - <> ppr s - ppr Lazy = char 'L' - -lubArgStr :: ArgStr -> ArgStr -> ArgStr -lubArgStr Lazy _ = Lazy -lubArgStr _ Lazy = Lazy -lubArgStr (Str x1 s1) (Str x2 s2) = Str (x1 `lubExnStr` x2) (s1 `lubStr` s2) - -lubExnStr :: ExnStr -> ExnStr -> ExnStr -lubExnStr VanStr VanStr = VanStr -lubExnStr _ _ = ExnStr -- ExnStr is lazier - -lubStr :: StrDmd -> StrDmd -> StrDmd -lubStr HyperStr s = s -lubStr (SCall s1) HyperStr = SCall s1 -lubStr (SCall _) HeadStr = HeadStr -lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) -lubStr (SCall _) (SProd _) = HeadStr -lubStr (SProd sx) HyperStr = SProd sx -lubStr (SProd _) HeadStr = HeadStr -lubStr (SProd s1) (SProd s2) - | length s1 == length s2 = mkSProd (zipWith lubArgStr s1 s2) - | otherwise = HeadStr -lubStr (SProd _) (SCall _) = HeadStr -lubStr HeadStr _ = HeadStr - -bothArgStr :: ArgStr -> ArgStr -> ArgStr -bothArgStr Lazy s = s -bothArgStr s Lazy = s -bothArgStr (Str x1 s1) (Str x2 s2) = Str (x1 `bothExnStr` x2) (s1 `bothStr` s2) - -bothExnStr :: ExnStr -> ExnStr -> ExnStr -bothExnStr ExnStr ExnStr = ExnStr -bothExnStr _ _ = VanStr - -bothStr :: StrDmd -> StrDmd -> StrDmd -bothStr HyperStr _ = HyperStr -bothStr HeadStr s = s -bothStr (SCall _) HyperStr = HyperStr -bothStr (SCall s1) HeadStr = SCall s1 -bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) -bothStr (SCall _) (SProd _) = HyperStr -- Weird - -bothStr (SProd _) HyperStr = HyperStr -bothStr (SProd s1) HeadStr = SProd s1 -bothStr (SProd s1) (SProd s2) - | length s1 == length s2 = mkSProd (zipWith bothArgStr s1 s2) - | otherwise = HyperStr -- Weird -bothStr (SProd _) (SCall _) = HyperStr - --- utility functions to deal with memory leaks -seqStrDmd :: StrDmd -> () -seqStrDmd (SProd ds) = seqStrDmdList ds -seqStrDmd (SCall s) = seqStrDmd s -seqStrDmd _ = () - -seqStrDmdList :: [ArgStr] -> () -seqStrDmdList [] = () -seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds - -seqArgStr :: ArgStr -> () -seqArgStr Lazy = () -seqArgStr (Str x s) = x `seq` seqStrDmd s - --- Splitting polymorphic demands -splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr] -splitArgStrProdDmd n Lazy = Just (replicate n Lazy) -splitArgStrProdDmd n (Str _ s) = splitStrProdDmd n s - -splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr] -splitStrProdDmd n HyperStr = Just (replicate n strBot) -splitStrProdDmd n HeadStr = Just (replicate n strTop) -splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n), - text "splitStrProdDmd" $$ ppr n $$ ppr ds ) - Just ds -splitStrProdDmd _ (SCall {}) = Nothing - -- This can happen when the programmer uses unsafeCoerce, - -- and we don't then want to crash the compiler (Trac #9208) - -{- -************************************************************************ -* * - Absence domain -* * -************************************************************************ - - Used - / \ - UCall UProd - \ / - UHead - | - Count x - - | - Abs --} - --- Domain for genuine usage -data UseDmd - = UCall Count UseDmd -- Call demand for absence - -- Used only for values of function type - - | UProd [ArgUse] -- Product - -- Used only for values of product type - -- See Note [Don't optimise UProd(Used) to Used] - -- [Invariant] Not all components are Abs - -- (in that case, use UHead) - - | UHead -- May be used; but its sub-components are - -- definitely *not* used. Roughly U(AAA) - -- Eg the usage of x in x `seq` e - -- A polymorphic demand: used for values of all types, - -- including a type variable - -- Since (UCall _ Abs) is ill-typed, UHead doesn't - -- make sense for lambdas - - | Used -- May be used; and its sub-components may be used - -- Top of the lattice - deriving ( Eq, Show ) - --- Extended usage demand for absence and counting -type ArgUse = Use UseDmd - -data Use u - = Abs -- Definitely unused - -- Bottom of the lattice - - | Use Count u -- May be used with some cardinality - deriving ( Eq, Show ) - --- Abstract counting of usages -data Count = One | Many - deriving ( Eq, Show ) - --- Pretty-printing -instance Outputable ArgUse where - ppr Abs = char 'A' - ppr (Use Many a) = ppr a - ppr (Use One a) = char '1' <> char '*' <> ppr a - -instance Outputable UseDmd where - ppr Used = char 'U' - ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) - ppr UHead = char 'H' - ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) - -instance Outputable Count where - ppr One = char '1' - ppr Many = text "" - -useBot, useTop :: ArgUse -useBot = Abs -useTop = Use Many Used - -mkUCall :: Count -> UseDmd -> UseDmd ---mkUCall c Used = Used c -mkUCall c a = UCall c a - -mkUProd :: [ArgUse] -> UseDmd -mkUProd ux - | all (== Abs) ux = UHead - | otherwise = UProd ux - -lubCount :: Count -> Count -> Count -lubCount _ Many = Many -lubCount Many _ = Many -lubCount x _ = x - -lubArgUse :: ArgUse -> ArgUse -> ArgUse -lubArgUse Abs x = x -lubArgUse x Abs = x -lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) - -lubUse :: UseDmd -> UseDmd -> UseDmd -lubUse UHead u = u -lubUse (UCall c u) UHead = UCall c u -lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) -lubUse (UCall _ _) _ = Used -lubUse (UProd ux) UHead = UProd ux -lubUse (UProd ux1) (UProd ux2) - | length ux1 == length ux2 = UProd $ zipWith lubArgUse ux1 ux2 - | otherwise = Used -lubUse (UProd {}) (UCall {}) = Used --- lubUse (UProd {}) Used = Used -lubUse (UProd ux) Used = UProd (map (`lubArgUse` useTop) ux) -lubUse Used (UProd ux) = UProd (map (`lubArgUse` useTop) ux) -lubUse Used _ = Used -- Note [Used should win] - --- `both` is different from `lub` in its treatment of counting; if --- `both` is computed for two used, the result always has --- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). --- Also, x `bothUse` x /= x (for anything but Abs). - -bothArgUse :: ArgUse -> ArgUse -> ArgUse -bothArgUse Abs x = x -bothArgUse x Abs = x -bothArgUse (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) - - -bothUse :: UseDmd -> UseDmd -> UseDmd -bothUse UHead u = u -bothUse (UCall c u) UHead = UCall c u - --- Exciting special treatment of inner demand for call demands: --- use `lubUse` instead of `bothUse`! -bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) - -bothUse (UCall {}) _ = Used -bothUse (UProd ux) UHead = UProd ux -bothUse (UProd ux1) (UProd ux2) - | length ux1 == length ux2 = UProd $ zipWith bothArgUse ux1 ux2 - | otherwise = Used -bothUse (UProd {}) (UCall {}) = Used --- bothUse (UProd {}) Used = Used -- Note [Used should win] -bothUse Used (UProd ux) = UProd (map (`bothArgUse` useTop) ux) -bothUse (UProd ux) Used = UProd (map (`bothArgUse` useTop) ux) -bothUse Used _ = Used -- Note [Used should win] - -peelUseCall :: UseDmd -> Maybe (Count, UseDmd) -peelUseCall (UCall c u) = Just (c,u) -peelUseCall _ = Nothing - -addCaseBndrDmd :: Demand -- On the case binder - -> [Demand] -- On the components of the constructor - -> [Demand] -- Final demands for the components of the constructor --- See Note [Demand on case-alternative binders] -addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds - = case mu of - Abs -> alt_dmds - Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us) - where - Just ss = splitArgStrProdDmd arity ms -- Guaranteed not to be a call - Just us = splitUseProdDmd arity u -- Ditto - where - arity = length alt_dmds - -{- Note [Demand on case-alternative binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The demand on a binder in a case alternative comes - (a) From the demand on the binder itself - (b) From the demand on the case binder -Forgetting (b) led directly to Trac #10148. - -Example. Source code: - f x@(p,_) = if p then foo x else True - - foo (p,True) = True - foo (p,q) = foo (q,p) - -After strictness analysis: - f = \ (x_an1 [Dmd=] :: (Bool, Bool)) -> - case x_an1 - of wild_X7 [Dmd=] - { (p_an2 [Dmd=], ds_dnz [Dmd=]) -> - case p_an2 of _ { - False -> GHC.Types.True; - True -> foo wild_X7 } - -It's true that ds_dnz is *itself* absent, but the use of wild_X7 means -that it is very much alive and demanded. See Trac #10148 for how the -consequences play out. - -This is needed even for non-product types, in case the case-binder -is used but the components of the case alternative are not. - -Note [Don't optimise UProd(Used) to Used] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These two UseDmds: - UProd [Used, Used] and Used -are semantically equivalent, but we do not turn the former into -the latter, for a regrettable-subtle reason. Suppose we did. -then - f (x,y) = (y,x) -would get - StrDmd = Str = SProd [Lazy, Lazy] - UseDmd = Used = UProd [Used, Used] -But with the joint demand of doesn't convey any clue -that there is a product involved, and so the worthSplittingFun -will not fire. (We'd need to use the type as well to make it fire.) -Moreover, consider - g h p@(_,_) = h p -This too would get , but this time there really isn't any -point in w/w since the components of the pair are not used at all. - -So the solution is: don't aggressively collapse UProd [Used,Used] to -Used; intead leave it as-is. In effect we are using the UseDmd to do a -little bit of boxity analysis. Not very nice. - -Note [Used should win] -~~~~~~~~~~~~~~~~~~~~~~ -Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. -Why? Because Used carries the implication the whole thing is used, -box and all, so we don't want to w/w it. If we use it both boxed and -unboxed, then we are definitely using the box, and so we are quite -likely to pay a reboxing cost. So we make Used win here. - -Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer - -Baseline: (A) Not making Used win (UProd wins) -Compare with: (B) making Used win for lub and both - - Min -0.3% -5.6% -10.7% -11.0% -33.3% - Max +0.3% +45.6% +11.5% +11.5% +6.9% - Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% - -Baseline: (B) Making Used win for both lub and both -Compare with: (C) making Used win for both, but UProd win for lub - - Min -0.1% -0.3% -7.9% -8.0% -6.5% - Max +0.1% +1.0% +21.0% +21.0% +0.5% - Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% --} - --- If a demand is used multiple times (i.e. reused), than any use-once --- mentioned there, that is not protected by a UCall, can happen many times. -markReusedDmd :: ArgUse -> ArgUse -markReusedDmd Abs = Abs -markReusedDmd (Use _ a) = Use Many (markReused a) - -markReused :: UseDmd -> UseDmd -markReused (UCall _ u) = UCall Many u -- No need to recurse here -markReused (UProd ux) = UProd (map markReusedDmd ux) -markReused u = u - -isUsedMU :: ArgUse -> Bool --- True <=> markReusedDmd d = d -isUsedMU Abs = True -isUsedMU (Use One _) = False -isUsedMU (Use Many u) = isUsedU u - -isUsedU :: UseDmd -> Bool --- True <=> markReused d = d -isUsedU Used = True -isUsedU UHead = True -isUsedU (UProd us) = all isUsedMU us -isUsedU (UCall One _) = False -isUsedU (UCall Many _) = True -- No need to recurse - --- Squashing usage demand demands -seqUseDmd :: UseDmd -> () -seqUseDmd (UProd ds) = seqArgUseList ds -seqUseDmd (UCall c d) = c `seq` seqUseDmd d -seqUseDmd _ = () - -seqArgUseList :: [ArgUse] -> () -seqArgUseList [] = () -seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds - -seqArgUse :: ArgUse -> () -seqArgUse (Use c u) = c `seq` seqUseDmd u -seqArgUse _ = () - --- Splitting polymorphic Maybe-Used demands -splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse] -splitUseProdDmd n Used = Just (replicate n useTop) -splitUseProdDmd n UHead = Just (replicate n Abs) -splitUseProdDmd n (UProd ds) = WARN( not (ds `lengthIs` n), - text "splitUseProdDmd" $$ ppr n - $$ ppr ds ) - Just ds -splitUseProdDmd _ (UCall _ _) = Nothing - -- This can happen when the programmer uses unsafeCoerce, - -- and we don't then want to crash the compiler (Trac #9208) - -useCount :: Use u -> Count -useCount Abs = One -useCount (Use One _) = One -useCount _ = Many - - -{- -************************************************************************ -* * - Clean demand for Strictness and Usage -* * -************************************************************************ - -This domain differst from JointDemand in the sence that pure absence -is taken away, i.e., we deal *only* with non-absent demands. - -Note [Strict demands] -~~~~~~~~~~~~~~~~~~~~~ -isStrictDmd returns true only of demands that are - both strict - and used -In particular, it is False for , which can and does -arise in, say (Trac #7319) - f x = raise# -Then 'x' is not used, so f gets strictness -> . -Now the w/w generates - fx = let x = absentError "unused" - in raise -At this point we really don't want to convert to - fx = case absentError "unused" of x -> raise -Since the program is going to diverge, this swaps one error for another, -but it's really a bad idea to *ever* evaluate an absent argument. -In Trac #7319 we get - T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] - -Note [Dealing with call demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Call demands are constructed and deconstructed coherently for -strictness and absence. For instance, the strictness signature for the -following function - -f :: (Int -> (Int, Int)) -> (Int, Bool) -f g = (snd (g 3), True) - -should be: m --} - -type CleanDemand = JointDmd StrDmd UseDmd - -- A demand that is at least head-strict - -bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand -bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2}) - = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } - -mkHeadStrict :: CleanDemand -> CleanDemand -mkHeadStrict cd = cd { sd = HeadStr } - -mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand -mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use One a } -mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use Many a } - -evalDmd :: Demand --- Evaluated strictly, and used arbitrarily deeply -evalDmd = JD { sd = Str VanStr HeadStr, ud = useTop } - -mkProdDmd :: [Demand] -> CleanDemand -mkProdDmd dx - = JD { sd = mkSProd $ map getStrDmd dx - , ud = mkUProd $ map getUseDmd dx } - -mkCallDmd :: CleanDemand -> CleanDemand -mkCallDmd (JD {sd = d, ud = u}) - = JD { sd = mkSCall d, ud = mkUCall One u } - --- See Note [Demand on the worker] in WorkWrap -mkWorkerDemand :: Int -> Demand -mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) } - where go 0 = Used - go n = mkUCall One $ go (n-1) - -cleanEvalDmd :: CleanDemand -cleanEvalDmd = JD { sd = HeadStr, ud = Used } - -cleanEvalProdDmd :: Arity -> CleanDemand -cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) } - - -{- -************************************************************************ -* * - Demand: combining stricness and usage -* * -************************************************************************ --} - -type Demand = JointDmd ArgStr ArgUse - -lubDmd :: Demand -> Demand -> Demand -lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) - = JD { sd = s1 `lubArgStr` s2 - , ud = a1 `lubArgUse` a2 } - -bothDmd :: Demand -> Demand -> Demand -bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) - = JD { sd = s1 `bothArgStr` s2 - , ud = a1 `bothArgUse` a2 } - -lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, catchArgDmd :: Demand - -strictApply1Dmd = JD { sd = Str VanStr (SCall HeadStr) - , ud = Use Many (UCall One Used) } - --- First argument of catchRetry# and catchSTM#: --- uses its arg once, applies it once --- and catches exceptions (the ExnStr) part -catchArgDmd = JD { sd = Str ExnStr (SCall HeadStr) - , ud = Use One (UCall One Used) } - -lazyApply1Dmd = JD { sd = Lazy - , ud = Use One (UCall One Used) } - --- Second argument of catch#: --- uses its arg at most once, applies it once --- but is lazy (might not be called at all) -lazyApply2Dmd = JD { sd = Lazy - , ud = Use One (UCall One (UCall One Used)) } - -absDmd :: Demand -absDmd = JD { sd = Lazy, ud = Abs } - -topDmd :: Demand -topDmd = JD { sd = Lazy, ud = useTop } - -botDmd :: Demand -botDmd = JD { sd = strBot, ud = useBot } - -seqDmd :: Demand -seqDmd = JD { sd = Str VanStr HeadStr, ud = Use One UHead } - -oneifyDmd :: Demand -> Demand -oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a } -oneifyDmd jd = jd - -isTopDmd :: Demand -> Bool --- Used to suppress pretty-printing of an uninformative demand -isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True -isTopDmd _ = False - -isAbsDmd :: Demand -> Bool -isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr -isAbsDmd _ = False -- for a bottom demand - -isSeqDmd :: Demand -> Bool -isSeqDmd (JD {sd = Str VanStr HeadStr, ud = Use _ UHead}) = True -isSeqDmd _ = False - -isUsedOnce :: Demand -> Bool -isUsedOnce (JD { ud = a }) = case useCount a of - One -> True - Many -> False - --- More utility functions for strictness -seqDemand :: Demand -> () -seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u - -seqDemandList :: [Demand] -> () -seqDemandList [] = () -seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds - -isStrictDmd :: Demand -> Bool --- See Note [Strict demands] -isStrictDmd (JD {ud = Abs}) = False -isStrictDmd (JD {sd = Lazy}) = False -isStrictDmd _ = True - -isWeakDmd :: Demand -> Bool -isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a - -cleanUseDmd_maybe :: Demand -> Maybe UseDmd -cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u -cleanUseDmd_maybe _ = Nothing - -splitFVs :: Bool -- Thunk - -> DmdEnv -> (DmdEnv, DmdEnv) -splitFVs is_thunk rhs_fvs - | is_thunk = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs - -- It's OK to use nonDetFoldUFM_Directly because we - -- immediately forget the ordering by putting the elements - -- in the envs again - | otherwise = partitionVarEnv isWeakDmd rhs_fvs - where - add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv) - | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv) - | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u }) - , addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) ) - -data TypeShape = TsFun TypeShape - | TsProd [TypeShape] - | TsUnk - -instance Outputable TypeShape where - ppr TsUnk = text "TsUnk" - ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) - ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) - -trimToType :: Demand -> TypeShape -> Demand --- See Note [Trimming a demand to a type] -trimToType (JD { sd = ms, ud = mu }) ts - = JD (go_ms ms ts) (go_mu mu ts) - where - go_ms :: ArgStr -> TypeShape -> ArgStr - go_ms Lazy _ = Lazy - go_ms (Str x s) ts = Str x (go_s s ts) - - go_s :: StrDmd -> TypeShape -> StrDmd - go_s HyperStr _ = HyperStr - go_s (SCall s) (TsFun ts) = SCall (go_s s ts) - go_s (SProd mss) (TsProd tss) - | equalLength mss tss = SProd (zipWith go_ms mss tss) - go_s _ _ = HeadStr - - go_mu :: ArgUse -> TypeShape -> ArgUse - go_mu Abs _ = Abs - go_mu (Use c u) ts = Use c (go_u u ts) - - go_u :: UseDmd -> TypeShape -> UseDmd - go_u UHead _ = UHead - go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts) - go_u (UProd mus) (TsProd tss) - | equalLength mus tss = UProd (zipWith go_mu mus tss) - go_u _ _ = Used - -{- -Note [Trimming a demand to a type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f :: a -> Bool - f x = case ... of - A g1 -> case (x |> g1) of (p,q) -> ... - B -> error "urk" - -where A,B are the constructors of a GADT. We'll get a U(U,U) demand -on x from the A branch, but that's a stupid demand for x itself, which -has type 'a'. Indeed we get ASSERTs going off (notably in -splitUseProdDmd, Trac #8569). - -Bottom line: we really don't want to have a binder whose demand is more -deeply-nested than its type. There are various ways to tackle this. -When processing (x |> g1), we could "trim" the incoming demand U(U,U) -to match x's type. But I'm currently doing so just at the moment when -we pin a demand on a binder, in DmdAnal.findBndrDmd. - - -Note [Threshold demands] -~~~~~~~~~~~~~~~~~~~~~~~~ -Threshold usage demand is generated to figure out if -cardinality-instrumented demands of a binding's free variables should -be unleashed. See also [Aggregated demand for cardinality]. - -Note [Replicating polymorphic demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some demands can be considered as polymorphic. Generally, it is -applicable to such beasts as tops, bottoms as well as Head-Used and -Head-stricts demands. For instance, - -S ~ S(L, ..., L) - -Also, when top or bottom is occurred as a result demand, it in fact -can be expanded to saturate a callee's arity. --} - -splitProdDmd_maybe :: Demand -> Maybe [Demand] --- Split a product into its components, iff there is any --- useful information to be extracted thereby --- The demand is not necessarily strict! -splitProdDmd_maybe (JD { sd = s, ud = u }) - = case (s,u) of - (Str _ (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u - -> Just (mkJointDmds sx ux) - (Str _ s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s - -> Just (mkJointDmds sx ux) - (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) - _ -> Nothing - -{- -************************************************************************ -* * - Demand results -* * -************************************************************************ - - -DmdResult: Dunno CPRResult - / - ThrowsExn - / - Diverges - - -CPRResult: NoCPR - / \ - RetProd RetSum ConTag - - -Product constructors return (Dunno (RetProd rs)) -In a fixpoint iteration, start from Diverges -We have lubs, but not glbs; but that is ok. --} - ------------------------------------------------------------------------- --- Constructed Product Result ------------------------------------------------------------------------- - -data Termination r - = Diverges -- Definitely diverges - | ThrowsExn -- Definitely throws an exception or diverges - | Dunno r -- Might diverge or converge - deriving( Eq, Show ) - -type DmdResult = Termination CPRResult - -data CPRResult = NoCPR -- Top of the lattice - | RetProd -- Returns a constructor from a product type - | RetSum ConTag -- Returns a constructor from a data type - deriving( Eq, Show ) - -lubCPR :: CPRResult -> CPRResult -> CPRResult -lubCPR (RetSum t1) (RetSum t2) - | t1 == t2 = RetSum t1 -lubCPR RetProd RetProd = RetProd -lubCPR _ _ = NoCPR - -lubDmdResult :: DmdResult -> DmdResult -> DmdResult -lubDmdResult Diverges r = r -lubDmdResult ThrowsExn Diverges = ThrowsExn -lubDmdResult ThrowsExn r = r -lubDmdResult (Dunno c1) Diverges = Dunno c1 -lubDmdResult (Dunno c1) ThrowsExn = Dunno c1 -lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2) --- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 --- (See Note [Default demand on free variables] for why) - -bothDmdResult :: DmdResult -> Termination () -> DmdResult --- See Note [Asymmetry of 'both' for DmdType and DmdResult] -bothDmdResult _ Diverges = Diverges -bothDmdResult r ThrowsExn = case r of { Diverges -> r; _ -> ThrowsExn } -bothDmdResult r (Dunno {}) = r --- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 --- (See Note [Default demand on free variables] for why) - -instance Outputable r => Outputable (Termination r) where - ppr Diverges = char 'b' - ppr ThrowsExn = char 'x' - ppr (Dunno c) = ppr c - -instance Outputable CPRResult where - ppr NoCPR = empty - ppr (RetSum n) = char 'm' <> int n - ppr RetProd = char 'm' - -seqDmdResult :: DmdResult -> () -seqDmdResult Diverges = () -seqDmdResult ThrowsExn = () -seqDmdResult (Dunno c) = seqCPRResult c - -seqCPRResult :: CPRResult -> () -seqCPRResult NoCPR = () -seqCPRResult (RetSum n) = n `seq` () -seqCPRResult RetProd = () - - ------------------------------------------------------------------------- --- Combined demand result -- ------------------------------------------------------------------------- - --- [cprRes] lets us switch off CPR analysis --- by making sure that everything uses TopRes -topRes, exnRes, botRes :: DmdResult -topRes = Dunno NoCPR -exnRes = ThrowsExn -botRes = Diverges - -cprSumRes :: ConTag -> DmdResult -cprSumRes tag = Dunno $ RetSum tag - -cprProdRes :: [DmdType] -> DmdResult -cprProdRes _arg_tys = Dunno $ RetProd - -vanillaCprProdRes :: Arity -> DmdResult -vanillaCprProdRes _arity = Dunno $ RetProd - -isTopRes :: DmdResult -> Bool -isTopRes (Dunno NoCPR) = True -isTopRes _ = False - -isBotRes :: DmdResult -> Bool --- True if the result diverges or throws an exception -isBotRes Diverges = True -isBotRes ThrowsExn = True -isBotRes (Dunno {}) = False - -trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult -trimCPRInfo trim_all trim_sums res - = trimR res - where - trimR (Dunno c) = Dunno (trimC c) - trimR res = res - - trimC (RetSum n) | trim_all || trim_sums = NoCPR - | otherwise = RetSum n - trimC RetProd | trim_all = NoCPR - | otherwise = RetProd - trimC NoCPR = NoCPR - -returnsCPR_maybe :: DmdResult -> Maybe ConTag -returnsCPR_maybe (Dunno c) = retCPR_maybe c -returnsCPR_maybe _ = Nothing - -retCPR_maybe :: CPRResult -> Maybe ConTag -retCPR_maybe (RetSum t) = Just t -retCPR_maybe RetProd = Just fIRST_TAG -retCPR_maybe NoCPR = Nothing - --- See Notes [Default demand on free variables] --- and [defaultDmd vs. resTypeArgDmd] -defaultDmd :: Termination r -> Demand -defaultDmd (Dunno {}) = absDmd -defaultDmd _ = botDmd -- Diverges or ThrowsExn - -resTypeArgDmd :: Termination r -> Demand --- TopRes and BotRes are polymorphic, so that --- BotRes === (Bot -> BotRes) === ... --- TopRes === (Top -> TopRes) === ... --- This function makes that concrete --- Also see Note [defaultDmd vs. resTypeArgDmd] -resTypeArgDmd (Dunno _) = topDmd -resTypeArgDmd _ = botDmd -- Diverges or ThrowsExn - -{- -Note [defaultDmd and resTypeArgDmd] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -These functions are similar: They express the demand on something not -explicitly mentioned in the environment resp. the argument list. Yet they are -different: - * Variables not mentioned in the free variables environment are definitely - unused, so we can use absDmd there. - * Further arguments *can* be used, of course. Hence topDmd is used. - -Note [Worthy functions for Worker-Wrapper split] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For non-bottoming functions a worker-wrapper transformation takes into -account several possibilities to decide if the function is worthy for -splitting: - -1. The result is of product type and the function is strict in some -(or even all) of its arguments. The check that the argument is used is -more of sanity nature, since strictness implies usage. Example: - -f :: (Int, Int) -> Int -f p = (case p of (a,b) -> a) + 1 - -should be splitted to - -f :: (Int, Int) -> Int -f p = case p of (a,b) -> $wf a - -$wf :: Int -> Int -$wf a = a + 1 - -2. Sometimes it also makes sense to perform a WW split if the -strictness analysis cannot say for sure if the function is strict in -components of its argument. Then we reason according to the inferred -usage information: if the function uses its product argument's -components, the WW split can be beneficial. Example: - -g :: Bool -> (Int, Int) -> Int -g c p = case p of (a,b) -> - if c then a else b - -The function g is strict in is argument p and lazy in its -components. However, both components are used in the RHS. The idea is -since some of the components (both in this case) are used in the -right-hand side, the product must presumable be taken apart. - -Therefore, the WW transform splits the function g to - -g :: Bool -> (Int, Int) -> Int -g c p = case p of (a,b) -> $wg c a b - -$wg :: Bool -> Int -> Int -> Int -$wg c a b = if c then a else b - -3. If an argument is absent, it would be silly to pass it to a -function, hence the worker with reduced arity is generated. - - -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....] - -However we *don't* want to do this when the argument is not actually -taken apart in the function at all. 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 - - -************************************************************************ -* * - Demand environments and types -* * -************************************************************************ --} - -type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables] - -data DmdType = DmdType - DmdEnv -- Demand on explicitly-mentioned - -- free variables - [Demand] -- Demand on arguments - DmdResult -- See [Nature of result demand] - -{- -Note [Nature of result demand] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A DmdResult contains information about termination (currently distinguishing -definite divergence and no information; it is possible to include definite -convergence here), and CPR information about the result. - -The semantics of this depends on whether we are looking at a DmdType, i.e. the -demand put on by an expression _under a specific incoming demand_ on its -environment, or at a StrictSig describing a demand transformer. - -For a - * DmdType, the termination information is true given the demand it was - generated with, while for - * a StrictSig it holds after applying enough arguments. - -The CPR information, though, is valid after the number of arguments mentioned -in the type is given. Therefore, when forgetting the demand on arguments, as in -dmdAnalRhs, this needs to be considere (via removeDmdTyArgs). - -Consider - b2 x y = x `seq` y `seq` error (show x) -this has a strictness signature of - b -meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but -for "b2 1 2 `seq` ()" we get definite divergence. - -For comparison, - b1 x = x `seq` error (show x) -has a strictness signature of - b -and "b1 1 `seq` ()" is known to terminate. - -Now consider a function h with signature "", and the expression - e1 = h b1 -now h puts a demand of onto its argument, and the demand transformer -turns it into - b -Now the DmdResult "b" does apply to us, even though "b1 `seq` ()" does not -diverge, and we do not anything being passed to b. - -Note [Asymmetry of 'both' for DmdType and DmdResult] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'both' for DmdTypes is *asymmetrical*, because there is only one -result! For example, given (e1 e2), we get a DmdType dt1 for e1, use -its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2). -Similarly with - case e of { p -> rhs } -we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then -compute (dt_rhs `bothType` dt_scrut). - -We - 1. combine the information on the free variables, - 2. take the demand on arguments from the first argument - 3. combine the termination results, but - 4. take CPR info from the first argument. - -3 and 4 are implementd in bothDmdResult. --} - --- Equality needed for fixpoints in DmdAnal -instance Eq DmdType where - (==) (DmdType fv1 ds1 res1) - (DmdType fv2 ds2 res2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 - -- It's OK to use nonDetUFMToList here because we're testing for - -- equality and even though the lists will be in some arbitrary - -- Unique order, it is the same order for both - && ds1 == ds2 && res1 == res2 - -lubDmdType :: DmdType -> DmdType -> DmdType -lubDmdType d1 d2 - = DmdType lub_fv lub_ds lub_res - where - n = max (dmdTypeDepth d1) (dmdTypeDepth d2) - (DmdType fv1 ds1 r1) = ensureArgs n d1 - (DmdType fv2 ds2 r2) = ensureArgs n d2 - - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) - lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 - lub_res = lubDmdResult r1 r2 - -{- -Note [The need for BothDmdArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously, the right argument to bothDmdType, as well as the return value of -dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs -to know about the free variables and termination information, but nothing about -the demand put on arguments, nor cpr information. So we make that explicit by -only passing the relevant information. --} - -type BothDmdArg = (DmdEnv, Termination ()) - -mkBothDmdArg :: DmdEnv -> BothDmdArg -mkBothDmdArg env = (env, Dunno ()) - -toBothDmdArg :: DmdType -> BothDmdArg -toBothDmdArg (DmdType fv _ r) = (fv, go r) - where - go (Dunno {}) = Dunno () - go ThrowsExn = ThrowsExn - go Diverges = Diverges - -bothDmdType :: DmdType -> BothDmdArg -> DmdType -bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) - -- See Note [Asymmetry of 'both' for DmdType and DmdResult] - -- 'both' takes the argument/result info from its *first* arg, - -- using its second arg just for its free-var info. - = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)) - ds1 - (r1 `bothDmdResult` t2) - -instance Outputable DmdType where - ppr (DmdType fv ds res) - = hsep [hcat (map ppr ds) <> ppr res, - if null fv_elts then empty - else braces (fsep (map pp_elt fv_elts))] - where - pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd - fv_elts = nonDetUFMToList fv - -- It's OK to use nonDetUFMToList here because we only do it for - -- pretty printing - -emptyDmdEnv :: VarEnv Demand -emptyDmdEnv = emptyVarEnv - --- nopDmdType is the demand of doing nothing --- (lazy, absent, no CPR information, no termination information). --- Note that it is ''not'' the top of the lattice (which would be "may use everything"), --- so it is (no longer) called topDmd -nopDmdType, botDmdType, exnDmdType :: DmdType -nopDmdType = DmdType emptyDmdEnv [] topRes -botDmdType = DmdType emptyDmdEnv [] botRes -exnDmdType = DmdType emptyDmdEnv [] exnRes - -cprProdDmdType :: Arity -> DmdType -cprProdDmdType arity - = DmdType emptyDmdEnv [] (vanillaCprProdRes arity) - -isTopDmdType :: DmdType -> Bool -isTopDmdType (DmdType env [] res) - | isTopRes res && isEmptyVarEnv env = True -isTopDmdType _ = False - -mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType -mkDmdType fv ds res = DmdType fv ds res - -dmdTypeDepth :: DmdType -> Arity -dmdTypeDepth (DmdType _ ds _) = length ds - --- Remove any demand on arguments. This is used in dmdAnalRhs on the body -removeDmdTyArgs :: DmdType -> DmdType -removeDmdTyArgs = ensureArgs 0 - --- This makes sure we can use the demand type with n arguments, --- It extends the argument list with the correct resTypeArgDmd --- It also adjusts the DmdResult: Divergence survives additional arguments, --- CPR information does not (and definite converge also would not). -ensureArgs :: Arity -> DmdType -> DmdType -ensureArgs n d | n == depth = d - | otherwise = DmdType fv ds' r' - where depth = dmdTypeDepth d - DmdType fv ds r = d - - ds' = take n (ds ++ repeat (resTypeArgDmd r)) - r' = case r of -- See [Nature of result demand] - Dunno _ -> topRes - _ -> r - - -seqDmdType :: DmdType -> () -seqDmdType (DmdType env ds res) = - seqDmdEnv env `seq` seqDemandList ds `seq` seqDmdResult res `seq` () - -seqDmdEnv :: DmdEnv -> () -seqDmdEnv env = seqEltsUFM seqDemandList env - -splitDmdTy :: DmdType -> (Demand, DmdType) --- Split off one function argument --- We already have a suitable demand on all --- free vars, so no need to add more! -splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) -splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) - --- When e is evaluated after executing an IO action, and d is e's demand, then --- what of this demand should we consider, given that the IO action can cleanly --- exit? --- * We have to kill all strictness demands (i.e. lub with a lazy demand) --- * We can keep usage information (i.e. lub with an absent demand) --- * We have to kill definite divergence --- * We can keep CPR information. --- See Note [IO hack in the demand analyser] in DmdAnal -deferAfterIO :: DmdType -> DmdType -deferAfterIO d@(DmdType _ _ res) = - case d `lubDmdType` nopDmdType of - DmdType fv ds _ -> DmdType fv ds (defer_res res) - where - defer_res r@(Dunno {}) = r - defer_res _ = topRes -- Diverges and ThrowsExn - -strictenDmd :: Demand -> CleanDemand -strictenDmd (JD { sd = s, ud = u}) - = JD { sd = poke_s s, ud = poke_u u } - where - poke_s Lazy = HeadStr - poke_s (Str _ s) = s - poke_u Abs = UHead - poke_u (Use _ u) = u - --- Deferring and peeling - -type DmdShell -- Describes the "outer shell" - -- of a Demand - = JointDmd (Str ()) (Use ()) - -toCleanDmd :: Demand -> Type -> (DmdShell, CleanDemand) --- Splits a Demand into its "shell" and the inner "clean demand" -toCleanDmd (JD { sd = s, ud = u }) expr_ty - = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' }) - -- See Note [Analyzing with lazy demand and lambdas] - where - (ss, s') = case s of - Str x s' -> (Str x (), s') - Lazy | is_unlifted -> (Str VanStr (), HeadStr) - | otherwise -> (Lazy, HeadStr) - - (us, u') = case u of - Use c u' -> (Use c (), u') - Abs | is_unlifted -> (Use One (), Used) - | otherwise -> (Abs, Used) - - is_unlifted = isUnliftedType expr_ty - -- See Note [Analysing with absent demand] - - --- This is used in dmdAnalStar when post-processing --- a function's argument demand. So we only care about what --- does to free variables, and whether it terminates. --- see Note [The need for BothDmdArg] -postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg -postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) - = (postProcessDmdEnv du fv, term_info) - where - term_info = case postProcessDmdResult ss res_ty of - Dunno _ -> Dunno () - ThrowsExn -> ThrowsExn - Diverges -> Diverges - -postProcessDmdResult :: Str () -> DmdResult -> DmdResult -postProcessDmdResult Lazy _ = topRes -postProcessDmdResult (Str ExnStr _) ThrowsExn = topRes -- Key point! --- Note that only ThrowsExn results can be caught, not Diverges -postProcessDmdResult _ res = res - -postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv -postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env - | Abs <- us = emptyDmdEnv - -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild - -- of the environment. Be careful, bad things will happen if this doesn't - -- match postProcessDmd (see #13977). - | Str VanStr _ <- ss - , Use One _ <- us = env - | otherwise = mapVarEnv (postProcessDmd ds) env - -- For the Absent case just discard all usage information - -- We only processed the thing at all to analyse the body - -- See Note [Always analyse in virgin pass] - -reuseEnv :: DmdEnv -> DmdEnv -reuseEnv = mapVarEnv (postProcessDmd - (JD { sd = Str VanStr (), ud = Use Many () })) - -postProcessUnsat :: DmdShell -> DmdType -> DmdType -postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty) - = DmdType (postProcessDmdEnv ds fv) - (map (postProcessDmd ds) args) - (postProcessDmdResult ss res_ty) - -postProcessDmd :: DmdShell -> Demand -> Demand -postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a}) - = JD { sd = s', ud = a' } - where - s' = case ss of - Lazy -> Lazy - Str ExnStr _ -> markExnStr s - Str VanStr _ -> s - a' = case us of - Abs -> Abs - Use Many _ -> markReusedDmd a - Use One _ -> a - -markExnStr :: ArgStr -> ArgStr -markExnStr (Str VanStr s) = Str ExnStr s -markExnStr s = s - --- Peels one call level from the demand, and also returns --- whether it was unsaturated (separately for strictness and usage) -peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell) --- Exploiting the fact that --- on the strictness side C(B) = B --- and on the usage side C(U) = U -peelCallDmd (JD {sd = s, ud = u}) - = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us }) - where - (s', ss) = case s of - SCall s' -> (s', Str VanStr ()) - HyperStr -> (HyperStr, Str VanStr ()) - _ -> (HeadStr, Lazy) - (u', us) = case u of - UCall c u' -> (u', Use c ()) - _ -> (Used, Use Many ()) - -- The _ cases for usage includes UHead which seems a bit wrong - -- because the body isn't used at all! - -- c.f. the Abs case in toCleanDmd - --- Peels that multiple nestings of calls clean demand and also returns --- whether it was unsaturated (separately for strictness and usage --- see Note [Demands from unsaturated function calls] -peelManyCalls :: Int -> CleanDemand -> DmdShell -peelManyCalls n (JD { sd = str, ud = abs }) - = JD { sd = go_str n str, ud = go_abs n abs } - where - go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer - go_str 0 _ = Str VanStr () - go_str _ HyperStr = Str VanStr () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr) - go_str n (SCall d') = go_str (n-1) d' - go_str _ _ = Lazy - - go_abs :: Int -> UseDmd -> Use () -- Many <=> unsaturated, or at least - go_abs 0 _ = Use One () -- one UCall Many in the demand - go_abs n (UCall One d') = go_abs (n-1) d' - go_abs _ _ = Use Many () - -{- -Note [Demands from unsaturated function calls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider a demand transformer d1 -> d2 -> r for f. -If a sufficiently detailed demand is fed into this transformer, -e.g arising from "f x1 x2" in a strict, use-once context, -then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for -the free variable environment) and furthermore the result information r is the -one we want to use. - -An anonymous lambda is also an unsaturated function all (needs one argument, -none given), so this applies to that case as well. - -But the demand fed into f might be less than . There are a few cases: - * Not enough demand on the strictness side: - - In that case, we need to zap all strictness in the demand on arguments and - free variables. - - Furthermore, we remove CPR information. It could be left, but given the incoming - demand is not enough to evaluate so far we just do not bother. - - And finally termination information: If r says that f diverges for sure, - then this holds when the demand guarantees that two arguments are going to - be passed. If the demand is lower, we may just as well converge. - If we were tracking definite convegence, than that would still hold under - a weaker demand than expected by the demand transformer. - * Not enough demand from the usage side: The missing usage can be expanded - using UCall Many, therefore this is subsumed by the third case: - * At least one of the uses has a cardinality of Many. - - Even if f puts a One demand on any of its argument or free variables, if - we call f multiple times, we may evaluate this argument or free variable - multiple times. So forget about any occurrence of "One" in the demand. - -In dmdTransformSig, we call peelManyCalls to find out if we are in any of these -cases, and then call postProcessUnsat to reduce the demand appropriately. - -Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use -peelCallDmd, which peels only one level, but also returns the demand put on the -body of the function. --} - -peelFV :: DmdType -> Var -> (DmdType, Demand) -peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) - (DmdType fv' ds res, dmd) - where - fv' = fv `delVarEnv` id - -- See Note [Default demand on free variables] - dmd = lookupVarEnv fv id `orElse` defaultDmd res - -addDemand :: Demand -> DmdType -> DmdType -addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res - -findIdDemand :: DmdType -> Var -> Demand -findIdDemand (DmdType fv _ res) id - = lookupVarEnv fv id `orElse` defaultDmd res - -{- -Note [Default demand on free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the variable is not mentioned in the environment of a demand type, -its demand is taken to be a result demand of the type. - For the stricness component, - if the result demand is a Diverges, then we use HyperStr - else we use Lazy - For the usage component, we use Absent. -So we use either absDmd or botDmd. - -Also note the equations for lubDmdResult (resp. bothDmdResult) noted there. - -Note [Always analyse in virgin pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tricky point: make sure that we analyse in the 'virgin' pass. Consider - rec { f acc x True = f (...rec { g y = ...g... }...) - f acc x False = acc } -In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. -That might mean that we analyse the sub-expression containing the -E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* -E, but just returned botType. - -Then in the *next* (non-virgin) iteration for 'f', we might analyse E -in a weaker demand, and that will trigger doing a fixpoint iteration -for g. But *because it's not the virgin pass* we won't start g's -iteration at bottom. Disaster. (This happened in $sfibToList' of -nofib/spectral/fibheaps.) - -So in the virgin pass we make sure that we do analyse the expression -at least once, to initialise its signatures. - -Note [Analyzing with lazy demand and lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The insight for analyzing lambdas follows from the fact that for -strictness S = C(L). This polymorphic expansion is critical for -cardinality analysis of the following example: - -{-# NOINLINE build #-} -build g = (g (:) [], g (:) []) - -h c z = build (\x -> - let z1 = z ++ z - in if c - then \y -> x (y ++ z1) - else \y -> x (z1 ++ y)) - -One can see that `build` assigns to `g` demand . -Therefore, when analyzing the lambda `(\x -> ...)`, we -expect each lambda \y -> ... to be annotated as "one-shot" -one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a -demand . - -This is achieved by, first, converting the lazy demand L into the -strict S by the second clause of the analysis. - -Note [Analysing with absent demand] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we analyse an expression with demand . The "A" means -"absent", so this expression will never be needed. What should happen? -There are several wrinkles: - -* We *do* want to analyse the expression regardless. - Reason: Note [Always analyse in virgin pass] - - But we can post-process the results to ignore all the usage - demands coming back. This is done by postProcessDmdType. - -* But in the case of an *unlifted type* we must be extra careful, - because unlifted values are evaluated even if they are not used. - Example (see Trac #9254): - f :: (() -> (# Int#, () #)) -> () - -- Strictness signature is - -- - -- I.e. calls k, but discards first component of result - f k = case k () of (# _, r #) -> r - - g :: Int -> () - g y = f (\n -> (# case y of I# y2 -> y2, n #)) - - Here f's strictness signature says (correctly) that it calls its - argument function and ignores the first component of its result. - This is correct in the sense that it'd be fine to (say) modify the - function so that always returned 0# in the first component. - - But in function g, we *will* evaluate the 'case y of ...', because - it has type Int#. So 'y' will be evaluated. So we must record this - usage of 'y', else 'g' will say 'y' is absent, and will w/w so that - 'y' is bound to an aBSENT_ERROR thunk. - - An alternative would be to replace the 'case y of ...' with (say) 0#, - but I have not tried that. It's not a common situation, but it is - not theoretical: unsafePerformIO's implementation is very very like - 'f' above. - - -************************************************************************ -* * - Demand signatures -* * -************************************************************************ - -In a let-bound Id we record its strictness info. -In principle, this strictness info is a demand transformer, mapping -a demand on the Id into a DmdType, which gives - a) the free vars of the Id's value - b) the Id's arguments - c) an indication of the result of applying - the Id to its arguments - -However, in fact we store in the Id an extremely emascuated demand -transfomer, namely - - a single DmdType -(Nevertheless we dignify StrictSig as a distinct type.) - -This DmdType gives the demands unleashed by the Id when it is applied -to as many arguments as are given in by the arg demands in the DmdType. -Also see Note [Nature of result demand] for the meaning of a DmdResult in a -strictness signature. - -If an Id is applied to less arguments than its arity, it means that -the demand on the function at a call site is weaker than the vanilla -call demand, used for signature inference. Therefore we place a top -demand on all arguments. Otherwise, the demand is specified by Id's -signature. - -For example, the demand transformer described by the demand signature - StrictSig (DmdType {x -> } m) -says that when the function is applied to two arguments, it -unleashes demand on the free var x, on the first arg, -and on the second, then returning a constructor. - -If this same function is applied to one arg, all we can say is that it -uses x with , and its arg with demand . --} - -newtype StrictSig = StrictSig DmdType - deriving( Eq ) - -instance Outputable StrictSig where - ppr (StrictSig ty) = ppr ty - --- Used for printing top-level strictness pragmas in interface files -pprIfaceStrictSig :: StrictSig -> SDoc -pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) - = hcat (map ppr dmds) <> ppr res - -mkStrictSig :: DmdType -> StrictSig -mkStrictSig dmd_ty = StrictSig dmd_ty - -mkClosedStrictSig :: [Demand] -> DmdResult -> StrictSig -mkClosedStrictSig ds res = mkStrictSig (DmdType emptyDmdEnv ds res) - -splitStrictSig :: StrictSig -> ([Demand], DmdResult) -splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) - -increaseStrictSigArity :: Int -> StrictSig -> StrictSig --- Add extra arguments to a strictness signature -increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res)) - = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res) - -isTopSig :: StrictSig -> Bool -isTopSig (StrictSig ty) = isTopDmdType ty - -hasDemandEnvSig :: StrictSig -> Bool -hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) - -strictSigDmdEnv :: StrictSig -> DmdEnv -strictSigDmdEnv (StrictSig (DmdType env _ _)) = env - -isBottomingSig :: StrictSig -> Bool --- True if the signature diverges or throws an exception -isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res - -nopSig, botSig, exnSig :: StrictSig -nopSig = StrictSig nopDmdType -botSig = StrictSig botDmdType -exnSig = StrictSig exnDmdType - -cprProdSig :: Arity -> StrictSig -cprProdSig arity = StrictSig (cprProdDmdType arity) - -seqStrictSig :: StrictSig -> () -seqStrictSig (StrictSig ty) = seqDmdType ty - -dmdTransformSig :: StrictSig -> CleanDemand -> DmdType --- (dmdTransformSig fun_sig dmd) considers a call to a function whose --- signature is fun_sig, with demand dmd. We return the demand --- that the function places on its context (eg its args) -dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd - = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty - -- see Note [Demands from unsaturated function calls] - -dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType --- Same as dmdTransformSig but for a data constructor (worker), --- which has a special kind of demand transformer. --- If the constructor is saturated, we feed the demand on --- the result into the constructor arguments. -dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) - (JD { sd = str, ud = abs }) - | Just str_dmds <- go_str arity str - , Just abs_dmds <- go_abs arity abs - = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res - -- Must remember whether it's a product, hence con_res, not TopRes - - | otherwise -- Not saturated - = nopDmdType - where - go_str 0 dmd = splitStrProdDmd arity dmd - go_str n (SCall s') = go_str (n-1) s' - go_str n HyperStr = go_str (n-1) HyperStr - go_str _ _ = Nothing - - go_abs 0 dmd = splitUseProdDmd arity dmd - go_abs n (UCall One u') = go_abs (n-1) u' - go_abs _ _ = Nothing - -dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType --- Like dmdTransformDataConSig, we have a special demand transformer --- for dictionary selectors. If the selector is saturated (ie has one --- argument: the dictionary), we feed the demand on the result into --- the indicated dictionary component. -dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd - | (cd',defer_use) <- peelCallDmd cd - , Just jds <- splitProdDmd_maybe dict_dmd - = postProcessUnsat defer_use $ - DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes - | otherwise - = nopDmdType -- See Note [Demand transformer for a dictionary selector] - where - enhance cd old | isAbsDmd old = old - | otherwise = mkOnceUsedDmd cd -- This is the one! - -dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" - -{- -Note [Demand transformer for a dictionary selector] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' -into the appropriate field of the dictionary. What *is* the appropriate field? -We just look at the strictness signature of the class op, which will be -something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'. - -For single-method classes, which are represented by newtypes the signature -of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. -That's fine: if we are doing strictness analysis we are also doing inlining, -so we'll have inlined 'op' into a cast. So we can bale out in a conservative -way, returning nopDmdType. - -It is (just.. Trac #8329) possible to be running strictness analysis *without* -having inlined class ops from single-method classes. Suppose you are using -ghc --make; and the first module has a local -O0 flag. So you may load a class -without interface pragmas, ie (currently) without an unfolding for the class -ops. Now if a subsequent module in the --make sweep has a local -O flag -you might do strictness analysis, but there is no inlining for the class op. -This is weird, so I'm not worried about whether this optimises brilliantly; but -it should not fall over. --} - -argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] --- See Note [Computing one-shot info] -argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args - | unsaturated_call = [] - | otherwise = go arg_ds - where - unsaturated_call = arg_ds `lengthExceeds` n_val_args - - go [] = [] - go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds - - -- Avoid list tail like [ [], [], [] ] - cons [] [] = [] - cons a as = a:as - --- saturatedByOneShots n C1(C1(...)) = True, --- <=> --- there are at least n nested C1(..) calls --- See Note [Demand on the worker] in WorkWrap -saturatedByOneShots :: Int -> Demand -> Bool -saturatedByOneShots n (JD { ud = usg }) - = case usg of - Use _ arg_usg -> go n arg_usg - _ -> False - where - go 0 _ = True - go n (UCall One u) = go (n-1) u - go _ _ = False - -argOneShots :: Demand -- depending on saturation - -> [OneShotInfo] -argOneShots (JD { ud = usg }) - = case usg of - Use _ arg_usg -> go arg_usg - _ -> [] - where - go (UCall One u) = OneShotLam : go u - go (UCall Many u) = NoOneShotInfo : go u - go _ = [] - -{- Note [Computing one-shot info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a call - f (\pqr. e1) (\xyz. e2) e3 -where f has usage signature - C1(C(C1(U))) C1(U) U -Then argsOneShots returns a [[OneShotInfo]] of - [[OneShot,NoOneShotInfo,OneShot], [OneShot]] -The occurrence analyser propagates this one-shot infor to the -binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. --} - --- appIsBottom returns true if an application to n args --- would diverge or throw an exception --- See Note [Unsaturated applications] -appIsBottom :: StrictSig -> Int -> Bool -appIsBottom (StrictSig (DmdType _ ds res)) n - | isBotRes res = not $ lengthExceeds ds n -appIsBottom _ _ = False - -{- -Note [Unsaturated applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a function having bottom as its demand result is applied to a less -number of arguments than its syntactic arity, we cannot say for sure -that it is going to diverge. This is the reason why we use the -function appIsBottom, which, given a strictness signature and a number -of arguments, says conservatively if the function is going to diverge -or not. - -Zap absence or one-shot information, under control of flags - -Note [Killing usage information] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The flags -fkill-one-shot and -fkill-absence let you switch off the generation -of absence or one-shot information altogether. This is only used for performance -tests, to see how important they are. --} - -zapUsageEnvSig :: StrictSig -> StrictSig --- Remove the usage environment from the demand -zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r - -zapUsageDemand :: Demand -> Demand --- Remove the usage info, but not the strictness info, from the demand -zapUsageDemand = kill_usage $ KillFlags - { kf_abs = True - , kf_used_once = True - , kf_called_once = True - } - --- | Remove all 1* information (but not C1 information) from the demand -zapUsedOnceDemand :: Demand -> Demand -zapUsedOnceDemand = kill_usage $ KillFlags - { kf_abs = False - , kf_used_once = True - , kf_called_once = False - } - --- | Remove all 1* information (but not C1 information) from the strictness --- signature -zapUsedOnceSig :: StrictSig -> StrictSig -zapUsedOnceSig (StrictSig (DmdType env ds r)) - = StrictSig (DmdType env (map zapUsedOnceDemand ds) r) - -killUsageDemand :: DynFlags -> Demand -> Demand --- See Note [Killing usage information] -killUsageDemand dflags dmd - | Just kfs <- killFlags dflags = kill_usage kfs dmd - | otherwise = dmd - -killUsageSig :: DynFlags -> StrictSig -> StrictSig --- See Note [Killing usage information] -killUsageSig dflags sig@(StrictSig (DmdType env ds r)) - | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r) - | otherwise = sig - -data KillFlags = KillFlags - { kf_abs :: Bool - , kf_used_once :: Bool - , kf_called_once :: Bool - } - -killFlags :: DynFlags -> Maybe KillFlags --- See Note [Killing usage information] -killFlags dflags - | not kf_abs && not kf_used_once = Nothing - | otherwise = Just (KillFlags {..}) - where - kf_abs = gopt Opt_KillAbsence dflags - kf_used_once = gopt Opt_KillOneShot dflags - kf_called_once = kf_used_once - -kill_usage :: KillFlags -> Demand -> Demand -kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u} - -zap_musg :: KillFlags -> ArgUse -> ArgUse -zap_musg kfs Abs - | kf_abs kfs = useTop - | otherwise = Abs -zap_musg kfs (Use c u) - | kf_used_once kfs = Use Many (zap_usg kfs u) - | otherwise = Use c (zap_usg kfs u) - -zap_usg :: KillFlags -> UseDmd -> UseDmd -zap_usg kfs (UCall c u) - | kf_called_once kfs = UCall Many (zap_usg kfs u) - | otherwise = UCall c (zap_usg kfs u) -zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) -zap_usg _ u = u - --- If the argument is a used non-newtype dictionary, give it strict --- demand. Also split the product type & demand and recur in order to --- similarly strictify the argument's contained used non-newtype --- superclass dictionaries. We use the demand as our recursive measure --- to guarantee termination. -strictifyDictDmd :: Type -> Demand -> Demand -strictifyDictDmd ty dmd = case getUseDmd dmd of - Use n _ | - Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) - <- splitDataProductType_maybe ty, - not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary - -> seqDmd `bothDmd` -- main idea: ensure it's strict - case splitProdDmd_maybe dmd of - -- superclass cycles should not be a problem, since the demand we are - -- consuming would also have to be infinite in order for us to diverge - Nothing -> dmd -- no components have interesting demand, so stop - -- looking for superclass dicts - Just dmds - | all (not . isAbsDmd) dmds -> evalDmd - -- abstract to strict w/ arbitrary component use, since this - -- smells like reboxing; results in CBV boxed - -- - -- TODO revisit this if we ever do boxity analysis - | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of - JD {sd = s,ud = a} -> JD (Str VanStr s) (Use n a) - -- TODO could optimize with an aborting variant of zipWith since - -- the superclass dicts are always a prefix - _ -> dmd -- unused or not a dictionary - -{- -Note [HyperStr and Use demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The information "HyperStr" needs to be in the strictness signature, and not in -the demand signature, because we still want to know about the demand on things. Consider - - f (x,y) True = error (show x) - f (x,y) False = x+1 - -The signature of f should be m. If we were not -distinguishing the uses on x and y in the True case, we could either not figure -out how deeply we can unpack x, or that we do not have to pass y. - - -************************************************************************ -* * - Serialisation -* * -************************************************************************ --} - -instance Binary StrDmd where - put_ bh HyperStr = do putByte bh 0 - put_ bh HeadStr = do putByte bh 1 - put_ bh (SCall s) = do putByte bh 2 - put_ bh s - put_ bh (SProd sx) = do putByte bh 3 - put_ bh sx - get bh = do - h <- getByte bh - case h of - 0 -> do return HyperStr - 1 -> do return HeadStr - 2 -> do s <- get bh - return (SCall s) - _ -> do sx <- get bh - return (SProd sx) - -instance Binary ExnStr where - put_ bh VanStr = putByte bh 0 - put_ bh ExnStr = putByte bh 1 - - get bh = do h <- getByte bh - return (case h of - 0 -> VanStr - _ -> ExnStr) - -instance Binary ArgStr where - put_ bh Lazy = do - putByte bh 0 - put_ bh (Str x s) = do - putByte bh 1 - put_ bh x - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> return Lazy - _ -> do x <- get bh - s <- get bh - return $ Str x s - -instance Binary Count where - put_ bh One = do putByte bh 0 - put_ bh Many = do putByte bh 1 - - get bh = do h <- getByte bh - case h of - 0 -> return One - _ -> return Many - -instance Binary ArgUse where - put_ bh Abs = do - putByte bh 0 - put_ bh (Use c u) = do - putByte bh 1 - put_ bh c - put_ bh u - - get bh = do - h <- getByte bh - case h of - 0 -> return Abs - _ -> do c <- get bh - u <- get bh - return $ Use c u - -instance Binary UseDmd where - put_ bh Used = do - putByte bh 0 - put_ bh UHead = do - putByte bh 1 - put_ bh (UCall c u) = do - putByte bh 2 - put_ bh c - put_ bh u - put_ bh (UProd ux) = do - putByte bh 3 - put_ bh ux - - get bh = do - h <- getByte bh - case h of - 0 -> return $ Used - 1 -> return $ UHead - 2 -> do c <- get bh - u <- get bh - return (UCall c u) - _ -> do ux <- get bh - return (UProd ux) - -instance (Binary s, Binary u) => Binary (JointDmd s u) where - put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y - get bh = do - x <- get bh - y <- get bh - return $ JD { sd = x, ud = y } - -instance Binary StrictSig where - put_ bh (StrictSig aa) = do - put_ bh aa - get bh = do - aa <- get bh - return (StrictSig aa) - -instance Binary DmdType where - -- Ignore DmdEnv when spitting out the DmdType - put_ bh (DmdType _ ds dr) - = do put_ bh ds - put_ bh dr - get bh - = do ds <- get bh - dr <- get bh - return (DmdType emptyDmdEnv ds dr) - -instance Binary DmdResult where - put_ bh (Dunno c) = do { putByte bh 0; put_ bh c } - put_ bh ThrowsExn = putByte bh 1 - put_ bh Diverges = putByte bh 2 - - get bh = do { h <- getByte bh - ; case h of - 0 -> do { c <- get bh; return (Dunno c) } - 1 -> return ThrowsExn - _ -> return Diverges } - -instance Binary CPRResult where - put_ bh (RetSum n) = do { putByte bh 0; put_ bh n } - put_ bh RetProd = putByte bh 1 - put_ bh NoCPR = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> do { n <- get bh; return (RetSum n) } - 1 -> return RetProd - _ -> return NoCPR diff --git a/basicTypes/FieldLabel.hs b/basicTypes/FieldLabel.hs deleted file mode 100644 --- a/basicTypes/FieldLabel.hs +++ /dev/null @@ -1,128 +0,0 @@ -{- -% -% (c) Adam Gundry 2013-2015 -% - -This module defines the representation of FieldLabels as stored in -TyCons. As well as a selector name, these have some extra structure -to support the DuplicateRecordFields extension. - -In the normal case (with NoDuplicateRecordFields), a datatype like - - data T = MkT { foo :: Int } - -has - - FieldLabel { flLabel = "foo" - , flIsOverloaded = False - , flSelector = foo }. - -In particular, the Name of the selector has the same string -representation as the label. If DuplicateRecordFields -is enabled, however, the same declaration instead gives - - FieldLabel { flLabel = "foo" - , flIsOverloaded = True - , flSelector = $sel:foo:MkT }. - -Now the name of the selector ($sel:foo:MkT) does not match the label of -the field (foo). We must be careful not to show the selector name to -the user! The point of mangling the selector name is to allow a -module to define the same field label in different datatypes: - - data T = MkT { foo :: Int } - data U = MkU { foo :: Bool } - -Now there will be two FieldLabel values for 'foo', one in T and one in -U. They share the same label (FieldLabelString), but the selector -functions differ. - -See also Note [Representing fields in AvailInfo] in Avail. - -Note [Why selector names include data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -As explained above, a selector name includes the name of the first -data constructor in the type, so that the same label can appear -multiple times in the same module. (This is irrespective of whether -the first constructor has that field, for simplicity.) - -We use a data constructor name, rather than the type constructor name, -because data family instances do not have a representation type -constructor name generated until relatively late in the typechecking -process. - -Of course, datatypes with no constructors cannot have any fields. - --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE StandaloneDeriving #-} - -module FieldLabel ( FieldLabelString - , FieldLabelEnv - , FieldLbl(..) - , FieldLabel - , mkFieldLabelOccs - ) where - -import OccName -import Name - -import FastString -import FastStringEnv -import Outputable -import Binary - -import Data.Data - --- | Field labels are just represented as strings; --- they are not necessarily unique (even within a module) -type FieldLabelString = FastString - --- | A map from labels to all the auxiliary information -type FieldLabelEnv = DFastStringEnv FieldLabel - - -type FieldLabel = FieldLbl Name - --- | Fields in an algebraic record type -data FieldLbl a = FieldLabel { - flLabel :: FieldLabelString, -- ^ User-visible label of the field - flIsOverloaded :: Bool, -- ^ Was DuplicateRecordFields on - -- in the defining module for this datatype? - flSelector :: a -- ^ Record selector function - } - deriving (Eq, Functor, Foldable, Traversable) -deriving instance Data a => Data (FieldLbl a) - -instance Outputable a => Outputable (FieldLbl a) where - ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl)) - -instance Binary a => Binary (FieldLbl a) where - put_ bh (FieldLabel aa ab ac) = do - put_ bh aa - put_ bh ab - put_ bh ac - get bh = do - ab <- get bh - ac <- get bh - ad <- get bh - return (FieldLabel ab ac ad) - - --- | Record selector OccNames are built from the underlying field name --- and the name of the first data constructor of the type, to support --- duplicate record field names. --- See Note [Why selector names include data constructors]. -mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName -mkFieldLabelOccs lbl dc is_overloaded - = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded - , flSelector = sel_occ } - where - str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc - sel_occ | is_overloaded = mkRecFldSelOcc str - | otherwise = mkVarOccFS lbl diff --git a/basicTypes/Id.hs b/basicTypes/Id.hs deleted file mode 100644 --- a/basicTypes/Id.hs +++ /dev/null @@ -1,946 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Id]{@Ids@: Value and constructor identifiers} --} - -{-# LANGUAGE ImplicitParams, CPP #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TyCoRep.Type' and some additional --- details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that --- are added, modified and inspected by various compiler passes. These 'Var.Var' names may either --- be global or local, see "Var#globalvslocal" --- --- * 'Var.Var': see "Var#name_types" - -module Id ( - -- * The main types - Var, Id, isId, - - -- * In and Out variants - InVar, InId, - OutVar, OutId, - - -- ** Simple construction - mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, - mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, - mkLocalIdOrCoVarWithInfo, - mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId, - mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, - mkUserLocal, mkUserLocalOrCoVar, - mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, - mkWorkerId, - - -- ** Taking an Id apart - idName, idType, idUnique, idInfo, idDetails, - recordSelectorTyCon, - - -- ** Modifying an Id - setIdName, setIdUnique, Id.setIdType, - setIdExported, setIdNotExported, - globaliseId, localiseId, - setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, - zapIdUsedOnceInfo, zapIdTailCallInfo, - zapFragileIdInfo, zapIdStrictness, - transferPolyIdInfo, - - -- ** Predicates on Ids - isImplicitId, isDeadBinder, - isStrictId, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, isNaughtyRecordSelector, - isPatSynRecordSelector, - isDataConRecordSelector, - isClassOpId_maybe, isDFunId, - isPrimOpId, isPrimOpId_maybe, - isFCallId, isFCallId_maybe, - isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, - isConLikeId, isBottomingId, idIsFrom, - hasNoBinding, - - -- ** Evidence variables - DictId, isDictId, isEvVar, - - -- ** Join variables - JoinId, isJoinId, isJoinId_maybe, idJoinArity, - asJoinId, asJoinId_maybe, zapJoinId, - - -- ** Inline pragma stuff - idInlinePragma, setInlinePragma, modifyInlinePragma, - idInlineActivation, setInlineActivation, idRuleMatchInfo, - - -- ** One-shot lambdas - isOneShotBndr, isProbablyOneShotLambda, - setOneShotLambda, clearOneShotLambda, - updOneShotInfo, setIdOneShotInfo, - isStateHackType, stateHackOneShot, typeOneShot, - - -- ** Reading 'IdInfo' fields - idArity, - idCallArity, idFunRepArity, - idUnfolding, realIdUnfolding, - idSpecialisation, idCoreRules, idHasRules, - idCafInfo, - idOneShotInfo, idStateHackOneShotInfo, - idOccInfo, - isNeverLevPolyId, - - -- ** Writing 'IdInfo' fields - setIdUnfolding, setCaseBndrEvald, - setIdArity, - setIdCallArity, - - setIdSpecialisation, - setIdCafInfo, - setIdOccInfo, zapIdOccInfo, - - setIdDemandInfo, - setIdStrictness, - - idDemandInfo, - idStrictness, - - ) where - -#include "HsVersions.h" - -import DynFlags -import CoreSyn ( CoreRule, evaldUnfolding, Unfolding( NoUnfolding ) ) - -import IdInfo -import BasicTypes - --- Imported and re-exported -import Var( Id, CoVar, DictId, JoinId, - InId, InVar, - OutId, OutVar, - idInfo, idDetails, setIdDetails, globaliseId, varType, - isId, isLocalId, isGlobalId, isExportedId ) -import qualified Var - -import Type -import RepType -import TysPrim -import DataCon -import Demand -import Name -import Module -import Class -import {-# SOURCE #-} PrimOp (PrimOp) -import ForeignCall -import Maybes -import SrcLoc -import Outputable -import Unique -import UniqSupply -import FastString -import Util - --- infixl so you can say (id `set` a `set` b) -infixl 1 `setIdUnfolding`, - `setIdArity`, - `setIdCallArity`, - `setIdOccInfo`, - `setIdOneShotInfo`, - - `setIdSpecialisation`, - `setInlinePragma`, - `setInlineActivation`, - `idCafInfo`, - - `setIdDemandInfo`, - `setIdStrictness`, - - `asJoinId`, - `asJoinId_maybe` - -{- -************************************************************************ -* * -\subsection{Basic Id manipulation} -* * -************************************************************************ --} - -idName :: Id -> Name -idName = Var.varName - -idUnique :: Id -> Unique -idUnique = Var.varUnique - -idType :: Id -> Kind -idType = Var.varType - -setIdName :: Id -> Name -> Id -setIdName = Var.setVarName - -setIdUnique :: Id -> Unique -> Id -setIdUnique = Var.setVarUnique - --- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and --- reduce space usage -setIdType :: Id -> Type -> Id -setIdType id ty = seqType ty `seq` Var.setVarType id ty - -setIdExported :: Id -> Id -setIdExported = Var.setIdExported - -setIdNotExported :: Id -> Id -setIdNotExported = Var.setIdNotExported - -localiseId :: Id -> Id --- Make an with the same unique and type as the --- incoming Id, but with an *Internal* Name and *LocalId* flavour -localiseId id - | ASSERT( isId id ) isLocalId id && isInternalName name - = id - | otherwise - = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id) - where - name = idName id - -lazySetIdInfo :: Id -> IdInfo -> Id -lazySetIdInfo = Var.lazySetIdInfo - -setIdInfo :: Id -> IdInfo -> Id -setIdInfo id info = info `seq` (lazySetIdInfo id info) - -- Try to avoid spack leaks by seq'ing - -modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id -modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) - --- maybeModifyIdInfo tries to avoid unnecessary thrashing -maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id -maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info -maybeModifyIdInfo Nothing id = id - -{- -************************************************************************ -* * -\subsection{Simple Id construction} -* * -************************************************************************ - -Absolutely all Ids are made by mkId. It is just like Var.mkId, -but in addition it pins free-tyvar-info onto the Id's type, -where it can easily be found. - -Note [Free type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -At one time we cached the free type variables of the type of an Id -at the root of the type in a TyNote. The idea was to avoid repeating -the free-type-variable calculation. But it turned out to slow down -the compiler overall. I don't quite know why; perhaps finding free -type variables of an Id isn't all that common whereas applying a -substitution (which changes the free type variables) is more common. -Anyway, we removed it in March 2008. --} - --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalId = Var.mkGlobalVar - --- | Make a global 'Id' without any extra information at all -mkVanillaGlobal :: Name -> Type -> Id -mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo - --- | Make a global 'Id' with no global information but some generic 'IdInfo' -mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id -mkVanillaGlobalWithInfo = mkGlobalId VanillaId - - --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkLocalId :: Name -> Type -> Id -mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo - -- It's tempting to ASSERT( not (isCoercionType ty) ), but don't. Sometimes, - -- the type is a panic. (Search invented_id) - --- | Make a local CoVar -mkLocalCoVar :: Name -> Type -> CoVar -mkLocalCoVar name ty - = ASSERT( isCoercionType ty ) - Var.mkLocalVar CoVarId name ty vanillaIdInfo - --- | Like 'mkLocalId', but checks the type to see if it should make a covar -mkLocalIdOrCoVar :: Name -> Type -> Id -mkLocalIdOrCoVar name ty - | isCoercionType ty = mkLocalCoVar name ty - | otherwise = mkLocalId name ty - --- | Make a local id, with the IdDetails set to CoVarId if the type indicates --- so. -mkLocalIdOrCoVarWithInfo :: Name -> Type -> IdInfo -> Id -mkLocalIdOrCoVarWithInfo name ty info - = Var.mkLocalVar details name ty info - where - details | isCoercionType ty = CoVarId - | otherwise = VanillaId - - -- proper ids only; no covars! -mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id -mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info - -- Note [Free type variables] - --- | Create a local 'Id' that is marked as exported. --- This prevents things attached to it from being removed as dead code. --- See Note [Exported LocalIds] -mkExportedLocalId :: IdDetails -> Name -> Type -> Id -mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo - -- Note [Free type variables] - -mkExportedVanillaId :: Name -> Type -> Id -mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo - -- Note [Free type variables] - - --- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") --- that are created by the compiler out of thin air -mkSysLocal :: FastString -> Unique -> Type -> Id -mkSysLocal fs uniq ty = ASSERT( not (isCoercionType ty) ) - mkLocalId (mkSystemVarName uniq fs) ty - --- | Like 'mkSysLocal', but checks to see if we have a covar type -mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id -mkSysLocalOrCoVar fs uniq ty - = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty - -mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id -mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) - -mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id -mkSysLocalOrCoVarM fs ty - = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty)) - --- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize -mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocal occ uniq ty loc = ASSERT( not (isCoercionType ty) ) - mkLocalId (mkInternalName uniq occ loc) ty - --- | Like 'mkUserLocal', but checks if we have a coercion type -mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocalOrCoVar occ uniq ty loc - = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty - -{- -Make some local @Ids@ for a template @CoreExpr@. These have bogus -@Uniques@, but that's OK because the templates are supposed to be -instantiated before use. --} - --- | Workers get local names. "CoreTidy" will externalise these if necessary -mkWorkerId :: Unique -> Id -> Type -> Id -mkWorkerId uniq unwrkr ty - = mkLocalIdOrCoVar (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty - --- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings -mkTemplateLocal :: Int -> Type -> Id -mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty - --- | Create a template local for a series of types -mkTemplateLocals :: [Type] -> [Id] -mkTemplateLocals = mkTemplateLocalsNum 1 - --- | Create a template local for a series of type, but start from a specified template local -mkTemplateLocalsNum :: Int -> [Type] -> [Id] -mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys - -{- Note [Exported LocalIds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use mkExportedLocalId for things like - - Dictionary functions (DFunId) - - Wrapper and matcher Ids for pattern synonyms - - Default methods for classes - - Pattern-synonym matcher and builder Ids - - etc - -They marked as "exported" in the sense that they should be kept alive -even if apparently unused in other bindings, and not dropped as dead -code by the occurrence analyser. (But "exported" here does not mean -"brought into lexical scope by an import declaration". Indeed these -things are always internal Ids that the user never sees.) - -It's very important that they are *LocalIds*, not GlobalIds, for lots -of reasons: - - * We want to treat them as free variables for the purpose of - dependency analysis (e.g. CoreFVs.exprFreeVars). - - * Look them up in the current substitution when we come across - occurrences of them (in Subst.lookupIdSubst). Lacking this we - can get an out-of-date unfolding, which can in turn make the - simplifier go into an infinite loop (Trac #9857) - - * Ensure that for dfuns that the specialiser does not float dict uses - above their defns, which would prevent good simplifications happening. - - * The strictness analyser treats a occurrence of a GlobalId as - imported and assumes it contains strictness in its IdInfo, which - isn't true if the thing is bound in the same module as the - occurrence. - -In CoreTidy we must make all these LocalIds into GlobalIds, so that in -importing modules (in --make mode) we treat them as properly global. -That is what is happening in, say tidy_insts in TidyPgm. - -************************************************************************ -* * -\subsection{Special Ids} -* * -************************************************************************ --} - --- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. -recordSelectorTyCon :: Id -> RecSelParent -recordSelectorTyCon id - = case Var.idDetails id of - RecSelId { sel_tycon = parent } -> parent - _ -> panic "recordSelectorTyCon" - - -isRecordSelector :: Id -> Bool -isNaughtyRecordSelector :: Id -> Bool -isPatSynRecordSelector :: Id -> Bool -isDataConRecordSelector :: Id -> Bool -isPrimOpId :: Id -> Bool -isFCallId :: Id -> Bool -isDataConWorkId :: Id -> Bool -isDFunId :: Id -> Bool - -isClassOpId_maybe :: Id -> Maybe Class -isPrimOpId_maybe :: Id -> Maybe PrimOp -isFCallId_maybe :: Id -> Maybe ForeignCall -isDataConWorkId_maybe :: Id -> Maybe DataCon - -isRecordSelector id = case Var.idDetails id of - RecSelId {} -> True - _ -> False - -isDataConRecordSelector id = case Var.idDetails id of - RecSelId {sel_tycon = RecSelData _} -> True - _ -> False - -isPatSynRecordSelector id = case Var.idDetails id of - RecSelId {sel_tycon = RecSelPatSyn _} -> True - _ -> False - -isNaughtyRecordSelector id = case Var.idDetails id of - RecSelId { sel_naughty = n } -> n - _ -> False - -isClassOpId_maybe id = case Var.idDetails id of - ClassOpId cls -> Just cls - _other -> Nothing - -isPrimOpId id = case Var.idDetails id of - PrimOpId _ -> True - _ -> False - -isDFunId id = case Var.idDetails id of - DFunId {} -> True - _ -> False - -isPrimOpId_maybe id = case Var.idDetails id of - PrimOpId op -> Just op - _ -> Nothing - -isFCallId id = case Var.idDetails id of - FCallId _ -> True - _ -> False - -isFCallId_maybe id = case Var.idDetails id of - FCallId call -> Just call - _ -> Nothing - -isDataConWorkId id = case Var.idDetails id of - DataConWorkId _ -> True - _ -> False - -isDataConWorkId_maybe id = case Var.idDetails id of - DataConWorkId con -> Just con - _ -> Nothing - -isDataConId_maybe :: Id -> Maybe DataCon -isDataConId_maybe id = case Var.idDetails id of - DataConWorkId con -> Just con - DataConWrapId con -> Just con - _ -> Nothing - -isJoinId :: Var -> Bool --- It is convenient in SetLevels.lvlMFE to apply isJoinId --- to the free vars of an expression, so it's convenient --- if it returns False for type variables -isJoinId id - | isId id = case Var.idDetails id of - JoinId {} -> True - _ -> False - | otherwise = False - -isJoinId_maybe :: Var -> Maybe JoinArity -isJoinId_maybe id - | isId id = ASSERT2( isId id, ppr id ) - case Var.idDetails id of - JoinId arity -> Just arity - _ -> Nothing - | otherwise = Nothing - -idDataCon :: Id -> DataCon --- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. --- --- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker -idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) - -hasNoBinding :: Id -> Bool --- ^ Returns @True@ of an 'Id' which may not have a --- binding, even though it is defined in this module. - --- Data constructor workers used to be things of this kind, but --- they aren't any more. Instead, we inject a binding for --- them at the CorePrep stage. --- EXCEPT: unboxed tuples, which definitely have no binding -hasNoBinding id = case Var.idDetails id of - PrimOpId _ -> True -- See Note [Primop wrappers] - FCallId _ -> True - DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc - _ -> False - -isImplicitId :: Id -> Bool --- ^ 'isImplicitId' tells whether an 'Id's info is implied by other --- declarations, so we don't need to put its signature in an interface --- file, even if it's mentioned in some other interface unfolding. -isImplicitId id - = case Var.idDetails id of - FCallId {} -> True - ClassOpId {} -> True - PrimOpId {} -> True - DataConWorkId {} -> True - DataConWrapId {} -> True - -- These are implied by their type or class decl; - -- remember that all type and class decls appear in the interface file. - -- The dfun id is not an implicit Id; it must *not* be omitted, because - -- it carries version info for the instance decl - _ -> False - -idIsFrom :: Module -> Id -> Bool -idIsFrom mod id = nameIsLocalOrFrom mod (idName id) - -{- -Note [Primop wrappers] -~~~~~~~~~~~~~~~~~~~~~~ -Currently hasNoBinding claims that PrimOpIds don't have a curried -function definition. But actually they do, in GHC.PrimopWrappers, -which is auto-generated from prelude/primops.txt.pp. So actually, hasNoBinding -could return 'False' for PrimOpIds. - -But we'd need to add something in CoreToStg to swizzle any unsaturated -applications of GHC.Prim.plusInt# to GHC.PrimopWrappers.plusInt#. - -Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's -used by GHCi, which does not implement primops direct at all. --} - -isDeadBinder :: Id -> Bool -isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) - | otherwise = False -- TyVars count as not dead - -{- -************************************************************************ -* * - Evidence variables -* * -************************************************************************ --} - -isEvVar :: Var -> Bool -isEvVar var = isPredTy (varType var) - -isDictId :: Id -> Bool -isDictId id = isDictTy (idType id) - -{- -************************************************************************ -* * - Join variables -* * -************************************************************************ --} - -idJoinArity :: JoinId -> JoinArity -idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id) - -asJoinId :: Id -> JoinArity -> JoinId -asJoinId id arity = WARN(not (isLocalId id), - text "global id being marked as join var:" <+> ppr id) - WARN(not (is_vanilla_or_join id), - ppr id <+> pprIdDetails (idDetails id)) - id `setIdDetails` JoinId arity - where - is_vanilla_or_join id = case Var.idDetails id of - VanillaId -> True - JoinId {} -> True - _ -> False - -zapJoinId :: Id -> Id --- May be a regular id already -zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId) - -- Core Lint may complain if still marked - -- as AlwaysTailCalled - | otherwise = jid - -asJoinId_maybe :: Id -> Maybe JoinArity -> Id -asJoinId_maybe id (Just arity) = asJoinId id arity -asJoinId_maybe id Nothing = zapJoinId id - -{- -************************************************************************ -* * -\subsection{IdInfo stuff} -* * -************************************************************************ --} - - --------------------------------- - -- ARITY -idArity :: Id -> Arity -idArity id = arityInfo (idInfo id) - -setIdArity :: Id -> Arity -> Id -setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id - -idCallArity :: Id -> Arity -idCallArity id = callArityInfo (idInfo id) - -setIdCallArity :: Id -> Arity -> Id -setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id - -idFunRepArity :: Id -> RepArity -idFunRepArity x = countFunRepArgs (idArity x) (idType x) - --- | Returns true if an application to n args would diverge -isBottomingId :: Var -> Bool -isBottomingId v - | isId v = isBottomingSig (idStrictness v) - | otherwise = False - -idStrictness :: Id -> StrictSig -idStrictness id = strictnessInfo (idInfo id) - -setIdStrictness :: Id -> StrictSig -> Id -setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id - -zapIdStrictness :: Id -> Id -zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id - --- | This predicate says whether the 'Id' has a strict demand placed on it or --- has a type such that it can always be evaluated strictly (i.e an --- unlifted type, as of GHC 7.6). We need to --- check separately whether the 'Id' has a so-called \"strict type\" because if --- the demand for the given @id@ hasn't been computed yet but @id@ has a strict --- type, we still want @isStrictId id@ to be @True@. -isStrictId :: Id -> Bool -isStrictId id - = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) - not (isJoinId id) && ( - (isStrictType (idType id)) || - -- Take the best of both strictnesses - old and new - (isStrictDmd (idDemandInfo id)) - ) - - --------------------------------- - -- UNFOLDING -idUnfolding :: Id -> Unfolding --- Do not expose the unfolding of a loop breaker! -idUnfolding id - | isStrongLoopBreaker (occInfo info) = NoUnfolding - | otherwise = unfoldingInfo info - where - info = idInfo id - -realIdUnfolding :: Id -> Unfolding --- Expose the unfolding if there is one, including for loop breakers -realIdUnfolding id = unfoldingInfo (idInfo id) - -setIdUnfolding :: Id -> Unfolding -> Id -setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id - -idDemandInfo :: Id -> Demand -idDemandInfo id = demandInfo (idInfo id) - -setIdDemandInfo :: Id -> Demand -> Id -setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id - -setCaseBndrEvald :: StrictnessMark -> Id -> Id --- Used for variables bound by a case expressions, both the case-binder --- itself, and any pattern-bound variables that are argument of a --- strict constructor. It just marks the variable as already-evaluated, --- so that (for example) a subsequent 'seq' can be dropped -setCaseBndrEvald str id - | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding - | otherwise = id - - --------------------------------- - -- SPECIALISATION - --- See Note [Specialisations and RULES in IdInfo] in IdInfo.hs - -idSpecialisation :: Id -> RuleInfo -idSpecialisation id = ruleInfo (idInfo id) - -idCoreRules :: Id -> [CoreRule] -idCoreRules id = ruleInfoRules (idSpecialisation id) - -idHasRules :: Id -> Bool -idHasRules id = not (isEmptyRuleInfo (idSpecialisation id)) - -setIdSpecialisation :: Id -> RuleInfo -> Id -setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id - - --------------------------------- - -- CAF INFO -idCafInfo :: Id -> CafInfo -idCafInfo id = cafInfo (idInfo id) - -setIdCafInfo :: Id -> CafInfo -> Id -setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id - - --------------------------------- - -- Occcurrence INFO -idOccInfo :: Id -> OccInfo -idOccInfo id = occInfo (idInfo id) - -setIdOccInfo :: Id -> OccInfo -> Id -setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id - -zapIdOccInfo :: Id -> Id -zapIdOccInfo b = b `setIdOccInfo` noOccInfo - -{- - --------------------------------- - -- INLINING -The inline pragma tells us to be very keen to inline this Id, but it's still -OK not to if optimisation is switched off. --} - -idInlinePragma :: Id -> InlinePragma -idInlinePragma id = inlinePragInfo (idInfo id) - -setInlinePragma :: Id -> InlinePragma -> Id -setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id - -modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id -modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id - -idInlineActivation :: Id -> Activation -idInlineActivation id = inlinePragmaActivation (idInlinePragma id) - -setInlineActivation :: Id -> Activation -> Id -setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) - -idRuleMatchInfo :: Id -> RuleMatchInfo -idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) - -isConLikeId :: Id -> Bool -isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id) - -{- - --------------------------------- - -- ONE-SHOT LAMBDAS --} - -idOneShotInfo :: Id -> OneShotInfo -idOneShotInfo id = oneShotInfo (idInfo id) - --- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account --- See Note [The state-transformer hack] in CoreArity -idStateHackOneShotInfo :: Id -> OneShotInfo -idStateHackOneShotInfo id - | isStateHackType (idType id) = stateHackOneShot - | otherwise = idOneShotInfo id - --- | Returns whether the lambda associated with the 'Id' is certainly applied at most once --- This one is the "business end", called externally. --- It works on type variables as well as Ids, returning True --- Its main purpose is to encapsulate the Horrible State Hack --- See Note [The state-transformer hack] in CoreArity -isOneShotBndr :: Var -> Bool -isOneShotBndr var - | isTyVar var = True - | OneShotLam <- idStateHackOneShotInfo var = True - | otherwise = False - --- | Should we apply the state hack to values of this 'Type'? -stateHackOneShot :: OneShotInfo -stateHackOneShot = OneShotLam - -typeOneShot :: Type -> OneShotInfo -typeOneShot ty - | isStateHackType ty = stateHackOneShot - | otherwise = NoOneShotInfo - -isStateHackType :: Type -> Bool -isStateHackType ty - | hasNoStateHack unsafeGlobalDynFlags - = False - | otherwise - = case tyConAppTyCon_maybe ty of - Just tycon -> tycon == statePrimTyCon - _ -> False - -- This is a gross hack. It claims that - -- every function over realWorldStatePrimTy is a one-shot - -- function. This is pretty true in practice, and makes a big - -- difference. For example, consider - -- a `thenST` \ r -> ...E... - -- The early full laziness pass, if it doesn't know that r is one-shot - -- will pull out E (let's say it doesn't mention r) to give - -- let lvl = E in a `thenST` \ r -> ...lvl... - -- When `thenST` gets inlined, we end up with - -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... - -- and we don't re-inline E. - -- - -- It would be better to spot that r was one-shot to start with, but - -- I don't want to rely on that. - -- - -- Another good example is in fill_in in PrelPack.hs. We should be able to - -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. - -isProbablyOneShotLambda :: Id -> Bool -isProbablyOneShotLambda id = case idStateHackOneShotInfo id of - OneShotLam -> True - NoOneShotInfo -> False - -setOneShotLambda :: Id -> Id -setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id - -clearOneShotLambda :: Id -> Id -clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id - -setIdOneShotInfo :: Id -> OneShotInfo -> Id -setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id - -updOneShotInfo :: Id -> OneShotInfo -> Id --- Combine the info in the Id with new info -updOneShotInfo id one_shot - | do_upd = setIdOneShotInfo id one_shot - | otherwise = id - where - do_upd = case (idOneShotInfo id, one_shot) of - (NoOneShotInfo, _) -> True - (OneShotLam, _) -> False - --- The OneShotLambda functions simply fiddle with the IdInfo flag --- But watch out: this may change the type of something else --- f = \x -> e --- If we change the one-shot-ness of x, f's type changes - -zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id -zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id - -zapLamIdInfo :: Id -> Id -zapLamIdInfo = zapInfo zapLamInfo - -zapFragileIdInfo :: Id -> Id -zapFragileIdInfo = zapInfo zapFragileInfo - -zapIdDemandInfo :: Id -> Id -zapIdDemandInfo = zapInfo zapDemandInfo - -zapIdUsageInfo :: Id -> Id -zapIdUsageInfo = zapInfo zapUsageInfo - -zapIdUsageEnvInfo :: Id -> Id -zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo - -zapIdUsedOnceInfo :: Id -> Id -zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo - -zapIdTailCallInfo :: Id -> Id -zapIdTailCallInfo = zapInfo zapTailCallInfo - -{- -Note [transferPolyIdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~ -This transfer is used in two places: - FloatOut (long-distance let-floating) - SimplUtils.abstractFloats (short-distance let-floating) - -Consider the short-distance let-floating: - - f = /\a. let g = rhs in ... - -Then if we float thus - - g' = /\a. rhs - f = /\a. ...[g' a/g].... - -we *do not* want to lose g's - * strictness information - * arity - * inline pragma (though that is bit more debatable) - * occurrence info - -Mostly this is just an optimisation, but it's *vital* to -transfer the occurrence info. Consider - - NonRec { f = /\a. let Rec { g* = ..g.. } in ... } - -where the '*' means 'LoopBreaker'. Then if we float we must get - - Rec { g'* = /\a. ...(g' a)... } - NonRec { f = /\a. ...[g' a/g]....} - -where g' is also marked as LoopBreaker. If not, terrible things -can happen if we re-simplify the binding (and the Simplifier does -sometimes simplify a term twice); see Trac #4345. - -It's not so simple to retain - * worker info - * rules -so we simply discard those. Sooner or later this may bite us. - -If we abstract wrt one or more *value* binders, we must modify the -arity and strictness info before transferring it. E.g. - f = \x. e ---> - g' = \y. \x. e - + substitute (g' y) for g -Notice that g' has an arity one more than the original g --} - -transferPolyIdInfo :: Id -- Original Id - -> [Var] -- Abstract wrt these variables - -> Id -- New Id - -> Id -transferPolyIdInfo old_id abstract_wrt new_id - = modifyIdInfo transfer new_id - where - arity_increase = count isId abstract_wrt -- Arity increases by the - -- number of value binders - - old_info = idInfo old_id - old_arity = arityInfo old_info - old_inline_prag = inlinePragInfo old_info - old_occ_info = occInfo old_info - new_arity = old_arity + arity_increase - new_occ_info = zapOccTailCallInfo old_occ_info - - old_strictness = strictnessInfo old_info - new_strictness = increaseStrictSigArity arity_increase old_strictness - - transfer new_info = new_info `setArityInfo` new_arity - `setInlinePragInfo` old_inline_prag - `setOccInfo` new_occ_info - `setStrictnessInfo` new_strictness - -isNeverLevPolyId :: Id -> Bool -isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo diff --git a/basicTypes/IdInfo.hs b/basicTypes/IdInfo.hs deleted file mode 100644 --- a/basicTypes/IdInfo.hs +++ /dev/null @@ -1,622 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} - -(And a pretty good illustration of quite a few things wrong with -Haskell. [WDP 94/11]) --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -module IdInfo ( - -- * The IdDetails type - IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, - JoinArity, isJoinIdDetails_maybe, - RecSelParent(..), - - -- * The IdInfo type - IdInfo, -- Abstract - vanillaIdInfo, noCafIdInfo, - - -- ** The OneShotInfo type - OneShotInfo(..), - oneShotInfo, noOneShotInfo, hasNoOneShotInfo, - setOneShotInfo, - - -- ** Zapping various forms of Info - zapLamInfo, zapFragileInfo, - zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, - zapTailCallInfo, zapCallArityInfo, - - -- ** The ArityInfo type - ArityInfo, - unknownArity, - arityInfo, setArityInfo, ppArityInfo, - - callArityInfo, setCallArityInfo, - - -- ** Demand and strictness Info - strictnessInfo, setStrictnessInfo, - demandInfo, setDemandInfo, pprStrictness, - - -- ** Unfolding Info - unfoldingInfo, setUnfoldingInfo, - - -- ** The InlinePragInfo type - InlinePragInfo, - inlinePragInfo, setInlinePragInfo, - - -- ** The OccInfo type - OccInfo(..), - isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, - occInfo, setOccInfo, - - InsideLam, OneBranch, - insideLam, notInsideLam, oneBranch, notOneBranch, - - TailCallInfo(..), - tailCallInfo, isAlwaysTailCalled, - - -- ** The RuleInfo type - RuleInfo(..), - emptyRuleInfo, - isEmptyRuleInfo, ruleInfoFreeVars, - ruleInfoRules, setRuleInfoHead, - ruleInfo, setRuleInfo, - - -- ** The CAFInfo type - CafInfo(..), - ppCafInfo, mayHaveCafRefs, - cafInfo, setCafInfo, - - -- ** Tick-box Info - TickBoxOp(..), TickBoxId, - - -- ** Levity info - LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType, - isNeverLevPolyIdInfo - ) where - -#include "HsVersions.h" - -import CoreSyn - -import Class -import {-# SOURCE #-} PrimOp (PrimOp) -import Name -import VarSet -import BasicTypes -import DataCon -import TyCon -import PatSyn -import Type -import ForeignCall -import Outputable -import Module -import Demand -import Util - --- infixl so you can say (id `set` a `set` b) -infixl 1 `setRuleInfo`, - `setArityInfo`, - `setInlinePragInfo`, - `setUnfoldingInfo`, - `setOneShotInfo`, - `setOccInfo`, - `setCafInfo`, - `setStrictnessInfo`, - `setDemandInfo`, - `setNeverLevPoly`, - `setLevityInfoWithType` - -{- -************************************************************************ -* * - IdDetails -* * -************************************************************************ --} - --- | Identifier Details --- --- The 'IdDetails' of an 'Id' give stable, and necessary, --- information about the Id. -data IdDetails - = VanillaId - - -- | The 'Id' for a record selector - | RecSelId - { sel_tycon :: RecSelParent - , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: - -- data T = forall a. MkT { x :: a } - } -- See Note [Naughty record selectors] in TcTyClsDecls - - | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ - | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ - - -- [the only reasons we need to know is so that - -- a) to support isImplicitId - -- b) when desugaring a RecordCon we can get - -- from the Id back to the data con] - | ClassOpId Class -- ^ The 'Id' is a superclass selector, - -- or class operation of a class - - | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator - | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. - -- Type will be simple: no type families, newtypes, etc - - | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - - | DFunId Bool -- ^ A dictionary function. - -- Bool = True <=> the class has only one method, so may be - -- implemented with a newtype, so it might be bad - -- to be strict on this dictionary - - | CoVarId -- ^ A coercion variable - -- This only covers /un-lifted/ coercions, of type - -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants - | JoinId JoinArity -- ^ An 'Id' for a join point taking n arguments - -- Note [Join points] in CoreSyn - --- | Recursive Selector Parent -data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq - -- Either `TyCon` or `PatSyn` depending - -- on the origin of the record selector. - -- For a data type family, this is the - -- /instance/ 'TyCon' not the family 'TyCon' - -instance Outputable RecSelParent where - ppr p = case p of - RecSelData ty_con -> ppr ty_con - RecSelPatSyn ps -> ppr ps - --- | Just a synonym for 'CoVarId'. Written separately so it can be --- exported in the hs-boot file. -coVarDetails :: IdDetails -coVarDetails = CoVarId - --- | Check if an 'IdDetails' says 'CoVarId'. -isCoVarDetails :: IdDetails -> Bool -isCoVarDetails CoVarId = True -isCoVarDetails _ = False - -isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity -isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity -isJoinIdDetails_maybe _ = Nothing - -instance Outputable IdDetails where - ppr = pprIdDetails - -pprIdDetails :: IdDetails -> SDoc -pprIdDetails VanillaId = empty -pprIdDetails other = brackets (pp other) - where - pp VanillaId = panic "pprIdDetails" - pp (DataConWorkId _) = text "DataCon" - pp (DataConWrapId _) = text "DataConWrapper" - pp (ClassOpId {}) = text "ClassOp" - pp (PrimOpId _) = text "PrimOp" - pp (FCallId _) = text "ForeignCall" - pp (TickBoxOpId _) = text "TickBoxOp" - pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") - pp (RecSelId { sel_naughty = is_naughty }) - = brackets $ text "RecSel" <> - ppWhen is_naughty (text "(naughty)") - pp CoVarId = text "CoVarId" - pp (JoinId arity) = text "JoinId" <> parens (int arity) - -{- -************************************************************************ -* * -\subsection{The main IdInfo type} -* * -************************************************************************ --} - --- | Identifier Information --- --- An 'IdInfo' gives /optional/ information about an 'Id'. If --- present it never lies, but it may not be present, in which case there --- is always a conservative assumption which can be made. --- --- Two 'Id's may have different info even though they have the same --- 'Unique' (and are hence the same 'Id'); for example, one might lack --- the properties attached to the other. --- --- Most of the 'IdInfo' gives information about the value, or definition, of --- the 'Id', independent of its usage. Exceptions to this --- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'. --- --- Performance note: when we update 'IdInfo', we have to reallocate this --- entire record, so it is a good idea not to let this data structure get --- too big. -data IdInfo - = IdInfo { - arityInfo :: !ArityInfo, -- ^ 'Id' arity - ruleInfo :: RuleInfo, -- ^ Specialisations of the 'Id's function which exist - -- See Note [Specialisations and RULES in IdInfo] - unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding - cafInfo :: CafInfo, -- ^ 'Id' CAF info - oneShotInfo :: OneShotInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one - inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id' - occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program - - strictnessInfo :: StrictSig, -- ^ A strictness signature - - demandInfo :: Demand, -- ^ ID demand information - callArityInfo :: !ArityInfo, -- ^ How this is called. - -- n <=> all calls have at least n arguments - - levityInfo :: LevityInfo -- ^ when applied, will this Id ever have a levity-polymorphic type? - } - --- Setters - -setRuleInfo :: IdInfo -> RuleInfo -> IdInfo -setRuleInfo info sp = sp `seq` info { ruleInfo = sp } -setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo -setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } -setOccInfo :: IdInfo -> OccInfo -> IdInfo -setOccInfo info oc = oc `seq` info { occInfo = oc } - -- Try to avoid spack leaks by seq'ing - -setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo -setUnfoldingInfo info uf - = -- We don't seq the unfolding, as we generate intermediate - -- unfoldings which are just thrown away, so evaluating them is a - -- waste of time. - -- seqUnfolding uf `seq` - info { unfoldingInfo = uf } - -setArityInfo :: IdInfo -> ArityInfo -> IdInfo -setArityInfo info ar = info { arityInfo = ar } -setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo -setCallArityInfo info ar = info { callArityInfo = ar } -setCafInfo :: IdInfo -> CafInfo -> IdInfo -setCafInfo info caf = info { cafInfo = caf } - -setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo -setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb } - -setDemandInfo :: IdInfo -> Demand -> IdInfo -setDemandInfo info dd = dd `seq` info { demandInfo = dd } - -setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo -setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } - --- | Basic 'IdInfo' that carries no useful information whatsoever -vanillaIdInfo :: IdInfo -vanillaIdInfo - = IdInfo { - cafInfo = vanillaCafInfo, - arityInfo = unknownArity, - ruleInfo = emptyRuleInfo, - unfoldingInfo = noUnfolding, - oneShotInfo = NoOneShotInfo, - inlinePragInfo = defaultInlinePragma, - occInfo = noOccInfo, - demandInfo = topDmd, - strictnessInfo = nopSig, - callArityInfo = unknownArity, - levityInfo = NoLevityInfo - } - --- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references -noCafIdInfo :: IdInfo -noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs - -- Used for built-in type Ids in MkId. - -{- -************************************************************************ -* * -\subsection[arity-IdInfo]{Arity info about an @Id@} -* * -************************************************************************ - -For locally-defined Ids, the code generator maintains its own notion -of their arities; so it should not be asking... (but other things -besides the code-generator need arity info!) --} - --- | Arity Information --- --- An 'ArityInfo' of @n@ tells us that partial application of this --- 'Id' to up to @n-1@ value arguments does essentially no work. --- --- That is not necessarily the same as saying that it has @n@ leading --- lambdas, because coerces may get in the way. --- --- The arity might increase later in the compilation process, if --- an extra lambda floats up to the binding site. -type ArityInfo = Arity - --- | It is always safe to assume that an 'Id' has an arity of 0 -unknownArity :: Arity -unknownArity = 0 - -ppArityInfo :: Int -> SDoc -ppArityInfo 0 = empty -ppArityInfo n = hsep [text "Arity", int n] - -{- -************************************************************************ -* * -\subsection{Inline-pragma information} -* * -************************************************************************ --} - --- | Inline Pragma Information --- --- Tells when the inlining is active. --- When it is active the thing may be inlined, depending on how --- big it is. --- --- If there was an @INLINE@ pragma, then as a separate matter, the --- RHS will have been made to look small with a Core inline 'Note' --- --- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves --- entirely as a way to inhibit inlining until we want it -type InlinePragInfo = InlinePragma - -{- -************************************************************************ -* * - Strictness -* * -************************************************************************ --} - -pprStrictness :: StrictSig -> SDoc -pprStrictness sig = ppr sig - -{- -************************************************************************ -* * - RuleInfo -* * -************************************************************************ - -Note [Specialisations and RULES in IdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking, a GlobalId has an *empty* RuleInfo. All their -RULES are contained in the globally-built rule-base. In principle, -one could attach the to M.f the RULES for M.f that are defined in M. -But we don't do that for instance declarations and so we just treat -them all uniformly. - -The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is -jsut for convenience really. - -However, LocalIds may have non-empty RuleInfo. We treat them -differently because: - a) they might be nested, in which case a global table won't work - b) the RULE might mention free variables, which we use to keep things alive - -In TidyPgm, when the LocalId becomes a GlobalId, its RULES are stripped off -and put in the global list. --} - --- | Rule Information --- --- Records the specializations of this 'Id' that we know about --- in the form of rewrite 'CoreRule's that target them -data RuleInfo - = RuleInfo - [CoreRule] - DVarSet -- Locally-defined free vars of *both* LHS and RHS - -- of rules. I don't think it needs to include the - -- ru_fn though. - -- Note [Rule dependency info] in OccurAnal - --- | Assume that no specilizations exist: always safe -emptyRuleInfo :: RuleInfo -emptyRuleInfo = RuleInfo [] emptyDVarSet - -isEmptyRuleInfo :: RuleInfo -> Bool -isEmptyRuleInfo (RuleInfo rs _) = null rs - --- | Retrieve the locally-defined free variables of both the left and --- right hand sides of the specialization rules -ruleInfoFreeVars :: RuleInfo -> DVarSet -ruleInfoFreeVars (RuleInfo _ fvs) = fvs - -ruleInfoRules :: RuleInfo -> [CoreRule] -ruleInfoRules (RuleInfo rules _) = rules - --- | Change the name of the function the rule is keyed on on all of the 'CoreRule's -setRuleInfoHead :: Name -> RuleInfo -> RuleInfo -setRuleInfoHead fn (RuleInfo rules fvs) - = RuleInfo (map (setRuleIdName fn) rules) fvs - -{- -************************************************************************ -* * -\subsection[CG-IdInfo]{Code generator-related information} -* * -************************************************************************ --} - --- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs). - --- | Constant applicative form Information --- --- Records whether an 'Id' makes Constant Applicative Form references -data CafInfo - = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: - -- - -- 1. A function or static constructor - -- that refers to one or more CAFs, or - -- - -- 2. A real live CAF - - | NoCafRefs -- ^ A function or static constructor - -- that refers to no CAFs. - deriving (Eq, Ord) - --- | Assumes that the 'Id' has CAF references: definitely safe -vanillaCafInfo :: CafInfo -vanillaCafInfo = MayHaveCafRefs - -mayHaveCafRefs :: CafInfo -> Bool -mayHaveCafRefs MayHaveCafRefs = True -mayHaveCafRefs _ = False - -instance Outputable CafInfo where - ppr = ppCafInfo - -ppCafInfo :: CafInfo -> SDoc -ppCafInfo NoCafRefs = text "NoCafRefs" -ppCafInfo MayHaveCafRefs = empty - -{- -************************************************************************ -* * -\subsection{Bulk operations on IdInfo} -* * -************************************************************************ --} - --- | This is used to remove information on lambda binders that we have --- setup as part of a lambda group, assuming they will be applied all at once, --- but turn out to be part of an unsaturated lambda as in e.g: --- --- > (\x1. \x2. e) arg1 -zapLamInfo :: IdInfo -> Maybe IdInfo -zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) - | is_safe_occ occ && is_safe_dmd demand - = Nothing - | otherwise - = Just (info {occInfo = safe_occ, demandInfo = topDmd}) - where - -- The "unsafe" occ info is the ones that say I'm not in a lambda - -- because that might not be true for an unsaturated lambda - is_safe_occ occ | isAlwaysTailCalled occ = False - is_safe_occ (OneOcc { occ_in_lam = in_lam }) = in_lam - is_safe_occ _other = True - - safe_occ = case occ of - OneOcc{} -> occ { occ_in_lam = True - , occ_tail = NoTailCallInfo } - IAmALoopBreaker{} - -> occ { occ_tail = NoTailCallInfo } - _other -> occ - - is_safe_dmd dmd = not (isStrictDmd dmd) - --- | Remove all demand info on the 'IdInfo' -zapDemandInfo :: IdInfo -> Maybe IdInfo -zapDemandInfo info = Just (info {demandInfo = topDmd}) - --- | Remove usage (but not strictness) info on the 'IdInfo' -zapUsageInfo :: IdInfo -> Maybe IdInfo -zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) - --- | Remove usage environment info from the strictness signature on the 'IdInfo' -zapUsageEnvInfo :: IdInfo -> Maybe IdInfo -zapUsageEnvInfo info - | hasDemandEnvSig (strictnessInfo info) - = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)}) - | otherwise - = Nothing - -zapUsedOnceInfo :: IdInfo -> Maybe IdInfo -zapUsedOnceInfo info - = Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info) - , demandInfo = zapUsedOnceDemand (demandInfo info) } - -zapFragileInfo :: IdInfo -> Maybe IdInfo --- ^ Zap info that depends on free variables -zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf }) - = new_unf `seq` -- The unfolding field is not (currently) strict, so we - -- force it here to avoid a (zapFragileUnfolding unf) thunk - -- which might leak space - Just (info `setRuleInfo` emptyRuleInfo - `setUnfoldingInfo` new_unf - `setOccInfo` zapFragileOcc occ) - where - new_unf = zapFragileUnfolding unf - -zapFragileUnfolding :: Unfolding -> Unfolding -zapFragileUnfolding unf - | isFragileUnfolding unf = noUnfolding - | otherwise = unf - -zapTailCallInfo :: IdInfo -> Maybe IdInfo -zapTailCallInfo info - = case occInfo info of - occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ) - | otherwise -> Nothing - where - safe_occ = occ { occ_tail = NoTailCallInfo } - -zapCallArityInfo :: IdInfo -> IdInfo -zapCallArityInfo info = setCallArityInfo info 0 - -{- -************************************************************************ -* * -\subsection{TickBoxOp} -* * -************************************************************************ --} - -type TickBoxId = Int - --- | Tick box for Hpc-style coverage -data TickBoxOp - = TickBox Module {-# UNPACK #-} !TickBoxId - -instance Outputable TickBoxOp where - ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) - -{- -************************************************************************ -* * - Levity -* * -************************************************************************ - -Note [Levity info] -~~~~~~~~~~~~~~~~~~ - -Ids store whether or not they can be levity-polymorphic at any amount -of saturation. This is helpful in optimizing the levity-polymorphism check -done in the desugarer, where we can usually learn that something is not -levity-polymorphic without actually figuring out its type. See -isExprLevPoly in CoreUtils for where this info is used. Storing -this is required to prevent perf/compiler/T5631 from blowing up. - --} - --- See Note [Levity info] -data LevityInfo = NoLevityInfo -- always safe - | NeverLevityPolymorphic - deriving Eq - -instance Outputable LevityInfo where - ppr NoLevityInfo = text "NoLevityInfo" - ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" - --- | Marks an IdInfo describing an Id that is never levity polymorphic (even when --- applied). The Type is only there for checking that it's really never levity --- polymorphic -setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo -setNeverLevPoly info ty - = ASSERT2( not (resultIsLevPoly ty), ppr ty ) - info { levityInfo = NeverLevityPolymorphic } - -setLevityInfoWithType :: IdInfo -> Type -> IdInfo -setLevityInfoWithType info ty - | not (resultIsLevPoly ty) - = info { levityInfo = NeverLevityPolymorphic } - | otherwise - = info - -isNeverLevPolyIdInfo :: IdInfo -> Bool -isNeverLevPolyIdInfo info - | NeverLevityPolymorphic <- levityInfo info = True - | otherwise = False diff --git a/basicTypes/IdInfo.hs-boot b/basicTypes/IdInfo.hs-boot deleted file mode 100644 --- a/basicTypes/IdInfo.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module IdInfo where -import Outputable -data IdInfo -data IdDetails - -vanillaIdInfo :: IdInfo -coVarDetails :: IdDetails -isCoVarDetails :: IdDetails -> Bool -pprIdDetails :: IdDetails -> SDoc - diff --git a/basicTypes/Lexeme.hs b/basicTypes/Lexeme.hs deleted file mode 100644 --- a/basicTypes/Lexeme.hs +++ /dev/null @@ -1,238 +0,0 @@ --- (c) The GHC Team --- --- Functions to evaluate whether or not a string is a valid identifier. --- There is considerable overlap between the logic here and the logic --- in Lexer.x, but sadly there seems to be way to merge them. - -module Lexeme ( - -- * Lexical characteristics of Haskell names - - -- | Use these functions to figure what kind of name a 'FastString' - -- represents; these functions do /not/ check that the identifier - -- is valid. - - isLexCon, isLexVar, isLexId, isLexSym, - isLexConId, isLexConSym, isLexVarId, isLexVarSym, - startsVarSym, startsVarId, startsConSym, startsConId, - - -- * Validating identifiers - - -- | These functions (working over plain old 'String's) check - -- to make sure that the identifier is valid. - okVarOcc, okConOcc, okTcOcc, - okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc - - -- Some of the exports above are not used within GHC, but may - -- be of value to GHC API users. - - ) where - -import FastString - -import Data.Char -import qualified Data.Set as Set - -import GHC.Lexeme - -{- - -************************************************************************ -* * - Lexical categories -* * -************************************************************************ - -These functions test strings to see if they fit the lexical categories -defined in the Haskell report. - -Note [Classification of generated names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Some names generated for internal use can show up in debugging output, -e.g. when using -ddump-simpl. These generated names start with a $ -but should still be pretty-printed using prefix notation. We make sure -this is the case in isLexVarSym by only classifying a name as a symbol -if all its characters are symbols, not just its first one. --} - -isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool -isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool - -isLexCon cs = isLexConId cs || isLexConSym cs -isLexVar cs = isLexVarId cs || isLexVarSym cs - -isLexId cs = isLexConId cs || isLexVarId cs -isLexSym cs = isLexConSym cs || isLexVarSym cs - -------------- -isLexConId cs -- Prefix type or data constructors - | nullFS cs = False -- e.g. "Foo", "[]", "(,)" - | cs == (fsLit "[]") = True - | otherwise = startsConId (headFS cs) - -isLexVarId cs -- Ordinary prefix identifiers - | nullFS cs = False -- e.g. "x", "_x" - | otherwise = startsVarId (headFS cs) - -isLexConSym cs -- Infix type or data constructors - | nullFS cs = False -- e.g. ":-:", ":", "->" - | cs == (fsLit "->") = True - | otherwise = startsConSym (headFS cs) - -isLexVarSym fs -- Infix identifiers e.g. "+" - | fs == (fsLit "~R#") = True - | otherwise - = case (if nullFS fs then [] else unpackFS fs) of - [] -> False - (c:cs) -> startsVarSym c && all isVarSymChar cs - -- See Note [Classification of generated names] - -{- - -************************************************************************ -* * - Detecting valid names for Template Haskell -* * -************************************************************************ - --} - ----------------------- --- External interface ----------------------- - --- | Is this an acceptable variable name? -okVarOcc :: String -> Bool -okVarOcc str@(c:_) - | startsVarId c - = okVarIdOcc str - | startsVarSym c - = okVarSymOcc str -okVarOcc _ = False - --- | Is this an acceptable constructor name? -okConOcc :: String -> Bool -okConOcc str@(c:_) - | startsConId c - = okConIdOcc str - | startsConSym c - = okConSymOcc str - | str == "[]" - = True -okConOcc _ = False - --- | Is this an acceptable type name? -okTcOcc :: String -> Bool -okTcOcc "[]" = True -okTcOcc "->" = True -okTcOcc "~" = True -okTcOcc str@(c:_) - | startsConId c - = okConIdOcc str - | startsConSym c - = okConSymOcc str - | startsVarSym c - = okVarSymOcc str -okTcOcc _ = False - --- | Is this an acceptable alphanumeric variable name, assuming it starts --- with an acceptable letter? -okVarIdOcc :: String -> Bool -okVarIdOcc str = okIdOcc str && - -- admit "_" as a valid identifier. Required to support typed - -- holes in Template Haskell. See #10267 - (str == "_" || not (str `Set.member` reservedIds)) - --- | Is this an acceptable symbolic variable name, assuming it starts --- with an acceptable character? -okVarSymOcc :: String -> Bool -okVarSymOcc str = all okSymChar str && - not (str `Set.member` reservedOps) && - not (isDashes str) - --- | Is this an acceptable alphanumeric constructor name, assuming it --- starts with an acceptable letter? -okConIdOcc :: String -> Bool -okConIdOcc str = okIdOcc str || - is_tuple_name1 True str || - -- Is it a boxed tuple... - is_tuple_name1 False str || - -- ...or an unboxed tuple (Trac #12407)... - is_sum_name1 str - -- ...or an unboxed sum (Trac #12514)? - where - -- check for tuple name, starting at the beginning - is_tuple_name1 True ('(' : rest) = is_tuple_name2 True rest - is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest - is_tuple_name1 _ _ = False - - -- check for tuple tail - is_tuple_name2 True ")" = True - is_tuple_name2 False "#)" = True - is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest - is_tuple_name2 boxed (ws : rest) - | isSpace ws = is_tuple_name2 boxed rest - is_tuple_name2 _ _ = False - - -- check for sum name, starting at the beginning - is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest - is_sum_name1 _ = False - - -- check for sum tail, only allowing at most one underscore - is_sum_name2 _ "#)" = True - is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest - is_sum_name2 False ('_' : rest) = is_sum_name2 True rest - is_sum_name2 underscore (ws : rest) - | isSpace ws = is_sum_name2 underscore rest - is_sum_name2 _ _ = False - --- | Is this an acceptable symbolic constructor name, assuming it --- starts with an acceptable character? -okConSymOcc :: String -> Bool -okConSymOcc ":" = True -okConSymOcc str = all okSymChar str && - not (str `Set.member` reservedOps) - ----------------------- --- Internal functions ----------------------- - --- | Is this string an acceptable id, possibly with a suffix of hashes, --- but not worrying about case or clashing with reserved words? -okIdOcc :: String -> Bool -okIdOcc str - = let hashes = dropWhile okIdChar str in - all (== '#') hashes -- -XMagicHash allows a suffix of hashes - -- of course, `all` says "True" to an empty list - --- | Is this character acceptable in an identifier (after the first letter)? --- See alexGetByte in Lexer.x -okIdChar :: Char -> Bool -okIdChar c = case generalCategory c of - UppercaseLetter -> True - LowercaseLetter -> True - TitlecaseLetter -> True - ModifierLetter -> True -- See #10196 - OtherLetter -> True -- See #1103 - NonSpacingMark -> True -- See #7650 - DecimalNumber -> True - OtherNumber -> True -- See #4373 - _ -> c == '\'' || c == '_' - --- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. -reservedIds :: Set.Set String -reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" - , "do", "else", "foreign", "if", "import", "in" - , "infix", "infixl", "infixr", "instance", "let" - , "module", "newtype", "of", "then", "type", "where" - , "_" ] - --- | All reserved operators. Taken from section 2.4 of the 2010 Report. -reservedOps :: Set.Set String -reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" - , "@", "~", "=>" ] - --- | Does this string contain only dashes and has at least 2 of them? -isDashes :: String -> Bool -isDashes ('-' : '-' : rest) = all (== '-') rest -isDashes _ = False diff --git a/basicTypes/Literal.hs b/basicTypes/Literal.hs deleted file mode 100644 --- a/basicTypes/Literal.hs +++ /dev/null @@ -1,603 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[Literal]{@Literal@: Machine literals (unboxed, of course)} --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -module Literal - ( - -- * Main data type - Literal(..) -- Exported to ParseIface - - -- ** Creating Literals - , mkMachInt, mkMachIntWrap - , mkMachWord, mkMachWordWrap - , mkMachInt64, mkMachInt64Wrap - , mkMachWord64, mkMachWord64Wrap - , mkMachFloat, mkMachDouble - , mkMachChar, mkMachString - , mkLitInteger - - -- ** Operations on Literals - , literalType - , absentLiteralOf - , pprLiteral - - -- ** Predicates on Literals and their contents - , litIsDupable, litIsTrivial, litIsLifted - , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange - , isZeroLit - , litFitsInChar - , litValue, isLitValue, isLitValue_maybe, mapLitValue - - -- ** Coercions - , word2IntLit, int2WordLit - , narrow8IntLit, narrow16IntLit, narrow32IntLit - , narrow8WordLit, narrow16WordLit, narrow32WordLit - , char2IntLit, int2CharLit - , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , nullAddrLit, float2DoubleLit, double2FloatLit - ) where - -#include "HsVersions.h" - -import TysPrim -import PrelNames -import Type -import TyCon -import Outputable -import FastString -import BasicTypes -import Binary -import Constants -import DynFlags -import Platform -import UniqFM -import Util - -import Data.ByteString (ByteString) -import Data.Int -import Data.Word -import Data.Char -import Data.Maybe ( isJust ) -import Data.Data ( Data ) -import Numeric ( fromRat ) - -{- -************************************************************************ -* * -\subsection{Literals} -* * -************************************************************************ --} - --- | So-called 'Literal's are one of: --- --- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.), --- which is presumed to be surrounded by appropriate constructors --- (@Int#@, etc.), so that the overall thing makes sense. --- --- We maintain the invariant that the 'Integer' the Mach{Int,Word}* --- constructors are actually in the (possibly target-dependent) range. --- The mkMach{Int,Word}*Wrap smart constructors ensure this by applying --- the target machine's wrapping semantics. Use these in situations --- where you know the wrapping semantics are correct. --- --- * The literal derived from the label mentioned in a \"foreign label\" --- declaration ('MachLabel') -data Literal - = ------------------ - -- First the primitive guys - MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar' - - | MachStr ByteString -- ^ A string-literal: stored and emitted - -- UTF-8 encoded, we'll arrange to decode it - -- at runtime. Also emitted with a @'\0'@ - -- terminator. Create with 'mkMachString' - - | MachNullAddr -- ^ The @NULL@ pointer, the only pointer value - -- that can be represented as a Literal. Create - -- with 'nullAddrLit' - - | MachInt Integer -- ^ @Int#@ - according to target machine - | MachInt64 Integer -- ^ @Int64#@ - exactly 64 bits - | MachWord Integer -- ^ @Word#@ - according to target machine - | MachWord64 Integer -- ^ @Word64#@ - exactly 64 bits - - | MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat' - | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble' - - | MachLabel FastString - (Maybe Int) - FunctionOrData - -- ^ A label literal. Parameters: - -- - -- 1) The name of the symbol mentioned in the declaration - -- - -- 2) The size (in bytes) of the arguments - -- the label expects. Only applicable with - -- @stdcall@ labels. @Just x@ => @\@ will - -- be appended to label name when emitting assembly. - - | LitInteger Integer Type -- ^ Integer literals - -- See Note [Integer literals] - deriving Data - -{- -Note [Integer literals] -~~~~~~~~~~~~~~~~~~~~~~~ -An Integer literal is represented using, well, an Integer, to make it -easier to write RULEs for them. They also contain the Integer type, so -that e.g. literalType can return the right Type for them. - -They only get converted into real Core, - mkInteger [c1, c2, .., cn] -during the CorePrep phase, although TidyPgm looks ahead at what the -core will be, so that it can see whether it involves CAFs. - -When we initally build an Integer literal, notably when -deserialising it from an interface file (see the Binary instance -below), we don't have convenient access to the mkInteger Id. So we -just use an error thunk, and fill in the real Id when we do tcIfaceLit -in TcIface. - - -Binary instance --} - -instance Binary Literal where - put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa - put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab - put_ bh (MachNullAddr) = do putByte bh 2 - put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad - put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae - put_ bh (MachWord af) = do putByte bh 5; put_ bh af - put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag - put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah - put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai - put_ bh (MachLabel aj mb fod) - = do putByte bh 9 - put_ bh aj - put_ bh mb - put_ bh fod - put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i - get bh = do - h <- getByte bh - case h of - 0 -> do - aa <- get bh - return (MachChar aa) - 1 -> do - ab <- get bh - return (MachStr ab) - 2 -> do - return (MachNullAddr) - 3 -> do - ad <- get bh - return (MachInt ad) - 4 -> do - ae <- get bh - return (MachInt64 ae) - 5 -> do - af <- get bh - return (MachWord af) - 6 -> do - ag <- get bh - return (MachWord64 ag) - 7 -> do - ah <- get bh - return (MachFloat ah) - 8 -> do - ai <- get bh - return (MachDouble ai) - 9 -> do - aj <- get bh - mb <- get bh - fod <- get bh - return (MachLabel aj mb fod) - _ -> do - i <- get bh - -- See Note [Integer literals] - return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger") - -instance Outputable Literal where - ppr lit = pprLiteral (\d -> d) lit - -instance Eq Literal where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - -instance Ord Literal where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = cmpLit a b - -{- - Construction - ~~~~~~~~~~~~ --} - --- | Creates a 'Literal' of type @Int#@ -mkMachInt :: DynFlags -> Integer -> Literal -mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x ) - MachInt x - --- | Creates a 'Literal' of type @Int#@. --- If the argument is out of the (target-dependent) range, it is wrapped. -mkMachIntWrap :: DynFlags -> Integer -> Literal -mkMachIntWrap dflags i - = MachInt $ case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (fromIntegral i :: Int32) - 8 -> toInteger (fromIntegral i :: Int64) - w -> panic ("toIntRange: Unknown platformWordSize: " ++ show w) - --- | Creates a 'Literal' of type @Word#@ -mkMachWord :: DynFlags -> Integer -> Literal -mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x ) - MachWord x - --- | Creates a 'Literal' of type @Word#@. --- If the argument is out of the (target-dependent) range, it is wrapped. -mkMachWordWrap :: DynFlags -> Integer -> Literal -mkMachWordWrap dflags i - = MachWord $ case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (fromInteger i :: Word32) - 8 -> toInteger (fromInteger i :: Word64) - w -> panic ("toWordRange: Unknown platformWordSize: " ++ show w) - --- | Creates a 'Literal' of type @Int64#@ -mkMachInt64 :: Integer -> Literal -mkMachInt64 x = ASSERT2( inInt64Range x, integer x ) - MachInt64 x - --- | Creates a 'Literal' of type @Int64#@. --- If the argument is out of the range, it is wrapped. -mkMachInt64Wrap :: Integer -> Literal -mkMachInt64Wrap i = MachInt64 (toInteger (fromIntegral i :: Int64)) - --- | Creates a 'Literal' of type @Word64#@ -mkMachWord64 :: Integer -> Literal -mkMachWord64 x = ASSERT2( inWord64Range x, integer x ) - MachWord64 x - --- | Creates a 'Literal' of type @Word64#@. --- If the argument is out of the range, it is wrapped. -mkMachWord64Wrap :: Integer -> Literal -mkMachWord64Wrap i = MachWord64 (toInteger (fromIntegral i :: Word64)) - --- | Creates a 'Literal' of type @Float#@ -mkMachFloat :: Rational -> Literal -mkMachFloat = MachFloat - --- | Creates a 'Literal' of type @Double#@ -mkMachDouble :: Rational -> Literal -mkMachDouble = MachDouble - --- | Creates a 'Literal' of type @Char#@ -mkMachChar :: Char -> Literal -mkMachChar = MachChar - --- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to --- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ -mkMachString :: String -> Literal --- stored UTF-8 encoded -mkMachString s = MachStr (fastStringToByteString $ mkFastString s) - -mkLitInteger :: Integer -> Type -> Literal -mkLitInteger = LitInteger - -inIntRange, inWordRange :: DynFlags -> Integer -> Bool -inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags -inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags - -inInt64Range, inWord64Range :: Integer -> Bool -inInt64Range x = x >= toInteger (minBound :: Int64) && - x <= toInteger (maxBound :: Int64) -inWord64Range x = x >= toInteger (minBound :: Word64) && - x <= toInteger (maxBound :: Word64) - -inCharRange :: Char -> Bool -inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR - --- | Tests whether the literal represents a zero of whatever type it is -isZeroLit :: Literal -> Bool -isZeroLit (MachInt 0) = True -isZeroLit (MachInt64 0) = True -isZeroLit (MachWord 0) = True -isZeroLit (MachWord64 0) = True -isZeroLit (MachFloat 0) = True -isZeroLit (MachDouble 0) = True -isZeroLit _ = False - --- | Returns the 'Integer' contained in the 'Literal', for when that makes --- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'. -litValue :: Literal -> Integer -litValue l = case isLitValue_maybe l of - Just x -> x - Nothing -> pprPanic "litValue" (ppr l) - --- | Returns the 'Integer' contained in the 'Literal', for when that makes --- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'. -isLitValue_maybe :: Literal -> Maybe Integer -isLitValue_maybe (MachChar c) = Just $ toInteger $ ord c -isLitValue_maybe (MachInt i) = Just i -isLitValue_maybe (MachInt64 i) = Just i -isLitValue_maybe (MachWord i) = Just i -isLitValue_maybe (MachWord64 i) = Just i -isLitValue_maybe (LitInteger i _) = Just i -isLitValue_maybe _ = Nothing - --- | Apply a function to the 'Integer' contained in the 'Literal', for when that --- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'. For --- fixed-size integral literals, the result will be wrapped in --- accordance with the semantics of the target type. -mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal -mapLitValue _ f (MachChar c) = mkMachChar (fchar c) - where fchar = chr . fromInteger . f . toInteger . ord -mapLitValue dflags f (MachInt i) = mkMachIntWrap dflags (f i) -mapLitValue _ f (MachInt64 i) = mkMachInt64Wrap (f i) -mapLitValue dflags f (MachWord i) = mkMachWordWrap dflags (f i) -mapLitValue _ f (MachWord64 i) = mkMachWord64Wrap (f i) -mapLitValue _ f (LitInteger i t) = mkLitInteger (f i) t -mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) - --- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', --- 'Int', 'Word' and 'LitInteger'. -isLitValue :: Literal -> Bool -isLitValue = isJust . isLitValue_maybe - -{- - Coercions - ~~~~~~~~~ --} - -narrow8IntLit, narrow16IntLit, narrow32IntLit, - narrow8WordLit, narrow16WordLit, narrow32WordLit, - char2IntLit, int2CharLit, - float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, - float2DoubleLit, double2FloatLit - :: Literal -> Literal - -word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal -word2IntLit dflags (MachWord w) - | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1) - | otherwise = MachInt w -word2IntLit _ l = pprPanic "word2IntLit" (ppr l) - -int2WordLit dflags (MachInt i) - | i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD - | otherwise = MachWord i -int2WordLit _ l = pprPanic "int2WordLit" (ppr l) - -narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8)) -narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l) -narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16)) -narrow16IntLit l = pprPanic "narrow16IntLit" (ppr l) -narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32)) -narrow32IntLit l = pprPanic "narrow32IntLit" (ppr l) -narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8)) -narrow8WordLit l = pprPanic "narrow8WordLit" (ppr l) -narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16)) -narrow16WordLit l = pprPanic "narrow16WordLit" (ppr l) -narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32)) -narrow32WordLit l = pprPanic "narrow32WordLit" (ppr l) - -char2IntLit (MachChar c) = MachInt (toInteger (ord c)) -char2IntLit l = pprPanic "char2IntLit" (ppr l) -int2CharLit (MachInt i) = MachChar (chr (fromInteger i)) -int2CharLit l = pprPanic "int2CharLit" (ppr l) - -float2IntLit (MachFloat f) = MachInt (truncate f) -float2IntLit l = pprPanic "float2IntLit" (ppr l) -int2FloatLit (MachInt i) = MachFloat (fromInteger i) -int2FloatLit l = pprPanic "int2FloatLit" (ppr l) - -double2IntLit (MachDouble f) = MachInt (truncate f) -double2IntLit l = pprPanic "double2IntLit" (ppr l) -int2DoubleLit (MachInt i) = MachDouble (fromInteger i) -int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) - -float2DoubleLit (MachFloat f) = MachDouble f -float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) -double2FloatLit (MachDouble d) = MachFloat d -double2FloatLit l = pprPanic "double2FloatLit" (ppr l) - -nullAddrLit :: Literal -nullAddrLit = MachNullAddr - -{- - Predicates - ~~~~~~~~~~ --} - --- | True if there is absolutely no penalty to duplicating the literal. --- False principally of strings. --- --- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would --- blow up code sizes. Not only this, it's also unsafe. --- --- Consider a program that wants to traverse a string. One way it might do this --- is to first compute the Addr# pointing to the end of the string, and then, --- starting from the beginning, bump a pointer using eqAddr# to determine the --- end. For instance, --- --- @ --- -- Given pointers to the start and end of a string, count how many zeros --- -- the string contains. --- countZeros :: Addr# -> Addr# -> -> Int --- countZeros start end = go start 0 --- where --- go off n --- | off `addrEq#` end = n --- | otherwise = go (off `plusAddr#` 1) n' --- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1 --- | otherwise = n --- @ --- --- Consider what happens if we considered strings to be trivial (and therefore --- duplicable) and emitted a call like @countZeros "hello"# ("hello"# --- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same --- string, meaning that an iteration like the above would blow up terribly. --- This is what happened in #12757. --- --- Ultimately the solution here is to make primitive strings a bit more --- structured, ensuring that the compiler can't inline in ways that will break --- user code. One approach to this is described in #8472. -litIsTrivial :: Literal -> Bool --- c.f. CoreUtils.exprIsTrivial -litIsTrivial (MachStr _) = False -litIsTrivial (LitInteger {}) = False -litIsTrivial _ = True - --- | True if code space does not go bad if we duplicate this literal --- Currently we treat it just like 'litIsTrivial' -litIsDupable :: DynFlags -> Literal -> Bool --- c.f. CoreUtils.exprIsDupable -litIsDupable _ (MachStr _) = False -litIsDupable dflags (LitInteger i _) = inIntRange dflags i -litIsDupable _ _ = True - -litFitsInChar :: Literal -> Bool -litFitsInChar (MachInt i) = i >= toInteger (ord minBound) - && i <= toInteger (ord maxBound) -litFitsInChar _ = False - -litIsLifted :: Literal -> Bool -litIsLifted (LitInteger {}) = True -litIsLifted _ = False - -{- - Types - ~~~~~ --} - --- | Find the Haskell 'Type' the literal occupies -literalType :: Literal -> Type -literalType MachNullAddr = addrPrimTy -literalType (MachChar _) = charPrimTy -literalType (MachStr _) = addrPrimTy -literalType (MachInt _) = intPrimTy -literalType (MachWord _) = wordPrimTy -literalType (MachInt64 _) = int64PrimTy -literalType (MachWord64 _) = word64PrimTy -literalType (MachFloat _) = floatPrimTy -literalType (MachDouble _) = doublePrimTy -literalType (MachLabel _ _ _) = addrPrimTy -literalType (LitInteger _ t) = t - -absentLiteralOf :: TyCon -> Maybe Literal --- Return a literal of the appropriate primtive --- TyCon, to use as a placeholder when it doesn't matter -absentLiteralOf tc = lookupUFM absent_lits (tyConName tc) - -absent_lits :: UniqFM Literal -absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr) - , (charPrimTyConKey, MachChar 'x') - , (intPrimTyConKey, MachInt 0) - , (int64PrimTyConKey, MachInt64 0) - , (floatPrimTyConKey, MachFloat 0) - , (doublePrimTyConKey, MachDouble 0) - , (wordPrimTyConKey, MachWord 0) - , (word64PrimTyConKey, MachWord64 0) ] - -{- - Comparison - ~~~~~~~~~~ --} - -cmpLit :: Literal -> Literal -> Ordering -cmpLit (MachChar a) (MachChar b) = a `compare` b -cmpLit (MachStr a) (MachStr b) = a `compare` b -cmpLit (MachNullAddr) (MachNullAddr) = EQ -cmpLit (MachInt a) (MachInt b) = a `compare` b -cmpLit (MachWord a) (MachWord b) = a `compare` b -cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b -cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b -cmpLit (MachFloat a) (MachFloat b) = a `compare` b -cmpLit (MachDouble a) (MachDouble b) = a `compare` b -cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b -cmpLit (LitInteger a _) (LitInteger b _) = a `compare` b -cmpLit lit1 lit2 | litTag lit1 < litTag lit2 = LT - | otherwise = GT - -litTag :: Literal -> Int -litTag (MachChar _) = 1 -litTag (MachStr _) = 2 -litTag (MachNullAddr) = 3 -litTag (MachInt _) = 4 -litTag (MachWord _) = 5 -litTag (MachInt64 _) = 6 -litTag (MachWord64 _) = 7 -litTag (MachFloat _) = 8 -litTag (MachDouble _) = 9 -litTag (MachLabel _ _ _) = 10 -litTag (LitInteger {}) = 11 - -{- - Printing - ~~~~~~~~ -* See Note [Printing of literals in Core] --} - -pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc -pprLiteral _ (MachChar c) = pprPrimChar c -pprLiteral _ (MachStr s) = pprHsBytes s -pprLiteral _ (MachNullAddr) = text "__NULL" -pprLiteral _ (MachInt i) = pprPrimInt i -pprLiteral _ (MachInt64 i) = pprPrimInt64 i -pprLiteral _ (MachWord w) = pprPrimWord w -pprLiteral _ (MachWord64 w) = pprPrimWord64 w -pprLiteral _ (MachFloat f) = float (fromRat f) <> primFloatSuffix -pprLiteral _ (MachDouble d) = double (fromRat d) <> primDoubleSuffix -pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i -pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod) - where b = case mb of - Nothing -> pprHsString l - Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) - -pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc --- See Note [Printing of literals in Core]. -pprIntegerVal add_par i | i < 0 = add_par (integer i) - | otherwise = integer i - -{- -Note [Printing of literals in Core] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The function `add_par` is used to wrap parenthesis around negative integers -(`LitInteger`) and labels (`MachLabel`), if they occur in a context requiring -an atomic thing (for example function application). - -Although not all Core literals would be valid Haskell, we are trying to stay -as close as possible to Haskell syntax in the printing of Core, to make it -easier for a Haskell user to read Core. - -To that end: - * We do print parenthesis around negative `LitInteger`, because we print - `LitInteger` using plain number literals (no prefix or suffix), and plain - number literals in Haskell require parenthesis in contexts like function - application (i.e. `1 - -1` is not valid Haskell). - - * We don't print parenthesis around other (negative) literals, because they - aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's - parser). - -Literal Output Output if context requires - an atom (if different) -------- ------- ---------------------- -MachChar 'a'# -MachStr "aaa"# -MachNullAddr "__NULL" -MachInt -1# -MachInt64 -1L# -MachWord 1## -MachWord64 1L## -MachFloat -1.0# -MachDouble -1.0## -LitInteger -1 (-1) -MachLabel "__label" ... ("__label" ...) --} diff --git a/basicTypes/MkId.hs b/basicTypes/MkId.hs deleted file mode 100644 --- a/basicTypes/MkId.hs +++ /dev/null @@ -1,1576 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1998 - - -This module contains definitions for the IdInfo for things that -have a standard form, namely: - -- data constructors -- record selectors -- method and superclass selectors -- primitive operations --} - -{-# LANGUAGE CPP #-} - -module MkId ( - mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, - - mkPrimOpId, mkFCallId, - - wrapNewTypeBody, unwrapNewTypeBody, - wrapFamInstBody, unwrapFamInstScrut, - wrapTypeUnbranchedFamInstBody, unwrapTypeUnbranchedFamInstScrut, - - DataConBoxer(..), mkDataConRep, mkDataConWorkId, - - -- And some particular Ids; see below for why they are wired in - wiredInIds, ghcPrimIds, - unsafeCoerceName, unsafeCoerceId, realWorldPrimId, - voidPrimId, voidArgId, - nullAddrId, seqId, lazyId, lazyIdKey, runRWId, - coercionTokenId, magicDictId, coerceId, - proxyHashId, noinlineId, noinlineIdName, - - -- Re-export error Ids - module PrelRules - ) where - -#include "HsVersions.h" - -import Rules -import TysPrim -import TysWiredIn -import PrelRules -import Type -import FamInstEnv -import Coercion -import TcType -import MkCore -import CoreUtils ( exprType, mkCast ) -import CoreUnfold -import Literal -import TyCon -import CoAxiom -import Class -import NameSet -import Name -import PrimOp -import ForeignCall -import DataCon -import Id -import IdInfo -import Demand -import CoreSyn -import Unique -import UniqSupply -import PrelNames -import BasicTypes hiding ( SuccessFlag(..) ) -import Util -import Pair -import DynFlags -import Outputable -import FastString -import ListSetOps -import qualified GHC.LanguageExtensions as LangExt - -import Data.Maybe ( maybeToList ) - -{- -************************************************************************ -* * -\subsection{Wired in Ids} -* * -************************************************************************ - -Note [Wired-in Ids] -~~~~~~~~~~~~~~~~~~~ -There are several reasons why an Id might appear in the wiredInIds: - -(1) The ghcPrimIds are wired in because they can't be defined in - Haskell at all, although the can be defined in Core. They have - compulsory unfoldings, so they are always inlined and they have - no definition site. Their home module is GHC.Prim, so they - also have a description in primops.txt.pp, where they are called - 'pseudoops'. - -(2) The 'error' function, eRROR_ID, is wired in because we don't yet have - a way to express in an interface file that the result type variable - is 'open'; that is can be unified with an unboxed type - - [The interface file format now carry such information, but there's - no way yet of expressing at the definition site for these - error-reporting functions that they have an 'open' - result type. -- sof 1/99] - -(3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because - the desugarer generates code that mentions them directly, and - (b) for the same reason as eRROR_ID - -(4) lazyId is wired in because the wired-in version overrides the - strictness of the version defined in GHC.Base - -(5) noinlineId is wired in because when we serialize to interfaces - we may insert noinline statements. - -In cases (2-4), the function has a definition in a library module, and -can be called; but the wired-in version means that the details are -never read from that module's interface file; instead, the full definition -is right here. --} - -wiredInIds :: [Id] -wiredInIds - = [lazyId, dollarId, oneShotId, runRWId, noinlineId] - ++ errorIds -- Defined in MkCore - ++ ghcPrimIds - --- These Ids are exported from GHC.Prim -ghcPrimIds :: [Id] -ghcPrimIds - = [ -- These can't be defined in Haskell, but they have - -- perfectly reasonable unfoldings in Core - realWorldPrimId, - voidPrimId, - unsafeCoerceId, - nullAddrId, - seqId, - magicDictId, - coerceId, - proxyHashId - ] - -{- -************************************************************************ -* * -\subsection{Data constructors} -* * -************************************************************************ - -The wrapper for a constructor is an ordinary top-level binding that evaluates -any strict args, unboxes any args that are going to be flattened, and calls -the worker. - -We're going to build a constructor that looks like: - - data (Data a, C b) => T a b = T1 !a !Int b - - T1 = /\ a b -> - \d1::Data a, d2::C b -> - \p q r -> case p of { p -> - case q of { q -> - Con T1 [a,b] [p,q,r]}} - -Notice that - -* d2 is thrown away --- a context in a data decl is used to make sure - one *could* construct dictionaries at the site the constructor - is used, but the dictionary isn't actually used. - -* We have to check that we can construct Data dictionaries for - the types a and Int. Once we've done that we can throw d1 away too. - -* We use (case p of q -> ...) to evaluate p, rather than "seq" because - all that matters is that the arguments are evaluated. "seq" is - very careful to preserve evaluation order, which we don't need - to be here. - - You might think that we could simply give constructors some strictness - info, like PrimOps, and let CoreToStg do the let-to-case transformation. - But we don't do that because in the case of primops and functions strictness - is a *property* not a *requirement*. In the case of constructors we need to - do something active to evaluate the argument. - - Making an explicit case expression allows the simplifier to eliminate - it in the (common) case where the constructor arg is already evaluated. - -Note [Wrappers for data instance tycons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the case of data instances, the wrapper also applies the coercion turning -the representation type into the family instance type to cast the result of -the wrapper. For example, consider the declarations - - data family Map k :: * -> * - data instance Map (a, b) v = MapPair (Map a (Pair b v)) - -The tycon to which the datacon MapPair belongs gets a unique internal -name of the form :R123Map, and we call it the representation tycon. -In contrast, Map is the family tycon (accessible via -tyConFamInst_maybe). A coercion allows you to move between -representation and family type. It is accessible from :R123Map via -tyConFamilyCoercion_maybe and has kind - - Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} - -The wrapper and worker of MapPair get the types - - -- Wrapper - $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v - $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) - - -- Worker - MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v - -This coercion is conditionally applied by wrapFamInstBody. - -It's a bit more complicated if the data instance is a GADT as well! - - data instance T [a] where - T1 :: forall b. b -> T [Maybe b] - -Hence we translate to - - -- Wrapper - $WT1 :: forall b. b -> T [Maybe b] - $WT1 b v = T1 (Maybe b) b (Maybe b) v - `cast` sym (Co7T (Maybe b)) - - -- Worker - T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c - - -- Coercion from family type to representation type - Co7T a :: T [a] ~ :R7T a - -Note [Newtype datacons] -~~~~~~~~~~~~~~~~~~~~~~~ -The "data constructor" for a newtype should always be vanilla. At one -point this wasn't true, because the newtype arising from - class C a => D a -looked like - newtype T:D a = D:D (C a) -so the data constructor for T:C had a single argument, namely the -predicate (C a). But now we treat that as an ordinary argument, not -part of the theta-type, so all is well. - - -************************************************************************ -* * -\subsection{Dictionary selectors} -* * -************************************************************************ - -Selecting a field for a dictionary. If there is just one field, then -there's nothing to do. - -Dictionary selectors may get nested forall-types. Thus: - - class Foo a where - op :: forall b. Ord b => a -> b -> b - -Then the top-level type for op is - - op :: forall a. Foo a => - forall b. Ord b => - a -> b -> b - --} - -mkDictSelId :: Name -- Name of one of the *value* selectors - -- (dictionary superclass or method) - -> Class -> Id -mkDictSelId name clas - = mkGlobalId (ClassOpId clas) name sel_ty info - where - tycon = classTyCon clas - sel_names = map idName (classAllSelIds clas) - new_tycon = isNewTyCon tycon - [data_con] = tyConDataCons tycon - tyvars = dataConUnivTyVarBinders data_con - n_ty_args = length tyvars - arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name - - sel_ty = mkForAllTys tyvars $ - mkFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ - getNth arg_tys val_index - - base_info = noCafIdInfo - `setArityInfo` 1 - `setStrictnessInfo` strict_sig - `setLevityInfoWithType` sel_ty - - info | new_tycon - = base_info `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 - (mkDictSelRhs clas val_index) - -- See Note [Single-method classes] in TcInstDcls - -- for why alwaysInlinePragma - - | otherwise - = base_info `setRuleInfo` mkRuleInfo [rule] - -- Add a magic BuiltinRule, but no unfolding - -- so that the rule is always available to fire. - -- See Note [ClassOp/DFun selection] in TcInstDcls - - -- This is the built-in rule that goes - -- op (dfT d1 d2) ---> opT d1 d2 - rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` - occNameFS (getOccName name) - , ru_fn = name - , ru_nargs = n_ty_args + 1 - , ru_try = dictSelRule val_index n_ty_args } - - -- The strictness signature is of the form U(AAAVAAAA) -> T - -- where the V depends on which item we are selecting - -- It's worth giving one, so that absence info etc is generated - -- even if the selector isn't inlined - - strict_sig = mkClosedStrictSig [arg_dmd] topRes - arg_dmd | new_tycon = evalDmd - | otherwise = mkManyUsedDmd $ - mkProdDmd [ if name == sel_name then evalDmd else absDmd - | sel_name <- sel_names ] - -mkDictSelRhs :: Class - -> Int -- 0-indexed selector among (superclasses ++ methods) - -> CoreExpr -mkDictSelRhs clas val_index - = mkLams tyvars (Lam dict_id rhs_body) - where - tycon = classTyCon clas - new_tycon = isNewTyCon tycon - [data_con] = tyConDataCons tycon - tyvars = dataConUnivTyVars data_con - arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - - the_arg_id = getNth arg_ids val_index - pred = mkClassPred clas (mkTyVarTys tyvars) - dict_id = mkTemplateLocal 1 pred - arg_ids = mkTemplateLocalsNum 2 arg_tys - - rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) (Var dict_id) - | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) - [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)] - -- varToCoreExpr needed for equality superclass selectors - -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } - -dictSelRule :: Int -> Arity -> RuleFun --- Tries to persuade the argument to look like a constructor --- application, using exprIsConApp_maybe, and then selects --- from it --- sel_i t1..tk (D t1..tk op1 ... opm) = opi --- -dictSelRule val_index n_ty_args _ id_unf _ args - | (dict_arg : _) <- drop n_ty_args args - , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg - = Just (getNth con_args val_index) - | otherwise - = Nothing - -{- -************************************************************************ -* * - Data constructors -* * -************************************************************************ --} - -mkDataConWorkId :: Name -> DataCon -> Id -mkDataConWorkId wkr_name data_con - | isNewTyCon tycon - = mkGlobalId (DataConWrapId data_con) wkr_name nt_wrap_ty nt_work_info - | otherwise - = mkGlobalId (DataConWorkId data_con) wkr_name alg_wkr_ty wkr_info - - where - tycon = dataConTyCon data_con - - ----------- Workers for data types -------------- - alg_wkr_ty = dataConRepType data_con - wkr_arity = dataConRepArity data_con - wkr_info = noCafIdInfo - `setArityInfo` wkr_arity - `setStrictnessInfo` wkr_sig - `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, - -- even if arity = 0 - `setLevityInfoWithType` alg_wkr_ty - -- NB: unboxed tuples have workers, so we can't use - -- setNeverLevPoly - - wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con) - -- Note [Data-con worker strictness] - -- Notice that we do *not* say the worker Id is strict - -- even if the data constructor is declared strict - -- e.g. data T = MkT !(Int,Int) - -- Why? Because the *wrapper* $WMkT is strict (and its unfolding has - -- case expressions that do the evals) but the *worker* MkT itself is - -- not. If we pretend it is strict then when we see - -- case x of y -> MkT y - -- the simplifier thinks that y is "sure to be evaluated" (because - -- the worker MkT is strict) and drops the case. No, the workerId - -- MkT is not strict. - -- - -- However, the worker does have StrictnessMarks. When the simplifier - -- sees a pattern - -- case e of MkT x -> ... - -- it uses the dataConRepStrictness of MkT to mark x as evaluated; - -- but that's fine... dataConRepStrictness comes from the data con - -- not from the worker Id. - - ----------- Workers for newtypes -------------- - (nt_tvs, _, nt_arg_tys, _) = dataConSig data_con - res_ty_args = mkTyVarTys nt_tvs - nt_wrap_ty = dataConUserType data_con - nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo - `setArityInfo` 1 -- Arity 1 - `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` newtype_unf - `setLevityInfoWithType` nt_wrap_ty - id_arg1 = mkTemplateLocal 1 (head nt_arg_tys) - newtype_unf = ASSERT2( isVanillaDataCon data_con && - isSingleton nt_arg_tys, ppr data_con ) - -- Note [Newtype datacons] - mkCompulsoryUnfolding $ - mkLams nt_tvs $ Lam id_arg1 $ - wrapNewTypeBody tycon res_ty_args (Var id_arg1) - -dataConCPR :: DataCon -> DmdResult -dataConCPR con - | isDataTyCon tycon -- Real data types only; that is, - -- not unboxed tuples or newtypes - , null (dataConExTyVars con) -- No existentials - , wkr_arity > 0 - , wkr_arity <= mAX_CPR_SIZE - = if is_prod then vanillaCprProdRes (dataConRepArity con) - else cprSumRes (dataConTag con) - | otherwise - = topRes - where - is_prod = isProductTyCon tycon - tycon = dataConTyCon con - wkr_arity = dataConRepArity con - - mAX_CPR_SIZE :: Arity - mAX_CPR_SIZE = 10 - -- We do not treat very big tuples as CPR-ish: - -- a) for a start we get into trouble because there aren't - -- "enough" unboxed tuple types (a tiresome restriction, - -- but hard to fix), - -- b) more importantly, big unboxed tuples get returned mainly - -- on the stack, and are often then allocated in the heap - -- by the caller. So doing CPR for them may in fact make - -- things worse. - -{- -------------------------------------------------- --- Data constructor representation --- --- This is where we decide how to wrap/unwrap the --- constructor fields --- --------------------------------------------------- --} - -type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) - -- Unbox: bind rep vars by decomposing src var - -data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) - -- Box: build src arg using these rep vars - --- | Data Constructor Boxer -newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) - -- Bind these src-level vars, returning the - -- rep-level vars to bind in the pattern - -{- -Note [Inline partially-applied constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We allow the wrapper to inline when partially applied to avoid -boxing values unnecessarily. For example, consider - - data Foo a = Foo !Int a - - instance Traversable Foo where - traverse f (Foo i a) = Foo i <$> f a - -This desugars to - - traverse f foo = case foo of - Foo i# a -> let i = I# i# - in map ($WFoo i) (f a) - -If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`. -But if we inline the wrapper, we get - - map (\a. case i of I# i# a -> Foo i# a) (f a) - -and now case-of-known-constructor eliminates the redundant allocation. --} - -mkDataConRep :: DynFlags - -> FamInstEnvs - -> Name - -> Maybe [HsImplBang] - -- See Note [Bangs on imported data constructors] - -> DataCon - -> UniqSM DataConRep -mkDataConRep dflags fam_envs wrap_name mb_bangs data_con - | not wrapper_reqd - = return NoDataConRep - - | otherwise - = do { wrap_args <- mapM newLocal wrap_arg_tys - ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) - initial_wrap_app - - ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info - wrap_info = noCafIdInfo - `setArityInfo` wrap_arity - -- It's important to specify the arity, so that partial - -- applications are treated as values - `setInlinePragInfo` wrap_prag - `setUnfoldingInfo` wrap_unf - `setStrictnessInfo` wrap_sig - -- We need to get the CAF info right here because TidyPgm - -- does not tidy the IdInfo of implicit bindings (like the wrapper) - -- so it not make sure that the CAF info is sane - `setNeverLevPoly` wrap_ty - - wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con) - - wrap_arg_dmds = - replicate (length theta) topDmd ++ map mk_dmd arg_ibangs - -- Don't forget the dictionary arguments when building - -- the strictness signature (#14290). - - mk_dmd str | isBanged str = evalDmd - | otherwise = topDmd - - wrap_prag = alwaysInlinePragma `setInlinePragmaActivation` - ActiveAfter NoSourceText 2 - -- See Note [Activation for data constructor wrappers] - - -- The wrapper will usually be inlined (see wrap_unf), so its - -- strictness and CPR info is usually irrelevant. But this is - -- not always the case; GHC may choose not to inline it. In - -- particular, the wrapper constructor is not inlined inside - -- an INLINE rhs or when it is not applied to any arguments. - -- See Note [Inline partially-applied constructor wrappers] - -- Passing Nothing here allows the wrapper to inline when - -- unsaturated. - wrap_unf = mkInlineUnfolding wrap_rhs - wrap_tvs = (univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs - wrap_rhs = mkLams wrap_tvs $ - mkLams wrap_args $ - wrapFamInstBody tycon res_ty_args $ - wrap_body - - ; return (DCR { dcr_wrap_id = wrap_id - , dcr_boxer = mk_boxer boxers - , dcr_arg_tys = rep_tys - , dcr_stricts = rep_strs - , dcr_bangs = arg_ibangs }) } - - where - (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) - = dataConFullSig data_con - res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs - - tycon = dataConTyCon data_con -- The representation TyCon (not family) - wrap_ty = dataConUserType data_con - ev_tys = eqSpecPreds eq_spec ++ theta - all_arg_tys = ev_tys ++ orig_arg_tys - ev_ibangs = map (const HsLazy) ev_tys - orig_bangs = dataConSrcBangs data_con - - wrap_arg_tys = theta ++ orig_arg_tys - wrap_arity = length wrap_arg_tys - -- The wrap_args are the arguments *other than* the eq_spec - -- Because we are going to apply the eq_spec args manually in the - -- wrapper - - arg_ibangs = - case mb_bangs of - Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs) - orig_arg_tys orig_bangs - Just bangs -> bangs - - (rep_tys_w_strs, wrappers) - = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs)) - - (unboxers, boxers) = unzip wrappers - (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) - - wrapper_reqd = not (isNewTyCon tycon) -- Newtypes have only a worker - && (any isBanged (ev_ibangs ++ arg_ibangs) - -- Some forcing/unboxing (includes eq_spec) - || isFamInstTyCon tycon -- Cast result - || (not $ null eq_spec)) -- GADT - - initial_wrap_app = Var (dataConWorkId data_con) - `mkTyApps` res_ty_args - `mkVarApps` ex_tvs - `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec - - mk_boxer :: [Boxer] -> DataConBoxer - mk_boxer boxers = DCB (\ ty_args src_vars -> - do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars - subst1 = zipTvSubst univ_tvs ty_args - subst2 = extendTvSubstList subst1 ex_tvs - (mkTyVarTys ex_vars) - ; (rep_ids, binds) <- go subst2 boxers term_vars - ; return (ex_vars ++ rep_ids, binds) } ) - - go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) - go subst (UnitBox : boxers) (src_var : src_vars) - = do { (rep_ids2, binds) <- go subst boxers src_vars - ; return (src_var : rep_ids2, binds) } - go subst (Boxer boxer : boxers) (src_var : src_vars) - = do { (rep_ids1, arg) <- boxer subst - ; (rep_ids2, binds) <- go subst boxers src_vars - ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } - go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) - - mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr - mk_rep_app [] con_app - = return con_app - mk_rep_app ((wrap_arg, unboxer) : prs) con_app - = do { (rep_ids, unbox_fn) <- unboxer wrap_arg - ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) - ; return (unbox_fn expr) } - -{- Note [Activation for data constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Activation on a data constructor wrapper allows it to inline in -Phase 2 and later (1, 0). But not in the InitialPhase. That gives -rewrite rules a chance to fire (in the InitialPhase) if they mention -a data constructor on the left - RULE "foo" f (K a b) = ... -Since the LHS of rules are simplified with InitialPhase, we won't -inline the wrapper on the LHS either. - -People have asked for this before, but now that even the InitialPhase -does some inlining, it has become important. - - -Note [Bangs on imported data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs -from imported modules. - -- Nothing <=> use HsSrcBangs -- Just bangs <=> use HsImplBangs - -For imported types we can't work it all out from the HsSrcBangs, -because we want to be very sure to follow what the original module -(where the data type was declared) decided, and that depends on what -flags were enabled when it was compiled. So we record the decisions in -the interface file. - -The HsImplBangs passed are in 1-1 correspondence with the -dataConOrigArgTys of the DataCon. - --} - -------------------------- -newLocal :: Type -> UniqSM Var -newLocal ty = do { uniq <- getUniqueM - ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) } - --- | Unpack/Strictness decisions from source module -dataConSrcToImplBang - :: DynFlags - -> FamInstEnvs - -> Type - -> HsSrcBang - -> HsImplBang - -dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang ann unpk NoSrcStrict) - | xopt LangExt.StrictData dflags -- StrictData => strict field - = dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang ann unpk SrcStrict) - | otherwise -- no StrictData => lazy field - = HsLazy - -dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) - = HsLazy - -dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang _ unpk_prag SrcStrict) - | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas - -- Don't unpack if we aren't optimising; rather arbitrarily, - -- we use -fomit-iface-pragmas as the indication - , let mb_co = topNormaliseType_maybe fam_envs arg_ty - -- Unwrap type families and newtypes - arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } - , isUnpackableType dflags fam_envs arg_ty' - , (rep_tys, _) <- dataConArgUnpack arg_ty' - , case unpk_prag of - NoSrcUnpack -> - gopt Opt_UnboxStrictFields dflags - || (gopt Opt_UnboxSmallStrictFields dflags - && length rep_tys <= 1) -- See Note [Unpack one-wide fields] - srcUnpack -> isSrcUnpacked srcUnpack - = case mb_co of - Nothing -> HsUnpack Nothing - Just (co,_) -> HsUnpack (Just co) - - | otherwise -- Record the strict-but-no-unpack decision - = HsStrict - - --- | Wrappers/Workers and representation following Unpack/Strictness --- decisions -dataConArgRep - :: Type - -> HsImplBang - -> ([(Type,StrictnessMark)] -- Rep types - ,(Unboxer,Boxer)) - -dataConArgRep arg_ty HsLazy - = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) - -dataConArgRep arg_ty HsStrict - = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) - -dataConArgRep arg_ty (HsUnpack Nothing) - | (rep_tys, wrappers) <- dataConArgUnpack arg_ty - = (rep_tys, wrappers) - -dataConArgRep _ (HsUnpack (Just co)) - | let co_rep_ty = pSnd (coercionKind co) - , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty - = (rep_tys, wrapCo co co_rep_ty wrappers) - - -------------------------- -wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) -wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty - = (unboxer, boxer) - where - unboxer arg_id = do { rep_id <- newLocal rep_ty - ; (rep_ids, rep_fn) <- unbox_rep rep_id - ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) - ; return (rep_ids, Let co_bind . rep_fn) } - boxer = Boxer $ \ subst -> - do { (rep_ids, rep_expr) - <- case box_rep of - UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) - ; return ([rep_id], Var rep_id) } - Boxer boxer -> boxer subst - ; let sco = substCoUnchecked subst co - ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } - ------------------------- -seqUnboxer :: Unboxer -seqUnboxer v = return ([v], \e -> Case (Var v) v (exprType e) [(DEFAULT, [], e)]) - -unitUnboxer :: Unboxer -unitUnboxer v = return ([v], \e -> e) - -unitBoxer :: Boxer -unitBoxer = UnitBox - -------------------------- -dataConArgUnpack - :: Type - -> ( [(Type, StrictnessMark)] -- Rep types - , (Unboxer, Boxer) ) - -dataConArgUnpack arg_ty - | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty - , Just con <- tyConSingleAlgDataCon_maybe tc - -- NB: check for an *algebraic* data type - -- A recursive newtype might mean that - -- 'arg_ty' is a newtype - , let rep_tys = dataConInstArgTys con tc_args - = ASSERT( isVanillaDataCon con ) - ( rep_tys `zip` dataConRepStrictness con - ,( \ arg_id -> - do { rep_ids <- mapM newLocal rep_tys - ; let unbox_fn body - = Case (Var arg_id) arg_id (exprType body) - [(DataAlt con, rep_ids, body)] - ; return (rep_ids, unbox_fn) } - , Boxer $ \ subst -> - do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys - ; return (rep_ids, Var (dataConWorkId con) - `mkTyApps` (substTysUnchecked subst tc_args) - `mkVarApps` rep_ids ) } ) ) - | otherwise - = pprPanic "dataConArgUnpack" (ppr arg_ty) - -- An interface file specified Unpacked, but we couldn't unpack it - -isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool --- True if we can unpack the UNPACK the argument type --- See Note [Recursive unboxing] --- We look "deeply" inside rather than relying on the DataCons --- we encounter on the way, because otherwise we might well --- end up relying on ourselves! -isUnpackableType dflags fam_envs ty - | Just (tc, _) <- splitTyConApp_maybe ty - , Just con <- tyConSingleAlgDataCon_maybe tc - , isVanillaDataCon con - = ok_con_args (unitNameSet (getName tc)) con - | otherwise - = False - where - ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty - where - norm_ty = topNormaliseType fam_envs ty - ok_ty tcs ty - | Just (tc, _) <- splitTyConApp_maybe ty - , let tc_name = getName tc - = not (tc_name `elemNameSet` tcs) - && case tyConSingleAlgDataCon_maybe tc of - Just con | isVanillaDataCon con - -> ok_con_args (tcs `extendNameSet` getName tc) con - _ -> True - | otherwise - = True - - ok_con_args tcs con - = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConSrcBangs con) - -- NB: dataConSrcBangs gives the *user* request; - -- We'd get a black hole if we used dataConImplBangs - - attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) - = xopt LangExt.StrictData dflags - attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) - = True - attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict) - = True -- Be conservative - attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict) - = xopt LangExt.StrictData dflags -- Be conservative - attempt_unpack _ = False - -{- -Note [Unpack one-wide fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The flag UnboxSmallStrictFields ensures that any field that can -(safely) be unboxed to a word-sized unboxed field, should be so unboxed. -For example: - - data A = A Int# - newtype B = B A - data C = C !B - data D = D !C - data E = E !() - data F = F !D - data G = G !F !F - -All of these should have an Int# as their representation, except -G which should have two Int#s. - -However - - data T = T !(S Int) - data S = S !a - -Here we can represent T with an Int#. - -Note [Recursive unboxing] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data R = MkR {-# UNPACK #-} !S Int - data S = MkS {-# UNPACK #-} !Int -The representation arguments of MkR are the *representation* arguments -of S (plus Int); the rep args of MkS are Int#. This is all fine. - -But be careful not to try to unbox this! - data T = MkT {-# UNPACK #-} !T Int -Because then we'd get an infinite number of arguments. - -Here is a more complicated case: - data S = MkS {-# UNPACK #-} !T Int - data T = MkT {-# UNPACK #-} !S Int -Each of S and T must decide independently whether to unpack -and they had better not both say yes. So they must both say no. - -Also behave conservatively when there is no UNPACK pragma - data T = MkS !T Int -with -funbox-strict-fields or -funbox-small-strict-fields -we need to behave as if there was an UNPACK pragma there. - -But it's the *argument* type that matters. This is fine: - data S = MkS S !Int -because Int is non-recursive. - -************************************************************************ -* * - Wrapping and unwrapping newtypes and type families -* * -************************************************************************ --} - -wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr --- The wrapper for the data constructor for a newtype looks like this: --- newtype T a = MkT (a,Int) --- MkT :: forall a. (a,Int) -> T a --- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) --- where CoT is the coercion TyCon associated with the newtype --- --- The call (wrapNewTypeBody T [a] e) returns the --- body of the wrapper, namely --- e `cast` (CoT [a]) --- --- If a coercion constructor is provided in the newtype, then we use --- it, otherwise the wrap/unwrap are both no-ops --- --- If the we are dealing with a newtype *instance*, we have a second coercion --- identifying the family instance with the constructor of the newtype --- instance. This coercion is applied in any case (ie, composed with the --- coercion constructor of the newtype or applied by itself). - -wrapNewTypeBody tycon args result_expr - = ASSERT( isNewTyCon tycon ) - wrapFamInstBody tycon args $ - mkCast result_expr (mkSymCo co) - where - co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] - --- When unwrapping, we do *not* apply any family coercion, because this will --- be done via a CoPat by the type checker. We have to do it this way as --- computing the right type arguments for the coercion requires more than just --- a spliting operation (cf, TcPat.tcConPat). - -unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -unwrapNewTypeBody tycon args result_expr - = ASSERT( isNewTyCon tycon ) - mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) - --- If the type constructor is a representation type of a data instance, wrap --- the expression into a cast adjusting the expression type, which is an --- instance of the representation type, to the corresponding instance of the --- family instance type. --- See Note [Wrappers for data instance tycons] -wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -wrapFamInstBody tycon args body - | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args [])) - | otherwise - = body - --- Same as `wrapFamInstBody`, but for type family instances, which are --- represented by a `CoAxiom`, and not a `TyCon` -wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> [Coercion] - -> CoreExpr -> CoreExpr -wrapTypeFamInstBody axiom ind args cos body - = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args cos)) - -wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> [Coercion] - -> CoreExpr -> CoreExpr -wrapTypeUnbranchedFamInstBody axiom - = wrapTypeFamInstBody axiom 0 - -unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr -unwrapFamInstScrut tycon args scrut - | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args []) -- data instances only - | otherwise - = scrut - -unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> [Coercion] - -> CoreExpr -> CoreExpr -unwrapTypeFamInstScrut axiom ind args cos scrut - = mkCast scrut (mkAxInstCo Representational axiom ind args cos) - -unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> [Coercion] - -> CoreExpr -> CoreExpr -unwrapTypeUnbranchedFamInstScrut axiom - = unwrapTypeFamInstScrut axiom 0 - -{- -************************************************************************ -* * -\subsection{Primitive operations} -* * -************************************************************************ --} - -mkPrimOpId :: PrimOp -> Id -mkPrimOpId prim_op - = id - where - (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op - ty = mkSpecForAllTys tyvars (mkFunTys arg_tys res_ty) - name = mkWiredInName gHC_PRIM (primOpOcc prim_op) - (mkPrimOpIdUnique (primOpTag prim_op)) - (AnId id) UserSyntax - id = mkGlobalId (PrimOpId prim_op) name ty info - - info = noCafIdInfo - `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) - `setArityInfo` arity - `setStrictnessInfo` strict_sig - `setInlinePragInfo` neverInlinePragma - `setLevityInfoWithType` res_ty - -- We give PrimOps a NOINLINE pragma so that we don't - -- get silly warnings from Desugar.dsRule (the inline_shadows_rule - -- test) about a RULE conflicting with a possible inlining - -- cf Trac #7287 - --- For each ccall we manufacture a separate CCallOpId, giving it --- a fresh unique, a type that is correct for this particular ccall, --- and a CCall structure that gives the correct details about calling --- convention etc. --- --- The *name* of this Id is a local name whose OccName gives the full --- details of the ccall, type and all. This means that the interface --- file reader can reconstruct a suitable Id - -mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id -mkFCallId dflags uniq fcall ty - = ASSERT( noFreeVarsOfType ty ) - -- A CCallOpId should have no free type variables; - -- when doing substitutions won't substitute over it - mkGlobalId (FCallId fcall) name ty info - where - occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty)) - -- The "occurrence name" of a ccall is the full info about the - -- ccall; it is encoded, but may have embedded spaces etc! - - name = mkFCallName uniq occ_str - - info = noCafIdInfo - `setArityInfo` arity - `setStrictnessInfo` strict_sig - `setLevityInfoWithType` ty - - (bndrs, _) = tcSplitPiTys ty - arity = count isAnonTyBinder bndrs - strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes - -- the call does not claim to be strict in its arguments, since they - -- may be lifted (foreign import prim) and the called code doesn't - -- necessarily force them. See Trac #11076. -{- -************************************************************************ -* * -\subsection{DictFuns and default methods} -* * -************************************************************************ - -Note [Dict funs and default methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Dict funs and default methods are *not* ImplicitIds. Their definition -involves user-written code, so we can't figure out their strictness etc -based on fixed info, as we can for constructors and record selectors (say). - -NB: See also Note [Exported LocalIds] in Id --} - -mkDictFunId :: Name -- Name to use for the dict fun; - -> [TyVar] - -> ThetaType - -> Class - -> [Type] - -> Id --- Implements the DFun Superclass Invariant (see TcInstDcls) --- See Note [Dict funs and default methods] - -mkDictFunId dfun_name tvs theta clas tys - = mkExportedLocalId (DFunId is_nt) - dfun_name - dfun_ty - where - is_nt = isNewTyCon (classTyCon clas) - dfun_ty = mkDictFunTy tvs theta clas tys - -mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type -mkDictFunTy tvs theta clas tys - = mkSpecSigmaTy tvs theta (mkClassPred clas tys) - -{- -************************************************************************ -* * -\subsection{Un-definable} -* * -************************************************************************ - -These Ids can't be defined in Haskell. They could be defined in -unfoldings in the wired-in GHC.Prim interface file, but we'd have to -ensure that they were definitely, definitely inlined, because there is -no curried identifier for them. That's what mkCompulsoryUnfolding -does. If we had a way to get a compulsory unfolding from an interface -file, we could do that, but we don't right now. - -unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that -just gets expanded into a type coercion wherever it occurs. Hence we -add it as a built-in Id with an unfolding here. - -The type variables we use here are "open" type variables: this means -they can unify with both unlifted and lifted types. Hence we provide -another gun with which to shoot yourself in the foot. --} - -lazyIdName, unsafeCoerceName, nullAddrName, seqName, - realWorldName, voidPrimIdName, coercionTokenName, - magicDictName, coerceName, proxyName, dollarName, oneShotName, - runRWName, noinlineIdName :: Name -unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId -nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId -seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId -realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId -voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId -lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId -coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId -magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId -coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId -proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId -dollarName = mkWiredInIdName gHC_BASE (fsLit "$") dollarIdKey dollarId -oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId -runRWName = mkWiredInIdName gHC_MAGIC (fsLit "runRW#") runRWKey runRWId -noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId - -dollarId :: Id -- Note [dollarId magic] -dollarId = pcMiscPrelId dollarName ty - (noCafIdInfo `setUnfoldingInfo` unf) - where - fun_ty = mkFunTy alphaTy openBetaTy - ty = mkSpecForAllTys [runtimeRep2TyVar, alphaTyVar, openBetaTyVar] $ - mkFunTy fun_ty fun_ty - unf = mkInlineUnfoldingWithArity 2 rhs - [f,x] = mkTemplateLocals [fun_ty, alphaTy] - rhs = mkLams [runtimeRep2TyVar, alphaTyVar, openBetaTyVar, f, x] $ - App (Var f) (Var x) - ------------------------------------------------- -proxyHashId :: Id -proxyHashId - = pcMiscPrelId proxyName ty - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setNeverLevPoly` ty ) - where - -- proxy# :: forall k (a:k). Proxy# k a - bndrs = mkTemplateKiTyVars [liftedTypeKind] (\ks -> ks) - [k,t] = mkTyVarTys bndrs - ty = mkSpecForAllTys bndrs (mkProxyPrimTy k t) - ------------------------------------------------- -unsafeCoerceId :: Id -unsafeCoerceId - = pcMiscPrelId unsafeCoerceName ty info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - - -- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) - -- (a :: TYPE r1) (b :: TYPE r2). - -- a -> b - bndrs = mkTemplateKiTyVars [runtimeRepTy, runtimeRepTy] - (\ks -> map tYPE ks) - - [_, _, a, b] = mkTyVarTys bndrs - - ty = mkSpecForAllTys bndrs (mkFunTy a b) - - [x] = mkTemplateLocals [a] - rhs = mkLams (bndrs ++ [x]) $ - Cast (Var x) (mkUnsafeCo Representational a b) - ------------------------------------------------- -nullAddrId :: Id --- nullAddr# :: Addr# --- The reason it is here is because we don't provide --- a way to write this literal in Haskell. -nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) - `setNeverLevPoly` addrPrimTy - ------------------------------------------------- -seqId :: Id -- See Note [seqId magic] -seqId = pcMiscPrelId seqName ty info - where - info = noCafIdInfo `setInlinePragInfo` inline_prag - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - `setNeverLevPoly` ty - - inline_prag - = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter - NoSourceText 0 - -- Make 'seq' not inline-always, so that simpleOptExpr - -- (see CoreSubst.simple_app) won't inline 'seq' on the - -- LHS of rules. That way we can have rules for 'seq'; - -- see Note [seqId magic] - - ty = mkSpecForAllTys [alphaTyVar,betaTyVar] - (mkFunTy alphaTy (mkFunTy betaTy betaTy)) - - [x,y] = mkTemplateLocals [alphaTy, betaTy] - rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)]) - ------------------------------------------------- -lazyId :: Id -- See Note [lazyId magic] -lazyId = pcMiscPrelId lazyIdName ty info - where - info = noCafIdInfo `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) - -noinlineId :: Id -- See Note [noinlineId magic] -noinlineId = pcMiscPrelId noinlineIdName ty info - where - info = noCafIdInfo `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) - -oneShotId :: Id -- See Note [The oneShot function] -oneShotId = pcMiscPrelId oneShotName ty info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar ] - (mkFunTy fun_ty fun_ty) - fun_ty = mkFunTy openAlphaTy openBetaTy - [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] - x' = setOneShotLambda x - rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar - , body, x'] $ - Var body `App` Var x - -runRWId :: Id -- See Note [runRW magic] in this module -runRWId = pcMiscPrelId runRWName ty info - where - info = noCafIdInfo `setInlinePragInfo` neverInlinePragma - `setStrictnessInfo` strict_sig - `setArityInfo` 1 - strict_sig = mkClosedStrictSig [strictApply1Dmd] topRes - -- Important to express its strictness, - -- since it is not inlined until CorePrep - -- Also see Note [runRW arg] in CorePrep - - -- State# RealWorld - stateRW = mkTyConApp statePrimTyCon [realWorldTy] - -- o - ret_ty = openAlphaTy - -- State# RealWorld -> o - arg_ty = stateRW `mkFunTy` ret_ty - -- (State# RealWorld -> o) -> o - ty = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $ - arg_ty `mkFunTy` ret_ty - --------------------------------------------------------------------------------- -magicDictId :: Id -- See Note [magicDictId magic] -magicDictId = pcMiscPrelId magicDictName ty info - where - info = noCafIdInfo `setInlinePragInfo` neverInlinePragma - `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] alphaTy - --------------------------------------------------------------------------------- - -coerceId :: Id -coerceId = pcMiscPrelId coerceName ty info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - `setNeverLevPoly` ty - eqRTy = mkTyConApp coercibleTyCon [ liftedTypeKind - , alphaTy, betaTy ] - eqRPrimTy = mkTyConApp eqReprPrimTyCon [ liftedTypeKind - , liftedTypeKind - , alphaTy, betaTy ] - ty = mkSpecForAllTys [alphaTyVar, betaTyVar] $ - mkFunTys [eqRTy, alphaTy] betaTy - - [eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy] - rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $ - mkWildCase (Var eqR) eqRTy betaTy $ - [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] - -{- -Note [dollarId magic] -~~~~~~~~~~~~~~~~~~~~~ -The only reason that ($) is wired in is so that its type can be - forall (a:*, b:Open). (a->b) -> a -> b -That is, the return type can be unboxed. E.g. this is OK - foo $ True where foo :: Bool -> Int# -because ($) doesn't inspect or move the result of the call to foo. -See Trac #8739. - -There is a special typing rule for ($) in TcExpr, so the type of ($) -isn't looked at there, BUT Lint subsequently (and rightly) complains -if sees ($) applied to Int# (say), unless we give it a wired-in type -as we do here. - -Note [Unsafe coerce magic] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We define a *primitive* - GHC.Prim.unsafeCoerce# -and then in the base library we define the ordinary function - Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b - unsafeCoerce x = unsafeCoerce# x - -Notice that unsafeCoerce has a civilized (albeit still dangerous) -polymorphic type, whose type args have kind *. So you can't use it on -unboxed values (unsafeCoerce 3#). - -In contrast unsafeCoerce# is even more dangerous because you *can* use -it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is - forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a: TYPE r1) (b: TYPE r2). a -> b - -Note [seqId magic] -~~~~~~~~~~~~~~~~~~ -'GHC.Prim.seq' is special in several ways. - -a) In source Haskell its second arg can have an unboxed type - x `seq` (v +# w) - But see Note [Typing rule for seq] in TcExpr, which - explains why we give seq itself an ordinary type - seq :: forall a b. a -> b -> b - and treat it as a language construct from a typing point of view. - -b) Its fixity is set in LoadIface.ghcPrimIface - -c) It has quite a bit of desugaring magic. - See DsUtils.hs Note [Desugaring seq (1)] and (2) and (3) - -d) There is some special rule handing: Note [User-defined RULES for seq] - -Note [User-defined RULES for seq] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Roman found situations where he had - case (f n) of _ -> e -where he knew that f (which was strict in n) would terminate if n did. -Notice that the result of (f n) is discarded. So it makes sense to -transform to - case n of _ -> e - -Rather than attempt some general analysis to support this, I've added -enough support that you can do this using a rewrite rule: - - RULE "f/seq" forall n. seq (f n) = seq n - -You write that rule. When GHC sees a case expression that discards -its result, it mentally transforms it to a call to 'seq' and looks for -a RULE. (This is done in Simplify.trySeqRules.) As usual, the -correctness of the rule is up to you. - -VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. -If we wrote - RULE "f/seq" forall n e. seq (f n) e = seq n e -with rule arity 2, then two bad things would happen: - - - The magical desugaring done in Note [seqId magic] item (c) - for saturated application of 'seq' would turn the LHS into - a case expression! - - - The code in Simplify.rebuildCase would need to actually supply - the value argument, which turns out to be awkward. - -Note [lazyId magic] -~~~~~~~~~~~~~~~~~~~ -lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) - -'lazy' is used to make sure that a sub-expression, and its free variables, -are truly used call-by-need, with no code motion. Key examples: - -* pseq: pseq a b = a `seq` lazy b - We want to make sure that the free vars of 'b' are not evaluated - before 'a', even though the expression is plainly strict in 'b'. - -* catch: catch a b = catch# (lazy a) b - Again, it's clear that 'a' will be evaluated strictly (and indeed - applied to a state token) but we want to make sure that any exceptions - arising from the evaluation of 'a' are caught by the catch (see - Trac #11555). - -Implementing 'lazy' is a bit tricky: - -* It must not have a strictness signature: by being a built-in Id, - all the info about lazyId comes from here, not from GHC.Base.hi. - This is important, because the strictness analyser will spot it as - strict! - -* It must not have an unfolding: it gets "inlined" by a HACK in - CorePrep. It's very important to do this inlining *after* unfoldings - are exposed in the interface file. Otherwise, the unfolding for - (say) pseq in the interface file will not mention 'lazy', so if we - inline 'pseq' we'll totally miss the very thing that 'lazy' was - there for in the first place. See Trac #3259 for a real world - example. - -* Suppose CorePrep sees (catch# (lazy e) b). At all costs we must - avoid using call by value here: - case e of r -> catch# r b - Avoiding that is the whole point of 'lazy'. So in CorePrep (which - generate the 'case' expression for a call-by-value call) we must - spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let' - instead. - -* lazyId is defined in GHC.Base, so we don't *have* to inline it. If it - appears un-applied, we'll end up just calling it. - -Note [noinlineId magic] -~~~~~~~~~~~~~~~~~~~~~~~ -noinline :: forall a. a -> a - -'noinline' is used to make sure that a function f is never inlined, -e.g., as in 'noinline f x'. Ordinarily, the identity function with NOINLINE -could be used to achieve this effect; however, this has the unfortunate -result of leaving a (useless) call to noinline at runtime. So we have -a little bit of magic to optimize away 'noinline' after we are done -running the simplifier. - -'noinline' needs to be wired-in because it gets inserted automatically -when we serialize an expression to the interface format, and we DON'T -want use its fingerprints. - - -Note [runRW magic] -~~~~~~~~~~~~~~~~~~ -Some definitions, for instance @runST@, must have careful control over float out -of the bindings in their body. Consider this use of @runST@, - - f x = runST ( \ s -> let (a, s') = newArray# 100 [] s - (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' ) - -If we inline @runST@, we'll get: - - f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} - (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' - -And now if we allow the @newArray#@ binding to float out to become a CAF, -we end up with a result that is totally and utterly wrong: - - f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! - in \ x -> - let (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' - -All calls to @f@ will share a {\em single} array! Clearly this is nonsense and -must be prevented. - -This is what @runRW#@ gives us: by being inlined extremely late in the -optimization (right before lowering to STG, in CorePrep), we can ensure that -no further floating will occur. This allows us to safely inline things like -@runST@, which are otherwise needlessly expensive (see #10678 and #5916). - -While the definition of @GHC.Magic.runRW#@, we override its type in @MkId@ -to be open-kinded, - - runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) - => (State# RealWorld -> (# State# RealWorld, o #)) - -> (# State# RealWorld, o #) - - -Note [The oneShot function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the context of making left-folds fuse somewhat okish (see ticket #7994 -and Note [Left folds via right fold]) it was determined that it would be useful -if library authors could explicitly tell the compiler that a certain lambda is -called at most once. The oneShot function allows that. - -'oneShot' is open kinded, i.e. the type variables can refer to unlifted -types as well (Trac #10744); e.g. - oneShot (\x:Int# -> x +# 1#) - -Like most magic functions it has a compulsary unfolding, so there is no need -for a real definition somewhere. We have one in GHC.Magic for the convenience -of putting the documentation there. - -It uses `setOneShotLambda` on the lambda's binder. That is the whole magic: - -A typical call looks like - oneShot (\y. e) -after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get - (\f \x[oneshot]. f x) (\y. e) - --> \x[oneshot]. ((\y.e) x) - --> \x[oneshot] e[x/y] -which is what we want. - -It is only effective if the one-shot info survives as long as possible; in -particular it must make it into the interface in unfoldings. See Note [Preserve -OneShotInfo] in CoreTidy. - -Also see https://ghc.haskell.org/trac/ghc/wiki/OneShot. - - -Note [magicDictId magic] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The identifier `magicDict` is just a place-holder, which is used to -implement a primitve that we cannot define in Haskell but we can write -in Core. It is declared with a place-holder type: - - magicDict :: forall a. a - -The intention is that the identifier will be used in a very specific way, -to create dictionaries for classes with a single method. Consider a class -like this: - - class C a where - f :: T a - -We are going to use `magicDict`, in conjunction with a built-in Prelude -rule, to cast values of type `T a` into dictionaries for `C a`. To do -this, we define a function like this in the library: - - data WrapC a b = WrapC (C a => Proxy a -> b) - - withT :: (C a => Proxy a -> b) - -> T a -> Proxy a -> b - withT f x y = magicDict (WrapC f) x y - -The purpose of `WrapC` is to avoid having `f` instantiated. -Also, it avoids impredicativity, because `magicDict`'s type -cannot be instantiated with a forall. The field of `WrapC` contains -a `Proxy` parameter which is used to link the type of the constraint, -`C a`, with the type of the `Wrap` value being made. - -Next, we add a built-in Prelude rule (see prelude/PrelRules.hs), -which will replace the RHS of this definition with the appropriate -definition in Core. The rewrite rule works as follows: - - magicDict @t (wrap @a @b f) x y -----> - f (x `cast` co a) y - -The `co` coercion is the newtype-coercion extracted from the type-class. -The type class is obtain by looking at the type of wrap. - - -------------------------------------------------------------- -@realWorld#@ used to be a magic literal, \tr{void#}. If things get -nasty as-is, change it back to a literal (@Literal@). - -voidArgId is a Local Id used simply as an argument in functions -where we just want an arg to avoid having a thunk of unlifted type. -E.g. - x = \ void :: Void# -> (# p, q #) - -This comes up in strictness analysis - -Note [evaldUnfoldings] -~~~~~~~~~~~~~~~~~~~~~~ -The evaldUnfolding makes it look that some primitive value is -evaluated, which in turn makes Simplify.interestingArg return True, -which in turn makes INLINE things applied to said value likely to be -inlined. --} - -realWorldPrimId :: Id -- :: State# RealWorld -realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setOneShotInfo` stateHackOneShot - `setNeverLevPoly` realWorldStatePrimTy) - -voidPrimId :: Id -- Global constant :: Void# -voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setNeverLevPoly` voidPrimTy) - -voidArgId :: Id -- Local lambda-bound :: Void# -voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy - -coercionTokenId :: Id -- :: () ~ () -coercionTokenId -- Used to replace Coercion terms when we go to STG - = pcMiscPrelId coercionTokenName - (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy]) - noCafIdInfo - -pcMiscPrelId :: Name -> Type -> IdInfo -> Id -pcMiscPrelId name ty info - = mkVanillaGlobalWithInfo name ty info - -- We lie and say the thing is imported; otherwise, we get into - -- a mess with dependency analysis; e.g., core2stg may heave in - -- random calls to GHCbase.unpackPS__. If GHCbase is the module - -- being compiled, then it's just a matter of luck if the definition - -- will be in "the right place" to be in scope. diff --git a/basicTypes/MkId.hs-boot b/basicTypes/MkId.hs-boot deleted file mode 100644 --- a/basicTypes/MkId.hs-boot +++ /dev/null @@ -1,15 +0,0 @@ -module MkId where -import Name( Name ) -import Var( Id ) -import Class( Class ) -import {-# SOURCE #-} DataCon( DataCon ) -import {-# SOURCE #-} PrimOp( PrimOp ) - -data DataConBoxer - -mkDataConWorkId :: Name -> DataCon -> Id -mkDictSelId :: Name -> Class -> Id - -mkPrimOpId :: PrimOp -> Id - -magicDictId :: Id diff --git a/basicTypes/Module.hs b/basicTypes/Module.hs deleted file mode 100644 --- a/basicTypes/Module.hs +++ /dev/null @@ -1,1275 +0,0 @@ -{- -(c) The University of Glasgow, 2004-2006 - - -Module -~~~~~~~~~~ -Simply the name of a module, represented as a FastString. -These are Uniquable, hence we can build Maps with Modules as -the keys. --} - -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Module - ( - -- * The ModuleName type - ModuleName, - pprModuleName, - moduleNameFS, - moduleNameString, - moduleNameSlashes, moduleNameColons, - moduleStableString, - moduleFreeHoles, - moduleIsDefinite, - mkModuleName, - mkModuleNameFS, - stableModuleNameCmp, - - -- * The UnitId type - ComponentId(..), - UnitId(..), - unitIdFS, - unitIdKey, - IndefUnitId(..), - IndefModule(..), - indefUnitIdToUnitId, - indefModuleToModule, - InstalledUnitId(..), - toInstalledUnitId, - ShHoleSubst, - - unitIdIsDefinite, - unitIdString, - unitIdFreeHoles, - - newUnitId, - newIndefUnitId, - newSimpleUnitId, - hashUnitId, - fsToUnitId, - stringToUnitId, - stableUnitIdCmp, - - -- * HOLE renaming - renameHoleUnitId, - renameHoleModule, - renameHoleUnitId', - renameHoleModule', - - -- * Generalization - splitModuleInsts, - splitUnitIdInsts, - generalizeIndefUnitId, - generalizeIndefModule, - - -- * Parsers - parseModuleName, - parseUnitId, - parseComponentId, - parseModuleId, - parseModSubst, - - -- * Wired-in UnitIds - -- $wired_in_packages - primUnitId, - integerUnitId, - baseUnitId, - rtsUnitId, - thUnitId, - dphSeqUnitId, - dphParUnitId, - mainUnitId, - thisGhcUnitId, - isHoleModule, - interactiveUnitId, isInteractiveModule, - wiredInUnitIds, - - -- * The Module type - Module(Module), - moduleUnitId, moduleName, - pprModule, - mkModule, - mkHoleModule, - stableModuleCmp, - HasModule(..), - ContainsModule(..), - - -- * Installed unit ids and modules - InstalledModule(..), - InstalledModuleEnv, - installedModuleEq, - installedUnitIdEq, - installedUnitIdString, - fsToInstalledUnitId, - componentIdToInstalledUnitId, - stringToInstalledUnitId, - emptyInstalledModuleEnv, - lookupInstalledModuleEnv, - extendInstalledModuleEnv, - filterInstalledModuleEnv, - delInstalledModuleEnv, - DefUnitId(..), - - -- * The ModuleLocation type - ModLocation(..), - addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn, - - -- * Module mappings - ModuleEnv, - elemModuleEnv, extendModuleEnv, extendModuleEnvList, - extendModuleEnvList_C, plusModuleEnv_C, - delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, - lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, - moduleEnvKeys, moduleEnvElts, moduleEnvToList, - unitModuleEnv, isEmptyModuleEnv, - extendModuleEnvWith, filterModuleEnv, - - -- * ModuleName mappings - ModuleNameEnv, DModuleNameEnv, - - -- * Sets of Modules - ModuleSet, - emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet - ) where - -import Config -import Outputable -import Unique -import UniqFM -import UniqDFM -import UniqDSet -import FastString -import Binary -import Util -import Data.List -import Data.Ord -import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..)) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS -import qualified Data.ByteString.Char8 as BS.Char8 -import System.IO.Unsafe -import Foreign.Ptr (castPtr) -import GHC.Fingerprint -import Encoding - -import qualified Text.ParserCombinators.ReadP as Parse -import Text.ParserCombinators.ReadP (ReadP, (<++)) -import Data.Char (isAlphaNum) -import Control.DeepSeq -import Data.Coerce -import Data.Data -import Data.Function -import Data.Map (Map) -import Data.Set (Set) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified FiniteMap as Map -import System.FilePath - -import {-# SOURCE #-} DynFlags (DynFlags) -import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap, displayInstalledUnitId) - --- Note [The identifier lexicon] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Unit IDs, installed package IDs, ABI hashes, package names, --- versions, there are a *lot* of different identifiers for closely --- related things. What do they all mean? Here's what. (See also --- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Packages/Concepts ) --- --- THE IMPORTANT ONES --- --- ComponentId: An opaque identifier provided by Cabal, which should --- uniquely identify such things as the package name, the package --- version, the name of the component, the hash of the source code --- tarball, the selected Cabal flags, GHC flags, direct dependencies of --- the component. These are very similar to InstalledPackageId, but --- an 'InstalledPackageId' implies that it identifies a package, while --- a package may install multiple components with different --- 'ComponentId's. --- - Same as Distribution.Package.ComponentId --- --- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names --- (ModuleName) to Modules. This is how the compiler identifies instantiated --- components, and also is the main identifier by which GHC identifies things. --- - When Backpack is not being used, UnitId = ComponentId. --- this means a useful fiction for end-users is that there are --- only ever ComponentIds, and some ComponentIds happen to have --- more information (UnitIds). --- - Same as Language.Haskell.TH.Syntax:PkgName, see --- https://ghc.haskell.org/trac/ghc/ticket/10279 --- - The same as PackageKey in GHC 7.10 (we renamed it because --- they don't necessarily identify packages anymore.) --- - Same as -this-package-key/-package-name flags --- - An InstalledUnitId corresponds to an actual package which --- we have installed on disk. It could be definite or indefinite, --- but if it's indefinite, it has nothing instantiated (we --- never install partially instantiated units.) --- --- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how --- the compiler identifies modules (e.g. a Name is a Module + OccName) --- - Same as Language.Haskell.TH.Syntax:Module --- --- THE LESS IMPORTANT ONES --- --- PackageName: The "name" field in a Cabal file, something like "lens". --- - Same as Distribution.Package.PackageName --- - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see --- https://ghc.haskell.org/trac/ghc/ticket/10279 --- - DIFFERENT FROM -package-name flag --- - DIFFERENT FROM the 'name' field in an installed package --- information. This field could more accurately be described --- as a munged package name: when it's for the main library --- it is the same as the package name, but if it's an internal --- library it's a munged combination of the package name and --- the component name. --- --- LEGACY ONES --- --- InstalledPackageId: This is what we used to call ComponentId. --- It's a still pretty useful concept for packages that have only --- one library; in that case the logical InstalledPackageId = --- ComponentId. Also, the Cabal nix-local-build continues to --- compute an InstalledPackageId which is then forcibly used --- for all components in a package. This means that if a dependency --- from one component in a package changes, the InstalledPackageId --- changes: you don't get as fine-grained dependency tracking, --- but it means your builds are hermetic. Eventually, Cabal will --- deal completely in components and we can get rid of this. --- --- PackageKey: This is what we used to call UnitId. We ditched --- "Package" from the name when we realized that you might want to --- assign different "PackageKeys" to components from the same package. --- (For a brief, non-released period of time, we also called these --- UnitKeys). - -{- -************************************************************************ -* * -\subsection{Module locations} -* * -************************************************************************ --} - --- | Module Location --- --- Where a module lives on the file system: the actual locations --- of the .hs, .hi and .o files, if we have them -data ModLocation - = ModLocation { - ml_hs_file :: Maybe FilePath, - -- The source file, if we have one. Package modules - -- probably don't have source files. - - ml_hi_file :: FilePath, - -- Where the .hi file is, whether or not it exists - -- yet. Always of form foo.hi, even if there is an - -- hi-boot file (we add the -boot suffix later) - - ml_obj_file :: FilePath - -- Where the .o file is, whether or not it exists yet. - -- (might not exist either because the module hasn't - -- been compiled yet, or because it is part of a - -- package with a .a file) - } deriving Show - -instance Outputable ModLocation where - ppr = text . show - -{- -For a module in another package, the hs_file and obj_file -components of ModLocation are undefined. - -The locations specified by a ModLocation may or may not -correspond to actual files yet: for example, even if the object -file doesn't exist, the ModLocation still contains the path to -where the object file will reside if/when it is created. --} - -addBootSuffix :: FilePath -> FilePath --- ^ Add the @-boot@ suffix to .hs, .hi and .o files -addBootSuffix path = path ++ "-boot" - -addBootSuffix_maybe :: Bool -> FilePath -> FilePath --- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@ -addBootSuffix_maybe is_boot path - | is_boot = addBootSuffix path - | otherwise = path - -addBootSuffixLocn :: ModLocation -> ModLocation --- ^ Add the @-boot@ suffix to all file paths associated with the module -addBootSuffixLocn locn - = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) - , ml_hi_file = addBootSuffix (ml_hi_file locn) - , ml_obj_file = addBootSuffix (ml_obj_file locn) } - -{- -************************************************************************ -* * -\subsection{The name of a module} -* * -************************************************************************ --} - --- | A ModuleName is essentially a simple string, e.g. @Data.List@. -newtype ModuleName = ModuleName FastString - -instance Uniquable ModuleName where - getUnique (ModuleName nm) = getUnique nm - -instance Eq ModuleName where - nm1 == nm2 = getUnique nm1 == getUnique nm2 - -instance Ord ModuleName where - nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 - -instance Outputable ModuleName where - ppr = pprModuleName - -instance Binary ModuleName where - put_ bh (ModuleName fs) = put_ bh fs - get bh = do fs <- get bh; return (ModuleName fs) - -instance BinaryStringRep ModuleName where - fromStringRep = mkModuleNameFS . mkFastStringByteString - toStringRep = fastStringToByteString . moduleNameFS - -instance Data ModuleName where - -- don't traverse? - toConstr _ = abstractConstr "ModuleName" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "ModuleName" - -instance NFData ModuleName where - rnf x = x `seq` () - -stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering --- ^ Compares module names lexically, rather than by their 'Unique's -stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 - -pprModuleName :: ModuleName -> SDoc -pprModuleName (ModuleName nm) = - getPprStyle $ \ sty -> - if codeStyle sty - then ztext (zEncodeFS nm) - else ftext nm - -moduleNameFS :: ModuleName -> FastString -moduleNameFS (ModuleName mod) = mod - -moduleNameString :: ModuleName -> String -moduleNameString (ModuleName mod) = unpackFS mod - --- | Get a string representation of a 'Module' that's unique and stable --- across recompilations. --- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal" -moduleStableString :: Module -> String -moduleStableString Module{..} = - "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName - -mkModuleName :: String -> ModuleName -mkModuleName s = ModuleName (mkFastString s) - -mkModuleNameFS :: FastString -> ModuleName -mkModuleNameFS s = ModuleName s - --- |Returns the string version of the module name, with dots replaced by slashes. --- -moduleNameSlashes :: ModuleName -> String -moduleNameSlashes = dots_to_slashes . moduleNameString - where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) - --- |Returns the string version of the module name, with dots replaced by colons. --- -moduleNameColons :: ModuleName -> String -moduleNameColons = dots_to_colons . moduleNameString - where dots_to_colons = map (\c -> if c == '.' then ':' else c) - -{- -************************************************************************ -* * -\subsection{A fully qualified module} -* * -************************************************************************ --} - --- | A Module is a pair of a 'UnitId' and a 'ModuleName'. --- --- Module variables (i.e. @@) which can be instantiated to a --- specific module at some later point in time are represented --- with 'moduleUnitId' set to 'holeUnitId' (this allows us to --- avoid having to make 'moduleUnitId' a partial operation.) --- -data Module = Module { - moduleUnitId :: !UnitId, -- pkg-1.0 - moduleName :: !ModuleName -- A.B.C - } - deriving (Eq, Ord) - --- | Calculate the free holes of a 'Module'. If this set is non-empty, --- this module was defined in an indefinite library that had required --- signatures. --- --- If a module has free holes, that means that substitutions can operate on it; --- if it has no free holes, substituting over a module has no effect. -moduleFreeHoles :: Module -> UniqDSet ModuleName -moduleFreeHoles m - | isHoleModule m = unitUniqDSet (moduleName m) - | otherwise = unitIdFreeHoles (moduleUnitId m) - --- | A 'Module' is definite if it has no free holes. -moduleIsDefinite :: Module -> Bool -moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles - --- | Create a module variable at some 'ModuleName'. --- See Note [Representation of module/name variables] -mkHoleModule :: ModuleName -> Module -mkHoleModule = mkModule holeUnitId - -instance Uniquable Module where - getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n) - -instance Outputable Module where - ppr = pprModule - -instance Binary Module where - put_ bh (Module p n) = put_ bh p >> put_ bh n - get bh = do p <- get bh; n <- get bh; return (Module p n) - -instance Data Module where - -- don't traverse? - toConstr _ = abstractConstr "Module" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Module" - -instance NFData Module where - rnf x = x `seq` () - --- | This gives a stable ordering, as opposed to the Ord instance which --- gives an ordering based on the 'Unique's of the components, which may --- not be stable from run to run of the compiler. -stableModuleCmp :: Module -> Module -> Ordering -stableModuleCmp (Module p1 n1) (Module p2 n2) - = (p1 `stableUnitIdCmp` p2) `thenCmp` - (n1 `stableModuleNameCmp` n2) - -mkModule :: UnitId -> ModuleName -> Module -mkModule = Module - -pprModule :: Module -> SDoc -pprModule mod@(Module p n) = getPprStyle doc - where - doc sty - | codeStyle sty = - (if p == mainUnitId - then empty -- never qualify the main package in code - else ztext (zEncodeFS (unitIdFS p)) <> char '_') - <> pprModuleName n - | qualModule sty mod = - if isHoleModule mod - then angleBrackets (pprModuleName n) - else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n - | otherwise = - pprModuleName n - -class ContainsModule t where - extractModule :: t -> Module - -class HasModule m where - getModule :: m Module - -instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where - fromDbModule (DbModule uid mod_name) = mkModule uid mod_name - fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name - fromDbUnitId (DbUnitId cid insts) = newUnitId cid insts - fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid) - -- GHC never writes to the database, so it's not needed - toDbModule = error "toDbModule: not implemented" - toDbUnitId = error "toDbUnitId: not implemented" - -{- -************************************************************************ -* * -\subsection{ComponentId} -* * -************************************************************************ --} - --- | A 'ComponentId' consists of the package name, package version, component --- ID, the transitive dependencies of the component, and other information to --- uniquely identify the source code and build configuration of a component. --- --- This used to be known as an 'InstalledPackageId', but a package can contain --- multiple components and a 'ComponentId' uniquely identifies a component --- within a package. When a package only has one component, the 'ComponentId' --- coincides with the 'InstalledPackageId' -newtype ComponentId = ComponentId FastString deriving (Eq, Ord) - -instance BinaryStringRep ComponentId where - fromStringRep = ComponentId . mkFastStringByteString - toStringRep (ComponentId s) = fastStringToByteString s - -instance Uniquable ComponentId where - getUnique (ComponentId n) = getUnique n - -instance Outputable ComponentId where - ppr cid@(ComponentId fs) = - getPprStyle $ \sty -> - sdocWithDynFlags $ \dflags -> - case componentIdString dflags cid of - Just str | not (debugStyle sty) -> text str - _ -> ftext fs - -{- -************************************************************************ -* * -\subsection{UnitId} -* * -************************************************************************ --} - --- | A unit identifier identifies a (possibly partially) instantiated --- library. It is primarily used as part of 'Module', which in turn --- is used in 'Name', which is used to give names to entities when --- typechecking. --- --- There are two possible forms for a 'UnitId'. It can be a --- 'DefiniteUnitId', in which case we just have a string that uniquely --- identifies some fully compiled, installed library we have on disk. --- However, when we are typechecking a library with missing holes, --- we may need to instantiate a library on the fly (in which case --- we don't have any on-disk representation.) In that case, you --- have an 'IndefiniteUnitId', which explicitly records the --- instantiation, so that we can substitute over it. -data UnitId - = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId - | DefiniteUnitId {-# UNPACK #-} !DefUnitId - deriving (Typeable) - -unitIdFS :: UnitId -> FastString -unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x -unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x - -unitIdKey :: UnitId -> Unique -unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x -unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x - --- | A unit identifier which identifies an indefinite --- library (with holes) that has been *on-the-fly* instantiated --- with a substitution 'indefUnitIdInsts'. In fact, an indefinite --- unit identifier could have no holes, but we haven't gotten --- around to compiling the actual library yet. --- --- An indefinite unit identifier pretty-prints to something like --- @p[H=,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the --- brackets enclose the module substitution). -data IndefUnitId - = IndefUnitId { - -- | A private, uniquely identifying representation of - -- a UnitId. This string is completely private to GHC - -- and is just used to get a unique; in particular, we don't use it for - -- symbols (indefinite libraries are not compiled). - indefUnitIdFS :: FastString, - -- | Cached unique of 'unitIdFS'. - indefUnitIdKey :: Unique, - -- | The component identity of the indefinite library that - -- is being instantiated. - indefUnitIdComponentId :: !ComponentId, - -- | The sorted (by 'ModuleName') instantiations of this library. - indefUnitIdInsts :: ![(ModuleName, Module)], - -- | A cache of the free module variables of 'unitIdInsts'. - -- This lets us efficiently tell if a 'UnitId' has been - -- fully instantiated (free module variables are empty) - -- and whether or not a substitution can have any effect. - indefUnitIdFreeHoles :: UniqDSet ModuleName - } deriving (Typeable) - -instance Eq IndefUnitId where - u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 - -instance Ord IndefUnitId where - u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 - -instance Binary IndefUnitId where - put_ bh indef = do - put_ bh (indefUnitIdComponentId indef) - put_ bh (indefUnitIdInsts indef) - get bh = do - cid <- get bh - insts <- get bh - let fs = hashUnitId cid insts - return IndefUnitId { - indefUnitIdComponentId = cid, - indefUnitIdInsts = insts, - indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - indefUnitIdFS = fs, - indefUnitIdKey = getUnique fs - } - --- | Create a new 'IndefUnitId' given an explicit module substitution. -newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId -newIndefUnitId cid insts = - IndefUnitId { - indefUnitIdComponentId = cid, - indefUnitIdInsts = sorted_insts, - indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - indefUnitIdFS = fs, - indefUnitIdKey = getUnique fs - } - where - fs = hashUnitId cid sorted_insts - sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts - --- | Injects an 'IndefUnitId' (indefinite library which --- was on-the-fly instantiated) to a 'UnitId' (either --- an indefinite or definite library). -indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId -indefUnitIdToUnitId dflags iuid = - -- NB: suppose that we want to compare the indefinite - -- unit id p[H=impl:H] against p+abcd (where p+abcd - -- happens to be the existing, installed version of - -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] - -- IndefiniteUnitId, they won't compare equal; only - -- after improvement will the equality hold. - improveUnitId (getPackageConfigMap dflags) $ - IndefiniteUnitId iuid - -data IndefModule = IndefModule { - indefModuleUnitId :: IndefUnitId, - indefModuleName :: ModuleName - } deriving (Typeable, Eq, Ord) - -instance Outputable IndefModule where - ppr (IndefModule uid m) = - ppr uid <> char ':' <> ppr m - --- | Injects an 'IndefModule' to 'Module' (see also --- 'indefUnitIdToUnitId'. -indefModuleToModule :: DynFlags -> IndefModule -> Module -indefModuleToModule dflags (IndefModule iuid mod_name) = - mkModule (indefUnitIdToUnitId dflags iuid) mod_name - --- | An installed unit identifier identifies a library which has --- been installed to the package database. These strings are --- provided to us via the @-this-unit-id@ flag. The library --- in question may be definite or indefinite; if it is indefinite, --- none of the holes have been filled (we never install partially --- instantiated libraries.) Put another way, an installed unit id --- is either fully instantiated, or not instantiated at all. --- --- Installed unit identifiers look something like @p+af23SAj2dZ219@, --- or maybe just @p@ if they don't use Backpack. -newtype InstalledUnitId = - InstalledUnitId { - -- | The full hashed unit identifier, including the component id - -- and the hash. - installedUnitIdFS :: FastString - } - deriving (Typeable) - -instance Binary InstalledUnitId where - put_ bh (InstalledUnitId fs) = put_ bh fs - get bh = do fs <- get bh; return (InstalledUnitId fs) - -instance BinaryStringRep InstalledUnitId where - fromStringRep bs = InstalledUnitId (mkFastStringByteString bs) - -- GHC doesn't write to database - toStringRep = error "BinaryStringRep InstalledUnitId: not implemented" - -instance Eq InstalledUnitId where - uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2 - -instance Ord InstalledUnitId where - u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2 - -instance Uniquable InstalledUnitId where - getUnique = installedUnitIdKey - -instance Outputable InstalledUnitId where - ppr uid@(InstalledUnitId fs) = - getPprStyle $ \sty -> - sdocWithDynFlags $ \dflags -> - case displayInstalledUnitId dflags uid of - Just str | not (debugStyle sty) -> text str - _ -> ftext fs - -installedUnitIdKey :: InstalledUnitId -> Unique -installedUnitIdKey = getUnique . installedUnitIdFS - --- | Lossy conversion to the on-disk 'InstalledUnitId' for a component. -toInstalledUnitId :: UnitId -> InstalledUnitId -toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid -toInstalledUnitId (IndefiniteUnitId indef) = - componentIdToInstalledUnitId (indefUnitIdComponentId indef) - -installedUnitIdString :: InstalledUnitId -> String -installedUnitIdString = unpackFS . installedUnitIdFS - -instance Outputable IndefUnitId where - ppr uid = - -- getPprStyle $ \sty -> - ppr cid <> - (if not (null insts) -- pprIf - then - brackets (hcat - (punctuate comma $ - [ ppr modname <> text "=" <> ppr m - | (modname, m) <- insts])) - else empty) - where - cid = indefUnitIdComponentId uid - insts = indefUnitIdInsts uid - --- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'. -data InstalledModule = InstalledModule { - installedModuleUnitId :: !InstalledUnitId, - installedModuleName :: !ModuleName - } - deriving (Eq, Ord) - -instance Outputable InstalledModule where - ppr (InstalledModule p n) = - ppr p <> char ':' <> pprModuleName n - -fsToInstalledUnitId :: FastString -> InstalledUnitId -fsToInstalledUnitId fs = InstalledUnitId fs - -componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId -componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs - -stringToInstalledUnitId :: String -> InstalledUnitId -stringToInstalledUnitId = fsToInstalledUnitId . mkFastString - --- | Test if a 'Module' corresponds to a given 'InstalledModule', --- modulo instantiation. -installedModuleEq :: InstalledModule -> Module -> Bool -installedModuleEq imod mod = - fst (splitModuleInsts mod) == imod - --- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId', --- modulo instantiation. -installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool -installedUnitIdEq iuid uid = - fst (splitUnitIdInsts uid) == iuid - --- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that --- it only refers to a definite library; i.e., one we have generated --- code for. -newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId } - deriving (Eq, Ord, Typeable) - -instance Outputable DefUnitId where - ppr (DefUnitId uid) = ppr uid - -instance Binary DefUnitId where - put_ bh (DefUnitId uid) = put_ bh uid - get bh = do uid <- get bh; return (DefUnitId uid) - --- | A map keyed off of 'InstalledModule' -newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) - -emptyInstalledModuleEnv :: InstalledModuleEnv a -emptyInstalledModuleEnv = InstalledModuleEnv Map.empty - -lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a -lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e - -extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a -extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e) - -filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a -filterInstalledModuleEnv f (InstalledModuleEnv e) = - InstalledModuleEnv (Map.filterWithKey f e) - -delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a -delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) - --- Note [UnitId to InstalledUnitId improvement] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Just because a UnitId is definite (has no holes) doesn't --- mean it's necessarily a InstalledUnitId; it could just be --- that over the course of renaming UnitIds on the fly --- while typechecking an indefinite library, we --- ended up with a fully instantiated unit id with no hash, --- since we haven't built it yet. This is fine. --- --- However, if there is a hashed unit id for this instantiation --- in the package database, we *better use it*, because --- that hashed unit id may be lurking in another interface, --- and chaos will ensue if we attempt to compare the two --- (the unitIdFS for a UnitId never corresponds to a Cabal-provided --- hash of a compiled instantiated library). --- --- There is one last niggle: improvement based on the package database means --- that we might end up developing on a package that is not transitively --- depended upon by the packages the user specified directly via command line --- flags. This could lead to strange and difficult to understand bugs if those --- instantiations are out of date. The solution is to only improve a --- unit id if the new unit id is part of the 'preloadClosure'; i.e., the --- closure of all the packages which were explicitly specified. - --- | Retrieve the set of free holes of a 'UnitId'. -unitIdFreeHoles :: UnitId -> UniqDSet ModuleName -unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x --- Hashed unit ids are always fully instantiated -unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet - -instance Show UnitId where - show = unitIdString - --- | A 'UnitId' is definite if it has no free holes. -unitIdIsDefinite :: UnitId -> Bool -unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles - --- | Generate a uniquely identifying 'FastString' for a unit --- identifier. This is a one-way function. You can rely on one special --- property: if a unit identifier is in most general form, its 'FastString' --- coincides with its 'ComponentId'. This hash is completely internal --- to GHC and is not used for symbol names or file paths. -hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString -hashUnitId cid sorted_holes = - mkFastStringByteString - . fingerprintUnitId (toStringRep cid) - $ rawHashUnitId sorted_holes - --- | Generate a hash for a sorted module substitution. -rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint -rawHashUnitId sorted_holes = - fingerprintByteString - . BS.concat $ do - (m, b) <- sorted_holes - [ toStringRep m, BS.Char8.singleton ' ', - fastStringToByteString (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', - toStringRep (moduleName b), BS.Char8.singleton '\n'] - -fingerprintByteString :: BS.ByteString -> Fingerprint -fingerprintByteString bs = unsafePerformIO - . BS.unsafeUseAsCStringLen bs - $ \(p,l) -> fingerprintData (castPtr p) l - -fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString -fingerprintUnitId prefix (Fingerprint a b) - = BS.concat - $ [ prefix - , BS.Char8.singleton '-' - , BS.Char8.pack (toBase62Padded a) - , BS.Char8.pack (toBase62Padded b) ] - --- | Create a new, un-hashed unit identifier. -newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId -newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug... -newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts - -pprUnitId :: UnitId -> SDoc -pprUnitId (DefiniteUnitId uid) = ppr uid -pprUnitId (IndefiniteUnitId uid) = ppr uid - -instance Eq UnitId where - uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 - -instance Uniquable UnitId where - getUnique = unitIdKey - -instance Ord UnitId where - nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2 - -instance Data UnitId where - -- don't traverse? - toConstr _ = abstractConstr "UnitId" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "UnitId" - -instance NFData UnitId where - rnf x = x `seq` () - -stableUnitIdCmp :: UnitId -> UnitId -> Ordering --- ^ Compares package ids lexically, rather than by their 'Unique's -stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2 - -instance Outputable UnitId where - ppr pk = pprUnitId pk - --- Performance: would prefer to have a NameCache like thing -instance Binary UnitId where - put_ bh (DefiniteUnitId def_uid) = do - putByte bh 0 - put_ bh def_uid - put_ bh (IndefiniteUnitId indef_uid) = do - putByte bh 1 - put_ bh indef_uid - get bh = do b <- getByte bh - case b of - 0 -> fmap DefiniteUnitId (get bh) - _ -> fmap IndefiniteUnitId (get bh) - -instance Binary ComponentId where - put_ bh (ComponentId fs) = put_ bh fs - get bh = do { fs <- get bh; return (ComponentId fs) } - --- | Create a new simple unit identifier (no holes) from a 'ComponentId'. -newSimpleUnitId :: ComponentId -> UnitId -newSimpleUnitId (ComponentId fs) = fsToUnitId fs - --- | Create a new simple unit identifier from a 'FastString'. Internally, --- this is primarily used to specify wired-in unit identifiers. -fsToUnitId :: FastString -> UnitId -fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId - -stringToUnitId :: String -> UnitId -stringToUnitId = fsToUnitId . mkFastString - -unitIdString :: UnitId -> String -unitIdString = unpackFS . unitIdFS - -{- -************************************************************************ -* * - Hole substitutions -* * -************************************************************************ --} - --- | Substitution on module variables, mapping module names to module --- identifiers. -type ShHoleSubst = ModuleNameEnv Module - --- | Substitutes holes in a 'Module'. NOT suitable for being called --- directly on a 'nameModule', see Note [Representation of module/name variable]. --- @p[A=]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; --- similarly, @@ maps to @q():A@. -renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module -renameHoleModule dflags = renameHoleModule' (getPackageConfigMap dflags) - --- | Substitutes holes in a 'UnitId', suitable for renaming when --- an include occurs; see Note [Representation of module/name variable]. --- --- @p[A=]@ maps to @p[A=]@ with @A=@. -renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId -renameHoleUnitId dflags = renameHoleUnitId' (getPackageConfigMap dflags) - --- | Like 'renameHoleModule', but requires only 'PackageConfigMap' --- so it can be used by "Packages". -renameHoleModule' :: PackageConfigMap -> ShHoleSubst -> Module -> Module -renameHoleModule' pkg_map env m - | not (isHoleModule m) = - let uid = renameHoleUnitId' pkg_map env (moduleUnitId m) - in mkModule uid (moduleName m) - | Just m' <- lookupUFM env (moduleName m) = m' - -- NB m = , that's what's in scope. - | otherwise = m - --- | Like 'renameHoleUnitId, but requires only 'PackageConfigMap' --- so it can be used by "Packages". -renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId -renameHoleUnitId' pkg_map env uid = - case uid of - (IndefiniteUnitId - IndefUnitId{ indefUnitIdComponentId = cid - , indefUnitIdInsts = insts - , indefUnitIdFreeHoles = fh }) - -> if isNullUFM (intersectUFM_C const (udfmToUfm fh) env) - then uid - -- Functorially apply the substitution to the instantiation, - -- then check the 'PackageConfigMap' to see if there is - -- a compiled version of this 'UnitId' we can improve to. - -- See Note [UnitId to InstalledUnitId] improvement - else improveUnitId pkg_map $ - newUnitId cid - (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) - _ -> uid - --- | Given a possibly on-the-fly instantiated module, split it into --- a 'Module' that we definitely can find on-disk, as well as an --- instantiation if we need to instantiate it on the fly. If the --- instantiation is @Nothing@ no on-the-fly renaming is needed. -splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule) -splitModuleInsts m = - let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m) - in (InstalledModule uid (moduleName m), - fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid) - --- | See 'splitModuleInsts'. -splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId) -splitUnitIdInsts (IndefiniteUnitId iuid) = - (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid) -splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing) - -generalizeIndefUnitId :: IndefUnitId -> IndefUnitId -generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid - , indefUnitIdInsts = insts } = - newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts) - -generalizeIndefModule :: IndefModule -> IndefModule -generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n - -parseModuleName :: ReadP ModuleName -parseModuleName = fmap mkModuleName - $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") - -parseUnitId :: ReadP UnitId -parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId - where - parseFullUnitId = do - cid <- parseComponentId - insts <- parseModSubst - return (newUnitId cid insts) - parseDefiniteUnitId = do - s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") - return (stringToUnitId s) - parseSimpleUnitId = do - cid <- parseComponentId - return (newSimpleUnitId cid) - -parseComponentId :: ReadP ComponentId -parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char - where abi_char c = isAlphaNum c || c `elem` "-_." - -parseModuleId :: ReadP Module -parseModuleId = parseModuleVar <++ parseModule - where - parseModuleVar = do - _ <- Parse.char '<' - modname <- parseModuleName - _ <- Parse.char '>' - return (mkHoleModule modname) - parseModule = do - uid <- parseUnitId - _ <- Parse.char ':' - modname <- parseModuleName - return (mkModule uid modname) - -parseModSubst :: ReadP [(ModuleName, Module)] -parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') - . flip Parse.sepBy (Parse.char ',') - $ do k <- parseModuleName - _ <- Parse.char '=' - v <- parseModuleId - return (k, v) - - --- ----------------------------------------------------------------------------- --- $wired_in_packages --- Certain packages are known to the compiler, in that we know about certain --- entities that reside in these packages, and the compiler needs to --- declare static Modules and Names that refer to these packages. Hence --- the wired-in packages can't include version numbers, since we don't want --- to bake the version numbers of these packages into GHC. --- --- So here's the plan. Wired-in packages are still versioned as --- normal in the packages database, and you can still have multiple --- versions of them installed. However, for each invocation of GHC, --- only a single instance of each wired-in package will be recognised --- (the desired one is selected via @-package@\/@-hide-package@), and GHC --- will use the unversioned 'UnitId' below when referring to it, --- including in .hi files and object file symbols. Unselected --- versions of wired-in packages will be ignored, as will any other --- package that depends directly or indirectly on it (much as if you --- had used @-ignore-package@). - --- Make sure you change 'Packages.findWiredInPackages' if you add an entry here - -integerUnitId, primUnitId, - baseUnitId, rtsUnitId, - thUnitId, dphSeqUnitId, dphParUnitId, - mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId -primUnitId = fsToUnitId (fsLit "ghc-prim") -integerUnitId = fsToUnitId (fsLit n) - where - n = case cIntegerLibraryType of - IntegerGMP -> "integer-gmp" - IntegerSimple -> "integer-simple" -baseUnitId = fsToUnitId (fsLit "base") -rtsUnitId = fsToUnitId (fsLit "rts") -thUnitId = fsToUnitId (fsLit "template-haskell") -dphSeqUnitId = fsToUnitId (fsLit "dph-seq") -dphParUnitId = fsToUnitId (fsLit "dph-par") -thisGhcUnitId = fsToUnitId (fsLit "ghc") -interactiveUnitId = fsToUnitId (fsLit "interactive") - --- | This is the package Id for the current program. It is the default --- package Id if you don't specify a package name. We don't add this prefix --- to symbol names, since there can be only one main package per program. -mainUnitId = fsToUnitId (fsLit "main") - --- | This is a fake package id used to provide identities to any un-implemented --- signatures. The set of hole identities is global over an entire compilation. --- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead. --- See Note [Representation of module/name variables] -holeUnitId :: UnitId -holeUnitId = fsToUnitId (fsLit "hole") - -isInteractiveModule :: Module -> Bool -isInteractiveModule mod = moduleUnitId mod == interactiveUnitId - --- Note [Representation of module/name variables] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In our ICFP'16, we use to represent module holes, and {A.T} to represent --- name holes. This could have been represented by adding some new cases --- to the core data types, but this would have made the existing 'nameModule' --- and 'moduleUnitId' partial, which would have required a lot of modifications --- to existing code. --- --- Instead, we adopted the following encoding scheme: --- --- ===> hole:A --- {A.T} ===> hole:A.T --- --- This encoding is quite convenient, but it is also a bit dangerous too, --- because if you have a 'hole:A' you need to know if it's actually a --- 'Module' or just a module stored in a 'Name'; these two cases must be --- treated differently when doing substitutions. 'renameHoleModule' --- and 'renameHoleUnitId' assume they are NOT operating on a --- 'Name'; 'NameShape' handles name substitutions exclusively. - -isHoleModule :: Module -> Bool -isHoleModule mod = moduleUnitId mod == holeUnitId - -wiredInUnitIds :: [UnitId] -wiredInUnitIds = [ primUnitId, - integerUnitId, - baseUnitId, - rtsUnitId, - thUnitId, - thisGhcUnitId, - dphSeqUnitId, - dphParUnitId ] - -{- -************************************************************************ -* * -\subsection{@ModuleEnv@s} -* * -************************************************************************ --} - --- | A map keyed off of 'Module's -newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) - -{- -Note [ModuleEnv performance and determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To prevent accidental reintroduction of nondeterminism the Ord instance -for Module was changed to not depend on Unique ordering and to use the -lexicographic order. This is potentially expensive, but when measured -there was no difference in performance. - -To be on the safe side and not pessimize ModuleEnv uses nondeterministic -ordering on Module and normalizes by doing the lexicographic sort when -turning the env to a list. -See Note [Unique Determinism] for more information about the source of -nondeterminismand and Note [Deterministic UniqFM] for explanation of why -it matters for maps. --} - -newtype NDModule = NDModule { unNDModule :: Module } - deriving Eq - -- A wrapper for Module with faster nondeterministic Ord. - -- Don't export, See [ModuleEnv performance and determinism] - -instance Ord NDModule where - compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = - (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` - (getUnique n1 `nonDetCmpUnique` getUnique n2) - -filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a -filterModuleEnv f (ModuleEnv e) = - ModuleEnv (Map.filterWithKey (f . unNDModule) e) - -elemModuleEnv :: Module -> ModuleEnv a -> Bool -elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e - -extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a -extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e) - -extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a - -> ModuleEnv a -extendModuleEnvWith f (ModuleEnv e) m x = - ModuleEnv (Map.insertWith f (NDModule m) x e) - -extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a -extendModuleEnvList (ModuleEnv e) xs = - ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e) - -extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] - -> ModuleEnv a -extendModuleEnvList_C f (ModuleEnv e) xs = - ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e) - -plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = - ModuleEnv (Map.unionWith f e1 e2) - -delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a -delModuleEnvList (ModuleEnv e) ms = - ModuleEnv (Map.deleteList (map NDModule ms) e) - -delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a -delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e) - -plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) - -lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a -lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e - -lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a -lookupWithDefaultModuleEnv (ModuleEnv e) x m = - Map.findWithDefault x (NDModule m) e - -mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b -mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) - -mkModuleEnv :: [(Module, a)] -> ModuleEnv a -mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) - -emptyModuleEnv :: ModuleEnv a -emptyModuleEnv = ModuleEnv Map.empty - -moduleEnvKeys :: ModuleEnv a -> [Module] -moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e - -- See Note [ModuleEnv performance and determinism] - -moduleEnvElts :: ModuleEnv a -> [a] -moduleEnvElts e = map snd $ moduleEnvToList e - -- See Note [ModuleEnv performance and determinism] - -moduleEnvToList :: ModuleEnv a -> [(Module, a)] -moduleEnvToList (ModuleEnv e) = - sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e] - -- See Note [ModuleEnv performance and determinism] - -unitModuleEnv :: Module -> a -> ModuleEnv a -unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x) - -isEmptyModuleEnv :: ModuleEnv a -> Bool -isEmptyModuleEnv (ModuleEnv e) = Map.null e - --- | A set of 'Module's -type ModuleSet = Set NDModule - -mkModuleSet :: [Module] -> ModuleSet -extendModuleSet :: ModuleSet -> Module -> ModuleSet -emptyModuleSet :: ModuleSet -moduleSetElts :: ModuleSet -> [Module] -elemModuleSet :: Module -> ModuleSet -> Bool - -emptyModuleSet = Set.empty -mkModuleSet = Set.fromList . coerce -extendModuleSet s m = Set.insert (NDModule m) s -moduleSetElts = sort . coerce . Set.toList -elemModuleSet = Set.member . coerce - -{- -A ModuleName has a Unique, so we can build mappings of these using -UniqFM. --} - --- | A map keyed off of 'ModuleName's (actually, their 'Unique's) -type ModuleNameEnv elt = UniqFM elt - - --- | A map keyed off of 'ModuleName's (actually, their 'Unique's) --- Has deterministic folds and can be deterministically converted to a list -type DModuleNameEnv elt = UniqDFM elt diff --git a/basicTypes/Module.hs-boot b/basicTypes/Module.hs-boot deleted file mode 100644 --- a/basicTypes/Module.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module Module where -import FastString - -data Module -data ModuleName -data UnitId -data InstalledUnitId -newtype ComponentId = ComponentId FastString - -moduleName :: Module -> ModuleName -moduleUnitId :: Module -> UnitId -unitIdString :: UnitId -> String diff --git a/basicTypes/Name.hs b/basicTypes/Name.hs deleted file mode 100644 --- a/basicTypes/Name.hs +++ /dev/null @@ -1,710 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Name]{@Name@: to transmit name info from renamer to typechecker} --} - -{-# LANGUAGE RecordWildCards #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name' is the type of names that have had their scoping and binding resolved. They --- have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have --- the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names --- also contain information about where they originated from, see "Name#name_sorts" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" --- --- #name_sorts# --- Names are one of: --- --- * External, if they name things declared in other modules. Some external --- Names are wired in, i.e. they name primitives defined in the compiler itself --- --- * Internal, if they name things in the module being compiled. Some internal --- Names are system names, if they are names manufactured by the compiler - -module Name ( - -- * The main types - Name, -- Abstract - BuiltInSyntax(..), - - -- ** Creating 'Name's - mkSystemName, mkSystemNameAt, - mkInternalName, mkClonedInternalName, mkDerivedInternalName, - mkSystemVarName, mkSysTvName, - mkFCallName, - mkExternalName, mkWiredInName, - - -- ** Manipulating and deconstructing 'Name's - nameUnique, setNameUnique, - nameOccName, nameModule, nameModule_maybe, - setNameLoc, - tidyNameOcc, - localiseName, - mkLocalisedOccName, - - nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, - - -- ** Predicates on 'Name's - isSystemName, isInternalName, isExternalName, - isTyVarName, isTyConName, isDataConName, - isValName, isVarName, - isWiredInName, isBuiltInSyntax, - isHoleName, - wiredInNameTyThing_maybe, - nameIsLocalOrFrom, nameIsHomePackage, - nameIsHomePackageImport, nameIsFromExternalPackage, - stableNameCmp, - - -- * Class 'NamedThing' and overloaded friends - NamedThing(..), - getSrcLoc, getSrcSpan, getOccString, getOccFS, - - pprInfixName, pprPrefixName, pprModulePrefix, - nameStableString, - - -- Re-export the OccName stuff - module OccName - ) where - -import {-# SOURCE #-} TyCoRep( TyThing ) -import {-# SOURCE #-} PrelNames( starKindTyConKey, unicodeStarKindTyConKey ) - -import OccName -import Module -import SrcLoc -import Unique -import Util -import Maybes -import Binary -import DynFlags -import FastString -import Outputable - -import Control.DeepSeq -import Data.Data - -{- -************************************************************************ -* * -\subsection[Name-datatype]{The @Name@ datatype, and name construction} -* * -************************************************************************ --} - --- | A unique, unambiguous name for something, containing information about where --- that thing originated. -data Name = Name { - n_sort :: NameSort, -- What sort of name it is - n_occ :: !OccName, -- Its occurrence name - n_uniq :: {-# UNPACK #-} !Int, - n_loc :: !SrcSpan -- Definition site - } - --- NOTE: we make the n_loc field strict to eliminate some potential --- (and real!) space leaks, due to the fact that we don't look at --- the SrcLoc in a Name all that often. - -data NameSort - = External Module - - | WiredIn Module TyThing BuiltInSyntax - -- A variant of External, for wired-in things - - | Internal -- A user-defined Id or TyVar - -- defined in the module being compiled - - | System -- A system-defined Id or TyVar. Typically the - -- OccName is very uninformative (like 's') - -instance Outputable NameSort where - ppr (External _) = text "external" - ppr (WiredIn _ _ _) = text "wired-in" - ppr Internal = text "internal" - ppr System = text "system" - -instance NFData Name where - rnf Name{..} = rnf n_sort - -instance NFData NameSort where - rnf (External m) = rnf m - rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () - -- XXX this is a *lie*, we're not going to rnf the TyThing, but - -- since the TyThings for WiredIn Names are all static they can't - -- be hiding space leaks or errors. - rnf Internal = () - rnf System = () - --- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, --- which have special syntactic forms. They aren't in scope --- as such. -data BuiltInSyntax = BuiltInSyntax | UserSyntax - -{- -Notes about the NameSorts: - -1. Initially, top-level Ids (including locally-defined ones) get External names, - and all other local Ids get Internal names - -2. In any invocation of GHC, an External Name for "M.x" has one and only one - unique. This unique association is ensured via the Name Cache; - see Note [The Name Cache] in IfaceEnv. - -3. Things with a External name are given C static labels, so they finally - appear in the .o file's symbol table. They appear in the symbol table - in the form M.n. If originally-local things have this property they - must be made @External@ first. - -4. In the tidy-core phase, a External that is not visible to an importer - is changed to Internal, and a Internal that is visible is changed to External - -5. A System Name differs in the following ways: - a) has unique attached when printing dumps - b) unifier eliminates sys tyvars in favour of user provs where possible - - Before anything gets printed in interface files or output code, it's - fed through a 'tidy' processor, which zaps the OccNames to have - unique names; and converts all sys-locals to user locals - If any desugarer sys-locals have survived that far, they get changed to - "ds1", "ds2", etc. - -Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) - -Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, - not read from an interface file. - E.g. Bool, True, Int, Float, and many others - -All built-in syntax is for wired-in things. --} - -instance HasOccName Name where - occName = nameOccName - -nameUnique :: Name -> Unique -nameOccName :: Name -> OccName -nameModule :: Name -> Module -nameSrcLoc :: Name -> SrcLoc -nameSrcSpan :: Name -> SrcSpan - -nameUnique name = mkUniqueGrimily (n_uniq name) -nameOccName name = n_occ name -nameSrcLoc name = srcSpanStart (n_loc name) -nameSrcSpan name = n_loc name - -{- -************************************************************************ -* * -\subsection{Predicates on names} -* * -************************************************************************ --} - -isInternalName :: Name -> Bool -isExternalName :: Name -> Bool -isSystemName :: Name -> Bool -isWiredInName :: Name -> Bool - -isWiredInName (Name {n_sort = WiredIn _ _ _}) = True -isWiredInName _ = False - -wiredInNameTyThing_maybe :: Name -> Maybe TyThing -wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing -wiredInNameTyThing_maybe _ = Nothing - -isBuiltInSyntax :: Name -> Bool -isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True -isBuiltInSyntax _ = False - -isExternalName (Name {n_sort = External _}) = True -isExternalName (Name {n_sort = WiredIn _ _ _}) = True -isExternalName _ = False - -isInternalName name = not (isExternalName name) - -isHoleName :: Name -> Bool -isHoleName = isHoleModule . nameModule - -nameModule name = - nameModule_maybe name `orElse` - pprPanic "nameModule" (ppr (n_sort name) <+> ppr name) - -nameModule_maybe :: Name -> Maybe Module -nameModule_maybe (Name { n_sort = External mod}) = Just mod -nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod -nameModule_maybe _ = Nothing - -nameIsLocalOrFrom :: Module -> Name -> Bool --- ^ Returns True if the name is --- (a) Internal --- (b) External but from the specified module --- (c) External but from the 'interactive' package --- --- The key idea is that --- False means: the entity is defined in some other module --- you can find the details (type, fixity, instances) --- in some interface file --- those details will be stored in the EPT or HPT --- --- True means: the entity is defined in this module or earlier in --- the GHCi session --- you can find details (type, fixity, instances) in the --- TcGblEnv or TcLclEnv --- --- The isInteractiveModule part is because successive interactions of a GCHi session --- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come --- from the magic 'interactive' package; and all the details are kept in the --- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. --- See Note [The interactive package] in HscTypes - -nameIsLocalOrFrom from name - | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod - | otherwise = True - -nameIsHomePackage :: Module -> Name -> Bool --- True if the Name is defined in module of this package -nameIsHomePackage this_mod - = \nm -> case n_sort nm of - External nm_mod -> moduleUnitId nm_mod == this_pkg - WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg - Internal -> True - System -> False - where - this_pkg = moduleUnitId this_mod - -nameIsHomePackageImport :: Module -> Name -> Bool --- True if the Name is defined in module of this package --- /other than/ the this_mod -nameIsHomePackageImport this_mod - = \nm -> case nameModule_maybe nm of - Nothing -> False - Just nm_mod -> nm_mod /= this_mod - && moduleUnitId nm_mod == this_pkg - where - this_pkg = moduleUnitId this_mod - --- | Returns True if the Name comes from some other package: neither this --- pacakge nor the interactive package. -nameIsFromExternalPackage :: UnitId -> Name -> Bool -nameIsFromExternalPackage this_pkg name - | Just mod <- nameModule_maybe name - , moduleUnitId mod /= this_pkg -- Not this package - , not (isInteractiveModule mod) -- Not the 'interactive' package - = True - | otherwise - = False - -isTyVarName :: Name -> Bool -isTyVarName name = isTvOcc (nameOccName name) - -isTyConName :: Name -> Bool -isTyConName name = isTcOcc (nameOccName name) - -isDataConName :: Name -> Bool -isDataConName name = isDataOcc (nameOccName name) - -isValName :: Name -> Bool -isValName name = isValOcc (nameOccName name) - -isVarName :: Name -> Bool -isVarName = isVarOcc . nameOccName - -isSystemName (Name {n_sort = System}) = True -isSystemName _ = False - -{- -************************************************************************ -* * -\subsection{Making names} -* * -************************************************************************ --} - --- | Create a name which is (for now at least) local to the current module and hence --- does not need a 'Module' to disambiguate it from other 'Name's -mkInternalName :: Unique -> OccName -> SrcSpan -> Name -mkInternalName uniq occ loc = Name { n_uniq = getKey uniq - , n_sort = Internal - , n_occ = occ - , n_loc = loc } - -- NB: You might worry that after lots of huffing and - -- puffing we might end up with two local names with distinct - -- uniques, but the same OccName. Indeed we can, but that's ok - -- * the insides of the compiler don't care: they use the Unique - -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the - -- uniques if you get confused - -- * for interface files we tidyCore first, which makes - -- the OccNames distinct when they need to be - -mkClonedInternalName :: Unique -> Name -> Name -mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) - = Name { n_uniq = getKey uniq, n_sort = Internal - , n_occ = occ, n_loc = loc } - -mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name -mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) - = Name { n_uniq = getKey uniq, n_sort = Internal - , n_occ = derive_occ occ, n_loc = loc } - --- | Create a name which definitely originates in the given module -mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name --- WATCH OUT! External Names should be in the Name Cache --- (see Note [The Name Cache] in IfaceEnv), so don't just call mkExternalName --- with some fresh unique without populating the Name Cache -mkExternalName uniq mod occ loc - = Name { n_uniq = getKey uniq, n_sort = External mod, - n_occ = occ, n_loc = loc } - --- | Create a name which is actually defined by the compiler itself -mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name -mkWiredInName mod occ uniq thing built_in - = Name { n_uniq = getKey uniq, - n_sort = WiredIn mod thing built_in, - n_occ = occ, n_loc = wiredInSrcSpan } - --- | Create a name brought into being by the compiler -mkSystemName :: Unique -> OccName -> Name -mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan - -mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name -mkSystemNameAt uniq occ loc = Name { n_uniq = getKey uniq, n_sort = System - , n_occ = occ, n_loc = loc } - -mkSystemVarName :: Unique -> FastString -> Name -mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) - -mkSysTvName :: Unique -> FastString -> Name -mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) - --- | Make a name for a foreign call -mkFCallName :: Unique -> String -> Name -mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan - -- The encoded string completely describes the ccall - --- When we renumber/rename things, we need to be --- able to change a Name's Unique to match the cached --- one in the thing it's the name of. If you know what I mean. -setNameUnique :: Name -> Unique -> Name -setNameUnique name uniq = name {n_uniq = getKey uniq} - --- This is used for hsigs: we want to use the name of the originally exported --- entity, but edit the location to refer to the reexport site -setNameLoc :: Name -> SrcSpan -> Name -setNameLoc name loc = name {n_loc = loc} - -tidyNameOcc :: Name -> OccName -> Name --- We set the OccName of a Name when tidying --- In doing so, we change System --> Internal, so that when we print --- it we don't get the unique by default. It's tidy now! -tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} -tidyNameOcc name occ = name { n_occ = occ } - --- | Make the 'Name' into an internal name, regardless of what it was to begin with -localiseName :: Name -> Name -localiseName n = n { n_sort = Internal } - --- |Create a localised variant of a name. --- --- If the name is external, encode the original's module name to disambiguate. --- SPJ says: this looks like a rather odd-looking function; but it seems to --- be used only during vectorisation, so I'm not going to worry -mkLocalisedOccName :: Module -> (Maybe String -> OccName -> OccName) -> Name -> OccName -mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name) - where - origin - | nameIsLocalOrFrom this_mod name = Nothing - | otherwise = Just (moduleNameColons . moduleName . nameModule $ name) - -{- -************************************************************************ -* * -\subsection{Hashing and comparison} -* * -************************************************************************ --} - -cmpName :: Name -> Name -> Ordering -cmpName n1 n2 = n_uniq n1 `compare` n_uniq n2 - --- | Compare Names lexicographically --- This only works for Names that originate in the source code or have been --- tidied. -stableNameCmp :: Name -> Name -> Ordering -stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) - (Name { n_sort = s2, n_occ = occ2 }) - = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) - -- The ordinary compare on OccNames is lexicographic - where - -- Later constructors are bigger - sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 - sort_cmp (External {}) _ = LT - sort_cmp (WiredIn {}) (External {}) = GT - sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 - sort_cmp (WiredIn {}) _ = LT - sort_cmp Internal (External {}) = GT - sort_cmp Internal (WiredIn {}) = GT - sort_cmp Internal Internal = EQ - sort_cmp Internal System = LT - sort_cmp System System = EQ - sort_cmp System _ = GT - -{- -************************************************************************ -* * -\subsection[Name-instances]{Instance declarations} -* * -************************************************************************ --} - -instance Eq Name where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - -instance Ord Name where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = cmpName a b - -instance Uniquable Name where - getUnique = nameUnique - -instance NamedThing Name where - getName n = n - -instance Data Name where - -- don't traverse? - toConstr _ = abstractConstr "Name" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Name" - -{- -************************************************************************ -* * -\subsection{Binary} -* * -************************************************************************ --} - --- | Assumes that the 'Name' is a non-binding one. See --- 'IfaceSyn.putIfaceTopBndr' and 'IfaceSyn.getIfaceTopBndr' for serializing --- binding 'Name's. See 'UserData' for the rationale for this distinction. -instance Binary Name where - put_ bh name = - case getUserData bh of - UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name - - get bh = - case getUserData bh of - UserData { ud_get_name = get_name } -> get_name bh - -{- -************************************************************************ -* * -\subsection{Pretty printing} -* * -************************************************************************ --} - -instance Outputable Name where - ppr name = pprName name - -instance OutputableBndr Name where - pprBndr _ name = pprName name - pprInfixOcc = pprInfixName - pprPrefixOcc = pprPrefixName - -pprName :: Name -> SDoc -pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ}) - = getPprStyle $ \ sty -> - case sort of - WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin - External mod -> pprExternal sty uniq mod occ False UserSyntax - System -> pprSystem sty uniq occ - Internal -> pprInternal sty uniq occ - where uniq = mkUniqueGrimily u - -pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc -pprExternal sty uniq mod occ is_wired is_builtin - | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ - -- In code style, always qualify - -- ToDo: maybe we could print all wired-in things unqualified - -- in code style, to reduce symbol table bloat? - | debugStyle sty = pp_mod <> ppr_occ_name occ - <> braces (hsep [if is_wired then text "(w)" else empty, - pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) - | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax - | otherwise = - if isHoleModule mod - then case qualName sty mod occ of - NameUnqual -> ppr_occ_name occ - _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) - else pprModulePrefix sty mod occ <> ppr_occ_name occ - where - pp_mod = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressModulePrefixes dflags - then empty - else ppr mod <> dot - -pprInternal :: PprStyle -> Unique -> OccName -> SDoc -pprInternal sty uniq occ - | codeStyle sty = pprUniqueAlways uniq - | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) - | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - -- For debug dumps, we're not necessarily dumping - -- tidied code, so we need to print the uniques. - | otherwise = ppr_occ_name occ -- User style - --- Like Internal, except that we only omit the unique in Iface style -pprSystem :: PprStyle -> Unique -> OccName -> SDoc -pprSystem sty uniq occ - | codeStyle sty = pprUniqueAlways uniq - | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - <> braces (pprNameSpaceBrief (occNameSpace occ)) - | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq - -- If the tidy phase hasn't run, the OccName - -- is unlikely to be informative (like 's'), - -- so print the unique - - -pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc --- Print the "M." part of a name, based on whether it's in scope or not --- See Note [Printing original names] in HscTypes -pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressModulePrefixes dflags - then empty - else - case qualName sty mod occ of -- See Outputable.QualifyName: - NameQual modname -> ppr modname <> dot -- Name is in scope - NameNotInScope1 -> ppr mod <> dot -- Not in scope - NameNotInScope2 -> ppr (moduleUnitId mod) <> colon -- Module not in - <> ppr (moduleName mod) <> dot -- scope either - NameUnqual -> empty -- In scope unqualified - -pprUnique :: Unique -> SDoc --- Print a unique unless we are suppressing them -pprUnique uniq - = sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressUniques dflags) $ - pprUniqueAlways uniq - -ppr_underscore_unique :: Unique -> SDoc --- Print an underscore separating the name from its unique --- But suppress it if we aren't printing the uniques anyway -ppr_underscore_unique uniq - = sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressUniques dflags) $ - char '_' <> pprUniqueAlways uniq - -ppr_occ_name :: OccName -> SDoc -ppr_occ_name occ = ftext (occNameFS occ) - -- Don't use pprOccName; instead, just print the string of the OccName; - -- we print the namespace in the debug stuff above - --- In code style, we Z-encode the strings. The results of Z-encoding each FastString are --- cached behind the scenes in the FastString implementation. -ppr_z_occ_name :: OccName -> SDoc -ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) - --- Prints (if mod information is available) "Defined at " or --- "Defined in " information for a Name. -pprDefinedAt :: Name -> SDoc -pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name - -pprNameDefnLoc :: Name -> SDoc --- Prints "at " or --- or "in " depending on what info is available -pprNameDefnLoc name - = case nameSrcLoc name of - -- nameSrcLoc rather than nameSrcSpan - -- It seems less cluttered to show a location - -- rather than a span for the definition point - RealSrcLoc s -> text "at" <+> ppr s - UnhelpfulLoc s - | isInternalName name || isSystemName name - -> text "at" <+> ftext s - | otherwise - -> text "in" <+> quotes (ppr (nameModule name)) - - --- | Get a string representation of a 'Name' that's unique and stable --- across recompilations. Used for deterministic generation of binds for --- derived instances. --- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String" -nameStableString :: Name -> String -nameStableString Name{..} = - nameSortStableString n_sort ++ "$" ++ occNameString n_occ - -nameSortStableString :: NameSort -> String -nameSortStableString System = "$_sys" -nameSortStableString Internal = "$_in" -nameSortStableString (External mod) = moduleStableString mod -nameSortStableString (WiredIn mod _ _) = moduleStableString mod - -{- -************************************************************************ -* * -\subsection{Overloaded functions related to Names} -* * -************************************************************************ --} - --- | A class allowing convenient access to the 'Name' of various datatypes -class NamedThing a where - getOccName :: a -> OccName - getName :: a -> Name - - getOccName n = nameOccName (getName n) -- Default method - -instance NamedThing e => NamedThing (GenLocated l e) where - getName = getName . unLoc - -getSrcLoc :: NamedThing a => a -> SrcLoc -getSrcSpan :: NamedThing a => a -> SrcSpan -getOccString :: NamedThing a => a -> String -getOccFS :: NamedThing a => a -> FastString - -getSrcLoc = nameSrcLoc . getName -getSrcSpan = nameSrcSpan . getName -getOccString = occNameString . getOccName -getOccFS = occNameFS . getOccName - -pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc --- See Outputable.pprPrefixVar, pprInfixVar; --- add parens or back-quotes as appropriate -pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) - -pprPrefixName :: NamedThing a => a -> SDoc -pprPrefixName thing - | name `hasKey` starKindTyConKey || name `hasKey` unicodeStarKindTyConKey - = ppr name -- See Note [Special treatment for kind *] - | otherwise - = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) - where - name = getName thing - -{- -Note [Special treatment for kind *] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do not put parens around the kind '*'. Even though it looks like -an operator, it is really a special case. - -This pprPrefixName stuff is really only used when printing HsSyn, -which has to be polymorphic in the name type, and hence has to go via -the overloaded function pprPrefixOcc. It's easier where we know the -type being pretty printed; eg the pretty-printing code in TyCoRep. - -See Trac #7645, which led to this. --} diff --git a/basicTypes/Name.hs-boot b/basicTypes/Name.hs-boot deleted file mode 100644 --- a/basicTypes/Name.hs-boot +++ /dev/null @@ -1,3 +0,0 @@ -module Name where - -data Name diff --git a/basicTypes/NameCache.hs b/basicTypes/NameCache.hs deleted file mode 100644 --- a/basicTypes/NameCache.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} - --- | The Name Cache -module NameCache - ( lookupOrigNameCache - , extendOrigNameCache - , extendNameCache - , initNameCache - , NameCache(..), OrigNameCache - ) where - -import Module -import Name -import UniqSupply -import TysWiredIn -import Util -import Outputable -import PrelNames - -#include "HsVersions.h" - -{- - -Note [The Name Cache] -~~~~~~~~~~~~~~~~~~~~~ -The Name Cache makes sure that, during any invocation of GHC, each -External Name "M.x" has one, and only one globally-agreed Unique. - -* The first time we come across M.x we make up a Unique and record that - association in the Name Cache. - -* When we come across "M.x" again, we look it up in the Name Cache, - and get a hit. - -The functions newGlobalBinder, allocateGlobalBinder do the main work. -When you make an External name, you should probably be calling one -of them. - - -Note [Built-in syntax and the OrigNameCache] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower -their cost we use two tricks, - - a. We specially encode tuple and sum Names in interface files' symbol tables - to avoid having to look up their names while loading interface files. - Namely these names are encoded as by their Uniques. We know how to get from - a Unique back to the Name which it represents via the mapping defined in - the SumTupleUniques module. See Note [Symbol table representation of names] - in BinIface and for details. - - b. We don't include them in the Orig name cache but instead parse their - OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with - them. - -Why is the second measure necessary? Good question; afterall, 1) the parser -emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never -needs to looked-up during interface loading due to (a). It turns out that there -are two reasons why we might look up an Orig RdrName for built-in syntax, - - * If you use setRdrNameSpace on an Exact RdrName it may be - turned into an Orig RdrName. - - * Template Haskell turns a BuiltInSyntax Name into a TH.NameG - (DsMeta.globalVar), and parses a NameG into an Orig RdrName - (Convert.thRdrName). So, e.g. $(do { reify '(,); ... }) will - go this route (Trac #8954). - --} - --- | Per-module cache of original 'OccName's given 'Name's -type OrigNameCache = ModuleEnv (OccEnv Name) - -lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name -lookupOrigNameCache nc mod occ - | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE - , Just name <- isBuiltInOcc_maybe occ - = -- See Note [Known-key names], 3(c) in PrelNames - -- Special case for tuples; there are too many - -- of them to pre-populate the original-name cache - Just name - - | otherwise - = case lookupModuleEnv nc mod of - Nothing -> Nothing - Just occ_env -> lookupOccEnv occ_env occ - -extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache -extendOrigNameCache nc name - = ASSERT2( isExternalName name, ppr name ) - extendNameCache nc (nameModule name) (nameOccName name) name - -extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache -extendNameCache nc mod occ name - = extendModuleEnvWith combine nc mod (unitOccEnv occ name) - where - combine _ occ_env = extendOccEnv occ_env occ name - --- | The NameCache makes sure that there is just one Unique assigned for --- each original name; i.e. (module-name, occ-name) pair and provides --- something of a lookup mechanism for those names. -data NameCache - = NameCache { nsUniqs :: !UniqSupply, - -- ^ Supply of uniques - nsNames :: !OrigNameCache - -- ^ Ensures that one original name gets one unique - } - --- | Return a function to atomically update the name cache. -initNameCache :: UniqSupply -> [Name] -> NameCache -initNameCache us names - = NameCache { nsUniqs = us, - nsNames = initOrigNames names } - -initOrigNames :: [Name] -> OrigNameCache -initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names diff --git a/basicTypes/NameEnv.hs b/basicTypes/NameEnv.hs deleted file mode 100644 --- a/basicTypes/NameEnv.hs +++ /dev/null @@ -1,151 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[NameEnv]{@NameEnv@: name environments} --} - -{-# LANGUAGE CPP #-} -module NameEnv ( - -- * Var, Id and TyVar environments (maps) - NameEnv, - - -- ** Manipulating these environments - mkNameEnv, - emptyNameEnv, isEmptyNameEnv, - unitNameEnv, nameEnvElts, - extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, - extendNameEnvList, extendNameEnvList_C, - filterNameEnv, anyNameEnv, - plusNameEnv, plusNameEnv_C, alterNameEnv, - lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, - elemNameEnv, mapNameEnv, disjointNameEnv, - - DNameEnv, - - emptyDNameEnv, - lookupDNameEnv, - mapDNameEnv, - alterDNameEnv, - -- ** Dependency analysis - depAnal - ) where - -#include "HsVersions.h" - -import Digraph -import Name -import UniqFM -import UniqDFM -import Maybes - -{- -************************************************************************ -* * -\subsection{Name environment} -* * -************************************************************************ --} - -{- -Note [depAnal determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -depAnal is deterministic provided it gets the nodes in a deterministic order. -The order of lists that get_defs and get_uses return doesn't matter, as these -are only used to construct the edges, and stronglyConnCompFromEdgedVertices is -deterministic even when the edges are not in deterministic order as explained -in Note [Deterministic SCC] in Digraph. --} - -depAnal :: (node -> [Name]) -- Defs - -> (node -> [Name]) -- Uses - -> [node] - -> [SCC node] --- Peform dependency analysis on a group of definitions, --- where each definition may define more than one Name --- --- The get_defs and get_uses functions are called only once per node -depAnal get_defs get_uses nodes - = stronglyConnCompFromEdgedVerticesUniq (map mk_node keyed_nodes) - where - keyed_nodes = nodes `zip` [(1::Int)..] - mk_node (node, key) = (node, key, mapMaybe (lookupNameEnv key_map) (get_uses node)) - - key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it - key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] - -{- -************************************************************************ -* * -\subsection{Name environment} -* * -************************************************************************ --} - --- | Name Environment -type NameEnv a = UniqFM a -- Domain is Name - -emptyNameEnv :: NameEnv a -isEmptyNameEnv :: NameEnv a -> Bool -mkNameEnv :: [(Name,a)] -> NameEnv a -nameEnvElts :: NameEnv a -> [a] -alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a -extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b -extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a -plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a -plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a -extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a -extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a -delFromNameEnv :: NameEnv a -> Name -> NameEnv a -delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a -elemNameEnv :: Name -> NameEnv a -> Bool -unitNameEnv :: Name -> a -> NameEnv a -lookupNameEnv :: NameEnv a -> Name -> Maybe a -lookupNameEnv_NF :: NameEnv a -> Name -> a -filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt -anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool -mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 -disjointNameEnv :: NameEnv a -> NameEnv a -> Bool - -nameEnvElts x = eltsUFM x -emptyNameEnv = emptyUFM -isEmptyNameEnv = isNullUFM -unitNameEnv x y = unitUFM x y -extendNameEnv x y z = addToUFM x y z -extendNameEnvList x l = addListToUFM x l -lookupNameEnv x y = lookupUFM x y -alterNameEnv = alterUFM -mkNameEnv l = listToUFM l -elemNameEnv x y = elemUFM x y -plusNameEnv x y = plusUFM x y -plusNameEnv_C f x y = plusUFM_C f x y -extendNameEnv_C f x y z = addToUFM_C f x y z -mapNameEnv f x = mapUFM f x -extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b -extendNameEnvList_C x y z = addListToUFM_C x y z -delFromNameEnv x y = delFromUFM x y -delListFromNameEnv x y = delListFromUFM x y -filterNameEnv x y = filterUFM x y -anyNameEnv f x = foldUFM ((||) . f) False x -disjointNameEnv x y = isNullUFM (intersectUFM x y) - -lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) - --- | Deterministic Name Environment --- --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DNameEnv. -type DNameEnv a = UniqDFM a - -emptyDNameEnv :: DNameEnv a -emptyDNameEnv = emptyUDFM - -lookupDNameEnv :: DNameEnv a -> Name -> Maybe a -lookupDNameEnv = lookupUDFM - -mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b -mapDNameEnv = mapUDFM - -alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a -alterDNameEnv = alterUDFM diff --git a/basicTypes/NameSet.hs b/basicTypes/NameSet.hs deleted file mode 100644 --- a/basicTypes/NameSet.hs +++ /dev/null @@ -1,212 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 --} - -{-# LANGUAGE CPP #-} -module NameSet ( - -- * Names set type - NameSet, - - -- ** Manipulating these sets - emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, - minusNameSet, elemNameSet, extendNameSet, extendNameSetList, - delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet, - intersectsNameSet, intersectNameSet, - nameSetAny, nameSetAll, nameSetElemsStable, - - -- * Free variables - FreeVars, - - -- ** Manipulating sets of free variables - isEmptyFVs, emptyFVs, plusFVs, plusFV, - mkFVs, addOneFV, unitFV, delFV, delFVs, - intersectFVs, - - -- * Defs and uses - Defs, Uses, DefUse, DefUses, - - -- ** Manipulating defs and uses - emptyDUs, usesOnly, mkDUs, plusDU, - findUses, duDefs, duUses, allUses - ) where - -#include "HsVersions.h" - -import Name -import UniqSet -import Data.List (sortBy) - -{- -************************************************************************ -* * -\subsection[Sets of names} -* * -************************************************************************ --} - -type NameSet = UniqSet Name - -emptyNameSet :: NameSet -unitNameSet :: Name -> NameSet -extendNameSetList :: NameSet -> [Name] -> NameSet -extendNameSet :: NameSet -> Name -> NameSet -mkNameSet :: [Name] -> NameSet -unionNameSet :: NameSet -> NameSet -> NameSet -unionNameSets :: [NameSet] -> NameSet -minusNameSet :: NameSet -> NameSet -> NameSet -elemNameSet :: Name -> NameSet -> Bool -isEmptyNameSet :: NameSet -> Bool -delFromNameSet :: NameSet -> Name -> NameSet -delListFromNameSet :: NameSet -> [Name] -> NameSet -filterNameSet :: (Name -> Bool) -> NameSet -> NameSet -intersectNameSet :: NameSet -> NameSet -> NameSet -intersectsNameSet :: NameSet -> NameSet -> Bool --- ^ True if there is a non-empty intersection. --- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty - -isEmptyNameSet = isEmptyUniqSet -emptyNameSet = emptyUniqSet -unitNameSet = unitUniqSet -mkNameSet = mkUniqSet -extendNameSetList = addListToUniqSet -extendNameSet = addOneToUniqSet -unionNameSet = unionUniqSets -unionNameSets = unionManyUniqSets -minusNameSet = minusUniqSet -elemNameSet = elementOfUniqSet -delFromNameSet = delOneFromUniqSet -filterNameSet = filterUniqSet -intersectNameSet = intersectUniqSets - -delListFromNameSet set ns = foldl delFromNameSet set ns - -intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) - -nameSetAny :: (Name -> Bool) -> NameSet -> Bool -nameSetAny = uniqSetAny - -nameSetAll :: (Name -> Bool) -> NameSet -> Bool -nameSetAll = uniqSetAll - --- | Get the elements of a NameSet with some stable ordering. --- This only works for Names that originate in the source code or have been --- tidied. --- See Note [Deterministic UniqFM] to learn about nondeterminism -nameSetElemsStable :: NameSet -> [Name] -nameSetElemsStable ns = - sortBy stableNameCmp $ nonDetEltsUniqSet ns - -- It's OK to use nonDetEltsUniqSet here because we immediately sort - -- with stableNameCmp - -{- -************************************************************************ -* * -\subsection{Free variables} -* * -************************************************************************ - -These synonyms are useful when we are thinking of free variables --} - -type FreeVars = NameSet - -plusFV :: FreeVars -> FreeVars -> FreeVars -addOneFV :: FreeVars -> Name -> FreeVars -unitFV :: Name -> FreeVars -emptyFVs :: FreeVars -plusFVs :: [FreeVars] -> FreeVars -mkFVs :: [Name] -> FreeVars -delFV :: Name -> FreeVars -> FreeVars -delFVs :: [Name] -> FreeVars -> FreeVars -intersectFVs :: FreeVars -> FreeVars -> FreeVars - -isEmptyFVs :: NameSet -> Bool -isEmptyFVs = isEmptyNameSet -emptyFVs = emptyNameSet -plusFVs = unionNameSets -plusFV = unionNameSet -mkFVs = mkNameSet -addOneFV = extendNameSet -unitFV = unitNameSet -delFV n s = delFromNameSet s n -delFVs ns s = delListFromNameSet s ns -intersectFVs = intersectNameSet - -{- -************************************************************************ -* * - Defs and uses -* * -************************************************************************ --} - --- | A set of names that are defined somewhere -type Defs = NameSet - --- | A set of names that are used somewhere -type Uses = NameSet - --- | @(Just ds, us) =>@ The use of any member of the @ds@ --- implies that all the @us@ are used too. --- Also, @us@ may mention @ds@. --- --- @Nothing =>@ Nothing is defined in this group, but --- nevertheless all the uses are essential. --- Used for instance declarations, for example -type DefUse = (Maybe Defs, Uses) - --- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' --- In a single (def, use) pair, the defs also scope over the uses -type DefUses = [DefUse] - -emptyDUs :: DefUses -emptyDUs = [] - -usesOnly :: Uses -> DefUses -usesOnly uses = [(Nothing, uses)] - -mkDUs :: [(Defs,Uses)] -> DefUses -mkDUs pairs = [(Just defs, uses) | (defs,uses) <- pairs] - -plusDU :: DefUses -> DefUses -> DefUses -plusDU = (++) - -duDefs :: DefUses -> Defs -duDefs dus = foldr get emptyNameSet dus - where - get (Nothing, _u1) d2 = d2 - get (Just d1, _u1) d2 = d1 `unionNameSet` d2 - -allUses :: DefUses -> Uses --- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned -allUses dus = foldr get emptyNameSet dus - where - get (_d1, u1) u2 = u1 `unionNameSet` u2 - -duUses :: DefUses -> Uses --- ^ Collect all 'Uses', regardless of whether the group is itself used, --- but remove 'Defs' on the way -duUses dus = foldr get emptyNameSet dus - where - get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses - get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses) - `minusNameSet` defs - -findUses :: DefUses -> Uses -> Uses --- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. --- The result is a superset of the input 'Uses'; and includes things defined --- in the input 'DefUses' (but only if they are used) -findUses dus uses - = foldr get uses dus - where - get (Nothing, rhs_uses) uses - = rhs_uses `unionNameSet` uses - get (Just defs, rhs_uses) uses - | defs `intersectsNameSet` uses -- Used - || nameSetAny (startsWithUnderscore . nameOccName) defs - -- At least one starts with an "_", - -- so treat the group as used - = rhs_uses `unionNameSet` uses - | otherwise -- No def is used - = uses diff --git a/basicTypes/OccName.hs b/basicTypes/OccName.hs deleted file mode 100644 --- a/basicTypes/OccName.hs +++ /dev/null @@ -1,959 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName' represents names as strings with just a little more information: --- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or --- data constructors --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" - -module OccName ( - -- * The 'NameSpace' type - NameSpace, -- Abstract - - nameSpacesRelated, - - -- ** Construction - -- $real_vs_source_data_constructors - tcName, clsName, tcClsName, dataName, varName, - tvName, srcDataName, - - -- ** Pretty Printing - pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, - - -- * The 'OccName' type - OccName, -- Abstract, instance of Outputable - pprOccName, - - -- ** Construction - mkOccName, mkOccNameFS, - mkVarOcc, mkVarOccFS, - mkDataOcc, mkDataOccFS, - mkTyVarOcc, mkTyVarOccFS, - mkTcOcc, mkTcOccFS, - mkClsOcc, mkClsOccFS, - mkDFunOcc, - setOccNameSpace, - demoteOccName, - HasOccName(..), - - -- ** Derived 'OccName's - isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, - mkMatcherOcc, mkBuilderOcc, - mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc, - mkNewTyCoOcc, mkClassOpAuxOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, - mkClassDataConOcc, mkDictOcc, mkIPOcc, - mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, - mkGenR, mkGen1R, - mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, - mkSuperDictSelOcc, mkSuperDictAuxOcc, - mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, - mkInstTyCoOcc, mkEqPredCoOcc, - mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, - mkPDataTyConOcc, mkPDataDataConOcc, - mkPDatasTyConOcc, mkPDatasDataConOcc, - mkPReprTyConOcc, - mkPADFunOcc, - mkRecFldSelOcc, - mkTyConRepOcc, - - -- ** Deconstruction - occNameFS, occNameString, occNameSpace, - - isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, - parenSymOcc, startsWithUnderscore, - - isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, - - -- * The 'OccEnv' type - OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, - lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, - occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, - extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, - alterOccEnv, pprOccEnv, - - -- * The 'OccSet' type - OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, - extendOccSetList, - unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, - isEmptyOccSet, intersectOccSet, intersectsOccSet, - filterOccSet, - - -- * Tidying up - TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, - tidyOccName, - tidyOccNames, avoidClashesOccEnv, - - -- FsEnv - FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv - ) where - -import Util -import Unique -import DynFlags -import UniqFM -import UniqSet -import FastString -import FastStringEnv -import Outputable -import Lexeme -import Binary -import Control.DeepSeq -import Data.List (mapAccumL) -import Data.Char -import Data.Data - -{- -************************************************************************ -* * -\subsection{Name space} -* * -************************************************************************ --} - -data NameSpace = VarName -- Variables, including "real" data constructors - | DataName -- "Source" data constructors - | TvName -- Type variables - | TcClsName -- Type constructors and classes; Haskell has them - -- in the same name space for now. - deriving( Eq, Ord ) - --- Note [Data Constructors] --- see also: Note [Data Constructor Naming] in DataCon.hs --- --- $real_vs_source_data_constructors --- There are two forms of data constructor: --- --- [Source data constructors] The data constructors mentioned in Haskell source code --- --- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type --- --- For example: --- --- > data T = T !(Int, Int) --- --- The source datacon has type @(Int, Int) -> T@ --- The real datacon has type @Int -> Int -> T@ --- --- GHC chooses a representation based on the strictness etc. - -tcName, clsName, tcClsName :: NameSpace -dataName, srcDataName :: NameSpace -tvName, varName :: NameSpace - --- Though type constructors and classes are in the same name space now, --- the NameSpace type is abstract, so we can easily separate them later -tcName = TcClsName -- Type constructors -clsName = TcClsName -- Classes -tcClsName = TcClsName -- Not sure which! - -dataName = DataName -srcDataName = DataName -- Haskell-source data constructors should be - -- in the Data name space - -tvName = TvName -varName = VarName - -isDataConNameSpace :: NameSpace -> Bool -isDataConNameSpace DataName = True -isDataConNameSpace _ = False - -isTcClsNameSpace :: NameSpace -> Bool -isTcClsNameSpace TcClsName = True -isTcClsNameSpace _ = False - -isTvNameSpace :: NameSpace -> Bool -isTvNameSpace TvName = True -isTvNameSpace _ = False - -isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors -isVarNameSpace TvName = True -isVarNameSpace VarName = True -isVarNameSpace _ = False - -isValNameSpace :: NameSpace -> Bool -isValNameSpace DataName = True -isValNameSpace VarName = True -isValNameSpace _ = False - -pprNameSpace :: NameSpace -> SDoc -pprNameSpace DataName = text "data constructor" -pprNameSpace VarName = text "variable" -pprNameSpace TvName = text "type variable" -pprNameSpace TcClsName = text "type constructor or class" - -pprNonVarNameSpace :: NameSpace -> SDoc -pprNonVarNameSpace VarName = empty -pprNonVarNameSpace ns = pprNameSpace ns - -pprNameSpaceBrief :: NameSpace -> SDoc -pprNameSpaceBrief DataName = char 'd' -pprNameSpaceBrief VarName = char 'v' -pprNameSpaceBrief TvName = text "tv" -pprNameSpaceBrief TcClsName = text "tc" - --- demoteNameSpace lowers the NameSpace if possible. We can not know --- in advance, since a TvName can appear in an HsTyVar. --- See Note [Demotion] in RnEnv -demoteNameSpace :: NameSpace -> Maybe NameSpace -demoteNameSpace VarName = Nothing -demoteNameSpace DataName = Nothing -demoteNameSpace TvName = Nothing -demoteNameSpace TcClsName = Just DataName - -{- -************************************************************************ -* * -\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} -* * -************************************************************************ --} - --- | Occurrence Name --- --- In this context that means: --- "classified (i.e. as a type name, value name, etc) but not qualified --- and not yet resolved" -data OccName = OccName - { occNameSpace :: !NameSpace - , occNameFS :: !FastString - } - -instance Eq OccName where - (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 - -instance Ord OccName where - -- Compares lexicographically, *not* by Unique of the string - compare (OccName sp1 s1) (OccName sp2 s2) - = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) - -instance Data OccName where - -- don't traverse? - toConstr _ = abstractConstr "OccName" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "OccName" - -instance HasOccName OccName where - occName = id - -instance NFData OccName where - rnf x = x `seq` () - -{- -************************************************************************ -* * -\subsection{Printing} -* * -************************************************************************ --} - -instance Outputable OccName where - ppr = pprOccName - -instance OutputableBndr OccName where - pprBndr _ = ppr - pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) - pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) - -pprOccName :: OccName -> SDoc -pprOccName (OccName sp occ) - = getPprStyle $ \ sty -> - if codeStyle sty - then ztext (zEncodeFS occ) - else pp_occ <> pp_debug sty - where - pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) - | otherwise = empty - - pp_occ = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressUniques dflags - then text (strip_th_unique (unpackFS occ)) - else ftext occ - - -- See Note [Suppressing uniques in OccNames] - strip_th_unique ('[' : c : _) | isAlphaNum c = [] - strip_th_unique (c : cs) = c : strip_th_unique cs - strip_th_unique [] = [] - -{- -Note [Suppressing uniques in OccNames] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This is a hack to de-wobblify the OccNames that contain uniques from -Template Haskell that have been turned into a string in the OccName. -See Note [Unique OccNames from Template Haskell] in Convert.hs - -************************************************************************ -* * -\subsection{Construction} -* * -************************************************************************ --} - -mkOccName :: NameSpace -> String -> OccName -mkOccName occ_sp str = OccName occ_sp (mkFastString str) - -mkOccNameFS :: NameSpace -> FastString -> OccName -mkOccNameFS occ_sp fs = OccName occ_sp fs - -mkVarOcc :: String -> OccName -mkVarOcc s = mkOccName varName s - -mkVarOccFS :: FastString -> OccName -mkVarOccFS fs = mkOccNameFS varName fs - -mkDataOcc :: String -> OccName -mkDataOcc = mkOccName dataName - -mkDataOccFS :: FastString -> OccName -mkDataOccFS = mkOccNameFS dataName - -mkTyVarOcc :: String -> OccName -mkTyVarOcc = mkOccName tvName - -mkTyVarOccFS :: FastString -> OccName -mkTyVarOccFS fs = mkOccNameFS tvName fs - -mkTcOcc :: String -> OccName -mkTcOcc = mkOccName tcName - -mkTcOccFS :: FastString -> OccName -mkTcOccFS = mkOccNameFS tcName - -mkClsOcc :: String -> OccName -mkClsOcc = mkOccName clsName - -mkClsOccFS :: FastString -> OccName -mkClsOccFS = mkOccNameFS clsName - --- demoteOccName lowers the Namespace of OccName. --- see Note [Demotion] -demoteOccName :: OccName -> Maybe OccName -demoteOccName (OccName space name) = do - space' <- demoteNameSpace space - return $ OccName space' name - --- Name spaces are related if there is a chance to mean the one when one writes --- the other, i.e. variables <-> data constructors and type variables <-> type constructors -nameSpacesRelated :: NameSpace -> NameSpace -> Bool -nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2 - -otherNameSpace :: NameSpace -> NameSpace -otherNameSpace VarName = DataName -otherNameSpace DataName = VarName -otherNameSpace TvName = TcClsName -otherNameSpace TcClsName = TvName - - - -{- | Other names in the compiler add additional information to an OccName. -This class provides a consistent way to access the underlying OccName. -} -class HasOccName name where - occName :: name -> OccName - -{- -************************************************************************ -* * - Environments -* * -************************************************************************ - -OccEnvs are used mainly for the envts in ModIfaces. - -Note [The Unique of an OccName] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -They are efficient, because FastStrings have unique Int# keys. We assume -this key is less than 2^24, and indeed FastStrings are allocated keys -sequentially starting at 0. - -So we can make a Unique using - mkUnique ns key :: Unique -where 'ns' is a Char representing the name space. This in turn makes it -easy to build an OccEnv. --} - -instance Uniquable OccName where - -- See Note [The Unique of an OccName] - getUnique (OccName VarName fs) = mkVarOccUnique fs - getUnique (OccName DataName fs) = mkDataOccUnique fs - getUnique (OccName TvName fs) = mkTvOccUnique fs - getUnique (OccName TcClsName fs) = mkTcOccUnique fs - -newtype OccEnv a = A (UniqFM a) - deriving Data - -emptyOccEnv :: OccEnv a -unitOccEnv :: OccName -> a -> OccEnv a -extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a -extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a -lookupOccEnv :: OccEnv a -> OccName -> Maybe a -mkOccEnv :: [(OccName,a)] -> OccEnv a -mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a -elemOccEnv :: OccName -> OccEnv a -> Bool -foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b -occEnvElts :: OccEnv a -> [a] -extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a -extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b -plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a -plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a -mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b -delFromOccEnv :: OccEnv a -> OccName -> OccEnv a -delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a -filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt -alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt - -emptyOccEnv = A emptyUFM -unitOccEnv x y = A $ unitUFM x y -extendOccEnv (A x) y z = A $ addToUFM x y z -extendOccEnvList (A x) l = A $ addListToUFM x l -lookupOccEnv (A x) y = lookupUFM x y -mkOccEnv l = A $ listToUFM l -elemOccEnv x (A y) = elemUFM x y -foldOccEnv a b (A c) = foldUFM a b c -occEnvElts (A x) = eltsUFM x -plusOccEnv (A x) (A y) = A $ plusUFM x y -plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y -extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z -extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z -mapOccEnv f (A x) = A $ mapUFM f x -mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l -delFromOccEnv (A x) y = A $ delFromUFM x y -delListFromOccEnv (A x) y = A $ delListFromUFM x y -filterOccEnv x (A y) = A $ filterUFM x y -alterOccEnv fn (A y) k = A $ alterUFM fn y k - -instance Outputable a => Outputable (OccEnv a) where - ppr x = pprOccEnv ppr x - -pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc -pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env - -type OccSet = UniqSet OccName - -emptyOccSet :: OccSet -unitOccSet :: OccName -> OccSet -mkOccSet :: [OccName] -> OccSet -extendOccSet :: OccSet -> OccName -> OccSet -extendOccSetList :: OccSet -> [OccName] -> OccSet -unionOccSets :: OccSet -> OccSet -> OccSet -unionManyOccSets :: [OccSet] -> OccSet -minusOccSet :: OccSet -> OccSet -> OccSet -elemOccSet :: OccName -> OccSet -> Bool -isEmptyOccSet :: OccSet -> Bool -intersectOccSet :: OccSet -> OccSet -> OccSet -intersectsOccSet :: OccSet -> OccSet -> Bool -filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet - -emptyOccSet = emptyUniqSet -unitOccSet = unitUniqSet -mkOccSet = mkUniqSet -extendOccSet = addOneToUniqSet -extendOccSetList = addListToUniqSet -unionOccSets = unionUniqSets -unionManyOccSets = unionManyUniqSets -minusOccSet = minusUniqSet -elemOccSet = elementOfUniqSet -isEmptyOccSet = isEmptyUniqSet -intersectOccSet = intersectUniqSets -intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) -filterOccSet = filterUniqSet - -{- -************************************************************************ -* * -\subsection{Predicates and taking them apart} -* * -************************************************************************ --} - -occNameString :: OccName -> String -occNameString (OccName _ s) = unpackFS s - -setOccNameSpace :: NameSpace -> OccName -> OccName -setOccNameSpace sp (OccName _ occ) = OccName sp occ - -isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool - -isVarOcc (OccName VarName _) = True -isVarOcc _ = False - -isTvOcc (OccName TvName _) = True -isTvOcc _ = False - -isTcOcc (OccName TcClsName _) = True -isTcOcc _ = False - --- | /Value/ 'OccNames's are those that are either in --- the variable or data constructor namespaces -isValOcc :: OccName -> Bool -isValOcc (OccName VarName _) = True -isValOcc (OccName DataName _) = True -isValOcc _ = False - -isDataOcc (OccName DataName _) = True -isDataOcc _ = False - --- | Test if the 'OccName' is a data constructor that starts with --- a symbol (e.g. @:@, or @[]@) -isDataSymOcc :: OccName -> Bool -isDataSymOcc (OccName DataName s) = isLexConSym s -isDataSymOcc _ = False --- Pretty inefficient! - --- | Test if the 'OccName' is that for any operator (whether --- it is a data constructor or variable or whatever) -isSymOcc :: OccName -> Bool -isSymOcc (OccName DataName s) = isLexConSym s -isSymOcc (OccName TcClsName s) = isLexSym s -isSymOcc (OccName VarName s) = isLexSym s -isSymOcc (OccName TvName s) = isLexSym s --- Pretty inefficient! - -parenSymOcc :: OccName -> SDoc -> SDoc --- ^ Wrap parens around an operator -parenSymOcc occ doc | isSymOcc occ = parens doc - | otherwise = doc - -startsWithUnderscore :: OccName -> Bool --- ^ Haskell 98 encourages compilers to suppress warnings about unsed --- names in a pattern if they start with @_@: this implements that test -startsWithUnderscore occ = headFS (occNameFS occ) == '_' - -{- -************************************************************************ -* * -\subsection{Making system names} -* * -************************************************************************ - -Here's our convention for splitting up the interface file name space: - - d... dictionary identifiers - (local variables, so no name-clash worries) - -All of these other OccNames contain a mixture of alphabetic -and symbolic characters, and hence cannot possibly clash with -a user-written type or function name - - $f... Dict-fun identifiers (from inst decls) - $dmop Default method for 'op' - $pnC n'th superclass selector for class C - $wf Worker for function 'f' - $sf.. Specialised version of f - D:C Data constructor for dictionary for class C - NTCo:T Coercion connecting newtype T with its representation type - TFCo:R Coercion connecting a data family to its representation type R - -In encoded form these appear as Zdfxxx etc - - :... keywords (export:, letrec: etc.) ---- I THINK THIS IS WRONG! - -This knowledge is encoded in the following functions. - -@mk_deriv@ generates an @OccName@ from the prefix and a string. -NB: The string must already be encoded! --} - --- | Build an 'OccName' derived from another 'OccName'. --- --- Note that the pieces of the name are passed in as a @[FastString]@ so that --- the whole name can be constructed with a single 'concatFS', minimizing --- unnecessary intermediate allocations. -mk_deriv :: NameSpace - -> FastString -- ^ A prefix which distinguishes one sort of - -- derived name from another - -> [FastString] -- ^ The name we are deriving from in pieces which - -- will be concatenated. - -> OccName -mk_deriv occ_sp sys_prefix str = - mkOccNameFS occ_sp (concatFS $ sys_prefix : str) - -isDerivedOccName :: OccName -> Bool --- ^ Test for definitions internally generated by GHC. This predicte --- is used to suppress printing of internal definitions in some debug prints -isDerivedOccName occ = - case occNameString occ of - '$':c:_ | isAlphaNum c -> True -- E.g. $wfoo - c:':':_ | isAlphaNum c -> True -- E.g. N:blah newtype coercions - _other -> False - -isDefaultMethodOcc :: OccName -> Bool -isDefaultMethodOcc occ = - case occNameString occ of - '$':'d':'m':_ -> True - _ -> False - --- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding? --- This is needed as these bindings are renamed differently. --- See Note [Grand plan for Typeable] in TcTypeable. -isTypeableBindOcc :: OccName -> Bool -isTypeableBindOcc occ = - case occNameString occ of - '$':'t':'c':_ -> True -- mkTyConRepOcc - '$':'t':'r':_ -> True -- Module binding - _ -> False - -mkDataConWrapperOcc, mkWorkerOcc, - mkMatcherOcc, mkBuilderOcc, - mkDefaultMethodOcc, - mkClassDataConOcc, mkDictOcc, - mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, - mkGenR, mkGen1R, - mkDataConWorkerOcc, mkNewTyCoOcc, - mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, - mkTyConRepOcc - :: OccName -> OccName - --- These derived variables have a prefix that no Haskell value could have -mkDataConWrapperOcc = mk_simple_deriv varName "$W" -mkWorkerOcc = mk_simple_deriv varName "$w" -mkMatcherOcc = mk_simple_deriv varName "$m" -mkBuilderOcc = mk_simple_deriv varName "$b" -mkDefaultMethodOcc = mk_simple_deriv varName "$dm" -mkClassOpAuxOcc = mk_simple_deriv varName "$c" -mkDictOcc = mk_simple_deriv varName "$d" -mkIPOcc = mk_simple_deriv varName "$i" -mkSpecOcc = mk_simple_deriv varName "$s" -mkForeignExportOcc = mk_simple_deriv varName "$f" -mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible -mkClassDataConOcc = mk_simple_deriv dataName "C:" -- Data con for a class -mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes -mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions -mkEqPredCoOcc = mk_simple_deriv tcName "$co" - --- Used in derived instances -mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" -mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" -mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" - --- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable -mkTyConRepOcc occ = mk_simple_deriv varName prefix occ - where - prefix | isDataOcc occ = "$tc'" - | otherwise = "$tc" - --- Generic deriving mechanism -mkGenR = mk_simple_deriv tcName "Rep_" -mkGen1R = mk_simple_deriv tcName "Rep1_" - --- Vectorisation -mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, - mkPADFunOcc, mkPReprTyConOcc, - mkPDataTyConOcc, mkPDataDataConOcc, - mkPDatasTyConOcc, mkPDatasDataConOcc - :: Maybe String -> OccName -> OccName -mkVectOcc = mk_simple_deriv_with varName "$v" -mkVectTyConOcc = mk_simple_deriv_with tcName "V:" -mkVectDataConOcc = mk_simple_deriv_with dataName "VD:" -mkVectIsoOcc = mk_simple_deriv_with varName "$vi" -mkPADFunOcc = mk_simple_deriv_with varName "$pa" -mkPReprTyConOcc = mk_simple_deriv_with tcName "VR:" -mkPDataTyConOcc = mk_simple_deriv_with tcName "VP:" -mkPDatasTyConOcc = mk_simple_deriv_with tcName "VPs:" -mkPDataDataConOcc = mk_simple_deriv_with dataName "VPD:" -mkPDatasDataConOcc = mk_simple_deriv_with dataName "VPDs:" - --- Overloaded record field selectors -mkRecFldSelOcc :: String -> OccName -mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] - -mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName -mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] - -mk_simple_deriv_with :: NameSpace -- ^ the namespace - -> FastString -- ^ an identifying prefix - -> Maybe String -- ^ another optional prefix - -> OccName -- ^ the 'OccName' to derive from - -> OccName -mk_simple_deriv_with sp px Nothing occ = mk_deriv sp px [occNameFS occ] -mk_simple_deriv_with sp px (Just with) occ = - mk_deriv sp px [fsLit with, fsLit "_", occNameFS occ] - --- Data constructor workers are made by setting the name space --- of the data constructor OccName (which should be a DataName) --- to VarName -mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ - -mkSuperDictAuxOcc :: Int -> OccName -> OccName -mkSuperDictAuxOcc index cls_tc_occ - = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ] - -mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 - -> OccName -- ^ Class, e.g. @Ord@ - -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ -mkSuperDictSelOcc index cls_tc_occ - = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ] - -mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' - -> OccName -- ^ Local name, e.g. @sat@ - -> OccName -- ^ Nice unique version, e.g. @$L23sat@ -mkLocalOcc uniq occ - = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ] - -- The Unique might print with characters - -- that need encoding (e.g. 'z'!) - --- | Derive a name for the representation type constructor of a --- @data@\/@newtype@ instance. -mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ @R:Map@ -mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str) - -mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. - -- Only used in debug mode, for extra clarity - -> Bool -- ^ Is this a hs-boot instance DFun? - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ E.g. @$f3OrdMaybe@ - --- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real --- thing when we compile the mother module. Reason: we don't know exactly --- what the mother module will call it. - -mkDFunOcc info_str is_boot set - = chooseUniqueOcc VarName (prefix ++ info_str) set - where - prefix | is_boot = "$fx" - | otherwise = "$f" - -mkDataTOcc, mkDataCOcc - :: OccName -- ^ TyCon or data con string - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ E.g. @$f3OrdMaybe@ --- data T = MkT ... deriving( Data ) needs definitions for --- $tT :: Data.Generics.Basics.DataType --- $cMkT :: Data.Generics.Basics.Constr -mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ) -mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ) - -{- -Sometimes we need to pick an OccName that has not already been used, -given a set of in-use OccNames. --} - -chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName -chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) - where - loop occ n - | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) - | otherwise = occ - -{- -We used to add a '$m' to indicate a method, but that gives rise to bad -error messages from the type checker when we print the function name or pattern -of an instance-decl binding. Why? Because the binding is zapped -to use the method name in place of the selector name. -(See TcClassDcl.tcMethodBind) - -The way it is now, -ddump-xx output may look confusing, but -you can always say -dppr-debug to get the uniques. - -However, we *do* have to zap the first character to be lower case, -because overloaded constructors (blarg) generate methods too. -And convert to VarName space - -e.g. a call to constructor MkFoo where - data (Ord a) => Foo a = MkFoo a - -If this is necessary, we do it by prefixing '$m'. These -guys never show up in error messages. What a hack. --} - -mkMethodOcc :: OccName -> OccName -mkMethodOcc occ@(OccName VarName _) = occ -mkMethodOcc occ = mk_simple_deriv varName "$m" occ - -{- -************************************************************************ -* * -\subsection{Tidying them up} -* * -************************************************************************ - -Before we print chunks of code we like to rename it so that -we don't have to print lots of silly uniques in it. But we mustn't -accidentally introduce name clashes! So the idea is that we leave the -OccName alone unless it accidentally clashes with one that is already -in scope; if so, we tack on '1' at the end and try again, then '2', and -so on till we find a unique one. - -There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' -because that isn't a single lexeme. So we encode it to 'lle' and *then* -tack on the '1', if necessary. - -Note [TidyOccEnv] -~~~~~~~~~~~~~~~~~ -type TidyOccEnv = UniqFM Int - -* Domain = The OccName's FastString. These FastStrings are "taken"; - make sure that we don't re-use - -* Int, n = A plausible starting point for new guesses - There is no guarantee that "FSn" is available; - you must look that up in the TidyOccEnv. But - it's a good place to start looking. - -* When looking for a renaming for "foo2" we strip off the "2" and start - with "foo". Otherwise if we tidy twice we get silly names like foo23. - - However, if it started with digits at the end, we always make a name - with digits at the end, rather than shortening "foo2" to just "foo", - even if "foo" is unused. Reasons: - - Plain "foo" might be used later - - We use trailing digits to subtly indicate a unification variable - in typechecker error message; see TypeRep.tidyTyVarBndr - -We have to take care though! Consider a machine-generated module (Trac #10370) - module Foo where - a1 = e1 - a2 = e2 - ... - a2000 = e2000 -Then "a1", "a2" etc are all marked taken. But now if we come across "a7" again, -we have to do a linear search to find a free one, "a2001". That might just be -acceptable once. But if we now come across "a8" again, we don't want to repeat -that search. - -So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for -starting the search; and we make sure to update the starting point for "a" -after we allocate a new one. - - -Node [Tidying multiple names at once] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider - - > :t (id,id,id) - -Every id contributes a type variable to the type signature, and all of them are -"a". If we tidy them one by one, we get - - (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a) - -which is a bit unfortunate, as it unfairly renames only one of them. What we -would like to see is - - (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1) - -This is achieved in tidyOccNames. It still uses tidyOccName to rename each name -on its own, but it prepares the TidyEnv (using avoidClashesOccEnv), by “blocking” every -name that occurs twice in the map. This way, none of the "a"s will get the -priviledge of keeping this name, and all of them will get a suitable numbery by -tidyOccName. - -It may be inappropriate to use tidyOccNames if the caller needs access to the -intermediate environments (e.g. to tidy the tyVarKind of a type variable). In that -case, avoidClashesOccEnv should be used directly, and tidyOccName afterwards. - -This is #12382. - --} - -type TidyOccEnv = UniqFM Int -- The in-scope OccNames - -- See Note [TidyOccEnv] - -emptyTidyOccEnv :: TidyOccEnv -emptyTidyOccEnv = emptyUFM - -initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! -initTidyOccEnv = foldl add emptyUFM - where - add env (OccName _ fs) = addToUFM env fs 1 - --- see Note [Tidying multiple names at once] -tidyOccNames :: TidyOccEnv -> [OccName] -> (TidyOccEnv, [OccName]) -tidyOccNames env occs = mapAccumL tidyOccName env' occs - where - env' = avoidClashesOccEnv env occs - -avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv -avoidClashesOccEnv env occs = go env emptyUFM occs - where - go env _ [] = env - go env seenOnce ((OccName _ fs):occs) - | fs `elemUFM` env = go env seenOnce occs - | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce occs - | otherwise = go env (addToUFM seenOnce fs ()) occs - -tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) -tidyOccName env occ@(OccName occ_sp fs) - | not (fs `elemUFM` env) - = (addToUFM env fs 1, occ) -- Desired OccName is free - | otherwise - = case lookupUFM env base1 of - Nothing -> (addToUFM env base1 2, OccName occ_sp base1) - Just n -> find 1 n - where - base :: String -- Drop trailing digits (see Note [TidyOccEnv]) - base = dropWhileEndLE isDigit (unpackFS fs) - base1 = mkFastString (base ++ "1") - - find !k !n - = case lookupUFM env new_fs of - Just {} -> find (k+1 :: Int) (n+k) - -- By using n+k, the n argument to find goes - -- 1, add 1, add 2, add 3, etc which - -- moves at quadratic speed through a dense patch - - Nothing -> (new_env, OccName occ_sp new_fs) - where - new_fs = mkFastString (base ++ show n) - new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) - -- Update: base1, so that next time we'll start where we left off - -- new_fs, so that we know it is taken - -- If they are the same (n==1), the former wins - -- See Note [TidyOccEnv] - -{- -************************************************************************ -* * - Binary instance - Here rather than BinIface because OccName is abstract -* * -************************************************************************ --} - -instance Binary NameSpace where - put_ bh VarName = do - putByte bh 0 - put_ bh DataName = do - putByte bh 1 - put_ bh TvName = do - putByte bh 2 - put_ bh TcClsName = do - putByte bh 3 - get bh = do - h <- getByte bh - case h of - 0 -> do return VarName - 1 -> do return DataName - 2 -> do return TvName - _ -> do return TcClsName - -instance Binary OccName where - put_ bh (OccName aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (OccName aa ab) diff --git a/basicTypes/OccName.hs-boot b/basicTypes/OccName.hs-boot deleted file mode 100644 --- a/basicTypes/OccName.hs-boot +++ /dev/null @@ -1,3 +0,0 @@ -module OccName where - -data OccName diff --git a/basicTypes/PatSyn.hs b/basicTypes/PatSyn.hs deleted file mode 100644 --- a/basicTypes/PatSyn.hs +++ /dev/null @@ -1,429 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[PatSyn]{@PatSyn@: Pattern synonyms} --} - -{-# LANGUAGE CPP #-} - -module PatSyn ( - -- * Main data types - PatSyn, mkPatSyn, - - -- ** Type deconstruction - patSynName, patSynArity, patSynIsInfix, - patSynArgs, - patSynMatcher, patSynBuilder, - patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig, - patSynInstArgTys, patSynInstResTy, patSynFieldLabels, - patSynFieldType, - - tidyPatSynIds, pprPatSynType - ) where - -#include "HsVersions.h" - -import Type -import Name -import Outputable -import Unique -import Util -import BasicTypes -import Var -import FieldLabel - -import qualified Data.Data as Data -import Data.Function -import Data.List - -{- -************************************************************************ -* * -\subsection{Pattern synonyms} -* * -************************************************************************ --} - --- | Pattern Synonym --- --- See Note [Pattern synonym representation] --- See Note [Pattern synonym signature contexts] -data PatSyn - = MkPatSyn { - psName :: Name, - psUnique :: Unique, -- Cached from Name - - psArgs :: [Type], - psArity :: Arity, -- == length psArgs - psInfix :: Bool, -- True <=> declared infix - psFieldLabels :: [FieldLabel], -- List of fields for a - -- record pattern synonym - -- INVARIANT: either empty if no - -- record pat syn or same length as - -- psArgs - - -- Universially-quantified type variables - psUnivTyVars :: [TyVarBinder], - - -- Required dictionaries (may mention psUnivTyVars) - psReqTheta :: ThetaType, - - -- Existentially-quantified type vars - psExTyVars :: [TyVarBinder], - - -- Provided dictionaries (may mention psUnivTyVars or psExTyVars) - psProvTheta :: ThetaType, - - -- Result type - psOrigResTy :: Type, -- Mentions only psUnivTyVars - - -- See Note [Matchers and builders for pattern synonyms] - psMatcher :: (Id, Bool), - -- Matcher function. - -- If Bool is True then prov_theta and arg_tys are empty - -- and type is - -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. - -- req_theta - -- => res_ty - -- -> (forall ex_tvs. Void# -> r) - -- -> (Void# -> r) - -- -> r - -- - -- Otherwise type is - -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. - -- req_theta - -- => res_ty - -- -> (forall ex_tvs. prov_theta => arg_tys -> r) - -- -> (Void# -> r) - -- -> r - - psBuilder :: Maybe (Id, Bool) - -- Nothing => uni-directional pattern synonym - -- Just (builder, is_unlifted) => bi-directional - -- Builder function, of type - -- forall univ_tvs, ex_tvs. (req_theta, prov_theta) - -- => arg_tys -> res_ty - -- See Note [Builder for pattern synonyms with unboxed type] - } - -{- Note [Pattern synonym signature contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a pattern synonym signature we write - pattern P :: req => prov => t1 -> ... tn -> res_ty - -Note that the "required" context comes first, then the "provided" -context. Moreover, the "required" context must not mention -existentially-bound type variables; that is, ones not mentioned in -res_ty. See lots of discussion in Trac #10928. - -If there is no "provided" context, you can omit it; but you -can't omit the "required" part (unless you omit both). - -Example 1: - pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b) - pattern P1 x = Just (3,x) - - We require (Num a, Eq a) to match the 3; there is no provided - context. - -Example 2: - data T2 where - MkT2 :: (Num a, Eq a) => a -> a -> T2 - - pattern P2 :: () => (Num a, Eq a) => a -> T2 - pattern P2 x = MkT2 3 x - - When we match against P2 we get a Num dictionary provided. - We can use that to check the match against 3. - -Example 3: - pattern P3 :: Eq a => a -> b -> T3 b - - This signature is illegal because the (Eq a) is a required - constraint, but it mentions the existentially-bound variable 'a'. - You can see it's existential because it doesn't appear in the - result type (T3 b). - -Note [Pattern synonym representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following pattern synonym declaration - - pattern P x = MkT [x] (Just 42) - -where - data T a where - MkT :: (Show a, Ord b) => [b] -> a -> T a - -so pattern P has type - - b -> T (Maybe t) - -with the following typeclass constraints: - - requires: (Eq t, Num t) - provides: (Show (Maybe t), Ord b) - -In this case, the fields of MkPatSyn will be set as follows: - - psArgs = [b] - psArity = 1 - psInfix = False - - psUnivTyVars = [t] - psExTyVars = [b] - psProvTheta = (Show (Maybe t), Ord b) - psReqTheta = (Eq t, Num t) - psOrigResTy = T (Maybe t) - -Note [Matchers and builders for pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For each pattern synonym P, we generate - - * a "matcher" function, used to desugar uses of P in patterns, - which implements pattern matching - - * A "builder" function (for bidirectional pattern synonyms only), - used to desugar uses of P in expressions, which constructs P-values. - -For the above example, the matcher function has type: - - $mP :: forall (r :: ?) t. (Eq t, Num t) - => T (Maybe t) - -> (forall b. (Show (Maybe t), Ord b) => b -> r) - -> (Void# -> r) - -> r - -with the following implementation: - - $mP @r @t $dEq $dNum scrut cont fail - = case scrut of - MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x - _ -> fail Void# - -Notice that the return type 'r' has an open kind, so that it can -be instantiated by an unboxed type; for example where we see - f (P x) = 3# - -The extra Void# argument for the failure continuation is needed so that -it is lazy even when the result type is unboxed. - -For the same reason, if the pattern has no arguments, an extra Void# -argument is added to the success continuation as well. - -For *bidirectional* pattern synonyms, we also generate a "builder" -function which implements the pattern synonym in an expression -context. For our running example, it will be: - - $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b) - => b -> T (Maybe t) - $bP x = MkT [x] (Just 42) - -NB: the existential/universal and required/provided split does not -apply to the builder since you are only putting stuff in, not getting -stuff out. - -Injectivity of bidirectional pattern synonyms is checked in -tcPatToExpr which walks the pattern and returns its corresponding -expression when available. - -Note [Builder for pattern synonyms with unboxed type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For bidirectional pattern synonyms that have no arguments and have an -unboxed type, we add an extra Void# argument to the builder, else it -would be a top-level declaration with an unboxed type. - - pattern P = 0# - - $bP :: Void# -> Int# - $bP _ = 0# - -This means that when typechecking an occurrence of P in an expression, -we must remember that the builder has this void argument. This is -done by TcPatSyn.patSynBuilderOcc. - -Note [Pattern synonyms and the data type Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type of a pattern synonym is of the form (See Note -[Pattern synonym signatures]): - - forall univ_tvs. req => forall ex_tvs. prov => ... - -We cannot in general represent this by a value of type Type: - - - if ex_tvs is empty, then req and prov cannot be distinguished from - each other - - if req is empty, then univ_tvs and ex_tvs cannot be distinguished - from each other, and moreover, prov is seen as the "required" context - (as it is the only context) - - -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq PatSyn where - (==) = (==) `on` getUnique - (/=) = (/=) `on` getUnique - -instance Uniquable PatSyn where - getUnique = psUnique - -instance NamedThing PatSyn where - getName = patSynName - -instance Outputable PatSyn where - ppr = ppr . getName - -instance OutputableBndr PatSyn where - pprInfixOcc = pprInfixName . getName - pprPrefixOcc = pprPrefixName . getName - -instance Data.Data PatSyn where - -- don't traverse? - toConstr _ = abstractConstr "PatSyn" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "PatSyn" - -{- -************************************************************************ -* * -\subsection{Construction} -* * -************************************************************************ --} - --- | Build a new pattern synonym -mkPatSyn :: Name - -> Bool -- ^ Is the pattern synonym declared infix? - -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type variables - -- and required dicts - -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type variables - -- and provided dicts - -> [Type] -- ^ Original arguments - -> Type -- ^ Original result type - -> (Id, Bool) -- ^ Name of matcher - -> Maybe (Id, Bool) -- ^ Name of builder - -> [FieldLabel] -- ^ Names of fields for - -- a record pattern synonym - -> PatSyn - -- NB: The univ and ex vars are both in TyBinder form and TyVar form for - -- convenience. All the TyBinders should be Named! -mkPatSyn name declared_infix - (univ_tvs, req_theta) - (ex_tvs, prov_theta) - orig_args - orig_res_ty - matcher builder field_labels - = MkPatSyn {psName = name, psUnique = getUnique name, - psUnivTyVars = univ_tvs, - psExTyVars = ex_tvs, - psProvTheta = prov_theta, psReqTheta = req_theta, - psInfix = declared_infix, - psArgs = orig_args, - psArity = length orig_args, - psOrigResTy = orig_res_ty, - psMatcher = matcher, - psBuilder = builder, - psFieldLabels = field_labels - } - --- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification -patSynName :: PatSyn -> Name -patSynName = psName - --- | Should the 'PatSyn' be presented infix? -patSynIsInfix :: PatSyn -> Bool -patSynIsInfix = psInfix - --- | Arity of the pattern synonym -patSynArity :: PatSyn -> Arity -patSynArity = psArity - -patSynArgs :: PatSyn -> [Type] -patSynArgs = psArgs - -patSynFieldLabels :: PatSyn -> [FieldLabel] -patSynFieldLabels = psFieldLabels - --- | Extract the type for any given labelled field of the 'DataCon' -patSynFieldType :: PatSyn -> FieldLabelString -> Type -patSynFieldType ps label - = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of - Just (_, ty) -> ty - Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) - -patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder] -patSynUnivTyVarBinders = psUnivTyVars - -patSynExTyVars :: PatSyn -> [TyVar] -patSynExTyVars ps = binderVars (psExTyVars ps) - -patSynExTyVarBinders :: PatSyn -> [TyVarBinder] -patSynExTyVarBinders = psExTyVars - -patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs - , psProvTheta = prov, psReqTheta = req - , psArgs = arg_tys, psOrigResTy = res_ty }) - = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty) - -patSynMatcher :: PatSyn -> (Id,Bool) -patSynMatcher = psMatcher - -patSynBuilder :: PatSyn -> Maybe (Id, Bool) -patSynBuilder = psBuilder - -tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn -tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) - = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } - where - tidy_pr (id, dummy) = (tidy_fn id, dummy) - -patSynInstArgTys :: PatSyn -> [Type] -> [Type] --- Return the types of the argument patterns --- e.g. data D a = forall b. MkD a b (b->a) --- pattern P f x y = MkD (x,True) y f --- D :: forall a. forall b. a -> b -> (b->a) -> D a --- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c --- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb] --- NB: the inst_tys should be both universal and existential -patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs - , psExTyVars = ex_tvs, psArgs = arg_tys }) - inst_tys - = ASSERT2( length tyvars == length inst_tys - , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) - map (substTyWith tyvars inst_tys) arg_tys - where - tyvars = binderVars (univ_tvs ++ ex_tvs) - -patSynInstResTy :: PatSyn -> [Type] -> Type --- Return the type of whole pattern --- E.g. pattern P x y = Just (x,x,y) --- P :: a -> b -> Just (a,a,b) --- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) --- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars -patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs - , psOrigResTy = res_ty }) - inst_tys - = ASSERT2( length univ_tvs == length inst_tys - , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) - substTyWith (binderVars univ_tvs) inst_tys res_ty - --- | Print the type of a pattern synonym. The foralls are printed explicitly -pprPatSynType :: PatSyn -> SDoc -pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta - , psExTyVars = ex_tvs, psProvTheta = prov_theta - , psArgs = orig_args, psOrigResTy = orig_res_ty }) - = sep [ pprForAll univ_tvs - , pprThetaArrowTy req_theta - , ppWhen insert_empty_ctxt $ parens empty <+> darrow - , pprType sigma_ty ] - where - sigma_ty = mkForAllTys ex_tvs $ - mkFunTys prov_theta $ - mkFunTys orig_args orig_res_ty - insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/basicTypes/PatSyn.hs-boot b/basicTypes/PatSyn.hs-boot deleted file mode 100644 --- a/basicTypes/PatSyn.hs-boot +++ /dev/null @@ -1,13 +0,0 @@ -module PatSyn where - -import BasicTypes (Arity) -import {-# SOURCE #-} TyCoRep (Type) -import Var (TyVar) -import Name (Name) - -data PatSyn - -patSynArity :: PatSyn -> Arity -patSynInstArgTys :: PatSyn -> [Type] -> [Type] -patSynExTyVars :: PatSyn -> [TyVar] -patSynName :: PatSyn -> Name diff --git a/basicTypes/RdrName.hs b/basicTypes/RdrName.hs deleted file mode 100644 --- a/basicTypes/RdrName.hs +++ /dev/null @@ -1,1243 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName' is the type of names that come directly from the parser. They --- have not yet had their scoping and binding resolved by the renamer and can be --- thought of to a first approximation as an 'OccName.OccName' with an optional module --- qualifier --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" - -module RdrName ( - -- * The main type - RdrName(..), -- Constructors exported only to BinIface - - -- ** Construction - mkRdrUnqual, mkRdrQual, - mkUnqual, mkVarUnqual, mkQual, mkOrig, - nameRdrName, getRdrName, - - -- ** Destruction - rdrNameOcc, rdrNameSpace, demoteRdrName, - isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, - - -- * Local mapping of 'RdrName' to 'Name.Name' - LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, - lookupLocalRdrEnv, lookupLocalRdrOcc, - elemLocalRdrEnv, inLocalRdrEnvScope, - localRdrEnvElts, delLocalRdrEnvList, - - -- * Global mapping of 'RdrName' to 'GlobalRdrElt's - GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, - lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, - pprGlobalRdrEnv, globalRdrEnvElts, - lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel, - getGRE_NameQualifier_maybes, - transformGREs, pickGREs, pickGREsModExp, - - -- * GlobalRdrElts - gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, - greUsedRdrName, greRdrNames, greSrcSpan, greQualModName, - gresToAvailInfo, - - -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' - GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel, - unQualOK, qualSpecOK, unQualSpecOK, - pprNameProvenance, - Parent(..), - ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - importSpecLoc, importSpecModule, isExplicitItem, bestImport - ) where - -#include "HsVersions.h" - -import Module -import Name -import Avail -import NameSet -import Maybes -import SrcLoc -import FastString -import FieldLabel -import Outputable -import Unique -import UniqFM -import UniqSet -import Util -import NameEnv - -import Data.Data -import Data.List( sortBy, foldl', nub ) - -{- -************************************************************************ -* * -\subsection{The main data type} -* * -************************************************************************ --} - --- | Reader Name --- --- Do not use the data constructors of RdrName directly: prefer the family --- of functions that creates them, such as 'mkRdrUnqual' --- --- - Note: A Located RdrName will only have API Annotations if it is a --- compound one, --- e.g. --- --- > `bar` --- > ( ~ ) --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', --- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@, --- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,, --- 'ApiAnnotation.AnnBackquote' @'`'@, --- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTildehsh', --- 'ApiAnnotation.AnnTilde', - --- For details on above see note [Api annotations] in ApiAnnotation -data RdrName - = Unqual OccName - -- ^ Unqualified name - -- - -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. - -- Create such a 'RdrName' with 'mkRdrUnqual' - - | Qual ModuleName OccName - -- ^ Qualified name - -- - -- A qualified name written by the user in - -- /source/ code. The module isn't necessarily - -- the module where the thing is defined; - -- just the one from which it is imported. - -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. - -- Create such a 'RdrName' with 'mkRdrQual' - - | Orig Module OccName - -- ^ Original name - -- - -- An original name; the module is the /defining/ module. - -- This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where - -- we want to say \"Use Prelude.map dammit\". One of these - -- can be created with 'mkOrig' - - | Exact Name - -- ^ Exact name - -- - -- We know exactly the 'Name'. This is used: - -- - -- (1) When the parser parses built-in syntax like @[]@ - -- and @(,)@, but wants a 'RdrName' from it - -- - -- (2) By Template Haskell, when TH has generated a unique name - -- - -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' - deriving Data - -{- -************************************************************************ -* * -\subsection{Simple functions} -* * -************************************************************************ --} - -instance HasOccName RdrName where - occName = rdrNameOcc - -rdrNameOcc :: RdrName -> OccName -rdrNameOcc (Qual _ occ) = occ -rdrNameOcc (Unqual occ) = occ -rdrNameOcc (Orig _ occ) = occ -rdrNameOcc (Exact name) = nameOccName name - -rdrNameSpace :: RdrName -> NameSpace -rdrNameSpace = occNameSpace . rdrNameOcc - --- demoteRdrName lowers the NameSpace of RdrName. --- see Note [Demotion] in OccName -demoteRdrName :: RdrName -> Maybe RdrName -demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) -demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) -demoteRdrName (Orig _ _) = panic "demoteRdrName" -demoteRdrName (Exact _) = panic "demoteRdrName" - - -- These two are the basic constructors -mkRdrUnqual :: OccName -> RdrName -mkRdrUnqual occ = Unqual occ - -mkRdrQual :: ModuleName -> OccName -> RdrName -mkRdrQual mod occ = Qual mod occ - -mkOrig :: Module -> OccName -> RdrName -mkOrig mod occ = Orig mod occ - ---------------- - -- These two are used when parsing source files - -- They do encode the module and occurrence names -mkUnqual :: NameSpace -> FastString -> RdrName -mkUnqual sp n = Unqual (mkOccNameFS sp n) - -mkVarUnqual :: FastString -> RdrName -mkVarUnqual n = Unqual (mkVarOccFS n) - --- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and --- the 'OccName' are taken from the first and second elements of the tuple respectively -mkQual :: NameSpace -> (FastString, FastString) -> RdrName -mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) - -getRdrName :: NamedThing thing => thing -> RdrName -getRdrName name = nameRdrName (getName name) - -nameRdrName :: Name -> RdrName -nameRdrName name = Exact name --- Keep the Name even for Internal names, so that the --- unique is still there for debug printing, particularly --- of Types (which are converted to IfaceTypes before printing) - -nukeExact :: Name -> RdrName -nukeExact n - | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) - -isRdrDataCon :: RdrName -> Bool -isRdrTyVar :: RdrName -> Bool -isRdrTc :: RdrName -> Bool - -isRdrDataCon rn = isDataOcc (rdrNameOcc rn) -isRdrTyVar rn = isTvOcc (rdrNameOcc rn) -isRdrTc rn = isTcOcc (rdrNameOcc rn) - -isSrcRdrName :: RdrName -> Bool -isSrcRdrName (Unqual _) = True -isSrcRdrName (Qual _ _) = True -isSrcRdrName _ = False - -isUnqual :: RdrName -> Bool -isUnqual (Unqual _) = True -isUnqual _ = False - -isQual :: RdrName -> Bool -isQual (Qual _ _) = True -isQual _ = False - -isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) -isQual_maybe (Qual m n) = Just (m,n) -isQual_maybe _ = Nothing - -isOrig :: RdrName -> Bool -isOrig (Orig _ _) = True -isOrig _ = False - -isOrig_maybe :: RdrName -> Maybe (Module, OccName) -isOrig_maybe (Orig m n) = Just (m,n) -isOrig_maybe _ = Nothing - -isExact :: RdrName -> Bool -isExact (Exact _) = True -isExact _ = False - -isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing - -{- -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Outputable RdrName where - ppr (Exact name) = ppr name - ppr (Unqual occ) = ppr occ - ppr (Qual mod occ) = ppr mod <> dot <> ppr occ - ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) - -instance OutputableBndr RdrName where - pprBndr _ n - | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n - | otherwise = ppr n - - pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - pprPrefixOcc rdr - | Just name <- isExact_maybe rdr = pprPrefixName name - -- pprPrefixName has some special cases, so - -- we delegate to them rather than reproduce them - | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - -instance Eq RdrName where - (Exact n1) == (Exact n2) = n1==n2 - -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 - r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 - - (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 - (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 - (Unqual o1) == (Unqual o2) = o1==o2 - _ == _ = False - -instance Ord RdrName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - - -- Exact < Unqual < Qual < Orig - -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig - -- before comparing so that Prelude.map == the exact Prelude.map, but - -- that meant that we reported duplicates when renaming bindings - -- generated by Template Haskell; e.g - -- do { n1 <- newName "foo"; n2 <- newName "foo"; - -- } - -- I think we can do without this conversion - compare (Exact n1) (Exact n2) = n1 `compare` n2 - compare (Exact _) _ = LT - - compare (Unqual _) (Exact _) = GT - compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - compare (Unqual _) _ = LT - - compare (Qual _ _) (Exact _) = GT - compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) - compare (Qual _ _) (Orig _ _) = LT - - compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) - compare (Orig _ _) _ = GT - -{- -************************************************************************ -* * - LocalRdrEnv -* * -************************************************************************ --} - --- | Local Reader Environment --- --- This environment is used to store local bindings --- (@let@, @where@, lambda, @case@). --- It is keyed by OccName, because we never use it for qualified names --- We keep the current mapping, *and* the set of all Names in scope --- Reason: see Note [Splicing Exact names] in RnEnv -data LocalRdrEnv = LRE { lre_env :: OccEnv Name - , lre_in_scope :: NameSet } - -instance Outputable LocalRdrEnv where - ppr (LRE {lre_env = env, lre_in_scope = ns}) - = hang (text "LocalRdrEnv {") - 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env - , text "in_scope =" - <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) - ] <+> char '}') - where - ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name - -- So we can see if the keys line up correctly - -emptyLocalRdrEnv :: LocalRdrEnv -emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv - , lre_in_scope = emptyNameSet } - -extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv --- The Name should be a non-top-level thing -extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name - = WARN( isExternalName name, ppr name ) - lre { lre_env = extendOccEnv env (nameOccName name) name - , lre_in_scope = extendNameSet ns name } - -extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv -extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names - = WARN( any isExternalName names, ppr names ) - lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] - , lre_in_scope = extendNameSetList ns names } - -lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name -lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr - | Unqual occ <- rdr - = lookupOccEnv env occ - - -- See Note [Local bindings with Exact Names] - | Exact name <- rdr - , name `elemNameSet` ns - = Just name - - | otherwise - = Nothing - -lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name -lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ - -elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool -elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) - = case rdr_name of - Unqual occ -> occ `elemOccEnv` env - Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] - Qual {} -> False - Orig {} -> False - -localRdrEnvElts :: LocalRdrEnv -> [Name] -localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env - -inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool --- This is the point of the NameSet -inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns - -delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv -delLocalRdrEnvList lre@(LRE { lre_env = env }) occs - = lre { lre_env = delListFromOccEnv env occs } - -{- -Note [Local bindings with Exact Names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With Template Haskell we can make local bindings that have Exact Names. -Computing shadowing etc may use elemLocalRdrEnv (at least it certainly -does so in RnTpes.bindHsQTyVars), so for an Exact Name we must consult -the in-scope-name-set. - - -************************************************************************ -* * - GlobalRdrEnv -* * -************************************************************************ --} - --- | Global Reader Environment -type GlobalRdrEnv = OccEnv [GlobalRdrElt] --- ^ Keyed by 'OccName'; when looking up a qualified name --- we look up the 'OccName' part, and then check the 'Provenance' --- to see if the appropriate qualification is valid. This --- saves routinely doubling the size of the env by adding both --- qualified and unqualified names to the domain. --- --- The list in the codomain is required because there may be name clashes --- These only get reported on lookup, not on construction --- --- INVARIANT 1: All the members of the list have distinct --- 'gre_name' fields; that is, no duplicate Names --- --- INVARIANT 2: Imported provenance => Name is an ExternalName --- However LocalDefs can have an InternalName. This --- happens only when type-checking a [d| ... |] Template --- Haskell quotation; see this note in RnNames --- Note [Top-level Names in Template Haskell decl quotes] --- --- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then --- greOccName gre = occ --- --- NB: greOccName gre is usually the same as --- nameOccName (gre_name gre), but not always in the --- case of record seectors; see greOccName - --- | Global Reader Element --- --- An element of the 'GlobalRdrEnv' -data GlobalRdrElt - = GRE { gre_name :: Name - , gre_par :: Parent - , gre_lcl :: Bool -- ^ True <=> the thing was defined locally - , gre_imp :: [ImportSpec] -- ^ In scope through these imports - } deriving (Data, Eq) - -- INVARIANT: either gre_lcl = True or gre_imp is non-empty - -- See Note [GlobalRdrElt provenance] - --- | The children of a Name are the things that are abbreviated by the ".." --- notation in export lists. See Note [Parents] -data Parent = NoParent - | ParentIs { par_is :: Name } - | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } - -- ^ See Note [Parents for record fields] - deriving (Eq, Data, Typeable) - -instance Outputable Parent where - ppr NoParent = empty - ppr (ParentIs n) = text "parent:" <> ppr n - ppr (FldParent n f) = text "fldparent:" - <> ppr n <> colon <> ppr f - -plusParent :: Parent -> Parent -> Parent --- See Note [Combining parents] -plusParent p1@(ParentIs _) p2 = hasParent p1 p2 -plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 -plusParent p1 p2@(ParentIs _) = hasParent p2 p1 -plusParent p1 p2@(FldParent _ _) = hasParent p2 p1 -plusParent _ _ = NoParent - -hasParent :: Parent -> Parent -> Parent -#ifdef DEBUG -hasParent p NoParent = p -hasParent p p' - | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree -#endif -hasParent p _ = p - - -{- Note [GlobalRdrElt provenance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", -i.e. how the Name came to be in scope. It can be in scope two ways: - - gre_lcl = True: it is bound in this module - - gre_imp: a list of all the imports that brought it into scope - -It's an INVARIANT that you have one or the other; that is, either -gre_lcl is True, or gre_imp is non-empty. - -It is just possible to have *both* if there is a module loop: a Name -is defined locally in A, and also brought into scope by importing a -module that SOURCE-imported A. Exapmle (Trac #7672): - - A.hs-boot module A where - data T - - B.hs module B(Decl.T) where - import {-# SOURCE #-} qualified A as Decl - - A.hs module A where - import qualified B - data T = Z | S B.T - -In A.hs, 'T' is locally bound, *and* imported as B.T. - -Note [Parents] -~~~~~~~~~~~~~~~~~ - Parent Children -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - data T Data constructors - Record-field ids - - data family T Data constructors and record-field ids - of all visible data instances of T - - class C Class operations - Associated type constructors - -~~~~~~~~~~~~~~~~~~~~~~~~~ - Constructor Meaning - ~~~~~~~~~~~~~~~~~~~~~~~~ - NoParent Can not be bundled with a type constructor. - ParentIs n Can be bundled with the type constructor corresponding to - n. - FldParent See Note [Parents for record fields] - - - - -Note [Parents for record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For record fields, in addition to the Name of the type constructor -(stored in par_is), we use FldParent to store the field label. This -extra information is used for identifying overloaded record fields -during renaming. - -In a definition arising from a normal module (without --XDuplicateRecordFields), par_lbl will be Nothing, meaning that the -field's label is the same as the OccName of the selector's Name. The -GlobalRdrEnv will contain an entry like this: - - "x" |-> GRE x (FldParent T Nothing) LocalDef - -When -XDuplicateRecordFields is enabled for the module that contains -T, the selector's Name will be mangled (see comments in FieldLabel). -Thus we store the actual field label in par_lbl, and the GlobalRdrEnv -entry looks like this: - - "x" |-> GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef - -Note that the OccName used when adding a GRE to the environment -(greOccName) now depends on the parent field: for FldParent it is the -field label, if present, rather than the selector name. - -~~ - -Record pattern synonym selectors are treated differently. Their parent -information is `NoParent` in the module in which they are defined. This is because -a pattern synonym `P` has no parent constructor either. - -However, if `f` is bundled with a type constructor `T` then whenever `f` is -imported the parent will use the `Parent` constructor so the parent of `f` is -now `T`. - - -Note [Combining parents] -~~~~~~~~~~~~~~~~~~~~~~~~ -With an associated type we might have - module M where - class C a where - data T a - op :: T a -> a - instance C Int where - data T Int = TInt - instance C Bool where - data T Bool = TBool - -Then: C is the parent of T - T is the parent of TInt and TBool -So: in an export list - C(..) is short for C( op, T ) - T(..) is short for T( TInt, TBool ) - -Module M exports everything, so its exports will be - AvailTC C [C,T,op] - AvailTC T [T,TInt,TBool] -On import we convert to GlobalRdrElt and then combine -those. For T that will mean we have - one GRE with Parent C - one GRE with NoParent -That's why plusParent picks the "best" case. --} - --- | make a 'GlobalRdrEnv' where all the elements point to the same --- Provenance (useful for "hiding" imports, or imports with no details). -gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] --- prov = Nothing => locally bound --- Just spec => imported as described by spec -gresFromAvails prov avails - = concatMap (gresFromAvail (const prov)) avails - -localGREsFromAvail :: AvailInfo -> [GlobalRdrElt] --- Turn an Avail into a list of LocalDef GlobalRdrElts -localGREsFromAvail = gresFromAvail (const Nothing) - -gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt] -gresFromAvail prov_fn avail - = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail) - where - mk_gre n - = case prov_fn n of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = n, gre_par = mkParent n avail - , gre_lcl = True, gre_imp = [] } - Just is -> GRE { gre_name = n, gre_par = mkParent n avail - , gre_lcl = False, gre_imp = [is] } - - mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded - , flSelector = n }) - = case prov_fn n of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl - , gre_lcl = True, gre_imp = [] } - Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl - , gre_lcl = False, gre_imp = [is] } - where - mb_lbl | is_overloaded = Just lbl - | otherwise = Nothing - - -greQualModName :: GlobalRdrElt -> ModuleName --- Get a suitable module qualifier for the GRE --- (used in mkPrintUnqualified) --- Prerecondition: the gre_name is always External -greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) - | lcl, Just mod <- nameModule_maybe name = moduleName mod - | (is:_) <- iss = is_as (is_decl is) - | otherwise = pprPanic "greQualModName" (ppr gre) - -greUsedRdrName :: GlobalRdrElt -> RdrName --- For imported things, return a RdrName to add to the used-RdrName --- set, which is used to generate unused-import-decl warnings. --- Return a Qual RdrName if poss, so that identifies the most --- specific ImportSpec. See Trac #10890 for some good examples. -greUsedRdrName gre@GRE{ gre_name = name, gre_lcl = lcl, gre_imp = iss } - | lcl, Just mod <- nameModule_maybe name = Qual (moduleName mod) occ - | not (null iss), is <- bestImport iss = Qual (is_as (is_decl is)) occ - | otherwise = pprTrace "greUsedRdrName" (ppr gre) (Unqual occ) - where - occ = greOccName gre - -greRdrNames :: GlobalRdrElt -> [RdrName] -greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } - = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss) - where - occ = greOccName gre - unqual = Unqual occ - do_spec decl_spec - | is_qual decl_spec = [qual] - | otherwise = [unqual,qual] - where qual = Qual (is_as decl_spec) occ - --- the SrcSpan that pprNameProvenance prints out depends on whether --- the Name is defined locally or not: for a local definition the --- definition site is used, otherwise the location of the import --- declaration. We want to sort the export locations in --- exportClashErr by this SrcSpan, we need to extract it: -greSrcSpan :: GlobalRdrElt -> SrcSpan -greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } ) - | lcl = nameSrcSpan name - | (is:_) <- iss = is_dloc (is_decl is) - | otherwise = pprPanic "greSrcSpan" (ppr gre) - -mkParent :: Name -> AvailInfo -> Parent -mkParent _ (Avail _) = NoParent -mkParent n (AvailTC m _ _) | n == m = NoParent - | otherwise = ParentIs m - -greParentName :: GlobalRdrElt -> Maybe Name -greParentName gre = case gre_par gre of - NoParent -> Nothing - ParentIs n -> Just n - FldParent n _ -> Just n - --- | Takes a list of distinct GREs and folds them --- into AvailInfos. This is more efficient than mapping each individual --- GRE to an AvailInfo and the folding using `plusAvail` but needs the --- uniqueness assumption. -gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] -gresToAvailInfo gres - = ASSERT( nub gres == gres ) nameEnvElts avail_env - where - avail_env :: NameEnv AvailInfo -- keyed by the parent - avail_env = foldl' add emptyNameEnv gres - - add :: NameEnv AvailInfo -> GlobalRdrElt -> NameEnv AvailInfo - add env gre = extendNameEnv_Acc comb availFromGRE env - (fromMaybe (gre_name gre) - (greParentName gre)) gre - - where - -- We want to insert the child `k` into a list of children but - -- need to maintain the invariant that the parent is first. - -- - -- We also use the invariant that `k` is not already in `ns`. - insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] - insertChildIntoChildren _ [] k = [k] - insertChildIntoChildren p (n:ns) k - | p == k = k:n:ns - | otherwise = n:k:ns - - comb :: GlobalRdrElt -> AvailInfo -> AvailInfo - comb _ (Avail n) = Avail n -- Duplicated name - comb gre (AvailTC m ns fls) = - let n = gre_name gre - in case gre_par gre of - NoParent -> AvailTC m (n:ns) fls -- Not sure this ever happens - ParentIs {} -> AvailTC m (insertChildIntoChildren m ns n) fls - FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel n mb_lbl : fls) - -availFromGRE :: GlobalRdrElt -> AvailInfo -availFromGRE (GRE { gre_name = me, gre_par = parent }) - = case parent of - ParentIs p -> AvailTC p [me] [] - NoParent | isTyConName me -> AvailTC me [me] [] - | otherwise -> avail me - FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl] - -mkFieldLabel :: Name -> Maybe FastString -> FieldLabel -mkFieldLabel me mb_lbl = - case mb_lbl of - Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me) - , flIsOverloaded = False - , flSelector = me } - Just lbl -> FieldLabel { flLabel = lbl - , flIsOverloaded = True - , flSelector = me } - -emptyGlobalRdrEnv :: GlobalRdrEnv -emptyGlobalRdrEnv = emptyOccEnv - -globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] -globalRdrEnvElts env = foldOccEnv (++) [] env - -instance Outputable GlobalRdrElt where - ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre)) - 2 (pprNameProvenance gre) - -pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc -pprGlobalRdrEnv locals_only env - = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)")) - <+> lbrace - , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] - <+> rbrace) ] - where - remove_locals gres | locals_only = filter isLocalGRE gres - | otherwise = gres - pp [] = empty - pp gres = hang (ppr occ - <+> parens (text "unique" <+> ppr (getUnique occ)) - <> colon) - 2 (vcat (map ppr gres)) - where - occ = nameOccName (gre_name (head gres)) - -lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] -lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of - Nothing -> [] - Just gres -> gres - -greOccName :: GlobalRdrElt -> OccName -greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl -greOccName gre = nameOccName (gre_name gre) - -lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] -lookupGRE_RdrName rdr_name env - = case lookupOccEnv env (rdrNameOcc rdr_name) of - Nothing -> [] - Just gres -> pickGREs rdr_name gres - -lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment. This tests --- whether it is in scope, ignoring anything else that might be in --- scope with the same 'OccName'. -lookupGRE_Name env name - = lookupGRE_Name_OccName env name (nameOccName name) - -lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt --- ^ Look for a particular record field selector in the environment, where the --- selector name and field label may be different: the GlobalRdrEnv is keyed on --- the label. See Note [Parents for record fields] for why this happens. -lookupGRE_FieldLabel env fl - = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl)) - -lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' --- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and --- Note [Parents for record fields]. -lookupGRE_Name_OccName env name occ - = case [ gre | gre <- lookupGlobalRdrEnv env occ - , gre_name gre == name ] of - [] -> Nothing - [gre] -> Just gre - gres -> pprPanic "lookupGRE_Name_OccName" - (ppr name $$ ppr occ $$ ppr gres) - -- See INVARIANT 1 on GlobalRdrEnv - - -getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] --- Returns all the qualifiers by which 'x' is in scope --- Nothing means "the unqualified version is in scope" --- [] means the thing is not in scope at all -getGRE_NameQualifier_maybes env name - = case lookupGRE_Name env name of - Just gre -> [qualifier_maybe gre] - Nothing -> [] - where - qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) - | lcl = Nothing - | otherwise = Just $ map (is_as . is_decl) iss - -isLocalGRE :: GlobalRdrElt -> Bool -isLocalGRE (GRE {gre_lcl = lcl }) = lcl - -isRecFldGRE :: GlobalRdrElt -> Bool -isRecFldGRE (GRE {gre_par = FldParent{}}) = True -isRecFldGRE _ = False - --- Returns the field label of this GRE, if it has one -greLabel :: GlobalRdrElt -> Maybe FieldLabelString -greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl -greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n)) -greLabel _ = Nothing - -unQualOK :: GlobalRdrElt -> Bool --- ^ Test if an unqualified version of this thing would be in scope -unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) - | lcl = True - | otherwise = any unQualSpecOK iss - -{- Note [GRE filtering] -~~~~~~~~~~~~~~~~~~~~~~~ -(pickGREs rdr gres) takes a list of GREs which have the same OccName -as 'rdr', say "x". It does two things: - -(a) filters the GREs to a subset that are in scope - * Qualified, as 'M.x' if want_qual is Qual M _ - * Unqualified, as 'x' if want_unqual is Unqual _ - -(b) for that subset, filter the provenance field (gre_lcl and gre_imp) - to ones that brought it into scope qualified or unqualified resp. - -Example: - module A ( f ) where - import qualified Foo( f ) - import Baz( f ) - f = undefined - -Let's suppose that Foo.f and Baz.f are the same entity really, but the local -'f' is different, so there will be two GREs matching "f": - gre1: gre_lcl = True, gre_imp = [] - gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] - -The use of "f" in the export list is ambiguous because it's in scope -from the local def and the import Baz(f); but *not* the import qualified Foo. -pickGREs returns two GRE - gre1: gre_lcl = True, gre_imp = [] - gre2: gre_lcl = False, gre_imp = [ imported from Bar ] - -Now the the "ambiguous occurrence" message can correctly report how the -ambiguity arises. --} - -pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] --- ^ Takes a list of GREs which have the right OccName 'x' --- Pick those GREs that are are in scope --- * Qualified, as 'M.x' if want_qual is Qual M _ --- * Unqualified, as 'x' if want_unqual is Unqual _ --- --- Return each such GRE, with its ImportSpecs filtered, to reflect --- how it is in scope qualified or unqualified respectively. --- See Note [GRE filtering] -pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres -pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres -pickGREs _ _ = [] -- I don't think this actually happens - -pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt -pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) - | not lcl, null iss' = Nothing - | otherwise = Just (gre { gre_imp = iss' }) - where - iss' = filter unQualSpecOK iss - -pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt -pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss }) - | not lcl', null iss' = Nothing - | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) - where - iss' = filter (qualSpecOK mod) iss - lcl' = lcl && name_is_from mod n - - name_is_from :: ModuleName -> Name -> Bool - name_is_from mod name = case nameModule_maybe name of - Just n_mod -> moduleName n_mod == mod - Nothing -> False - -pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] --- ^ Pick GREs that are in scope *both* qualified *and* unqualified --- Return each GRE that is, as a pair --- (qual_gre, unqual_gre) --- These two GREs are the original GRE with imports filtered to express how --- it is in scope qualified an unqualified respectively --- --- Used only for the 'module M' item in export list; --- see RnNames.exports_from_avail -pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres - -pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) -pickBothGRE mod gre@(GRE { gre_name = n }) - | isBuiltInSyntax n = Nothing - | Just gre1 <- pickQualGRE mod gre - , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) - | otherwise = Nothing - where - -- isBuiltInSyntax filter out names for built-in syntax They - -- just clutter up the environment (esp tuples), and the - -- parser will generate Exact RdrNames for them, so the - -- cluttered envt is no use. Really, it's only useful for - -- GHC.Base and GHC.Tuple. - --- Building GlobalRdrEnvs - -plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv -plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 - -mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv -mkGlobalRdrEnv gres - = foldr add emptyGlobalRdrEnv gres - where - add gre env = extendOccEnv_Acc insertGRE singleton env - (greOccName gre) - gre - -insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] -insertGRE new_g [] = [new_g] -insertGRE new_g (old_g : old_gs) - | gre_name new_g == gre_name old_g - = new_g `plusGRE` old_g : old_gs - | otherwise - = old_g : insertGRE new_g old_gs - -plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt --- Used when the gre_name fields match -plusGRE g1 g2 - = GRE { gre_name = gre_name g1 - , gre_lcl = gre_lcl g1 || gre_lcl g2 - , gre_imp = gre_imp g1 ++ gre_imp g2 - , gre_par = gre_par g1 `plusParent` gre_par g2 } - -transformGREs :: (GlobalRdrElt -> GlobalRdrElt) - -> [OccName] - -> GlobalRdrEnv -> GlobalRdrEnv --- ^ Apply a transformation function to the GREs for these OccNames -transformGREs trans_gre occs rdr_env - = foldr trans rdr_env occs - where - trans occ env - = case lookupOccEnv env occ of - Just gres -> extendOccEnv env occ (map trans_gre gres) - Nothing -> env - -extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv -extendGlobalRdrEnv env gre - = extendOccEnv_Acc insertGRE singleton env - (greOccName gre) gre - -shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv -shadowNames = foldl shadowName - -{- Note [GlobalRdrEnv shadowing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before adding new names to the GlobalRdrEnv we nuke some existing entries; -this is "shadowing". The actual work is done by RdrEnv.shadowNames. -There are two reasons for shadowing: - -* The GHCi REPL - - - Ids bought into scope on the command line (eg let x = True) have - External Names, like Ghci4.x. We want a new binding for 'x' (say) - to override the existing binding for 'x'. - See Note [Interactively-bound Ids in GHCi] in HscTypes - - - Data types also have Extenal Names, like Ghci4.T; but we still want - 'T' to mean the newly-declared 'T', not an old one. - -* Nested Template Haskell declaration brackets - See Note [Top-level Names in Template Haskell decl quotes] in RnNames - - Consider a TH decl quote: - module M where - f x = h [d| f = 3 |] - We must shadow the outer declaration of 'f', else we'll get a - complaint when extending the GlobalRdrEnv, saying that there are two - bindings for 'f'. There are several tricky points: - - - This shadowing applies even if the binding for 'f' is in a - where-clause, and hence is in the *local* RdrEnv not the *global* - RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. - - - The External Name M.f from the enclosing module must certainly - still be available. So we don't nuke it entirely; we just make - it seem like qualified import. - - - We only shadow *External* names (which come from the main module), - or from earlier GHCi commands. Do not shadow *Internal* names - because in the bracket - [d| class C a where f :: a - f = 4 |] - rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the - class decl, and *separately* extend the envt with the value binding. - At that stage, the class op 'f' will have an Internal name. --} - -shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv --- Remove certain old GREs that share the same OccName as this new Name. --- See Note [GlobalRdrEnv shadowing] for details -shadowName env name - = alterOccEnv (fmap alter_fn) env (nameOccName name) - where - alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt] - alter_fn gres = mapMaybe (shadow_with name) gres - - shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt - shadow_with new_name - old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss }) - = case nameModule_maybe old_name of - Nothing -> Just old_gre -- Old name is Internal; do not shadow - Just old_mod - | Just new_mod <- nameModule_maybe new_name - , new_mod == old_mod -- Old name same as new name; shadow completely - -> Nothing - - | null iss' -- Nothing remains - -> Nothing - - | otherwise - -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) - - where - iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss - lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod] - | otherwise = [] - - mk_fake_imp_spec old_name old_mod -- Urgh! - = ImpSpec id_spec ImpAll - where - old_mod_name = moduleName old_mod - id_spec = ImpDeclSpec { is_mod = old_mod_name - , is_as = old_mod_name - , is_qual = True - , is_dloc = nameSrcSpan old_name } - - shadow_is :: Name -> ImportSpec -> Maybe ImportSpec - shadow_is new_name is@(ImpSpec { is_decl = id_spec }) - | Just new_mod <- nameModule_maybe new_name - , is_as id_spec == moduleName new_mod - = Nothing -- Shadow both qualified and unqualified - | otherwise -- Shadow unqualified only - = Just (is { is_decl = id_spec { is_qual = True } }) - - -{- -************************************************************************ -* * - ImportSpec -* * -************************************************************************ --} - --- | Import Specification --- --- The 'ImportSpec' of something says how it came to be imported --- It's quite elaborate so that we can give accurate unused-name warnings. -data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } - deriving( Eq, Ord, Data ) - --- | Import Declaration Specification --- --- Describes a particular import declaration and is --- shared among all the 'Provenance's for that decl -data ImpDeclSpec - = ImpDeclSpec { - is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@ - -- Note the @Muggle@ may well not be - -- the defining module for this thing! - - -- TODO: either should be Module, or there - -- should be a Maybe UnitId here too. - is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) - is_qual :: Bool, -- ^ Was this import qualified? - is_dloc :: SrcSpan -- ^ The location of the entire import declaration - } deriving Data - --- | Import Item Specification --- --- Describes import info a particular Name -data ImpItemSpec - = ImpAll -- ^ The import had no import list, - -- or had a hiding list - - | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item - } -- ^ The import had an import list. - -- The 'is_explicit' field is @True@ iff the thing was named - -- /explicitly/ in the import specs rather - -- than being imported as part of a "..." group. Consider: - -- - -- > import C( T(..) ) - -- - -- Here the constructors of @T@ are not named explicitly; - -- only @T@ is named explicitly. - deriving Data - -instance Eq ImpDeclSpec where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Ord ImpDeclSpec where - compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp` - (is_dloc is1 `compare` is_dloc is2) - -instance Eq ImpItemSpec where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Ord ImpItemSpec where - compare is1 is2 = - case (is1, is2) of - (ImpAll, ImpAll) -> EQ - (ImpAll, _) -> GT - (_, ImpAll) -> LT - (ImpSome _ l1, ImpSome _ l2) -> l1 `compare` l2 - - -bestImport :: [ImportSpec] -> ImportSpec --- Given a non-empty bunch of ImportSpecs, return the one that --- imported the item most specifically (e.g. by name), using --- textually-first as a tie breaker. This is used when reporting --- redundant imports -bestImport iss - = case sortBy best iss of - (is:_) -> is - [] -> pprPanic "bestImport" (ppr iss) - where - best :: ImportSpec -> ImportSpec -> Ordering - -- Less means better - best (ImpSpec { is_item = item1, is_decl = d1 }) - (ImpSpec { is_item = item2, is_decl = d2 }) - = best_item item1 item2 `thenCmp` (is_dloc d1 `compare` is_dloc d2) - - best_item :: ImpItemSpec -> ImpItemSpec -> Ordering - best_item ImpAll ImpAll = EQ - best_item ImpAll (ImpSome {}) = GT - best_item (ImpSome {}) ImpAll = LT - best_item (ImpSome { is_explicit = e1 }) - (ImpSome { is_explicit = e2 }) = e2 `compare` e1 - -- False < True, so if e1 is explicit and e2 is not, we get LT - -unQualSpecOK :: ImportSpec -> Bool --- ^ Is in scope unqualified? -unQualSpecOK is = not (is_qual (is_decl is)) - -qualSpecOK :: ModuleName -> ImportSpec -> Bool --- ^ Is in scope qualified with the given module? -qualSpecOK mod is = mod == is_as (is_decl is) - -importSpecLoc :: ImportSpec -> SrcSpan -importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl -importSpecLoc (ImpSpec _ item) = is_iloc item - -importSpecModule :: ImportSpec -> ModuleName -importSpecModule is = is_mod (is_decl is) - -isExplicitItem :: ImpItemSpec -> Bool -isExplicitItem ImpAll = False -isExplicitItem (ImpSome {is_explicit = exp}) = exp - -pprNameProvenance :: GlobalRdrElt -> SDoc --- ^ Print out one place where the name was define/imported --- (With -dppr-debug, print them all) -pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) - = sdocWithPprDebug $ \dbg -> if dbg - then vcat pp_provs - else head pp_provs - where - pp_provs = pp_lcl ++ map pp_is iss - pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] - else [] - pp_is is = sep [ppr is, ppr_defn_site is name] - --- If we know the exact definition point (which we may do with GHCi) --- then show that too. But not if it's just "imported from X". -ppr_defn_site :: ImportSpec -> Name -> SDoc -ppr_defn_site imp_spec name - | same_module && not (isGoodSrcSpan loc) - = empty -- Nothing interesting to say - | otherwise - = parens $ hang (text "and originally defined" <+> pp_mod) - 2 (pprLoc loc) - where - loc = nameSrcSpan name - defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name - same_module = importSpecModule imp_spec == moduleName defining_mod - pp_mod | same_module = empty - | otherwise = text "in" <+> quotes (ppr defining_mod) - - -instance Outputable ImportSpec where - ppr imp_spec - = text "imported" <+> qual - <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) - <+> pprLoc (importSpecLoc imp_spec) - where - qual | is_qual (is_decl imp_spec) = text "qualified" - | otherwise = empty - -pprLoc :: SrcSpan -> SDoc -pprLoc (RealSrcSpan s) = text "at" <+> ppr s -pprLoc (UnhelpfulSpan {}) = empty diff --git a/basicTypes/SrcLoc.hs b/basicTypes/SrcLoc.hs deleted file mode 100644 --- a/basicTypes/SrcLoc.hs +++ /dev/null @@ -1,587 +0,0 @@ --- (c) The University of Glasgow, 1992-2006 - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} - -- Workaround for Trac #5252 crashes the bootstrap compiler without -O - -- When the earliest compiler we want to boostrap with is - -- GHC 7.2, we can make RealSrcLoc properly abstract - --- | This module contains types that relate to the positions of things --- in source files, and allow tagging of those things with locations -module SrcLoc ( - -- * SrcLoc - RealSrcLoc, -- Abstract - SrcLoc(..), - - -- ** Constructing SrcLoc - mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, - - noSrcLoc, -- "I'm sorry, I haven't a clue" - generatedSrcLoc, -- Code generated within the compiler - interactiveSrcLoc, -- Code from an interactive session - - advanceSrcLoc, - - -- ** Unsafely deconstructing SrcLoc - -- These are dubious exports, because they crash on some inputs - srcLocFile, -- return the file name part - srcLocLine, -- return the line part - srcLocCol, -- return the column part - - -- * SrcSpan - RealSrcSpan, -- Abstract - SrcSpan(..), - - -- ** Constructing SrcSpan - mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, - noSrcSpan, - wiredInSrcSpan, -- Something wired into the compiler - interactiveSrcSpan, - srcLocSpan, realSrcLocSpan, - combineSrcSpans, - srcSpanFirstCharacter, - - -- ** Deconstructing SrcSpan - srcSpanStart, srcSpanEnd, - realSrcSpanStart, realSrcSpanEnd, - srcSpanFileName_maybe, - pprUserRealSpan, - - -- ** Unsafely deconstructing SrcSpan - -- These are dubious exports, because they crash on some inputs - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, - srcSpanStartCol, srcSpanEndCol, - - -- ** Predicates on SrcSpan - isGoodSrcSpan, isOneLineSpan, - containsSpan, - - -- * Located - Located, - RealLocated, - GenLocated(..), - - -- ** Constructing Located - noLoc, - mkGeneralLocated, - - -- ** Deconstructing Located - getLoc, unLoc, - - -- ** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, - leftmost_smallest, leftmost_largest, rightmost, - spans, isSubspanOf, sortLocated - ) where - -import Util -import Json -import Outputable -import FastString - -import Control.DeepSeq -import Data.Bits -import Data.Data -import Data.List -import Data.Ord - -{- -************************************************************************ -* * -\subsection[SrcLoc-SrcLocations]{Source-location information} -* * -************************************************************************ - -We keep information about the {\em definition} point for each entity; -this is the obvious stuff: --} - --- | Real Source Location --- --- Represents a single point within a file -data RealSrcLoc - = SrcLoc FastString -- A precise location (file name) - {-# UNPACK #-} !Int -- line number, begins at 1 - {-# UNPACK #-} !Int -- column number, begins at 1 - deriving (Eq, Ord) - --- | Source Location -data SrcLoc - = RealSrcLoc {-# UNPACK #-}!RealSrcLoc - | UnhelpfulLoc FastString -- Just a general indication - deriving (Eq, Ord, Show) - -{- -************************************************************************ -* * -\subsection[SrcLoc-access-fns]{Access functions} -* * -************************************************************************ --} - -mkSrcLoc :: FastString -> Int -> Int -> SrcLoc -mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) - -mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc -mkRealSrcLoc x line col = SrcLoc x line col - --- | Built-in "bad" 'SrcLoc' values for particular locations -noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc -noSrcLoc = UnhelpfulLoc (fsLit "") -generatedSrcLoc = UnhelpfulLoc (fsLit "") -interactiveSrcLoc = UnhelpfulLoc (fsLit "") - --- | Creates a "bad" 'SrcLoc' that has no detailed information about its location -mkGeneralSrcLoc :: FastString -> SrcLoc -mkGeneralSrcLoc = UnhelpfulLoc - --- | Gives the filename of the 'RealSrcLoc' -srcLocFile :: RealSrcLoc -> FastString -srcLocFile (SrcLoc fname _ _) = fname - --- | Raises an error when used on a "bad" 'SrcLoc' -srcLocLine :: RealSrcLoc -> Int -srcLocLine (SrcLoc _ l _) = l - --- | Raises an error when used on a "bad" 'SrcLoc' -srcLocCol :: RealSrcLoc -> Int -srcLocCol (SrcLoc _ _ c) = c - --- | Move the 'SrcLoc' down by one line if the character is a newline, --- to the next 8-char tabstop if it is a tab, and across by one --- character in any other case -advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc -advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 -advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1) - `shiftL` 3) + 1) -advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) - -{- -************************************************************************ -* * -\subsection[SrcLoc-instances]{Instance declarations for various names} -* * -************************************************************************ --} - -sortLocated :: [Located a] -> [Located a] -sortLocated things = sortBy (comparing getLoc) things - -instance Outputable RealSrcLoc where - ppr (SrcLoc src_path src_line src_col) - = hcat [ pprFastFilePath src_path <> colon - , int src_line <> colon - , int src_col ] - --- I don't know why there is this style-based difference --- if userStyle sty || debugStyle sty then --- hcat [ pprFastFilePath src_path, char ':', --- int src_line, --- char ':', int src_col --- ] --- else --- hcat [text "{-# LINE ", int src_line, space, --- char '\"', pprFastFilePath src_path, text " #-}"] - -instance Outputable SrcLoc where - ppr (RealSrcLoc l) = ppr l - ppr (UnhelpfulLoc s) = ftext s - -instance Data RealSrcSpan where - -- don't traverse? - toConstr _ = abstractConstr "RealSrcSpan" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "RealSrcSpan" - -instance Data SrcSpan where - -- don't traverse? - toConstr _ = abstractConstr "SrcSpan" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "SrcSpan" - -{- -************************************************************************ -* * -\subsection[SrcSpan]{Source Spans} -* * -************************************************************************ --} - -{- | -A 'RealSrcSpan' delimits a portion of a text file. It could be represented -by a pair of (line,column) coordinates, but in fact we optimise -slightly by using more compact representations for single-line and -zero-length spans, both of which are quite common. - -The end position is defined to be the column /after/ the end of the -span. That is, a span of (1,1)-(1,2) is one character long, and a -span of (1,1)-(1,1) is zero characters long. --} - --- | Real Source Span -data RealSrcSpan - = RealSrcSpan' - { srcSpanFile :: !FastString, - srcSpanSLine :: {-# UNPACK #-} !Int, - srcSpanSCol :: {-# UNPACK #-} !Int, - srcSpanELine :: {-# UNPACK #-} !Int, - srcSpanECol :: {-# UNPACK #-} !Int - } - deriving Eq - --- | Source Span --- --- A 'SrcSpan' identifies either a specific portion of a text file --- or a human-readable description of a location. -data SrcSpan = - RealSrcSpan !RealSrcSpan - | UnhelpfulSpan !FastString -- Just a general indication - -- also used to indicate an empty span - - deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we - -- derive Show for Token - -instance ToJson SrcSpan where - json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] - json (RealSrcSpan rss) = json rss - -instance ToJson RealSrcSpan where - json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)) - , ("startLine", JSInt srcSpanSLine) - , ("startCol", JSInt srcSpanSCol) - , ("endLine", JSInt srcSpanELine) - , ("endCol", JSInt srcSpanECol) - ] - -instance NFData SrcSpan where - rnf x = x `seq` () - --- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty -noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan -noSrcSpan = UnhelpfulSpan (fsLit "") -wiredInSrcSpan = UnhelpfulSpan (fsLit "") -interactiveSrcSpan = UnhelpfulSpan (fsLit "") - --- | Create a "bad" 'SrcSpan' that has not location information -mkGeneralSrcSpan :: FastString -> SrcSpan -mkGeneralSrcSpan = UnhelpfulSpan - --- | Create a 'SrcSpan' corresponding to a single point -srcLocSpan :: SrcLoc -> SrcSpan -srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str -srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l) - -realSrcLocSpan :: RealSrcLoc -> RealSrcSpan -realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col - --- | Create a 'SrcSpan' between two points in a file -mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan -mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 - where - line1 = srcLocLine loc1 - line2 = srcLocLine loc2 - col1 = srcLocCol loc1 - col2 = srcLocCol loc2 - file = srcLocFile loc1 - --- | 'True' if the span is known to straddle only one line. -isOneLineRealSpan :: RealSrcSpan -> Bool -isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _) - = line1 == line2 - --- | 'True' if the span is a single point -isPointRealSpan :: RealSrcSpan -> Bool -isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) - = line1 == line2 && col1 == col2 - --- | Create a 'SrcSpan' between two points in a file -mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan -mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str -mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str -mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2) - = RealSrcSpan (mkRealSrcSpan loc1 loc2) - --- | Combines two 'SrcSpan' into one that spans at least all the characters --- within both spans. Assumes the "file" part is the same in both inputs -combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan -combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful -combineSrcSpans l (UnhelpfulSpan _) = l -combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2) - = RealSrcSpan (combineRealSrcSpans span1 span2) - --- | Combines two 'SrcSpan' into one that spans at least all the characters --- within both spans. Assumes the "file" part is the same in both inputs -combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan -combineRealSrcSpans span1 span2 - = RealSrcSpan' file line_start col_start line_end col_end - where - (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) - (srcSpanStartLine span2, srcSpanStartCol span2) - (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) - (srcSpanEndLine span2, srcSpanEndCol span2) - file = srcSpanFile span1 - --- | Convert a SrcSpan into one that represents only its first character -srcSpanFirstCharacter :: SrcSpan -> SrcSpan -srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l -srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2 - where - loc1@(SrcLoc f l c) = realSrcSpanStart span - loc2 = SrcLoc f l (c+1) -{- -************************************************************************ -* * -\subsection[SrcSpan-predicates]{Predicates} -* * -************************************************************************ --} - --- | Test if a 'SrcSpan' is "good", i.e. has precise location information -isGoodSrcSpan :: SrcSpan -> Bool -isGoodSrcSpan (RealSrcSpan _) = True -isGoodSrcSpan (UnhelpfulSpan _) = False - -isOneLineSpan :: SrcSpan -> Bool --- ^ True if the span is known to straddle only one line. --- For "bad" 'SrcSpan', it returns False -isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s -isOneLineSpan (UnhelpfulSpan _) = False - --- | Tests whether the first span "contains" the other span, meaning --- that it covers at least as much source code. True where spans are equal. -containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool -containsSpan s1 s2 - = (srcSpanStartLine s1, srcSpanStartCol s1) - <= (srcSpanStartLine s2, srcSpanStartCol s2) - && (srcSpanEndLine s1, srcSpanEndCol s1) - >= (srcSpanEndLine s2, srcSpanEndCol s2) - && (srcSpanFile s1 == srcSpanFile s2) - -- We check file equality last because it is (presumably?) least - -- likely to fail. -{- -%************************************************************************ -%* * -\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} -* * -************************************************************************ --} - -srcSpanStartLine :: RealSrcSpan -> Int -srcSpanEndLine :: RealSrcSpan -> Int -srcSpanStartCol :: RealSrcSpan -> Int -srcSpanEndCol :: RealSrcSpan -> Int - -srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l -srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l -srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l -srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c - -{- -************************************************************************ -* * -\subsection[SrcSpan-access-fns]{Access functions} -* * -************************************************************************ --} - --- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable -srcSpanStart :: SrcSpan -> SrcLoc -srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s) - --- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable -srcSpanEnd :: SrcSpan -> SrcLoc -srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s) - -realSrcSpanStart :: RealSrcSpan -> RealSrcLoc -realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) - (srcSpanStartLine s) - (srcSpanStartCol s) - -realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc -realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) - (srcSpanEndLine s) - (srcSpanEndCol s) - --- | Obtains the filename for a 'SrcSpan' if it is "good" -srcSpanFileName_maybe :: SrcSpan -> Maybe FastString -srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s) -srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing - -{- -************************************************************************ -* * -\subsection[SrcSpan-instances]{Instances} -* * -************************************************************************ --} - --- We want to order RealSrcSpans first by the start point, then by the --- end point. -instance Ord RealSrcSpan where - a `compare` b = - (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` - (realSrcSpanEnd a `compare` realSrcSpanEnd b) - -instance Show RealSrcLoc where - show (SrcLoc filename row col) - = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col - --- Show is used by Lexer.x, because we derive Show for Token -instance Show RealSrcSpan where - show span@(RealSrcSpan' file sl sc el ec) - | isPointRealSpan span - = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc]) - - | isOneLineRealSpan span - = "SrcSpanOneLine " ++ show file ++ " " - ++ intercalate " " (map show [sl,sc,ec]) - - | otherwise - = "SrcSpanMultiLine " ++ show file ++ " " - ++ intercalate " " (map show [sl,sc,el,ec]) - - -instance Outputable RealSrcSpan where - ppr span = pprUserRealSpan True span - --- I don't know why there is this style-based difference --- = getPprStyle $ \ sty -> --- if userStyle sty || debugStyle sty then --- text (showUserRealSpan True span) --- else --- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, --- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] - -instance Outputable SrcSpan where - ppr span = pprUserSpan True span - --- I don't know why there is this style-based difference --- = getPprStyle $ \ sty -> --- if userStyle sty || debugStyle sty then --- pprUserSpan True span --- else --- case span of --- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" --- RealSrcSpan s -> ppr s - -pprUserSpan :: Bool -> SrcSpan -> SDoc -pprUserSpan _ (UnhelpfulSpan s) = ftext s -pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s - -pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc -pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _) - | isPointRealSpan span - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , int line <> colon - , int col ] - -pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) - | isOneLineRealSpan span - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , int line <> colon - , int scol - , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ] - -- For single-character or point spans, we just - -- output the starting column number - -pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , parens (int sline <> comma <> int scol) - , char '-' - , parens (int eline <> comma <> int ecol') ] - where - ecol' = if ecol == 0 then ecol else ecol - 1 - -{- -************************************************************************ -* * -\subsection[Located]{Attaching SrcSpans to things} -* * -************************************************************************ --} - --- | We attach SrcSpans to lots of things, so let's have a datatype for it. -data GenLocated l e = L l e - deriving (Eq, Ord, Data, Functor, Foldable, Traversable) - -type Located e = GenLocated SrcSpan e -type RealLocated e = GenLocated RealSrcSpan e - -unLoc :: GenLocated l e -> e -unLoc (L _ e) = e - -getLoc :: GenLocated l e -> l -getLoc (L l _) = l - -noLoc :: e -> Located e -noLoc e = L noSrcSpan e - -mkGeneralLocated :: String -> e -> Located e -mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e - -combineLocs :: Located a -> Located b -> SrcSpan -combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) - --- | Combine locations from two 'Located' things and add them to a third thing -addCLoc :: Located a -> Located b -> c -> Located c -addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c - --- not clear whether to add a general Eq instance, but this is useful sometimes: - --- | Tests whether the two located things are equal -eqLocated :: Eq a => Located a -> Located a -> Bool -eqLocated a b = unLoc a == unLoc b - --- not clear whether to add a general Ord instance, but this is useful sometimes: - --- | Tests the ordering of the two located things -cmpLocated :: Ord a => Located a -> Located a -> Ordering -cmpLocated a b = unLoc a `compare` unLoc b - -instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where - ppr (L l e) = -- TODO: We can't do this since Located was refactored into - -- GenLocated: - -- Print spans without the file name etc - -- ifPprDebug (braces (pprUserSpan False l)) - ifPprDebug (braces (ppr l)) - $$ ppr e - -{- -************************************************************************ -* * -\subsection{Ordering SrcSpans for InteractiveUI} -* * -************************************************************************ --} - --- | Alternative strategies for ordering 'SrcSpan's -leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering -rightmost = flip compare -leftmost_smallest = compare -leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b) - `thenCmp` - (srcSpanEnd b `compare` srcSpanEnd a) - --- | Determines whether a span encloses a given line and column index -spans :: SrcSpan -> (Int, Int) -> Bool -spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" -spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span - where loc = mkRealSrcLoc (srcSpanFile span) l c - --- | Determines whether a span is enclosed by another one -isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other - -> SrcSpan -- ^ The span it may be enclosed by - -> Bool -isSubspanOf src parent - | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False - | otherwise = srcSpanStart parent <= srcSpanStart src && - srcSpanEnd parent >= srcSpanEnd src diff --git a/basicTypes/UniqSupply.hs b/basicTypes/UniqSupply.hs deleted file mode 100644 --- a/basicTypes/UniqSupply.hs +++ /dev/null @@ -1,232 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, UnboxedTuples #-} - -module UniqSupply ( - -- * Main data type - UniqSupply, -- Abstractly - - -- ** Operations on supplies - uniqFromSupply, uniqsFromSupply, -- basic ops - takeUniqFromSupply, - - mkSplitUniqSupply, - splitUniqSupply, listSplitUniqSupply, - splitUniqSupply3, splitUniqSupply4, - - -- * Unique supply monad and its abstraction - UniqSM, MonadUnique(..), liftUs, - - -- ** Operations on the monad - initUs, initUs_, - lazyThenUs, lazyMapUs, - getUniqueSupplyM3, - - -- * Set supply strategy - initUniqSupply - ) where - -import Unique - -import GHC.IO - -import MonadUtils -import Control.Monad -import Data.Bits -import Data.Char - -#include "Unique.h" - -{- -************************************************************************ -* * -\subsection{Splittable Unique supply: @UniqSupply@} -* * -************************************************************************ --} - --- | Unique Supply --- --- A value of type 'UniqSupply' is unique, and it can --- supply /one/ distinct 'Unique'. Also, from the supply, one can --- also manufacture an arbitrary number of further 'UniqueSupply' values, --- which will be distinct from the first and from all others. -data UniqSupply - = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this - UniqSupply UniqSupply - -- when split => these two supplies - -mkSplitUniqSupply :: Char -> IO UniqSupply --- ^ Create a unique supply out of thin air. The character given must --- be distinct from those of all calls to this function in the compiler --- for the values generated to be truly unique. - -splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) --- ^ Build two 'UniqSupply' from a single one, each of which --- can supply its own 'Unique'. -listSplitUniqSupply :: UniqSupply -> [UniqSupply] --- ^ Create an infinite list of 'UniqSupply' from a single one -uniqFromSupply :: UniqSupply -> Unique --- ^ Obtain the 'Unique' from this particular 'UniqSupply' -uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite --- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply -takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) --- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply - -mkSplitUniqSupply c - = case ord c `shiftL` uNIQUE_BITS of - mask -> let - -- here comes THE MAGIC: - - -- This is one of the most hammered bits in the whole compiler - mk_supply - -- NB: Use unsafeInterleaveIO for thread-safety. - = unsafeInterleaveIO ( - genSym >>= \ u -> - mk_supply >>= \ s1 -> - mk_supply >>= \ s2 -> - return (MkSplitUniqSupply (mask .|. u) s1 s2) - ) - in - mk_supply - -foreign import ccall unsafe "genSym" genSym :: IO Int -foreign import ccall unsafe "initGenSym" initUniqSupply :: Int -> Int -> IO () - -splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) -listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 - -uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n -uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 -takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) - --- | Build three 'UniqSupply' from a single one, --- each of which can supply its own unique -splitUniqSupply3 :: UniqSupply -> (UniqSupply, UniqSupply, UniqSupply) -splitUniqSupply3 us = (us1, us2, us3) - where - (us1, us') = splitUniqSupply us - (us2, us3) = splitUniqSupply us' - --- | Build four 'UniqSupply' from a single one, --- each of which can supply its own unique -splitUniqSupply4 :: UniqSupply -> (UniqSupply, UniqSupply, UniqSupply, UniqSupply) -splitUniqSupply4 us = (us1, us2, us3, us4) - where - (us1, us2, us') = splitUniqSupply3 us - (us3, us4) = splitUniqSupply us' - -{- -************************************************************************ -* * -\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} -* * -************************************************************************ --} - --- | A monad which just gives the ability to obtain 'Unique's -newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) } - -instance Monad UniqSM where - (>>=) = thenUs - (>>) = (*>) - -instance Functor UniqSM where - fmap f (USM x) = USM (\us -> case x us of - (# r, us' #) -> (# f r, us' #)) - -instance Applicative UniqSM where - pure = returnUs - (USM f) <*> (USM x) = USM $ \us -> case f us of - (# ff, us' #) -> case x us' of - (# xx, us'' #) -> (# ff xx, us'' #) - (*>) = thenUs_ - --- | Run the 'UniqSM' action, returning the final 'UniqSupply' -initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) -initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) } - --- | Run the 'UniqSM' action, discarding the final 'UniqSupply' -initUs_ :: UniqSupply -> UniqSM a -> a -initUs_ init_us m = case unUSM m init_us of { (# r, _ #) -> r } - -{-# INLINE thenUs #-} -{-# INLINE lazyThenUs #-} -{-# INLINE returnUs #-} -{-# INLINE splitUniqSupply #-} - --- @thenUs@ is where we split the @UniqSupply@. - -liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) -liftUSM (USM m) us = case m us of (# a, us' #) -> (a, us') - -instance MonadFix UniqSM where - mfix m = USM (\us -> let (r,us') = liftUSM (m r) us in (# r,us' #)) - -thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b -thenUs (USM expr) cont - = USM (\us -> case (expr us) of - (# result, us' #) -> unUSM (cont result) us') - -lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b -lazyThenUs expr cont - = USM (\us -> let (result, us') = liftUSM expr us in unUSM (cont result) us') - -thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b -thenUs_ (USM expr) (USM cont) - = USM (\us -> case (expr us) of { (# _, us' #) -> cont us' }) - -returnUs :: a -> UniqSM a -returnUs result = USM (\us -> (# result, us #)) - -getUs :: UniqSM UniqSupply -getUs = USM (\us -> case splitUniqSupply us of (us1,us2) -> (# us1, us2 #)) - --- | A monad for generating unique identifiers -class Monad m => MonadUnique m where - -- | Get a new UniqueSupply - getUniqueSupplyM :: m UniqSupply - -- | Get a new unique identifier - getUniqueM :: m Unique - -- | Get an infinite list of new unique identifiers - getUniquesM :: m [Unique] - - -- This default definition of getUniqueM, while correct, is not as - -- efficient as it could be since it needlessly generates and throws away - -- an extra Unique. For your instances consider providing an explicit - -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. - getUniqueM = liftM uniqFromSupply getUniqueSupplyM - getUniquesM = liftM uniqsFromSupply getUniqueSupplyM - -instance MonadUnique UniqSM where - getUniqueSupplyM = getUs - getUniqueM = getUniqueUs - getUniquesM = getUniquesUs - -getUniqueSupplyM3 :: MonadUnique m => m (UniqSupply, UniqSupply, UniqSupply) -getUniqueSupplyM3 = liftM3 (,,) getUniqueSupplyM getUniqueSupplyM getUniqueSupplyM - -liftUs :: MonadUnique m => UniqSM a -> m a -liftUs m = getUniqueSupplyM >>= return . flip initUs_ m - -getUniqueUs :: UniqSM Unique -getUniqueUs = USM (\us -> case takeUniqFromSupply us of - (u,us') -> (# u, us' #)) - -getUniquesUs :: UniqSM [Unique] -getUniquesUs = USM (\us -> case splitUniqSupply us of - (us1,us2) -> (# uniqsFromSupply us1, us2 #)) - --- {-# SPECIALIZE mapM :: (a -> UniqSM b) -> [a] -> UniqSM [b] #-} --- {-# SPECIALIZE mapAndUnzipM :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) #-} --- {-# SPECIALIZE mapAndUnzip3M :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) #-} - -lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] -lazyMapUs _ [] = returnUs [] -lazyMapUs f (x:xs) - = f x `lazyThenUs` \ r -> - lazyMapUs f xs `lazyThenUs` \ rs -> - returnUs (r:rs) diff --git a/basicTypes/Unique.hs b/basicTypes/Unique.hs deleted file mode 100644 --- a/basicTypes/Unique.hs +++ /dev/null @@ -1,436 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -@Uniques@ are used to distinguish entities in the compiler (@Ids@, -@Classes@, etc.) from each other. Thus, @Uniques@ are the basic -comparison key in the compiler. - -If there is any single operation that needs to be fast, it is @Unique@ - -comparison. Unsurprisingly, there is quite a bit of huff-and-puff -directed to that end. - -Some of the other hair in this code is to be able to use a -``splittable @UniqueSupply@'' if requested/possible (not standard -Haskell). --} - -{-# LANGUAGE CPP, BangPatterns, MagicHash #-} - -module Unique ( - -- * Main data types - Unique, Uniquable(..), - uNIQUE_BITS, - - -- ** Constructors, destructors and operations on 'Unique's - hasKey, - - pprUniqueAlways, - - mkUniqueGrimily, -- Used in UniqSupply only! - getKey, -- Used in Var, UniqFM, Name only! - mkUnique, unpkUnique, -- Used in BinIface only - - deriveUnique, -- Ditto - newTagUnique, -- Used in CgCase - initTyVarUnique, - nonDetCmpUnique, - isValidKnownKeyUnique, -- Used in PrelInfo.knownKeyNamesOkay - - -- ** Making built-in uniques - - -- now all the built-in Uniques (and functions to make them) - -- [the Oh-So-Wonderful Haskell module system wins again...] - mkAlphaTyVarUnique, - mkPrimOpIdUnique, - mkPreludeMiscIdUnique, mkPreludeDataConUnique, - mkPreludeTyConUnique, mkPreludeClassUnique, - mkPArrDataConUnique, mkCoVarUnique, - - mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, - mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, - mkCostCentreUnique, - - mkBuiltinUnique, - mkPseudoUniqueD, - mkPseudoUniqueE, - mkPseudoUniqueH, - - -- ** Deriving uniques - -- *** From TyCon name uniques - tyConRepNameUnique, - -- *** From DataCon name uniques - dataConWorkerUnique, dataConRepNameUnique - ) where - -#include "HsVersions.h" -#include "Unique.h" - -import BasicTypes -import FastString -import Outputable -import Util - --- just for implementing a fast [0,61) -> Char function -import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) - -import Data.Char ( chr, ord ) -import Data.Bits - -{- -************************************************************************ -* * -\subsection[Unique-type]{@Unique@ type and operations} -* * -************************************************************************ - -The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. -Fast comparison is everything on @Uniques@: --} - --- | Unique identifier. --- --- The type of unique identifiers that are used in many places in GHC --- for fast ordering and equality tests. You should generate these with --- the functions from the 'UniqSupply' module --- --- These are sometimes also referred to as \"keys\" in comments in GHC. -newtype Unique = MkUnique Int - -{-# INLINE uNIQUE_BITS #-} -uNIQUE_BITS :: Int -uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS - -{- -Now come the functions which construct uniques from their pieces, and vice versa. -The stuff about unique *supplies* is handled further down this module. --} - -unpkUnique :: Unique -> (Char, Int) -- The reverse - -mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply -getKey :: Unique -> Int -- for Var - -incrUnique :: Unique -> Unique -stepUnique :: Unique -> Int -> Unique -deriveUnique :: Unique -> Int -> Unique -newTagUnique :: Unique -> Char -> Unique - -mkUniqueGrimily = MkUnique - -{-# INLINE getKey #-} -getKey (MkUnique x) = x - -incrUnique (MkUnique i) = MkUnique (i + 1) -stepUnique (MkUnique i) n = MkUnique (i + n) - --- deriveUnique uses an 'X' tag so that it won't clash with --- any of the uniques produced any other way --- SPJ says: this looks terribly smelly to me! -deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta) - --- newTagUnique changes the "domain" of a unique to a different char -newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u - --- | How many bits are devoted to the unique index (as opposed to the class --- character). -uniqueMask :: Int -uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1 - --- pop the Char in the top 8 bits of the Unique(Supply) - --- No 64-bit bugs here, as long as we have at least 32 bits. --JSM - --- and as long as the Char fits in 8 bits, which we assume anyway! - -mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces --- NOT EXPORTED, so that we can see all the Chars that --- are used in this one module -mkUnique c i - = MkUnique (tag .|. bits) - where - tag = ord c `shiftL` uNIQUE_BITS - bits = i .&. uniqueMask - -unpkUnique (MkUnique u) - = let - -- as long as the Char may have its eighth bit set, we - -- really do need the logical right-shift here! - tag = chr (u `shiftR` uNIQUE_BITS) - i = u .&. uniqueMask - in - (tag, i) - --- | The interface file symbol-table encoding assumes that known-key uniques fit --- in 30-bits; verify this. --- --- See Note [Symbol table representation of names] in BinIface for details. -isValidKnownKeyUnique :: Unique -> Bool -isValidKnownKeyUnique u = - case unpkUnique u of - (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) - -{- -************************************************************************ -* * -\subsection[Uniquable-class]{The @Uniquable@ class} -* * -************************************************************************ --} - --- | Class of things that we can obtain a 'Unique' from -class Uniquable a where - getUnique :: a -> Unique - -hasKey :: Uniquable a => a -> Unique -> Bool -x `hasKey` k = getUnique x == k - -instance Uniquable FastString where - getUnique fs = mkUniqueGrimily (uniqueOfFS fs) - -instance Uniquable Int where - getUnique i = mkUniqueGrimily i - -{- -************************************************************************ -* * -\subsection[Unique-instances]{Instance declarations for @Unique@} -* * -************************************************************************ - -And the whole point (besides uniqueness) is fast equality. We don't -use `deriving' because we want {\em precise} control of ordering -(equality on @Uniques@ is v common). --} - --- Note [Unique Determinism] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- The order of allocated @Uniques@ is not stable across rebuilds. --- The main reason for that is that typechecking interface files pulls --- @Uniques@ from @UniqSupply@ and the interface file for the module being --- currently compiled can, but doesn't have to exist. --- --- It gets more complicated if you take into account that the interface --- files are loaded lazily and that building multiple files at once has to --- work for any subset of interface files present. When you add parallelism --- this makes @Uniques@ hopelessly random. --- --- As such, to get deterministic builds, the order of the allocated --- @Uniques@ should not affect the final result. --- see also wiki/DeterministicBuilds --- --- Note [Unique Determinism and code generation] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The goal of the deterministic builds (wiki/DeterministicBuilds, #4012) --- is to get ABI compatible binaries given the same inputs and environment. --- The motivation behind that is that if the ABI doesn't change the --- binaries can be safely reused. --- Note that this is weaker than bit-for-bit identical binaries and getting --- bit-for-bit identical binaries is not a goal for now. --- This means that we don't care about nondeterminism that happens after --- the interface files are created, in particular we don't care about --- register allocation and code generation. --- To track progress on bit-for-bit determinism see #12262. - -eqUnique :: Unique -> Unique -> Bool -eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 - --- Provided here to make it explicit at the call-site that it can --- introduce non-determinism. --- See Note [Unique Determinism] --- See Note [No Ord for Unique] -nonDetCmpUnique :: Unique -> Unique -> Ordering -nonDetCmpUnique (MkUnique u1) (MkUnique u2) - = if u1 == u2 then EQ else if u1 < u2 then LT else GT - -{- -Note [No Ord for Unique] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Unique Determinism] the relative order of Uniques -is nondeterministic. To prevent from accidental use the Ord Unique -instance has been removed. -This makes it easier to maintain deterministic builds, but comes with some -drawbacks. -The biggest drawback is that Maps keyed by Uniques can't directly be used. -The alternatives are: - - 1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which - 2) Create a newtype wrapper based on Unique ordering where nondeterminism - is controlled. See Module.ModuleEnv - 3) Change the algorithm to use nonDetCmpUnique and document why it's still - deterministic - 4) Use TrieMap as done in CmmCommonBlockElim.groupByLabel --} - -instance Eq Unique where - a == b = eqUnique a b - a /= b = not (eqUnique a b) - -instance Uniquable Unique where - getUnique u = u - --- We do sometimes make strings with @Uniques@ in them: - -showUnique :: Unique -> String -showUnique uniq - = case unpkUnique uniq of - (tag, u) -> finish_show tag u (iToBase62 u) - -finish_show :: Char -> Int -> String -> String -finish_show 't' u _pp_u | u < 26 - = -- Special case to make v common tyvars, t1, t2, ... - -- come out as a, b, ... (shorter, easier to read) - [chr (ord 'a' + u)] -finish_show tag _ pp_u = tag : pp_u - -pprUniqueAlways :: Unique -> SDoc --- The "always" means regardless of -dsuppress-uniques --- It replaces the old pprUnique to remind callers that --- they should consider whether they want to consult --- Opt_SuppressUniques -pprUniqueAlways u - = text (showUnique u) - -instance Outputable Unique where - ppr = pprUniqueAlways - -instance Show Unique where - show uniq = showUnique uniq - -{- -************************************************************************ -* * -\subsection[Utils-base62]{Base-62 numbers} -* * -************************************************************************ - -A character-stingy way to read/write numbers (notably Uniques). -The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. -Code stolen from Lennart. --} - -iToBase62 :: Int -> String -iToBase62 n_ - = ASSERT(n_ >= 0) go n_ "" - where - go n cs | n < 62 - = let !c = chooseChar62 n in c : cs - | otherwise - = go q (c : cs) where (q, r) = quotRem n 62 - !c = chooseChar62 r - - chooseChar62 :: Int -> Char - {-# INLINE chooseChar62 #-} - chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n) - chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# - -{- -************************************************************************ -* * -\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} -* * -************************************************************************ - -Allocation of unique supply characters: - v,t,u : for renumbering value-, type- and usage- vars. - B: builtin - C-E: pseudo uniques (used in native-code generator) - X: uniques derived by deriveUnique - _: unifiable tyvars (above) - 0-9: prelude things below - (no numbers left any more..) - :: (prelude) parallel array data constructors - - other a-z: lower case chars for unique supplies. Used so far: - - d desugarer - f AbsC flattener - g SimplStg - k constraint tuple tycons - m constraint tuple datacons - n Native codegen - r Hsc name cache - s simplifier - z anonymous sums --} - -mkAlphaTyVarUnique :: Int -> Unique -mkPreludeClassUnique :: Int -> Unique -mkPreludeTyConUnique :: Int -> Unique -mkPreludeDataConUnique :: Arity -> Unique -mkPrimOpIdUnique :: Int -> Unique -mkPreludeMiscIdUnique :: Int -> Unique -mkPArrDataConUnique :: Int -> Unique -mkCoVarUnique :: Int -> Unique - -mkAlphaTyVarUnique i = mkUnique '1' i -mkCoVarUnique i = mkUnique 'g' i -mkPreludeClassUnique i = mkUnique '2' i - --------------------------------------------------- --- Wired-in type constructor keys occupy *two* slots: --- * u: the TyCon itself --- * u+1: the TyConRepName of the TyCon -mkPreludeTyConUnique i = mkUnique '3' (2*i) - -tyConRepNameUnique :: Unique -> Unique -tyConRepNameUnique u = incrUnique u - --- Data constructor keys occupy *two* slots. The first is used for the --- data constructor itself and its wrapper function (the function that --- evaluates arguments as necessary and calls the worker). The second is --- used for the worker function (the function that builds the constructor --- representation). - --------------------------------------------------- --- Wired-in data constructor keys occupy *three* slots: --- * u: the DataCon itself --- * u+1: its worker Id --- * u+2: the TyConRepName of the promoted TyCon --- Prelude data constructors are too simple to need wrappers. - -mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic - --------------------------------------------------- -dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique -dataConWorkerUnique u = incrUnique u -dataConRepNameUnique u = stepUnique u 2 - --------------------------------------------------- -mkPrimOpIdUnique op = mkUnique '9' op -mkPreludeMiscIdUnique i = mkUnique '0' i - --- No numbers left anymore, so I pick something different for the character tag -mkPArrDataConUnique a = mkUnique ':' (2*a) - --- The "tyvar uniques" print specially nicely: a, b, c, etc. --- See pprUnique for details - -initTyVarUnique :: Unique -initTyVarUnique = mkUnique 't' 0 - -mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, - mkBuiltinUnique :: Int -> Unique - -mkBuiltinUnique i = mkUnique 'B' i -mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs -mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs -mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs - -mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique -mkRegSingleUnique = mkUnique 'R' -mkRegSubUnique = mkUnique 'S' -mkRegPairUnique = mkUnique 'P' -mkRegClassUnique = mkUnique 'L' - -mkCostCentreUnique :: Int -> Unique -mkCostCentreUnique = mkUnique 'C' - -mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique --- See Note [The Unique of an OccName] in OccName -mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs) -mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs) -mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs) -mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) diff --git a/basicTypes/Var.hs b/basicTypes/Var.hs deleted file mode 100644 --- a/basicTypes/Var.hs +++ /dev/null @@ -1,643 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{@Vars@: Variables} --} - -{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally --- potentially contain type variables, which have a 'TyCoRep.Kind' --- rather than a 'TyCoRep.Type' and only contain some extra --- details during typechecking. --- --- These 'Var.Var' names may either be global or local, see "Var#globalvslocal" --- --- #globalvslocal# --- Global 'Id's and 'Var's are those that are imported or correspond --- to a data constructor, primitive operation, or record selectors. --- Local 'Id's and 'Var's are those bound within an expression --- (e.g. by a lambda) or at the top level of the module being compiled. - -module Var ( - -- * The main data type and synonyms - Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId, - TyVar, TypeVar, KindVar, TKVar, TyCoVar, - - -- * In and Out variants - InVar, InCoVar, InId, InTyVar, - OutVar, OutCoVar, OutId, OutTyVar, - - -- ** Taking 'Var's apart - varName, varUnique, varType, - - -- ** Modifying 'Var's - setVarName, setVarUnique, setVarType, updateVarType, - updateVarTypeM, - - -- ** Constructing, taking apart, modifying 'Id's - mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, - idInfo, idDetails, - lazySetIdInfo, setIdDetails, globaliseId, - setIdExported, setIdNotExported, - - -- ** Predicates - isId, isTyVar, isTcTyVar, - isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar, - isGlobalId, isExportedId, - mustHaveLocalBinding, - - -- * TyVar's - TyVarBndr(..), ArgFlag(..), TyVarBinder, - binderVar, binderVars, binderArgFlag, binderKind, - isVisibleArgFlag, isInvisibleArgFlag, sameVis, - - -- ** Constructing TyVar's - mkTyVar, mkTcTyVar, - - -- ** Taking 'TyVar's apart - tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, - - -- ** Modifying 'TyVar's - setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, - updateTyVarKindM, - - nonDetCmpVar - - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TyCoRep( Type, Kind, pprKind ) -import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) -import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails, - vanillaIdInfo, pprIdDetails ) - -import Name hiding (varName) -import Unique ( Uniquable, Unique, getKey, getUnique - , mkUniqueGrimily, nonDetCmpUnique ) -import Util -import Binary -import DynFlags -import Outputable - -import Data.Data - -{- -************************************************************************ -* * - Synonyms -* * -************************************************************************ --- These synonyms are here and not in Id because otherwise we need a very --- large number of SOURCE imports of Id.hs :-( --} - --- | Identifier -type Id = Var -- A term-level identifier - -- predicate: isId - --- | Coercion Variable -type CoVar = Id -- See Note [Evidence: EvIds and CoVars] - -- predicate: isCoVar - --- | -type NcId = Id -- A term-level (value) variable that is - -- /not/ an (unlifted) coercion - -- predicate: isNonCoVarId - --- | Type or kind Variable -type TyVar = Var -- Type *or* kind variable (historical) - --- | Type or Kind Variable -type TKVar = Var -- Type *or* kind variable (historical) - --- | Type Variable -type TypeVar = Var -- Definitely a type variable - --- | Kind Variable -type KindVar = Var -- Definitely a kind variable - -- See Note [Kind and type variables] - --- See Note [Evidence: EvIds and CoVars] --- | Evidence Identifier -type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar - --- | Evidence Variable -type EvVar = EvId -- ...historical name for EvId - --- | Dictionary Function Identifier -type DFunId = Id -- A dictionary function - --- | Dictionary Identifier -type DictId = EvId -- A dictionary variable - --- | Implicit parameter Identifier -type IpId = EvId -- A term-level implicit parameter - --- | Equality Variable -type EqVar = EvId -- Boxed equality evidence -type JoinId = Id -- A join variable - --- | Type or Coercion Variable -type TyCoVar = Id -- Type, *or* coercion variable - -- predicate: isTyCoVar - - -{- Many passes apply a substitution, and it's very handy to have type - synonyms to remind us whether or not the subsitution has been applied -} - -type InVar = Var -type InTyVar = TyVar -type InCoVar = CoVar -type InId = Id -type OutVar = Var -type OutTyVar = TyVar -type OutCoVar = CoVar -type OutId = Id - - - -{- Note [Evidence: EvIds and CoVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* An EvId (evidence Id) is a term-level evidence variable - (dictionary, implicit parameter, or equality). Could be boxed or unboxed. - -* DictId, IpId, and EqVar are synonyms when we know what kind of - evidence we are talking about. For example, an EqVar has type (t1 ~ t2). - -* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2) - -Note [Kind and type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before kind polymorphism, TyVar were used to mean type variables. Now -they are use to mean kind *or* type variables. KindVar is used when we -know for sure that it is a kind variable. In future, we might want to -go over the whole compiler code to use: - - TKVar to mean kind or type variables - - TypeVar to mean type variables only - - KindVar to mean kind variables - - -************************************************************************ -* * -\subsection{The main data type declarations} -* * -************************************************************************ - - -Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a -@Type@, and an @IdInfo@ (non-essential info about it, e.g., -strictness). The essential info about different kinds of @Vars@ is -in its @VarDetails@. --} - --- | Variable --- --- Essentially a typed 'Name', that may also contain some additional information --- about the 'Var' and it's use sites. -data Var - = TyVar { -- Type and kind variables - -- see Note [Kind and type variables] - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - -- ^ Key for fast comparison - -- Identical to the Unique in the name, - -- cached here for speed - varType :: Kind -- ^ The type or kind of the 'Var' in question - } - - | TcTyVar { -- Used only during type inference - -- Used for kind variables during - -- inference, as well - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - varType :: Kind, - tc_tv_details :: TcTyVarDetails - } - - | Id { - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - varType :: Type, - idScope :: IdScope, - id_details :: IdDetails, -- Stable, doesn't change - id_info :: IdInfo } -- Unstable, updated by simplifier - --- | Identifier Scope -data IdScope -- See Note [GlobalId/LocalId] - = GlobalId - | LocalId ExportFlag - -data ExportFlag -- See Note [ExportFlag on binders] - = NotExported -- ^ Not exported: may be discarded as dead code. - | Exported -- ^ Exported: kept alive - -{- Note [ExportFlag on binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An ExportFlag of "Exported" on a top-level binder says "keep this -binding alive; do not drop it as dead code". This transitively -keeps alive all the other top-level bindings that this binding refers -to. This property is persisted all the way down the pipeline, so that -the binding will be compiled all the way to object code, and its -symbols will appear in the linker symbol table. - -However, note that this use of "exported" is quite different to the -export list on a Haskell module. Setting the ExportFlag on an Id does -/not/ mean that if you import the module (in Haskell source code) you -will see this Id. Of course, things that appear in the export list -of the source Haskell module do indeed have their ExportFlag set. -But many other things, such as dictionary functions, are kept alive -by having their ExportFlag set, even though they are not exported -in the source-code sense. - -We should probably use a different term for ExportFlag, like -KeepAlive. - -Note [GlobalId/LocalId] -~~~~~~~~~~~~~~~~~~~~~~~ -A GlobalId is - * always a constant (top-level) - * imported, or data constructor, or primop, or record selector - * has a Unique that is globally unique across the whole - GHC invocation (a single invocation may compile multiple modules) - * never treated as a candidate by the free-variable finder; - it's a constant! - -A LocalId is - * bound within an expression (lambda, case, local let(rec)) - * or defined at top level in the module being compiled - * always treated as a candidate by the free-variable finder - -After CoreTidy, top-level LocalIds are turned into GlobalIds --} - -instance Outputable Var where - ppr var = sdocWithDynFlags $ \dflags -> - getPprStyle $ \ppr_style -> - if | debugStyle ppr_style && (not (gopt Opt_SuppressVarKinds dflags)) - -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+> - dcolon <+> pprKind (tyVarKind var)) - | otherwise - -> ppr (varName var) <> ppr_debug var ppr_style - -ppr_debug :: Var -> PprStyle -> SDoc -ppr_debug (TyVar {}) sty - | debugStyle sty = brackets (text "tv") -ppr_debug (TcTyVar {tc_tv_details = d}) sty - | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) -ppr_debug (Id { idScope = s, id_details = d }) sty - | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d) -ppr_debug _ _ = empty - -ppr_id_scope :: IdScope -> SDoc -ppr_id_scope GlobalId = text "gid" -ppr_id_scope (LocalId Exported) = text "lidx" -ppr_id_scope (LocalId NotExported) = text "lid" - -instance NamedThing Var where - getName = varName - -instance Uniquable Var where - getUnique = varUnique - -instance Eq Var where - a == b = realUnique a == realUnique b - -instance Ord Var where - a <= b = realUnique a <= realUnique b - a < b = realUnique a < realUnique b - a >= b = realUnique a >= realUnique b - a > b = realUnique a > realUnique b - a `compare` b = a `nonDetCmpVar` b - --- | Compare Vars by their Uniques. --- This is what Ord Var does, provided here to make it explicit at the --- call-site that it can introduce non-determinism. --- See Note [Unique Determinism] -nonDetCmpVar :: Var -> Var -> Ordering -nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b - -instance Data Var where - -- don't traverse? - toConstr _ = abstractConstr "Var" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Var" - -instance HasOccName Var where - occName = nameOccName . varName - -varUnique :: Var -> Unique -varUnique var = mkUniqueGrimily (realUnique var) - -setVarUnique :: Var -> Unique -> Var -setVarUnique var uniq - = var { realUnique = getKey uniq, - varName = setNameUnique (varName var) uniq } - -setVarName :: Var -> Name -> Var -setVarName var new_name - = var { realUnique = getKey (getUnique new_name), - varName = new_name } - -setVarType :: Id -> Type -> Id -setVarType id ty = id { varType = ty } - -updateVarType :: (Type -> Type) -> Id -> Id -updateVarType f id = id { varType = f (varType id) } - -updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id -updateVarTypeM f id = do { ty' <- f (varType id) - ; return (id { varType = ty' }) } - -{- ********************************************************************* -* * -* ArgFlag -* * -********************************************************************* -} - --- | Argument Flag --- --- Is something required to appear in source Haskell ('Required'), --- permitted by request ('Specified') (visible type application), or --- prohibited entirely from appearing in source Haskell ('Inferred')? --- See Note [TyBinders and ArgFlags] in TyCoRep -data ArgFlag = Required | Specified | Inferred - deriving (Eq, Data) - --- | Does this 'ArgFlag' classify an argument that is written in Haskell? -isVisibleArgFlag :: ArgFlag -> Bool -isVisibleArgFlag Required = True -isVisibleArgFlag _ = False - --- | Does this 'ArgFlag' classify an argument that is not written in Haskell? -isInvisibleArgFlag :: ArgFlag -> Bool -isInvisibleArgFlag = not . isVisibleArgFlag - --- | Do these denote the same level of visibility? 'Required' --- arguments are visible, others are not. So this function --- equates 'Specified' and 'Inferred'. Used for printing. -sameVis :: ArgFlag -> ArgFlag -> Bool -sameVis Required Required = True -sameVis Required _ = False -sameVis _ Required = False -sameVis _ _ = True - -{- ********************************************************************* -* * -* TyVarBndr, TyVarBinder -* * -********************************************************************* -} - --- Type Variable Binder --- --- TyVarBndr is polymorphic in both tyvar and visiblity fields: --- * tyvar can be TyVar or IfaceTv --- * argf can be ArgFlag or TyConBndrVis -data TyVarBndr tyvar argf = TvBndr tyvar argf - deriving( Data ) - --- | Type Variable Binder --- --- A 'TyVarBinder' is the binder of a ForAllTy --- It's convenient to define this synonym here rather its natural --- home in TyCoRep, because it's used in DataCon.hs-boot -type TyVarBinder = TyVarBndr TyVar ArgFlag - -binderVar :: TyVarBndr tv argf -> tv -binderVar (TvBndr v _) = v - -binderVars :: [TyVarBndr tv argf] -> [tv] -binderVars tvbs = map binderVar tvbs - -binderArgFlag :: TyVarBndr tv argf -> argf -binderArgFlag (TvBndr _ argf) = argf - -binderKind :: TyVarBndr TyVar argf -> Kind -binderKind (TvBndr tv _) = tyVarKind tv - -{- -************************************************************************ -* * -* Type and kind variables * -* * -************************************************************************ --} - -tyVarName :: TyVar -> Name -tyVarName = varName - -tyVarKind :: TyVar -> Kind -tyVarKind = varType - -setTyVarUnique :: TyVar -> Unique -> TyVar -setTyVarUnique = setVarUnique - -setTyVarName :: TyVar -> Name -> TyVar -setTyVarName = setVarName - -setTyVarKind :: TyVar -> Kind -> TyVar -setTyVarKind tv k = tv {varType = k} - -updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar -updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} - -updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar -updateTyVarKindM update tv - = do { k' <- update (tyVarKind tv) - ; return $ tv {varType = k'} } - -mkTyVar :: Name -> Kind -> TyVar -mkTyVar name kind = TyVar { varName = name - , realUnique = getKey (nameUnique name) - , varType = kind - } - -mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar -mkTcTyVar name kind details - = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar' - TcTyVar { varName = name, - realUnique = getKey (nameUnique name), - varType = kind, - tc_tv_details = details - } - -tcTyVarDetails :: TyVar -> TcTyVarDetails --- See Note [TcTyVars in the typechecker] in TcType -tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details -tcTyVarDetails (TyVar {}) = vanillaSkolemTv -tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var)) - -setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar -setTcTyVarDetails tv details = tv { tc_tv_details = details } - -------------------------------------- -instance Outputable tv => Outputable (TyVarBndr tv ArgFlag) where - ppr (TvBndr v Required) = ppr v - ppr (TvBndr v Specified) = char '@' <> ppr v - ppr (TvBndr v Inferred) = braces (ppr v) - -instance Outputable ArgFlag where - ppr Required = text "[req]" - ppr Specified = text "[spec]" - ppr Inferred = text "[infrd]" - -instance (Binary tv, Binary vis) => Binary (TyVarBndr tv vis) where - put_ bh (TvBndr tv vis) = do { put_ bh tv; put_ bh vis } - - get bh = do { tv <- get bh; vis <- get bh; return (TvBndr tv vis) } - - -instance Binary ArgFlag where - put_ bh Required = putByte bh 0 - put_ bh Specified = putByte bh 1 - put_ bh Inferred = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> return Required - 1 -> return Specified - _ -> return Inferred - -{- -%************************************************************************ -%* * -\subsection{Ids} -* * -************************************************************************ --} - -idInfo :: HasDebugCallStack => Id -> IdInfo -idInfo (Id { id_info = info }) = info -idInfo other = pprPanic "idInfo" (ppr other) - -idDetails :: Id -> IdDetails -idDetails (Id { id_details = details }) = details -idDetails other = pprPanic "idDetails" (ppr other) - --- The next three have a 'Var' suffix even though they always build --- Ids, because Id.hs uses 'mkGlobalId' etc with different types -mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalVar details name ty info - = mk_id name ty GlobalId details info - -mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkLocalVar details name ty info - = mk_id name ty (LocalId NotExported) details info - -mkCoVar :: Name -> Type -> CoVar --- Coercion variables have no IdInfo -mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo - --- | Exported 'Var's will not be removed as dead code -mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkExportedLocalVar details name ty info - = mk_id name ty (LocalId Exported) details info - -mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id -mk_id name ty scope details info - = Id { varName = name, - realUnique = getKey (nameUnique name), - varType = ty, - idScope = scope, - id_details = details, - id_info = info } - -------------------- -lazySetIdInfo :: Id -> IdInfo -> Var -lazySetIdInfo id info = id { id_info = info } - -setIdDetails :: Id -> IdDetails -> Id -setIdDetails id details = id { id_details = details } - -globaliseId :: Id -> Id --- ^ If it's a local, make it global -globaliseId id = id { idScope = GlobalId } - -setIdExported :: Id -> Id --- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors --- and class operations, which are born as global 'Id's and automatically exported -setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } -setIdExported id@(Id { idScope = GlobalId }) = id -setIdExported tv = pprPanic "setIdExported" (ppr tv) - -setIdNotExported :: Id -> Id --- ^ We can only do this to LocalIds -setIdNotExported id = ASSERT( isLocalId id ) - id { idScope = LocalId NotExported } - -{- -************************************************************************ -* * -\subsection{Predicates over variables} -* * -************************************************************************ --} - -isTyVar :: Var -> Bool -- True of both TyVar and TcTyVar -isTyVar (TyVar {}) = True -isTyVar (TcTyVar {}) = True -isTyVar _ = False - -isTcTyVar :: Var -> Bool -- True of TcTyVar only -isTcTyVar (TcTyVar {}) = True -isTcTyVar _ = False - -isTyCoVar :: Var -> Bool -isTyCoVar v = isTyVar v || isCoVar v - -isId :: Var -> Bool -isId (Id {}) = True -isId _ = False - -isCoVar :: Var -> Bool --- A coercion variable -isCoVar (Id { id_details = details }) = isCoVarDetails details -isCoVar _ = False - -isNonCoVarId :: Var -> Bool --- A term variable (Id) that is /not/ a coercion variable -isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details) -isNonCoVarId _ = False - -isLocalId :: Var -> Bool -isLocalId (Id { idScope = LocalId _ }) = True -isLocalId _ = False - --- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's --- These are the variables that we need to pay attention to when finding free --- variables, or doing dependency analysis. -isLocalVar :: Var -> Bool -isLocalVar v = not (isGlobalId v) - -isGlobalId :: Var -> Bool -isGlobalId (Id { idScope = GlobalId }) = True -isGlobalId _ = False - --- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's --- that must have a binding in this module. The converse --- is not quite right: there are some global 'Id's that must have --- bindings, such as record selectors. But that doesn't matter, --- because it's only used for assertions -mustHaveLocalBinding :: Var -> Bool -mustHaveLocalBinding var = isLocalVar var - --- | 'isExportedIdVar' means \"don't throw this away\" -isExportedId :: Var -> Bool -isExportedId (Id { idScope = GlobalId }) = True -isExportedId (Id { idScope = LocalId Exported}) = True -isExportedId _ = False diff --git a/basicTypes/VarEnv.hs b/basicTypes/VarEnv.hs deleted file mode 100644 --- a/basicTypes/VarEnv.hs +++ /dev/null @@ -1,598 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module VarEnv ( - -- * Var, Id and TyVar environments (maps) - VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv, - - -- ** Manipulating these environments - emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, - elemVarEnv, disjointVarEnv, - extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly, - extendVarEnvList, - plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, - plusVarEnvList, alterVarEnv, - delVarEnvList, delVarEnv, delVarEnv_Directly, - minusVarEnv, intersectsVarEnv, - lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, - mapVarEnv, zipVarEnv, - modifyVarEnv, modifyVarEnv_Directly, - isEmptyVarEnv, - elemVarEnvByKey, lookupVarEnv_Directly, - filterVarEnv, filterVarEnv_Directly, restrictVarEnv, - partitionVarEnv, - - -- * Deterministic Var environments (maps) - DVarEnv, DIdEnv, DTyVarEnv, - - -- ** Manipulating these environments - emptyDVarEnv, mkDVarEnv, - dVarEnvElts, - extendDVarEnv, extendDVarEnv_C, - extendDVarEnvList, - lookupDVarEnv, elemDVarEnv, - isEmptyDVarEnv, foldDVarEnv, - mapDVarEnv, - modifyDVarEnv, - alterDVarEnv, - plusDVarEnv, plusDVarEnv_C, - unitDVarEnv, - delDVarEnv, - delDVarEnvList, - minusDVarEnv, - partitionDVarEnv, - anyDVarEnv, - - -- * The InScopeSet type - InScopeSet, - - -- ** Operations on InScopeSets - emptyInScopeSet, mkInScopeSet, delInScopeSet, - extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, - getInScopeVars, lookupInScope, lookupInScope_Directly, - unionInScope, elemInScopeSet, uniqAway, - varSetInScope, - - -- * The RnEnv2 type - RnEnv2, - - -- ** Operations on RnEnv2s - mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, - rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, - rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, - delBndrL, delBndrR, delBndrsL, delBndrsR, - addRnInScopeSet, - rnEtaL, rnEtaR, - rnInScope, rnInScopeSet, lookupRnInScope, - rnEnvL, rnEnvR, - - -- * TidyEnv and its operation - TidyEnv, - emptyTidyEnv - ) where - -import OccName -import Var -import VarSet -import UniqSet -import UniqFM -import UniqDFM -import Unique -import Util -import Maybes -import Outputable - -{- -************************************************************************ -* * - In-scope sets -* * -************************************************************************ --} - --- | A set of variables that are in scope at some point --- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides --- the motivation for this abstraction. -data InScopeSet = InScope VarSet {-# UNPACK #-} !Int - -- We store a VarSet here, but we use this for lookups rather than - -- just membership tests. Typically the InScopeSet contains the - -- canonical version of the variable (e.g. with an informative - -- unfolding), so this lookup is useful. - -- - -- The Int is a kind of hash-value used by uniqAway - -- For example, it might be the size of the set - -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway - -instance Outputable InScopeSet where - ppr (InScope s _) = - text "InScope" <+> - braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) - -- It's OK to use nonDetEltsUniqSet here because it's - -- only for pretty printing - -- In-scope sets get big, and with -dppr-debug - -- the output is overwhelming - -emptyInScopeSet :: InScopeSet -emptyInScopeSet = InScope emptyVarSet 1 - -getInScopeVars :: InScopeSet -> VarSet -getInScopeVars (InScope vs _) = vs - -mkInScopeSet :: VarSet -> InScopeSet -mkInScopeSet in_scope = InScope in_scope 1 - -extendInScopeSet :: InScopeSet -> Var -> InScopeSet -extendInScopeSet (InScope in_scope n) v - = InScope (extendVarSet in_scope v) (n + 1) - -extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet -extendInScopeSetList (InScope in_scope n) vs - = InScope (foldl (\s v -> extendVarSet s v) in_scope vs) - (n + length vs) - -extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet -extendInScopeSetSet (InScope in_scope n) vs - = InScope (in_scope `unionVarSet` vs) (n + sizeUniqSet vs) - -delInScopeSet :: InScopeSet -> Var -> InScopeSet -delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarSet` v) n - -elemInScopeSet :: Var -> InScopeSet -> Bool -elemInScopeSet v (InScope in_scope _) = v `elemVarSet` in_scope - --- | Look up a variable the 'InScopeSet'. This lets you map from --- the variable's identity (unique) to its full value. -lookupInScope :: InScopeSet -> Var -> Maybe Var -lookupInScope (InScope in_scope _) v = lookupVarSet in_scope v - -lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var -lookupInScope_Directly (InScope in_scope _) uniq - = lookupVarSet_Directly in_scope uniq - -unionInScope :: InScopeSet -> InScopeSet -> InScopeSet -unionInScope (InScope s1 _) (InScope s2 n2) - = InScope (s1 `unionVarSet` s2) n2 - -varSetInScope :: VarSet -> InScopeSet -> Bool -varSetInScope vars (InScope s1 _) = vars `subVarSet` s1 - --- | @uniqAway in_scope v@ finds a unique that is not used in the --- in-scope set, and gives that to v. -uniqAway :: InScopeSet -> Var -> Var --- It starts with v's current unique, of course, in the hope that it won't --- have to change, and thereafter uses a combination of that and the hash-code --- found in the in-scope set -uniqAway in_scope var - | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one - | otherwise = var -- Nothing to do - -uniqAway' :: InScopeSet -> Var -> Var --- This one *always* makes up a new variable -uniqAway' (InScope set n) var - = try 1 - where - orig_unique = getUnique var - try k - | debugIsOn && (k > 1000) - = pprPanic "uniqAway loop:" msg - | uniq `elemVarSetByKey` set = try (k + 1) - | k > 3 - = pprTraceDebug "uniqAway:" msg - setVarUnique var uniq - | otherwise = setVarUnique var uniq - where - msg = ppr k <+> text "tries" <+> ppr var <+> int n - uniq = deriveUnique orig_unique (n * k) - -{- -************************************************************************ -* * - Dual renaming -* * -************************************************************************ --} - --- | Rename Environment 2 --- --- When we are comparing (or matching) types or terms, we are faced with --- \"going under\" corresponding binders. E.g. when comparing: --- --- > \x. e1 ~ \y. e2 --- --- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of --- things we must be careful of. In particular, @x@ might be free in @e2@, or --- y in @e1@. So the idea is that we come up with a fresh binder that is free --- in neither, and rename @x@ and @y@ respectively. That means we must maintain: --- --- 1. A renaming for the left-hand expression --- --- 2. A renaming for the right-hand expressions --- --- 3. An in-scope set --- --- Furthermore, when matching, we want to be able to have an 'occurs check', --- to prevent: --- --- > \x. f ~ \y. y --- --- matching with [@f@ -> @y@]. So for each expression we want to know that set of --- locally-bound variables. That is precisely the domain of the mappings 1. --- and 2., but we must ensure that we always extend the mappings as we go in. --- --- All of this information is bundled up in the 'RnEnv2' -data RnEnv2 - = RV2 { envL :: VarEnv Var -- Renaming for Left term - , envR :: VarEnv Var -- Renaming for Right term - , in_scope :: InScopeSet } -- In scope in left or right terms - --- The renamings envL and envR are *guaranteed* to contain a binding --- for every variable bound as we go into the term, even if it is not --- renamed. That way we can ask what variables are locally bound --- (inRnEnvL, inRnEnvR) - -mkRnEnv2 :: InScopeSet -> RnEnv2 -mkRnEnv2 vars = RV2 { envL = emptyVarEnv - , envR = emptyVarEnv - , in_scope = vars } - -addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2 -addRnInScopeSet env vs - | isEmptyVarSet vs = env - | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } - -rnInScope :: Var -> RnEnv2 -> Bool -rnInScope x env = x `elemInScopeSet` in_scope env - -rnInScopeSet :: RnEnv2 -> InScopeSet -rnInScopeSet = in_scope - --- | Retrieve the left mapping -rnEnvL :: RnEnv2 -> VarEnv Var -rnEnvL = envL - --- | Retrieve the right mapping -rnEnvR :: RnEnv2 -> VarEnv Var -rnEnvR = envR - -rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 --- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length -rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR - -rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 --- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, --- and binder @bR@ in the Right term. --- It finds a new binder, @new_b@, --- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ -rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR - -rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but returns the new variable as well as the --- new environment -rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR - = (RV2 { envL = extendVarEnv envL bL new_b -- See Note - , envR = extendVarEnv envR bR new_b -- [Rebinding] - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - -- Find a new binder not in scope in either term - new_b | not (bL `elemInScopeSet` in_scope) = bL - | not (bR `elemInScopeSet` in_scope) = bR - | otherwise = uniqAway' in_scope bL - - -- Note [Rebinding] - -- If the new var is the same as the old one, note that - -- the extendVarEnv *deletes* any current renaming - -- E.g. (\x. \x. ...) ~ (\y. \z. ...) - -- - -- Inside \x \y { [x->y], [y->y], {y} } - -- \x \z { [x->x], [y->y, z->x], {y,x} } - -rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used when there's a binder on the left --- side only. -rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL - = (RV2 { envL = extendVarEnv envL bL new_b - , envR = envR - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bL - -rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used when there's a binder on the right --- side only. -rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR - = (RV2 { envR = extendVarEnv envR bR new_b - , envL = envL - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bR - -rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndrL' but used for eta expansion --- See Note [Eta expansion] -rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL - = (RV2 { envL = extendVarEnv envL bL new_b - , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bL - -rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used for eta expansion --- See Note [Eta expansion] -rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR - = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] - , envR = extendVarEnv envR bR new_b - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bR - -delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 -delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v - = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } -delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v - = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } - -delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 -delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v - = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } -delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v - = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } - -rnOccL, rnOccR :: RnEnv2 -> Var -> Var --- ^ Look up the renaming of an occurrence in the left or right term -rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v -rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v - -rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var --- ^ Look up the renaming of an occurrence in the left or right term -rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v -rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v - -inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool --- ^ Tells whether a variable is locally bound -inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env -inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env - -lookupRnInScope :: RnEnv2 -> Var -> Var -lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v - -nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 --- ^ Wipe the left or right side renaming -nukeRnEnvL env = env { envL = emptyVarEnv } -nukeRnEnvR env = env { envR = emptyVarEnv } - -rnSwap :: RnEnv2 -> RnEnv2 --- ^ swap the meaning of left and right -rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope }) - = RV2 { envL = envR, envR = envL, in_scope = in_scope } - -{- -Note [Eta expansion] -~~~~~~~~~~~~~~~~~~~~ -When matching - (\x.M) ~ N -we rename x to x' with, where x' is not in scope in -either term. Then we want to behave as if we'd seen - (\x'.M) ~ (\x'.N x') -Since x' isn't in scope in N, the form (\x'. N x') doesn't -capture any variables in N. But we must nevertheless extend -the envR with a binding [x' -> x'], to support the occurs check. -For example, if we don't do this, we can get silly matches like - forall a. (\y.a) ~ v -succeeding with [a -> v y], which is bogus of course. - - -************************************************************************ -* * - Tidying -* * -************************************************************************ --} - --- | Tidy Environment --- --- When tidying up print names, we keep a mapping of in-scope occ-names --- (the 'TidyOccEnv') and a Var-to-Var of the current renamings -type TidyEnv = (TidyOccEnv, VarEnv Var) - -emptyTidyEnv :: TidyEnv -emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) - -{- -************************************************************************ -* * -\subsection{@VarEnv@s} -* * -************************************************************************ --} - --- | Variable Environment -type VarEnv elt = UniqFM elt - --- | Identifier Environment -type IdEnv elt = VarEnv elt - --- | Type Variable Environment -type TyVarEnv elt = VarEnv elt - --- | Type or Coercion Variable Environment -type TyCoVarEnv elt = VarEnv elt - --- | Coercion Variable Environment -type CoVarEnv elt = VarEnv elt - -emptyVarEnv :: VarEnv a -mkVarEnv :: [(Var, a)] -> VarEnv a -mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a -zipVarEnv :: [Var] -> [a] -> VarEnv a -unitVarEnv :: Var -> a -> VarEnv a -alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a -extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a -extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a -extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b -extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a -plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a -plusVarEnvList :: [VarEnv a] -> VarEnv a -extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a - -lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a -filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a -delVarEnv_Directly :: VarEnv a -> Unique -> VarEnv a -partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) -restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a -delVarEnvList :: VarEnv a -> [Var] -> VarEnv a -delVarEnv :: VarEnv a -> Var -> VarEnv a -minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a -intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool -plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a -plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a -plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a -mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b -modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a - -isEmptyVarEnv :: VarEnv a -> Bool -lookupVarEnv :: VarEnv a -> Var -> Maybe a -filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a -lookupVarEnv_NF :: VarEnv a -> Var -> a -lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a -elemVarEnv :: Var -> VarEnv a -> Bool -elemVarEnvByKey :: Unique -> VarEnv a -> Bool -disjointVarEnv :: VarEnv a -> VarEnv a -> Bool - -elemVarEnv = elemUFM -elemVarEnvByKey = elemUFM_Directly -disjointVarEnv = disjointUFM -alterVarEnv = alterUFM -extendVarEnv = addToUFM -extendVarEnv_C = addToUFM_C -extendVarEnv_Acc = addToUFM_Acc -extendVarEnv_Directly = addToUFM_Directly -extendVarEnvList = addListToUFM -plusVarEnv_C = plusUFM_C -plusVarEnv_CD = plusUFM_CD -plusMaybeVarEnv_C = plusMaybeUFM_C -delVarEnvList = delListFromUFM -delVarEnv = delFromUFM -minusVarEnv = minusUFM -intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2)) -plusVarEnv = plusUFM -plusVarEnvList = plusUFMList -lookupVarEnv = lookupUFM -filterVarEnv = filterUFM -lookupWithDefaultVarEnv = lookupWithDefaultUFM -mapVarEnv = mapUFM -mkVarEnv = listToUFM -mkVarEnv_Directly= listToUFM_Directly -emptyVarEnv = emptyUFM -unitVarEnv = unitUFM -isEmptyVarEnv = isNullUFM -lookupVarEnv_Directly = lookupUFM_Directly -filterVarEnv_Directly = filterUFM_Directly -delVarEnv_Directly = delFromUFM_Directly -partitionVarEnv = partitionUFM - -restrictVarEnv env vs = filterVarEnv_Directly keep env - where - keep u _ = u `elemVarSetByKey` vs - -zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) -lookupVarEnv_NF env id = case lookupVarEnv env id of - Just xx -> xx - Nothing -> panic "lookupVarEnv_NF: Nothing" - -{- -@modifyVarEnv@: Look up a thing in the VarEnv, -then mash it with the modify function, and put it back. --} - -modifyVarEnv mangle_fn env key - = case (lookupVarEnv env key) of - Nothing -> env - Just xx -> extendVarEnv env key (mangle_fn xx) - -modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a -modifyVarEnv_Directly mangle_fn env key - = case (lookupUFM_Directly env key) of - Nothing -> env - Just xx -> addToUFM_Directly env key (mangle_fn xx) - --- Deterministic VarEnv --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DVarEnv. - --- | Deterministic Variable Environment -type DVarEnv elt = UniqDFM elt - --- | Deterministic Identifier Environment -type DIdEnv elt = DVarEnv elt - --- | Deterministic Type Variable Environment -type DTyVarEnv elt = DVarEnv elt - -emptyDVarEnv :: DVarEnv a -emptyDVarEnv = emptyUDFM - -dVarEnvElts :: DVarEnv a -> [a] -dVarEnvElts = eltsUDFM - -mkDVarEnv :: [(Var, a)] -> DVarEnv a -mkDVarEnv = listToUDFM - -extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a -extendDVarEnv = addToUDFM - -minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a -minusDVarEnv = minusUDFM - -lookupDVarEnv :: DVarEnv a -> Var -> Maybe a -lookupDVarEnv = lookupUDFM - -foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b -foldDVarEnv = foldUDFM - -mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b -mapDVarEnv = mapUDFM - -alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a -alterDVarEnv = alterUDFM - -plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a -plusDVarEnv = plusUDFM - -plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a -plusDVarEnv_C = plusUDFM_C - -unitDVarEnv :: Var -> a -> DVarEnv a -unitDVarEnv = unitUDFM - -delDVarEnv :: DVarEnv a -> Var -> DVarEnv a -delDVarEnv = delFromUDFM - -delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a -delDVarEnvList = delListFromUDFM - -isEmptyDVarEnv :: DVarEnv a -> Bool -isEmptyDVarEnv = isNullUDFM - -elemDVarEnv :: Var -> DVarEnv a -> Bool -elemDVarEnv = elemUDFM - -extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a -extendDVarEnv_C = addToUDFM_C - -modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a -modifyDVarEnv mangle_fn env key - = case (lookupDVarEnv env key) of - Nothing -> env - Just xx -> extendDVarEnv env key (mangle_fn xx) - -partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a) -partitionDVarEnv = partitionUDFM - -extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a -extendDVarEnvList = addListToUDFM - -anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool -anyDVarEnv = anyUDFM diff --git a/basicTypes/VarSet.hs b/basicTypes/VarSet.hs deleted file mode 100644 --- a/basicTypes/VarSet.hs +++ /dev/null @@ -1,340 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} - -module VarSet ( - -- * Var, Id and TyVar set types - VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet, - - -- ** Manipulating these sets - emptyVarSet, unitVarSet, mkVarSet, - extendVarSet, extendVarSetList, - elemVarSet, subVarSet, - unionVarSet, unionVarSets, mapUnionVarSet, - intersectVarSet, intersectsVarSet, disjointVarSet, - isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, - minusVarSet, filterVarSet, - anyVarSet, allVarSet, - transCloVarSet, fixVarSet, - lookupVarSet_Directly, lookupVarSet, lookupVarSetByName, - sizeVarSet, seqVarSet, - elemVarSetByKey, partitionVarSet, - pluralVarSet, pprVarSet, - - -- * Deterministic Var set types - DVarSet, DIdSet, DTyVarSet, DTyCoVarSet, - - -- ** Manipulating these sets - emptyDVarSet, unitDVarSet, mkDVarSet, - extendDVarSet, extendDVarSetList, - elemDVarSet, dVarSetElems, subDVarSet, - unionDVarSet, unionDVarSets, mapUnionDVarSet, - intersectDVarSet, intersectsDVarSet, disjointDVarSet, - isEmptyDVarSet, delDVarSet, delDVarSetList, - minusDVarSet, foldDVarSet, filterDVarSet, - dVarSetMinusVarSet, anyDVarSet, allDVarSet, - transCloDVarSet, - sizeDVarSet, seqDVarSet, - partitionDVarSet, - dVarSetToVarSet, - ) where - -#include "HsVersions.h" - -import Var ( Var, TyVar, CoVar, TyCoVar, Id ) -import Unique -import Name ( Name ) -import UniqSet -import UniqDSet -import UniqFM( disjointUFM, pluralUFM, pprUFM ) -import UniqDFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM ) -import Outputable (SDoc) - --- | A non-deterministic Variable Set --- --- A non-deterministic set of variables. --- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not --- deterministic and why it matters. Use DVarSet if the set eventually --- gets converted into a list or folded over in a way where the order --- changes the generated code, for example when abstracting variables. -type VarSet = UniqSet Var - --- | Identifier Set -type IdSet = UniqSet Id - --- | Type Variable Set -type TyVarSet = UniqSet TyVar - --- | Coercion Variable Set -type CoVarSet = UniqSet CoVar - --- | Type or Coercion Variable Set -type TyCoVarSet = UniqSet TyCoVar - -emptyVarSet :: VarSet -intersectVarSet :: VarSet -> VarSet -> VarSet -unionVarSet :: VarSet -> VarSet -> VarSet -unionVarSets :: [VarSet] -> VarSet - -mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet --- ^ map the function over the list, and union the results - -unitVarSet :: Var -> VarSet -extendVarSet :: VarSet -> Var -> VarSet -extendVarSetList:: VarSet -> [Var] -> VarSet -elemVarSet :: Var -> VarSet -> Bool -delVarSet :: VarSet -> Var -> VarSet -delVarSetList :: VarSet -> [Var] -> VarSet -minusVarSet :: VarSet -> VarSet -> VarSet -isEmptyVarSet :: VarSet -> Bool -mkVarSet :: [Var] -> VarSet -lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var -lookupVarSet :: VarSet -> Var -> Maybe Var - -- Returns the set element, which may be - -- (==) to the argument, but not the same as -lookupVarSetByName :: VarSet -> Name -> Maybe Var -sizeVarSet :: VarSet -> Int -filterVarSet :: (Var -> Bool) -> VarSet -> VarSet - -delVarSetByKey :: VarSet -> Unique -> VarSet -elemVarSetByKey :: Unique -> VarSet -> Bool -partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) - -emptyVarSet = emptyUniqSet -unitVarSet = unitUniqSet -extendVarSet = addOneToUniqSet -extendVarSetList= addListToUniqSet -intersectVarSet = intersectUniqSets - -intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection -disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection -subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second - -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; - -- ditto disjointVarSet, subVarSet - -unionVarSet = unionUniqSets -unionVarSets = unionManyUniqSets -elemVarSet = elementOfUniqSet -minusVarSet = minusUniqSet -delVarSet = delOneFromUniqSet -delVarSetList = delListFromUniqSet -isEmptyVarSet = isEmptyUniqSet -mkVarSet = mkUniqSet -lookupVarSet_Directly = lookupUniqSet_Directly -lookupVarSet = lookupUniqSet -lookupVarSetByName = lookupUniqSet -sizeVarSet = sizeUniqSet -filterVarSet = filterUniqSet -delVarSetByKey = delOneFromUniqSet_Directly -elemVarSetByKey = elemUniqSet_Directly -partitionVarSet = partitionUniqSet - -mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs - --- See comments with type signatures -intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) -disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2) -subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) - -anyVarSet :: (Var -> Bool) -> VarSet -> Bool -anyVarSet = uniqSetAny - -allVarSet :: (Var -> Bool) -> VarSet -> Bool -allVarSet = uniqSetAll - --- There used to exist mapVarSet, see Note [Unsound mapUniqSet] in UniqSet for --- why it got removed. - -fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set - -> VarSet -> VarSet --- (fixVarSet f s) repeatedly applies f to the set s, --- until it reaches a fixed point. -fixVarSet fn vars - | new_vars `subVarSet` vars = vars - | otherwise = fixVarSet fn new_vars - where - new_vars = fn vars - -transCloVarSet :: (VarSet -> VarSet) - -- Map some variables in the set to - -- extra variables that should be in it - -> VarSet -> VarSet --- (transCloVarSet f s) repeatedly applies f to new candidates, adding any --- new variables to s that it finds thereby, until it reaches a fixed point. --- --- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) --- for efficiency, so that the test can be batched up. --- It's essential that fn will work fine if given new candidates --- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 --- Use fixVarSet if the function needs to see the whole set all at once -transCloVarSet fn seeds - = go seeds seeds - where - go :: VarSet -- Accumulating result - -> VarSet -- Work-list; un-processed subset of accumulating result - -> VarSet - -- Specification: go acc vs = acc `union` transClo fn vs - - go acc candidates - | isEmptyVarSet new_vs = acc - | otherwise = go (acc `unionVarSet` new_vs) new_vs - where - new_vs = fn candidates `minusVarSet` acc - -seqVarSet :: VarSet -> () -seqVarSet s = sizeVarSet s `seq` () - --- | Determines the pluralisation suffix appropriate for the length of a set --- in the same way that plural from Outputable does for lists. -pluralVarSet :: VarSet -> SDoc -pluralVarSet = pluralUFM . getUniqSet - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetEltsUFM. --- Passing a list to the pretty-printing function allows the caller --- to decide on the order of Vars (eg. toposort them) without them having --- to use nonDetEltsUFM at the call site. This prevents from let-binding --- non-deterministically ordered lists and reusing them where determinism --- matters. -pprVarSet :: VarSet -- ^ The things to be pretty printed - -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the - -- elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprVarSet = pprUFM . getUniqSet - --- Deterministic VarSet --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DVarSet. - --- | Deterministic Variable Set -type DVarSet = UniqDSet Var - --- | Deterministic Identifier Set -type DIdSet = UniqDSet Id - --- | Deterministic Type Variable Set -type DTyVarSet = UniqDSet TyVar - --- | Deterministic Type or Coercion Variable Set -type DTyCoVarSet = UniqDSet TyCoVar - -emptyDVarSet :: DVarSet -emptyDVarSet = emptyUniqDSet - -unitDVarSet :: Var -> DVarSet -unitDVarSet = unitUniqDSet - -mkDVarSet :: [Var] -> DVarSet -mkDVarSet = mkUniqDSet - -extendDVarSet :: DVarSet -> Var -> DVarSet -extendDVarSet = addOneToUniqDSet - -elemDVarSet :: Var -> DVarSet -> Bool -elemDVarSet = elementOfUniqDSet - -dVarSetElems :: DVarSet -> [Var] -dVarSetElems = uniqDSetToList - -subDVarSet :: DVarSet -> DVarSet -> Bool -subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2) - -unionDVarSet :: DVarSet -> DVarSet -> DVarSet -unionDVarSet = unionUniqDSets - -unionDVarSets :: [DVarSet] -> DVarSet -unionDVarSets = unionManyUniqDSets - --- | Map the function over the list, and union the results -mapUnionDVarSet :: (a -> DVarSet) -> [a] -> DVarSet -mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs - -intersectDVarSet :: DVarSet -> DVarSet -> DVarSet -intersectDVarSet = intersectUniqDSets - --- | True if empty intersection -disjointDVarSet :: DVarSet -> DVarSet -> Bool -disjointDVarSet s1 s2 = disjointUDFM s1 s2 - --- | True if non-empty intersection -intersectsDVarSet :: DVarSet -> DVarSet -> Bool -intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2) - -isEmptyDVarSet :: DVarSet -> Bool -isEmptyDVarSet = isEmptyUniqDSet - -delDVarSet :: DVarSet -> Var -> DVarSet -delDVarSet = delOneFromUniqDSet - -minusDVarSet :: DVarSet -> DVarSet -> DVarSet -minusDVarSet = minusUniqDSet - -dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet -dVarSetMinusVarSet = uniqDSetMinusUniqSet - -foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a -foldDVarSet = foldUniqDSet - -anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool -anyDVarSet = anyUDFM - -allDVarSet :: (Var -> Bool) -> DVarSet -> Bool -allDVarSet = allUDFM - -filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet -filterDVarSet = filterUniqDSet - -sizeDVarSet :: DVarSet -> Int -sizeDVarSet = sizeUniqDSet - --- | Partition DVarSet according to the predicate given -partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet) -partitionDVarSet = partitionUniqDSet - --- | Delete a list of variables from DVarSet -delDVarSetList :: DVarSet -> [Var] -> DVarSet -delDVarSetList = delListFromUniqDSet - -seqDVarSet :: DVarSet -> () -seqDVarSet s = sizeDVarSet s `seq` () - --- | Add a list of variables to DVarSet -extendDVarSetList :: DVarSet -> [Var] -> DVarSet -extendDVarSetList = addListToUniqDSet - --- | Convert a DVarSet to a VarSet by forgeting the order of insertion -dVarSetToVarSet :: DVarSet -> VarSet -dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm - --- | transCloVarSet for DVarSet -transCloDVarSet :: (DVarSet -> DVarSet) - -- Map some variables in the set to - -- extra variables that should be in it - -> DVarSet -> DVarSet --- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any --- new variables to s that it finds thereby, until it reaches a fixed point. --- --- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) --- for efficiency, so that the test can be batched up. --- It's essential that fn will work fine if given new candidates --- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 -transCloDVarSet fn seeds - = go seeds seeds - where - go :: DVarSet -- Accumulating result - -> DVarSet -- Work-list; un-processed subset of accumulating result - -> DVarSet - -- Specification: go acc vs = acc `union` transClo fn vs - - go acc candidates - | isEmptyDVarSet new_vs = acc - | otherwise = go (acc `unionDVarSet` new_vs) new_vs - where - new_vs = fn candidates `minusDVarSet` acc diff --git a/cbits/cutils.c b/cbits/cutils.c new file mode 100644 --- /dev/null +++ b/cbits/cutils.c @@ -0,0 +1,24 @@ +/* +These utility routines are used various +places in the GHC library. +*/ + +#include + +#include + +void +enableTimingStats( void ) /* called from the driver */ +{ + RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS; +} + +void +setHeapSize( HsInt size ) +{ + RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE; + if (RtsFlags.GcFlags.maxHeapSize != 0 && + RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { + RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; + } +} diff --git a/cbits/genSym.c b/cbits/genSym.c --- a/cbits/genSym.c +++ b/cbits/genSym.c @@ -1,40 +1,26 @@ +#include #include -#include "Rts.h" #include "Unique.h" - -static HsInt GenSymCounter = 0; -static HsInt GenSymInc = 1; +#include -#define UNIQUE_BITS (sizeof (HsInt) * 8 - UNIQUE_TAG_BITS) -#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1) +// These global variables have been moved into the RTS. It allows them to be +// shared with plugins even if two different instances of the GHC library are +// loaded at the same time (#19940) +// +// The CPP is thus about the RTS version GHC is linked against, and not the +// version of the GHC being built. -STATIC_INLINE void checkUniqueRange(HsInt u STG_UNUSED) { -#if DEBUG - // Uh oh! We will overflow next time a unique is requested. - assert(u != UNIQUE_MASK); +#if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) +// Unique64 patch was present in 9.10 and later +#define HAVE_UNIQUE64 1 +#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0) +// Unique64 patch was backported to 9.8.4 +#define HAVE_UNIQUE64 1 +#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0) +// Unique64 patch was backported to 9.6.7 +#define HAVE_UNIQUE64 1 #endif -} -HsInt genSym(void) { -#if defined(THREADED_RTS) - if (n_capabilities == 1) { - GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK; - checkUniqueRange(GenSymCounter); - return GenSymCounter; - } else { - HsInt n = atomic_inc((StgWord *)&GenSymCounter, GenSymInc) - & UNIQUE_MASK; - checkUniqueRange(n); - return n; - } -#else - GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK; - checkUniqueRange(GenSymCounter); - return GenSymCounter; +#if !defined(HAVE_UNIQUE64) +HsWord64 ghc_unique_counter64 = 0; #endif -} - -void initGenSym(HsInt NewGenSymCounter, HsInt NewGenSymInc) { - GenSymCounter = NewGenSymCounter; - GenSymInc = NewGenSymInc; -} diff --git a/cbits/keepCAFsForGHCi.c b/cbits/keepCAFsForGHCi.c new file mode 100644 --- /dev/null +++ b/cbits/keepCAFsForGHCi.c @@ -0,0 +1,35 @@ +#include +#include + +// Note [keepCAFsForGHCi] +// ~~~~~~~~~~~~~~~~~~~~~~ +// This file is only included in the dynamic library. +// It contains an __attribute__((constructor)) function (run prior to main()) +// which sets the keepCAFs flag in the RTS, before any Haskell code is run. +// This is required so that GHCi can use dynamic libraries instead of HSxyz.o +// files. +// +// For static builds we have to guarantee that the linker loads this object file +// to ensure the constructor gets run and not discarded. If the object is part of +// an archive and not otherwise referenced the linker would ignore the object. +// To avoid this: +// * When initializing a GHC session in initGhcMonad we assert keeping cafs has been +// enabled by calling keepCAFsForGHCi. +// * This causes the GHC module from the ghc package to carry a reference to this object +// file. +// * Which in turn ensures the linker doesn't discard this object file, causing +// the constructor to be run, allowing the assertion to succeed in the first place +// as keepCAFs will have been set already during initialization of constructors. + + + +bool keepCAFsForGHCi(void) __attribute__((constructor)); + +bool keepCAFsForGHCi(void) +{ + bool was_set = keepCAFs; + setKeepCAFs(); + return was_set; +} + + diff --git a/cmm/Bitmap.hs b/cmm/Bitmap.hs deleted file mode 100644 --- a/cmm/Bitmap.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} - --- --- (c) The University of Glasgow 2003-2006 --- - --- Functions for constructing bitmaps, which are used in various --- places in generated code (stack frame liveness masks, function --- argument liveness masks, SRT bitmaps). - -module Bitmap ( - Bitmap, mkBitmap, - intsToBitmap, intsToReverseBitmap, - mAX_SMALL_BITMAP_SIZE, - seqBitmap, - ) where - -#include "HsVersions.h" -#include "MachDeps.h" - -import SMRep -import DynFlags -import Util - -import Data.Foldable (foldl') -import Data.Bits - -{-| -A bitmap represented by a sequence of 'StgWord's on the /target/ -architecture. These are used for bitmaps in info tables and other -generated code which need to be emitted as sequences of StgWords. --} -type Bitmap = [StgWord] - --- | Make a bitmap from a sequence of bits -mkBitmap :: DynFlags -> [Bool] -> Bitmap -mkBitmap _ [] = [] -mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest - where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff - -chunkToBitmap :: DynFlags -> [Bool] -> StgWord -chunkToBitmap dflags chunk = - foldl' (.|.) (toStgWord dflags 0) [ oneAt n | (True,n) <- zip chunk [0..] ] - where - oneAt :: Int -> StgWord - oneAt i = toStgWord dflags 1 `shiftL` i - --- | Make a bitmap where the slots specified are the /ones/ in the bitmap. --- eg. @[0,1,3], size 4 ==> 0xb@. --- --- The list of @Int@s /must/ be already sorted. -intsToBitmap :: DynFlags - -> Int -- ^ size in bits - -> [Int] -- ^ sorted indices of ones - -> Bitmap -intsToBitmap dflags size = go 0 - where - word_sz = wORD_SIZE_IN_BITS dflags - oneAt :: Int -> StgWord - oneAt i = toStgWord dflags 1 `shiftL` i - - -- It is important that we maintain strictness here. - -- See Note [Strictness when building Bitmaps]. - go :: Int -> [Int] -> Bitmap - go !pos slots - | size <= pos = [] - | otherwise = - (foldl' (.|.) (toStgWord dflags 0) (map (\i->oneAt (i - pos)) these)) : - go (pos + word_sz) rest - where - (these,rest) = span (< (pos + word_sz)) slots - --- | Make a bitmap where the slots specified are the /zeros/ in the bitmap. --- eg. @[0,1,3], size 4 ==> 0x4@ (we leave any bits outside the size as zero, --- just to make the bitmap easier to read). --- --- The list of @Int@s /must/ be already sorted and duplicate-free. -intsToReverseBitmap :: DynFlags - -> Int -- ^ size in bits - -> [Int] -- ^ sorted indices of zeros free of duplicates - -> Bitmap -intsToReverseBitmap dflags size = go 0 - where - word_sz = wORD_SIZE_IN_BITS dflags - oneAt :: Int -> StgWord - oneAt i = toStgWord dflags 1 `shiftL` i - - -- It is important that we maintain strictness here. - -- See Note [Strictness when building Bitmaps]. - go :: Int -> [Int] -> Bitmap - go !pos slots - | size <= pos = [] - | otherwise = - (foldl' xor (toStgWord dflags init) (map (\i->oneAt (i - pos)) these)) : - go (pos + word_sz) rest - where - (these,rest) = span (< (pos + word_sz)) slots - remain = size - pos - init - | remain >= word_sz = -1 - | otherwise = (1 `shiftL` remain) - 1 - -{- - -Note [Strictness when building Bitmaps] -======================================== - -One of the places where @Bitmap@ is used is in in building Static Reference -Tables (SRTs) (in @CmmBuildInfoTables.procpointSRT@). In #7450 it was noticed -that some test cases (particularly those whose C-- have large numbers of CAFs) -produced large quantities of allocations from this function. - -The source traced back to 'intsToBitmap', which was lazily subtracting the word -size from the elements of the tail of the @slots@ list and recursively invoking -itself with the result. This resulted in large numbers of subtraction thunks -being built up. Here we take care to avoid passing new thunks to the recursive -call. Instead we pass the unmodified tail along with an explicit position -accumulator, which get subtracted in the fold when we compute the Word. - --} - -{- | -Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h. -Some kinds of bitmap pack a size\/bitmap into a single word if -possible, or fall back to an external pointer when the bitmap is too -large. This value represents the largest size of bitmap that can be -packed into a single word. --} -mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int -mAX_SMALL_BITMAP_SIZE dflags - | wORD_SIZE dflags == 4 = 27 - | otherwise = 58 - -seqBitmap :: Bitmap -> a -> a -seqBitmap = seqList - diff --git a/cmm/BlockId.hs b/cmm/BlockId.hs deleted file mode 100644 --- a/cmm/BlockId.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{- BlockId module should probably go away completely, being superseded by Label -} -module BlockId - ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet - , newBlockId - , blockLbl, infoTblLbl - ) where - -import CLabel -import IdInfo -import Name -import Outputable -import Unique -import UniqSupply - -import Compiler.Hoopl as Hoopl hiding (Unique) -import Compiler.Hoopl.Internals (uniqueToLbl, lblToUnique) - ----------------------------------------------------------------- ---- Block Ids, their environments, and their sets - -{- Note [Unique BlockId] -~~~~~~~~~~~~~~~~~~~~~~~~ -Although a 'BlockId' is a local label, for reasons of implementation, -'BlockId's must be unique within an entire compilation unit. The reason -is that each local label is mapped to an assembly-language label, and in -most assembly languages allow, a label is visible throughout the entire -compilation unit in which it appears. --} - -type BlockId = Hoopl.Label - -instance Uniquable BlockId where - getUnique label = getUnique (lblToUnique label) - -instance Outputable BlockId where - ppr label = ppr (getUnique label) - -mkBlockId :: Unique -> BlockId -mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique - -newBlockId :: MonadUnique m => m BlockId -newBlockId = mkBlockId <$> getUniqueM - -blockLbl :: BlockId -> CLabel -blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs - -infoTblLbl :: BlockId -> CLabel -infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs diff --git a/cmm/CLabel.hs b/cmm/CLabel.hs deleted file mode 100644 --- a/cmm/CLabel.hs +++ /dev/null @@ -1,1332 +0,0 @@ ------------------------------------------------------------------------------ --- --- Object-file symbols (called CLabel for histerical raisins). --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -{-# LANGUAGE CPP #-} - -module CLabel ( - CLabel, -- abstract type - ForeignLabelSource(..), - pprDebugCLabel, - - mkClosureLabel, - mkSRTLabel, - mkTopSRTLabel, - mkInfoTableLabel, - mkEntryLabel, - mkSlowEntryLabel, - mkConEntryLabel, - mkRednCountsLabel, - mkConInfoTableLabel, - mkLargeSRTLabel, - mkApEntryLabel, - mkApInfoTableLabel, - mkClosureTableLabel, - mkBytesLabel, - - mkLocalClosureLabel, - mkLocalInfoTableLabel, - mkLocalEntryLabel, - mkLocalConEntryLabel, - mkLocalConInfoTableLabel, - mkLocalClosureTableLabel, - - mkReturnPtLabel, - mkReturnInfoLabel, - mkAltLabel, - mkDefaultLabel, - mkBitmapLabel, - mkStringLitLabel, - - mkAsmTempLabel, - mkAsmTempDerivedLabel, - mkAsmTempEndLabel, - mkAsmTempDieLabel, - - mkPlainModuleInitLabel, - - mkSplitMarkerLabel, - mkDirty_MUT_VAR_Label, - mkUpdInfoLabel, - mkBHUpdInfoLabel, - mkIndStaticInfoLabel, - mkMainCapabilityLabel, - mkMAP_FROZEN_infoLabel, - mkMAP_FROZEN0_infoLabel, - mkMAP_DIRTY_infoLabel, - mkSMAP_FROZEN_infoLabel, - mkSMAP_FROZEN0_infoLabel, - mkSMAP_DIRTY_infoLabel, - mkEMPTY_MVAR_infoLabel, - mkArrWords_infoLabel, - - mkTopTickyCtrLabel, - mkCAFBlackHoleInfoTableLabel, - mkCAFBlackHoleEntryLabel, - mkRtsPrimOpLabel, - mkRtsSlowFastTickyCtrLabel, - - mkSelectorInfoLabel, - mkSelectorEntryLabel, - - mkCmmInfoLabel, - mkCmmEntryLabel, - mkCmmRetInfoLabel, - mkCmmRetLabel, - mkCmmCodeLabel, - mkCmmDataLabel, - mkCmmClosureLabel, - - mkRtsApFastLabel, - - mkPrimCallLabel, - - mkForeignLabel, - addLabelSize, - - foreignLabelStdcallInfo, - isBytesLabel, - isForeignLabel, - mkCCLabel, mkCCSLabel, - - DynamicLinkerLabelInfo(..), - mkDynamicLinkerLabel, - dynamicLinkerLabelInfo, - - mkPicBaseLabel, - mkDeadStripPreventer, - - mkHpcTicksLabel, - - hasCAF, - needsCDecl, maybeAsmTemp, externallyVisibleCLabel, - isMathFun, - isCFunctionLabel, isGcPtrLabel, labelDynamic, - - -- * Conversions - toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, toRednCountsLbl, hasHaskellName, - - pprCLabel - ) where - -#include "HsVersions.h" - -import IdInfo -import BasicTypes -import Packages -import Module -import Name -import Unique -import PrimOp -import Config -import CostCentre -import Outputable -import FastString -import DynFlags -import Platform -import UniqSet -import Util -import PprCore ( {- instances -} ) - --- ----------------------------------------------------------------------------- --- The CLabel type - -{- - | CLabel is an abstract type that supports the following operations: - - - Pretty printing - - - In a C file, does it need to be declared before use? (i.e. is it - guaranteed to be already in scope in the places we need to refer to it?) - - - If it needs to be declared, what type (code or data) should it be - declared to have? - - - Is it visible outside this object file or not? - - - Is it "dynamic" (see details below) - - - Eq and Ord, so that we can make sets of CLabels (currently only - used in outputting C as far as I can tell, to avoid generating - more than one declaration for any given label). - - - Converting an info table label into an entry label. --} - -data CLabel - = -- | A label related to the definition of a particular Id or Con in a .hs file. - IdLabel - Name - CafInfo - IdLabelInfo -- encodes the suffix of the label - - -- | A label from a .cmm file that is not associated with a .hs level Id. - | CmmLabel - UnitId -- what package the label belongs to. - FastString -- identifier giving the prefix of the label - CmmLabelInfo -- encodes the suffix of the label - - -- | A label with a baked-in \/ algorithmically generated name that definitely - -- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so - -- If it doesn't have an algorithmically generated name then use a CmmLabel - -- instead and give it an appropriate UnitId argument. - | RtsLabel - RtsLabelInfo - - -- | A 'C' (or otherwise foreign) label. - -- - | ForeignLabel - FastString -- name of the imported label. - - (Maybe Int) -- possible '@n' suffix for stdcall functions - -- When generating C, the '@n' suffix is omitted, but when - -- generating assembler we must add it to the label. - - ForeignLabelSource -- what package the foreign label is in. - - FunctionOrData - - -- | A family of labels related to a particular case expression. - | CaseLabel - {-# UNPACK #-} !Unique -- Unique says which case expression - CaseLabelInfo - - | AsmTempLabel - {-# UNPACK #-} !Unique - - | AsmTempDerivedLabel - CLabel - FastString -- suffix - - | StringLitLabel - {-# UNPACK #-} !Unique - - | PlainModuleInitLabel -- without the version & way info - Module - - | CC_Label CostCentre - | CCS_Label CostCentreStack - - - -- | These labels are generated and used inside the NCG only. - -- They are special variants of a label used for dynamic linking - -- see module PositionIndependentCode for details. - | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel - - -- | This label is generated and used inside the NCG only. - -- It is used as a base for PIC calculations on some platforms. - -- It takes the form of a local numeric assembler label '1'; and - -- is pretty-printed as 1b, referring to the previous definition - -- of 1: in the assembler source file. - | PicBaseLabel - - -- | A label before an info table to prevent excessive dead-stripping on darwin - | DeadStripPreventer CLabel - - - -- | Per-module table of tick locations - | HpcTicksLabel Module - - -- | Static reference table - | SRTLabel !Unique - - -- | Label of an StgLargeSRT - | LargeSRTLabel - {-# UNPACK #-} !Unique - - -- | A bitmap (function or case return) - | LargeBitmapLabel - {-# UNPACK #-} !Unique - - deriving Eq - --- This is laborious, but necessary. We can't derive Ord because --- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the --- implementation. See Note [No Ord for Unique] --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] -instance Ord CLabel where - compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) = - compare a1 a2 `thenCmp` - compare b1 b2 `thenCmp` - compare c1 c2 - compare (CmmLabel a1 b1 c1) (CmmLabel a2 b2 c2) = - compare a1 a2 `thenCmp` - compare b1 b2 `thenCmp` - compare c1 c2 - compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2 - compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) = - compare a1 a2 `thenCmp` - compare b1 b2 `thenCmp` - compare c1 c2 `thenCmp` - compare d1 d2 - compare (CaseLabel u1 a1) (CaseLabel u2 a2) = - nonDetCmpUnique u1 u2 `thenCmp` - compare a1 a2 - compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2 - compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) = - compare a1 a2 `thenCmp` - compare b1 b2 - compare (StringLitLabel u1) (StringLitLabel u2) = - nonDetCmpUnique u1 u2 - compare (PlainModuleInitLabel a1) (PlainModuleInitLabel a2) = - compare a1 a2 - compare (CC_Label a1) (CC_Label a2) = - compare a1 a2 - compare (CCS_Label a1) (CCS_Label a2) = - compare a1 a2 - compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) = - compare a1 a2 `thenCmp` - compare b1 b2 - compare PicBaseLabel PicBaseLabel = EQ - compare (DeadStripPreventer a1) (DeadStripPreventer a2) = - compare a1 a2 - compare (HpcTicksLabel a1) (HpcTicksLabel a2) = - compare a1 a2 - compare (SRTLabel u1) (SRTLabel u2) = - nonDetCmpUnique u1 u2 - compare (LargeSRTLabel u1) (LargeSRTLabel u2) = - nonDetCmpUnique u1 u2 - compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) = - nonDetCmpUnique u1 u2 - compare IdLabel{} _ = LT - compare _ IdLabel{} = GT - compare CmmLabel{} _ = LT - compare _ CmmLabel{} = GT - compare RtsLabel{} _ = LT - compare _ RtsLabel{} = GT - compare ForeignLabel{} _ = LT - compare _ ForeignLabel{} = GT - compare CaseLabel{} _ = LT - compare _ CaseLabel{} = GT - compare AsmTempLabel{} _ = LT - compare _ AsmTempLabel{} = GT - compare AsmTempDerivedLabel{} _ = LT - compare _ AsmTempDerivedLabel{} = GT - compare StringLitLabel{} _ = LT - compare _ StringLitLabel{} = GT - compare PlainModuleInitLabel{} _ = LT - compare _ PlainModuleInitLabel{} = GT - compare CC_Label{} _ = LT - compare _ CC_Label{} = GT - compare CCS_Label{} _ = LT - compare _ CCS_Label{} = GT - compare DynamicLinkerLabel{} _ = LT - compare _ DynamicLinkerLabel{} = GT - compare PicBaseLabel{} _ = LT - compare _ PicBaseLabel{} = GT - compare DeadStripPreventer{} _ = LT - compare _ DeadStripPreventer{} = GT - compare HpcTicksLabel{} _ = LT - compare _ HpcTicksLabel{} = GT - compare SRTLabel{} _ = LT - compare _ SRTLabel{} = GT - compare LargeSRTLabel{} _ = LT - compare _ LargeSRTLabel{} = GT - --- | Record where a foreign label is stored. -data ForeignLabelSource - - -- | Label is in a named package - = ForeignLabelInPackage UnitId - - -- | Label is in some external, system package that doesn't also - -- contain compiled Haskell code, and is not associated with any .hi files. - -- We don't have to worry about Haskell code being inlined from - -- external packages. It is safe to treat the RTS package as "external". - | ForeignLabelInExternalPackage - - -- | Label is in the package currenly being compiled. - -- This is only used for creating hacky tmp labels during code generation. - -- Don't use it in any code that might be inlined across a package boundary - -- (ie, core code) else the information will be wrong relative to the - -- destination module. - | ForeignLabelInThisPackage - - deriving (Eq, Ord) - - --- | For debugging problems with the CLabel representation. --- We can't make a Show instance for CLabel because lots of its components don't have instances. --- The regular Outputable instance only shows the label name, and not its other info. --- -pprDebugCLabel :: CLabel -> SDoc -pprDebugCLabel lbl - = case lbl of - IdLabel{} -> ppr lbl <> (parens $ text "IdLabel") - CmmLabel pkg _name _info - -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg) - - RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel") - - ForeignLabel _name mSuffix src funOrData - -> ppr lbl <> (parens $ text "ForeignLabel" - <+> ppr mSuffix - <+> ppr src - <+> ppr funOrData) - - _ -> ppr lbl <> (parens $ text "other CLabel)") - - -data IdLabelInfo - = Closure -- ^ Label for closure - | SRT -- ^ Static reference table (TODO: could be removed - -- with the old code generator, but might be needed - -- when we implement the New SRT Plan) - | InfoTable -- ^ Info tables for closures; always read-only - | Entry -- ^ Entry point - | Slow -- ^ Slow entry point - - | LocalInfoTable -- ^ Like InfoTable but not externally visible - | LocalEntry -- ^ Like Entry but not externally visible - - | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id - - | ConEntry -- ^ Constructor entry point - | ConInfoTable -- ^ Corresponding info table - - | ClosureTable -- ^ Table of closures for Enum tycons - - | Bytes -- ^ Content of a string literal. See - -- Note [Bytes label]. - - deriving (Eq, Ord) - - -data CaseLabelInfo - = CaseReturnPt - | CaseReturnInfo - | CaseAlt ConTag - | CaseDefault - deriving (Eq, Ord) - - -data RtsLabelInfo - = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- ^ Selector thunks - | RtsSelectorEntry Bool{-updatable-} Int{-offset-} - - | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- ^ AP thunks - | RtsApEntry Bool{-updatable-} Int{-arity-} - - | RtsPrimOp PrimOp - | RtsApFast FastString -- ^ _fast versions of generic apply - | RtsSlowFastTickyCtr String - - deriving (Eq, Ord) - -- NOTE: Eq on LitString compares the pointer only, so this isn't - -- a real equality. - - --- | What type of Cmm label we're dealing with. --- Determines the suffix appended to the name when a CLabel.CmmLabel --- is pretty printed. -data CmmLabelInfo - = CmmInfo -- ^ misc rts info tabless, suffix _info - | CmmEntry -- ^ misc rts entry points, suffix _entry - | CmmRetInfo -- ^ misc rts ret info tables, suffix _info - | CmmRet -- ^ misc rts return points, suffix _ret - | CmmData -- ^ misc rts data bits, eg CHARLIKE_closure - | CmmCode -- ^ misc rts code - | CmmClosure -- ^ closures eg CHARLIKE_closure - | CmmPrimCall -- ^ a prim call to some hand written Cmm code - deriving (Eq, Ord) - -data DynamicLinkerLabelInfo - = CodeStub -- MachO: Lfoo$stub, ELF: foo@plt - | SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo - | GotSymbolPtr -- ELF: foo@got - | GotSymbolOffset -- ELF: foo@gotoff - - deriving (Eq, Ord) - - --- ----------------------------------------------------------------------------- --- Constructing CLabels --- ----------------------------------------------------------------------------- - --- Constructing IdLabels --- These are always local: -mkSlowEntryLabel :: Name -> CafInfo -> CLabel -mkSlowEntryLabel name c = IdLabel name c Slow - -mkTopSRTLabel :: Unique -> CLabel -mkTopSRTLabel u = SRTLabel u - -mkSRTLabel :: Name -> CafInfo -> CLabel -mkRednCountsLabel :: Name -> CLabel -mkSRTLabel name c = IdLabel name c SRT -mkRednCountsLabel name = - IdLabel name NoCafRefs RednCounts -- Note [ticky for LNE] - --- These have local & (possibly) external variants: -mkLocalClosureLabel :: Name -> CafInfo -> CLabel -mkLocalInfoTableLabel :: Name -> CafInfo -> CLabel -mkLocalEntryLabel :: Name -> CafInfo -> CLabel -mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel -mkLocalClosureLabel name c = IdLabel name c Closure -mkLocalInfoTableLabel name c = IdLabel name c LocalInfoTable -mkLocalEntryLabel name c = IdLabel name c LocalEntry -mkLocalClosureTableLabel name c = IdLabel name c ClosureTable - -mkClosureLabel :: Name -> CafInfo -> CLabel -mkInfoTableLabel :: Name -> CafInfo -> CLabel -mkEntryLabel :: Name -> CafInfo -> CLabel -mkClosureTableLabel :: Name -> CafInfo -> CLabel -mkLocalConInfoTableLabel :: CafInfo -> Name -> CLabel -mkLocalConEntryLabel :: CafInfo -> Name -> CLabel -mkConInfoTableLabel :: Name -> CafInfo -> CLabel -mkBytesLabel :: Name -> CLabel -mkClosureLabel name c = IdLabel name c Closure -mkInfoTableLabel name c = IdLabel name c InfoTable -mkEntryLabel name c = IdLabel name c Entry -mkClosureTableLabel name c = IdLabel name c ClosureTable -mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable -mkLocalConEntryLabel c con = IdLabel con c ConEntry -mkConInfoTableLabel name c = IdLabel name c ConInfoTable -mkBytesLabel name = IdLabel name NoCafRefs Bytes - -mkConEntryLabel :: Name -> CafInfo -> CLabel -mkConEntryLabel name c = IdLabel name c ConEntry - --- Constructing Cmm Labels -mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel, - mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, - mkMAP_FROZEN_infoLabel, mkMAP_FROZEN0_infoLabel, mkMAP_DIRTY_infoLabel, - mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel, - mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel, - mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel, - mkSMAP_DIRTY_infoLabel :: CLabel -mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction -mkSplitMarkerLabel = CmmLabel rtsUnitId (fsLit "__stg_split_marker") CmmCode -mkUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_upd_frame") CmmInfo -mkBHUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" ) CmmInfo -mkIndStaticInfoLabel = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC") CmmInfo -mkMainCapabilityLabel = CmmLabel rtsUnitId (fsLit "MainCapability") CmmData -mkMAP_FROZEN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo -mkMAP_FROZEN0_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo -mkMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo -mkEMPTY_MVAR_infoLabel = CmmLabel rtsUnitId (fsLit "stg_EMPTY_MVAR") CmmInfo -mkTopTickyCtrLabel = CmmLabel rtsUnitId (fsLit "top_ct") CmmData -mkCAFBlackHoleInfoTableLabel = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE") CmmInfo -mkCAFBlackHoleEntryLabel = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE") CmmEntry -mkArrWords_infoLabel = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS") CmmInfo -mkSMAP_FROZEN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo -mkSMAP_FROZEN0_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo -mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo - ------ -mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, - mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel - :: UnitId -> FastString -> CLabel - -mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo -mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry -mkCmmRetInfoLabel pkg str = CmmLabel pkg str CmmRetInfo -mkCmmRetLabel pkg str = CmmLabel pkg str CmmRet -mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode -mkCmmDataLabel pkg str = CmmLabel pkg str CmmData -mkCmmClosureLabel pkg str = CmmLabel pkg str CmmClosure - - --- Constructing RtsLabels -mkRtsPrimOpLabel :: PrimOp -> CLabel -mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) - -mkSelectorInfoLabel :: Bool -> Int -> CLabel -mkSelectorEntryLabel :: Bool -> Int -> CLabel -mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTable upd off) -mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) - -mkApInfoTableLabel :: Bool -> Int -> CLabel -mkApEntryLabel :: Bool -> Int -> CLabel -mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) -mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) - - --- A call to some primitive hand written Cmm code -mkPrimCallLabel :: PrimCall -> CLabel -mkPrimCallLabel (PrimCall str pkg) - = CmmLabel pkg str CmmPrimCall - - --- Constructing ForeignLabels - --- | Make a foreign label -mkForeignLabel - :: FastString -- name - -> Maybe Int -- size prefix - -> ForeignLabelSource -- what package it's in - -> FunctionOrData - -> CLabel - -mkForeignLabel str mb_sz src fod - = ForeignLabel str mb_sz src fod - - --- | Update the label size field in a ForeignLabel -addLabelSize :: CLabel -> Int -> CLabel -addLabelSize (ForeignLabel str _ src fod) sz - = ForeignLabel str (Just sz) src fod -addLabelSize label _ - = label - --- | Whether label is a top-level string literal -isBytesLabel :: CLabel -> Bool -isBytesLabel (IdLabel _ _ Bytes) = True -isBytesLabel _lbl = False - --- | Whether label is a non-haskell label (defined in C code) -isForeignLabel :: CLabel -> Bool -isForeignLabel (ForeignLabel _ _ _ _) = True -isForeignLabel _lbl = False - --- | Get the label size field from a ForeignLabel -foreignLabelStdcallInfo :: CLabel -> Maybe Int -foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info -foreignLabelStdcallInfo _lbl = Nothing - - --- Constructing Large*Labels -mkLargeSRTLabel :: Unique -> CLabel -mkBitmapLabel :: Unique -> CLabel -mkLargeSRTLabel uniq = LargeSRTLabel uniq -mkBitmapLabel uniq = LargeBitmapLabel uniq - - --- Constructin CaseLabels -mkReturnPtLabel :: Unique -> CLabel -mkReturnInfoLabel :: Unique -> CLabel -mkAltLabel :: Unique -> ConTag -> CLabel -mkDefaultLabel :: Unique -> CLabel -mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt -mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo -mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag) -mkDefaultLabel uniq = CaseLabel uniq CaseDefault - --- Constructing Cost Center Labels -mkCCLabel :: CostCentre -> CLabel -mkCCSLabel :: CostCentreStack -> CLabel -mkCCLabel cc = CC_Label cc -mkCCSLabel ccs = CCS_Label ccs - -mkRtsApFastLabel :: FastString -> CLabel -mkRtsApFastLabel str = RtsLabel (RtsApFast str) - -mkRtsSlowFastTickyCtrLabel :: String -> CLabel -mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat) - - --- Constructing Code Coverage Labels -mkHpcTicksLabel :: Module -> CLabel -mkHpcTicksLabel = HpcTicksLabel - - --- Constructing labels used for dynamic linking -mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel -mkDynamicLinkerLabel = DynamicLinkerLabel - -dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel) -dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl) -dynamicLinkerLabelInfo _ = Nothing - -mkPicBaseLabel :: CLabel -mkPicBaseLabel = PicBaseLabel - - --- Constructing miscellaneous other labels -mkDeadStripPreventer :: CLabel -> CLabel -mkDeadStripPreventer lbl = DeadStripPreventer lbl - -mkStringLitLabel :: Unique -> CLabel -mkStringLitLabel = StringLitLabel - -mkAsmTempLabel :: Uniquable a => a -> CLabel -mkAsmTempLabel a = AsmTempLabel (getUnique a) - -mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel -mkAsmTempDerivedLabel = AsmTempDerivedLabel - -mkAsmTempEndLabel :: CLabel -> CLabel -mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end") -mkPlainModuleInitLabel :: Module -> CLabel -mkPlainModuleInitLabel mod = PlainModuleInitLabel mod - --- | Construct a label for a DWARF Debug Information Entity (DIE) --- describing another symbol. -mkAsmTempDieLabel :: CLabel -> CLabel -mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die") - --- ----------------------------------------------------------------------------- --- Convert between different kinds of label - -toClosureLbl :: CLabel -> CLabel -toClosureLbl (IdLabel n c _) = IdLabel n c Closure -toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure -toClosureLbl l = pprPanic "toClosureLbl" (ppr l) - -toSlowEntryLbl :: CLabel -> CLabel -toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow -toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l) - -toEntryLbl :: CLabel -> CLabel -toEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry -toEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry -toEntryLbl (IdLabel n c _) = IdLabel n c Entry -toEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt -toEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry -toEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet -toEntryLbl l = pprPanic "toEntryLbl" (ppr l) - -toInfoLbl :: CLabel -> CLabel -toInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable -toInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable -toInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable -toInfoLbl (IdLabel n c _) = IdLabel n c InfoTable -toInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo -toInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo -toInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo -toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l) - -toRednCountsLbl :: CLabel -> Maybe CLabel -toRednCountsLbl = fmap mkRednCountsLabel . hasHaskellName - -hasHaskellName :: CLabel -> Maybe Name -hasHaskellName (IdLabel n _ _) = Just n -hasHaskellName _ = Nothing - --- ----------------------------------------------------------------------------- --- Does a CLabel's referent itself refer to a CAF? -hasCAF :: CLabel -> Bool -hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE] -hasCAF (IdLabel _ MayHaveCafRefs _) = True -hasCAF _ = False - --- Note [ticky for LNE] --- ~~~~~~~~~~~~~~~~~~~~~ - --- Until 14 Feb 2013, every ticky counter was associated with a --- closure. Thus, ticky labels used IdLabel. It is odd that --- CmmBuildInfoTables.cafTransfers would consider such a ticky label --- reason to add the name to the CAFEnv (and thus eventually the SRT), --- but it was harmless because the ticky was only used if the closure --- was also. --- --- Since we now have ticky counters for LNEs, it is no longer the case --- that every ticky counter has an actual closure. So I changed the --- generation of ticky counters' CLabels to not result in their --- associated id ending up in the SRT. --- --- NB IdLabel is still appropriate for ticky ids (as opposed to --- CmmLabel) because the LNE's counter is still related to an .hs Id, --- that Id just isn't for a proper closure. - --- ----------------------------------------------------------------------------- --- Does a CLabel need declaring before use or not? --- --- See wiki:Commentary/Compiler/Backends/PprC#Prototypes - -needsCDecl :: CLabel -> Bool - -- False <=> it's pre-declared; don't bother - -- don't bother declaring Bitmap labels, we always make sure - -- they are defined before use. -needsCDecl (SRTLabel _) = True -needsCDecl (LargeSRTLabel _) = False -needsCDecl (LargeBitmapLabel _) = False -needsCDecl (IdLabel _ _ _) = True -needsCDecl (CaseLabel _ _) = True -needsCDecl (PlainModuleInitLabel _) = True - -needsCDecl (StringLitLabel _) = False -needsCDecl (AsmTempLabel _) = False -needsCDecl (AsmTempDerivedLabel _ _) = False -needsCDecl (RtsLabel _) = False - -needsCDecl (CmmLabel pkgId _ _) - -- Prototypes for labels defined in the runtime system are imported - -- into HC files via includes/Stg.h. - | pkgId == rtsUnitId = False - - -- For other labels we inline one into the HC file directly. - | otherwise = True - -needsCDecl l@(ForeignLabel{}) = not (isMathFun l) -needsCDecl (CC_Label _) = True -needsCDecl (CCS_Label _) = True -needsCDecl (HpcTicksLabel _) = True -needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel" -needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel" -needsCDecl (DeadStripPreventer {}) = panic "needsCDecl DeadStripPreventer" - --- | If a label is a local temporary used for native code generation --- then return just its unique, otherwise nothing. -maybeAsmTemp :: CLabel -> Maybe Unique -maybeAsmTemp (AsmTempLabel uq) = Just uq -maybeAsmTemp _ = Nothing - - --- | Check whether a label corresponds to a C function that has --- a prototype in a system header somehere, or is built-in --- to the C compiler. For these labels we avoid generating our --- own C prototypes. -isMathFun :: CLabel -> Bool -isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs -isMathFun _ = False - -math_funs :: UniqSet FastString -math_funs = mkUniqSet [ - -- _ISOC99_SOURCE - (fsLit "acos"), (fsLit "acosf"), (fsLit "acosh"), - (fsLit "acoshf"), (fsLit "acoshl"), (fsLit "acosl"), - (fsLit "asin"), (fsLit "asinf"), (fsLit "asinl"), - (fsLit "asinh"), (fsLit "asinhf"), (fsLit "asinhl"), - (fsLit "atan"), (fsLit "atanf"), (fsLit "atanl"), - (fsLit "atan2"), (fsLit "atan2f"), (fsLit "atan2l"), - (fsLit "atanh"), (fsLit "atanhf"), (fsLit "atanhl"), - (fsLit "cbrt"), (fsLit "cbrtf"), (fsLit "cbrtl"), - (fsLit "ceil"), (fsLit "ceilf"), (fsLit "ceill"), - (fsLit "copysign"), (fsLit "copysignf"), (fsLit "copysignl"), - (fsLit "cos"), (fsLit "cosf"), (fsLit "cosl"), - (fsLit "cosh"), (fsLit "coshf"), (fsLit "coshl"), - (fsLit "erf"), (fsLit "erff"), (fsLit "erfl"), - (fsLit "erfc"), (fsLit "erfcf"), (fsLit "erfcl"), - (fsLit "exp"), (fsLit "expf"), (fsLit "expl"), - (fsLit "exp2"), (fsLit "exp2f"), (fsLit "exp2l"), - (fsLit "expm1"), (fsLit "expm1f"), (fsLit "expm1l"), - (fsLit "fabs"), (fsLit "fabsf"), (fsLit "fabsl"), - (fsLit "fdim"), (fsLit "fdimf"), (fsLit "fdiml"), - (fsLit "floor"), (fsLit "floorf"), (fsLit "floorl"), - (fsLit "fma"), (fsLit "fmaf"), (fsLit "fmal"), - (fsLit "fmax"), (fsLit "fmaxf"), (fsLit "fmaxl"), - (fsLit "fmin"), (fsLit "fminf"), (fsLit "fminl"), - (fsLit "fmod"), (fsLit "fmodf"), (fsLit "fmodl"), - (fsLit "frexp"), (fsLit "frexpf"), (fsLit "frexpl"), - (fsLit "hypot"), (fsLit "hypotf"), (fsLit "hypotl"), - (fsLit "ilogb"), (fsLit "ilogbf"), (fsLit "ilogbl"), - (fsLit "ldexp"), (fsLit "ldexpf"), (fsLit "ldexpl"), - (fsLit "lgamma"), (fsLit "lgammaf"), (fsLit "lgammal"), - (fsLit "llrint"), (fsLit "llrintf"), (fsLit "llrintl"), - (fsLit "llround"), (fsLit "llroundf"), (fsLit "llroundl"), - (fsLit "log"), (fsLit "logf"), (fsLit "logl"), - (fsLit "log10l"), (fsLit "log10"), (fsLit "log10f"), - (fsLit "log1pl"), (fsLit "log1p"), (fsLit "log1pf"), - (fsLit "log2"), (fsLit "log2f"), (fsLit "log2l"), - (fsLit "logb"), (fsLit "logbf"), (fsLit "logbl"), - (fsLit "lrint"), (fsLit "lrintf"), (fsLit "lrintl"), - (fsLit "lround"), (fsLit "lroundf"), (fsLit "lroundl"), - (fsLit "modf"), (fsLit "modff"), (fsLit "modfl"), - (fsLit "nan"), (fsLit "nanf"), (fsLit "nanl"), - (fsLit "nearbyint"), (fsLit "nearbyintf"), (fsLit "nearbyintl"), - (fsLit "nextafter"), (fsLit "nextafterf"), (fsLit "nextafterl"), - (fsLit "nexttoward"), (fsLit "nexttowardf"), (fsLit "nexttowardl"), - (fsLit "pow"), (fsLit "powf"), (fsLit "powl"), - (fsLit "remainder"), (fsLit "remainderf"), (fsLit "remainderl"), - (fsLit "remquo"), (fsLit "remquof"), (fsLit "remquol"), - (fsLit "rint"), (fsLit "rintf"), (fsLit "rintl"), - (fsLit "round"), (fsLit "roundf"), (fsLit "roundl"), - (fsLit "scalbln"), (fsLit "scalblnf"), (fsLit "scalblnl"), - (fsLit "scalbn"), (fsLit "scalbnf"), (fsLit "scalbnl"), - (fsLit "sin"), (fsLit "sinf"), (fsLit "sinl"), - (fsLit "sinh"), (fsLit "sinhf"), (fsLit "sinhl"), - (fsLit "sqrt"), (fsLit "sqrtf"), (fsLit "sqrtl"), - (fsLit "tan"), (fsLit "tanf"), (fsLit "tanl"), - (fsLit "tanh"), (fsLit "tanhf"), (fsLit "tanhl"), - (fsLit "tgamma"), (fsLit "tgammaf"), (fsLit "tgammal"), - (fsLit "trunc"), (fsLit "truncf"), (fsLit "truncl"), - -- ISO C 99 also defines these function-like macros in math.h: - -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater, - -- isgreaterequal, isless, islessequal, islessgreater, isunordered - - -- additional symbols from _BSD_SOURCE - (fsLit "drem"), (fsLit "dremf"), (fsLit "dreml"), - (fsLit "finite"), (fsLit "finitef"), (fsLit "finitel"), - (fsLit "gamma"), (fsLit "gammaf"), (fsLit "gammal"), - (fsLit "isinf"), (fsLit "isinff"), (fsLit "isinfl"), - (fsLit "isnan"), (fsLit "isnanf"), (fsLit "isnanl"), - (fsLit "j0"), (fsLit "j0f"), (fsLit "j0l"), - (fsLit "j1"), (fsLit "j1f"), (fsLit "j1l"), - (fsLit "jn"), (fsLit "jnf"), (fsLit "jnl"), - (fsLit "lgamma_r"), (fsLit "lgammaf_r"), (fsLit "lgammal_r"), - (fsLit "scalb"), (fsLit "scalbf"), (fsLit "scalbl"), - (fsLit "significand"), (fsLit "significandf"), (fsLit "significandl"), - (fsLit "y0"), (fsLit "y0f"), (fsLit "y0l"), - (fsLit "y1"), (fsLit "y1f"), (fsLit "y1l"), - (fsLit "yn"), (fsLit "ynf"), (fsLit "ynl"), - - -- These functions are described in IEEE Std 754-2008 - - -- Standard for Floating-Point Arithmetic and ISO/IEC TS 18661 - (fsLit "nextup"), (fsLit "nextupf"), (fsLit "nextupl"), - (fsLit "nextdown"), (fsLit "nextdownf"), (fsLit "nextdownl") - ] - --- ----------------------------------------------------------------------------- --- | Is a CLabel visible outside this object file or not? --- From the point of view of the code generator, a name is --- externally visible if it has to be declared as exported --- in the .o file's symbol table; that is, made non-static. -externallyVisibleCLabel :: CLabel -> Bool -- not C "static" -externallyVisibleCLabel (CaseLabel _ _) = False -externallyVisibleCLabel (StringLitLabel _) = False -externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False -externallyVisibleCLabel (PlainModuleInitLabel _)= True -externallyVisibleCLabel (RtsLabel _) = True -externallyVisibleCLabel (CmmLabel _ _ _) = True -externallyVisibleCLabel (ForeignLabel{}) = True -externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info -externallyVisibleCLabel (CC_Label _) = True -externallyVisibleCLabel (CCS_Label _) = True -externallyVisibleCLabel (DynamicLinkerLabel _ _) = False -externallyVisibleCLabel (HpcTicksLabel _) = True -externallyVisibleCLabel (LargeBitmapLabel _) = False -externallyVisibleCLabel (SRTLabel _) = False -externallyVisibleCLabel (LargeSRTLabel _) = False -externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel" -externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer" - -externallyVisibleIdLabel :: IdLabelInfo -> Bool -externallyVisibleIdLabel SRT = False -externallyVisibleIdLabel LocalInfoTable = False -externallyVisibleIdLabel LocalEntry = False -externallyVisibleIdLabel _ = True - --- ----------------------------------------------------------------------------- --- Finding the "type" of a CLabel - --- For generating correct types in label declarations: - -data CLabelType - = CodeLabel -- Address of some executable instructions - | DataLabel -- Address of data, not a GC ptr - | GcPtrLabel -- Address of a (presumably static) GC object - -isCFunctionLabel :: CLabel -> Bool -isCFunctionLabel lbl = case labelType lbl of - CodeLabel -> True - _other -> False - -isGcPtrLabel :: CLabel -> Bool -isGcPtrLabel lbl = case labelType lbl of - GcPtrLabel -> True - _other -> False - - --- | Work out the general type of data at the address of this label --- whether it be code, data, or static GC object. -labelType :: CLabel -> CLabelType -labelType (CmmLabel _ _ CmmData) = DataLabel -labelType (CmmLabel _ _ CmmClosure) = GcPtrLabel -labelType (CmmLabel _ _ CmmCode) = CodeLabel -labelType (CmmLabel _ _ CmmInfo) = DataLabel -labelType (CmmLabel _ _ CmmEntry) = CodeLabel -labelType (CmmLabel _ _ CmmPrimCall) = CodeLabel -labelType (CmmLabel _ _ CmmRetInfo) = DataLabel -labelType (CmmLabel _ _ CmmRet) = CodeLabel -labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel -labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel -labelType (RtsLabel (RtsApFast _)) = CodeLabel -labelType (CaseLabel _ CaseReturnInfo) = DataLabel -labelType (CaseLabel _ _) = CodeLabel -labelType (PlainModuleInitLabel _) = DataLabel -labelType (SRTLabel _) = DataLabel -labelType (LargeSRTLabel _) = DataLabel -labelType (LargeBitmapLabel _) = DataLabel -labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel -labelType (IdLabel _ _ info) = idInfoLabelType info -labelType _ = DataLabel - -idInfoLabelType :: IdLabelInfo -> CLabelType -idInfoLabelType info = - case info of - InfoTable -> DataLabel - LocalInfoTable -> DataLabel - Closure -> GcPtrLabel - ConInfoTable -> DataLabel - ClosureTable -> DataLabel - RednCounts -> DataLabel - Bytes -> DataLabel - _ -> CodeLabel - - --- ----------------------------------------------------------------------------- --- Does a CLabel need dynamic linkage? - --- When referring to data in code, we need to know whether --- that data resides in a DLL or not. [Win32 only.] --- @labelDynamic@ returns @True@ if the label is located --- in a DLL, be it a data reference or not. - -labelDynamic :: DynFlags -> Module -> CLabel -> Bool -labelDynamic dflags this_mod lbl = - case lbl of - -- is the RTS in a DLL or not? - RtsLabel _ -> (WayDyn `elem` ways dflags) && (this_pkg /= rtsUnitId) - - IdLabel n _ _ -> isDllName dflags this_mod n - - -- When compiling in the "dyn" way, each package is to be linked into - -- its own shared library. - CmmLabel pkg _ _ - | os == OSMinGW32 -> - (WayDyn `elem` ways dflags) && (this_pkg /= pkg) - | otherwise -> - True - - ForeignLabel _ _ source _ -> - if os == OSMinGW32 - then case source of - -- Foreign label is in some un-named foreign package (or DLL). - ForeignLabelInExternalPackage -> True - - -- Foreign label is linked into the same package as the - -- source file currently being compiled. - ForeignLabelInThisPackage -> False - - -- Foreign label is in some named package. - -- When compiling in the "dyn" way, each package is to be - -- linked into its own DLL. - ForeignLabelInPackage pkgId -> - (WayDyn `elem` ways dflags) && (this_pkg /= pkgId) - - else -- On Mac OS X and on ELF platforms, false positives are OK, - -- so we claim that all foreign imports come from dynamic - -- libraries - True - - PlainModuleInitLabel m -> (WayDyn `elem` ways dflags) && this_pkg /= (moduleUnitId m) - - HpcTicksLabel m -> (WayDyn `elem` ways dflags) && this_mod /= m - - -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. - _ -> False - where - os = platformOS (targetPlatform dflags) - this_pkg = moduleUnitId this_mod - - ------------------------------------------------------------------------------ --- Printing out CLabels. - -{- -Convention: - - _ - -where is _ for external names and for -internal names. is one of the following: - - info Info table - srt Static reference table - srtd Static reference table descriptor - entry Entry code (function, closure) - slow Slow entry code (if any) - ret Direct return address - vtbl Vector table - _alt Case alternative (tag n) - dflt Default case alternative - btm Large bitmap vector - closure Static closure - con_entry Dynamic Constructor entry code - con_info Dynamic Constructor info table - static_entry Static Constructor entry code - static_info Static Constructor info table - sel_info Selector info table - sel_entry Selector entry code - cc Cost centre - ccs Cost centre stack - -Many of these distinctions are only for documentation reasons. For -example, _ret is only distinguished from _entry to make it easy to -tell whether a code fragment is a return point or a closure/function -entry. - -Note [Closure and info labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a function 'foo, we have: - foo_info : Points to the info table describing foo's closure - (and entry code for foo with tables next to code) - foo_closure : Static (no-free-var) closure only: - points to the statically-allocated closure - -For a data constructor (such as Just or Nothing), we have: - Just_con_info: Info table for the data constructor itself - the first word of a heap-allocated Just - Just_info: Info table for the *worker function*, an - ordinary Haskell function of arity 1 that - allocates a (Just x) box: - Just = \x -> Just x - Just_closure: The closure for this worker - - Nothing_closure: a statically allocated closure for Nothing - Nothing_static_info: info table for Nothing_closure - -All these must be exported symbol, EXCEPT Just_info. We don't need to -export this because in other modules we either have - * A reference to 'Just'; use Just_closure - * A saturated call 'Just x'; allocate using Just_con_info -Not exporting these Just_info labels reduces the number of symbols -somewhat. - -Note [Bytes label] -~~~~~~~~~~~~~~~~~~ -For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which -points to a static data block containing the content of the literal. --} - -instance Outputable CLabel where - ppr c = sdocWithPlatform $ \platform -> pprCLabel platform c - -pprCLabel :: Platform -> CLabel -> SDoc - -pprCLabel platform (AsmTempLabel u) - | cGhcWithNativeCodeGen == "YES" - = getPprStyle $ \ sty -> - if asmStyle sty then - ptext (asmTempLabelPrefix platform) <> pprUniqueAlways u - else - char '_' <> pprUniqueAlways u - -pprCLabel platform (AsmTempDerivedLabel l suf) - | cGhcWithNativeCodeGen == "YES" - = ptext (asmTempLabelPrefix platform) - <> case l of AsmTempLabel u -> pprUniqueAlways u - _other -> pprCLabel platform l - <> ftext suf - -pprCLabel platform (DynamicLinkerLabel info lbl) - | cGhcWithNativeCodeGen == "YES" - = pprDynamicLinkerAsmLabel platform info lbl - -pprCLabel _ PicBaseLabel - | cGhcWithNativeCodeGen == "YES" - = text "1b" - -pprCLabel platform (DeadStripPreventer lbl) - | cGhcWithNativeCodeGen == "YES" - = pprCLabel platform lbl <> text "_dsp" - -pprCLabel _ (StringLitLabel u) - | cGhcWithNativeCodeGen == "YES" - = pprUniqueAlways u <> ptext (sLit "_str") - -pprCLabel platform lbl - = getPprStyle $ \ sty -> - if cGhcWithNativeCodeGen == "YES" && asmStyle sty - then maybe_underscore (pprAsmCLbl platform lbl) - else pprCLbl lbl - -maybe_underscore :: SDoc -> SDoc -maybe_underscore doc - | underscorePrefix = pp_cSEP <> doc - | otherwise = doc - -pprAsmCLbl :: Platform -> CLabel -> SDoc -pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _) - | platformOS platform == OSMinGW32 - -- In asm mode, we need to put the suffix on a stdcall ForeignLabel. - -- (The C compiler does this itself). - = ftext fs <> char '@' <> int sz -pprAsmCLbl _ lbl - = pprCLbl lbl - -pprCLbl :: CLabel -> SDoc -pprCLbl (StringLitLabel u) - = pprUniqueAlways u <> text "_str" - -pprCLbl (CaseLabel u CaseReturnPt) - = hcat [pprUniqueAlways u, text "_ret"] -pprCLbl (CaseLabel u CaseReturnInfo) - = hcat [pprUniqueAlways u, text "_info"] -pprCLbl (CaseLabel u (CaseAlt tag)) - = hcat [pprUniqueAlways u, pp_cSEP, int tag, text "_alt"] -pprCLbl (CaseLabel u CaseDefault) - = hcat [pprUniqueAlways u, text "_dflt"] - -pprCLbl (SRTLabel u) - = pprUniqueAlways u <> pp_cSEP <> text "srt" - -pprCLbl (LargeSRTLabel u) = pprUniqueAlways u <> pp_cSEP <> text "srtd" -pprCLbl (LargeBitmapLabel u) = text "b" <> pprUniqueAlways u <> pp_cSEP <> text "btm" --- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7') --- until that gets resolved we'll just force them to start --- with a letter so the label will be legal assmbly code. - - -pprCLbl (CmmLabel _ str CmmCode) = ftext str -pprCLbl (CmmLabel _ str CmmData) = ftext str -pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str - -pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> text "_fast" - -pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) - = sdocWithDynFlags $ \dflags -> - ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags) - hcat [text "stg_sel_", text (show offset), - ptext (if upd_reqd - then (sLit "_upd_info") - else (sLit "_noupd_info")) - ] - -pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) - = sdocWithDynFlags $ \dflags -> - ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags) - hcat [text "stg_sel_", text (show offset), - ptext (if upd_reqd - then (sLit "_upd_entry") - else (sLit "_noupd_entry")) - ] - -pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity)) - = sdocWithDynFlags $ \dflags -> - ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags) - hcat [text "stg_ap_", text (show arity), - ptext (if upd_reqd - then (sLit "_upd_info") - else (sLit "_noupd_info")) - ] - -pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) - = sdocWithDynFlags $ \dflags -> - ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags) - hcat [text "stg_ap_", text (show arity), - ptext (if upd_reqd - then (sLit "_upd_entry") - else (sLit "_noupd_entry")) - ] - -pprCLbl (CmmLabel _ fs CmmInfo) - = ftext fs <> text "_info" - -pprCLbl (CmmLabel _ fs CmmEntry) - = ftext fs <> text "_entry" - -pprCLbl (CmmLabel _ fs CmmRetInfo) - = ftext fs <> text "_info" - -pprCLbl (CmmLabel _ fs CmmRet) - = ftext fs <> text "_ret" - -pprCLbl (CmmLabel _ fs CmmClosure) - = ftext fs <> text "_closure" - -pprCLbl (RtsLabel (RtsPrimOp primop)) - = text "stg_" <> ppr primop - -pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat)) - = text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr") - -pprCLbl (ForeignLabel str _ _ _) - = ftext str - -pprCLbl (IdLabel name _cafs flavor) = ppr name <> ppIdFlavor flavor - -pprCLbl (CC_Label cc) = ppr cc -pprCLbl (CCS_Label ccs) = ppr ccs - -pprCLbl (PlainModuleInitLabel mod) - = text "__stginit_" <> ppr mod - -pprCLbl (HpcTicksLabel mod) - = text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc") - -pprCLbl (AsmTempLabel {}) = panic "pprCLbl AsmTempLabel" -pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel" -pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel" -pprCLbl (PicBaseLabel {}) = panic "pprCLbl PicBaseLabel" -pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer" - -ppIdFlavor :: IdLabelInfo -> SDoc -ppIdFlavor x = pp_cSEP <> - (case x of - Closure -> text "closure" - SRT -> text "srt" - InfoTable -> text "info" - LocalInfoTable -> text "info" - Entry -> text "entry" - LocalEntry -> text "entry" - Slow -> text "slow" - RednCounts -> text "ct" - ConEntry -> text "con_entry" - ConInfoTable -> text "con_info" - ClosureTable -> text "closure_tbl" - Bytes -> text "bytes" - ) - - -pp_cSEP :: SDoc -pp_cSEP = char '_' - - -instance Outputable ForeignLabelSource where - ppr fs - = case fs of - ForeignLabelInPackage pkgId -> parens $ text "package: " <> ppr pkgId - ForeignLabelInThisPackage -> parens $ text "this package" - ForeignLabelInExternalPackage -> parens $ text "external package" - --- ----------------------------------------------------------------------------- --- Machine-dependent knowledge about labels. - -underscorePrefix :: Bool -- leading underscore on assembler labels? -underscorePrefix = (cLeadingUnderscore == "YES") - -asmTempLabelPrefix :: Platform -> LitString -- for formatting labels -asmTempLabelPrefix platform = case platformOS platform of - OSDarwin -> sLit "L" - OSAIX -> sLit "__L" -- follow IBM XL C's convention - _ -> sLit ".L" - -pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc -pprDynamicLinkerAsmLabel platform dllInfo lbl - = if platformOS platform == OSDarwin - then if platformArch platform == ArchX86_64 - then case dllInfo of - CodeStub -> char 'L' <> ppr lbl <> text "$stub" - SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr" - GotSymbolPtr -> ppr lbl <> text "@GOTPCREL" - GotSymbolOffset -> ppr lbl - else case dllInfo of - CodeStub -> char 'L' <> ppr lbl <> text "$stub" - SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr" - _ -> panic "pprDynamicLinkerAsmLabel" - - else if platformOS platform == OSAIX - then case dllInfo of - SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention - _ -> panic "pprDynamicLinkerAsmLabel" - - else if osElfTarget (platformOS platform) - then if platformArch platform == ArchPPC - then case dllInfo of - CodeStub -> -- See Note [.LCTOC1 in PPC PIC code] - ppr lbl <> text "+32768@plt" - SymbolPtr -> text ".LC_" <> ppr lbl - _ -> panic "pprDynamicLinkerAsmLabel" - else if platformArch platform == ArchX86_64 - then case dllInfo of - CodeStub -> ppr lbl <> text "@plt" - GotSymbolPtr -> ppr lbl <> text "@gotpcrel" - GotSymbolOffset -> ppr lbl - SymbolPtr -> text ".LC_" <> ppr lbl - else if platformArch platform == ArchPPC_64 ELF_V1 - || platformArch platform == ArchPPC_64 ELF_V2 - then case dllInfo of - GotSymbolPtr -> text ".LC_" <> ppr lbl - <> text "@toc" - GotSymbolOffset -> ppr lbl - SymbolPtr -> text ".LC_" <> ppr lbl - _ -> panic "pprDynamicLinkerAsmLabel" - else case dllInfo of - CodeStub -> ppr lbl <> text "@plt" - SymbolPtr -> text ".LC_" <> ppr lbl - GotSymbolPtr -> ppr lbl <> text "@got" - GotSymbolOffset -> ppr lbl <> text "@gotoff" - else if platformOS platform == OSMinGW32 - then case dllInfo of - SymbolPtr -> text "__imp_" <> ppr lbl - _ -> panic "pprDynamicLinkerAsmLabel" - else panic "pprDynamicLinkerAsmLabel" - diff --git a/cmm/Cmm.hs b/cmm/Cmm.hs deleted file mode 100644 --- a/cmm/Cmm.hs +++ /dev/null @@ -1,218 +0,0 @@ --- Cmm representations using Hoopl's Graph CmmNode e x. -{-# LANGUAGE CPP, GADTs #-} - -module Cmm ( - -- * Cmm top-level datatypes - CmmProgram, CmmGroup, GenCmmGroup, - CmmDecl, GenCmmDecl(..), - CmmGraph, GenCmmGraph(..), - CmmBlock, - RawCmmDecl, RawCmmGroup, - Section(..), SectionType(..), CmmStatics(..), CmmStatic(..), - - -- ** Blocks containing lists - GenBasicBlock(..), blockId, - ListGraph(..), pprBBlock, - - -- * Cmm graphs - CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite, - - -- * Info Tables - CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable, - ClosureTypeInfo(..), - C_SRT(..), needsSRT, - ProfilingInfo(..), ConstrDescription, - - -- * Statements, expressions and types - module CmmNode, - module CmmExpr, - ) where - -import CLabel -import BlockId -import CmmNode -import SMRep -import CmmExpr -import UniqSupply -import Compiler.Hoopl -import Outputable - -import Data.Word ( Word8 ) - -#include "HsVersions.h" - ------------------------------------------------------------------------------ --- Cmm, GenCmm ------------------------------------------------------------------------------ - --- A CmmProgram is a list of CmmGroups --- A CmmGroup is a list of top-level declarations - --- When object-splitting is on, each group is compiled into a separate --- .o file. So typically we put closely related stuff in a CmmGroup. --- Section-splitting follows suit and makes one .text subsection for each --- CmmGroup. - -type CmmProgram = [CmmGroup] - -type GenCmmGroup d h g = [GenCmmDecl d h g] -type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph -type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph - ------------------------------------------------------------------------------ --- CmmDecl, GenCmmDecl ------------------------------------------------------------------------------ - --- GenCmmDecl is abstracted over --- d, the type of static data elements in CmmData --- h, the static info preceding the code of a CmmProc --- g, the control-flow graph of a CmmProc --- --- We expect there to be two main instances of this type: --- (a) C--, i.e. populated with various C-- constructs --- (b) Native code, populated with data/instructions - --- | A top-level chunk, abstracted over the type of the contents of --- the basic blocks (Cmm or instructions are the likely instantiations). -data GenCmmDecl d h g - = CmmProc -- A procedure - h -- Extra header such as the info table - CLabel -- Entry label - [GlobalReg] -- Registers live on entry. Note that the set of live - -- registers will be correct in generated C-- code, but - -- not in hand-written C-- code. However, - -- splitAtProcPoints calculates correct liveness - -- information for CmmProcs. - g -- Control-flow graph for the procedure's code - - | CmmData -- Static data - Section - d - -type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph - -type RawCmmDecl - = GenCmmDecl - CmmStatics - (LabelMap CmmStatics) - CmmGraph - ------------------------------------------------------------------------------ --- Graphs ------------------------------------------------------------------------------ - -type CmmGraph = GenCmmGraph CmmNode -data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } -type CmmBlock = Block CmmNode C C - -type CmmReplGraph e x = GenCmmReplGraph CmmNode e x -type GenCmmReplGraph n e x = UniqSM (Maybe (Graph n e x)) -type CmmFwdRewrite f = FwdRewrite UniqSM CmmNode f -type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f - ------------------------------------------------------------------------------ --- Info Tables ------------------------------------------------------------------------------ - -data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable - , stack_info :: CmmStackInfo } - -topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable -topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) -topInfoTable _ = Nothing - -data CmmStackInfo - = StackInfo { - arg_space :: ByteOff, - -- number of bytes of arguments on the stack on entry to the - -- the proc. This is filled in by StgCmm.codeGen, and used - -- by the stack allocator later. - updfr_space :: Maybe ByteOff, - -- XXX: this never contains anything useful, but it should. - -- See comment in CmmLayoutStack. - do_layout :: Bool - -- Do automatic stack layout for this proc. This is - -- True for all code generated by the code generator, - -- but is occasionally False for hand-written Cmm where - -- we want to do the stack manipulation manually. - } - --- | Info table as a haskell data type -data CmmInfoTable - = CmmInfoTable { - cit_lbl :: CLabel, -- Info table label - cit_rep :: SMRep, - cit_prof :: ProfilingInfo, - cit_srt :: C_SRT - } - -data ProfilingInfo - = NoProfilingInfo - | ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc - --- C_SRT is what StgSyn.SRT gets translated to... --- we add a label for the table, and expect only the 'offset/length' form - -data C_SRT = NoC_SRT - | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-} - deriving (Eq) - -needsSRT :: C_SRT -> Bool -needsSRT NoC_SRT = False -needsSRT (C_SRT _ _ _) = True - ------------------------------------------------------------------------------ --- Static Data ------------------------------------------------------------------------------ - -data SectionType - = Text - | Data - | ReadOnlyData - | RelocatableReadOnlyData - | UninitialisedData - | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned - | CString - | OtherSection String - deriving (Show) - -data Section = Section SectionType CLabel - -data CmmStatic - = CmmStaticLit CmmLit - -- a literal value, size given by cmmLitRep of the literal. - | CmmUninitialised Int - -- uninitialised data, N bytes long - | CmmString [Word8] - -- string of 8-bit values only, not zero terminated. - -data CmmStatics - = Statics - CLabel -- Label of statics - [CmmStatic] -- The static data itself - --- ----------------------------------------------------------------------------- --- Basic blocks consisting of lists - --- These are used by the LLVM and NCG backends, when populating Cmm --- with lists of instructions. - -data GenBasicBlock i = BasicBlock BlockId [i] - --- | The branch block id is that of the first block in --- the branch, which is that branch's entry point -blockId :: GenBasicBlock i -> BlockId -blockId (BasicBlock blk_id _ ) = blk_id - -newtype ListGraph i = ListGraph [GenBasicBlock i] - -instance Outputable instr => Outputable (ListGraph instr) where - ppr (ListGraph blocks) = vcat (map ppr blocks) - -instance Outputable instr => Outputable (GenBasicBlock instr) where - ppr = pprBBlock - -pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc -pprBBlock (BasicBlock ident stmts) = - hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) - diff --git a/cmm/CmmBuildInfoTables.hs b/cmm/CmmBuildInfoTables.hs deleted file mode 100644 --- a/cmm/CmmBuildInfoTables.hs +++ /dev/null @@ -1,379 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, GADTs #-} - -module CmmBuildInfoTables - ( CAFSet, CAFEnv, cafAnal - , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData ) -where - -#include "HsVersions.h" - -import Hoopl -import Digraph -import Bitmap -import CLabel -import PprCmmDecl () -import Cmm -import CmmUtils -import CmmInfo -import Data.List -import DynFlags -import Maybes -import Outputable -import SMRep -import UniqSupply -import Util - -import PprCmm() -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Control.Monad - -import qualified Prelude as P -import Prelude hiding (succ) - -foldSet :: (a -> b -> b) -> b -> Set a -> b -foldSet = Set.foldr - ------------------------------------------------------------------------ --- SRTs - -{- EXAMPLE - -f = \x. ... g ... - where - g = \y. ... h ... c1 ... - h = \z. ... c2 ... - -c1 & c2 are CAFs - -g and h are local functions, but they have no static closures. When -we generate code for f, we start with a CmmGroup of four CmmDecls: - - [ f_closure, f_entry, g_entry, h_entry ] - -we process each CmmDecl separately in cpsTop, giving us a list of -CmmDecls. e.g. for f_entry, we might end up with - - [ f_entry, f1_ret, f2_proc ] - -where f1_ret is a return point, and f2_proc is a proc-point. We have -a CAFSet for each of these CmmDecls, let's suppose they are - - [ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ] - [ g_entry{h_closure, c1_closure} ] - [ h_entry{c2_closure} ] - -Now, note that we cannot use g_closure and h_closure in an SRT, -because there are no static closures corresponding to these functions. -So we have to flatten out the structure, replacing g_closure and -h_closure with their contents: - - [ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ] - [ g_entry{c2_closure, c1_closure} ] - [ h_entry{c2_closure} ] - -This is what flattenCAFSets is doing. - --} - ------------------------------------------------------------------------ --- Finding the CAFs used by a procedure - -type CAFSet = Set CLabel -type CAFEnv = LabelMap CAFSet - -cafLattice :: DataflowLattice CAFSet -cafLattice = DataflowLattice Set.empty add - where - add (OldFact old) (NewFact new) = - let !new' = old `Set.union` new - in changedIf (Set.size new' > Set.size old) new' - -cafTransfers :: TransferFun CAFSet -cafTransfers (BlockCC eNode middle xNode) fBase = - let joined = cafsInNode xNode $! joinOutFacts cafLattice xNode fBase - !result = foldNodesBwdOO cafsInNode middle joined - in mapSingleton (entryLabel eNode) result - -cafsInNode :: CmmNode e x -> CAFSet -> CAFSet -cafsInNode node set = foldExpDeep addCaf node set - where - addCaf expr !set = - case expr of - CmmLit (CmmLabel c) -> add c set - CmmLit (CmmLabelOff c _) -> add c set - CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $! add c2 set - _ -> set - add l s | hasCAF l = Set.insert (toClosureLbl l) s - | otherwise = s - --- | An analysis to find live CAFs. -cafAnal :: CmmGraph -> CAFEnv -cafAnal cmmGraph = analyzeCmmBwd cafLattice cafTransfers cmmGraph mapEmpty - ------------------------------------------------------------------------ --- Building the SRTs - --- Description of the SRT for a given module. --- Note that this SRT may grow as we greedily add new CAFs to it. -data TopSRT = TopSRT { lbl :: CLabel - , next_elt :: Int -- the next entry in the table - , rev_elts :: [CLabel] - , elt_map :: Map CLabel Int } - -- map: CLabel -> its last entry in the table -instance Outputable TopSRT where - ppr (TopSRT lbl next elts eltmap) = - text "TopSRT:" <+> ppr lbl - <+> ppr next - <+> ppr elts - <+> ppr eltmap - -emptySRT :: MonadUnique m => m TopSRT -emptySRT = - do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u - return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty } - -isEmptySRT :: TopSRT -> Bool -isEmptySRT srt = null (rev_elts srt) - -cafMember :: TopSRT -> CLabel -> Bool -cafMember srt lbl = Map.member lbl (elt_map srt) - -cafOffset :: TopSRT -> CLabel -> Maybe Int -cafOffset srt lbl = Map.lookup lbl (elt_map srt) - -addCAF :: CLabel -> TopSRT -> TopSRT -addCAF caf srt = - srt { next_elt = last + 1 - , rev_elts = caf : rev_elts srt - , elt_map = Map.insert caf last (elt_map srt) } - where last = next_elt srt - -srtToData :: TopSRT -> CmmGroup -srtToData srt = [CmmData sec (Statics (lbl srt) tbl)] - where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt)) - sec = Section RelocatableReadOnlyData (lbl srt) - --- Once we have found the CAFs, we need to do two things: --- 1. Build a table of all the CAFs used in the procedure. --- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint. --- --- When building the local view of the SRT, we first make sure that all the CAFs are --- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap, --- we make sure they're all close enough to the bottom of the table that the --- bitmap will be able to cover all of them. -buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT) -buildSRT dflags topSRT cafs = - do let - -- For each label referring to a function f without a static closure, - -- replace it with the CAFs that are reachable from f. - sub_srt topSRT localCafs = - let cafs = Set.elems localCafs - mkSRT topSRT = - do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs - return (topSRT, localSRTs) - in if length cafs > maxBmpSize dflags then - mkSRT (foldl add_if_missing topSRT cafs) - else -- make sure all the cafs are near the bottom of the srt - mkSRT (add_if_too_far topSRT cafs) - add_if_missing srt caf = - if cafMember srt caf then srt else addCAF caf srt - -- If a CAF is more than maxBmpSize entries from the young end of the - -- SRT, then we add it to the SRT again. - -- (Note: Not in the SRT => infinitely far.) - add_if_too_far srt@(TopSRT {elt_map = m}) cafs = - add srt (sortBy farthestFst cafs) - where - farthestFst x y = case (Map.lookup x m, Map.lookup y m) of - (Nothing, Nothing) -> EQ - (Nothing, Just _) -> LT - (Just _, Nothing) -> GT - (Just d, Just d') -> compare d' d - add srt [] = srt - add srt@(TopSRT {next_elt = next}) (caf : rst) = - case cafOffset srt caf of - Just ix -> if next - ix > maxBmpSize dflags then - add (addCAF caf srt) rst - else srt - Nothing -> add (addCAF caf srt) rst - (topSRT, subSRTs) <- sub_srt topSRT cafs - let (sub_tbls, blockSRTs) = subSRTs - return (topSRT, sub_tbls, blockSRTs) - --- Construct an SRT bitmap. --- Adapted from simpleStg/SRT.hs, which expects Id's. -procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] -> - UniqSM (Maybe CmmDecl, C_SRT) -procpointSRT _ _ _ [] = - return (Nothing, NoC_SRT) -procpointSRT dflags top_srt top_table entries = - do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap - return (top, srt) - where - ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries - sorted_ints = sort ints - offset = head sorted_ints - bitmap_entries = map (subtract offset) sorted_ints - len = P.last bitmap_entries + 1 - bitmap = intsToBitmap dflags len bitmap_entries - -maxBmpSize :: DynFlags -> Int -maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2 - --- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT. -to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT) -to_SRT dflags top_srt off len bmp - | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))] - = do id <- getUniqueM - let srt_desc_lbl = mkLargeSRTLabel id - section = Section RelocatableReadOnlyData srt_desc_lbl - tbl = CmmData section $ - Statics srt_desc_lbl $ map CmmStaticLit - ( cmmLabelOffW dflags top_srt off - : mkWordCLit dflags (fromIntegral len) - : map (mkStgWordCLit dflags) bmp) - return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags)) - | otherwise - = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp)))) - -- The fromIntegral converts to StgHalfWord - --- Gather CAF info for a procedure, but only if the procedure --- doesn't have a static closure. --- (If it has a static closure, it will already have an SRT to --- keep its CAFs live.) --- Any procedure referring to a non-static CAF c must keep live --- any CAF that is reachable from c. -localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel) -localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing) -localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) = - case topInfoTable proc of - Just (CmmInfoTable { cit_rep = rep }) - | not (isStaticRep rep) && not (isStackRep rep) - -> (cafs, Just (toClosureLbl top_l)) - _other -> (cafs, Nothing) - where - cafs = expectJust "maybeBindCAFs" $ mapLookup entry cafEnv - --- Once we have the local CAF sets for some (possibly) mutually --- recursive functions, we can create an environment mapping --- each function to its set of CAFs. Note that a CAF may --- be a reference to a function. If that function f does not have --- a static closure, then we need to refer specifically --- to the set of CAFs used by f. Of course, the set of CAFs --- used by f must be included in the local CAF sets that are input to --- this function. To minimize lookup time later, we return --- the environment with every reference to f replaced by its set of CAFs. --- To do this replacement efficiently, we gather strongly connected --- components, then we sort the components in topological order. -mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet -mkTopCAFInfo localCAFs = foldl addToTop Map.empty g - where - addToTop env (AcyclicSCC (l, cafset)) = - Map.insert l (flatten env cafset) env - addToTop env (CyclicSCC nodes) = - let (lbls, cafsets) = unzip nodes - cafset = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls - in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls - - g = stronglyConnCompFromEdgedVerticesOrd - [ ((l,cafs), l, Set.elems cafs) | (cafs, Just l) <- localCAFs ] - -flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet -flatten env cafset = foldSet (lookup env) Set.empty cafset - where - lookup env caf cafset' = - case Map.lookup caf env of - Just cafs -> foldSet Set.insert cafset' cafs - Nothing -> Set.insert caf cafset' - -bundle :: Map CLabel CAFSet - -> (CAFEnv, CmmDecl) - -> (CAFSet, Maybe CLabel) - -> (LabelMap CAFSet, CmmDecl) -bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl) - = ( mapMapWithKey get_cafs (info_tbls infos), decl ) - where - entry = g_entry g - - entry_cafs - | Just l <- mb_lbl = expectJust "bundle" $ Map.lookup l flatmap - | otherwise = flatten flatmap closure_cafs - - get_cafs l _ - | l == entry = entry_cafs - | Just info <- mapLookup l env = flatten flatmap info - | otherwise = Set.empty - -- the label might not be in the env if the code corresponding to - -- this info table was optimised away (perhaps because it was - -- unreachable). In this case it doesn't matter what SRT we - -- infer, since the info table will not appear in the generated - -- code. See #9329. - -bundle _flatmap (_, decl) _ - = ( mapEmpty, decl ) - - -flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(LabelMap CAFSet, CmmDecl)] -flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs - where - zipped = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ] - localCAFs = unzipWith localCAFInfo zipped - flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs - -doSRTs :: DynFlags - -> TopSRT - -> [(CAFEnv, [CmmDecl])] - -> IO (TopSRT, [CmmDecl]) - -doSRTs dflags topSRT tops - = do - let caf_decls = flattenCAFSets tops - us <- mkSplitUniqSupply 'u' - let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls - return (topSRT', reverse gs' {- Note [reverse gs] -}) - where - setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do - (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map - let decl' = updInfoSRTs srt_env decl - return (topSRT, decl': srt_tables ++ rst) - setSRT (topSRT, rst) (_, decl) = - return (topSRT, decl : rst) - -buildSRTs :: DynFlags -> TopSRT -> LabelMap CAFSet - -> UniqSM (TopSRT, [CmmDecl], LabelMap C_SRT) -buildSRTs dflags top_srt caf_map - = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map) - where - doOne (top_srt, decls, srt_env) (l, cafs) - = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs - return ( top_srt, maybeToList mb_decl ++ decls - , mapInsert l srt srt_env ) - -{- -- In each CmmDecl there is a mapping from BlockId -> CmmInfoTable -- The one corresponding to g_entry is the closure info table, the - rest are continuations. -- Each one needs an SRT. -- We get the CAFSet for each one from the CAFEnv -- flatten gives us - [(LabelMap CAFSet, CmmDecl)] -- --} - - -{- Note [reverse gs] - - It is important to keep the code blocks in the same order, - otherwise binary sizes get slightly bigger. I'm not completely - sure why this is, perhaps the assembler generates bigger jump - instructions for forward refs. --SDM --} - -updInfoSRTs :: LabelMap C_SRT -> CmmDecl -> CmmDecl -updInfoSRTs srt_env (CmmProc top_info top_l live g) = - CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g - where updInfoTbl l info_tbl - = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env } -updInfoSRTs _ t = t diff --git a/cmm/CmmCallConv.hs b/cmm/CmmCallConv.hs deleted file mode 100644 --- a/cmm/CmmCallConv.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE CPP #-} - -module CmmCallConv ( - ParamLocation(..), - assignArgumentsPos, - assignStack, - realArgRegsCover -) where - -#include "HsVersions.h" - -import CmmExpr -import SMRep -import Cmm (Convention(..)) -import PprCmm () - -import DynFlags -import Platform -import Outputable - --- Calculate the 'GlobalReg' or stack locations for function call --- parameters as used by the Cmm calling convention. - -data ParamLocation - = RegisterParam GlobalReg - | StackParam ByteOff - -instance Outputable ParamLocation where - ppr (RegisterParam g) = ppr g - ppr (StackParam p) = ppr p - --- | --- Given a list of arguments, and a function that tells their types, --- return a list showing where each argument is passed --- -assignArgumentsPos :: DynFlags - -> ByteOff -- stack offset to start with - -> Convention - -> (a -> CmmType) -- how to get a type from an arg - -> [a] -- args - -> ( - ByteOff -- bytes of stack args - , [(a, ParamLocation)] -- args and locations - ) - -assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) - where - regs = case (reps, conv) of - (_, NativeNodeCall) -> getRegsWithNode dflags - (_, NativeDirectCall) -> getRegsWithoutNode dflags - ([_], NativeReturn) -> allRegs dflags - (_, NativeReturn) -> getRegsWithNode dflags - -- GC calling convention *must* put values in registers - (_, GC) -> allRegs dflags - (_, Slow) -> nodeOnly - -- The calling conventions first assign arguments to registers, - -- then switch to the stack when we first run out of registers - -- (even if there are still available registers for args of a - -- different type). When returning an unboxed tuple, we also - -- separate the stack arguments by pointerhood. - (reg_assts, stk_args) = assign_regs [] reps regs - (stk_off, stk_assts) = assignStack dflags off arg_ty stk_args - assignments = reg_assts ++ stk_assts - - assign_regs assts [] _ = (assts, []) - assign_regs assts (r:rs) regs | isVecType ty = vec - | isFloatType ty = float - | otherwise = int - where vec = case (w, regs) of - (W128, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss)) - (W256, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss)) - (W512, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss)) - _ -> (assts, (r:rs)) - float = case (w, regs) of - (W32, (vs, fs, ds, ls, s:ss)) - | passFloatInXmm -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss)) - (W32, (vs, f:fs, ds, ls, ss)) - | not passFloatInXmm -> k (RegisterParam f, (vs, fs, ds, ls, ss)) - (W64, (vs, fs, ds, ls, s:ss)) - | passFloatInXmm -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss)) - (W64, (vs, fs, d:ds, ls, ss)) - | not passFloatInXmm -> k (RegisterParam d, (vs, fs, ds, ls, ss)) - (W80, _) -> panic "F80 unsupported register type" - _ -> (assts, (r:rs)) - int = case (w, regs) of - (W128, _) -> panic "W128 unsupported register type" - (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags) - -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss)) - (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags) - -> k (RegisterParam l, (vs, fs, ds, ls, ss)) - _ -> (assts, (r:rs)) - k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' - ty = arg_ty r - w = typeWidth ty - gcp | isGcPtrType ty = VGcPtr - | otherwise = VNonGcPtr - passFloatInXmm = passFloatArgsInXmm dflags - -passFloatArgsInXmm :: DynFlags -> Bool -passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of - ArchX86_64 -> True - _ -> False - --- On X86_64, we always pass 128-bit-wide vectors in registers. On 32-bit X86 --- and for all larger vector sizes on X86_64, LLVM's GHC calling convention --- does not currently pass vectors in registers. The patch to update the GHC --- calling convention to support passing SIMD vectors in registers is small and --- well-contained, so it may make it into LLVM 3.4. The hidden --- -fllvm-pass-vectors-in-regs flag will generate LLVM code that attempts to --- pass vectors in registers, but it must only be used with a version of LLVM --- that has an updated GHC calling convention. -passVectorInReg :: Width -> DynFlags -> Bool -passVectorInReg W128 dflags = case platformArch (targetPlatform dflags) of - ArchX86_64 -> True - _ -> gopt Opt_LlvmPassVectorsInRegisters dflags -passVectorInReg _ dflags = gopt Opt_LlvmPassVectorsInRegisters dflags - -assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a] - -> ( - ByteOff -- bytes of stack args - , [(a, ParamLocation)] -- args and locations - ) -assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args) - where - assign_stk offset assts [] = (offset, assts) - assign_stk offset assts (r:rs) - = assign_stk off' ((r, StackParam off') : assts) rs - where w = typeWidth (arg_ty r) - size = (((widthInBytes w - 1) `div` word_size) + 1) * word_size - off' = offset + size - word_size = wORD_SIZE dflags - ------------------------------------------------------------------------------ --- Local information about the registers available - -type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. - , [GlobalReg] -- floats - , [GlobalReg] -- doubles - , [GlobalReg] -- longs (int64 and word64) - , [Int] -- XMM (floats and doubles) - ) - --- Vanilla registers can contain pointers, Ints, Chars. --- Floats and doubles have separate register supplies. --- --- We take these register supplies from the *real* registers, i.e. those --- that are guaranteed to map to machine registers. - -getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs -getRegsWithoutNode dflags = - ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags) - , realFloatRegs dflags - , realDoubleRegs dflags - , realLongRegs dflags - , realXmmRegNos dflags) - --- getRegsWithNode uses R1/node even if it isn't a register -getRegsWithNode dflags = - ( if null (realVanillaRegs dflags) - then [VanillaReg 1] - else realVanillaRegs dflags - , realFloatRegs dflags - , realDoubleRegs dflags - , realLongRegs dflags - , realXmmRegNos dflags) - -allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg] -allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] -allXmmRegs :: DynFlags -> [Int] - -allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags) -allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags) -allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags) -allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags) -allXmmRegs dflags = regList (mAX_XMM_REG dflags) - -realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg] -realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] -realXmmRegNos :: DynFlags -> [Int] - -realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags) -realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags) -realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags) -realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags) - -realXmmRegNos dflags - | isSse2Enabled dflags = regList (mAX_Real_XMM_REG dflags) - | otherwise = [] - -regList :: Int -> [Int] -regList n = [1 .. n] - -allRegs :: DynFlags -> AvailRegs -allRegs dflags = (allVanillaRegs dflags, - allFloatRegs dflags, - allDoubleRegs dflags, - allLongRegs dflags, - allXmmRegs dflags) - -nodeOnly :: AvailRegs -nodeOnly = ([VanillaReg 1], [], [], [], []) - --- This returns the set of global registers that *cover* the machine registers --- used for argument passing. On platforms where registers can overlap---right --- now just x86-64, where Float and Double registers overlap---passing this set --- of registers is guaranteed to preserve the contents of all live registers. We --- only use this functionality in hand-written C-- code in the RTS. -realArgRegsCover :: DynFlags -> [GlobalReg] -realArgRegsCover dflags - | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++ - realLongRegs dflags ++ - map XmmReg (realXmmRegNos dflags) - | otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++ - realFloatRegs dflags ++ - realDoubleRegs dflags ++ - realLongRegs dflags ++ - map XmmReg (realXmmRegNos dflags) diff --git a/cmm/CmmCommonBlockElim.hs b/cmm/CmmCommonBlockElim.hs deleted file mode 100644 --- a/cmm/CmmCommonBlockElim.hs +++ /dev/null @@ -1,302 +0,0 @@ -{-# LANGUAGE GADTs, BangPatterns #-} -module CmmCommonBlockElim - ( elimCommonBlocks - ) -where - - -import BlockId -import Cmm -import CmmUtils -import CmmSwitch (eqSwitchTargetWith) -import CmmContFlowOpt --- import PprCmm () -import Prelude hiding (iterate, succ, unzip, zip) - -import Hoopl hiding (ChangeFlag) -import Data.Bits -import Data.Maybe (mapMaybe) -import qualified Data.List as List -import Data.Word -import qualified Data.Map as M -import Outputable -import UniqFM -import UniqDFM -import qualified TrieMap as TM -import Unique -import Control.Arrow (first, second) - --- ----------------------------------------------------------------------------- --- Eliminate common blocks - --- If two blocks are identical except for the label on the first node, --- then we can eliminate one of the blocks. To ensure that the semantics --- of the program are preserved, we have to rewrite each predecessor of the --- eliminated block to proceed with the block we keep. - --- The algorithm iterates over the blocks in the graph, --- checking whether it has seen another block that is equal modulo labels. --- If so, then it adds an entry in a map indicating that the new block --- is made redundant by the old block. --- Otherwise, it is added to the useful blocks. - --- To avoid comparing every block with every other block repeatedly, we group --- them by --- * a hash of the block, ignoring labels (explained below) --- * the list of outgoing labels --- The hash is invariant under relabeling, so we only ever compare within --- the same group of blocks. --- --- The list of outgoing labels is updated as we merge blocks (that is why they --- are not included in the hash, which we want to calculate only once). --- --- All in all, two blocks should never be compared if they have different --- hashes, and at most once otherwise. Previously, we were slower, and people --- rightfully complained: #10397 - --- TODO: Use optimization fuel -elimCommonBlocks :: CmmGraph -> CmmGraph -elimCommonBlocks g = replaceLabels env $ copyTicks env g - where - env = iterate mapEmpty blocks_with_key - groups = groupByInt hash_block (postorderDfs g) - blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups] - --- Invariant: The blocks in the list are pairwise distinct --- (so avoid comparing them again) -type DistinctBlocks = [CmmBlock] -type Key = [Label] -type Subst = LabelMap BlockId - --- The outer list groups by hash. We retain this grouping throughout. -iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst -iterate subst blocks - | mapNull new_substs = subst - | otherwise = iterate subst' updated_blocks - where - grouped_blocks :: [[(Key, [DistinctBlocks])]] - grouped_blocks = map groupByLabel blocks - - merged_blocks :: [[(Key, DistinctBlocks)]] - (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks - where - go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db)) - where - (new_subst2, db) = mergeBlockList subst dbs - - subst' = subst `mapUnion` new_substs - updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks - -mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks) -mergeBlocks subst existing new = go new - where - go [] = (mapEmpty, existing) - go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of - -- This block is a duplicate. Drop it, and add it to the substitution - Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs - -- This block is not a duplicate, keep it. - Nothing -> second (b:) $ go bs - -mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks) -mergeBlockList _ [] = pprPanic "mergeBlockList" empty -mergeBlockList subst (b:bs) = go mapEmpty b bs - where - go !new_subst1 b [] = (new_subst1, b) - go !new_subst1 b1 (b2:bs) = go new_subst b bs - where - (new_subst2, b) = mergeBlocks subst b1 b2 - new_subst = new_subst1 `mapUnion` new_subst2 - - --- ----------------------------------------------------------------------------- --- Hashing and equality on blocks - --- Below here is mostly boilerplate: hashing blocks ignoring labels, --- and comparing blocks modulo a label mapping. - --- To speed up comparisons, we hash each basic block modulo jump labels. --- The hashing is a bit arbitrary (the numbers are completely arbitrary), --- but it should be fast and good enough. - --- We want to get as many small buckets as possible, as comparing blocks is --- expensive. So include as much as possible in the hash. Ideally everything --- that is compared with (==) in eqBlockBodyWith. - -type HashCode = Int - -hash_block :: CmmBlock -> HashCode -hash_block block = - fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32)) - -- UniqFM doesn't like negative Ints - where hash_fst _ h = h - hash_mid m h = hash_node m + h `shiftL` 1 - hash_lst m h = hash_node m + h `shiftL` 1 - - hash_node :: CmmNode O x -> Word32 - hash_node n | dont_care n = 0 -- don't care - hash_node (CmmAssign r e) = hash_reg r + hash_e e - hash_node (CmmStore e e') = hash_e e + hash_e e' - hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as - hash_node (CmmBranch _) = 23 -- NB. ignore the label - hash_node (CmmCondBranch p _ _ _) = hash_e p - hash_node (CmmCall e _ _ _ _ _) = hash_e e - hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t - hash_node (CmmSwitch e _) = hash_e e - hash_node _ = error "hash_node: unknown Cmm node!" - - hash_reg :: CmmReg -> Word32 - hash_reg (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397 - hash_reg (CmmGlobal _) = 19 - - hash_e :: CmmExpr -> Word32 - hash_e (CmmLit l) = hash_lit l - hash_e (CmmLoad e _) = 67 + hash_e e - hash_e (CmmReg r) = hash_reg r - hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check - hash_e (CmmRegOff r i) = hash_reg r + cvt i - hash_e (CmmStackSlot _ _) = 13 - - hash_lit :: CmmLit -> Word32 - hash_lit (CmmInt i _) = fromInteger i - hash_lit (CmmFloat r _) = truncate r - hash_lit (CmmVec ls) = hash_list hash_lit ls - hash_lit (CmmLabel _) = 119 -- ugh - hash_lit (CmmLabelOff _ i) = cvt $ 199 + i - hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i - hash_lit (CmmBlock _) = 191 -- ugh - hash_lit (CmmHighStackMark) = cvt 313 - - hash_tgt (ForeignTarget e _) = hash_e e - hash_tgt (PrimTarget _) = 31 -- lots of these - - hash_list f = foldl (\z x -> f x + z) (0::Word32) - - cvt = fromInteger . toInteger - - hash_unique :: Uniquable a => a -> Word32 - hash_unique = cvt . getKey . getUnique - --- | Ignore these node types for equality -dont_care :: CmmNode O x -> Bool -dont_care CmmComment {} = True -dont_care CmmTick {} = True -dont_care CmmUnwind {} = True -dont_care _other = False - --- Utilities: equality and substitution on the graph. - --- Given a map ``subst'' from BlockID -> BlockID, we define equality. -eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool -eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' -lookupBid :: LabelMap BlockId -> BlockId -> BlockId -lookupBid subst bid = case mapLookup bid subst of - Just bid -> lookupBid subst bid - Nothing -> bid - --- Middle nodes and expressions can contain BlockIds, in particular in --- CmmStackSlot and CmmBlock, so we have to use a special equality for --- these. --- -eqMiddleWith :: (BlockId -> BlockId -> Bool) - -> CmmNode O O -> CmmNode O O -> Bool -eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2) - = r1 == r2 && eqExprWith eqBid e1 e2 -eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2) - = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 -eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1) - (CmmUnsafeForeignCall t2 r2 a2) - = t1 == t2 && r1 == r2 && and (zipWith (eqExprWith eqBid) a1 a2) -eqMiddleWith _ _ _ = False - -eqExprWith :: (BlockId -> BlockId -> Bool) - -> CmmExpr -> CmmExpr -> Bool -eqExprWith eqBid = eq - where - CmmLit l1 `eq` CmmLit l2 = eqLit l1 l2 - CmmLoad e1 _ `eq` CmmLoad e2 _ = e1 `eq` e2 - CmmReg r1 `eq` CmmReg r2 = r1==r2 - CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2 - CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2 - CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2 - _e1 `eq` _e2 = False - - xs `eqs` ys = and (zipWith eq xs ys) - - eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2 - eqLit l1 l2 = l1 == l2 - - eqArea Old Old = True - eqArea (Young id1) (Young id2) = eqBid id1 id2 - eqArea _ _ = False - --- Equality on the body of a block, modulo a function mapping block --- IDs to block IDs. -eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool -eqBlockBodyWith eqBid block block' - {- - | equal = pprTrace "equal" (vcat [ppr block, ppr block']) True - | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False - -} - = equal - where (_,m,l) = blockSplit block - nodes = filter (not . dont_care) (blockToList m) - (_,m',l') = blockSplit block' - nodes' = filter (not . dont_care) (blockToList m') - - equal = and (zipWith (eqMiddleWith eqBid) nodes nodes') && - eqLastWith eqBid l l' - - -eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool -eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2 -eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) = - c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2 -eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) = - t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2 -eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) = - e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2 -eqLastWith _ _ _ = False - -eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool -eqMaybeWith eltEq (Just e) (Just e') = eltEq e e' -eqMaybeWith _ Nothing Nothing = True -eqMaybeWith _ _ _ = False - --- | Given a block map, ensure that all "target" blocks are covered by --- the same ticks as the respective "source" blocks. This not only --- means copying ticks, but also adjusting tick scopes where --- necessary. -copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph -copyTicks env g - | mapNull env = g - | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap - where -- Reverse block merge map - blockMap = toBlockMap g - revEnv = mapFoldWithKey insertRev M.empty env - insertRev k x = M.insertWith (const (k:)) x [k] - -- Copy ticks and scopes into the given block - copyTo block = case M.lookup (entryLabel block) revEnv of - Nothing -> block - Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls - copy from to = - let ticks = blockTicks from - CmmEntry _ scp0 = firstNode from - (CmmEntry lbl scp1, code) = blockSplitHead to - in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead` - foldr blockCons code (map CmmTick ticks) - --- Group by [Label] -groupByLabel :: [(Key, a)] -> [(Key, [a])] -groupByLabel = go (TM.emptyTM :: TM.ListMap UniqDFM a) - where - go !m [] = TM.foldTM (:) m [] - go !m ((k,v) : entries) = go (TM.alterTM k' adjust m) entries - where k' = map getUnique k - adjust Nothing = Just (k,[v]) - adjust (Just (_,vs)) = Just (k,v:vs) - - -groupByInt :: (a -> Int) -> [a] -> [[a]] -groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs - -- See Note [Unique Determinism and code generation] - where go m x = alterUFM (Just . maybe [x] (x:)) m (f x) diff --git a/cmm/CmmContFlowOpt.hs b/cmm/CmmContFlowOpt.hs deleted file mode 100644 --- a/cmm/CmmContFlowOpt.hs +++ /dev/null @@ -1,415 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -module CmmContFlowOpt - ( cmmCfgOpts - , cmmCfgOptsProc - , removeUnreachableBlocksProc - , replaceLabels - ) -where - -import Hoopl -import BlockId -import Cmm -import CmmUtils -import CmmSwitch (mapSwitchTargets) -import Maybes -import Panic - -import Control.Monad -import Prelude hiding (succ, unzip, zip) - - --- Note [What is shortcutting] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Consider this Cmm code: --- --- L1: ... --- goto L2; --- L2: goto L3; --- L3: ... --- --- Here L2 is an empty block and contains only an unconditional branch --- to L3. In this situation any block that jumps to L2 can jump --- directly to L3: --- --- L1: ... --- goto L3; --- L2: goto L3; --- L3: ... --- --- In this situation we say that we shortcut L2 to L3. One of --- consequences of shortcutting is that some blocks of code may become --- unreachable (in the example above this is true for L2). - - --- Note [Control-flow optimisations] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- This optimisation does three things: --- --- - If a block finishes in an unconditonal branch to another block --- and that is the only jump to that block we concatenate the --- destination block at the end of the current one. --- --- - If a block finishes in a call whose continuation block is a --- goto, then we can shortcut the destination, making the --- continuation block the destination of the goto - but see Note --- [Shortcut call returns]. --- --- - For any block that is not a call we try to shortcut the --- destination(s). Additionally, if a block ends with a --- conditional branch we try to invert the condition. --- --- Blocks are processed using postorder DFS traversal. A side effect --- of determining traversal order with a graph search is elimination --- of any blocks that are unreachable. --- --- Transformations are improved by working from the end of the graph --- towards the beginning, because we may be able to perform many --- shortcuts in one go. - - --- Note [Shortcut call returns] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We are going to maintain the "current" graph (LabelMap CmmBlock) as --- we go, and also a mapping from BlockId to BlockId, representing --- continuation labels that we have renamed. This latter mapping is --- important because we might shortcut a CmmCall continuation. For --- example: --- --- Sp[0] = L --- call g returns to L --- L: goto M --- M: ... --- --- So when we shortcut the L block, we need to replace not only --- the continuation of the call, but also references to L in the --- code (e.g. the assignment Sp[0] = L): --- --- Sp[0] = M --- call g returns to M --- M: ... --- --- So we keep track of which labels we have renamed and apply the mapping --- at the end with replaceLabels. - - --- Note [Shortcut call returns and proc-points] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Consider this code that you might get from a recursive --- let-no-escape: --- --- goto L1 --- L1: --- if (Hp > HpLim) then L2 else L3 --- L2: --- call stg_gc_noregs returns to L4 --- L4: --- goto L1 --- L3: --- ... --- goto L1 --- --- Then the control-flow optimiser shortcuts L4. But that turns L1 --- into the call-return proc point, and every iteration of the loop --- has to shuffle variables to and from the stack. So we must *not* --- shortcut L4. --- --- Moreover not shortcutting call returns is probably fine. If L4 can --- concat with its branch target then it will still do so. And we --- save some compile time because we don't have to traverse all the --- code in replaceLabels. --- --- However, we probably do want to do this if we are splitting proc --- points, because L1 will be a proc-point anyway, so merging it with --- L4 reduces the number of proc points. Unfortunately recursive --- let-no-escapes won't generate very good code with proc-point --- splitting on - we should probably compile them to explicitly use --- the native calling convention instead. - -cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph -cmmCfgOpts split g = fst (blockConcat split g) - -cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl -cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g' - where (g', env) = blockConcat split g - info' = info{ info_tbls = new_info_tbls } - new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info))) - - -- If we changed any labels, then we have to update the info tables - -- too, except for the top-level info table because that might be - -- referred to by other procs. - upd_info (k,info) - | Just k' <- mapLookup k env - = (k', if k' == g_entry g' - then info - else info{ cit_lbl = infoTblLbl k' }) - | otherwise - = (k,info) -cmmCfgOptsProc _ top = top - - -blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId) -blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } - = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map') - where - -- We might be able to shortcut the entry BlockId itself. - -- Remember to update the shortcut_map, since we also have to - -- update the info_tbls mapping now. - (new_entry, shortcut_map') - | Just entry_blk <- mapLookup entry_id new_blocks - , Just dest <- canShortcut entry_blk - = (dest, mapInsert entry_id dest shortcut_map) - | otherwise - = (entry_id, shortcut_map) - - -- blocks is a list of blocks in DFS postorder, while blockmap is - -- a map of blocks. We process each element from blocks and update - -- blockmap accordingly - blocks = postorderDfs g - blockmap = foldr addBlock emptyBody blocks - - -- Accumulator contains three components: - -- * map of blocks in a graph - -- * map of shortcut labels. See Note [Shortcut call returns] - -- * map containing number of predecessors for each block. We discard - -- it after we process all blocks. - (new_blocks, shortcut_map, _) = - foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks - - -- Map of predecessors for initial graph. We increase number of - -- predecessors for entry block by one to denote that it is - -- target of a jump, even if no block in the current graph jumps - -- to it. - initialBackEdges = incPreds entry_id (predMap blocks) - - maybe_concat :: CmmBlock - -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int) - -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int) - maybe_concat block (blocks, shortcut_map, backEdges) - -- If: - -- (1) current block ends with unconditional branch to b' and - -- (2) it has exactly one predecessor (namely, current block) - -- - -- Then: - -- (1) append b' block at the end of current block - -- (2) remove b' from the map of blocks - -- (3) remove information about b' from predecessors map - -- - -- Since we know that the block has only one predecessor we call - -- mapDelete directly instead of calling decPreds. - -- - -- Note that we always maintain an up-to-date list of predecessors, so - -- we can ignore the contents of shortcut_map - | CmmBranch b' <- last - , hasOnePredecessor b' - , Just blk' <- mapLookup b' blocks - = let bid' = entryLabel blk' - in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks - , shortcut_map - , mapDelete b' backEdges ) - - -- If: - -- (1) we are splitting proc points (see Note - -- [Shortcut call returns and proc-points]) and - -- (2) current block is a CmmCall or CmmForeignCall with - -- continuation b' and - -- (3) we can shortcut that continuation to dest - -- Then: - -- (1) we change continuation to point to b' - -- (2) create mapping from b' to dest - -- (3) increase number of predecessors of dest by 1 - -- (4) decrease number of predecessors of b' by 1 - -- - -- Later we will use replaceLabels to substitute all occurrences of b' - -- with dest. - | splitting_procs - , Just b' <- callContinuation_maybe last - , Just blk' <- mapLookup b' blocks - , Just dest <- canShortcut blk' - = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks - , mapInsert b' dest shortcut_map - , decPreds b' $ incPreds dest backEdges ) - - -- If: - -- (1) a block does not end with a call - -- Then: - -- (1) if it ends with a conditional attempt to invert the - -- conditional - -- (2) attempt to shortcut all destination blocks - -- (3) if new successors of a block are different from the old ones - -- update the of predecessors accordingly - -- - -- A special case of this is a situation when a block ends with an - -- unconditional jump to a block that can be shortcut. - | Nothing <- callContinuation_maybe last - = let oldSuccs = successors last - newSuccs = successors swapcond_last - in ( mapInsert bid (blockJoinTail head swapcond_last) blocks - , shortcut_map - , if oldSuccs == newSuccs - then backEdges - else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs ) - - -- Otherwise don't do anything - | otherwise - = ( blocks, shortcut_map, backEdges ) - where - (head, last) = blockSplitTail block - bid = entryLabel block - - -- Changes continuation of a call to a specified label - update_cont dest = - case last of - CmmCall{} -> last { cml_cont = Just dest } - CmmForeignCall{} -> last { succ = dest } - _ -> panic "Can't shortcut continuation." - - -- Attempts to shortcut successors of last node - shortcut_last = mapSuccessors shortcut last - where - shortcut l = - case mapLookup l blocks of - Just b | Just dest <- canShortcut b -> dest - _otherwise -> l - - -- For a conditional, we invert the conditional if that would make it - -- more likely that the branch-not-taken case becomes a fallthrough. - -- This helps the native codegen a little bit, and probably has no - -- effect on LLVM. It's convenient to do it here, where we have the - -- information about predecessors. - swapcond_last - | CmmCondBranch cond t f l <- shortcut_last - , likelyFalse l - , numPreds f > 1 - , hasOnePredecessor t - , Just cond' <- maybeInvertCmmExpr cond - = CmmCondBranch cond' f t (invertLikeliness l) - - | otherwise - = shortcut_last - - likelyFalse (Just False) = True - likelyFalse Nothing = True - likelyFalse _ = False - - invertLikeliness (Just b) = Just (not b) - invertLikeliness Nothing = Nothing - - -- Number of predecessors for a block - numPreds bid = mapLookup bid backEdges `orElse` 0 - - hasOnePredecessor b = numPreds b == 1 - --- Functions for incrementing and decrementing number of predecessors. If --- decrementing would set the predecessor count to 0, we remove entry from the --- map. --- Invariant: if a block has no predecessors it should be dropped from the --- graph because it is unreachable. maybe_concat is constructed to maintain --- that invariant, but calling replaceLabels may introduce unreachable blocks. --- We rely on subsequent passes in the Cmm pipeline to remove unreachable --- blocks. -incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int -incPreds bid edges = mapInsertWith (+) bid 1 edges -decPreds bid edges = case mapLookup bid edges of - Just preds | preds > 1 -> mapInsert bid (preds - 1) edges - Just _ -> mapDelete bid edges - _ -> edges - - --- Checks if a block consists only of "goto dest". If it does than we return --- "Just dest" label. See Note [What is shortcutting] -canShortcut :: CmmBlock -> Maybe BlockId -canShortcut block - | (_, middle, CmmBranch dest) <- blockSplit block - , all dont_care $ blockToList middle - = Just dest - | otherwise - = Nothing - where dont_care CmmComment{} = True - dont_care CmmTick{} = True - dont_care _other = False - --- Concatenates two blocks. First one is assumed to be open on exit, the second --- is assumed to be closed on entry (i.e. it has a label attached to it, which --- the splice function removes by calling snd on result of blockSplitHead). -splice :: Block CmmNode C O -> CmmBlock -> CmmBlock -splice head rest = entry `blockJoinHead` code0 `blockAppend` code1 - where (CmmEntry lbl sc0, code0) = blockSplitHead head - (CmmEntry _ sc1, code1) = blockSplitHead rest - entry = CmmEntry lbl (combineTickScopes sc0 sc1) - --- If node is a call with continuation call return Just label of that --- continuation. Otherwise return Nothing. -callContinuation_maybe :: CmmNode O C -> Maybe BlockId -callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b -callContinuation_maybe (CmmForeignCall { succ = b }) = Just b -callContinuation_maybe _ = Nothing - - --- Map over the CmmGraph, replacing each label with its mapping in the --- supplied LabelMap. -replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph -replaceLabels env g - | mapNull env = g - | otherwise = replace_eid $ mapGraphNodes1 txnode g - where - replace_eid g = g {g_entry = lookup (g_entry g)} - lookup id = mapLookup id env `orElse` id - - txnode :: CmmNode e x -> CmmNode e x - txnode (CmmBranch bid) = CmmBranch (lookup bid) - txnode (CmmCondBranch p t f l) = - mkCmmCondBranch (exp p) (lookup t) (lookup f) l - txnode (CmmSwitch e ids) = - CmmSwitch (exp e) (mapSwitchTargets lookup ids) - txnode (CmmCall t k rg a res r) = - CmmCall (exp t) (liftM lookup k) rg a res r - txnode fc@CmmForeignCall{} = - fc{ args = map exp (args fc), succ = lookup (succ fc) } - txnode other = mapExpDeep exp other - - exp :: CmmExpr -> CmmExpr - exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid)) - exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i - exp e = e - -mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C -mkCmmCondBranch p t f l = - if t == f then CmmBranch t else CmmCondBranch p t f l - --- Build a map from a block to its set of predecessors. -predMap :: [CmmBlock] -> LabelMap Int -predMap blocks = foldr add_preds mapEmpty blocks - where - add_preds block env = foldr add env (successors block) - where add lbl env = mapInsertWith (+) lbl 1 env - --- Removing unreachable blocks -removeUnreachableBlocksProc :: CmmDecl -> CmmDecl -removeUnreachableBlocksProc proc@(CmmProc info lbl live g) - | length used_blocks < mapSize (toBlockMap g) - = CmmProc info' lbl live g' - | otherwise - = proc - where - g' = ofBlockList (g_entry g) used_blocks - info' = info { info_tbls = keep_used (info_tbls info) } - -- Remove any info_tbls for unreachable - - keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable - keep_used bs = mapFoldWithKey keep mapEmpty bs - - keep :: Label -> CmmInfoTable -> LabelMap CmmInfoTable -> LabelMap CmmInfoTable - keep l i env | l `setMember` used_lbls = mapInsert l i env - | otherwise = env - - used_blocks :: [CmmBlock] - used_blocks = postorderDfs g - - used_lbls :: LabelSet - used_lbls = foldr (setInsert . entryLabel) setEmpty used_blocks diff --git a/cmm/CmmExpr.hs b/cmm/CmmExpr.hs deleted file mode 100644 --- a/cmm/CmmExpr.hs +++ /dev/null @@ -1,585 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} - -module CmmExpr - ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr - , CmmReg(..), cmmRegType - , CmmLit(..), cmmLitType - , LocalReg(..), localRegType - , GlobalReg(..), isArgReg, globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg - , VGcPtr(..) - - , DefinerOfRegs, UserOfRegs - , foldRegsDefd, foldRegsUsed - , foldLocalRegsDefd, foldLocalRegsUsed - - , RegSet, LocalRegSet, GlobalRegSet - , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet - , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet - , regSetToList - - , Area(..) - , module CmmMachOp - , module CmmType - ) -where - -import BlockId -import CLabel -import CmmMachOp -import CmmType -import DynFlags -import Outputable (panic) -import Unique - -import Data.Set (Set) -import Data.List -import qualified Data.Set as Set - ------------------------------------------------------------------------------ --- CmmExpr --- An expression. Expressions have no side effects. ------------------------------------------------------------------------------ - -data CmmExpr - = CmmLit CmmLit -- Literal - | CmmLoad !CmmExpr !CmmType -- Read memory location - | CmmReg !CmmReg -- Contents of register - | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.) - | CmmStackSlot Area {-# UNPACK #-} !Int - -- addressing expression of a stack slot - -- See Note [CmmStackSlot aliasing] - | CmmRegOff !CmmReg Int - -- CmmRegOff reg i - -- ** is shorthand only, meaning ** - -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] - -- where rep = typeWidth (cmmRegType reg) - -instance Eq CmmExpr where -- Equality ignores the types - CmmLit l1 == CmmLit l2 = l1==l2 - CmmLoad e1 _ == CmmLoad e2 _ = e1==e2 - CmmReg r1 == CmmReg r2 = r1==r2 - CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2 - CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2 - CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 - _e1 == _e2 = False - -data CmmReg - = CmmLocal {-# UNPACK #-} !LocalReg - | CmmGlobal GlobalReg - deriving( Eq, Ord ) - --- | A stack area is either the stack slot where a variable is spilled --- or the stack space where function arguments and results are passed. -data Area - = Old -- See Note [Old Area] - | Young {-# UNPACK #-} !BlockId -- Invariant: must be a continuation BlockId - -- See Note [Continuation BlockId] in CmmNode. - deriving (Eq, Ord) - -{- Note [Old Area] -~~~~~~~~~~~~~~~~~~ -There is a single call area 'Old', allocated at the extreme old -end of the stack frame (ie just younger than the return address) -which holds: - * incoming (overflow) parameters, - * outgoing (overflow) parameter to tail calls, - * outgoing (overflow) result values - * the update frame (if any) - -Its size is the max of all these requirements. On entry, the stack -pointer will point to the youngest incoming parameter, which is not -necessarily at the young end of the Old area. - -End of note -} - - -{- Note [CmmStackSlot aliasing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When do two CmmStackSlots alias? - - - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M - - T[old+N] aliases with U[old+M] only if the areas actually overlap - -Or more informally, different Areas may overlap with each other. - -An alternative semantics, that we previously had, was that different -Areas do not overlap. The problem that lead to redefining the -semantics of stack areas is described below. - -e.g. if we had - - x = Sp[old + 8] - y = Sp[old + 16] - - Sp[young(L) + 8] = L - Sp[young(L) + 16] = y - Sp[young(L) + 24] = x - call f() returns to L - -if areas semantically do not overlap, then we might optimise this to - - Sp[young(L) + 8] = L - Sp[young(L) + 16] = Sp[old + 8] - Sp[young(L) + 24] = Sp[old + 16] - call f() returns to L - -and now young(L) cannot be allocated at the same place as old, and we -are doomed to use more stack. - - - old+8 conflicts with young(L)+8 - - old+16 conflicts with young(L)+16 and young(L)+8 - -so young(L)+8 == old+24 and we get - - Sp[-8] = L - Sp[-16] = Sp[8] - Sp[-24] = Sp[0] - Sp -= 24 - call f() returns to L - -However, if areas are defined to be "possibly overlapping" in the -semantics, then we cannot commute any loads/stores of old with -young(L), and we will be able to re-use both old+8 and old+16 for -young(L). - - x = Sp[8] - y = Sp[0] - - Sp[8] = L - Sp[0] = y - Sp[-8] = x - Sp = Sp - 8 - call f() returns to L - -Now, the assignments of y go away, - - x = Sp[8] - Sp[8] = L - Sp[-8] = x - Sp = Sp - 8 - call f() returns to L --} - -data CmmLit - = CmmInt !Integer Width - -- Interpretation: the 2's complement representation of the value - -- is truncated to the specified size. This is easier than trying - -- to keep the value within range, because we don't know whether - -- it will be used as a signed or unsigned value (the CmmType doesn't - -- distinguish between signed & unsigned). - | CmmFloat Rational Width - | CmmVec [CmmLit] -- Vector literal - | CmmLabel CLabel -- Address of label - | CmmLabelOff CLabel Int -- Address of label + byte offset - - -- Due to limitations in the C backend, the following - -- MUST ONLY be used inside the info table indicated by label2 - -- (label2 must be the info label), and label1 must be an - -- SRT, a slow entrypoint or a large bitmap (see the Mangler) - -- Don't use it at all unless tablesNextToCode. - -- It is also used inside the NCG during when generating - -- position-independent code. - | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset - - | CmmBlock {-# UNPACK #-} !BlockId -- Code label - -- Invariant: must be a continuation BlockId - -- See Note [Continuation BlockId] in CmmNode. - - | CmmHighStackMark -- A late-bound constant that stands for the max - -- #bytes of stack space used during a procedure. - -- During the stack-layout pass, CmmHighStackMark - -- is replaced by a CmmInt for the actual number - -- of bytes used - deriving Eq - -cmmExprType :: DynFlags -> CmmExpr -> CmmType -cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit -cmmExprType _ (CmmLoad _ rep) = rep -cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg -cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args) -cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg -cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address --- Careful though: what is stored at the stack slot may be bigger than --- an address - -cmmLitType :: DynFlags -> CmmLit -> CmmType -cmmLitType _ (CmmInt _ width) = cmmBits width -cmmLitType _ (CmmFloat _ width) = cmmFloat width -cmmLitType _ (CmmVec []) = panic "cmmLitType: CmmVec []" -cmmLitType cflags (CmmVec (l:ls)) = let ty = cmmLitType cflags l - in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls) - then cmmVec (1+length ls) ty - else panic "cmmLitType: CmmVec" -cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl -cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl -cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags -cmmLitType dflags (CmmBlock _) = bWord dflags -cmmLitType dflags (CmmHighStackMark) = bWord dflags - -cmmLabelType :: DynFlags -> CLabel -> CmmType -cmmLabelType dflags lbl - | isGcPtrLabel lbl = gcWord dflags - | otherwise = bWord dflags - -cmmExprWidth :: DynFlags -> CmmExpr -> Width -cmmExprWidth dflags e = typeWidth (cmmExprType dflags e) - --------- ---- Negation for conditional branches - -maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr -maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op - return (CmmMachOp op' args) -maybeInvertCmmExpr _ = Nothing - ------------------------------------------------------------------------------ --- Local registers ------------------------------------------------------------------------------ - -data LocalReg - = LocalReg {-# UNPACK #-} !Unique CmmType - -- ^ Parameters: - -- 1. Identifier - -- 2. Type - -instance Eq LocalReg where - (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 - --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] --- See Note [No Ord for Unique] -instance Ord LocalReg where - compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2 - -instance Uniquable LocalReg where - getUnique (LocalReg uniq _) = uniq - -cmmRegType :: DynFlags -> CmmReg -> CmmType -cmmRegType _ (CmmLocal reg) = localRegType reg -cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg - -localRegType :: LocalReg -> CmmType -localRegType (LocalReg _ rep) = rep - ------------------------------------------------------------------------------ --- Register-use information for expressions and other types ------------------------------------------------------------------------------ - --- | Sets of registers - --- These are used for dataflow facts, and a common operation is taking --- the union of two RegSets and then asking whether the union is the --- same as one of the inputs. UniqSet isn't good here, because --- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary --- Sets. - -type RegSet r = Set r -type LocalRegSet = RegSet LocalReg -type GlobalRegSet = RegSet GlobalReg - -emptyRegSet :: RegSet r -nullRegSet :: RegSet r -> Bool -elemRegSet :: Ord r => r -> RegSet r -> Bool -extendRegSet :: Ord r => RegSet r -> r -> RegSet r -deleteFromRegSet :: Ord r => RegSet r -> r -> RegSet r -mkRegSet :: Ord r => [r] -> RegSet r -minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r -sizeRegSet :: RegSet r -> Int -regSetToList :: RegSet r -> [r] - -emptyRegSet = Set.empty -nullRegSet = Set.null -elemRegSet = Set.member -extendRegSet = flip Set.insert -deleteFromRegSet = flip Set.delete -mkRegSet = Set.fromList -minusRegSet = Set.difference -plusRegSet = Set.union -timesRegSet = Set.intersection -sizeRegSet = Set.size -regSetToList = Set.toList - -class Ord r => UserOfRegs r a where - foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b - -foldLocalRegsUsed :: UserOfRegs LocalReg a - => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b -foldLocalRegsUsed = foldRegsUsed - -class Ord r => DefinerOfRegs r a where - foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b - -foldLocalRegsDefd :: DefinerOfRegs LocalReg a - => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b -foldLocalRegsDefd = foldRegsDefd - -instance UserOfRegs LocalReg CmmReg where - foldRegsUsed _ f z (CmmLocal reg) = f z reg - foldRegsUsed _ _ z (CmmGlobal _) = z - -instance DefinerOfRegs LocalReg CmmReg where - foldRegsDefd _ f z (CmmLocal reg) = f z reg - foldRegsDefd _ _ z (CmmGlobal _) = z - -instance UserOfRegs GlobalReg CmmReg where - foldRegsUsed _ _ z (CmmLocal _) = z - foldRegsUsed _ f z (CmmGlobal reg) = f z reg - -instance DefinerOfRegs GlobalReg CmmReg where - foldRegsDefd _ _ z (CmmLocal _) = z - foldRegsDefd _ f z (CmmGlobal reg) = f z reg - -instance Ord r => UserOfRegs r r where - foldRegsUsed _ f z r = f z r - -instance Ord r => DefinerOfRegs r r where - foldRegsDefd _ f z r = f z r - -instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where - -- The (Ord r) in the context is necessary here - -- See Note [Recursive superclasses] in TcInstDcls - foldRegsUsed dflags f !z e = expr z e - where expr z (CmmLit _) = z - expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr - expr z (CmmReg r) = foldRegsUsed dflags f z r - expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs - expr z (CmmRegOff r _) = foldRegsUsed dflags f z r - expr z (CmmStackSlot _ _) = z - -instance UserOfRegs r a => UserOfRegs r [a] where - foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as - {-# INLINABLE foldRegsUsed #-} - -instance DefinerOfRegs r a => DefinerOfRegs r [a] where - foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as - {-# INLINABLE foldRegsDefd #-} - ------------------------------------------------------------------------------ --- Global STG registers ------------------------------------------------------------------------------ - -data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) - ------------------------------------------------------------------------------ --- Global STG registers ------------------------------------------------------------------------------ -{- -Note [Overlapping global registers] - -The backend might not faithfully implement the abstraction of the STG -machine with independent registers for different values of type -GlobalReg. Specifically, certain pairs of registers (r1, r2) may -overlap in the sense that a store to r1 invalidates the value in r2, -and vice versa. - -Currently this occurs only on the x86_64 architecture where FloatReg n -and DoubleReg n are assigned the same microarchitectural register, in -order to allow functions to receive more Float# or Double# arguments -in registers (as opposed to on the stack). - -There are no specific rules about which registers might overlap with -which other registers, but presumably it's safe to assume that nothing -will overlap with special registers like Sp or BaseReg. - -Use CmmUtils.regsOverlap to determine whether two GlobalRegs overlap -on a particular platform. The instance Eq GlobalReg is syntactic -equality of STG registers and does not take overlap into -account. However it is still used in UserOfRegs/DefinerOfRegs and -there are likely still bugs there, beware! --} - -data GlobalReg - -- Argument and return registers - = VanillaReg -- pointers, unboxed ints and chars - {-# UNPACK #-} !Int -- its number - VGcPtr - - | FloatReg -- single-precision floating-point registers - {-# UNPACK #-} !Int -- its number - - | DoubleReg -- double-precision floating-point registers - {-# UNPACK #-} !Int -- its number - - | LongReg -- long int registers (64-bit, really) - {-# UNPACK #-} !Int -- its number - - | XmmReg -- 128-bit SIMD vector register - {-# UNPACK #-} !Int -- its number - - | YmmReg -- 256-bit SIMD vector register - {-# UNPACK #-} !Int -- its number - - | ZmmReg -- 512-bit SIMD vector register - {-# UNPACK #-} !Int -- its number - - -- STG registers - | Sp -- Stack ptr; points to last occupied stack location. - | SpLim -- Stack limit - | Hp -- Heap ptr; points to last occupied heap location. - | HpLim -- Heap limit register - | CCCS -- Current cost-centre stack - | CurrentTSO -- pointer to current thread's TSO - | CurrentNursery -- pointer to allocation area - | HpAlloc -- allocation count for heap check failure - - -- We keep the address of some commonly-called - -- functions in the register table, to keep code - -- size down: - | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info - | GCEnter1 -- stg_gc_enter_1 - | GCFun -- stg_gc_fun - - -- Base offset for the register table, used for accessing registers - -- which do not have real registers assigned to them. This register - -- will only appear after we have expanded GlobalReg into memory accesses - -- (where necessary) in the native code generator. - | BaseReg - - -- The register used by the platform for the C stack pointer. This is - -- a break in the STG abstraction used exclusively to setup stack unwinding - -- information. - | MachSp - - -- The is a dummy register used to indicate to the stack unwinder where - -- a routine would return to. - | UnwindReturnReg - - -- Base Register for PIC (position-independent code) calculations - -- Only used inside the native code generator. It's exact meaning differs - -- from platform to platform (see module PositionIndependentCode). - | PicBaseReg - - deriving( Show ) - -instance Eq GlobalReg where - VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes - FloatReg i == FloatReg j = i==j - DoubleReg i == DoubleReg j = i==j - LongReg i == LongReg j = i==j - XmmReg i == XmmReg j = i==j - YmmReg i == YmmReg j = i==j - ZmmReg i == ZmmReg j = i==j - Sp == Sp = True - SpLim == SpLim = True - Hp == Hp = True - HpLim == HpLim = True - CCCS == CCCS = True - CurrentTSO == CurrentTSO = True - CurrentNursery == CurrentNursery = True - HpAlloc == HpAlloc = True - EagerBlackholeInfo == EagerBlackholeInfo = True - GCEnter1 == GCEnter1 = True - GCFun == GCFun = True - BaseReg == BaseReg = True - MachSp == MachSp = True - UnwindReturnReg == UnwindReturnReg = True - PicBaseReg == PicBaseReg = True - _r1 == _r2 = False - -instance Ord GlobalReg where - compare (VanillaReg i _) (VanillaReg j _) = compare i j - -- Ignore type when seeking clashes - compare (FloatReg i) (FloatReg j) = compare i j - compare (DoubleReg i) (DoubleReg j) = compare i j - compare (LongReg i) (LongReg j) = compare i j - compare (XmmReg i) (XmmReg j) = compare i j - compare (YmmReg i) (YmmReg j) = compare i j - compare (ZmmReg i) (ZmmReg j) = compare i j - compare Sp Sp = EQ - compare SpLim SpLim = EQ - compare Hp Hp = EQ - compare HpLim HpLim = EQ - compare CCCS CCCS = EQ - compare CurrentTSO CurrentTSO = EQ - compare CurrentNursery CurrentNursery = EQ - compare HpAlloc HpAlloc = EQ - compare EagerBlackholeInfo EagerBlackholeInfo = EQ - compare GCEnter1 GCEnter1 = EQ - compare GCFun GCFun = EQ - compare BaseReg BaseReg = EQ - compare MachSp MachSp = EQ - compare UnwindReturnReg UnwindReturnReg = EQ - compare PicBaseReg PicBaseReg = EQ - compare (VanillaReg _ _) _ = LT - compare _ (VanillaReg _ _) = GT - compare (FloatReg _) _ = LT - compare _ (FloatReg _) = GT - compare (DoubleReg _) _ = LT - compare _ (DoubleReg _) = GT - compare (LongReg _) _ = LT - compare _ (LongReg _) = GT - compare (XmmReg _) _ = LT - compare _ (XmmReg _) = GT - compare (YmmReg _) _ = LT - compare _ (YmmReg _) = GT - compare (ZmmReg _) _ = LT - compare _ (ZmmReg _) = GT - compare Sp _ = LT - compare _ Sp = GT - compare SpLim _ = LT - compare _ SpLim = GT - compare Hp _ = LT - compare _ Hp = GT - compare HpLim _ = LT - compare _ HpLim = GT - compare CCCS _ = LT - compare _ CCCS = GT - compare CurrentTSO _ = LT - compare _ CurrentTSO = GT - compare CurrentNursery _ = LT - compare _ CurrentNursery = GT - compare HpAlloc _ = LT - compare _ HpAlloc = GT - compare GCEnter1 _ = LT - compare _ GCEnter1 = GT - compare GCFun _ = LT - compare _ GCFun = GT - compare BaseReg _ = LT - compare _ BaseReg = GT - compare MachSp _ = LT - compare _ MachSp = GT - compare UnwindReturnReg _ = LT - compare _ UnwindReturnReg = GT - compare EagerBlackholeInfo _ = LT - compare _ EagerBlackholeInfo = GT - --- convenient aliases -baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg -baseReg = CmmGlobal BaseReg -spReg = CmmGlobal Sp -hpReg = CmmGlobal Hp -spLimReg = CmmGlobal SpLim -nodeReg = CmmGlobal node - -node :: GlobalReg -node = VanillaReg 1 VGcPtr - -globalRegType :: DynFlags -> GlobalReg -> CmmType -globalRegType dflags (VanillaReg _ VGcPtr) = gcWord dflags -globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags -globalRegType _ (FloatReg _) = cmmFloat W32 -globalRegType _ (DoubleReg _) = cmmFloat W64 -globalRegType _ (LongReg _) = cmmBits W64 -globalRegType _ (XmmReg _) = cmmVec 4 (cmmBits W32) -globalRegType _ (YmmReg _) = cmmVec 8 (cmmBits W32) -globalRegType _ (ZmmReg _) = cmmVec 16 (cmmBits W32) - -globalRegType dflags Hp = gcWord dflags - -- The initialiser for all - -- dynamically allocated closures -globalRegType dflags _ = bWord dflags - -isArgReg :: GlobalReg -> Bool -isArgReg (VanillaReg {}) = True -isArgReg (FloatReg {}) = True -isArgReg (DoubleReg {}) = True -isArgReg (LongReg {}) = True -isArgReg (XmmReg {}) = True -isArgReg (YmmReg {}) = True -isArgReg (ZmmReg {}) = True -isArgReg _ = False diff --git a/cmm/CmmImplementSwitchPlans.hs b/cmm/CmmImplementSwitchPlans.hs deleted file mode 100644 --- a/cmm/CmmImplementSwitchPlans.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE GADTs #-} -module CmmImplementSwitchPlans - ( cmmImplementSwitchPlans - ) -where - -import Hoopl -import BlockId -import Cmm -import CmmUtils -import CmmSwitch -import UniqSupply -import DynFlags - --- --- This module replaces Switch statements as generated by the Stg -> Cmm --- transformation, which might be huge and sparse and hence unsuitable for --- assembly code, by proper constructs (if-then-else trees, dense jump tables). --- --- The actual, abstract strategy is determined by createSwitchPlan in --- CmmSwitch and returned as a SwitchPlan; here is just the implementation in --- terms of Cmm code. See Note [Cmm Switches, the general plan] in CmmSwitch. --- --- This division into different modules is both to clearly separte concerns, --- but also because createSwitchPlan needs access to the constructors of --- SwitchTargets, a data type exported abstractly by CmmSwitch. --- - --- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for --- code generation. -cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph -cmmImplementSwitchPlans dflags g - | targetSupportsSwitch (hscTarget dflags) = return g - | otherwise = do - blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g) - return $ ofBlockList (g_entry g) blocks' - -visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock] -visitSwitches dflags block - | (entry@(CmmEntry _ scope), middle, CmmSwitch expr ids) <- blockSplit block - = do - let plan = createSwitchPlan ids - - (newTail, newBlocks) <- implementSwitchPlan dflags scope expr plan - - let block' = entry `blockJoinHead` middle `blockAppend` newTail - - return $ block' : newBlocks - - | otherwise - = return [block] - - --- Implementing a switch plan (returning a tail block) -implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock]) -implementSwitchPlan dflags scope expr = go - where - go (Unconditionally l) - = return (emptyBlock `blockJoinTail` CmmBranch l, []) - go (JumpTable ids) - = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, []) - go (IfLT signed i ids1 ids2) - = do - (bid1, newBlocks1) <- go' ids1 - (bid2, newBlocks2) <- go' ids2 - - let lt | signed = cmmSLtWord - | otherwise = cmmULtWord - scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i - lastNode = CmmCondBranch scrut bid1 bid2 Nothing - lastBlock = emptyBlock `blockJoinTail` lastNode - return (lastBlock, newBlocks1++newBlocks2) - go (IfEqual i l ids2) - = do - (bid2, newBlocks2) <- go' ids2 - - let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i - lastNode = CmmCondBranch scrut bid2 l Nothing - lastBlock = emptyBlock `blockJoinTail` lastNode - return (lastBlock, newBlocks2) - - -- Same but returning a label to branch to - go' (Unconditionally l) - = return (l, []) - go' p - = do - bid <- mkBlockId `fmap` getUniqueM - (last, newBlocks) <- go p - let block = CmmEntry bid scope `blockJoinHead` last - return (bid, block: newBlocks) diff --git a/cmm/CmmInfo.hs b/cmm/CmmInfo.hs deleted file mode 100644 --- a/cmm/CmmInfo.hs +++ /dev/null @@ -1,557 +0,0 @@ -{-# LANGUAGE CPP #-} -module CmmInfo ( - mkEmptyContInfoTable, - cmmToRawCmm, - mkInfoTable, - srtEscape, - - -- info table accessors - closureInfoPtr, - entryCode, - getConstrTag, - cmmGetClosureType, - infoTable, - infoTableConstrTag, - infoTableSrtBitmap, - infoTableClosureType, - infoTablePtrs, - infoTableNonPtrs, - funInfoTable, - funInfoArity, - - -- info table sizes and offsets - stdInfoTableSizeW, - fixedInfoTableSizeW, - profInfoTableSizeW, - maxStdInfoTableSizeW, - maxRetInfoTableSizeW, - stdInfoTableSizeB, - conInfoTableSizeB, - stdSrtBitmapOffset, - stdClosureTypeOffset, - stdPtrsOffset, stdNonPtrsOffset, -) where - -#include "HsVersions.h" - -import Cmm -import CmmUtils -import CLabel -import SMRep -import Bitmap -import Stream (Stream) -import qualified Stream -import Hoopl - -import Maybes -import DynFlags -import Panic -import UniqSupply -import MonadUtils -import Util -import Outputable - -import Data.Bits -import Data.Word - --- When we split at proc points, we need an empty info table. -mkEmptyContInfoTable :: CLabel -> CmmInfoTable -mkEmptyContInfoTable info_lbl - = CmmInfoTable { cit_lbl = info_lbl - , cit_rep = mkStackRep [] - , cit_prof = NoProfilingInfo - , cit_srt = NoC_SRT } - -cmmToRawCmm :: DynFlags -> Stream IO CmmGroup () - -> IO (Stream IO RawCmmGroup ()) -cmmToRawCmm dflags cmms - = do { uniqs <- mkSplitUniqSupply 'i' - ; let do_one uniqs cmm = do - case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of - (b,uniqs') -> return (uniqs',b) - -- NB. strictness fixes a space leak. DO NOT REMOVE. - ; return (Stream.mapAccumL do_one uniqs cmms >> return ()) - } - --- Make a concrete info table, represented as a list of CmmStatic --- (it can't be simply a list of Word, because the SRT field is --- represented by a label+offset expression). --- --- With tablesNextToCode, the layout is --- --- --- --- --- Without tablesNextToCode, the layout of an info table is --- --- --- --- --- See includes/rts/storage/InfoTables.h --- --- For return-points these are as follows --- --- Tables next to code: --- --- --- --- ret-addr --> --- --- Not tables-next-to-code: --- --- ret-addr --> --- --- --- --- * The SRT slot is only there if there is SRT info to record - -mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl] -mkInfoTable _ (CmmData sec dat) - = return [CmmData sec dat] - -mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) - -- - -- in the non-tables-next-to-code case, procs can have at most a - -- single info table associated with the entry label of the proc. - -- - | not (tablesNextToCode dflags) - = case topInfoTable proc of -- must be at most one - -- no info table - Nothing -> - return [CmmProc mapEmpty entry_lbl live blocks] - - Just info@CmmInfoTable { cit_lbl = info_lbl } -> do - (top_decls, (std_info, extra_bits)) <- - mkInfoTableContents dflags info Nothing - let - rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info - rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits - -- - -- Separately emit info table (with the function entry - -- point as first entry) and the entry code - -- - return (top_decls ++ - [CmmProc mapEmpty entry_lbl live blocks, - mkDataLits (Section Data info_lbl) info_lbl - (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]) - - -- - -- With tables-next-to-code, we can have many info tables, - -- associated with some of the BlockIds of the proc. For each info - -- table we need to turn it into CmmStatics, and collect any new - -- CmmDecls that arise from doing so. - -- - | otherwise - = do - (top_declss, raw_infos) <- - unzip `fmap` mapM do_one_info (mapToList (info_tbls infos)) - return (concat top_declss ++ - [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) - - where - do_one_info (lbl,itbl) = do - (top_decls, (std_info, extra_bits)) <- - mkInfoTableContents dflags itbl Nothing - let - info_lbl = cit_lbl itbl - rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info - rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits - -- - return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $ - reverse rel_extra_bits ++ rel_std_info)) - ------------------------------------------------------ -type InfoTableContents = ( [CmmLit] -- The standard part - , [CmmLit] ) -- The "extra bits" --- These Lits have *not* had mkRelativeTo applied to them - -mkInfoTableContents :: DynFlags - -> CmmInfoTable - -> Maybe Int -- Override default RTS type tag? - -> UniqSM ([RawCmmDecl], -- Auxiliary top decls - InfoTableContents) -- Info tbl + extra bits - -mkInfoTableContents dflags - info@(CmmInfoTable { cit_lbl = info_lbl - , cit_rep = smrep - , cit_prof = prof - , cit_srt = srt }) - mb_rts_tag - | RTSRep rts_tag rep <- smrep - = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag) - -- Completely override the rts_tag that mkInfoTableContents would - -- otherwise compute, with the rts_tag stored in the RTSRep - -- (which in turn came from a handwritten .cmm file) - - | StackRep frame <- smrep - = do { (prof_lits, prof_data) <- mkProfLits dflags prof - ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt - ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame - ; let - std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit - rts_tag | Just tag <- mb_rts_tag = tag - | null liveness_data = rET_SMALL -- Fits in extra_bits - | otherwise = rET_BIG -- Does not; extra_bits is - -- a label - ; return (prof_data ++ liveness_data, (std_info, srt_label)) } - - | HeapRep _ ptrs nonptrs closure_type <- smrep - = do { let layout = packIntsCLit dflags ptrs nonptrs - ; (prof_lits, prof_data) <- mkProfLits dflags prof - ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt - ; (mb_srt_field, mb_layout, extra_bits, ct_data) - <- mk_pieces closure_type srt_label - ; let std_info = mkStdInfoTable dflags prof_lits - (mb_rts_tag `orElse` rtsClosureType smrep) - (mb_srt_field `orElse` srt_bitmap) - (mb_layout `orElse` layout) - ; return (prof_data ++ ct_data, (std_info, extra_bits)) } - where - mk_pieces :: ClosureTypeInfo -> [CmmLit] - -> UniqSM ( Maybe StgHalfWord -- Override the SRT field with this - , Maybe CmmLit -- Override the layout field with this - , [CmmLit] -- "Extra bits" for info table - , [RawCmmDecl]) -- Auxiliary data decls - mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor - = do { (descr_lit, decl) <- newStringLit con_descr - ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag)) - , Nothing, [descr_lit], [decl]) } - - mk_pieces Thunk srt_label - = return (Nothing, Nothing, srt_label, []) - - mk_pieces (ThunkSelector offset) _no_srt - = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], []) - -- Layout known (one free var); we use the layout field for offset - - mk_pieces (Fun arity (ArgSpec fun_type)) srt_label - = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label - ; return (Nothing, Nothing, extra_bits, []) } - - mk_pieces (Fun arity (ArgGen arg_bits)) srt_label - = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits - ; let fun_type | null liveness_data = aRG_GEN - | otherwise = aRG_GEN_BIG - extra_bits = [ packIntsCLit dflags fun_type arity - , srt_lit, liveness_lit, slow_entry ] - ; return (Nothing, Nothing, extra_bits, liveness_data) } - where - slow_entry = CmmLabel (toSlowEntryLbl info_lbl) - srt_lit = case srt_label of - [] -> mkIntCLit dflags 0 - (lit:_rest) -> ASSERT( null _rest ) lit - - mk_pieces other _ = pprPanic "mk_pieces" (ppr other) - -mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier - -packIntsCLit :: DynFlags -> Int -> Int -> CmmLit -packIntsCLit dflags a b = packHalfWordsCLit dflags - (toStgHalfWord dflags (fromIntegral a)) - (toStgHalfWord dflags (fromIntegral b)) - - -mkSRTLit :: DynFlags - -> C_SRT - -> ([CmmLit], -- srt_label, if any - StgHalfWord) -- srt_bitmap -mkSRTLit dflags NoC_SRT = ([], toStgHalfWord dflags 0) -mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap) - - -------------------------------------------------------------------------- --- --- Lay out the info table and handle relative offsets --- -------------------------------------------------------------------------- - --- This function takes --- * the standard info table portion (StgInfoTable) --- * the "extra bits" (StgFunInfoExtraRev etc.) --- * the entry label --- * the code --- and lays them out in memory, producing a list of RawCmmDecl - -------------------------------------------------------------------------- --- --- Position independent code --- -------------------------------------------------------------------------- --- In order to support position independent code, we mustn't put absolute --- references into read-only space. Info tables in the tablesNextToCode --- case must be in .text, which is read-only, so we doctor the CmmLits --- to use relative offsets instead. - --- Note that this is done even when the -fPIC flag is not specified, --- as we want to keep binary compatibility between PIC and non-PIC. - -makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit - -makeRelativeRefTo dflags info_lbl (CmmLabel lbl) - | tablesNextToCode dflags - = CmmLabelDiffOff lbl info_lbl 0 -makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off) - | tablesNextToCode dflags - = CmmLabelDiffOff lbl info_lbl off -makeRelativeRefTo _ _ lit = lit - - -------------------------------------------------------------------------- --- --- Build a liveness mask for the stack layout --- -------------------------------------------------------------------------- - --- There are four kinds of things on the stack: --- --- - pointer variables (bound in the environment) --- - non-pointer variables (bound in the environment) --- - free slots (recorded in the stack free list) --- - non-pointer data slots (recorded in the stack free list) --- --- The first two are represented with a 'Just' of a 'LocalReg'. --- The last two with one or more 'Nothing' constructors. --- Each 'Nothing' represents one used word. --- --- The head of the stack layout is the top of the stack and --- the least-significant bit. - -mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl]) - -- ^ Returns: - -- 1. The bitmap (literal value or label) - -- 2. Large bitmap CmmData if needed - -mkLivenessBits dflags liveness - | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word - = do { uniq <- getUniqueM - ; let bitmap_lbl = mkBitmapLabel uniq - ; return (CmmLabel bitmap_lbl, - [mkRODataLits bitmap_lbl lits]) } - - | otherwise -- Fits in one word - = return (mkStgWordCLit dflags bitmap_word, []) - where - n_bits = length liveness - - bitmap :: Bitmap - bitmap = mkBitmap dflags liveness - - small_bitmap = case bitmap of - [] -> toStgWord dflags 0 - [b] -> b - _ -> panic "mkLiveness" - bitmap_word = toStgWord dflags (fromIntegral n_bits) - .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) - - lits = mkWordCLit dflags (fromIntegral n_bits) - : map (mkStgWordCLit dflags) bitmap - -- The first word is the size. The structure must match - -- StgLargeBitmap in includes/rts/storage/InfoTable.h - -------------------------------------------------------------------------- --- --- Generating a standard info table --- -------------------------------------------------------------------------- - --- The standard bits of an info table. This part of the info table --- corresponds to the StgInfoTable type defined in --- includes/rts/storage/InfoTables.h. --- --- Its shape varies with ticky/profiling/tables next to code etc --- so we can't use constant offsets from Constants - -mkStdInfoTable - :: DynFlags - -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) - -> Int -- Closure RTS tag - -> StgHalfWord -- SRT length - -> CmmLit -- layout field - -> [CmmLit] - -mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit - = -- Parallel revertible-black hole field - prof_info - -- Ticky info (none at present) - -- Debug info (none at present) - ++ [layout_lit, type_lit] - - where - prof_info - | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] - | otherwise = [] - - type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len - -------------------------------------------------------------------------- --- --- Making string literals --- -------------------------------------------------------------------------- - -mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl]) -mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), []) -mkProfLits _ (ProfilingInfo td cd) - = do { (td_lit, td_decl) <- newStringLit td - ; (cd_lit, cd_decl) <- newStringLit cd - ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } - -newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt) -newStringLit bytes - = do { uniq <- getUniqueM - ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) } - - --- Misc utils - --- | Value of the srt field of an info table when using an StgLargeSRT -srtEscape :: DynFlags -> StgHalfWord -srtEscape dflags = toStgHalfWord dflags (-1) - -------------------------------------------------------------------------- --- --- Accessing fields of an info table --- -------------------------------------------------------------------------- - -closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr --- Takes a closure pointer and returns the info table pointer -closureInfoPtr dflags e = CmmLoad e (bWord dflags) - -entryCode :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info pointer (the first word of a closure) --- and returns its entry code -entryCode dflags e - | tablesNextToCode dflags = e - | otherwise = CmmLoad e (bWord dflags) - -getConstrTag :: DynFlags -> CmmExpr -> CmmExpr --- Takes a closure pointer, and return the *zero-indexed* --- constructor tag obtained from the info table --- This lives in the SRT field of the info table --- (constructors don't need SRTs). -getConstrTag dflags closure_ptr - = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table] - where - info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) - -cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr --- Takes a closure pointer, and return the closure type --- obtained from the info table -cmmGetClosureType dflags closure_ptr - = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table] - where - info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) - -infoTable :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info pointer (the first word of a closure) --- and returns a pointer to the first word of the standard-form --- info table, excluding the entry-code word (if present) -infoTable dflags info_ptr - | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags) - | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer - -infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info table pointer (from infoTable) and returns the constr tag --- field of the info table (same as the srt_bitmap field) -infoTableConstrTag = infoTableSrtBitmap - -infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info table pointer (from infoTable) and returns the srt_bitmap --- field of the info table -infoTableSrtBitmap dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags) - -infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info table pointer (from infoTable) and returns the closure type --- field of the info table. -infoTableClosureType dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags) - -infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr -infoTablePtrs dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags) - -infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr -infoTableNonPtrs dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags) - -funInfoTable :: DynFlags -> CmmExpr -> CmmExpr --- Takes the info pointer of a function, --- and returns a pointer to the first word of the StgFunInfoExtra struct --- in the info table. -funInfoTable dflags info_ptr - | tablesNextToCode dflags - = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) - | otherwise - = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) - -- Past the entry code pointer - --- Takes the info pointer of a function, returns the function's arity -funInfoArity :: DynFlags -> CmmExpr -> CmmExpr -funInfoArity dflags iptr - = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes)) - where - fun_info = funInfoTable dflags iptr - rep = cmmBits (widthFromBytes rep_bytes) - - (rep_bytes, offset) - | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc - , oFFSET_StgFunInfoExtraRev_arity dflags ) - | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc - , oFFSET_StgFunInfoExtraFwd_arity dflags ) - - pc = sPlatformConstants (settings dflags) - ------------------------------------------------------------------------------ --- --- Info table sizes & offsets --- ------------------------------------------------------------------------------ - -stdInfoTableSizeW :: DynFlags -> WordOff --- The size of a standard info table varies with profiling/ticky etc, --- so we can't get it from Constants --- It must vary in sync with mkStdInfoTable -stdInfoTableSizeW dflags - = fixedInfoTableSizeW - + if gopt Opt_SccProfilingOn dflags - then profInfoTableSizeW - else 0 - -fixedInfoTableSizeW :: WordOff -fixedInfoTableSizeW = 2 -- layout, type - -profInfoTableSizeW :: WordOff -profInfoTableSizeW = 2 - -maxStdInfoTableSizeW :: WordOff -maxStdInfoTableSizeW = - 1 {- entry, when !tablesNextToCode -} - + fixedInfoTableSizeW - + profInfoTableSizeW - -maxRetInfoTableSizeW :: WordOff -maxRetInfoTableSizeW = - maxStdInfoTableSizeW - + 1 {- srt label -} - -stdInfoTableSizeB :: DynFlags -> ByteOff -stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags - -stdSrtBitmapOffset :: DynFlags -> ByteOff --- Byte offset of the SRT bitmap half-word which is --- in the *higher-addressed* part of the type_lit -stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags - -stdClosureTypeOffset :: DynFlags -> ByteOff --- Byte offset of the closure type half-word -stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags - -stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff -stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags - -conInfoTableSizeB :: DynFlags -> Int -conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags diff --git a/cmm/CmmLayoutStack.hs b/cmm/CmmLayoutStack.hs deleted file mode 100644 --- a/cmm/CmmLayoutStack.hs +++ /dev/null @@ -1,1146 +0,0 @@ -{-# LANGUAGE CPP, RecordWildCards, GADTs #-} -module CmmLayoutStack ( - cmmLayoutStack, setInfoTableStackMap - ) where - -import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX layering violation -import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX layering violation - -import BasicTypes -import Cmm -import CmmInfo -import BlockId -import CLabel -import CmmUtils -import MkGraph -import ForeignCall -import CmmLive -import CmmProcPoint -import SMRep -import Hoopl -import UniqSupply -import StgCmmUtils ( newTemp ) -import Maybes -import UniqFM -import Util - -import DynFlags -import FastString -import Outputable hiding ( isEmpty ) -import qualified Data.Set as Set -import Control.Monad.Fix -import Data.Array as Array -import Data.Bits -import Data.List (nub) - -import Prelude hiding ((<*>)) - -#include "HsVersions.h" - -{- Note [Stack Layout] - -The job of this pass is to - - - replace references to abstract stack Areas with fixed offsets from Sp. - - - replace the CmmHighStackMark constant used in the stack check with - the maximum stack usage of the proc. - - - save any variables that are live across a call, and reload them as - necessary. - -Before stack allocation, local variables remain live across native -calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local -variables are clobbered by native calls. - -We want to do stack allocation so that as far as possible - - stack use is minimized, and - - unnecessary stack saves and loads are avoided. - -The algorithm we use is a variant of linear-scan register allocation, -where the stack is our register file. - - - First, we do a liveness analysis, which annotates every block with - the variables live on entry to the block. - - - We traverse blocks in reverse postorder DFS; that is, we visit at - least one predecessor of a block before the block itself. The - stack layout flowing from the predecessor of the block will - determine the stack layout on entry to the block. - - - We maintain a data structure - - Map Label StackMap - - which describes the contents of the stack and the stack pointer on - entry to each block that is a successor of a block that we have - visited. - - - For each block we visit: - - - Look up the StackMap for this block. - - - If this block is a proc point (or a call continuation, if we - aren't splitting proc points), emit instructions to reload all - the live variables from the stack, according to the StackMap. - - - Walk forwards through the instructions: - - At an assignment x = Sp[loc] - - Record the fact that Sp[loc] contains x, so that we won't - need to save x if it ever needs to be spilled. - - At an assignment x = E - - If x was previously on the stack, it isn't any more - - At the last node, if it is a call or a jump to a proc point - - Lay out the stack frame for the call (see setupStackFrame) - - emit instructions to save all the live variables - - Remember the StackMaps for all the successors - - emit an instruction to adjust Sp - - If the last node is a branch, then the current StackMap is the - StackMap for the successors. - - - Manifest Sp: replace references to stack areas in this block - with real Sp offsets. We cannot do this until we have laid out - the stack area for the successors above. - - In this phase we also eliminate redundant stores to the stack; - see elimStackStores. - - - There is one important gotcha: sometimes we'll encounter a control - transfer to a block that we've already processed (a join point), - and in that case we might need to rearrange the stack to match - what the block is expecting. (exactly the same as in linear-scan - register allocation, except here we have the luxury of an infinite - supply of temporary variables). - - - Finally, we update the magic CmmHighStackMark constant with the - stack usage of the function, and eliminate the whole stack check - if there was no stack use. (in fact this is done as part of the - main traversal, by feeding the high-water-mark output back in as - an input. I hate cyclic programming, but it's just too convenient - sometimes.) - -There are plenty of tricky details: update frames, proc points, return -addresses, foreign calls, and some ad-hoc optimisations that are -convenient to do here and effective in common cases. Comments in the -code below explain these. - --} - - --- All stack locations are expressed as positive byte offsets from the --- "base", which is defined to be the address above the return address --- on the stack on entry to this CmmProc. --- --- Lower addresses have higher StackLocs. --- -type StackLoc = ByteOff - -{- - A StackMap describes the stack at any given point. At a continuation - it has a particular layout, like this: - - | | <- base - |-------------| - | ret0 | <- base + 8 - |-------------| - . upd frame . <- base + sm_ret_off - |-------------| - | | - . vars . - . (live/dead) . - | | <- base + sm_sp - sm_args - |-------------| - | ret1 | - . ret vals . <- base + sm_sp (<--- Sp points here) - |-------------| - -Why do we include the final return address (ret0) in our stack map? I -have absolutely no idea, but it seems to be done that way consistently -in the rest of the code generator, so I played along here. --SDM - -Note that we will be constructing an info table for the continuation -(ret1), which needs to describe the stack down to, but not including, -the update frame (or ret0, if there is no update frame). --} - -data StackMap = StackMap - { sm_sp :: StackLoc - -- ^ the offset of Sp relative to the base on entry - -- to this block. - , sm_args :: ByteOff - -- ^ the number of bytes of arguments in the area for this block - -- Defn: the offset of young(L) relative to the base is given by - -- (sm_sp - sm_args) of the StackMap for block L. - , sm_ret_off :: ByteOff - -- ^ Number of words of stack that we do not describe with an info - -- table, because it contains an update frame. - , sm_regs :: UniqFM (LocalReg,StackLoc) - -- ^ regs on the stack - } - -instance Outputable StackMap where - ppr StackMap{..} = - text "Sp = " <> int sm_sp $$ - text "sm_args = " <> int sm_args $$ - text "sm_ret_off = " <> int sm_ret_off $$ - text "sm_regs = " <> pprUFM sm_regs ppr - - -cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph - -> UniqSM (CmmGraph, LabelMap StackMap) -cmmLayoutStack dflags procpoints entry_args - graph@(CmmGraph { g_entry = entry }) - = do - -- We need liveness info. Dead assignments are removed later - -- by the sinking pass. - let liveness = cmmLocalLiveness dflags graph - blocks = postorderDfs graph - - (final_stackmaps, _final_high_sp, new_blocks) <- - mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) -> - layout dflags procpoints liveness entry entry_args - rec_stackmaps rec_high_sp blocks - - new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks - return (ofBlockList entry new_blocks', final_stackmaps) - - -layout :: DynFlags - -> LabelSet -- proc points - -> LabelMap CmmLocalLive -- liveness - -> BlockId -- entry - -> ByteOff -- stack args on entry - - -> LabelMap StackMap -- [final] stack maps - -> ByteOff -- [final] Sp high water mark - - -> [CmmBlock] -- [in] blocks - - -> UniqSM - ( LabelMap StackMap -- [out] stack maps - , ByteOff -- [out] Sp high water mark - , [CmmBlock] -- [out] new blocks - ) - -layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks - = go blocks init_stackmap entry_args [] - where - (updfr, cont_info) = collectContInfo blocks - - init_stackmap = mapSingleton entry StackMap{ sm_sp = entry_args - , sm_args = entry_args - , sm_ret_off = updfr - , sm_regs = emptyUFM - } - - go [] acc_stackmaps acc_hwm acc_blocks - = return (acc_stackmaps, acc_hwm, acc_blocks) - - go (b0 : bs) acc_stackmaps acc_hwm acc_blocks - = do - let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0 - - let stack0@StackMap { sm_sp = sp0 } - = mapFindWithDefault - (pprPanic "no stack map for" (ppr entry_lbl)) - entry_lbl acc_stackmaps - - -- (a) Update the stack map to include the effects of - -- assignments in this block - let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0 - - -- (b) Insert assignments to reload all the live variables if this - -- block is a proc point - let middle1 = if entry_lbl `setMember` procpoints - then foldr blockCons middle0 (insertReloads stack0) - else middle0 - - -- (c) Look at the last node and if we are making a call or - -- jumping to a proc point, we must save the live - -- variables, adjust Sp, and construct the StackMaps for - -- each of the successor blocks. See handleLastNode for - -- details. - (middle2, sp_off, last1, fixup_blocks, out) - <- handleLastNode dflags procpoints liveness cont_info - acc_stackmaps stack1 tscope middle0 last0 - - -- (d) Manifest Sp: run over the nodes in the block and replace - -- CmmStackSlot with CmmLoad from Sp with a concrete offset. - -- - -- our block: - -- middle1 -- the original middle nodes - -- middle2 -- live variable saves from handleLastNode - -- Sp = Sp + sp_off -- Sp adjustment goes here - -- last1 -- the last node - -- - let middle_pre = blockToList $ foldl blockSnoc middle1 middle2 - - let final_blocks = - manifestSp dflags final_stackmaps stack0 sp0 final_sp_high - entry0 middle_pre sp_off last1 fixup_blocks - - let acc_stackmaps' = mapUnion acc_stackmaps out - - -- If this block jumps to the GC, then we do not take its - -- stack usage into account for the high-water mark. - -- Otherwise, if the only stack usage is in the stack-check - -- failure block itself, we will do a redundant stack - -- check. The stack has a buffer designed to accommodate - -- the largest amount of stack needed for calling the GC. - -- - this_sp_hwm | isGcJump last0 = 0 - | otherwise = sp0 - sp_off - - hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out)) - - go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks) - - --- ----------------------------------------------------------------------------- - --- Not foolproof, but GCFun is the culprit we most want to catch -isGcJump :: CmmNode O C -> Bool -isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) }) - = l == GCFun || l == GCEnter1 -isGcJump _something_else = False - --- ----------------------------------------------------------------------------- - --- This doesn't seem right somehow. We need to find out whether this --- proc will push some update frame material at some point, so that we --- can avoid using that area of the stack for spilling. The --- updfr_space field of the CmmProc *should* tell us, but it doesn't --- (I think maybe it gets filled in later when we do proc-point --- splitting). --- --- So we'll just take the max of all the cml_ret_offs. This could be --- unnecessarily pessimistic, but probably not in the code we --- generate. - -collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff) -collectContInfo blocks - = (maximum ret_offs, mapFromList (catMaybes mb_argss)) - where - (mb_argss, ret_offs) = mapAndUnzip get_cont blocks - - get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff) - get_cont b = - case lastNode b of - CmmCall { cml_cont = Just l, .. } - -> (Just (l, cml_ret_args), cml_ret_off) - CmmForeignCall { .. } - -> (Just (succ, ret_args), ret_off) - _other -> (Nothing, 0) - - --- ----------------------------------------------------------------------------- --- Updating the StackMap from middle nodes - --- Look for loads from stack slots, and update the StackMap. This is --- purely for optimisation reasons, so that we can avoid saving a --- variable back to a different stack slot if it is already on the --- stack. --- --- This happens a lot: for example when function arguments are passed --- on the stack and need to be immediately saved across a call, we --- want to just leave them where they are on the stack. --- -procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap -procMiddle stackmaps node sm - = case node of - CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _) - -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) } - where loc = getStackLoc area off stackmaps - CmmAssign (CmmLocal r) _other - -> sm { sm_regs = delFromUFM (sm_regs sm) r } - _other - -> sm - -getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc -getStackLoc Old n _ = n -getStackLoc (Young l) n stackmaps = - case mapLookup l stackmaps of - Nothing -> pprPanic "getStackLoc" (ppr l) - Just sm -> sm_sp sm - sm_args sm + n - - --- ----------------------------------------------------------------------------- --- Handling stack allocation for a last node - --- We take a single last node and turn it into: --- --- C1 (some statements) --- Sp = Sp + N --- C2 (some more statements) --- call f() -- the actual last node --- --- plus possibly some more blocks (we may have to add some fixup code --- between the last node and the continuation). --- --- C1: is the code for saving the variables across this last node onto --- the stack, if the continuation is a call or jumps to a proc point. --- --- C2: if the last node is a safe foreign call, we have to inject some --- extra code that goes *after* the Sp adjustment. - -handleLastNode - :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff - -> LabelMap StackMap -> StackMap -> CmmTickScope - -> Block CmmNode O O - -> CmmNode O C - -> UniqSM - ( [CmmNode O O] -- nodes to go *before* the Sp adjustment - , ByteOff -- amount to adjust Sp - , CmmNode O C -- new last node - , [CmmBlock] -- new blocks - , LabelMap StackMap -- stackmaps for the continuations - ) - -handleLastNode dflags procpoints liveness cont_info stackmaps - stack0@StackMap { sm_sp = sp0 } tscp middle last - = case last of - -- At each return / tail call, - -- adjust Sp to point to the last argument pushed, which - -- is cml_args, after popping any other junk from the stack. - CmmCall{ cml_cont = Nothing, .. } -> do - let sp_off = sp0 - cml_args - return ([], sp_off, last, [], mapEmpty) - - -- At each CmmCall with a continuation: - CmmCall{ cml_cont = Just cont_lbl, .. } -> - return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off - - CmmForeignCall{ succ = cont_lbl, .. } -> do - return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off - -- one word of args: the return address - - CmmBranch {} -> handleBranches - CmmCondBranch {} -> handleBranches - CmmSwitch {} -> handleBranches - - where - -- Calls and ForeignCalls are handled the same way: - lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff - -> ( [CmmNode O O] - , ByteOff - , CmmNode O C - , [CmmBlock] - , LabelMap StackMap - ) - lastCall lbl cml_args cml_ret_args cml_ret_off - = ( assignments - , spOffsetForCall sp0 cont_stack cml_args - , last - , [] -- no new blocks - , mapSingleton lbl cont_stack ) - where - (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off - - - prepareStack lbl cml_ret_args cml_ret_off - | Just cont_stack <- mapLookup lbl stackmaps - -- If we have already seen this continuation before, then - -- we just have to make the stack look the same: - = (fixupStack stack0 cont_stack, cont_stack) - -- Otherwise, we have to allocate the stack frame - | otherwise - = (save_assignments, new_cont_stack) - where - (new_cont_stack, save_assignments) - = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0 - - - -- For other last nodes (branches), if any of the targets is a - -- proc point, we have to set up the stack to match what the proc - -- point is expecting. - -- - handleBranches :: UniqSM ( [CmmNode O O] - , ByteOff - , CmmNode O C - , [CmmBlock] - , LabelMap StackMap ) - - handleBranches - -- Note [diamond proc point] - | Just l <- futureContinuation middle - , (nub $ filter (`setMember` procpoints) $ successors last) == [l] - = do - let cont_args = mapFindWithDefault 0 l cont_info - (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0) - out = mapFromList [ (l', cont_stack) - | l' <- successors last ] - return ( assigs - , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags) - , last - , [] - , out) - - | otherwise = do - pps <- mapM handleBranch (successors last) - let lbl_map :: LabelMap Label - lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ] - fix_lbl l = mapFindWithDefault l l lbl_map - return ( [] - , 0 - , mapSuccessors fix_lbl last - , concat [ blk | (_,_,_,blk) <- pps ] - , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] ) - - -- For each successor of this block - handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock]) - handleBranch l - -- (a) if the successor already has a stackmap, we need to - -- shuffle the current stack to make it look the same. - -- We have to insert a new block to make this happen. - | Just stack2 <- mapLookup l stackmaps - = do - let assigs = fixupStack stack0 stack2 - (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs - return (l, tmp_lbl, stack2, block) - - -- (b) if the successor is a proc point, save everything - -- on the stack. - | l `setMember` procpoints - = do - let cont_args = mapFindWithDefault 0 l cont_info - (stack2, assigs) = - setupStackFrame dflags l liveness (sm_ret_off stack0) - cont_args stack0 - (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs - return (l, tmp_lbl, stack2, block) - - -- (c) otherwise, the current StackMap is the StackMap for - -- the continuation. But we must remember to remove any - -- variables from the StackMap that are *not* live at - -- the destination, because this StackMap might be used - -- by fixupStack if this is a join point. - | otherwise = return (l, l, stack1, []) - where live = mapFindWithDefault (panic "handleBranch") l liveness - stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) } - is_live (r,_) = r `elemRegSet` live - - -makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap - -> CmmTickScope -> [CmmNode O O] - -> UniqSM (Label, [CmmBlock]) -makeFixupBlock dflags sp0 l stack tscope assigs - | null assigs && sp0 == sm_sp stack = return (l, []) - | otherwise = do - tmp_lbl <- newBlockId - let sp_off = sp0 - sm_sp stack - maybeAddUnwind block - | debugLevel dflags > 0 - = block `blockSnoc` CmmUnwind [(Sp, Just unwind_val)] - | otherwise - = block - where unwind_val = cmmOffset dflags (CmmReg spReg) (sm_sp stack) - block = blockJoin (CmmEntry tmp_lbl tscope) - ( maybeAddSpAdj dflags sp_off - $ maybeAddUnwind - $ blockFromList assigs ) - (CmmBranch l) - return (tmp_lbl, [block]) - - --- Sp is currently pointing to current_sp, --- we want it to point to --- (sm_sp cont_stack - sm_args cont_stack + args) --- so the difference is --- sp0 - (sm_sp cont_stack - sm_args cont_stack + args) -spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff -spOffsetForCall current_sp cont_stack args - = current_sp - (sm_sp cont_stack - sm_args cont_stack + args) - - --- | create a sequence of assignments to establish the new StackMap, --- given the old StackMap. -fixupStack :: StackMap -> StackMap -> [CmmNode O O] -fixupStack old_stack new_stack = concatMap move new_locs - where - old_map = sm_regs old_stack - new_locs = stackSlotRegs new_stack - - move (r,n) - | Just (_,m) <- lookupUFM old_map r, n == m = [] - | otherwise = [CmmStore (CmmStackSlot Old n) - (CmmReg (CmmLocal r))] - - - -setupStackFrame - :: DynFlags - -> BlockId -- label of continuation - -> LabelMap CmmLocalLive -- liveness - -> ByteOff -- updfr - -> ByteOff -- bytes of return values on stack - -> StackMap -- current StackMap - -> (StackMap, [CmmNode O O]) - -setupStackFrame dflags lbl liveness updfr_off ret_args stack0 - = (cont_stack, assignments) - where - -- get the set of LocalRegs live in the continuation - live = mapFindWithDefault Set.empty lbl liveness - - -- the stack from the base to updfr_off is off-limits. - -- our new stack frame contains: - -- * saved live variables - -- * the return address [young(C) + 8] - -- * the args for the call, - -- which are replaced by the return values at the return - -- point. - - -- everything up to updfr_off is off-limits - -- stack1 contains updfr_off, plus everything we need to save - (stack1, assignments) = allocate dflags updfr_off live stack0 - - -- And the Sp at the continuation is: - -- sm_sp stack1 + ret_args - cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args - , sm_args = ret_args - , sm_ret_off = updfr_off - } - - --- ----------------------------------------------------------------------------- --- Note [diamond proc point] --- --- This special case looks for the pattern we get from a typical --- tagged case expression: --- --- Sp[young(L1)] = L1 --- if (R1 & 7) != 0 goto L1 else goto L2 --- L2: --- call [R1] returns to L1 --- L1: live: {y} --- x = R1 --- --- If we let the generic case handle this, we get --- --- Sp[-16] = L1 --- if (R1 & 7) != 0 goto L1a else goto L2 --- L2: --- Sp[-8] = y --- Sp = Sp - 16 --- call [R1] returns to L1 --- L1a: --- Sp[-8] = y --- Sp = Sp - 16 --- goto L1 --- L1: --- x = R1 --- --- The code for saving the live vars is duplicated in each branch, and --- furthermore there is an extra jump in the fast path (assuming L1 is --- a proc point, which it probably is if there is a heap check). --- --- So to fix this we want to set up the stack frame before the --- conditional jump. How do we know when to do this, and when it is --- safe? The basic idea is, when we see the assignment --- --- Sp[young(L)] = L --- --- we know that --- * we are definitely heading for L --- * there can be no more reads from another stack area, because young(L) --- overlaps with it. --- --- We don't necessarily know that everything live at L is live now --- (some might be assigned between here and the jump to L). So we --- simplify and only do the optimisation when we see --- --- (1) a block containing an assignment of a return address L --- (2) ending in a branch where one (and only) continuation goes to L, --- and no other continuations go to proc points. --- --- then we allocate the stack frame for L at the end of the block, --- before the branch. --- --- We could generalise (2), but that would make it a bit more --- complicated to handle, and this currently catches the common case. - -futureContinuation :: Block CmmNode O O -> Maybe BlockId -futureContinuation middle = foldBlockNodesB f middle Nothing - where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId - f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _ - = Just l - f _ r = r - --- ----------------------------------------------------------------------------- --- Saving live registers - --- | Given a set of live registers and a StackMap, save all the registers --- on the stack and return the new StackMap and the assignments to do --- the saving. --- -allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap - -> (StackMap, [CmmNode O O]) -allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0 - , sm_regs = regs0 } - = - -- we only have to save regs that are not already in a slot - let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live) - regs1 = filterUFM (\(r,_) -> elemRegSet r live) regs0 - in - - -- make a map of the stack - let stack = reverse $ Array.elems $ - accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $ - ret_words ++ live_words - where ret_words = - [ (x, Occupied) - | x <- [ 1 .. toWords dflags ret_off] ] - live_words = - [ (toWords dflags x, Occupied) - | (r,off) <- nonDetEltsUFM regs1, - -- See Note [Unique Determinism and code generation] - let w = localRegBytes dflags r, - x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ] - in - - -- Pass over the stack: find slots to save all the new live variables, - -- choosing the oldest slots first (hence a foldr). - let - save slot ([], stack, n, assigs, regs) -- no more regs to save - = ([], slot:stack, plusW dflags n 1, assigs, regs) - save slot (to_save, stack, n, assigs, regs) - = case slot of - Occupied -> (to_save, Occupied:stack, plusW dflags n 1, assigs, regs) - Empty - | Just (stack', r, to_save') <- - select_save to_save (slot:stack) - -> let assig = CmmStore (CmmStackSlot Old n') - (CmmReg (CmmLocal r)) - n' = plusW dflags n 1 - in - (to_save', stack', n', assig : assigs, (r,(r,n')):regs) - - | otherwise - -> (to_save, slot:stack, plusW dflags n 1, assigs, regs) - - -- we should do better here: right now we'll fit the smallest first, - -- but it would make more sense to fit the biggest first. - select_save :: [LocalReg] -> [StackSlot] - -> Maybe ([StackSlot], LocalReg, [LocalReg]) - select_save regs stack = go regs [] - where go [] _no_fit = Nothing - go (r:rs) no_fit - | Just rest <- dropEmpty words stack - = Just (replicate words Occupied ++ rest, r, rs++no_fit) - | otherwise - = go rs (r:no_fit) - where words = localRegWords dflags r - - -- fill in empty slots as much as possible - (still_to_save, save_stack, n, save_assigs, save_regs) - = foldr save (to_save, [], 0, [], []) stack - - -- push any remaining live vars on the stack - (push_sp, push_assigs, push_regs) - = foldr push (n, [], []) still_to_save - where - push r (n, assigs, regs) - = (n', assig : assigs, (r,(r,n')) : regs) - where - n' = n + localRegBytes dflags r - assig = CmmStore (CmmStackSlot Old n') - (CmmReg (CmmLocal r)) - - trim_sp - | not (null push_regs) = push_sp - | otherwise - = plusW dflags n (- length (takeWhile isEmpty save_stack)) - - final_regs = regs1 `addListToUFM` push_regs - `addListToUFM` save_regs - - in - -- XXX should be an assert - if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else - - if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else - - ( stackmap { sm_regs = final_regs , sm_sp = trim_sp } - , push_assigs ++ save_assigs ) - - --- ----------------------------------------------------------------------------- --- Manifesting Sp - --- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp. The --- block looks like this: --- --- middle_pre -- the middle nodes --- Sp = Sp + sp_off -- Sp adjustment goes here --- last -- the last node --- --- And we have some extra blocks too (that don't contain Sp adjustments) --- --- The adjustment for middle_pre will be different from that for --- middle_post, because the Sp adjustment intervenes. --- -manifestSp - :: DynFlags - -> LabelMap StackMap -- StackMaps for other blocks - -> StackMap -- StackMap for this block - -> ByteOff -- Sp on entry to the block - -> ByteOff -- SpHigh - -> CmmNode C O -- first node - -> [CmmNode O O] -- middle - -> ByteOff -- sp_off - -> CmmNode O C -- last node - -> [CmmBlock] -- new blocks - -> [CmmBlock] -- final blocks with Sp manifest - -manifestSp dflags stackmaps stack0 sp0 sp_high - first middle_pre sp_off last fixup_blocks - = final_block : fixup_blocks' - where - area_off = getAreaOff stackmaps - - adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x - adj_pre_sp = mapExpDeep (areaToSp dflags sp0 sp_high area_off) - adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off) - - -- Add unwind pseudo-instruction at the beginning of each block to - -- document Sp level for debugging - add_initial_unwind block - | debugLevel dflags > 0 - = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block - | otherwise - = block - where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags) - - -- Add unwind pseudo-instruction right before the Sp adjustment - -- if there is one. - add_adj_unwind block - | debugLevel dflags > 0 - , sp_off /= 0 - = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)] - | otherwise - = block - where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off) - - final_middle = maybeAddSpAdj dflags sp_off - . add_adj_unwind - . add_initial_unwind - . blockFromList - . map adj_pre_sp - . elimStackStores stack0 stackmaps area_off - $ middle_pre - final_last = optStackCheck (adj_post_sp last) - - final_block = blockJoin first final_middle final_last - - fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks - - -getAreaOff :: LabelMap StackMap -> (Area -> StackLoc) -getAreaOff _ Old = 0 -getAreaOff stackmaps (Young l) = - case mapLookup l stackmaps of - Just sm -> sm_sp sm - sm_args sm - Nothing -> pprPanic "getAreaOff" (ppr l) - - -maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O -maybeAddSpAdj _ 0 block = block -maybeAddSpAdj dflags sp_off block = block `blockSnoc` adj - where - adj = CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off) - -{- -Sp(L) is the Sp offset on entry to block L relative to the base of the -OLD area. - -SpArgs(L) is the size of the young area for L, i.e. the number of -arguments. - - - in block L, each reference to [old + N] turns into - [Sp + Sp(L) - N] - - - in block L, each reference to [young(L') + N] turns into - [Sp + Sp(L) - Sp(L') + SpArgs(L') - N] - - - be careful with the last node of each block: Sp has already been adjusted - to be Sp + Sp(L) - Sp(L') --} - -areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr - -areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n) - = cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n) - -- Replace (CmmStackSlot area n) with an offset from Sp - -areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark) - = mkIntExpr dflags sp_hwm - -- Replace CmmHighStackMark with the number of bytes of stack used, - -- the sp_hwm. See Note [Stack usage] in StgCmmHeap - -areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args) - | falseStackCheck args - = zeroExpr dflags -areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args) - | falseStackCheck args - = mkIntExpr dflags 1 - -- Replace a stack-overflow test that cannot fail with a no-op - -- See Note [Always false stack check] - -areaToSp _ _ _ _ other = other - --- | Determine whether a stack check cannot fail. -falseStackCheck :: [CmmExpr] -> Bool -falseStackCheck [ CmmMachOp (MO_Sub _) - [ CmmRegOff (CmmGlobal Sp) x_off - , CmmLit (CmmInt y_lit _)] - , CmmReg (CmmGlobal SpLim)] - = fromIntegral x_off >= y_lit -falseStackCheck _ = False - --- Note [Always false stack check] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- We can optimise stack checks of the form --- --- if ((Sp + x) - y < SpLim) then .. else .. --- --- where are non-negative integer byte offsets. Since we know that --- SpLim <= Sp (remember the stack grows downwards), this test must --- yield False if (x >= y), so we can rewrite the comparison to False. --- A subsequent sinking pass will later drop the dead code. --- Optimising this away depends on knowing that SpLim <= Sp, so it is --- really the job of the stack layout algorithm, hence we do it now. --- --- The control flow optimiser may negate a conditional to increase --- the likelihood of a fallthrough if the branch is not taken. But --- not every conditional is inverted as the control flow optimiser --- places some requirements on the predecessors of both branch targets. --- So we better look for the inverted comparison too. - -optStackCheck :: CmmNode O C -> CmmNode O C -optStackCheck n = -- Note [Always false stack check] - case n of - CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false - CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true - other -> other - - --- ----------------------------------------------------------------------------- - --- | Eliminate stores of the form --- --- Sp[area+n] = r --- --- when we know that r is already in the same slot as Sp[area+n]. We --- could do this in a later optimisation pass, but that would involve --- a separate analysis and we already have the information to hand --- here. It helps clean up some extra stack stores in common cases. --- --- Note that we may have to modify the StackMap as we walk through the --- code using procMiddle, since an assignment to a variable in the --- StackMap will invalidate its mapping there. --- -elimStackStores :: StackMap - -> LabelMap StackMap - -> (Area -> ByteOff) - -> [CmmNode O O] - -> [CmmNode O O] -elimStackStores stackmap stackmaps area_off nodes - = go stackmap nodes - where - go _stackmap [] = [] - go stackmap (n:ns) - = case n of - CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r)) - | Just (_,off) <- lookupUFM (sm_regs stackmap) r - , area_off area + m == off - -> go stackmap ns - _otherwise - -> n : go (procMiddle stackmaps n stackmap) ns - - --- ----------------------------------------------------------------------------- --- Update info tables to include stack liveness - - -setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl -setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g) - = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g - where - fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } = - info_tbl { cit_rep = StackRep (get_liveness lbl) } - fix_info _ other = other - - get_liveness :: BlockId -> Liveness - get_liveness lbl - = case mapLookup lbl stackmaps of - Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls) - Just sm -> stackMapToLiveness dflags sm - -setInfoTableStackMap _ _ d = d - - -stackMapToLiveness :: DynFlags -> StackMap -> Liveness -stackMapToLiveness dflags StackMap{..} = - reverse $ Array.elems $ - accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1, - toWords dflags (sm_sp - sm_args)) live_words - where - live_words = [ (toWords dflags off, False) - | (r,off) <- nonDetEltsUFM sm_regs - , isGcPtrType (localRegType r) ] - -- See Note [Unique Determinism and code generation] - - --- ----------------------------------------------------------------------------- --- Lowering safe foreign calls - -{- -Note [Lower safe foreign calls] - -We start with - - Sp[young(L1)] = L1 - ,----------------------- - | r1 = foo(x,y,z) returns to L1 - '----------------------- - L1: - R1 = r1 -- copyIn, inserted by mkSafeCall - ... - -the stack layout algorithm will arrange to save and reload everything -live across the call. Our job now is to expand the call so we get - - Sp[young(L1)] = L1 - ,----------------------- - | SAVE_THREAD_STATE() - | token = suspendThread(BaseReg, interruptible) - | r = foo(x,y,z) - | BaseReg = resumeThread(token) - | LOAD_THREAD_STATE() - | R1 = r -- copyOut - | jump Sp[0] - '----------------------- - L1: - r = R1 -- copyIn, inserted by mkSafeCall - ... - -Note the copyOut, which saves the results in the places that L1 is -expecting them (see Note [safe foreign call convention]). Note also -that safe foreign call is replace by an unsafe one in the Cmm graph. --} - -lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock -lowerSafeForeignCall dflags block - | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block - = do - -- Both 'id' and 'new_base' are KindNonPtr because they're - -- RTS-only objects and are not subject to garbage collection - id <- newTemp (bWord dflags) - new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg)) - let (caller_save, caller_load) = callerSaveVolatileRegs dflags - save_state_code <- saveThreadState dflags - load_state_code <- loadThreadState dflags - let suspend = save_state_code <*> - caller_save <*> - mkMiddle (callSuspendThread dflags id intrbl) - midCall = mkUnsafeCall tgt res args - resume = mkMiddle (callResumeThread new_base id) <*> - -- Assign the result to BaseReg: we - -- might now have a different Capability! - mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*> - caller_load <*> - load_state_code - - (_, regs, copyout) = - copyOutOflow dflags NativeReturn Jump (Young succ) - (map (CmmReg . CmmLocal) res) - ret_off [] - - -- NB. after resumeThread returns, the top-of-stack probably contains - -- the stack frame for succ, but it might not: if the current thread - -- received an exception during the call, then the stack might be - -- different. Hence we continue by jumping to the top stack frame, - -- not by jumping to succ. - jump = CmmCall { cml_target = entryCode dflags $ - CmmLoad (CmmReg spReg) (bWord dflags) - , cml_cont = Just succ - , cml_args_regs = regs - , cml_args = widthInBytes (wordWidth dflags) - , cml_ret_args = ret_args - , cml_ret_off = ret_off } - - graph' <- lgraphOfAGraph ( suspend <*> - midCall <*> - resume <*> - copyout <*> - mkLast jump, tscp) - - case toBlockList graph' of - [one] -> let (_, middle', last) = blockSplit one - in return (blockJoin entry (middle `blockAppend` middle') last) - _ -> panic "lowerSafeForeignCall0" - - -- Block doesn't end in a safe foreign call: - | otherwise = return block - - -foreignLbl :: FastString -> CmmExpr -foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction)) - -callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O -callSuspendThread dflags id intrbl = - CmmUnsafeForeignCall - (ForeignTarget (foreignLbl (fsLit "suspendThread")) - (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn)) - [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)] - -callResumeThread :: LocalReg -> LocalReg -> CmmNode O O -callResumeThread new_base id = - CmmUnsafeForeignCall - (ForeignTarget (foreignLbl (fsLit "resumeThread")) - (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn)) - [new_base] [CmmReg (CmmLocal id)] - --- ----------------------------------------------------------------------------- - -plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff -plusW dflags b w = b + w * wORD_SIZE dflags - -data StackSlot = Occupied | Empty - -- Occupied: a return address or part of an update frame - -instance Outputable StackSlot where - ppr Occupied = text "XXX" - ppr Empty = text "---" - -dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot] -dropEmpty 0 ss = Just ss -dropEmpty n (Empty : ss) = dropEmpty (n-1) ss -dropEmpty _ _ = Nothing - -isEmpty :: StackSlot -> Bool -isEmpty Empty = True -isEmpty _ = False - -localRegBytes :: DynFlags -> LocalReg -> ByteOff -localRegBytes dflags r - = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r))) - -localRegWords :: DynFlags -> LocalReg -> WordOff -localRegWords dflags = toWords dflags . localRegBytes dflags - -toWords :: DynFlags -> ByteOff -> WordOff -toWords dflags x = x `quot` wORD_SIZE dflags - - -insertReloads :: StackMap -> [CmmNode O O] -insertReloads stackmap = - [ CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot Old sp) - (localRegType r)) - | (r,sp) <- stackSlotRegs stackmap - ] - - -stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)] -stackSlotRegs sm = nonDetEltsUFM (sm_regs sm) - -- See Note [Unique Determinism and code generation] diff --git a/cmm/CmmLex.x b/cmm/CmmLex.x deleted file mode 100644 --- a/cmm/CmmLex.x +++ /dev/null @@ -1,363 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow, 2004-2006 --- --- Lexer for concrete Cmm. We try to stay close to the C-- spec, but there --- are a few minor differences: --- --- * extra keywords for our macros, and float32/float64 types --- * global registers (Sp,Hp, etc.) --- ------------------------------------------------------------------------------ - -{ --- See Note [Warnings in code generated by Alex] in compiler/parser/Lexer.x -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -module CmmLex ( - CmmToken(..), cmmlex, - ) where - -import CmmExpr - -import Lexer -import CmmMonad -import SrcLoc -import UniqFM -import StringBuffer -import FastString -import Ctype -import Util ---import TRACE - -import Data.Word -import Data.Char -} - -$whitechar = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space -$white_no_nl = $whitechar # \n - -$ascdigit = 0-9 -$unidigit = \x01 -- Trick Alex into handling Unicode. See alexGetChar. -$digit = [$ascdigit $unidigit] -$octit = 0-7 -$hexit = [$digit A-F a-f] - -$unilarge = \x03 -- Trick Alex into handling Unicode. See alexGetChar. -$asclarge = [A-Z \xc0-\xd6 \xd8-\xde] -$large = [$asclarge $unilarge] - -$unismall = \x04 -- Trick Alex into handling Unicode. See alexGetChar. -$ascsmall = [a-z \xdf-\xf6 \xf8-\xff] -$small = [$ascsmall $unismall \_] - -$namebegin = [$large $small \. \$ \@] -$namechar = [$namebegin $digit] - -@decimal = $digit+ -@octal = $octit+ -@hexadecimal = $hexit+ -@exponent = [eE] [\-\+]? @decimal - -@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent - -@escape = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3}) -@strchar = ($printable # [\"\\]) | @escape - -cmm :- - -$white_no_nl+ ; -^\# pragma .* \n ; -- Apple GCC 3.3 CPP generates pragmas in its output - -^\# (line)? { begin line_prag } - --- single-line line pragmas, of the form --- # "" \n - $digit+ { setLine line_prag1 } - \" [^\"]* \" { setFile line_prag2 } - .* { pop } - -<0> { - \n ; - - [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char } - - ".." { kw CmmT_DotDot } - "::" { kw CmmT_DoubleColon } - ">>" { kw CmmT_Shr } - "<<" { kw CmmT_Shl } - ">=" { kw CmmT_Ge } - "<=" { kw CmmT_Le } - "==" { kw CmmT_Eq } - "!=" { kw CmmT_Ne } - "&&" { kw CmmT_BoolAnd } - "||" { kw CmmT_BoolOr } - - P@decimal { global_regN (\n -> VanillaReg n VGcPtr) } - R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) } - F@decimal { global_regN FloatReg } - D@decimal { global_regN DoubleReg } - L@decimal { global_regN LongReg } - Sp { global_reg Sp } - SpLim { global_reg SpLim } - Hp { global_reg Hp } - HpLim { global_reg HpLim } - CCCS { global_reg CCCS } - CurrentTSO { global_reg CurrentTSO } - CurrentNursery { global_reg CurrentNursery } - HpAlloc { global_reg HpAlloc } - BaseReg { global_reg BaseReg } - MachSp { global_reg MachSp } - UnwindReturnReg { global_reg UnwindReturnReg } - - $namebegin $namechar* { name } - - 0 @octal { tok_octal } - @decimal { tok_decimal } - 0[xX] @hexadecimal { tok_hexadecimal } - @floating_point { strtoken tok_float } - - \" @strchar* \" { strtoken tok_string } -} - -{ -data CmmToken - = CmmT_SpecChar Char - | CmmT_DotDot - | CmmT_DoubleColon - | CmmT_Shr - | CmmT_Shl - | CmmT_Ge - | CmmT_Le - | CmmT_Eq - | CmmT_Ne - | CmmT_BoolAnd - | CmmT_BoolOr - | CmmT_CLOSURE - | CmmT_INFO_TABLE - | CmmT_INFO_TABLE_RET - | CmmT_INFO_TABLE_FUN - | CmmT_INFO_TABLE_CONSTR - | CmmT_INFO_TABLE_SELECTOR - | CmmT_else - | CmmT_export - | CmmT_section - | CmmT_goto - | CmmT_if - | CmmT_call - | CmmT_jump - | CmmT_foreign - | CmmT_never - | CmmT_prim - | CmmT_reserve - | CmmT_return - | CmmT_returns - | CmmT_import - | CmmT_switch - | CmmT_case - | CmmT_default - | CmmT_push - | CmmT_unwind - | CmmT_bits8 - | CmmT_bits16 - | CmmT_bits32 - | CmmT_bits64 - | CmmT_bits128 - | CmmT_bits256 - | CmmT_bits512 - | CmmT_float32 - | CmmT_float64 - | CmmT_gcptr - | CmmT_GlobalReg GlobalReg - | CmmT_Name FastString - | CmmT_String String - | CmmT_Int Integer - | CmmT_Float Rational - | CmmT_EOF - deriving (Show) - --- ----------------------------------------------------------------------------- --- Lexer actions - -type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken) - -begin :: Int -> Action -begin code _span _str _len = do liftP (pushLexState code); lexToken - -pop :: Action -pop _span _buf _len = liftP popLexState >> lexToken - -special_char :: Action -special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf))) - -kw :: CmmToken -> Action -kw tok span _buf _len = return (L span tok) - -global_regN :: (Int -> GlobalReg) -> Action -global_regN con span buf len - = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) - where buf' = stepOn buf - n = parseUnsignedInteger buf' (len-1) 10 octDecDigit - -global_reg :: GlobalReg -> Action -global_reg r span _buf _len = return (L span (CmmT_GlobalReg r)) - -strtoken :: (String -> CmmToken) -> Action -strtoken f span buf len = - return (L span $! (f $! lexemeToString buf len)) - -name :: Action -name span buf len = - case lookupUFM reservedWordsFM fs of - Just tok -> return (L span tok) - Nothing -> return (L span (CmmT_Name fs)) - where - fs = lexemeToFastString buf len - -reservedWordsFM = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "CLOSURE", CmmT_CLOSURE ), - ( "INFO_TABLE", CmmT_INFO_TABLE ), - ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), - ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), - ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), - ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), - ( "else", CmmT_else ), - ( "export", CmmT_export ), - ( "section", CmmT_section ), - ( "goto", CmmT_goto ), - ( "if", CmmT_if ), - ( "call", CmmT_call ), - ( "jump", CmmT_jump ), - ( "foreign", CmmT_foreign ), - ( "never", CmmT_never ), - ( "prim", CmmT_prim ), - ( "reserve", CmmT_reserve ), - ( "return", CmmT_return ), - ( "returns", CmmT_returns ), - ( "import", CmmT_import ), - ( "switch", CmmT_switch ), - ( "case", CmmT_case ), - ( "default", CmmT_default ), - ( "push", CmmT_push ), - ( "unwind", CmmT_unwind ), - ( "bits8", CmmT_bits8 ), - ( "bits16", CmmT_bits16 ), - ( "bits32", CmmT_bits32 ), - ( "bits64", CmmT_bits64 ), - ( "bits128", CmmT_bits128 ), - ( "bits256", CmmT_bits256 ), - ( "bits512", CmmT_bits512 ), - ( "float32", CmmT_float32 ), - ( "float64", CmmT_float64 ), --- New forms - ( "b8", CmmT_bits8 ), - ( "b16", CmmT_bits16 ), - ( "b32", CmmT_bits32 ), - ( "b64", CmmT_bits64 ), - ( "b128", CmmT_bits128 ), - ( "b256", CmmT_bits256 ), - ( "b512", CmmT_bits512 ), - ( "f32", CmmT_float32 ), - ( "f64", CmmT_float64 ), - ( "gcptr", CmmT_gcptr ) - ] - -tok_decimal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit)) - -tok_octal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit)) - -tok_hexadecimal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit)) - -tok_float str = CmmT_Float $! readRational str - -tok_string str = CmmT_String (read str) - -- urk, not quite right, but it'll do for now - --- ----------------------------------------------------------------------------- --- Line pragmas - -setLine :: Int -> Action -setLine code span buf len = do - let line = parseUnsignedInteger buf len 10 octDecDigit - liftP $ do - setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line - -- trace ("setLine " ++ show line) $ do - popLexState >> pushLexState code - lexToken - -setFile :: Int -> Action -setFile code span buf len = do - let file = lexemeToFastString (stepOn buf) (len-2) - liftP $ do - setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) - popLexState >> pushLexState code - lexToken - --- ----------------------------------------------------------------------------- --- This is the top-level function: called from the parser each time a --- new token is to be read from the input. - -cmmlex :: (Located CmmToken -> PD a) -> PD a -cmmlex cont = do - (L span tok) <- lexToken - --trace ("token: " ++ show tok) $ do - cont (L (RealSrcSpan span) tok) - -lexToken :: PD (RealLocated CmmToken) -lexToken = do - inp@(loc1,buf) <- getInput - sc <- liftP getLexState - case alexScan inp sc of - AlexEOF -> do let span = mkRealSrcSpan loc1 loc1 - liftP (setLastToken span 0) - return (L span CmmT_EOF) - AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error" - AlexSkip inp2 _ -> do - setInput inp2 - lexToken - AlexToken inp2@(end,_buf2) len t -> do - setInput inp2 - let span = mkRealSrcSpan loc1 end - span `seq` liftP (setLastToken span len) - t span buf len - --- ----------------------------------------------------------------------------- --- Monad stuff - --- Stuff that Alex needs to know about our input type: -type AlexInput = (RealSrcLoc,StringBuffer) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (_,s) = prevChar s '\n' - --- backwards compatibility for Alex 2.x -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar inp = case alexGetByte inp of - Nothing -> Nothing - Just (b,i) -> c `seq` Just (c,i) - where c = chr $ fromIntegral b - -alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) -alexGetByte (loc,s) - | atEnd s = Nothing - | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s')) - where c = currentChar s - b = fromIntegral $ ord $ c - loc' = advanceSrcLoc loc c - s' = stepOn s - -getInput :: PD AlexInput -getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b) - -setInput :: AlexInput -> PD () -setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } () -} diff --git a/cmm/CmmLint.hs b/cmm/CmmLint.hs deleted file mode 100644 --- a/cmm/CmmLint.hs +++ /dev/null @@ -1,257 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2011 --- --- CmmLint: checking the correctness of Cmm statements and expressions --- ------------------------------------------------------------------------------ -{-# LANGUAGE GADTs #-} -module CmmLint ( - cmmLint, cmmLintGraph - ) where - -import Hoopl -import Cmm -import CmmUtils -import CmmLive -import CmmSwitch (switchTargetsToList) -import PprCmm () -import Outputable -import DynFlags - -import Control.Monad (liftM, ap) - --- Things to check: --- - invariant on CmmBlock in CmmExpr (see comment there) --- - check for branches to blocks that don't exist --- - check types - --- ----------------------------------------------------------------------------- --- Exported entry points: - -cmmLint :: (Outputable d, Outputable h) - => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc -cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops - -cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc -cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g - -runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint dflags l p = - case unCL (l p) dflags of - Left err -> Just (vcat [text "Cmm lint error:", - nest 2 err, - text "Program was:", - nest 2 (ppr p)]) - Right _ -> Nothing - -lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint () -lintCmmDecl dflags (CmmProc _ lbl _ g) - = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g -lintCmmDecl _ (CmmData {}) - = return () - - -lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint () -lintCmmGraph dflags g = - cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks - -- cmmLiveness throws an error if there are registers - -- live on entry to the graph (i.e. undefined - -- variables) - where - blocks = toBlockList g - labels = setFromList (map entryLabel blocks) - - -lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint () -lintCmmBlock labels block - = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do - let (_, middle, last) = blockSplit block - mapM_ lintCmmMiddle (blockToList middle) - lintCmmLast labels last - --- ----------------------------------------------------------------------------- --- lintCmmExpr - --- Checks whether a CmmExpr is "type-correct", and check for obvious-looking --- byte/word mismatches. - -lintCmmExpr :: CmmExpr -> CmmLint CmmType -lintCmmExpr (CmmLoad expr rep) = do - _ <- lintCmmExpr expr - -- Disabled, if we have the inlining phase before the lint phase, - -- we can have funny offsets due to pointer tagging. -- EZY - -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ - -- cmmCheckWordAddress expr - return rep -lintCmmExpr expr@(CmmMachOp op args) = do - dflags <- getDynFlags - tys <- mapM lintCmmExpr args - if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op - then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op) -lintCmmExpr (CmmRegOff reg offset) - = do dflags <- getDynFlags - let rep = typeWidth (cmmRegType dflags reg) - lintCmmExpr (CmmMachOp (MO_Add rep) - [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) -lintCmmExpr expr = - do dflags <- getDynFlags - return (cmmExprType dflags expr) - --- Check for some common byte/word mismatches (eg. Sp + 1) -cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType -cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys - = cmmCheckMachOp op [reg, lit] tys -cmmCheckMachOp op _ tys - = do dflags <- getDynFlags - return (machOpResultType dflags op tys) - -{- -isOffsetOp :: MachOp -> Bool -isOffsetOp (MO_Add _) = True -isOffsetOp (MO_Sub _) = True -isOffsetOp _ = False - --- This expression should be an address from which a word can be loaded: --- check for funny-looking sub-word offsets. -_cmmCheckWordAddress :: CmmExpr -> CmmLint () -_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 - = cmmLintDubiousWordOffset e -_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 - = cmmLintDubiousWordOffset e -_cmmCheckWordAddress _ - = return () - --- No warnings for unaligned arithmetic with the node register, --- which is used to extract fields from tagged constructor closures. -notNodeReg :: CmmExpr -> Bool -notNodeReg (CmmReg reg) | reg == nodeReg = False -notNodeReg _ = True --} - -lintCmmMiddle :: CmmNode O O -> CmmLint () -lintCmmMiddle node = case node of - CmmComment _ -> return () - CmmTick _ -> return () - CmmUnwind{} -> return () - - CmmAssign reg expr -> do - dflags <- getDynFlags - erep <- lintCmmExpr expr - let reg_ty = cmmRegType dflags reg - if (erep `cmmEqType_ignoring_ptrhood` reg_ty) - then return () - else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty - - CmmStore l r -> do - _ <- lintCmmExpr l - _ <- lintCmmExpr r - return () - - CmmUnsafeForeignCall target _formals actuals -> do - lintTarget target - mapM_ lintCmmExpr actuals - - -lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint () -lintCmmLast labels node = case node of - CmmBranch id -> checkTarget id - - CmmCondBranch e t f _ -> do - dflags <- getDynFlags - mapM_ checkTarget [t,f] - _ <- lintCmmExpr e - checkCond dflags e - - CmmSwitch e ids -> do - dflags <- getDynFlags - mapM_ checkTarget $ switchTargetsToList ids - erep <- lintCmmExpr e - if (erep `cmmEqType_ignoring_ptrhood` bWord dflags) - then return () - else cmmLintErr (text "switch scrutinee is not a word: " <> - ppr e <> text " :: " <> ppr erep) - - CmmCall { cml_target = target, cml_cont = cont } -> do - _ <- lintCmmExpr target - maybe (return ()) checkTarget cont - - CmmForeignCall tgt _ args succ _ _ _ -> do - lintTarget tgt - mapM_ lintCmmExpr args - checkTarget succ - where - checkTarget id - | setMember id labels = return () - | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id) - - -lintTarget :: ForeignTarget -> CmmLint () -lintTarget (ForeignTarget e _) = lintCmmExpr e >> return () -lintTarget (PrimTarget {}) = return () - - -checkCond :: DynFlags -> CmmExpr -> CmmLint () -checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values -checkCond _ expr - = cmmLintErr (hang (text "expression is not a conditional:") 2 - (ppr expr)) - --- ----------------------------------------------------------------------------- --- CmmLint monad - --- just a basic error monad: - -newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a } - -instance Functor CmmLint where - fmap = liftM - -instance Applicative CmmLint where - pure a = CmmLint (\_ -> Right a) - (<*>) = ap - -instance Monad CmmLint where - CmmLint m >>= k = CmmLint $ \dflags -> - case m dflags of - Left e -> Left e - Right a -> unCL (k a) dflags - -instance HasDynFlags CmmLint where - getDynFlags = CmmLint (\dflags -> Right dflags) - -cmmLintErr :: SDoc -> CmmLint a -cmmLintErr msg = CmmLint (\_ -> Left msg) - -addLintInfo :: SDoc -> CmmLint a -> CmmLint a -addLintInfo info thing = CmmLint $ \dflags -> - case unCL thing dflags of - Left err -> Left (hang info 2 err) - Right a -> Right a - -cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a -cmmLintMachOpErr expr argsRep opExpectsRep - = cmmLintErr (text "in MachOp application: " $$ - nest 2 (ppr expr) $$ - (text "op is expecting: " <+> ppr opExpectsRep) $$ - (text "arguments provide: " <+> ppr argsRep)) - -cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a -cmmLintAssignErr stmt e_ty r_ty - = cmmLintErr (text "in assignment: " $$ - nest 2 (vcat [ppr stmt, - text "Reg ty:" <+> ppr r_ty, - text "Rhs ty:" <+> ppr e_ty])) - - -{- -cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a -cmmLintDubiousWordOffset expr - = cmmLintErr (text "offset is not a multiple of words: " $$ - nest 2 (ppr expr)) --} - diff --git a/cmm/CmmLive.hs b/cmm/CmmLive.hs deleted file mode 100644 --- a/cmm/CmmLive.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module CmmLive - ( CmmLocalLive - , cmmLocalLiveness - , cmmGlobalLiveness - , liveLattice - , gen_kill - ) -where - -import DynFlags -import BlockId -import Cmm -import PprCmmExpr () -import Hoopl - -import Maybes -import Outputable - ------------------------------------------------------------------------------ --- Calculating what variables are live on entry to a basic block ------------------------------------------------------------------------------ - --- | The variables live on entry to a block -type CmmLive r = RegSet r -type CmmLocalLive = CmmLive LocalReg - --- | The dataflow lattice -liveLattice :: Ord r => DataflowLattice (CmmLive r) -{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-} -{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-} -liveLattice = DataflowLattice emptyRegSet add - where - add (OldFact old) (NewFact new) = - let !join = plusRegSet old new - in changedIf (sizeRegSet join > sizeRegSet old) join - --- | A mapping from block labels to the variables live on entry -type BlockEntryLiveness r = LabelMap (CmmLive r) - ------------------------------------------------------------------------------ --- | Calculated liveness info for a CmmGraph ------------------------------------------------------------------------------ - -cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg -cmmLocalLiveness dflags graph = - check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty - where - entry = g_entry graph - check facts = - noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts - -cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg -cmmGlobalLiveness dflags graph = - analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty - --- | On entry to the procedure, there had better not be any LocalReg's live-in. -noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a -noLiveOnEntry bid in_fact x = - if nullRegSet in_fact then x - else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact) - -gen_kill - :: (DefinerOfRegs r n, UserOfRegs r n) - => DynFlags -> n -> CmmLive r -> CmmLive r -gen_kill dflags node set = - let !afterKill = foldRegsDefd dflags deleteFromRegSet set node - in foldRegsUsed dflags extendRegSet afterKill node -{-# INLINE gen_kill #-} - -xferLive - :: forall r. - ( UserOfRegs r (CmmNode O O) - , DefinerOfRegs r (CmmNode O O) - , UserOfRegs r (CmmNode O C) - , DefinerOfRegs r (CmmNode O C) - ) - => DynFlags -> TransferFun (CmmLive r) -xferLive dflags (BlockCC eNode middle xNode) fBase = - let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase - !result = foldNodesBwdOO (gen_kill dflags) middle joined - in mapSingleton (entryLabel eNode) result -{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-} -{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-} diff --git a/cmm/CmmMachOp.hs b/cmm/CmmMachOp.hs deleted file mode 100644 --- a/cmm/CmmMachOp.hs +++ /dev/null @@ -1,619 +0,0 @@ -{-# LANGUAGE CPP #-} - -module CmmMachOp - ( MachOp(..) - , pprMachOp, isCommutableMachOp, isAssociativeMachOp - , isComparisonMachOp, maybeIntComparison, machOpResultType - , machOpArgReps, maybeInvertComparison - - -- MachOp builders - , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot - , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem - , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe - , mo_wordULe, mo_wordUGt, mo_wordULt - , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot - , mo_wordShl, mo_wordSShr, mo_wordUShr - , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 - , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord - , mo_u_32ToWord, mo_s_32ToWord - , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 - - -- CallishMachOp - , CallishMachOp(..), callishMachOpHints - , pprCallishMachOp - , machOpMemcpyishAlign - - -- Atomic read-modify-write - , AtomicMachOp(..) - ) -where - -#include "HsVersions.h" - -import CmmType -import Outputable -import DynFlags - ------------------------------------------------------------------------------ --- MachOp ------------------------------------------------------------------------------ - -{- | -Machine-level primops; ones which we can reasonably delegate to the -native code generators to handle. - -Most operations are parameterised by the 'Width' that they operate on. -Some operations have separate signed and unsigned versions, and float -and integer versions. --} - -data MachOp - -- Integer operations (insensitive to signed/unsigned) - = MO_Add Width - | MO_Sub Width - | MO_Eq Width - | MO_Ne Width - | MO_Mul Width -- low word of multiply - - -- Signed multiply/divide - | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows - | MO_S_Quot Width -- signed / (same semantics as IntQuotOp) - | MO_S_Rem Width -- signed % (same semantics as IntRemOp) - | MO_S_Neg Width -- unary - - - -- Unsigned multiply/divide - | MO_U_MulMayOflo Width -- nonzero if unsigned multiply overflows - | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp) - | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp) - - -- Signed comparisons - | MO_S_Ge Width - | MO_S_Le Width - | MO_S_Gt Width - | MO_S_Lt Width - - -- Unsigned comparisons - | MO_U_Ge Width - | MO_U_Le Width - | MO_U_Gt Width - | MO_U_Lt Width - - -- Floating point arithmetic - | MO_F_Add Width - | MO_F_Sub Width - | MO_F_Neg Width -- unary - - | MO_F_Mul Width - | MO_F_Quot Width - - -- Floating point comparison - | MO_F_Eq Width - | MO_F_Ne Width - | MO_F_Ge Width - | MO_F_Le Width - | MO_F_Gt Width - | MO_F_Lt Width - - -- Bitwise operations. Not all of these may be supported - -- at all sizes, and only integral Widths are valid. - | MO_And Width - | MO_Or Width - | MO_Xor Width - | MO_Not Width - | MO_Shl Width - | MO_U_Shr Width -- unsigned shift right - | MO_S_Shr Width -- signed shift right - - -- Conversions. Some of these will be NOPs. - -- Floating-point conversions use the signed variant. - | MO_SF_Conv Width Width -- Signed int -> Float - | MO_FS_Conv Width Width -- Float -> Signed int - | MO_SS_Conv Width Width -- Signed int -> Signed int - | MO_UU_Conv Width Width -- unsigned int -> unsigned int - | MO_FF_Conv Width Width -- Float -> Float - - -- Vector element insertion and extraction operations - | MO_V_Insert Length Width -- Insert scalar into vector - | MO_V_Extract Length Width -- Extract scalar from vector - - -- Integer vector operations - | MO_V_Add Length Width - | MO_V_Sub Length Width - | MO_V_Mul Length Width - - -- Signed vector multiply/divide - | MO_VS_Quot Length Width - | MO_VS_Rem Length Width - | MO_VS_Neg Length Width - - -- Unsigned vector multiply/divide - | MO_VU_Quot Length Width - | MO_VU_Rem Length Width - - -- Floting point vector element insertion and extraction operations - | MO_VF_Insert Length Width -- Insert scalar into vector - | MO_VF_Extract Length Width -- Extract scalar from vector - - -- Floating point vector operations - | MO_VF_Add Length Width - | MO_VF_Sub Length Width - | MO_VF_Neg Length Width -- unary - - | MO_VF_Mul Length Width - | MO_VF_Quot Length Width - deriving (Eq, Show) - -pprMachOp :: MachOp -> SDoc -pprMachOp mo = text (show mo) - - - --- ----------------------------------------------------------------------------- --- Some common MachReps - --- A 'wordRep' is a machine word on the target architecture --- Specifically, it is the size of an Int#, Word#, Addr# --- and the unit of allocation on the stack and the heap --- Any pointer is also guaranteed to be a wordRep. - -mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot - , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem - , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe - , mo_wordULe, mo_wordUGt, mo_wordULt - , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr - , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord - , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 - :: DynFlags -> MachOp - -mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 - , mo_32To8, mo_32To16 - :: MachOp - -mo_wordAdd dflags = MO_Add (wordWidth dflags) -mo_wordSub dflags = MO_Sub (wordWidth dflags) -mo_wordEq dflags = MO_Eq (wordWidth dflags) -mo_wordNe dflags = MO_Ne (wordWidth dflags) -mo_wordMul dflags = MO_Mul (wordWidth dflags) -mo_wordSQuot dflags = MO_S_Quot (wordWidth dflags) -mo_wordSRem dflags = MO_S_Rem (wordWidth dflags) -mo_wordSNeg dflags = MO_S_Neg (wordWidth dflags) -mo_wordUQuot dflags = MO_U_Quot (wordWidth dflags) -mo_wordURem dflags = MO_U_Rem (wordWidth dflags) - -mo_wordSGe dflags = MO_S_Ge (wordWidth dflags) -mo_wordSLe dflags = MO_S_Le (wordWidth dflags) -mo_wordSGt dflags = MO_S_Gt (wordWidth dflags) -mo_wordSLt dflags = MO_S_Lt (wordWidth dflags) - -mo_wordUGe dflags = MO_U_Ge (wordWidth dflags) -mo_wordULe dflags = MO_U_Le (wordWidth dflags) -mo_wordUGt dflags = MO_U_Gt (wordWidth dflags) -mo_wordULt dflags = MO_U_Lt (wordWidth dflags) - -mo_wordAnd dflags = MO_And (wordWidth dflags) -mo_wordOr dflags = MO_Or (wordWidth dflags) -mo_wordXor dflags = MO_Xor (wordWidth dflags) -mo_wordNot dflags = MO_Not (wordWidth dflags) -mo_wordShl dflags = MO_Shl (wordWidth dflags) -mo_wordSShr dflags = MO_S_Shr (wordWidth dflags) -mo_wordUShr dflags = MO_U_Shr (wordWidth dflags) - -mo_u_8To32 = MO_UU_Conv W8 W32 -mo_s_8To32 = MO_SS_Conv W8 W32 -mo_u_16To32 = MO_UU_Conv W16 W32 -mo_s_16To32 = MO_SS_Conv W16 W32 - -mo_u_8ToWord dflags = MO_UU_Conv W8 (wordWidth dflags) -mo_s_8ToWord dflags = MO_SS_Conv W8 (wordWidth dflags) -mo_u_16ToWord dflags = MO_UU_Conv W16 (wordWidth dflags) -mo_s_16ToWord dflags = MO_SS_Conv W16 (wordWidth dflags) -mo_s_32ToWord dflags = MO_SS_Conv W32 (wordWidth dflags) -mo_u_32ToWord dflags = MO_UU_Conv W32 (wordWidth dflags) - -mo_WordTo8 dflags = MO_UU_Conv (wordWidth dflags) W8 -mo_WordTo16 dflags = MO_UU_Conv (wordWidth dflags) W16 -mo_WordTo32 dflags = MO_UU_Conv (wordWidth dflags) W32 -mo_WordTo64 dflags = MO_UU_Conv (wordWidth dflags) W64 - -mo_32To8 = MO_UU_Conv W32 W8 -mo_32To16 = MO_UU_Conv W32 W16 - - --- ---------------------------------------------------------------------------- --- isCommutableMachOp - -{- | -Returns 'True' if the MachOp has commutable arguments. This is used -in the platform-independent Cmm optimisations. - -If in doubt, return 'False'. This generates worse code on the -native routes, but is otherwise harmless. --} -isCommutableMachOp :: MachOp -> Bool -isCommutableMachOp mop = - case mop of - MO_Add _ -> True - MO_Eq _ -> True - MO_Ne _ -> True - MO_Mul _ -> True - MO_S_MulMayOflo _ -> True - MO_U_MulMayOflo _ -> True - MO_And _ -> True - MO_Or _ -> True - MO_Xor _ -> True - MO_F_Add _ -> True - MO_F_Mul _ -> True - _other -> False - --- ---------------------------------------------------------------------------- --- isAssociativeMachOp - -{- | -Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@) -This is used in the platform-independent Cmm optimisations. - -If in doubt, return 'False'. This generates worse code on the -native routes, but is otherwise harmless. --} -isAssociativeMachOp :: MachOp -> Bool -isAssociativeMachOp mop = - case mop of - MO_Add {} -> True -- NB: does not include - MO_Mul {} -> True -- floatint point! - MO_And {} -> True - MO_Or {} -> True - MO_Xor {} -> True - _other -> False - - --- ---------------------------------------------------------------------------- --- isComparisonMachOp - -{- | -Returns 'True' if the MachOp is a comparison. - -If in doubt, return False. This generates worse code on the -native routes, but is otherwise harmless. --} -isComparisonMachOp :: MachOp -> Bool -isComparisonMachOp mop = - case mop of - MO_Eq _ -> True - MO_Ne _ -> True - MO_S_Ge _ -> True - MO_S_Le _ -> True - MO_S_Gt _ -> True - MO_S_Lt _ -> True - MO_U_Ge _ -> True - MO_U_Le _ -> True - MO_U_Gt _ -> True - MO_U_Lt _ -> True - MO_F_Eq {} -> True - MO_F_Ne {} -> True - MO_F_Ge {} -> True - MO_F_Le {} -> True - MO_F_Gt {} -> True - MO_F_Lt {} -> True - _other -> False - -{- | -Returns @Just w@ if the operation is an integer comparison with width -@w@, or @Nothing@ otherwise. --} -maybeIntComparison :: MachOp -> Maybe Width -maybeIntComparison mop = - case mop of - MO_Eq w -> Just w - MO_Ne w -> Just w - MO_S_Ge w -> Just w - MO_S_Le w -> Just w - MO_S_Gt w -> Just w - MO_S_Lt w -> Just w - MO_U_Ge w -> Just w - MO_U_Le w -> Just w - MO_U_Gt w -> Just w - MO_U_Lt w -> Just w - _ -> Nothing - --- ----------------------------------------------------------------------------- --- Inverting conditions - --- Sometimes it's useful to be able to invert the sense of a --- condition. Not all conditional tests are invertible: in --- particular, floating point conditionals cannot be inverted, because --- there exist floating-point values which return False for both senses --- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)). - -maybeInvertComparison :: MachOp -> Maybe MachOp -maybeInvertComparison op - = case op of -- None of these Just cases include floating point - MO_Eq r -> Just (MO_Ne r) - MO_Ne r -> Just (MO_Eq r) - MO_U_Lt r -> Just (MO_U_Ge r) - MO_U_Gt r -> Just (MO_U_Le r) - MO_U_Le r -> Just (MO_U_Gt r) - MO_U_Ge r -> Just (MO_U_Lt r) - MO_S_Lt r -> Just (MO_S_Ge r) - MO_S_Gt r -> Just (MO_S_Le r) - MO_S_Le r -> Just (MO_S_Gt r) - MO_S_Ge r -> Just (MO_S_Lt r) - _other -> Nothing - --- ---------------------------------------------------------------------------- --- machOpResultType - -{- | -Returns the MachRep of the result of a MachOp. --} -machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType -machOpResultType dflags mop tys = - case mop of - MO_Add {} -> ty1 -- Preserve GC-ptr-hood - MO_Sub {} -> ty1 -- of first arg - MO_Mul r -> cmmBits r - MO_S_MulMayOflo r -> cmmBits r - MO_S_Quot r -> cmmBits r - MO_S_Rem r -> cmmBits r - MO_S_Neg r -> cmmBits r - MO_U_MulMayOflo r -> cmmBits r - MO_U_Quot r -> cmmBits r - MO_U_Rem r -> cmmBits r - - MO_Eq {} -> comparisonResultRep dflags - MO_Ne {} -> comparisonResultRep dflags - MO_S_Ge {} -> comparisonResultRep dflags - MO_S_Le {} -> comparisonResultRep dflags - MO_S_Gt {} -> comparisonResultRep dflags - MO_S_Lt {} -> comparisonResultRep dflags - - MO_U_Ge {} -> comparisonResultRep dflags - MO_U_Le {} -> comparisonResultRep dflags - MO_U_Gt {} -> comparisonResultRep dflags - MO_U_Lt {} -> comparisonResultRep dflags - - MO_F_Add r -> cmmFloat r - MO_F_Sub r -> cmmFloat r - MO_F_Mul r -> cmmFloat r - MO_F_Quot r -> cmmFloat r - MO_F_Neg r -> cmmFloat r - MO_F_Eq {} -> comparisonResultRep dflags - MO_F_Ne {} -> comparisonResultRep dflags - MO_F_Ge {} -> comparisonResultRep dflags - MO_F_Le {} -> comparisonResultRep dflags - MO_F_Gt {} -> comparisonResultRep dflags - MO_F_Lt {} -> comparisonResultRep dflags - - MO_And {} -> ty1 -- Used for pointer masking - MO_Or {} -> ty1 - MO_Xor {} -> ty1 - MO_Not r -> cmmBits r - MO_Shl r -> cmmBits r - MO_U_Shr r -> cmmBits r - MO_S_Shr r -> cmmBits r - - MO_SS_Conv _ to -> cmmBits to - MO_UU_Conv _ to -> cmmBits to - MO_FS_Conv _ to -> cmmBits to - MO_SF_Conv _ to -> cmmFloat to - MO_FF_Conv _ to -> cmmFloat to - - MO_V_Insert l w -> cmmVec l (cmmBits w) - MO_V_Extract _ w -> cmmBits w - - MO_V_Add l w -> cmmVec l (cmmBits w) - MO_V_Sub l w -> cmmVec l (cmmBits w) - MO_V_Mul l w -> cmmVec l (cmmBits w) - - MO_VS_Quot l w -> cmmVec l (cmmBits w) - MO_VS_Rem l w -> cmmVec l (cmmBits w) - MO_VS_Neg l w -> cmmVec l (cmmBits w) - - MO_VU_Quot l w -> cmmVec l (cmmBits w) - MO_VU_Rem l w -> cmmVec l (cmmBits w) - - MO_VF_Insert l w -> cmmVec l (cmmFloat w) - MO_VF_Extract _ w -> cmmFloat w - - MO_VF_Add l w -> cmmVec l (cmmFloat w) - MO_VF_Sub l w -> cmmVec l (cmmFloat w) - MO_VF_Mul l w -> cmmVec l (cmmFloat w) - MO_VF_Quot l w -> cmmVec l (cmmFloat w) - MO_VF_Neg l w -> cmmVec l (cmmFloat w) - where - (ty1:_) = tys - -comparisonResultRep :: DynFlags -> CmmType -comparisonResultRep = bWord -- is it? - - --- ----------------------------------------------------------------------------- --- machOpArgReps - --- | This function is used for debugging only: we can check whether an --- application of a MachOp is "type-correct" by checking that the MachReps of --- its arguments are the same as the MachOp expects. This is used when --- linting a CmmExpr. - -machOpArgReps :: DynFlags -> MachOp -> [Width] -machOpArgReps dflags op = - case op of - MO_Add r -> [r,r] - MO_Sub r -> [r,r] - MO_Eq r -> [r,r] - MO_Ne r -> [r,r] - MO_Mul r -> [r,r] - MO_S_MulMayOflo r -> [r,r] - MO_S_Quot r -> [r,r] - MO_S_Rem r -> [r,r] - MO_S_Neg r -> [r] - MO_U_MulMayOflo r -> [r,r] - MO_U_Quot r -> [r,r] - MO_U_Rem r -> [r,r] - - MO_S_Ge r -> [r,r] - MO_S_Le r -> [r,r] - MO_S_Gt r -> [r,r] - MO_S_Lt r -> [r,r] - - MO_U_Ge r -> [r,r] - MO_U_Le r -> [r,r] - MO_U_Gt r -> [r,r] - MO_U_Lt r -> [r,r] - - MO_F_Add r -> [r,r] - MO_F_Sub r -> [r,r] - MO_F_Mul r -> [r,r] - MO_F_Quot r -> [r,r] - MO_F_Neg r -> [r] - MO_F_Eq r -> [r,r] - MO_F_Ne r -> [r,r] - MO_F_Ge r -> [r,r] - MO_F_Le r -> [r,r] - MO_F_Gt r -> [r,r] - MO_F_Lt r -> [r,r] - - MO_And r -> [r,r] - MO_Or r -> [r,r] - MO_Xor r -> [r,r] - MO_Not r -> [r] - MO_Shl r -> [r, wordWidth dflags] - MO_U_Shr r -> [r, wordWidth dflags] - MO_S_Shr r -> [r, wordWidth dflags] - - MO_SS_Conv from _ -> [from] - MO_UU_Conv from _ -> [from] - MO_SF_Conv from _ -> [from] - MO_FS_Conv from _ -> [from] - MO_FF_Conv from _ -> [from] - - MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags] - MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth dflags] - - MO_V_Add _ r -> [r,r] - MO_V_Sub _ r -> [r,r] - MO_V_Mul _ r -> [r,r] - - MO_VS_Quot _ r -> [r,r] - MO_VS_Rem _ r -> [r,r] - MO_VS_Neg _ r -> [r] - - MO_VU_Quot _ r -> [r,r] - MO_VU_Rem _ r -> [r,r] - - MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags] - MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags] - - MO_VF_Add _ r -> [r,r] - MO_VF_Sub _ r -> [r,r] - MO_VF_Mul _ r -> [r,r] - MO_VF_Quot _ r -> [r,r] - MO_VF_Neg _ r -> [r] - ------------------------------------------------------------------------------ --- CallishMachOp ------------------------------------------------------------------------------ - --- CallishMachOps tend to be implemented by foreign calls in some backends, --- so we separate them out. In Cmm, these can only occur in a --- statement position, in contrast to an ordinary MachOp which can occur --- anywhere in an expression. -data CallishMachOp - = MO_F64_Pwr - | MO_F64_Sin - | MO_F64_Cos - | MO_F64_Tan - | MO_F64_Sinh - | MO_F64_Cosh - | MO_F64_Tanh - | MO_F64_Asin - | MO_F64_Acos - | MO_F64_Atan - | MO_F64_Log - | MO_F64_Exp - | MO_F64_Fabs - | MO_F64_Sqrt - | MO_F32_Pwr - | MO_F32_Sin - | MO_F32_Cos - | MO_F32_Tan - | MO_F32_Sinh - | MO_F32_Cosh - | MO_F32_Tanh - | MO_F32_Asin - | MO_F32_Acos - | MO_F32_Atan - | MO_F32_Log - | MO_F32_Exp - | MO_F32_Fabs - | MO_F32_Sqrt - - | MO_UF_Conv Width - - | MO_S_QuotRem Width - | MO_U_QuotRem Width - | MO_U_QuotRem2 Width - | MO_Add2 Width - | MO_SubWordC Width - | MO_AddIntC Width - | MO_SubIntC Width - | MO_U_Mul2 Width - - | MO_WriteBarrier - | MO_Touch -- Keep variables live (when using interior pointers) - - -- Prefetch - | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not - -- program behavior. - -- the Int can be 0-3. Needs to be known at compile time - -- to interact with code generation correctly. - -- TODO: add support for prefetch WRITES, - -- currently only exposes prefetch reads, which - -- would the majority of use cases in ghc anyways - - - -- These three MachOps are parameterised by the known alignment - -- of the destination and source (for memcpy/memmove) pointers. - -- This information may be used for optimisation in backends. - | MO_Memcpy Int - | MO_Memset Int - | MO_Memmove Int - - | MO_PopCnt Width - | MO_Clz Width - | MO_Ctz Width - - | MO_BSwap Width - - -- Atomic read-modify-write. - | MO_AtomicRMW Width AtomicMachOp - | MO_AtomicRead Width - | MO_AtomicWrite Width - | MO_Cmpxchg Width - deriving (Eq, Show) - --- | The operation to perform atomically. -data AtomicMachOp = - AMO_Add - | AMO_Sub - | AMO_And - | AMO_Nand - | AMO_Or - | AMO_Xor - deriving (Eq, Show) - -pprCallishMachOp :: CallishMachOp -> SDoc -pprCallishMachOp mo = text (show mo) - -callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint]) -callishMachOpHints op = case op of - MO_Memcpy _ -> ([], [AddrHint,AddrHint,NoHint]) - MO_Memset _ -> ([], [AddrHint,NoHint,NoHint]) - MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint]) - _ -> ([],[]) - -- empty lists indicate NoHint - --- | The alignment of a 'memcpy'-ish operation. -machOpMemcpyishAlign :: CallishMachOp -> Maybe Int -machOpMemcpyishAlign op = case op of - MO_Memcpy align -> Just align - MO_Memset align -> Just align - MO_Memmove align -> Just align - _ -> Nothing diff --git a/cmm/CmmMonad.hs b/cmm/CmmMonad.hs deleted file mode 100644 --- a/cmm/CmmMonad.hs +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------ --- A Parser monad with access to the 'DynFlags'. --- --- The 'P' monad only has access to the subset of of 'DynFlags' --- required for parsing Haskell. - --- The parser for C-- requires access to a lot more of the 'DynFlags', --- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance. ------------------------------------------------------------------------------ -{-# LANGUAGE CPP #-} -module CmmMonad ( - PD(..) - , liftP - ) where - -import Control.Monad -#if __GLASGOW_HASKELL__ > 710 -import qualified Control.Monad.Fail as MonadFail -#endif - -import DynFlags -import Lexer - -newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a } - -instance Functor PD where - fmap = liftM - -instance Applicative PD where - pure = returnPD - (<*>) = ap - -instance Monad PD where - (>>=) = thenPD - fail = failPD - -#if __GLASGOW_HASKELL__ > 710 -instance MonadFail.MonadFail PD where - fail = failPD -#endif - -liftP :: P a -> PD a -liftP (P f) = PD $ \_ s -> f s - -returnPD :: a -> PD a -returnPD = liftP . return - -thenPD :: PD a -> (a -> PD b) -> PD b -(PD m) `thenPD` k = PD $ \d s -> - case m d s of - POk s1 a -> unPD (k a) d s1 - PFailed span err -> PFailed span err - -failPD :: String -> PD a -failPD = liftP . fail - -instance HasDynFlags PD where - getDynFlags = PD $ \d s -> POk s d diff --git a/cmm/CmmNode.hs b/cmm/CmmNode.hs deleted file mode 100644 --- a/cmm/CmmNode.hs +++ /dev/null @@ -1,700 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - --- CmmNode type for representation using Hoopl graphs. - -module CmmNode ( - CmmNode(..), CmmFormal, CmmActual, CmmTickish, - UpdFrameOffset, Convention(..), - ForeignConvention(..), ForeignTarget(..), foreignTargetHints, - CmmReturnInfo(..), - mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf, - mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, - - -- * Tick scopes - CmmTickScope(..), isTickSubScope, combineTickScopes, - ) where - -import CodeGen.Platform -import CmmExpr -import CmmSwitch -import DynFlags -import FastString -import ForeignCall -import Outputable -import SMRep -import CoreSyn (Tickish) -import qualified Unique as U - -import Compiler.Hoopl -import Data.Maybe -import Data.List (tails,sortBy) -import Prelude hiding (succ) -import Unique (nonDetCmpUnique) -import Util - - ------------------------- --- CmmNode - -#define ULabel {-# UNPACK #-} !Label - -data CmmNode e x where - CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O - - CmmComment :: FastString -> CmmNode O O - - -- Tick annotation, covering Cmm code in our tick scope. We only - -- expect non-code @Tickish@ at this point (e.g. @SourceNote@). - -- See Note [CmmTick scoping details] - CmmTick :: !CmmTickish -> CmmNode O O - - -- Unwind pseudo-instruction, encoding stack unwinding - -- instructions for a debugger. This describes how to reconstruct - -- the "old" value of a register if we want to navigate the stack - -- up one frame. Having unwind information for @Sp@ will allow the - -- debugger to "walk" the stack. - -- - -- See Note [What is this unwinding business?] in Debug - CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O - - CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O - -- Assign to register - - CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O - -- Assign to memory location. Size is - -- given by cmmExprType of the rhs. - - CmmUnsafeForeignCall :: -- An unsafe foreign call; - -- see Note [Foreign calls] - -- Like a "fat machine instruction"; can occur - -- in the middle of a block - ForeignTarget -> -- call target - [CmmFormal] -> -- zero or more results - [CmmActual] -> -- zero or more arguments - CmmNode O O - -- Semantics: clobbers any GlobalRegs for which callerSaves r == True - -- See Note [Unsafe foreign calls clobber caller-save registers] - -- - -- Invariant: the arguments and the ForeignTarget must not - -- mention any registers for which CodeGen.Platform.callerSaves - -- is True. See Note [Register Parameter Passing]. - - CmmBranch :: ULabel -> CmmNode O C - -- Goto another block in the same procedure - - CmmCondBranch :: { -- conditional branch - cml_pred :: CmmExpr, - cml_true, cml_false :: ULabel, - cml_likely :: Maybe Bool -- likely result of the conditional, - -- if known - } -> CmmNode O C - - CmmSwitch - :: CmmExpr -- Scrutinee, of some integral type - -> SwitchTargets -- Cases. See [Note SwitchTargets] - -> CmmNode O C - - CmmCall :: { -- A native call or tail call - cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! - - cml_cont :: Maybe Label, - -- Label of continuation (Nothing for return or tail call) - -- - -- Note [Continuation BlockId]: these BlockIds are called - -- Continuation BlockIds, and are the only BlockIds that can - -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or - -- (CmmStackSlot (Young b) _). - - cml_args_regs :: [GlobalReg], - -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed - -- to the call. This is essential information for the - -- native code generator's register allocator; without - -- knowing which GlobalRegs are live it has to assume that - -- they are all live. This list should only include - -- GlobalRegs that are mapped to real machine registers on - -- the target platform. - - cml_args :: ByteOff, - -- Byte offset, from the *old* end of the Area associated with - -- the Label (if cml_cont = Nothing, then Old area), of - -- youngest outgoing arg. Set the stack pointer to this before - -- transferring control. - -- (NB: an update frame might also have been stored in the Old - -- area, but it'll be in an older part than the args.) - - cml_ret_args :: ByteOff, - -- For calls *only*, the byte offset for youngest returned value - -- This is really needed at the *return* point rather than here - -- at the call, but in practice it's convenient to record it here. - - cml_ret_off :: ByteOff - -- For calls *only*, the byte offset of the base of the frame that - -- must be described by the info table for the return point. - -- The older words are an update frames, which have their own - -- info-table and layout information - - -- From a liveness point of view, the stack words older than - -- cml_ret_off are treated as live, even if the sequel of - -- the call goes into a loop. - } -> CmmNode O C - - CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls] - -- Always the last node of a block - tgt :: ForeignTarget, -- call target and convention - res :: [CmmFormal], -- zero or more results - args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing] - succ :: ULabel, -- Label of continuation - ret_args :: ByteOff, -- same as cml_ret_args - ret_off :: ByteOff, -- same as cml_ret_off - intrbl:: Bool -- whether or not the call is interruptible - } -> CmmNode O C - -{- Note [Foreign calls] -~~~~~~~~~~~~~~~~~~~~~~~ -A CmmUnsafeForeignCall is used for *unsafe* foreign calls; -a CmmForeignCall call is used for *safe* foreign calls. - -Unsafe ones are mostly easy: think of them as a "fat machine -instruction". In particular, they do *not* kill all live registers, -just the registers they return to (there was a bit of code in GHC that -conservatively assumed otherwise.) However, see [Register parameter passing]. - -Safe ones are trickier. A safe foreign call - r = f(x) -ultimately expands to - push "return address" -- Never used to return to; - -- just points an info table - save registers into TSO - call suspendThread - r = f(x) -- Make the call - call resumeThread - restore registers - pop "return address" -We cannot "lower" a safe foreign call to this sequence of Cmms, because -after we've saved Sp all the Cmm optimiser's assumptions are broken. - -Note that a safe foreign call needs an info table. - -So Safe Foreign Calls must remain as last nodes until the stack is -made manifest in CmmLayoutStack, where they are lowered into the above -sequence. --} - -{- Note [Unsafe foreign calls clobber caller-save registers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A foreign call is defined to clobber any GlobalRegs that are mapped to -caller-saves machine registers (according to the prevailing C ABI). -StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves. - -This is a design choice that makes it easier to generate code later. -We could instead choose to say that foreign calls do *not* clobber -caller-saves regs, but then we would have to figure out which regs -were live across the call later and insert some saves/restores. - -Furthermore when we generate code we never have any GlobalRegs live -across a call, because they are always copied-in to LocalRegs and -copied-out again before making a call/jump. So all we have to do is -avoid any code motion that would make a caller-saves GlobalReg live -across a foreign call during subsequent optimisations. --} - -{- Note [Register parameter passing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -On certain architectures, some registers are utilized for parameter -passing in the C calling convention. For example, in x86-64 Linux -convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for -argument passing. These are registers R3-R6, which our generated -code may also be using; as a result, it's necessary to save these -values before doing a foreign call. This is done during initial -code generation in callerSaveVolatileRegs in StgCmmUtils.hs. However, -one result of doing this is that the contents of these registers -may mysteriously change if referenced inside the arguments. This -is dangerous, so you'll need to disable inlining much in the same -way is done in cmm/CmmOpt.hs currently. We should fix this! --} - ---------------------------------------------- --- Eq instance of CmmNode - -deriving instance Eq (CmmNode e x) - ----------------------------------------------- --- Hoopl instances of CmmNode - -instance NonLocal CmmNode where - entryLabel (CmmEntry l _) = l - - successors (CmmBranch l) = [l] - successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint - successors (CmmSwitch _ ids) = switchTargetsToList ids - successors (CmmCall {cml_cont=l}) = maybeToList l - successors (CmmForeignCall {succ=l}) = [l] - - --------------------------------------------------- --- Various helper types - -type CmmActual = CmmExpr -type CmmFormal = LocalReg - -type UpdFrameOffset = ByteOff - --- | A convention maps a list of values (function arguments or return --- values) to registers or stack locations. -data Convention - = NativeDirectCall - -- ^ top-level Haskell functions use @NativeDirectCall@, which - -- maps arguments to registers starting with R2, according to - -- how many registers are available on the platform. This - -- convention ignores R1, because for a top-level function call - -- the function closure is implicit, and doesn't need to be passed. - | NativeNodeCall - -- ^ non-top-level Haskell functions, which pass the address of - -- the function closure in R1 (regardless of whether R1 is a - -- real register or not), and the rest of the arguments in - -- registers or on the stack. - | NativeReturn - -- ^ a native return. The convention for returns depends on - -- how many values are returned: for just one value returned, - -- the appropriate register is used (R1, F1, etc.). regardless - -- of whether it is a real register or not. For multiple - -- values returned, they are mapped to registers or the stack. - | Slow - -- ^ Slow entry points: all args pushed on the stack - | GC - -- ^ Entry to the garbage collector: uses the node reg! - -- (TODO: I don't think we need this --SDM) - deriving( Eq ) - -data ForeignConvention - = ForeignConvention - CCallConv -- Which foreign-call convention - [ForeignHint] -- Extra info about the args - [ForeignHint] -- Extra info about the result - CmmReturnInfo - deriving Eq - -data CmmReturnInfo - = CmmMayReturn - | CmmNeverReturns - deriving ( Eq ) - -data ForeignTarget -- The target of a foreign call - = ForeignTarget -- A foreign procedure - CmmExpr -- Its address - ForeignConvention -- Its calling convention - | PrimTarget -- A possibly-side-effecting machine operation - CallishMachOp -- Which one - deriving Eq - -foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) -foreignTargetHints target - = ( res_hints ++ repeat NoHint - , arg_hints ++ repeat NoHint ) - where - (res_hints, arg_hints) = - case target of - PrimTarget op -> callishMachOpHints op - ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) -> - (res_hints, arg_hints) - --------------------------------------------------- --- Instances of register and slot users / definers - -instance UserOfRegs LocalReg (CmmNode e x) where - foldRegsUsed dflags f !z n = case n of - CmmAssign _ expr -> fold f z expr - CmmStore addr rval -> fold f (fold f z addr) rval - CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args - CmmCondBranch expr _ _ _ -> fold f z expr - CmmSwitch expr _ -> fold f z expr - CmmCall {cml_target=tgt} -> fold f z tgt - CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args - _ -> z - where fold :: forall a b. UserOfRegs LocalReg a - => (b -> LocalReg -> b) -> b -> a -> b - fold f z n = foldRegsUsed dflags f z n - -instance UserOfRegs GlobalReg (CmmNode e x) where - foldRegsUsed dflags f !z n = case n of - CmmAssign _ expr -> fold f z expr - CmmStore addr rval -> fold f (fold f z addr) rval - CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args - CmmCondBranch expr _ _ _ -> fold f z expr - CmmSwitch expr _ -> fold f z expr - CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt - CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args - _ -> z - where fold :: forall a b. UserOfRegs GlobalReg a - => (b -> GlobalReg -> b) -> b -> a -> b - fold f z n = foldRegsUsed dflags f z n - -instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where - -- The (Ord r) in the context is necessary here - -- See Note [Recursive superclasses] in TcInstDcls - foldRegsUsed _ _ !z (PrimTarget _) = z - foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e - -instance DefinerOfRegs LocalReg (CmmNode e x) where - foldRegsDefd dflags f !z n = case n of - CmmAssign lhs _ -> fold f z lhs - CmmUnsafeForeignCall _ fs _ -> fold f z fs - CmmForeignCall {res=res} -> fold f z res - _ -> z - where fold :: forall a b. DefinerOfRegs LocalReg a - => (b -> LocalReg -> b) -> b -> a -> b - fold f z n = foldRegsDefd dflags f z n - -instance DefinerOfRegs GlobalReg (CmmNode e x) where - foldRegsDefd dflags f !z n = case n of - CmmAssign lhs _ -> fold f z lhs - CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt) - CmmCall {} -> fold f z activeRegs - CmmForeignCall {} -> fold f z activeRegs - -- See Note [Safe foreign calls clobber STG registers] - _ -> z - where fold :: forall a b. DefinerOfRegs GlobalReg a - => (b -> GlobalReg -> b) -> b -> a -> b - fold f z n = foldRegsDefd dflags f z n - - platform = targetPlatform dflags - activeRegs = activeStgRegs platform - activeCallerSavesRegs = filter (callerSaves platform) activeRegs - - foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = [] - foreignTargetRegs _ = activeCallerSavesRegs - --- Note [Safe foreign calls clobber STG registers] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- During stack layout phase every safe foreign call is expanded into a block --- that contains unsafe foreign call (instead of safe foreign call) and ends --- with a normal call (See Note [Foreign calls]). This means that we must --- treat safe foreign call as if it was a normal call (because eventually it --- will be). This is important if we try to run sinking pass before stack --- layout phase. Consider this example of what might go wrong (this is cmm --- code from stablename001 test). Here is code after common block elimination --- (before stack layout): --- --- c1q6: --- _s1pf::P64 = R1; --- _c1q8::I64 = performMajorGC; --- I64[(young + 8)] = c1q9; --- foreign call "ccall" arg hints: [] result hints: [] (_c1q8::I64)(...) --- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8; --- c1q9: --- I64[(young + 8)] = c1qb; --- R1 = _s1pc::P64; --- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; --- --- If we run sinking pass now (still before stack layout) we will get this: --- --- c1q6: --- I64[(young + 8)] = c1q9; --- foreign call "ccall" arg hints: [] result hints: [] performMajorGC(...) --- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8; --- c1q9: --- I64[(young + 8)] = c1qb; --- _s1pf::P64 = R1; <------ _s1pf sunk past safe foreign call --- R1 = _s1pc::P64; --- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; --- --- Notice that _s1pf was sunk past a foreign call. When we run stack layout --- safe call to performMajorGC will be turned into: --- --- c1q6: --- _s1pc::P64 = P64[Sp + 8]; --- I64[Sp - 8] = c1q9; --- Sp = Sp - 8; --- I64[I64[CurrentTSO + 24] + 16] = Sp; --- P64[CurrentNursery + 8] = Hp + 8; --- (_u1qI::I64) = call "ccall" arg hints: [PtrHint,] --- result hints: [PtrHint] suspendThread(BaseReg, 0); --- call "ccall" arg hints: [] result hints: [] performMajorGC(); --- (_u1qJ::I64) = call "ccall" arg hints: [PtrHint] --- result hints: [PtrHint] resumeThread(_u1qI::I64); --- BaseReg = _u1qJ::I64; --- _u1qK::P64 = CurrentTSO; --- _u1qL::P64 = I64[_u1qK::P64 + 24]; --- Sp = I64[_u1qL::P64 + 16]; --- SpLim = _u1qL::P64 + 192; --- HpAlloc = 0; --- Hp = I64[CurrentNursery + 8] - 8; --- HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1); --- call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8; --- c1q9: --- I64[(young + 8)] = c1qb; --- _s1pf::P64 = R1; <------ INCORRECT! --- R1 = _s1pc::P64; --- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; --- --- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that --- call is clearly incorrect. This is what would happen if we assumed that --- safe foreign call has the same semantics as unsafe foreign call. To prevent --- this we need to treat safe foreign call as if was normal call. - ------------------------------------ --- mapping Expr in CmmNode - -mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget -mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c -mapForeignTarget _ m@(PrimTarget _) = m - -wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr --- Take a transformer on expressions and apply it recursively. --- (wrapRecExp f e) first recursively applies itself to sub-expressions of e --- then uses f to rewrite the resulting expression -wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es) -wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty) -wrapRecExp f e = f e - -mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x -mapExp _ f@(CmmEntry{}) = f -mapExp _ m@(CmmComment _) = m -mapExp _ m@(CmmTick _) = m -mapExp f (CmmUnwind regs) = CmmUnwind (map (fmap (fmap f)) regs) -mapExp f (CmmAssign r e) = CmmAssign r (f e) -mapExp f (CmmStore addr e) = CmmStore (f addr) (f e) -mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as) -mapExp _ l@(CmmBranch _) = l -mapExp f (CmmCondBranch e ti fi l) = CmmCondBranch (f e) ti fi l -mapExp f (CmmSwitch e ids) = CmmSwitch (f e) ids -mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt} -mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl - -mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x -mapExpDeep f = mapExp $ wrapRecExp f - ------------------------------------------------------------------------- --- mapping Expr in CmmNode, but not performing allocation if no changes - -mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget -mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e -mapForeignTargetM _ (PrimTarget _) = Nothing - -wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr) --- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e --- then gives f a chance to rewrite the resulting expression -wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es) -wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr) -wrapRecExpM f e = f e - -mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) -mapExpM _ (CmmEntry{}) = Nothing -mapExpM _ (CmmComment _) = Nothing -mapExpM _ (CmmTick _) = Nothing -mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs -mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e -mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e] -mapExpM _ (CmmBranch _) = Nothing -mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e -mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e -mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt -mapExpM f (CmmUnsafeForeignCall tgt fs as) - = case mapForeignTargetM f tgt of - Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as)) - Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as -mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) - = case mapForeignTargetM f tgt of - Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl) - Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as - --- share as much as possible -mapListM :: (a -> Maybe a) -> [a] -> Maybe [a] -mapListM f xs = let (b, r) = mapListT f xs - in if b then Just r else Nothing - -mapListJ :: (a -> Maybe a) -> [a] -> [a] -mapListJ f xs = snd (mapListT f xs) - -mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a]) -mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs)) - where g (_, y, Nothing) (True, ys) = (True, y:ys) - g (_, _, Just y) (True, ys) = (True, y:ys) - g (ys', _, Nothing) (False, _) = (False, ys') - g (_, _, Just y) (False, ys) = (True, y:ys) - -mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) -mapExpDeepM f = mapExpM $ wrapRecExpM f - ------------------------------------ --- folding Expr in CmmNode - -foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z -foldExpForeignTarget exp (ForeignTarget e _) z = exp e z -foldExpForeignTarget _ (PrimTarget _) z = z - --- Take a folder on expressions and apply it recursively. --- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad --- itself, delegating all the other CmmExpr forms to 'f'. -wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z -wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es -wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z) -wrapRecExpf f e z = f e z - -foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z -foldExp _ (CmmEntry {}) z = z -foldExp _ (CmmComment {}) z = z -foldExp _ (CmmTick {}) z = z -foldExp f (CmmUnwind xs) z = foldr (maybe id f) z (map snd xs) -foldExp f (CmmAssign _ e) z = f e z -foldExp f (CmmStore addr e) z = f addr $ f e z -foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as -foldExp _ (CmmBranch _) z = z -foldExp f (CmmCondBranch e _ _ _) z = f e z -foldExp f (CmmSwitch e _) z = f e z -foldExp f (CmmCall {cml_target=tgt}) z = f tgt z -foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args - -foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z -foldExpDeep f = foldExp (wrapRecExpf f) - --- ----------------------------------------------------------------------------- - -mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C -mapSuccessors f (CmmBranch bid) = CmmBranch (f bid) -mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l -mapSuccessors f (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets f ids) -mapSuccessors _ n = n - --- ----------------------------------------------------------------------------- - --- | Tickish in Cmm context (annotations only) -type CmmTickish = Tickish () - --- | Tick scope identifier, allowing us to reason about what --- annotations in a Cmm block should scope over. We especially take --- care to allow optimisations to reorganise blocks without losing --- tick association in the process. -data CmmTickScope - = GlobalScope - -- ^ The global scope is the "root" of the scope graph. Every - -- scope is a sub-scope of the global scope. It doesn't make sense - -- to add ticks to this scope. On the other hand, this means that - -- setting this scope on a block means no ticks apply to it. - - | SubScope !U.Unique CmmTickScope - -- ^ Constructs a new sub-scope to an existing scope. This allows - -- us to translate Core-style scoping rules (see @tickishScoped@) - -- into the Cmm world. Suppose the following code: - -- - -- tick<1> case ... of - -- A -> tick<2> ... - -- B -> tick<3> ... - -- - -- We want the top-level tick annotation to apply to blocks - -- generated for the A and B alternatives. We can achieve that by - -- generating tick<1> into a block with scope a, while the code - -- for alternatives A and B gets generated into sub-scopes a/b and - -- a/c respectively. - - | CombinedScope CmmTickScope CmmTickScope - -- ^ A combined scope scopes over everything that the two given - -- scopes cover. It is therefore a sub-scope of either scope. This - -- is required for optimisations. Consider common block elimination: - -- - -- A -> tick<2> case ... of - -- C -> [common] - -- B -> tick<3> case ... of - -- D -> [common] - -- - -- We will generate code for the C and D alternatives, and figure - -- out afterwards that it's actually common code. Scoping rules - -- dictate that the resulting common block needs to be covered by - -- both tick<2> and tick<3>, therefore we need to construct a - -- scope that is a child to *both* scope. Now we can do that - if - -- we assign the scopes a/c and b/d to the common-ed up blocks, - -- the new block could have a combined tick scope a/c+b/d, which - -- both tick<2> and tick<3> apply to. - --- Note [CmmTick scoping details]: --- --- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the --- same block. Note that as a result of this, optimisations making --- tick scopes more specific can *reduce* the amount of code a tick --- scopes over. Fixing this would require a separate @CmmTickScope@ --- field for @CmmTick@. Right now we do not do this simply because I --- couldn't find an example where it actually mattered -- multiple --- blocks within the same scope generally jump to each other, which --- prevents common block elimination from happening in the first --- place. But this is no strong reason, so if Cmm optimisations become --- more involved in future this might have to be revisited. - --- | Output all scope paths. -scopeToPaths :: CmmTickScope -> [[U.Unique]] -scopeToPaths GlobalScope = [[]] -scopeToPaths (SubScope u s) = map (u:) (scopeToPaths s) -scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2 - --- | Returns the head uniques of the scopes. This is based on the --- assumption that the @Unique@ of @SubScope@ identifies the --- underlying super-scope. Used for efficient equality and comparison, --- see below. -scopeUniques :: CmmTickScope -> [U.Unique] -scopeUniques GlobalScope = [] -scopeUniques (SubScope u _) = [u] -scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2 - --- Equality and order is based on the head uniques defined above. We --- take care to short-cut the (extremly) common cases. -instance Eq CmmTickScope where - GlobalScope == GlobalScope = True - GlobalScope == _ = False - _ == GlobalScope = False - (SubScope u _) == (SubScope u' _) = u == u' - (SubScope _ _) == _ = False - _ == (SubScope _ _) = False - scope == scope' = - sortBy nonDetCmpUnique (scopeUniques scope) == - sortBy nonDetCmpUnique (scopeUniques scope') - -- This is still deterministic because - -- the order is the same for equal lists - --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] --- See Note [No Ord for Unique] -instance Ord CmmTickScope where - compare GlobalScope GlobalScope = EQ - compare GlobalScope _ = LT - compare _ GlobalScope = GT - compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u' - compare scope scope' = cmpList nonDetCmpUnique - (sortBy nonDetCmpUnique $ scopeUniques scope) - (sortBy nonDetCmpUnique $ scopeUniques scope') - -instance Outputable CmmTickScope where - ppr GlobalScope = text "global" - ppr (SubScope us GlobalScope) - = ppr us - ppr (SubScope us s) = ppr s <> char '/' <> ppr us - ppr combined = parens $ hcat $ punctuate (char '+') $ - map (hcat . punctuate (char '/') . map ppr . reverse) $ - scopeToPaths combined - --- | Checks whether two tick scopes are sub-scopes of each other. True --- if the two scopes are equal. -isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool -isTickSubScope = cmp - where cmp _ GlobalScope = True - cmp GlobalScope _ = False - cmp (CombinedScope s1 s2) s' = cmp s1 s' && cmp s2 s' - cmp s (CombinedScope s1' s2') = cmp s s1' || cmp s s2' - cmp (SubScope u s) s'@(SubScope u' _) = u == u' || cmp s s' - --- | Combine two tick scopes. The new scope should be sub-scope of --- both parameters. We simplfy automatically if one tick scope is a --- sub-scope of the other already. -combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope -combineTickScopes s1 s2 - | s1 `isTickSubScope` s2 = s1 - | s2 `isTickSubScope` s1 = s2 - | otherwise = CombinedScope s1 s2 diff --git a/cmm/CmmOpt.hs b/cmm/CmmOpt.hs deleted file mode 100644 --- a/cmm/CmmOpt.hs +++ /dev/null @@ -1,392 +0,0 @@ -{-# LANGUAGE CPP #-} - --- The default iteration limit is a bit too low for the definitions --- in this module. -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-} -#endif - ------------------------------------------------------------------------------ --- --- Cmm optimisation --- --- (c) The University of Glasgow 2006 --- ------------------------------------------------------------------------------ - -module CmmOpt ( - constantFoldNode, - constantFoldExpr, - cmmMachOpFold, - cmmMachOpFoldM - ) where - -#include "HsVersions.h" - -import CmmUtils -import Cmm -import DynFlags -import Util - -import Outputable -import Platform - -import Data.Bits -import Data.Maybe - - -constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x -constantFoldNode dflags = mapExp (constantFoldExpr dflags) - -constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr -constantFoldExpr dflags = wrapRecExp f - where f (CmmMachOp op args) = cmmMachOpFold dflags op args - f (CmmRegOff r 0) = CmmReg r - f e = e - --- ----------------------------------------------------------------------------- --- MachOp constant folder - --- Now, try to constant-fold the MachOps. The arguments have already --- been optimized and folded. - -cmmMachOpFold - :: DynFlags - -> MachOp -- The operation from an CmmMachOp - -> [CmmExpr] -- The optimized arguments - -> CmmExpr - -cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args) - --- Returns Nothing if no changes, useful for Hoopl, also reduces --- allocation! -cmmMachOpFoldM - :: DynFlags - -> MachOp - -> [CmmExpr] - -> Maybe CmmExpr - -cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)] - = Just $ case op of - MO_S_Neg _ -> CmmLit (CmmInt (-x) rep) - MO_Not _ -> CmmLit (CmmInt (complement x) rep) - - -- these are interesting: we must first narrow to the - -- "from" type, in order to truncate to the correct size. - -- The final narrow/widen to the destination type - -- is implicit in the CmmLit. - MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to) - MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to) - MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to) - - _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op - - --- Eliminate conversion NOPs -cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x -cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x - --- Eliminate nested conversions where possible -cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]] - | Just (rep1,rep2,signed1) <- isIntConversion conv_inner, - Just (_, rep3,signed2) <- isIntConversion conv_outer - = case () of - -- widen then narrow to the same size is a nop - _ | rep1 < rep2 && rep1 == rep3 -> Just x - -- Widen then narrow to different size: collapse to single conversion - -- but remember to use the signedness from the widening, just in case - -- the final conversion is a widen. - | rep1 < rep2 && rep2 > rep3 -> - Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x] - -- Nested widenings: collapse if the signedness is the same - | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 -> - Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x] - -- Nested narrowings: collapse - | rep1 > rep2 && rep2 > rep3 -> - Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x] - | otherwise -> - Nothing - where - isIntConversion (MO_UU_Conv rep1 rep2) - = Just (rep1,rep2,False) - isIntConversion (MO_SS_Conv rep1 rep2) - = Just (rep1,rep2,True) - isIntConversion _ = Nothing - - intconv True = MO_SS_Conv - intconv False = MO_UU_Conv - --- ToDo: a narrow of a load can be collapsed into a narrow load, right? --- but what if the architecture only supports word-sized loads, should --- we do the transformation anyway? - -cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] - = case mop of - -- for comparisons: don't forget to narrow the arguments before - -- comparing, since they might be out of range. - MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags)) - MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags)) - - MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth dflags)) - MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags)) - MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth dflags)) - MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags)) - - MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth dflags)) - MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags)) - MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth dflags)) - MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags)) - - MO_Add r -> Just $ CmmLit (CmmInt (x + y) r) - MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r) - MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r) - MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r) - MO_U_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem` y_u) r) - MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r) - MO_S_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r) - - MO_And r -> Just $ CmmLit (CmmInt (x .&. y) r) - MO_Or r -> Just $ CmmLit (CmmInt (x .|. y) r) - MO_Xor r -> Just $ CmmLit (CmmInt (x `xor` y) r) - - MO_Shl r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r) - MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r) - MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r) - - _ -> Nothing - - where - x_u = narrowU xrep x - y_u = narrowU xrep y - x_s = narrowS xrep x - y_s = narrowS xrep y - - --- When possible, shift the constants to the right-hand side, so that we --- can match for strength reductions. Note that the code generator will --- also assume that constants have been shifted to the right when --- possible. - -cmmMachOpFoldM dflags op [x@(CmmLit _), y] - | not (isLit y) && isCommutableMachOp op - = Just (cmmMachOpFold dflags op [y, x]) - --- Turn (a+b)+c into a+(b+c) where possible. Because literals are --- moved to the right, it is more likely that we will find --- opportunities for constant folding when the expression is --- right-associated. --- --- ToDo: this appears to introduce a quadratic behaviour due to the --- nested cmmMachOpFold. Can we fix this? --- --- Why do we check isLit arg1? If arg1 is a lit, it means that arg2 --- is also a lit (otherwise arg1 would be on the right). If we --- put arg1 on the left of the rearranged expression, we'll get into a --- loop: (x1+x2)+x3 => x1+(x2+x3) => (x2+x3)+x1 => x2+(x3+x1) ... --- --- Also don't do it if arg1 is PicBaseReg, so that we don't separate the --- PicBaseReg from the corresponding label (or label difference). --- -cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3] - | mop2 `associates_with` mop1 - && not (isLit arg1) && not (isPicReg arg1) - = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]]) - where - MO_Add{} `associates_with` MO_Sub{} = True - mop1 `associates_with` mop2 = - mop1 == mop2 && isAssociativeMachOp mop1 - --- special case: (a - b) + c ==> a + (c - b) -cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] - | not (isLit arg1) && not (isPicReg arg1) - = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]]) - --- special case: (PicBaseReg + lit) + N ==> PicBaseReg + (lit+N) --- --- this is better because lit+N is a single link-time constant (e.g. a --- CmmLabelOff), so the right-hand expression needs only one --- instruction, whereas the left needs two. This happens when pointer --- tagging gives us label+offset, and PIC turns the label into --- PicBaseReg + label. --- -cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit] - , CmmLit (CmmInt n rep) ] - | isPicReg pic - = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ] - where off = fromIntegral (narrowS rep n) - --- Make a RegOff if we can -cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] - = Just $ cmmRegOff reg (fromIntegral (narrowS rep n)) -cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n)) -cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] - = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n)) -cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n)) - --- Fold label(+/-)offset into a CmmLit where possible - -cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)] - = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) -cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit] - = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) -cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)] - = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) - - --- Comparison of literal with widened operand: perform the comparison --- at the smaller width, as long as the literal is within range. - --- We can't do the reverse trick, when the operand is narrowed: --- narrowing throws away bits from the operand, there's no way to do --- the same comparison at the larger size. - -cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] - | -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try - platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64], - -- if the operand is widened: - Just (rep, signed, narrow_fn) <- maybe_conversion conv, - -- and this is a comparison operation: - Just narrow_cmp <- maybe_comparison cmp rep signed, - -- and the literal fits in the smaller size: - i == narrow_fn rep i - -- then we can do the comparison at the smaller size - = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)]) - where - maybe_conversion (MO_UU_Conv from to) - | to > from - = Just (from, False, narrowU) - maybe_conversion (MO_SS_Conv from to) - | to > from - = Just (from, True, narrowS) - - -- don't attempt to apply this optimisation when the source - -- is a float; see #1916 - maybe_conversion _ = Nothing - - -- careful (#2080): if the original comparison was signed, but - -- we were doing an unsigned widen, then we must do an - -- unsigned comparison at the smaller size. - maybe_comparison (MO_U_Gt _) rep _ = Just (MO_U_Gt rep) - maybe_comparison (MO_U_Ge _) rep _ = Just (MO_U_Ge rep) - maybe_comparison (MO_U_Lt _) rep _ = Just (MO_U_Lt rep) - maybe_comparison (MO_U_Le _) rep _ = Just (MO_U_Le rep) - maybe_comparison (MO_Eq _) rep _ = Just (MO_Eq rep) - maybe_comparison (MO_S_Gt _) rep True = Just (MO_S_Gt rep) - maybe_comparison (MO_S_Ge _) rep True = Just (MO_S_Ge rep) - maybe_comparison (MO_S_Lt _) rep True = Just (MO_S_Lt rep) - maybe_comparison (MO_S_Le _) rep True = Just (MO_S_Le rep) - maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep) - maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep) - maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep) - maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep) - maybe_comparison _ _ _ = Nothing - --- We can often do something with constants of 0 and 1 ... - -cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))] - = case mop of - MO_Add _ -> Just x - MO_Sub _ -> Just x - MO_Mul _ -> Just y - MO_And _ -> Just y - MO_Or _ -> Just x - MO_Xor _ -> Just x - MO_Shl _ -> Just x - MO_S_Shr _ -> Just x - MO_U_Shr _ -> Just x - MO_Ne _ | isComparisonExpr x -> Just x - MO_Eq _ | Just x' <- maybeInvertCmmExpr x -> Just x' - MO_U_Gt _ | isComparisonExpr x -> Just x - MO_S_Gt _ | isComparisonExpr x -> Just x - MO_U_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) - MO_S_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) - MO_U_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) - MO_S_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) - MO_U_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' - MO_S_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' - _ -> Nothing - -cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))] - = case mop of - MO_Mul _ -> Just x - MO_S_Quot _ -> Just x - MO_U_Quot _ -> Just x - MO_S_Rem _ -> Just $ CmmLit (CmmInt 0 rep) - MO_U_Rem _ -> Just $ CmmLit (CmmInt 0 rep) - MO_Ne _ | Just x' <- maybeInvertCmmExpr x -> Just x' - MO_Eq _ | isComparisonExpr x -> Just x - MO_U_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' - MO_S_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' - MO_U_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) - MO_S_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) - MO_U_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) - MO_S_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) - MO_U_Ge _ | isComparisonExpr x -> Just x - MO_S_Ge _ | isComparisonExpr x -> Just x - _ -> Nothing - --- Now look for multiplication/division by powers of 2 (integers). - -cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))] - = case mop of - MO_Mul rep - | Just p <- exactLog2 n -> - Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)]) - MO_U_Quot rep - | Just p <- exactLog2 n -> - Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]) - MO_S_Quot rep - | Just p <- exactLog2 n, - CmmReg _ <- x -> -- We duplicate x below, hence require - -- it is a reg. FIXME: remove this restriction. - -- shift right is not the same as quot, because it rounds - -- to minus infinity, whereasq quot rounds toward zero. - -- To fix this up, we add one less than the divisor to the - -- dividend if it is a negative number. - -- - -- to avoid a test/jump, we use the following sequence: - -- x1 = x >> word_size-1 (all 1s if -ve, all 0s if +ve) - -- x2 = y & (divisor-1) - -- result = (x+x2) >>= log2(divisor) - -- this could be done a bit more simply using conditional moves, - -- but we're processor independent here. - -- - -- we optimise the divide by 2 case slightly, generating - -- x1 = x >> word_size-1 (unsigned) - -- return = (x + x1) >>= log2(divisor) - let - bits = fromIntegral (widthInBits rep) - 1 - shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep - x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)] - x2 = if p == 1 then x1 else - CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] - x3 = CmmMachOp (MO_Add rep) [x, x2] - in - Just (cmmMachOpFold dflags (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)]) - _ -> Nothing - --- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x --- Unfortunately this needs a unique supply because x might not be a --- register. See #2253 (program 6) for an example. - - --- Anything else is just too hard. - -cmmMachOpFoldM _ _ _ = Nothing - --- ----------------------------------------------------------------------------- --- Utils - -isLit :: CmmExpr -> Bool -isLit (CmmLit _) = True -isLit _ = False - -isComparisonExpr :: CmmExpr -> Bool -isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op -isComparisonExpr _ = False - -isPicReg :: CmmExpr -> Bool -isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True -isPicReg _ = False diff --git a/cmm/CmmParse.y b/cmm/CmmParse.y deleted file mode 100644 --- a/cmm/CmmParse.y +++ /dev/null @@ -1,1419 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow, 2004-2012 --- --- Parser for concrete Cmm. --- ------------------------------------------------------------------------------ - -{- ----------------------------------------------------------------------------- -Note [Syntax of .cmm files] - -NOTE: You are very much on your own in .cmm. There is very little -error checking at all: - - * Type errors are detected by the (optional) -dcmm-lint pass, if you - don't turn this on then a type error will likely result in a panic - from the native code generator. - - * Passing the wrong number of arguments or arguments of the wrong - type is not detected. - -There are two ways to write .cmm code: - - (1) High-level Cmm code delegates the stack handling to GHC, and - never explicitly mentions Sp or registers. - - (2) Low-level Cmm manages the stack itself, and must know about - calling conventions. - -Whether you want high-level or low-level Cmm is indicated by the -presence of an argument list on a procedure. For example: - -foo ( gcptr a, bits32 b ) -{ - // this is high-level cmm code - - if (b > 0) { - // we can make tail calls passing arguments: - jump stg_ap_0_fast(a); - } - - push (stg_upd_frame_info, a) { - // stack frames can be explicitly pushed - - (x,y) = call wibble(a,b,3,4); - // calls pass arguments and return results using the native - // Haskell calling convention. The code generator will automatically - // construct a stack frame and an info table for the continuation. - - return (x,y); - // we can return multiple values from the current proc - } -} - -bar -{ - // this is low-level cmm code, indicated by the fact that we did not - // put an argument list on bar. - - x = R1; // the calling convention is explicit: better be careful - // that this works on all platforms! - - jump %ENTRY_CODE(Sp(0)) -} - -Here is a list of rules for high-level and low-level code. If you -break the rules, you get a panic (for using a high-level construct in -a low-level proc), or wrong code (when using low-level code in a -high-level proc). This stuff isn't checked! (TODO!) - -High-level only: - - - tail-calls with arguments, e.g. - jump stg_fun (arg1, arg2); - - - function calls: - (ret1,ret2) = call stg_fun (arg1, arg2); - - This makes a call with the NativeNodeCall convention, and the - values are returned to the following code using the NativeReturn - convention. - - - returning: - return (ret1, ret2) - - These use the NativeReturn convention to return zero or more - results to the caller. - - - pushing stack frames: - push (info_ptr, field1, ..., fieldN) { ... statements ... } - - - reserving temporary stack space: - - reserve N = x { ... } - - this reserves an area of size N (words) on the top of the stack, - and binds its address to x (a local register). Typically this is - used for allocating temporary storage for passing to foreign - functions. - - Note that if you make any native calls or invoke the GC in the - scope of the reserve block, you are responsible for ensuring that - the stack you reserved is laid out correctly with an info table. - -Low-level only: - - - References to Sp, R1-R8, F1-F4 etc. - - NB. foreign calls may clobber the argument registers R1-R8, F1-F4 - etc., so ensure they are saved into variables around foreign - calls. - - - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp - directly. - -Both high-level and low-level code can use a raw tail-call: - - jump stg_fun [R1,R2] - -NB. you *must* specify the list of GlobalRegs that are passed via a -jump, otherwise the register allocator will assume that all the -GlobalRegs are dead at the jump. - - -Calling Conventions -------------------- - -High-level procedures use the NativeNode calling convention, or the -NativeReturn convention if the 'return' keyword is used (see Stack -Frames below). - -Low-level procedures implement their own calling convention, so it can -be anything at all. - -If a low-level procedure implements the NativeNode calling convention, -then it can be called by high-level code using an ordinary function -call. In general this is hard to arrange because the calling -convention depends on the number of physical registers available for -parameter passing, but there are two cases where the calling -convention is platform-independent: - - - Zero arguments. - - - One argument of pointer or non-pointer word type; this is always - passed in R1 according to the NativeNode convention. - - - Returning a single value; these conventions are fixed and platform - independent. - - -Stack Frames ------------- - -A stack frame is written like this: - -INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN ) - return ( arg1, ..., argM ) -{ - ... code ... -} - -where field1 ... fieldN are the fields of the stack frame (with types) -arg1...argN are the values returned to the stack frame (with types). -The return values are assumed to be passed according to the -NativeReturn convention. - -On entry to the code, the stack frame looks like: - - |----------| - | fieldN | - | ... | - | field1 | - |----------| - | info_ptr | - |----------| - | argN | - | ... | <- Sp - -and some of the args may be in registers. - -We prepend the code by a copyIn of the args, and assign all the stack -frame fields to their formals. The initial "arg offset" for stack -layout purposes consists of the whole stack frame plus any args that -might be on the stack. - -A tail-call may pass a stack frame to the callee using the following -syntax: - -jump f (info_ptr, field1,..,fieldN) (arg1,..,argN) - -where info_ptr and field1..fieldN describe the stack frame, and -arg1..argN are the arguments passed to f using the NativeNodeCall -convention. Note if a field is longer than a word (e.g. a D_ on -a 32-bit machine) then the call will push as many words as -necessary to the stack to accommodate it (e.g. 2). - - ------------------------------------------------------------------------------ -} - -{ -module CmmParse ( parseCmmFile ) where - -import StgCmmExtCode -import CmmCallConv -import StgCmmProf -import StgCmmHeap -import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore - , emitAssign, emitOutOfLine, withUpdFrameOff - , getUpdFrameOff ) -import qualified StgCmmMonad as F -import StgCmmUtils -import StgCmmForeign -import StgCmmExpr -import StgCmmClosure -import StgCmmLayout hiding (ArgRep(..)) -import StgCmmTicky -import StgCmmBind ( emitBlackHoleCode, emitUpdateFrame ) -import CoreSyn ( Tickish(SourceNote) ) - -import CmmOpt -import MkGraph -import Cmm -import CmmUtils -import CmmSwitch ( mkSwitchTargets ) -import CmmInfo -import BlockId -import CmmLex -import CLabel -import SMRep -import Lexer -import CmmMonad - -import CostCentre -import ForeignCall -import Module -import Platform -import Literal -import Unique -import UniqFM -import SrcLoc -import DynFlags -import ErrUtils -import StringBuffer -import FastString -import Panic -import Constants -import Outputable -import BasicTypes -import Bag ( emptyBag, unitBag ) -import Var - -import Control.Monad -import Data.Array -import Data.Char ( ord ) -import System.Exit -import Data.Maybe -import qualified Data.Map as M - -#include "HsVersions.h" -} - -%expect 0 - -%token - ':' { L _ (CmmT_SpecChar ':') } - ';' { L _ (CmmT_SpecChar ';') } - '{' { L _ (CmmT_SpecChar '{') } - '}' { L _ (CmmT_SpecChar '}') } - '[' { L _ (CmmT_SpecChar '[') } - ']' { L _ (CmmT_SpecChar ']') } - '(' { L _ (CmmT_SpecChar '(') } - ')' { L _ (CmmT_SpecChar ')') } - '=' { L _ (CmmT_SpecChar '=') } - '`' { L _ (CmmT_SpecChar '`') } - '~' { L _ (CmmT_SpecChar '~') } - '/' { L _ (CmmT_SpecChar '/') } - '*' { L _ (CmmT_SpecChar '*') } - '%' { L _ (CmmT_SpecChar '%') } - '-' { L _ (CmmT_SpecChar '-') } - '+' { L _ (CmmT_SpecChar '+') } - '&' { L _ (CmmT_SpecChar '&') } - '^' { L _ (CmmT_SpecChar '^') } - '|' { L _ (CmmT_SpecChar '|') } - '>' { L _ (CmmT_SpecChar '>') } - '<' { L _ (CmmT_SpecChar '<') } - ',' { L _ (CmmT_SpecChar ',') } - '!' { L _ (CmmT_SpecChar '!') } - - '..' { L _ (CmmT_DotDot) } - '::' { L _ (CmmT_DoubleColon) } - '>>' { L _ (CmmT_Shr) } - '<<' { L _ (CmmT_Shl) } - '>=' { L _ (CmmT_Ge) } - '<=' { L _ (CmmT_Le) } - '==' { L _ (CmmT_Eq) } - '!=' { L _ (CmmT_Ne) } - '&&' { L _ (CmmT_BoolAnd) } - '||' { L _ (CmmT_BoolOr) } - - 'CLOSURE' { L _ (CmmT_CLOSURE) } - 'INFO_TABLE' { L _ (CmmT_INFO_TABLE) } - 'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) } - 'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) } - 'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) } - 'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) } - 'else' { L _ (CmmT_else) } - 'export' { L _ (CmmT_export) } - 'section' { L _ (CmmT_section) } - 'goto' { L _ (CmmT_goto) } - 'if' { L _ (CmmT_if) } - 'call' { L _ (CmmT_call) } - 'jump' { L _ (CmmT_jump) } - 'foreign' { L _ (CmmT_foreign) } - 'never' { L _ (CmmT_never) } - 'prim' { L _ (CmmT_prim) } - 'reserve' { L _ (CmmT_reserve) } - 'return' { L _ (CmmT_return) } - 'returns' { L _ (CmmT_returns) } - 'import' { L _ (CmmT_import) } - 'switch' { L _ (CmmT_switch) } - 'case' { L _ (CmmT_case) } - 'default' { L _ (CmmT_default) } - 'push' { L _ (CmmT_push) } - 'unwind' { L _ (CmmT_unwind) } - 'bits8' { L _ (CmmT_bits8) } - 'bits16' { L _ (CmmT_bits16) } - 'bits32' { L _ (CmmT_bits32) } - 'bits64' { L _ (CmmT_bits64) } - 'bits128' { L _ (CmmT_bits128) } - 'bits256' { L _ (CmmT_bits256) } - 'bits512' { L _ (CmmT_bits512) } - 'float32' { L _ (CmmT_float32) } - 'float64' { L _ (CmmT_float64) } - 'gcptr' { L _ (CmmT_gcptr) } - - GLOBALREG { L _ (CmmT_GlobalReg $$) } - NAME { L _ (CmmT_Name $$) } - STRING { L _ (CmmT_String $$) } - INT { L _ (CmmT_Int $$) } - FLOAT { L _ (CmmT_Float $$) } - -%monad { PD } { >>= } { return } -%lexer { cmmlex } { L _ CmmT_EOF } -%name cmmParse cmm -%tokentype { Located CmmToken } - --- C-- operator precedences, taken from the C-- spec -%right '||' -- non-std extension, called %disjoin in C-- -%right '&&' -- non-std extension, called %conjoin in C-- -%right '!' -%nonassoc '>=' '>' '<=' '<' '!=' '==' -%left '|' -%left '^' -%left '&' -%left '>>' '<<' -%left '-' '+' -%left '/' '*' '%' -%right '~' - -%% - -cmm :: { CmmParse () } - : {- empty -} { return () } - | cmmtop cmm { do $1; $2 } - -cmmtop :: { CmmParse () } - : cmmproc { $1 } - | cmmdata { $1 } - | decl { $1 } - | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' - {% liftP . withThisPackage $ \pkg -> - do lits <- sequence $6; - staticClosure pkg $3 $5 (map getLit lits) } - --- The only static closures in the RTS are dummy closures like --- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need --- to provide the full generality of static closures here. --- In particular: --- * CCS can always be CCS_DONT_CARE --- * closure is always extern --- * payload is always empty --- * we can derive closure and info table labels from a single NAME - -cmmdata :: { CmmParse () } - : 'section' STRING '{' data_label statics '}' - { do lbl <- $4; - ss <- sequence $5; - code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) } - -data_label :: { CmmParse CLabel } - : NAME ':' - {% liftP . withThisPackage $ \pkg -> - return (mkCmmDataLabel pkg $1) } - -statics :: { [CmmParse [CmmStatic]] } - : {- empty -} { [] } - | static statics { $1 : $2 } - --- Strings aren't used much in the RTS HC code, so it doesn't seem --- worth allowing inline strings. C-- doesn't allow them anyway. -static :: { CmmParse [CmmStatic] } - : type expr ';' { do e <- $2; - return [CmmStaticLit (getLit e)] } - | type ';' { return [CmmUninitialised - (widthInBytes (typeWidth $1))] } - | 'bits8' '[' ']' STRING ';' { return [mkString $4] } - | 'bits8' '[' INT ']' ';' { return [CmmUninitialised - (fromIntegral $3)] } - | typenot8 '[' INT ']' ';' { return [CmmUninitialised - (widthInBytes (typeWidth $1) * - fromIntegral $3)] } - | 'CLOSURE' '(' NAME lits ')' - { do { lits <- sequence $4 - ; dflags <- getDynFlags - ; return $ map CmmStaticLit $ - mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) - -- mkForeignLabel because these are only used - -- for CHARLIKE and INTLIKE closures in the RTS. - dontCareCCS (map getLit lits) [] [] [] } } - -- arrays of closures required for the CHARLIKE & INTLIKE arrays - -lits :: { [CmmParse CmmExpr] } - : {- empty -} { [] } - | ',' expr lits { $2 : $3 } - -cmmproc :: { CmmParse () } - : info maybe_conv maybe_formals maybe_body - { do ((entry_ret_label, info, stk_formals, formals), agraph) <- - getCodeScoped $ loopDecls $ do { - (entry_ret_label, info, stk_formals) <- $1; - dflags <- getDynFlags; - formals <- sequence (fromMaybe [] $3); - withName (showSDoc dflags (ppr entry_ret_label)) - $4; - return (entry_ret_label, info, stk_formals, formals) } - let do_layout = isJust $3 - code (emitProcWithStackFrame $2 info - entry_ret_label stk_formals formals agraph - do_layout ) } - -maybe_conv :: { Convention } - : {- empty -} { NativeNodeCall } - | 'return' { NativeReturn } - -maybe_body :: { CmmParse () } - : ';' { return () } - | '{' body '}' { withSourceNote $1 $3 $2 } - -info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } - : NAME - {% liftP . withThisPackage $ \pkg -> - do newFunctionName $1 pkg - return (mkCmmCodeLabel pkg $1, Nothing, []) } - - - | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' - -- ptrs, nptrs, closure type, description, type - {% liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags $11 $13 - rep = mkRTSRep (fromIntegral $9) $ - mkHeapRep dflags False (fromIntegral $5) - (fromIntegral $7) Thunk - -- not really Thunk, but that makes the info table - -- we want. - return (mkCmmEntryLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' - -- ptrs, nptrs, closure type, description, type, fun type - {% liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags $11 $13 - ty = Fun 0 (ArgSpec (fromIntegral $15)) - -- Arity zero, arg_type $15 - rep = mkRTSRep (fromIntegral $9) $ - mkHeapRep dflags False (fromIntegral $5) - (fromIntegral $7) ty - return (mkCmmEntryLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - -- we leave most of the fields zero here. This is only used - -- to generate the BCO info table in the RTS at the moment. - - | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' - -- ptrs, nptrs, tag, closure type, description, type - {% liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags $13 $15 - ty = Constr (fromIntegral $9) -- Tag - (stringToWord8s $13) - rep = mkRTSRep (fromIntegral $11) $ - mkHeapRep dflags False (fromIntegral $5) - (fromIntegral $7) ty - return (mkCmmEntryLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - -- If profiling is on, this string gets duplicated, - -- but that's the way the old code did it we can fix it some other time. - - | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' - -- selector, closure type, description, type - {% liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags $9 $11 - ty = ThunkSelector (fromIntegral $5) - rep = mkRTSRep (fromIntegral $7) $ - mkHeapRep dflags False 0 0 ty - return (mkCmmEntryLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - | 'INFO_TABLE_RET' '(' NAME ',' INT ')' - -- closure type (no live regs) - {% liftP . withThisPackage $ \pkg -> - do let prof = NoProfilingInfo - rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] - return (mkCmmRetLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' - -- closure type, live regs - {% liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - live <- sequence $7 - let prof = NoProfilingInfo - -- drop one for the info pointer - bitmap = mkLiveness dflags (map Just (drop 1 live)) - rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap - return (mkCmmRetLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - live) } - -body :: { CmmParse () } - : {- empty -} { return () } - | decl body { do $1; $2 } - | stmt body { do $1; $2 } - -decl :: { CmmParse () } - : type names ';' { mapM_ (newLocal $1) $2 } - | 'import' importNames ';' { mapM_ newImport $2 } - | 'export' names ';' { return () } -- ignore exports - - --- an imported function name, with optional packageId -importNames - :: { [(FastString, CLabel)] } - : importName { [$1] } - | importName ',' importNames { $1 : $3 } - -importName - :: { (FastString, CLabel) } - - -- A label imported without an explicit packageId. - -- These are taken to come frome some foreign, unnamed package. - : NAME - { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } - - -- as previous 'NAME', but 'IsData' - | 'CLOSURE' NAME - { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) } - - -- A label imported with an explicit packageId. - | STRING NAME - { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) } - - -names :: { [FastString] } - : NAME { [$1] } - | NAME ',' names { $1 : $3 } - -stmt :: { CmmParse () } - : ';' { return () } - - | NAME ':' - { do l <- newLabel $1; emitLabel l } - - - - | lreg '=' expr ';' - { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) } - | type '[' expr ']' '=' expr ';' - { withSourceNote $2 $7 (doStore $1 $3 $6) } - - -- Gah! We really want to say "foreign_results" but that causes - -- a shift/reduce conflict with assignment. We either - -- we expand out the no-result and single result cases or - -- we tweak the syntax to avoid the conflict. The later - -- option is taken here because the other way would require - -- multiple levels of expanding and get unwieldy. - | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';' - {% foreignCall $3 $1 $4 $6 $8 $9 } - | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';' - {% primCall $1 $4 $6 } - -- stmt-level macros, stealing syntax from ordinary C-- function calls. - -- Perhaps we ought to use the %%-form? - | NAME '(' exprs0 ')' ';' - {% stmtMacro $1 $3 } - | 'switch' maybe_range expr '{' arms default '}' - { do as <- sequence $5; doSwitch $2 $3 as $6 } - | 'goto' NAME ';' - { do l <- lookupLabel $2; emit (mkBranch l) } - | 'return' '(' exprs0 ')' ';' - { doReturn $3 } - | 'jump' expr vols ';' - { doRawJump $2 $3 } - | 'jump' expr '(' exprs0 ')' ';' - { doJumpWithStack $2 [] $4 } - | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';' - { doJumpWithStack $2 $4 $7 } - | 'call' expr '(' exprs0 ')' ';' - { doCall $2 [] $4 } - | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';' - { doCall $6 $2 $8 } - | 'if' bool_expr 'goto' NAME - { do l <- lookupLabel $4; cmmRawIf $2 l } - | 'if' bool_expr '{' body '}' else - { cmmIfThenElse $2 (withSourceNote $3 $5 $4) $6 } - | 'push' '(' exprs0 ')' maybe_body - { pushStackFrame $3 $5 } - | 'reserve' expr '=' lreg maybe_body - { reserveStackFrame $2 $4 $5 } - | 'unwind' unwind_regs ';' - { $2 >>= code . emitUnwind } - -unwind_regs - :: { CmmParse [(GlobalReg, Maybe CmmExpr)] } - : GLOBALREG '=' expr_or_unknown ',' unwind_regs - { do e <- $3; rest <- $5; return (($1, e) : rest) } - | GLOBALREG '=' expr_or_unknown - { do e <- $3; return [($1, e)] } - --- | Used by unwind to indicate unknown unwinding values. -expr_or_unknown - :: { CmmParse (Maybe CmmExpr) } - : 'return' - { do return Nothing } - | expr - { do e <- $1; return (Just e) } - -foreignLabel :: { CmmParse CmmExpr } - : NAME { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) } - -opt_never_returns :: { CmmReturnInfo } - : { CmmMayReturn } - | 'never' 'returns' { CmmNeverReturns } - -bool_expr :: { CmmParse BoolExpr } - : bool_op { $1 } - | expr { do e <- $1; return (BoolTest e) } - -bool_op :: { CmmParse BoolExpr } - : bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3; - return (BoolAnd e1 e2) } - | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3; - return (BoolOr e1 e2) } - | '!' bool_expr { do e <- $2; return (BoolNot e) } - | '(' bool_op ')' { $2 } - -safety :: { Safety } - : {- empty -} { PlayRisky } - | STRING {% parseSafety $1 } - -vols :: { [GlobalReg] } - : '[' ']' { [] } - | '[' '*' ']' {% do df <- getDynFlags - ; return (realArgRegsCover df) } - -- All of them. See comment attached - -- to realArgRegsCover - | '[' globals ']' { $2 } - -globals :: { [GlobalReg] } - : GLOBALREG { [$1] } - | GLOBALREG ',' globals { $1 : $3 } - -maybe_range :: { Maybe (Integer,Integer) } - : '[' INT '..' INT ']' { Just ($2, $4) } - | {- empty -} { Nothing } - -arms :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] } - : {- empty -} { [] } - | arm arms { $1 : $2 } - -arm :: { CmmParse ([Integer],Either BlockId (CmmParse ())) } - : 'case' ints ':' arm_body { do b <- $4; return ($2, b) } - -arm_body :: { CmmParse (Either BlockId (CmmParse ())) } - : '{' body '}' { return (Right (withSourceNote $1 $3 $2)) } - | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) } - -ints :: { [Integer] } - : INT { [ $1 ] } - | INT ',' ints { $1 : $3 } - -default :: { Maybe (CmmParse ()) } - : 'default' ':' '{' body '}' { Just (withSourceNote $3 $5 $4) } - -- taking a few liberties with the C-- syntax here; C-- doesn't have - -- 'default' branches - | {- empty -} { Nothing } - --- Note: OldCmm doesn't support a first class 'else' statement, though --- CmmNode does. -else :: { CmmParse () } - : {- empty -} { return () } - | 'else' '{' body '}' { withSourceNote $2 $4 $3 } - --- we have to write this out longhand so that Happy's precedence rules --- can kick in. -expr :: { CmmParse CmmExpr } - : expr '/' expr { mkMachOp MO_U_Quot [$1,$3] } - | expr '*' expr { mkMachOp MO_Mul [$1,$3] } - | expr '%' expr { mkMachOp MO_U_Rem [$1,$3] } - | expr '-' expr { mkMachOp MO_Sub [$1,$3] } - | expr '+' expr { mkMachOp MO_Add [$1,$3] } - | expr '>>' expr { mkMachOp MO_U_Shr [$1,$3] } - | expr '<<' expr { mkMachOp MO_Shl [$1,$3] } - | expr '&' expr { mkMachOp MO_And [$1,$3] } - | expr '^' expr { mkMachOp MO_Xor [$1,$3] } - | expr '|' expr { mkMachOp MO_Or [$1,$3] } - | expr '>=' expr { mkMachOp MO_U_Ge [$1,$3] } - | expr '>' expr { mkMachOp MO_U_Gt [$1,$3] } - | expr '<=' expr { mkMachOp MO_U_Le [$1,$3] } - | expr '<' expr { mkMachOp MO_U_Lt [$1,$3] } - | expr '!=' expr { mkMachOp MO_Ne [$1,$3] } - | expr '==' expr { mkMachOp MO_Eq [$1,$3] } - | '~' expr { mkMachOp MO_Not [$2] } - | '-' expr { mkMachOp MO_S_Neg [$2] } - | expr0 '`' NAME '`' expr0 {% do { mo <- nameToMachOp $3 ; - return (mkMachOp mo [$1,$5]) } } - | expr0 { $1 } - -expr0 :: { CmmParse CmmExpr } - : INT maybe_ty { return (CmmLit (CmmInt $1 (typeWidth $2))) } - | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) } - | STRING { do s <- code (newStringCLit $1); - return (CmmLit s) } - | reg { $1 } - | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) } - | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 } - | '(' expr ')' { $2 } - - --- leaving out the type of a literal gives you the native word size in C-- -maybe_ty :: { CmmType } - : {- empty -} {% do dflags <- getDynFlags; return $ bWord dflags } - | '::' type { $2 } - -cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] } - : {- empty -} { [] } - | cmm_hint_exprs { $1 } - -cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] } - : cmm_hint_expr { [$1] } - | cmm_hint_expr ',' cmm_hint_exprs { $1 : $3 } - -cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) } - : expr { do e <- $1; - return (e, inferCmmHint e) } - | expr STRING {% do h <- parseCmmHint $2; - return $ do - e <- $1; return (e, h) } - -exprs0 :: { [CmmParse CmmExpr] } - : {- empty -} { [] } - | exprs { $1 } - -exprs :: { [CmmParse CmmExpr] } - : expr { [ $1 ] } - | expr ',' exprs { $1 : $3 } - -reg :: { CmmParse CmmExpr } - : NAME { lookupName $1 } - | GLOBALREG { return (CmmReg (CmmGlobal $1)) } - -foreign_results :: { [CmmParse (LocalReg, ForeignHint)] } - : {- empty -} { [] } - | '(' foreign_formals ')' '=' { $2 } - -foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] } - : foreign_formal { [$1] } - | foreign_formal ',' { [$1] } - | foreign_formal ',' foreign_formals { $1 : $3 } - -foreign_formal :: { CmmParse (LocalReg, ForeignHint) } - : local_lreg { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) } - | STRING local_lreg {% do h <- parseCmmHint $1; - return $ do - e <- $2; return (e,h) } - -local_lreg :: { CmmParse LocalReg } - : NAME { do e <- lookupName $1; - return $ - case e of - CmmReg (CmmLocal r) -> r - other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") } - -lreg :: { CmmParse CmmReg } - : NAME { do e <- lookupName $1; - return $ - case e of - CmmReg r -> r - other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") } - | GLOBALREG { return (CmmGlobal $1) } - -maybe_formals :: { Maybe [CmmParse LocalReg] } - : {- empty -} { Nothing } - | '(' formals0 ')' { Just $2 } - -formals0 :: { [CmmParse LocalReg] } - : {- empty -} { [] } - | formals { $1 } - -formals :: { [CmmParse LocalReg] } - : formal ',' { [$1] } - | formal { [$1] } - | formal ',' formals { $1 : $3 } - -formal :: { CmmParse LocalReg } - : type NAME { newLocal $1 $2 } - -type :: { CmmType } - : 'bits8' { b8 } - | typenot8 { $1 } - -typenot8 :: { CmmType } - : 'bits16' { b16 } - | 'bits32' { b32 } - | 'bits64' { b64 } - | 'bits128' { b128 } - | 'bits256' { b256 } - | 'bits512' { b512 } - | 'float32' { f32 } - | 'float64' { f64 } - | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags } - -{ -section :: String -> SectionType -section "text" = Text -section "data" = Data -section "rodata" = ReadOnlyData -section "relrodata" = RelocatableReadOnlyData -section "bss" = UninitialisedData -section s = OtherSection s - -mkString :: String -> CmmStatic -mkString s = CmmString (map (fromIntegral.ord) s) - --- | --- Given an info table, decide what the entry convention for the proc --- is. That is, for an INFO_TABLE_RET we want the return convention, --- otherwise it is a NativeNodeCall. --- -infoConv :: Maybe CmmInfoTable -> Convention -infoConv Nothing = NativeNodeCall -infoConv (Just info) - | isStackRep (cit_rep info) = NativeReturn - | otherwise = NativeNodeCall - --- mkMachOp infers the type of the MachOp from the type of its first --- argument. We assume that this is correct: for MachOps that don't have --- symmetrical args (e.g. shift ops), the first arg determines the type of --- the op. -mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr -mkMachOp fn args = do - dflags <- getDynFlags - arg_exprs <- sequence args - return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs) - -getLit :: CmmExpr -> CmmLit -getLit (CmmLit l) = l -getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r -getLit _ = panic "invalid literal" -- TODO messy failure - -nameToMachOp :: FastString -> PD (Width -> MachOp) -nameToMachOp name = - case lookupUFM machOps name of - Nothing -> fail ("unknown primitive " ++ unpackFS name) - Just m -> return m - -exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) -exprOp name args_code = do - dflags <- getDynFlags - case lookupUFM (exprMacros dflags) name of - Just f -> return $ do - args <- sequence args_code - return (f args) - Nothing -> do - mo <- nameToMachOp name - return $ mkMachOp mo args_code - -exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) -exprMacros dflags = listToUFM [ - ( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ), - ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ), - ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), - ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ), - ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ), - ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ), - ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ), - ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), - ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ), - ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x ) - ] - --- we understand a subset of C-- primitives: -machOps = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "add", MO_Add ), - ( "sub", MO_Sub ), - ( "eq", MO_Eq ), - ( "ne", MO_Ne ), - ( "mul", MO_Mul ), - ( "neg", MO_S_Neg ), - ( "quot", MO_S_Quot ), - ( "rem", MO_S_Rem ), - ( "divu", MO_U_Quot ), - ( "modu", MO_U_Rem ), - - ( "ge", MO_S_Ge ), - ( "le", MO_S_Le ), - ( "gt", MO_S_Gt ), - ( "lt", MO_S_Lt ), - - ( "geu", MO_U_Ge ), - ( "leu", MO_U_Le ), - ( "gtu", MO_U_Gt ), - ( "ltu", MO_U_Lt ), - - ( "and", MO_And ), - ( "or", MO_Or ), - ( "xor", MO_Xor ), - ( "com", MO_Not ), - ( "shl", MO_Shl ), - ( "shrl", MO_U_Shr ), - ( "shra", MO_S_Shr ), - - ( "fadd", MO_F_Add ), - ( "fsub", MO_F_Sub ), - ( "fneg", MO_F_Neg ), - ( "fmul", MO_F_Mul ), - ( "fquot", MO_F_Quot ), - - ( "feq", MO_F_Eq ), - ( "fne", MO_F_Ne ), - ( "fge", MO_F_Ge ), - ( "fle", MO_F_Le ), - ( "fgt", MO_F_Gt ), - ( "flt", MO_F_Lt ), - - ( "lobits8", flip MO_UU_Conv W8 ), - ( "lobits16", flip MO_UU_Conv W16 ), - ( "lobits32", flip MO_UU_Conv W32 ), - ( "lobits64", flip MO_UU_Conv W64 ), - - ( "zx16", flip MO_UU_Conv W16 ), - ( "zx32", flip MO_UU_Conv W32 ), - ( "zx64", flip MO_UU_Conv W64 ), - - ( "sx16", flip MO_SS_Conv W16 ), - ( "sx32", flip MO_SS_Conv W32 ), - ( "sx64", flip MO_SS_Conv W64 ), - - ( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode - ( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode - ( "f2i8", flip MO_FS_Conv W8 ), - ( "f2i16", flip MO_FS_Conv W16 ), - ( "f2i32", flip MO_FS_Conv W32 ), - ( "f2i64", flip MO_FS_Conv W64 ), - ( "i2f32", flip MO_SF_Conv W32 ), - ( "i2f64", flip MO_SF_Conv W64 ) - ] - -callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr])) -callishMachOps = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "write_barrier", (,) MO_WriteBarrier ), - ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ), - ( "memset", memcpyLikeTweakArgs MO_Memset ), - ( "memmove", memcpyLikeTweakArgs MO_Memmove ), - - ("prefetch0", (,) $ MO_Prefetch_Data 0), - ("prefetch1", (,) $ MO_Prefetch_Data 1), - ("prefetch2", (,) $ MO_Prefetch_Data 2), - ("prefetch3", (,) $ MO_Prefetch_Data 3), - - ( "popcnt8", (,) $ MO_PopCnt W8 ), - ( "popcnt16", (,) $ MO_PopCnt W16 ), - ( "popcnt32", (,) $ MO_PopCnt W32 ), - ( "popcnt64", (,) $ MO_PopCnt W64 ), - - ( "cmpxchg8", (,) $ MO_Cmpxchg W8 ), - ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ), - ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ), - ( "cmpxchg64", (,) $ MO_Cmpxchg W64 ) - - -- ToDo: the rest, maybe - -- edit: which rest? - -- also: how do we tell CMM Lint how to type check callish macops? - ] - where - memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr]) - memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument" - memcpyLikeTweakArgs op args@(_:_) = - (op align, args') - where - args' = init args - align = case last args of - CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger - e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e) - -- The alignment of memcpy-ish operations must be a - -- compile-time constant. We verify this here, passing it around - -- in the MO_* constructor. In order to do this, however, we - -- must intercept the arguments in primCall. - -parseSafety :: String -> PD Safety -parseSafety "safe" = return PlaySafe -parseSafety "unsafe" = return PlayRisky -parseSafety "interruptible" = return PlayInterruptible -parseSafety str = fail ("unrecognised safety: " ++ str) - -parseCmmHint :: String -> PD ForeignHint -parseCmmHint "ptr" = return AddrHint -parseCmmHint "signed" = return SignedHint -parseCmmHint str = fail ("unrecognised hint: " ++ str) - --- labels are always pointers, so we might as well infer the hint -inferCmmHint :: CmmExpr -> ForeignHint -inferCmmHint (CmmLit (CmmLabel _)) = AddrHint -inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint -inferCmmHint _ = NoHint - -isPtrGlobalReg Sp = True -isPtrGlobalReg SpLim = True -isPtrGlobalReg Hp = True -isPtrGlobalReg HpLim = True -isPtrGlobalReg CCCS = True -isPtrGlobalReg CurrentTSO = True -isPtrGlobalReg CurrentNursery = True -isPtrGlobalReg (VanillaReg _ VGcPtr) = True -isPtrGlobalReg _ = False - -happyError :: PD a -happyError = PD $ \_ s -> unP srcParseFail s - --- ----------------------------------------------------------------------------- --- Statement-level macros - -stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) -stmtMacro fun args_code = do - case lookupUFM stmtMacros fun of - Nothing -> fail ("unknown macro: " ++ unpackFS fun) - Just fcode -> return $ do - args <- sequence args_code - code (fcode args) - -stmtMacros :: UniqFM ([CmmExpr] -> FCode ()) -stmtMacros = listToUFM [ - ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), - ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), - - ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), - ( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ), - - -- completely generic heap and stack checks, for use in high-level cmm. - ( fsLit "HP_CHK_GEN", \[bytes] -> - heapStackCheckGen Nothing (Just bytes) ), - ( fsLit "STK_CHK_GEN", \[] -> - heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ), - - -- A stack check for a fixed amount of stack. Sounds a bit strange, but - -- we use the stack for a bit of temporary storage in a couple of primops - ( fsLit "STK_CHK_GEN_N", \[bytes] -> - heapStackCheckGen (Just bytes) Nothing ), - - -- A stack check on entry to a thunk, where the argument is the thunk pointer. - ( fsLit "STK_CHK_NP" , \[node] -> entryHeapCheck' False node 0 [] (return ())), - - ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), - ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), - - ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), - ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), - - ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), - ( fsLit "SET_HDR", \[ptr,info,ccs] -> - emitSetDynHdr ptr info ccs ), - ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> - tickyAllocPrim hdr goods slop ), - ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> - tickyAllocPAP goods slop ), - ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> - tickyAllocThunk goods slop ), - ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode reg ) - ] - -emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () -emitPushUpdateFrame sp e = do - dflags <- getDynFlags - emitUpdateFrame dflags sp mkUpdInfoLabel e - -pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () -pushStackFrame fields body = do - dflags <- getDynFlags - exprs <- sequence fields - updfr_off <- getUpdFrameOff - let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old - [] updfr_off exprs - emit g - withUpdFrameOff new_updfr_off body - -reserveStackFrame - :: CmmParse CmmExpr - -> CmmParse CmmReg - -> CmmParse () - -> CmmParse () -reserveStackFrame psize preg body = do - dflags <- getDynFlags - old_updfr_off <- getUpdFrameOff - reg <- preg - esize <- psize - let size = case constantFoldExpr dflags esize of - CmmLit (CmmInt n _) -> n - _other -> pprPanic "CmmParse: not a compile-time integer: " - (ppr esize) - let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size - emitAssign reg (CmmStackSlot Old frame) - withUpdFrameOff frame body - -profilingInfo dflags desc_str ty_str - = if not (gopt Opt_SccProfilingOn dflags) - then NoProfilingInfo - else ProfilingInfo (stringToWord8s desc_str) - (stringToWord8s ty_str) - -staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () -staticClosure pkg cl_label info payload - = do dflags <- getDynFlags - let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] - code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits - -foreignCall - :: String - -> [CmmParse (LocalReg, ForeignHint)] - -> CmmParse CmmExpr - -> [CmmParse (CmmExpr, ForeignHint)] - -> Safety - -> CmmReturnInfo - -> PD (CmmParse ()) -foreignCall conv_string results_code expr_code args_code safety ret - = do conv <- case conv_string of - "C" -> return CCallConv - "stdcall" -> return StdCallConv - _ -> fail ("unknown calling convention: " ++ conv_string) - return $ do - dflags <- getDynFlags - results <- sequence results_code - expr <- expr_code - args <- sequence args_code - let - expr' = adjCallTarget dflags conv expr args - (arg_exprs, arg_hints) = unzip args - (res_regs, res_hints) = unzip results - fc = ForeignConvention conv arg_hints res_hints ret - target = ForeignTarget expr' fc - _ <- code $ emitForeignCall safety res_regs target arg_exprs - return () - - -doReturn :: [CmmParse CmmExpr] -> CmmParse () -doReturn exprs_code = do - dflags <- getDynFlags - exprs <- sequence exprs_code - updfr_off <- getUpdFrameOff - emit (mkReturnSimple dflags exprs updfr_off) - -mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph -mkReturnSimple dflags actuals updfr_off = - mkReturn dflags e actuals updfr_off - where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off) - (gcWord dflags)) - -doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () -doRawJump expr_code vols = do - dflags <- getDynFlags - expr <- expr_code - updfr_off <- getUpdFrameOff - emit (mkRawJump dflags expr updfr_off vols) - -doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr] - -> [CmmParse CmmExpr] -> CmmParse () -doJumpWithStack expr_code stk_code args_code = do - dflags <- getDynFlags - expr <- expr_code - stk_args <- sequence stk_code - args <- sequence args_code - updfr_off <- getUpdFrameOff - emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args) - -doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] - -> CmmParse () -doCall expr_code res_code args_code = do - dflags <- getDynFlags - expr <- expr_code - args <- sequence args_code - ress <- sequence res_code - updfr_off <- getUpdFrameOff - c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] - emit c - -adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ] - -> CmmExpr --- On Windows, we have to add the '@N' suffix to the label when making --- a call with the stdcall calling convention. -adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args - | platformOS (targetPlatform dflags) == OSMinGW32 - = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) - where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e))) - -- c.f. CgForeignCall.emitForeignCall -adjCallTarget _ _ expr _ - = expr - -primCall - :: [CmmParse (CmmFormal, ForeignHint)] - -> FastString - -> [CmmParse CmmExpr] - -> PD (CmmParse ()) -primCall results_code name args_code - = case lookupUFM callishMachOps name of - Nothing -> fail ("unknown primitive " ++ unpackFS name) - Just f -> return $ do - results <- sequence results_code - args <- sequence args_code - let (p, args') = f args - code (emitPrimCall (map fst results) p args') - -doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse () -doStore rep addr_code val_code - = do dflags <- getDynFlags - addr <- addr_code - val <- val_code - -- if the specified store type does not match the type of the expr - -- on the rhs, then we insert a coercion that will cause the type - -- mismatch to be flagged by cmm-lint. If we don't do this, then - -- the store will happen at the wrong type, and the error will not - -- be noticed. - let val_width = typeWidth (cmmExprType dflags val) - rep_width = typeWidth rep - let coerce_val - | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] - | otherwise = val - emitStore addr coerce_val - --- ----------------------------------------------------------------------------- --- If-then-else and boolean expressions - -data BoolExpr - = BoolExpr `BoolAnd` BoolExpr - | BoolExpr `BoolOr` BoolExpr - | BoolNot BoolExpr - | BoolTest CmmExpr - --- ToDo: smart constructors which simplify the boolean expression. - -cmmIfThenElse cond then_part else_part = do - then_id <- newBlockId - join_id <- newBlockId - c <- cond - emitCond c then_id - else_part - emit (mkBranch join_id) - emitLabel then_id - then_part - -- fall through to join - emitLabel join_id - -cmmRawIf cond then_id = do - c <- cond - emitCond c then_id - --- 'emitCond cond true_id' emits code to test whether the cond is true, --- branching to true_id if so, and falling through otherwise. -emitCond (BoolTest e) then_id = do - else_id <- newBlockId - emit (mkCbranch e then_id else_id Nothing) - emitLabel else_id -emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id - | Just op' <- maybeInvertComparison op - = emitCond (BoolTest (CmmMachOp op' args)) then_id -emitCond (BoolNot e) then_id = do - else_id <- newBlockId - emitCond e else_id - emit (mkBranch then_id) - emitLabel else_id -emitCond (e1 `BoolOr` e2) then_id = do - emitCond e1 then_id - emitCond e2 then_id -emitCond (e1 `BoolAnd` e2) then_id = do - -- we'd like to invert one of the conditionals here to avoid an - -- extra branch instruction, but we can't use maybeInvertComparison - -- here because we can't look too closely at the expression since - -- we're in a loop. - and_id <- newBlockId - else_id <- newBlockId - emitCond e1 and_id - emit (mkBranch else_id) - emitLabel and_id - emitCond e2 then_id - emitLabel else_id - --- ----------------------------------------------------------------------------- --- Source code notes - --- | Generate a source note spanning from "a" to "b" (inclusive), then --- proceed with parsing. This allows debugging tools to reason about --- locations in Cmm code. -withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c -withSourceNote a b parse = do - name <- getName - case combineSrcSpans (getLoc a) (getLoc b) of - RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse - _other -> parse - --- ----------------------------------------------------------------------------- --- Table jumps - --- We use a simplified form of C-- switch statements for now. A --- switch statement always compiles to a table jump. Each arm can --- specify a list of values (not ranges), and there can be a single --- default branch. The range of the table is given either by the --- optional range on the switch (eg. switch [0..7] {...}), or by --- the minimum/maximum values from the branches. - -doSwitch :: Maybe (Integer,Integer) - -> CmmParse CmmExpr - -> [([Integer],Either BlockId (CmmParse ()))] - -> Maybe (CmmParse ()) -> CmmParse () -doSwitch mb_range scrut arms deflt - = do - -- Compile code for the default branch - dflt_entry <- - case deflt of - Nothing -> return Nothing - Just e -> do b <- forkLabelledCode e; return (Just b) - - -- Compile each case branch - table_entries <- mapM emitArm arms - let table = M.fromList (concat table_entries) - - dflags <- getDynFlags - let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range - - expr <- scrut - -- ToDo: check for out of range and jump to default if necessary - emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table) - where - emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)] - emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] - emitArm (ints,Right code) = do - blockid <- forkLabelledCode code - return [ (i,blockid) | i <- ints ] - -forkLabelledCode :: CmmParse () -> CmmParse BlockId -forkLabelledCode p = do - (_,ag) <- getCodeScoped p - l <- newBlockId - emitOutOfLine l ag - return l - --- ----------------------------------------------------------------------------- --- Putting it all together - --- The initial environment: we define some constants that the compiler --- knows about here. -initEnv :: DynFlags -> Env -initEnv dflags = listToUFM [ - ( fsLit "SIZEOF_StgHeader", - VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )), - ( fsLit "SIZEOF_StgInfoTable", - VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) )) - ] - -parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) -parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do - buf <- hGetStringBuffer filename - let - init_loc = mkRealSrcLoc (mkFastString filename) 1 1 - init_state = (mkPState dflags buf init_loc) { lex_state = [0] } - -- reset the lex_state: the Lexer monad leaves some stuff - -- in there we don't want. - case unPD cmmParse dflags init_state of - PFailed span err -> do - let msg = mkPlainErrMsg dflags span err - return ((emptyBag, unitBag msg), Nothing) - POk pst code -> do - st <- initC - let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return () - (cmm,_) = runC dflags no_module st fcode - let ms = getMessages pst dflags - if (errorsFound dflags ms) - then return (ms, Nothing) - else return (ms, Just cmm) - where - no_module = panic "parseCmmFile: no module" -} diff --git a/cmm/CmmPipeline.hs b/cmm/CmmPipeline.hs deleted file mode 100644 --- a/cmm/CmmPipeline.hs +++ /dev/null @@ -1,365 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module CmmPipeline ( - -- | Converts C-- with an implicit stack and native C-- calls into - -- optimized, CPS converted and native-call-less C--. The latter - -- C-- can be used to generate assembly. - cmmPipeline -) where - -import Cmm -import CmmLint -import CmmBuildInfoTables -import CmmCommonBlockElim -import CmmImplementSwitchPlans -import CmmProcPoint -import CmmContFlowOpt -import CmmLayoutStack -import CmmSink -import Hoopl - -import UniqSupply -import DynFlags -import ErrUtils -import HscTypes -import Control.Monad -import Outputable -import Platform - ------------------------------------------------------------------------------ --- | Top level driver for C-- pipeline ------------------------------------------------------------------------------ - -cmmPipeline :: HscEnv -- Compilation env including - -- dynamic flags: -dcmm-lint -ddump-cmm-cps - -> TopSRT -- SRT table and accumulating list of compiled procs - -> CmmGroup -- Input C-- with Procedures - -> IO (TopSRT, CmmGroup) -- Output CPS transformed C-- - -cmmPipeline hsc_env topSRT prog = - do let dflags = hsc_dflags hsc_env - - tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog - - (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops - dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms) - - return (topSRT, cmms) - - -cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl]) -cpsTop _ p@(CmmData {}) = return (mapEmpty, [p]) -cpsTop hsc_env proc = - do - ----------- Control-flow optimisations ---------------------------------- - - -- The first round of control-flow optimisation speeds up the - -- later passes by removing lots of empty blocks, so we do it - -- even when optimisation isn't turned on. - -- - CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-} - return $ cmmCfgOptsProc splitting_proc_points proc - dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g - - let !TopInfo {stack_info=StackInfo { arg_space = entry_off - , do_layout = do_layout }} = h - - ----------- Eliminate common blocks ------------------------------------- - g <- {-# SCC "elimCommonBlocks" #-} - condPass Opt_CmmElimCommonBlocks elimCommonBlocks g - Opt_D_dump_cmm_cbe "Post common block elimination" - - -- Any work storing block Labels must be performed _after_ - -- elimCommonBlocks - - g <- {-# SCC "createSwitchPlans" #-} - runUniqSM $ cmmImplementSwitchPlans dflags g - dump Opt_D_dump_cmm_switch "Post switch plan" g - - ----------- Proc points ------------------------------------------------- - let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g - proc_points <- - if splitting_proc_points - then do - pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ - minimalProcPointSet (targetPlatform dflags) call_pps g - dumpWith dflags Opt_D_dump_cmm_proc "Proc points" - (ppr l $$ ppr pp $$ ppr g) - return pp - else - return call_pps - - ----------- Layout the stack and manifest Sp ---------------------------- - (g, stackmaps) <- - {-# SCC "layoutStack" #-} - if do_layout - then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g - else return (g, mapEmpty) - dump Opt_D_dump_cmm_sp "Layout Stack" g - - ----------- Sink and inline assignments -------------------------------- - g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] - condPass Opt_CmmSink (cmmSink dflags) g - Opt_D_dump_cmm_sink "Sink assignments" - - ------------- CAF analysis ---------------------------------------------- - let cafEnv = {-# SCC "cafAnal" #-} cafAnal g - dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv) - - g <- if splitting_proc_points - then do - ------------- Split into separate procedures ----------------------- - let pp_map = {-# SCC "procPointAnalysis" #-} - procPointAnalysis proc_points g - dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $ - ppr pp_map - g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ - splitAtProcPoints dflags l call_pps proc_points pp_map - (CmmProc h l v g) - dumps Opt_D_dump_cmm_split "Post splitting" g - return g - else do - -- attach info tables to return points - return $ [attachContInfoTables call_pps (CmmProc h l v g)] - - ------------- Populate info tables with stack info ----------------- - g <- {-# SCC "setInfoTableStackMap" #-} - return $ map (setInfoTableStackMap dflags stackmaps) g - dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g - - ----------- Control-flow optimisations ----------------------------- - g <- {-# SCC "cmmCfgOpts(2)" #-} - return $ if optLevel dflags >= 1 - then map (cmmCfgOptsProc splitting_proc_points) g - else g - g <- return (map removeUnreachableBlocksProc g) - -- See Note [unreachable blocks] - dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g - - return (cafEnv, g) - - where dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - dump = dumpGraph dflags - - dumps flag name - = mapM_ (dumpWith dflags flag name . ppr) - - condPass flag pass g dumpflag dumpname = - if gopt flag dflags - then do - g <- return $ pass g - dump dumpflag dumpname g - return g - else return g - - - -- we don't need to split proc points for the NCG, unless - -- tablesNextToCode is off. The latter is because we have no - -- label to put on info tables for basic blocks that are not - -- the entry point. - splitting_proc_points = hscTarget dflags /= HscAsm - || not (tablesNextToCode dflags) - || -- Note [inconsistent-pic-reg] - usingInconsistentPicReg - usingInconsistentPicReg - = case (platformArch platform, platformOS platform, positionIndependent dflags) - of (ArchX86, OSDarwin, pic) -> pic - (ArchPPC, OSDarwin, pic) -> pic - _ -> False - --- Note [Sinking after stack layout] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- In the past we considered running sinking pass also before stack --- layout, but after making some measurements we realized that: --- --- a) running sinking only before stack layout produces slower --- code than running sinking only before stack layout --- --- b) running sinking both before and after stack layout produces --- code that has the same performance as when running sinking --- only after stack layout. --- --- In other words sinking before stack layout doesn't buy as anything. --- --- An interesting question is "why is it better to run sinking after --- stack layout"? It seems that the major reason are stores and loads --- generated by stack layout. Consider this code before stack layout: --- --- c1E: --- _c1C::P64 = R3; --- _c1B::P64 = R2; --- _c1A::P64 = R1; --- I64[(young + 8)] = c1D; --- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; --- c1D: --- R3 = _c1C::P64; --- R2 = _c1B::P64; --- R1 = _c1A::P64; --- call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8; --- --- Stack layout pass will save all local variables live across a call --- (_c1C, _c1B and _c1A in this example) on the stack just before --- making a call and reload them from the stack after returning from a --- call: --- --- c1E: --- _c1C::P64 = R3; --- _c1B::P64 = R2; --- _c1A::P64 = R1; --- I64[Sp - 32] = c1D; --- P64[Sp - 24] = _c1A::P64; --- P64[Sp - 16] = _c1B::P64; --- P64[Sp - 8] = _c1C::P64; --- Sp = Sp - 32; --- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; --- c1D: --- _c1A::P64 = P64[Sp + 8]; --- _c1B::P64 = P64[Sp + 16]; --- _c1C::P64 = P64[Sp + 24]; --- R3 = _c1C::P64; --- R2 = _c1B::P64; --- R1 = _c1A::P64; --- Sp = Sp + 32; --- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8; --- --- If we don't run sinking pass after stack layout we are basically --- left with such code. However, running sinking on this code can lead --- to significant improvements: --- --- c1E: --- I64[Sp - 32] = c1D; --- P64[Sp - 24] = R1; --- P64[Sp - 16] = R2; --- P64[Sp - 8] = R3; --- Sp = Sp - 32; --- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; --- c1D: --- R3 = P64[Sp + 24]; --- R2 = P64[Sp + 16]; --- R1 = P64[Sp + 8]; --- Sp = Sp + 32; --- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8; --- --- Now we only have 9 assignments instead of 15. --- --- There is one case when running sinking before stack layout could --- be beneficial. Consider this: --- --- L1: --- x = y --- call f() returns L2 --- L2: ...x...y... --- --- Since both x and y are live across a call to f, they will be stored --- on the stack during stack layout and restored after the call: --- --- L1: --- x = y --- P64[Sp - 24] = L2 --- P64[Sp - 16] = x --- P64[Sp - 8] = y --- Sp = Sp - 24 --- call f() returns L2 --- L2: --- y = P64[Sp + 16] --- x = P64[Sp + 8] --- Sp = Sp + 24 --- ...x...y... --- --- However, if we run sinking before stack layout we would propagate x --- to its usage place (both x and y must be local register for this to --- be possible - global registers cannot be floated past a call): --- --- L1: --- x = y --- call f() returns L2 --- L2: ...y...y... --- --- Thus making x dead at the call to f(). If we ran stack layout now --- we would generate less stores and loads: --- --- L1: --- x = y --- P64[Sp - 16] = L2 --- P64[Sp - 8] = y --- Sp = Sp - 16 --- call f() returns L2 --- L2: --- y = P64[Sp + 8] --- Sp = Sp + 16 --- ...y...y... --- --- But since we don't see any benefits from running sinking befroe stack --- layout, this situation probably doesn't arise too often in practice. --- - -{- Note [inconsistent-pic-reg] - -On x86/Darwin, PIC is implemented by inserting a sequence like - - call 1f - 1: popl %reg - -at the proc entry point, and then referring to labels as offsets from -%reg. If we don't split proc points, then we could have many entry -points in a proc that would need this sequence, and each entry point -would then get a different value for %reg. If there are any join -points, then at the join point we don't have a consistent value for -%reg, so we don't know how to refer to labels. - -Hence, on x86/Darwin, we have to split proc points, and then each proc -point will get its own PIC initialisation sequence. - -The situation is the same for ppc/Darwin. We use essentially the same -sequence to load the program counter onto reg: - - bcl 20,31,1f - 1: mflr reg - -This isn't an issue on x86/ELF, where the sequence is - - call 1f - 1: popl %reg - addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg - -so %reg always has a consistent value: the address of -_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. - --} - -{- Note [unreachable blocks] - -The control-flow optimiser sometimes leaves unreachable blocks behind -containing junk code. These aren't necessarily a problem, but -removing them is good because it might save time in the native code -generator later. - --} - -runUniqSM :: UniqSM a -> IO a -runUniqSM m = do - us <- mkSplitUniqSupply 'u' - return (initUs_ us m) - - -dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO () -dumpGraph dflags flag name g = do - when (gopt Opt_DoCmmLinting dflags) $ do_lint g - dumpWith dflags flag name (ppr g) - where - do_lint g = case cmmLintGraph dflags g of - Just err -> do { fatalErrorMsg dflags err - ; ghcExit dflags 1 - } - Nothing -> return () - -dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO () -dumpWith dflags flag txt sdoc = do - -- ToDo: No easy way of say "dump all the cmm, *and* split - -- them into files." Also, -ddump-cmm-verbose doesn't play - -- nicely with -ddump-to-file, since the headers get omitted. - dumpIfSet_dyn dflags flag txt sdoc - when (not (dopt flag dflags)) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose txt sdoc diff --git a/cmm/CmmProcPoint.hs b/cmm/CmmProcPoint.hs deleted file mode 100644 --- a/cmm/CmmProcPoint.hs +++ /dev/null @@ -1,490 +0,0 @@ -{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-} - -module CmmProcPoint - ( ProcPointSet, Status(..) - , callProcPoints, minimalProcPointSet - , splitAtProcPoints, procPointAnalysis - , attachContInfoTables - ) -where - -import Prelude hiding (last, unzip, succ, zip) - -import DynFlags -import BlockId -import CLabel -import Cmm -import PprCmm () -import CmmUtils -import CmmInfo -import CmmLive -import CmmSwitch -import Data.List (sortBy) -import Maybes -import Control.Monad -import Outputable -import Platform -import UniqSupply -import Hoopl - --- Compute a minimal set of proc points for a control-flow graph. - --- Determine a protocol for each proc point (which live variables will --- be passed as arguments and which will be on the stack). - -{- -A proc point is a basic block that, after CPS transformation, will -start a new function. The entry block of the original function is a -proc point, as is the continuation of each function call. -A third kind of proc point arises if we want to avoid copying code. -Suppose we have code like the following: - - f() { - if (...) { ..1..; call foo(); ..2..} - else { ..3..; call bar(); ..4..} - x = y + z; - return x; - } - -The statement 'x = y + z' can be reached from two different proc -points: the continuations of foo() and bar(). We would prefer not to -put a copy in each continuation; instead we would like 'x = y + z' to -be the start of a new procedure to which the continuations can jump: - - f_cps () { - if (...) { ..1..; push k_foo; jump foo_cps(); } - else { ..3..; push k_bar; jump bar_cps(); } - } - k_foo() { ..2..; jump k_join(y, z); } - k_bar() { ..4..; jump k_join(y, z); } - k_join(y, z) { x = y + z; return x; } - -You might think then that a criterion to make a node a proc point is -that it is directly reached by two distinct proc points. (Note -[Direct reachability].) But this criterion is a bit too simple; for -example, 'return x' is also reached by two proc points, yet there is -no point in pulling it out of k_join. A good criterion would be to -say that a node should be made a proc point if it is reached by a set -of proc points that is different than its immediate dominator. NR -believes this criterion can be shown to produce a minimum set of proc -points, and given a dominator tree, the proc points can be chosen in -time linear in the number of blocks. Lacking a dominator analysis, -however, we turn instead to an iterative solution, starting with no -proc points and adding them according to these rules: - - 1. The entry block is a proc point. - 2. The continuation of a call is a proc point. - 3. A node is a proc point if it is directly reached by more proc - points than one of its predecessors. - -Because we don't understand the problem very well, we apply rule 3 at -most once per iteration, then recompute the reachability information. -(See Note [No simple dataflow].) The choice of the new proc point is -arbitrary, and I don't know if the choice affects the final solution, -so I don't know if the number of proc points chosen is the -minimum---but the set will be minimal. - - - -Note [Proc-point analysis] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Given a specified set of proc-points (a set of block-ids), "proc-point -analysis" figures out, for every block, which proc-point it belongs to. -All the blocks belonging to proc-point P will constitute a single -top-level C procedure. - -A non-proc-point block B "belongs to" a proc-point P iff B is -reachable from P without going through another proc-point. - -Invariant: a block B should belong to at most one proc-point; if it -belongs to two, that's a bug. - -Note [Non-existing proc-points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -On some architectures it might happen that the list of proc-points -computed before stack layout pass will be invalidated by the stack -layout. This will happen if stack layout removes from the graph -blocks that were determined to be proc-points. Later on in the pipeline -we use list of proc-points to perform [Proc-point analysis], but -if a proc-point does not exist anymore then we will get compiler panic. -See #8205. --} - -type ProcPointSet = LabelSet - -data Status - = ReachedBy ProcPointSet -- set of proc points that directly reach the block - | ProcPoint -- this block is itself a proc point - -instance Outputable Status where - ppr (ReachedBy ps) - | setNull ps = text "" - | otherwise = text "reached by" <+> - (hsep $ punctuate comma $ map ppr $ setElems ps) - ppr ProcPoint = text "" - --------------------------------------------------- --- Proc point analysis - --- Once you know what the proc-points are, figure out --- what proc-points each block is reachable from --- See Note [Proc-point analysis] -procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status -procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) = - analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints - where - initProcPoints = - mkFactBase - procPointLattice - [ (id, ProcPoint) - | id <- setElems procPoints - -- See Note [Non-existing proc-points] - , id `setMember` labelsInGraph - ] - labelsInGraph = labelsDefined graph - -procPointTransfer :: TransferFun Status -procPointTransfer block facts = - let label = entryLabel block - !fact = case getFact procPointLattice label facts of - ProcPoint -> ReachedBy $! setSingleton label - f -> f - result = map (\id -> (id, fact)) (successors block) - in mkFactBase procPointLattice result - -procPointLattice :: DataflowLattice Status -procPointLattice = DataflowLattice unreached add_to - where - unreached = ReachedBy setEmpty - add_to (OldFact ProcPoint) _ = NotChanged ProcPoint - add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case - add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p')) - | setSize union > setSize p = Changed (ReachedBy union) - | otherwise = NotChanged (ReachedBy p) - where - union = setUnion p' p - ----------------------------------------------------------------------- - --- It is worth distinguishing two sets of proc points: those that are --- induced by calls in the original graph and those that are --- introduced because they're reachable from multiple proc points. --- --- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds]. -callProcPoints :: CmmGraph -> ProcPointSet -callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g - where add :: CmmBlock -> LabelSet -> LabelSet - add b set = case lastNode b of - CmmCall {cml_cont = Just k} -> setInsert k set - CmmForeignCall {succ=k} -> setInsert k set - _ -> set - -minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph - -> UniqSM ProcPointSet --- Given the set of successors of calls (which must be proc-points) --- figure out the minimal set of necessary proc-points -minimalProcPointSet platform callProcPoints g - = extendPPSet platform g (postorderDfs g) callProcPoints - -extendPPSet - :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet -extendPPSet platform g blocks procPoints = - let env = procPointAnalysis procPoints g - add block pps = let id = entryLabel block - in case mapLookup id env of - Just ProcPoint -> setInsert id pps - _ -> pps - procPoints' = foldGraphBlocks add setEmpty g - newPoints = mapMaybe ppSuccessor blocks - newPoint = listToMaybe newPoints - ppSuccessor b = - let nreached id = case mapLookup id env `orElse` - pprPanic "no ppt" (ppr id <+> ppr b) of - ProcPoint -> 1 - ReachedBy ps -> setSize ps - block_procpoints = nreached (entryLabel b) - -- | Looking for a successor of b that is reached by - -- more proc points than b and is not already a proc - -- point. If found, it can become a proc point. - newId succ_id = not (setMember succ_id procPoints') && - nreached succ_id > block_procpoints - in listToMaybe $ filter newId $ successors b - - in case newPoint of - Just id -> - if setMember id procPoints' - then panic "added old proc pt" - else extendPPSet platform g blocks (setInsert id procPoints') - Nothing -> return procPoints' - - --- At this point, we have found a set of procpoints, each of which should be --- the entry point of a procedure. --- Now, we create the procedure for each proc point, --- which requires that we: --- 1. build a map from proc points to the blocks reachable from the proc point --- 2. turn each branch to a proc point into a jump --- 3. turn calls and returns into jumps --- 4. build info tables for the procedures -- and update the info table for --- the SRTs in the entry procedure as well. --- Input invariant: A block should only be reachable from a single ProcPoint. --- ToDo: use the _ret naming convention that the old code generator --- used. -- EZY -splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> - CmmDecl -> UniqSM [CmmDecl] -splitAtProcPoints dflags entry_label callPPs procPoints procMap - (CmmProc (TopInfo {info_tbls = info_tbls}) - top_l _ g@(CmmGraph {g_entry=entry})) = - do -- Build a map from procpoints to the blocks they reach - let addBlock - :: CmmBlock - -> LabelMap (LabelMap CmmBlock) - -> LabelMap (LabelMap CmmBlock) - addBlock b graphEnv = - case mapLookup bid procMap of - Just ProcPoint -> add graphEnv bid bid b - Just (ReachedBy set) -> - case setElems set of - [] -> graphEnv - [id] -> add graphEnv id bid b - _ -> panic "Each block should be reachable from only one ProcPoint" - Nothing -> graphEnv - where bid = entryLabel b - add graphEnv procId bid b = mapInsert procId graph' graphEnv - where graph = mapLookup procId graphEnv `orElse` mapEmpty - graph' = mapInsert bid b graph - - let liveness = cmmGlobalLiveness dflags g - let ppLiveness pp = filter isArgReg $ - regSetToList $ - expectJust "ppLiveness" $ mapLookup pp liveness - - graphEnv <- return $ foldGraphBlocks addBlock mapEmpty g - - -- Build a map from proc point BlockId to pairs of: - -- * Labels for their new procedures - -- * Labels for the info tables of their new procedures (only if - -- the proc point is a callPP) - -- Due to common blockification, we may overestimate the set of procpoints. - let add_label map pp = mapInsert pp lbls map - where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls)) - | otherwise = (block_lbl, guard (setMember pp callPPs) >> - Just (toInfoLbl block_lbl)) - where block_lbl = blockLbl pp - - procLabels :: LabelMap (CLabel, Maybe CLabel) - procLabels = foldl add_label mapEmpty - (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) - - -- In each new graph, add blocks jumping off to the new procedures, - -- and replace branches to procpoints with branches to the jump-off blocks - let add_jump_block - :: (LabelMap Label, [CmmBlock]) - -> (Label, CLabel) - -> UniqSM (LabelMap Label, [CmmBlock]) - add_jump_block (env, bs) (pp, l) = - do bid <- liftM mkBlockId getUniqueM - let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump - live = ppLiveness pp - jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 - return (mapInsert pp bid env, b : bs) - - add_jumps - :: LabelMap CmmGraph - -> (Label, LabelMap CmmBlock) - -> UniqSM (LabelMap CmmGraph) - add_jumps newGraphEnv (ppId, blockEnv) = - do let needed_jumps = -- find which procpoints we currently branch to - mapFold add_if_branch_to_pp [] blockEnv - add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)] - add_if_branch_to_pp block rst = - case lastNode block of - CmmBranch id -> add_if_pp id rst - CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst) - CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids - _ -> rst - - -- when jumping to a PP that has an info table, if - -- tablesNextToCode is off we must jump to the entry - -- label instead. - jump_label (Just info_lbl) _ - | tablesNextToCode dflags = info_lbl - | otherwise = toEntryLbl info_lbl - jump_label Nothing block_lbl = block_lbl - - add_if_pp id rst = case mapLookup id procLabels of - Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst - Nothing -> rst - (jumpEnv, jumpBlocks) <- - foldM add_jump_block (mapEmpty, []) needed_jumps - -- update the entry block - let b = expectJust "block in env" $ mapLookup ppId blockEnv - blockEnv' = mapInsert ppId b blockEnv - -- replace branches to procpoints with branches to jumps - blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' - -- add the jump blocks to the graph - blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks - let g' = ofBlockMap ppId blockEnv''' - -- pprTrace "g' pre jumps" (ppr g') $ do - return (mapInsert ppId g' newGraphEnv) - - graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv - - let to_proc (bid, g) - | bid == entry - = CmmProc (TopInfo {info_tbls = info_tbls, - stack_info = stack_info}) - top_l live g' - | otherwise - = case expectJust "pp label" $ mapLookup bid procLabels of - (lbl, Just info_lbl) - -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) - , stack_info=stack_info}) - lbl live g' - (lbl, Nothing) - -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) - lbl live g' - where - g' = replacePPIds g - live = ppLiveness (g_entry g') - stack_info = StackInfo { arg_space = 0 - , updfr_space = Nothing - , do_layout = True } - -- cannot use panic, this is printed by -ddump-cmm - - -- References to procpoint IDs can now be replaced with the - -- infotable's label - replacePPIds g = {-# SCC "replacePPIds" #-} - mapGraphNodes (id, mapExp repl, mapExp repl) g - where repl e@(CmmLit (CmmBlock bid)) = - case mapLookup bid procLabels of - Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) - _ -> e - repl e = e - - -- The C back end expects to see return continuations before the - -- call sites. Here, we sort them in reverse order -- it gets - -- reversed later. - let (_, block_order) = - foldl add_block_num (0::Int, mapEmpty :: LabelMap Int) - (postorderDfs g) - add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map) - sort_fn (bid, _) (bid', _) = - compare (expectJust "block_order" $ mapLookup bid block_order) - (expectJust "block_order" $ mapLookup bid' block_order) - procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv - return -- pprTrace "procLabels" (ppr procLabels) - -- pprTrace "splitting graphs" (ppr procs) - procs -splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] - --- Only called from CmmProcPoint.splitAtProcPoints. NB. does a --- recursive lookup, see comment below. -replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph -replaceBranches env cmmg - = {-# SCC "replaceBranches" #-} - ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg - where - f block = replaceLastNode block $ last (lastNode block) - - last :: CmmNode O C -> CmmNode O C - last (CmmBranch id) = CmmBranch (lookup id) - last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l - last (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets lookup ids) - last l@(CmmCall {}) = l { cml_cont = Nothing } - -- NB. remove the continuation of a CmmCall, since this - -- label will now be in a different CmmProc. Not only - -- is this tidier, it stops CmmLint from complaining. - last l@(CmmForeignCall {}) = l - lookup id = fmap lookup (mapLookup id env) `orElse` id - -- XXX: this is a recursive lookup, it follows chains - -- until the lookup returns Nothing, at which point we - -- return the last BlockId - --- -------------------------------------------------------------- --- Not splitting proc points: add info tables for continuations - -attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl -attachContInfoTables call_proc_points (CmmProc top_info top_l live g) - = CmmProc top_info{info_tbls = info_tbls'} top_l live g - where - info_tbls' = mapUnion (info_tbls top_info) $ - mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l)) - | l <- setElems call_proc_points - , l /= g_entry g ] -attachContInfoTables _ other_decl - = other_decl - ----------------------------------------------------------------- - -{- -Note [Direct reachability] - -Block B is directly reachable from proc point P iff control can flow -from P to B without passing through an intervening proc point. --} - ----------------------------------------------------------------- - -{- -Note [No simple dataflow] - -Sadly, it seems impossible to compute the proc points using a single -dataflow pass. One might attempt to use this simple lattice: - - data Location = Unknown - | InProc BlockId -- node is in procedure headed by the named proc point - | ProcPoint -- node is itself a proc point - -At a join, a node in two different blocks becomes a proc point. -The difficulty is that the change of information during iterative -computation may promote a node prematurely. Here's a program that -illustrates the difficulty: - - f () { - entry: - .... - L1: - if (...) { ... } - else { ... } - - L2: if (...) { g(); goto L1; } - return x + y; - } - -The only proc-point needed (besides the entry) is L1. But in an -iterative analysis, consider what happens to L2. On the first pass -through, it rises from Unknown to 'InProc entry', but when L1 is -promoted to a proc point (because it's the successor of g()), L1's -successors will be promoted to 'InProc L1'. The problem hits when the -new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'. -The join operation makes it a proc point when in fact it needn't be, -because its immediate dominator L1 is already a proc point and there -are no other proc points that directly reach L2. --} - - - -{- Note [Separate Adams optimization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It may be worthwhile to attempt the Adams optimization by rewriting -the graph before the assignment of proc-point protocols. Here are a -couple of rules: - - g() returns to k; g() returns to L; - k: CopyIn c ress; goto L: - ... ==> ... - L: // no CopyIn node here L: CopyIn c ress; - - -And when c == c' and ress == ress', this also: - - g() returns to k; g() returns to L; - k: CopyIn c ress; goto L: - ... ==> ... - L: CopyIn c' ress' L: CopyIn c' ress' ; - -In both cases the goal is to eliminate k. --} diff --git a/cmm/CmmSink.hs b/cmm/CmmSink.hs deleted file mode 100644 --- a/cmm/CmmSink.hs +++ /dev/null @@ -1,790 +0,0 @@ -{-# LANGUAGE GADTs #-} -module CmmSink ( - cmmSink - ) where - -import Cmm -import CmmOpt -import CmmLive -import CmmUtils -import Hoopl -import CodeGen.Platform -import Platform (isARM, platformArch) - -import DynFlags -import UniqFM -import PprCmm () - -import Data.List (partition) -import qualified Data.Set as Set -import Data.Maybe - --- ----------------------------------------------------------------------------- --- Sinking and inlining - --- This is an optimisation pass that --- (a) moves assignments closer to their uses, to reduce register pressure --- (b) pushes assignments into a single branch of a conditional if possible --- (c) inlines assignments to registers that are mentioned only once --- (d) discards dead assignments --- --- This tightens up lots of register-heavy code. It is particularly --- helpful in the Cmm generated by the Stg->Cmm code generator, in --- which every function starts with a copyIn sequence like: --- --- x1 = R1 --- x2 = Sp[8] --- x3 = Sp[16] --- if (Sp - 32 < SpLim) then L1 else L2 --- --- we really want to push the x1..x3 assignments into the L2 branch. --- --- Algorithm: --- --- * Start by doing liveness analysis. --- --- * Keep a list of assignments A; earlier ones may refer to later ones. --- Currently we only sink assignments to local registers, because we don't --- have liveness information about global registers. --- --- * Walk forwards through the graph, look at each node N: --- --- * If it is a dead assignment, i.e. assignment to a register that is --- not used after N, discard it. --- --- * Try to inline based on current list of assignments --- * If any assignments in A (1) occur only once in N, and (2) are --- not live after N, inline the assignment and remove it --- from A. --- --- * If an assignment in A is cheap (RHS is local register), then --- inline the assignment and keep it in A in case it is used afterwards. --- --- * Otherwise don't inline. --- --- * If N is assignment to a local register pick up the assignment --- and add it to A. --- --- * If N is not an assignment to a local register: --- * remove any assignments from A that conflict with N, and --- place them before N in the current block. We call this --- "dropping" the assignments. --- --- * An assignment conflicts with N if it: --- - assigns to a register mentioned in N --- - mentions a register assigned by N --- - reads from memory written by N --- * do this recursively, dropping dependent assignments --- --- * At an exit node: --- * drop any assignments that are live on more than one successor --- and are not trivial --- * if any successor has more than one predecessor (a join-point), --- drop everything live in that successor. Since we only propagate --- assignments that are not dead at the successor, we will therefore --- eliminate all assignments dead at this point. Thus analysis of a --- join-point will always begin with an empty list of assignments. --- --- --- As a result of above algorithm, sinking deletes some dead assignments --- (transitively, even). This isn't as good as removeDeadAssignments, --- but it's much cheaper. - --- ----------------------------------------------------------------------------- --- things that we aren't optimising very well yet. --- --- ----------- --- (1) From GHC's FastString.hashStr: --- --- s2ay: --- if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp; --- c2gn: --- R1 = _s2au::I64; --- call (I64[Sp])(R1) args: 8, res: 0, upd: 8; --- c2gp: --- _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128, --- 4091); --- _s2an::I64 = _s2an::I64 + 1; --- _s2au::I64 = _s2cO::I64; --- goto s2ay; --- --- a nice loop, but we didn't eliminate the silly assignment at the end. --- See Note [dependent assignments], which would probably fix this. --- This is #8336 on Trac. --- --- ----------- --- (2) From stg_atomically_frame in PrimOps.cmm --- --- We have a diamond control flow: --- --- x = ... --- | --- / \ --- A B --- \ / --- | --- use of x --- --- Now x won't be sunk down to its use, because we won't push it into --- both branches of the conditional. We certainly do have to check --- that we can sink it past all the code in both A and B, but having --- discovered that, we could sink it to its use. --- - --- ----------------------------------------------------------------------------- - -type Assignment = (LocalReg, CmmExpr, AbsMem) - -- Assignment caches AbsMem, an abstraction of the memory read by - -- the RHS of the assignment. - -type Assignments = [Assignment] - -- A sequence of assignments; kept in *reverse* order - -- So the list [ x=e1, y=e2 ] means the sequence of assignments - -- y = e2 - -- x = e1 - -cmmSink :: DynFlags -> CmmGraph -> CmmGraph -cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks - where - liveness = cmmLocalLiveness dflags graph - getLive l = mapFindWithDefault Set.empty l liveness - - blocks = postorderDfs graph - - join_pts = findJoinPoints blocks - - sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock] - sink _ [] = [] - sink sunk (b:bs) = - -- pprTrace "sink" (ppr lbl) $ - blockJoin first final_middle final_last : sink sunk' bs - where - lbl = entryLabel b - (first, middle, last) = blockSplit b - - succs = successors last - - -- Annotate the middle nodes with the registers live *after* - -- the node. This will help us decide whether we can inline - -- an assignment in the current node or not. - live = Set.unions (map getLive succs) - live_middle = gen_kill dflags last live - ann_middles = annotate dflags live_middle (blockToList middle) - - -- Now sink and inline in this block - (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk) - fold_last = constantFoldNode dflags last - (final_last, assigs') = tryToInline dflags live fold_last assigs - - -- We cannot sink into join points (successors with more than - -- one predecessor), so identify the join points and the set - -- of registers live in them. - (joins, nonjoins) = partition (`mapMember` join_pts) succs - live_in_joins = Set.unions (map getLive joins) - - -- We do not want to sink an assignment into multiple branches, - -- so identify the set of registers live in multiple successors. - -- This is made more complicated because when we sink an assignment - -- into one branch, this might change the set of registers that are - -- now live in multiple branches. - init_live_sets = map getLive nonjoins - live_in_multi live_sets r = - case filter (Set.member r) live_sets of - (_one:_two:_) -> True - _ -> False - - -- Now, drop any assignments that we will not sink any further. - (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs' - - drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') - where - should_drop = conflicts dflags a final_last - || not (isTrivial dflags rhs) && live_in_multi live_sets r - || r `Set.member` live_in_joins - - live_sets' | should_drop = live_sets - | otherwise = map upd live_sets - - upd set | r `Set.member` set = set `Set.union` live_rhs - | otherwise = set - - live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs - - final_middle = foldl blockSnoc middle' dropped_last - - sunk' = mapUnion sunk $ - mapFromList [ (l, filterAssignments dflags (getLive l) assigs'') - | l <- succs ] - -{- TODO: enable this later, when we have some good tests in place to - measure the effect and tune it. - --- small: an expression we don't mind duplicating -isSmall :: CmmExpr -> Bool -isSmall (CmmReg (CmmLocal _)) = True -- -isSmall (CmmLit _) = True -isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y -isSmall (CmmRegOff (CmmLocal _) _) = True -isSmall _ = False --} - --- --- We allow duplication of trivial expressions: registers (both local and --- global) and literals. --- -isTrivial :: DynFlags -> CmmExpr -> Bool -isTrivial _ (CmmReg (CmmLocal _)) = True -isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?] - if isARM (platformArch (targetPlatform dflags)) - then True -- CodeGen.Platform.ARM does not have globalRegMaybe - else isJust (globalRegMaybe (targetPlatform dflags) r) - -- GlobalRegs that are loads from BaseReg are not trivial -isTrivial _ (CmmLit _) = True -isTrivial _ _ = False - --- --- annotate each node with the set of registers live *after* the node --- -annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)] -annotate dflags live nodes = snd $ foldr ann (live,[]) nodes - where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes) - --- --- Find the blocks that have multiple successors (join points) --- -findJoinPoints :: [CmmBlock] -> LabelMap Int -findJoinPoints blocks = mapFilter (>1) succ_counts - where - all_succs = concatMap successors blocks - - succ_counts :: LabelMap Int - succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs - --- --- filter the list of assignments to remove any assignments that --- are not live in a continuation. --- -filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments -filterAssignments dflags live assigs = reverse (go assigs []) - where go [] kept = kept - go (a@(r,_,_):as) kept | needed = go as (a:kept) - | otherwise = go as kept - where - needed = r `Set.member` live - || any (conflicts dflags a) (map toNode kept) - -- Note that we must keep assignments that are - -- referred to by other assignments we have - -- already kept. - --- ----------------------------------------------------------------------------- --- Walk through the nodes of a block, sinking and inlining assignments --- as we go. --- --- On input we pass in a: --- * list of nodes in the block --- * a list of assignments that appeared *before* this block and --- that are being sunk. --- --- On output we get: --- * a new block --- * a list of assignments that will be placed *after* that block. --- - -walk :: DynFlags - -> [(LocalRegSet, CmmNode O O)] -- nodes of the block, annotated with - -- the set of registers live *after* - -- this node. - - -> Assignments -- The current list of - -- assignments we are sinking. - -- Earlier assignments may refer - -- to later ones. - - -> ( Block CmmNode O O -- The new block - , Assignments -- Assignments to sink further - ) - -walk dflags nodes assigs = go nodes emptyBlock assigs - where - go [] block as = (block, as) - go ((live,node):ns) block as - | shouldDiscard node live = go ns block as - -- discard dead assignment - | Just a <- shouldSink dflags node2 = go ns block (a : as1) - | otherwise = go ns block' as' - where - node1 = constantFoldNode dflags node - - (node2, as1) = tryToInline dflags live node1 as - - (dropped, as') = dropAssignmentsSimple dflags - (\a -> conflicts dflags a node2) as1 - - block' = foldl blockSnoc block dropped `blockSnoc` node2 - - --- --- Heuristic to decide whether to pick up and sink an assignment --- Currently we pick up all assignments to local registers. It might --- be profitable to sink assignments to global regs too, but the --- liveness analysis doesn't track those (yet) so we can't. --- -shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment -shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e) - where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e -shouldSink _ _other = Nothing - --- --- discard dead assignments. This doesn't do as good a job as --- removeDeadAssignments, because it would need multiple passes --- to get all the dead code, but it catches the common case of --- superfluous reloads from the stack that the stack allocator --- leaves behind. --- --- Also we catch "r = r" here. You might think it would fall --- out of inlining, but the inliner will see that r is live --- after the instruction and choose not to inline r in the rhs. --- -shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool -shouldDiscard node live - = case node of - CmmAssign r (CmmReg r') | r == r' -> True - CmmAssign (CmmLocal r) _ -> not (r `Set.member` live) - _otherwise -> False - - -toNode :: Assignment -> CmmNode O O -toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs - -dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments - -> ([CmmNode O O], Assignments) -dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) () - -dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments - -> ([CmmNode O O], Assignments) -dropAssignments dflags should_drop state assigs - = (dropped, reverse kept) - where - (dropped,kept) = go state assigs [] [] - - go _ [] dropped kept = (dropped, kept) - go state (assig : rest) dropped kept - | conflict = go state' rest (toNode assig : dropped) kept - | otherwise = go state' rest dropped (assig:kept) - where - (dropit, state') = should_drop assig state - conflict = dropit || any (conflicts dflags assig) dropped - - --- ----------------------------------------------------------------------------- --- Try to inline assignments into a node. - -tryToInline - :: DynFlags - -> LocalRegSet -- set of registers live after this - -- node. We cannot inline anything - -- that is live after the node, unless - -- it is small enough to duplicate. - -> CmmNode O x -- The node to inline into - -> Assignments -- Assignments to inline - -> ( - CmmNode O x -- New node - , Assignments -- Remaining assignments - ) - -tryToInline dflags live node assigs = go usages node [] assigs - where - usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used - usages = foldLocalRegsUsed dflags addUsage emptyUFM node - - go _usages node _skipped [] = (node, []) - - go usages node skipped (a@(l,rhs,_) : rest) - | cannot_inline = dont_inline - | occurs_none = discard -- Note [discard during inlining] - | occurs_once = inline_and_discard - | isTrivial dflags rhs = inline_and_keep - | otherwise = dont_inline - where - inline_and_discard = go usages' inl_node skipped rest - where usages' = foldLocalRegsUsed dflags addUsage usages rhs - - discard = go usages node skipped rest - - dont_inline = keep node -- don't inline the assignment, keep it - inline_and_keep = keep inl_node -- inline the assignment, keep it - - keep node' = (final_node, a : rest') - where (final_node, rest') = go usages' node' (l:skipped) rest - usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2) - usages rhs - -- we must not inline anything that is mentioned in the RHS - -- of a binding that we have already skipped, so we set the - -- usages of the regs on the RHS to 2. - - cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments] - || l `elem` skipped - || not (okToInline dflags rhs node) - - l_usages = lookupUFM usages l - l_live = l `elemRegSet` live - - occurs_once = not l_live && l_usages == Just 1 - occurs_none = not l_live && l_usages == Nothing - - inl_node = mapExpDeep inline node - -- mapExpDeep is where the inlining actually takes place! - where inline (CmmReg (CmmLocal l')) | l == l' = rhs - inline (CmmRegOff (CmmLocal l') off) | l == l' - = cmmOffset dflags rhs off - -- re-constant fold after inlining - inline (CmmMachOp op args) = cmmMachOpFold dflags op args - inline other = other - --- Note [dependent assignments] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- If our assignment list looks like --- --- [ y = e, x = ... y ... ] --- --- We cannot inline x. Remember this list is really in reverse order, --- so it means x = ... y ...; y = e --- --- Hence if we inline x, the outer assignment to y will capture the --- reference in x's right hand side. --- --- In this case we should rename the y in x's right-hand side, --- i.e. change the list to [ y = e, x = ... y1 ..., y1 = y ] --- Now we can go ahead and inline x. --- --- For now we do nothing, because this would require putting --- everything inside UniqSM. --- --- One more variant of this (#7366): --- --- [ y = e, y = z ] --- --- If we don't want to inline y = e, because y is used many times, we --- might still be tempted to inline y = z (because we always inline --- trivial rhs's). But of course we can't, because y is equal to e, --- not z. - --- Note [discard during inlining] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Opportunities to discard assignments sometimes appear after we've --- done some inlining. Here's an example: --- --- x = R1; --- y = P64[x + 7]; --- z = P64[x + 15]; --- /* z is dead */ --- R1 = y & (-8); --- --- The x assignment is trivial, so we inline it in the RHS of y, and --- keep both x and y. z gets dropped because it is dead, then we --- inline y, and we have a dead assignment to x. If we don't notice --- that x is dead in tryToInline, we end up retaining it. - -addUsage :: UniqFM Int -> LocalReg -> UniqFM Int -addUsage m r = addToUFM_C (+) m r 1 - -regsUsedIn :: [LocalReg] -> CmmExpr -> Bool -regsUsedIn [] _ = False -regsUsedIn ls e = wrapRecExpf f e False - where f (CmmReg (CmmLocal l)) _ | l `elem` ls = True - f (CmmRegOff (CmmLocal l) _) _ | l `elem` ls = True - f _ z = z - --- we don't inline into CmmUnsafeForeignCall if the expression refers --- to global registers. This is a HACK to avoid global registers --- clashing with C argument-passing registers, really the back-end --- ought to be able to handle it properly, but currently neither PprC --- nor the NCG can do it. See Note [Register parameter passing] --- See also StgCmmForeign:load_args_into_temps. -okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool -okToInline dflags expr node@(CmmUnsafeForeignCall{}) = - not (globalRegistersConflict dflags expr node) -okToInline _ _ _ = True - --- ----------------------------------------------------------------------------- - --- | @conflicts (r,e) node@ is @False@ if and only if the assignment --- @r = e@ can be safely commuted past statement @node@. -conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool -conflicts dflags (r, rhs, addr) node - - -- (1) node defines registers used by rhs of assignment. This catches - -- assignments and all three kinds of calls. See Note [Sinking and calls] - | globalRegistersConflict dflags rhs node = True - | localRegistersConflict dflags rhs node = True - - -- (2) node uses register defined by assignment - | foldRegsUsed dflags (\b r' -> r == r' || b) False node = True - - -- (3) a store to an address conflicts with a read of the same memory - | CmmStore addr' e <- node - , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True - - -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively - | HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True - | StackMem <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True - | SpMem{} <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True - - -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap] - | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem = True - - -- (6) native calls clobber any memory - | CmmCall{} <- node, memConflicts addr AnyMem = True - - -- (7) otherwise, no conflict - | otherwise = False - --- Returns True if node defines any global registers that are used in the --- Cmm expression -globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool -globalRegistersConflict dflags expr node = - foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr) - False node - --- Returns True if node defines any local registers that are used in the --- Cmm expression -localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool -localRegistersConflict dflags expr node = - foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal r) expr) - False node - --- Note [Sinking and calls] --- ~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall) --- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after --- stack layout (see Note [Sinking after stack layout]) which leads to two --- invariants related to calls: --- --- a) during stack layout phase all safe foreign calls are turned into --- unsafe foreign calls (see Note [Lower safe foreign calls]). This --- means that we will never encounter CmmForeignCall node when running --- sinking after stack layout --- --- b) stack layout saves all variables live across a call on the stack --- just before making a call (remember we are not sinking assignments to --- stack): --- --- L1: --- x = R1 --- P64[Sp - 16] = L2 --- P64[Sp - 8] = x --- Sp = Sp - 16 --- call f() returns L2 --- L2: --- --- We will attempt to sink { x = R1 } but we will detect conflict with --- { P64[Sp - 8] = x } and hence we will drop { x = R1 } without even --- checking whether it conflicts with { call f() }. In this way we will --- never need to check any assignment conflicts with CmmCall. Remember --- that we still need to check for potential memory conflicts. --- --- So the result is that we only need to worry about CmmUnsafeForeignCall nodes --- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]). --- This assumption holds only when we do sinking after stack layout. If we run --- it before stack layout we need to check for possible conflicts with all three --- kinds of calls. Our `conflicts` function does that by using a generic --- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and --- UserOfRegs typeclasses. --- - --- An abstraction of memory read or written. -data AbsMem - = NoMem -- no memory accessed - | AnyMem -- arbitrary memory - | HeapMem -- definitely heap memory - | StackMem -- definitely stack memory - | SpMem -- [Sp+n] - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - --- Having SpMem is important because it lets us float loads from Sp --- past stores to Sp as long as they don't overlap, and this helps to --- unravel some long sequences of --- x1 = [Sp + 8] --- x2 = [Sp + 16] --- ... --- [Sp + 8] = xi --- [Sp + 16] = xj --- --- Note that SpMem is invalidated if Sp is changed, but the definition --- of 'conflicts' above handles that. - --- ToDo: this won't currently fix the following commonly occurring code: --- x1 = [R1 + 8] --- x2 = [R1 + 16] --- .. --- [Hp - 8] = x1 --- [Hp - 16] = x2 --- .. - --- because [R1 + 8] and [Hp - 8] are both HeapMem. We know that --- assignments to [Hp + n] do not conflict with any other heap memory, --- but this is tricky to nail down. What if we had --- --- x = Hp + n --- [x] = ... --- --- the store to [x] should be "new heap", not "old heap". --- Furthermore, you could imagine that if we started inlining --- functions in Cmm then there might well be reads of heap memory --- that was written in the same basic block. To take advantage of --- non-aliasing of heap memory we will have to be more clever. - --- Note [Foreign calls clobber heap] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- It is tempting to say that foreign calls clobber only --- non-heap/stack memory, but unfortunately we break this invariant in --- the RTS. For example, in stg_catch_retry_frame we call --- stmCommitNestedTransaction() which modifies the contents of the --- TRec it is passed (this actually caused incorrect code to be --- generated). --- --- Since the invariant is true for the majority of foreign calls, --- perhaps we ought to have a special annotation for calls that can --- modify heap/stack memory. For now we just use the conservative --- definition here. --- --- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and --- therefore we should never float any memory operations across one of --- these calls. - - -bothMems :: AbsMem -> AbsMem -> AbsMem -bothMems NoMem x = x -bothMems x NoMem = x -bothMems HeapMem HeapMem = HeapMem -bothMems StackMem StackMem = StackMem -bothMems (SpMem o1 w1) (SpMem o2 w2) - | o1 == o2 = SpMem o1 (max w1 w2) - | otherwise = StackMem -bothMems SpMem{} StackMem = StackMem -bothMems StackMem SpMem{} = StackMem -bothMems _ _ = AnyMem - -memConflicts :: AbsMem -> AbsMem -> Bool -memConflicts NoMem _ = False -memConflicts _ NoMem = False -memConflicts HeapMem StackMem = False -memConflicts StackMem HeapMem = False -memConflicts SpMem{} HeapMem = False -memConflicts HeapMem SpMem{} = False -memConflicts (SpMem o1 w1) (SpMem o2 w2) - | o1 < o2 = o1 + w1 > o2 - | otherwise = o2 + w2 > o1 -memConflicts _ _ = True - -exprMem :: DynFlags -> CmmExpr -> AbsMem -exprMem dflags (CmmLoad addr w) = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr) -exprMem dflags (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem dflags) es) -exprMem _ _ = NoMem - -loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem -loadAddr dflags e w = - case e of - CmmReg r -> regAddr dflags r 0 w - CmmRegOff r i -> regAddr dflags r i w - _other | regUsedIn dflags (CmmGlobal Sp) e -> StackMem - | otherwise -> AnyMem - -regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem -regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w) -regAddr _ (CmmGlobal Hp) _ _ = HeapMem -regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps -regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself -regAddr _ _ _ _ = AnyMem - -{- -Note [Inline GlobalRegs?] - -Should we freely inline GlobalRegs? - -Actually it doesn't make a huge amount of difference either way, so we -*do* currently treat GlobalRegs as "trivial" and inline them -everywhere, but for what it's worth, here is what I discovered when I -(SimonM) looked into this: - -Common sense says we should not inline GlobalRegs, because when we -have - - x = R1 - -the register allocator will coalesce this assignment, generating no -code, and simply record the fact that x is bound to $rbx (or -whatever). Furthermore, if we were to sink this assignment, then the -range of code over which R1 is live increases, and the range of code -over which x is live decreases. All things being equal, it is better -for x to be live than R1, because R1 is a fixed register whereas x can -live in any register. So we should neither sink nor inline 'x = R1'. - -However, not inlining GlobalRegs can have surprising -consequences. e.g. (cgrun020) - - c3EN: - _s3DB::P64 = R1; - _c3ES::P64 = _s3DB::P64 & 7; - if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV; - c3EU: - _s3DD::P64 = P64[_s3DB::P64 + 6]; - _s3DE::P64 = P64[_s3DB::P64 + 14]; - I64[Sp - 8] = c3F0; - R1 = _s3DE::P64; - P64[Sp] = _s3DD::P64; - -inlining the GlobalReg gives: - - c3EN: - if (R1 & 7 >= 2) goto c3EU; else goto c3EV; - c3EU: - I64[Sp - 8] = c3F0; - _s3DD::P64 = P64[R1 + 6]; - R1 = P64[R1 + 14]; - P64[Sp] = _s3DD::P64; - -but if we don't inline the GlobalReg, instead we get: - - _s3DB::P64 = R1; - if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV; - c3EU: - I64[Sp - 8] = c3F0; - R1 = P64[_s3DB::P64 + 14]; - P64[Sp] = P64[_s3DB::P64 + 6]; - -This looks better - we managed to inline _s3DD - but in fact it -generates an extra reg-reg move: - -.Lc3EU: - movq $c3F0_info,-8(%rbp) - movq %rbx,%rax - movq 14(%rbx),%rbx - movq 6(%rax),%rax - movq %rax,(%rbp) - -because _s3DB is now live across the R1 assignment, we lost the -benefit of coalescing. - -Who is at fault here? Perhaps if we knew that _s3DB was an alias for -R1, then we would not sink a reference to _s3DB past the R1 -assignment. Or perhaps we *should* do that - we might gain by sinking -it, despite losing the coalescing opportunity. - -Sometimes not inlining global registers wins by virtue of the rule -about not inlining into arguments of a foreign call, e.g. (T7163) this -is what happens when we inlined F1: - - _s3L2::F32 = F1; - _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32); - (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(_c3O3::F32); - -but if we don't inline F1: - - (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(%MO_F_Mul_W32(_s3L2::F32, - 10.0 :: W32)); --} diff --git a/cmm/CmmSwitch.hs b/cmm/CmmSwitch.hs deleted file mode 100644 --- a/cmm/CmmSwitch.hs +++ /dev/null @@ -1,433 +0,0 @@ -{-# LANGUAGE GADTs #-} -module CmmSwitch ( - SwitchTargets, - mkSwitchTargets, - switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned, - mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough, - switchTargetsToList, eqSwitchTargetWith, - - SwitchPlan(..), - targetSupportsSwitch, - createSwitchPlan, - ) where - -import Outputable -import DynFlags -import Compiler.Hoopl (Label) - -import Data.Maybe -import Data.List (groupBy) -import Data.Function (on) -import qualified Data.Map as M - --- Note [Cmm Switches, the general plan] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Compiling a high-level switch statement, as it comes out of a STG case --- expression, for example, allows for a surprising amount of design decisions. --- Therefore, we cleanly separated this from the Stg → Cmm transformation, as --- well as from the actual code generation. --- --- The overall plan is: --- * The Stg → Cmm transformation creates a single `SwitchTargets` in --- emitSwitch and emitCmmLitSwitch in StgCmmUtils.hs. --- At this stage, they are unsuitable for code generation. --- * A dedicated Cmm transformation (CmmImplementSwitchPlans) replaces these --- switch statements with code that is suitable for code generation, i.e. --- a nice balanced tree of decisions with dense jump tables in the leafs. --- The actual planning of this tree is performed in pure code in createSwitchPlan --- in this module. See Note [createSwitchPlan]. --- * The actual code generation will not do any further processing and --- implement each CmmSwitch with a jump tables. --- --- When compiling to LLVM or C, CmmImplementSwitchPlans leaves the switch --- statements alone, as we can turn a SwitchTargets value into a nice --- switch-statement in LLVM resp. C, and leave the rest to the compiler. --- --- See Note [CmmSwitch vs. CmmImplementSwitchPlans] why the two module are --- separated. - ------------------------------------------------------------------------------ --- Note [Magic Constants in CmmSwitch] --- --- There are a lot of heuristics here that depend on magic values where it is --- hard to determine the "best" value (for whatever that means). These are the --- magic values: - --- | Number of consecutive default values allowed in a jump table. If there are --- more of them, the jump tables are split. --- --- Currently 7, as it costs 7 words of additional code when a jump table is --- split (at least on x64, determined experimentally). -maxJumpTableHole :: Integer -maxJumpTableHole = 7 - --- | Minimum size of a jump table. If the number is smaller, the switch is --- implemented using conditionals. --- Currently 5, because an if-then-else tree of 4 values is nice and compact. -minJumpTableSize :: Int -minJumpTableSize = 5 - --- | Minimum non-zero offset for a jump table. See Note [Jump Table Offset]. -minJumpTableOffset :: Integer -minJumpTableOffset = 2 - - ------------------------------------------------------------------------------ --- Switch Targets - --- Note [SwitchTargets]: --- ~~~~~~~~~~~~~~~~~~~~~ --- --- The branches of a switch are stored in a SwitchTargets, which consists of an --- (optional) default jump target, and a map from values to jump targets. --- --- If the default jump target is absent, the behaviour of the switch outside the --- values of the map is undefined. --- --- We use an Integer for the keys the map so that it can be used in switches on --- unsigned as well as signed integers. --- --- The map may be empty (we prune out-of-range branches here, so it could be us --- emptying it). --- --- Before code generation, the table needs to be brought into a form where all --- entries are non-negative, so that it can be compiled into a jump table. --- See switchTargetsToTable. - - --- | A value of type SwitchTargets contains the alternatives for a 'CmmSwitch' --- value, and knows whether the value is signed, the possible range, an --- optional default value and a map from values to jump labels. -data SwitchTargets = - SwitchTargets - Bool -- Signed values - (Integer, Integer) -- Range - (Maybe Label) -- Default value - (M.Map Integer Label) -- The branches - deriving (Show, Eq) - --- | The smart constructr mkSwitchTargets normalises the map a bit: --- * No entries outside the range --- * No entries equal to the default --- * No default if all elements have explicit values -mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets -mkSwitchTargets signed range@(lo,hi) mbdef ids - = SwitchTargets signed range mbdef' ids' - where - ids' = dropDefault $ restrict ids - mbdef' | defaultNeeded = mbdef - | otherwise = Nothing - - -- Drop entries outside the range, if there is a range - restrict = restrictMap (lo,hi) - - -- Drop entries that equal the default, if there is a default - dropDefault | Just l <- mbdef = M.filter (/= l) - | otherwise = id - - -- Check if the default is still needed - defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1 - - --- | Changes all labels mentioned in the SwitchTargets value -mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets -mapSwitchTargets f (SwitchTargets signed range mbdef branches) - = SwitchTargets signed range (fmap f mbdef) (fmap f branches) - --- | Returns the list of non-default branches of the SwitchTargets value -switchTargetsCases :: SwitchTargets -> [(Integer, Label)] -switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches - --- | Return the default label of the SwitchTargets value -switchTargetsDefault :: SwitchTargets -> Maybe Label -switchTargetsDefault (SwitchTargets _ _ mbdef _) = mbdef - --- | Return the range of the SwitchTargets value -switchTargetsRange :: SwitchTargets -> (Integer, Integer) -switchTargetsRange (SwitchTargets _ range _ _) = range - --- | Return whether this is used for a signed value -switchTargetsSigned :: SwitchTargets -> Bool -switchTargetsSigned (SwitchTargets signed _ _ _) = signed - --- | switchTargetsToTable creates a dense jump table, usable for code generation. --- --- Also returns an offset to add to the value; the list is 0-based on the --- result of that addition. --- --- The conversion from Integer to Int is a bit of a wart, as the actual --- scrutinee might be an unsigned word, but it just works, due to wrap-around --- arithmetic (as verified by the CmmSwitchTest test case). -switchTargetsToTable :: SwitchTargets -> (Int, [Maybe Label]) -switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches) - = (fromIntegral (-start), [ labelFor i | i <- [start..hi] ]) - where - labelFor i = case M.lookup i branches of Just l -> Just l - Nothing -> mbdef - start | lo >= 0 && lo < minJumpTableOffset = 0 -- See Note [Jump Table Offset] - | otherwise = lo - --- Note [Jump Table Offset] --- ~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Usually, the code for a jump table starting at x will first subtract x from --- the value, to avoid a large amount of empty entries. But if x is very small, --- the extra entries are no worse than the subtraction in terms of code size, and --- not having to do the subtraction is quicker. --- --- I.e. instead of --- _u20N: --- leaq -1(%r14),%rax --- jmp *_n20R(,%rax,8) --- _n20R: --- .quad _c20p --- .quad _c20q --- do --- _u20N: --- jmp *_n20Q(,%r14,8) --- --- _n20Q: --- .quad 0 --- .quad _c20p --- .quad _c20q --- .quad _c20r - --- | The list of all labels occuring in the SwitchTargets value. -switchTargetsToList :: SwitchTargets -> [Label] -switchTargetsToList (SwitchTargets _ _ mbdef branches) - = maybeToList mbdef ++ M.elems branches - --- | Groups cases with equal targets, suitable for pretty-printing to a --- c-like switch statement with fall-through semantics. -switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label) -switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef) - where - groups = map (\xs -> (map fst xs, snd (head xs))) $ - groupBy ((==) `on` snd) $ - M.toList branches - --- | Custom equality helper, needed for "CmmCommonBlockElim" -eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool -eqSwitchTargetWith eq (SwitchTargets signed1 range1 mbdef1 ids1) (SwitchTargets signed2 range2 mbdef2 ids2) = - signed1 == signed2 && range1 == range2 && goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2) - where - goMB Nothing Nothing = True - goMB (Just l1) (Just l2) = l1 `eq` l2 - goMB _ _ = False - goList [] [] = True - goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2 - goList _ _ = False - ------------------------------------------------------------------------------ --- Code generation for Switches - - --- | A SwitchPlan abstractly describes how a Switch statement ought to be --- implemented. See Note [createSwitchPlan] -data SwitchPlan - = Unconditionally Label - | IfEqual Integer Label SwitchPlan - | IfLT Bool Integer SwitchPlan SwitchPlan - | JumpTable SwitchTargets - deriving Show --- --- Note [createSwitchPlan] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- --- A SwitchPlan describes how a Switch statement is to be broken down into --- smaller pieces suitable for code generation. --- --- createSwitchPlan creates such a switch plan, in these steps: --- 1. It splits the switch statement at segments of non-default values that --- are too large. See splitAtHoles and Note [Magic Constants in CmmSwitch] --- 2. Too small jump tables should be avoided, so we break up smaller pieces --- in breakTooSmall. --- 3. We fill in the segments between those pieces with a jump to the default --- label (if there is one), returning a SeparatedList in mkFlatSwitchPlan --- 4. We find and replace two less-than branches by a single equal-to-test in --- findSingleValues --- 5. The thus collected pieces are assembled to a balanced binary tree. - - --- | Does the target support switch out of the box? Then leave this to the --- target! -targetSupportsSwitch :: HscTarget -> Bool -targetSupportsSwitch HscC = True -targetSupportsSwitch HscLlvm = True -targetSupportsSwitch _ = False - --- | This function creates a SwitchPlan from a SwitchTargets value, breaking it --- down into smaller pieces suitable for code generation. -createSwitchPlan :: SwitchTargets -> SwitchPlan --- Lets do the common case of a singleton map quicky and efficiently (#10677) -createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m) - | [(x, l)] <- M.toList m - = IfEqual x l (Unconditionally defLabel) --- And another common case, matching booleans -createSwitchPlan (SwitchTargets _signed (lo,hi) Nothing m) - | [(x1, l1), (x2,l2)] <- M.toAscList m - , x1 == lo - , x2 == hi - , x1 + 1 == x2 - = IfEqual x1 l1 (Unconditionally l2) -createSwitchPlan (SwitchTargets signed range mbdef m) = - -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $ - plan - where - pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m - flatPlan = findSingleValues $ mkFlatSwitchPlan signed mbdef range pieces - plan = buildTree signed $ flatPlan - - ---- ---- Step 1: Splitting at large holes ---- -splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a] -splitAtHoles _ m | M.null m = [] -splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles - where - holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m)) - nonHoles = reassocTuples lo holes hi - - (lo,_) = M.findMin m - (hi,_) = M.findMax m - ---- ---- Step 2: Avoid small jump tables ---- --- We do not want jump tables below a certain size. This breaks them up --- (into singleton maps, for now). -breakTooSmall :: M.Map Integer a -> [M.Map Integer a] -breakTooSmall m - | M.size m > minJumpTableSize = [m] - | otherwise = [M.singleton k v | (k,v) <- M.toList m] - ---- ---- Step 3: Fill in the blanks ---- - --- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every --- two entries, dividing the range. --- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if --- the expression is < n, and plan2 otherwise. - -type FlatSwitchPlan = SeparatedList Integer SwitchPlan - -mkFlatSwitchPlan :: Bool -> Maybe Label -> (Integer, Integer) -> [M.Map Integer Label] -> FlatSwitchPlan - --- If we have no default (i.e. undefined where there is no entry), we can --- branch at the minimum of each map -mkFlatSwitchPlan _ Nothing _ [] = pprPanic "mkFlatSwitchPlan with nothing left to do" empty -mkFlatSwitchPlan signed Nothing _ (m:ms) - = (mkLeafPlan signed Nothing m , [ (fst (M.findMin m'), mkLeafPlan signed Nothing m') | m' <- ms ]) - --- If we have a default, we have to interleave segments that jump --- to the default between the maps -mkFlatSwitchPlan signed (Just l) r ms = let ((_,p1):ps) = go r ms in (p1, ps) - where - go (lo,hi) [] - | lo > hi = [] - | otherwise = [(lo, Unconditionally l)] - go (lo,hi) (m:ms) - | lo < min - = (lo, Unconditionally l) : go (min,hi) (m:ms) - | lo == min - = (lo, mkLeafPlan signed (Just l) m) : go (max+1,hi) ms - | otherwise - = pprPanic "mkFlatSwitchPlan" (integer lo <+> integer min) - where - min = fst (M.findMin m) - max = fst (M.findMax m) - - -mkLeafPlan :: Bool -> Maybe Label -> M.Map Integer Label -> SwitchPlan -mkLeafPlan signed mbdef m - | [(_,l)] <- M.toList m -- singleton map - = Unconditionally l - | otherwise - = JumpTable $ mkSwitchTargets signed (min,max) mbdef m - where - min = fst (M.findMin m) - max = fst (M.findMax m) - ---- ---- Step 4: Reduce the number of branches using == ---- - --- A sequence of three unconditional jumps, with the outer two pointing to the --- same value and the bounds off by exactly one can be improved -findSingleValues :: FlatSwitchPlan -> FlatSwitchPlan -findSingleValues (Unconditionally l, (i, Unconditionally l2) : (i', Unconditionally l3) : xs) - | l == l3 && i + 1 == i' - = findSingleValues (IfEqual i l2 (Unconditionally l), xs) -findSingleValues (p, (i,p'):xs) - = (p,i) `consSL` findSingleValues (p', xs) -findSingleValues (p, []) - = (p, []) - ---- ---- Step 5: Actually build the tree ---- - --- Build a balanced tree from a separated list -buildTree :: Bool -> FlatSwitchPlan -> SwitchPlan -buildTree _ (p,[]) = p -buildTree signed sl = IfLT signed m (buildTree signed sl1) (buildTree signed sl2) - where - (sl1, m, sl2) = divideSL sl - - - --- --- Utility data type: Non-empty lists with extra markers in between each --- element: --- - -type SeparatedList b a = (a, [(b,a)]) - -consSL :: (a, b) -> SeparatedList b a -> SeparatedList b a -consSL (a, b) (a', xs) = (a, (b,a'):xs) - -divideSL :: SeparatedList b a -> (SeparatedList b a, b, SeparatedList b a) -divideSL (_,[]) = error "divideSL: Singleton SeparatedList" -divideSL (p,xs) = ((p, xs1), m, (p', xs2)) - where - (xs1, (m,p'):xs2) = splitAt (length xs `div` 2) xs - --- --- Other Utilities --- - -restrictMap :: (Integer,Integer) -> M.Map Integer b -> M.Map Integer b -restrictMap (lo,hi) m = mid - where (_, mid_hi) = M.split (lo-1) m - (mid, _) = M.split (hi+1) mid_hi - --- for example: reassocTuples a [(b,c),(d,e)] f == [(a,b),(c,d),(e,f)] -reassocTuples :: a -> [(a,a)] -> a -> [(a,a)] -reassocTuples initial [] last - = [(initial,last)] -reassocTuples initial ((a,b):tuples) last - = (initial,a) : reassocTuples b tuples last - --- Note [CmmSwitch vs. CmmImplementSwitchPlans] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- I (Joachim) separated the two somewhat closely related modules --- --- - CmmSwitch, which provides the CmmSwitchTargets type and contains the strategy --- for implementing a Cmm switch (createSwitchPlan), and --- - CmmImplementSwitchPlans, which contains the actuall Cmm graph modification, --- --- for these reasons: --- --- * CmmSwitch is very low in the dependency tree, i.e. does not depend on any --- GHC specific modules at all (with the exception of Output and Hoople --- (Literal)). CmmImplementSwitchPlans is the Cmm transformation and hence very --- high in the dependency tree. --- * CmmSwitch provides the CmmSwitchTargets data type, which is abstract, but --- used in CmmNodes. --- * Because CmmSwitch is low in the dependency tree, the separation allows --- for more parallelism when building GHC. --- * The interaction between the modules is very explicit and easy to --- understand, due to the small and simple interface. diff --git a/cmm/CmmType.hs b/cmm/CmmType.hs deleted file mode 100644 --- a/cmm/CmmType.hs +++ /dev/null @@ -1,439 +0,0 @@ -{-# LANGUAGE CPP #-} - -module CmmType - ( CmmType -- Abstract - , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord - , cInt - , cmmBits, cmmFloat - , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood - , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32 - - , Width(..) - , widthInBits, widthInBytes, widthInLog, widthFromBytes - , wordWidth, halfWordWidth, cIntWidth - , halfWordMask - , narrowU, narrowS - , rEP_CostCentreStack_mem_alloc - , rEP_CostCentreStack_scc_count - , rEP_StgEntCounter_allocs - , rEP_StgEntCounter_allocd - - , ForeignHint(..) - - , Length - , vec, vec2, vec4, vec8, vec16 - , vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 - , cmmVec - , vecLength, vecElemType - , isVecType - ) -where - -#include "HsVersions.h" - -import DynFlags -import FastString -import Outputable - -import Data.Word -import Data.Int - ------------------------------------------------------------------------------ --- CmmType ------------------------------------------------------------------------------ - - -- NOTE: CmmType is an abstract type, not exported from this - -- module so you can easily change its representation - -- - -- However Width is exported in a concrete way, - -- and is used extensively in pattern-matching - -data CmmType -- The important one! - = CmmType CmmCat Width - -data CmmCat -- "Category" (not exported) - = GcPtrCat -- GC pointer - | BitsCat -- Non-pointer - | FloatCat -- Float - | VecCat Length CmmCat -- Vector - deriving( Eq ) - -- See Note [Signed vs unsigned] at the end - -instance Outputable CmmType where - ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid) - -instance Outputable CmmCat where - ppr FloatCat = text "F" - ppr GcPtrCat = text "P" - ppr BitsCat = text "I" - ppr (VecCat n cat) = ppr cat <> text "x" <> ppr n <> text "V" - --- Why is CmmType stratified? For native code generation, --- most of the time you just want to know what sort of register --- to put the thing in, and for this you need to know how --- many bits thing has and whether it goes in a floating-point --- register. By contrast, the distinction between GcPtr and --- GcNonPtr is of interest to only a few parts of the code generator. - --------- Equality on CmmType -------------- --- CmmType is *not* an instance of Eq; sometimes we care about the --- Gc/NonGc distinction, and sometimes we don't --- So we use an explicit function to force you to think about it -cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality -cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2 - -cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool - -- This equality is temporary; used in CmmLint - -- but the RTS files are not yet well-typed wrt pointers -cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2) - = c1 `weak_eq` c2 && w1==w2 - where - weak_eq :: CmmCat -> CmmCat -> Bool - FloatCat `weak_eq` FloatCat = True - FloatCat `weak_eq` _other = False - _other `weak_eq` FloatCat = False - (VecCat l1 cat1) `weak_eq` (VecCat l2 cat2) = l1 == l2 - && cat1 `weak_eq` cat2 - (VecCat {}) `weak_eq` _other = False - _other `weak_eq` (VecCat {}) = False - _word1 `weak_eq` _word2 = True -- Ignores GcPtr - ---- Simple operations on CmmType ----- -typeWidth :: CmmType -> Width -typeWidth (CmmType _ w) = w - -cmmBits, cmmFloat :: Width -> CmmType -cmmBits = CmmType BitsCat -cmmFloat = CmmType FloatCat - --------- Common CmmTypes ------------ --- Floats and words of specific widths -b8, b16, b32, b64, b128, b256, b512, f32, f64 :: CmmType -b8 = cmmBits W8 -b16 = cmmBits W16 -b32 = cmmBits W32 -b64 = cmmBits W64 -b128 = cmmBits W128 -b256 = cmmBits W256 -b512 = cmmBits W512 -f32 = cmmFloat W32 -f64 = cmmFloat W64 - --- CmmTypes of native word widths -bWord :: DynFlags -> CmmType -bWord dflags = cmmBits (wordWidth dflags) - -bHalfWord :: DynFlags -> CmmType -bHalfWord dflags = cmmBits (halfWordWidth dflags) - -gcWord :: DynFlags -> CmmType -gcWord dflags = CmmType GcPtrCat (wordWidth dflags) - -cInt :: DynFlags -> CmmType -cInt dflags = cmmBits (cIntWidth dflags) - ------------- Predicates ---------------- -isFloatType, isGcPtrType :: CmmType -> Bool -isFloatType (CmmType FloatCat _) = True -isFloatType _other = False - -isGcPtrType (CmmType GcPtrCat _) = True -isGcPtrType _other = False - -isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool --- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise) --- isFloat32 and 64 are obvious - -isWord64 (CmmType BitsCat W64) = True -isWord64 (CmmType GcPtrCat W64) = True -isWord64 _other = False - -isWord32 (CmmType BitsCat W32) = True -isWord32 (CmmType GcPtrCat W32) = True -isWord32 _other = False - -isFloat32 (CmmType FloatCat W32) = True -isFloat32 _other = False - -isFloat64 (CmmType FloatCat W64) = True -isFloat64 _other = False - ------------------------------------------------------------------------------ --- Width ------------------------------------------------------------------------------ - -data Width = W8 | W16 | W32 | W64 - | W80 -- Extended double-precision float, - -- used in x86 native codegen only. - -- (we use Ord, so it'd better be in this order) - | W128 - | W256 - | W512 - deriving (Eq, Ord, Show) - -instance Outputable Width where - ppr rep = ptext (mrStr rep) - -mrStr :: Width -> LitString -mrStr W8 = sLit("W8") -mrStr W16 = sLit("W16") -mrStr W32 = sLit("W32") -mrStr W64 = sLit("W64") -mrStr W128 = sLit("W128") -mrStr W256 = sLit("W256") -mrStr W512 = sLit("W512") -mrStr W80 = sLit("W80") - - --------- Common Widths ------------ -wordWidth :: DynFlags -> Width -wordWidth dflags - | wORD_SIZE dflags == 4 = W32 - | wORD_SIZE dflags == 8 = W64 - | otherwise = panic "MachOp.wordRep: Unknown word size" - -halfWordWidth :: DynFlags -> Width -halfWordWidth dflags - | wORD_SIZE dflags == 4 = W16 - | wORD_SIZE dflags == 8 = W32 - | otherwise = panic "MachOp.halfWordRep: Unknown word size" - -halfWordMask :: DynFlags -> Integer -halfWordMask dflags - | wORD_SIZE dflags == 4 = 0xFFFF - | wORD_SIZE dflags == 8 = 0xFFFFFFFF - | otherwise = panic "MachOp.halfWordMask: Unknown word size" - --- cIntRep is the Width for a C-language 'int' -cIntWidth :: DynFlags -> Width -cIntWidth dflags = case cINT_SIZE dflags of - 4 -> W32 - 8 -> W64 - s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s) - -widthInBits :: Width -> Int -widthInBits W8 = 8 -widthInBits W16 = 16 -widthInBits W32 = 32 -widthInBits W64 = 64 -widthInBits W128 = 128 -widthInBits W256 = 256 -widthInBits W512 = 512 -widthInBits W80 = 80 - -widthInBytes :: Width -> Int -widthInBytes W8 = 1 -widthInBytes W16 = 2 -widthInBytes W32 = 4 -widthInBytes W64 = 8 -widthInBytes W128 = 16 -widthInBytes W256 = 32 -widthInBytes W512 = 64 -widthInBytes W80 = 10 - -widthFromBytes :: Int -> Width -widthFromBytes 1 = W8 -widthFromBytes 2 = W16 -widthFromBytes 4 = W32 -widthFromBytes 8 = W64 -widthFromBytes 16 = W128 -widthFromBytes 32 = W256 -widthFromBytes 64 = W512 -widthFromBytes 10 = W80 -widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n) - --- log_2 of the width in bytes, useful for generating shifts. -widthInLog :: Width -> Int -widthInLog W8 = 0 -widthInLog W16 = 1 -widthInLog W32 = 2 -widthInLog W64 = 3 -widthInLog W128 = 4 -widthInLog W256 = 5 -widthInLog W512 = 6 -widthInLog W80 = panic "widthInLog: F80" - --- widening / narrowing - -narrowU :: Width -> Integer -> Integer -narrowU W8 x = fromIntegral (fromIntegral x :: Word8) -narrowU W16 x = fromIntegral (fromIntegral x :: Word16) -narrowU W32 x = fromIntegral (fromIntegral x :: Word32) -narrowU W64 x = fromIntegral (fromIntegral x :: Word64) -narrowU _ _ = panic "narrowTo" - -narrowS :: Width -> Integer -> Integer -narrowS W8 x = fromIntegral (fromIntegral x :: Int8) -narrowS W16 x = fromIntegral (fromIntegral x :: Int16) -narrowS W32 x = fromIntegral (fromIntegral x :: Int32) -narrowS W64 x = fromIntegral (fromIntegral x :: Int64) -narrowS _ _ = panic "narrowTo" - ------------------------------------------------------------------------------ --- SIMD ------------------------------------------------------------------------------ - -type Length = Int - -vec :: Length -> CmmType -> CmmType -vec l (CmmType cat w) = CmmType (VecCat l cat) vecw - where - vecw :: Width - vecw = widthFromBytes (l*widthInBytes w) - -vec2, vec4, vec8, vec16 :: CmmType -> CmmType -vec2 = vec 2 -vec4 = vec 4 -vec8 = vec 8 -vec16 = vec 16 - -vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 :: CmmType -vec2f64 = vec 2 f64 -vec2b64 = vec 2 b64 -vec4f32 = vec 4 f32 -vec4b32 = vec 4 b32 -vec8b16 = vec 8 b16 -vec16b8 = vec 16 b8 - -cmmVec :: Int -> CmmType -> CmmType -cmmVec n (CmmType cat w) = - CmmType (VecCat n cat) (widthFromBytes (n*widthInBytes w)) - -vecLength :: CmmType -> Length -vecLength (CmmType (VecCat l _) _) = l -vecLength _ = panic "vecLength: not a vector" - -vecElemType :: CmmType -> CmmType -vecElemType (CmmType (VecCat l cat) w) = CmmType cat scalw - where - scalw :: Width - scalw = widthFromBytes (widthInBytes w `div` l) -vecElemType _ = panic "vecElemType: not a vector" - -isVecType :: CmmType -> Bool -isVecType (CmmType (VecCat {}) _) = True -isVecType _ = False - -------------------------------------------------------------------------- --- Hints - --- Hints are extra type information we attach to the arguments and --- results of a foreign call, where more type information is sometimes --- needed by the ABI to make the correct kind of call. - -data ForeignHint - = NoHint | AddrHint | SignedHint - deriving( Eq ) - -- Used to give extra per-argument or per-result - -- information needed by foreign calling conventions - -------------------------------------------------------------------------- - --- These don't really belong here, but I don't know where is best to --- put them. - -rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType -rEP_CostCentreStack_mem_alloc dflags - = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc)) - where pc = sPlatformConstants (settings dflags) - -rEP_CostCentreStack_scc_count :: DynFlags -> CmmType -rEP_CostCentreStack_scc_count dflags - = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc)) - where pc = sPlatformConstants (settings dflags) - -rEP_StgEntCounter_allocs :: DynFlags -> CmmType -rEP_StgEntCounter_allocs dflags - = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc)) - where pc = sPlatformConstants (settings dflags) - -rEP_StgEntCounter_allocd :: DynFlags -> CmmType -rEP_StgEntCounter_allocd dflags - = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc)) - where pc = sPlatformConstants (settings dflags) - -------------------------------------------------------------------------- -{- Note [Signed vs unsigned] - ~~~~~~~~~~~~~~~~~~~~~~~~~ -Should a CmmType include a signed vs. unsigned distinction? - -This is very much like a "hint" in C-- terminology: it isn't necessary -in order to generate correct code, but it might be useful in that the -compiler can generate better code if it has access to higher-level -hints about data. This is important at call boundaries, because the -definition of a function is not visible at all of its call sites, so -the compiler cannot infer the hints. - -Here in Cmm, we're taking a slightly different approach. We include -the int vs. float hint in the CmmType, because (a) the majority of -platforms have a strong distinction between float and int registers, -and (b) we don't want to do any heavyweight hint-inference in the -native code backend in order to get good code. We're treating the -hint more like a type: our Cmm is always completely consistent with -respect to hints. All coercions between float and int are explicit. - -What about the signed vs. unsigned hint? This information might be -useful if we want to keep sub-word-sized values in word-size -registers, which we must do if we only have word-sized registers. - -On such a system, there are two straightforward conventions for -representing sub-word-sized values: - -(a) Leave the upper bits undefined. Comparison operations must - sign- or zero-extend both operands before comparing them, - depending on whether the comparison is signed or unsigned. - -(b) Always keep the values sign- or zero-extended as appropriate. - Arithmetic operations must narrow the result to the appropriate - size. - -A clever compiler might not use either (a) or (b) exclusively, instead -it would attempt to minimize the coercions by analysis: the same kind -of analysis that propagates hints around. In Cmm we don't want to -have to do this, so we plump for having richer types and keeping the -type information consistent. - -If signed/unsigned hints are missing from CmmType, then the only -choice we have is (a), because we don't know whether the result of an -operation should be sign- or zero-extended. - -Many architectures have extending load operations, which work well -with (b). To make use of them with (a), you need to know whether the -value is going to be sign- or zero-extended by an enclosing comparison -(for example), which involves knowing above the context. This is -doable but more complex. - -Further complicating the issue is foreign calls: a foreign calling -convention can specify that signed 8-bit quantities are passed as -sign-extended 32 bit quantities, for example (this is the case on the -PowerPC). So we *do* need sign information on foreign call arguments. - -Pros for adding signed vs. unsigned to CmmType: - - - It would let us use convention (b) above, and get easier - code generation for extending loads. - - - Less information required on foreign calls. - - - MachOp type would be simpler - -Cons: - - - More complexity - - - What is the CmmType for a VanillaReg? Currently it is - always wordRep, but now we have to decide whether it is - signed or unsigned. The same VanillaReg can thus have - different CmmType in different parts of the program. - - - Extra coercions cluttering up expressions. - -Currently for GHC, the foreign call point is moot, because we do our -own promotion of sub-word-sized values to word-sized values. The Int8 -type is represented by an Int# which is kept sign-extended at all times -(this is slightly naughty, because we're making assumptions about the -C calling convention rather early on in the compiler). However, given -this, the cons outweigh the pros. - --} - diff --git a/cmm/CmmUtils.hs b/cmm/CmmUtils.hs deleted file mode 100644 --- a/cmm/CmmUtils.hs +++ /dev/null @@ -1,568 +0,0 @@ -{-# LANGUAGE CPP, GADTs, RankNTypes #-} - ------------------------------------------------------------------------------ --- --- Cmm utilities. --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module CmmUtils( - -- CmmType - primRepCmmType, slotCmmType, slotForeignHint, - typeCmmType, typeForeignHint, primRepForeignHint, - - -- CmmLit - zeroCLit, mkIntCLit, - mkWordCLit, packHalfWordsCLit, - mkByteStringCLit, - mkDataLits, mkRODataLits, - mkStgWordCLit, - - -- CmmExpr - mkIntExpr, zeroExpr, - mkLblExpr, - cmmRegOff, cmmOffset, cmmLabelOff, cmmOffsetLit, cmmOffsetExpr, - cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB, - cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW, - cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW, - cmmNegate, - cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, - cmmSLtWord, - cmmNeWord, cmmEqWord, - cmmOrWord, cmmAndWord, - cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord, - cmmToWord, - - isTrivialCmmExpr, hasNoGlobalRegs, - - -- Statics - blankWord, - - -- Tagging - cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, - cmmConstrTag1, - - -- Overlap and usage - regsOverlap, regUsedIn, - - -- Liveness and bitmaps - mkLiveness, - - -- * Operations that probably don't belong here - modifyGraph, - - ofBlockMap, toBlockMap, insertBlock, - ofBlockList, toBlockList, bodyToBlockList, - toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough, - foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1, - - -- * Ticks - blockTicks - ) where - -#include "HsVersions.h" - -import TyCon ( PrimRep(..), PrimElemRep(..) ) -import RepType ( UnaryType, SlotTy (..), typePrimRep1 ) - -import SMRep -import Cmm -import BlockId -import CLabel -import Outputable -import DynFlags -import Util -import CodeGen.Platform - -import Data.Word -import Data.Maybe -import Data.Bits -import Hoopl - ---------------------------------------------------- --- --- CmmTypes --- ---------------------------------------------------- - -primRepCmmType :: DynFlags -> PrimRep -> CmmType -primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep" -primRepCmmType dflags LiftedRep = gcWord dflags -primRepCmmType dflags UnliftedRep = gcWord dflags -primRepCmmType dflags IntRep = bWord dflags -primRepCmmType dflags WordRep = bWord dflags -primRepCmmType _ Int64Rep = b64 -primRepCmmType _ Word64Rep = b64 -primRepCmmType dflags AddrRep = bWord dflags -primRepCmmType _ FloatRep = f32 -primRepCmmType _ DoubleRep = f64 -primRepCmmType _ (VecRep len rep) = vec len (primElemRepCmmType rep) - -slotCmmType :: DynFlags -> SlotTy -> CmmType -slotCmmType dflags PtrSlot = gcWord dflags -slotCmmType dflags WordSlot = bWord dflags -slotCmmType _ Word64Slot = b64 -slotCmmType _ FloatSlot = f32 -slotCmmType _ DoubleSlot = f64 - -primElemRepCmmType :: PrimElemRep -> CmmType -primElemRepCmmType Int8ElemRep = b8 -primElemRepCmmType Int16ElemRep = b16 -primElemRepCmmType Int32ElemRep = b32 -primElemRepCmmType Int64ElemRep = b64 -primElemRepCmmType Word8ElemRep = b8 -primElemRepCmmType Word16ElemRep = b16 -primElemRepCmmType Word32ElemRep = b32 -primElemRepCmmType Word64ElemRep = b64 -primElemRepCmmType FloatElemRep = f32 -primElemRepCmmType DoubleElemRep = f64 - -typeCmmType :: DynFlags -> UnaryType -> CmmType -typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty) - -primRepForeignHint :: PrimRep -> ForeignHint -primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" -primRepForeignHint LiftedRep = AddrHint -primRepForeignHint UnliftedRep = AddrHint -primRepForeignHint IntRep = SignedHint -primRepForeignHint WordRep = NoHint -primRepForeignHint Int64Rep = SignedHint -primRepForeignHint Word64Rep = NoHint -primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg -primRepForeignHint FloatRep = NoHint -primRepForeignHint DoubleRep = NoHint -primRepForeignHint (VecRep {}) = NoHint - -slotForeignHint :: SlotTy -> ForeignHint -slotForeignHint PtrSlot = AddrHint -slotForeignHint WordSlot = NoHint -slotForeignHint Word64Slot = NoHint -slotForeignHint FloatSlot = NoHint -slotForeignHint DoubleSlot = NoHint - -typeForeignHint :: UnaryType -> ForeignHint -typeForeignHint = primRepForeignHint . typePrimRep1 - ---------------------------------------------------- --- --- CmmLit --- ---------------------------------------------------- - --- XXX: should really be Integer, since Int doesn't necessarily cover --- the full range of target Ints. -mkIntCLit :: DynFlags -> Int -> CmmLit -mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags) - -mkIntExpr :: DynFlags -> Int -> CmmExpr -mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i - -zeroCLit :: DynFlags -> CmmLit -zeroCLit dflags = CmmInt 0 (wordWidth dflags) - -zeroExpr :: DynFlags -> CmmExpr -zeroExpr dflags = CmmLit (zeroCLit dflags) - -mkWordCLit :: DynFlags -> Integer -> CmmLit -mkWordCLit dflags wd = CmmInt wd (wordWidth dflags) - -mkByteStringCLit - :: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt) --- We have to make a top-level decl for the string, --- and return a literal pointing to it -mkByteStringCLit lbl bytes - = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes]) - where - -- This can not happen for String literals (as there \NUL is replaced by - -- C0 80). However, it can happen with Addr# literals. - sec = if 0 `elem` bytes then ReadOnlyData else CString - -mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt --- Build a data-segment data block -mkDataLits section lbl lits - = CmmData section (Statics lbl $ map CmmStaticLit lits) - -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt --- Build a read-only data block -mkRODataLits lbl lits - = mkDataLits section lbl lits - where - section | any needsRelocation lits = Section RelocatableReadOnlyData lbl - | otherwise = Section ReadOnlyData lbl - needsRelocation (CmmLabel _) = True - needsRelocation (CmmLabelOff _ _) = True - needsRelocation _ = False - -mkStgWordCLit :: DynFlags -> StgWord -> CmmLit -mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags) - -packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit --- Make a single word literal in which the lower_half_word is --- at the lower address, and the upper_half_word is at the --- higher address --- ToDo: consider using half-word lits instead --- but be careful: that's vulnerable when reversed -packHalfWordsCLit dflags lower_half_word upper_half_word - = if wORDS_BIGENDIAN dflags - then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u) - else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags)) - where l = fromStgHalfWord lower_half_word - u = fromStgHalfWord upper_half_word - ---------------------------------------------------- --- --- CmmExpr --- ---------------------------------------------------- - -mkLblExpr :: CLabel -> CmmExpr -mkLblExpr lbl = CmmLit (CmmLabel lbl) - -cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr --- assumes base and offset have the same CmmType -cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n) -cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off] - -cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr -cmmOffset _ e 0 = e -cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off -cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off) -cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off) -cmmOffset _ (CmmStackSlot area off) byte_off - = CmmStackSlot area (off - byte_off) - -- note stack area offsets increase towards lower addresses -cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2 - = CmmMachOp (MO_Add rep) - [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)] -cmmOffset dflags expr byte_off - = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)] - where - width = cmmExprWidth dflags expr - --- Smart constructor for CmmRegOff. Same caveats as cmmOffset above. -cmmRegOff :: CmmReg -> Int -> CmmExpr -cmmRegOff reg 0 = CmmReg reg -cmmRegOff reg byte_off = CmmRegOff reg byte_off - -cmmOffsetLit :: CmmLit -> Int -> CmmLit -cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off -cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off) -cmmOffsetLit (CmmLabelDiffOff l1 l2 m) byte_off - = CmmLabelDiffOff l1 l2 (m+byte_off) -cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep -cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off) - -cmmLabelOff :: CLabel -> Int -> CmmLit --- Smart constructor for CmmLabelOff -cmmLabelOff lbl 0 = CmmLabel lbl -cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off - --- | Useful for creating an index into an array, with a statically known offset. --- The type is the element type; used for making the multiplier -cmmIndex :: DynFlags - -> Width -- Width w - -> CmmExpr -- Address of vector of items of width w - -> Int -- Which element of the vector (0 based) - -> CmmExpr -- Address of i'th element -cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width) - --- | Useful for creating an index into an array, with an unknown offset. -cmmIndexExpr :: DynFlags - -> Width -- Width w - -> CmmExpr -- Address of vector of items of width w - -> CmmExpr -- Which element of the vector (0 based) - -> CmmExpr -- Address of i'th element -cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n) -cmmIndexExpr dflags width base idx = - cmmOffsetExpr dflags base byte_off - where - idx_w = cmmExprWidth dflags idx - byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)] - -cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr -cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty - --- The "B" variants take byte offsets -cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr -cmmRegOffB = cmmRegOff - -cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr -cmmOffsetB = cmmOffset - -cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr -cmmOffsetExprB = cmmOffsetExpr - -cmmLabelOffB :: CLabel -> ByteOff -> CmmLit -cmmLabelOffB = cmmLabelOff - -cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit -cmmOffsetLitB = cmmOffsetLit - ------------------------ --- The "W" variants take word offsets - -cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr --- The second arg is a *word* offset; need to change it to bytes -cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n) -cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off - -cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr -cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n) - -cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr -cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off) - -cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit -cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off) - -cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit -cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off) - -cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr -cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty - ------------------------ -cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, - cmmSLtWord, - cmmNeWord, cmmEqWord, - cmmOrWord, cmmAndWord, - cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord - :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr -cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2] -cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2] -cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2] -cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2] -cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2] -cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2] -cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2] ---cmmShlWord dflags e1 e2 = CmmMachOp (mo_wordShl dflags) [e1, e2] -cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2] -cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2] -cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2] -cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2] -cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2] -cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2] - -cmmNegate :: DynFlags -> CmmExpr -> CmmExpr -cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) -cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e] - -blankWord :: DynFlags -> CmmStatic -blankWord dflags = CmmUninitialised (wORD_SIZE dflags) - -cmmToWord :: DynFlags -> CmmExpr -> CmmExpr -cmmToWord dflags e - | w == word = e - | otherwise = CmmMachOp (MO_UU_Conv w word) [e] - where - w = cmmExprWidth dflags e - word = wordWidth dflags - ---------------------------------------------------- --- --- CmmExpr predicates --- ---------------------------------------------------- - -isTrivialCmmExpr :: CmmExpr -> Bool -isTrivialCmmExpr (CmmLoad _ _) = False -isTrivialCmmExpr (CmmMachOp _ _) = False -isTrivialCmmExpr (CmmLit _) = True -isTrivialCmmExpr (CmmReg _) = True -isTrivialCmmExpr (CmmRegOff _ _) = True -isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" - -hasNoGlobalRegs :: CmmExpr -> Bool -hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e -hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es -hasNoGlobalRegs (CmmLit _) = True -hasNoGlobalRegs (CmmReg (CmmLocal _)) = True -hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True -hasNoGlobalRegs _ = False - ---------------------------------------------------- --- --- Tagging --- ---------------------------------------------------- - --- Tag bits mask ---cmmTagBits = CmmLit (mkIntCLit tAG_BITS) -cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr -cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags) -cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags)) - --- Used to untag a possibly tagged pointer --- A static label need not be untagged -cmmUntag :: DynFlags -> CmmExpr -> CmmExpr -cmmUntag _ e@(CmmLit (CmmLabel _)) = e --- Default case -cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags) - --- Test if a closure pointer is untagged -cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr -cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags) - -cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr --- Get constructor tag, but one based. -cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags) - - ------------------------------------------------------------------------------ --- Overlap and usage - --- | Returns True if the two STG registers overlap on the specified --- platform, in the sense that writing to one will clobber the --- other. This includes the case that the two registers are the same --- STG register. See Note [Overlapping global registers] for details. -regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool -regsOverlap dflags (CmmGlobal g) (CmmGlobal g') - | Just real <- globalRegMaybe (targetPlatform dflags) g, - Just real' <- globalRegMaybe (targetPlatform dflags) g', - real == real' - = True -regsOverlap _ reg reg' = reg == reg' - --- | Returns True if the STG register is used by the expression, in --- the sense that a store to the register might affect the value of --- the expression. --- --- We must check for overlapping registers and not just equal --- registers here, otherwise CmmSink may incorrectly reorder --- assignments that conflict due to overlap. See Trac #10521 and Note --- [Overlapping global registers]. -regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool -regUsedIn dflags = regUsedIn_ where - _ `regUsedIn_` CmmLit _ = False - reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e - reg `regUsedIn_` CmmReg reg' = regsOverlap dflags reg reg' - reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg' - reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es - _ `regUsedIn_` CmmStackSlot _ _ = False - --------------------------------------------- --- --- mkLiveness --- ---------------------------------------------- - -mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness -mkLiveness _ [] = [] -mkLiveness dflags (reg:regs) - = take sizeW bits ++ mkLiveness dflags regs - where - sizeW = case reg of - Nothing -> 1 - Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1) - `quot` wORD_SIZE dflags - -- number of words, rounded up - bits = repeat $ is_non_ptr reg -- True <=> Non Ptr - - is_non_ptr Nothing = True - is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg) - - --- ============================================== - --- ============================================== - --- ============================================== - - ---------------------------------------------------- --- --- Manipulating CmmGraphs --- ---------------------------------------------------- - -modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' -modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} - -toBlockMap :: CmmGraph -> LabelMap CmmBlock -toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body - -ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph -ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} - -insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock -insertBlock block map = - ASSERT(isNothing $ mapLookup id map) - mapInsert id block map - where id = entryLabel block - -toBlockList :: CmmGraph -> [CmmBlock] -toBlockList g = mapElems $ toBlockMap g - --- | like 'toBlockList', but the entry block always comes first -toBlockListEntryFirst :: CmmGraph -> [CmmBlock] -toBlockListEntryFirst g - | mapNull m = [] - | otherwise = entry_block : others - where - m = toBlockMap g - entry_id = g_entry g - Just entry_block = mapLookup entry_id m - others = filter ((/= entry_id) . entryLabel) (mapElems m) - --- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks --- so that the false case of a conditional jumps to the next block in the output --- list of blocks. This matches the way OldCmm blocks were output since in --- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches --- have both true and false successors. Block ordering can make a big difference --- in performance in the LLVM backend. Note that we rely crucially on the order --- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode --- defind in cmm/CmmNode.hs. -GBM -toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock] -toBlockListEntryFirstFalseFallthrough g - | mapNull m = [] - | otherwise = dfs setEmpty [entry_block] - where - m = toBlockMap g - entry_id = g_entry g - Just entry_block = mapLookup entry_id m - - dfs :: LabelSet -> [CmmBlock] -> [CmmBlock] - dfs _ [] = [] - dfs visited (block:bs) - | id `setMember` visited = dfs visited bs - | otherwise = block : dfs (setInsert id visited) bs' - where id = entryLabel block - bs' = foldr add_id bs (successors block) - add_id id bs = case mapLookup id m of - Just b -> b : bs - Nothing -> bs - -ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph -ofBlockList entry blocks = CmmGraph { g_entry = entry - , g_graph = GMany NothingO body NothingO } - where body = foldr addBlock emptyBody blocks - -bodyToBlockList :: Body CmmNode -> [CmmBlock] -bodyToBlockList body = mapElems body - -mapGraphNodes :: ( CmmNode C O -> CmmNode C O - , CmmNode O O -> CmmNode O O - , CmmNode O C -> CmmNode O C) - -> CmmGraph -> CmmGraph -mapGraphNodes funs@(mf,_,_) g = - ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $ - mapMap (mapBlock3' funs) $ toBlockMap g - -mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph -mapGraphNodes1 f = modifyGraph (mapGraph f) - - -foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a -foldGraphBlocks k z g = mapFold k z $ toBlockMap g - -postorderDfs :: CmmGraph -> [CmmBlock] -postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g) - -------------------------------------------------- --- Tick utilities - --- | Extract all tick annotations from the given block -blockTicks :: Block CmmNode C C -> [CmmTickish] -blockTicks b = reverse $ foldBlockNodesF goStmt b [] - where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish] - goStmt (CmmTick t) ts = t:ts - goStmt _other ts = ts diff --git a/cmm/Debug.hs b/cmm/Debug.hs deleted file mode 100644 --- a/cmm/Debug.hs +++ /dev/null @@ -1,459 +0,0 @@ -{-# LANGUAGE GADTs #-} - ------------------------------------------------------------------------------ --- --- Debugging data --- --- Association of debug data on the Cmm level, with methods to encode it in --- event log format for later inclusion in profiling event logs. --- ------------------------------------------------------------------------------ - -module Debug ( - - DebugBlock(..), dblIsEntry, - cmmDebugGen, - cmmDebugLabels, - cmmDebugLink, - debugToMap, - - -- * Unwinding information - UnwindTable, UnwindPoint(..), - UnwindExpr(..), toUnwindExpr - ) where - -import BlockId -import CLabel -import Cmm -import CmmUtils -import CoreSyn -import FastString ( nilFS, mkFastString ) -import Module -import Outputable -import PprCore () -import PprCmmExpr ( pprExpr ) -import SrcLoc -import Util - -import Compiler.Hoopl - -import Data.Maybe -import Data.List ( minimumBy, nubBy ) -import Data.Ord ( comparing ) -import qualified Data.Map as Map - --- | Debug information about a block of code. Ticks scope over nested --- blocks. -data DebugBlock = - DebugBlock - { dblProcedure :: !Label -- ^ Entry label of containing proc - , dblLabel :: !Label -- ^ Hoopl label - , dblCLabel :: !CLabel -- ^ Output label - , dblHasInfoTbl :: !Bool -- ^ Has an info table? - , dblParent :: !(Maybe DebugBlock) - -- ^ The parent of this proc. See Note [Splitting DebugBlocks] - , dblTicks :: ![CmmTickish] -- ^ Ticks defined in this block - , dblSourceTick - :: !(Maybe CmmTickish) -- ^ Best source tick covering block - , dblPosition :: !(Maybe Int) -- ^ Output position relative to - -- other blocks. @Nothing@ means - -- the block was optimized out - , dblUnwind :: [UnwindPoint] - , dblBlocks :: ![DebugBlock] -- ^ Nested blocks - } - --- | Is this the entry block? -dblIsEntry :: DebugBlock -> Bool -dblIsEntry blk = dblProcedure blk == dblLabel blk - -instance Outputable DebugBlock where - ppr blk = (if dblProcedure blk == dblLabel blk - then text "proc " - else if dblHasInfoTbl blk - then text "pp-blk " - else text "blk ") <> - ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+> - (maybe empty ppr (dblSourceTick blk)) <+> - (maybe (text "removed") ((text "pos " <>) . ppr) - (dblPosition blk)) <+> - (ppr (dblUnwind blk)) <+> - (if null (dblBlocks blk) then empty else ppr (dblBlocks blk)) - --- | Intermediate data structure holding debug-relevant context information --- about a block. -type BlockContext = (CmmBlock, RawCmmDecl) - --- | Extract debug data from a group of procedures. We will prefer --- source notes that come from the given module (presumably the module --- that we are currently compiling). -cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock] -cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes - where - blockCtxs :: Map.Map CmmTickScope [BlockContext] - blockCtxs = blockContexts decls - - -- Analyse tick scope structure: Each one is either a top-level - -- tick scope, or the child of another. - (topScopes, childScopes) - = splitEithers $ map (\a -> findP a a) $ Map.keys blockCtxs - findP tsc GlobalScope = Left tsc -- top scope - findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc) - | otherwise = findP tsc scp' - where -- Note that we only following the left parent of - -- combined scopes. This loses us ticks, which we will - -- recover by copying ticks below. - scp' | SubScope _ scp' <- scp = scp' - | CombinedScope scp' _ <- scp = scp' - | otherwise = panic "findP impossible" - - scopeMap = foldr (uncurry insertMulti) Map.empty childScopes - - -- This allows us to recover ticks that we lost by flattening - -- the graph. Basically, if the parent is A but the child is - -- CBA, we know that there is no BA, because it would have taken - -- priority - but there might be a B scope, with ticks that - -- would not be associated with our child anymore. Note however - -- that there might be other childs (DB), which we have to - -- filter out. - -- - -- We expect this to be called rarely, which is why we are not - -- trying too hard to be efficient here. In many cases we won't - -- have to construct blockCtxsU in the first place. - ticksToCopy :: CmmTickScope -> [CmmTickish] - ticksToCopy (CombinedScope scp s) = go s - where go s | scp `isTickSubScope` s = [] -- done - | SubScope _ s' <- s = ticks ++ go s' - | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2 - | otherwise = panic "ticksToCopy impossible" - where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs - ticksToCopy _ = [] - bCtxsTicks = concatMap (blockTicks . fst) - - -- Finding the "best" source tick is somewhat arbitrary -- we - -- select the first source span, while preferring source ticks - -- from the same source file. Furthermore, dumps take priority - -- (if we generated one, we probably want debug information to - -- refer to it). - bestSrcTick = minimumBy (comparing rangeRating) - rangeRating (SourceNote span _) - | srcSpanFile span == thisFile = 1 - | otherwise = 2 :: Int - rangeRating note = pprPanic "rangeRating" (ppr note) - thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc - - -- Returns block tree for this scope as well as all nested - -- scopes. Note that if there are multiple blocks in the (exact) - -- same scope we elect one as the "branch" node and add the rest - -- as children. - blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock - blocksForScope cstick scope = mkBlock True (head bctxs) - where bctxs = fromJust $ Map.lookup scope blockCtxs - nested = fromMaybe [] $ Map.lookup scope scopeMap - childs = map (mkBlock False) (tail bctxs) ++ - map (blocksForScope stick) nested - - mkBlock :: Bool -> BlockContext -> DebugBlock - mkBlock top (block, prc) - = DebugBlock { dblProcedure = g_entry graph - , dblLabel = label - , dblCLabel = case info of - Just (Statics infoLbl _) -> infoLbl - Nothing - | g_entry graph == label -> entryLbl - | otherwise -> blockLbl label - , dblHasInfoTbl = isJust info - , dblParent = Nothing - , dblTicks = ticks - , dblPosition = Nothing -- see cmmDebugLink - , dblSourceTick = stick - , dblBlocks = blocks - , dblUnwind = [] - } - where (CmmProc infos entryLbl _ graph) = prc - label = entryLabel block - info = mapLookup label infos - blocks | top = seqList childs childs - | otherwise = [] - - -- A source tick scopes over all nested blocks. However - -- their source ticks might take priority. - isSourceTick SourceNote {} = True - isSourceTick _ = False - -- Collect ticks from all blocks inside the tick scope. - -- We attempt to filter out duplicates while we're at it. - ticks = nubBy (flip tickishContains) $ - bCtxsTicks bctxs ++ ticksToCopy scope - stick = case filter isSourceTick ticks of - [] -> cstick - sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick) - --- | Build a map of blocks sorted by their tick scopes --- --- This involves a pre-order traversal, as we want blocks in rough --- control flow order (so ticks have a chance to be sorted in the --- right order). -blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext] -blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls - where walkProc :: RawCmmDecl - -> Map.Map CmmTickScope [BlockContext] - -> Map.Map CmmTickScope [BlockContext] - walkProc CmmData{} m = m - walkProc prc@(CmmProc _ _ _ graph) m - | mapNull blocks = m - | otherwise = snd $ walkBlock prc entry (emptyLbls, m) - where blocks = toBlockMap graph - entry = [mapFind (g_entry graph) blocks] - emptyLbls = setEmpty :: LabelSet - - walkBlock :: RawCmmDecl -> [Block CmmNode C C] - -> (LabelSet, Map.Map CmmTickScope [BlockContext]) - -> (LabelSet, Map.Map CmmTickScope [BlockContext]) - walkBlock _ [] c = c - walkBlock prc (block:blocks) (visited, m) - | lbl `setMember` visited - = walkBlock prc blocks (visited, m) - | otherwise - = walkBlock prc blocks $ - walkBlock prc succs - (lbl `setInsert` visited, - insertMulti scope (block, prc) m) - where CmmEntry lbl scope = firstNode block - (CmmProc _ _ _ graph) = prc - succs = map (flip mapFind (toBlockMap graph)) - (successors (lastNode block)) - mapFind = mapFindWithDefault (error "contextTree: block not found!") - -insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a] -insertMulti k v = Map.insertWith (const (v:)) k [v] - -cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label] -cmmDebugLabels isMeta nats = seqList lbls lbls - where -- Find order in which procedures will be generated by the - -- back-end (that actually matters for DWARF generation). - -- - -- Note that we might encounter blocks that are missing or only - -- consist of meta instructions -- we will declare them missing, - -- which will skip debug data generation without messing up the - -- block hierarchy. - lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats - getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs - getBlocks _other = [] - allMeta (BasicBlock _ instrs) = all isMeta instrs - --- | Sets position and unwind table fields in the debug block tree according to --- native generated code. -cmmDebugLink :: [Label] -> LabelMap [UnwindPoint] - -> [DebugBlock] -> [DebugBlock] -cmmDebugLink labels unwindPts blocks = map link blocks - where blockPos :: LabelMap Int - blockPos = mapFromList $ flip zip [0..] labels - link block = block { dblPosition = mapLookup (dblLabel block) blockPos - , dblBlocks = map link (dblBlocks block) - , dblUnwind = fromMaybe mempty - $ mapLookup (dblLabel block) unwindPts - } - --- | Converts debug blocks into a label map for easier lookups -debugToMap :: [DebugBlock] -> LabelMap DebugBlock -debugToMap = mapUnions . map go - where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b) - -{- -Note [What is this unwinding business?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Unwinding tables are a variety of debugging information used by debugging tools -to reconstruct the execution history of a program at runtime. These tables -consist of sets of "instructions", one set for every instruction in the program, -which describe how to reconstruct the state of the machine at the point where -the current procedure was called. For instance, consider the following annotated -pseudo-code, - - a_fun: - add rsp, 8 -- unwind: rsp = rsp - 8 - mov rax, 1 -- unwind: rax = unknown - call another_block - sub rsp, 8 -- unwind: rsp = rsp - -We see that attached to each instruction there is an "unwind" annotation, which -provides a relationship between each updated register and its value at the -time of entry to a_fun. This is the sort of information that allows gdb to give -you a stack backtrace given the execution state of your program. This -unwinding information is captured in various ways by various debug information -formats; in the case of DWARF (the only format supported by GHC) it is known as -Call Frame Information (CFI) and can be found in the .debug.frames section of -your object files. - -Currently we only bother to produce unwinding information for registers which -are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp -(which is the STG stack pointer) and $rsp (the C stack pointer). - -Let's consider how GHC would annotate a C-- program with unwinding information -with a typical C-- procedure as would come from the STG-to-Cmm code generator, - - entry() - { c2fe: - v :: P64 = R2; - if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg; - c2ff: - R2 = v :: P64; - R1 = test_closure; - call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; - c2fg: - I64[Sp - 8] = c2dD; - R1 = v :: P64; - Sp = Sp - 8; // Sp updated here - if (R1 & 7 != 0) goto c2dD; else goto c2dE; - c2dE: - call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8; - c2dD: - w :: P64 = R1; - Hp = Hp + 48; - if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi; - ... - }, - -Let's consider how this procedure will be decorated with unwind information -(largely by CmmLayoutStack). Naturally, when we enter the procedure `entry` the -value of Sp is no different from what it was at its call site. Therefore we will -add an `unwind` statement saying this at the beginning of its unwind-annotated -code, - - entry() - { c2fe: - unwind Sp = Just Sp + 0; - v :: P64 = R2; - if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg; - -After c2fe we we may pass to either c2ff or c2fg; let's first consider the -former. In this case there is nothing in particular that we need to do other -than reiterate what we already know about Sp, - - c2ff: - unwind Sp = Just Sp + 0; - R2 = v :: P64; - R1 = test_closure; - call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; - -In contrast, c2fg updates Sp midway through its body. To ensure that unwinding -can happen correctly after this point we must include an unwind statement there, -in addition to the usual beginning-of-block statement, - - c2fg: - unwind Sp = Just Sp + 0; - I64[Sp - 8] = c2dD; - R1 = v :: P64; - unwind Sp = Just Sp + 8; - Sp = Sp - 8; - if (R1 & 7 != 0) goto c2dD; else goto c2dE; - -The remaining blocks are simple, - - c2dE: - unwind Sp = Just Sp + 8; - call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8; - c2dD: - unwind Sp = Just Sp + 8; - w :: P64 = R1; - Hp = Hp + 48; - if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi; - ... - }, - - -The flow of unwinding information through the compiler is a bit convoluted: - - * C-- begins life in StgCmm without any unwind information. This is because we - haven't actually done any register assignment or stack layout yet, so there - is no need for unwind information. - - * CmmLayoutStack figures out how to layout each procedure's stack, and produces - appropriate unwinding nodes for each adjustment of the STG Sp register. - - * The unwind nodes are carried through the sinking pass. Currently this is - guaranteed not to invalidate unwind information since it won't touch stores - to Sp, but this will need revisiting if CmmSink gets smarter in the future. - - * Eventually we make it to the native code generator backend which can then - preserve the unwind nodes in its machine-specific instructions. In so doing - the backend can also modify or add unwinding information; this is necessary, - for instance, in the case of x86-64, where adjustment of $rsp may be - necessary during calls to native foreign code due to the native calling - convention. - - * The NCG then retrieves the final unwinding table for each block from the - backend with extractUnwindPoints. - - * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen - - * These DebugBlcosk are then converted to, e.g., DWARF unwinding tables - (by the Dwarf module) and emitted in the final object. - -See also: Note [Unwinding information in the NCG] in AsmCodeGen. --} - --- | A label associated with an 'UnwindTable' -data UnwindPoint = UnwindPoint !CLabel !UnwindTable - -instance Outputable UnwindPoint where - ppr (UnwindPoint lbl uws) = - braces $ ppr lbl<>colon - <+> hsep (punctuate comma $ map pprUw $ Map.toList uws) - where - pprUw (g, expr) = ppr g <> char '=' <> ppr expr - --- | Maps registers to expressions that yield their "old" values --- further up the stack. Most interesting for the stack pointer @Sp@, --- but might be useful to document saved registers, too. Note that a --- register's value will be 'Nothing' when the register's previous --- value cannot be reconstructed. -type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr) - --- | Expressions, used for unwind information -data UnwindExpr = UwConst !Int -- ^ literal value - | UwReg !GlobalReg !Int -- ^ register plus offset - | UwDeref UnwindExpr -- ^ pointer dereferencing - | UwLabel CLabel - | UwPlus UnwindExpr UnwindExpr - | UwMinus UnwindExpr UnwindExpr - | UwTimes UnwindExpr UnwindExpr - deriving (Eq) - -instance Outputable UnwindExpr where - pprPrec _ (UwConst i) = ppr i - pprPrec _ (UwReg g 0) = ppr g - pprPrec p (UwReg g x) = pprPrec p (UwPlus (UwReg g 0) (UwConst x)) - pprPrec _ (UwDeref e) = char '*' <> pprPrec 3 e - pprPrec _ (UwLabel l) = pprPrec 3 l - pprPrec p (UwPlus e0 e1) | p <= 0 - = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1 - pprPrec p (UwMinus e0 e1) | p <= 0 - = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1 - pprPrec p (UwTimes e0 e1) | p <= 1 - = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1 - pprPrec _ other = parens (pprPrec 0 other) - --- | Conversion of Cmm expressions to unwind expressions. We check for --- unsupported operator usages and simplify the expression as far as --- possible. -toUnwindExpr :: CmmExpr -> UnwindExpr -toUnwindExpr (CmmLit (CmmInt i _)) = UwConst (fromIntegral i) -toUnwindExpr (CmmLit (CmmLabel l)) = UwLabel l -toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i -toUnwindExpr (CmmReg (CmmGlobal g)) = UwReg g 0 -toUnwindExpr (CmmLoad e _) = UwDeref (toUnwindExpr e) -toUnwindExpr e@(CmmMachOp op [e1, e2]) = - case (op, toUnwindExpr e1, toUnwindExpr e2) of - (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y) - (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y) - (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y) - (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y) - (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y) - (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y) - (MO_Add{}, u1, u2 ) -> UwPlus u1 u2 - (MO_Sub{}, u1, u2 ) -> UwMinus u1 u2 - (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2 - _otherwise -> pprPanic "Unsupported operator in unwind expression!" - (pprExpr e) -toUnwindExpr e - = pprPanic "Unsupported unwind expression!" (ppr e) diff --git a/cmm/Hoopl.hs b/cmm/Hoopl.hs deleted file mode 100644 --- a/cmm/Hoopl.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Hoopl ( - module Compiler.Hoopl, - module Hoopl.Dataflow, - ) where - -import Compiler.Hoopl hiding - ( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph - DataflowLattice, OldFact, NewFact, JoinFun, - fact_bot, fact_join, joinOutFacts, mkFactBase, - Unique, - FwdTransfer(..), FwdRewrite(..), FwdPass(..), - BwdTransfer(..), BwdRewrite(..), BwdPass(..), - mkFactBase, Fact, - mkBRewrite3, mkBTransfer3, - mkFRewrite3, mkFTransfer3, - - ) - -import Hoopl.Dataflow -import Outputable - -instance Outputable LabelSet where - ppr = ppr . setElems - -instance Outputable a => Outputable (LabelMap a) where - ppr = ppr . mapToList diff --git a/cmm/Hoopl/Dataflow.hs b/cmm/Hoopl/Dataflow.hs deleted file mode 100644 --- a/cmm/Hoopl/Dataflow.hs +++ /dev/null @@ -1,323 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fprof-auto-top #-} - --- --- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones, --- and Norman Ramsey --- --- Modifications copyright (c) The University of Glasgow 2012 --- --- This module is a specialised and optimised version of --- Compiler.Hoopl.Dataflow in the hoopl package. In particular it is --- specialised to the UniqSM monad. --- - -module Hoopl.Dataflow - ( C, O, Block - , lastNode, entryLabel - , foldNodesBwdOO - , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..), TransferFun - , Fact, FactBase - , getFact, mkFactBase - , analyzeCmmFwd, analyzeCmmBwd - , changedIf - , joinOutFacts - ) -where - -import Cmm - -import Data.Array -import Data.List -import Data.Maybe - --- Hide definitions from Hoopl's Dataflow module. -import Compiler.Hoopl hiding ( DataflowLattice, OldFact, NewFact, JoinFun - , fact_bot, fact_join, joinOutFacts, mkFactBase - ) - -newtype OldFact a = OldFact a - -newtype NewFact a = NewFact a - --- | The result of joining OldFact and NewFact. -data JoinedFact a - = Changed !a -- ^ Result is different than OldFact. - | NotChanged !a -- ^ Result is the same as OldFact. - -getJoined :: JoinedFact a -> a -getJoined (Changed a) = a -getJoined (NotChanged a) = a - -changedIf :: Bool -> a -> JoinedFact a -changedIf True = Changed -changedIf False = NotChanged - -type JoinFun a = OldFact a -> NewFact a -> JoinedFact a - -data DataflowLattice a = DataflowLattice - { fact_bot :: a - , fact_join :: JoinFun a - } - -data Direction = Fwd | Bwd - -type TransferFun f = CmmBlock -> FactBase f -> FactBase f - -analyzeCmmBwd, analyzeCmmFwd - :: DataflowLattice f - -> TransferFun f - -> CmmGraph - -> FactBase f - -> FactBase f -analyzeCmmBwd = analyzeCmm Bwd -analyzeCmmFwd = analyzeCmm Fwd - -analyzeCmm - :: Direction - -> DataflowLattice f - -> TransferFun f - -> CmmGraph - -> FactBase f - -> FactBase f -analyzeCmm dir lattice transfer cmmGraph initFact = - let entry = g_entry cmmGraph - hooplGraph = g_graph cmmGraph - blockMap = - case hooplGraph of - GMany NothingO bm NothingO -> bm - entries = if mapNull initFact then [entry] else mapKeys initFact - in fixpointAnalysis dir lattice transfer entries blockMap initFact - --- Fixpoint algorithm. -fixpointAnalysis - :: forall f. - Direction - -> DataflowLattice f - -> TransferFun f - -> [Label] - -> LabelMap CmmBlock - -> FactBase f - -> FactBase f -fixpointAnalysis direction lattice do_block entries blockmap = loop start - where - -- Sorting the blocks helps to minimize the number of times we need to - -- process blocks. For instance, for forward analysis we want to look at - -- blocks in reverse postorder. Also, see comments for sortBlocks. - blocks = sortBlocks direction entries blockmap - num_blocks = length blocks - block_arr = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks - start = {-# SCC "start" #-} [0 .. num_blocks - 1] - dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks - join = fact_join lattice - - loop - :: IntHeap -- ^ Worklist, i.e., blocks to process - -> FactBase f -- ^ Current result (increases monotonically) - -> FactBase f - loop [] !fbase1 = fbase1 - loop (index : todo1) !fbase1 = - let block = block_arr ! index - out_facts = {-# SCC "do_block" #-} do_block block fbase1 - -- For each of the outgoing edges, we join it with the current - -- information in fbase1 and (if something changed) we update it - -- and add the affected blocks to the worklist. - (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-} - mapFoldWithKey - (updateFact join dep_blocks) (todo1, fbase1) out_facts - in loop todo2 fbase2 - - - -{- -Note [Unreachable blocks] -~~~~~~~~~~~~~~~~~~~~~~~~~ -A block that is not in the domain of tfb_fbase is "currently unreachable". -A currently-unreachable block is not even analyzed. Reason: consider -constant prop and this graph, with entry point L1: - L1: x:=3; goto L4 - L2: x:=4; goto L4 - L4: if x>3 goto L2 else goto L5 -Here L2 is actually unreachable, but if we process it with bottom input fact, -we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4. - -* If a currently-unreachable block is not analyzed, then its rewritten - graph will not be accumulated in tfb_rg. And that is good: - unreachable blocks simply do not appear in the output. - -* Note that clients must be careful to provide a fact (even if bottom) - for each entry point. Otherwise useful blocks may be garbage collected. - -* Note that updateFact must set the change-flag if a label goes from - not-in-fbase to in-fbase, even if its fact is bottom. In effect the - real fact lattice is - UNR - bottom - the points above bottom - -* Even if the fact is going from UNR to bottom, we still call the - client's fact_join function because it might give the client - some useful debugging information. - -* All of this only applies for *forward* ixpoints. For the backward - case we must treat every block as reachable; it might finish with a - 'return', and therefore have no successors, for example. --} - - ------------------------------------------------------------------------------ --- Pieces that are shared by fixpoint and fixpoint_anal ------------------------------------------------------------------------------ - --- | Sort the blocks into the right order for analysis. This means reverse --- postorder for a forward analysis. For the backward one, we simply reverse --- that (see Note [Backward vs forward analysis]). --- --- Note: We're using Hoopl's confusingly named `postorder_dfs_from` but AFAICS --- it returns the *reverse* postorder of the blocks (it visits blocks in the --- postorder and uses (:) to collect them, which gives the reverse of the --- visitation order). -sortBlocks - :: NonLocal n - => Direction -> [Label] -> LabelMap (Block n C C) -> [Block n C C] -sortBlocks direction entries blockmap = - case direction of - Fwd -> fwd - Bwd -> reverse fwd - where - fwd = postorder_dfs_from blockmap entries - --- Note [Backward vs forward analysis] --- --- The forward and backward cases are not dual. In the forward case, the entry --- points are known, and one simply traverses the body blocks from those points. --- In the backward case, something is known about the exit points, but a --- backward analysis must also include reachable blocks that don't reach the --- exit, as in a procedure that loops forever and has side effects.) --- For instance, let E be the entry and X the exit blocks (arrows indicate --- control flow) --- E -> X --- E -> B --- B -> C --- C -> B --- We do need to include B and C even though they're unreachable in the --- *reverse* graph (that we could use for backward analysis): --- E <- X --- E <- B --- B <- C --- C <- B --- So when sorting the blocks for the backward analysis, we simply take the --- reverse of what is used for the forward one. - - --- | construct a mapping from L -> block indices. If the fact for L --- changes, re-analyse the given blocks. -mkDepBlocks :: NonLocal n => Direction -> [Block n C C] -> LabelMap [Int] -mkDepBlocks Fwd blocks = go blocks 0 mapEmpty - where go [] !_ m = m - go (b:bs) !n m = go bs (n+1) $! mapInsert (entryLabel b) [n] m -mkDepBlocks Bwd blocks = go blocks 0 mapEmpty - where go [] !_ m = m - go (b:bs) !n m = go bs (n+1) $! go' (successors b) m - where go' [] m = m - go' (l:ls) m = go' ls (mapInsertWith (++) l [n] m) - - --- | After some new facts have been generated by analysing a block, we --- fold this function over them to generate (a) a list of block --- indices to (re-)analyse, and (b) the new FactBase. --- -updateFact :: JoinFun f -> LabelMap [Int] - -> Label -> f -- out fact - -> (IntHeap, FactBase f) - -> (IntHeap, FactBase f) - -updateFact fact_join dep_blocks lbl new_fact (todo, fbase) - = case lookupFact lbl fbase of - Nothing -> let !z = mapInsert lbl new_fact fbase in (changed, z) - -- Note [no old fact] - Just old_fact -> - case fact_join (OldFact old_fact) (NewFact new_fact) of - (NotChanged _) -> (todo, fbase) - (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z) - where - changed = foldr insertIntHeap todo $ - mapFindWithDefault [] lbl dep_blocks - -{- -Note [no old fact] - -We know that the new_fact is >= _|_, so we don't need to join. However, -if the new fact is also _|_, and we have already analysed its block, -we don't need to record a change. So there's a tradeoff here. It turns -out that always recording a change is faster. --} - ----------------------------------------------------------------- --- Utilities ----------------------------------------------------------------- - --- Fact lookup: the fact `orelse` bottom -getFact :: DataflowLattice f -> Label -> FactBase f -> f -getFact lat l fb = case lookupFact l fb of Just f -> f - Nothing -> fact_bot lat - --- | Returns the result of joining the facts from all the successors of the --- provided node or block. -joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f -joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts - where - join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new) - facts = - [ fromJust fact - | s <- successors nonLocal - , let fact = lookupFact s fact_base - , isJust fact - ] - --- | Returns the joined facts for each label. -mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f -mkFactBase lattice = foldl' add mapEmpty - where - join = fact_join lattice - - add result (l, f1) = - let !newFact = - case mapLookup l result of - Nothing -> f1 - Just f2 -> getJoined $ join (OldFact f1) (NewFact f2) - in mapInsert l newFact result - --- | Folds backward over all nodes of an open-open block. --- Strict in the accumulator. -foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f -foldNodesBwdOO funOO = go - where - go (BCat b1 b2) f = go b1 $! go b2 f - go (BSnoc h n) f = go h $! funOO n f - go (BCons n t) f = funOO n $! go t f - go (BMiddle n) f = funOO n f - go BNil f = f -{-# INLINABLE foldNodesBwdOO #-} - --- ----------------------------------------------------------------------------- --- a Heap of Int - --- We should really use a proper Heap here, but my attempts to make --- one have not succeeded in beating the simple ordered list. Another --- alternative is IntSet (using deleteFindMin), but that was also --- slower than the ordered list in my experiments --SDM 25/1/2012 - -type IntHeap = [Int] -- ordered - -insertIntHeap :: Int -> [Int] -> [Int] -insertIntHeap x [] = [x] -insertIntHeap x (y:ys) - | x < y = x : y : ys - | x == y = x : ys - | otherwise = y : insertIntHeap x ys diff --git a/cmm/MkGraph.hs b/cmm/MkGraph.hs deleted file mode 100644 --- a/cmm/MkGraph.hs +++ /dev/null @@ -1,415 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, GADTs #-} - -module MkGraph - ( CmmAGraph, CmmAGraphScoped, CgStmt(..) - , (<*>), catAGraphs - , mkLabel, mkMiddle, mkLast, outOfLine - , lgraphOfAGraph, labelAGraph - - , stackStubExpr - , mkNop, mkAssign, mkStore - , mkUnsafeCall, mkFinalCall, mkCallReturnsTo - , mkJumpReturnsTo - , mkJump, mkJumpExtra - , mkRawJump - , mkCbranch, mkSwitch - , mkReturn, mkComment, mkCallEntry, mkBranch - , mkUnwind - , copyInOflow, copyOutOflow - , noExtraStack - , toCall, Transfer(..) - ) -where - -import BlockId -import Cmm -import CmmCallConv -import CmmSwitch (SwitchTargets) - -import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..)) -import DynFlags -import FastString -import ForeignCall -import OrdList -import SMRep (ByteOff) -import UniqSupply - -import Control.Monad -import Data.List -import Data.Maybe -import Prelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>) - -#include "HsVersions.h" - - ------------------------------------------------------------------------------ --- Building Graphs - - --- | CmmAGraph is a chunk of code consisting of: --- --- * ordinary statements (assignments, stores etc.) --- * jumps --- * labels --- * out-of-line labelled blocks --- --- The semantics is that control falls through labels and out-of-line --- blocks. Everything after a jump up to the next label is by --- definition unreachable code, and will be discarded. --- --- Two CmmAGraphs can be stuck together with <*>, with the meaning that --- control flows from the first to the second. --- --- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends) --- by providing a label for the entry point and a tick scope; see --- 'labelAGraph'. -type CmmAGraph = OrdList CgStmt --- | Unlabeled graph with tick scope -type CmmAGraphScoped = (CmmAGraph, CmmTickScope) - -data CgStmt - = CgLabel BlockId CmmTickScope - | CgStmt (CmmNode O O) - | CgLast (CmmNode O C) - | CgFork BlockId CmmAGraph CmmTickScope - -flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph -flattenCmmAGraph id (stmts_t, tscope) = - CmmGraph { g_entry = id, - g_graph = GMany NothingO body NothingO } - where - body = foldr addBlock emptyBody $ flatten id stmts_t tscope [] - - -- - -- flatten: given an entry label and a CmmAGraph, make a list of blocks. - -- - -- NB. avoid the quadratic-append trap by passing in the tail of the - -- list. This is important for Very Long Functions (e.g. in T783). - -- - flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C] - -> [Block CmmNode C C] - flatten id g tscope blocks - = flatten1 (fromOL g) block' blocks - where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock - -- - -- flatten0: we are outside a block at this point: any code before - -- the first label is unreachable, so just drop it. - -- - flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C] - flatten0 [] blocks = blocks - - flatten0 (CgLabel id tscope : stmts) blocks - = flatten1 stmts block blocks - where !block = blockJoinHead (CmmEntry id tscope) emptyBlock - - flatten0 (CgFork fork_id stmts_t tscope : rest) blocks - = flatten fork_id stmts_t tscope $ flatten0 rest blocks - - flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks - flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks - - -- - -- flatten1: we have a partial block, collect statements until the - -- next last node to make a block, then call flatten0 to get the rest - -- of the blocks - -- - flatten1 :: [CgStmt] -> Block CmmNode C O - -> [Block CmmNode C C] -> [Block CmmNode C C] - - -- The current block falls through to the end of a function or fork: - -- this code should not be reachable, but it may be referenced by - -- other code that is not reachable. We'll remove it later with - -- dead-code analysis, but for now we have to keep the graph - -- well-formed, so we terminate the block with a branch to the - -- beginning of the current block. - flatten1 [] block blocks - = blockJoinTail block (CmmBranch (entryLabel block)) : blocks - - flatten1 (CgLast stmt : stmts) block blocks - = block' : flatten0 stmts blocks - where !block' = blockJoinTail block stmt - - flatten1 (CgStmt stmt : stmts) block blocks - = flatten1 stmts block' blocks - where !block' = blockSnoc block stmt - - flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks - = flatten fork_id stmts_t tscope $ flatten1 rest block blocks - - -- a label here means that we should start a new block, and the - -- current block should fall through to the new block. - flatten1 (CgLabel id tscp : stmts) block blocks - = blockJoinTail block (CmmBranch id) : - flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks - - - ----------- AGraph manipulation - -(<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph -(<*>) = appOL - -catAGraphs :: [CmmAGraph] -> CmmAGraph -catAGraphs = concatOL - --- | created a sequence "goto id; id:" as an AGraph -mkLabel :: BlockId -> CmmTickScope -> CmmAGraph -mkLabel bid scp = unitOL (CgLabel bid scp) - --- | creates an open AGraph from a given node -mkMiddle :: CmmNode O O -> CmmAGraph -mkMiddle middle = unitOL (CgStmt middle) - --- | created a closed AGraph from a given node -mkLast :: CmmNode O C -> CmmAGraph -mkLast last = unitOL (CgLast last) - --- | A labelled code block; should end in a last node -outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph -outOfLine l (c,s) = unitOL (CgFork l c s) - --- | allocate a fresh label for the entry point -lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph -lgraphOfAGraph g = do - u <- getUniqueM - return (labelAGraph (mkBlockId u) g) - --- | use the given BlockId as the label of the entry point -labelAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph -labelAGraph lbl ag = flattenCmmAGraph lbl ag - ----------- No-ops -mkNop :: CmmAGraph -mkNop = nilOL - -mkComment :: FastString -> CmmAGraph -#ifdef DEBUG --- SDM: generating all those comments takes time, this saved about 4% for me -mkComment fs = mkMiddle $ CmmComment fs -#else -mkComment _ = nilOL -#endif - ----------- Assignment and store -mkAssign :: CmmReg -> CmmExpr -> CmmAGraph -mkAssign l (CmmReg r) | l == r = mkNop -mkAssign l r = mkMiddle $ CmmAssign l r - -mkStore :: CmmExpr -> CmmExpr -> CmmAGraph -mkStore l r = mkMiddle $ CmmStore l r - ----------- Control transfer -mkJump :: DynFlags -> Convention -> CmmExpr - -> [CmmExpr] - -> UpdFrameOffset - -> CmmAGraph -mkJump dflags conv e actuals updfr_off = - lastWithArgs dflags Jump Old conv actuals updfr_off $ - toCall e Nothing updfr_off 0 - --- | A jump where the caller says what the live GlobalRegs are. Used --- for low-level hand-written Cmm. -mkRawJump :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg] - -> CmmAGraph -mkRawJump dflags e updfr_off vols = - lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $ - \arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols - - -mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr] - -> UpdFrameOffset -> [CmmExpr] - -> CmmAGraph -mkJumpExtra dflags conv e actuals updfr_off extra_stack = - lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $ - toCall e Nothing updfr_off 0 - -mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph -mkCbranch pred ifso ifnot likely = - mkLast (CmmCondBranch pred ifso ifnot likely) - -mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph -mkSwitch e tbl = mkLast $ CmmSwitch e tbl - -mkReturn :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset - -> CmmAGraph -mkReturn dflags e actuals updfr_off = - lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $ - toCall e Nothing updfr_off 0 - -mkBranch :: BlockId -> CmmAGraph -mkBranch bid = mkLast (CmmBranch bid) - -mkFinalCall :: DynFlags - -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset - -> CmmAGraph -mkFinalCall dflags f _ actuals updfr_off = - lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $ - toCall f Nothing updfr_off 0 - -mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr] - -> BlockId - -> ByteOff - -> UpdFrameOffset - -> [CmmExpr] - -> CmmAGraph -mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do - lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals - updfr_off extra_stack $ - toCall f (Just ret_lbl) updfr_off ret_off - --- Like mkCallReturnsTo, but does not push the return address (it is assumed to be --- already on the stack). -mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr] - -> BlockId - -> ByteOff - -> UpdFrameOffset - -> CmmAGraph -mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do - lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $ - toCall f (Just ret_lbl) updfr_off ret_off - -mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph -mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as - --- | Construct a 'CmmUnwind' node for the given register and unwinding --- expression. -mkUnwind :: GlobalReg -> CmmExpr -> CmmAGraph -mkUnwind r e = mkMiddle $ CmmUnwind [(r, Just e)] - --------------------------------------------------------------------------- - - - - --- Why are we inserting extra blocks that simply branch to the successors? --- Because in addition to the branch instruction, @mkBranch@ will insert --- a necessary adjustment to the stack pointer. - - --- For debugging purposes, we can stub out dead stack slots: -stackStubExpr :: Width -> CmmExpr -stackStubExpr w = CmmLit (CmmInt 0 w) - --- When we copy in parameters, we usually want to put overflow --- parameters on the stack, but sometimes we want to pass the --- variables in their spill slots. Therefore, for copying arguments --- and results, we provide different functions to pass the arguments --- in an overflow area and to pass them in spill slots. -copyInOflow :: DynFlags -> Convention -> Area - -> [CmmFormal] - -> [CmmFormal] - -> (Int, [GlobalReg], CmmAGraph) - -copyInOflow dflags conv area formals extra_stk - = (offset, gregs, catAGraphs $ map mkMiddle nodes) - where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk - --- Return the number of bytes used for copying arguments, as well as the --- instructions to copy the arguments. -copyIn :: DynFlags -> Convention -> Area - -> [CmmFormal] - -> [CmmFormal] - -> (ByteOff, [GlobalReg], [CmmNode O O]) -copyIn dflags conv area formals extra_stk - = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) - where - ci (reg, RegisterParam r) = - CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) - ci (reg, StackParam off) = - CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) - where ty = localRegType reg - - init_offset = widthInBytes (wordWidth dflags) -- infotable - - (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk - - (stk_size, args) = assignArgumentsPos dflags stk_off conv - localRegType formals - --- Factoring out the common parts of the copyout functions yielded something --- more complicated: - -data Transfer = Call | JumpRet | Jump | Ret deriving Eq - -copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr] - -> UpdFrameOffset - -> [CmmExpr] -- extra stack args - -> (Int, [GlobalReg], CmmAGraph) - --- Generate code to move the actual parameters into the locations --- required by the calling convention. This includes a store for the --- return address. --- --- The argument layout function ignores the pointer to the info table, --- so we slot that in here. When copying-out to a young area, we set --- the info table for return and adjust the offsets of the other --- parameters. If this is a call instruction, we adjust the offsets --- of the other parameters. -copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff - = (stk_size, regs, graph) - where - (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) - - co (v, RegisterParam r) (rs, ms) - = (r:rs, mkAssign (CmmGlobal r) v <*> ms) - co (v, StackParam off) (rs, ms) - = (rs, mkStore (CmmStackSlot area off) v <*> ms) - - (setRA, init_offset) = - case area of - Young id -> -- Generate a store instruction for - -- the return address if making a call - case transfer of - Call -> - ([(CmmLit (CmmBlock id), StackParam init_offset)], - widthInBytes (wordWidth dflags)) - JumpRet -> - ([], - widthInBytes (wordWidth dflags)) - _other -> - ([], 0) - Old -> ([], updfr_off) - - (extra_stack_off, stack_params) = - assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff - - args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it - (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv - (cmmExprType dflags) actuals - - - -mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal] - -> (Int, [GlobalReg], CmmAGraph) -mkCallEntry dflags conv formals extra_stk - = copyInOflow dflags conv Old formals extra_stk - -lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr] - -> UpdFrameOffset - -> (ByteOff -> [GlobalReg] -> CmmAGraph) - -> CmmAGraph -lastWithArgs dflags transfer area conv actuals updfr_off last = - lastWithArgsAndExtraStack dflags transfer area conv actuals - updfr_off noExtraStack last - -lastWithArgsAndExtraStack :: DynFlags - -> Transfer -> Area -> Convention -> [CmmExpr] - -> UpdFrameOffset -> [CmmExpr] - -> (ByteOff -> [GlobalReg] -> CmmAGraph) - -> CmmAGraph -lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off - extra_stack last = - copies <*> last outArgs regs - where - (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals - updfr_off extra_stack - - -noExtraStack :: [CmmExpr] -noExtraStack = [] - -toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff - -> ByteOff -> [GlobalReg] - -> CmmAGraph -toCall e cont updfr_off res_space arg_space regs = - mkLast $ CmmCall e cont regs arg_space res_space updfr_off diff --git a/cmm/PprC.hs b/cmm/PprC.hs deleted file mode 100644 --- a/cmm/PprC.hs +++ /dev/null @@ -1,1313 +0,0 @@ -{-# LANGUAGE CPP, GADTs #-} - ------------------------------------------------------------------------------ --- --- Pretty-printing of Cmm as C, suitable for feeding gcc --- --- (c) The University of Glasgow 2004-2006 --- --- Print Cmm as real C, for -fvia-C --- --- See wiki:Commentary/Compiler/Backends/PprC --- --- This is simpler than the old PprAbsC, because Cmm is "macro-expanded" --- relative to the old AbstractC, and many oddities/decorations have --- disappeared from the data type. --- --- This code generator is only supported in unregisterised mode. --- ------------------------------------------------------------------------------ - -module PprC ( - writeCs, - pprStringInCStyle - ) where - -#include "HsVersions.h" - --- Cmm stuff -import BlockId -import CLabel -import ForeignCall -import Cmm hiding (pprBBlock) -import PprCmm () -import Hoopl -import CmmUtils -import CmmSwitch - --- Utils -import CPrim -import DynFlags -import FastString -import Outputable -import Platform -import UniqSet -import UniqFM -import Unique -import Util - --- The rest -import Control.Monad.ST -import Data.Bits -import Data.Char -import Data.List -import Data.Map (Map) -import Data.Word -import System.IO -import qualified Data.Map as Map -import Control.Monad (liftM, ap) -import qualified Data.Array.Unsafe as U ( castSTUArray ) -import Data.Array.ST - --- -------------------------------------------------------------------------- --- Top level - -pprCs :: DynFlags -> [RawCmmGroup] -> SDoc -pprCs dflags cmms - = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms) - where - split_marker - | gopt Opt_SplitObjs dflags = text "__STG_SPLIT_MARKER" - | otherwise = empty - -writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO () -writeCs dflags handle cmms - = printForC dflags handle (pprCs dflags cmms) - --- -------------------------------------------------------------------------- --- Now do some real work --- --- for fun, we could call cmmToCmm over the tops... --- - -pprC :: RawCmmGroup -> SDoc -pprC tops = vcat $ intersperse blankLine $ map pprTop tops - --- --- top level procs --- -pprTop :: RawCmmDecl -> SDoc -pprTop (CmmProc infos clbl _ graph) = - - (case mapLookup (g_entry graph) infos of - Nothing -> empty - Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$ - pprWordArray info_clbl info_dat) $$ - (vcat [ - blankLine, - extern_decls, - (if (externallyVisibleCLabel clbl) - then mkFN_ else mkIF_) (ppr clbl) <+> lbrace, - nest 8 temp_decls, - vcat (map pprBBlock blocks), - rbrace ] - ) - where - blocks = toBlockListEntryFirst graph - (temp_decls, extern_decls) = pprTempAndExternDecls blocks - - --- Chunks of static data. - --- We only handle (a) arrays of word-sized things and (b) strings. - -pprTop (CmmData _section (Statics lbl [CmmString str])) = - hcat [ - pprLocalness lbl, text "char ", ppr lbl, - text "[] = ", pprStringInCStyle str, semi - ] - -pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) = - hcat [ - pprLocalness lbl, text "char ", ppr lbl, - brackets (int size), semi - ] - -pprTop (CmmData _section (Statics lbl lits)) = - pprDataExterns lits $$ - pprWordArray lbl lits - --- -------------------------------------------------------------------------- --- BasicBlocks are self-contained entities: they always end in a jump. --- --- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn --- as many jumps as possible into fall throughs. --- - -pprBBlock :: CmmBlock -> SDoc -pprBBlock block = - nest 4 (pprBlockId (entryLabel block) <> colon) $$ - nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last) - where - (_, nodes, last) = blockSplit block - --- -------------------------------------------------------------------------- --- Info tables. Just arrays of words. --- See codeGen/ClosureInfo, and nativeGen/PprMach - -pprWordArray :: CLabel -> [CmmStatic] -> SDoc -pprWordArray lbl ds - = sdocWithDynFlags $ \dflags -> - hcat [ pprLocalness lbl, text "StgWord" - , space, ppr lbl, text "[]" - -- See Note [StgWord alignment] - , pprAlignment (wordWidth dflags) - , text "= {" ] - $$ nest 8 (commafy (pprStatics dflags ds)) - $$ text "};" - -pprAlignment :: Width -> SDoc -pprAlignment words = - text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))" - --- Note [StgWord alignment] --- C codegen builds static closures as StgWord C arrays (pprWordArray). --- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume --- pointers to 'StgClosure' are aligned at pointer size boundary: --- 4 byte boundary on 32 systems --- and 8 bytes on 64-bit systems --- see TAG_MASK and TAG_BITS definition and usage. --- --- It's a reasonable assumption also known as natural alignment. --- Although some architectures have different alignment rules. --- One of known exceptions is m68k (Trac #11395, comment:16) where: --- __alignof__(StgWord) == 2, sizeof(StgWord) == 4 --- --- Thus we explicitly increase alignment by using --- __attribute__((aligned(4))) --- declaration. - --- --- has to be static, if it isn't globally visible --- -pprLocalness :: CLabel -> SDoc -pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static " - | otherwise = empty - --- -------------------------------------------------------------------------- --- Statements. --- - -pprStmt :: CmmNode e x -> SDoc - -pprStmt stmt = - sdocWithDynFlags $ \dflags -> - case stmt of - CmmEntry{} -> empty - CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/") - -- XXX if the string contains "*/", we need to fix it - -- XXX we probably want to emit these comments when - -- some debugging option is on. They can get quite - -- large. - - CmmTick _ -> empty - CmmUnwind{} -> empty - - CmmAssign dest src -> pprAssign dflags dest src - - CmmStore dest src - | typeWidth rep == W64 && wordWidth dflags /= W64 - -> (if isFloatType rep then text "ASSIGN_DBL" - else ptext (sLit ("ASSIGN_Word64"))) <> - parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi - - | otherwise - -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ] - where - rep = cmmExprType dflags src - - CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args -> - fnCall - where - (res_hints, arg_hints) = foreignTargetHints target - hresults = zip results res_hints - hargs = zip args arg_hints - - ForeignConvention cconv _ _ ret = conv - - cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn) - - -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes - fnCall = - case fn of - CmmLit (CmmLabel lbl) - | StdCallConv <- cconv -> - pprCall (ppr lbl) cconv hresults hargs - -- stdcall functions must be declared with - -- a function type, otherwise the C compiler - -- doesn't add the @n suffix to the label. We - -- can't add the @n suffix ourselves, because - -- it isn't valid C. - | CmmNeverReturns <- ret -> - pprCall cast_fn cconv hresults hargs <> semi - | not (isMathFun lbl) -> - pprForeignCall (ppr lbl) cconv hresults hargs - _ -> - pprCall cast_fn cconv hresults hargs <> semi - -- for a dynamic call, no declaration is necessary. - - CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty - CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty - - CmmUnsafeForeignCall target@(PrimTarget op) results args -> - fn_call - where - cconv = CCallConv - fn = pprCallishMachOp_for_C op - - (res_hints, arg_hints) = foreignTargetHints target - hresults = zip results res_hints - hargs = zip args arg_hints - - fn_call - -- The mem primops carry an extra alignment arg. - -- We could maybe emit an alignment directive using this info. - -- We also need to cast mem primops to prevent conflicts with GCC - -- builtins (see bug #5967). - | Just _align <- machOpMemcpyishAlign op - = (text ";EFF_(" <> fn <> char ')' <> semi) $$ - pprForeignCall fn cconv hresults hargs - | otherwise - = pprCall fn cconv hresults hargs - - CmmBranch ident -> pprBranch ident - CmmCondBranch expr yes no _ -> pprCondBranch expr yes no - CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi - CmmSwitch arg ids -> sdocWithDynFlags $ \dflags -> - pprSwitch dflags arg ids - - _other -> pprPanic "PprC.pprStmt" (ppr stmt) - -type Hinted a = (a, ForeignHint) - -pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] - -> SDoc -pprForeignCall fn cconv results args = fn_call - where - fn_call = braces ( - pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi - $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi - $$ pprCall (text "ghcFunPtr") cconv results args <> semi - ) - cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn) - -pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc -pprCFunType ppr_fn cconv ress args - = sdocWithDynFlags $ \dflags -> - let res_type [] = text "void" - res_type [(one, hint)] = machRepHintCType (localRegType one) hint - res_type _ = panic "pprCFunType: only void or 1 return value supported" - - arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint - in res_type ress <+> - parens (ccallConvAttribute cconv <> ppr_fn) <> - parens (commafy (map arg_type args)) - --- --------------------------------------------------------------------- --- unconditional branches -pprBranch :: BlockId -> SDoc -pprBranch ident = text "goto" <+> pprBlockId ident <> semi - - --- --------------------------------------------------------------------- --- conditional branches to local labels -pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc -pprCondBranch expr yes no - = hsep [ text "if" , parens(pprExpr expr) , - text "goto", pprBlockId yes <> semi, - text "else goto", pprBlockId no <> semi ] - --- --------------------------------------------------------------------- --- a local table branch --- --- we find the fall-through cases --- -pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc -pprSwitch dflags e ids - = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace) - 4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace - where - (pairs, mbdef) = switchTargetsFallThrough ids - - -- fall through case - caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix - where - do_fallthrough ix = - hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon , - text "/* fall through */" ] - - final_branch ix = - hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon , - text "goto" , (pprBlockId ident) <> semi ] - - caseify (_ , _ ) = panic "pprSwitch: switch with no cases!" - - def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi - | otherwise = empty - --- --------------------------------------------------------------------- --- Expressions. --- - --- C Types: the invariant is that the C expression generated by --- --- pprExpr e --- --- has a type in C which is also given by --- --- machRepCType (cmmExprType e) --- --- (similar invariants apply to the rest of the pretty printer). - -pprExpr :: CmmExpr -> SDoc -pprExpr e = case e of - CmmLit lit -> pprLit lit - - - CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty - CmmReg reg -> pprCastReg reg - CmmRegOff reg 0 -> pprCastReg reg - - CmmRegOff reg i - | i < 0 && negate_ok -> pprRegOff (char '-') (-i) - | otherwise -> pprRegOff (char '+') i - where - pprRegOff op i' = pprCastReg reg <> op <> int i' - negate_ok = negate (fromIntegral i :: Integer) < - fromIntegral (maxBound::Int) - -- overflow is undefined; see #7620 - - CmmMachOp mop args -> pprMachOpApp mop args - - CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" - - -pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc -pprLoad dflags e ty - | width == W64, wordWidth dflags /= W64 - = (if isFloatType ty then text "PK_DBL" - else text "PK_Word64") - <> parens (mkP_ <> pprExpr1 e) - - | otherwise - = case e of - CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) - -> char '*' <> pprAsPtrReg r - - CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) - -> char '*' <> pprAsPtrReg r - - CmmRegOff r off | isPtrReg r && width == wordWidth dflags - , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty) - -- ToDo: check that the offset is a word multiple? - -- (For tagging to work, I had to avoid unaligned loads. --ARY) - -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags)) - - _other -> cLoad e ty - where - width = typeWidth ty - -pprExpr1 :: CmmExpr -> SDoc -pprExpr1 (CmmLit lit) = pprLit1 lit -pprExpr1 e@(CmmReg _reg) = pprExpr e -pprExpr1 other = parens (pprExpr other) - --- -------------------------------------------------------------------------- --- MachOp applications - -pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc - -pprMachOpApp op args - | isMulMayOfloOp op - = text "mulIntMayOflo" <> parens (commafy (map pprExpr args)) - where isMulMayOfloOp (MO_U_MulMayOflo _) = True - isMulMayOfloOp (MO_S_MulMayOflo _) = True - isMulMayOfloOp _ = False - -pprMachOpApp mop args - | Just ty <- machOpNeedsCast mop - = ty <> parens (pprMachOpApp' mop args) - | otherwise - = pprMachOpApp' mop args - --- Comparisons in C have type 'int', but we want type W_ (this is what --- resultRepOfMachOp says). The other C operations inherit their type --- from their operands, so no casting is required. -machOpNeedsCast :: MachOp -> Maybe SDoc -machOpNeedsCast mop - | isComparisonMachOp mop = Just mkW_ - | otherwise = Nothing - -pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc -pprMachOpApp' mop args - = case args of - -- dyadic - [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y - - -- unary - [x] -> pprMachOp_for_C mop <> parens (pprArg x) - - _ -> panic "PprC.pprMachOp : machop with wrong number of args" - - where - -- Cast needed for signed integer ops - pprArg e | signedOp mop = sdocWithDynFlags $ \dflags -> - cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e - | needsFCasts mop = sdocWithDynFlags $ \dflags -> - cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e - | otherwise = pprExpr1 e - needsFCasts (MO_F_Eq _) = False - needsFCasts (MO_F_Ne _) = False - needsFCasts (MO_F_Neg _) = True - needsFCasts (MO_F_Quot _) = True - needsFCasts mop = floatComparison mop - --- -------------------------------------------------------------------------- --- Literals - -pprLit :: CmmLit -> SDoc -pprLit lit = case lit of - CmmInt i rep -> pprHexVal i rep - - CmmFloat f w -> parens (machRep_F_CType w) <> str - where d = fromRational f :: Double - str | isInfinite d && d < 0 = text "-INFINITY" - | isInfinite d = text "INFINITY" - | isNaN d = text "NAN" - | otherwise = text (show d) - -- these constants come from - -- see #1861 - - CmmVec {} -> panic "PprC printing vector literal" - - CmmBlock bid -> mkW_ <> pprCLabelAddr (infoTblLbl bid) - CmmHighStackMark -> panic "PprC printing high stack mark" - CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl - CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i - CmmLabelDiffOff clbl1 _ i - -- WARNING: - -- * the lit must occur in the info table clbl2 - -- * clbl1 must be an SRT, a slow entry point or a large bitmap - -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i - - where - pprCLabelAddr lbl = char '&' <> ppr lbl - -pprLit1 :: CmmLit -> SDoc -pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit) -pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit) -pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit) -pprLit1 other = pprLit other - --- --------------------------------------------------------------------------- --- Static data - -pprStatics :: DynFlags -> [CmmStatic] -> [SDoc] -pprStatics _ [] = [] -pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest) - -- floats are padded to a word by padLitToWord, see #1852 - | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest - = pprLit1 (floatToWord dflags f) : pprStatics dflags rest' - | wORD_SIZE dflags == 4 - = pprLit1 (floatToWord dflags f) : pprStatics dflags rest - | otherwise - = pprPanic "pprStatics: float" (vcat (map ppr' rest)) - where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags -> - ppr (cmmLitType dflags l) - ppr' _other = text "bad static!" -pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest) - = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest - -pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest) - | wordWidth dflags == W32 - = if wORDS_BIGENDIAN dflags - then pprStatics dflags (CmmStaticLit (CmmInt q W32) : - CmmStaticLit (CmmInt r W32) : rest) - else pprStatics dflags (CmmStaticLit (CmmInt r W32) : - CmmStaticLit (CmmInt q W32) : rest) - where r = i .&. 0xffffffff - q = i `shiftR` 32 -pprStatics dflags (CmmStaticLit (CmmInt _ w) : _) - | w /= wordWidth dflags - = panic "pprStatics: cannot emit a non-word-sized static literal" -pprStatics dflags (CmmStaticLit lit : rest) - = pprLit1 lit : pprStatics dflags rest -pprStatics _ (other : _) - = pprPanic "pprWord" (pprStatic other) - -pprStatic :: CmmStatic -> SDoc -pprStatic s = case s of - - CmmStaticLit lit -> nest 4 (pprLit lit) - CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) - - -- these should be inlined, like the old .hc - CmmString s' -> nest 4 (mkW_ <> parens(pprStringInCStyle s')) - - --- --------------------------------------------------------------------------- --- Block Ids - -pprBlockId :: BlockId -> SDoc -pprBlockId b = char '_' <> ppr (getUnique b) - --- -------------------------------------------------------------------------- --- Print a MachOp in a way suitable for emitting via C. --- - -pprMachOp_for_C :: MachOp -> SDoc - -pprMachOp_for_C mop = case mop of - - -- Integer operations - MO_Add _ -> char '+' - MO_Sub _ -> char '-' - MO_Eq _ -> text "==" - MO_Ne _ -> text "!=" - MO_Mul _ -> char '*' - - MO_S_Quot _ -> char '/' - MO_S_Rem _ -> char '%' - MO_S_Neg _ -> char '-' - - MO_U_Quot _ -> char '/' - MO_U_Rem _ -> char '%' - - -- & Floating-point operations - MO_F_Add _ -> char '+' - MO_F_Sub _ -> char '-' - MO_F_Neg _ -> char '-' - MO_F_Mul _ -> char '*' - MO_F_Quot _ -> char '/' - - -- Signed comparisons - MO_S_Ge _ -> text ">=" - MO_S_Le _ -> text "<=" - MO_S_Gt _ -> char '>' - MO_S_Lt _ -> char '<' - - -- & Unsigned comparisons - MO_U_Ge _ -> text ">=" - MO_U_Le _ -> text "<=" - MO_U_Gt _ -> char '>' - MO_U_Lt _ -> char '<' - - -- & Floating-point comparisons - MO_F_Eq _ -> text "==" - MO_F_Ne _ -> text "!=" - MO_F_Ge _ -> text ">=" - MO_F_Le _ -> text "<=" - MO_F_Gt _ -> char '>' - MO_F_Lt _ -> char '<' - - -- Bitwise operations. Not all of these may be supported at all - -- sizes, and only integral MachReps are valid. - MO_And _ -> char '&' - MO_Or _ -> char '|' - MO_Xor _ -> char '^' - MO_Not _ -> char '~' - MO_Shl _ -> text "<<" - MO_U_Shr _ -> text ">>" -- unsigned shift right - MO_S_Shr _ -> text ">>" -- signed shift right - --- Conversions. Some of these will be NOPs, but never those that convert --- between ints and floats. --- Floating-point conversions use the signed variant. --- We won't know to generate (void*) casts here, but maybe from --- context elsewhere - --- noop casts - MO_UU_Conv from to | from == to -> empty - MO_UU_Conv _from to -> parens (machRep_U_CType to) - - MO_SS_Conv from to | from == to -> empty - MO_SS_Conv _from to -> parens (machRep_S_CType to) - - MO_FF_Conv from to | from == to -> empty - MO_FF_Conv _from to -> parens (machRep_F_CType to) - - MO_SF_Conv _from to -> parens (machRep_F_CType to) - MO_FS_Conv _from to -> parens (machRep_S_CType to) - - MO_S_MulMayOflo _ -> pprTrace "offending mop:" - (text "MO_S_MulMayOflo") - (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo" - ++ " should have been handled earlier!") - MO_U_MulMayOflo _ -> pprTrace "offending mop:" - (text "MO_U_MulMayOflo") - (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo" - ++ " should have been handled earlier!") - - MO_V_Insert {} -> pprTrace "offending mop:" - (text "MO_V_Insert") - (panic $ "PprC.pprMachOp_for_C: MO_V_Insert" - ++ " should have been handled earlier!") - MO_V_Extract {} -> pprTrace "offending mop:" - (text "MO_V_Extract") - (panic $ "PprC.pprMachOp_for_C: MO_V_Extract" - ++ " should have been handled earlier!") - - MO_V_Add {} -> pprTrace "offending mop:" - (text "MO_V_Add") - (panic $ "PprC.pprMachOp_for_C: MO_V_Add" - ++ " should have been handled earlier!") - MO_V_Sub {} -> pprTrace "offending mop:" - (text "MO_V_Sub") - (panic $ "PprC.pprMachOp_for_C: MO_V_Sub" - ++ " should have been handled earlier!") - MO_V_Mul {} -> pprTrace "offending mop:" - (text "MO_V_Mul") - (panic $ "PprC.pprMachOp_for_C: MO_V_Mul" - ++ " should have been handled earlier!") - - MO_VS_Quot {} -> pprTrace "offending mop:" - (text "MO_VS_Quot") - (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot" - ++ " should have been handled earlier!") - MO_VS_Rem {} -> pprTrace "offending mop:" - (text "MO_VS_Rem") - (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem" - ++ " should have been handled earlier!") - MO_VS_Neg {} -> pprTrace "offending mop:" - (text "MO_VS_Neg") - (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg" - ++ " should have been handled earlier!") - - MO_VU_Quot {} -> pprTrace "offending mop:" - (text "MO_VU_Quot") - (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot" - ++ " should have been handled earlier!") - MO_VU_Rem {} -> pprTrace "offending mop:" - (text "MO_VU_Rem") - (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem" - ++ " should have been handled earlier!") - - MO_VF_Insert {} -> pprTrace "offending mop:" - (text "MO_VF_Insert") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert" - ++ " should have been handled earlier!") - MO_VF_Extract {} -> pprTrace "offending mop:" - (text "MO_VF_Extract") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract" - ++ " should have been handled earlier!") - - MO_VF_Add {} -> pprTrace "offending mop:" - (text "MO_VF_Add") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Add" - ++ " should have been handled earlier!") - MO_VF_Sub {} -> pprTrace "offending mop:" - (text "MO_VF_Sub") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub" - ++ " should have been handled earlier!") - MO_VF_Neg {} -> pprTrace "offending mop:" - (text "MO_VF_Neg") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg" - ++ " should have been handled earlier!") - MO_VF_Mul {} -> pprTrace "offending mop:" - (text "MO_VF_Mul") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul" - ++ " should have been handled earlier!") - MO_VF_Quot {} -> pprTrace "offending mop:" - (text "MO_VF_Quot") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot" - ++ " should have been handled earlier!") - -signedOp :: MachOp -> Bool -- Argument type(s) are signed ints -signedOp (MO_S_Quot _) = True -signedOp (MO_S_Rem _) = True -signedOp (MO_S_Neg _) = True -signedOp (MO_S_Ge _) = True -signedOp (MO_S_Le _) = True -signedOp (MO_S_Gt _) = True -signedOp (MO_S_Lt _) = True -signedOp (MO_S_Shr _) = True -signedOp (MO_SS_Conv _ _) = True -signedOp (MO_SF_Conv _ _) = True -signedOp _ = False - -floatComparison :: MachOp -> Bool -- comparison between float args -floatComparison (MO_F_Eq _) = True -floatComparison (MO_F_Ne _) = True -floatComparison (MO_F_Ge _) = True -floatComparison (MO_F_Le _) = True -floatComparison (MO_F_Gt _) = True -floatComparison (MO_F_Lt _) = True -floatComparison _ = False - --- --------------------------------------------------------------------- --- tend to be implemented by foreign calls - -pprCallishMachOp_for_C :: CallishMachOp -> SDoc - -pprCallishMachOp_for_C mop - = case mop of - MO_F64_Pwr -> text "pow" - MO_F64_Sin -> text "sin" - MO_F64_Cos -> text "cos" - MO_F64_Tan -> text "tan" - MO_F64_Sinh -> text "sinh" - MO_F64_Cosh -> text "cosh" - MO_F64_Tanh -> text "tanh" - MO_F64_Asin -> text "asin" - MO_F64_Acos -> text "acos" - MO_F64_Atan -> text "atan" - MO_F64_Log -> text "log" - MO_F64_Exp -> text "exp" - MO_F64_Sqrt -> text "sqrt" - MO_F64_Fabs -> text "fabs" - MO_F32_Pwr -> text "powf" - MO_F32_Sin -> text "sinf" - MO_F32_Cos -> text "cosf" - MO_F32_Tan -> text "tanf" - MO_F32_Sinh -> text "sinhf" - MO_F32_Cosh -> text "coshf" - MO_F32_Tanh -> text "tanhf" - MO_F32_Asin -> text "asinf" - MO_F32_Acos -> text "acosf" - MO_F32_Atan -> text "atanf" - MO_F32_Log -> text "logf" - MO_F32_Exp -> text "expf" - MO_F32_Sqrt -> text "sqrtf" - MO_F32_Fabs -> text "fabsf" - MO_WriteBarrier -> text "write_barrier" - MO_Memcpy _ -> text "memcpy" - MO_Memset _ -> text "memset" - MO_Memmove _ -> text "memmove" - (MO_BSwap w) -> ptext (sLit $ bSwapLabel w) - (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) - (MO_Clz w) -> ptext (sLit $ clzLabel w) - (MO_Ctz w) -> ptext (sLit $ ctzLabel w) - (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop) - (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w) - (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w) - (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w) - (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w) - - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - MO_Add2 {} -> unsupported - MO_SubWordC {} -> unsupported - MO_AddIntC {} -> unsupported - MO_SubIntC {} -> unsupported - MO_U_Mul2 {} -> unsupported - MO_Touch -> unsupported - (MO_Prefetch_Data _ ) -> unsupported - --- we could support prefetch via "__builtin_prefetch" - --- Not adding it for now - where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop - ++ " not supported!") - --- --------------------------------------------------------------------- --- Useful #defines --- - -mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc - -mkJMP_ i = text "JMP_" <> parens i -mkFN_ i = text "FN_" <> parens i -- externally visible function -mkIF_ i = text "IF_" <> parens i -- locally visible - --- from includes/Stg.h --- -mkC_,mkW_,mkP_ :: SDoc - -mkC_ = text "(C_)" -- StgChar -mkW_ = text "(W_)" -- StgWord -mkP_ = text "(P_)" -- StgWord* - --- --------------------------------------------------------------------- --- --- Assignments --- --- Generating assignments is what we're all about, here --- -pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc - --- dest is a reg, rhs is a reg -pprAssign _ r1 (CmmReg r2) - | isPtrReg r1 && isPtrReg r2 - = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ] - --- dest is a reg, rhs is a CmmRegOff -pprAssign dflags r1 (CmmRegOff r2 off) - | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0) - = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] - where - off1 = off `shiftR` wordShift dflags - - (op,off') | off >= 0 = (char '+', off1) - | otherwise = (char '-', -off1) - --- dest is a reg, rhs is anything. --- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting --- the lvalue elicits a warning from new GCC versions (3.4+). -pprAssign _ r1 r2 - | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2) - | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2) - | otherwise = mkAssign (pprExpr r2) - where mkAssign x = if r1 == CmmGlobal BaseReg - then text "ASSIGN_BaseReg" <> parens x <> semi - else pprReg r1 <> text " = " <> x <> semi - --- --------------------------------------------------------------------- --- Registers - -pprCastReg :: CmmReg -> SDoc -pprCastReg reg - | isStrangeTypeReg reg = mkW_ <> pprReg reg - | otherwise = pprReg reg - --- True if (pprReg reg) will give an expression with type StgPtr. We --- need to take care with pointer arithmetic on registers with type --- StgPtr. -isFixedPtrReg :: CmmReg -> Bool -isFixedPtrReg (CmmLocal _) = False -isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r - --- True if (pprAsPtrReg reg) will give an expression with type StgPtr --- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST. --- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT; --- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY. -isPtrReg :: CmmReg -> Bool -isPtrReg (CmmLocal _) = False -isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg - --- True if this global reg has type StgPtr -isFixedPtrGlobalReg :: GlobalReg -> Bool -isFixedPtrGlobalReg Sp = True -isFixedPtrGlobalReg Hp = True -isFixedPtrGlobalReg HpLim = True -isFixedPtrGlobalReg SpLim = True -isFixedPtrGlobalReg _ = False - --- True if in C this register doesn't have the type given by --- (machRepCType (cmmRegType reg)), so it has to be cast. -isStrangeTypeReg :: CmmReg -> Bool -isStrangeTypeReg (CmmLocal _) = False -isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g - -isStrangeTypeGlobal :: GlobalReg -> Bool -isStrangeTypeGlobal CCCS = True -isStrangeTypeGlobal CurrentTSO = True -isStrangeTypeGlobal CurrentNursery = True -isStrangeTypeGlobal BaseReg = True -isStrangeTypeGlobal r = isFixedPtrGlobalReg r - -strangeRegType :: CmmReg -> Maybe SDoc -strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *") -strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *") -strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *") -strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *") -strangeRegType _ = Nothing - --- pprReg just prints the register name. --- -pprReg :: CmmReg -> SDoc -pprReg r = case r of - CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global - -pprAsPtrReg :: CmmReg -> SDoc -pprAsPtrReg (CmmGlobal (VanillaReg n gcp)) - = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p" -pprAsPtrReg other_reg = pprReg other_reg - -pprGlobalReg :: GlobalReg -> SDoc -pprGlobalReg gr = case gr of - VanillaReg n _ -> char 'R' <> int n <> text ".w" - -- pprGlobalReg prints a VanillaReg as a .w regardless - -- Example: R1.w = R1.w & (-0x8UL); - -- JMP_(*R1.p); - FloatReg n -> char 'F' <> int n - DoubleReg n -> char 'D' <> int n - LongReg n -> char 'L' <> int n - Sp -> text "Sp" - SpLim -> text "SpLim" - Hp -> text "Hp" - HpLim -> text "HpLim" - CCCS -> text "CCCS" - CurrentTSO -> text "CurrentTSO" - CurrentNursery -> text "CurrentNursery" - HpAlloc -> text "HpAlloc" - BaseReg -> text "BaseReg" - EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" - GCEnter1 -> text "stg_gc_enter_1" - GCFun -> text "stg_gc_fun" - other -> panic $ "pprGlobalReg: Unsupported register: " ++ show other - -pprLocalReg :: LocalReg -> SDoc -pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq - --- ----------------------------------------------------------------------------- --- Foreign Calls - -pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc -pprCall ppr_fn cconv results args - | not (is_cishCC cconv) - = panic $ "pprCall: unknown calling convention" - - | otherwise - = - ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi - where - ppr_assign [] rhs = rhs - ppr_assign [(one,hint)] rhs - = pprLocalReg one <> text " = " - <> pprUnHint hint (localRegType one) <> rhs - ppr_assign _other _rhs = panic "pprCall: multiple results" - - pprArg (expr, AddrHint) - = cCast (text "void *") expr - -- see comment by machRepHintCType below - pprArg (expr, SignedHint) - = sdocWithDynFlags $ \dflags -> - cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr - pprArg (expr, _other) - = pprExpr expr - - pprUnHint AddrHint rep = parens (machRepCType rep) - pprUnHint SignedHint rep = parens (machRepCType rep) - pprUnHint _ _ = empty - --- Currently we only have these two calling conventions, but this might --- change in the future... -is_cishCC :: CCallConv -> Bool -is_cishCC CCallConv = True -is_cishCC CApiConv = True -is_cishCC StdCallConv = True -is_cishCC PrimCallConv = False -is_cishCC JavaScriptCallConv = False - --- --------------------------------------------------------------------- --- Find and print local and external declarations for a list of --- Cmm statements. --- -pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-}) -pprTempAndExternDecls stmts - = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl), - vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))) - where (temps, lbls) = runTE (mapM_ te_BB stmts) - -pprDataExterns :: [CmmStatic] -> SDoc -pprDataExterns statics - = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)) - where (_, lbls) = runTE (mapM_ te_Static statics) - -pprTempDecl :: LocalReg -> SDoc -pprTempDecl l@(LocalReg _ rep) - = hcat [ machRepCType rep, space, pprLocalReg l, semi ] - -pprExternDecl :: Bool -> CLabel -> SDoc -pprExternDecl _in_srt lbl - -- do not print anything for "known external" things - | not (needsCDecl lbl) = empty - | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz - | otherwise = - hcat [ visibility, label_type lbl, - lparen, ppr lbl, text ");" ] - where - label_type lbl | isBytesLabel lbl = text "B_" - | isForeignLabel lbl && isCFunctionLabel lbl = text "FF_" - | isCFunctionLabel lbl = text "F_" - | otherwise = text "I_" - - visibility - | externallyVisibleCLabel lbl = char 'E' - | otherwise = char 'I' - - -- If the label we want to refer to is a stdcall function (on Windows) then - -- we must generate an appropriate prototype for it, so that the C compiler will - -- add the @n suffix to the label (#2276) - stdcall_decl sz = sdocWithDynFlags $ \dflags -> - text "extern __attribute__((stdcall)) void " <> ppr lbl - <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags)))) - <> semi - -type TEState = (UniqSet LocalReg, Map CLabel ()) -newtype TE a = TE { unTE :: TEState -> (a, TEState) } - -instance Functor TE where - fmap = liftM - -instance Applicative TE where - pure a = TE $ \s -> (a, s) - (<*>) = ap - -instance Monad TE where - TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s' - -te_lbl :: CLabel -> TE () -te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls)) - -te_temp :: LocalReg -> TE () -te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls)) - -runTE :: TE () -> TEState -runTE (TE m) = snd (m (emptyUniqSet, Map.empty)) - -te_Static :: CmmStatic -> TE () -te_Static (CmmStaticLit lit) = te_Lit lit -te_Static _ = return () - -te_BB :: CmmBlock -> TE () -te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last - where (_, mid, last) = blockSplit block - -te_Lit :: CmmLit -> TE () -te_Lit (CmmLabel l) = te_lbl l -te_Lit (CmmLabelOff l _) = te_lbl l -te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1 -te_Lit _ = return () - -te_Stmt :: CmmNode e x -> TE () -te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e -te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r -te_Stmt (CmmUnsafeForeignCall target rs es) - = do te_Target target - mapM_ te_temp rs - mapM_ te_Expr es -te_Stmt (CmmCondBranch e _ _ _) = te_Expr e -te_Stmt (CmmSwitch e _) = te_Expr e -te_Stmt (CmmCall { cml_target = e }) = te_Expr e -te_Stmt _ = return () - -te_Target :: ForeignTarget -> TE () -te_Target (ForeignTarget e _) = te_Expr e -te_Target (PrimTarget{}) = return () - -te_Expr :: CmmExpr -> TE () -te_Expr (CmmLit lit) = te_Lit lit -te_Expr (CmmLoad e _) = te_Expr e -te_Expr (CmmReg r) = te_Reg r -te_Expr (CmmMachOp _ es) = mapM_ te_Expr es -te_Expr (CmmRegOff r _) = te_Reg r -te_Expr (CmmStackSlot _ _) = panic "te_Expr: CmmStackSlot not supported!" - -te_Reg :: CmmReg -> TE () -te_Reg (CmmLocal l) = te_temp l -te_Reg _ = return () - - --- --------------------------------------------------------------------- --- C types for MachReps - -cCast :: SDoc -> CmmExpr -> SDoc -cCast ty expr = parens ty <> pprExpr1 expr - -cLoad :: CmmExpr -> CmmType -> SDoc -cLoad expr rep - = sdocWithPlatform $ \platform -> - if bewareLoadStoreAlignment (platformArch platform) - then let decl = machRepCType rep <+> text "x" <> semi - struct = text "struct" <+> braces (decl) - packed_attr = text "__attribute__((packed))" - cast = parens (struct <+> packed_attr <> char '*') - in parens (cast <+> pprExpr1 expr) <> text "->x" - else char '*' <> parens (cCast (machRepPtrCType rep) expr) - where -- On these platforms, unaligned loads are known to cause problems - bewareLoadStoreAlignment ArchAlpha = True - bewareLoadStoreAlignment ArchMipseb = True - bewareLoadStoreAlignment ArchMipsel = True - bewareLoadStoreAlignment (ArchARM {}) = True - bewareLoadStoreAlignment ArchARM64 = True - bewareLoadStoreAlignment ArchSPARC = True - bewareLoadStoreAlignment ArchSPARC64 = True - -- Pessimistically assume that they will also cause problems - -- on unknown arches - bewareLoadStoreAlignment ArchUnknown = True - bewareLoadStoreAlignment _ = False - -isCmmWordType :: DynFlags -> CmmType -> Bool --- True of GcPtrReg/NonGcReg of native word size -isCmmWordType dflags ty = not (isFloatType ty) - && typeWidth ty == wordWidth dflags - --- This is for finding the types of foreign call arguments. For a pointer --- argument, we always cast the argument to (void *), to avoid warnings from --- the C compiler. -machRepHintCType :: CmmType -> ForeignHint -> SDoc -machRepHintCType _ AddrHint = text "void *" -machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep) -machRepHintCType rep _other = machRepCType rep - -machRepPtrCType :: CmmType -> SDoc -machRepPtrCType r - = sdocWithDynFlags $ \dflags -> - if isCmmWordType dflags r then text "P_" - else machRepCType r <> char '*' - -machRepCType :: CmmType -> SDoc -machRepCType ty | isFloatType ty = machRep_F_CType w - | otherwise = machRep_U_CType w - where - w = typeWidth ty - -machRep_F_CType :: Width -> SDoc -machRep_F_CType W32 = text "StgFloat" -- ToDo: correct? -machRep_F_CType W64 = text "StgDouble" -machRep_F_CType _ = panic "machRep_F_CType" - -machRep_U_CType :: Width -> SDoc -machRep_U_CType w - = sdocWithDynFlags $ \dflags -> - case w of - _ | w == wordWidth dflags -> text "W_" - W8 -> text "StgWord8" - W16 -> text "StgWord16" - W32 -> text "StgWord32" - W64 -> text "StgWord64" - _ -> panic "machRep_U_CType" - -machRep_S_CType :: Width -> SDoc -machRep_S_CType w - = sdocWithDynFlags $ \dflags -> - case w of - _ | w == wordWidth dflags -> text "I_" - W8 -> text "StgInt8" - W16 -> text "StgInt16" - W32 -> text "StgInt32" - W64 -> text "StgInt64" - _ -> panic "machRep_S_CType" - - --- --------------------------------------------------------------------- --- print strings as valid C strings - -pprStringInCStyle :: [Word8] -> SDoc -pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) - --- --------------------------------------------------------------------------- --- Initialising static objects with floating-point numbers. We can't --- just emit the floating point number, because C will cast it to an int --- by rounding it. We want the actual bit-representation of the float. --- --- Consider a concrete C example: --- double d = 2.5e-10; --- float f = 2.5e-10f; --- --- int * i2 = &d; printf ("i2: %08X %08X\n", i2[0], i2[1]); --- long long * l = &d; printf (" l: %016llX\n", l[0]); --- int * i = &f; printf (" i: %08X\n", i[0]); --- Result on 64-bit LE (x86_64): --- i2: E826D695 3DF12E0B --- l: 3DF12E0BE826D695 --- i: 2F89705F --- Result on 32-bit BE (m68k): --- i2: 3DF12E0B E826D695 --- l: 3DF12E0BE826D695 --- i: 2F89705F --- --- The trick here is to notice that binary representation does not --- change much: only Word32 values get swapped on LE hosts / targets. - --- This is a hack to turn the floating point numbers into ints that we --- can safely initialise to static locations. - -castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32) -castFloatToWord32Array = U.castSTUArray - -castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64) -castDoubleToWord64Array = U.castSTUArray - -floatToWord :: DynFlags -> Rational -> CmmLit -floatToWord dflags r - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 (fromRational r) - arr' <- castFloatToWord32Array arr - w32 <- readArray arr' 0 - return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags)) - ) - where wo | wordWidth dflags == W64 - , wORDS_BIGENDIAN dflags = 32 - | otherwise = 0 - -doubleToWords :: DynFlags -> Rational -> [CmmLit] -doubleToWords dflags r - = runST (do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 (fromRational r) - arr' <- castDoubleToWord64Array arr - w64 <- readArray arr' 0 - return (pprWord64 w64) - ) - where targetWidth = wordWidth dflags - targetBE = wORDS_BIGENDIAN dflags - pprWord64 w64 - | targetWidth == W64 = - [ CmmInt (toInteger w64) targetWidth ] - | targetWidth == W32 = - [ CmmInt (toInteger targetW1) targetWidth - , CmmInt (toInteger targetW2) targetWidth - ] - | otherwise = panic "doubleToWords.pprWord64" - where (targetW1, targetW2) - | targetBE = (wHi, wLo) - | otherwise = (wLo, wHi) - wHi = w64 `shiftR` 32 - wLo = w64 .&. 0xFFFFffff - --- --------------------------------------------------------------------------- --- Utils - -wordShift :: DynFlags -> Int -wordShift dflags = widthInLog (wordWidth dflags) - -commafy :: [SDoc] -> SDoc -commafy xs = hsep $ punctuate comma xs - --- Print in C hex format: 0x13fa -pprHexVal :: Integer -> Width -> SDoc -pprHexVal w rep - | w < 0 = parens (char '-' <> - text "0x" <> intToDoc (-w) <> repsuffix rep) - | otherwise = text "0x" <> intToDoc w <> repsuffix rep - where - -- type suffix for literals: - -- Integer literals are unsigned in Cmm/C. We explicitly cast to - -- signed values for doing signed operations, but at all other - -- times values are unsigned. This also helps eliminate occasional - -- warnings about integer overflow from gcc. - - repsuffix W64 = sdocWithDynFlags $ \dflags -> - if cINT_SIZE dflags == 8 then char 'U' - else if cLONG_SIZE dflags == 8 then text "UL" - else if cLONG_LONG_SIZE dflags == 8 then text "ULL" - else panic "pprHexVal: Can't find a 64-bit type" - repsuffix _ = char 'U' - - intToDoc :: Integer -> SDoc - intToDoc i = case truncInt i of - 0 -> char '0' - v -> go v - - -- We need to truncate value as Cmm backend does not drop - -- redundant bits to ease handling of negative values. - -- Thus the following Cmm code on 64-bit arch, like amd64: - -- CInt v; - -- v = {something}; - -- if (v == %lobits32(-1)) { ... - -- leads to the following C code: - -- StgWord64 v = (StgWord32)({something}); - -- if (v == 0xFFFFffffFFFFffffU) { ... - -- Such code is incorrect as it promotes both operands to StgWord64 - -- and the whole condition is always false. - truncInt :: Integer -> Integer - truncInt i = - case rep of - W8 -> i `rem` (2^(8 :: Int)) - W16 -> i `rem` (2^(16 :: Int)) - W32 -> i `rem` (2^(32 :: Int)) - W64 -> i `rem` (2^(64 :: Int)) - _ -> panic ("pprHexVal/truncInt: C backend can't encode " - ++ show rep ++ " literals") - - go 0 = empty - go w' = go q <> dig - where - (q,r) = w' `quotRem` 16 - dig | r < 10 = char (chr (fromInteger r + ord '0')) - | otherwise = char (chr (fromInteger r - 10 + ord 'a')) diff --git a/cmm/PprCmm.hs b/cmm/PprCmm.hs deleted file mode 100644 --- a/cmm/PprCmm.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ----------------------------------------------------------------------------- --- --- Pretty-printing of Cmm as (a superset of) C-- --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ --- --- This is where we walk over CmmNode emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cminusminus.org/. We differ --- slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs - -module PprCmm - ( module PprCmmDecl - , module PprCmmExpr - ) -where - -import BlockId () -import CLabel -import Cmm -import CmmUtils -import CmmSwitch -import DynFlags -import FastString -import Outputable -import PprCmmDecl -import PprCmmExpr -import Util -import PprCore () - -import BasicTypes -import Compiler.Hoopl -import Data.List -import Prelude hiding (succ) - -------------------------------------------------- --- Outputable instances - -instance Outputable CmmStackInfo where - ppr = pprStackInfo - -instance Outputable CmmTopInfo where - ppr = pprTopInfo - - -instance Outputable (CmmNode e x) where - ppr = pprNode - -instance Outputable Convention where - ppr = pprConvention - -instance Outputable ForeignConvention where - ppr = pprForeignConvention - -instance Outputable ForeignTarget where - ppr = pprForeignTarget - -instance Outputable CmmReturnInfo where - ppr = pprReturnInfo - -instance Outputable (Block CmmNode C C) where - ppr = pprBlock -instance Outputable (Block CmmNode C O) where - ppr = pprBlock -instance Outputable (Block CmmNode O C) where - ppr = pprBlock -instance Outputable (Block CmmNode O O) where - ppr = pprBlock - -instance Outputable (Graph CmmNode e x) where - ppr = pprGraph - -instance Outputable CmmGraph where - ppr = pprCmmGraph - ----------------------------------------------------------- --- Outputting types Cmm contains - -pprStackInfo :: CmmStackInfo -> SDoc -pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = - text "arg_space: " <> ppr arg_space <+> - text "updfr_space: " <> ppr updfr_space - -pprTopInfo :: CmmTopInfo -> SDoc -pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = - vcat [text "info_tbl: " <> ppr info_tbl, - text "stack_info: " <> ppr stack_info] - ----------------------------------------------------------- --- Outputting blocks and graphs - -pprBlock :: IndexedCO x SDoc SDoc ~ SDoc - => Block CmmNode e x -> IndexedCO e SDoc SDoc -pprBlock block - = foldBlockNodesB3 ( ($$) . ppr - , ($$) . (nest 4) . ppr - , ($$) . (nest 4) . ppr - ) - block - empty - -pprGraph :: Graph CmmNode e x -> SDoc -pprGraph GNil = empty -pprGraph (GUnit block) = ppr block -pprGraph (GMany entry body exit) - = text "{" - $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit) - $$ text "}" - where pprMaybeO :: Outputable (Block CmmNode e x) - => MaybeO ex (Block CmmNode e x) -> SDoc - pprMaybeO NothingO = empty - pprMaybeO (JustO block) = ppr block - -pprCmmGraph :: CmmGraph -> SDoc -pprCmmGraph g - = text "{" <> text "offset" - $$ nest 2 (vcat $ map ppr blocks) - $$ text "}" - where blocks = postorderDfs g - -- postorderDfs has the side-effect of discarding unreachable code, - -- so pretty-printed Cmm will omit any unreachable blocks. This can - -- sometimes be confusing. - ---------------------------------------------- --- Outputting CmmNode and types which it contains - -pprConvention :: Convention -> SDoc -pprConvention (NativeNodeCall {}) = text "" -pprConvention (NativeDirectCall {}) = text "" -pprConvention (NativeReturn {}) = text "" -pprConvention Slow = text "" -pprConvention GC = text "" - -pprForeignConvention :: ForeignConvention -> SDoc -pprForeignConvention (ForeignConvention c args res ret) = - doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret - -pprReturnInfo :: CmmReturnInfo -> SDoc -pprReturnInfo CmmMayReturn = empty -pprReturnInfo CmmNeverReturns = text "never returns" - -pprForeignTarget :: ForeignTarget -> SDoc -pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn - where - ppr_target :: CmmExpr -> SDoc - ppr_target t@(CmmLit _) = ppr t - ppr_target fn' = parens (ppr fn') - -pprForeignTarget (PrimTarget op) - -- HACK: We're just using a ForeignLabel to get this printed, the label - -- might not really be foreign. - = ppr - (CmmLabel (mkForeignLabel - (mkFastString (show op)) - Nothing ForeignLabelInThisPackage IsFunction)) - -pprNode :: CmmNode e x -> SDoc -pprNode node = pp_node <+> pp_debug - where - pp_node :: SDoc - pp_node = sdocWithDynFlags $ \dflags -> case node of - -- label: - CmmEntry id tscope -> ppr id <> colon <+> - (sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope)) - - -- // text - CmmComment s -> text "//" <+> ftext s - - -- //tick bla<...> - CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $ - text "//tick" <+> ppr t - - -- unwind reg = expr; - CmmUnwind regs -> - text "unwind " - <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi - - -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi - - -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi - where - rep = sdocWithDynFlags $ \dflags -> - ppr ( cmmExprType dflags expr ) - - -- call "ccall" foo(x, y)[r1, r2]; - -- ToDo ppr volatile - CmmUnsafeForeignCall target results args -> - hsep [ ppUnless (null results) $ - parens (commafy $ map ppr results) <+> equals, - text "call", - ppr target <> parens (commafy $ map ppr args) <> semi] - - -- goto label; - CmmBranch ident -> text "goto" <+> ppr ident <> semi - - -- if (expr) goto t; else goto f; - CmmCondBranch expr t f l -> - hsep [ text "if" - , parens(ppr expr) - , case l of - Nothing -> empty - Just b -> parens (text "likely:" <+> ppr b) - , text "goto" - , ppr t <> semi - , text "else goto" - , ppr f <> semi - ] - - CmmSwitch expr ids -> - hang (hsep [ text "switch" - , range - , if isTrivialCmmExpr expr - then ppr expr - else parens (ppr expr) - , text "{" - ]) - 4 (vcat (map ppCase cases) $$ def) $$ rbrace - where - (cases, mbdef) = switchTargetsFallThrough ids - ppCase (is,l) = hsep - [ text "case" - , commafy $ map integer is - , text ": goto" - , ppr l <> semi - ] - def | Just l <- mbdef = hsep - [ text "default: goto" - , ppr l <> semi - ] - | otherwise = empty - - range = brackets $ hsep [integer lo, text "..", integer hi] - where (lo,hi) = switchTargetsRange ids - - CmmCall tgt k regs out res updfr_off -> - hcat [ text "call", space - , pprFun tgt, parens (interpp'SP regs), space - , returns <+> - text "args: " <> ppr out <> comma <+> - text "res: " <> ppr res <> comma <+> - text "upd: " <> ppr updfr_off - , semi ] - where pprFun f@(CmmLit _) = ppr f - pprFun f = parens (ppr f) - - returns - | Just r <- k = text "returns to" <+> ppr r <> comma - | otherwise = empty - - CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> - hcat $ if i then [text "interruptible", space] else [] ++ - [ text "foreign call", space - , ppr t, text "(...)", space - , text "returns to" <+> ppr s - <+> text "args:" <+> parens (ppr as) - <+> text "ress:" <+> parens (ppr rs) - , text "ret_args:" <+> ppr a - , text "ret_off:" <+> ppr u - , semi ] - - pp_debug :: SDoc - pp_debug = - if not debugIsOn then empty - else case node of - CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" - CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" - CmmTick {} -> empty - CmmUnwind {} -> text " // CmmUnwind" - CmmAssign {} -> text " // CmmAssign" - CmmStore {} -> text " // CmmStore" - CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" - CmmBranch {} -> text " // CmmBranch" - CmmCondBranch {} -> text " // CmmCondBranch" - CmmSwitch {} -> text " // CmmSwitch" - CmmCall {} -> text " // CmmCall" - CmmForeignCall {} -> text " // CmmForeignCall" - - commafy :: [SDoc] -> SDoc - commafy xs = hsep $ punctuate comma xs diff --git a/cmm/PprCmmDecl.hs b/cmm/PprCmmDecl.hs deleted file mode 100644 --- a/cmm/PprCmmDecl.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE CPP #-} - ----------------------------------------------------------------------------- --- --- Pretty-printing of common Cmm types --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - --- --- This is where we walk over Cmm emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cminusminus.org/. We differ --- slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs --- - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module PprCmmDecl - ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic - ) -where - -import PprCmmExpr -import Cmm - -import DynFlags -import Outputable -import FastString - -import Data.List -import System.IO - --- Temp Jan08 -import SMRep -#include "rts/storage/FunTypes.h" - - -pprCmms :: (Outputable info, Outputable g) - => [GenCmmGroup CmmStatics info g] -> SDoc -pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) - where - separator = space $$ text "-------------------" $$ space - -writeCmms :: (Outputable info, Outputable g) - => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO () -writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms) - ------------------------------------------------------------------------------ - -instance (Outputable d, Outputable info, Outputable i) - => Outputable (GenCmmDecl d info i) where - ppr t = pprTop t - -instance Outputable CmmStatics where - ppr = pprStatics - -instance Outputable CmmStatic where - ppr = pprStatic - -instance Outputable CmmInfoTable where - ppr = pprInfoTable - - ------------------------------------------------------------------------------ - -pprCmmGroup :: (Outputable d, Outputable info, Outputable g) - => GenCmmGroup d info g -> SDoc -pprCmmGroup tops - = vcat $ intersperse blankLine $ map pprTop tops - --- -------------------------------------------------------------------------- --- Top level `procedure' blocks. --- -pprTop :: (Outputable d, Outputable info, Outputable i) - => GenCmmDecl d info i -> SDoc - -pprTop (CmmProc info lbl live graph) - - = vcat [ ppr lbl <> lparen <> rparen <+> text "// " <+> ppr live - , nest 8 $ lbrace <+> ppr info $$ rbrace - , nest 4 $ ppr graph - , rbrace ] - --- -------------------------------------------------------------------------- --- We follow [1], 4.5 --- --- section "data" { ... } --- -pprTop (CmmData section ds) = - (hang (pprSection section <+> lbrace) 4 (ppr ds)) - $$ rbrace - --- -------------------------------------------------------------------------- --- Info tables. - -pprInfoTable :: CmmInfoTable -> SDoc -pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep - , cit_prof = prof_info - , cit_srt = _srt }) - = vcat [ text "label:" <+> ppr lbl - , text "rep:" <> ppr rep - , case prof_info of - NoProfilingInfo -> empty - ProfilingInfo ct cd -> vcat [ text "type:" <+> pprWord8String ct - , text "desc: " <> pprWord8String cd ] ] - -instance Outputable C_SRT where - ppr NoC_SRT = text "_no_srt_" - ppr (C_SRT label off bitmap) - = parens (ppr label <> comma <> ppr off <> comma <> ppr bitmap) - -instance Outputable ForeignHint where - ppr NoHint = empty - ppr SignedHint = quotes(text "signed") --- ppr AddrHint = quotes(text "address") --- Temp Jan08 - ppr AddrHint = (text "PtrHint") - --- -------------------------------------------------------------------------- --- Static data. --- Strings are printed as C strings, and we print them as I8[], --- following C-- --- -pprStatics :: CmmStatics -> SDoc -pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) - -pprStatic :: CmmStatic -> SDoc -pprStatic s = case s of - CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit lit <> semi - CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) - CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') - --- -------------------------------------------------------------------------- --- data sections --- -pprSection :: Section -> SDoc -pprSection (Section t suffix) = - section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix) - where - section = text "section" - -pprSectionType :: SectionType -> SDoc -pprSectionType s = doubleQuotes (ptext t) - where - t = case s of - Text -> sLit "text" - Data -> sLit "data" - ReadOnlyData -> sLit "readonly" - ReadOnlyData16 -> sLit "readonly16" - RelocatableReadOnlyData - -> sLit "relreadonly" - UninitialisedData -> sLit "uninitialised" - CString -> sLit "cstring" - OtherSection s' -> sLit s' -- Not actually a literal though. diff --git a/cmm/PprCmmExpr.hs b/cmm/PprCmmExpr.hs deleted file mode 100644 --- a/cmm/PprCmmExpr.hs +++ /dev/null @@ -1,279 +0,0 @@ ----------------------------------------------------------------------------- --- --- Pretty-printing of common Cmm types --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - --- --- This is where we walk over Cmm emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cminusminus.org/. We differ --- slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs --- - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module PprCmmExpr - ( pprExpr, pprLit - ) -where - -import CmmExpr - -import Outputable - -import Data.Maybe -import Numeric ( fromRat ) - ------------------------------------------------------------------------------ - -instance Outputable CmmExpr where - ppr e = pprExpr e - -instance Outputable CmmReg where - ppr e = pprReg e - -instance Outputable CmmLit where - ppr l = pprLit l - -instance Outputable LocalReg where - ppr e = pprLocalReg e - -instance Outputable Area where - ppr e = pprArea e - -instance Outputable GlobalReg where - ppr e = pprGlobalReg e - --- -------------------------------------------------------------------------- --- Expressions --- - -pprExpr :: CmmExpr -> SDoc -pprExpr e - = sdocWithDynFlags $ \dflags -> - case e of - CmmRegOff reg i -> - pprExpr (CmmMachOp (MO_Add rep) - [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) - where rep = typeWidth (cmmRegType dflags reg) - CmmLit lit -> pprLit lit - _other -> pprExpr1 e - --- Here's the precedence table from CmmParse.y: --- %nonassoc '>=' '>' '<=' '<' '!=' '==' --- %left '|' --- %left '^' --- %left '&' --- %left '>>' '<<' --- %left '-' '+' --- %left '/' '*' '%' --- %right '~' - --- We just cope with the common operators for now, the rest will get --- a default conservative behaviour. - --- %nonassoc '>=' '>' '<=' '<' '!=' '==' -pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc -pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op - = pprExpr7 x <+> doc <+> pprExpr7 y -pprExpr1 e = pprExpr7 e - -infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc - -infixMachOp1 (MO_Eq _) = Just (text "==") -infixMachOp1 (MO_Ne _) = Just (text "!=") -infixMachOp1 (MO_Shl _) = Just (text "<<") -infixMachOp1 (MO_U_Shr _) = Just (text ">>") -infixMachOp1 (MO_U_Ge _) = Just (text ">=") -infixMachOp1 (MO_U_Le _) = Just (text "<=") -infixMachOp1 (MO_U_Gt _) = Just (char '>') -infixMachOp1 (MO_U_Lt _) = Just (char '<') -infixMachOp1 _ = Nothing - --- %left '-' '+' -pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 - = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) -pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op - = pprExpr7 x <+> doc <+> pprExpr8 y -pprExpr7 e = pprExpr8 e - -infixMachOp7 (MO_Add _) = Just (char '+') -infixMachOp7 (MO_Sub _) = Just (char '-') -infixMachOp7 _ = Nothing - --- %left '/' '*' '%' -pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op - = pprExpr8 x <+> doc <+> pprExpr9 y -pprExpr8 e = pprExpr9 e - -infixMachOp8 (MO_U_Quot _) = Just (char '/') -infixMachOp8 (MO_Mul _) = Just (char '*') -infixMachOp8 (MO_U_Rem _) = Just (char '%') -infixMachOp8 _ = Nothing - -pprExpr9 :: CmmExpr -> SDoc -pprExpr9 e = - case e of - CmmLit lit -> pprLit1 lit - CmmLoad expr rep -> ppr rep <> brackets (ppr expr) - CmmReg reg -> ppr reg - CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) - CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) - CmmMachOp mop args -> genMachOp mop args - -genMachOp :: MachOp -> [CmmExpr] -> SDoc -genMachOp mop args - | Just doc <- infixMachOp mop = case args of - -- dyadic - [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y - - -- unary - [x] -> doc <> pprExpr9 x - - _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args" - (pprMachOp mop <+> - parens (hcat $ punctuate comma (map pprExpr args))) - empty - - | isJust (infixMachOp1 mop) - || isJust (infixMachOp7 mop) - || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args)) - - | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args)) - where ppr_op = text (map (\c -> if c == ' ' then '_' else c) - (show mop)) - -- replace spaces in (show mop) with underscores, - --- --- Unsigned ops on the word size of the machine get nice symbols. --- All else get dumped in their ugly format. --- -infixMachOp :: MachOp -> Maybe SDoc -infixMachOp mop - = case mop of - MO_And _ -> Just $ char '&' - MO_Or _ -> Just $ char '|' - MO_Xor _ -> Just $ char '^' - MO_Not _ -> Just $ char '~' - MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) - _ -> Nothing - --- -------------------------------------------------------------------------- --- Literals. --- To minimise line noise we adopt the convention that if the literal --- has the natural machine word size, we do not append the type --- -pprLit :: CmmLit -> SDoc -pprLit lit = sdocWithDynFlags $ \dflags -> - case lit of - CmmInt i rep -> - hcat [ (if i < 0 then parens else id)(integer i) - , ppUnless (rep == wordWidth dflags) $ - space <> dcolon <+> ppr rep ] - - CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] - CmmVec lits -> char '<' <> commafy (map pprLit lits) <> char '>' - CmmLabel clbl -> ppr clbl - CmmLabelOff clbl i -> ppr clbl <> ppr_offset i - CmmLabelDiffOff clbl1 clbl2 i -> ppr clbl1 <> char '-' - <> ppr clbl2 <> ppr_offset i - CmmBlock id -> ppr id - CmmHighStackMark -> text "" - -pprLit1 :: CmmLit -> SDoc -pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit) -pprLit1 lit = pprLit lit - -ppr_offset :: Int -> SDoc -ppr_offset i - | i==0 = empty - | i>=0 = char '+' <> int i - | otherwise = char '-' <> int (-i) - --- -------------------------------------------------------------------------- --- Registers, whether local (temps) or global --- -pprReg :: CmmReg -> SDoc -pprReg r - = case r of - CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global - --- --- We only print the type of the local reg if it isn't wordRep --- -pprLocalReg :: LocalReg -> SDoc -pprLocalReg (LocalReg uniq rep) --- = ppr rep <> char '_' <> ppr uniq --- Temp Jan08 - = char '_' <> ppr uniq <> - (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh - then dcolon <> ptr <> ppr rep - else dcolon <> ptr <> ppr rep) - where - ptr = empty - --if isGcPtrType rep - -- then doubleQuotes (text "ptr") - -- else empty - --- Stack areas -pprArea :: Area -> SDoc -pprArea Old = text "old" -pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] - --- needs to be kept in syn with CmmExpr.hs.GlobalReg --- -pprGlobalReg :: GlobalReg -> SDoc -pprGlobalReg gr - = case gr of - VanillaReg n _ -> char 'R' <> int n --- Temp Jan08 --- VanillaReg n VNonGcPtr -> char 'R' <> int n --- VanillaReg n VGcPtr -> char 'P' <> int n - FloatReg n -> char 'F' <> int n - DoubleReg n -> char 'D' <> int n - LongReg n -> char 'L' <> int n - XmmReg n -> text "XMM" <> int n - YmmReg n -> text "YMM" <> int n - ZmmReg n -> text "ZMM" <> int n - Sp -> text "Sp" - SpLim -> text "SpLim" - Hp -> text "Hp" - HpLim -> text "HpLim" - MachSp -> text "MachSp" - UnwindReturnReg-> text "UnwindReturnReg" - CCCS -> text "CCCS" - CurrentTSO -> text "CurrentTSO" - CurrentNursery -> text "CurrentNursery" - HpAlloc -> text "HpAlloc" - EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" - GCEnter1 -> text "stg_gc_enter_1" - GCFun -> text "stg_gc_fun" - BaseReg -> text "BaseReg" - PicBaseReg -> text "PicBaseReg" - ------------------------------------------------------------------------------ - -commafy :: [SDoc] -> SDoc -commafy xs = fsep $ punctuate comma xs diff --git a/cmm/SMRep.hs b/cmm/SMRep.hs deleted file mode 100644 --- a/cmm/SMRep.hs +++ /dev/null @@ -1,574 +0,0 @@ --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --- --- Storage manager representation of closures - -{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} - -module SMRep ( - -- * Words and bytes - WordOff, ByteOff, - wordsToBytes, bytesToWordsRoundUp, - roundUpToWords, - - StgWord, fromStgWord, toStgWord, - StgHalfWord, fromStgHalfWord, toStgHalfWord, - hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS, - - -- * Closure repesentation - SMRep(..), -- CmmInfo sees the rep; no one else does - IsStatic, - ClosureTypeInfo(..), ArgDescr(..), Liveness, - ConstrDescription, - - -- ** Construction - mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep, - smallArrPtrsRep, arrWordsRep, - - -- ** Predicates - isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon, - isStackRep, - - -- ** Size-related things - heapClosureSizeW, - fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize, - arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW, - smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW, - fixedHdrSize, - - -- ** RTS closure types - rtsClosureType, rET_SMALL, rET_BIG, - aRG_GEN, aRG_GEN_BIG, - - -- ** Arrays - card, cardRoundUp, cardTableSizeB, cardTableSizeW, - - -- * Operations over [Word8] strings that don't belong here - pprWord8String, stringToWord8s - ) where - -#include "../HsVersions.h" -#include "MachDeps.h" - -import DynFlags -import Outputable -import Platform -import FastString - -import Data.Char( ord ) -import Data.Word -import Data.Bits - -{- -************************************************************************ -* * - Words and bytes -* * -************************************************************************ --} - --- | Word offset, or word count -type WordOff = Int - --- | Byte offset, or byte count -type ByteOff = Int - --- | Round up the given byte count to the next byte count that's a --- multiple of the machine's word size. -roundUpToWords :: DynFlags -> ByteOff -> ByteOff -roundUpToWords dflags n = - (n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZE dflags - 1)) - --- | Convert the given number of words to a number of bytes. --- --- This function morally has type @WordOff -> ByteOff@, but uses @Num --- a@ to allow for overloading. -wordsToBytes :: Num a => DynFlags -> a -> a -wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n -{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-} -{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-} -{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-} - --- | First round the given byte count up to a multiple of the --- machine's word size and then convert the result to words. -bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff -bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size - where word_size = wORD_SIZE dflags --- StgWord is a type representing an StgWord on the target platform. --- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform -newtype StgWord = StgWord Word64 - deriving (Eq, Bits) - -fromStgWord :: StgWord -> Integer -fromStgWord (StgWord i) = toInteger i - -toStgWord :: DynFlags -> Integer -> StgWord -toStgWord dflags i - = case platformWordSize (targetPlatform dflags) of - -- These conversions mean that things like toStgWord (-1) - -- do the right thing - 4 -> StgWord (fromIntegral (fromInteger i :: Word32)) - 8 -> StgWord (fromInteger i :: Word64) - w -> panic ("toStgWord: Unknown platformWordSize: " ++ show w) - -instance Outputable StgWord where - ppr (StgWord i) = integer (toInteger i) - --- - --- A Word32 is large enough to hold half a Word for either a 32bit or --- 64bit platform -newtype StgHalfWord = StgHalfWord Word32 - deriving Eq - -fromStgHalfWord :: StgHalfWord -> Integer -fromStgHalfWord (StgHalfWord w) = toInteger w - -toStgHalfWord :: DynFlags -> Integer -> StgHalfWord -toStgHalfWord dflags i - = case platformWordSize (targetPlatform dflags) of - -- These conversions mean that things like toStgHalfWord (-1) - -- do the right thing - 4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16)) - 8 -> StgHalfWord (fromInteger i :: Word32) - w -> panic ("toStgHalfWord: Unknown platformWordSize: " ++ show w) - -instance Outputable StgHalfWord where - ppr (StgHalfWord w) = integer (toInteger w) - -hALF_WORD_SIZE :: DynFlags -> ByteOff -hALF_WORD_SIZE dflags = platformWordSize (targetPlatform dflags) `shiftR` 1 -hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int -hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2 - -{- -************************************************************************ -* * -\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation} -* * -************************************************************************ --} - --- | A description of the layout of a closure. Corresponds directly --- to the closure types in includes/rts/storage/ClosureTypes.h. -data SMRep - = HeapRep -- GC routines consult sizes in info tbl - IsStatic - !WordOff -- # ptr words - !WordOff -- # non-ptr words INCLUDING SLOP (see mkHeapRep below) - ClosureTypeInfo -- type-specific info - - | ArrayPtrsRep - !WordOff -- # ptr words - !WordOff -- # card table words - - | SmallArrayPtrsRep - !WordOff -- # ptr words - - | ArrayWordsRep - !WordOff -- # bytes expressed in words, rounded up - - | StackRep -- Stack frame (RET_SMALL or RET_BIG) - Liveness - - | RTSRep -- The RTS needs to declare info tables with specific - Int -- type tags, so this form lets us override the default - SMRep -- tag for an SMRep. - --- | True <=> This is a static closure. Affects how we garbage-collect it. --- Static closure have an extra static link field at the end. --- Constructors do not have a static variant; see Note [static constructors] -type IsStatic = Bool - --- From an SMRep you can get to the closure type defined in --- includes/rts/storage/ClosureTypes.h. Described by the function --- rtsClosureType below. - -data ClosureTypeInfo - = Constr ConstrTag ConstrDescription - | Fun FunArity ArgDescr - | Thunk - | ThunkSelector SelectorOffset - | BlackHole - | IndStatic - -type ConstrTag = Int -type ConstrDescription = [Word8] -- result of dataConIdentity -type FunArity = Int -type SelectorOffset = Int - -------------------------- --- We represent liveness bitmaps as a Bitmap (whose internal --- representation really is a bitmap). These are pinned onto case return --- vectors to indicate the state of the stack for the garbage collector. --- --- In the compiled program, liveness bitmaps that fit inside a single --- word (StgWord) are stored as a single word, while larger bitmaps are --- stored as a pointer to an array of words. - -type Liveness = [Bool] -- One Bool per word; True <=> non-ptr or dead - -- False <=> ptr - -------------------------- --- An ArgDescr describes the argument pattern of a function - -data ArgDescr - = ArgSpec -- Fits one of the standard patterns - !Int -- RTS type identifier ARG_P, ARG_N, ... - - | ArgGen -- General case - Liveness -- Details about the arguments - - ------------------------------------------------------------------------------ --- Construction - -mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo - -> SMRep -mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info - = HeapRep is_static - ptr_wds - (nonptr_wds + slop_wds) - cl_type_info - where - slop_wds - | is_static = 0 - | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size)) - - hdr_size = closureTypeHdrSize dflags cl_type_info - payload_size = ptr_wds + nonptr_wds - -mkRTSRep :: Int -> SMRep -> SMRep -mkRTSRep = RTSRep - -mkStackRep :: [Bool] -> SMRep -mkStackRep liveness = StackRep liveness - -blackHoleRep :: SMRep -blackHoleRep = HeapRep False 0 0 BlackHole - -indStaticRep :: SMRep -indStaticRep = HeapRep True 1 0 IndStatic - -arrPtrsRep :: DynFlags -> WordOff -> SMRep -arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems) - -smallArrPtrsRep :: WordOff -> SMRep -smallArrPtrsRep elems = SmallArrayPtrsRep elems - -arrWordsRep :: DynFlags -> ByteOff -> SMRep -arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes) - ------------------------------------------------------------------------------ --- Predicates - -isStaticRep :: SMRep -> IsStatic -isStaticRep (HeapRep is_static _ _ _) = is_static -isStaticRep (RTSRep _ rep) = isStaticRep rep -isStaticRep _ = False - -isStackRep :: SMRep -> Bool -isStackRep StackRep{} = True -isStackRep (RTSRep _ rep) = isStackRep rep -isStackRep _ = False - -isConRep :: SMRep -> Bool -isConRep (HeapRep _ _ _ Constr{}) = True -isConRep _ = False - -isThunkRep :: SMRep -> Bool -isThunkRep (HeapRep _ _ _ Thunk{}) = True -isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True -isThunkRep (HeapRep _ _ _ BlackHole{}) = True -isThunkRep (HeapRep _ _ _ IndStatic{}) = True -isThunkRep _ = False - -isFunRep :: SMRep -> Bool -isFunRep (HeapRep _ _ _ Fun{}) = True -isFunRep _ = False - -isStaticNoCafCon :: SMRep -> Bool --- This should line up exactly with CONSTR_NOCAF below --- See Note [Static NoCaf constructors] -isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True -isStaticNoCafCon _ = False - - ------------------------------------------------------------------------------ --- Size-related things - -fixedHdrSize :: DynFlags -> ByteOff -fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags) - --- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h) -fixedHdrSizeW :: DynFlags -> WordOff -fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags - --- | Size of the profiling part of a closure header --- (StgProfHeader in includes/rts/storage/Closures.h) -profHdrSize :: DynFlags -> WordOff -profHdrSize dflags - | gopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags - | otherwise = 0 - --- | The garbage collector requires that every closure is at least as --- big as this. -minClosureSize :: DynFlags -> WordOff -minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags - -arrWordsHdrSize :: DynFlags -> ByteOff -arrWordsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags - -arrWordsHdrSizeW :: DynFlags -> WordOff -arrWordsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags) - -arrPtrsHdrSize :: DynFlags -> ByteOff -arrPtrsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags - -arrPtrsHdrSizeW :: DynFlags -> WordOff -arrPtrsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) - -smallArrPtrsHdrSize :: DynFlags -> ByteOff -smallArrPtrsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags - -smallArrPtrsHdrSizeW :: DynFlags -> WordOff -smallArrPtrsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) - --- Thunks have an extra header word on SMP, so the update doesn't --- splat the payload. -thunkHdrSize :: DynFlags -> WordOff -thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr - where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags - -hdrSize :: DynFlags -> SMRep -> ByteOff -hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep) - -hdrSizeW :: DynFlags -> SMRep -> WordOff -hdrSizeW dflags (HeapRep _ _ _ ty) = closureTypeHdrSize dflags ty -hdrSizeW dflags (ArrayPtrsRep _ _) = arrPtrsHdrSizeW dflags -hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags -hdrSizeW dflags (ArrayWordsRep _) = arrWordsHdrSizeW dflags -hdrSizeW _ _ = panic "SMRep.hdrSizeW" - -nonHdrSize :: DynFlags -> SMRep -> ByteOff -nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep) - -nonHdrSizeW :: SMRep -> WordOff -nonHdrSizeW (HeapRep _ p np _) = p + np -nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct -nonHdrSizeW (SmallArrayPtrsRep elems) = elems -nonHdrSizeW (ArrayWordsRep words) = words -nonHdrSizeW (StackRep bs) = length bs -nonHdrSizeW (RTSRep _ rep) = nonHdrSizeW rep - --- | The total size of the closure, in words. -heapClosureSizeW :: DynFlags -> SMRep -> WordOff -heapClosureSizeW dflags (HeapRep _ p np ty) - = closureTypeHdrSize dflags ty + p + np -heapClosureSizeW dflags (ArrayPtrsRep elems ct) - = arrPtrsHdrSizeW dflags + elems + ct -heapClosureSizeW dflags (SmallArrayPtrsRep elems) - = smallArrPtrsHdrSizeW dflags + elems -heapClosureSizeW dflags (ArrayWordsRep words) - = arrWordsHdrSizeW dflags + words -heapClosureSizeW _ _ = panic "SMRep.heapClosureSize" - -closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff -closureTypeHdrSize dflags ty = case ty of - Thunk{} -> thunkHdrSize dflags - ThunkSelector{} -> thunkHdrSize dflags - BlackHole{} -> thunkHdrSize dflags - IndStatic{} -> thunkHdrSize dflags - _ -> fixedHdrSizeW dflags - -- All thunks use thunkHdrSize, even if they are non-updatable. - -- this is because we don't have separate closure types for - -- updatable vs. non-updatable thunks, so the GC can't tell the - -- difference. If we ever have significant numbers of non- - -- updatable thunks, it might be worth fixing this. - --- --------------------------------------------------------------------------- --- Arrays - --- | The byte offset into the card table of the card for a given element -card :: DynFlags -> Int -> Int -card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags - --- | Convert a number of elements to a number of cards, rounding up -cardRoundUp :: DynFlags -> Int -> Int -cardRoundUp dflags i = - card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1)) - --- | The size of a card table, in bytes -cardTableSizeB :: DynFlags -> Int -> ByteOff -cardTableSizeB dflags elems = cardRoundUp dflags elems - --- | The size of a card table, in words -cardTableSizeW :: DynFlags -> Int -> WordOff -cardTableSizeW dflags elems = - bytesToWordsRoundUp dflags (cardTableSizeB dflags elems) - ------------------------------------------------------------------------------ --- deriving the RTS closure type from an SMRep - -#include "rts/storage/ClosureTypes.h" -#include "rts/storage/FunTypes.h" --- Defines CONSTR, CONSTR_1_0 etc - --- | Derives the RTS closure type from an 'SMRep' -rtsClosureType :: SMRep -> Int -rtsClosureType rep - = case rep of - RTSRep ty _ -> ty - - -- See Note [static constructors] - HeapRep _ 1 0 Constr{} -> CONSTR_1_0 - HeapRep _ 0 1 Constr{} -> CONSTR_0_1 - HeapRep _ 2 0 Constr{} -> CONSTR_2_0 - HeapRep _ 1 1 Constr{} -> CONSTR_1_1 - HeapRep _ 0 2 Constr{} -> CONSTR_0_2 - HeapRep _ 0 _ Constr{} -> CONSTR_NOCAF - -- See Note [Static NoCaf constructors] - HeapRep _ _ _ Constr{} -> CONSTR - - HeapRep False 1 0 Fun{} -> FUN_1_0 - HeapRep False 0 1 Fun{} -> FUN_0_1 - HeapRep False 2 0 Fun{} -> FUN_2_0 - HeapRep False 1 1 Fun{} -> FUN_1_1 - HeapRep False 0 2 Fun{} -> FUN_0_2 - HeapRep False _ _ Fun{} -> FUN - - HeapRep False 1 0 Thunk{} -> THUNK_1_0 - HeapRep False 0 1 Thunk{} -> THUNK_0_1 - HeapRep False 2 0 Thunk{} -> THUNK_2_0 - HeapRep False 1 1 Thunk{} -> THUNK_1_1 - HeapRep False 0 2 Thunk{} -> THUNK_0_2 - HeapRep False _ _ Thunk{} -> THUNK - - HeapRep False _ _ ThunkSelector{} -> THUNK_SELECTOR - - HeapRep True _ _ Fun{} -> FUN_STATIC - HeapRep True _ _ Thunk{} -> THUNK_STATIC - - HeapRep False _ _ BlackHole{} -> BLACKHOLE - - HeapRep False _ _ IndStatic{} -> IND_STATIC - - _ -> panic "rtsClosureType" - --- We export these ones -rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int -rET_SMALL = RET_SMALL -rET_BIG = RET_BIG -aRG_GEN = ARG_GEN -aRG_GEN_BIG = ARG_GEN_BIG - -{- -Note [static constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We used to have a CONSTR_STATIC closure type, and each constructor had -two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with -CONSTR_STATIC. - -This distinction was removed, because when copying a data structure -into a compact region, we must copy static constructors into the -compact region too. If we didn't do this, we would need to track the -references from the compact region out to the static constructors, -because they might (indirectly) refer to CAFs. - -Since static constructors will be copied to the heap, if we wanted to -use different info tables for static and dynamic constructors, we -would have to switch the info pointer when copying the constructor -into the compact region, which means we would need an extra field of -the static info table to point to the dynamic one. - -However, since the distinction between static and dynamic closure -types is never actually needed (other than for assertions), we can -just drop the distinction and use the same info table for both. - -The GC *does* need to distinguish between static and dynamic closures, -but it does this using the HEAP_ALLOCED() macro which checks whether -the address of the closure resides within the dynamic heap. -HEAP_ALLOCED() doesn't read the closure's info table. - -Note [Static NoCaf constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we know that a top-level binding 'x' is not Caffy (ie no CAFs are -reachable from 'x'), then a statically allocated constructor (Just x) -is also not Caffy, and the garbage collector need not follow its -argument fields. Exploiting this would require two static info tables -for Just, for the two cases where the argument was Caffy or non-Caffy. - -Currently we don't do this; instead we treat nullary constructors -as non-Caffy, and the others as potentially Caffy. - - -************************************************************************ -* * - Pretty printing of SMRep and friends -* * -************************************************************************ --} - -instance Outputable ClosureTypeInfo where - ppr = pprTypeInfo - -instance Outputable SMRep where - ppr (HeapRep static ps nps tyinfo) - = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace) - where - header = text "HeapRep" - <+> if static then text "static" else empty - <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps - pp_n :: String -> Int -> SDoc - pp_n _ 0 = empty - pp_n s n = int n <+> text s - - ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size - - ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size - - ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words - - ppr (StackRep bs) = text "StackRep" <+> ppr bs - - ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep - -instance Outputable ArgDescr where - ppr (ArgSpec n) = text "ArgSpec" <+> ppr n - ppr (ArgGen ls) = text "ArgGen" <+> ppr ls - -pprTypeInfo :: ClosureTypeInfo -> SDoc -pprTypeInfo (Constr tag descr) - = text "Con" <+> - braces (sep [ text "tag:" <+> ppr tag - , text "descr:" <> text (show descr) ]) - -pprTypeInfo (Fun arity args) - = text "Fun" <+> - braces (sep [ text "arity:" <+> ppr arity - , ptext (sLit ("fun_type:")) <+> ppr args ]) - -pprTypeInfo (ThunkSelector offset) - = text "ThunkSel" <+> ppr offset - -pprTypeInfo Thunk = text "Thunk" -pprTypeInfo BlackHole = text "BlackHole" -pprTypeInfo IndStatic = text "IndStatic" - --- XXX Does not belong here!! -stringToWord8s :: String -> [Word8] -stringToWord8s s = map (fromIntegral . ord) s - -pprWord8String :: [Word8] -> SDoc --- Debug printing. Not very clever right now. -pprWord8String ws = text (show ws) diff --git a/codeGen/CgUtils.hs b/codeGen/CgUtils.hs deleted file mode 100644 --- a/codeGen/CgUtils.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE CPP, GADTs #-} - ------------------------------------------------------------------------------ --- --- Code generator utilities; mostly monadic --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module CgUtils ( fixStgRegisters ) where - -#include "HsVersions.h" - -import CodeGen.Platform -import Cmm -import Hoopl -import CmmUtils -import CLabel -import DynFlags -import Outputable - --- ----------------------------------------------------------------------------- --- Information about global registers - -baseRegOffset :: DynFlags -> GlobalReg -> Int - -baseRegOffset dflags (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 dflags -baseRegOffset dflags (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 dflags -baseRegOffset dflags (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 dflags -baseRegOffset dflags (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 dflags -baseRegOffset dflags (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 dflags -baseRegOffset dflags (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 dflags -baseRegOffset dflags (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 dflags -baseRegOffset dflags (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 dflags -baseRegOffset dflags (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 dflags -baseRegOffset dflags (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 dflags -baseRegOffset _ (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") -baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags -baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags -baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags -baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags -baseRegOffset dflags (FloatReg 5) = oFFSET_StgRegTable_rF5 dflags -baseRegOffset dflags (FloatReg 6) = oFFSET_StgRegTable_rF6 dflags -baseRegOffset _ (FloatReg n) = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")") -baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags -baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags -baseRegOffset dflags (DoubleReg 3) = oFFSET_StgRegTable_rD3 dflags -baseRegOffset dflags (DoubleReg 4) = oFFSET_StgRegTable_rD4 dflags -baseRegOffset dflags (DoubleReg 5) = oFFSET_StgRegTable_rD5 dflags -baseRegOffset dflags (DoubleReg 6) = oFFSET_StgRegTable_rD6 dflags -baseRegOffset _ (DoubleReg n) = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")") -baseRegOffset dflags (XmmReg 1) = oFFSET_StgRegTable_rXMM1 dflags -baseRegOffset dflags (XmmReg 2) = oFFSET_StgRegTable_rXMM2 dflags -baseRegOffset dflags (XmmReg 3) = oFFSET_StgRegTable_rXMM3 dflags -baseRegOffset dflags (XmmReg 4) = oFFSET_StgRegTable_rXMM4 dflags -baseRegOffset dflags (XmmReg 5) = oFFSET_StgRegTable_rXMM5 dflags -baseRegOffset dflags (XmmReg 6) = oFFSET_StgRegTable_rXMM6 dflags -baseRegOffset _ (XmmReg n) = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")") -baseRegOffset dflags (YmmReg 1) = oFFSET_StgRegTable_rYMM1 dflags -baseRegOffset dflags (YmmReg 2) = oFFSET_StgRegTable_rYMM2 dflags -baseRegOffset dflags (YmmReg 3) = oFFSET_StgRegTable_rYMM3 dflags -baseRegOffset dflags (YmmReg 4) = oFFSET_StgRegTable_rYMM4 dflags -baseRegOffset dflags (YmmReg 5) = oFFSET_StgRegTable_rYMM5 dflags -baseRegOffset dflags (YmmReg 6) = oFFSET_StgRegTable_rYMM6 dflags -baseRegOffset _ (YmmReg n) = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")") -baseRegOffset dflags (ZmmReg 1) = oFFSET_StgRegTable_rZMM1 dflags -baseRegOffset dflags (ZmmReg 2) = oFFSET_StgRegTable_rZMM2 dflags -baseRegOffset dflags (ZmmReg 3) = oFFSET_StgRegTable_rZMM3 dflags -baseRegOffset dflags (ZmmReg 4) = oFFSET_StgRegTable_rZMM4 dflags -baseRegOffset dflags (ZmmReg 5) = oFFSET_StgRegTable_rZMM5 dflags -baseRegOffset dflags (ZmmReg 6) = oFFSET_StgRegTable_rZMM6 dflags -baseRegOffset _ (ZmmReg n) = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")") -baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags -baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags -baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags -baseRegOffset _ (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") -baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags -baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags -baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags -baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags -baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags -baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags -baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags -baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags -baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags -baseRegOffset _ BaseReg = panic "CgUtils.baseRegOffset:BaseReg" -baseRegOffset _ PicBaseReg = panic "CgUtils.baseRegOffset:PicBaseReg" -baseRegOffset _ MachSp = panic "CgUtils.baseRegOffset:MachSp" -baseRegOffset _ UnwindReturnReg = panic "CgUtils.baseRegOffset:UnwindReturnReg" - - --- ----------------------------------------------------------------------------- --- --- STG/Cmm GlobalReg --- --- ----------------------------------------------------------------------------- - --- | We map STG registers onto appropriate CmmExprs. Either they map --- to real machine registers or stored as offsets from BaseReg. Given --- a GlobalReg, get_GlobalReg_addr always produces the --- register table address for it. -get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr -get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0 -get_GlobalReg_addr dflags mid - = get_Regtable_addr_from_offset dflags - (globalRegType dflags mid) (baseRegOffset dflags mid) - --- Calculate a literal representing an offset into the register table. --- Used when we don't have an actual BaseReg to offset from. -regTableOffset :: DynFlags -> Int -> CmmExpr -regTableOffset dflags n = - CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n)) - -get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr -get_Regtable_addr_from_offset dflags _ offset = - if haveRegBase (targetPlatform dflags) - then CmmRegOff (CmmGlobal BaseReg) offset - else regTableOffset dflags offset - --- | Fixup global registers so that they assign to locations within the --- RegTable if they aren't pinned for the current target. -fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl -fixStgRegisters _ top@(CmmData _ _) = top - -fixStgRegisters dflags (CmmProc info lbl live graph) = - let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph - in CmmProc info lbl live graph' - -fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x -fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block - -fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x -fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt - where - platform = targetPlatform dflags - - fixAssign stmt = - case stmt of - CmmAssign (CmmGlobal reg) src - -- MachSp isn't an STG register; it's merely here for tracking unwind - -- information - | reg == MachSp -> stmt - | otherwise -> - let baseAddr = get_GlobalReg_addr dflags reg - in case reg `elem` activeStgRegs (targetPlatform dflags) of - True -> CmmAssign (CmmGlobal reg) src - False -> CmmStore baseAddr src - other_stmt -> other_stmt - - fixExpr expr = case expr of - -- MachSp isn't an STG; it's merely here for tracking unwind information - CmmReg (CmmGlobal MachSp) -> expr - CmmReg (CmmGlobal reg) -> - -- Replace register leaves with appropriate StixTrees for - -- the given target. MagicIds which map to a reg on this - -- arch are left unchanged. For the rest, BaseReg is taken - -- to mean the address of the reg table in MainCapability, - -- and for all others we generate an indirection to its - -- location in the register table. - case reg `elem` activeStgRegs platform of - True -> expr - False -> - let baseAddr = get_GlobalReg_addr dflags reg - in case reg of - BaseReg -> baseAddr - _other -> CmmLoad baseAddr (globalRegType dflags reg) - - CmmRegOff (CmmGlobal reg) offset -> - -- RegOf leaves are just a shorthand form. If the reg maps - -- to a real reg, we keep the shorthand, otherwise, we just - -- expand it and defer to the above code. - case reg `elem` activeStgRegs platform of - True -> expr - False -> CmmMachOp (MO_Add (wordWidth dflags)) [ - fixExpr (CmmReg (CmmGlobal reg)), - CmmLit (CmmInt (fromIntegral offset) - (wordWidth dflags))] - - other_expr -> other_expr - diff --git a/codeGen/CodeGen/Platform.hs b/codeGen/CodeGen/Platform.hs deleted file mode 100644 --- a/codeGen/CodeGen/Platform.hs +++ /dev/null @@ -1,116 +0,0 @@ - -module CodeGen.Platform - (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg) - where - -import CmmExpr -import Platform -import Reg - -import qualified CodeGen.Platform.ARM as ARM -import qualified CodeGen.Platform.ARM64 as ARM64 -import qualified CodeGen.Platform.PPC as PPC -import qualified CodeGen.Platform.PPC_Darwin as PPC_Darwin -import qualified CodeGen.Platform.SPARC as SPARC -import qualified CodeGen.Platform.X86 as X86 -import qualified CodeGen.Platform.X86_64 as X86_64 -import qualified CodeGen.Platform.NoRegs as NoRegs - --- | Returns 'True' if this global register is stored in a caller-saves --- machine register. - -callerSaves :: Platform -> GlobalReg -> Bool -callerSaves platform - | platformUnregisterised platform = NoRegs.callerSaves - | otherwise - = case platformArch platform of - ArchX86 -> X86.callerSaves - ArchX86_64 -> X86_64.callerSaves - ArchSPARC -> SPARC.callerSaves - ArchARM {} -> ARM.callerSaves - ArchARM64 -> ARM64.callerSaves - arch - | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> - case platformOS platform of - OSDarwin -> PPC_Darwin.callerSaves - _ -> PPC.callerSaves - - | otherwise -> NoRegs.callerSaves - --- | Here is where the STG register map is defined for each target arch. --- The order matters (for the llvm backend anyway)! We must make sure to --- maintain the order here with the order used in the LLVM calling conventions. --- Note that also, this isn't all registers, just the ones that are currently --- possbily mapped to real registers. -activeStgRegs :: Platform -> [GlobalReg] -activeStgRegs platform - | platformUnregisterised platform = NoRegs.activeStgRegs - | otherwise - = case platformArch platform of - ArchX86 -> X86.activeStgRegs - ArchX86_64 -> X86_64.activeStgRegs - ArchSPARC -> SPARC.activeStgRegs - ArchARM {} -> ARM.activeStgRegs - ArchARM64 -> ARM64.activeStgRegs - arch - | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> - case platformOS platform of - OSDarwin -> PPC_Darwin.activeStgRegs - _ -> PPC.activeStgRegs - - | otherwise -> NoRegs.activeStgRegs - -haveRegBase :: Platform -> Bool -haveRegBase platform - | platformUnregisterised platform = NoRegs.haveRegBase - | otherwise - = case platformArch platform of - ArchX86 -> X86.haveRegBase - ArchX86_64 -> X86_64.haveRegBase - ArchSPARC -> SPARC.haveRegBase - ArchARM {} -> ARM.haveRegBase - ArchARM64 -> ARM64.haveRegBase - arch - | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> - case platformOS platform of - OSDarwin -> PPC_Darwin.haveRegBase - _ -> PPC.haveRegBase - - | otherwise -> NoRegs.haveRegBase - -globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg -globalRegMaybe platform - | platformUnregisterised platform = NoRegs.globalRegMaybe - | otherwise - = case platformArch platform of - ArchX86 -> X86.globalRegMaybe - ArchX86_64 -> X86_64.globalRegMaybe - ArchSPARC -> SPARC.globalRegMaybe - ArchARM {} -> ARM.globalRegMaybe - ArchARM64 -> ARM64.globalRegMaybe - arch - | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> - case platformOS platform of - OSDarwin -> PPC_Darwin.globalRegMaybe - _ -> PPC.globalRegMaybe - - | otherwise -> NoRegs.globalRegMaybe - -freeReg :: Platform -> RegNo -> Bool -freeReg platform - | platformUnregisterised platform = NoRegs.freeReg - | otherwise - = case platformArch platform of - ArchX86 -> X86.freeReg - ArchX86_64 -> X86_64.freeReg - ArchSPARC -> SPARC.freeReg - ArchARM {} -> ARM.freeReg - ArchARM64 -> ARM64.freeReg - arch - | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> - case platformOS platform of - OSDarwin -> PPC_Darwin.freeReg - _ -> PPC.freeReg - - | otherwise -> NoRegs.freeReg - diff --git a/codeGen/CodeGen/Platform/ARM.hs b/codeGen/CodeGen/Platform/ARM.hs deleted file mode 100644 --- a/codeGen/CodeGen/Platform/ARM.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} - -module CodeGen.Platform.ARM where - -#define MACHREGS_NO_REGS 0 -#define MACHREGS_arm 1 -#include "CodeGen.Platform.hs" - diff --git a/codeGen/CodeGen/Platform/ARM64.hs b/codeGen/CodeGen/Platform/ARM64.hs deleted file mode 100644 --- a/codeGen/CodeGen/Platform/ARM64.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} - -module CodeGen.Platform.ARM64 where - -#define MACHREGS_NO_REGS 0 -#define MACHREGS_aarch64 1 -#include "CodeGen.Platform.hs" - diff --git a/codeGen/CodeGen/Platform/NoRegs.hs b/codeGen/CodeGen/Platform/NoRegs.hs deleted file mode 100644 --- a/codeGen/CodeGen/Platform/NoRegs.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE CPP #-} - -module CodeGen.Platform.NoRegs where - -#define MACHREGS_NO_REGS 1 -#include "CodeGen.Platform.hs" - diff --git a/codeGen/CodeGen/Platform/PPC.hs b/codeGen/CodeGen/Platform/PPC.hs deleted file mode 100644 --- a/codeGen/CodeGen/Platform/PPC.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} - -module CodeGen.Platform.PPC where - -#define MACHREGS_NO_REGS 0 -#define MACHREGS_powerpc 1 -#include "CodeGen.Platform.hs" - diff --git a/codeGen/CodeGen/Platform/PPC_Darwin.hs b/codeGen/CodeGen/Platform/PPC_Darwin.hs deleted file mode 100644 --- a/codeGen/CodeGen/Platform/PPC_Darwin.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE CPP #-} - -module CodeGen.Platform.PPC_Darwin where - -#define MACHREGS_NO_REGS 0 -#define MACHREGS_powerpc 1 -#define MACHREGS_darwin 1 -#include "CodeGen.Platform.hs" - diff --git a/codeGen/CodeGen/Platform/SPARC.hs b/codeGen/CodeGen/Platform/SPARC.hs deleted file mode 100644 --- a/codeGen/CodeGen/Platform/SPARC.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} - -module CodeGen.Platform.SPARC where - -#define MACHREGS_NO_REGS 0 -#define MACHREGS_sparc 1 -#include "CodeGen.Platform.hs" - diff --git a/codeGen/CodeGen/Platform/X86.hs b/codeGen/CodeGen/Platform/X86.hs deleted file mode 100644 --- a/codeGen/CodeGen/Platform/X86.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} - -module CodeGen.Platform.X86 where - -#define MACHREGS_NO_REGS 0 -#define MACHREGS_i386 1 -#include "CodeGen.Platform.hs" - diff --git a/codeGen/CodeGen/Platform/X86_64.hs b/codeGen/CodeGen/Platform/X86_64.hs deleted file mode 100644 --- a/codeGen/CodeGen/Platform/X86_64.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} - -module CodeGen.Platform.X86_64 where - -#define MACHREGS_NO_REGS 0 -#define MACHREGS_x86_64 1 -#include "CodeGen.Platform.hs" - diff --git a/codeGen/StgCmm.hs b/codeGen/StgCmm.hs deleted file mode 100644 --- a/codeGen/StgCmm.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Stg to C-- code generation --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module StgCmm ( codeGen ) where - -#include "HsVersions.h" - -import StgCmmProf (initCostCentres, ldvEnter) -import StgCmmMonad -import StgCmmEnv -import StgCmmBind -import StgCmmCon -import StgCmmLayout -import StgCmmUtils -import StgCmmClosure -import StgCmmHpc -import StgCmmTicky - -import Cmm -import CmmUtils -import CLabel - -import StgSyn -import DynFlags - -import HscTypes -import CostCentre -import Id -import IdInfo -import RepType -import DataCon -import Name -import TyCon -import Module -import Outputable -import Stream -import BasicTypes - -import OrdList -import MkGraph - -import qualified Data.ByteString as BS -import Data.IORef -import Control.Monad (when,void) -import Util - -codeGen :: DynFlags - -> Module - -> [TyCon] - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [StgTopBinding] -- Bindings to convert - -> HpcInfo - -> Stream IO CmmGroup () -- Output as a stream, so codegen can - -- be interleaved with output - -codeGen dflags this_mod data_tycons - cost_centre_info stg_binds hpc_info - = do { -- cg: run the code generator, and yield the resulting CmmGroup - -- Using an IORef to store the state is a bit crude, but otherwise - -- we would need to add a state monad layer. - ; cgref <- liftIO $ newIORef =<< initC - ; let cg :: FCode () -> Stream IO CmmGroup () - cg fcode = do - cmm <- liftIO $ do - st <- readIORef cgref - let (a,st') = runC dflags this_mod st (getCmm fcode) - - -- NB. stub-out cgs_tops and cgs_stmts. This fixes - -- a big space leak. DO NOT REMOVE! - writeIORef cgref $! st'{ cgs_tops = nilOL, - cgs_stmts = mkNop } - return a - yield cmm - - -- Note [codegen-split-init] the cmm_init block must come - -- FIRST. This is because when -split-objs is on we need to - -- combine this block with its initialisation routines; see - -- Note [pipeline-split-init]. - ; cg (mkModuleInit cost_centre_info this_mod hpc_info) - - ; mapM_ (cg . cgTopBinding dflags) stg_binds - - -- Put datatype_stuff after code_stuff, because the - -- datatype closure table (for enumeration types) to - -- (say) PrelBase_True_closure, which is defined in - -- code_stuff - ; let do_tycon tycon = do - -- Generate a table of static closures for an - -- enumeration type Note that the closure pointers are - -- tagged. - when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon) - mapM_ (cg . cgDataCon) (tyConDataCons tycon) - - ; mapM_ do_tycon data_tycons - } - ---------------------------------------------------------------- --- Top-level bindings ---------------------------------------------------------------- - -{- 'cgTopBinding' is only used for top-level bindings, since they need -to be allocated statically (not in the heap) and need to be labelled. -No unboxed bindings can happen at top level. - -In the code below, the static bindings are accumulated in the -@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@. -This is so that we can write the top level processing in a compositional -style, with the increasing static environment being plumbed as a state -variable. -} - -cgTopBinding :: DynFlags -> StgTopBinding -> FCode () -cgTopBinding dflags (StgTopLifted (StgNonRec id rhs)) - = do { id' <- maybeExternaliseId dflags id - ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs - ; fcode - ; addBindC info -- Add the *un-externalised* Id to the envt, - -- so we find it when we look up occurrences - } - -cgTopBinding dflags (StgTopLifted (StgRec pairs)) - = do { let (bndrs, rhss) = unzip pairs - ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs - ; let pairs' = zip bndrs' rhss - r = unzipWith (cgTopRhs dflags Recursive) pairs' - (infos, fcodes) = unzip r - ; addBindsC infos - ; sequence_ fcodes - } - -cgTopBinding dflags (StgTopStringLit id str) - = do { id' <- maybeExternaliseId dflags id - ; let label = mkBytesLabel (idName id') - ; let (lit, decl) = mkByteStringCLit label (BS.unpack str) - ; emitDecl decl - ; addBindC (litIdInfo dflags id' mkLFStringLit lit) - } - -cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ()) - -- The Id is passed along for setting up a binding... - -- It's already been externalised if necessary - -cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) - = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args) - -- con args are always non-void, - -- see Note [Post-unarisation invariants] in UnariseStg - -cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag args body) - = ASSERT(null fvs) -- There should be no free variables - cgTopRhsClosure dflags rec bndr cc bi upd_flag args body - - ---------------------------------------------------------------- --- Module initialisation code ---------------------------------------------------------------- - -{- The module initialisation code looks like this, roughly: - - FN(__stginit_Foo) { - JMP_(__stginit_Foo_1_p) - } - - FN(__stginit_Foo_1_p) { - ... - } - - We have one version of the init code with a module version and the - 'way' attached to it. The version number helps to catch cases - where modules are not compiled in dependency order before being - linked: if a module has been compiled since any modules which depend on - it, then the latter modules will refer to a different version in their - init blocks and a link error will ensue. - - The 'way' suffix helps to catch cases where modules compiled in different - ways are linked together (eg. profiled and non-profiled). - - We provide a plain, unadorned, version of the module init code - which just jumps to the version with the label and way attached. The - reason for this is that when using foreign exports, the caller of - startupHaskell() must supply the name of the init function for the "top" - module in the program, and we don't want to require that this name - has the version and way info appended to it. - -We initialise the module tree by keeping a work-stack, - * pointed to by Sp - * that grows downward - * Sp points to the last occupied slot --} - -mkModuleInit - :: CollectedCCs -- cost centre info - -> Module - -> HpcInfo - -> FCode () - -mkModuleInit cost_centre_info this_mod hpc_info - = do { initHpc this_mod hpc_info - ; initCostCentres cost_centre_info - -- For backwards compatibility: user code may refer to this - -- label for calling hs_add_root(). - ; let lbl = mkPlainModuleInitLabel this_mod - ; emitDecl (CmmData (Section Data lbl) (Statics lbl [])) - } - - ---------------------------------------------------------------- --- Generating static stuff for algebraic data types ---------------------------------------------------------------- - - -cgEnumerationTyCon :: TyCon -> FCode () -cgEnumerationTyCon tycon - = do dflags <- getDynFlags - emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) - [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) - (tagForCon dflags con) - | con <- tyConDataCons tycon] - - -cgDataCon :: DataCon -> FCode () --- Generate the entry code, info tables, and (for niladic constructor) --- the static closure, for a constructor. -cgDataCon data_con - = do { dflags <- getDynFlags - ; let - (tot_wds, -- #ptr_wds + #nonptr_wds - ptr_wds) -- #ptr_wds - = mkVirtConstrSizes dflags arg_reps - - nonptr_wds = tot_wds - ptr_wds - - dyn_info_tbl = - mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds - - -- We're generating info tables, so we don't know and care about - -- what the actual arguments are. Using () here as the place holder. - arg_reps :: [NonVoid PrimRep] - arg_reps = [ NonVoid rep_ty - | ty <- dataConRepArgTys data_con - , rep_ty <- typePrimRep ty - , not (isVoidRep rep_ty) ] - - ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $ - -- NB: the closure pointer is assumed *untagged* on - -- entry to a constructor. If the pointer is tagged, - -- then we should not be entering it. This assumption - -- is used in ldvEnter and when tagging the pointer to - -- return it. - -- NB 2: We don't set CC when entering data (WDP 94/06) - do { tickyEnterDynCon - ; ldvEnter (CmmReg nodeReg) - ; tickyReturnOldCon (length arg_reps) - ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)] - } - -- The case continuation code expects a tagged pointer - } - ---------------------------------------------------------------- --- Stuff to support splitting ---------------------------------------------------------------- - -maybeExternaliseId :: DynFlags -> Id -> FCode Id -maybeExternaliseId dflags id - | gopt Opt_SplitObjs dflags, -- See Note [Externalise when splitting] - -- in StgCmmMonad - isInternalName name = do { mod <- getModuleName - ; returnFC (setIdName id (externalise mod)) } - | otherwise = returnFC id - where - externalise mod = mkExternalName uniq mod new_occ loc - name = idName id - uniq = nameUnique name - new_occ = mkLocalOcc uniq (nameOccName name) - loc = nameSrcSpan name - -- We want to conjure up a name that can't clash with any - -- existing name. So we generate - -- Mod_$L243foo - -- where 243 is the unique. diff --git a/codeGen/StgCmmArgRep.hs b/codeGen/StgCmmArgRep.hs deleted file mode 100644 --- a/codeGen/StgCmmArgRep.hs +++ /dev/null @@ -1,152 +0,0 @@ ------------------------------------------------------------------------------ --- --- Argument representations used in StgCmmLayout. --- --- (c) The University of Glasgow 2013 --- ------------------------------------------------------------------------------ - -module StgCmmArgRep ( - ArgRep(..), toArgRep, argRepSizeW, - - argRepString, isNonV, idArgRep, - - slowCallPattern, - - ) where - -import StgCmmClosure ( idPrimRep ) - -import SMRep ( WordOff ) -import Id ( Id ) -import TyCon ( PrimRep(..), primElemRepSizeB ) -import BasicTypes ( RepArity ) -import Constants ( wORD64_SIZE ) -import DynFlags - -import Outputable -import FastString - --- I extricated this code as this new module in order to avoid a --- cyclic dependency between StgCmmLayout and StgCmmTicky. --- --- NSF 18 Feb 2013 - -------------------------------------------------------------------------- --- Classifying arguments: ArgRep -------------------------------------------------------------------------- - --- ArgRep is re-exported by StgCmmLayout, but only for use in the --- byte-code generator which also needs to know about the --- classification of arguments. - -data ArgRep = P -- GC Ptr - | N -- Word-sized non-ptr - | L -- 64-bit non-ptr (long) - | V -- Void - | F -- Float - | D -- Double - | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc. - | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc. - | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc. -instance Outputable ArgRep where ppr = text . argRepString - -argRepString :: ArgRep -> String -argRepString P = "P" -argRepString N = "N" -argRepString L = "L" -argRepString V = "V" -argRepString F = "F" -argRepString D = "D" -argRepString V16 = "V16" -argRepString V32 = "V32" -argRepString V64 = "V64" - -toArgRep :: PrimRep -> ArgRep -toArgRep VoidRep = V -toArgRep LiftedRep = P -toArgRep UnliftedRep = P -toArgRep IntRep = N -toArgRep WordRep = N -toArgRep AddrRep = N -toArgRep Int64Rep = L -toArgRep Word64Rep = L -toArgRep FloatRep = F -toArgRep DoubleRep = D -toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of - 16 -> V16 - 32 -> V32 - 64 -> V64 - _ -> error "toArgRep: bad vector primrep" - -isNonV :: ArgRep -> Bool -isNonV V = False -isNonV _ = True - -argRepSizeW :: DynFlags -> ArgRep -> WordOff -- Size in words -argRepSizeW _ N = 1 -argRepSizeW _ P = 1 -argRepSizeW _ F = 1 -argRepSizeW dflags L = wORD64_SIZE `quot` wORD_SIZE dflags -argRepSizeW dflags D = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags -argRepSizeW _ V = 0 -argRepSizeW dflags V16 = 16 `quot` wORD_SIZE dflags -argRepSizeW dflags V32 = 32 `quot` wORD_SIZE dflags -argRepSizeW dflags V64 = 64 `quot` wORD_SIZE dflags - -idArgRep :: Id -> ArgRep -idArgRep = toArgRep . idPrimRep - --- This list of argument patterns should be kept in sync with at least --- the following: --- --- * StgCmmLayout.stdPattern maybe to some degree? --- --- * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast) --- declarations in includes/stg/MiscClosures.h --- --- * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h, --- --- * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h, --- --- * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c, --- --- * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and --- SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c --- --- There may be more places that I haven't found; I merely igrep'd for --- pppppp and excluded things that seemed ghci-specific. --- --- Also, it seems at the moment that ticky counters with void --- arguments will never be bumped, but I'm still declaring those --- counters, defensively. --- --- NSF 6 Mar 2013 - -slowCallPattern :: [ArgRep] -> (FastString, RepArity) --- Returns the generic apply function and arity --- --- The first batch of cases match (some) specialised entries --- The last group deals exhaustively with the cases for the first argument --- (and the zero-argument case) --- --- In 99% of cases this function will match *all* the arguments in one batch - -slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6) -slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5) -slowCallPattern (P: P: P: P: _) = (fsLit "stg_ap_pppp", 4) -slowCallPattern (P: P: P: V: _) = (fsLit "stg_ap_pppv", 4) -slowCallPattern (P: P: P: _) = (fsLit "stg_ap_ppp", 3) -slowCallPattern (P: P: V: _) = (fsLit "stg_ap_ppv", 3) -slowCallPattern (P: P: _) = (fsLit "stg_ap_pp", 2) -slowCallPattern (P: V: _) = (fsLit "stg_ap_pv", 2) -slowCallPattern (P: _) = (fsLit "stg_ap_p", 1) -slowCallPattern (V: _) = (fsLit "stg_ap_v", 1) -slowCallPattern (N: _) = (fsLit "stg_ap_n", 1) -slowCallPattern (F: _) = (fsLit "stg_ap_f", 1) -slowCallPattern (D: _) = (fsLit "stg_ap_d", 1) -slowCallPattern (L: _) = (fsLit "stg_ap_l", 1) -slowCallPattern (V16: _) = (fsLit "stg_ap_v16", 1) -slowCallPattern (V32: _) = (fsLit "stg_ap_v32", 1) -slowCallPattern (V64: _) = (fsLit "stg_ap_v64", 1) -slowCallPattern [] = (fsLit "stg_ap_0", 0) diff --git a/codeGen/StgCmmBind.hs b/codeGen/StgCmmBind.hs deleted file mode 100644 --- a/codeGen/StgCmmBind.hs +++ /dev/null @@ -1,755 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Stg to C-- code generation: bindings --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module StgCmmBind ( - cgTopRhsClosure, - cgBind, - emitBlackHoleCode, - pushUpdateFrame, emitUpdateFrame - ) where - -#include "HsVersions.h" - -import StgCmmExpr -import StgCmmMonad -import StgCmmEnv -import StgCmmCon -import StgCmmHeap -import StgCmmProf (curCCS, ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk, - initUpdFrameProf) -import StgCmmTicky -import StgCmmLayout -import StgCmmUtils -import StgCmmClosure -import StgCmmForeign (emitPrimCall) - -import MkGraph -import CoreSyn ( AltCon(..), tickishIsCode ) -import BlockId -import SMRep -import Cmm -import CmmInfo -import CmmUtils -import CLabel -import StgSyn -import CostCentre -import Id -import IdInfo -import Name -import Module -import ListSetOps -import Util -import BasicTypes -import Outputable -import FastString -import DynFlags - -import Control.Monad - -import Prelude hiding ((<*>)) - ------------------------------------------------------------------------- --- Top-level bindings ------------------------------------------------------------------------- - --- For closures bound at top level, allocate in static space. --- They should have no free variables. - -cgTopRhsClosure :: DynFlags - -> RecFlag -- member of a recursive group? - -> Id - -> CostCentreStack -- Optional cost centre annotation - -> StgBinderInfo - -> UpdateFlag - -> [Id] -- Args - -> StgExpr - -> (CgIdInfo, FCode ()) - -cgTopRhsClosure dflags rec id ccs _ upd_flag args body = - let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) - cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) - lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args - in (cg_id_info, gen_code dflags lf_info closure_label) - where - -- special case for a indirection (f = g). We create an IND_STATIC - -- closure pointing directly to the indirectee. This is exactly - -- what the CAF will eventually evaluate to anyway, we're just - -- shortcutting the whole process, and generating a lot less code - -- (#7308) - -- - -- Note: we omit the optimisation when this binding is part of a - -- recursive group, because the optimisation would inhibit the black - -- hole detection from working in that case. Test - -- concurrent/should_run/4030 fails, for instance. - -- - gen_code dflags _ closure_label - | StgApp f [] <- body, null args, isNonRec rec - = do - cg_info <- getCgIdInfo f - let closure_rep = mkStaticClosureFields dflags - indStaticInfoTable ccs MayHaveCafRefs - [unLit (idInfoToAmode cg_info)] - emitDataLits closure_label closure_rep - return () - - gen_code dflags lf_info closure_label - = do { -- LAY OUT THE OBJECT - let name = idName id - ; mod_name <- getModuleName - ; let descr = closureDescription dflags mod_name name - closure_info = mkClosureInfo dflags True id lf_info 0 0 descr - - caffy = idCafInfo id - info_tbl = mkCmmInfo closure_info -- XXX short-cut - closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy [] - - -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) - ; emitDataLits closure_label closure_rep - ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] - (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) [] - -- Don't drop the non-void args until the closure info has been made - ; forkClosureBody (closureCodeBody True id closure_info ccs - (nonVoidIds args) (length args) body fv_details) - - ; return () } - - unLit (CmmLit l) = l - unLit _ = panic "unLit" - ------------------------------------------------------------------------- --- Non-top-level bindings ------------------------------------------------------------------------- - -cgBind :: StgBinding -> FCode () -cgBind (StgNonRec name rhs) - = do { (info, fcode) <- cgRhs name rhs - ; addBindC info - ; init <- fcode - ; emit init } - -- init cannot be used in body, so slightly better to sink it eagerly - -cgBind (StgRec pairs) - = do { r <- sequence $ unzipWith cgRhs pairs - ; let (id_infos, fcodes) = unzip r - ; addBindsC id_infos - ; (inits, body) <- getCodeR $ sequence fcodes - ; emit (catAGraphs inits <*> body) } - -{- Note [cgBind rec] - - Recursive let-bindings are tricky. - Consider the following pseudocode: - - let x = \_ -> ... y ... - y = \_ -> ... z ... - z = \_ -> ... x ... - in ... - - For each binding, we need to allocate a closure, and each closure must - capture the address of the other closures. - We want to generate the following C-- code: - // Initialization Code - x = hp - 24; // heap address of x's closure - y = hp - 40; // heap address of x's closure - z = hp - 64; // heap address of x's closure - // allocate and initialize x - m[hp-8] = ... - m[hp-16] = y // the closure for x captures y - m[hp-24] = x_info; - // allocate and initialize y - m[hp-32] = z; // the closure for y captures z - m[hp-40] = y_info; - // allocate and initialize z - ... - - For each closure, we must generate not only the code to allocate and - initialize the closure itself, but also some initialization Code that - sets a variable holding the closure pointer. - - We could generate a pair of the (init code, body code), but since - the bindings are recursive we also have to initialise the - environment with the CgIdInfo for all the bindings before compiling - anything. So we do this in 3 stages: - - 1. collect all the CgIdInfos and initialise the environment - 2. compile each binding into (init, body) code - 3. emit all the inits, and then all the bodies - - We'd rather not have separate functions to do steps 1 and 2 for - each binding, since in pratice they share a lot of code. So we - have just one function, cgRhs, that returns a pair of the CgIdInfo - for step 1, and a monadic computation to generate the code in step - 2. - - The alternative to separating things in this way is to use a - fixpoint. That's what we used to do, but it introduces a - maintenance nightmare because there is a subtle dependency on not - being too strict everywhere. Doing things this way means that the - FCode monad can be strict, for example. - -} - -cgRhs :: Id - -> StgRhs - -> FCode ( - CgIdInfo -- The info for this binding - , FCode CmmAGraph -- A computation which will generate the - -- code for the binding, and return an - -- assignent of the form "x = Hp - n" - -- (see above) - ) - -cgRhs id (StgRhsCon cc con args) - = withNewTickyCounterCon (idName id) $ - buildDynCon id True cc con (assertNonVoidStgArgs args) - -- con args are always non-void, - -- see Note [Post-unarisation invariants] in UnariseStg - -{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -} -cgRhs id (StgRhsClosure cc bi fvs upd_flag args body) - = do dflags <- getDynFlags - mkRhsClosure dflags id cc bi (nonVoidIds fvs) upd_flag args body - ------------------------------------------------------------------------- --- Non-constructor right hand sides ------------------------------------------------------------------------- - -mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo - -> [NonVoid Id] -- Free vars - -> UpdateFlag - -> [Id] -- Args - -> StgExpr - -> FCode (CgIdInfo, FCode CmmAGraph) - -{- mkRhsClosure looks for two special forms of the right-hand side: - a) selector thunks - b) AP thunks - -If neither happens, it just calls mkClosureLFInfo. You might think -that mkClosureLFInfo should do all this, but it seems wrong for the -latter to look at the structure of an expression - -Note [Selectors] -~~~~~~~~~~~~~~~~ -We look at the body of the closure to see if it's a selector---turgid, -but nothing deep. We are looking for a closure of {\em exactly} the -form: - -... = [the_fv] \ u [] -> - case the_fv of - con a_1 ... a_n -> a_i - -Note [Ap thunks] -~~~~~~~~~~~~~~~~ -A more generic AP thunk of the form - - x = [ x_1...x_n ] \.. [] -> x_1 ... x_n - -A set of these is compiled statically into the RTS, so we just use -those. We could extend the idea to thunks where some of the x_i are -global ids (and hence not free variables), but this would entail -generating a larger thunk. It might be an option for non-optimising -compilation, though. - -We only generate an Ap thunk if all the free variables are pointers, -for semi-obvious reasons. - --} - ----------- Note [Selectors] ------------------ -mkRhsClosure dflags bndr _cc _bi - [NonVoid the_fv] -- Just one free var - upd_flag -- Updatable thunk - [] -- A thunk - expr - | let strip = snd . stripStgTicksTop (not . tickishIsCode) - , StgCase (StgApp scrutinee [{-no args-}]) - _ -- ignore bndr - (AlgAlt _) - [(DataAlt _, params, sel_expr)] <- strip expr - , StgApp selectee [{-no args-}] <- strip sel_expr - , the_fv == scrutinee -- Scrutinee is the only free variable - - , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params)) - -- pattern binders are always non-void, - -- see Note [Post-unarisation invariants] in UnariseStg - , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee) - - , let offset_into_int = bytesToWordsRoundUp dflags the_offset - - fixedHdrSizeW dflags - , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough - = -- NOT TRUE: ASSERT(is_single_constructor) - -- The simplifier may have statically determined that the single alternative - -- is the only possible case and eliminated the others, even if there are - -- other constructors in the datatype. It's still ok to make a selector - -- thunk in this case, because we *know* which constructor the scrutinee - -- will evaluate to. - -- - -- srt is discarded; it must be empty - let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) - in cgRhsStdThunk bndr lf_info [StgVarArg the_fv] - ----------- Note [Ap thunks] ------------------ -mkRhsClosure dflags bndr _cc _bi - fvs - upd_flag - [] -- No args; a thunk - (StgApp fun_id args) - - -- We are looking for an "ApThunk"; see data con ApThunk in StgCmmClosure - -- of form (x1 x2 .... xn), where all the xi are locals (not top-level) - -- So the xi will all be free variables - | args `lengthIs` (n_fvs-1) -- This happens only if the fun_id and - -- args are all distinct local variables - -- The "-1" is for fun_id - -- Missed opportunity: (f x x) is not detected - , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs - , isUpdatable upd_flag - , n_fvs <= mAX_SPEC_AP_SIZE dflags - , not (gopt Opt_SccProfilingOn dflags) - -- not when profiling: we don't want to - -- lose information about this particular - -- thunk (e.g. its type) (#949) - - -- Ha! an Ap thunk - = cgRhsStdThunk bndr lf_info payload - - where - n_fvs = length fvs - lf_info = mkApLFInfo bndr upd_flag n_fvs - -- the payload has to be in the correct order, hence we can't - -- just use the fvs. - payload = StgVarArg fun_id : args - ----------- Default case ------------------ -mkRhsClosure dflags bndr cc _ fvs upd_flag args body - = do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args - ; (id_info, reg) <- rhsIdInfo bndr lf_info - ; return (id_info, gen_code lf_info reg) } - where - gen_code lf_info reg - = do { -- LAY OUT THE OBJECT - -- If the binder is itself a free variable, then don't store - -- it in the closure. Instead, just bind it to Node on entry. - -- NB we can be sure that Node will point to it, because we - -- haven't told mkClosureLFInfo about this; so if the binder - -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is* - -- stored in the closure itself, so it will make sure that - -- Node points to it... - ; let reduced_fvs = filter (NonVoid bndr /=) fvs - - -- MAKE CLOSURE INFO FOR THIS CLOSURE - ; mod_name <- getModuleName - ; dflags <- getDynFlags - ; let name = idName bndr - descr = closureDescription dflags mod_name name - fv_details :: [(NonVoid Id, ByteOff)] - (tot_wds, ptr_wds, fv_details) - = mkVirtHeapOffsets dflags (isLFThunk lf_info) - (addIdReps reduced_fvs) - closure_info = mkClosureInfo dflags False -- Not static - bndr lf_info tot_wds ptr_wds - descr - - -- BUILD ITS INFO TABLE AND CODE - ; forkClosureBody $ - -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere - -- (b) ignore Sequel from context; use empty Sequel - -- And compile the body - closureCodeBody False bndr closure_info cc (nonVoidIds args) - (length args) body fv_details - - -- BUILD THE OBJECT --- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body - ; let use_cc = curCCS; blame_cc = curCCS - ; emit (mkComment $ mkFastString "calling allocDynClosure") - ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) - ; let info_tbl = mkCmmInfo closure_info - ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc - (map toVarArg fv_details) - - -- RETURN - ; return (mkRhsInit dflags reg lf_info hp_plus_n) } - -------------------------- -cgRhsStdThunk - :: Id - -> LambdaFormInfo - -> [StgArg] -- payload - -> FCode (CgIdInfo, FCode CmmAGraph) - -cgRhsStdThunk bndr lf_info payload - = do { (id_info, reg) <- rhsIdInfo bndr lf_info - ; return (id_info, gen_code reg) - } - where - gen_code reg -- AHA! A STANDARD-FORM THUNK - = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $ - do - { -- LAY OUT THE OBJECT - mod_name <- getModuleName - ; dflags <- getDynFlags - ; let (tot_wds, ptr_wds, payload_w_offsets) - = mkVirtHeapOffsets dflags (isLFThunk lf_info) - (addArgReps (nonVoidStgArgs payload)) - - descr = closureDescription dflags mod_name (idName bndr) - closure_info = mkClosureInfo dflags False -- Not static - bndr lf_info tot_wds ptr_wds - descr - --- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body - ; let use_cc = curCCS; blame_cc = curCCS - - - -- BUILD THE OBJECT - ; let info_tbl = mkCmmInfo closure_info - ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info - use_cc blame_cc payload_w_offsets - - -- RETURN - ; return (mkRhsInit dflags reg lf_info hp_plus_n) } - - -mkClosureLFInfo :: DynFlags - -> Id -- The binder - -> TopLevelFlag -- True of top level - -> [NonVoid Id] -- Free vars - -> UpdateFlag -- Update flag - -> [Id] -- Args - -> LambdaFormInfo -mkClosureLFInfo dflags bndr top fvs upd_flag args - | null args = - mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag - | otherwise = - mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args) - - ------------------------------------------------------------------------- --- The code for closures ------------------------------------------------------------------------- - -closureCodeBody :: Bool -- whether this is a top-level binding - -> Id -- the closure's name - -> ClosureInfo -- Lots of information about this closure - -> CostCentreStack -- Optional cost centre attached to closure - -> [NonVoid Id] -- incoming args to the closure - -> Int -- arity, including void args - -> StgExpr - -> [(NonVoid Id, ByteOff)] -- the closure's free vars - -> FCode () - -{- There are two main cases for the code for closures. - -* If there are *no arguments*, then the closure is a thunk, and not in - normal form. So it should set up an update frame (if it is - shared). NB: Thunks cannot have a primitive type! - -* If there is *at least one* argument, then this closure is in - normal form, so there is no need to set up an update frame. --} - -closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details - | arity == 0 -- No args i.e. thunk - = withNewTickyCounterThunk - (isStaticClosure cl_info) - (closureUpdReqd cl_info) - (closureName cl_info) $ - emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ - \(_, node, _) -> thunkCode cl_info fv_details cc node arity body - where - lf_info = closureLFInfo cl_info - info_tbl = mkCmmInfo cl_info - -closureCodeBody top_lvl bndr cl_info cc args arity body fv_details - = -- Note: args may be [], if all args are Void - withNewTickyCounterFun - (closureSingleEntry cl_info) - (closureName cl_info) - args $ do { - - ; let - lf_info = closureLFInfo cl_info - info_tbl = mkCmmInfo cl_info - - -- Emit the main entry code - ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $ - \(_offset, node, arg_regs) -> do - -- Emit slow-entry code (for entering a closure through a PAP) - { mkSlowEntryCode bndr cl_info arg_regs - ; dflags <- getDynFlags - ; let node_points = nodeMustPointToIt dflags lf_info - node' = if node_points then Just node else Nothing - ; loop_header_id <- newBlockId - -- Extend reader monad with information that - -- self-recursive tail calls can be optimized into local - -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr. - ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do - { - -- Main payload - ; entryHeapCheck cl_info node' arity arg_regs $ do - { -- emit LDV code when profiling - when node_points (ldvEnterClosure cl_info (CmmLocal node)) - -- ticky after heap check to avoid double counting - ; tickyEnterFun cl_info - ; enterCostCentreFun cc - (CmmMachOp (mo_wordSub dflags) - [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification] - , mkIntExpr dflags (funTag dflags cl_info) ]) - ; fv_bindings <- mapM bind_fv fv_details - -- Load free vars out of closure *after* - -- heap check, to reduce live vars over check - ; when node_points $ load_fvs node lf_info fv_bindings - ; void $ cgExpr body - }}} - - } - --- Note [NodeReg clobbered with loopification] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Previously we used to pass nodeReg (aka R1) here. With profiling, upon --- entering a closure, enterFunCCS was called with R1 passed to it. But since R1 --- may get clobbered inside the body of a closure, and since a self-recursive --- tail call does not restore R1, a subsequent call to enterFunCCS received a --- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to --- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores --- the original value of R1. This way R1 may get modified but loopification will --- not care. - --- A function closure pointer may be tagged, so we --- must take it into account when accessing the free variables. -bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff) -bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) } - -load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode () -load_fvs node lf_info = mapM_ (\ (reg, off) -> - do dflags <- getDynFlags - let tag = lfDynTag dflags lf_info - emit $ mkTaggedObjectLoad dflags reg node off tag) - ------------------------------------------ --- The "slow entry" code for a function. This entry point takes its --- arguments on the stack. It loads the arguments into registers --- according to the calling convention, and jumps to the function's --- normal entry point. The function's closure is assumed to be in --- R1/node. --- --- The slow entry point is used for unknown calls: eg. stg_PAP_entry - -mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode () --- If this function doesn't have a specialised ArgDescr, we need --- to generate the function's arg bitmap and slow-entry code. --- Here, we emit the slow-entry code. -mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' - | Just (_, ArgGen _) <- closureFunInfo cl_info - = do dflags <- getDynFlags - let node = idToReg dflags (NonVoid bndr) - slow_lbl = closureSlowEntryLabel cl_info - fast_lbl = closureLocalEntryLabel dflags cl_info - -- mkDirectJump does not clobber `Node' containing function closure - jump = mkJump dflags NativeNodeCall - (mkLblExpr fast_lbl) - (map (CmmReg . CmmLocal) (node : arg_regs)) - (initUpdFrameOff dflags) - tscope <- getTickScope - emitProcWithConvention Slow Nothing slow_lbl - (node : arg_regs) (jump, tscope) - | otherwise = return () - ------------------------------------------ -thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack - -> LocalReg -> Int -> StgExpr -> FCode () -thunkCode cl_info fv_details _cc node arity body - = do { dflags <- getDynFlags - ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info) - node' = if node_points then Just node else Nothing - ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling - - -- Heap overflow check - ; entryHeapCheck cl_info node' arity [] $ do - { -- Overwrite with black hole if necessary - -- but *after* the heap-overflow check - ; tickyEnterThunk cl_info - ; when (blackHoleOnEntry cl_info && node_points) - (blackHoleIt node) - - -- Push update frame - ; setupUpdate cl_info node $ - -- We only enter cc after setting up update so - -- that cc of enclosing scope will be recorded - -- in update frame CAF/DICT functions will be - -- subsumed by this enclosing cc - do { enterCostCentreThunk (CmmReg nodeReg) - ; let lf_info = closureLFInfo cl_info - ; fv_bindings <- mapM bind_fv fv_details - ; load_fvs node lf_info fv_bindings - ; void $ cgExpr body }}} - - ------------------------------------------------------------------------- --- Update and black-hole wrappers ------------------------------------------------------------------------- - -blackHoleIt :: LocalReg -> FCode () --- Only called for closures with no args --- Node points to the closure -blackHoleIt node_reg - = emitBlackHoleCode (CmmReg (CmmLocal node_reg)) - -emitBlackHoleCode :: CmmExpr -> FCode () -emitBlackHoleCode node = do - dflags <- getDynFlags - - -- Eager blackholing is normally disabled, but can be turned on with - -- -feager-blackholing. When it is on, we replace the info pointer - -- of the thunk with stg_EAGER_BLACKHOLE_info on entry. - - -- If we wanted to do eager blackholing with slop filling, we'd need - -- to do it at the *end* of a basic block, otherwise we overwrite - -- the free variables in the thunk that we still need. We have a - -- patch for this from Andy Cheadle, but not incorporated yet. --SDM - -- [6/2004] - -- - -- Previously, eager blackholing was enabled when ticky-ticky was - -- on. But it didn't work, and it wasn't strictly necessary to bring - -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is - -- unconditionally disabled. -- krc 1/2007 - - -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, - -- because emitBlackHoleCode is called from CmmParse. - - let eager_blackholing = not (gopt Opt_SccProfilingOn dflags) - && gopt Opt_EagerBlackHoling dflags - -- Profiling needs slop filling (to support LDV - -- profiling), so currently eager blackholing doesn't - -- work with profiling. - - when eager_blackholing $ do - emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) - (CmmReg (CmmGlobal CurrentTSO)) - emitPrimCall [] MO_WriteBarrier [] - emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) - -setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () - -- Nota Bene: this function does not change Node (even if it's a CAF), - -- so that the cost centre in the original closure can still be - -- extracted by a subsequent enterCostCentre -setupUpdate closure_info node body - | not (lfUpdatable (closureLFInfo closure_info)) - = body - - | not (isStaticClosure closure_info) - = if not (closureUpdReqd closure_info) - then do tickyUpdateFrameOmitted; body - else do - tickyPushUpdateFrame - dflags <- getDynFlags - let - bh = blackHoleOnEntry closure_info && - not (gopt Opt_SccProfilingOn dflags) && - gopt Opt_EagerBlackHoling dflags - - lbl | bh = mkBHUpdInfoLabel - | otherwise = mkUpdInfoLabel - - pushUpdateFrame lbl (CmmReg (CmmLocal node)) body - - | otherwise -- A static closure - = do { tickyUpdateBhCaf closure_info - - ; if closureUpdReqd closure_info - then do -- Blackhole the (updatable) CAF: - { upd_closure <- link_caf node True - ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body } - else do {tickyUpdateFrameOmitted; body} - } - ------------------------------------------------------------------------------ --- Setting up update frames - --- Push the update frame on the stack in the Entry area, --- leaving room for the return address that is already --- at the old end of the area. --- -pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode () -pushUpdateFrame lbl updatee body - = do - updfr <- getUpdFrameOff - dflags <- getDynFlags - let - hdr = fixedHdrSize dflags - frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags - -- - emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee - withUpdFrameOff frame body - -emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode () -emitUpdateFrame dflags frame lbl updatee = do - let - hdr = fixedHdrSize dflags - off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags - -- - emitStore frame (mkLblExpr lbl) - emitStore (cmmOffset dflags frame off_updatee) updatee - initUpdFrameProf frame - ------------------------------------------------------------------------------ --- Entering a CAF --- --- See Note [CAF management] in rts/sm/Storage.c - -link_caf :: LocalReg -- pointer to the closure - -> Bool -- True <=> updatable, False <=> single-entry - -> FCode CmmExpr -- Returns amode for closure to be updated --- This function returns the address of the black hole, so it can be --- updated with the new value when available. -link_caf node _is_upd = do - { dflags <- getDynFlags - -- Call the RTS function newCAF, returning the newly-allocated - -- blackhole indirection closure - ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing - ForeignLabelInExternalPackage IsFunction - ; bh <- newTemp (bWord dflags) - ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl - [ (CmmReg (CmmGlobal BaseReg), AddrHint), - (CmmReg (CmmLocal node), AddrHint) ] - False - - -- see Note [atomic CAF entry] in rts/sm/Storage.c - ; updfr <- getUpdFrameOff - ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node))) - ; emit =<< mkCmmIfThen - (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags)) - -- re-enter the CAF - (mkJump dflags NativeNodeCall target [] updfr) - - ; return (CmmReg (CmmLocal bh)) } - ------------------------------------------------------------------------- --- Profiling ------------------------------------------------------------------------- - --- For "global" data constructors the description is simply occurrence --- name of the data constructor itself. Otherwise it is determined by --- @closureDescription@ from the let binding information. - -closureDescription :: DynFlags - -> Module -- Module - -> Name -- Id of closure binding - -> String - -- Not called for StgRhsCon which have global info tables built in - -- CgConTbls.hs with a description generated from the data constructor -closureDescription dflags mod_name name - = showSDocDump dflags (char '<' <> - (if isExternalName name - then ppr name -- ppr will include the module name prefix - else pprModule mod_name <> char '.' <> ppr name) <> - char '>') - -- showSDocDump, because we want to see the unique on the Name. diff --git a/codeGen/StgCmmBind.hs-boot b/codeGen/StgCmmBind.hs-boot deleted file mode 100644 --- a/codeGen/StgCmmBind.hs-boot +++ /dev/null @@ -1,6 +0,0 @@ -module StgCmmBind where - -import StgCmmMonad( FCode ) -import StgSyn( StgBinding ) - -cgBind :: StgBinding -> FCode () diff --git a/codeGen/StgCmmClosure.hs b/codeGen/StgCmmClosure.hs deleted file mode 100644 --- a/codeGen/StgCmmClosure.hs +++ /dev/null @@ -1,1086 +0,0 @@ -{-# LANGUAGE CPP, RecordWildCards #-} - ------------------------------------------------------------------------------ --- --- Stg to C-- code generation: --- --- The types LambdaFormInfo --- ClosureInfo --- --- Nothing monadic in here! --- ------------------------------------------------------------------------------ - -module StgCmmClosure ( - DynTag, tagForCon, isSmallFamily, - ConTagZ, dataConTagZ, - - idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, - argPrimRep, - - NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs, - assertNonVoidIds, assertNonVoidStgArgs, - - -- * LambdaFormInfo - LambdaFormInfo, -- Abstract - StandardFormInfo, -- ...ditto... - mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, - mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, - mkLFStringLit, - lfDynTag, - maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable, - - -- * Used by other modules - CgLoc(..), SelfLoopInfo, CallMethod(..), - nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod, - - -- * ClosureInfo - ClosureInfo, - mkClosureInfo, - mkCmmInfo, - - -- ** Inspection - closureLFInfo, closureName, - - -- ** Labels - -- These just need the info table label - closureInfoLabel, staticClosureLabel, - closureSlowEntryLabel, closureLocalEntryLabel, - - -- ** Predicates - -- These are really just functions on LambdaFormInfo - closureUpdReqd, closureSingleEntry, - closureReEntrant, closureFunInfo, - isToplevClosure, - - blackHoleOnEntry, -- Needs LambdaFormInfo and SMRep - isStaticClosure, -- Needs SMPre - - -- * InfoTables - mkDataConInfoTable, - cafBlackHoleInfoTable, - indStaticInfoTable, - staticClosureNeedsLink, - ) where - -#include "MachDeps.h" - -#include "HsVersions.h" - -import StgSyn -import SMRep -import Cmm -import PprCmmExpr() - -import BlockId -import CLabel -import Id -import IdInfo -import DataCon -import Name -import Type -import TyCoRep -import TcType -import TyCon -import RepType -import BasicTypes -import Outputable -import DynFlags -import Util - -import Data.Coerce (coerce) - ------------------------------------------------------------------------------ --- Data types and synonyms ------------------------------------------------------------------------------ - --- These data types are mostly used by other modules, especially StgCmmMonad, --- but we define them here because some functions in this module need to --- have access to them as well - -data CgLoc - = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning - -- Hp, so that it remains valid across calls - - | LneLoc BlockId [LocalReg] -- A join point - -- A join point (= let-no-escape) should only - -- be tail-called, and in a saturated way. - -- To tail-call it, assign to these locals, - -- and branch to the block id - -instance Outputable CgLoc where - ppr (CmmLoc e) = text "cmm" <+> ppr e - ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs - -type SelfLoopInfo = (Id, BlockId, [LocalReg]) - --- used by ticky profiling -isKnownFun :: LambdaFormInfo -> Bool -isKnownFun LFReEntrant{} = True -isKnownFun LFLetNoEscape = True -isKnownFun _ = False - - -------------------------------------- --- Non-void types -------------------------------------- --- We frequently need the invariant that an Id or a an argument --- is of a non-void type. This type is a witness to the invariant. - -newtype NonVoid a = NonVoid a - deriving (Eq, Show) - -fromNonVoid :: NonVoid a -> a -fromNonVoid (NonVoid a) = a - -instance (Outputable a) => Outputable (NonVoid a) where - ppr (NonVoid a) = ppr a - -nonVoidIds :: [Id] -> [NonVoid Id] -nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))] - --- | Used in places where some invariant ensures that all these Ids are --- non-void; e.g. constructor field binders in case expressions. --- See Note [Post-unarisation invariants] in UnariseStg. -assertNonVoidIds :: [Id] -> [NonVoid Id] -assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids)) - coerce ids - -nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] -nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))] - --- | Used in places where some invariant ensures that all these arguments are --- non-void; e.g. constructor arguments. --- See Note [Post-unarisation invariants] in UnariseStg. -assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] -assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args)) - coerce args - - ------------------------------------------------------------------------------ --- Representations ------------------------------------------------------------------------------ - --- Why are these here? - -idPrimRep :: Id -> PrimRep -idPrimRep id = typePrimRep1 (idType id) - -- NB: typePrimRep1 fails on unboxed tuples, - -- but by StgCmm no Ids have unboxed tuple type - -addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] -addIdReps = map (\id -> let id' = fromNonVoid id - in NonVoid (idPrimRep id', id')) - -addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)] -addArgReps = map (\arg -> let arg' = fromNonVoid arg - in NonVoid (argPrimRep arg', arg')) - -argPrimRep :: StgArg -> PrimRep -argPrimRep arg = typePrimRep1 (stgArgType arg) - - ------------------------------------------------------------------------------ --- LambdaFormInfo ------------------------------------------------------------------------------ - --- Information about an identifier, from the code generator's point of --- view. Every identifier is bound to a LambdaFormInfo in the --- environment, which gives the code generator enough info to be able to --- tail call or return that identifier. - -data LambdaFormInfo - = LFReEntrant -- Reentrant closure (a function) - TopLevelFlag -- True if top level - OneShotInfo - !RepArity -- Arity. Invariant: always > 0 - !Bool -- True <=> no fvs - ArgDescr -- Argument descriptor (should really be in ClosureInfo) - - | LFThunk -- Thunk (zero arity) - TopLevelFlag - !Bool -- True <=> no free vars - !Bool -- True <=> updatable (i.e., *not* single-entry) - StandardFormInfo - !Bool -- True <=> *might* be a function type - - | LFCon -- A saturated constructor application - DataCon -- The constructor - - | LFUnknown -- Used for function arguments and imported things. - -- We know nothing about this closure. - -- Treat like updatable "LFThunk"... - -- Imported things which we *do* know something about use - -- one of the other LF constructors (eg LFReEntrant for - -- known functions) - !Bool -- True <=> *might* be a function type - -- The False case is good when we want to enter it, - -- because then we know the entry code will do - -- For a function, the entry code is the fast entry point - - | LFUnlifted -- A value of unboxed type; - -- always a value, needs evaluation - - | LFLetNoEscape -- See LetNoEscape module for precise description - - -------------------------- --- StandardFormInfo tells whether this thunk has one of --- a small number of standard forms - -data StandardFormInfo - = NonStandardThunk - -- The usual case: not of the standard forms - - | SelectorThunk - -- A SelectorThunk is of form - -- case x of - -- con a1,..,an -> ak - -- and the constructor is from a single-constr type. - WordOff -- 0-origin offset of ak within the "goods" of - -- constructor (Recall that the a1,...,an may be laid - -- out in the heap in a non-obvious order.) - - | ApThunk - -- An ApThunk is of form - -- x1 ... xn - -- The code for the thunk just pushes x2..xn on the stack and enters x1. - -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled - -- in the RTS to save space. - RepArity -- Arity, n - - ------------------------------------------------------- --- Building LambdaFormInfo ------------------------------------------------------- - -mkLFArgument :: Id -> LambdaFormInfo -mkLFArgument id - | isUnliftedType ty = LFUnlifted - | might_be_a_function ty = LFUnknown True - | otherwise = LFUnknown False - where - ty = idType id - -------------- -mkLFLetNoEscape :: LambdaFormInfo -mkLFLetNoEscape = LFLetNoEscape - -------------- -mkLFReEntrant :: TopLevelFlag -- True of top level - -> [Id] -- Free vars - -> [Id] -- Args - -> ArgDescr -- Argument descriptor - -> LambdaFormInfo - -mkLFReEntrant _ _ [] _ - = pprPanic "mkLFReEntrant" empty -mkLFReEntrant top fvs args arg_descr - = LFReEntrant top os_info (length args) (null fvs) arg_descr - where os_info = idOneShotInfo (head args) - -------------- -mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo -mkLFThunk thunk_ty top fvs upd_flag - = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) ) - LFThunk top (null fvs) - (isUpdatable upd_flag) - NonStandardThunk - (might_be_a_function thunk_ty) - --------------- -might_be_a_function :: Type -> Bool --- Return False only if we are *sure* it's a data type --- Look through newtypes etc as much as poss -might_be_a_function ty - | [LiftedRep] <- typePrimRep ty - , Just tc <- tyConAppTyCon_maybe (unwrapType ty) - , isDataTyCon tc - = False - | otherwise - = True - -------------- -mkConLFInfo :: DataCon -> LambdaFormInfo -mkConLFInfo con = LFCon con - -------------- -mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo -mkSelectorLFInfo id offset updatable - = LFThunk NotTopLevel False updatable (SelectorThunk offset) - (might_be_a_function (idType id)) - -------------- -mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo -mkApLFInfo id upd_flag arity - = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) - (might_be_a_function (idType id)) - -------------- -mkLFImported :: Id -> LambdaFormInfo -mkLFImported id - | Just con <- isDataConWorkId_maybe id - , isNullaryRepDataCon con - = LFCon con -- An imported nullary constructor - -- We assume that the constructor is evaluated so that - -- the id really does point directly to the constructor - - | arity > 0 - = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr") - - | otherwise - = mkLFArgument id -- Not sure of exact arity - where - arity = idFunRepArity id - -------------- -mkLFStringLit :: LambdaFormInfo -mkLFStringLit = LFUnlifted - ------------------------------------------------------ --- Dynamic pointer tagging ------------------------------------------------------ - -type DynTag = Int -- The tag on a *pointer* - -- (from the dynamic-tagging paper) - --- Note [Data constructor dynamic tags] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- The family size of a data type (the number of constructors --- or the arity of a function) can be either: --- * small, if the family size < 2**tag_bits --- * big, otherwise. --- --- Small families can have the constructor tag in the tag bits. --- Big families only use the tag value 1 to represent evaluatedness. --- We don't have very many tag bits: for example, we have 2 bits on --- x86-32 and 3 bits on x86-64. - -isSmallFamily :: DynFlags -> Int -> Bool -isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags - --- We keep the *zero-indexed* tag in the srt_len field of the info --- table of a data constructor. -dataConTagZ :: DataCon -> ConTagZ -dataConTagZ con = dataConTag con - fIRST_TAG - -tagForCon :: DynFlags -> DataCon -> DynTag -tagForCon dflags con - | isSmallFamily dflags fam_size = con_tag + 1 - | otherwise = 1 - where - con_tag = dataConTagZ con - fam_size = tyConFamilySize (dataConTyCon con) - -tagForArity :: DynFlags -> RepArity -> DynTag -tagForArity dflags arity - | isSmallFamily dflags arity = arity - | otherwise = 0 - -lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag --- Return the tag in the low order bits of a variable bound --- to this LambdaForm -lfDynTag dflags (LFCon con) = tagForCon dflags con -lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity -lfDynTag _ _other = 0 - - ------------------------------------------------------------------------------ --- Observing LambdaFormInfo ------------------------------------------------------------------------------ - -------------- -maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon -maybeIsLFCon (LFCon con) = Just con -maybeIsLFCon _ = Nothing - ------------- -isLFThunk :: LambdaFormInfo -> Bool -isLFThunk (LFThunk {}) = True -isLFThunk _ = False - -isLFReEntrant :: LambdaFormInfo -> Bool -isLFReEntrant (LFReEntrant {}) = True -isLFReEntrant _ = False - ------------------------------------------------------------------------------ --- Choosing SM reps ------------------------------------------------------------------------------ - -lfClosureType :: LambdaFormInfo -> ClosureTypeInfo -lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd -lfClosureType (LFCon con) = Constr (dataConTagZ con) - (dataConIdentity con) -lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel -lfClosureType _ = panic "lfClosureType" - -thunkClosureType :: StandardFormInfo -> ClosureTypeInfo -thunkClosureType (SelectorThunk off) = ThunkSelector off -thunkClosureType _ = Thunk - --- We *do* get non-updatable top-level thunks sometimes. eg. f = g --- gets compiled to a jump to g (if g has non-zero arity), instead of --- messing around with update frames and PAPs. We set the closure type --- to FUN_STATIC in this case. - ------------------------------------------------------------------------------ --- nodeMustPointToIt ------------------------------------------------------------------------------ - -nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool --- If nodeMustPointToIt is true, then the entry convention for --- this closure has R1 (the "Node" register) pointing to the --- closure itself --- the "self" argument - -nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _) - = not no_fvs -- Certainly if it has fvs we need to point to it - || isNotTopLevel top -- See Note [GC recovery] - -- For lex_profiling we also access the cost centre for a - -- non-inherited (i.e. non-top-level) function. - -- The isNotTopLevel test above ensures this is ok. - -nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _) - = not no_fvs -- Self parameter - || isNotTopLevel top -- Note [GC recovery] - || updatable -- Need to push update frame - || gopt Opt_SccProfilingOn dflags - -- For the non-updatable (single-entry case): - -- - -- True if has fvs (in which case we need access to them, and we - -- should black-hole it) - -- or profiling (in which case we need to recover the cost centre - -- from inside it) ToDo: do we need this even for - -- top-level thunks? If not, - -- isNotTopLevel subsumes this - -nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk - = True - -nodeMustPointToIt _ (LFCon _) = True - - -- Strictly speaking, the above two don't need Node to point - -- to it if the arity = 0. But this is a *really* unlikely - -- situation. If we know it's nil (say) and we are entering - -- it. Eg: let x = [] in x then we will certainly have inlined - -- x, since nil is a simple atom. So we gain little by not - -- having Node point to known zero-arity things. On the other - -- hand, we do lose something; Patrick's code for figuring out - -- when something has been updated but not entered relies on - -- having Node point to the result of an update. SLPJ - -- 27/11/92. - -nodeMustPointToIt _ (LFUnknown _) = True -nodeMustPointToIt _ LFUnlifted = False -nodeMustPointToIt _ LFLetNoEscape = False - -{- Note [GC recovery] -~~~~~~~~~~~~~~~~~~~~~ -If we a have a local let-binding (function or thunk) - let f = in ... -AND allocates, then the heap-overflow check needs to know how -to re-start the evaluation. It uses the "self" pointer to do this. -So even if there are no free variables in , we still make -nodeMustPointToIt be True for non-top-level bindings. - -Why do any such bindings exist? After all, let-floating should have -floated them out. Well, a clever optimiser might leave one there to -avoid a space leak, deliberately recomputing a thunk. Also (and this -really does happen occasionally) let-floating may make a function f smaller -so it can be inlined, so now (f True) may generate a local no-fv closure. -This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind -in TcGenDeriv.) -} - ------------------------------------------------------------------------------ --- getCallMethod ------------------------------------------------------------------------------ - -{- The entry conventions depend on the type of closure being entered, -whether or not it has free variables, and whether we're running -sequentially or in parallel. - -Closure Node Argument Enter -Characteristics Par Req'd Passing Via ---------------------------------------------------------------------------- -Unknown & no & yes & stack & node -Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args) - & slow entry (otherwise) -Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args) -0 arg, no fvs \r,\s & no & no & n/a & direct entry -0 arg, no fvs \u & no & yes & n/a & node -0 arg, fvs \r,\s,selector & no & yes & n/a & node -0 arg, fvs \r,\s & no & yes & n/a & direct entry -0 arg, fvs \u & no & yes & n/a & node -Unknown & yes & yes & stack & node -Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args) - & slow entry (otherwise) -Known fun (>1 arg), fvs & yes & yes & registers & node -0 arg, fvs \r,\s,selector & yes & yes & n/a & node -0 arg, no fvs \r,\s & yes & no & n/a & direct entry -0 arg, no fvs \u & yes & yes & n/a & node -0 arg, fvs \r,\s & yes & yes & n/a & node -0 arg, fvs \u & yes & yes & n/a & node - -When black-holing, single-entry closures could also be entered via node -(rather than directly) to catch double-entry. -} - -data CallMethod - = EnterIt -- No args, not a function - - | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop - - | ReturnIt -- It's a value (function, unboxed value, - -- or constructor), so just return it. - - | SlowCall -- Unknown fun, or known fun with - -- too few args. - - | DirectEntry -- Jump directly, with args in regs - CLabel -- The code label - RepArity -- Its arity - -getCallMethod :: DynFlags - -> Name -- Function being applied - -> Id -- Function Id used to chech if it can refer to - -- CAF's and whether the function is tail-calling - -- itself - -> LambdaFormInfo -- Its info - -> RepArity -- Number of available arguments - -> RepArity -- Number of them being void arguments - -> CgLoc -- Passed in from cgIdApp so that we can - -- handle let-no-escape bindings and self-recursive - -- tail calls using the same data constructor, - -- JumpToIt. This saves us one case branch in - -- cgIdApp - -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call? - -> CallMethod - -getCallMethod dflags _ id _ n_args v_args _cg_loc - (Just (self_loop_id, block_id, args)) - | gopt Opt_Loopification dflags - , id == self_loop_id - , n_args - v_args == length args - -- If these patterns match then we know that: - -- * loopification optimisation is turned on - -- * function is performing a self-recursive call in a tail position - -- * number of non-void parameters of the function matches functions arity. - -- See Note [Self-recursive tail calls] and Note [Void arguments in - -- self-recursive tail calls] in StgCmmExpr for more details - = JumpToIt block_id args - -getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc - _self_loop_info - | n_args == 0 -- No args at all - && not (gopt Opt_SccProfilingOn dflags) - -- See Note [Evaluating functions with profiling] in rts/Apply.cmm - = ASSERT( arity /= 0 ) ReturnIt - | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity - -getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info - = ASSERT( n_args == 0 ) ReturnIt - -getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info - = ASSERT( n_args == 0 ) ReturnIt - -- n_args=0 because it'd be ill-typed to apply a saturated - -- constructor application to anything - -getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun) - n_args _v_args _cg_loc _self_loop_info - | is_fun -- it *might* be a function, so we must "call" it (which is always safe) - = SlowCall -- We cannot just enter it [in eval/apply, the entry code - -- is the fast-entry code] - - -- Since is_fun is False, we are *definitely* looking at a data value - | updatable || gopt Opt_Ticky dflags -- to catch double entry - {- OLD: || opt_SMP - I decided to remove this, because in SMP mode it doesn't matter - if we enter the same thunk multiple times, so the optimisation - of jumping directly to the entry code is still valid. --SDM - -} - = EnterIt - - -- even a non-updatable selector thunk can be updated by the garbage - -- collector, so we must enter it. (#8817) - | SelectorThunk{} <- std_form_info - = EnterIt - - -- We used to have ASSERT( n_args == 0 ), but actually it is - -- possible for the optimiser to generate - -- let bot :: Int = error Int "urk" - -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3 - -- This happens as a result of the case-of-error transformation - -- So the right thing to do is just to enter the thing - - | otherwise -- Jump direct to code for single-entry thunks - = ASSERT( n_args == 0 ) - DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info - updatable) 0 - -getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info - = SlowCall -- might be a function - -getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info - = ASSERT2( n_args == 0, ppr name <+> ppr n_args ) - EnterIt -- Not a function - -getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) - _self_loop_info - = JumpToIt blk_id lne_regs - -getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method" - ------------------------------------------------------------------------------ --- staticClosureRequired ------------------------------------------------------------------------------ - -{- staticClosureRequired is never called (hence commented out) - - SimonMar writes (Sept 07) It's an optimisation we used to apply at - one time, I believe, but it got lost probably in the rewrite of - the RTS/code generator. I left that code there to remind me to - look into whether it was worth doing sometime - -{- Avoiding generating entries and info tables - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At present, for every function we generate all of the following, -just in case. But they aren't always all needed, as noted below: - -[NB1: all of this applies only to *functions*. Thunks always -have closure, info table, and entry code.] - -[NB2: All are needed if the function is *exported*, just to play safe.] - -* Fast-entry code ALWAYS NEEDED - -* Slow-entry code - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) we're in the parallel world and the function has free vars - [Reason: in parallel world, we always enter functions - with free vars via the closure.] - -* The function closure - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) if the function has free vars (ie not top level) - - Why case (a) here? Because if the arg-satis check fails, - UpdatePAP stuffs a pointer to the function closure in the PAP. - [Could be changed; UpdatePAP could stuff in a code ptr instead, - but doesn't seem worth it.] - - [NB: these conditions imply that we might need the closure - without the slow-entry code. Here's how. - - f x y = let g w = ...x..y..w... - in - ...(g t)... - - Here we need a closure for g which contains x and y, - but since the calls are all saturated we just jump to the - fast entry point for g, with R1 pointing to the closure for g.] - - -* Standard info table - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) the function has free vars (ie not top level) - - NB. In the sequential world, (c) is only required so that the function closure has - an info table to point to, to keep the storage manager happy. - If (c) alone is true we could fake up an info table by choosing - one of a standard family of info tables, whose entry code just - bombs out. - - [NB In the parallel world (c) is needed regardless because - we enter functions with free vars via the closure.] - - If (c) is retained, then we'll sometimes generate an info table - (for storage mgr purposes) without slow-entry code. Then we need - to use an error label in the info table to substitute for the absent - slow entry code. --} - -staticClosureRequired - :: Name - -> StgBinderInfo - -> LambdaFormInfo - -> Bool -staticClosureRequired binder bndr_info - (LFReEntrant top_level _ _ _ _) -- It's a function - = ASSERT( isTopLevel top_level ) - -- Assumption: it's a top-level, no-free-var binding - not (satCallsOnly bndr_info) - -staticClosureRequired binder other_binder_info other_lf_info = True --} - ------------------------------------------------------------------------------ --- Data types for closure information ------------------------------------------------------------------------------ - - -{- ClosureInfo: information about a binding - - We make a ClosureInfo for each let binding (both top level and not), - but not bindings for data constructors: for those we build a CmmInfoTable - directly (see mkDataConInfoTable). - - To a first approximation: - ClosureInfo = (LambdaFormInfo, CmmInfoTable) - - A ClosureInfo has enough information - a) to construct the info table itself, and build other things - related to the binding (e.g. slow entry points for a function) - b) to allocate a closure containing that info pointer (i.e. - it knows the info table label) --} - -data ClosureInfo - = ClosureInfo { - closureName :: !Name, -- The thing bound to this closure - -- we don't really need this field: it's only used in generating - -- code for ticky and profiling, and we could pass the information - -- around separately, but it doesn't do much harm to keep it here. - - closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon - -- this tells us about what the closure contains: it's right-hand-side. - - -- the rest is just an unpacked CmmInfoTable. - closureInfoLabel :: !CLabel, - closureSMRep :: !SMRep, -- representation used by storage mgr - closureProf :: !ProfilingInfo - } - --- | Convert from 'ClosureInfo' to 'CmmInfoTable'. -mkCmmInfo :: ClosureInfo -> CmmInfoTable -mkCmmInfo ClosureInfo {..} - = CmmInfoTable { cit_lbl = closureInfoLabel - , cit_rep = closureSMRep - , cit_prof = closureProf - , cit_srt = NoC_SRT } - --------------------------------------- --- Building ClosureInfos --------------------------------------- - -mkClosureInfo :: DynFlags - -> Bool -- Is static - -> Id - -> LambdaFormInfo - -> Int -> Int -- Total and pointer words - -> String -- String descriptor - -> ClosureInfo -mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr - = ClosureInfo { closureName = name - , closureLFInfo = lf_info - , closureInfoLabel = info_lbl -- These three fields are - , closureSMRep = sm_rep -- (almost) an info table - , closureProf = prof } -- (we don't have an SRT yet) - where - name = idName id - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) - prof = mkProfilingInfo dflags id val_descr - nonptr_wds = tot_wds - ptr_wds - - info_lbl = mkClosureInfoTableLabel id lf_info - --------------------------------------- --- Other functions over ClosureInfo --------------------------------------- - --- Eager blackholing is normally disabled, but can be turned on with --- -feager-blackholing. When it is on, we replace the info pointer of --- the thunk with stg_EAGER_BLACKHOLE_info on entry. - --- If we wanted to do eager blackholing with slop filling, --- we'd need to do it at the *end* of a basic block, otherwise --- we overwrite the free variables in the thunk that we still --- need. We have a patch for this from Andy Cheadle, but not --- incorporated yet. --SDM [6/2004] --- --- Previously, eager blackholing was enabled when ticky-ticky --- was on. But it didn't work, and it wasn't strictly necessary --- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING --- is unconditionally disabled. -- krc 1/2007 --- --- Static closures are never themselves black-holed. - -blackHoleOnEntry :: ClosureInfo -> Bool -blackHoleOnEntry cl_info - | isStaticRep (closureSMRep cl_info) - = False -- Never black-hole a static closure - - | otherwise - = case closureLFInfo cl_info of - LFReEntrant {} -> False - LFLetNoEscape -> False - LFThunk _ _no_fvs upd _ _ -> upd -- See Note [Black-holing non-updatable thunks] - _other -> panic "blackHoleOnEntry" - -{- Note [Black-holing non-updatable thunks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must not black-hole non-updatable (single-entry) thunks otherwise -we run into issues like Trac #10414. Specifically: - - * There is no reason to black-hole a non-updatable thunk: it should - not be competed for by multiple threads - - * It could, conceivably, cause a space leak if we don't black-hole - it, if there was a live but never-followed pointer pointing to it. - Let's hope that doesn't happen. - - * It is dangerous to black-hole a non-updatable thunk because - - is not updated (of course) - - hence, if it is black-holed and another thread tries to evaluate - it, that thread will block forever - This actually happened in Trac #10414. So we do not black-hole - non-updatable thunks. - - * How could two threads evaluate the same non-updatable (single-entry) - thunk? See Reid Barton's example below. - - * Only eager blackholing could possibly black-hole a non-updatable - thunk, because lazy black-holing only affects thunks with an - update frame on the stack. - -Here is and example due to Reid Barton (Trac #10414): - x = \u [] concat [[1], []] -with the following definitions, - - concat x = case x of - [] -> [] - (:) x xs -> (++) x (concat xs) - - (++) xs ys = case xs of - [] -> ys - (:) x rest -> (:) x ((++) rest ys) - -Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to -denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@ -to WHNF and calls @(++)@ the heap will contain the following thunks, - - x = 1 : y - y = \u [] (++) [] z - z = \s [] concat [] - -Now that the stage is set, consider the follow evaluations by two racing threads -A and B, - - 1. Both threads enter @y@ before either is able to replace it with an - indirection - - 2. Thread A does the case analysis in @(++)@ and consequently enters @z@, - replacing it with a black-hole - - 3. At some later point thread B does the same case analysis and also attempts - to enter @z@. However, it finds that it has been replaced with a black-hole - so it blocks. - - 4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@ - accordingly. It does *not* update @z@, however, as it is single-entry. This - leaves Thread B blocked forever on a black-hole which will never be - updated. - -To avoid this sort of condition we never black-hole non-updatable thunks. --} - -isStaticClosure :: ClosureInfo -> Bool -isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) - -closureUpdReqd :: ClosureInfo -> Bool -closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info - -lfUpdatable :: LambdaFormInfo -> Bool -lfUpdatable (LFThunk _ _ upd _ _) = upd -lfUpdatable _ = False - -closureSingleEntry :: ClosureInfo -> Bool -closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd -closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True -closureSingleEntry _ = False - -closureReEntrant :: ClosureInfo -> Bool -closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True -closureReEntrant _ = False - -closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) -closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info - -lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) -lfFunInfo (LFReEntrant _ _ arity _ arg_desc) = Just (arity, arg_desc) -lfFunInfo _ = Nothing - -funTag :: DynFlags -> ClosureInfo -> DynTag -funTag dflags (ClosureInfo { closureLFInfo = lf_info }) - = lfDynTag dflags lf_info - -isToplevClosure :: ClosureInfo -> Bool -isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) - = case lf_info of - LFReEntrant TopLevel _ _ _ _ -> True - LFThunk TopLevel _ _ _ _ -> True - _other -> False - --------------------------------------- --- Label generation --------------------------------------- - -staticClosureLabel :: ClosureInfo -> CLabel -staticClosureLabel = toClosureLbl . closureInfoLabel - -closureSlowEntryLabel :: ClosureInfo -> CLabel -closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel - -closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel -closureLocalEntryLabel dflags - | tablesNextToCode dflags = toInfoLbl . closureInfoLabel - | otherwise = toEntryLbl . closureInfoLabel - -mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel -mkClosureInfoTableLabel id lf_info - = case lf_info of - LFThunk _ _ upd_flag (SelectorThunk offset) _ - -> mkSelectorInfoLabel upd_flag offset - - LFThunk _ _ upd_flag (ApThunk arity) _ - -> mkApInfoTableLabel upd_flag arity - - LFThunk{} -> std_mk_lbl name cafs - LFReEntrant{} -> std_mk_lbl name cafs - _other -> panic "closureInfoTableLabel" - - where - name = idName id - - std_mk_lbl | is_local = mkLocalInfoTableLabel - | otherwise = mkInfoTableLabel - - cafs = idCafInfo id - is_local = isDataConWorkId id - -- Make the _info pointer for the implicit datacon worker - -- binding local. The reason we can do this is that importing - -- code always either uses the _closure or _con_info. By the - -- invariants in CorePrep anything else gets eta expanded. - - -thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel --- thunkEntryLabel is a local help function, not exported. It's used from --- getCallMethod. -thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag - = enterApLabel dflags upd_flag arity -thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag - = enterSelectorLabel dflags upd_flag offset -thunkEntryLabel dflags thunk_id c _ _ - = enterIdLabel dflags thunk_id c - -enterApLabel :: DynFlags -> Bool -> Arity -> CLabel -enterApLabel dflags is_updatable arity - | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity - | otherwise = mkApEntryLabel is_updatable arity - -enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel -enterSelectorLabel dflags upd_flag offset - | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset - | otherwise = mkSelectorEntryLabel upd_flag offset - -enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel -enterIdLabel dflags id c - | tablesNextToCode dflags = mkInfoTableLabel id c - | otherwise = mkEntryLabel id c - - --------------------------------------- --- Profiling --------------------------------------- - --- Profiling requires two pieces of information to be determined for --- each closure's info table --- description and type. - --- The description is stored directly in the @CClosureInfoTable@ when the --- info table is built. - --- The type is determined from the type information stored with the @Id@ --- in the closure info using @closureTypeDescr@. - -mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo -mkProfilingInfo dflags id val_descr - | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo - | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8 - where - ty_descr_w8 = stringToWord8s (getTyDescription (idType id)) - val_descr_w8 = stringToWord8s val_descr - -getTyDescription :: Type -> String -getTyDescription ty - = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> - case tau_ty of - TyVarTy _ -> "*" - AppTy fun _ -> getTyDescription fun - TyConApp tycon _ -> getOccString tycon - FunTy _ res -> '-' : '>' : fun_result res - ForAllTy _ ty -> getTyDescription ty - LitTy n -> getTyLitDescription n - CastTy ty _ -> getTyDescription ty - CoercionTy co -> pprPanic "getTyDescription" (ppr co) - } - where - fun_result (FunTy _ res) = '>' : fun_result res - fun_result other = getTyDescription other - -getTyLitDescription :: TyLit -> String -getTyLitDescription l = - case l of - NumTyLit n -> show n - StrTyLit n -> show n - --------------------------------------- --- CmmInfoTable-related things --------------------------------------- - -mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable -mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds - = CmmInfoTable { cit_lbl = info_lbl - , cit_rep = sm_rep - , cit_prof = prof - , cit_srt = NoC_SRT } - where - name = dataConName data_con - info_lbl = mkConInfoTableLabel name NoCafRefs - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type - cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con) - - prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo - | otherwise = ProfilingInfo ty_descr val_descr - - ty_descr = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con - val_descr = stringToWord8s $ occNameString $ getOccName data_con - --- We need a black-hole closure info to pass to @allocDynClosure@ when we --- want to allocate the black hole on entry to a CAF. - -cafBlackHoleInfoTable :: CmmInfoTable -cafBlackHoleInfoTable - = CmmInfoTable { cit_lbl = mkCAFBlackHoleInfoTableLabel - , cit_rep = blackHoleRep - , cit_prof = NoProfilingInfo - , cit_srt = NoC_SRT } - -indStaticInfoTable :: CmmInfoTable -indStaticInfoTable - = CmmInfoTable { cit_lbl = mkIndStaticInfoLabel - , cit_rep = indStaticRep - , cit_prof = NoProfilingInfo - , cit_srt = NoC_SRT } - -staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool --- A static closure needs a link field to aid the GC when traversing --- the static closure graph. But it only needs such a field if either --- a) it has an SRT --- b) it's a constructor with one or more pointer fields --- In case (b), the constructor's fields themselves play the role --- of the SRT. -staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep } - | isConRep smrep = not (isStaticNoCafCon smrep) - | otherwise = has_srt -- needsSRT (cit_srt info_tbl) diff --git a/codeGen/StgCmmCon.hs b/codeGen/StgCmmCon.hs deleted file mode 100644 --- a/codeGen/StgCmmCon.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Stg to C--: code generation for constructors --- --- This module provides the support code for StgCmm to deal with with --- constructors on the RHSs of let(rec)s. --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module StgCmmCon ( - cgTopRhsCon, buildDynCon, bindConArgs - ) where - -#include "HsVersions.h" - -import StgSyn -import CoreSyn ( AltCon(..) ) - -import StgCmmMonad -import StgCmmEnv -import StgCmmHeap -import StgCmmLayout -import StgCmmUtils -import StgCmmClosure -import StgCmmProf ( curCCS ) - -import CmmExpr -import CLabel -import MkGraph -import SMRep -import CostCentre -import Module -import DataCon -import DynFlags -import FastString -import Id -import RepType (countConRepArgs) -import Literal -import PrelInfo -import Outputable -import Platform -import Util -import MonadUtils (mapMaybeM) - -import Control.Monad -import Data.Char - - - ---------------------------------------------------------------- --- Top-level constructors ---------------------------------------------------------------- - -cgTopRhsCon :: DynFlags - -> Id -- Name of thing bound to this RHS - -> DataCon -- Id - -> [NonVoid StgArg] -- Args - -> (CgIdInfo, FCode ()) -cgTopRhsCon dflags id con args = - let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) - in (id_info, gen_code) - where - name = idName id - caffy = idCafInfo id -- any stgArgHasCafRefs args - closure_label = mkClosureLabel name caffy - - gen_code = - do { this_mod <- getModuleName - ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ - -- Windows DLLs have a problem with static cross-DLL refs. - MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) ) - ; ASSERT( args `lengthIs` countConRepArgs con ) return () - - -- LAY IT OUT - ; let - (tot_wds, -- #ptr_wds + #nonptr_wds - ptr_wds, -- #ptr_wds - nv_args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args) - - nonptr_wds = tot_wds - ptr_wds - - -- we're not really going to emit an info table, so having - -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields - -- needs to poke around inside it. - info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds - - get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg - ; return lit } - - ; payload <- mapM get_lit nv_args_w_offsets - -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs - -- NB2: all the amodes should be Lits! - -- TODO (osa): Why? - - ; let closure_rep = mkStaticClosureFields - dflags - info_tbl - dontCareCCS -- Because it's static data - caffy -- Has CAF refs - payload - - -- BUILD THE OBJECT - ; emitDataLits closure_label closure_rep - - ; return () } - - ---------------------------------------------------------------- --- Lay out and allocate non-top-level constructors ---------------------------------------------------------------- - -buildDynCon :: Id -- Name of the thing to which this constr will - -- be bound - -> Bool -- is it genuinely bound to that name, or just - -- for profiling? - -> CostCentreStack -- Where to grab cost centre from; - -- current CCS if currentOrSubsumedCCS - -> DataCon -- The data constructor - -> [NonVoid StgArg] -- Its args - -> FCode (CgIdInfo, FCode CmmAGraph) - -- Return details about how to find it and initialization code -buildDynCon binder actually_bound cc con args - = do dflags <- getDynFlags - buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args - - -buildDynCon' :: DynFlags - -> Platform - -> Id -> Bool - -> CostCentreStack - -> DataCon - -> [NonVoid StgArg] - -> FCode (CgIdInfo, FCode CmmAGraph) - -{- We used to pass a boolean indicating whether all the -args were of size zero, so we could use a static -constructor; but I concluded that it just isn't worth it. -Now I/O uses unboxed tuples there just aren't any constructors -with all size-zero args. - -The reason for having a separate argument, rather than looking at -the addr modes of the args is that we may be in a "knot", and -premature looking at the args will cause the compiler to black-hole! --} - - --------- buildDynCon': Nullary constructors -------------- --- First we deal with the case of zero-arity constructors. They --- will probably be unfolded, so we don't expect to see this case much, --- if at all, but it does no harm, and sets the scene for characters. --- --- In the case of zero-arity constructors, or, more accurately, those --- which have exclusively size-zero (VoidRep) args, we generate no code --- at all. - -buildDynCon' dflags _ binder _ _cc con [] - | isNullaryRepDataCon con - = return (litIdInfo dflags binder (mkConLFInfo con) - (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), - return mkNop) - --------- buildDynCon': Charlike and Intlike constructors ----------- -{- The following three paragraphs about @Char@-like and @Int@-like -closures are obsolete, but I don't understand the details well enough -to properly word them, sorry. I've changed the treatment of @Char@s to -be analogous to @Int@s: only a subset is preallocated, because @Char@ -has now 31 bits. Only literals are handled here. -- Qrczak - -Now for @Char@-like closures. We generate an assignment of the -address of the closure to a temporary. It would be possible simply to -generate no code, and record the addressing mode in the environment, -but we'd have to be careful if the argument wasn't a constant --- so -for simplicity we just always assign to a temporary. - -Last special case: @Int@-like closures. We only special-case the -situation in which the argument is a literal in the range -@mIN_INTLIKE@..@mAX_INTLILKE@. NB: for @Char@-like closures we can -work with any old argument, but for @Int@-like ones the argument has -to be a literal. Reason: @Char@ like closures have an argument type -which is guaranteed in range. - -Because of this, we use can safely return an addressing mode. - -We don't support this optimisation when compiling into Windows DLLs yet -because they don't support cross package data references well. --} - -buildDynCon' dflags platform binder _ _cc con [arg] - | maybeIntLikeCon con - , platformOS platform /= OSMinGW32 || not (positionIndependent dflags) - , NonVoid (StgLitArg (MachInt val)) <- arg - , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer! - , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... - = do { let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE") - val_int = fromIntegral val :: Int - offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1) - -- INTLIKE closures consist of a header and one word payload - intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW - ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode - , return mkNop) } - -buildDynCon' dflags platform binder _ _cc con [arg] - | maybeCharLikeCon con - , platformOS platform /= OSMinGW32 || not (positionIndependent dflags) - , NonVoid (StgLitArg (MachChar val)) <- arg - , let val_int = ord val :: Int - , val_int <= mAX_CHARLIKE dflags - , val_int >= mIN_CHARLIKE dflags - = do { let charlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE") - offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1) - -- CHARLIKE closures consist of a header and one word payload - charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW - ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode - , return mkNop) } - --------- buildDynCon': the general case ----------- -buildDynCon' dflags _ binder actually_bound ccs con args - = do { (id_info, reg) <- rhsIdInfo binder lf_info - ; return (id_info, gen_code reg) - } - where - lf_info = mkConLFInfo con - - gen_code reg - = do { let (tot_wds, ptr_wds, args_w_offsets) - = mkVirtConstrOffsets dflags (addArgReps args) - nonptr_wds = tot_wds - ptr_wds - info_tbl = mkDataConInfoTable dflags con False - ptr_wds nonptr_wds - ; let ticky_name | actually_bound = Just binder - | otherwise = Nothing - - ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info - use_cc blame_cc args_w_offsets - ; return (mkRhsInit dflags reg lf_info hp_plus_n) } - where - use_cc -- cost-centre to stick in the object - | isCurrentCCS ccs = curCCS - | otherwise = panic "buildDynCon: non-current CCS not implemented" - - blame_cc = use_cc -- cost-centre on which to blame the alloc (same) - - ---------------------------------------------------------------- --- Binding constructor arguments ---------------------------------------------------------------- - -bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg] --- bindConArgs is called from cgAlt of a case --- (bindConArgs con args) augments the environment with bindings for the --- binders args, assuming that we have just returned from a 'case' which --- found a con -bindConArgs (DataAlt con) base args - = ASSERT(not (isUnboxedTupleCon con)) - do dflags <- getDynFlags - let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args) - tag = tagForCon dflags con - - -- The binding below forces the masking out of the tag bits - -- when accessing the constructor field. - bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode (Maybe LocalReg) - bind_arg (arg@(NonVoid b), offset) - | isDeadBinder b = - -- Do not load unused fields from objects to local variables. - -- (CmmSink can optimize this, but it's cheap and common enough - -- to handle here) - return Nothing - | otherwise = do - emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag - Just <$> bindArgToReg arg - - mapMaybeM bind_arg args_w_offsets - -bindConArgs _other_con _base args - = ASSERT( null args ) return [] diff --git a/codeGen/StgCmmEnv.hs b/codeGen/StgCmmEnv.hs deleted file mode 100644 --- a/codeGen/StgCmmEnv.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Stg to C-- code generation: the binding environment --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ -module StgCmmEnv ( - CgIdInfo, - - litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit, - idInfoToAmode, - - addBindC, addBindsC, - - bindArgsToRegs, bindToReg, rebindToReg, - bindArgToReg, idToReg, - getArgAmode, getNonVoidArgAmodes, - getCgIdInfo, - maybeLetNoEscape, - ) where - -#include "HsVersions.h" - -import TyCon -import StgCmmMonad -import StgCmmUtils -import StgCmmClosure - -import CLabel - -import BlockId -import CmmExpr -import CmmUtils -import DynFlags -import Id -import MkGraph -import Name -import Outputable -import StgSyn -import Type -import TysPrim -import UniqFM -import Util -import VarEnv - -------------------------------------- --- Manipulating CgIdInfo -------------------------------------- - -mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo -mkCgIdInfo id lf expr - = CgIdInfo { cg_id = id, cg_lf = lf - , cg_loc = CmmLoc expr } - -litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo -litIdInfo dflags id lf lit - = CgIdInfo { cg_id = id, cg_lf = lf - , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) } - where - tag = lfDynTag dflags lf - -lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo -lneIdInfo dflags id regs - = CgIdInfo { cg_id = id, cg_lf = lf - , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) } - where - lf = mkLFLetNoEscape - blk_id = mkBlockId (idUnique id) - - -rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg) -rhsIdInfo id lf_info - = do dflags <- getDynFlags - reg <- newTemp (gcWord dflags) - return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) - -mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph -mkRhsInit dflags reg lf_info expr - = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info)) - -idInfoToAmode :: CgIdInfo -> CmmExpr --- Returns a CmmExpr for the *tagged* pointer -idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e -idInfoToAmode cg_info - = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc - -addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr --- A tag adds a byte offset to the pointer -addDynTag dflags expr tag = cmmOffsetB dflags expr tag - -maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) -maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args) -maybeLetNoEscape _other = Nothing - - - ---------------------------------------------------------- --- The binding environment --- --- There are three basic routines, for adding (addBindC), --- modifying(modifyBindC) and looking up (getCgIdInfo) bindings. ---------------------------------------------------------- - -addBindC :: CgIdInfo -> FCode () -addBindC stuff_to_bind = do - binds <- getBinds - setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind - -addBindsC :: [CgIdInfo] -> FCode () -addBindsC new_bindings = do - binds <- getBinds - let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info) - binds - new_bindings - setBinds new_binds - -getCgIdInfo :: Id -> FCode CgIdInfo -getCgIdInfo id - = do { dflags <- getDynFlags - ; local_binds <- getBinds -- Try local bindings first - ; case lookupVarEnv local_binds id of { - Just info -> return info ; - Nothing -> do { - - -- Should be imported; make up a CgIdInfo for it - let name = idName id - ; if isExternalName name then - let ext_lbl - | isUnliftedType (idType id) = - -- An unlifted external Id must refer to a top-level - -- string literal. See Note [Bytes label] in CLabel. - ASSERT( idType id `eqType` addrPrimTy ) - mkBytesLabel name - | otherwise = mkClosureLabel name $ idCafInfo id - in return $ - litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl) - else - cgLookupPanic id -- Bug - }}} - -cgLookupPanic :: Id -> FCode a -cgLookupPanic id - = do local_binds <- getBinds - pprPanic "StgCmmEnv: variable not found" - (vcat [ppr id, - text "local binds for:", - pprUFM local_binds $ \infos -> - vcat [ ppr (cg_id info) | info <- infos ] - ]) - - --------------------- -getArgAmode :: NonVoid StgArg -> FCode CmmExpr -getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var -getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit - -getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] --- NB: Filters out void args, --- so the result list may be shorter than the argument list -getNonVoidArgAmodes [] = return [] -getNonVoidArgAmodes (arg:args) - | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args - | otherwise = do { amode <- getArgAmode (NonVoid arg) - ; amodes <- getNonVoidArgAmodes args - ; return ( amode : amodes ) } - - ------------------------------------------------------------------------- --- Interface functions for binding and re-binding names ------------------------------------------------------------------------- - -bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg --- Bind an Id to a fresh LocalReg -bindToReg nvid@(NonVoid id) lf_info - = do dflags <- getDynFlags - let reg = idToReg dflags nvid - addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) - return reg - -rebindToReg :: NonVoid Id -> FCode LocalReg --- Like bindToReg, but the Id is already in scope, so --- get its LF info from the envt -rebindToReg nvid@(NonVoid id) - = do { info <- getCgIdInfo id - ; bindToReg nvid (cg_lf info) } - -bindArgToReg :: NonVoid Id -> FCode LocalReg -bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) - -bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] -bindArgsToRegs args = mapM bindArgToReg args - -idToReg :: DynFlags -> NonVoid Id -> LocalReg --- Make a register from an Id, typically a function argument, --- free variable, or case binder --- --- We re-use the Unique from the Id to make it easier to see what is going on --- --- By now the Ids should be uniquely named; else one would worry --- about accidental collision -idToReg dflags (NonVoid id) - = LocalReg (idUnique id) - (primRepCmmType dflags (idPrimRep id)) diff --git a/codeGen/StgCmmExpr.hs b/codeGen/StgCmmExpr.hs deleted file mode 100644 --- a/codeGen/StgCmmExpr.hs +++ /dev/null @@ -1,944 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - ------------------------------------------------------------------------------ --- --- Stg to C-- code generation: expressions --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module StgCmmExpr ( cgExpr ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} StgCmmBind ( cgBind ) - -import StgCmmMonad -import StgCmmHeap -import StgCmmEnv -import StgCmmCon -import StgCmmProf (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC) -import StgCmmLayout -import StgCmmPrim -import StgCmmHpc -import StgCmmTicky -import StgCmmUtils -import StgCmmClosure - -import StgSyn - -import MkGraph -import BlockId -import Cmm -import CmmInfo -import CoreSyn -import DataCon -import ForeignCall -import Id -import PrimOp -import TyCon -import Type ( isUnliftedType ) -import RepType ( isVoidTy, countConRepArgs, primRepSlot ) -import CostCentre ( CostCentreStack, currentCCS ) -import Maybes -import Util -import FastString -import Outputable - -import Control.Monad (unless,void) -import Control.Arrow (first) -import Data.Function ( on ) - -import Prelude hiding ((<*>)) - ------------------------------------------------------------------------- --- cgExpr: the main function ------------------------------------------------------------------------- - -cgExpr :: StgExpr -> FCode ReturnKind - -cgExpr (StgApp fun args) = cgIdApp fun args - -{- seq# a s ==> a -} -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -cgExpr (StgOpApp op args ty) = cgOpApp op args ty -cgExpr (StgConApp con args _)= cgConApp con args -cgExpr (StgTick t e) = cgTick t >> cgExpr e -cgExpr (StgLit lit) = do cmm_lit <- cgLit lit - emitReturn [CmmLit cmm_lit] - -cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } -cgExpr (StgLetNoEscape binds expr) = - do { u <- newUnique - ; let join_id = mkBlockId u - ; cgLneBinds join_id binds - ; r <- cgExpr expr - ; emitLabel join_id - ; return r } - -cgExpr (StgCase expr bndr alt_type alts) = - cgCase expr bndr alt_type alts - -cgExpr (StgLam {}) = panic "cgExpr: StgLam" - ------------------------------------------------------------------------- --- Let no escape ------------------------------------------------------------------------- - -{- Generating code for a let-no-escape binding, aka join point is very -very similar to what we do for a case expression. The duality is -between - let-no-escape x = b - in e -and - case e of ... -> b - -That is, the RHS of 'x' (ie 'b') will execute *later*, just like -the alternative of the case; it needs to be compiled in an environment -in which all volatile bindings are forgotten, and the free vars are -bound only to stable things like stack locations.. The 'e' part will -execute *next*, just like the scrutinee of a case. -} - -------------------------- -cgLneBinds :: BlockId -> StgBinding -> FCode () -cgLneBinds join_id (StgNonRec bndr rhs) - = do { local_cc <- saveCurrentCostCentre - -- See Note [Saving the current cost centre] - ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs - ; fcode - ; addBindC info } - -cgLneBinds join_id (StgRec pairs) - = do { local_cc <- saveCurrentCostCentre - ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs - ; let (infos, fcodes) = unzip r - ; addBindsC infos - ; sequence_ fcodes - } - -------------------------- -cgLetNoEscapeRhs - :: BlockId -- join point for successor of let-no-escape - -> Maybe LocalReg -- Saved cost centre - -> Id - -> StgRhs - -> FCode (CgIdInfo, FCode ()) - -cgLetNoEscapeRhs join_id local_cc bndr rhs = - do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs - ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info - ; let code = do { (_, body) <- getCodeScoped rhs_code - ; emitOutOfLine bid (first (<*> mkBranch join_id) body) } - ; return (info, code) - } - -cgLetNoEscapeRhsBody - :: Maybe LocalReg -- Saved cost centre - -> Id - -> StgRhs - -> FCode (CgIdInfo, FCode ()) -cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd args body) - = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body -cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) - = cgLetNoEscapeClosure bndr local_cc cc [] - (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $ - text "StgRhsCon doesn't have type args")) - -- For a constructor RHS we want to generate a single chunk of - -- code which can be jumped to from many places, which will - -- return the constructor. It's easy; just behave as if it - -- was an StgRhsClosure with a ConApp inside! - -------------------------- -cgLetNoEscapeClosure - :: Id -- binder - -> Maybe LocalReg -- Slot for saved current cost centre - -> CostCentreStack -- XXX: *** NOT USED *** why not? - -> [NonVoid Id] -- Args (as in \ args -> body) - -> StgExpr -- Body (as in above) - -> FCode (CgIdInfo, FCode ()) - -cgLetNoEscapeClosure bndr cc_slot _unused_cc args body - = do dflags <- getDynFlags - return ( lneIdInfo dflags bndr args - , code ) - where - code = forkLneBody $ do { - ; withNewTickyCounterLNE (idName bndr) args $ do - ; restoreCurrentCostCentre cc_slot - ; arg_regs <- bindArgsToRegs args - ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } - - ------------------------------------------------------------------------- --- Case expressions ------------------------------------------------------------------------- - -{- Note [Compiling case expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is quite interesting to decide whether to put a heap-check at the -start of each alternative. Of course we certainly have to do so if -the case forces an evaluation, or if there is a primitive op which can -trigger GC. - -A more interesting situation is this (a Plan-B situation) - - !P!; - ...P... - case x# of - 0# -> !Q!; ...Q... - default -> !R!; ...R... - -where !x! indicates a possible heap-check point. The heap checks -in the alternatives *can* be omitted, in which case the topmost -heapcheck will take their worst case into account. - -In favour of omitting !Q!, !R!: - - - *May* save a heap overflow test, - if ...P... allocates anything. - - - We can use relative addressing from a single Hp to - get at all the closures so allocated. - - - No need to save volatile vars etc across heap checks - in !Q!, !R! - -Against omitting !Q!, !R! - - - May put a heap-check into the inner loop. Suppose - the main loop is P -> R -> P -> R... - Q is the loop exit, and only it does allocation. - This only hurts us if P does no allocation. If P allocates, - then there is a heap check in the inner loop anyway. - - - May do more allocation than reqd. This sometimes bites us - badly. For example, nfib (ha!) allocates about 30\% more space if the - worst-casing is done, because many many calls to nfib are leaf calls - which don't need to allocate anything. - - We can un-allocate, but that costs an instruction - -Neither problem hurts us if there is only one alternative. - -Suppose the inner loop is P->R->P->R etc. Then here is -how many heap checks we get in the *inner loop* under various -conditions - - Alloc Heap check in branches (!Q!, !R!)? - P Q R yes no (absorb to !P!) --------------------------------------- - n n n 0 0 - n y n 0 1 - n . y 1 1 - y . y 2 1 - y . n 1 1 - -Best choices: absorb heap checks from Q and R into !P! iff - a) P itself does some allocation -or - b) P does allocation, or there is exactly one alternative - -We adopt (b) because that is more likely to put the heap check at the -entry to a function, when not many things are live. After a bunch of -single-branch cases, we may have lots of things live - -Hence: two basic plans for - - case e of r { alts } - ------- Plan A: the general case --------- - - ...save current cost centre... - - ...code for e, - with sequel (SetLocals r) - - ...restore current cost centre... - ...code for alts... - ...alts do their own heap checks - ------- Plan B: special case when --------- - (i) e does not allocate or call GC - (ii) either upstream code performs allocation - or there is just one alternative - - Then heap allocation in the (single) case branch - is absorbed by the upstream check. - Very common example: primops on unboxed values - - ...code for e, - with sequel (SetLocals r)... - - ...code for alts... - ...no heap check... --} - - - -------------------------------------- -data GcPlan - = GcInAlts -- Put a GC check at the start the case alternatives, - [LocalReg] -- which binds these registers - | NoGcInAlts -- The scrutinee is a primitive value, or a call to a - -- primitive op which does no GC. Absorb the allocation - -- of the case alternative(s) into the upstream check - -------------------------------------- -cgCase :: StgExpr -> Id -> AltType -> [StgAlt] -> FCode ReturnKind - -cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts - | isEnumerationTyCon tycon -- Note [case on bool] - = do { tag_expr <- do_enum_primop op args - - -- If the binder is not dead, convert the tag to a constructor - -- and assign it. - ; unless (isDeadBinder bndr) $ do - { dflags <- getDynFlags - ; tmp_reg <- bindArgToReg (NonVoid bndr) - ; emitAssign (CmmLocal tmp_reg) - (tagToClosure dflags tycon tag_expr) } - - ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly) - (NonVoid bndr) alts - ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1) - ; return AssignedDirectly - } - where - do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr - do_enum_primop TagToEnumOp [arg] -- No code! - = getArgAmode (NonVoid arg) - do_enum_primop primop args - = do dflags <- getDynFlags - tmp <- newTemp (bWord dflags) - cgPrimOp [tmp] primop args - return (CmmReg (CmmLocal tmp)) - -{- -Note [case on bool] -~~~~~~~~~~~~~~~~~~~ -This special case handles code like - - case a <# b of - True -> - False -> - ---> case tagToEnum# (a <$# b) of - True -> .. ; False -> ... - ---> case (a <$# b) of r -> - case tagToEnum# r of - True -> .. ; False -> ... - -If we let the ordinary case code handle it, we'll get something like - - tmp1 = a < b - tmp2 = Bool_closure_tbl[tmp1] - if (tmp2 & 7 != 0) then ... // normal tagged case - -but this junk won't optimise away. What we really want is just an -inline comparison: - - if (a < b) then ... - -So we add a special case to generate - - tmp1 = a < b - if (tmp1 == 0) then ... - -and later optimisations will further improve this. - -Now that #6135 has been resolved it should be possible to remove that -special case. The idea behind this special case and pre-6135 implementation -of Bool-returning primops was that tagToEnum# was added implicitly in the -codegen and then optimized away. Now the call to tagToEnum# is explicit -in the source code, which allows to optimize it away at the earlier stages -of compilation (i.e. at the Core level). - -Note [Scrutinising VoidRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have this STG code: - f = \[s : State# RealWorld] -> - case s of _ -> blah -This is very odd. Why are we scrutinising a state token? But it -can arise with bizarre NOINLINE pragmas (Trac #9964) - crash :: IO () - crash = IO (\s -> let {-# NOINLINE s' #-} - s' = s - in (# s', () #)) - -Now the trouble is that 's' has VoidRep, and we do not bind void -arguments in the environment; they don't live anywhere. See the -calls to nonVoidIds in various places. So we must not look up -'s' in the environment. Instead, just evaluate the RHS! Simple. --} - -cgCase (StgApp v []) _ (PrimAlt _) alts - | isVoidRep (idPrimRep v) -- See Note [Scrutinising VoidRep] - , [(DEFAULT, _, rhs)] <- alts - = cgExpr rhs - -{- Note [Dodgy unsafeCoerce 1] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - case (x :: HValue) |> co of (y :: MutVar# Int) - DEFAULT -> ... -We want to gnerate an assignment - y := x -We want to allow this assignment to be generated in the case when the -types are compatible, because this allows some slightly-dodgy but -occasionally-useful casts to be used, such as in RtClosureInspect -where we cast an HValue to a MutVar# so we can print out the contents -of the MutVar#. If instead we generate code that enters the HValue, -then we'll get a runtime panic, because the HValue really is a -MutVar#. The types are compatible though, so we can just generate an -assignment. --} -cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts - | isUnliftedType (idType v) -- Note [Dodgy unsafeCoerce 1] - || reps_compatible - = -- assignment suffices for unlifted types - do { dflags <- getDynFlags - ; unless reps_compatible $ - pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" - (pp_bndr v $$ pp_bndr bndr) - ; v_info <- getCgIdInfo v - ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr))) - (idInfoToAmode v_info) - ; bindArgToReg (NonVoid bndr) - ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } - where - reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr - -- Must compare SlotTys, not proper PrimReps, because with unboxed sums, - -- the types of the binders are generated from slotPrimRep and might not - -- match. Test case: - -- swap :: (# Int | Int #) -> (# Int | Int #) - -- swap (# x | #) = (# | x #) - -- swap (# | y #) = (# y | #) - - pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id)) - -{- Note [Dodgy unsafeCoerce 2, #3132] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In all other cases of a lifted Id being cast to an unlifted type, the -Id should be bound to bottom, otherwise this is an unsafe use of -unsafeCoerce. We can generate code to enter the Id and assume that -it will never return. Hence, we emit the usual enter/return code, and -because bottom must be untagged, it will be entered. The Sequel is a -type-correct assignment, albeit bogus. The (dead) continuation loops; -it would be better to invoke some kind of panic function here. --} -cgCase scrut@(StgApp v []) _ (PrimAlt _) _ - = do { dflags <- getDynFlags - ; mb_cc <- maybeSaveCostCentre True - ; withSequel (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut) - ; restoreCurrentCostCentre mb_cc - ; emitComment $ mkFastString "should be unreachable code" - ; l <- newBlockId - ; emitLabel l - ; emit (mkBranch l) -- an infinite loop - ; return AssignedDirectly - } - -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -case seq# a s of v - (# s', a' #) -> e - -==> - -case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - -cgCase scrut bndr alt_type alts - = -- the general case - do { dflags <- getDynFlags - ; up_hp_usg <- getVirtHp -- Upstream heap usage - ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts - alt_regs = map (idToReg dflags) ret_bndrs - ; simple_scrut <- isSimpleScrut scrut alt_type - ; let do_gc | not simple_scrut = True - | isSingleton alts = False - | up_hp_usg > 0 = False - | otherwise = True - -- cf Note [Compiling case expressions] - gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts - - ; mb_cc <- maybeSaveCostCentre simple_scrut - - ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -} - ; ret_kind <- withSequel sequel (cgExpr scrut) - ; restoreCurrentCostCentre mb_cc - ; _ <- bindArgsToRegs ret_bndrs - ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts - } - - -{- -Note [scrut sequel] - -The job of the scrutinee is to assign its value(s) to alt_regs. -Additionally, if we plan to do a heap-check in the alternatives (see -Note [Compiling case expressions]), then we *must* retreat Hp to -recover any unused heap before passing control to the sequel. If we -don't do this, then any unused heap will become slop because the heap -check will reset the heap usage. Slop in the heap breaks LDV profiling -(+RTS -hb) which needs to do a linear sweep through the nursery. - - -Note [Inlining out-of-line primops and heap checks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If shouldInlinePrimOp returns True when called from StgCmmExpr for the -purpose of heap check placement, we *must* inline the primop later in -StgCmmPrim. If we don't things will go wrong. --} - ------------------ -maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg) -maybeSaveCostCentre simple_scrut - | simple_scrut = return Nothing - | otherwise = saveCurrentCostCentre - - ------------------ -isSimpleScrut :: StgExpr -> AltType -> FCode Bool --- Simple scrutinee, does not block or allocate; hence safe to amalgamate --- heap usage from alternatives into the stuff before the case --- NB: if you get this wrong, and claim that the expression doesn't allocate --- when it does, you'll deeply mess up allocation -isSimpleScrut (StgOpApp op args _) _ = isSimpleOp op args -isSimpleScrut (StgLit _) _ = return True -- case 1# of { 0# -> ..; ... } -isSimpleScrut (StgApp _ []) (PrimAlt _) = return True -- case x# of { 0# -> ..; ... } -isSimpleScrut _ _ = return False - -isSimpleOp :: StgOp -> [StgArg] -> FCode Bool --- True iff the op cannot block or allocate -isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) -isSimpleOp (StgPrimOp op) stg_args = do - arg_exprs <- getNonVoidArgAmodes stg_args - dflags <- getDynFlags - -- See Note [Inlining out-of-line primops and heap checks] - return $! isJust $ shouldInlinePrimOp dflags op arg_exprs -isSimpleOp (StgPrimCallOp _) _ = return False - ------------------ -chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id] --- These are the binders of a case that are assigned by the evaluation of the --- scrutinee. --- They're non-void, see Note [Post-unarisation invariants] in UnariseStg. -chooseReturnBndrs bndr (PrimAlt _) _alts - = assertNonVoidIds [bndr] - -chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)] - = ASSERT2(n == length ids, ppr n $$ ppr ids $$ ppr _bndr) - assertNonVoidIds ids -- 'bndr' is not assigned! - -chooseReturnBndrs bndr (AlgAlt _) _alts - = assertNonVoidIds [bndr] -- Only 'bndr' is assigned - -chooseReturnBndrs bndr PolyAlt _alts - = assertNonVoidIds [bndr] -- Only 'bndr' is assigned - -chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs" - -- MultiValAlt has only one alternative - -------------------------------------- -cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [StgAlt] - -> FCode ReturnKind --- At this point the result of the case are in the binders -cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)] - = maybeAltHeapCheck gc_plan (cgExpr rhs) - -cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)] - = maybeAltHeapCheck gc_plan (cgExpr rhs) - -- Here bndrs are *already* in scope, so don't rebind them - -cgAlts gc_plan bndr (PrimAlt _) alts - = do { dflags <- getDynFlags - - ; tagged_cmms <- cgAltRhss gc_plan bndr alts - - ; let bndr_reg = CmmLocal (idToReg dflags bndr) - (DEFAULT,deflt) = head tagged_cmms - -- PrimAlts always have a DEFAULT case - -- and it always comes first - - tagged_cmms' = [(lit,code) - | (LitAlt lit, code) <- tagged_cmms] - ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt - ; return AssignedDirectly } - -cgAlts gc_plan bndr (AlgAlt tycon) alts - = do { dflags <- getDynFlags - - ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts - - ; let fam_sz = tyConFamilySize tycon - bndr_reg = CmmLocal (idToReg dflags bndr) - - -- Is the constructor tag in the node reg? - ; if isSmallFamily dflags fam_sz - then do - let -- Yes, bndr_reg has constr. tag in ls bits - tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg) - branches' = [(tag+1,branch) | (tag,branch) <- branches] - emitSwitch tag_expr branches' mb_deflt 1 fam_sz - - else -- No, get tag from info table - do dflags <- getDynFlags - let -- Note that ptr _always_ has tag 1 - -- when the family size is big enough - untagged_ptr = cmmRegOffB bndr_reg (-1) - tag_expr = getConstrTag dflags (untagged_ptr) - emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) - - ; return AssignedDirectly } - -cgAlts _ _ _ _ = panic "cgAlts" - -- UbxTupAlt and PolyAlt have only one alternative - - --- Note [alg-alt heap check] --- --- In an algebraic case with more than one alternative, we will have --- code like --- --- L0: --- x = R1 --- goto L1 --- L1: --- if (x & 7 >= 2) then goto L2 else goto L3 --- L2: --- Hp = Hp + 16 --- if (Hp > HpLim) then goto L4 --- ... --- L4: --- call gc() returns to L5 --- L5: --- x = R1 --- goto L1 - -------------------- -cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt] - -> FCode ( Maybe CmmAGraphScoped - , [(ConTagZ, CmmAGraphScoped)] ) -cgAlgAltRhss gc_plan bndr alts - = do { tagged_cmms <- cgAltRhss gc_plan bndr alts - - ; let { mb_deflt = case tagged_cmms of - ((DEFAULT,rhs) : _) -> Just rhs - _other -> Nothing - -- DEFAULT is always first, if present - - ; branches = [ (dataConTagZ con, cmm) - | (DataAlt con, cmm) <- tagged_cmms ] - } - - ; return (mb_deflt, branches) - } - - -------------------- -cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt] - -> FCode [(AltCon, CmmAGraphScoped)] -cgAltRhss gc_plan bndr alts = do - dflags <- getDynFlags - let - base_reg = idToReg dflags bndr - cg_alt :: StgAlt -> FCode (AltCon, CmmAGraphScoped) - cg_alt (con, bndrs, rhs) - = getCodeScoped $ - maybeAltHeapCheck gc_plan $ - do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs) - -- alt binders are always non-void, - -- see Note [Post-unarisation invariants] in UnariseStg - ; _ <- cgExpr rhs - ; return con } - forkAlts (map cg_alt alts) - -maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a -maybeAltHeapCheck (NoGcInAlts,_) code = code -maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code = - altHeapCheck regs code -maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code = - altHeapCheckReturnsTo regs lret off code - ------------------------------------------------------------------------------ --- Tail calls ------------------------------------------------------------------------------ - -cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind -cgConApp con stg_args - | isUnboxedTupleCon con -- Unboxed tuple: assign and return - = do { arg_exprs <- getNonVoidArgAmodes stg_args - ; tickyUnboxedTupleReturn (length arg_exprs) - ; emitReturn arg_exprs } - - | otherwise -- Boxed constructors; allocate and return - = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args ) - do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False - currentCCS con (assertNonVoidStgArgs stg_args) - -- con args are always non-void, - -- see Note [Post-unarisation invariants] in UnariseStg - -- The first "con" says that the name bound to this - -- closure is "con", which is a bit of a fudge, but - -- it only affects profiling (hence the False) - - ; emit =<< fcode_init - ; tickyReturnNewCon (length stg_args) - ; emitReturn [idInfoToAmode idinfo] } - -cgIdApp :: Id -> [StgArg] -> FCode ReturnKind -cgIdApp fun_id args = do - dflags <- getDynFlags - fun_info <- getCgIdInfo fun_id - self_loop_info <- getSelfLoop - let cg_fun_id = cg_id fun_info - -- NB: use (cg_id fun_info) instead of fun_id, because - -- the former may be externalised for -split-objs. - -- See Note [Externalise when splitting] in StgCmmMonad - - fun_arg = StgVarArg cg_fun_id - fun_name = idName cg_fun_id - fun = idInfoToAmode fun_info - lf_info = cg_lf fun_info - n_args = length args - v_args = length $ filter (isVoidTy . stgArgType) args - node_points dflags = nodeMustPointToIt dflags lf_info - case getCallMethod dflags fun_name cg_fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of - -- A value in WHNF, so we can just return it. - ReturnIt - | isVoidTy (idType fun_id) -> emitReturn [] - | otherwise -> emitReturn [fun] - -- ToDo: does ReturnIt guarantee tagged? - - EnterIt -> ASSERT( null args ) -- Discarding arguments - emitEnter fun - - SlowCall -> do -- A slow function call via the RTS apply routines - { tickySlowCall lf_info args - ; emitComment $ mkFastString "slowCall" - ; slowCall fun args } - - -- A direct function call (possibly with some left-over arguments) - DirectEntry lbl arity -> do - { tickyDirectCall arity args - ; if node_points dflags - then directCall NativeNodeCall lbl arity (fun_arg:args) - else directCall NativeDirectCall lbl arity args } - - -- Let-no-escape call or self-recursive tail-call - JumpToIt blk_id lne_regs -> do - { adjustHpBackwards -- always do this before a tail-call - ; cmm_args <- getNonVoidArgAmodes args - ; emitMultiAssign lne_regs cmm_args - ; emit (mkBranch blk_id) - ; return AssignedDirectly } - --- Note [Self-recursive tail calls] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Self-recursive tail calls can be optimized into a local jump in the same --- way as let-no-escape bindings (see Note [What is a non-escaping let] in --- stgSyn/CoreToStg.hs). Consider this: --- --- foo.info: --- a = R1 // calling convention --- b = R2 --- goto L1 --- L1: ... --- ... --- ... --- L2: R1 = x --- R2 = y --- call foo(R1,R2) --- --- Instead of putting x and y into registers (or other locations required by the --- calling convention) and performing a call we can put them into local --- variables a and b and perform jump to L1: --- --- foo.info: --- a = R1 --- b = R2 --- goto L1 --- L1: ... --- ... --- ... --- L2: a = x --- b = y --- goto L1 --- --- This can be done only when function is calling itself in a tail position --- and only if the call passes number of parameters equal to function's arity. --- Note that this cannot be performed if a function calls itself with a --- continuation. --- --- This in fact implements optimization known as "loopification". It was --- described in "Low-level code optimizations in the Glasgow Haskell Compiler" --- by Krzysztof Woś, though we use different approach. Krzysztof performed his --- optimization at the Cmm level, whereas we perform ours during code generation --- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is --- generated in the first place. --- --- Implementation is spread across a couple of places in the code: --- --- * FCode monad stores additional information in its reader environment --- (cgd_self_loop field). This information tells us which function can --- tail call itself in an optimized way (it is the function currently --- being compiled), what is the label of a loop header (L1 in example above) --- and information about local registers in which we should arguments --- before making a call (this would be a and b in example above). --- --- * Whenever we are compiling a function, we set that information to reflect --- the fact that function currently being compiled can be jumped to, instead --- of called. This is done in closureCodyBody in StgCmmBind. --- --- * We also have to emit a label to which we will be jumping. We make sure --- that the label is placed after a stack check but before the heap --- check. The reason is that making a recursive tail-call does not increase --- the stack so we only need to check once. But it may grow the heap, so we --- have to repeat the heap check in every self-call. This is done in --- do_checks in StgCmmHeap. --- --- * When we begin compilation of another closure we remove the additional --- information from the environment. This is done by forkClosureBody --- in StgCmmMonad. Other functions that duplicate the environment - --- forkLneBody, forkAlts, codeOnly - duplicate that information. In other --- words, we only need to clean the environment of the self-loop information --- when compiling right hand side of a closure (binding). --- --- * When compiling a call (cgIdApp) we use getCallMethod to decide what kind --- of call will be generated. getCallMethod decides to generate a self --- recursive tail call when (a) environment stores information about --- possible self tail-call; (b) that tail call is to a function currently --- being compiled; (c) number of passed non-void arguments is equal to --- function's arity. (d) loopification is turned on via -floopification --- command-line option. --- --- * Command line option to turn loopification on and off is implemented in --- DynFlags. --- --- --- Note [Void arguments in self-recursive tail calls] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- State# tokens can get in the way of the loopification optimization as seen in --- #11372. Consider this: --- --- foo :: [a] --- -> (a -> State# s -> (# State s, Bool #)) --- -> State# s --- -> (# State# s, Maybe a #) --- foo [] f s = (# s, Nothing #) --- foo (x:xs) f s = case f x s of --- (# s', b #) -> case b of --- True -> (# s', Just x #) --- False -> foo xs f s' --- --- We would like to compile the call to foo as a local jump instead of a call --- (see Note [Self-recursive tail calls]). However, the generated function has --- an arity of 2 while we apply it to 3 arguments, one of them being of void --- type. Thus, we mustn't count arguments of void type when checking whether --- we can turn a call into a self-recursive jump. --- - -emitEnter :: CmmExpr -> FCode ReturnKind -emitEnter fun = do - { dflags <- getDynFlags - ; adjustHpBackwards - ; sequel <- getSequel - ; updfr_off <- getUpdFrameOff - ; case sequel of - -- For a return, we have the option of generating a tag-test or - -- not. If the value is tagged, we can return directly, which - -- is quicker than entering the value. This is a code - -- size/speed trade-off: when optimising for speed rather than - -- size we could generate the tag test. - -- - -- Right now, we do what the old codegen did, and omit the tag - -- test, just generating an enter. - Return -> do - { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg - ; emit $ mkJump dflags NativeNodeCall entry - [cmmUntag dflags fun] updfr_off - ; return AssignedDirectly - } - - -- The result will be scrutinised in the sequel. This is where - -- we generate a tag-test to avoid entering the closure if - -- possible. - -- - -- The generated code will be something like this: - -- - -- R1 = fun -- copyout - -- if (fun & 7 != 0) goto Lret else goto Lcall - -- Lcall: - -- call [fun] returns to Lret - -- Lret: - -- fun' = R1 -- copyin - -- ... - -- - -- Note in particular that the label Lret is used as a - -- destination by both the tag-test and the call. This is - -- because Lret will necessarily be a proc-point, and we want to - -- ensure that we generate only one proc-point for this - -- sequence. - -- - -- Furthermore, we tell the caller that we generated a native - -- return continuation by returning (ReturnedTo Lret off), so - -- that the continuation can be reused by the heap-check failure - -- code in the enclosing case expression. - -- - AssignTo res_regs _ -> do - { lret <- newBlockId - ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] - ; lcall <- newBlockId - ; updfr_off <- getUpdFrameOff - ; let area = Young lret - ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area - [fun] updfr_off [] - -- refer to fun via nodeReg after the copyout, to avoid having - -- both live simultaneously; this sometimes enables fun to be - -- inlined in the RHS of the R1 assignment. - ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) - the_call = toCall entry (Just lret) updfr_off off outArgs regs - ; tscope <- getTickScope - ; emit $ - copyout <*> - mkCbranch (cmmIsTagged dflags (CmmReg nodeReg)) - lret lcall Nothing <*> - outOfLine lcall (the_call,tscope) <*> - mkLabel lret tscope <*> - copyin - ; return (ReturnedTo lret off) - } - } - ------------------------------------------------------------------------- --- Ticks ------------------------------------------------------------------------- - --- | Generate Cmm code for a tick. Depending on the type of Tickish, --- this will either generate actual Cmm instrumentation code, or --- simply pass on the annotation as a @CmmTickish@. -cgTick :: Tickish Id -> FCode () -cgTick tick - = do { dflags <- getDynFlags - ; case tick of - ProfNote cc t p -> emitSetCCC cc t p - HpcTick m n -> emit (mkTickBox dflags m n) - SourceNote s n -> emitTick $ SourceNote s n - _other -> return () -- ignore - } diff --git a/codeGen/StgCmmExtCode.hs b/codeGen/StgCmmExtCode.hs deleted file mode 100644 --- a/codeGen/StgCmmExtCode.hs +++ /dev/null @@ -1,251 +0,0 @@ --- | Our extended FCode monad. - --- We add a mapping from names to CmmExpr, to support local variable names in --- the concrete C-- code. The unique supply of the underlying FCode monad --- is used to grab a new unique for each local variable. - --- In C--, a local variable can be declared anywhere within a proc, --- and it scopes from the beginning of the proc to the end. Hence, we have --- to collect declarations as we parse the proc, and feed the environment --- back in circularly (to avoid a two-pass algorithm). - -module StgCmmExtCode ( - CmmParse, unEC, - Named(..), Env, - - loopDecls, - getEnv, - - withName, - getName, - - newLocal, - newLabel, - newBlockId, - newFunctionName, - newImport, - lookupLabel, - lookupName, - - code, - emit, emitLabel, emitAssign, emitStore, - getCode, getCodeR, getCodeScoped, - emitOutOfLine, - withUpdFrameOff, getUpdFrameOff -) - -where - -import qualified StgCmmMonad as F -import StgCmmMonad (FCode, newUnique) - -import Cmm -import CLabel -import MkGraph - -import BlockId -import DynFlags -import FastString -import Module -import UniqFM -import Unique -import UniqSupply - -import Control.Monad (liftM, ap) - --- | The environment contains variable definitions or blockids. -data Named - = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, - -- eg, RtsLabel, ForeignLabel, CmmLabel etc. - - | FunN UnitId -- ^ A function name from this package - | LabelN BlockId -- ^ A blockid of some code or data. - --- | An environment of named things. -type Env = UniqFM Named - --- | Local declarations that are in scope during code generation. -type Decls = [(FastString,Named)] - --- | Does a computation in the FCode monad, with a current environment --- and a list of local declarations. Returns the resulting list of declarations. -newtype CmmParse a - = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) } - -type ExtCode = CmmParse () - -returnExtFC :: a -> CmmParse a -returnExtFC a = EC $ \_ _ s -> return (s, a) - -thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b -thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s' - -instance Functor CmmParse where - fmap = liftM - -instance Applicative CmmParse where - pure = returnExtFC - (<*>) = ap - -instance Monad CmmParse where - (>>=) = thenExtFC - -instance MonadUnique CmmParse where - getUniqueSupplyM = code getUniqueSupplyM - getUniqueM = EC $ \_ _ decls -> do - u <- getUniqueM - return (decls, u) - -instance HasDynFlags CmmParse where - getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags - return (d, dflags)) - - --- | Takes the variable decarations and imports from the monad --- and makes an environment, which is looped back into the computation. --- In this way, we can have embedded declarations that scope over the whole --- procedure, and imports that scope over the entire module. --- Discards the local declaration contained within decl' --- -loopDecls :: CmmParse a -> CmmParse a -loopDecls (EC fcode) = - EC $ \c e globalDecls -> do - (_, a) <- F.fixC $ \ ~(decls, _) -> - fcode c (addListToUFM e decls) globalDecls - return (globalDecls, a) - - --- | Get the current environment from the monad. -getEnv :: CmmParse Env -getEnv = EC $ \_ e s -> return (s, e) - --- | Get the current context name from the monad -getName :: CmmParse String -getName = EC $ \c _ s -> return (s, c) - --- | Set context name for a sub-parse -withName :: String -> CmmParse a -> CmmParse a -withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s - -addDecl :: FastString -> Named -> ExtCode -addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ()) - - --- | Add a new variable to the list of local declarations. --- The CmmExpr says where the value is stored. -addVarDecl :: FastString -> CmmExpr -> ExtCode -addVarDecl var expr = addDecl var (VarN expr) - --- | Add a new label to the list of local declarations. -addLabel :: FastString -> BlockId -> ExtCode -addLabel name block_id = addDecl name (LabelN block_id) - - --- | Create a fresh local variable of a given type. -newLocal - :: CmmType -- ^ data type - -> FastString -- ^ name of variable - -> CmmParse LocalReg -- ^ register holding the value - -newLocal ty name = do - u <- code newUnique - let reg = LocalReg u ty - addVarDecl name (CmmReg (CmmLocal reg)) - return reg - - --- | Allocate a fresh label. -newLabel :: FastString -> CmmParse BlockId -newLabel name = do - u <- code newUnique - addLabel name (mkBlockId u) - return (mkBlockId u) - --- | Add add a local function to the environment. -newFunctionName - :: FastString -- ^ name of the function - -> UnitId -- ^ package of the current module - -> ExtCode - -newFunctionName name pkg = addDecl name (FunN pkg) - - --- | Add an imported foreign label to the list of local declarations. --- If this is done at the start of the module the declaration will scope --- over the whole module. -newImport - :: (FastString, CLabel) - -> CmmParse () - -newImport (name, cmmLabel) - = addVarDecl name (CmmLit (CmmLabel cmmLabel)) - - --- | Lookup the BlockId bound to the label with this name. --- If one hasn't been bound yet, create a fresh one based on the --- Unique of the name. -lookupLabel :: FastString -> CmmParse BlockId -lookupLabel name = do - env <- getEnv - return $ - case lookupUFM env name of - Just (LabelN l) -> l - _other -> mkBlockId (newTagUnique (getUnique name) 'L') - - --- | Lookup the location of a named variable. --- Unknown names are treated as if they had been 'import'ed from the runtime system. --- This saves us a lot of bother in the RTS sources, at the expense of --- deferring some errors to link time. -lookupName :: FastString -> CmmParse CmmExpr -lookupName name = do - env <- getEnv - return $ - case lookupUFM env name of - Just (VarN e) -> e - Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name)) - _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name)) - - --- | Lift an FCode computation into the CmmParse monad -code :: FCode a -> CmmParse a -code fc = EC $ \_ _ s -> do - r <- fc - return (s, r) - -emit :: CmmAGraph -> CmmParse () -emit = code . F.emit - -emitLabel :: BlockId -> CmmParse () -emitLabel = code . F.emitLabel - -emitAssign :: CmmReg -> CmmExpr -> CmmParse () -emitAssign l r = code (F.emitAssign l r) - -emitStore :: CmmExpr -> CmmExpr -> CmmParse () -emitStore l r = code (F.emitStore l r) - -getCode :: CmmParse a -> CmmParse CmmAGraph -getCode (EC ec) = EC $ \c e s -> do - ((s',_), gr) <- F.getCodeR (ec c e s) - return (s', gr) - -getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph) -getCodeR (EC ec) = EC $ \c e s -> do - ((s', r), gr) <- F.getCodeR (ec c e s) - return (s', (r,gr)) - -getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped) -getCodeScoped (EC ec) = EC $ \c e s -> do - ((s', r), gr) <- F.getCodeScoped (ec c e s) - return (s', (r,gr)) - -emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse () -emitOutOfLine l g = code (F.emitOutOfLine l g) - -withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse () -withUpdFrameOff size inner - = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s - -getUpdFrameOff :: CmmParse UpdFrameOffset -getUpdFrameOff = code $ F.getUpdFrameOff diff --git a/codeGen/StgCmmForeign.hs b/codeGen/StgCmmForeign.hs deleted file mode 100644 --- a/codeGen/StgCmmForeign.hs +++ /dev/null @@ -1,553 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Code generation for foreign calls. --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module StgCmmForeign ( - cgForeignCall, - emitPrimCall, emitCCall, - emitForeignCall, -- For CmmParse - emitSaveThreadState, - saveThreadState, - emitLoadThreadState, - loadThreadState, - emitOpenNursery, - emitCloseNursery, - ) where - -#include "HsVersions.h" - -import StgSyn -import StgCmmProf (storeCurCCS, ccsType, curCCS) -import StgCmmEnv -import StgCmmMonad -import StgCmmUtils -import StgCmmClosure -import StgCmmLayout - -import BlockId (newBlockId) -import Cmm -import CmmUtils -import MkGraph -import Type -import RepType -import TysPrim -import CLabel -import SMRep -import ForeignCall -import DynFlags -import Maybes -import Outputable -import UniqSupply -import BasicTypes - -import Control.Monad - -import Prelude hiding( succ, (<*>) ) - ------------------------------------------------------------------------------ --- Code generation for Foreign Calls ------------------------------------------------------------------------------ - --- | emit code for a foreign call, and return the results to the sequel. --- -cgForeignCall :: ForeignCall -- the op - -> [StgArg] -- x,y arguments - -> Type -- result type - -> FCode ReturnKind - -cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty - = do { dflags <- getDynFlags - ; let -- in the stdcall calling convention, the symbol needs @size appended - -- to it, where size is the total number of bytes of arguments. We - -- attach this info to the CLabel here, and the CLabel pretty printer - -- will generate the suffix when the label is printed. - call_size args - | StdCallConv <- cconv = Just (sum (map arg_size args)) - | otherwise = Nothing - - -- ToDo: this might not be correct for 64-bit API - arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg) - (wORD_SIZE dflags) - ; cmm_args <- getFCallArgs stg_args - ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty - ; let ((call_args, arg_hints), cmm_target) - = case target of - StaticTarget _ _ _ False -> - panic "cgForeignCall: unexpected FFI value import" - StaticTarget _ lbl mPkgId True - -> let labelSource - = case mPkgId of - Nothing -> ForeignLabelInThisPackage - Just pkgId -> ForeignLabelInPackage pkgId - size = call_size cmm_args - in ( unzip cmm_args - , CmmLit (CmmLabel - (mkForeignLabel lbl size labelSource IsFunction))) - - DynamicTarget -> case cmm_args of - (fn,_):rest -> (unzip rest, fn) - [] -> panic "cgForeignCall []" - fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn - call_target = ForeignTarget cmm_target fc - - -- we want to emit code for the call, and then emitReturn. - -- However, if the sequel is AssignTo, we shortcut a little - -- and generate a foreign call that assigns the results - -- directly. Otherwise we end up generating a bunch of - -- useless "r = r" assignments, which are not merely annoying: - -- they prevent the common block elimination from working correctly - -- in the case of a safe foreign call. - -- See Note [safe foreign call convention] - -- - ; sequel <- getSequel - ; case sequel of - AssignTo assign_to_these _ -> - emitForeignCall safety assign_to_these call_target call_args - - _something_else -> - do { _ <- emitForeignCall safety res_regs call_target call_args - ; emitReturn (map (CmmReg . CmmLocal) res_regs) - } - } - -{- Note [safe foreign call convention] - -The simple thing to do for a safe foreign call would be the same as an -unsafe one: just - - emitForeignCall ... - emitReturn ... - -but consider what happens in this case - - case foo x y z of - (# s, r #) -> ... - -The sequel is AssignTo [r]. The call to newUnboxedTupleRegs picks [r] -as the result reg, and we generate - - r = foo(x,y,z) returns to L1 -- emitForeignCall - L1: - r = r -- emitReturn - goto L2 -L2: - ... - -Now L1 is a proc point (by definition, it is the continuation of the -safe foreign call). If L2 does a heap check, then L2 will also be a -proc point. - -Furthermore, the stack layout algorithm has to arrange to save r -somewhere between the call and the jump to L1, which is annoying: we -would have to treat r differently from the other live variables, which -have to be saved *before* the call. - -So we adopt a special convention for safe foreign calls: the results -are copied out according to the NativeReturn convention by the call, -and the continuation of the call should copyIn the results. (The -copyOut code is actually inserted when the safe foreign call is -lowered later). The result regs attached to the safe foreign call are -only used temporarily to hold the results before they are copied out. - -We will now generate this: - - r = foo(x,y,z) returns to L1 - L1: - r = R1 -- copyIn, inserted by mkSafeCall - goto L2 - L2: - ... r ... - -And when the safe foreign call is lowered later (see Note [lower safe -foreign calls]) we get this: - - suspendThread() - r = foo(x,y,z) - resumeThread() - R1 = r -- copyOut, inserted by lowerSafeForeignCall - jump L1 - L1: - r = R1 -- copyIn, inserted by mkSafeCall - goto L2 - L2: - ... r ... - -Now consider what happens if L2 does a heap check: the Adams -optimisation kicks in and commons up L1 with the heap-check -continuation, resulting in just one proc point instead of two. Yay! --} - - -emitCCall :: [(CmmFormal,ForeignHint)] - -> CmmExpr - -> [(CmmActual,ForeignHint)] - -> FCode () -emitCCall hinted_results fn hinted_args - = void $ emitForeignCall PlayRisky results target args - where - (args, arg_hints) = unzip hinted_args - (results, result_hints) = unzip hinted_results - target = ForeignTarget fn fc - fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn - - -emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () -emitPrimCall res op args - = void $ emitForeignCall PlayRisky res (PrimTarget op) args - --- alternative entry point, used by CmmParse -emitForeignCall - :: Safety - -> [CmmFormal] -- where to put the results - -> ForeignTarget -- the op - -> [CmmActual] -- arguments - -> FCode ReturnKind -emitForeignCall safety results target args - | not (playSafe safety) = do - dflags <- getDynFlags - let (caller_save, caller_load) = callerSaveVolatileRegs dflags - emit caller_save - target' <- load_target_into_temp target - args' <- mapM maybe_assign_temp args - emit $ mkUnsafeCall target' results args' - emit caller_load - return AssignedDirectly - - | otherwise = do - dflags <- getDynFlags - updfr_off <- getUpdFrameOff - target' <- load_target_into_temp target - args' <- mapM maybe_assign_temp args - k <- newBlockId - let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results [] - -- see Note [safe foreign call convention] - tscope <- getTickScope - emit $ - ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) - (CmmLit (CmmBlock k)) - <*> mkLast (CmmForeignCall { tgt = target' - , res = results - , args = args' - , succ = k - , ret_args = off - , ret_off = updfr_off - , intrbl = playInterruptible safety }) - <*> mkLabel k tscope - <*> copyout - ) - return (ReturnedTo k off) - -load_target_into_temp :: ForeignTarget -> FCode ForeignTarget -load_target_into_temp (ForeignTarget expr conv) = do - tmp <- maybe_assign_temp expr - return (ForeignTarget tmp conv) -load_target_into_temp other_target@(PrimTarget _) = - return other_target - --- What we want to do here is create a new temporary for the foreign --- call argument if it is not safe to use the expression directly, --- because the expression mentions caller-saves GlobalRegs (see --- Note [Register Parameter Passing]). --- --- However, we can't pattern-match on the expression here, because --- this is used in a loop by CmmParse, and testing the expression --- results in a black hole. So we always create a temporary, and rely --- on CmmSink to clean it up later. (Yuck, ToDo). The generated code --- ends up being the same, at least for the RTS .cmm code. --- -maybe_assign_temp :: CmmExpr -> FCode CmmExpr -maybe_assign_temp e = do - dflags <- getDynFlags - reg <- newTemp (cmmExprType dflags e) - emitAssign (CmmLocal reg) e - return (CmmReg (CmmLocal reg)) - --- ----------------------------------------------------------------------------- --- Save/restore the thread state in the TSO - --- This stuff can't be done in suspendThread/resumeThread, because it --- refers to global registers which aren't available in the C world. - -emitSaveThreadState :: FCode () -emitSaveThreadState = do - dflags <- getDynFlags - code <- saveThreadState dflags - emit code - --- | Produce code to save the current thread state to @CurrentTSO@ -saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph -saveThreadState dflags = do - tso <- newTemp (gcWord dflags) - close_nursery <- closeNursery dflags tso - pure $ catAGraphs [ - -- tso = CurrentTSO; - mkAssign (CmmLocal tso) stgCurrentTSO, - -- tso->stackobj->sp = Sp; - mkStore (cmmOffset dflags - (CmmLoad (cmmOffset dflags - (CmmReg (CmmLocal tso)) - (tso_stackobj dflags)) - (bWord dflags)) - (stack_SP dflags)) - stgSp, - close_nursery, - -- and save the current cost centre stack in the TSO when profiling: - if gopt Opt_SccProfilingOn dflags then - mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) curCCS - else mkNop - ] - -emitCloseNursery :: FCode () -emitCloseNursery = do - dflags <- getDynFlags - tso <- newTemp (bWord dflags) - code <- closeNursery dflags tso - emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> code - -{- | -@closeNursery dflags tso@ produces code to close the nursery. -A local register holding the value of @CurrentTSO@ is expected for -efficiency. - -Closing the nursery corresponds to the following code: - -@ - tso = CurrentTSO; - cn = CurrentNuresry; - - // Update the allocation limit for the current thread. We don't - // check to see whether it has overflowed at this point, that check is - // made when we run out of space in the current heap block (stg_gc_noregs) - // and in the scheduler when context switching (schedulePostRunThread). - tso->alloc_limit -= Hp + WDS(1) - cn->start; - - // Set cn->free to the next unoccupied word in the block - cn->free = Hp + WDS(1); -@ --} -closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph -closeNursery df tso = do - let tsoreg = CmmLocal tso - cnreg <- CmmLocal <$> newTemp (bWord df) - pure $ catAGraphs [ - mkAssign cnreg stgCurrentNursery, - - -- CurrentNursery->free = Hp+1; - mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df stgHp 1), - - let alloc = - CmmMachOp (mo_wordSub df) - [ cmmOffsetW df stgHp 1 - , CmmLoad (nursery_bdescr_start df cnreg) (bWord df) - ] - - alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df) - in - - -- tso->alloc_limit += alloc - mkStore alloc_limit (CmmMachOp (MO_Sub W64) - [ CmmLoad alloc_limit b64 - , CmmMachOp (mo_WordTo64 df) [alloc] ]) - ] - -emitLoadThreadState :: FCode () -emitLoadThreadState = do - dflags <- getDynFlags - code <- loadThreadState dflags - emit code - --- | Produce code to load the current thread state from @CurrentTSO@ -loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph -loadThreadState dflags = do - tso <- newTemp (gcWord dflags) - stack <- newTemp (gcWord dflags) - open_nursery <- openNursery dflags tso - pure $ catAGraphs [ - -- tso = CurrentTSO; - mkAssign (CmmLocal tso) stgCurrentTSO, - -- stack = tso->stackobj; - mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), - -- Sp = stack->sp; - mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)), - -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) - (rESERVED_STACK_WORDS dflags)), - -- HpAlloc = 0; - -- HpAlloc is assumed to be set to non-zero only by a failed - -- a heap check, see HeapStackCheck.cmm:GC_GENERIC - mkAssign hpAlloc (zeroExpr dflags), - open_nursery, - -- and load the current cost centre stack from the TSO when profiling: - if gopt Opt_SccProfilingOn dflags - then storeCurCCS - (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) - (tso_CCCS dflags)) (ccsType dflags)) - else mkNop - ] - - -emitOpenNursery :: FCode () -emitOpenNursery = do - dflags <- getDynFlags - tso <- newTemp (bWord dflags) - code <- openNursery dflags tso - emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> code - -{- | -@openNursery dflags tso@ produces code to open the nursery. A local register -holding the value of @CurrentTSO@ is expected for efficiency. - -Opening the nursery corresponds to the following code: - -@ - tso = CurrentTSO; - cn = CurrentNursery; - bdfree = CurrentNuresry->free; - bdstart = CurrentNuresry->start; - - // We *add* the currently occupied portion of the nursery block to - // the allocation limit, because we will subtract it again in - // closeNursery. - tso->alloc_limit += bdfree - bdstart; - - // Set Hp to the last occupied word of the heap block. Why not the - // next unocupied word? Doing it this way means that we get to use - // an offset of zero more often, which might lead to slightly smaller - // code on some architectures. - Hp = bdfree - WDS(1); - - // Set HpLim to the end of the current nursery block (note that this block - // might be a block group, consisting of several adjacent blocks. - HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1; -@ --} -openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph -openNursery df tso = do - let tsoreg = CmmLocal tso - cnreg <- CmmLocal <$> newTemp (bWord df) - bdfreereg <- CmmLocal <$> newTemp (bWord df) - bdstartreg <- CmmLocal <$> newTemp (bWord df) - - -- These assignments are carefully ordered to reduce register - -- pressure and generate not completely awful code on x86. To see - -- what code we generate, look at the assembly for - -- stg_returnToStackTop in rts/StgStartup.cmm. - pure $ catAGraphs [ - mkAssign cnreg stgCurrentNursery, - mkAssign bdfreereg (CmmLoad (nursery_bdescr_free df cnreg) (bWord df)), - - -- Hp = CurrentNursery->free - 1; - mkAssign hp (cmmOffsetW df (CmmReg bdfreereg) (-1)), - - mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)), - - -- HpLim = CurrentNursery->start + - -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; - mkAssign hpLim - (cmmOffsetExpr df - (CmmReg bdstartreg) - (cmmOffset df - (CmmMachOp (mo_wordMul df) [ - CmmMachOp (MO_SS_Conv W32 (wordWidth df)) - [CmmLoad (nursery_bdescr_blocks df cnreg) b32], - mkIntExpr df (bLOCK_SIZE df) - ]) - (-1) - ) - ), - - -- alloc = bd->free - bd->start - let alloc = - CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg] - - alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df) - in - - -- tso->alloc_limit += alloc - mkStore alloc_limit (CmmMachOp (MO_Add W64) - [ CmmLoad alloc_limit b64 - , CmmMachOp (mo_WordTo64 df) [alloc] ]) - - ] - -nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks - :: DynFlags -> CmmReg -> CmmExpr -nursery_bdescr_free dflags cn = - cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags) -nursery_bdescr_start dflags cn = - cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags) -nursery_bdescr_blocks dflags cn = - cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags) - -tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff -tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) -tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags) -tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) -stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) -stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) - - -closureField :: DynFlags -> ByteOff -> ByteOff -closureField dflags off = off + fixedHdrSize dflags - -stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr -stgSp = CmmReg sp -stgHp = CmmReg hp -stgCurrentTSO = CmmReg currentTSO -stgCurrentNursery = CmmReg currentNursery - -sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg -sp = CmmGlobal Sp -spLim = CmmGlobal SpLim -hp = CmmGlobal Hp -hpLim = CmmGlobal HpLim -currentTSO = CmmGlobal CurrentTSO -currentNursery = CmmGlobal CurrentNursery -hpAlloc = CmmGlobal HpAlloc - --- ----------------------------------------------------------------------------- --- For certain types passed to foreign calls, we adjust the actual --- value passed to the call. For ByteArray#/Array# we pass the --- address of the actual array, not the address of the heap object. - -getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)] --- (a) Drop void args --- (b) Add foreign-call shim code --- It's (b) that makes this differ from getNonVoidArgAmodes - -getFCallArgs args - = do { mb_cmms <- mapM get args - ; return (catMaybes mb_cmms) } - where - get arg | null arg_reps - = return Nothing - | otherwise - = do { cmm <- getArgAmode (NonVoid arg) - ; dflags <- getDynFlags - ; return (Just (add_shim dflags arg_ty cmm, hint)) } - where - arg_ty = stgArgType arg - arg_reps = typePrimRep arg_ty - hint = typeForeignHint arg_ty - -add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr -add_shim dflags arg_ty expr - | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon - = cmmOffsetB dflags expr (arrPtrsHdrSize dflags) - - | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon - = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags) - - | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon - = cmmOffsetB dflags expr (arrWordsHdrSize dflags) - - | otherwise = expr - where - tycon = tyConAppTyCon (unwrapType arg_ty) - -- should be a tycon app, since this is a foreign call diff --git a/codeGen/StgCmmHeap.hs b/codeGen/StgCmmHeap.hs deleted file mode 100644 --- a/codeGen/StgCmmHeap.hs +++ /dev/null @@ -1,698 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Stg to C--: heap management functions --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module StgCmmHeap ( - getVirtHp, setVirtHp, setRealHp, - getHpRelOffset, - - entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo, - heapStackCheckGen, - entryHeapCheck', - - mkStaticClosureFields, mkStaticClosure, - - allocDynClosure, allocDynClosureCmm, allocHeapClosure, - emitSetDynHdr - ) where - -#include "HsVersions.h" - -import StgSyn -import CLabel -import StgCmmLayout -import StgCmmUtils -import StgCmmMonad -import StgCmmProf (profDynAlloc, dynProfHdr, staticProfHdr) -import StgCmmTicky -import StgCmmClosure -import StgCmmEnv - -import MkGraph - -import Hoopl -import SMRep -import BlockId -import Cmm -import CmmUtils -import CostCentre -import IdInfo( CafInfo(..), mayHaveCafRefs ) -import Id ( Id ) -import Module -import DynFlags -import FastString( mkFastString, fsLit ) -import Panic( sorry ) - -import Prelude hiding ((<*>)) - -import Control.Monad (when) -import Data.Maybe (isJust) - ------------------------------------------------------------ --- Initialise dynamic heap objects ------------------------------------------------------------ - -allocDynClosure - :: Maybe Id - -> CmmInfoTable - -> LambdaFormInfo - -> CmmExpr -- Cost Centre to stick in the object - -> CmmExpr -- Cost Centre to blame for this alloc - -- (usually the same; sometimes "OVERHEAD") - - -> [(NonVoid StgArg, VirtualHpOffset)] -- Offsets from start of object - -- ie Info ptr has offset zero. - -- No void args in here - -> FCode CmmExpr -- returns Hp+n - -allocDynClosureCmm - :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr - -> [(CmmExpr, ByteOff)] - -> FCode CmmExpr -- returns Hp+n - --- allocDynClosure allocates the thing in the heap, --- and modifies the virtual Hp to account for this. --- The second return value is the graph that sets the value of the --- returned LocalReg, which should point to the closure after executing --- the graph. - --- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is --- only valid until Hp is changed. The caller should assign the --- result to a LocalReg if it is required to remain live. --- --- The reason we don't assign it to a LocalReg here is that the caller --- is often about to call regIdInfo, which immediately assigns the --- result of allocDynClosure to a new temp in order to add the tag. --- So by not generating a LocalReg here we avoid a common source of --- new temporaries and save some compile time. This can be quite --- significant - see test T4801. - - -allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do - let (args, offsets) = unzip args_w_offsets - cmm_args <- mapM getArgAmode args -- No void args - allocDynClosureCmm mb_id info_tbl lf_info - use_cc _blame_cc (zip cmm_args offsets) - - -allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do - -- SAY WHAT WE ARE ABOUT TO DO - let rep = cit_rep info_tbl - tickyDynAlloc mb_id rep lf_info - let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl)) - allocHeapClosure rep info_ptr use_cc amodes_w_offsets - - --- | Low-level heap object allocation. -allocHeapClosure - :: SMRep -- ^ representation of the object - -> CmmExpr -- ^ info pointer - -> CmmExpr -- ^ cost centre - -> [(CmmExpr,ByteOff)] -- ^ payload - -> FCode CmmExpr -- ^ returns the address of the object -allocHeapClosure rep info_ptr use_cc payload = do - profDynAlloc rep use_cc - - virt_hp <- getVirtHp - - -- Find the offset of the info-ptr word - let info_offset = virt_hp + 1 - -- info_offset is the VirtualHpOffset of the first - -- word of the new object - -- Remember, virtHp points to last allocated word, - -- ie 1 *before* the info-ptr word of new object. - - base <- getHpRelOffset info_offset - emitComment $ mkFastString "allocHeapClosure" - emitSetDynHdr base info_ptr use_cc - - -- Fill in the fields - hpStore base payload - - -- Bump the virtual heap pointer - dflags <- getDynFlags - setVirtHp (virt_hp + heapClosureSizeW dflags rep) - - return base - - -emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () -emitSetDynHdr base info_ptr ccs - = do dflags <- getDynFlags - hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..]) - where - header :: DynFlags -> [CmmExpr] - header dflags = [info_ptr] ++ dynProfHdr dflags ccs - -- ToDof: Parallel stuff - -- No ticky header - --- Store the item (expr,off) in base[off] -hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode () -hpStore base vals = do - dflags <- getDynFlags - sequence_ $ - [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ] - ------------------------------------------------------------ --- Layout of static closures ------------------------------------------------------------ - --- Make a static closure, adding on any extra padding needed for CAFs, --- and adding a static link field if necessary. - -mkStaticClosureFields - :: DynFlags - -> CmmInfoTable - -> CostCentreStack - -> CafInfo - -> [CmmLit] -- Payload - -> [CmmLit] -- The full closure -mkStaticClosureFields dflags info_tbl ccs caf_refs payload - = mkStaticClosure dflags info_lbl ccs payload padding - static_link_field saved_info_field - where - info_lbl = cit_lbl info_tbl - - -- CAFs must have consistent layout, regardless of whether they - -- are actually updatable or not. The layout of a CAF is: - -- - -- 3 saved_info - -- 2 static_link - -- 1 indirectee - -- 0 info ptr - -- - -- the static_link and saved_info fields must always be in the - -- same place. So we use isThunkRep rather than closureUpdReqd - -- here: - - is_caf = isThunkRep (cit_rep info_tbl) - - padding - | is_caf && null payload = [mkIntCLit dflags 0] - | otherwise = [] - - static_link_field - | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl - = [static_link_value] - | otherwise - = [] - - saved_info_field - | is_caf = [mkIntCLit dflags 0] - | otherwise = [] - - -- For a static constructor which has NoCafRefs, we set the - -- static link field to a non-zero value so the garbage - -- collector will ignore it. - static_link_value - | mayHaveCafRefs caf_refs = mkIntCLit dflags 0 - | otherwise = mkIntCLit dflags 3 -- No CAF refs - -- See Note [STATIC_LINK fields] - -- in rts/sm/Storage.h - -mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] - -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field - = [CmmLabel info_lbl] - ++ staticProfHdr dflags ccs - ++ concatMap (padLitToWord dflags) payload - ++ padding - ++ static_link_field - ++ saved_info_field - --- JD: Simon had ellided this padding, but without it the C back end asserts --- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary? -padLitToWord :: DynFlags -> CmmLit -> [CmmLit] -padLitToWord dflags lit = lit : padding pad_length - where width = typeWidth (cmmLitType dflags lit) - pad_length = wORD_SIZE dflags - widthInBytes width :: Int - - padding n | n <= 0 = [] - | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) - | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2) - | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4) - | otherwise = CmmInt 0 W64 : padding (n-8) - ------------------------------------------------------------ --- Heap overflow checking ------------------------------------------------------------ - -{- Note [Heap checks] - ~~~~~~~~~~~~~~~~~~ -Heap checks come in various forms. We provide the following entry -points to the runtime system, all of which use the native C-- entry -convention. - - * gc() performs garbage collection and returns - nothing to its caller - - * A series of canned entry points like - r = gc_1p( r ) - where r is a pointer. This performs gc, and - then returns its argument r to its caller. - - * A series of canned entry points like - gcfun_2p( f, x, y ) - where f is a function closure of arity 2 - This performs garbage collection, keeping alive the - three argument ptrs, and then tail-calls f(x,y) - -These are used in the following circumstances - -* entryHeapCheck: Function entry - (a) With a canned GC entry sequence - f( f_clo, x:ptr, y:ptr ) { - Hp = Hp+8 - if Hp > HpLim goto L - ... - L: HpAlloc = 8 - jump gcfun_2p( f_clo, x, y ) } - Note the tail call to the garbage collector; - it should do no register shuffling - - (b) No canned sequence - f( f_clo, x:ptr, y:ptr, ...etc... ) { - T: Hp = Hp+8 - if Hp > HpLim goto L - ... - L: HpAlloc = 8 - call gc() -- Needs an info table - goto T } - -* altHeapCheck: Immediately following an eval - Started as - case f x y of r { (p,q) -> rhs } - (a) With a canned sequence for the results of f - (which is the very common case since - all boxed cases return just one pointer - ... - r = f( x, y ) - K: -- K needs an info table - Hp = Hp+8 - if Hp > HpLim goto L - ...code for rhs... - - L: r = gc_1p( r ) - goto K } - - Here, the info table needed by the call - to gc_1p should be the *same* as the - one for the call to f; the C-- optimiser - spots this sharing opportunity) - - (b) No canned sequence for results of f - Note second info table - ... - (r1,r2,r3) = call f( x, y ) - K: - Hp = Hp+8 - if Hp > HpLim goto L - ...code for rhs... - - L: call gc() -- Extra info table here - goto K - -* generalHeapCheck: Anywhere else - e.g. entry to thunk - case branch *not* following eval, - or let-no-escape - Exactly the same as the previous case: - - K: -- K needs an info table - Hp = Hp+8 - if Hp > HpLim goto L - ... - - L: call gc() - goto K --} - --------------------------------------------------------------- --- A heap/stack check at a function or thunk entry point. - -entryHeapCheck :: ClosureInfo - -> Maybe LocalReg -- Function (closure environment) - -> Int -- Arity -- not same as len args b/c of voids - -> [LocalReg] -- Non-void args (empty for thunk) - -> FCode () - -> FCode () - -entryHeapCheck cl_info nodeSet arity args code - = entryHeapCheck' is_fastf node arity args code - where - node = case nodeSet of - Just r -> CmmReg (CmmLocal r) - Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info) - - is_fastf = case closureFunInfo cl_info of - Just (_, ArgGen _) -> False - _otherwise -> True - --- | lower-level version for CmmParse -entryHeapCheck' :: Bool -- is a known function pattern - -> CmmExpr -- expression for the closure pointer - -> Int -- Arity -- not same as len args b/c of voids - -> [LocalReg] -- Non-void args (empty for thunk) - -> FCode () - -> FCode () -entryHeapCheck' is_fastf node arity args code - = do dflags <- getDynFlags - let is_thunk = arity == 0 - - args' = map (CmmReg . CmmLocal) args - stg_gc_fun = CmmReg (CmmGlobal GCFun) - stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) - - {- Thunks: jump stg_gc_enter_1 - - Function (fast): call (NativeNode) stg_gc_fun(fun, args) - - Function (slow): call (slow) stg_gc_fun(fun, args) - -} - gc_call upd - | is_thunk - = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd - - | is_fastf - = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd - - | otherwise - = mkJump dflags Slow stg_gc_fun (node : args') upd - - updfr_sz <- getUpdFrameOff - - loop_id <- newBlockId - emitLabel loop_id - heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code - --- ------------------------------------------------------------ --- A heap/stack check in a case alternative - - --- If there are multiple alts and we need to GC, but don't have a --- continuation already (the scrut was simple), then we should --- pre-generate the continuation. (if there are multiple alts it is --- always a canned GC point). - --- altHeapCheck: --- If we have a return continuation, --- then if it is a canned GC pattern, --- then we do mkJumpReturnsTo --- else we do a normal call to stg_gc_noregs --- else if it is a canned GC pattern, --- then generate the continuation and do mkCallReturnsTo --- else we do a normal call to stg_gc_noregs - -altHeapCheck :: [LocalReg] -> FCode a -> FCode a -altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code - -altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a -altOrNoEscapeHeapCheck checkYield regs code = do - dflags <- getDynFlags - case cannedGCEntryPoint dflags regs of - Nothing -> genericGC checkYield code - Just gc -> do - lret <- newBlockId - let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] - lcont <- newBlockId - tscope <- getTickScope - emitOutOfLine lret (copyin <*> mkBranch lcont, tscope) - emitLabel lcont - cannedGCReturnsTo checkYield False gc regs lret off code - -altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a -altHeapCheckReturnsTo regs lret off code - = do dflags <- getDynFlags - case cannedGCEntryPoint dflags regs of - Nothing -> genericGC False code - Just gc -> cannedGCReturnsTo False True gc regs lret off code - --- noEscapeHeapCheck is implemented identically to altHeapCheck (which --- is more efficient), but cannot be optimized away in the non-allocating --- case because it may occur in a loop -noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a -noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code - -cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff - -> FCode a - -> FCode a -cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code - = do dflags <- getDynFlags - updfr_sz <- getUpdFrameOff - heapCheck False checkYield (gc_call dflags gc updfr_sz) code - where - reg_exprs = map (CmmReg . CmmLocal) regs - -- Note [stg_gc arguments] - - -- NB. we use the NativeReturn convention for passing arguments - -- to the canned heap-check routines, because we are in a case - -- alternative and hence the [LocalReg] was passed to us in the - -- NativeReturn convention. - gc_call dflags label sp - | cont_on_stack - = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp - | otherwise - = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp [] - -genericGC :: Bool -> FCode a -> FCode a -genericGC checkYield code - = do updfr_sz <- getUpdFrameOff - lretry <- newBlockId - emitLabel lretry - call <- mkCall generic_gc (GC, GC) [] [] updfr_sz [] - heapCheck False checkYield (call <*> mkBranch lretry) code - -cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr -cannedGCEntryPoint dflags regs - = case map localRegType regs of - [] -> Just (mkGcLabel "stg_gc_noregs") - [ty] - | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1") - | isFloatType ty -> case width of - W32 -> Just (mkGcLabel "stg_gc_f1") - W64 -> Just (mkGcLabel "stg_gc_d1") - _ -> Nothing - - | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1") - | width == W64 -> Just (mkGcLabel "stg_gc_l1") - | otherwise -> Nothing - where - width = typeWidth ty - [ty1,ty2] - | isGcPtrType ty1 - && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp") - [ty1,ty2,ty3] - | isGcPtrType ty1 - && isGcPtrType ty2 - && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp") - [ty1,ty2,ty3,ty4] - | isGcPtrType ty1 - && isGcPtrType ty2 - && isGcPtrType ty3 - && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp") - _otherwise -> Nothing - --- Note [stg_gc arguments] --- It might seem that we could avoid passing the arguments to the --- stg_gc function, because they are already in the right registers. --- While this is usually the case, it isn't always. Sometimes the --- code generator has cleverly avoided the eval in a case, e.g. in --- ffi/should_run/4221.hs we found --- --- case a_r1mb of z --- FunPtr x y -> ... --- --- where a_r1mb is bound a top-level constructor, and is known to be --- evaluated. The codegen just assigns x, y and z, and continues; --- R1 is never assigned. --- --- So we'll have to rely on optimisations to eliminatethese --- assignments where possible. - - --- | The generic GC procedure; no params, no results -generic_gc :: CmmExpr -generic_gc = mkGcLabel "stg_gc_noregs" - --- | Create a CLabel for calling a garbage collector entry point -mkGcLabel :: String -> CmmExpr -mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s))) - -------------------------------- -heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a -heapCheck checkStack checkYield do_gc code - = getHeapUsage $ \ hpHw -> - -- Emit heap checks, but be sure to do it lazily so - -- that the conditionals on hpHw don't cause a black hole - do { dflags <- getDynFlags - ; let mb_alloc_bytes - | hpHw > mBLOCK_SIZE = sorry $ unlines - [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.", - "", - "This is currently not possible due to a limitation of GHC's code generator.", - "See http://hackage.haskell.org/trac/ghc/ticket/4505 for details.", - "Suggestion: read data from a file instead of having large static data", - "structures in code."] - | hpHw > 0 = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags))) - | otherwise = Nothing - where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags - stk_hwm | checkStack = Just (CmmLit CmmHighStackMark) - | otherwise = Nothing - ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc - ; tickyAllocHeap True hpHw - ; setRealHp hpHw - ; code } - -heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode () -heapStackCheckGen stk_hwm mb_bytes - = do updfr_sz <- getUpdFrameOff - lretry <- newBlockId - emitLabel lretry - call <- mkCall generic_gc (GC, GC) [] [] updfr_sz [] - do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry) - --- Note [Single stack check] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- When compiling a function we can determine how much stack space it --- will use. We therefore need to perform only a single stack check at --- the beginning of a function to see if we have enough stack space. --- --- The check boils down to comparing Sp-N with SpLim, where N is the --- amount of stack space needed (see Note [Stack usage] below). *BUT* --- at this stage of the pipeline we are not supposed to refer to Sp --- itself, because the stack is not yet manifest, so we don't quite --- know where Sp pointing. - --- So instead of referring directly to Sp - as we used to do in the --- past - the code generator uses (old + 0) in the stack check. That --- is the address of the first word of the old area, so if we add N --- we'll get the address of highest used word. --- --- This makes the check robust. For example, while we need to perform --- only one stack check for each function, we could in theory place --- more stack checks later in the function. They would be redundant, --- but not incorrect (in a sense that they should not change program --- behaviour). We need to make sure however that a stack check --- inserted after incrementing the stack pointer checks for a --- respectively smaller stack space. This would not be the case if the --- code generator produced direct references to Sp. By referencing --- (old + 0) we make sure that we always check for a correct amount of --- stack: when converting (old + 0) to Sp the stack layout phase takes --- into account changes already made to stack pointer. The idea for --- this change came from observations made while debugging #8275. - --- Note [Stack usage] --- ~~~~~~~~~~~~~~~~~~ --- At the moment we convert from STG to Cmm we don't know N, the --- number of bytes of stack that the function will use, so we use a --- special late-bound CmmLit, namely --- CmmHighStackMark --- to stand for the number of bytes needed. When the stack is made --- manifest, the number of bytes needed is calculated, and used to --- replace occurrences of CmmHighStackMark --- --- The (Maybe CmmExpr) passed to do_checks is usually --- Just (CmmLit CmmHighStackMark) --- but can also (in certain hand-written RTS functions) --- Just (CmmLit 8) or some other fixed valuet --- If it is Nothing, we don't generate a stack check at all. - -do_checks :: Maybe CmmExpr -- Should we check the stack? - -- See Note [Stack usage] - -> Bool -- Should we check for preemption? - -> Maybe CmmExpr -- Heap headroom (bytes) - -> CmmAGraph -- What to do on failure - -> FCode () -do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do - dflags <- getDynFlags - gc_id <- newBlockId - - let - Just alloc_lit = mb_alloc_lit - - bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit - - -- Sp overflow if ((old + 0) - CmmHighStack < SpLim) - -- At the beginning of a function old + 0 = Sp - -- See Note [Single stack check] - sp_oflo sp_hwm = - CmmMachOp (mo_wordULt dflags) - [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg))) - [CmmStackSlot Old 0, sp_hwm], - CmmReg spLimReg] - - -- Hp overflow if (Hp > HpLim) - -- (Hp has been incremented by now) - -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp (mo_wordUGt dflags) - [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] - - alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit - - case mb_stk_hwm of - Nothing -> return () - Just stk_hwm -> tickyStackCheck - >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) ) - - -- Emit new label that might potentially be a header - -- of a self-recursive tail call. - -- See Note [Self-recursive loop header]. - self_loop_info <- getSelfLoop - case self_loop_info of - Just (_, loop_header_id, _) - | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id - _otherwise -> return () - - if (isJust mb_alloc_lit) - then do - tickyHeapCheck - emitAssign hpReg bump_hp - emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False) - else do - when (checkYield && not (gopt Opt_OmitYields dflags)) $ do - -- Yielding if HpLim == 0 - let yielding = CmmMachOp (mo_wordEq dflags) - [CmmReg (CmmGlobal HpLim), - CmmLit (zeroCLit dflags)] - emit =<< mkCmmIfGoto' yielding gc_id (Just False) - - tscope <- getTickScope - emitOutOfLine gc_id - (do_gc, tscope) -- this is expected to jump back somewhere - - -- Test for stack pointer exhaustion, then - -- bump heap pointer, and test for heap exhaustion - -- Note that we don't move the heap pointer unless the - -- stack check succeeds. Otherwise we might end up - -- with slop at the end of the current block, which can - -- confuse the LDV profiler. - --- Note [Self-recursive loop header] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Self-recursive loop header is required by loopification optimization (See --- Note [Self-recursive tail calls] in StgCmmExpr). We emit it if: --- --- 1. There is information about self-loop in the FCode environment. We don't --- check the binder (first component of the self_loop_info) because we are --- certain that if the self-loop info is present then we are compiling the --- binder body. Reason: the only possible way to get here with the --- self_loop_info present is from closureCodeBody. --- --- 2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible --- to preempt the heap check (see #367 for motivation behind this check). It --- is True for heap checks placed at the entry to a function and --- let-no-escape heap checks but false for other heap checks (eg. in case --- alternatives or created from hand-written high-level Cmm). The second --- check (isJust mb_stk_hwm) is true for heap checks at the entry to a --- function and some heap checks created in hand-written Cmm. Otherwise it --- is Nothing. In other words the only situation when both conditions are --- true is when compiling stack and heap checks at the entry to a --- function. This is the only situation when we want to emit a self-loop --- label. diff --git a/codeGen/StgCmmHpc.hs b/codeGen/StgCmmHpc.hs deleted file mode 100644 --- a/codeGen/StgCmmHpc.hs +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------ --- --- Code generation for coverage --- --- (c) Galois Connections, Inc. 2006 --- ------------------------------------------------------------------------------ - -module StgCmmHpc ( initHpc, mkTickBox ) where - -import StgCmmMonad - -import MkGraph -import CmmExpr -import CLabel -import Module -import CmmUtils -import StgCmmUtils -import HscTypes -import DynFlags - -import Control.Monad - -mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph -mkTickBox dflags mod n - = mkStore tick_box (CmmMachOp (MO_Add W64) - [ CmmLoad tick_box b64 - , CmmLit (CmmInt 1 W64) - ]) - where - tick_box = cmmIndex dflags W64 - (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) - n - -initHpc :: Module -> HpcInfo -> FCode () --- Emit top-level tables for HPC and return code to initialise -initHpc _ (NoHpcInfo {}) - = return () -initHpc this_mod (HpcInfo tickCount _hashNo) - = do dflags <- getDynFlags - when (gopt Opt_Hpc dflags) $ - do emitDataLits (mkHpcTicksLabel this_mod) - [ (CmmInt 0 W64) - | _ <- take tickCount [0 :: Int ..] - ] - diff --git a/codeGen/StgCmmLayout.hs b/codeGen/StgCmmLayout.hs deleted file mode 100644 --- a/codeGen/StgCmmLayout.hs +++ /dev/null @@ -1,552 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Building info tables. --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module StgCmmLayout ( - mkArgDescr, - emitCall, emitReturn, adjustHpBackwards, - - emitClosureProcAndInfoTable, - emitClosureAndInfoTable, - - slowCall, directCall, - - mkVirtHeapOffsets, mkVirtConstrOffsets, mkVirtConstrSizes, getHpRelOffset, - - ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep - ) where - - -#include "HsVersions.h" - -import Prelude hiding ((<*>)) - -import StgCmmClosure -import StgCmmEnv -import StgCmmArgRep -- notably: ( slowCallPattern ) -import StgCmmTicky -import StgCmmMonad -import StgCmmUtils -import StgCmmProf (curCCS) - -import MkGraph -import SMRep -import BlockId -import Cmm -import CmmUtils -import CmmInfo -import CLabel -import StgSyn -import Id -import TyCon ( PrimRep(..) ) -import BasicTypes ( RepArity ) -import DynFlags -import Module - -import Util -import Data.List -import Outputable -import FastString -import Control.Monad - ------------------------------------------------------------------------- --- Call and return sequences ------------------------------------------------------------------------- - --- | Return multiple values to the sequel --- --- If the sequel is @Return@ --- --- > return (x,y) --- --- If the sequel is @AssignTo [p,q]@ --- --- > p=x; q=y; --- -emitReturn :: [CmmExpr] -> FCode ReturnKind -emitReturn results - = do { dflags <- getDynFlags - ; sequel <- getSequel - ; updfr_off <- getUpdFrameOff - ; case sequel of - Return -> - do { adjustHpBackwards - ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags) - ; emit (mkReturn dflags (entryCode dflags e) results updfr_off) - } - AssignTo regs adjust -> - do { when adjust adjustHpBackwards - ; emitMultiAssign regs results } - ; return AssignedDirectly - } - - --- | @emitCall conv fun args@ makes a call to the entry-code of @fun@, --- using the call/return convention @conv@, passing @args@, and --- returning the results to the current sequel. --- -emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind -emitCall convs fun args - = emitCallWithExtraStack convs fun args noExtraStack - - --- | @emitCallWithExtraStack conv fun args stack@ makes a call to the --- entry-code of @fun@, using the call/return convention @conv@, --- passing @args@, pushing some extra stack frames described by --- @stack@, and returning the results to the current sequel. --- -emitCallWithExtraStack - :: (Convention, Convention) -> CmmExpr -> [CmmExpr] - -> [CmmExpr] -> FCode ReturnKind -emitCallWithExtraStack (callConv, retConv) fun args extra_stack - = do { dflags <- getDynFlags - ; adjustHpBackwards - ; sequel <- getSequel - ; updfr_off <- getUpdFrameOff - ; case sequel of - Return -> do - emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack - return AssignedDirectly - AssignTo res_regs _ -> do - k <- newBlockId - let area = Young k - (off, _, copyin) = copyInOflow dflags retConv area res_regs [] - copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off - extra_stack - tscope <- getTickScope - emit (copyout <*> mkLabel k tscope <*> copyin) - return (ReturnedTo k off) - } - - -adjustHpBackwards :: FCode () --- This function adjusts the heap pointer just before a tail call or --- return. At a call or return, the virtual heap pointer may be less --- than the real Hp, because the latter was advanced to deal with --- the worst-case branch of the code, and we may be in a better-case --- branch. In that case, move the real Hp *back* and retract some --- ticky allocation count. --- --- It *does not* deal with high-water-mark adjustment. That's done by --- functions which allocate heap. -adjustHpBackwards - = do { hp_usg <- getHpUsage - ; let rHp = realHp hp_usg - vHp = virtHp hp_usg - adjust_words = vHp -rHp - ; new_hp <- getHpRelOffset vHp - - ; emit (if adjust_words == 0 - then mkNop - else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp - - ; tickyAllocHeap False adjust_words -- ...ditto - - ; setRealHp vHp - } - - -------------------------------------------------------------------------- --- Making calls: directCall and slowCall -------------------------------------------------------------------------- - --- General plan is: --- - we'll make *one* fast call, either to the function itself --- (directCall) or to stg_ap__fast (slowCall) --- Any left-over arguments will be pushed on the stack, --- --- e.g. Sp[old+8] = arg1 --- Sp[old+16] = arg2 --- Sp[old+32] = stg_ap_pp_info --- R2 = arg3 --- R3 = arg4 --- call f() return to Nothing updfr_off: 32 - - -directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind --- (directCall f n args) --- calls f(arg1, ..., argn), and applies the result to the remaining args --- The function f has arity n, and there are guaranteed at least n args --- Both arity and args include void args -directCall conv lbl arity stg_args - = do { argreps <- getArgRepsAmodes stg_args - ; direct_call "directCall" conv lbl arity argreps } - - -slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind --- (slowCall fun args) applies fun to args, returning the results to Sequel -slowCall fun stg_args - = do dflags <- getDynFlags - argsreps <- getArgRepsAmodes stg_args - let (rts_fun, arity) = slowCallPattern (map fst argsreps) - - (r, slow_code) <- getCodeR $ do - r <- direct_call "slow_call" NativeNodeCall - (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps) - emitComment $ mkFastString ("slow_call for " ++ - showSDoc dflags (ppr fun) ++ - " with pat " ++ unpackFS rts_fun) - return r - - -- Note [avoid intermediate PAPs] - let n_args = length stg_args - if n_args > arity && optLevel dflags >= 2 - then do - funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun - fun_iptr <- (CmmReg . CmmLocal) `fmap` - assignTemp (closureInfoPtr dflags (cmmUntag dflags funv)) - - -- ToDo: we could do slightly better here by reusing the - -- continuation from the slow call, which we have in r. - -- Also we'd like to push the continuation on the stack - -- before the branch, so that we only get one copy of the - -- code that saves all the live variables across the - -- call, but that might need some improvements to the - -- special case in the stack layout code to handle this - -- (see Note [diamond proc point]). - - fast_code <- getCode $ - emitCall (NativeNodeCall, NativeReturn) - (entryCode dflags fun_iptr) - (nonVArgs ((P,Just funv):argsreps)) - - slow_lbl <- newBlockId - fast_lbl <- newBlockId - is_tagged_lbl <- newBlockId - end_lbl <- newBlockId - - let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr) - (mkIntExpr dflags n_args) - - tscope <- getTickScope - emit (mkCbranch (cmmIsTagged dflags funv) - is_tagged_lbl slow_lbl (Just True) - <*> mkLabel is_tagged_lbl tscope - <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True) - <*> mkLabel fast_lbl tscope - <*> fast_code - <*> mkBranch end_lbl - <*> mkLabel slow_lbl tscope - <*> slow_code - <*> mkLabel end_lbl tscope) - return r - - else do - emit slow_code - return r - - --- Note [avoid intermediate PAPs] --- --- A slow call which needs multiple generic apply patterns will be --- almost guaranteed to create one or more intermediate PAPs when --- applied to a function that takes the correct number of arguments. --- We try to avoid this situation by generating code to test whether --- we are calling a function with the correct number of arguments --- first, i.e.: --- --- if (TAG(f) != 0} { // f is not a thunk --- if (f->info.arity == n) { --- ... make a fast call to f ... --- } --- } --- ... otherwise make the slow call ... --- --- We *only* do this when the call requires multiple generic apply --- functions, which requires pushing extra stack frames and probably --- results in intermediate PAPs. (I say probably, because it might be --- that we're over-applying a function, but that seems even less --- likely). --- --- This very rarely applies, but if it does happen in an inner loop it --- can have a severe impact on performance (#6084). - - --------------- -direct_call :: String - -> Convention -- e.g. NativeNodeCall or NativeDirectCall - -> CLabel -> RepArity - -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind -direct_call caller call_conv lbl arity args - | debugIsOn && real_arity > length args -- Too few args - = do -- Caller should ensure that there enough args! - pprPanic "direct_call" $ - text caller <+> ppr arity <+> - ppr lbl <+> ppr (length args) <+> - ppr (map snd args) <+> ppr (map fst args) - - | null rest_args -- Precisely the right number of arguments - = emitCall (call_conv, NativeReturn) target (nonVArgs args) - - | otherwise -- Note [over-saturated calls] - = do dflags <- getDynFlags - emitCallWithExtraStack (call_conv, NativeReturn) - target - (nonVArgs fast_args) - (nonVArgs (stack_args dflags)) - where - target = CmmLit (CmmLabel lbl) - (fast_args, rest_args) = splitAt real_arity args - stack_args dflags = slowArgs dflags rest_args - real_arity = case call_conv of - NativeNodeCall -> arity+1 - _ -> arity - - --- When constructing calls, it is easier to keep the ArgReps and the --- CmmExprs zipped together. However, a void argument has no --- representation, so we need to use Maybe CmmExpr (the alternative of --- using zeroCLit or even undefined would work, but would be ugly). --- -getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)] -getArgRepsAmodes = mapM getArgRepAmode - where getArgRepAmode arg - | V <- rep = return (V, Nothing) - | otherwise = do expr <- getArgAmode (NonVoid arg) - return (rep, Just expr) - where rep = toArgRep (argPrimRep arg) - -nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] -nonVArgs [] = [] -nonVArgs ((_,Nothing) : args) = nonVArgs args -nonVArgs ((_,Just arg) : args) = arg : nonVArgs args - -{- -Note [over-saturated calls] - -The natural thing to do for an over-saturated call would be to call -the function with the correct number of arguments, and then apply the -remaining arguments to the value returned, e.g. - - f a b c d (where f has arity 2) - --> - r = call f(a,b) - call r(c,d) - -but this entails - - saving c and d on the stack - - making a continuation info table - - at the continuation, loading c and d off the stack into regs - - finally, call r - -Note that since there are a fixed number of different r's -(e.g. stg_ap_pp_fast), we can also pre-compile continuations -that correspond to each of them, rather than generating a fresh -one for each over-saturated call. - -Not only does this generate much less code, it is faster too. We will -generate something like: - -Sp[old+16] = c -Sp[old+24] = d -Sp[old+32] = stg_ap_pp_info -call f(a,b) -- usual calling convention - -For the purposes of the CmmCall node, we count this extra stack as -just more arguments that we are passing on the stack (cml_args). --} - --- | 'slowArgs' takes a list of function arguments and prepares them for --- pushing on the stack for "extra" arguments to a function which requires --- fewer arguments than we currently have. -slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] -slowArgs _ [] = [] -slowArgs dflags args -- careful: reps contains voids (V), but args does not - | gopt Opt_SccProfilingOn dflags - = save_cccs ++ this_pat ++ slowArgs dflags rest_args - | otherwise = this_pat ++ slowArgs dflags rest_args - where - (arg_pat, n) = slowCallPattern (map fst args) - (call_args, rest_args) = splitAt n args - - stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat - this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args - save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)] - save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs") - -------------------------------------------------------------------------- ----- Laying out objects on the heap and stack -------------------------------------------------------------------------- - --- The heap always grows upwards, so hpRel is easy to compute -hpRel :: VirtualHpOffset -- virtual offset of Hp - -> VirtualHpOffset -- virtual offset of The Thing - -> WordOff -- integer word offset -hpRel hp off = off - hp - -getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr --- See Note [Virtual and real heap pointers] in StgCmmMonad -getHpRelOffset virtual_offset - = do dflags <- getDynFlags - hp_usg <- getHpUsage - return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) - -mkVirtHeapOffsets - :: DynFlags - -> Bool -- True <=> is a thunk - -> [NonVoid (PrimRep,a)] -- Things to make offsets for - -> (WordOff, -- _Total_ number of words allocated - WordOff, -- Number of words allocated for *pointers* - [(NonVoid a, ByteOff)]) - --- Things with their offsets from start of object in order of --- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER --- First in list gets lowest offset, which is initial offset + 1. --- --- mkVirtHeapOffsets always returns boxed things with smaller offsets --- than the unboxed things - -mkVirtHeapOffsets dflags is_thunk things - = ASSERT(not (any (isVoidRep . fst . fromNonVoid) things)) - ( bytesToWordsRoundUp dflags tot_bytes - , bytesToWordsRoundUp dflags bytes_of_ptrs - , ptrs_w_offsets ++ non_ptrs_w_offsets - ) - where - hdr_words | is_thunk = thunkHdrSize dflags - | otherwise = fixedHdrSizeW dflags - hdr_bytes = wordsToBytes dflags hdr_words - - (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things - - (bytes_of_ptrs, ptrs_w_offsets) = - mapAccumL computeOffset 0 ptrs - (tot_bytes, non_ptrs_w_offsets) = - mapAccumL computeOffset bytes_of_ptrs non_ptrs - - computeOffset bytes_so_far nv_thing - = (bytes_so_far + wordsToBytes dflags (argRepSizeW dflags (toArgRep rep)), - (NonVoid thing, hdr_bytes + bytes_so_far)) - where (rep,thing) = fromNonVoid nv_thing - --- | Just like mkVirtHeapOffsets, but for constructors -mkVirtConstrOffsets - :: DynFlags -> [NonVoid (PrimRep, a)] - -> (WordOff, WordOff, [(NonVoid a, ByteOff)]) -mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False - --- | Just like mkVirtConstrOffsets, but used when we don't have the actual --- arguments. Useful when e.g. generating info tables; we just need to know --- sizes of pointer and non-pointer fields. -mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff) -mkVirtConstrSizes dflags field_reps - = (tot_wds, ptr_wds) - where - (tot_wds, ptr_wds, _) = - mkVirtConstrOffsets dflags - (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps) - -------------------------------------------------------------------------- --- --- Making argument descriptors --- --- An argument descriptor describes the layout of args on the stack, --- both for * GC (stack-layout) purposes, and --- * saving/restoring registers when a heap-check fails --- --- Void arguments aren't important, therefore (contrast constructSlowCall) --- -------------------------------------------------------------------------- - --- bring in ARG_P, ARG_N, etc. -#include "rts/storage/FunTypes.h" - -mkArgDescr :: DynFlags -> [Id] -> ArgDescr -mkArgDescr dflags args - = let arg_bits = argBits dflags arg_reps - arg_reps = filter isNonV (map idArgRep args) - -- Getting rid of voids eases matching of standard patterns - in case stdPattern arg_reps of - Just spec_id -> ArgSpec spec_id - Nothing -> ArgGen arg_bits - -argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits _ [] = [] -argBits dflags (P : args) = False : argBits dflags args -argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) - ++ argBits dflags args - ----------------------- -stdPattern :: [ArgRep] -> Maybe Int -stdPattern reps - = case reps of - [] -> Just ARG_NONE -- just void args, probably - [N] -> Just ARG_N - [P] -> Just ARG_P - [F] -> Just ARG_F - [D] -> Just ARG_D - [L] -> Just ARG_L - [V16] -> Just ARG_V16 - [V32] -> Just ARG_V32 - [V64] -> Just ARG_V64 - - [N,N] -> Just ARG_NN - [N,P] -> Just ARG_NP - [P,N] -> Just ARG_PN - [P,P] -> Just ARG_PP - - [N,N,N] -> Just ARG_NNN - [N,N,P] -> Just ARG_NNP - [N,P,N] -> Just ARG_NPN - [N,P,P] -> Just ARG_NPP - [P,N,N] -> Just ARG_PNN - [P,N,P] -> Just ARG_PNP - [P,P,N] -> Just ARG_PPN - [P,P,P] -> Just ARG_PPP - - [P,P,P,P] -> Just ARG_PPPP - [P,P,P,P,P] -> Just ARG_PPPPP - [P,P,P,P,P,P] -> Just ARG_PPPPPP - - _ -> Nothing - -------------------------------------------------------------------------- --- --- Generating the info table and code for a closure --- -------------------------------------------------------------------------- - --- Here we make an info table of type 'CmmInfo'. The concrete --- representation as a list of 'CmmAddr' is handled later --- in the pipeline by 'cmmToRawCmm'. --- When loading the free variables, a function closure pointer may be tagged, --- so we must take it into account. - -emitClosureProcAndInfoTable :: Bool -- top-level? - -> Id -- name of the closure - -> LambdaFormInfo - -> CmmInfoTable - -> [NonVoid Id] -- incoming arguments - -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body - -> FCode () -emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body - = do { dflags <- getDynFlags - -- Bind the binder itself, but only if it's not a top-level - -- binding. We need non-top let-bindings to refer to the - -- top-level binding, which this binding would incorrectly shadow. - ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr) - else bindToReg (NonVoid bndr) lf_info - ; let node_points = nodeMustPointToIt dflags lf_info - ; arg_regs <- bindArgsToRegs args - ; let args' = if node_points then (node : arg_regs) else arg_regs - conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall - else NativeDirectCall - (offset, _, _) = mkCallEntry dflags conv args' [] - ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) - } - --- Data constructors need closures, but not with all the argument handling --- needed for functions. The shared part goes here. -emitClosureAndInfoTable :: - CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode () -emitClosureAndInfoTable info_tbl conv args body - = do { (_, blks) <- getCodeScoped body - ; let entry_lbl = toEntryLbl (cit_lbl info_tbl) - ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks - } diff --git a/codeGen/StgCmmMonad.hs b/codeGen/StgCmmMonad.hs deleted file mode 100644 --- a/codeGen/StgCmmMonad.hs +++ /dev/null @@ -1,900 +0,0 @@ -{-# LANGUAGE CPP, GADTs, UnboxedTuples #-} - ------------------------------------------------------------------------------ --- --- Monad for Stg to C-- code generation --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module StgCmmMonad ( - FCode, -- type - - initC, runC, thenC, thenFC, listCs, - returnFC, fixC, - newUnique, newUniqSupply, - - emitLabel, - - emit, emitDecl, emitProc, - emitProcWithConvention, emitProcWithStackFrame, - emitOutOfLine, emitAssign, emitStore, - emitComment, emitTick, emitUnwind, - - getCmm, aGraphToGraph, - getCodeR, getCode, getCodeScoped, getHeapUsage, - - mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, - mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto', - - mkCall, mkCmmCall, - - forkClosureBody, forkLneBody, forkAlts, codeOnly, - - ConTagZ, - - Sequel(..), ReturnKind(..), - withSequel, getSequel, - - setTickyCtrLabel, getTickyCtrLabel, - tickScope, getTickScope, - - withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, - - HeapUsage(..), VirtualHpOffset, initHpUsage, - getHpUsage, setHpUsage, heapHWM, - setVirtHp, getVirtHp, setRealHp, - - getModuleName, - - -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage, - - -- more localised access to monad state - CgIdInfo(..), - getBinds, setBinds, - - -- out of general friendliness, we also export ... - CgInfoDownwards(..), CgState(..) -- non-abstract - ) where - -#include "HsVersions.h" - -import Cmm -import StgCmmClosure -import DynFlags -import Hoopl -import Maybes -import MkGraph -import BlockId -import CLabel -import SMRep -import Module -import Id -import VarEnv -import OrdList -import Unique -import UniqSupply -import FastString -import Outputable - -import Control.Monad -import Data.List -import Prelude hiding( sequence, succ ) - -infixr 9 `thenC` -- Right-associative! -infixr 9 `thenFC` - - --------------------------------------------------------- --- The FCode monad and its types --- --- FCode is the monad plumbed through the Stg->Cmm code generator, and --- the Cmm parser. It contains the following things: --- --- - A writer monad, collecting: --- - code for the current function, in the form of a CmmAGraph. --- The function "emit" appends more code to this. --- - the top-level CmmDecls accumulated so far --- --- - A state monad with: --- - the local bindings in scope --- - the current heap usage --- - a UniqSupply --- --- - A reader monad, for CgInfoDownwards, containing --- - DynFlags, --- - the current Module --- - the update-frame offset --- - the ticky counter label --- - the Sequel (the continuation to return to) --- - the self-recursive tail call information - --------------------------------------------------------- - -newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #)) - -instance Functor FCode where - fmap f (FCode g) = FCode $ \i s -> case g i s of (# a, s' #) -> (# f a, s' #) - -instance Applicative FCode where - pure = returnFC - (<*>) = ap - -instance Monad FCode where - (>>=) = thenFC - -{-# INLINE thenC #-} -{-# INLINE thenFC #-} -{-# INLINE returnFC #-} - -instance MonadUnique FCode where - getUniqueSupplyM = cgs_uniqs <$> getState - getUniqueM = FCode $ \_ st -> - let (u, us') = takeUniqFromSupply (cgs_uniqs st) - in (# u, st { cgs_uniqs = us' } #) - -initC :: IO CgState -initC = do { uniqs <- mkSplitUniqSupply 'c' - ; return (initCgState uniqs) } - -runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState) -runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st - -returnFC :: a -> FCode a -returnFC val = FCode (\_info_down state -> (# val, state #)) - -thenC :: FCode () -> FCode a -> FCode a -thenC (FCode m) (FCode k) = - FCode $ \info_down state -> case m info_down state of - (# _,new_state #) -> k info_down new_state - -listCs :: [FCode ()] -> FCode () -listCs [] = return () -listCs (fc:fcs) = do - fc - listCs fcs - -thenFC :: FCode a -> (a -> FCode c) -> FCode c -thenFC (FCode m) k = FCode $ - \info_down state -> - case m info_down state of - (# m_result, new_state #) -> - case k m_result of - FCode kcode -> kcode info_down new_state - -fixC :: (a -> FCode a) -> FCode a -fixC fcode = FCode ( - \info_down state -> - let - (v,s) = doFCode (fcode v) info_down state - in - (# v, s #) - ) - --------------------------------------------------------- --- The code generator environment --------------------------------------------------------- - --- This monadery has some information that it only passes --- *downwards*, as well as some ``state'' which is modified --- as we go along. - -data CgInfoDownwards -- information only passed *downwards* by the monad - = MkCgInfoDown { - cgd_dflags :: DynFlags, - cgd_mod :: Module, -- Module being compiled - cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame - cgd_ticky :: CLabel, -- Current destination for ticky counts - cgd_sequel :: Sequel, -- What to do at end of basic block - cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled - -- as local jumps? See Note - -- [Self-recursive tail calls] in - -- StgCmmExpr - cgd_tick_scope:: CmmTickScope -- Tick scope for new blocks & ticks - } - -type CgBindings = IdEnv CgIdInfo - -data CgIdInfo - = CgIdInfo - { cg_id :: Id -- Id that this is the info for - -- Can differ from the Id at occurrence sites by - -- virtue of being externalised, for splittable C - -- See Note [Externalise when splitting] - , cg_lf :: LambdaFormInfo - , cg_loc :: CgLoc -- CmmExpr for the *tagged* value - } - --- Note [Externalise when splitting] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- If we're splitting the object with -fsplit-objs, we need to --- externalise *all* the top-level names, and then make sure we only --- use the externalised one in any C label we use which refers to this --- name. - -instance Outputable CgIdInfo where - ppr (CgIdInfo { cg_id = id, cg_loc = loc }) - = ppr id <+> text "-->" <+> ppr loc - --- Sequel tells what to do with the result of this expression -data Sequel - = Return -- Return result(s) to continuation found on the stack. - - | AssignTo - [LocalReg] -- Put result(s) in these regs and fall through - -- NB: no void arguments here - -- - Bool -- Should we adjust the heap pointer back to - -- recover space that's unused on this path? - -- We need to do this only if the expression - -- may allocate (e.g. it's a foreign call or - -- allocating primOp) - -instance Outputable Sequel where - ppr Return = text "Return" - ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b - --- See Note [sharing continuations] below -data ReturnKind - = AssignedDirectly - | ReturnedTo BlockId ByteOff - --- Note [sharing continuations] --- --- ReturnKind says how the expression being compiled returned its --- results: either by assigning directly to the registers specified --- by the Sequel, or by returning to a continuation that does the --- assignments. The point of this is we might be able to re-use the --- continuation in a subsequent heap-check. Consider: --- --- case f x of z --- True -> --- False -> --- --- Naively we would generate --- --- R2 = x -- argument to f --- Sp[young(L1)] = L1 --- call f returns to L1 --- L1: --- z = R1 --- if (z & 1) then Ltrue else Lfalse --- Ltrue: --- Hp = Hp + 24 --- if (Hp > HpLim) then L4 else L7 --- L4: --- HpAlloc = 24 --- goto L5 --- L5: --- R1 = z --- Sp[young(L6)] = L6 --- call stg_gc_unpt_r1 returns to L6 --- L6: --- z = R1 --- goto L1 --- L7: --- --- Lfalse: --- --- --- We want the gc call in L4 to return to L1, and discard L6. Note --- that not only can we share L1 and L6, but the assignment of the --- return address in L4 is unnecessary because the return address for --- L1 is already on the stack. We used to catch the sharing of L1 and --- L6 in the common-block-eliminator, but not the unnecessary return --- address assignment. --- --- Since this case is so common I decided to make it more explicit and --- robust by programming the sharing directly, rather than relying on --- the common-block elimiantor to catch it. This makes --- common-block-elimianteion an optional optimisation, and furthermore --- generates less code in the first place that we have to subsequently --- clean up. --- --- There are some rarer cases of common blocks that we don't catch --- this way, but that's ok. Common-block-elimination is still available --- to catch them when optimisation is enabled. Some examples are: --- --- - when both the True and False branches do a heap check, we --- can share the heap-check failure code L4a and maybe L4 --- --- - in a case-of-case, there might be multiple continuations that --- we can common up. --- --- It is always safe to use AssignedDirectly. Expressions that jump --- to the continuation from multiple places (e.g. case expressions) --- fall back to AssignedDirectly. --- - - -initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards -initCgInfoDown dflags mod - = MkCgInfoDown { cgd_dflags = dflags - , cgd_mod = mod - , cgd_updfr_off = initUpdFrameOff dflags - , cgd_ticky = mkTopTickyCtrLabel - , cgd_sequel = initSequel - , cgd_self_loop = Nothing - , cgd_tick_scope= GlobalScope } - -initSequel :: Sequel -initSequel = Return - -initUpdFrameOff :: DynFlags -> UpdFrameOffset -initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA - - --------------------------------------------------------- --- The code generator state --------------------------------------------------------- - -data CgState - = MkCgState { - cgs_stmts :: CmmAGraph, -- Current procedure - - cgs_tops :: OrdList CmmDecl, - -- Other procedures and data blocks in this compilation unit - -- Both are ordered only so that we can - -- reduce forward references, when it's easy to do so - - cgs_binds :: CgBindings, - - cgs_hp_usg :: HeapUsage, - - cgs_uniqs :: UniqSupply } - -data HeapUsage -- See Note [Virtual and real heap pointers] - = HeapUsage { - virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word - -- Incremented whenever we allocate - realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr - -- Used in instruction addressing modes - } - -type VirtualHpOffset = WordOff - - -{- Note [Virtual and real heap pointers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The code generator can allocate one or more objects contiguously, performing -one heap check to cover allocation of all the objects at once. Let's call -this little chunk of heap space an "allocation chunk". The code generator -will emit code to - * Perform a heap-exhaustion check - * Move the heap pointer to the end of the allocation chunk - * Allocate multiple objects within the chunk - -The code generator uses VirtualHpOffsets to address words within a -single allocation chunk; these start at one and increase positively. -The first word of the chunk has VirtualHpOffset=1, the second has -VirtualHpOffset=2, and so on. - - * The field realHp tracks (the VirtualHpOffset) where the real Hp - register is pointing. Typically it'll be pointing to the end of the - allocation chunk. - - * The field virtHp gives the VirtualHpOffset of the highest-allocated - word so far. It starts at zero (meaning no word has been allocated), - and increases whenever an object is allocated. - -The difference between realHp and virtHp gives the offset from the -real Hp register of a particular word in the allocation chunk. This -is what getHpRelOffset does. Since the returned offset is relative -to the real Hp register, it is valid only until you change the real -Hp register. (Changing virtHp doesn't matter.) --} - - -initCgState :: UniqSupply -> CgState -initCgState uniqs - = MkCgState { cgs_stmts = mkNop - , cgs_tops = nilOL - , cgs_binds = emptyVarEnv - , cgs_hp_usg = initHpUsage - , cgs_uniqs = uniqs } - -stateIncUsage :: CgState -> CgState -> CgState --- stateIncUsage@ e1 e2 incorporates in e1 --- the heap high water mark found in e2. -stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg }) - = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg } - `addCodeBlocksFrom` s2 - -addCodeBlocksFrom :: CgState -> CgState -> CgState --- Add code blocks from the latter to the former --- (The cgs_stmts will often be empty, but not always; see codeOnly) -s1 `addCodeBlocksFrom` s2 - = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2, - cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 } - - --- The heap high water mark is the larger of virtHp and hwHp. The latter is --- only records the high water marks of forked-off branches, so to find the --- heap high water mark you have to take the max of virtHp and hwHp. Remember, --- virtHp never retreats! --- --- Note Jan 04: ok, so why do we only look at the virtual Hp?? - -heapHWM :: HeapUsage -> VirtualHpOffset -heapHWM = virtHp - -initHpUsage :: HeapUsage -initHpUsage = HeapUsage { virtHp = 0, realHp = 0 } - -maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage -hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw } - --------------------------------------------------------- --- Operators for getting and setting the state and "info_down". --------------------------------------------------------- - -getState :: FCode CgState -getState = FCode $ \_info_down state -> (# state, state #) - -setState :: CgState -> FCode () -setState state = FCode $ \_info_down _ -> (# (), state #) - -getHpUsage :: FCode HeapUsage -getHpUsage = do - state <- getState - return $ cgs_hp_usg state - -setHpUsage :: HeapUsage -> FCode () -setHpUsage new_hp_usg = do - state <- getState - setState $ state {cgs_hp_usg = new_hp_usg} - -setVirtHp :: VirtualHpOffset -> FCode () -setVirtHp new_virtHp - = do { hp_usage <- getHpUsage - ; setHpUsage (hp_usage {virtHp = new_virtHp}) } - -getVirtHp :: FCode VirtualHpOffset -getVirtHp - = do { hp_usage <- getHpUsage - ; return (virtHp hp_usage) } - -setRealHp :: VirtualHpOffset -> FCode () -setRealHp new_realHp - = do { hp_usage <- getHpUsage - ; setHpUsage (hp_usage {realHp = new_realHp}) } - -getBinds :: FCode CgBindings -getBinds = do - state <- getState - return $ cgs_binds state - -setBinds :: CgBindings -> FCode () -setBinds new_binds = do - state <- getState - setState $ state {cgs_binds = new_binds} - -withState :: FCode a -> CgState -> FCode (a,CgState) -withState (FCode fcode) newstate = FCode $ \info_down state -> - case fcode info_down newstate of - (# retval, state2 #) -> (# (retval,state2), state #) - -newUniqSupply :: FCode UniqSupply -newUniqSupply = do - state <- getState - let (us1, us2) = splitUniqSupply (cgs_uniqs state) - setState $ state { cgs_uniqs = us1 } - return us2 - -newUnique :: FCode Unique -newUnique = do - state <- getState - let (u,us') = takeUniqFromSupply (cgs_uniqs state) - setState $ state { cgs_uniqs = us' } - return u - ------------------- -getInfoDown :: FCode CgInfoDownwards -getInfoDown = FCode $ \info_down state -> (# info_down,state #) - -getSelfLoop :: FCode (Maybe SelfLoopInfo) -getSelfLoop = do - info_down <- getInfoDown - return $ cgd_self_loop info_down - -withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a -withSelfLoop self_loop code = do - info_down <- getInfoDown - withInfoDown code (info_down {cgd_self_loop = Just self_loop}) - -instance HasDynFlags FCode where - getDynFlags = liftM cgd_dflags getInfoDown - -getThisPackage :: FCode UnitId -getThisPackage = liftM thisPackage getDynFlags - -withInfoDown :: FCode a -> CgInfoDownwards -> FCode a -withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state - -doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState) -doFCode (FCode fcode) info_down state = - case fcode info_down state of - (# a, s #) -> ( a, s ) - --- ---------------------------------------------------------------------------- --- Get the current module name - -getModuleName :: FCode Module -getModuleName = do { info <- getInfoDown; return (cgd_mod info) } - --- ---------------------------------------------------------------------------- --- Get/set the end-of-block info - -withSequel :: Sequel -> FCode a -> FCode a -withSequel sequel code - = do { info <- getInfoDown - ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) } - -getSequel :: FCode Sequel -getSequel = do { info <- getInfoDown - ; return (cgd_sequel info) } - --- ---------------------------------------------------------------------------- --- Get/set the size of the update frame - --- We keep track of the size of the update frame so that we --- can set the stack pointer to the proper address on return --- (or tail call) from the closure. --- There should be at most one update frame for each closure. --- Note: I'm including the size of the original return address --- in the size of the update frame -- hence the default case on `get'. - -withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a -withUpdFrameOff size code - = do { info <- getInfoDown - ; withInfoDown code (info {cgd_updfr_off = size }) } - -getUpdFrameOff :: FCode UpdFrameOffset -getUpdFrameOff - = do { info <- getInfoDown - ; return $ cgd_updfr_off info } - --- ---------------------------------------------------------------------------- --- Get/set the current ticky counter label - -getTickyCtrLabel :: FCode CLabel -getTickyCtrLabel = do - info <- getInfoDown - return (cgd_ticky info) - -setTickyCtrLabel :: CLabel -> FCode a -> FCode a -setTickyCtrLabel ticky code = do - info <- getInfoDown - withInfoDown code (info {cgd_ticky = ticky}) - --- ---------------------------------------------------------------------------- --- Manage tick scopes - --- | The current tick scope. We will assign this to generated blocks. -getTickScope :: FCode CmmTickScope -getTickScope = do - info <- getInfoDown - return (cgd_tick_scope info) - --- | Places blocks generated by the given code into a fresh --- (sub-)scope. This will make sure that Cmm annotations in our scope --- will apply to the Cmm blocks generated therein - but not the other --- way around. -tickScope :: FCode a -> FCode a -tickScope code = do - info <- getInfoDown - if debugLevel (cgd_dflags info) == 0 then code else do - u <- newUnique - let scope' = SubScope u (cgd_tick_scope info) - withInfoDown code info{ cgd_tick_scope = scope' } - - --------------------------------------------------------- --- Forking --------------------------------------------------------- - -forkClosureBody :: FCode () -> FCode () --- forkClosureBody compiles body_code in environment where: --- - sequel, update stack frame and self loop info are --- set to fresh values --- - state is set to a fresh value, except for local bindings --- that are passed in unchanged. It's up to the enclosed code to --- re-bind the free variables to a field of the closure. - -forkClosureBody body_code - = do { dflags <- getDynFlags - ; info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let body_info_down = info { cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff dflags - , cgd_self_loop = Nothing } - fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - ((),fork_state_out) = doFCode body_code body_info_down fork_state_in - ; setState $ state `addCodeBlocksFrom` fork_state_out } - -forkLneBody :: FCode a -> FCode a --- 'forkLneBody' takes a body of let-no-escape binding and compiles --- it in the *current* environment, returning the graph thus constructed. --- --- The current environment is passed on completely unchanged to --- the successor. In particular, any heap usage from the enclosed --- code is discarded; it should deal with its own heap consumption. -forkLneBody body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - (result, fork_state_out) = doFCode body_code info_down fork_state_in - ; setState $ state `addCodeBlocksFrom` fork_state_out - ; return result } - -codeOnly :: FCode () -> FCode () --- Emit any code from the inner thing into the outer thing --- Do not affect anything else in the outer state --- Used in almost-circular code to prevent false loop dependencies -codeOnly body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state - , cgs_hp_usg = cgs_hp_usg state } - ((), fork_state_out) = doFCode body_code info_down fork_state_in - ; setState $ state `addCodeBlocksFrom` fork_state_out } - -forkAlts :: [FCode a] -> FCode [a] --- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and --- an fcode for the default case 'd', and compiles each in the current --- environment. The current environment is passed on unmodified, except --- that the virtual Hp is moved on to the worst virtual Hp for the branches - -forkAlts branch_fcodes - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let compile us branch - = (us2, doFCode branch info_down branch_state) - where - (us1,us2) = splitUniqSupply us - branch_state = (initCgState us1) { - cgs_binds = cgs_binds state - , cgs_hp_usg = cgs_hp_usg state } - (_us, results) = mapAccumL compile us branch_fcodes - (branch_results, branch_out_states) = unzip results - ; setState $ foldl stateIncUsage state branch_out_states - -- NB foldl. state is the *left* argument to stateIncUsage - ; return branch_results } - --- collect the code emitted by an FCode computation -getCodeR :: FCode a -> FCode (a, CmmAGraph) -getCodeR fcode - = do { state1 <- getState - ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop }) - ; setState $ state2 { cgs_stmts = cgs_stmts state1 } - ; return (a, cgs_stmts state2) } - -getCode :: FCode a -> FCode CmmAGraph -getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts } - --- | Generate code into a fresh tick (sub-)scope and gather generated code -getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped) -getCodeScoped fcode - = do { state1 <- getState - ; ((a, tscope), state2) <- - tickScope $ - flip withState state1 { cgs_stmts = mkNop } $ - do { a <- fcode - ; scp <- getTickScope - ; return (a, scp) } - ; setState $ state2 { cgs_stmts = cgs_stmts state1 } - ; return (a, (cgs_stmts state2, tscope)) } - - --- 'getHeapUsage' applies a function to the amount of heap that it uses. --- It initialises the heap usage to zeros, and passes on an unchanged --- heap usage. --- --- It is usually a prelude to performing a GC check, so everything must --- be in a tidy and consistent state. --- --- Note the slightly subtle fixed point behaviour needed here - -getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a -getHeapUsage fcode - = do { info_down <- getInfoDown - ; state <- getState - ; let fstate_in = state { cgs_hp_usg = initHpUsage } - (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in - hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here! - - ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state } - ; return r } - --- ---------------------------------------------------------------------------- --- Combinators for emitting code - -emitCgStmt :: CgStmt -> FCode () -emitCgStmt stmt - = do { state <- getState - ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } - } - -emitLabel :: BlockId -> FCode () -emitLabel id = do tscope <- getTickScope - emitCgStmt (CgLabel id tscope) - -emitComment :: FastString -> FCode () -#if 0 /* def DEBUG */ -emitComment s = emitCgStmt (CgStmt (CmmComment s)) -#else -emitComment _ = return () -#endif - -emitTick :: CmmTickish -> FCode () -emitTick = emitCgStmt . CgStmt . CmmTick - -emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode () -emitUnwind regs = do - dflags <- getDynFlags - when (debugLevel dflags > 0) $ do - emitCgStmt $ CgStmt $ CmmUnwind regs - -emitAssign :: CmmReg -> CmmExpr -> FCode () -emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r)) - -emitStore :: CmmExpr -> CmmExpr -> FCode () -emitStore l r = emitCgStmt (CgStmt (CmmStore l r)) - -emit :: CmmAGraph -> FCode () -emit ag - = do { state <- getState - ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } } - -emitDecl :: CmmDecl -> FCode () -emitDecl decl - = do { state <- getState - ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } } - -emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode () -emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope) - -emitProcWithStackFrame - :: Convention -- entry convention - -> Maybe CmmInfoTable -- info table? - -> CLabel -- label for the proc - -> [CmmFormal] -- stack frame - -> [CmmFormal] -- arguments - -> CmmAGraphScoped -- code - -> Bool -- do stack layout? - -> FCode () - -emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False - = do { dflags <- getDynFlags - ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False - } -emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True - -- do layout - = do { dflags <- getDynFlags - ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args - graph' = entry MkGraph.<*> graph - ; emitProc_ mb_info lbl live (graph', tscope) offset True - } -emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame" - -emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel - -> [CmmFormal] - -> CmmAGraphScoped - -> FCode () -emitProcWithConvention conv mb_info lbl args blocks - = emitProcWithStackFrame conv mb_info lbl [] args blocks True - -emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped - -> Int -> FCode () -emitProc mb_info lbl live blocks offset - = emitProc_ mb_info lbl live blocks offset True - -emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped - -> Int -> Bool -> FCode () -emitProc_ mb_info lbl live blocks offset do_layout - = do { dflags <- getDynFlags - ; l <- newBlockId - ; let - blks = labelAGraph l blocks - - infos | Just info <- mb_info = mapSingleton (g_entry blks) info - | otherwise = mapEmpty - - sinfo = StackInfo { arg_space = offset - , updfr_space = Just (initUpdFrameOff dflags) - , do_layout = do_layout } - - tinfo = TopInfo { info_tbls = infos - , stack_info=sinfo} - - proc_block = CmmProc tinfo lbl live blks - - ; state <- getState - ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } - -getCmm :: FCode () -> FCode CmmGroup --- Get all the CmmTops (there should be no stmts) --- Return a single Cmm which may be split from other Cmms by --- object splitting (at a later stage) -getCmm code - = do { state1 <- getState - ; ((), state2) <- withState code (state1 { cgs_tops = nilOL }) - ; setState $ state2 { cgs_tops = cgs_tops state1 } - ; return (fromOL (cgs_tops state2)) } - - -mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph -mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing - -mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph - -> Maybe Bool -> FCode CmmAGraph -mkCmmIfThenElse' e tbranch fbranch likely = do - tscp <- getTickScope - endif <- newBlockId - tid <- newBlockId - fid <- newBlockId - - let - (test, then_, else_, likely') = case likely of - Just False | Just e' <- maybeInvertCmmExpr e - -- currently NCG doesn't know about likely - -- annotations. We manually switch then and - -- else branch so the likely false branch - -- becomes a fallthrough. - -> (e', fbranch, tbranch, Just True) - _ -> (e, tbranch, fbranch, likely) - - return $ catAGraphs [ mkCbranch test tid fid likely' - , mkLabel tid tscp, then_, mkBranch endif - , mkLabel fid tscp, else_, mkLabel endif tscp ] - -mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph -mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing - -mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph -mkCmmIfGoto' e tid l = do - endif <- newBlockId - tscp <- getTickScope - return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ] - -mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph -mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing - -mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph -mkCmmIfThen' e tbranch l = do - endif <- newBlockId - tid <- newBlockId - tscp <- getTickScope - return $ catAGraphs [ mkCbranch e tid endif l - , mkLabel tid tscp, tbranch, mkLabel endif tscp ] - -mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr] - -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph -mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do - dflags <- getDynFlags - k <- newBlockId - tscp <- getTickScope - let area = Young k - (off, _, copyin) = copyInOflow dflags retConv area results [] - copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack - return $ catAGraphs [copyout, mkLabel k tscp, copyin] - -mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset - -> FCode CmmAGraph -mkCmmCall f results actuals updfr_off - = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off [] - - --- ---------------------------------------------------------------------------- --- turn CmmAGraph into CmmGraph, for making a new proc. - -aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph -aGraphToGraph stmts - = do { l <- newBlockId - ; return (labelAGraph l stmts) } diff --git a/codeGen/StgCmmPrim.hs b/codeGen/StgCmmPrim.hs deleted file mode 100644 --- a/codeGen/StgCmmPrim.hs +++ /dev/null @@ -1,2242 +0,0 @@ -{-# LANGUAGE CPP #-} - ----------------------------------------------------------------------------- --- --- Stg to C--: primitive operations --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module StgCmmPrim ( - cgOpApp, - cgPrimOp, -- internal(ish), used by cgCase to get code for a - -- comparison without also turning it into a Bool. - shouldInlinePrimOp - ) where - -#include "HsVersions.h" - -import StgCmmLayout -import StgCmmForeign -import StgCmmEnv -import StgCmmMonad -import StgCmmUtils -import StgCmmTicky -import StgCmmHeap -import StgCmmProf ( costCentreFrom, curCCS ) - -import DynFlags -import Platform -import BasicTypes -import BlockId -import MkGraph -import StgSyn -import Cmm -import CmmInfo -import Type ( Type, tyConAppTyCon ) -import TyCon -import CLabel -import CmmUtils -import PrimOp -import SMRep -import FastString -import Outputable -import Util - -import Prelude hiding ((<*>)) - -import Data.Bits ((.&.), bit) -import Control.Monad (liftM, when) - ------------------------------------------------------------------------- --- Primitive operations and foreign calls ------------------------------------------------------------------------- - -{- Note [Foreign call results] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A foreign call always returns an unboxed tuple of results, one -of which is the state token. This seems to happen even for pure -calls. - -Even if we returned a single result for pure calls, it'd still be -right to wrap it in a singleton unboxed tuple, because the result -might be a Haskell closure pointer, we don't want to evaluate it. -} - ----------------------------------- -cgOpApp :: StgOp -- The op - -> [StgArg] -- Arguments - -> Type -- Result type (always an unboxed tuple) - -> FCode ReturnKind - --- Foreign calls -cgOpApp (StgFCallOp fcall _) stg_args res_ty - = cgForeignCall fcall stg_args res_ty - -- Note [Foreign call results] - --- tagToEnum# is special: we need to pull the constructor --- out of the table, and perform an appropriate return. - -cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty - = ASSERT(isEnumerationTyCon tycon) - do { dflags <- getDynFlags - ; args' <- getNonVoidArgAmodes [arg] - ; let amode = case args' of [amode] -> amode - _ -> panic "TagToEnumOp had void arg" - ; emitReturn [tagToClosure dflags tycon amode] } - where - -- If you're reading this code in the attempt to figure - -- out why the compiler panic'ed here, it is probably because - -- you used tagToEnum# in a non-monomorphic setting, e.g., - -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# - -- That won't work. - tycon = tyConAppTyCon res_ty - -cgOpApp (StgPrimOp primop) args res_ty = do - dflags <- getDynFlags - cmm_args <- getNonVoidArgAmodes args - case shouldInlinePrimOp dflags primop cmm_args of - Nothing -> do -- out-of-line - let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) - emitCall (NativeNodeCall, NativeReturn) fun cmm_args - - Just f -- inline - | ReturnsPrim VoidRep <- result_info - -> do f [] - emitReturn [] - - | ReturnsPrim rep <- result_info - -> do dflags <- getDynFlags - res <- newTemp (primRepCmmType dflags rep) - f [res] - emitReturn [CmmReg (CmmLocal res)] - - | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon - -> do (regs, _hints) <- newUnboxedTupleRegs res_ty - f regs - emitReturn (map (CmmReg . CmmLocal) regs) - - | otherwise -> panic "cgPrimop" - where - result_info = getPrimOpResultInfo primop - -cgOpApp (StgPrimCallOp primcall) args _res_ty - = do { cmm_args <- getNonVoidArgAmodes args - ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) - ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } - --- | Interpret the argument as an unsigned value, assuming the value --- is given in two-complement form in the given width. --- --- Example: @asUnsigned W64 (-1)@ is 18446744073709551615. --- --- This function is used to work around the fact that many array --- primops take Int# arguments, but we interpret them as unsigned --- quantities in the code gen. This means that we have to be careful --- every time we work on e.g. a CmmInt literal that corresponds to the --- array size, as it might contain a negative Integer value if the --- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int# --- literal. -asUnsigned :: Width -> Integer -> Integer -asUnsigned w n = n .&. (bit (widthInBits w) - 1) - --- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use --- ByteOff (or some other fixed width signed type) to represent --- array sizes or indices. This means that these will overflow for --- large enough sizes. - --- | Decide whether an out-of-line primop should be replaced by an --- inline implementation. This might happen e.g. if there's enough --- static information, such as statically know arguments, to emit a --- more efficient implementation inline. --- --- Returns 'Nothing' if this primop should use its out-of-line --- implementation (defined elsewhere) and 'Just' together with a code --- generating function that takes the output regs as arguments --- otherwise. -shouldInlinePrimOp :: DynFlags - -> PrimOp -- ^ The primop - -> [CmmExpr] -- ^ The primop arguments - -> Maybe ([LocalReg] -> FCode ()) - -shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))] - | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) = - Just $ \ [res] -> doNewByteArrayOp res (fromInteger n) - -shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = - Just $ \ [res] -> - doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel - [ (mkIntExpr dflags (fromInteger n), - fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) - , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))), - fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags) - ] - (fromInteger n) init - -shouldInlinePrimOp _ CopyArrayOp - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = - Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) - -shouldInlinePrimOp _ CopyMutableArrayOp - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = - Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) - -shouldInlinePrimOp _ CopyArrayArrayOp - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = - Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) - -shouldInlinePrimOp _ CopyMutableArrayArrayOp - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = - Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) - -shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = - Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n) - -shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = - Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) - -shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = - Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n) - -shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = - Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) - -shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = - Just $ \ [res] -> - doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel - [ (mkIntExpr dflags (fromInteger n), - fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags) - ] - (fromInteger n) init - -shouldInlinePrimOp _ CopySmallArrayOp - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = - Just $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n) - -shouldInlinePrimOp _ CopySmallMutableArrayOp - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = - Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n) - -shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = - Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n) - -shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = - Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) - -shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = - Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n) - -shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = - Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) - -shouldInlinePrimOp dflags primop args - | primOpOutOfLine primop = Nothing - | otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args - --- TODO: Several primops, such as 'copyArray#', only have an inline --- implementation (below) but could possibly have both an inline --- implementation and an out-of-line implementation, just like --- 'newArray#'. This would lower the amount of code generated, --- hopefully without a performance impact (needs to be measured). - ---------------------------------------------------- -cgPrimOp :: [LocalReg] -- where to put the results - -> PrimOp -- the op - -> [StgArg] -- arguments - -> FCode () - -cgPrimOp results op args - = do dflags <- getDynFlags - arg_exprs <- getNonVoidArgAmodes args - emitPrimOp dflags results op arg_exprs - - ------------------------------------------------------------------------- --- Emitting code for a primop ------------------------------------------------------------------------- - -emitPrimOp :: DynFlags - -> [LocalReg] -- where to put the results - -> PrimOp -- the op - -> [CmmExpr] -- arguments - -> FCode () - --- First we handle various awkward cases specially. The remaining --- easy cases are then handled by translateOp, defined below. - -emitPrimOp _ [res] ParOp [arg] - = - -- for now, just implement this in a C function - -- later, we might want to inline it. - emitCCall - [(res,NoHint)] - (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) - [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] - -emitPrimOp dflags [res] SparkOp [arg] - = do - -- returns the value of arg in res. We're going to therefore - -- refer to arg twice (once to pass to newSpark(), and once to - -- assign to res), so put it in a temporary. - tmp <- assignTemp arg - tmp2 <- newTemp (bWord dflags) - emitCCall - [(tmp2,NoHint)] - (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) - [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] - emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) - -emitPrimOp dflags [res] GetCCSOfOp [arg] - = emitAssign (CmmLocal res) val - where - val - | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg) - | otherwise = CmmLit (zeroCLit dflags) - -emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] - = emitAssign (CmmLocal res) curCCS - -emitPrimOp dflags [res] ReadMutVarOp [mutv] - = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags)) - -emitPrimOp dflags res@[] WriteMutVarOp [mutv,var] - = do -- Without this write barrier, other CPUs may see this pointer before - -- the writes for the closure it points to have occurred. - emitPrimCall res MO_WriteBarrier [] - emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var - emitCCall - [{-no results-}] - (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) - [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)] - --- #define sizzeofByteArrayzh(r,a) \ --- r = ((StgArrBytes *)(a))->bytes -emitPrimOp dflags [res] SizeofByteArrayOp [arg] - = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags)) - --- #define sizzeofMutableByteArrayzh(r,a) \ --- r = ((StgArrBytes *)(a))->bytes -emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg] - = emitPrimOp dflags [res] SizeofByteArrayOp [arg] - --- #define getSizzeofMutableByteArrayzh(r,a) \ --- r = ((StgArrBytes *)(a))->bytes -emitPrimOp dflags [res] GetSizeofMutableByteArrayOp [arg] - = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags)) - - --- #define touchzh(o) /* nothing */ -emitPrimOp _ res@[] TouchOp args@[_arg] - = do emitPrimCall res MO_Touch args - --- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) -emitPrimOp dflags [res] ByteArrayContents_Char [arg] - = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags)) - --- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) -emitPrimOp dflags [res] StableNameToIntOp [arg] - = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags)) - --- #define eqStableNamezh(r,sn1,sn2) \ --- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) -emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] - = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ - cmmLoadIndexW dflags arg1 (fixedHdrSizeW dflags) (bWord dflags), - cmmLoadIndexW dflags arg2 (fixedHdrSizeW dflags) (bWord dflags) - ]) - -emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] - = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2]) - --- #define addrToHValuezh(r,a) r=(P_)a -emitPrimOp _ [res] AddrToAnyOp [arg] - = emitAssign (CmmLocal res) arg - --- #define hvalueToAddrzh(r, a) r=(W_)a -emitPrimOp _ [res] AnyToAddrOp [arg] - = emitAssign (CmmLocal res) arg - --- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) --- Note: argument may be tagged! -emitPrimOp dflags [res] DataToTagOp [arg] - = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg)) - -{- Freezing arrays-of-ptrs requires changing an info table, for the - benefit of the generational collector. It needs to scavenge mutable - objects, even if they are in old space. When they become immutable, - they can be removed from this scavenge list. -} - --- #define unsafeFreezzeArrayzh(r,a) --- { --- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info); --- r = a; --- } -emitPrimOp _ [res] UnsafeFreezeArrayOp [arg] - = emit $ catAGraphs - [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN0_infoLabel)), - mkAssign (CmmLocal res) arg ] -emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg] - = emit $ catAGraphs - [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN0_infoLabel)), - mkAssign (CmmLocal res) arg ] -emitPrimOp _ [res] UnsafeFreezeSmallArrayOp [arg] - = emit $ catAGraphs - [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN0_infoLabel)), - mkAssign (CmmLocal res) arg ] - --- #define unsafeFreezzeByteArrayzh(r,a) r=(a) -emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg] - = emitAssign (CmmLocal res) arg - --- Reading/writing pointer arrays - -emitPrimOp _ [res] ReadArrayOp [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp _ [res] IndexArrayOp [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp _ [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v - -emitPrimOp _ [res] IndexArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp _ [res] IndexArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp _ [res] ReadArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp _ [res] ReadArrayArrayOp_MutableByteArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp _ [res] ReadArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp _ [res] ReadArrayArrayOp_MutableArrayArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp _ [] WriteArrayArrayOp_ByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v -emitPrimOp _ [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v -emitPrimOp _ [] WriteArrayArrayOp_ArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v -emitPrimOp _ [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v - -emitPrimOp _ [res] ReadSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix -emitPrimOp _ [res] IndexSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix -emitPrimOp _ [] WriteSmallArrayOp [obj,ix,v] = doWriteSmallPtrArrayOp obj ix v - --- Getting the size of pointer arrays - -emitPrimOp dflags [res] SizeofArrayOp [arg] - = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg - (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags)) - (bWord dflags)) -emitPrimOp dflags [res] SizeofMutableArrayOp [arg] - = emitPrimOp dflags [res] SizeofArrayOp [arg] -emitPrimOp dflags [res] SizeofArrayArrayOp [arg] - = emitPrimOp dflags [res] SizeofArrayOp [arg] -emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg] - = emitPrimOp dflags [res] SizeofArrayOp [arg] - -emitPrimOp dflags [res] SizeofSmallArrayOp [arg] = - emit $ mkAssign (CmmLocal res) - (cmmLoadIndexW dflags arg - (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags)) - (bWord dflags)) -emitPrimOp dflags [res] SizeofSmallMutableArrayOp [arg] = - emitPrimOp dflags [res] SizeofSmallArrayOp [arg] - --- IndexXXXoffAddr - -emitPrimOp dflags res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp dflags res IndexOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp _ res IndexOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args -emitPrimOp _ res IndexOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args -emitPrimOp dflags res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args -emitPrimOp dflags res IndexOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args -emitPrimOp _ res IndexOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args -emitPrimOp dflags res IndexOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args -emitPrimOp dflags res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp _ res IndexOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args - --- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. - -emitPrimOp dflags res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp dflags res ReadOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp _ res ReadOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args -emitPrimOp _ res ReadOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args -emitPrimOp dflags res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args -emitPrimOp dflags res ReadOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args -emitPrimOp _ res ReadOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args -emitPrimOp dflags res ReadOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args -emitPrimOp dflags res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp _ res ReadOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args - --- IndexXXXArray - -emitPrimOp dflags res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp dflags res IndexByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp _ res IndexByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args -emitPrimOp _ res IndexByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args -emitPrimOp dflags res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args -emitPrimOp dflags res IndexByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args -emitPrimOp _ res IndexByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args -emitPrimOp dflags res IndexByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args -emitPrimOp dflags res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp _ res IndexByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args - --- ReadXXXArray, identical to IndexXXXArray. - -emitPrimOp dflags res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp dflags res ReadByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp _ res ReadByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args -emitPrimOp _ res ReadByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args -emitPrimOp dflags res ReadByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args -emitPrimOp dflags res ReadByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args -emitPrimOp _ res ReadByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args -emitPrimOp dflags res ReadByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args -emitPrimOp dflags res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp _ res ReadByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args - --- WriteXXXoffAddr - -emitPrimOp dflags res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp dflags res WriteOffAddrOp_Int args = doWriteOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteOffAddrOp_Word args = doWriteOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteOffAddrOp_Addr args = doWriteOffAddrOp Nothing (bWord dflags) res args -emitPrimOp _ res WriteOffAddrOp_Float args = doWriteOffAddrOp Nothing f32 res args -emitPrimOp _ res WriteOffAddrOp_Double args = doWriteOffAddrOp Nothing f64 res args -emitPrimOp dflags res WriteOffAddrOp_StablePtr args = doWriteOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteOffAddrOp_Int8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteOffAddrOp_Int16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args -emitPrimOp dflags res WriteOffAddrOp_Int32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp _ res WriteOffAddrOp_Int64 args = doWriteOffAddrOp Nothing b64 res args -emitPrimOp dflags res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args -emitPrimOp dflags res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp _ res WriteOffAddrOp_Word64 args = doWriteOffAddrOp Nothing b64 res args - --- WriteXXXArray - -emitPrimOp dflags res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp dflags res WriteByteArrayOp_Int args = doWriteByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteByteArrayOp_Word args = doWriteByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteByteArrayOp_Addr args = doWriteByteArrayOp Nothing (bWord dflags) res args -emitPrimOp _ res WriteByteArrayOp_Float args = doWriteByteArrayOp Nothing f32 res args -emitPrimOp _ res WriteByteArrayOp_Double args = doWriteByteArrayOp Nothing f64 res args -emitPrimOp dflags res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteByteArrayOp_Int8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteByteArrayOp_Int16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args -emitPrimOp dflags res WriteByteArrayOp_Int32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp _ res WriteByteArrayOp_Int64 args = doWriteByteArrayOp Nothing b64 res args -emitPrimOp dflags res WriteByteArrayOp_Word8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args -emitPrimOp dflags res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp _ res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing b64 res args - --- Copying and setting byte arrays -emitPrimOp _ [] CopyByteArrayOp [src,src_off,dst,dst_off,n] = - doCopyByteArrayOp src src_off dst dst_off n -emitPrimOp _ [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = - doCopyMutableByteArrayOp src src_off dst dst_off n -emitPrimOp _ [] CopyByteArrayToAddrOp [src,src_off,dst,n] = - doCopyByteArrayToAddrOp src src_off dst n -emitPrimOp _ [] CopyMutableByteArrayToAddrOp [src,src_off,dst,n] = - doCopyMutableByteArrayToAddrOp src src_off dst n -emitPrimOp _ [] CopyAddrToByteArrayOp [src,dst,dst_off,n] = - doCopyAddrToByteArrayOp src dst dst_off n -emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] = - doSetByteArrayOp ba off len c - -emitPrimOp _ [res] BSwap16Op [w] = emitBSwapCall res w W16 -emitPrimOp _ [res] BSwap32Op [w] = emitBSwapCall res w W32 -emitPrimOp _ [res] BSwap64Op [w] = emitBSwapCall res w W64 -emitPrimOp dflags [res] BSwapOp [w] = emitBSwapCall res w (wordWidth dflags) - --- Population count -emitPrimOp _ [res] PopCnt8Op [w] = emitPopCntCall res w W8 -emitPrimOp _ [res] PopCnt16Op [w] = emitPopCntCall res w W16 -emitPrimOp _ [res] PopCnt32Op [w] = emitPopCntCall res w W32 -emitPrimOp _ [res] PopCnt64Op [w] = emitPopCntCall res w W64 -emitPrimOp dflags [res] PopCntOp [w] = emitPopCntCall res w (wordWidth dflags) - --- count leading zeros -emitPrimOp _ [res] Clz8Op [w] = emitClzCall res w W8 -emitPrimOp _ [res] Clz16Op [w] = emitClzCall res w W16 -emitPrimOp _ [res] Clz32Op [w] = emitClzCall res w W32 -emitPrimOp _ [res] Clz64Op [w] = emitClzCall res w W64 -emitPrimOp dflags [res] ClzOp [w] = emitClzCall res w (wordWidth dflags) - --- count trailing zeros -emitPrimOp _ [res] Ctz8Op [w] = emitCtzCall res w W8 -emitPrimOp _ [res] Ctz16Op [w] = emitCtzCall res w W16 -emitPrimOp _ [res] Ctz32Op [w] = emitCtzCall res w W32 -emitPrimOp _ [res] Ctz64Op [w] = emitCtzCall res w W64 -emitPrimOp dflags [res] CtzOp [w] = emitCtzCall res w (wordWidth dflags) - --- Unsigned int to floating point conversions -emitPrimOp _ [res] Word2FloatOp [w] = emitPrimCall [res] - (MO_UF_Conv W32) [w] -emitPrimOp _ [res] Word2DoubleOp [w] = emitPrimCall [res] - (MO_UF_Conv W64) [w] - --- SIMD primops -emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do - checkVecCompatibility dflags vcat n w - doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res - where - zeros :: CmmExpr - zeros = CmmLit $ CmmVec (replicate n zero) - - zero :: CmmLit - zero = case vcat of - IntVec -> CmmInt 0 w - WordVec -> CmmInt 0 w - FloatVec -> CmmFloat 0 w - - ty :: CmmType - ty = vecVmmType vcat n w - -emitPrimOp dflags [res] (VecPackOp vcat n w) es = do - checkVecCompatibility dflags vcat n w - when (length es /= n) $ - panic "emitPrimOp: VecPackOp has wrong number of arguments" - doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res - where - zeros :: CmmExpr - zeros = CmmLit $ CmmVec (replicate n zero) - - zero :: CmmLit - zero = case vcat of - IntVec -> CmmInt 0 w - WordVec -> CmmInt 0 w - FloatVec -> CmmFloat 0 w - - ty :: CmmType - ty = vecVmmType vcat n w - -emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do - checkVecCompatibility dflags vcat n w - when (length res /= n) $ - panic "emitPrimOp: VecUnpackOp has wrong number of results" - doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res - where - ty :: CmmType - ty = vecVmmType vcat n w - -emitPrimOp dflags [res] (VecInsertOp vcat n w) [v,e,i] = do - checkVecCompatibility dflags vcat n w - doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res - where - ty :: CmmType - ty = vecVmmType vcat n w - -emitPrimOp dflags res (VecIndexByteArrayOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doIndexByteArrayOp Nothing ty res args - where - ty :: CmmType - ty = vecVmmType vcat n w - -emitPrimOp dflags res (VecReadByteArrayOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doIndexByteArrayOp Nothing ty res args - where - ty :: CmmType - ty = vecVmmType vcat n w - -emitPrimOp dflags res (VecWriteByteArrayOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doWriteByteArrayOp Nothing ty res args - where - ty :: CmmType - ty = vecVmmType vcat n w - -emitPrimOp dflags res (VecIndexOffAddrOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doIndexOffAddrOp Nothing ty res args - where - ty :: CmmType - ty = vecVmmType vcat n w - -emitPrimOp dflags res (VecReadOffAddrOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doIndexOffAddrOp Nothing ty res args - where - ty :: CmmType - ty = vecVmmType vcat n w - -emitPrimOp dflags res (VecWriteOffAddrOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doWriteOffAddrOp Nothing ty res args - where - ty :: CmmType - ty = vecVmmType vcat n w - -emitPrimOp dflags res (VecIndexScalarByteArrayOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doIndexByteArrayOpAs Nothing vecty ty res args - where - vecty :: CmmType - vecty = vecVmmType vcat n w - - ty :: CmmType - ty = vecCmmCat vcat w - -emitPrimOp dflags res (VecReadScalarByteArrayOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doIndexByteArrayOpAs Nothing vecty ty res args - where - vecty :: CmmType - vecty = vecVmmType vcat n w - - ty :: CmmType - ty = vecCmmCat vcat w - -emitPrimOp dflags res (VecWriteScalarByteArrayOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doWriteByteArrayOp Nothing ty res args - where - ty :: CmmType - ty = vecCmmCat vcat w - -emitPrimOp dflags res (VecIndexScalarOffAddrOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doIndexOffAddrOpAs Nothing vecty ty res args - where - vecty :: CmmType - vecty = vecVmmType vcat n w - - ty :: CmmType - ty = vecCmmCat vcat w - -emitPrimOp dflags res (VecReadScalarOffAddrOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doIndexOffAddrOpAs Nothing vecty ty res args - where - vecty :: CmmType - vecty = vecVmmType vcat n w - - ty :: CmmType - ty = vecCmmCat vcat w - -emitPrimOp dflags res (VecWriteScalarOffAddrOp vcat n w) args = do - checkVecCompatibility dflags vcat n w - doWriteOffAddrOp Nothing ty res args - where - ty :: CmmType - ty = vecCmmCat vcat w - --- Prefetch -emitPrimOp _ [] PrefetchByteArrayOp3 args = doPrefetchByteArrayOp 3 args -emitPrimOp _ [] PrefetchMutableByteArrayOp3 args = doPrefetchMutableByteArrayOp 3 args -emitPrimOp _ [] PrefetchAddrOp3 args = doPrefetchAddrOp 3 args -emitPrimOp _ [] PrefetchValueOp3 args = doPrefetchValueOp 3 args - -emitPrimOp _ [] PrefetchByteArrayOp2 args = doPrefetchByteArrayOp 2 args -emitPrimOp _ [] PrefetchMutableByteArrayOp2 args = doPrefetchMutableByteArrayOp 2 args -emitPrimOp _ [] PrefetchAddrOp2 args = doPrefetchAddrOp 2 args -emitPrimOp _ [] PrefetchValueOp2 args = doPrefetchValueOp 2 args - -emitPrimOp _ [] PrefetchByteArrayOp1 args = doPrefetchByteArrayOp 1 args -emitPrimOp _ [] PrefetchMutableByteArrayOp1 args = doPrefetchMutableByteArrayOp 1 args -emitPrimOp _ [] PrefetchAddrOp1 args = doPrefetchAddrOp 1 args -emitPrimOp _ [] PrefetchValueOp1 args = doPrefetchValueOp 1 args - -emitPrimOp _ [] PrefetchByteArrayOp0 args = doPrefetchByteArrayOp 0 args -emitPrimOp _ [] PrefetchMutableByteArrayOp0 args = doPrefetchMutableByteArrayOp 0 args -emitPrimOp _ [] PrefetchAddrOp0 args = doPrefetchAddrOp 0 args -emitPrimOp _ [] PrefetchValueOp0 args = doPrefetchValueOp 0 args - --- Atomic read-modify-write -emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] = - doAtomicRMW res AMO_Add mba ix (bWord dflags) n -emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] = - doAtomicRMW res AMO_Sub mba ix (bWord dflags) n -emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] = - doAtomicRMW res AMO_And mba ix (bWord dflags) n -emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] = - doAtomicRMW res AMO_Nand mba ix (bWord dflags) n -emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] = - doAtomicRMW res AMO_Or mba ix (bWord dflags) n -emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] = - doAtomicRMW res AMO_Xor mba ix (bWord dflags) n -emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] = - doAtomicReadByteArray res mba ix (bWord dflags) -emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] = - doAtomicWriteByteArray mba ix (bWord dflags) val -emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] = - doCasByteArray res mba ix (bWord dflags) old new - --- The rest just translate straightforwardly -emitPrimOp dflags [res] op [arg] - | nopOp op - = emitAssign (CmmLocal res) arg - - | Just (mop,rep) <- narrowOp op - = emitAssign (CmmLocal res) $ - CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]] - -emitPrimOp dflags r@[res] op args - | Just prim <- callishOp op - = do emitPrimCall r prim args - - | Just mop <- translateOp dflags op - = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in - emit stmt - -emitPrimOp dflags results op args - = case callishPrimOpSupported dflags op of - Left op -> emit $ mkUnsafeCall (PrimTarget op) results args - Right gen -> gen results args - -type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () - -callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp -callishPrimOpSupported dflags op - = case op of - IntQuotRemOp | ncg && (x86ish - || ppc) -> Left (MO_S_QuotRem (wordWidth dflags)) - | otherwise -> Right (genericIntQuotRemOp dflags) - - WordQuotRemOp | ncg && (x86ish - || ppc) -> Left (MO_U_QuotRem (wordWidth dflags)) - | otherwise -> Right (genericWordQuotRemOp dflags) - - WordQuotRem2Op | (ncg && (x86ish - || ppc)) - || llvm -> Left (MO_U_QuotRem2 (wordWidth dflags)) - | otherwise -> Right (genericWordQuotRem2Op dflags) - - WordAdd2Op | (ncg && (x86ish - || ppc)) - || llvm -> Left (MO_Add2 (wordWidth dflags)) - | otherwise -> Right genericWordAdd2Op - - WordSubCOp | (ncg && (x86ish - || ppc)) - || llvm -> Left (MO_SubWordC (wordWidth dflags)) - | otherwise -> Right genericWordSubCOp - - IntAddCOp | (ncg && (x86ish - || ppc)) - || llvm -> Left (MO_AddIntC (wordWidth dflags)) - | otherwise -> Right genericIntAddCOp - - IntSubCOp | (ncg && (x86ish - || ppc)) - || llvm -> Left (MO_SubIntC (wordWidth dflags)) - | otherwise -> Right genericIntSubCOp - - WordMul2Op | ncg && (x86ish - || ppc) - || llvm -> Left (MO_U_Mul2 (wordWidth dflags)) - | otherwise -> Right genericWordMul2Op - FloatFabsOp | (ncg && x86ish - || ppc) - || llvm -> Left MO_F32_Fabs - | otherwise -> Right $ genericFabsOp W32 - DoubleFabsOp | (ncg && x86ish - || ppc) - || llvm -> Left MO_F64_Fabs - | otherwise -> Right $ genericFabsOp W64 - - _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op) - where - ncg = case hscTarget dflags of - HscAsm -> True - _ -> False - llvm = case hscTarget dflags of - HscLlvm -> True - _ -> False - x86ish = case platformArch (targetPlatform dflags) of - ArchX86 -> True - ArchX86_64 -> True - _ -> False - ppc = case platformArch (targetPlatform dflags) of - ArchPPC -> True - ArchPPC_64 _ -> True - _ -> False - -genericIntQuotRemOp :: DynFlags -> GenericOp -genericIntQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] - = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> - mkAssign (CmmLocal res_r) - (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y]) -genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp" - -genericWordQuotRemOp :: DynFlags -> GenericOp -genericWordQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] - = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> - mkAssign (CmmLocal res_r) - (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y]) -genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp" - -genericWordQuotRem2Op :: DynFlags -> GenericOp -genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y] - = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low - where ty = cmmExprType dflags arg_x_high - shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i] - shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i] - or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] - ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y] - ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y] - minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y] - times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] - zero = lit 0 - one = lit 1 - negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1) - lit i = CmmLit (CmmInt i (wordWidth dflags)) - - f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph - f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*> - mkAssign (CmmLocal res_r) high) - f i acc high low = - do roverflowedBit <- newTemp ty - rhigh' <- newTemp ty - rhigh'' <- newTemp ty - rlow' <- newTemp ty - risge <- newTemp ty - racc' <- newTemp ty - let high' = CmmReg (CmmLocal rhigh') - isge = CmmReg (CmmLocal risge) - overflowedBit = CmmReg (CmmLocal roverflowedBit) - let this = catAGraphs - [mkAssign (CmmLocal roverflowedBit) - (shr high negone), - mkAssign (CmmLocal rhigh') - (or (shl high one) (shr low negone)), - mkAssign (CmmLocal rlow') - (shl low one), - mkAssign (CmmLocal risge) - (or (overflowedBit `ne` zero) - (high' `ge` arg_y)), - mkAssign (CmmLocal rhigh'') - (high' `minus` (arg_y `times` isge)), - mkAssign (CmmLocal racc') - (or (shl acc one) isge)] - rest <- f (i - 1) (CmmReg (CmmLocal racc')) - (CmmReg (CmmLocal rhigh'')) - (CmmReg (CmmLocal rlow')) - return (this <*> rest) -genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op" - -genericWordAdd2Op :: GenericOp -genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] - = do dflags <- getDynFlags - r1 <- newTemp (cmmExprType dflags arg_x) - r2 <- newTemp (cmmExprType dflags arg_x) - let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] - bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] - add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] - or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) - (wordWidth dflags)) - hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) - emit $ catAGraphs - [mkAssign (CmmLocal r1) - (add (bottomHalf arg_x) (bottomHalf arg_y)), - mkAssign (CmmLocal r2) - (add (topHalf (CmmReg (CmmLocal r1))) - (add (topHalf arg_x) (topHalf arg_y))), - mkAssign (CmmLocal res_h) - (topHalf (CmmReg (CmmLocal r2))), - mkAssign (CmmLocal res_l) - (or (toTopHalf (CmmReg (CmmLocal r2))) - (bottomHalf (CmmReg (CmmLocal r1))))] -genericWordAdd2Op _ _ = panic "genericWordAdd2Op" - -genericWordSubCOp :: GenericOp -genericWordSubCOp [res_r, res_c] [aa, bb] = do - dflags <- getDynFlags - emit $ catAGraphs - [ -- Put the result into 'res_r'. - mkAssign (CmmLocal res_r) $ - CmmMachOp (mo_wordSub dflags) [aa, bb] - -- Set 'res_c' to 1 if 'bb > aa' and to 0 otherwise. - , mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUGt dflags) [bb, aa] - ] -genericWordSubCOp _ _ = panic "genericWordSubCOp" - -genericIntAddCOp :: GenericOp -genericIntAddCOp [res_r, res_c] [aa, bb] -{- - With some bit-twiddling, we can define int{Add,Sub}Czh portably in - C, and without needing any comparisons. This may not be the - fastest way to do it - if you have better code, please send it! --SDM - - Return : r = a + b, c = 0 if no overflow, 1 on overflow. - - We currently don't make use of the r value if c is != 0 (i.e. - overflow), we just convert to big integers and try again. This - could be improved by making r and c the correct values for - plugging into a new J#. - - { r = ((I_)(a)) + ((I_)(b)); \ - c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - Wading through the mass of bracketry, it seems to reduce to: - c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) - --} - = do dflags <- getDynFlags - emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), - mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] -genericIntAddCOp _ _ = panic "genericIntAddCOp" - -genericIntSubCOp :: GenericOp -genericIntSubCOp [res_r, res_c] [aa, bb] -{- Similarly: - #define subIntCzh(r,c,a,b) \ - { r = ((I_)(a)) - ((I_)(b)); \ - c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - - c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) --} - = do dflags <- getDynFlags - emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), - mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordXor dflags) [aa,bb], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] -genericIntSubCOp _ _ = panic "genericIntSubCOp" - -genericWordMul2Op :: GenericOp -genericWordMul2Op [res_h, res_l] [arg_x, arg_y] - = do dflags <- getDynFlags - let t = cmmExprType dflags arg_x - xlyl <- liftM CmmLocal $ newTemp t - xlyh <- liftM CmmLocal $ newTemp t - xhyl <- liftM CmmLocal $ newTemp t - r <- liftM CmmLocal $ newTemp t - -- This generic implementation is very simple and slow. We might - -- well be able to do better, but for now this at least works. - let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] - bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] - add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] - sum = foldl1 add - mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] - or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) - (wordWidth dflags)) - hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) - emit $ catAGraphs - [mkAssign xlyl - (mul (bottomHalf arg_x) (bottomHalf arg_y)), - mkAssign xlyh - (mul (bottomHalf arg_x) (topHalf arg_y)), - mkAssign xhyl - (mul (topHalf arg_x) (bottomHalf arg_y)), - mkAssign r - (sum [topHalf (CmmReg xlyl), - bottomHalf (CmmReg xhyl), - bottomHalf (CmmReg xlyh)]), - mkAssign (CmmLocal res_l) - (or (bottomHalf (CmmReg xlyl)) - (toTopHalf (CmmReg r))), - mkAssign (CmmLocal res_h) - (sum [mul (topHalf arg_x) (topHalf arg_y), - topHalf (CmmReg xhyl), - topHalf (CmmReg xlyh), - topHalf (CmmReg r)])] -genericWordMul2Op _ _ = panic "genericWordMul2Op" - --- This replicates what we had in libraries/base/GHC/Float.hs: --- --- abs x | x == 0 = 0 -- handles (-0.0) --- | x > 0 = x --- | otherwise = negateFloat x -genericFabsOp :: Width -> GenericOp -genericFabsOp w [res_r] [aa] - = do dflags <- getDynFlags - let zero = CmmLit (CmmFloat 0 w) - - eq x y = CmmMachOp (MO_F_Eq w) [x, y] - gt x y = CmmMachOp (MO_F_Gt w) [x, y] - - neg x = CmmMachOp (MO_F_Neg w) [x] - - g1 = catAGraphs [mkAssign (CmmLocal res_r) zero] - g2 = catAGraphs [mkAssign (CmmLocal res_r) aa] - - res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa) - let g3 = catAGraphs [mkAssign res_t aa, - mkAssign (CmmLocal res_r) (neg (CmmReg res_t))] - - g4 <- mkCmmIfThenElse (gt aa zero) g2 g3 - - emit =<< mkCmmIfThenElse (eq aa zero) g1 g4 - -genericFabsOp _ _ _ = panic "genericFabsOp" - --- These PrimOps are NOPs in Cmm - -nopOp :: PrimOp -> Bool -nopOp Int2WordOp = True -nopOp Word2IntOp = True -nopOp Int2AddrOp = True -nopOp Addr2IntOp = True -nopOp ChrOp = True -- Int# and Char# are rep'd the same -nopOp OrdOp = True -nopOp _ = False - --- These PrimOps turn into double casts - -narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width) -narrowOp Narrow8IntOp = Just (MO_SS_Conv, W8) -narrowOp Narrow16IntOp = Just (MO_SS_Conv, W16) -narrowOp Narrow32IntOp = Just (MO_SS_Conv, W32) -narrowOp Narrow8WordOp = Just (MO_UU_Conv, W8) -narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16) -narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32) -narrowOp _ = Nothing - --- Native word signless ops - -translateOp :: DynFlags -> PrimOp -> Maybe MachOp -translateOp dflags IntAddOp = Just (mo_wordAdd dflags) -translateOp dflags IntSubOp = Just (mo_wordSub dflags) -translateOp dflags WordAddOp = Just (mo_wordAdd dflags) -translateOp dflags WordSubOp = Just (mo_wordSub dflags) -translateOp dflags AddrAddOp = Just (mo_wordAdd dflags) -translateOp dflags AddrSubOp = Just (mo_wordSub dflags) - -translateOp dflags IntEqOp = Just (mo_wordEq dflags) -translateOp dflags IntNeOp = Just (mo_wordNe dflags) -translateOp dflags WordEqOp = Just (mo_wordEq dflags) -translateOp dflags WordNeOp = Just (mo_wordNe dflags) -translateOp dflags AddrEqOp = Just (mo_wordEq dflags) -translateOp dflags AddrNeOp = Just (mo_wordNe dflags) - -translateOp dflags AndOp = Just (mo_wordAnd dflags) -translateOp dflags OrOp = Just (mo_wordOr dflags) -translateOp dflags XorOp = Just (mo_wordXor dflags) -translateOp dflags NotOp = Just (mo_wordNot dflags) -translateOp dflags SllOp = Just (mo_wordShl dflags) -translateOp dflags SrlOp = Just (mo_wordUShr dflags) - -translateOp dflags AddrRemOp = Just (mo_wordURem dflags) - --- Native word signed ops - -translateOp dflags IntMulOp = Just (mo_wordMul dflags) -translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags)) -translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags) -translateOp dflags IntRemOp = Just (mo_wordSRem dflags) -translateOp dflags IntNegOp = Just (mo_wordSNeg dflags) - - -translateOp dflags IntGeOp = Just (mo_wordSGe dflags) -translateOp dflags IntLeOp = Just (mo_wordSLe dflags) -translateOp dflags IntGtOp = Just (mo_wordSGt dflags) -translateOp dflags IntLtOp = Just (mo_wordSLt dflags) - -translateOp dflags AndIOp = Just (mo_wordAnd dflags) -translateOp dflags OrIOp = Just (mo_wordOr dflags) -translateOp dflags XorIOp = Just (mo_wordXor dflags) -translateOp dflags NotIOp = Just (mo_wordNot dflags) -translateOp dflags ISllOp = Just (mo_wordShl dflags) -translateOp dflags ISraOp = Just (mo_wordSShr dflags) -translateOp dflags ISrlOp = Just (mo_wordUShr dflags) - --- Native word unsigned ops - -translateOp dflags WordGeOp = Just (mo_wordUGe dflags) -translateOp dflags WordLeOp = Just (mo_wordULe dflags) -translateOp dflags WordGtOp = Just (mo_wordUGt dflags) -translateOp dflags WordLtOp = Just (mo_wordULt dflags) - -translateOp dflags WordMulOp = Just (mo_wordMul dflags) -translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags) -translateOp dflags WordRemOp = Just (mo_wordURem dflags) - -translateOp dflags AddrGeOp = Just (mo_wordUGe dflags) -translateOp dflags AddrLeOp = Just (mo_wordULe dflags) -translateOp dflags AddrGtOp = Just (mo_wordUGt dflags) -translateOp dflags AddrLtOp = Just (mo_wordULt dflags) - --- Char# ops - -translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags)) -translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags)) -translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags)) -translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags)) -translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags)) -translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags)) - --- Double ops - -translateOp _ DoubleEqOp = Just (MO_F_Eq W64) -translateOp _ DoubleNeOp = Just (MO_F_Ne W64) -translateOp _ DoubleGeOp = Just (MO_F_Ge W64) -translateOp _ DoubleLeOp = Just (MO_F_Le W64) -translateOp _ DoubleGtOp = Just (MO_F_Gt W64) -translateOp _ DoubleLtOp = Just (MO_F_Lt W64) - -translateOp _ DoubleAddOp = Just (MO_F_Add W64) -translateOp _ DoubleSubOp = Just (MO_F_Sub W64) -translateOp _ DoubleMulOp = Just (MO_F_Mul W64) -translateOp _ DoubleDivOp = Just (MO_F_Quot W64) -translateOp _ DoubleNegOp = Just (MO_F_Neg W64) - --- Float ops - -translateOp _ FloatEqOp = Just (MO_F_Eq W32) -translateOp _ FloatNeOp = Just (MO_F_Ne W32) -translateOp _ FloatGeOp = Just (MO_F_Ge W32) -translateOp _ FloatLeOp = Just (MO_F_Le W32) -translateOp _ FloatGtOp = Just (MO_F_Gt W32) -translateOp _ FloatLtOp = Just (MO_F_Lt W32) - -translateOp _ FloatAddOp = Just (MO_F_Add W32) -translateOp _ FloatSubOp = Just (MO_F_Sub W32) -translateOp _ FloatMulOp = Just (MO_F_Mul W32) -translateOp _ FloatDivOp = Just (MO_F_Quot W32) -translateOp _ FloatNegOp = Just (MO_F_Neg W32) - --- Vector ops - -translateOp _ (VecAddOp FloatVec n w) = Just (MO_VF_Add n w) -translateOp _ (VecSubOp FloatVec n w) = Just (MO_VF_Sub n w) -translateOp _ (VecMulOp FloatVec n w) = Just (MO_VF_Mul n w) -translateOp _ (VecDivOp FloatVec n w) = Just (MO_VF_Quot n w) -translateOp _ (VecNegOp FloatVec n w) = Just (MO_VF_Neg n w) - -translateOp _ (VecAddOp IntVec n w) = Just (MO_V_Add n w) -translateOp _ (VecSubOp IntVec n w) = Just (MO_V_Sub n w) -translateOp _ (VecMulOp IntVec n w) = Just (MO_V_Mul n w) -translateOp _ (VecQuotOp IntVec n w) = Just (MO_VS_Quot n w) -translateOp _ (VecRemOp IntVec n w) = Just (MO_VS_Rem n w) -translateOp _ (VecNegOp IntVec n w) = Just (MO_VS_Neg n w) - -translateOp _ (VecAddOp WordVec n w) = Just (MO_V_Add n w) -translateOp _ (VecSubOp WordVec n w) = Just (MO_V_Sub n w) -translateOp _ (VecMulOp WordVec n w) = Just (MO_V_Mul n w) -translateOp _ (VecQuotOp WordVec n w) = Just (MO_VU_Quot n w) -translateOp _ (VecRemOp WordVec n w) = Just (MO_VU_Rem n w) - --- Conversions - -translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64) -translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags)) - -translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32) -translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags)) - -translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64) -translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32) - --- Word comparisons masquerading as more exotic things. - -translateOp dflags SameMutVarOp = Just (mo_wordEq dflags) -translateOp dflags SameMVarOp = Just (mo_wordEq dflags) -translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags) -translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags) -translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags) -translateOp dflags SameSmallMutableArrayOp= Just (mo_wordEq dflags) -translateOp dflags SameTVarOp = Just (mo_wordEq dflags) -translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags) - -translateOp _ _ = Nothing - --- These primops are implemented by CallishMachOps, because they sometimes --- turn into foreign calls depending on the backend. - -callishOp :: PrimOp -> Maybe CallishMachOp -callishOp DoublePowerOp = Just MO_F64_Pwr -callishOp DoubleSinOp = Just MO_F64_Sin -callishOp DoubleCosOp = Just MO_F64_Cos -callishOp DoubleTanOp = Just MO_F64_Tan -callishOp DoubleSinhOp = Just MO_F64_Sinh -callishOp DoubleCoshOp = Just MO_F64_Cosh -callishOp DoubleTanhOp = Just MO_F64_Tanh -callishOp DoubleAsinOp = Just MO_F64_Asin -callishOp DoubleAcosOp = Just MO_F64_Acos -callishOp DoubleAtanOp = Just MO_F64_Atan -callishOp DoubleLogOp = Just MO_F64_Log -callishOp DoubleExpOp = Just MO_F64_Exp -callishOp DoubleSqrtOp = Just MO_F64_Sqrt - -callishOp FloatPowerOp = Just MO_F32_Pwr -callishOp FloatSinOp = Just MO_F32_Sin -callishOp FloatCosOp = Just MO_F32_Cos -callishOp FloatTanOp = Just MO_F32_Tan -callishOp FloatSinhOp = Just MO_F32_Sinh -callishOp FloatCoshOp = Just MO_F32_Cosh -callishOp FloatTanhOp = Just MO_F32_Tanh -callishOp FloatAsinOp = Just MO_F32_Asin -callishOp FloatAcosOp = Just MO_F32_Acos -callishOp FloatAtanOp = Just MO_F32_Atan -callishOp FloatLogOp = Just MO_F32_Log -callishOp FloatExpOp = Just MO_F32_Exp -callishOp FloatSqrtOp = Just MO_F32_Sqrt - -callishOp _ = Nothing - ------------------------------------------------------------------------------- --- Helpers for translating various minor variants of array indexing. - -doIndexOffAddrOp :: Maybe MachOp - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx] - = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx -doIndexOffAddrOp _ _ _ _ - = panic "StgCmmPrim: doIndexOffAddrOp" - -doIndexOffAddrOpAs :: Maybe MachOp - -> CmmType - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] - = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx -doIndexOffAddrOpAs _ _ _ _ _ - = panic "StgCmmPrim: doIndexOffAddrOpAs" - -doIndexByteArrayOp :: Maybe MachOp - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] - = do dflags <- getDynFlags - mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx -doIndexByteArrayOp _ _ _ _ - = panic "StgCmmPrim: doIndexByteArrayOp" - -doIndexByteArrayOpAs :: Maybe MachOp - -> CmmType - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] - = do dflags <- getDynFlags - mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx -doIndexByteArrayOpAs _ _ _ _ _ - = panic "StgCmmPrim: doIndexByteArrayOpAs" - -doReadPtrArrayOp :: LocalReg - -> CmmExpr - -> CmmExpr - -> FCode () -doReadPtrArrayOp res addr idx - = do dflags <- getDynFlags - mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx - -doWriteOffAddrOp :: Maybe MachOp - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val] - = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val -doWriteOffAddrOp _ _ _ _ - = panic "StgCmmPrim: doWriteOffAddrOp" - -doWriteByteArrayOp :: Maybe MachOp - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val] - = do dflags <- getDynFlags - mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val -doWriteByteArrayOp _ _ _ _ - = panic "StgCmmPrim: doWriteByteArrayOp" - -doWritePtrArrayOp :: CmmExpr - -> CmmExpr - -> CmmExpr - -> FCode () -doWritePtrArrayOp addr idx val - = do dflags <- getDynFlags - let ty = cmmExprType dflags val - -- This write barrier is to ensure that the heap writes to the object - -- referred to by val have happened before we write val into the array. - -- See #12469 for details. - emitPrimCall [] MO_WriteBarrier [] - mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val - emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - -- the write barrier. We must write a byte into the mark table: - -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] - emit $ mkStore ( - cmmOffsetExpr dflags - (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags)) - (loadArrPtrsSize dflags addr)) - (CmmMachOp (mo_wordUShr dflags) [idx, - mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)]) - ) (CmmLit (CmmInt 1 W8)) - -loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr -loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) - where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags - -mkBasicIndexedRead :: ByteOff -- Initial offset in bytes - -> Maybe MachOp -- Optional result cast - -> CmmType -- Type of element we are accessing - -> LocalReg -- Destination - -> CmmExpr -- Base address - -> CmmType -- Type of element by which we are indexing - -> CmmExpr -- Index - -> FCode () -mkBasicIndexedRead off Nothing ty res base idx_ty idx - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx) -mkBasicIndexedRead off (Just cast) ty res base idx_ty idx - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (CmmMachOp cast [ - cmmLoadIndexOffExpr dflags off ty base idx_ty idx]) - -mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes - -> Maybe MachOp -- Optional value cast - -> CmmExpr -- Base address - -> CmmType -- Type of element by which we are indexing - -> CmmExpr -- Index - -> CmmExpr -- Value to write - -> FCode () -mkBasicIndexedWrite off Nothing base idx_ty idx val - = do dflags <- getDynFlags - emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val -mkBasicIndexedWrite off (Just cast) base idx_ty idx val - = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val]) - --- ---------------------------------------------------------------------------- --- Misc utils - -cmmIndexOffExpr :: DynFlags - -> ByteOff -- Initial offset in bytes - -> Width -- Width of element by which we are indexing - -> CmmExpr -- Base address - -> CmmExpr -- Index - -> CmmExpr -cmmIndexOffExpr dflags off width base idx - = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx - -cmmLoadIndexOffExpr :: DynFlags - -> ByteOff -- Initial offset in bytes - -> CmmType -- Type of element we are accessing - -> CmmExpr -- Base address - -> CmmType -- Type of element by which we are indexing - -> CmmExpr -- Index - -> CmmExpr -cmmLoadIndexOffExpr dflags off ty base idx_ty idx - = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty - -setInfo :: CmmExpr -> CmmExpr -> CmmAGraph -setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr - ------------------------------------------------------------------------------- --- Helpers for translating vector primops. - -vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType -vecVmmType pocat n w = vec n (vecCmmCat pocat w) - -vecCmmCat :: PrimOpVecCat -> Width -> CmmType -vecCmmCat IntVec = cmmBits -vecCmmCat WordVec = cmmBits -vecCmmCat FloatVec = cmmFloat - -vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp -vecElemInjectCast _ FloatVec _ = Nothing -vecElemInjectCast dflags IntVec W8 = Just (mo_WordTo8 dflags) -vecElemInjectCast dflags IntVec W16 = Just (mo_WordTo16 dflags) -vecElemInjectCast dflags IntVec W32 = Just (mo_WordTo32 dflags) -vecElemInjectCast _ IntVec W64 = Nothing -vecElemInjectCast dflags WordVec W8 = Just (mo_WordTo8 dflags) -vecElemInjectCast dflags WordVec W16 = Just (mo_WordTo16 dflags) -vecElemInjectCast dflags WordVec W32 = Just (mo_WordTo32 dflags) -vecElemInjectCast _ WordVec W64 = Nothing -vecElemInjectCast _ _ _ = Nothing - -vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp -vecElemProjectCast _ FloatVec _ = Nothing -vecElemProjectCast dflags IntVec W8 = Just (mo_s_8ToWord dflags) -vecElemProjectCast dflags IntVec W16 = Just (mo_s_16ToWord dflags) -vecElemProjectCast dflags IntVec W32 = Just (mo_s_32ToWord dflags) -vecElemProjectCast _ IntVec W64 = Nothing -vecElemProjectCast dflags WordVec W8 = Just (mo_u_8ToWord dflags) -vecElemProjectCast dflags WordVec W16 = Just (mo_u_16ToWord dflags) -vecElemProjectCast dflags WordVec W32 = Just (mo_u_32ToWord dflags) -vecElemProjectCast _ WordVec W64 = Nothing -vecElemProjectCast _ _ _ = Nothing - --- Check to make sure that we can generate code for the specified vector type --- given the current set of dynamic flags. -checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () -checkVecCompatibility dflags vcat l w = do - when (hscTarget dflags /= HscLlvm) $ do - sorry $ unlines ["SIMD vector instructions require the LLVM back-end." - ,"Please use -fllvm."] - check vecWidth vcat l w - where - check :: Width -> PrimOpVecCat -> Length -> Width -> FCode () - check W128 FloatVec 4 W32 | not (isSseEnabled dflags) = - sorry $ "128-bit wide single-precision floating point " ++ - "SIMD vector instructions require at least -msse." - check W128 _ _ _ | not (isSse2Enabled dflags) = - sorry $ "128-bit wide integer and double precision " ++ - "SIMD vector instructions require at least -msse2." - check W256 FloatVec _ _ | not (isAvxEnabled dflags) = - sorry $ "256-bit wide floating point " ++ - "SIMD vector instructions require at least -mavx." - check W256 _ _ _ | not (isAvx2Enabled dflags) = - sorry $ "256-bit wide integer " ++ - "SIMD vector instructions require at least -mavx2." - check W512 _ _ _ | not (isAvx512fEnabled dflags) = - sorry $ "512-bit wide " ++ - "SIMD vector instructions require -mavx512f." - check _ _ _ _ = return () - - vecWidth = typeWidth (vecVmmType vcat l w) - ------------------------------------------------------------------------------- --- Helpers for translating vector packing and unpacking. - -doVecPackOp :: Maybe MachOp -- Cast from element to vector component - -> CmmType -- Type of vector - -> CmmExpr -- Initial vector - -> [CmmExpr] -- Elements - -> CmmFormal -- Destination for result - -> FCode () -doVecPackOp maybe_pre_write_cast ty z es res = do - dst <- newTemp ty - emitAssign (CmmLocal dst) z - vecPack dst es 0 - where - vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode () - vecPack src [] _ = - emitAssign (CmmLocal res) (CmmReg (CmmLocal src)) - - vecPack src (e : es) i = do - dst <- newTemp ty - if isFloatType (vecElemType ty) - then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid) - [CmmReg (CmmLocal src), cast e, iLit]) - else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid) - [CmmReg (CmmLocal src), cast e, iLit]) - vecPack dst es (i + 1) - where - -- vector indices are always 32-bits - iLit = CmmLit (CmmInt (toInteger i) W32) - - cast :: CmmExpr -> CmmExpr - cast val = case maybe_pre_write_cast of - Nothing -> val - Just cast -> CmmMachOp cast [val] - - len :: Length - len = vecLength ty - - wid :: Width - wid = typeWidth (vecElemType ty) - -doVecUnpackOp :: Maybe MachOp -- Cast from vector component to element result - -> CmmType -- Type of vector - -> CmmExpr -- Vector - -> [CmmFormal] -- Element results - -> FCode () -doVecUnpackOp maybe_post_read_cast ty e res = - vecUnpack res 0 - where - vecUnpack :: [CmmFormal] -> Int -> FCode () - vecUnpack [] _ = - return () - - vecUnpack (r : rs) i = do - if isFloatType (vecElemType ty) - then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid) - [e, iLit])) - else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid) - [e, iLit])) - vecUnpack rs (i + 1) - where - -- vector indices are always 32-bits - iLit = CmmLit (CmmInt (toInteger i) W32) - - cast :: CmmExpr -> CmmExpr - cast val = case maybe_post_read_cast of - Nothing -> val - Just cast -> CmmMachOp cast [val] - - len :: Length - len = vecLength ty - - wid :: Width - wid = typeWidth (vecElemType ty) - -doVecInsertOp :: Maybe MachOp -- Cast from element to vector component - -> CmmType -- Vector type - -> CmmExpr -- Source vector - -> CmmExpr -- Element - -> CmmExpr -- Index at which to insert element - -> CmmFormal -- Destination for result - -> FCode () -doVecInsertOp maybe_pre_write_cast ty src e idx res = do - dflags <- getDynFlags - -- vector indices are always 32-bits - let idx' :: CmmExpr - idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx] - if isFloatType (vecElemType ty) - then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx']) - else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx']) - where - cast :: CmmExpr -> CmmExpr - cast val = case maybe_pre_write_cast of - Nothing -> val - Just cast -> CmmMachOp cast [val] - - len :: Length - len = vecLength ty - - wid :: Width - wid = typeWidth (vecElemType ty) - ------------------------------------------------------------------------------- --- Helpers for translating prefetching. - - --- | Translate byte array prefetch operations into proper primcalls. -doPrefetchByteArrayOp :: Int - -> [CmmExpr] - -> FCode () -doPrefetchByteArrayOp locality [addr,idx] - = do dflags <- getDynFlags - mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx -doPrefetchByteArrayOp _ _ - = panic "StgCmmPrim: doPrefetchByteArrayOp" - --- | Translate mutable byte array prefetch operations into proper primcalls. -doPrefetchMutableByteArrayOp :: Int - -> [CmmExpr] - -> FCode () -doPrefetchMutableByteArrayOp locality [addr,idx] - = do dflags <- getDynFlags - mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx -doPrefetchMutableByteArrayOp _ _ - = panic "StgCmmPrim: doPrefetchByteArrayOp" - --- | Translate address prefetch operations into proper primcalls. -doPrefetchAddrOp ::Int - -> [CmmExpr] - -> FCode () -doPrefetchAddrOp locality [addr,idx] - = mkBasicPrefetch locality 0 addr idx -doPrefetchAddrOp _ _ - = panic "StgCmmPrim: doPrefetchAddrOp" - --- | Translate value prefetch operations into proper primcalls. -doPrefetchValueOp :: Int - -> [CmmExpr] - -> FCode () -doPrefetchValueOp locality [addr] - = do dflags <- getDynFlags - mkBasicPrefetch locality 0 addr (CmmLit (CmmInt 0 (wordWidth dflags))) -doPrefetchValueOp _ _ - = panic "StgCmmPrim: doPrefetchValueOp" - --- | helper to generate prefetch primcalls -mkBasicPrefetch :: Int -- Locality level 0-3 - -> ByteOff -- Initial offset in bytes - -> CmmExpr -- Base address - -> CmmExpr -- Index - -> FCode () -mkBasicPrefetch locality off base idx - = do dflags <- getDynFlags - emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx] - return () - --- ---------------------------------------------------------------------------- --- Allocating byte arrays - --- | Takes a register to return the newly allocated array in and the --- size of the new array in bytes. Allocates a new --- 'MutableByteArray#'. -doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode () -doNewByteArrayOp res_r n = do - dflags <- getDynFlags - - let info_ptr = mkLblExpr mkArrWords_infoLabel - rep = arrWordsRep dflags n - - tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags)) - (mkIntExpr dflags (nonHdrSize dflags rep)) - (zeroExpr dflags) - - let hdr_size = fixedHdrSize dflags - - base <- allocHeapClosure rep info_ptr curCCS - [ (mkIntExpr dflags n, - hdr_size + oFFSET_StgArrBytes_bytes dflags) - ] - - emit $ mkAssign (CmmLocal res_r) base - --- ---------------------------------------------------------------------------- --- Copying byte arrays - --- | Takes a source 'ByteArray#', an offset in the source array, a --- destination 'MutableByteArray#', an offset into the destination --- array, and the number of bytes to copy. Copies the given number of --- bytes from the source array to the destination array. -doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCopyByteArrayOp = emitCopyByteArray copy - where - -- Copy data (we assume the arrays aren't overlapping since - -- they're of different types) - copy _src _dst dst_p src_p bytes = - emitMemcpyCall dst_p src_p bytes 1 - --- | Takes a source 'MutableByteArray#', an offset in the source --- array, a destination 'MutableByteArray#', an offset into the --- destination array, and the number of bytes to copy. Copies the --- given number of bytes from the source array to the destination --- array. -doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCopyMutableByteArrayOp = emitCopyByteArray copy - where - -- The only time the memory might overlap is when the two arrays - -- we were provided are the same array! - -- TODO: Optimize branch for common case of no aliasing. - copy src dst dst_p src_p bytes = do - dflags <- getDynFlags - [moveCall, cpyCall] <- forkAlts [ - getCode $ emitMemmoveCall dst_p src_p bytes 1, - getCode $ emitMemcpyCall dst_p src_p bytes 1 - ] - emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall - -emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode ()) - -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -emitCopyByteArray copy src src_off dst dst_off n = do - dflags <- getDynFlags - dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off - src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off - copy src dst dst_p src_p n - --- | Takes a source 'ByteArray#', an offset in the source array, a --- destination 'Addr#', and the number of bytes to copy. Copies the given --- number of bytes from the source array to the destination memory region. -doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () -doCopyByteArrayToAddrOp src src_off dst_p bytes = do - -- Use memcpy (we are allowed to assume the arrays aren't overlapping) - dflags <- getDynFlags - src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off - emitMemcpyCall dst_p src_p bytes 1 - --- | Takes a source 'MutableByteArray#', an offset in the source array, a --- destination 'Addr#', and the number of bytes to copy. Copies the given --- number of bytes from the source array to the destination memory region. -doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp - --- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into --- the destination array, and the number of bytes to copy. Copies the given --- number of bytes from the source memory region to the destination array. -doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () -doCopyAddrToByteArrayOp src_p dst dst_off bytes = do - -- Use memcpy (we are allowed to assume the arrays aren't overlapping) - dflags <- getDynFlags - dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off - emitMemcpyCall dst_p src_p bytes 1 - - --- ---------------------------------------------------------------------------- --- Setting byte arrays - --- | Takes a 'MutableByteArray#', an offset into the array, a length, --- and a byte, and sets each of the selected bytes in the array to the --- character. -doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doSetByteArrayOp ba off len c - = do dflags <- getDynFlags - p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off - emitMemsetCall p c len 1 - --- ---------------------------------------------------------------------------- --- Allocating arrays - --- | Allocate a new array. -doNewArrayOp :: CmmFormal -- ^ return register - -> SMRep -- ^ representation of the array - -> CLabel -- ^ info pointer - -> [(CmmExpr, ByteOff)] -- ^ header payload - -> WordOff -- ^ array size - -> CmmExpr -- ^ initial element - -> FCode () -doNewArrayOp res_r rep info payload n init = do - dflags <- getDynFlags - - let info_ptr = mkLblExpr info - - tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep)) - (mkIntExpr dflags (nonHdrSize dflags rep)) - (zeroExpr dflags) - - base <- allocHeapClosure rep info_ptr curCCS payload - - arr <- CmmLocal `fmap` newTemp (bWord dflags) - emit $ mkAssign arr base - - -- Initialise all elements of the the array - p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep) - for <- newBlockId - emitLabel for - let loopBody = - [ mkStore (CmmReg (CmmLocal p)) init - , mkAssign (CmmLocal p) (cmmOffsetW dflags (CmmReg (CmmLocal p)) 1) - , mkBranch for ] - emit =<< mkCmmIfThen - (cmmULtWord dflags (CmmReg (CmmLocal p)) - (cmmOffsetW dflags (CmmReg arr) - (hdrSizeW dflags rep + n))) - (catAGraphs loopBody) - - emit $ mkAssign (CmmLocal res_r) (CmmReg arr) - --- ---------------------------------------------------------------------------- --- Copying pointer arrays - --- EZY: This code has an unusually high amount of assignTemp calls, seen --- nowhere else in the code generator. This is mostly because these --- "primitive" ops result in a surprisingly large amount of code. It --- will likely be worthwhile to optimize what is emitted here, so that --- our optimization passes don't waste time repeatedly optimizing the --- same bits of code. - --- More closely imitates 'assignTemp' from the old code generator, which --- returns a CmmExpr rather than a LocalReg. -assignTempE :: CmmExpr -> FCode CmmExpr -assignTempE e = do - t <- assignTemp e - return (CmmReg (CmmLocal t)) - --- | Takes a source 'Array#', an offset in the source array, a --- destination 'MutableArray#', an offset into the destination array, --- and the number of elements to copy. Copies the given number of --- elements from the source array to the destination array. -doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopyArrayOp = emitCopyArray copy - where - -- Copy data (we assume the arrays aren't overlapping since - -- they're of different types) - copy _src _dst dst_p src_p bytes = - do dflags <- getDynFlags - emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) - (wORD_SIZE dflags) - - --- | Takes a source 'MutableArray#', an offset in the source array, a --- destination 'MutableArray#', an offset into the destination array, --- and the number of elements to copy. Copies the given number of --- elements from the source array to the destination array. -doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopyMutableArrayOp = emitCopyArray copy - where - -- The only time the memory might overlap is when the two arrays - -- we were provided are the same array! - -- TODO: Optimize branch for common case of no aliasing. - copy src dst dst_p src_p bytes = do - dflags <- getDynFlags - [moveCall, cpyCall] <- forkAlts [ - getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes) - (wORD_SIZE dflags), - getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) - (wORD_SIZE dflags) - ] - emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall - -emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff - -> FCode ()) -- ^ copy function - -> CmmExpr -- ^ source array - -> CmmExpr -- ^ offset in source array - -> CmmExpr -- ^ destination array - -> CmmExpr -- ^ offset in destination array - -> WordOff -- ^ number of elements to copy - -> FCode () -emitCopyArray copy src0 src_off dst0 dst_off0 n = do - dflags <- getDynFlags - when (n /= 0) $ do - -- Passed as arguments (be careful) - src <- assignTempE src0 - dst <- assignTempE dst0 - dst_off <- assignTempE dst_off0 - - -- Set the dirty bit in the header. - emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - - dst_elems_p <- assignTempE $ cmmOffsetB dflags dst - (arrPtrsHdrSize dflags) - dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off - src_p <- assignTempE $ cmmOffsetExprW dflags - (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off - let bytes = wordsToBytes dflags n - - copy src dst dst_p src_p bytes - - -- The base address of the destination card table - dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p - (loadArrPtrsSize dflags dst) - - emitSetCards dst_off dst_cards_p n - -doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopySmallArrayOp = emitCopySmallArray copy - where - -- Copy data (we assume the arrays aren't overlapping since - -- they're of different types) - copy _src _dst dst_p src_p bytes = - do dflags <- getDynFlags - emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) - (wORD_SIZE dflags) - - -doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopySmallMutableArrayOp = emitCopySmallArray copy - where - -- The only time the memory might overlap is when the two arrays - -- we were provided are the same array! - -- TODO: Optimize branch for common case of no aliasing. - copy src dst dst_p src_p bytes = do - dflags <- getDynFlags - [moveCall, cpyCall] <- forkAlts - [ getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes) - (wORD_SIZE dflags) - , getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) - (wORD_SIZE dflags) - ] - emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall - -emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff - -> FCode ()) -- ^ copy function - -> CmmExpr -- ^ source array - -> CmmExpr -- ^ offset in source array - -> CmmExpr -- ^ destination array - -> CmmExpr -- ^ offset in destination array - -> WordOff -- ^ number of elements to copy - -> FCode () -emitCopySmallArray copy src0 src_off dst0 dst_off n = do - dflags <- getDynFlags - - -- Passed as arguments (be careful) - src <- assignTempE src0 - dst <- assignTempE dst0 - - -- Set the dirty bit in the header. - emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) - - dst_p <- assignTempE $ cmmOffsetExprW dflags - (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off - src_p <- assignTempE $ cmmOffsetExprW dflags - (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off - let bytes = wordsToBytes dflags n - - copy src dst dst_p src_p bytes - --- | Takes an info table label, a register to return the newly --- allocated array in, a source array, an offset in the source array, --- and the number of elements to copy. Allocates a new array and --- initializes it from the source array. -emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -emitCloneArray info_p res_r src src_off n = do - dflags <- getDynFlags - - let info_ptr = mkLblExpr info_p - rep = arrPtrsRep dflags n - - tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags)) - (mkIntExpr dflags (nonHdrSize dflags rep)) - (zeroExpr dflags) - - let hdr_size = fixedHdrSize dflags - - base <- allocHeapClosure rep info_ptr curCCS - [ (mkIntExpr dflags n, - hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags) - , (mkIntExpr dflags (nonHdrSizeW rep), - hdr_size + oFFSET_StgMutArrPtrs_size dflags) - ] - - arr <- CmmLocal `fmap` newTemp (bWord dflags) - emit $ mkAssign arr base - - dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr) - (arrPtrsHdrSize dflags) - src_p <- assignTempE $ cmmOffsetExprW dflags src - (cmmAddWord dflags - (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off) - - emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n)) - (wORD_SIZE dflags) - - emit $ mkAssign (CmmLocal res_r) (CmmReg arr) - --- | Takes an info table label, a register to return the newly --- allocated array in, a source array, an offset in the source array, --- and the number of elements to copy. Allocates a new array and --- initializes it from the source array. -emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -emitCloneSmallArray info_p res_r src src_off n = do - dflags <- getDynFlags - - let info_ptr = mkLblExpr info_p - rep = smallArrPtrsRep n - - tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags)) - (mkIntExpr dflags (nonHdrSize dflags rep)) - (zeroExpr dflags) - - let hdr_size = fixedHdrSize dflags - - base <- allocHeapClosure rep info_ptr curCCS - [ (mkIntExpr dflags n, - hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags) - ] - - arr <- CmmLocal `fmap` newTemp (bWord dflags) - emit $ mkAssign arr base - - dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr) - (smallArrPtrsHdrSize dflags) - src_p <- assignTempE $ cmmOffsetExprW dflags src - (cmmAddWord dflags - (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off) - - emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n)) - (wORD_SIZE dflags) - - emit $ mkAssign (CmmLocal res_r) (CmmReg arr) - --- | Takes and offset in the destination array, the base address of --- the card table, and the number of elements affected (*not* the --- number of cards). The number of elements may not be zero. --- Marks the relevant cards as dirty. -emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode () -emitSetCards dst_start dst_cards_start n = do - dflags <- getDynFlags - start_card <- assignTempE $ cardCmm dflags dst_start - let end_card = cardCmm dflags - (cmmSubWord dflags - (cmmAddWord dflags dst_start (mkIntExpr dflags n)) - (mkIntExpr dflags 1)) - emitMemsetCall (cmmAddWord dflags dst_cards_start start_card) - (mkIntExpr dflags 1) - (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1)) - 1 -- no alignment (1 byte) - --- Convert an element index to a card index -cardCmm :: DynFlags -> CmmExpr -> CmmExpr -cardCmm dflags i = - cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)) - ------------------------------------------------------------------------------- --- SmallArray PrimOp implementations - -doReadSmallPtrArrayOp :: LocalReg - -> CmmExpr - -> CmmExpr - -> FCode () -doReadSmallPtrArrayOp res addr idx = do - dflags <- getDynFlags - mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr - (gcWord dflags) idx - -doWriteSmallPtrArrayOp :: CmmExpr - -> CmmExpr - -> CmmExpr - -> FCode () -doWriteSmallPtrArrayOp addr idx val = do - dflags <- getDynFlags - let ty = cmmExprType dflags val - mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val - emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) - ------------------------------------------------------------------------------- --- Atomic read-modify-write - --- | Emit an atomic modification to a byte array element. The result --- reg contains that previous value of the element. Implies a full --- memory barrier. -doAtomicRMW :: LocalReg -- ^ Result reg - -> AtomicMachOp -- ^ Atomic op (e.g. add) - -> CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> CmmExpr -- ^ Op argument (e.g. amount to add) - -> FCode () -doAtomicRMW res amop mba idx idx_ty n = do - dflags <- getDynFlags - let width = typeWidth idx_ty - addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) - width mba idx - emitPrimCall - [ res ] - (MO_AtomicRMW width amop) - [ addr, n ] - --- | Emit an atomic read to a byte array that acts as a memory barrier. -doAtomicReadByteArray - :: LocalReg -- ^ Result reg - -> CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> FCode () -doAtomicReadByteArray res mba idx idx_ty = do - dflags <- getDynFlags - let width = typeWidth idx_ty - addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) - width mba idx - emitPrimCall - [ res ] - (MO_AtomicRead width) - [ addr ] - --- | Emit an atomic write to a byte array that acts as a memory barrier. -doAtomicWriteByteArray - :: CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> CmmExpr -- ^ Value to write - -> FCode () -doAtomicWriteByteArray mba idx idx_ty val = do - dflags <- getDynFlags - let width = typeWidth idx_ty - addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) - width mba idx - emitPrimCall - [ {- no results -} ] - (MO_AtomicWrite width) - [ addr, val ] - -doCasByteArray - :: LocalReg -- ^ Result reg - -> CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> CmmExpr -- ^ Old value - -> CmmExpr -- ^ New value - -> FCode () -doCasByteArray res mba idx idx_ty old new = do - dflags <- getDynFlags - let width = (typeWidth idx_ty) - addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) - width mba idx - emitPrimCall - [ res ] - (MO_Cmpxchg width) - [ addr, old, new ] - ------------------------------------------------------------------------------- --- Helpers for emitting function calls - --- | Emit a call to @memcpy@. -emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode () -emitMemcpyCall dst src n align = do - emitPrimCall - [ {-no results-} ] - (MO_Memcpy align) - [ dst, src, n ] - --- | Emit a call to @memmove@. -emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode () -emitMemmoveCall dst src n align = do - emitPrimCall - [ {- no results -} ] - (MO_Memmove align) - [ dst, src, n ] - --- | Emit a call to @memset@. The second argument must fit inside an --- unsigned char. -emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode () -emitMemsetCall dst c n align = do - emitPrimCall - [ {- no results -} ] - (MO_Memset align) - [ dst, c, n ] - -emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitBSwapCall res x width = do - emitPrimCall - [ res ] - (MO_BSwap width) - [ x ] - -emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitPopCntCall res x width = do - emitPrimCall - [ res ] - (MO_PopCnt width) - [ x ] - -emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitClzCall res x width = do - emitPrimCall - [ res ] - (MO_Clz width) - [ x ] - -emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitCtzCall res x width = do - emitPrimCall - [ res ] - (MO_Ctz width) - [ x ] diff --git a/codeGen/StgCmmProf.hs b/codeGen/StgCmmProf.hs deleted file mode 100644 --- a/codeGen/StgCmmProf.hs +++ /dev/null @@ -1,366 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Code generation for profiling --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module StgCmmProf ( - initCostCentres, ccType, ccsType, - mkCCostCentre, mkCCostCentreStack, - - -- Cost-centre Profiling - dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, - enterCostCentreThunk, enterCostCentreFun, - costCentreFrom, - curCCS, storeCurCCS, - emitSetCCC, - - saveCurrentCostCentre, restoreCurrentCostCentre, - - -- Lag/drag/void stuff - ldvEnter, ldvEnterClosure, ldvRecordCreate - ) where - -#include "HsVersions.h" - -import StgCmmClosure -import StgCmmUtils -import StgCmmMonad -import SMRep - -import MkGraph -import Cmm -import CmmUtils -import CLabel - -import qualified Module -import CostCentre -import DynFlags -import FastString -import Module -import Outputable - -import Control.Monad -import Data.Char (ord) - ------------------------------------------------------------------------------ --- --- Cost-centre-stack Profiling --- ------------------------------------------------------------------------------ - --- Expression representing the current cost centre stack -ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack -ccsType = bWord - -ccType :: DynFlags -> CmmType -- Type of a cost centre -ccType = bWord - -curCCS :: CmmExpr -curCCS = CmmReg (CmmGlobal CCCS) - -storeCurCCS :: CmmExpr -> CmmAGraph -storeCurCCS e = mkAssign (CmmGlobal CCCS) e - -mkCCostCentre :: CostCentre -> CmmLit -mkCCostCentre cc = CmmLabel (mkCCLabel cc) - -mkCCostCentreStack :: CostCentreStack -> CmmLit -mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) - -costCentreFrom :: DynFlags - -> CmmExpr -- A closure pointer - -> CmmExpr -- The cost centre from that closure -costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags) - --- | The profiling header words in a static closure -staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -staticProfHdr dflags ccs - = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags] - --- | Profiling header words in a dynamic closure -dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] - --- | Initialise the profiling field of an update frame -initUpdFrameProf :: CmmExpr -> FCode () -initUpdFrameProf frame - = ifProfiling $ -- frame->header.prof.ccs = CCCS - do dflags <- getDynFlags - emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS - -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) - -- is unnecessary because it is not used anyhow. - ---------------------------------------------------------------------------- --- Saving and restoring the current cost centre ---------------------------------------------------------------------------- - -{- Note [Saving the current cost centre] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The current cost centre is like a global register. Like other -global registers, it's a caller-saves one. But consider - case (f x) of (p,q) -> rhs -Since 'f' may set the cost centre, we must restore it -before resuming rhs. So we want code like this: - local_cc = CCC -- save - r = f( x ) - CCC = local_cc -- restore -That is, we explicitly "save" the current cost centre in -a LocalReg, local_cc; and restore it after the call. The -C-- infrastructure will arrange to save local_cc across the -call. - -The same goes for join points; - let j x = join-stuff - in blah-blah -We want this kind of code: - local_cc = CCC -- save - blah-blah - J: - CCC = local_cc -- restore --} - -saveCurrentCostCentre :: FCode (Maybe LocalReg) - -- Returns Nothing if profiling is off -saveCurrentCostCentre - = do dflags <- getDynFlags - if not (gopt Opt_SccProfilingOn dflags) - then return Nothing - else do local_cc <- newTemp (ccType dflags) - emitAssign (CmmLocal local_cc) curCCS - return (Just local_cc) - -restoreCurrentCostCentre :: Maybe LocalReg -> FCode () -restoreCurrentCostCentre Nothing - = return () -restoreCurrentCostCentre (Just local_cc) - = emit (storeCurCCS (CmmReg (CmmLocal local_cc))) - - -------------------------------------------------------------------------------- --- Recording allocation in a cost centre -------------------------------------------------------------------------------- - --- | Record the allocation of a closure. The CmmExpr is the cost --- centre stack to which to attribute the allocation. -profDynAlloc :: SMRep -> CmmExpr -> FCode () -profDynAlloc rep ccs - = ifProfiling $ - do dflags <- getDynFlags - profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs - --- | Record the allocation of a closure (size is given by a CmmExpr) --- The size must be in words, because the allocation counter in a CCS counts --- in words. -profAlloc :: CmmExpr -> CmmExpr -> FCode () -profAlloc words ccs - = ifProfiling $ - do dflags <- getDynFlags - let alloc_rep = rEP_CostCentreStack_mem_alloc dflags - emit (addToMemE alloc_rep - (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags)) - (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $ - [CmmMachOp (mo_wordSub dflags) [words, - mkIntExpr dflags (profHdrSize dflags)]])) - -- subtract the "profiling overhead", which is the - -- profiling header in a closure. - --- ----------------------------------------------------------------------- --- Setting the current cost centre on entry to a closure - -enterCostCentreThunk :: CmmExpr -> FCode () -enterCostCentreThunk closure = - ifProfiling $ do - dflags <- getDynFlags - emit $ storeCurCCS (costCentreFrom dflags closure) - -enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () -enterCostCentreFun ccs closure = - ifProfiling $ do - if isCurrentCCS ccs - then do dflags <- getDynFlags - emitRtsCall rtsUnitId (fsLit "enterFunCCS") - [(CmmReg (CmmGlobal BaseReg), AddrHint), - (costCentreFrom dflags closure, AddrHint)] False - else return () -- top-level function, nothing to do - -ifProfiling :: FCode () -> FCode () -ifProfiling code - = do dflags <- getDynFlags - if gopt Opt_SccProfilingOn dflags - then code - else return () - -ifProfilingL :: DynFlags -> [a] -> [a] -ifProfilingL dflags xs - | gopt Opt_SccProfilingOn dflags = xs - | otherwise = [] - - ---------------------------------------------------------------- --- Initialising Cost Centres & CCSs ---------------------------------------------------------------- - -initCostCentres :: CollectedCCs -> FCode () --- Emit the declarations -initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) - = do dflags <- getDynFlags - when (gopt Opt_SccProfilingOn dflags) $ - do mapM_ emitCostCentreDecl local_CCs - mapM_ emitCostCentreStackDecl singleton_CCSs - - -emitCostCentreDecl :: CostCentre -> FCode () -emitCostCentreDecl cc = do - { dflags <- getDynFlags - ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF - | otherwise = zero dflags - -- NB. bytesFS: we want the UTF-8 bytes here (#5559) - ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) - ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS - $ Module.moduleName - $ cc_mod cc) - ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ - showPpr dflags (costCentreSrcSpan cc) - -- XXX going via FastString to get UTF-8 encoding is silly - ; let - lits = [ zero dflags, -- StgInt ccID, - label, -- char *label, - modl, -- char *module, - loc, -- char *srcloc, - zero64, -- StgWord64 mem_alloc - zero dflags, -- StgWord time_ticks - is_caf, -- StgInt is_caf - zero dflags -- struct _CostCentre *link - ] - ; emitDataLits (mkCCLabel cc) lits - } - -emitCostCentreStackDecl :: CostCentreStack -> FCode () -emitCostCentreStackDecl ccs - = case maybeSingletonCCS ccs of - Just cc -> - do dflags <- getDynFlags - let mk_lits cc = zero dflags : - mkCCostCentre cc : - replicate (sizeof_ccs_words dflags - 2) (zero dflags) - -- Note: to avoid making any assumptions about how the - -- C compiler (that compiles the RTS, in particular) does - -- layouts of structs containing long-longs, simply - -- pad out the struct with zero words until we hit the - -- size of the overall struct (which we get via DerivedConstants.h) - emitDataLits (mkCCSLabel ccs) (mk_lits cc) - Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) - -zero :: DynFlags -> CmmLit -zero dflags = mkIntCLit dflags 0 -zero64 :: CmmLit -zero64 = CmmInt 0 W64 - -sizeof_ccs_words :: DynFlags -> Int -sizeof_ccs_words dflags - -- round up to the next word. - | ms == 0 = ws - | otherwise = ws + 1 - where - (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags - --- --------------------------------------------------------------------------- --- Set the current cost centre stack - -emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () -emitSetCCC cc tick push - = do dflags <- getDynFlags - if not (gopt Opt_SccProfilingOn dflags) - then return () - else do tmp <- newTemp (ccsType dflags) - pushCostCentre tmp curCCS cc - when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp))) - when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) - -pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () -pushCostCentre result ccs cc - = emitRtsCallWithResult result AddrHint - rtsUnitId - (fsLit "pushCostCentre") [(ccs,AddrHint), - (CmmLit (mkCCostCentre cc), AddrHint)] - False - -bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph -bumpSccCount dflags ccs - = addToMem (rEP_CostCentreStack_scc_count dflags) - (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 - ------------------------------------------------------------------------------ --- --- Lag/drag/void stuff --- ------------------------------------------------------------------------------ - --- --- Initial value for the LDV field in a static closure --- -staticLdvInit :: DynFlags -> CmmLit -staticLdvInit = zeroCLit - --- --- Initial value of the LDV field in a dynamic closure --- -dynLdvInit :: DynFlags -> CmmExpr -dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE - CmmMachOp (mo_wordOr dflags) [ - CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], - CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags)) - ] - --- --- Initialise the LDV word of a new closure --- -ldvRecordCreate :: CmmExpr -> FCode () -ldvRecordCreate closure = do - dflags <- getDynFlags - emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags) - --- --- | Called when a closure is entered, marks the closure as having --- been "used". The closure is not an "inherently used" one. The --- closure is not @IND@ because that is not considered for LDV profiling. --- -ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode () -ldvEnterClosure closure_info node_reg = do - dflags <- getDynFlags - let tag = funTag dflags closure_info - -- don't forget to substract node's tag - ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag)) - -ldvEnter :: CmmExpr -> FCode () --- Argument is a closure pointer -ldvEnter cl_ptr = do - dflags <- getDynFlags - let -- don't forget to substract node's tag - ldv_wd = ldvWord dflags cl_ptr - new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) - (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags)))) - (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags)))) - ifProfiling $ - -- if (era > 0) { - -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | - -- era | LDV_STATE_USE } - emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)]) - (mkStore ldv_wd new_ldv_wd) - mkNop - -loadEra :: DynFlags -> CmmExpr -loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) - [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era"))) - (cInt dflags)] - -ldvWord :: DynFlags -> CmmExpr -> CmmExpr --- Takes the address of a closure, and returns --- the address of the LDV word in the closure -ldvWord dflags closure_ptr - = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) diff --git a/codeGen/StgCmmTicky.hs b/codeGen/StgCmmTicky.hs deleted file mode 100644 --- a/codeGen/StgCmmTicky.hs +++ /dev/null @@ -1,675 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP #-} - ------------------------------------------------------------------------------ --- --- Code generation for ticky-ticky profiling --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -{- OVERVIEW: ticky ticky profiling - -Please see -http://ghc.haskell.org/trac/ghc/wiki/Debugging/TickyTicky and also -edit it and the rest of this comment to keep them up-to-date if you -change ticky-ticky. Thanks! - - *** All allocation ticky numbers are in bytes. *** - -Some of the relevant source files: - - ***not necessarily an exhaustive list*** - - * some codeGen/ modules import this one - - * this module imports cmm/CLabel.hs to manage labels - - * cmm/CmmParse.y expands some macros using generators defined in - this module - - * includes/stg/Ticky.h declares all of the global counters - - * includes/rts/Ticky.h declares the C data type for an - STG-declaration's counters - - * some macros defined in includes/Cmm.h (and used within the RTS's - CMM code) update the global ticky counters - - * at the end of execution rts/Ticky.c generates the final report - +RTS -r -RTS - -The rts/Ticky.c function that generates the report includes an -STG-declaration's ticky counters if - - * that declaration was entered, or - - * it was allocated (if -ticky-allocd) - -On either of those events, the counter is "registered" by adding it to -a linked list; cf the CMM generated by registerTickyCtr. - -Ticky-ticky profiling has evolved over many years. Many of the -counters from its most sophisticated days are no longer -active/accurate. As the RTS has changed, sometimes the ticky code for -relevant counters was not accordingly updated. Unfortunately, neither -were the comments. - -As of March 2013, there still exist deprecated code and comments in -the code generator as well as the RTS because: - - * I don't know what is out-of-date versus merely commented out for - momentary convenience, and - - * someone else might know how to repair it! - --} - -module StgCmmTicky ( - withNewTickyCounterFun, - withNewTickyCounterLNE, - withNewTickyCounterThunk, - withNewTickyCounterStdThunk, - withNewTickyCounterCon, - - tickyDynAlloc, - tickyAllocHeap, - - tickyAllocPrim, - tickyAllocThunk, - tickyAllocPAP, - tickyHeapCheck, - tickyStackCheck, - - tickyUnknownCall, tickyDirectCall, - - tickyPushUpdateFrame, - tickyUpdateFrameOmitted, - - tickyEnterDynCon, - tickyEnterStaticCon, - tickyEnterViaNode, - - tickyEnterFun, - tickyEnterThunk, tickyEnterStdThunk, -- dynamic non-value - -- thunks only - tickyEnterLNE, - - tickyUpdateBhCaf, - tickyBlackHole, - tickyUnboxedTupleReturn, - tickyReturnOldCon, tickyReturnNewCon, - - tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs, - tickySlowCall, tickySlowCallPat, - ) where - -#include "HsVersions.h" - -import StgCmmArgRep ( slowCallPattern , toArgRep , argRepString ) -import StgCmmClosure -import StgCmmUtils -import StgCmmMonad - -import StgSyn -import CmmExpr -import MkGraph -import CmmUtils -import CLabel -import SMRep - -import Module -import Name -import Id -import BasicTypes -import FastString -import Outputable - -import DynFlags - --- Turgid imports for showTypeCategory -import PrelNames -import TcType -import Type -import TyCon - -import Data.Maybe -import qualified Data.Char -import Control.Monad ( unless, when ) - ------------------------------------------------------------------------------ --- --- Ticky-ticky profiling --- ------------------------------------------------------------------------------ - -data TickyClosureType - = TickyFun - Bool -- True <-> single entry - | TickyCon - | TickyThunk - Bool -- True <-> updateable - Bool -- True <-> standard thunk (AP or selector), has no entry counter - | TickyLNE - -withNewTickyCounterFun :: Bool -> Name -> [NonVoid Id] -> FCode a -> FCode a -withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry) - -withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a -withNewTickyCounterLNE nm args code = do - b <- tickyLNEIsOn - if not b then code else withNewTickyCounter TickyLNE nm args code - -withNewTickyCounterThunk - :: Bool -- ^ static - -> Bool -- ^ updateable - -> Name - -> FCode a - -> FCode a -withNewTickyCounterThunk isStatic isUpdatable name code = do - b <- tickyDynThunkIsOn - if isStatic || not b -- ignore static thunks - then code - else withNewTickyCounter (TickyThunk isUpdatable False) name [] code - -withNewTickyCounterStdThunk - :: Bool -- ^ updateable - -> Name - -> FCode a - -> FCode a -withNewTickyCounterStdThunk isUpdatable name code = do - b <- tickyDynThunkIsOn - if not b - then code - else withNewTickyCounter (TickyThunk isUpdatable True) name [] code - -withNewTickyCounterCon - :: Name - -> FCode a - -> FCode a -withNewTickyCounterCon name code = do - b <- tickyDynThunkIsOn - if not b - then code - else withNewTickyCounter TickyCon name [] code - --- args does not include the void arguments -withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a -withNewTickyCounter cloType name args m = do - lbl <- emitTickyCounter cloType name args - setTickyCtrLabel lbl m - -emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel -emitTickyCounter cloType name args - = let ctr_lbl = mkRednCountsLabel name in - (>> return ctr_lbl) $ - ifTicky $ do - { dflags <- getDynFlags - ; parent <- getTickyCtrLabel - ; mod_name <- getModuleName - - -- When printing the name of a thing in a ticky file, we - -- want to give the module name even for *local* things. We - -- print just "x (M)" rather that "M.x" to distinguish them - -- from the global kind. - ; let ppr_for_ticky_name :: SDoc - ppr_for_ticky_name = - let n = ppr name - ext = case cloType of - TickyFun single_entry -> parens $ hcat $ punctuate comma $ - [text "fun"] ++ [text "se"|single_entry] - TickyCon -> parens (text "con") - TickyThunk upd std -> parens $ hcat $ punctuate comma $ - [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std] - TickyLNE | isInternalName name -> parens (text "LNE") - | otherwise -> panic "emitTickyCounter: how is this an external LNE?" - p = case hasHaskellName parent of - -- NB the default "top" ticky ctr does not - -- have a Haskell name - Just pname -> text "in" <+> ppr (nameUnique pname) - _ -> empty - in if isInternalName name - then n <+> parens (ppr mod_name) <+> ext <+> p - else n <+> ext <+> p - - ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name - ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args - ; emitDataLits ctr_lbl - -- Must match layout of includes/rts/Ticky.h's StgEntCounter - -- - -- krc: note that all the fields are I32 now; some were I16 - -- before, but the code generator wasn't handling that - -- properly and it led to chaos, panic and disorder. - [ mkIntCLit dflags 0, -- registered? - mkIntCLit dflags (length args), -- Arity - mkIntCLit dflags 0, -- Heap allocated for this thing - fun_descr_lit, - arg_descr_lit, - zeroCLit dflags, -- Entries into this thing - zeroCLit dflags, -- Heap allocated by this thing - zeroCLit dflags -- Link to next StgEntCounter - ] - } - --- ----------------------------------------------------------------------------- --- Ticky stack frames - -tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode () -tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr") -tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr") - --- ----------------------------------------------------------------------------- --- Ticky entries - --- NB the name-specific entries are only available for names that have --- dedicated Cmm code. As far as I know, this just rules out --- constructor thunks. For them, there is no CMM code block to put the --- bump of name-specific ticky counter into. On the other hand, we can --- still track allocation their allocation. - -tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode () -tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") -tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") -tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") - -tickyEnterThunk :: ClosureInfo -> FCode () -tickyEnterThunk cl_info - = ifTicky $ do - { bumpTickyCounter ctr - ; unless static $ do - ticky_ctr_lbl <- getTickyCtrLabel - registerTickyCtrAtEntryDyn ticky_ctr_lbl - bumpTickyEntryCount ticky_ctr_lbl } - where - updatable = closureSingleEntry cl_info - static = isStaticClosure cl_info - - ctr | static = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr" - else fsLit "ENT_STATIC_THK_MANY_ctr" - | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr" - else fsLit "ENT_DYN_THK_MANY_ctr" - -tickyEnterStdThunk :: ClosureInfo -> FCode () -tickyEnterStdThunk = tickyEnterThunk - -tickyBlackHole :: Bool{-updatable-} -> FCode () -tickyBlackHole updatable - = ifTicky (bumpTickyCounter ctr) - where - ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr") - | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr") - -tickyUpdateBhCaf :: ClosureInfo -> FCode () -tickyUpdateBhCaf cl_info - = ifTicky (bumpTickyCounter ctr) - where - ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr") - | otherwise = (fsLit "UPD_CAF_BH_UPDATABLE_ctr") - -tickyEnterFun :: ClosureInfo -> FCode () -tickyEnterFun cl_info = ifTicky $ do - ctr_lbl <- getTickyCtrLabel - - if isStaticClosure cl_info - then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr") - registerTickyCtr ctr_lbl - else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr") - registerTickyCtrAtEntryDyn ctr_lbl - - bumpTickyEntryCount ctr_lbl - -tickyEnterLNE :: FCode () -tickyEnterLNE = ifTicky $ do - bumpTickyCounter (fsLit "ENT_LNE_ctr") - ifTickyLNE $ do - ctr_lbl <- getTickyCtrLabel - registerTickyCtr ctr_lbl - bumpTickyEntryCount ctr_lbl - --- needn't register a counter upon entry if --- --- 1) it's for a dynamic closure, and --- --- 2) -ticky-allocd is on --- --- since the counter was registered already upon being alloc'd -registerTickyCtrAtEntryDyn :: CLabel -> FCode () -registerTickyCtrAtEntryDyn ctr_lbl = do - already_registered <- tickyAllocdIsOn - when (not already_registered) $ registerTickyCtr ctr_lbl - -registerTickyCtr :: CLabel -> FCode () --- Register a ticky counter --- if ( ! f_ct.registeredp ) { --- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */ --- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ --- f_ct.registeredp = 1 } -registerTickyCtr ctr_lbl = do - dflags <- getDynFlags - let - -- krc: code generator doesn't handle Not, so we test for Eq 0 instead - test = CmmMachOp (MO_Eq (wordWidth dflags)) - [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags), - zeroExpr dflags] - register_stmts - = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags))) - (CmmLoad ticky_entry_ctrs (bWord dflags)) - , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) - , mkStore (CmmLit (cmmLabelOffB ctr_lbl - (oFFSET_StgEntCounter_registeredp dflags))) - (mkIntExpr dflags 1) ] - ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs")) - emit =<< mkCmmIfThen test (catAGraphs register_stmts) - -tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () -tickyReturnOldCon arity - = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") - ; bumpHistogram (fsLit "RET_OLD_hst") arity } -tickyReturnNewCon arity - = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") - ; bumpHistogram (fsLit "RET_NEW_hst") arity } - -tickyUnboxedTupleReturn :: RepArity -> FCode () -tickyUnboxedTupleReturn arity - = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") - ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } - --- ----------------------------------------------------------------------------- --- Ticky calls - --- Ticks at a *call site*: -tickyDirectCall :: RepArity -> [StgArg] -> FCode () -tickyDirectCall arity args - | arity == length args = tickyKnownCallExact - | otherwise = do tickyKnownCallExtraArgs - tickySlowCallPat (map argPrimRep (drop arity args)) - -tickyKnownCallTooFewArgs :: FCode () -tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") - -tickyKnownCallExact :: FCode () -tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr") - -tickyKnownCallExtraArgs :: FCode () -tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr") - -tickyUnknownCall :: FCode () -tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr") - --- Tick for the call pattern at slow call site (i.e. in addition to --- tickyUnknownCall, tickyKnownCallExtraArgs, etc.) -tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode () -tickySlowCall _ [] = return () -tickySlowCall lf_info args = do - -- see Note [Ticky for slow calls] - if isKnownFun lf_info - then tickyKnownCallTooFewArgs - else tickyUnknownCall - tickySlowCallPat (map argPrimRep args) - -tickySlowCallPat :: [PrimRep] -> FCode () -tickySlowCallPat args = ifTicky $ - let argReps = map toArgRep args - (_, n_matched) = slowCallPattern argReps - in if n_matched > 0 && n_matched == length args - then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps - else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr" - -{- - -Note [Ticky for slow calls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Terminology is unfortunately a bit mixed up for these calls. codeGen -uses "slow call" to refer to unknown calls and under-saturated known -calls. - -Nowadays, though (ie as of the eval/apply paper), the significantly -slower calls are actually just a subset of these: the ones with no -built-in argument pattern (cf StgCmmArgRep.slowCallPattern) - -So for ticky profiling, we split slow calls into -"SLOW_CALL_fast__ctr" (those matching a built-in pattern) and -VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very -bad for both space and time). - --} - --- ----------------------------------------------------------------------------- --- Ticky allocation - -tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode () --- Called when doing a dynamic heap allocation; the LambdaFormInfo --- used to distinguish between closure types --- --- TODO what else to count while we're here? -tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags -> - let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep - - countGlobal tot ctr = do - bumpTickyCounterBy tot bytes - bumpTickyCounter ctr - countSpecific = ifTickyAllocd $ case mb_id of - Nothing -> return () - Just id -> do - let ctr_lbl = mkRednCountsLabel (idName id) - registerTickyCtr ctr_lbl - bumpTickyAllocd ctr_lbl bytes - - -- TODO are we still tracking "good stuff" (_gds) versus - -- administrative (_adm) versus slop (_slp)? I'm going with all _gds - -- for now, since I don't currently know neither if we do nor how to - -- distinguish. NSF Mar 2013 - - in case () of - _ | isConRep rep -> - ifTickyDynThunk countSpecific >> - countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr") - | isThunkRep rep -> - ifTickyDynThunk countSpecific >> - if lfUpdatable lf - then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr") - else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr") - | isFunRep rep -> - countSpecific >> - countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr") - | otherwise -> panic "How is this heap object not a con, thunk, or fun?" - - - -tickyAllocHeap :: - Bool -> -- is this a genuine allocation? As opposed to - -- StgCmmLayout.adjustHpBackwards - VirtualHpOffset -> FCode () --- Called when doing a heap check [TICK_ALLOC_HEAP] --- Must be lazy in the amount of allocation! -tickyAllocHeap genuine hp - = ifTicky $ - do { dflags <- getDynFlags - ; ticky_ctr <- getTickyCtrLabel - ; emit $ catAGraphs $ - -- only test hp from within the emit so that the monadic - -- computation itself is not strict in hp (cf knot in - -- StgCmmMonad.getHeapUsage) - if hp == 0 then [] - else let !bytes = wORD_SIZE dflags * hp in [ - -- Bump the allocation total in the closure's StgEntCounter - addToMem (rEP_StgEntCounter_allocs dflags) - (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags))) - bytes, - -- Bump the global allocation total ALLOC_HEAP_tot - addToMemLbl (bWord dflags) - (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot")) - bytes, - -- Bump the global allocation counter ALLOC_HEAP_ctr - if not genuine then mkNop - else addToMemLbl (bWord dflags) - (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr")) - 1 - ]} - - --------------------------------------------------------------------------------- --- these three are only called from CmmParse.y (ie ultimately from the RTS) - --- the units are bytes - -tickyAllocPrim :: CmmExpr -- ^ size of the full header, in bytes - -> CmmExpr -- ^ size of the payload, in bytes - -> CmmExpr -> FCode () -tickyAllocPrim _hdr _goods _slop = ifTicky $ do - bumpTickyCounter (fsLit "ALLOC_PRIM_ctr") - bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr - bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods - bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop - -tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode () -tickyAllocThunk _goods _slop = ifTicky $ do - -- TODO is it ever called with a Single-Entry thunk? - bumpTickyCounter (fsLit "ALLOC_UP_THK_ctr") - bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods - bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop - -tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode () -tickyAllocPAP _goods _slop = ifTicky $ do - bumpTickyCounter (fsLit "ALLOC_PAP_ctr") - bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods - bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop - -tickyHeapCheck :: FCode () -tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr") - -tickyStackCheck :: FCode () -tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr") - --- ----------------------------------------------------------------------------- --- Ticky utils - -ifTicky :: FCode () -> FCode () -ifTicky code = - getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code - -tickyAllocdIsOn :: FCode Bool -tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags - -tickyLNEIsOn :: FCode Bool -tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags - -tickyDynThunkIsOn :: FCode Bool -tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags - -ifTickyAllocd :: FCode () -> FCode () -ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code - -ifTickyLNE :: FCode () -> FCode () -ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code - -ifTickyDynThunk :: FCode () -> FCode () -ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code - -bumpTickyCounter :: FastString -> FCode () -bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl) - -bumpTickyCounterBy :: FastString -> Int -> FCode () -bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl) - -bumpTickyCounterByE :: FastString -> CmmExpr -> FCode () -bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl) - -bumpTickyEntryCount :: CLabel -> FCode () -bumpTickyEntryCount lbl = do - dflags <- getDynFlags - bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags)) - -bumpTickyAllocd :: CLabel -> Int -> FCode () -bumpTickyAllocd lbl bytes = do - dflags <- getDynFlags - bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes - -bumpTickyLbl :: CLabel -> FCode () -bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1 - -bumpTickyLblBy :: CLabel -> Int -> FCode () -bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) - -bumpTickyLblByE :: CLabel -> CmmExpr -> FCode () -bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0) - -bumpTickyLit :: CmmLit -> FCode () -bumpTickyLit lhs = bumpTickyLitBy lhs 1 - -bumpTickyLitBy :: CmmLit -> Int -> FCode () -bumpTickyLitBy lhs n = do - dflags <- getDynFlags - emit (addToMem (bWord dflags) (CmmLit lhs) n) - -bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode () -bumpTickyLitByE lhs e = do - dflags <- getDynFlags - emit (addToMemE (bWord dflags) (CmmLit lhs) e) - -bumpHistogram :: FastString -> Int -> FCode () -bumpHistogram lbl n = do - dflags <- getDynFlags - let offset = n `min` (tICKY_BIN_COUNT dflags - 1) - emit (addToMem (bWord dflags) - (cmmIndexExpr dflags - (wordWidth dflags) - (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl))) - (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags)))) - 1) - ------------------------------------------------------------------- --- Showing the "type category" for ticky-ticky profiling - -showTypeCategory :: Type -> Char - {- - + dictionary - - > function - - {C,I,F,D,W} char, int, float, double, word - {c,i,f,d,w} unboxed ditto - - T tuple - - P other primitive type - p unboxed ditto - - L list - E enumeration type - S other single-constructor type - M other multi-constructor data-con type - - . other type - - - reserved for others to mark as "uninteresting" - - Accurate as of Mar 2013, but I eliminated the Array category instead - of updating it, for simplicity. It's in P/p, I think --NSF - - -} -showTypeCategory ty - | isDictTy ty = '+' - | otherwise = case tcSplitTyConApp_maybe ty of - Nothing -> '.' - Just (tycon, _) -> - (if isUnliftedTyCon tycon then Data.Char.toLower else id) $ - let anyOf us = getUnique tycon `elem` us in - case () of - _ | anyOf [funTyConKey] -> '>' - | anyOf [charPrimTyConKey, charTyConKey] -> 'C' - | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D' - | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F' - | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey, - intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey - ] -> 'I' - | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey, - word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey - ] -> 'W' - | anyOf [listTyConKey] -> 'L' - | isTupleTyCon tycon -> 'T' - | isPrimTyCon tycon -> 'P' - | isEnumerationTyCon tycon -> 'E' - | isJust (tyConSingleDataCon_maybe tycon) -> 'S' - | otherwise -> 'M' -- oh, well... diff --git a/codeGen/StgCmmUtils.hs b/codeGen/StgCmmUtils.hs deleted file mode 100644 --- a/codeGen/StgCmmUtils.hs +++ /dev/null @@ -1,620 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Code generator utilities; mostly monadic --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module StgCmmUtils ( - cgLit, mkSimpleLit, - emitDataLits, mkDataLits, - emitRODataLits, mkRODataLits, - emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, - assignTemp, newTemp, - - newUnboxedTupleRegs, - - emitMultiAssign, emitCmmLitSwitch, emitSwitch, - - tagToClosure, mkTaggedObjectLoad, - - callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr, - - cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, - cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord, - cmmOffsetExprW, cmmOffsetExprB, - cmmRegOffW, cmmRegOffB, - cmmLabelOffW, cmmLabelOffB, - cmmOffsetW, cmmOffsetB, - cmmOffsetLitW, cmmOffsetLitB, - cmmLoadIndexW, - cmmConstrTag1, - - cmmUntag, cmmIsTagged, - - addToMem, addToMemE, addToMemLblE, addToMemLbl, - mkWordCLit, - newStringCLit, newByteStringCLit, - blankWord, - ) where - -#include "HsVersions.h" - -import StgCmmMonad -import StgCmmClosure -import Cmm -import BlockId -import MkGraph -import CodeGen.Platform -import CLabel -import CmmUtils -import CmmSwitch - -import ForeignCall -import IdInfo -import Type -import TyCon -import SMRep -import Module -import Literal -import Digraph -import Util -import Unique -import UniqSupply (MonadUnique(..)) -import DynFlags -import FastString -import Outputable -import RepType - -import qualified Data.ByteString as BS -import qualified Data.Map as M -import Data.Char -import Data.List -import Data.Ord -import Data.Word - - -------------------------------------------------------------------------- --- --- Literals --- -------------------------------------------------------------------------- - -cgLit :: Literal -> FCode CmmLit -cgLit (MachStr s) = newByteStringCLit (BS.unpack s) - -- not unpackFS; we want the UTF-8 byte stream. -cgLit other_lit = do dflags <- getDynFlags - return (mkSimpleLit dflags other_lit) - -mkSimpleLit :: DynFlags -> Literal -> CmmLit -mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) -mkSimpleLit dflags MachNullAddr = zeroCLit dflags -mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags) -mkSimpleLit _ (MachInt64 i) = CmmInt i W64 -mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags) -mkSimpleLit _ (MachWord64 i) = CmmInt i W64 -mkSimpleLit _ (MachFloat r) = CmmFloat r W32 -mkSimpleLit _ (MachDouble r) = CmmFloat r W64 -mkSimpleLit _ (MachLabel fs ms fod) - = CmmLabel (mkForeignLabel fs ms labelSrc fod) - where - -- TODO: Literal labels might not actually be in the current package... - labelSrc = ForeignLabelInThisPackage -mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other) - --------------------------------------------------------------------------- --- --- Incrementing a memory location --- --------------------------------------------------------------------------- - -addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph -addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n - -addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph -addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl)) - -addToMem :: CmmType -- rep of the counter - -> CmmExpr -- Address - -> Int -- What to add (a word) - -> CmmAGraph -addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep))) - -addToMemE :: CmmType -- rep of the counter - -> CmmExpr -- Address - -> CmmExpr -- What to add (a word-typed expression) - -> CmmAGraph -addToMemE rep ptr n - = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n]) - - -------------------------------------------------------------------------- --- --- Loading a field from an object, --- where the object pointer is itself tagged --- -------------------------------------------------------------------------- - -mkTaggedObjectLoad - :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph --- (loadTaggedObjectField reg base off tag) generates assignment --- reg = bitsK[ base + off - tag ] --- where K is fixed by 'reg' -mkTaggedObjectLoad dflags reg base offset tag - = mkAssign (CmmLocal reg) - (CmmLoad (cmmOffsetB dflags - (CmmReg (CmmLocal base)) - (offset - tag)) - (localRegType reg)) - -------------------------------------------------------------------------- --- --- Converting a closure tag to a closure for enumeration types --- (this is the implementation of tagToEnum#). --- -------------------------------------------------------------------------- - -tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr -tagToClosure dflags tycon tag - = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags) - where closure_tbl = CmmLit (CmmLabel lbl) - lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs - -------------------------------------------------------------------------- --- --- Conditionals and rts calls --- -------------------------------------------------------------------------- - -emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe - -emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString - -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCallWithResult res hint pkg fun args safe - = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe - --- Make a call to an RTS C procedure -emitRtsCallGen - :: [(LocalReg,ForeignHint)] - -> CLabel - -> [(CmmExpr,ForeignHint)] - -> Bool -- True <=> CmmSafe call - -> FCode () -emitRtsCallGen res lbl args safe - = do { dflags <- getDynFlags - ; updfr_off <- getUpdFrameOff - ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags - ; emit caller_save - ; call updfr_off - ; emit caller_load } - where - call updfr_off = - if safe then - emit =<< mkCmmCall fun_expr res' args' updfr_off - else do - let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn - emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args' - (args', arg_hints) = unzip args - (res', res_hints) = unzip res - fun_expr = mkLblExpr lbl - - ------------------------------------------------------------------------------ --- --- Caller-Save Registers --- ------------------------------------------------------------------------------ - --- Here we generate the sequence of saves/restores required around a --- foreign call instruction. - --- TODO: reconcile with includes/Regs.h --- * Regs.h claims that BaseReg should be saved last and loaded first --- * This might not have been tickled before since BaseReg is callee save --- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim --- --- This code isn't actually used right now, because callerSaves --- only ever returns true in the current universe for registers NOT in --- system_regs (just do a grep for CALLER_SAVES in --- includes/stg/MachRegs.h). It's all one giant no-op, and for --- good reason: having to save system registers on every foreign call --- would be very expensive, so we avoid assigning them to those --- registers when we add support for an architecture. --- --- Note that the old code generator actually does more work here: it --- also saves other global registers. We can't (nor want) to do that --- here, as we don't have liveness information. And really, we --- shouldn't be doing the workaround at this point in the pipeline, see --- Note [Register parameter passing] and the ToDo on CmmCall in --- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across --- unsafe foreign calls in rewriteAssignments, but this is strictly --- temporary. -callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph) -callerSaveVolatileRegs dflags = (caller_save, caller_load) - where - platform = targetPlatform dflags - - caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save) - caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save) - - system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery - {- ,SparkHd,SparkTl,SparkBase,SparkLim -} - , BaseReg ] - - regs_to_save = filter (callerSaves platform) system_regs - - callerSaveGlobalReg reg - = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg)) - - callerRestoreGlobalReg reg - = mkAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg)) - --- ----------------------------------------------------------------------------- --- Global registers - --- We map STG registers onto appropriate CmmExprs. Either they map --- to real machine registers or stored as offsets from BaseReg. Given --- a GlobalReg, get_GlobalReg_addr always produces the --- register table address for it. --- (See also get_GlobalReg_reg_or_addr in MachRegs) - -get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr -get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0 -get_GlobalReg_addr dflags mid - = get_Regtable_addr_from_offset dflags - (globalRegType dflags mid) (baseRegOffset dflags mid) - --- Calculate a literal representing an offset into the register table. --- Used when we don't have an actual BaseReg to offset from. -regTableOffset :: DynFlags -> Int -> CmmExpr -regTableOffset dflags n = - CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n)) - -get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr -get_Regtable_addr_from_offset dflags _rep offset = - if haveRegBase (targetPlatform dflags) - then CmmRegOff (CmmGlobal BaseReg) offset - else regTableOffset dflags offset - - --- ----------------------------------------------------------------------------- --- Information about global registers - -baseRegOffset :: DynFlags -> GlobalReg -> Int - -baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags -baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags -baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags -baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags -baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags -baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags -baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags -baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags -baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags -baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags -baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags -baseRegOffset _ reg = pprPanic "StgCmmUtils.baseRegOffset:" (ppr reg) - -------------------------------------------------------------------------- --- --- Strings generate a top-level data block --- -------------------------------------------------------------------------- - -emitDataLits :: CLabel -> [CmmLit] -> FCode () --- Emit a data-segment data block -emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits) - -emitRODataLits :: CLabel -> [CmmLit] -> FCode () --- Emit a read-only data block -emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits) - -newStringCLit :: String -> FCode CmmLit --- Make a global definition for the string, --- and return its label -newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str) - -newByteStringCLit :: [Word8] -> FCode CmmLit -newByteStringCLit bytes - = do { uniq <- newUnique - ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes - ; emitDecl decl - ; return lit } - -------------------------------------------------------------------------- --- --- Assigning expressions to temporaries --- -------------------------------------------------------------------------- - -assignTemp :: CmmExpr -> FCode LocalReg --- Make sure the argument is in a local register. --- We don't bother being particularly aggressive with avoiding --- unnecessary local registers, since we can rely on a later --- optimization pass to inline as necessary (and skipping out --- on things like global registers can be a little dangerous --- due to them being trashed on foreign calls--though it means --- the optimization pass doesn't have to do as much work) -assignTemp (CmmReg (CmmLocal reg)) = return reg -assignTemp e = do { dflags <- getDynFlags - ; uniq <- newUnique - ; let reg = LocalReg uniq (cmmExprType dflags e) - ; emitAssign (CmmLocal reg) e - ; return reg } - -newTemp :: MonadUnique m => CmmType -> m LocalReg -newTemp rep = do { uniq <- getUniqueM - ; return (LocalReg uniq rep) } - -newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint]) --- Choose suitable local regs to use for the components --- of an unboxed tuple that we are about to return to --- the Sequel. If the Sequel is a join point, using the --- regs it wants will save later assignments. -newUnboxedTupleRegs res_ty - = ASSERT( isUnboxedTupleType res_ty ) - do { dflags <- getDynFlags - ; sequel <- getSequel - ; regs <- choose_regs dflags sequel - ; ASSERT( regs `equalLength` reps ) - return (regs, map primRepForeignHint reps) } - where - reps = typePrimRep res_ty - choose_regs _ (AssignTo regs _) = return regs - choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps - - - -------------------------------------------------------------------------- --- emitMultiAssign -------------------------------------------------------------------------- - -emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode () --- Emit code to perform the assignments in the --- input simultaneously, using temporary variables when necessary. - -type Key = Int -type Vrtx = (Key, Stmt) -- Give each vertex a unique number, - -- for fast comparison -type Stmt = (LocalReg, CmmExpr) -- r := e - --- We use the strongly-connected component algorithm, in which --- * the vertices are the statements --- * an edge goes from s1 to s2 iff --- s1 assigns to something s2 uses --- that is, if s1 should *follow* s2 in the final order - -emitMultiAssign [] [] = return () -emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs -emitMultiAssign regs rhss = do - dflags <- getDynFlags - ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss ) - unscramble dflags ([1..] `zip` (regs `zip` rhss)) - -unscramble :: DynFlags -> [Vrtx] -> FCode () -unscramble dflags vertices = mapM_ do_component components - where - edges :: [ (Vrtx, Key, [Key]) ] - edges = [ (vertex, key1, edges_from stmt1) - | vertex@(key1, stmt1) <- vertices ] - - edges_from :: Stmt -> [Key] - edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, - stmt1 `mustFollow` stmt2 ] - - components :: [SCC Vrtx] - components = stronglyConnCompFromEdgedVerticesUniq edges - - -- do_components deal with one strongly-connected component - -- Not cyclic, or singleton? Just do it - do_component :: SCC Vrtx -> FCode () - do_component (AcyclicSCC (_,stmt)) = mk_graph stmt - do_component (CyclicSCC []) = panic "do_component" - do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt - - -- Cyclic? Then go via temporaries. Pick one to - -- break the loop and try again with the rest. - do_component (CyclicSCC ((_,first_stmt) : rest)) = do - dflags <- getDynFlags - u <- newUnique - let (to_tmp, from_tmp) = split dflags u first_stmt - mk_graph to_tmp - unscramble dflags rest - mk_graph from_tmp - - split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt) - split dflags uniq (reg, rhs) - = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp))) - where - rep = cmmExprType dflags rhs - tmp = LocalReg uniq rep - - mk_graph :: Stmt -> FCode () - mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs - - mustFollow :: Stmt -> Stmt -> Bool - (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs - -------------------------------------------------------------------------- --- mkSwitch -------------------------------------------------------------------------- - - -emitSwitch :: CmmExpr -- Tag to switch on - -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches - -> Maybe CmmAGraphScoped -- Default branch (if any) - -> ConTagZ -> ConTagZ -- Min and Max possible values; - -- behaviour outside this range is - -- undefined - -> FCode () - --- First, two rather common cases in which there is no work to do -emitSwitch _ [] (Just code) _ _ = emit (fst code) -emitSwitch _ [(_,code)] Nothing _ _ = emit (fst code) - --- Right, off we go -emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do - join_lbl <- newBlockId - mb_deflt_lbl <- label_default join_lbl mb_deflt - branches_lbls <- label_branches join_lbl branches - tag_expr' <- assignTemp' tag_expr - - -- Sort the branches before calling mk_discrete_switch - let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ] - let range = (fromIntegral lo_tag, fromIntegral hi_tag) - - emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range - - emitLabel join_lbl - -mk_discrete_switch :: Bool -- ^ Use signed comparisons - -> CmmExpr - -> [(Integer, BlockId)] - -> Maybe BlockId - -> (Integer, Integer) - -> CmmAGraph - --- SINGLETON TAG RANGE: no case analysis to do -mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag) - | lo_tag == hi_tag - = ASSERT( tag == lo_tag ) - mkBranch lbl - --- SINGLETON BRANCH, NO DEFAULT: no case analysis to do -mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _ - = mkBranch lbl - -- The simplifier might have eliminated a case - -- so we may have e.g. case xs of - -- [] -> e - -- In that situation we can be sure the (:) case - -- can't happen, so no need to test - --- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans --- See Note [Cmm Switches, the general plan] in CmmSwitch -mk_discrete_switch signed tag_expr branches mb_deflt range - = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches) - -divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)]) -divideBranches branches = (lo_branches, mid, hi_branches) - where - -- 2 branches => n_branches `div` 2 = 1 - -- => branches !! 1 give the *second* tag - -- There are always at least 2 branches here - (mid,_) = branches !! (length branches `div` 2) - (lo_branches, hi_branches) = span is_lo branches - is_lo (t,_) = t < mid - --------------- -emitCmmLitSwitch :: CmmExpr -- Tag to switch on - -> [(Literal, CmmAGraphScoped)] -- Tagged branches - -> CmmAGraphScoped -- Default branch (always) - -> FCode () -- Emit the code -emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt -emitCmmLitSwitch scrut branches deflt = do - scrut' <- assignTemp' scrut - join_lbl <- newBlockId - deflt_lbl <- label_code join_lbl deflt - branches_lbls <- label_branches join_lbl branches - - dflags <- getDynFlags - let cmm_ty = cmmExprType dflags scrut - rep = typeWidth cmm_ty - - -- We find the necessary type information in the literals in the branches - let signed = case head branches of - (MachInt _, _) -> True - (MachInt64 _, _) -> True - _ -> False - - let range | signed = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags) - | otherwise = (0, tARGET_MAX_WORD dflags) - - if isFloatType cmm_ty - then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls - else emit $ mk_discrete_switch - signed - scrut' - [(litValue lit,l) | (lit,l) <- branches_lbls] - (Just deflt_lbl) - range - emitLabel join_lbl - --- | lower bound (inclusive), upper bound (exclusive) -type LitBound = (Maybe Literal, Maybe Literal) - -noBound :: LitBound -noBound = (Nothing, Nothing) - -mk_float_switch :: Width -> CmmExpr -> BlockId - -> LitBound - -> [(Literal,BlockId)] - -> FCode CmmAGraph -mk_float_switch rep scrut deflt _bounds [(lit,blk)] - = do dflags <- getDynFlags - return $ mkCbranch (cond dflags) deflt blk Nothing - where - cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit] - where - cmm_lit = mkSimpleLit dflags lit - ne = MO_F_Ne rep - -mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches - = do dflags <- getDynFlags - lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches - hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches - mkCmmIfThenElse (cond dflags) lo_blk hi_blk - where - (lo_branches, mid_lit, hi_branches) = divideBranches branches - - bounds_lo = (lo_bound, Just mid_lit) - bounds_hi = (Just mid_lit, hi_bound) - - cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit] - where - cmm_lit = mkSimpleLit dflags mid_lit - lt = MO_F_Lt rep - - --------------- -label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId) -label_default _ Nothing - = return Nothing -label_default join_lbl (Just code) - = do lbl <- label_code join_lbl code - return (Just lbl) - --------------- -label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)] -label_branches _join_lbl [] - = return [] -label_branches join_lbl ((tag,code):branches) - = do lbl <- label_code join_lbl code - branches' <- label_branches join_lbl branches - return ((tag,lbl):branches') - --------------- -label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId --- label_code J code --- generates --- [L: code; goto J] --- and returns L -label_code join_lbl (code,tsc) = do - lbl <- newBlockId - emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc) - return lbl - --------------- -assignTemp' :: CmmExpr -> FCode CmmExpr -assignTemp' e - | isTrivialCmmExpr e = return e - | otherwise = do - dflags <- getDynFlags - lreg <- newTemp (cmmExprType dflags e) - let reg = CmmLocal lreg - emitAssign reg e - return (CmmReg reg) diff --git a/coreSyn/CoreArity.hs b/coreSyn/CoreArity.hs deleted file mode 100644 --- a/coreSyn/CoreArity.hs +++ /dev/null @@ -1,1200 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - - Arity and eta expansion --} - -{-# LANGUAGE CPP #-} - --- | Arity and eta expansion -module CoreArity ( - manifestArity, joinRhsArity, exprArity, typeArity, - exprEtaExpandArity, findRhsArity, CheapFun, etaExpand, - etaExpandToJoinPoint, etaExpandToJoinPointRule, - exprBotStrictness_maybe - ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreFVs -import CoreUtils -import CoreSubst -import Demand -import Var -import VarEnv -import Id -import Type -import TyCon ( initRecTc, checkRecTc ) -import Coercion -import BasicTypes -import Unique -import DynFlags ( DynFlags, GeneralFlag(..), gopt ) -import Outputable -import FastString -import Pair -import Util ( debugIsOn ) - -{- -************************************************************************ -* * - manifestArity and exprArity -* * -************************************************************************ - -exprArity is a cheap-and-cheerful version of exprEtaExpandArity. -It tells how many things the expression can be applied to before doing -any work. It doesn't look inside cases, lets, etc. The idea is that -exprEtaExpandArity will do the hard work, leaving something that's easy -for exprArity to grapple with. In particular, Simplify uses exprArity to -compute the ArityInfo for the Id. - -Originally I thought that it was enough just to look for top-level lambdas, but -it isn't. I've seen this - - foo = PrelBase.timesInt - -We want foo to get arity 2 even though the eta-expander will leave it -unchanged, in the expectation that it'll be inlined. But occasionally it -isn't, because foo is blacklisted (used in a rule). - -Similarly, see the ok_note check in exprEtaExpandArity. So - f = __inline_me (\x -> e) -won't be eta-expanded. - -And in any case it seems more robust to have exprArity be a bit more intelligent. -But note that (\x y z -> f x y z) -should have arity 3, regardless of f's arity. --} - -manifestArity :: CoreExpr -> Arity --- ^ manifestArity sees how many leading value lambdas there are, --- after looking through casts -manifestArity (Lam v e) | isId v = 1 + manifestArity e - | otherwise = manifestArity e -manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e -manifestArity (Cast e _) = manifestArity e -manifestArity _ = 0 - -joinRhsArity :: CoreExpr -> JoinArity --- Join points are supposed to have manifestly-visible --- lambdas at the top: no ticks, no casts, nothing --- Moreover, type lambdas count in JoinArity -joinRhsArity (Lam _ e) = 1 + joinRhsArity e -joinRhsArity _ = 0 - - ---------------- -exprArity :: CoreExpr -> Arity --- ^ An approximate, fast, version of 'exprEtaExpandArity' -exprArity e = go e - where - go (Var v) = idArity v - go (Lam x e) | isId x = go e + 1 - | otherwise = go e - go (Tick t e) | not (tickishIsCode t) = go e - go (Cast e co) = trim_arity (go e) (pSnd (coercionKind co)) - -- Note [exprArity invariant] - go (App e (Type _)) = go e - go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 - -- See Note [exprArity for applications] - -- NB: coercions count as a value argument - - go _ = 0 - - trim_arity :: Arity -> Type -> Arity - trim_arity arity ty = arity `min` length (typeArity ty) - ---------------- -typeArity :: Type -> [OneShotInfo] --- How many value arrows are visible in the type? --- We look through foralls, and newtypes --- See Note [exprArity invariant] -typeArity ty - = go initRecTc ty - where - go rec_nts ty - | Just (_, ty') <- splitForAllTy_maybe ty - = go rec_nts ty' - - | Just (arg,res) <- splitFunTy_maybe ty - = typeOneShot arg : go rec_nts res - - | Just (tc,tys) <- splitTyConApp_maybe ty - , Just (ty', _) <- instNewTyCon_maybe tc tys - , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] - -- in TyCon --- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes --- -- See Note [Newtype classes and eta expansion] --- (no longer required) - = go rec_nts' ty' - -- Important to look through non-recursive newtypes, so that, eg - -- (f x) where f has arity 2, f :: Int -> IO () - -- Here we want to get arity 1 for the result! - -- - -- AND through a layer of recursive newtypes - -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) - - | otherwise - = [] - ---------------- -exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) --- A cheap and cheerful function that identifies bottoming functions --- and gives them a suitable strictness signatures. It's used during --- float-out -exprBotStrictness_maybe e - = case getBotArity (arityType env e) of - Nothing -> Nothing - Just ar -> Just (ar, sig ar) - where - env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False } - sig ar = mkClosedStrictSig (replicate ar topDmd) exnRes - -- For this purpose we can be very simple - -- exnRes is a bit less aggressive than botRes - -{- -Note [exprArity invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -exprArity has the following invariant: - - (1) If typeArity (exprType e) = n, - then manifestArity (etaExpand e n) = n - - That is, etaExpand can always expand as much as typeArity says - So the case analysis in etaExpand and in typeArity must match - - (2) exprArity e <= typeArity (exprType e) - - (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n - - That is, if exprArity says "the arity is n" then etaExpand really - can get "n" manifest lambdas to the top. - -Why is this important? Because - - In TidyPgm we use exprArity to fix the *final arity* of - each top-level Id, and in - - In CorePrep we use etaExpand on each rhs, so that the visible lambdas - actually match that arity, which in turn means - that the StgRhs has the right number of lambdas - -An alternative would be to do the eta-expansion in TidyPgm, at least -for top-level bindings, in which case we would not need the trim_arity -in exprArity. That is a less local change, so I'm going to leave it for today! - -Note [Newtype classes and eta expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - NB: this nasty special case is no longer required, because - for newtype classes we don't use the class-op rule mechanism - at all. See Note [Single-method classes] in TcInstDcls. SLPJ May 2013 - --------- Old out of date comments, just for interest ----------- -We have to be careful when eta-expanding through newtypes. In general -it's a good idea, but annoyingly it interacts badly with the class-op -rule mechanism. Consider - - class C a where { op :: a -> a } - instance C b => C [b] where - op x = ... - -These translate to - - co :: forall a. (a->a) ~ C a - - $copList :: C b -> [b] -> [b] - $copList d x = ... - - $dfList :: C b -> C [b] - {-# DFunUnfolding = [$copList] #-} - $dfList d = $copList d |> co@[b] - -Now suppose we have: - - dCInt :: C Int - - blah :: [Int] -> [Int] - blah = op ($dfList dCInt) - -Now we want the built-in op/$dfList rule will fire to give - blah = $copList dCInt - -But with eta-expansion 'blah' might (and in Trac #3772, which is -slightly more complicated, does) turn into - - blah = op (\eta. ($dfList dCInt |> sym co) eta) - -and now it is *much* harder for the op/$dfList rule to fire, because -exprIsConApp_maybe won't hold of the argument to op. I considered -trying to *make* it hold, but it's tricky and I gave up. - -The test simplCore/should_compile/T3722 is an excellent example. --------- End of old out of date comments, just for interest ----------- - - -Note [exprArity for applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come to an application we check that the arg is trivial. - eg f (fac x) does not have arity 2, - even if f has arity 3! - -* We require that is trivial rather merely cheap. Suppose f has arity 2. - Then f (Just y) - has arity 0, because if we gave it arity 1 and then inlined f we'd get - let v = Just y in \w. - which has arity 0. And we try to maintain the invariant that we don't - have arity decreases. - -* The `max 0` is important! (\x y -> f x) has arity 2, even if f is - unknown, hence arity 0 - - -************************************************************************ -* * - Computing the "arity" of an expression -* * -************************************************************************ - -Note [Definition of arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The "arity" of an expression 'e' is n if - applying 'e' to *fewer* than n *value* arguments - converges rapidly - -Or, to put it another way - - there is no work lost in duplicating the partial - application (e x1 .. x(n-1)) - -In the divegent case, no work is lost by duplicating because if the thing -is evaluated once, that's the end of the program. - -Or, to put it another way, in any context C - - C[ (\x1 .. xn. e x1 .. xn) ] - is as efficient as - C[ e ] - -It's all a bit more subtle than it looks: - -Note [One-shot lambdas] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider one-shot lambdas - let x = expensive in \y z -> E -We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. - -Note [Dealing with bottom] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -A Big Deal with computing arities is expressions like - - f = \x -> case x of - True -> \s -> e1 - False -> \s -> e2 - -This happens all the time when f :: Bool -> IO () -In this case we do eta-expand, in order to get that \s to the -top, and give f arity 2. - -This isn't really right in the presence of seq. Consider - (f bot) `seq` 1 - -This should diverge! But if we eta-expand, it won't. We ignore this -"problem" (unless -fpedantic-bottoms is on), because being scrupulous -would lose an important transformation for many programs. (See -Trac #5587 for an example.) - -Consider also - f = \x -> error "foo" -Here, arity 1 is fine. But if it is - f = \x -> case x of - True -> error "foo" - False -> \y -> x+y -then we want to get arity 2. Technically, this isn't quite right, because - (f True) `seq` 1 -should diverge, but it'll converge if we eta-expand f. Nevertheless, we -do so; it improves some programs significantly, and increasing convergence -isn't a bad thing. Hence the ABot/ATop in ArityType. - -So these two transformations aren't always the Right Thing, and we -have several tickets reporting unexpected bahaviour resulting from -this transformation. So we try to limit it as much as possible: - - (1) Do NOT move a lambda outside a known-bottom case expression - case undefined of { (a,b) -> \y -> e } - This showed up in Trac #5557 - - (2) Do NOT move a lambda outside a case if all the branches of - the case are known to return bottom. - case x of { (a,b) -> \y -> error "urk" } - This case is less important, but the idea is that if the fn is - going to diverge eventually anyway then getting the best arity - isn't an issue, so we might as well play safe - - (3) Do NOT move a lambda outside a case unless - (a) The scrutinee is ok-for-speculation, or - (b) more liberally: the scrutinee is cheap (e.g. a variable), and - -fpedantic-bottoms is not enforced (see Trac #2915 for an example) - -Of course both (1) and (2) are readily defeated by disguising the bottoms. - -4. Note [Newtype arity] -~~~~~~~~~~~~~~~~~~~~~~~~ -Non-recursive newtypes are transparent, and should not get in the way. -We do (currently) eta-expand recursive newtypes too. So if we have, say - - newtype T = MkT ([T] -> Int) - -Suppose we have - e = coerce T f -where f has arity 1. Then: etaExpandArity e = 1; -that is, etaExpandArity looks through the coerce. - -When we eta-expand e to arity 1: eta_expand 1 e T -we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - - HOWEVER, note that if you use coerce bogusly you can ge - coerce Int negate - And since negate has arity 2, you might try to eta expand. But you can't - decopose Int to a function type. Hence the final case in eta_expand. - -Note [The state-transformer hack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - f = e -where e has arity n. Then, if we know from the context that f has -a usage type like - t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... -then we can expand the arity to m. This usage type says that -any application (x e1 .. en) will be applied to uniquely to (m-n) more args -Consider f = \x. let y = - in case x of - True -> foo - False -> \(s:RealWorld) -> e -where foo has arity 1. Then we want the state hack to -apply to foo too, so we can eta expand the case. - -Then we expect that if f is applied to one arg, it'll be applied to two -(that's the hack -- we don't really know, and sometimes it's false) -See also Id.isOneShotBndr. - -Note [State hack and bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's a terrible idea to use the state hack on a bottoming function. -Here's what happens (Trac #2861): - - f :: String -> IO T - f = \p. error "..." - -Eta-expand, using the state hack: - - f = \p. (\s. ((error "...") |> g1) s) |> g2 - g1 :: IO T ~ (S -> (S,T)) - g2 :: (S -> (S,T)) ~ IO T - -Extrude the g2 - - f' = \p. \s. ((error "...") |> g1) s - f = f' |> (String -> g2) - -Discard args for bottomming function - - f' = \p. \s. ((error "...") |> g1 |> g3 - g3 :: (S -> (S,T)) ~ (S,T) - -Extrude g1.g3 - - f'' = \p. \s. (error "...") - f' = f'' |> (String -> S -> g1.g3) - -And now we can repeat the whole loop. Aargh! The bug is in applying the -state hack to a function which then swallows the argument. - -This arose in another guise in Trac #3959. Here we had - - catch# (throw exn >> return ()) - -Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. -After inlining (>>) we get - - catch# (\_. throw {IO ()} exn) - -We must *not* eta-expand to - - catch# (\_ _. throw {...} exn) - -because 'catch#' expects to get a (# _,_ #) after applying its argument to -a State#, not another function! - -In short, we use the state hack to allow us to push let inside a lambda, -but not to introduce a new lambda. - - -Note [ArityType] -~~~~~~~~~~~~~~~~ -ArityType is the result of a compositional analysis on expressions, -from which we can decide the real arity of the expression (extracted -with function exprEtaExpandArity). - -Here is what the fields mean. If an arbitrary expression 'f' has -ArityType 'at', then - - * If at = ABot n, then (f x1..xn) definitely diverges. Partial - applications to fewer than n args may *or may not* diverge. - - We allow ourselves to eta-expand bottoming functions, even - if doing so may lose some `seq` sharing, - let x = in \y. error (g x y) - ==> \y. let x = in error (g x y) - - * If at = ATop as, and n=length as, - then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing, - assuming the calls of f respect the one-shot-ness of - its definition. - - NB 'f' is an arbitrary expression, eg (f = g e1 e2). This 'f' - can have ArityType as ATop, with length as > 0, only if e1 e2 are - themselves. - - * In both cases, f, (f x1), ... (f x1 ... f(n-1)) are definitely - really functions, or bottom, but *not* casts from a data type, in - at least one case branch. (If it's a function in one case branch but - an unsafe cast from a data type in another, the program is bogus.) - So eta expansion is dynamically ok; see Note [State hack and - bottoming functions], the part about catch# - -Example: - f = \x\y. let v = in - \s(one-shot) \t(one-shot). blah - 'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot] - The one-shot-ness means we can, in effect, push that - 'let' inside the \st. - - -Suppose f = \xy. x+y -Then f :: AT [False,False] ATop - f v :: AT [False] ATop - f :: AT [] ATop - --------------------- Main arity code ---------------------------- --} - --- See Note [ArityType] -data ArityType = ATop [OneShotInfo] | ABot Arity - -- There is always an explicit lambda - -- to justify the [OneShot], or the Arity - -vanillaArityType :: ArityType -vanillaArityType = ATop [] -- Totally uninformative - --- ^ The Arity returned is the number of value args the --- expression can be applied to without doing much work -exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity --- exprEtaExpandArity is used when eta expanding --- e ==> \xy -> e x y -exprEtaExpandArity dflags e - = case (arityType env e) of - ATop oss -> length oss - ABot n -> n - where - env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp - , ae_ped_bot = gopt Opt_PedanticBottoms dflags } - -getBotArity :: ArityType -> Maybe Arity --- Arity of a divergent function -getBotArity (ABot n) = Just n -getBotArity _ = Nothing - -mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun -mk_cheap_fn dflags cheap_app - | not (gopt Opt_DictsCheap dflags) - = \e _ -> exprIsOk cheap_app e - | otherwise - = \e mb_ty -> exprIsOk cheap_app e - || case mb_ty of - Nothing -> False - Just ty -> isDictLikeTy ty - - ----------------------- -findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity --- This implements the fixpoint loop for arity analysis --- See Note [Arity analysis] -findRhsArity dflags bndr rhs old_arity - = go (rhsEtaExpandArity dflags init_cheap_app rhs) - -- We always call exprEtaExpandArity once, but usually - -- that produces a result equal to old_arity, and then - -- we stop right away (since arities should not decrease) - -- Result: the common case is that there is just one iteration - where - init_cheap_app :: CheapAppFun - init_cheap_app fn n_val_args - | fn == bndr = True -- On the first pass, this binder gets infinite arity - | otherwise = isCheapApp fn n_val_args - - go :: Arity -> Arity - go cur_arity - | cur_arity <= old_arity = cur_arity - | new_arity == cur_arity = cur_arity - | otherwise = ASSERT( new_arity < cur_arity ) -#ifdef DEBUG - pprTrace "Exciting arity" - (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity - , ppr rhs]) -#endif - go new_arity - where - new_arity = rhsEtaExpandArity dflags cheap_app rhs - - cheap_app :: CheapAppFun - cheap_app fn n_val_args - | fn == bndr = n_val_args < cur_arity - | otherwise = isCheapApp fn n_val_args - --- ^ The Arity returned is the number of value args the --- expression can be applied to without doing much work -rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity --- exprEtaExpandArity is used when eta expanding --- e ==> \xy -> e x y -rhsEtaExpandArity dflags cheap_app e - = case (arityType env e) of - ATop (os:oss) - | isOneShotInfo os || has_lam e -> 1 + length oss - -- Don't expand PAPs/thunks - -- Note [Eta expanding thunks] - | otherwise -> 0 - ATop [] -> 0 - ABot n -> n - where - env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app - , ae_ped_bot = gopt Opt_PedanticBottoms dflags } - - has_lam (Tick _ e) = has_lam e - has_lam (Lam b e) = isId b || has_lam e - has_lam _ = False - -{- -Note [Arity analysis] -~~~~~~~~~~~~~~~~~~~~~ -The motivating example for arity analysis is this: - - f = \x. let g = f (x+1) - in \y. ...g... - -What arity does f have? Really it should have arity 2, but a naive -look at the RHS won't see that. You need a fixpoint analysis which -says it has arity "infinity" the first time round. - -This example happens a lot; it first showed up in Andy Gill's thesis, -fifteen years ago! It also shows up in the code for 'rnf' on lists -in Trac #4138. - -The analysis is easy to achieve because exprEtaExpandArity takes an -argument - type CheapFun = CoreExpr -> Maybe Type -> Bool -used to decide if an expression is cheap enough to push inside a -lambda. And exprIsCheap' in turn takes an argument - type CheapAppFun = Id -> Int -> Bool -which tells when an application is cheap. This makes it easy to -write the analysis loop. - -The analysis is cheap-and-cheerful because it doesn't deal with -mutual recursion. But the self-recursive case is the important one. - - -Note [Eta expanding through dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the experimental -fdicts-cheap flag is on, we eta-expand through -dictionary bindings. This improves arities. Thereby, it also -means that full laziness is less prone to floating out the -application of a function to its dictionary arguments, which -can thereby lose opportunities for fusion. Example: - foo :: Ord a => a -> ... - foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... - -- So foo has arity 1 - - f = \x. foo dInt $ bar x - -The (foo DInt) is floated out, and makes ineffective a RULE - foo (bar x) = ... - -One could go further and make exprIsCheap reply True to any -dictionary-typed expression, but that's more work. - -See Note [Dictionary-like types] in TcType.hs for why we use -isDictLikeTy here rather than isDictTy - -Note [Eta expanding thunks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't eta-expand - * Trivial RHSs x = y - * PAPs x = map g - * Thunks f = case y of p -> \x -> blah - -When we see - f = case y of p -> \x -> blah -should we eta-expand it? Well, if 'x' is a one-shot state token -then 'yes' because 'f' will only be applied once. But otherwise -we (conservatively) say no. My main reason is to avoid expanding -PAPSs - f = g d ==> f = \x. g d x -because that might in turn make g inline (if it has an inline pragma), -which we might not want. After all, INLINE pragmas say "inline only -when saturated" so we don't want to be too gung-ho about saturating! --} - -arityLam :: Id -> ArityType -> ArityType -arityLam id (ATop as) = ATop (idStateHackOneShotInfo id : as) -arityLam _ (ABot n) = ABot (n+1) - -floatIn :: Bool -> ArityType -> ArityType --- We have something like (let x = E in b), --- where b has the given arity type. -floatIn _ (ABot n) = ABot n -floatIn True (ATop as) = ATop as -floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as) - -- If E is not cheap, keep arity only for one-shots - -arityApp :: ArityType -> Bool -> ArityType --- Processing (fun arg) where at is the ArityType of fun, --- Knock off an argument and behave like 'let' -arityApp (ABot 0) _ = ABot 0 -arityApp (ABot n) _ = ABot (n-1) -arityApp (ATop []) _ = ATop [] -arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as) - -andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case' -andArityType (ABot n1) (ABot n2) = ABot (n1 `max` n2) -- Note [ABot branches: use max] -andArityType (ATop as) (ABot _) = ATop as -andArityType (ABot _) (ATop bs) = ATop bs -andArityType (ATop as) (ATop bs) = ATop (as `combine` bs) - where -- See Note [Combining case branches] - combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs - combine [] bs = takeWhile isOneShotInfo bs - combine as [] = takeWhile isOneShotInfo as - -{- Note [ABot branches: use max] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider case x of - True -> \x. error "urk" - False -> \xy. error "urk2" - -Remember: ABot n means "if you apply to n args, it'll definitely diverge". -So we need (ABot 2) for the whole thing, the /max/ of the ABot arities. - -Note [Combining case branches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - go = \x. let z = go e0 - go2 = \x. case x of - True -> z - False -> \s(one-shot). e1 - in go2 x -We *really* want to eta-expand go and go2. -When combining the barnches of the case we have - ATop [] `andAT` ATop [OneShotLam] -and we want to get ATop [OneShotLam]. But if the inner -lambda wasn't one-shot we don't want to do this. -(We need a proper arity analysis to justify that.) - -So we combine the best of the two branches, on the (slightly dodgy) -basis that if we know one branch is one-shot, then they all must be. --} - ---------------------------- -type CheapFun = CoreExpr -> Maybe Type -> Bool - -- How to decide if an expression is cheap - -- If the Maybe is Just, the type is the type - -- of the expression; Nothing means "don't know" - -data ArityEnv - = AE { ae_cheap_fn :: CheapFun - , ae_ped_bot :: Bool -- True <=> be pedantic about bottoms - } - -arityType :: ArityEnv -> CoreExpr -> ArityType - -arityType env (Cast e co) - = case arityType env e of - ATop os -> ATop (take co_arity os) - ABot n -> ABot (n `min` co_arity) - where - co_arity = length (typeArity (pSnd (coercionKind co))) - -- See Note [exprArity invariant] (2); must be true of - -- arityType too, since that is how we compute the arity - -- of variables, and they in turn affect result of exprArity - -- Trac #5441 is a nice demo - -- However, do make sure that ATop -> ATop and ABot -> ABot! - -- Casts don't affect that part. Getting this wrong provoked #5475 - -arityType _ (Var v) - | strict_sig <- idStrictness v - , not $ isTopSig strict_sig - , (ds, res) <- splitStrictSig strict_sig - , let arity = length ds - = if isBotRes res then ABot arity - else ATop (take arity one_shots) - | otherwise - = ATop (take (idArity v) one_shots) - where - one_shots :: [OneShotInfo] -- One-shot-ness derived from the type - one_shots = typeArity (idType v) - - -- Lambdas; increase arity -arityType env (Lam x e) - | isId x = arityLam x (arityType env e) - | otherwise = arityType env e - - -- Applications; decrease arity, except for types -arityType env (App fun (Type _)) - = arityType env fun -arityType env (App fun arg ) - = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing) - - -- Case/Let; keep arity if either the expression is cheap - -- or it's a 1-shot lambda - -- The former is not really right for Haskell - -- f x = case x of { (a,b) -> \y. e } - -- ===> - -- f x y = case x of { (a,b) -> e } - -- The difference is observable using 'seq' - -- -arityType env (Case scrut _ _ alts) - | exprIsBottom scrut || null alts - = ABot 0 -- Do not eta expand - -- See Note [Dealing with bottom (1)] - | otherwise - = case alts_type of - ABot n | n>0 -> ATop [] -- Don't eta expand - | otherwise -> ABot 0 -- if RHS is bottomming - -- See Note [Dealing with bottom (2)] - - ATop as | not (ae_ped_bot env) -- See Note [Dealing with bottom (3)] - , ae_cheap_fn env scrut Nothing -> ATop as - | exprOkForSpeculation scrut -> ATop as - | otherwise -> ATop (takeWhile isOneShotInfo as) - where - alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts] - -arityType env (Let b e) - = floatIn (cheap_bind b) (arityType env e) - where - cheap_bind (NonRec b e) = is_cheap (b,e) - cheap_bind (Rec prs) = all is_cheap prs - is_cheap (b,e) = ae_cheap_fn env e (Just (idType b)) - -arityType env (Tick t e) - | not (tickishIsCode t) = arityType env e - -arityType _ _ = vanillaArityType - -{- -%************************************************************************ -%* * - The main eta-expander -%* * -%************************************************************************ - -We go for: - f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym - (n >= 0) - -where (in both cases) - - * The xi can include type variables - - * The yi are all value variables - - * N is a NORMAL FORM (i.e. no redexes anywhere) - wanting a suitable number of extra args. - -The biggest reason for doing this is for cases like - - f = \x -> case x of - True -> \y -> e1 - False -> \y -> e2 - -Here we want to get the lambdas together. A good example is the nofib -program fibheaps, which gets 25% more allocation if you don't do this -eta-expansion. - -We may have to sandwich some coerces between the lambdas -to make the types work. exprEtaExpandArity looks through coerces -when computing arity; and etaExpand adds the coerces as necessary when -actually computing the expansion. - -Note [No crap in eta-expanded code] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The eta expander is careful not to introduce "crap". In particular, -given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it -returns a CoreExpr satisfying the same invariant. See Note [Eta -expansion and the CorePrep invariants] in CorePrep. - -This means the eta-expander has to do a bit of on-the-fly -simplification but it's not too hard. The alernative, of relying on -a subsequent clean-up phase of the Simplifier to de-crapify the result, -means you can't really use it in CorePrep, which is painful. - -Note [Eta expansion and SCCs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that SCCs are not treated specially by etaExpand. If we have - etaExpand 2 (\x -> scc "foo" e) - = (\xy -> (scc "foo" e) y) -So the costs of evaluating 'e' (not 'e y') are attributed to "foo" - -Note [Eta expansion and source notes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CorePrep puts floatable ticks outside of value applications, but not -type applications. As a result we might be trying to eta-expand an -expression like - - (src<...> v) @a - -which we want to lead to code like - - \x -> src<...> v @a x - -This means that we need to look through type applications and be ready -to re-add floats on the top. - --} - --- | @etaExpand n e@ returns an expression with --- the same meaning as @e@, but with arity @n@. --- --- Given: --- --- > e' = etaExpand n e --- --- We should have that: --- --- > ty = exprType e = exprType e' -etaExpand :: Arity -- ^ Result should have this number of value args - -> CoreExpr -- ^ Expression to expand - -> CoreExpr --- etaExpand arity e = res --- Then 'res' has at least 'arity' lambdas at the top --- --- etaExpand deals with for-alls. For example: --- etaExpand 1 E --- where E :: forall a. a -> a --- would return --- (/\b. \y::a -> E b y) --- --- It deals with coerces too, though they are now rare --- so perhaps the extra code isn't worth it - -etaExpand n orig_expr - = go n orig_expr - where - -- Strip off existing lambdas and casts - -- Note [Eta expansion and SCCs] - go 0 expr = expr - go n (Lam v body) | isTyVar v = Lam v (go n body) - | otherwise = Lam v (go (n-1) body) - go n (Cast expr co) = Cast (go n expr) co - go n expr - = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $ - retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas) - where - in_scope = mkInScopeSet (exprFreeVars expr) - (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr) - subst' = mkEmptySubst in_scope' - - -- Find ticks behind type apps. - -- See Note [Eta expansion and source notes] - (expr', args) = collectArgs expr - (ticks, expr'') = stripTicksTop tickishFloatable expr' - sexpr = foldl App expr'' args - retick expr = foldr mkTick expr ticks - - -- Wrapper Unwrapper --------------- -data EtaInfo = EtaVar Var -- /\a. [], [] a - -- \x. [], [] x - | EtaCo Coercion -- [] |> co, [] |> (sym co) - -instance Outputable EtaInfo where - ppr (EtaVar v) = text "EtaVar" <+> ppr v - ppr (EtaCo co) = text "EtaCo" <+> ppr co - -pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo] -pushCoercion co1 (EtaCo co2 : eis) - | isReflCo co = eis - | otherwise = EtaCo co : eis - where - co = co1 `mkTransCo` co2 - -pushCoercion co eis = EtaCo co : eis - --------------- -etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr -etaInfoAbs [] expr = expr -etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr) -etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co) - --------------- -etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr --- (etaInfoApp s e eis) returns something equivalent to --- ((substExpr s e) `appliedto` eis) - -etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) - = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis - -etaInfoApp subst (Cast e co1) eis - = etaInfoApp subst e (pushCoercion co' eis) - where - co' = CoreSubst.substCo subst co1 - -etaInfoApp subst (Case e b ty alts) eis - = Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts' - where - (subst1, b1) = substBndr subst b - alts' = map subst_alt alts - subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) - where - (subst2,bs') = substBndrs subst1 bs - - mk_alts_ty ty [] = ty - mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis - mk_alts_ty _ (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis - -etaInfoApp subst (Let b e) eis - = Let b' (etaInfoApp subst' e eis) - where - (subst', b') = etaInfoAppBind subst b eis - -etaInfoApp subst (Tick t e) eis - = Tick (substTickish subst t) (etaInfoApp subst e eis) - -etaInfoApp subst expr _ - | (Var fun, _) <- collectArgs expr - , Var fun' <- lookupIdSubst (text "etaInfoApp" <+> ppr fun) subst fun - , isJoinId fun' - = subst_expr subst expr - -etaInfoApp subst e eis - = go (subst_expr subst e) eis - where - go e [] = e - go e (EtaVar v : eis) = go (App e (varToCoreExpr v)) eis - go e (EtaCo co : eis) = go (Cast e co) eis - --------------- --- | Apply the eta info to a local binding. Mostly delegates to --- `etaInfoAppLocalBndr` and `etaInfoAppRhs`. -etaInfoAppBind :: Subst -> CoreBind -> [EtaInfo] -> (Subst, CoreBind) -etaInfoAppBind subst (NonRec bndr rhs) eis - = (subst', NonRec bndr' rhs') - where - bndr_w_new_type = etaInfoAppLocalBndr bndr eis - (subst', bndr1) = substBndr subst bndr_w_new_type - rhs' = etaInfoAppRhs subst bndr1 rhs eis - bndr' | isJoinId bndr = bndr1 `setIdArity` manifestArity rhs' - -- Arity may have changed - -- (see etaInfoAppRhs example) - | otherwise = bndr1 -etaInfoAppBind subst (Rec pairs) eis - = (subst', Rec (bndrs' `zip` rhss')) - where - (bndrs, rhss) = unzip pairs - bndrs_w_new_types = map (\bndr -> etaInfoAppLocalBndr bndr eis) bndrs - (subst', bndrs1) = substRecBndrs subst bndrs_w_new_types - rhss' = zipWith process bndrs1 rhss - process bndr' rhs = etaInfoAppRhs subst' bndr' rhs eis - bndrs' | isJoinId (head bndrs) - = [ bndr1 `setIdArity` manifestArity rhs' - | (bndr1, rhs') <- bndrs1 `zip` rhss' ] - -- Arities may have changed - -- (see etaInfoAppRhs example) - | otherwise - = bndrs1 - --------------- --- | Apply the eta info to a binder's RHS. Only interesting for a join point, --- where we might have this: --- join j :: a -> [a] -> [a] --- j x = \xs -> x : xs in jump j z --- Eta-expanding produces this: --- \ys -> (join j :: a -> [a] -> [a] --- j x = \xs -> x : xs in jump j z) ys --- Now when we push the application to ys inward (see Note [No crap in --- eta-expanded code]), it goes to the body of the RHS of the join point (after --- the lambda x!): --- \ys -> join j :: a -> [a] --- j x = x : ys in jump j z --- Note that the type and arity of j have both changed. -etaInfoAppRhs :: Subst -> CoreBndr -> CoreExpr -> [EtaInfo] -> CoreExpr -etaInfoAppRhs subst bndr expr eis - | Just arity <- isJoinId_maybe bndr - = do_join_point arity - | otherwise - = subst_expr subst expr - where - do_join_point arity = mkLams join_bndrs' join_body' - where - (join_bndrs, join_body) = collectNBinders arity expr - (subst', join_bndrs') = substBndrs subst join_bndrs - join_body' = etaInfoApp subst' join_body eis - - --------------- --- | Apply the eta info to a local binder. A join point will have the EtaInfos --- applied to its RHS, so its type may change. See comment on etaInfoAppRhs for --- an example. See Note [No crap in eta-expanded code] for why all this is --- necessary. -etaInfoAppLocalBndr :: CoreBndr -> [EtaInfo] -> CoreBndr -etaInfoAppLocalBndr bndr orig_eis - = case isJoinId_maybe bndr of - Just arity -> bndr `setIdType` modifyJoinResTy arity (app orig_eis) ty - Nothing -> bndr - where - ty = idType bndr - - -- | Apply the given EtaInfos to the result type of the join point. - app :: [EtaInfo] -- To apply - -> Type -- Result type of join point - -> Type -- New result type - app [] ty - = ty - app (EtaVar v : eis) ty - | isId v = app eis (funResultTy ty) - | otherwise = app eis (piResultTy ty (mkTyVarTy v)) - app (EtaCo co : eis) ty - = ASSERT2(from_ty `eqType` ty, fsep ([text "can't apply", ppr orig_eis, - text "to", ppr bndr <+> dcolon <+> - ppr (idType bndr)])) - app eis to_ty - where - Pair from_ty to_ty = coercionKind co - --------------- -mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type - -> (InScopeSet, [EtaInfo]) - -- EtaInfo contains fresh variables, - -- not free in the incoming CoreExpr - -- Outgoing InScopeSet includes the EtaInfo vars - -- and the original free vars - -mkEtaWW orig_n orig_expr in_scope orig_ty - = go orig_n empty_subst orig_ty [] - where - empty_subst = mkEmptyTCvSubst in_scope - - go n subst ty eis -- See Note [exprArity invariant] - | n == 0 - = (getTCvInScope subst, reverse eis) - - | Just (tv,ty') <- splitForAllTy_maybe ty - , let (subst', tv') = Type.substTyVarBndr subst tv - -- Avoid free vars of the original expression - = go n subst' ty' (EtaVar tv' : eis) - - | Just (arg_ty, res_ty) <- splitFunTy_maybe ty - , not (isTypeLevPoly arg_ty) - -- See Note [Levity polymorphism invariants] in CoreSyn - -- See also test case typecheck/should_run/EtaExpandLevPoly - - , let (subst', eta_id') = freshEtaId n subst arg_ty - -- Avoid free vars of the original expression - = go (n-1) subst' res_ty (EtaVar eta_id' : eis) - - | Just (co, ty') <- topNormaliseNewType_maybe ty - = -- Given this: - -- newtype T = MkT ([T] -> Int) - -- Consider eta-expanding this - -- eta_expand 1 e T - -- We want to get - -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - go n subst ty' (EtaCo co : eis) - - | otherwise -- We have an expression of arity > 0, - -- but its type isn't a function, or a binder - -- is levity-polymorphic - = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr ) - (getTCvInScope subst, reverse eis) - -- This *can* legitmately happen: - -- e.g. coerce Int (\x. x) Essentially the programmer is - -- playing fast and loose with types (Happy does this a lot). - -- So we simply decline to eta-expand. Otherwise we'd end up - -- with an explicit lambda having a non-function type - - - --------------- --- Don't use short-cutting substitution - we may be changing the types of join --- points, so applying the in-scope set is necessary --- TODO Check if we actually *are* changing any join points' types - -subst_expr :: Subst -> CoreExpr -> CoreExpr -subst_expr = substExpr (text "CoreArity:substExpr") - - --------------- - --- | Split an expression into the given number of binders and a body, --- eta-expanding if necessary. Counts value *and* type binders. -etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) -etaExpandToJoinPoint join_arity expr - = go join_arity [] expr - where - go 0 rev_bs e = (reverse rev_bs, e) - go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e - go n rev_bs e = case etaBodyForJoinPoint n e of - (bs, e') -> (reverse rev_bs ++ bs, e') - -etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule -etaExpandToJoinPointRule _ rule@(BuiltinRule {}) - = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule])) - -- How did a local binding get a built-in rule anyway? Probably a plugin. - rule -etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs - , ru_args = args }) - | need_args == 0 - = rule - | need_args < 0 - = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) - | otherwise - = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args - , ru_rhs = new_rhs } - where - need_args = join_arity - length args - (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs - new_args = varsToCoreExprs new_bndrs - --- Adds as many binders as asked for; assumes expr is not a lambda -etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) -etaBodyForJoinPoint need_args body - = go need_args (exprType body) (init_subst body) [] body - where - go 0 _ _ rev_bs e - = (reverse rev_bs, e) - go n ty subst rev_bs e - | Just (tv, res_ty) <- splitForAllTy_maybe ty - , let (subst', tv') = Type.substTyVarBndr subst tv - = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` Type (mkTyVarTy tv')) - | Just (arg_ty, res_ty) <- splitFunTy_maybe ty - , let (subst', b) = freshEtaId n subst arg_ty - = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b) - | otherwise - = pprPanic "etaBodyForJoinPoint" $ int need_args $$ - ppr body $$ ppr (exprType body) - - init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e)) - --------------- -freshEtaId :: Int -> TCvSubst -> Type -> (TCvSubst, Id) --- Make a fresh Id, with specified type (after applying substitution) --- It should be "fresh" in the sense that it's not in the in-scope set --- of the TvSubstEnv; and it should itself then be added to the in-scope --- set of the TvSubstEnv --- --- The Int is just a reasonable starting point for generating a unique; --- it does not necessarily have to be unique itself. -freshEtaId n subst ty - = (subst', eta_id') - where - ty' = Type.substTy subst ty - eta_id' = uniqAway (getTCvInScope subst) $ - mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty' - subst' = extendTCvInScope subst eta_id' diff --git a/coreSyn/CoreFVs.hs b/coreSyn/CoreFVs.hs deleted file mode 100644 --- a/coreSyn/CoreFVs.hs +++ /dev/null @@ -1,825 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -Taken quite directly from the Peyton Jones/Lester paper. --} - -{-# LANGUAGE CPP #-} - --- | A module concerned with finding the free variables of an expression. -module CoreFVs ( - -- * Free variables of expressions and binding groups - exprFreeVars, - exprFreeVarsDSet, - exprFreeVarsList, - exprFreeIds, - exprFreeIdsDSet, - exprFreeIdsList, - exprsFreeIdsDSet, - exprsFreeIdsList, - exprsFreeVars, - exprsFreeVarsList, - bindFreeVars, - - -- * Selective free variables of expressions - InterestingVarFun, - exprSomeFreeVars, exprsSomeFreeVars, - exprSomeFreeVarsList, exprsSomeFreeVarsList, - - -- * Free variables of Rules, Vars and Ids - varTypeTyCoVars, - varTypeTyCoFVs, - idUnfoldingVars, idFreeVars, dIdFreeVars, - bndrRuleAndUnfoldingVarsDSet, - idFVs, - idRuleVars, idRuleRhsVars, stableUnfoldingVars, - ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, - rulesFreeVarsDSet, - ruleLhsFreeIds, ruleLhsFreeIdsList, - vectsFreeVars, - - expr_fvs, - - -- * Orphan names - orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom, - orphNamesOfTypes, orphNamesOfCoCon, - exprsOrphNames, orphNamesOfFamInst, - - -- * Core syntax tree annotation with free variables - FVAnn, -- annotation, abstract - CoreExprWithFVs, -- = AnnExpr Id FVAnn - CoreExprWithFVs', -- = AnnExpr' Id FVAnn - CoreBindWithFVs, -- = AnnBind Id FVAnn - CoreAltWithFVs, -- = AnnAlt Id FVAnn - freeVars, -- CoreExpr -> CoreExprWithFVs - freeVarsBind, -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs) - freeVarsOf, -- CoreExprWithFVs -> DIdSet - freeVarsOfType, -- CoreExprWithFVs -> TyCoVarSet - freeVarsOfAnn, freeVarsOfTypeAnn, - exprTypeFV -- CoreExprWithFVs -> Type - ) where - -#include "HsVersions.h" - -import CoreSyn -import Id -import IdInfo -import NameSet -import UniqSet -import Unique (Uniquable (..)) -import Literal ( literalType ) -import Name -import VarSet -import Var -import Type -import TyCoRep -import TyCon -import CoAxiom -import FamInstEnv -import TysPrim( funTyConName ) -import Coercion -import Maybes( orElse ) -import Util -import BasicTypes( Activation ) -import Outputable -import FV - -{- -************************************************************************ -* * -\section{Finding the free variables of an expression} -* * -************************************************************************ - -This function simply finds the free variables of an expression. -So far as type variables are concerned, it only finds tyvars that are - - * free in type arguments, - * free in the type of a binder, - -but not those that are free in the type of variable occurrence. --} - --- | Find all locally-defined free Ids or type variables in an expression --- returning a non-deterministic set. -exprFreeVars :: CoreExpr -> VarSet -exprFreeVars = fvVarSet . exprFVs - --- | Find all locally-defined free Ids or type variables in an expression --- returning a composable FV computation. See Note [FV naming conventions] in FV --- for why export it. -exprFVs :: CoreExpr -> FV -exprFVs = filterFV isLocalVar . expr_fvs - --- | Find all locally-defined free Ids or type variables in an expression --- returning a deterministic set. -exprFreeVarsDSet :: CoreExpr -> DVarSet -exprFreeVarsDSet = fvDVarSet . exprFVs - --- | Find all locally-defined free Ids or type variables in an expression --- returning a deterministically ordered list. -exprFreeVarsList :: CoreExpr -> [Var] -exprFreeVarsList = fvVarList . exprFVs - --- | Find all locally-defined free Ids in an expression -exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids -exprFreeIds = exprSomeFreeVars isLocalId - --- | Find all locally-defined free Ids in an expression --- returning a deterministic set. -exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids -exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId - --- | Find all locally-defined free Ids in an expression --- returning a deterministically ordered list. -exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids -exprFreeIdsList = exprSomeFreeVarsList isLocalId - --- | Find all locally-defined free Ids in several expressions --- returning a deterministic set. -exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids -exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId - --- | Find all locally-defined free Ids in several expressions --- returning a deterministically ordered list. -exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids -exprsFreeIdsList = exprsSomeFreeVarsList isLocalId - --- | Find all locally-defined free Ids or type variables in several expressions --- returning a non-deterministic set. -exprsFreeVars :: [CoreExpr] -> VarSet -exprsFreeVars = fvVarSet . exprsFVs - --- | Find all locally-defined free Ids or type variables in several expressions --- returning a composable FV computation. See Note [FV naming conventions] in FV --- for why export it. -exprsFVs :: [CoreExpr] -> FV -exprsFVs exprs = mapUnionFV exprFVs exprs - --- | Find all locally-defined free Ids or type variables in several expressions --- returning a deterministically ordered list. -exprsFreeVarsList :: [CoreExpr] -> [Var] -exprsFreeVarsList = fvVarList . exprsFVs - --- | Find all locally defined free Ids in a binding group -bindFreeVars :: CoreBind -> VarSet -bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r) -bindFreeVars (Rec prs) = fvVarSet $ filterFV isLocalVar $ - addBndrs (map fst prs) - (mapUnionFV rhs_fvs prs) - --- | Finds free variables in an expression selected by a predicate -exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting - -> CoreExpr - -> VarSet -exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e - --- | Finds free variables in an expression selected by a predicate --- returning a deterministically ordered list. -exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting - -> CoreExpr - -> [Var] -exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e - --- | Finds free variables in an expression selected by a predicate --- returning a deterministic set. -exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting - -> CoreExpr - -> DVarSet -exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e - --- | Finds free variables in several expressions selected by a predicate -exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting - -> [CoreExpr] - -> VarSet -exprsSomeFreeVars fv_cand es = - fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es - --- | Finds free variables in several expressions selected by a predicate --- returning a deterministically ordered list. -exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting - -> [CoreExpr] - -> [Var] -exprsSomeFreeVarsList fv_cand es = - fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es - --- | Finds free variables in several expressions selected by a predicate --- returning a deterministic set. -exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting - -> [CoreExpr] - -> DVarSet -exprsSomeFreeVarsDSet fv_cand e = - fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e - --- Comment about obselete code --- We used to gather the free variables the RULES at a variable occurrence --- with the following cryptic comment: --- "At a variable occurrence, add in any free variables of its rule rhss --- Curiously, we gather the Id's free *type* variables from its binding --- site, but its free *rule-rhs* variables from its usage sites. This --- is a little weird. The reason is that the former is more efficient, --- but the latter is more fine grained, and a makes a difference when --- a variable mentions itself one of its own rule RHSs" --- Not only is this "weird", but it's also pretty bad because it can make --- a function seem more recursive than it is. Suppose --- f = ...g... --- g = ... --- RULE g x = ...f... --- Then f is not mentioned in its own RHS, and needn't be a loop breaker --- (though g may be). But if we collect the rule fvs from g's occurrence, --- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB --- code in GHC.Enum.) --- --- Anyway, it seems plain wrong. The RULE is like an extra RHS for the --- function, so its free variables belong at the definition site. --- --- Deleted code looked like --- foldVarSet add_rule_var var_itself_set (idRuleVars var) --- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var --- | otherwise = set --- SLPJ Feb06 - -addBndr :: CoreBndr -> FV -> FV -addBndr bndr fv fv_cand in_scope acc - = (varTypeTyCoFVs bndr `unionFV` - -- Include type variables in the binder's type - -- (not just Ids; coercion variables too!) - FV.delFV bndr fv) fv_cand in_scope acc - -addBndrs :: [CoreBndr] -> FV -> FV -addBndrs bndrs fv = foldr addBndr fv bndrs - -expr_fvs :: CoreExpr -> FV -expr_fvs (Type ty) fv_cand in_scope acc = - tyCoFVsOfType ty fv_cand in_scope acc -expr_fvs (Coercion co) fv_cand in_scope acc = - tyCoFVsOfCo co fv_cand in_scope acc -expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc -expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc -expr_fvs (Tick t expr) fv_cand in_scope acc = - (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc -expr_fvs (App fun arg) fv_cand in_scope acc = - (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc -expr_fvs (Lam bndr body) fv_cand in_scope acc = - addBndr bndr (expr_fvs body) fv_cand in_scope acc -expr_fvs (Cast expr co) fv_cand in_scope acc = - (expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc - -expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc - = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr - (mapUnionFV alt_fvs alts)) fv_cand in_scope acc - where - alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) - -expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc - = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body)) - fv_cand in_scope acc - -expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc - = addBndrs (map fst pairs) - (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body) - fv_cand in_scope acc - ---------- -rhs_fvs :: (Id, CoreExpr) -> FV -rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV` - bndrRuleAndUnfoldingFVs bndr - -- Treat any RULES as extra RHSs of the binding - ---------- -exprs_fvs :: [CoreExpr] -> FV -exprs_fvs exprs = mapUnionFV expr_fvs exprs - -tickish_fvs :: Tickish Id -> FV -tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids -tickish_fvs _ = emptyFV - -{- -************************************************************************ -* * -\section{Free names} -* * -************************************************************************ --} - --- | Finds the free /external/ names of an expression, notably --- including the names of type constructors (which of course do not show --- up in 'exprFreeVars'). -exprOrphNames :: CoreExpr -> NameSet --- There's no need to delete local binders, because they will all --- be /internal/ names. -exprOrphNames e - = go e - where - go (Var v) - | isExternalName n = unitNameSet n - | otherwise = emptyNameSet - where n = idName v - go (Lit _) = emptyNameSet - go (Type ty) = orphNamesOfType ty -- Don't need free tyvars - go (Coercion co) = orphNamesOfCo co - go (App e1 e2) = go e1 `unionNameSet` go e2 - go (Lam v e) = go e `delFromNameSet` idName v - go (Tick _ e) = go e - go (Cast e co) = go e `unionNameSet` orphNamesOfCo co - go (Let (NonRec _ r) e) = go e `unionNameSet` go r - go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSet` go e - go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty - `unionNameSet` unionNameSets (map go_alt as) - - go_alt (_,_,r) = go r - --- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details -exprsOrphNames :: [CoreExpr] -> NameSet -exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es - - -{- ********************************************************************** -%* * - orphNamesXXX - -%* * -%********************************************************************* -} - -orphNamesOfTyCon :: TyCon -> NameSet -orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of - Nothing -> emptyNameSet - Just cls -> unitNameSet (getName cls) - -orphNamesOfType :: Type -> NameSet -orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty' - -- Look through type synonyms (Trac #4912) -orphNamesOfType (TyVarTy _) = emptyNameSet -orphNamesOfType (LitTy {}) = emptyNameSet -orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon - `unionNameSet` orphNamesOfTypes tys -orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderKind bndr) - `unionNameSet` orphNamesOfType res -orphNamesOfType (FunTy arg res) = unitNameSet funTyConName -- NB! See Trac #8535 - `unionNameSet` orphNamesOfType arg - `unionNameSet` orphNamesOfType res -orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg -orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co -orphNamesOfType (CoercionTy co) = orphNamesOfCo co - -orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet -orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet - -orphNamesOfTypes :: [Type] -> NameSet -orphNamesOfTypes = orphNamesOfThings orphNamesOfType - -orphNamesOfCo :: Coercion -> NameSet -orphNamesOfCo (Refl _ ty) = orphNamesOfType ty -orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos -orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (ForAllCo _ kind_co co) - = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co -orphNamesOfCo (FunCo _ co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (CoVarCo _) = emptyNameSet -orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos -orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2 -orphNamesOfCo (SymCo co) = orphNamesOfCo co -orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (NthCo _ co) = orphNamesOfCo co -orphNamesOfCo (LRCo _ co) = orphNamesOfCo co -orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg -orphNamesOfCo (CoherenceCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (KindCo co) = orphNamesOfCo co -orphNamesOfCo (SubCo co) = orphNamesOfCo co -orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs - -orphNamesOfProv :: UnivCoProvenance -> NameSet -orphNamesOfProv UnsafeCoerceProv = emptyNameSet -orphNamesOfProv (PhantomProv co) = orphNamesOfCo co -orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co -orphNamesOfProv (PluginProv _) = emptyNameSet -orphNamesOfProv (HoleProv _) = emptyNameSet - -orphNamesOfCos :: [Coercion] -> NameSet -orphNamesOfCos = orphNamesOfThings orphNamesOfCo - -orphNamesOfCoCon :: CoAxiom br -> NameSet -orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) - = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches - -orphNamesOfAxiom :: CoAxiom br -> NameSet -orphNamesOfAxiom axiom - = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) - `extendNameSet` getName (coAxiomTyCon axiom) - -orphNamesOfCoAxBranches :: Branches br -> NameSet -orphNamesOfCoAxBranches - = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches - -orphNamesOfCoAxBranch :: CoAxBranch -> NameSet -orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) - = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs - --- | orphNamesOfAxiom collects the names of the concrete types and --- type constructors that make up the LHS of a type family instance, --- including the family name itself. --- --- For instance, given `type family Foo a b`: --- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H] --- --- Used in the implementation of ":info" in GHCi. -orphNamesOfFamInst :: FamInst -> NameSet -orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst) - -{- -************************************************************************ -* * -\section[freevars-everywhere]{Attaching free variables to every sub-expression} -* * -************************************************************************ --} - --- | Those variables free in the right hand side of a rule returned as a --- non-deterministic set -ruleRhsFreeVars :: CoreRule -> VarSet -ruleRhsFreeVars (BuiltinRule {}) = noFVs -ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) - = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) - -- See Note [Rule free var hack] - --- | Those variables free in the both the left right hand sides of a rule --- returned as a non-deterministic set -ruleFreeVars :: CoreRule -> VarSet -ruleFreeVars = fvVarSet . ruleFVs - --- | Those variables free in the both the left right hand sides of a rule --- returned as FV computation -ruleFVs :: CoreRule -> FV -ruleFVs (BuiltinRule {}) = emptyFV -ruleFVs (Rule { ru_fn = _do_not_include - -- See Note [Rule free var hack] - , ru_bndrs = bndrs - , ru_rhs = rhs, ru_args = args }) - = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args)) - --- | Those variables free in the both the left right hand sides of rules --- returned as FV computation -rulesFVs :: [CoreRule] -> FV -rulesFVs = mapUnionFV ruleFVs - --- | Those variables free in the both the left right hand sides of rules --- returned as a deterministic set -rulesFreeVarsDSet :: [CoreRule] -> DVarSet -rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules - -idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet --- Just the variables free on the *rhs* of a rule -idRuleRhsVars is_active id - = mapUnionVarSet get_fvs (idCoreRules id) - where - get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs - , ru_rhs = rhs, ru_act = act }) - | is_active act - -- See Note [Finding rule RHS free vars] in OccAnal.hs - = delOneFromUniqSet_Directly fvs (getUnique fn) - -- Note [Rule free var hack] - where - fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) - get_fvs _ = noFVs - --- | Those variables free in the right hand side of several rules -rulesFreeVars :: [CoreRule] -> VarSet -rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules - -ruleLhsFreeIds :: CoreRule -> VarSet --- ^ This finds all locally-defined free Ids on the left hand side of a rule --- and returns them as a non-deterministic set -ruleLhsFreeIds = fvVarSet . ruleLhsFVIds - -ruleLhsFreeIdsList :: CoreRule -> [Var] --- ^ This finds all locally-defined free Ids on the left hand side of a rule --- and returns them as a determinisitcally ordered list -ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds - -ruleLhsFVIds :: CoreRule -> FV --- ^ This finds all locally-defined free Ids on the left hand side of a rule --- and returns an FV computation -ruleLhsFVIds (BuiltinRule {}) = emptyFV -ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args }) - = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args) - -{- -Note [Rule free var hack] (Not a hack any more) -~~~~~~~~~~~~~~~~~~~~~~~~~ -We used not to include the Id in its own rhs free-var set. -Otherwise the occurrence analyser makes bindings recursive: - f x y = x+y - RULE: f (f x y) z ==> f x (f y z) -However, the occurrence analyser distinguishes "non-rule loop breakers" -from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will -put this 'f' in a Rec block, but will mark the binding as a non-rule loop -breaker, which is perfectly inlinable. --} - --- |Free variables of a vectorisation declaration -vectsFreeVars :: [CoreVect] -> VarSet -vectsFreeVars = mapUnionVarSet vectFreeVars - where - vectFreeVars (Vect _ rhs) = fvVarSet $ filterFV isLocalId $ expr_fvs rhs - vectFreeVars (NoVect _) = noFVs - vectFreeVars (VectType _ _ _) = noFVs - vectFreeVars (VectClass _) = noFVs - vectFreeVars (VectInst _) = noFVs - -- this function is only concerned with values, not types - -{- -************************************************************************ -* * -\section[freevars-everywhere]{Attaching free variables to every sub-expression} -* * -************************************************************************ - -The free variable pass annotates every node in the expression with its -NON-GLOBAL free variables and type variables. --} - -data FVAnn = FVAnn { fva_fvs :: DVarSet -- free in expression - , fva_ty_fvs :: DVarSet -- free only in expression's type - , fva_ty :: Type -- expression's type - } - --- | Every node in a binding group annotated with its --- (non-global) free variables, both Ids and TyVars, and type. -type CoreBindWithFVs = AnnBind Id FVAnn --- | Every node in an expression annotated with its --- (non-global) free variables, both Ids and TyVars, and type. -type CoreExprWithFVs = AnnExpr Id FVAnn -type CoreExprWithFVs' = AnnExpr' Id FVAnn - --- | Every node in an expression annotated with its --- (non-global) free variables, both Ids and TyVars, and type. -type CoreAltWithFVs = AnnAlt Id FVAnn - -freeVarsOf :: CoreExprWithFVs -> DIdSet --- ^ Inverse function to 'freeVars' -freeVarsOf (FVAnn { fva_fvs = fvs }, _) = fvs - --- | Extract the vars free in an annotated expression's type -freeVarsOfType :: CoreExprWithFVs -> DTyCoVarSet -freeVarsOfType (FVAnn { fva_ty_fvs = ty_fvs }, _) = ty_fvs - --- | Extract the type of an annotated expression. (This is cheap.) -exprTypeFV :: CoreExprWithFVs -> Type -exprTypeFV (FVAnn { fva_ty = ty }, _) = ty - --- | Extract the vars reported in a FVAnn -freeVarsOfAnn :: FVAnn -> DIdSet -freeVarsOfAnn = fva_fvs - --- | Extract the type-level vars reported in a FVAnn -freeVarsOfTypeAnn :: FVAnn -> DTyCoVarSet -freeVarsOfTypeAnn = fva_ty_fvs - -noFVs :: VarSet -noFVs = emptyVarSet - -aFreeVar :: Var -> DVarSet -aFreeVar = unitDVarSet - -unionFVs :: DVarSet -> DVarSet -> DVarSet -unionFVs = unionDVarSet - -unionFVss :: [DVarSet] -> DVarSet -unionFVss = unionDVarSets - -delBindersFV :: [Var] -> DVarSet -> DVarSet -delBindersFV bs fvs = foldr delBinderFV fvs bs - -delBinderFV :: Var -> DVarSet -> DVarSet --- This way round, so we can do it multiple times using foldr - --- (b `delBinderFV` s) removes the binder b from the free variable set s, --- but *adds* to s --- --- the free variables of b's type --- --- This is really important for some lambdas: --- In (\x::a -> x) the only mention of "a" is in the binder. --- --- Also in --- let x::a = b in ... --- we should really note that "a" is free in this expression. --- It'll be pinned inside the /\a by the binding for b, but --- it seems cleaner to make sure that a is in the free-var set --- when it is mentioned. --- --- This also shows up in recursive bindings. Consider: --- /\a -> letrec x::a = x in E --- Now, there are no explicit free type variables in the RHS of x, --- but nevertheless "a" is free in its definition. So we add in --- the free tyvars of the types of the binders, and include these in the --- free vars of the group, attached to the top level of each RHS. --- --- This actually happened in the defn of errorIO in IOBase.hs: --- errorIO (ST io) = case (errorIO# io) of --- _ -> bottom --- where --- bottom = bottom -- Never evaluated - -delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b - -- Include coercion variables too! - -varTypeTyCoVars :: Var -> TyCoVarSet --- Find the type/kind variables free in the type of the id/tyvar -varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var - -dVarTypeTyCoVars :: Var -> DTyCoVarSet --- Find the type/kind/coercion variables free in the type of the id/tyvar -dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var - -varTypeTyCoFVs :: Var -> FV -varTypeTyCoFVs var = tyCoFVsOfType (varType var) - -idFreeVars :: Id -> VarSet -idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id - -dIdFreeVars :: Id -> DVarSet -dIdFreeVars id = fvDVarSet $ idFVs id - -idFVs :: Id -> FV --- Type variables, rule variables, and inline variables -idFVs id = ASSERT( isId id) - varTypeTyCoFVs id `unionFV` - bndrRuleAndUnfoldingFVs id - -bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet -bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id - -bndrRuleAndUnfoldingFVs :: Id -> FV -bndrRuleAndUnfoldingFVs id - | isId id = idRuleFVs id `unionFV` idUnfoldingFVs id - | otherwise = emptyFV - -idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars -idRuleVars id = fvVarSet $ idRuleFVs id - -idRuleFVs :: Id -> FV -idRuleFVs id = ASSERT( isId id) - FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id)) - -idUnfoldingVars :: Id -> VarSet --- Produce free vars for an unfolding, but NOT for an ordinary --- (non-inline) unfolding, since it is a dup of the rhs --- and we'll get exponential behaviour if we look at both unf and rhs! --- But do look at the *real* unfolding, even for loop breakers, else --- we might get out-of-scope variables -idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id - -idUnfoldingFVs :: Id -> FV -idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV - -stableUnfoldingVars :: Unfolding -> Maybe VarSet -stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf - -stableUnfoldingFVs :: Unfolding -> Maybe FV -stableUnfoldingFVs unf - = case unf of - CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | isStableSource src - -> Just (filterFV isLocalVar $ expr_fvs rhs) - DFunUnfolding { df_bndrs = bndrs, df_args = args } - -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args) - -- DFuns are top level, so no fvs from types of bndrs - _other -> Nothing - - -{- -************************************************************************ -* * -\subsection{Free variables (and types)} -* * -************************************************************************ --} - -freeVarsBind :: CoreBind - -> DVarSet -- Free vars of scope of binding - -> (CoreBindWithFVs, DVarSet) -- Return free vars of binding + scope -freeVarsBind (NonRec binder rhs) body_fvs - = ( AnnNonRec binder rhs2 - , freeVarsOf rhs2 `unionFVs` body_fvs2 - `unionFVs` bndrRuleAndUnfoldingVarsDSet binder ) - where - rhs2 = freeVars rhs - body_fvs2 = binder `delBinderFV` body_fvs - -freeVarsBind (Rec binds) body_fvs - = ( AnnRec (binders `zip` rhss2) - , delBindersFV binders all_fvs ) - where - (binders, rhss) = unzip binds - rhss2 = map freeVars rhss - rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 - binders_fvs = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders - all_fvs = rhs_body_fvs `unionFVs` binders_fvs - -- The "delBinderFV" happens after adding the idSpecVars, - -- since the latter may add some of the binders as fvs - -freeVars :: CoreExpr -> CoreExprWithFVs --- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node -freeVars = go - where - go :: CoreExpr -> CoreExprWithFVs - go (Var v) - = (FVAnn fvs ty_fvs (idType v), AnnVar v) - where - -- ToDo: insert motivating example for why we *need* - -- to include the idSpecVars in the FV list. - -- Actually [June 98] I don't think it's necessary - -- fvs = fvs_v `unionVarSet` idSpecVars v - - (fvs, ty_fvs) - | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, dVarTypeTyCoVars v) - | otherwise = (emptyDVarSet, emptyDVarSet) - - go (Lit lit) = (FVAnn emptyDVarSet emptyDVarSet (literalType lit), AnnLit lit) - go (Lam b body) - = ( FVAnn { fva_fvs = b_fvs `unionFVs` (b `delBinderFV` body_fvs) - , fva_ty_fvs = b_fvs `unionFVs` (b `delBinderFV` body_ty_fvs) - , fva_ty = mkFunTy b_ty body_ty } - , AnnLam b body' ) - where - body'@(FVAnn { fva_fvs = body_fvs, fva_ty_fvs = body_ty_fvs - , fva_ty = body_ty }, _) = go body - b_ty = idType b - b_fvs = tyCoVarsOfTypeDSet b_ty - - go (App fun arg) - = ( FVAnn { fva_fvs = freeVarsOf fun' `unionFVs` freeVarsOf arg' - , fva_ty_fvs = tyCoVarsOfTypeDSet res_ty - , fva_ty = res_ty } - , AnnApp fun' arg' ) - where - fun' = go fun - fun_ty = exprTypeFV fun' - arg' = go arg - res_ty = applyTypeToArg fun_ty arg - - go (Case scrut bndr ty alts) - = ( FVAnn { fva_fvs = (bndr `delBinderFV` alts_fvs) - `unionFVs` freeVarsOf scrut2 - `unionFVs` tyCoVarsOfTypeDSet ty - -- don't need to look at (idType bndr) - -- b/c that's redundant with scrut - , fva_ty_fvs = tyCoVarsOfTypeDSet ty - , fva_ty = ty } - , AnnCase scrut2 bndr ty alts2 ) - where - scrut2 = go scrut - - (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts - alts_fvs = unionFVss alts_fvs_s - - fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), - (con, args, rhs2)) - where - rhs2 = go rhs - - go (Let bind body) - = ( FVAnn { fva_fvs = bind_fvs - , fva_ty_fvs = freeVarsOfType body2 - , fva_ty = exprTypeFV body2 } - , AnnLet bind2 body2 ) - where - (bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2) - body2 = go body - - go (Cast expr co) - = ( FVAnn (freeVarsOf expr2 `unionFVs` cfvs) (tyCoVarsOfTypeDSet to_ty) to_ty - , AnnCast expr2 (c_ann, co) ) - where - expr2 = go expr - cfvs = tyCoVarsOfCoDSet co - c_ann = FVAnn cfvs (tyCoVarsOfTypeDSet co_ki) co_ki - co_ki = coercionType co - Just (_, to_ty) = splitCoercionType_maybe co_ki - - - go (Tick tickish expr) - = ( FVAnn { fva_fvs = tickishFVs tickish `unionFVs` freeVarsOf expr2 - , fva_ty_fvs = freeVarsOfType expr2 - , fva_ty = exprTypeFV expr2 } - , AnnTick tickish expr2 ) - where - expr2 = go expr - tickishFVs (Breakpoint _ ids) = mkDVarSet ids - tickishFVs _ = emptyDVarSet - - go (Type ty) = ( FVAnn (tyCoVarsOfTypeDSet ty) - (tyCoVarsOfTypeDSet ki) - ki - , AnnType ty) - where - ki = typeKind ty - - go (Coercion co) = ( FVAnn (tyCoVarsOfCoDSet co) - (tyCoVarsOfTypeDSet ki) - ki - , AnnCoercion co) - where - ki = coercionType co diff --git a/coreSyn/CoreLint.hs b/coreSyn/CoreLint.hs deleted file mode 100644 --- a/coreSyn/CoreLint.hs +++ /dev/null @@ -1,2478 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - - -A ``lint'' pass to check for Core correctness --} - -{-# LANGUAGE CPP #-} - -module CoreLint ( - lintCoreBindings, lintUnfolding, - lintPassResult, lintInteractiveExpr, lintExpr, - lintAnnots, - - -- ** Debug output - endPass, endPassIO, - dumpPassResult, - CoreLint.dumpIfSet, - ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreFVs -import CoreUtils -import CoreStats ( coreBindsStats ) -import CoreMonad -import Bag -import Literal -import DataCon -import TysWiredIn -import TysPrim -import TcType ( isFloatingTy ) -import Var -import VarEnv -import VarSet -import Name -import Id -import IdInfo -import PprCore -import ErrUtils -import Coercion -import SrcLoc -import Kind -import Type -import RepType -import TyCoRep -- checks validity of types/coercions -import TyCon -import CoAxiom -import BasicTypes -import ErrUtils as Err -import ListSetOps -import PrelNames -import Outputable -import FastString -import Util -import InstEnv ( instanceDFunId ) -import OptCoercion ( checkAxInstCo ) -import UniqSupply -import CoreArity ( typeArity ) -import Demand ( splitStrictSig, isBotRes ) - -import HscTypes -import DynFlags -import Control.Monad -#if __GLASGOW_HASKELL__ > 710 -import qualified Control.Monad.Fail as MonadFail -#endif -import MonadUtils -import Data.Maybe -import Pair -import qualified GHC.LanguageExtensions as LangExt - -{- -Note [GHC Formalism] -~~~~~~~~~~~~~~~~~~~~ -This file implements the type-checking algorithm for System FC, the "official" -name of the Core language. Type safety of FC is heart of the claim that -executables produced by GHC do not have segmentation faults. Thus, it is -useful to be able to reason about System FC independently of reading the code. -To this purpose, there is a document core-spec.pdf built in docs/core-spec that -contains a formalism of the types and functions dealt with here. If you change -just about anything in this file or you change other types/functions throughout -the Core language (all signposted to this note), you should update that -formalism. See docs/core-spec/README for more info about how to do so. - -Note [check vs lint] -~~~~~~~~~~~~~~~~~~~~ -This file implements both a type checking algorithm and also general sanity -checking. For example, the "sanity checking" checks for TyConApp on the left -of an AppTy, which should never happen. These sanity checks don't really -affect any notion of type soundness. Yet, it is convenient to do the sanity -checks at the same time as the type checks. So, we use the following naming -convention: - -- Functions that begin with 'lint'... are involved in type checking. These - functions might also do some sanity checking. - -- Functions that begin with 'check'... are *not* involved in type checking. - They exist only for sanity checking. - -Issues surrounding variable naming, shadowing, and such are considered *not* -to be part of type checking, as the formalism omits these details. - -Summary of checks -~~~~~~~~~~~~~~~~~ -Checks that a set of core bindings is well-formed. The PprStyle and String -just control what we print in the event of an error. The Bool value -indicates whether we have done any specialisation yet (in which case we do -some extra checks). - -We check for - (a) type errors - (b) Out-of-scope type variables - (c) Out-of-scope local variables - (d) Ill-kinded types - (e) Incorrect unsafe coercions - -If we have done specialisation the we check that there are - (a) No top-level bindings of primitive (unboxed type) - -Outstanding issues: - - -- Things are *not* OK if: - -- - -- * Unsaturated type app before specialisation has been done; - -- - -- * Oversaturated type app after specialisation (eta reduction - -- may well be happening...); - - -Note [Linting function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As described in Note [Representation of function types], all saturated -applications of funTyCon are represented with the FunTy constructor. We check -this invariant in lintType. - -Note [Linting type lets] -~~~~~~~~~~~~~~~~~~~~~~~~ -In the desugarer, it's very very convenient to be able to say (in effect) - let a = Type Int in -That is, use a type let. See Note [Type let] in CoreSyn. - -However, when linting we need to remember that a=Int, else we might -reject a correct program. So we carry a type substitution (in this example -[a -> Int]) and apply this substitution before comparing types. The functin - lintInTy :: Type -> LintM (Type, Kind) -returns a substituted type. - -When we encounter a binder (like x::a) we must apply the substitution -to the type of the binding variable. lintBinders does this. - -For Ids, the type-substituted Id is added to the in_scope set (which -itself is part of the TCvSubst we are carrying down), and when we -find an occurrence of an Id, we fetch it from the in-scope set. - -Note [Bad unsafe coercion] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -For discussion see https://ghc.haskell.org/trac/ghc/wiki/BadUnsafeCoercions -Linter introduces additional rules that checks improper coercion between -different types, called bad coercions. Following coercions are forbidden: - - (a) coercions between boxed and unboxed values; - (b) coercions between unlifted values of the different sizes, here - active size is checked, i.e. size of the actual value but not - the space allocated for value; - (c) coercions between floating and integral boxed values, this check - is not yet supported for unboxed tuples, as no semantics were - specified for that; - (d) coercions from / to vector type - (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be - coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules - (a-e) holds. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -We check the rules listed in Note [Invariants on join points] in CoreSyn. The -only one that causes any difficulty is the first: All occurrences must be tail -calls. To this end, along with the in-scope set, we remember in le_joins the -subset of in-scope Ids that are valid join ids. For example: - - join j x = ... in - case e of - A -> jump j y -- good - B -> case (jump j z) of -- BAD - C -> join h = jump j w in ... -- good - D -> let x = jump j v in ... -- BAD - -A join point remains valid in case branches, so when checking the A -branch, j is still valid. When we check the scrutinee of the inner -case, however, we set le_joins to empty, and catch the -error. Similarly, join points can occur free in RHSes of other join -points but not the RHSes of value bindings (thunks and functions). - -************************************************************************ -* * - Beginning and ending passes -* * -************************************************************************ - -These functions are not CoreM monad stuff, but they probably ought to -be, and it makes a conveneint place. place for them. They print out -stuff before and after core passes, and do Core Lint when necessary. --} - -endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () -endPass pass binds rules - = do { hsc_env <- getHscEnv - ; print_unqual <- getPrintUnqualified - ; liftIO $ endPassIO hsc_env print_unqual pass binds rules } - -endPassIO :: HscEnv -> PrintUnqualified - -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () --- Used by the IO-is CorePrep too -endPassIO hsc_env print_unqual pass binds rules - = do { dumpPassResult dflags print_unqual mb_flag - (ppr pass) (pprPassDetails pass) binds rules - ; lintPassResult hsc_env pass binds } - where - dflags = hsc_dflags hsc_env - mb_flag = case coreDumpFlag pass of - Just flag | dopt flag dflags -> Just flag - | dopt Opt_D_verbose_core2core dflags -> Just flag - _ -> Nothing - -dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () -dumpIfSet dflags dump_me pass extra_info doc - = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc - -dumpPassResult :: DynFlags - -> PrintUnqualified - -> Maybe DumpFlag -- Just df => show details in a file whose - -- name is specified by df - -> SDoc -- Header - -> SDoc -- Extra info to appear after header - -> CoreProgram -> [CoreRule] - -> IO () -dumpPassResult dflags unqual mb_flag hdr extra_info binds rules - = do { forM_ mb_flag $ \flag -> - Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc - - -- Report result size - -- This has the side effect of forcing the intermediate to be evaluated - -- if it's not already forced by a -ddump flag. - ; Err.debugTraceMsg dflags 2 size_doc - } - - where - size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] - - dump_doc = vcat [ nest 2 extra_info - , size_doc - , blankLine - , pprCoreBindingsWithSize binds - , ppUnless (null rules) pp_rules ] - pp_rules = vcat [ blankLine - , text "------ Local rules for imported ids --------" - , pprRules rules ] - -coreDumpFlag :: CoreToDo -> Maybe DumpFlag -coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core -coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core -coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity -coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal -coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper -coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec -coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec -coreDumpFlag CoreCSE = Just Opt_D_dump_cse -coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect -coreDumpFlag CoreDesugar = Just Opt_D_dump_ds -coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds -coreDumpFlag CoreTidy = Just Opt_D_dump_simpl -coreDumpFlag CorePrep = Just Opt_D_dump_prep -coreDumpFlag CoreOccurAnal = Just Opt_D_dump_occur_anal - -coreDumpFlag CoreDoPrintCore = Nothing -coreDumpFlag (CoreDoRuleCheck {}) = Nothing -coreDumpFlag CoreDoNothing = Nothing -coreDumpFlag (CoreDoPasses {}) = Nothing - -{- -************************************************************************ -* * - Top-level interfaces -* * -************************************************************************ --} - -lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO () -lintPassResult hsc_env pass binds - | not (gopt Opt_DoCoreLinting dflags) - = return () - | otherwise - = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds - ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) - ; displayLintResults dflags pass warns errs binds } - where - dflags = hsc_dflags hsc_env - -displayLintResults :: DynFlags -> CoreToDo - -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram - -> IO () -displayLintResults dflags pass warns errs binds - | not (isEmptyBag errs) - = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) - (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs - , text "*** Offending Program ***" - , pprCoreBindings binds - , text "*** End of Offense ***" ]) - ; Err.ghcExit dflags 1 } - - | not (isEmptyBag warns) - , not (hasNoDebugOutput dflags) - , showLintWarnings pass - = putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) - (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns) - - | otherwise = return () - where - -lint_banner :: String -> SDoc -> SDoc -lint_banner string pass = text "*** Core Lint" <+> text string - <+> text ": in result of" <+> pass - <+> text "***" - -showLintWarnings :: CoreToDo -> Bool --- Disable Lint warnings on the first simplifier pass, because --- there may be some INLINE knots still tied, which is tiresomely noisy -showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False -showLintWarnings _ = True - -lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO () -lintInteractiveExpr what hsc_env expr - | not (gopt Opt_DoCoreLinting dflags) - = return () - | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr - = do { display_lint_err err - ; Err.ghcExit dflags 1 } - | otherwise - = return () - where - dflags = hsc_dflags hsc_env - - display_lint_err err - = do { putLogMsg dflags NoReason Err.SevDump - noSrcSpan (defaultDumpStyle dflags) - (vcat [ lint_banner "errors" (text what) - , err - , text "*** Offending Program ***" - , pprCoreExpr expr - , text "*** End of Offense ***" ]) - ; Err.ghcExit dflags 1 } - -interactiveInScope :: HscEnv -> [Var] --- In GHCi we may lint expressions, or bindings arising from 'deriving' --- clauses, that mention variables bound in the interactive context. --- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes). --- So we have to tell Lint about them, lest it reports them as out of scope. --- --- We do this by find local-named things that may appear free in interactive --- context. This function is pretty revolting and quite possibly not quite right. --- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty --- so this is a (cheap) no-op. --- --- See Trac #8215 for an example -interactiveInScope hsc_env - = tyvars ++ ids - where - -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr - ictxt = hsc_IC hsc_env - (cls_insts, _fam_insts) = ic_instances ictxt - te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) - te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts) - ids = typeEnvIds te - tyvars = tyCoVarsOfTypesList $ map idType ids - -- Why the type variables? How can the top level envt have free tyvars? - -- I think it's because of the GHCi debugger, which can bind variables - -- f :: [t] -> [t] - -- where t is a RuntimeUnk (see TcType) - -lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) --- Returns (warnings, errors) --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreBindings dflags pass local_in_scope binds - = initL dflags flags in_scope_set $ - addLoc TopLevelBindings $ - lintLetBndrs TopLevel binders $ - -- Put all the top-level binders in scope at the start - -- This is because transformation rules can bring something - -- into use 'unexpectedly' - do { checkL (null dups) (dupVars dups) - ; checkL (null ext_dups) (dupExtVars ext_dups) - ; mapM lint_bind binds } - where - in_scope_set = mkInScopeSet (mkVarSet local_in_scope) - - flags = LF { lf_check_global_ids = check_globals - , lf_check_inline_loop_breakers = check_lbs - , lf_check_static_ptrs = check_static_ptrs } - - -- See Note [Checking for global Ids] - check_globals = case pass of - CoreTidy -> False - CorePrep -> False - _ -> True - - -- See Note [Checking for INLINE loop breakers] - check_lbs = case pass of - CoreDesugar -> False - CoreDesugarOpt -> False - _ -> True - - -- See Note [Checking StaticPtrs] - check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere - | otherwise = case pass of - CoreDoFloatOutwards _ -> AllowAtTopLevel - CoreTidy -> RejectEverywhere - CorePrep -> AllowAtTopLevel - _ -> AllowAnywhere - - binders = bindersOfBinds binds - (_, dups) = removeDups compare binders - - -- dups_ext checks for names with different uniques - -- but but the same External name M.n. We don't - -- allow this at top level: - -- M.n{r3} = ... - -- M.n{r29} = ... - -- because they both get the same linker symbol - ext_dups = snd (removeDups ord_ext (map Var.varName binders)) - ord_ext n1 n2 | Just m1 <- nameModule_maybe n1 - , Just m2 <- nameModule_maybe n2 - = compare (m1, nameOccName n1) (m2, nameOccName n2) - | otherwise = LT - - -- If you edit this function, you may need to update the GHC formalism - -- See Note [GHC Formalism] - lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs - lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs) - -{- -************************************************************************ -* * -\subsection[lintUnfolding]{lintUnfolding} -* * -************************************************************************ - -We use this to check all unfoldings that come in from interfaces -(it is very painful to catch errors otherwise): --} - -lintUnfolding :: DynFlags - -> SrcLoc - -> VarSet -- Treat these as in scope - -> CoreExpr - -> Maybe MsgDoc -- Nothing => OK - -lintUnfolding dflags locn vars expr - | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) - where - in_scope = mkInScopeSet vars - (_warns, errs) = initL dflags defaultLintFlags in_scope linter - linter = addLoc (ImportedUnfolding locn) $ - lintCoreExpr expr - -lintExpr :: DynFlags - -> [Var] -- Treat these as in scope - -> CoreExpr - -> Maybe MsgDoc -- Nothing => OK - -lintExpr dflags vars expr - | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) - where - in_scope = mkInScopeSet (mkVarSet vars) - (_warns, errs) = initL dflags defaultLintFlags in_scope linter - linter = addLoc TopLevelBindings $ - lintCoreExpr expr - -{- -************************************************************************ -* * -\subsection[lintCoreBinding]{lintCoreBinding} -* * -************************************************************************ - -Check a core binding, returning the list of variables bound. --} - -lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintSingleBinding top_lvl_flag rec_flag (binder,rhs) - = addLoc (RhsOf binder) $ - -- Check the rhs - do { ty <- lintRhs binder rhs - ; binder_ty <- applySubstTy (idType binder) - ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty) - - -- Check that it's not levity-polymorphic - -- Do this first, because otherwise isUnliftedType panics - -- Annoyingly, this duplicates the test in lintIdBdr, - -- because for non-rec lets we call lintSingleBinding first - ; checkL (isJoinId binder || not (isTypeLevPoly binder_ty)) - (badBndrTyMsg binder (text "levity-polymorphic")) - - -- Check the let/app invariant - -- See Note [CoreSyn let/app invariant] in CoreSyn - ; checkL ( isJoinId binder - || not (isUnliftedType binder_ty) - || (isNonRec rec_flag && exprOkForSpeculation rhs) - || exprIsLiteralString rhs) - (badBndrTyMsg binder (text "unlifted")) - - -- Check that if the binder is top-level or recursive, it's not - -- demanded. Primitive string literals are exempt as there is no - -- computation to perform, see Note [CoreSyn top-level string literals]. - ; checkL (not (isStrictId binder) - || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)) - || exprIsLiteralString rhs) - (mkStrictMsg binder) - - -- Check that if the binder is at the top level and has type Addr#, - -- that it is a string literal, see - -- Note [CoreSyn top-level string literals]. - ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy) - || exprIsLiteralString rhs) - (mkTopNonLitStrMsg binder) - - ; flags <- getLintFlags - - -- Check that a join-point binder has a valid type - -- NB: lintIdBinder has checked that it is not top-level bound - ; case isJoinId_maybe binder of - Nothing -> return () - Just arity -> checkL (isValidJoinPointType arity binder_ty) - (mkInvalidJoinPointMsg binder binder_ty) - - ; when (lf_check_inline_loop_breakers flags - && isStrongLoopBreaker (idOccInfo binder) - && isInlinePragma (idInlinePragma binder)) - (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) - -- Only non-rule loop breakers inhibit inlining - - -- Check whether arity and demand type are consistent (only if demand analysis - -- already happened) - -- - -- Note (Apr 2014): this is actually ok. See Note [Demand analysis for trivial right-hand sides] - -- in DmdAnal. After eta-expansion in CorePrep the rhs is no longer trivial. - -- ; let dmdTy = idStrictness binder - -- ; checkL (case dmdTy of - -- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) - -- (mkArityMsg binder) - - -- Check that the binder's arity is within the bounds imposed by - -- the type and the strictness signature. See Note [exprArity invariant] - -- and Note [Trimming arity] - ; checkL (idArity binder <= length (typeArity (idType binder))) - (text "idArity" <+> ppr (idArity binder) <+> - text "exceeds typeArity" <+> - ppr (length (typeArity (idType binder))) <> colon <+> - ppr binder) - - ; case splitStrictSig (idStrictness binder) of - (demands, result_info) | isBotRes result_info -> - checkL (idArity binder <= length demands) - (text "idArity" <+> ppr (idArity binder) <+> - text "exceeds arity imposed by the strictness signature" <+> - ppr (idStrictness binder) <> colon <+> - ppr binder) - _ -> return () - - ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) - ; lintIdUnfolding binder binder_ty (idUnfolding binder) } - - -- We should check the unfolding, if any, but this is tricky because - -- the unfolding is a SimplifiableCoreExpr. Give up for now. - --- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' --- in that it doesn't reject occurrences of the function 'makeStatic' when they --- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and --- for join points, it skips the outer lambdas that take arguments to the --- join point. --- --- See Note [Checking StaticPtrs]. -lintRhs :: Id -> CoreExpr -> LintM OutType -lintRhs bndr rhs - | Just arity <- isJoinId_maybe bndr - = lint_join_lams arity arity True rhs - | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) - = lint_join_lams arity arity False rhs - where - lint_join_lams 0 _ _ rhs - = lintCoreExpr rhs - - lint_join_lams n tot enforce (Lam var expr) - = addLoc (LambdaBodyOf var) $ - lintBinder LambdaBind var $ \ var' -> - do { body_ty <- lint_join_lams (n-1) tot enforce expr - ; return $ mkLamType var' body_ty } - - lint_join_lams n tot True _other - = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) - lint_join_lams _ _ False rhs - = markAllJoinsBad $ lintCoreExpr rhs - -- Future join point, not yet eta-expanded - -- Body is not a tail position - --- Allow applications of the data constructor @StaticPtr@ at the top --- but produce errors otherwise. -lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go - where - -- Allow occurrences of 'makeStatic' at the top-level but produce errors - -- otherwise. - go AllowAtTopLevel - | (binders0, rhs') <- collectTyBinders rhs - , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' - = markAllJoinsBad $ - foldr - -- imitate @lintCoreExpr (Lam ...)@ - (\var loopBinders -> - addLoc (LambdaBodyOf var) $ - lintBinder LambdaBind var $ \var' -> - do { body_ty <- loopBinders - ; return $ mkLamType var' body_ty } - ) - -- imitate @lintCoreExpr (App ...)@ - (do fun_ty <- lintCoreExpr fun - addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e] - ) - binders0 - go _ = markAllJoinsBad $ lintCoreExpr rhs - -lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () -lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - | isStableSource src - = do { ty <- lintRhs bndr rhs - ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } - -lintIdUnfolding bndr bndr_ty (DFunUnfolding { df_con = con, df_bndrs = bndrs - , df_args = args }) - = do { ty <- lintBinders LambdaBind bndrs $ \ bndrs' -> - do { res_ty <- lintCoreArgs (dataConRepType con) args - ; return (mkLamTypes bndrs' res_ty) } - ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "dfun unfolding") ty) } - -lintIdUnfolding _ _ _ - = return () -- Do not Lint unstable unfoldings, because that leads - -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars - -{- -Note [Checking for INLINE loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very suspicious if a strong loop breaker is marked INLINE. - -However, the desugarer generates instance methods with INLINE pragmas -that form a mutually recursive group. Only after a round of -simplification are they unravelled. So we suppress the test for -the desugarer. - -************************************************************************ -* * -\subsection[lintCoreExpr]{lintCoreExpr} -* * -************************************************************************ --} - --- For OutType, OutKind, the substitution has been applied, --- but has not been linted yet - -type LintedType = Type -- Substitution applied, and type is linted -type LintedKind = Kind - -lintCoreExpr :: CoreExpr -> LintM OutType --- The returned type has the substitution from the monad --- already applied to it: --- lintCoreExpr e subst = exprType (subst e) --- --- The returned "type" can be a kind, if the expression is (Type ty) - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreExpr (Var var) - = lintVarOcc var 0 - -lintCoreExpr (Lit lit) - = return (literalType lit) - -lintCoreExpr (Cast expr co) - = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr - ; co' <- applySubstCo co - ; (_, k2, from_ty, to_ty, r) <- lintCoercion co' - ; lintL (classifiesTypeWithValues k2) - (text "Target of cast not # or *:" <+> ppr co) - ; lintRole co' Representational r - ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) - ; return to_ty } - -lintCoreExpr (Tick tickish expr) - = do case tickish of - Breakpoint _ ids -> forM_ ids $ \id -> do - checkDeadIdOcc id - lookupIdInScope id - _ -> return () - markAllJoinsBadIf block_joins $ lintCoreExpr expr - where - block_joins = not (tickish `tickishScopesLike` SoftScope) - -- TODO Consider whether this is the correct rule. It is consistent with - -- the simplifier's behaviour - cost-centre-scoped ticks become part of - -- the continuation, and thus they behave like part of an evaluation - -- context, but soft-scoped and non-scoped ticks simply wrap the result - -- (see Simplify.simplTick). - -lintCoreExpr (Let (NonRec tv (Type ty)) body) - | isTyVar tv - = -- See Note [Linting type lets] - do { ty' <- applySubstTy ty - ; lintTyBndr tv $ \ tv' -> - do { addLoc (RhsOf tv) $ lintTyKind tv' ty' - -- Now extend the substitution so we - -- take advantage of it in the body - ; extendSubstL tv ty' $ - addLoc (BodyOfLetRec [tv]) $ - lintCoreExpr body } } - -lintCoreExpr (Let (NonRec bndr rhs) body) - | isId bndr - = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) - ; addLoc (BodyOfLetRec [bndr]) - (lintIdBndr NotTopLevel LetBind bndr $ \_ -> - addGoodJoins [bndr] $ - lintCoreExpr body) } - - | otherwise - = failWithL (mkLetErr bndr rhs) -- Not quite accurate - -lintCoreExpr e@(Let (Rec pairs) body) - = lintLetBndrs NotTopLevel bndrs $ - addGoodJoins bndrs $ - do { -- Check that the list of pairs is non-empty - checkL (not (null pairs)) (emptyRec e) - - -- Check that there are no duplicated binders - ; checkL (null dups) (dupVars dups) - - -- Check that either all the binders are joins, or none - ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ - mkInconsistentRecMsg bndrs - - ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs - ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } - where - bndrs = map fst pairs - (_, dups) = removeDups compare bndrs - -lintCoreExpr e@(App _ _) - = addLoc (AnExpr e) $ - do { fun_ty <- lintCoreFun fun (length args) - ; lintCoreArgs fun_ty args } - where - (fun, args) = collectArgs e - -lintCoreExpr (Lam var expr) - = addLoc (LambdaBodyOf var) $ - markAllJoinsBad $ - lintBinder LambdaBind var $ \ var' -> - do { body_ty <- lintCoreExpr expr - ; return $ mkLamType var' body_ty } - -lintCoreExpr e@(Case scrut var alt_ty alts) = - -- Check the scrutinee - do { let scrut_diverges = exprIsBottom scrut - ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut - ; (alt_ty, _) <- lintInTy alt_ty - ; (var_ty, _) <- lintInTy (idType var) - - -- See Note [No alternatives lint check] - ; when (null alts) $ - do { checkL (not (exprIsHNF scrut)) - (text "No alternatives for a case scrutinee in head-normal form:" <+> ppr scrut) - ; checkWarnL scrut_diverges - (text "No alternatives for a case scrutinee not known to diverge for sure:" <+> ppr scrut) - } - - -- See Note [Rules for floating-point comparisons] in PrelRules - ; let isLitPat (LitAlt _, _ , _) = True - isLitPat _ = False - ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts) - (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++ - "expression with literal pattern in case " ++ - "analysis (see Trac #9238).") - $$ text "scrut" <+> ppr scrut) - - ; case tyConAppTyCon_maybe (idType var) of - Just tycon - | debugIsOn - , isAlgTyCon tycon - , not (isAbstractTyCon tycon) - , null (tyConDataCons tycon) - , not scrut_diverges - -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) - -- This can legitimately happen for type families - $ return () - _otherwise -> return () - - -- Don't use lintIdBndr on var, because unboxed tuple is legitimate - - ; subst <- getTCvSubst - ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) - - ; lintIdBndr NotTopLevel CaseBind var $ \_ -> - do { -- Check the alternatives - mapM_ (lintCoreAlt scrut_ty alt_ty) alts - ; checkCaseAlts e scrut_ty alts - ; return alt_ty } } - --- This case can't happen; linting types in expressions gets routed through --- lintCoreArgs -lintCoreExpr (Type ty) - = failWithL (text "Type found as expression" <+> ppr ty) - -lintCoreExpr (Coercion co) - = do { (k1, k2, ty1, ty2, role) <- lintInCo co - ; return (mkHeteroCoercionType role k1 k2 ty1 ty2) } - ----------------------- -lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed - -> LintM Type -- returns type of the *variable* -lintVarOcc var nargs - = do { checkL (isNonCoVarId var) - (text "Non term variable" <+> ppr var) - - -- Cneck that the type of the occurrence is the same - -- as the type of the binding site - ; ty <- applySubstTy (idType var) - ; var' <- lookupIdInScope var - ; let ty' = idType var' - ; ensureEqTys ty ty' $ mkBndrOccTypeMismatchMsg var' var ty' ty - - -- Check for a nested occurrence of the StaticPtr constructor. - -- See Note [Checking StaticPtrs]. - ; lf <- getLintFlags - ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ - checkL (idName var /= makeStaticName) $ - text "Found makeStatic nested in an expression" - - ; checkDeadIdOcc var - ; checkJoinOcc var nargs - - ; return (idType var') } - -lintCoreFun :: CoreExpr - -> Int -- Number of arguments (type or val) being passed - -> LintM Type -- Returns type of the *function* -lintCoreFun (Var var) nargs - = lintVarOcc var nargs - -lintCoreFun (Lam var body) nargs - -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see - -- Note [Beta redexes] - | nargs /= 0 - = addLoc (LambdaBodyOf var) $ - lintBinder LambdaBind var $ \ var' -> - do { body_ty <- lintCoreFun body (nargs - 1) - ; return $ mkLamType var' body_ty } - -lintCoreFun expr nargs - = markAllJoinsBadIf (nargs /= 0) $ - lintCoreExpr expr - ------------------- -checkDeadIdOcc :: Id -> LintM () --- Occurrences of an Id should never be dead.... --- except when we are checking a case pattern -checkDeadIdOcc id - | isDeadOcc (idOccInfo id) - = do { in_case <- inCasePat - ; checkL in_case - (text "Occurrence of a dead Id" <+> ppr id) } - | otherwise - = return () - ------------------- -checkJoinOcc :: Id -> JoinArity -> LintM () --- Check that if the occurrence is a JoinId, then so is the --- binding site, and it's a valid join Id -checkJoinOcc var n_args - | Just join_arity_occ <- isJoinId_maybe var - = do { mb_join_arity_bndr <- lookupJoinId var - ; case mb_join_arity_bndr of { - Nothing -> -- Binder is not a join point - addErrL (invalidJoinOcc var) ; - - Just join_arity_bndr -> - - do { checkL (join_arity_bndr == join_arity_occ) $ - -- Arity differs at binding site and occurrence - mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ - - ; checkL (n_args == join_arity_occ) $ - -- Arity doesn't match #args - mkBadJumpMsg var join_arity_occ n_args } } } - - | otherwise - = return () - -{- -Note [No alternatives lint check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Case expressions with no alternatives are odd beasts, and worth looking at -in the linter (cf Trac #10180). We check two things: - -* exprIsHNF is false: certainly, it would be terribly wrong if the - scrutinee was already in head normal form. - -* exprIsBottom is true: we should be able to see why GHC believes the - scrutinee is diverging for sure. - -In principle, the first check is redundant: exprIsBottom == True will -always imply exprIsHNF == False. But the first check is reliable: If -exprIsHNF == True, then there definitely is a problem (exprIsHNF errs -on the right side). If the second check triggers then it may be the -case that the compiler got smarter elsewhere, and the empty case is -correct, but that exprIsBottom is unable to see it. In particular, the -empty-type check in exprIsBottom is an approximation. Therefore, this -check is not fully reliable, and we keep both around. - -Note [Beta redexes] -~~~~~~~~~~~~~~~~~~~ -Consider: - - join j @x y z = ... in - (\@x y z -> jump j @x y z) @t e1 e2 - -This is clearly ill-typed, since the jump is inside both an application and a -lambda, either of which is enough to disqualify it as a tail call (see Note -[Invariants on join points] in CoreSyn). However, strictly from a -lambda-calculus perspective, the term doesn't go wrong---after the two beta -reductions, the jump *is* a tail call and everything is fine. - -Why would we want to allow this when we have let? One reason is that a compound -beta redex (that is, one with more than one argument) has different scoping -rules: naively reducing the above example using lets will capture any free -occurrence of y in e2. More fundamentally, type lets are tricky; many passes, -such as Float Out, tacitly assume that the incoming program's type lets have -all been dealt with by the simplifier. Thus we don't want to let-bind any types -in, say, CoreSubst.simpleOptPgm, which in some circumstances can run immediately -before Float Out. - -All that said, currently CoreSubst.simpleOptPgm is the only thing using this -loophole, doing so to avoid re-traversing large functions (beta-reducing a type -lambda without introducing a type let requires a substitution). TODO: Improve -simpleOptPgm so that we can forget all this ever happened. - -************************************************************************ -* * -\subsection[lintCoreArgs]{lintCoreArgs} -* * -************************************************************************ - -The basic version of these functions checks that the argument is a -subtype of the required type, as one would expect. --} - - -lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType -lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args - -lintCoreArg :: OutType -> CoreArg -> LintM OutType -lintCoreArg fun_ty (Type arg_ty) - = do { checkL (not (isCoercionTy arg_ty)) - (text "Unnecessary coercion-to-type injection:" - <+> ppr arg_ty) - ; arg_ty' <- applySubstTy arg_ty - ; lintTyApp fun_ty arg_ty' } - -lintCoreArg fun_ty arg - = do { arg_ty <- markAllJoinsBad $ lintCoreExpr arg - -- See Note [Levity polymorphism invariants] in CoreSyn - ; lintL (not (isTypeLevPoly arg_ty)) - (text "Levity-polymorphic argument:" <+> - (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty)))) - -- check for levity polymorphism first, because otherwise isUnliftedType panics - - ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg) - (mkLetAppMsg arg) - ; lintValApp arg fun_ty arg_ty } - ------------------ -lintAltBinders :: OutType -- Scrutinee type - -> OutType -- Constructor type - -> [OutVar] -- Binders - -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintAltBinders scrut_ty con_ty [] - = ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) -lintAltBinders scrut_ty con_ty (bndr:bndrs) - | isTyVar bndr - = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) - ; lintAltBinders scrut_ty con_ty' bndrs } - | otherwise - = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr) - ; lintAltBinders scrut_ty con_ty' bndrs } - ------------------ -lintTyApp :: OutType -> OutType -> LintM OutType -lintTyApp fun_ty arg_ty - | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty - = do { lintTyKind tv arg_ty - ; in_scope <- getInScope - -- substTy needs the set of tyvars in scope to avoid generating - -- uniques that are already in scope. - -- See Note [The substitution invariant] in TyCoRep - ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } - - | otherwise - = failWithL (mkTyAppMsg fun_ty arg_ty) - ------------------ -lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType -lintValApp arg fun_ty arg_ty - | Just (arg,res) <- splitFunTy_maybe fun_ty - = do { ensureEqTys arg arg_ty err1 - ; return res } - | otherwise - = failWithL err2 - where - err1 = mkAppMsg fun_ty arg_ty arg - err2 = mkNonFunAppMsg fun_ty arg_ty arg - -lintTyKind :: OutTyVar -> OutType -> LintM () --- Both args have had substitution applied - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintTyKind tyvar arg_ty - -- Arg type might be boxed for a function with an uncommitted - -- tyvar; notably this is used so that we can give - -- error :: forall a:*. String -> a - -- and then apply it to both boxed and unboxed types. - = do { arg_kind <- lintType arg_ty - ; unless (arg_kind `eqType` tyvar_kind) - (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))) } - where - tyvar_kind = tyVarKind tyvar - -{- -************************************************************************ -* * -\subsection[lintCoreAlts]{lintCoreAlts} -* * -************************************************************************ --} - -checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () --- a) Check that the alts are non-empty --- b1) Check that the DEFAULT comes first, if it exists --- b2) Check that the others are in increasing order --- c) Check that there's a default for infinite types --- NB: Algebraic cases are not necessarily exhaustive, because --- the simplifier correctly eliminates case that can't --- possibly match. - -checkCaseAlts e ty alts = - do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) - ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) - - -- For types Int#, Word# with an infinite (well, large!) number of - -- possible values, there should usually be a DEFAULT case - -- But (see Note [Empty case alternatives] in CoreSyn) it's ok to - -- have *no* case alternatives. - -- In effect, this is a kind of partial test. I suppose it's possible - -- that we might *know* that 'x' was 1 or 2, in which case - -- case x of { 1 -> e1; 2 -> e2 } - -- would be fine. - ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) - (nonExhaustiveAltsMsg e) } - where - (con_alts, maybe_deflt) = findDefault alts - - -- Check that successive alternatives have increasing tags - increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest - increasing_tag _ = True - - non_deflt (DEFAULT, _, _) = False - non_deflt _ = True - - is_infinite_ty = case tyConAppTyCon_maybe ty of - Nothing -> False - Just tycon -> isPrimTyCon tycon - -lintAltExpr :: CoreExpr -> OutType -> LintM () -lintAltExpr expr ann_ty - = do { actual_ty <- lintCoreExpr expr - ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) } - -lintCoreAlt :: OutType -- Type of scrutinee - -> OutType -- Type of the alternative - -> CoreAlt - -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreAlt _ alt_ty (DEFAULT, args, rhs) = - do { lintL (null args) (mkDefaultArgsMsg args) - ; lintAltExpr rhs alt_ty } - -lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) - | litIsLifted lit - = failWithL integerScrutinisedMsg - | otherwise - = do { lintL (null args) (mkDefaultArgsMsg args) - ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) - ; lintAltExpr rhs alt_ty } - where - lit_ty = literalType lit - -lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) - | isNewTyCon (dataConTyCon con) - = addErrL (mkNewTyDataConAltMsg scrut_ty alt) - | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty - = addLoc (CaseAlt alt) $ do - { -- First instantiate the universally quantified - -- type variables of the data constructor - -- We've already check - lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) - ; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys - - -- And now bring the new binders into scope - ; lintBinders CasePatBind args $ \ args' -> do - { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args') - ; lintAltExpr rhs alt_ty } } - - | otherwise -- Scrut-ty is wrong shape - = addErrL (mkBadAltMsg scrut_ty alt) - -{- -************************************************************************ -* * -\subsection[lint-types]{Types} -* * -************************************************************************ --} - --- When we lint binders, we (one at a time and in order): --- 1. Lint var types or kinds (possibly substituting) --- 2. Add the binder to the in scope set, and if its a coercion var, --- we may extend the substitution to reflect its (possibly) new kind -lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a -lintBinders _ [] linterF = linterF [] -lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> - lintBinders site vars $ \ vars' -> - linterF (var':vars') - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a -lintBinder site var linterF - | isTyVar var = lintTyBndr var linterF - | isCoVar var = lintCoBndr var linterF - | otherwise = lintIdBndr NotTopLevel site var linterF - -lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a -lintTyBndr tv thing_inside - = do { subst <- getTCvSubst - ; let (subst', tv') = substTyVarBndr subst tv - ; lintKind (varType tv') - ; updateTCvSubst subst' (thing_inside tv') } - -lintCoBndr :: InCoVar -> (OutCoVar -> LintM a) -> LintM a -lintCoBndr cv thing_inside - = do { subst <- getTCvSubst - ; let (subst', cv') = substCoVarBndr subst cv - ; lintKind (varType cv') - ; lintL (isCoercionType (varType cv')) - (text "CoVar with non-coercion type:" <+> pprTyVar cv) - ; updateTCvSubst subst' (thing_inside cv') } - -lintLetBndrs :: TopLevelFlag -> [Var] -> LintM a -> LintM a -lintLetBndrs top_lvl ids linterF - = go ids - where - go [] = linterF - go (id:ids) = lintIdBndr top_lvl LetBind id $ \_ -> - go ids - -lintIdBndr :: TopLevelFlag -> BindingSite - -> InVar -> (OutVar -> LintM a) -> LintM a --- Do substitution on the type of a binder and add the var with this --- new type to the in-scope set of the second argument --- ToDo: lint its rules -lintIdBndr top_lvl bind_site id linterF - = ASSERT2( isId id, ppr id ) - do { flags <- getLintFlags - ; checkL (not (lf_check_global_ids flags) || isLocalId id) - (text "Non-local Id binder" <+> ppr id) - -- See Note [Checking for global Ids] - - -- Check that if the binder is nested, it is not marked as exported - ; checkL (not (isExportedId id) || is_top_lvl) - (mkNonTopExportedMsg id) - - -- Check that if the binder is nested, it does not have an external name - ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl) - (mkNonTopExternalNameMsg id) - - ; (ty, k) <- lintInTy (idType id) - -- See Note [Levity polymorphism invariants] in CoreSyn - ; lintL (isJoinId id || not (isKindLevPoly k)) - (text "Levity-polymorphic binder:" <+> - (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k))) - - -- Check that a join-id is a not-top-level let-binding - ; when (isJoinId id) $ - checkL (not is_top_lvl && is_let_bind) $ - mkBadJoinBindMsg id - - ; let id' = setIdType id ty - ; addInScopeVar id' $ (linterF id') } - where - is_top_lvl = isTopLevel top_lvl - is_let_bind = case bind_site of - LetBind -> True - _ -> False - -{- -%************************************************************************ -%* * - Types -%* * -%************************************************************************ --} - -lintInTy :: InType -> LintM (LintedType, LintedKind) --- Types only, not kinds --- Check the type, and apply the substitution to it --- See Note [Linting type lets] -lintInTy ty - = addLoc (InType ty) $ - do { ty' <- applySubstTy ty - ; k <- lintType ty' - ; lintKind k - ; return (ty', k) } - -checkTyCon :: TyCon -> LintM () -checkTyCon tc - = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) - -------------------- -lintType :: OutType -> LintM LintedKind --- The returned Kind has itself been linted - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintType (TyVarTy tv) - = do { checkL (isTyVar tv) (mkBadTyVarMsg tv) - ; lintTyCoVarInScope tv - ; return (tyVarKind tv) } - -- We checked its kind when we added it to the envt - -lintType ty@(AppTy t1 t2) - | TyConApp {} <- t1 - = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty - | otherwise - = do { k1 <- lintType t1 - ; k2 <- lintType t2 - ; lint_ty_app ty k1 [(t2,k2)] } - -lintType ty@(TyConApp tc tys) - | Just ty' <- coreView ty - = lintType ty' -- Expand type synonyms, so that we do not bogusly complain - -- about un-saturated type synonyms - - -- We should never see a saturated application of funTyCon; such applications - -- should be represented with the FunTy constructor. See Note [Linting - -- function types] and Note [Representation of function types]. - | isFunTyCon tc - , length tys == 4 - = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty)) - - | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - -- Also type synonyms and type families - , length tys < tyConArity tc - = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) - - | otherwise - = do { checkTyCon tc - ; ks <- mapM lintType tys - ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } - --- arrows can related *unlifted* kinds, so this has to be separate from --- a dependent forall. -lintType ty@(FunTy t1 t2) - = do { k1 <- lintType t1 - ; k2 <- lintType t2 - ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 } - -lintType t@(ForAllTy (TvBndr tv _vis) ty) - = do { lintL (isTyVar tv) (text "Covar bound in type:" <+> ppr t) - ; lintTyBndr tv $ \tv' -> - do { k <- lintType ty - ; lintL (not (tv' `elemVarSet` tyCoVarsOfType k)) - (text "Variable escape in forall:" <+> ppr t) - ; lintL (classifiesTypeWithValues k) - (text "Non-* and non-# kind in forall:" <+> ppr t) - ; return k }} - -lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) - -lintType (CastTy ty co) - = do { k1 <- lintType ty - ; (k1', k2) <- lintStarCoercion co - ; ensureEqTys k1 k1' (mkCastErr ty co k1' k1) - ; return k2 } - -lintType (CoercionTy co) - = do { (k1, k2, ty1, ty2, r) <- lintCoercion co - ; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 } - -lintKind :: OutKind -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintKind k = do { sk <- lintType k - ; unless (classifiesTypeWithValues sk) - (addErrL (hang (text "Ill-kinded kind:" <+> ppr k) - 2 (text "has kind:" <+> ppr sk))) } - --- confirms that a type is really * -lintStar :: SDoc -> OutKind -> LintM () -lintStar doc k - = lintL (classifiesTypeWithValues k) - (text "Non-*-like kind when *-like expected:" <+> ppr k $$ - text "when checking" <+> doc) - -lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2 - -- or lintarrow "coercion `blah'" k1 k2 - = do { unless (okArrowArgKind k1) (addErrL (msg (text "argument") k1)) - ; unless (okArrowResultKind k2) (addErrL (msg (text "result") k2)) - ; return liftedTypeKind } - where - msg ar k - = vcat [ hang (text "Ill-kinded" <+> ar) - 2 (text "in" <+> what) - , what <+> text "kind:" <+> ppr k ] - -lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind -lint_ty_app ty k tys - = lint_app (text "type" <+> quotes (ppr ty)) k tys - ----------------- -lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind -lint_co_app ty k tys - = lint_app (text "coercion" <+> quotes (ppr ty)) k tys - ----------------- -lintTyLit :: TyLit -> LintM () -lintTyLit (NumTyLit n) - | n >= 0 = return () - | otherwise = failWithL msg - where msg = text "Negative type literal:" <+> integer n -lintTyLit (StrTyLit _) = return () - -lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind --- (lint_app d fun_kind arg_tys) --- We have an application (f arg_ty1 .. arg_tyn), --- where f :: fun_kind --- Takes care of linting the OutTypes - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lint_app doc kfn kas - = do { in_scope <- getInScope - -- We need the in_scope set to satisfy the invariant in - -- Note [The substitution invariant] in TyCoRep - ; foldlM (go_app in_scope) kfn kas } - where - fail_msg = vcat [ hang (text "Kind application error in") 2 doc - , nest 2 (text "Function kind =" <+> ppr kfn) - , nest 2 (text "Arg kinds =" <+> ppr kas) ] - - go_app in_scope kfn ka - | Just kfn' <- coreView kfn - = go_app in_scope kfn' ka - - go_app _ (FunTy kfa kfb) (_,ka) - = do { unless (ka `eqType` kfa) (addErrL fail_msg) - ; return kfb } - - go_app in_scope (ForAllTy (TvBndr kv _vis) kfn) (ta,ka) - = do { unless (ka `eqType` tyVarKind kv) (addErrL fail_msg) - ; return (substTyWithInScope in_scope [kv] [ta] kfn) } - - go_app _ _ _ = failWithL fail_msg - -{- ********************************************************************* -* * - Linting rules -* * -********************************************************************* -} - -lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM () -lintCoreRule _ _ (BuiltinRule {}) - = return () -- Don't bother - -lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs - , ru_args = args, ru_rhs = rhs }) - = lintBinders LambdaBind bndrs $ \ _ -> - do { lhs_ty <- foldM lintCoreArg fun_ty args - ; rhs_ty <- case isJoinId_maybe fun of - Just join_arity - -> do { checkL (args `lengthIs` join_arity) $ - mkBadJoinPointRuleMsg fun join_arity rule - -- See Note [Rules for join points] - ; lintCoreExpr rhs } - _ -> markAllJoinsBad $ lintCoreExpr rhs - ; ensureEqTys lhs_ty rhs_ty $ - (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty - , text "rhs type:" <+> ppr rhs_ty ]) - ; let bad_bndrs = filterOut (`elemVarSet` exprsFreeVars args) $ - filter (`elemVarSet` exprFreeVars rhs) $ - bndrs - - ; checkL (null bad_bndrs) - (rule_doc <+> text "unbound" <+> ppr bad_bndrs) - -- See Note [Linting rules] - } - where - rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon - -{- Note [Linting rules] -~~~~~~~~~~~~~~~~~~~~~~~ -It's very bad if simplifying a rule means that one of the template -variables (ru_bndrs) that /is/ mentioned on the RHS becomes -not-mentioned in the LHS (ru_args). How can that happen? Well, in -Trac #10602, SpecConstr stupidly constructed a rule like - - forall x,c1,c2. - f (x |> c1 |> c2) = .... - -But simplExpr collapses those coercions into one. (Indeed in -Trac #10602, it collapsed to the identity and was removed altogether.) - -We don't have a great story for what to do here, but at least -this check will nail it. - -NB (Trac #11643): it's possible that a variable listed in the -binders becomes not-mentioned on both LHS and RHS. Here's a silly -example: - RULE forall x y. f (g x y) = g (x+1 (y-1) -And suppose worker/wrapper decides that 'x' is Absent. Then -we'll end up with - RULE forall x y. f ($gw y) = $gw (x+1) -This seems sufficiently obscure that there isn't enough payoff to -try to trim the forall'd binder list. - -Note [Rules for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A join point cannot be partially applied. However, the left-hand side of a rule -for a join point is effectively a *pattern*, not a piece of code, so there's an -argument to be made for allowing a situation like this: - - join $sj :: Int -> Int -> String - $sj n m = ... - j :: forall a. Eq a => a -> a -> String - {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-} - j @a $dEq x y = ... - -Applying this rule can't turn a well-typed program into an ill-typed one, so -conceivably we could allow it. But we can always eta-expand such an -"undersaturated" rule (see 'CoreArity.etaExpandToJoinPointRule'), and in fact -the simplifier would have to in order to deal with the RHS. So we take a -conservative view and don't allow undersaturated rules for join points. See -Note [Rules and join points] in OccurAnal for further discussion. --} - -{- -************************************************************************ -* * - Linting coercions -* * -************************************************************************ --} - -lintInCo :: InCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role) --- Check the coercion, and apply the substitution to it --- See Note [Linting type lets] -lintInCo co - = addLoc (InCo co) $ - do { co' <- applySubstCo co - ; lintCoercion co' } - --- lints a coercion, confirming that its lh kind and its rh kind are both * --- also ensures that the role is Nominal -lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType) -lintStarCoercion g - = do { (k1, k2, t1, t2, r) <- lintCoercion g - ; lintStar (text "the kind of the left type in" <+> ppr g) k1 - ; lintStar (text "the kind of the right type in" <+> ppr g) k2 - ; lintRole g Nominal r - ; return (t1, t2) } - -lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role) --- Check the kind of a coercion term, returning the kind --- Post-condition: the returned OutTypes are lint-free --- --- If lintCoercion co = (k1, k2, s1, s2, r) --- then co :: s1 ~r s2 --- s1 :: k2 --- s2 :: k2 - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoercion (Refl r ty) - = do { k <- lintType ty - ; return (k, k, ty, ty, r) } - -lintCoercion co@(TyConAppCo r tc cos) - | tc `hasKey` funTyConKey - , [_rep1,_rep2,_co1,_co2] <- cos - = do { failWithL (text "Saturated TyConAppCo (->):" <+> ppr co) - } -- All saturated TyConAppCos should be FunCos - - | Just {} <- synTyConDefn_maybe tc - = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) - - | otherwise - = do { checkTyCon tc - ; (k's, ks, ss, ts, rs) <- mapAndUnzip5M lintCoercion cos - ; k' <- lint_co_app co (tyConKind tc) (ss `zip` k's) - ; k <- lint_co_app co (tyConKind tc) (ts `zip` ks) - ; _ <- zipWith3M lintRole cos (tyConRolesX r tc) rs - ; return (k', k, mkTyConApp tc ss, mkTyConApp tc ts, r) } - -lintCoercion co@(AppCo co1 co2) - | TyConAppCo {} <- co1 - = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) - | Refl _ (TyConApp {}) <- co1 - = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) - | otherwise - = do { (k1, k2, s1, s2, r1) <- lintCoercion co1 - ; (k'1, k'2, t1, t2, r2) <- lintCoercion co2 - ; k3 <- lint_co_app co k1 [(t1,k'1)] - ; k4 <- lint_co_app co k2 [(t2,k'2)] - ; if r1 == Phantom - then lintL (r2 == Phantom || r2 == Nominal) - (text "Second argument in AppCo cannot be R:" $$ - ppr co) - else lintRole co Nominal r2 - ; return (k3, k4, mkAppTy s1 t1, mkAppTy s2 t2, r1) } - ----------- -lintCoercion (ForAllCo tv1 kind_co co) - = do { (_, k2) <- lintStarCoercion kind_co - ; let tv2 = setTyVarKind tv1 k2 - ; addInScopeVar tv1 $ - do { - ; (k3, k4, t1, t2, r) <- lintCoercion co - ; in_scope <- getInScope - ; let tyl = mkInvForAllTy tv1 t1 - subst = mkTvSubst in_scope $ - -- We need both the free vars of the `t2` and the - -- free vars of the range of the substitution in - -- scope. All the free vars of `t2` and `kind_co` should - -- already be in `in_scope`, because they've been - -- linted and `tv2` has the same unique as `tv1`. - -- See Note [The substitution invariant] - unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co) - tyr = mkInvForAllTy tv2 $ - substTy subst t2 - ; return (k3, k4, tyl, tyr, r) } } - -lintCoercion co@(FunCo r co1 co2) - = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1 - ; (k2,k'2,s2,t2,r2) <- lintCoercion co2 - ; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2 - ; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2 - ; lintRole co1 r r1 - ; lintRole co2 r r2 - ; return (k, k', mkFunTy s1 s2, mkFunTy t1 t2, r) } - -lintCoercion (CoVarCo cv) - | not (isCoVar cv) - = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) - 2 (text "With offending type:" <+> ppr (varType cv))) - | otherwise - = do { lintTyCoVarInScope cv - ; cv' <- lookupIdInScope cv - ; lintUnliftedCoVar cv - ; return $ coVarKindsTypesRole cv' } - --- See Note [Bad unsafe coercion] -lintCoercion co@(UnivCo prov r ty1 ty2) - = do { k1 <- lintType ty1 - ; k2 <- lintType ty2 - ; case prov of - UnsafeCoerceProv -> return () -- no extra checks - - PhantomProv kco -> do { lintRole co Phantom r - ; check_kinds kco k1 k2 } - - ProofIrrelProv kco -> do { lintL (isCoercionTy ty1) $ - mkBadProofIrrelMsg ty1 co - ; lintL (isCoercionTy ty2) $ - mkBadProofIrrelMsg ty2 co - ; check_kinds kco k1 k2 } - - PluginProv _ -> return () -- no extra checks - HoleProv h -> addErrL $ - text "Unfilled coercion hole:" <+> ppr h - - ; when (r /= Phantom && classifiesTypeWithValues k1 - && classifiesTypeWithValues k2) - (checkTypes ty1 ty2) - ; return (k1, k2, ty1, ty2, r) } - where - report s = hang (text $ "Unsafe coercion between " ++ s) - 2 (vcat [ text "From:" <+> ppr ty1 - , text " To:" <+> ppr ty2]) - isUnBoxed :: PrimRep -> Bool - isUnBoxed = not . isGcPtrRep - - -- see #9122 for discussion of these checks - checkTypes t1 t2 - = do { checkWarnL (reps1 `equalLength` reps2) - (report "values with different # of reps") - ; zipWithM_ validateCoercion reps1 reps2 } - where - reps1 = typePrimRep t1 - reps2 = typePrimRep t2 - - validateCoercion :: PrimRep -> PrimRep -> LintM () - validateCoercion rep1 rep2 - = do { dflags <- getDynFlags - ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) - (report "unboxed and boxed value") - ; checkWarnL (TyCon.primRepSizeW dflags rep1 - == TyCon.primRepSizeW dflags rep2) - (report "unboxed values of different size") - ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) - (TyCon.primRepIsFloat rep2) - ; case fl of - Nothing -> addWarnL (report "vector types") - Just False -> addWarnL (report "float and integral values") - _ -> return () - } - - check_kinds kco k1 k2 = do { (k1', k2') <- lintStarCoercion kco - ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co) - ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) } - - -lintCoercion (SymCo co) - = do { (k1, k2, ty1, ty2, r) <- lintCoercion co - ; return (k2, k1, ty2, ty1, r) } - -lintCoercion co@(TransCo co1 co2) - = do { (k1a, _k1b, ty1a, ty1b, r1) <- lintCoercion co1 - ; (_k2a, k2b, ty2a, ty2b, r2) <- lintCoercion co2 - ; ensureEqTys ty1b ty2a - (hang (text "Trans coercion mis-match:" <+> ppr co) - 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) - ; lintRole co r1 r2 - ; return (k1a, k2b, ty1a, ty2b, r1) } - -lintCoercion the_co@(NthCo n co) - = do { (_, _, s, t, r) <- lintCoercion co - ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of - { (Just (tv_s, _ty_s), Just (tv_t, _ty_t)) - | n == 0 - -> return (ks, kt, ts, tt, Nominal) - where - ts = tyVarKind tv_s - tt = tyVarKind tv_t - ks = typeKind ts - kt = typeKind tt - - ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of - { (Just (tc_s, tys_s), Just (tc_t, tys_t)) - | tc_s == tc_t - , isInjectiveTyCon tc_s r - -- see Note [NthCo and newtypes] in TyCoRep - , tys_s `equalLength` tys_t - , n < length tys_s - -> return (ks, kt, ts, tt, tr) - where - ts = getNth tys_s n - tt = getNth tys_t n - tr = nthRole r tc_s n - ks = typeKind ts - kt = typeKind tt - - ; _ -> failWithL (hang (text "Bad getNth:") - 2 (ppr the_co $$ ppr s $$ ppr t)) }}} - -lintCoercion the_co@(LRCo lr co) - = do { (_,_,s,t,r) <- lintCoercion co - ; lintRole co Nominal r - ; case (splitAppTy_maybe s, splitAppTy_maybe t) of - (Just s_pr, Just t_pr) - -> return (ks_pick, kt_pick, s_pick, t_pick, Nominal) - where - s_pick = pickLR lr s_pr - t_pick = pickLR lr t_pr - ks_pick = typeKind s_pick - kt_pick = typeKind t_pick - - _ -> failWithL (hang (text "Bad LRCo:") - 2 (ppr the_co $$ ppr s $$ ppr t)) } - -lintCoercion (InstCo co arg) - = do { (k3, k4, t1',t2', r) <- lintCoercion co - ; (k1',k2',s1,s2, r') <- lintCoercion arg - ; lintRole arg Nominal r' - ; in_scope <- getInScope - ; case (splitForAllTy_maybe t1', splitForAllTy_maybe t2') of - (Just (tv1,t1), Just (tv2,t2)) - | k1' `eqType` tyVarKind tv1 - , k2' `eqType` tyVarKind tv2 - -> return (k3, k4, - substTyWithInScope in_scope [tv1] [s1] t1, - substTyWithInScope in_scope [tv2] [s2] t2, r) - | otherwise - -> failWithL (text "Kind mis-match in inst coercion") - _ -> failWithL (text "Bad argument of inst") } - -lintCoercion co@(AxiomInstCo con ind cos) - = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) - (bad_ax (text "index out of range")) - ; let CoAxBranch { cab_tvs = ktvs - , cab_cvs = cvs - , cab_roles = roles - , cab_lhs = lhs - , cab_rhs = rhs } = coAxiomNthBranch con ind - ; unless (length ktvs + length cvs == length cos) $ - bad_ax (text "lengths") - ; subst <- getTCvSubst - ; let empty_subst = zapTCvSubst subst - ; (subst_l, subst_r) <- foldlM check_ki - (empty_subst, empty_subst) - (zip3 (ktvs ++ cvs) roles cos) - ; let lhs' = substTys subst_l lhs - rhs' = substTy subst_r rhs - ; case checkAxInstCo co of - Just bad_branch -> bad_ax $ text "inconsistent with" <+> - pprCoAxBranch con bad_branch - Nothing -> return () - ; let s2 = mkTyConApp (coAxiomTyCon con) lhs' - ; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) } - where - bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what) - 2 (ppr co)) - - check_ki (subst_l, subst_r) (ktv, role, arg) - = do { (k', k'', s', t', r) <- lintCoercion arg - ; lintRole arg role r - ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) - ktv_kind_r = substTy subst_r (tyVarKind ktv) - ; unless (k' `eqType` ktv_kind_l) - (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr k', ppr ktv, ppr ktv_kind_l ] )) - ; unless (k'' `eqType` ktv_kind_r) - (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr k'', ppr ktv, ppr ktv_kind_r ] )) - ; return (extendTCvSubst subst_l ktv s', - extendTCvSubst subst_r ktv t') } - -lintCoercion (CoherenceCo co1 co2) - = do { (_, k2, t1, t2, r) <- lintCoercion co1 - ; let lhsty = mkCastTy t1 co2 - ; k1' <- lintType lhsty - ; return (k1', k2, lhsty, t2, r) } - -lintCoercion (KindCo co) - = do { (k1, k2, _, _, _) <- lintCoercion co - ; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) } - -lintCoercion (SubCo co') - = do { (k1,k2,s,t,r) <- lintCoercion co' - ; lintRole co' Nominal r - ; return (k1,k2,s,t,Representational) } - -lintCoercion this@(AxiomRuleCo co cs) - = do { eqs <- mapM lintCoercion cs - ; lintRoles 0 (coaxrAsmpRoles co) eqs - ; case coaxrProves co [ Pair l r | (_,_,l,r,_) <- eqs ] of - Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] - Just (Pair l r) -> - return (typeKind l, typeKind r, l, r, coaxrRole co) } - where - err m xs = failWithL $ - hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName co) : xs) - - lintRoles n (e : es) ((_,_,_,_,r) : rs) - | e == r = lintRoles (n+1) es rs - | otherwise = err "Argument roles mismatch" - [ text "In argument:" <+> int (n+1) - , text "Expected:" <+> ppr e - , text "Found:" <+> ppr r ] - lintRoles _ [] [] = return () - lintRoles n [] rs = err "Too many coercion arguments" - [ text "Expected:" <+> int n - , text "Provided:" <+> int (n + length rs) ] - - lintRoles n es [] = err "Not enough coercion arguments" - [ text "Expected:" <+> int (n + length es) - , text "Provided:" <+> int n ] - ----------- -lintUnliftedCoVar :: CoVar -> LintM () -lintUnliftedCoVar cv - = when (not (isUnliftedType (coVarKind cv))) $ - failWithL (text "Bad lifted equality:" <+> ppr cv - <+> dcolon <+> ppr (coVarKind cv)) - -{- -************************************************************************ -* * -\subsection[lint-monad]{The Lint monad} -* * -************************************************************************ --} - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] -data LintEnv - = LE { le_flags :: LintFlags -- Linting the result of this pass - , le_loc :: [LintLocInfo] -- Locations - , le_subst :: TCvSubst -- Current type substitution; we also use this - -- to keep track of all the variables in scope, - -- both Ids and TyVars - , le_joins :: IdSet -- Join points in scope that are valid - -- A subset of teh InScopeSet in le_subst - -- See Note [Join points] - , le_dynflags :: DynFlags -- DynamicFlags - } - -data LintFlags - = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] - , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] - , lf_check_static_ptrs :: StaticPtrCheck - -- ^ See Note [Checking StaticPtrs] - } - --- See Note [Checking StaticPtrs] -data StaticPtrCheck - = AllowAnywhere - -- ^ Allow 'makeStatic' to occur anywhere. - | AllowAtTopLevel - -- ^ Allow 'makeStatic' calls at the top-level only. - | RejectEverywhere - -- ^ Reject any 'makeStatic' occurrence. - deriving Eq - -defaultLintFlags :: LintFlags -defaultLintFlags = LF { lf_check_global_ids = False - , lf_check_inline_loop_breakers = True - , lf_check_static_ptrs = AllowAnywhere - } - -newtype LintM a = - LintM { unLintM :: - LintEnv -> - WarnsAndErrs -> -- Error and warning messages so far - (Maybe a, WarnsAndErrs) } -- Result and messages (if any) - -type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) - -{- Note [Checking for global Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before CoreTidy, all locally-bound Ids must be LocalIds, even -top-level ones. See Note [Exported LocalIds] and Trac #9857. - -Note [Checking StaticPtrs] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Note [Grand plan for static forms] in StaticPtrTable for an overview. - -Every occurrence of the function 'makeStatic' should be moved to the -top level by the FloatOut pass. It's vital that we don't have nested -'makeStatic' occurrences after CorePrep, because we populate the Static -Pointer Table from the top-level bindings. See SimplCore Note [Grand -plan for static forms]. - -The linter checks that no occurrence is left behind, nested within an -expression. The check is enabled only after the FloatOut, CorePrep, -and CoreTidy passes and only if the module uses the StaticPointers -language extension. Checking more often doesn't help since the condition -doesn't hold until after the first FloatOut pass. - -Note [Type substitution] -~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we need a type substitution? Consider - /\(a:*). \(x:a). /\(a:*). id a x -This is ill typed, because (renaming variables) it is really - /\(a:*). \(x:a). /\(b:*). id b x -Hence, when checking an application, we can't naively compare x's type -(at its binding site) with its expected type (at a use site). So we -rename type binders as we go, maintaining a substitution. - -The same substitution also supports let-type, current expressed as - (/\(a:*). body) ty -Here we substitute 'ty' for 'a' in 'body', on the fly. --} - -instance Functor LintM where - fmap = liftM - -instance Applicative LintM where - pure x = LintM $ \ _ errs -> (Just x, errs) - (<*>) = ap - -instance Monad LintM where - fail err = failWithL (text err) - m >>= k = LintM (\ env errs -> - let (res, errs') = unLintM m env errs in - case res of - Just r -> unLintM (k r) env errs' - Nothing -> (Nothing, errs')) - -#if __GLASGOW_HASKELL__ > 710 -instance MonadFail.MonadFail LintM where - fail err = failWithL (text err) -#endif - -instance HasDynFlags LintM where - getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs)) - -data LintLocInfo - = RhsOf Id -- The variable bound - | LambdaBodyOf Id -- The lambda-binder - | BodyOfLetRec [Id] -- One of the binders - | CaseAlt CoreAlt -- Case alternative - | CasePat CoreAlt -- The *pattern* of the case alternative - | AnExpr CoreExpr -- Some expression - | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) - | TopLevelBindings - | InType Type -- Inside a type - | InCo Coercion -- Inside a coercion - -initL :: DynFlags -> LintFlags -> InScopeSet - -> LintM a -> WarnsAndErrs -- Errors and warnings -initL dflags flags in_scope m - = case unLintM m env (emptyBag, emptyBag) of - (_, errs) -> errs - where - env = LE { le_flags = flags - , le_subst = mkEmptyTCvSubst in_scope - , le_joins = emptyVarSet - , le_loc = [] - , le_dynflags = dflags } - -getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) - -checkL :: Bool -> MsgDoc -> LintM () -checkL True _ = return () -checkL False msg = failWithL msg - --- like checkL, but relevant to type checking -lintL :: Bool -> MsgDoc -> LintM () -lintL = checkL - -checkWarnL :: Bool -> MsgDoc -> LintM () -checkWarnL True _ = return () -checkWarnL False msg = addWarnL msg - -failWithL :: MsgDoc -> LintM a -failWithL msg = LintM $ \ env (warns,errs) -> - (Nothing, (warns, addMsg env errs msg)) - -addErrL :: MsgDoc -> LintM () -addErrL msg = LintM $ \ env (warns,errs) -> - (Just (), (warns, addMsg env errs msg)) - -addWarnL :: MsgDoc -> LintM () -addWarnL msg = LintM $ \ env (warns,errs) -> - (Just (), (addMsg env warns msg, errs)) - -addMsg :: LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc -addMsg env msgs msg - = ASSERT( notNull locs ) - msgs `snocBag` mk_msg msg - where - locs = le_loc env - (loc, cxt1) = dumpLoc (head locs) - cxts = [snd (dumpLoc loc) | loc <- locs] - context = sdocWithPprDebug $ \dbg -> if dbg - then vcat (reverse cxts) $$ cxt1 $$ - text "Substitution:" <+> ppr (le_subst env) - else cxt1 - - mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg) - -addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m - = LintM $ \ env errs -> - unLintM m (env { le_loc = extra_loc : le_loc env }) errs - -inCasePat :: LintM Bool -- A slight hack; see the unique call site -inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs) - where - is_case_pat (LE { le_loc = CasePat {} : _ }) = True - is_case_pat _other = False - -addInScopeVar :: Var -> LintM a -> LintM a -addInScopeVar var m - = LintM $ \ env errs -> - unLintM m (env { le_subst = extendTCvInScope (le_subst env) var - , le_joins = delVarSet (le_joins env) var - }) errs - -extendSubstL :: TyVar -> Type -> LintM a -> LintM a -extendSubstL tv ty m - = LintM $ \ env errs -> - unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs - -updateTCvSubst :: TCvSubst -> LintM a -> LintM a -updateTCvSubst subst' m - = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs - -markAllJoinsBad :: LintM a -> LintM a -markAllJoinsBad m - = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs - -markAllJoinsBadIf :: Bool -> LintM a -> LintM a -markAllJoinsBadIf True m = markAllJoinsBad m -markAllJoinsBadIf False m = m - -addGoodJoins :: [Var] -> LintM a -> LintM a -addGoodJoins vars thing_inside - | null join_ids - = thing_inside - | otherwise - = LintM $ \ env errs -> unLintM thing_inside (add_joins env) errs - where - add_joins env = env { le_joins = le_joins env `extendVarSetList` join_ids } - join_ids = filter isJoinId vars - -getValidJoins :: LintM IdSet -getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs)) - -getTCvSubst :: LintM TCvSubst -getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) - -getInScope :: LintM InScopeSet -getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs)) - -applySubstTy :: InType -> LintM OutType -applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) } - -applySubstCo :: InCoercion -> LintM OutCoercion -applySubstCo co = do { subst <- getTCvSubst; return (substCo subst co) } - -lookupIdInScope :: Id -> LintM Id -lookupIdInScope id - | not (mustHaveLocalBinding id) - = return id -- An imported Id - | otherwise - = do { subst <- getTCvSubst - ; case lookupInScope (getTCvInScope subst) id of - Just v -> return v - Nothing -> do { addErrL out_of_scope - ; return id } } - where - out_of_scope = pprBndr LetBind id <+> text "is out of scope" - -lookupJoinId :: Id -> LintM (Maybe JoinArity) --- Look up an Id which should be a join point, valid here --- If so, return its arity, if not return Nothing -lookupJoinId id - = do { join_set <- getValidJoins - ; case lookupVarSet join_set id of - Just id' -> return (isJoinId_maybe id') - Nothing -> return Nothing } - -lintTyCoVarInScope :: Var -> LintM () -lintTyCoVarInScope v = lintInScope (text "is out of scope") v - -lintInScope :: SDoc -> Var -> LintM () -lintInScope loc_msg var = - do { subst <- getTCvSubst - ; lintL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) - (hsep [pprBndr LetBind var, loc_msg]) } - -ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM () --- check ty2 is subtype of ty1 (ie, has same structure but usage --- annotations need only be consistent, not equal) --- Assumes ty1,ty2 are have already had the substitution applied -ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg - -lintRole :: Outputable thing - => thing -- where the role appeared - -> Role -- expected - -> Role -- actual - -> LintM () -lintRole co r1 r2 - = lintL (r1 == r2) - (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> - text "got" <+> ppr r2 $$ - text "in" <+> ppr co) - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) - -dumpLoc (RhsOf v) - = (getSrcLoc v, brackets (text "RHS of" <+> pp_binders [v])) - -dumpLoc (LambdaBodyOf b) - = (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b)) - -dumpLoc (BodyOfLetRec []) - = (noSrcLoc, brackets (text "In body of a letrec with no binders")) - -dumpLoc (BodyOfLetRec bs@(_:_)) - = ( getSrcLoc (head bs), brackets (text "in body of letrec with binders" <+> pp_binders bs)) - -dumpLoc (AnExpr e) - = (noSrcLoc, text "In the expression:" <+> ppr e) - -dumpLoc (CaseAlt (con, args, _)) - = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) - -dumpLoc (CasePat (con, args, _)) - = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) - -dumpLoc (ImportedUnfolding locn) - = (locn, brackets (text "in an imported unfolding")) -dumpLoc TopLevelBindings - = (noSrcLoc, Outputable.empty) -dumpLoc (InType ty) - = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) -dumpLoc (InCo co) - = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) - -pp_binders :: [Var] -> SDoc -pp_binders bs = sep (punctuate comma (map pp_binder bs)) - -pp_binder :: Var -> SDoc -pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] - | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] - ------------------------------------------------------- --- Messages for case expressions - -mkDefaultArgsMsg :: [Var] -> MsgDoc -mkDefaultArgsMsg args - = hang (text "DEFAULT case with binders") - 4 (ppr args) - -mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc -mkCaseAltMsg e ty1 ty2 - = hang (text "Type of case alternatives not the same as the annotation on case:") - 4 (vcat [ text "Actual type:" <+> ppr ty1, - text "Annotation on case:" <+> ppr ty2, - text "Alt Rhs:" <+> ppr e ]) - -mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc -mkScrutMsg var var_ty scrut_ty subst - = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, - text "Result binder type:" <+> ppr var_ty,--(idType var), - text "Scrutinee type:" <+> ppr scrut_ty, - hsep [text "Current TCv subst", ppr subst]] - -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc -mkNonDefltMsg e - = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) -mkNonIncreasingAltsMsg e - = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) - -nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc -nonExhaustiveAltsMsg e - = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) - -mkBadConMsg :: TyCon -> DataCon -> MsgDoc -mkBadConMsg tycon datacon - = vcat [ - text "In a case alternative, data constructor isn't in scrutinee type:", - text "Scrutinee type constructor:" <+> ppr tycon, - text "Data con:" <+> ppr datacon - ] - -mkBadPatMsg :: Type -> Type -> MsgDoc -mkBadPatMsg con_result_ty scrut_ty - = vcat [ - text "In a case alternative, pattern result type doesn't match scrutinee type:", - text "Pattern result type:" <+> ppr con_result_ty, - text "Scrutinee type:" <+> ppr scrut_ty - ] - -integerScrutinisedMsg :: MsgDoc -integerScrutinisedMsg - = text "In a LitAlt, the literal is lifted (probably Integer)" - -mkBadAltMsg :: Type -> CoreAlt -> MsgDoc -mkBadAltMsg scrut_ty alt - = vcat [ text "Data alternative when scrutinee is not a tycon application", - text "Scrutinee type:" <+> ppr scrut_ty, - text "Alternative:" <+> pprCoreAlt alt ] - -mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc -mkNewTyDataConAltMsg scrut_ty alt - = vcat [ text "Data alternative for newtype datacon", - text "Scrutinee type:" <+> ppr scrut_ty, - text "Alternative:" <+> pprCoreAlt alt ] - - ------------------------------------------------------- --- Other error messages - -mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc -mkAppMsg fun_ty arg_ty arg - = vcat [text "Argument value doesn't match argument type:", - hang (text "Fun type:") 4 (ppr fun_ty), - hang (text "Arg type:") 4 (ppr arg_ty), - hang (text "Arg:") 4 (ppr arg)] - -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc -mkNonFunAppMsg fun_ty arg_ty arg - = vcat [text "Non-function type in function position", - hang (text "Fun type:") 4 (ppr fun_ty), - hang (text "Arg type:") 4 (ppr arg_ty), - hang (text "Arg:") 4 (ppr arg)] - -mkLetErr :: TyVar -> CoreExpr -> MsgDoc -mkLetErr bndr rhs - = vcat [text "Bad `let' binding:", - hang (text "Variable:") - 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), - hang (text "Rhs:") - 4 (ppr rhs)] - -mkTyAppMsg :: Type -> Type -> MsgDoc -mkTyAppMsg ty arg_ty - = vcat [text "Illegal type application:", - hang (text "Exp type:") - 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), - hang (text "Arg type:") - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -emptyRec :: CoreExpr -> MsgDoc -emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) - -mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc -mkRhsMsg binder what ty - = vcat - [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, - ppr binder], - hsep [text "Binder's type:", ppr (idType binder)], - hsep [text "Rhs type:", ppr ty]] - -mkLetAppMsg :: CoreExpr -> MsgDoc -mkLetAppMsg e - = hang (text "This argument does not satisfy the let/app invariant:") - 2 (ppr e) - -badBndrTyMsg :: Id -> SDoc -> MsgDoc -badBndrTyMsg binder what - = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder - , text "Binder's type:" <+> ppr (idType binder) ] - -mkStrictMsg :: Id -> MsgDoc -mkStrictMsg binder - = vcat [hsep [text "Recursive or top-level binder has strict demand info:", - ppr binder], - hsep [text "Binder's demand info:", ppr (idDemandInfo binder)] - ] - -mkNonTopExportedMsg :: Id -> MsgDoc -mkNonTopExportedMsg binder - = hsep [text "Non-top-level binder is marked as exported:", ppr binder] - -mkNonTopExternalNameMsg :: Id -> MsgDoc -mkNonTopExternalNameMsg binder - = hsep [text "Non-top-level binder has an external name:", ppr binder] - -mkTopNonLitStrMsg :: Id -> MsgDoc -mkTopNonLitStrMsg binder - = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] - -mkKindErrMsg :: TyVar -> Type -> MsgDoc -mkKindErrMsg tyvar arg_ty - = vcat [text "Kinds don't match in type application:", - hang (text "Type variable:") - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (text "Arg type:") - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -{- Not needed now -mkArityMsg :: Id -> MsgDoc -mkArityMsg binder - = vcat [hsep [text "Demand type has", - ppr (dmdTypeDepth dmd_ty), - text "arguments, rhs has", - ppr (idArity binder), - text "arguments,", - ppr binder], - hsep [text "Binder's strictness signature:", ppr dmd_ty] - - ] - where (StrictSig dmd_ty) = idStrictness binder --} -mkCastErr :: Outputable casted => casted -> Coercion -> Type -> Type -> MsgDoc -mkCastErr expr co from_ty expr_ty - = vcat [text "From-type of Cast differs from type of enclosed expression", - text "From-type:" <+> ppr from_ty, - text "Type of enclosed expr:" <+> ppr expr_ty, - text "Actual enclosed expr:" <+> ppr expr, - text "Coercion used in cast:" <+> ppr co - ] - -mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc -mkBadUnivCoMsg lr co - = text "Kind mismatch on the" <+> pprLeftOrRight lr <+> - text "side of a UnivCo:" <+> ppr co - -mkBadProofIrrelMsg :: Type -> Coercion -> SDoc -mkBadProofIrrelMsg ty co - = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:") - 2 (vcat [ text "type:" <+> ppr ty - , text "co:" <+> ppr co ]) - -mkBadTyVarMsg :: Var -> SDoc -mkBadTyVarMsg tv - = text "Non-tyvar used in TyVarTy:" - <+> ppr tv <+> dcolon <+> ppr (varType tv) - -mkBadJoinBindMsg :: Var -> SDoc -mkBadJoinBindMsg var - = vcat [ text "Bad join point binding:" <+> ppr var - , text "Join points can be bound only by a non-top-level let" ] - -mkInvalidJoinPointMsg :: Var -> Type -> SDoc -mkInvalidJoinPointMsg var ty - = hang (text "Join point has invalid type:") - 2 (ppr var <+> dcolon <+> ppr ty) - -mkBadJoinArityMsg :: Var -> Int -> Int -> SDoc -mkBadJoinArityMsg var ar nlams - = vcat [ text "Join point has too few lambdas", - text "Join var:" <+> ppr var, - text "Join arity:" <+> ppr ar, - text "Number of lambdas:" <+> ppr nlams ] - -invalidJoinOcc :: Var -> SDoc -invalidJoinOcc var - = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var - , text "The binder is either not a join point, or not valid here" ] - -mkBadJumpMsg :: Var -> Int -> Int -> SDoc -mkBadJumpMsg var ar nargs - = vcat [ text "Join point invoked with wrong number of arguments", - text "Join var:" <+> ppr var, - text "Join arity:" <+> ppr ar, - text "Number of arguments:" <+> int nargs ] - -mkInconsistentRecMsg :: [Var] -> SDoc -mkInconsistentRecMsg bndrs - = vcat [ text "Recursive let binders mix values and join points", - text "Binders:" <+> hsep (map ppr_with_details bndrs) ] - where - ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr) - -mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc -mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ - = vcat [ text "Mismatch in join point arity between binder and occurrence" - , text "Var:" <+> ppr bndr - , text "Arity at binding site:" <+> ppr join_arity_bndr - , text "Arity at occurrence: " <+> ppr join_arity_occ ] - -mkBndrOccTypeMismatchMsg :: Var -> Var -> OutType -> OutType -> SDoc -mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty - = vcat [ text "Mismatch in type between binder and occurrence" - , text "Var:" <+> ppr bndr - , text "Binder type:" <+> ppr bndr_ty - , text "Occurrence type:" <+> ppr var_ty - , text " Before subst:" <+> ppr (idType var) ] - -mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc -mkBadJoinPointRuleMsg bndr join_arity rule - = vcat [ text "Join point has rule with wrong number of arguments" - , text "Var:" <+> ppr bndr - , text "Join arity:" <+> ppr join_arity - , text "Rule:" <+> ppr rule ] - -pprLeftOrRight :: LeftOrRight -> MsgDoc -pprLeftOrRight CLeft = text "left" -pprLeftOrRight CRight = text "right" - -dupVars :: [[Var]] -> MsgDoc -dupVars vars - = hang (text "Duplicate variables brought into scope") - 2 (ppr vars) - -dupExtVars :: [[Name]] -> MsgDoc -dupExtVars vars - = hang (text "Duplicate top-level variables with the same qualified name") - 2 (ppr vars) - -{- -************************************************************************ -* * -\subsection{Annotation Linting} -* * -************************************************************************ --} - --- | This checks whether a pass correctly looks through debug --- annotations (@SourceNote@). This works a bit different from other --- consistency checks: We check this by running the given task twice, --- noting all differences between the results. -lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -lintAnnots pname pass guts = do - -- Run the pass as we normally would - dflags <- getDynFlags - when (gopt Opt_DoAnnotationLinting dflags) $ - liftIO $ Err.showPass dflags "Annotation linting - first run" - nguts <- pass guts - -- If appropriate re-run it without debug annotations to make sure - -- that they made no difference. - when (gopt Opt_DoAnnotationLinting dflags) $ do - liftIO $ Err.showPass dflags "Annotation linting - second run" - nguts' <- withoutAnnots pass guts - -- Finally compare the resulting bindings - liftIO $ Err.showPass dflags "Annotation linting - comparison" - let binds = flattenBinds $ mg_binds nguts - binds' = flattenBinds $ mg_binds nguts' - (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' - when (not (null diffs)) $ CoreMonad.putMsg $ vcat - [ lint_banner "warning" pname - , text "Core changes with annotations:" - , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs - ] - -- Return actual new guts - return nguts - --- | Run the given pass without annotations. This means that we both --- set the debugLevel setting to 0 in the environment as well as all --- annotations from incoming modules. -withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -withoutAnnots pass guts = do - -- Remove debug flag from environment. - dflags <- getDynFlags - let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} } - withoutFlag corem = - liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*> - getUniqueSupplyM <*> getModule <*> - getVisibleOrphanMods <*> - getPrintUnqualified <*> getSrcSpanM <*> - pure corem - -- Nuke existing ticks in module. - -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes - -- them in absence of debugLevel > 0. - let nukeTicks = stripTicksE (not . tickishIsCode) - nukeAnnotsBind :: CoreBind -> CoreBind - nukeAnnotsBind bind = case bind of - Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs - NonRec b e -> NonRec b $ nukeTicks e - nukeAnnotsMod mg@ModGuts{mg_binds=binds} - = mg{mg_binds = map nukeAnnotsBind binds} - -- Perform pass with all changes applied - fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts) diff --git a/coreSyn/CoreOpt.hs b/coreSyn/CoreOpt.hs deleted file mode 100644 --- a/coreSyn/CoreOpt.hs +++ /dev/null @@ -1,1176 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} -module CoreOpt ( - -- ** Simple expression optimiser - simpleOptPgm, simpleOptExpr, simpleOptExprWith, - - -- ** Join points - joinPointBinding_maybe, joinPointBindings_maybe, - - -- ** Predicates on expressions - exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, - - -- ** Coercions and casts - pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo - ) where - -#include "HsVersions.h" - -import CoreArity( joinRhsArity, etaExpandToJoinPoint ) - -import CoreSyn -import CoreSubst -import CoreUtils -import CoreFVs -import PprCore ( pprCoreBindings, pprRules ) -import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) -import Literal ( Literal(MachStr) ) -import Id -import Var ( varType ) -import VarSet -import VarEnv -import DataCon -import OptCoercion ( optCoercion ) -import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import Coercion hiding ( substCo, substCoVarBndr ) -import TyCon ( tyConArity ) -import TysWiredIn -import PrelNames -import BasicTypes -import Module ( Module ) -import ErrUtils -import DynFlags -import Outputable -import Pair -import Util -import Maybes ( orElse ) -import FastString -import Data.List -import qualified Data.ByteString as BS - -{- -************************************************************************ -* * - The Simple Optimiser -* * -************************************************************************ - -Note [The simple optimiser] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The simple optimiser is a lightweight, pure (non-monadic) function -that rapidly does a lot of simple optimisations, including - - - inlining things that occur just once, - or whose RHS turns out to be trivial - - beta reduction - - case of known constructor - - dead code elimination - -It does NOT do any call-site inlining; it only inlines a function if -it can do so unconditionally, dropping the binding. It thereby -guarantees to leave no un-reduced beta-redexes. - -It is careful to follow the guidance of "Secrets of the GHC inliner", -and in particular the pre-inline-unconditionally and -post-inline-unconditionally story, to do effective beta reduction on -functions called precisely once, without repeatedly optimising the same -expression. In fact, the simple optimiser is a good example of this -little dance in action; the full Simplifier is a lot more complicated. - --} - -simpleOptExpr :: CoreExpr -> CoreExpr --- See Note [The simple optimiser] --- Do simple optimisation on an expression --- The optimisation is very straightforward: just --- inline non-recursive bindings that are used only once, --- or where the RHS is trivial --- --- We also inline bindings that bind a Eq# box: see --- See Note [Getting the map/coerce RULE to work]. --- --- Also we convert functions to join points where possible (as --- the occurrence analyser does most of the work anyway). --- --- The result is NOT guaranteed occurrence-analysed, because --- in (let x = y in ....) we substitute for x; so y's occ-info --- may change radically - -simpleOptExpr expr - = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) - simpleOptExprWith init_subst expr - where - init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) - -- It's potentially important to make a proper in-scope set - -- Consider let x = ..y.. in \y. ...x... - -- Then we should remember to clone y before substituting - -- for x. It's very unlikely to occur, because we probably - -- won't *be* substituting for x if it occurs inside a - -- lambda. - -- - -- It's a bit painful to call exprFreeVars, because it makes - -- three passes instead of two (occ-anal, and go) - -simpleOptExprWith :: Subst -> InExpr -> OutExpr --- See Note [The simple optimiser] -simpleOptExprWith subst expr - = simple_opt_expr init_env (occurAnalyseExpr expr) - where - init_env = SOE { soe_inl = emptyVarEnv, soe_subst = subst } - ----------------------- -simpleOptPgm :: DynFlags -> Module - -> CoreProgram -> [CoreRule] -> [CoreVect] - -> IO (CoreProgram, [CoreRule], [CoreVect]) --- See Note [The simple optimiser] -simpleOptPgm dflags this_mod binds rules vects - = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" - (pprCoreBindings occ_anald_binds $$ pprRules rules ); - - ; return (reverse binds', rules', vects') } - where - occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -} - rules vects emptyVarSet binds - - (final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds - final_subst = soe_subst final_env - - rules' = substRulesForImportedIds final_subst rules - vects' = substVects final_subst vects - -- We never unconditionally inline into rules, - -- hence pasing just a substitution - - do_one (env, binds') bind - = case simple_opt_bind env bind of - (env', Nothing) -> (env', binds') - (env', Just bind') -> (env', bind':binds') - --- In these functions the substitution maps InVar -> OutExpr - ----------------------- -type SimpleClo = (SimpleOptEnv, InExpr) - -data SimpleOptEnv - = SOE { soe_inl :: IdEnv SimpleClo - -- Deals with preInlineUnconditionally; things - -- that occur exactly once and are inlined - -- without having first been simplified - - , soe_subst :: Subst - -- Deals with cloning; includes the InScopeSet - } - -instance Outputable SimpleOptEnv where - ppr (SOE { soe_inl = inl, soe_subst = subst }) - = text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl - , text "soe_subst =" <+> ppr subst ] - <+> text "}" - -emptyEnv :: SimpleOptEnv -emptyEnv = SOE { soe_inl = emptyVarEnv - , soe_subst = emptySubst } - -soeZapSubst :: SimpleOptEnv -> SimpleOptEnv -soeZapSubst (SOE { soe_subst = subst }) - = SOE { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst } - -soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv --- Take in-scope set from env1, and the rest from env2 -soeSetInScope (SOE { soe_subst = subst1 }) - env2@(SOE { soe_subst = subst2 }) - = env2 { soe_subst = setInScope subst2 (substInScope subst1) } - ---------------- -simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr -simple_opt_clo env (e_env, e) - = simple_opt_expr (soeSetInScope env e_env) e - -simple_opt_expr :: SimpleOptEnv -> InExpr -> OutExpr -simple_opt_expr env expr - = go expr - where - subst = soe_subst env - in_scope = substInScope subst - in_scope_env = (in_scope, simpleUnfoldingFun) - - go (Var v) - | Just clo <- lookupVarEnv (soe_inl env) v - = simple_opt_clo env clo - | otherwise - = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v - - go (App e1 e2) = simple_app env e1 [(env,e2)] - go (Type ty) = Type (substTy subst ty) - go (Coercion co) = Coercion (optCoercion (getTCvSubst subst) co) - go (Lit lit) = Lit lit - go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) - go (Cast e co) | isReflCo co' = go e - | otherwise = Cast (go e) co' - where - co' = optCoercion (getTCvSubst subst) co - - go (Let bind body) = case simple_opt_bind env bind of - (env', Nothing) -> simple_opt_expr env' body - (env', Just bind) -> Let bind (simple_opt_expr env' body) - - go lam@(Lam {}) = go_lam env [] lam - go (Case e b ty as) - -- See Note [Getting the map/coerce RULE to work] - | isDeadBinder b - , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e' - , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as - = case altcon of - DEFAULT -> go rhs - _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs - where - (env', mb_prs) = mapAccumL simple_out_bind env $ - zipEqual "simpleOptExpr" bs es - - -- Note [Getting the map/coerce RULE to work] - | isDeadBinder b - , [(DEFAULT, _, rhs)] <- as - , isCoercionType (varType b) - , (Var fun, _args) <- collectArgs e - , fun `hasKey` coercibleSCSelIdKey - -- without this last check, we get #11230 - = go rhs - - | otherwise - = Case e' b' (substTy subst ty) - (map (go_alt env') as) - where - e' = go e - (env', b') = subst_opt_bndr env b - - ---------------------- - go_alt env (con, bndrs, rhs) - = (con, bndrs', simple_opt_expr env' rhs) - where - (env', bndrs') = subst_opt_bndrs env bndrs - - ---------------------- - -- go_lam tries eta reduction - go_lam env bs' (Lam b e) - = go_lam env' (b':bs') e - where - (env', b') = subst_opt_bndr env b - go_lam env bs' e - | Just etad_e <- tryEtaReduce bs e' = etad_e - | otherwise = mkLams bs e' - where - bs = reverse bs' - e' = simple_opt_expr env e - ----------------------- --- simple_app collects arguments for beta reduction -simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr - -simple_app env (Var v) as - | Just (env', e) <- lookupVarEnv (soe_inl env) v - = simple_app (soeSetInScope env env') e as - - | let unf = idUnfolding v - , isCompulsoryUnfolding (idUnfolding v) - , isAlwaysActive (idInlineActivation v) - -- See Note [Unfold compulsory unfoldings in LHSs] - = simple_app (soeZapSubst env) (unfoldingTemplate unf) as - - | otherwise - , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v - = finish_app env out_fn as - -simple_app env (App e1 e2) as - = simple_app env e1 ((env, e2) : as) - -simple_app env (Lam b e) (a:as) - = wrapLet mb_pr (simple_app env' e as) - where - (env', mb_pr) = simple_bind_pair env b Nothing a - -simple_app env (Tick t e) as - -- Okay to do "(Tick t e) x ==> Tick t (e x)"? - | t `tickishScopesLike` SoftScope - = mkTick t $ simple_app env e as - -simple_app env e as - = finish_app env (simple_opt_expr env e) as - -finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr -finish_app _ fun [] - = fun -finish_app env fun (arg:args) - = finish_app env (App fun (simple_opt_clo env arg)) args - ----------------------- -simple_opt_bind :: SimpleOptEnv -> InBind - -> (SimpleOptEnv, Maybe OutBind) -simple_opt_bind env (NonRec b r) - = (env', case mb_pr of - Nothing -> Nothing - Just (b,r) -> Just (NonRec b r)) - where - (b', r') = joinPointBinding_maybe b r `orElse` (b, r) - (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') - -simple_opt_bind env (Rec prs) - = (env'', res_bind) - where - res_bind = Just (Rec (reverse rev_prs')) - prs' = joinPointBindings_maybe prs `orElse` prs - (env', bndrs') = subst_opt_bndrs env (map fst prs') - (env'', rev_prs') = foldl do_pr (env', []) (prs' `zip` bndrs') - do_pr (env, prs) ((b,r), b') - = (env', case mb_pr of - Just pr -> pr : prs - Nothing -> prs) - where - (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) - ----------------------- -simple_bind_pair :: SimpleOptEnv - -> InVar -> Maybe OutVar - -> SimpleClo - -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) - -- (simple_bind_pair subst in_var out_rhs) - -- either extends subst with (in_var -> out_rhs) - -- or returns Nothing -simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) - in_bndr mb_out_bndr clo@(rhs_env, in_rhs) - | Type ty <- in_rhs -- let a::* = TYPE ty in - , let out_ty = substTy (soe_subst rhs_env) ty - = ASSERT( isTyVar in_bndr ) - (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) - - | Coercion co <- in_rhs - , let out_co = optCoercion (getTCvSubst (soe_subst rhs_env)) co - = ASSERT( isCoVar in_bndr ) - (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) - - | pre_inline_unconditionally - = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing) - - | otherwise - = simple_out_bind_pair env in_bndr mb_out_bndr - (simple_opt_clo env clo) - occ active stable_unf - where - stable_unf = isStableUnfolding (idUnfolding in_bndr) - active = isAlwaysActive (idInlineActivation in_bndr) - occ = idOccInfo in_bndr - - pre_inline_unconditionally :: Bool - pre_inline_unconditionally - | isCoVar in_bndr = False -- See Note [Do not inline CoVars unconditionally] - | isExportedId in_bndr = False -- in SimplUtils - | stable_unf = False - | not active = False -- Note [Inline prag in simplOpt] - | not (safe_to_inline occ) = False - | otherwise = True - - -- Unconditionally safe to inline - safe_to_inline :: OccInfo -> Bool - safe_to_inline (IAmALoopBreaker {}) = False - safe_to_inline IAmDead = True - safe_to_inline occ@(OneOcc {}) = not (occ_in_lam occ) - && occ_one_br occ - safe_to_inline (ManyOccs {}) = False - -------------------- -simple_out_bind :: SimpleOptEnv -> (InVar, OutExpr) - -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) -simple_out_bind env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) - | Type out_ty <- out_rhs - = ASSERT( isTyVar in_bndr ) - (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) - - | Coercion out_co <- out_rhs - = ASSERT( isCoVar in_bndr ) - (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) - - | otherwise - = simple_out_bind_pair env in_bndr Nothing out_rhs - (idOccInfo in_bndr) True False - -------------------- -simple_out_bind_pair :: SimpleOptEnv - -> InId -> Maybe OutId -> OutExpr - -> OccInfo -> Bool -> Bool - -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) -simple_out_bind_pair env in_bndr mb_out_bndr out_rhs - occ_info active stable_unf - | post_inline_unconditionally - = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs } - , Nothing) - - | otherwise - = ( env', Just (out_bndr, out_rhs) ) - where - (env', bndr1) = case mb_out_bndr of - Just out_bndr -> (env, out_bndr) - Nothing -> subst_opt_bndr env in_bndr - out_bndr = add_info env' in_bndr bndr1 - - post_inline_unconditionally :: Bool - post_inline_unconditionally - | 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" - | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally] - | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs] - | exprIsTrivial out_rhs = True - | coercible_hack = True - | otherwise = False - - -- See Note [Getting the map/coerce RULE to work] - coercible_hack | (Var fun, args) <- collectArgs out_rhs - , Just dc <- isDataConWorkId_maybe fun - , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey - = all exprIsTrivial args - | otherwise - = False - -{- Note [Exported Ids and trivial RHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We obviously do not want to unconditionally inline an Id that is exported. -In SimplUtils, Note [Top level and postInlineUnconditionally], we -explain why we don't inline /any/ top-level things unconditionally, even -trivial ones. But we do here! Why? In the simple optimiser - - * We do no rule rewrites - * We do no call-site inlining - -Those differences obviate the reasons for not inlining a trivial rhs, -and increase the benefit for doing so. So we unconditionally inline trivial -rhss here. --} - ----------------------- -subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar]) -subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs - -subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar) -subst_opt_bndr env bndr - | isTyVar bndr = (env { soe_subst = subst_tv }, tv') - | isCoVar bndr = (env { soe_subst = subst_cv }, cv') - | otherwise = subst_opt_id_bndr env bndr - where - subst = soe_subst env - (subst_tv, tv') = substTyVarBndr subst bndr - (subst_cv, cv') = substCoVarBndr subst bndr - -subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) --- Nuke all fragile IdInfo, unfolding, and RULES; --- it gets added back later by add_info --- Rather like SimplEnv.substIdBndr --- --- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr --- carefully does not do) because simplOptExpr invalidates it - -subst_opt_id_bndr (SOE { soe_subst = subst, soe_inl = inl }) old_id - = (SOE { soe_subst = new_subst, soe_inl = new_inl }, new_id) - where - Subst in_scope id_subst tv_subst cv_subst = subst - - id1 = uniqAway in_scope old_id - id2 = setIdType id1 (substTy subst (idType old_id)) - new_id = zapFragileIdInfo id2 - -- Zaps rules, worker-info, unfolding, and fragile OccInfo - -- The unfolding and rules will get added back later, by add_info - - new_in_scope = in_scope `extendInScopeSet` new_id - - no_change = new_id == old_id - - -- Extend the substitution if the unique has changed, - -- See the notes with substTyVarBndr for the delSubstEnv - new_id_subst - | no_change = delVarEnv id_subst old_id - | otherwise = extendVarEnv id_subst old_id (Var new_id) - - new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst - new_inl = delVarEnv inl old_id - ----------------------- -add_info :: SimpleOptEnv -> InVar -> OutVar -> OutVar -add_info env old_bndr new_bndr - | isTyVar old_bndr = new_bndr - | otherwise = maybeModifyIdInfo mb_new_info new_bndr - where - subst = soe_subst env - mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr) - -simpleUnfoldingFun :: IdUnfoldingFun -simpleUnfoldingFun id - | isAlwaysActive (idInlineActivation id) = idUnfolding id - | otherwise = noUnfolding - -wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr -wrapLet Nothing body = body -wrapLet (Just (b,r)) body = Let (NonRec b r) body - ------------------- -substVects :: Subst -> [CoreVect] -> [CoreVect] -substVects subst = map (substVect subst) - ------------------- -substVect :: Subst -> CoreVect -> CoreVect -substVect subst (Vect v rhs) = Vect v (simpleOptExprWith subst rhs) -substVect _subst vd@(NoVect _) = vd -substVect _subst vd@(VectType _ _ _) = vd -substVect _subst vd@(VectClass _) = vd -substVect _subst vd@(VectInst _) = vd - -{- -Note [Inline prag in simplOpt] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If there's an INLINE/NOINLINE pragma that restricts the phase in -which the binder can be inlined, we don't inline here; after all, -we don't know what phase we're in. Here's an example - - foo :: Int -> Int -> Int - {-# INLINE foo #-} - foo m n = inner m - where - {-# INLINE [1] inner #-} - inner m = m+n - - bar :: Int -> Int - bar n = foo n 1 - -When inlining 'foo' in 'bar' we want the let-binding for 'inner' -to remain visible until Phase 1 - -Note [Unfold compulsory unfoldings in LHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the user writes `RULES map coerce = coerce` as a rule, the rule -will only ever match if simpleOptExpr replaces coerce by its unfolding -on the LHS, because that is the core that the rule matching engine -will find. So do that for everything that has a compulsory -unfolding. Also see Note [Desugaring coerce as cast] in Desugar. - -However, we don't want to inline 'seq', which happens to also have a -compulsory unfolding, so we only do this unfolding only for things -that are always-active. See Note [User-defined RULES for seq] in MkId. - -Note [Getting the map/coerce RULE to work] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We wish to allow the "map/coerce" RULE to fire: - - {-# RULES "map/coerce" map coerce = coerce #-} - -The naive core produced for this is - - forall a b (dict :: Coercible * a b). - map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict' - - where dict' :: Coercible [a] [b] - dict' = ... - -This matches literal uses of `map coerce` in code, but that's not what we -want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) -too. Some of this is addressed by compulsorily unfolding coerce on the LHS, -yielding - - forall a b (dict :: Coercible * a b). - map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... - -Getting better. But this isn't exactly what gets produced. This is because -Coercible essentially has ~R# as a superclass, and superclasses get eagerly -extracted during solving. So we get this: - - forall a b (dict :: Coercible * a b). - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... - -Unfortunately, this still abstracts over a Coercible dictionary. We really -want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, -which transforms the above to (see also Note [Desugaring coerce as cast] in -Desugar) - - forall a b (co :: a ~R# b). - let dict = MkCoercible @* @a @b co in - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... - -Now, we need simpleOptExpr to fix this up. It does so by taking three -separate actions: - 1. Inline certain non-recursive bindings. The choice whether to inline - is made in simple_bind_pair. Note the rather specific check for - MkCoercible in there. - - 2. Stripping case expressions like the Coercible_SCSel one. - See the `Case` case of simple_opt_expr's `go` function. - - 3. Look for case expressions that unpack something that was - just packed and inline them. This is also done in simple_opt_expr's - `go` function. - -This is all a fair amount of special-purpose hackery, but it's for -a good cause. And it won't hurt other RULES and such that it comes across. - - -************************************************************************ -* * - Join points -* * -************************************************************************ --} - --- | Returns Just (bndr,rhs) if the binding is a join point: --- If it's a JoinId, just return it --- If it's not yet a JoinId but is always tail-called, --- make it into a JoinId and return it. --- In the latter case, eta-expand the RHS if necessary, to make the --- lambdas explicit, as is required for join points --- --- Precondition: the InBndr has been occurrence-analysed, --- so its OccInfo is valid -joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr) -joinPointBinding_maybe bndr rhs - | not (isId bndr) - = Nothing - - | isJoinId bndr - = Just (bndr, rhs) - - | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) - , not (bad_unfolding join_arity (idUnfolding bndr)) - , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs - = Just (bndr `asJoinId` join_arity, mkLams bndrs body) - - | otherwise - = Nothing - - where - -- bad_unfolding returns True if we should /not/ convert a non-join-id - -- into a join-id, even though it is AlwaysTailCalled - -- See Note [Join points and INLINE pragmas] - bad_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs }) - = isStableSource src && join_arity > joinRhsArity rhs - bad_unfolding _ (DFunUnfolding {}) - = True - bad_unfolding _ _ - = False - -joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] -joinPointBindings_maybe bndrs - = mapM (uncurry joinPointBinding_maybe) bndrs - - -{- Note [Join points and INLINE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = let g = \x. not -- Arity 1 - {-# INLINE g #-} - in case x of - A -> g True True - B -> g True False - C -> blah2 - -Here 'g' is always tail-called applied to 2 args, but the stable -unfolding captured by the INLINE pragma has arity 1. If we try to -convert g to be a join point, its unfolding will still have arity 1 -(since it is stable, and we don't meddle with stable unfoldings), and -Lint will complain (see Note [Invariants on join points], (2a), in -CoreSyn. Trac #13413. - -Moreover, since g is going to be inlined anyway, there is no benefit -from making it a join point. - -If it is recursive, and uselessly marked INLINE, this will stop us -making it a join point, which is a annoying. But occasionally -(notably in class methods; see Note [Instances and loop breakers] in -TcInstDcls) we mark recurive things as INLINE but the recursion -unravels; so ignoring INLINE pragmas on recursive things isn't good -either. - - -************************************************************************ -* * - exprIsConApp_maybe -* * -************************************************************************ - -Note [exprIsConApp_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~ -exprIsConApp_maybe is a very important function. There are two principal -uses: - * case e of { .... } - * cls_op e, where cls_op is a class operation - -In both cases you want to know if e is of form (C e1..en) where C is -a data constructor. - -However e might not *look* as if - - -Note [exprIsConApp_maybe on literal strings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #9400 and #13317. - -Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core -they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or -unpackCStringUtf8# when the literal contains multi-byte UTF8 characters. - -For optimizations we want to be able to treat it as a list, so they can be -decomposed when used in a case-statement. exprIsConApp_maybe detects those -calls to unpackCString# and returns: - -Just (':', [Char], ['a', unpackCString# "bc"]). - -We need to be careful about UTF8 strings here. ""# contains a ByteString, so -we must parse it back into a FastString to split off the first character. -That way we can treat unpackCString# and unpackCStringUtf8# in the same way. - -We must also be caeful about - lvl = "foo"# - ...(unpackCString# lvl)... -to ensure that we see through the let-binding for 'lvl'. Hence the -(exprIsLiteral_maybe .. arg) in the guard before the call to -dealWithStringLiteral. - -Note [Push coercions in exprIsConApp_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Trac #13025 I found a case where we had - op (df @t1 @t2) -- op is a ClassOp -where - df = (/\a b. K e1 e2) |> g - -To get this to come out we need to simplify on the fly - ((/\a b. K e1 e2) |> g) @t1 @t2 - -Hence the use of pushCoArgs. --} - -data ConCont = CC [CoreExpr] Coercion - -- Substitution already applied - --- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is --- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, --- where t1..tk are the *universally-qantified* type args of 'dc' -exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) -exprIsConApp_maybe (in_scope, id_unf) expr - = go (Left in_scope) expr (CC [] (mkRepReflCo (exprType expr))) - where - go :: Either InScopeSet Subst - -- Left in-scope means "empty substitution" - -- Right subst means "apply this substitution to the CoreExpr" - -> CoreExpr -> ConCont - -> Maybe (DataCon, [Type], [CoreExpr]) - go subst (Tick t expr) cont - | not (tickishIsCode t) = go subst expr cont - go subst (Cast expr co1) (CC args co2) - | Just (args', co1') <- pushCoArgs (subst_co subst co1) args - -- See Note [Push coercions in exprIsConApp_maybe] - = go subst expr (CC args' (co1' `mkTransCo` co2)) - go subst (App fun arg) (CC args co) - = go subst fun (CC (subst_arg subst arg : args) co) - go subst (Lam var body) (CC (arg:args) co) - | exprIsTrivial arg -- Don't duplicate stuff! - = go (extend subst var arg) body (CC args co) - go (Right sub) (Var v) cont - = go (Left (substInScope sub)) - (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) - cont - - go (Left in_scope) (Var fun) cont@(CC args co) - - | Just con <- isDataConWorkId_maybe fun - , count isValArg args == idArity fun - = pushCoDataCon con args co - - -- Look through dictionary functions; see Note [Unfolding DFuns] - | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding - , bndrs `equalLength` args -- See Note [DFun arity check] - , let subst = mkOpenSubst in_scope (bndrs `zip` args) - = pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co - - -- Look through unfoldings, but only arity-zero one; - -- if arity > 0 we are effectively inlining a function call, - -- and that is the business of callSiteInline. - -- In practice, without this test, most of the "hits" were - -- CPR'd workers getting inlined back into their wrappers, - | idArity fun == 0 - , Just rhs <- expandUnfolding_maybe unfolding - , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) - = go (Left in_scope') rhs cont - - -- See Note [exprIsConApp_maybe on literal strings] - | (fun `hasKey` unpackCStringIdKey) || - (fun `hasKey` unpackCStringUtf8IdKey) - , [arg] <- args - , Just (MachStr str) <- exprIsLiteral_maybe (in_scope, id_unf) arg - = dealWithStringLiteral fun str co - where - unfolding = id_unf fun - - go _ _ _ = Nothing - - ---------------------------- - -- Operations on the (Either InScopeSet CoreSubst) - -- The Left case is wildly dominant - subst_co (Left {}) co = co - subst_co (Right s) co = CoreSubst.substCo s co - - subst_arg (Left {}) e = e - subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e - - extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) - extend (Right s) v e = Right (extendSubst s v e) - - --- See Note [exprIsConApp_maybe on literal strings] -dealWithStringLiteral :: Var -> BS.ByteString -> Coercion - -> Maybe (DataCon, [Type], [CoreExpr]) - --- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS --- turns those into [] automatically, but just in case something else in GHC --- generates a string literal directly. -dealWithStringLiteral _ str co - | BS.null str - = pushCoDataCon nilDataCon [Type charTy] co - -dealWithStringLiteral fun str co - = let strFS = mkFastStringByteString str - - char = mkConApp charDataCon [mkCharLit (headFS strFS)] - charTail = fastStringToByteString (tailFS strFS) - - -- In singleton strings, just add [] instead of unpackCstring# ""#. - rest = if BS.null charTail - then mkConApp nilDataCon [Type charTy] - else App (Var fun) - (Lit (MachStr charTail)) - - in pushCoDataCon consDataCon [Type charTy, char, rest] co - -{- -Note [Unfolding DFuns] -~~~~~~~~~~~~~~~~~~~~~~ -DFuns look like - - df :: forall a b. (Eq a, Eq b) -> Eq (a,b) - df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) - ($c2 a b d_a d_b) - -So to split it up we just need to apply the ops $c1, $c2 etc -to the very same args as the dfun. It takes a little more work -to compute the type arguments to the dictionary constructor. - -Note [DFun arity check] -~~~~~~~~~~~~~~~~~~~~~~~ -Here we check that the total number of supplied arguments (inclding -type args) matches what the dfun is expecting. This may be *less* -than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn --} - -exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal --- Same deal as exprIsConApp_maybe, but much simpler --- Nevertheless we do need to look through unfoldings for --- Integer and string literals, which are vigorously hoisted to top level --- and not subsequently inlined -exprIsLiteral_maybe env@(_, id_unf) e - = case e of - Lit l -> Just l - Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? - Var v | Just rhs <- expandUnfolding_maybe (id_unf v) - -> exprIsLiteral_maybe env rhs - _ -> Nothing - -{- -Note [exprIsLambda_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -exprIsLambda_maybe will, given an expression `e`, try to turn it into the form -`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through -casts (using the Push rule), and it unfolds function calls if the unfolding -has a greater arity than arguments are present. - -Currently, it is used in Rules.match, and is required to make -"map coerce = coerce" match. --} - -exprIsLambda_maybe :: InScopeEnv -> CoreExpr - -> Maybe (Var, CoreExpr,[Tickish Id]) - -- See Note [exprIsLambda_maybe] - --- The simple case: It is a lambda already -exprIsLambda_maybe _ (Lam x e) - = Just (x, e, []) - --- Still straightforward: Ticks that we can float out of the way -exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) - | tickishFloatable t - , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e - = Just (x, e, t:ts) - --- Also possible: A casted lambda. Push the coercion inside -exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) - | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e - -- Only do value lambdas. - -- this implies that x is not in scope in gamma (makes this code simpler) - , not (isTyVar x) && not (isCoVar x) - , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True - , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co - , let res = Just (x',e',ts) - = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) - res - --- Another attempt: See if we find a partial unfolding -exprIsLambda_maybe (in_scope_set, id_unf) e - | (Var f, as, ts) <- collectArgsTicks tickishFloatable e - , idArity f > count isValArg as - -- Make sure there is hope to get a lambda - , Just rhs <- expandUnfolding_maybe (id_unf f) - -- Optimize, for beta-reduction - , let e' = simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as) - -- Recurse, because of possible casts - , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' - , let res = Just (x', e'', ts++ts') - = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) - res - -exprIsLambda_maybe _ _e - = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) - Nothing - - -{- ********************************************************************* -* * - The "push rules" -* * -************************************************************************ - -Here we implement the "push rules" from FC papers: - -* The push-argument rules, where we can move a coercion past an argument. - We have - (fun |> co) arg - and we want to transform it to - (fun arg') |> co' - for some suitable co' and tranformed arg'. - -* The PushK rule for data constructors. We have - (K e1 .. en) |> co - and we want to tranform to - (K e1' .. en') - by pushing the coercion into the oarguments --} - -pushCoArgs :: Coercion -> [CoreArg] -> Maybe ([CoreArg], Coercion) -pushCoArgs co [] = return ([], co) -pushCoArgs co (arg:args) = do { (arg', co1) <- pushCoArg co arg - ; (args', co2) <- pushCoArgs co1 args - ; return (arg':args', co2) } - -pushCoArg :: Coercion -> CoreArg -> Maybe (CoreArg, Coercion) --- We have (fun |> co) arg, and we want to transform it to --- (fun arg) |> co --- This may fail, e.g. if (fun :: N) where N is a newtype --- C.f. simplCast in Simplify.hs --- 'co' is always Representational - -pushCoArg co (Type ty) = do { (ty', co') <- pushCoTyArg co ty - ; return (Type ty', co') } -pushCoArg co val_arg = do { (arg_co, co') <- pushCoValArg co - ; return (mkCast val_arg arg_co, co') } - -pushCoTyArg :: Coercion -> Type -> Maybe (Type, Coercion) --- We have (fun |> co) @ty --- Push the coercion through to return --- (fun @ty') |> co' --- 'co' is always Representational -pushCoTyArg co ty - | tyL `eqType` tyR - = Just (ty, mkRepReflCo (piResultTy tyR ty)) - - | isForAllTy tyL - = ASSERT2( isForAllTy tyR, ppr co $$ ppr ty ) - Just (ty `mkCastTy` mkSymCo co1, co2) - - | otherwise - = Nothing - where - Pair tyL tyR = coercionKind co - -- co :: tyL ~ tyR - -- tyL = forall (a1 :: k1). ty1 - -- tyR = forall (a2 :: k2). ty2 - - co1 = mkNthCo 0 co - -- co1 :: k1 ~ k2 - -- Note that NthCo can extract an equality between the kinds - -- of the types related by a coercion between forall-types. - -- See the NthCo case in CoreLint. - - co2 = mkInstCo co (mkCoherenceLeftCo (mkNomReflCo ty) co1) - -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] - -- Arg of mkInstCo is always nominal, hence mkNomReflCo - -pushCoValArg :: Coercion -> Maybe (Coercion, Coercion) --- We have (fun |> co) arg --- Push the coercion through to return --- (fun (arg |> co_arg)) |> co_res --- 'co' is always Representational -pushCoValArg co - | tyL `eqType` tyR - = Just (mkRepReflCo arg, mkRepReflCo res) - - | isFunTy tyL - , (co1, co2) <- decomposeFunCo co - -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) - -- then co1 :: tyL1 ~ tyR1 - -- co2 :: tyL2 ~ tyR2 - = ASSERT2( isFunTy tyR, ppr co $$ ppr arg ) - Just (mkSymCo co1, co2) - - | otherwise - = Nothing - where - (arg, res) = splitFunTy tyR - Pair tyL tyR = coercionKind co - -pushCoercionIntoLambda - :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr) --- This implements the Push rule from the paper on coercions --- (\x. e) |> co --- ===> --- (\x'. e |> co') -pushCoercionIntoLambda in_scope x e co - | ASSERT(not (isTyVar x) && not (isCoVar x)) True - , Pair s1s2 t1t2 <- coercionKind co - , Just (_s1,_s2) <- splitFunTy_maybe s1s2 - , Just (t1,_t2) <- splitFunTy_maybe t1t2 - = let (co1, co2) = decomposeFunCo co - -- Should we optimize the coercions here? - -- Otherwise they might not match too well - x' = x `setIdType` t1 - in_scope' = in_scope `extendInScopeSet` x' - subst = extendIdSubst (mkEmptySubst in_scope') - x - (mkCast (Var x') co1) - in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2) - | otherwise - = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) - Nothing - -pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion - -> Maybe (DataCon - , [Type] -- Universal type args - , [CoreExpr]) -- All other args incl existentials --- Implement the KPush reduction rule as described in "Down with kinds" --- The transformation applies iff we have --- (C e1 ... en) `cast` co --- where co :: (T t1 .. tn) ~ to_ty --- The left-hand one must be a T, because exprIsConApp returned True --- but the right-hand one might not be. (Though it usually will.) -pushCoDataCon dc dc_args co - | isReflCo co || from_ty `eqType` to_ty -- try cheap test first - , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args - = Just (dc, map exprToType univ_ty_args, rest_args) - - | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty - , to_tc == dataConTyCon dc - -- These two tests can fail; we might see - -- (C x y) `cast` (g :: T a ~ S [a]), - -- where S is a type function. In fact, exprIsConApp - -- will probably not be called in such circumstances, - -- but there't nothing wrong with it - - = let - tc_arity = tyConArity to_tc - dc_univ_tyvars = dataConUnivTyVars dc - dc_ex_tyvars = dataConExTyVars dc - arg_tys = dataConRepArgTys dc - - non_univ_args = dropList dc_univ_tyvars dc_args - (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args - - -- Make the "Psi" from the paper - omegas = decomposeCo tc_arity co - (psi_subst, to_ex_arg_tys) - = liftCoSubstWithEx Representational - dc_univ_tyvars - omegas - dc_ex_tyvars - (map exprToType ex_args) - - -- Cast the value arguments (which include dictionaries) - new_val_args = zipWith cast_arg arg_tys val_args - cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) - - to_ex_args = map Type to_ex_arg_tys - - dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, - ppr arg_tys, ppr dc_args, - ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ] - in - ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc ) - ASSERT2( equalLength val_args arg_tys, dump_doc ) - Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) - - | otherwise - = Nothing - - where - Pair from_ty to_ty = coercionKind co - -collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) --- Collect lambda binders, pushing coercions inside if possible --- E.g. (\x.e) |> g g :: -> blah --- = (\x. e |> Nth 1 g) --- --- That is, --- --- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) -collectBindersPushingCo e - = go [] e - where - -- Peel off lambdas until we hit a cast. - go :: [Var] -> CoreExpr -> ([Var], CoreExpr) - -- The accumulator is in reverse order - go bs (Lam b e) = go (b:bs) e - go bs (Cast e co) = go_c bs e co - go bs e = (reverse bs, e) - - -- We are in a cast; peel off casts until we hit a lambda. - go_c :: [Var] -> CoreExpr -> Coercion -> ([Var], CoreExpr) - -- (go_c bs e c) is same as (go bs e (e |> c)) - go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) - go_c bs (Lam b e) co = go_lam bs b e co - go_c bs e co = (reverse bs, mkCast e co) - - -- We are in a lambda under a cast; peel off lambdas and build a - -- new coercion for the body. - go_lam :: [Var] -> Var -> CoreExpr -> Coercion -> ([Var], CoreExpr) - -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) - go_lam bs b e co - | isTyVar b - , let Pair tyL tyR = coercionKind co - , ASSERT( isForAllTy tyL ) - isForAllTy tyR - , isReflCo (mkNthCo 0 co) -- See Note [collectBindersPushingCo] - = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) - - | isId b - , let Pair tyL tyR = coercionKind co - , ASSERT( isFunTy tyL) isFunTy tyR - , (co_arg, co_res) <- decomposeFunCo co - , isReflCo co_arg -- See Note [collectBindersPushingCo] - = go_c (b:bs) e co_res - - | otherwise = (reverse bs, mkCast (Lam b e) co) - -{- Note [collectBindersPushingCo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We just look for coercions of form - -> blah -(and similarly for foralls) to keep this function simple. We could do -more elaborate stuff, but it'd involve substitution etc. --} diff --git a/coreSyn/CorePrep.hs b/coreSyn/CorePrep.hs deleted file mode 100644 --- a/coreSyn/CorePrep.hs +++ /dev/null @@ -1,1587 +0,0 @@ -{- -(c) The University of Glasgow, 1994-2006 - - -Core pass to saturate constructors and PrimOps --} - -{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-} - -module CorePrep ( - corePrepPgm, corePrepExpr, cvtLitInteger, - lookupMkIntegerName, lookupIntegerSDataConName - ) where - -#include "HsVersions.h" - -import OccurAnal - -import HscTypes -import PrelNames -import MkId ( realWorldPrimId ) -import CoreUtils -import CoreArity -import CoreFVs -import CoreMonad ( CoreToDo(..) ) -import CoreLint ( endPassIO ) -import CoreSyn -import CoreSubst -import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here -import Type -import Literal -import Coercion -import TcEnv -import TyCon -import Demand -import Var -import VarSet -import VarEnv -import Id -import IdInfo -import TysWiredIn -import DataCon -import PrimOp -import BasicTypes -import Module -import UniqSupply -import Maybes -import OrdList -import ErrUtils -import DynFlags -import Util -import Pair -import Outputable -import Platform -import FastString -import Config -import Name ( NamedThing(..), nameSrcSpan ) -import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) -import Data.Bits -import MonadUtils ( mapAccumLM ) -import Data.List ( mapAccumL ) -import Control.Monad - -{- --- --------------------------------------------------------------------------- --- Overview --- --------------------------------------------------------------------------- - -The goal of this pass is to prepare for code generation. - -1. Saturate constructor and primop applications. - -2. Convert to A-normal form; that is, function arguments - are always variables. - - * Use case for strict arguments: - f E ==> case E of x -> f x - (where f is strict) - - * Use let for non-trivial lazy arguments - f E ==> let x = E in f x - (were f is lazy and x is non-trivial) - -3. Similarly, convert any unboxed lets into cases. - [I'm experimenting with leaving 'ok-for-speculation' - rhss in let-form right up to this point.] - -4. Ensure that *value* lambdas only occur as the RHS of a binding - (The code generator can't deal with anything else.) - Type lambdas are ok, however, because the code gen discards them. - -5. [Not any more; nuked Jun 2002] Do the seq/par munging. - -6. Clone all local Ids. - This means that all such Ids are unique, rather than the - weaker guarantee of no clashes which the simplifier provides. - And that is what the code generator needs. - - We don't clone TyVars or CoVars. The code gen doesn't need that, - and doing so would be tiresome because then we'd need - to substitute in types and coercions. - -7. Give each dynamic CCall occurrence a fresh unique; this is - rather like the cloning step above. - -8. Inject bindings for the "implicit" Ids: - * Constructor wrappers - * Constructor workers - We want curried definitions for all of these in case they - aren't inlined by some caller. - -9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.hs - Also replace (noinline e) by e. - -10. Convert (LitInteger i t) into the core representation - for the Integer i. Normally this uses mkInteger, but if - we are using the integer-gmp implementation then there is a - special case where we use the S# constructor for Integers that - are in the range of Int. - -11. Uphold tick consistency while doing this: We move ticks out of - (non-type) applications where we can, and make sure that we - annotate according to scoping rules when floating. - -This is all done modulo type applications and abstractions, so that -when type erasure is done for conversion to STG, we don't end up with -any trivial or useless bindings. - - -Note [CorePrep invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is the syntax of the Core produced by CorePrep: - - Trivial expressions - arg ::= lit | var - | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co - - Applications - app ::= lit | var | app arg | app ty | app co | app |> co - - Expressions - body ::= app - | let(rec) x = rhs in body -- Boxed only - | case body of pat -> body - | /\a. body | /\c. body - | body |> co - - Right hand sides (only place where value lambdas can occur) - rhs ::= /\a.rhs | \x.rhs | body - -We define a synonym for each of these non-terminals. Functions -with the corresponding name produce a result in that syntax. --} - -type CpeArg = CoreExpr -- Non-terminal 'arg' -type CpeApp = CoreExpr -- Non-terminal 'app' -type CpeBody = CoreExpr -- Non-terminal 'body' -type CpeRhs = CoreExpr -- Non-terminal 'rhs' - -{- -************************************************************************ -* * - Top level stuff -* * -************************************************************************ --} - -corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon] - -> IO CoreProgram -corePrepPgm hsc_env this_mod mod_loc binds data_tycons = - withTiming (pure dflags) - (text "CorePrep"<+>brackets (ppr this_mod)) - (const ()) $ do - us <- mkSplitUniqSupply 's' - initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env - - let implicit_binds = mkDataConWorkers dflags mod_loc data_tycons - -- NB: we must feed mkImplicitBinds through corePrep too - -- so that they are suitably cloned and eta-expanded - - binds_out = initUs_ us $ do - floats1 <- corePrepTopBinds initialCorePrepEnv binds - floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds - return (deFloatTop (floats1 `appendFloats` floats2)) - - endPassIO hsc_env alwaysQualify CorePrep binds_out [] - return binds_out - where - dflags = hsc_dflags hsc_env - -corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr -corePrepExpr dflags hsc_env expr = - withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do - us <- mkSplitUniqSupply 's' - initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env - let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) - dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) - return new_expr - -corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats --- Note [Floating out of top level bindings] -corePrepTopBinds initialCorePrepEnv binds - = go initialCorePrepEnv binds - where - go _ [] = return emptyFloats - go env (bind : binds) = do (env', floats, maybe_new_bind) - <- cpeBind TopLevel env bind - MASSERT(isNothing maybe_new_bind) - -- Only join points get returned this way by - -- cpeBind, and no join point may float to top - floatss <- go env' binds - return (floats `appendFloats` floatss) - -mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind] --- See Note [Data constructor workers] --- c.f. Note [Injecting implicit bindings] in TidyPgm -mkDataConWorkers dflags mod_loc data_tycons - = [ NonRec id (tick_it (getName data_con) (Var id)) - -- The ice is thin here, but it works - | tycon <- data_tycons, -- CorePrep will eta-expand it - data_con <- tyConDataCons tycon, - let id = dataConWorkId data_con - ] - where - -- If we want to generate debug info, we put a source note on the - -- worker. This is useful, especially for heap profiling. - tick_it name - | debugLevel dflags == 0 = id - | RealSrcSpan span <- nameSrcSpan name = tick span - | Just file <- ml_hs_file mod_loc = tick (span1 file) - | otherwise = tick (span1 "???") - where tick span = Tick (SourceNote span $ showSDoc dflags (ppr name)) - span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 - -{- -Note [Floating out of top level bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: we do need to float out of top-level bindings -Consider x = length [True,False] -We want to get - s1 = False : [] - s2 = True : s1 - x = length s2 - -We return a *list* of bindings, because we may start with - x* = f (g y) -where x is demanded, in which case we want to finish with - a = g y - x* = f a -And then x will actually end up case-bound - -Note [CafInfo and floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What happens when we try to float bindings to the top level? At this -point all the CafInfo is supposed to be correct, and we must make certain -that is true of the new top-level bindings. There are two cases -to consider - -a) The top-level binding is marked asCafRefs. In that case we are - basically fine. The floated bindings had better all be lazy lets, - so they can float to top level, but they'll all have HasCafRefs - (the default) which is safe. - -b) The top-level binding is marked NoCafRefs. This really happens - Example. CoreTidy produces - $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah... - Now CorePrep has to eta-expand to - $fApplicativeSTM = let sat = \xy. retry x y - in D:Alternative sat ...blah... - So what we *want* is - sat [NoCafRefs] = \xy. retry x y - $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah... - - So, gruesomely, we must set the NoCafRefs flag on the sat bindings, - *and* substitute the modified 'sat' into the old RHS. - - It should be the case that 'sat' is itself [NoCafRefs] (a value, no - cafs) else the original top-level binding would not itself have been - marked [NoCafRefs]. The DEBUG check in CoreToStg for - consistentCafInfo will find this. - -This is all very gruesome and horrible. It would be better to figure -out CafInfo later, after CorePrep. We'll do that in due course. -Meanwhile this horrible hack works. - -Note [Join points and floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Join points can float out of other join points but not out of value bindings: - - let z = - let w = ... in -- can float - join k = ... in -- can't float - ... jump k ... - join j x1 ... xn = - let y = ... in -- can float (but don't want to) - join h = ... in -- can float (but not much point) - ... jump h ... - in ... - -Here, the jump to h remains valid if h is floated outward, but the jump to k -does not. - -We don't float *out* of join points. It would only be safe to float out of -nullary join points (or ones where the arguments are all either type arguments -or dead binders). Nullary join points aren't ever recursive, so they're always -effectively one-shot functions, which we don't float out of. We *could* float -join points from nullary join points, but there's no clear benefit at this -stage. - -Note [Data constructor workers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Create any necessary "implicit" bindings for data con workers. We -create the rather strange (non-recursive!) binding - - $wC = \x y -> $wC x y - -i.e. a curried constructor that allocates. This means that we can -treat the worker for a constructor like any other function in the rest -of the compiler. The point here is that CoreToStg will generate a -StgConApp for the RHS, rather than a call to the worker (which would -give a loop). As Lennart says: the ice is thin here, but it works. - -Hmm. Should we create bindings for dictionary constructors? They are -always fully applied, and the bindings are just there to support -partial applications. But it's easier to let them through. - - -Note [Dead code in CorePrep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Imagine that we got an input program like this (see Trac #4962): - - f :: Show b => Int -> (Int, b -> Maybe Int -> Int) - f x = (g True (Just x) + g () (Just x), g) - where - g :: Show a => a -> Maybe Int -> Int - g _ Nothing = x - g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown - -After specialisation and SpecConstr, we would get something like this: - - f :: Show b => Int -> (Int, b -> Maybe Int -> Int) - f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) - where - {-# RULES g $dBool = g$Bool - g $dUnit = g$Unit #-} - g = ... - {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} - g$Bool = ... - {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} - g$Unit = ... - g$Bool_True_Just = ... - g$Unit_Unit_Just = ... - -Note that the g$Bool and g$Unit functions are actually dead code: they -are only kept alive by the occurrence analyser because they are -referred to by the rules of g, which is being kept alive by the fact -that it is used (unspecialised) in the returned pair. - -However, at the CorePrep stage there is no way that the rules for g -will ever fire, and it really seems like a shame to produce an output -program that goes to the trouble of allocating a closure for the -unreachable g$Bool and g$Unit functions. - -The way we fix this is to: - * In cloneBndr, drop all unfoldings/rules - - * In deFloatTop, run a simple dead code analyser on each top-level - RHS to drop the dead local bindings. For that call to OccAnal, we - disable the binder swap, else the occurrence analyser sometimes - introduces new let bindings for cased binders, which lead to the bug - in #5433. - -The reason we don't just OccAnal the whole output of CorePrep is that -the tidier ensures that all top-level binders are GlobalIds, so they -don't show up in the free variables any longer. So if you run the -occurrence analyser on the output of CoreTidy (or later) you e.g. turn -this program: - - Rec { - f = ... f ... - } - -Into this one: - - f = ... f ... - -(Since f is not considered to be free in its own RHS.) - - -************************************************************************ -* * - The main code -* * -************************************************************************ --} - -cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind - -> UniqSM (CorePrepEnv, - Floats, -- Floating value bindings - Maybe CoreBind) -- Just bind' <=> returned new bind; no float - -- Nothing <=> added bind' to floats instead -cpeBind top_lvl env (NonRec bndr rhs) - | not (isJoinId bndr) - = do { (_, bndr1) <- cpCloneBndr env bndr - ; let dmd = idDemandInfo bndr - is_unlifted = isUnliftedType (idType bndr) - ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive - dmd - is_unlifted - env bndr1 rhs - -- See Note [Inlining in CorePrep] - ; if exprIsTrivial rhs2 && isNotTopLevel top_lvl - then return (extendCorePrepEnvExpr env bndr rhs2, floats, Nothing) - else do { - - ; let new_float = mkFloat dmd is_unlifted bndr2 rhs2 - - -- We want bndr'' in the envt, because it records - -- the evaluated-ness of the binder - ; return (extendCorePrepEnv env bndr bndr2, - addFloat floats new_float, - Nothing) }} - | otherwise -- See Note [Join points and floating] - = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point - do { (_, bndr1) <- cpCloneBndr env bndr - ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs - ; return (extendCorePrepEnv env bndr bndr2, - emptyFloats, - Just (NonRec bndr2 rhs1)) } - -cpeBind top_lvl env (Rec pairs) - | not (isJoinId (head bndrs)) - = do { (env', bndrs1) <- cpCloneBndrs env bndrs - ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss - - ; let (floats_s, bndrs2, rhss2) = unzip3 stuff - all_pairs = foldrOL add_float (bndrs2 `zip` rhss2) - (concatFloats floats_s) - ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), - unitFloat (FloatLet (Rec all_pairs)), - Nothing) } - | otherwise -- See Note [Join points and floating] - = do { (env', bndrs1) <- cpCloneBndrs env bndrs - ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss - - ; let bndrs2 = map fst pairs1 - ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2), - emptyFloats, - Just (Rec pairs1)) } - where - (bndrs, rhss) = unzip pairs - - -- Flatten all the floats, and the current - -- group into a single giant Rec - add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 - add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 - add_float b _ = pprPanic "cpeBind" (ppr b) - ---------------- -cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool - -> CorePrepEnv -> Id -> CoreExpr - -> UniqSM (Floats, Id, CpeRhs) --- Used for all bindings -cpePair top_lvl is_rec dmd is_unlifted env bndr rhs - = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair - do { (floats1, rhs1) <- cpeRhsE env rhs - - -- See if we are allowed to float this stuff out of the RHS - ; (floats2, rhs2) <- float_from_rhs floats1 rhs1 - - -- Make the arity match up - ; (floats3, rhs3) - <- if manifestArity rhs1 <= arity - then return (floats2, cpeEtaExpand arity rhs2) - else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) - -- Note [Silly extra arguments] - (do { v <- newVar (idType bndr) - ; let float = mkFloat topDmd False v rhs2 - ; return ( addFloat floats2 float - , cpeEtaExpand arity (Var v)) }) - - -- Wrap floating ticks - ; let (floats4, rhs4) = wrapTicks floats3 rhs3 - - -- Record if the binder is evaluated - -- and otherwise trim off the unfolding altogether - -- It's not used by the code generator; getting rid of it reduces - -- heap usage and, since we may be changing uniques, we'd have - -- to substitute to keep it right - ; let bndr' | exprIsHNF rhs3 = bndr `setIdUnfolding` evaldUnfolding - | otherwise = bndr `setIdUnfolding` noUnfolding - - ; return (floats4, bndr', rhs4) } - where - platform = targetPlatform (cpe_dynFlags env) - - arity = idArity bndr -- We must match this arity - - --------------------- - float_from_rhs floats rhs - | isEmptyFloats floats = return (emptyFloats, rhs) - | isTopLevel top_lvl = float_top floats rhs - | otherwise = float_nested floats rhs - - --------------------- - float_nested floats rhs - | wantFloatNested is_rec dmd is_unlifted floats rhs - = return (floats, rhs) - | otherwise = dontFloat floats rhs - - --------------------- - float_top floats rhs -- Urhgh! See Note [CafInfo and floating] - | mayHaveCafRefs (idCafInfo bndr) - , allLazyTop floats - = return (floats, rhs) - - -- So the top-level binding is marked NoCafRefs - | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs - = return (floats', rhs') - - | otherwise - = dontFloat floats rhs - -dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody) --- Non-empty floats, but do not want to float from rhs --- So wrap the rhs in the floats --- But: rhs1 might have lambdas, and we can't --- put them inside a wrapBinds -dontFloat floats1 rhs - = do { (floats2, body) <- rhsToBody rhs - ; return (emptyFloats, wrapBinds floats1 $ - wrapBinds floats2 body) } - -{- Note [Silly extra arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we had this - f{arity=1} = \x\y. e -We *must* match the arity on the Id, so we have to generate - f' = \x\y. e - f = \x. f' x - -It's a bizarre case: why is the arity on the Id wrong? Reason -(in the days of __inline_me__): - f{arity=0} = __inline_me__ (let v = expensive in \xy. e) -When InlineMe notes go away this won't happen any more. But -it seems good for CorePrep to be robust. --} - ---------------- -cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr - -> UniqSM (JoinId, CpeRhs) --- Used for all join bindings -cpeJoinPair env bndr rhs - = ASSERT(isJoinId bndr) - do { let Just join_arity = isJoinId_maybe bndr - (bndrs, body) = collectNBinders join_arity rhs - - ; (env', bndrs') <- cpCloneBndrs env bndrs - - ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts - -- with a lambda - - ; let rhs' = mkCoreLams bndrs' body' - bndr' = bndr `setIdUnfolding` evaldUnfolding - `setIdArity` count isId bndrs - -- See Note [Arity and join points] - - ; return (bndr', rhs') } - -{- -Note [Arity and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Up to now, we've allowed a join point to have an arity greater than its join -arity (minus type arguments), since this is what's useful for eta expansion. -However, for code gen purposes, its arity must be exactly the number of value -arguments it will be called with, and it must have exactly that many value -lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS: - - join j x y z = \w -> ... in ... - => - join j x y z = (let f = \w -> ... in f) in ... - -This is also what happens with Note [Silly extra arguments]. Note that it's okay -for us to mess with the arity because a join point is never exported. --} - --- --------------------------------------------------------------------------- --- CpeRhs: produces a result satisfying CpeRhs --- --------------------------------------------------------------------------- - -cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- If --- e ===> (bs, e') --- then --- e = let bs in e' (semantically, that is!) --- --- For example --- f (g x) ===> ([v = g x], f v) - -cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) -cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) -cpeRhsE env (Lit (LitInteger i _)) - = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env) - (cpe_integerSDataCon env) i) -cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) -cpeRhsE env expr@(Var {}) = cpeApp env expr -cpeRhsE env expr@(App {}) = cpeApp env expr - -cpeRhsE env (Let bind body) - = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind - ; (body_floats, body') <- cpeRhsE env' body - ; let expr' = case maybe_bind' of Just bind' -> Let bind' body' - Nothing -> body' - ; return (bind_floats `appendFloats` body_floats, expr') } - -cpeRhsE env (Tick tickish expr) - | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope - = do { (floats, body) <- cpeRhsE env expr - -- See [Floating Ticks in CorePrep] - ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) } - | otherwise - = do { body <- cpeBodyNF env expr - ; return (emptyFloats, mkTick tickish' body) } - where - tickish' | Breakpoint n fvs <- tickish - -- See also 'substTickish' - = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) - | otherwise - = tickish - -cpeRhsE env (Cast expr co) - = do { (floats, expr') <- cpeRhsE env expr - ; return (floats, Cast expr' co) } - -cpeRhsE env expr@(Lam {}) - = do { let (bndrs,body) = collectBinders expr - ; (env', bndrs') <- cpCloneBndrs env bndrs - ; body' <- cpeBodyNF env' body - ; return (emptyFloats, mkLams bndrs' body') } - -cpeRhsE env (Case scrut bndr ty alts) - = do { (floats, scrut') <- cpeBody env scrut - ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding - -- Record that the case binder is evaluated in the alternatives - ; (env', bndr2) <- cpCloneBndr env bndr1 - ; alts' <- mapM (sat_alt env') alts - ; return (floats, Case scrut' bndr2 ty alts') } - where - sat_alt env (con, bs, rhs) - = do { (env2, bs') <- cpCloneBndrs env bs - ; rhs' <- cpeBodyNF env2 rhs - ; return (con, bs', rhs') } - -cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr --- Here we convert a literal Integer to the low-level --- representation. Exactly how we do this depends on the --- library that implements Integer. If it's GMP we --- use the S# data constructor for small literals. --- See Note [Integer literals] in Literal -cvtLitInteger dflags _ (Just sdatacon) i - | inIntRange dflags i -- Special case for small integers - = mkConApp sdatacon [Lit (mkMachInt dflags i)] - -cvtLitInteger dflags mk_integer _ i - = mkApps (Var mk_integer) [isNonNegative, ints] - where isNonNegative = if i < 0 then mkConApp falseDataCon [] - else mkConApp trueDataCon [] - ints = mkListExpr intTy (f (abs i)) - f 0 = [] - f x = let low = x .&. mask - high = x `shiftR` bits - in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high - bits = 31 - mask = 2 ^ bits - 1 - --- --------------------------------------------------------------------------- --- CpeBody: produces a result satisfying CpeBody --- --------------------------------------------------------------------------- - --- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without --- producing any floats (any generated floats are immediately --- let-bound using 'wrapBinds'). Generally you want this, esp. --- when you've reached a binding form (e.g., a lambda) and --- floating any further would be incorrect. -cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody -cpeBodyNF env expr - = do { (floats, body) <- cpeBody env expr - ; return (wrapBinds floats body) } - --- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce --- a list of 'Floats' which are being propagated upwards. In --- fact, this function is used in only two cases: to --- implement 'cpeBodyNF' (which is what you usually want), --- and in the case when a let-binding is in a case scrutinee--here, --- we can always float out: --- --- case (let x = y in z) of ... --- ==> let x = y in case z of ... --- -cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) -cpeBody env expr - = do { (floats1, rhs) <- cpeRhsE env expr - ; (floats2, body) <- rhsToBody rhs - ; return (floats1 `appendFloats` floats2, body) } - --------- -rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) --- Remove top level lambdas by let-binding - -rhsToBody (Tick t expr) - | tickishScoped t == NoScope -- only float out of non-scoped annotations - = do { (floats, expr') <- rhsToBody expr - ; return (floats, mkTick t expr') } - -rhsToBody (Cast e co) - -- You can get things like - -- case e of { p -> coerce t (\s -> ...) } - = do { (floats, e') <- rhsToBody e - ; return (floats, Cast e' co) } - -rhsToBody expr@(Lam {}) - | Just no_lam_result <- tryEtaReducePrep bndrs body - = return (emptyFloats, no_lam_result) - | all isTyVar bndrs -- Type lambdas are ok - = return (emptyFloats, expr) - | otherwise -- Some value lambdas - = do { fn <- newVar (exprType expr) - ; let rhs = cpeEtaExpand (exprArity expr) expr - float = FloatLet (NonRec fn rhs) - ; return (unitFloat float, Var fn) } - where - (bndrs,body) = collectBinders expr - -rhsToBody expr = return (emptyFloats, expr) - - - --- --------------------------------------------------------------------------- --- CpeApp: produces a result satisfying CpeApp --- --------------------------------------------------------------------------- - -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick (Tickish Id) - -{- Note [runRW arg] -~~~~~~~~~~~~~~~~~~~ -If we got, say - runRW# (case bot of {}) -which happened in Trac #11291, we do /not/ want to turn it into - (case bot of {}) realWorldPrimId# -because that gives a panic in CoreToStg.myCollectArgs, which expects -only variables in function position. But if we are sure to make -runRW# strict (which we do in MkId), this can't happen --} - -cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops -cpeApp top_env expr - = do { let (terminal, args, depth) = collect_args expr - ; cpe_app top_env terminal args depth - } - - where - -- We have a nested data structure of the form - -- e `App` a1 `App` a2 ... `App` an, convert it into - -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth) - -- We use 'ArgInfo' because we may also need to - -- record casts and ticks. Depth counts the number - -- of arguments that would consume strictness information - -- (so, no type or coercion arguments.) - collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int) - collect_args e = go e [] 0 - where - go (App fun arg) as !depth - = go fun (CpeApp arg : as) - (if isTyCoArg arg then depth else depth + 1) - go (Cast fun co) as depth - = go fun (CpeCast co : as) depth - go (Tick tickish fun) as depth - | tickishPlace tickish == PlaceNonLam - && tickish `tickishScopesLike` SoftScope - = go fun (CpeTick tickish : as) depth - go terminal as depth = (terminal, as, depth) - - cpe_app :: CorePrepEnv - -> CoreExpr - -> [ArgInfo] - -> Int - -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth - | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and - || f `hasKey` noinlineIdKey -- Replace (noinline a) with a - -- Consider the code: - -- - -- lazy (f x) y - -- - -- We need to make sure that we need to recursively collect arguments on - -- "f x", otherwise we'll float "f x" out (it's not a variable) and - -- end up with this awful -ddump-prep: - -- - -- case f x of f_x { - -- __DEFAULT -> f_x y - -- } - -- - -- rather than the far superior "f x y". Test case is par01. - = let (terminal, args', depth') = collect_args arg - in cpe_app env terminal (args' ++ args) (depth + depth' - 1) - cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1 - | f `hasKey` runRWKey - -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this - -- is why we return a CorePrepEnv as well) - = case arg of - Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0 - _ -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1 - cpe_app env (Var v) args depth - = do { v1 <- fiddleCCall v - ; let e2 = lookupCorePrepEnv env v1 - hd = getIdFromTrivialExpr_maybe e2 - -- NB: depth from collect_args is right, because e2 is a trivial expression - -- and thus its embedded Id *must* be at the same depth as any - -- Apps it is under are type applications only (c.f. - -- exprIsTrivial). But note that we need the type of the - -- expression, not the id. - ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts - ; mb_saturate hd app floats depth } - where - stricts = case idStrictness v of - StrictSig (DmdType _ demands _) - | listLengthCmp demands depth /= GT -> demands - -- length demands <= depth - | otherwise -> [] - -- If depth < length demands, then we have too few args to - -- satisfy strictness info so we have to ignore all the - -- strictness info, e.g. + (error "urk") - -- Here, we can't evaluate the arg strictly, because this - -- partial application might be seq'd - - -- We inlined into something that's not a var and has no args. - -- Bounce it back up to cpeRhsE. - cpe_app env fun [] _ = cpeRhsE env fun - - -- N-variable fun, better let-bind it - cpe_app env fun args depth - = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty - -- The evalDmd says that it's sure to be evaluated, - -- so we'll end up case-binding it - ; (app, floats) <- rebuild_app args fun' ty fun_floats [] - ; mb_saturate Nothing app floats depth } - where - ty = exprType fun - - -- Saturate if necessary - mb_saturate head app floats depth = - case head of - Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth - ; return (floats, sat_app) } - _other -> return (floats, app) - - -- Deconstruct and rebuild the application, floating any non-atomic - -- arguments to the outside. We collect the type of the expression, - -- the head of the application, and the number of actual value arguments, - -- all of which are used to possibly saturate this application if it - -- has a constructor or primop at the head. - rebuild_app - :: [ArgInfo] -- The arguments (inner to outer) - -> CpeApp - -> Type - -> Floats - -> [Demand] - -> UniqSM (CpeApp, Floats) - rebuild_app [] app _ floats ss = do - MASSERT(null ss) -- make sure we used all the strictness info - return (app, floats) - rebuild_app (a : as) fun' fun_ty floats ss = case a of - CpeApp arg@(Type arg_ty) -> - rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss - CpeApp arg@(Coercion {}) -> - rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss - CpeApp arg -> do - let (ss1, ss_rest) -- See Note [lazyId magic] in MkId - = case (ss, isLazyExpr arg) of - (_ : ss_rest, True) -> (topDmd, ss_rest) - (ss1 : ss_rest, False) -> (ss1, ss_rest) - ([], _) -> (topDmd, []) - (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $ - splitFunTy_maybe fun_ty - (fs, arg') <- cpeArg top_env ss1 arg arg_ty - rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest - CpeCast co -> - let Pair _ty1 ty2 = coercionKind co - in rebuild_app as (Cast fun' co) ty2 floats ss - CpeTick tickish -> - -- See [Floating Ticks in CorePrep] - rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss - -isLazyExpr :: CoreExpr -> Bool --- See Note [lazyId magic] in MkId -isLazyExpr (Cast e _) = isLazyExpr e -isLazyExpr (Tick _ e) = isLazyExpr e -isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey -isLazyExpr _ = False - --- --------------------------------------------------------------------------- --- CpeArg: produces a result satisfying CpeArg --- --------------------------------------------------------------------------- - -{- -Note [ANF-ising literal string arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider a program like, - - data Foo = Foo Addr# - - foo = Foo "turtle"# - -When we go to ANFise this we might think that we want to float the string -literal like we do any other non-trivial argument. This would look like, - - foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s } - -However, this 1) isn't necessary since strings are in a sense "trivial"; and 2) -wreaks havoc on the CAF annotations that we produce here since we the result -above is caffy since it is updateable. Ideally at some point in the future we -would like to just float the literal to the top level as suggested in #11312, - - s = "turtle"# - foo = Foo s - -However, until then we simply add a special case excluding literals from the -floating done by cpeArg. --} - --- | Is an argument okay to CPE? -okCpeArg :: CoreExpr -> Bool --- Don't float literals. See Note [ANF-ising literal string arguments]. -okCpeArg (Lit _) = False --- Do not eta expand a trivial argument -okCpeArg expr = not (exprIsTrivial expr) - --- This is where we arrange that a non-trivial argument is let-bound -cpeArg :: CorePrepEnv -> Demand - -> CoreArg -> Type -> UniqSM (Floats, CpeArg) -cpeArg env dmd arg arg_ty - = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda - ; (floats2, arg2) <- if want_float floats1 arg1 - then return (floats1, arg1) - else dontFloat floats1 arg1 - -- Else case: arg1 might have lambdas, and we can't - -- put them inside a wrapBinds - - ; if okCpeArg arg2 - then do { v <- newVar arg_ty - ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 - arg_float = mkFloat dmd is_unlifted v arg3 - ; return (addFloat floats2 arg_float, varToCoreExpr v) } - else return (floats2, arg2) - } - where - is_unlifted = isUnliftedType arg_ty - want_float = wantFloatNested NonRecursive dmd is_unlifted - -{- -Note [Floating unlifted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider C (let v* = expensive in v) - -where the "*" indicates "will be demanded". Usually v will have been -inlined by now, but let's suppose it hasn't (see Trac #2756). Then we -do *not* want to get - - let v* = expensive in C v - -because that has different strictness. Hence the use of 'allLazy'. -(NB: the let v* turns into a FloatCase, in mkLocalNonRec.) - - ------------------------------------------------------------------------------- --- Building the saturated syntax --- --------------------------------------------------------------------------- - -maybeSaturate deals with saturating primops and constructors -The type is the type of the entire application --} - -maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs -maybeSaturate fn expr n_args - | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg - -- A gruesome special case - = saturateDataToTag sat_expr - - | hasNoBinding fn -- There's no binding - = return sat_expr - - | otherwise - = return expr - where - fn_arity = idArity fn - excess_arity = fn_arity - n_args - sat_expr = cpeEtaExpand excess_arity expr - -------------- -saturateDataToTag :: CpeApp -> UniqSM CpeApp --- See Note [dataToTag magic] -saturateDataToTag sat_expr - = do { let (eta_bndrs, eta_body) = collectBinders sat_expr - ; eta_body' <- eval_data2tag_arg eta_body - ; return (mkLams eta_bndrs eta_body') } - where - eval_data2tag_arg :: CpeApp -> UniqSM CpeBody - eval_data2tag_arg app@(fun `App` arg) - | exprIsHNF arg -- Includes nullary constructors - = return app -- The arg is evaluated - | otherwise -- Arg not evaluated, so evaluate it - = do { arg_id <- newVar (exprType arg) - ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding - ; return (Case arg arg_id1 (exprType app) - [(DEFAULT, [], fun `App` Var arg_id1)]) } - - eval_data2tag_arg (Tick t app) -- Scc notes can appear - = do { app' <- eval_data2tag_arg app - ; return (Tick t app') } - - eval_data2tag_arg other -- Should not happen - = pprPanic "eval_data2tag" (ppr other) - -{- -Note [dataToTag magic] -~~~~~~~~~~~~~~~~~~~~~~ -Horrid: we must ensure that the arg of data2TagOp is evaluated - (data2tag x) --> (case x of y -> data2tag y) -(yuk yuk) take into account the lambdas we've now introduced - -How might it not be evaluated? Well, we might have floated it out -of the scope of a `seq`, or dropped the `seq` altogether. - - -************************************************************************ -* * - Simple CoreSyn operations -* * -************************************************************************ --} - -{- --- ----------------------------------------------------------------------------- --- Eta reduction --- ----------------------------------------------------------------------------- - -Note [Eta expansion] -~~~~~~~~~~~~~~~~~~~~~ -Eta expand to match the arity claimed by the binder Remember, -CorePrep must not change arity - -Eta expansion might not have happened already, because it is done by -the simplifier only when there at least one lambda already. - -NB1:we could refrain when the RHS is trivial (which can happen - for exported things). This would reduce the amount of code - generated (a little) and make things a little words for - code compiled without -O. The case in point is data constructor - wrappers. - -NB2: we have to be careful that the result of etaExpand doesn't - invalidate any of the assumptions that CorePrep is attempting - to establish. One possible cause is eta expanding inside of - an SCC note - we're now careful in etaExpand to make sure the - SCC is pushed inside any new lambdas that are generated. - -Note [Eta expansion and the CorePrep invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It turns out to be much much easier to do eta expansion -*after* the main CorePrep stuff. But that places constraints -on the eta expander: given a CpeRhs, it must return a CpeRhs. - -For example here is what we do not want: - f = /\a -> g (h 3) -- h has arity 2 -After ANFing we get - f = /\a -> let s = h 3 in g s -and now we do NOT want eta expansion to give - f = /\a -> \ y -> (let s = h 3 in g s) y - -Instead CoreArity.etaExpand gives - f = /\a -> \y -> let s = h 3 in g s y --} - -cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs -cpeEtaExpand arity expr - | arity == 0 = expr - | otherwise = etaExpand arity expr - -{- --- ----------------------------------------------------------------------------- --- Eta reduction --- ----------------------------------------------------------------------------- - -Why try eta reduction? Hasn't the simplifier already done eta? -But the simplifier only eta reduces if that leaves something -trivial (like f, or f Int). But for deLam it would be enough to -get to a partial application: - case x of { p -> \xs. map f xs } - ==> case x of { p -> map f } --} - -tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr -tryEtaReducePrep bndrs expr@(App _ _) - | ok_to_eta_reduce f - , n_remaining >= 0 - , and (zipWith ok bndrs last_args) - , not (any (`elemVarSet` fvs_remaining) bndrs) - , exprIsHNF remaining_expr -- Don't turn value into a non-value - -- else the behaviour with 'seq' changes - = Just remaining_expr - where - (f, args) = collectArgs expr - remaining_expr = mkApps f remaining_args - fvs_remaining = exprFreeVars remaining_expr - (remaining_args, last_args) = splitAt n_remaining args - n_remaining = length args - length bndrs - - ok bndr (Var arg) = bndr == arg - ok _ _ = False - - -- We can't eta reduce something which must be saturated. - ok_to_eta_reduce (Var f) = not (hasNoBinding f) - ok_to_eta_reduce _ = False -- Safe. ToDo: generalise - -tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) - | not (any (`elemVarSet` fvs) bndrs) - = case tryEtaReducePrep bndrs body of - Just e -> Just (Let bind e) - Nothing -> Nothing - where - fvs = exprFreeVars r - --- NB: do not attempt to eta-reduce across ticks --- Otherwise we risk reducing --- \x. (Tick (Breakpoint {x}) f x) --- ==> Tick (breakpoint {x}) f --- which is bogus (Trac #17228) --- tryEtaReducePrep bndrs (Tick tickish e) --- = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e - -tryEtaReducePrep _ _ = Nothing - -{- -************************************************************************ -* * - Floats -* * -************************************************************************ - -Note [Pin demand info on floats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pin demand info on floated lets, so that we can see the one-shot thunks. --} - -data FloatingBind - = FloatLet CoreBind -- Rhs of bindings are CpeRhss - -- They are always of lifted type; - -- unlifted ones are done with FloatCase - - | FloatCase - Id CpeBody - Bool -- The bool indicates "ok-for-speculation" - - -- | See Note [Floating Ticks in CorePrep] - | FloatTick (Tickish Id) - -data Floats = Floats OkToSpec (OrdList FloatingBind) - -instance Outputable FloatingBind where - ppr (FloatLet b) = ppr b - ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r - ppr (FloatTick t) = ppr t - -instance Outputable Floats where - ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+> - braces (vcat (map ppr (fromOL fs))) - -instance Outputable OkToSpec where - ppr OkToSpec = text "OkToSpec" - ppr IfUnboxedOk = text "IfUnboxedOk" - ppr NotOkToSpec = text "NotOkToSpec" - --- Can we float these binds out of the rhs of a let? We cache this decision --- to avoid having to recompute it in a non-linear way when there are --- deeply nested lets. -data OkToSpec - = OkToSpec -- Lazy bindings of lifted type - | IfUnboxedOk -- A mixture of lazy lifted bindings and n - -- ok-to-speculate unlifted bindings - | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings - -mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind -mkFloat dmd is_unlifted bndr rhs - | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs) - | is_hnf = FloatLet (NonRec bndr rhs) - | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) - -- See Note [Pin demand info on floats] - where - is_hnf = exprIsHNF rhs - is_strict = isStrictDmd dmd - use_case = is_unlifted || is_strict && not is_hnf - -- Don't make a case for a value binding, - -- even if it's strict. Otherwise we get - -- case (\x -> e) of ...! - -emptyFloats :: Floats -emptyFloats = Floats OkToSpec nilOL - -isEmptyFloats :: Floats -> Bool -isEmptyFloats (Floats _ bs) = isNilOL bs - -wrapBinds :: Floats -> CpeBody -> CpeBody -wrapBinds (Floats _ binds) body - = foldrOL mk_bind body binds - where - mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] - mk_bind (FloatLet bind) body = Let bind body - mk_bind (FloatTick tickish) body = mkTick tickish body - -addFloat :: Floats -> FloatingBind -> Floats -addFloat (Floats ok_to_spec floats) new_float - = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) - where - check (FloatLet _) = OkToSpec - check (FloatCase _ _ ok_for_spec) - | ok_for_spec = IfUnboxedOk - | otherwise = NotOkToSpec - check FloatTick{} = OkToSpec - -- The ok-for-speculation flag says that it's safe to - -- float this Case out of a let, and thereby do it more eagerly - -- We need the top-level flag because it's never ok to float - -- an unboxed binding to the top level - -unitFloat :: FloatingBind -> Floats -unitFloat = addFloat emptyFloats - -appendFloats :: Floats -> Floats -> Floats -appendFloats (Floats spec1 floats1) (Floats spec2 floats2) - = Floats (combine spec1 spec2) (floats1 `appOL` floats2) - -concatFloats :: [Floats] -> OrdList FloatingBind -concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL - -combine :: OkToSpec -> OkToSpec -> OkToSpec -combine NotOkToSpec _ = NotOkToSpec -combine _ NotOkToSpec = NotOkToSpec -combine IfUnboxedOk _ = IfUnboxedOk -combine _ IfUnboxedOk = IfUnboxedOk -combine _ _ = OkToSpec - -deFloatTop :: Floats -> [CoreBind] --- For top level only; we don't expect any FloatCases -deFloatTop (Floats _ floats) - = foldrOL get [] floats - where - get (FloatLet b) bs = occurAnalyseRHSs b : bs - get (FloatCase var body _) bs = - occurAnalyseRHSs (NonRec var body) : bs - get b _ = pprPanic "corePrepPgm" (ppr b) - - -- See Note [Dead code in CorePrep] - occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e) - occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes] - ---------------------------------------------------------------------------- - -canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs) - -- Note [CafInfo and floating] -canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs - | OkToSpec <- ok_to_spec -- Worth trying - , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) - = Just (Floats OkToSpec fs', subst_expr subst rhs) - | otherwise - = Nothing - where - subst_expr = substExpr (text "CorePrep") - - go :: (Subst, OrdList FloatingBind) -> [FloatingBind] - -> Maybe (Subst, OrdList FloatingBind) - - go (subst, fbs_out) [] = Just (subst, fbs_out) - - go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) - | rhs_ok r - = go (subst', fbs_out `snocOL` new_fb) fbs_in - where - (subst', b') = set_nocaf_bndr subst b - new_fb = FloatLet (NonRec b' (subst_expr subst r)) - - go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in) - | all rhs_ok rs - = go (subst', fbs_out `snocOL` new_fb) fbs_in - where - (bs,rs) = unzip prs - (subst', bs') = mapAccumL set_nocaf_bndr subst bs - rs' = map (subst_expr subst') rs - new_fb = FloatLet (Rec (bs' `zip` rs')) - - go (subst, fbs_out) (ft@FloatTick{} : fbs_in) - = go (subst, fbs_out `snocOL` ft) fbs_in - - go _ _ = Nothing -- Encountered a caffy binding - - ------------ - set_nocaf_bndr subst bndr - = (extendIdSubst subst bndr (Var bndr'), bndr') - where - bndr' = bndr `setIdCafInfo` NoCafRefs - - ------------ - rhs_ok :: CoreExpr -> Bool - -- We can only float to top level from a NoCaf thing if - -- the new binding is static. However it can't mention - -- any non-static things or it would *already* be Caffy - rhs_ok = rhsIsStatic platform (\_ -> False) - (\i -> pprPanic "rhsIsStatic" (integer i)) - -- Integer literals should not show up - -wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool -wantFloatNested is_rec dmd is_unlifted floats rhs - = isEmptyFloats floats - || isStrictDmd dmd - || is_unlifted - || (allLazyNested is_rec floats && exprIsHNF rhs) - -- Why the test for allLazyNested? - -- v = f (x `divInt#` y) - -- we don't want to float the case, even if f has arity 2, - -- because floating the case would make it evaluated too early - -allLazyTop :: Floats -> Bool -allLazyTop (Floats OkToSpec _) = True -allLazyTop _ = False - -allLazyNested :: RecFlag -> Floats -> Bool -allLazyNested _ (Floats OkToSpec _) = True -allLazyNested _ (Floats NotOkToSpec _) = False -allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec - -{- -************************************************************************ -* * - Cloning -* * -************************************************************************ --} - --- --------------------------------------------------------------------------- --- The environment --- --------------------------------------------------------------------------- - --- Note [Inlining in CorePrep] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- There is a subtle but important invariant that must be upheld in the output --- of CorePrep: there are no "trivial" updatable thunks. Thus, this Core --- is impermissible: --- --- let x :: () --- x = y --- --- (where y is a reference to a GLOBAL variable). Thunks like this are silly: --- they can always be profitably replaced by inlining x with y. Consequently, --- the code generator/runtime does not bother implementing this properly --- (specifically, there is no implementation of stg_ap_0_upd_info, which is the --- stack frame that would be used to update this thunk. The "0" means it has --- zero free variables.) --- --- In general, the inliner is good at eliminating these let-bindings. However, --- there is one case where these trivial updatable thunks can arise: when --- we are optimizing away 'lazy' (see Note [lazyId magic], and also --- 'cpeRhsE'.) Then, we could have started with: --- --- let x :: () --- x = lazy @ () y --- --- which is a perfectly fine, non-trivial thunk, but then CorePrep will --- drop 'lazy', giving us 'x = y' which is trivial and impermissible. --- The solution is CorePrep to have a miniature inlining pass which deals --- with cases like this. We can then drop the let-binding altogether. --- --- Why does the removal of 'lazy' have to occur in CorePrep? --- The gory details are in Note [lazyId magic] in MkId, but the --- main reason is that lazy must appear in unfoldings (optimizer --- output) and it must prevent call-by-value for catch# (which --- is implemented by CorePrep.) --- --- An alternate strategy for solving this problem is to have the --- inliner treat 'lazy e' as a trivial expression if 'e' is trivial. --- We decided not to adopt this solution to keep the definition --- of 'exprIsTrivial' simple. --- --- There is ONE caveat however: for top-level bindings we have --- to preserve the binding so that we float the (hacky) non-recursive --- binding for data constructors; see Note [Data constructor workers]. --- --- Note [CorePrep inlines trivial CoreExpr not Id] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an --- IdEnv Id? Naively, we might conjecture that trivial updatable thunks --- as per Note [Inlining in CorePrep] always have the form --- 'lazy @ SomeType gbl_id'. But this is not true: the following is --- perfectly reasonable Core: --- --- let x :: () --- x = lazy @ (forall a. a) y @ Bool --- --- When we inline 'x' after eliminating 'lazy', we need to replace --- occurrences of 'x' with 'y @ bool', not just 'y'. Situations like --- this can easily arise with higher-rank types; thus, cpe_env must --- map to CoreExprs, not Ids. - -data CorePrepEnv - = CPE { cpe_dynFlags :: DynFlags - , cpe_env :: IdEnv CoreExpr -- Clone local Ids - -- ^ This environment is used for three operations: - -- - -- 1. To support cloning of local Ids so that they are - -- all unique (see item (6) of CorePrep overview). - -- - -- 2. To support beta-reduction of runRW, see - -- Note [runRW magic] and Note [runRW arg]. - -- - -- 3. To let us inline trivial RHSs of non top-level let-bindings, - -- see Note [lazyId magic], Note [Inlining in CorePrep] - -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076) - , cpe_mkIntegerId :: Id - , cpe_integerSDataCon :: Maybe DataCon - } - -lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id -lookupMkIntegerName dflags hsc_env - = guardIntegerUse dflags $ liftM tyThingId $ - lookupGlobal hsc_env mkIntegerName - -lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon) -lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of - IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $ - lookupGlobal hsc_env integerSDataConName - IntegerSimple -> return Nothing - --- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName' -guardIntegerUse :: DynFlags -> IO a -> IO a -guardIntegerUse dflags act - | thisPackage dflags == primUnitId - = return $ panic "Can't use Integer in ghc-prim" - | thisPackage dflags == integerUnitId - = return $ panic "Can't use Integer in integer-*" - | otherwise = act - -mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv -mkInitialCorePrepEnv dflags hsc_env - = do mkIntegerId <- lookupMkIntegerName dflags hsc_env - integerSDataCon <- lookupIntegerSDataConName dflags hsc_env - return $ CPE { - cpe_dynFlags = dflags, - cpe_env = emptyVarEnv, - cpe_mkIntegerId = mkIntegerId, - cpe_integerSDataCon = integerSDataCon - } - -extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv -extendCorePrepEnv cpe id id' - = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') } - -extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv -extendCorePrepEnvExpr cpe id expr - = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr } - -extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv -extendCorePrepEnvList cpe prs - = cpe { cpe_env = extendVarEnvList (cpe_env cpe) - (map (\(id, id') -> (id, Var id')) prs) } - -lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr -lookupCorePrepEnv cpe id - = case lookupVarEnv (cpe_env cpe) id of - Nothing -> Var id - Just exp -> exp - -getMkIntegerId :: CorePrepEnv -> Id -getMkIntegerId = cpe_mkIntegerId - ------------------------------------------------------------------------------- --- Cloning binders --- --------------------------------------------------------------------------- - -cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var]) -cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs - -cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) -cpCloneBndr env bndr - | isLocalId bndr, not (isCoVar bndr) - = do bndr' <- setVarUnique bndr <$> getUniqueM - - -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings - -- so that we can drop more stuff as dead code. - -- See also Note [Dead code in CorePrep] - let bndr'' = bndr' `setIdUnfolding` noUnfolding - `setIdSpecialisation` emptyRuleInfo - return (extendCorePrepEnv env bndr bndr'', bndr'') - - | otherwise -- Top level things, which we don't want - -- to clone, have become GlobalIds by now - -- And we don't clone tyvars, or coercion variables - = return (env, bndr) - - ------------------------------------------------------------------------------- --- Cloning ccall Ids; each must have a unique name, --- to give the code generator a handle to hang it on --- --------------------------------------------------------------------------- - -fiddleCCall :: Id -> UniqSM Id -fiddleCCall id - | isFCallId id = (id `setVarUnique`) <$> getUniqueM - | otherwise = return id - ------------------------------------------------------------------------------- --- Generating new binders --- --------------------------------------------------------------------------- - -newVar :: Type -> UniqSM Id -newVar ty - = seqType ty `seq` do - uniq <- getUniqueM - return (mkSysLocalOrCoVar (fsLit "sat") uniq ty) - - ------------------------------------------------------------------------------- --- Floating ticks --- --------------------------------------------------------------------------- --- --- Note [Floating Ticks in CorePrep] --- --- It might seem counter-intuitive to float ticks by default, given --- that we don't actually want to move them if we can help it. On the --- other hand, nothing gets very far in CorePrep anyway, and we want --- to preserve the order of let bindings and tick annotations in --- relation to each other. For example, if we just wrapped let floats --- when they pass through ticks, we might end up performing the --- following transformation: --- --- src<...> let foo = bar in baz --- ==> let foo = src<...> bar in src<...> baz --- --- Because the let-binding would float through the tick, and then --- immediately materialize, achieving nothing but decreasing tick --- accuracy. The only special case is the following scenario: --- --- let foo = src<...> (let a = b in bar) in baz --- ==> let foo = src<...> bar; a = src<...> b in baz --- --- Here we would not want the source tick to end up covering "baz" and --- therefore refrain from pushing ticks outside. Instead, we copy them --- into the floating binds (here "a") in cpePair. Note that where "b" --- or "bar" are (value) lambdas we have to push the annotations --- further inside in order to uphold our rules. --- --- All of this is implemented below in @wrapTicks@. - --- | Like wrapFloats, but only wraps tick floats -wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr) -wrapTicks (Floats flag floats0) expr = - (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1)) - where (floats1, ticks1) = foldlOL go ([], []) $ floats0 - -- Deeply nested constructors will produce long lists of - -- redundant source note floats here. We need to eliminate - -- those early, as relying on mkTick to spot it after the fact - -- can yield O(n^3) complexity [#11095] - go (floats, ticks) (FloatTick t) - = ASSERT(tickishPlace t == PlaceNonLam) - (floats, if any (flip tickishContains t) ticks - then ticks else t:ticks) - go (floats, ticks) f - = (foldr wrap f (reverse ticks):floats, ticks) - - wrap t (FloatLet bind) = FloatLet (wrapBind t bind) - wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok - wrap _ other = pprPanic "wrapTicks: unexpected float!" - (ppr other) - wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) - wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) diff --git a/coreSyn/CoreSeq.hs b/coreSyn/CoreSeq.hs deleted file mode 100644 --- a/coreSyn/CoreSeq.hs +++ /dev/null @@ -1,111 +0,0 @@ --- | --- Various utilities for forcing Core structures --- --- It can often be useful to force various parts of the AST. This module --- provides a number of @seq@-like functions to accomplish this. - -module CoreSeq ( - -- * Utilities for forcing Core structures - seqExpr, seqExprs, seqUnfolding, seqRules, - megaSeqIdInfo, seqRuleInfo, seqBinds, - ) where - -import CoreSyn -import IdInfo -import Demand( seqDemand, seqStrictSig ) -import BasicTypes( seqOccInfo ) -import VarSet( seqDVarSet ) -import Var( varType, tyVarKind ) -import Type( seqType, isTyVar ) -import Coercion( seqCo ) -import Id( Id, idInfo ) - --- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the --- compiler -megaSeqIdInfo :: IdInfo -> () -megaSeqIdInfo info - = seqRuleInfo (ruleInfo info) `seq` - --- Omitting this improves runtimes a little, presumably because --- some unfoldings are not calculated at all --- seqUnfolding (unfoldingInfo info) `seq` - - seqDemand (demandInfo info) `seq` - seqStrictSig (strictnessInfo info) `seq` - seqCaf (cafInfo info) `seq` - seqOneShot (oneShotInfo info) `seq` - seqOccInfo (occInfo info) - -seqOneShot :: OneShotInfo -> () -seqOneShot l = l `seq` () - -seqRuleInfo :: RuleInfo -> () -seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqDVarSet fvs - -seqCaf :: CafInfo -> () -seqCaf c = c `seq` () - -seqRules :: [CoreRule] -> () -seqRules [] = () -seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) - = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules -seqRules (BuiltinRule {} : rules) = seqRules rules - -seqExpr :: CoreExpr -> () -seqExpr (Var v) = v `seq` () -seqExpr (Lit lit) = lit `seq` () -seqExpr (App f a) = seqExpr f `seq` seqExpr a -seqExpr (Lam b e) = seqBndr b `seq` seqExpr e -seqExpr (Let b e) = seqBind b `seq` seqExpr e -seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as -seqExpr (Cast e co) = seqExpr e `seq` seqCo co -seqExpr (Tick n e) = seqTickish n `seq` seqExpr e -seqExpr (Type t) = seqType t -seqExpr (Coercion co) = seqCo co - -seqExprs :: [CoreExpr] -> () -seqExprs [] = () -seqExprs (e:es) = seqExpr e `seq` seqExprs es - -seqTickish :: Tickish Id -> () -seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () -seqTickish HpcTick{} = () -seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids -seqTickish SourceNote{} = () - -seqBndr :: CoreBndr -> () -seqBndr b | isTyVar b = seqType (tyVarKind b) - | otherwise = seqType (varType b) `seq` - megaSeqIdInfo (idInfo b) - -seqBndrs :: [CoreBndr] -> () -seqBndrs [] = () -seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs - -seqBinds :: [Bind CoreBndr] -> () -seqBinds bs = foldr (seq . seqBind) () bs - -seqBind :: Bind CoreBndr -> () -seqBind (NonRec b e) = seqBndr b `seq` seqExpr e -seqBind (Rec prs) = seqPairs prs - -seqPairs :: [(CoreBndr, CoreExpr)] -> () -seqPairs [] = () -seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs - -seqAlts :: [CoreAlt] -> () -seqAlts [] = () -seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts - -seqUnfolding :: Unfolding -> () -seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, - uf_is_value = b1, uf_is_work_free = b2, - uf_expandable = b3, uf_is_conlike = b4, - uf_guidance = g}) - = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g - -seqUnfolding _ = () - -seqGuidance :: UnfoldingGuidance -> () -seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () -seqGuidance _ = () diff --git a/coreSyn/CoreStats.hs b/coreSyn/CoreStats.hs deleted file mode 100644 --- a/coreSyn/CoreStats.hs +++ /dev/null @@ -1,141 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-2015 --} - --- | Functions to computing the statistics reflective of the "size" --- of a Core expression -module CoreStats ( - -- * Expression and bindings size - coreBindsSize, exprSize, - CoreStats(..), coreBindsStats, exprStats, - ) where - -import BasicTypes -import CoreSyn -import Outputable -import Coercion -import Var -import Type (Type, typeSize, seqType) -import Id (idType, isJoinId) -import CoreSeq (megaSeqIdInfo) - -data CoreStats = CS { cs_tm :: Int -- Terms - , cs_ty :: Int -- Types - , cs_co :: Int -- Coercions - , cs_vb :: Int -- Local value bindings - , cs_jb :: Int } -- Local join bindings - - -instance Outputable CoreStats where - ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3, cs_vb = i4, cs_jb = i5 }) - = braces (sep [text "terms:" <+> intWithCommas i1 <> comma, - text "types:" <+> intWithCommas i2 <> comma, - text "coercions:" <+> intWithCommas i3 <> comma, - text "joins:" <+> intWithCommas i5 <> char '/' <> - intWithCommas (i4 + i5) ]) - -plusCS :: CoreStats -> CoreStats -> CoreStats -plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1, cs_vb = v1, cs_jb = j1 }) - (CS { cs_tm = p2, cs_ty = q2, cs_co = r2, cs_vb = v2, cs_jb = j2 }) - = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2, cs_vb = v1+v2 - , cs_jb = j1+j2 } - -zeroCS, oneTM :: CoreStats -zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0, cs_vb = 0, cs_jb = 0 } -oneTM = zeroCS { cs_tm = 1 } - -sumCS :: (a -> CoreStats) -> [a] -> CoreStats -sumCS f = foldr (plusCS . f) zeroCS - -coreBindsStats :: [CoreBind] -> CoreStats -coreBindsStats = sumCS (bindStats TopLevel) - -bindStats :: TopLevelFlag -> CoreBind -> CoreStats -bindStats top_lvl (NonRec v r) = bindingStats top_lvl v r -bindStats top_lvl (Rec prs) = sumCS (\(v,r) -> bindingStats top_lvl v r) prs - -bindingStats :: TopLevelFlag -> Var -> CoreExpr -> CoreStats -bindingStats top_lvl v r = letBndrStats top_lvl v `plusCS` exprStats r - -bndrStats :: Var -> CoreStats -bndrStats v = oneTM `plusCS` tyStats (varType v) - -letBndrStats :: TopLevelFlag -> Var -> CoreStats -letBndrStats top_lvl v - | isTyVar v || isTopLevel top_lvl = bndrStats v - | isJoinId v = oneTM { cs_jb = 1 } `plusCS` ty_stats - | otherwise = oneTM { cs_vb = 1 } `plusCS` ty_stats - where - ty_stats = tyStats (varType v) - -exprStats :: CoreExpr -> CoreStats -exprStats (Var {}) = oneTM -exprStats (Lit {}) = oneTM -exprStats (Type t) = tyStats t -exprStats (Coercion c) = coStats c -exprStats (App f a) = exprStats f `plusCS` exprStats a -exprStats (Lam b e) = bndrStats b `plusCS` exprStats e -exprStats (Let b e) = bindStats NotTopLevel b `plusCS` exprStats e -exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b - `plusCS` sumCS altStats as -exprStats (Cast e co) = coStats co `plusCS` exprStats e -exprStats (Tick _ e) = exprStats e - -altStats :: CoreAlt -> CoreStats -altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r - -altBndrStats :: [Var] -> CoreStats --- Charge one for the alternative, not for each binder -altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs - -tyStats :: Type -> CoreStats -tyStats ty = zeroCS { cs_ty = typeSize ty } - -coStats :: Coercion -> CoreStats -coStats co = zeroCS { cs_co = coercionSize co } - -coreBindsSize :: [CoreBind] -> Int --- We use coreBindStats for user printout --- but this one is a quick and dirty basis for --- the simplifier's tick limit -coreBindsSize bs = foldr ((+) . bindSize) 0 bs - -exprSize :: CoreExpr -> Int --- ^ A measure of the size of the expressions, strictly greater than 0 --- It also forces the expression pretty drastically as a side effect --- Counts *leaves*, not internal nodes. Types and coercions are not counted. -exprSize (Var v) = v `seq` 1 -exprSize (Lit lit) = lit `seq` 1 -exprSize (App f a) = exprSize f + exprSize a -exprSize (Lam b e) = bndrSize b + exprSize e -exprSize (Let b e) = bindSize b + exprSize e -exprSize (Case e b t as) = seqType t `seq` - exprSize e + bndrSize b + 1 + foldr ((+) . altSize) 0 as -exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e -exprSize (Tick n e) = tickSize n + exprSize e -exprSize (Type t) = seqType t `seq` 1 -exprSize (Coercion co) = seqCo co `seq` 1 - -tickSize :: Tickish Id -> Int -tickSize (ProfNote cc _ _) = cc `seq` 1 -tickSize _ = 1 -- the rest are strict - -bndrSize :: Var -> Int -bndrSize b | isTyVar b = seqType (tyVarKind b) `seq` 1 - | otherwise = seqType (idType b) `seq` - megaSeqIdInfo (idInfo b) `seq` - 1 - -bndrsSize :: [Var] -> Int -bndrsSize = sum . map bndrSize - -bindSize :: CoreBind -> Int -bindSize (NonRec b e) = bndrSize b + exprSize e -bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs - -pairSize :: (Var, CoreExpr) -> Int -pairSize (b,e) = bndrSize b + exprSize e - -altSize :: CoreAlt -> Int -altSize (c,bs,e) = c `seq` bndrsSize bs + exprSize e diff --git a/coreSyn/CoreSubst.hs b/coreSyn/CoreSubst.hs deleted file mode 100644 --- a/coreSyn/CoreSubst.hs +++ /dev/null @@ -1,762 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Utility functions on @Core@ syntax --} - -{-# LANGUAGE CPP #-} -module CoreSubst ( - -- * Main data types - Subst(..), -- Implementation exported for supercompiler's Renaming.hs only - TvSubstEnv, IdSubstEnv, InScopeSet, - - -- ** Substituting into expressions and related types - deShadowBinds, substSpec, substRulesForImportedIds, - substTy, substCo, substExpr, substExprSC, substBind, substBindSC, - substUnfolding, substUnfoldingSC, - lookupIdSubst, lookupTCvSubst, substIdOcc, - substTickish, substDVarSet, substIdInfo, - - -- ** Operations on substitutions - emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, - extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, - extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, - addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, - isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, - delBndr, delBndrs, - - -- ** Substituting and cloning binders - substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, - cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, - - ) where - -#include "HsVersions.h" - - -import CoreSyn -import CoreFVs -import CoreSeq -import CoreUtils -import qualified Type -import qualified Coercion - - -- We are defining local versions -import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import Coercion hiding ( substCo, substCoVarBndr ) - -import PrelNames -import VarSet -import VarEnv -import Id -import Name ( Name ) -import Var -import IdInfo -import UniqSupply -import Maybes -import Util -import Outputable -import PprCore () -- Instances -import Data.List - - - -{- -************************************************************************ -* * -\subsection{Substitutions} -* * -************************************************************************ --} - --- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar' --- substitutions. --- --- Some invariants apply to how you use the substitution: --- --- 1. #in_scope_invariant# The in-scope set contains at least those 'Id's and 'TyVar's that will be in scope /after/ --- applying the substitution to a term. Precisely, the in-scope set must be a superset of the free vars of the --- substitution range that might possibly clash with locally-bound variables in the thing being substituted in. --- --- 2. #apply_once# You may apply the substitution only /once/ --- --- There are various ways of setting up the in-scope set such that the first of these invariants hold: --- --- * Arrange that the in-scope set really is all the things in scope --- --- * Arrange that it's the free vars of the range of the substitution --- --- * Make it empty, if you know that all the free vars of the substitution are fresh, and hence can't possibly clash -data Subst - = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ - -- applying the substitution - IdSubstEnv -- Substitution from NcIds to CoreExprs - TvSubstEnv -- Substitution from TyVars to Types - CvSubstEnv -- Substitution from CoVars to Coercions - - -- INVARIANT 1: See #in_scope_invariant# - -- This is what lets us deal with name capture properly - -- It's a hard invariant to check... - -- - -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with - -- Types.TvSubstEnv - -- - -- INVARIANT 3: See Note [Extending the Subst] - -{- -Note [Extending the Subst] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a core Subst, which binds Ids as well, we make a different choice for Ids -than we do for TyVars. - -For TyVars, see Note [Extending the TCvSubst] with Type.TvSubstEnv - -For Ids, we have a different invariant - The IdSubstEnv is extended *only* when the Unique on an Id changes - Otherwise, we just extend the InScopeSet - -In consequence: - -* If all subst envs are empty, substExpr would be a - no-op, so substExprSC ("short cut") does nothing. - - However, substExpr still goes ahead and substitutes. Reason: we may - want to replace existing Ids with new ones from the in-scope set, to - avoid space leaks. - -* In substIdBndr, we extend the IdSubstEnv only when the unique changes - -* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty, - substExpr does nothing (Note that the above rule for substIdBndr - maintains this property. If the incoming envts are both empty, then - substituting the type and IdInfo can't change anything.) - -* In lookupIdSubst, we *must* look up the Id in the in-scope set, because - it may contain non-trivial changes. Example: - (/\a. \x:a. ...x...) Int - We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change - so we only extend the in-scope set. Then we must look up in the in-scope - set when we find the occurrence of x. - -* The requirement to look up the Id in the in-scope set means that we - must NOT take no-op short cut when the IdSubst is empty. - We must still look up every Id in the in-scope set. - -* (However, we don't need to do so for expressions found in the IdSubst - itself, whose range is assumed to be correct wrt the in-scope set.) - -Why do we make a different choice for the IdSubstEnv than the -TvSubstEnv and CvSubstEnv? - -* For Ids, we change the IdInfo all the time (e.g. deleting the - unfolding), and adding it back later, so using the TyVar convention - would entail extending the substitution almost all the time - -* The simplifier wants to look up in the in-scope set anyway, in case it - can see a better unfolding from an enclosing case expression - -* For TyVars, only coercion variables can possibly change, and they are - easy to spot --} - --- | An environment for substituting for 'Id's -type IdSubstEnv = IdEnv CoreExpr -- Domain is NcIds, i.e. not coercions - ----------------------------- -isEmptySubst :: Subst -> Bool -isEmptySubst (Subst _ id_env tv_env cv_env) - = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env - -emptySubst :: Subst -emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv - -mkEmptySubst :: InScopeSet -> Subst -mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv - -mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst -mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs - --- | Find the in-scope set: see "CoreSubst#in_scope_invariant" -substInScope :: Subst -> InScopeSet -substInScope (Subst in_scope _ _ _) = in_scope - --- | Remove all substitutions for 'Id's and 'Var's that might have been built up --- while preserving the in-scope set -zapSubstEnv :: Subst -> Subst -zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv - --- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is --- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this -extendIdSubst :: Subst -> Id -> CoreExpr -> Subst --- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set -extendIdSubst (Subst in_scope ids tvs cvs) v r - = ASSERT2( isNonCoVarId v, ppr v $$ ppr r ) - Subst in_scope (extendVarEnv ids v r) tvs cvs - --- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' -extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst -extendIdSubstList (Subst in_scope ids tvs cvs) prs - = ASSERT( all (isNonCoVarId . fst) prs ) - Subst in_scope (extendVarEnvList ids prs) tvs cvs - --- | Add a substitution for a 'TyVar' to the 'Subst' --- The 'TyVar' *must* be a real TyVar, and not a CoVar --- You must ensure that the in-scope set is such that --- the "CoreSubst#in_scope_invariant" is true after extending --- the substitution like this. -extendTvSubst :: Subst -> TyVar -> Type -> Subst -extendTvSubst (Subst in_scope ids tvs cvs) tv ty - = ASSERT( isTyVar tv ) - Subst in_scope ids (extendVarEnv tvs tv ty) cvs - --- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' -extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst -extendTvSubstList subst vrs - = foldl' extend subst vrs - where - extend subst (v, r) = extendTvSubst subst v r - --- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is --- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this -extendCvSubst :: Subst -> CoVar -> Coercion -> Subst -extendCvSubst (Subst in_scope ids tvs cvs) v r - = ASSERT( isCoVar v ) - Subst in_scope ids tvs (extendVarEnv cvs v r) - --- | Add a substitution appropriate to the thing being substituted --- (whether an expression, type, or coercion). See also --- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' -extendSubst :: Subst -> Var -> CoreArg -> Subst -extendSubst subst var arg - = case arg of - Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty - Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co - _ -> ASSERT( isId var ) extendIdSubst subst var arg - -extendSubstWithVar :: Subst -> Var -> Var -> Subst -extendSubstWithVar subst v1 v2 - | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2) - | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2) - | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2) - --- | Add a substitution as appropriate to each of the terms being --- substituted (whether expressions, types, or coercions). See also --- 'extendSubst'. -extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst -extendSubstList subst [] = subst -extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs - --- | Find the substitution for an 'Id' in the 'Subst' -lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr -lookupIdSubst doc (Subst in_scope ids _ _) v - | not (isLocalId v) = Var v - | Just e <- lookupVarEnv ids v = e - | Just v' <- lookupInScope in_scope v = Var v' - -- Vital! See Note [Extending the Subst] - | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v - $$ ppr in_scope) - Var v - --- | Find the substitution for a 'TyVar' in the 'Subst' -lookupTCvSubst :: Subst -> TyVar -> Type -lookupTCvSubst (Subst _ _ tvs cvs) v - | isTyVar v - = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v - | otherwise - = mkCoercionTy $ lookupVarEnv cvs v `orElse` mkCoVarCo v - -delBndr :: Subst -> Var -> Subst -delBndr (Subst in_scope ids tvs cvs) v - | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) - | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs - | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs - -delBndrs :: Subst -> [Var] -> Subst -delBndrs (Subst in_scope ids tvs cvs) vs - = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs) - -- Easiest thing is just delete all from all! - --- | Simultaneously substitute for a bunch of variables --- No left-right shadowing --- ie the substitution for (\x \y. e) a1 a2 --- so neither x nor y scope over a1 a2 -mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst -mkOpenSubst in_scope pairs = Subst in_scope - (mkVarEnv [(id,e) | (id, e) <- pairs, isId id]) - (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) - (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) - ------------------------------- -isInScope :: Var -> Subst -> Bool -isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope - --- | Add the 'Var' to the in-scope set, but do not remove --- any existing substitutions for it -addInScopeSet :: Subst -> VarSet -> Subst -addInScopeSet (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs - --- | Add the 'Var' to the in-scope set: as a side effect, --- and remove any existing substitutions for it -extendInScope :: Subst -> Var -> Subst -extendInScope (Subst in_scope ids tvs cvs) v - = Subst (in_scope `extendInScopeSet` v) - (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v) - --- | Add the 'Var's to the in-scope set: see also 'extendInScope' -extendInScopeList :: Subst -> [Var] -> Subst -extendInScopeList (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetList` vs) - (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs) - --- | Optimized version of 'extendInScopeList' that can be used if you are certain --- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's -extendInScopeIds :: Subst -> [Id] -> Subst -extendInScopeIds (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetList` vs) - (ids `delVarEnvList` vs) tvs cvs - -setInScope :: Subst -> InScopeSet -> Subst -setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs - --- Pretty printing, for debugging only - -instance Outputable Subst where - ppr (Subst in_scope ids tvs cvs) - = text " in_scope_doc - $$ text " IdSubst =" <+> ppr ids - $$ text " TvSubst =" <+> ppr tvs - $$ text " CvSubst =" <+> ppr cvs - <> char '>' - where - in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) - -{- -************************************************************************ -* * - Substituting expressions -* * -************************************************************************ --} - --- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only --- apply the substitution /once/: see "CoreSubst#apply_once" --- --- Do *not* attempt to short-cut in the case of an empty substitution! --- See Note [Extending the Subst] -substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr -substExprSC doc subst orig_expr - | isEmptySubst subst = orig_expr - | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $ - subst_expr doc subst orig_expr - -substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr -substExpr doc subst orig_expr = subst_expr doc subst orig_expr - -subst_expr :: SDoc -> Subst -> CoreExpr -> CoreExpr -subst_expr doc subst expr - = go expr - where - go (Var v) = lookupIdSubst (doc $$ text "subst_expr") subst v - go (Type ty) = Type (substTy subst ty) - go (Coercion co) = Coercion (substCo subst co) - go (Lit lit) = Lit lit - go (App fun arg) = App (go fun) (go arg) - go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) - go (Cast e co) = Cast (go e) (substCo subst co) - -- Do not optimise even identity coercions - -- Reason: substitution applies to the LHS of RULES, and - -- if you "optimise" an identity coercion, you may - -- lose a binder. We optimise the LHS of rules at - -- construction time - - go (Lam bndr body) = Lam bndr' (subst_expr doc subst' body) - where - (subst', bndr') = substBndr subst bndr - - go (Let bind body) = Let bind' (subst_expr doc subst' body) - where - (subst', bind') = substBind subst bind - - go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) - where - (subst', bndr') = substBndr subst bndr - - go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr doc subst' rhs) - where - (subst', bndrs') = substBndrs subst bndrs - --- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' --- that should be used by subsequent substitutions. -substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind) - -substBindSC subst bind -- Short-cut if the substitution is empty - | not (isEmptySubst subst) - = substBind subst bind - | otherwise - = case bind of - NonRec bndr rhs -> (subst', NonRec bndr' rhs) - where - (subst', bndr') = substBndr subst bndr - Rec pairs -> (subst', Rec (bndrs' `zip` rhss')) - where - (bndrs, rhss) = unzip pairs - (subst', bndrs') = substRecBndrs subst bndrs - rhss' | isEmptySubst subst' - = rhss - | otherwise - = map (subst_expr (text "substBindSC") subst') rhss - -substBind subst (NonRec bndr rhs) - = (subst', NonRec bndr' (subst_expr (text "substBind") subst rhs)) - where - (subst', bndr') = substBndr subst bndr - -substBind subst (Rec pairs) - = (subst', Rec (bndrs' `zip` rhss')) - where - (bndrs, rhss) = unzip pairs - (subst', bndrs') = substRecBndrs subst bndrs - rhss' = map (subst_expr (text "substBind") subst') rhss - --- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply --- by running over the bindings with an empty substitution, because substitution --- returns a result that has no-shadowing guaranteed. --- --- (Actually, within a single /type/ there might still be shadowing, because --- 'substTy' is a no-op for the empty substitution, but that's probably OK.) --- --- [Aug 09] This function is not used in GHC at the moment, but seems so --- short and simple that I'm going to leave it here -deShadowBinds :: CoreProgram -> CoreProgram -deShadowBinds binds = snd (mapAccumL substBind emptySubst binds) - -{- -************************************************************************ -* * - Substituting binders -* * -************************************************************************ - -Remember that substBndr and friends are used when doing expression -substitution only. Their only business is substitution, so they -preserve all IdInfo (suitably substituted). For example, we *want* to -preserve occ info in rules. --} - --- | Substitutes a 'Var' for another one according to the 'Subst' given, returning --- the result and an updated 'Subst' that should be used by subsequent substitutions. --- 'IdInfo' is preserved by this process, although it is substituted into appropriately. -substBndr :: Subst -> Var -> (Subst, Var) -substBndr subst bndr - | isTyVar bndr = substTyVarBndr subst bndr - | isCoVar bndr = substCoVarBndr subst bndr - | otherwise = substIdBndr (text "var-bndr") subst subst bndr - --- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right -substBndrs :: Subst -> [Var] -> (Subst, [Var]) -substBndrs subst bndrs = mapAccumL substBndr subst bndrs - --- | Substitute in a mutually recursive group of 'Id's -substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) -substRecBndrs subst bndrs - = (new_subst, new_bndrs) - where -- Here's the reason we need to pass rec_subst to subst_id - (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs - -substIdBndr :: SDoc - -> Subst -- ^ Substitution to use for the IdInfo - -> Subst -> Id -- ^ Substitution and Id to transform - -> (Subst, Id) -- ^ Transformed pair - -- NB: unfolding may be zapped - -substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id - = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ - (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) - where - id1 = uniqAway in_scope old_id -- id1 is cloned if necessary - id2 | no_type_change = id1 - | otherwise = setIdType id1 (substTy subst old_ty) - - old_ty = idType old_id - no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || - noFreeVarsOfType old_ty - - -- new_id has the right IdInfo - -- The lazy-set is because we're in a loop here, with - -- rec_subst, when dealing with a mutually-recursive group - new_id = maybeModifyIdInfo mb_new_info id2 - mb_new_info = substIdInfo rec_subst id2 (idInfo id2) - -- NB: unfolding info may be zapped - - -- Extend the substitution if the unique has changed - -- See the notes with substTyVarBndr for the delVarEnv - new_env | no_change = delVarEnv env old_id - | otherwise = extendVarEnv env old_id (Var new_id) - - no_change = id1 == old_id - -- See Note [Extending the Subst] - -- it's /not/ necessary to check mb_new_info and no_type_change - -{- -Now a variant that unconditionally allocates a new unique. -It also unconditionally zaps the OccInfo. --} - --- | Very similar to 'substBndr', but it always allocates a new 'Unique' for --- each variable in its output. It substitutes the IdInfo though. -cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) -cloneIdBndr subst us old_id - = clone_id subst subst (old_id, uniqFromSupply us) - --- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final --- substitution from left to right -cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) -cloneIdBndrs subst us ids - = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) - -cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) --- Works for all kinds of variables (typically case binders) --- not just Ids -cloneBndrs subst us vs - = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us) - -cloneBndr :: Subst -> Unique -> Var -> (Subst, Var) -cloneBndr subst uniq v - | isTyVar v = cloneTyVarBndr subst v uniq - | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too - --- | Clone a mutually recursive group of 'Id's -cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) -cloneRecIdBndrs subst us ids - = (subst', ids') - where - (subst', ids') = mapAccumL (clone_id subst') subst - (ids `zip` uniqsFromSupply us) - --- Just like substIdBndr, except that it always makes a new unique --- It is given the unique to use -clone_id :: Subst -- Substitution for the IdInfo - -> Subst -> (Id, Unique) -- Substitution and Id to transform - -> (Subst, Id) -- Transformed pair - -clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) - = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id) - where - id1 = setVarUnique old_id uniq - id2 = substIdType subst id1 - new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2 - (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id)) - | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs) - -{- -************************************************************************ -* * - Types and Coercions -* * -************************************************************************ - -For types and coercions we just call the corresponding functions in -Type and Coercion, but we have to repackage the substitution, from a -Subst to a TCvSubst. --} - -substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) -substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv - = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env', tv') - -cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) -cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq - = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env', tv') - -substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar) -substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv - = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of - (TCvSubst in_scope' tv_env' cv_env', cv') - -> (Subst in_scope' id_env tv_env' cv_env', cv') - --- | See 'Type.substTy' -substTy :: Subst -> Type -> Type -substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty - -getTCvSubst :: Subst -> TCvSubst -getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv - --- | See 'Coercion.substCo' -substCo :: Subst -> Coercion -> Coercion -substCo subst co = Coercion.substCo (getTCvSubst subst) co - -{- -************************************************************************ -* * -\section{IdInfo substitution} -* * -************************************************************************ --} - -substIdType :: Subst -> Id -> Id -substIdType subst@(Subst _ _ tv_env cv_env) id - | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || noFreeVarsOfType old_ty = id - | otherwise = setIdType id (substTy subst old_ty) - -- The tyCoVarsOfType is cheaper than it looks - -- because we cache the free tyvars of the type - -- in a Note in the id's type itself - where - old_ty = idType id - ------------------- --- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. -substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo -substIdInfo subst new_id info - | nothing_to_do = Nothing - | otherwise = Just (info `setRuleInfo` substSpec subst new_id old_rules - `setUnfoldingInfo` substUnfolding subst old_unf) - where - old_rules = ruleInfo info - old_unf = unfoldingInfo info - nothing_to_do = isEmptyRuleInfo old_rules && not (isFragileUnfolding old_unf) - ------------------- --- | Substitutes for the 'Id's within an unfolding -substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding - -- Seq'ing on the returned Unfolding is enough to cause - -- all the substitutions to happen completely - -substUnfoldingSC subst unf -- Short-cut version - | isEmptySubst subst = unf - | otherwise = substUnfolding subst unf - -substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) - = df { df_bndrs = bndrs', df_args = args' } - where - (subst',bndrs') = substBndrs subst bndrs - args' = map (substExpr (text "subst-unf:dfun") subst') args - -substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) - -- Retain an InlineRule! - | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work - = NoUnfolding - | otherwise -- But keep a stable one! - = seqExpr new_tmpl `seq` - unf { uf_tmpl = new_tmpl } - where - new_tmpl = substExpr (text "subst-unf") subst tmpl - -substUnfolding _ unf = unf -- NoUnfolding, OtherCon - ------------------- -substIdOcc :: Subst -> Id -> Id --- These Ids should not be substituted to non-Ids -substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of - Var v' -> v' - other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) - ------------------- --- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id' -substSpec :: Subst -> Id -> RuleInfo -> RuleInfo -substSpec subst new_id (RuleInfo rules rhs_fvs) - = seqRuleInfo new_spec `seq` new_spec - where - subst_ru_fn = const (idName new_id) - new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules) - (substDVarSet subst rhs_fvs) - ------------------- -substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] -substRulesForImportedIds subst rules - = map (substRule subst not_needed) rules - where - not_needed name = pprPanic "substRulesForImportedIds" (ppr name) - ------------------- -substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule - --- The subst_ru_fn argument is applied to substitute the ru_fn field --- of the rule: --- - Rules for *imported* Ids never change ru_fn --- - Rules for *local* Ids are in the IdInfo for that Id, --- and the ru_fn field is simply replaced by the new name --- of the Id -substRule _ _ rule@(BuiltinRule {}) = rule -substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args - , ru_fn = fn_name, ru_rhs = rhs - , ru_local = is_local }) - = rule { ru_bndrs = bndrs' - , ru_fn = if is_local - then subst_ru_fn fn_name - else fn_name - , ru_args = map (substExpr doc subst') args - , ru_rhs = substExpr (text "foo") subst' rhs } - -- Do NOT optimise the RHS (previously we did simplOptExpr here) - -- See Note [Substitute lazily] - where - doc = text "subst-rule" <+> ppr fn_name - (subst', bndrs') = substBndrs subst bndrs - ------------------- -substDVarSet :: Subst -> DVarSet -> DVarSet -substDVarSet subst fvs - = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs - where - subst_fv subst fv acc - | isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc - | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc - ------------------- -substTickish :: Subst -> Tickish Id -> Tickish Id -substTickish subst (Breakpoint n ids) - = Breakpoint n (map do_one ids) - where - do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst -substTickish _subst other = other - -{- Note [Substitute lazily] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The functions that substitute over IdInfo must be pretty lazy, because -they are knot-tied by substRecBndrs. - -One case in point was Trac #10627 in which a rule for a function 'f' -referred to 'f' (at a differnet type) on the RHS. But instead of just -substituting in the rhs of the rule, we were calling simpleOptExpr, which -looked at the idInfo for 'f'; result <>. - -In any case we don't need to optimise the RHS of rules, or unfoldings, -because the simplifier will do that. - - -Note [substTickish] -~~~~~~~~~~~~~~~~~~~~~~ -A Breakpoint contains a list of Ids. What happens if we ever want to -substitute an expression for one of these Ids? - -First, we ensure that we only ever substitute trivial expressions for -these Ids, by marking them as NoOccInfo in the occurrence analyser. -Then, when substituting for the Id, we unwrap any type applications -and abstractions to get back to an Id, with getIdFromTrivialExpr. - -Second, we have to ensure that we never try to substitute a literal -for an Id in a breakpoint. We ensure this by never storing an Id with -an unlifted type in a Breakpoint - see Coverage.mkTickish. -Breakpoints can't handle free variables with unlifted types anyway. --} - -{- -Note [Worker inlining] -~~~~~~~~~~~~~~~~~~~~~~ -A worker can get sustituted away entirely. - - it might be trivial - - it might simply be very small -We do not treat an InlWrapper as an 'occurrence' in the occurrence -analyser, so it's possible that the worker is not even in scope any more. - -In all all these cases we simply drop the special case, returning to -InlVanilla. The WARN is just so I can see if it happens a lot. --} - diff --git a/coreSyn/CoreSyn.hs b/coreSyn/CoreSyn.hs deleted file mode 100644 --- a/coreSyn/CoreSyn.hs +++ /dev/null @@ -1,2161 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} - --- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection -module CoreSyn ( - -- * Main data types - Expr(..), Alt, Bind(..), AltCon(..), Arg, - Tickish(..), TickishScoping(..), TickishPlacement(..), - CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, - TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, - - -- * In/Out type synonyms - InId, InBind, InExpr, InAlt, InArg, InType, InKind, - InBndr, InVar, InCoercion, InTyVar, InCoVar, - OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind, - OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, - - -- ** 'Expr' construction - mkLet, mkLets, mkLams, - mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg, - - mkIntLit, mkIntLitInt, - mkWordLit, mkWordLitWord, - mkWord64LitWord64, mkInt64LitInt64, - mkCharLit, mkStringLit, - mkFloatLit, mkFloatLitFloat, - mkDoubleLit, mkDoubleLitDouble, - - mkConApp, mkConApp2, mkTyBind, mkCoBind, - varToCoreExpr, varsToCoreExprs, - - isId, cmpAltCon, cmpAlt, ltAlt, - - -- ** Simple 'Expr' access functions and predicates - bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, - collectBinders, collectTyBinders, collectTyAndValBinders, - collectNBinders, - collectArgs, collectArgsTicks, flattenBinds, - - exprToType, exprToCoercion_maybe, - applyTypeToArg, - - isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount, - isRuntimeArg, isRuntimeVar, - - -- * Tick-related functions - tickishCounts, tickishScoped, tickishScopesLike, tickishFloatable, - tickishCanSplit, mkNoCount, mkNoScope, - tickishIsCode, tickishPlace, - tickishContains, - - -- * Unfolding data types - Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), - - -- ** Constructing 'Unfolding's - noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon, - unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, - - -- ** Predicates and deconstruction on 'Unfolding' - unfoldingTemplate, expandUnfolding_maybe, - maybeUnfoldingTemplate, otherCons, - isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, - isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, - isStableUnfolding, isFragileUnfolding, hasSomeUnfolding, - isBootUnfolding, - canUnfold, neverUnfoldGuidance, isStableSource, - - -- * Annotated expression data types - AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, - - -- ** Operations on annotated expressions - collectAnnArgs, collectAnnArgsTicks, - - -- ** Operations on annotations - deAnnotate, deAnnotate', deAnnAlt, - collectAnnBndrs, collectNAnnBndrs, - - -- * Orphanhood - IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, - - -- * Core rule data types - CoreRule(..), RuleBase, - RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, - RuleEnv(..), mkRuleEnv, emptyRuleEnv, - - -- ** Operations on 'CoreRule's - ruleArity, ruleName, ruleIdName, ruleActivation, - setRuleIdName, ruleModule, - isBuiltinRule, isLocalRule, isAutoRule, - - -- * Core vectorisation declarations data type - CoreVect(..) - ) where - -#include "HsVersions.h" - -import CostCentre -import VarEnv( InScopeSet ) -import Var -import Type -import Coercion -import Name -import NameSet -import NameEnv( NameEnv, emptyNameEnv ) -import Literal -import DataCon -import Module -import TyCon -import BasicTypes -import DynFlags -import Outputable -import Util -import UniqSet -import SrcLoc ( RealSrcSpan, containsSpan ) -import Binary - -import Data.Data hiding (TyCon) -import Data.Int -import Data.Word - -infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` --- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) - -{- -************************************************************************ -* * -\subsection{The main data types} -* * -************************************************************************ - -These data types are the heart of the compiler --} - --- | This is the data type that represents GHCs core intermediate language. Currently --- GHC uses System FC for this purpose, --- which is closely related to the simpler and better known System F . --- --- We get from Haskell source to this Core language in a number of stages: --- --- 1. The source code is parsed into an abstract syntax tree, which is represented --- by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames' --- --- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName' --- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical. --- For example, this program: --- --- @ --- f x = let f x = x + 1 --- in f (x - 2) --- @ --- --- Would be renamed by having 'Unique's attached so it looked something like this: --- --- @ --- f_1 x_2 = let f_3 x_4 = x_4 + 1 --- in f_3 (x_2 - 2) --- @ --- But see Note [Shadowing] below. --- --- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating --- type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names. --- --- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into --- this 'Expr' type, which has far fewer constructors and hence is easier to perform --- optimization, analysis and code generation on. --- --- The type parameter @b@ is for the type of binders in the expression tree. --- --- The language consists of the following elements: --- --- * Variables --- --- * Primitive literals --- --- * Applications: note that the argument may be a 'Type'. --- See Note [CoreSyn let/app invariant] --- See Note [Levity polymorphism invariants] --- --- * Lambda abstraction --- See Note [Levity polymorphism invariants] --- --- * Recursive and non recursive @let@s. Operationally --- this corresponds to allocating a thunk for the things --- bound and then executing the sub-expression. --- --- #top_level_invariant# --- #letrec_invariant# --- --- The right hand sides of all top-level and recursive @let@s --- /must/ be of lifted type (see "Type#type_classification" for --- the meaning of /lifted/ vs. /unlifted/). There is one exception --- to this rule, top-level @let@s are allowed to bind primitive --- string literals, see Note [CoreSyn top-level string literals]. --- --- See Note [CoreSyn let/app invariant] --- See Note [Levity polymorphism invariants] --- --- #type_let# --- We allow a /non-recursive/ let to bind a type variable, thus: --- --- > Let (NonRec tv (Type ty)) body --- --- This can be very convenient for postponing type substitutions until --- the next run of the simplifier. --- --- At the moment, the rest of the compiler only deals with type-let --- in a Let expression, rather than at top level. We may want to revist --- this choice. --- --- * Case expression. Operationally this corresponds to evaluating --- the scrutinee (expression examined) to weak head normal form --- and then examining at most one level of resulting constructor (i.e. you --- cannot do nested pattern matching directly with this). --- --- The binder gets bound to the value of the scrutinee, --- and the 'Type' must be that of all the case alternatives --- --- #case_invariants# --- This is one of the more complicated elements of the Core language, --- and comes with a number of restrictions: --- --- 1. The list of alternatives may be empty; --- See Note [Empty case alternatives] --- --- 2. The 'DEFAULT' case alternative must be first in the list, --- if it occurs at all. --- --- 3. The remaining cases are in order of increasing --- tag (for 'DataAlts') or --- lit (for 'LitAlts'). --- This makes finding the relevant constructor easy, --- and makes comparison easier too. --- --- 4. The list of alternatives must be exhaustive. An /exhaustive/ case --- does not necessarily mention all constructors: --- --- @ --- data Foo = Red | Green | Blue --- ... case x of --- Red -> True --- other -> f (case x of --- Green -> ... --- Blue -> ... ) ... --- @ --- --- The inner case does not need a @Red@ alternative, because @x@ --- can't be @Red@ at that program point. --- --- 5. Floating-point values must not be scrutinised against literals. --- See Trac #9238 and Note [Rules for floating-point comparisons] --- in PrelRules for rationale. --- --- * Cast an expression to a particular type. --- This is used to implement @newtype@s (a @newtype@ constructor or --- destructor just becomes a 'Cast' in Core) and GADTs. --- --- * Notes. These allow general information to be added to expressions --- in the syntax tree --- --- * A type: this should only show up at the top level of an Arg --- --- * A coercion - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Expr b - = Var Id - | Lit Literal - | App (Expr b) (Arg b) - | Lam b (Expr b) - | Let (Bind b) (Expr b) - | Case (Expr b) b Type [Alt b] -- See #case_invariants# - | Cast (Expr b) Coercion - | Tick (Tickish Id) (Expr b) - | Type Type - | Coercion Coercion - deriving Data - --- | Type synonym for expressions that occur in function argument positions. --- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not -type Arg b = Expr b - --- | A case split alternative. Consists of the constructor leading to the alternative, --- the variables bound from the constructor, and the expression to be executed given that binding. --- The default alternative is @(DEFAULT, [], rhs)@ - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -type Alt b = (AltCon, [b], Expr b) - --- | A case alternative constructor (i.e. pattern match) - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data AltCon - = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@. - -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ - - | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ - -- Invariant: always an *unlifted* literal - -- See Note [Literal alternatives] - - | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@ - deriving (Eq, Data) - --- | Binding, used for top level bindings in a module and local bindings in a @let@. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Bind b = NonRec b (Expr b) - | Rec [(b, (Expr b))] - deriving Data - -{- -Note [Shadowing] -~~~~~~~~~~~~~~~~ -While various passes attempt to rename on-the-fly in a manner that -avoids "shadowing" (thereby simplifying downstream optimizations), -neither the simplifier nor any other pass GUARANTEES that shadowing is -avoided. Thus, all passes SHOULD work fine even in the presence of -arbitrary shadowing in their inputs. - -In particular, scrutinee variables `x` in expressions of the form -`Case e x t` are often renamed to variables with a prefix -"wild_". These "wild" variables may appear in the body of the -case-expression, and further, may be shadowed within the body. - -So the Unique in an Var is not really unique at all. Still, it's very -useful to give a constant-time equality/ordering for Vars, and to give -a key that can be used to make sets of Vars (VarSet), or mappings from -Vars to other things (VarEnv). Moreover, if you do want to eliminate -shadowing, you can give a new Unique to an Id without changing its -printable name, which makes debugging easier. - -Note [Literal alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Literal alternatives (LitAlt lit) are always for *un-lifted* literals. -We have one literal, a literal Integer, that is lifted, and we don't -allow in a LitAlt, because LitAlt cases don't do any evaluation. Also -(see Trac #5603) if you say - case 3 of - S# x -> ... - J# _ _ -> ... -(where S#, J# are the constructors for Integer) we don't want the -simplifier calling findAlt with argument (LitAlt 3). No no. Integer -literals are an opaque encoding of an algebraic data type, not of -an unlifted literal, like all the others. - -Also, we do not permit case analysis with literal patterns on floating-point -types. See Trac #9238 and Note [Rules for floating-point comparisons] in -PrelRules for the rationale for this restriction. - --------------------------- CoreSyn INVARIANTS --------------------------- - -Note [CoreSyn top-level invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #toplevel_invariant# - -Note [CoreSyn letrec invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #letrec_invariant# - -Note [CoreSyn top-level string literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As an exception to the usual rule that top-level binders must be lifted, -we allow binding primitive string literals (of type Addr#) of type Addr# at the -top level. This allows us to share string literals earlier in the pipeline and -crucially allows other optimizations in the Core2Core pipeline to fire. -Consider, - - f n = let a::Addr# = "foo"# - in \x -> blah - -In order to be able to inline `f`, we would like to float `a` to the top. -Another option would be to inline `a`, but that would lead to duplicating string -literals, which we want to avoid. See Trac #8472. - -The solution is simply to allow top-level unlifted binders. We can't allow -arbitrary unlifted expression at the top-level though, unlifted binders cannot -be thunks, so we just allow string literals. - -It is important to note that top-level primitive string literals cannot be -wrapped in Ticks, as is otherwise done with lifted bindings. CoreToStg expects -to see just a plain (Lit (MachStr ...)) expression on the RHS of primitive -string bindings; anything else and things break. CoreLint checks this invariant. -To ensure that ticks don't sneak in CoreUtils.mkTick refuses to wrap any -primitve string expression with a tick. - -Also see Note [Compilation plan for top-level string literals]. - -Note [Compilation plan for top-level string literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is a summary on how top-level string literals are handled by various -parts of the compilation pipeline. - -* In the source language, there is no way to bind a primitive string literal - at the top leve. - -* In Core, we have a special rule that permits top-level Addr# bindings. See - Note [CoreSyn top-level string literals]. Core-to-core passes may introduce - new top-level string literals. - -* In STG, top-level string literals are explicitly represented in the syntax - tree. - -* A top-level string literal may end up exported from a module. In this case, - in the object file, the content of the exported literal is given a label with - the _bytes suffix. - -Note [CoreSyn let/app invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The let/app invariant - the right hand side of a non-recursive 'Let', and - the argument of an 'App', - /may/ be of unlifted type, but only if - the expression is ok-for-speculation - or the 'Let' is for a join point. - -This means that the let can be floated around -without difficulty. For example, this is OK: - - y::Int# = x +# 1# - -But this is not, as it may affect termination if the -expression is floated out: - - y::Int# = fac 4# - -In this situation you should use @case@ rather than a @let@. The function -'CoreUtils.needsCaseBinding' can help you determine which to generate, or -alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, -which will generate a @case@ if necessary - -The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in -coreSyn/MkCore. - -Note [CoreSyn case invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #case_invariants# - -Note [Levity polymorphism invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The levity-polymorphism invariants are these: - -* The type of a term-binder must not be levity-polymorphic, - unless it is a let(rec)-bound join point - (see Note [Invariants on join points]) - -* The type of the argument of an App must not be levity-polymorphic. - -A type (t::TYPE r) is "levity polymorphic" if 'r' has any free variables. - -For example - \(r::RuntimeRep). \(a::TYPE r). \(x::a). e -is illegal because x's type has kind (TYPE r), which has 'r' free. - -See Note [Levity polymorphism checking] in DsMonad to see where these -invariants are established for user-written code. - -Note [CoreSyn let goal] -~~~~~~~~~~~~~~~~~~~~~~~ -* The simplifier tries to ensure that if the RHS of a let is a constructor - application, its arguments are trivial, so that the constructor can be - inlined vigorously. - -Note [Type let] -~~~~~~~~~~~~~~~ -See #type_let# - -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The alternatives of a case expression should be exhaustive. But -this exhaustive list can be empty! - -* A case expression can have empty alternatives if (and only if) the - scrutinee is bound to raise an exception or diverge. When do we know - this? See Note [Bottoming expressions] in CoreUtils. - -* The possiblity of empty alternatives is one reason we need a type on - the case expression: if the alternatives are empty we can't get the - type from the alternatives! - -* In the case of empty types (see Note [Bottoming expressions]), say - data T - we do NOT want to replace - case (x::T) of Bool {} --> error Bool "Inaccessible case" - because x might raise an exception, and *that*'s what we want to see! - (Trac #6067 is an example.) To preserve semantics we'd have to say - x `seq` error Bool "Inaccessible case" - but the 'seq' is just a case, so we are back to square 1. Or I suppose - we could say - x |> UnsafeCoerce T Bool - but that loses all trace of the fact that this originated with an empty - set of alternatives. - -* We can use the empty-alternative construct to coerce error values from - one type to another. For example - - f :: Int -> Int - f n = error "urk" - - g :: Int -> (# Char, Bool #) - g x = case f x of { 0 -> ..., n -> ... } - - Then if we inline f in g's RHS we get - case (error Int "urk") of (# Char, Bool #) { ... } - and we can discard the alternatives since the scrutinee is bottom to give - case (error Int "urk") of (# Char, Bool #) {} - - This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #), - if for no other reason that we don't need to instantiate the (~) at an - unboxed type. - -* We treat a case expression with empty alternatives as trivial iff - its scrutinee is (see CoreUtils.exprIsTrivial). This is actually - important; see Note [Empty case is trivial] in CoreUtils - -* An empty case is replaced by its scrutinee during the CoreToStg - conversion; remember STG is un-typed, so there is no need for - the empty case to do the type conversion. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -In Core, a *join point* is a specially tagged function whose only occurrences -are saturated tail calls. A tail call can appear in these places: - - 1. In the branches (not the scrutinee) of a case - 2. Underneath a let (value or join point) - 3. Inside another join point - -We write a join-point declaration as - join j @a @b x y = e1 in e2, -like a let binding but with "join" instead (or "join rec" for "let rec"). Note -that we put the parameters before the = rather than using lambdas; this is -because it's relevant how many parameters the join point takes *as a join -point.* This number is called the *join arity,* distinct from arity because it -counts types as well as values. Note that a join point may return a lambda! So - join j x = x + 1 -is different from - join j = \x -> x + 1 -The former has join arity 1, while the latter has join arity 0. - -The identifier for a join point is called a join id or a *label.* An invocation -is called a *jump.* We write a jump using the jump keyword: - - jump j 3 - -The words *label* and *jump* are evocative of assembly code (or Cmm) for a -reason: join points are indeed compiled as labeled blocks, and jumps become -actual jumps (plus argument passing and stack adjustment). There is no closure -allocated and only a fraction of the function-call overhead. Hence we would -like as many functions as possible to become join points (see OccurAnal) and -the type rules for join points ensure we preserve the properties that make them -efficient. - -In the actual AST, a join point is indicated by the IdDetails of the binder: a -local value binding gets 'VanillaId' but a join point gets a 'JoinId' with its -join arity. - -For more details, see the paper: - - Luke Maurer, Paul Downen, Zena Ariola, and Simon Peyton Jones. "Compiling - without continuations." Submitted to PLDI'17. - - https://www.microsoft.com/en-us/research/publication/compiling-without-continuations/ - -Note [Invariants on join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Join points must follow these invariants: - - 1. All occurrences must be tail calls. Each of these tail calls must pass the - same number of arguments, counting both types and values; we call this the - "join arity" (to distinguish from regular arity, which only counts values). - - 2. For join arity n, the right-hand side must begin with at least n lambdas. - No ticks, no casts, just lambdas! C.f. CoreUtils.joinRhsArity. - - 2a. Moreover, this same constraint applies to any unfolding of the binder. - Reason: if we want to push a continuation into the RHS we must push it - into the unfolding as well. - - 3. If the binding is recursive, then all other bindings in the recursive group - must also be join points. - - 4. The binding's type must not be polymorphic in its return type (as defined - in Note [The polymorphism rule of join points]). - -However, join points have simpler invariants in other ways - - 5. A join point can have an unboxed type without the RHS being - ok-for-speculation (i.e. drop the let/app invariant) - e.g. let j :: Int# = factorial x in ... - - 6. A join point can have a levity-polymorphic RHS - e.g. let j :: r :: TYPE l = fail void# in ... - This happened in an intermediate program Trac #13394 - -Examples: - - join j1 x = 1 + x in jump j (jump j x) -- Fails 1: non-tail call - join j1' x = 1 + x in if even a - then jump j1 a - else jump j1 a b -- Fails 1: inconsistent calls - join j2 x = flip (+) x in j2 1 2 -- Fails 2: not enough lambdas - join j2' x = \y -> x + y in j3 1 -- Passes: extra lams ok - join j @a (x :: a) = x -- Fails 4: polymorphic in ret type - -Invariant 1 applies to left-hand sides of rewrite rules, so a rule for a join -point must have an exact call as its LHS. - -Strictly speaking, invariant 3 is redundant, since a call from inside a lazy -binding isn't a tail call. Since a let-bound value can't invoke a free join -point, then, they can't be mutually recursive. (A Core binding group *can* -include spurious extra bindings if the occurrence analyser hasn't run, so -invariant 3 does still need to be checked.) For the rigorous definition of -"tail call", see Section 3 of the paper (Note [Join points]). - -Invariant 4 is subtle; see Note [The polymorphism rule of join points]. - -Core Lint will check these invariants, anticipating that any binder whose -OccInfo is marked AlwaysTailCalled will become a join point as soon as the -simplifier (or simpleOptPgm) runs. - -Note [The type of a join point] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A join point has the same type it would have as a function. That is, if it takes -an Int and a Bool and its body produces a String, its type is `Int -> Bool -> -String`. Natural as this may seem, it can be awkward. A join point shouldn't be -thought to "return" in the same sense a function does---a jump is one-way. This -is crucial for understanding how case-of-case interacts with join points: - - case (join - j :: Int -> Bool -> String - j x y = ... - in - jump j z w) of - "" -> True - _ -> False - -The simplifier will pull the case into the join point (see Note [Case-of-case -and join points] in Simplify): - - join - j :: Int -> Bool -> Bool -- changed! - j x y = case ... of "" -> True - _ -> False - in - jump j z w - -The body of the join point now returns a Bool, so the label `j` has to have its -type updated accordingly. Inconvenient though this may be, it has the advantage -that 'CoreUtils.exprType' can still return a type for any expression, including -a jump. - -This differs from the paper (see Note [Invariants on join points]). In the -paper, we instead give j the type `Int -> Bool -> forall a. a`. Then each jump -carries the "return type" as a parameter, exactly the way other non-returning -functions like `error` work: - - case (join - j :: Int -> Bool -> forall a. a - j x y = ... - in - jump j z w @String) of - "" -> True - _ -> False - -Now we can move the case inward and we only have to change the jump: - - join - j :: Int -> Bool -> forall a. a - j x y = case ... of "" -> True - _ -> False - in - jump j z w @Bool - -(Core Lint would still check that the body of the join point has the right type; -that type would simply not be reflected in the join id.) - -Note [The polymorphism rule of join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Invariant 4 of Note [Invariants on join points] forbids a join point to be -polymorphic in its return type. That is, if its type is - - forall a1 ... ak. t1 -> ... -> tn -> r - -where its join arity is k+n, none of the type parameters ai may occur free in r. -The most direct explanation is that given - - join j @a1 ... @ak x1 ... xn = e1 in e2 - -our typing rules require `e1` and `e2` to have the same type. Therefore the type -of `e1`---the return type of the join point---must be the same as the type of -e2. Since the type variables aren't bound in `e2`, its type can't include them, -and thus neither can the type of `e1`. - -There's a deeper explanation in terms of the sequent calculus in Section 5.3 of -a previous paper: - - Paul Downen, Luke Maurer, Zena Ariola, and Simon Peyton Jones. "Sequent - calculus as a compiler intermediate language." ICFP'16. - - https://www.microsoft.com/en-us/research/wp-content/uploads/2016/04/sequent-calculus-icfp16.pdf - -The quick version: Consider the CPS term (the paper uses the sequent calculus, -but we can translate readily): - - \k -> join j @a1 ... @ak x1 ... xn = e1 k in e2 k - -Since `j` is a join point, it doesn't bind a continuation variable but reuses -the variable `k` from the context. But the parameters `ai` are not in `k`'s -scope, and `k`'s type determines the return type of `j`; thus the `ai`s don't -appear in the return type of `j`. (Also, since `e1` and `e2` are passed the same -continuation, they must have the same type; hence the direct explanation above.) - -************************************************************************ -* * - In/Out type synonyms -* * -********************************************************************* -} - -{- Many passes apply a substitution, and it's very handy to have type - synonyms to remind us whether or not the substitution has been applied -} - --- Pre-cloning or substitution -type InBndr = CoreBndr -type InType = Type -type InKind = Kind -type InBind = CoreBind -type InExpr = CoreExpr -type InAlt = CoreAlt -type InArg = CoreArg -type InCoercion = Coercion - --- Post-cloning or substitution -type OutBndr = CoreBndr -type OutType = Type -type OutKind = Kind -type OutCoercion = Coercion -type OutBind = CoreBind -type OutExpr = CoreExpr -type OutAlt = CoreAlt -type OutArg = CoreArg - - -{- ********************************************************************* -* * - Ticks -* * -************************************************************************ --} - --- | Allows attaching extra information to points in expressions - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Tickish id = - -- | An @{-# SCC #-}@ profiling annotation, either automatically - -- added by the desugarer as a result of -auto-all, or added by - -- the user. - ProfNote { - profNoteCC :: CostCentre, -- ^ the cost centre - profNoteCount :: !Bool, -- ^ bump the entry count? - profNoteScope :: !Bool -- ^ scopes over the enclosed expression - -- (i.e. not just a tick) - } - - -- | A "tick" used by HPC to track the execution of each - -- subexpression in the original source code. - | HpcTick { - tickModule :: Module, - tickId :: !Int - } - - -- | A breakpoint for the GHCi debugger. This behaves like an HPC - -- tick, but has a list of free variables which will be available - -- for inspection in GHCi when the program stops at the breakpoint. - -- - -- NB. we must take account of these Ids when (a) counting free variables, - -- and (b) substituting (don't substitute for them) - | Breakpoint - { breakpointId :: !Int - , breakpointFVs :: [id] -- ^ the order of this list is important: - -- it matches the order of the lists in the - -- appropriate entry in HscTypes.ModBreaks. - -- - -- Careful about substitution! See - -- Note [substTickish] in CoreSubst. - } - - -- | A source note. - -- - -- Source notes are pure annotations: Their presence should neither - -- influence compilation nor execution. The semantics are given by - -- causality: The presence of a source note means that a local - -- change in the referenced source code span will possibly provoke - -- the generated code to change. On the flip-side, the functionality - -- of annotated code *must* be invariant against changes to all - -- source code *except* the spans referenced in the source notes - -- (see "Causality of optimized Haskell" paper for details). - -- - -- Therefore extending the scope of any given source note is always - -- valid. Note that it is still undesirable though, as this reduces - -- their usefulness for debugging and profiling. Therefore we will - -- generally try only to make use of this property where it is - -- necessary to enable optimizations. - | SourceNote - { sourceSpan :: RealSrcSpan -- ^ Source covered - , sourceName :: String -- ^ Name for source location - -- (uses same names as CCs) - } - - deriving (Eq, Ord, Data) - --- | A "counting tick" (where tickishCounts is True) is one that --- counts evaluations in some way. We cannot discard a counting tick, --- and the compiler should preserve the number of counting ticks as --- far as possible. --- --- However, we still allow the simplifier to increase or decrease --- sharing, so in practice the actual number of ticks may vary, except --- that we never change the value from zero to non-zero or vice versa. -tickishCounts :: Tickish id -> Bool -tickishCounts n@ProfNote{} = profNoteCount n -tickishCounts HpcTick{} = True -tickishCounts Breakpoint{} = True -tickishCounts _ = False - - --- | Specifies the scoping behaviour of ticks. This governs the --- behaviour of ticks that care about the covered code and the cost --- associated with it. Important for ticks relating to profiling. -data TickishScoping = - -- | No scoping: The tick does not care about what code it - -- covers. Transformations can freely move code inside as well as - -- outside without any additional annotation obligations - NoScope - - -- | Soft scoping: We want all code that is covered to stay - -- covered. Note that this scope type does not forbid - -- transformations from happening, as as long as all results of - -- the transformations are still covered by this tick or a copy of - -- it. For example - -- - -- let x = tick<...> (let y = foo in bar) in baz - -- ===> - -- let x = tick<...> bar; y = tick<...> foo in baz - -- - -- Is a valid transformation as far as "bar" and "foo" is - -- concerned, because both still are scoped over by the tick. - -- - -- Note though that one might object to the "let" not being - -- covered by the tick any more. However, we are generally lax - -- with this - constant costs don't matter too much, and given - -- that the "let" was effectively merged we can view it as having - -- lost its identity anyway. - -- - -- Also note that this scoping behaviour allows floating a tick - -- "upwards" in pretty much any situation. For example: - -- - -- case foo of x -> tick<...> bar - -- ==> - -- tick<...> case foo of x -> bar - -- - -- While this is always leagl, we want to make a best effort to - -- only make us of this where it exposes transformation - -- opportunities. - | SoftScope - - -- | Cost centre scoping: We don't want any costs to move to other - -- cost-centre stacks. This means we not only want no code or cost - -- to get moved out of their cost centres, but we also object to - -- code getting associated with new cost-centre ticks - or - -- changing the order in which they get applied. - -- - -- A rule of thumb is that we don't want any code to gain new - -- annotations. However, there are notable exceptions, for - -- example: - -- - -- let f = \y -> foo in tick<...> ... (f x) ... - -- ==> - -- tick<...> ... foo[x/y] ... - -- - -- In-lining lambdas like this is always legal, because inlining a - -- function does not change the cost-centre stack when the - -- function is called. - | CostCentreScope - - deriving (Eq) - --- | Returns the intended scoping rule for a Tickish -tickishScoped :: Tickish id -> TickishScoping -tickishScoped n@ProfNote{} - | profNoteScope n = CostCentreScope - | otherwise = NoScope -tickishScoped HpcTick{} = NoScope -tickishScoped Breakpoint{} = CostCentreScope - -- Breakpoints are scoped: eventually we're going to do call - -- stacks, but also this helps prevent the simplifier from moving - -- breakpoints around and changing their result type (see #1531). -tickishScoped SourceNote{} = SoftScope - --- | Returns whether the tick scoping rule is at least as permissive --- as the given scoping rule. -tickishScopesLike :: Tickish id -> TickishScoping -> Bool -tickishScopesLike t scope = tickishScoped t `like` scope - where NoScope `like` _ = True - _ `like` NoScope = False - SoftScope `like` _ = True - _ `like` SoftScope = False - CostCentreScope `like` _ = True - --- | Returns @True@ for ticks that can be floated upwards easily even --- where it might change execution counts, such as: --- --- Just (tick<...> foo) --- ==> --- tick<...> (Just foo) --- --- This is a combination of @tickishSoftScope@ and --- @tickishCounts@. Note that in principle splittable ticks can become --- floatable using @mkNoTick@ -- even though there's currently no --- tickish for which that is the case. -tickishFloatable :: Tickish id -> Bool -tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t) - --- | Returns @True@ for a tick that is both counting /and/ scoping and --- can be split into its (tick, scope) parts using 'mkNoScope' and --- 'mkNoTick' respectively. -tickishCanSplit :: Tickish id -> Bool -tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True} - = True -tickishCanSplit _ = False - -mkNoCount :: Tickish id -> Tickish id -mkNoCount n | not (tickishCounts n) = n - | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!" -mkNoCount n@ProfNote{} = n {profNoteCount = False} -mkNoCount _ = panic "mkNoCount: Undefined split!" - -mkNoScope :: Tickish id -> Tickish id -mkNoScope n | tickishScoped n == NoScope = n - | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!" -mkNoScope n@ProfNote{} = n {profNoteScope = False} -mkNoScope _ = panic "mkNoScope: Undefined split!" - --- | Return @True@ if this source annotation compiles to some backend --- code. Without this flag, the tickish is seen as a simple annotation --- that does not have any associated evaluation code. --- --- What this means that we are allowed to disregard the tick if doing --- so means that we can skip generating any code in the first place. A --- typical example is top-level bindings: --- --- foo = tick<...> \y -> ... --- ==> --- foo = \y -> tick<...> ... --- --- Here there is just no operational difference between the first and --- the second version. Therefore code generation should simply --- translate the code as if it found the latter. -tickishIsCode :: Tickish id -> Bool -tickishIsCode SourceNote{} = False -tickishIsCode _tickish = True -- all the rest for now - - --- | Governs the kind of expression that the tick gets placed on when --- annotating for example using @mkTick@. If we find that we want to --- put a tickish on an expression ruled out here, we try to float it --- inwards until we find a suitable expression. -data TickishPlacement = - - -- | Place ticks exactly on run-time expressions. We can still - -- move the tick through pure compile-time constructs such as - -- other ticks, casts or type lambdas. This is the most - -- restrictive placement rule for ticks, as all tickishs have in - -- common that they want to track runtime processes. The only - -- legal placement rule for counting ticks. - PlaceRuntime - - -- | As @PlaceRuntime@, but we float the tick through all - -- lambdas. This makes sense where there is little difference - -- between annotating the lambda and annotating the lambda's code. - | PlaceNonLam - - -- | In addition to floating through lambdas, cost-centre style - -- tickishs can also be moved from constructors, non-function - -- variables and literals. For example: - -- - -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ... - -- - -- Neither the constructor application, the variable or the - -- literal are likely to have any cost worth mentioning. And even - -- if y names a thunk, the call would not care about the - -- evaluation context. Therefore removing all annotations in the - -- above example is safe. - | PlaceCostCentre - - deriving (Eq) - --- | Placement behaviour we want for the ticks -tickishPlace :: Tickish id -> TickishPlacement -tickishPlace n@ProfNote{} - | profNoteCount n = PlaceRuntime - | otherwise = PlaceCostCentre -tickishPlace HpcTick{} = PlaceRuntime -tickishPlace Breakpoint{} = PlaceRuntime -tickishPlace SourceNote{} = PlaceNonLam - --- | Returns whether one tick "contains" the other one, therefore --- making the second tick redundant. -tickishContains :: Eq b => Tickish b -> Tickish b -> Bool -tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2) - = containsSpan sp1 sp2 && n1 == n2 - -- compare the String last -tickishContains t1 t2 - = t1 == t2 - -{- -************************************************************************ -* * - Orphans -* * -************************************************************************ --} - --- | Is this instance an orphan? If it is not an orphan, contains an 'OccName' --- witnessing the instance's non-orphanhood. --- See Note [Orphans] -data IsOrphan - = IsOrphan - | NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood - -- In that case, the instance is fingerprinted as part - -- of the definition of 'n's definition - deriving Data - --- | Returns true if 'IsOrphan' is orphan. -isOrphan :: IsOrphan -> Bool -isOrphan IsOrphan = True -isOrphan _ = False - --- | Returns true if 'IsOrphan' is not an orphan. -notOrphan :: IsOrphan -> Bool -notOrphan NotOrphan{} = True -notOrphan _ = False - -chooseOrphanAnchor :: NameSet -> IsOrphan --- Something (rule, instance) is relate to all the Names in this --- list. Choose one of them to be an "anchor" for the orphan. We make --- the choice deterministic to avoid gratuitious changes in the ABI --- hash (Trac #4012). Specifically, use lexicographic comparison of --- OccName rather than comparing Uniques --- --- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically --- -chooseOrphanAnchor local_names - | isEmptyNameSet local_names = IsOrphan - | otherwise = NotOrphan (minimum occs) - where - occs = map nameOccName $ nonDetEltsUniqSet local_names - -- It's OK to use nonDetEltsUFM here, see comments above - -instance Binary IsOrphan where - put_ bh IsOrphan = putByte bh 0 - put_ bh (NotOrphan n) = do - putByte bh 1 - put_ bh n - get bh = do - h <- getByte bh - case h of - 0 -> return IsOrphan - _ -> do - n <- get bh - return $ NotOrphan n - -{- -Note [Orphans] -~~~~~~~~~~~~~~ -Class instances, rules, and family instances are divided into orphans -and non-orphans. Roughly speaking, an instance/rule is an orphan if -its left hand side mentions nothing defined in this module. Orphan-hood -has two major consequences - - * A module that contains orphans is called an "orphan module". If - the module being compiled depends (transitively) on an oprhan - module M, then M.hi is read in regardless of whether M is oherwise - needed. This is to ensure that we don't miss any instance decls in - M. But it's painful, because it means we need to keep track of all - the orphan modules below us. - - * A non-orphan is not finger-printed separately. Instead, for - fingerprinting purposes it is treated as part of the entity it - mentions on the LHS. For example - data T = T1 | T2 - instance Eq T where .... - The instance (Eq T) is incorprated as part of T's fingerprint. - - In contrast, orphans are all fingerprinted together in the - mi_orph_hash field of the ModIface. - - See MkIface.addFingerprints. - -Orphan-hood is computed - * For class instances: - when we make a ClsInst - (because it is needed during instance lookup) - - * For rules and family instances: - when we generate an IfaceRule (MkIface.coreRuleToIfaceRule) - or IfaceFamInst (MkIface.instanceToIfaceInst) --} - -{- -************************************************************************ -* * -\subsection{Transformation rules} -* * -************************************************************************ - -The CoreRule type and its friends are dealt with mainly in CoreRules, -but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. --} - --- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules -type RuleBase = NameEnv [CoreRule] - -- The rules are unordered; - -- we sort out any overlaps on lookup - --- | A full rule environment which we can apply rules from. Like a 'RuleBase', --- but it also includes the set of visible orphans we use to filter out orphan --- rules which are not visible (even though we can see them...) -data RuleEnv - = RuleEnv { re_base :: RuleBase - , re_visible_orphs :: ModuleSet - } - -mkRuleEnv :: RuleBase -> [Module] -> RuleEnv -mkRuleEnv rules vis_orphs = RuleEnv rules (mkModuleSet vis_orphs) - -emptyRuleEnv :: RuleEnv -emptyRuleEnv = RuleEnv emptyNameEnv emptyModuleSet - --- | A 'CoreRule' is: --- --- * \"Local\" if the function it is a rule for is defined in the --- same module as the rule itself. --- --- * \"Orphan\" if nothing on the LHS is defined in the same module --- as the rule itself -data CoreRule - = Rule { - ru_name :: RuleName, -- ^ Name of the rule, for communication with the user - ru_act :: Activation, -- ^ When the rule is active - - -- Rough-matching stuff - -- see comments with InstEnv.ClsInst( is_cls, is_rough ) - ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule - ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side - - -- Proper-matching stuff - -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) - ru_bndrs :: [CoreBndr], -- ^ Variables quantified over - ru_args :: [CoreExpr], -- ^ Left hand side arguments - - -- And the right-hand side - ru_rhs :: CoreExpr, -- ^ Right hand side of the rule - -- Occurrence info is guaranteed correct - -- See Note [OccInfo in unfoldings and rules] - - -- Locality - ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated - -- (notably by Specialise or SpecConstr) - -- @False@ <=> generated at the user's behest - -- See Note [Trimming auto-rules] in TidyPgm - -- for the sole purpose of this field. - - ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used - -- to test if we should see an orphan rule. - - ru_orphan :: !IsOrphan, -- ^ Whether or not the rule is an orphan. - - ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is - -- defined in the same module as the rule - -- and is not an implicit 'Id' (like a record selector, - -- class operation, or data constructor). This - -- is different from 'ru_orphan', where a rule - -- can avoid being an orphan if *any* Name in - -- LHS of the rule was defined in the same - -- module as the rule. - } - - -- | Built-in rules are used for constant folding - -- and suchlike. They have no free variables. - -- A built-in rule is always visible (there is no such thing as - -- an orphan built-in rule.) - | BuiltinRule { - ru_name :: RuleName, -- ^ As above - ru_fn :: Name, -- ^ As above - ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, - -- if it fires, including type arguments - ru_try :: RuleFun - -- ^ This function does the rewrite. It given too many - -- arguments, it simply discards them; the returned 'CoreExpr' - -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args - } - -- See Note [Extra args in rule matching] in Rules.hs - -type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr -type InScopeEnv = (InScopeSet, IdUnfoldingFun) - -type IdUnfoldingFun = Id -> Unfolding --- A function that embodies how to unfold an Id if you need --- to do that in the Rule. The reason we need to pass this info in --- is that whether an Id is unfoldable depends on the simplifier phase - -isBuiltinRule :: CoreRule -> Bool -isBuiltinRule (BuiltinRule {}) = True -isBuiltinRule _ = False - -isAutoRule :: CoreRule -> Bool -isAutoRule (BuiltinRule {}) = False -isAutoRule (Rule { ru_auto = is_auto }) = is_auto - --- | The number of arguments the 'ru_fn' must be applied --- to before the rule can match on it -ruleArity :: CoreRule -> Int -ruleArity (BuiltinRule {ru_nargs = n}) = n -ruleArity (Rule {ru_args = args}) = length args - -ruleName :: CoreRule -> RuleName -ruleName = ru_name - -ruleModule :: CoreRule -> Maybe Module -ruleModule Rule { ru_origin } = Just ru_origin -ruleModule BuiltinRule {} = Nothing - -ruleActivation :: CoreRule -> Activation -ruleActivation (BuiltinRule { }) = AlwaysActive -ruleActivation (Rule { ru_act = act }) = act - --- | The 'Name' of the 'Id.Id' at the head of the rule left hand side -ruleIdName :: CoreRule -> Name -ruleIdName = ru_fn - -isLocalRule :: CoreRule -> Bool -isLocalRule = ru_local - --- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side -setRuleIdName :: Name -> CoreRule -> CoreRule -setRuleIdName nm ru = ru { ru_fn = nm } - -{- -************************************************************************ -* * -\subsection{Vectorisation declarations} -* * -************************************************************************ - -Representation of desugared vectorisation declarations that are fed to the vectoriser (via -'ModGuts'). --} - -data CoreVect = Vect Id CoreExpr - | NoVect Id - | VectType Bool TyCon (Maybe TyCon) - | VectClass TyCon -- class tycon - | VectInst Id -- instance dfun (always SCALAR) !!!FIXME: should be superfluous now - -{- -************************************************************************ -* * - Unfoldings -* * -************************************************************************ - -The @Unfolding@ type is declared here to avoid numerous loops --} - --- | Records the /unfolding/ of an identifier, which is approximately the form the --- identifier would have if we substituted its definition in for the identifier. --- This type should be treated as abstract everywhere except in "CoreUnfold" -data Unfolding - = NoUnfolding -- ^ We have no information about the unfolding. - - | BootUnfolding -- ^ We have no information about the unfolding, because - -- this 'Id' came from an @hi-boot@ file. - -- See Note [Inlining and hs-boot files] in ToIface - -- for what this is used for. - - | OtherCon [AltCon] -- ^ It ain't one of these constructors. - -- @OtherCon xs@ also indicates that something has been evaluated - -- and hence there's no point in re-evaluating it. - -- @OtherCon []@ is used even for non-data-type values - -- to indicated evaluated-ness. Notably: - -- - -- > data C = C !(Int -> Int) - -- > case x of { C f -> ... } - -- - -- Here, @f@ gets an @OtherCon []@ unfolding. - - | DFunUnfolding { -- The Unfolding of a DFunId - -- See Note [DFun unfoldings] - -- df = /\a1..am. \d1..dn. MkD t1 .. tk - -- (op1 a1..am d1..dn) - -- (op2 a1..am d1..dn) - df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] - df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) - df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, - } -- in positional order - - | CoreUnfolding { -- An unfolding for an Id with no pragma, - -- or perhaps a NOINLINE pragma - -- (For NOINLINE, the phase, if any, is in the - -- InlinePragInfo for this Id.) - uf_tmpl :: CoreExpr, -- Template; occurrence info is correct - uf_src :: UnfoldingSource, -- Where the unfolding came from - uf_is_top :: Bool, -- True <=> top level binding - uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard - -- a `seq` on this variable - uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function - -- Cached version of exprIsConLike - uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand - -- inside an inlining - -- Cached version of exprIsCheap - uf_expandable :: Bool, -- True <=> can expand in RULE matching - -- Cached version of exprIsExpandable - uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. - } - -- ^ An unfolding with redundant cached information. Parameters: - -- - -- uf_tmpl: Template used to perform unfolding; - -- NB: Occurrence info is guaranteed correct: - -- see Note [OccInfo in unfoldings and rules] - -- - -- uf_is_top: Is this a top level binding? - -- - -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on - -- this variable - -- - -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? - -- Basically this is a cached version of 'exprIsWorkFree' - -- - -- uf_guidance: Tells us about the /size/ of the unfolding template - - ------------------------------------------------- -data UnfoldingSource - = -- See also Note [Historical note: unfoldings for wrappers] - - InlineRhs -- The current rhs of the function - -- Replace uf_tmpl each time around - - | InlineStable -- From an INLINE or INLINABLE pragma - -- INLINE if guidance is UnfWhen - -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever - -- (well, technically an INLINABLE might be made - -- UnfWhen if it was small enough, and then - -- it will behave like INLINE outside the current - -- module, but that is the way automatic unfoldings - -- work so it is consistent with the intended - -- meaning of INLINABLE). - -- - -- uf_tmpl may change, but only as a result of - -- gentle simplification, it doesn't get updated - -- to the current RHS during compilation as with - -- InlineRhs. - -- - -- See Note [InlineStable] - - | InlineCompulsory -- Something that *has* no binding, so you *must* inline it - -- Only a few primop-like things have this property - -- (see MkId.hs, calls to mkCompulsoryUnfolding). - -- Inline absolutely always, however boring the context. - - - --- | 'UnfoldingGuidance' says when unfolding should take place -data UnfoldingGuidance - = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl - -- Used (a) for small *and* cheap unfoldings - -- (b) for INLINE functions - -- See Note [INLINE for small functions] in CoreUnfold - ug_arity :: Arity, -- Number of value arguments expected - - ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated - ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring - -- So True,True means "always" - } - - | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the - -- result of a simple analysis of the RHS - - ug_args :: [Int], -- Discount if the argument is evaluated. - -- (i.e., a simplification will definitely - -- be possible). One elt of the list per *value* arg. - - ug_size :: Int, -- The "size" of the unfolding. - - ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in - } -- a context (case (thing args) of ...), - -- (where there are the right number of arguments.) - - | UnfNever -- The RHS is big, so don't inline it - deriving (Eq) - -{- -Note [Historical note: unfoldings for wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to have a nice clever scheme in interface files for -wrappers. A wrapper's unfolding can be reconstructed from its worker's -id and its strictness. This decreased .hi file size (sometimes -significantly, for modules like GHC.Classes with many high-arity w/w -splits) and had a slight corresponding effect on compile times. - -However, when we added the second demand analysis, this scheme lead to -some Core lint errors. The second analysis could change the strictness -signatures, which sometimes resulted in a wrapper's regenerated -unfolding applying the wrapper to too many arguments. - -Instead of repairing the clever .hi scheme, we abandoned it in favor -of simplicity. The .hi sizes are usually insignificant (excluding the -+1M for base libraries), and compile time barely increases (~+1% for -nofib). The nicer upshot is that the UnfoldingSource no longer mentions -an Id, so, eg, substitutions need not traverse them. - - -Note [DFun unfoldings] -~~~~~~~~~~~~~~~~~~~~~~ -The Arity in a DFunUnfolding is total number of args (type and value) -that the DFun needs to produce a dictionary. That's not necessarily -related to the ordinary arity of the dfun Id, esp if the class has -one method, so the dictionary is represented by a newtype. Example - - class C a where { op :: a -> Int } - instance C a -> C [a] where op xs = op (head xs) - -The instance translates to - - $dfCList :: forall a. C a => C [a] -- Arity 2! - $dfCList = /\a.\d. $copList {a} d |> co - - $copList :: forall a. C a => [a] -> Int -- Arity 2! - $copList = /\a.\d.\xs. op {a} d (head xs) - -Now we might encounter (op (dfCList {ty} d) a1 a2) -and we want the (op (dfList {ty} d)) rule to fire, because $dfCList -has all its arguments, even though its (value) arity is 2. That's -why we record the number of expected arguments in the DFunUnfolding. - -Note that although it's an Arity, it's most convenient for it to give -the *total* number of arguments, both type and value. See the use -site in exprIsConApp_maybe. --} - --- Constants for the UnfWhen constructor -needSaturated, unSaturatedOk :: Bool -needSaturated = False -unSaturatedOk = True - -boringCxtNotOk, boringCxtOk :: Bool -boringCxtOk = True -boringCxtNotOk = False - ------------------------------------------------- -noUnfolding :: Unfolding --- ^ There is no known 'Unfolding' -evaldUnfolding :: Unfolding --- ^ This unfolding marks the associated thing as being evaluated - -noUnfolding = NoUnfolding -evaldUnfolding = OtherCon [] - --- | There is no known 'Unfolding', because this came from an --- hi-boot file. -bootUnfolding :: Unfolding -bootUnfolding = BootUnfolding - -mkOtherCon :: [AltCon] -> Unfolding -mkOtherCon = OtherCon - -isStableSource :: UnfoldingSource -> Bool --- Keep the unfolding template -isStableSource InlineCompulsory = True -isStableSource InlineStable = True -isStableSource InlineRhs = False - --- | Retrieves the template of an unfolding: panics if none is known -unfoldingTemplate :: Unfolding -> CoreExpr -unfoldingTemplate = uf_tmpl - --- | Retrieves the template of an unfolding if possible --- maybeUnfoldingTemplate is used mainly wnen specialising, and we do --- want to specialise DFuns, so it's important to return a template --- for DFunUnfoldings -maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr -maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) - = Just expr -maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) - = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args)) -maybeUnfoldingTemplate _ - = Nothing - --- | The constructors that the unfolding could never be: --- returns @[]@ if no information is available -otherCons :: Unfolding -> [AltCon] -otherCons (OtherCon cons) = cons -otherCons _ = [] - --- | Determines if it is certainly the case that the unfolding will --- yield a value (something in HNF): returns @False@ if unsure -isValueUnfolding :: Unfolding -> Bool - -- Returns False for OtherCon -isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald -isValueUnfolding _ = False - --- | Determines if it possibly the case that the unfolding will --- yield a value. Unlike 'isValueUnfolding' it returns @True@ --- for 'OtherCon' -isEvaldUnfolding :: Unfolding -> Bool - -- Returns True for OtherCon -isEvaldUnfolding (OtherCon _) = True -isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald -isEvaldUnfolding _ = False - --- | @True@ if the unfolding is a constructor application, the application --- of a CONLIKE function or 'OtherCon' -isConLikeUnfolding :: Unfolding -> Bool -isConLikeUnfolding (OtherCon _) = True -isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con -isConLikeUnfolding _ = False - --- | Is the thing we will unfold into certainly cheap? -isCheapUnfolding :: Unfolding -> Bool -isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf -isCheapUnfolding _ = False - -isExpandableUnfolding :: Unfolding -> Bool -isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable -isExpandableUnfolding _ = False - -expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr --- Expand an expandable unfolding; this is used in rule matching --- See Note [Expanding variables] in Rules.hs --- The key point here is that CONLIKE things can be expanded -expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs -expandUnfolding_maybe _ = Nothing - -isCompulsoryUnfolding :: Unfolding -> Bool -isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True -isCompulsoryUnfolding _ = False - -isStableUnfolding :: Unfolding -> Bool --- True of unfoldings that should not be overwritten --- by a CoreUnfolding for the RHS of a let-binding -isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src -isStableUnfolding (DFunUnfolding {}) = True -isStableUnfolding _ = False - --- | Only returns False if there is no unfolding information available at all -hasSomeUnfolding :: Unfolding -> Bool -hasSomeUnfolding NoUnfolding = False -hasSomeUnfolding BootUnfolding = False -hasSomeUnfolding _ = True - -isBootUnfolding :: Unfolding -> Bool -isBootUnfolding BootUnfolding = True -isBootUnfolding _ = False - -neverUnfoldGuidance :: UnfoldingGuidance -> Bool -neverUnfoldGuidance UnfNever = True -neverUnfoldGuidance _ = False - -isFragileUnfolding :: Unfolding -> Bool --- An unfolding is fragile if it mentions free variables or --- is otherwise subject to change. A robust one can be kept. --- See Note [Fragile unfoldings] -isFragileUnfolding (CoreUnfolding {}) = True -isFragileUnfolding (DFunUnfolding {}) = True -isFragileUnfolding _ = False - -- NoUnfolding, BootUnfolding, OtherCon are all non-fragile - -canUnfold :: Unfolding -> Bool -canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) -canUnfold _ = False - -{- Note [Fragile unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An unfolding is "fragile" if it mentions free variables (and hence would -need substitution) or might be affected by optimisation. The non-fragile -ones are - - NoUnfolding, BootUnfolding - - OtherCon {} If we know this binder (say a lambda binder) will be - bound to an evaluated thing, we want to retain that - info in simpleOptExpr; see Trac #13077. - -We consider even a StableUnfolding as fragile, because it needs substitution. - -Note [InlineStable] -~~~~~~~~~~~~~~~~~ -When you say - {-# INLINE f #-} - f x = -you intend that calls (f e) are replaced by [e/x] So we -should capture (\x.) in the Unfolding of 'f', and never meddle -with it. Meanwhile, we can optimise to our heart's content, -leaving the original unfolding intact in Unfolding of 'f'. For example - all xs = foldr (&&) True xs - any p = all . map p {-# INLINE any #-} -We optimise any's RHS fully, but leave the InlineRule saying "all . map p", -which deforests well at the call site. - -So INLINE pragma gives rise to an InlineRule, which captures the original RHS. - -Moreover, it's only used when 'f' is applied to the -specified number of arguments; that is, the number of argument on -the LHS of the '=' sign in the original source definition. -For example, (.) is now defined in the libraries like this - {-# INLINE (.) #-} - (.) f g = \x -> f (g x) -so that it'll inline when applied to two arguments. If 'x' appeared -on the left, thus - (.) f g x = f (g x) -it'd only inline when applied to three arguments. This slightly-experimental -change was requested by Roman, but it seems to make sense. - -See also Note [Inlining an InlineRule] in CoreUnfold. - - -Note [OccInfo in unfoldings and rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In unfoldings and rules, we guarantee that the template is occ-analysed, -so that the occurrence info on the binders is correct. This is important, -because the Simplifier does not re-analyse the template when using it. If -the occurrence info is wrong - - We may get more simpifier iterations than necessary, because - once-occ info isn't there - - More seriously, we may get an infinite loop if there's a Rec - without a loop breaker marked - - -************************************************************************ -* * - AltCon -* * -************************************************************************ --} - --- The Ord is needed for the FiniteMap used in the lookForConstructor --- in SimplEnv. If you declared that lookForConstructor *ignores* --- constructor-applications with LitArg args, then you could get --- rid of this Ord. - -instance Outputable AltCon where - ppr (DataAlt dc) = ppr dc - ppr (LitAlt lit) = ppr lit - ppr DEFAULT = text "__DEFAULT" - -cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering -cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 - -ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool -ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT - -cmpAltCon :: AltCon -> AltCon -> Ordering --- ^ Compares 'AltCon's within a single list of alternatives -cmpAltCon DEFAULT DEFAULT = EQ -cmpAltCon DEFAULT _ = LT - -cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2 -cmpAltCon (DataAlt _) DEFAULT = GT -cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2 -cmpAltCon (LitAlt _) DEFAULT = GT - -cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> - ppr con1 <+> ppr con2 ) - LT - -{- -************************************************************************ -* * -\subsection{Useful synonyms} -* * -************************************************************************ - -Note [CoreProgram] -~~~~~~~~~~~~~~~~~~ -The top level bindings of a program, a CoreProgram, are represented as -a list of CoreBind - - * Later bindings in the list can refer to earlier ones, but not vice - versa. So this is OK - NonRec { x = 4 } - Rec { p = ...q...x... - ; q = ...p...x } - Rec { f = ...p..x..f.. } - NonRec { g = ..f..q...x.. } - But it would NOT be ok for 'f' to refer to 'g'. - - * The occurrence analyser does strongly-connected component analysis - on each Rec binding, and splits it into a sequence of smaller - bindings where possible. So the program typically starts life as a - single giant Rec, which is then dependency-analysed into smaller - chunks. --} - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -type CoreProgram = [CoreBind] -- See Note [CoreProgram] - --- | The common case for the type of binders and variables when --- we are manipulating the Core language within GHC -type CoreBndr = Var --- | Expressions where binders are 'CoreBndr's -type CoreExpr = Expr CoreBndr --- | Argument expressions where binders are 'CoreBndr's -type CoreArg = Arg CoreBndr --- | Binding groups where binders are 'CoreBndr's -type CoreBind = Bind CoreBndr --- | Case alternatives where binders are 'CoreBndr's -type CoreAlt = Alt CoreBndr - -{- -************************************************************************ -* * -\subsection{Tagging} -* * -************************************************************************ --} - --- | Binders are /tagged/ with a t -data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" - -type TaggedBind t = Bind (TaggedBndr t) -type TaggedExpr t = Expr (TaggedBndr t) -type TaggedArg t = Arg (TaggedBndr t) -type TaggedAlt t = Alt (TaggedBndr t) - -instance Outputable b => Outputable (TaggedBndr b) where - ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' - -deTagExpr :: TaggedExpr t -> CoreExpr -deTagExpr (Var v) = Var v -deTagExpr (Lit l) = Lit l -deTagExpr (Type ty) = Type ty -deTagExpr (Coercion co) = Coercion co -deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2) -deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e) -deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body) -deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts) -deTagExpr (Tick t e) = Tick t (deTagExpr e) -deTagExpr (Cast e co) = Cast (deTagExpr e) co - -deTagBind :: TaggedBind t -> CoreBind -deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs) -deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs] - -deTagAlt :: TaggedAlt t -> CoreAlt -deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs) - -{- -************************************************************************ -* * -\subsection{Core-constructing functions with checking} -* * -************************************************************************ --} - --- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to --- use 'MkCore.mkCoreApps' if possible -mkApps :: Expr b -> [Arg b] -> Expr b --- | Apply a list of type argument expressions to a function expression in a nested fashion -mkTyApps :: Expr b -> [Type] -> Expr b --- | Apply a list of coercion argument expressions to a function expression in a nested fashion -mkCoApps :: Expr b -> [Coercion] -> Expr b --- | Apply a list of type or value variables to a function expression in a nested fashion -mkVarApps :: Expr b -> [Var] -> Expr b --- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to --- use 'MkCore.mkCoreConApps' if possible -mkConApp :: DataCon -> [Arg b] -> Expr b - -mkApps f args = foldl App f args -mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args -mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars -mkConApp con args = mkApps (Var (dataConWorkId con)) args - -mkTyApps f args = foldl (\ e a -> App e (mkTyArg a)) f args - -mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b -mkConApp2 con tys arg_ids = Var (dataConWorkId con) - `mkApps` map Type tys - `mkApps` map varToCoreExpr arg_ids - -mkTyArg :: Type -> Expr b -mkTyArg ty - | Just co <- isCoercionTy_maybe ty = Coercion co - | otherwise = Type ty - --- | Create a machine integer literal expression of type @Int#@ from an @Integer@. --- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' -mkIntLit :: DynFlags -> Integer -> Expr b --- | Create a machine integer literal expression of type @Int#@ from an @Int@. --- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' -mkIntLitInt :: DynFlags -> Int -> Expr b - -mkIntLit dflags n = Lit (mkMachInt dflags n) -mkIntLitInt dflags n = Lit (mkMachInt dflags (toInteger n)) - --- | Create a machine word literal expression of type @Word#@ from an @Integer@. --- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' -mkWordLit :: DynFlags -> Integer -> Expr b --- | Create a machine word literal expression of type @Word#@ from a @Word@. --- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' -mkWordLitWord :: DynFlags -> Word -> Expr b - -mkWordLit dflags w = Lit (mkMachWord dflags w) -mkWordLitWord dflags w = Lit (mkMachWord dflags (toInteger w)) - -mkWord64LitWord64 :: Word64 -> Expr b -mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w)) - -mkInt64LitInt64 :: Int64 -> Expr b -mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w)) - --- | Create a machine character literal expression of type @Char#@. --- If you want an expression of type @Char@ use 'MkCore.mkCharExpr' -mkCharLit :: Char -> Expr b --- | Create a machine string literal expression of type @Addr#@. --- If you want an expression of type @String@ use 'MkCore.mkStringExpr' -mkStringLit :: String -> Expr b - -mkCharLit c = Lit (mkMachChar c) -mkStringLit s = Lit (mkMachString s) - --- | Create a machine single precision literal expression of type @Float#@ from a @Rational@. --- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' -mkFloatLit :: Rational -> Expr b --- | Create a machine single precision literal expression of type @Float#@ from a @Float@. --- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' -mkFloatLitFloat :: Float -> Expr b - -mkFloatLit f = Lit (mkMachFloat f) -mkFloatLitFloat f = Lit (mkMachFloat (toRational f)) - --- | Create a machine double precision literal expression of type @Double#@ from a @Rational@. --- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' -mkDoubleLit :: Rational -> Expr b --- | Create a machine double precision literal expression of type @Double#@ from a @Double@. --- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' -mkDoubleLitDouble :: Double -> Expr b - -mkDoubleLit d = Lit (mkMachDouble d) -mkDoubleLitDouble d = Lit (mkMachDouble (toRational d)) - --- | Bind all supplied binding groups over an expression in a nested let expression. Assumes --- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if --- possible, which does guarantee the invariant -mkLets :: [Bind b] -> Expr b -> Expr b --- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to --- use 'MkCore.mkCoreLams' if possible -mkLams :: [b] -> Expr b -> Expr b - -mkLams binders body = foldr Lam body binders -mkLets binds body = foldr mkLet body binds - -mkLet :: Bind b -> Expr b -> Expr b --- The desugarer sometimes generates an empty Rec group --- which Lint rejects, so we kill it off right away -mkLet (Rec []) body = body -mkLet bind body = Let bind body - --- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", --- this can only be used to bind something in a non-recursive @let@ expression -mkTyBind :: TyVar -> Type -> CoreBind -mkTyBind tv ty = NonRec tv (Type ty) - --- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", --- this can only be used to bind something in a non-recursive @let@ expression -mkCoBind :: CoVar -> Coercion -> CoreBind -mkCoBind cv co = NonRec cv (Coercion co) - --- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately -varToCoreExpr :: CoreBndr -> Expr b -varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) - | isCoVar v = Coercion (mkCoVarCo v) - | otherwise = ASSERT( isId v ) Var v - -varsToCoreExprs :: [CoreBndr] -> [Expr b] -varsToCoreExprs vs = map varToCoreExpr vs - -{- -************************************************************************ -* * - Getting a result type -* * -************************************************************************ - -These are defined here to avoid a module loop between CoreUtils and CoreFVs - --} - -applyTypeToArg :: Type -> CoreExpr -> Type --- ^ Determines the type resulting from applying an expression with given type --- to a given argument expression -applyTypeToArg fun_ty arg = piResultTy fun_ty (exprToType arg) - --- | If the expression is a 'Type', converts. Otherwise, --- panics. NB: This does /not/ convert 'Coercion' to 'CoercionTy'. -exprToType :: CoreExpr -> Type -exprToType (Type ty) = ty -exprToType _bad = pprPanic "exprToType" empty - --- | If the expression is a 'Coercion', converts. -exprToCoercion_maybe :: CoreExpr -> Maybe Coercion -exprToCoercion_maybe (Coercion co) = Just co -exprToCoercion_maybe _ = Nothing - -{- -************************************************************************ -* * -\subsection{Simple access functions} -* * -************************************************************************ --} - --- | Extract every variable by this group -bindersOf :: Bind b -> [b] --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -bindersOf (NonRec binder _) = [binder] -bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] - --- | 'bindersOf' applied to a list of binding groups -bindersOfBinds :: [Bind b] -> [b] -bindersOfBinds binds = foldr ((++) . bindersOf) [] binds - -rhssOfBind :: Bind b -> [Expr b] -rhssOfBind (NonRec _ rhs) = [rhs] -rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] - -rhssOfAlts :: [Alt b] -> [Expr b] -rhssOfAlts alts = [e | (_,_,e) <- alts] - --- | Collapse all the bindings in the supplied groups into a single --- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group -flattenBinds :: [Bind b] -> [(b, Expr b)] -flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds -flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds -flattenBinds [] = [] - --- | We often want to strip off leading lambdas before getting down to --- business. Variants are 'collectTyBinders', 'collectValBinders', --- and 'collectTyAndValBinders' -collectBinders :: Expr b -> ([b], Expr b) -collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) -collectValBinders :: CoreExpr -> ([Id], CoreExpr) -collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) --- | Strip off exactly N leading lambdas (type or value). Good for use with --- join points. -collectNBinders :: Int -> Expr b -> ([b], Expr b) - -collectBinders expr - = go [] expr - where - go bs (Lam b e) = go (b:bs) e - go bs e = (reverse bs, e) - -collectTyBinders expr - = go [] expr - where - go tvs (Lam b e) | isTyVar b = go (b:tvs) e - go tvs e = (reverse tvs, e) - -collectValBinders expr - = go [] expr - where - go ids (Lam b e) | isId b = go (b:ids) e - go ids body = (reverse ids, body) - -collectTyAndValBinders expr - = (tvs, ids, body) - where - (tvs, body1) = collectTyBinders expr - (ids, body) = collectValBinders body1 - -collectNBinders orig_n orig_expr - = go orig_n [] orig_expr - where - go 0 bs expr = (reverse bs, expr) - go n bs (Lam b e) = go (n-1) (b:bs) e - go _ _ _ = pprPanic "collectNBinders" $ int orig_n - --- | Takes a nested application expression and returns the the function --- being applied and the arguments to which it is applied -collectArgs :: Expr b -> (Expr b, [Arg b]) -collectArgs expr - = go expr [] - where - go (App f a) as = go f (a:as) - go e as = (e, as) - --- | Like @collectArgs@, but also collects looks through floatable --- ticks if it means that we can find more arguments. -collectArgsTicks :: (Tickish Id -> Bool) -> Expr b - -> (Expr b, [Arg b], [Tickish Id]) -collectArgsTicks skipTick expr - = go expr [] [] - where - go (App f a) as ts = go f (a:as) ts - go (Tick t e) as ts - | skipTick t = go e as (t:ts) - go e as ts = (e, as, reverse ts) - - -{- -************************************************************************ -* * -\subsection{Predicates} -* * -************************************************************************ - -At one time we optionally carried type arguments through to runtime. -@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime, -i.e. if type applications are actual lambdas because types are kept around -at runtime. Similarly isRuntimeArg. --} - --- | Will this variable exist at runtime? -isRuntimeVar :: Var -> Bool -isRuntimeVar = isId - --- | Will this argument expression exist at runtime? -isRuntimeArg :: CoreExpr -> Bool -isRuntimeArg = isValArg - --- | Returns @True@ for value arguments, false for type args --- NB: coercions are value arguments (zero width, to be sure, --- like State#, but still value args). -isValArg :: Expr b -> Bool -isValArg e = not (isTypeArg e) - --- | Returns @True@ iff the expression is a 'Type' or 'Coercion' --- expression at its top level -isTyCoArg :: Expr b -> Bool -isTyCoArg (Type {}) = True -isTyCoArg (Coercion {}) = True -isTyCoArg _ = False - --- | Returns @True@ iff the expression is a 'Type' expression at its --- top level. Note this does NOT include 'Coercion's. -isTypeArg :: Expr b -> Bool -isTypeArg (Type {}) = True -isTypeArg _ = False - --- | The number of binders that bind values rather than types -valBndrCount :: [CoreBndr] -> Int -valBndrCount = count isId - --- | The number of argument expressions that are values rather than types at their top level -valArgCount :: [Arg b] -> Int -valArgCount = count isValArg - -{- -************************************************************************ -* * -\subsection{Annotated core} -* * -************************************************************************ --} - --- | Annotated core: allows annotation at every node in the tree -type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) - --- | A clone of the 'Expr' type but allowing annotation at every tree node -data AnnExpr' bndr annot - = AnnVar Id - | AnnLit Literal - | AnnLam bndr (AnnExpr bndr annot) - | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) - | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] - | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) - | AnnCast (AnnExpr bndr annot) (annot, Coercion) - -- Put an annotation on the (root of) the coercion - | AnnTick (Tickish Id) (AnnExpr bndr annot) - | AnnType Type - | AnnCoercion Coercion - --- | A clone of the 'Alt' type but allowing annotation at every tree node -type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) - --- | A clone of the 'Bind' type but allowing annotation at every tree node -data AnnBind bndr annot - = AnnNonRec bndr (AnnExpr bndr annot) - | AnnRec [(bndr, AnnExpr bndr annot)] - --- | Takes a nested application expression and returns the the function --- being applied and the arguments to which it is applied -collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) -collectAnnArgs expr - = go expr [] - where - go (_, AnnApp f a) as = go f (a:as) - go e as = (e, as) - -collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a - -> (AnnExpr b a, [AnnExpr b a], [Tickish Var]) -collectAnnArgsTicks tickishOk expr - = go expr [] [] - where - go (_, AnnApp f a) as ts = go f (a:as) ts - go (_, AnnTick t e) as ts | tickishOk t - = go e as (t:ts) - go e as ts = (e, as, reverse ts) - -deAnnotate :: AnnExpr bndr annot -> Expr bndr -deAnnotate (_, e) = deAnnotate' e - -deAnnotate' :: AnnExpr' bndr annot -> Expr bndr -deAnnotate' (AnnType t) = Type t -deAnnotate' (AnnCoercion co) = Coercion co -deAnnotate' (AnnVar v) = Var v -deAnnotate' (AnnLit lit) = Lit lit -deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) -deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) -deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co -deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body) - -deAnnotate' (AnnLet bind body) - = Let (deAnnBind bind) (deAnnotate body) - where - deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) - deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] - -deAnnotate' (AnnCase scrut v t alts) - = Case (deAnnotate scrut) v t (map deAnnAlt alts) - -deAnnAlt :: AnnAlt bndr annot -> Alt bndr -deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) - --- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' -collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) -collectAnnBndrs e - = collect [] e - where - collect bs (_, AnnLam b body) = collect (b:bs) body - collect bs body = (reverse bs, body) - --- | As 'collectNBinders' but for 'AnnExpr' rather than 'Expr' -collectNAnnBndrs :: Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) -collectNAnnBndrs orig_n e - = collect orig_n [] e - where - collect 0 bs body = (reverse bs, body) - collect n bs (_, AnnLam b body) = collect (n-1) (b:bs) body - collect _ _ _ = pprPanic "collectNBinders" $ int orig_n diff --git a/coreSyn/CoreTidy.hs b/coreSyn/CoreTidy.hs deleted file mode 100644 --- a/coreSyn/CoreTidy.hs +++ /dev/null @@ -1,287 +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 TidyPgm. --} - -{-# LANGUAGE CPP #-} -module CoreTidy ( - tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding - ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreUnfold ( mkCoreUnfolding ) -import CoreArity -import Id -import IdInfo -import Demand ( zapUsageEnvSig ) -import Type( tidyType, tidyTyCoVarBndr ) -import Coercion( tidyCo ) -import Var -import VarEnv -import UniqFM -import Name hiding (tidyNameOcc) -import SrcLoc -import Maybes -import Data.List - -{- -************************************************************************ -* * -\subsection{Tidying expressions, rules} -* * -************************************************************************ --} - -tidyBind :: TidyEnv - -> CoreBind - -> (TidyEnv, CoreBind) - -tidyBind env (NonRec bndr rhs) - = tidyLetBndr env env (bndr,rhs) =: \ (env', bndr') -> - (env', NonRec bndr' (tidyExpr env' rhs)) - -tidyBind env (Rec prs) - = let - (env', bndrs') = mapAccumL (tidyLetBndr env') env prs - in - map (tidyExpr env') (map snd prs) =: \ 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 (con, vs, rhs) - = tidyBndrs env vs =: \ (env', vs) -> - (con, vs, tidyExpr env' rhs) - ------------- Tickish -------------- -tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id -tidyTickish env (Breakpoint ix ids) = Breakpoint 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 var_env 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 = tidyTyCoVarBndr 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) - name' = mkInternalName (idUnique id) occ' noSrcSpan - id' = mkLocalIdWithInfo name' 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 | isEvaldUnfolding old_unf = evaldUnfolding - | otherwise = noUnfolding - -- See Note [Preserve evaluatedness] - in - ((tidy_env', var_env'), id') - } - -tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings - -> TidyEnv -- The one to extend - -> (Id, CoreExpr) -> (TidyEnv, Var) --- 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,rhs) - = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> - let - ty' = tidyType env (idType id) - name' = mkInternalName (idUnique id) occ' noSrcSpan - details = idDetails id - id' = mkLocalVar details name' 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 WorkWrap) - -- - -- Similarly arity info for eta expansion in CorePrep - -- - -- Set inline-prag info so that we preseve it across - -- separate compilation boundaries - old_info = idInfo id - new_info = vanillaIdInfo - `setOccInfo` occInfo old_info - `setArityInfo` exprArity rhs - `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info) - `setDemandInfo` demandInfo old_info - `setInlinePragInfo` inlinePragInfo old_info - `setUnfoldingInfo` new_unf - - new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf - | isEvaldUnfolding old_unf = evaldUnfolding - -- See Note [Preserve evaluatedness] - | otherwise = noUnfolding - old_unf = unfoldingInfo old_info - 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 - (CoreUnfolding { uf_tmpl = unf_rhs, uf_is_top = top_lvl - , uf_src = src, uf_guidance = guidance }) - unf_from_rhs - | isStableSource src - = mkCoreUnfolding src top_lvl (tidyExpr tidy_env unf_rhs) guidance - -- Preserves OccInfo - - -- Note that uf_is_value and friends may be a thunk containing a reference - -- to the old template. Consequently it is important that we rebuild them, - -- despite the fact that they won't change, to avoid a space leak (since, - -- e.g., ToIface doesn't look at them; see #13564). This is the same - -- approach we use in Simplify.simplUnfolding and TcIface.tcUnfolding. - - | otherwise - = unf_from_rhs -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 MkId. - -This applies to lambda binders only, hence it is stored in IfaceLamBndr. --} - -(=:) :: a -> (a -> b) -> b -m =: k = m `seq` k m diff --git a/coreSyn/CoreUnfold.hs b/coreSyn/CoreUnfold.hs deleted file mode 100644 --- a/coreSyn/CoreUnfold.hs +++ /dev/null @@ -1,1492 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - - -Core-syntax unfoldings - -Unfoldings (which can travel across module boundaries) are in Core -syntax (namely @CoreExpr@s). - -The type @Unfolding@ sits ``above'' simply-Core-expressions -unfoldings, capturing ``higher-level'' things we know about a binding, -usually things that the simplifier found out (e.g., ``it's a -literal''). In the corner of a @CoreUnfolding@ unfolding, you will -find, unsurprisingly, a Core expression. --} - -{-# LANGUAGE CPP #-} - -module CoreUnfold ( - Unfolding, UnfoldingGuidance, -- Abstract types - - noUnfolding, mkImplicitUnfolding, - mkUnfolding, mkCoreUnfolding, - mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, - mkInlineUnfolding, mkInlineUnfoldingWithArity, - mkInlinableUnfolding, mkWwInlineRule, - mkCompulsoryUnfolding, mkDFunUnfolding, - specUnfolding, - - ArgSummary(..), - - couldBeSmallEnoughToInline, inlineBoringOk, - certainlyWillInline, smallEnoughToInline, - - callSiteInline, CallCtxt(..), - - -- Reexport from CoreSubst (it only live there so it can be used - -- by the Very Simple Optimiser) - exprIsConApp_maybe, exprIsLiteral_maybe - ) where - -#include "HsVersions.h" - -import DynFlags -import CoreSyn -import PprCore () -- Instances -import OccurAnal ( occurAnalyseExpr ) -import CoreOpt -import CoreArity ( manifestArity ) -import CoreUtils -import Id -import Demand ( isBottomingSig ) -import DataCon -import Literal -import PrimOp -import IdInfo -import BasicTypes ( Arity, InlineSpec(..), inlinePragmaSpec ) -import Type -import PrelNames -import TysPrim ( realWorldStatePrimTy ) -import Bag -import Util -import Outputable -import ForeignCall - -import qualified Data.ByteString as BS - -{- -************************************************************************ -* * -\subsection{Making unfoldings} -* * -************************************************************************ --} - -mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding -mkTopUnfolding dflags is_bottoming rhs - = mkUnfolding dflags InlineRhs True is_bottoming rhs - -mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding --- For implicit Ids, do a tiny bit of optimising first -mkImplicitUnfolding dflags expr - = mkTopUnfolding dflags False (simpleOptExpr expr) - --- Note [Top-level flag on inline rules] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Slight hack: note that mk_inline_rules conservatively sets the --- top-level flag to True. It gets set more accurately by the simplifier --- Simplify.simplUnfolding. - -mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding -mkSimpleUnfolding dflags rhs - = mkUnfolding dflags InlineRhs False False rhs - -mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding -mkDFunUnfolding bndrs con ops - = DFunUnfolding { df_bndrs = bndrs - , df_con = con - , df_args = map occurAnalyseExpr ops } - -- See Note [Occurrence analysis of unfoldings] - -mkWwInlineRule :: CoreExpr -> Arity -> Unfolding -mkWwInlineRule expr arity - = mkCoreUnfolding InlineStable True - (simpleOptExpr expr) - (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk - , ug_boring_ok = boringCxtNotOk }) - -mkCompulsoryUnfolding :: CoreExpr -> Unfolding -mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = mkCoreUnfolding InlineCompulsory True - (simpleOptExpr expr) - (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter - , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) - -mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding --- See Note [Worker-wrapper for INLINABLE functions] in WorkWrap -mkWorkerUnfolding dflags work_fn - (CoreUnfolding { uf_src = src, uf_tmpl = tmpl - , uf_is_top = top_lvl }) - | isStableSource src - = mkCoreUnfolding src top_lvl new_tmpl guidance - where - new_tmpl = simpleOptExpr (work_fn tmpl) - guidance = calcUnfoldingGuidance dflags False new_tmpl - -mkWorkerUnfolding _ _ _ = noUnfolding - --- | Make an unfolding that may be used unsaturated --- (ug_unsat_ok = unSaturatedOk) and that is reported as having its --- manifest arity (the number of outer lambdas applications will --- resolve before doing any work). -mkInlineUnfolding :: CoreExpr -> Unfolding -mkInlineUnfolding expr - = mkCoreUnfolding InlineStable - True -- Note [Top-level flag on inline rules] - expr' guide - where - expr' = simpleOptExpr expr - guide = UnfWhen { ug_arity = manifestArity expr' - , ug_unsat_ok = unSaturatedOk - , ug_boring_ok = boring_ok } - boring_ok = inlineBoringOk expr' - --- | Make an unfolding that will be used once the RHS has been saturated --- to the given arity. -mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding -mkInlineUnfoldingWithArity arity expr - = mkCoreUnfolding InlineStable - True -- Note [Top-level flag on inline rules] - expr' guide - where - expr' = simpleOptExpr expr - guide = UnfWhen { ug_arity = arity - , ug_unsat_ok = needSaturated - , ug_boring_ok = boring_ok } - boring_ok = inlineBoringOk expr' - -mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding -mkInlinableUnfolding dflags expr - = mkUnfolding dflags InlineStable False False expr' - where - expr' = simpleOptExpr expr - -specUnfolding :: [Var] -> (CoreExpr -> CoreExpr) -> Arity -> Unfolding -> Unfolding --- See Note [Specialising unfoldings] --- specUnfolding spec_bndrs spec_app arity_decrease unf --- = \spec_bndrs. spec_app( unf ) --- -specUnfolding spec_bndrs spec_app arity_decrease - df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args }) - = ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs, ppr df ) - mkDFunUnfolding spec_bndrs con (map spec_arg args) - -- There is a hard-to-check assumption here that the spec_app has - -- enough applications to exactly saturate the old_bndrs - -- For DFunUnfoldings we transform - -- \old_bndrs. MkD ... - -- to - -- \new_bndrs. MkD (spec_app(\old_bndrs. )) ... ditto - -- The ASSERT checks the value part of that - where - spec_arg arg = simpleOptExpr (spec_app (mkLams old_bndrs arg)) - -- The beta-redexes created by spec_app will be - -- simplified away by simplOptExpr - -specUnfolding spec_bndrs spec_app arity_decrease - (CoreUnfolding { uf_src = src, uf_tmpl = tmpl - , uf_is_top = top_lvl - , uf_guidance = old_guidance }) - | isStableSource src -- See Note [Specialising unfoldings] - , UnfWhen { ug_arity = old_arity - , ug_unsat_ok = unsat_ok - , ug_boring_ok = boring_ok } <- old_guidance - = let guidance = UnfWhen { ug_arity = old_arity - arity_decrease - , ug_unsat_ok = unsat_ok - , ug_boring_ok = boring_ok } - new_tmpl = simpleOptExpr (mkLams spec_bndrs (spec_app tmpl)) - -- The beta-redexes created by spec_app will be - -- simplified away by simplOptExpr - - in mkCoreUnfolding src top_lvl new_tmpl guidance - -specUnfolding _ _ _ _ = noUnfolding - -{- Note [Specialising unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we specialise a function for some given type-class arguments, we use -specUnfolding to specialise its unfolding. Some important points: - -* If the original function has a DFunUnfolding, the specialised one - must do so too! Otherwise we lose the magic rules that make it - interact with ClassOps - -* There is a bit of hack for INLINABLE functions: - f :: Ord a => .... - f = - {- INLINABLE f #-} - Now if we specialise f, should the specialised version still have - an INLINABLE pragma? If it does, we'll capture a specialised copy - of as its unfolding, and that probaby won't inline. But - if we don't, the specialised version of might be small - enough to inline at a call site. This happens with Control.Monad.liftM3, - and can cause a lot more allocation as a result (nofib n-body shows this). - - Moreover, keeping the INLINABLE thing isn't much help, because - the specialised function (probaby) isn't overloaded any more. - - Conclusion: drop the INLINEALE pragma. In practice what this means is: - if a stable unfolding has UnfoldingGuidance of UnfWhen, - we keep it (so the specialised thing too will always inline) - if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs - (which arises from INLINABLE), we discard it --} - -mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr - -> UnfoldingGuidance -> Unfolding --- Occurrence-analyses the expression before capturing it -mkCoreUnfolding src top_lvl expr guidance - = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, - -- See Note [Occurrence analysis of unfoldings] - uf_src = src, - uf_is_top = top_lvl, - uf_is_value = exprIsHNF expr, - uf_is_conlike = exprIsConLike expr, - uf_is_work_free = exprIsWorkFree expr, - uf_expandable = exprIsExpandable expr, - uf_guidance = guidance } - -mkUnfolding :: DynFlags -> UnfoldingSource - -> Bool -- Is top-level - -> Bool -- Definitely a bottoming binding - -- (only relevant for top-level bindings) - -> CoreExpr - -> Unfolding --- Calculates unfolding guidance --- Occurrence-analyses the expression before capturing it -mkUnfolding dflags src is_top_lvl is_bottoming expr - = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, - -- See Note [Occurrence analysis of unfoldings] - uf_src = src, - uf_is_top = is_top_lvl, - uf_is_value = exprIsHNF expr, - uf_is_conlike = exprIsConLike expr, - uf_expandable = exprIsExpandable expr, - uf_is_work_free = exprIsWorkFree expr, - uf_guidance = guidance } - where - is_top_bottoming = is_top_lvl && is_bottoming - guidance = calcUnfoldingGuidance dflags is_top_bottoming expr - -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))! - -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] - -{- -Note [Occurrence analysis of unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do occurrence-analysis of unfoldings once and for all, when the -unfolding is built, rather than each time we inline them. - -But given this decision it's vital that we do -*always* do it. Consider this unfolding - \x -> letrec { f = ...g...; g* = f } in body -where g* is (for some strange reason) the loop breaker. If we don't -occ-anal it when reading it in, we won't mark g as a loop breaker, and -we may inline g entirely in body, dropping its binding, and leaving -the occurrence in f out of scope. This happened in Trac #8892, where -the unfolding in question was a DFun unfolding. - -But more generally, the simplifier is designed on the -basis that it is looking at occurrence-analysed expressions, so better -ensure that they acutally are. - -Note [Calculate unfolding guidance on the non-occ-anal'd expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice that we give the non-occur-analysed expression to -calcUnfoldingGuidance. In some ways it'd be better to occur-analyse -first; for example, sometimes during simplification, there's a large -let-bound thing which has been substituted, and so is now dead; so -'expr' contains two copies of the thing while the occurrence-analysed -expression doesn't. - -Nevertheless, we *don't* and *must not* occ-analyse before computing -the size because - -a) The size computation bales out after a while, whereas occurrence - analysis does not. - -b) Residency increases sharply if you occ-anal first. I'm not - 100% sure why, but it's a large effect. Compiling Cabal went - from residency of 534M to over 800M with this one change. - -This can occasionally mean that the guidance is very pessimistic; -it gets fixed up next round. And it should be rare, because large -let-bound things that are dead are usually caught by preInlineUnconditionally - - -************************************************************************ -* * -\subsection{The UnfoldingGuidance type} -* * -************************************************************************ --} - -inlineBoringOk :: CoreExpr -> Bool --- See Note [INLINE for small functions] --- True => the result of inlining the expression is --- no bigger than the expression itself --- eg (\x y -> f y x) --- This is a quick and dirty version. It doesn't attempt --- to deal with (\x y z -> x (y z)) --- The really important one is (x `cast` c) -inlineBoringOk e - = go 0 e - where - go :: Int -> CoreExpr -> Bool - go credit (Lam x e) | isId x = go (credit+1) e - | otherwise = go credit e - go credit (App f (Type {})) = go credit f - go credit (App f a) | credit > 0 - , exprIsTrivial a = go (credit-1) f - go credit (Tick _ e) = go credit e -- dubious - go credit (Cast e _) = go credit e - go _ (Var {}) = boringCxtOk - go _ _ = boringCxtNotOk - -calcUnfoldingGuidance - :: DynFlags - -> Bool -- Definitely a top-level, bottoming binding - -> CoreExpr -- Expression to look at - -> UnfoldingGuidance -calcUnfoldingGuidance dflags is_top_bottoming (Tick t expr) - | not (tickishIsCode t) -- non-code ticks don't matter for unfolding - = calcUnfoldingGuidance dflags is_top_bottoming expr -calcUnfoldingGuidance dflags is_top_bottoming expr - = case sizeExpr dflags bOMB_OUT_SIZE val_bndrs body of - TooBig -> UnfNever - SizeIs size cased_bndrs scrut_discount - | uncondInline expr n_val_bndrs size - -> UnfWhen { ug_unsat_ok = unSaturatedOk - , ug_boring_ok = boringCxtOk - , ug_arity = n_val_bndrs } -- Note [INLINE for small functions] - - | is_top_bottoming - -> UnfNever -- See Note [Do not inline top-level bottoming functions] - - | otherwise - -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs - , ug_size = size - , ug_res = scrut_discount } - - where - (bndrs, body) = collectBinders expr - bOMB_OUT_SIZE = ufCreationThreshold dflags - -- Bomb out if size gets bigger than this - val_bndrs = filter isId bndrs - n_val_bndrs = length val_bndrs - - mk_discount :: Bag (Id,Int) -> Id -> Int - mk_discount cbs bndr = foldlBag combine 0 cbs - where - combine acc (bndr', disc) - | bndr == bndr' = acc `plus_disc` disc - | otherwise = acc - - plus_disc :: Int -> Int -> Int - plus_disc | isFunTy (idType bndr) = max - | otherwise = (+) - -- See Note [Function and non-function discounts] - -{- -Note [Computing the size of an expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea of sizeExpr is obvious enough: count nodes. But getting the -heuristics right has taken a long time. Here's the basic strategy: - - * Variables, literals: 0 - (Exception for string literals, see litSize.) - - * Function applications (f e1 .. en): 1 + #value args - - * Constructor applications: 1, regardless of #args - - * Let(rec): 1 + size of components - - * Note, cast: 0 - -Examples - - Size Term - -------------- - 0 42# - 0 x - 0 True - 2 f x - 1 Just x - 4 f (g x) - -Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's -a function call to account for. Notice also that constructor applications -are very cheap, because exposing them to a caller is so valuable. - -[25/5/11] All sizes are now multiplied by 10, except for primops -(which have sizes like 1 or 4. This makes primops look fantastically -cheap, and seems to be almost unversally beneficial. Done partly as a -result of #4978. - -Note [Do not inline top-level bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The FloatOut pass has gone to some trouble to float out calls to 'error' -and similar friends. See Note [Bottoming floats] in SetLevels. -Do not re-inline them! But we *do* still inline if they are very small -(the uncondInline stuff). - -Note [INLINE for small functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider {-# INLINE f #-} - f x = Just x - g y = f y -Then f's RHS is no larger than its LHS, so we should inline it into -even the most boring context. In general, f the function is -sufficiently small that its body is as small as the call itself, the -inline unconditionally, regardless of how boring the context is. - -Things to note: - -(1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr) - than the thing it's replacing. Notice that - (f x) --> (g 3) -- YES, unconditionally - (f x) --> x : [] -- YES, *even though* there are two - -- arguments to the cons - x --> g 3 -- NO - x --> Just v -- NO - - It's very important not to unconditionally replace a variable by - a non-atomic term. - -(2) We do this even if the thing isn't saturated, else we end up with the - silly situation that - f x y = x - ...map (f 3)... - doesn't inline. Even in a boring context, inlining without being - saturated will give a lambda instead of a PAP, and will be more - efficient at runtime. - -(3) However, when the function's arity > 0, we do insist that it - has at least one value argument at the call site. (This check is - made in the UnfWhen case of callSiteInline.) Otherwise we find this: - f = /\a \x:a. x - d = /\b. MkD (f b) - If we inline f here we get - d = /\b. MkD (\x:b. x) - and then prepareRhs floats out the argument, abstracting the type - variables, so we end up with the original again! - -(4) We must be much more cautious about arity-zero things. Consider - let x = y +# z in ... - In *size* terms primops look very small, because the generate a - single instruction, but we do not want to unconditionally replace - every occurrence of x with (y +# z). So we only do the - unconditional-inline thing for *trivial* expressions. - - NB: you might think that PostInlineUnconditionally would do this - but it doesn't fire for top-level things; see SimplUtils - Note [Top level and postInlineUnconditionally] --} - -uncondInline :: CoreExpr -> Arity -> Int -> Bool --- Inline unconditionally if there no size increase --- Size of call is arity (+1 for the function) --- See Note [INLINE for small functions] -uncondInline rhs arity size - | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1) - | otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4) - -sizeExpr :: DynFlags - -> Int -- Bomb out if it gets bigger than this - -> [Id] -- Arguments; we're interested in which of these - -- get case'd - -> CoreExpr - -> ExprSize - --- Note [Computing the size of an expression] - -sizeExpr dflags bOMB_OUT_SIZE top_args expr - = size_up expr - where - size_up (Cast e _) = size_up e - size_up (Tick _ e) = size_up e - size_up (Type _) = sizeZero -- Types cost nothing - size_up (Coercion _) = sizeZero - size_up (Lit lit) = sizeN (litSize lit) - size_up (Var f) | isRealWorldId f = sizeZero - -- Make sure we get constructor discounts even - -- on nullary constructors - | otherwise = size_up_call f [] 0 - - size_up (App fun arg) - | isTyCoArg arg = size_up fun - | otherwise = size_up arg `addSizeNSD` - size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0) - - size_up (Lam b e) - | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10) - | otherwise = size_up e - - size_up (Let (NonRec binder rhs) body) - = size_up_rhs (binder, rhs) `addSizeNSD` - size_up body `addSizeN` - size_up_alloc binder - - size_up (Let (Rec pairs) body) - = foldr (addSizeNSD . size_up_rhs) - (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) - pairs - - size_up (Case e _ _ alts) - | null alts - = size_up e -- case e of {} never returns, so take size of scrutinee - - size_up (Case e _ _ alts) - -- Now alts is non-empty - | Just v <- is_top_arg e -- We are scrutinising an argument variable - = let - alt_sizes = map size_up_alt alts - - -- alts_size tries to compute a good discount for - -- the case when we are scrutinising an argument variable - alts_size (SizeIs tot tot_disc tot_scrut) - -- Size of all alternatives - (SizeIs max _ _) - -- Size of biggest alternative - = SizeIs tot (unitBag (v, 20 + tot - max) - `unionBags` tot_disc) tot_scrut - -- If the variable is known, we produce a - -- discount that will take us back to 'max', - -- the size of the largest alternative The - -- 1+ is a little discount for reduced - -- allocation in the caller - -- - -- Notice though, that we return tot_disc, - -- the total discount from all branches. I - -- think that's right. - - alts_size tot_size _ = tot_size - in - alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty - (foldr1 maxSize alt_sizes) - -- Good to inline if an arg is scrutinised, because - -- that may eliminate allocation in the caller - -- And it eliminates the case itself - where - is_top_arg (Var v) | v `elem` top_args = Just v - is_top_arg (Cast e _) = is_top_arg e - is_top_arg _ = Nothing - - - size_up (Case e _ _ alts) = size_up e `addSizeNSD` - foldr (addAltSize . size_up_alt) case_size alts - where - case_size - | is_inline_scrut e, not (lengthExceeds alts 1) = sizeN (-10) - | otherwise = sizeZero - -- Normally we don't charge for the case itself, but - -- we charge one per alternative (see size_up_alt, - -- below) to account for the cost of the info table - -- and comparisons. - -- - -- However, in certain cases (see is_inline_scrut - -- below), no code is generated for the case unless - -- there are multiple alts. In these cases we - -- subtract one, making the first alt free. - -- e.g. case x# +# y# of _ -> ... should cost 1 - -- case touch# x# of _ -> ... should cost 0 - -- (see #4978) - -- - -- I would like to not have the "not (lengthExceeds alts 1)" - -- condition above, but without that some programs got worse - -- (spectral/hartel/event and spectral/para). I don't fully - -- understand why. (SDM 24/5/11) - - -- unboxed variables, inline primops and unsafe foreign calls - -- are all "inline" things: - is_inline_scrut (Var v) = isUnliftedType (idType v) - is_inline_scrut scrut - | (Var f, _) <- collectArgs scrut - = case idDetails f of - FCallId fc -> not (isSafeForeignCall fc) - PrimOpId op -> not (primOpOutOfLine op) - _other -> False - | otherwise - = False - - size_up_rhs (bndr, rhs) - | Just join_arity <- isJoinId_maybe bndr - -- Skip arguments to join point - , (_bndrs, body) <- collectNBinders join_arity rhs - = size_up body - | otherwise - = size_up rhs - - ------------ - -- size_up_app is used when there's ONE OR MORE value args - size_up_app (App fun arg) args voids - | isTyCoArg arg = size_up_app fun args voids - | isRealWorldExpr arg = size_up_app fun (arg:args) (voids + 1) - | otherwise = size_up arg `addSizeNSD` - size_up_app fun (arg:args) voids - size_up_app (Var fun) args voids = size_up_call fun args voids - size_up_app (Tick _ expr) args voids = size_up_app expr args voids - size_up_app (Cast expr _) args voids = size_up_app expr args voids - size_up_app other args voids = size_up other `addSizeN` - callSize (length args) voids - -- if the lhs is not an App or a Var, or an invisible thing like a - -- Tick or Cast, then we should charge for a complete call plus the - -- size of the lhs itself. - - ------------ - size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize - size_up_call fun val_args voids - = case idDetails fun of - FCallId _ -> sizeN (callSize (length val_args) voids) - DataConWorkId dc -> conSize dc (length val_args) - PrimOpId op -> primOpSize op (length val_args) - ClassOpId _ -> classOpSize dflags top_args val_args - _ -> funSize dflags top_args fun (length val_args) voids - - ------------ - size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 - -- Don't charge for args, so that wrappers look cheap - -- (See comments about wrappers with Case) - -- - -- IMPORATANT: *do* charge 1 for the alternative, else we - -- find that giant case nests are treated as practically free - -- A good example is Foreign.C.Error.errnoToIOError - - ------------ - -- Cost to allocate binding with given binder - size_up_alloc bndr - | isTyVar bndr -- Doesn't exist at runtime - || isJoinId bndr -- Not allocated at all - || isUnliftedType (idType bndr) -- Doesn't live in heap - = 0 - | otherwise - = 10 - - ------------ - -- These addSize things have to be here because - -- I don't want to give them bOMB_OUT_SIZE as an argument - addSizeN TooBig _ = TooBig - addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n + m) xs d - - -- addAltSize is used to add the sizes of case alternatives - addAltSize TooBig _ = TooBig - addAltSize _ TooBig = TooBig - addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) - = mkSizeIs bOMB_OUT_SIZE (n1 + n2) - (xs `unionBags` ys) - (d1 + d2) -- Note [addAltSize result discounts] - - -- This variant ignores the result discount from its LEFT argument - -- It's used when the second argument isn't part of the result - addSizeNSD TooBig _ = TooBig - addSizeNSD _ TooBig = TooBig - addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2) - = mkSizeIs bOMB_OUT_SIZE (n1 + n2) - (xs `unionBags` ys) - d2 -- Ignore d1 - - isRealWorldId id = idType id `eqType` realWorldStatePrimTy - - -- an expression of type State# RealWorld must be a variable - isRealWorldExpr (Var id) = isRealWorldId id - isRealWorldExpr (Tick _ e) = isRealWorldExpr e - isRealWorldExpr _ = False - --- | Finds a nominal size of a string literal. -litSize :: Literal -> Int --- Used by CoreUnfold.sizeExpr -litSize (LitInteger {}) = 100 -- Note [Size of literal integers] -litSize (MachStr str) = 10 + 10 * ((BS.length str + 3) `div` 4) - -- If size could be 0 then @f "x"@ might be too small - -- [Sept03: make literal strings a bit bigger to avoid fruitless - -- duplication of little strings] -litSize _other = 0 -- Must match size of nullary constructors - -- Key point: if x |-> 4, then x must inline unconditionally - -- (eg via case binding) - -classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize --- See Note [Conlike is interesting] -classOpSize _ _ [] - = sizeZero -classOpSize dflags top_args (arg1 : other_args) - = SizeIs size arg_discount 0 - where - size = 20 + (10 * length other_args) - -- If the class op is scrutinising a lambda bound dictionary then - -- give it a discount, to encourage the inlining of this function - -- The actual discount is rather arbitrarily chosen - arg_discount = case arg1 of - Var dict | dict `elem` top_args - -> unitBag (dict, ufDictDiscount dflags) - _other -> emptyBag - --- | The size of a function call -callSize - :: Int -- ^ number of value args - -> Int -- ^ number of value args that are void - -> Int -callSize n_val_args voids = 10 * (1 + n_val_args - voids) - -- The 1+ is for the function itself - -- Add 1 for each non-trivial arg; - -- the allocation cost, as in let(rec) - --- | The size of a jump to a join point -jumpSize - :: Int -- ^ number of value args - -> Int -- ^ number of value args that are void - -> Int -jumpSize n_val_args voids = 2 * (1 + n_val_args - voids) - -- A jump is 20% the size of a function call. Making jumps free reopens - -- bug #6048, but making them any more expensive loses a 21% improvement in - -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a - -- better solution? - -funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize --- Size for functions that are not constructors or primops --- Note [Function applications] -funSize dflags top_args fun n_val_args voids - | fun `hasKey` buildIdKey = buildSize - | fun `hasKey` augmentIdKey = augmentSize - | otherwise = SizeIs size arg_discount res_discount - where - some_val_args = n_val_args > 0 - is_join = isJoinId fun - - size | is_join = jumpSize n_val_args voids - | not some_val_args = 0 - | otherwise = callSize n_val_args voids - - -- DISCOUNTS - -- See Note [Function and non-function discounts] - arg_discount | some_val_args && fun `elem` top_args - = unitBag (fun, ufFunAppDiscount dflags) - | otherwise = emptyBag - -- If the function is an argument and is applied - -- to some values, give it an arg-discount - - res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags - | otherwise = 0 - -- If the function is partially applied, show a result discount --- XXX maybe behave like ConSize for eval'd variable - -conSize :: DataCon -> Int -> ExprSize -conSize dc n_val_args - | n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables - --- See Note [Unboxed tuple size and result discount] - | isUnboxedTupleCon dc = SizeIs 0 emptyBag (10 * (1 + n_val_args)) - --- See Note [Constructor size and result discount] - | otherwise = SizeIs 10 emptyBag (10 * (1 + n_val_args)) - --- XXX still looks to large to me - -{- -Note [Constructor size and result discount] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Treat a constructors application as size 10, regardless of how many -arguments it has; we are keen to expose them (and we charge separately -for their args). We can't treat them as size zero, else we find that -(Just x) has size 0, which is the same as a lone variable; and hence -'v' will always be replaced by (Just x), where v is bound to Just x. - -The "result discount" is applied if the result of the call is -scrutinised (say by a case). For a constructor application that will -mean the constructor application will disappear, so we don't need to -charge it to the function. So the discount should at least match the -cost of the constructor application, namely 10. But to give a bit -of extra incentive we give a discount of 10*(1 + n_val_args). - -Simon M tried a MUCH bigger discount: (10 * (10 + n_val_args)), -and said it was an "unambiguous win", but its terribly dangerous -because a function with many many case branches, each finishing with -a constructor, can have an arbitrarily large discount. This led to -terrible code bloat: see Trac #6099. - -Note [Unboxed tuple size and result discount] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -However, unboxed tuples count as size zero. I found occasions where we had - f x y z = case op# x y z of { s -> (# s, () #) } -and f wasn't getting inlined. - -I tried giving unboxed tuples a *result discount* of zero (see the -commented-out line). Why? When returned as a result they do not -allocate, so maybe we don't want to charge so much for them If you -have a non-zero discount here, we find that workers often get inlined -back into wrappers, because it look like - f x = case $wf x of (# a,b #) -> (a,b) -and we are keener because of the case. However while this change -shrank binary sizes by 0.5% it also made spectral/boyer allocate 5% -more. All other changes were very small. So it's not a big deal but I -didn't adopt the idea. - -Note [Function and non-function discounts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want a discount if the function is applied. A good example is -monadic combinators with continuation arguments, where inlining is -quite important. - -But we don't want a big discount when a function is called many times -(see the detailed comments with Trac #6048) because if the function is -big it won't be inlined at its many call sites and no benefit results. -Indeed, we can get exponentially big inlinings this way; that is what -Trac #6048 is about. - -On the other hand, for data-valued arguments, if there are lots of -case expressions in the body, each one will get smaller if we apply -the function to a constructor application, so we *want* a big discount -if the argument is scrutinised by many case expressions. - -Conclusion: - - For functions, take the max of the discounts - - For data values, take the sum of the discounts - - -Note [Literal integer size] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Literal integers *can* be big (mkInteger [...coefficients...]), but -need not be (S# n). We just use an arbitrary big-ish constant here -so that, in particular, we don't inline top-level defns like - n = S# 5 -There's no point in doing so -- any optimisations will see the S# -through n's unfolding. Nor will a big size inhibit unfoldings functions -that mention a literal Integer, because the float-out pass will float -all those constants to top level. --} - -primOpSize :: PrimOp -> Int -> ExprSize -primOpSize op n_val_args - = if primOpOutOfLine op - then sizeN (op_size + n_val_args) - else sizeN op_size - where - op_size = primOpCodeSize op - - -buildSize :: ExprSize -buildSize = SizeIs 0 emptyBag 40 - -- We really want to inline applications of build - -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later) - -- Indeed, we should add a result_discount because build is - -- very like a constructor. We don't bother to check that the - -- build is saturated (it usually is). The "-2" discounts for the \c n, - -- The "4" is rather arbitrary. - -augmentSize :: ExprSize -augmentSize = SizeIs 0 emptyBag 40 - -- Ditto (augment t (\cn -> e) ys) should cost only the cost of - -- e plus ys. The -2 accounts for the \cn - --- When we return a lambda, give a discount if it's used (applied) -lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize -lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (ufFunAppDiscount dflags) -lamScrutDiscount _ TooBig = TooBig - -{- -Note [addAltSize result discounts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When adding the size of alternatives, we *add* the result discounts -too, rather than take the *maximum*. For a multi-branch case, this -gives a discount for each branch that returns a constructor, making us -keener to inline. I did try using 'max' instead, but it makes nofib -'rewrite' and 'puzzle' allocate significantly more, and didn't make -binary sizes shrink significantly either. - -Note [Discounts and thresholds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Constants for discounts and thesholds are defined in main/DynFlags, -all of form ufXxxx. They are: - -ufCreationThreshold - At a definition site, if the unfolding is bigger than this, we - may discard it altogether - -ufUseThreshold - At a call site, if the unfolding, less discounts, is smaller than - this, then it's small enough inline - -ufKeenessFactor - Factor by which the discounts are multiplied before - subtracting from size - -ufDictDiscount - The discount for each occurrence of a dictionary argument - as an argument of a class method. Should be pretty small - else big functions may get inlined - -ufFunAppDiscount - Discount for a function argument that is applied. Quite - large, because if we inline we avoid the higher-order call. - -ufDearOp - The size of a foreign call or not-dupable PrimOp - -ufVeryAggressive - If True, the compiler ignores all the thresholds and inlines very - aggressively. It still adheres to arity, simplifier phase control and - loop breakers. - - -Note [Function applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a function application (f a b) - - - If 'f' is an argument to the function being analysed, - and there's at least one value arg, record a FunAppDiscount for f - - - If the application if a PAP (arity > 2 in this example) - record a *result* discount (because inlining - with "extra" args in the call may mean that we now - get a saturated application) - -Code for manipulating sizes --} - --- | The size of an candidate expression for unfolding -data ExprSize - = TooBig - | SizeIs { _es_size_is :: {-# UNPACK #-} !Int -- ^ Size found - , _es_args :: !(Bag (Id,Int)) - -- ^ Arguments cased herein, and discount for each such - , _es_discount :: {-# UNPACK #-} !Int - -- ^ Size to subtract if result is scrutinised by a case - -- expression - } - -instance Outputable ExprSize where - ppr TooBig = text "TooBig" - ppr (SizeIs a _ c) = brackets (int a <+> int c) - --- subtract the discount before deciding whether to bale out. eg. we --- want to inline a large constructor application into a selector: --- tup = (a_1, ..., a_99) --- x = case tup of ... --- -mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize -mkSizeIs max n xs d | (n - d) > max = TooBig - | otherwise = SizeIs n xs d - -maxSize :: ExprSize -> ExprSize -> ExprSize -maxSize TooBig _ = TooBig -maxSize _ TooBig = TooBig -maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2 = s1 - | otherwise = s2 - -sizeZero :: ExprSize -sizeN :: Int -> ExprSize - -sizeZero = SizeIs 0 emptyBag 0 -sizeN n = SizeIs n emptyBag 0 - -{- -************************************************************************ -* * -\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} -* * -************************************************************************ - -We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that -we ``couldn't possibly use'' on the other side. Can be overridden w/ -flaggery. Just the same as smallEnoughToInline, except that it has no -actual arguments. --} - -couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool -couldBeSmallEnoughToInline dflags threshold rhs - = case sizeExpr dflags threshold [] body of - TooBig -> False - _ -> True - where - (_, body) = collectBinders rhs - ----------------- -smallEnoughToInline :: DynFlags -> Unfolding -> Bool -smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}}) - = size <= ufUseThreshold dflags -smallEnoughToInline _ _ - = False - ----------------- - -certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding --- Sees if the unfolding is pretty certain to inline --- If so, return a *stable* unfolding for it, that will always inline -certainlyWillInline dflags fn_info - = case unfoldingInfo fn_info of - CoreUnfolding { uf_tmpl = e, uf_guidance = g } - | loop_breaker -> Nothing -- Won't inline, so try w/w - | otherwise -> do_cunf e g -- Depends on size, so look at that - - DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense - -- to do so, and even if it is currently a - -- loop breaker, it may not be later - - _other_unf -> Nothing - - where - loop_breaker = isStrongLoopBreaker (occInfo fn_info) - fn_unf = unfoldingInfo fn_info - - do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding - do_cunf _ UnfNever = Nothing - do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable }) - -- INLINE functions have UnfWhen - - -- The UnfIfGoodArgs case seems important. If we w/w small functions - -- binary sizes go up by 10%! (This is with SplitObjs.) - -- I'm not totally sure why. - -- INLINABLE functions come via this path - -- See Note [certainlyWillInline: INLINABLE] - do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args }) - | not (null args) -- See Note [certainlyWillInline: be careful of thunks] - , case inlinePragmaSpec (inlinePragInfo fn_info) of - NoInline -> False -- NOINLINE; do not say certainlyWillInline! - _ -> True -- INLINE, INLINABLE, or nothing - , not (isBottomingSig (strictnessInfo fn_info)) - -- Do not unconditionally inline a bottoming functions even if - -- it seems smallish. We've carefully lifted it out to top level, - -- so we don't want to re-inline it. - , let arity = length args - , size - (10 * (arity + 1)) <= ufUseThreshold dflags - = Just (fn_unf { uf_src = InlineStable - , uf_guidance = UnfWhen { ug_arity = arity - , ug_unsat_ok = unSaturatedOk - , ug_boring_ok = inlineBoringOk expr } }) - -- Note the "unsaturatedOk". A function like f = \ab. a - -- will certainly inline, even if partially applied (f e), so we'd - -- better make sure that the transformed inlining has the same property - | otherwise - = Nothing - -{- Note [certainlyWillInline: be careful of thunks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't claim that thunks will certainly inline, because that risks work -duplication. Even if the work duplication is not great (eg is_cheap -holds), it can make a big difference in an inner loop In Trac #5623 we -found that the WorkWrap phase thought that - y = case x of F# v -> F# (v +# v) -was certainlyWillInline, so the addition got duplicated. - -Note [certainlyWillInline: INLINABLE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -certainlyWillInline /must/ return Nothing for a large INLINABLE thing, -even though we have a stable inlining, so that strictness w/w takes -place. It makes a big difference to efficiency, and the w/w pass knows -how to transfer the INLINABLE info to the worker; see WorkWrap -Note [Worker-wrapper for INLINABLE functions] - -************************************************************************ -* * -\subsection{callSiteInline} -* * -************************************************************************ - -This is the key function. It decides whether to inline a variable at a call site - -callSiteInline is used at call sites, so it is a bit more generous. -It's a very important function that embodies lots of heuristics. -A non-WHNF can be inlined if it doesn't occur inside a lambda, -and occurs exactly once or - occurs once in each branch of a case and is small - -If the thing is in WHNF, there's no danger of duplicating work, -so we can inline if it occurs once, or is small - -NOTE: we don't want to inline top-level functions that always diverge. -It just makes the code bigger. Tt turns out that the convenient way to prevent -them inlining is to give them a NOINLINE pragma, which we do in -StrictAnal.addStrictnessInfoToTopId --} - -callSiteInline :: DynFlags - -> Id -- The Id - -> Bool -- True <=> unfolding is active - -> Bool -- True if there are no arguments at all (incl type args) - -> [ArgSummary] -- One for each value arg; True if it is interesting - -> CallCtxt -- True <=> continuation is interesting - -> Maybe CoreExpr -- Unfolding, if any - -data ArgSummary = TrivArg -- Nothing interesting - | NonTrivArg -- Arg has structure - | ValueArg -- Arg is a con-app or PAP - -- ..or con-like. Note [Conlike is interesting] - -instance Outputable ArgSummary where - ppr TrivArg = text "TrivArg" - ppr NonTrivArg = text "NonTrivArg" - ppr ValueArg = text "ValueArg" - -nonTriv :: ArgSummary -> Bool -nonTriv TrivArg = False -nonTriv _ = True - -data CallCtxt - = BoringCtxt - | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] - | DiscArgCtxt -- Argument of a function with non-zero arg discount - | RuleArgCtxt -- We are somewhere in the argument of a function with rules - - | ValAppCtxt -- We're applied to at least one value arg - -- This arises when we have ((f x |> co) y) - -- Then the (f x) has argument 'x' but in a ValAppCtxt - - | CaseCtxt -- We're the scrutinee of a case - -- that decomposes its scrutinee - -instance Outputable CallCtxt where - ppr CaseCtxt = text "CaseCtxt" - ppr ValAppCtxt = text "ValAppCtxt" - ppr BoringCtxt = text "BoringCtxt" - ppr RhsCtxt = text "RhsCtxt" - ppr DiscArgCtxt = text "DiscArgCtxt" - ppr RuleArgCtxt = text "RuleArgCtxt" - -callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info - = case idUnfolding id of - -- idUnfolding checks for loop-breakers, returning NoUnfolding - -- Things with an INLINE pragma may have an unfolding *and* - -- be a loop breaker (maybe the knot is not yet untied) - CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top - , uf_is_work_free = is_wf - , uf_guidance = guidance, uf_expandable = is_exp } - | active_unfolding -> tryUnfolding dflags id lone_variable - arg_infos cont_info unf_template is_top - is_wf is_exp guidance - | otherwise -> traceInline dflags "Inactive unfolding:" (ppr id) Nothing - NoUnfolding -> Nothing - BootUnfolding -> Nothing - OtherCon {} -> Nothing - DFunUnfolding {} -> Nothing -- Never unfold a DFun - -traceInline :: DynFlags -> String -> SDoc -> a -> a -traceInline dflags str doc result - | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags - = pprTrace str doc result - | otherwise - = result - -tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt - -> CoreExpr -> Bool -> Bool -> Bool -> UnfoldingGuidance - -> Maybe CoreExpr -tryUnfolding dflags id lone_variable - arg_infos cont_info unf_template is_top - is_wf is_exp guidance - = case guidance of - UnfNever -> traceInline dflags str (text "UnfNever") Nothing - - UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - | enough_args && (boring_ok || some_benefit || ufVeryAggressive dflags) - -- See Note [INLINE for small functions (3)] - -> traceInline dflags str (mk_doc some_benefit empty True) (Just unf_template) - | otherwise - -> traceInline dflags str (mk_doc some_benefit empty False) Nothing - where - some_benefit = calc_some_benefit uf_arity - enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0) - - UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } - | ufVeryAggressive dflags - -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template) - | is_wf && some_benefit && small_enough - -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template) - | otherwise - -> traceInline dflags str (mk_doc some_benefit extra_doc False) Nothing - where - some_benefit = calc_some_benefit (length arg_discounts) - extra_doc = text "discounted size =" <+> int discounted_size - discounted_size = size - discount - small_enough = discounted_size <= ufUseThreshold dflags - discount = computeDiscount dflags arg_discounts - res_discount arg_infos cont_info - - where - mk_doc some_benefit extra_doc yes_or_no - = vcat [ text "arg infos" <+> ppr arg_infos - , text "interesting continuation" <+> ppr cont_info - , text "some_benefit" <+> ppr some_benefit - , text "is exp:" <+> ppr is_exp - , text "is work-free:" <+> ppr is_wf - , text "guidance" <+> ppr guidance - , extra_doc - , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] - - str = "Considering inlining: " ++ showSDocDump dflags (ppr id) - n_val_args = length arg_infos - - -- some_benefit is used when the RHS is small enough - -- and the call has enough (or too many) value - -- arguments (ie n_val_args >= arity). But there must - -- be *something* interesting about some argument, or the - -- result context, to make it worth inlining - calc_some_benefit :: Arity -> Bool -- The Arity is the number of args - -- expected by the unfolding - calc_some_benefit uf_arity - | not saturated = interesting_args -- Under-saturated - -- Note [Unsaturated applications] - | otherwise = interesting_args -- Saturated or over-saturated - || interesting_call - where - saturated = n_val_args >= uf_arity - over_saturated = n_val_args > uf_arity - interesting_args = any nonTriv arg_infos - -- NB: (any nonTriv arg_infos) looks at the - -- over-saturated args too which is "wrong"; - -- but if over-saturated we inline anyway. - - interesting_call - | over_saturated - = True - | otherwise - = case cont_info of - CaseCtxt -> not (lone_variable && is_wf) -- Note [Lone variables] - ValAppCtxt -> True -- Note [Cast then apply] - RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts] - DiscArgCtxt -> uf_arity > 0 -- - RhsCtxt -> uf_arity > 0 -- - _ -> not is_top && uf_arity > 0 -- Note [Nested functions] - -- Note [Inlining in ArgCtxt] - -{- -Note [Unfold into lazy contexts], Note [RHS of lets] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the call is the argument of a function with a RULE, or the RHS of a let, -we are a little bit keener to inline. For example - f y = (y,y,y) - g y = let x = f y in ...(case x of (a,b,c) -> ...) ... -We'd inline 'f' if the call was in a case context, and it kind-of-is, -only we can't see it. Also - x = f v -could be expensive whereas - x = case v of (a,b) -> a -is patently cheap and may allow more eta expansion. -So we treat the RHS of a let as not-totally-boring. - -Note [Unsaturated applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When a call is not saturated, we *still* inline if one of the -arguments has interesting structure. That's sometimes very important. -A good example is the Ord instance for Bool in Base: - - Rec { - $fOrdBool =GHC.Classes.D:Ord - @ Bool - ... - $cmin_ajX - - $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool - $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool - } - -But the defn of GHC.Classes.$dmmin is: - - $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a - {- Arity: 3, HasNoCafRefs, Strictness: SLL, - Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> - case @ a GHC.Classes.<= @ a $dOrd x y of wild { - GHC.Types.False -> y GHC.Types.True -> x }) -} - -We *really* want to inline $dmmin, even though it has arity 3, in -order to unravel the recursion. - - -Note [Things to watch] -~~~~~~~~~~~~~~~~~~~~~~ -* { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } - Assume x is exported, so not inlined unconditionally. - Then we want x to inline unconditionally; no reason for it - not to, and doing so avoids an indirection. - -* { x = I# 3; ....f x.... } - Make sure that x does not inline unconditionally! - Lest we get extra allocation. - -Note [Inlining an InlineRule] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An InlineRules is used for - (a) programmer INLINE pragmas - (b) inlinings from worker/wrapper - -For (a) the RHS may be large, and our contract is that we *only* inline -when the function is applied to all the arguments on the LHS of the -source-code defn. (The uf_arity in the rule.) - -However for worker/wrapper it may be worth inlining even if the -arity is not satisfied (as we do in the CoreUnfolding case) so we don't -require saturation. - - -Note [Nested functions] -~~~~~~~~~~~~~~~~~~~~~~~ -If a function has a nested defn we also record some-benefit, on the -grounds that we are often able to eliminate the binding, and hence the -allocation, for the function altogether; this is good for join points. -But this only makes sense for *functions*; inlining a constructor -doesn't help allocation unless the result is scrutinised. UNLESS the -constructor occurs just once, albeit possibly in multiple case -branches. Then inlining it doesn't increase allocation, but it does -increase the chance that the constructor won't be allocated at all in -the branches that don't use it. - -Note [Cast then apply] -~~~~~~~~~~~~~~~~~~~~~~ -Consider - myIndex = __inline_me ( (/\a. ) |> co ) - co :: (forall a. a -> a) ~ (forall a. T a) - ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ... - -We need to inline myIndex to unravel this; but the actual call (myIndex a) has -no value arguments. The ValAppCtxt gives it enough incentive to inline. - -Note [Inlining in ArgCtxt] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The condition (arity > 0) here is very important, because otherwise -we end up inlining top-level stuff into useless places; eg - x = I# 3# - f = \y. g x -This can make a very big difference: it adds 16% to nofib 'integer' allocs, -and 20% to 'power'. - -At one stage I replaced this condition by 'True' (leading to the above -slow-down). The motivation was test eyeball/inline1.hs; but that seems -to work ok now. - -NOTE: arguably, we should inline in ArgCtxt only if the result of the -call is at least CONLIKE. At least for the cases where we use ArgCtxt -for the RHS of a 'let', we only profit from the inlining if we get a -CONLIKE thing (modulo lets). - -Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables] -~~~~~~~~~~~~~~~~~~~~~ which appears below -The "lone-variable" case is important. I spent ages messing about -with unsatisfactory variants, but this is nice. The idea is that if a -variable appears all alone - - as an arg of lazy fn, or rhs BoringCtxt - as scrutinee of a case CaseCtxt - as arg of a fn ArgCtxt -AND - it is bound to a cheap expression - -then we should not inline it (unless there is some other reason, -e.g. it is the sole occurrence). That is what is happening at -the use of 'lone_variable' in 'interesting_call'. - -Why? At least in the case-scrutinee situation, turning - let x = (a,b) in case x of y -> ... -into - let x = (a,b) in case (a,b) of y -> ... -and thence to - let x = (a,b) in let y = (a,b) in ... -is bad if the binding for x will remain. - -Another example: I discovered that strings -were getting inlined straight back into applications of 'error' -because the latter is strict. - s = "foo" - f = \x -> ...(error s)... - -Fundamentally such contexts should not encourage inlining because the -context can ``see'' the unfolding of the variable (e.g. case or a -RULE) so there's no gain. If the thing is bound to a value. - -However, watch out: - - * Consider this: - foo = _inline_ (\n. [n]) - bar = _inline_ (foo 20) - baz = \n. case bar of { (m:_) -> m + n } - Here we really want to inline 'bar' so that we can inline 'foo' - and the whole thing unravels as it should obviously do. This is - important: in the NDP project, 'bar' generates a closure data - structure rather than a list. - - So the non-inlining of lone_variables should only apply if the - unfolding is regarded as cheap; because that is when exprIsConApp_maybe - looks through the unfolding. Hence the "&& is_wf" in the - InlineRule branch. - - * Even a type application or coercion isn't a lone variable. - Consider - case $fMonadST @ RealWorld of { :DMonad a b c -> c } - We had better inline that sucker! The case won't see through it. - - For now, I'm treating treating a variable applied to types - in a *lazy* context "lone". The motivating example was - f = /\a. \x. BIG - g = /\a. \y. h (f a) - There's no advantage in inlining f here, and perhaps - a significant disadvantage. Hence some_val_args in the Stop case - -Note [Interaction of exprIsWorkFree and lone variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The lone-variable test says "don't inline if a case expression -scrutinises a lone variable whose unfolding is cheap". It's very -important that, under these circumstances, exprIsConApp_maybe -can spot a constructor application. So, for example, we don't -consider - let x = e in (x,x) -to be cheap, and that's good because exprIsConApp_maybe doesn't -think that expression is a constructor application. - -In the 'not (lone_variable && is_wf)' test, I used to test is_value -rather than is_wf, which was utterly wrong, because the above -expression responds True to exprIsHNF, which is what sets is_value. - -This kind of thing can occur if you have - - {-# INLINE foo #-} - foo = let x = e in (x,x) - -which Roman did. --} - -computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt - -> Int -computeDiscount dflags arg_discounts res_discount arg_infos cont_info - -- We multiple the raw discounts (args_discount and result_discount) - -- ty opt_UnfoldingKeenessFactor because the former have to do with - -- *size* whereas the discounts imply that there's some extra - -- *efficiency* to be gained (e.g. beta reductions, case reductions) - -- by inlining. - - = 10 -- Discount of 10 because the result replaces the call - -- so we count 10 for the function itself - - + 10 * length actual_arg_discounts - -- Discount of 10 for each arg supplied, - -- because the result replaces the call - - + round (ufKeenessFactor dflags * - fromIntegral (total_arg_discount + res_discount')) - where - actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos - total_arg_discount = sum actual_arg_discounts - - mk_arg_discount _ TrivArg = 0 - mk_arg_discount _ NonTrivArg = 10 - mk_arg_discount discount ValueArg = discount - - res_discount' - | LT <- arg_discounts `compareLength` arg_infos - = res_discount -- Over-saturated - | otherwise - = case cont_info of - BoringCtxt -> 0 - CaseCtxt -> res_discount -- Presumably a constructor - ValAppCtxt -> res_discount -- Presumably a function - _ -> 40 `min` res_discount - -- ToDo: this 40 `min` res_discount doesn't seem right - -- for DiscArgCtxt it shouldn't matter because the function will - -- get the arg discount for any non-triv arg - -- for RuleArgCtxt we do want to be keener to inline; but not only - -- constructor results - -- for RhsCtxt I suppose that exposing a data con is good in general - -- And 40 seems very arbitrary - -- - -- res_discount can be very large when a function returns - -- constructors; but we only want to invoke that large discount - -- when there's a case continuation. - -- Otherwise we, rather arbitrarily, threshold it. Yuk. - -- But we want to aovid inlining large functions that return - -- constructors into contexts that are simply "interesting" diff --git a/coreSyn/CoreUtils.hs b/coreSyn/CoreUtils.hs deleted file mode 100644 --- a/coreSyn/CoreUtils.hs +++ /dev/null @@ -1,2340 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Utility functions on @Core@ syntax --} - -{-# LANGUAGE CPP #-} - --- | Commonly useful utilites for manipulating the Core language -module CoreUtils ( - -- * Constructing expressions - mkCast, - mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, - bindNonRec, needsCaseBinding, - mkAltExpr, - - -- * Taking expressions apart - findDefault, addDefault, findAlt, isDefaultAlt, - mergeAlts, trimConArgs, - filterAlts, combineIdenticalAlts, refineDefaultAlt, - - -- * Properties of expressions - exprType, coreAltType, coreAltsType, isExprLevPoly, - exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, - getIdFromTrivialExpr_maybe, - exprIsCheap, exprIsExpandable, exprIsOk, CheapAppFun, - exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, - exprIsBig, exprIsConLike, - rhsIsStatic, isCheapApp, isExpandableApp, - exprIsLiteralString, exprIsTopLevelBindable, - - -- * Equality - cheapEqExpr, cheapEqExpr', eqExpr, - diffExpr, diffBinds, - - -- * Eta reduction - tryEtaReduce, - - -- * Manipulating data constructors and types - exprToType, exprToCoercion_maybe, - applyTypeToArgs, applyTypeToArg, - dataConRepInstPat, dataConRepFSInstPat, - isEmptyTy, - - -- * Working with ticks - stripTicksTop, stripTicksTopE, stripTicksTopT, - stripTicksE, stripTicksT, - - -- * StaticPtr - collectMakeStaticArgs, - - -- * Join points - isJoinBind - ) where - -#include "HsVersions.h" - -import CoreSyn -import PrelNames ( makeStaticName ) -import PprCore -import CoreFVs( exprFreeVars ) -import Var -import SrcLoc -import VarEnv -import VarSet -import Name -import Literal -import DataCon -import PrimOp -import Id -import IdInfo -import PrelNames( absentErrorIdKey ) -import Type -import TyCoRep( TyBinder(..) ) -import Coercion -import TyCon -import Unique -import Outputable -import TysPrim -import DynFlags -import FastString -import Maybes -import ListSetOps ( minusList ) -import BasicTypes ( Arity ) -import Platform -import Util -import Pair -import Data.Function ( on ) -import Data.List -import Data.Ord ( comparing ) -import OrdList - -{- -************************************************************************ -* * -\subsection{Find the type of a Core atom/expression} -* * -************************************************************************ --} - -exprType :: CoreExpr -> Type --- ^ Recover the type of a well-typed Core expression. Fails when --- applied to the actual 'CoreSyn.Type' expression as it cannot --- really be said to have a type -exprType (Var var) = idType var -exprType (Lit lit) = literalType lit -exprType (Coercion co) = coercionType co -exprType (Let bind body) - | NonRec tv rhs <- bind -- See Note [Type bindings] - , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) - | otherwise = exprType body -exprType (Case _ _ ty _) = ty -exprType (Cast _ co) = pSnd (coercionKind co) -exprType (Tick _ e) = exprType e -exprType (Lam binder expr) = mkLamType binder (exprType expr) -exprType e@(App _ _) - = case collectArgs e of - (fun, args) -> applyTypeToArgs e (exprType fun) args - -exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy - -coreAltType :: CoreAlt -> Type --- ^ Returns the type of the alternatives right hand side -coreAltType (_,bs,rhs) - | any bad_binder bs = expandTypeSynonyms ty - | otherwise = ty -- Note [Existential variables and silly type synonyms] - where - ty = exprType rhs - free_tvs = tyCoVarsOfType ty - bad_binder b = b `elemVarSet` free_tvs - -coreAltsType :: [CoreAlt] -> Type --- ^ Returns the type of the first alternative, which should be the same as for all alternatives -coreAltsType (alt:_) = coreAltType alt -coreAltsType [] = panic "corAltsType" - --- | Is this expression levity polymorphic? This should be the --- same as saying (isKindLevPoly . typeKind . exprType) but --- much faster. -isExprLevPoly :: CoreExpr -> Bool -isExprLevPoly = go - where - go (Var _) = False -- no levity-polymorphic binders - go (Lit _) = False -- no levity-polymorphic literals - go e@(App f _) | not (go_app f) = False - | otherwise = check_type e - go (Lam _ _) = False - go (Let _ e) = go e - go e@(Case {}) = check_type e -- checking type is fast - go e@(Cast {}) = check_type e - go (Tick _ e) = go e - go e@(Type {}) = pprPanic "isExprLevPoly ty" (ppr e) - go (Coercion {}) = False -- this case can happen in SetLevels - - check_type = isTypeLevPoly . exprType -- slow approach - - -- if the function is a variable (common case), check its - -- levityInfo. This might mean we don't need to look up and compute - -- on the type. Spec of these functions: return False if there is - -- no possibility, ever, of this expression becoming levity polymorphic, - -- no matter what it's applied to; return True otherwise. - -- returning True is always safe. See also Note [Levity info] in - -- IdInfo - go_app (Var id) = not (isNeverLevPolyId id) - go_app (Lit _) = False - go_app (App f _) = go_app f - go_app (Lam _ e) = go_app e - go_app (Let _ e) = go_app e - go_app (Case _ _ ty _) = resultIsLevPoly ty - go_app (Cast _ co) = resultIsLevPoly (pSnd $ coercionKind co) - go_app (Tick _ e) = go_app e - go_app e@(Type {}) = pprPanic "isExprLevPoly app ty" (ppr e) - go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e) - - -{- -Note [Type bindings] -~~~~~~~~~~~~~~~~~~~~ -Core does allow type bindings, although such bindings are -not much used, except in the output of the desuguarer. -Example: - let a = Int in (\x:a. x) -Given this, exprType must be careful to substitute 'a' in the -result type (Trac #8522). - -Note [Existential variables and silly type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = forall a. T (Funny a) - type Funny a = Bool - f :: T -> Bool - f (T x) = x - -Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. -That means that 'exprType' and 'coreAltsType' may give a result that *appears* -to mention an out-of-scope type variable. See Trac #3409 for a more real-world -example. - -Various possibilities suggest themselves: - - - Ignore the problem, and make Lint not complain about such variables - - - Expand all type synonyms (or at least all those that discard arguments) - This is tricky, because at least for top-level things we want to - retain the type the user originally specified. - - - Expand synonyms on the fly, when the problem arises. That is what - we are doing here. It's not too expensive, I think. - -Note that there might be existentially quantified coercion variables, too. --} - --- Not defined with applyTypeToArg because you can't print from CoreSyn. -applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type --- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. --- The first argument is just for debugging, and gives some context -applyTypeToArgs e op_ty args - = go op_ty args - where - go op_ty [] = op_ty - go op_ty (Type ty : args) = go_ty_args op_ty [ty] args - go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args - go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty - = go res_ty args - go _ _ = pprPanic "applyTypeToArgs" panic_msg - - -- go_ty_args: accumulate type arguments so we can - -- instantiate all at once with piResultTys - go_ty_args op_ty rev_tys (Type ty : args) - = go_ty_args op_ty (ty:rev_tys) args - go_ty_args op_ty rev_tys (Coercion co : args) - = go_ty_args op_ty (mkCoercionTy co : rev_tys) args - go_ty_args op_ty rev_tys args - = go (piResultTys op_ty (reverse rev_tys)) args - - panic_msg = vcat [ text "Expression:" <+> pprCoreExpr e - , text "Type:" <+> ppr op_ty - , text "Args:" <+> ppr args ] - - -{- -************************************************************************ -* * -\subsection{Attaching notes} -* * -************************************************************************ --} - --- | Wrap the given expression in the coercion safely, dropping --- identity coercions and coalescing nested coercions -mkCast :: CoreExpr -> Coercion -> CoreExpr -mkCast e co - | ASSERT2( coercionRole co == Representational - , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast") - <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) ) - isReflCo co - = e - -mkCast (Coercion e_co) co - | isCoercionType (pSnd (coercionKind co)) - -- The guard here checks that g has a (~#) on both sides, - -- otherwise decomposeCo fails. Can in principle happen - -- with unsafeCoerce - = Coercion (mkCoCast e_co co) - -mkCast (Cast expr co2) co - = WARN(let { Pair from_ty _to_ty = coercionKind co; - Pair _from_ty2 to_ty2 = coercionKind co2} in - not (from_ty `eqType` to_ty2), - vcat ([ text "expr:" <+> ppr expr - , text "co2:" <+> ppr co2 - , text "co:" <+> ppr co ]) ) - mkCast expr (mkTransCo co2 co) - -mkCast (Tick t expr) co - = Tick t (mkCast expr co) - -mkCast expr co - = let Pair from_ty _to_ty = coercionKind co in - WARN( not (from_ty `eqType` exprType expr), - text "Trying to coerce" <+> text "(" <> ppr expr - $$ text "::" <+> ppr (exprType expr) <> text ")" - $$ ppr co $$ ppr (coercionType co) ) - (Cast expr co) - --- | Wraps the given expression in the source annotation, dropping the --- annotation if possible. -mkTick :: Tickish Id -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' id id orig_expr - where - -- Some ticks (cost-centres) can be split in two, with the - -- non-counting part having laxer placement properties. - canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t - - mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through) - -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with) - -> CoreExpr -- ^ current expression - -> CoreExpr - mkTick' top rest expr = case expr of - - -- Never tick primitive string literals. These should ultimately float up to - -- the top-level where they must be unadorned. See Note - -- [CoreSyn top-level string literals] for details. - _ | exprIsLiteralString expr -> expr - - -- Cost centre ticks should never be reordered relative to each - -- other. Therefore we can stop whenever two collide. - Tick t2 e - | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr - - -- Otherwise we assume that ticks of different placements float - -- through each other. - | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e - - -- For annotations this is where we make sure to not introduce - -- redundant ticks. - | tickishContains t t2 -> mkTick' top rest e - | tickishContains t2 t -> orig_expr - | otherwise -> mkTick' top (rest . Tick t2) e - - -- Ticks don't care about types, so we just float all ticks - -- through them. Note that it's not enough to check for these - -- cases top-level. While mkTick will never produce Core with type - -- expressions below ticks, such constructs can be the result of - -- unfoldings. We therefore make an effort to put everything into - -- the right place no matter what we start with. - Cast e co -> mkTick' (top . flip Cast co) rest e - Coercion co -> Coercion co - - Lam x e - -- Always float through type lambdas. Even for non-type lambdas, - -- floating is allowed for all but the most strict placement rule. - | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime - -> mkTick' (top . Lam x) rest e - - -- If it is both counting and scoped, we split the tick into its - -- two components, often allowing us to keep the counting tick on - -- the outside of the lambda and push the scoped tick inside. - -- The point of this is that the counting tick can probably be - -- floated, and the lambda may then be in a position to be - -- beta-reduced. - | canSplit - -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e - - App f arg - -- Always float through type applications. - | not (isRuntimeArg arg) - -> mkTick' (top . flip App arg) rest f - - -- We can also float through constructor applications, placement - -- permitting. Again we can split. - | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) - -> if tickishPlace t == PlaceCostCentre - then top $ rest $ tickHNFArgs t expr - else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr - - Var x - | notFunction && tickishPlace t == PlaceCostCentre - -> orig_expr - | notFunction && canSplit - -> top $ Tick (mkNoScope t) $ rest expr - where - -- SCCs can be eliminated on variables provided the variable - -- is not a function. In these cases the SCC makes no difference: - -- the cost of evaluating the variable will be attributed to its - -- definition site. When the variable refers to a function, however, - -- an SCC annotation on the variable affects the cost-centre stack - -- when the function is called, so we must retain those. - notFunction = not (isFunTy (idType x)) - - Lit{} - | tickishPlace t == PlaceCostCentre - -> orig_expr - - -- Catch-all: Annotate where we stand - _any -> top $ Tick t $ rest expr - -mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr -mkTicks ticks expr = foldr mkTick expr ticks - -isSaturatedConApp :: CoreExpr -> Bool -isSaturatedConApp e = go e [] - where go (App f a) as = go f (a:as) - go (Var fun) args - = isConLikeId fun && idArity fun == valArgCount args - go (Cast f _) as = go f as - go _ _ = False - -mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr -mkTickNoHNF t e - | exprIsHNF e = tickHNFArgs t e - | otherwise = mkTick t e - --- push a tick into the arguments of a HNF (call or constructor app) -tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr -tickHNFArgs t e = push t e - where - push t (App f (Type u)) = App (push t f) (Type u) - push t (App f arg) = App (push t f) (mkTick t arg) - push _t e = e - --- | Strip ticks satisfying a predicate from top of an expression -stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b) -stripTicksTop p = go [] - where go ts (Tick t e) | p t = go (t:ts) e - go ts other = (reverse ts, other) - --- | Strip ticks satisfying a predicate from top of an expression, --- returning the remaining expression -stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b -stripTicksTopE p = go - where go (Tick t e) | p t = go e - go other = other - --- | Strip ticks satisfying a predicate from top of an expression, --- returning the ticks -stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] -stripTicksTopT p = go [] - where go ts (Tick t e) | p t = go (t:ts) e - go ts _ = ts - --- | Completely strip ticks satisfying a predicate from an --- expression. Note this is O(n) in the size of the expression! -stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b -stripTicksE p expr = go expr - where go (App e a) = App (go e) (go a) - go (Lam b e) = Lam b (go e) - go (Let b e) = Let (go_bs b) (go e) - go (Case e b t as) = Case (go e) b t (map go_a as) - go (Cast e c) = Cast (go e) c - go (Tick t e) - | p t = go e - | otherwise = Tick t (go e) - go other = other - go_bs (NonRec b e) = NonRec b (go e) - go_bs (Rec bs) = Rec (map go_b bs) - go_b (b, e) = (b, go e) - go_a (c,bs,e) = (c,bs, go e) - -stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] -stripTicksT p expr = fromOL $ go expr - where go (App e a) = go e `appOL` go a - go (Lam _ e) = go e - go (Let b e) = go_bs b `appOL` go e - go (Case e _ _ as) = go e `appOL` concatOL (map go_a as) - go (Cast e _) = go e - go (Tick t e) - | p t = t `consOL` go e - | otherwise = go e - go _ = nilOL - go_bs (NonRec _ e) = go e - go_bs (Rec bs) = concatOL (map go_b bs) - go_b (_, e) = go e - go_a (_, _, e) = go e - -{- -************************************************************************ -* * -\subsection{Other expression construction} -* * -************************************************************************ --} - -bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr --- ^ @bindNonRec x r b@ produces either: --- --- > let x = r in b --- --- or: --- --- > case r of x { _DEFAULT_ -> b } --- --- depending on whether we have to use a @case@ or @let@ --- binding for the expression (see 'needsCaseBinding'). --- It's used by the desugarer to avoid building bindings --- that give Core Lint a heart attack, although actually --- the simplifier deals with them perfectly well. See --- also 'MkCore.mkCoreLet' -bindNonRec bndr rhs body - | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)] - | otherwise = Let (NonRec bndr rhs) body - --- | Tests whether we have to use a @case@ rather than @let@ binding for this expression --- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant" -needsCaseBinding :: Type -> CoreExpr -> Bool -needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs) - -- Make a case expression instead of a let - -- These can arise either from the desugarer, - -- or from beta reductions: (\x.e) (x +# y) - -mkAltExpr :: AltCon -- ^ Case alternative constructor - -> [CoreBndr] -- ^ Things bound by the pattern match - -> [Type] -- ^ The type arguments to the case alternative - -> CoreExpr --- ^ This guy constructs the value that the scrutinee must have --- given that you are in one particular branch of a case -mkAltExpr (DataAlt con) args inst_tys - = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) -mkAltExpr (LitAlt lit) [] [] - = Lit lit -mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" -mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" - -{- -************************************************************************ -* * - Operations oer case alternatives -* * -************************************************************************ - -The default alternative must be first, if it exists at all. -This makes it easy to find, though it makes matching marginally harder. --} - --- | Extract the default case alternative -findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b) -findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) -findDefault alts = (alts, Nothing) - -addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)] -addDefault alts Nothing = alts -addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts - -isDefaultAlt :: (AltCon, a, b) -> Bool -isDefaultAlt (DEFAULT, _, _) = True -isDefaultAlt _ = False - --- | Find the case alternative corresponding to a particular --- constructor: panics if no such constructor exists -findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) - -- A "Nothing" result *is* legitmiate - -- See Note [Unreachable code] -findAlt con alts - = case alts of - (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt) - _ -> go alts Nothing - where - go [] deflt = deflt - go (alt@(con1,_,_) : alts) deflt - = case con `cmpAltCon` con1 of - LT -> deflt -- Missed it already; the alts are in increasing order - EQ -> Just alt - GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt - -{- Note [Unreachable code] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible (although unusual) for GHC to find a case expression -that cannot match. For example: - - data Col = Red | Green | Blue - x = Red - f v = case x of - Red -> ... - _ -> ...(case x of { Green -> e1; Blue -> e2 })... - -Suppose that for some silly reason, x isn't substituted in the case -expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff -gets in the way; cf Trac #3118.) Then the full-lazines pass might produce -this - - x = Red - lvl = case x of { Green -> e1; Blue -> e2 }) - f v = case x of - Red -> ... - _ -> ...lvl... - -Now if x gets inlined, we won't be able to find a matching alternative -for 'Red'. That's because 'lvl' is unreachable. So rather than crashing -we generate (error "Inaccessible alternative"). - -Similar things can happen (augmented by GADTs) when the Simplifier -filters down the matching alternatives in Simplify.rebuildCase. --} - ---------------------------------- -mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)] --- ^ Merge alternatives preserving order; alternatives in --- the first argument shadow ones in the second -mergeAlts [] as2 = as2 -mergeAlts as1 [] = as1 -mergeAlts (a1:as1) (a2:as2) - = case a1 `cmpAlt` a2 of - LT -> a1 : mergeAlts as1 (a2:as2) - EQ -> a1 : mergeAlts as1 as2 -- Discard a2 - GT -> a2 : mergeAlts (a1:as1) as2 - - ---------------------------------- -trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] --- ^ Given: --- --- > case (C a b x y) of --- > C b x y -> ... --- --- We want to drop the leading type argument of the scrutinee --- leaving the arguments to match against the pattern - -trimConArgs DEFAULT args = ASSERT( null args ) [] -trimConArgs (LitAlt _) args = ASSERT( null args ) [] -trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args - -filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities) - -> [Type] -- ^ And its type arguments - -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee - -> [(AltCon, [Var], a)] -- ^ Alternatives - -> ([AltCon], [(AltCon, [Var], a)]) - -- Returns: - -- 1. Constructors that will never be encountered by the - -- *default* case (if any). A superset of imposs_cons - -- 2. The new alternatives, trimmed by - -- a) remove imposs_cons - -- b) remove constructors which can't match because of GADTs - -- and with the DEFAULT expanded to a DataAlt if there is exactly - -- remaining constructor that can match - -- - -- NB: the final list of alternatives may be empty: - -- This is a tricky corner case. If the data type has no constructors, - -- which GHC allows, or if the imposs_cons covers all constructors (after taking - -- account of GADTs), then no alternatives can match. - -- - -- If callers need to preserve the invariant that there is always at least one branch - -- in a "case" statement then they will need to manually add a dummy case branch that just - -- calls "error" or similar. -filterAlts _tycon inst_tys imposs_cons alts - = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) - where - (alts_wo_default, maybe_deflt) = findDefault alts - alt_cons = [con | (con,_,_) <- alts_wo_default] - - trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default - - imposs_deflt_cons = nub (imposs_cons ++ alt_cons) - -- "imposs_deflt_cons" are handled - -- EITHER by the context, - -- OR by a non-DEFAULT branch in this case expression. - - impossible_alt :: [Type] -> (AltCon, a, b) -> Bool - impossible_alt _ (con, _, _) | con `elem` imposs_cons = True - impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con - impossible_alt _ _ = False - -refineDefaultAlt :: [Unique] -> TyCon -> [Type] - -> [AltCon] -- Constructors that cannot match the DEFAULT (if any) - -> [CoreAlt] - -> (Bool, [CoreAlt]) --- Refine the default alternative to a DataAlt, --- if there is a unique way to do so -refineDefaultAlt us tycon tys imposs_deflt_cons all_alts - | (DEFAULT,_,rhs) : rest_alts <- all_alts - , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. - , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: - -- case x of { DEFAULT -> e } - -- and we don't want to fill in a default for them! - , Just all_cons <- tyConDataCons_maybe tycon - , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type - impossible con = con `elem` imposs_data_cons || dataConCannotMatch tys con - = case filterOut impossible all_cons of - -- Eliminate the default alternative - -- altogether if it can't match: - [] -> (False, rest_alts) - - -- It matches exactly one constructor, so fill it in: - [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)]) - -- We need the mergeAlts to keep the alternatives in the right order - where - (ex_tvs, arg_ids) = dataConRepInstPat us con tys - - -- It matches more than one, so do nothing - _ -> (False, all_alts) - - | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon) - , not (isFamilyTyCon tycon || isAbstractTyCon tycon) - -- Check for no data constructors - -- This can legitimately happen for abstract types and type families, - -- so don't report that - = (False, all_alts) - - | otherwise -- The common case - = (False, all_alts) - -{- Note [Combine identical alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If several alternatives are identical, merge them into a single -DEFAULT alternative. I've occasionally seen this making a big -difference: - - case e of =====> case e of - C _ -> f x D v -> ....v.... - D v -> ....v.... DEFAULT -> f x - DEFAULT -> f x - -The point is that we merge common RHSs, at least for the DEFAULT case. -[One could do something more elaborate but I've never seen it needed.] -To avoid an expensive test, we just merge branches equal to the *first* -alternative; this picks up the common cases - a) all branches equal - b) some branches equal to the DEFAULT (which occurs first) - -The case where Combine Identical Alternatives transformation showed up -was like this (base/Foreign/C/Err/Error.hs): - - x | p `is` 1 -> e1 - | p `is` 2 -> e2 - ...etc... - -where @is@ was something like - - p `is` n = p /= (-1) && p == n - -This gave rise to a horrible sequence of cases - - case p of - (-1) -> $j p - 1 -> e1 - DEFAULT -> $j p - -and similarly in cascade for all the join points! - -NB: it's important that all this is done in [InAlt], *before* we work -on the alternatives themselves, because Simpify.simplAlt may zap the -occurrence info on the binders in the alternatives, which in turn -defeats combineIdenticalAlts (see Trac #7360). - -Note [Care with impossible-constructors when combining alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (Trac #10538) - data T = A | B | C | D - - case x::T of (Imposs-default-cons {A,B}) - DEFAULT -> e1 - A -> e2 - B -> e1 - -When calling combineIdentialAlts, we'll have computed that the -"impossible constructors" for the DEFAULT alt is {A,B}, since if x is -A or B we'll take the other alternatives. But suppose we combine B -into the DEFAULT, to get - - case x::T of (Imposs-default-cons {A}) - DEFAULT -> e1 - A -> e2 - -Then we must be careful to trim the impossible constructors to just {A}, -else we risk compiling 'e1' wrong! - -Not only that, but we take care when there is no DEFAULT beforehand, -because we are introducing one. Consider - - case x of (Imposs-default-cons {A,B,C}) - A -> e1 - B -> e2 - C -> e1 - -Then when combining the A and C alternatives we get - - case x of (Imposs-default-cons {B}) - DEFAULT -> e1 - B -> e2 - -Note that we have a new DEFAULT branch that we didn't have before. So -we need delete from the "impossible-default-constructors" all the -known-con alternatives that we have eliminated. (In Trac #11172 we -missed the first one.) - --} - -combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT - -> [CoreAlt] - -> (Bool, -- True <=> something happened - [AltCon], -- New constructors that cannot match DEFAULT - [CoreAlt]) -- New alternatives --- See Note [Combine identical alternatives] --- True <=> we did some combining, result is a single DEFAULT alternative -combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts) - | all isDeadBinder bndrs1 -- Remember the default - , not (null elim_rest) -- alternative comes first - = (True, imposs_deflt_cons', deflt_alt : filtered_rest) - where - (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts - deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1) - - -- See Note [Care with impossible-constructors when combining alternatives] - imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons - elim_cons = elim_con1 ++ map fstOf3 elim_rest - elim_con1 = case con1 of -- Don't forget con1! - DEFAULT -> [] -- See Note [ - _ -> [con1] - - cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 - identical_to_alt1 (_con,bndrs,rhs) - = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 - tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest - -combineIdenticalAlts imposs_cons alts - = (False, imposs_cons, alts) - -{- ********************************************************************* -* * - exprIsTrivial -* * -************************************************************************ - -Note [exprIsTrivial] -~~~~~~~~~~~~~~~~~~~~ -@exprIsTrivial@ is true of expressions we are unconditionally happy to - duplicate; simple variables and constants, and type - applications. Note that primop Ids aren't considered - trivial unless - -Note [Variables are trivial] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There used to be a gruesome test for (hasNoBinding v) in the -Var case: - exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 -The idea here is that a constructor worker, like \$wJust, is -really short for (\x -> \$wJust x), because \$wJust has no binding. -So it should be treated like a lambda. Ditto unsaturated primops. -But now constructor workers are not "have-no-binding" Ids. And -completely un-applied primops and foreign-call Ids are sufficiently -rare that I plan to allow them to be duplicated and put up with -saturating them. - -Note [Tick trivial] -~~~~~~~~~~~~~~~~~~~ -Ticks are only trivial if they are pure annotations. If we treat -"tick x" as trivial, it will be inlined inside lambdas and the -entry count will be skewed, for example. Furthermore "scc x" will -turn into just "x" in mkTick. - -Note [Empty case is trivial] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The expression (case (x::Int) Bool of {}) is just a type-changing -case used when we are sure that 'x' will not return. See -Note [Empty case alternatives] in CoreSyn. - -If the scrutinee is trivial, then so is the whole expression; and the -CoreToSTG pass in fact drops the case expression leaving only the -scrutinee. - -Having more trivial expressions is good. Moreover, if we don't treat -it as trivial we may land up with let-bindings like - let v = case x of {} in ... -and after CoreToSTG that gives - let v = x in ... -and that confuses the code generator (Trac #11155). So best to kill -it off at source. --} - -exprIsTrivial :: CoreExpr -> Bool -exprIsTrivial (Var _) = True -- See Note [Variables are trivial] -exprIsTrivial (Type _) = True -exprIsTrivial (Coercion _) = True -exprIsTrivial (Lit lit) = litIsTrivial lit -exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e -exprIsTrivial (Lam b e) = not (isRuntimeVar b) && exprIsTrivial e -exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e - -- See Note [Tick trivial] -exprIsTrivial (Cast e _) = exprIsTrivial e -exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial] -exprIsTrivial _ = False - -{- -Note [getIdFromTrivialExpr] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When substituting in a breakpoint we need to strip away the type cruft -from a trivial expression and get back to the Id. The invariant is -that the expression we're substituting was originally trivial -according to exprIsTrivial, AND the expression is not a literal. -See Note [substTickish] for how breakpoint substitution preserves -this extra invariant. - -We also need this functionality in CorePrep to extract out Id of a -function which we are saturating. However, in this case we don't know -if the variable actually refers to a literal; thus we use -'getIdFromTrivialExpr_maybe' to handle this case. See test -T12076lit for an example where this matters. --} - -getIdFromTrivialExpr :: CoreExpr -> Id -getIdFromTrivialExpr e - = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e)) - (getIdFromTrivialExpr_maybe e) - -getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id --- See Note [getIdFromTrivialExpr] -getIdFromTrivialExpr_maybe e = go e - where go (Var v) = Just v - go (App f t) | not (isRuntimeArg t) = go f - go (Tick t e) | not (tickishIsCode t) = go e - go (Cast e _) = go e - go (Lam b e) | not (isRuntimeVar b) = go e - go _ = Nothing - -{- -exprIsBottom is a very cheap and cheerful function; it may return -False for bottoming expressions, but it never costs much to ask. See -also CoreArity.exprBotStrictness_maybe, but that's a bit more -expensive. --} - -exprIsBottom :: CoreExpr -> Bool --- See Note [Bottoming expressions] -exprIsBottom e - | isEmptyTy (exprType e) - = True - | otherwise - = go 0 e - where - go n (Var v) = isBottomingId v && n >= idArity v - go n (App e a) | isTypeArg a = go n e - | otherwise = go (n+1) e - go n (Tick _ e) = go n e - go n (Cast e _) = go n e - go n (Let _ e) = go n e - go n (Lam v e) | isTyVar v = go n e - go _ (Case _ _ _ alts) = null alts - -- See Note [Empty case alternatives] in CoreSyn - go _ _ = False - -{- Note [Bottoming expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A bottoming expression is guaranteed to diverge, or raise an -exception. We can test for it in two different ways, and exprIsBottom -checks for both of these situations: - -* Visibly-bottom computations. For example - (error Int "Hello") - is visibly bottom. The strictness analyser also finds out if - a function diverges or raises an exception, and puts that info - in its strictness signature. - -* Empty types. If a type is empty, its only inhabitant is bottom. - For example: - data T - f :: T -> Bool - f = \(x:t). case x of Bool {} - Since T has no data constructors, the case alternatives are of course - empty. However note that 'x' is not bound to a visibly-bottom value; - it's the *type* that tells us it's going to diverge. - -A GADT may also be empty even though it has constructors: - data T a where - T1 :: a -> T Bool - T2 :: T Int - ...(case (x::T Char) of {})... -Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), -which is likewise uninhabited. - - -************************************************************************ -* * - exprIsDupable -* * -************************************************************************ - -Note [exprIsDupable] -~~~~~~~~~~~~~~~~~~~~ -@exprIsDupable@ is true of expressions that can be duplicated at a modest - cost in code size. This will only happen in different case - branches, so there's no issue about duplicating work. - - That is, exprIsDupable returns True of (f x) even if - f is very very expensive to call. - - Its only purpose is to avoid fruitless let-binding - and then inlining of case join points --} - -exprIsDupable :: DynFlags -> CoreExpr -> Bool -exprIsDupable dflags e - = isJust (go dupAppSize e) - where - go :: Int -> CoreExpr -> Maybe Int - go n (Type {}) = Just n - go n (Coercion {}) = Just n - go n (Var {}) = decrement n - go n (Tick _ e) = go n e - go n (Cast e _) = go n e - go n (App f a) | Just n' <- go n a = go n' f - go n (Lit lit) | litIsDupable dflags lit = decrement n - go _ _ = Nothing - - decrement :: Int -> Maybe Int - decrement 0 = Nothing - decrement n = Just (n-1) - -dupAppSize :: Int -dupAppSize = 8 -- Size of term we are prepared to duplicate - -- This is *just* big enough to make test MethSharing - -- inline enough join points. Really it should be - -- smaller, and could be if we fixed Trac #4960. - -{- -************************************************************************ -* * - exprIsCheap, exprIsExpandable -* * -************************************************************************ - -Note [exprIsWorkFree] -~~~~~~~~~~~~~~~~~~~~~ -exprIsWorkFree is used when deciding whether to inline something; we -don't inline it if doing so might duplicate work, by peeling off a -complete copy of the expression. Here we do not want even to -duplicate a primop (Trac #5623): - eg let x = a #+ b in x +# x - we do not want to inline/duplicate x - -Previously we were a bit more liberal, which led to the primop-duplicating -problem. However, being more conservative did lead to a big regression in -one nofib benchmark, wheel-sieve1. The situation looks like this: - - let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool - noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> - case GHC.Prim.<=# x_aRs 2 of _ { - GHC.Types.False -> notDivBy ps_adM qs_adN; - GHC.Types.True -> lvl_r2Eb }} - go = \x. ...(noFactor (I# y))....(go x')... - -The function 'noFactor' is heap-allocated and then called. Turns out -that 'notDivBy' is strict in its THIRD arg, but that is invisible to -the caller of noFactor, which therefore cannot do w/w and -heap-allocates noFactor's argument. At the moment (May 12) we are just -going to put up with this, because the previous more aggressive inlining -(which treated 'noFactor' as work-free) was duplicating primops, which -in turn was making inner loops of array calculations runs slow (#5623) - -Note [Case expressions are work-free] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Are case-expressions work-free? Consider - let v = case x of (p,q) -> p - go = \y -> ...case v of ... -Should we inline 'v' at its use site inside the loop? At the moment -we do. I experimented with saying that case are *not* work-free, but -that increased allocation slightly. It's a fairly small effect, and at -the moment we go for the slightly more aggressive version which treats -(case x of ....) as work-free if the alternatives are. - -Moreover it improves arities of overloaded functions where -there is only dictionary selection (no construction) involved - -Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables] -~~~~~~~~~~~~~~~~~~ in CoreUnfold.hs -@exprIsCheap@ looks at a Core expression and returns \tr{True} if -it is obviously in weak head normal form, or is cheap to get to WHNF. -[Note that that's not the same as exprIsDupable; an expression might be -big, and hence not dupable, but still cheap.] - -By ``cheap'' we mean a computation we're willing to: - push inside a lambda, or - inline at more than one place -That might mean it gets evaluated more than once, instead of being -shared. The main examples of things which aren't WHNF but are -``cheap'' are: - - * case e of - pi -> ei - (where e, and all the ei are cheap) - - * let x = e in b - (where e and b are cheap) - - * op x1 ... xn - (where op is a cheap primitive operator) - - * error "foo" - (because we are happy to substitute it inside a lambda) - -Notice that a variable is considered 'cheap': we can push it inside a lambda, -because sharing will make sure it is only evaluated once. - -Note [exprIsCheap and exprIsHNF] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that exprIsHNF does not imply exprIsCheap. Eg - let x = fac 20 in Just x -This responds True to exprIsHNF (you can discard a seq), but -False to exprIsCheap. - -Note [exprIsExpandable] -~~~~~~~~~~~~~~~~~~~~~~~ -An expression is "expandable" if we are willing to dupicate it, if doing -so might make a RULE or case-of-constructor fire. Mainly this means -data-constructor applications, but it's a bit more generous than exprIsCheap -because it is true of "CONLIKE" Ids: see Note [CONLIKE pragma] in BasicTypes. - -It is used to set the uf_expandable field of an Unfolding, and that -in turn is used - * In RULE matching - * In exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe - -But take care: exprIsExpandable should /not/ be true of primops. I -found this in test T5623a: - let q = /\a. Ptr a (a +# b) - in case q @ Float of Ptr v -> ...q... - -q's inlining should not be expandable, else exprIsConApp_maybe will -say that (q @ Float) expands to (Ptr a (a +# b)), and that will -duplicate the (a +# b) primop, which we should not do lightly. -(It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) - - -Note [Arguments in exprIsOk] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What predicate should we apply to the argument of an application? We -used to say "exprIsTrivial arg" due to concerns about duplicating -nested constructor applications, but see #4978. The principle here is -that - let x = a +# b in c *# x -should behave equivalently to - c *# (a +# b) -Since lets with cheap RHSs are accepted, so should paps with cheap arguments --} - --------------------- -exprIsCheap :: CoreExpr -> Bool -exprIsCheap = exprIsOk isCheapApp - -exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable] -exprIsExpandable = exprIsOk isExpandableApp - -exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] -exprIsWorkFree = exprIsOk isWorkFreeApp - --------------------- -exprIsOk :: CheapAppFun -> CoreExpr -> Bool -exprIsOk ok_app e - = ok e - where - ok e = go 0 e - - -- n is the number of value arguments - go n (Var v) = ok_app v n - go _ (Lit {}) = True - go _ (Type {}) = True - go _ (Coercion {}) = True - go n (Cast e _) = go n e - go n (Case scrut _ _ alts) = foldl (&&) (ok scrut) - [ go n rhs | (_,_,rhs) <- alts ] - go n (Tick t e) | tickishCounts t = False - | otherwise = go n e - go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e - | otherwise = go n e - go n (App f e) | isRuntimeArg e = go (n+1) f && ok e - | otherwise = go n f - go _ (Let {}) = False - - -- Case: see Note [Case expressions are work-free] - -- App: see Note [Arguments in exprIsOk] - -- Let: the old exprIsCheap worked through lets - - -------------------------------------- -type CheapAppFun = Id -> Arity -> Bool - -- Is an application of this function to n *value* args - -- always cheap, assuming the arguments are cheap? - -- True mainly of data constructors, partial applications; - -- but with minor variations: - -- isWorkFreeApp - -- isCheapApp - -- isExpandableApp - - -- NB: isCheapApp and isExpandableApp are called from outside - -- this module, so don't be tempted to move the notRedex - -- stuff into the call site in exprIsOk, and remove it - -- from the CheapAppFun implementations - - -notRedex :: CheapAppFun -notRedex fn n_val_args - = n_val_args == 0 -- No value args - || n_val_args < idArity fn -- Partial application - || isBottomingId fn -- OK to duplicate calls to bottom; - -- it certainly doesn't need to be shared! - -isWorkFreeApp :: CheapAppFun -isWorkFreeApp fn n_val_args - | notRedex fn n_val_args - = True - | otherwise - = case idDetails fn of - DataConWorkId {} -> True - _ -> False - -isCheapApp :: CheapAppFun -isCheapApp fn n_val_args - | notRedex fn n_val_args - = True - | otherwise - = case idDetails fn of - DataConWorkId {} -> True - RecSelId {} -> n_val_args == 1 -- See Note [Record selection] - ClassOpId {} -> n_val_args == 1 - PrimOpId op -> primOpIsCheap op - _ -> False - -- In principle we should worry about primops - -- that return a type variable, since the result - -- might be applied to something, but I'm not going - -- to bother to check the number of args - -isExpandableApp :: CheapAppFun -isExpandableApp fn n_val_args - | notRedex fn n_val_args - = True - | isConLikeId fn - = True - | otherwise - = case idDetails fn of - DataConWorkId {} -> True - RecSelId {} -> n_val_args == 1 -- See Note [Record selection] - ClassOpId {} -> n_val_args == 1 - PrimOpId {} -> False - _ -> all_pred_args n_val_args (idType fn) - - where - -- See if all the arguments are PredTys (implicit params or classes) - -- If so we'll regard it as expandable; see Note [Expandable overloadings] - all_pred_args n_val_args ty - | n_val_args == 0 - = True - - | Just (bndr, ty) <- splitPiTy_maybe ty - = caseBinder bndr - (\_tv -> all_pred_args n_val_args ty) - (\bndr_ty -> isPredTy bndr_ty && all_pred_args (n_val_args-1) ty) - - | otherwise - = False - -{- Note [Record selection] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -I'm experimenting with making record selection -look cheap, so we will substitute it inside a -lambda. Particularly for dictionary field selection. - -BUT: Take care with (sel d x)! The (sel d) might be cheap, but -there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) - -Note [Expandable overloadings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose the user wrote this - {-# RULE forall x. foo (negate x) = h x #-} - f x = ....(foo (negate x)).... -He'd expect the rule to fire. But since negate is overloaded, we might -get this: - f = \d -> let n = negate d in \x -> ...foo (n x)... -So we treat the application of a function (negate in this case) to a -*dictionary* as expandable. In effect, every function is CONLIKE when -it's applied only to dictionaries. - - -************************************************************************ -* * - exprOkForSpeculation -* * -************************************************************************ --} - ------------------------------ --- | 'exprOkForSpeculation' returns True of an expression that is: --- --- * Safe to evaluate even if normal order eval might not --- evaluate the expression at all, or --- --- * Safe /not/ to evaluate even if normal order would do so --- --- It is usually called on arguments of unlifted type, but not always --- In particular, Simplify.rebuildCase calls it on lifted types --- when a 'case' is a plain 'seq'. See the example in --- Note [exprOkForSpeculation: case expressions] below --- --- Precisely, it returns @True@ iff: --- a) The expression guarantees to terminate, --- b) soon, --- c) without causing a write side effect (e.g. writing a mutable variable) --- d) without throwing a Haskell exception --- e) without risking an unchecked runtime exception (array out of bounds, --- divide by zero) --- --- For @exprOkForSideEffects@ the list is the same, but omitting (e). --- --- Note that --- exprIsHNF implies exprOkForSpeculation --- exprOkForSpeculation implies exprOkForSideEffects --- --- See Note [PrimOp can_fail and has_side_effects] in PrimOp --- and Note [Implementation: how can_fail/has_side_effects affect transformations] --- --- As an example of the considerations in this test, consider: --- --- > let x = case y# +# 1# of { r# -> I# r# } --- > in E --- --- being translated to: --- --- > case y# +# 1# of { r# -> --- > let x = I# r# --- > in E --- > } --- --- We can only do this if the @y + 1@ is ok for speculation: it has no --- side effects, and can't diverge or raise an exception. -exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool -exprOkForSpeculation = expr_ok primOpOkForSpeculation -exprOkForSideEffects = expr_ok primOpOkForSideEffects - -- Polymorphic in binder type - -- There is one call at a non-Id binder type, in SetLevels - -expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool -expr_ok _ (Lit _) = True -expr_ok _ (Type _) = True -expr_ok _ (Coercion _) = True - -expr_ok primop_ok (Var v) = app_ok primop_ok v [] -expr_ok primop_ok (Cast e _) = expr_ok primop_ok e -expr_ok primop_ok (Lam b e) - | isTyVar b = expr_ok primop_ok e - | otherwise = True - - --- Tick annotations that *tick* cannot be speculated, because these --- are meant to identify whether or not (and how often) the particular --- source expression was evaluated at runtime. -expr_ok primop_ok (Tick tickish e) - | tickishCounts tickish = False - | otherwise = expr_ok primop_ok e - -expr_ok primop_ok (Case e _ _ alts) - = expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions] - && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts - && altsAreExhaustive alts -- Note [Exhaustive alts] - -expr_ok primop_ok other_expr - = case collectArgs other_expr of - (expr, args) | Var f <- stripTicksTopE (not . tickishCounts) expr - -> app_ok primop_ok f args - _ -> False - ------------------------------ -app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool -app_ok primop_ok fun args - = case idDetails fun of - DFunId new_type -> not new_type - -- DFuns terminate, unless the dict is implemented - -- with a newtype in which case they may not - - DataConWorkId {} -> True - -- The strictness of the constructor has already - -- been expressed by its "wrapper", so we don't need - -- to take the arguments into account - - PrimOpId op - | isDivOp op - , [arg1, Lit lit] <- args - -> not (isZeroLit lit) && expr_ok primop_ok arg1 - -- Special case for dividing operations that fail - -- In general they are NOT ok-for-speculation - -- (which primop_ok will catch), but they ARE OK - -- if the divisor is definitely non-zero. - -- Often there is a literal divisor, and this - -- can get rid of a thunk in an inner loop - - | otherwise - -> primop_ok op -- Check the primop itself - && and (zipWith arg_ok arg_tys args) -- Check the arguments - - _other -> isUnliftedType (idType fun) -- c.f. the Var case of exprIsHNF - || idArity fun > n_val_args -- Partial apps - || (n_val_args == 0 && - isEvaldUnfolding (idUnfolding fun)) -- Let-bound values - where - n_val_args = valArgCount args - where - (arg_tys, _) = splitPiTys (idType fun) - - arg_ok :: TyBinder -> CoreExpr -> Bool - arg_ok (Named _) _ = True -- A type argument - arg_ok (Anon ty) arg -- A term argument - | isUnliftedType ty = expr_ok primop_ok arg - | otherwise = True -- See Note [Primops with lifted arguments] - ------------------------------ -altsAreExhaustive :: [Alt b] -> Bool --- True <=> the case alternatives are definiely exhaustive --- False <=> they may or may not be -altsAreExhaustive [] - = False -- Should not happen -altsAreExhaustive ((con1,_,_) : alts) - = case con1 of - DEFAULT -> True - LitAlt {} -> False - DataAlt c -> 1 + length alts == tyConFamilySize (dataConTyCon c) - -- It is possible to have an exhaustive case that does not - -- enumerate all constructors, notably in a GADT match, but - -- we behave conservatively here -- I don't think it's important - -- enough to deserve special treatment - --- | True of dyadic operators that can fail only if the second arg is zero! -isDivOp :: PrimOp -> Bool --- This function probably belongs in PrimOp, or even in --- an automagically generated file.. but it's such a --- special case I thought I'd leave it here for now. -isDivOp IntQuotOp = True -isDivOp IntRemOp = True -isDivOp WordQuotOp = True -isDivOp WordRemOp = True -isDivOp FloatDivOp = True -isDivOp DoubleDivOp = True -isDivOp _ = False - -{- -Note [exprOkForSpeculation: case expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's always sound for exprOkForSpeculation to return False, and we -don't want it to take too long, so it bales out on complicated-looking -terms. Notably lets, which can be stacked very deeply; and in any -case the argument of exprOkForSpeculation is usually in a strict context, -so any lets will have been floated away. - -However, we keep going on case-expressions. An example like this one -showed up in DPH code (Trac #3717): - foo :: Int -> Int - foo 0 = 0 - foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) - -If exprOkForSpeculation doesn't look through case expressions, you get this: - T.$wfoo = - \ (ww :: GHC.Prim.Int#) -> - case ww of ds { - __DEFAULT -> case (case <# ds 5 of _ { - GHC.Types.False -> lvl1; - GHC.Types.True -> lvl}) - of _ { __DEFAULT -> - T.$wfoo (GHC.Prim.-# ds_XkE 1) }; - 0 -> 0 - } - -The inner case is redundant, and should be nuked. - -Note [Exhaustive alts] -~~~~~~~~~~~~~~~~~~~~~~ -We might have something like - case x of { - A -> ... - _ -> ...(case x of { B -> ...; C -> ... })... -Here, the inner case is fine, because the A alternative -can't happen, but it's not ok to float the inner case outside -the outer one (even if we know x is evaluated outside), because -then it would be non-exhaustive. See Trac #5453. - -Similarly, this is a valid program (albeit a slightly dodgy one) - let v = case x of { B -> ...; C -> ... } - in case x of - A -> ... - _ -> ...v...v.... -But we don't want to speculate the v binding. - -One could try to be clever, but the easy fix is simpy to regard -a non-exhaustive case as *not* okForSpeculation. - - -Note [Primops with lifted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is this ok-for-speculation (see Trac #13027)? - reallyUnsafePtrEq# a b -Well, yes. The primop accepts lifted arguments and does not -evaluate them. Indeed, in general primops are, well, primitive -and do not perform evaluation. - -There is one primop, dataToTag#, which does /require/ a lifted -argument to be evaluted. To ensure this, CorePrep adds an -eval if it can't see the the argument is definitely evaluated -(see [dataToTag magic] in CorePrep). - -We make no attempt to guarantee that dataToTag#'s argument is -evaluated here. Main reason: it's very fragile to test for the -evaluatedness of a lifted argument. Consider - case x of y -> let v = dataToTag# y in ... - -where x/y have type Int, say. 'y' looks evaluated (by the enclosing -case) so all is well. Now the FloatOut pass does a binder-swap (for -very good reasons), changing to - case x of y -> let v = dataToTag# x in ... - -See also Note [dataToTag#] in primops.txt.pp. - -Bottom line: - * in exprOkForSpeculation we simply ignore all lifted arguments. - - -************************************************************************ -* * - exprIsHNF, exprIsConLike -* * -************************************************************************ --} - --- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] --- ~~~~~~~~~~~~~~~~ --- | exprIsHNF returns true for expressions that are certainly /already/ --- evaluated to /head/ normal form. This is used to decide whether it's ok --- to change: --- --- > case x of _ -> e --- --- into: --- --- > e --- --- and to decide whether it's safe to discard a 'seq'. --- --- So, it does /not/ treat variables as evaluated, unless they say they are. --- However, it /does/ treat partial applications and constructor applications --- as values, even if their arguments are non-trivial, provided the argument --- type is lifted. For example, both of these are values: --- --- > (:) (f x) (map f xs) --- > map (...redex...) --- --- because 'seq' on such things completes immediately. --- --- For unlifted argument types, we have to be careful: --- --- > C (f x :: Int#) --- --- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't --- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of --- unboxed type must be ok-for-speculation (or trivial). -exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP -exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding - --- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as --- data constructors. Conlike arguments are considered interesting by the --- inliner. -exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP -exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding - --- | Returns true for values or value-like expressions. These are lambdas, --- constructors / CONLIKE functions (as determined by the function argument) --- or PAPs. --- -exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool -exprIsHNFlike is_con is_con_unf = is_hnf_like - where - is_hnf_like (Var v) -- NB: There are no value args at this point - = is_con v -- Catches nullary constructors, - -- so that [] and () are values, for example - || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings - || is_con_unf (idUnfolding v) - -- Check the thing's unfolding; it might be bound to a value - -- We don't look through loop breakers here, which is a bit conservative - -- but otherwise I worry that if an Id's unfolding is just itself, - -- we could get an infinite loop - - is_hnf_like (Lit _) = True - is_hnf_like (Type _) = True -- Types are honorary Values; - -- we don't mind copying them - is_hnf_like (Coercion _) = True -- Same for coercions - is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e - is_hnf_like (Tick tickish e) = not (tickishCounts tickish) - && is_hnf_like e - -- See Note [exprIsHNF Tick] - is_hnf_like (Cast e _) = is_hnf_like e - is_hnf_like (App e a) - | isValArg a = app_is_value e 1 - | otherwise = is_hnf_like e - is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us - is_hnf_like _ = False - - -- There is at least one value argument - -- 'n' is number of value args to which the expression is applied - app_is_value :: CoreExpr -> Int -> Bool - app_is_value (Var f) nva = id_app_is_value f nva - app_is_value (Tick _ f) nva = app_is_value f nva - app_is_value (Cast f _) nva = app_is_value f nva - app_is_value (App f a) nva - | isValArg a = app_is_value f (nva + 1) - | otherwise = app_is_value f nva - app_is_value _ _ = False - - id_app_is_value id n_val_args - = is_con id - || idArity id > n_val_args - || id `hasKey` absentErrorIdKey -- See Note [aBSENT_ERROR_ID] in MkCore - -- absentError behaves like an honorary data constructor - - -{- -Note [exprIsHNF Tick] - -We can discard source annotations on HNFs as long as they aren't -tick-like: - - scc c (\x . e) => \x . e - scc c (C x1..xn) => C x1..xn - -So we regard these as HNFs. Tick annotations that tick are not -regarded as HNF if the expression they surround is HNF, because the -tick is there to tell us that the expression was evaluated, so we -don't want to discard a seq on it. --} - --- | Can we bind this 'CoreExpr' at the top level? -exprIsTopLevelBindable :: CoreExpr -> Type -> Bool --- See Note [CoreSyn top-level string literals] --- Precondition: exprType expr = ty -exprIsTopLevelBindable expr ty - = exprIsLiteralString expr - || not (isUnliftedType ty) - -exprIsLiteralString :: CoreExpr -> Bool -exprIsLiteralString (Lit (MachStr _)) = True -exprIsLiteralString _ = False - -{- -************************************************************************ -* * - Instantiating data constructors -* * -************************************************************************ - -These InstPat functions go here to avoid circularity between DataCon and Id --} - -dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) -dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) - -dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) -dataConRepFSInstPat = dataConInstPat - -dataConInstPat :: [FastString] -- A long enough list of FSs to use for names - -> [Unique] -- An equally long list of uniques, at least one for each binder - -> DataCon - -> [Type] -- Types to instantiate the universally quantified tyvars - -> ([TyVar], [Id]) -- Return instantiated variables --- dataConInstPat arg_fun fss us con inst_tys returns a tuple --- (ex_tvs, arg_ids), --- --- ex_tvs are intended to be used as binders for existential type args --- --- arg_ids are indended to be used as binders for value arguments, --- and their types have been instantiated with inst_tys and ex_tys --- The arg_ids include both evidence and --- programmer-specified arguments (both after rep-ing) --- --- Example. --- The following constructor T1 --- --- data T a where --- T1 :: forall b. Int -> b -> T(a,b) --- ... --- --- has representation type --- forall a. forall a1. forall b. (a ~ (a1,b)) => --- Int -> b -> T a --- --- dataConInstPat fss us T1 (a1',b') will return --- --- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) --- --- where the double-primed variables are created with the FastStrings and --- Uniques given as fss and us -dataConInstPat fss uniqs con inst_tys - = ASSERT( univ_tvs `equalLength` inst_tys ) - (ex_bndrs, arg_ids) - where - univ_tvs = dataConUnivTyVars con - ex_tvs = dataConExTyVars con - arg_tys = dataConRepArgTys con - arg_strs = dataConRepStrictness con -- 1-1 with arg_tys - n_ex = length ex_tvs - - -- split the Uniques and FastStrings - (ex_uniqs, id_uniqs) = splitAt n_ex uniqs - (ex_fss, id_fss) = splitAt n_ex fss - - -- Make the instantiating substitution for universals - univ_subst = zipTvSubst univ_tvs inst_tys - - -- Make existential type variables, applying and extending the substitution - (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst - (zip3 ex_tvs ex_fss ex_uniqs) - - mk_ex_var :: TCvSubst -> (TyVar, FastString, Unique) -> (TCvSubst, TyVar) - mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubstWithClone subst tv - new_tv - , new_tv) - where - new_tv = mkTyVar (mkSysTvName uniq fs) kind - kind = Type.substTyUnchecked subst (tyVarKind tv) - - -- Make value vars, instantiating types - arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs - mk_id_var uniq fs ty str - = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments] - mkLocalIdOrCoVar name (Type.substTy full_subst ty) - where - name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan - -{- -Note [Mark evaluated arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When pattern matching on a constructor with strict fields, the binder -can have an 'evaldUnfolding'. Moreover, it *should* have one, so that -when loading an interface file unfolding like: - data T = MkT !Int - f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 - in ... } -we don't want Lint to complain. The 'y' is evaluated, so the -case in the RHS of the binding for 'v' is fine. But only if we -*know* that 'y' is evaluated. - -c.f. add_evals in Simplify.simplAlt - -************************************************************************ -* * - Equality -* * -************************************************************************ --} - --- | A cheap equality test which bales out fast! --- If it returns @True@ the arguments are definitely equal, --- otherwise, they may or may not be equal. --- --- See also 'exprIsBig' -cheapEqExpr :: Expr b -> Expr b -> Bool -cheapEqExpr = cheapEqExpr' (const False) - --- | Cheap expression equality test, can ignore ticks by type. -cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool -cheapEqExpr' ignoreTick = go_s - where go_s = go `on` stripTicksTopE ignoreTick - go (Var v1) (Var v2) = v1 == v2 - go (Lit lit1) (Lit lit2) = lit1 == lit2 - go (Type t1) (Type t2) = t1 `eqType` t2 - go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 - - go (App f1 a1) (App f2 a2) - = f1 `go_s` f2 && a1 `go_s` a2 - - go (Cast e1 t1) (Cast e2 t2) - = e1 `go_s` e2 && t1 `eqCoercion` t2 - - go (Tick t1 e1) (Tick t2 e2) - = t1 == t2 && e1 `go_s` e2 - - go _ _ = False - {-# INLINE go #-} -{-# INLINE cheapEqExpr' #-} - -exprIsBig :: Expr b -> Bool --- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' -exprIsBig (Lit _) = False -exprIsBig (Var _) = False -exprIsBig (Type _) = False -exprIsBig (Coercion _) = False -exprIsBig (Lam _ e) = exprIsBig e -exprIsBig (App f a) = exprIsBig f || exprIsBig a -exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! -exprIsBig (Tick _ e) = exprIsBig e -exprIsBig _ = True - -eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool --- Compares for equality, modulo alpha -eqExpr in_scope e1 e2 - = go (mkRnEnv2 in_scope) e1 e2 - where - go env (Var v1) (Var v2) - | rnOccL env v1 == rnOccR env v2 - = True - - go _ (Lit lit1) (Lit lit2) = lit1 == lit2 - go env (Type t1) (Type t2) = eqTypeX env t1 t2 - go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2 - go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2 - go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 - go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2 - - go env (Lam b1 e1) (Lam b2 e2) - = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination - && go (rnBndr2 env b1 b2) e1 e2 - - go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) - = go env r1 r2 -- No need to check binder types, since RHSs match - && go (rnBndr2 env v1 v2) e1 e2 - - go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) - = length ps1 == length ps2 - && all2 (go env') rs1 rs2 && go env' e1 e2 - where - (bs1,rs1) = unzip ps1 - (bs2,rs2) = unzip ps2 - env' = rnBndrs2 env bs1 bs2 - - go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) - | null a1 -- See Note [Empty case alternatives] in TrieMap - = null a2 && go env e1 e2 && eqTypeX env t1 t2 - | otherwise - = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 - - go _ _ _ = False - - ----------- - go_alt env (c1, bs1, e1) (c2, bs2, e2) - = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 - -eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool -eqTickish env (Breakpoint lid lids) (Breakpoint rid rids) - = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids -eqTickish _ l r = l == r - --- | Finds differences between core expressions, modulo alpha and --- renaming. Setting @top@ means that the @IdInfo@ of bindings will be --- checked for differences as well. -diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] -diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] -diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] -diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] -diffExpr _ env (Coercion co1) (Coercion co2) - | eqCoercionX env co1 co2 = [] -diffExpr top env (Cast e1 co1) (Cast e2 co2) - | eqCoercionX env co1 co2 = diffExpr top env e1 e2 -diffExpr top env (Tick n1 e1) e2 - | not (tickishIsCode n1) = diffExpr top env e1 e2 -diffExpr top env e1 (Tick n2 e2) - | not (tickishIsCode n2) = diffExpr top env e1 e2 -diffExpr top env (Tick n1 e1) (Tick n2 e2) - | eqTickish env n1 n2 = diffExpr top env e1 e2 - -- The error message of failed pattern matches will contain - -- generated names, which are allowed to differ. -diffExpr _ _ (App (App (Var absent) _) _) - (App (App (Var absent2) _) _) - | isBottomingId absent && isBottomingId absent2 = [] -diffExpr top env (App f1 a1) (App f2 a2) - = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 -diffExpr top env (Lam b1 e1) (Lam b2 e2) - | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination - = diffExpr top (rnBndr2 env b1 b2) e1 e2 -diffExpr top env (Let bs1 e1) (Let bs2 e2) - = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) - in ds ++ diffExpr top env' e1 e2 -diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) - | length a1 == length a2 && not (null a1) || eqTypeX env t1 t2 - -- See Note [Empty case alternatives] in TrieMap - = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) - where env' = rnBndr2 env b1 b2 - diffAlt (c1, bs1, e1) (c2, bs2, e2) - | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] - | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 -diffExpr _ _ e1 e2 - = [fsep [ppr e1, text "/=", ppr e2]] - --- | Finds differences between core bindings, see @diffExpr@. --- --- The main problem here is that while we expect the binds to have the --- same order in both lists, this is not guaranteed. To do this --- properly we'd either have to do some sort of unification or check --- all possible mappings, which would be seriously expensive. So --- instead we simply match single bindings as far as we can. This --- leaves us just with mutually recursive and/or mismatching bindings, --- which we then speculatively match by ordering them. It's by no means --- perfect, but gets the job done well enough. -diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] - -> ([SDoc], RnEnv2) -diffBinds top env binds1 = go (length binds1) env binds1 - where go _ env [] [] - = ([], env) - go fuel env binds1 binds2 - -- No binds left to compare? Bail out early. - | null binds1 || null binds2 - = (warn env binds1 binds2, env) - -- Iterated over all binds without finding a match? Then - -- try speculatively matching binders by order. - | fuel == 0 - = if not $ env `inRnEnvL` fst (head binds1) - then let env' = uncurry (rnBndrs2 env) $ unzip $ - zip (sort $ map fst binds1) (sort $ map fst binds2) - in go (length binds1) env' binds1 binds2 - -- If we have already tried that, give up - else (warn env binds1 binds2, env) - go fuel env ((bndr1,expr1):binds1) binds2 - | let matchExpr (bndr,expr) = - (not top || null (diffIdInfo env bndr bndr1)) && - null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr) - , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2 - = go (length binds1) (rnBndr2 env bndr1 bndr2) - binds1 (binds2l ++ binds2r) - | otherwise -- No match, so push back (FIXME O(n^2)) - = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 - go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough - - -- We have tried everything, but couldn't find a good match. So - -- now we just return the comparison results when we pair up - -- the binds in a pseudo-random order. - warn env binds1 binds2 = - concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++ - unmatched "unmatched left-hand:" (drop l binds1') ++ - unmatched "unmatched right-hand:" (drop l binds2') - where binds1' = sortBy (comparing fst) binds1 - binds2' = sortBy (comparing fst) binds2 - l = min (length binds1') (length binds2') - unmatched _ [] = [] - unmatched txt bs = [text txt $$ ppr (Rec bs)] - diffBind env (bndr1,expr1) (bndr2,expr2) - | ds@(_:_) <- diffExpr top env expr1 expr2 - = locBind "in binding" bndr1 bndr2 ds - | otherwise - = diffIdInfo env bndr1 bndr2 - --- | Find differences in @IdInfo@. We will especially check whether --- the unfoldings match, if present (see @diffUnfold@). -diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] -diffIdInfo env bndr1 bndr2 - | arityInfo info1 == arityInfo info2 - && cafInfo info1 == cafInfo info2 - && oneShotInfo info1 == oneShotInfo info2 - && inlinePragInfo info1 == inlinePragInfo info2 - && occInfo info1 == occInfo info2 - && demandInfo info1 == demandInfo info2 - && callArityInfo info1 == callArityInfo info2 - && levityInfo info1 == levityInfo info2 - = locBind "in unfolding of" bndr1 bndr2 $ - diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2) - | otherwise - = locBind "in Id info of" bndr1 bndr2 - [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]] - where info1 = idInfo bndr1; info2 = idInfo bndr2 - --- | Find differences in unfoldings. Note that we will not check for --- differences of @IdInfo@ in unfoldings, as this is generally --- redundant, and can lead to an exponential blow-up in complexity. -diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc] -diffUnfold _ NoUnfolding NoUnfolding = [] -diffUnfold _ BootUnfolding BootUnfolding = [] -diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = [] -diffUnfold env (DFunUnfolding bs1 c1 a1) - (DFunUnfolding bs2 c2 a2) - | c1 == c2 && length bs1 == length bs2 - = concatMap (uncurry (diffExpr False env')) (zip a1 a2) - where env' = rnBndrs2 env bs1 bs2 -diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1) - (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2) - | v1 == v2 && cl1 == cl2 - && wf1 == wf2 && x1 == x2 && g1 == g2 - = diffExpr False env t1 t2 -diffUnfold _ uf1 uf2 - = [fsep [ppr uf1, text "/=", ppr uf2]] - --- | Add location information to diff messages -locBind :: String -> Var -> Var -> [SDoc] -> [SDoc] -locBind loc b1 b2 diffs = map addLoc diffs - where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc)) - bindLoc | b1 == b2 = ppr b1 - | otherwise = ppr b1 <> char '/' <> ppr b2 - -{- -************************************************************************ -* * - Eta reduction -* * -************************************************************************ - -Note [Eta reduction conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We try for eta reduction here, but *only* if we get all the way to an -trivial expression. We don't want to remove extra lambdas unless we -are going to avoid allocating this thing altogether. - -There are some particularly delicate points here: - -* We want to eta-reduce if doing so leaves a trivial expression, - *including* a cast. For example - \x. f |> co --> f |> co - (provided co doesn't mention x) - -* Eta reduction is not valid in general: - \x. bot /= bot - This matters, partly for old-fashioned correctness reasons but, - worse, getting it wrong can yield a seg fault. Consider - f = \x.f x - h y = case (case y of { True -> f `seq` True; False -> False }) of - True -> ...; False -> ... - - If we (unsoundly) eta-reduce f to get f=f, the strictness analyser - says f=bottom, and replaces the (f `seq` True) with just - (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it - *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands - the definition again, so that it does not termninate after all. - Result: seg-fault because the boolean case actually gets a function value. - See Trac #1947. - - So it's important to do the right thing. - -* Note [Arity care]: we need to be careful if we just look at f's - arity. Currently (Dec07), f's arity is visible in its own RHS (see - Note [Arity robustness] in SimplEnv) so we must *not* trust the - arity when checking that 'f' is a value. Otherwise we will - eta-reduce - f = \x. f x - to - f = f - Which might change a terminating program (think (f `seq` e)) to a - non-terminating one. So we check for being a loop breaker first. - - However for GlobalIds we can look at the arity; and for primops we - must, since they have no unfolding. - -* Regardless of whether 'f' is a value, we always want to - reduce (/\a -> f a) to f - This came up in a RULE: foldr (build (/\a -> g a)) - did not match foldr (build (/\b -> ...something complex...)) - The type checker can insert these eta-expanded versions, - with both type and dictionary lambdas; hence the slightly - ad-hoc isDictId - -* Never *reduce* arity. For example - f = \xy. g x y - Then if h has arity 1 we don't want to eta-reduce because then - f's arity would decrease, and that is bad - -These delicacies are why we don't use exprIsTrivial and exprIsHNF here. -Alas. - -Note [Eta reduction with casted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (\(x:t3). f (x |> g)) :: t3 -> t2 - where - f :: t1 -> t2 - g :: t3 ~ t1 -This should be eta-reduced to - - f |> (sym g -> t2) - -So we need to accumulate a coercion, pushing it inward (past -variable arguments only) thus: - f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x - f (x:t) |> co --> (f |> (t -> co)) x - f @ a |> co --> (f |> (forall a.co)) @ a - f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) -These are the equations for ok_arg. - -It's true that we could also hope to eta reduce these: - (\xy. (f x |> g) y) - (\xy. (f x y) |> g) -But the simplifier pushes those casts outwards, so we don't -need to address that here. --} - -tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr -tryEtaReduce bndrs body - = go (reverse bndrs) body (mkRepReflCo (exprType body)) - where - incoming_arity = count isId bndrs - - go :: [Var] -- Binders, innermost first, types [a3,a2,a1] - -> CoreExpr -- Of type tr - -> Coercion -- Of type tr ~ ts - -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts - -- See Note [Eta reduction with casted arguments] - -- for why we have an accumulating coercion - go [] fun co - | ok_fun fun - , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co - , not (any (`elemVarSet` used_vars) bndrs) - = Just (mkCast fun co) -- Check for any of the binders free in the result - -- including the accumulated coercion - - go bs (Tick t e) co - | tickishFloatable t - = fmap (Tick t) $ go bs e co - -- Float app ticks: \x -> Tick t (e x) ==> Tick t e - - go (b : bs) (App fun arg) co - | Just (co', ticks) <- ok_arg b arg co - = fmap (flip (foldr mkTick) ticks) $ go bs fun co' - -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e - - go _ _ _ = Nothing -- Failure! - - --------------- - -- Note [Eta reduction conditions] - ok_fun (App fun (Type {})) = ok_fun fun - ok_fun (Cast fun _) = ok_fun fun - ok_fun (Tick _ expr) = ok_fun expr - ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs - ok_fun _fun = False - - --------------- - ok_fun_id fun = fun_arity fun >= incoming_arity - - --------------- - fun_arity fun -- See Note [Arity care] - | isLocalId fun - , isStrongLoopBreaker (idOccInfo fun) = 0 - | arity > 0 = arity - | isEvaldUnfolding (idUnfolding fun) = 1 - -- See Note [Eta reduction of an eval'd function] - | otherwise = 0 - where - arity = idArity fun - - --------------- - ok_lam v = isTyVar v || isEvVar v - - --------------- - ok_arg :: Var -- Of type bndr_t - -> CoreExpr -- Of type arg_t - -> Coercion -- Of kind (t1~t2) - -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) - -- (and similarly for tyvars, coercion args) - , [Tickish Var]) - -- See Note [Eta reduction with casted arguments] - ok_arg bndr (Type ty) co - | Just tv <- getTyVar_maybe ty - , bndr == tv = Just (mkHomoForAllCos [tv] co, []) - ok_arg bndr (Var v) co - | bndr == v = let reflCo = mkRepReflCo (idType bndr) - in Just (mkFunCo Representational reflCo co, []) - ok_arg bndr (Cast e co_arg) co - | (ticks, Var v) <- stripTicksTop tickishFloatable e - , bndr == v - = Just (mkFunCo Representational (mkSymCo co_arg) co, ticks) - -- The simplifier combines multiple casts into one, - -- so we can have a simple-minded pattern match here - ok_arg bndr (Tick t arg) co - | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co - = Just (co', t:ticks) - - ok_arg _ _ _ = Nothing - -{- -Note [Eta reduction of an eval'd function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell it is not true that f = \x. f x -because f might be bottom, and 'seq' can distinguish them. - -But it *is* true that f = f `seq` \x. f x -and we'd like to simplify the latter to the former. This amounts -to the rule that - * when there is just *one* value argument, - * f is not bottom -we can eta-reduce \x. f x ===> f - -This turned up in Trac #7542. - - -************************************************************************ -* * -\subsection{Determining non-updatable right-hand-sides} -* * -************************************************************************ - -Top-level constructor applications can usually be allocated -statically, but they can't if the constructor, or any of the -arguments, come from another DLL (because we can't refer to static -labels in other DLLs). - -If this happens we simply make the RHS into an updatable thunk, -and 'execute' it rather than allocating it statically. --} - --- | This function is called only on *top-level* right-hand sides. --- Returns @True@ if the RHS can be allocated statically in the output, --- with no thunks involved at all. -rhsIsStatic :: Platform - -> (Name -> Bool) -- Which names are dynamic - -> (Integer -> CoreExpr) -- Desugaring for integer literals (disgusting) - -- C.f. Note [Disgusting computation of CafRefs] - -- in TidyPgm - -> CoreExpr -> Bool --- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or --- refers to, CAFs; (ii) in CoreToStg to decide whether to put an --- update flag on it and (iii) in DsExpr to decide how to expand --- list literals --- --- The basic idea is that rhsIsStatic returns True only if the RHS is --- (a) a value lambda --- (b) a saturated constructor application with static args --- --- BUT watch out for --- (i) Any cross-DLL references kill static-ness completely --- because they must be 'executed' not statically allocated --- ("DLL" here really only refers to Windows DLLs, on other platforms, --- this is not necessary) --- --- (ii) We treat partial applications as redexes, because in fact we --- make a thunk for them that runs and builds a PAP --- at run-time. The only applications that are treated as --- static are *saturated* applications of constructors. - --- We used to try to be clever with nested structures like this: --- ys = (:) w ((:) w []) --- on the grounds that CorePrep will flatten ANF-ise it later. --- But supporting this special case made the function much more --- complicated, because the special case only applies if there are no --- enclosing type lambdas: --- ys = /\ a -> Foo (Baz ([] a)) --- Here the nested (Baz []) won't float out to top level in CorePrep. --- --- But in fact, even without -O, nested structures at top level are --- flattened by the simplifier, so we don't need to be super-clever here. --- --- Examples --- --- f = \x::Int. x+7 TRUE --- p = (True,False) TRUE --- --- d = (fst p, False) FALSE because there's a redex inside --- (this particular one doesn't happen but...) --- --- h = D# (1.0## /## 2.0##) FALSE (redex again) --- n = /\a. Nil a TRUE --- --- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex) --- --- --- This is a bit like CoreUtils.exprIsHNF, with the following differences: --- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) --- --- b) (C x xs), where C is a constructor is updatable if the application is --- dynamic --- --- c) don't look through unfolding of f in (f x). - -rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs - where - is_static :: Bool -- True <=> in a constructor argument; must be atomic - -> CoreExpr -> Bool - - is_static False (Lam b e) = isRuntimeVar b || is_static False e - is_static in_arg (Tick n e) = not (tickishIsCode n) - && is_static in_arg e - is_static in_arg (Cast e _) = is_static in_arg e - is_static _ (Coercion {}) = True -- Behaves just like a literal - is_static in_arg (Lit (LitInteger i _)) = is_static in_arg (cvt_integer i) - is_static _ (Lit (MachLabel {})) = False - is_static _ (Lit _) = True - -- A MachLabel (foreign import "&foo") in an argument - -- prevents a constructor application from being static. The - -- reason is that it might give rise to unresolvable symbols - -- in the object file: under Linux, references to "weak" - -- symbols from the data segment give rise to "unresolvable - -- relocation" errors at link time This might be due to a bug - -- in the linker, but we'll work around it here anyway. - -- SDM 24/2/2004 - - is_static in_arg other_expr = go other_expr 0 - where - go (Var f) n_val_args - | (platformOS platform /= OSMinGW32) || - not (is_dynamic_name (idName f)) - = saturated_data_con f n_val_args - || (in_arg && n_val_args == 0) - -- A naked un-applied variable is *not* deemed a static RHS - -- E.g. f = g - -- Reason: better to update so that the indirection gets shorted - -- out, and the true value will be seen - -- NB: if you change this, you'll break the invariant that THUNK_STATICs - -- are always updatable. If you do so, make sure that non-updatable - -- ones have enough space for their static link field! - - go (App f a) n_val_args - | isTypeArg a = go f n_val_args - | not in_arg && is_static True a = go f (n_val_args + 1) - -- The (not in_arg) checks that we aren't in a constructor argument; - -- if we are, we don't allow (value) applications of any sort - -- - -- NB. In case you wonder, args are sometimes not atomic. eg. - -- x = D# (1.0## /## 2.0##) - -- can't float because /## can fail. - - go (Tick n f) n_val_args = not (tickishIsCode n) && go f n_val_args - go (Cast e _) n_val_args = go e n_val_args - go _ _ = False - - saturated_data_con f n_val_args - = case isDataConWorkId_maybe f of - Just dc -> n_val_args == dataConRepArity dc - Nothing -> False - -{- -************************************************************************ -* * -\subsection{Type utilities} -* * -************************************************************************ --} - --- | True if the type has no non-bottom elements, e.g. when it is an empty --- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool. --- See Note [Bottoming expressions] --- --- See Note [No alternatives lint check] for another use of this function. -isEmptyTy :: Type -> Bool -isEmptyTy ty - -- Data types where, given the particular type parameters, no data - -- constructor matches, are empty. - -- This includes data types with no constructors, e.g. Data.Void.Void. - | Just (tc, inst_tys) <- splitTyConApp_maybe ty - , Just dcs <- tyConDataCons_maybe tc - , all (dataConCannotMatch inst_tys) dcs - = True - | otherwise - = False - -{- -***************************************************** -* -* StaticPtr -* -***************************************************** --} - --- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields --- @Just (makeStatic, t, srcLoc, e)@. --- --- Returns @Nothing@ for every other expression. -collectMakeStaticArgs - :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr) -collectMakeStaticArgs e - | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e - , idName b == makeStaticName = Just (fun, t, loc, arg) -collectMakeStaticArgs _ = Nothing - -{- -************************************************************************ -* * -\subsection{Join points} -* * -************************************************************************ --} - --- | Does this binding bind a join point (or a recursive group of join points)? -isJoinBind :: CoreBind -> Bool -isJoinBind (NonRec b _) = isJoinId b -isJoinBind (Rec ((b, _) : _)) = isJoinId b -isJoinBind _ = False diff --git a/coreSyn/MkCore.hs b/coreSyn/MkCore.hs deleted file mode 100644 --- a/coreSyn/MkCore.hs +++ /dev/null @@ -1,862 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Handy functions for creating much Core syntax -module MkCore ( - -- * Constructing normal syntax - mkCoreLet, mkCoreLets, - mkCoreApp, mkCoreApps, mkCoreConApps, - mkCoreLams, mkWildCase, mkIfThenElse, - mkWildValBinder, mkWildEvBinder, - sortQuantVars, castBottomExpr, - - -- * Constructing boxed literals - mkWordExpr, mkWordExprWord, - mkIntExpr, mkIntExprInt, - mkIntegerExpr, mkNaturalExpr, - mkFloatExpr, mkDoubleExpr, - mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, - - -- * Floats - FloatBind(..), wrapFloat, - - -- * Constructing small tuples - mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, - mkCoreTupBoxity, unitExpr, - - -- * Constructing big tuples - mkBigCoreVarTup, mkBigCoreVarTup1, - mkBigCoreVarTupTy, mkBigCoreTupTy, - mkBigCoreTup, - - -- * Deconstructing small tuples - mkSmallTupleSelector, mkSmallTupleCase, - - -- * Deconstructing big tuples - mkTupleSelector, mkTupleSelector1, mkTupleCase, - - -- * Constructing list expressions - mkNilExpr, mkConsExpr, mkListExpr, - mkFoldrExpr, mkBuildExpr, - - -- * Constructing Maybe expressions - mkNothingExpr, mkJustExpr, - - -- * Error Ids - mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, - rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, - nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, - tYPE_ERROR_ID, - ) where - -#include "HsVersions.h" - -import Id -import Var ( EvVar, setTyVarUnique ) - -import CoreSyn -import CoreUtils ( exprType, needsCaseBinding, bindNonRec ) -import Literal -import HscTypes - -import TysWiredIn -import PrelNames - -import HsUtils ( mkChunkified, chunkify ) -import Type -import Coercion ( isCoVar ) -import TysPrim -import DataCon ( DataCon, dataConWorkId ) -import IdInfo -import Demand -import Name hiding ( varName ) -import Outputable -import FastString -import UniqSupply -import BasicTypes -import Util -import DynFlags -import Data.List - -import Data.Char ( ord ) - -infixl 4 `mkCoreApp`, `mkCoreApps` - -{- -************************************************************************ -* * -\subsection{Basic CoreSyn construction} -* * -************************************************************************ --} -sortQuantVars :: [Var] -> [Var] --- Sort the variables, putting type and covars first, in scoped order, --- and then other Ids --- It is a deterministic sort, meaining it doesn't look at the values of --- Uniques. For explanation why it's important See Note [Unique Determinism] --- in Unique. -sortQuantVars vs = sorted_tcvs ++ ids - where - (tcvs, ids) = partition (isTyVar <||> isCoVar) vs - sorted_tcvs = toposortTyVars tcvs - --- | Bind a binding group over an expression, using a @let@ or @case@ as --- appropriate (see "CoreSyn#let_app_invariant") -mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr -mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant] - | needsCaseBinding (idType bndr) rhs - , not (isJoinId bndr) - = Case rhs bndr (exprType body) [(DEFAULT,[],body)] -mkCoreLet bind body - = Let bind body - --- | Bind a list of binding groups over an expression. The leftmost binding --- group becomes the outermost group in the resulting expression -mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr -mkCoreLets binds body = foldr mkCoreLet body binds - --- | Construct an expression which represents the application of one expression --- to the other -mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr --- Respects the let/app invariant by building a case expression where necessary --- See CoreSyn Note [CoreSyn let/app invariant] -mkCoreApp _ fun (Type ty) = App fun (Type ty) -mkCoreApp _ fun (Coercion co) = App fun (Coercion co) -mkCoreApp d fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d ) - mk_val_app fun arg arg_ty res_ty - where - fun_ty = exprType fun - (arg_ty, res_ty) = splitFunTy fun_ty - --- | Construct an expression which represents the application of a number of --- expressions to another. The leftmost expression in the list is applied first --- Respects the let/app invariant by building a case expression where necessary --- See CoreSyn Note [CoreSyn let/app invariant] -mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr --- Slightly more efficient version of (foldl mkCoreApp) -mkCoreApps orig_fun orig_args - = go orig_fun (exprType orig_fun) orig_args - where - go fun _ [] = fun - go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (piResultTy fun_ty ty) args - go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun - $$ ppr orig_args ) - go (mk_val_app fun arg arg_ty res_ty) res_ty args - where - (arg_ty, res_ty) = splitFunTy fun_ty - --- | Construct an expression which represents the application of a number of --- expressions to that of a data constructor expression. The leftmost expression --- in the list is applied first -mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr -mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args - -mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr --- Build an application (e1 e2), --- or a strict binding (case e2 of x -> e1 x) --- using the latter when necessary to respect the let/app invariant --- See Note [CoreSyn let/app invariant] -mk_val_app fun arg arg_ty res_ty - | not (needsCaseBinding arg_ty arg) - = App fun arg -- The vastly common case - - | otherwise - = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] - where - arg_id = mkWildValBinder arg_ty - -- Lots of shadowing, but it doesn't matter, - -- because 'fun ' should not have a free wild-id - -- - -- This is Dangerous. But this is the only place we play this - -- game, mk_val_app returns an expression that does not have - -- have a free wild-id. So the only thing that can go wrong - -- is if you take apart this case expression, and pass a - -- fragment of it as the fun part of a 'mk_val_app'. - ------------ -mkWildEvBinder :: PredType -> EvVar -mkWildEvBinder pred = mkWildValBinder pred - --- | Make a /wildcard binder/. This is typically used when you need a binder --- that you expect to use only at a *binding* site. Do not use it at --- occurrence sites because it has a single, fixed unique, and it's very --- easy to get into difficulties with shadowing. That's why it is used so little. --- See Note [WildCard binders] in SimplEnv -mkWildValBinder :: Type -> Id -mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty - -mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr --- Make a case expression whose case binder is unused --- The alts should not have any occurrences of WildId -mkWildCase scrut scrut_ty res_ty alts - = Case scrut (mkWildValBinder scrut_ty) res_ty alts - -mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr -mkIfThenElse guard then_expr else_expr --- Not going to be refining, so okay to take the type of the "then" clause - = mkWildCase guard boolTy (exprType then_expr) - [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! - (DataAlt trueDataCon, [], then_expr) ] - -castBottomExpr :: CoreExpr -> Type -> CoreExpr --- (castBottomExpr e ty), assuming that 'e' diverges, --- return an expression of type 'ty' --- See Note [Empty case alternatives] in CoreSyn -castBottomExpr e res_ty - | e_ty `eqType` res_ty = e - | otherwise = Case e (mkWildValBinder e_ty) res_ty [] - where - e_ty = exprType e - -{- -The functions from this point don't really do anything cleverer than -their counterparts in CoreSyn, but they are here for consistency --} - --- | Create a lambda where the given expression has a number of variables --- bound over it. The leftmost binder is that bound by the outermost --- lambda in the result -mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr -mkCoreLams = mkLams - -{- -************************************************************************ -* * -\subsection{Making literals} -* * -************************************************************************ --} - --- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int -mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i] - --- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int -mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i] - --- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value -mkWordExpr :: DynFlags -> Integer -> CoreExpr -mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w] - --- | Create a 'CoreExpr' which will evaluate to the given @Word@ -mkWordExprWord :: DynFlags -> Word -> CoreExpr -mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w] - --- | Create a 'CoreExpr' which will evaluate to the given @Integer@ -mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer -mkIntegerExpr i = do t <- lookupTyCon integerTyConName - return (Lit (mkLitInteger i (mkTyConTy t))) - --- | Create a 'CoreExpr' which will evaluate to the given @Natural@ --- --- TODO: should we add LitNatural to Core? -mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Natural -mkNaturalExpr i = do iExpr <- mkIntegerExpr i - fiExpr <- lookupId naturalFromIntegerName - return (mkCoreApps (Var fiExpr) [iExpr]) - - --- | Create a 'CoreExpr' which will evaluate to the given @Float@ -mkFloatExpr :: Float -> CoreExpr -mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f] - --- | Create a 'CoreExpr' which will evaluate to the given @Double@ -mkDoubleExpr :: Double -> CoreExpr -mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d] - - --- | Create a 'CoreExpr' which will evaluate to the given @Char@ -mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int -mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c] - --- | Create a 'CoreExpr' which will evaluate to the given @String@ -mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String - --- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@ -mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String - -mkStringExpr str = mkStringExprFS (mkFastString str) - -mkStringExprFS = mkStringExprFSWith lookupId - -mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr -mkStringExprFSWith lookupM str - | nullFS str - = return (mkNilExpr charTy) - - | all safeChar chars - = do unpack_id <- lookupM unpackCStringName - return (App (Var unpack_id) lit) - - | otherwise - = do unpack_utf8_id <- lookupM unpackCStringUtf8Name - return (App (Var unpack_utf8_id) lit) - - where - chars = unpackFS str - safeChar c = ord c >= 1 && ord c <= 0x7F - lit = Lit (MachStr (fastStringToByteString str)) - -{- -************************************************************************ -* * -\subsection{Tuple constructors} -* * -************************************************************************ --} - -{- -Creating tuples and their types for Core expressions - -@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@. - -* If it has only one element, it is the identity function. - -* If there are more elements than a big tuple can have, it nests - the tuples. - -Note [Flattening one-tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This family of functions creates a tuple of variables/expressions/types. - mkCoreTup [e1,e2,e3] = (e1,e2,e3) -What if there is just one variable/expression/type in the argument? -We could do one of two things: - -* Flatten it out, so that - mkCoreTup [e1] = e1 - -* Built a one-tuple (see Note [One-tuples] in TysWiredIn) - mkCoreTup1 [e1] = Unit e1 - We use a suffix "1" to indicate this. - -Usually we want the former, but occasionally the latter. --} - --- | Build a small tuple holding the specified variables --- One-tuples are flattened; see Note [Flattening one-tuples] -mkCoreVarTup :: [Id] -> CoreExpr -mkCoreVarTup ids = mkCoreTup (map Var ids) - --- | Build the type of a small tuple that holds the specified variables --- One-tuples are flattened; see Note [Flattening one-tuples] -mkCoreVarTupTy :: [Id] -> Type -mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) - --- | Build a small tuple holding the specified expressions --- One-tuples are flattened; see Note [Flattening one-tuples] -mkCoreTup :: [CoreExpr] -> CoreExpr -mkCoreTup [] = Var unitDataConId -mkCoreTup [c] = c -mkCoreTup cs = mkCoreConApps (tupleDataCon Boxed (length cs)) - (map (Type . exprType) cs ++ cs) - --- | Build a small unboxed tuple holding the specified expressions, --- with the given types. The types must be the types of the expressions. --- Do not include the RuntimeRep specifiers; this function calculates them --- for you. --- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] -mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr -mkCoreUbxTup tys exps - = ASSERT( tys `equalLength` exps) - mkCoreConApps (tupleDataCon Unboxed (length tys)) - (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) - --- | Make a core tuple of the given boxity -mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr -mkCoreTupBoxity Boxed exps = mkCoreTup exps -mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps - --- | Build a big tuple holding the specified variables --- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreVarTup :: [Id] -> CoreExpr -mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) - -mkBigCoreVarTup1 :: [Id] -> CoreExpr --- Same as mkBigCoreVarTup, but one-tuples are NOT flattened --- see Note [Flattening one-tuples] -mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1) - [Type (idType id), Var id] -mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids) - --- | Build the type of a big tuple that holds the specified variables --- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreVarTupTy :: [Id] -> Type -mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) - --- | Build a big tuple holding the specified expressions --- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreTup :: [CoreExpr] -> CoreExpr -mkBigCoreTup = mkChunkified mkCoreTup - --- | Build the type of a big tuple that holds the specified type of thing --- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreTupTy :: [Type] -> Type -mkBigCoreTupTy = mkChunkified mkBoxedTupleTy - --- | The unit expression -unitExpr :: CoreExpr -unitExpr = Var unitDataConId - -{- -************************************************************************ -* * -\subsection{Tuple destructors} -* * -************************************************************************ --} - --- | Builds a selector which scrutises the given --- expression and extracts the one name from the list given. --- If you want the no-shadowing rule to apply, the caller --- is responsible for making sure that none of these names --- are in scope. --- --- If there is just one 'Id' in the tuple, then the selector is --- just the identity. --- --- If necessary, we pattern match on a \"big\" tuple. -mkTupleSelector, mkTupleSelector1 - :: [Id] -- ^ The 'Id's to pattern match the tuple against - -> Id -- ^ The 'Id' to select - -> Id -- ^ A variable of the same type as the scrutinee - -> CoreExpr -- ^ Scrutinee - -> CoreExpr -- ^ Selector expression - --- mkTupleSelector [a,b,c,d] b v e --- = case e of v { --- (p,q) -> case p of p { --- (a,b) -> b }} --- We use 'tpl' vars for the p,q, since shadowing does not matter. --- --- In fact, it's more convenient to generate it innermost first, getting --- --- case (case e of v --- (p,q) -> p) of p --- (a,b) -> b -mkTupleSelector vars the_var scrut_var scrut - = mk_tup_sel (chunkify vars) the_var - where - mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut - mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $ - mk_tup_sel (chunkify tpl_vs) tpl_v - where - tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] - tpl_vs = mkTemplateLocals tpl_tys - [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, - the_var `elem` gp ] --- ^ 'mkTupleSelector1' is like 'mkTupleSelector' --- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) -mkTupleSelector1 vars the_var scrut_var scrut - | [_] <- vars - = mkSmallTupleSelector1 vars the_var scrut_var scrut - | otherwise - = mkTupleSelector vars the_var scrut_var scrut - --- | Like 'mkTupleSelector' but for tuples that are guaranteed --- never to be \"big\". --- --- > mkSmallTupleSelector [x] x v e = [| e |] --- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |] -mkSmallTupleSelector, mkSmallTupleSelector1 - :: [Id] -- The tuple args - -> Id -- The selected one - -> Id -- A variable of the same type as the scrutinee - -> CoreExpr -- Scrutinee - -> CoreExpr -mkSmallTupleSelector [var] should_be_the_same_var _ scrut - = ASSERT(var == should_be_the_same_var) - scrut -- Special case for 1-tuples -mkSmallTupleSelector vars the_var scrut_var scrut - = mkSmallTupleSelector1 vars the_var scrut_var scrut - --- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector' --- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) -mkSmallTupleSelector1 vars the_var scrut_var scrut - = ASSERT( notNull vars ) - Case scrut scrut_var (idType the_var) - [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)] - --- | A generalization of 'mkTupleSelector', allowing the body --- of the case to be an arbitrary expression. --- --- To avoid shadowing, we use uniques to invent new variables. --- --- If necessary we pattern match on a \"big\" tuple. -mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables - -> [Id] -- ^ The tuple identifiers to pattern match on - -> CoreExpr -- ^ Body of the case - -> Id -- ^ A variable of the same type as the scrutinee - -> CoreExpr -- ^ Scrutinee - -> CoreExpr --- ToDo: eliminate cases where none of the variables are needed. --- --- mkTupleCase uniqs [a,b,c,d] body v e --- = case e of v { (p,q) -> --- case p of p { (a,b) -> --- case q of q { (c,d) -> --- body }}} -mkTupleCase uniqs vars body scrut_var scrut - = mk_tuple_case uniqs (chunkify vars) body - where - -- This is the case where don't need any nesting - mk_tuple_case _ [vars] body - = mkSmallTupleCase vars body scrut_var scrut - - -- This is the case where we must make nest tuples at least once - mk_tuple_case us vars_s body - = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s - in mk_tuple_case us' (chunkify vars') body' - - one_tuple_case chunk_vars (us, vs, body) - = let (uniq, us') = takeUniqFromSupply us - scrut_var = mkSysLocal (fsLit "ds") uniq - (mkBoxedTupleTy (map idType chunk_vars)) - body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) - in (us', scrut_var:vs, body') - --- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed --- not to need nesting. -mkSmallTupleCase - :: [Id] -- ^ The tuple args - -> CoreExpr -- ^ Body of the case - -> Id -- ^ A variable of the same type as the scrutinee - -> CoreExpr -- ^ Scrutinee - -> CoreExpr - -mkSmallTupleCase [var] body _scrut_var scrut - = bindNonRec var scrut body -mkSmallTupleCase vars body scrut_var scrut --- One branch no refinement? - = Case scrut scrut_var (exprType body) - [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)] - -{- -************************************************************************ -* * - Floats -* * -************************************************************************ --} - -data FloatBind - = FloatLet CoreBind - | FloatCase CoreExpr Id AltCon [Var] - -- case e of y { C ys -> ... } - -- See Note [Floating cases] in SetLevels - -instance Outputable FloatBind where - ppr (FloatLet b) = text "LET" <+> ppr b - ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b) - 2 (ppr c <+> ppr bs) - -wrapFloat :: FloatBind -> CoreExpr -> CoreExpr -wrapFloat (FloatLet defns) body = Let defns body -wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)] - -{- -************************************************************************ -* * -\subsection{Common list manipulation expressions} -* * -************************************************************************ - -Call the constructor Ids when building explicit lists, so that they -interact well with rules. --} - --- | Makes a list @[]@ for lists of the specified type -mkNilExpr :: Type -> CoreExpr -mkNilExpr ty = mkCoreConApps nilDataCon [Type ty] - --- | Makes a list @(:)@ for lists of the specified type -mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr -mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl] - --- | Make a list containing the given expressions, where the list has the given type -mkListExpr :: Type -> [CoreExpr] -> CoreExpr -mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs - --- | Make a fully applied 'foldr' expression -mkFoldrExpr :: MonadThings m - => Type -- ^ Element type of the list - -> Type -- ^ Fold result type - -> CoreExpr -- ^ "Cons" function expression for the fold - -> CoreExpr -- ^ "Nil" expression for the fold - -> CoreExpr -- ^ List expression being folded acress - -> m CoreExpr -mkFoldrExpr elt_ty result_ty c n list = do - foldr_id <- lookupId foldrName - return (Var foldr_id `App` Type elt_ty - `App` Type result_ty - `App` c - `App` n - `App` list) - --- | Make a 'build' expression applied to a locally-bound worker function -mkBuildExpr :: (MonadThings m, MonadUnique m) - => Type -- ^ Type of list elements to be built - -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's - -- of the binders for the build worker function, returns - -- the body of that worker - -> m CoreExpr -mkBuildExpr elt_ty mk_build_inside = do - [n_tyvar] <- newTyVars [alphaTyVar] - let n_ty = mkTyVarTy n_tyvar - c_ty = mkFunTys [elt_ty, n_ty] n_ty - [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty] - - build_inside <- mk_build_inside (c, c_ty) (n, n_ty) - - build_id <- lookupId buildName - return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside - where - newTyVars tyvar_tmpls = do - uniqs <- getUniquesM - return (zipWith setTyVarUnique tyvar_tmpls uniqs) - -{- -************************************************************************ -* * - Manipulating Maybe data type -* * -************************************************************************ --} - - --- | Makes a Nothing for the specified type -mkNothingExpr :: Type -> CoreExpr -mkNothingExpr ty = mkConApp nothingDataCon [Type ty] - --- | Makes a Just from a value of the specified type -mkJustExpr :: Type -> CoreExpr -> CoreExpr -mkJustExpr ty val = mkConApp justDataCon [Type ty, val] - - -{- -************************************************************************ -* * - Error expressions -* * -************************************************************************ --} - -mkRuntimeErrorApp - :: Id -- Should be of type (forall a. Addr# -> a) - -- where Addr# points to a UTF8 encoded string - -> Type -- The type to instantiate 'a' - -> String -- The string to print - -> CoreExpr - -mkRuntimeErrorApp err_id res_ty err_msg - = mkApps (Var err_id) [ Type (getRuntimeRep res_ty) - , Type res_ty, err_string ] - where - err_string = Lit (mkMachString err_msg) - -mkImpossibleExpr :: Type -> CoreExpr -mkImpossibleExpr res_ty - = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" - -{- -************************************************************************ -* * - Error Ids -* * -************************************************************************ - -GHC randomly injects these into the code. - -@patError@ is just a version of @error@ for pattern-matching -failures. It knows various ``codes'' which expand to longer -strings---this saves space! - -@absentErr@ is a thing we put in for ``absent'' arguments. They jolly -well shouldn't be yanked on, but if one is, then you will get a -friendly message from @absentErr@ (rather than a totally random -crash). - -@parError@ is a special version of @error@ which the compiler does -not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ -templates, but we don't ever expect to generate code for it. --} - -errorIds :: [Id] -errorIds - = [ rUNTIME_ERROR_ID, - iRREFUT_PAT_ERROR_ID, - nON_EXHAUSTIVE_GUARDS_ERROR_ID, - nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID, - rEC_CON_ERROR_ID, - rEC_SEL_ERROR_ID, - aBSENT_ERROR_ID, - tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284 - ] - -recSelErrorName, runtimeErrorName, absentErrorName :: Name -irrefutPatErrorName, recConErrorName, patErrorName :: Name -nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name -typeErrorName :: Name - -recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID -absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID -runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID -irrefutPatErrorName = err_nm "irrefutPatError" irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID -recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID -patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID -typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID - -noMethodBindingErrorName = err_nm "noMethodBindingError" - noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID -nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError" - nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID - -err_nm :: String -> Unique -> Id -> Name -err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id - -rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id -pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id -tYPE_ERROR_ID, aBSENT_ERROR_ID :: Id -rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName -rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName -iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName -rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName -pAT_ERROR_ID = mkRuntimeErrorId patErrorName -nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName -nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName -tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName - -mkRuntimeErrorId :: Name -> Id --- Error function --- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a --- with arity: 1 --- which diverges after being given one argument --- The Addr# is expected to be the address of --- a UTF8-encoded error string -mkRuntimeErrorId name - = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info - where - bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig - `setArityInfo` 1 - -- Make arity and strictness agree - - -- Do *not* mark them as NoCafRefs, because they can indeed have - -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, - -- which has some CAFs - -- In due course we may arrange that these error-y things are - -- regarded by the GC as permanently live, in which case we - -- can give them NoCaf info. As it is, any function that calls - -- any pc_bottoming_Id will itself have CafRefs, which bloats - -- SRTs. - - strict_sig = mkClosedStrictSig [evalDmd] exnRes - -- exnRes: these throw an exception, not just diverge - -runtimeErrorTy :: Type --- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a --- See Note [Error and friends have an "open-tyvar" forall] -runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] - (mkFunTy addrPrimTy openAlphaTy) - -{- Note [Error and friends have an "open-tyvar" forall] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'error' and 'undefined' have types - error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a - undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a -Notice the runtime-representation polymorphism. This ensures that -"error" can be instantiated at unboxed as well as boxed types. -This is OK because it never returns, so the return type is irrelevant. - - -************************************************************************ -* * - aBSENT_ERROR_ID -* * -************************************************************************ - -Note [aBSENT_ERROR_ID] -~~~~~~~~~~~~~~~~~~~~~~ -We use aBSENT_ERROR_ID to build dummy values in workers. E.g. - - f x = (case x of (a,b) -> b) + 1::Int - -The demand analyser figures ot that only the second component of x is -used, and does a w/w split thus - - f x = case x of (a,b) -> $wf b - - $wf b = let a = absentError "blah" - x = (a,b) - in - -After some simplification, the (absentError "blah") thunk goes away. - ------- Tricky wrinkle ------- -Trac #14285 had, roughly - - data T a = MkT a !a - {-# INLINABLE f #-} - f x = case x of MkT a b -> g (MkT b a) - -It turned out that g didn't use the second component, and hence f doesn't use -the first. But the stable-unfolding for f looks like - \x. case x of MkT a b -> g ($WMkT b a) -where $WMkT is the wrapper for MkT that evaluates its arguments. We -apply the same w/w split to this unfolding (see Note [Worker-wrapper -for INLINEABLE functions] in WorkWrap) so the template ends up like - \b. let a = absentError "blah" - x = MkT a b - in case x of MkT a b -> g ($WMkT b a) - -After doing case-of-known-constructor, and expanding $WMkT we get - \b -> g (case absentError "blah" of a -> MkT b a) - -Yikes! That bogusly appears to evaluate the absentError! - -This is extremely tiresome. Another way to think of this is that, in -Core, it is an invariant that a strict data contructor, like MkT, must -be be applied only to an argument in HNF. so (absentError "blah") had -better be non-bottom. - -So the "solution" is to make absentError behave like a data constructor, -to respect this invariant. Rather than have a special case in exprIsHNF, -I eneded up doing this: - - * Make absentError claim to be ConLike - - * Make exprOkForSpeculation/exprOkForSideEffects - return True for ConLike things - - * In Simplify.rebuildCase, make the - Note [Case to let transformation] - branch use exprOkForSpeculation rather than exprIsHNF, so that - it converts the absentError case to a let. - -On the other hand if, by some bug or bizarre happenstance, we ever call -absentError, we should thow an exception. This should never happen, of -course, but we definitely can't return anything. e.g. if somehow we had - case absentError "foo" of - Nothing -> ... - Just x -> ... -then if we return, the case expression will select a field and continue. -Seg fault city. Better to throw an exception. (Even though we've said -it is ConLike :-) --} - -aBSENT_ERROR_ID - = mkVanillaGlobal absentErrorName absent_ty - where - absent_ty = mkSpecForAllTys [alphaTyVar] (mkFunTy addrPrimTy alphaTy) - -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for - -- lifted-type things; see Note [Absent errors] in WwLib - -mkAbsentErrorApp :: Type -- The type to instantiate 'a' - -> String -- The string to print - -> CoreExpr - -mkAbsentErrorApp res_ty err_msg - = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ] - where - err_string = Lit (mkMachString err_msg) - diff --git a/coreSyn/PprCore.hs b/coreSyn/PprCore.hs deleted file mode 100644 --- a/coreSyn/PprCore.hs +++ /dev/null @@ -1,622 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - - -Printing of Core syntax --} - -{-# LANGUAGE MultiWayIf #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module PprCore ( - pprCoreExpr, pprParendExpr, - pprCoreBinding, pprCoreBindings, pprCoreAlt, - pprCoreBindingWithSize, pprCoreBindingsWithSize, - pprRules, pprOptCo - ) where - -import CoreSyn -import CoreStats (exprStats) -import Literal( pprLiteral ) -import Name( pprInfixName, pprPrefixName ) -import Var -import Id -import IdInfo -import Demand -import DataCon -import TyCon -import Type -import Coercion -import DynFlags -import BasicTypes -import Maybes -import Util -import Outputable -import FastString -import SrcLoc ( pprUserRealSpan ) - -{- -************************************************************************ -* * -\subsection{Public interfaces for Core printing (excluding instances)} -* * -************************************************************************ - -@pprParendCoreExpr@ puts parens around non-atomic Core expressions. --} - -pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc -pprCoreBinding :: OutputableBndr b => Bind b -> SDoc -pprCoreExpr :: OutputableBndr b => Expr b -> SDoc -pprParendExpr :: OutputableBndr b => Expr b -> SDoc - -pprCoreBindings = pprTopBinds noAnn -pprCoreBinding = pprTopBind noAnn - -pprCoreBindingsWithSize :: [CoreBind] -> SDoc -pprCoreBindingWithSize :: CoreBind -> SDoc - -pprCoreBindingsWithSize = pprTopBinds sizeAnn -pprCoreBindingWithSize = pprTopBind sizeAnn - -instance OutputableBndr b => Outputable (Bind b) where - ppr bind = ppr_bind noAnn bind - -instance OutputableBndr b => Outputable (Expr b) where - ppr expr = pprCoreExpr expr - -{- -************************************************************************ -* * -\subsection{The guts} -* * -************************************************************************ --} - --- | A function to produce an annotation for a given right-hand-side -type Annotation b = Expr b -> SDoc - --- | Annotate with the size of the right-hand-side -sizeAnn :: CoreExpr -> SDoc -sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e) - --- | No annotation -noAnn :: Expr b -> SDoc -noAnn _ = empty - -pprTopBinds :: OutputableBndr a - => Annotation a -- ^ generate an annotation to place before the - -- binding - -> [Bind a] -- ^ bindings to show - -> SDoc -- ^ the pretty result -pprTopBinds ann binds = vcat (map (pprTopBind ann) binds) - -pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc -pprTopBind ann (NonRec binder expr) - = ppr_binding ann (binder,expr) $$ blankLine - -pprTopBind _ (Rec []) - = text "Rec { }" -pprTopBind ann (Rec (b:bs)) - = vcat [text "Rec {", - ppr_binding ann b, - vcat [blankLine $$ ppr_binding ann b | b <- bs], - text "end Rec }", - blankLine] - -ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc - -ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr) -ppr_bind ann (Rec binds) = vcat (map pp binds) - where - pp bind = ppr_binding ann bind <> semi - -ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc -ppr_binding ann (val_bdr, expr) - = ann expr $$ pprBndr LetBind val_bdr $$ pp_bind - where - pp_bind = case bndrIsJoin_maybe val_bdr of - Nothing -> pp_normal_bind - Just ar -> pp_join_bind ar - - pp_normal_bind = hang (ppr val_bdr) 2 (equals <+> pprCoreExpr expr) - - -- For a join point of join arity n, we want to print j = \x1 ... xn -> e - -- as "j x1 ... xn = e" to differentiate when a join point returns a - -- lambda (the first rendering looks like a nullary join point returning - -- an n-argument function). - pp_join_bind join_arity - = hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs)) - 2 (equals <+> pprCoreExpr rhs) - where - (lhs_bndrs, rhs) = collectNBinders join_arity expr - -pprParendExpr expr = ppr_expr parens expr -pprCoreExpr expr = ppr_expr noParens expr - -noParens :: SDoc -> SDoc -noParens pp = pp - -pprOptCo :: Coercion -> SDoc --- Print a coercion optionally; i.e. honouring -dsuppress-coercions -pprOptCo co = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressCoercions dflags - then angleBrackets (text "Co:" <> int (coercionSize co)) - else parens (sep [ppr co, dcolon <+> ppr (coercionType co)]) - -ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc - -- The function adds parens in context that need - -- an atomic value (e.g. function args) - -ppr_expr add_par (Var name) - | isJoinId name = add_par ((text "jump") <+> ppr name) - | otherwise = ppr name -ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird -ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co) -ppr_expr add_par (Lit lit) = pprLiteral add_par lit - -ppr_expr add_par (Cast expr co) - = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co] - -ppr_expr add_par expr@(Lam _ _) - = let - (bndrs, body) = collectBinders expr - in - add_par $ - hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) - 2 (pprCoreExpr body) - -ppr_expr add_par expr@(App {}) - = sdocWithDynFlags $ \dflags -> - case collectArgs expr of { (fun, args) -> - let - pp_args = sep (map pprArg args) - val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples - pp_tup_args = pprWithCommas pprCoreExpr val_args - args' - | gopt Opt_SuppressTypeApplications dflags = val_args - | otherwise = args - parens - | null args' = id - | otherwise = add_par - in - case fun of - Var f -> case isDataConWorkId_maybe f of - -- Notice that we print the *worker* - -- for tuples in paren'd format. - Just dc | saturated - , Just sort <- tyConTuple_maybe tc - -> tupleParens sort pp_tup_args - where - tc = dataConTyCon dc - saturated = val_args `lengthIs` idArity f - - _ -> parens (hang fun_doc 2 pp_args) - where - fun_doc | isJoinId f = text "jump" <+> ppr f - | otherwise = ppr f - - _ -> parens (hang (pprParendExpr fun) 2 pp_args) - } - -ppr_expr add_par (Case expr var ty [(con,args,rhs)]) - = sdocWithDynFlags $ \dflags -> - if gopt Opt_PprCaseAsLet dflags - then add_par $ -- See Note [Print case as let] - sep [ sep [ text "let! {" - <+> ppr_case_pat con args - <+> text "~" - <+> ppr_bndr var - , text "<-" <+> ppr_expr id expr - <+> text "} in" ] - , pprCoreExpr rhs - ] - else add_par $ - sep [sep [sep [ text "case" <+> pprCoreExpr expr - , ifPprDebug (text "return" <+> ppr ty) - , text "of" <+> ppr_bndr var - ] - , char '{' <+> ppr_case_pat con args <+> arrow - ] - , pprCoreExpr rhs - , char '}' - ] - where - ppr_bndr = pprBndr CaseBind - -ppr_expr add_par (Case expr var ty alts) - = add_par $ - sep [sep [text "case" - <+> pprCoreExpr expr - <+> ifPprDebug (text "return" <+> ppr ty), - text "of" <+> ppr_bndr var <+> char '{'], - nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), - char '}' - ] - where - ppr_bndr = pprBndr CaseBind - - --- special cases: let ... in let ... --- ("disgusting" SLPJ) - -{- -ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) - = add_par $ - vcat [ - hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], - nest 2 (pprCoreExpr rhs), - text "} in", - pprCoreExpr body ] - -ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) - = add_par - (hang (text "let {") - 2 (hsep [ppr_binding (val_bdr,rhs), - text "} in"]) - $$ - pprCoreExpr expr) --} - - --- General case (recursive case, too) -ppr_expr add_par (Let bind expr) - = add_par $ - sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"), - pprCoreExpr expr] - where - keyword (NonRec b _) - | isJust (bndrIsJoin_maybe b) = text "join" - | otherwise = text "let" - keyword (Rec pairs) - | ((b,_):_) <- pairs - , isJust (bndrIsJoin_maybe b) = text "joinrec" - | otherwise = text "letrec" - -ppr_expr add_par (Tick tickish expr) - = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressTicks dflags - then ppr_expr add_par expr - else add_par (sep [ppr tickish, pprCoreExpr expr]) - -pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc -pprCoreAlt (con, args, rhs) - = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) - -ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc -ppr_case_pat (DataAlt dc) args - | Just sort <- tyConTuple_maybe tc - = tupleParens sort (pprWithCommas ppr_bndr args) - where - ppr_bndr = pprBndr CasePatBind - tc = dataConTyCon dc - -ppr_case_pat con args - = ppr con <+> (fsep (map ppr_bndr args)) - where - ppr_bndr = pprBndr CasePatBind - - --- | Pretty print the argument in a function application. -pprArg :: OutputableBndr a => Expr a -> SDoc -pprArg (Type ty) - = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressTypeApplications dflags - then empty - else text "@" <+> pprParendType ty -pprArg (Coercion co) = text "@~" <+> pprOptCo co -pprArg expr = pprParendExpr expr - -{- -Note [Print case as let] -~~~~~~~~~~~~~~~~~~~~~~~~ -Single-branch case expressions are very common: - case x of y { I# x' -> - case p of q { I# p' -> ... } } -These are, in effect, just strict let's, with pattern matching. -With -dppr-case-as-let we print them as such: - let! { I# x' ~ y <- x } in - let! { I# p' ~ q <- p } in ... - - -Other printing bits-and-bobs used with the general @pprCoreBinding@ -and @pprCoreExpr@ functions. - - -Note [Binding-site specific printing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust -the information printed. - -Let-bound binders are printed with their full type and idInfo. - -Case-bound variables (both the case binder and pattern variables) are printed -without a type and without their unfolding. - -Furthermore, a dead case-binder is completely ignored, while otherwise, dead -binders are printed as "_". --} - --- These instances are sadly orphans - -instance OutputableBndr Var where - pprBndr = pprCoreBinder - pprInfixOcc = pprInfixName . varName - pprPrefixOcc = pprPrefixName . varName - bndrIsJoin_maybe = isJoinId_maybe - -instance Outputable b => OutputableBndr (TaggedBndr b) where - pprBndr _ b = ppr b -- Simple - pprInfixOcc b = ppr b - pprPrefixOcc b = ppr b - bndrIsJoin_maybe (TB b _) = isJoinId_maybe b - -pprCoreBinder :: BindingSite -> Var -> SDoc -pprCoreBinder LetBind binder - | isTyVar binder = pprKindedTyVarBndr binder - | otherwise = pprTypedLetBinder binder $$ - ppIdInfo binder (idInfo binder) - --- Lambda bound type variables are preceded by "@" -pprCoreBinder bind_site bndr - = getPprStyle $ \ sty -> - pprTypedLamBinder bind_site (debugStyle sty) bndr - -pprUntypedBinder :: Var -> SDoc -pprUntypedBinder binder - | isTyVar binder = text "@" <+> ppr binder -- NB: don't print kind - | otherwise = pprIdBndr binder - -pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc --- For lambda and case binders, show the unfolding info (usually none) -pprTypedLamBinder bind_site debug_on var - = sdocWithDynFlags $ \dflags -> - case () of - _ - | not debug_on -- Show case-bound wild bilders only if debug is on - , CaseBind <- bind_site - , isDeadBinder var -> empty - - | not debug_on -- Even dead binders can be one-shot - , isDeadBinder var -> char '_' <+> ppWhen (isId var) - (pprIdBndrInfo (idInfo var)) - - | not debug_on -- No parens, no kind info - , CaseBind <- bind_site -> pprUntypedBinder var - - | not debug_on - , CasePatBind <- bind_site -> pprUntypedBinder var - - | suppress_sigs dflags -> pprUntypedBinder var - - | isTyVar var -> parens (pprKindedTyVarBndr var) - - | otherwise -> parens (hang (pprIdBndr var) - 2 (vcat [ dcolon <+> pprType (idType var) - , pp_unf])) - where - suppress_sigs = gopt Opt_SuppressTypeSignatures - - unf_info = unfoldingInfo (idInfo var) - pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info - | otherwise = empty - -pprTypedLetBinder :: Var -> SDoc --- Print binder with a type or kind signature (not paren'd) -pprTypedLetBinder binder - = sdocWithDynFlags $ \dflags -> - case () of - _ - | isTyVar binder -> pprKindedTyVarBndr binder - | gopt Opt_SuppressTypeSignatures dflags -> pprIdBndr binder - | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) - -pprKindedTyVarBndr :: TyVar -> SDoc --- Print a type variable binder with its kind (but not if *) -pprKindedTyVarBndr tyvar - = text "@" <+> pprTyVar tyvar - --- pprIdBndr does *not* print the type --- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness -pprIdBndr :: Id -> SDoc -pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) - -pprIdBndrInfo :: IdInfo -> SDoc -pprIdBndrInfo info - = sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressIdInfo dflags) $ - info `seq` doc -- The seq is useful for poking on black holes - where - prag_info = inlinePragInfo info - occ_info = occInfo info - dmd_info = demandInfo info - lbv_info = oneShotInfo info - - has_prag = not (isDefaultInlinePragma prag_info) - has_occ = not (isManyOccs occ_info) - has_dmd = not $ isTopDmd dmd_info - has_lbv = not (hasNoOneShotInfo lbv_info) - - doc = showAttributes - [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) - , (has_occ, text "Occ=" <> ppr occ_info) - , (has_dmd, text "Dmd=" <> ppr dmd_info) - , (has_lbv , text "OS=" <> ppr lbv_info) - ] - -{- ------------------------------------------------------ --- IdDetails and IdInfo ------------------------------------------------------ --} - -ppIdInfo :: Id -> IdInfo -> SDoc -ppIdInfo id info - = sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressIdInfo dflags) $ - showAttributes - [ (True, pp_scope <> ppr (idDetails id)) - , (has_arity, text "Arity=" <> int arity) - , (has_called_arity, text "CallArity=" <> int called_arity) - , (has_caf_info, text "Caf=" <> ppr caf_info) - , (has_str_info, text "Str=" <> pprStrictness str_info) - , (has_unf, text "Unf=" <> ppr unf_info) - , (not (null rules), text "RULES:" <+> vcat (map pprRule rules)) - ] -- Inline pragma, occ, demand, one-shot info - -- printed out with all binders (when debug is on); - -- see PprCore.pprIdBndr - where - pp_scope | isGlobalId id = text "GblId" - | isExportedId id = text "LclIdX" - | otherwise = text "LclId" - - arity = arityInfo info - has_arity = arity /= 0 - - called_arity = callArityInfo info - has_called_arity = called_arity /= 0 - - caf_info = cafInfo info - has_caf_info = not (mayHaveCafRefs caf_info) - - str_info = strictnessInfo info - has_str_info = not (isTopSig str_info) - - unf_info = unfoldingInfo info - has_unf = hasSomeUnfolding unf_info - - rules = ruleInfoRules (ruleInfo info) - -showAttributes :: [(Bool,SDoc)] -> SDoc -showAttributes stuff - | null docs = empty - | otherwise = brackets (sep (punctuate comma docs)) - where - docs = [d | (True,d) <- stuff] - -{- ------------------------------------------------------ --- Unfolding and UnfoldingGuidance ------------------------------------------------------ --} - -instance Outputable UnfoldingGuidance where - ppr UnfNever = text "NEVER" - ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) - = text "ALWAYS_IF" <> - parens (text "arity=" <> int arity <> comma <> - text "unsat_ok=" <> ppr unsat_ok <> comma <> - text "boring_ok=" <> ppr boring_ok) - ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) - = hsep [ text "IF_ARGS", - brackets (hsep (map int cs)), - int size, - int discount ] - -instance Outputable UnfoldingSource where - ppr InlineCompulsory = text "Compulsory" - ppr InlineStable = text "InlineStable" - ppr InlineRhs = text "" - -instance Outputable Unfolding where - ppr NoUnfolding = text "No unfolding" - ppr BootUnfolding = text "No unfolding (from boot)" - ppr (OtherCon cs) = text "OtherCon" <+> ppr cs - ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) - = hang (text "DFun:" <+> ptext (sLit "\\") - <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) - 2 (ppr con <+> sep (map ppr args)) - ppr (CoreUnfolding { uf_src = src - , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf - , uf_is_conlike=conlike, uf_is_work_free=wf - , uf_expandable=exp, uf_guidance=g }) - = text "Unf" <> braces (pp_info $$ pp_rhs) - where - pp_info = fsep $ punctuate comma - [ text "Src=" <> ppr src - , text "TopLvl=" <> ppr top - , text "Value=" <> ppr hnf - , text "ConLike=" <> ppr conlike - , text "WorkFree=" <> ppr wf - , text "Expandable=" <> ppr exp - , text "Guidance=" <> ppr g ] - pp_tmpl = sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressUnfoldings dflags) $ - text "Tmpl=" <+> ppr rhs - pp_rhs | isStableSource src = pp_tmpl - | otherwise = empty - -- Don't print the RHS or we get a quadratic - -- blowup in the size of the printout! - -{- ------------------------------------------------------ --- Rules ------------------------------------------------------ --} - -instance Outputable CoreRule where - ppr = pprRule - -pprRules :: [CoreRule] -> SDoc -pprRules rules = vcat (map pprRule rules) - -pprRule :: CoreRule -> SDoc -pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) - = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name) - -pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, - ru_bndrs = tpl_vars, ru_args = tpl_args, - ru_rhs = rhs }) - = hang (doubleQuotes (ftext name) <+> ppr act) - 4 (sep [text "forall" <+> - sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, - nest 2 (ppr fn <+> sep (map pprArg tpl_args)), - nest 2 (text "=" <+> pprCoreExpr rhs) - ]) - -{- ------------------------------------------------------ --- Tickish ------------------------------------------------------ --} - -instance Outputable id => Outputable (Tickish id) where - ppr (HpcTick modl ix) = - hcat [text "hpc<", - ppr modl, comma, - ppr ix, - text ">"] - ppr (Breakpoint ix vars) = - hcat [text "break<", - ppr ix, - text ">", - parens (hcat (punctuate comma (map ppr vars)))] - ppr (ProfNote { profNoteCC = cc, - profNoteCount = tick, - profNoteScope = scope }) = - case (tick,scope) of - (True,True) -> hcat [text "scctick<", ppr cc, char '>'] - (True,False) -> hcat [text "tick<", ppr cc, char '>'] - _ -> hcat [text "scc<", ppr cc, char '>'] - ppr (SourceNote span _) = - hcat [ text "src<", pprUserRealSpan True span, char '>'] - -{- ------------------------------------------------------ --- Vectorisation declarations ------------------------------------------------------ --} - -instance Outputable CoreVect where - ppr (Vect var e) = hang (text "VECTORISE" <+> ppr var <+> char '=') - 4 (pprCoreExpr e) - ppr (NoVect var) = text "NOVECTORISE" <+> ppr var - ppr (VectType False var Nothing) = text "VECTORISE type" <+> ppr var - ppr (VectType True var Nothing) = text "VECTORISE SCALAR type" <+> ppr var - ppr (VectType False var (Just tc)) = text "VECTORISE type" <+> ppr var <+> char '=' <+> - ppr tc - ppr (VectType True var (Just tc)) = text "VECTORISE SCALAR type" <+> ppr var <+> - char '=' <+> ppr tc - ppr (VectClass tc) = text "VECTORISE class" <+> ppr tc - ppr (VectInst var) = text "VECTORISE SCALAR instance" <+> ppr var diff --git a/coreSyn/TrieMap.hs b/coreSyn/TrieMap.hs deleted file mode 100644 --- a/coreSyn/TrieMap.hs +++ /dev/null @@ -1,1129 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -module TrieMap( - -- * Maps over Core expressions - CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, - -- * Maps over 'Type's - TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, - LooseTypeMap, - -- ** With explicit scoping - CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope, - mkDeBruijnContext, - -- * Maps over 'Maybe' values - MaybeMap, - -- * Maps over 'List' values - ListMap, - -- * Maps over 'Literal's - LiteralMap, - -- * 'TrieMap' class - TrieMap(..), insertTM, deleteTM, - lkDFreeVar, xtDFreeVar, - lkDNamed, xtDNamed, - (>.>), (|>), (|>>), - ) where - -import CoreSyn -import Coercion -import Literal -import Name -import Type -import TyCoRep -import Var -import UniqDFM -import Unique( Unique ) -import FastString(FastString) - -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import VarEnv -import NameEnv -import Outputable -import Control.Monad( (>=>) ) - -{- -This module implements TrieMaps, which are finite mappings -whose key is a structured value like a CoreExpr or Type. - -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. - -The regular pattern for handling TrieMaps on data structures was first -described (to my knowledge) in Connelly and Morris's 1995 paper "A -generalization of the Trie Data Structure"; there is also an accessible -description of the idea in Okasaki's book "Purely Functional Data -Structures", Section 10.3.2 - -************************************************************************ -* * - The TrieMap class -* * -************************************************************************ --} - -type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) - -- or an existing elt (Just) - -class TrieMap m where - type Key m :: * - emptyTM :: m a - lookupTM :: forall b. Key m -> m b -> Maybe b - alterTM :: forall b. Key m -> XT b -> m b -> m b - mapTM :: (a->b) -> m a -> m b - - foldTM :: (a -> b -> b) -> m a -> b -> b - -- The unusual argument order here makes - -- it easy to compose calls to foldTM; - -- see for example fdE below - -insertTM :: TrieMap m => Key m -> a -> m a -> m a -insertTM k v m = alterTM k (\_ -> Just v) m - -deleteTM :: TrieMap m => Key m -> m a -> m a -deleteTM k m = alterTM k (\_ -> Nothing) m - ----------------------- --- Recall that --- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c - -(>.>) :: (a -> b) -> (b -> c) -> a -> c --- Reverse function composition (do f first, then g) -infixr 1 >.> -(f >.> g) x = g (f x) -infixr 1 |>, |>> - -(|>) :: a -> (a->b) -> b -- Reverse application -x |> f = f x - ----------------------- -(|>>) :: TrieMap m2 - => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) - -> (m2 a -> m2 a) - -> m1 (m2 a) -> m1 (m2 a) -(|>>) f g = f (Just . g . deMaybe) - -deMaybe :: TrieMap m => Maybe (m a) -> m a -deMaybe Nothing = emptyTM -deMaybe (Just m) = m - -{- -************************************************************************ -* * - IntMaps -* * -************************************************************************ --} - -instance TrieMap IntMap.IntMap where - type Key IntMap.IntMap = Int - emptyTM = IntMap.empty - lookupTM k m = IntMap.lookup k m - alterTM = xtInt - foldTM k m z = IntMap.foldr k z m - mapTM f m = IntMap.map f m - -xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a -xtInt k f m = IntMap.alter f k m - -instance Ord k => TrieMap (Map.Map k) where - type Key (Map.Map k) = k - emptyTM = Map.empty - lookupTM = Map.lookup - alterTM k f m = Map.alter f k m - foldTM k m z = Map.foldr k z m - mapTM f m = Map.map f m - - -{- -Note [foldTM determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We want foldTM to be deterministic, which is why we have an instance of -TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that -go wrong if foldTM is nondeterministic. Consider: - - f a b = return (a <> b) - -Depending on the order that the typechecker generates constraints you -get either: - - f :: (Monad m, Monoid a) => a -> a -> m a - -or: - - f :: (Monoid a, Monad m) => a -> a -> m a - -The generated code will be different after desugaring as the dictionaries -will be bound in different orders, leading to potential ABI incompatibility. - -One way to solve this would be to notice that the typeclasses could be -sorted alphabetically. - -Unfortunately that doesn't quite work with this example: - - f a b = let x = a <> a; y = b <> b in x - -where you infer: - - f :: (Monoid m, Monoid m1) => m1 -> m -> m1 - -or: - - f :: (Monoid m1, Monoid m) => m1 -> m -> m1 - -Here you could decide to take the order of the type variables in the type -according to depth first traversal and use it to order the constraints. - -The real trouble starts when the user enables incoherent instances and -the compiler has to make an arbitrary choice. Consider: - - class T a b where - go :: a -> b -> String - - instance (Show b) => T Int b where - go a b = show a ++ show b - - instance (Show a) => T a Bool where - go a b = show a ++ show b - - f = go 10 True - -GHC is free to choose either dictionary to implement f, but for the sake of -determinism we'd like it to be consistent when compiling the same sources -with the same flags. - -inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it -gets converted to a bag of (Wanted) Cts using a fold. Then in -solve_simple_wanteds it's merged with other WantedConstraints. We want the -conversion to a bag to be deterministic. For that purpose we use UniqDFM -instead of UniqFM to implement the TrieMap. - -See Note [Deterministic UniqFM] in UniqDFM for more details on how it's made -deterministic. --} - -instance TrieMap UniqDFM where - type Key UniqDFM = Unique - emptyTM = emptyUDFM - lookupTM k m = lookupUDFM m k - alterTM k f m = alterUDFM f m k - foldTM k m z = foldUDFM k z m - mapTM f m = mapUDFM f m - -{- -************************************************************************ -* * - Maybes -* * -************************************************************************ - -If m is a map from k -> val -then (MaybeMap m) is a map from (Maybe k) -> val --} - -data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } - -instance TrieMap m => TrieMap (MaybeMap m) where - type Key (MaybeMap m) = Maybe (Key m) - emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } - lookupTM = lkMaybe lookupTM - alterTM = xtMaybe alterTM - foldTM = fdMaybe - mapTM = mapMb - -mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b -mapMb f (MM { mm_nothing = mn, mm_just = mj }) - = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } - -lkMaybe :: (forall b. k -> m b -> Maybe b) - -> Maybe k -> MaybeMap m a -> Maybe a -lkMaybe _ Nothing = mm_nothing -lkMaybe lk (Just x) = mm_just >.> lk x - -xtMaybe :: (forall b. k -> XT b -> m b -> m b) - -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a -xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } -xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } - -fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b -fdMaybe k m = foldMaybe k (mm_nothing m) - . foldTM k (mm_just m) - -{- -************************************************************************ -* * - Lists -* * -************************************************************************ --} - -data ListMap m a - = LM { lm_nil :: Maybe a - , lm_cons :: m (ListMap m a) } - -instance TrieMap m => TrieMap (ListMap m) where - type Key (ListMap m) = [Key m] - emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } - lookupTM = lkList lookupTM - alterTM = xtList alterTM - foldTM = fdList - mapTM = mapList - -mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b -mapList f (LM { lm_nil = mnil, lm_cons = mcons }) - = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } - -lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) - -> [k] -> ListMap m a -> Maybe a -lkList _ [] = lm_nil -lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs - -xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) - -> [k] -> XT a -> ListMap m a -> ListMap m a -xtList _ [] f m = m { lm_nil = f (lm_nil m) } -xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } - -fdList :: forall m a b. TrieMap m - => (a -> b -> b) -> ListMap m a -> b -> b -fdList k m = foldMaybe k (lm_nil m) - . foldTM (fdList k) (lm_cons m) - -foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b -foldMaybe _ Nothing b = b -foldMaybe k (Just a) b = k a b - -{- -************************************************************************ -* * - Basic maps -* * -************************************************************************ --} - -lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a -lkDNamed n env = lookupDNameEnv env (getName n) - -xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a -xtDNamed tc f m = alterDNameEnv f m (getName tc) - ------------------------- -type LiteralMap a = Map.Map Literal a - -emptyLiteralMap :: LiteralMap a -emptyLiteralMap = emptyTM - -lkLit :: Literal -> LiteralMap a -> Maybe a -lkLit = lookupTM - -xtLit :: Literal -> XT a -> LiteralMap a -> LiteralMap a -xtLit = alterTM - -{- -************************************************************************ -* * - GenMap -* * -************************************************************************ - -Note [Compressed TrieMap] -~~~~~~~~~~~~~~~~~~~~~~~~~ - -The GenMap constructor augments TrieMaps with leaf compression. This helps -solve the performance problem detailed in #9960: suppose we have a handful -H of entries in a TrieMap, each with a very large key, size K. If you fold over -such a TrieMap you'd expect time O(H). That would certainly be true of an -association list! But with TrieMap we actually have to navigate down a long -singleton structure to get to the elements, so it takes time O(K*H). This -can really hurt on many type-level computation benchmarks: -see for example T9872d. - -The point of a TrieMap is that you need to navigate to the point where only one -key remains, and then things should be fast. So the point of a SingletonMap -is that, once we are down to a single (key,value) pair, we stop and -just use SingletonMap. - -'EmptyMap' provides an even more basic (but essential) optimization: if there is -nothing in the map, don't bother building out the (possibly infinite) recursive -TrieMap structure! --} - -data GenMap m a - = EmptyMap - | SingletonMap (Key m) a - | MultiMap (m a) - -instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where - ppr EmptyMap = text "Empty map" - ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v - ppr (MultiMap m) = ppr m - --- TODO undecidable instance -instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where - type Key (GenMap m) = Key m - emptyTM = EmptyMap - lookupTM = lkG - alterTM = xtG - foldTM = fdG - mapTM = mapG - --- NB: Be careful about RULES and type families (#5821). So we should make sure --- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form) - -{-# SPECIALIZE lkG :: Key TypeMapX -> TypeMapG a -> Maybe a #-} -{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-} -{-# SPECIALIZE lkG :: Key CoreMapX -> CoreMapG a -> Maybe a #-} -lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a -lkG _ EmptyMap = Nothing -lkG k (SingletonMap k' v') | k == k' = Just v' - | otherwise = Nothing -lkG k (MultiMap m) = lookupTM k m - -{-# SPECIALIZE xtG :: Key TypeMapX -> XT a -> TypeMapG a -> TypeMapG a #-} -{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-} -{-# SPECIALIZE xtG :: Key CoreMapX -> XT a -> CoreMapG a -> CoreMapG a #-} -xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a -xtG k f EmptyMap - = case f Nothing of - Just v -> SingletonMap k v - Nothing -> EmptyMap -xtG k f m@(SingletonMap k' v') - | k' == k - -- The new key matches the (single) key already in the tree. Hence, - -- apply @f@ to @Just v'@ and build a singleton or empty map depending - -- on the 'Just'/'Nothing' response respectively. - = case f (Just v') of - Just v'' -> SingletonMap k' v'' - Nothing -> EmptyMap - | otherwise - -- We've hit a singleton tree for a different key than the one we are - -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then - -- we can just return the old map. If not, we need a map with *two* - -- entries. The easiest way to do that is to insert two items into an empty - -- map of type @m a@. - = case f Nothing of - Nothing -> m - Just v -> emptyTM |> alterTM k' (const (Just v')) - >.> alterTM k (const (Just v)) - >.> MultiMap -xtG k f (MultiMap m) = MultiMap (alterTM k f m) - -{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a -> TypeMapG b #-} -{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-} -{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a -> CoreMapG b #-} -mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b -mapG _ EmptyMap = EmptyMap -mapG f (SingletonMap k v) = SingletonMap k (f v) -mapG f (MultiMap m) = MultiMap (mapTM f m) - -{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a -> b -> b #-} -{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-} -{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a -> b -> b #-} -fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b -fdG _ EmptyMap = \z -> z -fdG k (SingletonMap _ v) = \z -> k v z -fdG k (MultiMap m) = foldTM k m - -{- -************************************************************************ -* * - 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, notalby - - 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 (Trac #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 CoreSyn. --} - --- | @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) - --- | @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 (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) - = length ps1 == length 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 = emptyLiteralMap - , 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 - --------------------------- -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 } - --------------------------- -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 >.> lkLit 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 |> xtLit 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 (Tickish Id) a -lkTickish :: Tickish Id -> TickishMap a -> Maybe a -lkTickish = lookupTM - -xtTickish :: Tickish Id -> 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 = emptyLiteralMap } - lookupTM = lkA emptyCME - alterTM = xtA emptyCME - foldTM = fdA - mapTM = mapA - -instance Eq (DeBruijn CoreAlt) where - D env1 a1 == D env2 a2 = go a1 a2 where - go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2) - = D env1 rhs1 == D env2 rhs2 - go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2) - = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 - go (DataAlt dc1, bs1, rhs1) (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 } - -lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a -lkA env (DEFAULT, _, rhs) = am_deflt >.> lkG (D env rhs) -lkA env (LitAlt lit, _, rhs) = am_lit >.> lkLit lit >=> lkG (D env rhs) -lkA env (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 (DEFAULT, _, rhs) f m = - m { am_deflt = am_deflt m |> xtG (D env rhs) f } -xtA env (LitAlt l, _, rhs) f m = - m { am_lit = am_lit m |> xtLit l |>> xtG (D env rhs) f } -xtA env (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) - -{- -************************************************************************ -* * - Coercions -* * -************************************************************************ --} - --- We should really never care about the contents of a coercion. Instead, --- just look up the coercion's type. -newtype CoercionMap a = CoercionMap (CoercionMapG a) - -instance TrieMap CoercionMap where - type Key CoercionMap = Coercion - emptyTM = CoercionMap emptyTM - lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m - alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) - foldTM k (CoercionMap m) = foldTM k m - mapTM f (CoercionMap m) = CoercionMap (mapTM f m) - -type CoercionMapG = GenMap CoercionMapX -newtype CoercionMapX a = CoercionMapX (TypeMapX a) - -instance TrieMap CoercionMapX where - type Key CoercionMapX = DeBruijn Coercion - emptyTM = CoercionMapX emptyTM - lookupTM = lkC - alterTM = xtC - foldTM f (CoercionMapX core_tm) = foldTM f core_tm - mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm) - -instance Eq (DeBruijn Coercion) where - D env1 co1 == D env2 co2 - = D env1 (coercionType co1) == - D env2 (coercionType co2) - -lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a -lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co) - core_tm - -xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a -xtC (D env co) f (CoercionMapX m) - = CoercionMapX (xtT (D env $ coercionType co) f m) - -{- -************************************************************************ -* * - Types -* * -************************************************************************ --} - --- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@. The extended --- key makes it suitable for recursive traversal, since it can track binders, --- but it is strictly internal to this module. If you are including a 'TypeMap' --- inside another 'TrieMap', this is the type you want. Note that this --- lookup does not do a kind-check. Thus, all keys in this map must have --- the same kind. Also note that this map respects the distinction between --- @Type@ and @Constraint@, despite the fact that they are equivalent type --- synonyms in Core. -type TypeMapG = GenMap TypeMapX - --- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the --- 'GenMap' optimization. -data TypeMapX a - = TM { tm_var :: VarMap a - , tm_app :: TypeMapG (TypeMapG a) - , tm_tycon :: DNameEnv a - , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] - , tm_tylit :: TyLitMap a - , tm_coerce :: Maybe a - } - -- Note that there is no tyconapp case; see Note [Equality on AppTys] in Type - --- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the --- last one? See Note [Equality on AppTys] in Type --- --- Note, however, that we keep Constraint and Type apart here, despite the fact --- that they are both synonyms of TYPE 'LiftedRep (see #11715). -trieMapView :: Type -> Maybe Type -trieMapView ty - -- First check for TyConApps that need to be expanded to - -- AppTy chains. - | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty - = Just $ foldl AppTy (TyConApp tc []) tys - - -- Then resolve any remaining nullary synonyms. - | Just ty' <- tcView ty = Just ty' -trieMapView _ = Nothing - -instance TrieMap TypeMapX where - type Key TypeMapX = DeBruijn Type - emptyTM = emptyT - lookupTM = lkT - alterTM = xtT - foldTM = fdT - mapTM = mapT - -instance Eq (DeBruijn Type) where - env_t@(D env t) == env_t'@(D env' t') - | Just new_t <- tcView t = D env new_t == env_t' - | Just new_t' <- tcView t' = env_t == D env' new_t' - | otherwise - = case (t, t') of - (CastTy t1 _, _) -> D env t1 == D env t' - (_, CastTy t1' _) -> D env t == D env t1' - - (TyVarTy v, TyVarTy v') - -> case (lookupCME env v, lookupCME env' v') of - (Just bv, Just bv') -> bv == bv' - (Nothing, Nothing) -> v == v' - _ -> False - -- See Note [Equality on AppTys] in Type - (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s - -> D env t1 == D env' t1' && D env t2 == D env' t2' - (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s - -> D env t1 == D env' t1' && D env t2 == D env' t2' - (FunTy t1 t2, FunTy t1' t2') - -> D env t1 == D env' t1' && D env t2 == D env' t2' - (TyConApp tc tys, TyConApp tc' tys') - -> tc == tc' && D env tys == D env' tys' - (LitTy l, LitTy l') - -> l == l' - (ForAllTy (TvBndr tv _) ty, ForAllTy (TvBndr tv' _) ty') - -> D env (tyVarKind tv) == D env' (tyVarKind tv') && - D (extendCME env tv) ty == D (extendCME env' tv') ty' - (CoercionTy {}, CoercionTy {}) - -> True - _ -> False - -instance {-# OVERLAPPING #-} - Outputable a => Outputable (TypeMapG a) where - ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m []) - -emptyT :: TypeMapX a -emptyT = TM { tm_var = emptyTM - , tm_app = EmptyMap - , tm_tycon = emptyDNameEnv - , tm_forall = EmptyMap - , tm_tylit = emptyTyLitMap - , tm_coerce = Nothing } - -mapT :: (a->b) -> TypeMapX a -> TypeMapX b -mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon - , tm_forall = tforall, tm_tylit = tlit - , tm_coerce = tcoerce }) - = TM { tm_var = mapTM f tvar - , tm_app = mapTM (mapTM f) tapp - , tm_tycon = mapTM f ttycon - , tm_forall = mapTM (mapTM f) tforall - , tm_tylit = mapTM f tlit - , tm_coerce = fmap f tcoerce } - ------------------ -lkT :: DeBruijn Type -> TypeMapX a -> Maybe a -lkT (D env ty) m = go ty m - where - go ty | Just ty' <- trieMapView ty = go ty' - go (TyVarTy v) = tm_var >.> lkVar env v - go (AppTy t1 t2) = tm_app >.> lkG (D env t1) - >=> lkG (D env t2) - go (TyConApp tc []) = tm_tycon >.> lkDNamed tc - go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) - go (LitTy l) = tm_tylit >.> lkTyLit l - go (ForAllTy (TvBndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) - >=> lkBndr env tv - go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) - go (CastTy t _) = go t - go (CoercionTy {}) = tm_coerce - ------------------ -xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a -xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m - -xtT (D env (TyVarTy v)) f m = m { tm_var = tm_var m |> xtVar env v f } -xtT (D env (AppTy t1 t2)) f m = m { tm_app = tm_app m |> xtG (D env t1) - |>> xtG (D env t2) f } -xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f } -xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } -xtT (D env (CastTy t _)) f m = xtT (D env t) f m -xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } -xtT (D env (ForAllTy (TvBndr tv _) ty)) f m - = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) - |>> xtBndr env tv f } -xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) -xtT (D _ ty@(FunTy {})) _ _ = pprPanic "xtT FunTy" (ppr ty) - -fdT :: (a -> b -> b) -> TypeMapX a -> b -> b -fdT k m = foldTM k (tm_var m) - . foldTM (foldTM k) (tm_app m) - . foldTM k (tm_tycon m) - . foldTM (foldTM k) (tm_forall m) - . foldTyLit k (tm_tylit m) - . foldMaybe k (tm_coerce m) - ------------------------- -data TyLitMap a = TLM { tlm_number :: Map.Map Integer a - , tlm_string :: Map.Map FastString a - } - -instance TrieMap TyLitMap where - type Key TyLitMap = TyLit - emptyTM = emptyTyLitMap - lookupTM = lkTyLit - alterTM = xtTyLit - foldTM = foldTyLit - mapTM = mapTyLit - -emptyTyLitMap :: TyLitMap a -emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty } - -mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b -mapTyLit f (TLM { tlm_number = tn, tlm_string = ts }) - = TLM { tlm_number = Map.map f tn, tlm_string = Map.map f ts } - -lkTyLit :: TyLit -> TyLitMap a -> Maybe a -lkTyLit l = - case l of - NumTyLit n -> tlm_number >.> Map.lookup n - StrTyLit n -> tlm_string >.> Map.lookup n - -xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a -xtTyLit l f m = - case l of - NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n } - StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n } - -foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b -foldTyLit l m = flip (Map.foldr l) (tlm_string m) - . flip (Map.foldr l) (tlm_number m) - -------------------------------------------------- --- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this --- is the type you want. The keys in this map may have different kinds. -newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a)) - -lkTT :: DeBruijn Type -> TypeMap a -> Maybe a -lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m - >>= lkG (D env ty) - -xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a -xtTT (D env ty) f (TypeMap m) - = TypeMap (m |> xtG (D env $ typeKind ty) - |>> xtG (D env ty) f) - --- Below are some client-oriented functions which operate on 'TypeMap'. - -instance TrieMap TypeMap where - type Key TypeMap = Type - emptyTM = TypeMap emptyTM - lookupTM k m = lkTT (deBruijnize k) m - alterTM k f m = xtTT (deBruijnize k) f m - foldTM k (TypeMap m) = foldTM (foldTM k) m - mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m) - -foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b -foldTypeMap k z m = foldTM k m z - -emptyTypeMap :: TypeMap a -emptyTypeMap = emptyTM - -lookupTypeMap :: TypeMap a -> Type -> Maybe a -lookupTypeMap cm t = lookupTM t cm - -extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a -extendTypeMap m t v = alterTM t (const (Just v)) m - -lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a -lookupTypeMapWithScope m cm t = lkTT (D cm t) m - --- | Extend a 'TypeMap' with a type in the given context. --- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to --- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over --- multiple insertions. -extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a -extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m - --- | Construct a deBruijn environment with the given variables in scope. --- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@ -mkDeBruijnContext :: [Var] -> CmEnv -mkDeBruijnContext = extendCMEs emptyCME - --- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g), --- you'll find entries inserted under (t), even if (g) is non-reflexive. -newtype LooseTypeMap a - = LooseTypeMap (TypeMapG a) - -instance TrieMap LooseTypeMap where - type Key LooseTypeMap = Type - emptyTM = LooseTypeMap emptyTM - lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m - alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) - foldTM f (LooseTypeMap m) = foldTM f m - mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m) - -{- -************************************************************************ -* * - Variables -* * -************************************************************************ --} - -type BoundVar = Int -- Bound variables are deBruijn numbered -type BoundVarMap a = IntMap.IntMap a - -data CmEnv = CME { cme_next :: !BoundVar - , cme_env :: VarEnv BoundVar } - -emptyCME :: CmEnv -emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv } - -extendCME :: CmEnv -> Var -> CmEnv -extendCME (CME { cme_next = bv, cme_env = env }) v - = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv } - -extendCMEs :: CmEnv -> [Var] -> CmEnv -extendCMEs env vs = foldl extendCME env vs - -lookupCME :: CmEnv -> Var -> Maybe BoundVar -lookupCME (CME { cme_env = env }) v = lookupVarEnv env v - --- | @DeBruijn a@ represents @a@ modulo alpha-renaming. This is achieved --- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn --- numbering. This allows us to define an 'Eq' instance for @DeBruijn a@, even --- if this was not (easily) possible for @a@. Note: we purposely don't --- export the constructor. Make a helper function if you find yourself --- needing it. -data DeBruijn a = D CmEnv a - --- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no --- bound binders (an empty 'CmEnv'). This is usually what you want if there --- isn't already a 'CmEnv' in scope. -deBruijnize :: a -> DeBruijn a -deBruijnize = D emptyCME - -instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where - D _ [] == D _ [] = True - D env (x:xs) == D env' (x':xs') = D env x == D env' x' && - D env xs == D env' xs' - _ == _ = False - ---------- Variable binders ------------- - --- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between --- binding forms whose binders have different types. For example, --- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should --- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@: --- we can disambiguate this by matching on the type (or kind, if this --- a binder in a type) of the binder. -type BndrMap = TypeMapG - --- Note [Binders] --- ~~~~~~~~~~~~~~ --- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all --- of these data types have binding forms. - -lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a -lkBndr env v m = lkG (D env (varType v)) m - -xtBndr :: CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a -xtBndr env v f = xtG (D env (varType v)) f - ---------- Variable occurrence ------------- -data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable - , vm_fvar :: DVarEnv a } -- Free variable - -instance TrieMap VarMap where - type Key VarMap = Var - emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv } - lookupTM = lkVar emptyCME - alterTM = xtVar emptyCME - foldTM = fdVar - mapTM = mapVar - -mapVar :: (a->b) -> VarMap a -> VarMap b -mapVar f (VM { vm_bvar = bv, vm_fvar = fv }) - = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv } - -lkVar :: CmEnv -> Var -> VarMap a -> Maybe a -lkVar env v - | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv - | otherwise = vm_fvar >.> lkDFreeVar v - -xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a -xtVar env v f m - | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f } - | otherwise = m { vm_fvar = vm_fvar m |> xtDFreeVar v f } - -fdVar :: (a -> b -> b) -> VarMap a -> b -> b -fdVar k m = foldTM k (vm_bvar m) - . foldTM k (vm_fvar m) - -lkDFreeVar :: Var -> DVarEnv a -> Maybe a -lkDFreeVar var env = lookupDVarEnv env var - -xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a -xtDFreeVar v f m = alterDVarEnv f m v diff --git a/deSugar/Check.hs b/deSugar/Check.hs deleted file mode 100644 --- a/deSugar/Check.hs +++ /dev/null @@ -1,1859 +0,0 @@ -{- -Author: George Karachalias - -Pattern Matching Coverage Checking. --} - -{-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-} -{-# LANGUAGE TupleSections #-} - -module Check ( - -- Checking and printing - checkSingle, checkMatches, isAnyPmCheckEnabled, - - -- See Note [Type and Term Equality Propagation] - genCaseTmCs1, genCaseTmCs2 - ) where - -#include "HsVersions.h" - -import TmOracle - -import DynFlags -import HsSyn -import TcHsSyn -import Id -import ConLike -import Name -import FamInstEnv -import TysWiredIn -import TyCon -import SrcLoc -import Util -import Outputable -import FastString -import DataCon -import HscTypes (CompleteMatch(..)) - -import DsMonad -import TcSimplify (tcCheckSatisfiability) -import TcType (toTcType, isStringTy, isIntTy, isWordTy) -import Bag -import ErrUtils -import Var (EvVar) -import Type -import UniqSupply -import DsGRHSs (isTrueLHsExpr) - -import Data.List (find) -import Data.Maybe (isJust, fromMaybe) -import Control.Monad (forM, when, forM_) -import Coercion -import TcEvidence -import IOEnv - -import ListT (ListT(..), fold, select) - -{- -This module checks pattern matches for: -\begin{enumerate} - \item Equations that are redundant - \item Equations with inaccessible right-hand-side - \item Exhaustiveness -\end{enumerate} - -The algorithm is based on the paper: - - "GADTs Meet Their Match: - Pattern-matching Warnings That Account for GADTs, Guards, and Laziness" - - http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf - -%************************************************************************ -%* * - Pattern Match Check Types -%* * -%************************************************************************ --} - --- We use the non-determinism monad to apply the algorithm to several --- possible sets of constructors. Users can specify complete sets of --- constructors by using COMPLETE pragmas. --- The algorithm only picks out constructor --- sets deep in the bowels which makes a simpler `mapM` more difficult to --- implement. The non-determinism is only used in one place, see the ConVar --- case in `pmCheckHd`. - -type PmM a = ListT DsM a - -liftD :: DsM a -> PmM a -liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk - --- Pick the first match complete covered match or otherwise the "best" match. --- The best match is the one with the least uncovered clauses, ties broken --- by the number of inaccessible clauses followed by number of redudant --- clauses -getResult :: PmM PmResult -> DsM PmResult -getResult ls = do - res <- fold ls goM (pure Nothing) - case res of - Nothing -> panic "getResult is empty" - Just a -> return a - where - goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult) - goM mpm dpm = do - pmr <- dpm - return $ go pmr mpm - -- Careful not to force unecessary results - go :: Maybe PmResult -> PmResult -> Maybe PmResult - go Nothing rs = Just rs - go old@(Just (PmResult prov rs (UncoveredPatterns us) is)) new - | null us && null rs && null is = old - | otherwise = - let PmResult prov' rs' (UncoveredPatterns us') is' = new - lr = length rs - lr' = length rs' - li = length is - li' = length is' - in case compare (length us) (length us') - `mappend` (compare li li') - `mappend` (compare lr lr') - `mappend` (compare prov prov') of - GT -> Just new - EQ -> Just new - LT -> old - go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new - = panic "getResult: No inhabitation candidates" - -data PatTy = PAT | VA -- Used only as a kind, to index PmPat - --- The *arity* of a PatVec [p1,..,pn] is --- the number of p1..pn that are not Guards - -data PmPat :: PatTy -> * where - PmCon :: { pm_con_con :: ConLike - , pm_con_arg_tys :: [Type] - , pm_con_tvs :: [TyVar] - , pm_con_dicts :: [EvVar] - , pm_con_args :: [PmPat t] } -> PmPat t - -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs - PmVar :: { pm_var_id :: Id } -> PmPat t - PmLit :: { pm_lit_lit :: PmLit } -> PmPat t -- See Note [Literals in PmPat] - PmNLit :: { pm_lit_id :: Id - , pm_lit_not :: [PmLit] } -> PmPat 'VA - PmGrd :: { pm_grd_pv :: PatVec - , pm_grd_expr :: PmExpr } -> PmPat 'PAT - --- data T a where --- MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p] --- or MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r - -type Pattern = PmPat 'PAT -- ^ Patterns -type ValAbs = PmPat 'VA -- ^ Value Abstractions - -type PatVec = [Pattern] -- ^ Pattern Vectors -data ValVec = ValVec [ValAbs] Delta -- ^ Value Vector Abstractions - --- | Term and type constraints to accompany each value vector abstraction. --- For efficiency, we store the term oracle state instead of the term --- constraints. TODO: Do the same for the type constraints? -data Delta = MkDelta { delta_ty_cs :: Bag EvVar - , delta_tm_cs :: TmState } - -type ValSetAbs = [ValVec] -- ^ Value Set Abstractions -type Uncovered = ValSetAbs - --- Instead of keeping the whole sets in memory, we keep a boolean for both the --- covered and the divergent set (we store the uncovered set though, since we --- want to print it). For both the covered and the divergent we have: --- --- True <=> The set is non-empty --- --- hence: --- C = True ==> Useful clause (no warning) --- C = False, D = True ==> Clause with inaccessible RHS --- C = False, D = False ==> Redundant clause - -data Covered = Covered | NotCovered - deriving Show - -instance Outputable Covered where - ppr (Covered) = text "Covered" - ppr (NotCovered) = text "NotCovered" - --- Like the or monoid for booleans --- Covered = True, Uncovered = False -instance Monoid Covered where - mempty = NotCovered - Covered `mappend` _ = Covered - _ `mappend` Covered = Covered - NotCovered `mappend` NotCovered = NotCovered - -data Diverged = Diverged | NotDiverged - deriving Show - -instance Outputable Diverged where - ppr Diverged = text "Diverged" - ppr NotDiverged = text "NotDiverged" - -instance Monoid Diverged where - mempty = NotDiverged - Diverged `mappend` _ = Diverged - _ `mappend` Diverged = Diverged - NotDiverged `mappend` NotDiverged = NotDiverged - --- | When we learned that a given match group is complete -data Provenance = - FromBuiltin -- ^ From the original definition of the type - -- constructor. - | FromComplete -- ^ From a user-provided @COMPLETE@ pragma - deriving (Show, Eq, Ord) - -instance Outputable Provenance where - ppr = text . show - -instance Monoid Provenance where - mempty = FromBuiltin - FromComplete `mappend` _ = FromComplete - _ `mappend` FromComplete = FromComplete - _ `mappend` _ = FromBuiltin - -data PartialResult = PartialResult { - presultProvenence :: Provenance - -- keep track of provenance because we don't want - -- to warn about redundant matches if the result - -- is contaiminated with a COMPLETE pragma - , presultCovered :: Covered - , presultUncovered :: Uncovered - , presultDivergent :: Diverged } - -instance Outputable PartialResult where - ppr (PartialResult prov c vsa d) - = text "PartialResult" <+> ppr prov <+> ppr c - <+> ppr d <+> ppr vsa - -instance Monoid PartialResult where - mempty = PartialResult mempty mempty [] mempty - (PartialResult prov1 cs1 vsa1 ds1) - `mappend` (PartialResult prov2 cs2 vsa2 ds2) - = PartialResult (prov1 `mappend` prov2) - (cs1 `mappend` cs2) - (vsa1 `mappend` vsa2) - (ds1 `mappend` ds2) - --- newtype ChoiceOf a = ChoiceOf [a] - --- | Pattern check result --- --- * Redundant clauses --- * Not-covered clauses (or their type, if no pattern is available) --- * Clauses with inaccessible RHS --- --- More details about the classification of clauses into useful, redundant --- and with inaccessible right hand side can be found here: --- --- https://ghc.haskell.org/trac/ghc/wiki/PatternMatchCheck --- -data PmResult = - PmResult { - pmresultProvenance :: Provenance - , pmresultRedundant :: [Located [LPat Id]] - , pmresultUncovered :: UncoveredCandidates - , pmresultInaccessible :: [Located [LPat Id]] } - --- | Either a list of patterns that are not covered, or their type, in case we --- have no patterns at hand. Not having patterns at hand can arise when --- handling EmptyCase expressions, in two cases: --- --- * The type of the scrutinee is a trivially inhabited type (like Int or Char) --- * The type of the scrutinee cannot be reduced to WHNF. --- --- In both these cases we have no inhabitation candidates for the type at hand, --- but we don't want to issue just a wildcard as missing. Instead, we print a --- type annotated wildcard, so that the user knows what kind of patterns is --- expected (e.g. (_ :: Int), or (_ :: F Int), where F Int does not reduce). -data UncoveredCandidates = UncoveredPatterns Uncovered - | TypeOfUncovered Type - --- | The empty pattern check result -emptyPmResult :: PmResult -emptyPmResult = PmResult FromBuiltin [] (UncoveredPatterns []) [] - --- | Non-exhaustive empty case with unknown/trivial inhabitants -uncoveredWithTy :: Type -> PmResult -uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) [] - -{- -%************************************************************************ -%* * - Entry points to the checker: checkSingle and checkMatches -%* * -%************************************************************************ --} - --- | Check a single pattern binding (let) -checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM () -checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do - tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p]) - mb_pm_res <- tryM (getResult (checkSingle' locn var p)) - case mb_pm_res of - Left _ -> warnPmIters dflags ctxt - Right res -> dsPmWarn dflags ctxt res - --- | Check a single pattern binding (let) -checkSingle' :: SrcSpan -> Id -> Pat Id -> PmM PmResult -checkSingle' locn var p = do - liftD resetPmIterDs -- set the iter-no to zero - fam_insts <- liftD dsGetFamInstEnvs - clause <- liftD $ translatePat fam_insts p - missing <- mkInitialUncovered [var] - tracePm "checkSingle: missing" (vcat (map pprValVecDebug missing)) - -- no guards - PartialResult prov cs us ds <- runMany (pmcheckI clause []) missing - let us' = UncoveredPatterns us - return $ case (cs,ds) of - (Covered, _ ) -> PmResult prov [] us' [] -- useful - (NotCovered, NotDiverged) -> PmResult prov m us' [] -- redundant - (NotCovered, Diverged ) -> PmResult prov [] us' m -- inaccessible rhs - where m = [L locn [L locn p]] - --- | Check a matchgroup (case, functions, etc.) -checkMatches :: DynFlags -> DsMatchContext - -> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM () -checkMatches dflags ctxt vars matches = do - tracePmD "checkMatches" (hang (vcat [ppr ctxt - , ppr vars - , text "Matches:"]) - 2 - (vcat (map ppr matches))) - mb_pm_res <- tryM $ getResult $ case matches of - -- Check EmptyCase separately - -- See Note [Checking EmptyCase Expressions] - [] | [var] <- vars -> checkEmptyCase' var - _normal_match -> checkMatches' vars matches - case mb_pm_res of - Left _ -> warnPmIters dflags ctxt - Right res -> dsPmWarn dflags ctxt res - --- | Check a matchgroup (case, functions, etc.). To be called on a non-empty --- list of matches. For empty case expressions, use checkEmptyCase' instead. -checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> PmM PmResult -checkMatches' vars matches - | null matches = panic "checkMatches': EmptyCase" - | otherwise = do - liftD resetPmIterDs -- set the iter-no to zero - missing <- mkInitialUncovered vars - tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing)) - (prov, rs,us,ds) <- go matches missing - return $ PmResult { - pmresultProvenance = prov - , pmresultRedundant = map hsLMatchToLPats rs - , pmresultUncovered = UncoveredPatterns us - , pmresultInaccessible = map hsLMatchToLPats ds } - where - go :: [LMatch Id (LHsExpr Id)] -> Uncovered - -> PmM (Provenance - , [LMatch Id (LHsExpr Id)] - , Uncovered - , [LMatch Id (LHsExpr Id)]) - go [] missing = return (mempty, [], missing, []) - go (m:ms) missing = do - tracePm "checMatches': go" (ppr m $$ ppr missing) - fam_insts <- liftD dsGetFamInstEnvs - (clause, guards) <- liftD $ translateMatch fam_insts m - r@(PartialResult prov cs missing' ds) - <- runMany (pmcheckI clause guards) missing - tracePm "checMatches': go: res" (ppr r) - (ms_prov, rs, final_u, is) <- go ms missing' - let final_prov = prov `mappend` ms_prov - return $ case (cs, ds) of - -- useful - (Covered, _ ) -> (final_prov, rs, final_u, is) - -- redundant - (NotCovered, NotDiverged) -> (final_prov, m:rs, final_u,is) - -- inaccessible - (NotCovered, Diverged ) -> (final_prov, rs, final_u, m:is) - - hsLMatchToLPats :: LMatch id body -> Located [LPat id] - hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats - --- | Check an empty case expression. Since there are no clauses to process, we --- only compute the uncovered set. See Note [Checking EmptyCase Expressions] --- for details. -checkEmptyCase' :: Id -> PmM PmResult -checkEmptyCase' var = do - tm_css <- map toComplex . bagToList <$> liftD getTmCsDs - case tmOracle initialTmState tm_css of - Just tm_state -> do - ty_css <- liftD getDictsDs - fam_insts <- liftD dsGetFamInstEnvs - mb_candidates <- inhabitationCandidates fam_insts (idType var) - case mb_candidates of - -- Inhabitation checking failed / the type is trivially inhabited - Left ty -> return (uncoveredWithTy ty) - - -- A list of inhabitant candidates is available: Check for each - -- one for the satisfiability of the constraints it gives rise to. - Right candidates -> do - missing_m <- flip concatMapM candidates $ \(va,tm_ct,ty_cs) -> do - let all_ty_cs = unionBags ty_cs ty_css - sat_ty <- tyOracle all_ty_cs - return $ case (sat_ty, tmOracle tm_state (tm_ct:tm_css)) of - (True, Just tm_state') -> [(va, all_ty_cs, tm_state')] - _non_sat -> [] - let mkValVec (va,all_ty_cs,tm_state') - = ValVec [va] (MkDelta all_ty_cs tm_state') - uncovered = UncoveredPatterns (map mkValVec missing_m) - return $ if null missing_m - then emptyPmResult - else PmResult FromBuiltin [] uncovered [] - Nothing -> return emptyPmResult - --- | Generate all inhabitation candidates for a given type. The result is --- either (Left ty), if the type cannot be reduced to a closed algebraic type --- (or if it's one trivially inhabited, like Int), or (Right candidates), if it --- can. In this case, the candidates are the singnature of the tycon, each one --- accompanied by the term- and type- constraints it gives rise to. --- See also Note [Checking EmptyCase Expressions] -inhabitationCandidates :: FamInstEnvs -> Type - -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)]) -inhabitationCandidates fam_insts ty - = case pmTopNormaliseType_maybe fam_insts ty of - Just (src_ty, dcs, core_ty) -> alts_to_check src_ty core_ty dcs - Nothing -> alts_to_check ty ty [] - where - -- All these types are trivially inhabited - trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon - , intTyCon, wordTyCon, word8TyCon ] - - -- Note: At the moment we leave all the typing and constraint fields of - -- PmCon empty, since we know that they are not gonna be used. Is the - -- right-thing-to-do to actually create them, even if they are never used? - build_tm :: ValAbs -> [DataCon] -> ValAbs - build_tm = foldr (\dc e -> PmCon (RealDataCon dc) [] [] [] [e]) - - -- Inhabitation candidates, using the result of pmTopNormaliseType_maybe - alts_to_check :: Type -> Type -> [DataCon] - -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)]) - alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of - Just (tc, _) - | tc `elem` trivially_inhabited -> case dcs of - [] -> return (Left src_ty) - (_:_) -> do var <- liftD $ mkPmId (toTcType core_ty) - let va = build_tm (PmVar var) dcs - return $ Right [(va, mkIdEq var, emptyBag)] - | isClosedAlgType core_ty -> liftD $ do - var <- mkPmId (toTcType core_ty) -- it would be wrong to unify x - alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc) - return $ Right [(build_tm va dcs, eq, cs) | (va, eq, cs) <- alts] - -- For other types conservatively assume that they are inhabited. - _other -> return (Left src_ty) - -{- Note [Checking EmptyCase Expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Empty case expressions are strict on the scrutinee. That is, `case x of {}` -will force argument `x`. Hence, `checkMatches` is not sufficient for checking -empty cases, because it assumes that the match is not strict (which is true -for all other cases, apart from EmptyCase). This gave rise to #10746. Instead, -we do the following: - -1. We normalise the outermost type family redex, data family redex or newtype, - using pmTopNormaliseType_maybe (in types/FamInstEnv.hs). This computes 3 - things: - (a) A normalised type src_ty, which is equal to the type of the scrutinee in - source Haskell (does not normalise newtypes or data families) - (b) The actual normalised type core_ty, which coincides with the result - topNormaliseType_maybe. This type is not necessarily equal to the input - type in source Haskell. And this is precicely the reason we compute (a) - and (c): the reasoning happens with the underlying types, but both the - patterns and types we print should respect newtypes and also show the - family type constructors and not the representation constructors. - - (c) A list of all newtype data constructors dcs, each one corresponding to a - newtype rewrite performed in (b). - - For an example see also Note [Type normalisation for EmptyCase] - in types/FamInstEnv.hs. - -2. Function checkEmptyCase' performs the check: - - If core_ty is not an algebraic type, then we cannot check for - inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming - that the type is inhabited. - - If core_ty is an algebraic type, then we unfold the scrutinee to all - possible constructor patterns, using inhabitationCandidates, and then - check each one for constraint satisfiability, same as we for normal - pattern match checking. - -%************************************************************************ -%* * - Transform source syntax to *our* syntax -%* * -%************************************************************************ --} - --- ----------------------------------------------------------------------- --- * Utilities - -nullaryConPattern :: ConLike -> Pattern --- Nullary data constructor and nullary type constructor -nullaryConPattern con = - PmCon { pm_con_con = con, pm_con_arg_tys = [] - , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = [] } -{-# INLINE nullaryConPattern #-} - -truePattern :: Pattern -truePattern = nullaryConPattern (RealDataCon trueDataCon) -{-# INLINE truePattern #-} - --- | A fake guard pattern (True <- _) used to represent cases we cannot handle -fake_pat :: Pattern -fake_pat = PmGrd { pm_grd_pv = [truePattern] - , pm_grd_expr = PmExprOther EWildPat } -{-# INLINE fake_pat #-} - --- | Check whether a guard pattern is generated by the checker (unhandled) -isFakeGuard :: [Pattern] -> PmExpr -> Bool -isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat) - | c == trueDataCon = True - | otherwise = False -isFakeGuard _pats _e = False - --- | Generate a `canFail` pattern vector of a specific type -mkCanFailPmPat :: Type -> DsM PatVec -mkCanFailPmPat ty = do - var <- mkPmVar ty - return [var, fake_pat] - -vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern --- ADT constructor pattern => no existentials, no local constraints -vanillaConPattern con arg_tys args = - PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys - , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = args } -{-# INLINE vanillaConPattern #-} - --- | Create an empty list pattern of a given type -nilPattern :: Type -> Pattern -nilPattern ty = - PmCon { pm_con_con = RealDataCon nilDataCon, pm_con_arg_tys = [ty] - , pm_con_tvs = [], pm_con_dicts = [] - , pm_con_args = [] } -{-# INLINE nilPattern #-} - -mkListPatVec :: Type -> PatVec -> PatVec -> PatVec -mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon - , pm_con_arg_tys = [ty] - , pm_con_tvs = [], pm_con_dicts = [] - , pm_con_args = xs++ys }] -{-# INLINE mkListPatVec #-} - --- | Create a (non-overloaded) literal pattern -mkLitPattern :: HsLit -> Pattern -mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit } -{-# INLINE mkLitPattern #-} - --- ----------------------------------------------------------------------- --- * Transform (Pat Id) into of (PmPat Id) - -translatePat :: FamInstEnvs -> Pat Id -> DsM PatVec -translatePat fam_insts pat = case pat of - WildPat ty -> mkPmVars [ty] - VarPat id -> return [PmVar (unLoc id)] - ParPat p -> translatePat fam_insts (unLoc p) - LazyPat _ -> mkPmVars [hsPatType pat] -- like a variable - - -- ignore strictness annotations for now - BangPat p -> translatePat fam_insts (unLoc p) - - AsPat lid p -> do - -- Note [Translating As Patterns] - ps <- translatePat fam_insts (unLoc p) - let [e] = map vaToPmExpr (coercePatVec ps) - g = PmGrd [PmVar (unLoc lid)] e - return (ps ++ [g]) - - SigPatOut p _ty -> translatePat fam_insts (unLoc p) - - -- See Note [Translate CoPats] - CoPat wrapper p ty - | isIdHsWrapper wrapper -> translatePat fam_insts p - | WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts p - | otherwise -> do - ps <- translatePat fam_insts p - (xp,xe) <- mkPmId2Forms ty - let g = mkGuard ps (HsWrap wrapper (unLoc xe)) - return [xp,g] - - -- (n + k) ===> x (True <- x >= k) (n <- x-k) - NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty - - -- (fun -> pat) ===> x (pat <- fun x) - ViewPat lexpr lpat arg_ty -> do - ps <- translatePat fam_insts (unLoc lpat) - -- See Note [Guards and Approximation] - case all cantFailPattern ps of - True -> do - (xp,xe) <- mkPmId2Forms arg_ty - let g = mkGuard ps (HsApp lexpr xe) - return [xp,g] - False -> mkCanFailPmPat arg_ty - - -- list - ListPat ps ty Nothing -> do - foldr (mkListPatVec ty) [nilPattern ty] - <$> translatePatVec fam_insts (map unLoc ps) - - -- overloaded list - ListPat lpats elem_ty (Just (pat_ty, _to_list)) - | Just e_ty <- splitListTyConApp_maybe pat_ty - , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty - -- elem_ty is frequently something like - -- `Item [Int]`, but we prefer `Int` - , norm_elem_ty `eqType` e_ty -> - -- We have to ensure that the element types are exactly the same. - -- Otherwise, one may give an instance IsList [Int] (more specific than - -- the default IsList [a]) with a different implementation for `toList' - translatePat fam_insts (ListPat lpats e_ty Nothing) - -- See Note [Guards and Approximation] - | otherwise -> mkCanFailPmPat pat_ty - - ConPatOut { pat_con = L _ con - , pat_arg_tys = arg_tys - , pat_tvs = ex_tvs - , pat_dicts = dicts - , pat_args = ps } -> do - groups <- allCompleteMatches con arg_tys - case groups of - [] -> mkCanFailPmPat (conLikeResTy con arg_tys) - _ -> do - args <- translateConPatVec fam_insts arg_tys ex_tvs con ps - return [PmCon { pm_con_con = con - , pm_con_arg_tys = arg_tys - , pm_con_tvs = ex_tvs - , pm_con_dicts = dicts - , pm_con_args = args }] - - NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty - - LitPat lit - -- If it is a string then convert it to a list of characters - | HsString src s <- lit -> - foldr (mkListPatVec charTy) [nilPattern charTy] <$> - translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s)) - | otherwise -> return [mkLitPattern lit] - - PArrPat ps ty -> do - tidy_ps <- translatePatVec fam_insts (map unLoc ps) - let fake_con = RealDataCon (parrFakeCon (length ps)) - return [vanillaConPattern fake_con [ty] (concat tidy_ps)] - - TuplePat ps boxity tys -> do - tidy_ps <- translatePatVec fam_insts (map unLoc ps) - let tuple_con = RealDataCon (tupleDataCon boxity (length ps)) - return [vanillaConPattern tuple_con tys (concat tidy_ps)] - - SumPat p alt arity ty -> do - tidy_p <- translatePat fam_insts (unLoc p) - let sum_con = RealDataCon (sumDataCon alt arity) - return [vanillaConPattern sum_con ty tidy_p] - - -- -------------------------------------------------------------------------- - -- Not supposed to happen - ConPatIn {} -> panic "Check.translatePat: ConPatIn" - SplicePat {} -> panic "Check.translatePat: SplicePat" - SigPatIn {} -> panic "Check.translatePat: SigPatIn" - --- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs) -translateNPat :: FamInstEnvs - -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> DsM PatVec -translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty - | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg - = translatePat fam_insts (LitPat (HsString src s)) - | not type_change, isIntTy ty, HsIntegral src i <- val - = translatePat fam_insts (mk_num_lit HsInt src i) - | not type_change, isWordTy ty, HsIntegral src i <- val - = translatePat fam_insts (mk_num_lit HsWordPrim src i) - where - type_change = not (outer_ty `eqType` ty) - mk_num_lit c src i = LitPat $ case mb_neg of - Nothing -> c src i - Just _ -> c src (-i) -translateNPat _ ol mb_neg _ - = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }] - --- | Translate a list of patterns (Note: each pattern is translated --- to a pattern vector but we do not concatenate the results). -translatePatVec :: FamInstEnvs -> [Pat Id] -> DsM [PatVec] -translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats - --- | Translate a constructor pattern -translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar] - -> ConLike -> HsConPatDetails Id -> DsM PatVec -translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps) - = concat <$> translatePatVec fam_insts (map unLoc ps) -translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2) - = concat <$> translatePatVec fam_insts (map unLoc [p1,p2]) -translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _)) - -- Nothing matched. Make up some fresh term variables - | null fs = mkPmVars arg_tys - -- The data constructor was not defined using record syntax. For the - -- pattern to be in record syntax it should be empty (e.g. Just {}). - -- So just like the previous case. - | null orig_lbls = ASSERT(null matched_lbls) mkPmVars arg_tys - -- Some of the fields appear, in the original order (there may be holes). - -- Generate a simple constructor pattern and make up fresh variables for - -- the rest of the fields - | matched_lbls `subsetOf` orig_lbls - = ASSERT(length orig_lbls == length arg_tys) - let translateOne (lbl, ty) = case lookup lbl matched_pats of - Just p -> translatePat fam_insts p - Nothing -> mkPmVars [ty] - in concatMapM translateOne (zip orig_lbls arg_tys) - -- The fields that appear are not in the correct order. Make up fresh - -- variables for all fields and add guards after matching, to force the - -- evaluation in the correct order. - | otherwise = do - arg_var_pats <- mkPmVars arg_tys - translated_pats <- forM matched_pats $ \(x,pat) -> do - pvec <- translatePat fam_insts pat - return (x, pvec) - - let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ] - guards = map (\(name,pvec) -> case lookup name zipped of - Just x -> PmGrd pvec (PmExprVar (idName x)) - Nothing -> panic "translateConPatVec: lookup") - translated_pats - - return (arg_var_pats ++ guards) - where - -- The actual argument types (instantiated) - arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs) - - -- Some label information - orig_lbls = map flSelector $ conLikeFieldLabels c - matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x)) - | L _ x <- fs] - matched_lbls = [ name | (name, _pat) <- matched_pats ] - - subsetOf :: Eq a => [a] -> [a] -> Bool - subsetOf [] _ = True - subsetOf (_:_) [] = False - subsetOf (x:xs) (y:ys) - | x == y = subsetOf xs ys - | otherwise = subsetOf (x:xs) ys - --- Translate a single match -translateMatch :: FamInstEnvs -> LMatch Id (LHsExpr Id) -> DsM (PatVec,[PatVec]) -translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do - pats' <- concat <$> translatePatVec fam_insts pats - guards' <- mapM (translateGuards fam_insts) guards - return (pats', guards') - where - extractGuards :: LGRHS Id (LHsExpr Id) -> [GuardStmt Id] - extractGuards (L _ (GRHS gs _)) = map unLoc gs - - pats = map unLoc lpats - guards = map extractGuards (grhssGRHSs grhss) - --- ----------------------------------------------------------------------- --- * Transform source guards (GuardStmt Id) to PmPats (Pattern) - --- | Translate a list of guard statements to a pattern vector -translateGuards :: FamInstEnvs -> [GuardStmt Id] -> DsM PatVec -translateGuards fam_insts guards = do - all_guards <- concat <$> mapM (translateGuard fam_insts) guards - return (replace_unhandled all_guards) - -- It should have been (return all_guards) but it is too expressive. - -- Since the term oracle does not handle all constraints we generate, - -- we (hackily) replace all constraints the oracle cannot handle with a - -- single one (we need to know if there is a possibility of falure). - -- See Note [Guards and Approximation] for all guard-related approximations - -- we implement. - where - replace_unhandled :: PatVec -> PatVec - replace_unhandled gv - | any_unhandled gv = fake_pat : [ p | p <- gv, shouldKeep p ] - | otherwise = gv - - any_unhandled :: PatVec -> Bool - any_unhandled gv = any (not . shouldKeep) gv - - shouldKeep :: Pattern -> Bool - shouldKeep p - | PmVar {} <- p = True - | PmCon {} <- p = singleConstructor (pm_con_con p) - && all shouldKeep (pm_con_args p) - shouldKeep (PmGrd pv e) - | all shouldKeep pv = True - | isNotPmExprOther e = True -- expensive but we want it - shouldKeep _other_pat = False -- let the rest.. - --- | Check whether a pattern can fail to match -cantFailPattern :: Pattern -> Bool -cantFailPattern p - | PmVar {} <- p = True - | PmCon {} <- p = singleConstructor (pm_con_con p) - && all cantFailPattern (pm_con_args p) -cantFailPattern (PmGrd pv _e) - = all cantFailPattern pv -cantFailPattern _ = False - --- | Translate a guard statement to Pattern -translateGuard :: FamInstEnvs -> GuardStmt Id -> DsM PatVec -translateGuard fam_insts guard = case guard of - BodyStmt e _ _ _ -> translateBoolGuard e - LetStmt binds -> translateLet (unLoc binds) - BindStmt p e _ _ _ -> translateBind fam_insts p e - LastStmt {} -> panic "translateGuard LastStmt" - ParStmt {} -> panic "translateGuard ParStmt" - TransStmt {} -> panic "translateGuard TransStmt" - RecStmt {} -> panic "translateGuard RecStmt" - ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt" - --- | Translate let-bindings -translateLet :: HsLocalBinds Id -> DsM PatVec -translateLet _binds = return [] - --- | Translate a pattern guard -translateBind :: FamInstEnvs -> LPat Id -> LHsExpr Id -> DsM PatVec -translateBind fam_insts (L _ p) e = do - ps <- translatePat fam_insts p - return [mkGuard ps (unLoc e)] - --- | Translate a boolean guard -translateBoolGuard :: LHsExpr Id -> DsM PatVec -translateBoolGuard e - | isJust (isTrueLHsExpr e) = return [] - -- The formal thing to do would be to generate (True <- True) - -- but it is trivial to solve so instead we give back an empty - -- PatVec for efficiency - | otherwise = return [mkGuard [truePattern] (unLoc e)] - -{- Note [Guards and Approximation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even if the algorithm is really expressive, the term oracle we use is not. -Hence, several features are not translated *properly* but we approximate. -The list includes: - -1. View Patterns ----------------- -A view pattern @(f -> p)@ should be translated to @x (p <- f x)@. The term -oracle does not handle function applications so we know that the generated -constraints will not be handled at the end. Hence, we distinguish between two -cases: - a) Pattern @p@ cannot fail. Then this is just a binding and we do the *right - thing*. - b) Pattern @p@ can fail. This means that when checking the guard, we will - generate several cases, with no useful information. E.g.: - - h (f -> [a,b]) = ... - h x ([a,b] <- f x) = ... - - uncovered set = { [x |> { False ~ (f x ~ []) }] - , [x |> { False ~ (f x ~ (t1:[])) }] - , [x |> { False ~ (f x ~ (t1:t2:t3:t4)) }] } - - So we have two problems: - 1) Since we do not print the constraints in the general case (they may - be too many), the warning will look like this: - - Pattern match(es) are non-exhaustive - In an equation for `h': - Patterns not matched: - _ - _ - _ - Which is not short and not more useful than a single underscore. - 2) The size of the uncovered set increases a lot, without gaining more - expressivity in our warnings. - - Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy* - @fake_pat@: @True <- _@. That is, we record that there is a possibility - of failure but we minimize it to a True/False. This generates a single - warning and much smaller uncovered sets. - -2. Overloaded Lists -------------------- -An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The -problem is exactly like above, as its solution. For future reference, the code -below is the *right thing to do*: - - ListPat lpats elem_ty (Just (pat_ty, to_list)) - otherwise -> do - (xp, xe) <- mkPmId2Forms pat_ty - ps <- translatePatVec (map unLoc lpats) - let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps - g = mkGuard pats (HsApp (noLoc to_list) xe) - return [xp,g] - -3. Overloaded Literals ----------------------- -The case with literals is a bit different. a literal @l@ should be translated -to @x (True <- x == from l)@. Since we want to have better warnings for -overloaded literals as it is a very common feature, we treat them differently. -They are mainly covered in Note [Undecidable Equality on Overloaded Literals] -in PmExpr. - -4. N+K Patterns & Pattern Synonyms -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An n+k pattern (n+k) should be translated to @x (True <- x >= k) (n <- x-k)@. -Since the only pattern of the three that causes failure is guard @(n <- x-k)@, -and has two possible outcomes. Hence, there is no benefit in using a dummy and -we implement the proper thing. Pattern synonyms are simply not implemented yet. -Hence, to be conservative, we generate a dummy pattern, assuming that the -pattern can fail. - -5. Actual Guards ----------------- -During translation, boolean guards and pattern guards are translated properly. -Let bindings though are omitted by function @translateLet@. Since they are lazy -bindings, we do not actually want to generate a (strict) equality (like we do -in the pattern bind case). Hence, we safely drop them. - -Additionally, top-level guard translation (performed by @translateGuards@) -replaces guards that cannot be reasoned about (like the ones we described in -1-4) with a single @fake_pat@ to record the possibility of failure to match. - -Note [Translate CoPats] -~~~~~~~~~~~~~~~~~~~~~~~ -The pattern match checker did not know how to handle coerced patterns `CoPat` -efficiently, which gave rise to #11276. The original approach translated -`CoPat`s: - - pat |> co ===> x (pat <- (e |> co)) - -Instead, we now check whether the coercion is a hole or if it is just refl, in -which case we can drop it. Unfortunately, data families generate useful -coercions so guards are still generated in these cases and checking data -families is not really efficient. - -%************************************************************************ -%* * - Utilities for Pattern Match Checking -%* * -%************************************************************************ --} - --- ---------------------------------------------------------------------------- --- * Basic utilities - --- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type --- of the first (or the single -WHEREVER IT IS- valid to use?) pattern -pmPatType :: PmPat p -> Type -pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys }) - = conLikeResTy con tys -pmPatType (PmVar { pm_var_id = x }) = idType x -pmPatType (PmLit { pm_lit_lit = l }) = pmLitType l -pmPatType (PmNLit { pm_lit_id = x }) = idType x -pmPatType (PmGrd { pm_grd_pv = pv }) - = ASSERT(patVecArity pv == 1) (pmPatType p) - where Just p = find ((==1) . patternArity) pv - --- | Generate a value abstraction for a given constructor (generate --- fresh variables of the appropriate type for arguments) -mkOneConFull :: Id -> ConLike -> DsM (ValAbs, ComplexEq, Bag EvVar) --- * x :: T tys, where T is an algebraic data type --- NB: in the case of a data family, T is the *representation* TyCon --- e.g. data instance T (a,b) = T1 a b --- leads to --- data TPair a b = T1 a b -- The "representation" type --- It is TPair, not T, that is given to mkOneConFull --- --- * 'con' K is a constructor of data type T --- --- After instantiating the universal tyvars of K we get --- K tys :: forall bs. Q => s1 .. sn -> T tys --- --- Results: ValAbs: K (y1::s1) .. (yn::sn) --- ComplexEq: x ~ K y1..yn --- [EvVar]: Q -mkOneConFull x con = do - let -- res_ty == TyConApp (ConLikeTyCon cabs_con) cabs_arg_tys - res_ty = idType x - (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _) - = conLikeFullSig con - tc_args = case splitTyConApp_maybe res_ty of - Just (_, tys) -> tys - Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty) - subst1 = zipTvSubst univ_tvs tc_args - - (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM - - -- Fresh term variables (VAs) as arguments to the constructor - arguments <- mapM mkPmVar (substTys subst arg_tys) - -- All constraints bound by the constructor (alpha-renamed) - let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas) - evvars <- mapM (nameType "pm") theta_cs - let con_abs = PmCon { pm_con_con = con - , pm_con_arg_tys = tc_args - , pm_con_tvs = ex_tvs' - , pm_con_dicts = evvars - , pm_con_args = arguments } - return (con_abs, (PmExprVar (idName x), vaToPmExpr con_abs), listToBag evvars) - --- ---------------------------------------------------------------------------- --- * More smart constructors and fresh variable generation - --- | Create a guard pattern -mkGuard :: PatVec -> HsExpr Id -> Pattern -mkGuard pv e - | all cantFailPattern pv = PmGrd pv expr - | PmExprOther {} <- expr = fake_pat - | otherwise = PmGrd pv expr - where - expr = hsExprToPmExpr e - --- | Create a term equality of the form: `(False ~ (x ~ lit))` -mkNegEq :: Id -> PmLit -> ComplexEq -mkNegEq x l = (falsePmExpr, PmExprVar (idName x) `PmExprEq` PmExprLit l) -{-# INLINE mkNegEq #-} - --- | Create a term equality of the form: `(x ~ lit)` -mkPosEq :: Id -> PmLit -> ComplexEq -mkPosEq x l = (PmExprVar (idName x), PmExprLit l) -{-# INLINE mkPosEq #-} - --- | Create a term equality of the form: `(x ~ x)` --- (always discharged by the term oracle) -mkIdEq :: Id -> ComplexEq -mkIdEq x = (PmExprVar name, PmExprVar name) - where name = idName x -{-# INLINE mkIdEq #-} - --- | Generate a variable pattern of a given type -mkPmVar :: Type -> DsM (PmPat p) -mkPmVar ty = PmVar <$> mkPmId ty -{-# INLINE mkPmVar #-} - --- | Generate many variable patterns, given a list of types -mkPmVars :: [Type] -> DsM PatVec -mkPmVars tys = mapM mkPmVar tys -{-# INLINE mkPmVars #-} - --- | Generate a fresh `Id` of a given type -mkPmId :: Type -> DsM Id -mkPmId ty = getUniqueM >>= \unique -> - let occname = mkVarOccFS (fsLit (show unique)) - name = mkInternalName unique occname noSrcSpan - in return (mkLocalId name ty) - --- | Generate a fresh term variable of a given and return it in two forms: --- * A variable pattern --- * A variable expression -mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr Id) -mkPmId2Forms ty = do - x <- mkPmId ty - return (PmVar x, noLoc (HsVar (noLoc x))) - --- ---------------------------------------------------------------------------- --- * Converting between Value Abstractions, Patterns and PmExpr - --- | Convert a value abstraction an expression -vaToPmExpr :: ValAbs -> PmExpr -vaToPmExpr (PmCon { pm_con_con = c, pm_con_args = ps }) - = PmExprCon c (map vaToPmExpr ps) -vaToPmExpr (PmVar { pm_var_id = x }) = PmExprVar (idName x) -vaToPmExpr (PmLit { pm_lit_lit = l }) = PmExprLit l -vaToPmExpr (PmNLit { pm_lit_id = x }) = PmExprVar (idName x) - --- | Convert a pattern vector to a list of value abstractions by dropping the --- guards (See Note [Translating As Patterns]) -coercePatVec :: PatVec -> [ValAbs] -coercePatVec pv = concatMap coercePmPat pv - --- | Convert a pattern to a list of value abstractions (will be either an empty --- list if the pattern is a guard pattern, or a singleton list in all other --- cases) by dropping the guards (See Note [Translating As Patterns]) -coercePmPat :: Pattern -> [ValAbs] -coercePmPat (PmVar { pm_var_id = x }) = [PmVar { pm_var_id = x }] -coercePmPat (PmLit { pm_lit_lit = l }) = [PmLit { pm_lit_lit = l }] -coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys - , pm_con_tvs = tvs, pm_con_dicts = dicts - , pm_con_args = args }) - = [PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys - , pm_con_tvs = tvs, pm_con_dicts = dicts - , pm_con_args = coercePatVec args }] -coercePmPat (PmGrd {}) = [] -- drop the guards - --- | Check whether a data constructor is the only way to construct --- a data type. -singleConstructor :: ConLike -> Bool -singleConstructor (RealDataCon dc) = - case tyConDataCons (dataConTyCon dc) of - [_] -> True - _ -> False -singleConstructor _ = False - --- | For a given conlike, finds all the sets of patterns which could --- be relevant to that conlike by consulting the result type. --- --- These come from two places. --- 1. From data constructors defined with the result type constructor. --- 2. From `COMPLETE` pragmas which have the same type as the result --- type constructor. -allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])] -allCompleteMatches cl tys = do - let fam = case cl of - RealDataCon dc -> - [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))] - PatSynCon _ -> [] - - pragmas <- case splitTyConApp_maybe (conLikeResTy cl tys) of - Just (tc, _) -> dsGetCompleteMatches tc - Nothing -> return [] - let fams cm = fmap (FromComplete,) $ - mapM dsLookupConLike (completeMatchConLikes cm) - from_pragma <- mapM fams pragmas - - let final_groups = fam ++ from_pragma - tracePmD "allCompleteMatches" (ppr final_groups) - return final_groups - --- ----------------------------------------------------------------------- --- * Types and constraints - -newEvVar :: Name -> Type -> EvVar -newEvVar name ty = mkLocalId name (toTcType ty) - -nameType :: String -> Type -> DsM EvVar -nameType name ty = do - unique <- getUniqueM - let occname = mkVarOccFS (fsLit (name++"_"++show unique)) - idname = mkInternalName unique occname noSrcSpan - return (newEvVar idname ty) - -{- -%************************************************************************ -%* * - The type oracle -%* * -%************************************************************************ --} - --- | Check whether a set of type constraints is satisfiable. -tyOracle :: Bag EvVar -> PmM Bool -tyOracle evs - = liftD $ - do { ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability evs - ; case res of - Just sat -> return sat - Nothing -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) } - -{- -%************************************************************************ -%* * - Sanity Checks -%* * -%************************************************************************ --} - --- | The arity of a pattern/pattern vector is the --- number of top-level patterns that are not guards -type PmArity = Int - --- | Compute the arity of a pattern vector -patVecArity :: PatVec -> PmArity -patVecArity = sum . map patternArity - --- | Compute the arity of a pattern -patternArity :: Pattern -> PmArity -patternArity (PmGrd {}) = 0 -patternArity _other_pat = 1 - -{- -%************************************************************************ -%* * - Heart of the algorithm: Function pmcheck -%* * -%************************************************************************ - -Main functions are: - -* mkInitialUncovered :: [Id] -> PmM Uncovered - - Generates the initial uncovered set. Term and type constraints in scope - are checked, if they are inconsistent, the set is empty, otherwise, the - set contains only a vector of variables with the constraints in scope. - -* pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult - - Checks redundancy, coverage and inaccessibility, using auxilary functions - `pmcheckGuards` and `pmcheckHd`. Mainly handles the guard case which is - common in all three checks (see paper) and calls `pmcheckGuards` when the - whole clause is checked, or `pmcheckHd` when the pattern vector does not - start with a guard. - -* pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult - - Processes the guards. - -* pmcheckHd :: Pattern -> PatVec -> [PatVec] - -> ValAbs -> ValVec -> PmM PartialResult - - Worker: This function implements functions `covered`, `uncovered` and - `divergent` from the paper at once. Slightly different from the paper because - it does not even produce the covered and uncovered sets. Since we only care - about whether a clause covers SOMETHING or if it may forces ANY argument, we - only store a boolean in both cases, for efficiency. --} - --- | Lift a pattern matching action from a single value vector abstration to a --- value set abstraction, but calling it on every vector and the combining the --- results. -runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult) -runMany _ [] = return mempty -runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms - --- | Generate the initial uncovered set. It initializes the --- delta with all term and type constraints in scope. -mkInitialUncovered :: [Id] -> PmM Uncovered -mkInitialUncovered vars = do - ty_cs <- liftD getDictsDs - tm_cs <- map toComplex . bagToList <$> liftD getTmCsDs - sat_ty <- tyOracle ty_cs - let initTyCs = if sat_ty then ty_cs else emptyBag - initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs) - patterns = map PmVar vars - -- If any of the term/type constraints are non - -- satisfiable then return with the initialTmState. See #12957 - return [ValVec patterns (MkDelta initTyCs initTmState)] - --- | Increase the counter for elapsed algorithm iterations, check that the --- limit is not exceeded and call `pmcheck` -pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult -pmcheckI ps guards vva = do - n <- liftD incrCheckPmIterDs - tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps - $$ hang (text "guards:") 2 (vcat (map pprPatVec guards)) - $$ pprValVecDebug vva) - res <- pmcheck ps guards vva - tracePm "pmCheckResult:" (ppr res) - return res -{-# INLINE pmcheckI #-} - --- | Increase the counter for elapsed algorithm iterations, check that the --- limit is not exceeded and call `pmcheckGuards` -pmcheckGuardsI :: [PatVec] -> ValVec -> PmM PartialResult -pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva -{-# INLINE pmcheckGuardsI #-} - --- | Increase the counter for elapsed algorithm iterations, check that the --- limit is not exceeded and call `pmcheckHd` -pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec - -> PmM PartialResult -pmcheckHdI p ps guards va vva = do - n <- liftD incrCheckPmIterDs - tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p - $$ pprPatVec ps - $$ hang (text "guards:") 2 (vcat (map pprPatVec guards)) - $$ pprPmPatDebug va - $$ pprValVecDebug vva) - - res <- pmcheckHd p ps guards va vva - tracePm "pmCheckHdI: res" (ppr res) - return res -{-# INLINE pmcheckHdI #-} - --- | Matching function: Check simultaneously a clause (takes separately the --- patterns and the list of guards) for exhaustiveness, redundancy and --- inaccessibility. -pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult -pmcheck [] guards vva@(ValVec [] _) - | null guards = return $ mempty { presultCovered = Covered } - | otherwise = pmcheckGuardsI guards vva - --- Guard -pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta) - -- short-circuit if the guard pattern is useless. - -- we just have two possible outcomes: fail here or match and recurse - -- none of the two contains any useful information about the failure - -- though. So just have these two cases but do not do all the boilerplate - | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva - | otherwise = do - y <- liftD $ mkPmId (pmPatType p) - let tm_state = extendSubst y e (delta_tm_cs delta) - delta' = delta { delta_tm_cs = tm_state } - utail <$> pmcheckI (pv ++ ps) guards (ValVec (PmVar y : vas) delta') - -pmcheck [] _ (ValVec (_:_) _) = panic "pmcheck: nil-cons" -pmcheck (_:_) _ (ValVec [] _) = panic "pmcheck: cons-nil" - -pmcheck (p:ps) guards (ValVec (va:vva) delta) - = pmcheckHdI p ps guards va (ValVec vva delta) - --- | Check the list of guards -pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult -pmcheckGuards [] vva = return (usimple [vva]) -pmcheckGuards (gv:gvs) vva = do - (PartialResult prov1 cs vsa ds) <- pmcheckI gv [] vva - (PartialResult prov2 css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa - return $ PartialResult (prov1 `mappend` prov2) - (cs `mappend` css) - vsas - (ds `mappend` dss) - --- | Worker function: Implements all cases described in the paper for all three --- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard` --- cases which are handled by `pmcheck` -pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec - -> PmM PartialResult - --- Var -pmcheckHd (PmVar x) ps guards va (ValVec vva delta) - | Just tm_state <- solveOneEq (delta_tm_cs delta) - (PmExprVar (idName x), vaToPmExpr va) - = ucon va <$> pmcheckI ps guards (ValVec vva (delta {delta_tm_cs = tm_state})) - | otherwise = return mempty - --- ConCon -pmcheckHd ( p@(PmCon {pm_con_con = c1, pm_con_args = args1})) ps guards - (va@(PmCon {pm_con_con = c2, pm_con_args = args2})) (ValVec vva delta) - | c1 /= c2 = - return (usimple [ValVec (va:vva) delta]) - | otherwise = kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p) - <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta) - --- LitLit -pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva = - case eqPmLit l1 l2 of - True -> ucon va <$> pmcheckI ps guards vva - False -> return $ ucon va (usimple [vva]) - --- ConVar -pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys })) - ps guards - (PmVar x) (ValVec vva delta) = do - (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys) - - cons_cs <- mapM (liftD . mkOneConFull x) complete_match - - inst_vsa <- flip concatMapM cons_cs $ \(va, tm_ct, ty_cs) -> do - let ty_state = ty_cs `unionBags` delta_ty_cs delta -- not actually a state - sat_ty <- if isEmptyBag ty_cs then return True - else tyOracle ty_state - return $ case (sat_ty, solveOneEq (delta_tm_cs delta) tm_ct) of - (True, Just tm_state) -> [ValVec (va:vva) (MkDelta ty_state tm_state)] - _ty_or_tm_failed -> [] - - set_provenance prov . - force_if (canDiverge (idName x) (delta_tm_cs delta)) <$> - runMany (pmcheckI (p:ps) guards) inst_vsa - --- LitVar -pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta) - = force_if (canDiverge (idName x) (delta_tm_cs delta)) <$> - mkUnion non_matched <$> - case solveOneEq (delta_tm_cs delta) (mkPosEq x l) of - Just tm_state -> pmcheckHdI p ps guards (PmLit l) $ - ValVec vva (delta {delta_tm_cs = tm_state}) - Nothing -> return mempty - where - us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l) - = [ValVec (PmNLit x [l] : vva) (delta { delta_tm_cs = tm_state })] - | otherwise = [] - - non_matched = usimple us - --- LitNLit -pmcheckHd (p@(PmLit l)) ps guards - (PmNLit { pm_lit_id = x, pm_lit_not = lits }) (ValVec vva delta) - | all (not . eqPmLit l) lits - , Just tm_state <- solveOneEq (delta_tm_cs delta) (mkPosEq x l) - -- Both guards check the same so it would be sufficient to have only - -- the second one. Nevertheless, it is much cheaper to check whether - -- the literal is in the list so we check it first, to avoid calling - -- the term oracle (`solveOneEq`) if possible - = mkUnion non_matched <$> - pmcheckHdI p ps guards (PmLit l) - (ValVec vva (delta { delta_tm_cs = tm_state })) - | otherwise = return non_matched - where - us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l) - = [ValVec (PmNLit x (l:lits) : vva) (delta { delta_tm_cs = tm_state })] - | otherwise = [] - - non_matched = usimple us - --- ---------------------------------------------------------------------------- --- The following three can happen only in cases like #322 where constructors --- and overloaded literals appear in the same match. The general strategy is --- to replace the literal (positive/negative) by a variable and recurse. The --- fact that the variable is equal to the literal is recorded in `delta` so --- no information is lost - --- LitCon -pmcheckHd (PmLit l) ps guards (va@(PmCon {})) (ValVec vva delta) - = do y <- liftD $ mkPmId (pmPatType va) - let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta) - delta' = delta { delta_tm_cs = tm_state } - pmcheckHdI (PmVar y) ps guards va (ValVec vva delta') - --- ConLit -pmcheckHd (p@(PmCon {})) ps guards (PmLit l) (ValVec vva delta) - = do y <- liftD $ mkPmId (pmPatType p) - let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta) - delta' = delta { delta_tm_cs = tm_state } - pmcheckHdI p ps guards (PmVar y) (ValVec vva delta') - --- ConNLit -pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva - = pmcheckHdI p ps guards (PmVar x) vva - --- Impossible: handled by pmcheck -pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard" - --- ---------------------------------------------------------------------------- --- * Utilities for main checking - -updateVsa :: (ValSetAbs -> ValSetAbs) -> (PartialResult -> PartialResult) -updateVsa f p@(PartialResult { presultUncovered = old }) - = p { presultUncovered = f old } - - --- | Initialise with default values for covering and divergent information. -usimple :: ValSetAbs -> PartialResult -usimple vsa = mempty { presultUncovered = vsa } - --- | Take the tail of all value vector abstractions in the uncovered set -utail :: PartialResult -> PartialResult -utail = updateVsa upd - where upd vsa = [ ValVec vva delta | ValVec (_:vva) delta <- vsa ] - --- | Prepend a value abstraction to all value vector abstractions in the --- uncovered set -ucon :: ValAbs -> PartialResult -> PartialResult -ucon va = updateVsa upd - where - upd vsa = [ ValVec (va:vva) delta | ValVec vva delta <- vsa ] - --- | Given a data constructor of arity `a` and an uncovered set containing --- value vector abstractions of length `(a+n)`, pass the first `n` value --- abstractions to the constructor (Hence, the resulting value vector --- abstractions will have length `n+1`) -kcon :: ConLike -> [Type] -> [TyVar] -> [EvVar] - -> PartialResult -> PartialResult -kcon con arg_tys ex_tvs dicts - = let n = conLikeArity con - upd vsa = - [ ValVec (va:vva) delta - | ValVec vva' delta <- vsa - , let (args, vva) = splitAt n vva' - , let va = PmCon { pm_con_con = con - , pm_con_arg_tys = arg_tys - , pm_con_tvs = ex_tvs - , pm_con_dicts = dicts - , pm_con_args = args } ] - in updateVsa upd - --- | Get the union of two covered, uncovered and divergent value set --- abstractions. Since the covered and divergent sets are represented by a --- boolean, union means computing the logical or (at least one of the two is --- non-empty). - -mkUnion :: PartialResult -> PartialResult -> PartialResult -mkUnion = mappend - --- | Add a value vector abstraction to a value set abstraction (uncovered). -mkCons :: ValVec -> PartialResult -> PartialResult -mkCons vva = updateVsa (vva:) - --- | Set the divergent set to not empty -forces :: PartialResult -> PartialResult -forces pres = pres { presultDivergent = Diverged } - --- | Set the divergent set to non-empty if the flag is `True` -force_if :: Bool -> PartialResult -> PartialResult -force_if True pres = forces pres -force_if False pres = pres - -set_provenance :: Provenance -> PartialResult -> PartialResult -set_provenance prov pr = pr { presultProvenence = prov } - --- ---------------------------------------------------------------------------- --- * Propagation of term constraints inwards when checking nested matches - -{- Note [Type and Term Equality Propagation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When checking a match it would be great to have all type and term information -available so we can get more precise results. For this reason we have functions -`addDictsDs' and `addTmCsDs' in PmMonad that store in the environment type and -term constraints (respectively) as we go deeper. - -The type constraints we propagate inwards are collected by `collectEvVarsPats' -in HsPat.hs. This handles bug #4139 ( see example - https://ghc.haskell.org/trac/ghc/attachment/ticket/4139/GADTbug.hs ) -where this is needed. - -For term equalities we do less, we just generate equalities for HsCase. For -example we accurately give 2 redundancy warnings for the marked cases: - -f :: [a] -> Bool -f x = case x of - - [] -> case x of -- brings (x ~ []) in scope - [] -> True - (_:_) -> False -- can't happen - - (_:_) -> case x of -- brings (x ~ (_:_)) in scope - (_:_) -> True - [] -> False -- can't happen - -Functions `genCaseTmCs1' and `genCaseTmCs2' are responsible for generating -these constraints. --} - --- | Generate equalities when checking a case expression: --- case x of { p1 -> e1; ... pn -> en } --- When we go deeper to check e.g. e1 we record two equalities: --- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn) --- and (x ~ p1). -genCaseTmCs2 :: Maybe (LHsExpr Id) -- Scrutinee - -> [Pat Id] -- LHS (should have length 1) - -> [Id] -- MatchVars (should have length 1) - -> DsM (Bag SimpleEq) -genCaseTmCs2 Nothing _ _ = return emptyBag -genCaseTmCs2 (Just scr) [p] [var] = do - fam_insts <- dsGetFamInstEnvs - [e] <- map vaToPmExpr . coercePatVec <$> translatePat fam_insts p - let scr_e = lhsExprToPmExpr scr - return $ listToBag [(var, e), (var, scr_e)] -genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase" - --- | Generate a simple equality when checking a case expression: --- case x of { matches } --- When checking matches we record that (x ~ y) where y is the initial --- uncovered. All matches will have to satisfy this equality. -genCaseTmCs1 :: Maybe (LHsExpr Id) -> [Id] -> Bag SimpleEq -genCaseTmCs1 Nothing _ = emptyBag -genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr) -genCaseTmCs1 _ _ = panic "genCaseTmCs1: HsCase" - -{- Note [Literals in PmPat] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instead of translating a literal to a variable accompanied with a guard, we -treat them like constructor patterns. The following example from -"./libraries/base/GHC/IO/Encoding.hs" shows why: - -mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding -mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of - "UTF8" -> return $ UTF8.mkUTF8 cfm - "UTF16" -> return $ UTF16.mkUTF16 cfm - "UTF16LE" -> return $ UTF16.mkUTF16le cfm - ... - -Each clause gets translated to a list of variables with an equal number of -guards. For every guard we generate two cases (equals True/equals False) which -means that we generate 2^n cases to feed the oracle with, where n is the sum of -the length of all strings that appear in the patterns. For this particular -example this means over 2^40 cases. Instead, by representing them like with -constructor we get the following: - 1. We exploit the common prefix with our representation of VSAs - 2. We prune immediately non-reachable cases - (e.g. False == (x == "U"), True == (x == "U")) - -Note [Translating As Patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instead of translating x@p as: x (p <- x) -we instead translate it as: p (x <- coercePattern p) -for performance reasons. For example: - - f x@True = 1 - f y@False = 2 - -Gives the following with the first translation: - - x |> {x == False, x == y, y == True} - -If we use the second translation we get an empty set, independently of the -oracle. Since the pattern `p' may contain guard patterns though, it cannot be -used as an expression. That's why we call `coercePatVec' to drop the guard and -`vaToPmExpr' to transform the value abstraction to an expression in the -guard pattern (value abstractions are a subset of expressions). We keep the -guards in the first pattern `p' though. - - -%************************************************************************ -%* * - Pretty printing of exhaustiveness/redundancy check warnings -%* * -%************************************************************************ --} - --- | Check whether any part of pattern match checking is enabled (does not --- matter whether it is the redundancy check or the exhaustiveness check). -isAnyPmCheckEnabled :: DynFlags -> DsMatchContext -> Bool -isAnyPmCheckEnabled dflags (DsMatchContext kind _loc) - = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind - -instance Outputable ValVec where - ppr (ValVec vva delta) - = let (residual_eqs, subst) = wrapUpTmState (delta_tm_cs delta) - vector = substInValAbs subst vva - in ppr_uncovered (vector, residual_eqs) - --- | Apply a term substitution to a value vector abstraction. All VAs are --- transformed to PmExpr (used only before pretty printing). -substInValAbs :: PmVarEnv -> [ValAbs] -> [PmExpr] -substInValAbs subst = map (exprDeepLookup subst . vaToPmExpr) - --- | Wrap up the term oracle's state once solving is complete. Drop any --- information about unhandled constraints (involving HsExprs) and flatten --- (height 1) the substitution. -wrapUpTmState :: TmState -> ([ComplexEq], PmVarEnv) -wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst) - --- | Issue all the warnings (coverage, exhaustiveness, inaccessibility) -dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM () -dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result - = when (flag_i || flag_u) $ do - let exists_r = flag_i && notNull redundant && onlyBuiltin - exists_i = flag_i && notNull inaccessible && onlyBuiltin && not is_rec_upd - exists_u = flag_u && (case uncovered of - TypeOfUncovered _ -> True - UncoveredPatterns u -> notNull u) - - when exists_r $ forM_ redundant $ \(L l q) -> do - putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) - (pprEqn q "is redundant")) - when exists_i $ forM_ inaccessible $ \(L l q) -> do - putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) - (pprEqn q "has inaccessible right hand side")) - when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $ - case uncovered of - TypeOfUncovered ty -> warnEmptyCase ty - UncoveredPatterns candidates -> pprEqns candidates - where - PmResult - { pmresultProvenance = prov - , pmresultRedundant = redundant - , pmresultUncovered = uncovered - , pmresultInaccessible = inaccessible } = pm_result - - flag_i = wopt Opt_WarnOverlappingPatterns dflags - flag_u = exhaustive dflags kind - flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind) - - is_rec_upd = case kind of { RecUpd -> True; _ -> False } - -- See Note [Inaccessible warnings for record updates] - - onlyBuiltin = prov == FromBuiltin - - maxPatterns = maxUncoveredPatterns dflags - - -- Print a single clause (for redundant/with-inaccessible-rhs) - pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q - - -- Print several clauses (for uncovered clauses) - pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ -> - case qs of -- See #11245 - [ValVec [] _] - -> text "Guards do not cover entire pattern space" - _missing -> let us = map ppr qs - in hang (text "Patterns not matched:") 4 - (vcat (take maxPatterns us) - $$ dots maxPatterns us) - - -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for - -- which we only know the type and have no inhabitants at hand) - warnEmptyCase ty = pp_context False ctx (text "are non-exhaustive") $ \_ -> - hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty) - -{- Note [Inaccessible warnings for record updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #12957) - data T a where - T1 :: { x :: Int } -> T Bool - T2 :: { x :: Int } -> T a - T3 :: T a - - f :: T Char -> T a - f r = r { x = 3 } - -The desugarer will (conservatively generate a case for T1 even though -it's impossible: - f r = case r of - T1 x -> T1 3 -- Inaccessible branch - T2 x -> T2 3 - _ -> error "Missing" - -We don't want to warn about the inaccessible branch because the programmer -didn't put it there! So we filter out the warning here. --} - --- | Issue a warning when the predefined number of iterations is exceeded --- for the pattern match checker -warnPmIters :: DynFlags -> DsMatchContext -> DsM () -warnPmIters dflags (DsMatchContext kind loc) - = when (flag_i || flag_u) $ do - iters <- maxPmCheckIterations <$> getDynFlags - putSrcSpanDs loc (warnDs NoReason (msg iters)) - where - ctxt = pprMatchContext kind - msg is = fsep [ text "Pattern match checker exceeded" - , parens (ppr is), text "iterations in", ctxt <> dot - , text "(Use -fmax-pmcheck-iterations=n" - , text "to set the maximun number of iterations to n)" ] - - flag_i = wopt Opt_WarnOverlappingPatterns dflags - flag_u = exhaustive dflags kind - -dots :: Int -> [a] -> SDoc -dots maxPatterns qs - | qs `lengthExceeds` maxPatterns = text "..." - | otherwise = empty - --- | Check whether the exhaustiveness checker should run (exhaustiveness only) -exhaustive :: DynFlags -> HsMatchContext id -> Bool -exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag - --- | Denotes whether an exhaustiveness check is supported, and if so, --- via which 'WarningFlag' it's controlled. --- Returns 'Nothing' if check is not supported. -exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag -exhaustiveWarningFlag (FunRhs {}) = Just Opt_WarnIncompletePatterns -exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns -exhaustiveWarningFlag IfAlt = Nothing -exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns -exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns -exhaustiveWarningFlag ProcExpr = Just Opt_WarnIncompleteUniPatterns -exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd -exhaustiveWarningFlag ThPatSplice = Nothing -exhaustiveWarningFlag PatSyn = Nothing -exhaustiveWarningFlag ThPatQuote = Nothing -exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns - -- in list comprehensions, pattern guards - -- etc. They are often *supposed* to be - -- incomplete - --- True <==> singular -pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc -pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun - = vcat [text txt <+> msg, - sep [ text "In" <+> ppr_match <> char ':' - , nest 4 (rest_of_msg_fun pref)]] - where - txt | singular = "Pattern match" - | otherwise = "Pattern match(es)" - - (ppr_match, pref) - = case kind of - FunRhs (L _ fun) _ _ -> (pprMatchContext kind, - \ pp -> ppr fun <+> pp) - _ -> (pprMatchContext kind, \ pp -> pp) - -ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc -ppr_pats kind pats - = sep [sep (map ppr pats), matchSeparator kind, text "..."] - -ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat Id] -> SDoc -ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn)) - -ppr_constraint :: (SDoc,[PmLit]) -> SDoc -ppr_constraint (var, lits) = var <+> text "is not one of" - <+> braces (pprWithCommas ppr lits) - -ppr_uncovered :: ([PmExpr], [ComplexEq]) -> SDoc -ppr_uncovered (expr_vec, complex) - | null cs = fsep vec -- there are no literal constraints - | otherwise = hang (fsep vec) 4 $ - text "where" <+> vcat (map ppr_constraint cs) - where - sdoc_vec = mapM pprPmExprWithParens expr_vec - (vec,cs) = runPmPprM sdoc_vec (filterComplex complex) - -{- Note [Representation of Term Equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the paper, term constraints always take the form (x ~ e). Of course, a more -general constraint of the form (e1 ~ e1) can always be transformed to an -equivalent set of the former constraints, by introducing a fresh, intermediate -variable: { y ~ e1, y ~ e1 }. Yet, implementing this representation gave rise -to #11160 (incredibly bad performance for literal pattern matching). Two are -the main sources of this problem (the actual problem is how these two interact -with each other): - -1. Pattern matching on literals generates twice as many constraints as needed. - Consider the following (tests/ghci/should_run/ghcirun004): - - foo :: Int -> Int - foo 1 = 0 - ... - foo 5000 = 4999 - - The covered and uncovered set *should* look like: - U0 = { x |> {} } - - C1 = { 1 |> { x ~ 1 } } - U1 = { x |> { False ~ (x ~ 1) } } - ... - C10 = { 10 |> { False ~ (x ~ 1), .., False ~ (x ~ 9), x ~ 10 } } - U10 = { x |> { False ~ (x ~ 1), .., False ~ (x ~ 9), False ~ (x ~ 10) } } - ... - - If we replace { False ~ (x ~ 1) } with { y ~ False, y ~ (x ~ 1) } - we get twice as many constraints. Also note that half of them are just the - substitution [x |-> False]. - -2. The term oracle (`tmOracle` in deSugar/TmOracle) uses equalities of the form - (x ~ e) as substitutions [x |-> e]. More specifically, function - `extendSubstAndSolve` applies such substitutions in the residual constraints - and partitions them in the affected and non-affected ones, which are the new - worklist. Essentially, this gives quadradic behaviour on the number of the - residual constraints. (This would not be the case if the term oracle used - mutable variables but, since we use it to handle disjunctions on value set - abstractions (`Union` case), we chose a pure, incremental interface). - -Now the problem becomes apparent (e.g. for clause 300): - * Set U300 contains 300 substituting constraints [y_i |-> False] and 300 - constraints that we know that will not reduce (stay in the worklist). - * To check for consistency, we apply the substituting constraints ONE BY ONE - (since `tmOracle` is called incrementally, it does not have all of them - available at once). Hence, we go through the (non-progressing) constraints - over and over, achieving over-quadradic behaviour. - -If instead we allow constraints of the form (e ~ e), - * All uncovered sets Ui contain no substituting constraints and i - non-progressing constraints of the form (False ~ (x ~ lit)) so the oracle - behaves linearly. - * All covered sets Ci contain exactly (i-1) non-progressing constraints and - a single substituting constraint. So the term oracle goes through the - constraints only once. - -The performance improvement becomes even more important when more arguments are -involved. --} - --- Debugging Infrastructre - -tracePm :: String -> SDoc -> PmM () -tracePm herald doc = liftD $ tracePmD herald doc - - -tracePmD :: String -> SDoc -> DsM () -tracePmD herald doc = do - dflags <- getDynFlags - printer <- mkPrintUnqualifiedDs - liftIO $ dumpIfSet_dyn_printer printer dflags - Opt_D_dump_ec_trace (text herald $$ (nest 2 doc)) - - -pprPmPatDebug :: PmPat a -> SDoc -pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args) - = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)] -pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid -pprPmPatDebug (PmLit li) = text "PmLit" <+> ppr li -pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl -pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv) - <+> ppr ge - -pprPatVec :: PatVec -> SDoc -pprPatVec ps = hang (text "Pattern:") 2 - (brackets $ sep - $ punctuate (comma <> char '\n') (map pprPmPatDebug ps)) - -pprValAbs :: [ValAbs] -> SDoc -pprValAbs ps = hang (text "ValAbs:") 2 - (brackets $ sep - $ punctuate (comma) (map pprPmPatDebug ps)) - -pprValVecDebug :: ValVec -> SDoc -pprValVecDebug (ValVec vas _d) = text "ValVec" <+> - parens (pprValAbs vas) diff --git a/deSugar/Coverage.hs b/deSugar/Coverage.hs deleted file mode 100644 --- a/deSugar/Coverage.hs +++ /dev/null @@ -1,1354 +0,0 @@ -{- -(c) Galois, 2006 -(c) University of Glasgow, 2007 --} - -{-# LANGUAGE CPP, NondecreasingIndentation, RecordWildCards #-} - -module Coverage (addTicksToBinds, hpcInitCode) where - -import qualified GHCi -import GHCi.RemoteTypes -import Data.Array -import ByteCodeTypes -#if MIN_VERSION_base(4,9,0) -import GHC.Stack.CCS -#else -import GHC.Stack as GHC.Stack.CCS -#endif -import Type -import HsSyn -import Module -import Outputable -import DynFlags -import ConLike -import Control.Monad -import SrcLoc -import ErrUtils -import NameSet hiding (FreeVars) -import Name -import Bag -import CostCentre -import CoreSyn -import Id -import VarSet -import Data.List -import FastString -import HscTypes -import TyCon -import UniqSupply -import BasicTypes -import MonadUtils -import Maybes -import CLabel -import Util - -import Data.Time -import System.Directory - -import Trace.Hpc.Mix -import Trace.Hpc.Util - -import Data.Map (Map) -import qualified Data.Map as Map - -{- -************************************************************************ -* * -* The main function: addTicksToBinds -* * -************************************************************************ --} - -addTicksToBinds - :: HscEnv - -> Module - -> ModLocation -- ... off the current module - -> NameSet -- Exported Ids. When we call addTicksToBinds, - -- isExportedId doesn't work yet (the desugarer - -- hasn't set it), so we have to work from this set. - -> [TyCon] -- Type constructor in this module - -> LHsBinds Id - -> IO (LHsBinds Id, HpcInfo, Maybe ModBreaks) - -addTicksToBinds hsc_env mod mod_loc exports tyCons binds - | let dflags = hsc_dflags hsc_env - passes = coveragePasses dflags, not (null passes), - Just orig_file <- ml_hs_file mod_loc, - not ("boot" `isSuffixOf` orig_file) = do - - us <- mkSplitUniqSupply 'C' -- for cost centres - let orig_file2 = guessSourceFile binds orig_file - - tickPass tickish (binds,st) = - let env = TTE - { fileName = mkFastString orig_file2 - , declPath = [] - , tte_dflags = dflags - , exports = exports - , inlines = emptyVarSet - , inScope = emptyVarSet - , blackList = Map.fromList - [ (getSrcSpan (tyConName tyCon),()) - | tyCon <- tyCons ] - , density = mkDensity tickish dflags - , this_mod = mod - , tickishType = tickish -} - (binds',_,st') = unTM (addTickLHsBinds binds) env st - in (binds', st') - - initState = TT { tickBoxCount = 0 - , mixEntries = [] - , uniqSupply = us - } - - (binds1,st) = foldr tickPass (binds, initState) passes - - let tickCount = tickBoxCount st - entries = reverse $ mixEntries st - hashNo <- writeMixEntries dflags mod tickCount entries orig_file2 - modBreaks <- mkModBreaks hsc_env mod tickCount entries - - when (dopt Opt_D_dump_ticked dflags) $ - putLogMsg dflags NoReason SevDump noSrcSpan - (defaultDumpStyle dflags) (pprLHsBinds binds1) - - return (binds1, HpcInfo tickCount hashNo, Just modBreaks) - - | otherwise = return (binds, emptyHpcInfo False, Nothing) - -guessSourceFile :: LHsBinds Id -> FilePath -> FilePath -guessSourceFile binds orig_file = - -- Try look for a file generated from a .hsc file to a - -- .hs file, by peeking ahead. - let top_pos = catMaybes $ foldrBag (\ (L pos _) rest -> - srcSpanFileName_maybe pos : rest) [] binds - in - case top_pos of - (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name - -> unpackFS file_name - _ -> orig_file - - -mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks -mkModBreaks hsc_env mod count entries - | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do - breakArray <- GHCi.newBreakArray hsc_env (length entries) - ccs <- mkCCSArray hsc_env mod count entries - let - locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] - varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] - declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ] - return emptyModBreaks - { modBreaks_flags = breakArray - , modBreaks_locs = locsTicks - , modBreaks_vars = varsTicks - , modBreaks_decls = declsTicks - , modBreaks_ccs = ccs - } - | otherwise = return emptyModBreaks - -mkCCSArray - :: HscEnv -> Module -> Int -> [MixEntry_] - -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre)) -mkCCSArray hsc_env modul count entries = do - if interpreterProfiled dflags - then do - let module_str = moduleNameString (moduleName modul) - costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries) - return (listArray (0,count-1) costcentres) - else do - return (listArray (0,-1) []) - where - dflags = hsc_dflags hsc_env - mk_one (srcspan, decl_path, _, _) = (name, src) - where name = concat (intersperse "." decl_path) - src = showSDoc dflags (ppr srcspan) - - -writeMixEntries - :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int -writeMixEntries dflags mod count entries filename - | not (gopt Opt_Hpc dflags) = return 0 - | otherwise = do - let - hpc_dir = hpcDir dflags - mod_name = moduleNameString (moduleName mod) - - hpc_mod_dir - | moduleUnitId mod == mainUnitId = hpc_dir - | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod) - - tabStop = 8 -- counts as a normal char in GHC's - -- location ranges. - - createDirectoryIfMissing True hpc_mod_dir - modTime <- getModificationUTCTime filename - let entries' = [ (hpcPos, box) - | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] - when (length entries' /= count) $ do - panic "the number of .mix entries are inconsistent" - let hashNo = mixHash filename modTime tabStop entries' - mixCreate hpc_mod_dir mod_name - $ Mix filename modTime (toHash hashNo) tabStop entries' - return hashNo - - --- ----------------------------------------------------------------------------- --- TickDensity: where to insert ticks - -data TickDensity - = TickForCoverage -- for Hpc - | TickForBreakPoints -- for GHCi - | TickAllFunctions -- for -prof-auto-all - | TickTopFunctions -- for -prof-auto-top - | TickExportedFunctions -- for -prof-auto-exported - | TickCallSites -- for stack tracing - deriving Eq - -mkDensity :: TickishType -> DynFlags -> TickDensity -mkDensity tickish dflags = case tickish of - HpcTicks -> TickForCoverage - SourceNotes -> TickForCoverage - Breakpoints -> TickForBreakPoints - ProfNotes -> - case profAuto dflags of - ProfAutoAll -> TickAllFunctions - ProfAutoTop -> TickTopFunctions - ProfAutoExports -> TickExportedFunctions - ProfAutoCalls -> TickCallSites - _other -> panic "mkDensity" - --- | Decide whether to add a tick to a binding or not. -shouldTickBind :: TickDensity - -> Bool -- top level? - -> Bool -- exported? - -> Bool -- simple pat bind? - -> Bool -- INLINE pragma? - -> Bool - -shouldTickBind density top_lev exported _simple_pat inline - = case density of - TickForBreakPoints -> False - -- we never add breakpoints to simple pattern bindings - -- (there's always a tick on the rhs anyway). - TickAllFunctions -> not inline - TickTopFunctions -> top_lev && not inline - TickExportedFunctions -> exported && not inline - TickForCoverage -> True - TickCallSites -> False - -shouldTickPatBind :: TickDensity -> Bool -> Bool -shouldTickPatBind density top_lev - = case density of - TickForBreakPoints -> False - TickAllFunctions -> True - TickTopFunctions -> top_lev - TickExportedFunctions -> False - TickForCoverage -> False - TickCallSites -> False - --- ----------------------------------------------------------------------------- --- Adding ticks to bindings - -addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id) -addTickLHsBinds = mapBagM addTickLHsBind - -addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) -addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, - abs_exports = abs_exports })) = do - withEnv add_exports $ do - withEnv add_inlines $ do - binds' <- addTickLHsBinds binds - return $ L pos $ bind { abs_binds = binds' } - where - -- in AbsBinds, the Id on each binding is not the actual top-level - -- Id that we are defining, they are related by the abs_exports - -- field of AbsBinds. So if we're doing TickExportedFunctions we need - -- to add the local Ids to the set of exported Names so that we know to - -- tick the right bindings. - add_exports env = - env{ exports = exports env `extendNameSetList` - [ idName mid - | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports - , idName pid `elemNameSet` (exports env) ] } - - add_inlines env = - env{ inlines = inlines env `extendVarSetList` - [ mid - | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports - , isAnyInlinePragma (idInlinePragma pid) ] } - -addTickLHsBind (L pos bind@(AbsBindsSig { abs_sig_bind = val_bind - , abs_sig_export = poly_id })) - | L _ FunBind { fun_id = L _ mono_id } <- val_bind - = do withEnv (add_export mono_id) $ do - withEnv (add_inlines mono_id) $ do - val_bind' <- addTickLHsBind val_bind - return $ L pos $ bind { abs_sig_bind = val_bind' } - - | otherwise - = pprPanic "addTickLHsBind" (ppr bind) - where - -- see AbsBinds comments - add_export mono_id env - | idName poly_id `elemNameSet` exports env - = env { exports = exports env `extendNameSet` idName mono_id } - | otherwise - = env - - add_inlines mono_id env - | isAnyInlinePragma (idInlinePragma poly_id) - = env { inlines = inlines env `extendVarSet` mono_id } - | otherwise - = env - -addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do - let name = getOccString id - decl_path <- getPathEntry - density <- getDensity - - inline_ids <- liftM inlines getEnv - let inline = isAnyInlinePragma (idInlinePragma id) - || id `elemVarSet` inline_ids - - -- See Note [inline sccs] - tickish <- tickishType `liftM` getEnv - if inline && tickish == ProfNotes then return (L pos funBind) else do - - (fvs, mg@(MG { mg_alts = matches' })) <- - getFreeVars $ - addPathEntry name $ - addTickMatchGroup False (fun_matches funBind) - - blackListed <- isBlackListed pos - exported_names <- liftM exports getEnv - - -- We don't want to generate code for blacklisted positions - -- We don't want redundant ticks on simple pattern bindings - -- We don't want to tick non-exported bindings in TickExportedFunctions - let simple = isSimplePatBind funBind - toplev = null decl_path - exported = idName id `elemNameSet` exported_names - - tick <- if not blackListed && - shouldTickBind density toplev exported simple inline - then - bindTick density name pos fvs - else - return Nothing - - let mbCons = maybe Prelude.id (:) - return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' } - , fun_tick = tick `mbCons` fun_tick funBind } - - where - -- a binding is a simple pattern binding if it is a funbind with - -- zero patterns - isSimplePatBind :: HsBind a -> Bool - isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 - --- TODO: Revisit this -addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do - let name = "(...)" - (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs - let pat' = pat { pat_rhs = rhs'} - - -- Should create ticks here? - density <- getDensity - decl_path <- getPathEntry - let top_lev = null decl_path - if not (shouldTickPatBind density top_lev) then return (L pos pat') else do - - -- Allocate the ticks - rhs_tick <- bindTick density name pos fvs - let patvars = map getOccString (collectPatBinders lhs) - patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars - - -- Add to pattern - let mbCons = maybe id (:) - rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat') - patvar_tickss = zipWith mbCons patvar_ticks - (snd (pat_ticks pat') ++ repeat []) - return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } - --- Only internal stuff, not from source, uses VarBind, so we ignore it. -addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind -addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind - - -bindTick - :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) -bindTick density name pos fvs = do - decl_path <- getPathEntry - let - toplev = null decl_path - count_entries = toplev || density == TickAllFunctions - top_only = density /= TickAllFunctions - box_label = if toplev then TopLevelBox [name] - else LocalBox (decl_path ++ [name]) - -- - allocATickBox box_label count_entries top_only pos fvs - - --- Note [inline sccs] --- --- It should be reasonable to add ticks to INLINE functions; however --- currently this tickles a bug later on because the SCCfinal pass --- does not look inside unfoldings to find CostCentres. It would be --- difficult to fix that, because SCCfinal currently works on STG and --- not Core (and since it also generates CostCentres for CAFs, --- changing this would be difficult too). --- --- Another reason not to add ticks to INLINE functions is that this --- sometimes handy for avoiding adding a tick to a particular function --- (see #6131) --- --- So for now we do not add any ticks to INLINE functions at all. - --- ----------------------------------------------------------------------------- --- Decorate an LHsExpr with ticks - --- selectively add ticks to interesting expressions -addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExpr e@(L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | isGoodBreakExpr e0 -> tick_it - TickForCoverage -> tick_it - TickCallSites | isCallSite e0 -> tick_it - _other -> dont_tick_it - where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- Add a tick to an expression which is the RHS of an equation or a binding. --- We always consider these to be breakpoints, unless the expression is a 'let' --- (because the body will definitely have a tick somewhere). ToDo: perhaps --- we should treat 'case' and 'if' the same way? -addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExprRHS e@(L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it - | otherwise -> tick_it - TickForCoverage -> tick_it - TickCallSites | isCallSite e0 -> tick_it - _other -> dont_tick_it - where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- The inner expression of an evaluation context: --- let binds in [], ( [] ) --- we never tick these if we're doing HPC, but otherwise --- we treat it like an ordinary expression. -addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExprEvalInner e = do - d <- getDensity - case d of - TickForCoverage -> addTickLHsExprNever e - _otherwise -> addTickLHsExpr e - --- | A let body is treated differently from addTickLHsExprEvalInner --- above with TickForBreakPoints, because for breakpoints we always --- want to tick the body, even if it is not a redex. See test --- break012. This gives the user the opportunity to inspect the --- values of the let-bound variables. -addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExprLetBody e@(L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it - | otherwise -> tick_it - _other -> addTickLHsExprEvalInner e - where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- version of addTick that does not actually add a tick, --- because the scope of this tick is completely subsumed by --- another. -addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExprNever (L pos e0) = do - e1 <- addTickHsExpr e0 - return $ L pos e1 - --- general heuristic: expressions which do not denote values are good --- break points -isGoodBreakExpr :: HsExpr Id -> Bool -isGoodBreakExpr (HsApp {}) = True -isGoodBreakExpr (HsAppTypeOut {}) = True -isGoodBreakExpr (OpApp {}) = True -isGoodBreakExpr _other = False - -isCallSite :: HsExpr Id -> Bool -isCallSite HsApp{} = True -isCallSite HsAppTypeOut{} = True -isCallSite OpApp{} = True -isCallSite _ = False - -addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExprOptAlt oneOfMany (L pos e0) - = ifDensity TickForCoverage - (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) - (addTickLHsExpr (L pos e0)) - -addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) -addBinTickLHsExpr boxLabel (L pos e0) - = ifDensity TickForCoverage - (allocBinTickBox boxLabel pos $ addTickHsExpr e0) - (addTickLHsExpr (L pos e0)) - - --- ----------------------------------------------------------------------------- --- Decorate the body of an HsExpr with ticks. --- (Whether to put a tick around the whole expression was already decided, --- in the addTickLHsExpr family of functions.) - -addTickHsExpr :: HsExpr Id -> TM (HsExpr Id) -addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e -addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" -addTickHsExpr e@(HsConLikeOut con) - | Just id <- conLikeWrapId_maybe con = do freeVar id; return e -addTickHsExpr e@(HsIPVar _) = return e -addTickHsExpr e@(HsOverLit _) = return e -addTickHsExpr e@(HsOverLabel{}) = return e -addTickHsExpr e@(HsLit _) = return e -addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup) -addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs) -addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1) - (addTickLHsExpr e2) -addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e) - (return ty) - -addTickHsExpr (OpApp e1 e2 fix e3) = - liftM4 OpApp - (addTickLHsExpr e1) - (addTickLHsExprNever e2) - (return fix) - (addTickLHsExpr e3) -addTickHsExpr (NegApp e neg) = - liftM2 NegApp - (addTickLHsExpr e) - (addTickSyntaxExpr hpcSrcSpan neg) -addTickHsExpr (HsPar e) = - liftM HsPar (addTickLHsExprEvalInner e) -addTickHsExpr (SectionL e1 e2) = - liftM2 SectionL - (addTickLHsExpr e1) - (addTickLHsExprNever e2) -addTickHsExpr (SectionR e1 e2) = - liftM2 SectionR - (addTickLHsExprNever e1) - (addTickLHsExpr e2) -addTickHsExpr (ExplicitTuple es boxity) = - liftM2 ExplicitTuple - (mapM addTickTupArg es) - (return boxity) -addTickHsExpr (ExplicitSum tag arity e ty) = do - e' <- addTickLHsExpr e - return (ExplicitSum tag arity e' ty) -addTickHsExpr (HsCase e mgs) = - liftM2 HsCase - (addTickLHsExpr e) -- not an EvalInner; e might not necessarily - -- be evaluated. - (addTickMatchGroup False mgs) -addTickHsExpr (HsIf cnd e1 e2 e3) = - liftM3 (HsIf cnd) - (addBinTickLHsExpr (BinBox CondBinBox) e1) - (addTickLHsExprOptAlt True e2) - (addTickLHsExprOptAlt True e3) -addTickHsExpr (HsMultiIf ty alts) - = do { let isOneOfMany = case alts of [_] -> False; _ -> True - ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts - ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet (L l binds) e) = - bindLocals (collectLocalBinders binds) $ - liftM2 (HsLet . L l) - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsExprLetBody e) -addTickHsExpr (HsDo cxt (L l stmts) srcloc) - = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) - ; return (HsDo cxt (L l stmts') srcloc) } - where - forQual = case cxt of - ListComp -> Just $ BinBox QualBinBox - _ -> Nothing -addTickHsExpr (ExplicitList ty wit es) = - liftM3 ExplicitList - (return ty) - (addTickWit wit) - (mapM (addTickLHsExpr) es) - where addTickWit Nothing = return Nothing - addTickWit (Just fln) - = do fln' <- addTickSyntaxExpr hpcSrcSpan fln - return (Just fln') -addTickHsExpr (ExplicitPArr ty es) = - liftM2 ExplicitPArr - (return ty) - (mapM (addTickLHsExpr) es) - -addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e - -addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) - = do { rec_binds' <- addTickHsRecordBinds rec_binds - ; return (expr { rcon_flds = rec_binds' }) } - -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) - = do { e' <- addTickLHsExpr e - ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = flds' }) } - -addTickHsExpr (ExprWithTySig e ty) = - liftM2 ExprWithTySig - (addTickLHsExprNever e) -- No need to tick the inner expression - -- for expressions with signatures - (return ty) -addTickHsExpr (ArithSeq ty wit arith_seq) = - liftM3 ArithSeq - (return ty) - (addTickWit wit) - (addTickArithSeqInfo arith_seq) - where addTickWit Nothing = return Nothing - addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl - return (Just fl') - --- We might encounter existing ticks (multiple Coverage passes) -addTickHsExpr (HsTick t e) = - liftM (HsTick t) (addTickLHsExprNever e) -addTickHsExpr (HsBinTick t0 t1 e) = - liftM (HsBinTick t0 t1) (addTickLHsExprNever e) - -addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do - e2 <- allocTickBox (ExpBox False) False False pos $ - addTickHsExpr e0 - return $ unLoc e2 -addTickHsExpr (PArrSeq ty arith_seq) = - liftM2 PArrSeq - (return ty) - (addTickArithSeqInfo arith_seq) -addTickHsExpr (HsSCC src nm e) = - liftM3 HsSCC - (return src) - (return nm) - (addTickLHsExpr e) -addTickHsExpr (HsCoreAnn src nm e) = - liftM3 HsCoreAnn - (return src) - (return nm) - (addTickLHsExpr e) -addTickHsExpr e@(HsBracket {}) = return e -addTickHsExpr e@(HsTcBracketOut {}) = return e -addTickHsExpr e@(HsRnBracketOut {}) = return e -addTickHsExpr e@(HsSpliceE {}) = return e -addTickHsExpr (HsProc pat cmdtop) = - liftM2 HsProc - (addTickLPat pat) - (liftL (addTickHsCmdTop) cmdtop) -addTickHsExpr (HsWrap w e) = - liftM2 HsWrap - (return w) - (addTickHsExpr e) -- Explicitly no tick on inside - -addTickHsExpr (ExprWithTySigOut e ty) = - liftM2 ExprWithTySigOut - (addTickLHsExprNever e) -- No need to tick the inner expression - (return ty) -- for expressions with signatures - --- Others should never happen in expression content. -addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) - -addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id) -addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e - ; return (L l (Present e')) } -addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) - -addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id)) -addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do - let isOneOfMany = matchesOneOfMany matches - matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches - return $ mg { mg_alts = L l matches' } - -addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id)) -addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) = - bindLocals (collectPatsBinders pats) $ do - gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs - return $ Match mf pats opSig gRHSs' - -addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id)) -addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do - bindLocals binders $ do - local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded - return $ GRHSs guarded' (L l local_binds') - where - binders = collectLocalBinders local_binds - -addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id)) -addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do - (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts - (addTickGRHSBody isOneOfMany isLambda expr) - return $ GRHS stmts' expr' - -addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id) -addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do - d <- getDensity - case d of - TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr - TickAllFunctions | isLambda -> - addPathEntry "\\" $ - allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $ - addTickHsExpr e0 - _otherwise -> - addTickLHsExprRHS expr - -addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id] -addTickLStmts isGuard stmts = do - (stmts, _) <- addTickLStmts' isGuard stmts (return ()) - return stmts - -addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a - -> TM ([ExprLStmt Id], a) -addTickLStmts' isGuard lstmts res - = bindLocals (collectLStmtsBinders lstmts) $ - do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts - ; a <- res - ; return (lstmts', a) } - -addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id)) -addTickStmt _isGuard (LastStmt e noret ret) = do - liftM3 LastStmt - (addTickLHsExpr e) - (pure noret) - (addTickSyntaxExpr hpcSrcSpan ret) -addTickStmt _isGuard (BindStmt pat e bind fail ty) = do - liftM5 BindStmt - (addTickLPat pat) - (addTickLHsExprRHS e) - (addTickSyntaxExpr hpcSrcSpan bind) - (addTickSyntaxExpr hpcSrcSpan fail) - (return ty) -addTickStmt isGuard (BodyStmt e bind' guard' ty) = do - liftM4 BodyStmt - (addTick isGuard e) - (addTickSyntaxExpr hpcSrcSpan bind') - (addTickSyntaxExpr hpcSrcSpan guard') - (return ty) -addTickStmt _isGuard (LetStmt (L l binds)) = do - liftM (LetStmt . L l) - (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do - liftM4 ParStmt - (mapM (addTickStmtAndBinders isGuard) pairs) - (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) - (addTickSyntaxExpr hpcSrcSpan bindExpr) - (return ty) -addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do - args' <- mapM (addTickApplicativeArg isGuard) args - return (ApplicativeStmt args' mb_join body_ty) - -addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts - , trS_by = by, trS_using = using - , trS_ret = returnExpr, trS_bind = bindExpr - , trS_fmap = liftMExpr }) = do - t_s <- addTickLStmts isGuard stmts - t_y <- fmapMaybeM addTickLHsExprRHS by - t_u <- addTickLHsExprRHS using - t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr - t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr - L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr) - return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u - , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } - -addTickStmt isGuard stmt@(RecStmt {}) - = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt) - ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) - ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) - ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' - , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } - -addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) -addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e - | otherwise = addTickLHsExprRHS e - -addTickApplicativeArg - :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr Id, ApplicativeArg Id Id) - -> TM (SyntaxExpr Id, ApplicativeArg Id Id) -addTickApplicativeArg isGuard (op, arg) = - liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) - where - addTickArg (ApplicativeArgOne pat expr) = - ApplicativeArgOne <$> addTickLPat pat <*> addTickLHsExpr expr - addTickArg (ApplicativeArgMany stmts ret pat) = - ApplicativeArgMany - <$> addTickLStmts isGuard stmts - <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) - <*> addTickLPat pat - -addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id - -> TM (ParStmtBlock Id Id) -addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) = - liftM3 ParStmtBlock - (addTickLStmts isGuard stmts) - (return ids) - (addTickSyntaxExpr hpcSrcSpan returnExpr) - -addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id) -addTickHsLocalBinds (HsValBinds binds) = - liftM HsValBinds - (addTickHsValBinds binds) -addTickHsLocalBinds (HsIPBinds binds) = - liftM HsIPBinds - (addTickHsIPBinds binds) -addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds - -addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b) -addTickHsValBinds (ValBindsOut binds sigs) = - liftM2 ValBindsOut - (mapM (\ (rec,binds') -> - liftM2 (,) - (return rec) - (addTickLHsBinds binds')) - binds) - (return sigs) -addTickHsValBinds _ = panic "addTickHsValBinds" - -addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id) -addTickHsIPBinds (IPBinds ipbinds dictbinds) = - liftM2 IPBinds - (mapM (liftL (addTickIPBind)) ipbinds) - (return dictbinds) - -addTickIPBind :: IPBind Id -> TM (IPBind Id) -addTickIPBind (IPBind nm e) = - liftM2 IPBind - (return nm) - (addTickLHsExpr e) - --- There is no location here, so we might need to use a context location?? -addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id) -addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do - L _ x' <- addTickLHsExpr (L pos x) - return $ syn { syn_expr = x' } --- we do not walk into patterns. -addTickLPat :: LPat Id -> TM (LPat Id) -addTickLPat pat = return pat - -addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id) -addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = - liftM4 HsCmdTop - (addTickLHsCmd cmd) - (return tys) - (return ty) - (return syntaxtable) - -addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id) -addTickLHsCmd (L pos c0) = do - c1 <- addTickHsCmd c0 - return $ L pos c1 - -addTickHsCmd :: HsCmd Id -> TM (HsCmd Id) -addTickHsCmd (HsCmdLam matchgroup) = - liftM HsCmdLam (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsCmdApp c e) = - liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e) -{- -addTickHsCmd (OpApp e1 c2 fix c3) = - liftM4 OpApp - (addTickLHsExpr e1) - (addTickLHsCmd c2) - (return fix) - (addTickLHsCmd c3) --} -addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e) -addTickHsCmd (HsCmdCase e mgs) = - liftM2 HsCmdCase - (addTickLHsExpr e) - (addTickCmdMatchGroup mgs) -addTickHsCmd (HsCmdIf cnd e1 c2 c3) = - liftM3 (HsCmdIf cnd) - (addBinTickLHsExpr (BinBox CondBinBox) e1) - (addTickLHsCmd c2) - (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet (L l binds) c) = - bindLocals (collectLocalBinders binds) $ - liftM2 (HsCmdLet . L l) - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsCmd c) -addTickHsCmd (HsCmdDo (L l stmts) srcloc) - = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo (L l stmts') srcloc) } - -addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) = - liftM5 HsCmdArrApp - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (return ty1) - (return arr_ty) - (return lr) -addTickHsCmd (HsCmdArrForm e f fix cmdtop) = - liftM4 HsCmdArrForm - (addTickLHsExpr e) - (return f) - (return fix) - (mapM (liftL (addTickHsCmdTop)) cmdtop) - -addTickHsCmd (HsCmdWrap w cmd) - = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd) - --- Others should never happen in a command context. ---addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) - -addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id)) -addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do - matches' <- mapM (liftL addTickCmdMatch) matches - return $ mg { mg_alts = L l matches' } - -addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id)) -addTickCmdMatch (Match mf pats opSig gRHSs) = - bindLocals (collectPatsBinders pats) $ do - gRHSs' <- addTickCmdGRHSs gRHSs - return $ Match mf pats opSig gRHSs' - -addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id)) -addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do - bindLocals binders $ do - local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (liftL addTickCmdGRHS) guarded - return $ GRHSs guarded' (L l local_binds') - where - binders = collectLocalBinders local_binds - -addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id)) --- The *guards* are *not* Cmds, although the body is --- C.f. addTickGRHS for the BinBox stuff -addTickCmdGRHS (GRHS stmts cmd) - = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) - stmts (addTickLHsCmd cmd) - ; return $ GRHS stmts' expr' } - -addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)] -addTickLCmdStmts stmts = do - (stmts, _) <- addTickLCmdStmts' stmts (return ()) - return stmts - -addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a) -addTickLCmdStmts' lstmts res - = bindLocals binders $ do - lstmts' <- mapM (liftL addTickCmdStmt) lstmts - a <- res - return (lstmts', a) - where - binders = collectLStmtsBinders lstmts - -addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id)) -addTickCmdStmt (BindStmt pat c bind fail ty) = do - liftM5 BindStmt - (addTickLPat pat) - (addTickLHsCmd c) - (return bind) - (return fail) - (return ty) -addTickCmdStmt (LastStmt c noret ret) = do - liftM3 LastStmt - (addTickLHsCmd c) - (pure noret) - (addTickSyntaxExpr hpcSrcSpan ret) -addTickCmdStmt (BodyStmt c bind' guard' ty) = do - liftM4 BodyStmt - (addTickLHsCmd c) - (addTickSyntaxExpr hpcSrcSpan bind') - (addTickSyntaxExpr hpcSrcSpan guard') - (return ty) -addTickCmdStmt (LetStmt (L l binds)) = do - liftM (LetStmt . L l) - (addTickHsLocalBinds binds) -addTickCmdStmt stmt@(RecStmt {}) - = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) - ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) - ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) - ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' - , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } -addTickCmdStmt ApplicativeStmt{} = - panic "ToDo: addTickCmdStmt ApplicativeLastStmt" - --- Others should never happen in a command context. -addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) - -addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id) -addTickHsRecordBinds (HsRecFields fields dd) - = do { fields' <- mapM addTickHsRecField fields - ; return (HsRecFields fields' dd) } - -addTickHsRecField :: LHsRecField' id (LHsExpr Id) -> TM (LHsRecField' id (LHsExpr Id)) -addTickHsRecField (L l (HsRecField id expr pun)) - = do { expr' <- addTickLHsExpr expr - ; return (L l (HsRecField id expr' pun)) } - - -addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id) -addTickArithSeqInfo (From e1) = - liftM From - (addTickLHsExpr e1) -addTickArithSeqInfo (FromThen e1 e2) = - liftM2 FromThen - (addTickLHsExpr e1) - (addTickLHsExpr e2) -addTickArithSeqInfo (FromTo e1 e2) = - liftM2 FromTo - (addTickLHsExpr e1) - (addTickLHsExpr e2) -addTickArithSeqInfo (FromThenTo e1 e2 e3) = - liftM3 FromThenTo - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (addTickLHsExpr e3) - -liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a) -liftL f (L loc a) = do - a' <- f a - return $ L loc a' - -data TickTransState = TT { tickBoxCount:: Int - , mixEntries :: [MixEntry_] - , uniqSupply :: UniqSupply - } - -data TickTransEnv = TTE { fileName :: FastString - , density :: TickDensity - , tte_dflags :: DynFlags - , exports :: NameSet - , inlines :: VarSet - , declPath :: [String] - , inScope :: VarSet - , blackList :: Map SrcSpan () - , this_mod :: Module - , tickishType :: TickishType - } - --- deriving Show - -data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes - deriving (Eq) - -coveragePasses :: DynFlags -> [TickishType] -coveragePasses dflags = - ifa (hscTarget dflags == HscInterpreted) Breakpoints $ - ifa (gopt Opt_Hpc dflags) HpcTicks $ - ifa (gopt Opt_SccProfilingOn dflags && - profAuto dflags /= NoProfAuto) ProfNotes $ - ifa (debugLevel dflags > 0) SourceNotes [] - where ifa f x xs | f = x:xs - | otherwise = xs - --- | Tickishs that only make sense when their source code location --- refers to the current file. This might not always be true due to --- LINE pragmas in the code - which would confuse at least HPC. -tickSameFileOnly :: TickishType -> Bool -tickSameFileOnly HpcTicks = True -tickSameFileOnly _other = False - -type FreeVars = OccEnv Id -noFVs :: FreeVars -noFVs = emptyOccEnv - --- Note [freevars] --- For breakpoints we want to collect the free variables of an --- expression for pinning on the HsTick. We don't want to collect --- *all* free variables though: in particular there's no point pinning --- on free variables that are will otherwise be in scope at the GHCi --- prompt, which means all top-level bindings. Unfortunately detecting --- top-level bindings isn't easy (collectHsBindsBinders on the top-level --- bindings doesn't do it), so we keep track of a set of "in-scope" --- variables in addition to the free variables, and the former is used --- to filter additions to the latter. This gives us complete control --- over what free variables we track. - -data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) } - -- a combination of a state monad (TickTransState) and a writer - -- monad (FreeVars). - -instance Functor TM where - fmap = liftM - -instance Applicative TM where - pure a = TM $ \ _env st -> (a,noFVs,st) - (<*>) = ap - -instance Monad TM where - (TM m) >>= k = TM $ \ env st -> - case m env st of - (r1,fv1,st1) -> - case unTM (k r1) env st1 of - (r2,fv2,st2) -> - (r2, fv1 `plusOccEnv` fv2, st2) - -instance HasDynFlags TM where - getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st) - -instance MonadUnique TM where - getUniqueSupplyM = TM $ \_ st -> (uniqSupply st, noFVs, st) - getUniqueM = TM $ \_ st -> let (u, us') = takeUniqFromSupply (uniqSupply st) - in (u, noFVs, st { uniqSupply = us' }) - -getState :: TM TickTransState -getState = TM $ \ _ st -> (st, noFVs, st) - -setState :: (TickTransState -> TickTransState) -> TM () -setState f = TM $ \ _ st -> ((), noFVs, f st) - -getEnv :: TM TickTransEnv -getEnv = TM $ \ env st -> (env, noFVs, st) - -withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a -withEnv f (TM m) = TM $ \ env st -> - case m (f env) st of - (a, fvs, st') -> (a, fvs, st') - -getDensity :: TM TickDensity -getDensity = TM $ \env st -> (density env, noFVs, st) - -ifDensity :: TickDensity -> TM a -> TM a -> TM a -ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el - -getFreeVars :: TM a -> TM (FreeVars, a) -getFreeVars (TM m) - = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st') - -freeVar :: Id -> TM () -freeVar id = TM $ \ env st -> - if id `elemVarSet` inScope env - then ((), unitOccEnv (nameOccName (idName id)) id, st) - else ((), noFVs, st) - -addPathEntry :: String -> TM a -> TM a -addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] }) - -getPathEntry :: TM [String] -getPathEntry = declPath `liftM` getEnv - -getFileName :: TM FastString -getFileName = fileName `liftM` getEnv - -isGoodSrcSpan' :: SrcSpan -> Bool -isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos -isGoodSrcSpan' (UnhelpfulSpan _) = False - -isGoodTickSrcSpan :: SrcSpan -> TM Bool -isGoodTickSrcSpan pos = do - file_name <- getFileName - tickish <- tickishType `liftM` getEnv - let need_same_file = tickSameFileOnly tickish - same_file = Just file_name == srcSpanFileName_maybe pos - return (isGoodSrcSpan' pos && (not need_same_file || same_file)) - -ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a -ifGoodTickSrcSpan pos then_code else_code = do - good <- isGoodTickSrcSpan pos - if good then then_code else else_code - -bindLocals :: [Id] -> TM a -> TM a -bindLocals new_ids (TM m) - = TM $ \ env st -> - case m env{ inScope = inScope env `extendVarSetList` new_ids } st of - (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') - where occs = [ nameOccName (idName id) | id <- new_ids ] - -isBlackListed :: SrcSpan -> TM Bool -isBlackListed pos = TM $ \ env st -> - case Map.lookup pos (blackList env) of - Nothing -> (False,noFVs,st) - Just () -> (True,noFVs,st) - --- the tick application inherits the source position of its --- expression argument to support nested box allocations -allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id) - -> TM (LHsExpr Id) -allocTickBox boxLabel countEntries topOnly pos m = - ifGoodTickSrcSpan pos (do - (fvs, e) <- getFreeVars m - env <- getEnv - tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (L pos (HsTick tickish (L pos e))) - ) (do - e <- m - return (L pos e) - ) - --- the tick application inherits the source position of its --- expression argument to support nested box allocations -allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars - -> TM (Maybe (Tickish Id)) -allocATickBox boxLabel countEntries topOnly pos fvs = - ifGoodTickSrcSpan pos (do - let - mydecl_path = case boxLabel of - TopLevelBox x -> x - LocalBox xs -> xs - _ -> panic "allocATickBox" - tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path - return (Just tickish) - ) (return Nothing) - - -mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] - -> TM (Tickish Id) -mkTickish boxLabel countEntries topOnly pos fvs decl_path = do - - let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs - -- unlifted types cause two problems here: - -- * we can't bind them at the GHCi prompt - -- (bindLocalsAtBreakpoint already fliters them out), - -- * the simplifier might try to substitute a literal for - -- the Id, and we can't handle that. - - me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel) - - cc_name | topOnly = head decl_path - | otherwise = concat (intersperse "." decl_path) - - dflags <- getDynFlags - env <- getEnv - case tickishType env of - HpcTicks -> do - c <- liftM tickBoxCount getState - setState $ \st -> st { tickBoxCount = c + 1 - , mixEntries = me : mixEntries st } - return $ HpcTick (this_mod env) c - - ProfNotes -> do - ccUnique <- getUniqueM - let cc = mkUserCC (mkFastString cc_name) (this_mod env) pos ccUnique - count = countEntries && gopt Opt_ProfCountEntries dflags - return $ ProfNote cc count True{-scopes-} - - Breakpoints -> do - c <- liftM tickBoxCount getState - setState $ \st -> st { tickBoxCount = c + 1 - , mixEntries = me:mixEntries st } - return $ Breakpoint c ids - - SourceNotes | RealSrcSpan pos' <- pos -> - return $ SourceNote pos' cc_name - - _otherwise -> panic "mkTickish: bad source span!" - - -allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id) - -> TM (LHsExpr Id) -allocBinTickBox boxLabel pos m = do - env <- getEnv - case tickishType env of - HpcTicks -> do e <- liftM (L pos) m - ifGoodTickSrcSpan pos - (mkBinTickBoxHpc boxLabel pos e) - (return e) - _other -> allocTickBox (ExpBox False) False False pos m - -mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id - -> TM (LHsExpr Id) -mkBinTickBoxHpc boxLabel pos e = - TM $ \ env st -> - let meT = (pos,declPath env, [],boxLabel True) - meF = (pos,declPath env, [],boxLabel False) - meE = (pos,declPath env, [],ExpBox False) - c = tickBoxCount st - mes = mixEntries st - in - ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e - -- notice that F and T are reversed, - -- because we are building the list in - -- reverse... - , noFVs - , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} - ) - -mkHpcPos :: SrcSpan -> HpcPos -mkHpcPos pos@(RealSrcSpan s) - | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, - srcSpanStartCol s, - srcSpanEndLine s, - srcSpanEndCol s - 1) - -- the end column of a SrcSpan is one - -- greater than the last column of the - -- span (see SrcLoc), whereas HPC - -- expects to the column range to be - -- inclusive, hence we subtract one above. -mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" - -hpcSrcSpan :: SrcSpan -hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") - -matchesOneOfMany :: [LMatch Id body] -> Bool -matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 - where - matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss - -type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) - --- For the hash value, we hash everything: the file name, --- the timestamp of the original source file, the tab stop, --- and the mix entries. We cheat, and hash the show'd string. --- This hash only has to be hashed at Mix creation time, --- and is for sanity checking only. - -mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int -mixHash file tm tabstop entries = fromIntegral $ hashString - (show $ Mix file tm 0 tabstop entries) - -{- -************************************************************************ -* * -* initialisation -* * -************************************************************************ - -Each module compiled with -fhpc declares an initialisation function of -the form `hpc_init_()`, which is emitted into the _stub.c file -and annotated with __attribute__((constructor)) so that it gets -executed at startup time. - -The function's purpose is to call hs_hpc_module to register this -module with the RTS, and it looks something like this: - -static void hpc_init_Main(void) __attribute__((constructor)); -static void hpc_init_Main(void) -{extern StgWord64 _hpc_tickboxes_Main_hpc[]; - hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} --} - -hpcInitCode :: Module -> HpcInfo -> SDoc -hpcInitCode _ (NoHpcInfo {}) = Outputable.empty -hpcInitCode this_mod (HpcInfo tickCount hashNo) - = vcat - [ text "static void hpc_init_" <> ppr this_mod - <> text "(void) __attribute__((constructor));" - , text "static void hpc_init_" <> ppr this_mod <> text "(void)" - , braces (vcat [ - text "extern StgWord64 " <> tickboxes <> - text "[]" <> semi, - text "hs_hpc_module" <> - parens (hcat (punctuate comma [ - doubleQuotes full_name_str, - int tickCount, -- really StgWord32 - int hashNo, -- really StgWord32 - tickboxes - ])) <> semi - ]) - ] - where - tickboxes = ppr (mkHpcTicksLabel $ this_mod) - - module_name = hcat (map (text.charToC) $ - bytesFS (moduleNameFS (Module.moduleName this_mod))) - package_name = hcat (map (text.charToC) $ - bytesFS (unitIdFS (moduleUnitId this_mod))) - full_name_str - | moduleUnitId this_mod == mainUnitId - = module_name - | otherwise - = package_name <> char '/' <> module_name diff --git a/deSugar/Desugar.hs b/deSugar/Desugar.hs deleted file mode 100644 --- a/deSugar/Desugar.hs +++ /dev/null @@ -1,567 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The Desugarer: turning HsSyn into Core. --} - -{-# LANGUAGE CPP #-} - -module Desugar ( - -- * Desugaring operations - deSugar, deSugarExpr - ) where - -#include "HsVersions.h" - -import DsUsage -import DynFlags -import HscTypes -import HsSyn -import TcRnTypes -import TcRnMonad ( finalSafeMode, fixSafeInstances ) -import TcRnDriver ( runTcInteractive ) -import Id -import Name -import Type -import InstEnv -import Class -import Avail -import CoreSyn -import CoreFVs ( exprsSomeFreeVarsList ) -import CoreOpt ( simpleOptPgm, simpleOptExpr ) -import PprCore -import DsMonad -import DsExpr -import DsBinds -import DsForeign -import PrelNames ( coercibleTyConKey ) -import TysPrim ( eqReprPrimTyCon ) -import Unique ( hasKey ) -import Coercion ( mkCoVarCo ) -import TysWiredIn ( coercibleDataCon ) -import DataCon ( dataConWrapId ) -import MkCore ( mkCoreLet ) -import Module -import NameSet -import NameEnv -import Rules -import BasicTypes ( Activation(.. ), competesWith, pprRuleName ) -import CoreMonad ( CoreToDo(..) ) -import CoreLint ( endPassIO ) -import VarSet -import FastString -import ErrUtils -import Outputable -import SrcLoc -import Coverage -import Util -import MonadUtils -import OrdList - -import Data.List -import Data.IORef -import Control.Monad( when ) - -{- -************************************************************************ -* * -* The main function: deSugar -* * -************************************************************************ --} - --- | Main entry point to the desugarer. -deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) --- Can modify PCS by faulting in more declarations - -deSugar hsc_env - mod_loc - tcg_env@(TcGblEnv { tcg_mod = id_mod, - tcg_semantic_mod = mod, - tcg_src = hsc_src, - tcg_type_env = type_env, - tcg_imports = imports, - tcg_exports = exports, - tcg_keep = keep_var, - tcg_th_splice_used = tc_splice_used, - tcg_rdr_env = rdr_env, - tcg_fix_env = fix_env, - tcg_inst_env = inst_env, - tcg_fam_inst_env = fam_inst_env, - tcg_merged = merged, - tcg_warns = warns, - tcg_anns = anns, - tcg_binds = binds, - tcg_imp_specs = imp_specs, - tcg_dependent_files = dependent_files, - tcg_ev_binds = ev_binds, - tcg_th_foreign_files = th_foreign_files_var, - tcg_fords = fords, - tcg_rules = rules, - tcg_vects = vects, - tcg_patsyns = patsyns, - tcg_tcs = tcs, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_hpc = other_hpc_info, - tcg_complete_matches = complete_matches - }) - - = do { let dflags = hsc_dflags hsc_env - print_unqual = mkPrintUnqualified dflags rdr_env - ; withTiming (pure dflags) - (text "Desugar"<+>brackets (ppr mod)) - (const ()) $ - do { -- Desugar the program - ; let export_set = availsToNameSet exports - target = hscTarget dflags - hpcInfo = emptyHpcInfo other_hpc_info - - ; (binds_cvr, ds_hpc_info, modBreaks) - <- if not (isHsBootOrSig hsc_src) - then addTicksToBinds hsc_env mod mod_loc - export_set (typeEnvTyCons type_env) binds - else return (binds, hpcInfo, Nothing) - ; (msgs, mb_res) <- initDs hsc_env tcg_env $ - do { ds_ev_binds <- dsEvBinds ev_binds - ; core_prs <- dsTopLHsBinds binds_cvr - ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs - ; (ds_fords, foreign_prs) <- dsForeigns fords - ; ds_rules <- mapMaybeM dsRule rules - ; ds_vects <- mapM dsVect vects - ; let hpc_init - | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info - | otherwise = empty - ; return ( ds_ev_binds - , foreign_prs `appOL` core_prs `appOL` spec_prs - , spec_rules ++ ds_rules, ds_vects - , ds_fords `appendStubC` hpc_init) } - - ; case mb_res of { - Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> - - do { -- Add export flags to bindings - keep_alive <- readIORef keep_var - ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules - final_prs = addExportFlagsAndRules target export_set keep_alive - rules_for_locals (fromOL all_prs) - - final_pgm = combineEvBinds ds_ev_binds final_prs - -- Notice that we put the whole lot in a big Rec, even the foreign binds - -- When compiling PrelFloat, which defines data Float = F# Float# - -- we want F# to be in scope in the foreign marshalling code! - -- You might think it doesn't matter, but the simplifier brings all top-level - -- things into the in-scope set before simplifying; so we get no unfolding for F#! - -#ifdef DEBUG - -- Debug only as pre-simple-optimisation program may be really big - ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps -#endif - ; (ds_binds, ds_rules_for_imps, ds_vects) - <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0 - -- The simpleOptPgm gets rid of type - -- bindings plus any stupid dead code - - ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps - - ; let used_names = mkUsedNames tcg_env - ; deps <- mkDependencies tcg_env - - ; used_th <- readIORef tc_splice_used - ; dep_files <- readIORef dependent_files - ; safe_mode <- finalSafeMode dflags tcg_env - ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files merged - -- id_mod /= mod when we are processing an hsig, but hsigs - -- never desugared and compiled (there's no code!) - -- Consequently, this should hold for any ModGuts that make - -- past desugaring. See Note [Identity versus semantic module]. - ; MASSERT( id_mod == mod ) - - ; foreign_files <- readIORef th_foreign_files_var - - ; let mod_guts = ModGuts { - mg_module = mod, - mg_hsc_src = hsc_src, - mg_loc = mkFileSrcSpan mod_loc, - mg_exports = exports, - mg_usages = usages, - mg_deps = deps, - mg_used_th = used_th, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_anns = anns, - mg_tcs = tcs, - mg_insts = fixSafeInstances safe_mode insts, - mg_fam_insts = fam_insts, - mg_inst_env = inst_env, - mg_fam_inst_env = fam_inst_env, - mg_patsyns = patsyns, - mg_rules = ds_rules_for_imps, - mg_binds = ds_binds, - mg_foreign = ds_fords, - mg_foreign_files = foreign_files, - mg_hpc_info = ds_hpc_info, - mg_modBreaks = modBreaks, - mg_vect_decls = ds_vects, - mg_vect_info = noVectInfo, - mg_safe_haskell = safe_mode, - mg_trust_pkg = imp_trust_own_pkg imports, - mg_complete_sigs = complete_matches - } - ; return (msgs, Just mod_guts) - }}}} - -mkFileSrcSpan :: ModLocation -> SrcSpan -mkFileSrcSpan mod_loc - = case ml_hs_file mod_loc of - Just file_path -> mkGeneralSrcSpan (mkFastString file_path) - Nothing -> interactiveSrcSpan -- Presumably - -dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) -dsImpSpecs imp_specs - = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs - ; let (spec_binds, spec_rules) = unzip spec_prs - ; return (concatOL spec_binds, spec_rules) } - -combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind] --- Top-level bindings can include coercion bindings, but not via superclasses --- See Note [Top-level evidence] -combineEvBinds [] val_prs - = [Rec val_prs] -combineEvBinds (NonRec b r : bs) val_prs - | isId b = combineEvBinds bs ((b,r):val_prs) - | otherwise = NonRec b r : combineEvBinds bs val_prs -combineEvBinds (Rec prs : bs) val_prs - = combineEvBinds bs (prs ++ val_prs) - -{- -Note [Top-level evidence] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Top-level evidence bindings may be mutually recursive with the top-level value -bindings, so we must put those in a Rec. But we can't put them *all* in a Rec -because the occurrence analyser doesn't teke account of type/coercion variables -when computing dependencies. - -So we pull out the type/coercion variables (which are in dependency order), -and Rec the rest. --} - -deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr) - -deSugarExpr hsc_env tc_expr = do { - let dflags = hsc_dflags hsc_env - - ; showPass dflags "Desugar" - - -- Do desugaring - ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $ - dsLExpr tc_expr - - ; case mb_core_expr of - Nothing -> return () - Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" - (pprCoreExpr expr) - - ; return (msgs, mb_core_expr) } - -{- -************************************************************************ -* * -* Add rules and export flags to binders -* * -************************************************************************ --} - -addExportFlagsAndRules - :: HscTarget -> NameSet -> NameSet -> [CoreRule] - -> [(Id, t)] -> [(Id, t)] -addExportFlagsAndRules target exports keep_alive rules prs - = mapFst add_one prs - where - add_one bndr = add_rules name (add_export name bndr) - where - name = idName bndr - - ---------- Rules -------- - -- See Note [Attach rules to local ids] - -- NB: the binder might have some existing rules, - -- arising from specialisation pragmas - add_rules name bndr - | Just rules <- lookupNameEnv rule_base name - = bndr `addIdSpecialisations` rules - | otherwise - = bndr - rule_base = extendRuleBaseList emptyRuleBase rules - - ---------- Export flag -------- - -- See Note [Adding export flags] - add_export name bndr - | dont_discard name = setIdExported bndr - | otherwise = bndr - - dont_discard :: Name -> Bool - dont_discard name = is_exported name - || name `elemNameSet` keep_alive - - -- In interactive mode, we don't want to discard any top-level - -- entities at all (eg. do not inline them away during - -- simplification), and retain them all in the TypeEnv so they are - -- available from the command line. - -- - -- isExternalName separates the user-defined top-level names from those - -- introduced by the type checker. - is_exported :: Name -> Bool - is_exported | targetRetainsAllBindings target = isExternalName - | otherwise = (`elemNameSet` exports) - -{- -Note [Adding export flags] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Set the no-discard flag if either - a) the Id is exported - b) it's mentioned in the RHS of an orphan rule - c) it's in the keep-alive set - -It means that the binding won't be discarded EVEN if the binding -ends up being trivial (v = w) -- the simplifier would usually just -substitute w for v throughout, but we don't apply the substitution to -the rules (maybe we should?), so this substitution would make the rule -bogus. - -You might wonder why exported Ids aren't already marked as such; -it's just because the type checker is rather busy already and -I didn't want to pass in yet another mapping. - -Note [Attach rules to local ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Find the rules for locally-defined Ids; then we can attach them -to the binders in the top-level bindings - -Reason - - It makes the rules easier to look up - - It means that transformation rules and specialisations for - locally defined Ids are handled uniformly - - It keeps alive things that are referred to only from a rule - (the occurrence analyser knows about rules attached to Ids) - - It makes sure that, when we apply a rule, the free vars - of the RHS are more likely to be in scope - - The imported rules are carried in the in-scope set - which is extended on each iteration by the new wave of - local binders; any rules which aren't on the binding will - thereby get dropped - - -************************************************************************ -* * -* Desugaring transformation rules -* * -************************************************************************ --} - -dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule) -dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs)) - = putSrcSpanDs loc $ - do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars] - - ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ - unsetWOptM Opt_WarnIdentities $ - dsLExpr lhs -- Note [Desugaring RULE left hand sides] - - ; rhs' <- dsLExpr rhs - ; this_mod <- getModule - - ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs' - - -- Substitute the dict bindings eagerly, - -- and take the body apart into a (f args) form - ; case decomposeRuleLhs bndrs'' lhs'' of { - Left msg -> do { warnDs NoReason msg; return Nothing } ; - Right (final_bndrs, fn_id, args) -> do - - { let is_local = isLocalId fn_id - -- NB: isLocalId is False of implicit Ids. This is good because - -- we don't want to attach rules to the bindings of implicit Ids, - -- because they don't show up in the bindings until just before code gen - fn_name = idName fn_id - final_rhs = simpleOptExpr rhs'' -- De-crap it - rule_name = snd (unLoc name) - final_bndrs_set = mkVarSet final_bndrs - arg_ids = filterOut (`elemVarSet` final_bndrs_set) $ - exprsSomeFreeVarsList isId args - - ; dflags <- getDynFlags - ; rule <- dsMkUserRule this_mod is_local - rule_name rule_act fn_name final_bndrs args - final_rhs - ; when (wopt Opt_WarnInlineRuleShadowing dflags) $ - warnRuleShadowing rule_name rule_act fn_id arg_ids - - ; return (Just rule) - } } } - - -warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () --- See Note [Rules and inlining/other rules] -warnRuleShadowing rule_name rule_act fn_id arg_ids - = do { check False fn_id -- We often have multiple rules for the same Id in a - -- module. Maybe we should check that they don't overlap - -- but currently we don't - ; mapM_ (check True) arg_ids } - where - check check_rules_too lhs_id - | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) - -- If imported with no unfolding, no worries - , idInlineActivation lhs_id `competesWith` rule_act - = warnDs (Reason Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because" <+> quotes (ppr lhs_id) - <+> text "might inline first") - , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" - <+> quotes (ppr lhs_id) - , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) - - | check_rules_too - , bad_rule : _ <- get_bad_rules lhs_id - = warnDs (Reason Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because rule" <+> pprRuleName (ruleName bad_rule) - <+> text "for"<+> quotes (ppr lhs_id) - <+> text "might fire first") - , text "Probable fix: add phase [n] or [~n] to the competing rule" - , ifPprDebug (ppr bad_rule) ]) - - | otherwise - = return () - - get_bad_rules lhs_id - = [ rule | rule <- idCoreRules lhs_id - , ruleActivation rule `competesWith` rule_act ] - --- See Note [Desugaring coerce as cast] -unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr) -unfold_coerce bndrs lhs rhs = do - (bndrs', wrap) <- go bndrs - return (bndrs', wrap lhs, wrap rhs) - where - go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr) - go [] = return ([], id) - go (v:vs) - | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v) - , tc `hasKey` coercibleTyConKey = do - u <- newUnique - - let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2] - v' = mkLocalCoVar - (mkDerivedInternalName mkRepEqOcc u (getName v)) ty' - box = Var (dataConWrapId coercibleDataCon) `mkTyApps` - [k, t1, t2] `App` - Coercion (mkCoVarCo v') - - (bndrs, wrap) <- go vs - return (v':bndrs, mkCoreLet (NonRec v box) . wrap) - | otherwise = do - (bndrs,wrap) <- go vs - return (v:bndrs, wrap) - -{- Note [Desugaring RULE left hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the LHS of a RULE we do *not* want to desugar - [x] to build (\cn. x `c` n) -We want to leave explicit lists simply as chains -of cons's. We can achieve that slightly indirectly by -switching off EnableRewriteRules. See DsExpr.dsExplicitList. - -That keeps the desugaring of list comprehensions simple too. - -Nor do we want to warn of conversion identities on the LHS; -the rule is precisly to optimise them: - {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} - -Note [Desugaring coerce as cast] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want the user to express a rule saying roughly “mapping a coercion over a -list can be replaced by a coercion”. But the cast operator of Core (▷) cannot -be written in Haskell. So we use `coerce` for that (#2110). The user writes - map coerce = coerce -as a RULE, and this optimizes any kind of mapped' casts away, including `map -MkNewtype`. - -For that we replace any forall'ed `c :: Coercible a b` value in a RULE by -corresponding `co :: a ~#R b` and wrap the LHS and the RHS in -`let c = MkCoercible co in ...`. This is later simplified to the desired form -by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS). -See also Note [Getting the map/coerce RULE to work] in CoreSubst. - -Note [Rules and inlining/other rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you have - f x = ... - g x = ... - {-# RULES "rule-for-f" forall x. f (g x) = ... #-} -then there's a good chance that in a potential rule redex - ...f (g e)... -then 'f' or 'g' will inline befor the rule can fire. Solution: add an -INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'. - -Note that this applies to all the free variables on the LHS, both the -main function and things in its arguments. - -We also check if there are Ids on the LHS that have competing RULES. -In the above example, suppose we had - {-# RULES "rule-for-g" forally. g [y] = ... #-} -Then "rule-for-f" and "rule-for-g" would compete. Better to add phase -control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes -active; or perhpas after "rule-for-g" has become inactive. This is checked -by 'competesWith' - -Class methods have a built-in RULE to select the method from the dictionary, -so you can't change the phase on this. That makes id very dubious to -match on class methods in RULE lhs's. See Trac #10595. I'm not happy -about this. For example in Control.Arrow we have - -{-# RULES "compose/arr" forall f g . - (arr f) . (arr g) = arr (f . g) #-} - -and similar, which will elicit exactly these warnings, and risk never -firing. But it's not clear what to do instead. We could make the -class methocd rules inactive in phase 2, but that would delay when -subsequent transformations could fire. - - -************************************************************************ -* * -* Desugaring vectorisation declarations -* * -************************************************************************ --} - -dsVect :: LVectDecl Id -> DsM CoreVect -dsVect (L loc (HsVect _ (L _ v) rhs)) - = putSrcSpanDs loc $ - do { rhs' <- dsLExpr rhs - ; return $ Vect v rhs' - } -dsVect (L _loc (HsNoVect _ (L _ v))) - = return $ NoVect v -dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon)) - = return $ VectType isScalar tycon' rhs_tycon - where - tycon' | Just ty <- coreView $ mkTyConTy tycon - , (tycon', []) <- splitTyConApp ty = tycon' - | otherwise = tycon -dsVect vd@(L _ (HsVectTypeIn _ _ _ _)) - = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd) -dsVect (L _loc (HsVectClassOut cls)) - = return $ VectClass (classTyCon cls) -dsVect vc@(L _ (HsVectClassIn _ _)) - = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc) -dsVect (L _loc (HsVectInstOut inst)) - = return $ VectInst (instanceDFunId inst) -dsVect vi@(L _ (HsVectInstIn _)) - = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi) diff --git a/deSugar/DsArrows.hs b/deSugar/DsArrows.hs deleted file mode 100644 --- a/deSugar/DsArrows.hs +++ /dev/null @@ -1,1230 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Desugaring arrow commands --} - -{-# LANGUAGE CPP #-} - -module DsArrows ( dsProcExpr ) where - -#include "HsVersions.h" - -import Match -import DsUtils -import DsMonad - -import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders ) -import TcHsSyn -import qualified HsUtils - --- NB: The desugarer, which straddles the source and Core worlds, sometimes --- needs to see source types (newtypes etc), and sometimes not --- So WATCH OUT; check each use of split*Ty functions. --- Sigh. This is a pain. - -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) - -import TcType -import Type ( splitPiTy ) -import TcEvidence -import CoreSyn -import CoreFVs -import CoreUtils -import MkCore -import DsBinds (dsHsWrapper) - -import Name -import Var -import Id -import ConLike -import TysWiredIn -import BasicTypes -import PrelNames -import Outputable -import Bag -import VarSet -import SrcLoc -import ListSetOps( assocMaybe ) -import Data.List -import Util -import UniqDFM -import UniqSet - -data DsCmdEnv = DsCmdEnv { - arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr - } - -mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv) --- See Note [CmdSyntaxTable] in HsExpr -mkCmdEnv tc_meths - = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths - - -- NB: Some of these lookups might fail, but that's OK if the - -- symbol is never used. That's why we use Maybe first and then - -- panic. An eager panic caused trouble in typecheck/should_compile/tc192 - ; let the_arr_id = assocMaybe prs arrAName - the_compose_id = assocMaybe prs composeAName - the_first_id = assocMaybe prs firstAName - the_app_id = assocMaybe prs appAName - the_choice_id = assocMaybe prs choiceAName - the_loop_id = assocMaybe prs loopAName - - -- used as an argument in, e.g., do_premap - ; check_lev_poly 3 the_arr_id - - -- used as an argument in, e.g., dsCmdStmt/BodyStmt - ; check_lev_poly 5 the_compose_id - - -- used as an argument in, e.g., dsCmdStmt/BodyStmt - ; check_lev_poly 4 the_first_id - - -- the result of the_app_id is used as an argument in, e.g., - -- dsCmd/HsCmdArrApp/HsHigherOrderApp - ; check_lev_poly 2 the_app_id - - -- used as an argument in, e.g., HsCmdIf - ; check_lev_poly 5 the_choice_id - - -- used as an argument in, e.g., RecStmt - ; check_lev_poly 4 the_loop_id - - ; return (meth_binds, DsCmdEnv { - arr_id = Var (unmaybe the_arr_id arrAName), - compose_id = Var (unmaybe the_compose_id composeAName), - first_id = Var (unmaybe the_first_id firstAName), - app_id = Var (unmaybe the_app_id appAName), - choice_id = Var (unmaybe the_choice_id choiceAName), - loop_id = Var (unmaybe the_loop_id loopAName) - }) } - where - mk_bind (std_name, expr) - = do { rhs <- dsExpr expr - ; id <- newSysLocalDs (exprType rhs) -- no check needed; these are functions - ; return (NonRec id rhs, (std_name, id)) } - - unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name) - unmaybe (Just id) _ = id - - -- returns the result type of a pi-type (that is, a forall or a function) - -- Note that this result type may be ill-scoped. - res_type :: Type -> Type - res_type ty = res_ty - where - (_, res_ty) = splitPiTy ty - - check_lev_poly :: Int -- arity - -> Maybe Id -> DsM () - check_lev_poly _ Nothing = return () - check_lev_poly arity (Just id) - = dsNoLevPoly (nTimes arity res_type (idType id)) - (text "In the result of the function" <+> quotes (ppr id)) - - --- arr :: forall b c. (b -> c) -> a b c -do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr -do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f] - --- (>>>) :: forall b c d. a b c -> a c d -> a b d -do_compose :: DsCmdEnv -> Type -> Type -> Type -> - CoreExpr -> CoreExpr -> CoreExpr -do_compose ids b_ty c_ty d_ty f g - = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g] - --- first :: forall b c d. a b c -> a (b,d) (c,d) -do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr -do_first ids b_ty c_ty d_ty f - = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f] - --- app :: forall b c. a (a b c, b) c -do_app :: DsCmdEnv -> Type -> Type -> CoreExpr -do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty] - --- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d --- note the swapping of d and c -do_choice :: DsCmdEnv -> Type -> Type -> Type -> - CoreExpr -> CoreExpr -> CoreExpr -do_choice ids b_ty c_ty d_ty f g - = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g] - --- loop :: forall b d c. a (b,d) (c,d) -> a b c --- note the swapping of d and c -do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr -do_loop ids b_ty c_ty d_ty f - = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f] - --- premap :: forall b c d. (b -> c) -> a c d -> a b d --- premap f g = arr f >>> g -do_premap :: DsCmdEnv -> Type -> Type -> Type -> - CoreExpr -> CoreExpr -> CoreExpr -do_premap ids b_ty c_ty d_ty f g - = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g - -mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr -mkFailExpr ctxt ty - = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) - --- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a -mkFstExpr :: Type -> Type -> DsM CoreExpr -mkFstExpr a_ty b_ty = do - a_var <- newSysLocalDs a_ty - b_var <- newSysLocalDs b_ty - pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) - return (Lam pair_var - (coreCasePair pair_var a_var b_var (Var a_var))) - --- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b -mkSndExpr :: Type -> Type -> DsM CoreExpr -mkSndExpr a_ty b_ty = do - a_var <- newSysLocalDs a_ty - b_var <- newSysLocalDs b_ty - pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) - return (Lam pair_var - (coreCasePair pair_var a_var b_var (Var b_var))) - -{- -Build case analysis of a tuple. This cannot be done in the DsM monad, -because the list of variables is typically not yet defined. --} - --- coreCaseTuple [u1..] v [x1..xn] body --- = case v of v { (x1, .., xn) -> body } --- But the matching may be nested if the tuple is very big - -coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr -coreCaseTuple uniqs scrut_var vars body - = mkTupleCase uniqs vars body scrut_var (Var scrut_var) - -coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr -coreCasePair scrut_var var1 var2 body - = Case (Var scrut_var) scrut_var (exprType body) - [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)] - -mkCorePairTy :: Type -> Type -> Type -mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] - -mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr -mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] - -mkCoreUnitExpr :: CoreExpr -mkCoreUnitExpr = mkCoreTup [] - -{- -The input is divided into a local environment, which is a flat tuple -(unless it's too big), and a stack, which is a right-nested pair. -In general, the input has the form - - ((x1,...,xn), (s1,...(sk,())...)) - -where xi are the environment values, and si the ones on the stack, -with s1 being the "top", the first one to be matched with a lambda. --} - -envStackType :: [Id] -> Type -> Type -envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty - --- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t) -splitTypeAt :: Int -> Type -> ([Type], Type) -splitTypeAt n ty - | n == 0 = ([], ty) - | otherwise = case tcTyConAppArgs ty of - [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r) - _ -> pprPanic "splitTypeAt" (ppr ty) - ----------------------------------------------- --- buildEnvStack --- --- ((x1,...,xn),stk) - -buildEnvStack :: [Id] -> Id -> CoreExpr -buildEnvStack env_ids stack_id - = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id) - ----------------------------------------------- --- matchEnvStack --- --- \ ((x1,...,xn),stk) -> body --- => --- \ pair -> --- case pair of (tup,stk) -> --- case tup of (x1,...,xn) -> --- body - -matchEnvStack :: [Id] -- x1..xn - -> Id -- stk - -> CoreExpr -- e - -> DsM CoreExpr -matchEnvStack env_ids stack_id body = do - uniqs <- newUniqueSupply - tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids) - let match_env = coreCaseTuple uniqs tup_var env_ids body - pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id)) - return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) - ----------------------------------------------- --- matchEnv --- --- \ (x1,...,xn) -> body --- => --- \ tup -> --- case tup of (x1,...,xn) -> --- body - -matchEnv :: [Id] -- x1..xn - -> CoreExpr -- e - -> DsM CoreExpr -matchEnv env_ids body = do - uniqs <- newUniqueSupply - tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids) - return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) - ----------------------------------------------- --- matchVarStack --- --- case (x1, ...(xn, s)...) -> e --- => --- case z0 of (x1,z1) -> --- case zn-1 of (xn,s) -> --- e -matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr) -matchVarStack [] stack_id body = return (stack_id, body) -matchVarStack (param_id:param_ids) stack_id body = do - (tail_id, tail_code) <- matchVarStack param_ids stack_id body - pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id)) - return (pair_id, coreCasePair pair_id param_id tail_id tail_code) - -mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id -mkHsEnvStackExpr env_ids stack_id - = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] - --- Translation of arrow abstraction - --- D; xs |-a c : () --> t' ---> c' --- -------------------------- --- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c' --- --- where (xs) is the tuple of variables bound by p - -dsProcExpr - :: LPat Id - -> LHsCmdTop Id - -> DsM CoreExpr -dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do - (meth_binds, meth_ids) <- mkCmdEnv ids - let locals = mkVarSet (collectPatBinders pat) - (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd - let env_ty = mkBigCoreVarTupTy env_ids - let env_stk_ty = mkCorePairTy env_ty unitTy - let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr - fail_expr <- mkFailExpr ProcExpr env_stk_ty - var <- selectSimpleMatchVarL pat - match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr - let pat_ty = hsLPatType pat - let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty - (Lam var match_code) - core_cmd - return (mkLets meth_binds proc_code) - -{- -Translation of a command judgement of the form - - D; xs |-a c : stk --> t - -to an expression e such that - - D |- e :: a (xs, stk) t --} - -dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id] - -> DsM (CoreExpr, DIdSet) -dsLCmd ids local_vars stk_ty res_ty cmd env_ids - = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids - -dsCmd :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this command - -> Type -- type of the stack (right-nested tuple) - -> Type -- return type of the command - -> HsCmd Id -- command to desugar - -> [Id] -- list of vars in the input to this command - -- This is typically fed back, - -- so don't pull on it too early - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - --- D |- fun :: a t1 t2 --- D, xs |- arg :: t1 --- ----------------------------- --- D; xs |-a fun -< arg : stk --> t2 --- --- ---> premap (\ ((xs), _stk) -> arg) fun - -dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _) - env_ids = do - let - (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty - (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - core_arrow <- dsLExprNoLP arrow - core_arg <- dsLExpr arg - stack_id <- newSysLocalDs stack_ty - core_make_arg <- matchEnvStack env_ids stack_id core_arg - return (do_premap ids - (envStackType env_ids stack_ty) - arg_ty - res_ty - core_make_arg - core_arrow, - exprFreeIdsDSet core_arg `udfmIntersectUFM` (getUniqSet local_vars)) - --- D, xs |- fun :: a t1 t2 --- D, xs |- arg :: t1 --- ------------------------------ --- D; xs |-a fun -<< arg : stk --> t2 --- --- ---> premap (\ ((xs), _stk) -> (fun, arg)) app - -dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _) - env_ids = do - let - (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty - (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - - core_arrow <- dsLExpr arrow - core_arg <- dsLExpr arg - stack_id <- newSysLocalDs stack_ty - core_make_pair <- matchEnvStack env_ids stack_id - (mkCorePairExpr core_arrow core_arg) - - return (do_premap ids - (envStackType env_ids stack_ty) - (mkCorePairTy arrow_ty arg_ty) - res_ty - core_make_pair - (do_app ids arg_ty res_ty), - (exprsFreeIdsDSet [core_arrow, core_arg]) - `udfmIntersectUFM` getUniqSet local_vars) - --- D; ys |-a cmd : (t,stk) --> t' --- D, xs |- exp :: t --- ------------------------ --- D; xs |-a cmd exp : stk --> t' --- --- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd - -dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do - core_arg <- dsLExpr arg - let - arg_ty = exprType core_arg - stack_ty' = mkCorePairTy arg_ty stack_ty - (core_cmd, free_vars, env_ids') - <- dsfixCmd ids local_vars stack_ty' res_ty cmd - stack_id <- newSysLocalDs stack_ty - arg_id <- newSysLocalDsNoLP arg_ty - -- push the argument expression onto the stack - let - stack' = mkCorePairExpr (Var arg_id) (Var stack_id) - core_body = bindNonRec arg_id core_arg - (mkCorePairExpr (mkBigCoreVarTup env_ids') stack') - - -- match the environment and stack against the input - core_map <- matchEnvStack env_ids stack_id core_body - return (do_premap ids - (envStackType env_ids stack_ty) - (envStackType env_ids' stack_ty') - res_ty - core_map - core_cmd, - free_vars `unionDVarSet` - (exprFreeIdsDSet core_arg `udfmIntersectUFM` getUniqSet local_vars)) - --- D; ys |-a cmd : stk t' --- ----------------------------------------------- --- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t' --- --- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd - -dsCmd ids local_vars stack_ty res_ty - (HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _ - (GRHSs [L _ (GRHS [] body)] _ ))] })) - env_ids = do - let pat_vars = mkVarSet (collectPatsBinders pats) - let - local_vars' = pat_vars `unionVarSet` local_vars - (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty - (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body - param_ids <- mapM newSysLocalDsNoLP pat_tys - stack_id' <- newSysLocalDs stack_ty' - - -- the expression is built from the inside out, so the actions - -- are presented in reverse order - - let - -- build a new environment, plus what's left of the stack - core_expr = buildEnvStack env_ids' stack_id' - in_ty = envStackType env_ids stack_ty - in_ty' = envStackType env_ids' stack_ty' - - fail_expr <- mkFailExpr LambdaExpr in_ty' - -- match the patterns against the parameters - match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr - -- match the parameters against the top of the old stack - (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code - -- match the old environment and stack against the input - select_code <- matchEnvStack env_ids stack_id param_code - return (do_premap ids in_ty in_ty' res_ty select_code core_body, - free_vars `udfmMinusUFM` getUniqSet pat_vars) - -dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids - = dsLCmd ids local_vars stack_ty res_ty cmd env_ids - --- D, xs |- e :: Bool --- D; xs1 |-a c1 : stk --> t --- D; xs2 |-a c2 : stk --> t --- ---------------------------------------- --- D; xs |-a if e then c1 else c2 : stk --> t --- --- ---> premap (\ ((xs),stk) -> --- if e then Left ((xs1),stk) else Right ((xs2),stk)) --- (c1 ||| c2) - -dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) - env_ids = do - core_cond <- dsLExpr cond - (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd - (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd - stack_id <- newSysLocalDs stack_ty - either_con <- dsLookupTyCon eitherTyConName - left_con <- dsLookupDataCon leftDataConName - right_con <- dsLookupDataCon rightDataConName - - let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1, Type ty2, e] - mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1, Type ty2, e] - - in_ty = envStackType env_ids stack_ty - then_ty = envStackType then_ids stack_ty - else_ty = envStackType else_ids stack_ty - sum_ty = mkTyConApp either_con [then_ty, else_ty] - fvs_cond = exprFreeIdsDSet core_cond `udfmIntersectUFM` getUniqSet local_vars - - core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_id) - core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id) - - core_if <- case mb_fun of - Just fun -> do { fun_apps <- dsSyntaxExpr fun [core_cond, core_left, core_right] - ; matchEnvStack env_ids stack_id fun_apps } - Nothing -> matchEnvStack env_ids stack_id $ - mkIfThenElse core_cond core_left core_right - - return (do_premap ids in_ty sum_ty res_ty - core_if - (do_choice ids then_ty else_ty res_ty core_then core_else), - fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else) - -{- -Case commands are treated in much the same way as if commands -(see above) except that there are more alternatives. For example - - case e of { p1 -> c1; p2 -> c2; p3 -> c3 } - -is translated to - - premap (\ ((xs)*ts) -> case e of - p1 -> (Left (Left (xs1)*ts)) - p2 -> Left ((Right (xs2)*ts)) - p3 -> Right ((xs3)*ts)) - ((c1 ||| c2) ||| c3) - -The idea is to extract the commands from the case, build a balanced tree -of choices, and replace the commands with expressions that build tagged -tuples, obtaining a case expression that can be desugared normally. -To build all this, we use triples describing segments of the list of -case bodies, containing the following fields: - * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put - into the case replacing the commands - * a sum type that is the common type of these expressions, and also the - input type of the arrow - * a CoreExpr for an arrow built by combining the translated command - bodies with |||. --} - -dsCmd ids local_vars stack_ty res_ty - (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys - , mg_origin = origin })) - env_ids = do - stack_id <- newSysLocalDs stack_ty - - -- Extract and desugar the leaf commands in the case, building tuple - -- expressions that will (after tagging) replace these leaves - - let - leaves = concatMap leavesMatch matches - make_branch (leaf, bound_vars) = do - (core_leaf, _fvs, leaf_ids) <- - dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf - return ([mkHsEnvStackExpr leaf_ids stack_id], - envStackType leaf_ids stack_ty, - core_leaf) - - branches <- mapM make_branch leaves - either_con <- dsLookupTyCon eitherTyConName - left_con <- dsLookupDataCon leftDataConName - right_con <- dsLookupDataCon rightDataConName - let - left_id = HsConLikeOut (RealDataCon left_con) - right_id = HsConLikeOut (RealDataCon right_con) - left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e - right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e - - -- Prefix each tuple with a distinct series of Left's and Right's, - -- in a balanced way, keeping track of the types. - - merge_branches (builds1, in_ty1, core_exp1) - (builds2, in_ty2, core_exp2) - = (map (left_expr in_ty1 in_ty2) builds1 ++ - map (right_expr in_ty1 in_ty2) builds2, - mkTyConApp either_con [in_ty1, in_ty2], - do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2) - (leaves', sum_ty, core_choices) = foldb merge_branches branches - - -- Replace the commands in the case with these tagged tuples, - -- yielding a HsExpr Id we can feed to dsExpr. - - (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches - in_ty = envStackType env_ids stack_ty - - core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches' - , mg_arg_tys = arg_tys - , mg_res_ty = sum_ty, mg_origin = origin })) - -- Note that we replace the HsCase result type by sum_ty, - -- which is the type of matches' - - core_matches <- matchEnvStack env_ids stack_id core_body - return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, - exprFreeIdsDSet core_body `udfmIntersectUFM` getUniqSet local_vars) - --- D; ys |-a cmd : stk --> t --- ---------------------------------- --- D; xs |-a let binds in cmd : stk --> t --- --- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c - -dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do - let - defined_vars = mkVarSet (collectLocalBinders binds) - local_vars' = defined_vars `unionVarSet` local_vars - - (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body - stack_id <- newSysLocalDs stack_ty - -- build a new environment, plus the stack, using the let bindings - core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) - -- match the old environment and stack against the input - core_map <- matchEnvStack env_ids stack_id core_binds - return (do_premap ids - (envStackType env_ids stack_ty) - (envStackType env_ids' stack_ty) - res_ty - core_map - core_body, - exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars) - --- D; xs |-a ss : t --- ---------------------------------- --- D; xs |-a do { ss } : () --> t --- --- ---> premap (\ (env,stk) -> env) c - -dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do - putSrcSpanDs loc $ - dsNoLevPoly stmts_ty - (text "In the do-command:" <+> ppr do_block) - (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids - let env_ty = mkBigCoreVarTupTy env_ids - core_fst <- mkFstExpr env_ty stack_ty - return (do_premap ids - (mkCorePairTy env_ty stack_ty) - env_ty - res_ty - core_fst - core_stmts, - env_ids') - --- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t --- D; xs |-a ci :: stki --> ti --- ----------------------------------- --- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn - -dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do - let env_ty = mkBigCoreVarTupTy env_ids - core_op <- dsLExpr op - (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args - return (mkApps (App core_op (Type env_ty)) core_args, - unionDVarSets fv_sets) - -dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do - (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids - core_wrap <- dsHsWrapper wrap - return (core_wrap core_cmd, env_ids') - -dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) - --- D; ys |-a c : stk --> t (ys <= xs) --- --------------------- --- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c - -dsTrimCmdArg - :: IdSet -- set of local vars available to this command - -> [Id] -- list of vars in the input to this command - -> LHsCmdTop Id -- command argument to desugar - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free -dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do - (meth_binds, meth_ids) <- mkCmdEnv ids - (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd - stack_id <- newSysLocalDs stack_ty - trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) - let - in_ty = envStackType env_ids stack_ty - in_ty' = envStackType env_ids' stack_ty - arg_code = if env_ids' == env_ids then core_cmd else - do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd - return (mkLets meth_binds arg_code, free_vars) - --- Given D; xs |-a c : stk --> t, builds c with xs fed back. --- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) - -dsfixCmd - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this command - -> Type -- type of the stack (right-nested tuple) - -> Type -- return type of the command - -> LHsCmd Id -- command to desugar - -> DsM (CoreExpr, -- desugared expression - DIdSet, -- subset of local vars that occur free - [Id]) -- the same local vars as a list, fed back -dsfixCmd ids local_vars stk_ty cmd_ty cmd - = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty - (text "When desugaring the command:" <+> ppr cmd) - ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } - --- Feed back the list of local variables actually used a command, --- for use as the input tuple of the generated arrow. - -trimInput - :: ([Id] -> DsM (CoreExpr, DIdSet)) - -> DsM (CoreExpr, -- desugared expression - DIdSet, -- subset of local vars that occur free - [Id]) -- same local vars as a list, fed back to - -- the inner function to form the tuple of - -- inputs to the arrow. -trimInput build_arrow - = fixDs (\ ~(_,_,env_ids) -> do - (core_cmd, free_vars) <- build_arrow env_ids - return (core_cmd, free_vars, dVarSetElems free_vars)) - -{- -Translation of command judgements of the form - - D |-a do { ss } : t --} - -dsCmdDo :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> Type -- return type of the statement - -> [CmdLStmt Id] -- statements to desugar - -> [Id] -- list of vars in the input to this statement - -- This is typically fed back, - -- so don't pull on it too early - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - -dsCmdDo _ _ _ [] _ = panic "dsCmdDo" - --- D; xs |-a c : () --> t --- -------------------------- --- D; xs |-a do { c } : t --- --- ---> premap (\ (xs) -> ((xs), ())) c - -dsCmdDo ids local_vars res_ty [L loc (LastStmt body _ _)] env_ids = do - putSrcSpanDs loc $ dsNoLevPoly res_ty - (text "In the command:" <+> ppr body) - (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids - let env_ty = mkBigCoreVarTupTy env_ids - env_var <- newSysLocalDs env_ty - let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) - return (do_premap ids - env_ty - (mkCorePairTy env_ty unitTy) - res_ty - core_map - core_body, - env_ids') - -dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do - let bound_vars = mkVarSet (collectLStmtBinders stmt) - let local_vars' = bound_vars `unionVarSet` local_vars - (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) - (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids - return (do_compose ids - (mkBigCoreVarTupTy env_ids) - (mkBigCoreVarTupTy env_ids') - res_ty - core_stmt - core_stmts, - fv_stmt) - -{- -A statement maps one local environment to another, and is represented -as an arrow from one tuple type to another. A statement sequence is -translated to a composition of such arrows. --} - -dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id] - -> DsM (CoreExpr, DIdSet) -dsCmdLStmt ids local_vars out_ids cmd env_ids - = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids - -dsCmdStmt - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [Id] -- list of vars in the output of this statement - -> CmdStmt Id -- statement to desugar - -> [Id] -- list of vars in the input to this statement - -- This is typically fed back, - -- so don't pull on it too early - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - --- D; xs1 |-a c : () --> t --- D; xs' |-a do { ss } : t' --- ------------------------------ --- D; xs |-a do { c; ss } : t' --- --- ---> premap (\ ((xs)) -> (((xs1),()),(xs'))) --- (first c >>> arr snd) >>> ss - -dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do - (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd - core_mux <- matchEnv env_ids - (mkCorePairExpr - (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) - (mkBigCoreVarTup out_ids)) - let - in_ty = mkBigCoreVarTupTy env_ids - in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy - out_ty = mkBigCoreVarTupTy out_ids - before_c_ty = mkCorePairTy in_ty1 out_ty - after_c_ty = mkCorePairTy c_ty out_ty - dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here - snd_fn <- mkSndExpr c_ty out_ty - return (do_premap ids in_ty before_c_ty out_ty core_mux $ - do_compose ids before_c_ty after_c_ty out_ty - (do_first ids in_ty1 c_ty out_ty core_cmd) $ - do_arr ids after_c_ty out_ty snd_fn, - extendDVarSetList fv_cmd out_ids) - --- D; xs1 |-a c : () --> t --- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p) --- ----------------------------------- --- D; xs |-a do { p <- c; ss } : t' --- --- ---> premap (\ (xs) -> (((xs1),()),(xs2))) --- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss --- --- It would be simpler and more consistent to do this using second, --- but that's likely to be defined in terms of first. - -dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do - let pat_ty = hsLPatType pat - (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd - let pat_vars = mkVarSet (collectPatBinders pat) - let - env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids - env_ty2 = mkBigCoreVarTupTy env_ids2 - - -- multiplexing function - -- \ (xs) -> (((xs1),()),(xs2)) - - core_mux <- matchEnv env_ids - (mkCorePairExpr - (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) - (mkBigCoreVarTup env_ids2)) - - -- projection function - -- \ (p, (xs2)) -> (zs) - - env_id <- newSysLocalDs env_ty2 - uniqs <- newUniqueSupply - let - after_c_ty = mkCorePairTy pat_ty env_ty2 - out_ty = mkBigCoreVarTupTy out_ids - body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) - - fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty - pat_id <- selectSimpleMatchVarL pat - match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr - pair_id <- newSysLocalDs after_c_ty - let - proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) - - -- put it all together - let - in_ty = mkBigCoreVarTupTy env_ids - in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy - in_ty2 = mkBigCoreVarTupTy env_ids2 - before_c_ty = mkCorePairTy in_ty1 in_ty2 - return (do_premap ids in_ty before_c_ty out_ty core_mux $ - do_compose ids before_c_ty after_c_ty out_ty - (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $ - do_arr ids after_c_ty out_ty proj_expr, - fv_cmd `unionDVarSet` (mkDVarSet out_ids `udfmMinusUFM` getUniqSet pat_vars)) - --- D; xs' |-a do { ss } : t --- -------------------------------------- --- D; xs |-a do { let binds; ss } : t --- --- ---> arr (\ (xs) -> let binds in (xs')) >>> ss - -dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do - -- build a new environment using the let bindings - core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) - -- match the old environment against the input - core_map <- matchEnv env_ids core_binds - return (do_arr ids - (mkBigCoreVarTupTy env_ids) - (mkBigCoreVarTupTy out_ids) - core_map, - exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars) - --- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ... --- D; xs' |-a do { ss' } : t --- ------------------------------------ --- D; xs |-a do { rec ss; ss' } : t --- --- xs1 = xs' /\ defs(ss) --- xs2 = xs' - defs(ss) --- ys1 = ys - defs(ss) --- ys2 = ys /\ defs(ss) --- --- ---> arr (\(xs) -> ((ys1),(xs2))) >>> --- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> --- arr (\((xs1),(xs2)) -> (xs')) >>> ss' - -dsCmdStmt ids local_vars out_ids - (RecStmt { recS_stmts = stmts - , recS_later_ids = later_ids, recS_rec_ids = rec_ids - , recS_later_rets = later_rets, recS_rec_rets = rec_rets }) - env_ids = do - let - later_ids_set = mkVarSet later_ids - env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids - env2_id_set = mkDVarSet env2_ids - env2_ty = mkBigCoreVarTupTy env2_ids - - -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) - - uniqs <- newUniqueSupply - env2_id <- newSysLocalDs env2_ty - let - later_ty = mkBigCoreVarTupTy later_ids - post_pair_ty = mkCorePairTy later_ty env2_ty - post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids) - - post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body - - --- loop (...) - - (core_loop, env1_id_set, env1_ids) - <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets - - -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids)) - - let - env1_ty = mkBigCoreVarTupTy env1_ids - pre_pair_ty = mkCorePairTy env1_ty env2_ty - pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids) - (mkBigCoreVarTup env2_ids) - - pre_loop_fn <- matchEnv env_ids pre_loop_body - - -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn - - let - env_ty = mkBigCoreVarTupTy env_ids - out_ty = mkBigCoreVarTupTy out_ids - core_body = do_premap ids env_ty pre_pair_ty out_ty - pre_loop_fn - (do_compose ids pre_pair_ty post_pair_ty out_ty - (do_first ids env1_ty later_ty env2_ty - core_loop) - (do_arr ids post_pair_ty out_ty - post_loop_fn)) - - return (core_body, env1_id_set `unionDVarSet` env2_id_set) - -dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) - --- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) --- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>> - -dsRecCmd - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [CmdLStmt Id] -- list of statements inside the RecCmd - -> [Id] -- list of vars defined here and used later - -> [HsExpr Id] -- expressions corresponding to later_ids - -> [Id] -- list of vars fed back through the loop - -> [HsExpr Id] -- expressions corresponding to rec_ids - -> DsM (CoreExpr, -- desugared statement - DIdSet, -- subset of local vars that occur free - [Id]) -- same local vars as a list - -dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do - let - later_id_set = mkVarSet later_ids - rec_id_set = mkVarSet rec_ids - local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars - - -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets)) - - core_later_rets <- mapM dsExpr later_rets - core_rec_rets <- mapM dsExpr rec_rets - let - -- possibly polymorphic version of vars of later_ids and rec_ids - out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets) - out_ty = mkBigCoreVarTupTy out_ids - - later_tuple = mkBigCoreTup core_later_rets - later_ty = mkBigCoreVarTupTy later_ids - - rec_tuple = mkBigCoreTup core_rec_rets - rec_ty = mkBigCoreVarTupTy rec_ids - - out_pair = mkCorePairExpr later_tuple rec_tuple - out_pair_ty = mkCorePairTy later_ty rec_ty - - mk_pair_fn <- matchEnv out_ids out_pair - - -- ss - - (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts - - -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) - - rec_id <- newSysLocalDs rec_ty - let - env1_id_set = fv_stmts `udfmMinusUFM` getUniqSet rec_id_set - env1_ids = dVarSetElems env1_id_set - env1_ty = mkBigCoreVarTupTy env1_ids - in_pair_ty = mkCorePairTy env1_ty rec_ty - core_body = mkBigCoreTup (map selectVar env_ids) - where - selectVar v - | v `elemVarSet` rec_id_set - = mkTupleSelector rec_ids v rec_id (Var rec_id) - | otherwise = Var v - - squash_pair_fn <- matchEnvStack env1_ids rec_id core_body - - -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn)) - - let - env_ty = mkBigCoreVarTupTy env_ids - core_loop = do_loop ids env1_ty later_ty rec_ty - (do_premap ids in_pair_ty env_ty out_pair_ty - squash_pair_fn - (do_compose ids env_ty out_ty out_pair_ty - core_stmts - (do_arr ids out_ty out_pair_ty mk_pair_fn))) - - return (core_loop, env1_id_set, env1_ids) - -{- -A sequence of statements (as in a rec) is desugared to an arrow between -two environments (no stack) --} - -dsfixCmdStmts - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [Id] -- output vars of these statements - -> [CmdLStmt Id] -- statements to desugar - -> DsM (CoreExpr, -- desugared expression - DIdSet, -- subset of local vars that occur free - [Id]) -- same local vars as a list - -dsfixCmdStmts ids local_vars out_ids stmts - = trimInput (dsCmdStmts ids local_vars out_ids stmts) - -- TODO: Add levity polymorphism check for the resulting expression. - -- But I (Richard E.) don't know enough about arrows to do so. - -dsCmdStmts - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [Id] -- output vars of these statements - -> [CmdLStmt Id] -- statements to desugar - -> [Id] -- list of vars in the input to these statements - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - -dsCmdStmts ids local_vars out_ids [stmt] env_ids - = dsCmdLStmt ids local_vars out_ids stmt env_ids - -dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do - let bound_vars = mkVarSet (collectLStmtBinders stmt) - let local_vars' = bound_vars `unionVarSet` local_vars - (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts - (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids - return (do_compose ids - (mkBigCoreVarTupTy env_ids) - (mkBigCoreVarTupTy env_ids') - (mkBigCoreVarTupTy out_ids) - core_stmt - core_stmts, - fv_stmt) - -dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" - --- Match a list of expressions against a list of patterns, left-to-right. - -matchSimplys :: [CoreExpr] -- Scrutinees - -> HsMatchContext Name -- Match kind - -> [LPat Id] -- Patterns they should match - -> CoreExpr -- Return this if they all match - -> CoreExpr -- Return this if they don't - -> DsM CoreExpr -matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr -matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do - match_code <- matchSimplys exps ctxt pats result_expr fail_expr - matchSimply exp ctxt pat match_code fail_expr -matchSimplys _ _ _ _ _ = panic "matchSimplys" - --- List of leaf expressions, with set of variables bound in each - -leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)] -leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds)))) - = let - defined_vars = mkVarSet (collectPatsBinders pats) - `unionVarSet` - mkVarSet (collectLocalBinders binds) - in - [(body, - mkVarSet (collectLStmtsBinders stmts) - `unionVarSet` defined_vars) - | L _ (GRHS stmts body) <- grhss] - --- Replace the leaf commands in a match - -replaceLeavesMatch - :: Type -- new result type - -> [Located (body' Id)] -- replacement leaf expressions of that type - -> LMatch Id (Located (body Id)) -- the matches of a case command - -> ([Located (body' Id)], -- remaining leaf expressions - LMatch Id (Located (body' Id))) -- updated match -replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds))) - = let - (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss - in - (leaves', L loc (Match mf pat mt (GRHSs grhss' binds))) - -replaceLeavesGRHS - :: [Located (body' Id)] -- replacement leaf expressions of that type - -> LGRHS Id (Located (body Id)) -- rhss of a case command - -> ([Located (body' Id)], -- remaining leaf expressions - LGRHS Id (Located (body' Id))) -- updated GRHS -replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _)) - = (leaves, L loc (GRHS stmts leaf)) -replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" - --- Balanced fold of a non-empty list. - -foldb :: (a -> a -> a) -> [a] -> a -foldb _ [] = error "foldb of empty list" -foldb _ [x] = x -foldb f xs = foldb f (fold_pairs xs) - where - fold_pairs [] = [] - fold_pairs [x] = [x] - fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs - -{- -Note [Dictionary binders in ConPatOut] See also same Note in HsUtils -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The following functions to collect value variables from patterns are -copied from HsUtils, with one change: we also collect the dictionary -bindings (pat_binds) from ConPatOut. We need them for cases like - -h :: Arrow a => Int -> a (Int,Int) Int -h x = proc (y,z) -> case compare x y of - GT -> returnA -< z+x - -The type checker turns the case into - - case compare x y of - GT { p77 = plusInt } -> returnA -< p77 z x - -Here p77 is a local binding for the (+) operation. - -See comments in HsUtils for why the other version does not include -these bindings. --} - -collectPatBinders :: LPat Id -> [Id] -collectPatBinders pat = collectl pat [] - -collectPatsBinders :: [LPat Id] -> [Id] -collectPatsBinders pats = foldr collectl [] pats - ---------------------- -collectl :: LPat Id -> [Id] -> [Id] --- See Note [Dictionary binders in ConPatOut] -collectl (L _ pat) bndrs - = go pat - where - go (VarPat (L _ var)) = var : bndrs - go (WildPat _) = bndrs - go (LazyPat pat) = collectl pat bndrs - go (BangPat pat) = collectl pat bndrs - go (AsPat (L _ a) pat) = a : collectl pat bndrs - go (ParPat pat) = collectl pat bndrs - - go (ListPat pats _ _) = foldr collectl bndrs pats - go (PArrPat pats _) = foldr collectl bndrs pats - go (TuplePat pats _ _) = foldr collectl bndrs pats - go (SumPat pat _ _ _) = collectl pat bndrs - - go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) - go (ConPatOut {pat_args=ps, pat_binds=ds}) = - collectEvBinders ds - ++ foldr collectl bndrs (hsConPatArgs ps) - go (LitPat _) = bndrs - go (NPat {}) = bndrs - go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs - - go (SigPatIn pat _) = collectl pat bndrs - go (SigPatOut pat _) = collectl pat bndrs - go (CoPat _ pat _) = collectl (noLoc pat) bndrs - go (ViewPat _ pat _) = collectl pat bndrs - go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) - -collectEvBinders :: TcEvBinds -> [Id] -collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs -collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" - -add_ev_bndr :: EvBind -> [Id] -> [Id] -add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs - | otherwise = bs - -- A worry: what about coercion variable binders?? - -collectLStmtsBinders :: [LStmt Id body] -> [Id] -collectLStmtsBinders = concatMap collectLStmtBinders - -collectLStmtBinders :: LStmt Id body -> [Id] -collectLStmtBinders = collectStmtBinders . unLoc - -collectStmtBinders :: Stmt Id body -> [Id] -collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids -collectStmtBinders stmt = HsUtils.collectStmtBinders stmt diff --git a/deSugar/DsBinds.hs b/deSugar/DsBinds.hs deleted file mode 100644 --- a/deSugar/DsBinds.hs +++ /dev/null @@ -1,1387 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Pattern-matching bindings (HsBinds and MonoBinds) - -Handles @HsBinds@; those at the top level require different handling, -in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at -lower levels it is preserved with @let@/@letrec@s). --} - -{-# LANGUAGE CPP #-} - -module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, - dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} DsExpr( dsLExpr ) -import {-# SOURCE #-} Match( matchWrapper ) - -import DsMonad -import DsGRHSs -import DsUtils - -import HsSyn -- lots of things -import CoreSyn -- lots of things -import Literal ( Literal(MachStr) ) -import CoreOpt ( simpleOptExpr ) -import OccurAnal ( occurAnalyseExpr ) -import MkCore -import CoreUtils -import CoreArity ( etaExpand ) -import CoreUnfold -import CoreFVs -import Digraph - -import PrelNames -import TyCon -import TcEvidence -import TcType -import Type -import Coercion -import TysWiredIn ( typeNatKind, typeSymbolKind ) -import Id -import MkId(proxyHashId) -import Class -import Name -import VarSet -import Rules -import VarEnv -import Outputable -import Module -import SrcLoc -import Maybes -import OrdList -import Bag -import BasicTypes -import DynFlags -import FastString -import Util -import MonadUtils -import qualified GHC.LanguageExtensions as LangExt -import Control.Monad - -{-********************************************************************** -* * - Desugaring a MonoBinds -* * -**********************************************************************-} - --- | Desugar top level binds, strict binds are treated like normal --- binds since there is no good time to force before first usage. -dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) -dsTopLHsBinds binds - -- see Note [Strict binds checks] - | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) - = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds - ; mapBagM_ (top_level_err "strict pattern bindings") bang_binds - ; return nilOL } - - | otherwise - = do { (force_vars, prs) <- dsLHsBinds binds - ; when debugIsOn $ - do { xstrict <- xoptM LangExt.Strict - ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) } - -- with -XStrict, even top-level vars are listed as force vars. - - ; return (toOL prs) } - - where - unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds - bang_binds = filterBag (isBangedPatBind . unLoc) binds - - top_level_err desc (L loc bind) - = putSrcSpanDs loc $ - errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") - 2 (ppr bind)) - - --- | Desugar all other kind of bindings, Ids of strict binds are returned to --- later be forced in the binding group body, see Note [Desugar Strict binds] -dsLHsBinds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBinds binds - = do { MASSERT( allBag (not . isUnliftedHsBind . unLoc) binds ) - ; ds_bs <- mapBagM dsLHsBind binds - ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b')) - id ([], []) ds_bs) } - ------------------------- -dsLHsBind :: LHsBind Id - -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBind (L loc bind) = do dflags <- getDynFlags - putSrcSpanDs loc $ dsHsBind dflags bind - --- | Desugar a single binding (or group of recursive binds). -dsHsBind :: DynFlags - -> HsBind Id - -> DsM ([Id], [(Id,CoreExpr)]) - -- ^ The Ids of strict binds, to be forced in the body of the - -- binding group see Note [Desugar Strict binds] and all - -- bindings and their desugared right hand sides. - -dsHsBind dflags - (VarBind { var_id = var - , var_rhs = expr - , var_inline = inline_regardless }) - = do { core_expr <- dsLExpr expr - -- Dictionary bindings are always VarBinds, - -- so we only need do this here - ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr - | otherwise = var - ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr - force_var = if xopt LangExt.Strict dflags - then [id] - else [] - ; return (force_var, [core_bind]) } - -dsHsBind dflags - b@(FunBind { fun_id = L _ fun, fun_matches = matches - , fun_co_fn = co_fn, fun_tick = tick }) - = do { (args, body) <- matchWrapper - (mkPrefixFunRhs (noLoc $ idName fun)) - Nothing matches - ; core_wrap <- dsHsWrapper co_fn - ; let body' = mkOptTickBox tick body - rhs = core_wrap (mkLams args body') - core_binds@(id,_) = makeCorePair dflags fun False 0 rhs - force_var - -- Bindings are strict when -XStrict is enabled - | xopt LangExt.Strict dflags - , matchGroupArity matches == 0 -- no need to force lambdas - = [id] - | isBangedBind b - = [id] - | otherwise - = [] - ; --pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun) $$ ppr (mg_alts matches) $$ ppr args $$ ppr core_binds) $ - return (force_var, [core_binds]) } - -dsHsBind dflags - (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty - , pat_ticks = (rhs_tick, var_ticks) }) - = do { body_expr <- dsGuarded grhss ty - ; let body' = mkOptTickBox rhs_tick body_expr - pat' = decideBangHood dflags pat - ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body' - -- We silently ignore inline pragmas; no makeCorePair - -- Not so cool, but really doesn't matter - ; let force_var' = if isBangedLPat pat' - then [force_var] - else [] - ; return (force_var', sel_binds) } - - -- A common case: one exported variable, only non-strict binds - -- Non-recursive bindings come through this way - -- So do self-recursive bindings - -- Bindings with complete signatures are AbsBindsSigs, below -dsHsBind dflags - (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = [export] - , abs_ev_binds = ev_binds, abs_binds = binds }) - | ABE { abe_wrap = wrap, abe_poly = global - , abe_mono = local, abe_prags = prags } <- export - , not (xopt LangExt.Strict dflags) -- Handle strict binds - , not (anyBag (isBangedBind . unLoc) binds) -- in the next case - = -- See Note [AbsBinds wrappers] in HsBinds - addDictsDs (toTcTypeBag (listToBag dicts)) $ - -- addDictsDs: push type constraints deeper for pattern match check - do { (force_vars, bind_prs) <- dsLHsBinds binds - ; let core_bind = Rec bind_prs - ; ds_binds <- dsTcEvBinds_s ev_binds - ; core_wrap <- dsHsWrapper wrap -- Usually the identity - - ; let rhs = core_wrap $ - mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_binds $ - mkLet core_bind $ - Var local - ; (spec_binds, rules) <- dsSpecs rhs prags - - ; let global' = addIdSpecialisations global rules - main_bind = makeCorePair dflags global' (isDefaultMethod prags) - (dictArity dicts) rhs - - ; ASSERT(null force_vars) - return ([], main_bind : fromOL spec_binds) } - - -- Another common case: no tyvars, no dicts - -- In this case we can have a much simpler desugaring -dsHsBind dflags - (AbsBinds { abs_tvs = [], abs_ev_vars = [] - , abs_exports = exports - , abs_ev_binds = ev_binds, abs_binds = binds }) - = do { (force_vars, bind_prs) <- dsLHsBinds binds - ; 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 - - ; ds_binds <- dsTcEvBinds_s ev_binds - ; return (force_vars, flattenBinds ds_binds ++ bind_prs ++ main_binds) } - -dsHsBind dflags - (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = exports, abs_ev_binds = ev_binds - , abs_binds = binds }) - -- See Note [Desugaring AbsBinds] - = addDictsDs (toTcTypeBag (listToBag dicts)) $ - -- addDictsDs: push type constraints deeper for pattern match check - do { (local_force_vars, bind_prs) <- dsLHsBinds binds - ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs - | (lcl_id, rhs) <- bind_prs ] - -- Monomorphic recursion possible, hence Rec - new_force_vars = get_new_force_vars local_force_vars - locals = map abe_mono exports - all_locals = locals ++ new_force_vars - tup_expr = mkBigCoreVarTup all_locals - tup_ty = exprType tup_expr - ; ds_binds <- dsTcEvBinds_s ev_binds - ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_binds $ - mkLet core_bind $ - tup_expr - - ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) - - -- Find corresponding global or make up a new one: sometimes - -- we need to make new export to desugar strict binds, see - -- Note [Desugar Strict binds] - ; (exported_force_vars, extra_exports) <- get_exports local_force_vars - - ; let mk_bind (ABE { abe_wrap = wrap - , abe_poly = global - , abe_mono = local, abe_prags = spec_prags }) - -- See Note [AbsBinds wrappers] in HsBinds - = do { tup_id <- newSysLocalDs tup_ty - ; core_wrap <- dsHsWrapper wrap - ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ - mkTupleSelector all_locals local tup_id $ - mkVarApps (Var poly_tup_id) (tyvars ++ dicts) - rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs - ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags - ; let global' = (global `setInlinePragma` defaultInlinePragma) - `addIdSpecialisations` rules - -- Kill the INLINE pragma because it applies to - -- the user written (local) function. The global - -- Id is just the selector. Hmm. - ; return ((global', rhs) : fromOL spec_binds) } - - ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) - - ; return (exported_force_vars - ,(poly_tup_id, poly_tup_rhs) : - concat export_binds_s) } - where - inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with - -- the inline pragma from the source - -- The type checker put the inline pragma - -- on the *global* Id, so we need to transfer it - inline_env - = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) - | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports - , let prag = idInlinePragma gbl_id ] - - add_inline :: Id -> Id -- tran - add_inline lcl_id = lookupVarEnv inline_env lcl_id - `orElse` lcl_id - - global_env :: IdEnv Id -- Maps local Id to its global exported Id - global_env = - mkVarEnv [ (local, global) - | ABE { abe_mono = local, abe_poly = global } <- exports - ] - - -- find variables that are not exported - get_new_force_vars lcls = - foldr (\lcl acc -> case lookupVarEnv global_env lcl of - Just _ -> acc - Nothing -> lcl:acc) - [] lcls - - -- find exports or make up new exports for force variables - get_exports :: [Id] -> DsM ([Id], [ABExport Id]) - get_exports lcls = - foldM (\(glbls, exports) lcl -> - case lookupVarEnv global_env lcl of - Just glbl -> return (glbl:glbls, exports) - Nothing -> do export <- mk_export lcl - let glbl = abe_poly export - return (glbl:glbls, export:exports)) - ([],[]) lcls - - mk_export local = - do global <- newSysLocalDs - (exprType (mkLams tyvars (mkLams dicts (Var local)))) - return (ABE {abe_poly = global - ,abe_mono = local - ,abe_wrap = WpHole - ,abe_prags = SpecPrags []}) - --- AbsBindsSig is a combination of AbsBinds and FunBind -dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_sig_export = global - , abs_sig_prags = prags - , abs_sig_ev_bind = ev_bind - , abs_sig_bind = bind }) - | L bind_loc FunBind { fun_matches = matches - , fun_co_fn = co_fn - , fun_tick = tick } <- bind - = putSrcSpanDs bind_loc $ - addDictsDs (toTcTypeBag (listToBag dicts)) $ - -- addDictsDs: push type constraints deeper for pattern match check - do { (args, body) <- matchWrapper - (mkPrefixFunRhs (noLoc $ idName global)) - Nothing matches - ; core_wrap <- dsHsWrapper co_fn - ; let body' = mkOptTickBox tick body - fun_rhs = core_wrap (mkLams args body') - force_vars - | xopt LangExt.Strict dflags - , matchGroupArity matches == 0 -- no need to force lambdas - = [global] - | isBangedBind (unLoc bind) - = [global] - | otherwise - = [] - - ; ds_binds <- dsTcEvBinds ev_bind - ; let rhs = mkLams tyvars $ - mkLams dicts $ - mkCoreLets ds_binds $ - fun_rhs - - ; (spec_binds, rules) <- dsSpecs rhs prags - ; let global' = addIdSpecialisations global rules - main_bind = makeCorePair dflags global' (isDefaultMethod prags) - (dictArity dicts) rhs - - ; return (force_vars, main_bind : fromOL spec_binds) } - - | otherwise - = pprPanic "dsHsBind: AbsBindsSig" (ppr bind) - -dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" - - - --- | This is where we apply INLINE and INLINABLE pragmas. All we need to --- do is to attach the unfolding information to the Id. --- --- Other decisions about whether to inline are made in --- `calcUnfoldingGuidance` but the decision about whether to then expose --- the unfolding in the interface file is made in `TidyPgm.addExternal` --- using this information. ------------------------- -makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) -makeCorePair dflags gbl_id is_default_method dict_arity rhs - | is_default_method -- Default methods are *always* inlined - = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) - - | otherwise - = case inlinePragmaSpec inline_prag of - EmptyInlineSpec -> (gbl_id, rhs) - NoInline -> (gbl_id, rhs) - Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) - Inline -> inline_pair - - where - inline_prag = idInlinePragma gbl_id - inlinable_unf = mkInlinableUnfolding dflags rhs - inline_pair - | Just arity <- inlinePragmaSat inline_prag - -- Add an Unfolding for an INLINE (but not for NOINLINE) - -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] - , let real_arity = dict_arity + arity - -- NB: The arity in the InlineRule takes account of the dictionaries - = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs - , etaExpand real_arity rhs) - - | otherwise - = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ - (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs) - -dictArity :: [Var] -> Arity --- Don't count coercion variables in arity -dictArity dicts = count isId dicts - -{- -Note [Desugaring AbsBinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the general AbsBinds case we desugar the binding to this: - - tup a (d:Num a) = let fm = ...gm... - gm = ...fm... - in (fm,gm) - f a d = case tup a d of { (fm,gm) -> fm } - g a d = case tup a d of { (fm,gm) -> fm } - -Note [Rules and inlining] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Common special case: no type or dictionary abstraction -This is a bit less trivial than you might suppose -The naive way woudl be to desguar to something like - f_lcl = ...f_lcl... -- The "binds" from AbsBinds - M.f = f_lcl -- Generated from "exports" -But we don't want that, because if M.f isn't exported, -it'll be inlined unconditionally at every call site (its rhs is -trivial). That would be ok unless it has RULES, which would -thereby be completely lost. Bad, bad, bad. - -Instead we want to generate - M.f = ...f_lcl... - f_lcl = M.f -Now all is cool. The RULES are attached to M.f (by SimplCore), -and f_lcl is rapidly inlined away. - -This does not happen in the same way to polymorphic binds, -because they desugar to - M.f = /\a. let f_lcl = ...f_lcl... in f_lcl -Although I'm a bit worried about whether full laziness might -float the f_lcl binding out and then inline M.f at its call site - -Note [Specialising in no-dict case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even if there are no tyvars or dicts, we may have specialisation pragmas. -Class methods can generate - AbsBinds [] [] [( ... spec-prag] - { AbsBinds [tvs] [dicts] ...blah } -So the overloading is in the nested AbsBinds. A good example is in GHC.Float: - - class (Real a, Fractional a) => RealFrac a where - round :: (Integral b) => a -> b - - instance RealFrac Float where - {-# SPECIALIZE round :: Float -> Int #-} - -The top-level AbsBinds for $cround has no tyvars or dicts (because the -instance does not). But the method is locally overloaded! - -Note [Abstracting over tyvars only] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When abstracting over type variable only (not dictionaries), we don't really need to -built a tuple and select from it, as we do in the general case. Instead we can take - - AbsBinds [a,b] [ ([a,b], fg, fl, _), - ([b], gg, gl, _) ] - { fl = e1 - gl = e2 - h = e3 } - -and desugar it to - - fg = /\ab. let B in e1 - gg = /\b. let a = () in let B in S(e2) - h = /\ab. let B in e3 - -where B is the *non-recursive* binding - fl = fg a b - gl = gg b - h = h a b -- See (b); note shadowing! - -Notice (a) g has a different number of type variables to f, so we must - use the mkArbitraryType thing to fill in the gaps. - We use a type-let to do that. - - (b) The local variable h isn't in the exports, and rather than - clone a fresh copy we simply replace h by (h a b), where - the two h's have different types! Shadowing happens here, - which looks confusing but works fine. - - (c) The result is *still* quadratic-sized if there are a lot of - small bindings. So if there are more than some small - number (10), we filter the binding set B by the free - variables of the particular RHS. Tiresome. - -Why got to this trouble? It's a common case, and it removes the -quadratic-sized tuple desugaring. Less clutter, hopefully faster -compilation, especially in a case where there are a *lot* of -bindings. - - -Note [Eta-expanding INLINE things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - foo :: Eq a => a -> a - {-# INLINE foo #-} - foo x = ... - -If (foo d) ever gets floated out as a common sub-expression (which can -happen as a result of method sharing), there's a danger that we never -get to do the inlining, which is a Terribly Bad thing given that the -user said "inline"! - -To avoid this we pre-emptively eta-expand the definition, so that foo -has the arity with which it is declared in the source code. In this -example it has arity 2 (one for the Eq and one for x). Doing this -should mean that (foo d) is a PAP and we don't share it. - -Note [Nested arities] -~~~~~~~~~~~~~~~~~~~~~ -For reasons that are not entirely clear, method bindings come out looking like -this: - - AbsBinds [] [] [$cfromT <= [] fromT] - $cfromT [InlPrag=INLINE] :: T Bool -> Bool - { AbsBinds [] [] [fromT <= [] fromT_1] - fromT :: T Bool -> Bool - { fromT_1 ((TBool b)) = not b } } } - -Note the nested AbsBind. The arity for the InlineRule on $cfromT should be -gotten from the binding for fromT_1. - -It might be better to have just one level of AbsBinds, but that requires more -thought! - - -Note [Desugar Strict binds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Desugaring strict variable bindings looks as follows (core below ==>) - - let !x = rhs - in body -==> - let x = rhs - in x `seq` body -- seq the variable - -and if it is a pattern binding the desugaring looks like - - let !pat = rhs - in body -==> - let x = rhs -- bind the rhs to a new variable - pat = x - in x `seq` body -- seq the new variable - -if there is no variable in the pattern desugaring looks like - - let False = rhs - in body -==> - let x = case rhs of {False -> (); _ -> error "Match failed"} - in x `seq` body - -In order to force the Ids in the binding group they are passed around -in the dsHsBind family of functions, and later seq'ed in DsExpr.ds_val_bind. - -Consider a recursive group like this - - letrec - f : g = rhs[f,g] - in - -Without `Strict`, we get a translation like this: - - let t = /\a. letrec tm = rhs[fm,gm] - fm = case t of fm:_ -> fm - gm = case t of _:gm -> gm - in - (fm,gm) - - in let f = /\a. case t a of (fm,_) -> fm - in let g = /\a. case t a of (_,gm) -> gm - in - -Here `tm` is the monomorphic binding for `rhs`. - -With `Strict`, we want to force `tm`, but NOT `fm` or `gm`. -Alas, `tm` isn't in scope in the `in ` part. - -The simplest thing is to return it in the polymorphic -tuple `t`, thus: - - let t = /\a. letrec tm = rhs[fm,gm] - fm = case t of fm:_ -> fm - gm = case t of _:gm -> gm - in - (tm, fm, gm) - - in let f = /\a. case t a of (_,fm,_) -> fm - in let g = /\a. case t a of (_,_,gm) -> gm - in let tm = /\a. case t a of (tm,_,_) -> tm - in tm `seq` - - -See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma for a more -detailed explanation of the desugaring of strict bindings. - -Note [Strict binds checks] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several checks around properly formed strict bindings. They -all link to this Note. These checks must be here in the desugarer because -we cannot know whether or not a type is unlifted until after zonking, due -to levity polymorphism. These checks all used to be handled in the typechecker -in checkStrictBinds (before Jan '17). - -We define an "unlifted bind" to be any bind that binds an unlifted id. Note that - - x :: Char - (# True, x #) = blah - -is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind. - -Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind. -Define a "strict bind" to be either an unlifted bind or a banged bind. - -The restrictions are: - 1. Strict binds may not be top-level. Checked in dsTopLHsBinds. - - 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged - unlifted bind, but an unbanged bind looks lazy, and we don't want users to be - surprised by the strictness of an unlifted bind.) Checked in first clause - of DsExpr.ds_val_bind. - - 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type - variables or constraints.) Checked in first clause - of DsExpr.ds_val_bind. - - 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind. - --} - ------------------------- -dsSpecs :: CoreExpr -- Its rhs - -> TcSpecPrags - -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids - , [CoreRule] ) -- Rules for the Global Ids --- See Note [Handling SPECIALISE pragmas] in TcBinds -dsSpecs _ IsDefaultMethod = return (nilOL, []) -dsSpecs poly_rhs (SpecPrags sps) - = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps - ; let (spec_binds_s, rules) = unzip pairs - ; return (concatOL spec_binds_s, rules) } - -dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding - -- Nothing => RULE is for an imported Id - -- rhs is in the Id's unfolding - -> Located TcSpecPrag - -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) -dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) - | isJust (isClassOpId_maybe poly_id) - = putSrcSpanDs loc $ - do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector" - <+> quotes (ppr poly_id)) - ; return Nothing } -- There is no point in trying to specialise a class op - -- Moreover, classops don't (currently) have an inl_sat arity set - -- (it would be Just 0) and that in turn makes makeCorePair bleat - - | no_act_spec && isNeverActive rule_act - = putSrcSpanDs loc $ - do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" - <+> quotes (ppr poly_id)) - ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that - -- See Note [Activation pragmas for SPECIALISE] - - | otherwise - = putSrcSpanDs loc $ - do { uniq <- newUnique - ; let poly_name = idName poly_id - spec_occ = mkSpecOcc (getOccName poly_name) - spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name) - (spec_bndrs, spec_app) = collectHsWrapBinders spec_co - -- spec_co looks like - -- \spec_bndrs. [] spec_args - -- perhaps with the body of the lambda wrapped in some WpLets - -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2 - - ; core_app <- dsHsWrapper spec_app - - ; let ds_lhs = core_app (Var poly_id) - spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs) - ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id - -- , text "spec_co:" <+> ppr spec_co - -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ - case decomposeRuleLhs spec_bndrs ds_lhs of { - Left msg -> do { warnDs NoReason msg; return Nothing } ; - Right (rule_bndrs, _fn, args) -> do - - { dflags <- getDynFlags - ; this_mod <- getModule - ; let fn_unf = realIdUnfolding poly_id - spec_unf = specUnfolding spec_bndrs core_app arity_decrease fn_unf - spec_id = mkLocalId spec_name spec_ty - `setInlinePragma` inl_prag - `setIdUnfolding` spec_unf - arity_decrease = count isValArg args - count isId spec_bndrs - - ; rule <- dsMkUserRule this_mod is_local_id - (mkFastString ("SPEC " ++ showPpr dflags poly_name)) - rule_act poly_name - rule_bndrs args - (mkVarApps (Var spec_id) spec_bndrs) - - ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs) - --- Commented out: see Note [SPECIALISE on INLINE functions] --- ; when (isInlinePragma id_inl) --- (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:" --- <+> quotes (ppr poly_name)) - - ; return (Just (unitOL (spec_id, spec_rhs), rule)) - -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because - -- makeCorePair overwrites the unfolding, which we have - -- just created using specUnfolding - } } } - where - is_local_id = isJust mb_poly_rhs - poly_rhs | Just rhs <- mb_poly_rhs - = rhs -- Local Id; this is its rhs - | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id) - = unfolding -- Imported Id; this is its unfolding - -- Use realIdUnfolding so we get the unfolding - -- even when it is a loop breaker. - -- We want to specialise recursive functions! - | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) - -- The type checker has checked that it *has* an unfolding - - id_inl = idInlinePragma poly_id - - -- See Note [Activation pragmas for SPECIALISE] - inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl - | not is_local_id -- See Note [Specialising imported functions] - -- in OccurAnal - , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma - | otherwise = id_inl - -- Get the INLINE pragma from SPECIALISE declaration, or, - -- failing that, from the original Id - - spec_prag_act = inlinePragmaActivation spec_inl - - -- See Note [Activation pragmas for SPECIALISE] - -- no_act_spec is True if the user didn't write an explicit - -- phase specification in the SPECIALISE pragma - no_act_spec = case inlinePragmaSpec spec_inl of - NoInline -> isNeverActive spec_prag_act - _ -> isAlwaysActive spec_prag_act - rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit - | otherwise = spec_prag_act -- Specified by user - - -dsMkUserRule :: Module -> Bool -> RuleName -> Activation - -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule -dsMkUserRule this_mod is_local name act fn bndrs args rhs = do - let rule = mkRule this_mod False is_local name act fn bndrs args rhs - dflags <- getDynFlags - when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $ - warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule) - return rule - -ruleOrphWarn :: CoreRule -> SDoc -ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule - -{- Note [SPECIALISE on INLINE functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to warn that using SPECIALISE for a function marked INLINE -would be a no-op; but it isn't! Especially with worker/wrapper split -we might have - {-# INLINE f #-} - f :: Ord a => Int -> a -> ... - f d x y = case x of I# x' -> $wf d x' y - -We might want to specialise 'f' so that we in turn specialise '$wf'. -We can't even /name/ '$wf' in the source code, so we can't specialise -it even if we wanted to. Trac #10721 is a case in point. - -Note [Activation pragmas for SPECIALISE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -From a user SPECIALISE pragma for f, we generate - a) A top-level binding spec_fn = rhs - b) A RULE f dOrd = spec_fn - -We need two pragma-like things: - -* spec_fn's inline pragma: inherited from f's inline pragma (ignoring - activation on SPEC), unless overriden by SPEC INLINE - -* Activation of RULE: from SPECIALISE pragma (if activation given) - otherwise from f's inline pragma - -This is not obvious (see Trac #5237)! - -Examples Rule activation Inline prag on spec'd fn ---------------------------------------------------------------------- -SPEC [n] f :: ty [n] Always, or NOINLINE [n] - copy f's prag - -NOINLINE f -SPEC [n] f :: ty [n] NOINLINE - copy f's prag - -NOINLINE [k] f -SPEC [n] f :: ty [n] NOINLINE [k] - copy f's prag - -INLINE [k] f -SPEC [n] f :: ty [n] INLINE [k] - copy f's prag - -SPEC INLINE [n] f :: ty [n] INLINE [n] - (ignore INLINE prag on f, - same activation for rule and spec'd fn) - -NOINLINE [k] f -SPEC f :: ty [n] INLINE [k] - - -************************************************************************ -* * -\subsection{Adding inline pragmas} -* * -************************************************************************ --} - -decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr]) --- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, --- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs --- may add some extra dictionary binders (see Note [Free dictionaries]) --- --- Returns an error message if the LHS isn't of the expected shape --- Note [Decomposing the left-hand side of a RULE] -decomposeRuleLhs orig_bndrs orig_lhs - | not (null unbound) -- Check for things unbound on LHS - -- See Note [Unused spec binders] - = Left (vcat (map dead_msg unbound)) - | Var funId <- fun2 - , Just con <- isDataConId_maybe funId - = Left (constructor_msg con) -- See Note [No RULES on datacons] - | Just (fn_id, args) <- decompose fun2 args2 - , let extra_bndrs = mk_extra_bndrs fn_id args - = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs - -- , text "orig_lhs:" <+> ppr orig_lhs - -- , text "lhs1:" <+> ppr lhs1 - -- , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs - -- , text "fn_id:" <+> ppr fn_id - -- , text "args:" <+> ppr args]) $ - Right (orig_bndrs ++ extra_bndrs, fn_id, args) - - | otherwise - = Left bad_shape_msg - where - lhs1 = drop_dicts orig_lhs - lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS] - (fun2,args2) = collectArgs lhs2 - - lhs_fvs = exprFreeVars lhs2 - unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs - - orig_bndr_set = mkVarSet orig_bndrs - - -- Add extra tyvar binders: Note [Free tyvars in rule LHS] - -- and extra dict binders: Note [Free dictionaries in rule LHS] - mk_extra_bndrs fn_id args - = toposortTyVars unbound_tvs ++ unbound_dicts - where - unbound_tvs = [ v | v <- unbound_vars, isTyVar v ] - unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d) - | d <- unbound_vars, isDictId d ] - unbound_vars = [ v | v <- exprsFreeVarsList args - , not (v `elemVarSet` orig_bndr_set) - , not (v == fn_id) ] - -- fn_id: do not quantify over the function itself, which may - -- itself be a dictionary (in pathological cases, Trac #10251) - - decompose (Var fn_id) args - | not (fn_id `elemVarSet` orig_bndr_set) - = Just (fn_id, args) - - decompose _ _ = Nothing - - bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar") - 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 - , text "Orig lhs:" <+> ppr orig_lhs]) - dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr - , text "is not bound in RULE lhs"]) - 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs - , text "Orig lhs:" <+> ppr orig_lhs - , text "optimised lhs:" <+> ppr lhs2 ]) - pp_bndr bndr - | isTyVar bndr = text "type variable" <+> quotes (ppr bndr) - | Just pred <- evVarPred_maybe bndr = text "constraint" <+> quotes (ppr pred) - | otherwise = text "variable" <+> quotes (ppr bndr) - - constructor_msg con = vcat - [ text "A constructor," <+> ppr con <> - text ", appears as outermost match in RULE lhs." - , text "This rule will be ignored." ] - - drop_dicts :: CoreExpr -> CoreExpr - drop_dicts e - = wrap_lets needed bnds body - where - needed = orig_bndr_set `minusVarSet` exprFreeVars body - (bnds, body) = split_lets (occurAnalyseExpr e) - -- The occurAnalyseExpr drops dead bindings which is - -- crucial to ensure that every binding is used later; - -- which in turn makes wrap_lets work right - - split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) - split_lets (Let (NonRec d r) body) - | isDictId d - = ((d,r):bs, body') - where (bs, body') = split_lets body - - -- handle "unlifted lets" too, needed for "map/coerce" - split_lets (Case r d _ [(DEFAULT, _, body)]) - | isCoVar d - = ((d,r):bs, body') - where (bs, body') = split_lets body - - split_lets e = ([], e) - - wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr - wrap_lets _ [] body = body - wrap_lets needed ((d, r) : bs) body - | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body) - | otherwise = wrap_lets needed bs body - where - rhs_fvs = exprFreeVars r - needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d - -{- -Note [Decomposing the left-hand side of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several things going on here. -* drop_dicts: see Note [Drop dictionary bindings on rule LHS] -* simpleOptExpr: see Note [Simplify rule LHS] -* extra_dict_bndrs: see Note [Free dictionaries] - -Note [Free tyvars on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = C - - foo :: T a -> Int - foo C = 1 - - {-# RULES "myrule" foo C = 1 #-} - -After type checking the LHS becomes (foo alpha (C alpha)), where alpha -is an unbound meta-tyvar. The zonker in TcHsSyn is careful not to -turn the free alpha into Any (as it usually does). Instead it turns it -into a TyVar 'a'. See TcHsSyn Note [Zonking the LHS of a RULE]. - -Now we must quantify over that 'a'. It's /really/ inconvenient to do that -in the zonker, because the HsExpr data type is very large. But it's /easy/ -to do it here in the desugarer. - -Moreover, we have to do something rather similar for dictionaries; -see Note [Free dictionaries on rule LHS]. So that's why we look for -type variables free on the LHS, and quantify over them. - -Note [Free dictionaries on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, -which is presumably in scope at the function definition site, we can quantify -over it too. *Any* dict with that type will do. - -So for example when you have - f :: Eq a => a -> a - f = - ... SPECIALISE f :: Int -> Int ... - -Then we get the SpecPrag - SpecPrag (f Int dInt) - -And from that we want the rule - - RULE forall dInt. f Int dInt = f_spec - f_spec = let f = in f Int dInt - -But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External -Name, and you can't bind them in a lambda or forall without getting things -confused. Likewise it might have an InlineRule or something, which would be -utterly bogus. So we really make a fresh Id, with the same unique and type -as the old one, but with an Internal name and no IdInfo. - -Note [Drop dictionary bindings on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -drop_dicts drops dictionary bindings on the LHS where possible. - E.g. let d:Eq [Int] = $fEqList $fEqInt in f d - --> f d - Reasoning here is that there is only one d:Eq [Int], and so we can - quantify over it. That makes 'd' free in the LHS, but that is later - picked up by extra_dict_bndrs (Note [Dead spec binders]). - - NB 1: We can only drop the binding if the RHS doesn't bind - one of the orig_bndrs, which we assume occur on RHS. - Example - f :: (Eq a) => b -> a -> a - {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-} - Here we want to end up with - RULE forall d:Eq a. f ($dfEqList d) = f_spec d - Of course, the ($dfEqlist d) in the pattern makes it less likely - to match, but there is no other way to get d:Eq a - - NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all - the evidence bindings to be wrapped around the outside of the - LHS. (After simplOptExpr they'll usually have been inlined.) - dsHsWrapper does dependency analysis, so that civilised ones - will be simple NonRec bindings. We don't handle recursive - dictionaries! - - NB3: In the common case of a non-overloaded, but perhaps-polymorphic - specialisation, we don't need to bind *any* dictionaries for use - in the RHS. For example (Trac #8331) - {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-} - useAbstractMonad :: MonadAbstractIOST m => m Int - Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code - but the RHS uses no dictionaries, so we want to end up with - RULE forall s (d :: MonadAbstractIOST (ReaderT s)). - useAbstractMonad (ReaderT s) d = $suseAbstractMonad s - - Trac #8848 is a good example of where there are some intersting - dictionary bindings to discard. - -The drop_dicts algorithm is based on these observations: - - * Given (let d = rhs in e) where d is a DictId, - matching 'e' will bind e's free variables. - - * So we want to keep the binding if one of the needed variables (for - which we need a binding) is in fv(rhs) but not already in fv(e). - - * The "needed variables" are simply the orig_bndrs. Consider - f :: (Eq a, Show b) => a -> b -> String - ... SPECIALISE f :: (Show b) => Int -> b -> String ... - Then orig_bndrs includes the *quantified* dictionaries of the type - namely (dsb::Show b), but not the one for Eq Int - -So we work inside out, applying the above criterion at each step. - - -Note [Simplify rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~ -simplOptExpr occurrence-analyses and simplifies the LHS: - - (a) Inline any remaining dictionary bindings (which hopefully - occur just once) - - (b) Substitute trivial lets, so that they don't get in the way. - Note that we substitute the function too; we might - have this as a LHS: let f71 = M.f Int in f71 - - (c) Do eta reduction. To see why, consider the fold/build rule, - which without simplification looked like: - fold k z (build (/\a. g a)) ==> ... - This doesn't match unless you do eta reduction on the build argument. - Similarly for a LHS like - augment g (build h) - we do not want to get - augment (\a. g a) (build h) - otherwise we don't match when given an argument like - augment (\a. h a a) (build h) - -Note [Matching seqId] -~~~~~~~~~~~~~~~~~~~ -The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack -and this code turns it back into an application of seq! -See Note [Rules for seq] in MkId for the details. - -Note [Unused spec binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: a -> a - ... SPECIALISE f :: Eq a => a -> a ... -It's true that this *is* a more specialised type, but the rule -we get is something like this: - f_spec d = f - RULE: f = f_spec d -Note that the rule is bogus, because it mentions a 'd' that is -not bound on the LHS! But it's a silly specialisation anyway, because -the constraint is unused. We could bind 'd' to (error "unused") -but it seems better to reject the program because it's almost certainly -a mistake. That's what the isDeadBinder call detects. - -Note [No RULES on datacons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Previously, `RULES` like - - "JustNothing" forall x . Just x = Nothing - -were allowed. Simon Peyton Jones says this seems to have been a -mistake, that such rules have never been supported intentionally, -and that he doesn't know if they can break in horrible ways. -Furthermore, Ben Gamari and Reid Barton are considering trying to -detect the presence of "static data" that the simplifier doesn't -need to traverse at all. Such rules do not play well with that. -So for now, we ban them altogether as requested by #13290. See also #7398. - - -************************************************************************ -* * - Desugaring evidence -* * -************************************************************************ - --} - -dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) -dsHsWrapper WpHole = return $ \e -> e -dsHsWrapper (WpTyApp ty) = return $ \e -> App e (Type ty) -dsHsWrapper (WpEvLam ev) = return $ Lam ev -dsHsWrapper (WpTyLam tv) = return $ Lam tv -dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds - ; return (mkCoreLets bs) } -dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 - ; w2 <- dsHsWrapper c2 - ; return (w1 . w2) } - -- See comments on WpFun in TcEvidence for an explanation of what - -- the specification of this clause is -dsHsWrapper (WpFun c1 c2 t1 doc) - = do { x <- newSysLocalDsNoLP t1 - ; w1 <- dsHsWrapper c1 - ; w2 <- dsHsWrapper c2 - ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a - arg = w1 (Var x) - ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc - ; if ok - then return (\e -> (Lam x (w2 (app e arg)))) - else return id } -- this return is irrelevant -dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational) - return $ \e -> mkCastDs e co -dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm - ; return (\e -> App e core_tm) } - --------------------------------------- -dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] -dsTcEvBinds_s [] = return [] -dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null - dsTcEvBinds b - -dsTcEvBinds :: TcEvBinds -> DsM [CoreBind] -dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this -dsTcEvBinds (EvBinds bs) = dsEvBinds bs - -dsEvBinds :: Bag EvBind -> DsM [CoreBind] -dsEvBinds bs = mapM ds_scc (sccEvBinds bs) - where - ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r})) - = liftM (NonRec v) (dsEvTerm r) - ds_scc (CyclicSCC bs) = liftM Rec (mapM dsEvBind bs) - -dsEvBind :: EvBind -> DsM (Id, CoreExpr) -dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) - -{-********************************************************************** -* * - Desugaring EvTerms -* * -**********************************************************************-} - -dsEvTerm :: EvTerm -> DsM CoreExpr -dsEvTerm (EvId v) = return (Var v) -dsEvTerm (EvCallStack cs) = dsEvCallStack cs -dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev -dsEvTerm (EvLit (EvNum n)) = mkNaturalExpr n -dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s - -dsEvTerm (EvCast tm co) - = do { tm' <- dsEvTerm tm - ; return $ mkCastDs tm' co } - -dsEvTerm (EvDFunApp df tys tms) - = do { tms' <- mapM dsEvTerm tms - ; return $ Var df `mkTyApps` tys `mkApps` tms' } - -- The use of mkApps here is OK vis-a-vis levity polymorphism because - -- the terms are always evidence variables with types of kind Constraint - -dsEvTerm (EvCoercion co) = return (Coercion co) -dsEvTerm (EvSuperClass d n) - = do { d' <- dsEvTerm d - ; let (cls, tys) = getClassPredTys (exprType d') - sc_sel_id = classSCSelId cls n -- Zero-indexed - ; return $ Var sc_sel_id `mkTyApps` tys `App` d' } - -dsEvTerm (EvSelector sel_id tys tms) - = do { tms' <- mapM dsEvTerm tms - ; return $ Var sel_id `mkTyApps` tys `mkApps` tms' } - -dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg - -dsEvDelayedError :: Type -> FastString -> CoreExpr -dsEvDelayedError ty msg - = Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg] - where - errorId = tYPE_ERROR_ID - litMsg = Lit (MachStr (fastStringToByteString msg)) - -{-********************************************************************** -* * - Desugaring Typeable dictionaries -* * -**********************************************************************-} - -dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr --- Return a CoreExpr :: Typeable ty --- This code is tightly coupled to the representation --- of TypeRep, in base library Data.Typeable.Internals -dsEvTypeable ty ev - = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable - ; let kind = typeKind ty - Just typeable_data_con - = tyConSingleDataCon_maybe tyCl -- "Data constructor" - -- for Typeable - - ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a - - -- Package up the method as `Typeable` dictionary - ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] } - -type TypeRepExpr = CoreExpr - --- | Returns a @CoreExpr :: TypeRep ty@ -ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr -ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) - = do { mkTrCon <- dsLookupGlobalId mkTrConName - -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a - ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName - ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName - -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep - - ; tc_rep <- tyConRep tc -- :: TyCon - ; let ks = tyConAppArgs ty - -- Construct a SomeTypeRep - toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr - toSomeTypeRep t ev = do - rep <- getRep ev t - return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep] - ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev -- :: TypeRep t - ; let -- :: [SomeTypeRep] - kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps - - -- Note that we use the kind of the type, not the TyCon from which it - -- is constructed since the latter may be kind polymorphic whereas the - -- former we know is not (we checked in the solver). - ; return $ mkApps (Var mkTrCon) [ Type (typeKind ty) - , Type ty - , tc_rep - , kind_args ] - } - -ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) - | Just (t1,t2) <- splitAppTy_maybe ty - = do { e1 <- getRep ev1 t1 - ; e2 <- getRep ev2 t2 - ; mkTrApp <- dsLookupGlobalId mkTrAppName - -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). - -- TypeRep a -> TypeRep b -> TypeRep (a b) - ; let (k1, k2) = splitFunTy (typeKind t1) - ; return $ mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) - [ e1, e2 ] } - -ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) - | Just (t1,t2) <- splitFunTy_maybe ty - = do { e1 <- getRep ev1 t1 - ; e2 <- getRep ev2 t2 - ; mkTrFun <- dsLookupGlobalId mkTrFunName - -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). - -- TypeRep a -> TypeRep b -> TypeRep (a -> b) - ; let r1 = getRuntimeRep t1 - r2 = getRuntimeRep t2 - ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2]) - [ e1, e2 ] - } - -ds_ev_typeable ty (EvTypeableTyLit ev) - = do { fun <- dsLookupGlobalId tr_fun - ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSym - ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty] - ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) } - where - ty_kind = typeKind ty - - -- tr_fun is the Name of - -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a - -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a - tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName - | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName - | otherwise = panic "dsEvTypeable: unknown type lit kind" - -ds_ev_typeable ty ev - = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev) - -getRep :: EvTerm -- ^ EvTerm for @Typeable ty@ - -> Type -- ^ The type @ty@ - -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@ - -- namely @typeRep# dict@ --- Remember that --- typeRep# :: forall k (a::k). Typeable k a -> TypeRep a -getRep ev ty - = do { typeable_expr <- dsEvTerm ev - ; typeRepId <- dsLookupGlobalId typeRepIdName - ; let ty_args = [typeKind ty, ty] - ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) } - -tyConRep :: TyCon -> DsM CoreExpr --- Returns CoreExpr :: TyCon -tyConRep tc - | Just tc_rep_nm <- tyConRepName_maybe tc - = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm - ; return (Var tc_rep_id) } - | otherwise - = pprPanic "tyConRep" (ppr tc) - -{- Note [Memoising typeOf] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #3245, #9203 - -IMPORTANT: we don't want to recalculate the TypeRep once per call with -the proxy argument. This is what went wrong in #3245 and #9203. So we -help GHC by manually keeping the 'rep' *outside* the lambda. --} - - -{-********************************************************************** -* * - Desugaring EvCallStack evidence -* * -**********************************************************************-} - -dsEvCallStack :: EvCallStack -> DsM CoreExpr --- See Note [Overview of implicit CallStacks] in TcEvidence.hs -dsEvCallStack cs = do - df <- getDynFlags - m <- getModule - srcLocDataCon <- dsLookupDataCon srcLocDataConName - let mkSrcLoc l = - liftM (mkCoreConApps srcLocDataCon) - (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m) - , mkStringExprFS (moduleNameFS $ moduleName m) - , mkStringExprFS (srcSpanFile l) - , return $ mkIntExprInt df (srcSpanStartLine l) - , return $ mkIntExprInt df (srcSpanStartCol l) - , return $ mkIntExprInt df (srcSpanEndLine l) - , return $ mkIntExprInt df (srcSpanEndCol l) - ]) - - emptyCS <- Var <$> dsLookupGlobalId emptyCallStackName - - pushCSVar <- dsLookupGlobalId pushCallStackName - let pushCS name loc rest = - mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest] - - let mkPush name loc tm = do - nameExpr <- mkStringExprFS name - locExpr <- mkSrcLoc loc - case tm of - EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS) - _ -> do tmExpr <- dsEvTerm tm - -- at this point tmExpr :: IP sym CallStack - -- but we need the actual CallStack to pass to pushCS, - -- so we use unwrapIP to strip the dictionary wrapper - -- See Note [Overview of implicit CallStacks] - let ip_co = unwrapIP (exprType tmExpr) - return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co)) - case cs of - EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm - EvCsEmpty -> return emptyCS diff --git a/deSugar/DsCCall.hs b/deSugar/DsCCall.hs deleted file mode 100644 --- a/deSugar/DsCCall.hs +++ /dev/null @@ -1,377 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - - -Desugaring foreign calls --} - -{-# LANGUAGE CPP #-} -module DsCCall - ( dsCCall - , mkFCall - , unboxArg - , boxResult - , resultWrapper - ) where - -#include "HsVersions.h" - - -import CoreSyn - -import DsMonad -import CoreUtils -import MkCore -import MkId -import ForeignCall -import DataCon -import DsUtils - -import TcType -import Type -import Id ( Id ) -import Coercion -import PrimOp -import TysPrim -import TyCon -import TysWiredIn -import BasicTypes -import Literal -import PrelNames -import DynFlags -import Outputable -import Util - -import Data.Maybe - -{- -Desugaring of @ccall@s consists of adding some state manipulation, -unboxing any boxed primitive arguments and boxing the result if -desired. - -The state stuff just consists of adding in -@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place. - -The unboxing is straightforward, as all information needed to unbox is -available from the type. For each boxed-primitive argument, we -transform: -\begin{verbatim} - _ccall_ foo [ r, t1, ... tm ] e1 ... em - | - | - V - case e1 of { T1# x1# -> - ... - case em of { Tm# xm# -> xm# - ccall# foo [ r, t1#, ... tm# ] x1# ... xm# - } ... } -\end{verbatim} - -The reboxing of a @_ccall_@ result is a bit tricker: the types don't -contain information about the state-pairing functions so we have to -keep a list of \tr{(type, s-p-function)} pairs. We transform as -follows: -\begin{verbatim} - ccall# foo [ r, t1#, ... tm# ] e1# ... em# - | - | - V - \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of - (StateAnd# result# state#) -> (R# result#, realWorld#) -\end{verbatim} --} - -dsCCall :: CLabelString -- C routine to invoke - -> [CoreExpr] -- Arguments (desugared) - -- Precondition: none have levity-polymorphic types - -> Safety -- Safety of the call - -> Type -- Type of the result: IO t - -> DsM CoreExpr -- Result, of type ??? - -dsCCall lbl args may_gc result_ty - = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args - (ccall_result_ty, res_wrapper) <- boxResult result_ty - uniq <- newUnique - dflags <- getDynFlags - let - target = StaticTarget NoSourceText lbl Nothing True - the_fcall = CCall (CCallSpec target CCallConv may_gc) - the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty - return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) - -mkFCall :: DynFlags -> Unique -> ForeignCall - -> [CoreExpr] -- Args - -> Type -- Result type - -> CoreExpr --- Construct the ccall. The only tricky bit is that the ccall Id should have --- no free vars, so if any of the arg tys do we must give it a polymorphic type. --- [I forget *why* it should have no free vars!] --- For example: --- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char] --- --- Here we build a ccall thus --- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) --- a b s x c -mkFCall dflags uniq the_fcall val_args res_ty - = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level - mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args - where - arg_tys = map exprType val_args - body_ty = (mkFunTys arg_tys res_ty) - tyvars = tyCoVarsOfTypeWellScoped body_ty - ty = mkInvForAllTys tyvars body_ty - the_fcall_id = mkFCallId dflags uniq the_fcall ty - -unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic - -> DsM (CoreExpr, -- To pass as the actual argument - CoreExpr -> CoreExpr -- Wrapper to unbox the arg - ) --- Example: if the arg is e::Int, unboxArg will return --- (x#::Int#, \W. case x of I# x# -> W) --- where W is a CoreExpr that probably mentions x# - --- always returns a non-levity-polymorphic expression - -unboxArg arg - -- Primtive types: nothing to unbox - | isPrimitiveType arg_ty - = return (arg, \body -> body) - - -- Recursive newtypes - | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty - = unboxArg (mkCastDs arg co) - - -- Booleans - | Just tc <- tyConAppTyCon_maybe arg_ty, - tc `hasKey` boolTyConKey - = do dflags <- getDynFlags - prim_arg <- newSysLocalDs intPrimTy - return (Var prim_arg, - \ body -> Case (mkWildCase arg arg_ty intPrimTy - [(DataAlt falseDataCon,[],mkIntLit dflags 0), - (DataAlt trueDataCon, [],mkIntLit dflags 1)]) - -- In increasing tag order! - prim_arg - (exprType body) - [(DEFAULT,[],body)]) - - -- Data types with a single constructor, which has a single, primitive-typed arg - -- This deals with Int, Float etc; also Ptr, ForeignPtr - | is_product_type && data_con_arity == 1 - = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty) - -- Typechecker ensures this - do case_bndr <- newSysLocalDs arg_ty - prim_arg <- newSysLocalDs data_con_arg_ty1 - return (Var prim_arg, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] - ) - - -- Byte-arrays, both mutable and otherwise; hack warning - -- We're looking for values of type ByteArray, MutableByteArray - -- data ByteArray ix = ByteArray ix ix ByteArray# - -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) - | is_product_type && - data_con_arity == 3 && - isJust maybe_arg3_tycon && - (arg3_tycon == byteArrayPrimTyCon || - arg3_tycon == mutableByteArrayPrimTyCon) - = do case_bndr <- newSysLocalDs arg_ty - vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys - return (Var arr_cts_var, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] - ) - - | otherwise - = do l <- getSrcSpanDs - pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) - where - arg_ty = exprType arg - maybe_product_type = splitDataProductType_maybe arg_ty - is_product_type = isJust maybe_product_type - Just (_, _, data_con, data_con_arg_tys) = maybe_product_type - data_con_arity = dataConSourceArity data_con - (data_con_arg_ty1 : _) = data_con_arg_tys - - (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys - maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3 - Just arg3_tycon = maybe_arg3_tycon - -boxResult :: Type - -> DsM (Type, CoreExpr -> CoreExpr) - --- Takes the result of the user-level ccall: --- either (IO t), --- or maybe just t for an side-effect-free call --- Returns a wrapper for the primitive ccall itself, along with the --- type of the result of the primitive ccall. This result type --- will be of the form --- State# RealWorld -> (# State# RealWorld, t' #) --- where t' is the unwrapped form of t. If t is simply (), then --- the result type will be --- State# RealWorld -> (# State# RealWorld #) - -boxResult result_ty - | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty - -- isIOType_maybe handles the case where the type is a - -- simple wrapping of IO. E.g. - -- newtype Wrap a = W (IO a) - -- No coercion necessary because its a non-recursive newtype - -- (If we wanted to handle a *recursive* newtype too, we'd need - -- another case, and a coercion.) - -- The result is IO t, so wrap the result in an IO constructor - = do { res <- resultWrapper io_res_ty - ; let extra_result_tys - = case res of - (Just ty,_) - | isUnboxedTupleType ty - -> let Just ls = tyConAppArgs_maybe ty in tail ls - _ -> [] - - return_result state anss - = mkCoreUbxTup - (realWorldStatePrimTy : io_res_ty : extra_result_tys) - (state : anss) - - ; (ccall_res_ty, the_alt) <- mk_alt return_result res - - ; state_id <- newSysLocalDs realWorldStatePrimTy - ; let io_data_con = head (tyConDataCons io_tycon) - toIOCon = dataConWrapId io_data_con - - wrap the_call = - mkApps (Var toIOCon) - [ Type io_res_ty, - Lam state_id $ - mkWildCase (App the_call (Var state_id)) - ccall_res_ty - (coreAltType the_alt) - [the_alt] - ] - - ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) } - -boxResult result_ty - = do -- It isn't IO, so do unsafePerformIO - -- It's not conveniently available, so we inline it - res <- resultWrapper result_ty - (ccall_res_ty, the_alt) <- mk_alt return_result res - let - wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) - ccall_res_ty - (coreAltType the_alt) - [the_alt] - return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) - where - return_result _ [ans] = ans - return_result _ _ = panic "return_result: expected single result" - - -mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) - -> (Maybe Type, Expr Var -> Expr Var) - -> DsM (Type, (AltCon, [Id], Expr Var)) -mk_alt return_result (Nothing, wrap_result) - = do -- The ccall returns () - state_id <- newSysLocalDs realWorldStatePrimTy - let - the_rhs = return_result (Var state_id) - [wrap_result (panic "boxResult")] - - ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] - the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs) - - return (ccall_res_ty, the_alt) - -mk_alt return_result (Just prim_res_ty, wrap_result) - = -- The ccall returns a non-() value - ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty ) - -- True because resultWrapper ensures it is so - do { result_id <- newSysLocalDs prim_res_ty - ; state_id <- newSysLocalDs realWorldStatePrimTy - ; let the_rhs = return_result (Var state_id) - [wrap_result (Var result_id)] - ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] - the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs) - ; return (ccall_res_ty, the_alt) } - - -resultWrapper :: Type - -> DsM (Maybe Type, -- Type of the expected result, if any - CoreExpr -> CoreExpr) -- Wrapper for the result --- resultWrapper deals with the result *value* --- E.g. foreign import foo :: Int -> IO T --- Then resultWrapper deals with marshalling the 'T' part --- So if resultWrapper ty = (Just ty_rep, marshal) --- then marshal (e :: ty_rep) :: ty --- That is, 'marshal' wrape the result returned by the foreign call, --- of type ty_rep, into the value Haskell expected, of type 'ty' --- --- Invariant: ty_rep is always a primitive type --- i.e. (isPrimitiveType ty_rep) is True - -resultWrapper result_ty - -- Base case 1: primitive types - | isPrimitiveType result_ty - = return (Just result_ty, \e -> e) - - -- Base case 2: the unit type () - | Just (tc,_) <- maybe_tc_app - , tc `hasKey` unitTyConKey - = return (Nothing, \_ -> Var unitDataConId) - - -- Base case 3: the boolean type - | Just (tc,_) <- maybe_tc_app - , tc `hasKey` boolTyConKey - = do { dflags <- getDynFlags - ; let marshal_bool e - = mkWildCase e intPrimTy boolTy - [ (DEFAULT ,[],Var trueDataConId ) - , (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)] - ; return (Just intPrimTy, marshal_bool) } - - -- Newtypes - | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty - = do { (maybe_ty, wrapper) <- resultWrapper rep_ty - ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) } - - -- The type might contain foralls (eg. for dummy type arguments, - -- referring to 'Ptr a' is legal). - | Just (tyvar, rest) <- splitForAllTy_maybe result_ty - = do { (maybe_ty, wrapper) <- resultWrapper rest - ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) } - - -- Data types with a single constructor, which has a single arg - -- This includes types like Ptr and ForeignPtr - | Just (tycon, tycon_arg_tys) <- maybe_tc_app - , Just data_con <- isDataProductTyCon_maybe tycon -- One construtor, no existentials - , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument - = do { dflags <- getDynFlags - ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty - ; let narrow_wrapper = maybeNarrow dflags tycon - marshal_con e = Var (dataConWrapId data_con) - `mkTyApps` tycon_arg_tys - `App` wrapper (narrow_wrapper e) - ; return (maybe_ty, marshal_con) } - - | otherwise - = pprPanic "resultWrapper" (ppr result_ty) - where - maybe_tc_app = splitTyConApp_maybe result_ty - --- When the result of a foreign call is smaller than the word size, we --- need to sign- or zero-extend the result up to the word size. The C --- standard appears to say that this is the responsibility of the --- caller, not the callee. - -maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr) -maybeNarrow dflags tycon - | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e - | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e - | tycon `hasKey` int32TyConKey - && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e - - | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e - | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e - | tycon `hasKey` word32TyConKey - && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e - | otherwise = id diff --git a/deSugar/DsExpr.hs b/deSugar/DsExpr.hs deleted file mode 100644 --- a/deSugar/DsExpr.hs +++ /dev/null @@ -1,1065 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Desugaring exporessions. --} - -{-# LANGUAGE CPP, MultiWayIf #-} - -module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds - , dsValBinds, dsLit, dsSyntaxExpr ) where - -#include "HsVersions.h" - -import Match -import MatchLit -import DsBinds -import DsGRHSs -import DsListComp -import DsUtils -import DsArrows -import DsMonad -import Name -import NameEnv -import FamInstEnv( topNormaliseType ) -import DsMeta -import HsSyn - --- NB: The desugarer, which straddles the source and Core worlds, sometimes --- needs to see source types -import TcType -import TcEvidence -import TcRnMonad -import TcHsSyn -import Type -import CoreSyn -import CoreUtils -import MkCore - -import DynFlags -import CostCentre -import Id -import MkId -import Module -import ConLike -import DataCon -import TysWiredIn -import PrelNames -import BasicTypes -import Maybes -import VarEnv -import SrcLoc -import Util -import Bag -import Outputable -import PatSyn - -import Control.Monad - -{- -************************************************************************ -* * - dsLocalBinds, dsValBinds -* * -************************************************************************ --} - -dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr -dsLocalBinds (L _ EmptyLocalBinds) body = return body -dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $ - dsValBinds binds body -dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body - -------------------------- --- caller sets location -dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr -dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds -dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn" - -------------------------- -dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr -dsIPBinds (IPBinds ip_binds ev_binds) body - = do { ds_binds <- dsTcEvBinds ev_binds - ; let inner = mkCoreLets ds_binds body - -- The dict bindings may not be in - -- dependency order; hence Rec - ; foldrM ds_ip_bind inner ip_binds } - where - ds_ip_bind (L _ (IPBind ~(Right n) e)) body - = do e' <- dsLExpr e - return (Let (NonRec n e') body) - -------------------------- --- caller sets location -ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr --- Special case for bindings which bind unlifted variables --- We need to do a case right away, rather than building --- a tuple and doing selections. --- Silently ignore INLINE and SPECIALISE pragmas... -ds_val_bind (NonRecursive, hsbinds) body - | [L loc bind] <- bagToList hsbinds - -- Non-recursive, non-overloaded bindings only come in ones - -- ToDo: in some bizarre case it's conceivable that there - -- could be dict binds in the 'binds'. (See the notes - -- below. Then pattern-match would fail. Urk.) - , isUnliftedHsBind bind - = putSrcSpanDs loc $ - -- see Note [Strict binds checks] in DsBinds - if is_polymorphic bind - then errDsCoreExpr (poly_bind_err bind) - -- data Ptr a = Ptr Addr# - -- f x = let p@(Ptr y) = ... in ... - -- Here the binding for 'p' is polymorphic, but does - -- not mix with an unlifted binding for 'y'. You should - -- use a bang pattern. Trac #6078. - - else do { when (looksLazyPatBind bind) $ - warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) - -- Complain about a binding that looks lazy - -- e.g. let I# y = x in ... - -- Remember, in checkStrictBinds we are going to do strict - -- matching, so (for software engineering reasons) we insist - -- that the strictness is manifest on each binding - -- However, lone (unboxed) variables are ok - - - ; dsUnliftedBind bind body } - where - is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) - = not (null tvs && null evs) - is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }) - = not (null tvs && null evs) - is_polymorphic _ = False - - unlifted_must_be_bang bind - = hang (text "Pattern bindings containing unlifted types should use" $$ - text "an outermost bang pattern:") - 2 (ppr bind) - - poly_bind_err bind - = hang (text "You can't mix polymorphic and unlifted bindings:") - 2 (ppr bind) $$ - text "Probable fix: add a type signature" - -ds_val_bind (is_rec, binds) _body - | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds - = ASSERT( isRec is_rec ) - errDsCoreExpr $ - hang (text "Recursive bindings for unlifted types aren't allowed:") - 2 (vcat (map ppr (bagToList binds))) - --- Ordinary case for bindings; none should be unlifted -ds_val_bind (is_rec, binds) body - = do { MASSERT( isRec is_rec || isSingletonBag binds ) - -- we should never produce a non-recursive list of multiple binds - - ; (force_vars,prs) <- dsLHsBinds binds - ; let body' = foldr seqVar body force_vars - ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds ) - case prs of - [] -> return body - _ -> return (Let (Rec prs) body') } - -- Use a Rec regardless of is_rec. - -- Why? Because it allows the binds to be all - -- mixed up, which is what happens in one rare case - -- Namely, for an AbsBind with no tyvars and no dicts, - -- but which does have dictionary bindings. - -- See notes with TcSimplify.inferLoop [NO TYVARS] - -- It turned out that wrapping a Rec here was the easiest solution - -- - -- NB The previous case dealt with unlifted bindings, so we - -- only have to deal with lifted ones now; so Rec is ok - ------------------- -dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr -dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] - , abs_exports = exports - , abs_ev_binds = ev_binds - , abs_binds = lbinds }) body - = do { let body1 = foldr bind_export body exports - bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b - ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body) - body1 lbinds - ; ds_binds <- dsTcEvBinds_s ev_binds - ; return (mkCoreLets ds_binds body2) } - -dsUnliftedBind (AbsBindsSig { abs_tvs = [] - , abs_ev_vars = [] - , abs_sig_export = poly - , abs_sig_ev_bind = ev_bind - , abs_sig_bind = L _ bind }) body - = do { ds_binds <- dsTcEvBinds ev_bind - ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body - ; return (mkCoreLets ds_binds body') } - -dsUnliftedBind (FunBind { fun_id = L l fun - , fun_matches = matches - , fun_co_fn = co_fn - , fun_tick = tick }) body - -- Can't be a bang pattern (that looks like a PatBind) - -- so must be simply unboxed - = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) - Nothing matches - ; MASSERT( null args ) -- Functions aren't lifted - ; MASSERT( isIdHsWrapper co_fn ) - ; let rhs' = mkOptTickBox tick rhs - ; return (bindNonRec fun rhs' body) } - -dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body - = -- let C x# y# = rhs in body - -- ==> case rhs of C x# y# -> body - do { rhs <- dsGuarded grhss ty - ; let upat = unLoc pat - eqn = EqnInfo { eqn_pats = [upat], - eqn_rhs = cantFailMatchResult body } - ; var <- selectMatchVar upat - ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) - ; return (bindNonRec var rhs result) } - -dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) - -{- -************************************************************************ -* * -\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals} -* * -************************************************************************ --} - -dsLExpr :: LHsExpr Id -> DsM CoreExpr - -dsLExpr (L loc e) - = putSrcSpanDs loc $ - do { core_expr <- dsExpr e - -- uncomment this check to test the hsExprType function in TcHsSyn - -- ; MASSERT2( exprType core_expr `eqType` hsExprType e - -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ - -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) - ; return core_expr } - --- | Variant of 'dsLExpr' that ensures that the result is not levity --- polymorphic. This should be used when the resulting expression will --- be an argument to some other function. --- See Note [Levity polymorphism checking] in DsMonad --- See Note [Levity polymorphism invariants] in CoreSyn -dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr -dsLExprNoLP (L loc e) - = putSrcSpanDs loc $ - do { e' <- dsExpr e - ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) - ; return e' } - -dsExpr :: HsExpr Id -> DsM CoreExpr -dsExpr (HsPar e) = dsLExpr e -dsExpr (ExprWithTySigOut e _) = dsLExpr e -dsExpr (HsVar (L _ var)) = return (varToCoreExpr var) - -- See Note [Desugaring vars] -dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them -dsExpr (HsConLikeOut con) = return (dsConLike con) -dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar" -dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel" -dsExpr (HsLit lit) = dsLit lit -dsExpr (HsOverLit lit) = dsOverLit lit - -dsExpr (HsWrap co_fn e) - = do { e' <- dsExpr e - ; wrap' <- dsHsWrapper co_fn - ; dflags <- getDynFlags - ; let wrapped_e = wrap' e' - ; warnAboutIdentities dflags e' (exprType wrapped_e) - ; return wrapped_e } - -dsExpr (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral src i }))) - neg_expr) - = do { expr' <- putSrcSpanDs loc $ do - { dflags <- getDynFlags - ; warnAboutOverflowedLiterals dflags - (lit { ol_val = HsIntegral src (-i) }) - ; dsOverLit' dflags lit } - ; dsSyntaxExpr neg_expr [expr'] } - -dsExpr (NegApp expr neg_expr) - = do { expr' <- dsLExpr expr - ; dsSyntaxExpr neg_expr [expr'] } - -dsExpr (HsLam a_Match) - = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match - -dsExpr (HsLamCase matches) - = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches - ; return $ Lam discrim_var matching_code } - -dsExpr e@(HsApp fun arg) - = do { fun' <- dsLExpr fun - ; dsWhenNoErrs (dsLExprNoLP arg) - (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } - -dsExpr (HsAppTypeOut e _) - -- ignore type arguments here; they're in the wrappers instead at this point - = dsLExpr e - - -{- -Note [Desugaring vars] -~~~~~~~~~~~~~~~~~~~~~~ -In one situation we can get a *coercion* variable in a HsVar, namely -the support method for an equality superclass: - class (a~b) => C a b where ... - instance (blah) => C (T a) (T b) where .. -Then we get - $dfCT :: forall ab. blah => C (T a) (T b) - $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) - - $c$p1C :: forall ab. blah => (T a ~ T b) - $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g - -That 'g' in the 'in' part is an evidence variable, and when -converting to core it must become a CO. - -Operator sections. At first it looks as if we can convert -\begin{verbatim} - (expr op) -\end{verbatim} -to -\begin{verbatim} - \x -> op expr x -\end{verbatim} - -But no! expr might be a redex, and we can lose laziness badly this -way. Consider -\begin{verbatim} - map (expr op) xs -\end{verbatim} -for example. So we convert instead to -\begin{verbatim} - let y = expr in \x -> op y x -\end{verbatim} -If \tr{expr} is actually just a variable, say, then the simplifier -will sort it out. --} - -dsExpr e@(OpApp e1 op _ e2) - = -- for the type of y, we need the type of op's 2nd argument - do { op' <- dsLExpr op - ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) - (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } - -dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e) - = do { op' <- dsLExpr op - ; dsWhenNoErrs (dsLExprNoLP expr) - (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') } - --- dsLExpr (SectionR op expr) -- \ x -> op x expr -dsExpr e@(SectionR op expr) = do - core_op <- dsLExpr op - -- for the type of x, we need the type of op's 2nd argument - let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) - -- See comment with SectionL - y_core <- dsLExpr expr - dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty]) - (\[x_id, y_id] -> bindNonRec y_id y_core $ - Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) - core_op [Var x_id, Var y_id])) - -dsExpr (ExplicitTuple tup_args boxity) - = do { let go (lam_vars, args) (L _ (Missing ty)) - -- For every missing expression, we need - -- another lambda in the desugaring. - = do { lam_var <- newSysLocalDsNoLP ty - ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (L _ (Present expr)) - -- Expressions that are present don't generate - -- lambdas, just arguments. - = do { core_expr <- dsLExprNoLP expr - ; return (lam_vars, core_expr : args) } - - ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) - -- The reverse is because foldM goes left-to-right - (\(lam_vars, args) -> mkCoreLams lam_vars $ - mkCoreTupBoxity boxity args) } - -dsExpr (ExplicitSum alt arity expr types) - = do { dsWhenNoErrs (dsLExprNoLP expr) - (\core_expr -> mkCoreConApps (sumDataCon alt arity) - (map (Type . getRuntimeRep) types ++ - map Type types ++ - [core_expr]) ) } - -dsExpr (HsSCC _ cc expr@(L loc _)) = do - dflags <- getDynFlags - if gopt Opt_SccProfilingOn dflags - then do - mod_name <- getModule - count <- goptM Opt_ProfCountEntries - uniq <- newUnique - Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True) - <$> dsLExpr expr - else dsLExpr expr - -dsExpr (HsCoreAnn _ _ expr) - = dsLExpr expr - -dsExpr (HsCase discrim matches) - = do { core_discrim <- dsLExpr discrim - ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches - ; return (bindNonRec discrim_var core_discrim matching_code) } - --- Pepe: The binds are in scope in the body but NOT in the binding group --- This is to avoid silliness in breakpoints -dsExpr (HsLet binds body) = do - body' <- dsLExpr body - dsLocalBinds binds body' - --- We need the `ListComp' form to use `deListComp' (rather than the "do" form) --- because the interpretation of `stmts' depends on what sort of thing it is. --- -dsExpr (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty -dsExpr (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts) -dsExpr (HsDo DoExpr (L _ stmts) _) = dsDo stmts -dsExpr (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts -dsExpr (HsDo MDoExpr (L _ stmts) _) = dsDo stmts -dsExpr (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts - -dsExpr (HsIf mb_fun guard_expr then_expr else_expr) - = do { pred <- dsLExpr guard_expr - ; b1 <- dsLExpr then_expr - ; b2 <- dsLExpr else_expr - ; case mb_fun of - Just fun -> dsSyntaxExpr fun [pred, b1, b2] - Nothing -> return $ mkIfThenElse pred b1 b2 } - -dsExpr (HsMultiIf res_ty alts) - | null alts - = mkErrorExpr - - | otherwise - = do { match_result <- liftM (foldr1 combineMatchResults) - (mapM (dsGRHS IfAlt res_ty) alts) - ; error_expr <- mkErrorExpr - ; extractMatchResult match_result error_expr } - where - mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty - (text "multi-way if") - -{- -\noindent -\underline{\bf Various data construction things} - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --} - -dsExpr (ExplicitList elt_ty wit xs) - = dsExplicitList elt_ty wit xs - --- We desugar [:x1, ..., xn:] as --- singletonP x1 +:+ ... +:+ singletonP xn --- -dsExpr (ExplicitPArr ty []) = do - emptyP <- dsDPHBuiltin emptyPVar - return (Var emptyP `App` Type ty) -dsExpr (ExplicitPArr ty xs) = do - singletonP <- dsDPHBuiltin singletonPVar - appP <- dsDPHBuiltin appPVar - xs' <- mapM dsLExprNoLP xs - let unary fn x = mkApps (Var fn) [Type ty, x] - binary fn x y = mkApps (Var fn) [Type ty, x, y] - - return . foldr1 (binary appP) $ map (unary singletonP) xs' - -dsExpr (ArithSeq expr witness seq) - = case witness of - Nothing -> dsArithSeq expr seq - Just fl -> do { newArithSeq <- dsArithSeq expr seq - ; dsSyntaxExpr fl [newArithSeq] } - -dsExpr (PArrSeq expr (FromTo from to)) - = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to] - -dsExpr (PArrSeq expr (FromThenTo from thn to)) - = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to] - -dsExpr (PArrSeq _ _) - = panic "DsExpr.dsExpr: Infinite parallel array!" - -- the parser shouldn't have generated it and the renamer and typechecker - -- shouldn't have let it through - -{- -Static Pointers -~~~~~~~~~~~~~~~ - -See Note [Grand plan for static forms] in StaticPtrTable for an overview. - - g = ... static f ... -==> - g = ... makeStatic loc f ... --} - -dsExpr (HsStatic _ expr@(L loc _)) = do - expr_ds <- dsLExprNoLP expr - let ty = exprType expr_ds - makeStaticId <- dsLookupGlobalId makeStaticName - - dflags <- getDynFlags - let (line, col) = case loc of - RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r - , srcLocCol $ realSrcSpanStart r - ) - _ -> (0, 0) - srcLoc = mkCoreConApps (tupleDataCon Boxed 2) - [ Type intTy , Type intTy - , mkIntExprInt dflags line, mkIntExprInt dflags col - ] - - putSrcSpanDs loc $ return $ - mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] - -{- -\noindent -\underline{\bf Record construction and update} - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For record construction we do this (assuming T has three arguments) -\begin{verbatim} - T { op2 = e } -==> - let err = /\a -> recConErr a - T (recConErr t1 "M.hs/230/op1") - e - (recConErr t1 "M.hs/230/op3") -\end{verbatim} -@recConErr@ then converts its argument string into a proper message -before printing it as -\begin{verbatim} - M.hs, line 230: missing field op1 was evaluated -\end{verbatim} - -We also handle @C{}@ as valid construction syntax for an unlabelled -constructor @C@, setting all of @C@'s fields to bottom. --} - -dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds - , rcon_con_like = con_like }) - = do { con_expr' <- dsExpr con_expr - ; let - (arg_tys, _) = tcSplitFunTys (exprType con_expr') - -- A newtype in the corner should be opaque; - -- hence TcType.tcSplitFunTys - - mk_arg (arg_ty, fl) - = case findField (rec_flds rbinds) (flSelector fl) of - (rhs:rhss) -> ASSERT( null rhss ) - dsLExprNoLP rhs - [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) - unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty - - labels = conLikeFieldLabels con_like - - ; con_args <- if null labels - then mapM unlabelled_bottom arg_tys - else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) - - ; return (mkCoreApps con_expr' con_args) } - -{- -Record update is a little harder. Suppose we have the decl: -\begin{verbatim} - data T = T1 {op1, op2, op3 :: Int} - | T2 {op4, op2 :: Int} - | T3 -\end{verbatim} -Then we translate as follows: -\begin{verbatim} - r { op2 = e } -===> - let op2 = e in - case r of - T1 op1 _ op3 -> T1 op1 op2 op3 - T2 op4 _ -> T2 op4 op2 - other -> recUpdError "M.hs/230" -\end{verbatim} -It's important that we use the constructor Ids for @T1@, @T2@ etc on the -RHSs, and do not generate a Core constructor application directly, because the constructor -might do some argument-evaluation first; and may have to throw away some -dictionaries. - -Note [Update for GADTs] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a b where - T1 :: { f1 :: a } -> T a Int - -Then the wrapper function for T1 has type - $WT1 :: a -> T a Int -But if x::T a b, then - x { f1 = v } :: T a b (not T a Int!) -So we need to cast (T a Int) to (T a b). Sigh. - --} - -dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields - , rupd_cons = cons_to_upd - , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys - , rupd_wrap = dict_req_wrap } ) - | null fields - = dsLExpr record_expr - | otherwise - = ASSERT2( notNull cons_to_upd, ppr expr ) - - do { record_expr' <- dsLExpr record_expr - ; field_binds' <- mapM ds_field fields - ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding - upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] - - -- It's important to generate the match with matchWrapper, - -- and the right hand sides with applications of the wrapper Id - -- so that everything works when we are doing fancy unboxing on the - -- constructor arguments. - ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd - ; ([discrim_var], matching_code) - <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts - , mg_arg_tys = [in_ty] - , mg_res_ty = out_ty, mg_origin = FromSource }) - -- FromSource is not strictly right, but we - -- want incomplete pattern-match warnings - - ; return (add_field_binds field_binds' $ - bindNonRec discrim_var record_expr' matching_code) } - where - ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr) - -- Clone the Id in the HsRecField, because its Name is that - -- of the record selector, and we must not make that a local binder - -- else we shadow other uses of the record selector - -- Hence 'lcl_id'. Cf Trac #2735 - ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) - ; let fld_id = unLoc (hsRecUpdFieldId rec_field) - ; lcl_id <- newSysLocalDs (idType fld_id) - ; return (idName fld_id, lcl_id, rhs) } - - add_field_binds [] expr = expr - add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) - - -- Awkwardly, for families, the match goes - -- from instance type to family type - (in_ty, out_ty) = - case (head cons_to_upd) of - RealDataCon data_con -> - let tycon = dataConTyCon data_con in - (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys) - PatSynCon pat_syn -> - ( patSynInstResTy pat_syn in_inst_tys - , patSynInstResTy pat_syn out_inst_tys) - mk_alt upd_fld_env con - = do { let (univ_tvs, ex_tvs, eq_spec, - prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con - subst = zipTvSubst univ_tvs in_inst_tys - - -- I'm not bothering to clone the ex_tvs - ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta) - ; arg_ids <- newSysLocalsDs (substTysUnchecked subst arg_tys) - ; let field_labels = conLikeFieldLabels con - val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg - field_labels arg_ids - mk_val_arg fl pat_arg_id - = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - - inst_con = noLoc $ HsWrap wrap (HsConLikeOut con) - -- Reconstruct with the WrapId so that unpacking happens - -- The order here is because of the order in `TcPatSyn`. - wrap = mkWpEvVarApps theta_vars <.> - dict_req_wrap <.> - mkWpTyApps (mkTyVarTys ex_tvs) <.> - mkWpTyApps [ ty - | (tv, ty) <- univ_tvs `zip` out_inst_tys - , not (tv `elemVarEnv` wrap_subst) ] - rhs = foldl (\a b -> nlHsApp a b) inst_con val_args - - -- Tediously wrap the application in a cast - -- Note [Update for GADTs] - wrapped_rhs = - case con of - RealDataCon data_con -> - let - wrap_co = - mkTcTyConAppCo Nominal - (dataConTyCon data_con) - [ lookup tv ty - | (tv,ty) <- univ_tvs `zip` out_inst_tys ] - lookup univ_tv ty = - case lookupVarEnv wrap_subst univ_tv of - Just co' -> co' - Nothing -> mkTcReflCo Nominal ty - in if null eq_spec - then rhs - else mkLHsWrap (mkWpCastN wrap_co) rhs - -- eq_spec is always null for a PatSynCon - PatSynCon _ -> rhs - - wrap_subst = - mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) - | (spec, eq_var) <- eq_spec `zip` eqs_vars - , let tv = eqSpecTyVar spec ] - - req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys - - pat = noLoc $ ConPatOut { pat_con = noLoc con - , pat_tvs = ex_tvs - , pat_dicts = eqs_vars ++ theta_vars - , pat_binds = emptyTcEvBinds - , pat_args = PrefixCon $ map nlVarPat arg_ids - , pat_arg_tys = in_inst_tys - , pat_wrap = req_wrap } - ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } - --- Here is where we desugar the Template Haskell brackets and escapes - --- Template Haskell stuff - -dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" -dsExpr (HsTcBracketOut x ps) = dsBracket x 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 - } - -dsExpr (HsTickPragma _ _ _ expr) = do - dflags <- getDynFlags - if gopt Opt_Hpc dflags - then panic "dsExpr:HsTickPragma" - else dsLExpr expr - --- HsSyn constructs that just shouldn't be here: -dsExpr (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig" -dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" -dsExpr (HsArrApp {}) = panic "dsExpr:HsArrApp" -dsExpr (HsArrForm {}) = panic "dsExpr:HsArrForm" -dsExpr (EWildPat {}) = panic "dsExpr:EWildPat" -dsExpr (EAsPat {}) = panic "dsExpr:EAsPat" -dsExpr (EViewPat {}) = panic "dsExpr:EViewPat" -dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat" -dsExpr (HsAppType {}) = panic "dsExpr:HsAppType" -- removed by typechecker -dsExpr (HsDo {}) = panic "dsExpr:HsDo" -dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld" - ------------------------------- -dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr -dsSyntaxExpr (SyntaxExpr { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - arg_exprs - = do { fun <- dsExpr expr - ; core_arg_wraps <- mapM dsHsWrapper arg_wraps - ; core_res_wrap <- dsHsWrapper res_wrap - ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs - ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]) - (\_ -> core_res_wrap (mkApps fun wrapped_args)) } - where - mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) - -findField :: [LHsRecField Id arg] -> Name -> [arg] -findField rbinds sel - = [hsRecFieldArg fld | L _ fld <- rbinds - , sel == idName (unLoc $ hsRecFieldId fld) ] - -{- -%-------------------------------------------------------------------- - -Note [Desugaring explicit lists] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Explicit lists are desugared in a cleverer way to prevent some -fruitless allocations. Essentially, whenever we see a list literal -[x_1, ..., x_n] we generate the corresponding expression in terms of -build: - -Explicit lists (literals) are desugared to allow build/foldr fusion when -beneficial. This is a bit of a trade-off, - - * build/foldr fusion can generate far larger code than the corresponding - cons-chain (e.g. see #11707) - - * even when it doesn't produce more code, build can still fail to fuse, - requiring that the simplifier do more work to bring the expression - back into cons-chain form; this costs compile time - - * when it works, fusion can be a significant win. Allocations are reduced - by up to 25% in some nofib programs. Specifically, - - Program Size Allocs Runtime CompTime - rewrite +0.0% -26.3% 0.02 -1.8% - ansi -0.3% -13.8% 0.00 +0.0% - lift +0.0% -8.7% 0.00 -2.3% - -At the moment we use a simple heuristic to determine whether build will be -fruitful: for small lists we assume the benefits of fusion will be worthwhile; -for long lists we assume that the benefits will be outweighted by the cost of -code duplication. This magic length threshold is @maxBuildLength@. Also, fusion -won't work at all if rewrite rules are disabled, so we don't use the build-based -desugaring in this case. - -We used to have a more complex heuristic which would try to break the list into -"static" and "dynamic" parts and only build-desugar the dynamic part. -Unfortunately, determining "static-ness" reliably is a bit tricky and the -heuristic at times produced surprising behavior (see #11710) so it was dropped. --} - -{- | The longest list length which we will desugar using @build@. - -This is essentially a magic number and its setting is unfortunate rather -arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists], -is to avoid deforesting large static data into large(r) code. Ideally we'd -want a smaller threshold with larger consumers and vice-versa, but we have no -way of knowing what will be consuming our list in the desugaring impossible to -set generally correctly. - -The effect of reducing this number will be that 'build' fusion is applied -less often. From a runtime performance perspective, applying 'build' more -liberally on "moderately" sized lists should rarely hurt and will often it can -only expose further optimization opportunities; if no fusion is possible it will -eventually get rule-rewritten back to a list). We do, however, pay in compile -time. --} -maxBuildLength :: Int -maxBuildLength = 32 - -dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] - -> DsM CoreExpr --- See Note [Desugaring explicit lists] -dsExplicitList elt_ty Nothing xs - = do { dflags <- getDynFlags - ; xs' <- mapM dsLExprNoLP xs - ; if length xs' > maxBuildLength - -- Don't generate builds if the list is very long. - || length xs' == 0 - -- Don't generate builds when the [] constructor will do - || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off - -- Don't generate a build if there are no rules to eliminate it! - -- See Note [Desugaring RULE left hand sides] in Desugar - then return $ mkListExpr elt_ty xs' - else mkBuildExpr elt_ty (mk_build_list xs') } - where - mk_build_list xs' (cons, _) (nil, _) - = return (foldr (App . App (Var cons)) (Var nil) xs') - -dsExplicitList elt_ty (Just fln) xs - = do { list <- dsExplicitList elt_ty Nothing xs - ; dflags <- getDynFlags - ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] } - -dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr -dsArithSeq expr (From from) - = App <$> dsExpr expr <*> dsLExprNoLP from -dsArithSeq expr (FromTo from to) - = do dflags <- getDynFlags - warnAboutEmptyEnumerations dflags from Nothing to - expr' <- dsExpr expr - from' <- dsLExprNoLP from - to' <- dsLExprNoLP to - return $ mkApps expr' [from', to'] -dsArithSeq expr (FromThen from thn) - = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] -dsArithSeq expr (FromThenTo from thn to) - = do dflags <- getDynFlags - warnAboutEmptyEnumerations dflags from (Just thn) to - expr' <- dsExpr expr - from' <- dsLExprNoLP from - thn' <- dsLExprNoLP thn - to' <- dsLExprNoLP to - return $ mkApps expr' [from', thn', to'] - -{- -Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're -handled in DsListComp). Basically does the translation given in the -Haskell 98 report: --} - -dsDo :: [ExprLStmt Id] -> DsM CoreExpr -dsDo stmts - = goL stmts - where - goL [] = panic "dsDo" - goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - - go _ (LastStmt body _ _) stmts - = ASSERT( null stmts ) dsLExpr body - -- The 'return' op isn't used for 'do' expressions - - go _ (BodyStmt rhs then_expr _ _) stmts - = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings rhs (exprType rhs2) - ; rest <- goL stmts - ; dsSyntaxExpr then_expr [rhs2, rest] } - - go _ (LetStmt binds) stmts - = do { rest <- goL stmts - ; dsLocalBinds binds rest } - - go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts - = do { body <- goL stmts - ; rhs' <- dsLExpr rhs - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat - res1_ty (cantFailMatchResult body) - ; match_code <- handle_failure pat match fail_op - ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } - - go _ (ApplicativeStmt args mb_join body_ty) stmts - = do { - let - (pats, rhss) = unzip (map (do_arg . snd) args) - - do_arg (ApplicativeArgOne pat expr) = - (pat, dsLExpr expr) - do_arg (ApplicativeArgMany stmts ret pat) = - (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) - - arg_tys = map hsLPatType pats - - ; rhss' <- sequence rhss - - ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty - - ; let fun = L noSrcSpan $ HsLam $ - MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats - body'] - , mg_arg_tys = arg_tys - , mg_res_ty = body_ty - , mg_origin = Generated } - - ; fun' <- dsLExpr fun - ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] - ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') - ; case mb_join of - Nothing -> return expr - Just join_op -> dsSyntaxExpr join_op [expr] } - - go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_ret_fn = return_op - , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op - , recS_bind_ty = bind_ty - , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts - = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } - where - new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats) - mfix_app bind_op - noSyntaxExpr -- Tuple cannot fail - bind_ty - - tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids - tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case - rec_tup_pats = map nlVarPat tup_ids - later_pats = rec_tup_pats - rets = map noLoc rec_rets - mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] - mfix_arg = noLoc $ HsLam - (MG { mg_alts = noLoc [mkSimpleMatch - LambdaExpr - [mfix_pat] body] - , mg_arg_tys = [tup_ty], mg_res_ty = body_ty - , mg_origin = Generated }) - mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats - body = noLoc $ HsDo - DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty - ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] - ret_stmt = noLoc $ mkLastStmt ret_app - -- This LastStmt will be desugared with dsDo, - -- which ignores the return_op in the LastStmt, - -- so we must apply the return_op explicitly - - go _ (ParStmt {}) _ = panic "dsDo ParStmt" - go _ (TransStmt {}) _ = panic "dsDo TransStmt" - -handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr - -- In a do expression, pattern-match failure just calls - -- the monadic 'fail' rather than throwing an exception -handle_failure pat match fail_op - | matchCanFail match - = do { dflags <- getDynFlags - ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) - ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] - ; extractMatchResult match fail_expr } - | otherwise - = extractMatchResult match (error "It can't fail") - -mk_fail_msg :: DynFlags -> Located e -> String -mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ - showPpr dflags (getLoc pat) - -{- -************************************************************************ -* * - Desugaring ConLikes -* * -************************************************************************ --} - -dsConLike :: ConLike -> CoreExpr -dsConLike (RealDataCon dc) = Var (dataConWrapId dc) -dsConLike (PatSynCon ps) = case patSynBuilder ps of - Just (id, add_void) - | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) - | otherwise -> Var id - _ -> pprPanic "dsConLike" (ppr ps) - -{- -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ --} - --- Warn about certain types of values discarded in monadic bindings (#3263) -warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () -warnDiscardedDoBindings rhs rhs_ty - | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty - = do { warn_unused <- woptM Opt_WarnUnusedDoBind - ; warn_wrong <- woptM Opt_WarnWrongDoBind - ; when (warn_unused || warn_wrong) $ - do { fam_inst_envs <- dsGetFamInstEnvs - ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty - - -- Warn about discarding non-() things in 'monadic' binding - ; if warn_unused && not (isUnitTy norm_elt_ty) - then warnDs (Reason Opt_WarnUnusedDoBind) - (badMonadBind rhs elt_ty) - else - - -- Warn about discarding m a things in 'monadic' binding of the same type, - -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - when warn_wrong $ - do { case tcSplitAppTy_maybe norm_elt_ty of - Just (elt_m_ty, _) - | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty - -> warnDs (Reason Opt_WarnWrongDoBind) - (badMonadBind rhs elt_ty) - _ -> return () } } } - - | otherwise -- RHS does have type of form (m ty), which is weird - = return () -- but at lesat this warning is irrelevant - -badMonadBind :: LHsExpr Id -> 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) - ] diff --git a/deSugar/DsExpr.hs-boot b/deSugar/DsExpr.hs-boot deleted file mode 100644 --- a/deSugar/DsExpr.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module DsExpr where -import HsSyn ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) -import Var ( Id ) -import DsMonad ( DsM ) -import CoreSyn ( CoreExpr ) - -dsExpr :: HsExpr Id -> DsM CoreExpr -dsLExpr, dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr -dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr -dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr diff --git a/deSugar/DsForeign.hs b/deSugar/DsForeign.hs deleted file mode 100644 --- a/deSugar/DsForeign.hs +++ /dev/null @@ -1,811 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1998 - - -Desugaring foreign declarations (see also DsCCall). --} - -{-# LANGUAGE CPP #-} - -module DsForeign ( dsForeigns ) where - -#include "HsVersions.h" -import TcRnMonad -- temp - -import CoreSyn - -import DsCCall -import DsMonad - -import HsSyn -import DataCon -import CoreUnfold -import Id -import Literal -import Module -import Name -import Type -import RepType -import TyCon -import Coercion -import TcEnv -import TcType - -import CmmExpr -import CmmUtils -import HscTypes -import ForeignCall -import TysWiredIn -import TysPrim -import PrelNames -import BasicTypes -import SrcLoc -import Outputable -import FastString -import DynFlags -import Platform -import Config -import OrdList -import Pair -import Util -import Hooks -import Encoding - -import Data.Maybe -import Data.List - -{- -Desugaring of @foreign@ declarations is naturally split up into -parts, an @import@ and an @export@ part. A @foreign import@ -declaration -\begin{verbatim} - foreign import cc nm f :: prim_args -> IO prim_res -\end{verbatim} -is the same as -\begin{verbatim} - f :: prim_args -> IO prim_res - f a1 ... an = _ccall_ nm cc a1 ... an -\end{verbatim} -so we reuse the desugaring code in @DsCCall@ to deal with these. --} - -type Binding = (Id, CoreExpr) -- No rec/nonrec structure; - -- the occurrence analyser will sort it all out - -dsForeigns :: [LForeignDecl Id] - -> DsM (ForeignStubs, OrdList Binding) -dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos) - -dsForeigns' :: [LForeignDecl Id] - -> DsM (ForeignStubs, OrdList Binding) -dsForeigns' [] - = return (NoStubs, nilOL) -dsForeigns' fos = do - fives <- mapM do_ldecl fos - let - (hs, cs, idss, bindss) = unzip4 fives - fe_ids = concat idss - fe_init_code = map foreignExportInitialiser fe_ids - -- - return (ForeignStubs - (vcat hs) - (vcat cs $$ vcat fe_init_code), - foldr (appOL . toOL) nilOL bindss) - where - do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) - - do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do - traceIf (text "fi start" <+> ppr id) - let id' = unLoc id - (bs, h, c) <- dsFImport id' co spec - traceIf (text "fi end" <+> ppr id) - return (h, c, [], bs) - - do_decl (ForeignExport { fd_name = L _ id, fd_co = co - , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do - (h, c, _, _) <- dsFExport id co ext_nm cconv False - return (h, c, [id], []) - -{- -************************************************************************ -* * -\subsection{Foreign import} -* * -************************************************************************ - -Desugaring foreign imports is just the matter of creating a binding -that on its RHS unboxes its arguments, performs the external call -(using the @CCallOp@ primop), before boxing the result up and returning it. - -However, we create a worker/wrapper pair, thus: - - foreign import f :: Int -> IO Int -==> - f x = IO ( \s -> case x of { I# x# -> - case fw s x# of { (# s1, y# #) -> - (# s1, I# y# #)}}) - - fw s x# = ccall f s x# - -The strictness/CPR analyser won't do this automatically because it doesn't look -inside returned tuples; but inlining this wrapper is a Really Good Idea -because it exposes the boxing to the call site. --} - -dsFImport :: Id - -> Coercion - -> ForeignImport - -> DsM ([Binding], SDoc, SDoc) -dsFImport id co (CImport cconv safety mHeader spec _) = - dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader - -dsCImport :: Id - -> Coercion - -> CImportSpec - -> CCallConv - -> Safety - -> Maybe Header - -> DsM ([Binding], SDoc, SDoc) -dsCImport id co (CLabel cid) cconv _ _ = do - dflags <- getDynFlags - let ty = pFst $ coercionKind co - fod = case tyConAppTyCon_maybe (dropForAlls ty) of - Just tycon - | tyConUnique tycon == funPtrTyConKey -> - IsFunction - _ -> IsData - (resTy, foRhs) <- resultWrapper ty - ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this - let - rhs = foRhs (Lit (MachLabel cid stdcall_info fod)) - rhs' = Cast rhs co - stdcall_info = fun_type_arg_stdcall_info dflags cconv ty - in - return ([(id, rhs')], empty, empty) - -dsCImport id co (CFunction target) cconv@PrimCallConv safety _ - = dsPrimCall id co (CCall (CCallSpec target cconv safety)) -dsCImport id co (CFunction target) cconv safety mHeader - = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader -dsCImport id co CWrapper cconv _ _ - = dsFExportDynamic id co cconv - --- For stdcall labels, if the type was a FunPtr or newtype thereof, --- then we need to calculate the size of the arguments in order to add --- the @n suffix to the label. -fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int -fun_type_arg_stdcall_info dflags StdCallConv ty - | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty, - tyConUnique tc == funPtrTyConKey - = let - (bndrs, _) = tcSplitPiTys arg_ty - fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs - in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys) -fun_type_arg_stdcall_info _ _other_conv _ - = Nothing - -{- -************************************************************************ -* * -\subsection{Foreign calls} -* * -************************************************************************ --} - -dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header - -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) -dsFCall fn_id co fcall mDeclHeader = do - let - ty = pFst $ coercionKind co - (tv_bndrs, rho) = tcSplitForAllTyVarBndrs ty - (arg_tys, io_res_ty) = tcSplitFunTys rho - - args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism - (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) - - let - work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars - - (ccall_result_ty, res_wrapper) <- boxResult io_res_ty - - ccall_uniq <- newUnique - work_uniq <- newUnique - - dflags <- getDynFlags - (fcall', cDoc) <- - case fcall of - CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) - CApiConv safety) -> - do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) - let fcall' = CCall (CCallSpec - (StaticTarget NoSourceText - wrapperName mUnitId - True) - CApiConv safety) - c = includes - $$ fun_proto <+> braces (cRet <> semi) - includes = vcat [ text "#include <" <> ftext h <> text ">" - | Header _ h <- nub headers ] - fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes - cRet - | isVoidRes = cCall - | otherwise = text "return" <+> cCall - cCall = if isFun - then ppr cName <> parens argVals - else if null arg_tys - then ppr cName - else panic "dsFCall: Unexpected arguments to FFI value import" - raw_res_ty = case tcSplitIOType_maybe io_res_ty of - Just (_ioTyCon, res_ty) -> res_ty - Nothing -> io_res_ty - isVoidRes = raw_res_ty `eqType` unitTy - (mHeader, cResType) - | isVoidRes = (Nothing, text "void") - | otherwise = toCType raw_res_ty - pprCconv = ccallConvAttribute CApiConv - mHeadersArgTypeList - = [ (header, cType <+> char 'a' <> int n) - | (t, n) <- zip arg_tys [1..] - , let (header, cType) = toCType t ] - (mHeaders, argTypeList) = unzip mHeadersArgTypeList - argTypes = if null argTypeList - then text "void" - else hsep $ punctuate comma argTypeList - mHeaders' = mDeclHeader : mHeader : mHeaders - headers = catMaybes mHeaders' - argVals = hsep $ punctuate comma - [ char 'a' <> int n - | (_, n) <- zip arg_tys [1..] ] - return (fcall', c) - _ -> - return (fcall, empty) - let - -- Build the worker - worker_ty = mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty) - tvs = map binderVar tv_bndrs - the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty - work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) - work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty - - -- Build the wrapper - work_app = mkApps (mkVarApps (Var work_id) tvs) val_args - wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers - wrap_rhs = mkLams (tvs ++ args) wrapper_body - wrap_rhs' = Cast wrap_rhs co - fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity - (length args) wrap_rhs' - - return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc) - -{- -************************************************************************ -* * -\subsection{Primitive calls} -* * -************************************************************************ - -This is for `@foreign import prim@' declarations. - -Currently, at the core level we pretend that these primitive calls are -foreign calls. It may make more sense in future to have them as a distinct -kind of Id, or perhaps to bundle them with PrimOps since semantically and -for calling convention they are really prim ops. --} - -dsPrimCall :: Id -> Coercion -> ForeignCall - -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) -dsPrimCall fn_id co fcall = do - let - ty = pFst $ coercionKind co - (tvs, fun_ty) = tcSplitForAllTys ty - (arg_tys, io_res_ty) = tcSplitFunTys fun_ty - - args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism - - ccall_uniq <- newUnique - dflags <- getDynFlags - let - call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty - rhs = mkLams tvs (mkLams args call_app) - rhs' = Cast rhs co - return ([(fn_id, rhs')], empty, empty) - -{- -************************************************************************ -* * -\subsection{Foreign export} -* * -************************************************************************ - -The function that does most of the work for `@foreign export@' declarations. -(see below for the boilerplate code a `@foreign export@' declaration expands - into.) - -For each `@foreign export foo@' in a module M we generate: -\begin{itemize} -\item a C function `@foo@', which calls -\item a Haskell stub `@M.\$ffoo@', which calls -\end{itemize} -the user-written Haskell function `@M.foo@'. --} - -dsFExport :: Id -- Either the exported Id, - -- or the foreign-export-dynamic constructor - -> Coercion -- Coercion between the Haskell type callable - -- from C, and its representation type - -> CLabelString -- The name to export to C land - -> CCallConv - -> Bool -- True => foreign export dynamic - -- so invoke IO action that's hanging off - -- the first argument's stable pointer - -> DsM ( SDoc -- contents of Module_stub.h - , SDoc -- contents of Module_stub.c - , String -- string describing type to pass to createAdj. - , Int -- size of args to stub function - ) - -dsFExport fn_id co ext_name cconv isDyn = do - let - ty = pSnd $ coercionKind co - (bndrs, orig_res_ty) = tcSplitPiTys ty - fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs - -- We must use tcSplits here, because we want to see - -- the (IO t) in the corner of the type! - fe_arg_tys | isDyn = tail fe_arg_tys' - | otherwise = fe_arg_tys' - - -- Look at the result type of the exported function, orig_res_ty - -- If it's IO t, return (t, True) - -- If it's plain t, return (t, False) - (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of - -- The function already returns IO t - Just (_ioTyCon, res_ty) -> (res_ty, True) - -- The function returns t - Nothing -> (orig_res_ty, False) - - dflags <- getDynFlags - return $ - mkFExportCBits dflags ext_name - (if isDyn then Nothing else Just fn_id) - fe_arg_tys res_ty is_IO_res_ty cconv - -{- -@foreign import "wrapper"@ (previously "foreign export dynamic") lets -you dress up Haskell IO actions of some fixed type behind an -externally callable interface (i.e., as a C function pointer). Useful -for callbacks and stuff. - -\begin{verbatim} -type Fun = Bool -> Int -> IO Int -foreign import "wrapper" f :: Fun -> IO (FunPtr Fun) - --- Haskell-visible constructor, which is generated from the above: --- SUP: No check for NULL from createAdjustor anymore??? - -f :: Fun -> IO (FunPtr Fun) -f cback = - bindIO (newStablePtr cback) - (\StablePtr sp# -> IO (\s1# -> - case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of - (# s2#, a# #) -> (# s2#, A# a# #))) - -foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) - --- and the helper in C: (approximately; see `mkFExportCBits` below) - -f_helper(StablePtr s, HsBool b, HsInt i) -{ - Capability *cap; - cap = rts_lock(); - rts_evalIO(&cap, - rts_apply(rts_apply(deRefStablePtr(s), - rts_mkBool(b)), rts_mkInt(i))); - rts_unlock(cap); -} -\end{verbatim} --} - -dsFExportDynamic :: Id - -> Coercion - -> CCallConv - -> DsM ([Binding], SDoc, SDoc) -dsFExportDynamic id co0 cconv = do - mod <- getModule - dflags <- getDynFlags - let fe_nm = mkFastString $ zEncodeString - (moduleStableString mod ++ "$" ++ toCName dflags id) - -- Construct the label based on the passed id, don't use names - -- depending on Unique. See #13807 and Note [Unique Determinism]. - cback <- newSysLocalDs arg_ty - newStablePtrId <- dsLookupGlobalId newStablePtrName - stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName - let - stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] - export_ty = mkFunTy stable_ptr_ty arg_ty - bindIOId <- dsLookupGlobalId bindIOName - stbl_value <- newSysLocalDs stable_ptr_ty - (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True - let - {- - The arguments to the external function which will - create a little bit of (template) code on the fly - for allowing the (stable pointed) Haskell closure - to be entered using an external calling convention - (stdcall, ccall). - -} - adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv) - , Var stbl_value - , Lit (MachLabel fe_nm mb_sz_args IsFunction) - , Lit (mkMachString typestring) - ] - -- name of external entry point providing these services. - -- (probably in the RTS.) - adjustor = fsLit "createAdjustor" - - -- Determine the number of bytes of arguments to the stub function, - -- so that we can attach the '@N' suffix to its label if it is a - -- stdcall on Windows. - mb_sz_args = case cconv of - StdCallConv -> Just args_size - _ -> Nothing - - ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) - -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback - - let io_app = mkLams tvs $ - Lam cback $ - mkApps (Var bindIOId) - [ Type stable_ptr_ty - , Type res_ty - , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] - , Lam stbl_value ccall_adj - ] - - fed = (id `setInlineActivation` NeverActive, Cast io_app co0) - -- Never inline the f.e.d. function, because the litlit - -- might not be in scope in other modules. - - return ([fed], h_code, c_code) - - where - ty = pFst (coercionKind co0) - (tvs,sans_foralls) = tcSplitForAllTys ty - ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls - Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty - -- Must have an IO type; hence Just - - -toCName :: DynFlags -> Id -> String -toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) - -{- -* - -\subsection{Generating @foreign export@ stubs} - -* - -For each @foreign export@ function, a C stub function is generated. -The C stub constructs the application of the exported Haskell function -using the hugs/ghc rts invocation API. --} - -mkFExportCBits :: DynFlags - -> FastString - -> Maybe Id -- Just==static, Nothing==dynamic - -> [Type] - -> Type - -> Bool -- True <=> returns an IO type - -> CCallConv - -> (SDoc, - SDoc, - String, -- the argument reps - Int -- total size of arguments - ) -mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc - = (header_bits, c_bits, type_string, - sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args - -- NB. the calculation here isn't strictly speaking correct. - -- We have a primitive Haskell type (eg. Int#, Double#), and - -- we want to know the size, when passed on the C stack, of - -- the associated C type (eg. HsInt, HsDouble). We don't have - -- this information to hand, but we know what GHC's conventions - -- are for passing around the primitive Haskell types, so we - -- use that instead. I hope the two coincide --SDM - ) - where - -- list the arguments to the C function - arg_info :: [(SDoc, -- arg name - SDoc, -- C type - Type, -- Haskell type - CmmType)] -- the CmmType - arg_info = [ let stg_type = showStgType ty in - (arg_cname n stg_type, - stg_type, - ty, - typeCmmType dflags (getPrimTyOf ty)) - | (ty,n) <- zip arg_htys [1::Int ..] ] - - arg_cname n stg_ty - | libffi = char '*' <> parens (stg_ty <> char '*') <> - text "args" <> brackets (int (n-1)) - | otherwise = text ('a':show n) - - -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled - libffi = cLibFFI && isNothing maybe_target - - type_string - -- libffi needs to know the result type too: - | libffi = primTyDescChar dflags res_hty : arg_type_string - | otherwise = arg_type_string - - arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info] - -- just the real args - - -- add some auxiliary args; the stable ptr in the wrapper case, and - -- a slot for the dummy return address in the wrapper + ccall case - aug_arg_info - | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info - | otherwise = arg_info - - stable_ptr_arg = - (text "the_stableptr", text "StgStablePtr", undefined, - typeCmmType dflags (mkStablePtrPrimTy alphaTy)) - - -- stuff to do with the return type of the C function - res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes - - cResType | res_hty_is_unit = text "void" - | otherwise = showStgType res_hty - - -- when the return type is integral and word-sized or smaller, it - -- must be assigned as type ffi_arg (#3516). To see what type - -- libffi is expecting here, take a look in its own testsuite, e.g. - -- libffi/testsuite/libffi.call/cls_align_ulonglong.c - ffi_cResType - | is_ffi_arg_type = text "ffi_arg" - | otherwise = cResType - where - res_ty_key = getUnique (getName (typeTyCon res_hty)) - is_ffi_arg_type = res_ty_key `notElem` - [floatTyConKey, doubleTyConKey, - int64TyConKey, word64TyConKey] - - -- Now we can cook up the prototype for the exported function. - pprCconv = ccallConvAttribute cc - - header_bits = text "extern" <+> fun_proto <> semi - - fun_args - | null aug_arg_info = text "void" - | otherwise = hsep $ punctuate comma - $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info - - fun_proto - | libffi - = text "void" <+> ftext c_nm <> - parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr") - | otherwise - = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args - - -- the target which will form the root of what we ask rts_evalIO to run - the_cfun - = case maybe_target of - Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" - Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure" - - cap = text "cap" <> comma - - -- the expression we give to rts_evalIO - expr_to_run - = foldl appArg the_cfun arg_info -- NOT aug_arg_info - where - appArg acc (arg_cname, _, arg_hty, _) - = text "rts_apply" - <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname)) - - -- various other bits for inside the fn - declareResult = text "HaskellObj ret;" - declareCResult | res_hty_is_unit = empty - | otherwise = cResType <+> text "cret;" - - assignCResult | res_hty_is_unit = empty - | otherwise = - text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi - - -- an extern decl for the fn being called - extern_decl - = case maybe_target of - Nothing -> empty - Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi - - - -- finally, the whole darn thing - c_bits = - space $$ - extern_decl $$ - fun_proto $$ - vcat - [ lbrace - , text "Capability *cap;" - , declareResult - , declareCResult - , text "cap = rts_lock();" - -- create the application + perform it. - , text "rts_evalIO" <> parens ( - char '&' <> cap <> - text "rts_apply" <> parens ( - cap <> - text "(HaskellObj)" - <> ptext (if is_IO_res_ty - then (sLit "runIO_closure") - else (sLit "runNonIO_closure")) - <> comma - <> expr_to_run - ) <+> comma - <> text "&ret" - ) <> semi - , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) - <> comma <> text "cap") <> semi - , assignCResult - , text "rts_unlock(cap);" - , ppUnless res_hty_is_unit $ - if libffi - then char '*' <> parens (ffi_cResType <> char '*') <> - text "resp = cret;" - else text "return cret;" - , rbrace - ] - - -foreignExportInitialiser :: Id -> SDoc -foreignExportInitialiser hs_fn = - -- Initialise foreign exports by registering a stable pointer from an - -- __attribute__((constructor)) function. - -- The alternative is to do this from stginit functions generated in - -- codeGen/CodeGen.hs; however, stginit functions have a negative impact - -- on binary sizes and link times because the static linker will think that - -- all modules that are imported directly or indirectly are actually used by - -- the program. - -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) - vcat - [ text "static void stginit_export_" <> ppr hs_fn - <> text "() __attribute__((constructor));" - , text "static void stginit_export_" <> ppr hs_fn <> text "()" - , braces (text "foreignExportStablePtr" - <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure") - <> semi) - ] - - -mkHObj :: Type -> SDoc -mkHObj t = text "rts_mk" <> text (showFFIType t) - -unpackHObj :: Type -> SDoc -unpackHObj t = text "rts_get" <> text (showFFIType t) - -showStgType :: Type -> SDoc -showStgType t = text "Hs" <> text (showFFIType t) - -showFFIType :: Type -> String -showFFIType t = getOccString (getName (typeTyCon t)) - -toCType :: Type -> (Maybe Header, SDoc) -toCType = f False - where f voidOK t - -- First, if we have (Ptr t) of (FunPtr t), then we need to - -- convert t to a C type and put a * after it. If we don't - -- know a type for t, then "void" is fine, though. - | Just (ptr, [t']) <- splitTyConApp_maybe t - , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] - = case f True t' of - (mh, cType') -> - (mh, cType' <> char '*') - -- Otherwise, if we have a type constructor application, then - -- see if there is a C type associated with that constructor. - -- Note that we aren't looking through type synonyms or - -- anything, as it may be the synonym that is annotated. - | Just tycon <- tyConAppTyConPicky_maybe t - , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon - = (mHeader, ftext cType) - -- If we don't know a C type for this type, then try looking - -- through one layer of type synonym etc. - | Just t' <- coreView t - = f voidOK t' - -- This may be an 'UnliftedFFITypes'-style ByteArray# argument - -- (which is marshalled like a Ptr) - | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t - = (Nothing, text "const void*") - | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t - = (Nothing, text "void*") - -- Otherwise we don't know the C type. If we are allowing - -- void then return that; otherwise something has gone wrong. - | voidOK = (Nothing, text "void") - | otherwise - = pprPanic "toCType" (ppr t) - -typeTyCon :: Type -> TyCon -typeTyCon ty - | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) - = tc - | otherwise - = pprPanic "DsForeign.typeTyCon" (ppr ty) - -insertRetAddr :: DynFlags -> CCallConv - -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] -insertRetAddr dflags CCallConv args - = case platformArch platform of - ArchX86_64 - | platformOS platform == OSMinGW32 -> - -- On other Windows x86_64 we insert the return address - -- after the 4th argument, because this is the point - -- at which we need to flush a register argument to the stack - -- (See rts/Adjustor.c for details). - let go :: Int -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] - go 4 args = ret_addr_arg dflags : args - go n (arg:args) = arg : go (n+1) args - go _ [] = [] - in go 0 args - | otherwise -> - -- On other x86_64 platforms we insert the return address - -- after the 6th integer argument, because this is the point - -- at which we need to flush a register argument to the stack - -- (See rts/Adjustor.c for details). - let go :: Int -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] - go 6 args = ret_addr_arg dflags : args - go n (arg@(_,_,_,rep):args) - | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args - | otherwise = arg : go n args - go _ [] = [] - in go 0 args - _ -> - ret_addr_arg dflags : args - where platform = targetPlatform dflags -insertRetAddr _ _ args = args - -ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType) -ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined, - typeCmmType dflags addrPrimTy) - --- This function returns the primitive type associated with the boxed --- type argument to a foreign export (eg. Int ==> Int#). -getPrimTyOf :: Type -> UnaryType -getPrimTyOf ty - | isBoolTy rep_ty = intPrimTy - -- Except for Bool, the types we are interested in have a single constructor - -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). - | otherwise = - case splitDataProductType_maybe rep_ty of - Just (_, _, data_con, [prim_ty]) -> - ASSERT(dataConSourceArity data_con == 1) - ASSERT2(isUnliftedType prim_ty, ppr prim_ty) - prim_ty - _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty) - where - rep_ty = unwrapType ty - --- represent a primitive type as a Char, for building a string that --- described the foreign function type. The types are size-dependent, --- e.g. 'W' is a signed 32-bit integer. -primTyDescChar :: DynFlags -> Type -> Char -primTyDescChar dflags ty - | ty `eqType` unitTy = 'v' - | otherwise - = case typePrimRep1 (getPrimTyOf ty) of - IntRep -> signed_word - WordRep -> unsigned_word - Int64Rep -> 'L' - Word64Rep -> 'l' - AddrRep -> 'p' - FloatRep -> 'f' - DoubleRep -> 'd' - _ -> pprPanic "primTyDescChar" (ppr ty) - where - (signed_word, unsigned_word) - | wORD_SIZE dflags == 4 = ('W','w') - | wORD_SIZE dflags == 8 = ('L','l') - | otherwise = panic "primTyDescChar" diff --git a/deSugar/DsGRHSs.hs b/deSugar/DsGRHSs.hs deleted file mode 100644 --- a/deSugar/DsGRHSs.hs +++ /dev/null @@ -1,163 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Matching guarded right-hand-sides (GRHSs) --} - -{-# LANGUAGE CPP #-} - -module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) -import {-# SOURCE #-} Match ( matchSinglePat ) - -import HsSyn -import MkCore -import CoreSyn -import Var - -import DsMonad -import DsUtils -import TysWiredIn -import PrelNames -import Type ( Type ) -import Module -import Name -import Util -import SrcLoc -import Outputable - -{- -@dsGuarded@ is used for both @case@ expressions and pattern bindings. -It desugars: -\begin{verbatim} - | g1 -> e1 - ... - | gn -> en - where binds -\end{verbatim} -producing an expression with a runtime error in the corner if -necessary. The type argument gives the type of the @ei@. --} - -dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr - -dsGuarded grhss rhs_ty = do - match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty - error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty - extractMatchResult match_result error_expr - --- In contrast, @dsGRHSs@ produces a @MatchResult@. - -dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from - -> GRHSs Id (LHsExpr Id) -- Guarded RHSs - -> Type -- Type of RHS - -> DsM MatchResult -dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty - = ASSERT( notNull grhss ) - do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss - ; let match_result1 = foldr1 combineMatchResults match_results - match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 - -- NB: nested dsLet inside matchResult - ; return match_result2 } - -dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult -dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) - = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty - -{- -************************************************************************ -* * -* matchGuard : make a MatchResult from a guarded RHS * -* * -************************************************************************ --} - -matchGuards :: [GuardStmt Id] -- Guard - -> HsStmtContext Name -- Context - -> LHsExpr Id -- RHS - -> Type -- Type of RHS of guard - -> DsM MatchResult - --- See comments with HsExpr.Stmt re what a BodyStmt means --- Here we must be in a guard context (not do-expression, nor list-comp) - -matchGuards [] _ rhs _ - = do { core_rhs <- dsLExpr rhs - ; return (cantFailMatchResult core_rhs) } - - -- BodyStmts must be guards - -- Turn an "otherwise" guard is a no-op. This ensures that - -- you don't get a "non-exhaustive eqns" message when the guards - -- finish in "otherwise". - -- NB: The success of this clause depends on the typechecker not - -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors - -- If it does, you'll get bogus overlap warnings -matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty - | Just addTicks <- isTrueLHsExpr e = do - match_result <- matchGuards stmts ctx rhs rhs_ty - return (adjustMatchResultDs addTicks match_result) -matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do - match_result <- matchGuards stmts ctx rhs rhs_ty - pred_expr <- dsLExpr expr - return (mkGuardedMatchResult pred_expr match_result) - -matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do - match_result <- matchGuards stmts ctx rhs rhs_ty - return (adjustMatchResultDs (dsLocalBinds binds) match_result) - -- NB the dsLet occurs inside the match_result - -- Reason: dsLet takes the body expression as its argument - -- so we can't desugar the bindings without the - -- body expression in hand - -matchGuards (BindStmt pat bind_rhs _ _ _ : stmts) ctx rhs rhs_ty = do - match_result <- matchGuards stmts ctx rhs rhs_ty - core_rhs <- dsLExpr bind_rhs - matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result - -matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt" -matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt" -matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt" -matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" -matchGuards (ApplicativeStmt {} : _) _ _ _ = - panic "matchGuards ApplicativeLastStmt" - -isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr) - --- Returns Just {..} if we're sure that the expression is True --- I.e. * 'True' datacon --- * 'otherwise' Id --- * Trivial wappings of these --- The arguments to Just are any HsTicks that we have found, --- because we still want to tick then, even it they are always evaluated. -isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey - || v `hasKey` getUnique trueDataConId - = Just return - -- trueDataConId doesn't have the same unique as trueDataCon -isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return -isTrueLHsExpr (L _ (HsTick tickish e)) - | Just ticks <- isTrueLHsExpr e - = Just (\x -> do wrapped <- ticks x - return (Tick tickish wrapped)) - -- This encodes that the result is constant True for Hpc tick purposes; - -- which is specifically what isTrueLHsExpr is trying to find out. -isTrueLHsExpr (L _ (HsBinTick ixT _ e)) - | Just ticks <- isTrueLHsExpr e - = Just (\x -> do e <- ticks x - this_mod <- getModule - return (Tick (HpcTick this_mod ixT) e)) - -isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e -isTrueLHsExpr _ = Nothing - -{- -Should {\em fail} if @e@ returns @D@ -\begin{verbatim} -f x | p <- e', let C y# = e, f y# = r1 - | otherwise = r2 -\end{verbatim} --} diff --git a/deSugar/DsListComp.hs b/deSugar/DsListComp.hs deleted file mode 100644 --- a/deSugar/DsListComp.hs +++ /dev/null @@ -1,883 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Desugaring list comprehensions, monad comprehensions and array comprehensions --} - -{-# LANGUAGE CPP, NamedFieldPuns #-} - -module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) - -import HsSyn -import TcHsSyn -import CoreSyn -import MkCore - -import DsMonad -- the monadery used in the desugarer -import DsUtils - -import DynFlags -import CoreUtils -import Id -import Type -import TysWiredIn -import Match -import PrelNames -import SrcLoc -import Outputable -import TcType -import ListSetOps( getNth ) -import Util - -{- -List comprehensions may be desugared in one of two ways: ``ordinary'' -(as you would expect if you read SLPJ's book) and ``with foldr/build -turned on'' (if you read Gill {\em et al.}'s paper on the subject). - -There will be at least one ``qualifier'' in the input. --} - -dsListComp :: [ExprLStmt Id] - -> Type -- Type of entire list - -> DsM CoreExpr -dsListComp lquals res_ty = do - dflags <- getDynFlags - let quals = map unLoc lquals - elt_ty = case tcTyConAppArgs res_ty of - [elt_ty] -> elt_ty - _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals) - - if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags - -- Either rules are switched off, or we are ignoring what there are; - -- Either way foldr/build won't happen, so use the more efficient - -- Wadler-style desugaring - || isParallelComp quals - -- Foldr-style desugaring can't handle parallel list comprehensions - then deListComp quals (mkNilExpr elt_ty) - else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals) - -- Foldr/build should be enabled, so desugar - -- into foldrs and builds - - where - -- We must test for ParStmt anywhere, not just at the head, because an extension - -- to list comprehensions would be to add brackets to specify the associativity - -- of qualifier lists. This is really easy to do by adding extra ParStmts into the - -- mix of possibly a single element in length, so we do this to leave the possibility open - isParallelComp = any isParallelStmt - - isParallelStmt (ParStmt {}) = True - isParallelStmt _ = False - - --- This function lets you desugar a inner list comprehension and a list of the binders --- of that comprehension that we need in the outer comprehension into such an expression --- and the type of the elements that it outputs (tuples of binders) -dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type) -dsInnerListComp (ParStmtBlock stmts bndrs _) - = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs - list_ty = mkListTy bndrs_tuple_type - - -- really use original bndrs below! - ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty - - ; return (expr, bndrs_tuple_type) } - --- This function factors out commonality between the desugaring strategies for GroupStmt. --- Given such a statement it gives you back an expression representing how to compute the transformed --- list and the tuple that you need to bind from that list in order to proceed with your desugaring -dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id) -dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap - , trS_by = by, trS_using = using }) = do - let (from_bndrs, to_bndrs) = unzip binderMap - - let from_bndrs_tys = map idType from_bndrs - to_bndrs_tys = map idType to_bndrs - - to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys - - -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr) - - -- Work out what arguments should be supplied to that expression: i.e. is an extraction - -- function required? If so, create that desugared function and add to arguments - usingExpr' <- dsLExpr using - usingArgs' <- case by of - Nothing -> return [expr'] - Just by_e -> do { by_e' <- dsLExpr by_e - ; lam' <- matchTuple from_bndrs by_e' - ; return [lam', expr'] } - - -- Create an unzip function for the appropriate arity and element types and find "map" - unzip_stuff' <- mkUnzipBind form from_bndrs_tys - map_id <- dsLookupGlobalId mapName - - -- Generate the expressions to build the grouped list - let -- First we apply the grouping function to the inner list - inner_list_expr' = mkApps usingExpr' usingArgs' - -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists - -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and - -- the "b" to be a tuple of "to" lists! - -- Then finally we bind the unzip function around that expression - bound_unzipped_inner_list_expr' - = case unzip_stuff' of - Nothing -> inner_list_expr' - Just (unzip_fn', unzip_rhs') -> - Let (Rec [(unzip_fn', unzip_rhs')]) $ - mkApps (Var map_id) $ - [ Type (mkListTy from_tup_ty) - , Type to_bndrs_tup_ty - , Var unzip_fn' - , inner_list_expr' ] - - dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) - (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using) - - -- Build a pattern that ensures the consumer binds into the NEW binders, - -- which hold lists rather than single values - let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '! - return (bound_unzipped_inner_list_expr', pat) - -dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt" - -{- -************************************************************************ -* * -\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions} -* * -************************************************************************ - -Just as in Phil's chapter~7 in SLPJ, using the rules for -optimally-compiled list comprehensions. This is what Kevin followed -as well, and I quite happily do the same. The TQ translation scheme -transforms a list of qualifiers (either boolean expressions or -generators) into a single expression which implements the list -comprehension. Because we are generating 2nd-order polymorphic -lambda-calculus, calls to NIL and CONS must be applied to a type -argument, as well as their usual value arguments. -\begin{verbatim} -TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >> - -(Rule C) -TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <> TE <> - -(Rule B) -TQ << [ e | b , qs ] ++ L >> = - if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >> - -(Rule A') -TQ << [ e | p <- L1, qs ] ++ L2 >> = - letrec - h = \ u1 -> - case u1 of - [] -> TE << L2 >> - (u2 : u3) -> - (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2) - [] (h u3) - in - h ( TE << L1 >> ) - -"h", "u1", "u2", and "u3" are new variables. -\end{verbatim} - -@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@ -is the TE translation scheme. Note that we carry around the @L@ list -already desugared. @dsListComp@ does the top TE rule mentioned above. - -To the above, we add an additional rule to deal with parallel list -comprehensions. The translation goes roughly as follows: - [ e | p1 <- e11, let v1 = e12, p2 <- e13 - | q1 <- e21, let v2 = e22, q2 <- e23] - => - [ e | ((x1, .., xn), (y1, ..., ym)) <- - zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13] - [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]] -where (x1, .., xn) are the variables bound in p1, v1, p2 - (y1, .., ym) are the variables bound in q1, v2, q2 - -In the translation below, the ParStmt branch translates each parallel branch -into a sub-comprehension, and desugars each independently. The resulting lists -are fed to a zip function, we create a binding for all the variables bound in all -the comprehensions, and then we hand things off the the desugarer for bindings. -The zip function is generated here a) because it's small, and b) because then we -don't have to deal with arbitrary limits on the number of zip functions in the -prelude, nor which library the zip function came from. -The introduced tuples are Boxed, but only because I couldn't get it to work -with the Unboxed variety. --} - -deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr - -deListComp [] _ = panic "deListComp" - -deListComp (LastStmt body _ _ : quals) list - = -- Figure 7.4, SLPJ, p 135, rule C above - ASSERT( null quals ) - do { core_body <- dsLExpr body - ; return (mkConsExpr (exprType core_body) core_body list) } - - -- Non-last: must be a guard -deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above - core_guard <- dsLExpr guard - core_rest <- deListComp quals list - return (mkIfThenElse core_guard core_rest list) - --- [e | let B, qs] = let B in [e | qs] -deListComp (LetStmt binds : quals) list = do - core_rest <- deListComp quals list - dsLocalBinds binds core_rest - -deListComp (stmt@(TransStmt {}) : quals) list = do - (inner_list_expr, pat) <- dsTransStmt stmt - deBindComp pat inner_list_expr quals list - -deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above - core_list1 <- dsLExprNoLP list1 - deBindComp pat core_list1 quals core_list2 - -deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list - = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs - ; let (exps, qual_tys) = unzip exps_and_qual_tys - - ; (zip_fn, zip_rhs) <- mkZipBind qual_tys - - -- Deal with [e | pat <- zip l1 .. ln] in example above - ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) - quals list } - where - bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs] - - -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above - pat = mkBigLHsPatTupId pats - pats = map mkBigLHsVarPatTupId bndrs_s - -deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" - -deListComp (ApplicativeStmt {} : _) _ = - panic "deListComp ApplicativeStmt" - -deBindComp :: OutPat Id - -> CoreExpr - -> [ExprStmt Id] - -> CoreExpr - -> DsM (Expr Id) -deBindComp pat core_list1 quals core_list2 = do - let u3_ty@u1_ty = exprType core_list1 -- two names, same thing - - -- u1_ty is a [alpha] type, and u2_ty = alpha - let u2_ty = hsLPatType pat - - let res_ty = exprType core_list2 - h_ty = u1_ty `mkFunTy` res_ty - - -- no levity polymorphism here, as list comprehensions don't work - -- with RebindableSyntax. NB: These are *not* monad comps. - [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] - - -- the "fail" value ... - let - core_fail = App (Var h) (Var u3) - letrec_body = App (Var h) core_list1 - - rest_expr <- deListComp quals core_fail - core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail - - let - rhs = Lam u1 $ - Case (Var u1) u1 res_ty - [(DataAlt nilDataCon, [], core_list2), - (DataAlt consDataCon, [u2, u3], core_match)] - -- Increasing order of tag - - return (Let (Rec [(h, rhs)]) letrec_body) - -{- -************************************************************************ -* * -\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions} -* * -************************************************************************ - -@dfListComp@ are the rules used with foldr/build turned on: - -\begin{verbatim} -TE[ e | ] c n = c e n -TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n -TE[ e | p <- l , q ] c n = let - f = \ x b -> case x of - p -> TE[ e | q ] c b - _ -> b - in - foldr f n l -\end{verbatim} --} - -dfListComp :: Id -> Id -- 'c' and 'n' - -> [ExprStmt Id] -- the rest of the qual's - -> DsM CoreExpr - -dfListComp _ _ [] = panic "dfListComp" - -dfListComp c_id n_id (LastStmt body _ _ : quals) - = ASSERT( null quals ) - do { core_body <- dsLExprNoLP body - ; return (mkApps (Var c_id) [core_body, Var n_id]) } - - -- Non-last: must be a guard -dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do - core_guard <- dsLExpr guard - core_rest <- dfListComp c_id n_id quals - return (mkIfThenElse core_guard core_rest (Var n_id)) - -dfListComp c_id n_id (LetStmt binds : quals) = do - -- new in 1.3, local bindings - core_rest <- dfListComp c_id n_id quals - dsLocalBinds binds core_rest - -dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do - (inner_list_expr, pat) <- dsTransStmt stmt - -- Anyway, we bind the newly grouped list via the generic binding function - dfBindComp c_id n_id (pat, inner_list_expr) quals - -dfListComp c_id n_id (BindStmt pat list1 _ _ _ : quals) = do - -- evaluate the two lists - core_list1 <- dsLExpr list1 - - -- Do the rest of the work in the generic binding builder - dfBindComp c_id n_id (pat, core_list1) quals - -dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" -dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" -dfListComp _ _ (ApplicativeStmt {} : _) = - panic "dfListComp ApplicativeStmt" - -dfBindComp :: Id -> Id -- 'c' and 'n' - -> (LPat Id, CoreExpr) - -> [ExprStmt Id] -- the rest of the qual's - -> DsM CoreExpr -dfBindComp c_id n_id (pat, core_list1) quals = do - -- find the required type - let x_ty = hsLPatType pat - let b_ty = idType n_id - - -- create some new local id's - b <- newSysLocalDs b_ty - x <- newSysLocalDs x_ty - - -- build rest of the comprehesion - core_rest <- dfListComp c_id b quals - - -- build the pattern match - core_expr <- matchSimply (Var x) (StmtCtxt ListComp) - pat core_rest (Var b) - - -- now build the outermost foldr, and return - mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1 - -{- -************************************************************************ -* * -\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring} -* * -************************************************************************ --} - -mkZipBind :: [Type] -> DsM (Id, CoreExpr) --- mkZipBind [t1, t2] --- = (zip, \as1:[t1] as2:[t2] --- -> case as1 of --- [] -> [] --- (a1:as'1) -> case as2 of --- [] -> [] --- (a2:as'2) -> (a1, a2) : zip as'1 as'2)] - -mkZipBind elt_tys = do - ass <- mapM newSysLocalDs elt_list_tys - as' <- mapM newSysLocalDs elt_tys - as's <- mapM newSysLocalDs elt_list_tys - - zip_fn <- newSysLocalDs zip_fn_ty - - let inner_rhs = mkConsExpr elt_tuple_ty - (mkBigCoreVarTup as') - (mkVarApps (Var zip_fn) as's) - zip_body = foldr mk_case inner_rhs (zip3 ass as' as's) - - return (zip_fn, mkLams ass zip_body) - where - elt_list_tys = map mkListTy elt_tys - elt_tuple_ty = mkBigCoreTupTy elt_tys - elt_tuple_list_ty = mkListTy elt_tuple_ty - - zip_fn_ty = mkFunTys elt_list_tys elt_tuple_list_ty - - mk_case (as, a', as') rest - = Case (Var as) as elt_tuple_list_ty - [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty), - (DataAlt consDataCon, [a', as'], rest)] - -- Increasing order of tag - - -mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr)) --- mkUnzipBind [t1, t2] --- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2]) --- -> case ax of --- (x1, x2) -> case axs of --- (xs1, xs2) -> (x1 : xs1, x2 : xs2)) --- ([], []) --- ys) --- --- We use foldr here in all cases, even if rules are turned off, because we may as well! -mkUnzipBind ThenForm _ - = return Nothing -- No unzipping for ThenForm -mkUnzipBind _ elt_tys - = do { ax <- newSysLocalDs elt_tuple_ty - ; axs <- newSysLocalDs elt_list_tuple_ty - ; ys <- newSysLocalDs elt_tuple_list_ty - ; xs <- mapM newSysLocalDs elt_tys - ; xss <- mapM newSysLocalDs elt_list_tys - - ; unzip_fn <- newSysLocalDs unzip_fn_ty - - ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] - - ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) - concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) - tupled_concat_expression = mkBigCoreTup concat_expressions - - folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) - folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) - folder_body = mkLams [ax, axs] folder_body_outer_case - - ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) - ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } - where - elt_tuple_ty = mkBigCoreTupTy elt_tys - elt_tuple_list_ty = mkListTy elt_tuple_ty - elt_list_tys = map mkListTy elt_tys - elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys - - unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty - - mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail - -{- -************************************************************************ -* * -\subsection[DsPArrComp]{Desugaring of array comprehensions} -* * -************************************************************************ --} - --- entry point for desugaring a parallel array comprehension --- --- [:e | qss:] = <<[:e | qss:]>> () [:():] --- -dsPArrComp :: [ExprStmt Id] - -> DsM CoreExpr - --- Special case for parallel comprehension -dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals - --- Special case for simple generators: --- --- <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e --- --- if matching again p cannot fail, or else --- --- <<[:e' | p <- e, qs:]>> = --- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e) --- -dsPArrComp (BindStmt p e _ _ _ : qs) = do - filterP <- dsDPHBuiltin filterPVar - ce <- dsLExprNoLP e - let ety'ce = parrElemType ce - false = Var falseDataConId - true = Var trueDataConId - v <- newSysLocalDs ety'ce - pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false - let gen | isIrrefutableHsPat p = ce - | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] - dePArrComp qs p gen - -dsPArrComp qs = do -- no ParStmt in `qs' - sglP <- dsDPHBuiltin singletonPVar - let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []] - dePArrComp qs (noLoc $ WildPat unitTy) unitArray - - - --- the work horse --- -dePArrComp :: [ExprStmt Id] - -> LPat Id -- the current generator pattern - -> CoreExpr -- the current generator expression - -> DsM CoreExpr - -dePArrComp [] _ _ = panic "dePArrComp" - --- --- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea --- -dePArrComp (LastStmt e' _ _ : quals) pa cea - = ASSERT( null quals ) - do { mapP <- dsDPHBuiltin mapPVar - ; let ty = parrElemType cea - ; (clam, ty'e') <- deLambda ty pa e' - ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] } --- --- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) --- -dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do - filterP <- dsDPHBuiltin filterPVar - let ty = parrElemType cea - (clam,_) <- deLambda ty pa b - dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea]) - --- --- <<[:e' | p <- e, qs:]>> pa ea = --- let ef = \pa -> e --- in --- <<[:e' | qs:]>> (pa, p) (crossMap ea ef) --- --- if matching again p cannot fail, or else --- --- <<[:e' | p <- e, qs:]>> pa ea = --- let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e --- in --- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef) --- -dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do - filterP <- dsDPHBuiltin filterPVar - crossMapP <- dsDPHBuiltin crossMapPVar - ce <- dsLExpr e - let ety'cea = parrElemType cea - ety'ce = parrElemType ce - false = Var falseDataConId - true = Var trueDataConId - v <- newSysLocalDs ety'ce - pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false - let cef | isIrrefutableHsPat p = ce - | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] - (clam, _) <- mkLambda ety'cea pa cef - let ety'cef = ety'ce -- filter doesn't change the element type - pa' = mkLHsPatTup [pa, p] - - dePArrComp qs pa' (mkApps (Var crossMapP) - [Type ety'cea, Type ety'cef, cea, clam]) --- --- <<[:e' | let ds, qs:]>> pa ea = --- <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) --- (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea) --- where --- {x_1, ..., x_n} = DV (ds) -- Defined Variables --- -dePArrComp (LetStmt lds@(L _ ds) : qs) pa cea = do - mapP <- dsDPHBuiltin mapPVar - let xs = collectLocalBinders ds - ty'cea = parrElemType cea - v <- newSysLocalDs ty'cea - clet <- dsLocalBinds lds (mkCoreTup (map Var xs)) - let'v <- newSysLocalDs (exprType clet) - let projBody = mkCoreLet (NonRec let'v clet) $ - mkCoreTup [Var v, Var let'v] - errTy = exprType projBody - errMsg = text "DsListComp.dePArrComp: internal error!" - cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg - ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr - let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)] - proj = mkLams [v] ccase - dePArrComp qs pa' (mkApps (Var mapP) - [Type ty'cea, Type errTy, proj, cea]) --- --- The parser guarantees that parallel comprehensions can only appear as --- singleton qualifier lists, which we already special case in the caller. --- So, encountering one here is a bug. --- -dePArrComp (ParStmt {} : _) _ _ = - panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt" -dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt" -dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt" -dePArrComp (ApplicativeStmt {} : _) _ _ = - panic "DsListComp.dePArrComp: ApplicativeStmt" - --- <<[:e' | qs | qss:]>> pa ea = --- <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) --- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>) --- where --- {x_1, ..., x_n} = DV (qs) --- -dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr -dePArrParComp qss quals = do - (pQss, ceQss) <- deParStmt qss - dePArrComp quals pQss ceQss - where - deParStmt [] = - -- empty parallel statement lists have no source representation - panic "DsListComp.dePArrComp: Empty parallel list comprehension" - deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement - let res_expr = mkLHsVarTuple xs - cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) - parStmts qss (mkLHsVarPatTup xs) cqs - --- - parStmts [] pa cea = return (pa, cea) - parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed) - zipP <- dsDPHBuiltin zipPVar - let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] - ty'cea = parrElemType cea - res_expr = mkLHsVarTuple xs - cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) - let ty'cqs = parrElemType cqs - cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] - parStmts qss pa' cea' - --- generate Core corresponding to `\p -> e' --- -deLambda :: Type -- type of the argument (not levity-polymorphic) - -> LPat Id -- argument pattern - -> LHsExpr Id -- body - -> DsM (CoreExpr, Type) -deLambda ty p e = - mkLambda ty p =<< dsLExpr e - --- generate Core for a lambda pattern match, where the body is already in Core --- -mkLambda :: Type -- type of the argument (not levity-polymorphic) - -> LPat Id -- argument pattern - -> CoreExpr -- desugared body - -> DsM (CoreExpr, Type) -mkLambda ty p ce = do - v <- newSysLocalDs ty - let errMsg = text "DsListComp.deLambda: internal error!" - ce'ty = exprType ce - cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg - res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr - return (mkLams [v] res, ce'ty) - --- obtain the element type of the parallel array produced by the given Core --- expression --- -parrElemType :: CoreExpr -> Type -parrElemType e = - case splitTyConApp_maybe (exprType e) of - Just (tycon, [ty]) | tycon == parrTyCon -> ty - _ -> panic - "DsListComp.parrElemType: not a parallel array type" - --- Translation for monad comprehensions - --- Entry point for monad comprehension desugaring -dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr -dsMonadComp stmts = dsMcStmts stmts - -dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr -dsMcStmts [] = panic "dsMcStmts" -dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) - ---------------- -dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr - -dsMcStmt (LastStmt body _ ret_op) stmts - = ASSERT( null stmts ) - do { body' <- dsLExpr body - ; dsSyntaxExpr ret_op [body'] } - --- [ .. | let binds, stmts ] -dsMcStmt (LetStmt binds) stmts - = do { rest <- dsMcStmts stmts - ; dsLocalBinds binds rest } - --- [ .. | a <- m, stmts ] -dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts - = do { rhs' <- dsLExpr rhs - ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts } - --- Apply `guard` to the `exp` expression --- --- [ .. | exp, stmts ] --- -dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts - = do { exp' <- dsLExpr exp - ; rest <- dsMcStmts stmts - ; guard_exp' <- dsSyntaxExpr guard_exp [exp'] - ; dsSyntaxExpr then_exp [guard_exp', rest] } - --- Group statements desugar like this: --- --- [| (q, then group by e using f); rest |] --- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> --- case unzip n_tup of qv' -> [| rest |] --- --- where variables (v1:t1, ..., vk:tk) are bound by q --- qv = (v1, ..., vk) --- qt = (t1, ..., tk) --- (>>=) :: m2 a -> (a -> m3 b) -> m3 b --- f :: forall a. (a -> t) -> m1 a -> m2 (n a) --- n_tup :: n qt --- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n) - -dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs - , trS_by = by, trS_using = using - , trS_ret = return_op, trS_bind = bind_op - , trS_bind_arg_ty = n_tup_ty' -- n (a,b,c) - , trS_fmap = fmap_op, trS_form = form }) stmts_rest - = do { let (from_bndrs, to_bndrs) = unzip bndrs - - ; let from_bndr_tys = map idType from_bndrs -- Types ty - - - -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - ; expr' <- dsInnerMonadComp stmts from_bndrs return_op - - -- Work out what arguments should be supplied to that expression: i.e. is an extraction - -- function required? If so, create that desugared function and add to arguments - ; usingExpr' <- dsLExpr using - ; usingArgs' <- case by of - Nothing -> return [expr'] - Just by_e -> do { by_e' <- dsLExpr by_e - ; lam' <- matchTuple from_bndrs by_e' - ; return [lam', expr'] } - - -- Generate the expressions to build the grouped list - -- Build a pattern that ensures the consumer binds into the NEW binders, - -- which hold monads rather than single values - ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs - - ; body <- dsMcStmts stmts_rest - ; n_tup_var' <- newSysLocalDsNoLP n_tup_ty' - ; tup_n_var' <- newSysLocalDs tup_n_ty' - ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys - ; us <- newUniqueSupply - ; let rhs' = mkApps usingExpr' usingArgs' - body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr' - - ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } - --- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel --- statements, for example: --- --- [ body | qs1 | qs2 | qs3 ] --- -> [ body | (bndrs1, (bndrs2, bndrs3)) --- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ] --- --- where `mzip` has type --- mzip :: forall a b. m a -> m b -> m (a,b) --- NB: we need a polymorphic mzip because we call it several times - -dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest - = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) - ; mzip_op' <- dsExpr mzip_op - - ; let -- The pattern variables - pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks] - -- Pattern with tuples of variables - -- [v1,v2,v3] => (v1, (v2, v3)) - pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats - (rhs, _) = foldr1 (\(e1,t1) (e2,t2) -> - (mkApps mzip_op' [Type t1, Type t2, e1, e2], - mkBoxedTupleTy [t1,t2])) - exps_w_tys - - ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest } - where - ds_inner (ParStmtBlock stmts bndrs return_op) - = do { exp <- dsInnerMonadComp stmts bndrs return_op - ; return (exp, mkBigCoreVarTupTy bndrs) } - -dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) - - -matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr --- (matchTuple [a,b,c] body) --- returns the Core term --- \x. case x of (a,b,c) -> body -matchTuple ids body - = do { us <- newUniqueSupply - ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids) - ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } - --- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a --- desugared `CoreExpr` -dsMcBindStmt :: LPat Id - -> CoreExpr -- ^ the desugared rhs of the bind statement - -> SyntaxExpr Id - -> SyntaxExpr Id - -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T - -> [ExprLStmt Id] - -> DsM CoreExpr -dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts - = do { body <- dsMcStmts stmts - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat - res1_ty (cantFailMatchResult body) - ; match_code <- handle_failure pat match fail_op - ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } - - where - -- In a monad comprehension expression, pattern-match failure just calls - -- the monadic `fail` rather than throwing an exception - handle_failure pat match fail_op - | matchCanFail match - = do { dflags <- getDynFlags - ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) - ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] - ; extractMatchResult match fail_expr } - | otherwise - = extractMatchResult match (error "It can't fail") - - mk_fail_msg :: DynFlags -> Located e -> String - mk_fail_msg dflags pat - = "Pattern match failure in monad comprehension at " ++ - showPpr dflags (getLoc pat) - --- Desugar nested monad comprehensions, for example in `then..` constructs --- dsInnerMonadComp quals [a,b,c] ret_op --- returns the desugaring of --- [ (a,b,c) | quals ] - -dsInnerMonadComp :: [ExprLStmt Id] - -> [Id] -- Return a tuple of these variables - -> SyntaxExpr Id -- The monomorphic "return" operator - -> DsM CoreExpr -dsInnerMonadComp stmts bndrs ret_op - = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)]) - - --- The `unzip` function for `GroupStmt` in a monad comprehensions --- --- unzip :: m (a,b,..) -> (m a,m b,..) --- unzip m_tuple = ( liftM selN1 m_tuple --- , liftM selN2 m_tuple --- , .. ) --- --- mkMcUnzipM fmap ys [t1, t2] --- = ( fmap (selN1 :: (t1, t2) -> t1) ys --- , fmap (selN2 :: (t1, t2) -> t2) ys ) - -mkMcUnzipM :: TransForm - -> HsExpr TcId -- fmap - -> Id -- Of type n (a,b,c) - -> [Type] -- [a,b,c] (not levity-polymorphic) - -> DsM CoreExpr -- Of type (n a, n b, n c) -mkMcUnzipM ThenForm _ ys _ - = return (Var ys) -- No unzipping to do - -mkMcUnzipM _ fmap_op ys elt_tys - = do { fmap_op' <- dsExpr fmap_op - ; xs <- mapM newSysLocalDs elt_tys - ; let tup_ty = mkBigCoreTupTy elt_tys - ; tup_xs <- newSysLocalDs tup_ty - - ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b - [ Type tup_ty, Type (getNth elt_tys i) - , mk_sel i, Var ys] - - mk_sel n = Lam tup_xs $ - mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) - - ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } diff --git a/deSugar/DsMeta.hs b/deSugar/DsMeta.hs deleted file mode 100644 --- a/deSugar/DsMeta.hs +++ /dev/null @@ -1,2513 +0,0 @@ -{-# LANGUAGE CPP, TypeFamilies #-} - ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2006 --- --- The purpose of this module is to transform an HsExpr into a CoreExpr which --- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the --- input HsExpr. We do this in the DsM monad, which supplies access to --- CoreExpr's of the "smart constructors" of the Meta.Exp datatype. --- --- It also defines a bunch of knownKeyNames, in the same way as is done --- in prelude/PrelNames. It's much more convenient to do it here, because --- otherwise we have to recompile PrelNames whenever we add a Name, which is --- a Royal Pain (triggers other recompilation). ------------------------------------------------------------------------------ - -module DsMeta( dsBracket ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} DsExpr ( dsExpr ) - -import MatchLit -import DsMonad - -import qualified Language.Haskell.TH as TH - -import HsSyn -import Class -import PrelNames --- To avoid clashes with DsMeta.varName we must make a local alias for --- OccName.varName we do this by removing varName from the import of --- OccName above, making a qualified instance of OccName and using --- OccNameAlias.varName where varName ws previously used in this file. -import qualified OccName( isDataOcc, isVarOcc, isTcOcc ) - -import Module -import Id -import Name hiding( isVarOcc, isTcOcc, varName, tcName ) -import THNames -import NameEnv -import NameSet -import TcType -import TyCon -import TysWiredIn -import CoreSyn -import MkCore -import CoreUtils -import SrcLoc -import Unique -import BasicTypes -import Outputable -import Bag -import DynFlags -import FastString -import ForeignCall -import Util -import Maybes -import MonadUtils - -import Data.ByteString ( unpack ) -import Control.Monad -import Data.List - ------------------------------------------------------------------------------ -dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr --- Returns a CoreExpr of type TH.ExpQ --- The quoted thing is parameterised over Name, even though it has --- been type checked. We don't want all those type decorations! - -dsBracket brack splices - = dsExtendMetaEnv new_bit (do_brack brack) - where - new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices] - - do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 } - do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } - do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 } - do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } - do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } - do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL" - do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 } - -{- -------------- Examples -------------------- - - [| \x -> x |] -====> - gensym (unpackString "x"#) `bindQ` \ x1::String -> - lam (pvar x1) (var x1) - - - [| \x -> $(f [| x |]) |] -====> - gensym (unpackString "x"#) `bindQ` \ x1::String -> - lam (pvar x1) (f (var x1)) --} - - -------------------------------------------------------- --- Declarations -------------------------------------------------------- - -repTopP :: LPat Name -> DsM (Core TH.PatQ) -repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) - ; pat' <- addBinds ss (repLP pat) - ; wrapGenSyms ss pat' } - -repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) -repTopDs group@(HsGroup { hs_valds = valds - , hs_splcds = splcds - , hs_tyclds = tyclds - , hs_derivds = derivds - , hs_fixds = fixds - , hs_defds = defds - , hs_fords = fords - , hs_warnds = warnds - , hs_annds = annds - , hs_ruleds = ruleds - , hs_vects = vects - , hs_docs = docs }) - = do { let { bndrs = hsSigTvBinders valds - ++ hsGroupBinders group - ++ hsPatSynSelectors valds - ; instds = tyclds >>= group_instds } ; - ss <- mkGenSyms bndrs ; - - -- Bind all the names mainly to avoid repeated use of explicit strings. - -- Thus we get - -- do { t :: String <- genSym "T" ; - -- return (Data t [] ...more t's... } - -- The other important reason is that the output must mention - -- only "T", not "Foo:T" where Foo is the current module - - decls <- addBinds ss ( - do { val_ds <- rep_val_binds valds - ; _ <- mapM no_splice splcds - ; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds) - ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) - ; inst_ds <- mapM repInstD instds - ; deriv_ds <- mapM repStandaloneDerivD derivds - ; fix_ds <- mapM repFixD fixds - ; _ <- mapM no_default_decl defds - ; for_ds <- mapM repForD fords - ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc) - warnds) - ; ann_ds <- mapM repAnnD annds - ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc) - ruleds) - ; _ <- mapM no_vect vects - ; _ <- mapM no_doc docs - - -- more needed - ; return (de_loc $ sort_by_loc $ - val_ds ++ catMaybes tycl_ds ++ role_ds - ++ (concat fix_ds) - ++ inst_ds ++ rule_ds ++ for_ds - ++ ann_ds ++ deriv_ds) }) ; - - decl_ty <- lookupType decQTyConName ; - let { core_list = coreList' decl_ty decls } ; - - dec_ty <- lookupType decTyConName ; - q_decs <- repSequenceQ dec_ty core_list ; - - wrapGenSyms ss q_decs - } - where - no_splice (L loc _) - = notHandledL loc "Splices within declaration brackets" empty - no_default_decl (L loc decl) - = notHandledL loc "Default declarations" (ppr decl) - no_warn (L loc (Warning thing _)) - = notHandledL loc "WARNING and DEPRECATION pragmas" $ - text "Pragma for declaration of" <+> ppr thing - no_vect (L loc decl) - = notHandledL loc "Vectorisation pragmas" (ppr decl) - no_doc (L loc _) - = notHandledL loc "Haddock documentation" empty - -hsSigTvBinders :: HsValBinds Name -> [Name] --- See Note [Scoped type variables in bindings] -hsSigTvBinders binds - = concatMap get_scoped_tvs sigs - where - get_scoped_tvs :: LSig Name -> [Name] - -- Both implicit and explicit quantified variables - -- We need the implicit ones for f :: forall (a::k). blah - -- here 'k' scopes too - get_scoped_tvs (L _ (TypeSig _ sig)) - | HsIB { hsib_vars = implicit_vars - , hsib_body = hs_ty } <- hswc_body sig - , (explicit_vars, _) <- splitLHsForAllTy hs_ty - = implicit_vars ++ map hsLTyVarName explicit_vars - get_scoped_tvs _ = [] - - sigs = case binds of - ValBindsIn _ sigs -> sigs - ValBindsOut _ sigs -> sigs - -{- Notes - -Note [Scoped type variables in bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall a. a -> a - f x = x::a -Here the 'forall a' brings 'a' into scope over the binding group. -To achieve this we - - a) Gensym a binding for 'a' at the same time as we do one for 'f' - collecting the relevant binders with hsSigTvBinders - - b) When processing the 'forall', don't gensym - -The relevant places are signposted with references to this Note - -Note [Binders and occurrences] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we desugar [d| data T = MkT |] -we want to get - Data "T" [] [Con "MkT" []] [] -and *not* - Data "Foo:T" [] [Con "Foo:MkT" []] [] -That is, the new data decl should fit into whatever new module it is -asked to fit in. We do *not* clone, though; no need for this: - Data "T79" .... - -But if we see this: - data T = MkT - foo = reifyDecl T - -then we must desugar to - foo = Data "Foo:T" [] [Con "Foo:MkT" []] [] - -So in repTopDs we bring the binders into scope with mkGenSyms and addBinds. -And we use lookupOcc, rather than lookupBinder -in repTyClD and repC. - -Note [Don't quantify implicit type variables in quotes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you're not careful, it's suprisingly easy to take this quoted declaration: - - [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b - idProxy x = x - |] - -and have Template Haskell turn it into this: - - idProxy :: forall k proxy (b :: k). proxy b -> proxy b - idProxy x = x - -Notice that we explicitly quantified the variable `k`! This is quite bad, as the -latter declaration requires -XTypeInType, while the former does not. Not to -mention that the latter declaration isn't even what the user wrote in the -first place. - -Usually, the culprit behind these bugs is taking implicitly quantified type -variables (often from the hsib_vars field of HsImplicitBinders) and putting -them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. --} - --- represent associated family instances --- -repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) - -repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam) - -repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - repSynDecl tc1 bndrs rhs - ; return (Just (loc, dec)) } - -repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - repDataDefn tc1 bndrs Nothing defn - ; return (Just (loc, dec)) } - -repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, - tcdTyVars = tvs, tcdFDs = fds, - tcdSigs = sigs, tcdMeths = meth_binds, - tcdATs = ats, tcdATDefs = atds })) - = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> - do { cxt1 <- repLContext cxt - ; sigs1 <- rep_sigs sigs - ; binds1 <- rep_binds meth_binds - ; fds1 <- repLFunDeps fds - ; ats1 <- repFamilyDecls ats - ; atds1 <- repAssocTyFamDefaults atds - ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs1 ++ binds1) - ; repClass cxt1 cls1 bndrs fds1 decls1 - } - ; return $ Just (loc, dec) - } - -------------------------- -repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repRoleD (L loc (RoleAnnotDecl tycon roles)) - = do { tycon1 <- lookupLOcc tycon - ; roles1 <- mapM repRole roles - ; roles2 <- coreList roleTyConName roles1 - ; dec <- repRoleAnnotD tycon1 roles2 - ; return (loc, dec) } - -------------------------- -repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr] - -> Maybe (Core [TH.TypeQ]) - -> HsDataDefn Name - -> DsM (Core TH.DecQ) -repDataDefn tc bndrs opt_tys - (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig - , dd_cons = cons, dd_derivs = mb_derivs }) - = do { cxt1 <- repLContext cxt - ; derivs1 <- repDerivs mb_derivs - ; case (new_or_data, cons) of - (NewType, [con]) -> do { con' <- repC con - ; ksig' <- repMaybeLKind ksig - ; repNewtype cxt1 tc bndrs opt_tys ksig' con' - derivs1 } - (NewType, _) -> failWithDs (text "Multiple constructors for newtype:" - <+> pprQuotedList - (getConNames $ unLoc $ head cons)) - (DataType, _) -> do { ksig' <- repMaybeLKind ksig - ; consL <- mapM repC cons - ; cons1 <- coreList conQTyConName consL - ; repData cxt1 tc bndrs opt_tys ksig' cons1 - derivs1 } - } - -repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr] - -> LHsType Name - -> DsM (Core TH.DecQ) -repSynDecl tc bndrs ty - = do { ty1 <- repLTy ty - ; repTySyn tc bndrs ty1 } - -repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, - fdLName = tc, - fdTyVars = tvs, - fdResultSig = L _ resultSig, - fdInjectivityAnn = injectivity })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name - mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs - , hsq_dependent = emptyNameSet } - resTyVar = case resultSig of - TyVarSig bndr -> mkHsQTvs [bndr] - _ -> mkHsQTvs [] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - addTyClTyVarBinds resTyVar $ \_ -> - case info of - ClosedTypeFamily Nothing -> - notHandled "abstract closed type family" (ppr decl) - ClosedTypeFamily (Just eqns) -> - do { eqns1 <- mapM repTyFamEqn eqns - ; eqns2 <- coreList tySynEqnQTyConName eqns1 - ; result <- repFamilyResultSig resultSig - ; inj <- repInjectivityAnn injectivity - ; repClosedFamilyD tc1 bndrs result inj eqns2 } - OpenTypeFamily -> - do { result <- repFamilyResultSig resultSig - ; inj <- repInjectivityAnn injectivity - ; repOpenFamilyD tc1 bndrs result inj } - DataFamily -> - do { kind <- repFamilyResultSigToMaybeKind resultSig - ; repDataFamilyD tc1 bndrs kind } - ; return (loc, dec) - } - --- | Represent result signature of a type family -repFamilyResultSig :: FamilyResultSig Name -> DsM (Core TH.FamilyResultSig) -repFamilyResultSig NoSig = repNoSig -repFamilyResultSig (KindSig ki) = do { ki' <- repLKind ki - ; repKindSig ki' } -repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr - ; repTyVarSig bndr' } - --- | Represent result signature using a Maybe Kind. Used with data families, --- where the result signature can be either missing or a kind but never a named --- result variable. -repFamilyResultSigToMaybeKind :: FamilyResultSig Name - -> DsM (Core (Maybe TH.Kind)) -repFamilyResultSigToMaybeKind NoSig = - do { coreNothing kindTyConName } -repFamilyResultSigToMaybeKind (KindSig ki) = - do { ki' <- repLKind ki - ; coreJust kindTyConName ki' } -repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind" - --- | Represent injectivity annotation of a type family -repInjectivityAnn :: Maybe (LInjectivityAnn Name) - -> DsM (Core (Maybe TH.InjectivityAnn)) -repInjectivityAnn Nothing = - do { coreNothing injAnnTyConName } -repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = - do { lhs' <- lookupBinder (unLoc lhs) - ; rhs1 <- mapM (lookupBinder . unLoc) rhs - ; rhs2 <- coreList nameTyConName rhs1 - ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2] - ; coreJust injAnnTyConName injAnn } - -repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ] -repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) - -repAssocTyFamDefaults :: [LTyFamDefltEqn Name] -> DsM [Core TH.DecQ] -repAssocTyFamDefaults = mapM rep_deflt - where - -- very like repTyFamEqn, but different in the details - rep_deflt :: LTyFamDefltEqn Name -> DsM (Core TH.DecQ) - rep_deflt (L _ (TyFamEqn { tfe_tycon = tc - , tfe_pats = bndrs - , tfe_rhs = rhs })) - = addTyClTyVarBinds bndrs $ \ _ -> - do { tc1 <- lookupLOcc tc - ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs) - ; tys2 <- coreList typeQTyConName tys1 - ; rhs1 <- repLTy rhs - ; eqn1 <- repTySynEqn tys2 rhs1 - ; repTySynInst tc1 eqn1 } - -------------------------- --- represent fundeps --- -repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep]) -repLFunDeps fds = repList funDepTyConName repLFunDep fds - -repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep) -repLFunDep (L _ (xs, ys)) - = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs - ys' <- repList nameTyConName (lookupBinder . unLoc) ys - repFunDep xs' ys' - --- Represent instance declarations --- -repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) - = do { dec <- repTyFamInstD fi_decl - ; return (loc, dec) } -repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) - = do { dec <- repDataFamInstD fi_decl - ; return (loc, dec) } -repInstD (L loc (ClsInstD { cid_inst = cls_decl })) - = do { dec <- repClsInstD cls_decl - ; return (loc, dec) } - -repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ) -repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds - , cid_sigs = prags, cid_tyfam_insts = ats - , cid_datafam_insts = adts - , cid_overlap_mode = overlap - }) - = addSimpleTyVarBinds tvs $ - -- We must bring the type variables into scope, so their - -- occurrences don't fail, even though the binders don't - -- appear in the resulting data structure - -- - -- But we do NOT bring the binders of 'binds' into scope - -- because they are properly regarded as occurrences - -- For example, the method names should be bound to - -- the selector Ids, not to fresh names (Trac #5410) - -- - do { cxt1 <- repLContext cxt - ; inst_ty1 <- repLTy inst_ty - ; binds1 <- rep_binds binds - ; prags1 <- rep_sigs prags - ; ats1 <- mapM (repTyFamInstD . unLoc) ats - ; adts1 <- mapM (repDataFamInstD . unLoc) adts - ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1) - ; rOver <- repOverlap (fmap unLoc overlap) - ; repInst rOver cxt1 inst_ty1 decls } - where - (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty - -repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat - , deriv_type = ty })) - = do { dec <- addSimpleTyVarBinds tvs $ - do { cxt' <- repLContext cxt - ; strat' <- repDerivStrategy strat - ; inst_ty' <- repLTy inst_ty - ; repDeriv strat' cxt' inst_ty' } - ; return (loc, dec) } - where - (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty - -repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) -repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) - = do { let tc_name = tyFamInstDeclLName decl - ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; eqn1 <- repTyFamEqn eqn - ; repTySynInst tc eqn1 } - -repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) -repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys - , hsib_vars = var_names } - , tfe_rhs = rhs })) - = do { let hs_tvs = HsQTvs { hsq_implicit = var_names - , hsq_explicit = [] - , hsq_dependent = emptyNameSet } -- Yuk - ; addTyClTyVarBinds hs_tvs $ \ _ -> - do { tys1 <- repLTys tys - ; tys2 <- coreList typeQTyConName tys1 - ; rhs1 <- repLTy rhs - ; repTySynEqn tys2 rhs1 } } - -repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ) -repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name - , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names } - , dfid_defn = defn }) - = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; let hs_tvs = HsQTvs { hsq_implicit = var_names - , hsq_explicit = [] - , hsq_dependent = emptyNameSet } -- Yuk - ; addTyClTyVarBinds hs_tvs $ \ bndrs -> - do { tys1 <- repList typeQTyConName repLTy tys - ; repDataDefn tc bndrs (Just tys1) defn } } - -repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) -repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ - , fd_fi = CImport (L _ cc) (L _ s) mch cis _ })) - = do MkC name' <- lookupLOcc name - MkC typ' <- repHsSigType typ - MkC cc' <- repCCallConv cc - MkC s' <- repSafety s - cis' <- conv_cimportspec cis - MkC str <- coreStringLit (static ++ chStr ++ cis') - dec <- rep2 forImpDName [cc', s', str, name', typ'] - return (loc, dec) - where - conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls)) - conv_cimportspec (CFunction DynamicTarget) = return "dynamic" - conv_cimportspec (CFunction (StaticTarget _ fs _ True)) - = return (unpackFS fs) - conv_cimportspec (CFunction (StaticTarget _ _ _ False)) - = panic "conv_cimportspec: values not supported yet" - conv_cimportspec CWrapper = return "wrapper" - -- these calling conventions do not support headers and the static keyword - raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv - static = case cis of - CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static " - _ -> "" - chStr = case mch of - Just (Header _ h) | not raw_cconv -> unpackFS h ++ " " - _ -> "" -repForD decl = notHandled "Foreign declaration" (ppr decl) - -repCCallConv :: CCallConv -> DsM (Core TH.Callconv) -repCCallConv CCallConv = rep2 cCallName [] -repCCallConv StdCallConv = rep2 stdCallName [] -repCCallConv CApiConv = rep2 cApiCallName [] -repCCallConv PrimCallConv = rep2 primCallName [] -repCCallConv JavaScriptCallConv = rep2 javaScriptCallName [] - -repSafety :: Safety -> DsM (Core TH.Safety) -repSafety PlayRisky = rep2 unsafeName [] -repSafety PlayInterruptible = rep2 interruptibleName [] -repSafety PlaySafe = rep2 safeName [] - -repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)] -repFixD (L loc (FixitySig names (Fixity _ prec dir))) - = do { MkC prec' <- coreIntLit prec - ; let rep_fn = case dir of - InfixL -> infixLDName - InfixR -> infixRDName - InfixN -> infixNDName - ; let do_one name - = do { MkC name' <- lookupLOcc name - ; dec <- rep2 rep_fn [prec', name'] - ; return (loc,dec) } - ; mapM do_one names } - -repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) - = do { let bndr_names = concatMap ruleBndrNames bndrs - ; ss <- mkGenSyms bndr_names - ; rule1 <- addBinds ss $ - do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs - ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n - ; act' <- repPhases act - ; lhs' <- repLE lhs - ; rhs' <- repLE rhs - ; repPragRule n' bndrs' lhs' rhs' act' } - ; rule2 <- wrapGenSyms ss rule1 - ; return (loc, rule2) } - -ruleBndrNames :: LRuleBndr Name -> [Name] -ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] -ruleBndrNames (L _ (RuleBndrSig n sig)) - | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig - = unLoc n : vars - -repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ) -repRuleBndr (L _ (RuleBndr n)) - = do { MkC n' <- lookupLBinder n - ; rep2 ruleVarName [n'] } -repRuleBndr (L _ (RuleBndrSig n sig)) - = do { MkC n' <- lookupLBinder n - ; MkC ty' <- repLTy (hsSigWcType sig) - ; rep2 typedRuleVarName [n', ty'] } - -repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) - = do { target <- repAnnProv ann_prov - ; exp' <- repE exp - ; dec <- repPragAnn target exp' - ; return (loc, dec) } - -repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) -repAnnProv (ValueAnnProvenance (L _ n)) - = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level - ; rep2 valueAnnotationName [ n' ] } -repAnnProv (TypeAnnProvenance (L _ n)) - = do { MkC n' <- globalVar n - ; rep2 typeAnnotationName [ n' ] } -repAnnProv ModuleAnnProvenance - = rep2 moduleAnnotationName [] - -------------------------------------------------------- --- Constructors -------------------------------------------------------- - -repC :: LConDecl Name -> DsM (Core TH.ConQ) -repC (L _ (ConDeclH98 { con_name = con - , con_qvars = Nothing, con_cxt = Nothing - , con_details = details })) - = repDataCon con details - -repC (L _ (ConDeclH98 { con_name = con - , con_qvars = mcon_tvs, con_cxt = mcxt - , con_details = details })) - = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs - ctxt = unLoc $ fromMaybe (noLoc []) mcxt - ; addTyVarBinds con_tvs $ \ ex_bndrs -> - do { c' <- repDataCon con details - ; ctxt' <- repContext ctxt - ; if isEmptyLHsQTvs con_tvs && null ctxt - then return c' - else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) - } - } - -repC (L _ (ConDeclGADT { con_names = cons - , con_type = res_ty@(HsIB { hsib_vars = imp_tvs })})) - | (details, res_ty', L _ [] , []) <- gadtDetails - , [] <- imp_tvs - -- no implicit or explicit variables, no context = no need for a forall - = do { let doc = text "In the constructor for " <+> ppr (head cons) - ; (hs_details, gadt_res_ty) <- - updateGadtResult failWithDs doc details res_ty' - ; repGadtDataCons cons hs_details gadt_res_ty } - - | (details,res_ty',ctxt, exp_tvs) <- gadtDetails - = do { let doc = text "In the constructor for " <+> ppr (head cons) - con_tvs = HsQTvs { hsq_implicit = imp_tvs - , hsq_explicit = exp_tvs - , hsq_dependent = emptyNameSet } - -- NB: Don't put imp_tvs into the hsq_explicit field above - -- See Note [Don't quantify implicit type variables in quotes] - ; addTyVarBinds con_tvs $ \ ex_bndrs -> do - { (hs_details, gadt_res_ty) <- - updateGadtResult failWithDs doc details res_ty' - ; c' <- repGadtDataCons cons hs_details gadt_res_ty - ; ctxt' <- repContext (unLoc ctxt) - ; if null exp_tvs && null (unLoc ctxt) - then return c' - else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } } - where - gadtDetails = gadtDeclDetails res_ty - -repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ) -repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] -repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName [] -repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName [] - -repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ) -repSrcStrictness SrcLazy = rep2 sourceLazyName [] -repSrcStrictness SrcStrict = rep2 sourceStrictName [] -repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] - -repBangTy :: LBangType Name -> DsM (Core (TH.BangTypeQ)) -repBangTy ty = do - MkC u <- repSrcUnpackedness su' - MkC s <- repSrcStrictness ss' - MkC b <- rep2 bangName [u, s] - MkC t <- repLTy ty' - rep2 bangTypeName [b, t] - where - (su', ss', ty') = case ty of - L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty) - _ -> (NoSrcUnpack, NoSrcStrict, ty) - -------------------------------------------------------- --- Deriving clauses -------------------------------------------------------- - -repDerivs :: HsDeriving Name -> DsM (Core [TH.DerivClauseQ]) -repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses - -repDerivClause :: LHsDerivingClause Name - -> DsM (Core TH.DerivClauseQ) -repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = L _ dct })) - = do MkC dcs' <- repDerivStrategy dcs - MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct - rep2 derivClauseName [dcs',dct'] - where - rep_deriv_ty :: LHsType Name -> DsM (Core TH.TypeQ) - rep_deriv_ty (L _ ty) = repTy ty - -------------------------------------------------------- --- Signatures in a class decl, or a group of bindings -------------------------------------------------------- - -rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ] -rep_sigs sigs = do locs_cores <- rep_sigs' sigs - return $ de_loc $ sort_by_loc locs_cores - -rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)] - -- We silently ignore ones we don't recognise -rep_sigs' = concatMapM rep_sig - -rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms -rep_sig (L loc (PatSynSig nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms -rep_sig (L loc (ClassOpSig is_deflt nms ty)) - | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms - | otherwise = mapM (rep_ty_sig sigDName loc ty) nms -rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) -rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level -rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc -rep_sig (L loc (SpecSig nm tys ispec)) - = concatMapM (\t -> rep_specialise nm t ispec loc) tys -rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc -rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty -rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty -rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc - - -rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name - -> DsM (SrcSpan, Core TH.DecQ) -rep_ty_sig mk_sig loc sig_ty nm - = do { nm1 <- lookupLOcc nm - ; ty1 <- repHsSigType sig_ty - ; sig <- repProto mk_sig nm1 ty1 - ; return (loc, sig) } - -rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name - -> DsM (SrcSpan, Core TH.DecQ) --- represents a pattern synonym type signature; --- see Note [Pattern synonym type signatures and Template Haskell] in Convert -rep_patsyn_ty_sig loc sig_ty nm - = do { nm1 <- lookupLOcc nm - ; ty1 <- repHsPatSynSigType sig_ty - ; sig <- repProto patSynSigDName nm1 ty1 - ; return (loc, sig) } - -rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name - -> DsM (SrcSpan, Core TH.DecQ) - -- We must special-case the top-level explicit for-all of a TypeSig - -- See Note [Scoped type variables in bindings] -rep_wc_ty_sig mk_sig loc sig_ty nm - | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty - , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty - = do { nm1 <- lookupLOcc nm - ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) - ; repTyVarBndrWithKind tv name } - ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv - explicit_tvs - -- NB: Don't pass any implicit type variables to repList above - -- See Note [Don't quantify implicit type variables in quotes] - - ; th_ctxt <- repLContext ctxt - ; th_ty <- repLTy ty - ; ty1 <- if null explicit_tvs && null (unLoc ctxt) - then return th_ty - else repTForall th_explicit_tvs th_ctxt th_ty - ; sig <- repProto mk_sig nm1 ty1 - ; return (loc, sig) } - -rep_inline :: Located Name - -> InlinePragma -- Never defaultInlinePragma - -> SrcSpan - -> DsM [(SrcSpan, Core TH.DecQ)] -rep_inline nm ispec loc - = do { nm1 <- lookupLOcc nm - ; inline <- repInline $ inl_inline ispec - ; rm <- repRuleMatch $ inl_rule ispec - ; phases <- repPhases $ inl_act ispec - ; pragma <- repPragInl nm1 inline rm phases - ; return [(loc, pragma)] - } - -rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan - -> DsM [(SrcSpan, Core TH.DecQ)] -rep_specialise nm ty ispec loc - = do { nm1 <- lookupLOcc nm - ; ty1 <- repHsSigType ty - ; phases <- repPhases $ inl_act ispec - ; let inline = inl_inline ispec - ; pragma <- if isEmptyInlineSpec inline - then -- SPECIALISE - repPragSpec nm1 ty1 phases - else -- SPECIALISE INLINE - do { inline1 <- repInline inline - ; repPragSpecInl nm1 ty1 inline1 phases } - ; return [(loc, pragma)] - } - -rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] -rep_specialiseInst ty loc - = do { ty1 <- repHsSigType ty - ; pragma <- repPragSpecInst ty1 - ; return [(loc, pragma)] } - -repInline :: InlineSpec -> DsM (Core TH.Inline) -repInline NoInline = dataCon noInlineDataConName -repInline Inline = dataCon inlineDataConName -repInline Inlinable = dataCon inlinableDataConName -repInline spec = notHandled "repInline" (ppr spec) - -repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch) -repRuleMatch ConLike = dataCon conLikeDataConName -repRuleMatch FunLike = dataCon funLikeDataConName - -repPhases :: Activation -> DsM (Core TH.Phases) -repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i - ; dataCon' beforePhaseDataConName [arg] } -repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i - ; dataCon' fromPhaseDataConName [arg] } -repPhases _ = dataCon allPhasesDataConName - -rep_complete_sig :: Located [Located Name] - -> Maybe (Located Name) - -> SrcSpan - -> DsM [(SrcSpan, Core TH.DecQ)] -rep_complete_sig (L _ cls) mty loc - = do { mty' <- rep_maybe_name mty - ; cls' <- repList nameTyConName lookupLOcc cls - ; sig <- repPragComplete cls' mty' - ; return [(loc, sig)] } - where - rep_maybe_name Nothing = coreNothing nameTyConName - rep_maybe_name (Just n) = do - cn <- lookupLOcc n - coreJust nameTyConName cn - -------------------------------------------------------- --- Types -------------------------------------------------------- - -addSimpleTyVarBinds :: [Name] -- the binders to be added - -> DsM (Core (TH.Q a)) -- action in the ext env - -> DsM (Core (TH.Q a)) -addSimpleTyVarBinds names thing_inside - = do { fresh_names <- mkGenSyms names - ; term <- addBinds fresh_names thing_inside - ; wrapGenSyms fresh_names term } - -addTyVarBinds :: LHsQTyVars Name -- the binders to be added - -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env - -> DsM (Core (TH.Q a)) --- gensym a list of type variables and enter them into the meta environment; --- the computations passed as the second argument is executed in that extended --- meta environment and gets the *new* names on Core-level as an argument - -addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m - = do { fresh_imp_names <- mkGenSyms imp_tvs - ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs) - ; let fresh_names = fresh_imp_names ++ fresh_exp_names - ; term <- addBinds fresh_names $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr - (exp_tvs `zip` fresh_exp_names) - ; m kbs } - ; wrapGenSyms fresh_names term } - where - mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) - -addTyClTyVarBinds :: LHsQTyVars Name - -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) - -> DsM (Core (TH.Q a)) - --- Used for data/newtype declarations, and family instances, --- so that the nested type variables work right --- instance C (T a) where --- type W (T a) = blah --- The 'a' in the type instance is the one bound by the instance decl -addTyClTyVarBinds tvs m - = do { let tv_names = hsAllLTyVarNames tvs - ; env <- dsGetMetaEnv - ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) - -- Make fresh names for the ones that are not already in scope - -- This makes things work for family declarations - - ; term <- addBinds freshNames $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs) - ; m kbs } - - ; wrapGenSyms freshNames term } - where - mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) - ; repTyVarBndrWithKind tv v } - --- Produce kinded binder constructors from the Haskell tyvar binders --- -repTyVarBndrWithKind :: LHsTyVarBndr Name - -> Core TH.Name -> DsM (Core TH.TyVarBndr) -repTyVarBndrWithKind (L _ (UserTyVar _)) nm - = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm - = repLKind ki >>= repKindedTV nm - --- | Represent a type variable binder -repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr) -repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm - ; repPlainTV nm' } -repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm - ; ki' <- repLKind ki - ; repKindedTV nm' ki' } - --- represent a type context --- -repLContext :: LHsContext Name -> DsM (Core TH.CxtQ) -repLContext (L _ ctxt) = repContext ctxt - -repContext :: HsContext Name -> DsM (Core TH.CxtQ) -repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt - repCtxt preds - -repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ) -repHsSigType (HsIB { hsib_vars = implicit_tvs - , hsib_body = body }) - | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body - = addTyVarBinds (HsQTvs { hsq_implicit = implicit_tvs - , hsq_explicit = explicit_tvs - , hsq_dependent = emptyNameSet }) - -- NB: Don't pass implicit_tvs to the hsq_explicit field above - -- See Note [Don't quantify implicit type variables in quotes] - $ \ th_explicit_tvs -> - do { th_ctxt <- repLContext ctxt - ; th_ty <- repLTy ty - ; if null explicit_tvs && null (unLoc ctxt) - then return th_ty - else repTForall th_explicit_tvs th_ctxt th_ty } - -repHsPatSynSigType :: LHsSigType Name -> DsM (Core TH.TypeQ) -repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs - , hsib_body = body }) - = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs -> - addTyVarBinds (newTvs [] exis) $ \th_exis -> - do { th_reqs <- repLContext reqs - ; th_provs <- repLContext provs - ; th_ty <- repLTy ty - ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) } - where - newTvs impl_tvs expl_tvs = HsQTvs - { hsq_implicit = impl_tvs - , hsq_explicit = expl_tvs - , hsq_dependent = emptyNameSet } - -- NB: Don't pass impl_tvs to the hsq_explicit field above - -- See Note [Don't quantify implicit type variables in quotes] - - (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body - -repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ) -repHsSigWcType (HsWC { hswc_body = sig1 }) - = repHsSigType sig1 - --- yield the representation of a list of types -repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] -repLTys tys = mapM repLTy tys - --- represent a type -repLTy :: LHsType Name -> DsM (Core TH.TypeQ) -repLTy (L _ ty) = repTy ty - -repForall :: HsType Name -> DsM (Core TH.TypeQ) --- Arg of repForall is always HsForAllTy or HsQualTy -repForall ty - | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty) - = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs - , hsq_dependent = emptyNameSet }) $ \bndrs -> - do { ctxt1 <- repLContext ctxt - ; ty1 <- repLTy tau - ; repTForall bndrs ctxt1 ty1 } - -repTy :: HsType Name -> DsM (Core TH.TypeQ) -repTy ty@(HsForAllTy {}) = repForall ty -repTy ty@(HsQualTy {}) = repForall ty - -repTy (HsTyVar _ (L _ n)) - | isTvOcc occ = do tv1 <- lookupOcc n - repTvar tv1 - | isDataOcc occ = do tc1 <- lookupOcc n - repPromotedDataCon tc1 - | n == eqTyConName = repTequality - | otherwise = do tc1 <- lookupOcc n - repNamedTyCon tc1 - where - occ = nameOccName n - -repTy (HsAppTy f a) = do - f1 <- repLTy f - a1 <- repLTy a - repTapp f1 a1 -repTy (HsFunTy f a) = do - f1 <- repLTy f - a1 <- repLTy a - tcon <- repArrowTyCon - repTapps tcon [f1, a1] -repTy (HsListTy t) = do - t1 <- repLTy t - tcon <- repListTyCon - repTapp tcon t1 -repTy (HsPArrTy t) = do - t1 <- repLTy t - tcon <- repTy (HsTyVar NotPromoted - (noLoc (tyConName parrTyCon))) - repTapp tcon t1 -repTy (HsTupleTy HsUnboxedTuple tys) = do - tys1 <- repLTys tys - tcon <- repUnboxedTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys - tcon <- repTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsSumTy tys) = do tys1 <- repLTys tys - tcon <- repUnboxedSumTyCon (length tys) - repTapps tcon tys1 -repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) - `nlHsAppTy` ty2) -repTy (HsParTy t) = repLTy t -repTy (HsEqTy t1 t2) = do - t1' <- repLTy t1 - t2' <- repLTy t2 - eq <- repTequality - repTapps eq [t1', t2'] -repTy (HsKindSig t k) = do - t1 <- repLTy t - k1 <- repLKind k - repTSig t1 k1 -repTy (HsSpliceTy splice _) = repSplice splice -repTy (HsExplicitListTy _ _ tys) = do - tys1 <- repLTys tys - repTPromotedList tys1 -repTy (HsExplicitTupleTy _ tys) = do - tys1 <- repLTys tys - tcon <- repPromotedTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsTyLit lit) = do - lit' <- repTyLit lit - repTLit lit' -repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard - -repTy ty = notHandled "Exotic form of type" (ppr ty) - -repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ) -repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i - rep2 numTyLitName [iExpr] -repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s - ; rep2 strTyLitName [s'] - } - --- represent a kind --- -repLKind :: LHsKind Name -> DsM (Core TH.Kind) -repLKind ki - = do { let (kis, ki') = splitHsFunType ki - ; kis_rep <- mapM repLKind kis - ; ki'_rep <- repNonArrowLKind ki' - ; kcon <- repKArrow - ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2 - ; foldrM f ki'_rep kis_rep - } - --- | Represent a kind wrapped in a Maybe -repMaybeLKind :: Maybe (LHsKind Name) - -> DsM (Core (Maybe TH.Kind)) -repMaybeLKind Nothing = - do { coreNothing kindTyConName } -repMaybeLKind (Just ki) = - do { ki' <- repLKind ki - ; coreJust kindTyConName ki' } - -repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind) -repNonArrowLKind (L _ ki) = repNonArrowKind ki - -repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind) -repNonArrowKind (HsTyVar _ (L _ name)) - | isLiftedTypeKindTyConName name = repKStar - | name `hasKey` constraintKindTyConKey = repKConstraint - | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar - | otherwise = lookupOcc name >>= repKCon -repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f - ; a' <- repLKind a - ; repKApp f' a' - } -repNonArrowKind (HsListTy k) = do { k' <- repLKind k - ; kcon <- repKList - ; repKApp kcon k' - } -repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks - ; kcon <- repKTuple (length ks) - ; repKApps kcon ks' - } -repNonArrowKind k = notHandled "Exotic form of kind" (ppr k) - -repRole :: Located (Maybe Role) -> DsM (Core TH.Role) -repRole (L _ (Just Nominal)) = rep2 nominalRName [] -repRole (L _ (Just Representational)) = rep2 representationalRName [] -repRole (L _ (Just Phantom)) = rep2 phantomRName [] -repRole (L _ Nothing) = rep2 inferRName [] - ------------------------------------------------------------------------------ --- Splices ------------------------------------------------------------------------------ - -repSplice :: HsSplice Name -> DsM (Core a) --- See Note [How brackets and nested splices are handled] in TcSplice --- We return a CoreExpr of any old type; the context should know -repSplice (HsTypedSplice _ n _) = rep_splice n -repSplice (HsUntypedSplice _ n _) = rep_splice n -repSplice (HsQuasiQuote n _ _ _) = rep_splice n -repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e) - -rep_splice :: Name -> DsM (Core a) -rep_splice splice_name - = do { mb_val <- dsLookupMetaEnv splice_name - ; case mb_val of - Just (DsSplice e) -> do { e' <- dsExpr e - ; return (MkC e') } - _ -> pprPanic "HsSplice" (ppr splice_name) } - -- Should not happen; statically checked - ------------------------------------------------------------------------------ --- Expressions ------------------------------------------------------------------------------ - -repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ]) -repLEs es = repList expQTyConName repLE es - --- FIXME: some of these panics should be converted into proper error messages --- unless we can make sure that constructs, which are plainly not --- supported in TH already lead to error messages at an earlier stage -repLE :: LHsExpr Name -> DsM (Core TH.ExpQ) -repLE (L loc e) = putSrcSpanDs loc (repE e) - -repE :: HsExpr Name -> DsM (Core TH.ExpQ) -repE (HsVar (L _ x)) = - do { mb_val <- dsLookupMetaEnv x - ; case mb_val of - Nothing -> do { str <- globalVar x - ; repVarOrCon x str } - Just (DsBound y) -> repVarOrCon x (coreVar y) - Just (DsSplice e) -> do { e' <- dsExpr e - ; return (MkC e') } } -repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) -repE e@(HsOverLabel{}) = notHandled "Overloaded labels" (ppr e) - -repE e@(HsRecFld f) = case f of - Unambiguous _ x -> repE (HsVar (noLoc x)) - Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) - - -- Remember, we're desugaring renamer output here, so - -- HsOverlit can definitely occur -repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } -repE (HsLit l) = do { a <- repLiteral l; repLit a } -repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m -repE (HsLamCase (MG { mg_alts = L _ ms })) - = do { ms' <- mapM repMatchTup ms - ; core_ms <- coreList matchQTyConName ms' - ; repLamCase core_ms } -repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b} -repE (HsAppType e t) = do { a <- repLE e - ; s <- repLTy (hswc_body t) - ; repAppType a s } - -repE (OpApp e1 op _ e2) = - do { arg1 <- repLE e1; - arg2 <- repLE e2; - the_op <- repLE op ; - repInfixApp arg1 the_op arg2 } -repE (NegApp x _) = do - a <- repLE x - negateVar <- lookupOcc negateName >>= repVar - negateVar `repApp` a -repE (HsPar x) = repLE x -repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } -repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase e (MG { mg_alts = L _ ms })) - = do { arg <- repLE e - ; ms2 <- mapM repMatchTup ms - ; core_ms2 <- coreList matchQTyConName ms2 - ; repCaseE arg core_ms2 } -repE (HsIf _ x y z) = do - a <- repLE x - b <- repLE y - c <- repLE z - repCond a b c -repE (HsMultiIf _ alts) - = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts - ; expr' <- repMultiIf (nonEmptyCoreList alts') - ; wrapGenSyms (concat binds) expr' } -repE (HsLet (L _ bs) e) = do { (ss,ds) <- repBinds bs - ; e2 <- addBinds ss (repLE e) - ; z <- repLetE ds e2 - ; wrapGenSyms ss z } - --- FIXME: I haven't got the types here right yet -repE e@(HsDo ctxt (L _ sts) _) - | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } - = do { (ss,zs) <- repLSts sts; - e' <- repDoE (nonEmptyCoreList zs); - wrapGenSyms ss e' } - - | ListComp <- ctxt - = do { (ss,zs) <- repLSts sts; - e' <- repComp (nonEmptyCoreList zs); - wrapGenSyms ss e' } - - | otherwise - = notHandled "mdo, monad comprehension and [: :]" (ppr e) - -repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } -repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) -repE e@(ExplicitTuple es boxed) - | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) - | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs } - | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es] - ; repUnboxedTup xs } - -repE (ExplicitSum alt arity e _) - = do { e1 <- repLE e - ; repUnboxedSum e1 alt arity } - -repE (RecordCon { rcon_con_name = c, rcon_flds = flds }) - = do { x <- lookupLOcc c; - fs <- repFields flds; - repRecCon x fs } -repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) - = do { x <- repLE e; - fs <- repUpdFields flds; - repRecUpd x fs } - -repE (ExprWithTySig e ty) - = do { e1 <- repLE e - ; t1 <- repHsSigWcType ty - ; repSigExp e1 t1 } - -repE (ArithSeq _ _ aseq) = - case aseq of - From e -> do { ds1 <- repLE e; repFrom ds1 } - FromThen e1 e2 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - repFromThen ds1 ds2 - FromTo e1 e2 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - repFromTo ds1 ds2 - FromThenTo e1 e2 e3 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - ds3 <- repLE e3 - repFromThenTo ds1 ds2 ds3 - -repE (HsSpliceE splice) = repSplice splice -repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC -repE (HsUnboundVar uv) = do - occ <- occNameLit (unboundVarOcc uv) - sname <- repNameS occ - repUnboundVar sname - -repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) -repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) -repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) -repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) -repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e) -repE e = notHandled "Expression form" (ppr e) - ------------------------------------------------------------------------------ --- Building representations of auxillary structures like Match, Clause, Stmt, - -repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ) -repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) = - do { ss1 <- mkGenSyms (collectPatBinders p) - ; addBinds ss1 $ do { - ; p1 <- repLP p - ; (ss2,ds) <- repBinds wheres - ; addBinds ss2 $ do { - ; gs <- repGuards guards - ; match <- repMatch p1 gs ds - ; wrapGenSyms (ss1++ss2) match }}} -repMatchTup _ = panic "repMatchTup: case alt with more than one arg" - -repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ) -repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) = - do { ss1 <- mkGenSyms (collectPatsBinders ps) - ; addBinds ss1 $ do { - ps1 <- repLPs ps - ; (ss2,ds) <- repBinds wheres - ; addBinds ss2 $ do { - gs <- repGuards guards - ; clause <- repClause ps1 gs ds - ; wrapGenSyms (ss1++ss2) clause }}} - -repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ) -repGuards [L _ (GRHS [] e)] - = do {a <- repLE e; repNormal a } -repGuards other - = do { zs <- mapM repLGRHS other - ; let (xs, ys) = unzip zs - ; gd <- repGuarded (nonEmptyCoreList ys) - ; wrapGenSyms (concat xs) gd } - -repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) -repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2)) - = do { guarded <- repLNormalGE e1 e2 - ; return ([], guarded) } -repLGRHS (L _ (GRHS ss rhs)) - = do { (gs, ss') <- repLSts ss - ; rhs' <- addBinds gs $ repLE rhs - ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' - ; return (gs, guarded) } - -repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) -repFields (HsRecFields { rec_flds = flds }) - = repList fieldExpQTyConName rep_fld flds - where - rep_fld :: LHsRecField Name (LHsExpr Name) -> DsM (Core (TH.Q TH.FieldExp)) - rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) - ; e <- repLE (hsRecFieldArg fld) - ; repFieldExp fn e } - -repUpdFields :: [LHsRecUpdField Name] -> DsM (Core [TH.Q TH.FieldExp]) -repUpdFields = repList fieldExpQTyConName rep_fld - where - rep_fld :: LHsRecUpdField Name -> DsM (Core (TH.Q TH.FieldExp)) - rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of - Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name) - ; e <- repLE (hsRecFieldArg fld) - ; repFieldExp fn e } - _ -> notHandled "Ambiguous record updates" (ppr fld) - - - ------------------------------------------------------------------------------ --- Representing Stmt's is tricky, especially if bound variables --- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] --- First gensym new names for every variable in any of the patterns. --- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) --- if variables didn't shaddow, the static gensym wouldn't be necessary --- and we could reuse the original names (x and x). --- --- do { x'1 <- gensym "x" --- ; x'2 <- gensym "x" --- ; doE [ BindSt (pvar x'1) [| f 1 |] --- , BindSt (pvar x'2) [| f x |] --- , NoBindSt [| g x |] --- ] --- } - --- The strategy is to translate a whole list of do-bindings by building a --- bigger environment, and a bigger set of meta bindings --- (like: x'1 <- gensym "x" ) and then combining these with the translations --- of the expressions within the Do - ------------------------------------------------------------------------------ --- The helper function repSts computes the translation of each sub expression --- and a bunch of prefix bindings denoting the dynamic renaming. - -repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) -repLSts stmts = repSts (map unLoc stmts) - -repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) -repSts (BindStmt p e _ _ _ : ss) = - do { e2 <- repLE e - ; ss1 <- mkGenSyms (collectPatBinders p) - ; addBinds ss1 $ do { - ; p1 <- repLP p; - ; (ss2,zs) <- repSts ss - ; z <- repBindSt p1 e2 - ; return (ss1++ss2, z : zs) }} -repSts (LetStmt (L _ bs) : ss) = - do { (ss1,ds) <- repBinds bs - ; z <- repLetSt ds - ; (ss2,zs) <- addBinds ss1 (repSts ss) - ; return (ss1++ss2, z : zs) } -repSts (BodyStmt e _ _ _ : ss) = - do { e2 <- repLE e - ; z <- repNoBindSt e2 - ; (ss2,zs) <- repSts ss - ; return (ss2, z : zs) } -repSts (ParStmt stmt_blocks _ _ _ : ss) = - do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks - ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 - ss1 = concat ss_s - ; z <- repParSt stmt_blocks2 - ; (ss2, zs) <- addBinds ss1 (repSts ss) - ; return (ss1++ss2, z : zs) } - where - rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ]) - rep_stmt_block (ParStmtBlock stmts _ _) = - do { (ss1, zs) <- repSts (map unLoc stmts) - ; zs1 <- coreList stmtQTyConName zs - ; return (ss1, zs1) } -repSts [LastStmt e _ _] - = do { e2 <- repLE e - ; z <- repNoBindSt e2 - ; return ([], [z]) } -repSts [] = return ([],[]) -repSts other = notHandled "Exotic statement" (ppr other) - - ------------------------------------------------------------ --- Bindings ------------------------------------------------------------ - -repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) -repBinds EmptyLocalBinds - = do { core_list <- coreList decQTyConName [] - ; return ([], core_list) } - -repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b) - -repBinds (HsValBinds decs) - = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs } - -- No need to worry about detailed scopes within - -- the binding group, because we are talking Names - -- here, so we can safely treat it as a mutually - -- recursive group - -- For hsSigTvBinders see Note [Scoped type variables in bindings] - ; ss <- mkGenSyms bndrs - ; prs <- addBinds ss (rep_val_binds decs) - ; core_list <- coreList decQTyConName - (de_loc (sort_by_loc prs)) - ; return (ss, core_list) } - -rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] --- Assumes: all the binders of the binding are already in the meta-env -rep_val_binds (ValBindsOut binds sigs) - = do { core1 <- rep_binds' (unionManyBags (map snd binds)) - ; core2 <- rep_sigs' sigs - ; return (core1 ++ core2) } -rep_val_binds (ValBindsIn _ _) - = panic "rep_val_binds: ValBindsIn" - -rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] -rep_binds binds = do { binds_w_locs <- rep_binds' binds - ; return (de_loc (sort_by_loc binds_w_locs)) } - -rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] -rep_binds' = mapM rep_bind . bagToList - -rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) --- Assumes: all the binders of the binding are already in the meta-env - --- Note GHC treats declarations of a variable (not a pattern) --- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match --- with an empty list of patterns -rep_bind (L loc (FunBind - { fun_id = fn, - fun_matches = MG { mg_alts - = L _ [L _ (Match _ [] _ - (GRHSs guards (L _ wheres)))] } })) - = do { (ss,wherecore) <- repBinds wheres - ; guardcore <- addBinds ss (repGuards guards) - ; fn' <- lookupLBinder fn - ; p <- repPvar fn' - ; ans <- repVal p guardcore wherecore - ; ans' <- wrapGenSyms ss ans - ; return (loc, ans') } - -rep_bind (L loc (FunBind { fun_id = fn - , fun_matches = MG { mg_alts = L _ ms } })) - = do { ms1 <- mapM repClauseTup ms - ; fn' <- lookupLBinder fn - ; ans <- repFun fn' (nonEmptyCoreList ms1) - ; return (loc, ans) } - -rep_bind (L loc (PatBind { pat_lhs = pat - , pat_rhs = GRHSs guards (L _ wheres) })) - = do { patcore <- repLP pat - ; (ss,wherecore) <- repBinds wheres - ; guardcore <- addBinds ss (repGuards guards) - ; ans <- repVal patcore guardcore wherecore - ; ans' <- wrapGenSyms ss ans - ; return (loc, ans') } - -rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) - = do { v' <- lookupBinder v - ; e2 <- repLE e - ; x <- repNormal e2 - ; patcore <- repPvar v' - ; empty_decls <- coreList decQTyConName [] - ; ans <- repVal patcore x empty_decls - ; return (srcLocSpan (getSrcLoc v), ans) } - -rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" -rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig" -rep_bind (L loc (PatSynBind (PSB { psb_id = syn - , psb_fvs = _fvs - , psb_args = args - , psb_def = pat - , psb_dir = dir }))) - = do { syn' <- lookupLBinder syn - ; dir' <- repPatSynDir dir - ; ss <- mkGenArgSyms args - ; patSynD' <- addBinds ss ( - do { args' <- repPatSynArgs args - ; pat' <- repLP pat - ; repPatSynD syn' args' dir' pat' }) - ; patSynD'' <- wrapGenArgSyms args ss patSynD' - ; return (loc, patSynD'') } - where - mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind] - -- for Record Pattern Synonyms we want to conflate the selector - -- and the pattern-only names in order to provide a nicer TH - -- API. Whereas inside GHC, record pattern synonym selectors and - -- their pattern-only bound right hand sides have different names, - -- we want to treat them the same in TH. This is the reason why we - -- need an adjusted mkGenArgSyms in the `RecordPatSyn` case below. - mkGenArgSyms (PrefixPatSyn args) = mkGenSyms (map unLoc args) - mkGenArgSyms (InfixPatSyn arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] - mkGenArgSyms (RecordPatSyn fields) - = do { let pats = map (unLoc . recordPatSynPatVar) fields - sels = map (unLoc . recordPatSynSelectorId) fields - ; ss <- mkGenSyms sels - ; return $ replaceNames (zip sels pats) ss } - - replaceNames selsPats genSyms - = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats - , sel == sel' ] - - wrapGenArgSyms :: HsPatSynDetails (Located Name) - -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ) - wrapGenArgSyms (RecordPatSyn _) _ dec = return dec - wrapGenArgSyms _ ss dec = wrapGenSyms ss dec - -repPatSynD :: Core TH.Name - -> Core TH.PatSynArgsQ - -> Core TH.PatSynDirQ - -> Core TH.PatQ - -> DsM (Core TH.DecQ) -repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat) - = rep2 patSynDName [syn, args, dir, pat] - -repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ) -repPatSynArgs (PrefixPatSyn args) - = do { args' <- repList nameTyConName lookupLOcc args - ; repPrefixPatSynArgs args' } -repPatSynArgs (InfixPatSyn arg1 arg2) - = do { arg1' <- lookupLOcc arg1 - ; arg2' <- lookupLOcc arg2 - ; repInfixPatSynArgs arg1' arg2' } -repPatSynArgs (RecordPatSyn fields) - = do { sels' <- repList nameTyConName lookupLOcc sels - ; repRecordPatSynArgs sels' } - where sels = map recordPatSynSelectorId fields - -repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ) -repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms] - -repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ) -repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2] - -repRecordPatSynArgs :: Core [TH.Name] - -> DsM (Core TH.PatSynArgsQ) -repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] - -repPatSynDir :: HsPatSynDir Name -> DsM (Core TH.PatSynDirQ) -repPatSynDir Unidirectional = rep2 unidirPatSynName [] -repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] -repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses })) - = do { clauses' <- mapM repClauseTup clauses - ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } - -repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ) -repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] - - ------------------------------------------------------------------------------ --- Since everything in a Bind is mutually recursive we need rename all --- all the variables simultaneously. For example: --- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to --- do { f'1 <- gensym "f" --- ; g'2 <- gensym "g" --- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]}, --- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]} --- ]} --- This requires collecting the bindings (f'1 <- gensym "f"), and the --- environment ( f |-> f'1 ) from each binding, and then unioning them --- together. As we do this we collect GenSymBinds's which represent the renamed --- variables bound by the Bindings. In order not to lose track of these --- representations we build a shadow datatype MB with the same structure as --- MonoBinds, but which has slots for the representations - - ------------------------------------------------------------------------------ --- GHC allows a more general form of lambda abstraction than specified --- by Haskell 98. In particular it allows guarded lambda's like : --- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in --- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like --- (\ p1 .. pn -> exp) by causing an error. - -repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ) -repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds)))) - = do { let bndrs = collectPatsBinders ps ; - ; ss <- mkGenSyms bndrs - ; lam <- addBinds ss ( - do { xs <- repLPs ps; body <- repLE e; repLam xs body }) - ; wrapGenSyms ss lam } - -repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m) - - ------------------------------------------------------------------------------ --- Patterns --- repP deals with patterns. It assumes that we have already --- walked over the pattern(s) once to collect the binders, and --- have extended the environment. So every pattern-bound --- variable should already appear in the environment. - --- Process a list of patterns -repLPs :: [LPat Name] -> DsM (Core [TH.PatQ]) -repLPs ps = repList patQTyConName repLP ps - -repLP :: LPat Name -> DsM (Core TH.PatQ) -repLP (L _ p) = repP p - -repP :: Pat Name -> DsM (Core TH.PatQ) -repP (WildPat _) = repPwild -repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } -repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' } -repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } -repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } -repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } -repP (ParPat p) = repLP p -repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } -repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p} -repP (TuplePat ps boxed _) - | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } - | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } -repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity } -repP (ConPatIn dc details) - = do { con_str <- lookupLOcc dc - ; case details of - PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } - RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec) - ; repPrec con_str fps } - InfixCon p1 p2 -> do { p1' <- repLP p1; - p2' <- repLP p2; - repPinfix p1' con_str p2' } - } - where - rep_fld :: LHsRecField Name (LPat Name) -> DsM (Core (TH.Name,TH.PatQ)) - rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) - ; MkC p <- repLP (hsRecFieldArg 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 (SigPatIn p t) = do { p' <- repLP p - ; t' <- repLTy (hsSigWcType t) - ; repPsig p' t' } -repP (SplicePat splice) = repSplice splice - -repP other = notHandled "Exotic pattern" (ppr other) - ----------------------------------------------------------- --- Declaration ordering helpers - -sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)] -sort_by_loc xs = sortBy comp xs - where comp x y = compare (fst x) (fst y) - -de_loc :: [(a, b)] -> [b] -de_loc = map snd - ----------------------------------------------------------- --- The meta-environment - --- A name/identifier association for fresh names of locally bound entities -type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id - -- I.e. (x, x_id) means - -- let x_id = gensym "x" in ... - --- Generate a fresh name for a locally bound entity - -mkGenSyms :: [Name] -> DsM [GenSymBind] --- We can use the existing name. For example: --- [| \x_77 -> x_77 + x_77 |] --- desugars to --- do { x_77 <- genSym "x"; .... } --- We use the same x_77 in the desugared program, but with the type Bndr --- instead of Int --- --- We do make it an Internal name, though (hence localiseName) --- --- Nevertheless, it's monadic because we have to generate nameTy -mkGenSyms ns = do { var_ty <- lookupType nameTyConName - ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] } - - -addBinds :: [GenSymBind] -> DsM a -> DsM a --- Add a list of fresh names for locally bound entities to the --- meta environment (which is part of the state carried around --- by the desugarer monad) -addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m - --- Look up a locally bound name --- -lookupLBinder :: Located Name -> DsM (Core TH.Name) -lookupLBinder (L _ n) = lookupBinder n - -lookupBinder :: Name -> DsM (Core TH.Name) -lookupBinder = lookupOcc - -- Binders are brought into scope before the pattern or what-not is - -- desugared. Moreover, in instance declaration the binder of a method - -- will be the selector Id and hence a global; so we need the - -- globalVar case of lookupOcc - --- Look up a name that is either locally bound or a global name --- --- * If it is a global name, generate the "original name" representation (ie, --- the : form) for the associated entity --- -lookupLOcc :: Located Name -> DsM (Core TH.Name) --- Lookup an occurrence; it can't be a splice. --- Use the in-scope bindings if they exist -lookupLOcc (L _ n) = lookupOcc n - -lookupOcc :: Name -> DsM (Core TH.Name) -lookupOcc n - = do { mb_val <- dsLookupMetaEnv n ; - case mb_val of - Nothing -> globalVar n - Just (DsBound x) -> return (coreVar x) - Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n) - } - -globalVar :: Name -> DsM (Core TH.Name) --- Not bound by the meta-env --- Could be top-level; or could be local --- f x = $(g [| x |]) --- Here the x will be local -globalVar name - | isExternalName name - = do { MkC mod <- coreStringLit name_mod - ; MkC pkg <- coreStringLit name_pkg - ; MkC occ <- nameLit name - ; rep2 mk_varg [pkg,mod,occ] } - | otherwise - = do { MkC occ <- nameLit name - ; MkC uni <- coreIntLit (getKey (getUnique name)) - ; rep2 mkNameLName [occ,uni] } - where - mod = ASSERT( isExternalName name) nameModule name - name_mod = moduleNameString (moduleName mod) - name_pkg = unitIdString (moduleUnitId mod) - name_occ = nameOccName name - mk_varg | OccName.isDataOcc name_occ = mkNameG_dName - | OccName.isVarOcc name_occ = mkNameG_vName - | OccName.isTcOcc name_occ = mkNameG_tcName - | otherwise = pprPanic "DsMeta.globalVar" (ppr name) - -lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ) - -> DsM Type -- The type -lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; - return (mkTyConApp tc []) } - -wrapGenSyms :: [GenSymBind] - -> Core (TH.Q a) -> DsM (Core (TH.Q a)) --- wrapGenSyms [(nm1,id1), (nm2,id2)] y --- --> bindQ (gensym nm1) (\ id1 -> --- bindQ (gensym nm2 (\ id2 -> --- y)) - -wrapGenSyms binds body@(MkC b) - = do { var_ty <- lookupType nameTyConName - ; go var_ty binds } - where - [elt_ty] = tcTyConAppArgs (exprType b) - -- b :: Q a, so we can get the type 'a' by looking at the - -- argument type. NB: this relies on Q being a data/newtype, - -- not a type synonym - - go _ [] = return body - go var_ty ((name,id) : binds) - = do { MkC body' <- go var_ty binds - ; lit_str <- nameLit name - ; gensym_app <- repGensym lit_str - ; repBindQ var_ty elt_ty - gensym_app (MkC (Lam id body')) } - -nameLit :: Name -> DsM (Core String) -nameLit n = coreStringLit (occNameString (nameOccName n)) - -occNameLit :: OccName -> DsM (Core String) -occNameLit name = coreStringLit (occNameString name) - - --- %********************************************************************* --- %* * --- Constructing code --- %* * --- %********************************************************************* - ------------------------------------------------------------------------------ --- PHANTOM TYPES for consistency. In order to make sure we do this correct --- we invent a new datatype which uses phantom types. - -newtype Core a = MkC CoreExpr -unC :: Core a -> CoreExpr -unC (MkC x) = x - -rep2 :: Name -> [ CoreExpr ] -> DsM (Core a) -rep2 n xs = do { id <- dsLookupGlobalId n - ; return (MkC (foldl App (Var id) xs)) } - -dataCon' :: Name -> [CoreExpr] -> DsM (Core a) -dataCon' n args = do { id <- dsLookupDataCon n - ; return $ MkC $ mkCoreConApps id args } - -dataCon :: Name -> DsM (Core a) -dataCon n = dataCon' n [] - - --- %********************************************************************* --- %* * --- The 'smart constructors' --- %* * --- %********************************************************************* - ---------------- Patterns ----------------- -repPlit :: Core TH.Lit -> DsM (Core TH.PatQ) -repPlit (MkC l) = rep2 litPName [l] - -repPvar :: Core TH.Name -> DsM (Core TH.PatQ) -repPvar (MkC s) = rep2 varPName [s] - -repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) -repPtup (MkC ps) = rep2 tupPName [ps] - -repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) -repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] - -repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ) --- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here -repPunboxedSum (MkC p) alt arity - = do { dflags <- getDynFlags - ; rep2 unboxedSumPName [ p - , mkIntExprInt dflags alt - , mkIntExprInt dflags arity ] } - -repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ) -repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] - -repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ) -repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps] - -repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) -repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2] - -repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ) -repPtilde (MkC p) = rep2 tildePName [p] - -repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ) -repPbang (MkC p) = rep2 bangPName [p] - -repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) -repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] - -repPwild :: DsM (Core TH.PatQ) -repPwild = rep2 wildPName [] - -repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ) -repPlist (MkC ps) = rep2 listPName [ps] - -repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ) -repPview (MkC e) (MkC p) = rep2 viewPName [e,p] - -repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ) -repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] - ---------------- Expressions ----------------- -repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ) -repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str - | otherwise = repVar str - -repVar :: Core TH.Name -> DsM (Core TH.ExpQ) -repVar (MkC s) = rep2 varEName [s] - -repCon :: Core TH.Name -> DsM (Core TH.ExpQ) -repCon (MkC s) = rep2 conEName [s] - -repLit :: Core TH.Lit -> DsM (Core TH.ExpQ) -repLit (MkC c) = rep2 litEName [c] - -repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repApp (MkC x) (MkC y) = rep2 appEName [x,y] - -repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ) -repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y] - -repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] - -repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ) -repLamCase (MkC ms) = rep2 lamCaseEName [ms] - -repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) -repTup (MkC es) = rep2 tupEName [es] - -repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) -repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] - -repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ) --- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here -repUnboxedSum (MkC e) alt arity - = do { dflags <- getDynFlags - ; rep2 unboxedSumEName [ e - , mkIntExprInt dflags alt - , mkIntExprInt dflags arity ] } - -repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] - -repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ) -repMultiIf (MkC alts) = rep2 multiIfEName [alts] - -repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] - -repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ) -repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] - -repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) -repDoE (MkC ss) = rep2 doEName [ss] - -repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) -repComp (MkC ss) = rep2 compEName [ss] - -repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) -repListExp (MkC es) = rep2 listEName [es] - -repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ) -repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t] - -repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ) -repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs] - -repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ) -repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs] - -repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp)) -repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x] - -repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] - -repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y] - -repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] - ------------- Right hand sides (guarded expressions) ---- -repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ) -repGuarded (MkC pairs) = rep2 guardedBName [pairs] - -repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ) -repNormal (MkC e) = rep2 normalBName [e] - ------------- Guards ---- -repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) -repLNormalGE g e = do g' <- repLE g - e' <- repLE e - repNormalGE g' e' - -repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) -repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e] - -repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) -repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e] - -------------- Stmts ------------------- -repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ) -repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e] - -repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ) -repLetSt (MkC ds) = rep2 letSName [ds] - -repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ) -repNoBindSt (MkC e) = rep2 noBindSName [e] - -repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ) -repParSt (MkC sss) = rep2 parSName [sss] - --------------- Range (Arithmetic sequences) ----------- -repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ) -repFrom (MkC x) = rep2 fromEName [x] - -repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y] - -repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y] - -repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z] - ------------- Match and Clause Tuples ----------- -repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ) -repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds] - -repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ) -repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] - --------------- Dec ----------------------------- -repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) -repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] - -repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) -repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] - -repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) - -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) -repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs) - = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] -repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons) - (MkC derivs) - = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs] - -repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) - -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) -repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con) - (MkC derivs) - = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs] -repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con) - (MkC derivs) - = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs] - -repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] - -> Core TH.TypeQ -> DsM (Core TH.DecQ) -repTySyn (MkC nm) (MkC tvs) (MkC rhs) - = rep2 tySynDName [nm, tvs, rhs] - -repInst :: Core (Maybe TH.Overlap) -> - Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) -repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName - [o, cxt, ty, ds] - -repDerivStrategy :: Maybe (Located DerivStrategy) - -> DsM (Core (Maybe TH.DerivStrategy)) -repDerivStrategy mds = - case mds of - Nothing -> nothing - Just (L _ ds) -> - case ds of - StockStrategy -> just =<< dataCon stockStrategyDataConName - AnyclassStrategy -> just =<< dataCon anyclassStrategyDataConName - NewtypeStrategy -> just =<< dataCon newtypeStrategyDataConName - where - nothing = coreNothing derivStrategyTyConName - just = coreJust derivStrategyTyConName - -repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap)) -repOverlap mb = - case mb of - Nothing -> nothing - Just o -> - case o of - NoOverlap _ -> nothing - Overlappable _ -> just =<< dataCon overlappableDataConName - Overlapping _ -> just =<< dataCon overlappingDataConName - Overlaps _ -> just =<< dataCon overlapsDataConName - Incoherent _ -> just =<< dataCon incoherentDataConName - where - nothing = coreNothing overlapTyConName - just = coreJust overlapTyConName - - -repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Core [TH.FunDep] -> Core [TH.DecQ] - -> DsM (Core TH.DecQ) -repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) - = rep2 classDName [cxt, cls, tvs, fds, ds] - -repDeriv :: Core (Maybe TH.DerivStrategy) - -> Core TH.CxtQ -> Core TH.TypeQ - -> DsM (Core TH.DecQ) -repDeriv (MkC ds) (MkC cxt) (MkC ty) - = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty] - -repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch - -> Core TH.Phases -> DsM (Core TH.DecQ) -repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases) - = rep2 pragInlDName [nm, inline, rm, phases] - -repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases - -> DsM (Core TH.DecQ) -repPragSpec (MkC nm) (MkC ty) (MkC phases) - = rep2 pragSpecDName [nm, ty, phases] - -repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline - -> Core TH.Phases -> DsM (Core TH.DecQ) -repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases) - = rep2 pragSpecInlDName [nm, ty, inline, phases] - -repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ) -repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty] - -repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ) -repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty] - -repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ - -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ) -repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases) - = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases] - -repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ) -repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] - -repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ) -repTySynInst (MkC nm) (MkC eqn) - = rep2 tySynInstDName [nm, eqn] - -repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr] - -> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ) -repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) - = rep2 dataFamilyDName [nm, tvs, kind] - -repOpenFamilyD :: Core TH.Name - -> Core [TH.TyVarBndr] - -> Core TH.FamilyResultSig - -> Core (Maybe TH.InjectivityAnn) - -> DsM (Core TH.DecQ) -repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) - = rep2 openTypeFamilyDName [nm, tvs, result, inj] - -repClosedFamilyD :: Core TH.Name - -> Core [TH.TyVarBndr] - -> Core TH.FamilyResultSig - -> Core (Maybe TH.InjectivityAnn) - -> Core [TH.TySynEqnQ] - -> DsM (Core TH.DecQ) -repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) - = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] - -repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ) -repTySynEqn (MkC lhs) (MkC rhs) - = rep2 tySynEqnName [lhs, rhs] - -repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ) -repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles] - -repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep) -repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] - -repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) -repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] - -repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) -repCtxt (MkC tys) = rep2 cxtName [tys] - -repDataCon :: Located Name - -> HsConDeclDetails Name - -> DsM (Core TH.ConQ) -repDataCon con details - = do con' <- lookupLOcc con -- See Note [Binders and occurrences] - repConstr details Nothing [con'] - -repGadtDataCons :: [Located Name] - -> HsConDeclDetails Name - -> LHsType Name - -> DsM (Core TH.ConQ) -repGadtDataCons cons details res_ty - = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] - repConstr details (Just res_ty) cons' - --- Invariant: --- * for plain H98 data constructors second argument is Nothing and third --- argument is a singleton list --- * for GADTs data constructors second argument is (Just return_type) and --- third argument is a non-empty list -repConstr :: HsConDeclDetails Name - -> Maybe (LHsType Name) - -> [Core TH.Name] - -> DsM (Core TH.ConQ) -repConstr (PrefixCon ps) Nothing [con] - = do arg_tys <- repList bangTypeQTyConName repBangTy ps - rep2 normalCName [unC con, unC arg_tys] - -repConstr (PrefixCon ps) (Just (L _ res_ty)) cons - = do arg_tys <- repList bangTypeQTyConName repBangTy ps - res_ty' <- repTy res_ty - rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty'] - -repConstr (RecCon (L _ ips)) resTy cons - = do args <- concatMapM rep_ip ips - arg_vtys <- coreList varBangTypeQTyConName args - case resTy of - Nothing -> rep2 recCName [unC (head cons), unC arg_vtys] - Just (L _ res_ty) -> do - res_ty' <- repTy res_ty - rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys, - unC res_ty'] - - where - rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) - - rep_one_ip :: LBangType Name -> LFieldOcc Name -> DsM (Core a) - rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n) - ; MkC ty <- repBangTy t - ; rep2 varBangTypeName [v,ty] } - -repConstr (InfixCon st1 st2) Nothing [con] - = do arg1 <- repBangTy st1 - arg2 <- repBangTy st2 - rep2 infixCName [unC arg1, unC con, unC arg2] - -repConstr (InfixCon {}) (Just _) _ = - panic "repConstr: infix GADT constructor should be in a PrefixCon" -repConstr _ _ _ = - panic "repConstr: invariant violated" - ------------- Types ------------------- - -repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ - -> DsM (Core TH.TypeQ) -repTForall (MkC tvars) (MkC ctxt) (MkC ty) - = rep2 forallTName [tvars, ctxt, ty] - -repTvar :: Core TH.Name -> DsM (Core TH.TypeQ) -repTvar (MkC s) = rep2 varTName [s] - -repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) -repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2] - -repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ) -repTapps f [] = return f -repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } - -repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ) -repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] - -repTequality :: DsM (Core TH.TypeQ) -repTequality = rep2 equalityTName [] - -repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ) -repTPromotedList [] = repPromotedNilTyCon -repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon - ; f <- repTapp tcon t - ; t' <- repTPromotedList ts - ; repTapp f t' - } - -repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ) -repTLit (MkC lit) = rep2 litTName [lit] - -repTWildCard :: DsM (Core TH.TypeQ) -repTWildCard = rep2 wildCardTName [] - ---------- Type constructors -------------- - -repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) -repNamedTyCon (MkC s) = rep2 conTName [s] - -repTupleTyCon :: Int -> DsM (Core TH.TypeQ) --- Note: not Core Int; it's easier to be direct here -repTupleTyCon i = do dflags <- getDynFlags - rep2 tupleTName [mkIntExprInt dflags i] - -repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ) --- Note: not Core Int; it's easier to be direct here -repUnboxedTupleTyCon i = do dflags <- getDynFlags - rep2 unboxedTupleTName [mkIntExprInt dflags i] - -repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ) --- Note: not Core TH.SumArity; it's easier to be direct here -repUnboxedSumTyCon arity = do dflags <- getDynFlags - rep2 unboxedSumTName [mkIntExprInt dflags arity] - -repArrowTyCon :: DsM (Core TH.TypeQ) -repArrowTyCon = rep2 arrowTName [] - -repListTyCon :: DsM (Core TH.TypeQ) -repListTyCon = rep2 listTName [] - -repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ) -repPromotedDataCon (MkC s) = rep2 promotedTName [s] - -repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ) -repPromotedTupleTyCon i = do dflags <- getDynFlags - rep2 promotedTupleTName [mkIntExprInt dflags i] - -repPromotedNilTyCon :: DsM (Core TH.TypeQ) -repPromotedNilTyCon = rep2 promotedNilTName [] - -repPromotedConsTyCon :: DsM (Core TH.TypeQ) -repPromotedConsTyCon = rep2 promotedConsTName [] - ------------- Kinds ------------------- - -repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr) -repPlainTV (MkC nm) = rep2 plainTVName [nm] - -repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr) -repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] - -repKVar :: Core TH.Name -> DsM (Core TH.Kind) -repKVar (MkC s) = rep2 varKName [s] - -repKCon :: Core TH.Name -> DsM (Core TH.Kind) -repKCon (MkC s) = rep2 conKName [s] - -repKTuple :: Int -> DsM (Core TH.Kind) -repKTuple i = do dflags <- getDynFlags - rep2 tupleKName [mkIntExprInt dflags i] - -repKArrow :: DsM (Core TH.Kind) -repKArrow = rep2 arrowKName [] - -repKList :: DsM (Core TH.Kind) -repKList = rep2 listKName [] - -repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind) -repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2] - -repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind) -repKApps f [] = return f -repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks } - -repKStar :: DsM (Core TH.Kind) -repKStar = rep2 starKName [] - -repKConstraint :: DsM (Core TH.Kind) -repKConstraint = rep2 constraintKName [] - ----------------------------------------------------------- --- Type family result signature - -repNoSig :: DsM (Core TH.FamilyResultSig) -repNoSig = rep2 noSigName [] - -repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig) -repKindSig (MkC ki) = rep2 kindSigName [ki] - -repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig) -repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] - ----------------------------------------------------------- --- Literals - -repLiteral :: HsLit -> DsM (Core TH.Lit) -repLiteral (HsStringPrim _ bs) - = do dflags <- getDynFlags - word8_ty <- lookupType word8TyConName - let w8s = unpack bs - w8s_expr = map (\w8 -> mkCoreConApps word8DataCon - [mkWordLit dflags (toInteger w8)]) w8s - rep2 stringPrimLName [mkListExpr word8_ty w8s_expr] -repLiteral lit - = do lit' <- case lit of - HsIntPrim _ i -> mk_integer i - HsWordPrim _ w -> mk_integer w - HsInt _ i -> mk_integer i - HsFloatPrim r -> mk_rational r - HsDoublePrim r -> mk_rational r - HsCharPrim _ c -> mk_char c - _ -> return lit - lit_expr <- dsLit lit' - case mb_lit_name of - Just lit_name -> rep2 lit_name [lit_expr] - Nothing -> notHandled "Exotic literal" (ppr lit) - where - mb_lit_name = case lit of - HsInteger _ _ _ -> Just integerLName - HsInt _ _ -> Just integerLName - HsIntPrim _ _ -> Just intPrimLName - HsWordPrim _ _ -> Just wordPrimLName - HsFloatPrim _ -> Just floatPrimLName - HsDoublePrim _ -> Just doublePrimLName - HsChar _ _ -> Just charLName - HsCharPrim _ _ -> Just charPrimLName - HsString _ _ -> Just stringLName - HsRat _ _ -> Just rationalLName - _ -> Nothing - -mk_integer :: Integer -> DsM HsLit -mk_integer i = do integer_ty <- lookupType integerTyConName - return $ HsInteger NoSourceText i integer_ty -mk_rational :: FractionalLit -> DsM HsLit -mk_rational r = do rat_ty <- lookupType rationalTyConName - return $ HsRat r rat_ty -mk_string :: FastString -> DsM HsLit -mk_string s = return $ HsString NoSourceText s - -mk_char :: Char -> DsM HsLit -mk_char c = return $ HsChar NoSourceText c - -repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) -repOverloadedLiteral (OverLit { ol_val = val}) - = do { lit <- mk_lit val; repLiteral lit } - -- The type Rational will be in the environment, because - -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, - -- and rationalL is sucked in when any TH stuff is used - -mk_lit :: OverLitVal -> DsM HsLit -mk_lit (HsIntegral _ i) = mk_integer i -mk_lit (HsFractional f) = mk_rational f -mk_lit (HsIsString _ s) = mk_string s - -repNameS :: Core String -> DsM (Core TH.Name) -repNameS (MkC name) = rep2 mkNameSName [name] - ---------------- Miscellaneous ------------------- - -repGensym :: Core String -> DsM (Core (TH.Q TH.Name)) -repGensym (MkC lit_str) = rep2 newNameName [lit_str] - -repBindQ :: Type -> Type -- a and b - -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b)) -repBindQ ty_a ty_b (MkC x) (MkC y) - = rep2 bindQName [Type ty_a, Type ty_b, x, y] - -repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a])) -repSequenceQ ty_a (MkC list) - = rep2 sequenceQName [Type ty_a, list] - -repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ) -repUnboundVar (MkC name) = rep2 unboundVarEName [name] - ------------- Lists ------------------- --- turn a list of patterns into a single pattern matching a list - -repList :: Name -> (a -> DsM (Core b)) - -> [a] -> DsM (Core [b]) -repList tc_name f args - = do { args1 <- mapM f args - ; coreList tc_name args1 } - -coreList :: Name -- Of the TyCon of the element type - -> [Core a] -> DsM (Core [a]) -coreList tc_name es - = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } - -coreList' :: Type -- The element type - -> [Core a] -> Core [a] -coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) - -nonEmptyCoreList :: [Core a] -> Core [a] - -- The list must be non-empty so we can get the element type - -- Otherwise use coreList -nonEmptyCoreList [] = panic "coreList: empty argument" -nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) - -coreStringLit :: String -> DsM (Core String) -coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } - -------------------- Maybe ------------------ - --- | Construct Core expression for Nothing of a given type name -coreNothing :: Name -- ^ Name of the TyCon of the element type - -> DsM (Core (Maybe a)) -coreNothing tc_name = - do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) } - --- | Construct Core expression for Nothing of a given type -coreNothing' :: Type -- ^ The element type - -> Core (Maybe a) -coreNothing' elt_ty = MkC (mkNothingExpr elt_ty) - --- | Store given Core expression in a Just of a given type name -coreJust :: Name -- ^ Name of the TyCon of the element type - -> Core a -> DsM (Core (Maybe a)) -coreJust tc_name es - = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) } - --- | Store given Core expression in a Just of a given type -coreJust' :: Type -- ^ The element type - -> Core a -> Core (Maybe a) -coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es)) - ------------- Literals & Variables ------------------- - -coreIntLit :: Int -> DsM (Core Int) -coreIntLit i = do dflags <- getDynFlags - return (MkC (mkIntExprInt dflags i)) - -coreVar :: Id -> Core TH.Name -- The Id has type Name -coreVar id = MkC (Var id) - ------------------ Failure ----------------------- -notHandledL :: SrcSpan -> String -> SDoc -> DsM a -notHandledL loc what doc - | isGoodSrcSpan loc - = putSrcSpanDs loc $ notHandled what doc - | otherwise - = notHandled what doc - -notHandled :: String -> SDoc -> DsM a -notHandled what doc = failWithDs msg - where - msg = hang (text what <+> text "not (yet) handled by Template Haskell") - 2 doc diff --git a/deSugar/DsMonad.hs b/deSugar/DsMonad.hs deleted file mode 100644 --- a/deSugar/DsMonad.hs +++ /dev/null @@ -1,733 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -@DsMonad@: monadery used in desugaring --} - -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan - -module DsMonad ( - DsM, mapM, mapAndUnzipM, - initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs, - foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM, - Applicative(..),(<$>), - - duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs, - newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId, - newFailLocalDs, newPredVarDs, - getSrcSpanDs, putSrcSpanDs, - mkPrintUnqualifiedDs, - newUnique, - UniqSupply, newUniqueSupply, - getGhcModeDs, dsGetFamInstEnvs, - dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, - dsLookupDataCon, dsLookupConLike, - - PArrBuiltin(..), - dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe, - dsInitPArrBuiltin, - - DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, - - -- Getting and setting EvVars and term constraints in local environment - getDictsDs, addDictsDs, getTmCsDs, addTmCsDs, - - -- Iterations for pm checking - incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches, - - -- Warnings and errors - DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr, - failWithDs, failDs, discardWarningsDs, - askNoErrsDs, - - -- Data types - DsMatchContext(..), - EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper, - CanItFail(..), orFail, - - -- Levity polymorphism - dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs - ) where - -import TcRnMonad -import FamInstEnv -import CoreSyn -import MkCore ( unitExpr ) -import CoreUtils ( exprType, isExprLevPoly ) -import HsSyn -import TcIface -import TcMType ( checkForLevPolyX, formatLevPolyErr ) -import LoadIface -import Finder -import PrelNames -import RdrName -import HscTypes -import Bag -import DataCon -import ConLike -import TyCon -import PmExpr -import Id -import Module -import Outputable -import SrcLoc -import Type -import UniqSupply -import Name -import NameEnv -import DynFlags -import ErrUtils -import FastString -import Maybes -import Var (EvVar) -import qualified GHC.LanguageExtensions as LangExt -import UniqFM ( lookupWithDefaultUFM ) - -import Data.IORef -import Control.Monad - -{- -************************************************************************ -* * - Data types for the desugarer -* * -************************************************************************ --} - -data DsMatchContext - = DsMatchContext (HsMatchContext Name) SrcSpan - deriving () - -instance Outputable DsMatchContext where - ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match - -data EquationInfo - = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn - eqn_rhs :: MatchResult } -- What to do after match - -instance Outputable EquationInfo where - ppr (EqnInfo pats _) = ppr pats - -type DsWrapper = CoreExpr -> CoreExpr -idDsWrapper :: DsWrapper -idDsWrapper e = e - --- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult --- \fail. wrap (case vs of { pats -> rhs fail }) --- where vs are not bound by wrap - - --- A MatchResult is an expression with a hole in it -data MatchResult - = MatchResult - CanItFail -- Tells whether the failure expression is used - (CoreExpr -> DsM CoreExpr) - -- Takes a expression to plug in at the - -- failure point(s). The expression should - -- be duplicatable! - -data CanItFail = CanFail | CantFail - -orFail :: CanItFail -> CanItFail -> CanItFail -orFail CantFail CantFail = CantFail -orFail _ _ = CanFail - -{- -************************************************************************ -* * - Monad functions -* * -************************************************************************ --} - --- Compatibility functions -fixDs :: (a -> DsM a) -> DsM a -fixDs = fixM - -type DsWarning = (SrcSpan, SDoc) - -- Not quite the same as a WarnMsg, we have an SDoc here - -- and we'll do the print_unqual stuff later on to turn it - -- into a Doc. - --- | Run a 'DsM' action inside the 'TcM' monad. -initDsTc :: DsM a -> TcM a -initDsTc thing_inside - = do { tcg_env <- getGblEnv - ; msg_var <- getErrsVar - ; hsc_env <- getTopEnv - ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - ; setEnvs envs $ initDPH thing_inside - } - --- | Run a 'DsM' action inside the 'IO' monad. -initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a) -initDs hsc_env tcg_env thing_inside - = do { msg_var <- newIORef emptyMessages - ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - ; runDs hsc_env envs thing_inside - } - --- | Build a set of desugarer environments derived from a 'TcGblEnv'. -mkDsEnvsFromTcGbl :: MonadIO m - => HscEnv -> IORef Messages -> TcGblEnv - -> m (DsGblEnv, DsLclEnv) -mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - = do { pm_iter_var <- liftIO $ newIORef 0 - ; let dflags = hsc_dflags hsc_env - this_mod = tcg_mod tcg_env - type_env = tcg_type_env tcg_env - rdr_env = tcg_rdr_env tcg_env - fam_inst_env = tcg_fam_inst_env tcg_env - complete_matches = hptCompleteSigs hsc_env - ++ tcg_complete_matches tcg_env - ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env - msg_var pm_iter_var complete_matches - } - -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a) -runDs hsc_env (ds_gbl, ds_lcl) thing_inside - = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl - (initDPH $ tryM thing_inside) - ; msgs <- readIORef (ds_msgs ds_gbl) - ; let final_res - | errorsFound dflags msgs = Nothing - | Right r <- res = Just r - | otherwise = panic "initDs" - ; return (msgs, final_res) - } - where dflags = hsc_dflags hsc_env - --- | Run a 'DsM' action in the context of an existing 'ModGuts' -initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a) -initDsWithModGuts hsc_env guts thing_inside - = do { pm_iter_var <- newIORef 0 - ; msg_var <- newIORef emptyMessages - ; let dflags = hsc_dflags hsc_env - type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) - rdr_env = mg_rdr_env guts - fam_inst_env = mg_fam_inst_env guts - this_mod = mg_module guts - complete_matches = hptCompleteSigs hsc_env - ++ mg_complete_sigs guts - - bindsToIds (NonRec v _) = [v] - bindsToIds (Rec binds) = map fst binds - ids = concatMap bindsToIds (mg_binds guts) - - envs = mkDsEnvs dflags this_mod rdr_env type_env - fam_inst_env msg_var pm_iter_var - complete_matches - ; runDs hsc_env envs thing_inside - } - -initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a) --- Spin up a TcM context so that we can run the constraint solver --- Returns any error messages generated by the constraint solver --- and (Just res) if no error happened; Nothing if an error happened --- --- Simon says: I'm not very happy about this. We spin up a complete TcM monad --- only to immediately refine it to a TcS monad. --- Better perhaps to make TcS into its own monad, rather than building on TcS --- But that may in turn interact with plugins - -initTcDsForSolver thing_inside - = do { (gbl, lcl) <- getEnvs - ; hsc_env <- getTopEnv - - ; let DsGblEnv { ds_mod = mod - , ds_fam_inst_env = fam_inst_env } = gbl - - DsLclEnv { dsl_loc = loc } = lcl - - ; liftIO $ initTc hsc_env HsSrcFile False mod loc $ - updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $ - thing_inside } - -mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef Messages -> IORef Int -> [CompleteMatch] - -> (DsGblEnv, DsLclEnv) -mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar - complete_matches - = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", - if_rec_types = Just (mod, return type_env) } - if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) - False -- not boot! - real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) - completeMatchMap = mkCompleteMatchMap complete_matches - gbl_env = DsGblEnv { ds_mod = mod - , ds_fam_inst_env = fam_inst_env - , ds_if_env = (if_genv, if_lenv) - , ds_unqual = mkPrintUnqualified dflags rdr_env - , ds_msgs = msg_var - , ds_dph_env = emptyGlobalRdrEnv - , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi" - , ds_complete_matches = completeMatchMap - } - lcl_env = DsLclEnv { dsl_meta = emptyNameEnv - , dsl_loc = real_span - , dsl_dicts = emptyBag - , dsl_tm_cs = emptyBag - , dsl_pm_iter = pmvar - } - in (gbl_env, lcl_env) - - -{- -************************************************************************ -* * - Operations in the monad -* * -************************************************************************ - -And all this mysterious stuff is so we can occasionally reach out and -grab one or more names. @newLocalDs@ isn't exported---exported -functions are defined with it. The difference in name-strings makes -it easier to read debugging output. - -Note [Levity polymorphism checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -According to the Levity Polymorphism paper -, levity -polymorphism is forbidden in precisely two places: in the type of a bound -term-level argument and in the type of an argument to a function. The paper -explains it more fully, but briefly: expressions in these contexts need to be -stored in registers, and it's hard (read, impossible) to store something -that's levity polymorphic. - -We cannot check for bad levity polymorphism conveniently in the type checker, -because we can't tell, a priori, which levity metavariables will be solved. -At one point, I (Richard) thought we could check in the zonker, but it's hard -to know where precisely are the abstracted variables and the arguments. So -we check in the desugarer, the only place where we can see the Core code and -still report respectable syntax to the user. This covers the vast majority -of cases; see calls to DsMonad.dsNoLevPoly and friends. - -Levity polymorphism is also prohibited in the types of binders, and the -desugarer checks for this in GHC-generated Ids. (The zonker handles -the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP. -The newSysLocalDs variant is used in the vast majority of cases where -the binder is obviously not levity polymorphic, omitting the check. -It would be nice to ASSERT that there is no levity polymorphism here, -but we can't, because of the fixM in DsArrows. It's all OK, though: -Core Lint will catch an error here. - -However, the desugarer is the wrong place for certain checks. In particular, -the desugarer can't report a sensible error message if an HsWrapper is malformed. -After all, GHC itself produced the HsWrapper. So we store some message text -in the appropriate HsWrappers (e.g. WpFun) that we can print out in the -desugarer. - -There are a few more checks in places where Core is generated outside the -desugarer. For example, in datatype and class declarations, where levity -polymorphism is checked for during validity checking. It would be nice to -have one central place for all this, but that doesn't seem possible while -still reporting nice error messages. - --} - --- Make a new Id with the same print name, but different type, and new unique -newUniqueId :: Id -> Type -> DsM Id -newUniqueId id = mk_local (occNameFS (nameOccName (idName id))) - -duplicateLocalDs :: Id -> DsM Id -duplicateLocalDs old_local - = do { uniq <- newUnique - ; return (setIdUnique old_local uniq) } - -newPredVarDs :: PredType -> DsM Var -newPredVarDs pred - = newSysLocalDs pred - -newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id -newSysLocalDsNoLP = mk_local (fsLit "ds") - --- this variant should be used when the caller can be sure that the variable type --- is not levity-polymorphic. It is necessary when the type is knot-tied because --- of the fixM used in DsArrows. See Note [Levity polymorphism checking] -newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds") -newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail") - -- the fail variable is used only in a situation where we can tell that - -- levity-polymorphism is impossible. - -newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id] -newSysLocalsDsNoLP = mapM newSysLocalDsNoLP -newSysLocalsDs = mapM newSysLocalDs - -mk_local :: FastString -> Type -> DsM Id -mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+> - ppr ty) -- could improve the msg with another - -- parameter indicating context - ; mkSysLocalOrCoVarM fs ty } - -{- -We can also reach out and either set/grab location information from -the @SrcSpan@ being carried around. --} - -getGhcModeDs :: DsM GhcMode -getGhcModeDs = getDynFlags >>= return . ghcMode - --- | Get in-scope type constraints (pm check) -getDictsDs :: DsM (Bag EvVar) -getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) } - --- | Add in-scope type constraints (pm check) -addDictsDs :: Bag EvVar -> DsM a -> DsM a -addDictsDs ev_vars - = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) }) - --- | Get in-scope term constraints (pm check) -getTmCsDs :: DsM (Bag SimpleEq) -getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) } - --- | Add in-scope term constraints (pm check) -addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a -addTmCsDs tm_cs - = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) }) - --- | Increase the counter for elapsed pattern match check iterations. --- If the current counter is already over the limit, fail -incrCheckPmIterDs :: DsM Int -incrCheckPmIterDs = do - env <- getLclEnv - cnt <- readTcRef (dsl_pm_iter env) - max_iters <- maxPmCheckIterations <$> getDynFlags - if cnt >= max_iters - then failM - else updTcRef (dsl_pm_iter env) (+1) - return cnt - --- | Reset the counter for pattern match check iterations to zero -resetPmIterDs :: DsM () -resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 } - -getSrcSpanDs :: DsM SrcSpan -getSrcSpanDs = do { env <- getLclEnv - ; return (RealSrcSpan (dsl_loc env)) } - -putSrcSpanDs :: SrcSpan -> DsM a -> DsM a -putSrcSpanDs (UnhelpfulSpan {}) thing_inside - = thing_inside -putSrcSpanDs (RealSrcSpan real_span) thing_inside - = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside - --- | Emit a warning for the current source location --- NB: Warns whether or not -Wxyz is set -warnDs :: WarnReason -> SDoc -> DsM () -warnDs reason warn - = do { env <- getGblEnv - ; loc <- getSrcSpanDs - ; dflags <- getDynFlags - ; let msg = makeIntoWarning reason $ - mkWarnMsg dflags loc (ds_unqual env) warn - ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } - --- | Emit a warning only if the correct WarnReason is set in the DynFlags -warnIfSetDs :: WarningFlag -> SDoc -> DsM () -warnIfSetDs flag warn - = whenWOptM flag $ - warnDs (Reason flag) warn - -errDs :: SDoc -> DsM () -errDs err - = do { env <- getGblEnv - ; loc <- getSrcSpanDs - ; dflags <- getDynFlags - ; let msg = mkErrMsg dflags loc (ds_unqual env) err - ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) } - --- | Issue an error, but return the expression for (), so that we can continue --- reporting errors. -errDsCoreExpr :: SDoc -> DsM CoreExpr -errDsCoreExpr err - = do { errDs err - ; return unitExpr } - -failWithDs :: SDoc -> DsM a -failWithDs err - = do { errDs err - ; failM } - -failDs :: DsM a -failDs = failM - --- (askNoErrsDs m) runs m --- If m fails, --- then (askNoErrsDs m) fails --- If m succeeds with result r, --- then (askNoErrsDs m) succeeds with result (r, b), --- where b is True iff m generated no errors --- Regardless of success or failure, --- propagate any errors/warnings generated by m --- --- c.f. TcRnMonad.askNoErrs -askNoErrsDs :: DsM a -> DsM (a, Bool) -askNoErrsDs thing_inside - = do { errs_var <- newMutVar emptyMessages - ; env <- getGblEnv - ; mb_res <- tryM $ -- Be careful to catch exceptions - -- so that we propagate errors correctly - -- (Trac #13642) - setGblEnv (env { ds_msgs = errs_var }) $ - thing_inside - - -- Propagate errors - ; msgs@(warns, errs) <- readMutVar errs_var - ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs)) - - -- And return - ; case mb_res of - Left _ -> failM - Right res -> do { dflags <- getDynFlags - ; let errs_found = errorsFound dflags msgs - ; return (res, not errs_found) } } - -mkPrintUnqualifiedDs :: DsM PrintUnqualified -mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv - -instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where - lookupThing = dsLookupGlobal - --- | Attempt to load the given module and return its exported entities if --- successful. -dsLoadModule :: SDoc -> Module -> DsM GlobalRdrEnv -dsLoadModule doc mod - = do { env <- getGblEnv - ; setEnvs (ds_if_env env) $ do - { iface <- loadInterface doc mod ImportBySystem - ; case iface of - Failed err -> pprPanic "DsMonad.dsLoadModule: failed to load" (err $$ doc) - Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface - } } - where - prov = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll }) - imp_spec = ImpDeclSpec { is_mod = name, is_qual = True, - is_dloc = wiredInSrcSpan, is_as = name } - name = moduleName mod - -dsLookupGlobal :: Name -> DsM TyThing --- Very like TcEnv.tcLookupGlobal -dsLookupGlobal name - = do { env <- getGblEnv - ; setEnvs (ds_if_env env) - (tcIfaceGlobal name) } - -dsLookupGlobalId :: Name -> DsM Id -dsLookupGlobalId name - = tyThingId <$> dsLookupGlobal name - -dsLookupTyCon :: Name -> DsM TyCon -dsLookupTyCon name - = tyThingTyCon <$> dsLookupGlobal name - -dsLookupDataCon :: Name -> DsM DataCon -dsLookupDataCon name - = tyThingDataCon <$> dsLookupGlobal name - -dsLookupConLike :: Name -> DsM ConLike -dsLookupConLike name - = tyThingConLike <$> dsLookupGlobal name - - -dsGetFamInstEnvs :: DsM FamInstEnvs --- Gets both the external-package inst-env --- and the home-pkg inst env (includes module being compiled) -dsGetFamInstEnvs - = do { eps <- getEps; env <- getGblEnv - ; return (eps_fam_inst_env eps, ds_fam_inst_env env) } - -dsGetMetaEnv :: DsM (NameEnv DsMetaVal) -dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) } - --- | The @COMPLETE@ pragams provided by the user for a given `TyCon`. -dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch] -dsGetCompleteMatches tc = do - eps <- getEps - env <- getGblEnv - let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc - eps_matches_list = lookup_completes $ eps_complete_matches eps - env_matches_list = lookup_completes $ ds_complete_matches env - return $ eps_matches_list ++ env_matches_list - -dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) -dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) } - -dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a -dsExtendMetaEnv menv thing_inside - = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside - -discardWarningsDs :: DsM a -> DsM a --- Ignore warnings inside the thing inside; --- used to ignore inaccessable cases etc. inside generated code -discardWarningsDs thing_inside - = do { env <- getGblEnv - ; old_msgs <- readTcRef (ds_msgs env) - - ; result <- thing_inside - - -- Revert messages to old_msgs - ; writeTcRef (ds_msgs env) old_msgs - - ; return result } - --- | Fail with an error message if the type is levity polymorphic. -dsNoLevPoly :: Type -> SDoc -> DsM () --- See Note [Levity polymorphism checking] -dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty - --- | Check an expression for levity polymorphism, failing if it is --- levity polymorphic. -dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM () --- See Note [Levity polymorphism checking] -dsNoLevPolyExpr e doc - | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc) - | otherwise = return () - --- | Runs the thing_inside. If there are no errors, then returns the expr --- given. Otherwise, returns unitExpr. This is useful for doing a bunch --- of levity polymorphism checks and then avoiding making a core App. --- (If we make a core App on a levity polymorphic argument, detecting how --- to handle the let/app invariant might call isUnliftedType, which panics --- on a levity polymorphic type.) --- See #12709 for an example of why this machinery is necessary. -dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr -dsWhenNoErrs thing_inside mk_expr - = do { (result, no_errs) <- askNoErrsDs thing_inside - ; return $ if no_errs - then mk_expr result - else unitExpr } - --------------------------------------------------------------------------- --- Data Parallel Haskell --------------------------------------------------------------------------- - --- | Run a 'DsM' with DPH things in scope if necessary. -initDPH :: DsM a -> DsM a -initDPH = loadDAP . initDPHBuiltins - --- | Extend the global environment with a 'GlobalRdrEnv' containing the exported --- entities of, --- --- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP'). --- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified. -loadDAP :: DsM a -> DsM a -loadDAP thing_inside - = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr - ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr - ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside - } - where - loadOneModule :: ModuleName -- the module to load - -> DsM Bool -- under which condition - -> MsgDoc -- error message if module not found - -> DsM GlobalRdrEnv -- empty if condition 'False' - loadOneModule modname check err - = do { doLoad <- check - ; if not doLoad - then return emptyGlobalRdrEnv - else do { - ; hsc_env <- getTopEnv - ; result <- liftIO $ findImportedModule hsc_env modname Nothing - ; case result of - Found _ mod -> dsLoadModule err mod - _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err - } } - - paErr = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2 - veErr = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2 - specBackend = text "you must specify a DPH backend package" - hint1 = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'" - hint2 = text "You may need to install them with 'cabal install dph-examples'" - --- | If '-XParallelArrays' given, we populate the builtin table for desugaring --- those. -initDPHBuiltins :: DsM a -> DsM a -initDPHBuiltins thing_inside - = do { doInitBuiltins <- checkLoadDAP - ; if doInitBuiltins - then dsInitPArrBuiltin thing_inside - else thing_inside - } - -checkLoadDAP :: DsM Bool -checkLoadDAP - = do { paEnabled <- xoptM LangExt.ParallelArrays - ; mod <- getModule - -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a - -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top - -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries - ; return $ paEnabled && - mod /= gHC_PARR' && - moduleName mod /= dATA_ARRAY_PARALLEL_NAME - } - --- | Populate 'ds_parr_bi' from 'ds_dph_env'. --- -dsInitPArrBuiltin :: DsM a -> DsM a -dsInitPArrBuiltin thing_inside - = do { lengthPVar <- externalVar (fsLit "lengthP") - ; replicatePVar <- externalVar (fsLit "replicateP") - ; singletonPVar <- externalVar (fsLit "singletonP") - ; mapPVar <- externalVar (fsLit "mapP") - ; filterPVar <- externalVar (fsLit "filterP") - ; zipPVar <- externalVar (fsLit "zipP") - ; crossMapPVar <- externalVar (fsLit "crossMapP") - ; indexPVar <- externalVar (fsLit "!:") - ; emptyPVar <- externalVar (fsLit "emptyP") - ; appPVar <- externalVar (fsLit "+:+") - -- ; enumFromToPVar <- externalVar (fsLit "enumFromToP") - -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP") - ; enumFromToPVar <- return arithErr - ; enumFromThenToPVar <- return arithErr - - ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin - { lengthPVar = lengthPVar - , replicatePVar = replicatePVar - , singletonPVar = singletonPVar - , mapPVar = mapPVar - , filterPVar = filterPVar - , zipPVar = zipPVar - , crossMapPVar = crossMapPVar - , indexPVar = indexPVar - , emptyPVar = emptyPVar - , appPVar = appPVar - , enumFromToPVar = enumFromToPVar - , enumFromThenToPVar = enumFromThenToPVar - } }) - thing_inside - } - where - externalVar :: FastString -> DsM Var - externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId - - arithErr = panic "Arithmetic sequences have to wait until we support type classes" - --- |Get a name from "Data.Array.Parallel" for the desugarer, from the --- 'ds_parr_bi' component of the global desugerar environment. --- -dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a -dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv - --- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'. --- Panic if there isn't one, or if it is defined multiple times. -dsLookupDPHRdrEnv :: OccName -> DsM Name -dsLookupDPHRdrEnv occ - = liftM (fromMaybe (pprPanic nameNotFound (ppr occ))) - $ dsLookupDPHRdrEnv_maybe occ - where nameNotFound = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':" - --- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim', --- returning `Nothing` if it's not defined. Panic if it's defined multiple times. -dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name) -dsLookupDPHRdrEnv_maybe occ - = do { env <- ds_dph_env <$> getGblEnv - ; let gres = lookupGlobalRdrEnv env occ - ; case gres of - [] -> return $ Nothing - [gre] -> return $ Just $ gre_name gre - _ -> pprPanic multipleNames (ppr occ) - } - where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':" diff --git a/deSugar/DsUsage.hs b/deSugar/DsUsage.hs deleted file mode 100644 --- a/deSugar/DsUsage.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE CPP #-} - -module DsUsage ( - -- * Dependency/fingerprinting code (used by MkIface) - mkUsageInfo, mkUsedNames, mkDependencies - ) where - -#include "HsVersions.h" - -import DynFlags -import HscTypes -import TcRnTypes -import Name -import NameSet -import Module -import Outputable -import Util -import UniqSet -import UniqFM -import Fingerprint -import Maybes - -import Data.List -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Set as Set - -{- Note [Module self-dependency] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -RnNames.calculateAvails asserts the invariant that a module must not occur in -its own dep_orphs or dep_finsts. However, if we aren't careful this can occur -in the presence of hs-boot files: Consider that we have two modules, A and B, -both with hs-boot files, - - A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A - A.hs-boot declares an orphan instance A.hs defines the orphan instance - -In this case, B's dep_orphs will contain A due to its SOURCE import of A. -Consequently, A will contain itself in its imp_orphs due to its import of B. -This fact would end up being recorded in A's interface file. This would then -break the invariant asserted by calculateAvails that a module does not itself in -its dep_orphs. This was the cause of Trac #14128. - --} - --- | Extract information from the rename and typecheck phases to produce --- a dependencies information for the module being compiled. -mkDependencies :: TcGblEnv -> IO Dependencies -mkDependencies - TcGblEnv{ tcg_mod = mod, - tcg_imports = imports, - tcg_th_used = th_var - } - = do - -- Template Haskell used? - 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] - - pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) (imp_dep_pkgs imports) - | otherwise = imp_dep_pkgs imports - - -- Set the packages required to be Safe according to Safe Haskell. - -- See Note [RnNames . Tracking Trust Transitively] - sorted_pkgs = sort (Set.toList pkgs) - trust_pkgs = imp_trust_pkgs imports - dep_pkgs' = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs - - return Deps { dep_mods = dep_mods, - dep_pkgs = dep_pkgs', - dep_orphs = dep_orphs, - dep_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)] -> IO [Usage] -mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged - = do - eps <- hscEPS hsc_env - hashes <- mapM getFileHash dependent_files - let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod - dir_imp_mods used_names - usages = mod_usages ++ [ UsageFile { usg_file_path = f - , usg_file_hash = hash } - | (f, hash) <- zip dependent_files hashes ] - ++ [ UsageMergedRequirement - { usg_mod = mod, - usg_mod_hash = hash - } - | (mod, hash) <- merged ] - usages `seqList` return usages - -- seq the list of Usages returned: occasionally these - -- don't get evaluated for a while and we can end up hanging on to - -- the entire collection of Ifaces. - -mk_mod_usage_info :: PackageIfaceTable - -> HscEnv - -> Module - -> ImportedMods - -> NameSet - -> [Usage] -mk_mod_usage_info pit hsc_env this_mod direct_imports used_names - = mapMaybe mkUsage usage_mods - where - hpt = hsc_HPT hsc_env - dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags - - used_mods = moduleEnvKeys ent_map - dir_imp_mods = moduleEnvKeys direct_imports - all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods - usage_mods = sortBy stableModuleCmp all_mods - -- canonical order is imported, to avoid interface-file - -- wobblage. - - -- ent_map groups together all the things imported and used - -- from a particular module - ent_map :: ModuleEnv [OccName] - ent_map = nonDetFoldUniqSet add_mv emptyModuleEnv used_names - -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName - -- in ent_hashs - where - add_mv name mv_map - | isWiredInName name = mv_map -- ignore wired-in names - | otherwise - = case nameModule_maybe name of - Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map - -- See Note [Internal used_names] - - Just mod -> - -- See Note [Identity versus semantic module] - let mod' = if isHoleModule mod - then mkModule this_pkg (moduleName mod) - else mod - -- This lambda function is really just a - -- specialised (++); originally came about to - -- avoid quadratic behaviour (trac #2680) - in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ] - where occ = nameOccName name - - -- We want to create a Usage for a home module if - -- a) we used something from it; has something in used_names - -- b) we imported it, even if we used nothing from it - -- (need to recompile if its export list changes: export_fprint) - mkUsage :: Module -> Maybe Usage - mkUsage mod - | isNothing maybe_iface -- We can't depend on it if we didn't - -- load its interface. - || mod == this_mod -- We don't care about usages of - -- things in *this* module - = Nothing - - | moduleUnitId mod /= this_pkg - = Just UsagePackageModule{ usg_mod = mod, - usg_mod_hash = mod_hash, - usg_safe = imp_safe } - -- for package modules, we record the module hash only - - | (null used_occs - && isNothing export_hash - && not is_direct_import - && not finsts_mod) - = Nothing -- Record no usage info - -- for directly-imported modules, we always want to record a usage - -- on the orphan hash. This is what triggers a recompilation if - -- an orphan is added or removed somewhere below us in the future. - - | otherwise - = Just UsageHomeModule { - usg_mod_name = moduleName mod, - usg_mod_hash = mod_hash, - usg_exports = export_hash, - usg_entities = Map.toList ent_hashs, - usg_safe = imp_safe } - where - maybe_iface = lookupIfaceByModule dflags hpt pit mod - -- In one-shot mode, the interfaces for home-package - -- modules accumulate in the PIT not HPT. Sigh. - - Just iface = maybe_iface - finsts_mod = mi_finsts iface - hash_env = mi_hash_fn iface - mod_hash = mi_mod_hash iface - export_hash | depend_on_exports = Just (mi_exp_hash iface) - | otherwise = Nothing - - by_is_safe (ImportedByUser imv) = imv_is_safe imv - by_is_safe _ = False - (is_direct_import, imp_safe) - = case lookupModuleEnv direct_imports mod of - -- ezyang: I'm not sure if any is the correct - -- metric here. If safety was guaranteed to be uniform - -- across all imports, why did the old code only look - -- at the first import? - Just bys -> (True, any by_is_safe bys) - Nothing -> (False, safeImplicitImpsReq dflags) - -- Nothing case is for references to entities which were - -- not directly imported (NB: the "implicit" Prelude import - -- counts as directly imported! An entity is not directly - -- imported if, e.g., we got a reference to it from a - -- reexport of another module.) - - used_occs = lookupModuleEnv ent_map mod `orElse` [] - - -- Making a Map here ensures that (a) we remove duplicates - -- when we have usages on several subordinates of a single parent, - -- and (b) that the usages emerge in a canonical order, which - -- is why we use Map rather than OccEnv: Map works - -- using Ord on the OccNames, which is a lexicographic ordering. - ent_hashs :: Map OccName Fingerprint - ent_hashs = Map.fromList (map lookup_occ used_occs) - - lookup_occ occ = - case hash_env occ of - Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names) - Just r -> r - - depend_on_exports = is_direct_import - {- True - Even if we used 'import M ()', we have to register a - usage on the export list because we are sensitive to - changes in orphan instances/rules. - False - In GHC 6.8.x we always returned true, and in - fact it recorded a dependency on *all* the - modules underneath in the dependency tree. This - happens to make orphans work right, but is too - expensive: it'll read too many interface files. - The 'isNothing maybe_iface' check above saved us - from generating many of these usages (at least in - one-shot mode), but that's even more bogus! - -} diff --git a/deSugar/DsUtils.hs b/deSugar/DsUtils.hs deleted file mode 100644 --- a/deSugar/DsUtils.hs +++ /dev/null @@ -1,1008 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Utilities for desugaring - -This module exports some utility functions of no great interest. --} - -{-# LANGUAGE CPP #-} - --- | Utility functions for constructing Core syntax, principally for desugaring -module DsUtils ( - EquationInfo(..), - firstPat, shiftEqns, - - MatchResult(..), CanItFail(..), CaseAlt(..), - cantFailMatchResult, alwaysFailMatchResult, - extractMatchResult, combineMatchResults, - adjustMatchResult, adjustMatchResultDs, - mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, - matchCanFail, mkEvalMatchResult, - mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, - wrapBind, wrapBinds, - - mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, - - seqVar, - - -- LHs tuples - mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat, - mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId, - - mkSelectorBinds, - - selectSimpleMatchVarL, selectMatchVars, selectMatchVar, - mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} Match ( matchSimply ) -import {-# SOURCE #-} DsExpr ( dsLExpr ) - -import HsSyn -import TcHsSyn -import TcType( tcSplitTyConApp ) -import CoreSyn -import DsMonad - -import CoreUtils -import MkCore -import MkId -import Id -import Literal -import TyCon -import DataCon -import PatSyn -import Type -import Coercion -import TysPrim -import TysWiredIn -import BasicTypes -import ConLike -import UniqSet -import UniqSupply -import Module -import PrelNames -import Name( isInternalName ) -import Outputable -import SrcLoc -import Util -import DynFlags -import FastString -import qualified GHC.LanguageExtensions as LangExt - -import TcEvidence - -import Control.Monad ( zipWithM ) - -{- -************************************************************************ -* * -\subsection{ Selecting match variables} -* * -************************************************************************ - -We're about to match against some patterns. We want to make some -@Ids@ to use as match variables. If a pattern has an @Id@ readily at -hand, which should indeed be bound to the pattern as a whole, then use it; -otherwise, make one up. --} - -selectSimpleMatchVarL :: LPat Id -> DsM Id -selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) - --- (selectMatchVars ps tys) chooses variables of type tys --- to use for matching ps against. If the pattern is a variable, --- we try to use that, to save inventing lots of fresh variables. --- --- OLD, but interesting note: --- But even if it is a variable, its type might not match. Consider --- data T a where --- T1 :: Int -> T Int --- T2 :: a -> T a --- --- f :: T a -> a -> Int --- f (T1 i) (x::Int) = x --- f (T2 i) (y::a) = 0 --- Then we must not choose (x::Int) as the matching variable! --- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat - -selectMatchVars :: [Pat Id] -> DsM [Id] -selectMatchVars ps = mapM selectMatchVar ps - -selectMatchVar :: Pat Id -> DsM Id -selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (VarPat var) = return (localiseId (unLoc var)) - -- Note [Localise pattern binders] -selectMatchVar (AsPat var _) = return (unLoc var) -selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) - -- OK, better make up one... - -{- -Note [Localise pattern binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider module M where - [Just a] = e -After renaming it looks like - module M where - [Just M.a] = e - -We don't generalise, since it's a pattern binding, monomorphic, etc, -so after desugaring we may get something like - M.a = case e of (v:_) -> - case v of Just M.a -> M.a -Notice the "M.a" in the pattern; after all, it was in the original -pattern. However, after optimisation those pattern binders can become -let-binders, and then end up floated to top level. They have a -different *unique* by then (the simplifier is good about maintaining -proper scoping), but it's BAD to have two top-level bindings with the -External Name M.a, because that turns into two linker symbols for M.a. -It's quite rare for this to actually *happen* -- the only case I know -of is tc003 compiled with the 'hpc' way -- but that only makes it -all the more annoying. - -To avoid this, we craftily call 'localiseId' in the desugarer, which -simply turns the External Name for the Id into an Internal one, but -doesn't change the unique. So the desugarer produces this: - M.a{r8} = case e of (v:_) -> - case v of Just a{r8} -> M.a{r8} -The unique is still 'r8', but the binding site in the pattern -is now an Internal Name. Now the simplifier's usual mechanisms -will propagate that Name to all the occurrence sites, as well as -un-shadowing it, so we'll get - M.a{r8} = case e of (v:_) -> - case v of Just a{s77} -> a{s77} -In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr -runs on the output of the desugarer, so all is well by the end of -the desugaring pass. - - -************************************************************************ -* * -* type synonym EquationInfo and access functions for its pieces * -* * -************************************************************************ -\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} - -The ``equation info'' used by @match@ is relatively complicated and -worthy of a type synonym and a few handy functions. --} - -firstPat :: EquationInfo -> Pat Id -firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) - -shiftEqns :: [EquationInfo] -> [EquationInfo] --- Drop the first pattern in each equation -shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ] - --- Functions on MatchResults - -matchCanFail :: MatchResult -> Bool -matchCanFail (MatchResult CanFail _) = True -matchCanFail (MatchResult CantFail _) = False - -alwaysFailMatchResult :: MatchResult -alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail) - -cantFailMatchResult :: CoreExpr -> MatchResult -cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr) - -extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr -extractMatchResult (MatchResult CantFail match_fn) _ - = match_fn (error "It can't fail!") - -extractMatchResult (MatchResult CanFail match_fn) fail_expr = do - (fail_bind, if_it_fails) <- mkFailurePair fail_expr - body <- match_fn if_it_fails - return (mkCoreLet fail_bind body) - - -combineMatchResults :: MatchResult -> MatchResult -> MatchResult -combineMatchResults (MatchResult CanFail body_fn1) - (MatchResult can_it_fail2 body_fn2) - = MatchResult can_it_fail2 body_fn - where - body_fn fail = do body2 <- body_fn2 fail - (fail_bind, duplicatable_expr) <- mkFailurePair body2 - body1 <- body_fn1 duplicatable_expr - return (Let fail_bind body1) - -combineMatchResults match_result1@(MatchResult CantFail _) _ - = match_result1 - -adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult -adjustMatchResult encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail) - -adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult -adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail) - -wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr -wrapBinds [] e = e -wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) - -wrapBind :: Var -> Var -> CoreExpr -> CoreExpr -wrapBind new old body -- NB: this function must deal with term - | new==old = body -- variables, type variables or coercion variables - | otherwise = Let (NonRec new (varToCoreExpr old)) body - -seqVar :: Var -> CoreExpr -> CoreExpr -seqVar var body = Case (Var var) var (exprType body) - [(DEFAULT, [], body)] - -mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult -mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind) - --- (mkViewMatchResult var' viewExpr mr) makes the expression --- let var' = viewExpr in mr -mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult -mkViewMatchResult var' viewExpr = - adjustMatchResult (mkCoreLet (NonRec var' viewExpr)) - -mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult -mkEvalMatchResult var ty - = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) - -mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult -mkGuardedMatchResult pred_expr (MatchResult _ body_fn) - = MatchResult CanFail (\fail -> do body <- body_fn fail - return (mkIfThenElse pred_expr body fail)) - -mkCoPrimCaseMatchResult :: Id -- Scrutinee - -> Type -- Type of the case - -> [(Literal, MatchResult)] -- Alternatives - -> MatchResult -- Literals are all unlifted -mkCoPrimCaseMatchResult var ty match_alts - = MatchResult CanFail mk_case - where - mk_case fail = do - alts <- mapM (mk_alt fail) sorted_alts - return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) - - sorted_alts = sortWith fst match_alts -- Right order for a Case - mk_alt fail (lit, MatchResult _ body_fn) - = ASSERT( not (litIsLifted lit) ) - do body <- body_fn fail - return (LitAlt lit, [], body) - -data CaseAlt a = MkCaseAlt{ alt_pat :: a, - alt_bndrs :: [Var], - alt_wrapper :: HsWrapper, - alt_result :: MatchResult } - -mkCoAlgCaseMatchResult - :: DynFlags - -> Id -- Scrutinee - -> Type -- Type of exp - -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts) - -> MatchResult -mkCoAlgCaseMatchResult dflags var ty match_alts - | isNewtype -- Newtype case; use a let - = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) - mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 - - | isPArrFakeAlts match_alts - = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts) - | otherwise - = mkDataConCase var ty match_alts - where - isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1)) - - -- [Interesting: because of GADTs, we can't rely on the type of - -- the scrutinised Id to be sufficiently refined to have a TyCon in it] - - alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } - = ASSERT( notNull match_alts ) head match_alts - -- Stuff for newtype - arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 - var_ty = idType var - (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes - -- (not that splitTyConApp does, these days) - newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) - - --- Stuff for parallel arrays - -- - -- Concerning `isPArrFakeAlts': - -- - -- * it is *not* sufficient to just check the type of the type - -- constructor, as we have to be careful not to confuse the real - -- representation of parallel arrays with the fake constructors; - -- moreover, a list of alternatives must not mix fake and real - -- constructors (this is checked earlier on) - -- - -- FIXME: We actually go through the whole list and make sure that - -- either all or none of the constructors are fake parallel - -- array constructors. This is to spot equations that mix fake - -- constructors with the real representation defined in - -- `PrelPArr'. It would be nicer to spot this situation - -- earlier and raise a proper error message, but it can really - -- only happen in `PrelPArr' anyway. - -- - - isPArrFakeAlts :: [CaseAlt DataCon] -> Bool - isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt) - isPArrFakeAlts (alt:alts) = - case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of - (True , True ) -> True - (False, False) -> False - _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns" - isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives" - -mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult -mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt - -sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon] -sort_alts = sortWith (dataConTag . alt_pat) - -mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr -mkPatSynCase var ty alt fail = do - matcher <- dsLExpr $ mkLHsWrap wrapper $ - nlHsTyApp matcher [getRuntimeRep ty, ty] - let MatchResult _ mkCont = match_result - cont <- mkCoreLams bndrs <$> mkCont fail - return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] - where - MkCaseAlt{ alt_pat = psyn, - alt_bndrs = bndrs, - alt_wrapper = wrapper, - alt_result = match_result} = alt - (matcher, needs_void_lam) = patSynMatcher psyn - - -- See Note [Matchers and builders for pattern synonyms] in PatSyns - -- on these extra Void# arguments - ensure_unstrict cont | needs_void_lam = Lam voidArgId cont - | otherwise = cont - -mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult -mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives" -mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case - where - con1 = alt_pat alt1 - tycon = dataConTyCon con1 - data_cons = tyConDataCons tycon - match_results = map alt_result alts - - sorted_alts :: [CaseAlt DataCon] - sorted_alts = sort_alts alts - - var_ty = idType var - (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes - -- (not that splitTyConApp does, these days) - - mk_case :: CoreExpr -> DsM CoreExpr - mk_case fail = do - alts <- mapM (mk_alt fail) sorted_alts - return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts) - - mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt - mk_alt fail MkCaseAlt{ alt_pat = con, - alt_bndrs = args, - alt_result = MatchResult _ body_fn } - = do { body <- body_fn fail - ; case dataConBoxer con of { - Nothing -> return (DataAlt con, args, body) ; - Just (DCB boxer) -> - do { us <- newUniqueSupply - ; let (rep_ids, binds) = initUs_ us (boxer ty_args args) - ; return (DataAlt con, rep_ids, mkLets binds body) } } } - - mk_default :: CoreExpr -> [CoreAlt] - mk_default fail | exhaustive_case = [] - | otherwise = [(DEFAULT, [], fail)] - - fail_flag :: CanItFail - fail_flag | exhaustive_case - = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results] - | otherwise - = CanFail - - mentioned_constructors = mkUniqSet $ map alt_pat alts - un_mentioned_constructors - = mkUniqSet data_cons `minusUniqSet` mentioned_constructors - exhaustive_case = isEmptyUniqSet un_mentioned_constructors - ---- Stuff for parallel arrays --- --- * the following is to desugar cases over fake constructors for --- parallel arrays, which are introduced by `tidy1' in the `PArrPat' --- case --- -mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr -mkPArrCase dflags var ty sorted_alts fail = do - lengthP <- dsDPHBuiltin lengthPVar - alt <- unboxAlt - return (mkWildCase (len lengthP) intTy ty [alt]) - where - elemTy = case splitTyConApp (idType var) of - (_, [elemTy]) -> elemTy - _ -> panic panicMsg - panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?" - len lengthP = mkApps (Var lengthP) [Type elemTy, Var var] - -- - unboxAlt = do - l <- newSysLocalDs intPrimTy - indexP <- dsDPHBuiltin indexPVar - alts <- mapM (mkAlt indexP) sorted_alts - return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) - where - dft = (DEFAULT, [], fail) - - -- - -- each alternative matches one array length (corresponding to one - -- fake array constructor), so the match is on a literal; each - -- alternative's body is extended by a local binding for each - -- constructor argument, which are bound to array elements starting - -- with the first - -- - mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do - body <- bodyFun fail - return (LitAlt lit, [], mkCoreLets binds body) - where - lit = MachInt $ toInteger (dataConSourceArity (alt_pat alt)) - binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)] - -- - indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i] - -{- -************************************************************************ -* * -\subsection{Desugarer's versions of some Core functions} -* * -************************************************************************ --} - -mkErrorAppDs :: Id -- The error function - -> Type -- Type to which it should be applied - -> SDoc -- The error message string to pass - -> DsM CoreExpr - -mkErrorAppDs err_id ty msg = do - src_loc <- getSrcSpanDs - dflags <- getDynFlags - let - full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) - core_msg = Lit (mkMachString full_msg) - -- mkMachString returns a result of type String# - return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) - -{- -'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'. - -Note [Desugaring seq (1)] cf Trac #1031 -~~~~~~~~~~~~~~~~~~~~~~~~~ - f x y = x `seq` (y `seq` (# x,y #)) - -The [CoreSyn let/app invariant] means that, other things being equal, because -the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: - - f x y = case (y `seq` (# x,y #)) of v -> x `seq` v - -But that is bad for two reasons: - (a) we now evaluate y before x, and - (b) we can't bind v to an unboxed pair - -Seq is very, very special! So we recognise it right here, and desugar to - case x of _ -> case y of _ -> (# x,y #) - -Note [Desugaring seq (2)] cf Trac #2273 -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let chp = case b of { True -> fst x; False -> 0 } - in chp `seq` ...chp... -Here the seq is designed to plug the space leak of retaining (snd x) -for too long. - -If we rely on the ordinary inlining of seq, we'll get - let chp = case b of { True -> fst x; False -> 0 } - case chp of _ { I# -> ...chp... } - -But since chp is cheap, and the case is an alluring contet, we'll -inline chp into the case scrutinee. Now there is only one use of chp, -so we'll inline a second copy. Alas, we've now ruined the purpose of -the seq, by re-introducing the space leak: - case (case b of {True -> fst x; False -> 0}) of - I# _ -> ...case b of {True -> fst x; False -> 0}... - -We can try to avoid doing this by ensuring that the binder-swap in the -case happens, so we get his at an early stage: - case chp of chp2 { I# -> ...chp2... } -But this is fragile. The real culprit is the source program. Perhaps we -should have said explicitly - let !chp2 = chp in ...chp2... - -But that's painful. So the code here does a little hack to make seq -more robust: a saturated application of 'seq' is turned *directly* into -the case expression, thus: - x `seq` e2 ==> case x of x -> e2 -- Note shadowing! - e1 `seq` e2 ==> case x of _ -> e2 - -So we desugar our example to: - let chp = case b of { True -> fst x; False -> 0 } - case chp of chp { I# -> ...chp... } -And now all is well. - -The reason it's a hack is because if you define mySeq=seq, the hack -won't work on mySeq. - -Note [Desugaring seq (3)] cf Trac #2409 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The isLocalId ensures that we don't turn - True `seq` e -into - case True of True { ... } -which stupidly tries to bind the datacon 'True'. --} - --- NB: Make sure the argument is not levity polymorphic -mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr -mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 - | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)] - = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] - where - case_bndr = case arg1 of - Var v1 | isInternalName (idName v1) - -> v1 -- Note [Desugaring seq (2) and (3)] - _ -> mkWildValBinder ty1 - -mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore - --- NB: No argument can be levity polymorphic -mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr -mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args - -mkCastDs :: CoreExpr -> Coercion -> CoreExpr --- We define a desugarer-specific version of CoreUtils.mkCast, --- because in the immediate output of the desugarer, we can have --- apparently-mis-matched coercions: E.g. --- let a = b --- in (x :: a) |> (co :: b ~ Int) --- Lint know about type-bindings for let and does not complain --- So here we do not make the assertion checks that we make in --- CoreUtils.mkCast; and we do less peephole optimisation too -mkCastDs e co | isReflCo co = e - | otherwise = Cast e co - -{- -************************************************************************ -* * - Tuples and selector bindings -* * -************************************************************************ - -This is used in various places to do with lazy patterns. -For each binder $b$ in the pattern, we create a binding: -\begin{verbatim} - b = case v of pat' -> b' -\end{verbatim} -where @pat'@ is @pat@ with each binder @b@ cloned into @b'@. - -ToDo: making these bindings should really depend on whether there's -much work to be done per binding. If the pattern is complex, it -should be de-mangled once, into a tuple (and then selected from). -Otherwise the demangling can be in-line in the bindings (as here). - -Boring! Boring! One error message per binder. The above ToDo is -even more helpful. Something very similar happens for pattern-bound -expressions. - -Note [mkSelectorBinds] -~~~~~~~~~~~~~~~~~~~~~~ -mkSelectorBinds is used to desugar a pattern binding {p = e}, -in a binding group: - let { ...; p = e; ... } in body -where p binds x,y (this list of binders can be empty). -There are two cases. - ------- Special case (A) ------- - For a pattern that is just a variable, - let !x = e in body - ==> - let x = e in x `seq` body - So we return the binding, with 'x' as the variable to seq. - ------- Special case (B) ------- - For a pattern that is essentially just a tuple: - * A product type, so cannot fail - * Only one level, so that - - generating multiple matches is fine - - seq'ing it evaluates the same as matching it - Then instead we generate - { v = e - ; x = case v of p -> x - ; y = case v of p -> y } - with 'v' as the variable to force - ------- General case (C) ------- - In the general case we generate these bindings: - let { ...; p = e; ... } in body - ==> - let { t = case e of p -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> y } - in t `seq` body - - Note that we return 't' as the variable to force if the pattern - is strict (i.e. with -XStrict or an outermost-bang-pattern) - - Note that (A) /includes/ the situation where - - * The pattern binds exactly one variable - let !(Just (Just x) = e in body - ==> - let { t = case e of Just (Just v) -> Unit v - ; v = case t of Unit v -> v } - in t `seq` body - The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn - Note that forcing 't' makes the pattern match happen, - but does not force 'v'. - - * The pattern binds no variables - let !(True,False) = e in body - ==> - let t = case e of (True,False) -> () - in t `seq` body - - ------- Examples ---------- - * !(_, (_, a)) = e - ==> - t = case e of (_, (_, a)) -> Unit a - a = case t of Unit a -> a - - Note that - - Forcing 't' will force the pattern to match fully; - e.g. will diverge if (snd e) is bottom - - But 'a' itself is not forced; it is wrapped in a one-tuple - (see Note [One-tuples] in TysWiredIn) - - * !(Just x) = e - ==> - t = case e of Just x -> Unit x - x = case t of Unit x -> x - - Again, forcing 't' will fail if 'e' yields Nothing. - -Note that even though this is rather general, the special cases -work out well: - -* One binder, not -XStrict: - - let Just (Just v) = e in body - ==> - let t = case e of Just (Just v) -> Unit v - v = case t of Unit v -> v - in body - ==> - let v = case (case e of Just (Just v) -> Unit v) of - Unit v -> v - in body - ==> - let v = case e of Just (Just v) -> v - in body - -* Non-recursive, -XStrict - let p = e in body - ==> - let { t = case e of p -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> x } - in t `seq` body - ==> {inline seq, float x,y bindings inwards} - let t = case e of p -> (x,y) in - case t of t' -> - let { x = case t' of (x,y) -> x - ; y = case t' of (x,y) -> x } in - body - ==> {inline t, do case of case} - case e of p -> - let t = (x,y) in - let { x = case t' of (x,y) -> x - ; y = case t' of (x,y) -> x } in - body - ==> {case-cancellation, drop dead code} - case e of p -> body - -* Special case (B) is there to avoid fruitlessly taking the tuple - apart and rebuilding it. For example, consider - { K x y = e } - where K is a product constructor. Then general case (A) does: - { t = case e of K x y -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> y } - In the lazy case we can't optimise out this fruitless taking apart - and rebuilding. Instead (B) builds - { v = e - ; x = case v of K x y -> x - ; y = case v of K x y -> y } - which is better. --} - -mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly - -> LPat Id -- ^ The pattern - -> CoreExpr -- ^ Expression to which the pattern is bound - -> DsM (Id,[(Id,CoreExpr)]) - -- ^ Id the rhs is bound to, for desugaring strict - -- binds (see Note [Desugar Strict binds] in DsBinds) - -- and all the desugared binds - -mkSelectorBinds ticks pat val_expr - | L _ (VarPat (L _ v)) <- pat' -- Special case (A) - = return (v, [(v, val_expr)]) - - | is_flat_prod_lpat pat' -- Special case (B) - = do { let pat_ty = hsLPatType pat' - ; val_var <- newSysLocalDsNoLP pat_ty - - ; let mk_bind tick bndr_var - -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } - -- Remember, 'pat' binds 'bv' - = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' - (Var bndr_var) - (Var bndr_var) -- Neat hack - -- Neat hack: since 'pat' can't fail, the - -- "fail-expr" passed to matchSimply is not - -- used. But it /is/ used for its type, and for - -- that bndr_var is just the ticket. - ; return (bndr_var, mkOptTickBox tick rhs_expr) } - - ; binds <- zipWithM mk_bind ticks' binders - ; return ( val_var, (val_var, val_expr) : binds) } - - | otherwise -- General case (C) - = do { tuple_var <- newSysLocalDs tuple_ty - ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat') - ; tuple_expr <- matchSimply val_expr PatBindRhs pat - local_tuple error_expr - ; let mk_tup_bind tick binder - = (binder, mkOptTickBox tick $ - mkTupleSelector1 local_binders binder - tuple_var (Var tuple_var)) - tup_binds = zipWith mk_tup_bind ticks' binders - ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) } - where - pat' = strip_bangs pat - -- Strip the bangs before looking for case (A) or (B) - -- The incoming pattern may well have a bang on it - - binders = collectPatBinders pat' - ticks' = ticks ++ repeat [] - - local_binders = map localiseId binders -- See Note [Localise pattern binders] - local_tuple = mkBigCoreVarTup1 binders - tuple_ty = exprType local_tuple - -strip_bangs :: LPat a -> LPat a --- Remove outermost bangs and parens -strip_bangs (L _ (ParPat p)) = strip_bangs p -strip_bangs (L _ (BangPat p)) = strip_bangs p -strip_bangs lp = lp - -is_flat_prod_lpat :: LPat a -> Bool -is_flat_prod_lpat p = is_flat_prod_pat (unLoc p) - -is_flat_prod_pat :: Pat a -> Bool -is_flat_prod_pat (ParPat p) = is_flat_prod_lpat p -is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps -is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps}) - | RealDataCon con <- pcon - , isProductTyCon (dataConTyCon con) - = all is_triv_lpat (hsConPatArgs ps) -is_flat_prod_pat _ = False - -is_triv_lpat :: LPat a -> Bool -is_triv_lpat p = is_triv_pat (unLoc p) - -is_triv_pat :: Pat a -> Bool -is_triv_pat (VarPat _) = True -is_triv_pat (WildPat _) = True -is_triv_pat (ParPat p) = is_triv_lpat p -is_triv_pat _ = False - - -{- ********************************************************************* -* * - Creating big tuples and their types for full Haskell expressions. - They work over *Ids*, and create tuples replete with their types, - which is whey they are not in HsUtils. -* * -********************************************************************* -} - -mkLHsPatTup :: [LPat Id] -> LPat Id -mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed -mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ - mkVanillaTuplePat lpats Boxed - -mkLHsVarPatTup :: [Id] -> LPat Id -mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) - -mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id --- A vanilla tuple pattern simply gets its type from its sub-patterns -mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats) - --- The Big equivalents for the source tuple expressions -mkBigLHsVarTupId :: [Id] -> LHsExpr Id -mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids) - -mkBigLHsTupId :: [LHsExpr Id] -> LHsExpr Id -mkBigLHsTupId = mkChunkified mkLHsTupleExpr - --- The Big equivalents for the source tuple patterns -mkBigLHsVarPatTupId :: [Id] -> LPat Id -mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs) - -mkBigLHsPatTupId :: [LPat Id] -> LPat Id -mkBigLHsPatTupId = mkChunkified mkLHsPatTup - -{- -************************************************************************ -* * - Code for pattern-matching and other failures -* * -************************************************************************ - -Generally, we handle pattern matching failure like this: let-bind a -fail-variable, and use that variable if the thing fails: -\begin{verbatim} - let fail.33 = error "Help" - in - case x of - p1 -> ... - p2 -> fail.33 - p3 -> fail.33 - p4 -> ... -\end{verbatim} -Then -\begin{itemize} -\item -If the case can't fail, then there'll be no mention of @fail.33@, and the -simplifier will later discard it. - -\item -If it can fail in only one way, then the simplifier will inline it. - -\item -Only if it is used more than once will the let-binding remain. -\end{itemize} - -There's a problem when the result of the case expression is of -unboxed type. Then the type of @fail.33@ is unboxed too, and -there is every chance that someone will change the let into a case: -\begin{verbatim} - case error "Help" of - fail.33 -> case .... -\end{verbatim} - -which is of course utterly wrong. Rather than drop the condition that -only boxed types can be let-bound, we just turn the fail into a function -for the primitive case: -\begin{verbatim} - let fail.33 :: Void -> Int# - fail.33 = \_ -> error "Help" - in - case x of - p1 -> ... - p2 -> fail.33 void - p3 -> fail.33 void - p4 -> ... -\end{verbatim} - -Now @fail.33@ is a function, so it can be let-bound. - -We would *like* to use join points here; in fact, these "fail variables" are -paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as -CPS functions - i.e. they take "join points" as parameters. It's not impossible -to imagine extending our type system to allow passing join points around (very -carefully), but we certainly don't support it now. - -99.99% of the time, the fail variables wind up as join points in short order -anyway, and the Void# doesn't do much harm. --} - -mkFailurePair :: CoreExpr -- Result type of the whole case expression - -> DsM (CoreBind, -- Binds the newly-created fail variable - -- to \ _ -> expression - CoreExpr) -- Fail variable applied to realWorld# --- See Note [Failure thunks and CPR] -mkFailurePair expr - = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty) - ; fail_fun_arg <- newSysLocalDs voidPrimTy - ; let real_arg = setOneShotLambda fail_fun_arg - ; return (NonRec fail_fun_var (Lam real_arg expr), - App (Var fail_fun_var) (Var voidPrimId)) } - where - ty = exprType expr - -{- -Note [Failure thunks and CPR] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(This note predates join points as formal entities (hence the quotation marks). -We can't use actual join points here (see above); if we did, this would also -solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR -join points] in WorkWrap.) - -When we make a failure point we ensure that it -does not look like a thunk. Example: - - let fail = \rw -> error "urk" - in case x of - [] -> fail realWorld# - (y:ys) -> case ys of - [] -> fail realWorld# - (z:zs) -> (y,z) - -Reason: we know that a failure point is always a "join point" and is -entered at most once. Adding a dummy 'realWorld' token argument makes -it clear that sharing is not an issue. And that in turn makes it more -CPR-friendly. This matters a lot: if you don't get it right, you lose -the tail call property. For example, see Trac #3403. - - -************************************************************************ -* * - Ticks -* * -********************************************************************* -} - -mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr -mkOptTickBox = flip (foldr Tick) - -mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr -mkBinaryTickBox ixT ixF e = do - uq <- newUnique - this_mod <- getModule - let bndr1 = mkSysLocal (fsLit "t1") uq boolTy - let - falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) - trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) - -- - return $ Case e bndr1 boolTy - [ (DataAlt falseDataCon, [], falseBox) - , (DataAlt trueDataCon, [], trueBox) - ] - - - --- ******************************************************************* - --- | Use -XStrict to add a ! or remove a ~ --- --- Examples: --- ~pat => pat -- when -XStrict (even if pat = ~pat') --- !pat => !pat -- always --- pat => !pat -- when -XStrict --- pat => pat -- otherwise -decideBangHood :: DynFlags - -> LPat id -- ^ Original pattern - -> LPat id -- Pattern with bang if necessary -decideBangHood dflags lpat - | not (xopt LangExt.Strict dflags) - = lpat - | otherwise -- -XStrict - = go lpat - where - go lp@(L l p) - = case p of - ParPat p -> L l (ParPat (go p)) - LazyPat lp' -> lp' - BangPat _ -> lp - _ -> L l (BangPat lp) - --- | Unconditionally make a 'Pat' strict. -addBang :: LPat id -- ^ Original pattern - -> LPat id -- ^ Banged pattern -addBang = go - where - go lp@(L l p) - = case p of - ParPat p -> L l (ParPat (go p)) - LazyPat lp' -> L l (BangPat lp') - BangPat _ -> lp - _ -> L l (BangPat lp) diff --git a/deSugar/Match.hs b/deSugar/Match.hs deleted file mode 100644 --- a/deSugar/Match.hs +++ /dev/null @@ -1,1135 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The @match@ function --} - -{-# LANGUAGE CPP #-} - -module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where - -#include "HsVersions.h" - -import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr) - -import DynFlags -import HsSyn -import TcHsSyn -import TcEvidence -import TcRnMonad -import Check -import CoreSyn -import Literal -import CoreUtils -import MkCore -import DsMonad -import DsBinds -import DsGRHSs -import DsUtils -import Id -import ConLike -import DataCon -import PatSyn -import MatchCon -import MatchLit -import Type -import Coercion ( eqCoercion ) -import TcType ( toTcTypeBag ) -import TyCon( isNewTyCon ) -import TysWiredIn -import ListSetOps -import SrcLoc -import Maybes -import Util -import Name -import Outputable -import BasicTypes ( isGenerated, fl_value ) -import FastString -import Unique -import UniqDFM - -import Control.Monad( when, unless ) -import qualified Data.Map as Map - -{- -************************************************************************ -* * - The main matching function -* * -************************************************************************ - -The function @match@ is basically the same as in the Wadler chapter, -except it is monadised, to carry around the name supply, info about -annotations, etc. - -Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns: -\begin{enumerate} -\item -A list of $n$ variable names, those variables presumably bound to the -$n$ expressions being matched against the $n$ patterns. Using the -list of $n$ expressions as the first argument showed no benefit and -some inelegance. - -\item -The second argument, a list giving the ``equation info'' for each of -the $m$ equations: -\begin{itemize} -\item -the $n$ patterns for that equation, and -\item -a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on -the front'' of the matching code, as in: -\begin{verbatim} -let -in -\end{verbatim} -\item -and finally: (ToDo: fill in) - -The right way to think about the ``after-match function'' is that it -is an embryonic @CoreExpr@ with a ``hole'' at the end for the -final ``else expression''. -\end{itemize} - -There is a data type, @EquationInfo@, defined in module @DsMonad@. - -An experiment with re-ordering this information about equations (in -particular, having the patterns available in column-major order) -showed no benefit. - -\item -A default expression---what to evaluate if the overall pattern-match -fails. This expression will (almost?) always be -a measly expression @Var@, unless we know it will only be used once -(as we do in @glue_success_exprs@). - -Leaving out this third argument to @match@ (and slamming in lots of -@Var "fail"@s) is a positively {\em bad} idea, because it makes it -impossible to share the default expressions. (Also, it stands no -chance of working in our post-upheaval world of @Locals@.) -\end{enumerate} - -Note: @match@ is often called via @matchWrapper@ (end of this module), -a function that does much of the house-keeping that goes with a call -to @match@. - -It is also worth mentioning the {\em typical} way a block of equations -is desugared with @match@. At each stage, it is the first column of -patterns that is examined. The steps carried out are roughly: -\begin{enumerate} -\item -Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add -bindings to the second component of the equation-info): -\begin{itemize} -\item -Remove the `as' patterns from column~1. -\item -Make all constructor patterns in column~1 into @ConPats@, notably -@ListPats@ and @TuplePats@. -\item -Handle any irrefutable (or ``twiddle'') @LazyPats@. -\end{itemize} -\item -Now {\em unmix} the equations into {\em blocks} [w\/ local function -@unmix_eqns@], in which the equations in a block all have variable -patterns in column~1, or they all have constructor patterns in ... -(see ``the mixture rule'' in SLPJ). -\item -Call @matchEqnBlock@ on each block of equations; it will do the -appropriate thing for each kind of column-1 pattern, usually ending up -in a recursive call to @match@. -\end{enumerate} - -We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) -than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). -And gluing the ``success expressions'' together isn't quite so pretty. - -This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@ -(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and -(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em -un}mixes the equations], producing a list of equation-info -blocks, each block having as its first column of patterns either all -constructors, or all variables (or similar beasts), etc. - -@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the -Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ -corresponds roughly to @matchVarCon@. - -Note [Match Ids] -~~~~~~~~~~~~~~~~ -Most of the matching fuctions take an Id or [Id] as argument. This Id -is the scrutinee(s) of the match. The desugared expression may -sometimes use that Id in a local binding or as a case binder. So it -should not have an External name; Lint rejects non-top-level binders -with External names (Trac #13043). --} - -type MatchId = Id -- See Note [Match Ids] - -match :: [MatchId] -- Variables rep\'ing the exprs we\'re matching with - -- See Note [Match Ids] - -> Type -- Type of the case expression - -> [EquationInfo] -- Info about patterns, etc. (type synonym below) - -> DsM MatchResult -- Desugared result! - -match [] ty eqns - = ASSERT2( not (null eqns), ppr ty ) - return (foldr1 combineMatchResults match_results) - where - match_results = [ ASSERT( null (eqn_pats eqn) ) - eqn_rhs eqn - | eqn <- eqns ] - -match vars@(v:_) ty eqns -- Eqns *can* be empty - = ASSERT2( all (isInternalName . idName) vars, ppr vars ) - do { dflags <- getDynFlags - -- Tidy the first pattern, generating - -- auxiliary bindings if necessary - ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns - - -- Group the equations and match each group in turn - ; let grouped = groupEquations dflags tidy_eqns - - -- print the view patterns that are commoned up to help debug - ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped) - - ; match_results <- match_groups grouped - ; return (adjustMatchResult (foldr (.) id aux_binds) $ - foldr1 combineMatchResults match_results) } - where - dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo] - dropGroup = map snd - - match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult] - -- Result list of [MatchResult] is always non-empty - match_groups [] = matchEmpty v ty - match_groups gs = mapM match_group gs - - match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult - match_group [] = panic "match_group" - match_group eqns@((group,_) : _) - = case group of - PgCon {} -> matchConFamily vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns]) - PgSyn {} -> matchPatSyn vars ty (dropGroup eqns) - PgLit {} -> matchLiterals vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns]) - PgAny -> matchVariables vars ty (dropGroup eqns) - PgN {} -> matchNPats vars ty (dropGroup eqns) - PgOverS {}-> matchNPats vars ty (dropGroup eqns) - PgNpK {} -> matchNPlusKPats vars ty (dropGroup eqns) - PgBang -> matchBangs vars ty (dropGroup eqns) - PgCo {} -> matchCoercion vars ty (dropGroup eqns) - PgView {} -> matchView vars ty (dropGroup eqns) - PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns) - - -- FIXME: we should also warn about view patterns that should be - -- commoned up but are not - - -- print some stuff to see what's getting grouped - -- use -dppr-debug to see the resolution of overloaded literals - debug eqns = - let gs = map (\group -> foldr (\ (p,_) -> \acc -> - case p of PgView e _ -> e:acc - _ -> acc) [] group) eqns - maybeWarn [] = return () - maybeWarn l = warnDs NoReason (vcat l) - in - maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) - (filter (not . null) gs)) - -matchEmpty :: MatchId -> Type -> DsM [MatchResult] --- See Note [Empty case expressions] -matchEmpty var res_ty - = return [MatchResult CanFail mk_seq] - where - mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty - [(DEFAULT, [], fail)] - -matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult --- Real true variables, just like in matchVar, SLPJ p 94 --- No binding to do: they'll all be wildcards by now (done in tidy) -matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns) -matchVariables [] _ _ = panic "matchVariables" - -matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult -matchBangs (var:vars) ty eqns - = do { match_result <- match (var:vars) ty $ - map (decomposeFirstPat getBangPat) eqns - ; return (mkEvalMatchResult var ty match_result) } -matchBangs [] _ _ = panic "matchBangs" - -matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult --- Apply the coercion to the match variable and then match that -matchCoercion (var:vars) ty (eqns@(eqn1:_)) - = do { let CoPat co pat _ = firstPat eqn1 - ; let pat_ty' = hsPatType pat - ; var' <- newUniqueId var pat_ty' - ; match_result <- match (var':vars) ty $ - map (decomposeFirstPat getCoPat) eqns - ; core_wrap <- dsHsWrapper co - ; let bind = NonRec var' (core_wrap (Var var)) - ; return (mkCoLetMatchResult bind match_result) } -matchCoercion _ _ _ = panic "matchCoercion" - -matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult --- Apply the view function to the match variable and then match that -matchView (var:vars) ty (eqns@(eqn1:_)) - = do { -- we could pass in the expr from the PgView, - -- but this needs to extract the pat anyway - -- to figure out the type of the fresh variable - let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 - -- do the rest of the compilation - ; let pat_ty' = hsPatType pat - ; var' <- newUniqueId var pat_ty' - ; match_result <- match (var':vars) ty $ - map (decomposeFirstPat getViewPat) eqns - -- compile the view expressions - ; viewExpr' <- dsLExpr viewExpr - ; return (mkViewMatchResult var' - (mkCoreAppDs (text "matchView") viewExpr' (Var var)) - match_result) } -matchView _ _ _ = panic "matchView" - -matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult -matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) --- Since overloaded list patterns are treated as view patterns, --- the code is roughly the same as for matchView - = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1 - ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand - ; match_result <- match (var':vars) ty $ - map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern - ; e' <- dsSyntaxExpr e [Var var] - ; return (mkViewMatchResult var' e' match_result) } -matchOverloadedList _ _ _ = panic "matchOverloadedList" - --- decompose the first pattern and leave the rest alone -decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo -decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) - = eqn { eqn_pats = extractpat pat : pats} -decomposeFirstPat _ _ = panic "decomposeFirstPat" - -getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id -getCoPat (CoPat _ pat _) = pat -getCoPat _ = panic "getCoPat" -getBangPat (BangPat pat ) = unLoc pat -getBangPat _ = panic "getBangPat" -getViewPat (ViewPat _ pat _) = unLoc pat -getViewPat _ = panic "getViewPat" -getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing -getOLPat _ = panic "getOLPat" - -{- -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The list of EquationInfo can be empty, arising from - case x of {} or \case {} -In that situation we desugar to - case x of { _ -> error "pattern match failure" } -The *desugarer* isn't certain whether there really should be no -alternatives, so it adds a default case, as it always does. A later -pass may remove it if it's inaccessible. (See also Note [Empty case -alternatives] in CoreSyn.) - -We do *not* desugar simply to - error "empty case" -or some such, because 'x' might be bound to (error "hello"), in which -case we want to see that "hello" exception, not (error "empty case"). -See also Note [Case elimination: lifted case] in Simplify. - - -************************************************************************ -* * - Tidying patterns -* * -************************************************************************ - -Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ -which will be scrutinised. This means: -\begin{itemize} -\item -Replace variable patterns @x@ (@x /= v@) with the pattern @_@, -together with the binding @x = v@. -\item -Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. -\item -Removing lazy (irrefutable) patterns (you don't want to know...). -\item -Converting explicit tuple-, list-, and parallel-array-pats into ordinary -@ConPats@. -\item -Convert the literal pat "" to []. -\end{itemize} - -The result of this tidying is that the column of patterns will include -{\em only}: -\begin{description} -\item[@WildPats@:] -The @VarPat@ information isn't needed any more after this. - -\item[@ConPats@:] -@ListPats@, @TuplePats@, etc., are all converted into @ConPats@. - -\item[@LitPats@ and @NPats@:] -@LitPats@/@NPats@ of ``known friendly types'' (Int, Char, -Float, Double, at least) are converted to unboxed form; e.g., -\tr{(NPat (HsInt i) _ _)} is converted to: -\begin{verbatim} -(ConPat I# _ _ [LitPat (HsIntPrim i)]) -\end{verbatim} -\end{description} --} - -tidyEqnInfo :: Id -> EquationInfo - -> DsM (DsWrapper, EquationInfo) - -- DsM'd because of internal call to dsLHsBinds - -- and mkSelectorBinds. - -- "tidy1" does the interesting stuff, looking at - -- one pattern and fiddling the list of bindings. - -- - -- POST CONDITION: head pattern in the EqnInfo is - -- WildPat - -- ConPat - -- NPat - -- LitPat - -- NPlusKPat - -- but no other - -tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) - = panic "tidyEqnInfo" - -tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) - = do { (wrap, pat') <- tidy1 v pat - ; return (wrap, eqn { eqn_pats = do pat' : pats }) } - -tidy1 :: Id -- The Id being scrutinised - -> Pat Id -- The pattern against which it is to be matched - -> DsM (DsWrapper, -- Extra bindings to do before the match - Pat Id) -- Equivalent pattern - -------------------------------------------------------- --- (pat', mr') = tidy1 v pat mr --- tidies the *outer level only* of pat, giving pat' --- It eliminates many pattern forms (as-patterns, variable patterns, --- list patterns, etc) yielding one of: --- WildPat --- ConPatOut --- LitPat --- NPat --- NPlusKPat - -tidy1 v (ParPat pat) = tidy1 v (unLoc pat) -tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) -tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p - - -- case v of { x -> mr[] } - -- = case v of { _ -> let x=v in mr[] } -tidy1 v (VarPat (L _ var)) - = return (wrapBind var v, WildPat (idType var)) - - -- case v of { x@p -> mr[] } - -- = case v of { p -> let x=v in mr[] } -tidy1 v (AsPat (L _ var) pat) - = do { (wrap, pat') <- tidy1 v (unLoc pat) - ; return (wrapBind var v . wrap, pat') } - -{- now, here we handle lazy patterns: - tidy1 v ~p bs = (v, v1 = case v of p -> v1 : - v2 = case v of p -> v2 : ... : bs ) - - where the v_i's are the binders in the pattern. - - ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing? - - The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr --} - -tidy1 v (LazyPat pat) - -- This is a convenient place to check for unlifted types under a lazy pattern. - -- Doing this check during type-checking is unsatisfactory because we may - -- not fully know the zonked types yet. We sure do here. - = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat) - ; unless (null unlifted_bndrs) $ - putSrcSpanDs (getLoc pat) $ - errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ - text "Unlifted variables:") - 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) - unlifted_bndrs))) - - ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) - ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] - ; return (mkCoreLets sel_binds, WildPat (idType v)) } - -tidy1 _ (ListPat pats ty Nothing) - = return (idDsWrapper, unLoc list_ConPat) - where - list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) - (mkNilPat ty) - pats - --- Introduce fake parallel array constructors to be able to handle parallel --- arrays with the existing machinery for constructor pattern -tidy1 _ (PArrPat pats ty) - = return (idDsWrapper, unLoc parrConPat) - where - arity = length pats - parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty] - -tidy1 _ (TuplePat pats boxity tys) - = return (idDsWrapper, unLoc tuple_ConPat) - where - arity = length pats - tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys - -tidy1 _ (SumPat pat alt arity tys) - = return (idDsWrapper, unLoc sum_ConPat) - where - sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys - --- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (LitPat lit) - = return (idDsWrapper, tidyLitPat lit) - --- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (NPat (L _ lit) mb_neg eq ty) - = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty) - --- Everything else goes through unchanged... - -tidy1 _ non_interesting_pat - = return (idDsWrapper, non_interesting_pat) - --------------------- -tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id) - --- Discard par/sig under a bang -tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p -tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p - --- Push the bang-pattern inwards, in the hope that --- it may disappear next time -tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p))) -tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t) - --- Discard bang around strict pattern -tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p -tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p -tidy_bang_pat v _ p@(TuplePat {}) = tidy1 v p -tidy_bang_pat v _ p@(SumPat {}) = tidy1 v p -tidy_bang_pat v _ p@(PArrPat {}) = tidy1 v p - --- Data/newtype constructors -tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc) - , pat_args = args - , pat_arg_tys = arg_tys }) - -- Newtypes: push bang inwards (Trac #9844) - = - if isNewTyCon (dataConTyCon dc) - then tidy1 v (p { pat_args = push_bang_into_newtype_arg l ty args }) - else tidy1 v p -- Data types: discard the bang - where - (ty:_) = dataConInstArgTys dc arg_tys - -------------------- --- Default case, leave the bang there: --- VarPat, --- LazyPat, --- WildPat, --- ViewPat, --- pattern synonyms (ConPatOut with PatSynCon) --- NPat, --- NPlusKPat --- --- For LazyPat, remember that it's semantically like a VarPat --- i.e. !(~p) is not like ~p, or p! (Trac #8952) --- --- NB: SigPatIn, ConPatIn should not happen - -tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p)) - -------------------- -push_bang_into_newtype_arg :: SrcSpan - -> Type -- The type of the argument we are pushing - -- onto - -> HsConPatDetails Id -> HsConPatDetails Id --- See Note [Bang patterns and newtypes] --- We are transforming !(N p) into (N !p) -push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) - = ASSERT( null args) - PrefixCon [L l (BangPat 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 = L l (BangPat arg) })] }) -push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) - | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [L l (BangPat (noLoc (WildPat ty)))] -push_bang_into_newtype_arg _ _ cd - = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) - -{- -Note [Bang patterns and newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the pattern !(Just pat) we can discard the bang, because -the pattern is strict anyway. But for !(N pat), where - newtype NT = N Int -we definitely can't discard the bang. Trac #9844. - -So what we do is to push the bang inwards, in the hope that it will -get discarded there. So we transform - !(N pat) into (N !pat) - -But what if there is nothing to push the bang onto? In at least one instance -a user has written !(N {}) which we translate into (N !_). See #13215 - - -\noindent -{\bf Previous @matchTwiddled@ stuff:} - -Now we get to the only interesting part; note: there are choices for -translation [from Simon's notes]; translation~1: -\begin{verbatim} -deTwiddle [s,t] e -\end{verbatim} -returns -\begin{verbatim} -[ w = e, - s = case w of [s,t] -> s - t = case w of [s,t] -> t -] -\end{verbatim} - -Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple -evaluation of \tr{e}. An alternative translation (No.~2): -\begin{verbatim} -[ w = case e of [s,t] -> (s,t) - s = case w of (s,t) -> s - t = case w of (s,t) -> t -] -\end{verbatim} - -************************************************************************ -* * -\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing} -* * -************************************************************************ - -We might be able to optimise unmixing when confronted by -only-one-constructor-possible, of which tuples are the most notable -examples. Consider: -\begin{verbatim} -f (a,b,c) ... = ... -f d ... (e:f) = ... -f (g,h,i) ... = ... -f j ... = ... -\end{verbatim} -This definition would normally be unmixed into four equation blocks, -one per equation. But it could be unmixed into just one equation -block, because if the one equation matches (on the first column), -the others certainly will. - -You have to be careful, though; the example -\begin{verbatim} -f j ... = ... -------------------- -f (a,b,c) ... = ... -f d ... (e:f) = ... -f (g,h,i) ... = ... -\end{verbatim} -{\em must} be broken into two blocks at the line shown; otherwise, you -are forcing unnecessary evaluation. In any case, the top-left pattern -always gives the cue. You could then unmix blocks into groups of... -\begin{description} -\item[all variables:] -As it is now. -\item[constructors or variables (mixed):] -Need to make sure the right names get bound for the variable patterns. -\item[literals or variables (mixed):] -Presumably just a variant on the constructor case (as it is now). -\end{description} - -************************************************************************ -* * -* matchWrapper: a convenient way to call @match@ * -* * -************************************************************************ -\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@} - -Calls to @match@ often involve similar (non-trivial) work; that work -is collected here, in @matchWrapper@. This function takes as -arguments: -\begin{itemize} -\item -Typchecked @Matches@ (of a function definition, or a case or lambda -expression)---the main input; -\item -An error message to be inserted into any (runtime) pattern-matching -failure messages. -\end{itemize} - -As results, @matchWrapper@ produces: -\begin{itemize} -\item -A list of variables (@Locals@) that the caller must ``promise'' to -bind to appropriate values; and -\item -a @CoreExpr@, the desugared output (main result). -\end{itemize} - -The main actions of @matchWrapper@ include: -\begin{enumerate} -\item -Flatten the @[TypecheckedMatch]@ into a suitable list of -@EquationInfo@s. -\item -Create as many new variables as there are patterns in a pattern-list -(in any one of the @EquationInfo@s). -\item -Create a suitable ``if it fails'' expression---a call to @error@ using -the error-string input; the {\em type} of this fail value can be found -by examining one of the RHS expressions in one of the @EquationInfo@s. -\item -Call @match@ with all of this information! -\end{enumerate} --} - -matchWrapper :: HsMatchContext Name -- For shadowing warning messages - -> Maybe (LHsExpr Id) -- The scrutinee, if we check a case expr - -> MatchGroup Id (LHsExpr Id) -- Matches being desugared - -> DsM ([Id], CoreExpr) -- Results - -{- - There is one small problem with the Lambda Patterns, when somebody - writes something similar to: -\begin{verbatim} - (\ (x:xs) -> ...) -\end{verbatim} - he/she don't want a warning about incomplete patterns, that is done with - the flag @opt_WarnSimplePatterns@. - This problem also appears in the: -\begin{itemize} -\item @do@ patterns, but if the @do@ can fail - it creates another equation if the match can fail - (see @DsExpr.doDo@ function) -\item @let@ patterns, are treated by @matchSimply@ - List Comprension Patterns, are treated by @matchSimply@ also -\end{itemize} - -We can't call @matchSimply@ with Lambda patterns, -due to the fact that lambda patterns can have more than -one pattern, and match simply only accepts one pattern. - -JJQC 30-Nov-1997 --} - -matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches - , mg_arg_tys = arg_tys - , mg_res_ty = rhs_ty - , mg_origin = origin }) - = do { dflags <- getDynFlags - ; locn <- getSrcSpanDs - - ; new_vars <- case matches of - [] -> mapM newSysLocalDsNoLP arg_tys - (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) - - ; eqns_info <- mapM (mk_eqn_info new_vars) matches - - -- pattern match check warnings - ; unless (isGenerated origin) $ - when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $ - addTmCsDs (genCaseTmCs1 mb_scr new_vars) $ - -- See Note [Type and Term Equality Propagation] - checkMatches dflags (DsMatchContext ctxt locn) new_vars matches - - ; result_expr <- handleWarnings $ - matchEquations ctxt new_vars eqns_info rhs_ty - ; return (new_vars, result_expr) } - where - mk_eqn_info vars (L _ (Match ctx pats _ grhss)) - = do { dflags <- getDynFlags - ; let add_bang - | FunRhs {mc_strictness=SrcStrict} <- ctx - = pprTrace "addBang" empty addBang - | otherwise - = decideBangHood dflags - upats = map (unLoc . add_bang) pats - dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars - ; tm_cs <- genCaseTmCs2 mb_scr upats vars - ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation] - addTmCsDs tm_cs $ -- See Note [Type and Term Equality Propagation] - dsGRHSs ctxt upats grhss rhs_ty - ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } - - handleWarnings = if isGenerated origin - then discardWarningsDs - else id - - -matchEquations :: HsMatchContext Name - -> [MatchId] -> [EquationInfo] -> Type - -> DsM CoreExpr -matchEquations ctxt vars eqns_info rhs_ty - = do { let error_doc = matchContextErrString ctxt - - ; match_result <- match vars rhs_ty eqns_info - - ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc - ; extractMatchResult match_result fail_expr } - -{- -************************************************************************ -* * -\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} -* * -************************************************************************ - -@mkSimpleMatch@ is a wrapper for @match@ which deals with the -situation where we want to match a single expression against a single -pattern. It returns an expression. --} - -matchSimply :: CoreExpr -- Scrutinee - -> HsMatchContext Name -- Match kind - -> LPat Id -- Pattern it should match - -> CoreExpr -- Return this if it matches - -> CoreExpr -- Return this if it doesn't - -> DsM CoreExpr --- Do not warn about incomplete patterns; see matchSinglePat comments -matchSimply scrut hs_ctx pat result_expr fail_expr = do - let - match_result = cantFailMatchResult result_expr - rhs_ty = exprType fail_expr - -- Use exprType of fail_expr, because won't refine in the case of failure! - match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result - extractMatchResult match_result' fail_expr - -matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id - -> Type -> MatchResult -> DsM MatchResult --- matchSinglePat ensures that the scrutinee is a variable --- and then calls match_single_pat_var --- --- matchSinglePat does not warn about incomplete patterns --- Used for things like [ e | pat <- stuff ], where --- incomplete patterns are just fine - -matchSinglePat (Var var) ctx pat ty match_result - | not (isExternalName (idName var)) - = match_single_pat_var var ctx pat ty match_result - -matchSinglePat scrut hs_ctx pat ty match_result - = do { var <- selectSimpleMatchVarL pat - ; match_result' <- match_single_pat_var var hs_ctx pat ty match_result - ; return (adjustMatchResult (bindNonRec var scrut) match_result') } - -match_single_pat_var :: Id -- See Note [Match Ids] - -> HsMatchContext Name -> LPat Id - -> Type -> MatchResult -> DsM MatchResult -match_single_pat_var var ctx pat ty match_result - = ASSERT2( isInternalName (idName var), ppr var ) - do { dflags <- getDynFlags - ; locn <- getSrcSpanDs - - -- Pattern match check warnings - ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat) - - ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] - , eqn_rhs = match_result } - ; match [var] ty [eqn_info] } - - -{- -************************************************************************ -* * - Pattern classification -* * -************************************************************************ --} - -data PatGroup - = PgAny -- Immediate match: variables, wildcards, - -- lazy patterns - | PgCon DataCon -- Constructor patterns (incl list, tuple) - | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups] - | PgLit Literal -- Literal patterns - | PgN Rational -- Overloaded numeric literals; - -- see Note [Don't use Literal for PgN] - | PgOverS FastString -- Overloaded string literals - | PgNpK Integer -- n+k patterns - | PgBang -- Bang patterns - | PgCo Type -- Coercion patterns; the type is the type - -- of the pattern *inside* - | PgView (LHsExpr Id) -- view pattern (e -> p): - -- the LHsExpr is the expression e - Type -- the Type is the type of p (equivalently, the result type of e) - | PgOverloadedList - -{- Note [Don't use Literal for PgN] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously we had, as PatGroup constructors - - | ... - | PgN Literal -- Overloaded literals - | PgNpK Literal -- n+k patterns - | ... - -But Literal is really supposed to represent an *unboxed* literal, like Int#. -We were sticking the literal from, say, an overloaded numeric literal pattern -into a MachInt constructor. This didn't really make sense; and we now have -the invariant that value in a MachInt must be in the range of the target -machine's Int# type, and an overloaded literal could meaningfully be larger. - -Solution: For pattern grouping purposes, just store the literal directly in -the PgN constructor as a Rational if numeric, and add a PgOverStr constructor -for overloaded strings. --} - -groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]] --- If the result is of form [g1, g2, g3], --- (a) all the (pg,eq) pairs in g1 have the same pg --- (b) none of the gi are empty --- The ordering of equations is unchanged -groupEquations dflags eqns - = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns] - where - same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool - (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 - -subGroup :: (m -> [[EquationInfo]]) -- Map.elems - -> m -- Map.empty - -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup - -> (a -> [EquationInfo] -> m -> m) -- Map.insert - -> [(a, EquationInfo)] -> [[EquationInfo]] --- Input is a particular group. The result sub-groups the --- equations by with particular constructor, literal etc they match. --- Each sub-list in the result has the same PatGroup --- See Note [Take care with pattern order] --- Parameterized by map operations to allow different implementations --- and constraints, eg. types without Ord instance. -subGroup elems empty lookup insert group - = map reverse $ elems $ foldl accumulate empty group - where - accumulate pg_map (pg, eqn) - = case lookup pg pg_map of - Just eqns -> insert pg (eqn:eqns) pg_map - Nothing -> insert pg [eqn] pg_map - -- pg_map :: Map a [EquationInfo] - -- Equations seen so far in reverse order of appearance - -subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] -subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert - -subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]] -subGroupUniq = - subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v) - -{- Note [Pattern synonym groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see - f (P a) = e1 - f (P b) = e2 - ... -where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the -same group? We can if P is a constructor, but /not/ if P is a pattern synonym. -Consider (Trac #11224) - -- readMaybe :: Read a => String -> Maybe a - pattern PRead :: Read a => () => a -> String - pattern PRead a <- (readMaybe -> Just a) - - f (PRead (x::Int)) = e1 - f (PRead (y::Bool)) = e2 -This is all fine: we match the string by trying to read an Int; if that -fails we try to read a Bool. But clearly we can't combine the two into a single -match. - -Conclusion: we can combine when we invoke PRead /at the same type/. Hence -in PgSyn we record the instantiaing types, and use them in sameGroup. - -Note [Take care with pattern order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the subGroup function we must be very careful about pattern re-ordering, -Consider the patterns [ (True, Nothing), (False, x), (True, y) ] -Then in bringing together the patterns for True, we must not -swap the Nothing and y! --} - -sameGroup :: PatGroup -> PatGroup -> Bool --- Same group means that a single case expression --- or test will suffice to match both, *and* the order --- of testing within the group is insignificant. -sameGroup PgAny PgAny = True -sameGroup PgBang PgBang = True -sameGroup (PgCon _) (PgCon _) = True -- One case expression -sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2 - -- eqTypes: See Note [Pattern synonym groups] -sameGroup (PgLit _) (PgLit _) = True -- One case expression -sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant -sameGroup (PgOverS s1) (PgOverS s2) = s1==s2 -sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] -sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 - -- CoPats are in the same goup only if the type of the - -- enclosed pattern is the same. The patterns outside the CoPat - -- always have the same type, so this boils down to saying that - -- the two coercions are identical. -sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) - -- ViewPats are in the same group iff the expressions - -- are "equal"---conservatively, we use syntactic equality -sameGroup _ _ = False - --- An approximation of syntactic equality used for determining when view --- exprs are in the same group. --- This function can always safely return false; --- but doing so will result in the application of the view function being repeated. --- --- Currently: compare applications of literals and variables --- and anything else that we can do without involving other --- HsSyn types in the recursion --- --- NB we can't assume that the two view expressions have the same type. Consider --- f (e1 -> True) = ... --- f (e2 -> "hi") = ... -viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool -viewLExprEq (e1,_) (e2,_) = lexp e1 e2 - where - lexp :: LHsExpr Id -> LHsExpr Id -> Bool - lexp e e' = exp (unLoc e) (unLoc e') - - --------- - exp :: HsExpr Id -> HsExpr Id -> Bool - -- real comparison is on HsExpr's - -- strip parens - exp (HsPar (L _ e)) e' = exp e e' - exp e (HsPar (L _ e')) = exp e e' - -- because the expressions do not necessarily have the same type, - -- we have to compare the wrappers - exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e' - exp (HsVar i) (HsVar i') = i == i' - exp (HsConLikeOut c) (HsConLikeOut c') = c == c' - -- the instance for IPName derives using the id, so this works if the - -- above does - exp (HsIPVar i) (HsIPVar i') = i == i' - exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x' - exp (HsOverLit l) (HsOverLit l') = - -- Overloaded lits are equal if they have the same type - -- and the data is the same. - -- this is coarser than comparing the SyntaxExpr's in l and l', - -- which resolve the overloading (e.g., fromInteger 1), - -- because these expressions get written as a bunch of different variables - -- (presumably to improve sharing) - eqType (overLitType l) (overLitType l') && l == l' - exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' - -- the fixities have been straightened out by now, so it's safe - -- to ignore them? - exp (OpApp l o _ ri) (OpApp l' o' _ ri') = - lexp l l' && lexp o o' && lexp ri ri' - exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n' - exp (SectionL e1 e2) (SectionL e1' e2') = - lexp e1 e1' && lexp e2 e2' - exp (SectionR e1 e2) (SectionR e1' e2') = - lexp e1 e1' && lexp e2 e2' - exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) = - eq_list tup_arg es1 es2 - exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e' - exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = - lexp e e' && lexp e1 e1' && lexp e2 e2' - - -- Enhancement: could implement equality for more expressions - -- if it seems useful - -- But no need for HsLit, ExplicitList, ExplicitTuple, - -- because they cannot be functions - exp _ _ = False - - --------- - syn_exp :: SyntaxExpr Id -> SyntaxExpr Id -> Bool - syn_exp (SyntaxExpr { syn_expr = expr1 - , syn_arg_wraps = arg_wraps1 - , syn_res_wrap = res_wrap1 }) - (SyntaxExpr { syn_expr = expr2 - , syn_arg_wraps = arg_wraps2 - , syn_res_wrap = res_wrap2 }) - = exp expr1 expr2 && - and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) && - wrap res_wrap1 res_wrap2 - - --------- - tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2 - tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 - tup_arg _ _ = False - - --------- - wrap :: HsWrapper -> HsWrapper -> Bool - -- Conservative, in that it demands that wrappers be - -- syntactically identical and doesn't look under binders - -- - -- Coarser notions of equality are possible - -- (e.g., reassociating compositions, - -- equating different ways of writing a coercion) - wrap WpHole WpHole = True - wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' - wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2' - wrap (WpCast co) (WpCast co') = co `eqCoercion` co' - wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2 - wrap (WpTyApp t) (WpTyApp t') = eqType t t' - -- Enhancement: could implement equality for more wrappers - -- if it seems useful (lams and lets) - wrap _ _ = False - - --------- - ev_term :: EvTerm -> EvTerm -> Bool - ev_term (EvId a) (EvId b) = a==b - ev_term (EvCoercion a) (EvCoercion b) = a `eqCoercion` b - ev_term _ _ = False - - --------- - eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool - eq_list _ [] [] = True - eq_list _ [] (_:_) = False - eq_list _ (_:_) [] = False - eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys - -patGroup :: DynFlags -> Pat Id -> PatGroup -patGroup _ (ConPatOut { pat_con = L _ con - , pat_arg_tys = tys }) - | RealDataCon dcon <- con = PgCon dcon - | PatSynCon psyn <- con = PgSyn psyn tys -patGroup _ (WildPat {}) = PgAny -patGroup _ (BangPat {}) = PgBang -patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) = - case (oval, isJust mb_neg) of - (HsIntegral _ i, False) -> PgN (fromInteger i) - (HsIntegral _ i, True ) -> PgN (-fromInteger i) - (HsFractional r, False) -> PgN (fl_value r) - (HsFractional r, True ) -> PgN (-fl_value r) - (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) - PgOverS s -patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) = - case oval of - HsIntegral _ i -> PgNpK i - _ -> pprPanic "patGroup NPlusKPat" (ppr oval) -patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern -patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) -patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList -patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) -patGroup _ pat = pprPanic "patGroup" (ppr pat) - -{- -Note [Grouping overloaded literal patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -WATCH OUT! Consider - - f (n+1) = ... - f (n+2) = ... - f (n+1) = ... - -We can't group the first and third together, because the second may match -the same thing as the first. Same goes for *overloaded* literal patterns - f 1 True = ... - f 2 False = ... - f 1 False = ... -If the first arg matches '1' but the second does not match 'True', we -cannot jump to the third equation! Because the same argument might -match '2'! -Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group. --} diff --git a/deSugar/Match.hs-boot b/deSugar/Match.hs-boot deleted file mode 100644 --- a/deSugar/Match.hs-boot +++ /dev/null @@ -1,34 +0,0 @@ -module Match where -import Var ( Id ) -import TcType ( Type ) -import DsMonad ( DsM, EquationInfo, MatchResult ) -import CoreSyn ( CoreExpr ) -import HsSyn ( LPat, HsMatchContext, MatchGroup, LHsExpr ) -import Name ( Name ) - -match :: [Id] - -> Type - -> [EquationInfo] - -> DsM MatchResult - -matchWrapper - :: HsMatchContext Name - -> Maybe (LHsExpr Id) - -> MatchGroup Id (LHsExpr Id) - -> DsM ([Id], CoreExpr) - -matchSimply - :: CoreExpr - -> HsMatchContext Name - -> LPat Id - -> CoreExpr - -> CoreExpr - -> DsM CoreExpr - -matchSinglePat - :: CoreExpr - -> HsMatchContext Name - -> LPat Id - -> Type - -> MatchResult - -> DsM MatchResult diff --git a/deSugar/MatchCon.hs b/deSugar/MatchCon.hs deleted file mode 100644 --- a/deSugar/MatchCon.hs +++ /dev/null @@ -1,287 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Pattern-matching constructors --} - -{-# LANGUAGE CPP #-} - -module MatchCon ( matchConFamily, matchPatSyn ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} Match ( match ) - -import HsSyn -import DsBinds -import ConLike -import TcType -import DsMonad -import DsUtils -import MkCore ( mkCoreLets ) -import Util -import ListSetOps ( runs ) -import Id -import NameEnv -import FieldLabel ( flSelector ) -import SrcLoc -import DynFlags -import Outputable -import Control.Monad(liftM) - -{- -We are confronted with the first column of patterns in a set of -equations, all beginning with constructors from one ``family'' (e.g., -@[]@ and @:@ make up the @List@ ``family''). We want to generate the -alternatives for a @Case@ expression. There are several choices: -\begin{enumerate} -\item -Generate an alternative for every constructor in the family, whether -they are used in this set of equations or not; this is what the Wadler -chapter does. -\begin{description} -\item[Advantages:] -(a)~Simple. (b)~It may also be that large sparsely-used constructor -families are mainly handled by the code for literals. -\item[Disadvantages:] -(a)~Not practical for large sparsely-used constructor families, e.g., -the ASCII character set. (b)~Have to look up a list of what -constructors make up the whole family. -\end{description} - -\item -Generate an alternative for each constructor used, then add a default -alternative in case some constructors in the family weren't used. -\begin{description} -\item[Advantages:] -(a)~Alternatives aren't generated for unused constructors. (b)~The -STG is quite happy with defaults. (c)~No lookup in an environment needed. -\item[Disadvantages:] -(a)~A spurious default alternative may be generated. -\end{description} - -\item -``Do it right:'' generate an alternative for each constructor used, -and add a default alternative if all constructors in the family -weren't used. -\begin{description} -\item[Advantages:] -(a)~You will get cases with only one alternative (and no default), -which should be amenable to optimisation. Tuples are a common example. -\item[Disadvantages:] -(b)~Have to look up constructor families in TDE (as above). -\end{description} -\end{enumerate} - -We are implementing the ``do-it-right'' option for now. The arguments -to @matchConFamily@ are the same as to @match@; the extra @Int@ -returned is the number of constructors in the family. - -The function @matchConFamily@ is concerned with this -have-we-used-all-the-constructors? question; the local function -@match_cons_used@ does all the real work. --} - -matchConFamily :: [Id] - -> Type - -> [[EquationInfo]] - -> DsM MatchResult --- Each group of eqns is for a single constructor -matchConFamily (var:vars) ty groups - = do dflags <- getDynFlags - alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups - return (mkCoAlgCaseMatchResult dflags var ty alts) - where - toRealAlt alt = case alt_pat alt of - RealDataCon dcon -> alt{ alt_pat = dcon } - _ -> panic "matchConFamily: not RealDataCon" -matchConFamily [] _ _ = panic "matchConFamily []" - -matchPatSyn :: [Id] - -> Type - -> [EquationInfo] - -> DsM MatchResult -matchPatSyn (var:vars) ty eqns - = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns - return (mkCoSynCaseMatchResult var ty alt) - where - toSynAlt alt = case alt_pat alt of - PatSynCon psyn -> alt{ alt_pat = psyn } - _ -> panic "matchPatSyn: not PatSynCon" -matchPatSyn _ _ _ = panic "matchPatSyn []" - -type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id)) - -matchOneConLike :: [Id] - -> Type - -> [EquationInfo] - -> DsM (CaseAlt ConLike) -matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor - = do { let inst_tys = ASSERT( tvs1 `equalLength` ex_tvs ) - arg_tys ++ mkTyVarTys tvs1 - - val_arg_tys = conLikeInstOrigArgTys con1 inst_tys - -- dataConInstOrigArgTys takes the univ and existential tyvars - -- and returns the types of the *value* args, which is what we want - - match_group :: [Id] - -> [(ConArgPats, EquationInfo)] -> DsM MatchResult - -- All members of the group have compatible ConArgPats - match_group arg_vars arg_eqn_prs - = ASSERT( notNull arg_eqn_prs ) - do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) - ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs - ; match_result <- match (group_arg_vars ++ vars) ty eqns' - ; return (adjustMatchResult (foldr1 (.) wraps) match_result) } - - shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, - pat_binds = bind, pat_args = args - } : pats })) - = do ds_bind <- dsTcEvBinds bind - return ( wrapBinds (tvs `zip` tvs1) - . wrapBinds (ds `zip` dicts1) - . mkCoreLets ds_bind - , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats } - ) - shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) - - ; arg_vars <- selectConMatchVars val_arg_tys args1 - -- Use the first equation as a source of - -- suggestions for the new variables - - -- Divide into sub-groups; see Note [Record patterns] - ; let groups :: [[(ConArgPats, EquationInfo)]] - groups = runs compatible_pats [ (pat_args (firstPat eqn), eqn) - | eqn <- eqn1:eqns ] - - ; match_results <- mapM (match_group arg_vars) groups - - ; return $ MkCaseAlt{ alt_pat = con1, - alt_bndrs = tvs1 ++ dicts1 ++ arg_vars, - alt_wrapper = wrapper1, - alt_result = foldr1 combineMatchResults match_results } } - where - ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1, - pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } - = firstPat eqn1 - fields1 = map flSelector (conLikeFieldLabels con1) - - ex_tvs = conLikeExTyVars con1 - - -- Choose the right arg_vars in the right order for this group - -- Note [Record patterns] - select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id] - select_arg_vars arg_vars ((arg_pats, _) : _) - | RecCon flds <- arg_pats - , let rpats = rec_flds flds - , not (null rpats) -- Treated specially; cf conArgPats - = ASSERT2( length fields1 == length 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))) - select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" -matchOneConLike _ _ [] = panic "matchOneCon []" - ------------------ -compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool --- Two constructors have compatible argument patterns if the number --- and order of sub-matches is the same in both cases -compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2 -compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1) -compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2) -compatible_pats _ _ = True -- Prefix or infix con - -same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool -same_fields flds1 flds2 - = all2 (\(L _ f1) (L _ f2) - -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) - (rec_flds flds1) (rec_flds flds2) - - ------------------ -selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id] -selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDsNoLP arg_tys -selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps) -selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2] - -conArgPats :: [Type] -- Instantiated argument types - -- Used only to fill in the types of WildPats, which - -- are probably never looked at anyway - -> ConArgPats - -> [Pat Id] -conArgPats _arg_tys (PrefixCon ps) = map unLoc ps -conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] -conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) - | null rpats = map WildPat arg_tys - -- Important special case for C {}, which can be used for a - -- datacon that isn't declared to have fields at all - | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats - -{- -Note [Record patterns] -~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = T { x,y,z :: Bool } - - f (T { y=True, x=False }) = ... - -We must match the patterns IN THE ORDER GIVEN, thus for the first -one we match y=True before x=False. See Trac #246; or imagine -matching against (T { y=False, x=undefined }): should fail without -touching the undefined. - -Now consider: - - f (T { y=True, x=False }) = ... - f (T { x=True, y= False}) = ... - -In the first we must test y first; in the second we must test x -first. So we must divide even the equations for a single constructor -T into sub-goups, based on whether they match the same field in the -same order. That's what the (runs compatible_pats) grouping. - -All non-record patterns are "compatible" in this sense, because the -positional patterns (T a b) and (a `T` b) all match the arguments -in order. Also T {} is special because it's equivalent to (T _ _). -Hence the (null rpats) checks here and there. - - -Note [Existentials in shift_con_pat] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = forall a. Ord a => T a (a->Int) - - f (T x f) True = ...expr1... - f (T y g) False = ...expr2.. - -When we put in the tyvars etc we get - - f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1... - f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2... - -After desugaring etc we'll get a single case: - - f = \t::T b::Bool -> - case t of - T a (d::Ord a) (x::a) (f::a->Int)) -> - case b of - True -> ...expr1... - False -> ...expr2... - -*** We have to substitute [a/b, d/e] in expr2! ** -Hence - False -> ....((/\b\(e:Ord b).expr2) a d).... - -Originally I tried to use - (\b -> let e = d in expr2) a -to do this substitution. While this is "correct" in a way, it fails -Lint, because e::Ord b but d::Ord a. - --} diff --git a/deSugar/MatchLit.hs b/deSugar/MatchLit.hs deleted file mode 100644 --- a/deSugar/MatchLit.hs +++ /dev/null @@ -1,456 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Pattern-matching literal patterns --} - -{-# LANGUAGE CPP, ScopedTypeVariables #-} - -module MatchLit ( dsLit, dsOverLit, dsOverLit', hsLitKey - , tidyLitPat, tidyNPat - , matchLiterals, matchNPlusKPats, matchNPats - , warnAboutIdentities, warnAboutOverflowedLiterals - , warnAboutEmptyEnumerations - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} Match ( match ) -import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr ) - -import DsMonad -import DsUtils - -import HsSyn - -import Id -import CoreSyn -import MkCore -import TyCon -import DataCon -import TcHsSyn ( shortCutLit ) -import TcType -import Name -import Type -import PrelNames -import TysWiredIn -import Literal -import SrcLoc -import Data.Ratio -import Outputable -import BasicTypes -import DynFlags -import Util -import FastString -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Int -import Data.Word - -{- -************************************************************************ -* * - Desugaring literals - [used to be in DsExpr, but DsMeta needs it, - and it's nice to avoid a loop] -* * -************************************************************************ - -We give int/float literals type @Integer@ and @Rational@, respectively. -The typechecker will (presumably) have put \tr{from{Integer,Rational}s} -around them. - -ToDo: put in range checks for when converting ``@i@'' -(or should that be in the typechecker?) - -For numeric literals, we try to detect there use at a standard type -(@Int@, @Float@, etc.) are directly put in the right constructor. -[NB: down with the @App@ conversion.] - -See also below where we look for @DictApps@ for \tr{plusInt}, etc. --} - -dsLit :: HsLit -> DsM CoreExpr -dsLit (HsStringPrim _ s) = return (Lit (MachStr s)) -dsLit (HsCharPrim _ c) = return (Lit (MachChar c)) -dsLit (HsIntPrim _ i) = return (Lit (MachInt i)) -dsLit (HsWordPrim _ w) = return (Lit (MachWord w)) -dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i)) -dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w)) -dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f))) -dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) - -dsLit (HsChar _ c) = return (mkCharExpr c) -dsLit (HsString _ str) = mkStringExprFS str -dsLit (HsInteger _ i _) = mkIntegerExpr i -dsLit (HsInt _ i) = do dflags <- getDynFlags - return (mkIntExpr dflags i) - -dsLit (HsRat r ty) = do - num <- mkIntegerExpr (numerator (fl_value r)) - denom <- mkIntegerExpr (denominator (fl_value r)) - return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) - where - (ratio_data_con, integer_ty) - = case tcSplitTyConApp ty of - (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) - (head (tyConDataCons tycon), i_ty) - x -> pprPanic "dsLit" (ppr x) - -dsOverLit :: HsOverLit Id -> DsM CoreExpr -dsOverLit lit = do { dflags <- getDynFlags - ; warnAboutOverflowedLiterals dflags lit - ; dsOverLit' dflags lit } - -dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr --- Post-typechecker, the HsExpr field of an OverLit contains --- (an expression for) the literal value itself -dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable - , ol_witness = witness, ol_type = ty }) - | not rebindable - , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut] - | otherwise = dsExpr witness - -{- -Note [Literal short cut] -~~~~~~~~~~~~~~~~~~~~~~~~ -The type checker tries to do this short-cutting as early as possible, but -because of unification etc, more information is available to the desugarer. -And where it's possible to generate the correct literal right away, it's -much better to do so. - - -************************************************************************ -* * - Warnings about overflowed literals -* * -************************************************************************ - -Warn about functions like toInteger, fromIntegral, that convert -between one type and another when the to- and from- types are the -same. Then it's probably (albeit not definitely) the identity --} - -warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM () -warnAboutIdentities dflags (Var conv_fn) type_of_conv - | wopt Opt_WarnIdentities dflags - , idName conv_fn `elem` conversionNames - , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv - , arg_ty `eqType` res_ty -- So we are converting ty -> ty - = warnDs (Reason Opt_WarnIdentities) - (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv - , nest 2 $ text "can probably be omitted" - ]) -warnAboutIdentities _ _ _ = return () - -conversionNames :: [Name] -conversionNames - = [ toIntegerName, toRationalName - , fromIntegralName, realToFracName ] - -- We can't easily add fromIntegerName, fromRationalName, - -- because they are generated by literals - -warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM () -warnAboutOverflowedLiterals dflags lit - | wopt Opt_WarnOverflowedLiterals dflags - , Just (i, tc) <- getIntegralLit lit - = if tc == intTyConName then check i tc (undefined :: Int) - else if tc == int8TyConName then check i tc (undefined :: Int8) - else if tc == int16TyConName then check i tc (undefined :: Int16) - else if tc == int32TyConName then check i tc (undefined :: Int32) - else if tc == int64TyConName then check i tc (undefined :: Int64) - else if tc == wordTyConName then check i tc (undefined :: Word) - else if tc == word8TyConName then check i tc (undefined :: Word8) - else if tc == word16TyConName then check i tc (undefined :: Word16) - else if tc == word32TyConName then check i tc (undefined :: Word32) - else if tc == word64TyConName then check i tc (undefined :: Word64) - else return () - - | otherwise = return () - where - check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM () - check i tc _proxy - = when (i < minB || i > maxB) $ do - warnDs (Reason Opt_WarnOverflowedLiterals) - (vcat [ text "Literal" <+> integer i - <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range") - <+> integer minB <> text ".." <> integer maxB - , sug ]) - where - minB = toInteger (minBound :: a) - maxB = toInteger (maxBound :: a) - sug | minB == -i -- Note [Suggest NegativeLiterals] - , i > 0 - , not (xopt LangExt.NegativeLiterals dflags) - = text "If you are trying to write a large negative literal, use NegativeLiterals" - | otherwise = Outputable.empty - -{- -Note [Suggest NegativeLiterals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you write - x :: Int8 - x = -128 -it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals. -We get an erroneous suggestion for - x = 128 -but perhaps that does not matter too much. --} - -warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM () --- Warns about [2,3 .. 1] which returns the empty list --- Only works for integral types, not floating point -warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr - | wopt Opt_WarnEmptyEnumerations dflags - , Just (from,tc) <- getLHsIntegralLit fromExpr - , Just mThn <- traverse getLHsIntegralLit mThnExpr - , Just (to,_) <- getLHsIntegralLit toExpr - , let check :: forall a. (Enum a, Num a) => a -> DsM () - check _proxy - = when (null enumeration) $ - warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty") - where - enumeration :: [a] - enumeration = case mThn of - Nothing -> [fromInteger from .. fromInteger to] - Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to] - - = if tc == intTyConName then check (undefined :: Int) - else if tc == int8TyConName then check (undefined :: Int8) - else if tc == int16TyConName then check (undefined :: Int16) - else if tc == int32TyConName then check (undefined :: Int32) - else if tc == int64TyConName then check (undefined :: Int64) - else if tc == wordTyConName then check (undefined :: Word) - else if tc == word8TyConName then check (undefined :: Word8) - else if tc == word16TyConName then check (undefined :: Word16) - else if tc == word32TyConName then check (undefined :: Word32) - else if tc == word64TyConName then check (undefined :: Word64) - else if tc == integerTyConName then check (undefined :: Integer) - else return () - - | otherwise = return () - -getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name) --- See if the expression is an Integral literal --- Remember to look through automatically-added tick-boxes! (Trac #8384) -getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsTick _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit -getLHsIntegralLit _ = Nothing - -getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name) -getIntegralLit (OverLit { ol_val = HsIntegral _ i, ol_type = ty }) - | Just tc <- tyConAppTyCon_maybe ty - = Just (i, tyConName tc) -getIntegralLit _ = Nothing - -{- -************************************************************************ -* * - Tidying lit pats -* * -************************************************************************ --} - -tidyLitPat :: HsLit -> Pat Id --- Result has only the following HsLits: --- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim --- HsDoublePrim, HsStringPrim, HsString --- * HsInteger, HsRat, HsInt can't show up in LitPats --- * We get rid of HsChar right here -tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c) -tidyLitPat (HsString src s) - | lengthFS s <= 1 -- Short string literals only - = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon - [mkCharLitPat src c, pat] [charTy]) - (mkNilPat charTy) (unpackFS s) - -- The stringTy is the type of the whole pattern, not - -- the type to instantiate (:) or [] with! -tidyLitPat lit = LitPat lit - ----------------- -tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat - -- We need this argument because tidyNPat is called - -- both by Match and by Check, but they tidy LitPats - -- slightly differently; and we must desugar - -- literals consistently (see Trac #5117) - -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Type - -> Pat Id -tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty - -- False: Take short cuts only if the literal is not using rebindable syntax - -- - -- Once that is settled, look for cases where the type of the - -- entire overloaded literal matches the type of the underlying literal, - -- and in that case take the short cut - -- NB: Watch out for weird cases like Trac #3382 - -- f :: Int -> Int - -- f "blah" = 4 - -- which might be ok if we have 'instance IsString Int' - -- - | not type_change, isIntTy ty, Just int_lit <- mb_int_lit - = mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit) - | not type_change, isWordTy ty, Just int_lit <- mb_int_lit - = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit) - | not type_change, isStringTy ty, Just str_lit <- mb_str_lit - = tidy_lit_pat (HsString NoSourceText str_lit) - -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 - -- If we do convert to the constructor form, we'll generate a case - -- expression on a Float# or Double# and that's not allowed in Core; see - -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules - where - -- Sometimes (like in test case - -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include - -- type-changing wrappers (for example, from Id Int to Int, for the identity - -- type family Id). In these cases, we can't do the short-cut. - type_change = not (outer_ty `eqType` ty) - - mk_con_pat :: DataCon -> HsLit -> Pat Id - mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] []) - - mb_int_lit :: Maybe Integer - mb_int_lit = case (mb_neg, val) of - (Nothing, HsIntegral _ i) -> Just i - (Just _, HsIntegral _ i) -> Just (-i) - _ -> Nothing - - mb_str_lit :: Maybe FastString - mb_str_lit = case (mb_neg, val) of - (Nothing, HsIsString _ s) -> Just s - _ -> Nothing - -tidyNPat _ over_lit mb_neg eq outer_ty - = NPat (noLoc over_lit) mb_neg eq outer_ty - -{- -************************************************************************ -* * - Pattern matching on LitPat -* * -************************************************************************ --} - -matchLiterals :: [Id] - -> Type -- Type of the whole case expression - -> [[EquationInfo]] -- All PgLits - -> DsM MatchResult - -matchLiterals (var:vars) ty sub_groups - = ASSERT( notNull sub_groups && all notNull sub_groups ) - do { -- Deal with each group - ; alts <- mapM match_group sub_groups - - -- Combine results. For everything except String - -- we can use a case expression; for String we need - -- a chain of if-then-else - ; if isStringTy (idType var) then - do { eq_str <- dsLookupGlobalId eqStringName - ; mrs <- mapM (wrap_str_guard eq_str) alts - ; return (foldr1 combineMatchResults mrs) } - else - return (mkCoPrimCaseMatchResult var ty alts) - } - where - match_group :: [EquationInfo] -> DsM (Literal, MatchResult) - match_group eqns - = do dflags <- getDynFlags - let LitPat hs_lit = firstPat (head eqns) - match_result <- match vars ty (shiftEqns eqns) - return (hsLitKey dflags hs_lit, match_result) - - wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult - -- Equality check for string literals - wrap_str_guard eq_str (MachStr s, mr) - = do { -- We now have to convert back to FastString. Perhaps there - -- should be separate MachBytes and MachStr constructors? - let s' = mkFastStringByteString s - ; lit <- mkStringExprFS s' - ; let pred = mkApps (Var eq_str) [Var var, lit] - ; return (mkGuardedMatchResult pred mr) } - wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) - -matchLiterals [] _ _ = panic "matchLiterals []" - ---------------------------- -hsLitKey :: DynFlags -> HsLit -> Literal --- Get the Core literal corresponding to a HsLit. --- It only works for primitive types and strings; --- others have been removed by tidy --- For HsString, it produces a MachStr, which really represents an _unboxed_ --- string literal; and we deal with it in matchLiterals above. Otherwise, it --- produces a primitive Literal of type matching the original HsLit. --- In the case of the fixed-width numeric types, we need to wrap here --- because Literal has an invariant that the literal is in range, while --- HsLit does not. -hsLitKey dflags (HsIntPrim _ i) = mkMachIntWrap dflags i -hsLitKey dflags (HsWordPrim _ w) = mkMachWordWrap dflags w -hsLitKey _ (HsInt64Prim _ i) = mkMachInt64Wrap i -hsLitKey _ (HsWord64Prim _ w) = mkMachWord64Wrap w -hsLitKey _ (HsCharPrim _ c) = mkMachChar c -hsLitKey _ (HsFloatPrim f) = mkMachFloat (fl_value f) -hsLitKey _ (HsDoublePrim d) = mkMachDouble (fl_value d) -hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s) -hsLitKey _ l = pprPanic "hsLitKey" (ppr l) - -{- -************************************************************************ -* * - Pattern matching on NPat -* * -************************************************************************ --} - -matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1 - ; lit_expr <- dsOverLit lit - ; neg_lit <- case mb_neg of - Nothing -> return lit_expr - Just neg -> dsSyntaxExpr neg [lit_expr] - ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit] - ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) - ; return (mkGuardedMatchResult pred_expr match_result) } -matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns)) - -{- -************************************************************************ -* * - Pattern matching on n+k patterns -* * -************************************************************************ - -For an n+k pattern, we use the various magic expressions we've been given. -We generate: -\begin{verbatim} - if ge var lit then - let n = sub var lit - in - else - -\end{verbatim} --} - -matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult --- All NPlusKPats, for the *same* literal k -matchNPlusKPats (var:vars) ty (eqn1:eqns) - = do { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1 - ; lit1_expr <- dsOverLit lit1 - ; lit2_expr <- dsOverLit lit2 - ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] - ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr] - ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) - ; match_result <- match vars ty eqns' - ; return (mkGuardedMatchResult pred_expr $ - mkCoLetMatchResult (NonRec n1 minusk_expr) $ - adjustMatchResult (foldr1 (.) wraps) $ - match_result) } - where - shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats }) - = (wrapBind n n1, eqn { eqn_pats = pats }) - -- The wrapBind is a no-op for the first equation - shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) - -matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns)) diff --git a/deSugar/PmExpr.hs b/deSugar/PmExpr.hs deleted file mode 100644 --- a/deSugar/PmExpr.hs +++ /dev/null @@ -1,449 +0,0 @@ -{- -Author: George Karachalias - -Haskell expressions (as used by the pattern matching checker) and utilities. --} - -{-# LANGUAGE CPP #-} - -module PmExpr ( - PmExpr(..), PmLit(..), SimpleEq, ComplexEq, toComplex, eqPmLit, - truePmExpr, falsePmExpr, isTruePmExpr, isFalsePmExpr, isNotPmExprOther, - lhsExprToPmExpr, hsExprToPmExpr, substComplexEq, filterComplex, - pprPmExprWithParens, runPmPprM - ) where - -#include "HsVersions.h" - -import HsSyn -import Id -import Name -import NameSet -import DataCon -import ConLike -import TysWiredIn -import Outputable -import Util -import SrcLoc - -import Data.Maybe (mapMaybe) -import Data.List (groupBy, sortBy, nubBy) -import Control.Monad.Trans.State.Lazy - -{- -%************************************************************************ -%* * - Lifted Expressions -%* * -%************************************************************************ --} - -{- Note [PmExprOther in PmExpr] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since there is no plan to extend the (currently pretty naive) term oracle in -the near future, instead of playing with the verbose (HsExpr Id), we lift it to -PmExpr. All expressions the term oracle does not handle are wrapped by the -constructor PmExprOther. Note that we do not perform substitution in -PmExprOther. Because of this, we do not even print PmExprOther, since they may -refer to variables that are otherwise substituted away. --} - --- ---------------------------------------------------------------------------- --- ** Types - --- | Lifted expressions for pattern match checking. -data PmExpr = PmExprVar Name - | PmExprCon ConLike [PmExpr] - | PmExprLit PmLit - | PmExprEq PmExpr PmExpr -- Syntactic equality - | PmExprOther (HsExpr Id) -- Note [PmExprOther in PmExpr] - - -mkPmExprData :: DataCon -> [PmExpr] -> PmExpr -mkPmExprData dc args = PmExprCon (RealDataCon dc) args - --- | Literals (simple and overloaded ones) for pattern match checking. -data PmLit = PmSLit HsLit -- simple - | PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded - --- | Equality between literals for pattern match checking. -eqPmLit :: PmLit -> PmLit -> Bool -eqPmLit (PmSLit l1) (PmSLit l2) = l1 == l2 -eqPmLit (PmOLit b1 l1) (PmOLit b2 l2) = b1 == b2 && l1 == l2 - -- See Note [Undecidable Equality for Overloaded Literals] -eqPmLit _ _ = False - -{- Note [Undecidable Equality for Overloaded Literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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 should be able to solve the -constraint: False ~ (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. Performance. - Having an unresolved constraint False ~ (fromInteger 2 ~ fromInteger 1) - lying around could become expensive really fast. Ticket #11161 illustrates - how heavy use of overloaded literals can generate plenty of those - constraints, effectively undermining the term oracle's performance. - -3. Error nessages/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 treat overloaded literals that look different as different. The -impact of this 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 deSugar/Check.hs and effectively addresses - #11161. - - * The warnings issued are simpler. - - * We do not play on the safe side, strictly speaking. The assumption that - 1 /= 2 makes the redundancy check more conservative but at the same time - makes its dual (exhaustiveness check) unsafe. This we can live with, mainly - for two reasons: - 1. At the moment we do not use the results of the check during compilation - where this would be a disaster (could result in runtime errors even if - our function was deemed exhaustive). - 2. Pattern matcing on literals can never be considered exhaustive unless we - have a catch-all clause. Hence, this assumption affects mainly the - appearance of the warnings and is, in practice safe. --} - -nubPmLit :: [PmLit] -> [PmLit] -nubPmLit = nubBy eqPmLit - --- | Term equalities -type SimpleEq = (Id, PmExpr) -- We always use this orientation -type ComplexEq = (PmExpr, PmExpr) - --- | Lift a `SimpleEq` to a `ComplexEq` -toComplex :: SimpleEq -> ComplexEq -toComplex (x,e) = (PmExprVar (idName x), e) - --- | Expression `True' -truePmExpr :: PmExpr -truePmExpr = mkPmExprData trueDataCon [] - --- | Expression `False' -falsePmExpr :: PmExpr -falsePmExpr = mkPmExprData falseDataCon [] - --- ---------------------------------------------------------------------------- --- ** Predicates on PmExpr - --- | Check if an expression is lifted or not -isNotPmExprOther :: PmExpr -> Bool -isNotPmExprOther (PmExprOther _) = False -isNotPmExprOther _expr = True - --- | Check whether a literal is negated -isNegatedPmLit :: PmLit -> Bool -isNegatedPmLit (PmOLit b _) = b -isNegatedPmLit _other_lit = False - --- | Check whether a PmExpr is syntactically equal to term `True'. -isTruePmExpr :: PmExpr -> Bool -isTruePmExpr (PmExprCon c []) = c == RealDataCon trueDataCon -isTruePmExpr _other_expr = False - --- | Check whether a PmExpr is syntactically equal to term `False'. -isFalsePmExpr :: PmExpr -> Bool -isFalsePmExpr (PmExprCon c []) = c == RealDataCon falseDataCon -isFalsePmExpr _other_expr = False - --- | Check whether a PmExpr is syntactically e -isNilPmExpr :: PmExpr -> Bool -isNilPmExpr (PmExprCon c _) = c == RealDataCon nilDataCon -isNilPmExpr _other_expr = False - --- | Check whether a PmExpr is syntactically equal to (x == y). --- Since (==) is overloaded and can have an arbitrary implementation, we use --- the PmExprEq constructor to represent only equalities with non-overloaded --- literals where it coincides with a syntactic equality check. -isPmExprEq :: PmExpr -> Maybe (PmExpr, PmExpr) -isPmExprEq (PmExprEq e1 e2) = Just (e1,e2) -isPmExprEq _other_expr = Nothing - --- | Check if a DataCon is (:). -isConsDataCon :: DataCon -> Bool -isConsDataCon con = consDataCon == con - --- ---------------------------------------------------------------------------- --- ** Substitution in PmExpr - --- | We return a boolean along with the expression. Hence, if substitution was --- a no-op, we know that the expression still cannot progress. -substPmExpr :: Name -> PmExpr -> PmExpr -> (PmExpr, Bool) -substPmExpr x e1 e = - case e of - PmExprVar z | x == z -> (e1, True) - | otherwise -> (e, False) - PmExprCon c ps -> let (ps', bs) = mapAndUnzip (substPmExpr x e1) ps - in (PmExprCon c ps', or bs) - PmExprEq ex ey -> let (ex', bx) = substPmExpr x e1 ex - (ey', by) = substPmExpr x e1 ey - in (PmExprEq ex' ey', bx || by) - _other_expr -> (e, False) -- The rest are terminals (We silently ignore - -- Other). See Note [PmExprOther in PmExpr] - --- | Substitute in a complex equality. We return (Left eq) if the substitution --- affected the equality or (Right eq) if nothing happened. -substComplexEq :: Name -> PmExpr -> ComplexEq -> Either ComplexEq ComplexEq -substComplexEq x e (ex, ey) - | bx || by = Left (ex', ey') - | otherwise = Right (ex', ey') - where - (ex', bx) = substPmExpr x e ex - (ey', by) = substPmExpr x e ey - --- ----------------------------------------------------------------------- --- ** Lift source expressions (HsExpr Id) to PmExpr - -lhsExprToPmExpr :: LHsExpr Id -> PmExpr -lhsExprToPmExpr (L _ e) = hsExprToPmExpr e - -hsExprToPmExpr :: HsExpr Id -> PmExpr - -hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x)) -hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c) -hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit) -hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit) - -hsExprToPmExpr e@(NegApp _ neg_e) - | PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e - = PmExprLit (PmOLit True ol) - | otherwise = PmExprOther e -hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e - -hsExprToPmExpr e@(ExplicitTuple ps boxity) - | all tupArgPresent ps = mkPmExprData tuple_con tuple_args - | otherwise = PmExprOther e - where - tuple_con = tupleDataCon boxity (length ps) - tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ] - -hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems) - | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems) - | otherwise = PmExprOther e {- overloaded list: No PmExprApp -} - where - cons x xs = mkPmExprData consDataCon [x,xs] - nil = mkPmExprData nilDataCon [] - -hsExprToPmExpr (ExplicitPArr _elem_ty elems) - = mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems) - - --- we want this but we would have to make everything monadic :/ --- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon --- --- hsExprToPmExpr (RecordCon c _ binds) = do --- con <- dsLookupDataCon (unLoc c) --- args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds) --- return (PmExprCon con args) -hsExprToPmExpr e@(RecordCon _ _ _ _) = PmExprOther e - -hsExprToPmExpr (HsTick _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsBinTick _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsTickPragma _ _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsSCC _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsCoreAnn _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (ExprWithTySig e _) = lhsExprToPmExpr e -hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e -hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e -hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle - -synExprToPmExpr :: SyntaxExpr Id -> PmExpr -synExprToPmExpr = hsExprToPmExpr . syn_expr -- ignore the wrappers - -{- -%************************************************************************ -%* * - Pretty printing -%* * -%************************************************************************ --} - -{- 1. Literals -~~~~~~~~~~~~~~ -Starting with a function definition like: - - f :: Int -> Bool - f 5 = True - f 6 = True - -The uncovered set looks like: - { var |> False == (var == 5), False == (var == 6) } - -Yet, we would like to print this nicely as follows: - x , where x not one of {5,6} - -Function `filterComplex' takes the set of residual constraints and packs -together the negative constraints that refer to the same variable so we can do -just this. Since these variables will be shown to the programmer, we also give -them better names (t1, t2, ..), hence the SDoc in PmNegLitCt. - -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 -Check.hs) to be more precice. --} - --- ----------------------------------------------------------------------------- --- ** Transform residual constraints in appropriate form for pretty printing - -type PmNegLitCt = (Name, (SDoc, [PmLit])) - -filterComplex :: [ComplexEq] -> [PmNegLitCt] -filterComplex = zipWith rename nameList . map mkGroup - . groupBy name . sortBy order . mapMaybe isNegLitCs - where - order x y = compare (fst x) (fst y) - name x y = fst x == fst y - mkGroup l = (fst (head l), nubPmLit $ map snd l) - rename new (old, lits) = (old, (new, lits)) - - isNegLitCs (e1,e2) - | isFalsePmExpr e1, Just (x,y) <- isPmExprEq e2 = isNegLitCs' x y - | isFalsePmExpr e2, Just (x,y) <- isPmExprEq e1 = isNegLitCs' x y - | otherwise = Nothing - - isNegLitCs' (PmExprVar x) (PmExprLit l) = Just (x, l) - isNegLitCs' (PmExprLit l) (PmExprVar x) = Just (x, l) - isNegLitCs' _ _ = Nothing - - -- 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)..] ] - --- ---------------------------------------------------------------------------- - -runPmPprM :: PmPprM a -> [PmNegLitCt] -> (a, [(SDoc,[PmLit])]) -runPmPprM m lit_env = (result, mapMaybe is_used lit_env) - where - (result, (_lit_env, used)) = runState m (lit_env, emptyNameSet) - - is_used (x,(name, lits)) - | elemNameSet x used = Just (name, lits) - | otherwise = Nothing - -type PmPprM a = State ([PmNegLitCt], NameSet) a --- (the first part of the state is read only. make it a reader?) - -addUsed :: Name -> PmPprM () -addUsed x = modify (\(negated, used) -> (negated, extendNameSet used x)) - -checkNegation :: Name -> PmPprM (Maybe SDoc) -- the clean name if it is negated -checkNegation x = do - negated <- gets fst - return $ case lookup x negated of - Just (new, _) -> Just new - Nothing -> Nothing - --- | Pretty print a pmexpr, but remember to prettify the names of the variables --- that refer to neg-literals. The ones that cannot be shown are printed as --- underscores. -pprPmExpr :: PmExpr -> PmPprM SDoc -pprPmExpr (PmExprVar x) = do - mb_name <- checkNegation x - case mb_name of - Just name -> addUsed x >> return name - Nothing -> return underscore - -pprPmExpr (PmExprCon con args) = pprPmExprCon con args -pprPmExpr (PmExprLit l) = return (ppr l) -pprPmExpr (PmExprEq _ _) = return underscore -- don't show -pprPmExpr (PmExprOther _) = return underscore -- don't show - -needsParens :: PmExpr -> Bool -needsParens (PmExprVar {}) = False -needsParens (PmExprLit l) = isNegatedPmLit l -needsParens (PmExprEq {}) = False -- will become a wildcard -needsParens (PmExprOther {}) = False -- will become a wildcard -needsParens (PmExprCon (RealDataCon c) es) - | isTupleDataCon c || isPArrFakeCon c - || isConsDataCon c || null es = False - | otherwise = True -needsParens (PmExprCon (PatSynCon _) es) = not (null es) - -pprPmExprWithParens :: PmExpr -> PmPprM SDoc -pprPmExprWithParens expr - | needsParens expr = parens <$> pprPmExpr expr - | otherwise = pprPmExpr expr - -pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc -pprPmExprCon (RealDataCon con) args - | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args - | isPArrFakeCon con = mkPArr <$> mapM pprPmExpr args - | isConsDataCon con = pretty_list - where - mkTuple, mkPArr :: [SDoc] -> SDoc - mkTuple = parens . fsep . punctuate comma - mkPArr = paBrackets . fsep . punctuate comma - - -- lazily, to be used in the list case only - pretty_list :: PmPprM SDoc - pretty_list = case isNilPmExpr (last list) of - True -> brackets . fsep . punctuate comma <$> mapM pprPmExpr (init list) - False -> parens . hcat . punctuate colon <$> mapM pprPmExpr list - - list = list_elements args - - list_elements [x,y] - | PmExprCon c es <- y, RealDataCon nilDataCon == c - = ASSERT(null es) [x,y] - | PmExprCon c es <- y, RealDataCon consDataCon == c - = x : list_elements es - | otherwise = [x,y] - list_elements list = pprPanic "list_elements:" (ppr list) -pprPmExprCon cl args - | conLikeIsInfix cl = case args of - [x, y] -> do x' <- pprPmExprWithParens x - y' <- pprPmExprWithParens y - return (x' <+> ppr cl <+> y') - -- can it be infix but have more than two arguments? - list -> pprPanic "pprPmExprCon:" (ppr list) - | null args = return (ppr cl) - | otherwise = do args' <- mapM pprPmExprWithParens args - return (fsep (ppr cl : args')) - -instance Outputable PmLit where - ppr (PmSLit l) = pmPprHsLit l - ppr (PmOLit neg l) = (if neg then char '-' else empty) <> ppr l - --- not really useful for pmexprs per se -instance Outputable PmExpr where - ppr e = fst $ runPmPprM (pprPmExpr e) [] diff --git a/deSugar/TmOracle.hs b/deSugar/TmOracle.hs deleted file mode 100644 --- a/deSugar/TmOracle.hs +++ /dev/null @@ -1,257 +0,0 @@ -{- -Author: George Karachalias - -The term equality oracle. The main export of the module is function `tmOracle'. --} - -{-# LANGUAGE CPP, MultiWayIf #-} - -module TmOracle ( - - -- re-exported from PmExpr - PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr, - eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, lhsExprToPmExpr, - hsExprToPmExpr, pprPmExprWithParens, - - -- the term oracle - tmOracle, TmState, initialTmState, solveOneEq, extendSubst, canDiverge, - - -- misc. - toComplex, exprDeepLookup, pmLitType, flattenPmVarEnv - ) where - -#include "HsVersions.h" - -import PmExpr - -import Id -import Name -import Type -import HsLit -import TcHsSyn -import MonadUtils -import Util - -import NameEnv - -{- -%************************************************************************ -%* * - The term equality oracle -%* * -%************************************************************************ --} - --- | The type of substitutions. -type PmVarEnv = NameEnv PmExpr - --- | The environment of the oracle contains --- 1. A Bool (are there any constraints we cannot handle? (PmExprOther)). --- 2. A substitution we extend with every step and return as a result. -type TmOracleEnv = (Bool, PmVarEnv) - --- | Check whether a constraint (x ~ BOT) can succeed, --- given the resulting state of the term oracle. -canDiverge :: Name -> TmState -> Bool -canDiverge x (standby, (_unhandled, env)) - -- If the variable seems not evaluated, there is a possibility for - -- constraint x ~ BOT to be satisfiable. - | PmExprVar y <- varDeepLookup env x -- seems not forced - -- If it is involved (directly or indirectly) in any equality in the - -- worklist, we can assume that it is already indirectly evaluated, - -- as a side-effect of equality checking. If not, then we can assume - -- that the constraint is satisfiable. - = not $ any (isForcedByEq x) standby || any (isForcedByEq y) standby - -- Variable x is already in WHNF so the constraint is non-satisfiable - | otherwise = False - - where - isForcedByEq :: Name -> ComplexEq -> Bool - isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2 - --- | Check whether a variable is in the free variables of an expression -varIn :: Name -> PmExpr -> Bool -varIn x e = case e of - PmExprVar y -> x == y - PmExprCon _ es -> any (x `varIn`) es - PmExprLit _ -> False - PmExprEq e1 e2 -> (x `varIn` e1) || (x `varIn` e2) - PmExprOther _ -> False - --- | Flatten the DAG (Could be improved in terms of performance.). -flattenPmVarEnv :: PmVarEnv -> PmVarEnv -flattenPmVarEnv env = mapNameEnv (exprDeepLookup env) env - --- | The state of the term oracle (includes complex constraints that cannot --- progress unless we get more information). -type TmState = ([ComplexEq], TmOracleEnv) - --- | Initial state of the oracle. -initialTmState :: TmState -initialTmState = ([], (False, emptyNameEnv)) - --- | Solve a complex equality (top-level). -solveOneEq :: TmState -> ComplexEq -> Maybe TmState -solveOneEq solver_env@(_,(_,env)) complex - = solveComplexEq solver_env -- do the actual *merging* with existing state - $ simplifyComplexEq -- simplify as much as you can - $ applySubstComplexEq env complex -- replace everything we already know - --- | Solve a complex equality. -solveComplexEq :: TmState -> ComplexEq -> Maybe TmState -solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of - -- We cannot do a thing about these cases - (PmExprOther _,_) -> Just (standby, (True, env)) - (_,PmExprOther _) -> Just (standby, (True, env)) - - (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of - -- See Note [Undecidable Equality for Overloaded Literals] - True -> Just solver_state - False -> Nothing - - (PmExprCon c1 ts1, PmExprCon c2 ts2) - | c1 == c2 -> foldlM solveComplexEq solver_state (zip ts1 ts2) - | otherwise -> Nothing - (PmExprCon _ [], PmExprEq t1 t2) - | isTruePmExpr e1 -> solveComplexEq solver_state (t1, t2) - | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env)) - (PmExprEq t1 t2, PmExprCon _ []) - | isTruePmExpr e2 -> solveComplexEq solver_state (t1, t2) - | isFalsePmExpr e2 -> Just (eq:standby, (unhandled, env)) - - (PmExprVar x, PmExprVar y) - | x == y -> Just solver_state - | otherwise -> extendSubstAndSolve x e2 solver_state - - (PmExprVar x, _) -> extendSubstAndSolve x e2 solver_state - (_, PmExprVar x) -> extendSubstAndSolve x e1 solver_state - - (PmExprEq _ _, PmExprEq _ _) -> Just (eq:standby, (unhandled, env)) - - _ -> Just (standby, (True, env)) -- I HATE CATCH-ALLS - --- | Extend the substitution and solve the (possibly updated) constraints. -extendSubstAndSolve :: Name -> PmExpr -> TmState -> Maybe TmState -extendSubstAndSolve x e (standby, (unhandled, env)) - = foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed) - where - -- Apply the substitution to the worklist and partition them to the ones - -- that had some progress and the rest. Then, recurse over the ones that - -- had some progress. Careful about performance: - -- See Note [Representation of Term Equalities] in deSugar/Check.hs - (changed, unchanged) = partitionWith (substComplexEq x e) standby - new_incr_state = (unchanged, (unhandled, extendNameEnv env x e)) - --- | When we know that a variable is fresh, we do not actually have to --- check whether anything changes, we know that nothing does. Hence, --- `extendSubst` simply extends the substitution, unlike what --- `extendSubstAndSolve` does. -extendSubst :: Id -> PmExpr -> TmState -> TmState -extendSubst y e (standby, (unhandled, env)) - | isNotPmExprOther simpl_e - = (standby, (unhandled, extendNameEnv env x simpl_e)) - | otherwise = (standby, (True, env)) - where - x = idName y - simpl_e = fst $ simplifyPmExpr $ exprDeepLookup env e - --- | Simplify a complex equality. -simplifyComplexEq :: ComplexEq -> ComplexEq -simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2) - --- | Simplify an expression. The boolean indicates if there has been any --- simplification or if the operation was a no-op. -simplifyPmExpr :: PmExpr -> (PmExpr, Bool) --- See Note [Deep equalities] -simplifyPmExpr e = case e of - PmExprCon c ts -> case mapAndUnzip simplifyPmExpr ts of - (ts', bs) -> (PmExprCon c ts', or bs) - PmExprEq t1 t2 -> simplifyEqExpr t1 t2 - _other_expr -> (e, False) -- the others are terminals - --- | Simplify an equality expression. The equality is given in parts. -simplifyEqExpr :: PmExpr -> PmExpr -> (PmExpr, Bool) --- See Note [Deep equalities] -simplifyEqExpr e1 e2 = case (e1, e2) of - -- Varables - (PmExprVar x, PmExprVar y) - | x == y -> (truePmExpr, True) - - -- Literals - (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of - -- See Note [Undecidable Equality for Overloaded Literals] - True -> (truePmExpr, True) - False -> (falsePmExpr, True) - - -- Can potentially be simplified - (PmExprEq {}, _) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of - ((e1', True ), (e2', _ )) -> simplifyEqExpr e1' e2' - ((e1', _ ), (e2', True )) -> simplifyEqExpr e1' e2' - ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress - (_, PmExprEq {}) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of - ((e1', True ), (e2', _ )) -> simplifyEqExpr e1' e2' - ((e1', _ ), (e2', True )) -> simplifyEqExpr e1' e2' - ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress - - -- Constructors - (PmExprCon c1 ts1, PmExprCon c2 ts2) - | c1 == c2 -> - let (ts1', bs1) = mapAndUnzip simplifyPmExpr ts1 - (ts2', bs2) = mapAndUnzip simplifyPmExpr ts2 - (tss, _bss) = zipWithAndUnzip simplifyEqExpr ts1' ts2' - worst_case = PmExprEq (PmExprCon c1 ts1') (PmExprCon c2 ts2') - in if | not (or bs1 || or bs2) -> (worst_case, False) -- no progress - | all isTruePmExpr tss -> (truePmExpr, True) - | any isFalsePmExpr tss -> (falsePmExpr, True) - | otherwise -> (worst_case, False) - | otherwise -> (falsePmExpr, True) - - -- We cannot do anything about the rest.. - _other_equality -> (original, False) - - where - original = PmExprEq e1 e2 -- reconstruct equality - --- | Apply an (un-flattened) substitution to a simple equality. -applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq -applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2) - --- | Apply an (un-flattened) substitution to a variable. -varDeepLookup :: PmVarEnv -> Name -> PmExpr -varDeepLookup env x - | Just e <- lookupNameEnv env x = exprDeepLookup env e -- go deeper - | otherwise = PmExprVar x -- terminal -{-# INLINE varDeepLookup #-} - --- | Apply an (un-flattened) substitution to an expression. -exprDeepLookup :: PmVarEnv -> PmExpr -> PmExpr -exprDeepLookup env (PmExprVar x) = varDeepLookup env x -exprDeepLookup env (PmExprCon c es) = PmExprCon c (map (exprDeepLookup env) es) -exprDeepLookup env (PmExprEq e1 e2) = PmExprEq (exprDeepLookup env e1) - (exprDeepLookup env e2) -exprDeepLookup _ other_expr = other_expr -- PmExprLit, PmExprOther - --- | External interface to the term oracle. -tmOracle :: TmState -> [ComplexEq] -> Maybe TmState -tmOracle tm_state eqs = foldlM solveOneEq tm_state eqs - --- | Type of a PmLit -pmLitType :: PmLit -> Type -- should be in PmExpr but gives cyclic imports :( -pmLitType (PmSLit lit) = hsLitType lit -pmLitType (PmOLit _ lit) = overLitType lit - -{- Note [Deep equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Solving nested equalities is the most difficult part. The general strategy -is the following: - - * Equalities of the form (True ~ (e1 ~ e2)) are transformed to just - (e1 ~ e2) and then treated recursively. - - * Equalities of the form (False ~ (e1 ~ e2)) cannot be analyzed unless - we know more about the inner equality (e1 ~ e2). That's exactly what - `simplifyEqExpr' tries to do: It takes e1 and e2 and either returns - truePmExpr, falsePmExpr or (e1' ~ e2') in case it is uncertain. Note - that it is not e but rather e', since it may perform some - simplifications deeper. --} diff --git a/dist/build/CmmLex.hs b/dist/build/CmmLex.hs deleted file mode 100644 --- a/dist/build/CmmLex.hs +++ /dev/null @@ -1,896 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} -{-# LANGUAGE CPP,MagicHash #-} -{-# LINE 13 "cmm/CmmLex.x" #-} - --- See Note [Warnings in code generated by Alex] in compiler/parser/Lexer.x -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -module CmmLex ( - CmmToken(..), cmmlex, - ) where - -import CmmExpr - -import Lexer -import CmmMonad -import SrcLoc -import UniqFM -import StringBuffer -import FastString -import Ctype -import Util ---import TRACE - -import Data.Word -import Data.Char - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#elif defined(__GLASGOW_HASKELL__) -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -import Data.Array.Base (unsafeAt) -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif -alex_tab_size :: Int -alex_tab_size = 8 -alex_base :: AlexAddr -alex_base = AlexA# - "\x01\x00\x00\x00\x7f\x00\x00\x00\x78\x00\x00\x00\xc2\x00\x00\x00\x9c\xff\xff\xff\xa5\x00\x00\x00\xc1\x00\x00\x00\xde\x00\x00\x00\xec\x00\x00\x00\xa2\xff\xff\xff\x42\x01\x00\x00\xc2\x01\x00\x00\xc1\x02\x00\x00\xa8\x02\x00\x00\x99\xff\xff\xff\x9e\xff\xff\xff\x28\x03\x00\x00\xa8\x03\x00\x00\x28\x04\x00\x00\xa8\x04\x00\x00\x28\x05\x00\x00\xa1\xff\xff\xff\xa8\x05\x00\x00\x28\x06\x00\x00\xa8\xff\xff\xff\x9d\xff\xff\xff\x00\x00\x00\x00\x99\x06\x00\x00\x00\x00\x00\x00\x0a\x07\x00\x00\x00\x00\x00\x00\x7b\x07\x00\x00\x00\x00\x00\x00\xbc\x07\x00\x00\x00\x00\x00\x00\x2d\x08\x00\x00\x00\x00\x00\x00\x9e\x08\x00\x00\x00\x00\x00\x00\xdf\x08\x00\x00\x00\x00\x00\x00\x20\x09\x00\x00\x20\x0a\x00\x00\x7e\x0a\x00\x00\x37\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x0a\x00\x00\x00\x00\x00\x00\xb9\x0a\x00\x00\xb9\x0b\x00\x00\x79\x0b\x00\x00\x00\x00\x00\x00\xa3\xff\xff\xff\x79\x0c\x00\x00\x39\x0c\x00\x00\x00\x00\x00\x00\x38\x0d\x00\x00\x0d\x0e\x00\x00\x39\x0d\x00\x00\x02\x0f\x00\x00\xcd\x0d\x00\x00\x00\x00\x00\x00\x82\x0f\x00\x00\x42\x0f\x00\x00\x00\x00\x00\x00\x38\x10\x00\x00\x2e\x11\x00\x00\x70\xff\xff\xff\xae\x11\x00\x00\x37\x0d\x00\x00\xa5\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\xff\xff\xff\x9b\x13\x00\x00\x91\x14\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x87\x15\x00\x00\x7d\x16\x00\x00\x73\x17\x00\x00\x69\x18\x00\x00\x5f\x19\x00\x00\x55\x1a\x00\x00\x4b\x1b\x00\x00\x41\x1c\x00\x00\x37\x1d\x00\x00\x2d\x1e\x00\x00\x00\x00\x00\x00\xd6\xff\xff\xff\xd7\xff\xff\xff\x00\x00\x00\x00\x9b\xff\xff\xff\xef\xff\xff\xff\xdc\xff\xff\xff\xdd\xff\xff\xff\xe2\xff\xff\xff\x2c\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x1f\x00\x00\x34\x20\x00\x00\xb8\x20\x00\x00\x3c\x21\x00\x00\xc0\x21\x00\x00\x44\x22\x00\x00\xc8\x22\x00\x00\x4c\x23\x00\x00\xd0\x23\x00\x00\x54\x24\x00\x00\xd8\x24\x00\x00\x5c\x25\x00\x00\xe0\x25\x00\x00\x64\x26\x00\x00\xe8\x26\x00\x00\x6c\x27\x00\x00\xf0\x27\x00\x00\x74\x28\x00\x00\xf8\x28\x00\x00\x7c\x29\x00\x00\x00\x2a\x00\x00\x84\x2a\x00\x00\x08\x2b\x00\x00\x8c\x2b\x00\x00\x10\x2c\x00\x00\x94\x2c\x00\x00\x18\x2d\x00\x00\x9c\x2d\x00\x00\x20\x2e\x00\x00\xa4\x2e\x00\x00\x28\x2f\x00\x00\xac\x2f\x00\x00\x30\x30\x00\x00\xb4\x30\x00\x00\x38\x31\x00\x00\xbc\x31\x00\x00\x40\x32\x00\x00\xc4\x32\x00\x00\x48\x33\x00\x00\xcc\x33\x00\x00\x50\x34\x00\x00\xd4\x34\x00\x00\x58\x35\x00\x00\xdc\x35\x00\x00\x60\x36\x00\x00\xe4\x36\x00\x00\x68\x37\x00\x00\xec\x37\x00\x00\x70\x38\x00\x00\xf4\x38\x00\x00\x78\x39\x00\x00\xfc\x39\x00\x00\x80\x3a\x00\x00\x04\x3b\x00\x00\x88\x3b\x00\x00\x0c\x3c\x00\x00\x90\x3c\x00\x00\x14\x3d\x00\x00\x98\x3d\x00\x00\x1c\x3e\x00\x00\xa0\x3e\x00\x00\x24\x3f\x00\x00\xa8\x3f\x00\x00\x2c\x40\x00\x00\xb0\x40\x00\x00\x34\x41\x00\x00\xb8\x41\x00\x00\x3c\x42\x00\x00\xc0\x42\x00\x00\x44\x43\x00\x00\xc8\x43\x00\x00\x4c\x44\x00\x00\xd0\x44\x00\x00\x54\x45\x00\x00\xd8\x45\x00\x00\x42\x10\x00\x00\x38\x11\x00\x00\x32\x46\x00\x00\x4c\x10\x00\x00\x42\x11\x00\x00\xd8\x02\x00\x00\x00\x00\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# - "\x00\x00\x49\x00\xb8\x00\x43\x00\x9f\x00\x9f\x00\x09\x00\x35\x00\x0e\x00\x15\x00\x46\x00\x59\x00\x46\x00\x46\x00\x46\x00\x18\x00\x46\x00\x04\x00\x0f\x00\x68\x00\x69\x00\x6a\x00\x19\x00\x6b\x00\x65\x00\x67\x00\x66\x00\x64\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x5b\x00\x3a\x00\x4a\x00\x9f\x00\x5c\x00\x5e\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\xb6\x00\x5c\x00\xb9\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x61\x00\x5c\x00\x5f\x00\x5a\x00\x60\x00\x00\x00\x9f\x00\x9f\x00\x9a\x00\x91\x00\x7f\x00\x9f\x00\x7e\x00\x9f\x00\xb4\x00\x9f\x00\x9f\x00\x9f\x00\x80\x00\x97\x00\x9f\x00\x9f\x00\x7c\x00\x9f\x00\x7d\x00\xb5\x00\x9f\x00\xa0\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x9f\x00\x5c\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x5c\x00\x5d\x00\x5c\x00\x5c\x00\x4d\x00\x46\x00\x00\x00\x46\x00\x46\x00\x46\x00\x00\x00\x00\x00\x46\x00\x00\x00\x46\x00\x46\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x42\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x44\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\xff\xff\x47\x00\x47\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xbb\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x4c\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x08\x00\xbc\x00\x08\x00\x00\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x36\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x32\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x0a\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2a\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x0d\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x10\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x13\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x33\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x46\x00\x46\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x3a\x00\x3a\x00\xbd\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x2b\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x44\x00\x2a\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2c\x00\x13\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x21\x00\x17\x00\x1a\x00\x1a\x00\x1a\x00\x1b\x00\x3a\x00\x3a\x00\xbd\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x2b\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x2a\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2c\x00\x13\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x21\x00\x17\x00\x1a\x00\x1a\x00\x1a\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb8\x00\xb8\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x33\x00\x10\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x27\x00\x16\x00\x1c\x00\x1c\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x37\x00\x0d\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x29\x00\x14\x00\x1e\x00\x1e\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x47\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x47\x00\xff\xff\x47\x00\x47\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x0b\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2f\x00\x12\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x40\x00\x0a\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x31\x00\x11\x00\x24\x00\x24\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x89\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\xab\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x8a\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x72\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x74\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x75\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x76\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x77\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x78\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x79\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x7b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x81\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x82\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x83\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x84\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x86\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x87\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xb3\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x88\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x8b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xa4\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xb2\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x92\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xaf\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\xae\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x94\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x95\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xa9\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xa8\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x96\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xa7\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xa5\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xa1\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9d\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9e\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xa2\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\xa3\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9c\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xa6\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x98\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xaa\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x93\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xac\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xad\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xb0\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xb1\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x90\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x8f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x8e\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x8d\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x99\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x8c\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x85\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x7a\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x73\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x71\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# - "\xff\xff\x65\x00\x01\x00\x61\x00\x03\x00\x04\x00\x6d\x00\x69\x00\x67\x00\x61\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x72\x00\xa0\x00\x6e\x00\x6c\x00\x3d\x00\x3d\x00\x26\x00\x70\x00\x7c\x00\x3c\x00\x3d\x00\x3d\x00\x3e\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xc2\x00\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2b\x00\x01\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xff\xff\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc2\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# - "\xff\xff\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x20\x00\x26\x00\x26\x00\x28\x00\x28\x00\x2d\x00\x2d\x00\x2e\x00\x2e\x00\x30\x00\x30\x00\x34\x00\x34\x00\x38\x00\x38\x00\x3a\x00\xff\xff\x3a\x00\x3a\x00\x3e\x00\x3e\x00\x41\x00\x41\x00\x42\x00\x42\x00\x42\x00\xff\xff\x43\x00\x43\x00\x43\x00\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x55\x00\x58\x00\x58\x00\x58\x00\x42\x00\x43\x00\xff\xff\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\xff\xff\xff\xff\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0 :: Int, 189) - [ AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 118 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccSkip - , AlexAccSkip - , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccPred 117 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccPred 116 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccPred 115 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 114) - , AlexAccPred 113 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 112) - , AlexAcc 111 - , AlexAcc 110 - , AlexAcc 109 - , AlexAcc 108 - , AlexAcc 107 - , AlexAcc 106 - , AlexAcc 105 - , AlexAcc 104 - , AlexAcc 103 - , AlexAcc 102 - , AlexAcc 101 - , AlexAcc 100 - , AlexAccSkip - , AlexAcc 99 - , AlexAcc 98 - , AlexAcc 97 - , AlexAcc 96 - , AlexAcc 95 - , AlexAcc 94 - , AlexAcc 93 - , AlexAcc 92 - , AlexAcc 91 - , AlexAcc 90 - , AlexAcc 89 - , AlexAcc 88 - , AlexAcc 87 - , AlexAcc 86 - , AlexAcc 85 - , AlexAcc 84 - , AlexAcc 83 - , AlexAcc 82 - , AlexAcc 81 - , AlexAcc 80 - , AlexAcc 79 - , AlexAcc 78 - , AlexAcc 77 - , AlexAcc 76 - , AlexAcc 75 - , AlexAcc 74 - , AlexAcc 73 - , AlexAcc 72 - , AlexAcc 71 - , AlexAcc 70 - , AlexAcc 69 - , AlexAcc 68 - , AlexAcc 67 - , AlexAcc 66 - , AlexAcc 65 - , AlexAcc 64 - , AlexAcc 63 - , AlexAcc 62 - , AlexAcc 61 - , AlexAcc 60 - , AlexAcc 59 - , AlexAcc 58 - , AlexAcc 57 - , AlexAcc 56 - , AlexAcc 55 - , AlexAcc 54 - , AlexAcc 53 - , AlexAcc 52 - , AlexAcc 51 - , AlexAcc 50 - , AlexAcc 49 - , AlexAcc 48 - , AlexAcc 47 - , AlexAcc 46 - , AlexAcc 45 - , AlexAcc 44 - , AlexAcc 43 - , AlexAcc 42 - , AlexAcc 41 - , AlexAcc 40 - , AlexAcc 39 - , AlexAcc 38 - , AlexAcc 37 - , AlexAcc 36 - , AlexAcc 35 - , AlexAcc 34 - , AlexAcc 33 - , AlexAcc 32 - , AlexAcc 31 - , AlexAcc 30 - , AlexAcc 29 - , AlexAcc 28 - , AlexAcc 27 - , AlexAcc 26 - , AlexAcc 25 - , AlexAcc 24 - , AlexAcc 23 - , AlexAcc 22 - , AlexAcc 21 - , AlexAcc 20 - , AlexAcc 19 - , AlexAcc 18 - , AlexAcc 17 - , AlexAcc 16 - , AlexAcc 15 - , AlexAcc 14 - , AlexAcc 13 - , AlexAcc 12 - , AlexAcc 11 - , AlexAcc 10 - , AlexAcc 9 - , AlexAcc 8 - , AlexAcc 7 - , AlexAcc 6 - , AlexAcc 5 - , AlexAcc 4 - , AlexAcc 3 - , AlexAcc 2 - , AlexAcc 1 - , AlexAcc 0 - ] - -alex_actions = array (0 :: Int, 119) - [ (118,alex_action_5) - , (117,alex_action_2) - , (116,alex_action_2) - , (115,alex_action_2) - , (114,alex_action_5) - , (113,alex_action_2) - , (112,alex_action_5) - , (111,alex_action_3) - , (110,alex_action_4) - , (109,alex_action_5) - , (108,alex_action_5) - , (107,alex_action_5) - , (106,alex_action_5) - , (105,alex_action_5) - , (104,alex_action_5) - , (103,alex_action_5) - , (102,alex_action_5) - , (101,alex_action_5) - , (100,alex_action_5) - , (99,alex_action_7) - , (98,alex_action_7) - , (97,alex_action_7) - , (96,alex_action_7) - , (95,alex_action_7) - , (94,alex_action_7) - , (93,alex_action_7) - , (92,alex_action_7) - , (91,alex_action_8) - , (90,alex_action_9) - , (89,alex_action_10) - , (88,alex_action_11) - , (87,alex_action_12) - , (86,alex_action_13) - , (85,alex_action_14) - , (84,alex_action_15) - , (83,alex_action_16) - , (82,alex_action_17) - , (81,alex_action_18) - , (80,alex_action_19) - , (79,alex_action_20) - , (78,alex_action_21) - , (77,alex_action_22) - , (76,alex_action_23) - , (75,alex_action_24) - , (74,alex_action_25) - , (73,alex_action_26) - , (72,alex_action_27) - , (71,alex_action_28) - , (70,alex_action_29) - , (69,alex_action_30) - , (68,alex_action_31) - , (67,alex_action_32) - , (66,alex_action_33) - , (65,alex_action_34) - , (64,alex_action_34) - , (63,alex_action_34) - , (62,alex_action_34) - , (61,alex_action_34) - , (60,alex_action_34) - , (59,alex_action_34) - , (58,alex_action_34) - , (57,alex_action_34) - , (56,alex_action_34) - , (55,alex_action_34) - , (54,alex_action_34) - , (53,alex_action_34) - , (52,alex_action_34) - , (51,alex_action_34) - , (50,alex_action_34) - , (49,alex_action_34) - , (48,alex_action_34) - , (47,alex_action_34) - , (46,alex_action_34) - , (45,alex_action_34) - , (44,alex_action_34) - , (43,alex_action_34) - , (42,alex_action_34) - , (41,alex_action_34) - , (40,alex_action_34) - , (39,alex_action_34) - , (38,alex_action_34) - , (37,alex_action_34) - , (36,alex_action_34) - , (35,alex_action_34) - , (34,alex_action_34) - , (33,alex_action_34) - , (32,alex_action_34) - , (31,alex_action_34) - , (30,alex_action_34) - , (29,alex_action_34) - , (28,alex_action_34) - , (27,alex_action_34) - , (26,alex_action_34) - , (25,alex_action_34) - , (24,alex_action_34) - , (23,alex_action_34) - , (22,alex_action_34) - , (21,alex_action_34) - , (20,alex_action_34) - , (19,alex_action_34) - , (18,alex_action_34) - , (17,alex_action_34) - , (16,alex_action_34) - , (15,alex_action_34) - , (14,alex_action_34) - , (13,alex_action_34) - , (12,alex_action_34) - , (11,alex_action_34) - , (10,alex_action_34) - , (9,alex_action_34) - , (8,alex_action_34) - , (7,alex_action_34) - , (6,alex_action_35) - , (5,alex_action_36) - , (4,alex_action_36) - , (3,alex_action_37) - , (2,alex_action_38) - , (1,alex_action_38) - , (0,alex_action_39) - ] - -{-# LINE 127 "cmm/CmmLex.x" #-} - -data CmmToken - = CmmT_SpecChar Char - | CmmT_DotDot - | CmmT_DoubleColon - | CmmT_Shr - | CmmT_Shl - | CmmT_Ge - | CmmT_Le - | CmmT_Eq - | CmmT_Ne - | CmmT_BoolAnd - | CmmT_BoolOr - | CmmT_CLOSURE - | CmmT_INFO_TABLE - | CmmT_INFO_TABLE_RET - | CmmT_INFO_TABLE_FUN - | CmmT_INFO_TABLE_CONSTR - | CmmT_INFO_TABLE_SELECTOR - | CmmT_else - | CmmT_export - | CmmT_section - | CmmT_goto - | CmmT_if - | CmmT_call - | CmmT_jump - | CmmT_foreign - | CmmT_never - | CmmT_prim - | CmmT_reserve - | CmmT_return - | CmmT_returns - | CmmT_import - | CmmT_switch - | CmmT_case - | CmmT_default - | CmmT_push - | CmmT_unwind - | CmmT_bits8 - | CmmT_bits16 - | CmmT_bits32 - | CmmT_bits64 - | CmmT_bits128 - | CmmT_bits256 - | CmmT_bits512 - | CmmT_float32 - | CmmT_float64 - | CmmT_gcptr - | CmmT_GlobalReg GlobalReg - | CmmT_Name FastString - | CmmT_String String - | CmmT_Int Integer - | CmmT_Float Rational - | CmmT_EOF - deriving (Show) - --- ----------------------------------------------------------------------------- --- Lexer actions - -type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken) - -begin :: Int -> Action -begin code _span _str _len = do liftP (pushLexState code); lexToken - -pop :: Action -pop _span _buf _len = liftP popLexState >> lexToken - -special_char :: Action -special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf))) - -kw :: CmmToken -> Action -kw tok span _buf _len = return (L span tok) - -global_regN :: (Int -> GlobalReg) -> Action -global_regN con span buf len - = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) - where buf' = stepOn buf - n = parseUnsignedInteger buf' (len-1) 10 octDecDigit - -global_reg :: GlobalReg -> Action -global_reg r span _buf _len = return (L span (CmmT_GlobalReg r)) - -strtoken :: (String -> CmmToken) -> Action -strtoken f span buf len = - return (L span $! (f $! lexemeToString buf len)) - -name :: Action -name span buf len = - case lookupUFM reservedWordsFM fs of - Just tok -> return (L span tok) - Nothing -> return (L span (CmmT_Name fs)) - where - fs = lexemeToFastString buf len - -reservedWordsFM = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "CLOSURE", CmmT_CLOSURE ), - ( "INFO_TABLE", CmmT_INFO_TABLE ), - ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), - ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), - ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), - ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), - ( "else", CmmT_else ), - ( "export", CmmT_export ), - ( "section", CmmT_section ), - ( "goto", CmmT_goto ), - ( "if", CmmT_if ), - ( "call", CmmT_call ), - ( "jump", CmmT_jump ), - ( "foreign", CmmT_foreign ), - ( "never", CmmT_never ), - ( "prim", CmmT_prim ), - ( "reserve", CmmT_reserve ), - ( "return", CmmT_return ), - ( "returns", CmmT_returns ), - ( "import", CmmT_import ), - ( "switch", CmmT_switch ), - ( "case", CmmT_case ), - ( "default", CmmT_default ), - ( "push", CmmT_push ), - ( "unwind", CmmT_unwind ), - ( "bits8", CmmT_bits8 ), - ( "bits16", CmmT_bits16 ), - ( "bits32", CmmT_bits32 ), - ( "bits64", CmmT_bits64 ), - ( "bits128", CmmT_bits128 ), - ( "bits256", CmmT_bits256 ), - ( "bits512", CmmT_bits512 ), - ( "float32", CmmT_float32 ), - ( "float64", CmmT_float64 ), --- New forms - ( "b8", CmmT_bits8 ), - ( "b16", CmmT_bits16 ), - ( "b32", CmmT_bits32 ), - ( "b64", CmmT_bits64 ), - ( "b128", CmmT_bits128 ), - ( "b256", CmmT_bits256 ), - ( "b512", CmmT_bits512 ), - ( "f32", CmmT_float32 ), - ( "f64", CmmT_float64 ), - ( "gcptr", CmmT_gcptr ) - ] - -tok_decimal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit)) - -tok_octal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit)) - -tok_hexadecimal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit)) - -tok_float str = CmmT_Float $! readRational str - -tok_string str = CmmT_String (read str) - -- urk, not quite right, but it'll do for now - --- ----------------------------------------------------------------------------- --- Line pragmas - -setLine :: Int -> Action -setLine code span buf len = do - let line = parseUnsignedInteger buf len 10 octDecDigit - liftP $ do - setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line - -- trace ("setLine " ++ show line) $ do - popLexState >> pushLexState code - lexToken - -setFile :: Int -> Action -setFile code span buf len = do - let file = lexemeToFastString (stepOn buf) (len-2) - liftP $ do - setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) - popLexState >> pushLexState code - lexToken - --- ----------------------------------------------------------------------------- --- This is the top-level function: called from the parser each time a --- new token is to be read from the input. - -cmmlex :: (Located CmmToken -> PD a) -> PD a -cmmlex cont = do - (L span tok) <- lexToken - --trace ("token: " ++ show tok) $ do - cont (L (RealSrcSpan span) tok) - -lexToken :: PD (RealLocated CmmToken) -lexToken = do - inp@(loc1,buf) <- getInput - sc <- liftP getLexState - case alexScan inp sc of - AlexEOF -> do let span = mkRealSrcSpan loc1 loc1 - liftP (setLastToken span 0) - return (L span CmmT_EOF) - AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error" - AlexSkip inp2 _ -> do - setInput inp2 - lexToken - AlexToken inp2@(end,_buf2) len t -> do - setInput inp2 - let span = mkRealSrcSpan loc1 end - span `seq` liftP (setLastToken span len) - t span buf len - --- ----------------------------------------------------------------------------- --- Monad stuff - --- Stuff that Alex needs to know about our input type: -type AlexInput = (RealSrcLoc,StringBuffer) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (_,s) = prevChar s '\n' - --- backwards compatibility for Alex 2.x -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar inp = case alexGetByte inp of - Nothing -> Nothing - Just (b,i) -> c `seq` Just (c,i) - where c = chr $ fromIntegral b - -alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) -alexGetByte (loc,s) - | atEnd s = Nothing - | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s')) - where c = currentChar s - b = fromIntegral $ ord $ c - loc' = advanceSrcLoc loc c - s' = stepOn s - -getInput :: PD AlexInput -getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b) - -setInput :: AlexInput -> PD () -setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } () - - -line_prag,line_prag1,line_prag2 :: Int -line_prag = 1 -line_prag1 = 2 -line_prag2 = 3 -alex_action_2 = begin line_prag -alex_action_3 = setLine line_prag1 -alex_action_4 = setFile line_prag2 -alex_action_5 = pop -alex_action_7 = special_char -alex_action_8 = kw CmmT_DotDot -alex_action_9 = kw CmmT_DoubleColon -alex_action_10 = kw CmmT_Shr -alex_action_11 = kw CmmT_Shl -alex_action_12 = kw CmmT_Ge -alex_action_13 = kw CmmT_Le -alex_action_14 = kw CmmT_Eq -alex_action_15 = kw CmmT_Ne -alex_action_16 = kw CmmT_BoolAnd -alex_action_17 = kw CmmT_BoolOr -alex_action_18 = global_regN (\n -> VanillaReg n VGcPtr) -alex_action_19 = global_regN (\n -> VanillaReg n VNonGcPtr) -alex_action_20 = global_regN FloatReg -alex_action_21 = global_regN DoubleReg -alex_action_22 = global_regN LongReg -alex_action_23 = global_reg Sp -alex_action_24 = global_reg SpLim -alex_action_25 = global_reg Hp -alex_action_26 = global_reg HpLim -alex_action_27 = global_reg CCCS -alex_action_28 = global_reg CurrentTSO -alex_action_29 = global_reg CurrentNursery -alex_action_30 = global_reg HpAlloc -alex_action_31 = global_reg BaseReg -alex_action_32 = global_reg MachSp -alex_action_33 = global_reg UnwindReturnReg -alex_action_34 = name -alex_action_35 = tok_octal -alex_action_36 = tok_decimal -alex_action_37 = tok_hexadecimal -alex_action_38 = strtoken tok_float -alex_action_39 = strtoken tok_string -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - - - - - - - - - - - - - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define GTE(n,m) (tagToEnum# (n >=# m)) -#define EQ(n,m) (tagToEnum# (n ==# m)) -#else -#define GTE(n,m) (n >=# m) -#define EQ(n,m) (n ==# m) -#endif - - - - - - - - - - - - - - - - - - - -data AlexAddr = AlexA# Addr# --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else - indexInt16OffAddr# arr off -#endif - - - - - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else - indexInt32OffAddr# arr off -#endif - - - - - - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - - - - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input__ (I# (sc)) - = alexScanUser undefined input__ (I# (sc)) - -alexScanUser user__ input__ (I# (sc)) - = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of - (AlexNone, input__') -> - case alexGetByte input__ of - Nothing -> - - - - AlexEOF - Just _ -> - - - - AlexError input__' - - (AlexLastSkip input__'' len, _) -> - - - - AlexSkip input__'' len - - (AlexLastAcc k input__''' len, _) -> - - - - AlexToken input__''' len (alex_actions ! k) - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user__ orig_input len input__ s last_acc = - input__ `seq` -- strict in the input - let - new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) - in - new_acc `seq` - case alexGetByte input__ of - Nothing -> (new_acc, input__) - Just (c, new_input) -> - - - - case fromIntegral c of { (I# (ord_c)) -> - let - base = alexIndexInt32OffAddr alex_base s - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if GTE(offset,0#) && EQ(check,ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - -1# -> (new_acc, input__) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) - -- note that the length is increased ONLY if this is the 1st byte in a char encoding) - new_input new_s new_acc - } - where - check_accs (AlexAccNone) = last_acc - check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) - check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) - - check_accs (AlexAccPred a predx rest) - | predx user__ orig_input (I# (len)) input__ - = AlexLastAcc a input__ (I# (len)) - | otherwise - = check_accs rest - check_accs (AlexAccSkipPred predx rest) - | predx user__ orig_input (I# (len)) input__ - = AlexLastSkip input__ (I# (len)) - | otherwise - = check_accs rest - - -data AlexLastAcc - = AlexNone - | AlexLastAcc !Int !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc user - = AlexAccNone - | AlexAcc Int - | AlexAccSkip - - | AlexAccPred Int (AlexAccPred user) (AlexAcc user) - | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user__ in1 len in2 - = p1 user__ in1 len in2 && p2 user__ in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ - -alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext (I# (sc)) user__ _ _ input__ = - case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. - diff --git a/dist/build/CmmParse.hs b/dist/build/CmmParse.hs deleted file mode 100644 --- a/dist/build/CmmParse.hs +++ /dev/null @@ -1,3500 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS -XMagicHash -XBangPatterns -XTypeSynonymInstances -XFlexibleInstances -cpp #-} -#if __GLASGOW_HASKELL__ >= 710 -{-# OPTIONS_GHC -XPartialTypeSignatures #-} -#endif -module CmmParse ( parseCmmFile ) where - -import StgCmmExtCode -import CmmCallConv -import StgCmmProf -import StgCmmHeap -import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore - , emitAssign, emitOutOfLine, withUpdFrameOff - , getUpdFrameOff ) -import qualified StgCmmMonad as F -import StgCmmUtils -import StgCmmForeign -import StgCmmExpr -import StgCmmClosure -import StgCmmLayout hiding (ArgRep(..)) -import StgCmmTicky -import StgCmmBind ( emitBlackHoleCode, emitUpdateFrame ) -import CoreSyn ( Tickish(SourceNote) ) - -import CmmOpt -import MkGraph -import Cmm -import CmmUtils -import CmmSwitch ( mkSwitchTargets ) -import CmmInfo -import BlockId -import CmmLex -import CLabel -import SMRep -import Lexer -import CmmMonad - -import CostCentre -import ForeignCall -import Module -import Platform -import Literal -import Unique -import UniqFM -import SrcLoc -import DynFlags -import ErrUtils -import StringBuffer -import FastString -import Panic -import Constants -import Outputable -import BasicTypes -import Bag ( emptyBag, unitBag ) -import Var - -import Control.Monad -import Data.Array -import Data.Char ( ord ) -import System.Exit -import Data.Maybe -import qualified Data.Map as M - -#include "HsVersions.h" -import qualified Data.Array as Happy_Data_Array -import qualified Data.Bits as Bits -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.9 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn4 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> (CmmParse ()) -happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> (CmmParse ()) -happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> (CmmParse ()) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (CmmParse CLabel) -> (HappyAbsSyn ) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (CmmParse CLabel) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: ([CmmParse [CmmStatic]]) -> (HappyAbsSyn ) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> ([CmmParse [CmmStatic]]) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (CmmParse [CmmStatic]) -> (HappyAbsSyn ) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (CmmParse [CmmStatic]) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> ([CmmParse CmmExpr]) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (CmmParse ()) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (Convention) -> (HappyAbsSyn ) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (Convention) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> (CmmParse ()) -happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) -> (HappyAbsSyn ) -happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) -happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> (CmmParse ()) -happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (CmmParse ()) -happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: ([(FastString, CLabel)]) -> (HappyAbsSyn ) -happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> ([(FastString, CLabel)]) -happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: ((FastString, CLabel)) -> (HappyAbsSyn ) -happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> ((FastString, CLabel)) -happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: ([FastString]) -> (HappyAbsSyn ) -happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> ([FastString]) -happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> (CmmParse ()) -happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: (CmmParse [(GlobalReg, Maybe CmmExpr)]) -> (HappyAbsSyn ) -happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> (CmmParse [(GlobalReg, Maybe CmmExpr)]) -happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (CmmParse (Maybe CmmExpr)) -> (HappyAbsSyn ) -happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> (CmmParse (Maybe CmmExpr)) -happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyIn23 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) -happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> (CmmParse CmmExpr) -happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut23 #-} -happyIn24 :: (CmmReturnInfo) -> (HappyAbsSyn ) -happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> (CmmReturnInfo) -happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut24 #-} -happyIn25 :: (CmmParse BoolExpr) -> (HappyAbsSyn ) -happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> (CmmParse BoolExpr) -happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut25 #-} -happyIn26 :: (CmmParse BoolExpr) -> (HappyAbsSyn ) -happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> (CmmParse BoolExpr) -happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut26 #-} -happyIn27 :: (Safety) -> (HappyAbsSyn ) -happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> (Safety) -happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut27 #-} -happyIn28 :: ([GlobalReg]) -> (HappyAbsSyn ) -happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> ([GlobalReg]) -happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut28 #-} -happyIn29 :: ([GlobalReg]) -> (HappyAbsSyn ) -happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> ([GlobalReg]) -happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut29 #-} -happyIn30 :: (Maybe (Integer,Integer)) -> (HappyAbsSyn ) -happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> (Maybe (Integer,Integer)) -happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut30 #-} -happyIn31 :: ([CmmParse ([Integer],Either BlockId (CmmParse ()))]) -> (HappyAbsSyn ) -happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> ([CmmParse ([Integer],Either BlockId (CmmParse ()))]) -happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut31 #-} -happyIn32 :: (CmmParse ([Integer],Either BlockId (CmmParse ()))) -> (HappyAbsSyn ) -happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn ) -> (CmmParse ([Integer],Either BlockId (CmmParse ()))) -happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut32 #-} -happyIn33 :: (CmmParse (Either BlockId (CmmParse ()))) -> (HappyAbsSyn ) -happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn ) -> (CmmParse (Either BlockId (CmmParse ()))) -happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut33 #-} -happyIn34 :: ([Integer]) -> (HappyAbsSyn ) -happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> ([Integer]) -happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut34 #-} -happyIn35 :: (Maybe (CmmParse ())) -> (HappyAbsSyn ) -happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn ) -> (Maybe (CmmParse ())) -happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut35 #-} -happyIn36 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> (CmmParse ()) -happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut36 #-} -happyIn37 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) -happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> (CmmParse CmmExpr) -happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut37 #-} -happyIn38 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) -happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn ) -> (CmmParse CmmExpr) -happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut38 #-} -happyIn39 :: (CmmType) -> (HappyAbsSyn ) -happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn ) -> (CmmType) -happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut39 #-} -happyIn40 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn ) -happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn ) -> ([CmmParse (CmmExpr, ForeignHint)]) -happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut40 #-} -happyIn41 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn ) -happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn ) -> ([CmmParse (CmmExpr, ForeignHint)]) -happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut41 #-} -happyIn42 :: (CmmParse (CmmExpr, ForeignHint)) -> (HappyAbsSyn ) -happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn ) -> (CmmParse (CmmExpr, ForeignHint)) -happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut42 #-} -happyIn43 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) -happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn ) -> ([CmmParse CmmExpr]) -happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut43 #-} -happyIn44 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) -happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn ) -> ([CmmParse CmmExpr]) -happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut44 #-} -happyIn45 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) -happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn ) -> (CmmParse CmmExpr) -happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut45 #-} -happyIn46 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn ) -happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn ) -> ([CmmParse (LocalReg, ForeignHint)]) -happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut46 #-} -happyIn47 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn ) -happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn ) -> ([CmmParse (LocalReg, ForeignHint)]) -happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut47 #-} -happyIn48 :: (CmmParse (LocalReg, ForeignHint)) -> (HappyAbsSyn ) -happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn ) -> (CmmParse (LocalReg, ForeignHint)) -happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut48 #-} -happyIn49 :: (CmmParse LocalReg) -> (HappyAbsSyn ) -happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn ) -> (CmmParse LocalReg) -happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut49 #-} -happyIn50 :: (CmmParse CmmReg) -> (HappyAbsSyn ) -happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn ) -> (CmmParse CmmReg) -happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut50 #-} -happyIn51 :: (Maybe [CmmParse LocalReg]) -> (HappyAbsSyn ) -happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn ) -> (Maybe [CmmParse LocalReg]) -happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut51 #-} -happyIn52 :: ([CmmParse LocalReg]) -> (HappyAbsSyn ) -happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn ) -> ([CmmParse LocalReg]) -happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut52 #-} -happyIn53 :: ([CmmParse LocalReg]) -> (HappyAbsSyn ) -happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn53 #-} -happyOut53 :: (HappyAbsSyn ) -> ([CmmParse LocalReg]) -happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut53 #-} -happyIn54 :: (CmmParse LocalReg) -> (HappyAbsSyn ) -happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn54 #-} -happyOut54 :: (HappyAbsSyn ) -> (CmmParse LocalReg) -happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut54 #-} -happyIn55 :: (CmmType) -> (HappyAbsSyn ) -happyIn55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn55 #-} -happyOut55 :: (HappyAbsSyn ) -> (CmmType) -happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut55 #-} -happyIn56 :: (CmmType) -> (HappyAbsSyn ) -happyIn56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn56 #-} -happyOut56 :: (HappyAbsSyn ) -> (CmmType) -happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut56 #-} -happyInTok :: (Located CmmToken) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> (Located CmmToken) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyExpList :: HappyAddr -happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x03\x10\xfc\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xdf\x00\x04\xff\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\xf0\x3f\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x3d\x36\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x04\x00\x00\x00\xd0\x63\xf3\xff\x03\x00\x00\x00\x00\x00\x00\x80\x10\x00\x00\x00\x40\x8f\xcd\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x04\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\xff\x03\x00\x00\x00\x00\x00\x00\x00\x42\x64\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x80\x00\xfe\x87\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x1f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xe1\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\xff\xe1\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x60\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x04\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x10\x19\x10\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x02\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\xff\xe1\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x80\x10\x00\x00\x00\x40\x8f\xcd\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x40\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x3f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x40\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\xff\xe1\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xfe\x87\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x07\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x7f\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x81\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x7f\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x81\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x03\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x07\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x0f\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\xfe\x87\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x7f\xf8\x01\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x3d\x36\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x10\x00\x00\x00\x40\x8f\xcd\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x04\x00\x00\x00\xd0\x63\xf3\xff\x03\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -{-# NOINLINE happyExpListPerState #-} -happyExpListPerState st = - token_strs_expected - where token_strs = ["error","%dummy","%start_cmmParse","cmm","cmmtop","cmmdata","data_label","statics","static","lits","cmmproc","maybe_conv","maybe_body","info","body","decl","importNames","importName","names","stmt","unwind_regs","expr_or_unknown","foreignLabel","opt_never_returns","bool_expr","bool_op","safety","vols","globals","maybe_range","arms","arm","arm_body","ints","default","else","expr","expr0","maybe_ty","cmm_hint_exprs0","cmm_hint_exprs","cmm_hint_expr","exprs0","exprs","reg","foreign_results","foreign_formals","foreign_formal","local_lreg","lreg","maybe_formals","formals0","formals","formal","type","typenot8","':'","';'","'{'","'}'","'['","']'","'('","')'","'='","'`'","'~'","'/'","'*'","'%'","'-'","'+'","'&'","'^'","'|'","'>'","'<'","','","'!'","'..'","'::'","'>>'","'<<'","'>='","'<='","'=='","'!='","'&&'","'||'","'CLOSURE'","'INFO_TABLE'","'INFO_TABLE_RET'","'INFO_TABLE_FUN'","'INFO_TABLE_CONSTR'","'INFO_TABLE_SELECTOR'","'else'","'export'","'section'","'goto'","'if'","'call'","'jump'","'foreign'","'never'","'prim'","'reserve'","'return'","'returns'","'import'","'switch'","'case'","'default'","'push'","'unwind'","'bits8'","'bits16'","'bits32'","'bits64'","'bits128'","'bits256'","'bits512'","'float32'","'float64'","'gcptr'","GLOBALREG","NAME","STRING","INT","FLOAT","%eof"] - bit_start = st * 130 - bit_end = (st + 1) * 130 - read_bit = readArrayBit happyExpList - bits = map read_bit [bit_start..bit_end - 1] - bits_indexed = zip bits [0..129] - token_strs_expected = concatMap f bits_indexed - f (False, _) = [] - f (True, nr) = [token_strs !! nr] - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x45\x01\x00\x00\xb8\xff\x45\x01\x00\x00\x00\x00\xe1\xff\x00\x00\xd2\xff\x00\x00\x1c\x00\x65\x00\x6b\x00\x72\x00\x74\x00\x92\x00\x7e\x00\x7f\x00\xe7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\xe5\x00\xb8\x00\x00\x00\xc0\x00\x08\x01\x14\x01\x02\x01\xd8\x00\xda\x00\xe8\x00\xf0\x00\xf6\x00\xfb\x00\x41\x01\x2d\x01\x00\x00\x00\x00\x19\x00\x14\x04\x00\x00\x38\x01\x3c\x01\x40\x01\x42\x01\x43\x01\x47\x01\x18\x01\x00\x00\x19\x01\x00\x00\x00\x00\xe7\xff\x00\x00\x00\x00\x09\x01\x62\x01\x00\x00\x1c\x01\x25\x01\x2f\x01\x30\x01\x31\x01\x35\x01\x74\x01\x00\x00\x67\x01\x44\x01\x00\x00\x00\x00\x20\x00\x90\x01\x20\x00\x20\x00\xd6\xff\x8c\x01\x23\x00\x00\x00\x07\x04\x50\x01\x60\x00\x6f\x00\x6f\x00\x6f\x00\x9a\x01\x92\x01\x9c\x01\x60\x01\x00\x00\x16\x00\x00\x00\x14\x04\x00\x00\x91\x01\x93\x01\x03\x00\xa7\x01\xa8\x01\xa9\x01\x00\x00\xcd\x01\x09\x01\xff\xff\xdf\x01\xcb\x01\xe1\x01\x02\x00\x8d\x01\x9f\x01\xa6\x01\xef\x01\x00\x00\xf3\x01\x00\x00\x6f\x00\x6f\x00\xb4\x01\x6f\x00\x00\x00\x00\x00\x00\x00\xea\x01\xea\x01\x00\x00\x00\x00\xb3\x01\xbd\x01\xbe\x01\x00\x00\x14\x04\xbf\x01\x00\x02\x6f\x00\x00\x00\x00\x00\x6f\x00\x11\x02\x0b\x02\x6f\x00\x6f\x00\xe5\x01\x6f\x00\x92\x02\xfd\x01\x4a\x02\x09\x00\x00\x00\xce\x02\x60\x00\x60\x00\x13\x02\x0e\x02\x18\x02\x00\x00\x27\x02\x00\x00\x01\x02\x6f\x00\x6f\x00\xe9\x01\x3a\x02\x00\x00\x00\x00\x00\x00\x03\x02\x04\x02\xba\x01\x17\x02\x00\x00\x49\x02\x7b\x00\x4b\x02\x00\x00\x00\x00\xc2\x00\x4d\x02\x7b\x02\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x20\x00\x60\x00\x60\x00\x0d\x02\x6f\x00\x5e\x02\x25\x00\x6f\x00\xac\x00\xa6\x02\x59\x02\x00\x00\x53\x02\xe2\x01\x5a\x02\x49\x00\x00\x00\x5b\x02\xba\x02\x6a\x02\x57\x02\x66\x02\x64\x02\x65\x02\x6e\x02\x00\x00\x14\x04\x00\x00\x29\x00\x72\x02\x00\x00\x7b\x02\x6f\x00\x36\x02\x00\x00\x7f\x02\x70\x02\x4c\x02\x8b\x02\x90\x02\x9a\x02\x8c\x02\x9b\x02\x9e\x02\x31\x02\x00\x00\x6f\x00\x00\x00\x62\x02\x75\x02\x76\x02\x00\x00\x77\x02\x00\x00\x00\x00\xa8\x02\x95\x02\xce\x02\x00\x00\xfd\x00\x9c\x02\x89\x02\xd0\x02\x6f\x00\xfd\x00\x00\x00\xdc\x02\xdf\x02\x00\x00\xe0\x02\xd1\x02\x00\x00\xf0\x02\x00\x00\xd3\x00\xd9\x02\xf6\x02\xe2\x02\xe2\x02\xe2\x02\xe2\x02\x88\x00\x88\x00\xe2\x02\xe2\x02\x64\x01\x20\x04\x26\x04\x29\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x02\xf2\x02\x00\x00\x00\x03\x00\x00\x07\x03\x6f\x00\x6f\x00\x6f\x00\x6f\x00\xe7\x02\x0e\x03\xcc\x02\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x0c\x03\xdb\x02\xee\x02\xd3\x02\x00\x00\xe3\x02\x00\x00\x08\x03\x10\x03\x11\x03\x13\x03\x22\x03\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x02\xe5\x02\xeb\x02\xf5\x02\x00\x00\x34\x03\x27\x03\x00\x00\x3a\x03\x3e\x03\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x46\x03\x63\x02\xce\x01\xca\x00\x38\x03\x00\x00\x2b\x03\x3c\x03\x4a\x03\x6f\x00\x0d\x03\x00\x00\x00\x00\x6f\x00\x20\x00\x4b\x03\x52\x03\x00\x00\x21\x03\x01\x00\x40\x03\x42\x03\x45\x03\x4f\x03\x00\x00\x24\x03\x25\x03\x32\x03\x00\x00\x20\x00\x53\x03\x00\x00\x20\x00\x6b\x03\x7a\x03\x7b\x03\x55\x03\x00\x00\x00\x00\x00\x00\x84\x03\x54\x03\x85\x03\x00\x00\x00\x00\x87\x03\x99\x03\x9b\x03\x95\x03\x8a\x03\x9d\x03\x5a\x03\x6d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x03\xb1\x03\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\xb9\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\xb2\x03\x00\x00\xac\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x03\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x03\x00\x00\x00\x00\xc8\x03\xee\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x03\x00\x00\xd1\x03\x00\x00\x00\x00\x0f\x01\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\xf1\x00\xf9\x00\x00\x00\x00\x00\xc6\x03\x00\x00\x2e\x04\x00\x00\xe1\x00\xfd\xff\x41\x03\x4d\x03\x00\x00\xcd\x03\x00\x00\xd8\x03\x00\x00\x00\x00\x00\x00\x8b\x00\x00\x00\xe5\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x56\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x03\x5b\x03\x00\x00\x6f\x03\x00\x00\x00\x00\x00\x00\xca\x03\xcb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x02\x00\x00\x00\x00\x71\x03\x00\x00\x00\x00\xe1\x02\x00\x00\x00\x00\xe4\x02\x73\x03\x00\x00\xf8\x02\x00\x00\xe9\x03\x00\x00\x00\x00\x00\x00\x00\x00\x77\x01\x79\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x03\x75\x03\x89\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x03\x8d\x03\x8f\x03\xa3\x03\xa5\x03\xa7\x03\xa9\x03\xbd\x03\xbf\x03\xc1\x03\xc3\x03\xd7\x03\xd9\x03\xdb\x03\xdd\x03\xf1\x03\xfc\x00\x7b\x01\x7d\x01\x00\x00\xfb\x02\x00\x00\xec\x03\x0f\x03\xda\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xff\x00\x00\x00\x00\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x03\x00\x00\x00\x00\x00\x00\x03\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x04\x1d\x01\x00\x00\x00\x00\x3f\x03\x16\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x03\x4f\x00\xf5\x03\xf7\x03\xfd\x03\x00\x00\x08\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x24\x01\x19\x04\x00\x00\x11\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x21\x04\x00\x00\x00\x00\x3d\x03\x07\x01\x00\x00\x00\x00\x00\x00\x1b\x04\x1f\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x01\x00\x00\x00\x00\x32\x01\x00\x00\x00\x00\x00\x00\x29\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int# -happyAdjustOffset off = off - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfb\xff\xfc\xff\xeb\xff\xfa\xff\x00\x00\x62\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xff\x61\xff\x60\xff\x5f\xff\x5e\xff\x5d\xff\x5c\xff\x5b\xff\x5a\xff\x59\xff\xe7\xff\x00\x00\xda\xff\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\xd5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\xff\xea\xff\xfd\xff\x00\x00\x69\xff\xdd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xff\x00\x00\xd6\xff\xd7\xff\x00\x00\xdc\xff\xd9\xff\xf6\xff\x00\x00\xd4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\xff\x66\xff\x00\x00\xec\xff\xe9\xff\xe0\xff\x00\x00\xe0\xff\xe0\xff\x00\x00\x00\x00\x00\x00\xd3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\xff\x00\x00\x00\x00\x6c\xff\x6d\xff\x64\xff\x67\xff\x6a\xff\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\xf6\xff\x00\x00\x62\xff\x00\x00\x63\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8b\xff\x87\xff\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x76\xff\x77\xff\x88\xff\x83\xff\x83\xff\xf5\xff\xf8\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x69\xff\x00\x00\x00\x00\x00\x00\x65\xff\xd2\xff\x7b\xff\x00\x00\x00\x00\x7b\xff\x00\x00\x00\x00\x7b\xff\x00\x00\x00\x00\x00\x00\x00\x00\xb8\xff\xb7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x73\xff\x70\xff\x00\x00\x6e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xff\xdf\xff\xe8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xff\x00\x00\x72\xff\x00\x00\xcb\xff\xb4\xff\x00\x00\xb8\xff\xb7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\x00\x00\x00\x00\x00\x00\x7b\xff\x00\x00\x00\x00\x7b\xff\x00\x00\x79\xff\x00\x00\x7a\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\xff\x00\x00\x8a\xff\x8d\xff\x00\x00\x8e\xff\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\xff\x7b\xff\x82\xff\x00\x00\x00\x00\x00\x00\xe1\xff\x00\x00\xf9\xff\xed\xff\x00\x00\xbe\xff\xbc\xff\xbd\xff\x00\x00\xa9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6d\xff\x00\x00\x00\x00\xb0\xff\x00\x00\xad\xff\xc9\xff\x00\x00\xc4\xff\xb5\xff\xb6\xff\x00\x00\x90\xff\x8f\xff\x92\xff\x94\xff\x98\xff\x99\xff\x91\xff\x93\xff\x95\xff\x96\xff\x97\xff\x9a\xff\x9b\xff\x9c\xff\x9d\xff\x9e\xff\xb3\xff\x74\xff\x71\xff\x00\x00\x00\x00\xd1\xff\x00\x00\xbb\xff\x00\x00\x7b\xff\x81\xff\x00\x00\x00\x00\xa0\xff\x00\x00\x00\x00\xaf\xff\xae\xff\x00\x00\xc1\xff\x78\xff\xca\xff\x00\x00\xa1\xff\xa9\xff\x00\x00\xc2\xff\x00\x00\xcd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\xff\x00\x00\xf0\xff\xef\xff\xf2\xff\xf1\xff\x8c\xff\x85\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xff\x00\x00\xa4\xff\xa8\xff\x00\x00\x00\x00\xab\xff\xc8\xff\x7b\xff\xac\xff\xc6\xff\xc3\xff\x00\x00\x00\x00\x00\x00\x7d\xff\x00\x00\x80\xff\x7f\xff\x00\x00\x00\x00\x00\x00\xb2\xff\x7c\xff\xd0\xff\x7b\xff\xe0\xff\x00\x00\x00\x00\xcc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xa7\xff\xe0\xff\x00\x00\xa3\xff\xe0\xff\x00\x00\x00\x00\x00\x00\xba\xff\xb1\xff\x7e\xff\xce\xff\x00\x00\x00\x00\x00\x00\x9f\xff\xc7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xa6\xff\xa5\xff\xa2\xff\xc5\xff\xb9\xff\xcf\xff\x00\x00\x00\x00\xe4\xff\xe5\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x4a\x00\x12\x00\x03\x00\x2f\x00\x07\x00\x31\x00\x06\x00\x22\x00\x0b\x00\x08\x00\x03\x00\x0e\x00\x0f\x00\x22\x00\x0b\x00\x0c\x00\x21\x00\x22\x00\x33\x00\x10\x00\x29\x00\x01\x00\x46\x00\x16\x00\x29\x00\x02\x00\x03\x00\x07\x00\x21\x00\x22\x00\x33\x00\x34\x00\x02\x00\x07\x00\x33\x00\x34\x00\x29\x00\x07\x00\x05\x00\x20\x00\x21\x00\x06\x00\x2b\x00\x46\x00\x47\x00\x2a\x00\x33\x00\x34\x00\x0d\x00\x2e\x00\x2b\x00\x0c\x00\x0d\x00\x0e\x00\x33\x00\x34\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x29\x00\x48\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x07\x00\x31\x00\x32\x00\x33\x00\x0b\x00\x35\x00\x36\x00\x0e\x00\x0f\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x07\x00\x02\x00\x46\x00\x45\x00\x0b\x00\x07\x00\x07\x00\x0e\x00\x0f\x00\x21\x00\x22\x00\x07\x00\x24\x00\x25\x00\x26\x00\x07\x00\x17\x00\x29\x00\x07\x00\x0b\x00\x07\x00\x33\x00\x0e\x00\x0f\x00\x2b\x00\x2c\x00\x2d\x00\x33\x00\x34\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x07\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x07\x00\x0e\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x00\x00\x01\x00\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x07\x00\x46\x00\x47\x00\x0a\x00\x46\x00\x0c\x00\x47\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x20\x00\x21\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x04\x00\x05\x00\x33\x00\x34\x00\x00\x00\x01\x00\x02\x00\x45\x00\x46\x00\x20\x00\x21\x00\x07\x00\x15\x00\x16\x00\x0a\x00\x02\x00\x0c\x00\x16\x00\x0b\x00\x0c\x00\x46\x00\x02\x00\x03\x00\x10\x00\x21\x00\x22\x00\x0b\x00\x0c\x00\x46\x00\x0b\x00\x0c\x00\x10\x00\x29\x00\x03\x00\x10\x00\x0d\x00\x0e\x00\x33\x00\x34\x00\x47\x00\x0b\x00\x0c\x00\x33\x00\x34\x00\x02\x00\x10\x00\x16\x00\x33\x00\x34\x00\x2a\x00\x0d\x00\x0e\x00\x46\x00\x2e\x00\x46\x00\x33\x00\x34\x00\x2a\x00\x33\x00\x34\x00\x2a\x00\x2e\x00\x33\x00\x34\x00\x2e\x00\x22\x00\x33\x00\x34\x00\x46\x00\x33\x00\x34\x00\x2a\x00\x0b\x00\x0c\x00\x07\x00\x2e\x00\x46\x00\x10\x00\x1b\x00\x1c\x00\x33\x00\x34\x00\x46\x00\x0b\x00\x0c\x00\x1b\x00\x1c\x00\x46\x00\x10\x00\x02\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x16\x00\x21\x00\x22\x00\x2a\x00\x16\x00\x25\x00\x26\x00\x2e\x00\x16\x00\x29\x00\x16\x00\x16\x00\x33\x00\x34\x00\x2a\x00\x16\x00\x46\x00\x46\x00\x2e\x00\x33\x00\x34\x00\x01\x00\x48\x00\x33\x00\x34\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x48\x00\x29\x00\x2a\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x48\x00\x48\x00\x48\x00\x35\x00\x46\x00\x08\x00\x16\x00\x1a\x00\x1b\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x46\x00\x46\x00\x15\x00\x16\x00\x15\x00\x16\x00\x15\x00\x16\x00\x15\x00\x16\x00\x04\x00\x09\x00\x46\x00\x05\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x29\x00\x07\x00\x29\x00\x07\x00\x29\x00\x45\x00\x29\x00\x16\x00\x02\x00\x16\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x16\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x04\x00\x07\x00\x46\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x05\x00\x03\x00\x05\x00\x48\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x05\x00\x0a\x00\x46\x00\x48\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x05\x00\x19\x00\x07\x00\x48\x00\x48\x00\x48\x00\x08\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x09\x00\x02\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x48\x00\x16\x00\x08\x00\x47\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x46\x00\x0e\x00\x46\x00\x46\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x09\x00\x46\x00\x09\x00\x08\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x08\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x18\x00\x02\x00\x16\x00\x08\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x07\x00\x16\x00\x16\x00\x46\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x16\x00\x06\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x06\x00\x02\x00\x47\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x09\x00\x02\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x0a\x00\x47\x00\x02\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x48\x00\x48\x00\x48\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x48\x00\x02\x00\x37\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x06\x00\x06\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x20\x00\x04\x00\x09\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x21\x00\x22\x00\x2d\x00\x21\x00\x22\x00\x07\x00\x27\x00\x28\x00\x29\x00\x27\x00\x28\x00\x29\x00\x07\x00\x28\x00\x02\x00\x45\x00\x06\x00\x38\x00\x33\x00\x34\x00\x47\x00\x33\x00\x34\x00\x21\x00\x22\x00\x48\x00\x21\x00\x22\x00\x16\x00\x27\x00\x28\x00\x29\x00\x27\x00\x28\x00\x29\x00\x37\x00\x16\x00\x16\x00\x45\x00\x16\x00\x08\x00\x33\x00\x34\x00\x48\x00\x33\x00\x34\x00\x21\x00\x22\x00\x47\x00\x21\x00\x22\x00\x01\x00\x27\x00\x28\x00\x29\x00\x27\x00\x28\x00\x29\x00\x47\x00\x16\x00\x04\x00\x01\x00\x08\x00\x16\x00\x33\x00\x34\x00\x08\x00\x33\x00\x34\x00\x21\x00\x22\x00\x03\x00\x21\x00\x22\x00\x02\x00\x27\x00\x28\x00\x29\x00\x27\x00\x28\x00\x29\x00\x08\x00\x47\x00\x03\x00\x16\x00\x08\x00\x16\x00\x33\x00\x34\x00\x16\x00\x33\x00\x34\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x27\x00\x28\x00\x29\x00\x28\x00\x29\x00\x48\x00\x29\x00\x47\x00\x47\x00\x02\x00\x21\x00\x22\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x29\x00\x21\x00\x22\x00\x47\x00\x21\x00\x22\x00\x21\x00\x22\x00\x04\x00\x29\x00\x33\x00\x34\x00\x29\x00\x08\x00\x29\x00\x30\x00\x02\x00\x02\x00\x34\x00\x33\x00\x34\x00\x04\x00\x33\x00\x34\x00\x33\x00\x34\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x29\x00\x46\x00\x29\x00\x02\x00\x29\x00\x08\x00\x29\x00\x04\x00\x16\x00\x47\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x29\x00\x16\x00\x29\x00\x48\x00\x29\x00\x08\x00\x29\x00\x08\x00\x08\x00\x0f\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x29\x00\x0f\x00\x29\x00\x2f\x00\x29\x00\x09\x00\x29\x00\x0f\x00\x03\x00\x0f\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x29\x00\x1a\x00\x29\x00\x11\x00\x29\x00\x06\x00\x29\x00\x23\x00\x23\x00\x2d\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x29\x00\x18\x00\x29\x00\x13\x00\x29\x00\x19\x00\x29\x00\x06\x00\x2e\x00\x06\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x21\x00\x22\x00\x29\x00\x09\x00\x29\x00\x20\x00\x29\x00\x09\x00\x29\x00\x19\x00\x11\x00\x1f\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x33\x00\x34\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x1e\x00\x17\x00\x1e\x00\x1a\x00\x1b\x00\x1d\x00\x14\x00\xff\xff\xff\xff\x1a\x00\x1b\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\xff\xff\x46\x00\x47\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x7c\x00\xff\xff\x03\x01\x80\x01\xaa\x00\x7d\x00\xab\x00\xf1\x00\x21\x00\x7e\x00\x8b\x00\xcc\x00\x7f\x00\x80\x00\x50\x01\x51\x00\x52\x00\x04\x01\x78\x00\x2f\x00\x53\x00\x79\x00\x91\x00\x26\x00\x8c\x00\x79\x00\x50\x00\x51\x00\x92\x00\x9a\x00\x78\x00\x7a\x00\x09\x00\x58\x00\x2c\x00\x7a\x00\x09\x00\x79\x00\x59\x00\xa8\x00\xcd\x00\xce\x00\x10\x01\x81\x01\x22\x00\x23\x00\x54\x00\x7a\x00\x09\x00\x11\x01\x55\x00\xcf\x00\xbc\x00\xbd\x00\xbe\x00\x56\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x11\x00\xf2\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x75\xff\x7d\x00\x75\xff\x5e\x00\x5f\x00\x7e\x00\x13\x00\x60\x00\x7f\x00\x80\x00\x61\x00\x62\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x63\x00\x64\x00\x9f\x00\x5e\x01\x26\x00\x12\x01\x7e\x00\x2b\x00\x5f\x01\x7f\x00\x80\x00\x65\x01\x78\x00\x2a\x00\x66\x01\x67\x01\x68\x01\x7d\x00\xa0\x00\x79\x00\x29\x00\x7e\x00\x28\x00\x06\x01\x7f\x00\x80\x00\x2a\x01\xa2\x00\xa3\x00\x7a\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x7d\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\x27\x00\x7f\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x02\x00\x03\x00\x04\x00\x8f\x00\x4c\x00\x4d\x00\x09\x00\x05\x00\xa6\x00\xa7\x00\x06\x00\x26\x00\x07\x00\x24\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x6e\x00\x6f\x00\xcd\x00\xce\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x85\x00\x6f\x00\x08\x00\x09\x00\x2f\x00\x03\x00\x04\x00\x63\x00\x0d\x01\xcd\x00\xce\x00\x05\x00\x9b\x00\x9c\x00\x06\x00\x40\x00\x07\x00\x3f\x00\xac\x00\x52\x00\x3e\x00\x50\x00\x51\x00\x53\x00\x9d\x00\x78\x00\xab\x00\x52\x00\x3d\x00\x17\x01\x52\x00\x53\x00\x79\x00\x3c\x00\x53\x00\x1e\x00\x1f\x00\x70\x00\x71\x00\x6e\x01\x84\x01\x52\x00\x7a\x00\x09\x00\x3b\x00\x53\x00\x3a\x00\x70\x00\x71\x00\x54\x00\x40\x00\x1f\x00\x39\x00\x55\x00\x38\x00\x08\x00\x09\x00\x54\x00\x56\x00\x09\x00\x54\x00\x55\x00\xfa\x00\x09\x00\x55\x00\x73\x00\x56\x00\x09\x00\x37\x00\x56\x00\x09\x00\x54\x00\x91\x01\x52\x00\x32\x00\x55\x00\x36\x00\x53\x00\x3f\x01\x40\x01\x56\x00\x09\x00\x35\x00\x8f\x01\x52\x00\x59\x01\x40\x01\x34\x00\x53\x00\x33\x00\x74\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x4a\x00\x65\x01\x78\x00\x54\x00\x49\x00\x88\x01\x68\x01\x55\x00\x48\x00\x79\x00\x47\x00\x46\x00\x56\x00\x09\x00\x54\x00\x45\x00\x26\x00\x43\x00\x55\x00\x7a\x00\x09\x00\x6e\x00\x6d\x00\x56\x00\x09\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x6c\x00\x11\x00\x12\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x6b\x00\x6a\x00\x69\x00\x13\x00\x68\x00\x67\x00\x66\x00\xc6\x00\xc7\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x65\x00\x1e\x00\xb8\x00\xb9\x00\xb7\x00\x9c\x00\x16\x01\x9c\x00\x15\x01\x9c\x00\xae\x00\xa9\x00\xa1\x00\x97\x00\xba\x00\x78\x00\x9d\x00\x78\x00\x9d\x00\x78\x00\x9d\x00\x78\x00\x79\x00\x98\x00\x79\x00\x95\x00\x79\x00\x94\x00\x79\x00\x8f\x00\xee\x00\x8d\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x2e\x01\x8a\x00\x89\x00\x88\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x6f\x01\x87\x00\x76\x00\xf0\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x77\x00\x08\x01\x75\x00\xef\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xec\x00\xed\x00\xe9\x00\xe4\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xd2\x00\xe6\x00\xd3\x00\xe3\x00\xe2\x00\xe0\x00\xdf\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xdc\x00\xdb\x00\xb7\x00\xb6\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x2d\x01\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xd8\x00\xb5\x00\xb4\x00\xb0\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x4b\x01\xe0\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xa6\x00\xaf\x00\x31\x01\x30\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xd0\x00\x2c\x01\x15\x01\x2a\x01\x29\x01\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x13\x01\x0a\x01\x07\x01\x03\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x70\x01\x09\x01\x01\x01\x00\x01\xff\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xfa\x00\xfe\x00\xfd\x00\xf7\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xf9\x00\xfc\x00\xf6\x00\x8f\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xf3\x00\x50\x01\xf4\x00\x4e\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xd4\x00\x4f\x01\x4d\x01\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x4c\x01\x49\x01\x45\x01\x44\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x0b\x01\x48\x01\x47\x01\x46\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x8f\x00\x3f\x01\x3e\x01\x42\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x3b\x01\x3a\x01\x39\x01\x38\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\x00\x00\x37\x01\xcd\x00\x36\x01\x34\x01\xc6\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x78\x00\x35\x01\xd4\x00\x78\x00\x33\x01\xdc\x00\xd6\x00\x79\x00\xd9\x00\xd6\x00\x79\x00\x32\x01\x63\x01\x61\x01\x12\x01\x5d\x01\x5c\x01\x7a\x00\x09\x00\x7a\x01\x7a\x00\x09\x00\xd4\x00\x78\x00\x59\x01\xd4\x00\x78\x00\x56\x01\xd5\x00\xd6\x00\x79\x00\x13\x01\xd6\x00\x79\x00\x42\x01\x55\x01\x54\x01\x94\x00\x53\x01\x52\x01\x7a\x00\x09\x00\x79\x01\x7a\x00\x09\x00\xd4\x00\x78\x00\x78\x01\xd4\x00\x78\x00\x76\x01\x0d\x01\xd6\x00\x79\x00\x49\x01\xd6\x00\x79\x00\x77\x01\x75\x01\x74\x01\x73\x01\x6d\x01\x6c\x01\x7a\x00\x09\x00\x6b\x01\x7a\x00\x09\x00\xd4\x00\x78\x00\x71\x01\xd4\x00\x78\x00\x8a\x01\x69\x01\xd6\x00\x79\x00\x71\x01\xd6\x00\x79\x00\x84\x01\x88\x01\x83\x01\x7e\x01\x7b\x01\x7d\x01\x7a\x00\x09\x00\x7c\x01\x7a\x00\x09\x00\xd4\x00\x78\x00\xd4\x00\x78\x00\x99\x00\x78\x00\x85\x01\xd6\x00\x79\x00\x3c\x01\x79\x00\x59\x01\x79\x00\x95\x01\x94\x01\x8f\x01\x98\x00\x78\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x79\x00\x77\x00\x78\x00\x93\x01\xea\x00\x78\x00\xe9\x00\x78\x00\x8e\x01\x79\x00\x7a\x00\x09\x00\x79\x00\x8d\x01\x79\x00\x8c\x01\x9e\x01\x9c\x01\x9d\x01\x7a\x00\x09\x00\x9b\x01\x7a\x00\x09\x00\x7a\x00\x09\x00\xe7\x00\x78\x00\xdd\x00\x78\x00\xd8\x00\x78\x00\xb1\x00\x78\x00\x79\x00\x91\x01\x79\x00\x9a\x01\x79\x00\x98\x01\x79\x00\x99\x01\x97\x01\xa0\x01\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\xb0\x00\x78\x00\x27\x01\x78\x00\x26\x01\x78\x00\x25\x01\x78\x00\x79\x00\x96\x01\x79\x00\x9f\x01\x79\x00\xa2\x01\x79\x00\xa1\x01\x2d\x00\x2c\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x24\x01\x78\x00\x23\x01\x78\x00\x22\x01\x78\x00\x21\x01\x78\x00\x79\x00\x24\x00\x79\x00\x30\x00\x79\x00\x4e\x00\x79\x00\x43\x00\x41\x00\x2c\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x20\x01\x78\x00\x1f\x01\x78\x00\x1e\x01\x78\x00\x1d\x01\x78\x00\x79\x00\x95\x00\x79\x00\x92\x00\x79\x00\x8d\x00\x79\x00\xe6\x00\xe4\x00\xb2\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x1c\x01\x78\x00\x1b\x01\x78\x00\x1a\x01\x78\x00\x19\x01\x78\x00\x79\x00\xd0\x00\x79\x00\x2e\x01\x79\x00\x0e\x01\x79\x00\x01\x01\x0b\x01\xf4\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x18\x01\x78\x00\xf7\x00\x78\x00\x64\x01\x78\x00\x63\x01\x78\x00\x79\x00\x42\x01\x79\x00\x61\x01\x79\x00\x3b\x01\x79\x00\x5f\x01\x56\x01\x5a\x01\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\x57\x01\x86\x01\x81\x01\xc6\x00\xc7\x00\x7e\x01\x8a\x01\x00\x00\x00\x00\xc6\x00\xc7\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\xa6\x00\xa7\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xa1\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x4c\x00\x4d\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (1, 166) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68), - (69 , happyReduce_69), - (70 , happyReduce_70), - (71 , happyReduce_71), - (72 , happyReduce_72), - (73 , happyReduce_73), - (74 , happyReduce_74), - (75 , happyReduce_75), - (76 , happyReduce_76), - (77 , happyReduce_77), - (78 , happyReduce_78), - (79 , happyReduce_79), - (80 , happyReduce_80), - (81 , happyReduce_81), - (82 , happyReduce_82), - (83 , happyReduce_83), - (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86), - (87 , happyReduce_87), - (88 , happyReduce_88), - (89 , happyReduce_89), - (90 , happyReduce_90), - (91 , happyReduce_91), - (92 , happyReduce_92), - (93 , happyReduce_93), - (94 , happyReduce_94), - (95 , happyReduce_95), - (96 , happyReduce_96), - (97 , happyReduce_97), - (98 , happyReduce_98), - (99 , happyReduce_99), - (100 , happyReduce_100), - (101 , happyReduce_101), - (102 , happyReduce_102), - (103 , happyReduce_103), - (104 , happyReduce_104), - (105 , happyReduce_105), - (106 , happyReduce_106), - (107 , happyReduce_107), - (108 , happyReduce_108), - (109 , happyReduce_109), - (110 , happyReduce_110), - (111 , happyReduce_111), - (112 , happyReduce_112), - (113 , happyReduce_113), - (114 , happyReduce_114), - (115 , happyReduce_115), - (116 , happyReduce_116), - (117 , happyReduce_117), - (118 , happyReduce_118), - (119 , happyReduce_119), - (120 , happyReduce_120), - (121 , happyReduce_121), - (122 , happyReduce_122), - (123 , happyReduce_123), - (124 , happyReduce_124), - (125 , happyReduce_125), - (126 , happyReduce_126), - (127 , happyReduce_127), - (128 , happyReduce_128), - (129 , happyReduce_129), - (130 , happyReduce_130), - (131 , happyReduce_131), - (132 , happyReduce_132), - (133 , happyReduce_133), - (134 , happyReduce_134), - (135 , happyReduce_135), - (136 , happyReduce_136), - (137 , happyReduce_137), - (138 , happyReduce_138), - (139 , happyReduce_139), - (140 , happyReduce_140), - (141 , happyReduce_141), - (142 , happyReduce_142), - (143 , happyReduce_143), - (144 , happyReduce_144), - (145 , happyReduce_145), - (146 , happyReduce_146), - (147 , happyReduce_147), - (148 , happyReduce_148), - (149 , happyReduce_149), - (150 , happyReduce_150), - (151 , happyReduce_151), - (152 , happyReduce_152), - (153 , happyReduce_153), - (154 , happyReduce_154), - (155 , happyReduce_155), - (156 , happyReduce_156), - (157 , happyReduce_157), - (158 , happyReduce_158), - (159 , happyReduce_159), - (160 , happyReduce_160), - (161 , happyReduce_161), - (162 , happyReduce_162), - (163 , happyReduce_163), - (164 , happyReduce_164), - (165 , happyReduce_165), - (166 , happyReduce_166) - ] - -happy_n_terms = 75 :: Int -happy_n_nonterms = 53 :: Int - -happyReduce_1 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_1 = happySpecReduce_0 0# happyReduction_1 -happyReduction_1 = happyIn4 - (return () - ) - -happyReduce_2 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_2 = happySpecReduce_2 0# happyReduction_2 -happyReduction_2 happy_x_2 - happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut4 happy_x_2 of { happy_var_2 -> - happyIn4 - (do happy_var_1; happy_var_2 - )}} - -happyReduce_3 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_3 = happySpecReduce_1 1# happyReduction_3 -happyReduction_3 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn5 - (happy_var_1 - )} - -happyReduce_4 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_4 = happySpecReduce_1 1# happyReduction_4 -happyReduction_4 happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn5 - (happy_var_1 - )} - -happyReduce_5 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_5 = happySpecReduce_1 1# happyReduction_5 -happyReduction_5 happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - happyIn5 - (happy_var_1 - )} - -happyReduce_6 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_6 = happyMonadReduce 8# 1# happyReduction_6 -happyReduction_6 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Name happy_var_5)) -> - case happyOut10 happy_x_6 of { happy_var_6 -> - ( liftP . withThisPackage $ \pkg -> - do lits <- sequence happy_var_6; - staticClosure pkg happy_var_3 happy_var_5 (map getLit lits))}}}) - ) (\r -> happyReturn (happyIn5 r)) - -happyReduce_7 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_7 = happyReduce 6# 2# happyReduction_7 -happyReduction_7 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> - case happyOut7 happy_x_4 of { happy_var_4 -> - case happyOut8 happy_x_5 of { happy_var_5 -> - happyIn6 - (do lbl <- happy_var_4; - ss <- sequence happy_var_5; - code (emitDecl (CmmData (Section (section happy_var_2) lbl) (Statics lbl $ concat ss))) - ) `HappyStk` happyRest}}} - -happyReduce_8 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_8 = happyMonadReduce 2# 3# happyReduction_8 -happyReduction_8 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - ( liftP . withThisPackage $ \pkg -> - return (mkCmmDataLabel pkg happy_var_1))}) - ) (\r -> happyReturn (happyIn7 r)) - -happyReduce_9 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_9 = happySpecReduce_0 4# happyReduction_9 -happyReduction_9 = happyIn8 - ([] - ) - -happyReduce_10 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_10 = happySpecReduce_2 4# happyReduction_10 -happyReduction_10 happy_x_2 - happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn8 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_11 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_11 = happySpecReduce_3 5# happyReduction_11 -happyReduction_11 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_2 of { happy_var_2 -> - happyIn9 - (do e <- happy_var_2; - return [CmmStaticLit (getLit e)] - )} - -happyReduce_12 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_12 = happySpecReduce_2 5# happyReduction_12 -happyReduction_12 happy_x_2 - happy_x_1 - = case happyOut55 happy_x_1 of { happy_var_1 -> - happyIn9 - (return [CmmUninitialised - (widthInBytes (typeWidth happy_var_1))] - )} - -happyReduce_13 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_13 = happyReduce 5# 5# happyReduction_13 -happyReduction_13 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_4 of { (L _ (CmmT_String happy_var_4)) -> - happyIn9 - (return [mkString happy_var_4] - ) `HappyStk` happyRest} - -happyReduce_14 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_14 = happyReduce 5# 5# happyReduction_14 -happyReduction_14 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> - happyIn9 - (return [CmmUninitialised - (fromIntegral happy_var_3)] - ) `HappyStk` happyRest} - -happyReduce_15 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_15 = happyReduce 5# 5# happyReduction_15 -happyReduction_15 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut56 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> - happyIn9 - (return [CmmUninitialised - (widthInBytes (typeWidth happy_var_1) * - fromIntegral happy_var_3)] - ) `HappyStk` happyRest}} - -happyReduce_16 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_16 = happyReduce 5# 5# happyReduction_16 -happyReduction_16 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn9 - (do { lits <- sequence happy_var_4 - ; dflags <- getDynFlags - ; return $ map CmmStaticLit $ - mkStaticClosure dflags (mkForeignLabel happy_var_3 Nothing ForeignLabelInExternalPackage IsData) - -- mkForeignLabel because these are only used - -- for CHARLIKE and INTLIKE closures in the RTS. - dontCareCCS (map getLit lits) [] [] [] } - ) `HappyStk` happyRest}} - -happyReduce_17 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_17 = happySpecReduce_0 6# happyReduction_17 -happyReduction_17 = happyIn10 - ([] - ) - -happyReduce_18 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_18 = happySpecReduce_3 6# happyReduction_18 -happyReduction_18 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn10 - (happy_var_2 : happy_var_3 - )}} - -happyReduce_19 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_19 = happyReduce 4# 7# happyReduction_19 -happyReduction_19 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut14 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - case happyOut51 happy_x_3 of { happy_var_3 -> - case happyOut13 happy_x_4 of { happy_var_4 -> - happyIn11 - (do ((entry_ret_label, info, stk_formals, formals), agraph) <- - getCodeScoped $ loopDecls $ do { - (entry_ret_label, info, stk_formals) <- happy_var_1; - dflags <- getDynFlags; - formals <- sequence (fromMaybe [] happy_var_3); - withName (showSDoc dflags (ppr entry_ret_label)) - happy_var_4; - return (entry_ret_label, info, stk_formals, formals) } - let do_layout = isJust happy_var_3 - code (emitProcWithStackFrame happy_var_2 info - entry_ret_label stk_formals formals agraph - do_layout ) - ) `HappyStk` happyRest}}}} - -happyReduce_20 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_20 = happySpecReduce_0 8# happyReduction_20 -happyReduction_20 = happyIn12 - (NativeNodeCall - ) - -happyReduce_21 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_21 = happySpecReduce_1 8# happyReduction_21 -happyReduction_21 happy_x_1 - = happyIn12 - (NativeReturn - ) - -happyReduce_22 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_22 = happySpecReduce_1 9# happyReduction_22 -happyReduction_22 happy_x_1 - = happyIn13 - (return () - ) - -happyReduce_23 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_23 = happySpecReduce_3 9# happyReduction_23 -happyReduction_23 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn13 - (withSourceNote happy_var_1 happy_var_3 happy_var_2 - )}}} - -happyReduce_24 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_24 = happyMonadReduce 1# 10# happyReduction_24 -happyReduction_24 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - ( liftP . withThisPackage $ \pkg -> - do newFunctionName happy_var_1 pkg - return (mkCmmCodeLabel pkg happy_var_1, Nothing, []))}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_25 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_25 = happyMonadReduce 14# 10# happyReduction_25 -happyReduction_25 (happy_x_14 `HappyStk` - happy_x_13 `HappyStk` - happy_x_12 `HappyStk` - happy_x_11 `HappyStk` - happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> - case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> - case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> - case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> - ( liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags happy_var_11 happy_var_13 - rep = mkRTSRep (fromIntegral happy_var_9) $ - mkHeapRep dflags False (fromIntegral happy_var_5) - (fromIntegral happy_var_7) Thunk - -- not really Thunk, but that makes the info table - -- we want. - return (mkCmmEntryLabel pkg happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []))}}}}}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_26 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_26 = happyMonadReduce 16# 10# happyReduction_26 -happyReduction_26 (happy_x_16 `HappyStk` - happy_x_15 `HappyStk` - happy_x_14 `HappyStk` - happy_x_13 `HappyStk` - happy_x_12 `HappyStk` - happy_x_11 `HappyStk` - happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> - case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> - case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> - case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> - case happyOutTok happy_x_15 of { (L _ (CmmT_Int happy_var_15)) -> - ( liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags happy_var_11 happy_var_13 - ty = Fun 0 (ArgSpec (fromIntegral happy_var_15)) - -- Arity zero, arg_type happy_var_15 - rep = mkRTSRep (fromIntegral happy_var_9) $ - mkHeapRep dflags False (fromIntegral happy_var_5) - (fromIntegral happy_var_7) ty - return (mkCmmEntryLabel pkg happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []))}}}}}}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_27 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_27 = happyMonadReduce 16# 10# happyReduction_27 -happyReduction_27 (happy_x_16 `HappyStk` - happy_x_15 `HappyStk` - happy_x_14 `HappyStk` - happy_x_13 `HappyStk` - happy_x_12 `HappyStk` - happy_x_11 `HappyStk` - happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> - case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> - case happyOutTok happy_x_11 of { (L _ (CmmT_Int happy_var_11)) -> - case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> - case happyOutTok happy_x_15 of { (L _ (CmmT_String happy_var_15)) -> - ( liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags happy_var_13 happy_var_15 - ty = Constr (fromIntegral happy_var_9) -- Tag - (stringToWord8s happy_var_13) - rep = mkRTSRep (fromIntegral happy_var_11) $ - mkHeapRep dflags False (fromIntegral happy_var_5) - (fromIntegral happy_var_7) ty - return (mkCmmEntryLabel pkg happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []))}}}}}}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_28 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_28 = happyMonadReduce 12# 10# happyReduction_28 -happyReduction_28 (happy_x_12 `HappyStk` - happy_x_11 `HappyStk` - happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> - case happyOutTok happy_x_9 of { (L _ (CmmT_String happy_var_9)) -> - case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> - ( liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags happy_var_9 happy_var_11 - ty = ThunkSelector (fromIntegral happy_var_5) - rep = mkRTSRep (fromIntegral happy_var_7) $ - mkHeapRep dflags False 0 0 ty - return (mkCmmEntryLabel pkg happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []))}}}}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_29 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_29 = happyMonadReduce 6# 10# happyReduction_29 -happyReduction_29 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - ( liftP . withThisPackage $ \pkg -> - do let prof = NoProfilingInfo - rep = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep [] - return (mkCmmRetLabel pkg happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []))}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_30 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_30 = happyMonadReduce 8# 10# happyReduction_30 -happyReduction_30 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOut52 happy_x_7 of { happy_var_7 -> - ( liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - live <- sequence happy_var_7 - let prof = NoProfilingInfo - -- drop one for the info pointer - bitmap = mkLiveness dflags (map Just (drop 1 live)) - rep = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep bitmap - return (mkCmmRetLabel pkg happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - live))}}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_31 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_31 = happySpecReduce_0 11# happyReduction_31 -happyReduction_31 = happyIn15 - (return () - ) - -happyReduce_32 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_32 = happySpecReduce_2 11# happyReduction_32 -happyReduction_32 happy_x_2 - happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - case happyOut15 happy_x_2 of { happy_var_2 -> - happyIn15 - (do happy_var_1; happy_var_2 - )}} - -happyReduce_33 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_33 = happySpecReduce_2 11# happyReduction_33 -happyReduction_33 happy_x_2 - happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - case happyOut15 happy_x_2 of { happy_var_2 -> - happyIn15 - (do happy_var_1; happy_var_2 - )}} - -happyReduce_34 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_34 = happySpecReduce_3 12# happyReduction_34 -happyReduction_34 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut55 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_2 of { happy_var_2 -> - happyIn16 - (mapM_ (newLocal happy_var_1) happy_var_2 - )}} - -happyReduce_35 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_35 = happySpecReduce_3 12# happyReduction_35 -happyReduction_35 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut17 happy_x_2 of { happy_var_2 -> - happyIn16 - (mapM_ newImport happy_var_2 - )} - -happyReduce_36 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_36 = happySpecReduce_3 12# happyReduction_36 -happyReduction_36 happy_x_3 - happy_x_2 - happy_x_1 - = happyIn16 - (return () - ) - -happyReduce_37 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_37 = happySpecReduce_1 13# happyReduction_37 -happyReduction_37 happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn17 - ([happy_var_1] - )} - -happyReduce_38 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_38 = happySpecReduce_3 13# happyReduction_38 -happyReduction_38 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - case happyOut17 happy_x_3 of { happy_var_3 -> - happyIn17 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_39 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_39 = happySpecReduce_1 14# happyReduction_39 -happyReduction_39 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn18 - ((happy_var_1, mkForeignLabel happy_var_1 Nothing ForeignLabelInExternalPackage IsFunction) - )} - -happyReduce_40 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_40 = happySpecReduce_2 14# happyReduction_40 -happyReduction_40 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn18 - ((happy_var_2, mkForeignLabel happy_var_2 Nothing ForeignLabelInExternalPackage IsData) - )} - -happyReduce_41 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_41 = happySpecReduce_2 14# happyReduction_41 -happyReduction_41 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn18 - ((happy_var_2, mkCmmCodeLabel (fsToUnitId (mkFastString happy_var_1)) happy_var_2) - )}} - -happyReduce_42 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_42 = happySpecReduce_1 15# happyReduction_42 -happyReduction_42 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn19 - ([happy_var_1] - )} - -happyReduce_43 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_43 = happySpecReduce_3 15# happyReduction_43 -happyReduction_43 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn19 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_44 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_44 = happySpecReduce_1 16# happyReduction_44 -happyReduction_44 happy_x_1 - = happyIn20 - (return () - ) - -happyReduce_45 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_45 = happySpecReduce_2 16# happyReduction_45 -happyReduction_45 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn20 - (do l <- newLabel happy_var_1; emitLabel l - )} - -happyReduce_46 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_46 = happyReduce 4# 16# happyReduction_46 -happyReduction_46 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut50 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn20 - (do reg <- happy_var_1; e <- happy_var_3; withSourceNote happy_var_2 happy_var_4 (emitAssign reg e) - ) `HappyStk` happyRest}}}} - -happyReduce_47 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_47 = happyReduce 7# 16# happyReduction_47 -happyReduction_47 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut55 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - case happyOut37 happy_x_6 of { happy_var_6 -> - case happyOutTok happy_x_7 of { happy_var_7 -> - happyIn20 - (withSourceNote happy_var_2 happy_var_7 (doStore happy_var_1 happy_var_3 happy_var_6) - ) `HappyStk` happyRest}}}}} - -happyReduce_48 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_48 = happyMonadReduce 10# 16# happyReduction_48 -happyReduction_48 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut46 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_3 of { (L _ (CmmT_String happy_var_3)) -> - case happyOut23 happy_x_4 of { happy_var_4 -> - case happyOut40 happy_x_6 of { happy_var_6 -> - case happyOut27 happy_x_8 of { happy_var_8 -> - case happyOut24 happy_x_9 of { happy_var_9 -> - ( foreignCall happy_var_3 happy_var_1 happy_var_4 happy_var_6 happy_var_8 happy_var_9)}}}}}}) - ) (\r -> happyReturn (happyIn20 r)) - -happyReduce_49 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_49 = happyMonadReduce 8# 16# happyReduction_49 -happyReduction_49 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut46 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_4 of { (L _ (CmmT_Name happy_var_4)) -> - case happyOut43 happy_x_6 of { happy_var_6 -> - ( primCall happy_var_1 happy_var_4 happy_var_6)}}}) - ) (\r -> happyReturn (happyIn20 r)) - -happyReduce_50 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_50 = happyMonadReduce 5# 16# happyReduction_50 -happyReduction_50 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - case happyOut43 happy_x_3 of { happy_var_3 -> - ( stmtMacro happy_var_1 happy_var_3)}}) - ) (\r -> happyReturn (happyIn20 r)) - -happyReduce_51 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_51 = happyReduce 7# 16# happyReduction_51 -happyReduction_51 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut30 happy_x_2 of { happy_var_2 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - case happyOut31 happy_x_5 of { happy_var_5 -> - case happyOut35 happy_x_6 of { happy_var_6 -> - happyIn20 - (do as <- sequence happy_var_5; doSwitch happy_var_2 happy_var_3 as happy_var_6 - ) `HappyStk` happyRest}}}} - -happyReduce_52 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_52 = happySpecReduce_3 16# happyReduction_52 -happyReduction_52 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn20 - (do l <- lookupLabel happy_var_2; emit (mkBranch l) - )} - -happyReduce_53 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_53 = happyReduce 5# 16# happyReduction_53 -happyReduction_53 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut43 happy_x_3 of { happy_var_3 -> - happyIn20 - (doReturn happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_54 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_54 = happyReduce 4# 16# happyReduction_54 -happyReduction_54 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut37 happy_x_2 of { happy_var_2 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn20 - (doRawJump happy_var_2 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_55 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_55 = happyReduce 6# 16# happyReduction_55 -happyReduction_55 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut37 happy_x_2 of { happy_var_2 -> - case happyOut43 happy_x_4 of { happy_var_4 -> - happyIn20 - (doJumpWithStack happy_var_2 [] happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_56 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_56 = happyReduce 9# 16# happyReduction_56 -happyReduction_56 (happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut37 happy_x_2 of { happy_var_2 -> - case happyOut43 happy_x_4 of { happy_var_4 -> - case happyOut43 happy_x_7 of { happy_var_7 -> - happyIn20 - (doJumpWithStack happy_var_2 happy_var_4 happy_var_7 - ) `HappyStk` happyRest}}} - -happyReduce_57 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_57 = happyReduce 6# 16# happyReduction_57 -happyReduction_57 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut37 happy_x_2 of { happy_var_2 -> - case happyOut43 happy_x_4 of { happy_var_4 -> - happyIn20 - (doCall happy_var_2 [] happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_58 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_58 = happyReduce 10# 16# happyReduction_58 -happyReduction_58 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut53 happy_x_2 of { happy_var_2 -> - case happyOut37 happy_x_6 of { happy_var_6 -> - case happyOut43 happy_x_8 of { happy_var_8 -> - happyIn20 - (doCall happy_var_6 happy_var_2 happy_var_8 - ) `HappyStk` happyRest}}} - -happyReduce_59 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_59 = happyReduce 4# 16# happyReduction_59 -happyReduction_59 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut25 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_4 of { (L _ (CmmT_Name happy_var_4)) -> - happyIn20 - (do l <- lookupLabel happy_var_4; cmmRawIf happy_var_2 l - ) `HappyStk` happyRest}} - -happyReduce_60 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_60 = happyReduce 6# 16# happyReduction_60 -happyReduction_60 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut25 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut15 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut36 happy_x_6 of { happy_var_6 -> - happyIn20 - (cmmIfThenElse happy_var_2 (withSourceNote happy_var_3 happy_var_5 happy_var_4) happy_var_6 - ) `HappyStk` happyRest}}}}} - -happyReduce_61 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_61 = happyReduce 5# 16# happyReduction_61 -happyReduction_61 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut43 happy_x_3 of { happy_var_3 -> - case happyOut13 happy_x_5 of { happy_var_5 -> - happyIn20 - (pushStackFrame happy_var_3 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_62 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_62 = happyReduce 5# 16# happyReduction_62 -happyReduction_62 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut37 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - case happyOut13 happy_x_5 of { happy_var_5 -> - happyIn20 - (reserveStackFrame happy_var_2 happy_var_4 happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_63 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_63 = happySpecReduce_3 16# happyReduction_63 -happyReduction_63 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut21 happy_x_2 of { happy_var_2 -> - happyIn20 - (happy_var_2 >>= code . emitUnwind - )} - -happyReduce_64 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_64 = happyReduce 5# 17# happyReduction_64 -happyReduction_64 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - case happyOut22 happy_x_3 of { happy_var_3 -> - case happyOut21 happy_x_5 of { happy_var_5 -> - happyIn21 - (do e <- happy_var_3; rest <- happy_var_5; return ((happy_var_1, e) : rest) - ) `HappyStk` happyRest}}} - -happyReduce_65 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_65 = happySpecReduce_3 17# happyReduction_65 -happyReduction_65 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - case happyOut22 happy_x_3 of { happy_var_3 -> - happyIn21 - (do e <- happy_var_3; return [(happy_var_1, e)] - )}} - -happyReduce_66 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_66 = happySpecReduce_1 18# happyReduction_66 -happyReduction_66 happy_x_1 - = happyIn22 - (do return Nothing - ) - -happyReduce_67 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_67 = happySpecReduce_1 18# happyReduction_67 -happyReduction_67 happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - happyIn22 - (do e <- happy_var_1; return (Just e) - )} - -happyReduce_68 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_68 = happySpecReduce_1 19# happyReduction_68 -happyReduction_68 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn23 - (return (CmmLit (CmmLabel (mkForeignLabel happy_var_1 Nothing ForeignLabelInThisPackage IsFunction))) - )} - -happyReduce_69 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_69 = happySpecReduce_0 20# happyReduction_69 -happyReduction_69 = happyIn24 - (CmmMayReturn - ) - -happyReduce_70 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_70 = happySpecReduce_2 20# happyReduction_70 -happyReduction_70 happy_x_2 - happy_x_1 - = happyIn24 - (CmmNeverReturns - ) - -happyReduce_71 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_71 = happySpecReduce_1 21# happyReduction_71 -happyReduction_71 happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - happyIn25 - (happy_var_1 - )} - -happyReduce_72 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_72 = happySpecReduce_1 21# happyReduction_72 -happyReduction_72 happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - happyIn25 - (do e <- happy_var_1; return (BoolTest e) - )} - -happyReduce_73 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_73 = happySpecReduce_3 22# happyReduction_73 -happyReduction_73 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut25 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_3 of { happy_var_3 -> - happyIn26 - (do e1 <- happy_var_1; e2 <- happy_var_3; - return (BoolAnd e1 e2) - )}} - -happyReduce_74 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_74 = happySpecReduce_3 22# happyReduction_74 -happyReduction_74 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut25 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_3 of { happy_var_3 -> - happyIn26 - (do e1 <- happy_var_1; e2 <- happy_var_3; - return (BoolOr e1 e2) - )}} - -happyReduce_75 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_75 = happySpecReduce_2 22# happyReduction_75 -happyReduction_75 happy_x_2 - happy_x_1 - = case happyOut25 happy_x_2 of { happy_var_2 -> - happyIn26 - (do e <- happy_var_2; return (BoolNot e) - )} - -happyReduce_76 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_76 = happySpecReduce_3 22# happyReduction_76 -happyReduction_76 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut26 happy_x_2 of { happy_var_2 -> - happyIn26 - (happy_var_2 - )} - -happyReduce_77 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_77 = happySpecReduce_0 23# happyReduction_77 -happyReduction_77 = happyIn27 - (PlayRisky - ) - -happyReduce_78 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_78 = happyMonadReduce 1# 23# happyReduction_78 -happyReduction_78 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - ( parseSafety happy_var_1)}) - ) (\r -> happyReturn (happyIn27 r)) - -happyReduce_79 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_79 = happySpecReduce_2 24# happyReduction_79 -happyReduction_79 happy_x_2 - happy_x_1 - = happyIn28 - ([] - ) - -happyReduce_80 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_80 = happyMonadReduce 3# 24# happyReduction_80 -happyReduction_80 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((( do df <- getDynFlags - ; return (realArgRegsCover df))) - ) (\r -> happyReturn (happyIn28 r)) - -happyReduce_81 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_81 = happySpecReduce_3 24# happyReduction_81 -happyReduction_81 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut29 happy_x_2 of { happy_var_2 -> - happyIn28 - (happy_var_2 - )} - -happyReduce_82 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_82 = happySpecReduce_1 25# happyReduction_82 -happyReduction_82 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn29 - ([happy_var_1] - )} - -happyReduce_83 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_83 = happySpecReduce_3 25# happyReduction_83 -happyReduction_83 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - case happyOut29 happy_x_3 of { happy_var_3 -> - happyIn29 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_84 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_84 = happyReduce 5# 26# happyReduction_84 -happyReduction_84 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (L _ (CmmT_Int happy_var_2)) -> - case happyOutTok happy_x_4 of { (L _ (CmmT_Int happy_var_4)) -> - happyIn30 - (Just (happy_var_2, happy_var_4) - ) `HappyStk` happyRest}} - -happyReduce_85 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_85 = happySpecReduce_0 26# happyReduction_85 -happyReduction_85 = happyIn30 - (Nothing - ) - -happyReduce_86 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_86 = happySpecReduce_0 27# happyReduction_86 -happyReduction_86 = happyIn31 - ([] - ) - -happyReduce_87 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_87 = happySpecReduce_2 27# happyReduction_87 -happyReduction_87 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut31 happy_x_2 of { happy_var_2 -> - happyIn31 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_88 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_88 = happyReduce 4# 28# happyReduction_88 -happyReduction_88 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut33 happy_x_4 of { happy_var_4 -> - happyIn32 - (do b <- happy_var_4; return (happy_var_2, b) - ) `HappyStk` happyRest}} - -happyReduce_89 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_89 = happySpecReduce_3 29# happyReduction_89 -happyReduction_89 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn33 - (return (Right (withSourceNote happy_var_1 happy_var_3 happy_var_2)) - )}}} - -happyReduce_90 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_90 = happySpecReduce_3 29# happyReduction_90 -happyReduction_90 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn33 - (do l <- lookupLabel happy_var_2; return (Left l) - )} - -happyReduce_91 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_91 = happySpecReduce_1 30# happyReduction_91 -happyReduction_91 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - happyIn34 - ([ happy_var_1 ] - )} - -happyReduce_92 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_92 = happySpecReduce_3 30# happyReduction_92 -happyReduction_92 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn34 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_93 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_93 = happyReduce 5# 31# happyReduction_93 -happyReduction_93 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut15 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - happyIn35 - (Just (withSourceNote happy_var_3 happy_var_5 happy_var_4) - ) `HappyStk` happyRest}}} - -happyReduce_94 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_94 = happySpecReduce_0 31# happyReduction_94 -happyReduction_94 = happyIn35 - (Nothing - ) - -happyReduce_95 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_95 = happySpecReduce_0 32# happyReduction_95 -happyReduction_95 = happyIn36 - (return () - ) - -happyReduce_96 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_96 = happyReduce 4# 32# happyReduction_96 -happyReduction_96 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut15 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn36 - (withSourceNote happy_var_2 happy_var_4 happy_var_3 - ) `HappyStk` happyRest}}} - -happyReduce_97 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_97 = happySpecReduce_3 33# happyReduction_97 -happyReduction_97 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_U_Quot [happy_var_1,happy_var_3] - )}} - -happyReduce_98 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_98 = happySpecReduce_3 33# happyReduction_98 -happyReduction_98 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_Mul [happy_var_1,happy_var_3] - )}} - -happyReduce_99 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_99 = happySpecReduce_3 33# happyReduction_99 -happyReduction_99 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_U_Rem [happy_var_1,happy_var_3] - )}} - -happyReduce_100 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_100 = happySpecReduce_3 33# happyReduction_100 -happyReduction_100 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_Sub [happy_var_1,happy_var_3] - )}} - -happyReduce_101 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_101 = happySpecReduce_3 33# happyReduction_101 -happyReduction_101 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_Add [happy_var_1,happy_var_3] - )}} - -happyReduce_102 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_102 = happySpecReduce_3 33# happyReduction_102 -happyReduction_102 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_U_Shr [happy_var_1,happy_var_3] - )}} - -happyReduce_103 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_103 = happySpecReduce_3 33# happyReduction_103 -happyReduction_103 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_Shl [happy_var_1,happy_var_3] - )}} - -happyReduce_104 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_104 = happySpecReduce_3 33# happyReduction_104 -happyReduction_104 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_And [happy_var_1,happy_var_3] - )}} - -happyReduce_105 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_105 = happySpecReduce_3 33# happyReduction_105 -happyReduction_105 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_Xor [happy_var_1,happy_var_3] - )}} - -happyReduce_106 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_106 = happySpecReduce_3 33# happyReduction_106 -happyReduction_106 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_Or [happy_var_1,happy_var_3] - )}} - -happyReduce_107 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_107 = happySpecReduce_3 33# happyReduction_107 -happyReduction_107 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_U_Ge [happy_var_1,happy_var_3] - )}} - -happyReduce_108 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_108 = happySpecReduce_3 33# happyReduction_108 -happyReduction_108 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_U_Gt [happy_var_1,happy_var_3] - )}} - -happyReduce_109 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_109 = happySpecReduce_3 33# happyReduction_109 -happyReduction_109 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_U_Le [happy_var_1,happy_var_3] - )}} - -happyReduce_110 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_110 = happySpecReduce_3 33# happyReduction_110 -happyReduction_110 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_U_Lt [happy_var_1,happy_var_3] - )}} - -happyReduce_111 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_111 = happySpecReduce_3 33# happyReduction_111 -happyReduction_111 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_Ne [happy_var_1,happy_var_3] - )}} - -happyReduce_112 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_112 = happySpecReduce_3 33# happyReduction_112 -happyReduction_112 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - (mkMachOp MO_Eq [happy_var_1,happy_var_3] - )}} - -happyReduce_113 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_113 = happySpecReduce_2 33# happyReduction_113 -happyReduction_113 happy_x_2 - happy_x_1 - = case happyOut37 happy_x_2 of { happy_var_2 -> - happyIn37 - (mkMachOp MO_Not [happy_var_2] - )} - -happyReduce_114 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_114 = happySpecReduce_2 33# happyReduction_114 -happyReduction_114 happy_x_2 - happy_x_1 - = case happyOut37 happy_x_2 of { happy_var_2 -> - happyIn37 - (mkMachOp MO_S_Neg [happy_var_2] - )} - -happyReduce_115 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_115 = happyMonadReduce 5# 33# happyReduction_115 -happyReduction_115 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut38 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOut38 happy_x_5 of { happy_var_5 -> - ( do { mo <- nameToMachOp happy_var_3 ; - return (mkMachOp mo [happy_var_1,happy_var_5]) })}}}) - ) (\r -> happyReturn (happyIn37 r)) - -happyReduce_116 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_116 = happySpecReduce_1 33# happyReduction_116 -happyReduction_116 happy_x_1 - = case happyOut38 happy_x_1 of { happy_var_1 -> - happyIn37 - (happy_var_1 - )} - -happyReduce_117 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_117 = happySpecReduce_2 34# happyReduction_117 -happyReduction_117 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - case happyOut39 happy_x_2 of { happy_var_2 -> - happyIn38 - (return (CmmLit (CmmInt happy_var_1 (typeWidth happy_var_2))) - )}} - -happyReduce_118 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_118 = happySpecReduce_2 34# happyReduction_118 -happyReduction_118 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Float happy_var_1)) -> - case happyOut39 happy_x_2 of { happy_var_2 -> - happyIn38 - (return (CmmLit (CmmFloat happy_var_1 (typeWidth happy_var_2))) - )}} - -happyReduce_119 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_119 = happySpecReduce_1 34# happyReduction_119 -happyReduction_119 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - happyIn38 - (do s <- code (newStringCLit happy_var_1); - return (CmmLit s) - )} - -happyReduce_120 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_120 = happySpecReduce_1 34# happyReduction_120 -happyReduction_120 happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - happyIn38 - (happy_var_1 - )} - -happyReduce_121 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_121 = happyReduce 4# 34# happyReduction_121 -happyReduction_121 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut55 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn38 - (do e <- happy_var_3; return (CmmLoad e happy_var_1) - ) `HappyStk` happyRest}} - -happyReduce_122 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_122 = happyMonadReduce 5# 34# happyReduction_122 -happyReduction_122 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - case happyOut43 happy_x_4 of { happy_var_4 -> - ( exprOp happy_var_2 happy_var_4)}}) - ) (\r -> happyReturn (happyIn38 r)) - -happyReduce_123 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_123 = happySpecReduce_3 34# happyReduction_123 -happyReduction_123 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_2 of { happy_var_2 -> - happyIn38 - (happy_var_2 - )} - -happyReduce_124 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_124 = happyMonadReduce 0# 35# happyReduction_124 -happyReduction_124 (happyRest) tk - = happyThen ((( do dflags <- getDynFlags; return $ bWord dflags)) - ) (\r -> happyReturn (happyIn39 r)) - -happyReduce_125 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_125 = happySpecReduce_2 35# happyReduction_125 -happyReduction_125 happy_x_2 - happy_x_1 - = case happyOut55 happy_x_2 of { happy_var_2 -> - happyIn39 - (happy_var_2 - )} - -happyReduce_126 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_126 = happySpecReduce_0 36# happyReduction_126 -happyReduction_126 = happyIn40 - ([] - ) - -happyReduce_127 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_127 = happySpecReduce_1 36# happyReduction_127 -happyReduction_127 happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - happyIn40 - (happy_var_1 - )} - -happyReduce_128 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_128 = happySpecReduce_1 37# happyReduction_128 -happyReduction_128 happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - happyIn41 - ([happy_var_1] - )} - -happyReduce_129 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_129 = happySpecReduce_3 37# happyReduction_129 -happyReduction_129 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut41 happy_x_3 of { happy_var_3 -> - happyIn41 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_130 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_130 = happySpecReduce_1 38# happyReduction_130 -happyReduction_130 happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - happyIn42 - (do e <- happy_var_1; - return (e, inferCmmHint e) - )} - -happyReduce_131 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_131 = happyMonadReduce 2# 38# happyReduction_131 -happyReduction_131 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> - ( do h <- parseCmmHint happy_var_2; - return $ do - e <- happy_var_1; return (e, h))}}) - ) (\r -> happyReturn (happyIn42 r)) - -happyReduce_132 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_132 = happySpecReduce_0 39# happyReduction_132 -happyReduction_132 = happyIn43 - ([] - ) - -happyReduce_133 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_133 = happySpecReduce_1 39# happyReduction_133 -happyReduction_133 happy_x_1 - = case happyOut44 happy_x_1 of { happy_var_1 -> - happyIn43 - (happy_var_1 - )} - -happyReduce_134 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_134 = happySpecReduce_1 40# happyReduction_134 -happyReduction_134 happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - happyIn44 - ([ happy_var_1 ] - )} - -happyReduce_135 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_135 = happySpecReduce_3 40# happyReduction_135 -happyReduction_135 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut44 happy_x_3 of { happy_var_3 -> - happyIn44 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_136 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_136 = happySpecReduce_1 41# happyReduction_136 -happyReduction_136 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn45 - (lookupName happy_var_1 - )} - -happyReduce_137 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_137 = happySpecReduce_1 41# happyReduction_137 -happyReduction_137 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn45 - (return (CmmReg (CmmGlobal happy_var_1)) - )} - -happyReduce_138 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_138 = happySpecReduce_0 42# happyReduction_138 -happyReduction_138 = happyIn46 - ([] - ) - -happyReduce_139 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_139 = happyReduce 4# 42# happyReduction_139 -happyReduction_139 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut47 happy_x_2 of { happy_var_2 -> - happyIn46 - (happy_var_2 - ) `HappyStk` happyRest} - -happyReduce_140 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_140 = happySpecReduce_1 43# happyReduction_140 -happyReduction_140 happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - happyIn47 - ([happy_var_1] - )} - -happyReduce_141 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_141 = happySpecReduce_2 43# happyReduction_141 -happyReduction_141 happy_x_2 - happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - happyIn47 - ([happy_var_1] - )} - -happyReduce_142 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_142 = happySpecReduce_3 43# happyReduction_142 -happyReduction_142 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - happyIn47 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_143 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_143 = happySpecReduce_1 44# happyReduction_143 -happyReduction_143 happy_x_1 - = case happyOut49 happy_x_1 of { happy_var_1 -> - happyIn48 - (do e <- happy_var_1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) - )} - -happyReduce_144 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_144 = happyMonadReduce 2# 44# happyReduction_144 -happyReduction_144 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - case happyOut49 happy_x_2 of { happy_var_2 -> - ( do h <- parseCmmHint happy_var_1; - return $ do - e <- happy_var_2; return (e,h))}}) - ) (\r -> happyReturn (happyIn48 r)) - -happyReduce_145 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_145 = happySpecReduce_1 45# happyReduction_145 -happyReduction_145 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn49 - (do e <- lookupName happy_var_1; - return $ - case e of - CmmReg (CmmLocal r) -> r - other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a local register") - )} - -happyReduce_146 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_146 = happySpecReduce_1 46# happyReduction_146 -happyReduction_146 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn50 - (do e <- lookupName happy_var_1; - return $ - case e of - CmmReg r -> r - other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a register") - )} - -happyReduce_147 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_147 = happySpecReduce_1 46# happyReduction_147 -happyReduction_147 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn50 - (return (CmmGlobal happy_var_1) - )} - -happyReduce_148 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_148 = happySpecReduce_0 47# happyReduction_148 -happyReduction_148 = happyIn51 - (Nothing - ) - -happyReduce_149 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_149 = happySpecReduce_3 47# happyReduction_149 -happyReduction_149 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut52 happy_x_2 of { happy_var_2 -> - happyIn51 - (Just happy_var_2 - )} - -happyReduce_150 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_150 = happySpecReduce_0 48# happyReduction_150 -happyReduction_150 = happyIn52 - ([] - ) - -happyReduce_151 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_151 = happySpecReduce_1 48# happyReduction_151 -happyReduction_151 happy_x_1 - = case happyOut53 happy_x_1 of { happy_var_1 -> - happyIn52 - (happy_var_1 - )} - -happyReduce_152 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_152 = happySpecReduce_2 49# happyReduction_152 -happyReduction_152 happy_x_2 - happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - happyIn53 - ([happy_var_1] - )} - -happyReduce_153 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_153 = happySpecReduce_1 49# happyReduction_153 -happyReduction_153 happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - happyIn53 - ([happy_var_1] - )} - -happyReduce_154 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_154 = happySpecReduce_3 49# happyReduction_154 -happyReduction_154 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - case happyOut53 happy_x_3 of { happy_var_3 -> - happyIn53 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_155 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_155 = happySpecReduce_2 50# happyReduction_155 -happyReduction_155 happy_x_2 - happy_x_1 - = case happyOut55 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn54 - (newLocal happy_var_1 happy_var_2 - )}} - -happyReduce_156 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_156 = happySpecReduce_1 51# happyReduction_156 -happyReduction_156 happy_x_1 - = happyIn55 - (b8 - ) - -happyReduce_157 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_157 = happySpecReduce_1 51# happyReduction_157 -happyReduction_157 happy_x_1 - = case happyOut56 happy_x_1 of { happy_var_1 -> - happyIn55 - (happy_var_1 - )} - -happyReduce_158 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_158 = happySpecReduce_1 52# happyReduction_158 -happyReduction_158 happy_x_1 - = happyIn56 - (b16 - ) - -happyReduce_159 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_159 = happySpecReduce_1 52# happyReduction_159 -happyReduction_159 happy_x_1 - = happyIn56 - (b32 - ) - -happyReduce_160 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_160 = happySpecReduce_1 52# happyReduction_160 -happyReduction_160 happy_x_1 - = happyIn56 - (b64 - ) - -happyReduce_161 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_161 = happySpecReduce_1 52# happyReduction_161 -happyReduction_161 happy_x_1 - = happyIn56 - (b128 - ) - -happyReduce_162 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_162 = happySpecReduce_1 52# happyReduction_162 -happyReduction_162 happy_x_1 - = happyIn56 - (b256 - ) - -happyReduce_163 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_163 = happySpecReduce_1 52# happyReduction_163 -happyReduction_163 happy_x_1 - = happyIn56 - (b512 - ) - -happyReduce_164 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_164 = happySpecReduce_1 52# happyReduction_164 -happyReduction_164 happy_x_1 - = happyIn56 - (f32 - ) - -happyReduce_165 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_165 = happySpecReduce_1 52# happyReduction_165 -happyReduction_165 happy_x_1 - = happyIn56 - (f64 - ) - -happyReduce_166 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_166 = happyMonadReduce 1# 52# happyReduction_166 -happyReduction_166 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((( do dflags <- getDynFlags; return $ gcWord dflags)) - ) (\r -> happyReturn (happyIn56 r)) - -happyNewToken action sts stk - = cmmlex(\tk -> - let cont i = happyDoAction i tk action sts stk in - case tk of { - L _ CmmT_EOF -> happyDoAction 74# tk action sts stk; - L _ (CmmT_SpecChar ':') -> cont 1#; - L _ (CmmT_SpecChar ';') -> cont 2#; - L _ (CmmT_SpecChar '{') -> cont 3#; - L _ (CmmT_SpecChar '}') -> cont 4#; - L _ (CmmT_SpecChar '[') -> cont 5#; - L _ (CmmT_SpecChar ']') -> cont 6#; - L _ (CmmT_SpecChar '(') -> cont 7#; - L _ (CmmT_SpecChar ')') -> cont 8#; - L _ (CmmT_SpecChar '=') -> cont 9#; - L _ (CmmT_SpecChar '`') -> cont 10#; - L _ (CmmT_SpecChar '~') -> cont 11#; - L _ (CmmT_SpecChar '/') -> cont 12#; - L _ (CmmT_SpecChar '*') -> cont 13#; - L _ (CmmT_SpecChar '%') -> cont 14#; - L _ (CmmT_SpecChar '-') -> cont 15#; - L _ (CmmT_SpecChar '+') -> cont 16#; - L _ (CmmT_SpecChar '&') -> cont 17#; - L _ (CmmT_SpecChar '^') -> cont 18#; - L _ (CmmT_SpecChar '|') -> cont 19#; - L _ (CmmT_SpecChar '>') -> cont 20#; - L _ (CmmT_SpecChar '<') -> cont 21#; - L _ (CmmT_SpecChar ',') -> cont 22#; - L _ (CmmT_SpecChar '!') -> cont 23#; - L _ (CmmT_DotDot) -> cont 24#; - L _ (CmmT_DoubleColon) -> cont 25#; - L _ (CmmT_Shr) -> cont 26#; - L _ (CmmT_Shl) -> cont 27#; - L _ (CmmT_Ge) -> cont 28#; - L _ (CmmT_Le) -> cont 29#; - L _ (CmmT_Eq) -> cont 30#; - L _ (CmmT_Ne) -> cont 31#; - L _ (CmmT_BoolAnd) -> cont 32#; - L _ (CmmT_BoolOr) -> cont 33#; - L _ (CmmT_CLOSURE) -> cont 34#; - L _ (CmmT_INFO_TABLE) -> cont 35#; - L _ (CmmT_INFO_TABLE_RET) -> cont 36#; - L _ (CmmT_INFO_TABLE_FUN) -> cont 37#; - L _ (CmmT_INFO_TABLE_CONSTR) -> cont 38#; - L _ (CmmT_INFO_TABLE_SELECTOR) -> cont 39#; - L _ (CmmT_else) -> cont 40#; - L _ (CmmT_export) -> cont 41#; - L _ (CmmT_section) -> cont 42#; - L _ (CmmT_goto) -> cont 43#; - L _ (CmmT_if) -> cont 44#; - L _ (CmmT_call) -> cont 45#; - L _ (CmmT_jump) -> cont 46#; - L _ (CmmT_foreign) -> cont 47#; - L _ (CmmT_never) -> cont 48#; - L _ (CmmT_prim) -> cont 49#; - L _ (CmmT_reserve) -> cont 50#; - L _ (CmmT_return) -> cont 51#; - L _ (CmmT_returns) -> cont 52#; - L _ (CmmT_import) -> cont 53#; - L _ (CmmT_switch) -> cont 54#; - L _ (CmmT_case) -> cont 55#; - L _ (CmmT_default) -> cont 56#; - L _ (CmmT_push) -> cont 57#; - L _ (CmmT_unwind) -> cont 58#; - L _ (CmmT_bits8) -> cont 59#; - L _ (CmmT_bits16) -> cont 60#; - L _ (CmmT_bits32) -> cont 61#; - L _ (CmmT_bits64) -> cont 62#; - L _ (CmmT_bits128) -> cont 63#; - L _ (CmmT_bits256) -> cont 64#; - L _ (CmmT_bits512) -> cont 65#; - L _ (CmmT_float32) -> cont 66#; - L _ (CmmT_float64) -> cont 67#; - L _ (CmmT_gcptr) -> cont 68#; - L _ (CmmT_GlobalReg happy_dollar_dollar) -> cont 69#; - L _ (CmmT_Name happy_dollar_dollar) -> cont 70#; - L _ (CmmT_String happy_dollar_dollar) -> cont 71#; - L _ (CmmT_Int happy_dollar_dollar) -> cont 72#; - L _ (CmmT_Float happy_dollar_dollar) -> cont 73#; - _ -> happyError' (tk, []) - }) - -happyError_ explist 74# tk = happyError' (tk, explist) -happyError_ explist _ tk = happyError' (tk, explist) - -happyThen :: () => PD a -> (a -> PD b) -> PD b -happyThen = (>>=) -happyReturn :: () => a -> PD a -happyReturn = (return) -happyParse :: () => Happy_GHC_Exts.Int# -> PD (HappyAbsSyn ) - -happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) - -happyDoAction :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) - -happyReduceArr :: () => Happy_Data_Array.Array Int (Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )) - -happyThen1 :: () => PD a -> (a -> PD b) -> PD b -happyThen1 = happyThen -happyReturn1 :: () => a -> PD a -happyReturn1 = happyReturn -happyError' :: () => ((Located CmmToken), [String]) -> PD a -happyError' tk = (\(tokens, explist) -> happyError) tk -cmmParse = happySomeParser where - happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut4 x)) - -happySeq = happyDontSeq - - -section :: String -> SectionType -section "text" = Text -section "data" = Data -section "rodata" = ReadOnlyData -section "relrodata" = RelocatableReadOnlyData -section "bss" = UninitialisedData -section s = OtherSection s - -mkString :: String -> CmmStatic -mkString s = CmmString (map (fromIntegral.ord) s) - --- | --- Given an info table, decide what the entry convention for the proc --- is. That is, for an INFO_TABLE_RET we want the return convention, --- otherwise it is a NativeNodeCall. --- -infoConv :: Maybe CmmInfoTable -> Convention -infoConv Nothing = NativeNodeCall -infoConv (Just info) - | isStackRep (cit_rep info) = NativeReturn - | otherwise = NativeNodeCall - --- mkMachOp infers the type of the MachOp from the type of its first --- argument. We assume that this is correct: for MachOps that don't have --- symmetrical args (e.g. shift ops), the first arg determines the type of --- the op. -mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr -mkMachOp fn args = do - dflags <- getDynFlags - arg_exprs <- sequence args - return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs) - -getLit :: CmmExpr -> CmmLit -getLit (CmmLit l) = l -getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r -getLit _ = panic "invalid literal" -- TODO messy failure - -nameToMachOp :: FastString -> PD (Width -> MachOp) -nameToMachOp name = - case lookupUFM machOps name of - Nothing -> fail ("unknown primitive " ++ unpackFS name) - Just m -> return m - -exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) -exprOp name args_code = do - dflags <- getDynFlags - case lookupUFM (exprMacros dflags) name of - Just f -> return $ do - args <- sequence args_code - return (f args) - Nothing -> do - mo <- nameToMachOp name - return $ mkMachOp mo args_code - -exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) -exprMacros dflags = listToUFM [ - ( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ), - ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ), - ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), - ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ), - ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ), - ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ), - ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ), - ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), - ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ), - ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x ) - ] - --- we understand a subset of C-- primitives: -machOps = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "add", MO_Add ), - ( "sub", MO_Sub ), - ( "eq", MO_Eq ), - ( "ne", MO_Ne ), - ( "mul", MO_Mul ), - ( "neg", MO_S_Neg ), - ( "quot", MO_S_Quot ), - ( "rem", MO_S_Rem ), - ( "divu", MO_U_Quot ), - ( "modu", MO_U_Rem ), - - ( "ge", MO_S_Ge ), - ( "le", MO_S_Le ), - ( "gt", MO_S_Gt ), - ( "lt", MO_S_Lt ), - - ( "geu", MO_U_Ge ), - ( "leu", MO_U_Le ), - ( "gtu", MO_U_Gt ), - ( "ltu", MO_U_Lt ), - - ( "and", MO_And ), - ( "or", MO_Or ), - ( "xor", MO_Xor ), - ( "com", MO_Not ), - ( "shl", MO_Shl ), - ( "shrl", MO_U_Shr ), - ( "shra", MO_S_Shr ), - - ( "fadd", MO_F_Add ), - ( "fsub", MO_F_Sub ), - ( "fneg", MO_F_Neg ), - ( "fmul", MO_F_Mul ), - ( "fquot", MO_F_Quot ), - - ( "feq", MO_F_Eq ), - ( "fne", MO_F_Ne ), - ( "fge", MO_F_Ge ), - ( "fle", MO_F_Le ), - ( "fgt", MO_F_Gt ), - ( "flt", MO_F_Lt ), - - ( "lobits8", flip MO_UU_Conv W8 ), - ( "lobits16", flip MO_UU_Conv W16 ), - ( "lobits32", flip MO_UU_Conv W32 ), - ( "lobits64", flip MO_UU_Conv W64 ), - - ( "zx16", flip MO_UU_Conv W16 ), - ( "zx32", flip MO_UU_Conv W32 ), - ( "zx64", flip MO_UU_Conv W64 ), - - ( "sx16", flip MO_SS_Conv W16 ), - ( "sx32", flip MO_SS_Conv W32 ), - ( "sx64", flip MO_SS_Conv W64 ), - - ( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode - ( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode - ( "f2i8", flip MO_FS_Conv W8 ), - ( "f2i16", flip MO_FS_Conv W16 ), - ( "f2i32", flip MO_FS_Conv W32 ), - ( "f2i64", flip MO_FS_Conv W64 ), - ( "i2f32", flip MO_SF_Conv W32 ), - ( "i2f64", flip MO_SF_Conv W64 ) - ] - -callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr])) -callishMachOps = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "write_barrier", (,) MO_WriteBarrier ), - ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ), - ( "memset", memcpyLikeTweakArgs MO_Memset ), - ( "memmove", memcpyLikeTweakArgs MO_Memmove ), - - ("prefetch0", (,) $ MO_Prefetch_Data 0), - ("prefetch1", (,) $ MO_Prefetch_Data 1), - ("prefetch2", (,) $ MO_Prefetch_Data 2), - ("prefetch3", (,) $ MO_Prefetch_Data 3), - - ( "popcnt8", (,) $ MO_PopCnt W8 ), - ( "popcnt16", (,) $ MO_PopCnt W16 ), - ( "popcnt32", (,) $ MO_PopCnt W32 ), - ( "popcnt64", (,) $ MO_PopCnt W64 ), - - ( "cmpxchg8", (,) $ MO_Cmpxchg W8 ), - ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ), - ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ), - ( "cmpxchg64", (,) $ MO_Cmpxchg W64 ) - - -- ToDo: the rest, maybe - -- edit: which rest? - -- also: how do we tell CMM Lint how to type check callish macops? - ] - where - memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr]) - memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument" - memcpyLikeTweakArgs op args@(_:_) = - (op align, args') - where - args' = init args - align = case last args of - CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger - e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e) - -- The alignment of memcpy-ish operations must be a - -- compile-time constant. We verify this here, passing it around - -- in the MO_* constructor. In order to do this, however, we - -- must intercept the arguments in primCall. - -parseSafety :: String -> PD Safety -parseSafety "safe" = return PlaySafe -parseSafety "unsafe" = return PlayRisky -parseSafety "interruptible" = return PlayInterruptible -parseSafety str = fail ("unrecognised safety: " ++ str) - -parseCmmHint :: String -> PD ForeignHint -parseCmmHint "ptr" = return AddrHint -parseCmmHint "signed" = return SignedHint -parseCmmHint str = fail ("unrecognised hint: " ++ str) - --- labels are always pointers, so we might as well infer the hint -inferCmmHint :: CmmExpr -> ForeignHint -inferCmmHint (CmmLit (CmmLabel _)) = AddrHint -inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint -inferCmmHint _ = NoHint - -isPtrGlobalReg Sp = True -isPtrGlobalReg SpLim = True -isPtrGlobalReg Hp = True -isPtrGlobalReg HpLim = True -isPtrGlobalReg CCCS = True -isPtrGlobalReg CurrentTSO = True -isPtrGlobalReg CurrentNursery = True -isPtrGlobalReg (VanillaReg _ VGcPtr) = True -isPtrGlobalReg _ = False - -happyError :: PD a -happyError = PD $ \_ s -> unP srcParseFail s - --- ----------------------------------------------------------------------------- --- Statement-level macros - -stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) -stmtMacro fun args_code = do - case lookupUFM stmtMacros fun of - Nothing -> fail ("unknown macro: " ++ unpackFS fun) - Just fcode -> return $ do - args <- sequence args_code - code (fcode args) - -stmtMacros :: UniqFM ([CmmExpr] -> FCode ()) -stmtMacros = listToUFM [ - ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), - ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), - - ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), - ( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ), - - -- completely generic heap and stack checks, for use in high-level cmm. - ( fsLit "HP_CHK_GEN", \[bytes] -> - heapStackCheckGen Nothing (Just bytes) ), - ( fsLit "STK_CHK_GEN", \[] -> - heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ), - - -- A stack check for a fixed amount of stack. Sounds a bit strange, but - -- we use the stack for a bit of temporary storage in a couple of primops - ( fsLit "STK_CHK_GEN_N", \[bytes] -> - heapStackCheckGen (Just bytes) Nothing ), - - -- A stack check on entry to a thunk, where the argument is the thunk pointer. - ( fsLit "STK_CHK_NP" , \[node] -> entryHeapCheck' False node 0 [] (return ())), - - ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), - ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), - - ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), - ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), - - ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), - ( fsLit "SET_HDR", \[ptr,info,ccs] -> - emitSetDynHdr ptr info ccs ), - ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> - tickyAllocPrim hdr goods slop ), - ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> - tickyAllocPAP goods slop ), - ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> - tickyAllocThunk goods slop ), - ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode reg ) - ] - -emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () -emitPushUpdateFrame sp e = do - dflags <- getDynFlags - emitUpdateFrame dflags sp mkUpdInfoLabel e - -pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () -pushStackFrame fields body = do - dflags <- getDynFlags - exprs <- sequence fields - updfr_off <- getUpdFrameOff - let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old - [] updfr_off exprs - emit g - withUpdFrameOff new_updfr_off body - -reserveStackFrame - :: CmmParse CmmExpr - -> CmmParse CmmReg - -> CmmParse () - -> CmmParse () -reserveStackFrame psize preg body = do - dflags <- getDynFlags - old_updfr_off <- getUpdFrameOff - reg <- preg - esize <- psize - let size = case constantFoldExpr dflags esize of - CmmLit (CmmInt n _) -> n - _other -> pprPanic "CmmParse: not a compile-time integer: " - (ppr esize) - let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size - emitAssign reg (CmmStackSlot Old frame) - withUpdFrameOff frame body - -profilingInfo dflags desc_str ty_str - = if not (gopt Opt_SccProfilingOn dflags) - then NoProfilingInfo - else ProfilingInfo (stringToWord8s desc_str) - (stringToWord8s ty_str) - -staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () -staticClosure pkg cl_label info payload - = do dflags <- getDynFlags - let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] - code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits - -foreignCall - :: String - -> [CmmParse (LocalReg, ForeignHint)] - -> CmmParse CmmExpr - -> [CmmParse (CmmExpr, ForeignHint)] - -> Safety - -> CmmReturnInfo - -> PD (CmmParse ()) -foreignCall conv_string results_code expr_code args_code safety ret - = do conv <- case conv_string of - "C" -> return CCallConv - "stdcall" -> return StdCallConv - _ -> fail ("unknown calling convention: " ++ conv_string) - return $ do - dflags <- getDynFlags - results <- sequence results_code - expr <- expr_code - args <- sequence args_code - let - expr' = adjCallTarget dflags conv expr args - (arg_exprs, arg_hints) = unzip args - (res_regs, res_hints) = unzip results - fc = ForeignConvention conv arg_hints res_hints ret - target = ForeignTarget expr' fc - _ <- code $ emitForeignCall safety res_regs target arg_exprs - return () - - -doReturn :: [CmmParse CmmExpr] -> CmmParse () -doReturn exprs_code = do - dflags <- getDynFlags - exprs <- sequence exprs_code - updfr_off <- getUpdFrameOff - emit (mkReturnSimple dflags exprs updfr_off) - -mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph -mkReturnSimple dflags actuals updfr_off = - mkReturn dflags e actuals updfr_off - where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off) - (gcWord dflags)) - -doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () -doRawJump expr_code vols = do - dflags <- getDynFlags - expr <- expr_code - updfr_off <- getUpdFrameOff - emit (mkRawJump dflags expr updfr_off vols) - -doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr] - -> [CmmParse CmmExpr] -> CmmParse () -doJumpWithStack expr_code stk_code args_code = do - dflags <- getDynFlags - expr <- expr_code - stk_args <- sequence stk_code - args <- sequence args_code - updfr_off <- getUpdFrameOff - emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args) - -doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] - -> CmmParse () -doCall expr_code res_code args_code = do - dflags <- getDynFlags - expr <- expr_code - args <- sequence args_code - ress <- sequence res_code - updfr_off <- getUpdFrameOff - c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] - emit c - -adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ] - -> CmmExpr --- On Windows, we have to add the '@N' suffix to the label when making --- a call with the stdcall calling convention. -adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args - | platformOS (targetPlatform dflags) == OSMinGW32 - = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) - where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e))) - -- c.f. CgForeignCall.emitForeignCall -adjCallTarget _ _ expr _ - = expr - -primCall - :: [CmmParse (CmmFormal, ForeignHint)] - -> FastString - -> [CmmParse CmmExpr] - -> PD (CmmParse ()) -primCall results_code name args_code - = case lookupUFM callishMachOps name of - Nothing -> fail ("unknown primitive " ++ unpackFS name) - Just f -> return $ do - results <- sequence results_code - args <- sequence args_code - let (p, args') = f args - code (emitPrimCall (map fst results) p args') - -doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse () -doStore rep addr_code val_code - = do dflags <- getDynFlags - addr <- addr_code - val <- val_code - -- if the specified store type does not match the type of the expr - -- on the rhs, then we insert a coercion that will cause the type - -- mismatch to be flagged by cmm-lint. If we don't do this, then - -- the store will happen at the wrong type, and the error will not - -- be noticed. - let val_width = typeWidth (cmmExprType dflags val) - rep_width = typeWidth rep - let coerce_val - | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] - | otherwise = val - emitStore addr coerce_val - --- ----------------------------------------------------------------------------- --- If-then-else and boolean expressions - -data BoolExpr - = BoolExpr `BoolAnd` BoolExpr - | BoolExpr `BoolOr` BoolExpr - | BoolNot BoolExpr - | BoolTest CmmExpr - --- ToDo: smart constructors which simplify the boolean expression. - -cmmIfThenElse cond then_part else_part = do - then_id <- newBlockId - join_id <- newBlockId - c <- cond - emitCond c then_id - else_part - emit (mkBranch join_id) - emitLabel then_id - then_part - -- fall through to join - emitLabel join_id - -cmmRawIf cond then_id = do - c <- cond - emitCond c then_id - --- 'emitCond cond true_id' emits code to test whether the cond is true, --- branching to true_id if so, and falling through otherwise. -emitCond (BoolTest e) then_id = do - else_id <- newBlockId - emit (mkCbranch e then_id else_id Nothing) - emitLabel else_id -emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id - | Just op' <- maybeInvertComparison op - = emitCond (BoolTest (CmmMachOp op' args)) then_id -emitCond (BoolNot e) then_id = do - else_id <- newBlockId - emitCond e else_id - emit (mkBranch then_id) - emitLabel else_id -emitCond (e1 `BoolOr` e2) then_id = do - emitCond e1 then_id - emitCond e2 then_id -emitCond (e1 `BoolAnd` e2) then_id = do - -- we'd like to invert one of the conditionals here to avoid an - -- extra branch instruction, but we can't use maybeInvertComparison - -- here because we can't look too closely at the expression since - -- we're in a loop. - and_id <- newBlockId - else_id <- newBlockId - emitCond e1 and_id - emit (mkBranch else_id) - emitLabel and_id - emitCond e2 then_id - emitLabel else_id - --- ----------------------------------------------------------------------------- --- Source code notes - --- | Generate a source note spanning from "a" to "b" (inclusive), then --- proceed with parsing. This allows debugging tools to reason about --- locations in Cmm code. -withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c -withSourceNote a b parse = do - name <- getName - case combineSrcSpans (getLoc a) (getLoc b) of - RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse - _other -> parse - --- ----------------------------------------------------------------------------- --- Table jumps - --- We use a simplified form of C-- switch statements for now. A --- switch statement always compiles to a table jump. Each arm can --- specify a list of values (not ranges), and there can be a single --- default branch. The range of the table is given either by the --- optional range on the switch (eg. switch [0..7] {...}), or by --- the minimum/maximum values from the branches. - -doSwitch :: Maybe (Integer,Integer) - -> CmmParse CmmExpr - -> [([Integer],Either BlockId (CmmParse ()))] - -> Maybe (CmmParse ()) -> CmmParse () -doSwitch mb_range scrut arms deflt - = do - -- Compile code for the default branch - dflt_entry <- - case deflt of - Nothing -> return Nothing - Just e -> do b <- forkLabelledCode e; return (Just b) - - -- Compile each case branch - table_entries <- mapM emitArm arms - let table = M.fromList (concat table_entries) - - dflags <- getDynFlags - let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range - - expr <- scrut - -- ToDo: check for out of range and jump to default if necessary - emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table) - where - emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)] - emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] - emitArm (ints,Right code) = do - blockid <- forkLabelledCode code - return [ (i,blockid) | i <- ints ] - -forkLabelledCode :: CmmParse () -> CmmParse BlockId -forkLabelledCode p = do - (_,ag) <- getCodeScoped p - l <- newBlockId - emitOutOfLine l ag - return l - --- ----------------------------------------------------------------------------- --- Putting it all together - --- The initial environment: we define some constants that the compiler --- knows about here. -initEnv :: DynFlags -> Env -initEnv dflags = listToUFM [ - ( fsLit "SIZEOF_StgHeader", - VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )), - ( fsLit "SIZEOF_StgInfoTable", - VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) )) - ] - -parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) -parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do - buf <- hGetStringBuffer filename - let - init_loc = mkRealSrcLoc (mkFastString filename) 1 1 - init_state = (mkPState dflags buf init_loc) { lex_state = [0] } - -- reset the lex_state: the Lexer monad leaves some stuff - -- in there we don't want. - case unPD cmmParse dflags init_state of - PFailed span err -> do - let msg = mkPlainErrMsg dflags span err - return ((emptyBag, unitBag msg), Nothing) - POk pst code -> do - st <- initC - let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return () - (cmm,_) = runC dflags no_module st fcode - let ms = getMessages pst dflags - if (errorsFound dflags ms) - then return (ms, Nothing) - else return (ms, Just cmm) - where - no_module = panic "parseCmmFile: no module" -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 10 "" #-} -# 1 "/usr/include/stdc-predef.h" 1 3 4 - -# 17 "/usr/include/stdc-predef.h" 3 4 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -{-# LINE 10 "" #-} -{-# LINE 1 "/opt/ghc/8.2.2/lib/ghc-8.2.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - -{-# LINE 10 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - - - - - - - - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) -#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) -#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) -#else -#define LT(n,m) (n Happy_GHC_Exts.<# m) -#define GTE(n,m) (n Happy_GHC_Exts.>=# m) -#define EQ(n,m) (n Happy_GHC_Exts.==# m) -#endif -{-# LINE 43 "templates/GenericTemplate.hs" #-} - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - - - -{-# LINE 65 "templates/GenericTemplate.hs" #-} - -{-# LINE 75 "templates/GenericTemplate.hs" #-} - -{-# LINE 84 "templates/GenericTemplate.hs" #-} - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail (happyExpListPerState ((Happy_GHC_Exts.I# (st)) :: Int)) i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = happyAdjustOffset (indexShortOffAddr happyActOffsets st) - off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) - then EQ(indexShortOffAddr happyCheck off_i, i) - else False - action - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# - - - - -{-# INLINE happyLt #-} -happyLt x y = LT(x,y) - - -readArrayBit arr bit = - Bits.testBit (Happy_GHC_Exts.I# (indexShortOffAddr arr ((unbox_int bit) `Happy_GHC_Exts.iShiftRA#` 4#))) (bit `mod` 16) - where unbox_int (Happy_GHC_Exts.I# x) = x - - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - -{-# LINE 180 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk - - off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st1) - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st) - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail explist 0# tk old_st _ stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "failing" $ - happyError_ explist i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail explist i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. diff --git a/dist/build/Lexer.hs b/dist/build/Lexer.hs deleted file mode 100644 --- a/dist/build/Lexer.hs +++ /dev/null @@ -1,3357 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} -{-# LANGUAGE CPP,MagicHash #-} -{-# LINE 43 "parser/Lexer.x" #-} - -{-# LANGUAGE BangPatterns #-} - --- See Note [Warnings in code generated by Alex] in compiler/parser/Lexer.x -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -{-# OPTIONS_GHC -funbox-strict-fields #-} - -module Lexer ( - Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..), - P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getSrcLoc, - getPState, extopt, withThisPackage, - failLocMsgP, failSpanMsgP, srcParseFail, - getMessages, - popContext, pushModuleContext, setLastToken, setSrcLoc, - activeContext, nextIsEOF, - getLexState, popLexState, pushLexState, - extension, bangPatEnabled, datatypeContextsEnabled, - traditionalRecordSyntaxEnabled, - explicitForallEnabled, - inRulePrag, - explicitNamespacesEnabled, - patternSynonymsEnabled, - sccProfilingOn, hpcEnabled, - addWarning, - lexTokenStream, - addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn, - commentToAnnotation, - moveAnnotations - ) where - --- base -import Control.Monad -#if __GLASGOW_HASKELL__ > 710 -import Control.Monad.Fail -#endif -import Data.Bits -import Data.Char -import Data.List -import Data.Maybe -import Data.Word - -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - --- ghc-boot -import qualified GHC.LanguageExtensions as LangExt - --- bytestring -import Data.ByteString (ByteString) - --- containers -import Data.Map (Map) -import qualified Data.Map as Map - --- compiler/utils -import Bag -import Outputable -import StringBuffer -import FastString -import UniqFM -import Util ( readRational ) - --- compiler/main -import ErrUtils -import DynFlags - --- compiler/basicTypes -import SrcLoc -import Module -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..), - SourceText(..) ) - --- compiler/parser -import Ctype - -import ApiAnnotation - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#elif defined(__GLASGOW_HASKELL__) -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -import Data.Array.Base (unsafeAt) -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif -alex_tab_size :: Int -alex_tab_size = 8 -alex_base :: AlexAddr -alex_base = AlexA# - "\x01\x00\x00\x00\x7b\x00\x00\x00\x84\x00\x00\x00\xa0\x00\x00\x00\xbc\x00\x00\x00\xc5\x00\x00\x00\xce\x00\x00\x00\xec\x00\x00\x00\x06\x01\x00\x00\x0b\x01\x00\x00\x06\x02\x00\x00\x20\x02\x00\x00\x25\x02\x00\x00\x62\x02\x00\x00\xd4\xff\xff\xff\x61\x00\x00\x00\xd7\xff\xff\xff\xdb\xff\xff\xff\xa4\xff\xff\xff\xaa\xff\xff\xff\xdf\x02\x00\x00\x59\x03\x00\x00\xd3\x03\x00\x00\x93\xff\xff\xff\x94\xff\xff\xff\x4d\x04\x00\x00\x95\xff\xff\xff\x48\x04\x00\x00\xc8\x04\x00\x00\x48\x05\x00\x00\xc8\x05\x00\x00\x48\x06\x00\x00\xb2\xff\xff\xff\xc8\x06\x00\x00\xe7\xff\xff\xff\xe8\xff\xff\xff\xe9\xff\xff\xff\x48\x07\x00\x00\xc8\x07\x00\x00\x48\x08\x00\x00\xc8\x08\x00\x00\x48\x09\x00\x00\xae\xff\xff\xff\xc8\x09\x00\x00\xab\xff\xff\xff\x48\x0a\x00\x00\xb0\xff\xff\xff\xc8\x0a\x00\x00\x22\x01\x00\x00\x41\x01\x00\x00\x48\x0b\x00\x00\xb3\xff\xff\xff\xc8\x0b\x00\x00\xba\xff\xff\xff\xac\xff\xff\xff\x00\x00\x00\x00\x39\x0c\x00\x00\x00\x00\x00\x00\xaa\x0c\x00\x00\xa9\x0d\x00\x00\x00\x00\x00\x00\x95\x0d\x00\x00\x00\x00\x00\x00\xd6\x0d\x00\x00\x00\x00\x00\x00\x17\x0e\x00\x00\x00\x00\x00\x00\x88\x0e\x00\x00\x00\x00\x00\x00\xf9\x0e\x00\x00\x00\x00\x00\x00\x6a\x0f\x00\x00\x00\x00\x00\x00\xdb\x0f\x00\x00\x00\x00\x00\x00\x4c\x10\x00\x00\x4b\x11\x00\x00\x00\x00\x00\x00\x07\x11\x00\x00\xaf\xff\xff\xff\x07\x12\x00\x00\xc7\x11\x00\x00\x00\x00\x00\x00\xc7\x12\x00\x00\x87\x12\x00\x00\x00\x00\x00\x00\xb1\xff\xff\xff\x00\x00\x00\x00\xc8\x12\x00\x00\x00\x00\x00\x00\x09\x13\x00\x00\x00\x00\x00\x00\x4a\x13\x00\x00\x00\x00\x00\x00\x8b\x13\x00\x00\x00\x00\x00\x00\xcc\x13\x00\x00\xd1\x00\x00\x00\x1f\x01\x00\x00\xe4\x01\x00\x00\x23\x02\x00\x00\x40\x02\x00\x00\x60\x02\x00\x00\x82\x0d\x00\x00\x62\x00\x00\x00\x51\x00\x00\x00\x1e\x11\x00\x00\x29\x01\x00\x00\x5a\x00\x00\x00\xcb\x14\x00\x00\x25\x15\x00\x00\xa3\x15\x00\x00\x1f\x16\x00\x00\x9b\x16\x00\x00\x17\x17\x00\x00\x93\x17\x00\x00\x0f\x18\x00\x00\x78\x00\x00\x00\x8b\x18\x00\x00\x0a\x19\x00\x00\xca\x18\x00\x00\x00\x00\x00\x00\xc9\x19\x00\x00\xc8\x19\x00\x00\xbe\x1a\x00\x00\xbe\x1b\x00\x00\x09\x1a\x00\x00\x00\x00\x00\x00\x3e\x1c\x00\x00\xfe\x1b\x00\x00\x00\x00\x00\x00\xfe\x1c\x00\x00\xbe\x1c\x00\x00\x00\x00\x00\x00\xbe\x1d\x00\x00\x7e\x1d\x00\x00\x00\x00\x00\x00\x7e\x1e\x00\x00\x3e\x1e\x00\x00\x00\x00\x00\x00\x5d\x01\x00\x00\x39\x1f\x00\x00\x00\x00\x00\x00\x2f\x20\x00\x00\xe1\x02\x00\x00\x5b\x03\x00\x00\xf9\xff\xff\xff\x25\x21\x00\x00\x1b\x22\x00\x00\x11\x23\x00\x00\x07\x24\x00\x00\xfd\x24\x00\x00\xf3\x25\x00\x00\xe9\x26\x00\x00\xe5\x27\x00\x00\xe1\x28\x00\x00\xdd\x29\x00\x00\xd9\x2a\x00\x00\xd5\x2b\x00\x00\xd1\x2c\x00\x00\xcd\x2d\x00\x00\xc3\x2e\x00\x00\xb9\x2f\x00\x00\xaf\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x1f\x00\x00\xaf\x31\x00\x00\xa3\x32\x00\x00\x1d\x33\x00\x00\xbd\x02\x00\x00\x97\x33\x00\x00\x0c\x34\x00\x00\x02\x35\x00\x00\x02\x36\x00\x00\x78\x36\x00\x00\x37\x03\x00\x00\x77\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x37\x00\x00\x00\x00\x00\x00\x6f\x38\x00\x00\xe9\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x39\x00\x00\xdd\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x3a\x00\x00\xf1\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\xc7\x3b\x00\x00\x41\x3c\x00\x00\xbb\x3c\x00\x00\x35\x3d\x00\x00\xaf\x3d\x00\x00\x29\x3e\x00\x00\xa3\x3e\x00\x00\x1d\x3f\x00\x00\x80\x00\x00\x00\x83\x00\x00\x00\x8b\x00\x00\x00\x8c\x00\x00\x00\x77\x3f\x00\x00\x9a\x3f\x00\x00\xf6\x3f\x00\x00\x19\x40\x00\x00\x3c\x40\x00\x00\x64\x40\x00\x00\xa7\x40\x00\x00\xcc\x40\x00\x00\x45\x41\x00\x00\xbe\x41\x00\x00\x37\x42\x00\x00\x93\x42\x00\x00\xb8\x42\x00\x00\xc9\x03\x00\x00\x17\x20\x00\x00\x9b\x00\x00\x00\x2e\x04\x00\x00\x7d\x15\x00\x00\x43\x04\x00\x00\x0d\x21\x00\x00\xb1\x00\x00\x00\x35\x11\x00\x00\x03\x22\x00\x00\xc3\x14\x00\x00\xab\x14\x00\x00\x34\x1f\x00\x00\xb7\x14\x00\x00\x8d\x00\x00\x00\x8f\x00\x00\x00\x90\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# - "\x00\x00\x92\x00\xed\x00\xeb\x00\x9b\x00\xf9\x00\x8c\x00\xd3\x00\x9c\x00\xa5\x00\x8e\x00\xae\x00\x8c\x00\x8c\x00\x8c\x00\xab\x00\xbb\x00\xbc\x00\xbe\x00\x7c\x00\x17\x00\x18\x00\x1a\x00\x56\x00\x20\x00\x4f\x00\x2c\x00\x33\x00\x14\x00\x13\x00\x35\x00\x12\x00\x92\x00\x8c\x00\xf9\x00\x1d\x01\xfa\x00\xfd\x00\xf9\x00\xf9\x00\x1c\x01\xdc\x00\xdd\x00\xf9\x00\xf9\x00\xe1\x00\xf5\x00\xf9\x00\xf9\x00\x01\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\xfe\x00\xe2\x00\xf9\x00\xf9\x00\xf9\x00\xfb\x00\xd4\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xdf\x00\xf9\x00\xe0\x00\xf9\x00\xeb\x00\xe3\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xe5\x00\xf7\x00\xe6\x00\xf9\x00\x8c\x00\x07\x01\x07\x01\x2e\x00\x8e\x00\xa4\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x02\x01\x02\x01\xc5\x00\x8e\x00\x9c\x00\x8c\x00\x8c\x00\x8c\x00\x08\x01\x08\x01\x08\x01\x08\x01\x08\x01\x08\x01\x08\x01\x08\x01\xc7\x00\x8c\x00\xc1\x00\x90\x00\xa6\x00\x91\x00\x7b\x00\xd9\x00\xc1\x00\xef\x00\x8c\x00\x8c\x00\xf0\x00\x00\x00\x11\x00\x8e\x00\xaa\x00\x8c\x00\x8c\x00\x8c\x00\xf1\x00\xf2\x00\x16\x01\x11\x00\x17\x01\x18\x01\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x0f\x01\x19\x01\x8c\x00\x8c\x00\x1b\x01\xac\x00\x00\x00\x8e\x00\xaa\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x02\x01\x02\x01\x11\x00\x8e\x00\xaa\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x13\x01\x00\x00\xc1\x00\x8e\x00\x00\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x00\x00\xbb\x00\xac\x00\x00\x00\x07\x01\x07\x01\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\xac\x00\x11\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x8c\x00\x36\x00\x00\x00\x8c\x00\x11\x00\x00\x00\xc1\x00\x8e\x00\x0e\x00\x8c\x00\x8c\x00\x8c\x00\xd5\x00\x11\x00\x62\x00\x00\x00\x62\x00\x0e\x00\x00\x00\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x8c\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8d\x00\x8c\x00\x8c\x00\x8c\x00\x8f\x00\xff\xff\x8d\x00\x8d\x00\x8d\x00\x11\x00\x00\x00\xa9\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\x8c\x00\x30\x00\x7a\x00\x00\x00\x00\x00\x8d\x00\x30\x00\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xad\x00\x30\x00\x00\x00\x00\x00\x23\x00\x30\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x30\x00\x30\x00\x30\x00\x30\x00\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x03\x01\x03\x01\x03\x01\x03\x01\x03\x01\x03\x01\x03\x01\x03\x01\x30\x00\x8c\x00\x00\x00\x23\x00\x00\x00\x00\x00\x0e\x00\x8c\x00\x8c\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x78\x00\x21\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4e\x00\x2f\x00\x3c\x00\x3c\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x8c\x00\x8c\x00\x8c\x00\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8e\x00\x00\x00\x8c\x00\x8c\x00\x8c\x00\x11\x00\x00\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x8c\x00\x00\x00\x76\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x65\x00\x00\x00\x65\x00\x00\x00\x0f\x00\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\xec\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x8e\x00\xae\x00\x8c\x00\x8c\x00\x8c\x00\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x8c\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\xdd\x00\x00\x00\x00\x00\xe1\x00\x10\x00\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x00\x00\x0e\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xde\x00\x00\x00\xe0\x00\x00\x00\xec\x00\xe3\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xe4\x00\x00\x00\xe6\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x75\x00\x00\x00\x00\x00\xbf\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xc1\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xb1\x00\xb1\x00\xb1\x00\xc1\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x75\x00\x00\x00\x00\x00\xc0\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xc1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb2\x00\xb2\x00\xb2\x00\xc1\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x64\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xbd\x00\xbd\x00\xbd\x00\x10\x01\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x03\x01\x03\x01\x03\x01\x03\x01\x03\x01\x03\x01\x03\x01\x03\x01\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\x61\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x00\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\x89\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x86\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x83\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x80\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x7d\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x77\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x1b\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x1c\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x1d\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x1e\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x1f\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x53\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x50\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x21\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x2b\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x2d\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x6f\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x14\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x08\x01\x08\x01\x08\x01\x08\x01\x08\x01\x08\x01\x08\x01\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xe8\x00\x1a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x00\x00\x1a\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x0d\x01\x00\x00\x00\x00\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xe9\x00\xe7\x00\x64\x00\xf3\x00\xe8\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xf3\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\xf3\x00\xf3\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\xf3\x00\x00\x00\xf3\x00\xe7\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x11\x01\xf3\x00\x00\x00\xf3\x00\x6f\x00\x6f\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x00\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x00\x00\xd2\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\xd1\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\xca\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\xc9\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\xc8\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\xc6\x00\x76\x00\x76\x00\x76\x00\x76\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x76\x00\xba\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x7a\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x7a\x00\xb4\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x51\x00\x2d\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3f\x00\x34\x00\x37\x00\x37\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x54\x00\x2b\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x41\x00\x32\x00\x39\x00\x39\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\xff\xff\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x01\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\x0c\x01\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x61\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x78\x00\x21\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4e\x00\x2f\x00\x3c\x00\x3c\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x78\x00\x21\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4e\x00\x2f\x00\x3c\x00\x3c\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x78\x00\x21\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4e\x00\x2f\x00\x3c\x00\x3c\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x09\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8a\x00\x1b\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x60\x00\x25\x00\x4a\x00\x4a\x00\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x86\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x87\x00\x1c\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5e\x00\x26\x00\x48\x00\x48\x00\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x83\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x84\x00\x1d\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5c\x00\x27\x00\x46\x00\x46\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x81\x00\x1e\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x5a\x00\x28\x00\x44\x00\x44\x00\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x83\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x84\x00\x1d\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5c\x00\x27\x00\x46\x00\x46\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7e\x00\x1f\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x58\x00\x29\x00\x42\x00\x42\x00\x42\x00\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x9a\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7e\x00\x1f\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x58\x00\x29\x00\x42\x00\x42\x00\x42\x00\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x9a\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x86\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x87\x00\x1c\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5e\x00\x26\x00\x48\x00\x48\x00\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x9a\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x86\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x87\x00\x1c\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5e\x00\x26\x00\x48\x00\x48\x00\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xb8\x00\x00\x00\x9d\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb8\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7e\x00\x1f\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x58\x00\x29\x00\x42\x00\x42\x00\x42\x00\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xb8\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xb8\x00\x00\x00\x9d\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb8\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x86\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x87\x00\x1c\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5e\x00\x26\x00\x48\x00\x48\x00\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\xf9\x00\xf9\x00\x00\x00\x9f\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7e\x00\x1f\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x58\x00\x29\x00\x42\x00\x42\x00\x42\x00\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\xf9\x00\xf9\x00\x00\x00\x9f\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x86\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x87\x00\x1c\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5e\x00\x26\x00\x48\x00\x48\x00\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8a\x00\x1b\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x60\x00\x25\x00\x4a\x00\x4a\x00\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8a\x00\x1b\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x60\x00\x25\x00\x4a\x00\x4a\x00\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8a\x00\x1b\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x60\x00\x25\x00\x4a\x00\x4a\x00\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb8\x00\xb0\x00\xb0\x00\xb0\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb0\x00\xb8\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x78\x00\x21\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4e\x00\x2f\x00\x3c\x00\x3c\x00\x3c\x00\x3d\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x7a\x00\xb4\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x78\x00\x21\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4e\x00\x2f\x00\x3c\x00\x3c\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x78\x00\x21\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4e\x00\x2f\x00\x3c\x00\x3c\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb8\x00\xb0\x00\xb0\x00\xb0\x00\xb8\x00\xb7\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x14\x00\xb7\x00\xb7\x00\xb7\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb7\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb0\x00\xb8\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x78\x00\x21\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4e\x00\x2f\x00\x3c\x00\x3c\x00\x3c\x00\x3d\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x79\x00\x78\x00\x21\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4e\x00\x2f\x00\x3c\x00\x3c\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x76\x00\x76\x00\x76\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x76\x00\xba\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\xbd\x00\xbd\x00\xbd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x00\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\xf9\x00\xce\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\xf9\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xd7\x00\xd7\x00\xd7\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\x00\x00\x00\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd8\x00\xd8\x00\xd8\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\x3b\x00\x70\x00\x00\x00\x00\x00\xd8\x00\x00\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x70\x00\x70\x00\x70\x00\x72\x00\x74\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x73\x00\x70\x00\x70\x00\x70\x00\x71\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\xc4\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xea\x00\xea\x00\xea\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xec\x00\xec\x00\xec\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xed\x00\xed\x00\xed\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xed\x00\xee\x00\xee\x00\xee\x00\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\x00\x00\x00\x00\x00\x00\xf3\x00\xee\x00\x00\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xee\x00\xf3\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf4\x00\x00\x00\x00\x00\xf3\x00\xf3\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\xf4\x00\xf4\x00\xf4\x00\xf4\x00\x00\x00\x00\x00\x00\x00\xf4\x00\xf4\x00\x00\x00\xf4\x00\xf4\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\xf4\x00\xf3\x00\xf4\x00\xf4\x00\xf4\x00\xf4\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\xf3\x00\xf4\x00\x00\x00\xf4\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\xf9\x00\xf4\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\xf9\x00\xf9\x00\x00\x00\xa0\x00\xf9\x00\xf9\x00\x06\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\x05\x01\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\xf9\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\xd6\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\xf9\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\xf9\x00\xbe\x00\xf9\x00\xf9\x00\xcb\x00\xf9\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\xcc\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xd8\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\xda\x00\xf9\x00\xf9\x00\x00\x00\xf6\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xd8\x00\x00\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd7\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\xf9\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xd7\x00\x00\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xce\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\xd0\x00\x00\x00\xf9\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xce\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xcd\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xfc\x00\xf9\x00\xf9\x00\x00\x00\xcf\x00\x00\x00\xf9\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\xf9\x00\xcd\x00\xff\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\xf9\x00\xff\x00\xf9\x00\xff\x00\xff\x00\xff\x00\xff\x00\x00\x00\x00\x00\xff\x00\xff\x00\xff\x00\x00\x00\xff\x00\xff\x00\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x00\x00\x00\xff\x00\xff\x00\xff\x00\xff\x00\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x00\x00\x00\xff\x00\xff\x00\xff\x00\xff\x00\x00\x00\x00\x00\x00\x00\xff\x00\xff\x00\x00\x00\xff\x00\xff\x00\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x00\xc3\x00\xff\x00\xff\x00\x00\x00\xff\x00\xff\x00\xff\x00\xff\x00\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x00\x00\x00\xff\x00\x00\x00\x00\x00\xff\x00\x00\x00\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x00\x00\x00\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# - "\xff\xff\x2d\x00\x01\x00\x02\x00\x2d\x00\x04\x00\x05\x00\x06\x00\x2d\x00\x65\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x65\x00\x7d\x00\x7d\x00\x7d\x00\x61\x00\x2d\x00\x2d\x00\x2d\x00\x69\x00\x6d\x00\x69\x00\x67\x00\x61\x00\x23\x00\x6e\x00\x72\x00\x6e\x00\x2d\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\x30\x00\x31\x00\x6c\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x30\x00\x31\x00\x7c\x00\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x7c\x00\x20\x00\x24\x00\x2d\x00\x23\x00\x2d\x00\x21\x00\x23\x00\x2a\x00\x23\x00\x20\x00\x05\x00\x23\x00\xff\xff\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x23\x00\x23\x00\x23\x00\x2d\x00\x23\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x23\x00\x23\x00\x20\x00\x05\x00\x23\x00\x23\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x30\x00\x31\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x23\x00\xff\xff\x5e\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x20\x00\xff\xff\x7d\x00\x23\x00\xff\xff\x30\x00\x31\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x2d\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x20\x00\x70\x00\xff\xff\x05\x00\x2d\x00\xff\xff\x7c\x00\x09\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\x7c\x00\x2d\x00\x2b\x00\xff\xff\x2d\x00\x7b\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x05\x00\x20\x00\xff\xff\xff\xff\x09\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\xff\xff\x7b\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\x05\x00\x22\x00\xff\xff\xff\xff\x20\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x20\x00\xff\xff\xff\xff\x23\x00\x05\x00\xff\xff\xff\xff\x7b\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x20\x00\x05\x00\xff\xff\x23\x00\xff\xff\xff\xff\x7b\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x00\x20\x00\xff\xff\xff\xff\x09\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\x2b\x00\xff\xff\x2d\x00\xff\xff\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x7b\x00\xff\xff\x3b\x00\xff\xff\xff\xff\x7b\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\x7d\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x5e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x7c\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x5e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x7c\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\x02\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\x02\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x65\x00\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x05\x00\x01\x00\x02\x00\x03\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x42\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x42\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x02\x00\xff\xff\x04\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x02\x00\x7c\x00\x04\x00\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x02\x00\x7c\x00\x04\x00\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x02\x00\x7c\x00\x04\x00\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x04\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# - "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3e\x00\x40\x00\x40\x00\xff\xff\x4d\x00\x4d\x00\x52\x00\x52\x00\x55\x00\x55\x00\x57\x00\x57\x00\x59\x00\x59\x00\x5b\x00\x5b\x00\x5d\x00\x5d\x00\x5f\x00\x5f\x00\xff\xff\x79\x00\x79\x00\xff\xff\x7b\x00\x7b\x00\x7b\x00\x7c\x00\x7c\x00\x7c\x00\xff\xff\x7f\x00\x7f\x00\x82\x00\x82\x00\x85\x00\x85\x00\x88\x00\x88\x00\x8b\x00\x8b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb8\x00\xb8\x00\xb8\x00\xff\xff\x7b\x00\x7c\x00\x99\x00\x99\x00\x99\x00\x97\x00\x97\x00\x97\x00\x96\x00\x96\x00\x96\x00\x95\x00\x95\x00\x95\x00\x94\x00\x94\x00\x94\x00\xff\xff\xb8\x00\xff\xff\xb8\x00\xff\xff\xff\xff\xff\xff\xb8\x00\x94\x00\x95\x00\x96\x00\x97\x00\x96\x00\x99\x00\x99\x00\x95\x00\x95\x00\x99\x00\x95\x00\x99\x00\x95\x00\x94\x00\x94\x00\x94\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb8\x00\xb8\x00\xff\xff\xb8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0 :: Int, 285) - [ AlexAccNone - , AlexAcc 168 - , AlexAccNone - , AlexAcc 167 - , AlexAcc 166 - , AlexAcc 165 - , AlexAcc 164 - , AlexAccNone - , AlexAccNone - , AlexAcc 163 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccSkip - , AlexAccSkip - , AlexAcc 162 - , AlexAcc 161 - , AlexAccPred 160 ( isNormalComment )(AlexAccNone) - , AlexAccPred 159 ( isNormalComment )(AlexAccNone) - , AlexAccPred 158 ( isNormalComment )(AlexAccNone) - , AlexAccPred 157 ( isNormalComment )(AlexAcc 156) - , AlexAcc 155 - , AlexAcc 154 - , AlexAccPred 153 ( ifExtension (not . haddockEnabled) )(AlexAccNone) - , AlexAccPred 152 ( ifExtension (not . haddockEnabled) )(AlexAcc 151) - , AlexAccPred 150 ( ifExtension (not . haddockEnabled) )(AlexAccPred 149 ( ifExtension haddockEnabled )(AlexAccNone)) - , AlexAcc 148 - , AlexAccPred 147 ( atEOL )(AlexAccNone) - , AlexAccPred 146 ( atEOL )(AlexAccNone) - , AlexAccPred 145 ( atEOL )(AlexAccNone) - , AlexAccPred 144 ( atEOL )(AlexAcc 143) - , AlexAccPred 142 ( atEOL )(AlexAcc 141) - , AlexAccPred 140 ( atEOL )(AlexAcc 139) - , AlexAccPred 138 ( atEOL )(AlexAcc 137) - , AlexAccPred 136 ( atEOL )(AlexAccNone) - , AlexAccPred 135 ( atEOL )(AlexAccNone) - , AlexAccPred 134 ( atEOL )(AlexAcc 133) - , AlexAccSkip - , AlexAccPred 132 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccPred 131 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False) `alexAndPred` followedByDigit )(AlexAccNone) - , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccPred 130 ( notFollowedBy '-' )(AlexAccNone) - , AlexAccSkip - , AlexAccPred 129 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccPred 128 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccPred 127 ( notFollowedBySymbol )(AlexAccNone) - , AlexAcc 126 - , AlexAccPred 125 ( known_pragma linePrags )(AlexAccNone) - , AlexAccPred 124 ( known_pragma linePrags )(AlexAcc 123) - , AlexAccPred 122 ( known_pragma linePrags )(AlexAccPred 121 ( known_pragma oneWordPrags )(AlexAccPred 120 ( known_pragma ignoredPrags )(AlexAccPred 119 ( known_pragma fileHeaderPrags )(AlexAccNone)))) - , AlexAccPred 118 ( known_pragma linePrags )(AlexAccPred 117 ( known_pragma oneWordPrags )(AlexAccPred 116 ( known_pragma ignoredPrags )(AlexAccPred 115 ( known_pragma fileHeaderPrags )(AlexAccNone)))) - , AlexAcc 114 - , AlexAcc 113 - , AlexAcc 112 - , AlexAcc 111 - , AlexAcc 110 - , AlexAcc 109 - , AlexAcc 108 - , AlexAcc 107 - , AlexAcc 106 - , AlexAcc 105 - , AlexAccPred 104 ( known_pragma twoWordPrags )(AlexAccNone) - , AlexAcc 103 - , AlexAcc 102 - , AlexAcc 101 - , AlexAccPred 100 ( ifExtension haddockEnabled )(AlexAccNone) - , AlexAccPred 99 ( ifExtension parrEnabled )(AlexAccNone) - , AlexAccPred 98 ( ifExtension parrEnabled )(AlexAccNone) - , AlexAccPred 97 ( ifExtension thQuotesEnabled )(AlexAccNone) - , AlexAccPred 96 ( ifExtension thQuotesEnabled )(AlexAccNone) - , AlexAccPred 95 ( ifExtension thQuotesEnabled )(AlexAccPred 94 ( ifExtension qqEnabled )(AlexAccNone)) - , AlexAccPred 93 ( ifExtension thQuotesEnabled )(AlexAccNone) - , AlexAccPred 92 ( ifExtension thQuotesEnabled )(AlexAccPred 91 ( ifExtension qqEnabled )(AlexAccNone)) - , AlexAccPred 90 ( ifExtension thQuotesEnabled )(AlexAccPred 89 ( ifExtension qqEnabled )(AlexAccNone)) - , AlexAccPred 88 ( ifExtension thQuotesEnabled )(AlexAccPred 87 ( ifExtension qqEnabled )(AlexAccNone)) - , AlexAccPred 86 ( ifExtension thQuotesEnabled )(AlexAccNone) - , AlexAccPred 85 ( ifExtension thQuotesEnabled )(AlexAccNone) - , AlexAccPred 84 ( ifExtension thEnabled )(AlexAccNone) - , AlexAccPred 83 ( ifExtension thEnabled )(AlexAccNone) - , AlexAccPred 82 ( ifExtension thEnabled )(AlexAccNone) - , AlexAccPred 81 ( ifExtension thEnabled )(AlexAccNone) - , AlexAccPred 80 ( ifExtension qqEnabled )(AlexAccNone) - , AlexAccPred 79 ( ifExtension qqEnabled )(AlexAccNone) - , AlexAccPred 78 ( ifCurrentChar '⟦' `alexAndPred` - ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) )(AlexAccPred 77 ( ifCurrentChar '⟧' `alexAndPred` - ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) )(AlexAccPred 76 ( ifCurrentChar '⦇' `alexAndPred` - ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) )(AlexAccPred 75 ( ifCurrentChar '⦈' `alexAndPred` - ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) )(AlexAccNone)))) - , AlexAccPred 74 (alexPrevCharMatches(\c -> True && c < '\SOH' || c > '\ETX' && c < '\a' || c > '\a' && c < '\n' || c > '\n' && c < '\'' || c > '\'' && c < ')' || c > ')' && c < '0' || c > '9' && c < 'A' || c > 'Z' && c < '_' || c > '_' && c < 'a' || c > 'z' && True || False) `alexAndPred` ifExtension typeApplicationEnabled `alexAndPred` notFollowedBySymbol )(AlexAcc 73) - , AlexAccPred 72 ( ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol )(AlexAccNone) - , AlexAccPred 71 ( ifExtension arrowsEnabled )(AlexAccNone) - , AlexAccPred 70 ( ifExtension ipEnabled )(AlexAccNone) - , AlexAccPred 69 ( ifExtension overloadedLabelsEnabled )(AlexAccNone) - , AlexAccPred 68 ( orExtensions unboxedTuplesEnabled unboxedSumsEnabled )(AlexAccNone) - , AlexAccPred 67 ( orExtensions unboxedTuplesEnabled unboxedSumsEnabled )(AlexAccNone) - , AlexAcc 66 - , AlexAcc 65 - , AlexAcc 64 - , AlexAcc 63 - , AlexAcc 62 - , AlexAcc 61 - , AlexAcc 60 - , AlexAcc 59 - , AlexAcc 58 - , AlexAcc 57 - , AlexAcc 56 - , AlexAcc 55 - , AlexAcc 54 - , AlexAcc 53 - , AlexAcc 52 - , AlexAcc 51 - , AlexAcc 50 - , AlexAcc 49 - , AlexAcc 48 - , AlexAcc 47 - , AlexAccPred 46 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 45 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 44 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 43 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAcc 42 - , AlexAcc 41 - , AlexAcc 40 - , AlexAcc 39 - , AlexAcc 38 - , AlexAcc 37 - , AlexAcc 36 - , AlexAcc 35 - , AlexAcc 34 - , AlexAcc 33 - , AlexAcc 32 - , AlexAcc 31 - , AlexAcc 30 - , AlexAcc 29 - , AlexAcc 28 - , AlexAccPred 27 ( ifExtension binaryLiteralsEnabled )(AlexAccNone) - , AlexAcc 26 - , AlexAcc 25 - , AlexAccPred 24 ( ifExtension negativeLiteralsEnabled )(AlexAccNone) - , AlexAccPred 23 ( ifExtension negativeLiteralsEnabled )(AlexAccNone) - , AlexAccPred 22 ( ifExtension negativeLiteralsEnabled `alexAndPred` - ifExtension binaryLiteralsEnabled )(AlexAccNone) - , AlexAccPred 21 ( ifExtension negativeLiteralsEnabled )(AlexAccNone) - , AlexAccPred 20 ( ifExtension negativeLiteralsEnabled )(AlexAccNone) - , AlexAcc 19 - , AlexAcc 18 - , AlexAccPred 17 ( ifExtension negativeLiteralsEnabled )(AlexAccNone) - , AlexAccPred 16 ( ifExtension negativeLiteralsEnabled )(AlexAccNone) - , AlexAccPred 15 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 14 ( ifExtension magicHashEnabled `alexAndPred` - ifExtension binaryLiteralsEnabled )(AlexAccNone) - , AlexAccPred 13 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 12 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 11 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 10 ( ifExtension magicHashEnabled `alexAndPred` - ifExtension binaryLiteralsEnabled )(AlexAccNone) - , AlexAccPred 9 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 8 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 7 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 6 ( ifExtension magicHashEnabled `alexAndPred` - ifExtension binaryLiteralsEnabled )(AlexAccNone) - , AlexAccPred 5 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 4 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 3 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAccPred 2 ( ifExtension magicHashEnabled )(AlexAccNone) - , AlexAcc 1 - , AlexAcc 0 - ] - -alex_actions = array (0 :: Int, 169) - [ (168,alex_action_14) - , (167,alex_action_20) - , (166,alex_action_21) - , (165,alex_action_19) - , (164,alex_action_22) - , (163,alex_action_27) - , (162,alex_action_1) - , (161,alex_action_1) - , (160,alex_action_2) - , (159,alex_action_2) - , (158,alex_action_2) - , (157,alex_action_2) - , (156,alex_action_27) - , (155,alex_action_3) - , (154,alex_action_4) - , (153,alex_action_5) - , (152,alex_action_5) - , (151,alex_action_27) - , (150,alex_action_5) - , (149,alex_action_39) - , (148,alex_action_6) - , (147,alex_action_7) - , (146,alex_action_7) - , (145,alex_action_7) - , (144,alex_action_7) - , (143,alex_action_27) - , (142,alex_action_7) - , (141,alex_action_27) - , (140,alex_action_7) - , (139,alex_action_88) - , (138,alex_action_7) - , (137,alex_action_88) - , (136,alex_action_8) - , (135,alex_action_8) - , (134,alex_action_8) - , (133,alex_action_27) - , (132,alex_action_10) - , (131,alex_action_11) - , (130,alex_action_15) - , (129,alex_action_17) - , (128,alex_action_17) - , (127,alex_action_18) - , (126,alex_action_23) - , (125,alex_action_24) - , (124,alex_action_24) - , (123,alex_action_27) - , (122,alex_action_24) - , (121,alex_action_33) - , (120,alex_action_34) - , (119,alex_action_36) - , (118,alex_action_24) - , (117,alex_action_33) - , (116,alex_action_34) - , (115,alex_action_37) - , (114,alex_action_25) - , (113,alex_action_26) - , (112,alex_action_27) - , (111,alex_action_27) - , (110,alex_action_27) - , (109,alex_action_27) - , (108,alex_action_28) - , (107,alex_action_29) - , (106,alex_action_30) - , (105,alex_action_31) - , (104,alex_action_32) - , (103,alex_action_35) - , (102,alex_action_38) - , (101,alex_action_38) - , (100,alex_action_40) - , (99,alex_action_41) - , (98,alex_action_42) - , (97,alex_action_43) - , (96,alex_action_44) - , (95,alex_action_45) - , (94,alex_action_56) - , (93,alex_action_46) - , (92,alex_action_47) - , (91,alex_action_56) - , (90,alex_action_48) - , (89,alex_action_56) - , (88,alex_action_49) - , (87,alex_action_56) - , (86,alex_action_50) - , (85,alex_action_51) - , (84,alex_action_52) - , (83,alex_action_53) - , (82,alex_action_54) - , (81,alex_action_55) - , (80,alex_action_56) - , (79,alex_action_57) - , (78,alex_action_58) - , (77,alex_action_59) - , (76,alex_action_63) - , (75,alex_action_64) - , (74,alex_action_60) - , (73,alex_action_88) - , (72,alex_action_61) - , (71,alex_action_62) - , (70,alex_action_65) - , (69,alex_action_66) - , (68,alex_action_67) - , (67,alex_action_68) - , (66,alex_action_69) - , (65,alex_action_69) - , (64,alex_action_70) - , (63,alex_action_71) - , (62,alex_action_71) - , (61,alex_action_72) - , (60,alex_action_73) - , (59,alex_action_74) - , (58,alex_action_75) - , (57,alex_action_76) - , (56,alex_action_76) - , (55,alex_action_77) - , (54,alex_action_78) - , (53,alex_action_78) - , (52,alex_action_79) - , (51,alex_action_79) - , (50,alex_action_80) - , (49,alex_action_80) - , (48,alex_action_81) - , (47,alex_action_81) - , (46,alex_action_82) - , (45,alex_action_83) - , (44,alex_action_84) - , (43,alex_action_85) - , (42,alex_action_86) - , (41,alex_action_87) - , (40,alex_action_88) - , (39,alex_action_88) - , (38,alex_action_88) - , (37,alex_action_88) - , (36,alex_action_88) - , (35,alex_action_88) - , (34,alex_action_88) - , (33,alex_action_88) - , (32,alex_action_88) - , (31,alex_action_89) - , (30,alex_action_89) - , (29,alex_action_90) - , (28,alex_action_90) - , (27,alex_action_91) - , (26,alex_action_92) - , (25,alex_action_93) - , (24,alex_action_94) - , (23,alex_action_94) - , (22,alex_action_95) - , (21,alex_action_96) - , (20,alex_action_97) - , (19,alex_action_98) - , (18,alex_action_98) - , (17,alex_action_99) - , (16,alex_action_99) - , (15,alex_action_100) - , (14,alex_action_101) - , (13,alex_action_102) - , (12,alex_action_103) - , (11,alex_action_104) - , (10,alex_action_105) - , (9,alex_action_106) - , (8,alex_action_107) - , (7,alex_action_108) - , (6,alex_action_109) - , (5,alex_action_110) - , (4,alex_action_111) - , (3,alex_action_112) - , (2,alex_action_113) - , (1,alex_action_114) - , (0,alex_action_115) - ] - -{-# LINE 568 "parser/Lexer.x" #-} - - --- ----------------------------------------------------------------------------- --- The token type - -data Token - = ITas -- Haskell keywords - | ITcase - | ITclass - | ITdata - | ITdefault - | ITderiving - | ITdo - | ITelse - | IThiding - | ITforeign - | ITif - | ITimport - | ITin - | ITinfix - | ITinfixl - | ITinfixr - | ITinstance - | ITlet - | ITmodule - | ITnewtype - | ITof - | ITqualified - | ITthen - | ITtype - | ITwhere - - | ITforall IsUnicodeSyntax -- GHC extension keywords - | ITexport - | ITlabel - | ITdynamic - | ITsafe - | ITinterruptible - | ITunsafe - | ITstdcallconv - | ITccallconv - | ITcapiconv - | ITprimcallconv - | ITjavascriptcallconv - | ITmdo - | ITfamily - | ITrole - | ITgroup - | ITby - | ITusing - | ITpattern - | ITstatic - | ITstock - | ITanyclass - - -- Backpack tokens - | ITunit - | ITsignature - | ITdependency - | ITrequires - - -- Pragmas, see note [Pragma source text] in BasicTypes - | ITinline_prag SourceText InlineSpec RuleMatchInfo - | ITspec_prag SourceText -- SPECIALISE - | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) - | ITsource_prag SourceText - | ITrules_prag SourceText - | ITwarning_prag SourceText - | ITdeprecated_prag SourceText - | ITline_prag - | ITscc_prag SourceText - | ITgenerated_prag SourceText - | ITcore_prag SourceText -- hdaume: core annotations - | ITunpack_prag SourceText - | ITnounpack_prag SourceText - | ITann_prag SourceText - | ITcomplete_prag SourceText - | ITclose_prag - | IToptions_prag String - | ITinclude_prag String - | ITlanguage_prag - | ITvect_prag SourceText - | ITvect_scalar_prag SourceText - | ITnovect_prag SourceText - | ITminimal_prag SourceText - | IToverlappable_prag SourceText -- instance overlap mode - | IToverlapping_prag SourceText -- instance overlap mode - | IToverlaps_prag SourceText -- instance overlap mode - | ITincoherent_prag SourceText -- instance overlap mode - | ITctype SourceText - - | ITdotdot -- reserved symbols - | ITcolon - | ITdcolon IsUnicodeSyntax - | ITequal - | ITlam - | ITlcase - | ITvbar - | ITlarrow IsUnicodeSyntax - | ITrarrow IsUnicodeSyntax - | ITat - | ITtilde - | ITtildehsh - | ITdarrow IsUnicodeSyntax - | ITminus - | ITbang - | ITdot - - | ITbiglam -- GHC-extension symbols - - | ITocurly -- special symbols - | ITccurly - | ITvocurly - | ITvccurly - | ITobrack - | ITopabrack -- [:, for parallel arrays with -XParallelArrays - | ITcpabrack -- :], for parallel arrays with -XParallelArrays - | ITcbrack - | IToparen - | ITcparen - | IToubxparen - | ITcubxparen - | ITsemi - | ITcomma - | ITunderscore - | ITbackquote - | ITsimpleQuote -- ' - - | ITvarid FastString -- identifiers - | ITconid FastString - | ITvarsym FastString - | ITconsym FastString - | ITqvarid (FastString,FastString) - | ITqconid (FastString,FastString) - | ITqvarsym (FastString,FastString) - | ITqconsym (FastString,FastString) - - | ITdupipvarid FastString -- GHC extension: implicit param: ?x - | ITlabelvarid FastString -- Overloaded label: #x - - | ITchar SourceText Char -- Note [Literal source text] in BasicTypes - | ITstring SourceText FastString -- Note [Literal source text] in BasicTypes - | ITinteger SourceText Integer -- Note [Literal source text] in BasicTypes - | ITrational FractionalLit - - | ITprimchar SourceText Char -- Note [Literal source text] in BasicTypes - | ITprimstring SourceText ByteString -- Note [Literal source text] @BasicTypes - | ITprimint SourceText Integer -- Note [Literal source text] in BasicTypes - | ITprimword SourceText Integer -- Note [Literal source text] in BasicTypes - | ITprimfloat FractionalLit - | ITprimdouble FractionalLit - - -- Template Haskell extension tokens - | ITopenExpQuote HasE IsUnicodeSyntax -- [| or [e| - | ITopenPatQuote -- [p| - | ITopenDecQuote -- [d| - | ITopenTypQuote -- [t| - | ITcloseQuote IsUnicodeSyntax -- |] - | ITopenTExpQuote HasE -- [|| or [e|| - | ITcloseTExpQuote -- ||] - | ITidEscape FastString -- $x - | ITparenEscape -- $( - | ITidTyEscape FastString -- $$x - | ITparenTyEscape -- $$( - | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,RealSrcSpan) - -- ITquasiQuote(quoter, quote, loc) - -- represents a quasi-quote of the form - -- [quoter| quote |] - | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan) - -- ITqQuasiQuote(Qual, quoter, quote, loc) - -- represents a qualified quasi-quote of the form - -- [Qual.quoter| quote |] - - -- Arrow notation extension - | ITproc - | ITrec - | IToparenbar IsUnicodeSyntax -- (| - | ITcparenbar IsUnicodeSyntax -- |) - | ITlarrowtail IsUnicodeSyntax -- -< - | ITrarrowtail IsUnicodeSyntax -- >- - | ITLarrowtail IsUnicodeSyntax -- -<< - | ITRarrowtail IsUnicodeSyntax -- >>- - - -- type application '@' (lexed differently than as-pattern '@', - -- due to checking for preceding whitespace) - | ITtypeApp - - - | ITunknown String -- Used when the lexer can't make sense of it - | ITeof -- end of file token - - -- Documentation annotations - | ITdocCommentNext String -- something beginning '-- |' - | ITdocCommentPrev String -- something beginning '-- ^' - | ITdocCommentNamed String -- something beginning '-- $' - | ITdocSection Int String -- a section heading - | ITdocOptions String -- doc options (prune, ignore-exports, etc) - | ITlineComment String -- comment starting by "--" - | ITblockComment String -- comment in {- -} - - deriving Show - -instance Outputable Token where - ppr x = text (show x) - - --- the bitmap provided as the third component indicates whether the --- corresponding extension keyword is valid under the extension options --- provided to the compiler; if the extension corresponding to *any* of the --- bits set in the bitmap is enabled, the keyword is valid (this setup --- facilitates using a keyword in two different extensions that can be --- activated independently) --- -reservedWordsFM :: UniqFM (Token, ExtsBitmap) -reservedWordsFM = listToUFM $ - map (\(x, y, z) -> (mkFastString x, (y, z))) - [( "_", ITunderscore, 0 ), - ( "as", ITas, 0 ), - ( "case", ITcase, 0 ), - ( "class", ITclass, 0 ), - ( "data", ITdata, 0 ), - ( "default", ITdefault, 0 ), - ( "deriving", ITderiving, 0 ), - ( "do", ITdo, 0 ), - ( "else", ITelse, 0 ), - ( "hiding", IThiding, 0 ), - ( "if", ITif, 0 ), - ( "import", ITimport, 0 ), - ( "in", ITin, 0 ), - ( "infix", ITinfix, 0 ), - ( "infixl", ITinfixl, 0 ), - ( "infixr", ITinfixr, 0 ), - ( "instance", ITinstance, 0 ), - ( "let", ITlet, 0 ), - ( "module", ITmodule, 0 ), - ( "newtype", ITnewtype, 0 ), - ( "of", ITof, 0 ), - ( "qualified", ITqualified, 0 ), - ( "then", ITthen, 0 ), - ( "type", ITtype, 0 ), - ( "where", ITwhere, 0 ), - - ( "forall", ITforall NormalSyntax, - xbit ExplicitForallBit .|. - xbit InRulePragBit), - ( "mdo", ITmdo, xbit RecursiveDoBit), - -- See Note [Lexing type pseudo-keywords] - ( "family", ITfamily, 0 ), - ( "role", ITrole, 0 ), - ( "pattern", ITpattern, xbit PatternSynonymsBit), - ( "static", ITstatic, 0 ), - ( "stock", ITstock, 0 ), - ( "anyclass", ITanyclass, 0 ), - ( "group", ITgroup, xbit TransformComprehensionsBit), - ( "by", ITby, xbit TransformComprehensionsBit), - ( "using", ITusing, xbit TransformComprehensionsBit), - - ( "foreign", ITforeign, xbit FfiBit), - ( "export", ITexport, xbit FfiBit), - ( "label", ITlabel, xbit FfiBit), - ( "dynamic", ITdynamic, xbit FfiBit), - ( "safe", ITsafe, xbit FfiBit .|. - xbit SafeHaskellBit), - ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), - ( "unsafe", ITunsafe, xbit FfiBit), - ( "stdcall", ITstdcallconv, xbit FfiBit), - ( "ccall", ITccallconv, xbit FfiBit), - ( "capi", ITcapiconv, xbit CApiFfiBit), - ( "prim", ITprimcallconv, xbit FfiBit), - ( "javascript", ITjavascriptcallconv, xbit FfiBit), - - ( "unit", ITunit, 0 ), - ( "dependency", ITdependency, 0 ), - ( "signature", ITsignature, 0 ), - - ( "rec", ITrec, xbit ArrowsBit .|. - xbit RecursiveDoBit), - ( "proc", ITproc, xbit ArrowsBit) - ] - -{----------------------------------- -Note [Lexing type pseudo-keywords] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -One might think that we wish to treat 'family' and 'role' as regular old -varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively. -But, there is no need to do so. These pseudo-keywords are not stolen syntax: -they are only used after the keyword 'type' at the top-level, where varids are -not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that -type families and role annotations are never declared without their extensions -on. In fact, by unconditionally lexing these pseudo-keywords as special, we -can get better error messages. - -Also, note that these are included in the `varid` production in the parser -- -a key detail to make all this work. --------------------------------------} - -reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool) -reservedSymsFM = listToUFM $ - map (\ (x,y,z) -> (mkFastString x,(y,z))) - [ ("..", ITdotdot, always) - -- (:) is a reserved op, meaning only list cons - ,(":", ITcolon, always) - ,("::", ITdcolon NormalSyntax, always) - ,("=", ITequal, always) - ,("\\", ITlam, always) - ,("|", ITvbar, always) - ,("<-", ITlarrow NormalSyntax, always) - ,("->", ITrarrow NormalSyntax, always) - ,("@", ITat, always) - ,("~", ITtilde, always) - ,("~#", ITtildehsh, magicHashEnabled) - ,("=>", ITdarrow NormalSyntax, always) - ,("-", ITminus, always) - ,("!", ITbang, always) - - -- For 'forall a . t' - ,(".", ITdot, always) -- \i -> explicitForallEnabled i || inRulePrag i) - - ,("-<", ITlarrowtail NormalSyntax, arrowsEnabled) - ,(">-", ITrarrowtail NormalSyntax, arrowsEnabled) - ,("-<<", ITLarrowtail NormalSyntax, arrowsEnabled) - ,(">>-", ITRarrowtail NormalSyntax, arrowsEnabled) - - ,("∷", ITdcolon UnicodeSyntax, unicodeSyntaxEnabled) - ,("⇒", ITdarrow UnicodeSyntax, unicodeSyntaxEnabled) - ,("∀", ITforall UnicodeSyntax, unicodeSyntaxEnabled) - ,("→", ITrarrow UnicodeSyntax, unicodeSyntaxEnabled) - ,("←", ITlarrow UnicodeSyntax, unicodeSyntaxEnabled) - - ,("⤙", ITlarrowtail UnicodeSyntax, - \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - ,("⤚", ITrarrowtail UnicodeSyntax, - \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - ,("⤛", ITLarrowtail UnicodeSyntax, - \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - ,("⤜", ITRarrowtail UnicodeSyntax, - \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - - -- ToDo: ideally, → and ∷ should be "specials", so that they cannot - -- form part of a large operator. This would let us have a better - -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). - ] - --- ----------------------------------------------------------------------------- --- Lexer actions - -type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) - -special :: Token -> Action -special tok span _buf _len = return (L span tok) - -token, layout_token :: Token -> Action -token t span _buf _len = return (L span t) -layout_token t span _buf _len = pushLexState layout >> return (L span t) - -idtoken :: (StringBuffer -> Int -> Token) -> Action -idtoken f span buf len = return (L span $! (f buf len)) - -skip_one_varid :: (FastString -> Token) -> Action -skip_one_varid f span buf len - = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) - -skip_two_varid :: (FastString -> Token) -> Action -skip_two_varid f span buf len - = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) - -strtoken :: (String -> Token) -> Action -strtoken f span buf len = - return (L span $! (f $! lexemeToString buf len)) - -init_strtoken :: Int -> (String -> Token) -> Action --- like strtoken, but drops the last N character(s) -init_strtoken drop f span buf len = - return (L span $! (f $! lexemeToString buf (len-drop))) - -begin :: Int -> Action -begin code _span _str _len = do pushLexState code; lexToken - -pop :: Action -pop _span _buf _len = do _ <- popLexState - lexToken - -hopefully_open_brace :: Action -hopefully_open_brace span buf len - = do relaxed <- extension relaxedLayout - ctx <- getContext - (AI l _) <- getInput - let offset = srcLocCol l - isOK = relaxed || - case ctx of - Layout prev_off _ : _ -> prev_off < offset - _ -> True - if isOK then pop_and open_brace span buf len - else failSpanMsgP (RealSrcSpan span) (text "Missing block") - -pop_and :: Action -> Action -pop_and act span buf len = do _ <- popLexState - act span buf len - -{-# INLINE nextCharIs #-} -nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool -nextCharIs buf p = not (atEnd buf) && p (currentChar buf) - -{-# INLINE nextCharIsNot #-} -nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool -nextCharIsNot buf p = not (nextCharIs buf p) - -notFollowedBy :: Char -> AlexAccPred ExtsBitmap -notFollowedBy char _ _ _ (AI _ buf) - = nextCharIsNot buf (== char) - -notFollowedBySymbol :: AlexAccPred ExtsBitmap -notFollowedBySymbol _ _ _ (AI _ buf) - = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") - -followedByDigit :: AlexAccPred ExtsBitmap -followedByDigit _ _ _ (AI _ buf) - = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9'])) - -ifCurrentChar :: Char -> AlexAccPred ExtsBitmap -ifCurrentChar char _ (AI _ buf) _ _ - = nextCharIs buf (== char) - --- We must reject doc comments as being ordinary comments everywhere. --- In some cases the doc comment will be selected as the lexeme due to --- maximal munch, but not always, because the nested comment rule is --- valid in all states, but the doc-comment rules are only valid in --- the non-layout states. -isNormalComment :: AlexAccPred ExtsBitmap -isNormalComment bits _ _ (AI _ buf) - | haddockEnabled bits = notFollowedByDocOrPragma - | otherwise = nextCharIsNot buf (== '#') - where - notFollowedByDocOrPragma - = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) - -afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool -afterOptionalSpace buf p - = if nextCharIs buf (== ' ') - then p (snd (nextChar buf)) - else p buf - -atEOL :: AlexAccPred ExtsBitmap -atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' - -ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap -ifExtension pred bits _ _ _ = pred bits - -orExtensions :: (ExtsBitmap -> Bool) -> (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap -orExtensions pred1 pred2 bits _ _ _ = pred1 bits || pred2 bits - -multiline_doc_comment :: Action -multiline_doc_comment span buf _len = withLexedDocType (worker "") - where - worker commentAcc input docType checkNextLine = case alexGetChar' input of - Just ('\n', input') - | checkNextLine -> case checkIfCommentLine input' of - Just input -> worker ('\n':commentAcc) input docType checkNextLine - Nothing -> docCommentEnd input commentAcc docType buf span - | otherwise -> docCommentEnd input commentAcc docType buf span - Just (c, input) -> worker (c:commentAcc) input docType checkNextLine - Nothing -> docCommentEnd input commentAcc docType buf span - - -- Check if the next line of input belongs to this doc comment as well. - -- A doc comment continues onto the next line when the following - -- conditions are met: - -- * The line starts with "--" - -- * The line doesn't start with "---". - -- * The line doesn't start with "-- $", because that would be the - -- start of a /new/ named haddock chunk (#10398). - checkIfCommentLine :: AlexInput -> Maybe AlexInput - checkIfCommentLine input = check (dropNonNewlineSpace input) - where - check input = do - ('-', input) <- alexGetChar' input - ('-', input) <- alexGetChar' input - (c, after_c) <- alexGetChar' input - case c of - '-' -> Nothing - ' ' -> case alexGetChar' after_c of - Just ('$', _) -> Nothing - _ -> Just input - _ -> Just input - - dropNonNewlineSpace input = case alexGetChar' input of - Just (c, input') - | isSpace c && c /= '\n' -> dropNonNewlineSpace input' - | otherwise -> input - Nothing -> input - -lineCommentToken :: Action -lineCommentToken span buf len = do - b <- extension rawTokenStreamEnabled - if b then strtoken ITlineComment span buf len else lexToken - -{- - nested comments require traversing by hand, they can't be parsed - using regular expressions. --} -nested_comment :: P (RealLocated Token) -> Action -nested_comment cont span buf len = do - input <- getInput - go (reverse $ lexemeToString buf len) (1::Int) input - where - go commentAcc 0 input = do - setInput input - b <- extension rawTokenStreamEnabled - if b - then docCommentEnd input commentAcc ITblockComment buf span - else cont - go commentAcc n input = case alexGetChar' input of - Nothing -> errBrace input span - Just ('-',input) -> case alexGetChar' input of - Nothing -> errBrace input span - Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' - Just (_,_) -> go ('-':commentAcc) n input - Just ('\123',input) -> case alexGetChar' input of -- '{' char - Nothing -> errBrace input span - Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input - Just (_,_) -> go ('\123':commentAcc) n input - Just (c,input) -> go (c:commentAcc) n input - -nested_doc_comment :: Action -nested_doc_comment span buf _len = withLexedDocType (go "") - where - go commentAcc input docType _ = case alexGetChar' input of - Nothing -> errBrace input span - Just ('-',input) -> case alexGetChar' input of - Nothing -> errBrace input span - Just ('\125',input) -> - docCommentEnd input commentAcc docType buf span - Just (_,_) -> go ('-':commentAcc) input docType False - Just ('\123', input) -> case alexGetChar' input of - Nothing -> errBrace input span - Just ('-',input) -> do - setInput input - let cont = do input <- getInput; go commentAcc input docType False - nested_comment cont span buf _len - Just (_,_) -> go ('\123':commentAcc) input docType False - Just (c,input) -> go (c:commentAcc) input docType False - -withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token)) - -> P (RealLocated Token) -withLexedDocType lexDocComment = do - input@(AI _ buf) <- getInput - case prevChar buf ' ' of - -- The `Bool` argument to lexDocComment signals whether or not the next - -- line of input might also belong to this doc comment. - '|' -> lexDocComment input ITdocCommentNext True - '^' -> lexDocComment input ITdocCommentPrev True - '$' -> lexDocComment input ITdocCommentNamed True - '*' -> lexDocSection 1 input - _ -> panic "withLexedDocType: Bad doc type" - where - lexDocSection n input = case alexGetChar' input of - Just ('*', input) -> lexDocSection (n+1) input - Just (_, _) -> lexDocComment input (ITdocSection n) False - Nothing -> do setInput input; lexToken -- eof reached, lex it normally - --- RULES pragmas turn on the forall and '.' keywords, and we turn them --- off again at the end of the pragma. -rulePrag :: Action -rulePrag span buf len = do - setExts (.|. xbit InRulePragBit) - let !src = lexemeToString buf len - return (L span (ITrules_prag (SourceText src))) - -endPrag :: Action -endPrag span _buf _len = do - setExts (.&. complement (xbit InRulePragBit)) - return (L span ITclose_prag) - --- docCommentEnd -------------------------------------------------------------------------------- --- This function is quite tricky. We can't just return a new token, we also --- need to update the state of the parser. Why? Because the token is longer --- than what was lexed by Alex, and the lexToken function doesn't know this, so --- it writes the wrong token length to the parser state. This function is --- called afterwards, so it can just update the state. - -docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> - RealSrcSpan -> P (RealLocated Token) -docCommentEnd input commentAcc docType buf span = do - setInput input - let (AI loc nextBuf) = input - comment = reverse commentAcc - span' = mkRealSrcSpan (realSrcSpanStart span) loc - last_len = byteDiff buf nextBuf - - span `seq` setLastToken span' last_len - return (L span' (docType comment)) - -errBrace :: AlexInput -> RealSrcSpan -> P a -errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" - -open_brace, close_brace :: Action -open_brace span _str _len = do - ctx <- getContext - setContext (NoLayout:ctx) - return (L span ITocurly) -close_brace span _str _len = do - popContext - return (L span ITccurly) - -qvarid, qconid :: StringBuffer -> Int -> Token -qvarid buf len = ITqvarid $! splitQualName buf len False -qconid buf len = ITqconid $! splitQualName buf len False - -splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) --- takes a StringBuffer and a length, and returns the module name --- and identifier parts of a qualified name. Splits at the *last* dot, --- because of hierarchical module names. -splitQualName orig_buf len parens = split orig_buf orig_buf - where - split buf dot_buf - | orig_buf `byteDiff` buf >= len = done dot_buf - | c == '.' = found_dot buf' - | otherwise = split buf' dot_buf - where - (c,buf') = nextChar buf - - -- careful, we might get names like M.... - -- so, if the character after the dot is not upper-case, this is - -- the end of the qualifier part. - found_dot buf -- buf points after the '.' - | isUpper c = split buf' buf - | otherwise = done buf - where - (c,buf') = nextChar buf - - done dot_buf = - (lexemeToFastString orig_buf (qual_size - 1), - if parens -- Prelude.(+) - then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) - else lexemeToFastString dot_buf (len - qual_size)) - where - qual_size = orig_buf `byteDiff` dot_buf - -varid :: Action -varid span buf len = - case lookupUFM reservedWordsFM fs of - Just (ITcase, _) -> do - lambdaCase <- extension lambdaCaseEnabled - keyword <- if lambdaCase - then do - lastTk <- getLastTk - return $ case lastTk of - Just ITlam -> ITlcase - _ -> ITcase - else - return ITcase - maybe_layout keyword - return $ L span keyword - Just (ITstatic, _) -> do - staticPointers <- extension staticPointersEnabled - if staticPointers - then return $ L span ITstatic - else return $ L span $ ITvarid fs - Just (keyword, 0) -> do - maybe_layout keyword - return $ L span keyword - Just (keyword, exts) -> do - extsEnabled <- extension $ \i -> exts .&. i /= 0 - if extsEnabled - then do - maybe_layout keyword - return $ L span keyword - else - return $ L span $ ITvarid fs - Nothing -> - return $ L span $ ITvarid fs - where - !fs = lexemeToFastString buf len - -conid :: StringBuffer -> Int -> Token -conid buf len = ITconid $! lexemeToFastString buf len - -qvarsym, qconsym :: StringBuffer -> Int -> Token -qvarsym buf len = ITqvarsym $! splitQualName buf len False -qconsym buf len = ITqconsym $! splitQualName buf len False - -varsym, consym :: Action -varsym = sym ITvarsym -consym = sym ITconsym - -sym :: (FastString -> Token) -> Action -sym con span buf len = - case lookupUFM reservedSymsFM fs of - Just (keyword, exts) -> do - extsEnabled <- extension exts - let !tk | extsEnabled = keyword - | otherwise = con fs - return $ L span tk - Nothing -> - return $ L span $! con fs - where - !fs = lexemeToFastString buf len - --- Variations on the integral numeric literal. -tok_integral :: (SourceText -> Integer -> Token) - -> (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char -> Int)) - -> Action -tok_integral itint transint transbuf translen (radix,char_to_int) span buf len - = return $ L span $ itint (SourceText $ lexemeToString buf len) - $! transint $ parseUnsignedInteger - (offsetBytes transbuf buf) (subtract translen len) radix char_to_int - --- some conveniences for use with tok_integral -tok_num :: (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_num = tok_integral ITinteger -tok_primint :: (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_primint = tok_integral ITprimint -tok_primword :: Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_primword = tok_integral ITprimword positive -positive, negative :: (Integer -> Integer) -positive = id -negative = negate -decimal, octal, hexadecimal :: (Integer, Char -> Int) -decimal = (10,octDecDigit) -binary = (2,octDecDigit) -octal = (8,octDecDigit) -hexadecimal = (16,hexDigit) - --- readRational can understand negative rationals, exponents, everything. -tok_float, tok_primfloat, tok_primdouble :: String -> Token -tok_float str = ITrational $! readFractionalLit str -tok_primfloat str = ITprimfloat $! readFractionalLit str -tok_primdouble str = ITprimdouble $! readFractionalLit str - -readFractionalLit :: String -> FractionalLit -readFractionalLit str = (FL $! str) $! readRational str - --- ----------------------------------------------------------------------------- --- Layout processing - --- we're at the first token on a line, insert layout tokens if necessary -do_bol :: Action -do_bol span _str _len = do - (pos, gen_semic) <- getOffside - case pos of - LT -> do - --trace "layout: inserting '}'" $ do - popContext - -- do NOT pop the lex state, we might have a ';' to insert - return (L span ITvccurly) - EQ | gen_semic -> do - --trace "layout: inserting ';'" $ do - _ <- popLexState - return (L span ITsemi) - _ -> do - _ <- popLexState - lexToken - --- certain keywords put us in the "layout" state, where we might --- add an opening curly brace. -maybe_layout :: Token -> P () -maybe_layout t = do -- If the alternative layout rule is enabled then - -- we never create an implicit layout context here. - -- Layout is handled XXX instead. - -- The code for closing implicit contexts, or - -- inserting implicit semi-colons, is therefore - -- irrelevant as it only applies in an implicit - -- context. - alr <- extension alternativeLayoutRule - unless alr $ f t - where f ITdo = pushLexState layout_do - f ITmdo = pushLexState layout_do - f ITof = pushLexState layout - f ITlcase = pushLexState layout - f ITlet = pushLexState layout - f ITwhere = pushLexState layout - f ITrec = pushLexState layout - f ITif = pushLexState layout_if - f _ = return () - --- Pushing a new implicit layout context. If the indentation of the --- next token is not greater than the previous layout context, then --- Haskell 98 says that the new layout context should be empty; that is --- the lexer must generate {}. --- --- We are slightly more lenient than this: when the new context is started --- by a 'do', then we allow the new context to be at the same indentation as --- the previous context. This is what the 'strict' argument is for. -new_layout_context :: Bool -> Bool -> Token -> Action -new_layout_context strict gen_semic tok span _buf len = do - _ <- popLexState - (AI l _) <- getInput - let offset = srcLocCol l - len - ctx <- getContext - nondecreasing <- extension nondecreasingIndentation - let strict' = strict || not nondecreasing - case ctx of - Layout prev_off _ : _ | - (strict' && prev_off >= offset || - not strict' && prev_off > offset) -> do - -- token is indented to the left of the previous context. - -- we must generate a {} sequence now. - pushLexState layout_left - return (L span tok) - _ -> do setContext (Layout offset gen_semic : ctx) - return (L span tok) - -do_layout_left :: Action -do_layout_left span _buf _len = do - _ <- popLexState - pushLexState bol -- we must be at the start of a line - return (L span ITvccurly) - --- ----------------------------------------------------------------------------- --- LINE pragmas - -setLine :: Int -> Action -setLine code span buf len = do - let line = parseUnsignedInteger buf len 10 octDecDigit - setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line - _ <- popLexState - pushLexState code - lexToken - -setColumn :: Action -setColumn span buf len = do - let column = - case reads (lexemeToString buf len) of - [(column, _)] -> column - _ -> error "setColumn: expected integer" -- shouldn't happen - setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span) - (fromIntegral (column :: Integer))) - _ <- popLexState - lexToken - -setFile :: Int -> Action -setFile code span buf len = do - let file = mkFastString (go (lexemeToString (stepOn buf) (len-2))) - where go ('\\':c:cs) = c : go cs - go (c:cs) = c : go cs - go [] = [] - -- decode escapes in the filename. e.g. on Windows - -- when our filenames have backslashes in, gcc seems to - -- escape the backslashes. One symptom of not doing this - -- is that filenames in error messages look a bit strange: - -- C:\\foo\bar.hs - -- only the first backslash is doubled, because we apply - -- System.FilePath.normalise before printing out - -- filenames and it does not remove duplicate - -- backslashes after the drive letter (should it?). - setAlrLastLoc $ alrInitialLoc file - setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) - addSrcFile file - _ <- popLexState - pushLexState code - lexToken - -alrInitialLoc :: FastString -> RealSrcSpan -alrInitialLoc file = mkRealSrcSpan loc loc - where -- This is a hack to ensure that the first line in a file - -- looks like it is after the initial location: - loc = mkRealSrcLoc file (-1) (-1) - --- ----------------------------------------------------------------------------- --- Options, includes and language pragmas. - -lex_string_prag :: (String -> Token) -> Action -lex_string_prag mkTok span _buf _len - = do input <- getInput - start <- getSrcLoc - tok <- go [] input - end <- getSrcLoc - return (L (mkRealSrcSpan start end) tok) - where go acc input - = if isString input "#-}" - then do setInput input - return (mkTok (reverse acc)) - else case alexGetChar input of - Just (c,i) -> go (c:acc) i - Nothing -> err input - isString _ [] = True - isString i (x:xs) - = case alexGetChar i of - Just (c,i') | c == x -> isString i' xs - _other -> False - err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma" - - --- ----------------------------------------------------------------------------- --- Strings & Chars - --- This stuff is horrible. I hates it. - -lex_string_tok :: Action -lex_string_tok span buf _len = do - tok <- lex_string "" - (AI end bufEnd) <- getInput - let - tok' = case tok of - ITprimstring _ bs -> ITprimstring (SourceText src) bs - ITstring _ s -> ITstring (SourceText src) s - _ -> panic "lex_string_tok" - src = lexemeToString buf (cur bufEnd - cur buf) - return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok') - -lex_string :: String -> P Token -lex_string s = do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i - - Just ('"',i) -> do - setInput i - magicHash <- extension magicHashEnabled - if magicHash - then do - i <- getInput - case alexGetChar' i of - Just ('#',i) -> do - setInput i - if any (> '\xFF') s - then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" - else let bs = unsafeMkByteString (reverse s) - in return (ITprimstring (SourceText (reverse s)) bs) - _other -> - return (ITstring (SourceText (reverse s)) - (mkFastString (reverse s))) - else - return (ITstring (SourceText (reverse s)) - (mkFastString (reverse s))) - - Just ('\\',i) - | Just ('&',i) <- next -> do - setInput i; lex_string s - | Just (c,i) <- next, c <= '\x7f' && is_space c -> do - -- is_space only works for <= '\x7f' (#3751, #5425) - setInput i; lex_stringgap s - where next = alexGetChar' i - - Just (c, i1) -> do - case c of - '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) - c | isAny c -> do setInput i1; lex_string (c:s) - _other -> lit_error i - -lex_stringgap :: String -> P Token -lex_stringgap s = do - i <- getInput - c <- getCharOrFail i - case c of - '\\' -> lex_string s - c | c <= '\x7f' && is_space c -> lex_stringgap s - -- is_space only works for <= '\x7f' (#3751, #5425) - _other -> lit_error i - - -lex_char_tok :: Action --- Here we are basically parsing character literals, such as 'x' or '\n' --- but we additionally spot 'x and ''T, returning ITsimpleQuote and --- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part --- (the parser does that). --- So we have to do two characters of lookahead: when we see 'x we need to --- see if there's a trailing quote -lex_char_tok span buf _len = do -- We've seen ' - i1 <- getInput -- Look ahead to first character - let loc = realSrcSpanStart span - case alexGetChar' i1 of - Nothing -> lit_error i1 - - Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' - setInput i2 - return (L (mkRealSrcSpan loc end2) ITtyQuote) - - Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash - setInput i2 - lit_ch <- lex_escape - i3 <- getInput - mc <- getCharOrFail i3 -- Trailing quote - if mc == '\'' then finish_char_tok buf loc lit_ch - else lit_error i3 - - Just (c, i2@(AI _end2 _)) - | not (isAny c) -> lit_error i1 - | otherwise -> - - -- We've seen 'x, where x is a valid character - -- (i.e. not newline etc) but not a quote or backslash - case alexGetChar' i2 of -- Look ahead one more character - Just ('\'', i3) -> do -- We've seen 'x' - setInput i3 - finish_char_tok buf loc c - _other -> do -- We've seen 'x not followed by quote - -- (including the possibility of EOF) - -- Just parse the quote only - let (AI end _) = i1 - return (L (mkRealSrcSpan loc end) ITsimpleQuote) - -finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token) -finish_char_tok buf loc ch -- We've already seen the closing quote - -- Just need to check for trailing # - = do magicHash <- extension magicHashEnabled - i@(AI end bufEnd) <- getInput - let src = lexemeToString buf (cur bufEnd - cur buf) - if magicHash then do - case alexGetChar' i of - Just ('#',i@(AI end _)) -> do - setInput i - return (L (mkRealSrcSpan loc end) - (ITprimchar (SourceText src) ch)) - _other -> - return (L (mkRealSrcSpan loc end) - (ITchar (SourceText src) ch)) - else do - return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch)) - -isAny :: Char -> Bool -isAny c | c > '\x7f' = isPrint c - | otherwise = is_any c - -lex_escape :: P Char -lex_escape = do - i0 <- getInput - c <- getCharOrFail i0 - case c of - 'a' -> return '\a' - 'b' -> return '\b' - 'f' -> return '\f' - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'v' -> return '\v' - '\\' -> return '\\' - '"' -> return '\"' - '\'' -> return '\'' - '^' -> do i1 <- getInput - c <- getCharOrFail i1 - if c >= '@' && c <= '_' - then return (chr (ord c - ord '@')) - else lit_error i1 - - 'x' -> readNum is_hexdigit 16 hexDigit - 'o' -> readNum is_octdigit 8 octDecDigit - x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) - - c1 -> do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i0 - Just (c2,i2) -> - case alexGetChar' i2 of - Nothing -> do lit_error i0 - Just (c3,i3) -> - let str = [c1,c2,c3] in - case [ (c,rest) | (p,c) <- silly_escape_chars, - Just rest <- [stripPrefix p str] ] of - (escape_char,[]):_ -> do - setInput i3 - return escape_char - (escape_char,_:_):_ -> do - setInput i2 - return escape_char - [] -> lit_error i0 - -readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char -readNum is_digit base conv = do - i <- getInput - c <- getCharOrFail i - if is_digit c - then readNum2 is_digit base conv (conv c) - else lit_error i - -readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char -readNum2 is_digit base conv i = do - input <- getInput - read i input - where read i input = do - case alexGetChar' input of - Just (c,input') | is_digit c -> do - let i' = i*base + conv c - if i' > 0x10ffff - then setInput input >> lexError "numeric escape sequence out of range" - else read i' input' - _other -> do - setInput input; return (chr i) - - -silly_escape_chars :: [(String, Char)] -silly_escape_chars = [ - ("NUL", '\NUL'), - ("SOH", '\SOH'), - ("STX", '\STX'), - ("ETX", '\ETX'), - ("EOT", '\EOT'), - ("ENQ", '\ENQ'), - ("ACK", '\ACK'), - ("BEL", '\BEL'), - ("BS", '\BS'), - ("HT", '\HT'), - ("LF", '\LF'), - ("VT", '\VT'), - ("FF", '\FF'), - ("CR", '\CR'), - ("SO", '\SO'), - ("SI", '\SI'), - ("DLE", '\DLE'), - ("DC1", '\DC1'), - ("DC2", '\DC2'), - ("DC3", '\DC3'), - ("DC4", '\DC4'), - ("NAK", '\NAK'), - ("SYN", '\SYN'), - ("ETB", '\ETB'), - ("CAN", '\CAN'), - ("EM", '\EM'), - ("SUB", '\SUB'), - ("ESC", '\ESC'), - ("FS", '\FS'), - ("GS", '\GS'), - ("RS", '\RS'), - ("US", '\US'), - ("SP", '\SP'), - ("DEL", '\DEL') - ] - --- before calling lit_error, ensure that the current input is pointing to --- the position of the error in the buffer. This is so that we can report --- a correct location to the user, but also so we can detect UTF-8 decoding --- errors if they occur. -lit_error :: AlexInput -> P a -lit_error i = do setInput i; lexError "lexical error in string/character literal" - -getCharOrFail :: AlexInput -> P Char -getCharOrFail i = do - case alexGetChar' i of - Nothing -> lexError "unexpected end-of-file in string/character literal" - Just (c,i) -> do setInput i; return c - --- ----------------------------------------------------------------------------- --- QuasiQuote - -lex_qquasiquote_tok :: Action -lex_qquasiquote_tok span buf len = do - let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False - quoteStart <- getSrcLoc - quote <- lex_quasiquote quoteStart "" - end <- getSrcLoc - return (L (mkRealSrcSpan (realSrcSpanStart span) end) - (ITqQuasiQuote (qual, - quoter, - mkFastString (reverse quote), - mkRealSrcSpan quoteStart end))) - -lex_quasiquote_tok :: Action -lex_quasiquote_tok span buf len = do - let quoter = tail (lexemeToString buf (len - 1)) - -- 'tail' drops the initial '[', - -- while the -1 drops the trailing '|' - quoteStart <- getSrcLoc - quote <- lex_quasiquote quoteStart "" - end <- getSrcLoc - return (L (mkRealSrcSpan (realSrcSpanStart span) end) - (ITquasiQuote (mkFastString quoter, - mkFastString (reverse quote), - mkRealSrcSpan quoteStart end))) - -lex_quasiquote :: RealSrcLoc -> String -> P String -lex_quasiquote start s = do - i <- getInput - case alexGetChar' i of - Nothing -> quasiquote_error start - - -- NB: The string "|]" terminates the quasiquote, - -- with absolutely no escaping. See the extensive - -- discussion on Trac #5348 for why there is no - -- escape handling. - Just ('|',i) - | Just (']',i) <- alexGetChar' i - -> do { setInput i; return s } - - Just (c, i) -> do - setInput i; lex_quasiquote start (c : s) - -quasiquote_error :: RealSrcLoc -> P a -quasiquote_error start = do - (AI end buf) <- getInput - reportLexError start end buf "unterminated quasiquotation" - --- ----------------------------------------------------------------------------- --- Warnings - -warnTab :: Action -warnTab srcspan _buf _len = do - addTabWarning srcspan - lexToken - -warnThen :: WarningFlag -> SDoc -> Action -> Action -warnThen option warning action srcspan buf len = do - addWarning option (RealSrcSpan srcspan) warning - action srcspan buf len - --- ----------------------------------------------------------------------------- --- The Parse Monad - --- | Do we want to generate ';' layout tokens? In some cases we just want to --- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates --- alternatives (unlike a `case` expression where we need ';' to as a separator --- between alternatives). -type GenSemic = Bool - -generateSemic, dontGenerateSemic :: GenSemic -generateSemic = True -dontGenerateSemic = False - -data LayoutContext - = NoLayout - | Layout !Int !GenSemic - deriving Show - -data ParseResult a - = POk PState a - | PFailed - SrcSpan -- The start and end of the text span related to - -- the error. Might be used in environments which can - -- show this span, e.g. by highlighting it. - MsgDoc -- The error message - --- | Test whether a 'WarningFlag' is set -warnopt :: WarningFlag -> ParserFlags -> Bool -warnopt f options = fromEnum f `IntSet.member` pWarningFlags options - --- | Test whether a 'LangExt.Extension' is set -extopt :: LangExt.Extension -> ParserFlags -> Bool -extopt f options = fromEnum f `IntSet.member` pExtensionFlags options - --- | The subset of the 'DynFlags' used by the parser -data ParserFlags = ParserFlags { - pWarningFlags :: IntSet - , pExtensionFlags :: IntSet - , pThisPackage :: UnitId -- ^ key of package currently being compiled - , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions - } - -data PState = PState { - buffer :: StringBuffer, - options :: ParserFlags, - -- This needs to take DynFlags as an argument until - -- we have a fix for #10143 - messages :: DynFlags -> Messages, - tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file - tab_count :: !Int, -- number of tab warnings in the file - last_tk :: Maybe Token, - last_loc :: RealSrcSpan, -- pos of previous token - last_len :: !Int, -- len of previous token - loc :: RealSrcLoc, -- current loc (end of prev token + 1) - context :: [LayoutContext], - lex_state :: [Int], - srcfiles :: [FastString], - -- Used in the alternative layout rule: - -- These tokens are the next ones to be sent out. They are - -- just blindly emitted, without the rule looking at them again: - alr_pending_implicit_tokens :: [RealLocated Token], - -- This is the next token to be considered or, if it is Nothing, - -- we need to get the next token from the input stream: - alr_next_token :: Maybe (RealLocated Token), - -- This is what we consider to be the location of the last token - -- emitted: - alr_last_loc :: RealSrcSpan, - -- The stack of layout contexts: - alr_context :: [ALRContext], - -- Are we expecting a '{'? If it's Just, then the ALRLayout tells - -- us what sort of layout the '{' will open: - alr_expecting_ocurly :: Maybe ALRLayout, - -- Have we just had the '}' for a let block? If so, than an 'in' - -- token doesn't need to close anything: - alr_justClosedExplicitLetBlock :: Bool, - - -- The next three are used to implement Annotations giving the - -- locations of 'noise' tokens in the source, so that users of - -- the GHC API can do source to source conversions. - -- See note [Api annotations] in ApiAnnotation.hs - annotations :: [(ApiAnnKey,[SrcSpan])], - comment_q :: [Located AnnotationComment], - annotations_comments :: [(SrcSpan,[Located AnnotationComment])] - } - -- last_loc and last_len are used when generating error messages, - -- and in pushCurrentContext only. Sigh, if only Happy passed the - -- current token to happyError, we could at least get rid of last_len. - -- Getting rid of last_loc would require finding another way to - -- implement pushCurrentContext (which is only called from one place). - -data ALRContext = ALRNoLayout Bool{- does it contain commas? -} - Bool{- is it a 'let' block? -} - | ALRLayout ALRLayout Int -data ALRLayout = ALRLayoutLet - | ALRLayoutWhere - | ALRLayoutOf - | ALRLayoutDo - -newtype P a = P { unP :: PState -> ParseResult a } - -instance Functor P where - fmap = liftM - -instance Applicative P where - pure = returnP - (<*>) = ap - -instance Monad P where - (>>=) = thenP - fail = failP - -#if __GLASGOW_HASKELL__ > 710 -instance MonadFail P where - fail = failP -#endif - -returnP :: a -> P a -returnP a = a `seq` (P $ \s -> POk s a) - -thenP :: P a -> (a -> P b) -> P b -(P m) `thenP` k = P $ \ s -> - case m s of - POk s1 a -> (unP (k a)) s1 - PFailed span err -> PFailed span err - -failP :: String -> P a -failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) - -failMsgP :: String -> P a -failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) - -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a -failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) - -failSpanMsgP :: SrcSpan -> SDoc -> P a -failSpanMsgP span msg = P $ \_ -> PFailed span msg - -getPState :: P PState -getPState = P $ \s -> POk s s - -withThisPackage :: (UnitId -> a) -> P a -withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o)) - -extension :: (ExtsBitmap -> Bool) -> P Bool -extension p = P $ \s -> POk s (p $! (pExtsBitmap . options) s) - -getExts :: P ExtsBitmap -getExts = P $ \s -> POk s (pExtsBitmap . options $ s) - -setExts :: (ExtsBitmap -> ExtsBitmap) -> P () -setExts f = P $ \s -> POk s { - options = - let p = options s - in p { pExtsBitmap = f (pExtsBitmap p) } - } () - -setSrcLoc :: RealSrcLoc -> P () -setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () - -getSrcLoc :: P RealSrcLoc -getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc - -addSrcFile :: FastString -> P () -addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () - -setLastToken :: RealSrcSpan -> Int -> P () -setLastToken loc len = P $ \s -> POk s { - last_loc=loc, - last_len=len - } () - -setLastTk :: Token -> P () -setLastTk tk = P $ \s -> POk s { last_tk = Just tk } () - -getLastTk :: P (Maybe Token) -getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk - -data AlexInput = AI RealSrcLoc StringBuffer - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (AI _ buf) = prevChar buf '\n' - --- backwards compatibility for Alex 2.x -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar inp = case alexGetByte inp of - Nothing -> Nothing - Just (b,i) -> c `seq` Just (c,i) - where c = chr $ fromIntegral b - -alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) -alexGetByte (AI loc s) - | atEnd s = Nothing - | otherwise = byte `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (byte, (AI loc' s')) - where (c,s') = nextChar s - loc' = advanceSrcLoc loc c - byte = fromIntegral $ ord adj_c - - non_graphic = '\x00' - upper = '\x01' - lower = '\x02' - digit = '\x03' - symbol = '\x04' - space = '\x05' - other_graphic = '\x06' - uniidchar = '\x07' - - adj_c - | c <= '\x07' = non_graphic - | c <= '\x7f' = c - -- Alex doesn't handle Unicode, so when Unicode - -- character is encountered we output these values - -- with the actual character value hidden in the state. - | otherwise = - -- NB: The logic behind these definitions is also reflected - -- in basicTypes/Lexeme.hs - -- Any changes here should likely be reflected there. - - case generalCategory c of - UppercaseLetter -> upper - LowercaseLetter -> lower - TitlecaseLetter -> upper - ModifierLetter -> uniidchar -- see #10196 - OtherLetter -> lower -- see #1103 - NonSpacingMark -> uniidchar -- see #7650 - SpacingCombiningMark -> other_graphic - EnclosingMark -> other_graphic - DecimalNumber -> digit - LetterNumber -> other_graphic - OtherNumber -> digit -- see #4373 - ConnectorPunctuation -> symbol - DashPunctuation -> symbol - OpenPunctuation -> other_graphic - ClosePunctuation -> other_graphic - InitialQuote -> other_graphic - FinalQuote -> other_graphic - OtherPunctuation -> symbol - MathSymbol -> symbol - CurrencySymbol -> symbol - ModifierSymbol -> symbol - OtherSymbol -> symbol - Space -> space - _other -> non_graphic - --- This version does not squash unicode characters, it is used when --- lexing strings. -alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar' (AI loc s) - | atEnd s = Nothing - | otherwise = c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (c, (AI loc' s')) - where (c,s') = nextChar s - loc' = advanceSrcLoc loc c - -getInput :: P AlexInput -getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) - -setInput :: AlexInput -> P () -setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () - -nextIsEOF :: P Bool -nextIsEOF = do - AI _ s <- getInput - return $ atEnd s - -pushLexState :: Int -> P () -pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () - -popLexState :: P Int -popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls - -getLexState :: P Int -getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls - -popNextToken :: P (Maybe (RealLocated Token)) -popNextToken - = P $ \s@PState{ alr_next_token = m } -> - POk (s {alr_next_token = Nothing}) m - -activeContext :: P Bool -activeContext = do - ctxt <- getALRContext - expc <- getAlrExpectingOCurly - impt <- implicitTokenPending - case (ctxt,expc) of - ([],Nothing) -> return impt - _other -> return True - -setAlrLastLoc :: RealSrcSpan -> P () -setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () - -getAlrLastLoc :: P RealSrcSpan -getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l - -getALRContext :: P [ALRContext] -getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs - -setALRContext :: [ALRContext] -> P () -setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () - -getALRTransitional :: P Bool -getALRTransitional = P $ \s@PState {options = o} -> - POk s (extopt LangExt.AlternativeLayoutRuleTransitional o) - -getJustClosedExplicitLetBlock :: P Bool -getJustClosedExplicitLetBlock - = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b - -setJustClosedExplicitLetBlock :: Bool -> P () -setJustClosedExplicitLetBlock b - = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () - -setNextToken :: RealLocated Token -> P () -setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () - -implicitTokenPending :: P Bool -implicitTokenPending - = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> - case ts of - [] -> POk s False - _ -> POk s True - -popPendingImplicitToken :: P (Maybe (RealLocated Token)) -popPendingImplicitToken - = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> - case ts of - [] -> POk s Nothing - (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) - -setPendingImplicitTokens :: [RealLocated Token] -> P () -setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () - -getAlrExpectingOCurly :: P (Maybe ALRLayout) -getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b - -setAlrExpectingOCurly :: Maybe ALRLayout -> P () -setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () - --- for reasons of efficiency, flags indicating language extensions (eg, --- -fglasgow-exts or -XParallelArrays) are represented by a bitmap --- stored in an unboxed Word64 -type ExtsBitmap = Word64 - -xbit :: ExtBits -> ExtsBitmap -xbit = bit . fromEnum - -xtest :: ExtBits -> ExtsBitmap -> Bool -xtest ext xmap = testBit xmap (fromEnum ext) - -data ExtBits - = FfiBit - | InterruptibleFfiBit - | CApiFfiBit - | ParrBit - | ArrowsBit - | ThBit - | ThQuotesBit - | IpBit - | OverloadedLabelsBit -- #x overloaded labels - | ExplicitForallBit -- the 'forall' keyword and '.' symbol - | BangPatBit -- Tells the parser to understand bang-patterns - -- (doesn't affect the lexer) - | PatternSynonymsBit -- pattern synonyms - | HaddockBit-- Lex and parse Haddock comments - | MagicHashBit -- "#" in both functions and operators - | RecursiveDoBit -- mdo - | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc - | UnboxedTuplesBit -- (# and #) - | UnboxedSumsBit -- (# and #) - | DatatypeContextsBit - | TransformComprehensionsBit - | QqBit -- enable quasiquoting - | InRulePragBit - | RawTokenStreamBit -- producing a token stream with all comments included - | SccProfilingOnBit - | HpcBit - | AlternativeLayoutRuleBit - | RelaxedLayoutBit - | NondecreasingIndentationBit - | SafeHaskellBit - | TraditionalRecordSyntaxBit - | ExplicitNamespacesBit - | LambdaCaseBit - | BinaryLiteralsBit - | NegativeLiteralsBit - | TypeApplicationsBit - | StaticPointersBit - deriving Enum - - -always :: ExtsBitmap -> Bool -always _ = True -parrEnabled :: ExtsBitmap -> Bool -parrEnabled = xtest ParrBit -arrowsEnabled :: ExtsBitmap -> Bool -arrowsEnabled = xtest ArrowsBit -thEnabled :: ExtsBitmap -> Bool -thEnabled = xtest ThBit -thQuotesEnabled :: ExtsBitmap -> Bool -thQuotesEnabled = xtest ThQuotesBit -ipEnabled :: ExtsBitmap -> Bool -ipEnabled = xtest IpBit -overloadedLabelsEnabled :: ExtsBitmap -> Bool -overloadedLabelsEnabled = xtest OverloadedLabelsBit -explicitForallEnabled :: ExtsBitmap -> Bool -explicitForallEnabled = xtest ExplicitForallBit -bangPatEnabled :: ExtsBitmap -> Bool -bangPatEnabled = xtest BangPatBit -haddockEnabled :: ExtsBitmap -> Bool -haddockEnabled = xtest HaddockBit -magicHashEnabled :: ExtsBitmap -> Bool -magicHashEnabled = xtest MagicHashBit -unicodeSyntaxEnabled :: ExtsBitmap -> Bool -unicodeSyntaxEnabled = xtest UnicodeSyntaxBit -unboxedTuplesEnabled :: ExtsBitmap -> Bool -unboxedTuplesEnabled = xtest UnboxedTuplesBit -unboxedSumsEnabled :: ExtsBitmap -> Bool -unboxedSumsEnabled = xtest UnboxedSumsBit -datatypeContextsEnabled :: ExtsBitmap -> Bool -datatypeContextsEnabled = xtest DatatypeContextsBit -qqEnabled :: ExtsBitmap -> Bool -qqEnabled = xtest QqBit -inRulePrag :: ExtsBitmap -> Bool -inRulePrag = xtest InRulePragBit -rawTokenStreamEnabled :: ExtsBitmap -> Bool -rawTokenStreamEnabled = xtest RawTokenStreamBit -alternativeLayoutRule :: ExtsBitmap -> Bool -alternativeLayoutRule = xtest AlternativeLayoutRuleBit -hpcEnabled :: ExtsBitmap -> Bool -hpcEnabled = xtest HpcBit -relaxedLayout :: ExtsBitmap -> Bool -relaxedLayout = xtest RelaxedLayoutBit -nondecreasingIndentation :: ExtsBitmap -> Bool -nondecreasingIndentation = xtest NondecreasingIndentationBit -sccProfilingOn :: ExtsBitmap -> Bool -sccProfilingOn = xtest SccProfilingOnBit -traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool -traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit - -explicitNamespacesEnabled :: ExtsBitmap -> Bool -explicitNamespacesEnabled = xtest ExplicitNamespacesBit -lambdaCaseEnabled :: ExtsBitmap -> Bool -lambdaCaseEnabled = xtest LambdaCaseBit -binaryLiteralsEnabled :: ExtsBitmap -> Bool -binaryLiteralsEnabled = xtest BinaryLiteralsBit -negativeLiteralsEnabled :: ExtsBitmap -> Bool -negativeLiteralsEnabled = xtest NegativeLiteralsBit -patternSynonymsEnabled :: ExtsBitmap -> Bool -patternSynonymsEnabled = xtest PatternSynonymsBit -typeApplicationEnabled :: ExtsBitmap -> Bool -typeApplicationEnabled = xtest TypeApplicationsBit -staticPointersEnabled :: ExtsBitmap -> Bool -staticPointersEnabled = xtest StaticPointersBit - --- PState for parsing options pragmas --- -pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState -pragState dynflags buf loc = (mkPState dynflags buf loc) { - lex_state = [bol, option_prags, 0] - } - --- | Extracts the flag information needed for parsing -mkParserFlags :: DynFlags -> ParserFlags -mkParserFlags flags = - ParserFlags { - pWarningFlags = DynFlags.warningFlags flags - , pExtensionFlags = DynFlags.extensionFlags flags - , pThisPackage = DynFlags.thisPackage flags - , pExtsBitmap = bitmap - } - where - bitmap = FfiBit `setBitIf` xopt LangExt.ForeignFunctionInterface flags - .|. InterruptibleFfiBit `setBitIf` xopt LangExt.InterruptibleFFI flags - .|. CApiFfiBit `setBitIf` xopt LangExt.CApiFFI flags - .|. ParrBit `setBitIf` xopt LangExt.ParallelArrays flags - .|. ArrowsBit `setBitIf` xopt LangExt.Arrows flags - .|. ThBit `setBitIf` xopt LangExt.TemplateHaskell flags - .|. ThQuotesBit `setBitIf` xopt LangExt.TemplateHaskellQuotes flags - .|. QqBit `setBitIf` xopt LangExt.QuasiQuotes flags - .|. IpBit `setBitIf` xopt LangExt.ImplicitParams flags - .|. OverloadedLabelsBit `setBitIf` xopt LangExt.OverloadedLabels flags - .|. ExplicitForallBit `setBitIf` xopt LangExt.ExplicitForAll flags - .|. BangPatBit `setBitIf` xopt LangExt.BangPatterns flags - .|. HaddockBit `setBitIf` gopt Opt_Haddock flags - .|. MagicHashBit `setBitIf` xopt LangExt.MagicHash flags - .|. RecursiveDoBit `setBitIf` xopt LangExt.RecursiveDo flags - .|. UnicodeSyntaxBit `setBitIf` xopt LangExt.UnicodeSyntax flags - .|. UnboxedTuplesBit `setBitIf` xopt LangExt.UnboxedTuples flags - .|. UnboxedSumsBit `setBitIf` xopt LangExt.UnboxedSums flags - .|. DatatypeContextsBit `setBitIf` xopt LangExt.DatatypeContexts flags - .|. TransformComprehensionsBit `setBitIf` xopt LangExt.TransformListComp flags - .|. TransformComprehensionsBit `setBitIf` xopt LangExt.MonadComprehensions flags - .|. RawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags - .|. HpcBit `setBitIf` gopt Opt_Hpc flags - .|. AlternativeLayoutRuleBit `setBitIf` xopt LangExt.AlternativeLayoutRule flags - .|. RelaxedLayoutBit `setBitIf` xopt LangExt.RelaxedLayout flags - .|. SccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags - .|. NondecreasingIndentationBit `setBitIf` xopt LangExt.NondecreasingIndentation flags - .|. SafeHaskellBit `setBitIf` safeImportsOn flags - .|. TraditionalRecordSyntaxBit `setBitIf` xopt LangExt.TraditionalRecordSyntax flags - .|. ExplicitNamespacesBit `setBitIf` xopt LangExt.ExplicitNamespaces flags - .|. LambdaCaseBit `setBitIf` xopt LangExt.LambdaCase flags - .|. BinaryLiteralsBit `setBitIf` xopt LangExt.BinaryLiterals flags - .|. NegativeLiteralsBit `setBitIf` xopt LangExt.NegativeLiterals flags - .|. PatternSynonymsBit `setBitIf` xopt LangExt.PatternSynonyms flags - .|. TypeApplicationsBit `setBitIf` xopt LangExt.TypeApplications flags - .|. StaticPointersBit `setBitIf` xopt LangExt.StaticPointers flags - - setBitIf :: ExtBits -> Bool -> ExtsBitmap - b `setBitIf` cond | cond = xbit b - | otherwise = 0 - --- | Creates a parse state from a 'DynFlags' value -mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState -mkPState flags = mkPStatePure (mkParserFlags flags) - --- | Creates a parse state from a 'ParserFlags' value -mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState -mkPStatePure options buf loc = - PState { - buffer = buf, - options = options, - messages = const emptyMessages, - tab_first = Nothing, - tab_count = 0, - last_tk = Nothing, - last_loc = mkRealSrcSpan loc loc, - last_len = 0, - loc = loc, - context = [], - lex_state = [bol, 0], - srcfiles = [], - alr_pending_implicit_tokens = [], - alr_next_token = Nothing, - alr_last_loc = alrInitialLoc (fsLit ""), - alr_context = [], - alr_expecting_ocurly = Nothing, - alr_justClosedExplicitLetBlock = False, - annotations = [], - comment_q = [], - annotations_comments = [] - } - -addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () -addWarning option srcspan warning - = P $ \s@PState{messages=m, options=o} -> - let - m' d = - let (ws, es) = m d - warning' = makeIntoWarning (Reason option) $ - mkWarnMsg d srcspan alwaysQualify warning - ws' = if warnopt option o then ws `snocBag` warning' else ws - in (ws', es) - in POk s{messages=m'} () - -addTabWarning :: RealSrcSpan -> P () -addTabWarning srcspan - = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> - let tf' = if isJust tf then tf else Just srcspan - tc' = tc + 1 - s' = if warnopt Opt_WarnTabs o - then s{tab_first = tf', tab_count = tc'} - else s - in POk s' () - -mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg -mkTabWarning PState{tab_first=tf, tab_count=tc} d = - let middle = if tc == 1 - then text "" - else text ", and in" <+> speakNOf (tc - 1) (text "further location") - message = text "Tab character found here" - <> middle - <> text "." - $+$ text "Please use spaces instead." - in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $ - mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf - -getMessages :: PState -> DynFlags -> Messages -getMessages p@PState{messages=m} d = - let (ws, es) = m d - tabwarning = mkTabWarning p d - ws' = maybe ws (`consBag` ws) tabwarning - in (ws', es) - -getContext :: P [LayoutContext] -getContext = P $ \s@PState{context=ctx} -> POk s ctx - -setContext :: [LayoutContext] -> P () -setContext ctx = P $ \s -> POk s{context=ctx} () - -popContext :: P () -popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, - last_len = len, last_loc = last_loc }) -> - case ctx of - (_:tl) -> POk s{ context = tl } () - [] -> PFailed (RealSrcSpan last_loc) (srcParseErr o buf len) - --- Push a new layout context at the indentation of the last token read. -pushCurrentContext :: GenSemic -> P () -pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } -> - POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} () - --- This is only used at the outer level of a module when the 'module' keyword is --- missing. -pushModuleContext :: P () -pushModuleContext = pushCurrentContext generateSemic - -getOffside :: P (Ordering, Bool) -getOffside = P $ \s@PState{last_loc=loc, context=stk} -> - let offs = srcSpanStartCol loc in - let ord = case stk of - Layout n gen_semic : _ -> - --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ - (compare offs n, gen_semic) - _ -> - (GT, dontGenerateSemic) - in POk s ord - --- --------------------------------------------------------------------------- --- Construct a parse error - -srcParseErr - :: ParserFlags - -> StringBuffer -- current buffer (placed just after the last token) - -> Int -- length of the previous token - -> MsgDoc -srcParseErr options buf len - = if null token - then text "parse error (possibly incorrect indentation or mismatched brackets)" - else text "parse error on input" <+> quotes (text token) - $$ ppWhen (not th_enabled && token == "$") -- #7396 - (text "Perhaps you intended to use TemplateHaskell") - $$ ppWhen (token == "<-") - (text "Perhaps this statement should be within a 'do' block?") - $$ ppWhen (token == "=") - (text "Perhaps you need a 'let' in a 'do' block?" - $$ text "e.g. 'let x = 5' instead of 'x = 5'") - $$ ppWhen (not ps_enabled && pattern == "pattern") -- #12429 - (text "Perhaps you intended to use PatternSynonyms") - where token = lexemeToString (offsetBytes (-len) buf) len - pattern = lexemeToString (offsetBytes (-len - 8) buf) 7 - th_enabled = extopt LangExt.TemplateHaskell options - ps_enabled = extopt LangExt.PatternSynonyms options - --- Report a parse failure, giving the span of the previous token as --- the location of the error. This is the entry point for errors --- detected during parsing. -srcParseFail :: P a -srcParseFail = P $ \PState{ buffer = buf, options = o, last_len = len, - last_loc = last_loc } -> - PFailed (RealSrcSpan last_loc) (srcParseErr o buf len) - --- A lexical error is reported at a particular position in the source file, --- not over a token range. -lexError :: String -> P a -lexError str = do - loc <- getSrcLoc - (AI end buf) <- getInput - reportLexError loc end buf str - --- ----------------------------------------------------------------------------- --- This is the top-level function: called from the parser each time a --- new token is to be read from the input. - -lexer :: Bool -> (Located Token -> P a) -> P a -lexer queueComments cont = do - alr <- extension alternativeLayoutRule - let lexTokenFun = if alr then lexTokenAlr else lexToken - (L span tok) <- lexTokenFun - --trace ("token: " ++ show tok) $ do - - case tok of - ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span) - _ -> return () - - if (queueComments && isDocComment tok) - then queueComment (L (RealSrcSpan span) tok) - else return () - - if (queueComments && isComment tok) - then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont - else cont (L (RealSrcSpan span) tok) - -lexTokenAlr :: P (RealLocated Token) -lexTokenAlr = do mPending <- popPendingImplicitToken - t <- case mPending of - Nothing -> - do mNext <- popNextToken - t <- case mNext of - Nothing -> lexToken - Just next -> return next - alternativeLayoutRuleToken t - Just t -> - return t - setAlrLastLoc (getLoc t) - case unLoc t of - ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) - ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) - ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) - ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo) - ITmdo -> setAlrExpectingOCurly (Just ALRLayoutDo) - ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) - _ -> return () - return t - -alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) -alternativeLayoutRuleToken t - = do context <- getALRContext - lastLoc <- getAlrLastLoc - mExpectingOCurly <- getAlrExpectingOCurly - transitional <- getALRTransitional - justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock - setJustClosedExplicitLetBlock False - let thisLoc = getLoc t - thisCol = srcSpanStartCol thisLoc - newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc - case (unLoc t, context, mExpectingOCurly) of - -- This case handles a GHC extension to the original H98 - -- layout rule... - (ITocurly, _, Just alrLayout) -> - do setAlrExpectingOCurly Nothing - let isLet = case alrLayout of - ALRLayoutLet -> True - _ -> False - setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) - return t - -- ...and makes this case unnecessary - {- - -- I think our implicit open-curly handling is slightly - -- different to John's, in how it interacts with newlines - -- and "in" - (ITocurly, _, Just _) -> - do setAlrExpectingOCurly Nothing - setNextToken t - lexTokenAlr - -} - (_, ALRLayout _ col : _ls, Just expectingOCurly) - | (thisCol > col) || - (thisCol == col && - isNonDecreasingIntentation expectingOCurly) -> - do setAlrExpectingOCurly Nothing - setALRContext (ALRLayout expectingOCurly thisCol : context) - setNextToken t - return (L thisLoc ITocurly) - | otherwise -> - do setAlrExpectingOCurly Nothing - setPendingImplicitTokens [L lastLoc ITccurly] - setNextToken t - return (L lastLoc ITocurly) - (_, _, Just expectingOCurly) -> - do setAlrExpectingOCurly Nothing - setALRContext (ALRLayout expectingOCurly thisCol : context) - setNextToken t - return (L thisLoc ITocurly) - -- We do the [] cases earlier than in the spec, as we - -- have an actual EOF token - (ITeof, ALRLayout _ _ : ls, _) -> - do setALRContext ls - setNextToken t - return (L thisLoc ITccurly) - (ITeof, _, _) -> - return t - -- the other ITeof case omitted; general case below covers it - (ITin, _, _) - | justClosedExplicitLetBlock -> - return t - (ITin, ALRLayout ALRLayoutLet _ : ls, _) - | newLine -> - do setPendingImplicitTokens [t] - setALRContext ls - return (L thisLoc ITccurly) - -- This next case is to handle a transitional issue: - (ITwhere, ALRLayout _ col : ls, _) - | newLine && thisCol == col && transitional -> - do addWarning Opt_WarnAlternativeLayoutRuleTransitional - (RealSrcSpan thisLoc) - (transitionalAlternativeLayoutWarning - "`where' clause at the same depth as implicit layout block") - setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITccurly) - -- This next case is to handle a transitional issue: - (ITvbar, ALRLayout _ col : ls, _) - | newLine && thisCol == col && transitional -> - do addWarning Opt_WarnAlternativeLayoutRuleTransitional - (RealSrcSpan thisLoc) - (transitionalAlternativeLayoutWarning - "`|' at the same depth as implicit layout block") - setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITccurly) - (_, ALRLayout _ col : ls, _) - | newLine && thisCol == col -> - do setNextToken t - return (L thisLoc ITsemi) - | newLine && thisCol < col -> - do setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITccurly) - -- We need to handle close before open, as 'then' is both - -- an open and a close - (u, _, _) - | isALRclose u -> - case context of - ALRLayout _ _ : ls -> - do setALRContext ls - setNextToken t - return (L thisLoc ITccurly) - ALRNoLayout _ isLet : ls -> - do let ls' = if isALRopen u - then ALRNoLayout (containsCommas u) False : ls - else ls - setALRContext ls' - when isLet $ setJustClosedExplicitLetBlock True - return t - [] -> - do let ls = if isALRopen u - then [ALRNoLayout (containsCommas u) False] - else [] - setALRContext ls - -- XXX This is an error in John's code, but - -- it looks reachable to me at first glance - return t - (u, _, _) - | isALRopen u -> - do setALRContext (ALRNoLayout (containsCommas u) False : context) - return t - (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> - do setALRContext ls - setPendingImplicitTokens [t] - return (L thisLoc ITccurly) - (ITin, ALRLayout _ _ : ls, _) -> - do setALRContext ls - setNextToken t - return (L thisLoc ITccurly) - -- the other ITin case omitted; general case below covers it - (ITcomma, ALRLayout _ _ : ls, _) - | topNoLayoutContainsCommas ls -> - do setALRContext ls - setNextToken t - return (L thisLoc ITccurly) - (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> - do setALRContext ls - setPendingImplicitTokens [t] - return (L thisLoc ITccurly) - -- the other ITwhere case omitted; general case below covers it - (_, _, _) -> return t - -transitionalAlternativeLayoutWarning :: String -> SDoc -transitionalAlternativeLayoutWarning msg - = text "transitional layout will not be accepted in the future:" - $$ text msg - -isALRopen :: Token -> Bool -isALRopen ITcase = True -isALRopen ITif = True -isALRopen ITthen = True -isALRopen IToparen = True -isALRopen ITobrack = True -isALRopen ITocurly = True --- GHC Extensions: -isALRopen IToubxparen = True -isALRopen ITparenEscape = True -isALRopen ITparenTyEscape = True -isALRopen _ = False - -isALRclose :: Token -> Bool -isALRclose ITof = True -isALRclose ITthen = True -isALRclose ITelse = True -isALRclose ITcparen = True -isALRclose ITcbrack = True -isALRclose ITccurly = True --- GHC Extensions: -isALRclose ITcubxparen = True -isALRclose _ = False - -isNonDecreasingIntentation :: ALRLayout -> Bool -isNonDecreasingIntentation ALRLayoutDo = True -isNonDecreasingIntentation _ = False - -containsCommas :: Token -> Bool -containsCommas IToparen = True -containsCommas ITobrack = True --- John doesn't have {} as containing commas, but records contain them, --- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs --- (defaultInstallDirs). -containsCommas ITocurly = True --- GHC Extensions: -containsCommas IToubxparen = True -containsCommas _ = False - -topNoLayoutContainsCommas :: [ALRContext] -> Bool -topNoLayoutContainsCommas [] = False -topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls -topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b - -lexToken :: P (RealLocated Token) -lexToken = do - inp@(AI loc1 buf) <- getInput - sc <- getLexState - exts <- getExts - case alexScanUser exts inp sc of - AlexEOF -> do - let span = mkRealSrcSpan loc1 loc1 - setLastToken span 0 - return (L span ITeof) - AlexError (AI loc2 buf) -> - reportLexError loc1 loc2 buf "lexical error" - AlexSkip inp2 _ -> do - setInput inp2 - lexToken - AlexToken inp2@(AI end buf2) _ t -> do - setInput inp2 - let span = mkRealSrcSpan loc1 end - let bytes = byteDiff buf buf2 - span `seq` setLastToken span bytes - lt <- t span buf bytes - case unLoc lt of - ITlineComment _ -> return lt - ITblockComment _ -> return lt - lt' -> do - setLastTk lt' - return lt - -reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a -reportLexError loc1 loc2 buf str - | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") - | otherwise = - let c = fst (nextChar buf) - in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# - then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") - else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) - -lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] -lexTokenStream buf loc dflags = unP go initState - where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream - initState = mkPState dflags' buf loc - go = do - ltok <- lexer False return - case ltok of - L _ ITeof -> return [] - _ -> liftM (ltok:) go - -linePrags = Map.singleton "line" (begin line_prag2) - -fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), - ("options_ghc", lex_string_prag IToptions_prag), - ("options_haddock", lex_string_prag ITdocOptions), - ("language", token ITlanguage_prag), - ("include", lex_string_prag ITinclude_prag)]) - -ignoredPrags = Map.fromList (map ignored pragmas) - where ignored opt = (opt, nested_comment lexToken) - impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] - options_pragmas = map ("options_" ++) impls - -- CFILES is a hugs-only thing. - pragmas = options_pragmas ++ ["cfiles", "contract"] - -oneWordPrags = Map.fromList [ - ("rules", rulePrag), - ("inline", - strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))), - ("inlinable", - strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), - ("inlineable", - strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), - -- Spelling variant - ("notinline", - strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))), - ("specialize", strtoken (\s -> ITspec_prag (SourceText s))), - ("source", strtoken (\s -> ITsource_prag (SourceText s))), - ("warning", strtoken (\s -> ITwarning_prag (SourceText s))), - ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))), - ("scc", strtoken (\s -> ITscc_prag (SourceText s))), - ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))), - ("core", strtoken (\s -> ITcore_prag (SourceText s))), - ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))), - ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))), - ("ann", strtoken (\s -> ITann_prag (SourceText s))), - ("vectorize", strtoken (\s -> ITvect_prag (SourceText s))), - ("novectorize", strtoken (\s -> ITnovect_prag (SourceText s))), - ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))), - ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))), - ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))), - ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))), - ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))), - ("ctype", strtoken (\s -> ITctype (SourceText s))), - ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))), - ("column", begin column_prag) - ] - -twoWordPrags = Map.fromList([ - ("inline conlike", - strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))), - ("notinline conlike", - strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))), - ("specialize inline", - strtoken (\s -> (ITspec_inline_prag (SourceText s) True))), - ("specialize notinline", - strtoken (\s -> (ITspec_inline_prag (SourceText s) False))), - ("vectorize scalar", - strtoken (\s -> ITvect_scalar_prag (SourceText s)))]) - -dispatch_pragmas :: Map String Action -> Action -dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of - Just found -> found span buf len - Nothing -> lexError "unknown pragma" - -known_pragma :: Map String Action -> AlexAccPred ExtsBitmap -known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) - = isKnown && nextCharIsNot curbuf pragmaNameChar - where l = lexemeToString startbuf (byteDiff startbuf curbuf) - isKnown = isJust $ Map.lookup (clean_pragma l) prags - pragmaNameChar c = isAlphaNum c || c == '_' - -clean_pragma :: String -> String -clean_pragma prag = canon_ws (map toLower (unprefix prag)) - where unprefix prag' = case stripPrefix "{-#" prag' of - Just rest -> rest - Nothing -> prag' - canonical prag' = case prag' of - "noinline" -> "notinline" - "specialise" -> "specialize" - "vectorise" -> "vectorize" - "novectorise" -> "novectorize" - "constructorlike" -> "conlike" - _ -> prag' - canon_ws s = unwords (map canonical (words s)) - - - -{- -%************************************************************************ -%* * - Helper functions for generating annotations in the parser -%* * -%************************************************************************ --} - --- | Encapsulated call to addAnnotation, requiring only the SrcSpan of --- the AST construct the annotation belongs to; together with the --- AnnKeywordId, this is the key of the annotation map. --- --- This type is useful for places in the parser where it is not yet --- known what SrcSpan an annotation should be added to. The most --- common situation is when we are parsing a list: the annotations --- need to be associated with the AST element that *contains* the --- list, not the list itself. 'AddAnn' lets us defer adding the --- annotations until we finish parsing the list and are now parsing --- the enclosing element; we then apply the 'AddAnn' to associate --- the annotations. Another common situation is where a common fragment of --- the AST has been factored out but there is no separate AST node for --- this fragment (this occurs in class and data declarations). In this --- case, the annotation belongs to the parent data declaration. --- --- The usual way an 'AddAnn' is created is using the 'mj' ("make jump") --- function, and then it can be discharged using the 'ams' function. -type AddAnn = SrcSpan -> P () - -addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct - -> AnnKeywordId -- The first two parameters are the key - -> SrcSpan -- The location of the keyword itself - -> P () -addAnnotation l a v = do - addAnnotationOnly l a v - allocateComments l - -addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () -addAnnotationOnly l a v = P $ \s -> POk s { - annotations = ((l,a), [v]) : annotations s - } () - --- |Given a location and a list of AddAnn, apply them all to the location. -addAnnsAt :: SrcSpan -> [AddAnn] -> P () -addAnnsAt loc anns = mapM_ (\a -> a loc) anns - --- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate --- 'AddAnn' values for the opening and closing bordering on the start --- and end of the span -mkParensApiAnn :: SrcSpan -> [AddAnn] -mkParensApiAnn (UnhelpfulSpan _) = [] -mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc] - where - mj a l = (\s -> addAnnotation s a l) - f = srcSpanFile ss - sl = srcSpanStartLine ss - sc = srcSpanStartCol ss - el = srcSpanEndLine ss - ec = srcSpanEndCol ss - lo = mkSrcSpan (srcSpanStart s) (mkSrcLoc f sl (sc+1)) - lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s) - --- | Move the annotations and comments belonging to the @old@ span to the @new@ --- one. -moveAnnotations :: SrcSpan -> SrcSpan -> P () -moveAnnotations old new = P $ \s -> - let - updateAnn ((l,a),v) - | l == old = ((new,a),v) - | otherwise = ((l,a),v) - updateComment (l,c) - | l == old = (new,c) - | otherwise = (l,c) - in - POk s { - annotations = map updateAnn (annotations s) - , annotations_comments = map updateComment (annotations_comments s) - } () - -queueComment :: Located Token -> P() -queueComment c = P $ \s -> POk s { - comment_q = commentToAnnotation c : comment_q s - } () - --- | Go through the @comment_q@ in @PState@ and remove all comments --- that belong within the given span -allocateComments :: SrcSpan -> P () -allocateComments ss = P $ \s -> - let - (before,rest) = break (\(L l _) -> isSubspanOf l ss) (comment_q s) - (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest - comment_q' = before ++ after - newAnns = if null middle then [] - else [(ss,middle)] - in - POk s { - comment_q = comment_q' - , annotations_comments = newAnns ++ (annotations_comments s) - } () - -commentToAnnotation :: Located Token -> Located AnnotationComment -commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) -commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s) -commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s) -commentToAnnotation (L l (ITdocSection n s)) = L l (AnnDocSection n s) -commentToAnnotation (L l (ITdocOptions s)) = L l (AnnDocOptions s) -commentToAnnotation (L l (ITlineComment s)) = L l (AnnLineComment s) -commentToAnnotation (L l (ITblockComment s)) = L l (AnnBlockComment s) -commentToAnnotation _ = panic "commentToAnnotation" - --- --------------------------------------------------------------------- - -isComment :: Token -> Bool -isComment (ITlineComment _) = True -isComment (ITblockComment _) = True -isComment _ = False - -isDocComment :: Token -> Bool -isDocComment (ITdocCommentNext _) = True -isDocComment (ITdocCommentPrev _) = True -isDocComment (ITdocCommentNamed _) = True -isDocComment (ITdocSection _ _) = True -isDocComment (ITdocOptions _) = True -isDocComment _ = False - -{- Note [Warnings in code generated by Alex] - -We add the following warning suppression flags to all code generated by Alex: - -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -Without these flags, current versions of Alex will generate code that is not -warning free. Note that this is the result of Alex' internals, not of the way -we have written our (Lexer).x files. - -As always, we need code to be warning free when validating with -Werror. - -The list of flags is as short as possible (at the time of writing), to try to -avoid suppressing warnings for bugs in our own code. - -TODO. Reevaluate this situation once Alex >3.1.4 is released. Hopefully you -can remove these flags from all (Lexer).x files in the repository, and also -delete this Note. Don't forget to update aclocal.m4, and send a HEADS UP -message to ghc-devs. - -The first release of Alex after 3.1.4 will either suppress all warnings itself -[1] (bad), or most warnings will be fixed and only a few select ones will be -suppressed by default [2] (better). - -[1] https://github.com/simonmar/alex/commit/1eefcde22ba1bb9b51d523814415714e20f0761e -[2] https://github.com/simonmar/alex/pull/69 --} - - -bol,column_prag,layout,layout_do,layout_if,layout_left,line_prag1,line_prag1a,line_prag1b,line_prag2,line_prag2a,line_prag2b,option_prags :: Int -bol = 1 -column_prag = 2 -layout = 3 -layout_do = 4 -layout_if = 5 -layout_left = 6 -line_prag1 = 7 -line_prag1a = 8 -line_prag1b = 9 -line_prag2 = 10 -line_prag2a = 11 -line_prag2b = 12 -option_prags = 13 -alex_action_1 = warnTab -alex_action_2 = nested_comment lexToken -alex_action_3 = lineCommentToken -alex_action_4 = lineCommentToken -alex_action_5 = lineCommentToken -alex_action_6 = lineCommentToken -alex_action_7 = lineCommentToken -alex_action_8 = lineCommentToken -alex_action_10 = begin line_prag1 -alex_action_11 = begin line_prag1 -alex_action_14 = do_bol -alex_action_15 = hopefully_open_brace -alex_action_17 = begin line_prag1 -alex_action_18 = new_layout_context True dontGenerateSemic ITvbar -alex_action_19 = pop -alex_action_20 = new_layout_context True generateSemic ITvocurly -alex_action_21 = new_layout_context False generateSemic ITvocurly -alex_action_22 = do_layout_left -alex_action_23 = begin bol -alex_action_24 = dispatch_pragmas linePrags -alex_action_25 = setLine line_prag1a -alex_action_26 = setFile line_prag1b -alex_action_27 = pop -alex_action_28 = setLine line_prag2a -alex_action_29 = setFile line_prag2b -alex_action_30 = pop -alex_action_31 = setColumn -alex_action_32 = dispatch_pragmas twoWordPrags -alex_action_33 = dispatch_pragmas oneWordPrags -alex_action_34 = dispatch_pragmas ignoredPrags -alex_action_35 = endPrag -alex_action_36 = dispatch_pragmas fileHeaderPrags -alex_action_37 = nested_comment lexToken -alex_action_38 = warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma") - (nested_comment lexToken) -alex_action_39 = multiline_doc_comment -alex_action_40 = nested_doc_comment -alex_action_41 = token ITopabrack -alex_action_42 = token ITcpabrack -alex_action_43 = token (ITopenExpQuote NoE - NormalSyntax) -alex_action_44 = token (ITopenTExpQuote NoE) -alex_action_45 = token (ITopenExpQuote HasE - NormalSyntax) -alex_action_46 = token (ITopenTExpQuote HasE) -alex_action_47 = token ITopenPatQuote -alex_action_48 = layout_token ITopenDecQuote -alex_action_49 = token ITopenTypQuote -alex_action_50 = token (ITcloseQuote - NormalSyntax) -alex_action_51 = token ITcloseTExpQuote -alex_action_52 = skip_one_varid ITidEscape -alex_action_53 = skip_two_varid ITidTyEscape -alex_action_54 = token ITparenEscape -alex_action_55 = token ITparenTyEscape -alex_action_56 = lex_quasiquote_tok -alex_action_57 = lex_qquasiquote_tok -alex_action_58 = token (ITopenExpQuote NoE UnicodeSyntax) -alex_action_59 = token (ITcloseQuote UnicodeSyntax) -alex_action_60 = token ITtypeApp -alex_action_61 = special (IToparenbar NormalSyntax) -alex_action_62 = special (ITcparenbar NormalSyntax) -alex_action_63 = special (IToparenbar UnicodeSyntax) -alex_action_64 = special (ITcparenbar UnicodeSyntax) -alex_action_65 = skip_one_varid ITdupipvarid -alex_action_66 = skip_one_varid ITlabelvarid -alex_action_67 = token IToubxparen -alex_action_68 = token ITcubxparen -alex_action_69 = special IToparen -alex_action_70 = special ITcparen -alex_action_71 = special ITobrack -alex_action_72 = special ITcbrack -alex_action_73 = special ITcomma -alex_action_74 = special ITsemi -alex_action_75 = special ITbackquote -alex_action_76 = open_brace -alex_action_77 = close_brace -alex_action_78 = idtoken qvarid -alex_action_79 = idtoken qconid -alex_action_80 = varid -alex_action_81 = idtoken conid -alex_action_82 = idtoken qvarid -alex_action_83 = idtoken qconid -alex_action_84 = varid -alex_action_85 = idtoken conid -alex_action_86 = idtoken qvarsym -alex_action_87 = idtoken qconsym -alex_action_88 = varsym -alex_action_89 = consym -alex_action_90 = tok_num positive 0 0 decimal -alex_action_91 = tok_num positive 2 2 binary -alex_action_92 = tok_num positive 2 2 octal -alex_action_93 = tok_num positive 2 2 hexadecimal -alex_action_94 = tok_num negative 1 1 decimal -alex_action_95 = tok_num negative 3 3 binary -alex_action_96 = tok_num negative 3 3 octal -alex_action_97 = tok_num negative 3 3 hexadecimal -alex_action_98 = strtoken tok_float -alex_action_99 = strtoken tok_float -alex_action_100 = tok_primint positive 0 1 decimal -alex_action_101 = tok_primint positive 2 3 binary -alex_action_102 = tok_primint positive 2 3 octal -alex_action_103 = tok_primint positive 2 3 hexadecimal -alex_action_104 = tok_primint negative 1 2 decimal -alex_action_105 = tok_primint negative 3 4 binary -alex_action_106 = tok_primint negative 3 4 octal -alex_action_107 = tok_primint negative 3 4 hexadecimal -alex_action_108 = tok_primword 0 2 decimal -alex_action_109 = tok_primword 2 4 binary -alex_action_110 = tok_primword 2 4 octal -alex_action_111 = tok_primword 2 4 hexadecimal -alex_action_112 = init_strtoken 1 tok_primfloat -alex_action_113 = init_strtoken 2 tok_primdouble -alex_action_114 = lex_char_tok -alex_action_115 = lex_string_tok -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - - - - - - - - - - - - - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define GTE(n,m) (tagToEnum# (n >=# m)) -#define EQ(n,m) (tagToEnum# (n ==# m)) -#else -#define GTE(n,m) (n >=# m) -#define EQ(n,m) (n ==# m) -#endif - - - - - - - - - - - - - - - - - - - -data AlexAddr = AlexA# Addr# --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else - indexInt16OffAddr# arr off -#endif - - - - - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else - indexInt32OffAddr# arr off -#endif - - - - - - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - - - - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input__ (I# (sc)) - = alexScanUser undefined input__ (I# (sc)) - -alexScanUser user__ input__ (I# (sc)) - = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of - (AlexNone, input__') -> - case alexGetByte input__ of - Nothing -> - - - - AlexEOF - Just _ -> - - - - AlexError input__' - - (AlexLastSkip input__'' len, _) -> - - - - AlexSkip input__'' len - - (AlexLastAcc k input__''' len, _) -> - - - - AlexToken input__''' len (alex_actions ! k) - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user__ orig_input len input__ s last_acc = - input__ `seq` -- strict in the input - let - new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) - in - new_acc `seq` - case alexGetByte input__ of - Nothing -> (new_acc, input__) - Just (c, new_input) -> - - - - case fromIntegral c of { (I# (ord_c)) -> - let - base = alexIndexInt32OffAddr alex_base s - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if GTE(offset,0#) && EQ(check,ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - -1# -> (new_acc, input__) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) - -- note that the length is increased ONLY if this is the 1st byte in a char encoding) - new_input new_s new_acc - } - where - check_accs (AlexAccNone) = last_acc - check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) - check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) - - check_accs (AlexAccPred a predx rest) - | predx user__ orig_input (I# (len)) input__ - = AlexLastAcc a input__ (I# (len)) - | otherwise - = check_accs rest - check_accs (AlexAccSkipPred predx rest) - | predx user__ orig_input (I# (len)) input__ - = AlexLastSkip input__ (I# (len)) - | otherwise - = check_accs rest - - -data AlexLastAcc - = AlexNone - | AlexLastAcc !Int !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc user - = AlexAccNone - | AlexAcc Int - | AlexAccSkip - - | AlexAccPred Int (AlexAccPred user) (AlexAcc user) - | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user__ in1 len in2 - = p1 user__ in1 len in2 && p2 user__ in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ - -alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext (I# (sc)) user__ _ _ input__ = - case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. - diff --git a/dist/build/Parser.hs b/dist/build/Parser.hs deleted file mode 100644 --- a/dist/build/Parser.hs +++ /dev/null @@ -1,12373 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS -XMagicHash -XBangPatterns -XTypeSynonymInstances -XFlexibleInstances -cpp #-} -#if __GLASGOW_HASKELL__ >= 710 -{-# OPTIONS_GHC -XPartialTypeSignatures #-} -#endif --- | This module provides the generated Happy parser for Haskell. It exports --- a number of parsers which may be used in any library that uses the GHC API. --- A common usage pattern is to initialize the parser state with a given string --- and then parse that string: --- --- @ --- runParser :: DynFlags -> String -> P a -> ParseResult a --- runParser flags str parser = unP parser parseState --- where --- filename = "\" --- location = mkRealSrcLoc (mkFastString filename) 1 1 --- buffer = stringToStringBuffer str --- parseState = mkPState flags buffer location --- @ -module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBackpack, - parseDeclaration, parseExpression, parsePattern, - parseTypeSignature, - parseStmt, parseIdentifier, - parseType, parseHeader) where - --- base -import Control.Monad ( unless, liftM ) -import GHC.Exts -import Data.Char -import Control.Monad ( mplus ) -import Control.Applicative ((<$)) - --- compiler/hsSyn -import HsSyn - --- compiler/main -import HscTypes ( IsBootInterface, WarningTxt(..) ) -import DynFlags -import BkpSyn -import PackageConfig - --- compiler/utils -import OrdList -import BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue ) -import FastString -import Maybes ( orElse ) -import Outputable - --- compiler/basicTypes -import RdrName -import OccName ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) -import DataCon ( DataCon, dataConName ) -import SrcLoc -import Module -import BasicTypes - --- compiler/types -import Type ( funTyCon ) -import Kind ( Kind ) -import Class ( FunDep ) - --- compiler/parser -import RdrHsSyn -import Lexer -import HaddockUtils -import ApiAnnotation - --- compiler/typecheck -import TcEvidence ( emptyTcEvBinds ) - --- compiler/prelude -import ForeignCall -import TysPrim ( eqPrimTyCon ) -import PrelNames ( eqTyCon_RDR ) -import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, - unboxedUnitTyCon, unboxedUnitDataCon, - listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR ) - --- compiler/utils -import Util ( looksLikePackageName ) -import Prelude - -import qualified GHC.LanguageExtensions as LangExt -import qualified Data.Array as Happy_Data_Array -import qualified Data.Bits as Bits -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.9 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn16 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: ([LHsUnit PackageName]) -> (HappyAbsSyn ) -happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> ([LHsUnit PackageName]) -happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: (OrdList (LHsUnit PackageName)) -> (HappyAbsSyn ) -happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> (OrdList (LHsUnit PackageName)) -happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: (LHsUnit PackageName) -> (HappyAbsSyn ) -happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> (LHsUnit PackageName) -happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: (LHsUnitId PackageName) -> (HappyAbsSyn ) -happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> (LHsUnitId PackageName) -happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: (OrdList (LHsModuleSubst PackageName)) -> (HappyAbsSyn ) -happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> (OrdList (LHsModuleSubst PackageName)) -happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (LHsModuleSubst PackageName) -> (HappyAbsSyn ) -happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> (LHsModuleSubst PackageName) -happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyIn23 :: (LHsModuleId PackageName) -> (HappyAbsSyn ) -happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> (LHsModuleId PackageName) -happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut23 #-} -happyIn24 :: (Located PackageName) -> (HappyAbsSyn ) -happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> (Located PackageName) -happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut24 #-} -happyIn25 :: (Located FastString) -> (HappyAbsSyn ) -happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> (Located FastString) -happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut25 #-} -happyIn26 :: (Located FastString) -> (HappyAbsSyn ) -happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> (Located FastString) -happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut26 #-} -happyIn27 :: (Maybe [LRenaming]) -> (HappyAbsSyn ) -happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> (Maybe [LRenaming]) -happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut27 #-} -happyIn28 :: (OrdList LRenaming) -> (HappyAbsSyn ) -happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> (OrdList LRenaming) -happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut28 #-} -happyIn29 :: (LRenaming) -> (HappyAbsSyn ) -happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> (LRenaming) -happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut29 #-} -happyIn30 :: (OrdList (LHsUnitDecl PackageName)) -> (HappyAbsSyn ) -happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> (OrdList (LHsUnitDecl PackageName)) -happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut30 #-} -happyIn31 :: (OrdList (LHsUnitDecl PackageName)) -> (HappyAbsSyn ) -happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> (OrdList (LHsUnitDecl PackageName)) -happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut31 #-} -happyIn32 :: (LHsUnitDecl PackageName) -> (HappyAbsSyn ) -happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn ) -> (LHsUnitDecl PackageName) -happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut32 #-} -happyIn33 :: (Located (HsModule RdrName)) -> (HappyAbsSyn ) -happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn ) -> (Located (HsModule RdrName)) -happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut33 #-} -happyIn34 :: (Located (HsModule RdrName)) -> (HappyAbsSyn ) -happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> (Located (HsModule RdrName)) -happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut34 #-} -happyIn35 :: (Maybe LHsDocString) -> (HappyAbsSyn ) -happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn ) -> (Maybe LHsDocString) -happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut35 #-} -happyIn36 :: (()) -> (HappyAbsSyn ) -happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> (()) -happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut36 #-} -happyIn37 :: (()) -> (HappyAbsSyn ) -happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> (()) -happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut37 #-} -happyIn38 :: (Maybe (Located WarningTxt)) -> (HappyAbsSyn ) -happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn ) -> (Maybe (Located WarningTxt)) -happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut38 #-} -happyIn39 :: (([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName]))) -> (HappyAbsSyn ) -happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn ) -> (([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName]))) -happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut39 #-} -happyIn40 :: (([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName]))) -> (HappyAbsSyn ) -happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn ) -> (([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName]))) -happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut40 #-} -happyIn41 :: (([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName]))) -> (HappyAbsSyn ) -happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn ) -> (([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName]))) -happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut41 #-} -happyIn42 :: (([LImportDecl RdrName], [LHsDecl RdrName])) -> (HappyAbsSyn ) -happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn ) -> (([LImportDecl RdrName], [LHsDecl RdrName])) -happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut42 #-} -happyIn43 :: (Located (HsModule RdrName)) -> (HappyAbsSyn ) -happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn ) -> (Located (HsModule RdrName)) -happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut43 #-} -happyIn44 :: ([LImportDecl RdrName]) -> (HappyAbsSyn ) -happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) -happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut44 #-} -happyIn45 :: ([LImportDecl RdrName]) -> (HappyAbsSyn ) -happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) -happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut45 #-} -happyIn46 :: ([LImportDecl RdrName]) -> (HappyAbsSyn ) -happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) -happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut46 #-} -happyIn47 :: ([LImportDecl RdrName]) -> (HappyAbsSyn ) -happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) -happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut47 #-} -happyIn48 :: ((Maybe (Located [LIE RdrName]))) -> (HappyAbsSyn ) -happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn ) -> ((Maybe (Located [LIE RdrName]))) -happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut48 #-} -happyIn49 :: (OrdList (LIE RdrName)) -> (HappyAbsSyn ) -happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn ) -> (OrdList (LIE RdrName)) -happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut49 #-} -happyIn50 :: (OrdList (LIE RdrName)) -> (HappyAbsSyn ) -happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn ) -> (OrdList (LIE RdrName)) -happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut50 #-} -happyIn51 :: (OrdList (LIE RdrName)) -> (HappyAbsSyn ) -happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn ) -> (OrdList (LIE RdrName)) -happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut51 #-} -happyIn52 :: (OrdList (LIE RdrName)) -> (HappyAbsSyn ) -happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn ) -> (OrdList (LIE RdrName)) -happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut52 #-} -happyIn53 :: (OrdList (LIE RdrName)) -> (HappyAbsSyn ) -happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn53 #-} -happyOut53 :: (HappyAbsSyn ) -> (OrdList (LIE RdrName)) -happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut53 #-} -happyIn54 :: (Located ([AddAnn],ImpExpSubSpec)) -> (HappyAbsSyn ) -happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn54 #-} -happyOut54 :: (HappyAbsSyn ) -> (Located ([AddAnn],ImpExpSubSpec)) -happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut54 #-} -happyIn55 :: (([AddAnn], [Located ImpExpQcSpec])) -> (HappyAbsSyn ) -happyIn55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn55 #-} -happyOut55 :: (HappyAbsSyn ) -> (([AddAnn], [Located ImpExpQcSpec])) -happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut55 #-} -happyIn56 :: (([AddAnn], [Located ImpExpQcSpec])) -> (HappyAbsSyn ) -happyIn56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn56 #-} -happyOut56 :: (HappyAbsSyn ) -> (([AddAnn], [Located ImpExpQcSpec])) -happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut56 #-} -happyIn57 :: (Located ([AddAnn], Located ImpExpQcSpec)) -> (HappyAbsSyn ) -happyIn57 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn57 #-} -happyOut57 :: (HappyAbsSyn ) -> (Located ([AddAnn], Located ImpExpQcSpec)) -happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut57 #-} -happyIn58 :: (Located ImpExpQcSpec) -> (HappyAbsSyn ) -happyIn58 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn58 #-} -happyOut58 :: (HappyAbsSyn ) -> (Located ImpExpQcSpec) -happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut58 #-} -happyIn59 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn59 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn59 #-} -happyOut59 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut59 #-} -happyIn60 :: ([AddAnn]) -> (HappyAbsSyn ) -happyIn60 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn60 #-} -happyOut60 :: (HappyAbsSyn ) -> ([AddAnn]) -happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut60 #-} -happyIn61 :: ([AddAnn]) -> (HappyAbsSyn ) -happyIn61 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn61 #-} -happyOut61 :: (HappyAbsSyn ) -> ([AddAnn]) -happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut61 #-} -happyIn62 :: ([LImportDecl RdrName]) -> (HappyAbsSyn ) -happyIn62 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn62 #-} -happyOut62 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) -happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut62 #-} -happyIn63 :: ([LImportDecl RdrName]) -> (HappyAbsSyn ) -happyIn63 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn63 #-} -happyOut63 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) -happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut63 #-} -happyIn64 :: (LImportDecl RdrName) -> (HappyAbsSyn ) -happyIn64 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn64 #-} -happyOut64 :: (HappyAbsSyn ) -> (LImportDecl RdrName) -happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut64 #-} -happyIn65 :: ((([AddAnn],SourceText),IsBootInterface)) -> (HappyAbsSyn ) -happyIn65 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn65 #-} -happyOut65 :: (HappyAbsSyn ) -> ((([AddAnn],SourceText),IsBootInterface)) -happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut65 #-} -happyIn66 :: (([AddAnn],Bool)) -> (HappyAbsSyn ) -happyIn66 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn66 #-} -happyOut66 :: (HappyAbsSyn ) -> (([AddAnn],Bool)) -happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut66 #-} -happyIn67 :: (([AddAnn],Maybe StringLiteral)) -> (HappyAbsSyn ) -happyIn67 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn67 #-} -happyOut67 :: (HappyAbsSyn ) -> (([AddAnn],Maybe StringLiteral)) -happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut67 #-} -happyIn68 :: (([AddAnn],Bool)) -> (HappyAbsSyn ) -happyIn68 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn68 #-} -happyOut68 :: (HappyAbsSyn ) -> (([AddAnn],Bool)) -happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut68 #-} -happyIn69 :: (([AddAnn],Located (Maybe (Located ModuleName)))) -> (HappyAbsSyn ) -happyIn69 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn69 #-} -happyOut69 :: (HappyAbsSyn ) -> (([AddAnn],Located (Maybe (Located ModuleName)))) -happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut69 #-} -happyIn70 :: (Located (Maybe (Bool, Located [LIE RdrName]))) -> (HappyAbsSyn ) -happyIn70 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn70 #-} -happyOut70 :: (HappyAbsSyn ) -> (Located (Maybe (Bool, Located [LIE RdrName]))) -happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut70 #-} -happyIn71 :: (Located (Bool, Located [LIE RdrName])) -> (HappyAbsSyn ) -happyIn71 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn71 #-} -happyOut71 :: (HappyAbsSyn ) -> (Located (Bool, Located [LIE RdrName])) -happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut71 #-} -happyIn72 :: (Located (SourceText,Int)) -> (HappyAbsSyn ) -happyIn72 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn72 #-} -happyOut72 :: (HappyAbsSyn ) -> (Located (SourceText,Int)) -happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut72 #-} -happyIn73 :: (Located FixityDirection) -> (HappyAbsSyn ) -happyIn73 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn73 #-} -happyOut73 :: (HappyAbsSyn ) -> (Located FixityDirection) -happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut73 #-} -happyIn74 :: (Located (OrdList (Located RdrName))) -> (HappyAbsSyn ) -happyIn74 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn74 #-} -happyOut74 :: (HappyAbsSyn ) -> (Located (OrdList (Located RdrName))) -happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut74 #-} -happyIn75 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) -happyIn75 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn75 #-} -happyOut75 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) -happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut75 #-} -happyIn76 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) -happyIn76 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn76 #-} -happyOut76 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) -happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut76 #-} -happyIn77 :: (LHsDecl RdrName) -> (HappyAbsSyn ) -happyIn77 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn77 #-} -happyOut77 :: (HappyAbsSyn ) -> (LHsDecl RdrName) -happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut77 #-} -happyIn78 :: (LTyClDecl RdrName) -> (HappyAbsSyn ) -happyIn78 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn78 #-} -happyOut78 :: (HappyAbsSyn ) -> (LTyClDecl RdrName) -happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut78 #-} -happyIn79 :: (LTyClDecl RdrName) -> (HappyAbsSyn ) -happyIn79 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn79 #-} -happyOut79 :: (HappyAbsSyn ) -> (LTyClDecl RdrName) -happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut79 #-} -happyIn80 :: (LInstDecl RdrName) -> (HappyAbsSyn ) -happyIn80 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn80 #-} -happyOut80 :: (HappyAbsSyn ) -> (LInstDecl RdrName) -happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut80 #-} -happyIn81 :: (Maybe (Located OverlapMode)) -> (HappyAbsSyn ) -happyIn81 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn81 #-} -happyOut81 :: (HappyAbsSyn ) -> (Maybe (Located OverlapMode)) -happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut81 #-} -happyIn82 :: (Maybe (Located DerivStrategy)) -> (HappyAbsSyn ) -happyIn82 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn82 #-} -happyOut82 :: (HappyAbsSyn ) -> (Maybe (Located DerivStrategy)) -happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut82 #-} -happyIn83 :: (Located ([AddAnn], Maybe (LInjectivityAnn RdrName))) -> (HappyAbsSyn ) -happyIn83 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn83 #-} -happyOut83 :: (HappyAbsSyn ) -> (Located ([AddAnn], Maybe (LInjectivityAnn RdrName))) -happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut83 #-} -happyIn84 :: (LInjectivityAnn RdrName) -> (HappyAbsSyn ) -happyIn84 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn84 #-} -happyOut84 :: (HappyAbsSyn ) -> (LInjectivityAnn RdrName) -happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut84 #-} -happyIn85 :: (Located [Located RdrName]) -> (HappyAbsSyn ) -happyIn85 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn85 #-} -happyOut85 :: (HappyAbsSyn ) -> (Located [Located RdrName]) -happyOut85 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut85 #-} -happyIn86 :: (Located ([AddAnn],FamilyInfo RdrName)) -> (HappyAbsSyn ) -happyIn86 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn86 #-} -happyOut86 :: (HappyAbsSyn ) -> (Located ([AddAnn],FamilyInfo RdrName)) -happyOut86 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut86 #-} -happyIn87 :: (Located ([AddAnn],Maybe [LTyFamInstEqn RdrName])) -> (HappyAbsSyn ) -happyIn87 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn87 #-} -happyOut87 :: (HappyAbsSyn ) -> (Located ([AddAnn],Maybe [LTyFamInstEqn RdrName])) -happyOut87 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut87 #-} -happyIn88 :: (Located [LTyFamInstEqn RdrName]) -> (HappyAbsSyn ) -happyIn88 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn88 #-} -happyOut88 :: (HappyAbsSyn ) -> (Located [LTyFamInstEqn RdrName]) -happyOut88 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut88 #-} -happyIn89 :: (Located ([AddAnn],LTyFamInstEqn RdrName)) -> (HappyAbsSyn ) -happyIn89 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn89 #-} -happyOut89 :: (HappyAbsSyn ) -> (Located ([AddAnn],LTyFamInstEqn RdrName)) -happyOut89 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut89 #-} -happyIn90 :: (LHsDecl RdrName) -> (HappyAbsSyn ) -happyIn90 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn90 #-} -happyOut90 :: (HappyAbsSyn ) -> (LHsDecl RdrName) -happyOut90 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut90 #-} -happyIn91 :: ([AddAnn]) -> (HappyAbsSyn ) -happyIn91 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn91 #-} -happyOut91 :: (HappyAbsSyn ) -> ([AddAnn]) -happyOut91 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut91 #-} -happyIn92 :: (LInstDecl RdrName) -> (HappyAbsSyn ) -happyIn92 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn92 #-} -happyOut92 :: (HappyAbsSyn ) -> (LInstDecl RdrName) -happyOut92 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut92 #-} -happyIn93 :: (Located (AddAnn, NewOrData)) -> (HappyAbsSyn ) -happyIn93 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn93 #-} -happyOut93 :: (HappyAbsSyn ) -> (Located (AddAnn, NewOrData)) -happyOut93 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut93 #-} -happyIn94 :: (Located ([AddAnn], Maybe (LHsKind RdrName))) -> (HappyAbsSyn ) -happyIn94 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn94 #-} -happyOut94 :: (HappyAbsSyn ) -> (Located ([AddAnn], Maybe (LHsKind RdrName))) -happyOut94 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut94 #-} -happyIn95 :: (Located ([AddAnn], LFamilyResultSig RdrName)) -> (HappyAbsSyn ) -happyIn95 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn95 #-} -happyOut95 :: (HappyAbsSyn ) -> (Located ([AddAnn], LFamilyResultSig RdrName)) -happyOut95 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut95 #-} -happyIn96 :: (Located ([AddAnn], LFamilyResultSig RdrName)) -> (HappyAbsSyn ) -happyIn96 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn96 #-} -happyOut96 :: (HappyAbsSyn ) -> (Located ([AddAnn], LFamilyResultSig RdrName)) -happyOut96 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut96 #-} -happyIn97 :: (Located ([AddAnn], ( LFamilyResultSig RdrName - , Maybe (LInjectivityAnn RdrName)))) -> (HappyAbsSyn ) -happyIn97 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn97 #-} -happyOut97 :: (HappyAbsSyn ) -> (Located ([AddAnn], ( LFamilyResultSig RdrName - , Maybe (LInjectivityAnn RdrName)))) -happyOut97 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut97 #-} -happyIn98 :: (Located (Maybe (LHsContext RdrName), LHsType RdrName)) -> (HappyAbsSyn ) -happyIn98 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn98 #-} -happyOut98 :: (HappyAbsSyn ) -> (Located (Maybe (LHsContext RdrName), LHsType RdrName)) -happyOut98 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut98 #-} -happyIn99 :: (Maybe (Located CType)) -> (HappyAbsSyn ) -happyIn99 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn99 #-} -happyOut99 :: (HappyAbsSyn ) -> (Maybe (Located CType)) -happyOut99 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut99 #-} -happyIn100 :: (LDerivDecl RdrName) -> (HappyAbsSyn ) -happyIn100 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn100 #-} -happyOut100 :: (HappyAbsSyn ) -> (LDerivDecl RdrName) -happyOut100 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut100 #-} -happyIn101 :: (LRoleAnnotDecl RdrName) -> (HappyAbsSyn ) -happyIn101 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn101 #-} -happyOut101 :: (HappyAbsSyn ) -> (LRoleAnnotDecl RdrName) -happyOut101 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut101 #-} -happyIn102 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) -happyIn102 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn102 #-} -happyOut102 :: (HappyAbsSyn ) -> (Located [Located (Maybe FastString)]) -happyOut102 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut102 #-} -happyIn103 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) -happyIn103 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn103 #-} -happyOut103 :: (HappyAbsSyn ) -> (Located [Located (Maybe FastString)]) -happyOut103 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut103 #-} -happyIn104 :: (Located (Maybe FastString)) -> (HappyAbsSyn ) -happyIn104 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn104 #-} -happyOut104 :: (HappyAbsSyn ) -> (Located (Maybe FastString)) -happyOut104 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut104 #-} -happyIn105 :: (LHsDecl RdrName) -> (HappyAbsSyn ) -happyIn105 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn105 #-} -happyOut105 :: (HappyAbsSyn ) -> (LHsDecl RdrName) -happyOut105 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut105 #-} -happyIn106 :: ((Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn])) -> (HappyAbsSyn ) -happyIn106 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn106 #-} -happyOut106 :: (HappyAbsSyn ) -> ((Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn])) -happyOut106 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut106 #-} -happyIn107 :: ([Located RdrName]) -> (HappyAbsSyn ) -happyIn107 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn107 #-} -happyOut107 :: (HappyAbsSyn ) -> ([Located RdrName]) -happyOut107 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut107 #-} -happyIn108 :: ([RecordPatSynField (Located RdrName)]) -> (HappyAbsSyn ) -happyIn108 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn108 #-} -happyOut108 :: (HappyAbsSyn ) -> ([RecordPatSynField (Located RdrName)]) -happyOut108 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut108 #-} -happyIn109 :: (Located ([AddAnn] - , Located (OrdList (LHsDecl RdrName)))) -> (HappyAbsSyn ) -happyIn109 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn109 #-} -happyOut109 :: (HappyAbsSyn ) -> (Located ([AddAnn] - , Located (OrdList (LHsDecl RdrName)))) -happyOut109 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut109 #-} -happyIn110 :: (LSig RdrName) -> (HappyAbsSyn ) -happyIn110 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn110 #-} -happyOut110 :: (HappyAbsSyn ) -> (LSig RdrName) -happyOut110 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut110 #-} -happyIn111 :: (LHsDecl RdrName) -> (HappyAbsSyn ) -happyIn111 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn111 #-} -happyOut111 :: (HappyAbsSyn ) -> (LHsDecl RdrName) -happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut111 #-} -happyIn112 :: (Located ([AddAnn],OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) -happyIn112 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn112 #-} -happyOut112 :: (HappyAbsSyn ) -> (Located ([AddAnn],OrdList (LHsDecl RdrName))) -happyOut112 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut112 #-} -happyIn113 :: (Located ([AddAnn] - , OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) -happyIn113 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn113 #-} -happyOut113 :: (HappyAbsSyn ) -> (Located ([AddAnn] - , OrdList (LHsDecl RdrName))) -happyOut113 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut113 #-} -happyIn114 :: (Located ([AddAnn] - ,(OrdList (LHsDecl RdrName)))) -> (HappyAbsSyn ) -happyIn114 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn114 #-} -happyOut114 :: (HappyAbsSyn ) -> (Located ([AddAnn] - ,(OrdList (LHsDecl RdrName)))) -happyOut114 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut114 #-} -happyIn115 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) -happyIn115 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn115 #-} -happyOut115 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) -happyOut115 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut115 #-} -happyIn116 :: (Located ([AddAnn],OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) -happyIn116 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn116 #-} -happyOut116 :: (HappyAbsSyn ) -> (Located ([AddAnn],OrdList (LHsDecl RdrName))) -happyOut116 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut116 #-} -happyIn117 :: (Located ([AddAnn] - , OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) -happyIn117 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn117 #-} -happyOut117 :: (HappyAbsSyn ) -> (Located ([AddAnn] - , OrdList (LHsDecl RdrName))) -happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut117 #-} -happyIn118 :: (Located ([AddAnn] - , OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) -happyIn118 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn118 #-} -happyOut118 :: (HappyAbsSyn ) -> (Located ([AddAnn] - , OrdList (LHsDecl RdrName))) -happyOut118 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut118 #-} -happyIn119 :: (Located ([AddAnn],OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) -happyIn119 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn119 #-} -happyOut119 :: (HappyAbsSyn ) -> (Located ([AddAnn],OrdList (LHsDecl RdrName))) -happyOut119 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut119 #-} -happyIn120 :: (Located ([AddAnn],Located (OrdList (LHsDecl RdrName)))) -> (HappyAbsSyn ) -happyIn120 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn120 #-} -happyOut120 :: (HappyAbsSyn ) -> (Located ([AddAnn],Located (OrdList (LHsDecl RdrName)))) -happyOut120 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut120 #-} -happyIn121 :: (Located ([AddAnn],Located (HsLocalBinds RdrName))) -> (HappyAbsSyn ) -happyIn121 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn121 #-} -happyOut121 :: (HappyAbsSyn ) -> (Located ([AddAnn],Located (HsLocalBinds RdrName))) -happyOut121 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut121 #-} -happyIn122 :: (Located ([AddAnn],Located (HsLocalBinds RdrName))) -> (HappyAbsSyn ) -happyIn122 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn122 #-} -happyOut122 :: (HappyAbsSyn ) -> (Located ([AddAnn],Located (HsLocalBinds RdrName))) -happyOut122 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut122 #-} -happyIn123 :: (OrdList (LRuleDecl RdrName)) -> (HappyAbsSyn ) -happyIn123 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn123 #-} -happyOut123 :: (HappyAbsSyn ) -> (OrdList (LRuleDecl RdrName)) -happyOut123 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut123 #-} -happyIn124 :: (LRuleDecl RdrName) -> (HappyAbsSyn ) -happyIn124 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn124 #-} -happyOut124 :: (HappyAbsSyn ) -> (LRuleDecl RdrName) -happyOut124 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut124 #-} -happyIn125 :: (([AddAnn],Maybe Activation)) -> (HappyAbsSyn ) -happyIn125 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn125 #-} -happyOut125 :: (HappyAbsSyn ) -> (([AddAnn],Maybe Activation)) -happyOut125 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut125 #-} -happyIn126 :: (([AddAnn] - ,Activation)) -> (HappyAbsSyn ) -happyIn126 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn126 #-} -happyOut126 :: (HappyAbsSyn ) -> (([AddAnn] - ,Activation)) -happyOut126 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut126 #-} -happyIn127 :: (([AddAnn],[LRuleBndr RdrName])) -> (HappyAbsSyn ) -happyIn127 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn127 #-} -happyOut127 :: (HappyAbsSyn ) -> (([AddAnn],[LRuleBndr RdrName])) -happyOut127 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut127 #-} -happyIn128 :: ([LRuleBndr RdrName]) -> (HappyAbsSyn ) -happyIn128 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn128 #-} -happyOut128 :: (HappyAbsSyn ) -> ([LRuleBndr RdrName]) -happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut128 #-} -happyIn129 :: (LRuleBndr RdrName) -> (HappyAbsSyn ) -happyIn129 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn129 #-} -happyOut129 :: (HappyAbsSyn ) -> (LRuleBndr RdrName) -happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut129 #-} -happyIn130 :: (OrdList (LWarnDecl RdrName)) -> (HappyAbsSyn ) -happyIn130 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn130 #-} -happyOut130 :: (HappyAbsSyn ) -> (OrdList (LWarnDecl RdrName)) -happyOut130 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut130 #-} -happyIn131 :: (OrdList (LWarnDecl RdrName)) -> (HappyAbsSyn ) -happyIn131 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn131 #-} -happyOut131 :: (HappyAbsSyn ) -> (OrdList (LWarnDecl RdrName)) -happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut131 #-} -happyIn132 :: (OrdList (LWarnDecl RdrName)) -> (HappyAbsSyn ) -happyIn132 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn132 #-} -happyOut132 :: (HappyAbsSyn ) -> (OrdList (LWarnDecl RdrName)) -happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut132 #-} -happyIn133 :: (OrdList (LWarnDecl RdrName)) -> (HappyAbsSyn ) -happyIn133 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn133 #-} -happyOut133 :: (HappyAbsSyn ) -> (OrdList (LWarnDecl RdrName)) -happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut133 #-} -happyIn134 :: (Located ([AddAnn],[Located StringLiteral])) -> (HappyAbsSyn ) -happyIn134 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn134 #-} -happyOut134 :: (HappyAbsSyn ) -> (Located ([AddAnn],[Located StringLiteral])) -happyOut134 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut134 #-} -happyIn135 :: (Located (OrdList (Located StringLiteral))) -> (HappyAbsSyn ) -happyIn135 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn135 #-} -happyOut135 :: (HappyAbsSyn ) -> (Located (OrdList (Located StringLiteral))) -happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut135 #-} -happyIn136 :: (LHsDecl RdrName) -> (HappyAbsSyn ) -happyIn136 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn136 #-} -happyOut136 :: (HappyAbsSyn ) -> (LHsDecl RdrName) -happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut136 #-} -happyIn137 :: (Located ([AddAnn],HsDecl RdrName)) -> (HappyAbsSyn ) -happyIn137 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn137 #-} -happyOut137 :: (HappyAbsSyn ) -> (Located ([AddAnn],HsDecl RdrName)) -happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut137 #-} -happyIn138 :: (Located CCallConv) -> (HappyAbsSyn ) -happyIn138 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn138 #-} -happyOut138 :: (HappyAbsSyn ) -> (Located CCallConv) -happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut138 #-} -happyIn139 :: (Located Safety) -> (HappyAbsSyn ) -happyIn139 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn139 #-} -happyOut139 :: (HappyAbsSyn ) -> (Located Safety) -happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut139 #-} -happyIn140 :: (Located ([AddAnn] - ,(Located StringLiteral, Located RdrName, LHsSigType RdrName))) -> (HappyAbsSyn ) -happyIn140 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn140 #-} -happyOut140 :: (HappyAbsSyn ) -> (Located ([AddAnn] - ,(Located StringLiteral, Located RdrName, LHsSigType RdrName))) -happyOut140 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut140 #-} -happyIn141 :: (([AddAnn], Maybe (LHsType RdrName))) -> (HappyAbsSyn ) -happyIn141 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn141 #-} -happyOut141 :: (HappyAbsSyn ) -> (([AddAnn], Maybe (LHsType RdrName))) -happyOut141 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut141 #-} -happyIn142 :: (([AddAnn],Maybe (LHsType RdrName))) -> (HappyAbsSyn ) -happyIn142 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn142 #-} -happyOut142 :: (HappyAbsSyn ) -> (([AddAnn],Maybe (LHsType RdrName))) -happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut142 #-} -happyIn143 :: (([AddAnn], Maybe (Located RdrName))) -> (HappyAbsSyn ) -happyIn143 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn143 #-} -happyOut143 :: (HappyAbsSyn ) -> (([AddAnn], Maybe (Located RdrName))) -happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut143 #-} -happyIn144 :: (LHsType RdrName) -> (HappyAbsSyn ) -happyIn144 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn144 #-} -happyOut144 :: (HappyAbsSyn ) -> (LHsType RdrName) -happyOut144 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut144 #-} -happyIn145 :: (LHsType RdrName) -> (HappyAbsSyn ) -happyIn145 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn145 #-} -happyOut145 :: (HappyAbsSyn ) -> (LHsType RdrName) -happyOut145 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut145 #-} -happyIn146 :: (Located [Located RdrName]) -> (HappyAbsSyn ) -happyIn146 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn146 #-} -happyOut146 :: (HappyAbsSyn ) -> (Located [Located RdrName]) -happyOut146 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut146 #-} -happyIn147 :: ((OrdList (LHsSigType RdrName))) -> (HappyAbsSyn ) -happyIn147 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn147 #-} -happyOut147 :: (HappyAbsSyn ) -> ((OrdList (LHsSigType RdrName))) -happyOut147 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut147 #-} -happyIn148 :: (Located ([AddAnn],HsSrcBang)) -> (HappyAbsSyn ) -happyIn148 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn148 #-} -happyOut148 :: (HappyAbsSyn ) -> (Located ([AddAnn],HsSrcBang)) -happyOut148 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut148 #-} -happyIn149 :: (Located ([AddAnn], SrcStrictness)) -> (HappyAbsSyn ) -happyIn149 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn149 #-} -happyOut149 :: (HappyAbsSyn ) -> (Located ([AddAnn], SrcStrictness)) -happyOut149 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut149 #-} -happyIn150 :: (Located ([AddAnn], SourceText, SrcUnpackedness)) -> (HappyAbsSyn ) -happyIn150 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn150 #-} -happyOut150 :: (HappyAbsSyn ) -> (Located ([AddAnn], SourceText, SrcUnpackedness)) -happyOut150 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut150 #-} -happyIn151 :: (LHsType RdrName) -> (HappyAbsSyn ) -happyIn151 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn151 #-} -happyOut151 :: (HappyAbsSyn ) -> (LHsType RdrName) -happyOut151 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut151 #-} -happyIn152 :: (LHsType RdrName) -> (HappyAbsSyn ) -happyIn152 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn152 #-} -happyOut152 :: (HappyAbsSyn ) -> (LHsType RdrName) -happyOut152 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut152 #-} -happyIn153 :: (LHsContext RdrName) -> (HappyAbsSyn ) -happyIn153 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn153 #-} -happyOut153 :: (HappyAbsSyn ) -> (LHsContext RdrName) -happyOut153 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut153 #-} -happyIn154 :: (LHsContext RdrName) -> (HappyAbsSyn ) -happyIn154 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn154 #-} -happyOut154 :: (HappyAbsSyn ) -> (LHsContext RdrName) -happyOut154 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut154 #-} -happyIn155 :: (LHsType RdrName) -> (HappyAbsSyn ) -happyIn155 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn155 #-} -happyOut155 :: (HappyAbsSyn ) -> (LHsType RdrName) -happyOut155 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut155 #-} -happyIn156 :: (LHsType RdrName) -> (HappyAbsSyn ) -happyIn156 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn156 #-} -happyOut156 :: (HappyAbsSyn ) -> (LHsType RdrName) -happyOut156 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut156 #-} -happyIn157 :: (LHsType RdrName) -> (HappyAbsSyn ) -happyIn157 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn157 #-} -happyOut157 :: (HappyAbsSyn ) -> (LHsType RdrName) -happyOut157 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut157 #-} -happyIn158 :: (LHsType RdrName) -> (HappyAbsSyn ) -happyIn158 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn158 #-} -happyOut158 :: (HappyAbsSyn ) -> (LHsType RdrName) -happyOut158 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut158 #-} -happyIn159 :: (Located [LHsAppType RdrName]) -> (HappyAbsSyn ) -happyIn159 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn159 #-} -happyOut159 :: (HappyAbsSyn ) -> (Located [LHsAppType RdrName]) -happyOut159 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut159 #-} -happyIn160 :: (LHsAppType RdrName) -> (HappyAbsSyn ) -happyIn160 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn160 #-} -happyOut160 :: (HappyAbsSyn ) -> (LHsAppType RdrName) -happyOut160 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut160 #-} -happyIn161 :: (LHsType RdrName) -> (HappyAbsSyn ) -happyIn161 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn161 #-} -happyOut161 :: (HappyAbsSyn ) -> (LHsType RdrName) -happyOut161 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut161 #-} -happyIn162 :: (LHsSigType RdrName) -> (HappyAbsSyn ) -happyIn162 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn162 #-} -happyOut162 :: (HappyAbsSyn ) -> (LHsSigType RdrName) -happyOut162 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut162 #-} -happyIn163 :: ([LHsSigType RdrName]) -> (HappyAbsSyn ) -happyIn163 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn163 #-} -happyOut163 :: (HappyAbsSyn ) -> ([LHsSigType RdrName]) -happyOut163 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut163 #-} -happyIn164 :: ([LHsType RdrName]) -> (HappyAbsSyn ) -happyIn164 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn164 #-} -happyOut164 :: (HappyAbsSyn ) -> ([LHsType RdrName]) -happyOut164 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut164 #-} -happyIn165 :: ([LHsType RdrName]) -> (HappyAbsSyn ) -happyIn165 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn165 #-} -happyOut165 :: (HappyAbsSyn ) -> ([LHsType RdrName]) -happyOut165 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut165 #-} -happyIn166 :: ([LHsType RdrName]) -> (HappyAbsSyn ) -happyIn166 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn166 #-} -happyOut166 :: (HappyAbsSyn ) -> ([LHsType RdrName]) -happyOut166 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut166 #-} -happyIn167 :: ([LHsTyVarBndr RdrName]) -> (HappyAbsSyn ) -happyIn167 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn167 #-} -happyOut167 :: (HappyAbsSyn ) -> ([LHsTyVarBndr RdrName]) -happyOut167 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut167 #-} -happyIn168 :: (LHsTyVarBndr RdrName) -> (HappyAbsSyn ) -happyIn168 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn168 #-} -happyOut168 :: (HappyAbsSyn ) -> (LHsTyVarBndr RdrName) -happyOut168 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut168 #-} -happyIn169 :: (Located ([AddAnn],[Located (FunDep (Located RdrName))])) -> (HappyAbsSyn ) -happyIn169 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn169 #-} -happyOut169 :: (HappyAbsSyn ) -> (Located ([AddAnn],[Located (FunDep (Located RdrName))])) -happyOut169 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut169 #-} -happyIn170 :: (Located [Located (FunDep (Located RdrName))]) -> (HappyAbsSyn ) -happyIn170 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn170 #-} -happyOut170 :: (HappyAbsSyn ) -> (Located [Located (FunDep (Located RdrName))]) -happyOut170 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut170 #-} -happyIn171 :: (Located (FunDep (Located RdrName))) -> (HappyAbsSyn ) -happyIn171 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn171 #-} -happyOut171 :: (HappyAbsSyn ) -> (Located (FunDep (Located RdrName))) -happyOut171 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut171 #-} -happyIn172 :: (Located [Located RdrName]) -> (HappyAbsSyn ) -happyIn172 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn172 #-} -happyOut172 :: (HappyAbsSyn ) -> (Located [Located RdrName]) -happyOut172 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut172 #-} -happyIn173 :: (LHsKind RdrName) -> (HappyAbsSyn ) -happyIn173 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn173 #-} -happyOut173 :: (HappyAbsSyn ) -> (LHsKind RdrName) -happyOut173 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut173 #-} -happyIn174 :: (Located ([AddAnn] - ,[LConDecl RdrName])) -> (HappyAbsSyn ) -happyIn174 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn174 #-} -happyOut174 :: (HappyAbsSyn ) -> (Located ([AddAnn] - ,[LConDecl RdrName])) -happyOut174 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut174 #-} -happyIn175 :: (Located [LConDecl RdrName]) -> (HappyAbsSyn ) -happyIn175 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn175 #-} -happyOut175 :: (HappyAbsSyn ) -> (Located [LConDecl RdrName]) -happyOut175 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut175 #-} -happyIn176 :: (LConDecl RdrName) -> (HappyAbsSyn ) -happyIn176 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn176 #-} -happyOut176 :: (HappyAbsSyn ) -> (LConDecl RdrName) -happyOut176 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut176 #-} -happyIn177 :: (LConDecl RdrName) -> (HappyAbsSyn ) -happyIn177 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn177 #-} -happyOut177 :: (HappyAbsSyn ) -> (LConDecl RdrName) -happyOut177 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut177 #-} -happyIn178 :: (Located ([AddAnn],[LConDecl RdrName])) -> (HappyAbsSyn ) -happyIn178 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn178 #-} -happyOut178 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LConDecl RdrName])) -happyOut178 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut178 #-} -happyIn179 :: (Located [LConDecl RdrName]) -> (HappyAbsSyn ) -happyIn179 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn179 #-} -happyOut179 :: (HappyAbsSyn ) -> (Located [LConDecl RdrName]) -happyOut179 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut179 #-} -happyIn180 :: (LConDecl RdrName) -> (HappyAbsSyn ) -happyIn180 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn180 #-} -happyOut180 :: (HappyAbsSyn ) -> (LConDecl RdrName) -happyOut180 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut180 #-} -happyIn181 :: (Located ([AddAnn], Maybe [LHsTyVarBndr RdrName])) -> (HappyAbsSyn ) -happyIn181 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn181 #-} -happyOut181 :: (HappyAbsSyn ) -> (Located ([AddAnn], Maybe [LHsTyVarBndr RdrName])) -happyOut181 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut181 #-} -happyIn182 :: (Located (Located RdrName, HsConDeclDetails RdrName)) -> (HappyAbsSyn ) -happyIn182 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn182 #-} -happyOut182 :: (HappyAbsSyn ) -> (Located (Located RdrName, HsConDeclDetails RdrName)) -happyOut182 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut182 #-} -happyIn183 :: ([LConDeclField RdrName]) -> (HappyAbsSyn ) -happyIn183 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn183 #-} -happyOut183 :: (HappyAbsSyn ) -> ([LConDeclField RdrName]) -happyOut183 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut183 #-} -happyIn184 :: ([LConDeclField RdrName]) -> (HappyAbsSyn ) -happyIn184 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn184 #-} -happyOut184 :: (HappyAbsSyn ) -> ([LConDeclField RdrName]) -happyOut184 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut184 #-} -happyIn185 :: (LConDeclField RdrName) -> (HappyAbsSyn ) -happyIn185 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn185 #-} -happyOut185 :: (HappyAbsSyn ) -> (LConDeclField RdrName) -happyOut185 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut185 #-} -happyIn186 :: (HsDeriving RdrName) -> (HappyAbsSyn ) -happyIn186 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn186 #-} -happyOut186 :: (HappyAbsSyn ) -> (HsDeriving RdrName) -happyOut186 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut186 #-} -happyIn187 :: (HsDeriving RdrName) -> (HappyAbsSyn ) -happyIn187 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn187 #-} -happyOut187 :: (HappyAbsSyn ) -> (HsDeriving RdrName) -happyOut187 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut187 #-} -happyIn188 :: (LHsDerivingClause RdrName) -> (HappyAbsSyn ) -happyIn188 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn188 #-} -happyOut188 :: (HappyAbsSyn ) -> (LHsDerivingClause RdrName) -happyOut188 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut188 #-} -happyIn189 :: (LHsDecl RdrName) -> (HappyAbsSyn ) -happyIn189 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn189 #-} -happyOut189 :: (HappyAbsSyn ) -> (LHsDecl RdrName) -happyOut189 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut189 #-} -happyIn190 :: (LDocDecl) -> (HappyAbsSyn ) -happyIn190 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn190 #-} -happyOut190 :: (HappyAbsSyn ) -> (LDocDecl) -happyOut190 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut190 #-} -happyIn191 :: (LHsDecl RdrName) -> (HappyAbsSyn ) -happyIn191 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn191 #-} -happyOut191 :: (HappyAbsSyn ) -> (LHsDecl RdrName) -happyOut191 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut191 #-} -happyIn192 :: (LHsDecl RdrName) -> (HappyAbsSyn ) -happyIn192 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn192 #-} -happyOut192 :: (HappyAbsSyn ) -> (LHsDecl RdrName) -happyOut192 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut192 #-} -happyIn193 :: (Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName))) -> (HappyAbsSyn ) -happyIn193 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn193 #-} -happyOut193 :: (HappyAbsSyn ) -> (Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName))) -happyOut193 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut193 #-} -happyIn194 :: (Located [LGRHS RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) -happyIn194 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn194 #-} -happyOut194 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName (LHsExpr RdrName)]) -happyOut194 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut194 #-} -happyIn195 :: (LGRHS RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) -happyIn195 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn195 #-} -happyOut195 :: (HappyAbsSyn ) -> (LGRHS RdrName (LHsExpr RdrName)) -happyOut195 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut195 #-} -happyIn196 :: (LHsDecl RdrName) -> (HappyAbsSyn ) -happyIn196 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn196 #-} -happyOut196 :: (HappyAbsSyn ) -> (LHsDecl RdrName) -happyOut196 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut196 #-} -happyIn197 :: (([AddAnn],Maybe Activation)) -> (HappyAbsSyn ) -happyIn197 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn197 #-} -happyOut197 :: (HappyAbsSyn ) -> (([AddAnn],Maybe Activation)) -happyOut197 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut197 #-} -happyIn198 :: (([AddAnn],Activation)) -> (HappyAbsSyn ) -happyIn198 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn198 #-} -happyOut198 :: (HappyAbsSyn ) -> (([AddAnn],Activation)) -happyOut198 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut198 #-} -happyIn199 :: (Located (HsSplice RdrName)) -> (HappyAbsSyn ) -happyIn199 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn199 #-} -happyOut199 :: (HappyAbsSyn ) -> (Located (HsSplice RdrName)) -happyOut199 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut199 #-} -happyIn200 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn200 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn200 #-} -happyOut200 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut200 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut200 #-} -happyIn201 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn201 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn201 #-} -happyOut201 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut201 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut201 #-} -happyIn202 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn202 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn202 #-} -happyOut202 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut202 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut202 #-} -happyIn203 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn203 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn203 #-} -happyOut203 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut203 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut203 #-} -happyIn204 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn204 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn204 #-} -happyOut204 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut204 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut204 #-} -happyIn205 :: (([Located a],Bool)) -> (HappyAbsSyn ) -happyIn205 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn205 #-} -happyOut205 :: (HappyAbsSyn ) -> (([Located a],Bool)) -happyOut205 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut205 #-} -happyIn206 :: (Located (([AddAnn],SourceText),StringLiteral)) -> (HappyAbsSyn ) -happyIn206 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn206 #-} -happyOut206 :: (HappyAbsSyn ) -> (Located (([AddAnn],SourceText),StringLiteral)) -happyOut206 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut206 #-} -happyIn207 :: (Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))), - ((SourceText,SourceText),(SourceText,SourceText)) - )) -> (HappyAbsSyn ) -happyIn207 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn207 #-} -happyOut207 :: (HappyAbsSyn ) -> (Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))), - ((SourceText,SourceText),(SourceText,SourceText)) - )) -happyOut207 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut207 #-} -happyIn208 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn208 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn208 #-} -happyOut208 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut208 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut208 #-} -happyIn209 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn209 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn209 #-} -happyOut209 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut209 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut209 #-} -happyIn210 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn210 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn210 #-} -happyOut210 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut210 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut210 #-} -happyIn211 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn211 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn211 #-} -happyOut211 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut211 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut211 #-} -happyIn212 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn212 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn212 #-} -happyOut212 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut212 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut212 #-} -happyIn213 :: ([LHsCmdTop RdrName]) -> (HappyAbsSyn ) -happyIn213 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn213 #-} -happyOut213 :: (HappyAbsSyn ) -> ([LHsCmdTop RdrName]) -happyOut213 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut213 #-} -happyIn214 :: (LHsCmdTop RdrName) -> (HappyAbsSyn ) -happyIn214 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn214 #-} -happyOut214 :: (HappyAbsSyn ) -> (LHsCmdTop RdrName) -happyOut214 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut214 #-} -happyIn215 :: (([AddAnn],[LHsDecl RdrName])) -> (HappyAbsSyn ) -happyIn215 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn215 #-} -happyOut215 :: (HappyAbsSyn ) -> (([AddAnn],[LHsDecl RdrName])) -happyOut215 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut215 #-} -happyIn216 :: ([LHsDecl RdrName]) -> (HappyAbsSyn ) -happyIn216 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn216 #-} -happyOut216 :: (HappyAbsSyn ) -> ([LHsDecl RdrName]) -happyOut216 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut216 #-} -happyIn217 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn217 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn217 #-} -happyOut217 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut217 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut217 #-} -happyIn218 :: (([AddAnn],SumOrTuple)) -> (HappyAbsSyn ) -happyIn218 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn218 #-} -happyOut218 :: (HappyAbsSyn ) -> (([AddAnn],SumOrTuple)) -happyOut218 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut218 #-} -happyIn219 :: ((SrcSpan,[LHsTupArg RdrName])) -> (HappyAbsSyn ) -happyIn219 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn219 #-} -happyOut219 :: (HappyAbsSyn ) -> ((SrcSpan,[LHsTupArg RdrName])) -happyOut219 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut219 #-} -happyIn220 :: ([LHsTupArg RdrName]) -> (HappyAbsSyn ) -happyIn220 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn220 #-} -happyOut220 :: (HappyAbsSyn ) -> ([LHsTupArg RdrName]) -happyOut220 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut220 #-} -happyIn221 :: (([AddAnn],HsExpr RdrName)) -> (HappyAbsSyn ) -happyIn221 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn221 #-} -happyOut221 :: (HappyAbsSyn ) -> (([AddAnn],HsExpr RdrName)) -happyOut221 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut221 #-} -happyIn222 :: (Located [LHsExpr RdrName]) -> (HappyAbsSyn ) -happyIn222 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn222 #-} -happyOut222 :: (HappyAbsSyn ) -> (Located [LHsExpr RdrName]) -happyOut222 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut222 #-} -happyIn223 :: (Located [LStmt RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) -happyIn223 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn223 #-} -happyOut223 :: (HappyAbsSyn ) -> (Located [LStmt RdrName (LHsExpr RdrName)]) -happyOut223 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut223 #-} -happyIn224 :: (Located [[LStmt RdrName (LHsExpr RdrName)]]) -> (HappyAbsSyn ) -happyIn224 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn224 #-} -happyOut224 :: (HappyAbsSyn ) -> (Located [[LStmt RdrName (LHsExpr RdrName)]]) -happyOut224 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut224 #-} -happyIn225 :: (Located [LStmt RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) -happyIn225 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn225 #-} -happyOut225 :: (HappyAbsSyn ) -> (Located [LStmt RdrName (LHsExpr RdrName)]) -happyOut225 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut225 #-} -happyIn226 :: (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName))) -> (HappyAbsSyn ) -happyIn226 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn226 #-} -happyOut226 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName))) -happyOut226 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut226 #-} -happyIn227 :: (([AddAnn],HsExpr RdrName)) -> (HappyAbsSyn ) -happyIn227 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn227 #-} -happyOut227 :: (HappyAbsSyn ) -> (([AddAnn],HsExpr RdrName)) -happyOut227 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut227 #-} -happyIn228 :: (Located [LStmt RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) -happyIn228 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn228 #-} -happyOut228 :: (HappyAbsSyn ) -> (Located [LStmt RdrName (LHsExpr RdrName)]) -happyOut228 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut228 #-} -happyIn229 :: (Located [LStmt RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) -happyIn229 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn229 #-} -happyOut229 :: (HappyAbsSyn ) -> (Located [LStmt RdrName (LHsExpr RdrName)]) -happyOut229 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut229 #-} -happyIn230 :: (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) -happyIn230 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn230 #-} -happyOut230 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) -happyOut230 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut230 #-} -happyIn231 :: (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) -happyIn231 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn231 #-} -happyOut231 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) -happyOut231 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut231 #-} -happyIn232 :: (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) -happyIn232 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn232 #-} -happyOut232 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) -happyOut232 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut232 #-} -happyIn233 :: (LMatch RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) -happyIn233 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn233 #-} -happyOut233 :: (HappyAbsSyn ) -> (LMatch RdrName (LHsExpr RdrName)) -happyOut233 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut233 #-} -happyIn234 :: (Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName))) -> (HappyAbsSyn ) -happyIn234 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn234 #-} -happyOut234 :: (HappyAbsSyn ) -> (Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName))) -happyOut234 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut234 #-} -happyIn235 :: (Located [LGRHS RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) -happyIn235 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn235 #-} -happyOut235 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName (LHsExpr RdrName)]) -happyOut235 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut235 #-} -happyIn236 :: (Located [LGRHS RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) -happyIn236 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn236 #-} -happyOut236 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName (LHsExpr RdrName)]) -happyOut236 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut236 #-} -happyIn237 :: (Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) -happyIn237 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn237 #-} -happyOut237 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)])) -happyOut237 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut237 #-} -happyIn238 :: (LGRHS RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) -happyIn238 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn238 #-} -happyOut238 :: (HappyAbsSyn ) -> (LGRHS RdrName (LHsExpr RdrName)) -happyOut238 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut238 #-} -happyIn239 :: (LPat RdrName) -> (HappyAbsSyn ) -happyIn239 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn239 #-} -happyOut239 :: (HappyAbsSyn ) -> (LPat RdrName) -happyOut239 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut239 #-} -happyIn240 :: (LPat RdrName) -> (HappyAbsSyn ) -happyIn240 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn240 #-} -happyOut240 :: (HappyAbsSyn ) -> (LPat RdrName) -happyOut240 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut240 #-} -happyIn241 :: (LPat RdrName) -> (HappyAbsSyn ) -happyIn241 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn241 #-} -happyOut241 :: (HappyAbsSyn ) -> (LPat RdrName) -happyOut241 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut241 #-} -happyIn242 :: ([LPat RdrName]) -> (HappyAbsSyn ) -happyIn242 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn242 #-} -happyOut242 :: (HappyAbsSyn ) -> ([LPat RdrName]) -happyOut242 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut242 #-} -happyIn243 :: (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) -happyIn243 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn243 #-} -happyOut243 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)])) -happyOut243 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut243 #-} -happyIn244 :: (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) -happyIn244 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn244 #-} -happyOut244 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)])) -happyOut244 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut244 #-} -happyIn245 :: (Maybe (LStmt RdrName (LHsExpr RdrName))) -> (HappyAbsSyn ) -happyIn245 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn245 #-} -happyOut245 :: (HappyAbsSyn ) -> (Maybe (LStmt RdrName (LHsExpr RdrName))) -happyOut245 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut245 #-} -happyIn246 :: (LStmt RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) -happyIn246 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn246 #-} -happyOut246 :: (HappyAbsSyn ) -> (LStmt RdrName (LHsExpr RdrName)) -happyOut246 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut246 #-} -happyIn247 :: (LStmt RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) -happyIn247 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn247 #-} -happyOut247 :: (HappyAbsSyn ) -> (LStmt RdrName (LHsExpr RdrName)) -happyOut247 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut247 #-} -happyIn248 :: (([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool))) -> (HappyAbsSyn ) -happyIn248 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn248 #-} -happyOut248 :: (HappyAbsSyn ) -> (([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool))) -happyOut248 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut248 #-} -happyIn249 :: (([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool))) -> (HappyAbsSyn ) -happyIn249 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn249 #-} -happyOut249 :: (HappyAbsSyn ) -> (([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool))) -happyOut249 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut249 #-} -happyIn250 :: (LHsRecField RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) -happyIn250 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn250 #-} -happyOut250 :: (HappyAbsSyn ) -> (LHsRecField RdrName (LHsExpr RdrName)) -happyOut250 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut250 #-} -happyIn251 :: (Located [LIPBind RdrName]) -> (HappyAbsSyn ) -happyIn251 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn251 #-} -happyOut251 :: (HappyAbsSyn ) -> (Located [LIPBind RdrName]) -happyOut251 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut251 #-} -happyIn252 :: (LIPBind RdrName) -> (HappyAbsSyn ) -happyIn252 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn252 #-} -happyOut252 :: (HappyAbsSyn ) -> (LIPBind RdrName) -happyOut252 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut252 #-} -happyIn253 :: (Located HsIPName) -> (HappyAbsSyn ) -happyIn253 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn253 #-} -happyOut253 :: (HappyAbsSyn ) -> (Located HsIPName) -happyOut253 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut253 #-} -happyIn254 :: (Located FastString) -> (HappyAbsSyn ) -happyIn254 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn254 #-} -happyOut254 :: (HappyAbsSyn ) -> (Located FastString) -happyOut254 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut254 #-} -happyIn255 :: (LBooleanFormula (Located RdrName)) -> (HappyAbsSyn ) -happyIn255 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn255 #-} -happyOut255 :: (HappyAbsSyn ) -> (LBooleanFormula (Located RdrName)) -happyOut255 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut255 #-} -happyIn256 :: (LBooleanFormula (Located RdrName)) -> (HappyAbsSyn ) -happyIn256 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn256 #-} -happyOut256 :: (HappyAbsSyn ) -> (LBooleanFormula (Located RdrName)) -happyOut256 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut256 #-} -happyIn257 :: (LBooleanFormula (Located RdrName)) -> (HappyAbsSyn ) -happyIn257 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn257 #-} -happyOut257 :: (HappyAbsSyn ) -> (LBooleanFormula (Located RdrName)) -happyOut257 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut257 #-} -happyIn258 :: ([LBooleanFormula (Located RdrName)]) -> (HappyAbsSyn ) -happyIn258 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn258 #-} -happyOut258 :: (HappyAbsSyn ) -> ([LBooleanFormula (Located RdrName)]) -happyOut258 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut258 #-} -happyIn259 :: (LBooleanFormula (Located RdrName)) -> (HappyAbsSyn ) -happyIn259 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn259 #-} -happyOut259 :: (HappyAbsSyn ) -> (LBooleanFormula (Located RdrName)) -happyOut259 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut259 #-} -happyIn260 :: (Located [Located RdrName]) -> (HappyAbsSyn ) -happyIn260 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn260 #-} -happyOut260 :: (HappyAbsSyn ) -> (Located [Located RdrName]) -happyOut260 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut260 #-} -happyIn261 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn261 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn261 #-} -happyOut261 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut261 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut261 #-} -happyIn262 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn262 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn262 #-} -happyOut262 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut262 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut262 #-} -happyIn263 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn263 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn263 #-} -happyOut263 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut263 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut263 #-} -happyIn264 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn264 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn264 #-} -happyOut264 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut264 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut264 #-} -happyIn265 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn265 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn265 #-} -happyOut265 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut265 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut265 #-} -happyIn266 :: (Located [Located RdrName]) -> (HappyAbsSyn ) -happyIn266 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn266 #-} -happyOut266 :: (HappyAbsSyn ) -> (Located [Located RdrName]) -happyOut266 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut266 #-} -happyIn267 :: (Located DataCon) -> (HappyAbsSyn ) -happyIn267 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn267 #-} -happyOut267 :: (HappyAbsSyn ) -> (Located DataCon) -happyOut267 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut267 #-} -happyIn268 :: (Located DataCon) -> (HappyAbsSyn ) -happyIn268 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn268 #-} -happyOut268 :: (HappyAbsSyn ) -> (Located DataCon) -happyOut268 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut268 #-} -happyIn269 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn269 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn269 #-} -happyOut269 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut269 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut269 #-} -happyIn270 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn270 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn270 #-} -happyOut270 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut270 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut270 #-} -happyIn271 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn271 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn271 #-} -happyOut271 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut271 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut271 #-} -happyIn272 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn272 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn272 #-} -happyOut272 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut272 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut272 #-} -happyIn273 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn273 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn273 #-} -happyOut273 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut273 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut273 #-} -happyIn274 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn274 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn274 #-} -happyOut274 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut274 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut274 #-} -happyIn275 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn275 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn275 #-} -happyOut275 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut275 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut275 #-} -happyIn276 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn276 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn276 #-} -happyOut276 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut276 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut276 #-} -happyIn277 :: (LHsType RdrName) -> (HappyAbsSyn ) -happyIn277 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn277 #-} -happyOut277 :: (HappyAbsSyn ) -> (LHsType RdrName) -happyOut277 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut277 #-} -happyIn278 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn278 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn278 #-} -happyOut278 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut278 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut278 #-} -happyIn279 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn279 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn279 #-} -happyOut279 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut279 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut279 #-} -happyIn280 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn280 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn280 #-} -happyOut280 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut280 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut280 #-} -happyIn281 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn281 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn281 #-} -happyOut281 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut281 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut281 #-} -happyIn282 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn282 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn282 #-} -happyOut282 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut282 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut282 #-} -happyIn283 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn283 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn283 #-} -happyOut283 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut283 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut283 #-} -happyIn284 :: (LHsExpr RdrName) -> (HappyAbsSyn ) -happyIn284 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn284 #-} -happyOut284 :: (HappyAbsSyn ) -> (LHsExpr RdrName) -happyOut284 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut284 #-} -happyIn285 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn285 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn285 #-} -happyOut285 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut285 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut285 #-} -happyIn286 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn286 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn286 #-} -happyOut286 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut286 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut286 #-} -happyIn287 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn287 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn287 #-} -happyOut287 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut287 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut287 #-} -happyIn288 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn288 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn288 #-} -happyOut288 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut288 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut288 #-} -happyIn289 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn289 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn289 #-} -happyOut289 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut289 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut289 #-} -happyIn290 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn290 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn290 #-} -happyOut290 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut290 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut290 #-} -happyIn291 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn291 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn291 #-} -happyOut291 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut291 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut291 #-} -happyIn292 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn292 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn292 #-} -happyOut292 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut292 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut292 #-} -happyIn293 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn293 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn293 #-} -happyOut293 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut293 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut293 #-} -happyIn294 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn294 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn294 #-} -happyOut294 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut294 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut294 #-} -happyIn295 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn295 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn295 #-} -happyOut295 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut295 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut295 #-} -happyIn296 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn296 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn296 #-} -happyOut296 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut296 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut296 #-} -happyIn297 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn297 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn297 #-} -happyOut297 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut297 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut297 #-} -happyIn298 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn298 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn298 #-} -happyOut298 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut298 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut298 #-} -happyIn299 :: (Located FastString) -> (HappyAbsSyn ) -happyIn299 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn299 #-} -happyOut299 :: (HappyAbsSyn ) -> (Located FastString) -happyOut299 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut299 #-} -happyIn300 :: (Located FastString) -> (HappyAbsSyn ) -happyIn300 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn300 #-} -happyOut300 :: (HappyAbsSyn ) -> (Located FastString) -happyOut300 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut300 #-} -happyIn301 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn301 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn301 #-} -happyOut301 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut301 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut301 #-} -happyIn302 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn302 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn302 #-} -happyOut302 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut302 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut302 #-} -happyIn303 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn303 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn303 #-} -happyOut303 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut303 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut303 #-} -happyIn304 :: (Located RdrName) -> (HappyAbsSyn ) -happyIn304 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn304 #-} -happyOut304 :: (HappyAbsSyn ) -> (Located RdrName) -happyOut304 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut304 #-} -happyIn305 :: (Located HsLit) -> (HappyAbsSyn ) -happyIn305 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn305 #-} -happyOut305 :: (HappyAbsSyn ) -> (Located HsLit) -happyOut305 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut305 #-} -happyIn306 :: (()) -> (HappyAbsSyn ) -happyIn306 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn306 #-} -happyOut306 :: (HappyAbsSyn ) -> (()) -happyOut306 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut306 #-} -happyIn307 :: (Located ModuleName) -> (HappyAbsSyn ) -happyIn307 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn307 #-} -happyOut307 :: (HappyAbsSyn ) -> (Located ModuleName) -happyOut307 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut307 #-} -happyIn308 :: (([SrcSpan],Int)) -> (HappyAbsSyn ) -happyIn308 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn308 #-} -happyOut308 :: (HappyAbsSyn ) -> (([SrcSpan],Int)) -happyOut308 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut308 #-} -happyIn309 :: (([SrcSpan],Int)) -> (HappyAbsSyn ) -happyIn309 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn309 #-} -happyOut309 :: (HappyAbsSyn ) -> (([SrcSpan],Int)) -happyOut309 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut309 #-} -happyIn310 :: (([SrcSpan],Int)) -> (HappyAbsSyn ) -happyIn310 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn310 #-} -happyOut310 :: (HappyAbsSyn ) -> (([SrcSpan],Int)) -happyOut310 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut310 #-} -happyIn311 :: (LHsDocString) -> (HappyAbsSyn ) -happyIn311 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn311 #-} -happyOut311 :: (HappyAbsSyn ) -> (LHsDocString) -happyOut311 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut311 #-} -happyIn312 :: (LHsDocString) -> (HappyAbsSyn ) -happyIn312 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn312 #-} -happyOut312 :: (HappyAbsSyn ) -> (LHsDocString) -happyOut312 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut312 #-} -happyIn313 :: (Located (String, HsDocString)) -> (HappyAbsSyn ) -happyIn313 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn313 #-} -happyOut313 :: (HappyAbsSyn ) -> (Located (String, HsDocString)) -happyOut313 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut313 #-} -happyIn314 :: (Located (Int, HsDocString)) -> (HappyAbsSyn ) -happyIn314 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn314 #-} -happyOut314 :: (HappyAbsSyn ) -> (Located (Int, HsDocString)) -happyOut314 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut314 #-} -happyIn315 :: (Maybe LHsDocString) -> (HappyAbsSyn ) -happyIn315 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn315 #-} -happyOut315 :: (HappyAbsSyn ) -> (Maybe LHsDocString) -happyOut315 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut315 #-} -happyIn316 :: (Maybe LHsDocString) -> (HappyAbsSyn ) -happyIn316 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn316 #-} -happyOut316 :: (HappyAbsSyn ) -> (Maybe LHsDocString) -happyOut316 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut316 #-} -happyIn317 :: (Maybe LHsDocString) -> (HappyAbsSyn ) -happyIn317 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn317 #-} -happyOut317 :: (HappyAbsSyn ) -> (Maybe LHsDocString) -happyOut317 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut317 #-} -happyInTok :: ((Located Token)) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> ((Located Token)) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyExpList :: HappyAddr -happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\xff\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xdf\x7c\xd5\xff\x7f\xf9\xdf\xcf\x07\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x5c\x44\xff\x7f\xf9\x9f\x03\x04\x41\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\xff\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x08\x80\x21\x88\x82\xfe\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x21\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x00\x10\x81\xa8\x02\x47\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x00\x10\x80\xa8\x02\x47\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xb8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xe8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\xb4\xa1\xa8\xc3\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\xc6\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x08\x80\x21\x88\x82\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x84\x21\x00\x41\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x40\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x91\x80\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x80\x10\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xf1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x90\x21\xb8\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x90\x21\xa8\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x91\x21\xa8\xcb\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x91\x21\xa8\xce\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\xa8\x02\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x80\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x91\x21\xa8\xcb\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x80\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x20\x04\xbf\x3f\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x80\x54\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x41\x00\x54\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x80\x21\x00\x41\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x80\x00\x40\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x80\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x41\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x02\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x80\x3f\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x90\x21\xa8\xca\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x91\x21\xa8\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xf1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x08\x80\x21\x88\x43\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x5c\x44\xff\x7f\xf9\x9f\x03\x04\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x5c\x44\xff\x7f\xf9\x9f\x03\x04\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x80\x21\x00\x80\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xb4\x00\x00\x41\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x80\x21\x00\x80\x98\x01\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x80\x21\x00\x41\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x90\x21\xa8\xca\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x40\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\xff\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\xff\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x04\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x00\x10\x81\xa8\x02\x47\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\xc3\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x07\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x06\x10\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x21\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa9\x2a\x67\xfe\x1f\x5e\x7f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xac\x2a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x90\x21\xa8\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x4c\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x90\x21\xa8\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x4c\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x90\x21\xa8\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x90\x21\xa8\xca\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\xa8\x1a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xdf\x7c\xd5\xff\x7f\xf9\xdf\xcf\x07\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x40\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x80\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x80\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x90\x21\xa8\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x90\x00\x00\x00\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x10\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xdf\x7c\xd5\xff\x7f\xf9\xdf\xcf\x07\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x04\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x5c\x44\xff\x7f\xf9\x9f\x03\x04\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x80\x21\x00\x80\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x00\x10\x81\xa8\x02\x47\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x2a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\xff\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x48\x90\x21\xa8\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x04\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x07\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x4c\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x4c\xff\x7f\xf1\x83\x03\x00\x40\x90\x01\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd6\x5c\x54\xff\x7f\xf9\x9f\x03\x04\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd6\x5c\x54\xff\x7f\xf9\x9f\x03\x04\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd2\x5c\x55\xff\x7f\xf9\x9f\x03\x04\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd2\x5c\x55\xff\x7f\xf9\x9f\x03\x04\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x80\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x5c\x44\xff\x7f\xf9\x9f\x03\x04\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x5c\x44\xff\x7f\xf9\x9f\x03\x04\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x20\x04\xbf\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x07\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x06\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x80\x54\xbf\x3f\xe9\x03\x00\x00\x00\x00\x00\x80\x40\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x90\x21\x00\x00\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x07\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x06\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x00\x10\x81\xa8\x02\x47\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x83\xdf\x31\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd6\x5c\x54\xff\x7f\xf9\x9f\x03\x04\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x80\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd2\x5c\x55\xff\x7f\xf9\x9f\x03\x04\x41\x90\x01\xa8\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x0c\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x0c\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x10\x81\xa8\x82\x57\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x83\x03\x00\x40\x90\x00\xa8\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x41\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x54\xbf\x3f\xe1\x03\x00\x00\x04\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x00\x10\x81\xa8\x02\x47\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x00\x10\x81\xa8\x02\x47\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x03\x30\x00\x08\xb4\xa1\xa8\xc3\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x90\xa1\xa8\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x08\x10\x81\xa8\x82\x57\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x03\x30\x00\x00\x10\x81\xa8\x02\x47\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x07\x3e\xe1\x03\x00\x00\x00\x00\x00\x00\x00\x0e\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x54\xbf\x3f\xe1\x03\x00\x00\x04\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x80\x54\xbf\x3f\xe9\x03\x00\x00\x00\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -{-# NOINLINE happyExpListPerState #-} -happyExpListPerState st = - token_strs_expected - where token_strs = ["error","%dummy","%start_parseModule","%start_parseSignature","%start_parseImport","%start_parseStatement","%start_parseDeclaration","%start_parseExpression","%start_parsePattern","%start_parseTypeSignature","%start_parseStmt","%start_parseIdentifier","%start_parseType","%start_parseBackpack","%start_parseHeader","identifier","backpack","units","unit","unitid","msubsts","msubst","moduleid","pkgname","litpkgname_segment","litpkgname","mayberns","rns","rn","unitbody","unitdecls","unitdecl","signature","module","maybedocheader","missing_module_keyword","implicit_top","maybemodwarning","body","body2","top","top1","header","header_body","header_body2","header_top","header_top_importdecls","maybeexports","exportlist","exportlist1","expdoclist","exp_doc","export","export_subspec","qcnames","qcnames1","qcname_ext_w_wildcard","qcname_ext","qcname","semis1","semis","importdecls","importdecls_semi","importdecl","maybe_src","maybe_safe","maybe_pkg","optqualified","maybeas","maybeimpspec","impspec","prec","infix","ops","topdecls","topdecls_semi","topdecl","cl_decl","ty_decl","inst_decl","overlap_pragma","deriv_strategy","opt_injective_info","injectivity_cond","inj_varids","where_type_family","ty_fam_inst_eqn_list","ty_fam_inst_eqns","ty_fam_inst_eqn","at_decl_cls","opt_family","at_decl_inst","data_or_newtype","opt_kind_sig","opt_datafam_kind_sig","opt_tyfam_kind_sig","opt_at_kind_inj_sig","tycl_hdr","capi_ctype","stand_alone_deriving","role_annot","maybe_roles","roles","role","pattern_synonym_decl","pattern_synonym_lhs","vars0","cvars1","where_decls","pattern_synonym_sig","decl_cls","decls_cls","decllist_cls","where_cls","decl_inst","decls_inst","decllist_inst","where_inst","decls","decllist","binds","wherebinds","rules","rule","rule_activation","rule_explicit_activation","rule_forall","rule_var_list","rule_var","warnings","warning","deprecations","deprecation","strings","stringlist","annotation","fdecl","callconv","safety","fspec","opt_sig","opt_asig","opt_tyconsig","sigtype","sigtypedoc","sig_vars","sigtypes1","strict_mark","strictness","unpackedness","ctype","ctypedoc","context","context_no_ops","type","typedoc","btype","btype_no_ops","tyapps","tyapp","atype","inst_type","deriv_types","comma_types0","comma_types1","bar_types2","tv_bndrs","tv_bndr","fds","fds1","fd","varids0","kind","gadt_constrlist","gadt_constrs","gadt_constr_with_doc","gadt_constr","constrs","constrs1","constr","forall","constr_stuff","fielddecls","fielddecls1","fielddecl","maybe_derivings","derivings","deriving","docdecl","docdecld","decl_no_th","decl","rhs","gdrhs","gdrh","sigdecl","activation","explicit_activation","quasiquote","exp","infixexp","infixexp_top","exp10_top","exp10","optSemi","scc_annot","hpc_annot","fexp","aexp","aexp1","aexp2","splice_exp","cmdargs","acmd","cvtopbody","cvtopdecls0","texp","tup_exprs","commas_tup_tail","tup_tail","list","lexps","flattenedpquals","pquals","squals","transformqual","parr","guardquals","guardquals1","altslist","alts","alts1","alt","alt_rhs","ralt","gdpats","ifgdpats","gdpat","pat","bindpat","apat","apats","stmtlist","stmts","maybe_stmt","stmt","qual","fbinds","fbinds1","fbind","dbinds","dbind","ipvar","overloaded_label","name_boolformula_opt","name_boolformula","name_boolformula_and","name_boolformula_and_list","name_boolformula_atom","namelist","name_var","qcon_nowiredlist","qcon","gen_qcon","con","con_list","sysdcon_nolist","sysdcon","conop","qconop","gtycon","ntgtycon","oqtycon","oqtycon_no_varcon","qtyconop","qtycon","qtycondoc","tycon","qtyconsym","tyconsym","op","varop","qop","qopm","qvarop","qvaropm","tyvar","tyvarop","tyvarid","var","qvar","qvarid","varid","qvarsym","qvarsym_no_minus","qvarsym1","varsym","varsym_no_minus","special_id","special_sym","qconid","conid","qconsym","consym","literal","close","modid","commas","bars0","bars","docnext","docprev","docnamed","docsection","moduleheader","maybe_docprev","maybe_docnext","'_'","'as'","'case'","'class'","'data'","'default'","'deriving'","'do'","'else'","'hiding'","'if'","'import'","'in'","'infix'","'infixl'","'infixr'","'instance'","'let'","'module'","'newtype'","'of'","'qualified'","'then'","'type'","'where'","'forall'","'foreign'","'export'","'label'","'dynamic'","'safe'","'interruptible'","'unsafe'","'mdo'","'family'","'role'","'stdcall'","'ccall'","'capi'","'prim'","'javascript'","'proc'","'rec'","'group'","'by'","'using'","'pattern'","'static'","'stock'","'anyclass'","'unit'","'signature'","'dependency'","'{-# INLINE'","'{-# SPECIALISE'","'{-# SPECIALISE_INLINE'","'{-# SOURCE'","'{-# RULES'","'{-# CORE'","'{-# SCC'","'{-# GENERATED'","'{-# DEPRECATED'","'{-# WARNING'","'{-# UNPACK'","'{-# NOUNPACK'","'{-# ANN'","'{-# VECTORISE'","'{-# VECTORISE_SCALAR'","'{-# NOVECTORISE'","'{-# MINIMAL'","'{-# CTYPE'","'{-# OVERLAPPING'","'{-# OVERLAPPABLE'","'{-# OVERLAPS'","'{-# INCOHERENT'","'{-# COMPLETE'","'#-}'","'..'","':'","'::'","'='","'\\\\'","'lcase'","'|'","'<-'","'->'","'@'","'~'","'~#'","'=>'","'-'","'!'","'-<'","'>-'","'-<<'","'>>-'","'.'","TYPEAPP","'{'","'}'","vocurly","vccurly","'['","']'","'[:'","':]'","'('","')'","'(#'","'#)'","'(|'","'|)'","';'","','","'`'","SIMPLEQUOTE","VARID","CONID","VARSYM","CONSYM","QVARID","QCONID","QVARSYM","QCONSYM","IPDUPVARID","LABELVARID","CHAR","STRING","INTEGER","RATIONAL","PRIMCHAR","PRIMSTRING","PRIMINTEGER","PRIMWORD","PRIMFLOAT","PRIMDOUBLE","DOCNEXT","DOCPREV","DOCNAMED","DOCSECTION","'[|'","'[p|'","'[t|'","'[d|'","'|]'","'[||'","'||]'","TH_ID_SPLICE","'$('","TH_ID_TY_SPLICE","'$$('","TH_TY_QUOTE","TH_QUASIQUOTE","TH_QQUASIQUOTE","%eof"] - bit_start = st * 472 - bit_end = (st + 1) * 472 - read_bit = readArrayBit happyExpList - bits = map read_bit [bit_start..bit_end - 1] - bits_indexed = zip bits [0..471] - token_strs_expected = concatMap f bits_indexed - f (False, _) = [] - f (True, nr) = [token_strs !! nr] - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x30\x00\x0e\x01\x7a\x00\xd7\x17\x9d\x0d\x98\x1f\x96\x1c\x3b\x14\xd7\x17\xa6\x3e\xc6\x29\x3a\x00\x44\x01\xae\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x02\x00\x00\x00\x00\x17\x01\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x01\xb5\x01\xb5\x01\xe0\x36\x00\x00\xdf\x00\x6f\x01\xc6\x01\x00\x00\xce\x02\x5d\x35\x00\x00\x00\x00\x00\x00\x1c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x45\x00\x00\x00\x00\x00\x00\xdc\x01\x79\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x43\x28\xc4\x28\xc0\x26\x41\x27\x10\x42\x0d\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x1f\x00\x00\x00\x00\x66\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x02\x0b\x0b\x71\x01\x0d\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x02\x20\x11\x00\x00\x00\x00\x98\x1f\x98\x1f\x78\x22\x00\x00\xdc\x02\x00\x00\x00\x00\x3e\x03\x0e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x03\x00\x00\x00\x00\x98\x1f\x21\x04\x71\x18\xb4\x04\x0f\x05\x9c\x24\x0f\x05\x9c\x24\x44\x03\xf5\x01\x49\x03\xef\x21\x9c\x24\x01\x23\x9c\x24\xd5\x14\xa3\x16\x39\x11\xd3\x11\x37\x26\x25\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x1f\x98\x1f\xc6\x29\x3b\x05\x98\x1f\x00\x00\x98\x1f\x00\x00\x98\x1f\x2d\x41\x64\x03\x00\x00\x5c\x03\x40\x0c\x00\x00\x6a\x03\xa9\x03\x00\x00\x00\x00\x00\x00\x42\x05\xe7\x03\xc4\x03\x88\x00\xc4\x03\xae\x42\x72\x43\xe7\x03\x6d\x12\x00\x00\x9a\x03\x9c\x24\x9a\x03\x9a\x03\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x05\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x35\x19\x04\xe6\x03\x63\x01\xac\x05\x00\x00\x45\x29\x9a\x01\xd0\x43\xbe\x03\xf0\x43\xf0\x43\x52\x43\x30\x42\x42\x04\xae\x42\x9c\x24\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x03\xd8\x03\x46\x04\x00\x04\x79\x04\x18\x04\xa3\x04\x00\x00\x00\x00\x00\x00\x59\x04\x73\x04\x62\x00\xfc\x02\xfc\x02\x0e\x05\x86\x04\xda\x04\xac\x04\xcd\x03\xd3\x04\xcd\x03\xcd\x03\x9c\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x24\xbb\x04\xef\x02\x40\x00\x00\x00\xa6\x01\xc6\x04\x62\x01\x00\x00\xa6\x01\x78\x01\x00\x00\xd4\x04\x1a\x02\xcc\x44\x13\x05\x3f\x00\x50\x02\x00\x00\xf9\x05\xf9\x05\x20\x05\x22\x05\x5d\x35\x5d\x35\xcc\x02\xc6\x29\x3a\x05\x3d\x05\x4c\x05\x57\x05\x8c\x05\x00\x00\x00\x00\x00\x00\xc6\x29\x5d\x35\x60\x05\x5e\x05\x00\x00\xda\x04\x00\x00\x66\x21\x00\x00\x47\x2a\x74\x3f\x5d\x35\x75\x05\x43\x05\x00\x00\x78\x05\x20\x11\x87\x01\x6c\x05\x00\x00\x98\x1f\x00\x00\x00\x00\x81\x05\x90\x05\x9a\x05\x9d\x05\x07\x13\x6f\x15\x00\x00\x01\x23\x00\x00\x00\x00\x8f\x41\xb1\x05\xd6\x05\xe7\x05\x00\x00\xe4\x05\x00\x00\xd4\x05\x00\x00\xec\x42\x38\x00\xae\x42\x00\x00\x47\x01\xae\x42\xc8\x2a\xae\x42\x00\x00\x32\x06\x9f\x10\x9f\x10\x14\x45\x49\x2b\xfb\x01\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x05\xed\x05\xd8\x08\x3a\x03\xfd\x05\x00\x06\xdc\x05\xea\x05\x00\x00\x00\x00\xf0\x05\xe2\x06\xf4\x05\x00\x00\x00\x00\x3d\x04\x00\x00\x00\x00\x14\x02\x1a\x06\x00\x00\x00\x00\xa1\x13\x00\x00\x21\x06\x99\x01\x28\x06\x37\x06\xcd\x01\x3a\x06\x31\x06\x00\x00\x00\x00\x8a\x23\x00\x00\x00\x00\x13\x24\x48\x05\x9c\x24\x23\x06\x58\x06\x5b\x06\x62\x06\x00\x00\x00\x00\x0b\x19\x0b\x19\x5d\x06\x00\x00\xa7\x06\x45\x06\x59\x01\x00\x00\x00\x00\x30\x1d\x63\x06\x00\x00\xa3\x06\x9c\x24\x98\x1f\x8e\x42\x00\x00\xe0\x36\x00\x00\x00\x00\x98\x1f\xca\x2b\x98\x1f\x98\x1f\x98\x1f\x98\x1f\x4b\x06\x4c\x06\x6f\x03\x54\x06\x55\x06\x15\x02\x56\x06\x57\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x2b\xc2\x27\xaf\x41\x51\x06\x59\x06\xa1\x01\x5a\x06\x64\x06\x86\x03\x00\x00\xbc\x01\x6a\x06\x57\x02\x6b\x06\x6c\x06\x6d\x06\x00\x00\x5f\x06\x00\x00\x77\x02\x00\x00\x76\x06\x00\x00\xb2\x01\x00\x00\x14\x45\x00\x00\x00\x00\x7a\x06\xc8\x45\x00\x00\x54\x46\x5d\x35\x00\x00\xca\x2b\xca\x2b\x00\x00\x00\x00\xab\x40\x92\x00\x00\x00\x13\x3e\x58\x00\x00\x00\x6e\x06\x00\x00\xa6\x03\xa6\x03\x26\x04\x00\x00\x00\x00\x26\x04\x00\x00\x00\x00\xd4\x06\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x06\xce\x06\x8e\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x06\x00\x00\xca\x2b\xd4\x00\x00\x00\xc2\x02\x7c\x06\x00\x00\x00\x00\xca\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x2b\x00\x00\xca\x2b\x00\x00\x00\x00\x00\x00\xca\x2b\xca\x2b\x00\x00\x00\x00\x7e\x06\x7d\x06\x86\x06\x87\x06\x88\x06\x89\x06\x93\x06\x94\x06\x95\x06\x97\x06\x92\x06\x9f\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x06\x00\x00\x98\x06\xba\x06\x00\x00\x00\x00\x00\x00\x48\x05\x8c\x01\xb6\x06\xa1\x06\x00\x00\x00\x00\x00\x00\xfd\x06\x00\x00\x98\x1f\x98\x1f\x5d\x00\x00\x00\xff\x00\x98\x1f\x00\x00\x00\x00\xc6\x06\x00\x00\x00\x00\x3d\x17\xc5\x0b\x13\x24\xc7\x06\xa3\x16\x00\x00\x98\x1f\xa5\x19\xa3\x16\x00\x00\x98\x1f\xa5\x19\xa3\x16\x00\x00\xa4\x06\x00\x00\x00\x00\x00\x00\x09\x16\xc9\x06\x00\x00\x25\x25\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x0d\x62\x00\xb7\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x06\xb3\x06\x00\x00\xbd\x06\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x43\x00\x00\x00\x00\xca\x06\x00\x00\x7f\x01\xd0\x06\xc8\x45\x40\x01\x69\x00\x00\x00\x00\x00\x15\x0e\x2e\x1a\x6b\x00\x00\x00\xdf\x06\x38\x01\xcf\x01\xd8\x06\x00\x00\xe5\x06\xe4\x06\xb8\x06\xd2\x06\xe8\x06\x00\x00\xf2\x06\xd5\x06\xdb\x06\x4e\x44\x4e\x44\x00\x00\xf3\x06\xcd\x03\xe7\x03\xd1\x06\xf4\x06\x00\x00\xd9\x06\x49\x0f\x00\x00\x00\x00\x98\x1f\xa3\x16\x39\x01\x5d\x35\x21\x00\xda\x06\x00\x00\xf5\x06\x3b\x00\xfe\x06\xc8\x45\x00\x00\x00\x00\x5b\x00\x00\x00\x98\x1f\x30\x1d\x5d\x35\x37\x07\x00\x00\x07\x07\xef\x06\xac\x05\x00\x00\x00\x00\x00\x00\x00\x00\x43\x07\x55\x00\x42\x03\x15\x01\x00\x00\x0e\x07\x4b\x2c\x59\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x3d\xdb\x25\xee\x06\x4b\x2c\x00\x00\xdb\x25\xdb\x25\xca\x1d\xca\x1d\x4b\x07\x00\x00\x4a\x01\x00\x00\xe6\x06\x00\x00\xe7\x06\x00\x00\x00\x00\x6e\x44\x6e\x44\x00\x00\x00\x00\x6e\x44\xae\x25\x1d\x07\x20\x07\xd6\x03\x21\x07\x98\x1f\x1f\x04\x00\x00\x00\x00\x00\x00\x5a\x07\x00\x00\xa0\x04\xa0\x04\x00\x00\x00\x00\x00\x00\x66\x07\x00\x00\x03\x07\x00\x00\x9d\x0d\x17\x07\xa6\x01\xa6\x01\x17\x07\xf9\x06\x00\x00\x00\x00\xcd\x03\x39\x07\x00\x00\x00\x00\xcd\x03\x00\x00\x00\x00\x3c\x07\x00\x00\x00\x00\x00\x00\x08\x03\x00\x00\x00\x00\x2f\x00\x22\x07\x98\x1f\x40\x45\x72\x07\x00\x00\x30\x07\x23\x07\x00\x00\x00\x00\x25\x07\x00\x00\xb7\x3d\x00\x00\x46\x07\x4c\x07\x4f\x07\x52\x07\x6e\x45\x00\x00\x00\x00\xcc\x2c\x47\x07\xcc\x2c\xc8\x45\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x05\xcc\x2c\x00\x00\x00\x00\xcc\x2c\x34\x07\x00\x00\xf4\x45\x00\x00\x56\x05\x00\x00\x56\x07\x8f\x07\x00\x00\x00\x00\x61\x05\x48\x07\x5d\x35\x55\x07\x4d\x2d\x4d\x2d\x00\x00\x91\x07\xa8\x07\x63\x07\xce\x2d\x21\x00\x00\x00\x70\x07\x00\x00\x00\x00\x6a\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x2d\x00\x00\x57\x07\xce\x2d\x00\x00\x00\x00\x00\x00\x44\x07\x00\x00\x9f\x10\x98\x1f\x00\x00\x00\x00\x4f\x2e\x6e\x45\x62\x07\x5d\x35\x4f\x2e\x4f\x2e\xfb\x01\x00\x00\x00\x00\x5e\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x03\x00\x00\x00\x00\x00\x00\x20\x02\x00\x00\x00\x00\x32\x20\x00\x00\x38\x03\x00\x00\x00\x00\x00\x00\x75\x07\xe0\x36\x00\x00\x62\x00\x5f\x07\x00\x00\x76\x07\x00\x00\xc8\x1a\x74\x07\x00\x00\x50\x07\x00\x00\x00\x00\x62\x1b\x00\x00\x00\x00\x00\x00\xcc\x20\x64\x1e\xcc\x20\x00\x00\x00\x00\xa3\x16\x8e\x42\x00\x00\x00\x00\x00\x00\xd0\x2e\x00\x00\x00\x00\x85\x07\x00\x00\x6e\x07\x00\x00\x6f\x07\x7b\x07\x53\x07\xd0\x2e\x00\x00\xd0\x2e\x55\x0d\x76\x05\x00\x00\x71\x07\x71\x07\xcb\x07\x1a\x04\xcc\x07\x00\x00\x32\x00\x32\x00\x00\x00\x7a\x07\x5d\x07\x00\x00\x60\x07\x00\x00\x00\x00\x00\x00\x80\x07\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x07\x00\x00\x94\x07\x00\x00\x00\x00\xe4\x02\xfe\x1e\x00\x00\x00\x00\xcc\x20\xcc\x20\xc3\x07\xb4\x02\xfc\x1b\xfc\x1b\xcc\x20\x88\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x07\x8d\x07\xb5\x07\x00\x00\xb7\x07\x00\x00\xec\x07\xff\x07\x00\x00\x7e\x07\x00\x00\x01\x08\x00\x00\x22\x02\x01\x08\xb2\x05\x51\x2f\xe1\x04\xd2\x2f\x00\x00\x00\x00\xcc\x20\x00\x00\x37\x0e\x37\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x0e\xd1\x0e\x00\x00\x00\x00\x00\x00\xf0\x07\x54\x46\x00\x00\xbc\x07\x53\x30\x00\x00\x00\x00\xdb\x25\x00\x00\x00\x00\xc4\x05\xac\x07\x9a\x45\x00\x00\xdb\x25\xb1\x11\x00\x00\x00\x00\xab\x07\x00\x00\x96\x07\x00\x00\xc7\x07\x00\x00\xd1\x07\x0f\x04\x00\x00\x07\x08\xd4\x07\xd5\x07\x0a\x08\xa7\x07\x00\x00\x0d\x06\x00\x00\x00\x00\x0d\x06\x18\x08\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x20\xd9\x07\x00\x00\x00\x00\x9f\x10\x9f\x10\x00\x00\x00\x00\x53\x30\x00\x00\xd6\x07\x00\x00\x10\x06\x00\x00\xe3\x07\x00\x00\xa1\x00\x00\x00\x00\x00\x5d\x35\xd8\x01\x00\x00\x54\x46\x00\x00\x00\x00\x27\x01\x00\x00\x08\x08\xcc\x20\xd4\x30\xe4\x01\x00\x00\x00\x00\x00\x00\x84\x03\x84\x03\x00\x00\x11\x03\x00\x00\xa3\x00\x00\x00\x13\x08\x00\x00\x28\x08\x00\x00\x00\x00\x55\x31\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x20\xcc\x20\xcc\x20\x00\x00\x00\x00\x00\x00\x00\x00\x19\x08\xdf\x07\xcc\x20\xb8\x07\x2f\x08\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x00\x00\x8a\x01\x41\x3e\x4a\x02\x11\x06\xcf\x07\x00\x00\xa0\x3f\x1a\x04\x00\x00\x00\x00\x00\x00\x11\x06\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x04\xd2\x07\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x04\x3b\x03\xd0\x03\x4f\x03\x1a\x04\x00\x00\x00\x00\x00\x00\x42\x00\xdd\x07\xd8\x07\x6f\x3e\x0f\x04\x0f\x04\x00\x00\xcc\x20\xfb\x07\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x08\x00\x00\x00\x00\xe0\x36\x28\x46\xf8\x07\xc4\x07\x00\x00\xda\x33\x62\x00\xe4\x07\x00\x00\x04\x08\xe6\x07\xf5\x07\x00\x00\x6b\x0f\x00\x00\xc1\x03\x5d\x35\x5d\x35\xaf\x0e\x5d\x35\x00\x00\x00\x00\x00\x00\x05\x10\x00\x00\x00\x00\x5d\x35\x00\x00\x5b\x34\xdc\x34\x54\x46\x00\x00\x89\x01\x7c\x02\x55\x31\x00\x00\x52\x00\x0f\x04\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\xf7\x07\x00\x00\x00\x00\x00\x00\xf4\x07\x1a\x04\xf6\x07\x00\x00\x00\x00\x54\x46\x00\x00\x9e\x01\x00\x00\x62\x00\xa3\x02\xfc\x07\x21\x00\x00\x00\x11\x08\xd6\x31\x99\x04\x00\x00\x00\x00\x57\x32\xd8\x32\x00\x00\x00\x00\xe7\x03\x59\x33\x84\x03\x00\x00\xf1\x07\x14\x00\xf9\x07\x00\x00\x00\x00\xda\x07\x06\x08\x10\x08\xde\x35\x00\x00\xe1\x07\xcc\x20\xeb\x07\x00\x00\x45\x01\x45\x01\x00\x00\x0f\x04\x00\x00\x0f\x04\x00\x00\x00\x00\x0b\x08\x0c\x08\x0d\x08\x0e\x08\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x8b\x40\x09\x08\x00\x00\x00\x00\x1a\x04\x14\x08\x0f\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x00\x00\x74\x08\x2a\x03\x00\x00\x1b\x00\x17\x08\x17\x08\x32\x08\x00\x00\x00\x00\x00\x00\xe0\x36\xe0\x36\x00\x00\xfa\x07\x00\x00\x5d\x35\x00\x00\x00\x00\x00\x00\x31\x08\x33\x08\xc0\x26\x00\x00\x00\x00\x28\x46\x00\x00\x00\x00\x6d\x08\x87\x08\x00\x00\x00\x00\x5d\x35\x00\x00\x00\x00\x00\x00\x00\x00\x25\x08\x1a\x04\x00\x00\x00\x00\x29\x08\x00\x00\x00\x00\x00\x00\x90\x08\x48\x08\x54\x46\x00\x00\x00\x00\x5f\x36\x1f\x08\xe0\x36\x00\x00\x80\x08\x81\x08\xe5\x3d\x0f\x04\x00\x00\x0f\x04\x0f\x04\x00\x00\x0f\x04\x8b\x40\x00\x00\x00\x00\x05\x40\x00\x00\x00\x00\x00\x00\x00\x00\x27\x08\x54\x08\x00\x00\x0f\x04\x1d\x06\x1d\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x08\x0f\x04\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x05\x00\xfe\xff\x7d\x08\x6e\x4e\x3d\x01\xe4\x50\x12\x50\x13\x07\x70\x4c\x01\x00\xac\x39\x97\x00\x07\x00\xcb\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x04\x00\x00\x00\x00\x00\x00\x8b\x02\x00\x00\x00\x00\x00\x00\x13\x03\x00\x00\x00\x00\xea\x03\x05\x05\xb1\x06\x00\x00\x2a\x08\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\xff\xc8\x39\x57\x3a\xbc\x08\x6e\x08\xd4\x01\xaa\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x03\x92\x07\x59\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x0b\x00\x00\x00\x00\x70\x51\xb6\x51\xaa\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x51\xd0\x07\xb4\x4e\xe7\x04\xd7\x07\xdc\x5c\xdb\x07\xf0\x5c\x00\x00\x00\x00\x00\x00\x9a\x5c\x22\x5d\x45\x0c\x32\x5d\x6f\x47\xda\x47\xd6\x45\xb6\x46\x6e\x5e\x99\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x52\xbc\x5a\x69\x3a\xe9\x07\x88\x52\x00\x00\xce\x52\x00\x00\x14\x53\x37\x09\x83\x08\x00\x00\x00\x00\x9a\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x05\x81\xff\x96\x04\x15\x05\x66\x05\x15\x03\xb3\x08\xa0\x01\x46\x46\x00\x00\x00\x00\x64\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x07\x00\x00\x00\x00\x82\x08\x7e\x08\x00\x00\x38\x22\x4a\x08\x85\x00\x85\x05\xbf\x00\x93\x00\x5a\x02\xc8\x03\x00\x00\xe3\x03\x78\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x08\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x00\x00\xc5\x01\x00\x00\x1a\x03\xa4\x07\xa5\x07\xa6\x07\x95\x08\x00\x00\xee\x02\x00\x00\x57\x04\x00\x00\xc1\x04\x55\x05\xaa\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x5d\xc5\x07\x3f\x03\x00\x00\x00\x00\x59\x08\x00\x00\x00\x00\x00\x00\x60\x08\x00\x00\x00\x00\xbe\x05\x00\x00\xe9\xff\x00\x00\x7b\xff\x8a\x03\x00\x00\x50\x08\x5d\x08\x00\x00\x00\x00\xcf\x04\x4a\x23\x99\x03\x54\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x25\x5c\x24\x3f\x08\x00\x00\x00\x00\xc7\x03\x00\x00\x0e\x5c\x00\x00\x0f\x09\x59\x03\xb1\x07\x86\x08\x00\x00\x00\x00\x00\x00\x34\x12\x96\xff\x00\x00\x00\x00\x02\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x48\x1b\x49\x00\x00\x45\x0c\x00\x00\x00\x00\x4d\x04\x00\x00\x5b\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x25\x00\x00\xf0\x03\x00\x00\x00\x00\x07\x04\xa2\x09\x62\x04\x00\x00\x00\x00\xd5\x02\x54\x03\x8f\x00\x36\x04\xc9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x01\xbb\x07\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x28\x00\x00\x00\xce\x12\x00\x00\x00\x00\x00\x00\x88\x03\x16\x08\x00\x00\x96\xff\x00\x00\x00\x00\x00\x00\x45\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x5d\x00\x00\x00\x00\x1e\x5c\x1a\x08\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x4c\xfc\x4c\x00\x00\x00\x00\x00\x00\x26\x08\x87\xff\x00\x00\x00\x00\x47\x4d\x2b\x03\x00\x00\x00\x00\x32\x5e\x5a\x53\xe7\x01\x00\x00\x05\x08\x00\x00\x00\x00\xd0\x5b\x9e\x0a\xa0\x53\xe6\x53\x2c\x54\x72\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x36\x1b\x08\x3f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x02\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\xd3\x00\x00\x00\xa4\x01\xf9\x26\x00\x00\x86\x3a\x98\x3a\x00\x00\x00\x00\xbf\x04\x00\x00\x00\x00\x16\x00\xc2\x07\x00\x00\xa8\x02\x00\x00\xce\x07\xd3\x07\xd0\x08\x00\x00\x00\x00\xd4\x08\x00\x00\x00\x00\xbe\x08\x00\x00\x00\x00\x00\x00\x00\x00\xec\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x3b\x00\x00\x00\x00\xd9\x03\x00\x00\x00\x00\x00\x00\x4d\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x37\x00\x00\xc1\x37\x00\x00\x00\x00\x00\x00\xd3\x37\xf0\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x08\x1c\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x54\xfe\x54\xde\x07\x00\x00\x00\x00\x44\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x4d\x26\x47\x5c\x5c\x84\x08\x86\x49\x00\x00\x8a\x55\x9d\x4b\xf1\x49\x00\x00\xd0\x55\xe4\x4b\x5c\x4a\x00\x00\x9d\xff\x00\x00\x00\x00\x00\x00\xb0\x48\x00\x00\x00\x00\x03\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x83\x01\xe5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x02\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x07\x00\x00\x14\x01\x00\x00\xea\x07\x00\x00\x00\x00\xf8\x00\x00\x00\xed\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x08\x54\x07\x00\x00\x00\x00\x95\x05\x04\x02\x00\x00\x1d\x05\x00\x00\x00\x00\xce\x12\x00\x00\x00\x00\xd0\x5b\xc7\x4a\x00\x00\xcd\x07\xc4\xff\x00\x00\x00\x00\x00\x00\xe8\x07\x00\x00\x4e\x01\x00\x00\x00\x00\xa9\x00\x00\x00\x16\x56\xdd\x4d\xfa\x27\x9a\x08\xf5\x03\xb2\x08\x00\x00\xcc\x08\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x08\xb8\x04\x58\x05\xc1\x08\x00\x00\x00\x00\xbd\x3a\xc2\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xff\xeb\x02\x1e\x08\x85\x0b\x00\x00\xed\xff\xd9\xff\x58\x50\x9e\x50\xa3\x08\x00\x00\x00\x00\x00\x00\xa9\x08\x00\x00\xa0\x08\x00\x00\x00\x00\xd9\x01\x9e\x06\x00\x00\x00\x00\xb2\xff\x42\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x56\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x08\x00\x00\x03\x09\x04\x09\x00\x00\x00\x00\x00\x00\xfa\x02\x00\x00\xf1\x08\x00\x00\x83\x01\x06\x09\xae\x08\xb7\x08\x08\x09\xf6\x08\x00\x00\x00\x00\x52\x06\x00\x00\x00\x00\x00\x00\x7f\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x5b\x1a\x00\xd2\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x02\x00\x00\x00\x00\x4c\x3b\xef\x08\x02\x38\xb1\xff\x00\x00\xe0\x08\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x08\xbe\x09\x00\x00\x00\x00\x91\x38\x00\x00\x00\x00\xea\x02\x00\x00\xdc\x08\x00\x00\x00\x00\xcf\x08\x00\x00\x00\x00\xe1\x05\x00\x00\xfc\x28\x00\x00\xde\x36\xfa\x36\x00\x00\xaa\x08\x98\x04\x00\x00\xad\x38\xce\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x09\x00\x00\x00\x00\xf9\x09\x00\x00\x00\x00\x00\x00\x9f\x05\x00\x00\xcd\x06\xa2\x56\x00\x00\x00\x00\xe0\x0b\xbd\x02\x00\x00\xfe\x29\x5e\x3b\x7c\x3b\xef\x01\x00\x00\x00\x00\x1a\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x0a\x00\x00\x2c\x08\x00\x00\x00\x00\xd3\x08\x00\x00\x28\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x4e\x00\x00\x00\x00\x00\x00\x2e\x57\x86\x4f\x74\x57\x00\x00\x00\x00\x32\x4b\x0c\x02\x00\x00\x00\x00\x00\x00\xc9\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x03\x0b\x3c\x00\x00\xe5\x38\x22\x00\x44\x09\x00\x00\x35\x09\x36\x09\x00\x00\x15\x00\x00\x00\x00\x00\xfb\xff\xfd\xff\x00\x00\x00\x00\xa1\x03\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x08\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x05\xcc\x4f\x00\x00\x00\x00\xba\x57\x00\x58\x00\x00\x00\x00\x2a\x4c\x40\x4f\x46\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x08\xd8\x04\x00\x00\xae\xff\x00\x00\xad\x08\x00\x00\x18\x09\xe3\x04\x00\x00\x3b\x3c\x00\x00\x16\x37\x00\x00\x00\x00\x8c\x58\x00\x00\xd3\x03\x52\x04\x00\x00\xc2\x08\xfc\x05\x00\x00\x00\x00\x00\x00\xc9\x01\x56\x02\x00\x00\x00\x00\x00\x00\x1b\x09\xc5\xff\x00\x00\x00\x00\xf2\x0b\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\xf5\x02\xce\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x09\x00\x00\x00\x00\x50\x09\x33\x09\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x58\x00\x00\x00\x00\x00\x00\xcf\x05\x4e\x06\x00\x00\x00\x00\x1e\x0c\x00\x00\x00\x00\x00\x00\x22\x09\x00\x00\x17\x09\x00\x00\x4e\x08\x00\x00\x00\x00\xaa\x05\x00\x00\x00\x00\xea\x02\x00\x00\x00\x00\x56\x08\x00\x00\x2e\x09\x8e\x5b\xcd\x05\x00\x00\x00\x00\x00\x00\x00\x00\xba\xff\x67\x01\x00\x00\x92\x04\x00\x00\x26\x03\x00\x00\xd5\x08\x00\x00\x62\x05\x00\x00\x00\x00\x8c\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x18\x59\x5e\x59\xa4\x59\x00\x00\x00\x00\x00\x00\x00\x00\x11\x09\x9e\x08\xea\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x08\x00\x00\x00\x00\x26\x00\x00\x00\x69\x09\x00\x00\x00\x00\x54\x00\xe3\xff\x00\x00\x00\x00\x00\x00\x6b\x09\x00\x00\x41\x03\x5b\x03\x00\x00\x27\x00\x65\x09\x00\x00\x00\x00\x00\x00\x00\x00\x76\x08\x68\x04\x4d\x03\x4e\x05\x2b\x00\x00\x00\x00\x00\x00\x00\x03\x00\x86\x09\x00\x00\x29\x00\x7a\x08\x88\x08\x00\x00\x30\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x04\x82\x01\x00\x00\x79\x08\x00\x00\x65\x19\x85\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x05\x00\x00\x59\x09\x9d\x06\x00\x2b\xce\x12\x02\x2c\x00\x00\x00\x00\x00\x00\xd1\x04\x00\x00\x00\x00\x5c\x08\x00\x00\xd3\x02\xd1\x03\x12\x00\x00\x00\x8b\x08\x00\x00\x59\x3c\x00\x00\x69\x06\x8d\x08\x00\x00\x40\x02\x63\x02\x00\x00\x8f\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x8a\x02\x00\x00\x91\x08\x00\x00\x93\x08\x00\x00\x00\x00\xd3\xff\x00\x00\x63\x09\x8b\x0c\x66\x09\x00\x00\x00\x00\x74\x39\x90\x39\x00\x00\x00\x00\x23\x01\xbb\x0a\xac\x01\x00\x00\x00\x00\x8e\x08\x00\x00\x00\x00\x00\x00\xa4\x03\x00\x00\x00\x00\x2c\x02\x00\x00\xae\x03\x76\x5a\x00\x00\x00\x00\xa3\x09\xa4\x09\x00\x00\xff\xff\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x02\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x09\x9b\x09\x00\x00\x00\x00\x00\x00\x00\x00\x18\x06\xa2\x04\x00\x00\x6c\x00\x00\x00\x26\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x08\x00\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x20\x09\x87\x05\x00\x00\x00\x00\x6d\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x05\x00\x00\xf0\xff\x00\x00\x00\x00\x2c\x02\xc3\x03\x5f\x0a\x00\x00\x00\x00\x00\x00\x1f\x00\xa4\x08\x00\x00\x02\x00\xa6\x08\x00\x00\xf5\xff\x5e\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x08\xaa\x09\xb8\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x08\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int# -happyAdjustOffset off = off - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xc0\xff\xc1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\xfd\x00\x00\x00\x00\xbf\xff\xc0\xff\x00\x00\xf2\xff\x1b\xfd\x18\xfd\x15\xfd\x05\xfd\x03\xfd\x04\xfd\x11\xfd\x02\xfd\x01\xfd\x00\xfd\x13\xfd\x12\xfd\x14\xfd\x10\xfd\x0f\xfd\xff\xfc\xfe\xfc\xfd\xfc\xfc\xfc\xfb\xfc\xfa\xfc\xf9\xfc\xf8\xfc\xf7\xfc\xf5\xfc\xf6\xfc\x00\x00\x16\xfd\x17\xfd\x00\x00\x8b\xff\x00\x00\xb1\xff\xc2\xff\x8b\xff\xd5\xfc\x00\x00\x00\x00\x00\x00\x00\x00\xac\xfe\xab\xfe\x00\x00\x00\x00\xa2\xfe\x9b\xfe\x95\xfe\x92\xfe\x90\xfe\x7e\xfe\x00\x00\x8b\xfe\x4f\xfd\x8f\xfe\x48\xfd\x3d\xfd\x40\xfd\x37\xfd\x8a\xfe\x8e\xfe\x25\xfd\x21\xfd\x74\xfe\x69\xfe\x1f\xfd\x1e\xfd\x20\xfd\x00\x00\x00\x00\x34\xfd\xa8\xfe\x33\xfd\xa9\xfe\x23\xfd\xd1\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\xfd\x3a\xfd\x35\xfd\x36\xfd\x3e\xfd\x38\xfd\x39\xfd\x76\xfd\x75\xfe\x76\xfe\x7c\xfe\x00\x00\x1f\xfe\x1e\xfe\x00\x00\xf1\xff\x65\xfd\x58\xfd\x64\xfd\xef\xff\xf0\xff\x29\xfd\x0d\xfd\x0e\xfd\x09\xfd\x06\xfd\x63\xfd\xf2\xfc\x54\xfd\xef\xfc\xec\xfc\x08\xfd\xf4\xfc\xf3\xfc\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xfc\x07\xfd\xed\xfc\xf1\xfc\x0a\xfd\xee\xfc\xde\xfd\x83\xfd\x18\xfe\x06\xfe\x17\xfe\x00\x00\x00\x00\x07\xfe\xfc\xfd\xf9\xfd\xf7\xfd\xe8\xfd\x00\x00\x00\x00\x88\xfd\x86\xfd\xf4\xfd\xf3\xfd\xf5\xfd\xf6\xfd\xf2\xfd\xe9\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x75\xfd\xeb\xfc\xea\xfc\xf1\xfd\xf0\xfd\xe7\xfc\xe6\xfc\xe9\xfc\xe8\xfc\xe5\xfc\xe4\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\xfd\x00\x00\xda\xfd\x00\x00\x00\x00\x78\xff\x2c\xfe\x00\x00\x00\x00\x15\xfe\x00\x00\x18\xfd\x76\xff\x75\xff\x74\xff\x00\x00\x00\x00\x23\xfe\x23\xfe\x23\xfe\x00\x00\x73\xfd\x00\x00\x00\x00\x96\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x6e\xff\x6d\xff\x6c\xff\x1d\xff\x6b\xff\x6a\xff\x38\xfe\x5d\xff\x37\xfe\x40\xfe\x5c\xff\x3b\xfe\x5b\xff\x3f\xfe\x3e\xfe\x3d\xfe\x3c\xfe\x00\x00\x2d\xff\x00\x00\x48\xff\x4c\xff\x2c\xff\x00\x00\x00\x00\x00\x00\xe4\xfe\xcf\xfe\xd4\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\xfc\xd8\xfc\xd7\xfc\xd6\xfc\x00\x00\x00\x00\x85\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8b\xff\xc3\xff\x8b\xff\x00\x00\x88\xff\x00\x00\x00\x00\x00\x00\x83\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\xfd\x5f\xfd\x69\xfd\x1d\xfd\x61\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xd5\xfe\x00\x00\x6b\xfd\x00\x00\xd0\xfe\x00\x00\x00\x00\xe5\xfe\xe2\xfe\x00\x00\x5e\xfd\x00\x00\x00\x00\x00\x00\x68\xff\x00\x00\x00\x00\x00\x00\x9b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\xff\x4b\xff\x4a\xff\x6f\xfe\x00\x00\x66\xfe\x00\x00\x20\xff\x00\x00\x2d\xfd\x00\x00\x2e\xfd\x00\x00\x00\x00\x00\x00\x1d\xff\x00\x00\x95\xfd\xd1\xfd\x18\xfe\x00\x00\x00\x00\x2a\xfd\x00\x00\x2b\xfd\x27\xfd\x0b\xfd\x00\x00\x0c\xfd\x54\xfd\x00\x00\x00\x00\xda\xfc\x08\xfd\x5c\xfd\xde\xfc\x00\x00\x5e\xfd\xb4\xfe\x00\x00\x74\xfd\x72\xfd\x70\xfd\x6f\xfd\x6c\xfd\x00\x00\x00\x00\x00\x00\x22\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xec\xfe\x00\x00\xef\xfe\xef\xfe\x00\x00\x00\x00\x00\x00\x77\xff\xe4\xfd\x52\xfd\xe5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xff\x6f\xff\x00\x00\x00\x00\x00\x00\xe6\xfd\xe7\xfd\x00\x00\xd7\xfd\xf6\xfd\x00\x00\x00\x00\x0b\xfd\x0c\xfd\x00\x00\x5a\xfd\x00\x00\xb0\xfd\xaf\xfd\x00\x00\xc5\xfd\x00\x00\xc4\xfd\x57\xfd\x93\xfd\x0d\xfe\xfa\xfd\x92\xfd\x8f\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xfd\x85\xfd\x89\xfd\x89\xfd\x00\x00\x0b\xfe\x82\xfd\x03\xfe\x00\x00\x0f\xfe\x9a\xfd\x00\x00\x00\x00\x0c\xfe\x00\x00\x00\x00\x00\x00\x80\xfd\xff\xfd\x00\x00\x0a\xfe\x05\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\xfe\x67\xfd\x66\xfd\x8d\xfe\x8c\xfe\x78\xfe\x30\xfd\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x6e\xfe\x00\x00\x00\x00\x00\x00\x85\xfe\x00\x00\x40\xfd\x00\x00\x00\x00\xa8\xfe\x00\x00\x87\xfe\x00\x00\x4a\xfd\x00\x00\x4b\xfd\x00\x00\x4b\xfe\x49\xfe\xd2\xfc\x00\x00\xa6\xfe\xa7\xfe\x00\x00\x69\xfe\x68\xfe\x00\x00\x00\x00\x91\xfe\x00\x00\x00\x00\xaa\xfe\x89\xfe\x00\x00\x00\x00\xe9\xff\x00\x00\x00\x00\xae\xff\x88\xff\xad\xff\x00\x00\x00\x00\xbc\xff\xe1\xfc\xe0\xfc\xbc\xff\xac\xff\xaa\xff\xab\xff\x8c\xff\xed\xff\xe2\xfc\xe3\xfc\xea\xff\x00\x00\xd9\xff\xdd\xff\xda\xff\xdc\xff\xdb\xff\xde\xff\xec\xff\xa4\xfe\x9a\xfe\xa3\xfe\x00\x00\x6a\xfe\x00\x00\x00\x00\xaf\xfe\x00\x00\x00\x00\x88\xfe\x82\xfe\x00\x00\x81\xfe\x49\xfd\x46\xfd\x4c\xfd\x4e\xfd\xdf\xfc\x47\xfd\x00\x00\x80\xfe\x00\x00\x4d\xfd\x83\xfe\x84\xfe\x00\x00\x00\x00\x24\xfd\x3f\xfd\x00\x00\x00\x00\x00\x00\x34\xfd\x33\xfd\xa9\xfe\x23\xfd\x35\xfd\x36\xfd\x39\xfd\x6e\xfe\x00\x00\x70\xfe\x7d\xfe\xee\xff\x5b\xfd\x62\xfd\x19\xfd\x59\xfd\x53\xfd\x28\xfd\x19\xfe\x1a\xfe\x1b\xfe\x1c\xfe\x1d\xfe\xb2\xfe\x16\xfe\xfe\xfd\x00\x00\x81\xfd\x7e\xfd\x7b\xfd\x7d\xfd\x84\xfd\xfb\xfd\x00\x00\x00\x00\x00\x00\xab\xfd\xa9\xfd\x9b\xfd\x98\xfd\x00\x00\x04\xfe\x00\x00\x00\x00\x00\x00\x8a\xfd\x00\x00\x00\x00\x02\xfe\x01\xfe\x00\x00\x91\xfd\x11\xfe\x00\x00\x00\x00\x8f\xfd\xb6\xfe\x00\x00\xeb\xfd\xc3\xfd\x00\x00\x00\x00\xea\xfd\x00\x00\x00\x00\x00\x00\x1a\xfd\xc7\xfd\xcb\xfd\xec\xfd\xcd\xfd\xc6\xfd\xcc\xfd\xed\xfd\x00\x00\xe3\xfd\xe0\xfd\xe1\xfd\xd2\xfd\xd3\xfd\x00\x00\x00\x00\xdf\xfd\xe2\xfd\xdb\xfd\xd9\xfd\x50\xfd\x00\x00\x00\x00\x51\xfd\x2d\xfe\x31\xfd\x72\xff\x32\xfd\x56\xfd\x00\x00\x2f\xfe\xb1\xfe\x00\x00\x9e\xfe\x99\xfe\x00\x00\x69\xfe\x00\x00\x00\x00\x36\xfe\xf0\xfe\xb8\xfe\x35\xfe\x00\x00\x78\xfd\xf4\xfd\x00\x00\x00\x00\x00\x00\x73\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xdc\xfc\xdb\xfc\x1a\xfd\xcf\xfd\xee\xfd\xef\xfd\xd0\xfd\x00\x00\x00\x00\x00\x00\x2b\xff\x00\x00\xb7\xfe\x00\x00\x99\xfe\x00\x00\x69\xfe\x14\xfe\x39\xfe\xe8\xfe\x31\xfe\x00\x00\x00\x00\x00\x00\xfd\xfe\x61\xfe\x29\xff\x00\x00\x4c\xff\x4d\xff\x4e\xff\x50\xff\x4f\xff\xf3\xfe\x1a\xff\x00\x00\x27\xff\x53\xff\x00\x00\x00\x00\x00\x00\xc2\xfe\xc1\xfe\xc0\xfe\xbf\xfe\xbe\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x11\xff\x0e\xff\x00\x00\x00\x00\x00\x00\xdc\xfe\xe1\xfe\x00\x00\x65\xff\xe6\xfe\xce\xfe\xc9\xfe\xcd\xfe\x67\xff\xd1\xfe\x00\x00\xd3\xfe\x66\xff\xd6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xff\x3a\xfe\x86\xff\x7f\xff\x84\xff\xbc\xff\xbc\xff\xb8\xff\xb7\xff\xb4\xff\x6f\xff\xb9\xff\x8a\xff\xb5\xff\xb6\xff\xa8\xff\x00\x00\x00\x00\xa8\xff\x81\xff\x80\xff\x61\xff\x00\x00\x00\x00\x5e\xff\x62\xff\x00\x00\xc8\xfe\xc6\xfe\x00\x00\xd7\xfe\x6a\xfd\xd2\xfe\x00\x00\xca\xfe\xe7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x13\xff\x14\xff\x00\x00\x0c\xff\x0d\xff\x08\xff\x00\x00\x10\xff\x00\x00\xc4\xfe\x00\x00\xbc\xfe\xbb\xfe\xbd\xfe\x00\x00\xc3\xfe\x59\xff\x00\x00\x47\xff\x00\x00\x00\x00\x1b\xff\x19\xff\x18\xff\x15\xff\x16\xff\x54\xff\x00\x00\x00\x00\x69\xff\x55\xff\x00\x00\x65\xfe\x63\xfe\x00\x00\x5a\xff\x00\x00\x21\xff\x00\x00\xe8\xfe\x33\xfe\x32\xfe\x00\x00\x00\x00\x00\x00\x98\xfe\x00\x00\x00\x00\x2c\xfd\x5c\xfe\x47\xfe\x00\x00\x00\x00\x2b\xff\x1e\xff\x00\x00\xce\xfd\xca\xfd\xdd\xfc\x26\xfd\x5d\xfd\xb3\xfe\x2b\xfe\x71\xfd\x6e\xfd\x60\xfd\x6d\xfd\x28\xfe\x00\x00\x21\xfe\x00\x00\x00\x00\x25\xfe\x2a\xfe\xeb\xfe\x79\xfd\xee\xfe\xf1\xfe\x00\x00\xea\xfe\xed\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\xfd\xd4\xfd\x71\xff\xd6\xfd\xd8\xfd\xdd\xfd\xc9\xfd\xc8\xfd\xd1\xfd\xbd\xfd\xac\xfd\xbc\xfd\xba\xfd\xb7\xfd\xb6\xfd\x00\x00\xae\xfd\xd1\xfd\xbf\xfd\xc1\xfd\xbe\xfd\x00\x00\x00\x00\x90\xfd\x00\x00\xa4\xfd\xa0\xfd\xb6\xfe\xa5\xfd\x00\x00\x00\x00\xa6\xfd\x00\x00\x08\xfe\x8e\xfd\x8b\xfd\x8d\xfd\x09\xfe\x12\xfe\x00\x00\x00\x00\x00\x00\x99\xfd\x0e\xfe\x00\x00\x00\x00\xf8\xfd\x79\xfe\x1c\xfd\x00\x00\x2f\xfd\x6d\xfe\x6c\xfe\x6b\xfe\x00\x00\x5f\xfe\x00\x00\x00\x00\xd3\xfc\x00\x00\xa5\xfe\x00\x00\x00\x00\x00\x00\xeb\xff\xa8\xff\xa8\xff\x00\x00\xa1\xff\x00\x00\xe8\xff\xc1\xff\xc1\xff\xd8\xff\x00\x00\xd3\xfc\xd4\xfc\xd1\xfc\x77\xfe\x7f\xfe\x86\xfe\x00\x00\x7f\xfd\x7c\xfd\x97\xfd\xaa\xfd\x03\xfe\x8c\xfd\x00\x00\xa8\xfd\xa3\xfd\x00\x00\xa1\xfd\xa7\xfd\xb5\xfe\x00\x00\xc2\xfd\xb5\xfd\xfa\xfc\x00\x00\x00\x00\x00\x00\x70\xff\x8d\xff\x73\xff\xa0\xfe\x97\xfe\x9f\xfe\x00\x00\xb0\xfe\x2e\xfe\x77\xfd\xf2\xfe\x7a\xfd\x00\x00\xae\xfe\x00\x00\x20\xfe\x00\x00\x1f\xff\x5c\xfe\x47\xfe\x2a\xff\xd1\xfc\x57\xff\x46\xfe\x44\xfe\x48\xff\x47\xfe\x00\x00\x00\x00\x9f\xfe\x00\x00\xe9\xfe\x34\xfe\x00\x00\xfe\xfe\x01\xff\x01\xff\x60\xfe\x61\xfe\x61\xfe\x28\xff\x1c\xff\xf4\xfe\xf7\xfe\xf7\xfe\x17\xff\x25\xff\x26\xff\x42\xff\x00\x00\x38\xff\x00\x00\x00\x00\xc5\xfe\x55\xfd\x00\x00\x0f\xff\x12\xff\x00\x00\x00\x00\xdb\xfe\xd9\xfe\x00\x00\x00\x00\xe0\xfe\xde\xfe\x00\x00\xcc\xfe\x00\x00\xc7\xfe\x00\x00\x64\xff\x00\x00\x00\x00\x82\xff\x00\x00\x00\x00\x00\x00\x00\x00\x89\xff\x8e\xff\x00\x00\xbe\xff\xbd\xff\x00\x00\x7d\xff\x5f\xff\x60\xff\xcb\xfe\xdf\xfe\x00\x00\x00\x00\xda\xfe\xdd\xfe\xef\xfe\xef\xfe\x0b\xff\xb9\xfe\x00\x00\x46\xff\x00\x00\x58\xff\x00\x00\xfc\xfe\x1d\xff\xf8\xfe\x00\x00\xfb\xfe\x2d\xff\x00\x00\x00\x00\x64\xfe\x62\xfe\x07\xff\x02\xff\x00\x00\x06\xff\x32\xff\x00\x00\x00\x00\x00\x00\x30\xfe\xa1\xfe\x96\xfe\x59\xfe\x59\xfe\x56\xff\x00\x00\x45\xfe\x55\xfe\x53\xfe\x4f\xfe\x52\xff\x47\xfe\x26\xfe\x27\xfe\x00\x00\xad\xfd\xb9\xfd\xb8\xfd\xbb\xfd\x00\x00\x00\x00\x00\x00\xc0\xfd\x13\xfe\xa2\xfd\x9f\xfd\xe8\xfe\x9c\xfd\x00\x00\x00\x00\x00\x00\x7a\xfe\x4a\xfe\x48\xfe\x67\xfe\x00\x00\xcc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\xff\xa3\xff\xa1\xff\x9e\xff\x9f\xff\xa0\xff\x00\x00\xb2\xff\x8b\xff\x8b\xff\xa2\xff\xa1\xff\x9a\xff\x92\xff\x8f\xff\x45\xfd\x90\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa1\xff\xa9\xff\xb3\xff\xd0\xff\xcd\xff\xd7\xff\xe7\xff\xf5\xfc\x00\x00\x00\x00\xcf\xff\x00\x00\x00\x00\x9d\xfd\x9e\xfd\xb4\xfd\xb3\xfd\x00\x00\xad\xfe\x51\xff\x00\x00\x69\xfe\x00\x00\x3c\xfd\x43\xfe\x00\x00\x00\x00\x5a\xfe\x57\xfe\x00\x00\x00\x00\x00\x00\x00\xff\x03\xff\x34\xff\x24\xff\x00\x00\x00\x00\x00\x00\x00\x00\x31\xff\xff\xfe\xf6\xfe\xf9\xfe\x30\xff\xf5\xfe\x00\x00\x41\xff\x39\xff\x39\xff\x00\x00\xba\xfe\x00\x00\x00\x00\x00\x00\xe3\xfe\x7b\xff\x00\x00\xc5\xff\x8b\xff\x8b\xff\xc4\xff\x00\x00\x00\x00\x7e\xff\x87\xff\x7c\xff\x00\x00\xa1\xff\x00\x00\x0a\xff\x09\xff\x45\xff\x43\xff\x00\x00\x3a\xff\x00\x00\x00\x00\x00\x00\x2b\xff\xfa\xfe\x29\xff\x00\x00\x24\xff\x33\xff\x36\xff\x00\x00\x00\x00\x04\xff\x5e\xfe\x00\x00\x00\x00\x59\xfe\x5d\xfe\x72\xfe\x99\xfe\x00\x00\x42\xfe\x3b\xfd\xd3\xfc\x00\x00\x00\x00\x4e\xfe\x93\xfe\xd3\xfc\x00\x00\x00\x00\x10\xfe\xc8\xff\xc9\xff\xc6\xff\x00\x00\xc7\xff\x00\x00\xce\xff\xa7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9b\xff\x00\x00\x91\xff\x9c\xff\x9d\xff\x98\xff\xa4\xff\xaf\xff\xb0\xff\xa1\xff\x00\x00\x97\xff\x95\xff\x94\xff\x93\xff\x44\xfd\x43\xfd\x41\xfd\x42\xfd\x00\x00\xd3\xff\xd1\xff\x00\x00\xe3\xff\x00\x00\xa8\xff\xa8\xff\x00\x00\xb2\xfd\x51\xfe\x94\xfe\x00\x00\x00\x00\x50\xfe\xd1\xfc\x41\xfe\x00\x00\x5b\xfe\x56\xfe\x58\xfe\x00\x00\x8a\xfe\x00\x00\x23\xff\x35\xff\x00\x00\x05\xff\x37\xff\x5c\xfe\x47\xfe\x3e\xff\x40\xff\x3b\xff\x3d\xff\x3f\xff\x44\xff\xd8\xfe\x00\x00\xa1\xff\xbb\xff\xba\xff\x00\x00\x7a\xff\x3c\xff\x2f\xff\x47\xfe\x8a\xfe\x00\x00\x71\xfe\x54\xfe\x4e\xfe\xd3\xfc\x4d\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xe4\xff\x00\x00\xd6\xff\xd4\xff\x00\x00\x99\xff\xa5\xff\xa3\xff\x96\xff\xd5\xff\xd2\xff\xe5\xff\x00\x00\x00\x00\xe2\xff\x00\x00\x00\x00\x00\x00\x52\xfe\x22\xff\x2e\xff\x79\xff\xca\xff\xcb\xff\x00\x00\x00\x00\xe1\xff\xdf\xff\xe0\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x00\x00\x0d\x00\x3a\x00\x05\x00\x06\x00\x23\x00\x24\x00\x06\x00\x44\x00\x0f\x00\x10\x00\x0f\x00\x10\x00\x13\x00\x11\x00\x13\x00\x13\x00\x4e\x00\x10\x00\x0c\x00\x0d\x00\x13\x00\x12\x00\x13\x00\x14\x00\x13\x00\x14\x00\x4e\x00\x18\x00\x08\x00\x09\x00\x0a\x00\x4e\x00\x1b\x00\x04\x00\x1d\x00\x73\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x04\x00\x09\x00\x0a\x00\x04\x00\x08\x00\x09\x00\x0a\x00\x08\x00\x09\x00\x0a\x00\x44\x00\x5c\x00\x21\x00\x22\x00\x23\x00\x24\x00\x21\x00\x22\x00\x23\x00\x24\x00\x7c\x00\x21\x00\x22\x00\x23\x00\x24\x00\x13\x00\x5b\x00\x22\x00\x23\x00\x24\x00\x5b\x00\x98\x00\x23\x00\x24\x00\x3b\x00\x3c\x00\x23\x00\x24\x00\x5c\x00\xa3\x00\xa4\x00\x7b\x00\x7c\x00\x13\x00\x01\x00\x45\x00\x00\x00\x9f\x00\xa0\x00\xa1\x00\x0a\x00\x00\x00\xa7\x00\xa8\x00\xa9\x00\xcb\x00\x00\x00\x3b\x00\x3c\x00\xde\x00\xa2\x00\x35\x00\xcb\x00\x00\x00\x56\x00\x00\x00\x51\x00\x11\x00\x97\x00\x98\x00\xa2\x00\x50\x00\x51\x00\x4f\x00\x19\x00\xa2\x00\x34\x00\x35\x00\xfd\x00\x25\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\x2a\x00\x2b\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x4d\x00\x0c\x00\x29\x00\x2a\x00\x2b\x00\x70\x00\x71\x00\x51\x00\x4d\x00\x4f\x00\x54\x00\x6c\x00\x56\x00\x77\x00\x63\x00\x19\x00\x5a\x00\x72\x00\x68\x00\x01\x00\x11\x00\x64\x00\x20\x01\x78\x00\x63\x00\x8a\x00\x1e\x01\x7c\x00\x00\x00\x00\x00\x47\x00\x70\x00\x71\x00\xf4\x00\xf5\x00\x2d\x00\x22\x01\x89\x00\xf9\x00\x15\x00\xfb\x00\xfc\x00\x54\x00\x81\x00\x71\x00\x73\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\x78\x00\x80\x00\x89\x00\x24\x01\x89\x00\x26\x01\x6b\x00\x66\x00\x89\x00\x0f\x01\x24\x01\x11\x01\x66\x00\x12\x01\x8a\x00\xfd\x00\x15\x01\x66\x00\x71\x00\x75\x00\x89\x00\x1b\x01\x1b\x01\x71\x00\x66\x00\x1e\x01\x66\x00\x09\x01\x0a\x01\x12\x01\x27\x01\x11\x01\x15\x01\x1e\x01\xc8\x00\x71\x00\x2d\x01\x71\x00\x1b\x01\x27\x01\x5a\x00\x1b\x01\x27\x01\x19\x01\x1a\x01\x2d\x01\x1c\x01\x0f\x01\x2d\x01\x11\x01\x20\x01\x12\x01\x27\x01\x7c\x00\x15\x01\x15\x01\x67\x00\xc8\x00\x2d\x01\x1b\x01\x1b\x01\x1b\x01\x27\x01\x64\x00\x54\x00\xf7\x00\xf8\x00\x27\x01\x2d\x01\xfb\x00\xfc\x00\x15\x01\xfe\x00\x2d\x01\x11\x01\x15\x01\x71\x00\x1b\x01\x72\x00\x73\x00\x66\x00\x1b\x01\x15\x01\x27\x01\x1b\x01\x29\x01\x2a\x01\x0d\x01\x1b\x01\xa4\x00\x82\x00\x71\x00\x6a\x00\x13\x01\x14\x01\x15\x01\x16\x01\x23\x01\x18\x01\x19\x01\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x23\x01\x11\x01\x50\x00\x23\x01\x2b\x01\x00\x00\x2b\x01\x2b\x01\x13\x00\x23\x01\x89\x00\x1b\x01\x2b\x01\x15\x01\x2b\x01\x1b\x01\x2b\x01\x74\x00\x75\x00\x1b\x01\x82\x00\x58\x00\xa8\x00\xa9\x00\x1b\x01\x5c\x00\x27\x01\x1b\x01\x29\x01\x2a\x01\x27\x01\x1b\x01\x29\x01\x2a\x01\x1b\x01\x27\x01\x72\x00\x29\x01\x2a\x01\x15\x01\x27\x01\x34\x00\x29\x01\x2a\x01\x27\x01\x1b\x01\x29\x01\x2a\x01\x27\x01\x98\x00\x29\x01\x2a\x01\x02\x01\x13\x00\x04\x01\x00\x00\x06\x01\x02\x01\xb3\x00\x04\x01\x19\x00\x06\x01\x02\x01\x00\x00\x04\x01\x64\x00\x06\x01\x50\x00\x51\x00\x13\x01\x14\x01\x15\x01\x97\x00\x98\x00\x13\x01\x14\x01\x15\x01\x1b\x01\x71\x00\x13\x01\x14\x01\x15\x01\x1b\x01\x7d\x00\x39\x00\x14\x00\x34\x00\x1b\x01\x3d\x00\x3e\x00\x3f\x00\x40\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\x12\x01\x3e\x00\x3f\x00\x15\x01\x4d\x00\xf4\x00\xf5\x00\x00\x00\x4d\x00\x1b\x01\xf9\x00\x66\x00\xfb\x00\xfc\x00\x50\x00\x54\x00\x55\x00\x27\x01\x31\x00\x32\x00\x59\x00\x89\x00\x71\x00\x2d\x01\x15\x01\x5e\x00\x64\x00\x13\x00\x00\x00\x58\x00\x1b\x01\x12\x01\x58\x00\x1e\x01\x15\x01\x12\x01\x0c\x00\x63\x00\x15\x01\x71\x00\x1b\x01\x97\x00\x98\x00\x54\x00\x1b\x01\x4d\x00\x6b\x00\x1e\x01\x72\x00\xf4\x00\xf5\x00\x78\x00\x1c\x00\x27\x01\xf9\x00\x80\x00\xfb\x00\xfc\x00\x39\x00\x2d\x01\x34\x00\x66\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xa1\x00\x4d\x00\x12\x01\x66\x00\x81\x00\x15\x01\x0f\x01\x81\x00\x11\x01\x89\x00\x9b\x00\x1b\x01\x4d\x00\x12\x01\x71\x00\x71\x00\x15\x01\x56\x00\x1b\x01\x54\x00\x55\x00\x5a\x00\x1b\x01\x54\x00\x59\x00\x1e\x01\x19\x00\x6e\x00\x54\x00\x5e\x00\x0f\x01\x72\x00\x11\x01\x97\x00\x98\x00\x4e\x00\x33\x00\x71\x00\xad\x00\xae\x00\xaf\x00\x54\x00\x1b\x01\x66\x00\x64\x00\xb4\x00\x2d\x00\x6c\x00\xb7\x00\x54\x00\xfe\x00\xba\x00\xbb\x00\x72\x00\x71\x00\x78\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x39\x00\x0b\x01\x66\x00\x0d\x01\x9f\x00\xa0\x00\xa1\x00\x8a\x00\x9b\x00\x72\x00\x50\x00\x67\x00\x16\x01\x71\x00\x18\x01\x19\x01\x1a\x01\x72\x00\x1c\x01\x4c\x00\x4d\x00\x1f\x01\x20\x01\x97\x00\x98\x00\x4e\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\x5a\x00\x54\x00\x59\x00\x0f\x01\x72\x00\x11\x01\x80\x00\x5e\x00\x6c\x00\x4d\x00\xed\x00\xee\x00\x63\x00\x64\x00\x72\x00\x1b\x01\xad\x00\xae\x00\xaf\x00\x64\x00\xf7\x00\xf8\x00\x14\x00\xb4\x00\xfb\x00\xfc\x00\xb7\x00\x89\x00\x64\x00\xba\x00\xbb\x00\x72\x00\x71\x00\x1e\x01\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x64\x00\x71\x00\x4f\x00\x9f\x00\xa0\x00\xa1\x00\x75\x00\x12\x01\x13\x01\x14\x01\x15\x01\x31\x00\x32\x00\x71\x00\x5b\x00\x5c\x00\x1b\x01\x19\x00\x1d\x01\x1e\x01\x61\x00\x0f\x01\x21\x01\x11\x01\xf9\x00\xfa\x00\xfb\x00\xfc\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x54\x00\x1b\x01\x75\x00\x51\x00\x50\x00\x2d\x00\x73\x00\x55\x00\xed\x00\xee\x00\x77\x00\x78\x00\x54\x00\x80\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xf7\x00\xf8\x00\x19\x00\xb4\x00\xfb\x00\xfc\x00\xb7\x00\x6c\x00\x6e\x00\xba\x00\xbb\x00\x1e\x01\x72\x00\x72\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x27\x01\x39\x00\x2d\x00\x0f\x01\x72\x00\x11\x01\x2d\x01\x12\x01\x13\x01\x14\x01\x15\x01\xf9\x00\xfa\x00\xfb\x00\xfc\x00\x1b\x01\x1b\x01\x4f\x00\x1d\x01\x1e\x01\x4c\x00\x4d\x00\x21\x01\xf9\x00\xfa\x00\xfb\x00\xfc\x00\x1e\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x64\x00\x59\x00\x84\x00\x85\x00\x86\x00\x0f\x01\x5e\x00\x11\x01\xed\x00\xee\x00\x2d\x00\x63\x00\x64\x00\x71\x00\x6c\x00\x91\x00\x1e\x01\x1b\x01\xf7\x00\xf8\x00\x72\x00\x6c\x00\xfb\x00\xfc\x00\x4d\x00\x1f\x00\x78\x00\x72\x00\x1e\x01\x07\x01\x08\x01\xf4\x00\xf5\x00\xe8\x00\xe9\x00\xea\x00\xf9\x00\x27\x01\xfb\x00\xfc\x00\x2e\x00\x2f\x00\x04\x01\x2d\x01\x06\x01\x12\x01\x13\x01\x14\x01\x15\x01\x68\x00\x64\x00\x2d\x00\x2e\x00\xb7\x00\x1b\x01\x11\x01\x1d\x01\x1e\x01\x24\x01\x72\x00\x21\x01\x12\x01\xfd\x00\x71\x00\x15\x01\x1b\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x1b\x01\xe9\x00\xea\x00\x1e\x01\x09\x01\x0a\x01\x13\x01\x14\x01\x15\x01\xf9\x00\xfa\x00\xfb\x00\xfc\x00\x9b\x00\x1b\x01\xad\x00\xae\x00\xaf\x00\xb0\x00\x64\x00\x19\x01\x1a\x01\xb4\x00\x1c\x01\x6c\x00\xb7\x00\x39\x00\x20\x01\xba\x00\xbb\x00\x72\x00\x68\x00\x71\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x48\x00\x49\x00\x5b\x00\x5c\x00\x13\x01\x14\x01\x15\x01\x1e\x01\x61\x00\x56\x00\x5b\x00\x5c\x00\x1b\x01\x5a\x00\xfd\x00\x30\x00\x61\x00\x00\x01\x01\x01\x59\x00\x55\x00\x04\x01\x1e\x00\x06\x01\x5e\x00\x1a\x00\x3b\x00\x3c\x00\x6b\x00\x54\x00\x77\x00\x56\x00\x0f\x01\x67\x00\x11\x01\x4f\x00\x63\x00\x2d\x00\x77\x00\x76\x00\xed\x00\xee\x00\x7b\x00\x7a\x00\x1b\x01\x2e\x00\x2f\x00\x5b\x00\x5c\x00\x20\x01\xf7\x00\xf8\x00\xf5\x00\x61\x00\xfb\x00\xfc\x00\xf9\x00\x15\x01\xfb\x00\xfc\x00\x84\x00\x85\x00\x86\x00\x1b\x01\x6c\x00\x1d\x01\x1e\x01\x8b\x00\x1e\x00\x8d\x00\x72\x00\x8f\x00\x90\x00\x91\x00\x4e\x00\x77\x00\x78\x00\x12\x01\x13\x01\x14\x01\x15\x01\x12\x01\x56\x00\x2d\x00\x15\x01\x68\x00\x1b\x01\x76\x00\x1d\x01\x1e\x01\x1b\x01\x7a\x00\x21\x01\x1e\x01\x1e\x00\x72\x00\x27\x01\x6b\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x2d\x01\xad\x00\xae\x00\xaf\x00\xb0\x00\x4e\x00\x76\x00\x2d\x00\xb4\x00\xb7\x00\x7a\x00\xb7\x00\x39\x00\x56\x00\xba\x00\xbb\x00\x4f\x00\x68\x00\x55\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x58\x00\x11\x01\x72\x00\x5b\x00\x4f\x00\xb1\x00\xb2\x00\xb3\x00\x84\x00\x85\x00\x86\x00\x1b\x01\x6b\x00\x58\x00\x6e\x00\x9b\x00\x5b\x00\x5c\x00\x72\x00\x59\x00\x90\x00\x91\x00\x61\x00\x76\x00\x5e\x00\x1f\x01\x20\x01\x7a\x00\x15\x01\x57\x00\x24\x01\x77\x00\x78\x00\x67\x00\x1b\x01\x7b\x00\x7c\x00\x1e\x01\xeb\x00\xec\x00\xed\x00\xee\x00\x80\x00\x12\x01\x77\x00\x78\x00\x15\x01\x80\x00\x7b\x00\x7c\x00\xf7\x00\xf8\x00\x1b\x01\x12\x01\xfb\x00\xfc\x00\x15\x01\x00\x01\x01\x01\xb7\x00\x03\x01\x04\x01\x1b\x01\x06\x01\x07\x01\x08\x01\x72\x00\x6e\x00\x13\x01\x14\x01\x15\x01\x72\x00\x0f\x01\x10\x01\x11\x01\x81\x00\x1b\x01\x12\x01\x13\x01\x14\x01\x15\x01\x67\x00\x02\x00\x03\x00\x1b\x01\x6b\x00\x1b\x01\x6d\x00\x1d\x01\x1e\x01\x6e\x00\x71\x00\x21\x01\x9b\x00\x72\x00\x0f\x01\x76\x00\x11\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x15\x01\xad\x00\xae\x00\xaf\x00\xb0\x00\x1b\x01\x1b\x01\xdc\x00\xb4\x00\xde\x00\x15\x01\xb7\x00\x39\x00\x89\x00\xba\x00\xbb\x00\x1b\x01\x50\x00\x51\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x48\x00\x49\x00\x72\x00\x76\x00\x4a\x00\x00\x01\x01\x01\x7a\x00\x03\x01\x04\x01\x4d\x00\x06\x01\x07\x01\x08\x01\x51\x00\x13\x01\x14\x01\x15\x01\x67\x00\x59\x00\x0f\x01\x10\x01\x11\x01\x1b\x01\x5e\x00\x5f\x00\x60\x00\x67\x00\x9b\x00\x69\x00\x67\x00\x6b\x00\x1b\x01\x6d\x00\x6b\x00\x23\x00\x6d\x00\x80\x00\xeb\x00\xec\x00\xed\x00\xee\x00\x76\x00\xf7\x00\xf8\x00\x76\x00\x7a\x00\xfb\x00\xfc\x00\x7a\x00\xf7\x00\xf8\x00\x27\x01\x67\x00\xfb\x00\xfc\x00\x6b\x00\x6b\x00\x2d\x01\x6d\x00\x84\x00\x85\x00\x86\x00\x19\x01\x1a\x01\x18\x00\x1c\x01\x8b\x00\x76\x00\x8d\x00\x20\x01\x8f\x00\x90\x00\x91\x00\x24\x01\x3e\x00\x3f\x00\x12\x01\x13\x01\x14\x01\x15\x01\x1d\x01\x1e\x01\x4d\x00\x14\x01\x15\x01\x1b\x01\x51\x00\x1d\x01\x1e\x01\x9b\x00\x1b\x01\x21\x01\x1d\x01\x1e\x01\xb1\x00\xb2\x00\xb3\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x39\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\x63\x00\x76\x00\x65\x00\xb4\x00\xb7\x00\x7a\x00\xb7\x00\x39\x00\x4f\x00\xba\x00\xbb\x00\x9a\x00\x9b\x00\x9c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x5b\x00\x5c\x00\x01\x01\x9b\x00\x4a\x00\x04\x01\x61\x00\x06\x01\x18\x01\x19\x01\x1a\x01\x89\x00\x1c\x01\x8b\x00\x8c\x00\x1f\x01\x20\x01\x6c\x00\x20\x01\x59\x00\x24\x01\x34\x00\x24\x01\x72\x00\x5e\x00\x5f\x00\x60\x00\x9b\x00\x77\x00\x78\x00\x13\x00\x81\x00\x7b\x00\x7c\x00\x84\x00\x85\x00\x86\x00\x64\x00\x88\x00\x89\x00\xed\x00\xee\x00\x8c\x00\x8d\x00\x28\x01\x8f\x00\x90\x00\x91\x00\x2c\x01\x28\x01\xf7\x00\xf8\x00\x28\x01\x2c\x01\xfb\x00\xfc\x00\x2c\x01\x00\x01\x01\x01\x4d\x00\x03\x01\x04\x01\x28\x01\x06\x01\x07\x01\x08\x01\x2c\x01\x13\x01\x14\x01\x15\x01\x3e\x00\x3f\x00\x0f\x01\x10\x01\x11\x01\x1b\x01\x71\x00\x12\x01\x13\x01\x14\x01\x15\x01\x50\x00\x51\x00\x28\x01\x1b\x01\xb7\x00\x1b\x01\x2c\x01\x1d\x01\x1e\x01\x19\x01\x1a\x01\x21\x01\x1c\x01\x13\x01\x14\x01\x15\x01\x4d\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x1b\x01\xad\x00\xae\x00\xaf\x00\xb0\x00\x13\x01\x14\x01\x15\x01\xb4\x00\x02\x00\x03\x00\xb7\x00\x39\x00\x1b\x01\xba\x00\xbb\x00\x56\x00\x57\x00\x58\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x63\x00\x49\x00\x65\x00\x13\x01\x14\x01\x15\x01\x4c\x00\x4d\x00\x84\x00\x85\x00\x86\x00\x1b\x01\xed\x00\x51\x00\x8a\x00\x84\x00\x85\x00\x86\x00\x8e\x00\x59\x00\x51\x00\x91\x00\x1f\x00\x54\x00\x5e\x00\x8e\x00\x76\x00\x51\x00\x91\x00\x63\x00\x54\x00\x00\x01\x01\x01\x72\x00\x03\x01\x04\x01\x67\x00\x06\x01\x07\x01\x08\x01\xed\x00\xee\x00\xa6\x00\xaa\x00\xab\x00\xac\x00\x0f\x01\x10\x01\x11\x01\xa6\x00\xf7\x00\xf8\x00\xb5\x00\xb6\x00\xfb\x00\xfc\x00\x68\x00\x69\x00\x1b\x01\xb7\x00\x84\x00\x85\x00\x86\x00\xff\x00\x00\x01\x01\x01\xb7\x00\x8b\x00\x04\x01\x8d\x00\x06\x01\x8f\x00\x90\x00\x91\x00\x14\x01\x15\x01\x50\x00\x12\x01\x13\x01\x14\x01\x15\x01\x1b\x01\x01\x01\x1d\x01\x1e\x01\x04\x01\x1b\x01\x06\x01\x1d\x01\x1e\x01\x51\x00\x63\x00\x21\x01\x65\x00\x13\x01\x14\x01\x15\x01\x56\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x1b\x01\xad\x00\xae\x00\xaf\x00\xb0\x00\xaa\x00\xab\x00\xac\x00\xb4\x00\xb7\x00\x4d\x00\xb7\x00\x39\x00\x4d\x00\xba\x00\xbb\x00\xaa\x00\xab\x00\xac\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x04\x01\x05\x01\x06\x01\x4d\x00\x4a\x00\x00\x01\x01\x01\x11\x00\x63\x00\x04\x01\x65\x00\x06\x01\x00\x01\x01\x01\x4d\x00\x63\x00\x04\x01\x65\x00\x06\x01\x59\x00\x0f\x01\x63\x00\x11\x01\x65\x00\x5e\x00\x5f\x00\x63\x00\x0f\x01\x65\x00\x11\x01\x54\x00\xf6\x00\x1b\x01\xf8\x00\x5a\x00\x63\x00\xfb\x00\x65\x00\x47\x00\x1b\x01\xed\x00\xee\x00\xff\x00\x00\x01\x01\x01\x80\x00\x63\x00\x04\x01\x65\x00\x06\x01\xf7\x00\xf8\x00\xb5\x00\xb6\x00\xfb\x00\xfc\x00\x56\x00\x00\x01\x01\x01\x12\x01\x03\x01\x04\x01\x15\x01\x06\x01\x07\x01\x08\x01\x6c\x00\x63\x00\x1b\x01\x65\x00\x1d\x01\x1e\x01\x0f\x01\x10\x01\x11\x01\x68\x00\x69\x00\x12\x01\x13\x01\x14\x01\x15\x01\xda\x00\xdb\x00\xdc\x00\x1b\x01\xde\x00\x1b\x01\x6c\x00\x1d\x01\x1e\x01\x6b\x00\x6c\x00\x21\x01\x49\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x6c\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\x18\x01\x19\x01\x1a\x01\xb4\x00\x1c\x01\x6c\x00\xb7\x00\x39\x00\x6c\x00\xba\x00\xbb\x00\xaa\x00\xab\x00\xac\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x63\x00\x49\x00\x65\x00\x4f\x00\x50\x00\x51\x00\xb5\x00\xb6\x00\x54\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x72\x00\x5b\x00\x5c\x00\x50\x00\x63\x00\x59\x00\x65\x00\x61\x00\x6d\x00\x6e\x00\x5e\x00\x84\x00\x85\x00\x86\x00\xaa\x00\xab\x00\xac\x00\x4d\x00\x8b\x00\x67\x00\x8d\x00\x54\x00\x8f\x00\x90\x00\x91\x00\x73\x00\xed\x00\xee\x00\x0d\x00\x77\x00\x78\x00\x25\x01\x26\x01\x7b\x00\x7c\x00\x72\x00\xf7\x00\xf8\x00\x68\x00\x69\x00\xfb\x00\xfc\x00\xaa\x00\xab\x00\xac\x00\x68\x00\x84\x00\x85\x00\x86\x00\xff\x00\x00\x01\x01\x01\x6a\x00\x8b\x00\x04\x01\x8d\x00\x06\x01\x8f\x00\x90\x00\x91\x00\x07\x01\x08\x01\xb7\x00\x12\x01\x13\x01\x14\x01\x15\x01\x18\x01\x19\x01\x1a\x01\x6c\x00\x1c\x01\x1b\x01\x6c\x00\x1d\x01\x1e\x01\x93\x00\x63\x00\x21\x01\x65\x00\x63\x00\x63\x00\x65\x00\x65\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x91\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\x63\x00\x91\x00\x65\x00\xb4\x00\xb7\x00\x91\x00\xb7\x00\x39\x00\x6e\x00\xba\x00\xbb\x00\xec\x00\xed\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\x00\x00\x01\x01\x01\x9b\x00\x9c\x00\x04\x01\x72\x00\x06\x01\x84\x00\x85\x00\x86\x00\x36\x00\x37\x00\x6a\x00\x68\x00\x72\x00\x81\x00\x4d\x00\x8e\x00\x59\x00\x4d\x00\x91\x00\x00\x01\x01\x01\x5e\x00\x03\x01\x04\x01\x4d\x00\x06\x01\x07\x01\x08\x01\x56\x00\x0d\x00\x67\x00\x71\x00\x54\x00\x15\x00\x0f\x01\x10\x01\x11\x01\xed\x00\xee\x00\x73\x00\x73\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x73\x00\x1b\x01\xf7\x00\xf8\x00\x6e\x00\x6a\x00\xfb\x00\xfc\x00\x73\x00\x00\x01\x01\x01\xb7\x00\x03\x01\x04\x01\x6e\x00\x06\x01\x07\x01\x08\x01\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x64\x00\x61\x00\x0f\x01\x10\x01\x11\x01\x71\x00\x0c\x00\x12\x01\x13\x01\x14\x01\x15\x01\x33\x00\x49\x00\x19\x00\x1b\x01\x5b\x00\x1b\x01\x50\x00\x1d\x01\x1e\x01\x72\x00\x72\x00\x21\x01\x73\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x64\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\x6c\x00\x6c\x00\x6c\x00\xb4\x00\x6c\x00\x72\x00\xb7\x00\x39\x00\x68\x00\xba\x00\xbb\x00\x72\x00\x51\x00\x56\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x72\x00\x17\x00\x4f\x00\x72\x00\x50\x00\x00\x01\x01\x01\x6c\x00\x64\x00\x04\x01\x54\x00\x06\x01\x6c\x00\x50\x00\x84\x00\x85\x00\x86\x00\x5a\x00\x4d\x00\x59\x00\x0f\x01\x8b\x00\x11\x01\x8d\x00\x5e\x00\x8f\x00\x90\x00\x91\x00\x72\x00\x51\x00\x4f\x00\x4d\x00\x1b\x01\x50\x00\x84\x00\x85\x00\x86\x00\x50\x00\x81\x00\x68\x00\xed\x00\xee\x00\x5b\x00\x5c\x00\x4d\x00\x4d\x00\x6c\x00\x91\x00\x61\x00\x73\x00\xf7\x00\xf8\x00\x6c\x00\x54\x00\xfb\x00\xfc\x00\x72\x00\x39\x00\x73\x00\x50\x00\x5a\x00\x19\x00\xff\x00\x00\x01\x01\x01\xb7\x00\x73\x00\x04\x01\x50\x00\x06\x01\x77\x00\x78\x00\x6c\x00\x19\x00\x7b\x00\x7c\x00\x51\x00\x12\x01\x13\x01\x14\x01\x15\x01\x76\x00\x1a\x00\x80\x00\x80\x00\xb7\x00\x1b\x01\x4d\x00\x1d\x01\x1e\x01\x4d\x00\x4d\x00\x21\x01\x16\x00\x5e\x00\x0c\x00\x91\x00\x71\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x80\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xff\x00\x00\x01\x01\x01\xb4\x00\x6b\x00\x04\x01\xb7\x00\x06\x01\x4d\x00\xba\x00\xbb\x00\x4d\x00\x68\x00\x19\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xf4\x00\xf5\x00\x64\x00\x72\x00\x50\x00\xf9\x00\x73\x00\xfb\x00\xfc\x00\x54\x00\x50\x00\x00\x01\x01\x01\x50\x00\x03\x01\x04\x01\x50\x00\x06\x01\x07\x01\x08\x01\x72\x00\x51\x00\x19\x00\x61\x00\x19\x00\x56\x00\x0f\x01\x10\x01\x11\x01\x07\x00\x12\x01\x00\x01\x01\x01\x15\x01\x51\x00\x04\x01\x49\x00\x06\x01\x1b\x01\x1b\x01\xed\x00\xee\x00\x1e\x01\x4d\x00\x54\x00\x68\x00\x0f\x01\x7d\x00\x11\x01\x61\x00\xf7\x00\xf8\x00\x50\x00\xb4\x00\xfb\x00\xfc\x00\xb7\x00\x56\x00\x1b\x01\xba\x00\xbb\x00\x71\x00\x71\x00\x81\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x64\x00\x54\x00\x6c\x00\x6c\x00\x6b\x00\x8a\x00\x52\x00\x12\x01\x13\x01\x14\x01\x15\x01\x68\x00\x19\x00\x19\x00\x6c\x00\x8a\x00\x1b\x01\x89\x00\x1d\x01\x1e\x01\x6c\x00\x71\x00\x21\x01\x5b\x00\x2d\x00\x84\x00\x85\x00\x86\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x8b\x00\x71\x00\x8d\x00\x51\x00\x8f\x00\x90\x00\x91\x00\x72\x00\xed\x00\xee\x00\x4d\x00\x52\x00\x4d\x00\x19\x00\x07\x00\x89\x00\x07\x00\x19\x00\xf7\x00\xf8\x00\x50\x00\x61\x00\xfb\x00\xfc\x00\x84\x00\x85\x00\x86\x00\x68\x00\x4d\x00\x89\x00\x80\x00\x8b\x00\x71\x00\x8d\x00\x02\x00\x8f\x00\x90\x00\x91\x00\x4d\x00\x52\x00\x19\x00\x4d\x00\x4d\x00\x19\x00\xb7\x00\x12\x01\x13\x01\x14\x01\x15\x01\x50\x00\x47\x00\x23\x00\x56\x00\x1a\x00\x1b\x01\x07\x00\x1d\x01\x1e\x01\x19\x00\x54\x00\x21\x01\x84\x00\x85\x00\x86\x00\x09\x00\x81\x00\x89\x00\x6c\x00\x8b\x00\x6b\x00\x8d\x00\x67\x00\x8f\x00\x90\x00\x91\x00\xb7\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\x6b\x00\xf5\x00\x4f\x00\x2e\x00\x54\x00\xf9\x00\x8a\x00\xfb\x00\xfc\x00\x84\x00\x85\x00\x86\x00\x50\x00\x71\x00\x89\x00\x71\x00\x8b\x00\x64\x00\x8d\x00\x64\x00\x8f\x00\x90\x00\x91\x00\x6b\x00\x64\x00\x50\x00\x6c\x00\x72\x00\x8a\x00\x6c\x00\x12\x01\x61\x00\xb7\x00\x15\x01\x5a\x00\x8a\x00\x81\x00\x00\x01\x01\x01\x1b\x01\x03\x01\x04\x01\x1e\x01\x06\x01\x07\x01\x08\x01\x02\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x72\x00\x0f\x01\x10\x01\x11\x01\x4d\x00\x6c\x00\x72\x00\x6b\x00\x89\x00\xb7\x00\x54\x00\x19\x00\x54\x00\x1b\x01\x84\x00\x85\x00\x86\x00\x00\x01\x01\x01\x07\x00\x03\x01\x04\x01\x6c\x00\x06\x01\x07\x01\x08\x01\x6c\x00\x91\x00\x07\x00\x50\x00\x19\x00\x19\x00\x0f\x01\x10\x01\x11\x01\x77\x00\x84\x00\x85\x00\x86\x00\x87\x00\x4f\x00\x89\x00\x77\x00\x8b\x00\x1b\x01\x8d\x00\x8a\x00\x8f\x00\x90\x00\x91\x00\x30\x00\x52\x00\x85\x00\xc7\x00\x00\x01\x01\x01\xe3\x00\x03\x01\x04\x01\x24\x01\x06\x01\x07\x01\x08\x01\xe3\x00\x38\x00\xb7\x00\x53\x00\xe3\x00\x41\x00\x0f\x01\x10\x01\x11\x01\x79\x00\x42\x00\x31\x00\x22\x01\x32\x00\x23\x01\x23\x01\x7a\x00\x06\x01\x1b\x01\x00\x01\x01\x01\x76\x00\x03\x01\x04\x01\xb7\x00\x06\x01\x07\x01\x08\x01\x76\x00\x7a\x00\x99\x00\x53\x00\x7f\x00\xc5\x00\x0f\x01\x10\x01\x11\x01\x24\x01\x84\x00\x85\x00\x86\x00\xbd\x00\x22\x01\x89\x00\x16\x00\x8b\x00\x1b\x01\x8d\x00\x16\x00\x8f\x00\x90\x00\x91\x00\x30\x00\x03\x00\xd6\x00\x23\x01\x84\x00\x85\x00\x86\x00\x87\x00\x23\x01\x89\x00\xd6\x00\x8b\x00\xde\x00\x8d\x00\x62\x00\x8f\x00\x90\x00\x91\x00\x22\x01\x4f\x00\x7e\x00\x95\x00\x96\x00\x00\x01\x01\x01\x22\x01\xed\x00\x04\x01\x28\x01\x06\x01\x22\x01\x41\x00\x66\x00\x22\x01\x28\x01\x50\x00\x6f\x00\xb7\x00\x0f\x01\x6c\x00\x11\x01\x77\x00\x34\x00\x16\x00\x16\x00\x00\x01\x01\x01\x2c\x00\x03\x01\x04\x01\x1b\x01\x06\x01\x07\x01\x08\x01\x76\x00\xb7\x00\x20\x00\x4f\x00\x20\x00\x33\x00\x0f\x01\x10\x01\x11\x01\x76\x00\x56\x00\x5d\x00\x58\x00\x59\x00\x43\x00\x5b\x00\x19\x01\x1a\x01\x1b\x01\x1c\x01\x58\x00\x6a\x00\x1f\x01\x20\x01\x1e\x01\x61\x00\x65\x00\x24\x01\x84\x00\x85\x00\x86\x00\x87\x00\x6c\x00\x89\x00\x2c\x00\x8b\x00\x9e\x00\x8d\x00\x72\x00\x8f\x00\x90\x00\x91\x00\x22\x01\x77\x00\x78\x00\x7e\x00\x0e\x00\x7b\x00\x7c\x00\x20\x00\x20\x00\x9e\x00\xbd\x00\xac\x00\x42\x00\xed\x00\x00\x01\x01\x01\x9c\x00\x03\x01\x04\x01\x46\x00\x06\x01\x07\x01\x08\x01\x23\x01\x17\x00\x17\x00\x35\x00\x47\x00\x53\x00\x0f\x01\x10\x01\x11\x01\x00\x01\x01\x01\x22\x01\x03\x01\x04\x01\xb7\x00\x06\x01\x07\x01\x08\x01\x1b\x01\x22\x01\x4b\x00\xa5\x00\x6a\x00\xde\x00\x0f\x01\x10\x01\x11\x01\x22\x01\x84\x00\x85\x00\x86\x00\x87\x00\x1c\x00\x89\x00\x1c\x00\x8b\x00\x1b\x01\x8d\x00\x26\x00\x8f\x00\x90\x00\x91\x00\x80\x00\x81\x00\x0b\x00\x24\x01\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x23\x01\x8b\x00\x8c\x00\x8d\x00\x23\x01\x8f\x00\x90\x00\x91\x00\x28\x01\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\x22\x01\xf5\x00\xed\x00\x51\x00\x23\x01\xf9\x00\x22\x01\xfb\x00\xfc\x00\x23\x01\x22\x01\x4f\x00\x22\x01\xb7\x00\x22\x01\x28\x01\x51\x00\x20\x00\x16\x00\x16\x00\x20\x00\x00\x01\x01\x01\x9e\x00\x03\x01\x04\x01\x17\x00\x06\x01\x07\x01\x08\x01\x12\x01\xb7\x00\x23\x01\x15\x01\x23\x01\x23\x01\x0f\x01\x10\x01\x11\x01\x1b\x01\x17\x00\xff\xff\x1e\x01\x23\x01\xff\xff\x80\x00\xff\xff\xff\xff\x1b\x01\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\x24\x01\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xf9\x00\xff\xff\xfb\x00\xfc\x00\xed\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\x0f\x01\x10\x01\x11\x01\x00\x01\x01\x01\x12\x01\x03\x01\x04\x01\x15\x01\x06\x01\x07\x01\x08\x01\x1b\x01\xff\xff\x1b\x01\xff\xff\xff\xff\x1e\x01\x0f\x01\x10\x01\x11\x01\x24\x01\x80\x00\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\x1b\x01\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\xff\x00\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\xff\xff\x06\x01\x80\x00\xff\xff\xff\xff\xed\x00\x84\x00\x85\x00\x86\x00\x87\x00\x0f\x01\x89\x00\x11\x01\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x1b\x01\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xb7\x00\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\x80\x00\xff\xff\xff\xff\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x1b\x01\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xb7\x00\x8f\x00\x90\x00\x91\x00\x80\x00\xff\xff\xff\xff\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xed\x00\x13\x01\x14\x01\x15\x01\xff\xff\xb7\x00\x0f\x01\x10\x01\x11\x01\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\x84\x00\x85\x00\x86\x00\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xed\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x1b\x01\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\x80\x00\xff\xff\xff\xff\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x1b\x01\x89\x00\xb7\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x80\x00\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xb7\x00\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\xff\xff\x06\x01\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\x0f\x01\xff\xff\x11\x01\x00\x01\x01\x01\x56\x00\xff\xff\x04\x01\xff\xff\x06\x01\x5b\x00\x5c\x00\x1b\x01\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x0f\x01\xff\xff\x11\x01\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xed\x00\x1b\x01\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\xff\xff\xff\xff\xff\xff\xed\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x1b\x01\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x0f\x01\x10\x01\x11\x01\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\x81\x00\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\x71\x00\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xb7\x00\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x81\x00\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xed\x00\x81\x00\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\x4f\x00\x50\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xb7\x00\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\x81\x00\x1b\x01\x61\x00\x84\x00\x85\x00\x86\x00\xfe\x00\x88\x00\x89\x00\xff\xff\xb7\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\x0b\x01\x73\x00\x0d\x01\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x16\x01\xff\xff\x18\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\xff\xff\xff\xff\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xb7\x00\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xed\x00\x00\x01\x01\x01\x95\x00\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x1b\x01\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xb7\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xed\x00\x81\x00\x1b\x01\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xed\x00\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\x02\x00\x13\x01\x14\x01\x15\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x0a\x00\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\x1b\x01\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x1b\x01\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\x75\x00\x76\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\x4f\x00\x50\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x5b\x00\x5c\x00\x3b\x00\x3c\x00\x3d\x00\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x52\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\x58\x00\x7b\x00\x7c\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\x4f\x00\x50\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x5b\x00\x5c\x00\x3b\x00\x3c\x00\x3d\x00\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x52\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\x58\x00\x7b\x00\x7c\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\x4f\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x5b\x00\x5c\x00\x3b\x00\x3c\x00\x3d\x00\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x52\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\x58\x00\x7b\x00\x7c\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x4f\x00\x50\x00\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x73\x00\x5b\x00\x5c\x00\xff\xff\x77\x00\x78\x00\xff\xff\x61\x00\x7b\x00\x7c\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\x4f\x00\xff\xff\x51\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x3b\x00\x3c\x00\x3d\x00\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\x73\x00\x52\x00\xff\xff\x54\x00\x77\x00\x78\x00\xff\xff\x58\x00\x7b\x00\x7c\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\x6e\x00\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xfe\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\x0b\x01\xff\xff\x0d\x01\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\xff\xff\x18\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\xff\xff\xff\xff\x1f\x01\x20\x01\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xfe\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\x0b\x01\xff\xff\x0d\x01\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\xff\xff\x18\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\xff\xff\xff\xff\x1f\x01\x20\x01\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xfe\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\x0b\x01\xff\xff\x0d\x01\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\xff\xff\x18\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\xff\xff\xff\xff\x1f\x01\x20\x01\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\x6e\x00\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x68\x00\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\x71\x00\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x52\x00\x93\x00\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xb7\x00\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\x0a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\x51\x00\x1b\x01\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\x71\x00\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\x3b\x00\xf8\x00\x3d\x00\xff\xff\xfb\x00\xff\xff\xff\xff\xfe\x00\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\x0a\x01\x8f\x00\x90\x00\x91\x00\x52\x00\x93\x00\xff\xff\xff\xff\x12\x01\xff\xff\x58\x00\x15\x01\xff\xff\x5b\x00\xff\xff\x19\x01\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xb7\x00\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\x0a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\x0a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xb7\x00\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\x0a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\x0a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xb7\x00\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\x0a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\x0a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xb7\x00\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\x0a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\x0a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\x58\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\x0a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x75\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xf9\x00\xff\xff\xfb\x00\xfc\x00\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\x12\x01\xff\xff\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x1c\x01\xff\xff\x1e\x01\xff\xff\x20\x01\x67\x00\xff\xff\x69\x00\x24\x01\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xb7\x00\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\xff\xff\x92\x00\x0a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xed\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\x40\x00\x41\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\x6e\x00\xb7\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\x40\x00\x41\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\x68\x00\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\x40\x00\x41\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\x40\x00\x41\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\x40\x00\x41\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\x40\x00\x41\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\xff\xff\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\x58\x00\x89\x00\xff\xff\x8b\x00\x5c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x63\x00\x94\x00\x95\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\xff\xff\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x16\x00\xff\xff\x99\x00\x9a\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\x1b\x01\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\xff\xff\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\xb7\x00\xff\xff\x9d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xed\x00\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\x1b\x01\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\x95\x00\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xb7\x00\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\x95\x00\x84\x00\x85\x00\x86\x00\x87\x00\xb7\x00\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x1b\x01\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xed\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\x1b\x01\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\x9d\x00\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\x95\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\xb7\x00\xff\xff\x9d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xed\x00\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\x1b\x01\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x98\x00\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xed\x00\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\x1b\x01\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xb7\x00\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xb7\x00\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xed\x00\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x1b\x01\xed\x00\xb7\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xed\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xed\x00\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\x1b\x01\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xb7\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xc3\x00\xc4\x00\xff\xff\xc6\x00\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\x1b\x01\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xb7\x00\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\x84\x00\x85\x00\x86\x00\xb7\x00\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xb7\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x1b\x01\xff\xff\xed\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\x1b\x01\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\xb7\x00\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x85\x00\x86\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xb7\x00\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\x1b\x01\xff\xff\xed\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\xff\xff\xed\x00\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\xff\xff\x00\x01\x01\x01\x02\x00\x03\x01\x04\x01\xff\xff\x06\x01\x07\x01\x08\x01\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x01\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x75\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x80\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\x6b\x00\xff\xff\xff\xff\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\x75\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x80\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\x02\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\x73\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x01\x00\x02\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\x73\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\xff\xff\x7c\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x02\x00\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\x13\x00\x79\x00\x7a\x00\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x02\x00\xff\xff\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x6b\x00\x0a\x00\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\x16\x00\xff\xff\x7a\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\x0a\x00\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\x16\x00\xff\xff\x7a\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x16\x00\xff\xff\xff\xff\x7a\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\xff\xff\x04\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x75\x00\xff\xff\xff\xff\x1a\x00\x79\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x75\x00\xff\xff\xff\xff\x1a\x00\x79\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\x6b\x00\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x16\x00\x75\x00\xff\xff\xff\xff\x1a\x00\x79\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x02\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x13\x00\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x75\x00\x76\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x0a\x00\xff\xff\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x75\x00\x76\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x0a\x00\xff\xff\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x75\x00\x76\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x0a\x00\xff\xff\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x75\x00\x76\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\x0a\x00\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x63\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x72\x00\xff\xff\x2c\x00\x75\x00\x02\x00\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x75\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x02\x00\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x75\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x02\x00\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x56\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x02\x00\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\xff\xff\xff\xff\xff\xff\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\x6b\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\x75\x00\xff\xff\xc9\x00\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\x19\x01\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\x19\x01\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\xff\xff\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\x13\x01\x14\x01\x15\x01\xcd\x00\xce\x00\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\x22\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\xff\xff\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xd0\x00\xd1\x00\xd2\x00\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe5\x00\xe6\x00\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xe4\x00\xff\xff\xe6\x00\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xe4\x00\xff\xff\xe6\x00\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xd4\x00\xd5\x00\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xd7\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xd4\x00\xd5\x00\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xd7\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xdc\x00\xdd\x00\xde\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xd9\x00\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xb8\x00\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xff\xff\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xff\xff\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xff\xff\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xff\xff\xb9\x00\xff\xff\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xb7\x00\xff\xff\xfb\x00\xfc\x00\xbb\x00\xbc\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xf7\x00\xf8\x00\xbb\x00\xff\xff\xfb\x00\xfc\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xe1\x00\xe2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xe1\x00\xe2\x00\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xe1\x00\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xb7\x00\xff\xff\xfb\x00\xfc\x00\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xed\x00\xee\x00\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xf7\x00\xf8\x00\xb7\x00\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xed\x00\xee\x00\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xb7\x00\xff\xff\xfb\x00\xfc\x00\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xed\x00\xee\x00\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xf7\x00\xf8\x00\xb7\x00\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xed\x00\xee\x00\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xb7\x00\xff\xff\xfb\x00\xfc\x00\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xed\x00\xee\x00\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xf7\x00\xf8\x00\xb7\x00\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xed\x00\xee\x00\x21\x01\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xed\x00\xee\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xed\x00\xee\x00\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xf7\x00\xf8\x00\xff\xff\xff\xff\xfb\x00\xfc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x6e\x00\x81\x05\x9c\x02\x3f\x05\x40\x05\xa6\x04\x9e\x04\x83\x05\x5b\x04\x99\x04\x96\x04\x95\x04\x96\x04\x97\x04\x0d\x01\x97\x04\x0e\x01\x6b\x03\x23\x05\x3c\x05\x3d\x05\x97\x04\x0f\x01\x10\x01\x11\x01\x2c\x00\x2d\x00\x0a\x04\x12\x01\x19\x02\x1a\x02\x1b\x02\x59\x05\x2e\x00\x85\x05\x2f\x00\x30\x03\x86\x05\xb7\x04\x1a\x02\x1b\x02\xb6\x04\x1a\x02\xdb\x03\x1f\x05\xb7\x04\x1a\x02\x1b\x02\xb7\x04\x1a\x02\x1b\x02\x8b\x05\x3c\x03\x9b\x04\x9c\x04\x9d\x04\x9e\x04\x62\x05\x9c\x04\x9d\x04\x9e\x04\x49\x03\x66\x05\x9c\x04\x9d\x04\x9e\x04\xc1\xff\xf8\x02\x7e\x05\x7f\x05\x9e\x04\x3e\x03\x26\x04\x2f\x05\x9e\x04\x90\x02\x91\x02\x24\x05\x9e\x04\x58\x04\x79\x04\x7a\x04\x42\x03\x43\x03\xc1\xff\x53\x03\xf9\x04\x17\x02\xd0\x04\xcc\x04\xcd\x04\xf5\x04\x17\x02\xf2\x01\xf3\x01\xf4\x01\x88\x02\x17\x02\x90\x02\x91\x02\x68\x02\x6c\x03\x99\x04\x99\x03\x17\x02\x90\x03\x17\x02\x76\x05\x57\x01\xf9\x01\xfa\x01\x0b\x04\x6f\x03\xd1\xfc\x7f\x00\x65\x03\x5a\x05\xc1\xff\x99\x04\xf5\x02\xa7\x04\x6c\x01\x36\x01\x71\x00\x23\x01\xa8\x04\xa9\x04\x33\x05\x34\x05\x35\x05\x36\x05\xa9\x04\xbc\x02\x0d\x01\x80\x05\x36\x05\xa9\x04\x33\x04\x34\x04\x9b\xfe\x0a\x03\x7f\x00\x9b\xfe\x6a\x01\x69\x03\x77\x05\x14\x01\x16\x01\x9d\xfe\x6b\x01\x3a\x04\x33\x00\x7b\x01\x4c\xfe\xa0\x02\x89\x00\x36\x00\x08\x01\x26\x01\x8c\x00\x17\x02\xff\xff\x58\x01\x54\x04\x34\x04\x2c\x01\x2d\x01\x15\x01\x69\x02\x07\x01\x22\x01\x34\x00\x71\x00\x23\x01\xdd\x02\x3b\x04\x0b\x03\xf7\x02\x6c\x01\xce\x04\x71\x00\x23\x01\x89\x00\xbd\x02\x33\x00\x89\x02\x33\x00\x8a\x02\xf6\x04\x18\x02\x07\x01\xfb\x01\x89\x02\x4b\x00\x18\x02\x24\x01\x08\x01\x9d\x02\x25\x01\x18\x02\x19\x02\x54\x03\x33\x00\x4c\x00\x11\x00\xb6\x03\x18\x02\x26\x01\x18\x02\x9e\x02\x9f\x02\x44\x03\xf5\x01\x5c\x04\x25\x01\x26\x01\x93\x02\x88\x03\x7b\x04\x86\x03\x11\x00\xf5\x01\x34\x01\x4c\x00\xf5\x01\xdc\x01\x78\x00\xf6\x01\x79\x00\xfb\x01\xcf\x04\x4b\x00\xa0\x02\x44\x03\xf5\x01\x2d\x04\x25\x01\x3d\x03\x79\x01\x92\x02\x6d\x03\x4c\x00\x11\x00\x11\x00\xf5\x01\x21\x02\xd1\xfc\x6f\x00\x70\x00\xf5\x01\x6d\x03\x71\x00\x72\x00\xf9\x02\x73\x00\x6d\x03\x5c\x04\xf9\x02\x19\x02\x11\x00\x2a\x01\x2b\x01\x18\x02\x11\x00\x3d\x03\x9f\x04\x4c\x00\xa0\x04\xa1\x04\x74\x00\x11\x00\x6e\x05\xa9\x02\xdd\x04\x62\x03\x0e\x00\x0f\x00\x10\x00\x75\x00\x3e\x05\x76\x00\x77\x00\x78\x00\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x41\x05\xfa\x04\xce\x03\x41\x05\x30\x00\x17\x02\x30\x00\x30\x00\x0c\x02\x3e\x05\x07\x01\x4c\x00\x30\x00\x35\x04\x30\x00\x1c\x02\x30\x00\x2e\x01\x2f\x01\x11\x00\x27\x02\x56\x00\x92\x04\xf4\x01\x1c\x02\x58\x00\x9f\x04\x1c\x02\xa0\x04\xa1\x04\x9f\x04\x1c\x02\xa0\x04\xa1\x04\x1c\x02\x9f\x04\x8d\x03\xa0\x04\xa1\x04\x35\x04\x9f\x04\x0d\x02\xa0\x04\xa1\x04\x9f\x04\x11\x00\xa0\x04\xa1\x04\x9f\x04\x51\x05\xa0\x04\xa1\x04\xaa\x04\xc1\xff\xab\x04\x17\x02\x46\x00\xaa\x04\x63\x03\xab\x04\xbc\xff\x46\x00\xaa\x04\x17\x02\xab\x04\xb5\x03\x46\x00\x4e\x03\x4f\x03\xac\x04\x0f\x00\x10\x00\x25\x02\xfa\x01\xac\x04\x0f\x00\x10\x00\x11\x00\xb6\x03\xac\x04\x0f\x00\x10\x00\x11\x00\x4f\x01\xcc\x00\x48\x01\xc1\xff\x11\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\x35\x01\x36\x01\x71\x00\x23\x01\x44\x03\x23\x03\x24\x03\x25\x01\x71\x03\x2c\x01\x2d\x01\x17\x02\xe7\x00\x11\x00\x22\x01\x18\x02\x71\x00\x23\x01\x8c\x03\xe8\x00\xe9\x00\xf5\x01\x49\x01\x4a\x01\xea\x00\x33\x00\xd3\x04\x7b\x04\x37\x01\xcd\x00\x87\x03\xba\x04\x17\x02\xb9\x02\x11\x00\x28\x02\x37\x03\x26\x01\x25\x01\x24\x01\x3b\x01\x32\x00\x25\x01\x88\x03\x11\x00\x8d\x03\xfa\x01\xbe\x01\x11\x00\x06\x03\xbc\xff\x26\x01\x8d\x03\x30\x01\x2d\x01\xeb\x00\x3c\x01\xf5\x01\x22\x01\x72\x03\x71\x00\x23\x01\xcc\x00\xf6\x01\xbb\x04\x18\x02\x94\x03\xe4\x00\xe5\x00\xe6\x00\x50\x05\x01\x03\x28\x02\x18\x02\xba\x02\x25\x01\xfb\x01\x38\x03\x4b\x00\x33\x00\xff\xff\x11\x00\xe7\x00\x24\x01\xb6\x04\x07\x03\x25\x01\x90\x03\x4c\x00\xe8\x00\xe9\x00\x9d\xfe\x11\x00\x68\x01\xea\x00\x26\x01\x14\x01\x9f\x01\xbe\x01\xcd\x00\xfb\x01\x6b\x01\x4b\x00\x65\x03\xfa\x01\x82\x02\x07\x02\x02\x03\xec\x00\xed\x00\xee\x00\x83\x02\x4c\x00\x18\x02\xbd\x03\xef\x00\x15\x01\xcc\x02\x8c\x00\x3c\x02\x50\x01\xf0\x00\xd0\x00\x6b\x01\x88\x03\xeb\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xcc\x00\x51\x01\x18\x02\x52\x01\xcb\x04\xcc\x04\xcd\x04\x08\x01\xff\xff\x84\x02\x36\x02\x04\x03\x75\x00\x5e\x05\x76\x00\x77\x00\x78\x00\x3d\x02\x79\x00\x5f\x04\x60\x04\x7c\x00\x7d\x00\x15\x05\xfa\x01\x7e\x02\x6c\x01\xce\x04\x71\x00\x23\x01\x01\x02\x7f\x02\xea\x00\xfb\x01\xd1\xfc\x4b\x00\x05\x03\xcd\x00\x37\x02\xf9\x01\x9c\x00\x9d\x00\x61\x04\x66\x04\x38\x02\x4c\x00\xec\x00\xed\x00\xee\x00\x85\x03\x9e\x00\x70\x00\x48\x01\xef\x00\x71\x00\x72\x00\x8c\x00\x07\x01\xdc\x04\xf0\x00\xd0\x00\x80\x02\x86\x03\x26\x01\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xd2\x04\xdd\x04\x7f\x00\x4e\x05\xcc\x04\xcd\x04\x32\x03\xd1\x00\x9f\x00\x0f\x00\xd2\x00\x49\x01\x4a\x01\xd3\x04\x80\x00\x81\x00\x11\x00\xf0\x04\x7a\x00\x7b\x00\x82\x00\xfb\x01\xa0\x00\x4b\x00\x6c\x01\xce\x04\x71\x00\x23\x01\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x68\x01\x4c\x00\xb0\x01\xfc\x02\xfe\x01\x15\x01\xa2\x02\xfd\x02\x9c\x00\x9d\x00\x88\x00\x89\x00\xf6\x03\xb1\x01\xec\x00\xed\x00\xab\x02\x63\x04\x9e\x00\x70\x00\xef\x04\xef\x00\x71\x00\x72\x00\x8c\x00\x4f\x02\x8c\x02\xad\x02\xd0\x00\x26\x01\x6b\x01\x34\x02\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xae\x02\xf5\x01\xcc\x00\x15\x01\xfb\x01\xf7\x03\x4b\x00\xcf\x04\xd1\x00\x9f\x00\x0f\x00\xd2\x00\x6c\x01\x6d\x01\x71\x00\x23\x01\x4c\x00\x11\x00\x7f\x00\x7a\x00\x7b\x00\x5f\x04\x60\x04\xa0\x00\x6c\x01\xce\x04\x71\x00\x23\x01\x0a\x02\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xb5\x04\xea\x00\x36\x00\x37\x00\x38\x00\x24\x02\xcd\x00\x4b\x00\x9c\x00\x9d\x00\x09\x02\x61\x04\x62\x04\xb6\x04\x6a\x01\x47\x05\x26\x01\x4c\x00\x9e\x00\x70\x00\x6b\x01\x33\x02\x71\x00\x72\x00\xf8\x01\x11\x02\x89\x00\x34\x02\x26\x01\x99\x02\x48\x00\x30\x01\x2d\x01\x5c\x02\x5d\x02\x5e\x02\x22\x01\xf5\x01\x71\x00\x23\x01\x12\x02\x13\x02\xe0\x01\xcf\x04\x46\x00\xd1\x00\x9f\x00\x0f\x00\xd2\x00\x2d\x02\xf8\x04\x86\x04\x87\x04\x40\x00\x11\x00\xe1\x01\x7a\x00\x7b\x00\xe9\x01\x2e\x02\xa0\x00\x24\x01\x9d\x02\x88\x03\x25\x01\x4c\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x11\x00\xe4\x03\x5e\x02\x26\x01\xfa\x03\x9f\x02\x5f\x02\x0f\x00\x10\x00\x6c\x01\x76\x03\x71\x00\x23\x01\xff\xff\x11\x00\xec\x00\xed\x00\xab\x02\x63\x04\x5d\x05\xdc\x01\x78\x00\xef\x00\x79\x00\x7b\x05\x8c\x00\xcc\x00\xa0\x02\xad\x02\xd0\x00\x7c\x05\xa7\x01\x5e\x05\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xae\x02\xfe\x04\xfc\x04\x80\x00\x81\x00\x5f\x02\x0f\x00\x10\x00\x26\x01\x82\x00\x00\x02\x80\x00\x81\x00\x11\x00\x9d\xfe\x48\x05\x1e\x03\x82\x00\x42\x00\x43\x00\xea\x00\x94\xfd\x45\x00\x08\x02\x46\x00\xcd\x00\x1a\x03\x1f\x03\x20\x03\xea\x02\xbe\x01\x88\x00\x8f\x04\x49\x00\xb2\x02\x4b\x00\x7f\x00\xc4\x01\x09\x02\x88\x00\x62\x00\x9c\x00\x9d\x00\x8b\x00\x65\x00\x4c\x00\x1b\x03\x1c\x03\x80\x00\x81\x00\xa0\x02\x9e\x00\x70\x00\x21\x01\x82\x00\x71\x00\x72\x00\x22\x01\x3f\x02\x71\x00\x23\x01\x36\x00\x37\x00\x38\x00\x11\x00\x6a\x01\xcf\x01\x7b\x00\xec\x02\x31\x05\x3d\x01\x6b\x01\x3d\x00\x3e\x00\x3f\x00\xf8\x03\x88\x00\x89\x00\xd1\x00\x9f\x00\x0f\x00\xd2\x00\x24\x01\xce\x02\x09\x02\x25\x01\x3c\x04\x11\x00\x0f\x02\x7a\x00\x7b\x00\x11\x00\x10\x02\xa0\x00\x26\x01\x30\x05\x3d\x04\xf5\x01\xcb\x04\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x2a\x02\xec\x00\xed\x00\xab\x02\xac\x02\xf3\x03\x62\x00\x09\x02\xef\x00\x40\x00\x65\x00\x8c\x00\xcc\x00\xce\x02\xad\x02\xd0\x00\x55\x00\x78\x05\xc3\x01\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xae\x02\x9b\x02\x60\x05\x79\x05\x57\x00\x26\x05\x13\x03\xd9\x02\xda\x02\x36\x00\x37\x00\x38\x00\x4c\x00\xea\x02\x27\x05\x99\x02\xff\xff\x80\x00\x81\x00\x6b\x01\xea\x00\xfe\x01\x3f\x00\x82\x00\x62\x00\xcd\x00\xd2\x01\x7d\x00\x65\x00\x3f\x02\xc2\x01\xd3\x01\x63\x00\x64\x00\xaa\x02\x11\x00\x66\x00\x67\x00\x40\x03\xb3\x02\xb0\x02\xb1\x02\x9d\x00\xb2\x01\x2b\x04\x88\x00\x28\x05\x25\x01\xaf\x01\x8b\x00\x29\x05\x9e\x00\x70\x00\x11\x00\xff\x03\x71\x00\x72\x00\x25\x01\x42\x00\x43\x00\x40\x00\x44\x00\x45\x00\x11\x00\x46\x00\x47\x00\x48\x00\x81\x01\x52\x02\x0e\x00\x0f\x00\x10\x00\x34\x02\x49\x00\x4a\x00\x4b\x00\x84\x01\x11\x00\xd1\x00\x9f\x00\x0f\x00\xd2\x00\x83\x00\x07\x02\x05\x02\x4c\x00\x39\x01\x11\x00\x85\x00\x7a\x00\x7b\x00\x39\x02\xd1\xfc\xa0\x00\xff\xff\x34\x02\x1d\x04\x87\x00\x4b\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x41\x03\xec\x00\xed\x00\xab\x02\xac\x02\x4c\x00\x11\x00\x64\x02\xef\x00\xbc\x01\x53\x04\x8c\x00\xcc\x00\x07\x01\xad\x02\xd0\x00\x11\x00\x08\x05\x09\x05\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xae\x02\xfb\x04\xfc\x04\x1d\xfd\x0f\x02\x69\x04\x42\x00\x43\x00\x10\x02\x44\x00\x45\x00\x2c\x03\x46\x00\x47\x00\x48\x00\x2d\x03\x75\x01\x0f\x00\x10\x00\x79\x01\xea\x00\x49\x00\x4a\x00\x4b\x00\x11\x00\xcd\x00\x6a\x04\x70\x04\x88\x01\xff\xff\x89\x01\x83\x00\x8a\x01\x4c\x00\x8b\x01\x2b\x05\x4c\x01\x85\x00\x34\x01\xaf\x02\xb0\x02\xb1\x02\x9d\x00\x62\x00\x29\x05\x70\x00\x87\x00\x65\x00\x71\x00\x72\x00\x8a\x00\x9e\x00\x70\x00\xf5\x01\x83\x00\x71\x00\x72\x00\x4b\x01\x39\x01\xc7\x04\x85\x00\x36\x00\x37\x00\x38\x00\x41\x02\x78\x00\x1e\x01\x79\x00\xec\x02\x87\x00\x3d\x01\xbe\x02\x3d\x00\x3e\x00\x3f\x00\xd3\x01\x23\x03\x24\x03\xd1\x00\x9f\x00\x0f\x00\xd2\x00\x7a\x00\x7b\x00\x28\x03\xce\x01\x10\x00\x11\x00\x29\x03\x7a\x00\x7b\x00\xff\xff\x11\x00\xa0\x00\xcf\x01\x7b\x00\xd8\x02\xd9\x02\xda\x02\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x1b\x01\xec\x00\xed\x00\xab\x02\x6c\x04\xb5\x01\x0f\x02\xb6\x01\xef\x00\x40\x00\x10\x02\x8c\x00\xcc\x00\x7f\x00\xad\x02\xd0\x00\x5a\x03\x5b\x03\x5c\x03\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xae\x02\x80\x00\x81\x00\xe8\x02\xff\xff\x69\x04\x45\x00\x82\x00\x46\x00\xd1\x01\x9f\x01\x78\x00\x07\x01\x79\x00\x09\x01\x0a\x01\xd2\x01\x7d\x00\x6a\x01\xbe\x02\xea\x00\xd3\x01\x19\x01\xd3\x01\x6b\x01\xcd\x00\x6a\x04\x6b\x04\xff\xff\x88\x00\x89\x00\x18\x01\xa2\x02\x8b\x00\x8c\x00\x36\x00\x37\x00\x38\x00\x1e\x03\xa3\x02\xa4\x02\x9c\x00\x9d\x00\xa5\x02\xa6\x02\xde\x03\x3d\x00\x3e\x00\x3f\x00\xdf\x03\xde\x03\x9e\x00\x70\x00\xde\x03\x93\x04\x71\x00\x72\x00\x4b\x05\x42\x00\x43\x00\x15\x03\x44\x00\x45\x00\xde\x03\x46\x00\x47\x00\x48\x00\x46\x05\x1e\x01\x0f\x00\x10\x00\x23\x03\x24\x03\x49\x00\x4a\x00\x4b\x00\x11\x00\x15\x02\xd1\x00\x9f\x00\x0f\x00\xd2\x00\x08\x05\x57\x05\xde\x03\x4c\x00\x40\x00\x11\x00\x8a\x05\x7a\x00\x7b\x00\x41\x02\x78\x00\xa0\x00\x79\x00\x1c\x01\x0f\x00\x10\x00\x13\x03\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x11\x00\xec\x00\xed\x00\xab\x02\x6c\x04\xba\x02\x0f\x00\x10\x00\xef\x00\x04\x02\x05\x02\x8c\x00\xcc\x00\x11\x00\xad\x02\xd0\x00\x4f\x03\x50\x03\x51\x03\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xae\x02\x7f\x01\xeb\x02\x80\x01\xb7\x02\x0f\x00\x10\x00\x5f\x04\x60\x04\x36\x00\x37\x00\x38\x00\x11\x00\xa7\x02\x11\x03\x16\x05\x36\x00\x37\x00\x38\x00\x17\x05\xea\x00\xdc\x02\x18\x05\x17\x03\xdd\x02\xcd\x00\x6f\x05\x62\x00\xa3\xfe\x18\x05\x01\x05\xa3\xfe\x42\x00\x43\x00\x08\x03\x44\x00\x45\x00\x00\x03\x46\x00\x47\x00\x48\x00\x9c\x00\x9d\x00\x19\x05\x0e\x04\x0f\x04\x10\x04\x49\x00\x4a\x00\x4b\x00\x70\x05\x9e\x00\x70\x00\x7b\x01\x77\x01\x71\x00\x72\x00\x7c\x01\xb8\x01\x4c\x00\x40\x00\x36\x00\x37\x00\x38\x00\x11\x03\x85\x01\x43\x00\x40\x00\xec\x02\x45\x00\x3d\x01\x46\x00\x3d\x00\x3e\x00\x3f\x00\xc5\x02\x10\x00\xf8\x02\xd1\x00\x9f\x00\x0f\x00\xd2\x00\x11\x00\x2b\x05\xcf\x01\x7b\x00\x45\x00\x11\x00\x46\x00\x7a\x00\x7b\x00\xee\x02\xb5\x01\xa0\x00\xb6\x01\xb4\x02\x0f\x00\x10\x00\x00\x02\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x11\x00\xec\x00\xed\x00\xab\x02\x63\x04\x7c\x04\x0f\x04\x10\x04\xef\x00\x40\x00\xe7\x02\x8c\x00\xcc\x00\xe6\x02\xad\x02\xd0\x00\x76\x04\x0f\x04\x10\x04\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xae\x02\xc8\x04\xc9\x04\x46\x00\xe5\x02\x69\x04\x42\x00\x43\x00\xe3\x02\x90\x01\x45\x00\x91\x01\x46\x00\x42\x00\x43\x00\xe4\x02\x7f\x01\x45\x00\x80\x01\x46\x00\xea\x00\x49\x00\x78\x02\x4b\x00\x79\x02\xcd\x00\x09\x05\x24\x04\x49\x00\x25\x04\x4b\x00\xe0\x02\xd6\x01\x4c\x00\xd7\x01\xde\x02\x1c\x04\xd8\x01\x1d\x04\x58\x01\x4c\x00\x9c\x00\x9d\x00\x0f\x03\x85\x01\x43\x00\xcf\x02\x7f\x01\x45\x00\x80\x01\x46\x00\x9e\x00\x70\x00\x79\x01\x77\x01\x71\x00\x72\x00\xce\x02\x42\x00\x43\x00\xdb\x01\x44\x00\x45\x00\x25\x01\x46\x00\x47\x00\x48\x00\xcb\x02\xda\x03\x11\x00\xdb\x03\x7a\x00\x7b\x00\x49\x00\x4a\x00\x4b\x00\x7c\x01\x7d\x01\xd1\x00\x9f\x00\x0f\x00\xd2\x00\x8b\x04\x8c\x04\x8d\x04\x4c\x00\xbc\x01\x11\x00\x51\x02\x7a\x00\x7b\x00\x31\x01\x32\x01\xa0\x00\xdd\x04\x43\x01\x44\x01\x45\x01\x46\x01\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xc9\x02\xec\x00\xed\x00\xab\x02\x6c\x04\xd1\x01\x9f\x01\x78\x00\xef\x00\x79\x00\x09\xfd\x8c\x00\xcc\x00\x50\x02\xad\x02\xd0\x00\xc4\x04\x0f\x04\x10\x04\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xae\x02\x75\x04\xd3\x04\x76\x04\x7f\x00\x54\x01\xb8\xfe\x76\x01\x77\x01\xb8\xfe\xf0\x02\xf1\x02\xf2\x02\xf3\x02\xf4\x02\xc5\x02\x80\x00\x81\x00\xc4\x02\x57\x04\xea\x00\x58\x04\x82\x00\xfd\x02\xfe\x02\xcd\x00\x36\x00\x37\x00\x38\x00\x69\x05\x0f\x04\x10\x04\xc2\x02\xec\x02\xe6\x04\x3d\x01\xc1\x02\x3d\x00\x3e\x00\x3f\x00\x55\x01\x9c\x00\x9d\x00\x6d\x02\x88\x00\x89\x00\x73\x03\x74\x03\x8b\x00\x8c\x00\xc0\x02\x9e\x00\x70\x00\x7c\x01\x17\x04\x71\x00\x72\x00\x8c\x05\x0f\x04\x10\x04\xf2\x01\x36\x00\x37\x00\x38\x00\x0e\x03\x85\x01\x43\x00\xf0\x01\xd4\x04\x45\x00\x3d\x01\x46\x00\x3d\x00\x3e\x00\x3f\x00\x99\x02\x48\x00\x40\x00\xd1\x00\x9f\x00\x0f\x00\xd2\x00\xd1\x01\x9f\x01\x78\x00\x98\x02\x79\x00\x11\x00\x97\x02\x7a\x00\x7b\x00\x96\x02\xed\x04\xa0\x00\xee\x04\xe2\x04\xa5\x04\xe3\x04\xa6\x04\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x95\x02\xec\x00\xed\x00\xab\x02\xac\x02\xed\x04\x90\x02\xee\x04\xef\x00\x40\x00\x8e\x02\x8c\x00\xcc\x00\x88\x02\xad\x02\xd0\x00\x03\x04\x04\x04\x85\x02\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xae\x02\x77\x03\x85\x01\x43\x00\x67\x04\x5c\x03\x45\x00\x7c\x02\x46\x00\x36\x00\x37\x00\x38\x00\xf2\x04\xf3\x04\x81\x02\x7d\x02\x7c\x02\x75\x02\x74\x02\x71\x05\xea\x00\x73\x02\x18\x05\x42\x00\x43\x00\xcd\x00\x44\x00\x45\x00\x72\x02\x46\x00\x47\x00\x48\x00\x6e\x02\x6d\x02\xe5\x04\x6c\x02\xbe\x01\x64\x02\x49\x00\x4a\x00\x4b\x00\x9c\x00\x9d\x00\x54\x02\x53\x02\x51\x02\x50\x02\x4e\x02\x4d\x02\x3f\x02\x4c\x00\x9e\x00\x70\x00\x3b\x02\x2f\x02\x71\x00\x72\x00\x3e\x02\x42\x00\x43\x00\x40\x00\x44\x00\x45\x00\x3a\x02\x46\x00\x47\x00\x48\x00\x35\x02\x32\x02\x31\x02\x30\x02\x2c\x02\x27\x02\x49\x00\x4a\x00\x4b\x00\x15\x02\x0d\x01\xd1\x00\x9f\x00\x0f\x00\xd2\x00\x07\x02\x05\x05\xd2\x03\x4c\x00\xd1\x03\x11\x00\xd0\x03\x7a\x00\x7b\x00\xcd\x03\xc4\x03\xa0\x00\xc5\x03\xc3\x03\xec\xfc\x08\xfd\xf4\xfc\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xc1\x03\xec\x00\xed\x00\xab\x02\xac\x02\xf3\xfc\x07\xfd\xed\xfc\xef\x00\xee\xfc\x3d\x02\x8c\x00\xcc\x00\xc2\x03\xad\x02\xd0\x00\xc0\x03\xbf\x03\xbc\x03\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xae\x02\xbb\x03\xba\x03\xb3\x03\x6b\x01\xa9\x03\x42\x00\x43\x00\x35\x02\x93\x03\x45\x00\xc8\x02\x46\x00\x31\x02\x8f\x03\x36\x00\x37\x00\x38\x00\x91\x03\x84\x03\xea\x00\x49\x00\xec\x02\x4b\x00\x3d\x01\xcd\x00\x3d\x00\x3e\x00\x3f\x00\x92\x03\x89\x03\x7f\x00\x83\x03\x4c\x00\x82\x03\x36\x00\x37\x00\x38\x00\x7f\x03\x81\x03\x80\x03\x9c\x00\x9d\x00\x80\x00\x81\x00\x7e\x03\x79\x03\x7d\x03\x02\x02\x82\x00\x76\x03\x9e\x00\x70\x00\x7c\x03\x68\x01\x71\x00\x72\x00\x1c\xfd\xcc\x00\x6b\x03\x67\x03\x6a\x03\x5f\x03\x40\x04\x85\x01\x43\x00\x40\x00\x55\x01\x45\x00\x5a\x03\x46\x00\x88\x00\x89\x00\x58\x03\x56\x03\x8b\x00\x8c\x00\x4c\x03\xd1\x00\x9f\x00\x0f\x00\xd2\x00\x87\x00\x3a\x03\x34\x01\x35\x03\x40\x00\x11\x00\x2f\x03\x7a\x00\x7b\x00\x2e\x03\x2b\x03\xa0\x00\x27\x03\xcd\x00\x0d\x01\x8f\x02\xfa\x03\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x43\x04\xec\x00\xed\x00\xab\x02\x02\x04\x3e\x04\x85\x01\x43\x00\xef\x00\xd7\x03\x45\x00\x8c\x00\x46\x00\x40\x04\xad\x02\xd0\x00\x3e\x04\x39\x04\x33\x04\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xae\x02\x31\x03\x2d\x01\x31\x04\x30\x04\x2d\x04\x22\x01\x2f\x04\x71\x00\x23\x01\x2a\x04\x13\xfd\x42\x00\x43\x00\x12\xfd\x44\x00\x45\x00\x14\xfd\x46\x00\x47\x00\x48\x00\x20\x04\x1a\x04\x65\x03\x17\x04\x14\x04\x15\x04\x49\x00\x4a\x00\x4b\x00\x12\x04\x24\x01\x42\x00\x43\x00\x25\x01\x0e\x04\x45\x00\x68\x05\x46\x00\x4c\x00\x11\x00\x9c\x00\x9d\x00\x26\x01\x0a\x04\xc8\x02\x08\x04\x49\x00\x68\x00\x4b\x00\xff\x03\x9e\x00\x70\x00\xa9\x03\xce\x00\x71\x00\x72\x00\x8c\x00\xf2\x03\x4c\x00\xcf\x00\xd0\x00\xfa\x03\xef\x03\xeb\x03\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xec\x03\x3c\x02\xe3\x03\xe2\x03\xd7\x03\x08\x01\x4c\x01\xd1\x00\x9f\x00\x0f\x00\xd2\x00\xe1\x03\xa3\x04\x9b\x04\x95\x04\x08\x01\x11\x00\x07\x01\x7a\x00\x7b\x00\x92\x04\x6c\x02\xa0\x00\x90\x04\x88\x04\x36\x00\x37\x00\x38\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xec\x02\x49\x04\x3d\x01\x89\x03\x3d\x00\x3e\x00\x3f\x00\x81\x04\x9c\x00\x9d\x00\x80\x04\xd0\x02\x7f\x04\x14\x04\x12\x04\x07\x01\x12\x04\x5f\x04\x9e\x00\x70\x00\x5b\x04\x56\x04\x71\x00\x72\x00\x36\x00\x37\x00\x38\x00\x52\x04\x50\x04\x4d\x01\x51\x04\x4e\x01\x49\x04\x3c\x00\xeb\x04\x3d\x00\x3e\x00\x3f\x00\x4f\x04\x6f\x03\x4d\x04\x4c\x04\x4b\x04\x4a\x04\x40\x00\xd1\x00\x9f\x00\x0f\x00\xd2\x00\xe8\x04\x58\x01\xda\x04\xe4\x04\xc7\x04\x11\x00\x12\x04\x7a\x00\x7b\x00\x65\x03\xbe\x01\xa0\x00\x36\x00\x37\x00\x38\x00\xbd\x04\xbe\x04\x4d\x01\xb3\x04\x4e\x01\x2f\x05\x3c\x00\x21\x05\x3d\x00\x3e\x00\x3f\x00\x40\x00\x79\x03\x70\x01\x71\x01\x72\x01\x23\x05\x73\x01\x1c\x05\x1b\x05\x15\x05\x22\x01\x08\x01\x71\x00\x23\x01\x36\x00\x37\x00\x38\x00\x0d\x05\x0e\x05\x4d\x01\x0c\x05\x4e\x01\x0b\x05\x3c\x00\x65\x05\x3d\x00\x3e\x00\x3f\x00\x64\x05\x5c\x05\x5a\x03\x62\x05\x4e\x05\x08\x01\x4d\x05\x24\x01\x4b\x05\x40\x00\x25\x01\x4a\x05\x08\x01\x45\x05\x42\x00\x43\x00\x11\x00\x44\x00\x45\x00\x26\x01\x46\x00\x47\x00\x48\x00\x7a\x05\x3c\x05\x3b\x05\x3a\x05\x39\x05\x33\x05\x49\x00\x4a\x00\x4b\x00\x73\x05\x7e\x05\x7d\x05\xd7\x03\x07\x01\x40\x00\x6d\x05\x14\x04\x68\xfe\x4c\x00\x36\x00\x37\x00\x38\x00\x42\x00\x43\x00\x12\x04\x44\x00\x45\x00\x68\x05\x46\x00\x47\x00\x48\x00\x8e\x05\x5b\x02\x12\x04\xd0\x03\x8a\x05\x89\x05\x49\x00\x4a\x00\x4b\x00\x93\x05\x36\x00\x37\x00\x38\x00\x40\x02\x92\x05\x3a\x00\x95\x05\x3b\x00\x4c\x00\x3c\x00\x08\x01\x3d\x00\x3e\x00\x3f\x00\x0b\x01\x00\x05\x01\x02\x8e\x01\x42\x00\x43\x00\xbf\x01\x44\x00\x45\x00\xd0\x01\x46\x00\x47\x00\x48\x00\xb7\x01\x82\x01\x40\x00\x55\x01\xb3\x01\x41\x01\x49\x00\x4a\x00\x4b\x00\x39\x01\x46\x01\x19\x01\x19\x03\x15\x03\x18\x03\x17\x03\xf4\x02\x0b\x03\x4c\x00\x42\x00\x43\x00\x08\x03\x44\x00\x45\x00\x40\x00\x46\x00\x47\x00\x48\x00\x02\x03\xee\x02\xde\x02\xcf\x02\xc2\x02\x8c\x02\x49\x00\x4a\x00\x4b\x00\xe5\x01\x36\x00\x37\x00\x38\x00\x6a\x02\x15\x02\x4d\x01\xd4\x03\x4e\x01\x4c\x00\x3c\x00\xd3\x03\x3d\x00\x3e\x00\x3f\x00\x1e\x03\xd2\x03\x76\x02\x10\x02\x36\x00\x37\x00\x38\x00\xe2\x01\x0d\x02\x3a\x00\xbd\x03\x3b\x00\x68\x02\x3c\x00\x5d\x03\x3d\x00\x3e\x00\x3f\x00\xb6\x03\x58\x03\xa7\x03\xe3\x01\xe4\x01\x42\x00\x43\x00\x93\x03\x41\x00\x45\x00\x67\x03\x46\x00\x8a\x03\x56\x03\x54\x03\x89\x03\x67\x03\x4c\x03\x38\x03\x40\x00\x49\x00\x35\x03\x4b\x00\x33\x03\x25\x03\x24\x03\x21\x03\x42\x00\x43\x00\x47\x04\x44\x00\x45\x00\x4c\x00\x46\x00\x47\x00\x48\x00\x45\x04\x40\x00\x46\x04\x55\x00\x43\x04\x41\x04\x49\x00\x4a\x00\x4b\x00\x44\x04\xeb\x01\x31\x04\x9b\x02\xed\x01\x28\x04\x57\x00\x41\x02\x78\x00\x4c\x00\x79\x00\x25\x04\x18\x04\xd2\x01\x7d\x00\x40\x03\x1a\x04\x22\x04\xd3\x01\x36\x00\x37\x00\x38\x00\xe7\x01\x9c\x02\x3a\x00\xf8\x03\x3b\x00\x12\x04\x3c\x00\x6b\x01\x3d\x00\x3e\x00\x3f\x00\xef\x03\x63\x00\x64\x00\xed\x03\xd8\x03\x66\x00\x67\x00\xd7\x03\xd5\x03\x7d\x04\x90\x04\x78\x04\x77\x04\x41\x00\x42\x00\x43\x00\x68\x04\x44\x00\x45\x00\x5d\x04\x46\x00\x47\x00\x48\x00\x4d\x04\xee\x04\xeb\x04\xe9\x04\xe0\x04\xdf\x04\x49\x00\x4a\x00\x4b\x00\x42\x00\x43\x00\xde\x04\x44\x00\x45\x00\x40\x00\x46\x00\x47\x00\x48\x00\x4c\x00\xda\x04\xd8\x04\xc5\x04\xbf\x04\x68\x02\x49\x00\x4a\x00\x4b\x00\xbb\x04\x36\x00\x37\x00\x38\x00\xe7\x01\xb3\x04\x3a\x00\xa3\x04\x3b\x00\x4c\x00\x3c\x00\x2d\x05\x3d\x00\x3e\x00\x3f\x00\xd2\x02\xa2\x02\x21\x05\xe5\x01\x36\x00\x37\x00\x38\x00\x59\x02\xa3\x02\xd3\x02\x2c\x05\x3b\x00\xa5\x02\xd4\x02\x1e\x05\x3d\x00\x3e\x00\x3f\x00\x13\x05\x6e\x01\x6f\x01\x70\x01\x71\x01\x72\x01\x0e\x05\x73\x01\x41\x00\x06\x05\x1d\x05\x22\x01\xf8\x04\x71\x00\x23\x01\xf1\x04\x65\x05\x58\x05\x5f\x05\x40\x00\x5e\x05\x67\x03\x55\x05\x74\x05\x43\x05\x42\x05\x73\x05\x42\x00\x43\x00\x6a\x05\x44\x00\x45\x00\x8f\x05\x46\x00\xe8\x01\x48\x00\x24\x01\x40\x00\x84\x05\x25\x01\x82\x05\x90\x05\x49\x00\x4a\x00\x4b\x00\x11\x00\x8e\x05\x00\x00\x26\x01\x93\x05\x00\x00\xb5\x02\x00\x00\x00\x00\x4c\x00\x36\x00\x37\x00\x38\x00\x59\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\xe9\x01\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\xe7\x02\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x03\x72\x01\x00\x00\x73\x01\x00\x00\x00\x00\x00\x00\x22\x01\x00\x00\x71\x00\x23\x01\xd5\x02\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\xe8\x01\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x6b\x05\x4a\x00\x4b\x00\x42\x00\x43\x00\x24\x01\x44\x00\x45\x00\x25\x01\x46\x00\x47\x00\x48\x00\x4c\x00\x00\x00\x11\x00\x00\x00\x00\x00\x26\x01\x49\x00\x4a\x00\x4b\x00\xe9\x01\xb5\x02\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x59\x02\x4c\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\xb6\x02\x00\x00\x84\x01\x85\x01\x43\x00\x00\x00\x00\x00\x45\x00\x00\x00\x46\x00\xb5\x02\x00\x00\x00\x00\x41\x00\x36\x00\x37\x00\x38\x00\x59\x02\x86\x01\x3a\x00\x4b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x21\x04\x00\x00\x4c\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x40\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x05\x04\x00\x00\x00\x00\x08\x04\x36\x00\x37\x00\x38\x00\x59\x02\x4c\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x40\x00\x3d\x00\x3e\x00\x3f\x00\x05\x04\x00\x00\x00\x00\x06\x04\x36\x00\x37\x00\x38\x00\x59\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x94\x01\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x41\x00\x95\x01\x0f\x00\x10\x00\x00\x00\x40\x00\x49\x00\x4a\x00\x4b\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x36\x00\x37\x00\x38\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x41\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x47\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x4c\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x05\x04\x00\x00\x00\x00\xc3\x04\x36\x00\x37\x00\x38\x00\x59\x02\x4c\x00\x3a\x00\x40\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x58\x02\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x59\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x05\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x59\x02\x40\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x42\x00\x43\x00\x00\x00\x00\x00\x45\x00\x00\x00\x46\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x49\x00\x00\x00\x4b\x00\x42\x00\x43\x00\xd5\x01\x00\x00\x45\x00\x00\x00\x46\x00\x80\x00\x81\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x49\x00\x00\x00\x4b\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x01\x00\x00\x41\x00\x4c\x00\x00\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x89\x00\x00\x00\x00\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x41\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x4c\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x17\x02\xa2\x00\x13\x00\xa3\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x3f\x03\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\xa3\x02\xa4\x02\x00\x00\x00\x00\xa5\x02\xa6\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x02\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\xb0\x03\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x40\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x04\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\xa3\x02\xa4\x02\x00\x00\x00\x00\xa5\x02\xa6\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\xa7\x02\x59\x04\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\xa3\x02\xa4\x02\x00\x00\x00\x00\xa5\x02\xa6\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x7f\x00\x82\x01\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x40\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xe4\x04\x4c\x00\x82\x00\x36\x00\x37\x00\x38\x00\x50\x01\xa3\x02\xa4\x02\x00\x00\x40\x00\xa5\x02\xa6\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xc8\x01\x55\x01\x52\x01\x00\x00\x00\x00\x88\x00\x89\x00\x00\x00\x00\x00\x8b\x00\x8c\x00\x75\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x79\x00\x00\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x02\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x49\x02\x40\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\xa7\x02\x42\x00\x43\x00\xcb\x03\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x4c\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x40\x00\xa8\x01\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\xa7\x02\x57\x05\x4c\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\xa3\x02\xa4\x02\x00\x00\x00\x00\xa5\x02\xa6\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x41\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x13\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x14\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x02\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\xa2\x00\x13\x00\xa3\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xa4\x00\x4c\x00\x14\x00\xa5\x00\x00\x00\x00\x00\xd4\x00\xd5\x00\xd6\x00\xfa\x00\xd7\x00\x00\x00\xfb\x00\x00\x00\x15\x00\x00\x00\xfc\x00\x00\x00\x16\x00\xfd\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x1e\x02\x1f\x02\xfe\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd9\x00\xda\x00\xdb\x00\x00\x00\xff\x00\xab\x00\xdc\x00\xad\x00\x00\x01\x01\x01\x00\x00\x00\x00\x02\x01\x03\x01\x04\x01\x05\x01\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xdf\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x6e\x04\x6f\x04\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x70\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x7f\x00\x54\x01\xfe\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd9\x00\xda\x00\xdb\x00\x80\x00\x81\x00\xab\x00\xdc\x00\xad\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x01\xae\x00\x00\x00\x00\x00\x88\x00\x89\x00\x00\x00\xaf\x00\x8b\x00\x8c\x00\xb0\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xdf\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x65\x04\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\xfb\x00\x00\x00\x15\x00\x00\x00\x66\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x7f\x00\x04\x05\xfe\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd9\x00\xda\x00\xdb\x00\x80\x00\x81\x00\xab\x00\xdc\x00\xad\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x01\xae\x00\x00\x00\x00\x00\x88\x00\x89\x00\x00\x00\xaf\x00\x8b\x00\x8c\x00\xb0\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xdf\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x6e\x04\x6f\x04\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x70\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x7f\x00\x00\x00\xfe\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd9\x00\xda\x00\xdb\x00\x80\x00\x81\x00\xab\x00\xdc\x00\xad\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x01\xae\x00\x00\x00\x00\x00\x88\x00\x89\x00\x00\x00\xaf\x00\x8b\x00\x8c\x00\xb0\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xdf\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x65\x04\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\xfb\x00\x00\x00\x15\x00\x00\x00\x66\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\xfe\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd9\x00\xda\x00\xdb\x00\x00\x00\x00\x00\xab\x00\xdc\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xdf\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\xfe\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd9\x00\xda\x00\xdb\x00\x00\x00\x00\x00\xab\x00\xdc\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xdf\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x7f\x00\xca\x01\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\xcb\x01\xcc\x01\xcd\x01\xce\x01\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\xae\x00\x00\x00\x68\x01\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x55\x01\x69\x01\x81\x00\x00\x00\x88\x00\x89\x00\x00\x00\x82\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x6a\x01\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x6b\x01\x6c\x01\xb7\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x7f\x00\x00\x00\x53\x04\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\xab\x00\xac\x00\xad\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x55\x01\xae\x00\x00\x00\x68\x01\x88\x00\x89\x00\x00\x00\xaf\x00\x8b\x00\x8c\x00\xb0\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x9f\x01\xb6\x00\x00\x00\x00\x00\x6b\x01\x6c\x01\xb7\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x50\x01\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x51\x01\x00\x00\x52\x01\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x79\x00\x00\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x7f\x00\x00\x00\x00\x00\xae\x00\x00\x00\x68\x01\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x69\x01\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x6a\x01\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x6b\x01\x6c\x01\xb7\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x50\x01\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\xcc\x02\x00\x00\x52\x01\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x79\x00\x00\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x7f\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x4f\x02\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x34\x02\x6c\x01\xb7\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x50\x01\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\xc8\x01\x00\x00\x52\x01\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x79\x00\x00\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x7f\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x52\x02\xb6\x00\x00\x00\x00\x00\x34\x02\x6c\x01\xb7\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\xd8\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd9\x00\xda\x00\xdb\x00\x00\x00\x00\x00\xab\x00\xdc\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xdf\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\xa7\x01\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x6c\x01\xb7\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\xae\x00\x00\x00\xc8\x02\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x6c\x01\xb7\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x34\x02\x6c\x01\xb7\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x6c\x01\xb7\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x03\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\xb0\x03\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\xa9\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\xbe\x01\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x01\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\xa9\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x15\x00\xa2\x03\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x05\x10\x05\x00\x00\x3d\x00\x3e\x00\x3f\x00\xae\x00\x11\x05\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x40\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xe8\xfd\xe8\xfd\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\xe8\xfd\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xfd\x00\x00\x00\x00\x00\x00\xe8\xfd\x00\x00\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\x00\x00\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\x00\x00\x00\x00\xe8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xfd\xe8\xfd\xe8\xfd\x4c\x00\x00\x00\xe8\xfd\x00\x00\x00\x00\x00\x00\xe8\xfd\x00\x00\x00\x00\xe8\xfd\xe8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xfd\xe8\xfd\xe8\xfd\x00\x00\x00\x00\x00\x00\xe8\xfd\x00\x00\xe8\xfd\x00\x00\xe8\xfd\x00\x00\xe8\xfd\x00\x00\xe8\xfd\x00\x00\x00\x00\x00\x00\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\x00\x00\xe8\xfd\x00\x00\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xe8\xfd\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\xb0\x03\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\xa9\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x15\x00\xa2\x03\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\xf5\x03\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\xa2\x00\x13\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x14\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xa7\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa8\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x01\xab\x00\xd7\x01\xad\x00\x00\x00\xd8\x01\x00\x00\x00\x00\xd9\x01\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x05\x10\x05\xda\x01\x3d\x00\x3e\x00\x3f\x00\xae\x00\x6d\x05\x00\x00\x00\x00\xdb\x01\x00\x00\xaf\x00\x25\x01\x00\x00\xb0\x00\x00\x00\xdc\x01\x78\x00\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x40\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xa2\x00\x13\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x14\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\xad\x01\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\xae\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xa2\x00\x13\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x14\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x01\x00\x00\x3d\x01\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x40\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xa2\x00\x13\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x14\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xa2\x00\x13\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x14\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x02\x00\x00\x3d\x01\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x40\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xa2\x00\x13\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x14\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\xae\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xa2\x00\x13\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x14\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x02\x00\x00\x3d\x01\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x40\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xa2\x00\x13\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x14\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x98\x03\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xa2\x00\x13\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x14\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\xaf\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xa2\x00\x13\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x14\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2b\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xbd\x02\x70\x01\x71\x01\x72\x01\x00\x00\x73\x01\x00\x00\x00\x00\x00\x00\x22\x01\x00\x00\x71\x00\x23\x01\x00\x00\x36\x00\x37\x00\x38\x00\x49\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xe1\x02\x4b\x02\x00\x00\x00\x00\x24\x01\x00\x00\x00\x00\x25\x01\x00\x00\x00\x00\x00\x00\x41\x02\x78\x00\x11\x00\x79\x00\x00\x00\x26\x01\x00\x00\xbe\x02\xb2\x00\x00\x00\xb3\x00\xd3\x01\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2b\x00\x87\x00\x40\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x68\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x4e\x00\x13\x00\x00\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x14\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x41\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\xeb\x01\x00\x00\xec\x01\xed\x01\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\xee\x01\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x01\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x53\x00\x54\x00\x00\x00\x23\x02\x00\x00\x3d\x01\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\xe7\x01\x40\x00\x00\x00\x00\x00\x6b\x01\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x02\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x44\x02\x45\x02\x00\x00\x00\x00\x00\x00\x00\x00\x46\x02\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x6a\x01\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x01\x5f\x00\x60\x00\x61\x00\x62\x00\x47\x02\x48\x02\x00\x00\x65\x00\x66\x00\x49\x02\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x53\x00\x54\x00\x5f\x03\x00\x00\x3d\x01\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\xf2\x01\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\xf0\x01\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x01\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x40\x01\x41\x01\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x53\x00\x54\x00\x15\x04\x00\x00\x3d\x01\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x00\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\xd7\x02\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x53\x00\x54\x00\xfd\x03\x00\x00\x3d\x01\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\xa9\x02\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x53\x00\x54\x00\x04\x05\x00\x00\x3d\x01\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\xa9\x02\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x53\x00\x54\x00\x02\x05\x00\x00\x3d\x01\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\xd7\x02\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\xa9\x02\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\xa9\x02\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\xd7\x02\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\xa9\x02\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x04\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\xd7\x04\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x00\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\xa9\x02\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x54\x05\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x4f\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x13\x05\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x00\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x00\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x04\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x00\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x00\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x9c\xfe\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x02\x04\x02\x61\x00\x62\x00\x00\x00\x89\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x49\x02\x56\x00\x3a\x00\x00\x00\x3b\x00\x58\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x5a\x00\x4a\x02\x4b\x02\x00\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x02\x04\x02\x61\x00\x62\x00\x00\x00\x89\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x4e\x00\x13\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x15\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x56\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x4c\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x61\x00\x62\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x36\x00\x37\x00\x38\x00\x22\x02\xfc\x03\xd3\x02\x00\x00\x3b\x00\xa5\x02\xd4\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x21\x02\xfb\x03\xd3\x02\x00\x00\x3b\x00\xa5\x02\xd4\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\xce\x03\x72\x04\xd3\x02\x00\x00\x3b\x00\xa5\x02\xd4\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\xc9\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x02\x00\x00\x40\x00\x00\x00\xca\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\xd5\x02\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\xd5\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x36\x00\x37\x00\x38\x00\x49\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x4c\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xc8\x03\x36\x00\x37\x00\x38\x00\xc6\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x49\x02\x40\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xc5\x03\x36\x00\x37\x00\x38\x00\xc9\x03\x40\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x4c\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x41\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x36\x00\x37\x00\x38\x00\xc9\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x4c\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x04\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\xc9\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x0c\x04\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x49\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xe3\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\xc9\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x40\x00\x00\x00\xdc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x41\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x36\x00\x37\x00\x38\x00\xc9\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x4c\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x2a\x04\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x05\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\xf0\x01\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x41\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x05\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x36\x00\x37\x00\x38\x00\xee\x01\x00\x00\x3a\x00\x00\x00\x3b\x00\x4c\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x91\x01\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x22\x02\x40\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x21\x02\x40\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x41\x00\x4a\x03\xa4\x02\x00\x00\x00\x00\xa5\x02\xa6\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x4c\x00\x41\x00\x40\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x41\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\xa7\x02\x36\x00\x37\x00\x38\x00\xce\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x4c\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x95\x03\x97\x00\x00\x00\x96\x03\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x36\x00\x37\x00\x38\x00\x2a\x04\x00\x00\x3a\x00\x00\x00\x3b\x00\x4c\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\xfc\x03\xa4\x02\x00\x00\x00\x00\xa5\x02\xa6\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x36\x00\x37\x00\x38\x00\x40\x00\xfb\x03\xa4\x02\x00\x00\x00\x00\xa5\x02\xa6\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x40\x00\x98\x01\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x02\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x4c\x00\x00\x00\xa7\x02\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x36\x00\x37\x00\x38\x00\xdd\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x4c\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x00\x00\x72\x04\xa4\x02\x00\x00\x00\x00\xa5\x02\xa6\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x40\x00\x73\x04\xa4\x02\x00\x00\x00\x00\xa5\x02\xa6\x02\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\xf6\x04\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x02\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x40\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x4c\x00\x00\x00\xa7\x02\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x42\x00\x43\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x42\x00\x43\x00\x13\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x4c\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x14\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x46\x03\x47\x03\x48\x03\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x2a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x2b\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x49\x03\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x2a\x02\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x2b\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x03\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x03\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x1e\x02\x1f\x02\x88\x05\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x02\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\xb9\x04\x29\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x1e\x02\x1f\x02\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x02\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x02\x1f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x20\x02\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x02\x1f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x13\x00\x00\x00\x84\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x86\x00\x00\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x01\xd2\x02\x13\x00\x00\x00\xdf\x01\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\xe0\x01\x00\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8c\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x13\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x04\x00\x00\x00\x00\x15\x00\x00\x00\xaf\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\xb0\x04\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\xb1\x04\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\xb2\x04\x00\x00\x00\x00\x2b\x00\x62\x00\x00\x00\xae\x04\x2c\x00\x65\x00\x15\x00\x00\x00\xaf\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x14\x00\x00\x00\x24\x00\x00\x00\x00\x00\xb0\x04\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x62\x00\x00\x00\x00\x00\x2c\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x13\x00\x00\x00\x00\x00\x97\x01\x00\x00\x85\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x15\x00\x00\x00\xaf\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x14\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x38\x05\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x62\x00\x00\x00\x00\x00\x2c\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\xde\x01\x00\x00\x00\x00\x00\x00\xdf\x01\x14\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x87\x00\x00\x00\x15\x00\x00\x00\x8a\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x14\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x88\x01\x00\x00\x89\x01\x00\x00\x8a\x01\x14\x00\x8b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x00\x00\x15\x00\x00\x00\x65\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x14\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x87\x00\x15\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x13\x00\x00\x00\x20\x01\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x14\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x15\x00\x00\x00\x21\x01\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x2b\x00\x00\x00\x00\x00\x16\x00\x2c\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x14\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x61\x02\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x2b\x00\x00\x00\x00\x00\x16\x00\x2c\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x14\x00\x00\x00\x24\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x15\x00\x2b\x00\x00\x00\x00\x00\x16\x00\x2c\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x13\x00\x00\x00\x00\x00\x75\x01\x6a\x01\x85\x00\x00\x00\x00\x00\x14\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x2b\x00\x87\x00\x88\x00\x89\x00\x28\x01\x00\x00\x00\x00\x15\x00\x00\x00\x29\x01\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x14\x00\x00\x00\x24\x00\x00\x00\x00\x00\x2b\x00\x87\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x2a\x01\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x14\x00\x00\x00\x00\x00\x75\x01\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x2b\x00\x87\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x14\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x39\x01\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x14\x00\x00\x00\x00\x00\x2a\x01\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x2b\x00\x87\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x14\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x75\x01\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x14\x00\x00\x00\x00\x00\x2a\x01\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x2b\x00\x87\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\xff\x14\x00\x00\x00\x00\x00\x0e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\xfb\x02\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xc5\x02\x00\x00\x24\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x2b\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x13\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x04\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x2b\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x13\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x04\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x1f\x04\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x13\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x50\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x59\x01\x5a\x01\x00\x00\x8f\x00\x90\x00\xfd\x01\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x61\x00\x00\x00\x5b\x01\x5c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x61\x01\x9f\x01\x63\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x64\x01\x7d\x00\xa0\x00\x00\x00\x00\x00\x65\x01\x00\x00\x66\x01\x8c\x00\x59\x01\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x01\x5c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x61\x01\x62\x01\x63\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x64\x01\x7d\x00\xa0\x00\x00\x00\x00\x00\x65\x01\x00\x00\x66\x01\x8c\x00\x59\x01\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x01\x9a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xa0\x00\x00\x00\x00\x00\x9d\x01\x00\x00\x66\x01\x8c\x00\xdf\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x03\xab\x03\xac\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x59\x01\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x01\x9f\x00\x0f\x00\x10\x00\xa4\x01\xa5\x01\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\xae\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xa0\x00\x8c\x00\x59\x01\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xa0\x00\x8c\x00\x59\x01\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x02\x00\x00\x00\x00\x86\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xa0\x00\x8c\x00\x59\x01\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x02\x00\x00\x00\x00\x98\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xa0\x00\x8c\x00\x59\x01\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xa0\x00\x8c\x00\x59\x01\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xa0\x00\x8c\x00\xa3\x03\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xa0\x00\x8c\x00\x9a\x03\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xa0\x00\x8c\x00\x59\x01\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xa0\x00\x8c\x00\x59\x01\x5a\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x60\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xa0\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x03\x9d\x03\x9e\x03\x9f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x9c\x03\x9d\x03\x9e\x03\x9f\x03\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x84\x04\x9e\x03\x9f\x03\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x70\x02\x00\x00\x6f\x02\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x6e\x02\x00\x00\x6f\x02\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x65\x02\x66\x02\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\xdf\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\xb0\x03\xab\x03\xac\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x60\x03\x66\x02\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\xdf\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\xec\x03\xab\x03\xac\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xb9\x01\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\xba\x01\xbb\x01\xbc\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x03\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x82\x04\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xdf\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x8a\x04\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\xad\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xdf\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xdf\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x3b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xdf\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x3a\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xe2\x00\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xd5\x01\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xc7\x01\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xc6\x01\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xc0\x01\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x93\x01\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x8d\x01\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x8c\x01\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x8b\x01\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x61\x02\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x57\x02\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x56\x02\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x55\x02\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x54\x02\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xb8\x03\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xb7\x03\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xb3\x03\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xa5\x03\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xa2\x03\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x61\x03\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x29\x03\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x01\x04\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xf3\x03\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xe8\x03\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xe6\x03\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x89\x04\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x88\x04\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x81\x04\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x71\x04\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xe8\x04\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xc2\x04\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xc1\x04\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xc0\x04\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\xbe\x04\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x1c\x05\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x45\x05\x8e\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x00\x00\x92\x01\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x00\x00\xc9\x02\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x00\x00\x37\x04\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x00\x00\xd7\x04\x00\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x8c\x00\x00\x00\x71\x00\x72\x00\x8f\x00\x5a\x02\x00\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x9e\x00\x70\x00\xd7\x02\x00\x00\x71\x00\x72\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x01\x95\x00\x96\x00\x97\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x79\x02\x7a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\xaa\x01\x95\x00\x96\x00\x97\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x79\x02\xa9\x03\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\xaa\x01\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x01\x95\x00\x96\x00\x97\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\xab\x01\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x8c\x00\x00\x00\x71\x00\x72\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x01\x95\x00\x96\x00\x97\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\xb2\x01\x95\x00\x96\x00\x97\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x9c\x00\x9d\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x01\x95\x00\x96\x00\x97\x00\x9e\x00\x70\x00\x8c\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\xa7\x01\x95\x00\x96\x00\x97\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x9c\x00\x9d\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x8c\x00\x00\x00\x71\x00\x72\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x01\x95\x00\x96\x00\x97\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x1b\x01\x95\x00\x96\x00\x97\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x9c\x00\x9d\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x03\x95\x00\x96\x00\x97\x00\x9e\x00\x70\x00\x8c\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x0c\x03\x95\x00\x96\x00\x97\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x9c\x00\x9d\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x8c\x00\x00\x00\x71\x00\x72\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x01\x95\x00\x96\x00\x97\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x75\x02\x95\x00\x96\x00\x97\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x9c\x00\x9d\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x02\x95\x00\x96\x00\x97\x00\x9e\x00\x70\x00\x8c\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x2f\x03\x95\x00\x96\x00\x97\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x9c\x00\x9d\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x9c\x00\x9d\x00\x97\x01\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x9f\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x9e\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x01\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7a\x00\x7b\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (13, 814) [ - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68), - (69 , happyReduce_69), - (70 , happyReduce_70), - (71 , happyReduce_71), - (72 , happyReduce_72), - (73 , happyReduce_73), - (74 , happyReduce_74), - (75 , happyReduce_75), - (76 , happyReduce_76), - (77 , happyReduce_77), - (78 , happyReduce_78), - (79 , happyReduce_79), - (80 , happyReduce_80), - (81 , happyReduce_81), - (82 , happyReduce_82), - (83 , happyReduce_83), - (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86), - (87 , happyReduce_87), - (88 , happyReduce_88), - (89 , happyReduce_89), - (90 , happyReduce_90), - (91 , happyReduce_91), - (92 , happyReduce_92), - (93 , happyReduce_93), - (94 , happyReduce_94), - (95 , happyReduce_95), - (96 , happyReduce_96), - (97 , happyReduce_97), - (98 , happyReduce_98), - (99 , happyReduce_99), - (100 , happyReduce_100), - (101 , happyReduce_101), - (102 , happyReduce_102), - (103 , happyReduce_103), - (104 , happyReduce_104), - (105 , happyReduce_105), - (106 , happyReduce_106), - (107 , happyReduce_107), - (108 , happyReduce_108), - (109 , happyReduce_109), - (110 , happyReduce_110), - (111 , happyReduce_111), - (112 , happyReduce_112), - (113 , happyReduce_113), - (114 , happyReduce_114), - (115 , happyReduce_115), - (116 , happyReduce_116), - (117 , happyReduce_117), - (118 , happyReduce_118), - (119 , happyReduce_119), - (120 , happyReduce_120), - (121 , happyReduce_121), - (122 , happyReduce_122), - (123 , happyReduce_123), - (124 , happyReduce_124), - (125 , happyReduce_125), - (126 , happyReduce_126), - (127 , happyReduce_127), - (128 , happyReduce_128), - (129 , happyReduce_129), - (130 , happyReduce_130), - (131 , happyReduce_131), - (132 , happyReduce_132), - (133 , happyReduce_133), - (134 , happyReduce_134), - (135 , happyReduce_135), - (136 , happyReduce_136), - (137 , happyReduce_137), - (138 , happyReduce_138), - (139 , happyReduce_139), - (140 , happyReduce_140), - (141 , happyReduce_141), - (142 , happyReduce_142), - (143 , happyReduce_143), - (144 , happyReduce_144), - (145 , happyReduce_145), - (146 , happyReduce_146), - (147 , happyReduce_147), - (148 , happyReduce_148), - (149 , happyReduce_149), - (150 , happyReduce_150), - (151 , happyReduce_151), - (152 , happyReduce_152), - (153 , happyReduce_153), - (154 , happyReduce_154), - (155 , happyReduce_155), - (156 , happyReduce_156), - (157 , happyReduce_157), - (158 , happyReduce_158), - (159 , happyReduce_159), - (160 , happyReduce_160), - (161 , happyReduce_161), - (162 , happyReduce_162), - (163 , happyReduce_163), - (164 , happyReduce_164), - (165 , happyReduce_165), - (166 , happyReduce_166), - (167 , happyReduce_167), - (168 , happyReduce_168), - (169 , happyReduce_169), - (170 , happyReduce_170), - (171 , happyReduce_171), - (172 , happyReduce_172), - (173 , happyReduce_173), - (174 , happyReduce_174), - (175 , happyReduce_175), - (176 , happyReduce_176), - (177 , happyReduce_177), - (178 , happyReduce_178), - (179 , happyReduce_179), - (180 , happyReduce_180), - (181 , happyReduce_181), - (182 , happyReduce_182), - (183 , happyReduce_183), - (184 , happyReduce_184), - (185 , happyReduce_185), - (186 , happyReduce_186), - (187 , happyReduce_187), - (188 , happyReduce_188), - (189 , happyReduce_189), - (190 , happyReduce_190), - (191 , happyReduce_191), - (192 , happyReduce_192), - (193 , happyReduce_193), - (194 , happyReduce_194), - (195 , happyReduce_195), - (196 , happyReduce_196), - (197 , happyReduce_197), - (198 , happyReduce_198), - (199 , happyReduce_199), - (200 , happyReduce_200), - (201 , happyReduce_201), - (202 , happyReduce_202), - (203 , happyReduce_203), - (204 , happyReduce_204), - (205 , happyReduce_205), - (206 , happyReduce_206), - (207 , happyReduce_207), - (208 , happyReduce_208), - (209 , happyReduce_209), - (210 , happyReduce_210), - (211 , happyReduce_211), - (212 , happyReduce_212), - (213 , happyReduce_213), - (214 , happyReduce_214), - (215 , happyReduce_215), - (216 , happyReduce_216), - (217 , happyReduce_217), - (218 , happyReduce_218), - (219 , happyReduce_219), - (220 , happyReduce_220), - (221 , happyReduce_221), - (222 , happyReduce_222), - (223 , happyReduce_223), - (224 , happyReduce_224), - (225 , happyReduce_225), - (226 , happyReduce_226), - (227 , happyReduce_227), - (228 , happyReduce_228), - (229 , happyReduce_229), - (230 , happyReduce_230), - (231 , happyReduce_231), - (232 , happyReduce_232), - (233 , happyReduce_233), - (234 , happyReduce_234), - (235 , happyReduce_235), - (236 , happyReduce_236), - (237 , happyReduce_237), - (238 , happyReduce_238), - (239 , happyReduce_239), - (240 , happyReduce_240), - (241 , happyReduce_241), - (242 , happyReduce_242), - (243 , happyReduce_243), - (244 , happyReduce_244), - (245 , happyReduce_245), - (246 , happyReduce_246), - (247 , happyReduce_247), - (248 , happyReduce_248), - (249 , happyReduce_249), - (250 , happyReduce_250), - (251 , happyReduce_251), - (252 , happyReduce_252), - (253 , happyReduce_253), - (254 , happyReduce_254), - (255 , happyReduce_255), - (256 , happyReduce_256), - (257 , happyReduce_257), - (258 , happyReduce_258), - (259 , happyReduce_259), - (260 , happyReduce_260), - (261 , happyReduce_261), - (262 , happyReduce_262), - (263 , happyReduce_263), - (264 , happyReduce_264), - (265 , happyReduce_265), - (266 , happyReduce_266), - (267 , happyReduce_267), - (268 , happyReduce_268), - (269 , happyReduce_269), - (270 , happyReduce_270), - (271 , happyReduce_271), - (272 , happyReduce_272), - (273 , happyReduce_273), - (274 , happyReduce_274), - (275 , happyReduce_275), - (276 , happyReduce_276), - (277 , happyReduce_277), - (278 , happyReduce_278), - (279 , happyReduce_279), - (280 , happyReduce_280), - (281 , happyReduce_281), - (282 , happyReduce_282), - (283 , happyReduce_283), - (284 , happyReduce_284), - (285 , happyReduce_285), - (286 , happyReduce_286), - (287 , happyReduce_287), - (288 , happyReduce_288), - (289 , happyReduce_289), - (290 , happyReduce_290), - (291 , happyReduce_291), - (292 , happyReduce_292), - (293 , happyReduce_293), - (294 , happyReduce_294), - (295 , happyReduce_295), - (296 , happyReduce_296), - (297 , happyReduce_297), - (298 , happyReduce_298), - (299 , happyReduce_299), - (300 , happyReduce_300), - (301 , happyReduce_301), - (302 , happyReduce_302), - (303 , happyReduce_303), - (304 , happyReduce_304), - (305 , happyReduce_305), - (306 , happyReduce_306), - (307 , happyReduce_307), - (308 , happyReduce_308), - (309 , happyReduce_309), - (310 , happyReduce_310), - (311 , happyReduce_311), - (312 , happyReduce_312), - (313 , happyReduce_313), - (314 , happyReduce_314), - (315 , happyReduce_315), - (316 , happyReduce_316), - (317 , happyReduce_317), - (318 , happyReduce_318), - (319 , happyReduce_319), - (320 , happyReduce_320), - (321 , happyReduce_321), - (322 , happyReduce_322), - (323 , happyReduce_323), - (324 , happyReduce_324), - (325 , happyReduce_325), - (326 , happyReduce_326), - (327 , happyReduce_327), - (328 , happyReduce_328), - (329 , happyReduce_329), - (330 , happyReduce_330), - (331 , happyReduce_331), - (332 , happyReduce_332), - (333 , happyReduce_333), - (334 , happyReduce_334), - (335 , happyReduce_335), - (336 , happyReduce_336), - (337 , happyReduce_337), - (338 , happyReduce_338), - (339 , happyReduce_339), - (340 , happyReduce_340), - (341 , happyReduce_341), - (342 , happyReduce_342), - (343 , happyReduce_343), - (344 , happyReduce_344), - (345 , happyReduce_345), - (346 , happyReduce_346), - (347 , happyReduce_347), - (348 , happyReduce_348), - (349 , happyReduce_349), - (350 , happyReduce_350), - (351 , happyReduce_351), - (352 , happyReduce_352), - (353 , happyReduce_353), - (354 , happyReduce_354), - (355 , happyReduce_355), - (356 , happyReduce_356), - (357 , happyReduce_357), - (358 , happyReduce_358), - (359 , happyReduce_359), - (360 , happyReduce_360), - (361 , happyReduce_361), - (362 , happyReduce_362), - (363 , happyReduce_363), - (364 , happyReduce_364), - (365 , happyReduce_365), - (366 , happyReduce_366), - (367 , happyReduce_367), - (368 , happyReduce_368), - (369 , happyReduce_369), - (370 , happyReduce_370), - (371 , happyReduce_371), - (372 , happyReduce_372), - (373 , happyReduce_373), - (374 , happyReduce_374), - (375 , happyReduce_375), - (376 , happyReduce_376), - (377 , happyReduce_377), - (378 , happyReduce_378), - (379 , happyReduce_379), - (380 , happyReduce_380), - (381 , happyReduce_381), - (382 , happyReduce_382), - (383 , happyReduce_383), - (384 , happyReduce_384), - (385 , happyReduce_385), - (386 , happyReduce_386), - (387 , happyReduce_387), - (388 , happyReduce_388), - (389 , happyReduce_389), - (390 , happyReduce_390), - (391 , happyReduce_391), - (392 , happyReduce_392), - (393 , happyReduce_393), - (394 , happyReduce_394), - (395 , happyReduce_395), - (396 , happyReduce_396), - (397 , happyReduce_397), - (398 , happyReduce_398), - (399 , happyReduce_399), - (400 , happyReduce_400), - (401 , happyReduce_401), - (402 , happyReduce_402), - (403 , happyReduce_403), - (404 , happyReduce_404), - (405 , happyReduce_405), - (406 , happyReduce_406), - (407 , happyReduce_407), - (408 , happyReduce_408), - (409 , happyReduce_409), - (410 , happyReduce_410), - (411 , happyReduce_411), - (412 , happyReduce_412), - (413 , happyReduce_413), - (414 , happyReduce_414), - (415 , happyReduce_415), - (416 , happyReduce_416), - (417 , happyReduce_417), - (418 , happyReduce_418), - (419 , happyReduce_419), - (420 , happyReduce_420), - (421 , happyReduce_421), - (422 , happyReduce_422), - (423 , happyReduce_423), - (424 , happyReduce_424), - (425 , happyReduce_425), - (426 , happyReduce_426), - (427 , happyReduce_427), - (428 , happyReduce_428), - (429 , happyReduce_429), - (430 , happyReduce_430), - (431 , happyReduce_431), - (432 , happyReduce_432), - (433 , happyReduce_433), - (434 , happyReduce_434), - (435 , happyReduce_435), - (436 , happyReduce_436), - (437 , happyReduce_437), - (438 , happyReduce_438), - (439 , happyReduce_439), - (440 , happyReduce_440), - (441 , happyReduce_441), - (442 , happyReduce_442), - (443 , happyReduce_443), - (444 , happyReduce_444), - (445 , happyReduce_445), - (446 , happyReduce_446), - (447 , happyReduce_447), - (448 , happyReduce_448), - (449 , happyReduce_449), - (450 , happyReduce_450), - (451 , happyReduce_451), - (452 , happyReduce_452), - (453 , happyReduce_453), - (454 , happyReduce_454), - (455 , happyReduce_455), - (456 , happyReduce_456), - (457 , happyReduce_457), - (458 , happyReduce_458), - (459 , happyReduce_459), - (460 , happyReduce_460), - (461 , happyReduce_461), - (462 , happyReduce_462), - (463 , happyReduce_463), - (464 , happyReduce_464), - (465 , happyReduce_465), - (466 , happyReduce_466), - (467 , happyReduce_467), - (468 , happyReduce_468), - (469 , happyReduce_469), - (470 , happyReduce_470), - (471 , happyReduce_471), - (472 , happyReduce_472), - (473 , happyReduce_473), - (474 , happyReduce_474), - (475 , happyReduce_475), - (476 , happyReduce_476), - (477 , happyReduce_477), - (478 , happyReduce_478), - (479 , happyReduce_479), - (480 , happyReduce_480), - (481 , happyReduce_481), - (482 , happyReduce_482), - (483 , happyReduce_483), - (484 , happyReduce_484), - (485 , happyReduce_485), - (486 , happyReduce_486), - (487 , happyReduce_487), - (488 , happyReduce_488), - (489 , happyReduce_489), - (490 , happyReduce_490), - (491 , happyReduce_491), - (492 , happyReduce_492), - (493 , happyReduce_493), - (494 , happyReduce_494), - (495 , happyReduce_495), - (496 , happyReduce_496), - (497 , happyReduce_497), - (498 , happyReduce_498), - (499 , happyReduce_499), - (500 , happyReduce_500), - (501 , happyReduce_501), - (502 , happyReduce_502), - (503 , happyReduce_503), - (504 , happyReduce_504), - (505 , happyReduce_505), - (506 , happyReduce_506), - (507 , happyReduce_507), - (508 , happyReduce_508), - (509 , happyReduce_509), - (510 , happyReduce_510), - (511 , happyReduce_511), - (512 , happyReduce_512), - (513 , happyReduce_513), - (514 , happyReduce_514), - (515 , happyReduce_515), - (516 , happyReduce_516), - (517 , happyReduce_517), - (518 , happyReduce_518), - (519 , happyReduce_519), - (520 , happyReduce_520), - (521 , happyReduce_521), - (522 , happyReduce_522), - (523 , happyReduce_523), - (524 , happyReduce_524), - (525 , happyReduce_525), - (526 , happyReduce_526), - (527 , happyReduce_527), - (528 , happyReduce_528), - (529 , happyReduce_529), - (530 , happyReduce_530), - (531 , happyReduce_531), - (532 , happyReduce_532), - (533 , happyReduce_533), - (534 , happyReduce_534), - (535 , happyReduce_535), - (536 , happyReduce_536), - (537 , happyReduce_537), - (538 , happyReduce_538), - (539 , happyReduce_539), - (540 , happyReduce_540), - (541 , happyReduce_541), - (542 , happyReduce_542), - (543 , happyReduce_543), - (544 , happyReduce_544), - (545 , happyReduce_545), - (546 , happyReduce_546), - (547 , happyReduce_547), - (548 , happyReduce_548), - (549 , happyReduce_549), - (550 , happyReduce_550), - (551 , happyReduce_551), - (552 , happyReduce_552), - (553 , happyReduce_553), - (554 , happyReduce_554), - (555 , happyReduce_555), - (556 , happyReduce_556), - (557 , happyReduce_557), - (558 , happyReduce_558), - (559 , happyReduce_559), - (560 , happyReduce_560), - (561 , happyReduce_561), - (562 , happyReduce_562), - (563 , happyReduce_563), - (564 , happyReduce_564), - (565 , happyReduce_565), - (566 , happyReduce_566), - (567 , happyReduce_567), - (568 , happyReduce_568), - (569 , happyReduce_569), - (570 , happyReduce_570), - (571 , happyReduce_571), - (572 , happyReduce_572), - (573 , happyReduce_573), - (574 , happyReduce_574), - (575 , happyReduce_575), - (576 , happyReduce_576), - (577 , happyReduce_577), - (578 , happyReduce_578), - (579 , happyReduce_579), - (580 , happyReduce_580), - (581 , happyReduce_581), - (582 , happyReduce_582), - (583 , happyReduce_583), - (584 , happyReduce_584), - (585 , happyReduce_585), - (586 , happyReduce_586), - (587 , happyReduce_587), - (588 , happyReduce_588), - (589 , happyReduce_589), - (590 , happyReduce_590), - (591 , happyReduce_591), - (592 , happyReduce_592), - (593 , happyReduce_593), - (594 , happyReduce_594), - (595 , happyReduce_595), - (596 , happyReduce_596), - (597 , happyReduce_597), - (598 , happyReduce_598), - (599 , happyReduce_599), - (600 , happyReduce_600), - (601 , happyReduce_601), - (602 , happyReduce_602), - (603 , happyReduce_603), - (604 , happyReduce_604), - (605 , happyReduce_605), - (606 , happyReduce_606), - (607 , happyReduce_607), - (608 , happyReduce_608), - (609 , happyReduce_609), - (610 , happyReduce_610), - (611 , happyReduce_611), - (612 , happyReduce_612), - (613 , happyReduce_613), - (614 , happyReduce_614), - (615 , happyReduce_615), - (616 , happyReduce_616), - (617 , happyReduce_617), - (618 , happyReduce_618), - (619 , happyReduce_619), - (620 , happyReduce_620), - (621 , happyReduce_621), - (622 , happyReduce_622), - (623 , happyReduce_623), - (624 , happyReduce_624), - (625 , happyReduce_625), - (626 , happyReduce_626), - (627 , happyReduce_627), - (628 , happyReduce_628), - (629 , happyReduce_629), - (630 , happyReduce_630), - (631 , happyReduce_631), - (632 , happyReduce_632), - (633 , happyReduce_633), - (634 , happyReduce_634), - (635 , happyReduce_635), - (636 , happyReduce_636), - (637 , happyReduce_637), - (638 , happyReduce_638), - (639 , happyReduce_639), - (640 , happyReduce_640), - (641 , happyReduce_641), - (642 , happyReduce_642), - (643 , happyReduce_643), - (644 , happyReduce_644), - (645 , happyReduce_645), - (646 , happyReduce_646), - (647 , happyReduce_647), - (648 , happyReduce_648), - (649 , happyReduce_649), - (650 , happyReduce_650), - (651 , happyReduce_651), - (652 , happyReduce_652), - (653 , happyReduce_653), - (654 , happyReduce_654), - (655 , happyReduce_655), - (656 , happyReduce_656), - (657 , happyReduce_657), - (658 , happyReduce_658), - (659 , happyReduce_659), - (660 , happyReduce_660), - (661 , happyReduce_661), - (662 , happyReduce_662), - (663 , happyReduce_663), - (664 , happyReduce_664), - (665 , happyReduce_665), - (666 , happyReduce_666), - (667 , happyReduce_667), - (668 , happyReduce_668), - (669 , happyReduce_669), - (670 , happyReduce_670), - (671 , happyReduce_671), - (672 , happyReduce_672), - (673 , happyReduce_673), - (674 , happyReduce_674), - (675 , happyReduce_675), - (676 , happyReduce_676), - (677 , happyReduce_677), - (678 , happyReduce_678), - (679 , happyReduce_679), - (680 , happyReduce_680), - (681 , happyReduce_681), - (682 , happyReduce_682), - (683 , happyReduce_683), - (684 , happyReduce_684), - (685 , happyReduce_685), - (686 , happyReduce_686), - (687 , happyReduce_687), - (688 , happyReduce_688), - (689 , happyReduce_689), - (690 , happyReduce_690), - (691 , happyReduce_691), - (692 , happyReduce_692), - (693 , happyReduce_693), - (694 , happyReduce_694), - (695 , happyReduce_695), - (696 , happyReduce_696), - (697 , happyReduce_697), - (698 , happyReduce_698), - (699 , happyReduce_699), - (700 , happyReduce_700), - (701 , happyReduce_701), - (702 , happyReduce_702), - (703 , happyReduce_703), - (704 , happyReduce_704), - (705 , happyReduce_705), - (706 , happyReduce_706), - (707 , happyReduce_707), - (708 , happyReduce_708), - (709 , happyReduce_709), - (710 , happyReduce_710), - (711 , happyReduce_711), - (712 , happyReduce_712), - (713 , happyReduce_713), - (714 , happyReduce_714), - (715 , happyReduce_715), - (716 , happyReduce_716), - (717 , happyReduce_717), - (718 , happyReduce_718), - (719 , happyReduce_719), - (720 , happyReduce_720), - (721 , happyReduce_721), - (722 , happyReduce_722), - (723 , happyReduce_723), - (724 , happyReduce_724), - (725 , happyReduce_725), - (726 , happyReduce_726), - (727 , happyReduce_727), - (728 , happyReduce_728), - (729 , happyReduce_729), - (730 , happyReduce_730), - (731 , happyReduce_731), - (732 , happyReduce_732), - (733 , happyReduce_733), - (734 , happyReduce_734), - (735 , happyReduce_735), - (736 , happyReduce_736), - (737 , happyReduce_737), - (738 , happyReduce_738), - (739 , happyReduce_739), - (740 , happyReduce_740), - (741 , happyReduce_741), - (742 , happyReduce_742), - (743 , happyReduce_743), - (744 , happyReduce_744), - (745 , happyReduce_745), - (746 , happyReduce_746), - (747 , happyReduce_747), - (748 , happyReduce_748), - (749 , happyReduce_749), - (750 , happyReduce_750), - (751 , happyReduce_751), - (752 , happyReduce_752), - (753 , happyReduce_753), - (754 , happyReduce_754), - (755 , happyReduce_755), - (756 , happyReduce_756), - (757 , happyReduce_757), - (758 , happyReduce_758), - (759 , happyReduce_759), - (760 , happyReduce_760), - (761 , happyReduce_761), - (762 , happyReduce_762), - (763 , happyReduce_763), - (764 , happyReduce_764), - (765 , happyReduce_765), - (766 , happyReduce_766), - (767 , happyReduce_767), - (768 , happyReduce_768), - (769 , happyReduce_769), - (770 , happyReduce_770), - (771 , happyReduce_771), - (772 , happyReduce_772), - (773 , happyReduce_773), - (774 , happyReduce_774), - (775 , happyReduce_775), - (776 , happyReduce_776), - (777 , happyReduce_777), - (778 , happyReduce_778), - (779 , happyReduce_779), - (780 , happyReduce_780), - (781 , happyReduce_781), - (782 , happyReduce_782), - (783 , happyReduce_783), - (784 , happyReduce_784), - (785 , happyReduce_785), - (786 , happyReduce_786), - (787 , happyReduce_787), - (788 , happyReduce_788), - (789 , happyReduce_789), - (790 , happyReduce_790), - (791 , happyReduce_791), - (792 , happyReduce_792), - (793 , happyReduce_793), - (794 , happyReduce_794), - (795 , happyReduce_795), - (796 , happyReduce_796), - (797 , happyReduce_797), - (798 , happyReduce_798), - (799 , happyReduce_799), - (800 , happyReduce_800), - (801 , happyReduce_801), - (802 , happyReduce_802), - (803 , happyReduce_803), - (804 , happyReduce_804), - (805 , happyReduce_805), - (806 , happyReduce_806), - (807 , happyReduce_807), - (808 , happyReduce_808), - (809 , happyReduce_809), - (810 , happyReduce_810), - (811 , happyReduce_811), - (812 , happyReduce_812), - (813 , happyReduce_813), - (814 , happyReduce_814) - ] - -happy_n_terms = 156 :: Int -happy_n_nonterms = 302 :: Int - -happyReduce_13 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_13 = happySpecReduce_1 0# happyReduction_13 -happyReduction_13 happy_x_1 - = case happyOut291 happy_x_1 of { happy_var_1 -> - happyIn16 - (happy_var_1 - )} - -happyReduce_14 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_14 = happySpecReduce_1 0# happyReduction_14 -happyReduction_14 happy_x_1 - = case happyOut263 happy_x_1 of { happy_var_1 -> - happyIn16 - (happy_var_1 - )} - -happyReduce_15 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_15 = happySpecReduce_1 0# happyReduction_15 -happyReduction_15 happy_x_1 - = case happyOut285 happy_x_1 of { happy_var_1 -> - happyIn16 - (happy_var_1 - )} - -happyReduce_16 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_16 = happySpecReduce_1 0# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOut270 happy_x_1 of { happy_var_1 -> - happyIn16 - (happy_var_1 - )} - -happyReduce_17 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_17 = happyMonadReduce 3# 0# happyReduction_17 -happyReduction_17 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ getRdrName funTyCon) - [mj AnnOpenP happy_var_1,mu AnnRarrow happy_var_2,mj AnnCloseP happy_var_3])}}}) - ) (\r -> happyReturn (happyIn16 r)) - -happyReduce_18 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_18 = happySpecReduce_3 1# happyReduction_18 -happyReduction_18 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut18 happy_x_2 of { happy_var_2 -> - happyIn17 - (fromOL happy_var_2 - )} - -happyReduce_19 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_19 = happySpecReduce_3 1# happyReduction_19 -happyReduction_19 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut18 happy_x_2 of { happy_var_2 -> - happyIn17 - (fromOL happy_var_2 - )} - -happyReduce_20 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_20 = happySpecReduce_3 2# happyReduction_20 -happyReduction_20 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn18 - (happy_var_1 `appOL` unitOL happy_var_3 - )}} - -happyReduce_21 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_21 = happySpecReduce_2 2# happyReduction_21 -happyReduction_21 happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn18 - (happy_var_1 - )} - -happyReduce_22 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_22 = happySpecReduce_1 2# happyReduction_22 -happyReduction_22 happy_x_1 - = case happyOut19 happy_x_1 of { happy_var_1 -> - happyIn18 - (unitOL happy_var_1 - )} - -happyReduce_23 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_23 = happyReduce 4# 3# happyReduction_23 -happyReduction_23 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut24 happy_x_2 of { happy_var_2 -> - case happyOut30 happy_x_4 of { happy_var_4 -> - happyIn19 - (sL1 happy_var_1 $ HsUnit { hsunitName = happy_var_2 - , hsunitBody = fromOL happy_var_4 } - ) `HappyStk` happyRest}}} - -happyReduce_24 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_24 = happySpecReduce_1 4# happyReduction_24 -happyReduction_24 happy_x_1 - = case happyOut24 happy_x_1 of { happy_var_1 -> - happyIn20 - (sL1 happy_var_1 $ HsUnitId happy_var_1 [] - )} - -happyReduce_25 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_25 = happyReduce 4# 4# happyReduction_25 -happyReduction_25 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut21 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn20 - (sLL happy_var_1 happy_var_4 $ HsUnitId happy_var_1 (fromOL happy_var_3) - ) `HappyStk` happyRest}}} - -happyReduce_26 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_26 = happySpecReduce_3 5# happyReduction_26 -happyReduction_26 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut21 happy_x_1 of { happy_var_1 -> - case happyOut22 happy_x_3 of { happy_var_3 -> - happyIn21 - (happy_var_1 `appOL` unitOL happy_var_3 - )}} - -happyReduce_27 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_27 = happySpecReduce_2 5# happyReduction_27 -happyReduction_27 happy_x_2 - happy_x_1 - = case happyOut21 happy_x_1 of { happy_var_1 -> - happyIn21 - (happy_var_1 - )} - -happyReduce_28 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_28 = happySpecReduce_1 5# happyReduction_28 -happyReduction_28 happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - happyIn21 - (unitOL happy_var_1 - )} - -happyReduce_29 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_29 = happySpecReduce_3 6# happyReduction_29 -happyReduction_29 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut307 happy_x_1 of { happy_var_1 -> - case happyOut23 happy_x_3 of { happy_var_3 -> - happyIn22 - (sLL happy_var_1 happy_var_3 $ (happy_var_1, happy_var_3) - )}} - -happyReduce_30 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_30 = happyReduce 4# 6# happyReduction_30 -happyReduction_30 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut307 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut307 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn22 - (sLL happy_var_1 happy_var_4 $ (happy_var_1, sLL happy_var_2 happy_var_4 $ HsModuleVar happy_var_3) - ) `HappyStk` happyRest}}}} - -happyReduce_31 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_31 = happySpecReduce_3 7# happyReduction_31 -happyReduction_31 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut307 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn23 - (sLL happy_var_1 happy_var_3 $ HsModuleVar happy_var_2 - )}}} - -happyReduce_32 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_32 = happySpecReduce_3 7# happyReduction_32 -happyReduction_32 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - case happyOut307 happy_x_3 of { happy_var_3 -> - happyIn23 - (sLL happy_var_1 happy_var_3 $ HsModuleId happy_var_1 happy_var_3 - )}} - -happyReduce_33 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_33 = happySpecReduce_1 8# happyReduction_33 -happyReduction_33 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn24 - (sL1 happy_var_1 $ PackageName (getSTRING happy_var_1) - )} - -happyReduce_34 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_34 = happySpecReduce_1 8# happyReduction_34 -happyReduction_34 happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - happyIn24 - (sL1 happy_var_1 $ PackageName (unLoc happy_var_1) - )} - -happyReduce_35 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_35 = happySpecReduce_1 9# happyReduction_35 -happyReduction_35 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn25 - (sL1 happy_var_1 $ getVARID happy_var_1 - )} - -happyReduce_36 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_36 = happySpecReduce_1 9# happyReduction_36 -happyReduction_36 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn25 - (sL1 happy_var_1 $ getCONID happy_var_1 - )} - -happyReduce_37 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_37 = happySpecReduce_1 9# happyReduction_37 -happyReduction_37 happy_x_1 - = case happyOut299 happy_x_1 of { happy_var_1 -> - happyIn25 - (happy_var_1 - )} - -happyReduce_38 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_38 = happySpecReduce_1 10# happyReduction_38 -happyReduction_38 happy_x_1 - = case happyOut25 happy_x_1 of { happy_var_1 -> - happyIn26 - (happy_var_1 - )} - -happyReduce_39 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_39 = happySpecReduce_3 10# happyReduction_39 -happyReduction_39 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut25 happy_x_1 of { happy_var_1 -> - case happyOut26 happy_x_3 of { happy_var_3 -> - happyIn26 - (sLL happy_var_1 happy_var_3 $ appendFS (unLoc happy_var_1) (consFS '-' (unLoc happy_var_3)) - )}} - -happyReduce_40 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_40 = happySpecReduce_0 11# happyReduction_40 -happyReduction_40 = happyIn27 - (Nothing - ) - -happyReduce_41 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_41 = happySpecReduce_3 11# happyReduction_41 -happyReduction_41 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut28 happy_x_2 of { happy_var_2 -> - happyIn27 - (Just (fromOL happy_var_2) - )} - -happyReduce_42 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_42 = happySpecReduce_3 12# happyReduction_42 -happyReduction_42 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut29 happy_x_3 of { happy_var_3 -> - happyIn28 - (happy_var_1 `appOL` unitOL happy_var_3 - )}} - -happyReduce_43 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_43 = happySpecReduce_2 12# happyReduction_43 -happyReduction_43 happy_x_2 - happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - happyIn28 - (happy_var_1 - )} - -happyReduce_44 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_44 = happySpecReduce_1 12# happyReduction_44 -happyReduction_44 happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - happyIn28 - (unitOL happy_var_1 - )} - -happyReduce_45 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_45 = happySpecReduce_3 13# happyReduction_45 -happyReduction_45 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut307 happy_x_1 of { happy_var_1 -> - case happyOut307 happy_x_3 of { happy_var_3 -> - happyIn29 - (sLL happy_var_1 happy_var_3 $ Renaming happy_var_1 (Just happy_var_3) - )}} - -happyReduce_46 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_46 = happySpecReduce_1 13# happyReduction_46 -happyReduction_46 happy_x_1 - = case happyOut307 happy_x_1 of { happy_var_1 -> - happyIn29 - (sL1 happy_var_1 $ Renaming happy_var_1 Nothing - )} - -happyReduce_47 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_47 = happySpecReduce_3 14# happyReduction_47 -happyReduction_47 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut31 happy_x_2 of { happy_var_2 -> - happyIn30 - (happy_var_2 - )} - -happyReduce_48 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_48 = happySpecReduce_3 14# happyReduction_48 -happyReduction_48 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut31 happy_x_2 of { happy_var_2 -> - happyIn30 - (happy_var_2 - )} - -happyReduce_49 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_49 = happySpecReduce_3 15# happyReduction_49 -happyReduction_49 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut31 happy_x_1 of { happy_var_1 -> - case happyOut32 happy_x_3 of { happy_var_3 -> - happyIn31 - (happy_var_1 `appOL` unitOL happy_var_3 - )}} - -happyReduce_50 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_50 = happySpecReduce_2 15# happyReduction_50 -happyReduction_50 happy_x_2 - happy_x_1 - = case happyOut31 happy_x_1 of { happy_var_1 -> - happyIn31 - (happy_var_1 - )} - -happyReduce_51 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_51 = happySpecReduce_1 15# happyReduction_51 -happyReduction_51 happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - happyIn31 - (unitOL happy_var_1 - )} - -happyReduce_52 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_52 = happyReduce 7# 16# happyReduction_52 -happyReduction_52 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut35 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut307 happy_x_3 of { happy_var_3 -> - case happyOut38 happy_x_4 of { happy_var_4 -> - case happyOut48 happy_x_5 of { happy_var_5 -> - case happyOut39 happy_x_7 of { happy_var_7 -> - happyIn32 - (sL1 happy_var_2 $ DeclD ModuleD happy_var_3 (Just (sL1 happy_var_2 (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) (snd $ snd happy_var_7) happy_var_4 happy_var_1))) - ) `HappyStk` happyRest}}}}}} - -happyReduce_53 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_53 = happyReduce 7# 16# happyReduction_53 -happyReduction_53 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut35 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut307 happy_x_3 of { happy_var_3 -> - case happyOut38 happy_x_4 of { happy_var_4 -> - case happyOut48 happy_x_5 of { happy_var_5 -> - case happyOut39 happy_x_7 of { happy_var_7 -> - happyIn32 - (sL1 happy_var_2 $ DeclD SignatureD happy_var_3 (Just (sL1 happy_var_2 (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) (snd $ snd happy_var_7) happy_var_4 happy_var_1))) - ) `HappyStk` happyRest}}}}}} - -happyReduce_54 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_54 = happySpecReduce_3 16# happyReduction_54 -happyReduction_54 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut307 happy_x_3 of { happy_var_3 -> - happyIn32 - (sL1 happy_var_2 $ DeclD ModuleD happy_var_3 Nothing - )}} - -happyReduce_55 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_55 = happySpecReduce_3 16# happyReduction_55 -happyReduction_55 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut307 happy_x_3 of { happy_var_3 -> - happyIn32 - (sL1 happy_var_2 $ DeclD SignatureD happy_var_3 Nothing - )}} - -happyReduce_56 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_56 = happySpecReduce_3 16# happyReduction_56 -happyReduction_56 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut20 happy_x_2 of { happy_var_2 -> - case happyOut27 happy_x_3 of { happy_var_3 -> - happyIn32 - (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_2 - , idModRenaming = happy_var_3 - , idSignatureInclude = False }) - )}}} - -happyReduce_57 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_57 = happySpecReduce_3 16# happyReduction_57 -happyReduction_57 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut20 happy_x_3 of { happy_var_3 -> - happyIn32 - (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_3 - , idModRenaming = Nothing - , idSignatureInclude = True }) - )}} - -happyReduce_58 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_58 = happyMonadReduce 7# 17# happyReduction_58 -happyReduction_58 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut35 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut307 happy_x_3 of { happy_var_3 -> - case happyOut38 happy_x_4 of { happy_var_4 -> - case happyOut48 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { happy_var_6 -> - case happyOut39 happy_x_7 of { happy_var_7 -> - ( fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) - (snd $ snd happy_var_7) happy_var_4 happy_var_1) - ) - ([mj AnnSignature happy_var_2, mj AnnWhere happy_var_6] ++ fst happy_var_7))}}}}}}}) - ) (\r -> happyReturn (happyIn33 r)) - -happyReduce_59 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_59 = happyMonadReduce 7# 18# happyReduction_59 -happyReduction_59 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut35 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut307 happy_x_3 of { happy_var_3 -> - case happyOut38 happy_x_4 of { happy_var_4 -> - case happyOut48 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { happy_var_6 -> - case happyOut39 happy_x_7 of { happy_var_7 -> - ( fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) - (snd $ snd happy_var_7) happy_var_4 happy_var_1) - ) - ([mj AnnModule happy_var_2, mj AnnWhere happy_var_6] ++ fst happy_var_7))}}}}}}}) - ) (\r -> happyReturn (happyIn34 r)) - -happyReduce_60 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_60 = happyMonadReduce 1# 18# happyReduction_60 -happyReduction_60 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut40 happy_x_1 of { happy_var_1 -> - ( fileSrcSpan >>= \ loc -> - ams (L loc (HsModule Nothing Nothing - (fst $ snd happy_var_1) (snd $ snd happy_var_1) Nothing Nothing)) - (fst happy_var_1))}) - ) (\r -> happyReturn (happyIn34 r)) - -happyReduce_61 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_61 = happySpecReduce_1 19# happyReduction_61 -happyReduction_61 happy_x_1 - = case happyOut315 happy_x_1 of { happy_var_1 -> - happyIn35 - (happy_var_1 - )} - -happyReduce_62 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_62 = happySpecReduce_0 19# happyReduction_62 -happyReduction_62 = happyIn35 - (Nothing - ) - -happyReduce_63 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_63 = happyMonadReduce 0# 20# happyReduction_63 -happyReduction_63 (happyRest) tk - = happyThen ((( pushModuleContext)) - ) (\r -> happyReturn (happyIn36 r)) - -happyReduce_64 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_64 = happyMonadReduce 0# 21# happyReduction_64 -happyReduction_64 (happyRest) tk - = happyThen ((( pushModuleContext)) - ) (\r -> happyReturn (happyIn37 r)) - -happyReduce_65 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_65 = happyMonadReduce 3# 22# happyReduction_65 -happyReduction_65 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut134 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ajs (Just (sLL happy_var_1 happy_var_3 $ DeprecatedTxt (sL1 happy_var_1 (getDEPRECATED_PRAGs happy_var_1)) (snd $ unLoc happy_var_2))) - (mo happy_var_1:mc happy_var_3: (fst $ unLoc happy_var_2)))}}}) - ) (\r -> happyReturn (happyIn38 r)) - -happyReduce_66 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_66 = happyMonadReduce 3# 22# happyReduction_66 -happyReduction_66 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut134 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ajs (Just (sLL happy_var_1 happy_var_3 $ WarningTxt (sL1 happy_var_1 (getWARNING_PRAGs happy_var_1)) (snd $ unLoc happy_var_2))) - (mo happy_var_1:mc happy_var_3 : (fst $ unLoc happy_var_2)))}}}) - ) (\r -> happyReturn (happyIn38 r)) - -happyReduce_67 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_67 = happySpecReduce_0 22# happyReduction_67 -happyReduction_67 = happyIn38 - (Nothing - ) - -happyReduce_68 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_68 = happySpecReduce_3 23# happyReduction_68 -happyReduction_68 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut41 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn39 - ((moc happy_var_1:mcc happy_var_3:(fst happy_var_2) - , snd happy_var_2) - )}}} - -happyReduce_69 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_69 = happySpecReduce_3 23# happyReduction_69 -happyReduction_69 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut41 happy_x_2 of { happy_var_2 -> - happyIn39 - ((fst happy_var_2, snd happy_var_2) - )} - -happyReduce_70 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_70 = happySpecReduce_3 24# happyReduction_70 -happyReduction_70 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut41 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn40 - ((moc happy_var_1:mcc happy_var_3 - :(fst happy_var_2), snd happy_var_2) - )}}} - -happyReduce_71 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_71 = happySpecReduce_3 24# happyReduction_71 -happyReduction_71 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut41 happy_x_2 of { happy_var_2 -> - happyIn40 - (([],snd happy_var_2) - )} - -happyReduce_72 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_72 = happySpecReduce_2 25# happyReduction_72 -happyReduction_72 happy_x_2 - happy_x_1 - = case happyOut61 happy_x_1 of { happy_var_1 -> - case happyOut42 happy_x_2 of { happy_var_2 -> - happyIn41 - ((happy_var_1, happy_var_2) - )}} - -happyReduce_73 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_73 = happySpecReduce_2 26# happyReduction_73 -happyReduction_73 happy_x_2 - happy_x_1 - = case happyOut63 happy_x_1 of { happy_var_1 -> - case happyOut76 happy_x_2 of { happy_var_2 -> - happyIn42 - ((reverse happy_var_1, cvTopDecls happy_var_2) - )}} - -happyReduce_74 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_74 = happySpecReduce_2 26# happyReduction_74 -happyReduction_74 happy_x_2 - happy_x_1 - = case happyOut63 happy_x_1 of { happy_var_1 -> - case happyOut75 happy_x_2 of { happy_var_2 -> - happyIn42 - ((reverse happy_var_1, cvTopDecls happy_var_2) - )}} - -happyReduce_75 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_75 = happySpecReduce_1 26# happyReduction_75 -happyReduction_75 happy_x_1 - = case happyOut62 happy_x_1 of { happy_var_1 -> - happyIn42 - ((reverse happy_var_1, []) - )} - -happyReduce_76 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_76 = happyMonadReduce 7# 27# happyReduction_76 -happyReduction_76 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut35 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut307 happy_x_3 of { happy_var_3 -> - case happyOut38 happy_x_4 of { happy_var_4 -> - case happyOut48 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { happy_var_6 -> - case happyOut44 happy_x_7 of { happy_var_7 -> - ( fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just happy_var_3) happy_var_5 happy_var_7 [] happy_var_4 happy_var_1 - )) [mj AnnModule happy_var_2,mj AnnWhere happy_var_6])}}}}}}}) - ) (\r -> happyReturn (happyIn43 r)) - -happyReduce_77 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_77 = happyMonadReduce 7# 27# happyReduction_77 -happyReduction_77 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut35 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut307 happy_x_3 of { happy_var_3 -> - case happyOut38 happy_x_4 of { happy_var_4 -> - case happyOut48 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { happy_var_6 -> - case happyOut44 happy_x_7 of { happy_var_7 -> - ( fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just happy_var_3) happy_var_5 happy_var_7 [] happy_var_4 happy_var_1 - )) [mj AnnModule happy_var_2,mj AnnWhere happy_var_6])}}}}}}}) - ) (\r -> happyReturn (happyIn43 r)) - -happyReduce_78 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_78 = happyMonadReduce 1# 27# happyReduction_78 -happyReduction_78 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut45 happy_x_1 of { happy_var_1 -> - ( fileSrcSpan >>= \ loc -> - return (L loc (HsModule Nothing Nothing happy_var_1 [] Nothing - Nothing)))}) - ) (\r -> happyReturn (happyIn43 r)) - -happyReduce_79 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_79 = happySpecReduce_2 28# happyReduction_79 -happyReduction_79 happy_x_2 - happy_x_1 - = case happyOut46 happy_x_2 of { happy_var_2 -> - happyIn44 - (happy_var_2 - )} - -happyReduce_80 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_80 = happySpecReduce_2 28# happyReduction_80 -happyReduction_80 happy_x_2 - happy_x_1 - = case happyOut46 happy_x_2 of { happy_var_2 -> - happyIn44 - (happy_var_2 - )} - -happyReduce_81 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_81 = happySpecReduce_2 29# happyReduction_81 -happyReduction_81 happy_x_2 - happy_x_1 - = case happyOut46 happy_x_2 of { happy_var_2 -> - happyIn45 - (happy_var_2 - )} - -happyReduce_82 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_82 = happySpecReduce_2 29# happyReduction_82 -happyReduction_82 happy_x_2 - happy_x_1 - = case happyOut46 happy_x_2 of { happy_var_2 -> - happyIn45 - (happy_var_2 - )} - -happyReduce_83 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_83 = happySpecReduce_2 30# happyReduction_83 -happyReduction_83 happy_x_2 - happy_x_1 - = case happyOut47 happy_x_2 of { happy_var_2 -> - happyIn46 - (happy_var_2 - )} - -happyReduce_84 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_84 = happySpecReduce_1 31# happyReduction_84 -happyReduction_84 happy_x_1 - = case happyOut63 happy_x_1 of { happy_var_1 -> - happyIn47 - (happy_var_1 - )} - -happyReduce_85 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_85 = happySpecReduce_1 31# happyReduction_85 -happyReduction_85 happy_x_1 - = case happyOut62 happy_x_1 of { happy_var_1 -> - happyIn47 - (happy_var_1 - )} - -happyReduce_86 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_86 = happyMonadReduce 3# 32# happyReduction_86 -happyReduction_86 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut49 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 ()) [mop happy_var_1,mcp happy_var_3] >> - return (Just (sLL happy_var_1 happy_var_3 (fromOL happy_var_2))))}}}) - ) (\r -> happyReturn (happyIn48 r)) - -happyReduce_87 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_87 = happySpecReduce_0 32# happyReduction_87 -happyReduction_87 = happyIn48 - (Nothing - ) - -happyReduce_88 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_88 = happyMonadReduce 3# 33# happyReduction_88 -happyReduction_88 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut51 happy_x_3 of { happy_var_3 -> - ( addAnnotation (oll happy_var_1) AnnComma (gl happy_var_2) - >> return (happy_var_1 `appOL` happy_var_3))}}}) - ) (\r -> happyReturn (happyIn49 r)) - -happyReduce_89 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_89 = happySpecReduce_1 33# happyReduction_89 -happyReduction_89 happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - happyIn49 - (happy_var_1 - )} - -happyReduce_90 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_90 = happyMonadReduce 5# 34# happyReduction_90 -happyReduction_90 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut53 happy_x_2 of { happy_var_2 -> - case happyOut51 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut50 happy_x_5 of { happy_var_5 -> - ( (addAnnotation (oll (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3)) - AnnComma (gl happy_var_4) ) >> - return (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3 `appOL` happy_var_5))}}}}}) - ) (\r -> happyReturn (happyIn50 r)) - -happyReduce_91 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_91 = happySpecReduce_3 34# happyReduction_91 -happyReduction_91 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut53 happy_x_2 of { happy_var_2 -> - case happyOut51 happy_x_3 of { happy_var_3 -> - happyIn50 - (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3 - )}}} - -happyReduce_92 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_92 = happySpecReduce_1 34# happyReduction_92 -happyReduction_92 happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - happyIn50 - (happy_var_1 - )} - -happyReduce_93 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_93 = happySpecReduce_2 35# happyReduction_93 -happyReduction_93 happy_x_2 - happy_x_1 - = case happyOut52 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn51 - (happy_var_1 `appOL` happy_var_2 - )}} - -happyReduce_94 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_94 = happySpecReduce_0 35# happyReduction_94 -happyReduction_94 = happyIn51 - (nilOL - ) - -happyReduce_95 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_95 = happySpecReduce_1 36# happyReduction_95 -happyReduction_95 happy_x_1 - = case happyOut314 happy_x_1 of { happy_var_1 -> - happyIn52 - (unitOL (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> IEGroup n doc)) - )} - -happyReduce_96 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_96 = happySpecReduce_1 36# happyReduction_96 -happyReduction_96 happy_x_1 - = case happyOut313 happy_x_1 of { happy_var_1 -> - happyIn52 - (unitOL (sL1 happy_var_1 (IEDocNamed ((fst . unLoc) happy_var_1))) - )} - -happyReduce_97 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_97 = happySpecReduce_1 36# happyReduction_97 -happyReduction_97 happy_x_1 - = case happyOut311 happy_x_1 of { happy_var_1 -> - happyIn52 - (unitOL (sL1 happy_var_1 (IEDoc (unLoc happy_var_1))) - )} - -happyReduce_98 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_98 = happyMonadReduce 2# 37# happyReduction_98 -happyReduction_98 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut58 happy_x_1 of { happy_var_1 -> - case happyOut54 happy_x_2 of { happy_var_2 -> - ( mkModuleImpExp happy_var_1 (snd $ unLoc happy_var_2) - >>= \ie -> amsu (sLL happy_var_1 happy_var_2 ie) (fst $ unLoc happy_var_2))}}) - ) (\r -> happyReturn (happyIn53 r)) - -happyReduce_99 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_99 = happyMonadReduce 2# 37# happyReduction_99 -happyReduction_99 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut307 happy_x_2 of { happy_var_2 -> - ( amsu (sLL happy_var_1 happy_var_2 (IEModuleContents happy_var_2)) - [mj AnnModule happy_var_1])}}) - ) (\r -> happyReturn (happyIn53 r)) - -happyReduce_100 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_100 = happyMonadReduce 2# 37# happyReduction_100 -happyReduction_100 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut263 happy_x_2 of { happy_var_2 -> - ( amsu (sLL happy_var_1 happy_var_2 (IEVar (sLL happy_var_1 happy_var_2 (IEPattern happy_var_2)))) - [mj AnnPattern happy_var_1])}}) - ) (\r -> happyReturn (happyIn53 r)) - -happyReduce_101 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_101 = happySpecReduce_0 38# happyReduction_101 -happyReduction_101 = happyIn54 - (sL0 ([],ImpExpAbs) - ) - -happyReduce_102 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_102 = happyMonadReduce 3# 38# happyReduction_102 -happyReduction_102 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut55 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( mkImpExpSubSpec (reverse (snd happy_var_2)) - >>= \(as,ie) -> return $ sLL happy_var_1 happy_var_3 - (as ++ [mop happy_var_1,mcp happy_var_3] ++ fst happy_var_2, ie))}}}) - ) (\r -> happyReturn (happyIn54 r)) - -happyReduce_103 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_103 = happySpecReduce_0 39# happyReduction_103 -happyReduction_103 = happyIn55 - (([],[]) - ) - -happyReduce_104 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_104 = happySpecReduce_1 39# happyReduction_104 -happyReduction_104 happy_x_1 - = case happyOut56 happy_x_1 of { happy_var_1 -> - happyIn55 - (happy_var_1 - )} - -happyReduce_105 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_105 = happyMonadReduce 3# 40# happyReduction_105 -happyReduction_105 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut56 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut57 happy_x_3 of { happy_var_3 -> - ( case (head (snd happy_var_1)) of - l@(L _ ImpExpQcWildcard) -> - return ([mj AnnComma happy_var_2, mj AnnDotdot l] - ,(snd (unLoc happy_var_3) : snd happy_var_1)) - l -> (ams (head (snd happy_var_1)) [mj AnnComma happy_var_2] >> - return (fst happy_var_1 ++ fst (unLoc happy_var_3), - snd (unLoc happy_var_3) : snd happy_var_1)))}}}) - ) (\r -> happyReturn (happyIn56 r)) - -happyReduce_106 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_106 = happySpecReduce_1 40# happyReduction_106 -happyReduction_106 happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - happyIn56 - ((fst (unLoc happy_var_1),[snd (unLoc happy_var_1)]) - )} - -happyReduce_107 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_107 = happySpecReduce_1 41# happyReduction_107 -happyReduction_107 happy_x_1 - = case happyOut58 happy_x_1 of { happy_var_1 -> - happyIn57 - (sL1 happy_var_1 ([],happy_var_1) - )} - -happyReduce_108 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_108 = happySpecReduce_1 41# happyReduction_108 -happyReduction_108 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn57 - (sL1 happy_var_1 ([mj AnnDotdot happy_var_1], sL1 happy_var_1 ImpExpQcWildcard) - )} - -happyReduce_109 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_109 = happySpecReduce_1 42# happyReduction_109 -happyReduction_109 happy_x_1 - = case happyOut59 happy_x_1 of { happy_var_1 -> - happyIn58 - (sL1 happy_var_1 (ImpExpQcName happy_var_1) - )} - -happyReduce_110 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_110 = happyMonadReduce 2# 42# happyReduction_110 -happyReduction_110 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut273 happy_x_2 of { happy_var_2 -> - ( do { n <- mkTypeImpExp happy_var_2 - ; ams (sLL happy_var_1 happy_var_2 (ImpExpQcType n)) - [mj AnnType happy_var_1] })}}) - ) (\r -> happyReturn (happyIn58 r)) - -happyReduce_111 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_111 = happySpecReduce_1 43# happyReduction_111 -happyReduction_111 happy_x_1 - = case happyOut291 happy_x_1 of { happy_var_1 -> - happyIn59 - (happy_var_1 - )} - -happyReduce_112 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_112 = happySpecReduce_1 43# happyReduction_112 -happyReduction_112 happy_x_1 - = case happyOut274 happy_x_1 of { happy_var_1 -> - happyIn59 - (happy_var_1 - )} - -happyReduce_113 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_113 = happySpecReduce_2 44# happyReduction_113 -happyReduction_113 happy_x_2 - happy_x_1 - = case happyOut60 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn60 - (mj AnnSemi happy_var_2 : happy_var_1 - )}} - -happyReduce_114 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_114 = happySpecReduce_1 44# happyReduction_114 -happyReduction_114 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn60 - ([mj AnnSemi happy_var_1] - )} - -happyReduce_115 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_115 = happySpecReduce_2 45# happyReduction_115 -happyReduction_115 happy_x_2 - happy_x_1 - = case happyOut61 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn61 - (mj AnnSemi happy_var_2 : happy_var_1 - )}} - -happyReduce_116 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_116 = happySpecReduce_0 45# happyReduction_116 -happyReduction_116 = happyIn61 - ([] - ) - -happyReduce_117 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_117 = happySpecReduce_2 46# happyReduction_117 -happyReduction_117 happy_x_2 - happy_x_1 - = case happyOut63 happy_x_1 of { happy_var_1 -> - case happyOut64 happy_x_2 of { happy_var_2 -> - happyIn62 - (happy_var_2 : happy_var_1 - )}} - -happyReduce_118 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_118 = happyMonadReduce 3# 47# happyReduction_118 -happyReduction_118 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut63 happy_x_1 of { happy_var_1 -> - case happyOut64 happy_x_2 of { happy_var_2 -> - case happyOut60 happy_x_3 of { happy_var_3 -> - ( ams happy_var_2 happy_var_3 >> return (happy_var_2 : happy_var_1))}}}) - ) (\r -> happyReturn (happyIn63 r)) - -happyReduce_119 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_119 = happySpecReduce_0 47# happyReduction_119 -happyReduction_119 = happyIn63 - ([] - ) - -happyReduce_120 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_120 = happyMonadReduce 8# 48# happyReduction_120 -happyReduction_120 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut65 happy_x_2 of { happy_var_2 -> - case happyOut66 happy_x_3 of { happy_var_3 -> - case happyOut68 happy_x_4 of { happy_var_4 -> - case happyOut67 happy_x_5 of { happy_var_5 -> - case happyOut307 happy_x_6 of { happy_var_6 -> - case happyOut69 happy_x_7 of { happy_var_7 -> - case happyOut70 happy_x_8 of { happy_var_8 -> - ( ams (L (comb4 happy_var_1 happy_var_6 (snd happy_var_7) happy_var_8) $ - ImportDecl { ideclSourceSrc = snd $ fst happy_var_2 - , ideclName = happy_var_6, ideclPkgQual = snd happy_var_5 - , ideclSource = snd happy_var_2, ideclSafe = snd happy_var_3 - , ideclQualified = snd happy_var_4, ideclImplicit = False - , ideclAs = unLoc (snd happy_var_7) - , ideclHiding = unLoc happy_var_8 }) - ((mj AnnImport happy_var_1 : (fst $ fst happy_var_2) ++ fst happy_var_3 ++ fst happy_var_4 - ++ fst happy_var_5 ++ fst happy_var_7)))}}}}}}}}) - ) (\r -> happyReturn (happyIn64 r)) - -happyReduce_121 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_121 = happySpecReduce_2 49# happyReduction_121 -happyReduction_121 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn65 - ((([mo happy_var_1,mc happy_var_2],getSOURCE_PRAGs happy_var_1) - ,True) - )}} - -happyReduce_122 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_122 = happySpecReduce_0 49# happyReduction_122 -happyReduction_122 = happyIn65 - ((([],NoSourceText),False) - ) - -happyReduce_123 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_123 = happySpecReduce_1 50# happyReduction_123 -happyReduction_123 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn66 - (([mj AnnSafe happy_var_1],True) - )} - -happyReduce_124 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_124 = happySpecReduce_0 50# happyReduction_124 -happyReduction_124 = happyIn66 - (([],False) - ) - -happyReduce_125 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_125 = happyMonadReduce 1# 51# happyReduction_125 -happyReduction_125 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( let pkgFS = getSTRING happy_var_1 in - if looksLikePackageName (unpackFS pkgFS) - then return ([mj AnnPackageName happy_var_1], Just (StringLiteral (getSTRINGs happy_var_1) pkgFS)) - else parseErrorSDoc (getLoc happy_var_1) $ vcat [ - text "parse error" <> colon <+> quotes (ppr pkgFS), - text "Version number or non-alphanumeric" <+> - text "character in package name"])}) - ) (\r -> happyReturn (happyIn67 r)) - -happyReduce_126 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_126 = happySpecReduce_0 51# happyReduction_126 -happyReduction_126 = happyIn67 - (([],Nothing) - ) - -happyReduce_127 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_127 = happySpecReduce_1 52# happyReduction_127 -happyReduction_127 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn68 - (([mj AnnQualified happy_var_1],True) - )} - -happyReduce_128 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_128 = happySpecReduce_0 52# happyReduction_128 -happyReduction_128 = happyIn68 - (([],False) - ) - -happyReduce_129 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_129 = happySpecReduce_2 53# happyReduction_129 -happyReduction_129 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut307 happy_x_2 of { happy_var_2 -> - happyIn69 - (([mj AnnAs happy_var_1] - ,sLL happy_var_1 happy_var_2 (Just happy_var_2)) - )}} - -happyReduce_130 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_130 = happySpecReduce_0 53# happyReduction_130 -happyReduction_130 = happyIn69 - (([],noLoc Nothing) - ) - -happyReduce_131 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_131 = happyMonadReduce 1# 54# happyReduction_131 -happyReduction_131 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut71 happy_x_1 of { happy_var_1 -> - ( let (b, ie) = unLoc happy_var_1 in - checkImportSpec ie - >>= \checkedIe -> - return (L (gl happy_var_1) (Just (b, checkedIe))))}) - ) (\r -> happyReturn (happyIn70 r)) - -happyReduce_132 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_132 = happySpecReduce_0 54# happyReduction_132 -happyReduction_132 = happyIn70 - (noLoc Nothing - ) - -happyReduce_133 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_133 = happyMonadReduce 3# 55# happyReduction_133 -happyReduction_133 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut49 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (False, - sLL happy_var_1 happy_var_3 $ fromOL happy_var_2)) - [mop happy_var_1,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn71 r)) - -happyReduce_134 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_134 = happyMonadReduce 4# 55# happyReduction_134 -happyReduction_134 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut49 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 (True, - sLL happy_var_1 happy_var_4 $ fromOL happy_var_3)) - [mj AnnHiding happy_var_1,mop happy_var_2,mcp happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn71 r)) - -happyReduce_135 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_135 = happySpecReduce_0 56# happyReduction_135 -happyReduction_135 = happyIn72 - (noLoc (NoSourceText,9) - ) - -happyReduce_136 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_136 = happyMonadReduce 1# 56# happyReduction_136 -happyReduction_136 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( checkPrecP (sL1 happy_var_1 (getINTEGERs happy_var_1,fromInteger (getINTEGER happy_var_1))))}) - ) (\r -> happyReturn (happyIn72 r)) - -happyReduce_137 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_137 = happySpecReduce_1 57# happyReduction_137 -happyReduction_137 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn73 - (sL1 happy_var_1 InfixN - )} - -happyReduce_138 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_138 = happySpecReduce_1 57# happyReduction_138 -happyReduction_138 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn73 - (sL1 happy_var_1 InfixL - )} - -happyReduce_139 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_139 = happySpecReduce_1 57# happyReduction_139 -happyReduction_139 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn73 - (sL1 happy_var_1 InfixR - )} - -happyReduce_140 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_140 = happyMonadReduce 3# 58# happyReduction_140 -happyReduction_140 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut74 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut281 happy_x_3 of { happy_var_3 -> - ( addAnnotation (oll $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> - return (sLL happy_var_1 happy_var_3 ((unLoc happy_var_1) `appOL` unitOL happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn74 r)) - -happyReduce_141 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_141 = happySpecReduce_1 58# happyReduction_141 -happyReduction_141 happy_x_1 - = case happyOut281 happy_x_1 of { happy_var_1 -> - happyIn74 - (sL1 happy_var_1 (unitOL happy_var_1) - )} - -happyReduce_142 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_142 = happySpecReduce_2 59# happyReduction_142 -happyReduction_142 happy_x_2 - happy_x_1 - = case happyOut76 happy_x_1 of { happy_var_1 -> - case happyOut77 happy_x_2 of { happy_var_2 -> - happyIn75 - (happy_var_1 `snocOL` happy_var_2 - )}} - -happyReduce_143 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_143 = happyMonadReduce 3# 60# happyReduction_143 -happyReduction_143 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut76 happy_x_1 of { happy_var_1 -> - case happyOut77 happy_x_2 of { happy_var_2 -> - case happyOut60 happy_x_3 of { happy_var_3 -> - ( ams happy_var_2 happy_var_3 >> return (happy_var_1 `snocOL` happy_var_2))}}}) - ) (\r -> happyReturn (happyIn76 r)) - -happyReduce_144 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_144 = happySpecReduce_0 60# happyReduction_144 -happyReduction_144 = happyIn76 - (nilOL - ) - -happyReduce_145 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_145 = happySpecReduce_1 61# happyReduction_145 -happyReduction_145 happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - happyIn77 - (sL1 happy_var_1 (TyClD (unLoc happy_var_1)) - )} - -happyReduce_146 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_146 = happySpecReduce_1 61# happyReduction_146 -happyReduction_146 happy_x_1 - = case happyOut79 happy_x_1 of { happy_var_1 -> - happyIn77 - (sL1 happy_var_1 (TyClD (unLoc happy_var_1)) - )} - -happyReduce_147 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_147 = happySpecReduce_1 61# happyReduction_147 -happyReduction_147 happy_x_1 - = case happyOut80 happy_x_1 of { happy_var_1 -> - happyIn77 - (sL1 happy_var_1 (InstD (unLoc happy_var_1)) - )} - -happyReduce_148 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_148 = happySpecReduce_1 61# happyReduction_148 -happyReduction_148 happy_x_1 - = case happyOut100 happy_x_1 of { happy_var_1 -> - happyIn77 - (sLL happy_var_1 happy_var_1 (DerivD (unLoc happy_var_1)) - )} - -happyReduce_149 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_149 = happySpecReduce_1 61# happyReduction_149 -happyReduction_149 happy_x_1 - = case happyOut101 happy_x_1 of { happy_var_1 -> - happyIn77 - (sL1 happy_var_1 (RoleAnnotD (unLoc happy_var_1)) - )} - -happyReduce_150 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_150 = happyMonadReduce 4# 61# happyReduction_150 -happyReduction_150 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut164 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 (DefD (DefaultDecl happy_var_3))) - [mj AnnDefault happy_var_1 - ,mop happy_var_2,mcp happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_151 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_151 = happyMonadReduce 2# 61# happyReduction_151 -happyReduction_151 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut137 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 (snd $ unLoc happy_var_2)) - (mj AnnForeign happy_var_1:(fst $ unLoc happy_var_2)))}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_152 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_152 = happyMonadReduce 3# 61# happyReduction_152 -happyReduction_152 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut132 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ WarningD (Warnings (getDEPRECATED_PRAGs happy_var_1) (fromOL happy_var_2))) - [mo happy_var_1,mc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_153 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_153 = happyMonadReduce 3# 61# happyReduction_153 -happyReduction_153 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut130 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ WarningD (Warnings (getWARNING_PRAGs happy_var_1) (fromOL happy_var_2))) - [mo happy_var_1,mc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_154 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_154 = happyMonadReduce 3# 61# happyReduction_154 -happyReduction_154 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut123 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ RuleD (HsRules (getRULES_PRAGs happy_var_1) (fromOL happy_var_2))) - [mo happy_var_1,mc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_155 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_155 = happyMonadReduce 5# 61# happyReduction_155 -happyReduction_155 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut291 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut200 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( ams (sLL happy_var_1 happy_var_5 $ VectD (HsVect (getVECT_PRAGs happy_var_1) happy_var_2 happy_var_4)) - [mo happy_var_1,mj AnnEqual happy_var_3 - ,mc happy_var_5])}}}}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_156 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_156 = happyMonadReduce 3# 61# happyReduction_156 -happyReduction_156 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut291 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ VectD (HsNoVect (getNOVECT_PRAGs happy_var_1) happy_var_2)) - [mo happy_var_1,mc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_157 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_157 = happyMonadReduce 4# 61# happyReduction_157 -happyReduction_157 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut271 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 $ - VectD (HsVectTypeIn (getVECT_PRAGs happy_var_1) False happy_var_3 Nothing)) - [mo happy_var_1,mj AnnType happy_var_2,mc happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_158 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_158 = happyMonadReduce 4# 61# happyReduction_158 -happyReduction_158 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut271 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 $ - VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs happy_var_1) True happy_var_3 Nothing)) - [mo happy_var_1,mj AnnType happy_var_2,mc happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_159 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_159 = happyMonadReduce 6# 61# happyReduction_159 -happyReduction_159 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut271 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut271 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { happy_var_6 -> - ( ams (sLL happy_var_1 happy_var_6 $ - VectD (HsVectTypeIn (getVECT_PRAGs happy_var_1) False happy_var_3 (Just happy_var_5))) - [mo happy_var_1,mj AnnType happy_var_2,mj AnnEqual happy_var_4,mc happy_var_6])}}}}}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_160 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_160 = happyMonadReduce 6# 61# happyReduction_160 -happyReduction_160 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut271 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut271 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { happy_var_6 -> - ( ams (sLL happy_var_1 happy_var_6 $ - VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs happy_var_1) True happy_var_3 (Just happy_var_5))) - [mo happy_var_1,mj AnnType happy_var_2,mj AnnEqual happy_var_4,mc happy_var_6])}}}}}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_161 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_161 = happyMonadReduce 4# 61# happyReduction_161 -happyReduction_161 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut271 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 $ VectD (HsVectClassIn (getVECT_PRAGs happy_var_1) happy_var_3)) - [mo happy_var_1,mj AnnClass happy_var_2,mc happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_162 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_162 = happySpecReduce_1 61# happyReduction_162 -happyReduction_162 happy_x_1 - = case happyOut136 happy_x_1 of { happy_var_1 -> - happyIn77 - (happy_var_1 - )} - -happyReduce_163 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_163 = happySpecReduce_1 61# happyReduction_163 -happyReduction_163 happy_x_1 - = case happyOut191 happy_x_1 of { happy_var_1 -> - happyIn77 - (happy_var_1 - )} - -happyReduce_164 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_164 = happySpecReduce_1 61# happyReduction_164 -happyReduction_164 happy_x_1 - = case happyOut202 happy_x_1 of { happy_var_1 -> - happyIn77 - (sLL happy_var_1 happy_var_1 $ mkSpliceDecl happy_var_1 - )} - -happyReduce_165 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_165 = happyMonadReduce 4# 62# happyReduction_165 -happyReduction_165 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut98 happy_x_2 of { happy_var_2 -> - case happyOut169 happy_x_3 of { happy_var_3 -> - case happyOut114 happy_x_4 of { happy_var_4 -> - ( amms (mkClassDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) happy_var_2 happy_var_3 (snd $ unLoc happy_var_4)) - (mj AnnClass happy_var_1:(fst $ unLoc happy_var_3)++(fst $ unLoc happy_var_4)))}}}}) - ) (\r -> happyReturn (happyIn78 r)) - -happyReduce_166 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_166 = happyMonadReduce 4# 63# happyReduction_166 -happyReduction_166 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut155 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut152 happy_x_4 of { happy_var_4 -> - ( amms (mkTySynonym (comb2 happy_var_1 happy_var_4) happy_var_2 happy_var_4) - [mj AnnType happy_var_1,mj AnnEqual happy_var_3])}}}}) - ) (\r -> happyReturn (happyIn79 r)) - -happyReduce_167 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_167 = happyMonadReduce 6# 63# happyReduction_167 -happyReduction_167 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut155 happy_x_3 of { happy_var_3 -> - case happyOut96 happy_x_4 of { happy_var_4 -> - case happyOut83 happy_x_5 of { happy_var_5 -> - case happyOut86 happy_x_6 of { happy_var_6 -> - ( amms (mkFamDecl (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_6) happy_var_3 - (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5)) - (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4) - ++ (fst $ unLoc happy_var_5) ++ (fst $ unLoc happy_var_6)))}}}}}}) - ) (\r -> happyReturn (happyIn79 r)) - -happyReduce_168 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_168 = happyMonadReduce 5# 63# happyReduction_168 -happyReduction_168 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut93 happy_x_1 of { happy_var_1 -> - case happyOut99 happy_x_2 of { happy_var_2 -> - case happyOut98 happy_x_3 of { happy_var_3 -> - case happyOut178 happy_x_4 of { happy_var_4 -> - case happyOut186 happy_x_5 of { happy_var_5 -> - ( amms (mkTyData (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3 - Nothing (reverse (snd $ unLoc happy_var_4)) - (fmap reverse happy_var_5)) - -- We need the location on tycl_hdr in case - -- constrs and deriving are both empty - ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)))}}}}}) - ) (\r -> happyReturn (happyIn79 r)) - -happyReduce_169 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_169 = happyMonadReduce 6# 63# happyReduction_169 -happyReduction_169 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut93 happy_x_1 of { happy_var_1 -> - case happyOut99 happy_x_2 of { happy_var_2 -> - case happyOut98 happy_x_3 of { happy_var_3 -> - case happyOut94 happy_x_4 of { happy_var_4 -> - case happyOut174 happy_x_5 of { happy_var_5 -> - case happyOut186 happy_x_6 of { happy_var_6 -> - ( amms (mkTyData (comb4 happy_var_1 happy_var_3 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3 - (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) - (fmap reverse happy_var_6) ) - -- We need the location on tycl_hdr in case - -- constrs and deriving are both empty - ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))}}}}}}) - ) (\r -> happyReturn (happyIn79 r)) - -happyReduce_170 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_170 = happyMonadReduce 4# 63# happyReduction_170 -happyReduction_170 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut155 happy_x_3 of { happy_var_3 -> - case happyOut95 happy_x_4 of { happy_var_4 -> - ( amms (mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_4) DataFamily happy_var_3 - (snd $ unLoc happy_var_4) Nothing) - (mj AnnData happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)))}}}}) - ) (\r -> happyReturn (happyIn79 r)) - -happyReduce_171 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_171 = happyMonadReduce 4# 64# happyReduction_171 -happyReduction_171 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut81 happy_x_2 of { happy_var_2 -> - case happyOut162 happy_x_3 of { happy_var_3 -> - case happyOut118 happy_x_4 of { happy_var_4 -> - ( do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc happy_var_4) - ; let cid = ClsInstDecl { cid_poly_ty = happy_var_3, cid_binds = binds - , cid_sigs = mkClassOpSigs sigs - , cid_tyfam_insts = ats - , cid_overlap_mode = happy_var_2 - , cid_datafam_insts = adts } - ; ams (L (comb3 happy_var_1 (hsSigType happy_var_3) happy_var_4) (ClsInstD { cid_inst = cid })) - (mj AnnInstance happy_var_1 : (fst $ unLoc happy_var_4)) })}}}}) - ) (\r -> happyReturn (happyIn80 r)) - -happyReduce_172 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_172 = happyMonadReduce 3# 64# happyReduction_172 -happyReduction_172 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut89 happy_x_3 of { happy_var_3 -> - ( ams happy_var_3 (fst $ unLoc happy_var_3) - >> amms (mkTyFamInst (comb2 happy_var_1 happy_var_3) (snd $ unLoc happy_var_3)) - (mj AnnType happy_var_1:mj AnnInstance happy_var_2:(fst $ unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn80 r)) - -happyReduce_173 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_173 = happyMonadReduce 6# 64# happyReduction_173 -happyReduction_173 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut93 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut99 happy_x_3 of { happy_var_3 -> - case happyOut98 happy_x_4 of { happy_var_4 -> - case happyOut178 happy_x_5 of { happy_var_5 -> - case happyOut186 happy_x_6 of { happy_var_6 -> - ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 happy_var_4 - Nothing (reverse (snd $ unLoc happy_var_5)) - (fmap reverse happy_var_6)) - ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2:(fst $ unLoc happy_var_5)))}}}}}}) - ) (\r -> happyReturn (happyIn80 r)) - -happyReduce_174 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_174 = happyMonadReduce 7# 64# happyReduction_174 -happyReduction_174 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut93 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut99 happy_x_3 of { happy_var_3 -> - case happyOut98 happy_x_4 of { happy_var_4 -> - case happyOut94 happy_x_5 of { happy_var_5 -> - case happyOut174 happy_x_6 of { happy_var_6 -> - case happyOut186 happy_x_7 of { happy_var_7 -> - ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 happy_var_4 - (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) - (fmap reverse happy_var_7)) - ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2 - :(fst $ unLoc happy_var_5)++(fst $ unLoc happy_var_6)))}}}}}}}) - ) (\r -> happyReturn (happyIn80 r)) - -happyReduce_175 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_175 = happyMonadReduce 2# 65# happyReduction_175 -happyReduction_175 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ajs (Just (sLL happy_var_1 happy_var_2 (Overlappable (getOVERLAPPABLE_PRAGs happy_var_1)))) - [mo happy_var_1,mc happy_var_2])}}) - ) (\r -> happyReturn (happyIn81 r)) - -happyReduce_176 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_176 = happyMonadReduce 2# 65# happyReduction_176 -happyReduction_176 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ajs (Just (sLL happy_var_1 happy_var_2 (Overlapping (getOVERLAPPING_PRAGs happy_var_1)))) - [mo happy_var_1,mc happy_var_2])}}) - ) (\r -> happyReturn (happyIn81 r)) - -happyReduce_177 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_177 = happyMonadReduce 2# 65# happyReduction_177 -happyReduction_177 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ajs (Just (sLL happy_var_1 happy_var_2 (Overlaps (getOVERLAPS_PRAGs happy_var_1)))) - [mo happy_var_1,mc happy_var_2])}}) - ) (\r -> happyReturn (happyIn81 r)) - -happyReduce_178 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_178 = happyMonadReduce 2# 65# happyReduction_178 -happyReduction_178 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ajs (Just (sLL happy_var_1 happy_var_2 (Incoherent (getINCOHERENT_PRAGs happy_var_1)))) - [mo happy_var_1,mc happy_var_2])}}) - ) (\r -> happyReturn (happyIn81 r)) - -happyReduce_179 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_179 = happySpecReduce_0 65# happyReduction_179 -happyReduction_179 = happyIn81 - (Nothing - ) - -happyReduce_180 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_180 = happyMonadReduce 1# 66# happyReduction_180 -happyReduction_180 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( ajs (Just (sL1 happy_var_1 StockStrategy)) - [mj AnnStock happy_var_1])}) - ) (\r -> happyReturn (happyIn82 r)) - -happyReduce_181 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_181 = happyMonadReduce 1# 66# happyReduction_181 -happyReduction_181 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( ajs (Just (sL1 happy_var_1 AnyclassStrategy)) - [mj AnnAnyclass happy_var_1])}) - ) (\r -> happyReturn (happyIn82 r)) - -happyReduce_182 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_182 = happyMonadReduce 1# 66# happyReduction_182 -happyReduction_182 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( ajs (Just (sL1 happy_var_1 NewtypeStrategy)) - [mj AnnNewtype happy_var_1])}) - ) (\r -> happyReturn (happyIn82 r)) - -happyReduce_183 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_183 = happySpecReduce_0 66# happyReduction_183 -happyReduction_183 = happyIn82 - (Nothing - ) - -happyReduce_184 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_184 = happySpecReduce_0 67# happyReduction_184 -happyReduction_184 = happyIn83 - (noLoc ([], Nothing) - ) - -happyReduce_185 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_185 = happySpecReduce_2 67# happyReduction_185 -happyReduction_185 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut84 happy_x_2 of { happy_var_2 -> - happyIn83 - (sLL happy_var_1 happy_var_2 ([mj AnnVbar happy_var_1] - , Just (happy_var_2)) - )}} - -happyReduce_186 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_186 = happyMonadReduce 3# 68# happyReduction_186 -happyReduction_186 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut289 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut85 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (InjectivityAnn happy_var_1 (reverse (unLoc happy_var_3)))) - [mu AnnRarrow happy_var_2])}}}) - ) (\r -> happyReturn (happyIn84 r)) - -happyReduce_187 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_187 = happySpecReduce_2 69# happyReduction_187 -happyReduction_187 happy_x_2 - happy_x_1 - = case happyOut85 happy_x_1 of { happy_var_1 -> - case happyOut289 happy_x_2 of { happy_var_2 -> - happyIn85 - (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) - )}} - -happyReduce_188 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_188 = happySpecReduce_1 69# happyReduction_188 -happyReduction_188 happy_x_1 - = case happyOut289 happy_x_1 of { happy_var_1 -> - happyIn85 - (sLL happy_var_1 happy_var_1 [happy_var_1] - )} - -happyReduce_189 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_189 = happySpecReduce_0 70# happyReduction_189 -happyReduction_189 = happyIn86 - (noLoc ([],OpenTypeFamily) - ) - -happyReduce_190 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_190 = happySpecReduce_2 70# happyReduction_190 -happyReduction_190 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut87 happy_x_2 of { happy_var_2 -> - happyIn86 - (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) - ,ClosedTypeFamily (fmap reverse $ snd $ unLoc happy_var_2)) - )}} - -happyReduce_191 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_191 = happySpecReduce_3 71# happyReduction_191 -happyReduction_191 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut88 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn87 - (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3] - ,Just (unLoc happy_var_2)) - )}}} - -happyReduce_192 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_192 = happySpecReduce_3 71# happyReduction_192 -happyReduction_192 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut88 happy_x_2 of { happy_var_2 -> - happyIn87 - (let L loc _ = happy_var_2 in - L loc ([],Just (unLoc happy_var_2)) - )} - -happyReduce_193 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_193 = happySpecReduce_3 71# happyReduction_193 -happyReduction_193 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn87 - (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mj AnnDotdot happy_var_2 - ,mcc happy_var_3],Nothing) - )}}} - -happyReduce_194 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_194 = happySpecReduce_3 71# happyReduction_194 -happyReduction_194 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn87 - (let L loc _ = happy_var_2 in - L loc ([mj AnnDotdot happy_var_2],Nothing) - )} - -happyReduce_195 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_195 = happyMonadReduce 3# 72# happyReduction_195 -happyReduction_195 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut88 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut89 happy_x_3 of { happy_var_3 -> - ( asl (unLoc happy_var_1) happy_var_2 (snd $ unLoc happy_var_3) - >> ams happy_var_3 (fst $ unLoc happy_var_3) - >> return (sLL happy_var_1 happy_var_3 ((snd $ unLoc happy_var_3) : unLoc happy_var_1)))}}}) - ) (\r -> happyReturn (happyIn88 r)) - -happyReduce_196 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_196 = happyMonadReduce 2# 72# happyReduction_196 -happyReduction_196 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut88 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( addAnnotation (gl happy_var_1) AnnSemi (gl happy_var_2) - >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}}) - ) (\r -> happyReturn (happyIn88 r)) - -happyReduce_197 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_197 = happyMonadReduce 1# 72# happyReduction_197 -happyReduction_197 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut89 happy_x_1 of { happy_var_1 -> - ( ams happy_var_1 (fst $ unLoc happy_var_1) - >> return (sLL happy_var_1 happy_var_1 [snd $ unLoc happy_var_1]))}) - ) (\r -> happyReturn (happyIn88 r)) - -happyReduce_198 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_198 = happySpecReduce_0 72# happyReduction_198 -happyReduction_198 = happyIn88 - (noLoc [] - ) - -happyReduce_199 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_199 = happyMonadReduce 3# 73# happyReduction_199 -happyReduction_199 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut155 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut151 happy_x_3 of { happy_var_3 -> - ( do { (eqn,ann) <- mkTyFamInstEqn happy_var_1 happy_var_3 - ; return (sLL happy_var_1 happy_var_3 (mj AnnEqual happy_var_2:ann, sLL happy_var_1 happy_var_3 eqn)) })}}}) - ) (\r -> happyReturn (happyIn89 r)) - -happyReduce_200 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_200 = happyMonadReduce 4# 74# happyReduction_200 -happyReduction_200 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut91 happy_x_2 of { happy_var_2 -> - case happyOut155 happy_x_3 of { happy_var_3 -> - case happyOut95 happy_x_4 of { happy_var_4 -> - ( amms (liftM mkTyClD (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) DataFamily happy_var_3 - (snd $ unLoc happy_var_4) Nothing)) - (mj AnnData happy_var_1:happy_var_2++(fst $ unLoc happy_var_4)))}}}}) - ) (\r -> happyReturn (happyIn90 r)) - -happyReduce_201 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_201 = happyMonadReduce 3# 74# happyReduction_201 -happyReduction_201 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut155 happy_x_2 of { happy_var_2 -> - case happyOut97 happy_x_3 of { happy_var_3 -> - ( amms (liftM mkTyClD - (mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_3) OpenTypeFamily happy_var_2 - (fst . snd $ unLoc happy_var_3) - (snd . snd $ unLoc happy_var_3))) - (mj AnnType happy_var_1:(fst $ unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn90 r)) - -happyReduce_202 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_202 = happyMonadReduce 4# 74# happyReduction_202 -happyReduction_202 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut155 happy_x_3 of { happy_var_3 -> - case happyOut97 happy_x_4 of { happy_var_4 -> - ( amms (liftM mkTyClD - (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) OpenTypeFamily happy_var_3 - (fst . snd $ unLoc happy_var_4) - (snd . snd $ unLoc happy_var_4))) - (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)))}}}}) - ) (\r -> happyReturn (happyIn90 r)) - -happyReduce_203 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_203 = happyMonadReduce 2# 74# happyReduction_203 -happyReduction_203 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut89 happy_x_2 of { happy_var_2 -> - ( ams happy_var_2 (fst $ unLoc happy_var_2) >> - amms (liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_2) (snd $ unLoc happy_var_2))) - (mj AnnType happy_var_1:(fst $ unLoc happy_var_2)))}}) - ) (\r -> happyReturn (happyIn90 r)) - -happyReduce_204 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_204 = happyMonadReduce 3# 74# happyReduction_204 -happyReduction_204 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut89 happy_x_3 of { happy_var_3 -> - ( ams happy_var_3 (fst $ unLoc happy_var_3) >> - amms (liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_3) (snd $ unLoc happy_var_3))) - (mj AnnType happy_var_1:mj AnnInstance happy_var_2:(fst $ unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn90 r)) - -happyReduce_205 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_205 = happySpecReduce_0 75# happyReduction_205 -happyReduction_205 = happyIn91 - ([] - ) - -happyReduce_206 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_206 = happySpecReduce_1 75# happyReduction_206 -happyReduction_206 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn91 - ([mj AnnFamily happy_var_1] - )} - -happyReduce_207 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_207 = happyMonadReduce 2# 76# happyReduction_207 -happyReduction_207 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut89 happy_x_2 of { happy_var_2 -> - ( ams happy_var_2 (fst $ unLoc happy_var_2) >> - amms (mkTyFamInst (comb2 happy_var_1 happy_var_2) (snd $ unLoc happy_var_2)) - (mj AnnType happy_var_1:(fst $ unLoc happy_var_2)))}}) - ) (\r -> happyReturn (happyIn92 r)) - -happyReduce_208 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_208 = happyMonadReduce 5# 76# happyReduction_208 -happyReduction_208 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut93 happy_x_1 of { happy_var_1 -> - case happyOut99 happy_x_2 of { happy_var_2 -> - case happyOut98 happy_x_3 of { happy_var_3 -> - case happyOut178 happy_x_4 of { happy_var_4 -> - case happyOut186 happy_x_5 of { happy_var_5 -> - ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3 - Nothing (reverse (snd $ unLoc happy_var_4)) - (fmap reverse happy_var_5)) - ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)))}}}}}) - ) (\r -> happyReturn (happyIn92 r)) - -happyReduce_209 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_209 = happyMonadReduce 6# 76# happyReduction_209 -happyReduction_209 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut93 happy_x_1 of { happy_var_1 -> - case happyOut99 happy_x_2 of { happy_var_2 -> - case happyOut98 happy_x_3 of { happy_var_3 -> - case happyOut94 happy_x_4 of { happy_var_4 -> - case happyOut174 happy_x_5 of { happy_var_5 -> - case happyOut186 happy_x_6 of { happy_var_6 -> - ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_3 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_2 - happy_var_3 (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) - (fmap reverse happy_var_6)) - ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))}}}}}}) - ) (\r -> happyReturn (happyIn92 r)) - -happyReduce_210 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_210 = happySpecReduce_1 77# happyReduction_210 -happyReduction_210 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn93 - (sL1 happy_var_1 (mj AnnData happy_var_1,DataType) - )} - -happyReduce_211 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_211 = happySpecReduce_1 77# happyReduction_211 -happyReduction_211 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn93 - (sL1 happy_var_1 (mj AnnNewtype happy_var_1,NewType) - )} - -happyReduce_212 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_212 = happySpecReduce_0 78# happyReduction_212 -happyReduction_212 = happyIn94 - (noLoc ([] , Nothing) - ) - -happyReduce_213 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_213 = happySpecReduce_2 78# happyReduction_213 -happyReduction_213 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut173 happy_x_2 of { happy_var_2 -> - happyIn94 - (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], Just happy_var_2) - )}} - -happyReduce_214 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_214 = happySpecReduce_0 79# happyReduction_214 -happyReduction_214 = happyIn95 - (noLoc ([] , noLoc NoSig ) - ) - -happyReduce_215 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_215 = happySpecReduce_2 79# happyReduction_215 -happyReduction_215 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut173 happy_x_2 of { happy_var_2 -> - happyIn95 - (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], sLL happy_var_1 happy_var_2 (KindSig happy_var_2)) - )}} - -happyReduce_216 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_216 = happySpecReduce_0 80# happyReduction_216 -happyReduction_216 = happyIn96 - (noLoc ([] , noLoc NoSig ) - ) - -happyReduce_217 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_217 = happySpecReduce_2 80# happyReduction_217 -happyReduction_217 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut173 happy_x_2 of { happy_var_2 -> - happyIn96 - (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], sLL happy_var_1 happy_var_2 (KindSig happy_var_2)) - )}} - -happyReduce_218 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_218 = happySpecReduce_2 80# happyReduction_218 -happyReduction_218 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut168 happy_x_2 of { happy_var_2 -> - happyIn96 - (sLL happy_var_1 happy_var_2 ([mj AnnEqual happy_var_1] , sLL happy_var_1 happy_var_2 (TyVarSig happy_var_2)) - )}} - -happyReduce_219 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_219 = happySpecReduce_0 81# happyReduction_219 -happyReduction_219 = happyIn97 - (noLoc ([], (noLoc NoSig, Nothing)) - ) - -happyReduce_220 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_220 = happySpecReduce_2 81# happyReduction_220 -happyReduction_220 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut173 happy_x_2 of { happy_var_2 -> - happyIn97 - (sLL happy_var_1 happy_var_2 ( [mu AnnDcolon happy_var_1] - , (sLL happy_var_2 happy_var_2 (KindSig happy_var_2), Nothing)) - )}} - -happyReduce_221 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_221 = happyReduce 4# 81# happyReduction_221 -happyReduction_221 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut168 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut84 happy_x_4 of { happy_var_4 -> - happyIn97 - (sLL happy_var_1 happy_var_4 ([mj AnnEqual happy_var_1, mj AnnVbar happy_var_3] - , (sLL happy_var_1 happy_var_2 (TyVarSig happy_var_2), Just happy_var_4)) - ) `HappyStk` happyRest}}}} - -happyReduce_222 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_222 = happyMonadReduce 3# 82# happyReduction_222 -happyReduction_222 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut153 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut155 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) - >> (return (sLL happy_var_1 happy_var_3 (Just happy_var_1, happy_var_3))))}}}) - ) (\r -> happyReturn (happyIn98 r)) - -happyReduce_223 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_223 = happySpecReduce_1 82# happyReduction_223 -happyReduction_223 happy_x_1 - = case happyOut155 happy_x_1 of { happy_var_1 -> - happyIn98 - (sL1 happy_var_1 (Nothing, happy_var_1) - )} - -happyReduce_224 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_224 = happyMonadReduce 4# 83# happyReduction_224 -happyReduction_224 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ajs (Just (sLL happy_var_1 happy_var_4 (CType (getCTYPEs happy_var_1) (Just (Header (getSTRINGs happy_var_2) (getSTRING happy_var_2))) - (getSTRINGs happy_var_3,getSTRING happy_var_3)))) - [mo happy_var_1,mj AnnHeader happy_var_2,mj AnnVal happy_var_3,mc happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn99 r)) - -happyReduce_225 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_225 = happyMonadReduce 3# 83# happyReduction_225 -happyReduction_225 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ajs (Just (sLL happy_var_1 happy_var_3 (CType (getCTYPEs happy_var_1) Nothing (getSTRINGs happy_var_2, getSTRING happy_var_2)))) - [mo happy_var_1,mj AnnVal happy_var_2,mc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn99 r)) - -happyReduce_226 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_226 = happySpecReduce_0 83# happyReduction_226 -happyReduction_226 = happyIn99 - (Nothing - ) - -happyReduce_227 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_227 = happyMonadReduce 5# 84# happyReduction_227 -happyReduction_227 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut82 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut81 happy_x_4 of { happy_var_4 -> - case happyOut162 happy_x_5 of { happy_var_5 -> - ( do { let { err = text "in the stand-alone deriving instance" - <> colon <+> quotes (ppr happy_var_5) } - ; ams (sLL happy_var_1 (hsSigType happy_var_5) (DerivDecl happy_var_5 happy_var_2 happy_var_4)) - [mj AnnDeriving happy_var_1, mj AnnInstance happy_var_3] })}}}}}) - ) (\r -> happyReturn (happyIn100 r)) - -happyReduce_228 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_228 = happyMonadReduce 4# 85# happyReduction_228 -happyReduction_228 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut273 happy_x_3 of { happy_var_3 -> - case happyOut102 happy_x_4 of { happy_var_4 -> - ( amms (mkRoleAnnotDecl (comb3 happy_var_1 happy_var_3 happy_var_4) happy_var_3 (reverse (unLoc happy_var_4))) - [mj AnnType happy_var_1,mj AnnRole happy_var_2])}}}}) - ) (\r -> happyReturn (happyIn101 r)) - -happyReduce_229 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_229 = happySpecReduce_0 86# happyReduction_229 -happyReduction_229 = happyIn102 - (noLoc [] - ) - -happyReduce_230 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_230 = happySpecReduce_1 86# happyReduction_230 -happyReduction_230 happy_x_1 - = case happyOut103 happy_x_1 of { happy_var_1 -> - happyIn102 - (happy_var_1 - )} - -happyReduce_231 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_231 = happySpecReduce_1 87# happyReduction_231 -happyReduction_231 happy_x_1 - = case happyOut104 happy_x_1 of { happy_var_1 -> - happyIn103 - (sLL happy_var_1 happy_var_1 [happy_var_1] - )} - -happyReduce_232 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_232 = happySpecReduce_2 87# happyReduction_232 -happyReduction_232 happy_x_2 - happy_x_1 - = case happyOut103 happy_x_1 of { happy_var_1 -> - case happyOut104 happy_x_2 of { happy_var_2 -> - happyIn103 - (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 - )}} - -happyReduce_233 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_233 = happySpecReduce_1 88# happyReduction_233 -happyReduction_233 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn104 - (sL1 happy_var_1 $ Just $ getVARID happy_var_1 - )} - -happyReduce_234 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_234 = happySpecReduce_1 88# happyReduction_234 -happyReduction_234 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn104 - (sL1 happy_var_1 Nothing - )} - -happyReduce_235 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_235 = happyMonadReduce 4# 89# happyReduction_235 -happyReduction_235 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut106 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut239 happy_x_4 of { happy_var_4 -> - ( let (name, args,as ) = happy_var_2 in - ams (sLL happy_var_1 happy_var_4 . ValD $ mkPatSynBind name args happy_var_4 - ImplicitBidirectional) - (as ++ [mj AnnPattern happy_var_1, mj AnnEqual happy_var_3]))}}}}) - ) (\r -> happyReturn (happyIn105 r)) - -happyReduce_236 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_236 = happyMonadReduce 4# 89# happyReduction_236 -happyReduction_236 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut106 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut239 happy_x_4 of { happy_var_4 -> - ( let (name, args, as) = happy_var_2 in - ams (sLL happy_var_1 happy_var_4 . ValD $ mkPatSynBind name args happy_var_4 Unidirectional) - (as ++ [mj AnnPattern happy_var_1,mu AnnLarrow happy_var_3]))}}}}) - ) (\r -> happyReturn (happyIn105 r)) - -happyReduce_237 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_237 = happyMonadReduce 5# 89# happyReduction_237 -happyReduction_237 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut106 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut239 happy_x_4 of { happy_var_4 -> - case happyOut109 happy_x_5 of { happy_var_5 -> - ( do { let (name, args, as) = happy_var_2 - ; mg <- mkPatSynMatchGroup name (snd $ unLoc happy_var_5) - ; ams (sLL happy_var_1 happy_var_5 . ValD $ - mkPatSynBind name args happy_var_4 (ExplicitBidirectional mg)) - (as ++ ((mj AnnPattern happy_var_1:mu AnnLarrow happy_var_3:(fst $ unLoc happy_var_5))) ) - })}}}}}) - ) (\r -> happyReturn (happyIn105 r)) - -happyReduce_238 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_238 = happySpecReduce_2 90# happyReduction_238 -happyReduction_238 happy_x_2 - happy_x_1 - = case happyOut265 happy_x_1 of { happy_var_1 -> - case happyOut107 happy_x_2 of { happy_var_2 -> - happyIn106 - ((happy_var_1, PrefixPatSyn happy_var_2, []) - )}} - -happyReduce_239 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_239 = happySpecReduce_3 90# happyReduction_239 -happyReduction_239 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut293 happy_x_1 of { happy_var_1 -> - case happyOut269 happy_x_2 of { happy_var_2 -> - case happyOut293 happy_x_3 of { happy_var_3 -> - happyIn106 - ((happy_var_2, InfixPatSyn happy_var_1 happy_var_3, []) - )}}} - -happyReduce_240 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_240 = happyReduce 4# 90# happyReduction_240 -happyReduction_240 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut265 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut108 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn106 - ((happy_var_1, RecordPatSyn happy_var_3, [moc happy_var_2, mcc happy_var_4] ) - ) `HappyStk` happyRest}}}} - -happyReduce_241 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_241 = happySpecReduce_0 91# happyReduction_241 -happyReduction_241 = happyIn107 - ([] - ) - -happyReduce_242 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_242 = happySpecReduce_2 91# happyReduction_242 -happyReduction_242 happy_x_2 - happy_x_1 - = case happyOut293 happy_x_1 of { happy_var_1 -> - case happyOut107 happy_x_2 of { happy_var_2 -> - happyIn107 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_243 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_243 = happySpecReduce_1 92# happyReduction_243 -happyReduction_243 happy_x_1 - = case happyOut293 happy_x_1 of { happy_var_1 -> - happyIn108 - ([RecordPatSynField happy_var_1 happy_var_1] - )} - -happyReduce_244 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_244 = happyMonadReduce 3# 92# happyReduction_244 -happyReduction_244 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut293 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut108 happy_x_3 of { happy_var_3 -> - ( addAnnotation (getLoc happy_var_1) AnnComma (getLoc happy_var_2) >> - return ((RecordPatSynField happy_var_1 happy_var_1) : happy_var_3 ))}}}) - ) (\r -> happyReturn (happyIn108 r)) - -happyReduce_245 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_245 = happyReduce 4# 93# happyReduction_245 -happyReduction_245 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut119 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn109 - (sLL happy_var_1 happy_var_4 ((mj AnnWhere happy_var_1:moc happy_var_2 - :mcc happy_var_4:(fst $ unLoc happy_var_3)),sL1 happy_var_3 (snd $ unLoc happy_var_3)) - ) `HappyStk` happyRest}}}} - -happyReduce_246 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_246 = happyReduce 4# 93# happyReduction_246 -happyReduction_246 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut119 happy_x_3 of { happy_var_3 -> - happyIn109 - (L (comb2 happy_var_1 happy_var_3) ((mj AnnWhere happy_var_1:(fst $ unLoc happy_var_3)) - ,sL1 happy_var_3 (snd $ unLoc happy_var_3)) - ) `HappyStk` happyRest}} - -happyReduce_247 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_247 = happyMonadReduce 4# 94# happyReduction_247 -happyReduction_247 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut266 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut145 happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 $ PatSynSig (unLoc happy_var_2) (mkLHsSigType happy_var_4)) - [mj AnnPattern happy_var_1, mu AnnDcolon happy_var_3])}}}}) - ) (\r -> happyReturn (happyIn110 r)) - -happyReduce_248 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_248 = happySpecReduce_1 95# happyReduction_248 -happyReduction_248 happy_x_1 - = case happyOut90 happy_x_1 of { happy_var_1 -> - happyIn111 - (happy_var_1 - )} - -happyReduce_249 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_249 = happySpecReduce_1 95# happyReduction_249 -happyReduction_249 happy_x_1 - = case happyOut192 happy_x_1 of { happy_var_1 -> - happyIn111 - (happy_var_1 - )} - -happyReduce_250 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_250 = happyMonadReduce 4# 95# happyReduction_250 -happyReduction_250 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut201 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut145 happy_x_4 of { happy_var_4 -> - ( do { v <- checkValSigLhs happy_var_2 - ; let err = text "in default signature" <> colon <+> - quotes (ppr happy_var_2) - ; ams (sLL happy_var_1 happy_var_4 $ SigD $ ClassOpSig True [v] $ mkLHsSigType happy_var_4) - [mj AnnDefault happy_var_1,mu AnnDcolon happy_var_3] })}}}}) - ) (\r -> happyReturn (happyIn111 r)) - -happyReduce_251 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_251 = happyMonadReduce 3# 96# happyReduction_251 -happyReduction_251 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut112 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut111 happy_x_3 of { happy_var_3 -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) - , unitOL happy_var_3)) - else ams (lastOL (snd $ unLoc happy_var_1)) [mj AnnSemi happy_var_2] - >> return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 - ,(snd $ unLoc happy_var_1) `appOL` unitOL happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn112 r)) - -happyReduce_252 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_252 = happyMonadReduce 2# 96# happyReduction_252 -happyReduction_252 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut112 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) - ,snd $ unLoc happy_var_1)) - else ams (lastOL (snd $ unLoc happy_var_1)) [mj AnnSemi happy_var_2] - >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}}) - ) (\r -> happyReturn (happyIn112 r)) - -happyReduce_253 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_253 = happySpecReduce_1 96# happyReduction_253 -happyReduction_253 happy_x_1 - = case happyOut111 happy_x_1 of { happy_var_1 -> - happyIn112 - (sL1 happy_var_1 ([], unitOL happy_var_1) - )} - -happyReduce_254 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_254 = happySpecReduce_0 96# happyReduction_254 -happyReduction_254 = happyIn112 - (noLoc ([],nilOL) - ) - -happyReduce_255 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_255 = happySpecReduce_3 97# happyReduction_255 -happyReduction_255 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut112 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn113 - (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2) - ,snd $ unLoc happy_var_2) - )}}} - -happyReduce_256 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_256 = happySpecReduce_3 97# happyReduction_256 -happyReduction_256 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut112 happy_x_2 of { happy_var_2 -> - happyIn113 - (happy_var_2 - )} - -happyReduce_257 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_257 = happySpecReduce_2 98# happyReduction_257 -happyReduction_257 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut113 happy_x_2 of { happy_var_2 -> - happyIn114 - (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) - ,snd $ unLoc happy_var_2) - )}} - -happyReduce_258 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_258 = happySpecReduce_0 98# happyReduction_258 -happyReduction_258 = happyIn114 - (noLoc ([],nilOL) - ) - -happyReduce_259 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_259 = happySpecReduce_1 99# happyReduction_259 -happyReduction_259 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - happyIn115 - (sLL happy_var_1 happy_var_1 (unitOL (sL1 happy_var_1 (InstD (unLoc happy_var_1)))) - )} - -happyReduce_260 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_260 = happySpecReduce_1 99# happyReduction_260 -happyReduction_260 happy_x_1 - = case happyOut192 happy_x_1 of { happy_var_1 -> - happyIn115 - (sLL happy_var_1 happy_var_1 (unitOL happy_var_1) - )} - -happyReduce_261 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_261 = happyMonadReduce 3# 100# happyReduction_261 -happyReduction_261 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut116 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut115 happy_x_3 of { happy_var_3 -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) - , unLoc happy_var_3)) - else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] - >> return - (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 - ,(snd $ unLoc happy_var_1) `appOL` unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn116 r)) - -happyReduce_262 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_262 = happyMonadReduce 2# 100# happyReduction_262 -happyReduction_262 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut116 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) - ,snd $ unLoc happy_var_1)) - else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] - >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}}) - ) (\r -> happyReturn (happyIn116 r)) - -happyReduce_263 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_263 = happySpecReduce_1 100# happyReduction_263 -happyReduction_263 happy_x_1 - = case happyOut115 happy_x_1 of { happy_var_1 -> - happyIn116 - (sL1 happy_var_1 ([],unLoc happy_var_1) - )} - -happyReduce_264 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_264 = happySpecReduce_0 100# happyReduction_264 -happyReduction_264 = happyIn116 - (noLoc ([],nilOL) - ) - -happyReduce_265 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_265 = happySpecReduce_3 101# happyReduction_265 -happyReduction_265 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut116 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn117 - (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2),snd $ unLoc happy_var_2) - )}}} - -happyReduce_266 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_266 = happySpecReduce_3 101# happyReduction_266 -happyReduction_266 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut116 happy_x_2 of { happy_var_2 -> - happyIn117 - (L (gl happy_var_2) (unLoc happy_var_2) - )} - -happyReduce_267 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_267 = happySpecReduce_2 102# happyReduction_267 -happyReduction_267 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut117 happy_x_2 of { happy_var_2 -> - happyIn118 - (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) - ,(snd $ unLoc happy_var_2)) - )}} - -happyReduce_268 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_268 = happySpecReduce_0 102# happyReduction_268 -happyReduction_268 = happyIn118 - (noLoc ([],nilOL) - ) - -happyReduce_269 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_269 = happyMonadReduce 3# 103# happyReduction_269 -happyReduction_269 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut119 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut192 happy_x_3 of { happy_var_3 -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) - , unitOL happy_var_3)) - else do ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] - >> return ( - let { this = unitOL happy_var_3; - rest = snd $ unLoc happy_var_1; - these = rest `appOL` this } - in rest `seq` this `seq` these `seq` - (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,these))))}}}) - ) (\r -> happyReturn (happyIn119 r)) - -happyReduce_270 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_270 = happyMonadReduce 2# 103# happyReduction_270 -happyReduction_270 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut119 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_2 ((mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) - ,snd $ unLoc happy_var_1))) - else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] - >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}}) - ) (\r -> happyReturn (happyIn119 r)) - -happyReduce_271 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_271 = happySpecReduce_1 103# happyReduction_271 -happyReduction_271 happy_x_1 - = case happyOut192 happy_x_1 of { happy_var_1 -> - happyIn119 - (sL1 happy_var_1 ([], unitOL happy_var_1) - )} - -happyReduce_272 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_272 = happySpecReduce_0 103# happyReduction_272 -happyReduction_272 = happyIn119 - (noLoc ([],nilOL) - ) - -happyReduce_273 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_273 = happySpecReduce_3 104# happyReduction_273 -happyReduction_273 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut119 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn120 - (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2) - ,sL1 happy_var_2 $ snd $ unLoc happy_var_2) - )}}} - -happyReduce_274 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_274 = happySpecReduce_3 104# happyReduction_274 -happyReduction_274 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut119 happy_x_2 of { happy_var_2 -> - happyIn120 - (L (gl happy_var_2) (fst $ unLoc happy_var_2,sL1 happy_var_2 $ snd $ unLoc happy_var_2) - )} - -happyReduce_275 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_275 = happyMonadReduce 1# 105# happyReduction_275 -happyReduction_275 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut120 happy_x_1 of { happy_var_1 -> - ( do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc happy_var_1) - ; return (sL1 happy_var_1 (fst $ unLoc happy_var_1 - ,sL1 happy_var_1 $ HsValBinds val_binds)) })}) - ) (\r -> happyReturn (happyIn121 r)) - -happyReduce_276 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_276 = happySpecReduce_3 105# happyReduction_276 -happyReduction_276 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut251 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn121 - (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3] - ,sL1 happy_var_2 $ HsIPBinds (IPBinds (reverse $ unLoc happy_var_2) - emptyTcEvBinds)) - )}}} - -happyReduce_277 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_277 = happySpecReduce_3 105# happyReduction_277 -happyReduction_277 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut251 happy_x_2 of { happy_var_2 -> - happyIn121 - (L (getLoc happy_var_2) ([] - ,sL1 happy_var_2 $ HsIPBinds (IPBinds (reverse $ unLoc happy_var_2) - emptyTcEvBinds)) - )} - -happyReduce_278 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_278 = happySpecReduce_2 106# happyReduction_278 -happyReduction_278 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut121 happy_x_2 of { happy_var_2 -> - happyIn122 - (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1 : (fst $ unLoc happy_var_2) - ,snd $ unLoc happy_var_2) - )}} - -happyReduce_279 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_279 = happySpecReduce_0 106# happyReduction_279 -happyReduction_279 = happyIn122 - (noLoc ([],noLoc emptyLocalBinds) - ) - -happyReduce_280 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_280 = happyMonadReduce 3# 107# happyReduction_280 -happyReduction_280 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut123 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut124 happy_x_3 of { happy_var_3 -> - ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) - >> return (happy_var_1 `snocOL` happy_var_3))}}}) - ) (\r -> happyReturn (happyIn123 r)) - -happyReduce_281 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_281 = happyMonadReduce 2# 107# happyReduction_281 -happyReduction_281 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut123 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) - >> return happy_var_1)}}) - ) (\r -> happyReturn (happyIn123 r)) - -happyReduce_282 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_282 = happySpecReduce_1 107# happyReduction_282 -happyReduction_282 happy_x_1 - = case happyOut124 happy_x_1 of { happy_var_1 -> - happyIn123 - (unitOL happy_var_1 - )} - -happyReduce_283 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_283 = happySpecReduce_0 107# happyReduction_283 -happyReduction_283 = happyIn123 - (nilOL - ) - -happyReduce_284 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_284 = happyMonadReduce 6# 108# happyReduction_284 -happyReduction_284 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut125 happy_x_2 of { happy_var_2 -> - case happyOut127 happy_x_3 of { happy_var_3 -> - case happyOut201 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut200 happy_x_6 of { happy_var_6 -> - (ams (sLL happy_var_1 happy_var_6 $ (HsRule (L (gl happy_var_1) (getSTRINGs happy_var_1,getSTRING happy_var_1)) - ((snd happy_var_2) `orElse` AlwaysActive) - (snd happy_var_3) happy_var_4 placeHolderNames happy_var_6 - placeHolderNames)) - (mj AnnEqual happy_var_5 : (fst happy_var_2) ++ (fst happy_var_3)))}}}}}}) - ) (\r -> happyReturn (happyIn124 r)) - -happyReduce_285 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_285 = happySpecReduce_0 109# happyReduction_285 -happyReduction_285 = happyIn125 - (([],Nothing) - ) - -happyReduce_286 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_286 = happySpecReduce_1 109# happyReduction_286 -happyReduction_286 happy_x_1 - = case happyOut126 happy_x_1 of { happy_var_1 -> - happyIn125 - ((fst happy_var_1,Just (snd happy_var_1)) - )} - -happyReduce_287 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_287 = happySpecReduce_3 110# happyReduction_287 -happyReduction_287 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn126 - (([mos happy_var_1,mj AnnVal happy_var_2,mcs happy_var_3] - ,ActiveAfter (getINTEGERs happy_var_2) (fromInteger (getINTEGER happy_var_2))) - )}}} - -happyReduce_288 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_288 = happyReduce 4# 110# happyReduction_288 -happyReduction_288 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn126 - (([mos happy_var_1,mj AnnTilde happy_var_2,mj AnnVal happy_var_3,mcs happy_var_4] - ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (getINTEGER happy_var_3))) - ) `HappyStk` happyRest}}}} - -happyReduce_289 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_289 = happySpecReduce_3 110# happyReduction_289 -happyReduction_289 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn126 - (([mos happy_var_1,mj AnnTilde happy_var_2,mcs happy_var_3] - ,NeverActive) - )}}} - -happyReduce_290 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_290 = happySpecReduce_3 111# happyReduction_290 -happyReduction_290 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut128 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn127 - (([mu AnnForall happy_var_1,mj AnnDot happy_var_3],happy_var_2) - )}}} - -happyReduce_291 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_291 = happySpecReduce_0 111# happyReduction_291 -happyReduction_291 = happyIn127 - (([],[]) - ) - -happyReduce_292 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_292 = happySpecReduce_1 112# happyReduction_292 -happyReduction_292 happy_x_1 - = case happyOut129 happy_x_1 of { happy_var_1 -> - happyIn128 - ([happy_var_1] - )} - -happyReduce_293 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_293 = happySpecReduce_2 112# happyReduction_293 -happyReduction_293 happy_x_2 - happy_x_1 - = case happyOut129 happy_x_1 of { happy_var_1 -> - case happyOut128 happy_x_2 of { happy_var_2 -> - happyIn128 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_294 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_294 = happySpecReduce_1 113# happyReduction_294 -happyReduction_294 happy_x_1 - = case happyOut293 happy_x_1 of { happy_var_1 -> - happyIn129 - (sLL happy_var_1 happy_var_1 (RuleBndr happy_var_1) - )} - -happyReduce_295 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_295 = happyMonadReduce 5# 113# happyReduction_295 -happyReduction_295 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut293 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut151 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( ams (sLL happy_var_1 happy_var_5 (RuleBndrSig happy_var_2 - (mkLHsSigWcType happy_var_4))) - [mop happy_var_1,mu AnnDcolon happy_var_3,mcp happy_var_5])}}}}}) - ) (\r -> happyReturn (happyIn129 r)) - -happyReduce_296 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_296 = happyMonadReduce 3# 114# happyReduction_296 -happyReduction_296 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut130 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut131 happy_x_3 of { happy_var_3 -> - ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) - >> return (happy_var_1 `appOL` happy_var_3))}}}) - ) (\r -> happyReturn (happyIn130 r)) - -happyReduce_297 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_297 = happyMonadReduce 2# 114# happyReduction_297 -happyReduction_297 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut130 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) - >> return happy_var_1)}}) - ) (\r -> happyReturn (happyIn130 r)) - -happyReduce_298 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_298 = happySpecReduce_1 114# happyReduction_298 -happyReduction_298 happy_x_1 - = case happyOut131 happy_x_1 of { happy_var_1 -> - happyIn130 - (happy_var_1 - )} - -happyReduce_299 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_299 = happySpecReduce_0 114# happyReduction_299 -happyReduction_299 = happyIn130 - (nilOL - ) - -happyReduce_300 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_300 = happyMonadReduce 2# 115# happyReduction_300 -happyReduction_300 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut260 happy_x_1 of { happy_var_1 -> - case happyOut134 happy_x_2 of { happy_var_2 -> - ( amsu (sLL happy_var_1 happy_var_2 (Warning (unLoc happy_var_1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc happy_var_2))) - (fst $ unLoc happy_var_2))}}) - ) (\r -> happyReturn (happyIn131 r)) - -happyReduce_301 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_301 = happyMonadReduce 3# 116# happyReduction_301 -happyReduction_301 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut132 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut133 happy_x_3 of { happy_var_3 -> - ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) - >> return (happy_var_1 `appOL` happy_var_3))}}}) - ) (\r -> happyReturn (happyIn132 r)) - -happyReduce_302 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_302 = happyMonadReduce 2# 116# happyReduction_302 -happyReduction_302 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut132 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) - >> return happy_var_1)}}) - ) (\r -> happyReturn (happyIn132 r)) - -happyReduce_303 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_303 = happySpecReduce_1 116# happyReduction_303 -happyReduction_303 happy_x_1 - = case happyOut133 happy_x_1 of { happy_var_1 -> - happyIn132 - (happy_var_1 - )} - -happyReduce_304 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_304 = happySpecReduce_0 116# happyReduction_304 -happyReduction_304 = happyIn132 - (nilOL - ) - -happyReduce_305 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_305 = happyMonadReduce 2# 117# happyReduction_305 -happyReduction_305 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut260 happy_x_1 of { happy_var_1 -> - case happyOut134 happy_x_2 of { happy_var_2 -> - ( amsu (sLL happy_var_1 happy_var_2 $ (Warning (unLoc happy_var_1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc happy_var_2))) - (fst $ unLoc happy_var_2))}}) - ) (\r -> happyReturn (happyIn133 r)) - -happyReduce_306 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_306 = happySpecReduce_1 118# happyReduction_306 -happyReduction_306 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn134 - (sL1 happy_var_1 ([],[L (gl happy_var_1) (getStringLiteral happy_var_1)]) - )} - -happyReduce_307 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_307 = happySpecReduce_3 118# happyReduction_307 -happyReduction_307 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut135 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn134 - (sLL happy_var_1 happy_var_3 $ ([mos happy_var_1,mcs happy_var_3],fromOL (unLoc happy_var_2)) - )}}} - -happyReduce_308 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_308 = happyMonadReduce 3# 119# happyReduction_308 -happyReduction_308 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut135 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( addAnnotation (oll $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> - return (sLL happy_var_1 happy_var_3 (unLoc happy_var_1 `snocOL` - (L (gl happy_var_3) (getStringLiteral happy_var_3)))))}}}) - ) (\r -> happyReturn (happyIn135 r)) - -happyReduce_309 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_309 = happySpecReduce_1 119# happyReduction_309 -happyReduction_309 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn135 - (sLL happy_var_1 happy_var_1 (unitOL (L (gl happy_var_1) (getStringLiteral happy_var_1))) - )} - -happyReduce_310 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_310 = happySpecReduce_0 119# happyReduction_310 -happyReduction_310 = happyIn135 - (noLoc nilOL - ) - -happyReduce_311 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_311 = happyMonadReduce 4# 120# happyReduction_311 -happyReduction_311 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut261 happy_x_2 of { happy_var_2 -> - case happyOut209 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 (AnnD $ HsAnnotation - (getANN_PRAGs happy_var_1) - (ValueAnnProvenance happy_var_2) happy_var_3)) - [mo happy_var_1,mc happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn136 r)) - -happyReduce_312 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_312 = happyMonadReduce 5# 120# happyReduction_312 -happyReduction_312 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut278 happy_x_3 of { happy_var_3 -> - case happyOut209 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( ams (sLL happy_var_1 happy_var_5 (AnnD $ HsAnnotation - (getANN_PRAGs happy_var_1) - (TypeAnnProvenance happy_var_3) happy_var_4)) - [mo happy_var_1,mj AnnType happy_var_2,mc happy_var_5])}}}}}) - ) (\r -> happyReturn (happyIn136 r)) - -happyReduce_313 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_313 = happyMonadReduce 4# 120# happyReduction_313 -happyReduction_313 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut209 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 (AnnD $ HsAnnotation - (getANN_PRAGs happy_var_1) - ModuleAnnProvenance happy_var_3)) - [mo happy_var_1,mj AnnModule happy_var_2,mc happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn136 r)) - -happyReduce_314 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_314 = happyMonadReduce 4# 121# happyReduction_314 -happyReduction_314 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut138 happy_x_2 of { happy_var_2 -> - case happyOut139 happy_x_3 of { happy_var_3 -> - case happyOut140 happy_x_4 of { happy_var_4 -> - ( mkImport happy_var_2 happy_var_3 (snd $ unLoc happy_var_4) >>= \i -> - return (sLL happy_var_1 happy_var_4 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_4),i)))}}}}) - ) (\r -> happyReturn (happyIn137 r)) - -happyReduce_315 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_315 = happyMonadReduce 3# 121# happyReduction_315 -happyReduction_315 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut138 happy_x_2 of { happy_var_2 -> - case happyOut140 happy_x_3 of { happy_var_3 -> - ( do { d <- mkImport happy_var_2 (noLoc PlaySafe) (snd $ unLoc happy_var_3); - return (sLL happy_var_1 happy_var_3 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_3),d)) })}}}) - ) (\r -> happyReturn (happyIn137 r)) - -happyReduce_316 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_316 = happyMonadReduce 3# 121# happyReduction_316 -happyReduction_316 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut138 happy_x_2 of { happy_var_2 -> - case happyOut140 happy_x_3 of { happy_var_3 -> - ( mkExport happy_var_2 (snd $ unLoc happy_var_3) >>= \i -> - return (sLL happy_var_1 happy_var_3 (mj AnnExport happy_var_1 : (fst $ unLoc happy_var_3),i) ))}}}) - ) (\r -> happyReturn (happyIn137 r)) - -happyReduce_317 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_317 = happySpecReduce_1 122# happyReduction_317 -happyReduction_317 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn138 - (sLL happy_var_1 happy_var_1 StdCallConv - )} - -happyReduce_318 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_318 = happySpecReduce_1 122# happyReduction_318 -happyReduction_318 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn138 - (sLL happy_var_1 happy_var_1 CCallConv - )} - -happyReduce_319 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_319 = happySpecReduce_1 122# happyReduction_319 -happyReduction_319 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn138 - (sLL happy_var_1 happy_var_1 CApiConv - )} - -happyReduce_320 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_320 = happySpecReduce_1 122# happyReduction_320 -happyReduction_320 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn138 - (sLL happy_var_1 happy_var_1 PrimCallConv - )} - -happyReduce_321 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_321 = happySpecReduce_1 122# happyReduction_321 -happyReduction_321 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn138 - (sLL happy_var_1 happy_var_1 JavaScriptCallConv - )} - -happyReduce_322 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_322 = happySpecReduce_1 123# happyReduction_322 -happyReduction_322 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn139 - (sLL happy_var_1 happy_var_1 PlayRisky - )} - -happyReduce_323 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_323 = happySpecReduce_1 123# happyReduction_323 -happyReduction_323 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn139 - (sLL happy_var_1 happy_var_1 PlaySafe - )} - -happyReduce_324 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_324 = happySpecReduce_1 123# happyReduction_324 -happyReduction_324 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn139 - (sLL happy_var_1 happy_var_1 PlayInterruptible - )} - -happyReduce_325 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_325 = happyReduce 4# 124# happyReduction_325 -happyReduction_325 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut290 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut145 happy_x_4 of { happy_var_4 -> - happyIn140 - (sLL happy_var_1 happy_var_4 ([mu AnnDcolon happy_var_3] - ,(L (getLoc happy_var_1) - (getStringLiteral happy_var_1), happy_var_2, mkLHsSigType happy_var_4)) - ) `HappyStk` happyRest}}}} - -happyReduce_326 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_326 = happySpecReduce_3 124# happyReduction_326 -happyReduction_326 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut290 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut145 happy_x_3 of { happy_var_3 -> - happyIn140 - (sLL happy_var_1 happy_var_3 ([mu AnnDcolon happy_var_2] - ,(noLoc (StringLiteral NoSourceText nilFS), happy_var_1, mkLHsSigType happy_var_3)) - )}}} - -happyReduce_327 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_327 = happySpecReduce_0 125# happyReduction_327 -happyReduction_327 = happyIn141 - (([],Nothing) - ) - -happyReduce_328 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_328 = happySpecReduce_2 125# happyReduction_328 -happyReduction_328 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut144 happy_x_2 of { happy_var_2 -> - happyIn141 - (([mu AnnDcolon happy_var_1],Just happy_var_2) - )}} - -happyReduce_329 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_329 = happySpecReduce_0 126# happyReduction_329 -happyReduction_329 = happyIn142 - (([],Nothing) - ) - -happyReduce_330 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_330 = happySpecReduce_2 126# happyReduction_330 -happyReduction_330 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut161 happy_x_2 of { happy_var_2 -> - happyIn142 - (([mu AnnDcolon happy_var_1],Just happy_var_2) - )}} - -happyReduce_331 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_331 = happySpecReduce_0 127# happyReduction_331 -happyReduction_331 = happyIn143 - (([], Nothing) - ) - -happyReduce_332 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_332 = happySpecReduce_2 127# happyReduction_332 -happyReduction_332 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut271 happy_x_2 of { happy_var_2 -> - happyIn143 - (([mu AnnDcolon happy_var_1], Just happy_var_2) - )}} - -happyReduce_333 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_333 = happySpecReduce_1 128# happyReduction_333 -happyReduction_333 happy_x_1 - = case happyOut151 happy_x_1 of { happy_var_1 -> - happyIn144 - (happy_var_1 - )} - -happyReduce_334 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_334 = happySpecReduce_1 129# happyReduction_334 -happyReduction_334 happy_x_1 - = case happyOut152 happy_x_1 of { happy_var_1 -> - happyIn145 - (happy_var_1 - )} - -happyReduce_335 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_335 = happyMonadReduce 3# 130# happyReduction_335 -happyReduction_335 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut146 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut290 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl $ head $ unLoc happy_var_1) - AnnComma (gl happy_var_2) - >> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}}) - ) (\r -> happyReturn (happyIn146 r)) - -happyReduce_336 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_336 = happySpecReduce_1 130# happyReduction_336 -happyReduction_336 happy_x_1 - = case happyOut290 happy_x_1 of { happy_var_1 -> - happyIn146 - (sL1 happy_var_1 [happy_var_1] - )} - -happyReduce_337 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_337 = happySpecReduce_1 131# happyReduction_337 -happyReduction_337 happy_x_1 - = case happyOut144 happy_x_1 of { happy_var_1 -> - happyIn147 - (unitOL (mkLHsSigType happy_var_1) - )} - -happyReduce_338 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_338 = happyMonadReduce 3# 131# happyReduction_338 -happyReduction_338 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut144 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut147 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) - >> return (unitOL (mkLHsSigType happy_var_1) `appOL` happy_var_3))}}}) - ) (\r -> happyReturn (happyIn147 r)) - -happyReduce_339 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_339 = happySpecReduce_1 132# happyReduction_339 -happyReduction_339 happy_x_1 - = case happyOut149 happy_x_1 of { happy_var_1 -> - happyIn148 - (sL1 happy_var_1 (let (a, str) = unLoc happy_var_1 in (a, HsSrcBang NoSourceText NoSrcUnpack str)) - )} - -happyReduce_340 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_340 = happySpecReduce_1 132# happyReduction_340 -happyReduction_340 happy_x_1 - = case happyOut150 happy_x_1 of { happy_var_1 -> - happyIn148 - (sL1 happy_var_1 (let (a, prag, unpk) = unLoc happy_var_1 in (a, HsSrcBang prag unpk NoSrcStrict)) - )} - -happyReduce_341 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_341 = happySpecReduce_2 132# happyReduction_341 -happyReduction_341 happy_x_2 - happy_x_1 - = case happyOut150 happy_x_1 of { happy_var_1 -> - case happyOut149 happy_x_2 of { happy_var_2 -> - happyIn148 - (sLL happy_var_1 happy_var_2 (let { (a, prag, unpk) = unLoc happy_var_1 - ; (a', str) = unLoc happy_var_2 } - in (a ++ a', HsSrcBang prag unpk str)) - )}} - -happyReduce_342 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_342 = happySpecReduce_1 133# happyReduction_342 -happyReduction_342 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn149 - (sL1 happy_var_1 ([mj AnnBang happy_var_1], SrcStrict) - )} - -happyReduce_343 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_343 = happySpecReduce_1 133# happyReduction_343 -happyReduction_343 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn149 - (sL1 happy_var_1 ([mj AnnTilde happy_var_1], SrcLazy) - )} - -happyReduce_344 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_344 = happySpecReduce_2 134# happyReduction_344 -happyReduction_344 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn150 - (sLL happy_var_1 happy_var_2 ([mo happy_var_1, mc happy_var_2], getUNPACK_PRAGs happy_var_1, SrcUnpack) - )}} - -happyReduce_345 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_345 = happySpecReduce_2 134# happyReduction_345 -happyReduction_345 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn150 - (sLL happy_var_1 happy_var_2 ([mo happy_var_1, mc happy_var_2], getNOUNPACK_PRAGs happy_var_1, SrcNoUnpack) - )}} - -happyReduce_346 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_346 = happyMonadReduce 4# 135# happyReduction_346 -happyReduction_346 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut167 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut151 happy_x_4 of { happy_var_4 -> - ( hintExplicitForall (getLoc happy_var_1) >> - ams (sLL happy_var_1 happy_var_4 $ - HsForAllTy { hst_bndrs = happy_var_2 - , hst_body = happy_var_4 }) - [mu AnnForall happy_var_1, mj AnnDot happy_var_3])}}}}) - ) (\r -> happyReturn (happyIn151 r)) - -happyReduce_347 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_347 = happyMonadReduce 3# 135# happyReduction_347 -happyReduction_347 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut153 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut151 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) - >> return (sLL happy_var_1 happy_var_3 $ - HsQualTy { hst_ctxt = happy_var_1 - , hst_body = happy_var_3 }))}}}) - ) (\r -> happyReturn (happyIn151 r)) - -happyReduce_348 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_348 = happyMonadReduce 3# 135# happyReduction_348 -happyReduction_348 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut253 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut155 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (HsIParamTy happy_var_1 happy_var_3)) - [mu AnnDcolon happy_var_2])}}}) - ) (\r -> happyReturn (happyIn151 r)) - -happyReduce_349 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_349 = happySpecReduce_1 135# happyReduction_349 -happyReduction_349 happy_x_1 - = case happyOut155 happy_x_1 of { happy_var_1 -> - happyIn151 - (happy_var_1 - )} - -happyReduce_350 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_350 = happyMonadReduce 4# 136# happyReduction_350 -happyReduction_350 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut167 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut152 happy_x_4 of { happy_var_4 -> - ( hintExplicitForall (getLoc happy_var_1) >> - ams (sLL happy_var_1 happy_var_4 $ - HsForAllTy { hst_bndrs = happy_var_2 - , hst_body = happy_var_4 }) - [mu AnnForall happy_var_1,mj AnnDot happy_var_3])}}}}) - ) (\r -> happyReturn (happyIn152 r)) - -happyReduce_351 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_351 = happyMonadReduce 3# 136# happyReduction_351 -happyReduction_351 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut153 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut152 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) - >> return (sLL happy_var_1 happy_var_3 $ - HsQualTy { hst_ctxt = happy_var_1 - , hst_body = happy_var_3 }))}}}) - ) (\r -> happyReturn (happyIn152 r)) - -happyReduce_352 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_352 = happyMonadReduce 3# 136# happyReduction_352 -happyReduction_352 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut253 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut155 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (HsIParamTy happy_var_1 happy_var_3)) - [mu AnnDcolon happy_var_2])}}}) - ) (\r -> happyReturn (happyIn152 r)) - -happyReduce_353 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_353 = happySpecReduce_1 136# happyReduction_353 -happyReduction_353 happy_x_1 - = case happyOut156 happy_x_1 of { happy_var_1 -> - happyIn152 - (happy_var_1 - )} - -happyReduce_354 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_354 = happyMonadReduce 1# 137# happyReduction_354 -happyReduction_354 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut157 happy_x_1 of { happy_var_1 -> - ( do { (anns,ctx) <- checkContext happy_var_1 - ; if null (unLoc ctx) - then addAnnotation (gl happy_var_1) AnnUnit (gl happy_var_1) - else return () - ; ams ctx anns - })}) - ) (\r -> happyReturn (happyIn153 r)) - -happyReduce_355 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_355 = happyMonadReduce 1# 138# happyReduction_355 -happyReduction_355 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut158 happy_x_1 of { happy_var_1 -> - ( do { ty <- splitTilde happy_var_1 - ; (anns,ctx) <- checkContext ty - ; if null (unLoc ctx) - then addAnnotation (gl ty) AnnUnit (gl ty) - else return () - ; ams ctx anns - })}) - ) (\r -> happyReturn (happyIn154 r)) - -happyReduce_356 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_356 = happySpecReduce_1 139# happyReduction_356 -happyReduction_356 happy_x_1 - = case happyOut157 happy_x_1 of { happy_var_1 -> - happyIn155 - (happy_var_1 - )} - -happyReduce_357 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_357 = happyMonadReduce 3# 139# happyReduction_357 -happyReduction_357 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut157 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut151 happy_x_3 of { happy_var_3 -> - ( ams happy_var_1 [mu AnnRarrow happy_var_2] -- See note [GADT decl discards annotations] - >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy happy_var_1 happy_var_3) - [mu AnnRarrow happy_var_2])}}}) - ) (\r -> happyReturn (happyIn155 r)) - -happyReduce_358 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_358 = happySpecReduce_1 140# happyReduction_358 -happyReduction_358 happy_x_1 - = case happyOut157 happy_x_1 of { happy_var_1 -> - happyIn156 - (happy_var_1 - )} - -happyReduce_359 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_359 = happySpecReduce_2 140# happyReduction_359 -happyReduction_359 happy_x_2 - happy_x_1 - = case happyOut157 happy_x_1 of { happy_var_1 -> - case happyOut312 happy_x_2 of { happy_var_2 -> - happyIn156 - (sLL happy_var_1 happy_var_2 $ HsDocTy happy_var_1 happy_var_2 - )}} - -happyReduce_360 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_360 = happyMonadReduce 3# 140# happyReduction_360 -happyReduction_360 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut157 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut152 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsFunTy happy_var_1 happy_var_3) - [mu AnnRarrow happy_var_2])}}}) - ) (\r -> happyReturn (happyIn156 r)) - -happyReduce_361 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_361 = happyMonadReduce 4# 140# happyReduction_361 -happyReduction_361 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut157 happy_x_1 of { happy_var_1 -> - case happyOut312 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut152 happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 $ - HsFunTy (L (comb2 happy_var_1 happy_var_2) (HsDocTy happy_var_1 happy_var_2)) - happy_var_4) - [mu AnnRarrow happy_var_3])}}}}) - ) (\r -> happyReturn (happyIn156 r)) - -happyReduce_362 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_362 = happyMonadReduce 1# 141# happyReduction_362 -happyReduction_362 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut159 happy_x_1 of { happy_var_1 -> - ( splitTildeApps (reverse (unLoc happy_var_1)) >>= - \ts -> return $ sL1 happy_var_1 $ HsAppsTy ts)}) - ) (\r -> happyReturn (happyIn157 r)) - -happyReduce_363 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_363 = happySpecReduce_2 142# happyReduction_363 -happyReduction_363 happy_x_2 - happy_x_1 - = case happyOut158 happy_x_1 of { happy_var_1 -> - case happyOut161 happy_x_2 of { happy_var_2 -> - happyIn158 - (sLL happy_var_1 happy_var_2 $ HsAppTy happy_var_1 happy_var_2 - )}} - -happyReduce_364 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_364 = happySpecReduce_1 142# happyReduction_364 -happyReduction_364 happy_x_1 - = case happyOut161 happy_x_1 of { happy_var_1 -> - happyIn158 - (happy_var_1 - )} - -happyReduce_365 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_365 = happySpecReduce_1 143# happyReduction_365 -happyReduction_365 happy_x_1 - = case happyOut160 happy_x_1 of { happy_var_1 -> - happyIn159 - (sL1 happy_var_1 [happy_var_1] - )} - -happyReduce_366 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_366 = happySpecReduce_2 143# happyReduction_366 -happyReduction_366 happy_x_2 - happy_x_1 - = case happyOut159 happy_x_1 of { happy_var_1 -> - case happyOut160 happy_x_2 of { happy_var_2 -> - happyIn159 - (sLL happy_var_1 happy_var_2 $ happy_var_2 : (unLoc happy_var_1) - )}} - -happyReduce_367 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_367 = happySpecReduce_1 144# happyReduction_367 -happyReduction_367 happy_x_1 - = case happyOut161 happy_x_1 of { happy_var_1 -> - happyIn160 - (sL1 happy_var_1 $ HsAppPrefix happy_var_1 - )} - -happyReduce_368 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_368 = happySpecReduce_1 144# happyReduction_368 -happyReduction_368 happy_x_1 - = case happyOut275 happy_x_1 of { happy_var_1 -> - happyIn160 - (sL1 happy_var_1 $ HsAppInfix happy_var_1 - )} - -happyReduce_369 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_369 = happySpecReduce_1 144# happyReduction_369 -happyReduction_369 happy_x_1 - = case happyOut288 happy_x_1 of { happy_var_1 -> - happyIn160 - (sL1 happy_var_1 $ HsAppInfix happy_var_1 - )} - -happyReduce_370 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_370 = happyMonadReduce 2# 144# happyReduction_370 -happyReduction_370 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut270 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsAppInfix happy_var_2) - [mj AnnSimpleQuote happy_var_1])}}) - ) (\r -> happyReturn (happyIn160 r)) - -happyReduce_371 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_371 = happyMonadReduce 2# 144# happyReduction_371 -happyReduction_371 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut282 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsAppInfix happy_var_2) - [mj AnnSimpleQuote happy_var_1])}}) - ) (\r -> happyReturn (happyIn160 r)) - -happyReduce_372 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_372 = happySpecReduce_1 145# happyReduction_372 -happyReduction_372 happy_x_1 - = case happyOut272 happy_x_1 of { happy_var_1 -> - happyIn161 - (sL1 happy_var_1 (HsTyVar NotPromoted happy_var_1) - )} - -happyReduce_373 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_373 = happySpecReduce_1 145# happyReduction_373 -happyReduction_373 happy_x_1 - = case happyOut287 happy_x_1 of { happy_var_1 -> - happyIn161 - (sL1 happy_var_1 (HsTyVar NotPromoted happy_var_1) - )} - -happyReduce_374 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_374 = happyMonadReduce 2# 145# happyReduction_374 -happyReduction_374 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut148 happy_x_1 of { happy_var_1 -> - case happyOut161 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 (HsBangTy (snd $ unLoc happy_var_1) happy_var_2)) - (fst $ unLoc happy_var_1))}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_375 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_375 = happyMonadReduce 3# 145# happyReduction_375 -happyReduction_375 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut183 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amms (checkRecordSyntax - (sLL happy_var_1 happy_var_3 $ HsRecTy happy_var_2)) - -- Constructor sigs only - [moc happy_var_1,mcc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_376 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_376 = happyMonadReduce 2# 145# happyReduction_376 -happyReduction_376 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy - HsBoxedOrConstraintTuple []) - [mop happy_var_1,mcp happy_var_2])}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_377 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_377 = happyMonadReduce 5# 145# happyReduction_377 -happyReduction_377 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut151 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut165 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( addAnnotation (gl happy_var_2) AnnComma - (gl happy_var_3) >> - ams (sLL happy_var_1 happy_var_5 $ HsTupleTy - HsBoxedOrConstraintTuple (happy_var_2 : happy_var_4)) - [mop happy_var_1,mcp happy_var_5])}}}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_378 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_378 = happyMonadReduce 2# 145# happyReduction_378 -happyReduction_378 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy HsUnboxedTuple []) - [mo happy_var_1,mc happy_var_2])}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_379 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_379 = happyMonadReduce 3# 145# happyReduction_379 -happyReduction_379 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut165 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsTupleTy HsUnboxedTuple happy_var_2) - [mo happy_var_1,mc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_380 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_380 = happyMonadReduce 3# 145# happyReduction_380 -happyReduction_380 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut166 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsSumTy happy_var_2) - [mo happy_var_1,mc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_381 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_381 = happyMonadReduce 3# 145# happyReduction_381 -happyReduction_381 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut151 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsListTy happy_var_2) [mos happy_var_1,mcs happy_var_3])}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_382 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_382 = happyMonadReduce 3# 145# happyReduction_382 -happyReduction_382 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut151 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsPArrTy happy_var_2) [mo happy_var_1,mc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_383 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_383 = happyMonadReduce 3# 145# happyReduction_383 -happyReduction_383 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut151 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsParTy happy_var_2) [mop happy_var_1,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_384 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_384 = happyMonadReduce 5# 145# happyReduction_384 -happyReduction_384 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut151 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut173 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( ams (sLL happy_var_1 happy_var_5 $ HsKindSig happy_var_2 happy_var_4) - [mop happy_var_1,mu AnnDcolon happy_var_3,mcp happy_var_5])}}}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_385 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_385 = happySpecReduce_1 145# happyReduction_385 -happyReduction_385 happy_x_1 - = case happyOut199 happy_x_1 of { happy_var_1 -> - happyIn161 - (sL1 happy_var_1 (HsSpliceTy (unLoc happy_var_1) placeHolderKind) - )} - -happyReduce_386 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_386 = happyMonadReduce 3# 145# happyReduction_386 -happyReduction_386 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ mkHsSpliceTy HasParens happy_var_2) - [mj AnnOpenPE happy_var_1,mj AnnCloseP happy_var_3])}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_387 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_387 = happyMonadReduce 1# 145# happyReduction_387 -happyReduction_387 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - (ams (sLL happy_var_1 happy_var_1 $ mkHsSpliceTy HasDollar $ sL1 happy_var_1 $ HsVar $ - (sL1 happy_var_1 (mkUnqual varName (getTH_ID_SPLICE happy_var_1)))) - [mj AnnThIdSplice happy_var_1])}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_388 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_388 = happyMonadReduce 2# 145# happyReduction_388 -happyReduction_388 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut262 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsTyVar Promoted happy_var_2) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_389 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_389 = happyMonadReduce 6# 145# happyReduction_389 -happyReduction_389 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut151 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut165 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { happy_var_6 -> - ( addAnnotation (gl happy_var_3) AnnComma (gl happy_var_4) >> - ams (sLL happy_var_1 happy_var_6 $ HsExplicitTupleTy [] (happy_var_3 : happy_var_5)) - [mj AnnSimpleQuote happy_var_1,mop happy_var_2,mcp happy_var_6])}}}}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_390 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_390 = happyMonadReduce 4# 145# happyReduction_390 -happyReduction_390 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut164 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 $ HsExplicitListTy Promoted - placeHolderKind happy_var_3) - [mj AnnSimpleQuote happy_var_1,mos happy_var_2,mcs happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_391 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_391 = happyMonadReduce 2# 145# happyReduction_391 -happyReduction_391 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut290 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsTyVar Promoted happy_var_2) - [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_392 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_392 = happyMonadReduce 5# 145# happyReduction_392 -happyReduction_392 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut151 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut165 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( addAnnotation (gl happy_var_2) AnnComma - (gl happy_var_3) >> - ams (sLL happy_var_1 happy_var_5 $ HsExplicitListTy NotPromoted - placeHolderKind (happy_var_2 : happy_var_4)) - [mos happy_var_1,mcs happy_var_5])}}}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_393 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_393 = happySpecReduce_1 145# happyReduction_393 -happyReduction_393 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn161 - (sLL happy_var_1 happy_var_1 $ HsTyLit $ HsNumTy (getINTEGERs happy_var_1) - (getINTEGER happy_var_1) - )} - -happyReduce_394 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_394 = happySpecReduce_1 145# happyReduction_394 -happyReduction_394 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn161 - (sLL happy_var_1 happy_var_1 $ HsTyLit $ HsStrTy (getSTRINGs happy_var_1) - (getSTRING happy_var_1) - )} - -happyReduce_395 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_395 = happySpecReduce_1 145# happyReduction_395 -happyReduction_395 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn161 - (sL1 happy_var_1 $ mkAnonWildCardTy - )} - -happyReduce_396 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_396 = happySpecReduce_1 146# happyReduction_396 -happyReduction_396 happy_x_1 - = case happyOut144 happy_x_1 of { happy_var_1 -> - happyIn162 - (mkLHsSigType happy_var_1 - )} - -happyReduce_397 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_397 = happySpecReduce_1 147# happyReduction_397 -happyReduction_397 happy_x_1 - = case happyOut156 happy_x_1 of { happy_var_1 -> - happyIn163 - ([mkLHsSigType happy_var_1] - )} - -happyReduce_398 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_398 = happyMonadReduce 3# 147# happyReduction_398 -happyReduction_398 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut156 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut163 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) - >> return (mkLHsSigType happy_var_1 : happy_var_3))}}}) - ) (\r -> happyReturn (happyIn163 r)) - -happyReduce_399 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_399 = happySpecReduce_1 148# happyReduction_399 -happyReduction_399 happy_x_1 - = case happyOut165 happy_x_1 of { happy_var_1 -> - happyIn164 - (happy_var_1 - )} - -happyReduce_400 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_400 = happySpecReduce_0 148# happyReduction_400 -happyReduction_400 = happyIn164 - ([] - ) - -happyReduce_401 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_401 = happySpecReduce_1 149# happyReduction_401 -happyReduction_401 happy_x_1 - = case happyOut151 happy_x_1 of { happy_var_1 -> - happyIn165 - ([happy_var_1] - )} - -happyReduce_402 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_402 = happyMonadReduce 3# 149# happyReduction_402 -happyReduction_402 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut151 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut165 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) - >> return (happy_var_1 : happy_var_3))}}}) - ) (\r -> happyReturn (happyIn165 r)) - -happyReduce_403 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_403 = happyMonadReduce 3# 150# happyReduction_403 -happyReduction_403 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut151 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut151 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) AnnVbar (gl happy_var_2) - >> return [happy_var_1,happy_var_3])}}}) - ) (\r -> happyReturn (happyIn166 r)) - -happyReduce_404 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_404 = happyMonadReduce 3# 150# happyReduction_404 -happyReduction_404 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut151 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut166 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) AnnVbar (gl happy_var_2) - >> return (happy_var_1 : happy_var_3))}}}) - ) (\r -> happyReturn (happyIn166 r)) - -happyReduce_405 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_405 = happySpecReduce_2 151# happyReduction_405 -happyReduction_405 happy_x_2 - happy_x_1 - = case happyOut168 happy_x_1 of { happy_var_1 -> - case happyOut167 happy_x_2 of { happy_var_2 -> - happyIn167 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_406 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_406 = happySpecReduce_0 151# happyReduction_406 -happyReduction_406 = happyIn167 - ([] - ) - -happyReduce_407 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_407 = happySpecReduce_1 152# happyReduction_407 -happyReduction_407 happy_x_1 - = case happyOut287 happy_x_1 of { happy_var_1 -> - happyIn168 - (sL1 happy_var_1 (UserTyVar happy_var_1) - )} - -happyReduce_408 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_408 = happyMonadReduce 5# 152# happyReduction_408 -happyReduction_408 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut287 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut173 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( ams (sLL happy_var_1 happy_var_5 (KindedTyVar happy_var_2 happy_var_4)) - [mop happy_var_1,mu AnnDcolon happy_var_3 - ,mcp happy_var_5])}}}}}) - ) (\r -> happyReturn (happyIn168 r)) - -happyReduce_409 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_409 = happySpecReduce_0 153# happyReduction_409 -happyReduction_409 = happyIn169 - (noLoc ([],[]) - ) - -happyReduce_410 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_410 = happySpecReduce_2 153# happyReduction_410 -happyReduction_410 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut170 happy_x_2 of { happy_var_2 -> - happyIn169 - ((sLL happy_var_1 happy_var_2 ([mj AnnVbar happy_var_1] - ,reverse (unLoc happy_var_2))) - )}} - -happyReduce_411 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_411 = happyMonadReduce 3# 154# happyReduction_411 -happyReduction_411 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut170 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut171 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) - >> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}}) - ) (\r -> happyReturn (happyIn170 r)) - -happyReduce_412 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_412 = happySpecReduce_1 154# happyReduction_412 -happyReduction_412 happy_x_1 - = case happyOut171 happy_x_1 of { happy_var_1 -> - happyIn170 - (sL1 happy_var_1 [happy_var_1] - )} - -happyReduce_413 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_413 = happyMonadReduce 3# 155# happyReduction_413 -happyReduction_413 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut172 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut172 happy_x_3 of { happy_var_3 -> - ( ams (L (comb3 happy_var_1 happy_var_2 happy_var_3) - (reverse (unLoc happy_var_1), reverse (unLoc happy_var_3))) - [mu AnnRarrow happy_var_2])}}}) - ) (\r -> happyReturn (happyIn171 r)) - -happyReduce_414 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_414 = happySpecReduce_0 156# happyReduction_414 -happyReduction_414 = happyIn172 - (noLoc [] - ) - -happyReduce_415 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_415 = happySpecReduce_2 156# happyReduction_415 -happyReduction_415 happy_x_2 - happy_x_1 - = case happyOut172 happy_x_1 of { happy_var_1 -> - case happyOut287 happy_x_2 of { happy_var_2 -> - happyIn172 - (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) - )}} - -happyReduce_416 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_416 = happySpecReduce_1 157# happyReduction_416 -happyReduction_416 happy_x_1 - = case happyOut151 happy_x_1 of { happy_var_1 -> - happyIn173 - (happy_var_1 - )} - -happyReduce_417 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_417 = happyReduce 4# 158# happyReduction_417 -happyReduction_417 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut175 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn174 - (L (comb2 happy_var_1 happy_var_3) - ([mj AnnWhere happy_var_1 - ,moc happy_var_2 - ,mcc happy_var_4] - , unLoc happy_var_3) - ) `HappyStk` happyRest}}}} - -happyReduce_418 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_418 = happyReduce 4# 158# happyReduction_418 -happyReduction_418 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut175 happy_x_3 of { happy_var_3 -> - happyIn174 - (L (comb2 happy_var_1 happy_var_3) - ([mj AnnWhere happy_var_1] - , unLoc happy_var_3) - ) `HappyStk` happyRest}} - -happyReduce_419 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_419 = happySpecReduce_0 158# happyReduction_419 -happyReduction_419 = happyIn174 - (noLoc ([],[]) - ) - -happyReduce_420 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_420 = happyMonadReduce 3# 159# happyReduction_420 -happyReduction_420 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut176 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut175 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) AnnSemi (gl happy_var_2) - >> return (L (comb2 happy_var_1 happy_var_3) (happy_var_1 : unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn175 r)) - -happyReduce_421 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_421 = happySpecReduce_1 159# happyReduction_421 -happyReduction_421 happy_x_1 - = case happyOut176 happy_x_1 of { happy_var_1 -> - happyIn175 - (L (gl happy_var_1) [happy_var_1] - )} - -happyReduce_422 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_422 = happySpecReduce_0 159# happyReduction_422 -happyReduction_422 = happyIn175 - (noLoc [] - ) - -happyReduce_423 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_423 = happyMonadReduce 3# 160# happyReduction_423 -happyReduction_423 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut317 happy_x_1 of { happy_var_1 -> - case happyOut177 happy_x_3 of { happy_var_3 -> - ( return $ addConDoc happy_var_3 happy_var_1)}}) - ) (\r -> happyReturn (happyIn176 r)) - -happyReduce_424 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_424 = happyMonadReduce 1# 160# happyReduction_424 -happyReduction_424 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut177 happy_x_1 of { happy_var_1 -> - ( return happy_var_1)}) - ) (\r -> happyReturn (happyIn176 r)) - -happyReduce_425 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_425 = happyMonadReduce 3# 161# happyReduction_425 -happyReduction_425 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut266 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut144 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (mkGadtDecl (unLoc happy_var_1) (mkLHsSigType happy_var_3))) - [mu AnnDcolon happy_var_2])}}}) - ) (\r -> happyReturn (happyIn177 r)) - -happyReduce_426 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_426 = happySpecReduce_3 162# happyReduction_426 -happyReduction_426 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut317 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut179 happy_x_3 of { happy_var_3 -> - happyIn178 - (L (comb2 happy_var_2 happy_var_3) ([mj AnnEqual happy_var_2] - ,addConDocs (unLoc happy_var_3) happy_var_1) - )}}} - -happyReduce_427 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_427 = happyMonadReduce 5# 163# happyReduction_427 -happyReduction_427 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut179 happy_x_1 of { happy_var_1 -> - case happyOut317 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut316 happy_x_4 of { happy_var_4 -> - case happyOut180 happy_x_5 of { happy_var_5 -> - ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnVbar (gl happy_var_3) - >> return (sLL happy_var_1 happy_var_5 (addConDoc happy_var_5 happy_var_2 : addConDocFirst (unLoc happy_var_1) happy_var_4)))}}}}}) - ) (\r -> happyReturn (happyIn179 r)) - -happyReduce_428 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_428 = happySpecReduce_1 163# happyReduction_428 -happyReduction_428 happy_x_1 - = case happyOut180 happy_x_1 of { happy_var_1 -> - happyIn179 - (sL1 happy_var_1 [happy_var_1] - )} - -happyReduce_429 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_429 = happyMonadReduce 6# 164# happyReduction_429 -happyReduction_429 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut317 happy_x_1 of { happy_var_1 -> - case happyOut181 happy_x_2 of { happy_var_2 -> - case happyOut154 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut182 happy_x_5 of { happy_var_5 -> - case happyOut316 happy_x_6 of { happy_var_6 -> - ( ams (let (con,details) = unLoc happy_var_5 in - addConDoc (L (comb4 happy_var_2 happy_var_3 happy_var_4 happy_var_5) (mkConDeclH98 con - (snd $ unLoc happy_var_2) happy_var_3 details)) - (happy_var_1 `mplus` happy_var_6)) - (mu AnnDarrow happy_var_4:(fst $ unLoc happy_var_2)))}}}}}}) - ) (\r -> happyReturn (happyIn180 r)) - -happyReduce_430 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_430 = happyMonadReduce 4# 164# happyReduction_430 -happyReduction_430 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut317 happy_x_1 of { happy_var_1 -> - case happyOut181 happy_x_2 of { happy_var_2 -> - case happyOut182 happy_x_3 of { happy_var_3 -> - case happyOut316 happy_x_4 of { happy_var_4 -> - ( ams ( let (con,details) = unLoc happy_var_3 in - addConDoc (L (comb2 happy_var_2 happy_var_3) (mkConDeclH98 con - (snd $ unLoc happy_var_2) (noLoc []) details)) - (happy_var_1 `mplus` happy_var_4)) - (fst $ unLoc happy_var_2))}}}}) - ) (\r -> happyReturn (happyIn180 r)) - -happyReduce_431 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_431 = happySpecReduce_3 165# happyReduction_431 -happyReduction_431 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut167 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn181 - (sLL happy_var_1 happy_var_3 ([mu AnnForall happy_var_1,mj AnnDot happy_var_3], Just happy_var_2) - )}}} - -happyReduce_432 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_432 = happySpecReduce_0 165# happyReduction_432 -happyReduction_432 = happyIn181 - (noLoc ([], Nothing) - ) - -happyReduce_433 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_433 = happyMonadReduce 1# 166# happyReduction_433 -happyReduction_433 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut158 happy_x_1 of { happy_var_1 -> - ( do { c <- splitCon happy_var_1 - ; return $ sLL happy_var_1 happy_var_1 c })}) - ) (\r -> happyReturn (happyIn182 r)) - -happyReduce_434 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_434 = happyMonadReduce 3# 166# happyReduction_434 -happyReduction_434 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut158 happy_x_1 of { happy_var_1 -> - case happyOut269 happy_x_2 of { happy_var_2 -> - case happyOut158 happy_x_3 of { happy_var_3 -> - ( do { ty <- splitTilde happy_var_1 - ; return $ sLL happy_var_1 happy_var_3 (happy_var_2, InfixCon ty happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn182 r)) - -happyReduce_435 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_435 = happySpecReduce_0 167# happyReduction_435 -happyReduction_435 = happyIn183 - ([] - ) - -happyReduce_436 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_436 = happySpecReduce_1 167# happyReduction_436 -happyReduction_436 happy_x_1 - = case happyOut184 happy_x_1 of { happy_var_1 -> - happyIn183 - (happy_var_1 - )} - -happyReduce_437 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_437 = happyMonadReduce 5# 168# happyReduction_437 -happyReduction_437 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut185 happy_x_1 of { happy_var_1 -> - case happyOut317 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut316 happy_x_4 of { happy_var_4 -> - case happyOut184 happy_x_5 of { happy_var_5 -> - ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_3) >> - return ((addFieldDoc happy_var_1 happy_var_4) : addFieldDocs happy_var_5 happy_var_2))}}}}}) - ) (\r -> happyReturn (happyIn184 r)) - -happyReduce_438 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_438 = happySpecReduce_1 168# happyReduction_438 -happyReduction_438 happy_x_1 - = case happyOut185 happy_x_1 of { happy_var_1 -> - happyIn184 - ([happy_var_1] - )} - -happyReduce_439 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_439 = happyMonadReduce 5# 169# happyReduction_439 -happyReduction_439 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut317 happy_x_1 of { happy_var_1 -> - case happyOut146 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut151 happy_x_4 of { happy_var_4 -> - case happyOut316 happy_x_5 of { happy_var_5 -> - ( ams (L (comb2 happy_var_2 happy_var_4) - (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc ln PlaceHolder) (unLoc happy_var_2))) happy_var_4 (happy_var_1 `mplus` happy_var_5))) - [mu AnnDcolon happy_var_3])}}}}}) - ) (\r -> happyReturn (happyIn185 r)) - -happyReduce_440 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_440 = happySpecReduce_0 170# happyReduction_440 -happyReduction_440 = happyIn186 - (noLoc [] - ) - -happyReduce_441 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_441 = happySpecReduce_1 170# happyReduction_441 -happyReduction_441 happy_x_1 - = case happyOut187 happy_x_1 of { happy_var_1 -> - happyIn186 - (happy_var_1 - )} - -happyReduce_442 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_442 = happySpecReduce_2 171# happyReduction_442 -happyReduction_442 happy_x_2 - happy_x_1 - = case happyOut187 happy_x_1 of { happy_var_1 -> - case happyOut188 happy_x_2 of { happy_var_2 -> - happyIn187 - (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 - )}} - -happyReduce_443 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_443 = happySpecReduce_1 171# happyReduction_443 -happyReduction_443 happy_x_1 - = case happyOut188 happy_x_1 of { happy_var_1 -> - happyIn187 - (sLL happy_var_1 happy_var_1 [happy_var_1] - )} - -happyReduce_444 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_444 = happyMonadReduce 3# 172# happyReduction_444 -happyReduction_444 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut82 happy_x_2 of { happy_var_2 -> - case happyOut277 happy_x_3 of { happy_var_3 -> - ( let { full_loc = comb2 happy_var_1 happy_var_3 } - in ams (L full_loc $ HsDerivingClause happy_var_2 $ L full_loc - [mkLHsSigType happy_var_3]) - [mj AnnDeriving happy_var_1])}}}) - ) (\r -> happyReturn (happyIn188 r)) - -happyReduce_445 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_445 = happyMonadReduce 4# 172# happyReduction_445 -happyReduction_445 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut82 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( let { full_loc = comb2 happy_var_1 happy_var_4 } - in ams (L full_loc $ HsDerivingClause happy_var_2 $ L full_loc []) - [mj AnnDeriving happy_var_1,mop happy_var_3,mcp happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn188 r)) - -happyReduce_446 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_446 = happyMonadReduce 5# 172# happyReduction_446 -happyReduction_446 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut82 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut163 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( let { full_loc = comb2 happy_var_1 happy_var_5 } - in ams (L full_loc $ HsDerivingClause happy_var_2 $ L full_loc happy_var_4) - [mj AnnDeriving happy_var_1,mop happy_var_3,mcp happy_var_5])}}}}}) - ) (\r -> happyReturn (happyIn188 r)) - -happyReduce_447 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_447 = happySpecReduce_1 173# happyReduction_447 -happyReduction_447 happy_x_1 - = case happyOut190 happy_x_1 of { happy_var_1 -> - happyIn189 - (sL1 happy_var_1 (DocD (unLoc happy_var_1)) - )} - -happyReduce_448 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_448 = happySpecReduce_1 174# happyReduction_448 -happyReduction_448 happy_x_1 - = case happyOut311 happy_x_1 of { happy_var_1 -> - happyIn190 - (sL1 happy_var_1 (DocCommentNext (unLoc happy_var_1)) - )} - -happyReduce_449 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_449 = happySpecReduce_1 174# happyReduction_449 -happyReduction_449 happy_x_1 - = case happyOut312 happy_x_1 of { happy_var_1 -> - happyIn190 - (sL1 happy_var_1 (DocCommentPrev (unLoc happy_var_1)) - )} - -happyReduce_450 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_450 = happySpecReduce_1 174# happyReduction_450 -happyReduction_450 happy_x_1 - = case happyOut313 happy_x_1 of { happy_var_1 -> - happyIn190 - (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> DocCommentNamed n doc) - )} - -happyReduce_451 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_451 = happySpecReduce_1 174# happyReduction_451 -happyReduction_451 happy_x_1 - = case happyOut314 happy_x_1 of { happy_var_1 -> - happyIn190 - (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> DocGroup n doc) - )} - -happyReduce_452 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_452 = happySpecReduce_1 175# happyReduction_452 -happyReduction_452 happy_x_1 - = case happyOut196 happy_x_1 of { happy_var_1 -> - happyIn191 - (happy_var_1 - )} - -happyReduce_453 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_453 = happyMonadReduce 3# 175# happyReduction_453 -happyReduction_453 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut209 happy_x_2 of { happy_var_2 -> - case happyOut193 happy_x_3 of { happy_var_3 -> - ( do { let { e = sLL happy_var_1 happy_var_2 (SectionR (sL1 happy_var_1 (HsVar (sL1 happy_var_1 bang_RDR))) happy_var_2) - -- Turn it all into an expression so that - -- checkPattern can check that bangs are enabled - ; l = comb2 happy_var_1 happy_var_3 }; - (ann, r) <- checkValDef empty SrcStrict e Nothing happy_var_3 ; - -- Depending upon what the pattern looks like we might get either - -- a FunBind or PatBind back from checkValDef. See Note - -- [Varieties of binding pattern matches] - case r of { - (FunBind n _ _ _ _) -> - ams (L l ()) [mj AnnFunId n] >> return () ; - (PatBind (L lh _lhs) _rhs _ _ _) -> - ams (L lh ()) [] >> return () } ; - - _ <- ams (L l ()) (ann ++ fst (unLoc happy_var_3) ++ [mj AnnBang happy_var_1]) ; - return $! (sL l $ ValD r) })}}}) - ) (\r -> happyReturn (happyIn191 r)) - -happyReduce_454 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_454 = happyMonadReduce 3# 175# happyReduction_454 -happyReduction_454 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut202 happy_x_1 of { happy_var_1 -> - case happyOut141 happy_x_2 of { happy_var_2 -> - case happyOut193 happy_x_3 of { happy_var_3 -> - ( do { (ann,r) <- checkValDef empty NoSrcStrict happy_var_1 (snd happy_var_2) happy_var_3; - let { l = comb2 happy_var_1 happy_var_3 }; - -- Depending upon what the pattern looks like we might get either - -- a FunBind or PatBind back from checkValDef. See Note - -- [Varieties of binding pattern matches] - case r of { - (FunBind n _ _ _ _) -> - ams (L l ()) (mj AnnFunId n:(fst happy_var_2)) >> return () ; - (PatBind (L lh _lhs) _rhs _ _ _) -> - ams (L lh ()) (fst happy_var_2) >> return () } ; - _ <- ams (L l ()) (ann ++ (fst $ unLoc happy_var_3)); - return $! (sL l $ ValD r) })}}}) - ) (\r -> happyReturn (happyIn191 r)) - -happyReduce_455 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_455 = happySpecReduce_1 175# happyReduction_455 -happyReduction_455 happy_x_1 - = case happyOut105 happy_x_1 of { happy_var_1 -> - happyIn191 - (happy_var_1 - )} - -happyReduce_456 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_456 = happySpecReduce_1 175# happyReduction_456 -happyReduction_456 happy_x_1 - = case happyOut189 happy_x_1 of { happy_var_1 -> - happyIn191 - (happy_var_1 - )} - -happyReduce_457 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_457 = happySpecReduce_1 176# happyReduction_457 -happyReduction_457 happy_x_1 - = case happyOut191 happy_x_1 of { happy_var_1 -> - happyIn192 - (happy_var_1 - )} - -happyReduce_458 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_458 = happySpecReduce_1 176# happyReduction_458 -happyReduction_458 happy_x_1 - = case happyOut212 happy_x_1 of { happy_var_1 -> - happyIn192 - (sLL happy_var_1 happy_var_1 $ mkSpliceDecl happy_var_1 - )} - -happyReduce_459 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_459 = happySpecReduce_3 177# happyReduction_459 -happyReduction_459 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - case happyOut122 happy_x_3 of { happy_var_3 -> - happyIn193 - (sL (comb3 happy_var_1 happy_var_2 happy_var_3) - ((mj AnnEqual happy_var_1 : (fst $ unLoc happy_var_3)) - ,GRHSs (unguardedRHS (comb3 happy_var_1 happy_var_2 happy_var_3) happy_var_2) - (snd $ unLoc happy_var_3)) - )}}} - -happyReduce_460 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_460 = happySpecReduce_2 177# happyReduction_460 -happyReduction_460 happy_x_2 - happy_x_1 - = case happyOut194 happy_x_1 of { happy_var_1 -> - case happyOut122 happy_x_2 of { happy_var_2 -> - happyIn193 - (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_2 - ,GRHSs (reverse (unLoc happy_var_1)) - (snd $ unLoc happy_var_2)) - )}} - -happyReduce_461 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_461 = happySpecReduce_2 178# happyReduction_461 -happyReduction_461 happy_x_2 - happy_x_1 - = case happyOut194 happy_x_1 of { happy_var_1 -> - case happyOut195 happy_x_2 of { happy_var_2 -> - happyIn194 - (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) - )}} - -happyReduce_462 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_462 = happySpecReduce_1 178# happyReduction_462 -happyReduction_462 happy_x_1 - = case happyOut195 happy_x_1 of { happy_var_1 -> - happyIn194 - (sL1 happy_var_1 [happy_var_1] - )} - -happyReduce_463 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_463 = happyMonadReduce 4# 179# happyReduction_463 -happyReduction_463 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut228 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut200 happy_x_4 of { happy_var_4 -> - ( ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS (unLoc happy_var_2) happy_var_4) - [mj AnnVbar happy_var_1,mj AnnEqual happy_var_3])}}}}) - ) (\r -> happyReturn (happyIn195 r)) - -happyReduce_464 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_464 = happyMonadReduce 3# 180# happyReduction_464 -happyReduction_464 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut202 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut145 happy_x_3 of { happy_var_3 -> - ( do v <- checkValSigLhs happy_var_1 - ; _ <- ams (sLL happy_var_1 happy_var_3 ()) [mu AnnDcolon happy_var_2] - ; return (sLL happy_var_1 happy_var_3 $ SigD $ - TypeSig [v] (mkLHsSigWcType happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn196 r)) - -happyReduce_465 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_465 = happyMonadReduce 5# 180# happyReduction_465 -happyReduction_465 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut290 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut146 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut145 happy_x_5 of { happy_var_5 -> - ( do { let sig = TypeSig (happy_var_1 : reverse (unLoc happy_var_3)) - (mkLHsSigWcType happy_var_5) - ; addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) - ; ams ( sLL happy_var_1 happy_var_5 $ SigD sig ) - [mu AnnDcolon happy_var_4] })}}}}}) - ) (\r -> happyReturn (happyIn196 r)) - -happyReduce_466 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_466 = happyMonadReduce 3# 180# happyReduction_466 -happyReduction_466 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut73 happy_x_1 of { happy_var_1 -> - case happyOut72 happy_x_2 of { happy_var_2 -> - case happyOut74 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ SigD - (FixSig (FixitySig (fromOL $ unLoc happy_var_3) - (Fixity (fst $ unLoc happy_var_2) (snd $ unLoc happy_var_2) (unLoc happy_var_1))))) - [mj AnnInfix happy_var_1,mj AnnVal happy_var_2])}}}) - ) (\r -> happyReturn (happyIn196 r)) - -happyReduce_467 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_467 = happySpecReduce_1 180# happyReduction_467 -happyReduction_467 happy_x_1 - = case happyOut110 happy_x_1 of { happy_var_1 -> - happyIn196 - (sLL happy_var_1 happy_var_1 . SigD . unLoc $ happy_var_1 - )} - -happyReduce_468 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_468 = happyMonadReduce 4# 180# happyReduction_468 -happyReduction_468 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut266 happy_x_2 of { happy_var_2 -> - case happyOut143 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( let (dcolon, tc) = happy_var_3 - in ams - (sLL happy_var_1 happy_var_4 - (SigD (CompleteMatchSig (getCOMPLETE_PRAGs happy_var_1) happy_var_2 tc))) - ([ mo happy_var_1 ] ++ dcolon ++ [mc happy_var_4]))}}}}) - ) (\r -> happyReturn (happyIn196 r)) - -happyReduce_469 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_469 = happyMonadReduce 4# 180# happyReduction_469 -happyReduction_469 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut197 happy_x_2 of { happy_var_2 -> - case happyOut291 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams ((sLL happy_var_1 happy_var_4 $ SigD (InlineSig happy_var_3 - (mkInlinePragma (getINLINE_PRAGs happy_var_1) (getINLINE happy_var_1) - (snd happy_var_2))))) - ((mo happy_var_1:fst happy_var_2) ++ [mc happy_var_4]))}}}}) - ) (\r -> happyReturn (happyIn196 r)) - -happyReduce_470 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_470 = happyMonadReduce 3# 180# happyReduction_470 -happyReduction_470 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut291 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (SigD (SCCFunSig (getSCC_PRAGs happy_var_1) happy_var_2 Nothing))) - [mo happy_var_1, mc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn196 r)) - -happyReduce_471 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_471 = happyMonadReduce 4# 180# happyReduction_471 -happyReduction_471 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut291 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( do { scc <- getSCC happy_var_3 - ; let str_lit = StringLiteral (getSTRINGs happy_var_3) scc - ; ams (sLL happy_var_1 happy_var_4 (SigD (SCCFunSig (getSCC_PRAGs happy_var_1) happy_var_2 (Just ( sL1 happy_var_3 str_lit))))) - [mo happy_var_1, mc happy_var_4] })}}}}) - ) (\r -> happyReturn (happyIn196 r)) - -happyReduce_472 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_472 = happyMonadReduce 6# 180# happyReduction_472 -happyReduction_472 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut197 happy_x_2 of { happy_var_2 -> - case happyOut291 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut147 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { happy_var_6 -> - ( ams ( - let inl_prag = mkInlinePragma (getSPEC_PRAGs happy_var_1) - (EmptyInlineSpec, FunLike) (snd happy_var_2) - in sLL happy_var_1 happy_var_6 $ SigD (SpecSig happy_var_3 (fromOL happy_var_5) inl_prag)) - (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)))}}}}}}) - ) (\r -> happyReturn (happyIn196 r)) - -happyReduce_473 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_473 = happyMonadReduce 6# 180# happyReduction_473 -happyReduction_473 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut197 happy_x_2 of { happy_var_2 -> - case happyOut291 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut147 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { happy_var_6 -> - ( ams (sLL happy_var_1 happy_var_6 $ SigD (SpecSig happy_var_3 (fromOL happy_var_5) - (mkInlinePragma (getSPEC_INLINE_PRAGs happy_var_1) - (getSPEC_INLINE happy_var_1) (snd happy_var_2)))) - (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)))}}}}}}) - ) (\r -> happyReturn (happyIn196 r)) - -happyReduce_474 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_474 = happyMonadReduce 4# 180# happyReduction_474 -happyReduction_474 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut162 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 - $ SigD (SpecInstSig (getSPEC_PRAGs happy_var_1) happy_var_3)) - [mo happy_var_1,mj AnnInstance happy_var_2,mc happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn196 r)) - -happyReduce_475 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_475 = happyMonadReduce 3# 180# happyReduction_475 -happyReduction_475 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut255 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ SigD (MinimalSig (getMINIMAL_PRAGs happy_var_1) happy_var_2)) - [mo happy_var_1,mc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn196 r)) - -happyReduce_476 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_476 = happySpecReduce_0 181# happyReduction_476 -happyReduction_476 = happyIn197 - (([],Nothing) - ) - -happyReduce_477 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_477 = happySpecReduce_1 181# happyReduction_477 -happyReduction_477 happy_x_1 - = case happyOut198 happy_x_1 of { happy_var_1 -> - happyIn197 - ((fst happy_var_1,Just (snd happy_var_1)) - )} - -happyReduce_478 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_478 = happySpecReduce_3 182# happyReduction_478 -happyReduction_478 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn198 - (([mj AnnOpenS happy_var_1,mj AnnVal happy_var_2,mj AnnCloseS happy_var_3] - ,ActiveAfter (getINTEGERs happy_var_2) (fromInteger (getINTEGER happy_var_2))) - )}}} - -happyReduce_479 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_479 = happyReduce 4# 182# happyReduction_479 -happyReduction_479 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn198 - (([mj AnnOpenS happy_var_1,mj AnnTilde happy_var_2,mj AnnVal happy_var_3 - ,mj AnnCloseS happy_var_4] - ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (getINTEGER happy_var_3))) - ) `HappyStk` happyRest}}}} - -happyReduce_480 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_480 = happySpecReduce_1 183# happyReduction_480 -happyReduction_480 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn199 - (let { loc = getLoc happy_var_1 - ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc happy_var_1 - ; quoterId = mkUnqual varName quoter } - in sL1 happy_var_1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) - )} - -happyReduce_481 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_481 = happySpecReduce_1 183# happyReduction_481 -happyReduction_481 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn199 - (let { loc = getLoc happy_var_1 - ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc happy_var_1 - ; quoterId = mkQual varName (qual, quoter) } - in sL (getLoc happy_var_1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) - )} - -happyReduce_482 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_482 = happyMonadReduce 3# 184# happyReduction_482 -happyReduction_482 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut201 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut144 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ ExprWithTySig happy_var_1 (mkLHsSigWcType happy_var_3)) - [mu AnnDcolon happy_var_2])}}}) - ) (\r -> happyReturn (happyIn200 r)) - -happyReduce_483 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_483 = happyMonadReduce 3# 184# happyReduction_483 -happyReduction_483 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut201 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut200 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsArrApp happy_var_1 happy_var_3 placeHolderType - HsFirstOrderApp True) - [mu Annlarrowtail happy_var_2])}}}) - ) (\r -> happyReturn (happyIn200 r)) - -happyReduce_484 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_484 = happyMonadReduce 3# 184# happyReduction_484 -happyReduction_484 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut201 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut200 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsArrApp happy_var_3 happy_var_1 placeHolderType - HsFirstOrderApp False) - [mu Annrarrowtail happy_var_2])}}}) - ) (\r -> happyReturn (happyIn200 r)) - -happyReduce_485 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_485 = happyMonadReduce 3# 184# happyReduction_485 -happyReduction_485 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut201 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut200 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsArrApp happy_var_1 happy_var_3 placeHolderType - HsHigherOrderApp True) - [mu AnnLarrowtail happy_var_2])}}}) - ) (\r -> happyReturn (happyIn200 r)) - -happyReduce_486 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_486 = happyMonadReduce 3# 184# happyReduction_486 -happyReduction_486 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut201 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut200 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsArrApp happy_var_3 happy_var_1 placeHolderType - HsHigherOrderApp False) - [mu AnnRarrowtail happy_var_2])}}}) - ) (\r -> happyReturn (happyIn200 r)) - -happyReduce_487 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_487 = happySpecReduce_1 184# happyReduction_487 -happyReduction_487 happy_x_1 - = case happyOut201 happy_x_1 of { happy_var_1 -> - happyIn200 - (happy_var_1 - )} - -happyReduce_488 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_488 = happySpecReduce_1 185# happyReduction_488 -happyReduction_488 happy_x_1 - = case happyOut204 happy_x_1 of { happy_var_1 -> - happyIn201 - (happy_var_1 - )} - -happyReduce_489 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_489 = happyMonadReduce 3# 185# happyReduction_489 -happyReduction_489 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut201 happy_x_1 of { happy_var_1 -> - case happyOut283 happy_x_2 of { happy_var_2 -> - case happyOut204 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (OpApp happy_var_1 happy_var_2 placeHolderFixity happy_var_3)) - [mj AnnVal happy_var_2])}}}) - ) (\r -> happyReturn (happyIn201 r)) - -happyReduce_490 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_490 = happySpecReduce_1 186# happyReduction_490 -happyReduction_490 happy_x_1 - = case happyOut203 happy_x_1 of { happy_var_1 -> - happyIn202 - (happy_var_1 - )} - -happyReduce_491 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_491 = happyMonadReduce 3# 186# happyReduction_491 -happyReduction_491 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut202 happy_x_1 of { happy_var_1 -> - case happyOut283 happy_x_2 of { happy_var_2 -> - case happyOut203 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (OpApp happy_var_1 happy_var_2 placeHolderFixity happy_var_3)) - [mj AnnVal happy_var_2])}}}) - ) (\r -> happyReturn (happyIn202 r)) - -happyReduce_492 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_492 = happyMonadReduce 6# 187# happyReduction_492 -happyReduction_492 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut241 happy_x_2 of { happy_var_2 -> - case happyOut242 happy_x_3 of { happy_var_3 -> - case happyOut142 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut200 happy_x_6 of { happy_var_6 -> - ( ams (sLL happy_var_1 happy_var_6 $ HsLam (mkMatchGroup FromSource - [sLL happy_var_1 happy_var_6 $ Match { m_ctxt = LambdaExpr - , m_pats = happy_var_2:happy_var_3 - , m_type = snd happy_var_4 - , m_grhss = unguardedGRHSs happy_var_6 }])) - (mj AnnLam happy_var_1:mu AnnRarrow happy_var_5:(fst happy_var_4)))}}}}}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_493 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_493 = happyMonadReduce 4# 187# happyReduction_493 -happyReduction_493 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut121 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut200 happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 $ HsLet (snd $ unLoc happy_var_2) happy_var_4) - (mj AnnLet happy_var_1:mj AnnIn happy_var_3 - :(fst $ unLoc happy_var_2)))}}}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_494 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_494 = happyMonadReduce 3# 187# happyReduction_494 -happyReduction_494 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut230 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsLamCase - (mkMatchGroup FromSource (snd $ unLoc happy_var_3))) - (mj AnnLam happy_var_1:mj AnnCase happy_var_2:(fst $ unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_495 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_495 = happyMonadReduce 8# 187# happyReduction_495 -happyReduction_495 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - case happyOut205 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut200 happy_x_5 of { happy_var_5 -> - case happyOut205 happy_x_6 of { happy_var_6 -> - case happyOutTok happy_x_7 of { happy_var_7 -> - case happyOut200 happy_x_8 of { happy_var_8 -> - ( checkDoAndIfThenElse happy_var_2 (snd happy_var_3) happy_var_5 (snd happy_var_6) happy_var_8 >> - ams (sLL happy_var_1 happy_var_8 $ mkHsIf happy_var_2 happy_var_5 happy_var_8) - (mj AnnIf happy_var_1:mj AnnThen happy_var_4 - :mj AnnElse happy_var_7 - :(map (\l -> mj AnnSemi l) (fst happy_var_3)) - ++(map (\l -> mj AnnSemi l) (fst happy_var_6))))}}}}}}}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_496 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_496 = happyMonadReduce 2# 187# happyReduction_496 -happyReduction_496 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut237 happy_x_2 of { happy_var_2 -> - ( hintMultiWayIf (getLoc happy_var_1) >> - ams (sLL happy_var_1 happy_var_2 $ HsMultiIf - placeHolderType - (reverse $ snd $ unLoc happy_var_2)) - (mj AnnIf happy_var_1:(fst $ unLoc happy_var_2)))}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_497 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_497 = happyMonadReduce 4# 187# happyReduction_497 -happyReduction_497 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut230 happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 $ HsCase happy_var_2 (mkMatchGroup - FromSource (snd $ unLoc happy_var_4))) - (mj AnnCase happy_var_1:mj AnnOf happy_var_3 - :(fst $ unLoc happy_var_4)))}}}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_498 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_498 = happyMonadReduce 2# 187# happyReduction_498 -happyReduction_498 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut208 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ NegApp happy_var_2 noSyntaxExpr) - [mj AnnMinus happy_var_1])}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_499 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_499 = happyMonadReduce 2# 187# happyReduction_499 -happyReduction_499 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut243 happy_x_2 of { happy_var_2 -> - ( ams (L (comb2 happy_var_1 happy_var_2) - (mkHsDo DoExpr (snd $ unLoc happy_var_2))) - (mj AnnDo happy_var_1:(fst $ unLoc happy_var_2)))}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_500 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_500 = happyMonadReduce 2# 187# happyReduction_500 -happyReduction_500 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut243 happy_x_2 of { happy_var_2 -> - ( ams (L (comb2 happy_var_1 happy_var_2) - (mkHsDo MDoExpr (snd $ unLoc happy_var_2))) - (mj AnnMdo happy_var_1:(fst $ unLoc happy_var_2)))}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_501 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_501 = happyMonadReduce 2# 187# happyReduction_501 -happyReduction_501 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut207 happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsTickPragma (snd $ fst $ fst $ unLoc happy_var_1) - (snd $ fst $ unLoc happy_var_1) (snd $ unLoc happy_var_1) happy_var_2) - (fst $ fst $ fst $ unLoc happy_var_1))}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_502 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_502 = happyMonadReduce 4# 187# happyReduction_502 -happyReduction_502 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut209 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut200 happy_x_4 of { happy_var_4 -> - ( checkPattern empty happy_var_2 >>= \ p -> - checkCommand happy_var_4 >>= \ cmd -> - ams (sLL happy_var_1 happy_var_4 $ HsProc p (sLL happy_var_1 happy_var_4 $ HsCmdTop cmd placeHolderType - placeHolderType [])) - -- TODO: is LL right here? - [mj AnnProc happy_var_1,mu AnnRarrow happy_var_3])}}}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_503 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_503 = happyMonadReduce 4# 187# happyReduction_503 -happyReduction_503 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut200 happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 $ HsCoreAnn (getCORE_PRAGs happy_var_1) (getStringLiteral happy_var_2) happy_var_4) - [mo happy_var_1,mj AnnVal happy_var_2 - ,mc happy_var_3])}}}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_504 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_504 = happySpecReduce_1 187# happyReduction_504 -happyReduction_504 happy_x_1 - = case happyOut208 happy_x_1 of { happy_var_1 -> - happyIn203 - (happy_var_1 - )} - -happyReduce_505 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_505 = happySpecReduce_1 188# happyReduction_505 -happyReduction_505 happy_x_1 - = case happyOut203 happy_x_1 of { happy_var_1 -> - happyIn204 - (happy_var_1 - )} - -happyReduce_506 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_506 = happyMonadReduce 2# 188# happyReduction_506 -happyReduction_506 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut206 happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsSCC (snd $ fst $ unLoc happy_var_1) (snd $ unLoc happy_var_1) happy_var_2) - (fst $ fst $ unLoc happy_var_1))}}) - ) (\r -> happyReturn (happyIn204 r)) - -happyReduce_507 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_507 = happySpecReduce_1 189# happyReduction_507 -happyReduction_507 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn205 - (([happy_var_1],True) - )} - -happyReduce_508 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_508 = happySpecReduce_0 189# happyReduction_508 -happyReduction_508 = happyIn205 - (([],False) - ) - -happyReduce_509 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_509 = happyMonadReduce 3# 190# happyReduction_509 -happyReduction_509 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( do scc <- getSCC happy_var_2 - ; return $ sLL happy_var_1 happy_var_3 - (([mo happy_var_1,mj AnnValStr happy_var_2 - ,mc happy_var_3],getSCC_PRAGs happy_var_1),(StringLiteral (getSTRINGs happy_var_2) scc)))}}}) - ) (\r -> happyReturn (happyIn206 r)) - -happyReduce_510 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_510 = happySpecReduce_3 190# happyReduction_510 -happyReduction_510 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn206 - (sLL happy_var_1 happy_var_3 (([mo happy_var_1,mj AnnVal happy_var_2 - ,mc happy_var_3],getSCC_PRAGs happy_var_1) - ,(StringLiteral NoSourceText (getVARID happy_var_2))) - )}}} - -happyReduce_511 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_511 = happyReduce 10# 191# happyReduction_511 -happyReduction_511 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { happy_var_6 -> - case happyOutTok happy_x_7 of { happy_var_7 -> - case happyOutTok happy_x_8 of { happy_var_8 -> - case happyOutTok happy_x_9 of { happy_var_9 -> - case happyOutTok happy_x_10 of { happy_var_10 -> - happyIn207 - (sLL happy_var_1 happy_var_10 $ ((([mo happy_var_1,mj AnnVal happy_var_2 - ,mj AnnVal happy_var_3,mj AnnColon happy_var_4 - ,mj AnnVal happy_var_5,mj AnnMinus happy_var_6 - ,mj AnnVal happy_var_7,mj AnnColon happy_var_8 - ,mj AnnVal happy_var_9,mc happy_var_10], - getGENERATED_PRAGs happy_var_1) - ,((getStringLiteral happy_var_2) - ,( fromInteger $ getINTEGER happy_var_3 - , fromInteger $ getINTEGER happy_var_5 - ) - ,( fromInteger $ getINTEGER happy_var_7 - , fromInteger $ getINTEGER happy_var_9 - ) - )) - , (( getINTEGERs happy_var_3 - , getINTEGERs happy_var_5 - ) - ,( getINTEGERs happy_var_7 - , getINTEGERs happy_var_9 - ))) - ) `HappyStk` happyRest}}}}}}}}}} - -happyReduce_512 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_512 = happySpecReduce_2 192# happyReduction_512 -happyReduction_512 happy_x_2 - happy_x_1 - = case happyOut208 happy_x_1 of { happy_var_1 -> - case happyOut209 happy_x_2 of { happy_var_2 -> - happyIn208 - (sLL happy_var_1 happy_var_2 $ HsApp happy_var_1 happy_var_2 - )}} - -happyReduce_513 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_513 = happyMonadReduce 3# 192# happyReduction_513 -happyReduction_513 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut208 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut161 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsAppType happy_var_1 (mkHsWildCardBndrs happy_var_3)) - [mj AnnAt happy_var_2])}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_514 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_514 = happyMonadReduce 2# 192# happyReduction_514 -happyReduction_514 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut209 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsStatic placeHolderNames happy_var_2) - [mj AnnStatic happy_var_1])}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_515 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_515 = happySpecReduce_1 192# happyReduction_515 -happyReduction_515 happy_x_1 - = case happyOut209 happy_x_1 of { happy_var_1 -> - happyIn208 - (happy_var_1 - )} - -happyReduce_516 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_516 = happyMonadReduce 3# 193# happyReduction_516 -happyReduction_516 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut291 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut209 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ EAsPat happy_var_1 happy_var_3) [mj AnnAt happy_var_2])}}}) - ) (\r -> happyReturn (happyIn209 r)) - -happyReduce_517 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_517 = happyMonadReduce 2# 193# happyReduction_517 -happyReduction_517 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut209 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ ELazyPat happy_var_2) [mj AnnTilde happy_var_1])}}) - ) (\r -> happyReturn (happyIn209 r)) - -happyReduce_518 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_518 = happySpecReduce_1 193# happyReduction_518 -happyReduction_518 happy_x_1 - = case happyOut210 happy_x_1 of { happy_var_1 -> - happyIn209 - (happy_var_1 - )} - -happyReduce_519 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_519 = happyMonadReduce 4# 194# happyReduction_519 -happyReduction_519 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut210 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut248 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( do { r <- mkRecConstrOrUpdate happy_var_1 (comb2 happy_var_2 happy_var_4) - (snd happy_var_3) - ; _ <- ams (sLL happy_var_1 happy_var_4 ()) (moc happy_var_2:mcc happy_var_4:(fst happy_var_3)) - ; checkRecordSyntax (sLL happy_var_1 happy_var_4 r) })}}}}) - ) (\r -> happyReturn (happyIn210 r)) - -happyReduce_520 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_520 = happySpecReduce_1 194# happyReduction_520 -happyReduction_520 happy_x_1 - = case happyOut211 happy_x_1 of { happy_var_1 -> - happyIn210 - (happy_var_1 - )} - -happyReduce_521 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_521 = happySpecReduce_1 195# happyReduction_521 -happyReduction_521 happy_x_1 - = case happyOut291 happy_x_1 of { happy_var_1 -> - happyIn211 - (sL1 happy_var_1 (HsVar $! happy_var_1) - )} - -happyReduce_522 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_522 = happySpecReduce_1 195# happyReduction_522 -happyReduction_522 happy_x_1 - = case happyOut263 happy_x_1 of { happy_var_1 -> - happyIn211 - (sL1 happy_var_1 (HsVar $! happy_var_1) - )} - -happyReduce_523 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_523 = happySpecReduce_1 195# happyReduction_523 -happyReduction_523 happy_x_1 - = case happyOut253 happy_x_1 of { happy_var_1 -> - happyIn211 - (sL1 happy_var_1 (HsIPVar $! unLoc happy_var_1) - )} - -happyReduce_524 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_524 = happySpecReduce_1 195# happyReduction_524 -happyReduction_524 happy_x_1 - = case happyOut254 happy_x_1 of { happy_var_1 -> - happyIn211 - (sL1 happy_var_1 (HsOverLabel Nothing $! unLoc happy_var_1) - )} - -happyReduce_525 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_525 = happySpecReduce_1 195# happyReduction_525 -happyReduction_525 happy_x_1 - = case happyOut305 happy_x_1 of { happy_var_1 -> - happyIn211 - (sL1 happy_var_1 (HsLit $! unLoc happy_var_1) - )} - -happyReduce_526 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_526 = happySpecReduce_1 195# happyReduction_526 -happyReduction_526 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn211 - (sL (getLoc happy_var_1) (HsOverLit $! mkHsIntegral (getINTEGERs happy_var_1) - (getINTEGER happy_var_1) placeHolderType) - )} - -happyReduce_527 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_527 = happySpecReduce_1 195# happyReduction_527 -happyReduction_527 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn211 - (sL (getLoc happy_var_1) (HsOverLit $! mkHsFractional - (getRATIONAL happy_var_1) placeHolderType) - )} - -happyReduce_528 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_528 = happyMonadReduce 3# 195# happyReduction_528 -happyReduction_528 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut217 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (HsPar happy_var_2)) [mop happy_var_1,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_529 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_529 = happyMonadReduce 3# 195# happyReduction_529 -happyReduction_529 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut218 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( do { e <- mkSumOrTuple Boxed (comb2 happy_var_1 happy_var_3) (snd happy_var_2) - ; ams (sLL happy_var_1 happy_var_3 e) ((mop happy_var_1:fst happy_var_2) ++ [mcp happy_var_3]) })}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_530 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_530 = happyMonadReduce 3# 195# happyReduction_530 -happyReduction_530 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut217 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (ExplicitTuple [L (gl happy_var_2) - (Present happy_var_2)] Unboxed)) - [mo happy_var_1,mc happy_var_3])}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_531 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_531 = happyMonadReduce 3# 195# happyReduction_531 -happyReduction_531 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut218 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( do { e <- mkSumOrTuple Unboxed (comb2 happy_var_1 happy_var_3) (snd happy_var_2) - ; ams (sLL happy_var_1 happy_var_3 e) ((mo happy_var_1:fst happy_var_2) ++ [mc happy_var_3]) })}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_532 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_532 = happyMonadReduce 3# 195# happyReduction_532 -happyReduction_532 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut221 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (snd happy_var_2)) (mos happy_var_1:mcs happy_var_3:(fst happy_var_2)))}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_533 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_533 = happyMonadReduce 3# 195# happyReduction_533 -happyReduction_533 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut227 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (snd happy_var_2)) (mo happy_var_1:mc happy_var_3:(fst happy_var_2)))}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_534 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_534 = happySpecReduce_1 195# happyReduction_534 -happyReduction_534 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn211 - (sL1 happy_var_1 EWildPat - )} - -happyReduce_535 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_535 = happySpecReduce_1 195# happyReduction_535 -happyReduction_535 happy_x_1 - = case happyOut212 happy_x_1 of { happy_var_1 -> - happyIn211 - (happy_var_1 - )} - -happyReduce_536 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_536 = happyMonadReduce 2# 195# happyReduction_536 -happyReduction_536 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut291 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsBracket (VarBr True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_537 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_537 = happyMonadReduce 2# 195# happyReduction_537 -happyReduction_537 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut263 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsBracket (VarBr True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_538 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_538 = happyMonadReduce 2# 195# happyReduction_538 -happyReduction_538 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut287 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsBracket (VarBr False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_539 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_539 = happyMonadReduce 2# 195# happyReduction_539 -happyReduction_539 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut271 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsBracket (VarBr False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_540 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_540 = happyMonadReduce 3# 195# happyReduction_540 -happyReduction_540 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsBracket (ExpBr happy_var_2)) - (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1, mu AnnCloseQ happy_var_3] - else [mu AnnOpenEQ happy_var_1,mu AnnCloseQ happy_var_3]))}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_541 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_541 = happyMonadReduce 3# 195# happyReduction_541 -happyReduction_541 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsBracket (TExpBr happy_var_2)) - (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1,mc happy_var_3] else [mo happy_var_1,mc happy_var_3]))}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_542 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_542 = happyMonadReduce 3# 195# happyReduction_542 -happyReduction_542 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut151 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsBracket (TypBr happy_var_2)) [mo happy_var_1,mu AnnCloseQ happy_var_3])}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_543 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_543 = happyMonadReduce 3# 195# happyReduction_543 -happyReduction_543 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut201 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( checkPattern empty happy_var_2 >>= \p -> - ams (sLL happy_var_1 happy_var_3 $ HsBracket (PatBr p)) - [mo happy_var_1,mu AnnCloseQ happy_var_3])}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_544 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_544 = happyMonadReduce 3# 195# happyReduction_544 -happyReduction_544 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut215 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsBracket (DecBrL (snd happy_var_2))) - (mo happy_var_1:mu AnnCloseQ happy_var_3:fst happy_var_2))}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_545 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_545 = happySpecReduce_1 195# happyReduction_545 -happyReduction_545 happy_x_1 - = case happyOut199 happy_x_1 of { happy_var_1 -> - happyIn211 - (sL1 happy_var_1 (HsSpliceE (unLoc happy_var_1)) - )} - -happyReduce_546 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_546 = happyMonadReduce 4# 195# happyReduction_546 -happyReduction_546 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut211 happy_x_2 of { happy_var_2 -> - case happyOut213 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 $ HsArrForm happy_var_2 - Nothing (reverse happy_var_3)) - [mu AnnOpenB happy_var_1,mu AnnCloseB happy_var_4])}}}}) - ) (\r -> happyReturn (happyIn211 r)) - -happyReduce_547 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_547 = happyMonadReduce 1# 196# happyReduction_547 -happyReduction_547 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( ams (sL1 happy_var_1 $ mkHsSpliceE HasDollar - (sL1 happy_var_1 $ HsVar (sL1 happy_var_1 (mkUnqual varName - (getTH_ID_SPLICE happy_var_1))))) - [mj AnnThIdSplice happy_var_1])}) - ) (\r -> happyReturn (happyIn212 r)) - -happyReduce_548 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_548 = happyMonadReduce 3# 196# happyReduction_548 -happyReduction_548 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ mkHsSpliceE HasParens happy_var_2) - [mj AnnOpenPE happy_var_1,mj AnnCloseP happy_var_3])}}}) - ) (\r -> happyReturn (happyIn212 r)) - -happyReduce_549 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_549 = happyMonadReduce 1# 196# happyReduction_549 -happyReduction_549 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( ams (sL1 happy_var_1 $ mkHsSpliceTE HasDollar - (sL1 happy_var_1 $ HsVar (sL1 happy_var_1 (mkUnqual varName - (getTH_ID_TY_SPLICE happy_var_1))))) - [mj AnnThIdTySplice happy_var_1])}) - ) (\r -> happyReturn (happyIn212 r)) - -happyReduce_550 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_550 = happyMonadReduce 3# 196# happyReduction_550 -happyReduction_550 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ mkHsSpliceTE HasParens happy_var_2) - [mj AnnOpenPTE happy_var_1,mj AnnCloseP happy_var_3])}}}) - ) (\r -> happyReturn (happyIn212 r)) - -happyReduce_551 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_551 = happySpecReduce_2 197# happyReduction_551 -happyReduction_551 happy_x_2 - happy_x_1 - = case happyOut213 happy_x_1 of { happy_var_1 -> - case happyOut214 happy_x_2 of { happy_var_2 -> - happyIn213 - (happy_var_2 : happy_var_1 - )}} - -happyReduce_552 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_552 = happySpecReduce_0 197# happyReduction_552 -happyReduction_552 = happyIn213 - ([] - ) - -happyReduce_553 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_553 = happyMonadReduce 1# 198# happyReduction_553 -happyReduction_553 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut211 happy_x_1 of { happy_var_1 -> - ( checkCommand happy_var_1 >>= \ cmd -> - return (sL1 happy_var_1 $ HsCmdTop cmd - placeHolderType placeHolderType []))}) - ) (\r -> happyReturn (happyIn214 r)) - -happyReduce_554 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_554 = happySpecReduce_3 199# happyReduction_554 -happyReduction_554 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut216 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn215 - (([mj AnnOpenC happy_var_1 - ,mj AnnCloseC happy_var_3],happy_var_2) - )}}} - -happyReduce_555 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_555 = happySpecReduce_3 199# happyReduction_555 -happyReduction_555 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut216 happy_x_2 of { happy_var_2 -> - happyIn215 - (([],happy_var_2) - )} - -happyReduce_556 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_556 = happySpecReduce_1 200# happyReduction_556 -happyReduction_556 happy_x_1 - = case happyOut76 happy_x_1 of { happy_var_1 -> - happyIn216 - (cvTopDecls happy_var_1 - )} - -happyReduce_557 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_557 = happySpecReduce_1 200# happyReduction_557 -happyReduction_557 happy_x_1 - = case happyOut75 happy_x_1 of { happy_var_1 -> - happyIn216 - (cvTopDecls happy_var_1 - )} - -happyReduce_558 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_558 = happySpecReduce_1 201# happyReduction_558 -happyReduction_558 happy_x_1 - = case happyOut200 happy_x_1 of { happy_var_1 -> - happyIn217 - (happy_var_1 - )} - -happyReduce_559 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_559 = happySpecReduce_2 201# happyReduction_559 -happyReduction_559 happy_x_2 - happy_x_1 - = case happyOut201 happy_x_1 of { happy_var_1 -> - case happyOut283 happy_x_2 of { happy_var_2 -> - happyIn217 - (sLL happy_var_1 happy_var_2 $ SectionL happy_var_1 happy_var_2 - )}} - -happyReduce_560 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_560 = happySpecReduce_2 201# happyReduction_560 -happyReduction_560 happy_x_2 - happy_x_1 - = case happyOut284 happy_x_1 of { happy_var_1 -> - case happyOut201 happy_x_2 of { happy_var_2 -> - happyIn217 - (sLL happy_var_1 happy_var_2 $ SectionR happy_var_1 happy_var_2 - )}} - -happyReduce_561 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_561 = happyMonadReduce 3# 201# happyReduction_561 -happyReduction_561 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut200 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut217 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ EViewPat happy_var_1 happy_var_3) [mu AnnRarrow happy_var_2])}}}) - ) (\r -> happyReturn (happyIn217 r)) - -happyReduce_562 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_562 = happyMonadReduce 2# 202# happyReduction_562 -happyReduction_562 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { happy_var_2 -> - ( do { addAnnotation (gl happy_var_1) AnnComma (fst happy_var_2) - ; return ([],Tuple ((sL1 happy_var_1 (Present happy_var_1)) : snd happy_var_2)) })}}) - ) (\r -> happyReturn (happyIn218 r)) - -happyReduce_563 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_563 = happySpecReduce_2 202# happyReduction_563 -happyReduction_563 happy_x_2 - happy_x_1 - = case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOut310 happy_x_2 of { happy_var_2 -> - happyIn218 - ((mvbars (fst happy_var_2), Sum 1 (snd happy_var_2 + 1) happy_var_1) - )}} - -happyReduce_564 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_564 = happyMonadReduce 2# 202# happyReduction_564 -happyReduction_564 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut308 happy_x_1 of { happy_var_1 -> - case happyOut220 happy_x_2 of { happy_var_2 -> - ( do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst happy_var_1) - ; return - ([],Tuple (map (\l -> L l missingTupArg) (fst happy_var_1) ++ happy_var_2)) })}}) - ) (\r -> happyReturn (happyIn218 r)) - -happyReduce_565 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_565 = happySpecReduce_3 202# happyReduction_565 -happyReduction_565 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut310 happy_x_1 of { happy_var_1 -> - case happyOut217 happy_x_2 of { happy_var_2 -> - case happyOut309 happy_x_3 of { happy_var_3 -> - happyIn218 - ((mvbars (fst happy_var_1) ++ mvbars (fst happy_var_3), Sum (snd happy_var_1 + 1) (snd happy_var_1 + snd happy_var_3 + 1) happy_var_2) - )}}} - -happyReduce_566 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_566 = happyMonadReduce 2# 203# happyReduction_566 -happyReduction_566 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut308 happy_x_1 of { happy_var_1 -> - case happyOut220 happy_x_2 of { happy_var_2 -> - ( do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst happy_var_1) - ; return ( - (head $ fst happy_var_1 - ,(map (\l -> L l missingTupArg) (tail $ fst happy_var_1)) ++ happy_var_2)) })}}) - ) (\r -> happyReturn (happyIn219 r)) - -happyReduce_567 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_567 = happyMonadReduce 2# 204# happyReduction_567 -happyReduction_567 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { happy_var_2 -> - ( addAnnotation (gl happy_var_1) AnnComma (fst happy_var_2) >> - return ((L (gl happy_var_1) (Present happy_var_1)) : snd happy_var_2))}}) - ) (\r -> happyReturn (happyIn220 r)) - -happyReduce_568 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_568 = happySpecReduce_1 204# happyReduction_568 -happyReduction_568 happy_x_1 - = case happyOut217 happy_x_1 of { happy_var_1 -> - happyIn220 - ([L (gl happy_var_1) (Present happy_var_1)] - )} - -happyReduce_569 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_569 = happySpecReduce_0 204# happyReduction_569 -happyReduction_569 = happyIn220 - ([noLoc missingTupArg] - ) - -happyReduce_570 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_570 = happySpecReduce_1 205# happyReduction_570 -happyReduction_570 happy_x_1 - = case happyOut217 happy_x_1 of { happy_var_1 -> - happyIn221 - (([],ExplicitList placeHolderType Nothing [happy_var_1]) - )} - -happyReduce_571 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_571 = happySpecReduce_1 205# happyReduction_571 -happyReduction_571 happy_x_1 - = case happyOut222 happy_x_1 of { happy_var_1 -> - happyIn221 - (([],ExplicitList placeHolderType Nothing - (reverse (unLoc happy_var_1))) - )} - -happyReduce_572 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_572 = happySpecReduce_2 205# happyReduction_572 -happyReduction_572 happy_x_2 - happy_x_1 - = case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn221 - (([mj AnnDotdot happy_var_2], - ArithSeq noPostTcExpr Nothing (From happy_var_1)) - )}} - -happyReduce_573 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_573 = happyReduce 4# 205# happyReduction_573 -happyReduction_573 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut200 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn221 - (([mj AnnComma happy_var_2,mj AnnDotdot happy_var_4], - ArithSeq noPostTcExpr Nothing - (FromThen happy_var_1 happy_var_3)) - ) `HappyStk` happyRest}}}} - -happyReduce_574 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_574 = happySpecReduce_3 205# happyReduction_574 -happyReduction_574 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut200 happy_x_3 of { happy_var_3 -> - happyIn221 - (([mj AnnDotdot happy_var_2], - ArithSeq noPostTcExpr Nothing - (FromTo happy_var_1 happy_var_3)) - )}}} - -happyReduce_575 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_575 = happyReduce 5# 205# happyReduction_575 -happyReduction_575 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut200 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut200 happy_x_5 of { happy_var_5 -> - happyIn221 - (([mj AnnComma happy_var_2,mj AnnDotdot happy_var_4], - ArithSeq noPostTcExpr Nothing - (FromThenTo happy_var_1 happy_var_3 happy_var_5)) - ) `HappyStk` happyRest}}}}} - -happyReduce_576 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_576 = happyMonadReduce 3# 205# happyReduction_576 -happyReduction_576 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut223 happy_x_3 of { happy_var_3 -> - ( checkMonadComp >>= \ ctxt -> - return ([mj AnnVbar happy_var_2], - mkHsComp ctxt (unLoc happy_var_3) happy_var_1))}}}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_577 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_577 = happyMonadReduce 3# 206# happyReduction_577 -happyReduction_577 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut222 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut217 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl $ head $ unLoc happy_var_1) - AnnComma (gl happy_var_2) >> - return (sLL happy_var_1 happy_var_3 (((:) $! happy_var_3) $! unLoc happy_var_1)))}}}) - ) (\r -> happyReturn (happyIn222 r)) - -happyReduce_578 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_578 = happyMonadReduce 3# 206# happyReduction_578 -happyReduction_578 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut217 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> - return (sLL happy_var_1 happy_var_3 [happy_var_3,happy_var_1]))}}}) - ) (\r -> happyReturn (happyIn222 r)) - -happyReduce_579 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_579 = happySpecReduce_1 207# happyReduction_579 -happyReduction_579 happy_x_1 - = case happyOut224 happy_x_1 of { happy_var_1 -> - happyIn223 - (case (unLoc happy_var_1) of - [qs] -> sL1 happy_var_1 qs - -- We just had one thing in our "parallel" list so - -- we simply return that thing directly - - qss -> sL1 happy_var_1 [sL1 happy_var_1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr | - qs <- qss] - noExpr noSyntaxExpr placeHolderType] - -- We actually found some actual parallel lists so - -- we wrap them into as a ParStmt - )} - -happyReduce_580 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_580 = happyMonadReduce 3# 208# happyReduction_580 -happyReduction_580 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut225 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut224 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnVbar (gl happy_var_2) >> - return (sLL happy_var_1 happy_var_3 (reverse (unLoc happy_var_1) : unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn224 r)) - -happyReduce_581 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_581 = happySpecReduce_1 208# happyReduction_581 -happyReduction_581 happy_x_1 - = case happyOut225 happy_x_1 of { happy_var_1 -> - happyIn224 - (L (getLoc happy_var_1) [reverse (unLoc happy_var_1)] - )} - -happyReduce_582 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_582 = happyMonadReduce 3# 209# happyReduction_582 -happyReduction_582 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut225 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut226 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> - ams (sLL happy_var_1 happy_var_3 ()) (fst $ unLoc happy_var_3) >> - return (sLL happy_var_1 happy_var_3 [sLL happy_var_1 happy_var_3 ((snd $ unLoc happy_var_3) (reverse (unLoc happy_var_1)))]))}}}) - ) (\r -> happyReturn (happyIn225 r)) - -happyReduce_583 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_583 = happyMonadReduce 3# 209# happyReduction_583 -happyReduction_583 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut225 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut247 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> - return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}}) - ) (\r -> happyReturn (happyIn225 r)) - -happyReduce_584 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_584 = happyMonadReduce 1# 209# happyReduction_584 -happyReduction_584 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut226 happy_x_1 of { happy_var_1 -> - ( ams happy_var_1 (fst $ unLoc happy_var_1) >> - return (sLL happy_var_1 happy_var_1 [L (getLoc happy_var_1) ((snd $ unLoc happy_var_1) [])]))}) - ) (\r -> happyReturn (happyIn225 r)) - -happyReduce_585 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_585 = happySpecReduce_1 209# happyReduction_585 -happyReduction_585 happy_x_1 - = case happyOut247 happy_x_1 of { happy_var_1 -> - happyIn225 - (sL1 happy_var_1 [happy_var_1] - )} - -happyReduce_586 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_586 = happySpecReduce_2 210# happyReduction_586 -happyReduction_586 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - happyIn226 - (sLL happy_var_1 happy_var_2 ([mj AnnThen happy_var_1], \ss -> (mkTransformStmt ss happy_var_2)) - )}} - -happyReduce_587 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_587 = happyReduce 4# 210# happyReduction_587 -happyReduction_587 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut200 happy_x_4 of { happy_var_4 -> - happyIn226 - (sLL happy_var_1 happy_var_4 ([mj AnnThen happy_var_1,mj AnnBy happy_var_3],\ss -> (mkTransformByStmt ss happy_var_2 happy_var_4)) - ) `HappyStk` happyRest}}}} - -happyReduce_588 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_588 = happyReduce 4# 210# happyReduction_588 -happyReduction_588 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut200 happy_x_4 of { happy_var_4 -> - happyIn226 - (sLL happy_var_1 happy_var_4 ([mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnUsing happy_var_3], \ss -> (mkGroupUsingStmt ss happy_var_4)) - ) `HappyStk` happyRest}}}} - -happyReduce_589 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_589 = happyReduce 6# 210# happyReduction_589 -happyReduction_589 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut200 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut200 happy_x_6 of { happy_var_6 -> - happyIn226 - (sLL happy_var_1 happy_var_6 ([mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnBy happy_var_3,mj AnnUsing happy_var_5], \ss -> (mkGroupByUsingStmt ss happy_var_4 happy_var_6)) - ) `HappyStk` happyRest}}}}}} - -happyReduce_590 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_590 = happySpecReduce_0 211# happyReduction_590 -happyReduction_590 = happyIn227 - (([],ExplicitPArr placeHolderType []) - ) - -happyReduce_591 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_591 = happySpecReduce_1 211# happyReduction_591 -happyReduction_591 happy_x_1 - = case happyOut217 happy_x_1 of { happy_var_1 -> - happyIn227 - (([],ExplicitPArr placeHolderType [happy_var_1]) - )} - -happyReduce_592 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_592 = happySpecReduce_1 211# happyReduction_592 -happyReduction_592 happy_x_1 - = case happyOut222 happy_x_1 of { happy_var_1 -> - happyIn227 - (([],ExplicitPArr placeHolderType - (reverse (unLoc happy_var_1))) - )} - -happyReduce_593 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_593 = happySpecReduce_3 211# happyReduction_593 -happyReduction_593 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut200 happy_x_3 of { happy_var_3 -> - happyIn227 - (([mj AnnDotdot happy_var_2] - ,PArrSeq noPostTcExpr (FromTo happy_var_1 happy_var_3)) - )}}} - -happyReduce_594 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_594 = happyReduce 5# 211# happyReduction_594 -happyReduction_594 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut200 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut200 happy_x_5 of { happy_var_5 -> - happyIn227 - (([mj AnnComma happy_var_2,mj AnnDotdot happy_var_4] - ,PArrSeq noPostTcExpr (FromThenTo happy_var_1 happy_var_3 happy_var_5)) - ) `HappyStk` happyRest}}}}} - -happyReduce_595 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_595 = happySpecReduce_3 211# happyReduction_595 -happyReduction_595 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut217 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut223 happy_x_3 of { happy_var_3 -> - happyIn227 - (([mj AnnVbar happy_var_2],mkHsComp PArrComp (unLoc happy_var_3) happy_var_1) - )}}} - -happyReduce_596 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_596 = happySpecReduce_1 212# happyReduction_596 -happyReduction_596 happy_x_1 - = case happyOut229 happy_x_1 of { happy_var_1 -> - happyIn228 - (L (getLoc happy_var_1) (reverse (unLoc happy_var_1)) - )} - -happyReduce_597 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_597 = happyMonadReduce 3# 213# happyReduction_597 -happyReduction_597 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut229 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut247 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma - (gl happy_var_2) >> - return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}}) - ) (\r -> happyReturn (happyIn229 r)) - -happyReduce_598 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_598 = happySpecReduce_1 213# happyReduction_598 -happyReduction_598 happy_x_1 - = case happyOut247 happy_x_1 of { happy_var_1 -> - happyIn229 - (sL1 happy_var_1 [happy_var_1] - )} - -happyReduce_599 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_599 = happySpecReduce_3 214# happyReduction_599 -happyReduction_599 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut231 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn230 - (sLL happy_var_1 happy_var_3 ((moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2)) - ,(reverse (snd $ unLoc happy_var_2))) - )}}} - -happyReduce_600 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_600 = happySpecReduce_3 214# happyReduction_600 -happyReduction_600 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut231 happy_x_2 of { happy_var_2 -> - happyIn230 - (L (getLoc happy_var_2) (fst $ unLoc happy_var_2 - ,(reverse (snd $ unLoc happy_var_2))) - )} - -happyReduce_601 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_601 = happySpecReduce_2 214# happyReduction_601 -happyReduction_601 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn230 - (noLoc ([moc happy_var_1,mcc happy_var_2],[]) - )}} - -happyReduce_602 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_602 = happySpecReduce_2 214# happyReduction_602 -happyReduction_602 happy_x_2 - happy_x_1 - = happyIn230 - (noLoc ([],[]) - ) - -happyReduce_603 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_603 = happySpecReduce_1 215# happyReduction_603 -happyReduction_603 happy_x_1 - = case happyOut232 happy_x_1 of { happy_var_1 -> - happyIn231 - (sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) - )} - -happyReduce_604 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_604 = happySpecReduce_2 215# happyReduction_604 -happyReduction_604 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut231 happy_x_2 of { happy_var_2 -> - happyIn231 - (sLL happy_var_1 happy_var_2 ((mj AnnSemi happy_var_1:(fst $ unLoc happy_var_2)) - ,snd $ unLoc happy_var_2) - )}} - -happyReduce_605 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_605 = happyMonadReduce 3# 216# happyReduction_605 -happyReduction_605 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut232 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut233 happy_x_3 of { happy_var_3 -> - ( if null (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) - ,[happy_var_3])) - else (ams (head $ snd $ unLoc happy_var_1) - (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1)) - >> return (sLL happy_var_1 happy_var_3 ([],happy_var_3 : (snd $ unLoc happy_var_1))) ))}}}) - ) (\r -> happyReturn (happyIn232 r)) - -happyReduce_606 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_606 = happyMonadReduce 2# 216# happyReduction_606 -happyReduction_606 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut232 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( if null (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) - ,snd $ unLoc happy_var_1)) - else (ams (head $ snd $ unLoc happy_var_1) - (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1)) - >> return (sLL happy_var_1 happy_var_2 ([],snd $ unLoc happy_var_1))))}}) - ) (\r -> happyReturn (happyIn232 r)) - -happyReduce_607 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_607 = happySpecReduce_1 216# happyReduction_607 -happyReduction_607 happy_x_1 - = case happyOut233 happy_x_1 of { happy_var_1 -> - happyIn232 - (sL1 happy_var_1 ([],[happy_var_1]) - )} - -happyReduce_608 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_608 = happyMonadReduce 3# 217# happyReduction_608 -happyReduction_608 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut239 happy_x_1 of { happy_var_1 -> - case happyOut142 happy_x_2 of { happy_var_2 -> - case happyOut234 happy_x_3 of { happy_var_3 -> - (ams (sLL happy_var_1 happy_var_3 (Match { m_ctxt = CaseAlt - , m_pats = [happy_var_1] - , m_type = snd happy_var_2 - , m_grhss = snd $ unLoc happy_var_3 })) - (fst happy_var_2 ++ (fst $ unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn233 r)) - -happyReduce_609 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_609 = happySpecReduce_2 218# happyReduction_609 -happyReduction_609 happy_x_2 - happy_x_1 - = case happyOut235 happy_x_1 of { happy_var_1 -> - case happyOut122 happy_x_2 of { happy_var_2 -> - happyIn234 - (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_2, - GRHSs (unLoc happy_var_1) (snd $ unLoc happy_var_2)) - )}} - -happyReduce_610 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_610 = happyMonadReduce 2# 219# happyReduction_610 -happyReduction_610 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 (unguardedRHS (comb2 happy_var_1 happy_var_2) happy_var_2)) - [mu AnnRarrow happy_var_1])}}) - ) (\r -> happyReturn (happyIn235 r)) - -happyReduce_611 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_611 = happySpecReduce_1 219# happyReduction_611 -happyReduction_611 happy_x_1 - = case happyOut236 happy_x_1 of { happy_var_1 -> - happyIn235 - (sL1 happy_var_1 (reverse (unLoc happy_var_1)) - )} - -happyReduce_612 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_612 = happySpecReduce_2 220# happyReduction_612 -happyReduction_612 happy_x_2 - happy_x_1 - = case happyOut236 happy_x_1 of { happy_var_1 -> - case happyOut238 happy_x_2 of { happy_var_2 -> - happyIn236 - (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) - )}} - -happyReduce_613 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_613 = happySpecReduce_1 220# happyReduction_613 -happyReduction_613 happy_x_1 - = case happyOut238 happy_x_1 of { happy_var_1 -> - happyIn236 - (sL1 happy_var_1 [happy_var_1] - )} - -happyReduce_614 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_614 = happySpecReduce_3 221# happyReduction_614 -happyReduction_614 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut236 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn237 - (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3],unLoc happy_var_2) - )}}} - -happyReduce_615 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_615 = happySpecReduce_2 221# happyReduction_615 -happyReduction_615 happy_x_2 - happy_x_1 - = case happyOut236 happy_x_1 of { happy_var_1 -> - happyIn237 - (sL1 happy_var_1 ([],unLoc happy_var_1) - )} - -happyReduce_616 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_616 = happyMonadReduce 4# 222# happyReduction_616 -happyReduction_616 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut228 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut200 happy_x_4 of { happy_var_4 -> - ( ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS (unLoc happy_var_2) happy_var_4) - [mj AnnVbar happy_var_1,mu AnnRarrow happy_var_3])}}}}) - ) (\r -> happyReturn (happyIn238 r)) - -happyReduce_617 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_617 = happyMonadReduce 1# 223# happyReduction_617 -happyReduction_617 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut200 happy_x_1 of { happy_var_1 -> - ( checkPattern empty happy_var_1)}) - ) (\r -> happyReturn (happyIn239 r)) - -happyReduce_618 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_618 = happyMonadReduce 2# 223# happyReduction_618 -happyReduction_618 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut209 happy_x_2 of { happy_var_2 -> - ( amms (checkPattern empty (sLL happy_var_1 happy_var_2 (SectionR - (sL1 happy_var_1 (HsVar (sL1 happy_var_1 bang_RDR))) happy_var_2))) - [mj AnnBang happy_var_1])}}) - ) (\r -> happyReturn (happyIn239 r)) - -happyReduce_619 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_619 = happyMonadReduce 1# 224# happyReduction_619 -happyReduction_619 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut200 happy_x_1 of { happy_var_1 -> - ( checkPattern - (text "Possibly caused by a missing 'do'?") happy_var_1)}) - ) (\r -> happyReturn (happyIn240 r)) - -happyReduce_620 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_620 = happyMonadReduce 2# 224# happyReduction_620 -happyReduction_620 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut209 happy_x_2 of { happy_var_2 -> - ( amms (checkPattern - (text "Possibly caused by a missing 'do'?") - (sLL happy_var_1 happy_var_2 (SectionR (sL1 happy_var_1 (HsVar (sL1 happy_var_1 bang_RDR))) happy_var_2))) - [mj AnnBang happy_var_1])}}) - ) (\r -> happyReturn (happyIn240 r)) - -happyReduce_621 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_621 = happyMonadReduce 1# 225# happyReduction_621 -happyReduction_621 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut209 happy_x_1 of { happy_var_1 -> - ( checkPattern empty happy_var_1)}) - ) (\r -> happyReturn (happyIn241 r)) - -happyReduce_622 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_622 = happyMonadReduce 2# 225# happyReduction_622 -happyReduction_622 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut209 happy_x_2 of { happy_var_2 -> - ( amms (checkPattern empty - (sLL happy_var_1 happy_var_2 (SectionR - (sL1 happy_var_1 (HsVar (sL1 happy_var_1 bang_RDR))) happy_var_2))) - [mj AnnBang happy_var_1])}}) - ) (\r -> happyReturn (happyIn241 r)) - -happyReduce_623 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_623 = happySpecReduce_2 226# happyReduction_623 -happyReduction_623 happy_x_2 - happy_x_1 - = case happyOut241 happy_x_1 of { happy_var_1 -> - case happyOut242 happy_x_2 of { happy_var_2 -> - happyIn242 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_624 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_624 = happySpecReduce_0 226# happyReduction_624 -happyReduction_624 = happyIn242 - ([] - ) - -happyReduce_625 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_625 = happySpecReduce_3 227# happyReduction_625 -happyReduction_625 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut244 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn243 - (sLL happy_var_1 happy_var_3 ((moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2)) - ,(reverse $ snd $ unLoc happy_var_2)) - )}}} - -happyReduce_626 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_626 = happySpecReduce_3 227# happyReduction_626 -happyReduction_626 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut244 happy_x_2 of { happy_var_2 -> - happyIn243 - (L (gl happy_var_2) (fst $ unLoc happy_var_2 - ,reverse $ snd $ unLoc happy_var_2) - )} - -happyReduce_627 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_627 = happyMonadReduce 3# 228# happyReduction_627 -happyReduction_627 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut244 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut246 happy_x_3 of { happy_var_3 -> - ( if null (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) - ,happy_var_3 : (snd $ unLoc happy_var_1))) - else do - { ams (head $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] - ; return $ sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,happy_var_3 :(snd $ unLoc happy_var_1)) })}}}) - ) (\r -> happyReturn (happyIn244 r)) - -happyReduce_628 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_628 = happyMonadReduce 2# 228# happyReduction_628 -happyReduction_628 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut244 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( if null (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1),snd $ unLoc happy_var_1)) - else do - { ams (head $ snd $ unLoc happy_var_1) - [mj AnnSemi happy_var_2] - ; return happy_var_1 })}}) - ) (\r -> happyReturn (happyIn244 r)) - -happyReduce_629 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_629 = happySpecReduce_1 228# happyReduction_629 -happyReduction_629 happy_x_1 - = case happyOut246 happy_x_1 of { happy_var_1 -> - happyIn244 - (sL1 happy_var_1 ([],[happy_var_1]) - )} - -happyReduce_630 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_630 = happySpecReduce_0 228# happyReduction_630 -happyReduction_630 = happyIn244 - (noLoc ([],[]) - ) - -happyReduce_631 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_631 = happySpecReduce_1 229# happyReduction_631 -happyReduction_631 happy_x_1 - = case happyOut246 happy_x_1 of { happy_var_1 -> - happyIn245 - (Just happy_var_1 - )} - -happyReduce_632 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_632 = happySpecReduce_0 229# happyReduction_632 -happyReduction_632 = happyIn245 - (Nothing - ) - -happyReduce_633 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_633 = happySpecReduce_1 230# happyReduction_633 -happyReduction_633 happy_x_1 - = case happyOut247 happy_x_1 of { happy_var_1 -> - happyIn246 - (happy_var_1 - )} - -happyReduce_634 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_634 = happyMonadReduce 2# 230# happyReduction_634 -happyReduction_634 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut243 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ mkRecStmt (snd $ unLoc happy_var_2)) - (mj AnnRec happy_var_1:(fst $ unLoc happy_var_2)))}}) - ) (\r -> happyReturn (happyIn246 r)) - -happyReduce_635 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_635 = happyMonadReduce 3# 231# happyReduction_635 -happyReduction_635 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut240 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut200 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ mkBindStmt happy_var_1 happy_var_3) - [mu AnnLarrow happy_var_2])}}}) - ) (\r -> happyReturn (happyIn247 r)) - -happyReduce_636 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_636 = happySpecReduce_1 231# happyReduction_636 -happyReduction_636 happy_x_1 - = case happyOut200 happy_x_1 of { happy_var_1 -> - happyIn247 - (sL1 happy_var_1 $ mkBodyStmt happy_var_1 - )} - -happyReduce_637 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_637 = happyMonadReduce 2# 231# happyReduction_637 -happyReduction_637 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut121 happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2$ LetStmt (snd $ unLoc happy_var_2)) - (mj AnnLet happy_var_1:(fst $ unLoc happy_var_2)))}}) - ) (\r -> happyReturn (happyIn247 r)) - -happyReduce_638 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_638 = happySpecReduce_1 232# happyReduction_638 -happyReduction_638 happy_x_1 - = case happyOut249 happy_x_1 of { happy_var_1 -> - happyIn248 - (happy_var_1 - )} - -happyReduce_639 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_639 = happySpecReduce_0 232# happyReduction_639 -happyReduction_639 = happyIn248 - (([],([], False)) - ) - -happyReduce_640 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_640 = happyMonadReduce 3# 233# happyReduction_640 -happyReduction_640 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut250 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut249 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> - return (case happy_var_3 of (ma,(flds, dd)) -> (ma,(happy_var_1 : flds, dd))))}}}) - ) (\r -> happyReturn (happyIn249 r)) - -happyReduce_641 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_641 = happySpecReduce_1 233# happyReduction_641 -happyReduction_641 happy_x_1 - = case happyOut250 happy_x_1 of { happy_var_1 -> - happyIn249 - (([],([happy_var_1], False)) - )} - -happyReduce_642 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_642 = happySpecReduce_1 233# happyReduction_642 -happyReduction_642 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn249 - (([mj AnnDotdot happy_var_1],([], True)) - )} - -happyReduce_643 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_643 = happyMonadReduce 3# 234# happyReduction_643 -happyReduction_643 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut291 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut217 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsRecField (sL1 happy_var_1 $ mkFieldOcc happy_var_1) happy_var_3 False) - [mj AnnEqual happy_var_2])}}}) - ) (\r -> happyReturn (happyIn250 r)) - -happyReduce_644 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_644 = happySpecReduce_1 234# happyReduction_644 -happyReduction_644 happy_x_1 - = case happyOut291 happy_x_1 of { happy_var_1 -> - happyIn250 - (sLL happy_var_1 happy_var_1 $ HsRecField (sL1 happy_var_1 $ mkFieldOcc happy_var_1) placeHolderPunRhs True - )} - -happyReduce_645 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_645 = happyMonadReduce 3# 235# happyReduction_645 -happyReduction_645 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut251 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut252 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl $ last $ unLoc happy_var_1) AnnSemi (gl happy_var_2) >> - return (let { this = happy_var_3; rest = unLoc happy_var_1 } - in rest `seq` this `seq` sLL happy_var_1 happy_var_3 (this : rest)))}}}) - ) (\r -> happyReturn (happyIn251 r)) - -happyReduce_646 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_646 = happyMonadReduce 2# 235# happyReduction_646 -happyReduction_646 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut251 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( addAnnotation (gl $ last $ unLoc happy_var_1) AnnSemi (gl happy_var_2) >> - return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}}) - ) (\r -> happyReturn (happyIn251 r)) - -happyReduce_647 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_647 = happySpecReduce_1 235# happyReduction_647 -happyReduction_647 happy_x_1 - = case happyOut252 happy_x_1 of { happy_var_1 -> - happyIn251 - (let this = happy_var_1 in this `seq` sL1 happy_var_1 [this] - )} - -happyReduce_648 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_648 = happyMonadReduce 3# 236# happyReduction_648 -happyReduction_648 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut253 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut200 happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (IPBind (Left happy_var_1) happy_var_3)) - [mj AnnEqual happy_var_2])}}}) - ) (\r -> happyReturn (happyIn252 r)) - -happyReduce_649 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_649 = happySpecReduce_1 237# happyReduction_649 -happyReduction_649 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn253 - (sL1 happy_var_1 (HsIPName (getIPDUPVARID happy_var_1)) - )} - -happyReduce_650 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_650 = happySpecReduce_1 238# happyReduction_650 -happyReduction_650 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn254 - (sL1 happy_var_1 (getLABELVARID happy_var_1) - )} - -happyReduce_651 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_651 = happySpecReduce_1 239# happyReduction_651 -happyReduction_651 happy_x_1 - = case happyOut256 happy_x_1 of { happy_var_1 -> - happyIn255 - (happy_var_1 - )} - -happyReduce_652 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_652 = happySpecReduce_0 239# happyReduction_652 -happyReduction_652 = happyIn255 - (noLoc mkTrue - ) - -happyReduce_653 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_653 = happySpecReduce_1 240# happyReduction_653 -happyReduction_653 happy_x_1 - = case happyOut257 happy_x_1 of { happy_var_1 -> - happyIn256 - (happy_var_1 - )} - -happyReduce_654 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_654 = happyMonadReduce 3# 240# happyReduction_654 -happyReduction_654 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut257 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut256 happy_x_3 of { happy_var_3 -> - ( aa happy_var_1 (AnnVbar, happy_var_2) - >> return (sLL happy_var_1 happy_var_3 (Or [happy_var_1,happy_var_3])))}}}) - ) (\r -> happyReturn (happyIn256 r)) - -happyReduce_655 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_655 = happySpecReduce_1 241# happyReduction_655 -happyReduction_655 happy_x_1 - = case happyOut258 happy_x_1 of { happy_var_1 -> - happyIn257 - (sLL (head happy_var_1) (last happy_var_1) (And (happy_var_1)) - )} - -happyReduce_656 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_656 = happySpecReduce_1 242# happyReduction_656 -happyReduction_656 happy_x_1 - = case happyOut259 happy_x_1 of { happy_var_1 -> - happyIn258 - ([happy_var_1] - )} - -happyReduce_657 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_657 = happyMonadReduce 3# 242# happyReduction_657 -happyReduction_657 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut259 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut258 happy_x_3 of { happy_var_3 -> - ( aa happy_var_1 (AnnComma, happy_var_2) >> return (happy_var_1 : happy_var_3))}}}) - ) (\r -> happyReturn (happyIn258 r)) - -happyReduce_658 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_658 = happyMonadReduce 3# 243# happyReduction_658 -happyReduction_658 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut256 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (Parens happy_var_2)) [mop happy_var_1,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn259 r)) - -happyReduce_659 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_659 = happySpecReduce_1 243# happyReduction_659 -happyReduction_659 happy_x_1 - = case happyOut261 happy_x_1 of { happy_var_1 -> - happyIn259 - (sL1 happy_var_1 (Var happy_var_1) - )} - -happyReduce_660 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_660 = happySpecReduce_1 244# happyReduction_660 -happyReduction_660 happy_x_1 - = case happyOut261 happy_x_1 of { happy_var_1 -> - happyIn260 - (sL1 happy_var_1 [happy_var_1] - )} - -happyReduce_661 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_661 = happyMonadReduce 3# 244# happyReduction_661 -happyReduction_661 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut261 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut260 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> - return (sLL happy_var_1 happy_var_3 (happy_var_1 : unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn260 r)) - -happyReduce_662 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_662 = happySpecReduce_1 245# happyReduction_662 -happyReduction_662 happy_x_1 - = case happyOut290 happy_x_1 of { happy_var_1 -> - happyIn261 - (happy_var_1 - )} - -happyReduce_663 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_663 = happySpecReduce_1 245# happyReduction_663 -happyReduction_663 happy_x_1 - = case happyOut265 happy_x_1 of { happy_var_1 -> - happyIn261 - (happy_var_1 - )} - -happyReduce_664 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_664 = happySpecReduce_1 246# happyReduction_664 -happyReduction_664 happy_x_1 - = case happyOut264 happy_x_1 of { happy_var_1 -> - happyIn262 - (happy_var_1 - )} - -happyReduce_665 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_665 = happySpecReduce_1 246# happyReduction_665 -happyReduction_665 happy_x_1 - = case happyOut267 happy_x_1 of { happy_var_1 -> - happyIn262 - (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) - )} - -happyReduce_666 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_666 = happySpecReduce_1 247# happyReduction_666 -happyReduction_666 happy_x_1 - = case happyOut264 happy_x_1 of { happy_var_1 -> - happyIn263 - (happy_var_1 - )} - -happyReduce_667 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_667 = happySpecReduce_1 247# happyReduction_667 -happyReduction_667 happy_x_1 - = case happyOut268 happy_x_1 of { happy_var_1 -> - happyIn263 - (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) - )} - -happyReduce_668 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_668 = happySpecReduce_1 248# happyReduction_668 -happyReduction_668 happy_x_1 - = case happyOut301 happy_x_1 of { happy_var_1 -> - happyIn264 - (happy_var_1 - )} - -happyReduce_669 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_669 = happyMonadReduce 3# 248# happyReduction_669 -happyReduction_669 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut303 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn264 r)) - -happyReduce_670 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_670 = happySpecReduce_1 249# happyReduction_670 -happyReduction_670 happy_x_1 - = case happyOut302 happy_x_1 of { happy_var_1 -> - happyIn265 - (happy_var_1 - )} - -happyReduce_671 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_671 = happyMonadReduce 3# 249# happyReduction_671 -happyReduction_671 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut304 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn265 r)) - -happyReduce_672 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_672 = happySpecReduce_1 249# happyReduction_672 -happyReduction_672 happy_x_1 - = case happyOut268 happy_x_1 of { happy_var_1 -> - happyIn265 - (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) - )} - -happyReduce_673 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_673 = happySpecReduce_1 250# happyReduction_673 -happyReduction_673 happy_x_1 - = case happyOut265 happy_x_1 of { happy_var_1 -> - happyIn266 - (sL1 happy_var_1 [happy_var_1] - )} - -happyReduce_674 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_674 = happyMonadReduce 3# 250# happyReduction_674 -happyReduction_674 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut265 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut266 happy_x_3 of { happy_var_3 -> - ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> - return (sLL happy_var_1 happy_var_3 (happy_var_1 : unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn266 r)) - -happyReduce_675 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_675 = happyMonadReduce 2# 251# happyReduction_675 -happyReduction_675 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 unitDataCon) [mop happy_var_1,mcp happy_var_2])}}) - ) (\r -> happyReturn (happyIn267 r)) - -happyReduce_676 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_676 = happyMonadReduce 3# 251# happyReduction_676 -happyReduction_676 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut308 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ tupleDataCon Boxed (snd happy_var_2 + 1)) - (mop happy_var_1:mcp happy_var_3:(mcommas (fst happy_var_2))))}}}) - ) (\r -> happyReturn (happyIn267 r)) - -happyReduce_677 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_677 = happyMonadReduce 2# 251# happyReduction_677 -happyReduction_677 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ unboxedUnitDataCon) [mo happy_var_1,mc happy_var_2])}}) - ) (\r -> happyReturn (happyIn267 r)) - -happyReduce_678 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_678 = happyMonadReduce 3# 251# happyReduction_678 -happyReduction_678 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut308 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ tupleDataCon Unboxed (snd happy_var_2 + 1)) - (mo happy_var_1:mc happy_var_3:(mcommas (fst happy_var_2))))}}}) - ) (\r -> happyReturn (happyIn267 r)) - -happyReduce_679 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_679 = happySpecReduce_1 252# happyReduction_679 -happyReduction_679 happy_x_1 - = case happyOut267 happy_x_1 of { happy_var_1 -> - happyIn268 - (happy_var_1 - )} - -happyReduce_680 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_680 = happyMonadReduce 2# 252# happyReduction_680 -happyReduction_680 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 nilDataCon) [mos happy_var_1,mcs happy_var_2])}}) - ) (\r -> happyReturn (happyIn268 r)) - -happyReduce_681 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_681 = happySpecReduce_1 253# happyReduction_681 -happyReduction_681 happy_x_1 - = case happyOut304 happy_x_1 of { happy_var_1 -> - happyIn269 - (happy_var_1 - )} - -happyReduce_682 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_682 = happyMonadReduce 3# 253# happyReduction_682 -happyReduction_682 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut302 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 - ,mj AnnBackquote happy_var_3])}}}) - ) (\r -> happyReturn (happyIn269 r)) - -happyReduce_683 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_683 = happySpecReduce_1 254# happyReduction_683 -happyReduction_683 happy_x_1 - = case happyOut303 happy_x_1 of { happy_var_1 -> - happyIn270 - (happy_var_1 - )} - -happyReduce_684 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_684 = happyMonadReduce 3# 254# happyReduction_684 -happyReduction_684 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut301 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 - ,mj AnnBackquote happy_var_3])}}}) - ) (\r -> happyReturn (happyIn270 r)) - -happyReduce_685 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_685 = happySpecReduce_1 255# happyReduction_685 -happyReduction_685 happy_x_1 - = case happyOut272 happy_x_1 of { happy_var_1 -> - happyIn271 - (happy_var_1 - )} - -happyReduce_686 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_686 = happyMonadReduce 2# 255# happyReduction_686 -happyReduction_686 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ getRdrName unitTyCon) - [mop happy_var_1,mcp happy_var_2])}}) - ) (\r -> happyReturn (happyIn271 r)) - -happyReduce_687 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_687 = happyMonadReduce 2# 255# happyReduction_687 -happyReduction_687 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ getRdrName unboxedUnitTyCon) - [mo happy_var_1,mc happy_var_2])}}) - ) (\r -> happyReturn (happyIn271 r)) - -happyReduce_688 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_688 = happySpecReduce_1 256# happyReduction_688 -happyReduction_688 happy_x_1 - = case happyOut273 happy_x_1 of { happy_var_1 -> - happyIn272 - (happy_var_1 - )} - -happyReduce_689 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_689 = happyMonadReduce 3# 256# happyReduction_689 -happyReduction_689 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut308 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Boxed - (snd happy_var_2 + 1))) - (mop happy_var_1:mcp happy_var_3:(mcommas (fst happy_var_2))))}}}) - ) (\r -> happyReturn (happyIn272 r)) - -happyReduce_690 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_690 = happyMonadReduce 3# 256# happyReduction_690 -happyReduction_690 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut308 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Unboxed - (snd happy_var_2 + 1))) - (mo happy_var_1:mc happy_var_3:(mcommas (fst happy_var_2))))}}}) - ) (\r -> happyReturn (happyIn272 r)) - -happyReduce_691 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_691 = happyMonadReduce 3# 256# happyReduction_691 -happyReduction_691 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ getRdrName funTyCon) - [mop happy_var_1,mu AnnRarrow happy_var_2,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn272 r)) - -happyReduce_692 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_692 = happyMonadReduce 2# 256# happyReduction_692 -happyReduction_692 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ listTyCon_RDR) [mos happy_var_1,mcs happy_var_2])}}) - ) (\r -> happyReturn (happyIn272 r)) - -happyReduce_693 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_693 = happyMonadReduce 2# 256# happyReduction_693 -happyReduction_693 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ parrTyCon_RDR) [mo happy_var_1,mc happy_var_2])}}) - ) (\r -> happyReturn (happyIn272 r)) - -happyReduce_694 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_694 = happyMonadReduce 3# 256# happyReduction_694 -happyReduction_694 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ getRdrName eqPrimTyCon) - [mop happy_var_1,mj AnnTildehsh happy_var_2,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn272 r)) - -happyReduce_695 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_695 = happySpecReduce_1 257# happyReduction_695 -happyReduction_695 happy_x_1 - = case happyOut276 happy_x_1 of { happy_var_1 -> - happyIn273 - (happy_var_1 - )} - -happyReduce_696 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_696 = happyMonadReduce 3# 257# happyReduction_696 -happyReduction_696 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut279 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn273 r)) - -happyReduce_697 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_697 = happyMonadReduce 3# 257# happyReduction_697 -happyReduction_697 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ eqTyCon_RDR) - [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn273 r)) - -happyReduce_698 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_698 = happySpecReduce_1 258# happyReduction_698 -happyReduction_698 happy_x_1 - = case happyOut276 happy_x_1 of { happy_var_1 -> - happyIn274 - (happy_var_1 - )} - -happyReduce_699 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_699 = happyMonadReduce 3# 258# happyReduction_699 -happyReduction_699 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( let name = sL1 happy_var_2 $! mkQual tcClsName (getQCONSYM happy_var_2) - in ams (sLL happy_var_1 happy_var_3 (unLoc name)) [mop happy_var_1,mj AnnVal name,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn274 r)) - -happyReduce_700 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_700 = happyMonadReduce 3# 258# happyReduction_700 -happyReduction_700 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( let name = sL1 happy_var_2 $! mkUnqual tcClsName (getCONSYM happy_var_2) - in ams (sLL happy_var_1 happy_var_3 (unLoc name)) [mop happy_var_1,mj AnnVal name,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn274 r)) - -happyReduce_701 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_701 = happyMonadReduce 3# 258# happyReduction_701 -happyReduction_701 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( let name = sL1 happy_var_2 $! consDataCon_RDR - in ams (sLL happy_var_1 happy_var_3 (unLoc name)) [mop happy_var_1,mj AnnVal name,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn274 r)) - -happyReduce_702 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_702 = happyMonadReduce 3# 258# happyReduction_702 -happyReduction_702 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ eqTyCon_RDR) [mop happy_var_1,mj AnnTilde happy_var_2,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn274 r)) - -happyReduce_703 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_703 = happySpecReduce_1 259# happyReduction_703 -happyReduction_703 happy_x_1 - = case happyOut279 happy_x_1 of { happy_var_1 -> - happyIn275 - (happy_var_1 - )} - -happyReduce_704 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_704 = happyMonadReduce 3# 259# happyReduction_704 -happyReduction_704 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut276 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 - ,mj AnnBackquote happy_var_3])}}}) - ) (\r -> happyReturn (happyIn275 r)) - -happyReduce_705 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_705 = happySpecReduce_1 260# happyReduction_705 -happyReduction_705 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn276 - (sL1 happy_var_1 $! mkQual tcClsName (getQCONID happy_var_1) - )} - -happyReduce_706 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_706 = happySpecReduce_1 260# happyReduction_706 -happyReduction_706 happy_x_1 - = case happyOut278 happy_x_1 of { happy_var_1 -> - happyIn276 - (happy_var_1 - )} - -happyReduce_707 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_707 = happySpecReduce_1 261# happyReduction_707 -happyReduction_707 happy_x_1 - = case happyOut276 happy_x_1 of { happy_var_1 -> - happyIn277 - (sL1 happy_var_1 (HsTyVar NotPromoted happy_var_1) - )} - -happyReduce_708 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_708 = happySpecReduce_2 261# happyReduction_708 -happyReduction_708 happy_x_2 - happy_x_1 - = case happyOut276 happy_x_1 of { happy_var_1 -> - case happyOut312 happy_x_2 of { happy_var_2 -> - happyIn277 - (sLL happy_var_1 happy_var_2 (HsDocTy (sL1 happy_var_1 (HsTyVar NotPromoted happy_var_1)) happy_var_2) - )}} - -happyReduce_709 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_709 = happySpecReduce_1 262# happyReduction_709 -happyReduction_709 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn278 - (sL1 happy_var_1 $! mkUnqual tcClsName (getCONID happy_var_1) - )} - -happyReduce_710 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_710 = happySpecReduce_1 263# happyReduction_710 -happyReduction_710 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn279 - (sL1 happy_var_1 $! mkQual tcClsName (getQCONSYM happy_var_1) - )} - -happyReduce_711 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_711 = happySpecReduce_1 263# happyReduction_711 -happyReduction_711 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn279 - (sL1 happy_var_1 $! mkQual tcClsName (getQVARSYM happy_var_1) - )} - -happyReduce_712 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_712 = happySpecReduce_1 263# happyReduction_712 -happyReduction_712 happy_x_1 - = case happyOut280 happy_x_1 of { happy_var_1 -> - happyIn279 - (happy_var_1 - )} - -happyReduce_713 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_713 = happySpecReduce_1 264# happyReduction_713 -happyReduction_713 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn280 - (sL1 happy_var_1 $! mkUnqual tcClsName (getCONSYM happy_var_1) - )} - -happyReduce_714 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_714 = happySpecReduce_1 264# happyReduction_714 -happyReduction_714 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn280 - (sL1 happy_var_1 $! mkUnqual tcClsName (getVARSYM happy_var_1) - )} - -happyReduce_715 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_715 = happySpecReduce_1 264# happyReduction_715 -happyReduction_715 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn280 - (sL1 happy_var_1 $! consDataCon_RDR - )} - -happyReduce_716 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_716 = happySpecReduce_1 264# happyReduction_716 -happyReduction_716 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn280 - (sL1 happy_var_1 $! mkUnqual tcClsName (fsLit "-") - )} - -happyReduce_717 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_717 = happySpecReduce_1 265# happyReduction_717 -happyReduction_717 happy_x_1 - = case happyOut282 happy_x_1 of { happy_var_1 -> - happyIn281 - (happy_var_1 - )} - -happyReduce_718 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_718 = happySpecReduce_1 265# happyReduction_718 -happyReduction_718 happy_x_1 - = case happyOut269 happy_x_1 of { happy_var_1 -> - happyIn281 - (happy_var_1 - )} - -happyReduce_719 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_719 = happySpecReduce_1 266# happyReduction_719 -happyReduction_719 happy_x_1 - = case happyOut297 happy_x_1 of { happy_var_1 -> - happyIn282 - (happy_var_1 - )} - -happyReduce_720 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_720 = happyMonadReduce 3# 266# happyReduction_720 -happyReduction_720 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut293 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 - ,mj AnnBackquote happy_var_3])}}}) - ) (\r -> happyReturn (happyIn282 r)) - -happyReduce_721 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_721 = happySpecReduce_1 267# happyReduction_721 -happyReduction_721 happy_x_1 - = case happyOut285 happy_x_1 of { happy_var_1 -> - happyIn283 - (sL1 happy_var_1 $ HsVar happy_var_1 - )} - -happyReduce_722 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_722 = happySpecReduce_1 267# happyReduction_722 -happyReduction_722 happy_x_1 - = case happyOut270 happy_x_1 of { happy_var_1 -> - happyIn283 - (sL1 happy_var_1 $ HsVar happy_var_1 - )} - -happyReduce_723 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_723 = happyMonadReduce 3# 267# happyReduction_723 -happyReduction_723 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 EWildPat) - [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 - ,mj AnnBackquote happy_var_3])}}}) - ) (\r -> happyReturn (happyIn283 r)) - -happyReduce_724 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_724 = happySpecReduce_1 268# happyReduction_724 -happyReduction_724 happy_x_1 - = case happyOut286 happy_x_1 of { happy_var_1 -> - happyIn284 - (sL1 happy_var_1 $ HsVar happy_var_1 - )} - -happyReduce_725 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_725 = happySpecReduce_1 268# happyReduction_725 -happyReduction_725 happy_x_1 - = case happyOut270 happy_x_1 of { happy_var_1 -> - happyIn284 - (sL1 happy_var_1 $ HsVar happy_var_1 - )} - -happyReduce_726 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_726 = happySpecReduce_1 269# happyReduction_726 -happyReduction_726 happy_x_1 - = case happyOut294 happy_x_1 of { happy_var_1 -> - happyIn285 - (happy_var_1 - )} - -happyReduce_727 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_727 = happyMonadReduce 3# 269# happyReduction_727 -happyReduction_727 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut292 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 - ,mj AnnBackquote happy_var_3])}}}) - ) (\r -> happyReturn (happyIn285 r)) - -happyReduce_728 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_728 = happySpecReduce_1 270# happyReduction_728 -happyReduction_728 happy_x_1 - = case happyOut295 happy_x_1 of { happy_var_1 -> - happyIn286 - (happy_var_1 - )} - -happyReduce_729 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_729 = happyMonadReduce 3# 270# happyReduction_729 -happyReduction_729 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut292 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 - ,mj AnnBackquote happy_var_3])}}}) - ) (\r -> happyReturn (happyIn286 r)) - -happyReduce_730 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_730 = happySpecReduce_1 271# happyReduction_730 -happyReduction_730 happy_x_1 - = case happyOut289 happy_x_1 of { happy_var_1 -> - happyIn287 - (happy_var_1 - )} - -happyReduce_731 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_731 = happyMonadReduce 3# 272# happyReduction_731 -happyReduction_731 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut289 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 - ,mj AnnBackquote happy_var_3])}}}) - ) (\r -> happyReturn (happyIn288 r)) - -happyReduce_732 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_732 = happyMonadReduce 1# 272# happyReduction_732 -happyReduction_732 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( hintExplicitForall' (getLoc happy_var_1))}) - ) (\r -> happyReturn (happyIn288 r)) - -happyReduce_733 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_733 = happySpecReduce_1 273# happyReduction_733 -happyReduction_733 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn289 - (sL1 happy_var_1 $! mkUnqual tvName (getVARID happy_var_1) - )} - -happyReduce_734 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_734 = happySpecReduce_1 273# happyReduction_734 -happyReduction_734 happy_x_1 - = case happyOut299 happy_x_1 of { happy_var_1 -> - happyIn289 - (sL1 happy_var_1 $! mkUnqual tvName (unLoc happy_var_1) - )} - -happyReduce_735 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_735 = happySpecReduce_1 273# happyReduction_735 -happyReduction_735 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn289 - (sL1 happy_var_1 $! mkUnqual tvName (fsLit "unsafe") - )} - -happyReduce_736 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_736 = happySpecReduce_1 273# happyReduction_736 -happyReduction_736 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn289 - (sL1 happy_var_1 $! mkUnqual tvName (fsLit "safe") - )} - -happyReduce_737 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_737 = happySpecReduce_1 273# happyReduction_737 -happyReduction_737 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn289 - (sL1 happy_var_1 $! mkUnqual tvName (fsLit "interruptible") - )} - -happyReduce_738 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_738 = happySpecReduce_1 274# happyReduction_738 -happyReduction_738 happy_x_1 - = case happyOut293 happy_x_1 of { happy_var_1 -> - happyIn290 - (happy_var_1 - )} - -happyReduce_739 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_739 = happyMonadReduce 3# 274# happyReduction_739 -happyReduction_739 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut297 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn290 r)) - -happyReduce_740 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_740 = happySpecReduce_1 275# happyReduction_740 -happyReduction_740 happy_x_1 - = case happyOut292 happy_x_1 of { happy_var_1 -> - happyIn291 - (happy_var_1 - )} - -happyReduce_741 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_741 = happyMonadReduce 3# 275# happyReduction_741 -happyReduction_741 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut297 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn291 r)) - -happyReduce_742 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_742 = happyMonadReduce 3# 275# happyReduction_742 -happyReduction_742 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut296 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) - ) (\r -> happyReturn (happyIn291 r)) - -happyReduce_743 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_743 = happySpecReduce_1 276# happyReduction_743 -happyReduction_743 happy_x_1 - = case happyOut293 happy_x_1 of { happy_var_1 -> - happyIn292 - (happy_var_1 - )} - -happyReduce_744 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_744 = happySpecReduce_1 276# happyReduction_744 -happyReduction_744 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn292 - (sL1 happy_var_1 $! mkQual varName (getQVARID happy_var_1) - )} - -happyReduce_745 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_745 = happySpecReduce_1 277# happyReduction_745 -happyReduction_745 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn293 - (sL1 happy_var_1 $! mkUnqual varName (getVARID happy_var_1) - )} - -happyReduce_746 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_746 = happySpecReduce_1 277# happyReduction_746 -happyReduction_746 happy_x_1 - = case happyOut299 happy_x_1 of { happy_var_1 -> - happyIn293 - (sL1 happy_var_1 $! mkUnqual varName (unLoc happy_var_1) - )} - -happyReduce_747 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_747 = happySpecReduce_1 277# happyReduction_747 -happyReduction_747 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn293 - (sL1 happy_var_1 $! mkUnqual varName (fsLit "unsafe") - )} - -happyReduce_748 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_748 = happySpecReduce_1 277# happyReduction_748 -happyReduction_748 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn293 - (sL1 happy_var_1 $! mkUnqual varName (fsLit "safe") - )} - -happyReduce_749 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_749 = happySpecReduce_1 277# happyReduction_749 -happyReduction_749 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn293 - (sL1 happy_var_1 $! mkUnqual varName (fsLit "interruptible") - )} - -happyReduce_750 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_750 = happySpecReduce_1 277# happyReduction_750 -happyReduction_750 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn293 - (sL1 happy_var_1 $! mkUnqual varName (fsLit "forall") - )} - -happyReduce_751 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_751 = happySpecReduce_1 277# happyReduction_751 -happyReduction_751 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn293 - (sL1 happy_var_1 $! mkUnqual varName (fsLit "family") - )} - -happyReduce_752 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_752 = happySpecReduce_1 277# happyReduction_752 -happyReduction_752 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn293 - (sL1 happy_var_1 $! mkUnqual varName (fsLit "role") - )} - -happyReduce_753 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_753 = happySpecReduce_1 278# happyReduction_753 -happyReduction_753 happy_x_1 - = case happyOut297 happy_x_1 of { happy_var_1 -> - happyIn294 - (happy_var_1 - )} - -happyReduce_754 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_754 = happySpecReduce_1 278# happyReduction_754 -happyReduction_754 happy_x_1 - = case happyOut296 happy_x_1 of { happy_var_1 -> - happyIn294 - (happy_var_1 - )} - -happyReduce_755 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_755 = happySpecReduce_1 279# happyReduction_755 -happyReduction_755 happy_x_1 - = case happyOut298 happy_x_1 of { happy_var_1 -> - happyIn295 - (happy_var_1 - )} - -happyReduce_756 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_756 = happySpecReduce_1 279# happyReduction_756 -happyReduction_756 happy_x_1 - = case happyOut296 happy_x_1 of { happy_var_1 -> - happyIn295 - (happy_var_1 - )} - -happyReduce_757 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_757 = happySpecReduce_1 280# happyReduction_757 -happyReduction_757 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn296 - (sL1 happy_var_1 $ mkQual varName (getQVARSYM happy_var_1) - )} - -happyReduce_758 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_758 = happySpecReduce_1 281# happyReduction_758 -happyReduction_758 happy_x_1 - = case happyOut298 happy_x_1 of { happy_var_1 -> - happyIn297 - (happy_var_1 - )} - -happyReduce_759 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_759 = happySpecReduce_1 281# happyReduction_759 -happyReduction_759 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn297 - (sL1 happy_var_1 $ mkUnqual varName (fsLit "-") - )} - -happyReduce_760 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_760 = happySpecReduce_1 282# happyReduction_760 -happyReduction_760 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn298 - (sL1 happy_var_1 $ mkUnqual varName (getVARSYM happy_var_1) - )} - -happyReduce_761 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_761 = happySpecReduce_1 282# happyReduction_761 -happyReduction_761 happy_x_1 - = case happyOut300 happy_x_1 of { happy_var_1 -> - happyIn298 - (sL1 happy_var_1 $ mkUnqual varName (unLoc happy_var_1) - )} - -happyReduce_762 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_762 = happySpecReduce_1 283# happyReduction_762 -happyReduction_762 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "as") - )} - -happyReduce_763 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_763 = happySpecReduce_1 283# happyReduction_763 -happyReduction_763 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "qualified") - )} - -happyReduce_764 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_764 = happySpecReduce_1 283# happyReduction_764 -happyReduction_764 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "hiding") - )} - -happyReduce_765 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_765 = happySpecReduce_1 283# happyReduction_765 -happyReduction_765 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "export") - )} - -happyReduce_766 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_766 = happySpecReduce_1 283# happyReduction_766 -happyReduction_766 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "label") - )} - -happyReduce_767 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_767 = happySpecReduce_1 283# happyReduction_767 -happyReduction_767 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "dynamic") - )} - -happyReduce_768 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_768 = happySpecReduce_1 283# happyReduction_768 -happyReduction_768 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "stdcall") - )} - -happyReduce_769 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_769 = happySpecReduce_1 283# happyReduction_769 -happyReduction_769 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "ccall") - )} - -happyReduce_770 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_770 = happySpecReduce_1 283# happyReduction_770 -happyReduction_770 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "capi") - )} - -happyReduce_771 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_771 = happySpecReduce_1 283# happyReduction_771 -happyReduction_771 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "prim") - )} - -happyReduce_772 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_772 = happySpecReduce_1 283# happyReduction_772 -happyReduction_772 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "javascript") - )} - -happyReduce_773 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_773 = happySpecReduce_1 283# happyReduction_773 -happyReduction_773 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "group") - )} - -happyReduce_774 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_774 = happySpecReduce_1 283# happyReduction_774 -happyReduction_774 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "stock") - )} - -happyReduce_775 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_775 = happySpecReduce_1 283# happyReduction_775 -happyReduction_775 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "anyclass") - )} - -happyReduce_776 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_776 = happySpecReduce_1 283# happyReduction_776 -happyReduction_776 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "unit") - )} - -happyReduce_777 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_777 = happySpecReduce_1 283# happyReduction_777 -happyReduction_777 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "dependency") - )} - -happyReduce_778 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_778 = happySpecReduce_1 283# happyReduction_778 -happyReduction_778 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn299 - (sL1 happy_var_1 (fsLit "signature") - )} - -happyReduce_779 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_779 = happyMonadReduce 1# 284# happyReduction_779 -happyReduction_779 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( ams (sL1 happy_var_1 (fsLit "!")) [mj AnnBang happy_var_1])}) - ) (\r -> happyReturn (happyIn300 r)) - -happyReduce_780 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_780 = happySpecReduce_1 284# happyReduction_780 -happyReduction_780 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn300 - (sL1 happy_var_1 (fsLit ".") - )} - -happyReduce_781 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_781 = happySpecReduce_1 285# happyReduction_781 -happyReduction_781 happy_x_1 - = case happyOut302 happy_x_1 of { happy_var_1 -> - happyIn301 - (happy_var_1 - )} - -happyReduce_782 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_782 = happySpecReduce_1 285# happyReduction_782 -happyReduction_782 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn301 - (sL1 happy_var_1 $! mkQual dataName (getQCONID happy_var_1) - )} - -happyReduce_783 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_783 = happySpecReduce_1 286# happyReduction_783 -happyReduction_783 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn302 - (sL1 happy_var_1 $ mkUnqual dataName (getCONID happy_var_1) - )} - -happyReduce_784 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_784 = happySpecReduce_1 287# happyReduction_784 -happyReduction_784 happy_x_1 - = case happyOut304 happy_x_1 of { happy_var_1 -> - happyIn303 - (happy_var_1 - )} - -happyReduce_785 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_785 = happySpecReduce_1 287# happyReduction_785 -happyReduction_785 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn303 - (sL1 happy_var_1 $ mkQual dataName (getQCONSYM happy_var_1) - )} - -happyReduce_786 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_786 = happySpecReduce_1 288# happyReduction_786 -happyReduction_786 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn304 - (sL1 happy_var_1 $ mkUnqual dataName (getCONSYM happy_var_1) - )} - -happyReduce_787 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_787 = happySpecReduce_1 288# happyReduction_787 -happyReduction_787 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn304 - (sL1 happy_var_1 $ consDataCon_RDR - )} - -happyReduce_788 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_788 = happySpecReduce_1 289# happyReduction_788 -happyReduction_788 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn305 - (sL1 happy_var_1 $ HsChar (getCHARs happy_var_1) $ getCHAR happy_var_1 - )} - -happyReduce_789 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_789 = happySpecReduce_1 289# happyReduction_789 -happyReduction_789 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn305 - (sL1 happy_var_1 $ HsString (getSTRINGs happy_var_1) - $ getSTRING happy_var_1 - )} - -happyReduce_790 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_790 = happySpecReduce_1 289# happyReduction_790 -happyReduction_790 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn305 - (sL1 happy_var_1 $ HsIntPrim (getPRIMINTEGERs happy_var_1) - $ getPRIMINTEGER happy_var_1 - )} - -happyReduce_791 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_791 = happySpecReduce_1 289# happyReduction_791 -happyReduction_791 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn305 - (sL1 happy_var_1 $ HsWordPrim (getPRIMWORDs happy_var_1) - $ getPRIMWORD happy_var_1 - )} - -happyReduce_792 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_792 = happySpecReduce_1 289# happyReduction_792 -happyReduction_792 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn305 - (sL1 happy_var_1 $ HsCharPrim (getPRIMCHARs happy_var_1) - $ getPRIMCHAR happy_var_1 - )} - -happyReduce_793 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_793 = happySpecReduce_1 289# happyReduction_793 -happyReduction_793 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn305 - (sL1 happy_var_1 $ HsStringPrim (getPRIMSTRINGs happy_var_1) - $ getPRIMSTRING happy_var_1 - )} - -happyReduce_794 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_794 = happySpecReduce_1 289# happyReduction_794 -happyReduction_794 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn305 - (sL1 happy_var_1 $ HsFloatPrim $ getPRIMFLOAT happy_var_1 - )} - -happyReduce_795 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_795 = happySpecReduce_1 289# happyReduction_795 -happyReduction_795 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn305 - (sL1 happy_var_1 $ HsDoublePrim $ getPRIMDOUBLE happy_var_1 - )} - -happyReduce_796 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_796 = happySpecReduce_1 290# happyReduction_796 -happyReduction_796 happy_x_1 - = happyIn306 - (() - ) - -happyReduce_797 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_797 = happyMonadReduce 1# 290# happyReduction_797 -happyReduction_797 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((( popContext)) - ) (\r -> happyReturn (happyIn306 r)) - -happyReduce_798 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_798 = happySpecReduce_1 291# happyReduction_798 -happyReduction_798 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 $ mkModuleNameFS (getCONID happy_var_1) - )} - -happyReduce_799 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_799 = happySpecReduce_1 291# happyReduction_799 -happyReduction_799 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in - mkModuleNameFS - (mkFastString - (unpackFS mod ++ '.':unpackFS c)) - )} - -happyReduce_800 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_800 = happySpecReduce_2 292# happyReduction_800 -happyReduction_800 happy_x_2 - happy_x_1 - = case happyOut308 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn308 - (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1) - )}} - -happyReduce_801 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_801 = happySpecReduce_1 292# happyReduction_801 -happyReduction_801 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (([gl happy_var_1],1) - )} - -happyReduce_802 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_802 = happySpecReduce_1 293# happyReduction_802 -happyReduction_802 happy_x_1 - = case happyOut310 happy_x_1 of { happy_var_1 -> - happyIn309 - (happy_var_1 - )} - -happyReduce_803 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_803 = happySpecReduce_0 293# happyReduction_803 -happyReduction_803 = happyIn309 - (([], 0) - ) - -happyReduce_804 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_804 = happySpecReduce_2 294# happyReduction_804 -happyReduction_804 happy_x_2 - happy_x_1 - = case happyOut310 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn310 - (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1) - )}} - -happyReduce_805 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_805 = happySpecReduce_1 294# happyReduction_805 -happyReduction_805 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn310 - (([gl happy_var_1],1) - )} - -happyReduce_806 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_806 = happyMonadReduce 1# 295# happyReduction_806 -happyReduction_806 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( return (sL1 happy_var_1 (HsDocString (mkFastString (getDOCNEXT happy_var_1)))))}) - ) (\r -> happyReturn (happyIn311 r)) - -happyReduce_807 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_807 = happyMonadReduce 1# 296# happyReduction_807 -happyReduction_807 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( return (sL1 happy_var_1 (HsDocString (mkFastString (getDOCPREV happy_var_1)))))}) - ) (\r -> happyReturn (happyIn312 r)) - -happyReduce_808 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_808 = happyMonadReduce 1# 297# happyReduction_808 -happyReduction_808 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( - let string = getDOCNAMED happy_var_1 - (name, rest) = break isSpace string - in return (sL1 happy_var_1 (name, HsDocString (mkFastString rest))))}) - ) (\r -> happyReturn (happyIn313 r)) - -happyReduce_809 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_809 = happyMonadReduce 1# 298# happyReduction_809 -happyReduction_809 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( let (n, doc) = getDOCSECTION happy_var_1 in - return (sL1 happy_var_1 (n, HsDocString (mkFastString doc))))}) - ) (\r -> happyReturn (happyIn314 r)) - -happyReduce_810 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_810 = happyMonadReduce 1# 299# happyReduction_810 -happyReduction_810 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( let string = getDOCNEXT happy_var_1 in - return (Just (sL1 happy_var_1 (HsDocString (mkFastString string)))))}) - ) (\r -> happyReturn (happyIn315 r)) - -happyReduce_811 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_811 = happySpecReduce_1 300# happyReduction_811 -happyReduction_811 happy_x_1 - = case happyOut312 happy_x_1 of { happy_var_1 -> - happyIn316 - (Just happy_var_1 - )} - -happyReduce_812 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_812 = happySpecReduce_0 300# happyReduction_812 -happyReduction_812 = happyIn316 - (Nothing - ) - -happyReduce_813 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_813 = happySpecReduce_1 301# happyReduction_813 -happyReduction_813 happy_x_1 - = case happyOut311 happy_x_1 of { happy_var_1 -> - happyIn317 - (Just happy_var_1 - )} - -happyReduce_814 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_814 = happySpecReduce_0 301# happyReduction_814 -happyReduction_814 = happyIn317 - (Nothing - ) - -happyNewToken action sts stk - = (lexer True)(\tk -> - let cont i = happyDoAction i tk action sts stk in - case tk of { - L _ ITeof -> happyDoAction 155# tk action sts stk; - L _ ITunderscore -> cont 1#; - L _ ITas -> cont 2#; - L _ ITcase -> cont 3#; - L _ ITclass -> cont 4#; - L _ ITdata -> cont 5#; - L _ ITdefault -> cont 6#; - L _ ITderiving -> cont 7#; - L _ ITdo -> cont 8#; - L _ ITelse -> cont 9#; - L _ IThiding -> cont 10#; - L _ ITif -> cont 11#; - L _ ITimport -> cont 12#; - L _ ITin -> cont 13#; - L _ ITinfix -> cont 14#; - L _ ITinfixl -> cont 15#; - L _ ITinfixr -> cont 16#; - L _ ITinstance -> cont 17#; - L _ ITlet -> cont 18#; - L _ ITmodule -> cont 19#; - L _ ITnewtype -> cont 20#; - L _ ITof -> cont 21#; - L _ ITqualified -> cont 22#; - L _ ITthen -> cont 23#; - L _ ITtype -> cont 24#; - L _ ITwhere -> cont 25#; - L _ (ITforall _) -> cont 26#; - L _ ITforeign -> cont 27#; - L _ ITexport -> cont 28#; - L _ ITlabel -> cont 29#; - L _ ITdynamic -> cont 30#; - L _ ITsafe -> cont 31#; - L _ ITinterruptible -> cont 32#; - L _ ITunsafe -> cont 33#; - L _ ITmdo -> cont 34#; - L _ ITfamily -> cont 35#; - L _ ITrole -> cont 36#; - L _ ITstdcallconv -> cont 37#; - L _ ITccallconv -> cont 38#; - L _ ITcapiconv -> cont 39#; - L _ ITprimcallconv -> cont 40#; - L _ ITjavascriptcallconv -> cont 41#; - L _ ITproc -> cont 42#; - L _ ITrec -> cont 43#; - L _ ITgroup -> cont 44#; - L _ ITby -> cont 45#; - L _ ITusing -> cont 46#; - L _ ITpattern -> cont 47#; - L _ ITstatic -> cont 48#; - L _ ITstock -> cont 49#; - L _ ITanyclass -> cont 50#; - L _ ITunit -> cont 51#; - L _ ITsignature -> cont 52#; - L _ ITdependency -> cont 53#; - L _ (ITinline_prag _ _ _) -> cont 54#; - L _ (ITspec_prag _) -> cont 55#; - L _ (ITspec_inline_prag _ _) -> cont 56#; - L _ (ITsource_prag _) -> cont 57#; - L _ (ITrules_prag _) -> cont 58#; - L _ (ITcore_prag _) -> cont 59#; - L _ (ITscc_prag _) -> cont 60#; - L _ (ITgenerated_prag _) -> cont 61#; - L _ (ITdeprecated_prag _) -> cont 62#; - L _ (ITwarning_prag _) -> cont 63#; - L _ (ITunpack_prag _) -> cont 64#; - L _ (ITnounpack_prag _) -> cont 65#; - L _ (ITann_prag _) -> cont 66#; - L _ (ITvect_prag _) -> cont 67#; - L _ (ITvect_scalar_prag _) -> cont 68#; - L _ (ITnovect_prag _) -> cont 69#; - L _ (ITminimal_prag _) -> cont 70#; - L _ (ITctype _) -> cont 71#; - L _ (IToverlapping_prag _) -> cont 72#; - L _ (IToverlappable_prag _) -> cont 73#; - L _ (IToverlaps_prag _) -> cont 74#; - L _ (ITincoherent_prag _) -> cont 75#; - L _ (ITcomplete_prag _) -> cont 76#; - L _ ITclose_prag -> cont 77#; - L _ ITdotdot -> cont 78#; - L _ ITcolon -> cont 79#; - L _ (ITdcolon _) -> cont 80#; - L _ ITequal -> cont 81#; - L _ ITlam -> cont 82#; - L _ ITlcase -> cont 83#; - L _ ITvbar -> cont 84#; - L _ (ITlarrow _) -> cont 85#; - L _ (ITrarrow _) -> cont 86#; - L _ ITat -> cont 87#; - L _ ITtilde -> cont 88#; - L _ ITtildehsh -> cont 89#; - L _ (ITdarrow _) -> cont 90#; - L _ ITminus -> cont 91#; - L _ ITbang -> cont 92#; - L _ (ITlarrowtail _) -> cont 93#; - L _ (ITrarrowtail _) -> cont 94#; - L _ (ITLarrowtail _) -> cont 95#; - L _ (ITRarrowtail _) -> cont 96#; - L _ ITdot -> cont 97#; - L _ ITtypeApp -> cont 98#; - L _ ITocurly -> cont 99#; - L _ ITccurly -> cont 100#; - L _ ITvocurly -> cont 101#; - L _ ITvccurly -> cont 102#; - L _ ITobrack -> cont 103#; - L _ ITcbrack -> cont 104#; - L _ ITopabrack -> cont 105#; - L _ ITcpabrack -> cont 106#; - L _ IToparen -> cont 107#; - L _ ITcparen -> cont 108#; - L _ IToubxparen -> cont 109#; - L _ ITcubxparen -> cont 110#; - L _ (IToparenbar _) -> cont 111#; - L _ (ITcparenbar _) -> cont 112#; - L _ ITsemi -> cont 113#; - L _ ITcomma -> cont 114#; - L _ ITbackquote -> cont 115#; - L _ ITsimpleQuote -> cont 116#; - L _ (ITvarid _) -> cont 117#; - L _ (ITconid _) -> cont 118#; - L _ (ITvarsym _) -> cont 119#; - L _ (ITconsym _) -> cont 120#; - L _ (ITqvarid _) -> cont 121#; - L _ (ITqconid _) -> cont 122#; - L _ (ITqvarsym _) -> cont 123#; - L _ (ITqconsym _) -> cont 124#; - L _ (ITdupipvarid _) -> cont 125#; - L _ (ITlabelvarid _) -> cont 126#; - L _ (ITchar _ _) -> cont 127#; - L _ (ITstring _ _) -> cont 128#; - L _ (ITinteger _ _) -> cont 129#; - L _ (ITrational _) -> cont 130#; - L _ (ITprimchar _ _) -> cont 131#; - L _ (ITprimstring _ _) -> cont 132#; - L _ (ITprimint _ _) -> cont 133#; - L _ (ITprimword _ _) -> cont 134#; - L _ (ITprimfloat _) -> cont 135#; - L _ (ITprimdouble _) -> cont 136#; - L _ (ITdocCommentNext _) -> cont 137#; - L _ (ITdocCommentPrev _) -> cont 138#; - L _ (ITdocCommentNamed _) -> cont 139#; - L _ (ITdocSection _ _) -> cont 140#; - L _ (ITopenExpQuote _ _) -> cont 141#; - L _ ITopenPatQuote -> cont 142#; - L _ ITopenTypQuote -> cont 143#; - L _ ITopenDecQuote -> cont 144#; - L _ (ITcloseQuote _) -> cont 145#; - L _ (ITopenTExpQuote _) -> cont 146#; - L _ ITcloseTExpQuote -> cont 147#; - L _ (ITidEscape _) -> cont 148#; - L _ ITparenEscape -> cont 149#; - L _ (ITidTyEscape _) -> cont 150#; - L _ ITparenTyEscape -> cont 151#; - L _ ITtyQuote -> cont 152#; - L _ (ITquasiQuote _) -> cont 153#; - L _ (ITqQuasiQuote _) -> cont 154#; - _ -> happyError' (tk, []) - }) - -happyError_ explist 155# tk = happyError' (tk, explist) -happyError_ explist _ tk = happyError' (tk, explist) - -happyThen :: () => P a -> (a -> P b) -> P b -happyThen = (>>=) -happyReturn :: () => a -> P a -happyReturn = (return) -happyParse :: () => Happy_GHC_Exts.Int# -> P (HappyAbsSyn ) - -happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) - -happyDoAction :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) - -happyReduceArr :: () => Happy_Data_Array.Array Int (Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )) - -happyThen1 :: () => P a -> (a -> P b) -> P b -happyThen1 = happyThen -happyReturn1 :: () => a -> P a -happyReturn1 = happyReturn -happyError' :: () => (((Located Token)), [String]) -> P a -happyError' tk = (\(tokens, explist) -> happyError) tk -parseModule = happySomeParser where - happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut34 x)) - -parseSignature = happySomeParser where - happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (happyOut33 x)) - -parseImport = happySomeParser where - happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (happyOut64 x)) - -parseStatement = happySomeParser where - happySomeParser = happyThen (happyParse 3#) (\x -> happyReturn (happyOut246 x)) - -parseDeclaration = happySomeParser where - happySomeParser = happyThen (happyParse 4#) (\x -> happyReturn (happyOut77 x)) - -parseExpression = happySomeParser where - happySomeParser = happyThen (happyParse 5#) (\x -> happyReturn (happyOut200 x)) - -parsePattern = happySomeParser where - happySomeParser = happyThen (happyParse 6#) (\x -> happyReturn (happyOut239 x)) - -parseTypeSignature = happySomeParser where - happySomeParser = happyThen (happyParse 7#) (\x -> happyReturn (happyOut196 x)) - -parseStmt = happySomeParser where - happySomeParser = happyThen (happyParse 8#) (\x -> happyReturn (happyOut245 x)) - -parseIdentifier = happySomeParser where - happySomeParser = happyThen (happyParse 9#) (\x -> happyReturn (happyOut16 x)) - -parseType = happySomeParser where - happySomeParser = happyThen (happyParse 10#) (\x -> happyReturn (happyOut151 x)) - -parseBackpack = happySomeParser where - happySomeParser = happyThen (happyParse 11#) (\x -> happyReturn (happyOut17 x)) - -parseHeader = happySomeParser where - happySomeParser = happyThen (happyParse 12#) (\x -> happyReturn (happyOut43 x)) - -happySeq = happyDontSeq - - -happyError :: P a -happyError = srcParseFail - -getVARID (L _ (ITvarid x)) = x -getCONID (L _ (ITconid x)) = x -getVARSYM (L _ (ITvarsym x)) = x -getCONSYM (L _ (ITconsym x)) = x -getQVARID (L _ (ITqvarid x)) = x -getQCONID (L _ (ITqconid x)) = x -getQVARSYM (L _ (ITqvarsym x)) = x -getQCONSYM (L _ (ITqconsym x)) = x -getIPDUPVARID (L _ (ITdupipvarid x)) = x -getLABELVARID (L _ (ITlabelvarid x)) = x -getCHAR (L _ (ITchar _ x)) = x -getSTRING (L _ (ITstring _ x)) = x -getINTEGER (L _ (ITinteger _ x)) = x -getRATIONAL (L _ (ITrational x)) = x -getPRIMCHAR (L _ (ITprimchar _ x)) = x -getPRIMSTRING (L _ (ITprimstring _ x)) = x -getPRIMINTEGER (L _ (ITprimint _ x)) = x -getPRIMWORD (L _ (ITprimword _ x)) = x -getPRIMFLOAT (L _ (ITprimfloat x)) = x -getPRIMDOUBLE (L _ (ITprimdouble x)) = x -getTH_ID_SPLICE (L _ (ITidEscape x)) = x -getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x -getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) -getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) -getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) -getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x - -getDOCNEXT (L _ (ITdocCommentNext x)) = x -getDOCPREV (L _ (ITdocCommentPrev x)) = x -getDOCNAMED (L _ (ITdocCommentNamed x)) = x -getDOCSECTION (L _ (ITdocSection n x)) = (n, x) - -getCHARs (L _ (ITchar src _)) = src -getSTRINGs (L _ (ITstring src _)) = src -getINTEGERs (L _ (ITinteger src _)) = src -getPRIMCHARs (L _ (ITprimchar src _)) = src -getPRIMSTRINGs (L _ (ITprimstring src _)) = src -getPRIMINTEGERs (L _ (ITprimint src _)) = src -getPRIMWORDs (L _ (ITprimword src _)) = src - --- See Note [Pragma source text] in BasicTypes for the following -getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src -getSPEC_PRAGs (L _ (ITspec_prag src)) = src -getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src -getSOURCE_PRAGs (L _ (ITsource_prag src)) = src -getRULES_PRAGs (L _ (ITrules_prag src)) = src -getWARNING_PRAGs (L _ (ITwarning_prag src)) = src -getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src -getSCC_PRAGs (L _ (ITscc_prag src)) = src -getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src -getCORE_PRAGs (L _ (ITcore_prag src)) = src -getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src -getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src -getANN_PRAGs (L _ (ITann_prag src)) = src -getVECT_PRAGs (L _ (ITvect_prag src)) = src -getVECT_SCALAR_PRAGs (L _ (ITvect_scalar_prag src)) = src -getNOVECT_PRAGs (L _ (ITnovect_prag src)) = src -getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src -getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src -getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src -getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src -getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src -getCTYPEs (L _ (ITctype src)) = src - -getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) - -isUnicode :: Located Token -> Bool -isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax -isUnicode _ = False - -hasE :: Located Token -> Bool -hasE (L _ (ITopenExpQuote HasE _)) = True -hasE (L _ (ITopenTExpQuote HasE)) = True -hasE _ = False - -getSCC :: Located Token -> P FastString -getSCC lt = do let s = getSTRING lt - err = "Spaces are not allowed in SCCs" - -- We probably actually want to be more restrictive than this - if ' ' `elem` unpackFS s - then failSpanMsgP (getLoc lt) (text err) - else return s - --- Utilities for combining source spans -comb2 :: Located a -> Located b -> SrcSpan -comb2 a b = a `seq` b `seq` combineLocs a b - -comb3 :: Located a -> Located b -> Located c -> SrcSpan -comb3 a b c = a `seq` b `seq` c `seq` - combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) - -comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan -comb4 a b c d = a `seq` b `seq` c `seq` d `seq` - (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ - combineSrcSpans (getLoc c) (getLoc d)) - --- strict constructor version: -{-# INLINE sL #-} -sL :: SrcSpan -> a -> Located a -sL span a = span `seq` a `seq` L span a - --- See Note [Adding location info] for how these utility functions are used - --- replaced last 3 CPP macros in this file -{-# INLINE sL0 #-} -sL0 :: a -> Located a -sL0 = L noSrcSpan -- #define L0 L noSrcSpan - -{-# INLINE sL1 #-} -sL1 :: Located a -> b -> Located b -sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) - -{-# INLINE sLL #-} -sLL :: Located a -> Located b -> c -> Located c -sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) - -{- Note [Adding location info] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -This is done using the three functions below, sL0, sL1 -and sLL. Note that these functions were mechanically -converted from the three macros that used to exist before, -namely L0, L1 and LL. - -They each add a SrcSpan to their argument. - - sL0 adds 'noSrcSpan', used for empty productions - -- This doesn't seem to work anymore -=chak - - sL1 for a production with a single token on the lhs. Grabs the SrcSpan - from that token. - - sLL for a production with >1 token on the lhs. Makes up a SrcSpan from - the first and last tokens. - -These suffice for the majority of cases. However, we must be -especially careful with empty productions: sLL won't work if the first -or last token on the lhs can represent an empty span. In these cases, -we have to calculate the span using more of the tokens from the lhs, eg. - - | 'newtype' tycl_hdr '=' newconstr deriving - { L (comb3 $1 $4 $5) - (mkTyData NewType (unLoc $2) $4 (unLoc $5)) } - -We provide comb3 and comb4 functions which are useful in such cases. - -Be careful: there's no checking that you actually got this right, the -only symptom will be that the SrcSpans of your syntax will be -incorrect. - --} - --- Make a source location for the file. We're a bit lazy here and just --- make a point SrcSpan at line 1, column 0. Strictly speaking we should --- try to find the span of the whole file (ToDo). -fileSrcSpan :: P SrcSpan -fileSrcSpan = do - l <- getSrcLoc; - let loc = mkSrcLoc (srcLocFile l) 1 1; - return (mkSrcSpan loc loc) - --- Hint about the MultiWayIf extension -hintMultiWayIf :: SrcSpan -> P () -hintMultiWayIf span = do - mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState - unless mwiEnabled $ parseErrorSDoc span $ - text "Multi-way if-expressions need MultiWayIf turned on" - --- Hint about if usage for beginners -hintIf :: SrcSpan -> String -> P (LHsExpr RdrName) -hintIf span msg = do - mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState - if mwiEnabled - then parseErrorSDoc span $ text $ "parse error in if statement" - else parseErrorSDoc span $ text $ "parse error in if statement: "++msg - --- Hint about explicit-forall, assuming UnicodeSyntax is on -hintExplicitForall :: SrcSpan -> P () -hintExplicitForall span = do - forall <- extension explicitForallEnabled - rulePrag <- extension inRulePrag - unless (forall || rulePrag) $ parseErrorSDoc span $ vcat - [ text "Illegal symbol '\x2200' in type" -- U+2200 FOR ALL - , text "Perhaps you intended to use RankNTypes or a similar language" - , text "extension to enable explicit-forall syntax: \x2200 . " - ] - --- Hint about explicit-forall, assuming UnicodeSyntax is off -hintExplicitForall' :: SrcSpan -> P (GenLocated SrcSpan RdrName) -hintExplicitForall' span = do - forall <- extension explicitForallEnabled - let illegalDot = "Illegal symbol '.' in type" - if forall - then parseErrorSDoc span $ vcat - [ text illegalDot - , text "Perhaps you meant to write 'forall . '?" - ] - else parseErrorSDoc span $ vcat - [ text illegalDot - , text "Perhaps you intended to use RankNTypes or a similar language" - , text "extension to enable explicit-forall syntax: forall . " - ] - -{- -%************************************************************************ -%* * - Helper functions for generating annotations in the parser -%* * -%************************************************************************ - -For the general principles of the following routines, see Note [Api annotations] -in ApiAnnotation.hs - --} - --- |Construct an AddAnn from the annotation keyword and the location --- of the keyword itself -mj :: AnnKeywordId -> Located e -> AddAnn -mj a l s = addAnnotation s a (gl l) - --- |Construct an AddAnn from the annotation keyword and the Located Token. If --- the token has a unicode equivalent and this has been used, provide the --- unicode variant of the annotation. -mu :: AnnKeywordId -> Located Token -> AddAnn -mu a lt@(L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l) - --- | If the 'Token' is using its unicode variant return the unicode variant of --- the annotation -toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId -toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a - -gl = getLoc - --- |Add an annotation to the located element, and return the located --- element as a pass through -aa :: Located a -> (AnnKeywordId,Located c) -> P (Located a) -aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a - --- |Add an annotation to a located element resulting from a monadic action -am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a) -am a (b,s) = do - av@(L l _) <- a - addAnnotation l b (gl s) - return av - --- | Add a list of AddAnns to the given AST element. For example, --- the parsing rule for @let@ looks like: --- --- @ --- | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) --- (mj AnnLet $1:mj AnnIn $3 --- :(fst $ unLoc $2)) } --- @ --- --- This adds an AnnLet annotation for @let@, an AnnIn for @in@, as well --- as any annotations that may arise in the binds. This will include open --- and closing braces if they are used to delimit the let expressions. --- -ams :: Located a -> [AddAnn] -> P (Located a) -ams a@(L l _) bs = addAnnsAt l bs >> return a - --- |Add all [AddAnn] to an AST element wrapped in a Just -aljs :: Located (Maybe a) -> [AddAnn] -> P (Located (Maybe a)) -aljs a@(L l _) bs = addAnnsAt l bs >> return a - --- |Add all [AddAnn] to an AST element wrapped in a Just -ajs a@(Just (L l _)) bs = addAnnsAt l bs >> return a - --- |Add a list of AddAnns to the given AST element, where the AST element is the --- result of a monadic action -amms :: P (Located a) -> [AddAnn] -> P (Located a) -amms a bs = do { av@(L l _) <- a - ; addAnnsAt l bs - ; return av } - --- |Add a list of AddAnns to the AST element, and return the element as a --- OrdList -amsu :: Located a -> [AddAnn] -> P (OrdList (Located a)) -amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a) - --- |Synonyms for AddAnn versions of AnnOpen and AnnClose -mo,mc :: Located Token -> AddAnn -mo ll = mj AnnOpen ll -mc ll = mj AnnClose ll - -moc,mcc :: Located Token -> AddAnn -moc ll = mj AnnOpenC ll -mcc ll = mj AnnCloseC ll - -mop,mcp :: Located Token -> AddAnn -mop ll = mj AnnOpenP ll -mcp ll = mj AnnCloseP ll - -mos,mcs :: Located Token -> AddAnn -mos ll = mj AnnOpenS ll -mcs ll = mj AnnCloseS ll - --- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma --- entry for each SrcSpan -mcommas :: [SrcSpan] -> [AddAnn] -mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss - --- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar --- entry for each SrcSpan -mvbars :: [SrcSpan] -> [AddAnn] -mvbars ss = map (\s -> mj AnnVbar (L s ())) ss - --- |Get the location of the last element of a OrdList, or noSrcSpan -oll :: OrdList (Located a) -> SrcSpan -oll l = - if isNilOL l then noSrcSpan - else getLoc (lastOL l) - --- |Add a semicolon annotation in the right place in a list. If the --- leading list is empty, add it to the tail -asl :: [Located a] -> Located b -> Located a -> P() -asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls -asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 10 "" #-} -# 1 "/usr/include/stdc-predef.h" 1 3 4 - -# 17 "/usr/include/stdc-predef.h" 3 4 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -{-# LINE 10 "" #-} -{-# LINE 1 "/opt/ghc/8.2.2/lib/ghc-8.2.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - -{-# LINE 10 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - - - - - - - - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) -#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) -#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) -#else -#define LT(n,m) (n Happy_GHC_Exts.<# m) -#define GTE(n,m) (n Happy_GHC_Exts.>=# m) -#define EQ(n,m) (n Happy_GHC_Exts.==# m) -#endif -{-# LINE 43 "templates/GenericTemplate.hs" #-} - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - - - -{-# LINE 65 "templates/GenericTemplate.hs" #-} - -{-# LINE 75 "templates/GenericTemplate.hs" #-} - -{-# LINE 84 "templates/GenericTemplate.hs" #-} - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail (happyExpListPerState ((Happy_GHC_Exts.I# (st)) :: Int)) i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = happyAdjustOffset (indexShortOffAddr happyActOffsets st) - off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) - then EQ(indexShortOffAddr happyCheck off_i, i) - else False - action - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# - - - - -{-# INLINE happyLt #-} -happyLt x y = LT(x,y) - - -readArrayBit arr bit = - Bits.testBit (Happy_GHC_Exts.I# (indexShortOffAddr arr ((unbox_int bit) `Happy_GHC_Exts.iShiftRA#` 4#))) (bit `mod` 16) - where unbox_int (Happy_GHC_Exts.I# x) = x - - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - -{-# LINE 180 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail [] 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk - - off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st1) - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st) - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail explist 0# tk old_st _ stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "failing" $ - happyError_ explist i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail explist i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -1,643 +1,1044 @@ -Cabal-Version: 2.0 -Name: ghc -Version: 8.2.2 - -License: BSD3 -License-File: LICENSE -Author: The GHC Team -Maintainer: glasgow-haskell-users@haskell.org -Homepage: http://www.haskell.org/ghc/ -Synopsis: The GHC API -Description: - GHC's functionality can be useful for more things than just - compiling Haskell programs. Important use cases are programs - that analyse (and perhaps transform) Haskell code. Others - include loading Haskell code dynamically in a GHCi-like manner. - For this reason, a lot of GHC's functionality is made available - through this package. -Category: Development -Build-Type: Simple - -extra-source-files: - utils/md5.h - Unique.h - HsVersions.h - nativeGen/NCG.h - parser/cutils.h - autogen/ghc_boot_platform.h - autogen/CodeGen.Platform.hs - autogen/Config.hs - autogen/GHCConstantsHaskellExports.hs - autogen/GHCConstantsHaskellType.hs - autogen/GHCConstantsHaskellWrappers.hs - autogen/*.hs-incl - - -Flag terminfo - Description: Build GHC with terminfo support on non-Windows platforms. - Default: True - Manual: True - -Flag buildable - Description: Make this package buildable /(experimental tech preview)/. - . - See [reinstallable lib:ghc announcement](https://mail.haskell.org/pipermail/ghc-devs/2017-July/014424.html) for more information. - Default: False - Manual: True - -Library - -- The generated code in autogen/ has been generated for a linux/x86_64 target - -- So everything else is definitely not working... - if !(os(linux) && arch(x86_64) && impl(ghc == 8.2.2)) - build-depends: base<0 - - -- ...while this package may in theory allow to reinstall lib:ghc - -- under very limited constraints, this most likely could fail in - -- weird ways (e.g. mismatched tag numbers, GHC panics, etc), and - -- since cabal doesn't mark this package as non-upgradable, we - -- declare this package out of reach to the cabal solver by default - -- here - if !flag(buildable) - build-depends: base<0 - - Default-Language: Haskell2010 - Exposed: False - - Build-Depends: base == 4.10.*, - deepseq >= 1.4 && < 1.5, - directory >= 1 && < 1.4, - process >= 1 && < 1.7, - bytestring >= 0.9 && < 0.11, - binary == 0.8.*, - time >= 1.4 && < 1.9, - containers >= 0.5 && < 0.6, - array >= 0.1 && < 0.6, - filepath >= 1 && < 1.5, - template-haskell == 2.12.*, - hpc == 0.6.*, - transformers == 0.5.*, - ghc-boot == 8.2.2, - ghc-boot-th == 8.2.2, - ghci == 8.2.2, - hoopl >= 3.10.2 && < 3.11 - - if os(windows) - Build-Depends: Win32 >= 2.3 && < 2.6 - else - if flag(terminfo) - Build-Depends: terminfo == 0.4.* - Build-Depends: unix == 2.7.* - - build-tools: alex ^>= 3.2.1, happy ^>= 1.19.5 - - GHC-Options: -Wall -fno-warn-name-shadowing - - -- if flag(ghci) - -- CPP-Options: -DGHCI - -- Include-Dirs: ../rts/dist/build - - Other-Extensions: - BangPatterns - CPP - DataKinds - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveTraversable - DisambiguateRecordFields - ExplicitForAll - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - MagicHash - MultiParamTypeClasses - NamedFieldPuns - NondecreasingIndentation - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - Trustworthy - TupleSections - TypeFamilies - TypeSynonymInstances - UnboxedTuples - UndecidableInstances - - Include-Dirs: . parser utils - - -- We need to set the unit id to ghc (without a version number) - -- as it's magic. But we can't set it for old versions of GHC (e.g. - -- when bootstrapping) because those versions of GHC don't understand - -- that GHC is wired-in. - if impl ( ghc >= 7.11 ) - GHC-Options: -this-unit-id ghc - else - if impl( ghc >= 7.9 ) - GHC-Options: -this-package-key ghc - - cpp-options: -DSTAGE=2 - - Install-Includes: HsVersions.h, ghc_boot_platform.h - - c-sources: - parser/cutils.c - ghci/keepCAFsForGHCi.c - cbits/genSym.c - - hs-source-dirs: - autogen - - include-dirs: - autogen - - hs-source-dirs: - backpack - basicTypes - cmm - codeGen - coreSyn - deSugar - ghci - hsSyn - iface - llvmGen - main - nativeGen - parser - prelude - profiling - rename - simplCore - simplStg - specialise - stgSyn - stranal - typecheck - types - utils - vectorise - - Exposed-Modules: - DriverBkp - BkpSyn - NameShape - RnModIface - Avail - BasicTypes - ConLike - DataCon - PatSyn - Demand - Debug - Exception - FieldLabel - GhcMonad - Hooks - Id - IdInfo - Lexeme - Literal - Llvm - Llvm.AbsSyn - Llvm.MetaData - Llvm.PpLlvm - Llvm.Types - LlvmCodeGen - LlvmCodeGen.Base - LlvmCodeGen.CodeGen - LlvmCodeGen.Data - LlvmCodeGen.Ppr - LlvmCodeGen.Regs - LlvmMangler - MkId - Module - Name - NameEnv - NameSet - OccName - RdrName - NameCache - SrcLoc - UniqSupply - Unique - Var - VarEnv - VarSet - UnVarGraph - BlockId - CLabel - Cmm - CmmBuildInfoTables - CmmPipeline - CmmCallConv - CmmCommonBlockElim - CmmImplementSwitchPlans - CmmContFlowOpt - CmmExpr - CmmInfo - CmmLex - CmmLint - CmmLive - CmmMachOp - CmmMonad - CmmSwitch - CmmNode - CmmOpt - CmmParse - CmmProcPoint - CmmSink - CmmType - CmmUtils - CmmLayoutStack - MkGraph - PprBase - PprC - PprCmm - PprCmmDecl - PprCmmExpr - Bitmap - CodeGen.Platform - CodeGen.Platform.ARM - CodeGen.Platform.ARM64 - CodeGen.Platform.NoRegs - CodeGen.Platform.PPC - CodeGen.Platform.PPC_Darwin - CodeGen.Platform.SPARC - CodeGen.Platform.X86 - CodeGen.Platform.X86_64 - CgUtils - StgCmm - StgCmmBind - StgCmmClosure - StgCmmCon - StgCmmEnv - StgCmmExpr - StgCmmForeign - StgCmmHeap - StgCmmHpc - StgCmmArgRep - StgCmmLayout - StgCmmMonad - StgCmmPrim - StgCmmProf - StgCmmTicky - StgCmmUtils - StgCmmExtCode - SMRep - CoreArity - CoreFVs - CoreLint - CorePrep - CoreSubst - CoreOpt - CoreSyn - TrieMap - CoreTidy - CoreUnfold - CoreUtils - CoreSeq - CoreStats - MkCore - PprCore - PmExpr - TmOracle - Check - Coverage - Desugar - DsArrows - DsBinds - DsCCall - DsExpr - DsForeign - DsGRHSs - DsListComp - DsMonad - DsUsage - DsUtils - Match - MatchCon - MatchLit - HsBinds - HsDecls - HsDoc - HsExpr - HsImpExp - HsLit - PlaceHolder - HsPat - HsSyn - HsTypes - HsUtils - HsDumpAst - BinIface - BinFingerprint - BuildTyCl - IfaceEnv - IfaceSyn - IfaceType - ToIface - LoadIface - MkIface - TcIface - FlagChecker - Annotations - CmdLineParser - CodeOutput - Config - Constants - DriverMkDepend - DriverPhases - PipelineMonad - DriverPipeline - DynFlags - ErrUtils - Finder - GHC - GhcMake - GhcPlugins - DynamicLoading - HeaderInfo - HscMain - HscStats - HscTypes - InteractiveEval - InteractiveEvalTypes - PackageConfig - Packages - PlatformConstants - Plugins - TcPluginM - PprTyThing - StaticPtrTable - SysTools - SysTools.Terminal - Elf - TidyPgm - Ctype - HaddockUtils - Lexer - OptCoercion - Parser - RdrHsSyn - ApiAnnotation - ForeignCall - KnownUniques - PrelInfo - PrelNames - PrelRules - PrimOp - TysPrim - TysWiredIn - CostCentre - ProfInit - SCCfinal - RnBinds - RnEnv - RnExpr - RnHsDoc - RnNames - RnPat - RnSource - RnSplice - RnTypes - CoreMonad - CSE - FloatIn - FloatOut - LiberateCase - OccurAnal - SAT - SetLevels - SimplCore - SimplEnv - SimplMonad - SimplUtils - Simplify - SimplStg - StgStats - StgCse - UnariseStg - RepType - Rules - SpecConstr - Specialise - CoreToStg - StgLint - StgSyn - CallArity - DmdAnal - WorkWrap - WwLib - FamInst - Inst - TcAnnotations - TcArrows - TcBinds - TcSigs - TcClassDcl - TcDefaults - TcDeriv - TcDerivInfer - TcDerivUtils - TcEnv - TcExpr - TcForeign - TcGenDeriv - TcGenFunctor - TcGenGenerics - TcHsSyn - TcHsType - TcInstDcls - TcMType - TcValidity - TcMatches - TcPat - TcPatSyn - TcRnDriver - TcBackpack - TcRnExports - TcRnMonad - TcRnTypes - TcRules - TcSimplify - TcErrors - TcTyClsDecls - TcTyDecls - TcTypeable - TcType - TcEvidence - TcUnify - TcInteract - TcCanonical - TcFlatten - TcSMonad - TcTypeNats - TcSplice - Class - Coercion - DsMeta - THNames - FamInstEnv - FunDeps - InstEnv - TyCon - CoAxiom - Kind - Type - TyCoRep - Unify - Bag - Binary - BooleanFormula - BufWrite - Digraph - Encoding - FastFunctions - FastMutInt - FastString - FastStringEnv - Fingerprint - FiniteMap - FV - GraphBase - GraphColor - GraphOps - GraphPpr - IOEnv - Json - ListSetOps - ListT - Maybes - MonadUtils - OrdList - Outputable - Pair - Panic - PprColour - Pretty - State - Stream - StringBuffer - UniqDFM - UniqDSet - UniqFM - UniqSet - Util - Vectorise.Builtins.Base - Vectorise.Builtins.Initialise - Vectorise.Builtins - Vectorise.Monad.Base - Vectorise.Monad.Naming - Vectorise.Monad.Local - Vectorise.Monad.Global - Vectorise.Monad.InstEnv - Vectorise.Monad - Vectorise.Utils.Base - Vectorise.Utils.Closure - Vectorise.Utils.Hoisting - Vectorise.Utils.PADict - Vectorise.Utils.Poly - Vectorise.Utils - Vectorise.Generic.Description - Vectorise.Generic.PAMethods - Vectorise.Generic.PADict - Vectorise.Generic.PData - Vectorise.Type.Env - Vectorise.Type.Type - Vectorise.Type.TyConDecl - Vectorise.Type.Classify - Vectorise.Convert - Vectorise.Vect - Vectorise.Var - Vectorise.Env - Vectorise.Exp - Vectorise - Hoopl.Dataflow - Hoopl --- CgInfoTbls used in ghci/DebuggerUtils --- CgHeapery mkVirtHeapOffsets used in ghci - - Exposed-Modules: - AsmCodeGen - TargetReg - NCGMonad - Instruction - Format - Reg - RegClass - PIC - Platform - CPrim - X86.Regs - X86.RegInfo - X86.Instr - X86.Cond - X86.Ppr - X86.CodeGen - PPC.Regs - PPC.RegInfo - PPC.Instr - PPC.Cond - PPC.Ppr - PPC.CodeGen - SPARC.Base - SPARC.Regs - SPARC.Imm - SPARC.AddrMode - SPARC.Cond - SPARC.Instr - SPARC.Stack - SPARC.ShortcutJump - SPARC.Ppr - SPARC.CodeGen - SPARC.CodeGen.Amode - SPARC.CodeGen.Base - SPARC.CodeGen.CondCode - SPARC.CodeGen.Gen32 - SPARC.CodeGen.Gen64 - SPARC.CodeGen.Sanity - SPARC.CodeGen.Expand - RegAlloc.Liveness - RegAlloc.Graph.Main - RegAlloc.Graph.Stats - RegAlloc.Graph.ArchBase - RegAlloc.Graph.ArchX86 - RegAlloc.Graph.Coalesce - RegAlloc.Graph.Spill - RegAlloc.Graph.SpillClean - RegAlloc.Graph.SpillCost - RegAlloc.Graph.TrivColorable - RegAlloc.Linear.Main - RegAlloc.Linear.JoinToTargets - RegAlloc.Linear.State - RegAlloc.Linear.Stats - RegAlloc.Linear.FreeRegs - RegAlloc.Linear.StackMap - RegAlloc.Linear.Base - RegAlloc.Linear.X86.FreeRegs - RegAlloc.Linear.X86_64.FreeRegs - RegAlloc.Linear.PPC.FreeRegs - RegAlloc.Linear.SPARC.FreeRegs - Dwarf - Dwarf.Types - Dwarf.Constants - Convert - ByteCodeTypes - ByteCodeAsm - ByteCodeGen - ByteCodeInstr - ByteCodeItbls - ByteCodeLink - Debugger - Linker - RtClosureInspect - DebuggerUtils - GHCi - - -- ghc:Serialized moved to ghc-boot:GHC.Serialized. So for - -- compatibility with GHC 7.10 and earlier, we reexport it - -- under the old name. - reexported-modules: - ghc-boot:GHC.Serialized as Serialized +Cabal-Version: 2.2 +-- WARNING: ghc.cabal is automatically generated from ghc.cabal.in by +-- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. + +Name: ghc +Version: 9.14.1 +License: BSD-3-Clause +License-File: LICENSE +Author: The GHC Team +Maintainer: glasgow-haskell-users@haskell.org +Homepage: http://www.haskell.org/ghc/ +Synopsis: The GHC API +Description: + GHC's functionality can be useful for more things than just + compiling Haskell programs. Important use cases are programs + that analyse (and perhaps transform) Haskell code. Others + include loading Haskell code dynamically in a GHCi-like manner. + For this reason, a lot of GHC's functionality is made available + through this package. + . + See + for more information. + . + __This package is not PVP-compliant.__ + . + This package directly exposes GHC internals, which can and do change with + every release. +Category: Development +Build-Type: Custom + +extra-source-files: + GHC/Builtin/primops.txt.pp + Unique.h + CodeGen.Platform.h + -- Shared with rts via hard-link at configure time. This is safer + -- for Windows, where symlinks don't work out of the box, so we + -- can't just commit some in git. + Bytecodes.h + ClosureTypes.h + FunTypes.h + MachRegs.h + MachRegs/arm32.h + MachRegs/arm64.h + MachRegs/loongarch64.h + MachRegs/ppc.h + MachRegs/riscv64.h + MachRegs/s390x.h + MachRegs/wasm32.h + MachRegs/x86.h + + +custom-setup + setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.14, directory, process, filepath, containers + +Flag internal-interpreter + Description: Build with internal interpreter support. + Default: False + Manual: True + +Flag dynamic-system-linker + Description: The system can load dynamic code. This is not the case for musl. + Default: True + Manual: True + +-- hadrian disables this flag because the user may be building from a source +-- distribution where the parser has already been generated. +Flag build-tool-depends + Description: Use build-tool-depends + Default: True + +Flag with-libzstd + Default: False + Manual: True + +Flag static-libzstd + Default: False + Manual: True + +-- While the boot compiler fixes ghc's unit-id to `ghc`, the stage0 compiler must still be compiled with `-this-unit-id ghc` +Flag hadrian-stage0 + Description: Enable if compiling the stage0 compiler with hadrian + Default: False + Manual: True + +Flag bootstrap + Description: + Enabled when building the stage1 compiler in order to vendor the in-tree + `ghc-boot-th` library, and through that the in-tree TH AST defintions from + `ghc-internal`. + See Note [Bootstrapping Template Haskell] + Default: False + Manual: True + +Library + Default-Language: GHC2021 + Exposed: False + Includes: Unique.h + -- CodeGen.Platform.h -- invalid as C, skip + -- shared with rts via symlink + Bytecodes.h + ClosureTypes.h + FunTypes.h + + if flag(build-tool-depends) + build-tool-depends: alex:alex >= 3.2.6, happy:happy >= 1.20.0, genprimopcode:genprimopcode, deriveConstants:deriveConstants + + if flag(with-libzstd) + if flag(static-libzstd) + if os(darwin) + buildable: False + else + extra-libraries: :libzstd.a + else + extra-libraries: zstd + CPP-Options: -DHAVE_LIBZSTD + + Build-Depends: base >= 4.11 && < 4.23, + deepseq >= 1.4 && < 1.6, + directory >= 1 && < 1.4, + process >= 1 && < 1.7, + bytestring >= 0.11 && < 0.13, + binary == 0.8.*, + time >= 1.4 && < 1.16, + containers >= 0.6.2.1 && < 0.9, + array >= 0.1 && < 0.6, + filepath >= 1.5 && < 1.6, + os-string >= 2.0.1 && < 2.1, + hpc >= 0.6 && < 0.8, + transformers >= 0.5 && < 0.7, + exceptions == 0.10.*, + semaphore-compat, + stm, + rts, + ghc-boot == 9.14.1, + ghc-heap >=9.10.1 && <=9.14.1, + ghci == 9.14.1 + + if flag(bootstrap) + Build-Depends: + ghc-boot-th-next == 9.14.1 + else + Build-Depends: + ghc-boot-th == 9.14.1, + ghc-internal == 9.1401.0, + + if os(windows) + Build-Depends: Win32 >= 2.3 && < 2.15 + else + Build-Depends: unix >= 2.7 && < 2.9 + + GHC-Options: -Wall + -Wno-name-shadowing + -Wnoncanonical-monad-instances + -Wnoncanonical-monoid-instances + + if flag(internal-interpreter) + CPP-Options: -DHAVE_INTERNAL_INTERPRETER + + -- if no dynamic system linker is available, don't try DLLs. + if flag(dynamic-system-linker) + CPP-Options: -DCAN_LOAD_DLL + + Other-Extensions: + CPP + DataKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveTraversable + DisambiguateRecordFields + ExplicitForAll + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + MagicHash + MultiParamTypeClasses + NamedFieldPuns + NondecreasingIndentation + RankNTypes + RecordWildCards + StandaloneDeriving + Trustworthy + TupleSections + TypeFamilies + TypeSynonymInstances + UnboxedTuples + UndecidableInstances + + Include-Dirs: . + + if flag(hadrian-stage0) + -- We need to set the unit id to ghc (without a version number) + -- as it's magic. + GHC-Options: -this-unit-id ghc + + if arch(javascript) + js-sources: + jsbits/genSym.js + else + c-sources: + cbits/cutils.c + cbits/genSym.c + cbits/keepCAFsForGHCi.c + + hs-source-dirs: + . + + -- we use an explicit Prelude + Default-Extensions: + NoImplicitPrelude + ,MonoLocalBinds + + Exposed-Modules: + GHC + GHC.Builtin.Names + GHC.Builtin.Names.TH + GHC.Builtin.PrimOps + GHC.Builtin.PrimOps.Casts + GHC.Builtin.PrimOps.Ids + GHC.Builtin.Types + GHC.Builtin.Types.Literals + GHC.Builtin.Types.Prim + GHC.Builtin.Uniques + GHC.Builtin.Utils + GHC.ByteCode.Asm + GHC.ByteCode.Breakpoints + GHC.ByteCode.InfoTable + GHC.ByteCode.Instr + GHC.ByteCode.Linker + GHC.ByteCode.Types + GHC.Cmm + GHC.Cmm.BlockId + GHC.Cmm.CallConv + GHC.Cmm.CLabel + GHC.Cmm.CommonBlockElim + GHC.Cmm.Config + GHC.Cmm.ContFlowOpt + GHC.Cmm.Dataflow + GHC.Cmm.Dataflow.Block + GHC.Cmm.Dataflow.Graph + GHC.Cmm.Dataflow.Label + GHC.Cmm.DebugBlock + GHC.Cmm.Expr + GHC.Cmm.GenericOpt + GHC.Cmm.Graph + GHC.Cmm.Info + GHC.Cmm.Info.Build + GHC.Cmm.InitFini + GHC.Cmm.LayoutStack + GHC.Cmm.Lexer + GHC.Cmm.Lint + GHC.Cmm.Liveness + GHC.Cmm.MachOp + GHC.Cmm.Node + GHC.Cmm.Opt + GHC.Cmm.Parser + GHC.Cmm.Parser.Config + GHC.Cmm.Parser.Monad + GHC.Cmm.Pipeline + GHC.Cmm.ProcPoint + GHC.Cmm.Reg + GHC.Cmm.Sink + GHC.Cmm.Switch + GHC.Cmm.Switch.Implement + GHC.Cmm.ThreadSanitizer + GHC.Cmm.UniqueRenamer + GHC.CmmToAsm + GHC.Cmm.LRegSet + GHC.CmmToAsm.AArch64 + GHC.CmmToAsm.AArch64.CodeGen + GHC.CmmToAsm.AArch64.Cond + GHC.CmmToAsm.AArch64.Instr + GHC.CmmToAsm.AArch64.Ppr + GHC.CmmToAsm.AArch64.RegInfo + GHC.CmmToAsm.AArch64.Regs + GHC.CmmToAsm.BlockLayout + GHC.CmmToAsm.CFG + GHC.CmmToAsm.CFG.Dominators + GHC.CmmToAsm.CFG.Weight + GHC.CmmToAsm.Config + GHC.CmmToAsm.CPrim + GHC.CmmToAsm.Dwarf + GHC.CmmToAsm.Dwarf.Constants + GHC.CmmToAsm.Dwarf.Types + GHC.CmmToAsm.Format + GHC.CmmToAsm.Instr + GHC.CmmToAsm.LA64 + GHC.CmmToAsm.LA64.CodeGen + GHC.CmmToAsm.LA64.Cond + GHC.CmmToAsm.LA64.Instr + GHC.CmmToAsm.LA64.Ppr + GHC.CmmToAsm.LA64.RegInfo + GHC.CmmToAsm.LA64.Regs + GHC.CmmToAsm.Monad + GHC.CmmToAsm.PIC + GHC.CmmToAsm.PPC + GHC.CmmToAsm.PPC.CodeGen + GHC.CmmToAsm.PPC.Cond + GHC.CmmToAsm.PPC.Instr + GHC.CmmToAsm.PPC.Ppr + GHC.CmmToAsm.PPC.RegInfo + GHC.CmmToAsm.PPC.Regs + GHC.CmmToAsm.Ppr + GHC.CmmToAsm.Reg.Graph + GHC.CmmToAsm.Reg.Graph.Base + GHC.CmmToAsm.Reg.Graph.Coalesce + GHC.CmmToAsm.Reg.Graph.Spill + GHC.CmmToAsm.Reg.Graph.SpillClean + GHC.CmmToAsm.Reg.Graph.SpillCost + GHC.CmmToAsm.Reg.Graph.Stats + GHC.CmmToAsm.Reg.Graph.TrivColorable + GHC.CmmToAsm.Reg.Graph.X86 + GHC.CmmToAsm.Reg.Linear + GHC.CmmToAsm.Reg.Linear.AArch64 + GHC.CmmToAsm.Reg.Linear.Base + GHC.CmmToAsm.Reg.Linear.FreeRegs + GHC.CmmToAsm.Reg.Linear.JoinToTargets + GHC.CmmToAsm.Reg.Linear.LA64 + GHC.CmmToAsm.Reg.Linear.PPC + GHC.CmmToAsm.Reg.Linear.RV64 + GHC.CmmToAsm.Reg.Linear.StackMap + GHC.CmmToAsm.Reg.Linear.State + GHC.CmmToAsm.Reg.Linear.Stats + GHC.CmmToAsm.Reg.Linear.X86 + GHC.CmmToAsm.Reg.Linear.X86_64 + GHC.CmmToAsm.Reg.Liveness + GHC.CmmToAsm.Reg.Target + GHC.CmmToAsm.Reg.Utils + GHC.CmmToAsm.RV64 + GHC.CmmToAsm.RV64.CodeGen + GHC.CmmToAsm.RV64.Cond + GHC.CmmToAsm.RV64.Instr + GHC.CmmToAsm.RV64.Ppr + GHC.CmmToAsm.RV64.RegInfo + GHC.CmmToAsm.RV64.Regs + GHC.CmmToAsm.Types + GHC.CmmToAsm.Utils + GHC.CmmToAsm.X86 + GHC.CmmToAsm.X86.CodeGen + GHC.CmmToAsm.X86.Cond + GHC.CmmToAsm.X86.Instr + GHC.CmmToAsm.X86.Ppr + GHC.CmmToAsm.X86.RegInfo + GHC.CmmToAsm.X86.Regs + GHC.CmmToC + GHC.CmmToLlvm + GHC.CmmToLlvm.Base + GHC.CmmToLlvm.CodeGen + GHC.CmmToLlvm.Config + GHC.CmmToLlvm.Data + GHC.CmmToLlvm.Mangler + GHC.CmmToLlvm.Ppr + GHC.CmmToLlvm.Regs + GHC.CmmToLlvm.Version + GHC.CmmToLlvm.Version.Bounds + GHC.CmmToLlvm.Version.Type + GHC.Cmm.Dominators + GHC.Cmm.Reducibility + GHC.Cmm.Type + GHC.Cmm.Utils + GHC.Core + GHC.Core.Class + GHC.Core.Coercion + GHC.Core.Coercion.Axiom + GHC.Core.Coercion.Opt + GHC.Core.ConLike + GHC.Core.DataCon + GHC.Core.FamInstEnv + GHC.Core.FVs + GHC.Core.InstEnv + GHC.Core.Lint + GHC.Core.Lint.Interactive + GHC.Core.LateCC + GHC.Core.LateCC.Types + GHC.Core.LateCC.TopLevelBinds + GHC.Core.LateCC.Utils + GHC.Core.LateCC.OverloadedCalls + GHC.Core.Make + GHC.Core.Map.Expr + GHC.Core.Map.Type + GHC.Core.Multiplicity + GHC.Core.Opt.Arity + GHC.Core.Opt.CallArity + GHC.Core.Opt.CallerCC + GHC.Core.Opt.CallerCC.Types + GHC.Core.Opt.ConstantFold + GHC.Core.Opt.CprAnal + GHC.Core.Opt.CSE + GHC.Core.Opt.DmdAnal + GHC.Core.Opt.Exitify + GHC.Core.Opt.FloatIn + GHC.Core.Opt.FloatOut + GHC.Core.Opt.LiberateCase + GHC.Core.Opt.Monad + GHC.Core.Opt.OccurAnal + GHC.Core.Opt.Pipeline + GHC.Core.Opt.Pipeline.Types + GHC.Core.Opt.SetLevels + GHC.Core.Opt.Simplify + GHC.Core.Opt.Simplify.Env + GHC.Core.Opt.Simplify.Inline + GHC.Core.Opt.Simplify.Iteration + GHC.Core.Opt.Simplify.Monad + GHC.Core.Opt.Simplify.Utils + GHC.Core.Opt.SpecConstr + GHC.Core.Opt.Specialise + GHC.Core.Opt.StaticArgs + GHC.Core.Opt.Stats + GHC.Core.Opt.WorkWrap + GHC.Core.Opt.WorkWrap.Utils + GHC.Core.PatSyn + GHC.Core.Ppr + GHC.Types.TyThing.Ppr + GHC.Core.Predicate + GHC.Core.Reduction + GHC.Core.Rules + GHC.Core.Rules.Config + GHC.Core.Seq + GHC.Core.SimpleOpt + GHC.Core.Stats + GHC.Core.Subst + GHC.Core.Tidy + GHC.CoreToIface + GHC.CoreToStg + GHC.CoreToStg.Prep + GHC.CoreToStg.AddImplicitBinds + GHC.Core.TyCo.FVs + GHC.Core.TyCo.Compare + GHC.Core.TyCon + GHC.Core.TyCon.Env + GHC.Core.TyCon.RecWalk + GHC.Core.TyCon.Set + GHC.Core.TyCo.Ppr + GHC.Core.TyCo.Rep + GHC.Core.TyCo.Subst + GHC.Core.TyCo.Tidy + GHC.Core.Type + GHC.Core.RoughMap + GHC.Core.Unfold + GHC.Core.Unfold.Make + GHC.Core.Unify + GHC.Core.UsageEnv + GHC.Core.Utils + GHC.Data.Bag + GHC.Data.Bitmap + GHC.Data.Bool + GHC.Data.BooleanFormula + GHC.Data.EnumSet + GHC.Data.FastMutInt + GHC.Data.FastString + GHC.Data.FastString.Env + GHC.Data.FiniteMap + GHC.Data.FlatBag + GHC.Data.Graph.Base + GHC.Data.Graph.Color + GHC.Data.Graph.Collapse + GHC.Data.Graph.Directed + GHC.Data.Graph.Directed.Internal + GHC.Data.Graph.Directed.Reachability + GHC.Data.Graph.Inductive.Graph + GHC.Data.Graph.Inductive.PatriciaTree + GHC.Data.Graph.Ops + GHC.Data.Graph.Ppr + GHC.Data.Graph.UnVar + GHC.Data.IOEnv + GHC.Data.List + GHC.Data.List.Infinite + GHC.Data.List.NonEmpty + GHC.Data.List.SetOps + GHC.Data.Maybe + GHC.Data.OrdList + GHC.Data.OsPath + GHC.Data.Pair + GHC.Data.SmallArray + GHC.Data.Stream + GHC.Data.Strict + GHC.Data.StringBuffer + GHC.Data.TrieMap + GHC.Data.Unboxed + GHC.Data.UnionFind + GHC.Data.Word64Set + GHC.Data.Word64Set.Internal + GHC.Data.Word64Map + GHC.Data.Word64Map.Internal + GHC.Data.Word64Map.Lazy + GHC.Data.Word64Map.Strict + GHC.Data.Word64Map.Strict.Internal + GHC.Driver.Backend + GHC.Driver.Backend.Internal + GHC.Driver.Backpack + GHC.Driver.Backpack.Syntax + GHC.Driver.CmdLine + GHC.Driver.CodeOutput + GHC.Driver.Config + GHC.Driver.Config.Cmm + GHC.Driver.Config.Cmm.Parser + GHC.Driver.Config.CmmToAsm + GHC.Driver.Config.CmmToLlvm + GHC.Driver.Config.Core.Lint + GHC.Driver.Config.Core.Lint.Interactive + GHC.Driver.Config.Core.Opt.Arity + GHC.Driver.Config.Core.Opt.LiberateCase + GHC.Driver.Config.Core.Opt.Simplify + GHC.Driver.Config.Core.Opt.WorkWrap + GHC.Driver.Config.Core.Rules + GHC.Driver.Config.CoreToStg + GHC.Driver.Config.CoreToStg.Prep + GHC.Driver.Config.Diagnostic + GHC.Driver.Config.Finder + GHC.Driver.Config.HsToCore + GHC.Driver.Config.HsToCore.Ticks + GHC.Driver.Config.HsToCore.Usage + GHC.Driver.Config.Linker + GHC.Driver.Config.Logger + GHC.Driver.Config.Parser + GHC.Driver.Config.Stg.Debug + GHC.Driver.Config.Stg.Lift + GHC.Driver.Config.Stg.Pipeline + GHC.Driver.Config.Stg.Ppr + GHC.Driver.Config.StgToCmm + GHC.Driver.Config.Tidy + GHC.Driver.Config.StgToJS + GHC.Driver.DynFlags + GHC.Driver.IncludeSpecs + GHC.Driver.Downsweep + GHC.Driver.Env + GHC.Driver.Env.KnotVars + GHC.Driver.Env.Types + GHC.Driver.Errors + GHC.Driver.Errors.Ppr + GHC.Driver.Errors.Types + GHC.Driver.Flags + GHC.Driver.GenerateCgIPEStub + GHC.Driver.Hooks + GHC.Driver.LlvmConfigCache + GHC.Driver.MakeSem + GHC.Driver.Main + GHC.Driver.Make + GHC.Driver.Messager + GHC.Driver.MakeAction + GHC.Driver.MakeFile + GHC.Driver.Monad + GHC.Driver.Phases + GHC.Driver.Pipeline + GHC.Driver.Pipeline.Execute + GHC.Driver.Pipeline.LogQueue + GHC.Driver.Pipeline.Phases + GHC.Driver.Pipeline.Monad + GHC.Driver.Plugins + GHC.Driver.Plugins.External + GHC.Driver.Ppr + GHC.Driver.Session + GHC.Driver.Session.Inspect + GHC.Driver.Session.Units + GHC.Hs + GHC.Hs.Basic + GHC.Hs.Binds + GHC.Hs.Decls + GHC.Hs.Doc + GHC.Hs.DocString + GHC.Hs.Dump + GHC.Hs.Expr + GHC.Hs.Syn.Type + GHC.Hs.Extension + GHC.Hs.ImpExp + GHC.Hs.Instances + GHC.Hs.Lit + GHC.Hs.Pat + GHC.Hs.Specificity + GHC.Hs.Stats + GHC.HsToCore + GHC.HsToCore.Arrows + GHC.HsToCore.Binds + GHC.HsToCore.Breakpoints + GHC.HsToCore.Coverage + GHC.HsToCore.Docs + GHC.HsToCore.Errors.Ppr + GHC.HsToCore.Errors.Types + GHC.HsToCore.Expr + GHC.HsToCore.Foreign.C + GHC.HsToCore.Foreign.Call + GHC.HsToCore.Foreign.Decl + GHC.HsToCore.Foreign.JavaScript + GHC.HsToCore.Foreign.Prim + GHC.HsToCore.Foreign.Utils + GHC.HsToCore.Foreign.Wasm + GHC.HsToCore.GuardedRHSs + GHC.HsToCore.ListComp + GHC.HsToCore.Match + GHC.HsToCore.Match.Constructor + GHC.HsToCore.Match.Literal + GHC.HsToCore.Monad + GHC.HsToCore.Pmc + GHC.HsToCore.Pmc.Check + GHC.HsToCore.Pmc.Desugar + GHC.HsToCore.Pmc.Ppr + GHC.HsToCore.Pmc.Solver + GHC.HsToCore.Pmc.Solver.Types + GHC.HsToCore.Pmc.Types + GHC.HsToCore.Pmc.Utils + GHC.HsToCore.Quote + GHC.HsToCore.Ticks + GHC.HsToCore.Types + GHC.HsToCore.Usage + GHC.HsToCore.Utils + GHC.Hs.Type + GHC.Hs.Utils + GHC.Iface.Binary + GHC.Iface.Decl + GHC.Iface.Env + GHC.Iface.Errors + GHC.Iface.Errors.Types + GHC.Iface.Errors.Ppr + GHC.Iface.Ext.Ast + GHC.Iface.Ext.Binary + GHC.Iface.Ext.Debug + GHC.Iface.Ext.Fields + GHC.Iface.Ext.Types + GHC.Iface.Ext.Utils + GHC.Iface.Load + GHC.Iface.Make + GHC.Iface.Recomp + GHC.Iface.Recomp.Binary + GHC.Iface.Recomp.Flags + GHC.Iface.Recomp.Types + GHC.Iface.Rename + GHC.Iface.Syntax + GHC.Iface.Flags + GHC.Iface.Tidy + GHC.Iface.Tidy.StaticPtrTable + GHC.Iface.Warnings + GHC.IfaceToCore + GHC.Iface.Type + GHC.JS.Ident + GHC.JS.Make + GHC.JS.Optimizer + GHC.JS.Opt.Expr + GHC.JS.Opt.Simple + GHC.JS.Ppr + GHC.JS.Syntax + GHC.JS.JStg.Syntax + GHC.JS.JStg.Monad + GHC.JS.Transform + GHC.Linker.Config + GHC.Linker.Deps + GHC.Linker.Dynamic + GHC.Linker.External + GHC.Linker.ExtraObj + GHC.Linker.Loader + GHC.Linker.MacOS + GHC.Linker.Static + GHC.Linker.Static.Utils + GHC.Linker.Types + GHC.Linker.Unit + GHC.Linker.Windows + GHC.Llvm + GHC.Llvm.MetaData + GHC.Llvm.Ppr + GHC.Llvm.Syntax + GHC.Llvm.Types + GHC.Parser + GHC.Parser.Annotation + GHC.Parser.CharClass + GHC.Parser.Errors.Basic + GHC.Parser.Errors.Ppr + GHC.Parser.Errors.Types + GHC.Parser.Header + GHC.Parser.Lexer + GHC.Parser.Lexer.Interface + GHC.Parser.Lexer.String + GHC.Parser.HaddockLex + GHC.Parser.PostProcess + GHC.Parser.PostProcess.Haddock + GHC.Parser.String + GHC.Parser.Types + GHC.Parser.Utils + GHC.Platform + GHC.Platform.ARM + GHC.Platform.AArch64 + GHC.Platform.Constants + GHC.Platform.LA64 + GHC.Platform.NoRegs + GHC.Platform.PPC + GHC.Platform.Profile + GHC.Platform.Reg + GHC.Platform.Reg.Class + GHC.Platform.Reg.Class.NoVectors + GHC.Platform.Reg.Class.Separate + GHC.Platform.Reg.Class.Unified + GHC.Platform.Regs + GHC.Platform.RISCV64 + GHC.Platform.S390X + GHC.Platform.Wasm32 + GHC.Platform.Ways + GHC.Platform.X86 + GHC.Platform.X86_64 + GHC.Plugins + GHC.Prelude + GHC.Prelude.Basic + GHC.Rename.Bind + GHC.Rename.Doc + GHC.Rename.Env + GHC.Rename.Expr + GHC.Rename.Fixity + GHC.Rename.HsType + GHC.Rename.Module + GHC.Rename.Names + GHC.Rename.Pat + GHC.Rename.Splice + GHC.Rename.Unbound + GHC.Rename.Utils + GHC.Runtime.Context + GHC.Runtime.Debugger + GHC.Runtime.Debugger.Breakpoints + GHC.Runtime.Eval + GHC.Runtime.Eval.Types + GHC.Runtime.Eval.Utils + GHC.Runtime.Heap.Inspect + GHC.Runtime.Heap.Layout + GHC.Runtime.Interpreter + GHC.Runtime.Interpreter.JS + GHC.Runtime.Interpreter.Process + GHC.Runtime.Interpreter.Types + GHC.Runtime.Interpreter.Types.SymbolCache + GHC.Runtime.Interpreter.Wasm + GHC.Runtime.Loader + GHC.Runtime.Utils + GHC.Settings + GHC.Settings.Config + GHC.Settings.Constants + GHC.Settings.IO + GHC.Stg.BcPrep + GHC.Stg.CSE + GHC.Stg.Debug + GHC.Stg.EnforceEpt + GHC.Stg.EnforceEpt.Rewrite + GHC.Stg.EnforceEpt.TagSig + GHC.Stg.EnforceEpt.Types + GHC.Stg.FVs + GHC.Stg.Lift + GHC.Stg.Lift.Analysis + GHC.Stg.Lift.Config + GHC.Stg.Lift.Monad + GHC.Stg.Lift.Types + GHC.Stg.Lint + GHC.Stg.Make + GHC.Stg.Pipeline + GHC.Stg.Stats + GHC.Stg.Subst + GHC.Stg.Syntax + GHC.Stg.Utils + GHC.StgToByteCode + GHC.StgToCmm + GHC.StgToCmm.ArgRep + GHC.StgToCmm.Bind + GHC.StgToCmm.CgUtils + GHC.StgToCmm.Closure + GHC.StgToCmm.Config + GHC.StgToCmm.DataCon + GHC.StgToCmm.Env + GHC.StgToCmm.Expr + GHC.StgToCmm.ExtCode + GHC.StgToCmm.Foreign + GHC.StgToCmm.Heap + GHC.StgToCmm.Hpc + GHC.StgToCmm.InfoTableProv + GHC.StgToCmm.Layout + GHC.StgToCmm.Lit + GHC.StgToCmm.Monad + GHC.StgToCmm.Prim + GHC.StgToCmm.Prof + GHC.StgToCmm.Sequel + GHC.StgToCmm.TagCheck + GHC.StgToCmm.Ticky + GHC.StgToCmm.Types + GHC.StgToCmm.Utils + GHC.StgToJS + GHC.StgToJS.Apply + GHC.StgToJS.Arg + GHC.StgToJS.Closure + GHC.StgToJS.CodeGen + GHC.StgToJS.DataCon + GHC.StgToJS.Deps + GHC.StgToJS.Expr + GHC.StgToJS.ExprCtx + GHC.StgToJS.FFI + GHC.StgToJS.Heap + GHC.StgToJS.Ids + GHC.StgToJS.Literal + GHC.StgToJS.Monad + GHC.StgToJS.Object + GHC.StgToJS.Prim + GHC.StgToJS.Profiling + GHC.StgToJS.Regs + GHC.StgToJS.Rts.Types + GHC.StgToJS.Rts.Rts + GHC.StgToJS.Sinker.Collect + GHC.StgToJS.Sinker.StringsUnfloat + GHC.StgToJS.Sinker.Sinker + GHC.StgToJS.Stack + GHC.StgToJS.StaticPtr + GHC.StgToJS.Symbols + GHC.StgToJS.Types + GHC.StgToJS.Utils + GHC.StgToJS.Linker.Linker + GHC.StgToJS.Linker.Types + GHC.StgToJS.Linker.Utils + GHC.StgToJS.Linker.Opt + GHC.Stg.Unarise + GHC.SysTools + GHC.SysTools.Ar + GHC.SysTools.BaseDir + GHC.SysTools.Cpp + GHC.SysTools.Elf + GHC.SysTools.Process + GHC.SysTools.Tasks + GHC.SysTools.Terminal + GHC.Tc.Deriv + GHC.Tc.Deriv.Functor + GHC.Tc.Deriv.Generate + GHC.Tc.Deriv.Generics + GHC.Tc.Deriv.Infer + GHC.Tc.Deriv.Utils + GHC.Tc.Errors + GHC.Tc.Errors.Hole + GHC.Tc.Errors.Hole.FitTypes + GHC.Tc.Errors.Hole.Plugin + GHC.Tc.Errors.Ppr + GHC.Tc.Errors.Types + GHC.Tc.Errors.Types.PromotionErr + GHC.Tc.Gen.Annotation + GHC.Tc.Gen.App + GHC.Tc.Gen.Arrow + GHC.Tc.Gen.Bind + GHC.Tc.Gen.Default + GHC.Tc.Gen.Do + GHC.Tc.Gen.Export + GHC.Tc.Gen.Expr + GHC.Tc.Gen.Foreign + GHC.Tc.Gen.Head + GHC.Tc.Gen.HsType + GHC.Tc.Gen.Match + GHC.Tc.Gen.Pat + GHC.Tc.Gen.Sig + GHC.Tc.Gen.Splice + GHC.Tc.Instance.Class + GHC.Tc.Instance.Family + GHC.Tc.Instance.FunDeps + GHC.Tc.Instance.Typeable + GHC.Tc.Module + GHC.Tc.Plugin + GHC.Tc.Solver + GHC.Tc.Solver.Default + GHC.Tc.Solver.Rewrite + GHC.Tc.Solver.InertSet + GHC.Tc.Solver.Solve + GHC.Tc.Solver.Irred + GHC.Tc.Solver.Equality + GHC.Tc.Solver.Dict + GHC.Tc.Solver.Monad + GHC.Tc.Solver.Types + GHC.Tc.TyCl + GHC.Tc.TyCl.Build + GHC.Tc.TyCl.Class + GHC.Tc.TyCl.Instance + GHC.Tc.TyCl.PatSyn + GHC.Tc.TyCl.Utils + GHC.Tc.Types + GHC.Tc.Types.Constraint + GHC.Tc.Types.Evidence + GHC.Tc.Types.Origin + GHC.Tc.Types.Rank + GHC.Tc.Types.CtLoc + GHC.Tc.Types.ErrCtxt + GHC.Tc.Types.LclEnv + GHC.Tc.Types.TH + GHC.Tc.Types.TcRef + GHC.Tc.Types.BasicTypes + GHC.Tc.Utils.Backpack + GHC.Tc.Utils.Concrete + GHC.Tc.Utils.Env + GHC.Tc.Utils.Instantiate + GHC.Tc.Utils.Monad + GHC.Tc.Utils.TcMType + GHC.Tc.Utils.TcType + GHC.Tc.Utils.Unify + GHC.Tc.Validity + GHC.Tc.Zonk.Env + GHC.Tc.Zonk.Monad + GHC.Tc.Zonk.TcType + GHC.Tc.Zonk.Type + GHC.ThToHs + GHC.Types.Annotations + GHC.Types.Avail + GHC.Types.Basic + GHC.Types.CompleteMatch + GHC.Types.CostCentre + GHC.Types.CostCentre.State + GHC.Types.Cpr + GHC.Types.DefaultEnv + GHC.Types.Demand + GHC.Types.Error + GHC.Types.Error.Codes + GHC.Types.FieldLabel + GHC.Types.Fixity + GHC.Types.Fixity.Env + GHC.Types.ForeignCall + GHC.Types.ForeignStubs + GHC.Types.GREInfo + GHC.Types.Hint + GHC.Types.Hint.Ppr + GHC.Types.HpcInfo + GHC.Types.Id + GHC.Types.IPE + GHC.Types.ThLevelIndex + GHC.Types.Id.Info + GHC.Types.Id.Make + GHC.Types.Literal + GHC.Types.Meta + GHC.Types.Name + GHC.Types.Name.Cache + GHC.Types.Name.Env + GHC.Types.Name.Occurrence + GHC.Types.Name.Reader + GHC.Types.Name.Set + GHC.Types.Name.Shape + GHC.Types.Name.Ppr + GHC.Types.PkgQual + GHC.Types.ProfAuto + GHC.Types.RepType + GHC.Types.SafeHaskell + GHC.Types.SaneDouble + GHC.Types.SourceError + GHC.Types.SourceFile + GHC.Types.SourceText + GHC.Types.SptEntry + GHC.Types.SrcLoc + GHC.Types.Target + GHC.Types.Tickish + GHC.Types.TypeEnv + GHC.Types.TyThing + GHC.Types.Unique + GHC.Types.Unique.DFM + GHC.Types.Unique.DSet + GHC.Types.Unique.DSM + GHC.Types.Unique.FM + GHC.Types.Unique.Map + GHC.Types.Unique.MemoFun + GHC.Types.Unique.SDFM + GHC.Types.Unique.Set + GHC.Types.Unique.Supply + GHC.Types.Var + GHC.Types.Var.Env + GHC.Types.Var.Set + GHC.Unit + GHC.Unit.Env + GHC.Unit.External + GHC.Unit.Finder + GHC.Unit.Finder.Types + GHC.Unit.Home + GHC.Unit.Home.Graph + GHC.Unit.Home.ModInfo + GHC.Unit.Home.PackageTable + GHC.Unit.Info + GHC.Unit.Module + GHC.Unit.Module.Deps + GHC.Unit.Module.Env + GHC.Unit.Module.Graph + GHC.Unit.Module.ModNodeKey + GHC.Unit.Module.Stage + GHC.Unit.Module.Imported + GHC.Unit.Module.Location + GHC.Unit.Module.ModDetails + GHC.Unit.Module.ModGuts + GHC.Unit.Module.ModIface + GHC.Unit.Module.WholeCoreBindings + GHC.Unit.Module.ModSummary + GHC.Unit.Module.Status + GHC.Unit.Module.Warnings + GHC.Unit.Parser + GHC.Unit.Ppr + GHC.Unit.State + GHC.Unit.Types + GHC.Utils.Asm + GHC.Utils.Binary + GHC.Utils.Binary.Typeable + GHC.Utils.BufHandle + GHC.Utils.CliOption + GHC.Utils.Constants + GHC.Utils.Containers.Internal.BitUtil + GHC.Utils.Containers.Internal.StrictPair + GHC.Utils.Error + GHC.Utils.Exception + GHC.Utils.Fingerprint + GHC.Utils.FV + GHC.Utils.GlobalVars + GHC.Utils.IO.Unsafe + GHC.Utils.Json + GHC.Utils.Lexeme + GHC.Utils.Logger + GHC.Utils.Misc + GHC.Utils.Monad + GHC.Utils.Monad.Codensity + 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.Touch + GHC.Utils.Trace + GHC.Utils.Unique + GHC.Utils.Word64 + GHC.Wasm.ControlFlow + GHC.Wasm.ControlFlow.FromCmm + GHC.CmmToAsm.Wasm + GHC.CmmToAsm.Wasm.Asm + GHC.CmmToAsm.Wasm.FromCmm + GHC.CmmToAsm.Wasm.Types + GHC.CmmToAsm.Wasm.Utils + + Language.Haskell.Syntax + Language.Haskell.Syntax.Basic + Language.Haskell.Syntax.Binds + Language.Haskell.Syntax.BooleanFormula + Language.Haskell.Syntax.Decls + Language.Haskell.Syntax.Expr + Language.Haskell.Syntax.Extension + Language.Haskell.Syntax.ImpExp + Language.Haskell.Syntax.ImpExp.IsBoot + Language.Haskell.Syntax.Lit + Language.Haskell.Syntax.Module.Name + Language.Haskell.Syntax.Pat + Language.Haskell.Syntax.Specificity + Language.Haskell.Syntax.Type + + autogen-modules: GHC.Platform.Constants + GHC.Settings.Config + + reexported-modules: + GHC.Platform.ArchOS + , GHC.Platform.Host diff --git a/ghci/ByteCodeAsm.hs b/ghci/ByteCodeAsm.hs deleted file mode 100644 --- a/ghci/ByteCodeAsm.hs +++ /dev/null @@ -1,538 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeLink: Bytecode assembler and linker -module ByteCodeAsm ( - assembleBCOs, assembleOneBCO, - - bcoFreeNames, - SizedSeq, sizeSS, ssElts, - iNTERP_STACK_CHECK_THRESH - ) where - -#include "HsVersions.h" - -import ByteCodeInstr -import ByteCodeItbls -import ByteCodeTypes -import GHCi.RemoteTypes -import GHCi - -import HscTypes -import Name -import NameSet -import Literal -import TyCon -import FastString -import StgCmmLayout ( ArgRep(..) ) -import SMRep -import DynFlags -import Outputable -import Platform -import Util -import Unique -import UniqDSet - --- From iserv -import SizedSeq - -import Control.Monad -import Control.Monad.ST ( runST ) -import Control.Monad.Trans.Class -import Control.Monad.Trans.State.Strict - -import Data.Array.MArray - -import qualified Data.Array.Unboxed as Array -import Data.Array.Base ( UArray(..) ) - -import Data.Array.Unsafe( castSTUArray ) - -import Foreign -import Data.Char ( ord ) -import Data.List -import Data.Map (Map) -import Data.Maybe (fromMaybe) -import qualified Data.Map as Map - --- ----------------------------------------------------------------------------- --- Unlinked BCOs - --- CompiledByteCode represents the result of byte-code --- compiling a bunch of functions and data types - --- | Finds external references. Remember to remove the names --- defined by this group of BCOs themselves -bcoFreeNames :: UnlinkedBCO -> UniqDSet Name -bcoFreeNames bco - = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] - where - bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) - = unionManyUniqDSets ( - mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] : - mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] : - map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ] - ) - --- ----------------------------------------------------------------------------- --- The bytecode assembler - --- The object format for bytecodes is: 16 bits for the opcode, and 16 --- for each field -- so the code can be considered a sequence of --- 16-bit ints. Each field denotes either a stack offset or number of --- items on the stack (eg SLIDE), and index into the pointer table (eg --- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a --- bytecode address in this BCO. - --- Top level assembler fn. -assembleBCOs - :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()] - -> Maybe ModBreaks - -> IO CompiledByteCode -assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do - itblenv <- mkITbls hsc_env tycons - bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos - (bcos',ptrs) <- mallocStrings hsc_env bcos - return CompiledByteCode - { bc_bcos = bcos' - , bc_itbls = itblenv - , bc_ffis = concat (map protoBCOFFIs proto_bcos) - , bc_strs = top_strs ++ ptrs - , bc_breaks = modbreaks - } - --- Find all the literal strings and malloc them together. We want to --- do this because: --- --- a) It should be done when we compile the module, not each time we relink it --- b) For -fexternal-interpreter It's more efficient to malloc the strings --- as a single batch message, especially when compiling in parallel. --- -mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()]) -mallocStrings hsc_env ulbcos = do - let bytestrings = reverse (execState (mapM_ collect ulbcos) []) - ptrs <- iservCmd hsc_env (MallocStrings bytestrings) - return (evalState (mapM splice ulbcos) ptrs, ptrs) - where - splice bco@UnlinkedBCO{..} = do - lits <- mapM spliceLit unlinkedBCOLits - ptrs <- mapM splicePtr unlinkedBCOPtrs - return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs } - - spliceLit (BCONPtrStr _) = do - (RemotePtr p : rest) <- get - put rest - return (BCONPtrWord (fromIntegral p)) - spliceLit other = return other - - splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco - splicePtr other = return other - - collect UnlinkedBCO{..} = do - mapM_ collectLit unlinkedBCOLits - mapM_ collectPtr unlinkedBCOPtrs - - collectLit (BCONPtrStr bs) = do - strs <- get - put (bs:strs) - collectLit _ = return () - - collectPtr (BCOPtrBCO bco) = collect bco - collectPtr _ = return () - - -assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO -assembleOneBCO hsc_env pbco = do - ubco <- assembleBCO (hsc_dflags hsc_env) pbco - ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco] - return ubco' - -assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO -assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do - -- pass 1: collect up the offsets of the local labels. - let asm = mapM_ (assembleI dflags) instrs - - initial_offset = 0 - - -- Jump instructions are variable-sized, there are long and short variants - -- depending on the magnitude of the offset. However, we can't tell what - -- size instructions we will need until we have calculated the offsets of - -- the labels, which depends on the size of the instructions... So we - -- first create the label environment assuming that all jumps are short, - -- and if the final size is indeed small enough for short jumps, we are - -- done. Otherwise, we repeat the calculation, and we force all jumps in - -- this BCO to be long. - (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm - ((n_insns, lbl_map), long_jumps) - | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True) - | otherwise = ((n_insns0, lbl_map0), False) - - env :: Word16 -> Word - env lbl = fromMaybe - (pprPanic "assembleBCO.findLabel" (ppr lbl)) - (Map.lookup lbl lbl_map) - - -- pass 2: run assembler and generate instructions, literals and pointers - let initial_state = (emptySS, emptySS, emptySS) - (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm - - -- precomputed size should be equal to final size - ASSERT(n_insns == sizeSS final_insns) return () - - let asm_insns = ssElts final_insns - insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns - bitmap_arr = mkBitmapArray bsize bitmap - ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs - - -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive - -- objects, since they might get run too early. Disable this until - -- we figure out what to do. - -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) - - return ul_bco - -mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word --- Here the return type must be an array of Words, not StgWords, --- because the underlying ByteArray# will end up as a component --- of a BCO object. -mkBitmapArray bsize bitmap - = Array.listArray (0, length bitmap) $ - fromIntegral bsize : map (fromInteger . fromStgWord) bitmap - --- instrs nonptrs ptrs -type AsmState = (SizedSeq Word16, - SizedSeq BCONPtr, - SizedSeq BCOPtr) - -data Operand - = Op Word - | SmallOp Word16 - | LabelOp Word16 --- (unused) | LargeOp Word - -data Assembler a - = AllocPtr (IO BCOPtr) (Word -> Assembler a) - | AllocLit [BCONPtr] (Word -> Assembler a) - | AllocLabel Word16 (Assembler a) - | Emit Word16 [Operand] (Assembler a) - | NullAsm a - -instance Functor Assembler where - fmap = liftM - -instance Applicative Assembler where - pure = NullAsm - (<*>) = ap - -instance Monad Assembler where - NullAsm x >>= f = f x - AllocPtr p k >>= f = AllocPtr p (k >=> f) - AllocLit l k >>= f = AllocLit l (k >=> f) - AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f) - Emit w ops k >>= f = Emit w ops (k >>= f) - -ioptr :: IO BCOPtr -> Assembler Word -ioptr p = AllocPtr p return - -ptr :: BCOPtr -> Assembler Word -ptr = ioptr . return - -lit :: [BCONPtr] -> Assembler Word -lit l = AllocLit l return - -label :: Word16 -> Assembler () -label w = AllocLabel w (return ()) - -emit :: Word16 -> [Operand] -> Assembler () -emit w ops = Emit w ops (return ()) - -type LabelEnv = Word16 -> Word - -largeOp :: Bool -> Operand -> Bool -largeOp long_jumps op = case op of - SmallOp _ -> False - Op w -> isLarge w - LabelOp _ -> long_jumps --- LargeOp _ -> True - -runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a -runAsm dflags long_jumps e = go - where - go (NullAsm x) = return x - go (AllocPtr p_io k) = do - p <- lift p_io - w <- state $ \(st_i0,st_l0,st_p0) -> - let st_p1 = addToSS st_p0 p - in (sizeSS st_p0, (st_i0,st_l0,st_p1)) - go $ k w - go (AllocLit lits k) = do - w <- state $ \(st_i0,st_l0,st_p0) -> - let st_l1 = addListToSS st_l0 lits - in (sizeSS st_l0, (st_i0,st_l1,st_p0)) - go $ k w - go (AllocLabel _ k) = go k - go (Emit w ops k) = do - let largeOps = any (largeOp long_jumps) ops - opcode - | largeOps = largeArgInstr w - | otherwise = w - words = concatMap expand ops - expand (SmallOp w) = [w] - expand (LabelOp w) = expand (Op (e w)) - expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w] --- expand (LargeOp w) = largeArg dflags w - state $ \(st_i0,st_l0,st_p0) -> - let st_i1 = addListToSS st_i0 (opcode : words) - in ((), (st_i1,st_l0,st_p0)) - go k - -type LabelEnvMap = Map Word16 Word - -data InspectState = InspectState - { instrCount :: !Word - , ptrCount :: !Word - , litCount :: !Word - , lblEnv :: LabelEnvMap - } - -inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap) -inspectAsm dflags long_jumps initial_offset - = go (InspectState initial_offset 0 0 Map.empty) - where - go s (NullAsm _) = (instrCount s, lblEnv s) - go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n) - where n = ptrCount s - go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n) - where n = litCount s - go s (AllocLabel lbl k) = go s' k - where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) } - go s (Emit _ ops k) = go s' k - where - s' = s { instrCount = instrCount s + size } - size = sum (map count ops) + 1 - largeOps = any (largeOp long_jumps) ops - count (SmallOp _) = 1 - count (LabelOp _) = count (Op 0) - count (Op _) = if largeOps then largeArg16s dflags else 1 --- count (LargeOp _) = largeArg16s dflags - --- Bring in all the bci_ bytecode constants. -#include "rts/Bytecodes.h" - -largeArgInstr :: Word16 -> Word16 -largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci - -largeArg :: DynFlags -> Word -> [Word16] -largeArg dflags w - | wORD_SIZE_IN_BITS dflags == 64 - = [fromIntegral (w `shiftR` 48), - fromIntegral (w `shiftR` 32), - fromIntegral (w `shiftR` 16), - fromIntegral w] - | wORD_SIZE_IN_BITS dflags == 32 - = [fromIntegral (w `shiftR` 16), - fromIntegral w] - | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" - -largeArg16s :: DynFlags -> Word -largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4 - | otherwise = 2 - -assembleI :: DynFlags - -> BCInstr - -> Assembler () -assembleI dflags i = case i of - STKCHECK n -> emit bci_STKCHECK [Op n] - PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1] - PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] - PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3] - PUSH_G nm -> do p <- ptr (BCOPtrName nm) - emit bci_PUSH_G [Op p] - PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) - emit bci_PUSH_G [Op p] - PUSH_BCO proto -> do let ul_bco = assembleBCO dflags proto - p <- ioptr (liftM BCOPtrBCO ul_bco) - emit bci_PUSH_G [Op p] - PUSH_ALTS proto -> do let ul_bco = assembleBCO dflags proto - p <- ioptr (liftM BCOPtrBCO ul_bco) - emit bci_PUSH_ALTS [Op p] - PUSH_ALTS_UNLIFTED proto pk - -> do let ul_bco = assembleBCO dflags proto - p <- ioptr (liftM BCOPtrBCO ul_bco) - emit (push_alts pk) [Op p] - PUSH_UBX lit nws -> do np <- literal lit - emit bci_PUSH_UBX [Op np, SmallOp nws] - - PUSH_APPLY_N -> emit bci_PUSH_APPLY_N [] - PUSH_APPLY_V -> emit bci_PUSH_APPLY_V [] - PUSH_APPLY_F -> emit bci_PUSH_APPLY_F [] - PUSH_APPLY_D -> emit bci_PUSH_APPLY_D [] - PUSH_APPLY_L -> emit bci_PUSH_APPLY_L [] - PUSH_APPLY_P -> emit bci_PUSH_APPLY_P [] - PUSH_APPLY_PP -> emit bci_PUSH_APPLY_PP [] - PUSH_APPLY_PPP -> emit bci_PUSH_APPLY_PPP [] - PUSH_APPLY_PPPP -> emit bci_PUSH_APPLY_PPPP [] - PUSH_APPLY_PPPPP -> emit bci_PUSH_APPLY_PPPPP [] - PUSH_APPLY_PPPPPP -> emit bci_PUSH_APPLY_PPPPPP [] - - SLIDE n by -> emit bci_SLIDE [SmallOp n, SmallOp by] - ALLOC_AP n -> emit bci_ALLOC_AP [SmallOp n] - ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [SmallOp n] - ALLOC_PAP arity n -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n] - MKAP off sz -> emit bci_MKAP [SmallOp off, SmallOp sz] - MKPAP off sz -> emit bci_MKPAP [SmallOp off, SmallOp sz] - UNPACK n -> emit bci_UNPACK [SmallOp n] - PACK dcon sz -> do itbl_no <- lit [BCONPtrItbl (getName dcon)] - emit bci_PACK [Op itbl_no, SmallOp sz] - LABEL lbl -> label lbl - TESTLT_I i l -> do np <- int i - emit bci_TESTLT_I [Op np, LabelOp l] - TESTEQ_I i l -> do np <- int i - emit bci_TESTEQ_I [Op np, LabelOp l] - TESTLT_W w l -> do np <- word w - emit bci_TESTLT_W [Op np, LabelOp l] - TESTEQ_W w l -> do np <- word w - emit bci_TESTEQ_W [Op np, LabelOp l] - TESTLT_F f l -> do np <- float f - emit bci_TESTLT_F [Op np, LabelOp l] - TESTEQ_F f l -> do np <- float f - emit bci_TESTEQ_F [Op np, LabelOp l] - TESTLT_D d l -> do np <- double d - emit bci_TESTLT_D [Op np, LabelOp l] - TESTEQ_D d l -> do np <- double d - emit bci_TESTEQ_D [Op np, LabelOp l] - TESTLT_P i l -> emit bci_TESTLT_P [SmallOp i, LabelOp l] - TESTEQ_P i l -> emit bci_TESTEQ_P [SmallOp i, LabelOp l] - CASEFAIL -> emit bci_CASEFAIL [] - SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n] - JMP l -> emit bci_JMP [LabelOp l] - ENTER -> emit bci_ENTER [] - RETURN -> emit bci_RETURN [] - RETURN_UBX rep -> emit (return_ubx rep) [] - CCALL off m_addr i -> do np <- addr m_addr - emit bci_CCALL [SmallOp off, Op np, SmallOp i] - BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray - q <- int (getKey uniq) - np <- addr cc - emit bci_BRK_FUN [Op p1, SmallOp index, - Op q, Op np] - - where - literal (MachLabel fs (Just sz) _) - | platformOS (targetPlatform dflags) == OSMinGW32 - = litlabel (appendFS fs (mkFastString ('@':show sz))) - -- On Windows, stdcall labels have a suffix indicating the no. of - -- arg words, e.g. foo@8. testcase: ffi012(ghci) - literal (MachLabel fs _ _) = litlabel fs - literal (MachWord w) = int (fromIntegral w) - literal (MachInt j) = int (fromIntegral j) - literal MachNullAddr = int 0 - literal (MachFloat r) = float (fromRational r) - literal (MachDouble r) = double (fromRational r) - literal (MachChar c) = int (ord c) - literal (MachInt64 ii) = int64 (fromIntegral ii) - literal (MachWord64 ii) = int64 (fromIntegral ii) - literal (MachStr bs) = lit [BCONPtrStr bs] - -- MachStr requires a zero-terminator when emitted - literal LitInteger{} = panic "ByteCodeAsm.literal: LitInteger" - - litlabel fs = lit [BCONPtrLbl fs] - addr (RemotePtr a) = words [fromIntegral a] - float = words . mkLitF - double = words . mkLitD dflags - int = words . mkLitI - int64 = words . mkLitI64 dflags - words ws = lit (map BCONPtrWord ws) - word w = words [w] - -isLarge :: Word -> Bool -isLarge n = n > 65535 - -push_alts :: ArgRep -> Word16 -push_alts V = bci_PUSH_ALTS_V -push_alts P = bci_PUSH_ALTS_P -push_alts N = bci_PUSH_ALTS_N -push_alts L = bci_PUSH_ALTS_L -push_alts F = bci_PUSH_ALTS_F -push_alts D = bci_PUSH_ALTS_D -push_alts V16 = error "push_alts: vector" -push_alts V32 = error "push_alts: vector" -push_alts V64 = error "push_alts: vector" - -return_ubx :: ArgRep -> Word16 -return_ubx V = bci_RETURN_V -return_ubx P = bci_RETURN_P -return_ubx N = bci_RETURN_N -return_ubx L = bci_RETURN_L -return_ubx F = bci_RETURN_F -return_ubx D = bci_RETURN_D -return_ubx V16 = error "return_ubx: vector" -return_ubx V32 = error "return_ubx: vector" -return_ubx V64 = error "return_ubx: vector" - --- Make lists of host-sized words for literals, so that when the --- words are placed in memory at increasing addresses, the --- bit pattern is correct for the host's word size and endianness. -mkLitI :: Int -> [Word] -mkLitF :: Float -> [Word] -mkLitD :: DynFlags -> Double -> [Word] -mkLitI64 :: DynFlags -> Int64 -> [Word] - -mkLitF f - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 f - f_arr <- castSTUArray arr - w0 <- readArray f_arr 0 - return [w0 :: Word] - ) - -mkLitD dflags d - | wORD_SIZE dflags == 4 - = runST (do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 d - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - w1 <- readArray d_arr 1 - return [w0 :: Word, w1] - ) - | wORD_SIZE dflags == 8 - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 d - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - return [w0 :: Word] - ) - | otherwise - = panic "mkLitD: Bad wORD_SIZE" - -mkLitI64 dflags ii - | wORD_SIZE dflags == 4 - = runST (do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 ii - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - w1 <- readArray d_arr 1 - return [w0 :: Word,w1] - ) - | wORD_SIZE dflags == 8 - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 ii - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - return [w0 :: Word] - ) - | otherwise - = panic "mkLitI64: Bad wORD_SIZE" - -mkLitI i = [fromIntegral i :: Word] - -iNTERP_STACK_CHECK_THRESH :: Int -iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH diff --git a/ghci/ByteCodeGen.hs b/ghci/ByteCodeGen.hs deleted file mode 100644 --- a/ghci/ByteCodeGen.hs +++ /dev/null @@ -1,1798 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} -{-# OPTIONS_GHC -fprof-auto-top #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeGen: Generate bytecode from Core -module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where - -#include "HsVersions.h" - -import ByteCodeInstr -import ByteCodeAsm -import ByteCodeTypes - -import GHCi -import GHCi.FFI -import GHCi.RemoteTypes -import BasicTypes -import DynFlags -import Outputable -import Platform -import Name -import MkId -import Id -import ForeignCall -import HscTypes -import CoreUtils -import CoreSyn -import PprCore -import Literal -import PrimOp -import CoreFVs -import Type -import RepType -import Kind ( isLiftedTypeKind ) -import DataCon -import TyCon -import Util -import VarSet -import TysPrim -import ErrUtils -import Unique -import FastString -import Panic -import StgCmmLayout ( ArgRep(..), toArgRep, argRepSizeW ) -import SMRep -import Bitmap -import OrdList -import Maybes -import VarEnv - -import Data.List -import Foreign -import Control.Monad -import Data.Char - -import UniqSupply -import Module -import Control.Arrow ( second ) - -import Control.Exception -import Data.Array -import Data.ByteString (ByteString) -import Data.Map (Map) -import Data.IntMap (IntMap) -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified FiniteMap as Map -import Data.Ord -#if MIN_VERSION_base(4,9,0) -import GHC.Stack.CCS -#else -import GHC.Stack as GHC.Stack.CCS -#endif - --- ----------------------------------------------------------------------------- --- Generating byte code for a complete module - -byteCodeGen :: HscEnv - -> Module - -> CoreProgram - -> [TyCon] - -> Maybe ModBreaks - -> IO CompiledByteCode -byteCodeGen hsc_env this_mod binds tycs mb_modBreaks - = withTiming (pure dflags) - (text "ByteCodeGen"<+>brackets (ppr this_mod)) - (const ()) $ do - -- Split top-level binds into strings and others. - -- See Note [generating code for top-level string literal bindings]. - let (strings, flatBinds) = splitEithers $ do - (bndr, rhs) <- flattenBinds binds - return $ case rhs of - Lit (MachStr str) -> Left (bndr, str) - _ -> Right (bndr, simpleFreeVars rhs) - stringPtrs <- allocateTopStrings hsc_env strings - - us <- mkSplitUniqSupply 'y' - (BcM_State{..}, proto_bcos) <- - runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ - mapM schemeTopBind flatBinds - - when (notNull ffis) - (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") - - dumpIfSet_dyn dflags Opt_D_dump_BCOs - "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) - - cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs) - (case modBreaks of - Nothing -> Nothing - Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }) - - -- Squash space leaks in the CompiledByteCode. This is really - -- important, because when loading a set of modules into GHCi - -- we don't touch the CompiledByteCode until the end when we - -- do linking. Forcing out the thunks here reduces space - -- usage by more than 50% when loading a large number of - -- modules. - evaluate (seqCompiledByteCode cbc) - - return cbc - - where dflags = hsc_dflags hsc_env - -allocateTopStrings - :: HscEnv - -> [(Id, ByteString)] - -> IO [(Var, RemotePtr ())] -allocateTopStrings hsc_env topStrings = do - let !(bndrs, strings) = unzip topStrings - ptrs <- iservCmd hsc_env $ MallocStrings strings - return $ zip bndrs ptrs - -{- -Note [generating code for top-level string literal bindings] - -Here is a summary on how the byte code generator deals with top-level string -literals: - -1. Top-level string literal bindings are spearted from the rest of the module. - -2. The strings are allocated via iservCmd, in allocateTopStrings - -3. The mapping from binders to allocated strings (topStrings) are maintained in - BcM and used when generating code for variable references. --} - --- ----------------------------------------------------------------------------- --- Generating byte code for an expression - --- Returns: the root BCO for this expression -coreExprToBCOs :: HscEnv - -> Module - -> CoreExpr - -> IO UnlinkedBCO -coreExprToBCOs hsc_env this_mod expr - = withTiming (pure dflags) - (text "ByteCodeGen"<+>brackets (ppr this_mod)) - (const ()) $ do - -- create a totally bogus name for the top-level BCO; this - -- should be harmless, since it's never used for anything - let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel") - invented_id = Id.mkLocalId invented_name (panic "invented_id's type") - - -- the uniques are needed to generate fresh variables when we introduce new - -- let bindings for ticked expressions - us <- mkSplitUniqSupply 'y' - (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco) - <- runBc hsc_env us this_mod Nothing emptyVarEnv $ - schemeTopBind (invented_id, simpleFreeVars expr) - - when (notNull mallocd) - (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") - - dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco) - - assembleOneBCO hsc_env proto_bco - where dflags = hsc_dflags hsc_env - --- The regular freeVars function gives more information than is useful to --- us here. simpleFreeVars does the impedance matching. -simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet -simpleFreeVars = go . freeVars - where - go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet - go (ann, e) = (freeVarsOfAnn ann, go' e) - - go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet - go' (AnnVar id) = AnnVar id - go' (AnnLit lit) = AnnLit lit - go' (AnnLam bndr body) = AnnLam bndr (go body) - go' (AnnApp fun arg) = AnnApp (go fun) (go arg) - go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts) - go' (AnnLet bind body) = AnnLet (go_bind bind) (go body) - go' (AnnCast expr (ann, co)) = AnnCast (go expr) (freeVarsOfAnn ann, co) - go' (AnnTick tick body) = AnnTick tick (go body) - go' (AnnType ty) = AnnType ty - go' (AnnCoercion co) = AnnCoercion co - - go_alt (con, args, expr) = (con, args, go expr) - - go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs) - go_bind (AnnRec pairs) = AnnRec (map (second go) pairs) - --- ----------------------------------------------------------------------------- --- Compilation schema for the bytecode generator - -type BCInstrList = OrdList BCInstr - -type Sequel = Word -- back off to this depth before ENTER - --- Maps Ids to the offset from the stack _base_ so we don't have --- to mess with it after each push/pop. -type BCEnv = Map Id Word -- To find vars on the stack - -{- -ppBCEnv :: BCEnv -> SDoc -ppBCEnv p - = text "begin-env" - $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p)))) - $$ text "end-env" - where - pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var) - cmp_snd x y = compare (snd x) (snd y) --} - --- Create a BCO and do a spot of peephole optimisation on the insns --- at the same time. -mkProtoBCO - :: DynFlags - -> name - -> BCInstrList - -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet) - -> Int - -> Word16 - -> [StgWord] - -> Bool -- True <=> is a return point, rather than a function - -> [FFIInfo] - -> ProtoBCO name -mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis - = ProtoBCO { - protoBCOName = nm, - protoBCOInstrs = maybe_with_stack_check, - protoBCOBitmap = bitmap, - protoBCOBitmapSize = bitmap_size, - protoBCOArity = arity, - protoBCOExpr = origin, - protoBCOFFIs = ffis - } - where - -- Overestimate the stack usage (in words) of this BCO, - -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit - -- stack check. (The interpreter always does a stack check - -- for iNTERP_STACK_CHECK_THRESH words at the start of each - -- BCO anyway, so we only need to add an explicit one in the - -- (hopefully rare) cases when the (overestimated) stack use - -- exceeds iNTERP_STACK_CHECK_THRESH. - maybe_with_stack_check - | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d - -- don't do stack checks at return points, - -- everything is aggregated up to the top BCO - -- (which must be a function). - -- That is, unless the stack usage is >= AP_STACK_SPLIM, - -- see bug #1466. - | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH - = STKCHECK stack_usage : peep_d - | otherwise - = peep_d -- the supposedly common case - - -- We assume that this sum doesn't wrap - stack_usage = sum (map bciStackUse peep_d) - - -- Merge local pushes - peep_d = peep (fromOL instrs_ordlist) - - peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest) - = PUSH_LLL off1 (off2-1) (off3-2) : peep rest - peep (PUSH_L off1 : PUSH_L off2 : rest) - = PUSH_LL off1 (off2-1) : peep rest - peep (i:rest) - = i : peep rest - peep [] - = [] - -argBits :: DynFlags -> [ArgRep] -> [Bool] -argBits _ [] = [] -argBits dflags (rep : args) - | isFollowableArg rep = False : argBits dflags args - | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args - --- ----------------------------------------------------------------------------- --- schemeTopBind - --- Compile code for the right-hand side of a top-level binding - -schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name) - - -schemeTopBind (id, rhs) - | Just data_con <- isDataConWorkId_maybe id, - isNullaryRepDataCon data_con = do - dflags <- getDynFlags - -- Special case for the worker of a nullary data con. - -- It'll look like this: Nil = /\a -> Nil a - -- If we feed it into schemeR, we'll get - -- Nil = Nil - -- because mkConAppCode treats nullary constructor applications - -- by just re-using the single top-level definition. So - -- for the worker itself, we must allocate it directly. - -- ioToBc (putStrLn $ "top level BCO") - emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER]) - (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) - - | otherwise - = schemeR [{- No free variables -}] (id, rhs) - - --- ----------------------------------------------------------------------------- --- schemeR - --- Compile code for a right-hand side, to give a BCO that, --- when executed with the free variables and arguments on top of the stack, --- will return with a pointer to the result on top of the stack, after --- removing the free variables and arguments. --- --- Park the resulting BCO in the monad. Also requires the --- variable to which this value was bound, so as to give the --- resulting BCO a name. - -schemeR :: [Id] -- Free vars of the RHS, ordered as they - -- will appear in the thunk. Empty for - -- top-level things, which have no free vars. - -> (Id, AnnExpr Id DVarSet) - -> BcM (ProtoBCO Name) -schemeR fvs (nm, rhs) -{- - | trace (showSDoc ( - (char ' ' - $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs - $$ pprCoreExpr (deAnnotate rhs) - $$ char ' ' - ))) False - = undefined - | otherwise --} - = schemeR_wrk fvs nm rhs (collect rhs) - -collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet) -collect (_, e) = go [] e - where - go xs e | Just e' <- bcView e = go xs e' - go xs (AnnLam x (_,e)) - | typePrimRep (idType x) `lengthExceeds` 1 - = multiValException - | otherwise - = go (x:xs) e - go xs not_lambda = (reverse xs, not_lambda) - -schemeR_wrk :: [Id] -> Id -> AnnExpr Id DVarSet -> ([Var], AnnExpr' Var DVarSet) -> BcM (ProtoBCO Name) -schemeR_wrk fvs nm original_body (args, body) - = do - dflags <- getDynFlags - let - all_args = reverse args ++ fvs - arity = length all_args - -- all_args are the args in reverse order. We're compiling a function - -- \fv1..fvn x1..xn -> e - -- i.e. the fvs come first - - szsw_args = map (fromIntegral . idSizeW dflags) all_args - szw_args = sum szsw_args - p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args)) - - -- make the arg bitmap - bits = argBits dflags (reverse (map bcIdArgRep all_args)) - bitmap_size = genericLength bits - bitmap = mkBitmap dflags bits - body_code <- schemeER_wrk szw_args p_init body - - emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body) - arity bitmap_size bitmap False{-not alts-}) - --- introduce break instructions for ticked expressions -schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList -schemeER_wrk d p rhs - | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs - = do code <- schemeE (fromIntegral d) 0 p newRhs - cc_arr <- getCCArray - this_mod <- moduleName <$> getCurrentModule - let idOffSets = getVarOffSets d p fvs - let breakInfo = CgBreakInfo - { cgb_vars = idOffSets - , cgb_resty = exprType (deAnnotate' newRhs) - } - newBreakInfo tick_no breakInfo - dflags <- getDynFlags - let cc | interpreterProfiled dflags = cc_arr ! tick_no - | otherwise = toRemotePtr nullPtr - let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc - return $ breakInstr `consOL` code - | otherwise = schemeE (fromIntegral d) 0 p rhs - -getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)] -getVarOffSets d p = catMaybes . map (getOffSet d p) - -getOffSet :: Word -> BCEnv -> Id -> Maybe (Id, Word16) -getOffSet d env id - = case lookupBCEnv_maybe id env of - Nothing -> Nothing - Just offset -> Just (id, trunc16 $ d - offset) - -trunc16 :: Word -> Word16 -trunc16 w - | w > fromIntegral (maxBound :: Word16) - = panic "stack depth overflow" - | otherwise - = fromIntegral w - -fvsToEnv :: BCEnv -> DVarSet -> [Id] --- Takes the free variables of a right-hand side, and --- delivers an ordered list of the local variables that will --- be captured in the thunk for the RHS --- The BCEnv argument tells which variables are in the local --- environment: these are the ones that should be captured --- --- The code that constructs the thunk, and the code that executes --- it, have to agree about this layout -fvsToEnv p fvs = [v | v <- dVarSetElems fvs, - isId v, -- Could be a type variable - v `Map.member` p] - --- ----------------------------------------------------------------------------- --- schemeE - -returnUnboxedAtom :: Word -> Sequel -> BCEnv - -> AnnExpr' Id DVarSet -> ArgRep - -> BcM BCInstrList --- Returning an unlifted value. --- Heave it on the stack, SLIDE, and RETURN. -returnUnboxedAtom d s p e e_rep - = do (push, szw) <- pushAtom d p e - return (push -- value onto stack - `appOL` mkSLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN_UBX e_rep) -- go - --- Compile code to apply the given expression to the remaining args --- on the stack, returning a HNF. -schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList - -schemeE d s p e - | Just e' <- bcView e - = schemeE d s p e' - --- Delegate tail-calls to schemeT. -schemeE d s p e@(AnnApp _ _) = schemeT d s p e - -schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit)) -schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V - -schemeE d s p e@(AnnVar v) - | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v) - | otherwise = schemeT d s p e - -schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) - | (AnnVar v, args_r_to_l) <- splitApp rhs, - Just data_con <- isDataConWorkId_maybe v, - dataConRepArity data_con == length args_r_to_l - = do -- Special case for a non-recursive let whose RHS is a - -- saturated constructor application. - -- Just allocate the constructor and carry on - alloc_code <- mkConAppCode d s p data_con args_r_to_l - body_code <- schemeE (d+1) s (Map.insert x d p) body - return (alloc_code `appOL` body_code) - --- General case for let. Generates correct, if inefficient, code in --- all situations. -schemeE d s p (AnnLet binds (_,body)) = do - dflags <- getDynFlags - let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) - AnnRec xs_n_rhss -> unzip xs_n_rhss - n_binds = genericLength xs - - fvss = map (fvsToEnv p' . fst) rhss - - -- Sizes of free vars - sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss - - -- the arity of each rhs - arities = map (genericLength . fst . collect) rhss - - -- This p', d' defn is safe because all the items being pushed - -- are ptrs, so all have size 1. d' and p' reflect the stack - -- after the closures have been allocated in the heap (but not - -- filled in), and pointers to them parked on the stack. - p' = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p - d' = d + fromIntegral n_binds - zipE = zipEqual "schemeE" - - -- ToDo: don't build thunks for things with no free variables - build_thunk _ [] size bco off arity - = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size)) - where - mkap | arity == 0 = MKAP - | otherwise = MKPAP - build_thunk dd (fv:fvs) size bco off arity = do - (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) - more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity - return (push_code `appOL` more_push_code) - - alloc_code = toOL (zipWith mkAlloc sizes arities) - where mkAlloc sz 0 - | is_tick = ALLOC_AP_NOUPD sz - | otherwise = ALLOC_AP sz - mkAlloc sz arity = ALLOC_PAP arity sz - - is_tick = case binds of - AnnNonRec id _ -> occNameFS (getOccName id) == tickFS - _other -> False - - compile_bind d' fvs x rhs size arity off = do - bco <- schemeR fvs (x,rhs) - build_thunk d' fvs size bco off arity - - compile_binds = - [ compile_bind d' fvs x rhs size arity n - | (fvs, x, rhs, size, arity, n) <- - zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] - ] - body_code <- schemeE d' s p' body - thunk_codes <- sequence compile_binds - return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) - --- Introduce a let binding for a ticked case expression. This rule --- *should* only fire when the expression was not already let-bound --- (the code gen for let bindings should take care of that). Todo: we --- call exprFreeVars on a deAnnotated expression, this may not be the --- best way to calculate the free vars but it seemed like the least --- intrusive thing to do -schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs) - | isLiftedTypeKind (typeKind ty) - = do id <- newId ty - -- Todo: is emptyVarSet correct on the next line? - let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id) - schemeE d s p letExp - - | otherwise - = do -- If the result type is not definitely lifted, then we must generate - -- let f = \s . tick e - -- in f realWorld# - -- When we stop at the breakpoint, _result will have an unlifted - -- type and hence won't be bound in the environment, but the - -- breakpoint will otherwise work fine. - -- - -- NB (Trac #12007) this /also/ applies for if (ty :: TYPE r), where - -- r :: RuntimeRep is a variable. This can happen in the - -- continuations for a pattern-synonym matcher - -- match = /\(r::RuntimeRep) /\(a::TYPE r). - -- \(k :: Int -> a) \(v::T). - -- case v of MkV n -> k n - -- Here (k n) :: a :: Type r, so we don't know if it's lifted - -- or not; but that should be fine provided we add that void arg. - - id <- newId (mkFunTy realWorldStatePrimTy ty) - st <- newId realWorldStatePrimTy - let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp))) - (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id) - (emptyDVarSet, AnnVar realWorldPrimId))) - schemeE d s p letExp - - where - exp' = deAnnotate' exp - fvs = exprFreeVarsDSet exp' - ty = exprType exp' - --- ignore other kinds of tick -schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs - -schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut - -- no alts: scrut is guaranteed to diverge - -schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) - | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token) - -- Convert - -- case .... of x { (# V'd-thing, a #) -> ... } - -- to - -- case .... of a { DEFAULT -> ... } - -- because the return convention for both are identical. - -- - -- Note that it does not matter losing the void-rep thing from the - -- envt (it won't be bound now) because we never look such things up. - , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of - ([], [_]) - -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr) - ([_], []) - -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) - _ -> Nothing - = res - -schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) - | isUnboxedTupleCon dc - , length (typePrimRep (idType bndr)) <= 1 -- handles unit tuples - = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) - -schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)]) - | isUnboxedTupleType (idType bndr) - , Just ty <- case typePrimRep (idType bndr) of - [_] -> Just (unwrapType (idType bndr)) - [] -> Just voidPrimTy - _ -> Nothing - -- handles any pattern with a single non-void binder; in particular I/O - -- monad returns (# RealWorld#, a #) - = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr) - -schemeE d s p (AnnCase scrut bndr _ alts) - = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-} - -schemeE _ _ _ expr - = pprPanic "ByteCodeGen.schemeE: unhandled case" - (pprCoreExpr (deAnnotate' expr)) - -{- - Ticked Expressions - ------------------ - - The idea is that the "breakpoint E" is really just an annotation on - the code. When we find such a thing, we pull out the useful information, - and then compile the code as if it was just the expression E. - --} - --- Compile code to do a tail call. Specifically, push the fn, --- slide the on-stack app back down to the sequel depth, --- and enter. Four cases: --- --- 0. (Nasty hack). --- An application "GHC.Prim.tagToEnum# unboxed-int". --- The int will be on the stack. Generate a code sequence --- to convert it to the relevant constructor, SLIDE and ENTER. --- --- 1. The fn denotes a ccall. Defer to generateCCall. --- --- 2. (Another nasty hack). Spot (# a::V, b #) and treat --- it simply as b -- since the representations are identical --- (the V takes up zero stack space). Also, spot --- (# b #) and treat it as b. --- --- 3. Application of a constructor, by defn saturated. --- Split the args into ptrs and non-ptrs, and push the nonptrs, --- then the ptrs, and then do PACK and RETURN. --- --- 4. Otherwise, it must be a function call. Push the args --- right to left, SLIDE and ENTER. - -schemeT :: Word -- Stack depth - -> Sequel -- Sequel depth - -> BCEnv -- stack env - -> AnnExpr' Id DVarSet - -> BcM BCInstrList - -schemeT d s p app - --- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False --- = panic "schemeT ?!?!" - --- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False --- = error "?!?!" - - -- Case 0 - | Just (arg, constr_names) <- maybe_is_tagToEnum_call app - = implement_tagToId d s p arg constr_names - - -- Case 1 - | Just (CCall ccall_spec) <- isFCallId_maybe fn - = if isSupportedCConv ccall_spec - then generateCCall d s p ccall_spec fn args_r_to_l - else unsupportedCConvException - - - -- Case 2: Constructor application - | Just con <- maybe_saturated_dcon - , isUnboxedTupleCon con - = case args_r_to_l of - [arg1,arg2] | isVAtom arg1 -> - unboxedTupleReturn d s p arg2 - [arg1,arg2] | isVAtom arg2 -> - unboxedTupleReturn d s p arg1 - _other -> multiValException - - -- Case 3: Ordinary data constructor - | Just con <- maybe_saturated_dcon - = do alloc_con <- mkConAppCode d s p con args_r_to_l - return (alloc_con `appOL` - mkSLIDE 1 (d - s) `snocOL` - ENTER) - - -- Case 4: Tail call of function - | otherwise - = doTailCall d s p fn args_r_to_l - - where - -- Extract the args (R->L) and fn - -- The function will necessarily be a variable, - -- because we are compiling a tail call - (AnnVar fn, args_r_to_l) = splitApp app - - -- Only consider this to be a constructor application iff it is - -- saturated. Otherwise, we'll call the constructor wrapper. - n_args = length args_r_to_l - maybe_saturated_dcon - = case isDataConWorkId_maybe fn of - Just con | dataConRepArity con == n_args -> Just con - _ -> Nothing - --- ----------------------------------------------------------------------------- --- Generate code to build a constructor application, --- leaving it on top of the stack - -mkConAppCode :: Word -> Sequel -> BCEnv - -> DataCon -- The data constructor - -> [AnnExpr' Id DVarSet] -- Args, in *reverse* order - -> BcM BCInstrList - -mkConAppCode _ _ _ con [] -- Nullary constructor - = ASSERT( isNullaryRepDataCon con ) - return (unitOL (PUSH_G (getName (dataConWorkId con)))) - -- Instead of doing a PACK, which would allocate a fresh - -- copy of this constructor, use the single shared version. - -mkConAppCode orig_d _ p con args_r_to_l - = ASSERT( dataConRepArity con == length args_r_to_l ) - do_pushery orig_d (non_ptr_args ++ ptr_args) - where - -- The args are already in reverse order, which is the way PACK - -- expects them to be. We must push the non-ptrs after the ptrs. - (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l - - do_pushery d (arg:args) - = do (push, arg_words) <- pushAtom d p arg - more_push_code <- do_pushery (d + fromIntegral arg_words) args - return (push `appOL` more_push_code) - do_pushery d [] - = return (unitOL (PACK con n_arg_words)) - where - n_arg_words = trunc16 $ d - orig_d - - --- ----------------------------------------------------------------------------- --- Returning an unboxed tuple with one non-void component (the only --- case we can handle). --- --- Remember, we don't want to *evaluate* the component that is being --- returned, even if it is a pointed type. We always just return. - -unboxedTupleReturn - :: Word -> Sequel -> BCEnv - -> AnnExpr' Id DVarSet -> BcM BCInstrList -unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg) - --- ----------------------------------------------------------------------------- --- Generate code for a tail-call - -doTailCall - :: Word -> Sequel -> BCEnv - -> Id -> [AnnExpr' Id DVarSet] - -> BcM BCInstrList -doTailCall init_d s p fn args - = do_pushes init_d args (map atomRep args) - where - do_pushes d [] reps = do - ASSERT( null reps ) return () - (push_fn, sz) <- pushAtom d p (AnnVar fn) - ASSERT( sz == 1 ) return () - return (push_fn `appOL` ( - mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL` - unitOL ENTER)) - do_pushes d args reps = do - let (push_apply, n, rest_of_reps) = findPushSeq reps - (these_args, rest_of_args) = splitAt n args - (next_d, push_code) <- push_seq d these_args - instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps - -- ^^^ for the PUSH_APPLY_ instruction - return (push_code `appOL` (push_apply `consOL` instrs)) - - push_seq d [] = return (d, nilOL) - push_seq d (arg:args) = do - (push_code, sz) <- pushAtom d p arg - (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args - return (final_d, push_code `appOL` more_push_code) - --- v. similar to CgStackery.findMatch, ToDo: merge -findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep]) -findPushSeq (P: P: P: P: P: P: rest) - = (PUSH_APPLY_PPPPPP, 6, rest) -findPushSeq (P: P: P: P: P: rest) - = (PUSH_APPLY_PPPPP, 5, rest) -findPushSeq (P: P: P: P: rest) - = (PUSH_APPLY_PPPP, 4, rest) -findPushSeq (P: P: P: rest) - = (PUSH_APPLY_PPP, 3, rest) -findPushSeq (P: P: rest) - = (PUSH_APPLY_PP, 2, rest) -findPushSeq (P: rest) - = (PUSH_APPLY_P, 1, rest) -findPushSeq (V: rest) - = (PUSH_APPLY_V, 1, rest) -findPushSeq (N: rest) - = (PUSH_APPLY_N, 1, rest) -findPushSeq (F: rest) - = (PUSH_APPLY_F, 1, rest) -findPushSeq (D: rest) - = (PUSH_APPLY_D, 1, rest) -findPushSeq (L: rest) - = (PUSH_APPLY_L, 1, rest) -findPushSeq _ - = panic "ByteCodeGen.findPushSeq" - --- ----------------------------------------------------------------------------- --- Case expressions - -doCase :: Word -> Sequel -> BCEnv - -> AnnExpr Id DVarSet -> Id -> [AnnAlt Id DVarSet] - -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result - -> BcM BCInstrList -doCase d s p (_,scrut) bndr alts is_unboxed_tuple - | typePrimRep (idType bndr) `lengthExceeds` 1 - = multiValException - | otherwise - = do - dflags <- getDynFlags - let - profiling - | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags - | otherwise = rtsIsProfiled - - -- Top of stack is the return itbl, as usual. - -- underneath it is the pointer to the alt_code BCO. - -- When an alt is entered, it assumes the returned value is - -- on top of the itbl. - ret_frame_sizeW :: Word - ret_frame_sizeW = 2 - - -- The extra frame we push to save/restor the CCCS when profiling - save_ccs_sizeW | profiling = 2 - | otherwise = 0 - - -- An unlifted value gets an extra info table pushed on top - -- when it is returned. - unlifted_itbl_sizeW :: Word - unlifted_itbl_sizeW | isAlgCase = 0 - | otherwise = 1 - - -- depth of stack after the return value has been pushed - d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr) - - -- depth of stack after the extra info table for an unboxed return - -- has been pushed, if any. This is the stack depth at the - -- continuation. - d_alts = d_bndr + unlifted_itbl_sizeW - - -- Env in which to compile the alts, not including - -- any vars bound by the alts themselves - d_bndr' = fromIntegral d_bndr - 1 - p_alts0 = Map.insert bndr d_bndr' p - p_alts = case is_unboxed_tuple of - Just ubx_bndr -> Map.insert ubx_bndr d_bndr' p_alts0 - Nothing -> p_alts0 - - bndr_ty = idType bndr - isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple - - -- given an alt, return a discr and code for it. - codeAlt (DEFAULT, _, (_,rhs)) - = do rhs_code <- schemeE d_alts s p_alts rhs - return (NoDiscr, rhs_code) - - codeAlt alt@(_, bndrs, (_,rhs)) - -- primitive or nullary constructor alt: no need to UNPACK - | null real_bndrs = do - rhs_code <- schemeE d_alts s p_alts rhs - return (my_discr alt, rhs_code) - -- algebraic alt with some binders - | otherwise = - let - (ptrs,nptrs) = partition (isFollowableArg.bcIdArgRep) real_bndrs - ptr_sizes = map (fromIntegral . idSizeW dflags) ptrs - nptrs_sizes = map (fromIntegral . idSizeW dflags) nptrs - bind_sizes = ptr_sizes ++ nptrs_sizes - size = sum ptr_sizes + sum nptrs_sizes - -- the UNPACK instruction unpacks in reverse order... - p' = Map.insertList - (zip (reverse (ptrs ++ nptrs)) - (mkStackOffsets d_alts (reverse bind_sizes))) - p_alts - in do - MASSERT(isAlgCase) - rhs_code <- schemeE (d_alts + size) s p' rhs - return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code) - where - real_bndrs = filterOut isTyVar bndrs - - my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} - my_discr (DataAlt dc, _, _) - | isUnboxedTupleCon dc || isUnboxedSumCon dc - = multiValException - | otherwise - = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) - my_discr (LitAlt l, _, _) - = case l of MachInt i -> DiscrI (fromInteger i) - MachWord w -> DiscrW (fromInteger w) - MachFloat r -> DiscrF (fromRational r) - MachDouble r -> DiscrD (fromRational r) - MachChar i -> DiscrI (ord i) - _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) - - maybe_ncons - | not isAlgCase = Nothing - | otherwise - = case [dc | (DataAlt dc, _, _) <- alts] of - [] -> Nothing - (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) - - -- the bitmap is relative to stack depth d, i.e. before the - -- BCO, info table and return value are pushed on. - -- This bit of code is v. similar to buildLivenessMask in CgBindery, - -- except that here we build the bitmap from the known bindings of - -- things that are pointers, whereas in CgBindery the code builds the - -- bitmap from the free slots and unboxed bindings. - -- (ToDo: merge?) - -- - -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002. - -- The bitmap must cover the portion of the stack up to the sequel only. - -- Previously we were building a bitmap for the whole depth (d), but we - -- really want a bitmap up to depth (d-s). This affects compilation of - -- case-of-case expressions, which is the only time we can be compiling a - -- case expression with s /= 0. - bitmap_size = trunc16 $ d-s - bitmap_size' :: Int - bitmap_size' = fromIntegral bitmap_size - bitmap = intsToReverseBitmap dflags bitmap_size'{-size-} - (sort (filter (< bitmap_size') rel_slots)) - where - binds = Map.toList p - -- NB: unboxed tuple cases bind the scrut binder to the same offset - -- as one of the alt binders, so we have to remove any duplicates here: - rel_slots = nub $ map fromIntegral $ concat (map spread binds) - spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ] - | otherwise = [] - where rel_offset = trunc16 $ d - fromIntegral offset - 1 - - alt_stuff <- mapM codeAlt alts - alt_final <- mkMultiBranch maybe_ncons alt_stuff - - let - alt_bco_name = getName bndr - alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts) - 0{-no arity-} bitmap_size bitmap True{-is alts-} --- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ --- "\n bitmap = " ++ show bitmap) $ do - - scrut_code <- schemeE (d + ret_frame_sizeW + save_ccs_sizeW) - (d + ret_frame_sizeW + save_ccs_sizeW) - p scrut - alt_bco' <- emitBc alt_bco - let push_alts - | isAlgCase = PUSH_ALTS alt_bco' - | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty) - return (push_alts `consOL` scrut_code) - - --- ----------------------------------------------------------------------------- --- Deal with a CCall. - --- Taggedly push the args onto the stack R->L, --- deferencing ForeignObj#s and adjusting addrs to point to --- payloads in Ptr/Byte arrays. Then, generate the marshalling --- (machine) code for the ccall, and create bytecodes to call that and --- then return in the right way. - -generateCCall :: Word -> Sequel -- stack and sequel depths - -> BCEnv - -> CCallSpec -- where to call - -> Id -- of target, for type info - -> [AnnExpr' Id DVarSet] -- args (atoms) - -> BcM BCInstrList - -generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l - = do - dflags <- getDynFlags - - let - -- useful constants - addr_sizeW :: Word16 - addr_sizeW = fromIntegral (argRepSizeW dflags N) - - -- Get the args on the stack, with tags and suitably - -- dereferenced for the CCall. For each arg, return the - -- depth to the first word of the bits for that arg, and the - -- ArgRep of what was actually pushed. - - pargs _ [] = return [] - pargs d (a:az) - = let arg_ty = unwrapType (exprType (deAnnotate' a)) - - in case tyConAppTyCon_maybe arg_ty of - -- Don't push the FO; instead push the Addr# it - -- contains. - Just t - | t == arrayPrimTyCon || t == mutableArrayPrimTyCon - -> do rest <- pargs (d + fromIntegral addr_sizeW) az - code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a - return ((code,AddrRep):rest) - - | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon - -> do rest <- pargs (d + fromIntegral addr_sizeW) az - code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a - return ((code,AddrRep):rest) - - | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon - -> do rest <- pargs (d + fromIntegral addr_sizeW) az - code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a - return ((code,AddrRep):rest) - - -- Default case: push taggedly, but otherwise intact. - _ - -> do (code_a, sz_a) <- pushAtom d p a - rest <- pargs (d + fromIntegral sz_a) az - return ((code_a, atomPrimRep a) : rest) - - -- Do magic for Ptr/Byte arrays. Push a ptr to the array on - -- the stack but then advance it over the headers, so as to - -- point to the payload. - parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id DVarSet - -> BcM BCInstrList - parg_ArrayishRep hdrSize d p a - = do (push_fo, _) <- pushAtom d p a - -- The ptr points at the header. Advance it over the - -- header and then pretend this is an Addr#. - return (push_fo `snocOL` SWIZZLE 0 hdrSize) - - code_n_reps <- pargs d0 args_r_to_l - let - (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps - a_reps_sizeW = fromIntegral (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l)) - - push_args = concatOL pushs_arg - d_after_args = d0 + a_reps_sizeW - a_reps_pushed_RAW - | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep - = panic "ByteCodeGen.generateCCall: missing or invalid World token?" - | otherwise - = reverse (tail a_reps_pushed_r_to_l) - - -- Now: a_reps_pushed_RAW are the reps which are actually on the stack. - -- push_args is the code to do that. - -- d_after_args is the stack depth once the args are on. - - -- Get the result rep. - (returns_void, r_rep) - = case maybe_getCCallReturnRep (idType fn) of - Nothing -> (True, VoidRep) - Just rr -> (False, rr) - {- - Because the Haskell stack grows down, the a_reps refer to - lowest to highest addresses in that order. The args for the call - are on the stack. Now push an unboxed Addr# indicating - the C function to call. Then push a dummy placeholder for the - result. Finally, emit a CCALL insn with an offset pointing to the - Addr# just pushed, and a literal field holding the mallocville - address of the piece of marshalling code we generate. - So, just prior to the CCALL insn, the stack looks like this - (growing down, as usual): - - - ... - - Addr# address_of_C_fn - (must be an unboxed type) - - The interpreter then calls the marshall code mentioned - in the CCALL insn, passing it (& ), - that is, the addr of the topmost word in the stack. - When this returns, the placeholder will have been - filled in. The placeholder is slid down to the sequel - depth, and we RETURN. - - This arrangement makes it simple to do f-i-dynamic since the Addr# - value is the first arg anyway. - - The marshalling code is generated specifically for this - call site, and so knows exactly the (Haskell) stack - offsets of the args, fn address and placeholder. It - copies the args to the C stack, calls the stacked addr, - and parks the result back in the placeholder. The interpreter - calls it as a normal C call, assuming it has a signature - void marshall_code ( StgWord* ptr_to_top_of_stack ) - -} - -- resolve static address - maybe_static_target = - case target of - DynamicTarget -> Nothing - StaticTarget _ _ _ False -> - panic "generateCCall: unexpected FFI value import" - StaticTarget _ target _ True -> - Just (MachLabel target mb_size IsFunction) - where - mb_size - | OSMinGW32 <- platformOS (targetPlatform dflags) - , StdCallConv <- cconv - = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags) - | otherwise - = Nothing - - let - is_static = isJust maybe_static_target - - -- Get the arg reps, zapping the leading Addr# in the dynamic case - a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" - | is_static = a_reps_pushed_RAW - | otherwise = if null a_reps_pushed_RAW - then panic "ByteCodeGen.generateCCall: dyn with no args" - else tail a_reps_pushed_RAW - - -- push the Addr# - (push_Addr, d_after_Addr) - | Just machlabel <- maybe_static_target - = (toOL [PUSH_UBX machlabel addr_sizeW], - d_after_args + fromIntegral addr_sizeW) - | otherwise -- is already on the stack - = (nilOL, d_after_args) - - -- Push the return placeholder. For a call returning nothing, - -- this is a V (tag). - r_sizeW = fromIntegral (primRepSizeW dflags r_rep) - d_after_r = d_after_Addr + fromIntegral r_sizeW - push_r = (if returns_void - then nilOL - else unitOL (PUSH_UBX (mkDummyLiteral r_rep) r_sizeW)) - - -- generate the marshalling code we're going to call - - -- Offset of the next stack frame down the stack. The CCALL - -- instruction needs to describe the chunk of stack containing - -- the ccall args to the GC, so it needs to know how large it - -- is. See comment in Interpreter.c with the CCALL instruction. - stk_offset = trunc16 $ d_after_r - s - - conv = case cconv of - CCallConv -> FFICCall - StdCallConv -> FFIStdCall - _ -> panic "ByteCodeGen: unexpected calling convention" - - -- the only difference in libffi mode is that we prepare a cif - -- describing the call type by calling libffi, and we attach the - -- address of this to the CCALL instruction. - - - let ffires = primRepToFFIType dflags r_rep - ffiargs = map (primRepToFFIType dflags) a_reps - hsc_env <- getHscEnv - token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires) - recordFFIBc token - - let - -- do the call - do_call = unitOL (CCALL stk_offset token - (fromIntegral (fromEnum (playInterruptible safety)))) - -- slide and return - wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s) - `snocOL` RETURN_UBX (toArgRep r_rep) - --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ - return ( - push_args `appOL` - push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup - ) - -primRepToFFIType :: DynFlags -> PrimRep -> FFIType -primRepToFFIType dflags r - = case r of - VoidRep -> FFIVoid - IntRep -> signed_word - WordRep -> unsigned_word - Int64Rep -> FFISInt64 - Word64Rep -> FFIUInt64 - AddrRep -> FFIPointer - FloatRep -> FFIFloat - DoubleRep -> FFIDouble - _ -> panic "primRepToFFIType" - where - (signed_word, unsigned_word) - | wORD_SIZE dflags == 4 = (FFISInt32, FFIUInt32) - | wORD_SIZE dflags == 8 = (FFISInt64, FFIUInt64) - | otherwise = panic "primTyDescChar" - --- Make a dummy literal, to be used as a placeholder for FFI return --- values on the stack. -mkDummyLiteral :: PrimRep -> Literal -mkDummyLiteral pr - = case pr of - IntRep -> MachInt 0 - WordRep -> MachWord 0 - AddrRep -> MachNullAddr - DoubleRep -> MachDouble 0 - FloatRep -> MachFloat 0 - Int64Rep -> MachInt64 0 - Word64Rep -> MachWord64 0 - _ -> pprPanic "mkDummyLiteral" (ppr pr) - - --- Convert (eg) --- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld --- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) --- --- to Just IntRep --- and check that an unboxed pair is returned wherein the first arg is V'd. --- --- Alternatively, for call-targets returning nothing, convert --- --- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld --- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) --- --- to Nothing - -maybe_getCCallReturnRep :: Type -> Maybe PrimRep -maybe_getCCallReturnRep fn_ty - = let - (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - r_reps = typePrimRepArgs r_ty - - blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" - (pprType fn_ty) - in - case r_reps of - [] -> panic "empty typePrimRepArgs" - [VoidRep] -> Nothing - [rep] - | isGcPtrRep rep -> blargh - | otherwise -> Just rep - - -- if it was, it would be impossible to create a - -- valid return value placeholder on the stack - _ -> blargh - -maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name]) --- Detect and extract relevant info for the tagToEnum kludge. -maybe_is_tagToEnum_call app - | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app - , Just TagToEnumOp <- isPrimOpId_maybe v - = Just (snd arg, extract_constr_Names t) - | otherwise - = Nothing - where - extract_constr_Names ty - | rep_ty <- unwrapType ty - , Just tyc <- tyConAppTyCon_maybe rep_ty - , isDataTyCon tyc - = map (getName . dataConWorkId) (tyConDataCons tyc) - -- NOTE: use the worker name, not the source name of - -- the DataCon. See DataCon.hs for details. - | otherwise - = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) - -{- ----------------------------------------------------------------------------- -Note [Implementing tagToEnum#] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(implement_tagToId arg names) compiles code which takes an argument -'arg', (call it i), and enters the i'th closure in the supplied list -as a consequence. The [Name] is a list of the constructors of this -(enumeration) type. - -The code we generate is this: - push arg - push bogus-word - - TESTEQ_I 0 L1 - PUSH_G - JMP L_Exit - - L1: TESTEQ_I 1 L2 - PUSH_G - JMP L_Exit - ...etc... - Ln: TESTEQ_I n L_fail - PUSH_G - JMP L_Exit - - L_fail: CASEFAIL - - L_exit: SLIDE 1 n - ENTER - -The 'bogus-word' push is because TESTEQ_I expects the top of the stack -to have an info-table, and the next word to have the value to be -tested. This is very weird, but it's the way it is right now. See -Interpreter.c. We don't acutally need an info-table here; we just -need to have the argument to be one-from-top on the stack, hence pushing -a 1-word null. See Trac #8383. --} - - -implement_tagToId :: Word -> Sequel -> BCEnv - -> AnnExpr' Id DVarSet -> [Name] -> BcM BCInstrList --- See Note [Implementing tagToEnum#] -implement_tagToId d s p arg names - = ASSERT( notNull names ) - do (push_arg, arg_words) <- pushAtom d p arg - labels <- getLabelsBc (genericLength names) - label_fail <- getLabelBc - label_exit <- getLabelBc - let infos = zip4 labels (tail labels ++ [label_fail]) - [0 ..] names - steps = map (mkStep label_exit) infos - - return (push_arg - `appOL` unitOL (PUSH_UBX MachNullAddr 1) - -- Push bogus word (see Note [Implementing tagToEnum#]) - `appOL` concatOL steps - `appOL` toOL [ LABEL label_fail, CASEFAIL, - LABEL label_exit ] - `appOL` mkSLIDE 1 (d - s + fromIntegral arg_words + 1) - -- "+1" to account for bogus word - -- (see Note [Implementing tagToEnum#]) - `appOL` unitOL ENTER) - where - mkStep l_exit (my_label, next_label, n, name_for_n) - = toOL [LABEL my_label, - TESTEQ_I n next_label, - PUSH_G name_for_n, - JMP l_exit] - - --- ----------------------------------------------------------------------------- --- pushAtom - --- Push an atom onto the stack, returning suitable code & number of --- stack words used. --- --- The env p must map each variable to the highest- numbered stack --- slot for it. For example, if the stack has depth 4 and we --- tagged-ly push (v :: Int#) on it, the value will be in stack[4], --- the tag in stack[5], the stack will have depth 6, and p must map v --- to 5 and not to 4. Stack locations are numbered from zero, so a --- depth 6 stack has valid words 0 .. 5. - -pushAtom :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, Word16) - -pushAtom d p e - | Just e' <- bcView e - = pushAtom d p e' - -pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, - = return (nilOL, 0) -- treated just like a variable V - --- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs --- and Note [Bottoming expressions] in coreSyn/CoreUtils.hs: --- The scrutinee of an empty case evaluates to bottom -pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128 - = pushAtom d p a - -pushAtom d p (AnnVar v) - | [] <- typePrimRep (idType v) - = return (nilOL, 0) - - | isFCallId v - = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v) - - | Just primop <- isPrimOpId_maybe v - = return (unitOL (PUSH_PRIMOP primop), 1) - - | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable - = do dflags <- getDynFlags - let sz :: Word16 - sz = fromIntegral (idSizeW dflags v) - l = trunc16 $ d - d_v + fromIntegral sz - 2 - return (toOL (genericReplicate sz (PUSH_L l)), sz) - -- d - d_v the number of words between the TOS - -- and the 1st slot of the object - -- - -- d - d_v - 1 the offset from the TOS of the 1st slot - -- - -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot - -- of the object. - -- - -- Having found the last slot, we proceed to copy the right number of - -- slots on to the top of the stack. - - | otherwise -- v must be a global variable - = do topStrings <- getTopStrings - case lookupVarEnv topStrings v of - Just ptr -> pushAtom d p $ AnnLit $ MachWord $ fromIntegral $ - ptrToWordPtr $ fromRemotePtr ptr - Nothing -> do - dflags <- getDynFlags - let sz :: Word16 - sz = fromIntegral (idSizeW dflags v) - MASSERT(sz == 1) - return (unitOL (PUSH_G (getName v)), sz) - - -pushAtom _ _ (AnnLit lit) = do - dflags <- getDynFlags - let code rep - = let size_host_words = fromIntegral (argRepSizeW dflags rep) - in return (unitOL (PUSH_UBX lit size_host_words), - size_host_words) - - case lit of - MachLabel _ _ _ -> code N - MachWord _ -> code N - MachInt _ -> code N - MachWord64 _ -> code L - MachInt64 _ -> code L - MachFloat _ -> code F - MachDouble _ -> code D - MachChar _ -> code N - MachNullAddr -> code N - MachStr _ -> code N - -- No LitInteger's should be left by the time this is called. - -- CorePrep should have converted them all to a real core - -- representation. - LitInteger {} -> panic "pushAtom: LitInteger" - -pushAtom _ _ expr - = pprPanic "ByteCodeGen.pushAtom" - (pprCoreExpr (deAnnotate' expr)) - - --- ----------------------------------------------------------------------------- --- Given a bunch of alts code and their discrs, do the donkey work --- of making a multiway branch using a switch tree. --- What a load of hassle! - -mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt - -- a hint; generates better code - -- Nothing is always safe - -> [(Discr, BCInstrList)] - -> BcM BCInstrList -mkMultiBranch maybe_ncons raw_ways = do - lbl_default <- getLabelBc - - let - mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList - mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default)) - -- shouldn't happen? - - mkTree [val] range_lo range_hi - | range_lo == range_hi - = return (snd val) - | null defaults -- Note [CASEFAIL] - = do lbl <- getLabelBc - return (testEQ (fst val) lbl - `consOL` (snd val - `appOL` (LABEL lbl `consOL` unitOL CASEFAIL))) - | otherwise - = return (testEQ (fst val) lbl_default `consOL` snd val) - - -- Note [CASEFAIL] It may be that this case has no default - -- branch, but the alternatives are not exhaustive - this - -- happens for GADT cases for example, where the types - -- prove that certain branches are impossible. We could - -- just assume that the other cases won't occur, but if - -- this assumption was wrong (because of a bug in GHC) - -- then the result would be a segfault. So instead we - -- emit an explicit test and a CASEFAIL instruction that - -- causes the interpreter to barf() if it is ever - -- executed. - - mkTree vals range_lo range_hi - = let n = length vals `div` 2 - vals_lo = take n vals - vals_hi = drop n vals - v_mid = fst (head vals_hi) - in do - label_geq <- getLabelBc - code_lo <- mkTree vals_lo range_lo (dec v_mid) - code_hi <- mkTree vals_hi v_mid range_hi - return (testLT v_mid label_geq - `consOL` (code_lo - `appOL` unitOL (LABEL label_geq) - `appOL` code_hi)) - - the_default - = case defaults of - [] -> nilOL - [(_, def)] -> LABEL lbl_default `consOL` def - _ -> panic "mkMultiBranch/the_default" - instrs <- mkTree notd_ways init_lo init_hi - return (instrs `appOL` the_default) - where - (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways - notd_ways = sortBy (comparing fst) not_defaults - - testLT (DiscrI i) fail_label = TESTLT_I i fail_label - testLT (DiscrW i) fail_label = TESTLT_W i fail_label - testLT (DiscrF i) fail_label = TESTLT_F i fail_label - testLT (DiscrD i) fail_label = TESTLT_D i fail_label - testLT (DiscrP i) fail_label = TESTLT_P i fail_label - testLT NoDiscr _ = panic "mkMultiBranch NoDiscr" - - testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label - testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label - testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label - testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label - testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label - testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr" - - -- None of these will be needed if there are no non-default alts - (init_lo, init_hi) - | null notd_ways - = panic "mkMultiBranch: awesome foursome" - | otherwise - = case fst (head notd_ways) of - DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) - DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) - DiscrF _ -> ( DiscrF minF, DiscrF maxF ) - DiscrD _ -> ( DiscrD minD, DiscrD maxD ) - DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) - NoDiscr -> panic "mkMultiBranch NoDiscr" - - (algMinBound, algMaxBound) - = case maybe_ncons of - -- XXX What happens when n == 0? - Just n -> (0, fromIntegral n - 1) - Nothing -> (minBound, maxBound) - - isNoDiscr NoDiscr = True - isNoDiscr _ = False - - dec (DiscrI i) = DiscrI (i-1) - dec (DiscrW w) = DiscrW (w-1) - dec (DiscrP i) = DiscrP (i-1) - dec other = other -- not really right, but if you - -- do cases on floating values, you'll get what you deserve - - -- same snotty comment applies to the following - minF, maxF :: Float - minD, maxD :: Double - minF = -1.0e37 - maxF = 1.0e37 - minD = -1.0e308 - maxD = 1.0e308 - - --- ----------------------------------------------------------------------------- --- Supporting junk for the compilation schemes - --- Describes case alts -data Discr - = DiscrI Int - | DiscrW Word - | DiscrF Float - | DiscrD Double - | DiscrP Word16 - | NoDiscr - deriving (Eq, Ord) - -instance Outputable Discr where - ppr (DiscrI i) = int i - ppr (DiscrW w) = text (show w) - ppr (DiscrF f) = text (show f) - ppr (DiscrD d) = text (show d) - ppr (DiscrP i) = ppr i - ppr NoDiscr = text "DEF" - - -lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word -lookupBCEnv_maybe = Map.lookup - -idSizeW :: DynFlags -> Id -> Int -idSizeW dflags = argRepSizeW dflags . bcIdArgRep - -bcIdArgRep :: Id -> ArgRep -bcIdArgRep = toArgRep . bcIdPrimRep - -bcIdPrimRep :: Id -> PrimRep -bcIdPrimRep id - | [rep] <- typePrimRepArgs (idType id) - = rep - | otherwise - = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) - -isFollowableArg :: ArgRep -> Bool -isFollowableArg P = True -isFollowableArg _ = False - -isVoidArg :: ArgRep -> Bool -isVoidArg V = True -isVoidArg _ = False - --- See bug #1257 -multiValException :: a -multiValException = throwGhcException (ProgramError - ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++ - " Possibly due to foreign import/export decls in source.\n"++ - " Workaround: use -fobject-code, or compile this module to .o separately.")) - --- | Indicate if the calling convention is supported -isSupportedCConv :: CCallSpec -> Bool -isSupportedCConv (CCallSpec _ cconv _) = case cconv of - CCallConv -> True -- we explicitly pattern match on every - StdCallConv -> True -- convention to ensure that a warning - PrimCallConv -> False -- is triggered when a new one is added - JavaScriptCallConv -> False - CApiConv -> False - --- See bug #10462 -unsupportedCConvException :: a -unsupportedCConvException = throwGhcException (ProgramError - ("Error: bytecode compiler can't handle some foreign calling conventions\n"++ - " Workaround: use -fobject-code, or compile this module to .o separately.")) - -mkSLIDE :: Word16 -> Word -> OrdList BCInstr -mkSLIDE n d - -- if the amount to slide doesn't fit in a word, - -- generate multiple slide instructions - | d > fromIntegral limit - = SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit) - | d == 0 - = nilOL - | otherwise - = if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d) - where - limit :: Word16 - limit = maxBound - -splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann]) - -- The arguments are returned in *right-to-left* order -splitApp e | Just e' <- bcView e = splitApp e' -splitApp (AnnApp (_,f) (_,a)) = case splitApp f of - (f', as) -> (f', a:as) -splitApp e = (e, []) - - -bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) --- The "bytecode view" of a term discards --- a) type abstractions --- b) type applications --- c) casts --- d) ticks (but not breakpoints) --- Type lambdas *can* occur in random expressions, --- whereas value lambdas cannot; that is why they are nuked here -bcView (AnnCast (_,e) _) = Just e -bcView (AnnLam v (_,e)) | isTyVar v = Just e -bcView (AnnApp (_,e) (_, AnnType _)) = Just e -bcView (AnnTick Breakpoint{} _) = Nothing -bcView (AnnTick _other_tick (_,e)) = Just e -bcView _ = Nothing - -isVAtom :: AnnExpr' Var ann -> Bool -isVAtom e | Just e' <- bcView e = isVAtom e' -isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v) -isVAtom (AnnCoercion {}) = True -isVAtom _ = False - -atomPrimRep :: AnnExpr' Id ann -> PrimRep -atomPrimRep e | Just e' <- bcView e = atomPrimRep e' -atomPrimRep (AnnVar v) = bcIdPrimRep v -atomPrimRep (AnnLit l) = typePrimRep1 (literalType l) - --- Trac #12128: --- A case expression can be an atom because empty cases evaluate to bottom. --- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs -atomPrimRep (AnnCase _ _ ty _) = ASSERT(typePrimRep ty == [LiftedRep]) LiftedRep -atomPrimRep (AnnCoercion {}) = VoidRep -atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other)) - -atomRep :: AnnExpr' Id ann -> ArgRep -atomRep e = toArgRep (atomPrimRep e) - -isPtrAtom :: AnnExpr' Id ann -> Bool -isPtrAtom e = isFollowableArg (atomRep e) - --- Let szsw be the sizes in words of some items pushed onto the stack, --- which has initial depth d'. Return the values which the stack environment --- should map these items to. -mkStackOffsets :: Word -> [Word] -> [Word] -mkStackOffsets original_depth szsw - = map (subtract 1) (tail (scanl (+) original_depth szsw)) - -typeArgRep :: Type -> ArgRep -typeArgRep = toArgRep . typePrimRep1 - --- ----------------------------------------------------------------------------- --- The bytecode generator's monad - -data BcM_State - = BcM_State - { bcm_hsc_env :: HscEnv - , uniqSupply :: UniqSupply -- for generating fresh variable names - , thisModule :: Module -- current module (for breakpoints) - , nextlabel :: Word16 -- for generating local labels - , ffis :: [FFIInfo] -- ffi info blocks, to free later - -- Should be free()d when it is GCd - , modBreaks :: Maybe ModBreaks -- info about breakpoints - , breakInfo :: IntMap CgBreakInfo - , topStrings :: IdEnv (RemotePtr ()) -- top-level string literals - -- See Note [generating code for top-level string literal bindings]. - } - -newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) - -ioToBc :: IO a -> BcM a -ioToBc io = BcM $ \st -> do - x <- io - return (st, x) - -runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks - -> IdEnv (RemotePtr ()) - -> BcM r - -> IO (BcM_State, r) -runBc hsc_env us this_mod modBreaks topStrings (BcM m) - = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings) - -thenBc :: BcM a -> (a -> BcM b) -> BcM b -thenBc (BcM expr) cont = BcM $ \st0 -> do - (st1, q) <- expr st0 - let BcM k = cont q - (st2, r) <- k st1 - return (st2, r) - -thenBc_ :: BcM a -> BcM b -> BcM b -thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do - (st1, _) <- expr st0 - (st2, r) <- cont st1 - return (st2, r) - -returnBc :: a -> BcM a -returnBc result = BcM $ \st -> (return (st, result)) - -instance Functor BcM where - fmap = liftM - -instance Applicative BcM where - pure = returnBc - (<*>) = ap - (*>) = thenBc_ - -instance Monad BcM where - (>>=) = thenBc - (>>) = (*>) - -instance HasDynFlags BcM where - getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st)) - -getHscEnv :: BcM HscEnv -getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) - -emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) -emitBc bco - = BcM $ \st -> return (st{ffis=[]}, bco (ffis st)) - -recordFFIBc :: RemotePtr C_ffi_cif -> BcM () -recordFFIBc a - = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ()) - -getLabelBc :: BcM Word16 -getLabelBc - = BcM $ \st -> do let nl = nextlabel st - when (nl == maxBound) $ - panic "getLabelBc: Ran out of labels" - return (st{nextlabel = nl + 1}, nl) - -getLabelsBc :: Word16 -> BcM [Word16] -getLabelsBc n - = BcM $ \st -> let ctr = nextlabel st - in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) - -getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre)) -getCCArray = BcM $ \st -> - let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in - return (st, modBreaks_ccs breaks) - - -newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM () -newBreakInfo ix info = BcM $ \st -> - return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()) - -newUnique :: BcM Unique -newUnique = BcM $ - \st -> case takeUniqFromSupply (uniqSupply st) of - (uniq, us) -> let newState = st { uniqSupply = us } - in return (newState, uniq) - -getCurrentModule :: BcM Module -getCurrentModule = BcM $ \st -> return (st, thisModule st) - -getTopStrings :: BcM (IdEnv (RemotePtr ())) -getTopStrings = BcM $ \st -> return (st, topStrings st) - -newId :: Type -> BcM Id -newId ty = do - uniq <- newUnique - return $ mkSysLocal tickFS uniq ty - -tickFS :: FastString -tickFS = fsLit "ticked" diff --git a/ghci/ByteCodeInstr.hs b/ghci/ByteCodeInstr.hs deleted file mode 100644 --- a/ghci/ByteCodeInstr.hs +++ /dev/null @@ -1,315 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeInstrs: Bytecode instruction definitions -module ByteCodeInstr ( - BCInstr(..), ProtoBCO(..), bciStackUse, - ) where - -#include "HsVersions.h" -#include "MachDeps.h" - -import ByteCodeTypes -import GHCi.RemoteTypes -import GHCi.FFI (C_ffi_cif) -import StgCmmLayout ( ArgRep(..) ) -import PprCore -import Outputable -import FastString -import Name -import Unique -import Id -import CoreSyn -import Literal -import DataCon -import VarSet -import PrimOp -import SMRep - -import Data.Word -#if MIN_VERSION_base(4,9,0) -import GHC.Stack.CCS (CostCentre) -#else -import GHC.Stack (CostCentre) -#endif - --- ---------------------------------------------------------------------------- --- Bytecode instructions - -data ProtoBCO a - = ProtoBCO { - protoBCOName :: a, -- name, in some sense - protoBCOInstrs :: [BCInstr], -- instrs - -- arity and GC info - protoBCOBitmap :: [StgWord], - protoBCOBitmapSize :: Word16, - protoBCOArity :: Int, - -- what the BCO came from - protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet), - -- malloc'd pointers - protoBCOFFIs :: [FFIInfo] - } - -type LocalLabel = Word16 - -data BCInstr - -- Messing with the stack - = STKCHECK Word - - -- Push locals (existing bits of the stack) - | PUSH_L !Word16{-offset-} - | PUSH_LL !Word16 !Word16{-2 offsets-} - | PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-} - - -- Push a ptr (these all map to PUSH_G really) - | PUSH_G Name - | PUSH_PRIMOP PrimOp - | PUSH_BCO (ProtoBCO Name) - - -- Push an alt continuation - | PUSH_ALTS (ProtoBCO Name) - | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep - - -- Pushing literals - | PUSH_UBX Literal Word16 - -- push this int/float/double/addr, on the stack. Word16 - -- is # of words to copy from literal pool. Eitherness reflects - -- the difficulty of dealing with MachAddr here, mostly due to - -- the excessive (and unnecessary) restrictions imposed by the - -- designers of the new Foreign library. In particular it is - -- quite impossible to convert an Addr to any other integral - -- type, and it appears impossible to get hold of the bits of - -- an addr, even though we need to assemble BCOs. - - -- various kinds of application - | PUSH_APPLY_N - | PUSH_APPLY_V - | PUSH_APPLY_F - | PUSH_APPLY_D - | PUSH_APPLY_L - | PUSH_APPLY_P - | PUSH_APPLY_PP - | PUSH_APPLY_PPP - | PUSH_APPLY_PPPP - | PUSH_APPLY_PPPPP - | PUSH_APPLY_PPPPPP - - | SLIDE Word16{-this many-} Word16{-down by this much-} - - -- To do with the heap - | ALLOC_AP !Word16 -- make an AP with this many payload words - | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words - | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words - | MKAP !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-} - | MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-} - | UNPACK !Word16 -- unpack N words from t.o.s Constr - | PACK DataCon !Word16 - -- after assembly, the DataCon is an index into the - -- itbl array - -- For doing case trees - | LABEL LocalLabel - | TESTLT_I Int LocalLabel - | TESTEQ_I Int LocalLabel - | TESTLT_W Word LocalLabel - | TESTEQ_W Word LocalLabel - | TESTLT_F Float LocalLabel - | TESTEQ_F Float LocalLabel - | TESTLT_D Double LocalLabel - | TESTEQ_D Double LocalLabel - - -- The Word16 value is a constructor number and therefore - -- stored in the insn stream rather than as an offset into - -- the literal pool. - | TESTLT_P Word16 LocalLabel - | TESTEQ_P Word16 LocalLabel - - | CASEFAIL - | JMP LocalLabel - - -- For doing calls to C (via glue code generated by libffi) - | CCALL Word16 -- stack frame size - (RemotePtr C_ffi_cif) -- addr of the glue code - Word16 -- whether or not the call is interruptible - -- (XXX: inefficient, but I don't know - -- what the alignment constraints are.) - - -- For doing magic ByteArray passing to foreign calls - | SWIZZLE Word16 -- to the ptr N words down the stack, - Word16 -- add M (interpreted as a signed 16-bit entity) - - -- To Infinity And Beyond - | ENTER - | RETURN -- return a lifted value - | RETURN_UBX ArgRep -- return an unlifted value, here's its rep - - -- Breakpoints - | BRK_FUN Word16 Unique (RemotePtr CostCentre) - --- ----------------------------------------------------------------------------- --- Printing bytecode instructions - -instance Outputable a => Outputable (ProtoBCO a) where - ppr (ProtoBCO name instrs bitmap bsize arity origin ffis) - = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity - <+> text (show ffis) <> colon) - $$ nest 3 (case origin of - Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) - (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}' - Right rhs -> pprCoreExprShort (deAnnotate rhs)) - $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap) - $$ nest 3 (vcat (map ppr instrs)) - --- Print enough of the Core expression to enable the reader to find --- the expression in the -ddump-prep output. That is, we need to --- include at least a binder. - -pprCoreExprShort :: CoreExpr -> SDoc -pprCoreExprShort expr@(Lam _ _) - = let - (bndrs, _) = collectBinders expr - in - char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..." - -pprCoreExprShort (Case _expr var _ty _alts) - = text "case of" <+> ppr var - -pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ...")) -pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ...")) - -pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e -pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T" - -pprCoreExprShort e = pprCoreExpr e - -pprCoreAltShort :: CoreAlt -> SDoc -pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr - -instance Outputable BCInstr where - ppr (STKCHECK n) = text "STKCHECK" <+> ppr n - ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset - ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2 - ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3 - ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm - ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." - <> ppr op - ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) - ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco) - ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco) - - ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit - ppr PUSH_APPLY_N = text "PUSH_APPLY_N" - ppr PUSH_APPLY_V = text "PUSH_APPLY_V" - ppr PUSH_APPLY_F = text "PUSH_APPLY_F" - ppr PUSH_APPLY_D = text "PUSH_APPLY_D" - ppr PUSH_APPLY_L = text "PUSH_APPLY_L" - ppr PUSH_APPLY_P = text "PUSH_APPLY_P" - ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" - ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" - ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" - ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" - ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" - - ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d - ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz - ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz - ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz - ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words," - <+> ppr offset <+> text "stkoff" - ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words," - <+> ppr offset <+> text "stkoff" - ppr (UNPACK sz) = text "UNPACK " <+> ppr sz - ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz - ppr (LABEL lab) = text "__" <> ppr lab <> colon - ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab - ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab - ppr (TESTLT_W i lab) = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab - ppr (TESTEQ_W i lab) = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab - ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab - ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab - ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab - ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab - ppr (TESTLT_P i lab) = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab - ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab - ppr CASEFAIL = text "CASEFAIL" - ppr (JMP lab) = text "JMP" <+> ppr lab - ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off - <+> text "marshall code at" - <+> text (show marshall_addr) - <+> (if int == 1 - then text "(interruptible)" - else empty) - ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff - <+> text "by" <+> ppr n - ppr ENTER = text "ENTER" - ppr RETURN = text "RETURN" - ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk - ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "" - --- ----------------------------------------------------------------------------- --- The stack use, in words, of each bytecode insn. These _must_ be --- correct, or overestimates of reality, to be safe. - --- NOTE: we aggregate the stack use from case alternatives too, so that --- we can do a single stack check at the beginning of a function only. - --- This could all be made more accurate by keeping track of a proper --- stack high water mark, but it doesn't seem worth the hassle. - -protoBCOStackUse :: ProtoBCO a -> Word -protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco)) - -bciStackUse :: BCInstr -> Word -bciStackUse STKCHECK{} = 0 -bciStackUse PUSH_L{} = 1 -bciStackUse PUSH_LL{} = 2 -bciStackUse PUSH_LLL{} = 3 -bciStackUse PUSH_G{} = 1 -bciStackUse PUSH_PRIMOP{} = 1 -bciStackUse PUSH_BCO{} = 1 -bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco -bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco -bciStackUse (PUSH_UBX _ nw) = fromIntegral nw -bciStackUse PUSH_APPLY_N{} = 1 -bciStackUse PUSH_APPLY_V{} = 1 -bciStackUse PUSH_APPLY_F{} = 1 -bciStackUse PUSH_APPLY_D{} = 1 -bciStackUse PUSH_APPLY_L{} = 1 -bciStackUse PUSH_APPLY_P{} = 1 -bciStackUse PUSH_APPLY_PP{} = 1 -bciStackUse PUSH_APPLY_PPP{} = 1 -bciStackUse PUSH_APPLY_PPPP{} = 1 -bciStackUse PUSH_APPLY_PPPPP{} = 1 -bciStackUse PUSH_APPLY_PPPPPP{} = 1 -bciStackUse ALLOC_AP{} = 1 -bciStackUse ALLOC_AP_NOUPD{} = 1 -bciStackUse ALLOC_PAP{} = 1 -bciStackUse (UNPACK sz) = fromIntegral sz -bciStackUse LABEL{} = 0 -bciStackUse TESTLT_I{} = 0 -bciStackUse TESTEQ_I{} = 0 -bciStackUse TESTLT_W{} = 0 -bciStackUse TESTEQ_W{} = 0 -bciStackUse TESTLT_F{} = 0 -bciStackUse TESTEQ_F{} = 0 -bciStackUse TESTLT_D{} = 0 -bciStackUse TESTEQ_D{} = 0 -bciStackUse TESTLT_P{} = 0 -bciStackUse TESTEQ_P{} = 0 -bciStackUse CASEFAIL{} = 0 -bciStackUse JMP{} = 0 -bciStackUse ENTER{} = 0 -bciStackUse RETURN{} = 0 -bciStackUse RETURN_UBX{} = 1 -bciStackUse CCALL{} = 0 -bciStackUse SWIZZLE{} = 0 -bciStackUse BRK_FUN{} = 0 - --- These insns actually reduce stack use, but we need the high-tide level, --- so can't use this info. Not that it matters much. -bciStackUse SLIDE{} = 0 -bciStackUse MKAP{} = 0 -bciStackUse MKPAP{} = 0 -bciStackUse PACK{} = 1 -- worst case is PACK 0 words diff --git a/ghci/ByteCodeItbls.hs b/ghci/ByteCodeItbls.hs deleted file mode 100644 --- a/ghci/ByteCodeItbls.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes -module ByteCodeItbls ( mkITbls ) where - -#include "HsVersions.h" - -import ByteCodeTypes -import GHCi -import DynFlags -import HscTypes -import Name ( Name, getName ) -import NameEnv -import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) -import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) -import RepType -import StgCmmLayout ( mkVirtConstrSizes ) -import StgCmmClosure ( tagForCon, NonVoid (..) ) -import Util -import Panic - -{- - Manufacturing of info tables for DataCons --} - --- Make info tables for the data decls in this module -mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv -mkITbls hsc_env tcs = - foldr plusNameEnv emptyNameEnv <$> - mapM (mkITbl hsc_env) (filter isDataTyCon tcs) - where - mkITbl :: HscEnv -> TyCon -> IO ItblEnv - mkITbl hsc_env tc - | dcs `lengthIs` n -- paranoia; this is an assertion. - = make_constr_itbls hsc_env dcs - where - dcs = tyConDataCons tc - n = tyConFamilySize tc - mkITbl _ _ = panic "mkITbl" - -mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv -mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs] - --- Assumes constructors are numbered from zero, not one -make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv -make_constr_itbls hsc_env cons = - mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..]) - where - dflags = hsc_dflags hsc_env - - mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) - mk_itbl dcon conNo = do - let rep_args = [ NonVoid prim_rep - | arg <- dataConRepArgTys dcon - , prim_rep <- typePrimRep arg ] - - (tot_wds, ptr_wds) = - mkVirtConstrSizes dflags rep_args - - ptrs' = ptr_wds - nptrs' = tot_wds - ptr_wds - nptrs_really - | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs' - | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs' - - descr = dataConIdentity dcon - - r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really - conNo (tagForCon dflags dcon) descr) - return (getName dcon, ItblPtr r) diff --git a/ghci/ByteCodeLink.hs b/ghci/ByteCodeLink.hs deleted file mode 100644 --- a/ghci/ByteCodeLink.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeLink: Bytecode assembler and linker -module ByteCodeLink ( - ClosureEnv, emptyClosureEnv, extendClosureEnv, - linkBCO, lookupStaticPtr, - lookupIE, - nameToCLabel, linkFail - ) where - -#include "HsVersions.h" - -import GHCi.RemoteTypes -import GHCi.ResolvedBCO -import GHCi.InfoTable -import GHCi.BreakArray -import SizedSeq - -import GHCi -import ByteCodeTypes -import HscTypes -import DynFlags -import Name -import NameEnv -import PrimOp -import Module -import FastString -import Panic -import Outputable -import Util - --- Standard libraries -import Data.Array.Unboxed -import Data.Array.Base -import Data.Word -import Foreign.Ptr -import GHC.IO ( IO(..) ) -import GHC.Exts - -{- - Linking interpretables into something we can run --} - -type ClosureEnv = NameEnv (Name, ForeignHValue) - -emptyClosureEnv :: ClosureEnv -emptyClosureEnv = emptyNameEnv - -extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv -extendClosureEnv cl_env pairs - = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs] - -{- - Linking interpretables into something we can run --} - -linkBCO - :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray - -> UnlinkedBCO - -> IO ResolvedBCO -linkBCO hsc_env ie ce bco_ix breakarray - (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do - lits <- mapM (lookupLiteral hsc_env ie) (ssElts lits0) - ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0) - let dflags = hsc_dflags hsc_env - return (ResolvedBCO arity (toWordArray dflags insns) bitmap - (listArray (0, fromIntegral (sizeSS lits0)-1) lits) - (addListToSS emptySS ptrs)) - --- Turn the insns array from a Word16 array into a Word array. The --- latter is much faster to serialize/deserialize. Assumes the input --- array is zero-indexed. -toWordArray :: DynFlags -> UArray Int Word16 -> UArray Int Word -toWordArray dflags (UArray _ _ n arr) = UArray 0 (n'-1) n' arr - where n' = (n + w16s_per_word - 1) `quot` w16s_per_word - w16s_per_word = wORD_SIZE dflags `quot` 2 - -lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word -lookupLiteral _ _ (BCONPtrWord lit) = return lit -lookupLiteral hsc_env _ (BCONPtrLbl sym) = do - Ptr a# <- lookupStaticPtr hsc_env sym - return (W# (int2Word# (addr2Int# a#))) -lookupLiteral hsc_env ie (BCONPtrItbl nm) = do - Ptr a# <- lookupIE hsc_env ie nm - return (W# (int2Word# (addr2Int# a#))) -lookupLiteral _ _ (BCONPtrStr _) = - -- should be eliminated during assembleBCOs - panic "lookupLiteral: BCONPtrStr" - -lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ()) -lookupStaticPtr hsc_env addr_of_label_string = do - m <- lookupSymbol hsc_env addr_of_label_string - case m of - Just ptr -> return ptr - Nothing -> linkFail "ByteCodeLink: can't find label" - (unpackFS addr_of_label_string) - -lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ()) -lookupIE hsc_env ie con_nm = - case lookupNameEnv ie con_nm of - Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a))) - Nothing -> do -- try looking up in the object files. - let sym_to_find1 = nameToCLabel con_nm "con_info" - m <- lookupSymbol hsc_env sym_to_find1 - case m of - Just addr -> return addr - Nothing - -> do -- perhaps a nullary constructor? - let sym_to_find2 = nameToCLabel con_nm "static_info" - n <- lookupSymbol hsc_env sym_to_find2 - case n of - Just addr -> return addr - Nothing -> linkFail "ByteCodeLink.lookupIE" - (unpackFS sym_to_find1 ++ " or " ++ - unpackFS sym_to_find2) - -lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ()) -lookupPrimOp hsc_env primop = do - let sym_to_find = primopToCLabel primop "closure" - m <- lookupSymbol hsc_env (mkFastString sym_to_find) - case m of - Just p -> return (toRemotePtr p) - Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find - -resolvePtr - :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray - -> BCOPtr - -> IO ResolvedBCOPtr -resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm) - | Just ix <- lookupNameEnv bco_ix nm = - return (ResolvedBCORef ix) -- ref to another BCO in this group - | Just (_, rhv) <- lookupNameEnv ce nm = - return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) - | otherwise = - ASSERT2(isExternalName nm, ppr nm) - do let sym_to_find = nameToCLabel nm "closure" - m <- lookupSymbol hsc_env sym_to_find - case m of - Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) - Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find) -resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) = - ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op -resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) = - ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco -resolvePtr _ _ _ _ breakarray BCOPtrBreakArray = - return (ResolvedBCOPtrBreakArray breakarray) - -linkFail :: String -> String -> IO a -linkFail who what - = throwGhcExceptionIO (ProgramError $ - unlines [ "",who - , "During interactive linking, GHCi couldn't find the following symbol:" - , ' ' : ' ' : what - , "This may be due to you not asking GHCi to load extra object files," - , "archives or DLLs needed by your current session. Restart GHCi, specifying" - , "the missing library using the -L/path/to/object/dir and -lmissinglibname" - , "flags, or simply by naming the relevant files on the GHCi command line." - , "Alternatively, this link failure might indicate a bug in GHCi." - , "If you suspect the latter, please send a bug report to:" - , " glasgow-haskell-bugs@haskell.org" - ]) - - -nameToCLabel :: Name -> String -> FastString -nameToCLabel n suffix = mkFastString label - where - encodeZ = zString . zEncodeFS - (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n - packagePart = encodeZ (unitIdFS pkgKey) - modulePart = encodeZ (moduleNameFS modName) - occPart = encodeZ (occNameFS (nameOccName n)) - - label = concat - [ if pkgKey == mainUnitId then "" else packagePart ++ "_" - , modulePart - , '_':occPart - , '_':suffix - ] - - -primopToCLabel :: PrimOp -> String -> String -primopToCLabel primop suffix = concat - [ "ghczmprim_GHCziPrimopWrappers_" - , zString (zEncodeFS (occNameFS (primOpOcc primop))) - , '_':suffix - ] diff --git a/ghci/ByteCodeTypes.hs b/ghci/ByteCodeTypes.hs deleted file mode 100644 --- a/ghci/ByteCodeTypes.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | Bytecode assembler types -module ByteCodeTypes - ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..) - , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) - , ItblEnv, ItblPtr(..) - , CgBreakInfo(..) - , ModBreaks (..), BreakIndex, emptyModBreaks - , CCostCentre - ) where - -import FastString -import Id -import Name -import NameEnv -import Outputable -import PrimOp -import SizedSeq -import Type -import SrcLoc -import GHCi.BreakArray -import GHCi.RemoteTypes -import GHCi.FFI -import GHCi.InfoTable -import Control.DeepSeq - -import Foreign -import Data.Array -import Data.Array.Base ( UArray(..) ) -import Data.ByteString (ByteString) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -#if MIN_VERSION_base(4,9,0) -import GHC.Stack.CCS -#else -import GHC.Stack as GHC.Stack.CCS -#endif - --- ----------------------------------------------------------------------------- --- Compiled Byte Code - -data CompiledByteCode = CompiledByteCode - { bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings - , bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls - , bc_ffis :: [FFIInfo] -- ffi blocks we allocated - , bc_strs :: [RemotePtr ()] -- malloc'd strings - , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not - -- creating breakpoints, for some reason) - } - -- ToDo: we're not tracking strings that we malloc'd -newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif) - deriving (Show, NFData) - -instance Outputable CompiledByteCode where - ppr CompiledByteCode{..} = ppr bc_bcos - --- Not a real NFData instance, because ModBreaks contains some things --- we can't rnf -seqCompiledByteCode :: CompiledByteCode -> () -seqCompiledByteCode CompiledByteCode{..} = - rnf bc_bcos `seq` - rnf (nameEnvElts bc_itbls) `seq` - rnf bc_ffis `seq` - rnf bc_strs `seq` - rnf (fmap seqModBreaks bc_breaks) - -type ItblEnv = NameEnv (Name, ItblPtr) - -- We need the Name in the range so we know which - -- elements to filter out when unloading a module - -newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable) - deriving (Show, NFData) - -data UnlinkedBCO - = UnlinkedBCO { - unlinkedBCOName :: !Name, - unlinkedBCOArity :: {-# UNPACK #-} !Int, - unlinkedBCOInstrs :: !(UArray Int Word16), -- insns - unlinkedBCOBitmap :: !(UArray Int Word), -- bitmap - unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs - } - -instance NFData UnlinkedBCO where - rnf UnlinkedBCO{..} = - rnf unlinkedBCOLits `seq` - rnf unlinkedBCOPtrs - -data BCOPtr - = BCOPtrName !Name - | BCOPtrPrimOp !PrimOp - | BCOPtrBCO !UnlinkedBCO - | BCOPtrBreakArray -- a pointer to this module's BreakArray - -instance NFData BCOPtr where - rnf (BCOPtrBCO bco) = rnf bco - rnf x = x `seq` () - -data BCONPtr - = BCONPtrWord {-# UNPACK #-} !Word - | BCONPtrLbl !FastString - | BCONPtrItbl !Name - | BCONPtrStr !ByteString - -instance NFData BCONPtr where - rnf x = x `seq` () - --- | Information about a breakpoint that we know at code-generation time -data CgBreakInfo - = CgBreakInfo - { cgb_vars :: [(Id,Word16)] - , cgb_resty :: Type - } - --- Not a real NFData instance because we can't rnf Id or Type -seqCgBreakInfo :: CgBreakInfo -> () -seqCgBreakInfo CgBreakInfo{..} = - rnf (map snd cgb_vars) `seq` - seqType cgb_resty - -instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) - = sep [text "BCO", ppr nm, text "with", - ppr (sizeSS lits), text "lits", - ppr (sizeSS ptrs), text "ptrs" ] - -instance Outputable CgBreakInfo where - ppr info = text "CgBreakInfo" <+> - parens (ppr (cgb_vars info) <+> - ppr (cgb_resty info)) - --- ----------------------------------------------------------------------------- --- Breakpoints - --- | Breakpoint index -type BreakIndex = Int - --- | C CostCentre type -data CCostCentre - --- | All the information about the breakpoints for a module -data ModBreaks - = ModBreaks - { modBreaks_flags :: ForeignRef BreakArray - -- ^ The array of flags, one per breakpoint, - -- indicating which breakpoints are enabled. - , modBreaks_locs :: !(Array BreakIndex SrcSpan) - -- ^ An array giving the source span of each breakpoint. - , modBreaks_vars :: !(Array BreakIndex [OccName]) - -- ^ An array giving the names of the free variables at each breakpoint. - , modBreaks_decls :: !(Array BreakIndex [String]) - -- ^ An array giving the names of the declarations enclosing each breakpoint. - , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre)) - -- ^ Array pointing to cost centre for each breakpoint - , modBreaks_breakInfo :: IntMap CgBreakInfo - -- ^ info about each breakpoint from the bytecode generator - } - -seqModBreaks :: ModBreaks -> () -seqModBreaks ModBreaks{..} = - rnf modBreaks_flags `seq` - rnf modBreaks_locs `seq` - rnf modBreaks_vars `seq` - rnf modBreaks_decls `seq` - rnf modBreaks_ccs `seq` - rnf (fmap seqCgBreakInfo modBreaks_breakInfo) - --- | Construct an empty ModBreaks -emptyModBreaks :: ModBreaks -emptyModBreaks = ModBreaks - { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" - -- ToDo: can we avoid this? - , modBreaks_locs = array (0,-1) [] - , modBreaks_vars = array (0,-1) [] - , modBreaks_decls = array (0,-1) [] - , modBreaks_ccs = array (0,-1) [] - , modBreaks_breakInfo = IntMap.empty - } diff --git a/ghci/Debugger.hs b/ghci/Debugger.hs deleted file mode 100644 --- a/ghci/Debugger.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE MagicHash #-} - ------------------------------------------------------------------------------ --- --- GHCi Interactive debugging commands --- --- Pepe Iborra (supported by Google SoC) 2006 --- --- ToDo: lots of violation of layering here. This module should --- decide whether it is above the GHC API (import GHC and nothing --- else) or below it. --- ------------------------------------------------------------------------------ - -module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where - -import Linker -import RtClosureInspect - -import GHCi -import GHCi.RemoteTypes -import GhcMonad -import HscTypes -import Id -import IfaceSyn ( showToHeader ) -import IfaceEnv( newInteractiveBinder ) -import Name -import Var hiding ( varName ) -import VarSet -import UniqSet -import Type -import GHC -import Outputable -import PprTyThing -import ErrUtils -import MonadUtils -import DynFlags -import Exception - -import Control.Monad -import Data.List -import Data.Maybe -import Data.IORef - -import GHC.Exts - -------------------------------------- --- | The :print & friends commands -------------------------------------- -pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m () -pprintClosureCommand bindThings force str = do - tythings <- (catMaybes . concat) `liftM` - mapM (\w -> GHC.parseName w >>= - mapM GHC.lookupName) - (words str) - let ids = [id | AnId id <- tythings] - - -- Obtain the terms and the recovered type information - (subst, terms) <- mapAccumLM go emptyTCvSubst ids - - -- Apply the substitutions obtained after recovering the types - modifySession $ \hsc_env -> - hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst} - - -- Finally, print the Terms - unqual <- GHC.getPrintUnqual - docterms <- mapM showTerm terms - dflags <- getDynFlags - liftIO $ (printOutputForUser dflags unqual . vcat) - (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) - ids - docterms) - where - -- Do the obtainTerm--bindSuspensions-computeSubstitution dance - go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) - go subst id = do - let id' = id `setIdType` substTy subst (idType id) - term_ <- GHC.obtainTermFromId maxBound force id' - term <- tidyTermTyVars term_ - term' <- if bindThings && - (not (isUnliftedType (termType term))) - then bindSuspensions term - else return term - -- Before leaving, we compare the type obtained to see if it's more specific - -- Then, we extract a substitution, - -- mapping the old tyvars to the reconstructed types. - let reconstructed_type = termType term - hsc_env <- getSession - case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of - Nothing -> return (subst, term') - Just subst' -> do { traceOptIf Opt_D_dump_rtti - (fsep $ [text "RTTI Improvement for", ppr id, - text "is the substitution:" , ppr subst']) - ; return (subst `unionTCvSubst` subst', term')} - - tidyTermTyVars :: GhcMonad m => Term -> m Term - tidyTermTyVars t = - withSession $ \hsc_env -> do - let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env - my_tvs = termTyCoVars t - tvs = env_tvs `minusVarSet` my_tvs - tyvarOccName = nameOccName . tyVarName - tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs)) - -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv - -- forgets the ordering immediately by creating an env - , getUniqSet $ env_tvs `intersectVarSet` my_tvs) - return $ mapTermType (snd . tidyOpenType tidyEnv) t - --- | Give names, and bind in the interactive environment, to all the suspensions --- included (inductively) in a term -bindSuspensions :: GhcMonad m => Term -> m Term -bindSuspensions t = do - hsc_env <- getSession - inScope <- GHC.getBindings - let ictxt = hsc_IC hsc_env - prefix = "_t" - alreadyUsedNames = map (occNameString . nameOccName . getName) inScope - availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames - availNames_var <- liftIO $ newIORef availNames - (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t - let (names, tys, hvals) = unzip3 stuff - let ids = [ mkVanillaGlobal name ty - | (name,ty) <- zip names tys] - new_ic = extendInteractiveContextWithIds ictxt ids - fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) hvals - liftIO $ extendLinkEnv (zip names fhvs) - setSession hsc_env {hsc_IC = new_ic } - return t' - where - --- Processing suspensions. Give names and recopilate info - nameSuspensionsAndGetInfos :: HscEnv -> IORef [String] - -> TermFold (IO (Term, [(Name,Type,HValue)])) - 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=val} = - if not (isFullyEvaluatedTerm t) - then return Nothing - else do - hsc_env <- getSession - dflags <- GHC.getSessionDynFlags - do - (new_env, bname) <- bindToFreshName hsc_env ty "showme" - setSession new_env - -- XXX: this tries to disable logging of errors - -- does this still do what it is intended to do - -- with the changed error handling and logging? - let noop_log _ _ _ _ _ _ = return () - expr = "show " ++ showPpr dflags bname - _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} - fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val - txt_ <- withExtendedLinkEnv [(bname, fhv)] - (GHC.compileExpr expr) - let myprec = 10 -- application precedence. TODO Infix constructors - let txt = unsafeCoerce# txt_ :: [a] - if not (null txt) then - return $ Just $ cparen (prec >= myprec && needsParens txt) - (text txt) - else return Nothing - `gfinally` do - setSession hsc_env - GHC.setSessionDynFlags dflags - cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = - cPprShowable prec t{ty=new_ty} - cPprShowable _ _ = return Nothing - - needsParens ('"':_) = False -- some simple heuristics to see whether parens - -- are redundant in an arbitrary Show output - needsParens ('(':_) = False - needsParens txt = ' ' `elem` txt - - - bindToFreshName hsc_env ty userName = do - name <- newGrimName hsc_env userName - let id = mkVanillaGlobal name ty - new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id] - return (hsc_env {hsc_IC = new_ic }, name) - --- Create new uniques and give them sequentially numbered names -newGrimName :: MonadIO m => HscEnv -> String -> m Name -newGrimName hsc_env userName - = liftIO (newInteractiveBinder hsc_env occ noSrcSpan) - where - occ = mkOccName varName userName - -pprTypeAndContents :: GhcMonad m => Id -> m SDoc -pprTypeAndContents id = do - dflags <- GHC.getSessionDynFlags - let pcontents = gopt Opt_PrintBindContents dflags - pprdId = (pprTyThing showToHeader . AnId) id - if pcontents - then do - let depthBound = 100 - -- If the value is an exception, make sure we catch it and - -- show the exception, rather than propagating the exception out. - e_term <- gtry $ GHC.obtainTermFromId depthBound False id - docs_term <- case e_term of - Right term -> showTerm term - Left exn -> return (text "*** Exception:" <+> - text (show (exn :: SomeException))) - return $ pprdId <+> equals <+> docs_term - else return pprdId - --------------------------------------------------------------- --- Utils - -traceOptIf :: GhcMonad m => DumpFlag -> SDoc -> m () -traceOptIf flag doc = do - dflags <- GHC.getSessionDynFlags - when (dopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc diff --git a/ghci/DebuggerUtils.hs b/ghci/DebuggerUtils.hs deleted file mode 100644 --- a/ghci/DebuggerUtils.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE CPP #-} - -module DebuggerUtils ( - dataConInfoPtrToName, - ) where - -import GHCi.InfoTable -import CmmInfo ( stdInfoTableSizeB ) -import DynFlags -import FastString -import TcRnTypes -import TcRnMonad -import IfaceEnv -import Module -import OccName -import Name -import Outputable -import Util - -import Data.Char -import Foreign -import Data.List - -#include "HsVersions.h" - --- | Given a data constructor in the heap, find its Name. --- The info tables for data constructors have a field which records --- the source name of the constructor as a Ptr Word8 (UTF-8 encoded --- string). The format is: --- --- > Package:Module.Name --- --- We use this string to lookup the interpreter's internal representation of the name --- using the lookupOrig. --- -dataConInfoPtrToName :: Ptr () -> TcM (Either String Name) -dataConInfoPtrToName x = do - dflags <- getDynFlags - theString <- liftIO $ do - let ptr = castPtr x :: Ptr StgInfoTable - conDescAddress <- getConDescAddress dflags ptr - peekArray0 0 conDescAddress - let (pkg, mod, occ) = parse theString - pkgFS = mkFastStringByteList pkg - modFS = mkFastStringByteList mod - occFS = mkFastStringByteList occ - occName = mkOccNameFS OccName.dataName occFS - modName = mkModule (fsToUnitId pkgFS) (mkModuleNameFS modFS) - return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName) - `recoverM` (Right `fmap` lookupOrig modName occName) - - where - - {- To find the string in the constructor's info table we need to consider - the layout of info tables relative to the entry code for a closure. - - An info table can be next to the entry code for the closure, or it can - be separate. The former (faster) is used in registerised versions of ghc, - and the latter (portable) is for non-registerised versions. - - The diagrams below show where the string is to be found relative to - the normal info table of the closure. - - 1) Code next to table: - - -------------- - | | <- pointer to the start of the string - -------------- - | | <- the (start of the) info table structure - | | - | | - -------------- - | entry code | - | .... | - - In this case the pointer to the start of the string can be found in - the memory location _one word before_ the first entry in the normal info - table. - - 2) Code NOT next to table: - - -------------- - info table structure -> | *------------------> -------------- - | | | entry code | - | | | .... | - -------------- - ptr to start of str -> | | - -------------- - - In this case the pointer to the start of the string can be found - in the memory location: info_table_ptr + info_table_size - -} - - getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8) - getConDescAddress dflags ptr - | ghciTablesNextToCode = do - let ptr' = ptr `plusPtr` (- wORD_SIZE dflags) - -- NB. the offset must be read as an Int32 not a Word32, so - -- that the sign is preserved when converting to an Int. - offsetToString <- fromIntegral <$> (peek ptr' :: IO Int32) - return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString - | otherwise = - peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags) - -- parsing names is a little bit fiddly because we have a string in the form: - -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). - -- Thus we split at the leftmost colon and the rightmost occurrence of the dot. - -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas - -- this is not the conventional way of writing Haskell names. We stick with - -- convention, even though it makes the parsing code more troublesome. - -- Warning: this code assumes that the string is well formed. - parse :: [Word8] -> ([Word8], [Word8], [Word8]) - parse input - = ASSERT(all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) - where - dot = fromIntegral (ord '.') - (pkg, rest1) = break (== fromIntegral (ord ':')) input - (mod, occ) - = (concat $ intersperse [dot] $ reverse modWords, occWord) - where - (modWords, occWord) = ASSERT(length rest1 > 0) (parseModOcc [] (tail rest1)) - parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) - -- We only look for dots if str could start with a module name, - -- i.e. if it starts with an upper case character. - -- Otherwise we might think that "X.:->" is the module name in - -- "X.:->.+", whereas actually "X" is the module name and - -- ":->.+" is a constructor name. - parseModOcc acc str@(c : _) - | isUpper $ chr $ fromIntegral c - = case break (== dot) str of - (top, []) -> (acc, top) - (top, _ : bot) -> parseModOcc (top : acc) bot - parseModOcc acc str = (acc, str) diff --git a/ghci/GHCi.hsc b/ghci/GHCi.hsc deleted file mode 100644 --- a/ghci/GHCi.hsc +++ /dev/null @@ -1,677 +0,0 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-} - --- --- | Interacting with the interpreter, whether it is running on an --- external process or in the current process. --- -module GHCi - ( -- * High-level interface to the interpreter - evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..) - , resumeStmt - , abandonStmt - , evalIO - , evalString - , evalStringToIOString - , mallocData - , createBCOs - , addSptEntry - , mkCostCentres - , costCentreStackInfo - , newBreakArray - , enableBreakpoint - , breakpointStatus - , getBreakpointVar - - -- * The object-code linker - , initObjLinker - , lookupSymbol - , lookupClosure - , loadDLL - , loadArchive - , loadObj - , unloadObj - , addLibrarySearchPath - , removeLibrarySearchPath - , resolveObjs - , findSystemLibrary - - -- * Lower-level API using messages - , iservCmd, Message(..), withIServ, stopIServ - , iservCall, readIServ, writeIServ - , purgeLookupSymbolCache - , freeHValueRefs - , mkFinalizedHValue - , wormhole, wormholeRef - , mkEvalOpts - , fromEvalResult - ) where - -import GHCi.Message -#ifdef GHCI -import GHCi.Run -#endif -import GHCi.RemoteTypes -import GHCi.ResolvedBCO -import GHCi.BreakArray (BreakArray) -import Fingerprint -import HscTypes -import UniqFM -import Panic -import DynFlags -import ErrUtils -import Outputable -import Exception -import BasicTypes -import FastString -import Util -import Hooks - -import Control.Concurrent -import Control.Monad -import Control.Monad.IO.Class -import Data.Binary -import Data.Binary.Put -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LB -import Data.IORef -import Foreign hiding (void) -#if MIN_VERSION_base(4,9,0) -import GHC.Stack.CCS (CostCentre,CostCentreStack) -#else -import GHC.Stack (CostCentre,CostCentreStack) -#endif -import System.Exit -import Data.Maybe -import GHC.IO.Handle.Types (Handle) -#ifdef mingw32_HOST_OS -import Foreign.C -import GHC.IO.Handle.FD (fdToHandle) -#if !MIN_VERSION_process(1,4,2) -import System.Posix.Internals -import Foreign.Marshal.Array -import Foreign.C.Error -import Foreign.Storable -#endif -#else -import System.Posix as Posix -#endif -import System.Directory -import System.Process -import GHC.Conc (getNumProcessors, pseq, par) - -{- Note [Remote GHCi] - -When the flag -fexternal-interpreter is given to GHC, interpreted code -is run in a separate process called iserv, and we communicate with the -external process over a pipe using Binary-encoded messages. - -Motivation -~~~~~~~~~~ - -When the interpreted code is running in a separate process, it can -use a different "way", e.g. profiled or dynamic. This means - -- compiling Template Haskell code with -prof does not require - building the code without -prof first - -- when GHC itself is profiled, it can interpret unprofiled code, - and the same applies to dynamic linking. - -- An unprofiled GHCi can load and run profiled code, which means it - can use the stack-trace functionality provided by profiling without - taking the performance hit on the compiler that profiling would - entail. - -For other reasons see RemoteGHCi on the wiki. - -Implementation Overview -~~~~~~~~~~~~~~~~~~~~~~~ - -The main pieces are: - -- libraries/ghci, containing: - - types for talking about remote values (GHCi.RemoteTypes) - - the message protocol (GHCi.Message), - - implementation of the messages (GHCi.Run) - - implementation of Template Haskell (GHCi.TH) - - a few other things needed to run interpreted code - -- top-level iserv directory, containing the codefor the external - server. This is a fairly simple wrapper, most of the functionality - is provided by modules in libraries/ghci. - -- This module (GHCi) which provides the interface to the server used - by the rest of GHC. - -GHC works with and without -fexternal-interpreter. With the flag, all -interpreted code is run by the iserv binary. Without the flag, -interpreted code is run in the same process as GHC. - -Things that do not work with -fexternal-interpreter -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -dynCompileExpr cannot work, because we have no way to run code of an -unknown type in the remote process. This API fails with an error -message if it is used with -fexternal-interpreter. - -Other Notes on Remote GHCi -~~~~~~~~~~~~~~~~~~~~~~~~~~ - * This wiki page has an implementation overview: - https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/ExternalInterpreter - * Note [External GHCi pointers] in compiler/ghci/GHCi.hs - * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs --} - -#ifndef GHCI -needExtInt :: IO a -needExtInt = throwIO - (InstallationError "this operation requires -fexternal-interpreter") -#endif - --- | Run a command in the interpreter's context. With --- @-fexternal-interpreter@, the command is serialized and sent to an --- external iserv process, and the response is deserialized (hence the --- @Binary@ constraint). With @-fno-external-interpreter@ we execute --- the command directly here. -iservCmd :: Binary a => HscEnv -> Message a -> IO a -iservCmd hsc_env@HscEnv{..} msg - | gopt Opt_ExternalInterpreter hsc_dflags = - withIServ hsc_env $ \iserv -> - uninterruptibleMask_ $ do -- Note [uninterruptibleMask_] - iservCall iserv msg - | otherwise = -- Just run it directly -#ifdef GHCI - run msg -#else - needExtInt -#endif - --- Note [uninterruptibleMask_ and iservCmd] --- --- If we receive an async exception, such as ^C, while communicating --- with the iserv process then we will be out-of-sync and not be able --- to recoever. Thus we use uninterruptibleMask_ during --- communication. A ^C will be delivered to the iserv process (because --- signals get sent to the whole process group) which will interrupt --- the running computation and return an EvalException result. - --- | Grab a lock on the 'IServ' and do something with it. --- Overloaded because this is used from TcM as well as IO. -withIServ - :: (MonadIO m, ExceptionMonad m) - => HscEnv -> (IServ -> m a) -> m a -withIServ HscEnv{..} action = - gmask $ \restore -> do - m <- liftIO $ takeMVar hsc_iserv - -- start the iserv process if we haven't done so yet - iserv <- maybe (liftIO $ startIServ hsc_dflags) return m - `gonException` (liftIO $ putMVar hsc_iserv Nothing) - -- free any ForeignHValues that have been garbage collected. - let iserv' = iserv{ iservPendingFrees = [] } - a <- (do - liftIO $ when (not (null (iservPendingFrees iserv))) $ - iservCall iserv (FreeHValueRefs (iservPendingFrees iserv)) - -- run the inner action - restore $ action iserv) - `gonException` (liftIO $ putMVar hsc_iserv (Just iserv')) - liftIO $ putMVar hsc_iserv (Just iserv') - return a - - --- ----------------------------------------------------------------------------- --- Wrappers around messages - --- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for --- each of the results. -evalStmt - :: HscEnv -> Bool -> EvalExpr ForeignHValue - -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) -evalStmt hsc_env step foreign_expr = do - let dflags = hsc_dflags hsc_env - status <- withExpr foreign_expr $ \expr -> - iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr) - handleEvalStatus hsc_env status - where - withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a - withExpr (EvalThis fhv) cont = - withForeignRef fhv $ \hvref -> cont (EvalThis hvref) - withExpr (EvalApp fl fr) cont = - withExpr fl $ \fl' -> - withExpr fr $ \fr' -> - cont (EvalApp fl' fr') - -resumeStmt - :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef]) - -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) -resumeStmt hsc_env step resume_ctxt = do - let dflags = hsc_dflags hsc_env - status <- withForeignRef resume_ctxt $ \rhv -> - iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv) - handleEvalStatus hsc_env status - -abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO () -abandonStmt hsc_env resume_ctxt = do - withForeignRef resume_ctxt $ \rhv -> - iservCmd hsc_env (AbandonStmt rhv) - -handleEvalStatus - :: HscEnv -> EvalStatus [HValueRef] - -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) -handleEvalStatus hsc_env status = - case status of - EvalBreak a b c d e f -> return (EvalBreak a b c d e f) - EvalComplete alloc res -> - EvalComplete alloc <$> addFinalizer res - where - addFinalizer (EvalException e) = return (EvalException e) - addFinalizer (EvalSuccess rs) = do - EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs - --- | Execute an action of type @IO ()@ -evalIO :: HscEnv -> ForeignHValue -> IO () -evalIO hsc_env fhv = do - liftIO $ withForeignRef fhv $ \fhv -> - iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult - --- | Execute an action of type @IO String@ -evalString :: HscEnv -> ForeignHValue -> IO String -evalString hsc_env fhv = do - liftIO $ withForeignRef fhv $ \fhv -> - iservCmd hsc_env (EvalString fhv) >>= fromEvalResult - --- | Execute an action of type @String -> IO String@ -evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String -evalStringToIOString hsc_env fhv str = do - liftIO $ withForeignRef fhv $ \fhv -> - iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult - - --- | Allocate and store the given bytes in memory, returning a pointer --- to the memory in the remote process. -mallocData :: HscEnv -> ByteString -> IO (RemotePtr ()) -mallocData hsc_env bs = iservCmd hsc_env (MallocData bs) - -mkCostCentres - :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre] -mkCostCentres hsc_env mod ccs = - iservCmd hsc_env (MkCostCentres mod ccs) - --- | Create a set of BCOs that may be mutually recursive. -createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef] -createBCOs hsc_env rbcos = do - n_jobs <- case parMakeCount (hsc_dflags hsc_env) of - Nothing -> liftIO getNumProcessors - Just n -> return n - -- Serializing ResolvedBCO is expensive, so if we're in parallel mode - -- (-j) parallelise the serialization. - if (n_jobs == 1) - then - iservCmd hsc_env (CreateBCOs [runPut (put rbcos)]) - - else do - old_caps <- getNumCapabilities - if old_caps == n_jobs - then void $ evaluate puts - else bracket_ (setNumCapabilities n_jobs) - (setNumCapabilities old_caps) - (void $ evaluate puts) - iservCmd hsc_env (CreateBCOs puts) - where - puts = parMap doChunk (chunkList 100 rbcos) - - -- make sure we force the whole lazy ByteString - doChunk c = pseq (LB.length bs) bs - where bs = runPut (put c) - - -- We don't have the parallel package, so roll our own simple parMap - parMap _ [] = [] - parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs)) - where fx = f x; fxs = parMap f xs - -addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO () -addSptEntry hsc_env fpr ref = - withForeignRef ref $ \val -> - iservCmd hsc_env (AddSptEntry fpr val) - -costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String] -costCentreStackInfo hsc_env ccs = - iservCmd hsc_env (CostCentreStackInfo ccs) - -newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray) -newBreakArray hsc_env size = do - breakArray <- iservCmd hsc_env (NewBreakArray size) - mkFinalizedHValue hsc_env breakArray - -enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO () -enableBreakpoint hsc_env ref ix b = do - withForeignRef ref $ \breakarray -> - iservCmd hsc_env (EnableBreakpoint breakarray ix b) - -breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool -breakpointStatus hsc_env ref ix = do - withForeignRef ref $ \breakarray -> - iservCmd hsc_env (BreakpointStatus breakarray ix) - -getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue) -getBreakpointVar hsc_env ref ix = - withForeignRef ref $ \apStack -> do - mb <- iservCmd hsc_env (GetBreakpointVar apStack ix) - mapM (mkFinalizedHValue hsc_env) mb - --- ----------------------------------------------------------------------------- --- Interface to the object-code linker - -initObjLinker :: HscEnv -> IO () -initObjLinker hsc_env = iservCmd hsc_env InitLinker - -lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ())) -lookupSymbol hsc_env@HscEnv{..} str - | gopt Opt_ExternalInterpreter hsc_dflags = - -- Profiling of GHCi showed a lot of time and allocation spent - -- making cross-process LookupSymbol calls, so I added a GHC-side - -- cache which sped things up quite a lot. We have to be careful - -- to purge this cache when unloading code though. - withIServ hsc_env $ \iserv@IServ{..} -> do - cache <- readIORef iservLookupSymbolCache - case lookupUFM cache str of - Just p -> return (Just p) - Nothing -> do - m <- uninterruptibleMask_ $ - iservCall iserv (LookupSymbol (unpackFS str)) - case m of - Nothing -> return Nothing - Just r -> do - let p = fromRemotePtr r - writeIORef iservLookupSymbolCache $! addToUFM cache str p - return (Just p) - | otherwise = -#ifdef GHCI - fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) -#else - needExtInt -#endif - -lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef) -lookupClosure hsc_env str = - iservCmd hsc_env (LookupClosure str) - -purgeLookupSymbolCache :: HscEnv -> IO () -purgeLookupSymbolCache hsc_env@HscEnv{..} = - when (gopt Opt_ExternalInterpreter hsc_dflags) $ - withIServ hsc_env $ \IServ{..} -> - writeIORef iservLookupSymbolCache emptyUFM - - --- | loadDLL loads a dynamic library using the OS's native linker --- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either --- an absolute pathname to the file, or a relative filename --- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL --- searches the standard locations for the appropriate library. --- --- Returns: --- --- Nothing => success --- Just err_msg => failure -loadDLL :: HscEnv -> String -> IO (Maybe String) -loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str) - -loadArchive :: HscEnv -> String -> IO () -loadArchive hsc_env path = do - path' <- canonicalizePath path -- Note [loadObj and relative paths] - iservCmd hsc_env (LoadArchive path') - -loadObj :: HscEnv -> String -> IO () -loadObj hsc_env path = do - path' <- canonicalizePath path -- Note [loadObj and relative paths] - iservCmd hsc_env (LoadObj path') - -unloadObj :: HscEnv -> String -> IO () -unloadObj hsc_env path = do - path' <- canonicalizePath path -- Note [loadObj and relative paths] - iservCmd hsc_env (UnloadObj path') - --- Note [loadObj and relative paths] --- the iserv process might have a different current directory from the --- GHC process, so we must make paths absolute before sending them --- over. - -addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ()) -addLibrarySearchPath hsc_env str = - fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str) - -removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool -removeLibrarySearchPath hsc_env p = - iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p)) - -resolveObjs :: HscEnv -> IO SuccessFlag -resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs - -findSystemLibrary :: HscEnv -> String -> IO (Maybe String) -findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str) - - --- ----------------------------------------------------------------------------- --- Raw calls and messages - --- | Send a 'Message' and receive the response from the iserv process -iservCall :: Binary a => IServ -> Message a -> IO a -iservCall iserv@IServ{..} msg = - remoteCall iservPipe msg - `catch` \(e :: SomeException) -> handleIServFailure iserv e - --- | Read a value from the iserv process -readIServ :: IServ -> Get a -> IO a -readIServ iserv@IServ{..} get = - readPipe iservPipe get - `catch` \(e :: SomeException) -> handleIServFailure iserv e - --- | Send a value to the iserv process -writeIServ :: IServ -> Put -> IO () -writeIServ iserv@IServ{..} put = - writePipe iservPipe put - `catch` \(e :: SomeException) -> handleIServFailure iserv e - -handleIServFailure :: IServ -> SomeException -> IO a -handleIServFailure IServ{..} e = do - ex <- getProcessExitCode iservProcess - case ex of - Just (ExitFailure n) -> - throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")")) - _ -> do - terminateProcess iservProcess - _ <- waitForProcess iservProcess - throw e - --- ----------------------------------------------------------------------------- --- Starting and stopping the iserv process - -startIServ :: DynFlags -> IO IServ -startIServ dflags = do - let flavour - | WayProf `elem` ways dflags = "-prof" - | WayDyn `elem` ways dflags = "-dyn" - | otherwise = "" - prog = pgm_i dflags ++ flavour - opts = getOpts dflags opt_i - debugTraceMsg dflags 3 $ text "Starting " <> text prog - let createProc = lookupHook createIservProcessHook - (\cp -> do { (_,_,_,ph) <- createProcess cp - ; return ph }) - dflags - (ph, rh, wh) <- runWithPipes createProc prog opts - lo_ref <- newIORef Nothing - cache_ref <- newIORef emptyUFM - return $ IServ - { iservPipe = Pipe { pipeRead = rh - , pipeWrite = wh - , pipeLeftovers = lo_ref } - , iservProcess = ph - , iservLookupSymbolCache = cache_ref - , iservPendingFrees = [] - } - -stopIServ :: HscEnv -> IO () -stopIServ HscEnv{..} = - gmask $ \_restore -> do - m <- takeMVar hsc_iserv - maybe (return ()) stop m - putMVar hsc_iserv Nothing - where - stop iserv = do - ex <- getProcessExitCode (iservProcess iserv) - if isJust ex - then return () - else iservCall iserv Shutdown - -runWithPipes :: (CreateProcess -> IO ProcessHandle) - -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) -#ifdef mingw32_HOST_OS -foreign import ccall "io.h _close" - c__close :: CInt -> IO CInt - -foreign import ccall unsafe "io.h _get_osfhandle" - _get_osfhandle :: CInt -> IO CInt - -runWithPipes createProc prog opts = do - (rfd1, wfd1) <- createPipeFd -- we read on rfd1 - (rfd2, wfd2) <- createPipeFd -- we write on wfd2 - wh_client <- _get_osfhandle wfd1 - rh_client <- _get_osfhandle rfd2 - let args = show wh_client : show rh_client : opts - ph <- createProc (proc prog args) - rh <- mkHandle rfd1 - wh <- mkHandle wfd2 - return (ph, rh, wh) - where mkHandle :: CInt -> IO Handle - mkHandle fd = (fdToHandle fd) `onException` (c__close fd) - -#if !MIN_VERSION_process(1,4,2) --- This #include and the _O_BINARY below are the only reason this is hsc, --- so we can remove that once we can depend on process 1.4.2 -#include - -createPipeFd :: IO (FD, FD) -createPipeFd = do - allocaArray 2 $ \ pfds -> do - throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY) - readfd <- peek pfds - writefd <- peekElemOff pfds 1 - return (readfd, writefd) - -foreign import ccall "io.h _pipe" c__pipe :: - Ptr CInt -> CUInt -> CInt -> IO CInt -#endif -#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 an value in the local heap. Obviously -we cannot use this to refer to things in the external process. - - -RemoteRef ---------- - -RemoteRef is a StablePtr to a heap-resident value. When --fexternal-interpreter is used, this value resides in the external -process's heap. RemoteRefs are mostly used to send pointers in -messages between GHC and iserv. - -A RemoteRef must be explicitly freed when no longer required, using -freeHValueRefs, or by attaching a finalizer with mkForeignHValue. - -To get from a RemoteRef to an HValue you can use 'wormholeRef', which -fails with an error message if -fexternal-interpreter is in use. - -ForeignRef ----------- - -A ForeignRef is a RemoteRef with a finalizer that will free the -'RemoteRef' when it is garbage collected. We mostly use ForeignHValue -on the GHC side. - -The finalizer adds the RemoteRef to the iservPendingFrees list in the -IServ record. The next call to iservCmd will free any RemoteRefs in -the list. It was done this way rather than calling iservCmd directly, -because I didn't want to have arbitrary threads calling iservCmd. In -principle it would probably be ok, but it seems less hairy this way. --} - --- | Creates a 'ForeignRef' that will automatically release the --- 'RemoteRef' when it is no longer referenced. -mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a) -mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free - where - !external = gopt Opt_ExternalInterpreter hsc_dflags - hvref = toHValueRef rref - - free :: IO () - free - | not external = freeRemoteRef hvref - | otherwise = - modifyMVar_ hsc_iserv $ \mb_iserv -> - case mb_iserv of - Nothing -> return Nothing -- already shut down - Just iserv@IServ{..} -> - return (Just iserv{iservPendingFrees = hvref : iservPendingFrees}) - -freeHValueRefs :: HscEnv -> [HValueRef] -> IO () -freeHValueRefs _ [] = return () -freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs) - --- | Convert a 'ForeignRef' to the value it references directly. This --- only works when the interpreter is running in the same process as --- the compiler, so it fails when @-fexternal-interpreter@ is on. -wormhole :: DynFlags -> ForeignRef a -> IO a -wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r) - --- | Convert an 'RemoteRef' to the value it references directly. This --- only works when the interpreter is running in the same process as --- the compiler, so it fails when @-fexternal-interpreter@ is on. -wormholeRef :: DynFlags -> RemoteRef a -> IO a -wormholeRef dflags _r - | gopt Opt_ExternalInterpreter dflags - = throwIO (InstallationError - "this operation requires -fno-external-interpreter") -#ifdef GHCI - | otherwise - = localRef _r -#else - | otherwise - = throwIO (InstallationError - "can't wormhole a value in a stage1 compiler") -#endif - --- ----------------------------------------------------------------------------- --- Misc utils - -mkEvalOpts :: DynFlags -> Bool -> EvalOpts -mkEvalOpts dflags step = - EvalOpts - { useSandboxThread = gopt Opt_GhciSandbox dflags - , singleStep = step - , breakOnException = gopt Opt_BreakOnException dflags - , breakOnError = gopt Opt_BreakOnError dflags } - -fromEvalResult :: EvalResult a -> IO a -fromEvalResult (EvalException e) = throwIO (fromSerializableException e) -fromEvalResult (EvalSuccess a) = return a diff --git a/ghci/Linker.hs b/ghci/Linker.hs deleted file mode 100644 --- a/ghci/Linker.hs +++ /dev/null @@ -1,1475 +0,0 @@ -{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-} -{-# OPTIONS_GHC -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - --- --- (c) The University of Glasgow 2002-2006 --- --- | The dynamic linker for GHCi. --- --- This module deals with the top-level issues of dynamic linking, --- calling the object-code linker and the byte-code linker where --- necessary. -module Linker ( getHValue, showLinkerState, - linkExpr, linkDecls, unload, withExtendedLinkEnv, - extendLinkEnv, deleteFromLinkEnv, - extendLoadedPkgs, - linkPackages,initDynLinker,linkModule, - linkCmdLineLibs - ) where - -#include "HsVersions.h" - -import GHCi -import GHCi.RemoteTypes -import LoadIface -import ByteCodeLink -import ByteCodeAsm -import ByteCodeTypes -import TcRnMonad -import Packages -import DriverPhases -import Finder -import HscTypes -import Name -import NameEnv -import Module -import ListSetOps -import DynFlags -import BasicTypes -import Outputable -import Panic -import Util -import ErrUtils -import SrcLoc -import qualified Maybes -import UniqDSet -import FastString -import Platform -import SysTools - --- Standard libraries -import Control.Monad -import Control.Applicative((<|>)) - -import Data.IORef -import Data.List -import Data.Maybe -import Control.Concurrent.MVar - -import System.FilePath -import System.Directory - -import Exception - -import Foreign (Ptr) -- needed for 2nd stage - -{- ********************************************************************** - - The Linker's state - - ********************************************************************* -} - -{- -The persistent linker state *must* match the actual state of the -C dynamic linker at all times, so we keep it in a private global variable. - -The global IORef used for PersistentLinkerState actually contains another MVar. -The reason for this is that we want to allow another loaded copy of the GHC -library to side-effect the PLS and for those changes to be reflected here. - -The PersistentLinkerState maps Names to actual closures (for -interpreted code only), for use during linking. --} -#if STAGE < 2 -GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState) -GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised -#else -SHARED_GLOBAL_VAR_M( v_PersistentLinkerState - , getOrSetLibHSghcPersistentLinkerState - , "getOrSetLibHSghcPersistentLinkerState" - , newMVar (panic "Dynamic linker not initialised") - , MVar PersistentLinkerState) --- Set True when dynamic linker is initialised -SHARED_GLOBAL_VAR( v_InitLinkerDone - , getOrSetLibHSghcInitLinkerDone - , "getOrSetLibHSghcInitLinkerDone" - , False - , Bool) -#endif - -modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO () -modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f - -modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a -modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f - -data PersistentLinkerState - = PersistentLinkerState { - - -- Current global mapping from Names to their true values - closure_env :: ClosureEnv, - - -- The current global mapping from RdrNames of DataCons to - -- info table addresses. - -- When a new Unlinked is linked into the running image, or an existing - -- module in the image is replaced, the itbl_env must be updated - -- appropriately. - itbl_env :: !ItblEnv, - - -- The currently loaded interpreted modules (home package) - bcos_loaded :: ![Linkable], - - -- And the currently-loaded compiled modules (home package) - objs_loaded :: ![Linkable], - - -- The currently-loaded packages; always object code - -- Held, as usual, in dependency order; though I am not sure if - -- that is really important - pkgs_loaded :: ![LinkerUnitId], - - -- we need to remember the name of previous temporary DLL/.so - -- libraries so we can link them (see #10322) - temp_sos :: ![(FilePath, String)] } - - -emptyPLS :: DynFlags -> PersistentLinkerState -emptyPLS _ = PersistentLinkerState { - closure_env = emptyNameEnv, - itbl_env = emptyNameEnv, - pkgs_loaded = init_pkgs, - bcos_loaded = [], - objs_loaded = [], - temp_sos = [] } - - -- Packages that don't need loading, because the compiler - -- shares them with the interpreted program. - -- - -- The linker's symbol table is populated with RTS symbols using an - -- explicit list. See rts/Linker.c for details. - where init_pkgs = map toInstalledUnitId [rtsUnitId] - - -extendLoadedPkgs :: [InstalledUnitId] -> IO () -extendLoadedPkgs pkgs = - modifyPLS_ $ \s -> - return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } - -extendLinkEnv :: [(Name,ForeignHValue)] -> IO () -extendLinkEnv new_bindings = - modifyPLS_ $ \pls -> do - let ce = closure_env pls - let new_ce = extendClosureEnv ce new_bindings - return pls{ closure_env = new_ce } - -deleteFromLinkEnv :: [Name] -> IO () -deleteFromLinkEnv to_remove = - modifyPLS_ $ \pls -> do - let ce = closure_env pls - let new_ce = delListFromNameEnv ce to_remove - return pls{ closure_env = new_ce } - --- | Get the 'HValue' associated with the given name. --- --- May cause loading the module that contains the name. --- --- Throws a 'ProgramError' if loading fails or the name cannot be found. -getHValue :: HscEnv -> Name -> IO ForeignHValue -getHValue hsc_env name = do - initDynLinker hsc_env - pls <- modifyPLS $ \pls -> do - if (isExternalName name) then do - (pls', ok) <- linkDependencies hsc_env pls noSrcSpan - [nameModule name] - if (failed ok) then throwGhcExceptionIO (ProgramError "") - else return (pls', pls') - else - return (pls, pls) - case lookupNameEnv (closure_env pls) name of - Just (_,aa) -> return aa - Nothing - -> ASSERT2(isExternalName name, ppr name) - do let sym_to_find = nameToCLabel name "closure" - m <- lookupClosure hsc_env (unpackFS sym_to_find) - case m of - Just hvref -> mkFinalizedHValue hsc_env hvref - Nothing -> linkFail "ByteCodeLink.lookupCE" - (unpackFS sym_to_find) - -linkDependencies :: HscEnv -> PersistentLinkerState - -> SrcSpan -> [Module] - -> IO (PersistentLinkerState, SuccessFlag) -linkDependencies hsc_env pls span needed_mods = do --- initDynLinker (hsc_dflags hsc_env) - let hpt = hsc_HPT hsc_env - dflags = hsc_dflags hsc_env - -- The interpreter and dynamic linker can only handle object code built - -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. - -- So here we check the build tag: if we're building a non-standard way - -- then we need to find & link object files built the "normal" way. - maybe_normal_osuf <- checkNonStdWay dflags span - - -- Find what packages and linkables are required - (lnks, pkgs) <- getLinkDeps hsc_env hpt pls - maybe_normal_osuf span needed_mods - - -- Link the packages and modules required - pls1 <- linkPackages' hsc_env pkgs pls - linkModules hsc_env pls1 lnks - - --- | Temporarily extend the linker state. - -withExtendedLinkEnv :: (ExceptionMonad m) => - [(Name,ForeignHValue)] -> m a -> m a -withExtendedLinkEnv new_env action - = gbracket (liftIO $ extendLinkEnv new_env) - (\_ -> reset_old_env) - (\_ -> action) - where - -- Remember that the linker state might be side-effected - -- during the execution of the IO action, and we don't want to - -- lose those changes (we might have linked a new module or - -- package), so the reset action only removes the names we - -- added earlier. - reset_old_env = liftIO $ do - modifyPLS_ $ \pls -> - let cur = closure_env pls - new = delListFromNameEnv cur (map fst new_env) - in return pls{ closure_env = new } - - --- | Display the persistent linker state. -showLinkerState :: DynFlags -> IO () -showLinkerState dflags - = do pls <- readIORef v_PersistentLinkerState >>= readMVar - putLogMsg dflags NoReason SevDump noSrcSpan - (defaultDumpStyle dflags) - (vcat [text "----- Linker state -----", - text "Pkgs:" <+> ppr (pkgs_loaded pls), - text "Objs:" <+> ppr (objs_loaded pls), - text "BCOs:" <+> ppr (bcos_loaded pls)]) - - -{- ********************************************************************** - - Initialisation - - ********************************************************************* -} - --- | Initialise the dynamic linker. This entails --- --- a) Calling the C initialisation procedure, --- --- b) Loading any packages specified on the command line, --- --- c) Loading any packages specified on the command line, now held in the --- @-l@ options in @v_Opt_l@, --- --- d) Loading any @.o\/.dll@ files specified on the command line, now held --- in @ldInputs@, --- --- e) Loading any MacOS frameworks. --- --- NOTE: This function is idempotent; if called more than once, it does --- nothing. This is useful in Template Haskell, where we call it before --- trying to link. --- -initDynLinker :: HscEnv -> IO () -initDynLinker hsc_env = - modifyPLS_ $ \pls0 -> do - done <- readIORef v_InitLinkerDone - if done then return pls0 - else do writeIORef v_InitLinkerDone True - reallyInitDynLinker hsc_env - -reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState -reallyInitDynLinker hsc_env = do - -- Initialise the linker state - let dflags = hsc_dflags hsc_env - pls0 = emptyPLS dflags - - -- (a) initialise the C dynamic linker - initObjLinker hsc_env - - -- (b) Load packages from the command-line (Note [preload packages]) - pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0 - - -- steps (c), (d) and (e) - linkCmdLineLibs' hsc_env pls - - -linkCmdLineLibs :: HscEnv -> IO () -linkCmdLineLibs hsc_env = do - initDynLinker hsc_env - modifyPLS_ $ \pls -> do - linkCmdLineLibs' hsc_env pls - -linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState -linkCmdLineLibs' hsc_env pls = - do - let dflags@(DynFlags { ldInputs = cmdline_ld_inputs - , libraryPaths = lib_paths}) = hsc_dflags hsc_env - - -- (c) Link libraries from the command-line - let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] - - -- On Windows we want to add libpthread by default just as GCC would. - -- However because we don't know the actual name of pthread's dll we - -- need to defer this to the locateLib call so we can't initialize it - -- inside of the rts. Instead we do it here to be able to find the - -- import library for pthreads. See Trac #13210. - let platform = targetPlatform dflags - os = platformOS platform - minus_ls = case os of - OSMinGW32 -> "pthread" : minus_ls_1 - _ -> minus_ls_1 - - libspecs <- mapM (locateLib hsc_env False lib_paths) minus_ls - - -- (d) Link .o files from the command-line - classified_ld_inputs <- mapM (classifyLdInput dflags) - [ f | FileOption _ f <- cmdline_ld_inputs ] - - -- (e) Link any MacOS frameworks - let platform = targetPlatform dflags - let (framework_paths, frameworks) = - if platformUsesFrameworks platform - then (frameworkPaths dflags, cmdlineFrameworks dflags) - else ([],[]) - - -- Finally do (c),(d),(e) - let cmdline_lib_specs = catMaybes classified_ld_inputs - ++ libspecs - ++ map Framework frameworks - if null cmdline_lib_specs then return pls - else do - - -- Add directories to library search paths, this only has an effect - -- on Windows. On Unix OSes this function is a NOP. - let all_paths = let paths = takeDirectory (fst $ sPgm_c $ settings dflags) - : framework_paths - ++ lib_paths - ++ [ takeDirectory dll | DLLPath dll <- libspecs ] - in nub $ map normalise paths - pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths - - pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls - cmdline_lib_specs - maybePutStr dflags "final link ... " - ok <- resolveObjs hsc_env - - -- DLLs are loaded, reset the search paths - mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache - - if succeeded ok then maybePutStrLn dflags "done" - else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") - - return pls1 - -{- Note [preload packages] - -Why do we need to preload packages from the command line? This is an -explanation copied from #2437: - -I tried to implement the suggestion from #3560, thinking it would be -easy, but there are two reasons we link in packages eagerly when they -are mentioned on the command line: - - * So that you can link in extra object files or libraries that - depend on the packages. e.g. ghc -package foo -lbar where bar is a - C library that depends on something in foo. So we could link in - foo eagerly if and only if there are extra C libs or objects to - link in, but.... - - * Haskell code can depend on a C function exported by a package, and - the normal dependency tracking that TH uses can't know about these - dependencies. The test ghcilink004 relies on this, for example. - -I conclude that we need two -package flags: one that says "this is a -package I want to make available", and one that says "this is a -package I want to link in eagerly". Would that be too complicated for -users? --} - -classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) -classifyLdInput dflags f - | isObjectFilename platform f = return (Just (Object f)) - | isDynLibFilename platform f = return (Just (DLLPath f)) - | otherwise = do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) - (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) - return Nothing - where platform = targetPlatform dflags - -preloadLib - :: HscEnv -> [String] -> [String] -> PersistentLinkerState - -> LibrarySpec -> IO PersistentLinkerState -preloadLib hsc_env lib_paths framework_paths pls lib_spec = do - maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") - case lib_spec of - Object static_ish -> do - (b, pls1) <- preload_static lib_paths static_ish - maybePutStrLn dflags (if b then "done" else "not found") - return pls1 - - Archive static_ish -> do - b <- preload_static_archive lib_paths static_ish - maybePutStrLn dflags (if b then "done" else "not found") - return pls - - DLL dll_unadorned -> do - maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned) - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm | platformOS platform /= OSDarwin -> - preloadFailed mm lib_paths lib_spec - Just mm | otherwise -> do - -- As a backup, on Darwin, try to also load a .so file - -- since (apparently) some things install that way - see - -- ticket #8770. - let libfile = ("lib" ++ dll_unadorned) <.> "so" - err2 <- loadDLL hsc_env libfile - case err2 of - Nothing -> maybePutStrLn dflags "done" - Just _ -> preloadFailed mm lib_paths lib_spec - return pls - - DLLPath dll_path -> do - do maybe_errstr <- loadDLL hsc_env dll_path - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm -> preloadFailed mm lib_paths lib_spec - return pls - - Framework framework -> - if platformUsesFrameworks (targetPlatform dflags) - then do maybe_errstr <- loadFramework hsc_env framework_paths framework - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm -> preloadFailed mm framework_paths lib_spec - return pls - else panic "preloadLib Framework" - - where - dflags = hsc_dflags hsc_env - - platform = targetPlatform dflags - - preloadFailed :: String -> [String] -> LibrarySpec -> IO () - preloadFailed sys_errmsg paths spec - = do maybePutStr dflags "failed.\n" - throwGhcExceptionIO $ - CmdLineError ( - "user specified .o/.so/.DLL could not be loaded (" - ++ sys_errmsg ++ ")\nWhilst trying to load: " - ++ showLS spec ++ "\nAdditional directories searched:" - ++ (if null paths then " (none)" else - intercalate "\n" (map (" "++) paths))) - - -- Not interested in the paths in the static case. - preload_static _paths name - = do b <- doesFileExist name - if not b then return (False, pls) - else if dynamicGhc - then do pls1 <- dynLoadObjs hsc_env pls [name] - return (True, pls1) - else do loadObj hsc_env name - return (True, pls) - - preload_static_archive _paths name - = do b <- doesFileExist name - if not b then return False - else do if dynamicGhc - then panic "Loading archives not supported" - else loadArchive hsc_env name - return True - - -{- ********************************************************************** - - Link a byte-code expression - - ********************************************************************* -} - --- | Link a single expression, /including/ first linking packages and --- modules that this expression depends on. --- --- Raises an IO exception ('ProgramError') if it can't find a compiled --- version of the dependents to link. --- -linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue -linkExpr hsc_env span root_ul_bco - = do { - -- Initialise the linker (if it's not been done already) - ; initDynLinker hsc_env - - -- Take lock for the actual work. - ; modifyPLS $ \pls0 -> do { - - -- Link the packages and modules required - ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods - ; if failed ok then - throwGhcExceptionIO (ProgramError "") - else do { - - -- Link the expression itself - let ie = itbl_env pls - ce = closure_env pls - - -- Link the necessary packages and linkables - - ; let nobreakarray = error "no break array" - bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] - ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco - ; [root_hvref] <- createBCOs hsc_env [resolved] - ; fhv <- mkFinalizedHValue hsc_env root_hvref - ; return (pls, fhv) - }}} - where - free_names = uniqDSetToList (bcoFreeNames root_ul_bco) - - needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, - isExternalName n, -- Names from other modules - not (isWiredInName n) -- Exclude wired-in names - ] -- (see note below) - -- Exclude wired-in names because we may not have read - -- their interface files, so getLinkDeps will fail - -- All wired-in names are in the base package, which we link - -- by default, so we can safely ignore them here. - -dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a -dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) - - -checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath) -checkNonStdWay dflags srcspan - | gopt Opt_ExternalInterpreter dflags = return Nothing - -- with -fexternal-interpreter we load the .o files, whatever way - -- they were built. If they were built for a non-std way, then - -- we will use the appropriate variant of the iserv binary to load them. - - | interpWays == haskellWays = return Nothing - -- Only if we are compiling with the same ways as GHC is built - -- with, can we dynamically load those object files. (see #3604) - - | objectSuf dflags == normalObjectSuffix && not (null haskellWays) - = failNonStd dflags srcspan - - | otherwise = return (Just (interpTag ++ "o")) - where - haskellWays = filter (not . wayRTSOnly) (ways dflags) - interpTag = case mkBuildTag interpWays of - "" -> "" - tag -> tag ++ "_" - -normalObjectSuffix :: String -normalObjectSuffix = phaseInputExt StopLn - -failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) -failNonStd dflags srcspan = dieWith dflags srcspan $ - text "Cannot load" <+> compWay <+> - text "objects when GHC is built" <+> ghciWay $$ - text "To fix this, either:" $$ - text " (1) Use -fexternal-interprter, or" $$ - text " (2) Build the program twice: once" <+> - ghciWay <> text ", and then" $$ - text " with" <+> compWay <+> - text "using -osuf to set a different object file suffix." - where compWay - | WayDyn `elem` ways dflags = text "-dynamic" - | WayProf `elem` ways dflags = text "-prof" - | otherwise = text "normal" - ghciWay - | dynamicGhc = text "with -dynamic" - | rtsIsProfiled = text "with -prof" - | otherwise = text "the normal way" - -getLinkDeps :: HscEnv -> HomePackageTable - -> PersistentLinkerState - -> Maybe FilePath -- replace object suffices? - -> SrcSpan -- for error messages - -> [Module] -- If you need these - -> IO ([Linkable], [InstalledUnitId]) -- ... then link these first --- Fails with an IO exception if it can't find enough files - -getLinkDeps hsc_env hpt pls replace_osuf span mods --- Find all the packages and linkables that a set of modules depends on - = do { - -- 1. Find the dependent home-pkg-modules/packages from each iface - -- (omitting modules from the interactive package, which is already linked) - ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods) - emptyUniqDSet emptyUniqDSet; - - ; let { - -- 2. Exclude ones already linked - -- Main reason: avoid findModule calls in get_linkable - mods_needed = mods_s `minusList` linked_mods ; - pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; - - linked_mods = map (moduleName.linkableModule) - (objs_loaded pls ++ bcos_loaded pls) } - - -- 3. For each dependent module, find its linkable - -- This will either be in the HPT or (in the case of one-shot - -- compilation) we may need to use maybe_getFileLinkable - ; let { osuf = objectSuf dflags } - ; lnks_needed <- mapM (get_linkable osuf) mods_needed - - ; return (lnks_needed, pkgs_needed) } - where - dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags - - -- The ModIface contains the transitive closure of the module dependencies - -- within the current package, *except* for boot modules: if we encounter - -- a boot module, we have to find its real interface and discover the - -- dependencies of that. Hence we need to traverse the dependency - -- tree recursively. See bug #936, testcase ghci/prog007. - follow_deps :: [Module] -- modules to follow - -> UniqDSet ModuleName -- accum. module dependencies - -> UniqDSet InstalledUnitId -- accum. package dependencies - -> IO ([ModuleName], [InstalledUnitId]) -- result - follow_deps [] acc_mods acc_pkgs - = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs) - follow_deps (mod:mods) acc_mods acc_pkgs - = do - mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $ - loadInterface msg mod (ImportByUser False) - iface <- case mb_iface of - Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Maybes.Succeeded iface -> return iface - - when (mi_boot iface) $ link_boot_mod_error mod - - let - pkg = moduleUnitId mod - deps = mi_deps iface - - pkg_deps = dep_pkgs deps - (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps) - where is_boot (m,True) = Left m - is_boot (m,False) = Right m - - boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps - acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps) - acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps - -- - if pkg /= this_pkg - then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg)) - else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) - acc_mods' acc_pkgs' - where - msg = text "need to link module" <+> ppr mod <+> - text "due to use of Template Haskell" - - - link_boot_mod_error mod = - throwGhcExceptionIO (ProgramError (showSDoc dflags ( - text "module" <+> ppr mod <+> - text "cannot be linked; it is only available as a boot module"))) - - no_obj :: Outputable a => a -> IO b - no_obj mod = dieWith dflags span $ - text "cannot find object file for module " <> - quotes (ppr mod) $$ - while_linking_expr - - while_linking_expr = text "while linking an interpreted expression" - - -- This one is a build-system bug - - get_linkable osuf mod_name -- A home-package module - | Just mod_info <- lookupHpt hpt mod_name - = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) - | otherwise - = do -- It's not in the HPT because we are in one shot mode, - -- so use the Finder to get a ModLocation... - mb_stuff <- findHomeModule hsc_env mod_name - case mb_stuff of - Found loc mod -> found loc mod - _ -> no_obj mod_name - where - found loc mod = do { - -- ...and then find the linkable for it - mb_lnk <- findObjectLinkableMaybe mod loc ; - case mb_lnk of { - Nothing -> no_obj mod ; - Just lnk -> adjust_linkable lnk - }} - - adjust_linkable lnk - | Just new_osuf <- replace_osuf = do - new_uls <- mapM (adjust_ul new_osuf) - (linkableUnlinked lnk) - return lnk{ linkableUnlinked=new_uls } - | otherwise = - return lnk - - adjust_ul new_osuf (DotO file) = do - MASSERT(osuf `isSuffixOf` file) - let file_base = fromJust (stripExtension osuf file) - new_file = file_base <.> new_osuf - ok <- doesFileExist new_file - if (not ok) - then dieWith dflags span $ - text "cannot find object file " - <> quotes (text new_file) $$ while_linking_expr - else return (DotO new_file) - adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) - adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) - adjust_ul _ l@(BCOs {}) = return l -#if !MIN_VERSION_filepath(1,4,1) - stripExtension :: String -> FilePath -> Maybe FilePath - stripExtension [] path = Just path - stripExtension ext@(x:_) path = stripSuffix dotExt path - where dotExt = if isExtSeparator x then ext else '.':ext - - stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] - stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys) -#endif - - - -{- ********************************************************************** - - Loading a Decls statement - - ********************************************************************* -} - -linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () -linkDecls hsc_env span cbc@CompiledByteCode{..} = do - -- Initialise the linker (if it's not been done already) - initDynLinker hsc_env - - -- Take lock for the actual work. - modifyPLS $ \pls0 -> do - - -- Link the packages and modules required - (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods - if failed ok - then throwGhcExceptionIO (ProgramError "") - else do - - -- Link the expression itself - let ie = plusNameEnv (itbl_env pls) bc_itbls - ce = closure_env pls - - -- Link the necessary packages and linkables - new_bindings <- linkSomeBCOs hsc_env ie ce [cbc] - nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings - let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs - , itbl_env = ie } - return (pls2, ()) - where - free_names = uniqDSetToList $ - foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos - - needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, - isExternalName n, -- Names from other modules - not (isWiredInName n) -- Exclude wired-in names - ] -- (see note below) - -- Exclude wired-in names because we may not have read - -- their interface files, so getLinkDeps will fail - -- All wired-in names are in the base package, which we link - -- by default, so we can safely ignore them here. - -{- ********************************************************************** - - Loading a single module - - ********************************************************************* -} - -linkModule :: HscEnv -> Module -> IO () -linkModule hsc_env mod = do - initDynLinker hsc_env - modifyPLS_ $ \pls -> do - (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] - if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module") - else return pls' - -{- ********************************************************************** - - Link some linkables - The linkables may consist of a mixture of - byte-code modules and object modules - - ********************************************************************* -} - -linkModules :: HscEnv -> PersistentLinkerState -> [Linkable] - -> IO (PersistentLinkerState, SuccessFlag) -linkModules hsc_env pls linkables - = mask_ $ do -- don't want to be interrupted by ^C in here - - let (objs, bcos) = partition isObjectLinkable - (concatMap partitionLinkable linkables) - - -- Load objects first; they can't depend on BCOs - (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs - - if failed ok_flag then - return (pls1, Failed) - else do - pls2 <- dynLinkBCOs hsc_env pls1 bcos - return (pls2, Succeeded) - - --- HACK to support f-x-dynamic in the interpreter; no other purpose -partitionLinkable :: Linkable -> [Linkable] -partitionLinkable li - = let li_uls = linkableUnlinked li - li_uls_obj = filter isObject li_uls - li_uls_bco = filter isInterpretable li_uls - in - case (li_uls_obj, li_uls_bco) of - (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj}, - li {linkableUnlinked=li_uls_bco}] - _ -> [li] - -findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable -findModuleLinkable_maybe lis mod - = case [LM time nm us | LM time nm us <- lis, nm == mod] of - [] -> Nothing - [li] -> Just li - _ -> pprPanic "findModuleLinkable" (ppr mod) - -linkableInSet :: Linkable -> [Linkable] -> Bool -linkableInSet l objs_loaded = - case findModuleLinkable_maybe objs_loaded (linkableModule l) of - Nothing -> False - Just m -> linkableTime l == linkableTime m - - -{- ********************************************************************** - - The object-code linker - - ********************************************************************* -} - -dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable] - -> IO (PersistentLinkerState, SuccessFlag) -dynLinkObjs hsc_env pls objs = do - -- Load the object files and link them - let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs - pls1 = pls { objs_loaded = objs_loaded' } - unlinkeds = concatMap linkableUnlinked new_objs - wanted_objs = map nameOfObject unlinkeds - - if interpreterDynamic (hsc_dflags hsc_env) - then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs - return (pls2, Succeeded) - else do mapM_ (loadObj hsc_env) wanted_objs - - -- Link them all together - ok <- resolveObjs hsc_env - - -- If resolving failed, unload all our - -- object modules and carry on - if succeeded ok then do - return (pls1, Succeeded) - else do - pls2 <- unload_wkr hsc_env [] pls1 - return (pls2, Failed) - - -dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath] - -> IO PersistentLinkerState -dynLoadObjs _ pls [] = return pls -dynLoadObjs hsc_env pls objs = do - let dflags = hsc_dflags hsc_env - let platform = targetPlatform dflags - let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] - let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] - (soFile, libPath , libName) <- newTempLibName dflags (soExt platform) - let - dflags2 = dflags { - -- We don't want the original ldInputs in - -- (they're already linked in), but we do want - -- to link against previous dynLoadObjs - -- libraries if there were any, so that the linker - -- can resolve dependencies when it loads this - -- library. - ldInputs = - concatMap - (\(lp, l) -> - [ Option ("-L" ++ lp) - , Option "-Xlinker" - , Option "-rpath" - , Option "-Xlinker" - , Option lp - , Option ("-l" ++ l) - ]) - (temp_sos pls) - ++ concatMap - (\lp -> - [ Option ("-L" ++ lp) - , Option "-Xlinker" - , Option "-rpath" - , Option "-Xlinker" - , Option lp - ]) - minus_big_ls - -- See Note [-Xlinker -rpath vs -Wl,-rpath] - ++ map (\l -> Option ("-l" ++ l)) minus_ls, - -- Add -l options and -L options from dflags. - -- - -- When running TH for a non-dynamic way, we still - -- need to make -l flags to link against the dynamic - -- libraries, so we need to add WayDyn to ways. - -- - -- Even if we're e.g. profiling, we still want - -- the vanilla dynamic libraries, so we set the - -- ways / build tag to be just WayDyn. - ways = [WayDyn], - buildTag = mkBuildTag [WayDyn], - outputFile = Just soFile - } - -- link all "loaded packages" so symbols in those can be resolved - -- Note: We are loading packages with local scope, so to see the - -- symbols in this link we must link all loaded packages again. - linkDynLib dflags2 objs (pkgs_loaded pls) - consIORef (filesToNotIntermediateClean dflags) soFile - m <- loadDLL hsc_env soFile - case m of - Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls } - Just err -> panic ("Loading temp shared object failed: " ++ err) - -rmDupLinkables :: [Linkable] -- Already loaded - -> [Linkable] -- New linkables - -> ([Linkable], -- New loaded set (including new ones) - [Linkable]) -- New linkables (excluding dups) -rmDupLinkables already ls - = go already [] ls - where - go already extras [] = (already, extras) - go already extras (l:ls) - | linkableInSet l already = go already extras ls - | otherwise = go (l:already) (l:extras) ls - -{- ********************************************************************** - - The byte-code linker - - ********************************************************************* -} - - -dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable] - -> IO PersistentLinkerState -dynLinkBCOs hsc_env pls bcos = do - - let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos - pls1 = pls { bcos_loaded = bcos_loaded' } - unlinkeds :: [Unlinked] - unlinkeds = concatMap linkableUnlinked new_bcos - - cbcs :: [CompiledByteCode] - cbcs = map byteCodeOfObject unlinkeds - - - ies = map bc_itbls cbcs - gce = closure_env pls - final_ie = foldr plusNameEnv (itbl_env pls) ies - - names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs - - -- We only want to add the external ones to the ClosureEnv - let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs - - -- Immediately release any HValueRefs we're not going to add - freeHValueRefs hsc_env (map snd to_drop) - -- Wrap finalizers on the ones we want to keep - new_binds <- makeForeignNamedHValueRefs hsc_env to_add - - return pls1 { closure_env = extendClosureEnv gce new_binds, - itbl_env = final_ie } - --- Link a bunch of BCOs and return references to their values -linkSomeBCOs :: HscEnv - -> ItblEnv - -> ClosureEnv - -> [CompiledByteCode] - -> IO [(Name,HValueRef)] - -- The returned HValueRefs are associated 1-1 with - -- the incoming unlinked BCOs. Each gives the - -- value of the corresponding unlinked BCO - -linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods [] - where - fun CompiledByteCode{..} inner accum = - case bc_breaks of - Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum) - Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray -> - inner ((breakarray, bc_bcos) : accum) - - do_link [] = return [] - do_link mods = do - let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] - names = map (unlinkedBCOName . snd) flat - bco_ix = mkNameEnv (zip names [0..]) - resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco - | (breakarray, bco) <- flat ] - hvrefs <- createBCOs hsc_env resolved - return (zip names hvrefs) - --- | Useful to apply to the result of 'linkSomeBCOs' -makeForeignNamedHValueRefs - :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)] -makeForeignNamedHValueRefs hsc_env bindings = - mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings - -{- ********************************************************************** - - Unload some object modules - - ********************************************************************* -} - --- --------------------------------------------------------------------------- --- | Unloading old objects ready for a new compilation sweep. --- --- The compilation manager provides us with a list of linkables that it --- considers \"stable\", i.e. won't be recompiled this time around. For --- each of the modules current linked in memory, --- --- * if the linkable is stable (and it's the same one -- the user may have --- recompiled the module on the side), we keep it, --- --- * otherwise, we unload it. --- --- * we also implicitly unload all temporary bindings at this point. --- -unload :: HscEnv - -> [Linkable] -- ^ The linkables to *keep*. - -> IO () -unload hsc_env linkables - = mask_ $ do -- mask, so we're safe from Ctrl-C in here - - -- Initialise the linker (if it's not been done already) - initDynLinker hsc_env - - new_pls - <- modifyPLS $ \pls -> do - pls1 <- unload_wkr hsc_env linkables pls - return (pls1, pls1) - - let dflags = hsc_dflags hsc_env - debugTraceMsg dflags 3 $ - text "unload: retaining objs" <+> ppr (objs_loaded new_pls) - debugTraceMsg dflags 3 $ - text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls) - return () - -unload_wkr :: HscEnv - -> [Linkable] -- stable linkables - -> PersistentLinkerState - -> IO PersistentLinkerState --- Does the core unload business --- (the wrapper blocks exceptions and deals with the PLS get and put) - -unload_wkr hsc_env keep_linkables pls = do - let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables - - discard keep l = not (linkableInSet l keep) - - (objs_to_unload, remaining_objs_loaded) = - partition (discard objs_to_keep) (objs_loaded pls) - (bcos_to_unload, remaining_bcos_loaded) = - partition (discard bcos_to_keep) (bcos_loaded pls) - - mapM_ unloadObjs objs_to_unload - mapM_ unloadObjs bcos_to_unload - - -- If we unloaded any object files at all, we need to purge the cache - -- of lookupSymbol results. - when (not (null (objs_to_unload ++ - filter (not . null . linkableObjs) bcos_to_unload))) $ - purgeLookupSymbolCache hsc_env - - let bcos_retained = map linkableModule remaining_bcos_loaded - - -- Note that we want to remove all *local* - -- (i.e. non-isExternal) names too (these are the - -- temporary bindings from the command line). - keep_name (n,_) = isExternalName n && - nameModule n `elem` bcos_retained - - itbl_env' = filterNameEnv keep_name (itbl_env pls) - closure_env' = filterNameEnv keep_name (closure_env pls) - - new_pls = pls { itbl_env = itbl_env', - closure_env = closure_env', - bcos_loaded = remaining_bcos_loaded, - objs_loaded = remaining_objs_loaded } - - return new_pls - where - unloadObjs :: Linkable -> IO () - unloadObjs lnk - | dynamicGhc = return () - -- We don't do any cleanup when linking objects with the - -- dynamic linker. Doing so introduces extra complexity for - -- not much benefit. - | otherwise - = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk] - -- The components of a BCO linkable may contain - -- dot-o files. Which is very confusing. - -- - -- But the BCO parts can be unlinked just by - -- letting go of them (plus of course depopulating - -- the symbol table which is done in the main body) - -{- ********************************************************************** - - Loading packages - - ********************************************************************* -} - -data LibrarySpec - = Object FilePath -- Full path name of a .o file, including trailing .o - -- For dynamic objects only, try to find the object - -- file in all the directories specified in - -- v_Library_paths before giving up. - - | Archive FilePath -- Full path name of a .a file, including trailing .a - - | DLL String -- "Unadorned" name of a .DLL/.so - -- e.g. On unix "qt" denotes "libqt.so" - -- On Windows "burble" denotes "burble.DLL" or "libburble.dll" - -- loadDLL is platform-specific and adds the lib/.so/.DLL - -- suffixes platform-dependently - - | DLLPath FilePath -- Absolute or relative pathname to a dynamic library - -- (ends with .dll or .so). - - | Framework String -- Only used for darwin, but does no harm - --- If this package is already part of the GHCi binary, we'll already --- have the right DLLs for this package loaded, so don't try to --- load them again. --- --- But on Win32 we must load them 'again'; doing so is a harmless no-op --- as far as the loader is concerned, but it does initialise the list --- of DLL handles that rts/Linker.c maintains, and that in turn is --- used by lookupSymbol. So we must call addDLL for each library --- just to get the DLL handle into the list. -partOfGHCi :: [PackageName] -partOfGHCi - | isWindowsHost || isDarwinHost = [] - | otherwise = map (PackageName . mkFastString) - ["base", "template-haskell", "editline"] - -showLS :: LibrarySpec -> String -showLS (Object nm) = "(static) " ++ nm -showLS (Archive nm) = "(static archive) " ++ nm -showLS (DLL nm) = "(dynamic) " ++ nm -showLS (DLLPath nm) = "(dynamic) " ++ nm -showLS (Framework nm) = "(framework) " ++ nm - --- TODO: Make this type more precise -type LinkerUnitId = InstalledUnitId - --- | Link exactly the specified packages, and their dependents (unless of --- course they are already linked). The dependents are linked --- automatically, and it doesn't matter what order you specify the input --- packages. --- -linkPackages :: HscEnv -> [LinkerUnitId] -> IO () --- NOTE: in fact, since each module tracks all the packages it depends on, --- we don't really need to use the package-config dependencies. --- --- However we do need the package-config stuff (to find aux libs etc), --- and following them lets us load libraries in the right order, which --- perhaps makes the error message a bit more localised if we get a link --- failure. So the dependency walking code is still here. - -linkPackages hsc_env new_pkgs = do - -- It's probably not safe to try to load packages concurrently, so we take - -- a lock. - initDynLinker hsc_env - modifyPLS_ $ \pls -> do - linkPackages' hsc_env new_pkgs pls - -linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState - -> IO PersistentLinkerState -linkPackages' hsc_env new_pks pls = do - pkgs' <- link (pkgs_loaded pls) new_pks - return $! pls { pkgs_loaded = pkgs' } - where - dflags = hsc_dflags hsc_env - - link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId] - link pkgs new_pkgs = - foldM link_one pkgs new_pkgs - - link_one pkgs new_pkg - | new_pkg `elem` pkgs -- Already linked - = return pkgs - - | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg - = do { -- Link dependents first - pkgs' <- link pkgs (depends pkg_cfg) - -- Now link the package itself - ; linkPackage hsc_env pkg_cfg - ; return (new_pkg : pkgs') } - - | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg))) - - -linkPackage :: HscEnv -> PackageConfig -> IO () -linkPackage hsc_env pkg - = do - let dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - dirs | interpreterDynamic dflags = Packages.libraryDynDirs pkg - | otherwise = Packages.libraryDirs pkg - - let hs_libs = Packages.hsLibraries pkg - -- The FFI GHCi import lib isn't needed as - -- compiler/ghci/Linker.hs + rts/Linker.c link the - -- interpreted references to FFI to the compiled FFI. - -- We therefore filter it out so that we don't get - -- duplicate symbol errors. - hs_libs' = filter ("HSffi" /=) hs_libs - - -- Because of slight differences between the GHC dynamic linker and - -- the native system linker some packages have to link with a - -- different list of libraries when using GHCi. Examples include: libs - -- that are actually gnu ld scripts, and the possibility that the .a - -- libs do not exactly match the .so/.dll equivalents. So if the - -- package file provides an "extra-ghci-libraries" field then we use - -- that instead of the "extra-libraries" field. - extra_libs = - (if null (Packages.extraGHCiLibraries pkg) - then Packages.extraLibraries pkg - else Packages.extraGHCiLibraries pkg) - ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] - - hs_classifieds <- mapM (locateLib hsc_env True dirs) hs_libs' - extra_classifieds <- mapM (locateLib hsc_env False dirs) extra_libs - let classifieds = hs_classifieds ++ extra_classifieds - - -- Complication: all the .so's must be loaded before any of the .o's. - let known_dlls = [ dll | DLLPath dll <- classifieds ] - dlls = [ dll | DLL dll <- classifieds ] - objs = [ obj | Object obj <- classifieds ] - archs = [ arch | Archive arch <- classifieds ] - - -- Add directories to library search paths - let dll_paths = map takeDirectory known_dlls - all_paths = nub $ map normalise $ dll_paths ++ dirs - pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths - - maybePutStr dflags - ("Loading package " ++ sourcePackageIdString pkg ++ " ... ") - - -- See comments with partOfGHCi - when (packageName pkg `notElem` partOfGHCi) $ do - loadFrameworks hsc_env platform pkg - mapM_ (load_dyn hsc_env) - (known_dlls ++ map (mkSOName platform) dlls) - - -- After loading all the DLLs, we can load the static objects. - -- Ordering isn't important here, because we do one final link - -- step to resolve everything. - mapM_ (loadObj hsc_env) objs - mapM_ (loadArchive hsc_env) archs - - maybePutStr dflags "linking ... " - ok <- resolveObjs hsc_env - - -- DLLs are loaded, reset the search paths - -- Import libraries will be loaded via loadArchive so only - -- reset the DLL search path after all archives are loaded - -- as well. - mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache - - if succeeded ok - then maybePutStrLn dflags "done." - else let errmsg = "unable to load package `" - ++ sourcePackageIdString pkg ++ "'" - in throwGhcExceptionIO (InstallationError errmsg) - --- we have already searched the filesystem; the strings passed to load_dyn --- can be passed directly to loadDLL. They are either fully-qualified --- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, --- loadDLL is going to search the system paths to find the library. --- -load_dyn :: HscEnv -> FilePath -> IO () -load_dyn hsc_env dll = do - r <- loadDLL hsc_env dll - case r of - Nothing -> return () - Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: " - ++ dll ++ " (" ++ err ++ ")" )) - -loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO () -loadFrameworks hsc_env platform pkg - = when (platformUsesFrameworks platform) $ mapM_ load frameworks - where - fw_dirs = Packages.frameworkDirs pkg - frameworks = Packages.frameworks pkg - - load fw = do r <- loadFramework hsc_env fw_dirs fw - case r of - Nothing -> return () - Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: " - ++ fw ++ " (" ++ err ++ ")" )) - --- Try to find an object file for a given library in the given paths. --- If it isn't present, we assume that addDLL in the RTS can find it, --- which generally means that it should be a dynamic library in the --- standard system search path. --- For GHCi we tend to prefer dynamic libraries over static ones as --- they are easier to load and manage, have less overhead. -locateLib :: HscEnv -> Bool -> [FilePath] -> String -> IO LibrarySpec -locateLib hsc_env is_hs dirs lib - | not is_hs - -- For non-Haskell libraries (e.g. gmp, iconv): - -- first look in library-dirs for a dynamic library (libfoo.so) - -- then look in library-dirs for a static library (libfoo.a) - -- then look in library-dirs and inplace GCC for a dynamic library (libfoo.so) - -- then check for system dynamic libraries (e.g. kernel32.dll on windows) - -- then try looking for import libraries on Windows (.dll.a, .lib) - -- then try "gcc --print-file-name" to search gcc's search path - -- then look in library-dirs and inplace GCC for a static library (libfoo.a) - -- for a dynamic library (#5289) - -- otherwise, assume loadDLL can find it - -- - = findDll `orElse` - findSysDll `orElse` - tryImpLib `orElse` - tryGcc `orElse` - findArchive `orElse` - assumeDll - - | loading_dynamic_hs_libs -- search for .so libraries first. - = findHSDll `orElse` - findDynObject `orElse` - assumeDll - - | loading_profiled_hs_libs -- only a libHSfoo_p.a archive will do. - = findArchive `orElse` - assumeDll - - | otherwise - -- HSfoo.o is the best, but only works for the normal way - -- libHSfoo.a is the backup option. - = findObject `orElse` - findArchive `orElse` - assumeDll - - where - dflags = hsc_dflags hsc_env - - obj_file = lib <.> "o" - dyn_obj_file = lib <.> "dyn_o" - arch_files = [ "lib" ++ lib ++ lib_tag <.> "a" - , lib <.> "a" -- native code has no lib_tag - ] - lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" - - loading_profiled_hs_libs = interpreterProfiled dflags - loading_dynamic_hs_libs = interpreterDynamic dflags - - import_libs = [ lib <.> "lib" , "lib" ++ lib <.> "lib" - , "lib" ++ lib <.> "dll.a", lib <.> "dll.a" - ] - - hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags - hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name - - so_name = mkSOName platform lib - lib_so_name = "lib" ++ so_name - dyn_lib_file = case (arch, os) of - (ArchX86_64, OSSolaris2) -> "64" so_name - _ -> so_name - - findObject = liftM (fmap Object) $ findFile dirs obj_file - findDynObject = liftM (fmap Object) $ findFile dirs dyn_obj_file - findArchive = let local name = liftM (fmap Archive) $ findFile dirs name - linked name = liftM (fmap Archive) $ searchForLibUsingGcc dflags name dirs - check name = apply [local name, linked name] - in apply (map check arch_files) - findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file - findDll = liftM (fmap DLLPath) $ findFile dirs dyn_lib_file - findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ findSystemLibrary hsc_env so_name - tryGcc = let short = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name dirs - full = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs - in liftM2 (<|>) short full - tryImpLib = case os of - OSMinGW32 -> let check name = liftM (fmap Archive) $ searchForLibUsingGcc dflags name dirs - in apply (map check import_libs) - _ -> return Nothing - - assumeDll = return (DLL lib) - infixr `orElse` - f `orElse` g = f >>= maybe g return - - apply [] = return Nothing - apply (x:xs) = do x' <- x - if isJust x' - then return x' - else apply xs - - platform = targetPlatform dflags - arch = platformArch platform - os = platformOS platform - -searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) -searchForLibUsingGcc dflags so dirs = do - -- GCC does not seem to extend the library search path (using -L) when using - -- --print-file-name. So instead pass it a new base location. - str <- askLd dflags (map (FileOption "-B") dirs - ++ [Option "--print-file-name", Option so]) - let file = case lines str of - [] -> "" - l:_ -> l - if (file == so) - then return Nothing - else return (Just file) - --- ---------------------------------------------------------------------------- --- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) - --- Darwin / MacOS X only: load a framework --- a framework is a dynamic library packaged inside a directory of the same --- name. They are searched for in different paths than normal libraries. -loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String) -loadFramework hsc_env extraPaths rootname - = do { either_dir <- tryIO getHomeDirectory - ; let homeFrameworkPath = case either_dir of - Left _ -> [] - Right dir -> [dir "Library/Frameworks"] - ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths - ; mb_fwk <- findFile ps fwk_file - ; case mb_fwk of - Just fwk_path -> loadDLL hsc_env fwk_path - Nothing -> return (Just "not found") } - -- Tried all our known library paths, but dlopen() - -- has no built-in paths for frameworks: give up - where - fwk_file = rootname <.> "framework" rootname - -- sorry for the hardcoded paths, I hope they won't change anytime soon: - defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] - -{- ********************************************************************** - - Helper functions - - ********************************************************************* -} - -maybePutStr :: DynFlags -> String -> IO () -maybePutStr dflags s - = when (verbosity dflags > 1) $ - putLogMsg dflags - NoReason - SevInteractive - noSrcSpan - (defaultUserStyle dflags) - (text s) - -maybePutStrLn :: DynFlags -> String -> IO () -maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") diff --git a/ghci/RtClosureInspect.hs b/ghci/RtClosureInspect.hs deleted file mode 100644 --- a/ghci/RtClosureInspect.hs +++ /dev/null @@ -1,1281 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-} - ------------------------------------------------------------------------------ --- --- GHC Interactive support for inspecting arbitrary closures at runtime --- --- Pepe Iborra (supported by Google SoC) 2006 --- ------------------------------------------------------------------------------ -module RtClosureInspect( - cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term - cvReconstructType, - improveRTTIType, - - Term(..), - isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap, - isFullyEvaluated, isFullyEvaluatedTerm, - termType, mapTermType, termTyCoVars, - foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold, - pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter, - --- unsafeDeepSeq, - - Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection - ) where - -#include "HsVersions.h" - -import DebuggerUtils -import GHCi.RemoteTypes ( HValue ) -import qualified GHCi.InfoTable as InfoTable -import GHCi.InfoTable (StgInfoTable, peekItbl) -import HscTypes - -import DataCon -import Type -import RepType -import qualified Unify as U -import Var -import TcRnMonad -import TcType -import TcMType -import TcHsSyn ( zonkTcTypeToType, mkEmptyZonkEnv ) -import TcUnify -import TcEnv - -import TyCon -import Name -import Util -import VarSet -import BasicTypes ( Boxity(..) ) -import TysPrim -import PrelNames -import TysWiredIn -import DynFlags -import Outputable as Ppr -import GHC.Arr ( Array(..) ) -import GHC.Exts -import GHC.IO ( IO(..) ) - -import Control.Monad -import Data.Maybe -import Data.Array.Base -import Data.Ix -import Data.List -import qualified Data.Sequence as Seq -import Data.Sequence (viewl, ViewL(..)) -import Foreign -import System.IO.Unsafe - ---------------------------------------------- --- * A representation of semi evaluated Terms ---------------------------------------------- - -data Term = Term { ty :: RttiType - , dc :: Either String DataCon - -- Carries a text representation if the datacon is - -- not exported by the .hi file, which is the case - -- for private constructors in -O0 compiled libraries - , val :: HValue - , subTerms :: [Term] } - - | Prim { ty :: RttiType - , value :: [Word] } - - | Suspension { ctype :: ClosureType - , ty :: RttiType - , val :: HValue - , bound_to :: Maybe Name -- Useful for printing - } - | NewtypeWrap{ -- At runtime there are no newtypes, and hence no - -- newtype constructors. A NewtypeWrap is just a - -- made-up tag saying "heads up, there used to be - -- a newtype constructor here". - ty :: RttiType - , dc :: Either String DataCon - , wrapped_term :: Term } - | RefWrap { -- The contents of a reference - ty :: RttiType - , wrapped_term :: Term } - -isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool -isTerm Term{} = True -isTerm _ = False -isSuspension Suspension{} = True -isSuspension _ = False -isPrim Prim{} = True -isPrim _ = False -isNewtypeWrap NewtypeWrap{} = True -isNewtypeWrap _ = False - -isFun Suspension{ctype=Fun} = True -isFun _ = False - -isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty -isFunLike _ = False - -termType :: Term -> RttiType -termType t = ty t - -isFullyEvaluatedTerm :: Term -> Bool -isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt -isFullyEvaluatedTerm Prim {} = True -isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t -isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t -isFullyEvaluatedTerm _ = False - -instance Outputable (Term) where - ppr t | Just doc <- cPprTerm cPprTermBase t = doc - | otherwise = panic "Outputable Term instance" - -------------------------------------------------------------------------- --- Runtime Closure Datatype and functions for retrieving closure related stuff -------------------------------------------------------------------------- -data ClosureType = Constr - | Fun - | Thunk Int - | ThunkSelector - | Blackhole - | AP - | PAP - | Indirection Int - | MutVar Int - | MVar Int - | Other Int - deriving (Show, Eq) - -data Closure = Closure { tipe :: ClosureType - , infoPtr :: Ptr () - , infoTable :: StgInfoTable - , ptrs :: Array Int HValue - , nonPtrs :: [Word] - } - -instance Outputable ClosureType where - ppr = text . show - -#include "rts/storage/ClosureTypes.h" - -aP_CODE, pAP_CODE :: Int -aP_CODE = AP -pAP_CODE = PAP -#undef AP -#undef PAP - -getClosureData :: DynFlags -> a -> IO Closure -getClosureData dflags a = - case unpackClosure# a of - (# iptr, ptrs, nptrs #) -> do - let iptr0 = Ptr iptr - let iptr1 - | ghciTablesNextToCode = iptr0 - | otherwise = - -- the info pointer we get back from unpackClosure# - -- is to the beginning of the standard info table, - -- but the Storable instance for info tables takes - -- into account the extra entry pointer when - -- !ghciTablesNextToCode, so we must adjust here: - iptr0 `plusPtr` negate (wORD_SIZE dflags) - itbl <- peekItbl iptr1 - let tipe = readCType (InfoTable.tipe itbl) - elems = fromIntegral (InfoTable.ptrs itbl) - ptrsList = Array 0 (elems - 1) elems ptrs - nptrs_data = [W# (indexWordArray# nptrs i) - | I# i <- [0.. fromIntegral (InfoTable.nptrs itbl)-1] ] - ASSERT(elems >= 0) return () - ptrsList `seq` - return (Closure tipe iptr0 itbl ptrsList nptrs_data) - -readCType :: Integral a => a -> ClosureType -readCType i - | i >= CONSTR && i <= CONSTR_NOCAF = Constr - | i >= FUN && i <= FUN_STATIC = Fun - | i >= THUNK && i < THUNK_SELECTOR = Thunk i' - | i == THUNK_SELECTOR = ThunkSelector - | i == BLACKHOLE = Blackhole - | i >= IND && i <= IND_STATIC = Indirection i' - | i' == aP_CODE = AP - | i == AP_STACK = AP - | i' == pAP_CODE = PAP - | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i' - | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i' - | otherwise = Other i' - where i' = fromIntegral i - -isConstr, isIndirection, isThunk :: ClosureType -> Bool -isConstr Constr = True -isConstr _ = False - -isIndirection (Indirection _) = True -isIndirection _ = False - -isThunk (Thunk _) = True -isThunk ThunkSelector = True -isThunk AP = True -isThunk _ = False - -isFullyEvaluated :: DynFlags -> a -> IO Bool -isFullyEvaluated dflags a = do - closure <- getClosureData dflags a - case tipe closure of - Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure) - return$ and are_subs_evaluated - _ -> return False - where amapM f = sequence . amap' f - --- TODO: Fix it. Probably the otherwise case is failing, trace/debug it -{- -unsafeDeepSeq :: a -> b -> b -unsafeDeepSeq = unsafeDeepSeq1 2 - where unsafeDeepSeq1 0 a b = seq a $! b - unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks - | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b - -- | unsafePerformIO (isFullyEvaluated a) = b - | otherwise = case unsafePerformIO (getClosureData a) of - closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure) - where tipe = unsafePerformIO (getClosureType a) --} - ------------------------------------ --- * Traversals for Terms ------------------------------------ -type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b - -data TermFold a = TermFold { fTerm :: TermProcessor a a - , fPrim :: RttiType -> [Word] -> a - , fSuspension :: ClosureType -> RttiType -> HValue - -> Maybe Name -> a - , fNewtypeWrap :: RttiType -> Either String DataCon - -> a -> a - , fRefWrap :: RttiType -> a -> a - } - - -data TermFoldM m a = - TermFoldM {fTermM :: TermProcessor a (m a) - , fPrimM :: RttiType -> [Word] -> m a - , fSuspensionM :: ClosureType -> RttiType -> HValue - -> Maybe Name -> m a - , fNewtypeWrapM :: RttiType -> Either String DataCon - -> a -> m a - , fRefWrapM :: RttiType -> a -> m a - } - -foldTerm :: TermFold a -> Term -> a -foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt) -foldTerm tf (Prim ty v ) = fPrim tf ty v -foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b -foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t) -foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t) - - -foldTermM :: Monad m => TermFoldM m a -> Term -> m a -foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v -foldTermM tf (Prim ty v ) = fPrimM tf ty v -foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b -foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc -foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty - -idTermFold :: TermFold Term -idTermFold = TermFold { - fTerm = Term, - fPrim = Prim, - fSuspension = Suspension, - fNewtypeWrap = NewtypeWrap, - fRefWrap = RefWrap - } - -mapTermType :: (RttiType -> Type) -> Term -> Term -mapTermType f = foldTerm idTermFold { - fTerm = \ty dc hval tt -> Term (f ty) dc hval tt, - fSuspension = \ct ty hval n -> - Suspension ct (f ty) hval n, - fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t, - fRefWrap = \ty t -> RefWrap (f ty) t} - -mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term -mapTermTypeM f = foldTermM TermFoldM { - fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt, - fPrimM = (return.) . Prim, - fSuspensionM = \ct ty hval n -> - f ty >>= \ty' -> return $ Suspension ct ty' hval n, - fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t, - fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t} - -termTyCoVars :: Term -> TyCoVarSet -termTyCoVars = foldTerm TermFold { - fTerm = \ty _ _ tt -> - tyCoVarsOfType ty `unionVarSet` concatVarEnv tt, - fSuspension = \_ ty _ _ -> tyCoVarsOfType ty, - fPrim = \ _ _ -> emptyVarSet, - fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t, - fRefWrap = \ty t -> tyCoVarsOfType ty `unionVarSet` t} - where concatVarEnv = foldr unionVarSet emptyVarSet - ----------------------------------- --- Pretty printing of terms ----------------------------------- - -type Precedence = Int -type TermPrinter = Precedence -> Term -> SDoc -type TermPrinterM m = Precedence -> Term -> m SDoc - -app_prec,cons_prec, max_prec ::Int -max_prec = 10 -app_prec = max_prec -cons_prec = 5 -- TODO Extract this info from GHC itself - -pprTerm :: TermPrinter -> TermPrinter -pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc -pprTerm _ _ _ = panic "pprTerm" - -pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m -pprTermM y p t = pprDeeper `liftM` ppr_termM y p t - -ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do - tt_docs <- mapM (y app_prec) tt - return $ cparen (not (null tt) && p >= app_prec) - (text dc_tag <+> pprDeeperList fsep tt_docs) - -ppr_termM y p Term{dc=Right dc, subTerms=tt} = do -{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity - = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) - <+> hsep (map (ppr_term1 True) tt) --} -- TODO Printing infix constructors properly - tt_docs' <- mapM (y app_prec) tt - return $ sdocWithPprDebug $ \dbg -> - -- Don't show the dictionary arguments to - -- constructors unless -dppr-debug is on - let tt_docs = if dbg - then tt_docs' - else dropList (dataConTheta dc) tt_docs' - in if null tt_docs - then ppr dc - else cparen (p >= app_prec) $ - sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] - -ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t -ppr_termM y p RefWrap{wrapped_term=t} = do - contents <- y app_prec t - return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents) - -- The constructor name is wired in here ^^^ for the sake of simplicity. - -- I don't think mutvars are going to change in a near future. - -- In any case this is solely a presentation matter: MutVar# is - -- a datatype with no constructors, implemented by the RTS - -- (hence there is no way to obtain a datacon and print it). -ppr_termM _ _ t = ppr_termM1 t - - -ppr_termM1 :: Monad m => Term -> m SDoc -ppr_termM1 Prim{value=words, ty=ty} = - return $ repPrim (tyConAppTyCon ty) words -ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = - return (char '_' <+> ifPprDebug (text "::" <> ppr ty)) -ppr_termM1 Suspension{ty=ty, bound_to=Just n} --- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("") - | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty -ppr_termM1 Term{} = panic "ppr_termM1 - Term" -ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap" -ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap" - -pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} - | Just (tc,_) <- tcSplitTyConApp_maybe ty - , ASSERT(isNewTyCon tc) True - , Just new_dc <- tyConSingleDataCon_maybe tc = do - real_term <- y max_prec t - return $ cparen (p >= app_prec) (ppr new_dc <+> real_term) -pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" - -------------------------------------------------------- --- Custom Term Pretty Printers -------------------------------------------------------- - --- We can want to customize the representation of a --- term depending on its type. --- However, note that custom printers have to work with --- type representations, instead of directly with types. --- We cannot use type classes here, unless we employ some --- typerep trickery (e.g. Weirich's RepLib tricks), --- which I didn't. Therefore, this code replicates a lot --- of what type classes provide for free. - -type CustomTermPrinter m = TermPrinterM m - -> [Precedence -> Term -> (m (Maybe SDoc))] - --- | Takes a list of custom printers with a explicit recursion knot and a term, --- and returns the output of the first successful printer, or the default printer -cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc -cPprTerm printers_ = go 0 where - printers = printers_ go - go prec t = do - let default_ = Just `liftM` pprTermM go prec t - mb_customDocs = [pp prec t | pp <- printers] ++ [default_] - Just doc <- firstJustM mb_customDocs - return$ cparen (prec>app_prec+1) doc - - firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just) - firstJustM [] = return Nothing - --- Default set of custom printers. Note that the recursion knot is explicit -cPprTermBase :: forall m. Monad m => CustomTermPrinter m -cPprTermBase y = - [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) - . mapM (y (-1)) - . subTerms) - , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) - ppr_list - , ifTerm (isTyCon intTyCon . ty) ppr_int - , ifTerm (isTyCon charTyCon . ty) ppr_char - , ifTerm (isTyCon floatTyCon . ty) ppr_float - , ifTerm (isTyCon doubleTyCon . ty) ppr_double - , ifTerm (isIntegerTy . ty) ppr_integer - ] - where - ifTerm :: (Term -> Bool) - -> (Precedence -> Term -> m SDoc) - -> Precedence -> Term -> m (Maybe SDoc) - ifTerm pred f prec t@Term{} - | pred t = Just `liftM` f prec t - ifTerm _ _ _ _ = return Nothing - - isTupleTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (isBoxedTupleTyCon tc) - - isTyCon a_tc ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (a_tc == tc) - - isIntegerTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (tyConName tc == integerTyConName) - - ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer - :: Precedence -> Term -> m SDoc - ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v))) - ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'') - ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v))) - ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v))) - ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v))) - - --Note pprinting of list terms is not lazy - ppr_list :: Precedence -> Term -> m SDoc - ppr_list p (Term{subTerms=[h,t]}) = do - let elems = h : getListTerms t - isConsLast = not (termType (last elems) `eqType` termType h) - is_string = all (isCharTy . ty) elems - - print_elems <- mapM (y cons_prec) elems - if is_string - then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems)))) - else if isConsLast - then return $ cparen (p >= cons_prec) - $ pprDeeperList fsep - $ punctuate (space<>colon) print_elems - else return $ brackets - $ pprDeeperList fcat - $ punctuate comma print_elems - - where getListTerms Term{subTerms=[h,t]} = h : getListTerms t - getListTerms Term{subTerms=[]} = [] - getListTerms t@Suspension{} = [t] - getListTerms t = pprPanic "getListTerms" (ppr t) - ppr_list _ _ = panic "doList" - - -repPrim :: TyCon -> [Word] -> SDoc -repPrim t = rep where - rep x - | t == charPrimTyCon = text $ show (build x :: Char) - | t == intPrimTyCon = text $ show (build x :: Int) - | t == wordPrimTyCon = text $ show (build x :: Word) - | t == floatPrimTyCon = text $ show (build x :: Float) - | t == doublePrimTyCon = text $ show (build x :: Double) - | t == int32PrimTyCon = text $ show (build x :: Int32) - | t == word32PrimTyCon = text $ show (build x :: Word32) - | t == int64PrimTyCon = text $ show (build x :: Int64) - | t == word64PrimTyCon = text $ show (build x :: Word64) - | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x) - | t == stablePtrPrimTyCon = text "" - | t == stableNamePrimTyCon = text "" - | t == statePrimTyCon = text "" - | t == proxyPrimTyCon = text "" - | t == realWorldTyCon = text "" - | t == threadIdPrimTyCon = text "" - | t == weakPrimTyCon = text "" - | t == arrayPrimTyCon = text "" - | t == smallArrayPrimTyCon = text "" - | t == byteArrayPrimTyCon = text "" - | t == mutableArrayPrimTyCon = text "" - | t == smallMutableArrayPrimTyCon = text "" - | t == mutableByteArrayPrimTyCon = text "" - | t == mutVarPrimTyCon = text "" - | t == mVarPrimTyCon = text "" - | t == tVarPrimTyCon = text "" - | otherwise = char '<' <> ppr t <> char '>' - where build ww = unsafePerformIO $ withArray ww (peek . castPtr) --- This ^^^ relies on the representation of Haskell heap values being --- the same as in a C array. - ------------------------------------ --- Type Reconstruction ------------------------------------ -{- -Type Reconstruction is type inference done on heap closures. -The algorithm walks the heap generating a set of equations, which -are solved with syntactic unification. -A type reconstruction equation looks like: - - = - -The full equation set is generated by traversing all the subterms, starting -from a given term. - -The only difficult part is that newtypes are only found in the lhs of equations. -Right hand sides are missing them. We can either (a) drop them from the lhs, or -(b) reconstruct them in the rhs when possible. - -The function congruenceNewtypes takes a shot at (b) --} - - --- A (non-mutable) tau type containing --- existentially quantified tyvars. --- (since GHC type language currently does not support --- existentials, we leave these variables unquantified) -type RttiType = Type - --- An incomplete type as stored in GHCi: --- no polymorphism: no quantifiers & all tyvars are skolem. -type GhciType = Type - - --- The Type Reconstruction monad --------------------------------- -type TR a = TcM a - -runTR :: HscEnv -> TR a -> IO a -runTR hsc_env thing = do - mb_val <- runTR_maybe hsc_env thing - case mb_val of - Nothing -> error "unable to :print the term" - Just x -> return x - -runTR_maybe :: HscEnv -> TR a -> IO (Maybe a) -runTR_maybe hsc_env thing_inside - = do { (_errs, res) <- initTcInteractive hsc_env thing_inside - ; return res } - --- | Term Reconstruction trace -traceTR :: SDoc -> TR () -traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti - - --- Semantically different to recoverM in TcRnMonad --- recoverM retains the errors in the first action, --- whereas recoverTc here does not -recoverTR :: TR a -> TR a -> TR a -recoverTR = tryTcDiscardingErrs - -trIO :: IO a -> TR a -trIO = liftTcM . liftIO - -liftTcM :: TcM a -> TR a -liftTcM = id - -newVar :: Kind -> TR TcType -newVar = liftTcM . newFlexiTyVarTy - -newOpenVar :: TR TcType -newOpenVar = liftTcM newOpenFlexiTyVarTy - -instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar]) --- Instantiate fresh mutable type variables from some TyVars --- This function preserves the print-name, which helps error messages -instTyVars tvs - = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs) - -type RttiInstantiation = [(TcTyVar, TyVar)] - -- Associates the typechecker-world meta type variables - -- (which are mutable and may be refined), to their - -- debugger-world RuntimeUnk counterparts. - -- If the TcTyVar has not been refined by the runtime type - -- elaboration, then we want to turn it back into the - -- original RuntimeUnk - --- | Returns the instantiated type scheme ty', and the --- mapping from new (instantiated) -to- old (skolem) type variables -instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation) -instScheme (tvs, ty) - = do { (subst, tvs') <- instTyVars tvs - ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] - ; return (substTy subst ty, rtti_inst) } - -applyRevSubst :: RttiInstantiation -> TR () --- Apply the *reverse* substitution in-place to any un-filled-in --- meta tyvars. This recovers the original debugger-world variable --- unless it has been refined by new information from the heap -applyRevSubst pairs = liftTcM (mapM_ do_pair pairs) - where - do_pair (tc_tv, rtti_tv) - = do { tc_ty <- zonkTcTyVar tc_tv - ; case tcGetTyVar_maybe tc_ty of - Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv) - _ -> return () } - --- Adds a constraint of the form t1 == t2 --- t1 is expected to come from walking the heap --- t2 is expected to come from a datacon signature --- Before unification, congruenceNewtypes needs to --- do its magic. -addConstraint :: TcType -> TcType -> TR () -addConstraint actual expected = do - traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected]) - recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual, - text "with", ppr expected]) $ - discardResult $ - captureConstraints $ - do { (ty1, ty2) <- congruenceNewtypes actual expected - ; unifyType noThing ty1 ty2 } - -- TOMDO: what about the coercion? - -- we should consider family instances - --- Type & Term reconstruction ------------------------------- -cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term -cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do - -- we quantify existential tyvars as universal, - -- as this is needed to be able to manipulate - -- them properly - let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty - sigma_old_ty = mkInvForAllTys old_tvs old_tau - traceTR (text "Term reconstruction started with initial type " <> ppr old_ty) - term <- - if null old_tvs - then do - term <- go max_depth sigma_old_ty sigma_old_ty hval - term' <- zonkTerm term - return $ fixFunDictionaries $ expandNewtypes term' - else do - (old_ty', rev_subst) <- instScheme quant_old_ty - my_ty <- newOpenVar - when (check1 quant_old_ty) (traceTR (text "check1 passed") >> - addConstraint my_ty old_ty') - term <- go max_depth my_ty sigma_old_ty hval - new_ty <- zonkTcType (termType term) - if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty - then do - traceTR (text "check2 passed") - addConstraint new_ty old_ty' - applyRevSubst rev_subst - zterm' <- zonkTerm term - return ((fixFunDictionaries . expandNewtypes) zterm') - else do - traceTR (text "check2 failed" <+> parens - (ppr term <+> text "::" <+> ppr new_ty)) - -- we have unsound types. Replace constructor types in - -- subterms with tyvars - zterm' <- mapTermTypeM - (\ty -> case tcSplitTyConApp_maybe ty of - Just (tc, _:_) | tc /= funTyCon - -> newOpenVar - _ -> return ty) - term - zonkTerm zterm' - traceTR (text "Term reconstruction completed." $$ - text "Term obtained: " <> ppr term $$ - text "Type obtained: " <> ppr (termType term)) - return term - where - dflags = hsc_dflags hsc_env - - go :: Int -> Type -> Type -> HValue -> TcM Term - -- I believe that my_ty should not have any enclosing - -- foralls, nor any free RuntimeUnk skolems; - -- that is partly what the quantifyType stuff achieved - -- - -- [SPJ May 11] I don't understand the difference between my_ty and old_ty - - go 0 my_ty _old_ty a = do - traceTR (text "Gave up reconstructing a term after" <> - int max_depth <> text " steps") - clos <- trIO $ getClosureData dflags a - return (Suspension (tipe clos) my_ty a Nothing) - go !max_depth my_ty old_ty a = do - let monomorphic = not(isTyVarTy my_ty) - -- This ^^^ is a convention. The ancestor tests for - -- monomorphism and passes a type instead of a tv - clos <- trIO $ getClosureData dflags a - case tipe clos of --- Thunks we may want to force - t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >> - seq a (go (pred max_depth) my_ty old_ty a) --- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we --- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up --- showing '_' which is what we want. - Blackhole -> do traceTR (text "Following a BLACKHOLE") - appArr (go max_depth my_ty old_ty) (ptrs clos) 0 --- We always follow indirections - Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) ) - go max_depth my_ty old_ty $! (ptrs clos ! 0) --- We also follow references - MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty - -> do - -- Deal with the MutVar# primitive - -- It does not have a constructor at all, - -- so we simulate the following one - -- MutVar# :: contents_ty -> MutVar# s contents_ty - traceTR (text "Following a MutVar") - contents_tv <- newVar liftedTypeKind - contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w - ASSERT(isUnliftedType my_ty) return () - (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy - contents_ty (mkTyConApp tycon [world,contents_ty]) - addConstraint (mkFunTy contents_tv my_ty) mutvar_ty - x <- go (pred max_depth) contents_tv contents_ty contents - return (RefWrap my_ty x) - - -- The interesting case - Constr -> do - traceTR (text "entering a constructor " <> - if monomorphic - then parens (text "already monomorphic: " <> ppr my_ty) - else Ppr.empty) - Right dcname <- dataConInfoPtrToName (infoPtr clos) - (_,mb_dc) <- tryTc (tcLookupDataCon dcname) - case mb_dc of - Nothing -> do -- This can happen for private constructors compiled -O0 - -- where the .hi descriptor does not export them - -- In such case, we return a best approximation: - -- ignore the unpointed args, and recover the pointeds - -- This preserves laziness, and should be safe. - traceTR (text "Not constructor" <+> ppr dcname) - let dflags = hsc_dflags hsc_env - tag = showPpr dflags dcname - vars <- replicateM (length$ elems$ ptrs clos) - (newVar liftedTypeKind) - subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i - | (i, tv) <- zip [0..] vars] - return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) - Just dc -> do - traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty)) - subTtypes <- getDataConArgTys dc my_ty - subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes - return (Term my_ty (Right dc) a subTerms) - --- The otherwise case: can be a Thunk,AP,PAP,etc. - tipe_clos -> do - traceTR (text "Unknown closure:" <+> ppr tipe_clos) - return (Suspension tipe_clos my_ty a Nothing) - - -- insert NewtypeWraps around newtypes - expandNewtypes = foldTerm idTermFold { fTerm = worker } where - worker ty dc hval tt - | Just (tc, args) <- tcSplitTyConApp_maybe ty - , isNewTyCon tc - , wrapped_type <- newTyConInstRhs tc args - , Just dc' <- tyConSingleDataCon_maybe tc - , t' <- worker wrapped_type dc hval tt - = NewtypeWrap ty (Right dc') t' - | otherwise = Term ty dc hval tt - - - -- Avoid returning types where predicates have been expanded to dictionaries. - fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where - worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n - | otherwise = Suspension ct ty hval n - -extractSubTerms :: (Type -> HValue -> TcM Term) - -> Closure -> [Type] -> TcM [Term] -extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos) - where - go ptr_i ws [] = return (ptr_i, ws, []) - go ptr_i ws (ty:tys) - | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty - , isUnboxedTupleTyCon tc - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - = do (ptr_i, ws, terms0) <- go ptr_i ws (dropRuntimeRepArgs elem_tys) - (ptr_i, ws, terms1) <- go ptr_i ws tys - return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) - | otherwise - = case typePrimRepArgs ty of - [rep_ty] -> do - (ptr_i, ws, term0) <- go_rep ptr_i ws ty rep_ty - (ptr_i, ws, terms1) <- go ptr_i ws tys - return (ptr_i, ws, term0 : terms1) - rep_tys -> do - (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys - (ptr_i, ws, terms1) <- go ptr_i ws tys - return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) - - go_unary_types ptr_i ws [] = return (ptr_i, ws, []) - go_unary_types ptr_i ws (rep_ty:rep_tys) = do - tv <- newVar liftedTypeKind - (ptr_i, ws, term0) <- go_rep ptr_i ws tv rep_ty - (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys - return (ptr_i, ws, term0 : terms1) - - go_rep ptr_i ws ty rep - | isGcPtrRep rep - = do t <- appArr (recurse ty) (ptrs clos) ptr_i - return (ptr_i + 1, ws, t) - | otherwise - = do dflags <- getDynFlags - let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws - return (ptr_i, ws1, Prim ty ws0) - - unboxedTupleTerm ty terms - = Term ty (Right (tupleDataCon Unboxed (length terms))) - (error "unboxedTupleTerm: no HValue for unboxed tuple") terms - - --- Fast, breadth-first Type reconstruction ------------------------------------------- -cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type) -cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do - traceTR (text "RTTI started with initial type " <> ppr old_ty) - let sigma_old_ty@(old_tvs, _) = quantifyType old_ty - new_ty <- - if null old_tvs - then return old_ty - else do - (old_ty', rev_subst) <- instScheme sigma_old_ty - my_ty <- newOpenVar - when (check1 sigma_old_ty) (traceTR (text "check1 passed") >> - addConstraint my_ty old_ty') - search (isMonomorphic `fmap` zonkTcType my_ty) - (\(ty,a) -> go ty a) - (Seq.singleton (my_ty, hval)) - max_depth - new_ty <- zonkTcType my_ty - if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty - then do - traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty) - addConstraint my_ty old_ty' - applyRevSubst rev_subst - zonkRttiType new_ty - else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >> - return old_ty - traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty) - return new_ty - where - dflags = hsc_dflags hsc_env - --- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m () - search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> - int max_depth <> text " steps") - search stop expand l d = - case viewl l of - EmptyL -> return () - x :< xx -> unlessM stop $ do - new <- expand x - search stop expand (xx `mappend` Seq.fromList new) $! (pred d) - - -- returns unification tasks,since we are going to want a breadth-first search - go :: Type -> HValue -> TR [(Type, HValue)] - go my_ty a = do - traceTR (text "go" <+> ppr my_ty) - clos <- trIO $ getClosureData dflags a - case tipe clos of - Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO - Indirection _ -> go my_ty $! (ptrs clos ! 0) - MutVar _ -> do - contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w - tv' <- newVar liftedTypeKind - world <- newVar liftedTypeKind - addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv']) - return [(tv', contents)] - Constr -> do - Right dcname <- dataConInfoPtrToName (infoPtr clos) - traceTR (text "Constr1" <+> ppr dcname) - (_,mb_dc) <- tryTc (tcLookupDataCon dcname) - case mb_dc of - Nothing-> do - forM (elems $ ptrs clos) $ \a -> do - tv <- newVar liftedTypeKind - return (tv, a) - - Just dc -> do - arg_tys <- getDataConArgTys dc my_ty - (_, itys) <- findPtrTyss 0 arg_tys - traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) - return $ [ appArr (\e-> (ty,e)) (ptrs clos) i - | (i,ty) <- itys] - _ -> return [] - -findPtrTys :: Int -- Current pointer index - -> Type -- Type - -> TR (Int, [(Int, Type)]) -findPtrTys i ty - | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty - , isUnboxedTupleTyCon tc - = findPtrTyss i elem_tys - - | otherwise - = case typePrimRep ty of - [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)]) - | otherwise -> return (i, []) - prim_reps -> - foldM (\(i, extras) prim_rep -> - if isGcPtrRep prim_rep - then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)]) - else return (i, extras)) - (i, []) prim_reps - -findPtrTyss :: Int - -> [Type] - -> TR (Int, [(Int, Type)]) -findPtrTyss i tys = foldM step (i, []) tys - where step (i, discovered) elem_ty = do - (i, extras) <- findPtrTys i elem_ty - return (i, discovered ++ extras) - - --- Compute the difference between a base type and the type found by RTTI --- improveType --- The types can contain skolem type variables, which need to be treated as normal vars. --- In particular, we want them to unify with things. -improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst -improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty - -getDataConArgTys :: DataCon -> Type -> TR [Type] --- Given the result type ty of a constructor application (D a b c :: ty) --- return the types of the arguments. This is RTTI-land, so 'ty' might --- not be fully known. Moreover, the arg types might involve existentials; --- if so, make up fresh RTTI type variables for them --- --- I believe that con_app_ty should not have any enclosing foralls -getDataConArgTys dc con_app_ty - = do { let rep_con_app_ty = unwrapType con_app_ty - ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty - $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty))) - ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs) - ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) - -- See Note [Constructor arg types] - ; let con_arg_tys = substTys subst (dataConRepArgTys dc) - ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst)) - ; return con_arg_tys } - where - univ_tvs = dataConUnivTyVars dc - ex_tvs = dataConExTyVars dc - -{- Note [Constructor arg types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a GADT (cf Trac #7386) - data family D a b - data instance D [a] a where - MkT :: a -> D [a] (Maybe a) - ... - -In getDataConArgTys -* con_app_ty is the known type (from outside) of the constructor application, - say D [Int] Int - -* The data constructor MkT has a (representation) dataConTyCon = DList, - say where - data DList a where - MkT :: a -> DList a (Maybe a) - ... - -So the dataConTyCon of the data constructor, DList, differs from -the "outside" type, D. So we can't straightforwardly decompose the -"outside" type, and we end up in the "_" branch of the case. - -Then we match the dataConOrigResTy of the data constructor against the -outside type, hoping to get a substitution that tells how to instantiate -the *representation* type constructor. This looks a bit delicate to -me, but it seems to work. --} - --- Soundness checks --------------------- -{- -This is not formalized anywhere, so hold to your seats! -RTTI in the presence of newtypes can be a tricky and unsound business. - -Example: -~~~~~~~~~ -Suppose we are doing RTTI for a partially evaluated -closure t, the real type of which is t :: MkT Int, for - - newtype MkT a = MkT [Maybe a] - -The table below shows the results of RTTI and the improvement -calculated for different combinations of evaluatedness and :type t. -Regard the two first columns as input and the next two as output. - - # | t | :type t | rtti(t) | improv. | result - ------------------------------------------------------------ - 1 | _ | t b | a | none | OK - 2 | _ | MkT b | a | none | OK - 3 | _ | t Int | a | none | OK - - If t is not evaluated at *all*, we are safe. - - 4 | (_ : _) | t b | [a] | t = [] | UNSOUND - 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype) - 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND - - If a is a minimal whnf, we run into trouble. Note that - row 5 above does newtype enrichment on the ty_rtty parameter. - - 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND - | | | b = Maybe a| - - 8 | (Just _:_)| MkT b | MkT a | none | OK - 9 | (Just _:_)| t Int | FAIL | none | OK - - And if t is any more evaluated than whnf, we are still in trouble. - Because constraints are solved in top-down order, when we reach the - Maybe subterm what we got is already unsound. This explains why the - row 9 fails to complete. - - 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK - 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK - - We can undo the failure in row 9 by leaving out the constraint - coming from the type signature of t (i.e., the 2nd column). - Note that this type information is still used - to calculate the improvement. But we fail - when trying to calculate the improvement, as there is no unifier for - t Int = [Maybe a] or t Int = [Maybe Int]. - - - Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]] - - # | t | :type t | rtti(t) | improvement | result - --------------------------------------------------------------------- - 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] | - | | | | b = Maybe a | - -The checks: -~~~~~~~~~~~ -Consider a function obtainType that takes a value and a type and produces -the Term representation and a substitution (the improvement). -Assume an auxiliar rtti' function which does the actual job if recovering -the type, but which may produce a false type. - -In pseudocode: - - rtti' :: a -> IO Type -- Does not use the static type information - - obtainType :: a -> Type -> IO (Maybe (Term, Improvement)) - obtainType v old_ty = do - rtti_ty <- rtti' v - if monomorphic rtti_ty || (check rtti_ty old_ty) - then ... - else return Nothing - where check rtti_ty old_ty = check1 rtti_ty && - check2 rtti_ty old_ty - - check1 :: Type -> Bool - check2 :: Type -> Type -> Bool - -Now, if rtti' returns a monomorphic type, we are safe. -If that is not the case, then we consider two conditions. - - -1. To prevent the class of unsoundness displayed by - rows 4 and 7 in the example: no higher kind tyvars - accepted. - - check1 (t a) = NO - check1 (t Int) = NO - check1 ([] a) = YES - -2. To prevent the class of unsoundness shown by row 6, - the rtti type should be structurally more - defined than the old type we are comparing it to. - check2 :: NewType -> OldType -> Bool - check2 a _ = True - check2 [a] a = True - check2 [a] (t Int) = False - check2 [a] (t a) = False -- By check1 we never reach this equation - check2 [Int] a = True - check2 [Int] (t Int) = True - check2 [Maybe a] (t Int) = False - check2 [Maybe Int] (t Int) = True - check2 (Maybe [a]) (m [Int]) = False - check2 (Maybe [Int]) (m [Int]) = True - --} - -check1 :: QuantifiedType -> Bool -check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs) - where - isHigherKind = not . null . fst . splitPiTys - -check2 :: QuantifiedType -> QuantifiedType -> Bool -check2 (_, rtti_ty) (_, old_ty) - | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty - = case () of - _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty - -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds) - _ | Just _ <- splitAppTy_maybe old_ty - -> isMonomorphicOnNonPhantomArgs rtti_ty - _ -> True - | otherwise = True - --- Dealing with newtypes --------------------------- -{- - congruenceNewtypes does a parallel fold over two Type values, - compensating for missing newtypes on both sides. - This is necessary because newtypes are not present - in runtime, but sometimes there is evidence available. - Evidence can come from DataCon signatures or - from compile-time type inference. - What we are doing here is an approximation - of unification modulo a set of equations derived - from newtype definitions. These equations should be the - same as the equality coercions generated for newtypes - in System Fc. The idea is to perform a sort of rewriting, - taking those equations as rules, before launching unification. - - The caller must ensure the following. - The 1st type (lhs) comes from the heap structure of ptrs,nptrs. - The 2nd type (rhs) comes from a DataCon type signature. - Rewriting (i.e. adding/removing a newtype wrapper) can happen - in both types, but in the rhs it is restricted to the result type. - - Note that it is very tricky to make this 'rewriting' - work with the unification implemented by TcM, where - substitutions are operationally inlined. The order in which - constraints are unified is vital as we cannot modify - anything that has been touched by a previous unification step. -Therefore, congruenceNewtypes is sound only if the types -recovered by the RTTI mechanism are unified Top-Down. --} -congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType) -congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') - where - go l r - -- TyVar lhs inductive case - | Just tv <- getTyVar_maybe l - , isTcTyVar tv - , isMetaTyVar tv - = recoverTR (return r) $ do - Indirect ty_v <- readMetaTyVar tv - traceTR $ fsep [text "(congruence) Following indirect tyvar:", - ppr tv, equals, ppr ty_v] - go ty_v r --- FunTy inductive case - | Just (l1,l2) <- splitFunTy_maybe l - , Just (r1,r2) <- splitFunTy_maybe r - = do r2' <- go l2 r2 - r1' <- go l1 r1 - return (mkFunTy r1' r2') --- TyconApp Inductive case; this is the interesting bit. - | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs - , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs - , tycon_l /= tycon_r - = upgrade tycon_l r - - | otherwise = return r - - where upgrade :: TyCon -> Type -> TR Type - upgrade new_tycon ty - | not (isNewTyCon new_tycon) = do - traceTR (text "(Upgrade) Not matching newtype evidence: " <> - ppr new_tycon <> text " for " <> ppr ty) - return ty - | otherwise = do - traceTR (text "(Upgrade) upgraded " <> ppr ty <> - text " in presence of newtype evidence " <> ppr new_tycon) - (_, vars) <- instTyVars (tyConTyVars new_tycon) - let ty' = mkTyConApp new_tycon (mkTyVarTys vars) - rep_ty = unwrapType ty' - _ <- liftTcM (unifyType noThing ty rep_ty) - -- assumes that reptype doesn't ^^^^ touch tyconApp args - return ty' - - -zonkTerm :: Term -> TcM Term -zonkTerm = foldTermM (TermFoldM - { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' -> - return (Term ty' dc v tt) - , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty -> - return (Suspension ct ty v b) - , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' -> - return$ NewtypeWrap ty' dc t - , fRefWrapM = \ty t -> return RefWrap `ap` - zonkRttiType ty `ap` return t - , fPrimM = (return.) . Prim }) - -zonkRttiType :: TcType -> TcM Type --- Zonk the type, replacing any unbound Meta tyvars --- by skolems, safely out of Meta-tyvar-land -zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta) - where - zonk_unbound_meta tv - = ASSERT( isTcTyVar tv ) - do { tv' <- skolemiseRuntimeUnk tv - -- This is where RuntimeUnks are born: - -- otherwise-unconstrained unification variables are - -- turned into RuntimeUnks as they leave the - -- typechecker's monad - ; return (mkTyVarTy tv') } - --------------------------------------------------------------------------------- --- Restore Class predicates out of a representation type -dictsView :: Type -> Type -dictsView ty = ty - - --- Use only for RTTI types -isMonomorphic :: RttiType -> Bool -isMonomorphic ty = noExistentials && noUniversals - where (tvs, _, ty') = tcSplitSigmaTy ty - noExistentials = noFreeVarsOfType ty' - noUniversals = null tvs - --- Use only for RTTI types -isMonomorphicOnNonPhantomArgs :: RttiType -> Bool -isMonomorphicOnNonPhantomArgs ty - | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty) - , phantom_vars <- tyConPhantomTyVars tc - , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args - , tyv `notElem` phantom_vars] - = all isMonomorphicOnNonPhantomArgs concrete_args - | Just (ty1, ty2) <- splitFunTy_maybe ty - = all isMonomorphicOnNonPhantomArgs [ty1,ty2] - | otherwise = isMonomorphic ty - -tyConPhantomTyVars :: TyCon -> [TyVar] -tyConPhantomTyVars tc - | isAlgTyCon tc - , Just dcs <- tyConDataCons_maybe tc - , dc_vars <- concatMap dataConUnivTyVars dcs - = tyConTyVars tc \\ dc_vars -tyConPhantomTyVars _ = [] - -type QuantifiedType = ([TyVar], Type) - -- Make the free type variables explicit - -- The returned Type should have no top-level foralls (I believe) - -quantifyType :: Type -> QuantifiedType --- Generalize the type: find all free and forall'd tyvars --- and return them, together with the type inside, which --- should not be a forall type. --- --- Thus (quantifyType (forall a. a->[b])) --- returns ([a,b], a -> [b]) - -quantifyType ty = ( filter isTyVar $ - tyCoVarsOfTypeWellScoped rho - , rho) - where - (_tvs, rho) = tcSplitForAllTys ty - --- Strict application of f at index i -appArr :: Ix i => (e -> a) -> Array i e -> Int -> a -appArr f a@(Array _ _ _ ptrs#) i@(I# i#) - = ASSERT2(i < length(elems a), ppr(length$ elems a, i)) - case indexArray# ptrs# i# of - (# e #) -> f e - -amap' :: (t -> b) -> Array Int t -> [b] -amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] - where g (I# i#) = case indexArray# arr# i# of - (# e #) -> f e diff --git a/ghci/keepCAFsForGHCi.c b/ghci/keepCAFsForGHCi.c deleted file mode 100644 --- a/ghci/keepCAFsForGHCi.c +++ /dev/null @@ -1,15 +0,0 @@ -#include "Rts.h" - -// This file is only included in the dynamic library. -// It contains an __attribute__((constructor)) function (run prior to main()) -// which sets the keepCAFs flag in the RTS, before any Haskell code is run. -// This is required so that GHCi can use dynamic libraries instead of HSxyz.o -// files. - -static void keepCAFsForGHCi(void) __attribute__((constructor)); - -static void keepCAFsForGHCi(void) -{ - keepCAFs = 1; -} - diff --git a/hsSyn/Convert.hs b/hsSyn/Convert.hs deleted file mode 100644 --- a/hsSyn/Convert.hs +++ /dev/null @@ -1,1721 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -This module converts Template Haskell syntax into HsSyn --} - -{-# LANGUAGE ScopedTypeVariables #-} - -module Convert( convertToHsExpr, convertToPat, convertToHsDecls, - convertToHsType, - thRdrNameGuesses ) where - -import HsSyn as Hs -import qualified Class -import RdrName -import qualified Name -import Module -import RdrHsSyn -import qualified OccName -import OccName -import SrcLoc -import Type -import qualified Coercion ( Role(..) ) -import TysWiredIn -import TysPrim (eqPrimTyCon) -import BasicTypes as Hs -import ForeignCall -import Unique -import ErrUtils -import Bag -import Lexeme -import Util -import FastString -import Outputable -import MonadUtils ( foldrM ) - -import qualified Data.ByteString as BS -import Control.Monad( unless, liftM, ap, (<=<) ) - -import Data.Maybe( catMaybes, fromMaybe, isNothing ) -import Language.Haskell.TH as TH hiding (sigP) -import Language.Haskell.TH.Syntax as TH - -------------------------------------------------------------------- --- The external interface - -convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName] -convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds)) - where - cvt_dec d = wrapMsg "declaration" d (cvtDec d) - -convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName) -convertToHsExpr loc e - = initCvt loc $ wrapMsg "expression" e $ cvtl e - -convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName) -convertToPat loc p - = initCvt loc $ wrapMsg "pattern" p $ cvtPat p - -convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName) -convertToHsType loc t - = initCvt loc $ wrapMsg "type" t $ cvtType t - -------------------------------------------------------------------- -newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) } - -- Push down the source location; - -- Can fail, with a single error message - --- NB: If the conversion succeeds with (Right x), there should --- be no exception values hiding in x --- Reason: so a (head []) in TH code doesn't subsequently --- make GHC crash when it tries to walk the generated tree - --- Use the loc everywhere, for lack of anything better --- In particular, we want it on binding locations, so that variables bound in --- the spliced-in declarations get a location that at least relates to the splice point - -instance Functor CvtM where - fmap = liftM - -instance Applicative CvtM where - pure x = CvtM $ \loc -> Right (loc,x) - (<*>) = ap - -instance Monad CvtM where - (CvtM m) >>= k = CvtM $ \loc -> case m loc of - Left err -> Left err - Right (loc',v) -> unCvtM (k v) loc' - -initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a -initCvt loc (CvtM m) = fmap snd (m loc) - -force :: a -> CvtM () -force a = a `seq` return () - -failWith :: MsgDoc -> CvtM a -failWith m = CvtM (\_ -> Left m) - -getL :: CvtM SrcSpan -getL = CvtM (\loc -> Right (loc,loc)) - -setL :: SrcSpan -> CvtM () -setL loc = CvtM (\_ -> Right (loc, ())) - -returnL :: a -> CvtM (Located a) -returnL x = CvtM (\loc -> Right (loc, L loc x)) - -returnJustL :: a -> CvtM (Maybe (Located a)) -returnJustL = fmap Just . returnL - -wrapParL :: (Located a -> a) -> a -> CvtM a -wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x))) - -wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b --- E.g wrapMsg "declaration" dec thing -wrapMsg what item (CvtM m) - = CvtM (\loc -> case m loc of - Left err -> Left (err $$ getPprStyle msg) - Right v -> Right v) - where - -- Show the item in pretty syntax normally, - -- but with all its constructors if you say -dppr-debug - msg sty = hang (text "When splicing a TH" <+> text what <> colon) - 2 (if debugStyle sty - then text (show item) - else text (pprint item)) - -wrapL :: CvtM a -> CvtM (Located a) -wrapL (CvtM m) = CvtM (\loc -> case m loc of - Left err -> Left err - Right (loc',v) -> Right (loc',L loc v)) - -------------------------------------------------------------------- -cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName] -cvtDecs = fmap catMaybes . mapM cvtDec - -cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName)) -cvtDec (TH.ValD pat body ds) - | TH.VarP s <- pat - = do { s' <- vNameL s - ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds) - ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] } - - | otherwise - = do { pat' <- cvtPat pat - ; body' <- cvtGuard body - ; ds' <- cvtLocalDecs (text "a where clause") ds - ; returnJustL $ Hs.ValD $ - PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds') - , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames - , pat_ticks = ([],[]) } } - -cvtDec (TH.FunD nm cls) - | null cls - = failWith (text "Function binding for" - <+> quotes (text (TH.pprint nm)) - <+> text "has no equations") - | otherwise - = do { nm' <- vNameL nm - ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls - ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' } - -cvtDec (TH.SigD nm typ) - = do { nm' <- vNameL nm - ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) } - -cvtDec (TH.InfixD fx nm) - -- Fixity signatures are allowed for variables, constructors, and types - -- the renamer automatically looks for types during renaming, even when - -- the RdrName says it's a variable or a constructor. So, just assume - -- it's a variable or constructor and proceed. - = do { nm' <- vcNameL nm - ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) } - -cvtDec (PragmaD prag) - = cvtPragmaD prag - -cvtDec (TySynD tc tvs rhs) - = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs - ; rhs' <- cvtType rhs - ; returnJustL $ TyClD $ - SynDecl { tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdFVs = placeHolderNames - , tcdRhs = rhs' } } - -cvtDec (DataD ctxt tc tvs ksig constrs derivs) - = do { let isGadtCon (GadtC _ _ _) = True - isGadtCon (RecGadtC _ _ _) = True - isGadtCon (ForallC _ _ c) = isGadtCon c - isGadtCon _ = False - isGadtDecl = all isGadtCon constrs - isH98Decl = all (not . isGadtCon) constrs - ; unless (isGadtDecl || isH98Decl) - (failWith (text "Cannot mix GADT constructors with Haskell 98" - <+> text "constructors")) - ; unless (isNothing ksig || isGadtDecl) - (failWith (text "Kind signatures are only allowed on GADTs")) - ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs - ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM cvtConstr constrs - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing - , dd_ctxt = ctxt' - , dd_kindSig = ksig' - , dd_cons = cons', dd_derivs = derivs' } - ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdDataDefn = defn - , tcdDataCusk = PlaceHolder - , tcdFVs = placeHolderNames }) } - -cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) - = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs - ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr constr - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing - , dd_ctxt = ctxt' - , dd_kindSig = ksig' - , dd_cons = [con'] - , dd_derivs = derivs' } - ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdDataDefn = defn - , tcdDataCusk = PlaceHolder - , tcdFVs = placeHolderNames }) } - -cvtDec (ClassD ctxt cl tvs fds decs) - = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs - ; fds' <- mapM cvt_fundep fds - ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs - ; unless (null adts') - (failWith $ (text "Default data instance declarations" - <+> text "are not allowed:") - $$ (Outputable.ppr adts')) - ; at_defs <- mapM cvt_at_def ats' - ; returnJustL $ TyClD $ - ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' - , tcdMeths = binds' - , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] - , tcdFVs = placeHolderNames } - -- no docs in TH ^^ - } - where - cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName) - -- Very similar to what happens in RdrHsSyn.mkClassDecl - cvt_at_def decl = case RdrHsSyn.mkATDefault decl of - Right def -> return def - Left (_, msg) -> failWith msg - -cvtDec (InstanceD o ctxt ty decs) - = do { let doc = text "an instance declaration" - ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs - ; unless (null fams') (failWith (mkBadDecMsg doc fams')) - ; ctxt' <- cvtContext ctxt - ; L loc ty' <- cvtType ty - ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty' - ; returnJustL $ InstD $ ClsInstD $ - ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty' - , cid_binds = binds' - , cid_sigs = Hs.mkClassOpSigs sigs' - , cid_tyfam_insts = ats', cid_datafam_insts = adts' - , cid_overlap_mode = fmap (L loc . overlap) o } } - where - overlap pragma = - case pragma of - TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS") - TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE") - TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING") - TH.Incoherent -> Hs.Incoherent (SourceText "INCOHERENT") - - - - -cvtDec (ForeignD ford) - = do { ford' <- cvtForD ford - ; returnJustL $ ForD ford' } - -cvtDec (DataFamilyD tc tvs kind) - = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs - ; result <- cvtMaybeKindToFamilyResultSig kind - ; returnJustL $ TyClD $ FamDecl $ - FamilyDecl DataFamily tc' tvs' Prefix result Nothing } - -cvtDec (DataInstD ctxt tc tys ksig constrs derivs) - = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys - ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM cvtConstr constrs - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing - , dd_ctxt = ctxt' - , dd_kindSig = ksig' - , dd_cons = cons', dd_derivs = derivs' } - - ; returnJustL $ InstD $ DataFamInstD - { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' - , dfid_defn = defn - , dfid_fixity = Prefix - , dfid_fvs = placeHolderNames } }} - -cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs) - = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys - ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr constr - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing - , dd_ctxt = ctxt' - , dd_kindSig = ksig' - , dd_cons = [con'], dd_derivs = derivs' } - ; returnJustL $ InstD $ DataFamInstD - { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' - , dfid_defn = defn - , dfid_fixity = Prefix - , dfid_fvs = placeHolderNames } }} - -cvtDec (TySynInstD tc eqn) - = do { tc' <- tconNameL tc - ; eqn' <- cvtTySynEqn tc' eqn - ; returnJustL $ InstD $ TyFamInstD - { tfid_inst = TyFamInstDecl { tfid_eqn = eqn' - , tfid_fvs = placeHolderNames } } } - -cvtDec (OpenTypeFamilyD head) - = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head - ; returnJustL $ TyClD $ FamDecl $ - FamilyDecl OpenTypeFamily tc' tyvars' Prefix result' injectivity' } - -cvtDec (ClosedTypeFamilyD head eqns) - = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head - ; eqns' <- mapM (cvtTySynEqn tc') eqns - ; returnJustL $ TyClD $ FamDecl $ - FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result' - injectivity' } - -cvtDec (TH.RoleAnnotD tc roles) - = do { tc' <- tconNameL tc - ; let roles' = map (noLoc . cvtRole) roles - ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') } - -cvtDec (TH.StandaloneDerivD ds cxt ty) - = do { cxt' <- cvtContext cxt - ; L loc ty' <- cvtType ty - ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty' - ; returnJustL $ DerivD $ - DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds - , deriv_type = mkLHsSigType inst_ty' - , deriv_overlap_mode = Nothing } } - -cvtDec (TH.DefaultSigD nm typ) - = do { nm' <- vNameL nm - ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') } - -cvtDec (TH.PatSynD nm args dir pat) - = do { nm' <- cNameL nm - ; args' <- cvtArgs args - ; dir' <- cvtDir nm' dir - ; pat' <- cvtPat pat - ; returnJustL $ Hs.ValD $ PatSynBind $ - PSB nm' placeHolderType args' pat' dir' } - where - cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args - cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2 - cvtArgs (TH.RecordPatSyn sels) - = do { sels' <- mapM vNameL sels - ; vars' <- mapM (vNameL . mkNameS . nameBase) sels - ; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' } - - cvtDir _ Unidir = return Unidirectional - cvtDir _ ImplBidir = return ImplicitBidirectional - cvtDir n (ExplBidir cls) = - do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls - ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms } - -cvtDec (TH.PatSynSigD nm ty) - = do { nm' <- cNameL nm - ; ty' <- cvtPatSynSigTy ty - ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') } - ----------------- -cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) -cvtTySynEqn tc (TySynEqn lhs rhs) - = do { lhs' <- mapM (wrap_apps <=< cvtType) lhs - ; rhs' <- cvtType rhs - ; returnL $ TyFamEqn { tfe_tycon = tc - , tfe_pats = mkHsImplicitBndrs lhs' - , tfe_fixity = Prefix - , tfe_rhs = rhs' } } - ----------------- -cvt_ci_decs :: MsgDoc -> [TH.Dec] - -> CvtM (LHsBinds RdrName, - [LSig RdrName], - [LFamilyDecl RdrName], - [LTyFamInstDecl RdrName], - [LDataFamInstDecl RdrName]) --- Convert the declarations inside a class or instance decl --- ie signatures, bindings, and associated types -cvt_ci_decs doc decs - = do { decs' <- cvtDecs decs - ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs' - ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs' - ; let (sigs', prob_binds') = partitionWith is_sig no_ats' - ; let (binds', prob_fams') = partitionWith is_bind prob_binds' - ; let (fams', bads) = partitionWith is_fam_decl prob_fams' - ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - --We use FromSource as the origin of the bind - -- because the TH declaration is user-written - ; return (listToBag binds', sigs', fams', ats', adts') } - ----------------- -cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] - -> CvtM ( LHsContext RdrName - , Located RdrName - , LHsQTyVars RdrName) -cvt_tycl_hdr cxt tc tvs - = do { cxt' <- cvtContext cxt - ; tc' <- tconNameL tc - ; tvs' <- cvtTvs tvs - ; return (cxt', tc', tvs') - } - -cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] - -> CvtM ( LHsContext RdrName - , Located RdrName - , HsImplicitBndrs RdrName [LHsType RdrName]) -cvt_tyinst_hdr cxt tc tys - = do { cxt' <- cvtContext cxt - ; tc' <- tconNameL tc - ; tys' <- mapM (wrap_apps <=< cvtType) tys - ; return (cxt', tc', mkHsImplicitBndrs tys') } - ----------------- -cvt_tyfam_head :: TypeFamilyHead - -> CvtM ( Located RdrName - , LHsQTyVars RdrName - , Hs.LFamilyResultSig RdrName - , Maybe (Hs.LInjectivityAnn RdrName)) - -cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) - = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars - ; result' <- cvtFamilyResultSig result - ; injectivity' <- traverse cvtInjectivityAnnotation injectivity - ; return (tc', tyvars', result', injectivity') } - -------------------------------------------------------------------- --- Partitioning declarations -------------------------------------------------------------------- - -is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName) -is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d) -is_fam_decl decl = Right decl - -is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName) -is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d) -is_tyfam_inst decl = Right decl - -is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName) -is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d) -is_datafam_inst decl = Right decl - -is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName) -is_sig (L loc (Hs.SigD sig)) = Left (L loc sig) -is_sig decl = Right decl - -is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName) -is_bind (L loc (Hs.ValD bind)) = Left (L loc bind) -is_bind decl = Right decl - -mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc -mkBadDecMsg doc bads - = sep [ text "Illegal declaration(s) in" <+> doc <> colon - , nest 2 (vcat (map Outputable.ppr bads)) ] - ---------------------------------------------------- --- Data types ---------------------------------------------------- - -cvtConstr :: TH.Con -> CvtM (LConDecl RdrName) - -cvtConstr (NormalC c strtys) - = do { c' <- cNameL c - ; cxt' <- returnL [] - ; tys' <- mapM cvt_arg strtys - ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') } - -cvtConstr (RecC c varstrtys) - = do { c' <- cNameL c - ; cxt' <- returnL [] - ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ mkConDeclH98 c' Nothing cxt' - (RecCon (noLoc args')) } - -cvtConstr (InfixC st1 c st2) - = do { c' <- cNameL c - ; cxt' <- returnL [] - ; st1' <- cvt_arg st1 - ; st2' <- cvt_arg st2 - ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') } - -cvtConstr (ForallC tvs ctxt con) - = do { tvs' <- cvtTvs tvs - ; L loc ctxt' <- cvtContext ctxt - ; L _ con' <- cvtConstr con - ; returnL $ case con' of - ConDeclGADT { con_type = conT } -> - let hs_ty = mkHsForAllTy tvs noSrcSpan tvs' rho_ty - rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt') - (hsib_body conT) - in con' { con_type = mkHsImplicitBndrs hs_ty } - ConDeclH98 {} -> - let qvars = case (tvs, con_qvars con') of - ([], Nothing) -> Nothing - (_ , m_qvs ) -> Just $ - mkHsQTvs (hsQTvExplicit tvs' ++ - maybe [] hsQTvExplicit m_qvs) - in con' { con_qvars = qvars - , con_cxt = Just $ - L loc (ctxt' ++ - unLoc (fromMaybe (noLoc []) - (con_cxt con'))) } } - -cvtConstr (GadtC c strtys ty) - = do { c' <- mapM cNameL c - ; args <- mapM cvt_arg strtys - ; L _ ty' <- cvtType ty - ; c_ty <- mk_arr_apps args ty' - ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)} - -cvtConstr (RecGadtC c varstrtys ty) - = do { c' <- mapM cNameL c - ; ty' <- cvtType ty - ; rec_flds <- mapM cvt_id_arg varstrtys - ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty') - ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) } - -cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness -cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack -cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack -cvtSrcUnpackedness SourceUnpack = SrcUnpack - -cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness -cvtSrcStrictness NoSourceStrictness = NoSrcStrict -cvtSrcStrictness SourceLazy = SrcLazy -cvtSrcStrictness SourceStrict = SrcStrict - -cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType RdrName) -cvt_arg (Bang su ss, ty) - = do { ty'' <- cvtType ty - ; ty' <- wrap_apps ty'' - ; let su' = cvtSrcUnpackedness su - ; let ss' = cvtSrcStrictness ss - ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' } - -cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName) -cvt_id_arg (i, str, ty) - = do { L li i' <- vNameL i - ; ty' <- cvt_arg (str,ty) - ; return $ noLoc (ConDeclField - { cd_fld_names - = [L li $ FieldOcc (L li i') PlaceHolder] - , cd_fld_type = ty' - , cd_fld_doc = Nothing}) } - -cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving RdrName) -cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs - ; returnL cs' } - -cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName))) -cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs - ; ys' <- mapM tNameL ys - ; returnL (xs', ys') } - - ------------------------------------------- --- Foreign declarations ------------------------------------------- - -cvtForD :: Foreign -> CvtM (ForeignDecl RdrName) -cvtForD (ImportF callconv safety from nm ty) - -- the prim and javascript calling conventions do not support headers - -- and are inserted verbatim, analogous to mkImport in RdrHsSyn - | callconv == TH.Prim || callconv == TH.JavaScript - = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing - (CFunction (StaticTarget (SourceText from) - (mkFastString from) Nothing - True)) - (noLoc $ quotedSourceText from)) - | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety') - (mkFastString (TH.nameBase nm)) - from (noLoc $ quotedSourceText from) - = mk_imp impspec - | otherwise - = failWith $ text (show from) <+> text "is not a valid ccall impent" - where - mk_imp impspec - = do { nm' <- vNameL nm - ; ty' <- cvtType ty - ; return (ForeignImport { fd_name = nm' - , fd_sig_ty = mkLHsSigType ty' - , fd_co = noForeignImportCoercionYet - , fd_fi = impspec }) - } - safety' = case safety of - Unsafe -> PlayRisky - Safe -> PlaySafe - Interruptible -> PlayInterruptible - -cvtForD (ExportF callconv as nm ty) - = do { nm' <- vNameL nm - ; ty' <- cvtType ty - ; let e = CExport (noLoc (CExportStatic (SourceText as) - (mkFastString as) - (cvt_conv callconv))) - (noLoc (SourceText as)) - ; return $ ForeignExport { fd_name = nm' - , fd_sig_ty = mkLHsSigType ty' - , fd_co = noForeignExportCoercionYet - , fd_fe = e } } - -cvt_conv :: TH.Callconv -> CCallConv -cvt_conv TH.CCall = CCallConv -cvt_conv TH.StdCall = StdCallConv -cvt_conv TH.CApi = CApiConv -cvt_conv TH.Prim = PrimCallConv -cvt_conv TH.JavaScript = JavaScriptCallConv - ------------------------------------------- --- Pragmas ------------------------------------------- - -cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName)) -cvtPragmaD (InlineP nm inline rm phases) - = do { nm' <- vNameL nm - ; let dflt = dfltActivation inline - ; let src TH.NoInline = "{-# NOINLINE" - src TH.Inline = "{-# INLINE" - src TH.Inlinable = "{-# INLINABLE" - ; let ip = InlinePragma { inl_src = SourceText $ src inline - , inl_inline = cvtInline inline - , inl_rule = cvtRuleMatch rm - , inl_act = cvtPhases phases dflt - , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ InlineSig nm' ip } - -cvtPragmaD (SpecialiseP nm ty inline phases) - = do { nm' <- vNameL nm - ; ty' <- cvtType ty - ; let src TH.NoInline = "{-# SPECIALISE NOINLINE" - src TH.Inline = "{-# SPECIALISE INLINE" - src TH.Inlinable = "{-# SPECIALISE INLINE" - ; let (inline', dflt,srcText) = case inline of - Just inline1 -> (cvtInline inline1, dfltActivation inline1, - src inline1) - Nothing -> (EmptyInlineSpec, AlwaysActive, - "{-# SPECIALISE") - ; let ip = InlinePragma { inl_src = SourceText srcText - , inl_inline = inline' - , inl_rule = Hs.FunLike - , inl_act = cvtPhases phases dflt - , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip } - -cvtPragmaD (SpecialiseInstP ty) - = do { ty' <- cvtType ty - ; returnJustL $ Hs.SigD $ - SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') } - -cvtPragmaD (RuleP nm bndrs lhs rhs phases) - = do { let nm' = mkFastString nm - ; let act = cvtPhases phases AlwaysActive - ; bndrs' <- mapM cvtRuleBndr bndrs - ; lhs' <- cvtl lhs - ; rhs' <- cvtl rhs - ; returnJustL $ Hs.RuleD - $ HsRules (SourceText "{-# RULES") - [noLoc $ HsRule (noLoc (SourceText nm,nm')) act bndrs' - lhs' placeHolderNames - rhs' placeHolderNames] - } - -cvtPragmaD (AnnP target exp) - = do { exp' <- cvtl exp - ; target' <- case target of - ModuleAnnotation -> return ModuleAnnProvenance - TypeAnnotation n -> do - n' <- tconName n - return (TypeAnnProvenance (noLoc n')) - ValueAnnotation n -> do - n' <- vcName n - return (ValueAnnProvenance (noLoc n')) - ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target' - exp' - } - -cvtPragmaD (LineP line file) - = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1)) - ; return Nothing - } -cvtPragmaD (CompleteP cls mty) - = do { cls' <- noLoc <$> mapM cNameL cls - ; mty' <- traverse tconNameL mty - ; returnJustL $ Hs.SigD - $ CompleteMatchSig NoSourceText cls' mty' } - -dfltActivation :: TH.Inline -> Activation -dfltActivation TH.NoInline = NeverActive -dfltActivation _ = AlwaysActive - -cvtInline :: TH.Inline -> Hs.InlineSpec -cvtInline TH.NoInline = Hs.NoInline -cvtInline TH.Inline = Hs.Inline -cvtInline TH.Inlinable = Hs.Inlinable - -cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo -cvtRuleMatch TH.ConLike = Hs.ConLike -cvtRuleMatch TH.FunLike = Hs.FunLike - -cvtPhases :: TH.Phases -> Activation -> Activation -cvtPhases AllPhases dflt = dflt -cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i -cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i - -cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName) -cvtRuleBndr (RuleVar n) - = do { n' <- vNameL n - ; return $ noLoc $ Hs.RuleBndr n' } -cvtRuleBndr (TypedRuleVar n ty) - = do { n' <- vNameL n - ; ty' <- cvtType ty - ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' } - ---------------------------------------------------- --- Declarations ---------------------------------------------------- - -cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName) -cvtLocalDecs doc ds - | null ds - = return EmptyLocalBinds - | otherwise - = do { ds' <- cvtDecs ds - ; let (binds, prob_sigs) = partitionWith is_bind ds' - ; let (sigs, bads) = partitionWith is_sig prob_sigs - ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } - -cvtClause :: HsMatchContext RdrName - -> TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) -cvtClause ctxt (Clause ps body wheres) - = do { ps' <- cvtPats ps - ; pps <- mapM wrap_conpat ps' - ; g' <- cvtGuard body - ; ds' <- cvtLocalDecs (text "a where clause") wheres - ; returnL $ Hs.Match ctxt pps Nothing - (GRHSs g' (noLoc ds')) } - - -------------------------------------------------------------------- --- Expressions -------------------------------------------------------------------- - -cvtl :: TH.Exp -> CvtM (LHsExpr RdrName) -cvtl e = wrapL (cvt e) - where - cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } - cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') } - cvt (LitE l) - | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } - | otherwise = do { l' <- cvtLit l; return $ HsLit l' } - cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp (mkLHsPar x') (mkLHsPar y')} - cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp (mkLHsPar x') (mkLHsPar y')} - cvt (AppTypeE e t) = do { e' <- cvtl e - ; t' <- cvtType t - ; tp <- wrap_apps t' - ; return $ HsAppType e' $ mkHsWildCardBndrs tp } - cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e - ; return $ HsLam (mkMatchGroup FromSource - [mkSimpleMatch LambdaExpr ps' e'])} - cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms - ; return $ HsLamCase (mkMatchGroup FromSource ms') - } - cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } - -- Note [Dropping constructors] - -- Singleton tuples treated like nothing (just parens) - cvt (TupE es) = do { es' <- mapM cvtl es - ; return $ ExplicitTuple (map (noLoc . Present) es') - Boxed } - cvt (UnboxedTupE es) = do { es' <- mapM cvtl es - ; return $ ExplicitTuple - (map (noLoc . Present) es') Unboxed } - cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e - ; unboxedSumChecks alt arity - ; return $ ExplicitSum - alt arity e' placeHolderType } - cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; - ; return $ HsIf (Just noSyntaxExpr) x' y' z' } - cvt (MultiIfE alts) - | null alts = failWith (text "Multi-way if-expression with no alternatives") - | otherwise = do { alts' <- mapM cvtpair alts - ; return $ HsMultiIf placeHolderType alts' } - cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds - ; e' <- cvtl e; return $ HsLet (noLoc ds') e' } - cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms - ; return $ HsCase e' (mkMatchGroup FromSource ms') } - cvt (DoE ss) = cvtHsDo DoExpr ss - cvt (CompE ss) = cvtHsDo ListComp ss - cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' } - cvt (ListE xs) - | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } - -- Note [Converting strings] - | otherwise = do { xs' <- mapM cvtl xs - ; return $ ExplicitList placeHolderType Nothing xs' - } - - -- Infix expressions - cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y - ; wrapParL HsPar $ - OpApp (mkLHsPar x') s' undefined (mkLHsPar y') } - -- Parenthesise both arguments and result, - -- to ensure this operator application does - -- does not get re-associated - -- See Note [Operator association] - cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y - ; wrapParL HsPar $ SectionR s' y' } - -- See Note [Sections in HsSyn] in HsExpr - cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s - ; wrapParL HsPar $ SectionL x' s' } - - cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' } - -- Can I indicate this is an infix thing? - -- Note [Dropping constructors] - - cvt (UInfixE x s y) = do { x' <- cvtl x - ; let x'' = case x' of - L _ (OpApp {}) -> x' - _ -> mkLHsPar x' - ; cvtOpApp x'' s y } -- Note [Converting UInfix] - - cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' } - cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t - ; return $ ExprWithTySig e' (mkLHsSigWcType t') } - cvt (RecConE c flds) = do { c' <- cNameL c - ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds - ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } - cvt (RecUpdE e flds) = do { e' <- cvtl e - ; flds' - <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) - flds - ; return $ mkRdrRecordUpd e' flds' } - cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e - cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } - -{- Note [Dropping constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we drop constructors from the input (for instance, when we encounter @TupE [e]@) -we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@ -could meet @UInfix@ constructors containing the @TupE [e]@. For example: - - UInfixE x * (TupE [UInfixE y + z]) - -If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet -and the above expression would be reassociated to - - OpApp (OpApp x * y) + z - -which we don't want. --} - -cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) -> CvtM (LHsRecField' t (LHsExpr RdrName)) -cvtFld f (v,e) - = do { v' <- vNameL v; e' <- cvtl e - ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v' - , hsRecFieldArg = e' - , hsRecPun = False}) } - -cvtDD :: Range -> CvtM (ArithSeqInfo RdrName) -cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } -cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' } -cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } -cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } - -{- Note [Operator assocation] -We must be quite careful about adding parens: - * Infix (UInfix ...) op arg Needs parens round the first arg - * Infix (Infix ...) op arg Needs parens round the first arg - * UInfix (UInfix ...) op arg No parens for first arg - * UInfix (Infix ...) op arg Needs parens round first arg - - -Note [Converting UInfix] -~~~~~~~~~~~~~~~~~~~~~~~~ -When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust -the trees to reflect the fixities of the underlying operators: - - UInfixE x * (UInfixE y + z) ---> (x * y) + z - -This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and -@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely -right-biased for types and left-biased for everything else. So we left-bias the -trees of @UInfixP@ and @UInfixE@ and use HsAppsTy for UInfixT. - -Sample input: - - UInfixE - (UInfixE x op1 y) - op2 - (UInfixE z op3 w) - -Sample output: - - OpApp - (OpApp - (OpApp x op1 y) - op2 - z) - op3 - w - -The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this -biasing. --} - -{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. -The produced tree of infix expressions will be left-biased, provided @x@ is. - -We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis -is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that -this holds for both branches (of @cvtOpApp@), provided we assume it holds for -the recursive calls to @cvtOpApp@. - -When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased -since we have already run @cvtl@ on it. --} -cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName) -cvtOpApp x op1 (UInfixE y op2 z) - = do { l <- wrapL $ cvtOpApp x op1 y - ; cvtOpApp l op2 z } -cvtOpApp x op y - = do { op' <- cvtl op - ; y' <- cvtl y - ; return (OpApp x op' undefined y') } - -------------------------------------- --- Do notation and statements -------------------------------------- - -cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName) -cvtHsDo do_or_lc stmts - | null stmts = failWith (text "Empty stmt list in do-block") - | otherwise - = do { stmts' <- cvtStmts stmts - ; let Just (stmts'', last') = snocView stmts' - - ; last'' <- case last' of - L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body)) - _ -> failWith (bad_last last') - - ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType } - where - bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon - , nest 2 $ Outputable.ppr stmt - , text "(It should be an expression.)" ] - -cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)] -cvtStmts = mapM cvtStmt - -cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName)) -cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } -cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } -cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds - ; returnL $ LetStmt (noLoc ds') } -cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType } - where - cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } - -cvtMatch :: HsMatchContext RdrName - -> TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) -cvtMatch ctxt (TH.Match p body decs) - = do { p' <- cvtPat p - ; lp <- case ctxt of - CaseAlt -> return p' - _ -> wrap_conpat p' - ; g' <- cvtGuard body - ; decs' <- cvtLocalDecs (text "a where clause") decs - ; returnL $ Hs.Match ctxt [lp] Nothing - (GRHSs g' (noLoc decs')) } - -cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)] -cvtGuard (GuardedB pairs) = mapM cvtpair pairs -cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] } - -cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName)) -cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs - ; g' <- returnL $ mkBodyStmt ge' - ; returnL $ GRHS [g'] rhs' } -cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs - ; returnL $ GRHS gs' rhs' } - -cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) -cvtOverLit (IntegerL i) - = do { force i; return $ mkHsIntegral NoSourceText i placeHolderType} -cvtOverLit (RationalL r) - = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType} -cvtOverLit (StringL s) - = do { let { s' = mkFastString s } - ; force s' - ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType - } -cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" --- An Integer is like an (overloaded) '3' in a Haskell source program --- Similarly 3.5 for fractionals - -{- Note [Converting strings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to -a string literal for "xy". Of course, we might hope to get -(LitE (StringL "xy")), but not always, and allCharLs fails quickly -if it isn't a literal string --} - -allCharLs :: [TH.Exp] -> Maybe String --- Note [Converting strings] --- NB: only fire up this setup for a non-empty list, else --- there's a danger of returning "" for [] :: [Int]! -allCharLs xs - = case xs of - LitE (CharL c) : ys -> go [c] ys - _ -> Nothing - where - go cs [] = Just (reverse cs) - go cs (LitE (CharL c) : ys) = go (c:cs) ys - go _ _ = Nothing - -cvtLit :: Lit -> CvtM HsLit -cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } -cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } -cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) } -cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) } -cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } -cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } -cvtLit (StringL s) = do { let { s' = mkFastString s } - ; force s' - ; return $ HsString (quotedSourceText s) s' } -cvtLit (StringPrimL s) = do { let { s' = BS.pack s } - ; force s' - ; return $ HsStringPrim NoSourceText s' } -cvtLit _ = panic "Convert.cvtLit: Unexpected literal" - -- cvtLit should not be called on IntegerL, RationalL - -- That precondition is established right here in - -- Convert.hs, hence panic - -quotedSourceText :: String -> SourceText -quotedSourceText s = SourceText $ "\"" ++ s ++ "\"" - -cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName] -cvtPats pats = mapM cvtPat pats - -cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName) -cvtPat pat = wrapL (cvtp pat) - -cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName) -cvtp (TH.LitP l) - | overloadedLit l = do { l' <- cvtOverLit l - ; return (mkNPat (noLoc l') Nothing) } - -- Not right for negative patterns; - -- need to think about that! - | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } -cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') } -cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors] -cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] } -cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] } -cvtp (UnboxedSumP p alt arity) - = do { p' <- cvtPat p - ; unboxedSumChecks alt arity - ; return $ SumPat p' alt arity placeHolderType } -cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps - ; pps <- mapM wrap_conpat ps' - ; return $ ConPatIn s' (PrefixCon pps) } -cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 - ; wrapParL ParPat $ - ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) } - -- See Note [Operator association] -cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] -cvtp (ParensP p) = do { p' <- cvtPat p; - ; case p' of -- may be wrapped ConPatIn - (L _ (ParPat {})) -> return $ unLoc p' - _ -> return $ ParPat p' } -cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } -cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } -cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } -cvtp TH.WildP = return $ WildPat placeHolderType -cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs - ; return $ ConPatIn c' - $ Hs.RecCon (HsRecFields fs' Nothing) } -cvtp (ListP ps) = do { ps' <- cvtPats ps - ; return $ ListPat ps' placeHolderType Nothing } -cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPatIn p' (mkLHsSigWcType t') } -cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p - ; return $ ViewPat e' p' placeHolderType } - -cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName)) -cvtPatFld (s,p) - = do { L ls s' <- vNameL s; p' <- cvtPat p - ; return (noLoc $ HsRecField { hsRecFieldLbl - = L ls $ mkFieldOcc (L ls s') - , hsRecFieldArg = p' - , hsRecPun = False}) } - -wrap_conpat :: Hs.LPat RdrName -> CvtM (Hs.LPat RdrName) -wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat p -wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p -wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat p -wrap_conpat p = return p - -{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. -The produced tree of infix patterns will be left-biased, provided @x@ is. - -See the @cvtOpApp@ documentation for how this function works. --} -cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName) -cvtOpAppP x op1 (UInfixP y op2 z) - = do { l <- wrapL $ cvtOpAppP x op1 y - ; cvtOpAppP l op2 z } -cvtOpAppP x op y - = do { op' <- cNameL op - ; y' <- cvtPat y - ; return (ConPatIn op' (InfixCon x y')) } - ------------------------------------------------------------ --- Types and type variables - -cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars RdrName) -cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } - -cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) -cvt_tv (TH.PlainTV nm) - = do { nm' <- tNameL nm - ; returnL $ UserTyVar nm' } -cvt_tv (TH.KindedTV nm ki) - = do { nm' <- tNameL nm - ; ki' <- cvtKind ki - ; returnL $ KindedTyVar nm' ki' } - -cvtRole :: TH.Role -> Maybe Coercion.Role -cvtRole TH.NominalR = Just Coercion.Nominal -cvtRole TH.RepresentationalR = Just Coercion.Representational -cvtRole TH.PhantomR = Just Coercion.Phantom -cvtRole TH.InferR = Nothing - -cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) -cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } - -cvtPred :: TH.Pred -> CvtM (LHsType RdrName) -cvtPred = cvtType - -cvtDerivClause :: TH.DerivClause - -> CvtM (LHsDerivingClause RdrName) -cvtDerivClause (TH.DerivClause ds ctxt) - = do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt - ; let ds' = fmap (L loc . cvtDerivStrategy) ds - ; returnL $ HsDerivingClause ds' ctxt' } - -cvtDerivStrategy :: TH.DerivStrategy -> Hs.DerivStrategy -cvtDerivStrategy TH.StockStrategy = Hs.StockStrategy -cvtDerivStrategy TH.AnyclassStrategy = Hs.AnyclassStrategy -cvtDerivStrategy TH.NewtypeStrategy = Hs.NewtypeStrategy - -cvtType :: TH.Type -> CvtM (LHsType RdrName) -cvtType = cvtTypeKind "type" - -cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName) -cvtTypeKind ty_str ty - = do { (head_ty, tys') <- split_ty_app ty - ; case head_ty of - TupleT n - | length tys' == n -- Saturated - -> if n==1 then return (head tys') -- Singleton tuples treated - -- like nothing (ie just parens) - else returnL (HsTupleTy HsBoxedOrConstraintTuple tys') - | n == 1 - -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) - | otherwise - -> mk_apps (HsTyVar NotPromoted - (noLoc (getRdrName (tupleTyCon Boxed n)))) tys' - UnboxedTupleT n - | length tys' == n -- Saturated - -> returnL (HsTupleTy HsUnboxedTuple tys') - | otherwise - -> mk_apps (HsTyVar NotPromoted - (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys' - UnboxedSumT n - | n < 2 - -> failWith $ - vcat [ text "Illegal sum arity:" <+> text (show n) - , nest 2 $ - text "Sums must have an arity of at least 2" ] - | length tys' == n -- Saturated - -> returnL (HsSumTy tys') - | otherwise - -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n)))) - tys' - ArrowT - | [x',y'] <- tys' -> returnL (HsFunTy x' y') - | otherwise -> - mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon))) - tys' - ListT - | [x'] <- tys' -> returnL (HsListTy x') - | otherwise -> - mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon))) - tys' - VarT nm -> do { nm' <- tNameL nm - ; mk_apps (HsTyVar NotPromoted nm') tys' } - ConT nm -> do { nm' <- tconName nm - ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } - - ForallT tvs cxt ty - | null tys' - -> do { tvs' <- cvtTvs tvs - ; cxt' <- cvtContext cxt - ; ty' <- cvtType ty - ; loc <- getL - ; let hs_ty = mkHsForAllTy tvs loc tvs' rho_ty - rho_ty = mkHsQualTy cxt loc cxt' ty' - - ; return hs_ty } - - SigT ty ki - -> do { ty' <- cvtType ty - ; ki' <- cvtKind ki - ; mk_apps (HsKindSig ty' ki') tys' - } - - LitT lit - -> returnL (HsTyLit (cvtTyLit lit)) - - WildCardT - -> mk_apps mkAnonWildCardTy tys' - - InfixT t1 s t2 - -> do { s' <- tconName s - ; t1' <- cvtType t1 - ; t2' <- cvtType t2 - ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2'] - } - - UInfixT t1 s t2 - -> do { t1' <- cvtType t1 - ; t2' <- cvtType t2 - ; s' <- tconName s - ; return $ cvtOpAppT t1' s' t2' - } -- Note [Converting UInfix] - - ParensT t - -> do { t' <- cvtType t - ; returnL $ HsParTy t' - } - - PromotedT nm -> do { nm' <- cName nm - ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } - -- Promoted data constructor; hence cName - - PromotedTupleT n - | n == 1 - -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str))) - | m == n -- Saturated - -> do { let kis = replicate m placeHolderKind - ; returnL (HsExplicitTupleTy kis tys') - } - where - m = length tys' - - PromotedNilT - -> returnL (HsExplicitListTy Promoted placeHolderKind []) - - PromotedConsT -- See Note [Representing concrete syntax in types] - -- in Language.Haskell.TH.Syntax - | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys' - -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2)) - | otherwise - -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon))) - tys' - - StarT - -> returnL (HsTyVar NotPromoted (noLoc - (getRdrName liftedTypeKindTyCon))) - - ConstraintT - -> returnL (HsTyVar NotPromoted - (noLoc (getRdrName constraintKindTyCon))) - - EqualityT - | [x',y'] <- tys' -> returnL (HsEqTy x' y') - | otherwise -> - mk_apps (HsTyVar NotPromoted - (noLoc (getRdrName eqPrimTyCon))) tys' - - _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) - } - --- | Constructs an application of a type to arguments passed in a list. -mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName) -mk_apps head_ty [] = returnL head_ty -mk_apps head_ty (ty:tys) = - do { head_ty' <- returnL head_ty - ; p_ty <- add_parens ty - ; mk_apps (HsAppTy head_ty' p_ty) tys } - where - add_parens t@(L _ HsAppTy{}) = returnL (HsParTy t) - add_parens t = return t - -wrap_apps :: LHsType RdrName -> CvtM (LHsType RdrName) -wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t) -wrap_apps t = return t - --- | Constructs an arrow type with a specified return type -mk_arr_apps :: [LHsType RdrName] -> HsType RdrName -> CvtM (LHsType RdrName) -mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL - where go :: LHsType RdrName -> HsType RdrName -> CvtM (HsType RdrName) - go arg ret_ty = do { ret_ty_l <- returnL ret_ty - ; return (HsFunTy arg ret_ty_l) } - -split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName]) -split_ty_app ty = go ty [] - where - go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') } - go f as = return (f,as) - -cvtTyLit :: TH.TyLit -> HsTyLit -cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i -cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) - -{- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy - structure in them. --} -cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName -cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) - = L (combineSrcSpans loc1 loc2) $ - HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2') - where - t1' | L _ (HsAppsTy t1s) <- t1 - = t1s - | otherwise - = [noLoc $ HsAppPrefix t1] - - t2' | L _ (HsAppsTy t2s) <- t2 - = t2s - | otherwise - = [noLoc $ HsAppPrefix t2] - -cvtKind :: TH.Kind -> CvtM (LHsKind RdrName) -cvtKind = cvtTypeKind "kind" - --- | Convert Maybe Kind to a type family result signature. Used with data --- families where naming of the result is not possible (thus only kind or no --- signature is possible). -cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind - -> CvtM (LFamilyResultSig RdrName) -cvtMaybeKindToFamilyResultSig Nothing = returnL Hs.NoSig -cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki - ; returnL (Hs.KindSig ki') } - --- | Convert type family result signature. Used with both open and closed type --- families. -cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig RdrName) -cvtFamilyResultSig TH.NoSig = returnL Hs.NoSig -cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki - ; returnL (Hs.KindSig ki') } -cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr - ; returnL (Hs.TyVarSig tv) } - --- | Convert injectivity annotation of a type family. -cvtInjectivityAnnotation :: TH.InjectivityAnn - -> CvtM (Hs.LInjectivityAnn RdrName) -cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) - = do { annLHS' <- tNameL annLHS - ; annRHS' <- mapM tNameL annRHS - ; returnL (Hs.InjectivityAnn annLHS' annRHS') } - -cvtPatSynSigTy :: TH.Type -> CvtM (LHsType RdrName) --- pattern synonym types are of peculiar shapes, which is why we treat --- them separately from regular types; --- see Note [Pattern synonym type signatures and Template Haskell] -cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) - | null exis, null provs = cvtType (ForallT univs reqs ty) - | null univs, null reqs = do { l <- getL - ; ty' <- cvtType (ForallT exis provs ty) - ; return $ L l (HsQualTy { hst_ctxt = L l [] - , hst_body = ty' }) } - | null reqs = do { l <- getL - ; univs' <- hsQTvExplicit <$> cvtTvs univs - ; ty' <- cvtType (ForallT exis provs ty) - ; let forTy = HsForAllTy { hst_bndrs = univs' - , hst_body = L l cxtTy } - cxtTy = HsQualTy { hst_ctxt = L l [] - , hst_body = ty' } - ; return $ L l forTy } - | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty)) -cvtPatSynSigTy ty = cvtType ty - ------------------------------------------------------------ -cvtFixity :: TH.Fixity -> Hs.Fixity -cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir) - where - cvt_dir TH.InfixL = Hs.InfixL - cvt_dir TH.InfixR = Hs.InfixR - cvt_dir TH.InfixN = Hs.InfixN - ------------------------------------------------------------ - - ------------------------------------------------------------ --- some useful things - -overloadedLit :: Lit -> Bool --- True for literals that Haskell treats as overloaded -overloadedLit (IntegerL _) = True -overloadedLit (RationalL _) = True -overloadedLit _ = False - -cvtFractionalLit :: Rational -> FractionalLit -cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r } - --- Checks that are performed when converting unboxed sum expressions and --- patterns alike. -unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM () -unboxedSumChecks alt arity - | alt > arity - = failWith $ text "Sum alternative" <+> text (show alt) - <+> text "exceeds its arity," <+> text (show arity) - | alt <= 0 - = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt) - , nest 2 $ text "Sum alternatives must start from 1" ] - | arity < 2 - = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity) - , nest 2 $ text "Sums must have an arity of at least 2" ] - | otherwise - = return () - --- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the --- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy' --- using the provided 'LHsQTyVars' and 'LHsType'. -mkHsForAllTy :: [TH.TyVarBndr] - -- ^ The original Template Haskell type variable binders - -> SrcSpan - -- ^ The location of the returned 'LHsType' if it needs an - -- explicit forall - -> LHsQTyVars name - -- ^ The converted type variable binders - -> LHsType name - -- ^ The converted rho type - -> LHsType name - -- ^ The complete type, quantified with a forall if necessary -mkHsForAllTy tvs loc tvs' rho_ty - | null tvs = rho_ty - | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs' - , hst_body = rho_ty } - --- | If passed an empty 'TH.Cxt', this simply returns the third argument --- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided --- 'LHsContext' and 'LHsType'. - --- It's important that we don't build an HsQualTy if the context is empty, --- as the pretty-printer for HsType _always_ prints contexts, even if --- they're empty. See Trac #13183. -mkHsQualTy :: TH.Cxt - -- ^ The original Template Haskell context - -> SrcSpan - -- ^ The location of the returned 'LHsType' if it needs an - -- explicit context - -> LHsContext name - -- ^ The converted context - -> LHsType name - -- ^ The converted tau type - -> LHsType name - -- ^ The complete type, qualified with a context if necessary -mkHsQualTy ctxt loc ctxt' ty - | null ctxt = ty - | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty } - --------------------------------------------------------------------- --- Turning Name back into RdrName --------------------------------------------------------------------- - --- variable names -vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) -vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName - --- Variable names -vNameL n = wrapL (vName n) -vName n = cvtName OccName.varName n - --- Constructor function names; this is Haskell source, hence srcDataName -cNameL n = wrapL (cName n) -cName n = cvtName OccName.dataName n - --- Variable *or* constructor names; check by looking at the first char -vcNameL n = wrapL (vcName n) -vcName n = if isVarName n then vName n else cName n - --- Type variable names -tNameL n = wrapL (tName n) -tName n = cvtName OccName.tvName n - --- Type Constructor names -tconNameL n = wrapL (tconName n) -tconName n = cvtName OccName.tcClsName n - -cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName -cvtName ctxt_ns (TH.Name occ flavour) - | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str) - | otherwise - = do { loc <- getL - ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour - ; force rdr_name - ; return rdr_name } - where - occ_str = TH.occString occ - -okOcc :: OccName.NameSpace -> String -> Bool -okOcc ns str - | OccName.isVarNameSpace ns = okVarOcc str - | OccName.isDataConNameSpace ns = okConOcc str - | otherwise = okTcOcc str - --- Determine the name space of a name in a type --- -isVarName :: TH.Name -> Bool -isVarName (TH.Name occ _) - = case TH.occString occ of - "" -> False - (c:_) -> startsVarId c || startsVarSym c - -badOcc :: OccName.NameSpace -> String -> SDoc -badOcc ctxt_ns occ - = text "Illegal" <+> pprNameSpace ctxt_ns - <+> text "name:" <+> quotes (text occ) - -thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName --- This turns a TH Name into a RdrName; used for both binders and occurrences --- See Note [Binders in Template Haskell] --- The passed-in name space tells what the context is expecting; --- use it unless the TH name knows what name-space it comes --- from, in which case use the latter --- --- We pass in a SrcSpan (gotten from the monad) because this function --- is used for *binders* and if we make an Exact Name we want it --- to have a binding site inside it. (cf Trac #5434) --- --- ToDo: we may generate silly RdrNames, by passing a name space --- that doesn't match the string, like VarName ":+", --- which will give confusing error messages later --- --- The strict applications ensure that any buried exceptions get forced -thRdrName loc ctxt_ns th_occ th_name - = case th_name of - TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod - TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ - TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc) - TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc) - TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name - | otherwise -> mkRdrUnqual $! occ - -- We check for built-in syntax here, because the TH - -- user might have written a (NameS "(,,)"), for example - where - occ :: OccName.OccName - occ = mk_occ ctxt_ns th_occ - -thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName -thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) - -thRdrNameGuesses :: TH.Name -> [RdrName] -thRdrNameGuesses (TH.Name occ flavour) - -- This special case for NameG ensures that we don't generate duplicates in the output list - | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod] - | otherwise = [ thRdrName noSrcSpan gns occ_str flavour - | gns <- guessed_nss] - where - -- guessed_ns are the name spaces guessed from looking at the TH name - guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] - | otherwise = [OccName.varName, OccName.tvName] - occ_str = TH.occString occ - --- The packing and unpacking is rather turgid :-( -mk_occ :: OccName.NameSpace -> String -> OccName.OccName -mk_occ ns occ = OccName.mkOccName ns occ - -mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace -mk_ghc_ns TH.DataName = OccName.dataName -mk_ghc_ns TH.TcClsName = OccName.tcClsName -mk_ghc_ns TH.VarName = OccName.varName - -mk_mod :: TH.ModName -> ModuleName -mk_mod mod = mkModuleName (TH.modString mod) - -mk_pkg :: TH.PkgName -> UnitId -mk_pkg pkg = stringToUnitId (TH.pkgString pkg) - -mk_uniq :: Int -> Unique -mk_uniq u = mkUniqueGrimily u - -{- -Note [Binders in Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this TH term construction: - do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name - ; x2 <- TH.newName "x" -- Builds a NameU - ; x3 <- TH.newName "x" - - ; let x = mkName "x" -- mkName :: String -> TH.Name - -- Builds a NameS - - ; return (LamE (..pattern [x1,x2]..) $ - LamE (VarPat x3) $ - ..tuple (x1,x2,x3,x)) } - -It represents the term \[x1,x2]. \x3. (x1,x2,x3,x) - -a) We don't want to complain about "x" being bound twice in - the pattern [x1,x2] -b) We don't want x3 to shadow the x1,x2 -c) We *do* want 'x' (dynamically bound with mkName) to bind - to the innermost binding of "x", namely x3. -d) When pretty printing, we want to print a unique with x1,x2 - etc, else they'll all print as "x" which isn't very helpful - -When we convert all this to HsSyn, the TH.Names are converted with -thRdrName. To achieve (b) we want the binders to be Exact RdrNames. -Achieving (a) is a bit awkward, because - - We must check for duplicate and shadowed names on Names, - not RdrNames, *after* renaming. - See Note [Collect binders only after renaming] in HsUtils - - - But to achieve (a) we must distinguish between the Exact - RdrNames arising from TH and the Unqual RdrNames that would - come from a user writing \[x,x] -> blah - -So in Convert.thRdrName we translate - TH Name RdrName - -------------------------------------------------------- - NameU (arising from newName) --> Exact (Name{ System }) - NameS (arising from mkName) --> Unqual - -Notice that the NameUs generate *System* Names. Then, when -figuring out shadowing and duplicates, we can filter out -System Names. - -This use of System Names fits with other uses of System Names, eg for -temporary variables "a". Since there are lots of things called "a" we -usually want to print the name with the unique, and that is indeed -the way System Names are printed. - -There's a small complication of course; see Note [Looking up Exact -RdrNames] in RnEnv. --} - -{- -Note [Pattern synonym type signatures and Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In general, the type signature of a pattern synonym - - pattern P x1 x2 .. xn = - -is of the form - - forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t - -with the following parts: - - 1) the (possibly empty lists of) universally quantified type - variables `univs` and required constraints `reqs` on them. - 2) the (possibly empty lists of) existentially quantified type - variables `exis` and the provided constraints `provs` on them. - 3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1, - x2, .., xn, respectively - 4) the type `t` of , mentioning only universals from `univs`. - -Due to the two forall quantifiers and constraint contexts (either of -which might be empty), pattern synonym type signatures are treated -specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and -`typecheck/TcSplice.hs`: - - (a) When desugaring a pattern synonym from HsSyn to TH.Dec in - `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.: - - ForallT univs reqs (ForallT exis provs ty) - (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) - - (b) When converting pattern synonyms from TH.Dec to HsSyn in - `hsSyn/Convert.hs`, we convert their TH type signatures back to an - appropriate Haskell pattern synonym type of the form - - forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t - - where initial empty `univs` type variables or an empty `reqs` - constraint context are represented *explicitly* as `() =>`. - - (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always - return its *full* type, i.e.: - - ForallT univs reqs (ForallT exis provs ty) - (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) - -The key point is to always represent a pattern synonym's *full* type -in cases (a) and (c) to make it clear which of the two forall -quantifiers and/or constraint contexts are specified, and which are -not. See GHC's user's guide on pattern synonyms for more information -about pattern synonym type signatures. - --} diff --git a/hsSyn/HsBinds.hs b/hsSyn/HsBinds.hs deleted file mode 100644 --- a/hsSyn/HsBinds.hs +++ /dev/null @@ -1,1193 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[HsBinds]{Abstract syntax: top-level bindings and signatures} - -Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE BangPatterns #-} - -module HsBinds where - -import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, - MatchGroup, pprFunBind, - GRHSs, pprPatBind ) -import {-# SOURCE #-} HsPat ( LPat ) - -import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) -import HsTypes -import PprCore () -import CoreSyn -import TcEvidence -import Type -import Name -import NameSet -import BasicTypes -import Outputable -import SrcLoc -import Var -import Bag -import FastString -import BooleanFormula (LBooleanFormula) -import DynFlags - -import Data.Data hiding ( Fixity ) -import Data.List hiding ( foldr ) -import Data.Ord -import Data.Foldable ( Foldable(..) ) - -{- -************************************************************************ -* * -\subsection{Bindings: @BindGroup@} -* * -************************************************************************ - -Global bindings (where clauses) --} - --- During renaming, we need bindings where the left-hand sides --- have been renamed but the the right-hand sides have not. --- the ...LR datatypes are parametrized by two id types, --- one for the left and one for the right. --- Other than during renaming, these will be the same. - --- | Haskell Local Bindings -type HsLocalBinds id = HsLocalBindsLR id id - --- | Located Haskell local bindings -type LHsLocalBinds id = Located (HsLocalBinds id) - --- | Haskell Local Bindings with separate Left and Right identifier types --- --- Bindings in a 'let' expression --- or a 'where' clause -data HsLocalBindsLR idL idR - = HsValBinds (HsValBindsLR idL idR) - -- ^ Haskell Value Bindings - - -- There should be no pattern synonyms in the HsValBindsLR - -- These are *local* (not top level) bindings - -- The parser accepts them, however, leaving the the - -- renamer to report them - - | HsIPBinds (HsIPBinds idR) - -- ^ Haskell Implicit Parameter Bindings - - | EmptyLocalBinds - -- ^ Empty Local Bindings - -type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) - -deriving instance (DataId idL, DataId idR) - => Data (HsLocalBindsLR idL idR) - --- | Haskell Value Bindings -type HsValBinds id = HsValBindsLR id id - --- | Haskell Value bindings with separate Left and Right identifier types --- (not implicit parameters) --- Used for both top level and nested bindings --- May contain pattern synonym bindings -data HsValBindsLR idL idR - = -- | Value Bindings In - -- - -- Before renaming RHS; idR is always RdrName - -- Not dependency analysed - -- Recursive by default - ValBindsIn - (LHsBindsLR idL idR) [LSig idR] - - -- | Value Bindings Out - -- - -- After renaming RHS; idR can be Name or Id Dependency analysed, - -- later bindings in the list may depend on earlier ones. - | ValBindsOut - [(RecFlag, LHsBinds idL)] - [LSig Name] - -deriving instance (DataId idL, DataId idR) - => Data (HsValBindsLR idL idR) - --- | Located Haskell Binding -type LHsBind id = LHsBindLR id id - --- | Located Haskell Bindings -type LHsBinds id = LHsBindsLR id id - --- | Haskell Binding -type HsBind id = HsBindLR id id - --- | Located Haskell Bindings with separate Left and Right identifier types -type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) - --- | Located Haskell Binding with separate Left and Right identifier types -type LHsBindLR idL idR = Located (HsBindLR idL idR) - -{- Note [Varieties of binding pattern matches] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The distinction between FunBind and PatBind is a bit subtle. FunBind covers -patterns which resemble function bindings and simple variable bindings. - - f x = e - f !x = e - f = e - !x = e -- FunRhs has SrcStrict - x `f` y = e -- FunRhs has Infix - -The actual patterns and RHSs of a FunBind are encoding in fun_matches. -The m_ctxt field of Match will be FunRhs and carries two bits of information -about the match, - - * the mc_strictness field describes whether the match is decorated with a bang - (e.g. `!x = e`) - * the mc_fixity field describes the fixity of the function binder - -By contrast, PatBind represents data constructor patterns, as well as a few -other interesting cases. Namely, - - Just x = e - (x) = e - x :: Ty = e --} - --- | Haskell Binding with separate Left and Right id's -data HsBindLR idL idR - = -- | Function-like Binding - -- - -- FunBind is used for both functions @f x = e@ - -- and variables @f = \x -> e@ - -- and strict variables @!x = x + 1@ - -- - -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'. - -- - -- Reason 2: Instance decls can only have FunBinds, which is convenient. - -- If you change this, you'll need to change e.g. rnMethodBinds - -- - -- But note that the form @f :: a->a = ...@ - -- parses as a pattern binding, just like - -- @(f :: a -> a) = ... @ - -- - -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their - -- 'MatchContext'. See Note [Varieties of binding pattern matches] for - -- details about the relationship between FunBind and PatBind. - -- - -- 'ApiAnnotation.AnnKeywordId's - -- - -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches - -- - -- - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - FunBind { - - fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr - - fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload - - fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of - -- the Id. Example: - -- - -- @ - -- f :: Int -> forall a. a -> a - -- f x y = y - -- @ - -- - -- Then the MatchGroup will have type (Int -> a' -> a') - -- (with a free type variable a'). The coercion will take - -- a CoreExpr of this type and convert it to a CoreExpr of - -- type Int -> forall a'. a' -> a' - -- Notice that the coercion captures the free a'. - - bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains - -- the locally-bound - -- free variables of this defn. - -- See Note [Bind free vars] - - - fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any - } - - -- | Pattern Binding - -- - -- The pattern is never a simple variable; - -- That case is done by FunBind. - -- See Note [Varieties of binding pattern matches] for details about the - -- relationship between FunBind and PatBind. - - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang', - -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - | PatBind { - pat_lhs :: LPat idL, - pat_rhs :: GRHSs idR (LHsExpr idR), - pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs - bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars] - pat_ticks :: ([Tickish Id], [[Tickish Id]]) - -- ^ Ticks to put on the rhs, if any, and ticks to put on - -- the bound variables. - } - - -- | Variable Binding - -- - -- Dictionary binding and suchlike. - -- All VarBinds are introduced by the type checker - | VarBind { - var_id :: idL, - var_rhs :: LHsExpr idR, -- ^ Located only for consistency - var_inline :: Bool -- ^ True <=> inline this binding regardless - -- (used for implication constraints only) - } - - -- | Abstraction Bindings - | AbsBinds { -- Binds abstraction; TRANSLATION - abs_tvs :: [TyVar], - abs_ev_vars :: [EvVar], -- ^ Includes equality constraints - - -- | AbsBinds only gets used when idL = idR after renaming, - -- but these need to be idL's for the collect... code in HsUtil - -- to have the right type - abs_exports :: [ABExport idL], - - -- | Evidence bindings - -- Why a list? See TcInstDcls - -- Note [Typechecking plan for instance declarations] - abs_ev_binds :: [TcEvBinds], - - -- | Typechecked user bindings - abs_binds :: LHsBinds idL - } - - -- | Abstraction Bindings Signature - | AbsBindsSig { -- Simpler form of AbsBinds, used with a type sig - -- in tcPolyCheck. Produces simpler desugaring and - -- is necessary to avoid #11405, comment:3. - abs_tvs :: [TyVar], - abs_ev_vars :: [EvVar], - - abs_sig_export :: idL, -- like abe_poly - abs_sig_prags :: TcSpecPrags, - - abs_sig_ev_bind :: TcEvBinds, -- no list needed here - abs_sig_bind :: LHsBind idL -- always only one, and it's always a - -- FunBind - } - - -- | Patterns Synonym Binding - | PatSynBind (PatSynBind idL idR) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', - -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual', - -- 'ApiAnnotation.AnnWhere' - -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - -deriving instance (DataId idL, DataId idR) - => Data (HsBindLR idL idR) - - -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] - -- - -- Creates bindings for (polymorphic, overloaded) poly_f - -- in terms of monomorphic, non-overloaded mono_f - -- - -- Invariants: - -- 1. 'binds' binds mono_f - -- 2. ftvs is a subset of tvs - -- 3. ftvs includes all tyvars free in ds - -- - -- See Note [AbsBinds] - --- | Abtraction Bindings Export -data ABExport id - = ABE { abe_poly :: id -- ^ Any INLINE pragmas is attached to this Id - , abe_mono :: id - , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] - -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly - , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas - } deriving Data - --- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', --- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' --- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@, --- 'ApiAnnotation.AnnClose' @'}'@, - --- For details on above see note [Api annotations] in ApiAnnotation - --- | Pattern Synonym binding -data PatSynBind idL idR - = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym - psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars] - psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names - psb_def :: LPat idR, -- ^ Right-hand side - psb_dir :: HsPatSynDir idR -- ^ Directionality - } -deriving instance (DataId idL, DataId idR) - => Data (PatSynBind idL idR) - -{- -Note [AbsBinds] -~~~~~~~~~~~~~~~ -The AbsBinds constructor is used in the output of the type checker, to record -*typechecked* and *generalised* bindings. Consider a module M, with this -top-level binding, where there is no type signature for M.reverse, - M.reverse [] = [] - M.reverse (x:xs) = M.reverse xs ++ [x] - -In Hindley-Milner, a recursive binding is typechecked with the *recursive* uses -being *monomorphic*. So after typechecking *and* desugaring we will get something -like this - - M.reverse :: forall a. [a] -> [a] - = /\a. letrec - reverse :: [a] -> [a] = \xs -> case xs of - [] -> [] - (x:xs) -> reverse xs ++ [x] - in reverse - -Notice that 'M.reverse' is polymorphic as expected, but there is a local -definition for plain 'reverse' which is *monomorphic*. The type variable -'a' scopes over the entire letrec. - -That's after desugaring. What about after type checking but before -desugaring? That's where AbsBinds comes in. It looks like this: - - AbsBinds { abs_tvs = [a] - , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a], - , abe_mono = reverse :: [a] -> [a]}] - , abs_binds = { reverse :: [a] -> [a] - = \xs -> case xs of - [] -> [] - (x:xs) -> reverse xs ++ [x] } } - -Here, - * abs_tvs says what type variables are abstracted over the binding group, - just 'a' in this case. - * abs_binds is the *monomorphic* bindings of the group - * abs_exports describes how to get the polymorphic Id 'M.reverse' from the - monomorphic one 'reverse' - -Notice that the *original* function (the polymorphic one you thought -you were defining) appears in the abe_poly field of the -abs_exports. The bindings in abs_binds are for fresh, local, Ids with -a *monomorphic* Id. - -If there is a group of mutually recursive (see Note [Polymorphic -recursion]) functions without type signatures, we get one AbsBinds -with the monomorphic versions of the bindings in abs_binds, and one -element of abe_exports for each variable bound in the mutually -recursive group. This is true even for pattern bindings. Example: - (f,g) = (\x -> x, f) -After type checking we get - AbsBinds { abs_tvs = [a] - , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a - , abe_mono = f :: a -> a } - , ABE { abe_poly = M.g :: forall a. a -> a - , abe_mono = g :: a -> a }] - , abs_binds = { (f,g) = (\x -> x, f) } - -Note [Polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - Rec { f x = ...(g ef)... - - ; g :: forall a. [a] -> [a] - ; g y = ...(f eg)... } - -These bindings /are/ mutually recursive (f calls g, and g calls f). -But we can use the type signature for g to break the recursion, -like this: - - 1. Add g :: forall a. [a] -> [a] to the type environment - - 2. Typecheck the definition of f, all by itself, - including generalising it to find its most general - type, say f :: forall b. b -> b -> [b] - - 3. Extend the type environment with that type for f - - 4. Typecheck the definition of g, all by itself, - checking that it has the type claimed by its signature - -Steps 2 and 4 each generate a separate AbsBinds, so we end -up with - Rec { AbsBinds { ...for f ... } - ; AbsBinds { ...for g ... } } - -This approach allows both f and to call each other -polymorphically, even though only g has a signature. - -We get an AbsBinds that encompasses multiple source-program -bindings only when - * Each binding in the group has at least one binder that - lacks a user type signature - * The group forms a strongly connected component - -Note [ABExport wrapper] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (f,g) = (\x.x, \y.y) -This ultimately desugars to something like this: - tup :: forall a b. (a->a, b->b) - tup = /\a b. (\x:a.x, \y:b.y) - f :: forall a. a -> a - f = /\a. case tup a Any of - (fm::a->a,gm:Any->Any) -> fm - ...similarly for g... - -The abe_wrap field deals with impedance-matching between - (/\a b. case tup a b of { (f,g) -> f }) -and the thing we really want, which may have fewer type -variables. The action happens in TcBinds.mkExport. - -Note [Bind free vars] -~~~~~~~~~~~~~~~~~~~~~ -The bind_fvs field of FunBind and PatBind records the free variables -of the definition. It is used for the following purposes - -a) Dependency analysis prior to type checking - (see TcBinds.tc_group) - -b) Deciding whether we can do generalisation of the binding - (see TcBinds.decideGeneralisationPlan) - -c) Deciding whether the binding can be used in static forms - (see TcExpr.checkClosedInStaticForm for the HsStatic case and - TcBinds.isClosedBndrGroup). - -Specifically, - - * bind_fvs includes all free vars that are defined in this module - (including top-level things and lexically scoped type variables) - - * bind_fvs excludes imported vars; this is just to keep the set smaller - - * Before renaming, and after typechecking, the field is unused; - it's just an error thunk --} - -instance (OutputableBndrId idL, OutputableBndrId idR) - => Outputable (HsLocalBindsLR idL idR) where - ppr (HsValBinds bs) = ppr bs - ppr (HsIPBinds bs) = ppr bs - ppr EmptyLocalBinds = empty - -instance (OutputableBndrId idL, OutputableBndrId idR) - => Outputable (HsValBindsLR idL idR) where - ppr (ValBindsIn binds sigs) - = pprDeclList (pprLHsBindsForUser binds sigs) - - ppr (ValBindsOut sccs sigs) - = getPprStyle $ \ sty -> - if debugStyle sty then -- Print with sccs showing - vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) - else - pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) - where - ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds - pp_rec Recursive = text "rec" - pp_rec NonRecursive = text "nonrec" - -pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR) - => LHsBindsLR idL idR -> SDoc -pprLHsBinds binds - | isEmptyLHsBinds binds = empty - | otherwise = pprDeclList (map ppr (bagToList binds)) - -pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR, - OutputableBndrId id2) - => LHsBindsLR idL idR -> [LSig id2] -> [SDoc] --- pprLHsBindsForUser is different to pprLHsBinds because --- a) No braces: 'let' and 'where' include a list of HsBindGroups --- and we don't want several groups of bindings each --- with braces around --- b) Sort by location before printing --- c) Include signatures -pprLHsBindsForUser binds sigs - = map snd (sort_by_loc decls) - where - - decls :: [(SrcSpan, SDoc)] - decls = [(loc, ppr sig) | L loc sig <- sigs] ++ - [(loc, ppr bind) | L loc bind <- bagToList binds] - - sort_by_loc decls = sortBy (comparing fst) decls - -pprDeclList :: [SDoc] -> SDoc -- Braces with a space --- Print a bunch of declarations --- One could choose { d1; d2; ... }, using 'sep' --- or d1 --- d2 --- .. --- using vcat --- At the moment we chose the latter --- Also we do the 'pprDeeperList' thing. -pprDeclList ds = pprDeeperList vcat ds - ------------- -emptyLocalBinds :: HsLocalBindsLR a b -emptyLocalBinds = EmptyLocalBinds - -isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool -isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds -isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds -isEmptyLocalBinds EmptyLocalBinds = True - -eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool -eqEmptyLocalBinds EmptyLocalBinds = True -eqEmptyLocalBinds _ = False - -isEmptyValBinds :: HsValBindsLR a b -> Bool -isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs -isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs - -emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b -emptyValBindsIn = ValBindsIn emptyBag [] -emptyValBindsOut = ValBindsOut [] [] - -emptyLHsBinds :: LHsBindsLR idL idR -emptyLHsBinds = emptyBag - -isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool -isEmptyLHsBinds = isEmptyBag - ------------- -plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a -plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2) - = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2) -plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2) - = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2) -plusHsValBinds _ _ - = panic "HsBinds.plusHsValBinds" - -{- -What AbsBinds means -~~~~~~~~~~~~~~~~~~~ - AbsBinds tvs - [d1,d2] - [(tvs1, f1p, f1m), - (tvs2, f2p, f2m)] - BIND -means - - f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND - in fm - - gp = ...same again, with gm instead of fm - -This is a pretty bad translation, because it duplicates all the bindings. -So the desugarer tries to do a better job: - - fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of - (fm,gm) -> fm - ..ditto for gp.. - - tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND - in (fm,gm) --} - -instance (OutputableBndrId idL, OutputableBndrId idR) - => Outputable (HsBindLR idL idR) where - ppr mbind = ppr_monobind mbind - -ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR) - => HsBindLR idL idR -> SDoc - -ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) - = pprPatBind pat grhss -ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) - = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] -ppr_monobind (FunBind { fun_id = fun, - fun_co_fn = wrap, - fun_matches = matches, - fun_tick = ticks }) - = pprTicks empty (if null ticks then empty - else text "-- ticks = " <> ppr ticks) - $$ ifPprDebug (pprBndr LetBind (unLoc fun)) - $$ pprFunBind matches - $$ ifPprDebug (ppr wrap) -ppr_monobind (PatSynBind psb) = ppr psb -ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars - , abs_exports = exports, abs_binds = val_binds - , abs_ev_binds = ev_binds }) - = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintTypecheckerElaboration dflags then - -- Show extra information (bug number: #10662) - hang (text "AbsBinds" <+> brackets (interpp'SP tyvars) - <+> brackets (interpp'SP dictvars)) - 2 $ braces $ vcat - [ text "Exports:" <+> - brackets (sep (punctuate comma (map ppr exports))) - , text "Exported types:" <+> - vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] - , text "Binds:" <+> pprLHsBinds val_binds - , text "Evidence:" <+> ppr ev_binds ] - else - pprLHsBinds val_binds -ppr_monobind (AbsBindsSig { abs_tvs = tyvars - , abs_ev_vars = dictvars - , abs_sig_export = poly_id - , abs_sig_ev_bind = ev_bind - , abs_sig_bind = bind }) - = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintTypecheckerElaboration dflags then - hang (text "AbsBindsSig" <+> brackets (interpp'SP tyvars) - <+> brackets (interpp'SP dictvars)) - 2 $ braces $ vcat - [ text "Exported type:" <+> pprBndr LetBind poly_id - , text "Bind:" <+> ppr bind - , text "Evidence:" <+> ppr ev_bind ] - else - ppr bind - -instance (OutputableBndr id) => Outputable (ABExport id) where - ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) - = vcat [ ppr gbl <+> text "<=" <+> ppr lcl - , nest 2 (pprTcSpecPrags prags) - , nest 2 (text "wrap:" <+> ppr wrap)] - -instance (OutputableBndr idL, OutputableBndrId idR) - => Outputable (PatSynBind idL idR) where - ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, - psb_dir = dir }) - = ppr_lhs <+> ppr_rhs - where - ppr_lhs = text "pattern" <+> ppr_details - ppr_simple syntax = syntax <+> ppr pat - - ppr_details = case details of - InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2] - PrefixPatSyn vs -> hsep (pprPrefixOcc psyn : map ppr vs) - RecordPatSyn vs -> - pprPrefixOcc psyn - <> braces (sep (punctuate comma (map ppr vs))) - - ppr_rhs = case dir of - Unidirectional -> ppr_simple (text "<-") - ImplicitBidirectional -> ppr_simple equals - ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ - (nest 2 $ pprFunBind mg) - -pprTicks :: SDoc -> SDoc -> SDoc --- Print stuff about ticks only when -dppr-debug is on, to avoid --- them appearing in error messages (from the desugarer); see Trac # 3263 --- Also print ticks in dumpStyle, so that -ddump-hpc actually does --- something useful. -pprTicks pp_no_debug pp_when_debug - = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty - then pp_when_debug - else pp_no_debug) - -{- -************************************************************************ -* * - Implicit parameter bindings -* * -************************************************************************ --} - --- | Haskell Implicit Parameter Bindings -data HsIPBinds id - = IPBinds - [LIPBind id] - TcEvBinds -- Only in typechecker output; binds - -- uses of the implicit parameters -deriving instance (DataId id) => Data (HsIPBinds id) - -isEmptyIPBinds :: HsIPBinds id -> Bool -isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds - --- | Located Implicit Parameter Binding -type LIPBind id = Located (IPBind id) --- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a --- list - --- For details on above see note [Api annotations] in ApiAnnotation - --- | Implicit parameter bindings. --- --- These bindings start off as (Left "x") in the parser and stay --- that way until after type-checking when they are replaced with --- (Right d), where "d" is the name of the dictionary holding the --- evidence for the implicit parameter. --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' - --- For details on above see note [Api annotations] in ApiAnnotation -data IPBind id - = IPBind (Either (Located HsIPName) id) (LHsExpr id) -deriving instance (DataId name) => Data (IPBind name) - -instance (OutputableBndrId id ) => Outputable (HsIPBinds id) where - ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) - $$ ifPprDebug (ppr ds) - -instance (OutputableBndrId id ) => Outputable (IPBind id) where - ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) - where name = case lr of - Left (L _ ip) -> pprBndr LetBind ip - Right id -> pprBndr LetBind id - -{- -************************************************************************ -* * -\subsection{@Sig@: type signatures and value-modifying user pragmas} -* * -************************************************************************ - -It is convenient to lump ``value-modifying'' user-pragmas (e.g., -``specialise this function to these four types...'') in with type -signatures. Then all the machinery to move them into place, etc., -serves for both. --} - --- | Located Signature -type LSig name = Located (Sig name) - --- | Signatures and pragmas -data Sig name - = -- | An ordinary type signature - -- - -- > f :: Num a => a -> a - -- - -- After renaming, this list of Names contains the named and unnamed - -- wildcards brought into scope by this signature. For a signature - -- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@ - -- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@ - -- are then both replaced with fresh meta vars in the type. Their names - -- are stored in the type signature that brought them into scope, in - -- this third field to be more specific. - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnComma' - - -- For details on above see note [Api annotations] in ApiAnnotation - TypeSig - [Located name] -- LHS of the signature; e.g. f,g,h :: blah - (LHsSigWcType name) -- RHS of the signature; can have wildcards - - -- | A pattern synonym type signature - -- - -- > pattern Single :: () => (Show a) => a -> [a] - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall' - -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | PatSynSig [Located name] (LHsSigType name) - -- P :: forall a b. Req => Prov => ty - - -- | A signature for a class method - -- False: ordinary class-method signature - -- True: generic-default class method signature - -- e.g. class C a where - -- op :: a -> a -- Ordinary - -- default op :: Eq a => a -> a -- Generic default - -- No wildcards allowed here - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', - -- 'ApiAnnotation.AnnDcolon' - | ClassOpSig Bool [Located name] (LHsSigType name) - - -- | A type signature in generated code, notably the code - -- generated for record selectors. We simply record - -- the desired Id itself, replete with its name, type - -- and IdDetails. Otherwise it's just like a type - -- signature: there should be an accompanying binding - | IdSig Id - - -- | An ordinary fixity declaration - -- - -- > infixl 8 *** - -- - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix', - -- 'ApiAnnotation.AnnVal' - - -- For details on above see note [Api annotations] in ApiAnnotation - | FixSig (FixitySig name) - - -- | An inline pragma - -- - -- > {#- INLINE f #-} - -- - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@, - -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | InlineSig (Located name) -- Function name - InlinePragma -- Never defaultInlinePragma - - -- | A specialisation pragma - -- - -- > {-# SPECIALISE f :: Int -> Int #-} - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, - -- 'ApiAnnotation.AnnTilde', - -- 'ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@, - -- 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | SpecSig (Located name) -- Specialise a function or datatype ... - [LHsSigType name] -- ... to these types - InlinePragma -- The pragma on SPECIALISE_INLINE form. - -- If it's just defaultInlinePragma, then we said - -- SPECIALISE, not SPECIALISE_INLINE - - -- | A specialisation pragma for instance declarations only - -- - -- > {-# SPECIALISE instance Eq [Int] #-} - -- - -- (Class tys); should be a specialisation of the - -- current instance declaration - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | SpecInstSig SourceText (LHsSigType name) - -- Note [Pragma source text] in BasicTypes - - -- | A minimal complete definition pragma - -- - -- > {-# MINIMAL a | (b, c | (d | e)) #-} - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | MinimalSig SourceText (LBooleanFormula (Located name)) - -- Note [Pragma source text] in BasicTypes - - -- | A "set cost centre" pragma for declarations - -- - -- > {-# SCC funName #-} - -- - -- or - -- - -- > {-# SCC funName "cost_centre_name" #-} - - | SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes - (Located name) -- Function name - (Maybe (Located StringLiteral)) - -- | A complete match pragma - -- - -- > {-# COMPLETE C, D [:: T] #-} - -- - -- Used to inform the pattern match checker about additional - -- complete matchings which, for example, arise from pattern - -- synonym definitions. - | CompleteMatchSig SourceText (Located [Located name]) (Maybe (Located name)) - -deriving instance (DataId name) => Data (Sig name) - --- | Located Fixity Signature -type LFixitySig name = Located (FixitySig name) - --- | Fixity Signature -data FixitySig name = FixitySig [Located name] Fixity - deriving Data - --- | Type checker Specialisation Pragmas --- --- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer -data TcSpecPrags - = IsDefaultMethod -- ^ Super-specialised: a default method should - -- be macro-expanded at every call site - | SpecPrags [LTcSpecPrag] - deriving Data - --- | Located Type checker Specification Pragmas -type LTcSpecPrag = Located TcSpecPrag - --- | Type checker Specification Pragma -data TcSpecPrag - = SpecPrag - Id - HsWrapper - InlinePragma - -- ^ The Id to be specialised, an wrapper that specialises the - -- polymorphic function, and inlining spec for the specialised function - deriving Data - -noSpecPrags :: TcSpecPrags -noSpecPrags = SpecPrags [] - -hasSpecPrags :: TcSpecPrags -> Bool -hasSpecPrags (SpecPrags ps) = not (null ps) -hasSpecPrags IsDefaultMethod = False - -isDefaultMethod :: TcSpecPrags -> Bool -isDefaultMethod IsDefaultMethod = True -isDefaultMethod (SpecPrags {}) = False - - -isFixityLSig :: LSig name -> Bool -isFixityLSig (L _ (FixSig {})) = True -isFixityLSig _ = False - -isTypeLSig :: LSig name -> Bool -- Type signatures -isTypeLSig (L _(TypeSig {})) = True -isTypeLSig (L _(ClassOpSig {})) = True -isTypeLSig (L _(IdSig {})) = True -isTypeLSig _ = False - -isSpecLSig :: LSig name -> Bool -isSpecLSig (L _(SpecSig {})) = True -isSpecLSig _ = False - -isSpecInstLSig :: LSig name -> Bool -isSpecInstLSig (L _ (SpecInstSig {})) = True -isSpecInstLSig _ = False - -isPragLSig :: LSig name -> Bool --- Identifies pragmas -isPragLSig (L _ (SpecSig {})) = True -isPragLSig (L _ (InlineSig {})) = True -isPragLSig (L _ (SCCFunSig {})) = True -isPragLSig (L _ (CompleteMatchSig {})) = True -isPragLSig _ = False - -isInlineLSig :: LSig name -> Bool --- Identifies inline pragmas -isInlineLSig (L _ (InlineSig {})) = True -isInlineLSig _ = False - -isMinimalLSig :: LSig name -> Bool -isMinimalLSig (L _ (MinimalSig {})) = True -isMinimalLSig _ = False - -isSCCFunSig :: LSig name -> Bool -isSCCFunSig (L _ (SCCFunSig {})) = True -isSCCFunSig _ = False - -isCompleteMatchSig :: LSig name -> Bool -isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True -isCompleteMatchSig _ = False - -hsSigDoc :: Sig name -> SDoc -hsSigDoc (TypeSig {}) = text "type signature" -hsSigDoc (PatSynSig {}) = text "pattern synonym signature" -hsSigDoc (ClassOpSig is_deflt _ _) - | is_deflt = text "default type signature" - | otherwise = text "class method signature" -hsSigDoc (IdSig {}) = text "id signature" -hsSigDoc (SpecSig {}) = text "SPECIALISE pragma" -hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" -hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma" -hsSigDoc (FixSig {}) = text "fixity declaration" -hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" -hsSigDoc (SCCFunSig {}) = text "SCC pragma" -hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" - -{- -Check if signatures overlap; this is used when checking for duplicate -signatures. Since some of the signatures contain a list of names, testing for -equality is not enough -- we have to check if they overlap. --} - -instance (OutputableBndrId name ) => Outputable (Sig name) where - ppr sig = ppr_sig sig - -ppr_sig :: (OutputableBndrId name ) => Sig name -> SDoc -ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (ClassOpSig is_deflt vars ty) - | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) - | otherwise = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) -ppr_sig (FixSig fix_sig) = ppr fix_sig -ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec })) - = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) - (interpp'SP ty) inl) - where - pragmaSrc = case spec of - EmptyInlineSpec -> "{-# SPECIALISE" - _ -> "{-# SPECIALISE_INLINE" -ppr_sig (InlineSig var inl) - = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl - <+> pprPrefixOcc (unLoc var)) -ppr_sig (SpecInstSig src ty) - = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty) -ppr_sig (MinimalSig src bf) - = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) -ppr_sig (PatSynSig names sig_ty) - = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) -ppr_sig (SCCFunSig src fn mlabel) - = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel ) -ppr_sig (CompleteMatchSig src cs mty) - = pragSrcBrackets src "{-# COMPLETE" - ((hsep (punctuate comma (map ppr (unLoc cs)))) - <+> opt_sig) - where - opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty - -instance OutputableBndr name => Outputable (FixitySig name) where - ppr (FixitySig names fixity) = sep [ppr fixity, pprops] - where - pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) - -pragBrackets :: SDoc -> SDoc -pragBrackets doc = text "{-#" <+> doc <+> text "#-}" - --- | Using SourceText in case the pragma was spelled differently or used mixed --- case -pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc -pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}" -pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}" - -pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc -pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] - where - pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) - -pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc -pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty - where - pp_inl | isDefaultInlinePragma inl = empty - | otherwise = pprInline inl - -pprTcSpecPrags :: TcSpecPrags -> SDoc -pprTcSpecPrags IsDefaultMethod = text "" -pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) - -instance Outputable TcSpecPrag where - ppr (SpecPrag var _ inl) - = text "SPECIALIZE" <+> pprSpec var (text "") inl - -pprMinimalSig :: (OutputableBndr name) - => LBooleanFormula (Located name) -> SDoc -pprMinimalSig (L _ bf) = ppr (fmap unLoc bf) - -{- -************************************************************************ -* * -\subsection[PatSynBind]{A pattern synonym definition} -* * -************************************************************************ --} - --- | Haskell Pattern Synonym Details -data HsPatSynDetails a - = InfixPatSyn a a -- ^ Infix Pattern Synonym - | PrefixPatSyn [a] -- ^ Prefix Pattern Synonym - | RecordPatSyn [RecordPatSynField a] -- ^ Record Pattern Synonym - deriving Data - - --- See Note [Record PatSyn Fields] --- | Record Pattern Synonym Field -data RecordPatSynField a - = RecordPatSynField { - recordPatSynSelectorId :: a -- Selector name visible in rest of the file - , recordPatSynPatVar :: a - -- Filled in by renamer, the name used internally - -- by the pattern - } deriving Data - - - -{- -Note [Record PatSyn Fields] - -Consider the following two pattern synonyms. - -pattern P x y = ([x,True], [y,'v']) -pattern Q{ x, y } =([x,True], [y,'v']) - -In P, we just have two local binders, x and y. - -In Q, we have local binders but also top-level record selectors -x :: ([Bool], [Char]) -> Bool and similarly for y. - -It would make sense to support record-like syntax - -pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) - -when we have a different name for the local and top-level binder -the distinction between the two names clear - --} -instance Functor RecordPatSynField where - fmap f (RecordPatSynField { recordPatSynSelectorId = visible - , recordPatSynPatVar = hidden }) - = RecordPatSynField { recordPatSynSelectorId = f visible - , recordPatSynPatVar = f hidden } - -instance Outputable a => Outputable (RecordPatSynField a) where - ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v - -instance Foldable RecordPatSynField where - foldMap f (RecordPatSynField { recordPatSynSelectorId = visible - , recordPatSynPatVar = hidden }) - = f visible `mappend` f hidden - -instance Traversable RecordPatSynField where - traverse f (RecordPatSynField { recordPatSynSelectorId =visible - , recordPatSynPatVar = hidden }) - = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id - , recordPatSynPatVar = pat_var }) - <$> f visible <*> f hidden - - -instance Functor HsPatSynDetails where - fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right) - fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args) - fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args) - -instance Foldable HsPatSynDetails where - foldMap f (InfixPatSyn left right) = f left `mappend` f right - foldMap f (PrefixPatSyn args) = foldMap f args - foldMap f (RecordPatSyn args) = foldMap (foldMap f) args - - foldl1 f (InfixPatSyn left right) = left `f` right - foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args - foldl1 f (RecordPatSyn args) = - Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args) - - foldr1 f (InfixPatSyn left right) = left `f` right - foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args - foldr1 f (RecordPatSyn args) = - Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args) - - length (InfixPatSyn _ _) = 2 - length (PrefixPatSyn args) = Data.List.length args - length (RecordPatSyn args) = Data.List.length args - - null (InfixPatSyn _ _) = False - null (PrefixPatSyn args) = Data.List.null args - null (RecordPatSyn args) = Data.List.null args - - toList (InfixPatSyn left right) = [left, right] - toList (PrefixPatSyn args) = args - toList (RecordPatSyn args) = foldMap toList args - -instance Traversable HsPatSynDetails where - traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right - traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args - traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args - --- | Haskell Pattern Synonym Direction -data HsPatSynDir id - = Unidirectional - | ImplicitBidirectional - | ExplicitBidirectional (MatchGroup id (LHsExpr id)) -deriving instance (DataId id) => Data (HsPatSynDir id) diff --git a/hsSyn/HsDecls.hs b/hsSyn/HsDecls.hs deleted file mode 100644 --- a/hsSyn/HsDecls.hs +++ /dev/null @@ -1,2104 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, - DeriveTraversable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Abstract syntax of global declarations. --- --- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, --- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. -module HsDecls ( - -- * Toplevel declarations - HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, - HsDerivingClause(..), LHsDerivingClause, - - -- ** Class or type declarations - TyClDecl(..), LTyClDecl, - TyClGroup(..), mkTyClGroup, emptyTyClGroup, - tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, - isClassDecl, isDataDecl, isSynDecl, tcdName, - isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, - isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, - tyFamInstDeclName, tyFamInstDeclLName, - countTyClDecls, pprTyClDeclFlavour, - tyClDeclLName, tyClDeclTyVars, - hsDeclHasCusk, famDeclHasCusk, - FamilyDecl(..), LFamilyDecl, - - -- ** Instance declarations - InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..), - TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, - DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, - TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, - HsTyPats, - LClsInstDecl, ClsInstDecl(..), - - -- ** Standalone deriving declarations - DerivDecl(..), LDerivDecl, - -- ** @RULE@ declarations - LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr, - collectRuleBndrSigTys, - flattenRuleDecls, pprFullRuleName, - -- ** @VECTORISE@ declarations - VectDecl(..), LVectDecl, - lvectDeclName, lvectInstDecl, - -- ** @default@ declarations - DefaultDecl(..), LDefaultDecl, - -- ** Template haskell declaration splice - SpliceExplicitFlag(..), - SpliceDecl(..), LSpliceDecl, - -- ** Foreign function interface declarations - ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), - noForeignImportCoercionYet, noForeignExportCoercionYet, - CImportSpec(..), - -- ** Data-constructor declarations - ConDecl(..), LConDecl, - HsConDeclDetails, hsConDeclArgTys, - getConNames, - getConDetails, - gadtDeclDetails, - -- ** Document comments - DocDecl(..), LDocDecl, docDeclDoc, - -- ** Deprecations - WarnDecl(..), LWarnDecl, - WarnDecls(..), LWarnDecls, - -- ** Annotations - AnnDecl(..), LAnnDecl, - AnnProvenance(..), annProvenanceName_maybe, - -- ** Role annotations - RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName, - -- ** Injective type families - FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn, - resultVariableName, - - -- * Grouping - HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls - - ) where - --- friends: -import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, - pprSpliceDecl ) - -- Because Expr imports Decls via HsBracket - -import HsBinds -import HsTypes -import HsDoc -import TyCon -import Name -import BasicTypes -import Coercion -import ForeignCall -import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId ) -import NameSet - --- others: -import InstEnv -import Class -import Outputable -import Util -import SrcLoc - -import Bag -import Maybes -import Data.Data hiding (TyCon,Fixity, Infix) - -{- -************************************************************************ -* * -\subsection[HsDecl]{Declarations} -* * -************************************************************************ --} - -type LHsDecl id = Located (HsDecl id) - -- ^ When in a list this may have - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' - -- - --- For details on above see note [Api annotations] in ApiAnnotation - --- | A Haskell Declaration -data HsDecl id - = TyClD (TyClDecl id) -- ^ Type or Class Declaration - | InstD (InstDecl id) -- ^ Instance declaration - | DerivD (DerivDecl id) -- ^ Deriving declaration - | ValD (HsBind id) -- ^ Value declaration - | SigD (Sig id) -- ^ Signature declaration - | DefD (DefaultDecl id) -- ^ 'default' declaration - | ForD (ForeignDecl id) -- ^ Foreign declaration - | WarningD (WarnDecls id) -- ^ Warning declaration - | AnnD (AnnDecl id) -- ^ Annotation declaration - | RuleD (RuleDecls id) -- ^ Rule declaration - | VectD (VectDecl id) -- ^ Vectorise declaration - | SpliceD (SpliceDecl id) -- ^ Splice declaration - -- (Includes quasi-quotes) - | DocD (DocDecl) -- ^ Documentation comment declaration - | RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration -deriving instance (DataId id) => Data (HsDecl id) - - --- NB: all top-level fixity decls are contained EITHER --- EITHER SigDs --- OR in the ClassDecls in TyClDs --- --- The former covers --- a) data constructors --- b) class methods (but they can be also done in the --- signatures of class decls) --- c) imported functions (that have an IfacSig) --- d) top level decls --- --- The latter is for class methods only - --- | Haskell Group --- --- A 'HsDecl' is categorised into a 'HsGroup' before being --- fed to the renamer. -data HsGroup id - = HsGroup { - hs_valds :: HsValBinds id, - hs_splcds :: [LSpliceDecl id], - - hs_tyclds :: [TyClGroup id], - -- A list of mutually-recursive groups; - -- This includes `InstDecl`s as well; - -- Parser generates a singleton list; - -- renamer does dependency analysis - - hs_derivds :: [LDerivDecl id], - - hs_fixds :: [LFixitySig id], - -- Snaffled out of both top-level fixity signatures, - -- and those in class declarations - - hs_defds :: [LDefaultDecl id], - hs_fords :: [LForeignDecl id], - hs_warnds :: [LWarnDecls id], - hs_annds :: [LAnnDecl id], - hs_ruleds :: [LRuleDecls id], - hs_vects :: [LVectDecl id], - - hs_docs :: [LDocDecl] - } -deriving instance (DataId id) => Data (HsGroup id) - -emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a -emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } -emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } - -hsGroupInstDecls :: HsGroup id -> [LInstDecl id] -hsGroupInstDecls = (=<<) group_instds . hs_tyclds - -emptyGroup = HsGroup { hs_tyclds = [], - hs_derivds = [], - hs_fixds = [], hs_defds = [], hs_annds = [], - hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [], - hs_valds = error "emptyGroup hs_valds: Can't happen", - hs_splcds = [], - hs_docs = [] } - -appendGroups :: HsGroup a -> HsGroup a -> HsGroup a -appendGroups - HsGroup { - hs_valds = val_groups1, - hs_splcds = spliceds1, - hs_tyclds = tyclds1, - hs_derivds = derivds1, - hs_fixds = fixds1, - hs_defds = defds1, - hs_annds = annds1, - hs_fords = fords1, - hs_warnds = warnds1, - hs_ruleds = rulds1, - hs_vects = vects1, - hs_docs = docs1 } - HsGroup { - hs_valds = val_groups2, - hs_splcds = spliceds2, - hs_tyclds = tyclds2, - hs_derivds = derivds2, - hs_fixds = fixds2, - hs_defds = defds2, - hs_annds = annds2, - hs_fords = fords2, - hs_warnds = warnds2, - hs_ruleds = rulds2, - hs_vects = vects2, - hs_docs = docs2 } - = - HsGroup { - hs_valds = val_groups1 `plusHsValBinds` val_groups2, - hs_splcds = spliceds1 ++ spliceds2, - hs_tyclds = tyclds1 ++ tyclds2, - hs_derivds = derivds1 ++ derivds2, - hs_fixds = fixds1 ++ fixds2, - hs_annds = annds1 ++ annds2, - hs_defds = defds1 ++ defds2, - hs_fords = fords1 ++ fords2, - hs_warnds = warnds1 ++ warnds2, - hs_ruleds = rulds1 ++ rulds2, - hs_vects = vects1 ++ vects2, - hs_docs = docs1 ++ docs2 } - -instance (OutputableBndrId name) => Outputable (HsDecl name) where - ppr (TyClD dcl) = ppr dcl - ppr (ValD binds) = ppr binds - ppr (DefD def) = ppr def - ppr (InstD inst) = ppr inst - ppr (DerivD deriv) = ppr deriv - ppr (ForD fd) = ppr fd - ppr (SigD sd) = ppr sd - ppr (RuleD rd) = ppr rd - ppr (VectD vect) = ppr vect - ppr (WarningD wd) = ppr wd - ppr (AnnD ad) = ppr ad - ppr (SpliceD dd) = ppr dd - ppr (DocD doc) = ppr doc - ppr (RoleAnnotD ra) = ppr ra - -instance (OutputableBndrId name) => Outputable (HsGroup name) where - ppr (HsGroup { hs_valds = val_decls, - hs_tyclds = tycl_decls, - hs_derivds = deriv_decls, - hs_fixds = fix_decls, - hs_warnds = deprec_decls, - hs_annds = ann_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls }) - = vcat_mb empty - [ppr_ds fix_decls, ppr_ds default_decls, - ppr_ds deprec_decls, ppr_ds ann_decls, - ppr_ds rule_decls, - ppr_ds vect_decls, - if isEmptyValBinds val_decls - then Nothing - else Just (ppr val_decls), - ppr_ds (tyClGroupTyClDecls tycl_decls), - ppr_ds (tyClGroupInstDecls tycl_decls), - ppr_ds deriv_decls, - ppr_ds foreign_decls] - where - ppr_ds :: Outputable a => [a] -> Maybe SDoc - ppr_ds [] = Nothing - ppr_ds ds = Just (vcat (map ppr ds)) - - vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc - -- Concatenate vertically with white-space between non-blanks - vcat_mb _ [] = empty - vcat_mb gap (Nothing : ds) = vcat_mb gap ds - vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds - --- | Located Splice Declaration -type LSpliceDecl name = Located (SpliceDecl name) - --- | Splice Declaration -data SpliceDecl id - = SpliceDecl -- Top level splice - (Located (HsSplice id)) - SpliceExplicitFlag -deriving instance (DataId id) => Data (SpliceDecl id) - -instance (OutputableBndrId name) => Outputable (SpliceDecl name) where - ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f - -{- -************************************************************************ -* * - Type and class declarations -* * -************************************************************************ - -Note [The Naming story] -~~~~~~~~~~~~~~~~~~~~~~~ -Here is the story about the implicit names that go with type, class, -and instance decls. It's a bit tricky, so pay attention! - -"Implicit" (or "system") binders -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Each data type decl defines - a worker name for each constructor - to-T and from-T convertors - Each class decl defines - a tycon for the class - a data constructor for that tycon - the worker for that constructor - a selector for each superclass - -All have occurrence names that are derived uniquely from their parent -declaration. - -None of these get separate definitions in an interface file; they are -fully defined by the data or class decl. But they may *occur* in -interface files, of course. Any such occurrence must haul in the -relevant type or class decl. - -Plan of attack: - - Ensure they "point to" the parent data/class decl - when loading that decl from an interface file - (See RnHiFiles.getSysBinders) - - - When typechecking the decl, we build the implicit TyCons and Ids. - When doing so we look them up in the name cache (RnEnv.lookupSysName), - to ensure correct module and provenance is set - -These are the two places that we have to conjure up the magic derived -names. (The actual magic is in OccName.mkWorkerOcc, etc.) - -Default methods -~~~~~~~~~~~~~~~ - - Occurrence name is derived uniquely from the method name - E.g. $dmmax - - - If there is a default method name at all, it's recorded in - the ClassOpSig (in HsBinds), in the DefMethInfo field. - (DefMethInfo is defined in Class.hs) - -Source-code class decls and interface-code class decls are treated subtly -differently, which has given me a great deal of confusion over the years. -Here's the deal. (We distinguish the two cases because source-code decls -have (Just binds) in the tcdMeths field, whereas interface decls have Nothing. - -In *source-code* class declarations: - - - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName - This is done by RdrHsSyn.mkClassOpSigDM - - - The renamer renames it to a Name - - - During typechecking, we generate a binding for each $dm for - which there's a programmer-supplied default method: - class Foo a where - op1 :: - op2 :: - op1 = ... - We generate a binding for $dmop1 but not for $dmop2. - The Class for Foo has a Nothing for op2 and - a Just ($dm_op1, VanillaDM) for op1. - The Name for $dmop2 is simply discarded. - -In *interface-file* class declarations: - - When parsing, we see if there's an explicit programmer-supplied default method - because there's an '=' sign to indicate it: - class Foo a where - op1 = :: -- NB the '=' - op2 :: - We use this info to generate a DefMeth with a suitable RdrName for op1, - and a NoDefMeth for op2 - - The interface file has a separate definition for $dmop1, with unfolding etc. - - The renamer renames it to a Name. - - The renamer treats $dmop1 as a free variable of the declaration, so that - the binding for $dmop1 will be sucked in. (See RnHsSyn.tyClDeclFVs) - This doesn't happen for source code class decls, because they *bind* the default method. - -Dictionary functions -~~~~~~~~~~~~~~~~~~~~ -Each instance declaration gives rise to one dictionary function binding. - -The type checker makes up new source-code instance declarations -(e.g. from 'deriving' or generic default methods --- see -TcInstDcls.tcInstDecls1). So we can't generate the names for -dictionary functions in advance (we don't know how many we need). - -On the other hand for interface-file instance declarations, the decl -specifies the name of the dictionary function, and it has a binding elsewhere -in the interface file: - instance {Eq Int} = dEqInt - dEqInt :: {Eq Int} - -So again we treat source code and interface file code slightly differently. - -Source code: - - Source code instance decls have a Nothing in the (Maybe name) field - (see data InstDecl below) - - - The typechecker makes up a Local name for the dict fun for any source-code - instance decl, whether it comes from a source-code instance decl, or whether - the instance decl is derived from some other construct (e.g. 'deriving'). - - - The occurrence name it chooses is derived from the instance decl (just for - documentation really) --- e.g. dNumInt. Two dict funs may share a common - occurrence name, but will have different uniques. E.g. - instance Foo [Int] where ... - instance Foo [Bool] where ... - These might both be dFooList - - - The CoreTidy phase externalises the name, and ensures the occurrence name is - unique (this isn't special to dict funs). So we'd get dFooList and dFooList1. - - - We can take this relaxed approach (changing the occurrence name later) - because dict fun Ids are not captured in a TyCon or Class (unlike default - methods, say). Instead, they are kept separately in the InstEnv. This - makes it easy to adjust them after compiling a module. (Once we've finished - compiling that module, they don't change any more.) - - -Interface file code: - - The instance decl gives the dict fun name, so the InstDecl has a (Just name) - in the (Maybe name) field. - - - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we - suck in the dfun binding --} - --- | Located Declaration of a Type or Class -type LTyClDecl name = Located (TyClDecl name) - --- | A type or class declaration. -data TyClDecl name - = -- | @type/data family T :: *->*@ - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnData', - -- 'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP', - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP', - -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow', - -- 'ApiAnnotation.AnnVbar' - - -- For details on above see note [Api annotations] in ApiAnnotation - FamDecl { tcdFam :: FamilyDecl name } - - | -- | @type@ declaration - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnEqual', - - -- For details on above see note [Api annotations] in ApiAnnotation - SynDecl { tcdLName :: Located name -- ^ Type constructor - , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type - -- these include outer binders - , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdRhs :: LHsType name -- ^ RHS of type declaration - , tcdFVs :: PostRn name NameSet } - - | -- | @data@ declaration - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', - -- 'ApiAnnotation.AnnFamily', - -- 'ApiAnnotation.AnnNewType', - -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon' - -- 'ApiAnnotation.AnnWhere', - - -- For details on above see note [Api annotations] in ApiAnnotation - DataDecl { tcdLName :: Located name -- ^ Type constructor - , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type - -- these include outer binders - -- Eg class T a where - -- type F a :: * - -- type F a = a -> a - -- Here the type decl for 'f' includes 'a' - -- in its tcdTyVars - , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdDataDefn :: HsDataDefn name - , tcdDataCusk :: PostRn name Bool -- ^ does this have a CUSK? - , tcdFVs :: PostRn name NameSet } - - | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... - tcdLName :: Located name, -- ^ Name of the class - tcdTyVars :: LHsQTyVars name, -- ^ Class type variables - tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration - tcdFDs :: [Located (FunDep (Located name))], - -- ^ Functional deps - tcdSigs :: [LSig name], -- ^ Methods' signatures - tcdMeths :: LHsBinds name, -- ^ Default methods - tcdATs :: [LFamilyDecl name], -- ^ Associated types; - tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults - tcdDocs :: [LDocDecl], -- ^ Haddock docs - tcdFVs :: PostRn name NameSet - } - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass', - -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - -- - The tcdFDs will have 'ApiAnnotation.AnnVbar', - -- 'ApiAnnotation.AnnComma' - -- 'ApiAnnotation.AnnRarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - -deriving instance (DataId id) => Data (TyClDecl id) - - --- Simple classifiers for TyClDecl --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- | @True@ <=> argument is a @data@\/@newtype@ --- declaration. -isDataDecl :: TyClDecl name -> Bool -isDataDecl (DataDecl {}) = True -isDataDecl _other = False - --- | type or type instance declaration -isSynDecl :: TyClDecl name -> Bool -isSynDecl (SynDecl {}) = True -isSynDecl _other = False - --- | type class -isClassDecl :: TyClDecl name -> Bool -isClassDecl (ClassDecl {}) = True -isClassDecl _ = False - --- | type/data family declaration -isFamilyDecl :: TyClDecl name -> Bool -isFamilyDecl (FamDecl {}) = True -isFamilyDecl _other = False - --- | type family declaration -isTypeFamilyDecl :: TyClDecl name -> Bool -isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of - OpenTypeFamily -> True - ClosedTypeFamily {} -> True - _ -> False -isTypeFamilyDecl _ = False - --- | open type family info -isOpenTypeFamilyInfo :: FamilyInfo name -> Bool -isOpenTypeFamilyInfo OpenTypeFamily = True -isOpenTypeFamilyInfo _ = False - --- | closed type family info -isClosedTypeFamilyInfo :: FamilyInfo name -> Bool -isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True -isClosedTypeFamilyInfo _ = False - --- | data family declaration -isDataFamilyDecl :: TyClDecl name -> Bool -isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True -isDataFamilyDecl _other = False - --- Dealing with names - -tyFamInstDeclName :: TyFamInstDecl name -> name -tyFamInstDeclName = unLoc . tyFamInstDeclLName - -tyFamInstDeclLName :: TyFamInstDecl name -> Located name -tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = - (L _ (TyFamEqn { tfe_tycon = ln })) }) - = ln - -tyClDeclLName :: TyClDecl name -> Located name -tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln -tyClDeclLName decl = tcdLName decl - -tcdName :: TyClDecl name -> name -tcdName = unLoc . tyClDeclLName - -tyClDeclTyVars :: TyClDecl name -> LHsQTyVars name -tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs -tyClDeclTyVars d = tcdTyVars d - -countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int) - -- class, synonym decls, data, newtype, family decls -countTyClDecls decls - = (count isClassDecl decls, - count isSynDecl decls, -- excluding... - count isDataTy decls, -- ...family... - count isNewTy decls, -- ...instances - count isFamilyDecl decls) - where - isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True - isDataTy _ = False - - isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True - isNewTy _ = False - --- | Does this declaration have a complete, user-supplied kind signature? --- See Note [Complete user-supplied kind signatures] -hsDeclHasCusk :: TyClDecl Name -> Bool -hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl -hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) - -- NB: Keep this synchronized with 'getInitialKind' - = hsTvbAllKinded tyvars && rhs_annotated rhs - where - rhs_annotated (L _ ty) = case ty of - HsParTy lty -> rhs_annotated lty - HsKindSig {} -> True - _ -> False -hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk -hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars - --- Pretty-printing TyClDecl --- ~~~~~~~~~~~~~~~~~~~~~~~~ - -instance (OutputableBndrId name) => Outputable (TyClDecl name) where - - ppr (FamDecl { tcdFam = decl }) = ppr decl - ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity - , tcdRhs = rhs }) - = hang (text "type" <+> - pp_vanilla_decl_head ltycon tyvars fixity [] <+> equals) - 4 (ppr rhs) - - ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity - , tcdDataDefn = defn }) - = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn - - ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdFDs = fds, - tcdSigs = sigs, tcdMeths = methods, - tcdATs = ats, tcdATDefs = at_defs}) - | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part - = top_matter - - | otherwise -- Laid out - = vcat [ top_matter <+> text "where" - , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++ - map ppr_fam_deflt_eqn at_defs ++ - pprLHsBindsForUser methods sigs) ] - where - top_matter = text "class" - <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context) - <+> pprFundeps (map unLoc fds) - -instance (OutputableBndrId name) => Outputable (TyClGroup name) where - ppr (TyClGroup { group_tyclds = tyclds - , group_roles = roles - , group_instds = instds - } - ) - = ppr tyclds $$ - ppr roles $$ - ppr instds - -pp_vanilla_decl_head :: (OutputableBndrId name) => Located name - -> LHsQTyVars name - -> LexicalFixity - -> HsContext name - -> SDoc -pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context - = hsep [pprHsContext context, pp_tyvars tyvars] - where - pp_tyvars (varl:varsr) - | fixity == Infix - = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) - , hsep (map (ppr.unLoc) varsr)] - | otherwise = hsep [ pprPrefixOcc (unLoc thing) - , hsep (map (ppr.unLoc) (varl:varsr))] - pp_tyvars [] = ppr thing - -pprTyClDeclFlavour :: TyClDecl a -> SDoc -pprTyClDeclFlavour (ClassDecl {}) = text "class" -pprTyClDeclFlavour (SynDecl {}) = text "type" -pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) - = pprFlavour info <+> text "family" -pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) - = ppr nd - - -{- Note [Complete user-supplied kind signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We kind-check declarations differently if they have a complete, user-supplied -kind signature (CUSK). This is because we can safely generalise a CUSKed -declaration before checking all of the others, supporting polymorphic recursion. -See ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy -and #9200 for lots of discussion of how we got here. - -A declaration has a CUSK if we can know its complete kind without doing any -inference, at all. Here are the rules: - - - A class or datatype is said to have a CUSK if and only if all of its type -variables are annotated. Its result kind is, by construction, Constraint or * -respectively. - - - A type synonym has a CUSK if and only if all of its type variables and its -RHS are annotated with kinds. - - - A closed type family is said to have a CUSK if and only if all of its type -variables and its return type are annotated. - - - An open type family always has a CUSK -- unannotated type variables (and -return type) default to *. - - - Additionally, if -XTypeInType is on, then a data definition with a top-level - :: must explicitly bind all kind variables to the right of the ::. - See test dependent/should_compile/KindLevels, which requires this case. - (Naturally, any kind variable mentioned before the :: should not be bound - after it.) --} - - -{- ********************************************************************* -* * - TyClGroup - Strongly connected components of - type, class, instance, and role declarations -* * -********************************************************************* -} - -{- Note [TyClGroups and dependency analysis] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A TyClGroup represents a strongly connected components of type/class/instance -decls, together with the role annotations for the type/class declarations. - -The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order -sequence of strongly-connected components. - -Invariants - * The type and class declarations, group_tyclds, may depend on each - other, or earlier TyClGroups, but not on later ones - - * The role annotations, group_roles, are role-annotations for some or - all of the types and classes in group_tyclds (only). - - * The instance declarations, group_instds, may (and usually will) - depend on group_tyclds, or on earlier TyClGroups, but not on later - ones. - -See Note [Dependency analsis of type, class, and instance decls] -in RnSource for more info. --} - --- | Type or Class Group -data TyClGroup name -- See Note [TyClGroups and dependency analysis] - = TyClGroup { group_tyclds :: [LTyClDecl name] - , group_roles :: [LRoleAnnotDecl name] - , group_instds :: [LInstDecl name] } -deriving instance (DataId id) => Data (TyClGroup id) - -emptyTyClGroup :: TyClGroup name -emptyTyClGroup = TyClGroup [] [] [] - -tyClGroupTyClDecls :: [TyClGroup name] -> [LTyClDecl name] -tyClGroupTyClDecls = concatMap group_tyclds - -tyClGroupInstDecls :: [TyClGroup name] -> [LInstDecl name] -tyClGroupInstDecls = concatMap group_instds - -tyClGroupRoleDecls :: [TyClGroup name] -> [LRoleAnnotDecl name] -tyClGroupRoleDecls = concatMap group_roles - -mkTyClGroup :: [LTyClDecl name] -> [LInstDecl name] -> TyClGroup name -mkTyClGroup decls instds = TyClGroup - { group_tyclds = decls - , group_roles = [] - , group_instds = instds - } - - - -{- ********************************************************************* -* * - Data and type family declarations -* * -********************************************************************* -} - -{- Note [FamilyResultSig] -~~~~~~~~~~~~~~~~~~~~~~~~~ - -This data type represents the return signature of a type family. Possible -values are: - - * NoSig - the user supplied no return signature: - type family Id a where ... - - * KindSig - the user supplied the return kind: - type family Id a :: * where ... - - * TyVarSig - user named the result with a type variable and possibly - provided a kind signature for that variable: - type family Id a = r where ... - type family Id a = (r :: *) where ... - - Naming result of a type family is required if we want to provide - injectivity annotation for a type family: - type family Id a = r | r -> a where ... - -See also: Note [Injectivity annotation] - -Note [Injectivity annotation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A user can declare a type family to be injective: - - type family Id a = r | r -> a where ... - - * The part after the "|" is called "injectivity annotation". - * "r -> a" part is called "injectivity condition"; at the moment terms - "injectivity annotation" and "injectivity condition" are synonymous - because we only allow a single injectivity condition. - * "r" is the "LHS of injectivity condition". LHS can only contain the - variable naming the result of a type family. - - * "a" is the "RHS of injectivity condition". RHS contains space-separated - type and kind variables representing the arguments of a type - family. Variables can be omitted if a type family is not injective in - these arguments. Example: - type family Foo a b c = d | d -> a c where ... - -Note that: - (a) naming of type family result is required to provide injectivity - annotation - (b) for associated types if the result was named then injectivity annotation - is mandatory. Otherwise result type variable is indistinguishable from - associated type default. - -It is possible that in the future this syntax will be extended to support -more complicated injectivity annotations. For example we could declare that -if we know the result of Plus and one of its arguments we can determine the -other argument: - - type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ... - -Here injectivity annotation would consist of two comma-separated injectivity -conditions. - -See also Note [Injective type families] in TyCon --} - --- | Located type Family Result Signature -type LFamilyResultSig name = Located (FamilyResultSig name) - --- | type Family Result Signature -data FamilyResultSig name = -- see Note [FamilyResultSig] - NoSig - -- ^ - 'ApiAnnotation.AnnKeywordId' : - - -- For details on above see note [Api annotations] in ApiAnnotation - - | KindSig (LHsKind name) - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnCloseP' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | TyVarSig (LHsTyVarBndr name) - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual' - - -- For details on above see note [Api annotations] in ApiAnnotation - -deriving instance (DataId name) => Data (FamilyResultSig name) - --- | Located type Family Declaration -type LFamilyDecl name = Located (FamilyDecl name) - --- | type Family Declaration -data FamilyDecl name = FamilyDecl - { fdInfo :: FamilyInfo name -- type/data, closed/open - , fdLName :: Located name -- type constructor - , fdTyVars :: LHsQTyVars name -- type variables - , fdFixity :: LexicalFixity -- Fixity used in the declaration - , fdResultSig :: LFamilyResultSig name -- result signature - , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann - } - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily', - -- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP', - -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnCloseP', - -- 'ApiAnnotation.AnnEqual', 'ApiAnnotation.AnnRarrow', - -- 'ApiAnnotation.AnnVbar' - - -- For details on above see note [Api annotations] in ApiAnnotation - -deriving instance (DataId id) => Data (FamilyDecl id) - --- | Located Injectivity Annotation -type LInjectivityAnn name = Located (InjectivityAnn name) - --- | If the user supplied an injectivity annotation it is represented using --- InjectivityAnn. At the moment this is a single injectivity condition - see --- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity --- condition. `[Located name]` stores the RHS of injectivity condition. Example: --- --- type family Foo a b c = r | r -> a c where ... --- --- This will be represented as "InjectivityAnn `r` [`a`, `c`]" -data InjectivityAnn name - = InjectivityAnn (Located name) [Located name] - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar' - - -- For details on above see note [Api annotations] in ApiAnnotation - deriving Data - -data FamilyInfo name - = DataFamily - | OpenTypeFamily - -- | 'Nothing' if we're in an hs-boot file and the user - -- said "type family Foo x where .." - | ClosedTypeFamily (Maybe [LTyFamInstEqn name]) -deriving instance (DataId name) => Data (FamilyInfo name) - --- | Does this family declaration have a complete, user-supplied kind signature? -famDeclHasCusk :: Maybe Bool - -- ^ if associated, does the enclosing class have a CUSK? - -> FamilyDecl name -> Bool -famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _ - , fdTyVars = tyvars - , fdResultSig = L _ resultSig }) - = hsTvbAllKinded tyvars && hasReturnKindSignature resultSig -famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True - -- all un-associated open families have CUSKs! - --- | Does this family declaration have user-supplied return kind signature? -hasReturnKindSignature :: FamilyResultSig a -> Bool -hasReturnKindSignature NoSig = False -hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False -hasReturnKindSignature _ = True - --- | Maybe return name of the result type variable -resultVariableName :: FamilyResultSig a -> Maybe a -resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig -resultVariableName _ = Nothing - -instance (OutputableBndrId name) => Outputable (FamilyDecl name) where - ppr = pprFamilyDecl TopLevel - -pprFamilyDecl :: (OutputableBndrId name) - => TopLevelFlag -> FamilyDecl name -> SDoc -pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon - , fdTyVars = tyvars - , fdFixity = fixity - , fdResultSig = L _ result - , fdInjectivityAnn = mb_inj }) - = vcat [ pprFlavour info <+> pp_top_level <+> - pp_vanilla_decl_head ltycon tyvars fixity [] <+> - pp_kind <+> pp_inj <+> pp_where - , nest 2 $ pp_eqns ] - where - pp_top_level = case top_level of - TopLevel -> text "family" - NotTopLevel -> empty - - pp_kind = case result of - NoSig -> empty - KindSig kind -> dcolon <+> ppr kind - TyVarSig tv_bndr -> text "=" <+> ppr tv_bndr - pp_inj = case mb_inj of - Just (L _ (InjectivityAnn lhs rhs)) -> - hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] - Nothing -> empty - (pp_where, pp_eqns) = case info of - ClosedTypeFamily mb_eqns -> - ( text "where" - , case mb_eqns of - Nothing -> text ".." - Just eqns -> vcat $ map ppr_fam_inst_eqn eqns ) - _ -> (empty, empty) - -pprFlavour :: FamilyInfo name -> SDoc -pprFlavour DataFamily = text "data" -pprFlavour OpenTypeFamily = text "type" -pprFlavour (ClosedTypeFamily {}) = text "type" - -instance Outputable (FamilyInfo name) where - ppr info = pprFlavour info <+> text "family" - - - -{- ********************************************************************* -* * - Data types and data constructors -* * -********************************************************************* -} - --- | Haskell Data type Definition -data HsDataDefn name -- The payload of a data type defn - -- Used *both* for vanilla data declarations, - -- *and* for data family instances - = -- | Declares a data type or newtype, giving its constructors - -- @ - -- data/newtype T a = - -- data/newtype instance T [a] = - -- @ - HsDataDefn { dd_ND :: NewOrData, - dd_ctxt :: LHsContext name, -- ^ Context - dd_cType :: Maybe (Located CType), - dd_kindSig:: Maybe (LHsKind name), - -- ^ Optional kind signature. - -- - -- @(Just k)@ for a GADT-style @data@, - -- or @data instance@ decl, with explicit kind sig - -- - -- Always @Nothing@ for H98-syntax decls - - dd_cons :: [LConDecl name], - -- ^ Data constructors - -- - -- For @data T a = T1 | T2 a@ - -- the 'LConDecl's all have 'ConDeclH98'. - -- For @data T a where { T1 :: T a }@ - -- the 'LConDecls' all have 'ConDeclGADT'. - - dd_derivs :: HsDeriving name -- ^ Optional 'deriving' claues - - -- For details on above see note [Api annotations] in ApiAnnotation - } -deriving instance (DataId id) => Data (HsDataDefn id) - --- | Haskell Deriving clause -type HsDeriving name = Located [LHsDerivingClause name] - -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is - -- plural because one can specify multiple deriving clauses using the - -- @-XDerivingStrategies@ language extension. - -- - -- The list of 'LHsDerivingClause's corresponds to exactly what the user - -- requested to derive, in order. If no deriving clauses were specified, - -- the list is empty. - -type LHsDerivingClause name = Located (HsDerivingClause name) - --- | A single @deriving@ clause of a data declaration. --- --- - 'ApiAnnotation.AnnKeywordId' : --- 'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock', --- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', --- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -data HsDerivingClause name - -- See Note [Deriving strategies] in TcDeriv - = HsDerivingClause - { deriv_clause_strategy :: Maybe (Located DerivStrategy) - -- ^ The user-specified strategy (if any) to use when deriving - -- 'deriv_clause_tys'. - , deriv_clause_tys :: Located [LHsSigType name] - -- ^ The types to derive. - -- - -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, - -- we can mention type variables that aren't bound by the datatype, e.g. - -- - -- > data T b = ... deriving (C [a]) - -- - -- should produce a derived instance for @C [a] (T b)@. - } -deriving instance (DataId id) => Data (HsDerivingClause id) - -instance (OutputableBndrId name) - => Outputable (HsDerivingClause name) where - ppr (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = L _ dct }) - = hsep [ text "deriving" - , ppDerivStrategy dcs - , pp_dct dct ] - where - -- This complexity is to distinguish between - -- deriving Show - -- deriving (Show) - pp_dct [a@(HsIB { hsib_body = L _ HsAppsTy{} })] = parens (ppr a) - pp_dct [a] = ppr a - pp_dct _ = parens (interpp'SP dct) - -data NewOrData - = NewType -- ^ @newtype Blah ...@ - | DataType -- ^ @data Blah ...@ - deriving( Eq, Data ) -- Needed because Demand derives Eq - --- | Located data Constructor Declaration -type LConDecl name = Located (ConDecl name) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when - -- in a GADT constructor list - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | --- --- @ --- data T b = forall a. Eq a => MkT a b --- MkT :: forall b a. Eq a => MkT a b --- --- data T b where --- MkT1 :: Int -> T Int --- --- data T = Int `MkT` Int --- | MkT2 --- --- data T a where --- Int `MkT` Int :: T Int --- @ --- --- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', --- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose', --- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar', --- 'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow', --- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot' - --- For details on above see note [Api annotations] in ApiAnnotation - --- | data Constructor Declaration -data ConDecl name - = ConDeclGADT - { con_names :: [Located name] - , con_type :: LHsSigType name - -- ^ The type after the ‘::’ - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - } - - | ConDeclH98 - { con_name :: Located name - - , con_qvars :: Maybe (LHsQTyVars name) - -- User-written forall (if any), and its implicit - -- kind variables - -- Non-Nothing needs -XExistentialQuantification - -- e.g. data T a = forall b. MkT b (b->a) - -- con_qvars = {b} - - , con_cxt :: Maybe (LHsContext name) - -- ^ User-written context (if any) - - , con_details :: HsConDeclDetails name - -- ^ Arguments - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - } -deriving instance (DataId name) => Data (ConDecl name) - --- | Haskell data Constructor Declaration Details -type HsConDeclDetails name - = HsConDetails (LBangType name) (Located [LConDeclField name]) - -getConNames :: ConDecl name -> [Located name] -getConNames ConDeclH98 {con_name = name} = [name] -getConNames ConDeclGADT {con_names = names} = names - --- don't call with RdrNames, because it can't deal with HsAppsTy -getConDetails :: ConDecl name -> HsConDeclDetails name -getConDetails ConDeclH98 {con_details = details} = details -getConDetails ConDeclGADT {con_type = ty } = details - where - (details,_,_,_) = gadtDeclDetails ty - --- don't call with RdrNames, because it can't deal with HsAppsTy -gadtDeclDetails :: LHsSigType name - -> ( HsConDeclDetails name - , LHsType name - , LHsContext name - , [LHsTyVarBndr name] ) -gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs) - where - (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty - (details, res_ty) -- See Note [Sorting out the result type] - = case tau of - L _ (HsFunTy (L l (HsRecTy flds)) res_ty') - -> (RecCon (L l flds), res_ty') - _other -> (PrefixCon [], tau) - -hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name] -hsConDeclArgTys (PrefixCon tys) = tys -hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] -hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) - -pp_data_defn :: (OutputableBndrId name) - => (HsContext name -> SDoc) -- Printing the header - -> HsDataDefn name - -> SDoc -pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context - , dd_cType = mb_ct - , dd_kindSig = mb_sig - , dd_cons = condecls, dd_derivs = derivings }) - | null condecls - = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig - <+> pp_derivings derivings - - | otherwise - = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig) - 2 (pp_condecls condecls $$ pp_derivings derivings) - where - pp_ct = case mb_ct of - Nothing -> empty - Just ct -> ppr ct - pp_sig = case mb_sig of - Nothing -> empty - Just kind -> dcolon <+> ppr kind - pp_derivings (L _ ds) = vcat (map ppr ds) - -instance (OutputableBndrId name) => Outputable (HsDataDefn name) where - ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d - -instance Outputable NewOrData where - ppr NewType = text "newtype" - ppr DataType = text "data" - -pp_condecls :: (OutputableBndrId name) => [LConDecl name] -> SDoc -pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax - = hang (text "where") 2 (vcat (map ppr cs)) -pp_condecls cs -- In H98 syntax - = equals <+> sep (punctuate (text " |") (map ppr cs)) - -instance (OutputableBndrId name) => Outputable (ConDecl name) where - ppr = pprConDecl - -pprConDecl :: (OutputableBndrId name) => ConDecl name -> SDoc -pprConDecl (ConDeclH98 { con_name = L _ con - , con_qvars = mtvs - , con_cxt = mcxt - , con_details = details - , con_doc = doc }) - = sep [ppr_mbDoc doc, pprHsForAll tvs cxt, ppr_details details] - where - ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] - ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con - : map (pprParendHsType . unLoc) tys) - ppr_details (RecCon fields) = pprPrefixOcc con - <+> pprConDeclFields (unLoc fields) - tvs = case mtvs of - Nothing -> [] - Just (HsQTvs { hsq_explicit = tvs }) -> tvs - - cxt = fromMaybe (noLoc []) mcxt - -pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc }) - = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon - <+> ppr res_ty] - -ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc -ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) - -{- -************************************************************************ -* * - Instance declarations -* * -************************************************************************ - -Note [Type family instance declarations in HsSyn] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The data type TyFamEqn represents one equation of a type family instance. -It is parameterised over its tfe_pats field: - - * An ordinary type family instance declaration looks like this in source Haskell - type instance T [a] Int = a -> a - (or something similar for a closed family) - It is represented by a TyFamInstEqn, with *type* in the tfe_pats field. - - * On the other hand, the *default instance* of an associated type looks like - this in source Haskell - class C a where - type T a b - type T a b = a -> b -- The default instance - It is represented by a TyFamDefltEqn, with *type variables* in the tfe_pats - field. --} - ------------------ Type synonym family instances ------------- - --- | Located Type Family Instance Equation -type LTyFamInstEqn name = Located (TyFamInstEqn name) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' - -- when in a list - --- For details on above see note [Api annotations] in ApiAnnotation - --- | Located Type Family Default Equation -type LTyFamDefltEqn name = Located (TyFamDefltEqn name) - --- | Haskell Type Patterns -type HsTyPats name = HsImplicitBndrs name [LHsType name] - -- ^ Type patterns (with kind and type bndrs) - -- See Note [Family instance declaration binders] - -{- Note [Family instance declaration binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The HsTyPats field is LHS patterns or a type/data family instance. - -The hsib_vars of the HsImplicitBndrs are the template variables of the -type patterns, i.e. fv(pat_tys). Note in particular - -* The hsib_vars *includes* any anonymous wildcards. For example - type instance F a _ = a - The hsib_vars will be {a, _}. Remember that each separate wildcard - '_' gets its own unique. In this context wildcards behave just like - an ordinary type variable, only anonymous. - -* The hsib_vars *including* type variables that are already in scope - - Eg class C s t where - type F t p :: * - instance C w (a,b) where - type F (a,b) x = x->a - The hsib_vars of the F decl are {a,b,x}, even though the F decl - is nested inside the 'instance' decl. - - However after the renamer, the uniques will match up: - instance C w7 (a8,b9) where - type F (a8,b9) x10 = x10->a8 - so that we can compare the type pattern in the 'instance' decl and - in the associated 'type' decl --} - --- | Type Family Instance Equation -type TyFamInstEqn name = TyFamEqn name (HsTyPats name) - --- | Type Family Default Equation -type TyFamDefltEqn name = TyFamEqn name (LHsQTyVars name) - -- See Note [Type family instance declarations in HsSyn] - --- | Type Family Equation --- --- One equation in a type family instance declaration --- See Note [Type family instance declarations in HsSyn] -data TyFamEqn name pats - = TyFamEqn - { tfe_tycon :: Located name - , tfe_pats :: pats - , tfe_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , tfe_rhs :: LHsType name } - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name, Data pats) => Data (TyFamEqn name pats) - --- | Located Type Family Instance Declaration -type LTyFamInstDecl name = Located (TyFamInstDecl name) - --- | Type Family Instance Declaration -data TyFamInstDecl name - = TyFamInstDecl - { tfid_eqn :: LTyFamInstEqn name - , tfid_fvs :: PostRn name NameSet } - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnInstance', - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (TyFamInstDecl name) - ------------------ Data family instances ------------- - --- | Located Data Family Instance Declaration -type LDataFamInstDecl name = Located (DataFamInstDecl name) - --- | Data Family Instance Declaration -data DataFamInstDecl name - = DataFamInstDecl - { dfid_tycon :: Located name - , dfid_pats :: HsTyPats name -- LHS - , dfid_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , dfid_defn :: HsDataDefn name -- RHS - , dfid_fvs :: PostRn name NameSet } -- Free vars for dependency analysis - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', - -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance', - -- 'ApiAnnotation.AnnDcolon' - -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (DataFamInstDecl name) - - ------------------ Class instances ------------- - --- | Located Class Instance Declaration -type LClsInstDecl name = Located (ClsInstDecl name) - --- | Class Instance Declaration -data ClsInstDecl name - = ClsInstDecl - { cid_poly_ty :: LHsSigType name -- Context => Class Instance-type - -- Using a polytype means that the renamer conveniently - -- figures out the quantified type variables for us. - , cid_binds :: LHsBinds name -- Class methods - , cid_sigs :: [LSig name] -- User-supplied pragmatic info - , cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances - , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances - , cid_overlap_mode :: Maybe (Located OverlapMode) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - } - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance', - -- 'ApiAnnotation.AnnWhere', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId id) => Data (ClsInstDecl id) - - ------------------ Instances of all kinds ------------- - --- | Located Instance Declaration -type LInstDecl name = Located (InstDecl name) - --- | Instance Declaration -data InstDecl name -- Both class and family instances - = ClsInstD - { cid_inst :: ClsInstDecl name } - | DataFamInstD -- data family instance - { dfid_inst :: DataFamInstDecl name } - | TyFamInstD -- type family instance - { tfid_inst :: TyFamInstDecl name } -deriving instance (DataId id) => Data (InstDecl id) - -instance (OutputableBndrId name) => Outputable (TyFamInstDecl name) where - ppr = pprTyFamInstDecl TopLevel - -pprTyFamInstDecl :: (OutputableBndrId name) - => TopLevelFlag -> TyFamInstDecl name -> SDoc -pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) - = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn - -ppr_instance_keyword :: TopLevelFlag -> SDoc -ppr_instance_keyword TopLevel = text "instance" -ppr_instance_keyword NotTopLevel = empty - -ppr_fam_inst_eqn :: (OutputableBndrId name) => LTyFamInstEqn name -> SDoc -ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon - , tfe_pats = pats - , tfe_fixity = fixity - , tfe_rhs = rhs })) - = pp_fam_inst_lhs tycon pats fixity [] <+> equals <+> ppr rhs - -ppr_fam_deflt_eqn :: (OutputableBndrId name) => LTyFamDefltEqn name -> SDoc -ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon - , tfe_pats = tvs - , tfe_fixity = fixity - , tfe_rhs = rhs })) - = text "type" <+> pp_vanilla_decl_head tycon tvs fixity [] - <+> equals <+> ppr rhs - -instance (OutputableBndrId name) => Outputable (DataFamInstDecl name) where - ppr = pprDataFamInstDecl TopLevel - -pprDataFamInstDecl :: (OutputableBndrId name) - => TopLevelFlag -> DataFamInstDecl name -> SDoc -pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon - , dfid_pats = pats - , dfid_fixity = fixity - , dfid_defn = defn }) - = pp_data_defn pp_hdr defn - where - pp_hdr ctxt = ppr_instance_keyword top_lvl - <+> pp_fam_inst_lhs tycon pats fixity ctxt - -pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc -pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) }) - = ppr nd - -pp_fam_inst_lhs :: (OutputableBndrId name) => Located name - -> HsTyPats name - -> LexicalFixity - -> HsContext name - -> SDoc -pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context - -- explicit type patterns - = hsep [ pprHsContext context, pp_pats typats] - where - pp_pats (patl:patsr) - | fixity == Infix - = hsep [pprParendHsType (unLoc patl), pprInfixOcc (unLoc thing) - , hsep (map (pprParendHsType.unLoc) patsr)] - | otherwise = hsep [ pprPrefixOcc (unLoc thing) - , hsep (map (pprParendHsType.unLoc) (patl:patsr))] - pp_pats [] = empty - -instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where - ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds - , cid_sigs = sigs, cid_tyfam_insts = ats - , cid_overlap_mode = mbOverlap - , cid_datafam_insts = adts }) - | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part - = top_matter - - | otherwise -- Laid out - = vcat [ top_matter <+> text "where" - , nest 2 $ pprDeclList $ - map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++ - map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ - pprLHsBindsForUser binds sigs ] - where - top_matter = text "instance" <+> ppOverlapPragma mbOverlap - <+> ppr inst_ty - -ppDerivStrategy :: Maybe (Located DerivStrategy) -> SDoc -ppDerivStrategy mb = - case mb of - Nothing -> empty - Just (L _ ds) -> ppr ds - -ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc -ppOverlapPragma mb = - case mb of - Nothing -> empty - Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}" - Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}" - Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}" - Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}" - Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}" - where - maybe_stext NoSourceText alt = text alt - maybe_stext (SourceText src) _ = text src <+> text "#-}" - - -instance (OutputableBndrId name) => Outputable (InstDecl name) where - ppr (ClsInstD { cid_inst = decl }) = ppr decl - ppr (TyFamInstD { tfid_inst = decl }) = ppr decl - ppr (DataFamInstD { dfid_inst = decl }) = ppr decl - --- Extract the declarations of associated data types from an instance - -instDeclDataFamInsts :: [LInstDecl name] -> [DataFamInstDecl name] -instDeclDataFamInsts inst_decls - = concatMap do_one inst_decls - where - do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } })) - = map unLoc fam_insts - do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] - do_one (L _ (TyFamInstD {})) = [] - -{- -************************************************************************ -* * -\subsection[DerivDecl]{A stand-alone instance deriving declaration} -* * -************************************************************************ --} - --- | Located Deriving Declaration -type LDerivDecl name = Located (DerivDecl name) - --- | Deriving Declaration -data DerivDecl name = DerivDecl - { deriv_type :: LHsSigType name - , deriv_strategy :: Maybe (Located DerivStrategy) - , deriv_overlap_mode :: Maybe (Located OverlapMode) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', - -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock', - -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - } -deriving instance (DataId name) => Data (DerivDecl name) - -instance (OutputableBndrId name) => Outputable (DerivDecl name) where - ppr (DerivDecl { deriv_type = ty - , deriv_strategy = ds - , deriv_overlap_mode = o }) - = hsep [ text "deriving" - , ppDerivStrategy ds - , text "instance" - , ppOverlapPragma o - , ppr ty ] - -{- -************************************************************************ -* * -\subsection[DefaultDecl]{A @default@ declaration} -* * -************************************************************************ - -There can only be one default declaration per module, but it is hard -for the parser to check that; we pass them all through in the abstract -syntax, and that restriction must be checked in the front end. --} - --- | Located Default Declaration -type LDefaultDecl name = Located (DefaultDecl name) - --- | Default Declaration -data DefaultDecl name - = DefaultDecl [LHsType name] - -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (DefaultDecl name) - -instance (OutputableBndrId name) => Outputable (DefaultDecl name) where - - ppr (DefaultDecl tys) - = text "default" <+> parens (interpp'SP tys) - -{- -************************************************************************ -* * -\subsection{Foreign function interface declaration} -* * -************************************************************************ --} - --- foreign declarations are distinguished as to whether they define or use a --- Haskell name --- --- * the Boolean value indicates whether the pre-standard deprecated syntax --- has been used - --- | Located Foreign Declaration -type LForeignDecl name = Located (ForeignDecl name) - --- | Foreign Declaration -data ForeignDecl name - = ForeignImport - { fd_name :: Located name -- defines this name - , fd_sig_ty :: LHsSigType name -- sig_ty - , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty - , fd_fi :: ForeignImport } - - | ForeignExport - { fd_name :: Located name -- uses this name - , fd_sig_ty :: LHsSigType name -- sig_ty - , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty - , fd_fe :: ForeignExport } - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', - -- 'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport', - -- 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - -deriving instance (DataId name) => Data (ForeignDecl name) -{- - In both ForeignImport and ForeignExport: - sig_ty is the type given in the Haskell code - rep_ty is the representation for this type, i.e. with newtypes - coerced away and type functions evaluated. - Thus if the declaration is valid, then rep_ty will only use types - such as Int and IO that we know how to make foreign calls with. --} - -noForeignImportCoercionYet :: PlaceHolder -noForeignImportCoercionYet = PlaceHolder - -noForeignExportCoercionYet :: PlaceHolder -noForeignExportCoercionYet = PlaceHolder - --- Specification Of an imported external entity in dependence on the calling --- convention --- -data ForeignImport = -- import of a C entity - -- - -- * the two strings specifying a header file or library - -- may be empty, which indicates the absence of a - -- header or object specification (both are not used - -- in the case of `CWrapper' and when `CFunction' - -- has a dynamic target) - -- - -- * the calling convention is irrelevant for code - -- generation in the case of `CLabel', but is needed - -- for pretty printing - -- - -- * `Safety' is irrelevant for `CLabel' and `CWrapper' - -- - CImport (Located CCallConv) -- ccall or stdcall - (Located Safety) -- interruptible, safe or unsafe - (Maybe Header) -- name of C header - CImportSpec -- details of the C entity - (Located SourceText) -- original source text for - -- the C entity - deriving Data - --- details of an external C entity --- -data CImportSpec = CLabel CLabelString -- import address of a C label - | CFunction CCallTarget -- static or dynamic function - | CWrapper -- wrapper to expose closures - -- (former f.e.d.) - deriving Data - --- specification of an externally exported entity in dependence on the calling --- convention --- -data ForeignExport = CExport (Located CExportSpec) -- contains the calling - -- convention - (Located SourceText) -- original source text for - -- the C entity - deriving Data - --- pretty printing of foreign declarations --- - -instance (OutputableBndrId name) => Outputable (ForeignDecl name) where - ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) - = hang (text "foreign import" <+> ppr fimport <+> ppr n) - 2 (dcolon <+> ppr ty) - ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = - hang (text "foreign export" <+> ppr fexport <+> ppr n) - 2 (dcolon <+> ppr ty) - -instance Outputable ForeignImport where - ppr (CImport cconv safety mHeader spec (L _ srcText)) = - ppr cconv <+> ppr safety - <+> pprWithSourceText srcText (pprCEntity spec "") - where - pp_hdr = case mHeader of - Nothing -> empty - Just (Header _ header) -> ftext header - - pprCEntity (CLabel lbl) _ = - doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl - pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src = - if dqNeeded then doubleQuotes ce else empty - where - dqNeeded = (take 6 src == "static") - || isJust mHeader - || not isFun - || st /= NoSourceText - ce = - -- We may need to drop leading spaces first - (if take 6 src == "static" then text "static" else empty) - <+> pp_hdr - <+> (if isFun then empty else text "value") - <+> (pprWithSourceText st empty) - pprCEntity (CFunction DynamicTarget) _ = - doubleQuotes $ text "dynamic" - pprCEntity CWrapper _ = doubleQuotes $ text "wrapper" - -instance Outputable ForeignExport where - ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) = - ppr cconv <+> char '"' <> ppr lbl <> char '"' - -{- -************************************************************************ -* * -\subsection{Transformation rules} -* * -************************************************************************ --} - --- | Located Rule Declarations -type LRuleDecls name = Located (RuleDecls name) - - -- Note [Pragma source text] in BasicTypes --- | Rule Declarations -data RuleDecls name = HsRules { rds_src :: SourceText - , rds_rules :: [LRuleDecl name] } -deriving instance (DataId name) => Data (RuleDecls name) - --- | Located Rule Declaration -type LRuleDecl name = Located (RuleDecl name) - --- | Rule Declaration -data RuleDecl name - = HsRule -- Source rule - (Located (SourceText,RuleName)) -- Rule name - -- Note [Pragma source text] in BasicTypes - Activation - [LRuleBndr name] -- Forall'd vars; after typechecking this - -- includes tyvars - (Located (HsExpr name)) -- LHS - (PostRn name NameSet) -- Free-vars from the LHS - (Located (HsExpr name)) -- RHS - (PostRn name NameSet) -- Free-vars from the RHS - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', - -- 'ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot', - -- 'ApiAnnotation.AnnEqual', - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (RuleDecl name) - -flattenRuleDecls :: [LRuleDecls name] -> [LRuleDecl name] -flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls - --- | Located Rule Binder -type LRuleBndr name = Located (RuleBndr name) - --- | Rule Binder -data RuleBndr name - = RuleBndr (Located name) - | RuleBndrSig (Located name) (LHsSigWcType name) - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (RuleBndr name) - -collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name] -collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] - -pprFullRuleName :: Located (SourceText, RuleName) -> SDoc -pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) - -instance (OutputableBndrId name) => Outputable (RuleDecls name) where - ppr (HsRules st rules) - = pprWithSourceText st (text "{-# RULES") - <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" - -instance (OutputableBndrId name) => Outputable (RuleDecl name) where - ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) - = sep [pprFullRuleName name <+> ppr act, - nest 4 (pp_forall <+> pprExpr (unLoc lhs)), - nest 6 (equals <+> pprExpr (unLoc rhs)) ] - where - pp_forall | null ns = empty - | otherwise = forAllLit <+> fsep (map ppr ns) <> dot - -instance (OutputableBndrId name) => Outputable (RuleBndr name) where - ppr (RuleBndr name) = ppr name - ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty) - -{- -************************************************************************ -* * -\subsection{Vectorisation declarations} -* * -************************************************************************ - -A vectorisation pragma, one of - - {-# VECTORISE f = closure1 g (scalar_map g) #-} - {-# VECTORISE SCALAR f #-} - {-# NOVECTORISE f #-} - - {-# VECTORISE type T = ty #-} - {-# VECTORISE SCALAR type T #-} --} - --- | Located Vectorise Declaration -type LVectDecl name = Located (VectDecl name) - --- | Vectorise Declaration -data VectDecl name - = HsVect - SourceText -- Note [Pragma source text] in BasicTypes - (Located name) - (LHsExpr name) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsNoVect - SourceText -- Note [Pragma source text] in BasicTypes - (Located name) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsVectTypeIn -- pre type-checking - SourceText -- Note [Pragma source text] in BasicTypes - Bool -- 'TRUE' => SCALAR declaration - (Located name) - (Maybe (Located name)) -- 'Nothing' => no right-hand side - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnEqual' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsVectTypeOut -- post type-checking - Bool -- 'TRUE' => SCALAR declaration - TyCon - (Maybe TyCon) -- 'Nothing' => no right-hand side - | HsVectClassIn -- pre type-checking - SourceText -- Note [Pragma source text] in BasicTypes - (Located name) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsVectClassOut -- post type-checking - Class - | HsVectInstIn -- pre type-checking (always SCALAR) !!!FIXME: should be superfluous now - (LHsSigType name) - | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now - ClsInst -deriving instance (DataId name) => Data (VectDecl name) - -lvectDeclName :: NamedThing name => LVectDecl name -> Name -lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name -lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName name -lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName name -lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon -lvectDeclName (L _ (HsVectClassIn _ (L _ name))) = getName name -lvectDeclName (L _ (HsVectClassOut cls)) = getName cls -lvectDeclName (L _ (HsVectInstIn _)) - = panic "HsDecls.lvectDeclName: HsVectInstIn" -lvectDeclName (L _ (HsVectInstOut _)) - = panic "HsDecls.lvectDeclName: HsVectInstOut" - -lvectInstDecl :: LVectDecl name -> Bool -lvectInstDecl (L _ (HsVectInstIn _)) = True -lvectInstDecl (L _ (HsVectInstOut _)) = True -lvectInstDecl _ = False - -instance (OutputableBndrId name) => Outputable (VectDecl name) where - ppr (HsVect _ v rhs) - = sep [text "{-# VECTORISE" <+> ppr v, - nest 4 $ - pprExpr (unLoc rhs) <+> text "#-}" ] - ppr (HsNoVect _ v) - = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ] - ppr (HsVectTypeIn _ False t Nothing) - = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeIn _ False t (Just t')) - = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectTypeIn _ True t Nothing) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeIn _ True t (Just t')) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectTypeOut False t Nothing) - = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeOut False t (Just t')) - = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectTypeOut True t Nothing) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeOut True t (Just t')) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectClassIn _ c) - = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] - ppr (HsVectClassOut c) - = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] - ppr (HsVectInstIn ty) - = sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ] - ppr (HsVectInstOut i) - = sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ] - -{- -************************************************************************ -* * -\subsection[DocDecl]{Document comments} -* * -************************************************************************ --} - --- | Located Documentation comment Declaration -type LDocDecl = Located (DocDecl) - --- | Documentation comment Declaration -data DocDecl - = DocCommentNext HsDocString - | DocCommentPrev HsDocString - | DocCommentNamed String HsDocString - | DocGroup Int HsDocString - deriving Data - --- Okay, I need to reconstruct the document comments, but for now: -instance Outputable DocDecl where - ppr _ = text "" - -docDeclDoc :: DocDecl -> HsDocString -docDeclDoc (DocCommentNext d) = d -docDeclDoc (DocCommentPrev d) = d -docDeclDoc (DocCommentNamed _ d) = d -docDeclDoc (DocGroup _ d) = d - -{- -************************************************************************ -* * -\subsection[DeprecDecl]{Deprecations} -* * -************************************************************************ - -We use exported entities for things to deprecate. --} - --- | Located Warning Declarations -type LWarnDecls name = Located (WarnDecls name) - - -- Note [Pragma source text] in BasicTypes --- | Warning pragma Declarations -data WarnDecls name = Warnings { wd_src :: SourceText - , wd_warnings :: [LWarnDecl name] - } - deriving Data - --- | Located Warning pragma Declaration -type LWarnDecl name = Located (WarnDecl name) - --- | Warning pragma Declaration -data WarnDecl name = Warning [Located name] WarningTxt - deriving Data - -instance OutputableBndr name => Outputable (WarnDecls name) where - ppr (Warnings (SourceText src) decls) - = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" - ppr (Warnings NoSourceText _decls) = panic "WarnDecls" - -instance OutputableBndr name => Outputable (WarnDecl name) where - ppr (Warning thing txt) - = hsep ( punctuate comma (map ppr thing)) - <+> ppr txt - -{- -************************************************************************ -* * -\subsection[AnnDecl]{Annotations} -* * -************************************************************************ --} - --- | Located Annotation Declaration -type LAnnDecl name = Located (AnnDecl name) - --- | Annotation Declaration -data AnnDecl name = HsAnnotation - SourceText -- Note [Pragma source text] in BasicTypes - (AnnProvenance name) (Located (HsExpr name)) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnType' - -- 'ApiAnnotation.AnnModule' - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (AnnDecl name) - -instance (OutputableBndrId name) => Outputable (AnnDecl name) where - ppr (HsAnnotation _ provenance expr) - = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] - --- | Annotation Provenance -data AnnProvenance name = ValueAnnProvenance (Located name) - | TypeAnnProvenance (Located name) - | ModuleAnnProvenance - deriving (Data, Functor) -deriving instance Foldable AnnProvenance -deriving instance Traversable AnnProvenance - -annProvenanceName_maybe :: AnnProvenance name -> Maybe name -annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name -annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name -annProvenanceName_maybe ModuleAnnProvenance = Nothing - -pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc -pprAnnProvenance ModuleAnnProvenance = text "ANN module" -pprAnnProvenance (ValueAnnProvenance (L _ name)) - = text "ANN" <+> ppr name -pprAnnProvenance (TypeAnnProvenance (L _ name)) - = text "ANN type" <+> ppr name - -{- -************************************************************************ -* * -\subsection[RoleAnnot]{Role annotations} -* * -************************************************************************ --} - --- | Located Role Annotation Declaration -type LRoleAnnotDecl name = Located (RoleAnnotDecl name) - --- See #8185 for more info about why role annotations are --- top-level declarations --- | Role Annotation Declaration -data RoleAnnotDecl name - = RoleAnnotDecl (Located name) -- type constructor - [Located (Maybe Role)] -- optional annotations - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnRole' - - -- For details on above see note [Api annotations] in ApiAnnotation - deriving Data - -instance OutputableBndr name => Outputable (RoleAnnotDecl name) where - ppr (RoleAnnotDecl ltycon roles) - = text "type role" <+> ppr ltycon <+> - hsep (map (pp_role . unLoc) roles) - where - pp_role Nothing = underscore - pp_role (Just r) = ppr r - -roleAnnotDeclName :: RoleAnnotDecl name -> name -roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name diff --git a/hsSyn/HsDoc.hs b/hsSyn/HsDoc.hs deleted file mode 100644 --- a/hsSyn/HsDoc.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -module HsDoc ( - HsDocString(..), - LHsDocString, - ppr_mbDoc - ) where - -#include "HsVersions.h" - -import Outputable -import SrcLoc -import FastString - -import Data.Data - --- | Haskell Documentation String -newtype HsDocString = HsDocString FastString - deriving (Eq, Show, Data) - --- | Located Haskell Documentation String -type LHsDocString = Located HsDocString - -instance Outputable HsDocString where - ppr (HsDocString fs) = ftext fs - -ppr_mbDoc :: Maybe LHsDocString -> SDoc -ppr_mbDoc (Just doc) = ppr doc -ppr_mbDoc Nothing = empty - diff --git a/hsSyn/HsDumpAst.hs b/hsSyn/HsDumpAst.hs deleted file mode 100644 --- a/hsSyn/HsDumpAst.hs +++ /dev/null @@ -1,206 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Contains a debug function to dump parts of the hsSyn AST. It uses a syb --- traversal which falls back to displaying based on the constructor name, so --- can be used to dump anything having a @Data.Data@ instance. - -module HsDumpAst ( - -- * Dumping ASTs - showAstData, - BlankSrcSpan(..), - ) where - -import Data.Data hiding (Fixity) -import Data.List -import Bag -import BasicTypes -import FastString -import NameSet -import Name -import RdrName -import DataCon -import SrcLoc -import HsSyn -import OccName hiding (occName) -import Var -import Module -import DynFlags -import Outputable hiding (space) - -import qualified Data.ByteString as B - -data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan - deriving (Eq,Show) - --- | Show a GHC syntax tree. This parameterised because it is also used for --- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked --- out, to avoid comparing locations, only structure -showAstData :: Data a => BlankSrcSpan -> a -> String -showAstData b = showAstData' 0 - where - showAstData' :: Data a => Int -> a -> String - showAstData' n = - generic - `ext1Q` list - `extQ` string `extQ` fastString `extQ` srcSpan `extQ` lit - `extQ` bytestring - `extQ` name `extQ` occName `extQ` moduleName `extQ` var - `extQ` dataCon - `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet - `extQ` fixity - `ext2Q` located - where generic :: Data a => a -> String - generic t = indent n ++ "(" ++ showConstr (toConstr t) - ++ space (unwords (gmapQ (showAstData' (n+1)) t)) ++ ")" - - space "" = "" - space s = ' ':s - - indent i = "\n" ++ replicate i ' ' - - string :: String -> String - string = normalize_newlines . show - - fastString :: FastString -> String - fastString = ("{FastString: "++) . (++"}") . normalize_newlines - . show - - bytestring :: B.ByteString -> String - bytestring = normalize_newlines . show - - list l = indent n ++ "[" - ++ intercalate "," (map (showAstData' (n+1)) l) - ++ "]" - - -- Eliminate word-size dependence - lit :: HsLit -> String - lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s - lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s - lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s - lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s - lit l = generic l - - numericLit :: String -> Integer -> SourceText -> String - numericLit tag x s = indent n ++ unwords [ "{" ++ tag - , generic x - , generic s ++ "}" ] - - name :: Name -> String - name = ("{Name: "++) . (++"}") . showSDocDebug_ . ppr - - occName = ("{OccName: "++) . (++"}") . OccName.occNameString - - moduleName :: ModuleName -> String - moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr - - srcSpan :: SrcSpan -> String - srcSpan ss = case b of - BlankSrcSpan -> "{ "++ "ss" ++"}" - NoBlankSrcSpan -> - "{ "++ showSDoc_ (hang (ppr ss) (n+2) - -- TODO: show annotations here - (text "") - ) - ++"}" - - var :: Var -> String - var = ("{Var: "++) . (++"}") . showSDocDebug_ . ppr - - dataCon :: DataCon -> String - dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr - - bagRdrName:: Bag (Located (HsBind RdrName)) -> String - bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") - . list . bagToList - - bagName :: Bag (Located (HsBind Name)) -> String - bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") - . list . bagToList - - bagVar :: Bag (Located (HsBind Var)) -> String - bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") - . list . bagToList - - nameSet = ("{NameSet: "++) . (++"}") . list . nameSetElemsStable - - fixity :: Fixity -> String - fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr - - located :: (Data b,Data loc) => GenLocated loc b -> String - located (L ss a) = - indent n ++ "(" - ++ case cast ss of - Just (s :: SrcSpan) -> - srcSpan s - Nothing -> "nnnnnnnn" - ++ showAstData' (n+1) a - ++ ")" - -normalize_newlines :: String -> String -normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs -normalize_newlines (x:xs) = x:normalize_newlines xs -normalize_newlines [] = [] - -showSDoc_ :: SDoc -> String -showSDoc_ = normalize_newlines . showSDoc unsafeGlobalDynFlags - -showSDocDebug_ :: SDoc -> String -showSDocDebug_ = normalize_newlines . showSDocDebug unsafeGlobalDynFlags - -{- -************************************************************************ -* * -* Copied from syb -* * -************************************************************************ --} - - --- | The type constructor for queries -newtype Q q x = Q { unQ :: x -> q } - --- | Extend a generic query by a type-specific case -extQ :: ( Typeable a - , Typeable b - ) - => (a -> q) - -> (b -> q) - -> a - -> q -extQ f g a = maybe (f a) g (cast a) - --- | Type extension of queries for type constructors -ext1Q :: (Data d, Typeable t) - => (d -> q) - -> (forall e. Data e => t e -> q) - -> d -> q -ext1Q def ext = unQ ((Q def) `ext1` (Q ext)) - - --- | Type extension of queries for type constructors -ext2Q :: (Data d, Typeable t) - => (d -> q) - -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) - -> d -> q -ext2Q def ext = unQ ((Q def) `ext2` (Q ext)) - --- | Flexible type extension -ext1 :: (Data a, Typeable t) - => c a - -> (forall d. Data d => c (t d)) - -> c a -ext1 def ext = maybe def id (dataCast1 ext) - - - --- | Flexible type extension -ext2 :: (Data a, Typeable t) - => c a - -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) - -> c a -ext2 def ext = maybe def id (dataCast2 ext) diff --git a/hsSyn/HsExpr.hs b/hsSyn/HsExpr.hs deleted file mode 100644 --- a/hsSyn/HsExpr.hs +++ /dev/null @@ -1,2556 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DeriveFunctor #-} - --- | Abstract Haskell syntax for expressions. -module HsExpr where - -#include "HsVersions.h" - --- friends: -import HsDecls -import HsPat -import HsLit -import PlaceHolder ( PostTc,PostRn,DataId,DataIdPost, - NameOrRdrName,OutputableBndrId ) -import HsTypes -import HsBinds - --- others: -import TcEvidence -import CoreSyn -import Var -import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) -import Name -import NameSet -import RdrName ( GlobalRdrEnv ) -import BasicTypes -import ConLike -import SrcLoc -import Util -import Outputable -import FastString -import Type - --- libraries: -import Data.Data hiding (Fixity(..)) -import qualified Data.Data as Data (Fixity(..)) -import Data.Maybe (isNothing) - -import GHCi.RemoteTypes ( ForeignRef ) -import qualified Language.Haskell.TH as TH (Q) - -{- -************************************************************************ -* * -\subsection{Expressions proper} -* * -************************************************************************ --} - --- * Expressions proper - --- | Located Haskell Expression -type LHsExpr id = Located (HsExpr id) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when - -- in a list - - -- For details on above see note [Api annotations] in ApiAnnotation - -------------------------- --- | Post-Type checking Expression --- --- PostTcExpr is an evidence expression attached to the syntax tree by the --- type checker (c.f. postTcType). -type PostTcExpr = HsExpr Id - --- | Post-Type checking Table --- --- We use a PostTcTable where there are a bunch of pieces of evidence, more --- than is convenient to keep individually. -type PostTcTable = [(Name, PostTcExpr)] - -noPostTcExpr :: PostTcExpr -noPostTcExpr = HsLit (HsString NoSourceText (fsLit "noPostTcExpr")) - -noPostTcTable :: PostTcTable -noPostTcTable = [] - -------------------------- --- | Syntax Expression --- --- SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier, --- by the renamer. It's used for rebindable syntax. --- --- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for --- @(>>=)@, and then instantiated by the type checker with its type args --- etc --- --- This should desugar to --- --- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0) --- > (syn_arg_wraps[1] arg1) ... --- --- where the actual arguments come from elsewhere in the AST. --- This could be defined using @PostRn@ and @PostTc@ and such, but it's --- harder to get it all to work out that way. ('noSyntaxExpr' is hard to --- write, for example.) -data SyntaxExpr id = SyntaxExpr { syn_expr :: HsExpr id - , syn_arg_wraps :: [HsWrapper] - , syn_res_wrap :: HsWrapper } -deriving instance (DataId id) => Data (SyntaxExpr id) - --- | This is used for rebindable-syntax pieces that are too polymorphic --- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) -noExpr :: HsExpr id -noExpr = HsLit (HsString (SourceText "noExpr") (fsLit "noExpr")) - -noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after, - -- (if the syntax slot makes no sense) -noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString NoSourceText - (fsLit "noSyntaxExpr")) - , syn_arg_wraps = [] - , syn_res_wrap = WpHole } - --- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the --- renamer), missing its HsWrappers. -mkRnSyntaxExpr :: Name -> SyntaxExpr Name -mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name - , syn_arg_wraps = [] - , syn_res_wrap = WpHole } - -- don't care about filling in syn_arg_wraps because we're clearly - -- not past the typechecker - -instance (OutputableBndrId id) => Outputable (SyntaxExpr id) where - ppr (SyntaxExpr { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - = sdocWithDynFlags $ \ dflags -> - getPprStyle $ \s -> - if debugStyle s || gopt Opt_PrintExplicitCoercions dflags - then ppr expr <> braces (pprWithCommas ppr arg_wraps) - <> braces (ppr res_wrap) - else ppr expr - --- | Command Syntax Table (for Arrow syntax) -type CmdSyntaxTable id = [(Name, HsExpr id)] --- See Note [CmdSyntaxTable] - -{- -Note [CmdSyntaxtable] -~~~~~~~~~~~~~~~~~~~~~ -Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps -track of the methods needed for a Cmd. - -* Before the renamer, this list is an empty list - -* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ - For example, for the 'arr' method - * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) - * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) - where @arr_22@ is whatever 'arr' is in scope - -* After the type checker, it takes the form [(std_name, )] - where is the evidence for the method. This evidence is - instantiated with the class, but is still polymorphic in everything - else. For example, in the case of 'arr', the evidence has type - forall b c. (b->c) -> a b c - where 'a' is the ambient type of the arrow. This polymorphism is - important because the desugarer uses the same evidence at multiple - different types. - -This is Less Cool than what we normally do for rebindable syntax, which is to -make fully-instantiated piece of evidence at every use site. The Cmd way -is Less Cool because - * The renamer has to predict which methods are needed. - See the tedious RnExpr.methodNamesCmd. - - * The desugarer has to know the polymorphic type of the instantiated - method. This is checked by Inst.tcSyntaxName, but is less flexible - than the rest of rebindable syntax, where the type is less - pre-ordained. (And this flexibility is useful; for example we can - typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) --} - --- | An unbound variable; used for treating out-of-scope variables as --- expression holes -data UnboundVar - = OutOfScope OccName GlobalRdrEnv -- ^ An (unqualified) out-of-scope - -- variable, together with the GlobalRdrEnv - -- with respect to which it is unbound - - -- See Note [OutOfScope and GlobalRdrEnv] - - | TrueExprHole OccName -- ^ A "true" expression hole (_ or _x) - - deriving Data - -instance Outputable UnboundVar where - ppr = ppr . unboundVarOcc - -unboundVarOcc :: UnboundVar -> OccName -unboundVarOcc (OutOfScope occ _) = occ -unboundVarOcc (TrueExprHole occ) = occ - -{- -Note [OutOfScope and GlobalRdrEnv] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To understand why we bundle a GlobalRdrEnv with an out-of-scope variable, -consider the following module: - - module A where - - foo :: () - foo = bar - - bat :: [Double] - bat = [1.2, 3.4] - - $(return []) - - bar = () - bad = False - -When A is compiled, the renamer determines that `bar` is not in scope in the -declaration of `foo` (since `bar` is declared in the following inter-splice -group). Once it has finished typechecking the entire module, the typechecker -then generates the associated error message, which specifies both the type of -`bar` and a list of possible in-scope alternatives: - - A.hs:6:7: error: - • Variable not in scope: bar :: () - • ‘bar’ (line 13) is not in scope before the splice on line 11 - Perhaps you meant ‘bat’ (line 9) - -When it calls RnEnv.unknownNameSuggestions to identify these alternatives, the -typechecker must provide a GlobalRdrEnv. If it provided the current one, which -contains top-level declarations for the entire module, the error message would -incorrectly suggest the out-of-scope `bar` and `bad` as possible alternatives -for `bar` (see Trac #11680). Instead, the typechecker must use the same -GlobalRdrEnv the renamer used when it determined that `bar` is out-of-scope. - -To obtain this GlobalRdrEnv, can the typechecker simply use the out-of-scope -`bar`'s location to either reconstruct it (from the current GlobalRdrEnv) or to -look it up in some global store? Unfortunately, no. The problem is that -location information is not always sufficient for this task. This is most -apparent when dealing with the TH function addTopDecls, which adds its -declarations to the FOLLOWING inter-splice group. Consider these declarations: - - ex9 = cat -- cat is NOT in scope here - - $(do ------------------------------------------------------------- - ds <- [d| f = cab -- cat and cap are both in scope here - cat = () - |] - addTopDecls ds - [d| g = cab -- only cap is in scope here - cap = True - |]) - - ex10 = cat -- cat is NOT in scope here - - $(return []) ----------------------------------------------------- - - ex11 = cat -- cat is in scope - -Here, both occurrences of `cab` are out-of-scope, and so the typechecker needs -the GlobalRdrEnvs which were used when they were renamed. These GlobalRdrEnvs -are different (`cat` is present only in the GlobalRdrEnv for f's `cab'), but the -locations of the two `cab`s are the same (they are both created in the same -splice). Thus, we must include some additional information with each `cab` to -allow the typechecker to obtain the correct GlobalRdrEnv. Clearly, the simplest -information to use is the GlobalRdrEnv itself. --} - --- | A Haskell expression. -data HsExpr id - = HsVar (Located id) -- ^ Variable - - -- See Note [Located RdrNames] - - | HsUnboundVar UnboundVar -- ^ Unbound variable; also used for "holes" - -- (_ or _x). - -- Turned from HsVar to HsUnboundVar by the - -- renamer, when it finds an out-of-scope - -- variable or hole. - -- Turned into HsVar by type checker, to support - -- deferred type errors. - - | HsConLikeOut ConLike -- ^ After typechecker only; must be different - -- HsVar for pretty printing - - | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector - -- Not in use after typechecking - - | HsOverLabel (Maybe id) FastString - -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) - -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the - -- in-scope 'fromLabel'. - -- NB: Not in use after typechecking - - | HsIPVar HsIPName -- ^ Implicit parameter (not in use after typechecking) - | HsOverLit (HsOverLit id) -- ^ Overloaded literals - - | HsLit HsLit -- ^ Simple (non-overloaded) literals - - | HsLam (MatchGroup id (LHsExpr id)) -- ^ Lambda abstraction. Currently always a single match - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', - -- 'ApiAnnotation.AnnRarrow', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsLamCase (MatchGroup id (LHsExpr id)) -- ^ Lambda-case - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', - -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsApp (LHsExpr id) (LHsExpr id) -- ^ Application - - | HsAppType (LHsExpr id) (LHsWcType id) -- ^ Visible type application - -- - -- Explicit type argument; e.g f @Int x y - -- NB: Has wildcards, but no implicit quantification - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt', - - | HsAppTypeOut (LHsExpr id) (LHsWcType Name) -- just for pretty-printing - - - -- | Operator applications: - -- NB Bracketed ops such as (+) come out as Vars. - - -- NB We need an expr for the operator in an OpApp/Section since - -- the typechecker may need to apply the operator to a few types. - - | OpApp (LHsExpr id) -- left operand - (LHsExpr id) -- operator - (PostRn id Fixity) -- Renamer adds fixity; bottom until then - (LHsExpr id) -- right operand - - -- | Negation operator. Contains the negated expression and the name - -- of 'negate' - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus' - - -- For details on above see note [Api annotations] in ApiAnnotation - | NegApp (LHsExpr id) - (SyntaxExpr id) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsPar (LHsExpr id) -- ^ Parenthesised expr; see Note [Parens in HsSyn] - - | SectionL (LHsExpr id) -- operand; see Note [Sections in HsSyn] - (LHsExpr id) -- operator - | SectionR (LHsExpr id) -- operator; see Note [Sections in HsSyn] - (LHsExpr id) -- operand - - -- | Used for explicit tuples and sections thereof - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | ExplicitTuple - [LHsTupArg id] - Boxity - - -- | Used for unboxed sum types - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, - -- 'ApiAnnotation.AnnVbar', 'ApiAnnotation.AnnClose' @'#)'@, - -- - -- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before - -- the expression, (arity - alternative) after it - | ExplicitSum - ConTag -- Alternative (one-based) - Arity -- Sum arity - (LHsExpr id) - (PostTc id [Type]) -- the type arguments - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', - -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsCase (LHsExpr id) - (MatchGroup id (LHsExpr id)) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', - -- 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnElse', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsIf (Maybe (SyntaxExpr id)) -- cond function - -- Nothing => use the built-in 'if' - -- See Note [Rebindable if] - (LHsExpr id) -- predicate - (LHsExpr id) -- then part - (LHsExpr id) -- else part - - -- | Multi-way if - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf' - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsMultiIf (PostTc id Type) [LGRHS id (LHsExpr id)] - - -- | let(rec) - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', - -- 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsLet (LHsLocalBinds id) - (LHsExpr id) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', - -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnVbar', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsDo (HsStmtContext Name) -- The parameterisation is unimportant - -- because in this context we never use - -- the PatGuard or ParStmt variant - (Located [ExprLStmt id]) -- "do":one or more stmts - (PostTc id Type) -- Type of the whole expression - - -- | Syntactic list: [a,b,c,...] - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | ExplicitList - (PostTc id Type) -- Gives type of components of list - (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness - [LHsExpr id] - - -- | Syntactic parallel array: [:e1, ..., en:] - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma', - -- 'ApiAnnotation.AnnVbar' - -- 'ApiAnnotation.AnnClose' @':]'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | ExplicitPArr - (PostTc id Type) -- type of elements of the parallel array - [LHsExpr id] - - -- | Record construction - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | RecordCon - { rcon_con_name :: Located id -- The constructor name; - -- not used after type checking - , rcon_con_like :: PostTc id ConLike -- The data constructor or pattern synonym - , rcon_con_expr :: PostTcExpr -- Instantiated constructor function - , rcon_flds :: HsRecordBinds id } -- The fields - - -- | Record update - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | RecordUpd - { rupd_expr :: LHsExpr id - , rupd_flds :: [LHsRecUpdField id] - , rupd_cons :: PostTc id [ConLike] - -- Filled in by the type checker to the - -- _non-empty_ list of DataCons that have - -- all the upd'd fields - - , rupd_in_tys :: PostTc id [Type] -- Argument types of *input* record type - , rupd_out_tys :: PostTc id [Type] -- and *output* record type - -- The original type can be reconstructed - -- with conLikeResTy - , rupd_wrap :: PostTc id HsWrapper -- See note [Record Update HsWrapper] - } - -- For a type family, the arg types are of the *instance* tycon, - -- not the family tycon - - -- | Expression with an explicit type signature. @e :: type@ - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | ExprWithTySig - (LHsExpr id) - (LHsSigWcType id) - - | ExprWithTySigOut -- Post typechecking - (LHsExpr id) - (LHsSigWcType Name) -- Retain the signature, - -- as HsSigType Name, for - -- round-tripping purposes - - -- | Arithmetic sequence - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot', - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | ArithSeq - PostTcExpr - (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromList witness - (ArithSeqInfo id) - - -- | Arithmetic sequence for parallel array - -- - -- > [:e1..e2:] or [:e1, e2..e3:] - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, - -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot', - -- 'ApiAnnotation.AnnVbar', - -- 'ApiAnnotation.AnnClose' @':]'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | PArrSeq - PostTcExpr - (ArithSeqInfo id) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@, - -- 'ApiAnnotation.AnnVal' or 'ApiAnnotation.AnnValStr', - -- 'ApiAnnotation.AnnClose' @'\#-}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsSCC SourceText -- Note [Pragma source text] in BasicTypes - StringLiteral -- "set cost centre" SCC pragma - (LHsExpr id) -- expr whose cost is to be measured - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, - -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes - StringLiteral -- hdaume: core annotation - (LHsExpr id) - - ----------------------------------------------------------- - -- MetaHaskell Extensions - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpenE','ApiAnnotation.AnnOpenEQ', - -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsBracket (HsBracket id) - - -- See Note [Pending Splices] - | HsRnBracketOut - (HsBracket Name) -- Output of the renamer is the *original* renamed - -- expression, plus - [PendingRnSplice] -- _renamed_ splices to be type checked - - | HsTcBracketOut - (HsBracket Name) -- Output of the type checker is the *original* - -- renamed expression, plus - [PendingTcSplice] -- _typechecked_ splices to be - -- pasted back in by the desugarer - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsSpliceE (HsSplice id) - - ----------------------------------------------------------- - -- Arrow notation extension - - -- | @proc@ notation for Arrows - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc', - -- 'ApiAnnotation.AnnRarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsProc (LPat id) -- arrow abstraction, proc - (LHsCmdTop id) -- body of the abstraction - -- always has an empty stack - - --------------------------------------- - -- static pointers extension - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsStatic (PostRn id NameSet) -- Free variables of the body - (LHsExpr id) -- Body - - --------------------------------------- - -- The following are commands, not expressions proper - -- They are only used in the parsing stage and are removed - -- immediately in parser.RdrHsSyn.checkCommand - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail', - -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail', - -- 'ApiAnnotation.AnnRarrowtail' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsArrApp -- Arrow tail, or arrow application (f -< arg) - (LHsExpr id) -- arrow expression, f - (LHsExpr id) -- input expression, arg - (PostTc id Type) -- type of the arrow expressions f, - -- of the form a t t', where arg :: t - HsArrAppType -- higher-order (-<<) or first-order (-<) - Bool -- True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@, - -- 'ApiAnnotation.AnnCloseB' @'|)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) - (LHsExpr id) -- the operator - -- after type-checking, a type abstraction to be - -- applied to the type of the local environment tuple - (Maybe Fixity) -- fixity (filled in by the renamer), for forms that - -- were converted from OpApp's by the renamer - [LHsCmdTop id] -- argument commands - - --------------------------------------- - -- Haskell program coverage (Hpc) Support - - | HsTick - (Tickish id) - (LHsExpr id) -- sub-expression - - | HsBinTick - Int -- module-local tick number for True - Int -- module-local tick number for False - (LHsExpr id) -- sub-expression - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnMinus', - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon', - -- 'ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose' @'\#-}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsTickPragma -- A pragma introduced tick - SourceText -- Note [Pragma source text] in BasicTypes - (StringLiteral,(Int,Int),(Int,Int)) - -- external span for this tick - ((SourceText,SourceText),(SourceText,SourceText)) - -- Source text for the four integers used in the span. - -- See note [Pragma source text] in BasicTypes - (LHsExpr id) - - --------------------------------------- - -- These constructors only appear temporarily in the parser. - -- The renamer translates them into the Right Thing. - - | EWildPat -- wildcard - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' - - -- For details on above see note [Api annotations] in ApiAnnotation - | EAsPat (Located id) -- as pattern - (LHsExpr id) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | EViewPat (LHsExpr id) -- view pattern - (LHsExpr id) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' - - -- For details on above see note [Api annotations] in ApiAnnotation - | ELazyPat (LHsExpr id) -- ~ pattern - - - --------------------------------------- - -- Finally, HsWrap appears only in typechecker output - - | HsWrap HsWrapper -- TRANSLATION - (HsExpr id) - -deriving instance (DataId id) => Data (HsExpr id) - --- | Located Haskell Tuple Argument --- --- 'HsTupArg' is used for tuple sections --- @(,a,)@ is represented by --- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@ --- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@ -type LHsTupArg id = Located (HsTupArg id) --- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' - --- For details on above see note [Api annotations] in ApiAnnotation - --- | Haskell Tuple Argument -data HsTupArg id - = Present (LHsExpr id) -- ^ The argument - | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type -deriving instance (DataId id) => Data (HsTupArg id) - -tupArgPresent :: LHsTupArg id -> Bool -tupArgPresent (L _ (Present {})) = True -tupArgPresent (L _ (Missing {})) = False - -{- -Note [Parens in HsSyn] -~~~~~~~~~~~~~~~~~~~~~~ -HsPar (and ParPat in patterns, HsParTy in types) is used as follows - - * HsPar is required; the pretty printer does not add parens. - - * HsPars are respected when rearranging operator fixities. - So a * (b + c) means what it says (where the parens are an HsPar) - - * For ParPat and HsParTy the pretty printer does add parens but this should be - a no-op for ParsedSource, based on the pretty printer round trip feature - introduced in - https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c - - * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or - not they are strictly necssary. This should be addressed when #13238 is - completed, to be treated the same as HsPar. - - -Note [Sections in HsSyn] -~~~~~~~~~~~~~~~~~~~~~~~~ -Sections should always appear wrapped in an HsPar, thus - HsPar (SectionR ...) -The parser parses sections in a wider variety of situations -(See Note [Parsing sections]), but the renamer checks for those -parens. This invariant makes pretty-printing easier; we don't need -a special case for adding the parens round sections. - -Note [Rebindable if] -~~~~~~~~~~~~~~~~~~~~ -The rebindable syntax for 'if' is a bit special, because when -rebindable syntax is *off* we do not want to treat - (if c then t else e) -as if it was an application (ifThenElse c t e). Why not? -Because we allow an 'if' to return *unboxed* results, thus - if blah then 3# else 4# -whereas that would not be possible using a all to a polymorphic function -(because you can't call a polymorphic function at an unboxed type). - -So we use Nothing to mean "use the old built-in typing rule". - -Note [Record Update HsWrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is a wrapper in RecordUpd which is used for the *required* -constraints for pattern synonyms. This wrapper is created in the -typechecking and is then directly used in the desugaring without -modification. - -For example, if we have the record pattern synonym P, - pattern P :: (Show a) => a -> Maybe a - pattern P{x} = Just x - - foo = (Just True) { x = False } -then `foo` desugars to something like - foo = case Just True of - P x -> P False -hence we need to provide the correct dictionaries to P's matcher on -the RHS so that we can build the expression. - -Note [Located RdrNames] -~~~~~~~~~~~~~~~~~~~~~~~ -A number of syntax elements have seemingly redundant locations attached to them. -This is deliberate, to allow transformations making use of the API Annotations -to easily correlate a Located Name in the RenamedSource with a Located RdrName -in the ParsedSource. - -There are unfortunately enough differences between the ParsedSource and the -RenamedSource that the API Annotations cannot be used directly with -RenamedSource, so this allows a simple mapping to be used based on the location. --} - -instance (OutputableBndrId id) => Outputable (HsExpr id) where - ppr expr = pprExpr expr - ------------------------ --- pprExpr, pprLExpr, pprBinds call pprDeeper; --- the underscore versions do not -pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc -pprLExpr (L _ e) = pprExpr e - -pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc -pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e - | otherwise = pprDeeper (ppr_expr e) - -isQuietHsExpr :: HsExpr id -> Bool --- Parentheses do display something, but it gives little info and --- if we go deeper when we go inside them then we get ugly things --- like (...) -isQuietHsExpr (HsPar _) = True --- applications don't display anything themselves -isQuietHsExpr (HsApp _ _) = True -isQuietHsExpr (HsAppType _ _) = True -isQuietHsExpr (HsAppTypeOut _ _) = True -isQuietHsExpr (OpApp _ _ _ _) = True -isQuietHsExpr _ = False - -pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) - => HsLocalBindsLR idL idR -> SDoc -pprBinds b = pprDeeper (ppr b) - ------------------------ -ppr_lexpr :: (OutputableBndrId id) => LHsExpr id -> SDoc -ppr_lexpr e = ppr_expr (unLoc e) - -ppr_expr :: forall id. (OutputableBndrId id) => HsExpr id -> SDoc -ppr_expr (HsVar (L _ v)) = pprPrefixOcc v -ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv) -ppr_expr (HsConLikeOut c) = pprPrefixOcc c -ppr_expr (HsIPVar v) = ppr v -ppr_expr (HsOverLabel _ l)= char '#' <> ppr l -ppr_expr (HsLit lit) = ppr lit -ppr_expr (HsOverLit lit) = ppr lit -ppr_expr (HsPar e) = parens (ppr_lexpr e) - -ppr_expr (HsCoreAnn stc (StringLiteral sta s) e) - = vcat [pprWithSourceText stc (text "{-# CORE") - <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" - , ppr_lexpr e] - -ppr_expr e@(HsApp {}) = ppr_apps e [] -ppr_expr e@(HsAppType {}) = ppr_apps e [] -ppr_expr e@(HsAppTypeOut {}) = ppr_apps e [] - -ppr_expr (OpApp e1 op _ e2) - | Just pp_op <- should_print_infix (unLoc op) - = pp_infixly pp_op - | otherwise - = pp_prefixly - - where - should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v) - should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c)) - should_print_infix (HsRecFld f) = Just (pprInfixOcc f) - should_print_infix (HsUnboundVar h@TrueExprHole{}) - = Just (pprInfixOcc (unboundVarOcc h)) - should_print_infix EWildPat = Just (text "`_`") - should_print_infix (HsWrap _ e) = should_print_infix e - should_print_infix _ = Nothing - - pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens - pp_e2 = pprDebugParendExpr e2 -- to make precedence clear - - pp_prefixly - = hang (ppr op) 2 (sep [pp_e1, pp_e2]) - - pp_infixly pp_op - = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) - -ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e - -ppr_expr (SectionL expr op) - = case unLoc op of - HsVar (L _ v) -> pp_infixly v - HsConLikeOut c -> pp_infixly (conLikeName c) - _ -> pp_prefixly - where - pp_expr = pprDebugParendExpr expr - - pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) - 4 (hsep [pp_expr, text "x_ )"]) - pp_infixly v = (sep [pp_expr, pprInfixOcc v]) - -ppr_expr (SectionR op expr) - = case unLoc op of - HsVar (L _ v) -> pp_infixly v - HsConLikeOut c -> pp_infixly (conLikeName c) - _ -> pp_prefixly - where - pp_expr = pprDebugParendExpr expr - - pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) - 4 (pp_expr <> rparen) - pp_infixly v = sep [pprInfixOcc v, pp_expr] - -ppr_expr (ExplicitTuple exprs boxity) - = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) - where - ppr_tup_args [] = [] - ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es - ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es - - punc (Present {} : _) = comma <> space - punc (Missing {} : _) = comma - punc [] = empty - -ppr_expr (ExplicitSum alt arity expr _) - = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" - where - ppr_bars n = hsep (replicate n (char '|')) - -ppr_expr (HsLam matches) - = pprMatches matches - -ppr_expr (HsLamCase matches) - = sep [ sep [text "\\case"], - nest 2 (pprMatches matches) ] - -ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] })) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], - nest 2 (pprMatches matches) <+> char '}'] -ppr_expr (HsCase expr matches) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], - nest 2 (pprMatches matches) ] - -ppr_expr (HsIf _ e1 e2 e3) - = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], - nest 4 (ppr e2), - text "else", - nest 4 (ppr e3)] - -ppr_expr (HsMultiIf _ alts) - = hang (text "if") 3 (vcat (map ppr_alt alts)) - where ppr_alt (L _ (GRHS guards expr)) = - hang vbar 2 (ppr_one one_alt) - where - ppr_one [] = panic "ppr_exp HsMultiIf" - ppr_one (h:t) = hang h 2 (sep t) - one_alt = [ interpp'SP guards - , text "->" <+> pprDeeper (ppr expr) ] - --- special case: let ... in let ... -ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _))) - = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), - ppr_lexpr expr] - -ppr_expr (HsLet (L _ binds) expr) - = sep [hang (text "let") 2 (pprBinds binds), - hang (text "in") 2 (ppr expr)] - -ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts - -ppr_expr (ExplicitList _ _ exprs) - = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) - -ppr_expr (ExplicitPArr _ exprs) - = paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) - -ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) - = hang (ppr con_id) 2 (ppr rbinds) - -ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) - = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) - -ppr_expr (ExprWithTySig expr sig) - = hang (nest 2 (ppr_lexpr expr) <+> dcolon) - 4 (ppr sig) -ppr_expr (ExprWithTySigOut expr sig) - = hang (nest 2 (ppr_lexpr expr) <+> dcolon) - 4 (ppr sig) - -ppr_expr (ArithSeq _ _ info) = brackets (ppr info) -ppr_expr (PArrSeq _ info) = paBrackets (ppr info) - -ppr_expr EWildPat = char '_' -ppr_expr (ELazyPat e) = char '~' <> ppr e -ppr_expr (EAsPat v e) = ppr v <> char '@' <> ppr e -ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e - -ppr_expr (HsSCC st (StringLiteral stl lbl) expr) - = sep [ pprWithSourceText st (text "{-# SCC") - -- no doublequotes if stl empty, for the case where the SCC was written - -- without quotes. - <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", - ppr expr ] - -ppr_expr (HsWrap co_fn e) - = pprHsWrapper co_fn (\parens -> if parens then pprExpr e - else pprExpr e) - -ppr_expr (HsSpliceE s) = pprSplice s -ppr_expr (HsBracket b) = pprHsBracket b -ppr_expr (HsRnBracketOut e []) = ppr e -ppr_expr (HsRnBracketOut e ps) = ppr e $$ text "pending(rn)" <+> ppr ps -ppr_expr (HsTcBracketOut e []) = ppr e -ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps - -ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) - = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] - -ppr_expr (HsStatic _ e) - = hsep [text "static", ppr e] - -ppr_expr (HsTick tickish exp) - = pprTicks (ppr exp) $ - ppr tickish <+> ppr_lexpr exp -ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) - = pprTicks (ppr exp) $ - hcat [text "bintick<", - ppr tickIdTrue, - text ",", - ppr tickIdFalse, - text ">(", - ppr exp, text ")"] -ppr_expr (HsTickPragma _ externalSrcLoc _ exp) - = pprTicks (ppr exp) $ - hcat [text "tickpragma<", - pprExternalSrcLoc externalSrcLoc, - text ">(", - ppr exp, - text ")"] - -ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) - = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] -ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False) - = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] -ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True) - = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] -ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) - = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] - -ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2]) - = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] -ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2]) - = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]] -ppr_expr (HsArrForm op _ args) - = hang (text "(|" <+> ppr_lexpr op) - 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") -ppr_expr (HsRecFld f) = ppr f - --- We must tiresomely make the "id" parameter to the LHsWcType existential --- because it's different in the HsAppType case and the HsAppTypeOut case --- | Located Haskell Wildcard Type Expression -data LHsWcTypeX = forall id. (OutputableBndrId id) => LHsWcTypeX (LHsWcType id) - -ppr_apps :: (OutputableBndrId id) => HsExpr id - -> [Either (LHsExpr id) LHsWcTypeX] - -> SDoc -ppr_apps (HsApp (L _ fun) arg) args - = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType (L _ fun) arg) args - = ppr_apps fun (Right (LHsWcTypeX arg) : args) -ppr_apps (HsAppTypeOut (L _ fun) arg) args - = ppr_apps fun (Right (LHsWcTypeX arg) : args) -ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args)) - where - pp (Left arg) = ppr arg - pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) - = char '@' <> pprParendHsType arg - -pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc -pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) - = ppr (src,(n1,n2),(n3,n4)) - -{- -HsSyn records exactly where the user put parens, with HsPar. -So generally speaking we print without adding any parens. -However, some code is internally generated, and in some places -parens are absolutely required; so for these places we use -pprParendLExpr (but don't print double parens of course). - -For operator applications we don't add parens, because the operator -fixities should do the job, except in debug mode (-dppr-debug) so we -can see the structure of the parse tree. --} - -pprDebugParendExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc -pprDebugParendExpr expr - = getPprStyle (\sty -> - if debugStyle sty then pprParendLExpr expr - else pprLExpr expr) - -pprParendLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc -pprParendLExpr (L _ e) = pprParendExpr e - -pprParendExpr :: (OutputableBndrId id) => HsExpr id -> SDoc -pprParendExpr expr - | hsExprNeedsParens expr = parens (pprExpr expr) - | otherwise = pprExpr expr - -- Using pprLExpr makes sure that we go 'deeper' - -- I think that is usually (always?) right - -hsExprNeedsParens :: HsExpr id -> Bool --- True of expressions for which '(e)' and 'e' --- mean the same thing -hsExprNeedsParens (ArithSeq {}) = False -hsExprNeedsParens (PArrSeq {}) = False -hsExprNeedsParens (HsLit {}) = False -hsExprNeedsParens (HsOverLit {}) = False -hsExprNeedsParens (HsVar {}) = False -hsExprNeedsParens (HsUnboundVar {}) = False -hsExprNeedsParens (HsConLikeOut {}) = False -hsExprNeedsParens (HsIPVar {}) = False -hsExprNeedsParens (HsOverLabel {}) = False -hsExprNeedsParens (ExplicitTuple {}) = False -hsExprNeedsParens (ExplicitList {}) = False -hsExprNeedsParens (ExplicitPArr {}) = False -hsExprNeedsParens (HsPar {}) = False -hsExprNeedsParens (HsBracket {}) = False -hsExprNeedsParens (HsRnBracketOut {}) = False -hsExprNeedsParens (HsTcBracketOut {}) = False -hsExprNeedsParens (HsDo sc _ _) - | isListCompExpr sc = False -hsExprNeedsParens (HsRecFld{}) = False -hsExprNeedsParens (RecordCon{}) = False -hsExprNeedsParens (HsSpliceE{}) = False -hsExprNeedsParens (RecordUpd{}) = False -hsExprNeedsParens (HsWrap _ e) = hsExprNeedsParens e -hsExprNeedsParens _ = True - - -isAtomicHsExpr :: HsExpr id -> Bool --- True of a single token -isAtomicHsExpr (HsVar {}) = True -isAtomicHsExpr (HsConLikeOut {}) = True -isAtomicHsExpr (HsLit {}) = True -isAtomicHsExpr (HsOverLit {}) = True -isAtomicHsExpr (HsIPVar {}) = True -isAtomicHsExpr (HsOverLabel {}) = True -isAtomicHsExpr (HsUnboundVar {}) = True -isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e -isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e) -isAtomicHsExpr (HsRecFld{}) = True -isAtomicHsExpr _ = False - -{- -************************************************************************ -* * -\subsection{Commands (in arrow abstractions)} -* * -************************************************************************ - -We re-use HsExpr to represent these. --} - --- | Located Haskell Command (for arrow syntax) -type LHsCmd id = Located (HsCmd id) - --- | Haskell Command (e.g. a "statement" in an Arrow proc block) -data HsCmd id - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail', - -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail', - -- 'ApiAnnotation.AnnRarrowtail' - - -- For details on above see note [Api annotations] in ApiAnnotation - = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) - (LHsExpr id) -- arrow expression, f - (LHsExpr id) -- input expression, arg - (PostTc id Type) -- type of the arrow expressions f, - -- of the form a t t', where arg :: t - HsArrAppType -- higher-order (-<<) or first-order (-<) - Bool -- True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@, - -- 'ApiAnnotation.AnnCloseB' @'|)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) - (LHsExpr id) -- The operator. - -- After type-checking, a type abstraction to be - -- applied to the type of the local environment tuple - LexicalFixity -- Whether the operator appeared prefix or infix when - -- parsed. - (Maybe Fixity) -- fixity (filled in by the renamer), for forms that - -- were converted from OpApp's by the renamer - [LHsCmdTop id] -- argument commands - - | HsCmdApp (LHsCmd id) - (LHsExpr id) - - | HsCmdLam (MatchGroup id (LHsCmd id)) -- kappa - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', - -- 'ApiAnnotation.AnnRarrow', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdPar (LHsCmd id) -- parenthesised command - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdCase (LHsExpr id) - (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', - -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdIf (Maybe (SyntaxExpr id)) -- cond function - (LHsExpr id) -- predicate - (LHsCmd id) -- then part - (LHsCmd id) -- else part - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', - -- 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnElse', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdLet (LHsLocalBinds id) -- let(rec) - (LHsCmd id) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', - -- 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdDo (Located [CmdLStmt id]) - (PostTc id Type) -- Type of the whole expression - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', - -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnVbar', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdWrap HsWrapper - (HsCmd id) -- If cmd :: arg1 --> res - -- wrap :: arg1 "->" arg2 - -- Then (HsCmdWrap wrap cmd) :: arg2 --> res -deriving instance (DataId id) => Data (HsCmd id) - --- | Haskell Array Application Type -data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp - deriving Data - - -{- | Top-level command, introducing a new arrow. -This may occur inside a proc (where the stack is empty) or as an -argument of a command-forming operator. --} - --- | Located Haskell Top-level Command -type LHsCmdTop id = Located (HsCmdTop id) - --- | Haskell Top-level Command -data HsCmdTop id - = HsCmdTop (LHsCmd id) - (PostTc id Type) -- Nested tuple of inputs on the command's stack - (PostTc id Type) -- return type of the command - (CmdSyntaxTable id) -- See Note [CmdSyntaxTable] -deriving instance (DataId id) => Data (HsCmdTop id) - -instance (OutputableBndrId id) => Outputable (HsCmd id) where - ppr cmd = pprCmd cmd - ------------------------ --- pprCmd and pprLCmd call pprDeeper; --- the underscore versions do not -pprLCmd :: (OutputableBndrId id) => LHsCmd id -> SDoc -pprLCmd (L _ c) = pprCmd c - -pprCmd :: (OutputableBndrId id) => HsCmd id -> SDoc -pprCmd c | isQuietHsCmd c = ppr_cmd c - | otherwise = pprDeeper (ppr_cmd c) - -isQuietHsCmd :: HsCmd id -> Bool --- Parentheses do display something, but it gives little info and --- if we go deeper when we go inside them then we get ugly things --- like (...) -isQuietHsCmd (HsCmdPar _) = True --- applications don't display anything themselves -isQuietHsCmd (HsCmdApp _ _) = True -isQuietHsCmd _ = False - ------------------------ -ppr_lcmd :: (OutputableBndrId id) => LHsCmd id -> SDoc -ppr_lcmd c = ppr_cmd (unLoc c) - -ppr_cmd :: forall id. (OutputableBndrId id) => HsCmd id -> SDoc -ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) - -ppr_cmd (HsCmdApp c e) - = let (fun, args) = collect_args c [e] in - hang (ppr_lcmd fun) 2 (sep (map ppr args)) - where - collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args) - collect_args fun args = (fun, args) - -ppr_cmd (HsCmdLam matches) - = pprMatches matches - -ppr_cmd (HsCmdCase expr matches) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], - nest 2 (pprMatches matches) ] - -ppr_cmd (HsCmdIf _ e ct ce) - = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], - nest 4 (ppr ct), - text "else", - nest 4 (ppr ce)] - --- special case: let ... in let ... -ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _))) - = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), - ppr_lcmd cmd] - -ppr_cmd (HsCmdLet (L _ binds) cmd) - = sep [hang (text "let") 2 (pprBinds binds), - hang (text "in") 2 (ppr cmd)] - -ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts - -ppr_cmd (HsCmdWrap w cmd) - = pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) -ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True) - = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False) - = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True) - = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) - = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] - -ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _ [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _ [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm op _ _ args) - = hang (text "(|" <> ppr_lexpr op) - 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)") - -pprCmdArg :: (OutputableBndrId id) => HsCmdTop id -> SDoc -pprCmdArg (HsCmdTop cmd _ _ _) - = ppr_lcmd cmd - -instance (OutputableBndrId id) => Outputable (HsCmdTop id) where - ppr = pprCmdArg - -{- -************************************************************************ -* * -\subsection{Record binds} -* * -************************************************************************ --} - --- | Haskell Record Bindings -type HsRecordBinds id = HsRecFields id (LHsExpr id) - -{- -************************************************************************ -* * -\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} -* * -************************************************************************ - -@Match@es are sets of pattern bindings and right hand sides for -functions, patterns or case branches. For example, if a function @g@ -is defined as: -\begin{verbatim} -g (x,y) = y -g ((x:ys),y) = y+1, -\end{verbatim} -then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. - -It is always the case that each element of an @[Match]@ list has the -same number of @pats@s inside it. This corresponds to saying that -a function defined by pattern matching must have the same number of -patterns in each equation. --} - -data MatchGroup id body - = MG { mg_alts :: Located [LMatch id body] -- The alternatives - , mg_arg_tys :: [PostTc id Type] -- Types of the arguments, t1..tn - , mg_res_ty :: PostTc id Type -- Type of the result, tr - , mg_origin :: Origin } - -- The type is the type of the entire group - -- t1 -> ... -> tn -> tr - -- where there are n patterns -deriving instance (Data body,DataId id) => Data (MatchGroup id body) - --- | Located Match -type LMatch id body = Located (Match id body) --- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a --- list - --- For details on above see note [Api annotations] in ApiAnnotation -data Match id body - = Match { - m_ctxt :: HsMatchContext (NameOrRdrName id), - -- See note [m_ctxt in Match] - m_pats :: [LPat id], -- The patterns - m_type :: (Maybe (LHsType id)), - -- A type signature for the result of the match - -- Nothing after typechecking - -- NB: No longer supported - m_grhss :: (GRHSs id body) - } -deriving instance (Data body,DataId id) => Data (Match id body) - -instance (OutputableBndrId idR, Outputable body) - => Outputable (Match idR body) where - ppr = pprMatch - -{- -Note [m_ctxt in Match] -~~~~~~~~~~~~~~~~~~~~~~ - -A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and -so on. - -In order to simplify tooling processing and pretty print output, the provenance -is captured in an HsMatchContext. - -This is particularly important for the API Annotations for a multi-equation -FunBind. - -The parser initially creates a FunBind with a single Match in it for -every function definition it sees. - -These are then grouped together by getMonoBind into a single FunBind, -where all the Matches are combined. - -In the process, all the original FunBind fun_id's bar one are -discarded, including the locations. - -This causes a problem for source to source conversions via API -Annotations, so the original fun_ids and infix flags are preserved in -the Match, when it originates from a FunBind. - -Example infix function definition requiring individual API Annotations - - (&&& ) [] [] = [] - xs &&& [] = xs - ( &&& ) [] ys = ys - - - --} - - -isInfixMatch :: Match id body -> Bool -isInfixMatch match = case m_ctxt match of - FunRhs {mc_fixity = Infix} -> True - _ -> False - -isEmptyMatchGroup :: MatchGroup id body -> Bool -isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms - --- | Is there only one RHS in this list of matches? -isSingletonMatchGroup :: [LMatch id body] -> Bool -isSingletonMatchGroup matches - | [L _ match] <- matches - , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match - = True - | otherwise - = False - -matchGroupArity :: MatchGroup id body -> Arity --- Precondition: MatchGroup is non-empty --- This is called before type checking, when mg_arg_tys is not set -matchGroupArity (MG { mg_alts = alts }) - | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) - | otherwise = panic "matchGroupArity" - -hsLMatchPats :: LMatch id body -> [LPat id] -hsLMatchPats (L _ (Match _ pats _ _)) = pats - --- | Guarded Right-Hand Sides --- --- GRHSs are used both for pattern bindings and for Matches --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', --- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', --- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' --- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi' - --- For details on above see note [Api annotations] in ApiAnnotation -data GRHSs id body - = GRHSs { - grhssGRHSs :: [LGRHS id body], -- ^ Guarded RHSs - grhssLocalBinds :: LHsLocalBinds id -- ^ The where clause - } -deriving instance (Data body,DataId id) => Data (GRHSs id body) - --- | Located Guarded Right-Hand Side -type LGRHS id body = Located (GRHS id body) - --- | Guarded Right Hand Side. -data GRHS id body = GRHS [GuardLStmt id] -- Guards - body -- Right hand side -deriving instance (Data body,DataId id) => Data (GRHS id body) - --- We know the list must have at least one @Match@ in it. - -pprMatches :: (OutputableBndrId idR, Outputable body) - => MatchGroup idR body -> SDoc -pprMatches MG { mg_alts = matches } - = vcat (map pprMatch (map unLoc (unLoc matches))) - -- Don't print the type; it's only a place-holder before typechecking - --- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndrId idR, Outputable body) - => MatchGroup idR body -> SDoc -pprFunBind matches = pprMatches matches - --- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr id body. (OutputableBndrId bndr, - OutputableBndrId id, - Outputable body) - => LPat bndr -> GRHSs id body -> SDoc -pprPatBind pat (grhss) - = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)] - -pprMatch :: (OutputableBndrId idR, Outputable body) => Match idR body -> SDoc -pprMatch match - = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) - , nest 2 ppr_maybe_ty - , nest 2 (pprGRHSs ctxt (m_grhss match)) ] - where - ctxt = m_ctxt match - (herald, other_pats) - = case ctxt of - FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} - | strictness == SrcStrict -> ASSERT(null $ m_pats match) - (char '!'<>pprPrefixOcc fun, m_pats match) - -- a strict variable binding - | fixity == Prefix -> (pprPrefixOcc fun, m_pats match) - -- f x y z = e - -- Not pprBndr; the AbsBinds will - -- have printed the signature - - | null pats2 -> (pp_infix, []) - -- x &&& y = e - - | otherwise -> (parens pp_infix, pats2) - -- (x &&& y) z = e - where - pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2 - - LambdaExpr -> (char '\\', m_pats match) - - _ -> ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 ) - (ppr pat1, []) -- No parens around the single pat - - (pat1:pats1) = m_pats match - (pat2:pats2) = pats1 - ppr_maybe_ty = case m_type match of - Just ty -> dcolon <+> ppr ty - Nothing -> empty - - -pprGRHSs :: (OutputableBndrId idR, Outputable body) - => HsMatchContext idL -> GRHSs idR body -> SDoc -pprGRHSs ctxt (GRHSs grhss (L _ binds)) - = vcat (map (pprGRHS ctxt . unLoc) grhss) - -- Print the "where" even if the contents of the binds is empty. Only - -- EmptyLocalBinds means no "where" keyword - $$ ppUnless (eqEmptyLocalBinds binds) - (text "where" $$ nest 4 (pprBinds binds)) - -pprGRHS :: (OutputableBndrId idR, Outputable body) - => HsMatchContext idL -> GRHS idR body -> SDoc -pprGRHS ctxt (GRHS [] body) - = pp_rhs ctxt body - -pprGRHS ctxt (GRHS guards body) - = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] - -pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc -pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) - -{- -************************************************************************ -* * -\subsection{Do stmts and list comprehensions} -* * -************************************************************************ --} - --- | Located @do@ block Statement -type LStmt id body = Located (StmtLR id id body) - --- | Located Statement with separate Left and Right id's -type LStmtLR idL idR body = Located (StmtLR idL idR body) - --- | @do@ block Statement -type Stmt id body = StmtLR id id body - --- | Command Located Statement -type CmdLStmt id = LStmt id (LHsCmd id) - --- | Command Statement -type CmdStmt id = Stmt id (LHsCmd id) - --- | Expression Located Statement -type ExprLStmt id = LStmt id (LHsExpr id) - --- | Expression Statement -type ExprStmt id = Stmt id (LHsExpr id) - --- | Guard Located Statement -type GuardLStmt id = LStmt id (LHsExpr id) - --- | Guard Statement -type GuardStmt id = Stmt id (LHsExpr id) - --- | Ghci Located Statemnt -type GhciLStmt id = LStmt id (LHsExpr id) - --- | Ghci Statement -type GhciStmt id = Stmt id (LHsExpr id) - --- The SyntaxExprs in here are used *only* for do-notation and monad --- comprehensions, which have rebindable syntax. Otherwise they are unused. --- | API Annotations when in qualifier lists or guards --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', --- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen', --- 'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy', --- 'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing' - --- For details on above see note [Api annotations] in ApiAnnotation -data StmtLR idL idR body -- body should always be (LHs**** idR) - = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp, - -- and (after the renamer) DoExpr, MDoExpr - -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff - body - Bool -- True <=> return was stripped by ApplicativeDo - (SyntaxExpr idR) -- The return operator, used only for - -- MonadComp For ListComp, PArrComp, we - -- use the baked-in 'return' For DoExpr, - -- MDoExpr, we don't apply a 'return' at - -- all See Note [Monad Comprehensions] | - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnLarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | BindStmt (LPat idL) - body - (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts] - (SyntaxExpr idR) -- The fail operator - -- The fail operator is noSyntaxExpr - -- if the pattern match can't fail - - (PostTc idR Type) -- result type of the function passed to bind; - -- that is, S in (>>=) :: Q -> (R -> S) -> T - - -- | 'ApplicativeStmt' represents an applicative expression built with - -- <$> and <*>. It is generated by the renamer, and is desugared into the - -- appropriate applicative expression by the desugarer, but it is intended - -- to be invisible in error messages. - -- - -- For full details, see Note [ApplicativeDo] in RnExpr - -- - | ApplicativeStmt - [ ( SyntaxExpr idR - , ApplicativeArg idL idR) ] - -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] - (Maybe (SyntaxExpr idR)) -- 'join', if necessary - (PostTc idR Type) -- Type of the body - - | BodyStmt body -- See Note [BodyStmt] - (SyntaxExpr idR) -- The (>>) operator - (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp - -- See notes [Monad Comprehensions] - (PostTc idR Type) -- Element type of the RHS (used for arrows) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet' - -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@, - - -- For details on above see note [Api annotations] in ApiAnnotation - | LetStmt (LHsLocalBindsLR idL idR) - - -- ParStmts only occur in a list/monad comprehension - | ParStmt [ParStmtBlock idL idR] - (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions - (SyntaxExpr idR) -- The `>>=` operator - -- See notes [Monad Comprehensions] - (PostTc idR Type) -- S in (>>=) :: Q -> (R -> S) -> T - -- After renaming, the ids are the binders - -- bound by the stmts and used after themp - - | TransStmt { - trS_form :: TransForm, - trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' - -- which generates the tuples to be grouped - - trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map] - - trS_using :: LHsExpr idR, - trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) - -- Invariant: if trS_form = GroupBy, then grp_by = Just e - - trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for - -- the inner monad comprehensions - trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator - trS_bind_arg_ty :: PostTc idR Type, -- R in (>>=) :: Q -> (R -> S) -> T - trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring - -- Only for 'group' forms - -- Just a simple HsExpr, because it's - -- too polymorphic for tcSyntaxOp - } -- See Note [Monad Comprehensions] - - -- Recursive statement (see Note [How RecStmt works] below) - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec' - - -- For details on above see note [Api annotations] in ApiAnnotation - | RecStmt - { recS_stmts :: [LStmtLR idL idR body] - - -- The next two fields are only valid after renaming - , recS_later_ids :: [idR] -- The ids are a subset of the variables bound by the - -- stmts that are used in stmts that follow the RecStmt - - , recS_rec_ids :: [idR] -- Ditto, but these variables are the "recursive" ones, - -- that are used before they are bound in the stmts of - -- the RecStmt. - -- An Id can be in both groups - -- Both sets of Ids are (now) treated monomorphically - -- See Note [How RecStmt works] for why they are separate - - -- Rebindable syntax - , recS_bind_fn :: SyntaxExpr idR -- The bind function - , recS_ret_fn :: SyntaxExpr idR -- The return function - , recS_mfix_fn :: SyntaxExpr idR -- The mfix function - , recS_bind_ty :: PostTc idR Type -- S in (>>=) :: Q -> (R -> S) -> T - - -- These fields are only valid after typechecking - , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) - , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 - -- with recS_later_ids and recS_rec_ids, - -- and are the expressions that should be - -- returned by the recursion. - -- They may not quite be the Ids themselves, - -- because the Id may be *polymorphic*, but - -- the returned thing has to be *monomorphic*, - -- so they may be type applications - - , recS_ret_ty :: PostTc idR Type -- The type of - -- do { stmts; return (a,b,c) } - -- With rebindable syntax the type might not - -- be quite as simple as (m (tya, tyb, tyc)). - } -deriving instance (Data body, DataId idL, DataId idR) - => Data (StmtLR idL idR body) - -data TransForm -- The 'f' below is the 'using' function, 'e' is the by function - = ThenForm -- then f or then f by e (depending on trS_by) - | GroupForm -- then group using f or then group by e using f (depending on trS_by) - deriving Data - --- | Parenthesised Statement Block -data ParStmtBlock idL idR - = ParStmtBlock - [ExprLStmt idL] - [idR] -- The variables to be returned - (SyntaxExpr idR) -- The return operator -deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR) - --- | Applicative Argument -data ApplicativeArg idL idR - = ApplicativeArgOne -- pat <- expr (pat must be irrefutable) - (LPat idL) - (LHsExpr idL) - | ApplicativeArgMany -- do { stmts; return vars } - [ExprLStmt idL] -- stmts - (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) - (LPat idL) -- (v1,...,vn) -deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR) - -{- -Note [The type of bind in Stmts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some Stmts, notably BindStmt, keep the (>>=) bind operator. -We do NOT assume that it has type - (>>=) :: m a -> (a -> m b) -> m b -In some cases (see Trac #303, #1537) it might have a more -exotic type, such as - (>>=) :: m i j a -> (a -> m j k b) -> m i k b -So we must be careful not to make assumptions about the type. -In particular, the monad may not be uniform throughout. - -Note [TransStmt binder map] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The [(idR,idR)] in a TransStmt behaves as follows: - - * Before renaming: [] - - * After renaming: - [ (x27,x27), ..., (z35,z35) ] - These are the variables - bound by the stmts to the left of the 'group' - and used either in the 'by' clause, - or in the stmts following the 'group' - Each item is a pair of identical variables. - - * After typechecking: - [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] - Each pair has the same unique, but different *types*. - -Note [BodyStmt] -~~~~~~~~~~~~~~~ -BodyStmts are a bit tricky, because what they mean -depends on the context. Consider the following contexts: - - A do expression of type (m res_ty) - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E any_ty: do { ....; E; ... } - E :: m any_ty - Translation: E >> ... - - A list comprehensions of type [elt_ty] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E Bool: [ .. | .... E ] - [ .. | ..., E, ... ] - [ .. | .... | ..., E | ... ] - E :: Bool - Translation: if E then fail else ... - - A guard list, guarding a RHS of type rhs_ty - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... - E :: Bool - Translation: if E then fail else ... - - A monad comprehension of type (m res_ty) - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E Bool: [ .. | .... E ] - E :: Bool - Translation: guard E >> ... - -Array comprehensions are handled like list comprehensions. - -Note [How RecStmt works] -~~~~~~~~~~~~~~~~~~~~~~~~ -Example: - HsDo [ BindStmt x ex - - , RecStmt { recS_rec_ids = [a, c] - , recS_stmts = [ BindStmt b (return (a,c)) - , LetStmt a = ...b... - , BindStmt c ec ] - , recS_later_ids = [a, b] - - , return (a b) ] - -Here, the RecStmt binds a,b,c; but - - Only a,b are used in the stmts *following* the RecStmt, - - Only a,c are used in the stmts *inside* the RecStmt - *before* their bindings - -Why do we need *both* rec_ids and later_ids? For monads they could be -combined into a single set of variables, but not for arrows. That -follows from the types of the respective feedback operators: - - mfix :: MonadFix m => (a -> m a) -> m a - loop :: ArrowLoop a => a (b,d) (c,d) -> a b c - -* For mfix, the 'a' covers the union of the later_ids and the rec_ids -* For 'loop', 'c' is the later_ids and 'd' is the rec_ids - -Note [Typing a RecStmt] -~~~~~~~~~~~~~~~~~~~~~~~ -A (RecStmt stmts) types as if you had written - - (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) -> - do { stmts - ; return (v1,..vn, r1, ..., rm) }) - -where v1..vn are the later_ids - r1..rm are the rec_ids - -Note [Monad Comprehensions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Monad comprehensions require separate functions like 'return' and -'>>=' for desugaring. These functions are stored in the statements -used in monad comprehensions. For example, the 'return' of the 'LastStmt' -expression is used to lift the body of the monad comprehension: - - [ body | stmts ] - => - stmts >>= \bndrs -> return body - -In transform and grouping statements ('then ..' and 'then group ..') the -'return' function is required for nested monad comprehensions, for example: - - [ body | stmts, then f, rest ] - => - f [ env | stmts ] >>= \bndrs -> [ body | rest ] - -BodyStmts require the 'Control.Monad.guard' function for boolean -expressions: - - [ body | exp, stmts ] - => - guard exp >> [ body | stmts ] - -Parallel statements require the 'Control.Monad.Zip.mzip' function: - - [ body | stmts1 | stmts2 | .. ] - => - mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body - -In any other context than 'MonadComp', the fields for most of these -'SyntaxExpr's stay bottom. --} - -instance (OutputableBndrId idL) => Outputable (ParStmtBlock idL idR) where - ppr (ParStmtBlock stmts _ _) = interpp'SP stmts - -instance (OutputableBndrId idL, OutputableBndrId idR, Outputable body) - => Outputable (StmtLR idL idR body) where - ppr stmt = pprStmt stmt - -pprStmt :: forall idL idR body . (OutputableBndrId idL, OutputableBndrId idR, - Outputable body) - => (StmtLR idL idR body) -> SDoc -pprStmt (LastStmt expr ret_stripped _) - = ifPprDebug (text "[last]") <+> - (if ret_stripped then text "return" else empty) <+> - ppr expr -pprStmt (BindStmt pat expr _ _ _) = hsep [ppr pat, larrow, ppr expr] -pprStmt (LetStmt (L _ binds)) = hsep [text "let", pprBinds binds] -pprStmt (BodyStmt expr _ _ _) = ppr expr -pprStmt (ParStmt stmtss _ _ _) = sep (punctuate (text " | ") (map ppr stmtss)) - -pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form }) - = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) - -pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids - , recS_later_ids = later_ids }) - = text "rec" <+> - vcat [ ppr_do_stmts segment - , ifPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids - , text "later_ids=" <> ppr later_ids])] - -pprStmt (ApplicativeStmt args mb_join _) - = getPprStyle $ \style -> - if userStyle style - then pp_for_user - else pp_debug - where - -- make all the Applicative stuff invisible in error messages by - -- flattening the whole ApplicativeStmt nest back to a sequence - -- of statements. - pp_for_user = vcat $ concatMap flattenArg args - - -- ppr directly rather than transforming here, because we need to - -- inject a "return" which is hard when we're polymorphic in the id - -- type. - flattenStmt :: ExprLStmt idL -> [SDoc] - flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args - flattenStmt stmt = [ppr stmt] - - flattenArg (_, ApplicativeArgOne pat expr) = - [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt idL)] - flattenArg (_, ApplicativeArgMany stmts _ _) = - concatMap flattenStmt stmts - - pp_debug = - let - ap_expr = sep (punctuate (text " |") (map pp_arg args)) - in - if isNothing mb_join - then ap_expr - else text "join" <+> parens ap_expr - - pp_arg (_, ApplicativeArgOne pat expr) = - ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt idL) - pp_arg (_, ApplicativeArgMany stmts return pat) = - ppr pat <+> - text "<-" <+> - ppr (HsDo DoExpr (noLoc - (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) - (error "pprStmt")) - -pprTransformStmt :: (OutputableBndrId id) - => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc -pprTransformStmt bndrs using by - = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs)) - , nest 2 (ppr using) - , nest 2 (pprBy by)] - -pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc -pprTransStmt by using ThenForm - = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] -pprTransStmt by using GroupForm - = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] - -pprBy :: Outputable body => Maybe body -> SDoc -pprBy Nothing = empty -pprBy (Just e) = text "by" <+> ppr e - -pprDo :: (OutputableBndrId id, Outputable body) - => HsStmtContext any -> [LStmt id body] -> SDoc -pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts -pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts -pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts -pprDo MDoExpr stmts = text "mdo" <+> ppr_do_stmts stmts -pprDo ListComp stmts = brackets $ pprComp stmts -pprDo PArrComp stmts = paBrackets $ pprComp stmts -pprDo MonadComp stmts = brackets $ pprComp stmts -pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt - -ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) - => [LStmtLR idL idR body] -> SDoc --- Print a bunch of do stmts -ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) - -pprComp :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc -pprComp quals -- Prints: body | qual1, ..., qualn - | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals - = if null initStmts - -- If there are no statements in a list comprehension besides the last - -- one, we simply treat it like a normal list. This does arise - -- occasionally in code that GHC generates, e.g., in implementations of - -- 'range' for derived 'Ix' instances for product datatypes with exactly - -- one constructor (e.g., see Trac #12583). - then ppr body - else hang (ppr body <+> vbar) 2 (pprQuals initStmts) - | otherwise - = pprPanic "pprComp" (pprQuals quals) - -pprQuals :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc --- Show list comprehension qualifiers separated by commas -pprQuals quals = interpp'SP quals - -{- -************************************************************************ -* * - Template Haskell quotation brackets -* * -************************************************************************ --} - --- | Haskell Splice -data HsSplice id - = HsTypedSplice -- $$z or $$(f 4) - SpliceDecoration -- Whether $$( ) variant found, for pretty printing - id -- A unique name to identify this splice point - (LHsExpr id) -- See Note [Pending Splices] - - | HsUntypedSplice -- $z or $(f 4) - SpliceDecoration -- Whether $( ) variant found, for pretty printing - id -- A unique name to identify this splice point - (LHsExpr id) -- See Note [Pending Splices] - - | HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice - id -- Splice point - id -- Quoter - SrcSpan -- The span of the enclosed string - FastString -- The enclosed string - - | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in - -- RnSplice. - -- This is the result of splicing a splice. It is produced by - -- the renamer and consumed by the typechecker. It lives only - -- between the two. - ThModFinalizers -- TH finalizers produced by the splice. - (HsSplicedThing id) -- The result of splicing - deriving Typeable -deriving instance (DataId id) => Data (HsSplice id) - --- | A splice can appear with various decorations wrapped around it. This data --- type captures explicitly how it was originally written, for use in the pretty --- printer. -data SpliceDecoration - = HasParens -- ^ $( splice ) or $$( splice ) - | HasDollar -- ^ $splice or $$splice - | NoParens -- ^ bare splice - deriving (Data, Eq, Show) - -instance Outputable SpliceDecoration where - ppr x = text $ show x - - -isTypedSplice :: HsSplice id -> Bool -isTypedSplice (HsTypedSplice {}) = True -isTypedSplice _ = False -- Quasi-quotes are untyped splices - --- | Finalizers produced by a splice with --- 'Language.Haskell.TH.Syntax.addModFinalizer' --- --- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how --- this is used. --- -newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] - --- A Data instance which ignores the argument of 'ThModFinalizers'. -instance Data ThModFinalizers where - gunfold _ z _ = z $ ThModFinalizers [] - toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix - dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] - --- | Haskell Spliced Thing --- --- Values that can result from running a splice. -data HsSplicedThing id - = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression - | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type - | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern - deriving Typeable - -deriving instance (DataId id) => Data (HsSplicedThing id) - --- See Note [Pending Splices] -type SplicePointName = Name - --- | Pending Renamer Splice -data PendingRnSplice - = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr Name) - deriving Data - -data UntypedSpliceFlavour - = UntypedExpSplice - | UntypedPatSplice - | UntypedTypeSplice - | UntypedDeclSplice - deriving Data - --- | Pending Type-checker Splice -data PendingTcSplice - = PendingTcSplice SplicePointName (LHsExpr Id) - deriving Data - - -{- -Note [Pending Splices] -~~~~~~~~~~~~~~~~~~~~~~ -When we rename an untyped bracket, we name and lift out all the nested -splices, so that when the typechecker hits the bracket, it can -typecheck those nested splices without having to walk over the untyped -bracket code. So for example - [| f $(g x) |] -looks like - - HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x))) - -which the renamer rewrites to - - HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x))) - [PendingRnSplice UntypedExpSplice sn (g x)] - -* The 'sn' is the Name of the splice point, the SplicePointName - -* The PendingRnExpSplice gives the splice that splice-point name maps to; - and the typechecker can now conveniently find these sub-expressions - -* The other copy of the splice, in the second argument of HsSpliceE - in the renamed first arg of HsRnBracketOut - is used only for pretty printing - -There are four varieties of pending splices generated by the renamer, -distinguished by their UntypedSpliceFlavour - - * Pending expression splices (UntypedExpSplice), e.g., - [|$(f x) + 2|] - - UntypedExpSplice is also used for - * quasi-quotes, where the pending expression expands to - $(quoter "...blah...") - (see RnSplice.makePending, HsQuasiQuote case) - - * cross-stage lifting, where the pending expression expands to - $(lift x) - (see RnSplice.checkCrossStageLifting) - - * Pending pattern splices (UntypedPatSplice), e.g., - [| \$(f x) -> x |] - - * Pending type splices (UntypedTypeSplice), e.g., - [| f :: $(g x) |] - - * Pending declaration (UntypedDeclSplice), e.g., - [| let $(f x) in ... |] - -There is a fifth variety of pending splice, which is generated by the type -checker: - - * Pending *typed* expression splices, (PendingTcSplice), e.g., - [||1 + $$(f 2)||] - -It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the -output of the renamer. However, when pretty printing the output of the renamer, -e.g., in a type error message, we *do not* want to print out the pending -splices. In contrast, when pretty printing the output of the type checker, we -*do* want to print the pending splices. So splitting them up seems to make -sense, although I hate to add another constructor to HsExpr. --} - -instance (OutputableBndrId id) => Outputable (HsSplicedThing id) where - ppr (HsSplicedExpr e) = ppr_expr e - ppr (HsSplicedTy t) = ppr t - ppr (HsSplicedPat p) = ppr p - -instance (OutputableBndrId id) => Outputable (HsSplice id) where - ppr s = pprSplice s - -pprPendingSplice :: (OutputableBndrId id) - => SplicePointName -> LHsExpr id -> SDoc -pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) - -pprSpliceDecl :: (OutputableBndrId id) - => HsSplice id -> SpliceExplicitFlag -> SDoc -pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e -pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" -pprSpliceDecl e ImplicitSplice = ppr_splice_decl e - -ppr_splice_decl :: (OutputableBndrId id) => HsSplice id -> SDoc -ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty -ppr_splice_decl e = pprSplice e - -pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc -pprSplice (HsTypedSplice HasParens n e) - = ppr_splice (text "$$(") n e (text ")") -pprSplice (HsTypedSplice HasDollar n e) - = ppr_splice (text "$$") n e empty -pprSplice (HsTypedSplice NoParens n e) - = ppr_splice empty n e empty -pprSplice (HsUntypedSplice HasParens n e) - = ppr_splice (text "$(") n e (text ")") -pprSplice (HsUntypedSplice HasDollar n e) - = ppr_splice (text "$") n e empty -pprSplice (HsUntypedSplice NoParens n e) - = ppr_splice empty n e empty -pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s -pprSplice (HsSpliced _ thing) = ppr thing - -ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc -ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <> - char '[' <> ppr quoter <> vbar <> - ppr quote <> text "|]" - -ppr_splice :: (OutputableBndrId id) - => SDoc -> id -> LHsExpr id -> SDoc -> SDoc -ppr_splice herald n e trail - = herald <> ifPprDebug (brackets (ppr n)) <> ppr e <> trail - --- | Haskell Bracket -data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] - | PatBr (LPat id) -- [p| pat |] - | DecBrL [LHsDecl id] -- [d| decls |]; result of parser - | DecBrG (HsGroup id) -- [d| decls |]; result of renamer - | TypBr (LHsType id) -- [t| type |] - | VarBr Bool id -- True: 'x, False: ''T - -- (The Bool flag is used only in pprHsBracket) - | TExpBr (LHsExpr id) -- [|| expr ||] -deriving instance (DataId id) => Data (HsBracket id) - -isTypedBracket :: HsBracket id -> Bool -isTypedBracket (TExpBr {}) = True -isTypedBracket _ = False - -instance (OutputableBndrId id) => Outputable (HsBracket id) where - ppr = pprHsBracket - - -pprHsBracket :: (OutputableBndrId id) => HsBracket id -> SDoc -pprHsBracket (ExpBr e) = thBrackets empty (ppr e) -pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) -pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) -pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) -pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) -pprHsBracket (VarBr True n) - = char '\'' <> pprPrefixOcc n -pprHsBracket (VarBr False n) - = text "''" <> pprPrefixOcc n -pprHsBracket (TExpBr e) = thTyBrackets (ppr e) - -thBrackets :: SDoc -> SDoc -> SDoc -thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> - pp_body <+> text "|]" - -thTyBrackets :: SDoc -> SDoc -thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]") - -instance Outputable PendingRnSplice where - ppr (PendingRnSplice _ n e) = pprPendingSplice n e - -instance Outputable PendingTcSplice where - ppr (PendingTcSplice n e) = pprPendingSplice n e - -{- -************************************************************************ -* * -\subsection{Enumerations and list comprehensions} -* * -************************************************************************ --} - --- | Arithmetic Sequence Information -data ArithSeqInfo id - = From (LHsExpr id) - | FromThen (LHsExpr id) - (LHsExpr id) - | FromTo (LHsExpr id) - (LHsExpr id) - | FromThenTo (LHsExpr id) - (LHsExpr id) - (LHsExpr id) -deriving instance (DataId id) => Data (ArithSeqInfo id) - -instance (OutputableBndrId id) - => Outputable (ArithSeqInfo id) where - ppr (From e1) = hcat [ppr e1, pp_dotdot] - ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] - ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] - ppr (FromThenTo e1 e2 e3) - = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] - -pp_dotdot :: SDoc -pp_dotdot = text " .. " - -{- -************************************************************************ -* * -\subsection{HsMatchCtxt} -* * -************************************************************************ --} - --- | Haskell Match Context --- --- Context of a pattern match. This is more subtle than it would seem. See Note --- [Varieties of pattern matches]. -data HsMatchContext id -- Not an extensible tag - = FunRhs { mc_fun :: Located id -- ^ function binder of @f@ - , mc_fixity :: LexicalFixity -- ^ fixing of @f@ - , mc_strictness :: SrcStrictness - -- ^ was the pattern banged? See - -- Note [Varieties of binding pattern matches] - } - -- ^A pattern matching on an argument of a - -- function binding - | LambdaExpr -- ^Patterns of a lambda - | CaseAlt -- ^Patterns and guards on a case alternative - | IfAlt -- ^Guards of a multi-way if alternative - | ProcExpr -- ^Patterns of a proc - | PatBindRhs -- ^A pattern binding eg [y] <- e = e - - | RecUpd -- ^Record update [used only in DsExpr to - -- tell matchWrapper what sort of - -- runtime error message to generate] - - | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension, - -- pattern guard, etc - - | ThPatSplice -- ^A Template Haskell pattern splice - | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] - | PatSyn -- ^A pattern synonym declaration - deriving Functor -deriving instance (DataIdPost id) => Data (HsMatchContext id) - -instance OutputableBndr id => Outputable (HsMatchContext id) where - ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) - ppr LambdaExpr = text "LambdaExpr" - ppr CaseAlt = text "CaseAlt" - ppr IfAlt = text "IfAlt" - ppr ProcExpr = text "ProcExpr" - ppr PatBindRhs = text "PatBindRhs" - ppr RecUpd = text "RecUpd" - ppr (StmtCtxt _) = text "StmtCtxt _" - ppr ThPatSplice = text "ThPatSplice" - ppr ThPatQuote = text "ThPatQuote" - ppr PatSyn = text "PatSyn" - -isPatSynCtxt :: HsMatchContext id -> Bool -isPatSynCtxt ctxt = - case ctxt of - PatSyn -> True - _ -> False - --- | Haskell Statement Context -data HsStmtContext id - = ListComp - | MonadComp - | PArrComp -- ^Parallel array comprehension - - | DoExpr -- ^do { ... } - | MDoExpr -- ^mdo { ... } ie recursive do-expression - | ArrowExpr -- ^do-notation in an arrow-command context - - | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs - | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing - | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt - | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt - deriving Functor -deriving instance (DataIdPost id) => Data (HsStmtContext id) - -isListCompExpr :: HsStmtContext id -> Bool --- Uses syntax [ e | quals ] -isListCompExpr ListComp = True -isListCompExpr PArrComp = True -isListCompExpr MonadComp = True -isListCompExpr (ParStmtCtxt c) = isListCompExpr c -isListCompExpr (TransStmtCtxt c) = isListCompExpr c -isListCompExpr _ = False - -isMonadCompExpr :: HsStmtContext id -> Bool -isMonadCompExpr MonadComp = True -isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt -isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt -isMonadCompExpr _ = False - --- | Should pattern match failure in a 'HsStmtContext' be desugared using --- 'MonadFail'? -isMonadFailStmtContext :: HsStmtContext id -> Bool -isMonadFailStmtContext MonadComp = True -isMonadFailStmtContext DoExpr = True -isMonadFailStmtContext MDoExpr = True -isMonadFailStmtContext GhciStmtCtxt = True -isMonadFailStmtContext _ = False - -matchSeparator :: HsMatchContext id -> SDoc -matchSeparator (FunRhs {}) = text "=" -matchSeparator CaseAlt = text "->" -matchSeparator IfAlt = text "->" -matchSeparator LambdaExpr = text "->" -matchSeparator ProcExpr = text "->" -matchSeparator PatBindRhs = text "=" -matchSeparator (StmtCtxt _) = text "<-" -matchSeparator RecUpd = text "=" -- This can be printed by the pattern - -- match checker trace -matchSeparator ThPatSplice = panic "unused" -matchSeparator ThPatQuote = panic "unused" -matchSeparator PatSyn = panic "unused" - -pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id) - => HsMatchContext id -> SDoc -pprMatchContext ctxt - | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt - | otherwise = text "a" <+> pprMatchContextNoun ctxt - where - want_an (FunRhs {}) = True -- Use "an" in front - want_an ProcExpr = True - want_an _ = False - -pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id) - => HsMatchContext id -> SDoc -pprMatchContextNoun (FunRhs {mc_fun=L _ fun}) - = text "equation for" - <+> quotes (ppr fun) -pprMatchContextNoun CaseAlt = text "case alternative" -pprMatchContextNoun IfAlt = text "multi-way if alternative" -pprMatchContextNoun RecUpd = text "record-update construct" -pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" -pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" -pprMatchContextNoun PatBindRhs = text "pattern binding" -pprMatchContextNoun LambdaExpr = text "lambda abstraction" -pprMatchContextNoun ProcExpr = text "arrow abstraction" -pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" - $$ pprStmtContext ctxt -pprMatchContextNoun PatSyn = text "pattern synonym declaration" - ------------------ -pprAStmtContext, pprStmtContext :: (Outputable id, - Outputable (NameOrRdrName id)) - => HsStmtContext id -> SDoc -pprAStmtContext ctxt = article <+> pprStmtContext ctxt - where - pp_an = text "an" - pp_a = text "a" - article = case ctxt of - MDoExpr -> pp_an - PArrComp -> pp_an - GhciStmtCtxt -> pp_an - _ -> pp_a - - ------------------ -pprStmtContext GhciStmtCtxt = text "interactive GHCi command" -pprStmtContext DoExpr = text "'do' block" -pprStmtContext MDoExpr = text "'mdo' block" -pprStmtContext ArrowExpr = text "'do' block in an arrow command" -pprStmtContext ListComp = text "list comprehension" -pprStmtContext MonadComp = text "monad comprehension" -pprStmtContext PArrComp = text "array comprehension" -pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt - --- Drop the inner contexts when reporting errors, else we get --- Unexpected transform statement --- in a transformed branch of --- transformed branch of --- transformed branch of monad comprehension -pprStmtContext (ParStmtCtxt c) = - sdocWithPprDebug $ \dbg -> if dbg - then sep [text "parallel branch of", pprAStmtContext c] - else pprStmtContext c -pprStmtContext (TransStmtCtxt c) = - sdocWithPprDebug $ \dbg -> if dbg - then sep [text "transformed branch of", pprAStmtContext c] - else pprStmtContext c - -instance (Outputable id, Outputable (NameOrRdrName id)) - => Outputable (HsStmtContext id) where - ppr = pprStmtContext - --- Used to generate the string for a *runtime* error message -matchContextErrString :: Outputable id - => HsMatchContext id -> SDoc -matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun -matchContextErrString CaseAlt = text "case" -matchContextErrString IfAlt = text "multi-way if" -matchContextErrString PatBindRhs = text "pattern binding" -matchContextErrString RecUpd = text "record update" -matchContextErrString LambdaExpr = text "lambda" -matchContextErrString ProcExpr = text "proc" -matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime -matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime -matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime -matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" -matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command" -matchContextErrString (StmtCtxt DoExpr) = text "'do' block" -matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block" -matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block" -matchContextErrString (StmtCtxt ListComp) = text "list comprehension" -matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" -matchContextErrString (StmtCtxt PArrComp) = text "array comprehension" - -pprMatchInCtxt :: (OutputableBndrId idR, - Outputable (NameOrRdrName (NameOrRdrName idR)), - Outputable body) - => Match idR body -> SDoc -pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) - <> colon) - 4 (pprMatch match) - -pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, - Outputable body) - => HsStmtContext idL -> StmtLR idL idR body -> SDoc -pprStmtInCtxt ctxt (LastStmt e _ _) - | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" - = hang (text "In the expression:") 2 (ppr e) - -pprStmtInCtxt ctxt stmt - = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) - 2 (ppr_stmt stmt) - where - -- For Group and Transform Stmts, don't print the nested stmts! - ppr_stmt (TransStmt { trS_by = by, trS_using = using - , trS_form = form }) = pprTransStmt by using form - ppr_stmt stmt = pprStmt stmt diff --git a/hsSyn/HsExpr.hs-boot b/hsSyn/HsExpr.hs-boot deleted file mode 100644 --- a/hsSyn/HsExpr.hs-boot +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE CPP, KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RoleAnnotations #-} - -module HsExpr where - -import SrcLoc ( Located ) -import Outputable ( SDoc, Outputable ) -import {-# SOURCE #-} HsPat ( LPat ) -import BasicTypes ( SpliceExplicitFlag(..)) -import PlaceHolder ( DataId, OutputableBndrId ) -import Data.Data hiding ( Fixity ) - -type role HsExpr nominal -type role HsCmd nominal -type role MatchGroup nominal representational -type role GRHSs nominal representational -type role HsSplice nominal -type role SyntaxExpr nominal -data HsExpr (i :: *) -data HsCmd (i :: *) -data HsSplice (i :: *) -data MatchGroup (a :: *) (body :: *) -data GRHSs (a :: *) (body :: *) -data SyntaxExpr (i :: *) - -instance (DataId id) => Data (HsSplice id) -instance (DataId id) => Data (HsExpr id) -instance (DataId id) => Data (HsCmd id) -instance (Data body,DataId id) => Data (MatchGroup id body) -instance (Data body,DataId id) => Data (GRHSs id body) -instance (DataId id) => Data (SyntaxExpr id) - -instance (OutputableBndrId id) => Outputable (HsExpr id) -instance (OutputableBndrId id) => Outputable (HsCmd id) - -type LHsExpr a = Located (HsExpr a) - -pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc - -pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc - -pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc - -pprSpliceDecl :: (OutputableBndrId id) - => HsSplice id -> SpliceExplicitFlag -> SDoc - -pprPatBind :: (OutputableBndrId bndr, - OutputableBndrId id, - Outputable body) - => LPat bndr -> GRHSs id body -> SDoc - -pprFunBind :: (OutputableBndrId idR, Outputable body) - => MatchGroup idR body -> SDoc diff --git a/hsSyn/HsImpExp.hs b/hsSyn/HsImpExp.hs deleted file mode 100644 --- a/hsSyn/HsImpExp.hs +++ /dev/null @@ -1,310 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -HsImpExp: Abstract syntax: imports, exports, interfaces --} - -{-# LANGUAGE DeriveDataTypeable #-} - -module HsImpExp where - -import Module ( ModuleName ) -import HsDoc ( HsDocString ) -import OccName ( HasOccName(..), isTcOcc, isSymOcc ) -import BasicTypes ( SourceText(..), StringLiteral(..), pprWithSourceText ) -import FieldLabel ( FieldLbl(..) ) - -import Outputable -import FastString -import SrcLoc - -import Data.Data - -{- -************************************************************************ -* * -\subsection{Import and export declaration lists} -* * -************************************************************************ - -One per \tr{import} declaration in a module. --} - --- | Located Import Declaration -type LImportDecl name = Located (ImportDecl name) - -- ^ When in a list this may have - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | Import Declaration --- --- A single Haskell @import@ declaration. -data ImportDecl name - = ImportDecl { - ideclSourceSrc :: SourceText, - -- Note [Pragma source text] in BasicTypes - ideclName :: Located ModuleName, -- ^ Module name. - ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier. - ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import - ideclSafe :: Bool, -- ^ True => safe import - ideclQualified :: Bool, -- ^ True => qualified - ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) - ideclAs :: Maybe (Located ModuleName), -- ^ as Module - ideclHiding :: Maybe (Bool, Located [LIE name]) - -- ^ (True => hiding, names) - } - -- ^ - -- 'ApiAnnotation.AnnKeywordId's - -- - -- - 'ApiAnnotation.AnnImport' - -- - -- - 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnClose' for ideclSource - -- - -- - 'ApiAnnotation.AnnSafe','ApiAnnotation.AnnQualified', - -- 'ApiAnnotation.AnnPackageName','ApiAnnotation.AnnAs', - -- 'ApiAnnotation.AnnVal' - -- - -- - 'ApiAnnotation.AnnHiding','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' attached - -- to location in ideclHiding - - -- For details on above see note [Api annotations] in ApiAnnotation - deriving Data - -simpleImportDecl :: ModuleName -> ImportDecl name -simpleImportDecl mn = ImportDecl { - ideclSourceSrc = NoSourceText, - ideclName = noLoc mn, - ideclPkgQual = Nothing, - ideclSource = False, - ideclSafe = False, - ideclImplicit = False, - ideclQualified = False, - ideclAs = Nothing, - ideclHiding = Nothing - } - -instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) where - ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' - , ideclPkgQual = pkg - , ideclSource = from, ideclSafe = safe - , ideclQualified = qual, ideclImplicit = implicit - , ideclAs = as, ideclHiding = spec }) - = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe, - pp_qual qual, pp_pkg pkg, ppr mod', pp_as as]) - 4 (pp_spec spec) - where - pp_implicit False = empty - pp_implicit True = ptext (sLit ("(implicit)")) - - pp_pkg Nothing = empty - pp_pkg (Just (StringLiteral st p)) - = pprWithSourceText st (doubleQuotes (ftext p)) - - pp_qual False = empty - pp_qual True = text "qualified" - - pp_safe False = empty - pp_safe True = text "safe" - - pp_as Nothing = empty - pp_as (Just a) = text "as" <+> ppr a - - ppr_imp True = case mSrcText of - NoSourceText -> text "{-# SOURCE #-}" - SourceText src -> text src <+> text "#-}" - ppr_imp False = empty - - pp_spec Nothing = empty - pp_spec (Just (False, (L _ ies))) = ppr_ies ies - pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies - - ppr_ies [] = text "()" - ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' - -{- -************************************************************************ -* * -\subsection{Imported and exported entities} -* * -************************************************************************ --} - --- | A name in an import or export specfication which may have adornments. Used --- primarily for accurate pretty printing of ParsedSource, and API Annotation --- placement. -data IEWrappedName name - = IEName (Located name) -- ^ no extra - | IEPattern (Located name) -- ^ pattern X - | IEType (Located name) -- ^ type (:+:) - deriving (Eq,Data) - --- | Located name with possible adornment --- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnType', --- 'ApiAnnotation.AnnPattern' -type LIEWrappedName name = Located (IEWrappedName name) --- For details on above see note [Api annotations] in ApiAnnotation - - --- | Located Import or Export -type LIE name = Located (IE name) - -- ^ When in a list this may have - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | Imported or exported entity. -data IE name - = IEVar (LIEWrappedName name) - -- ^ Imported or Exported Variable - - | IEThingAbs (LIEWrappedName name) - -- ^ Imported or exported Thing with Absent list - -- - -- The thing is a Class/Type (can't tell) - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern', - -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnVal' - - -- For details on above see note [Api annotations] in ApiAnnotation - -- See Note [Located RdrNames] in HsExpr - | IEThingAll (LIEWrappedName name) - -- ^ Imported or exported Thing with All imported or exported - -- - -- The thing is a Class/Type and the All refers to methods/constructors - -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnType' - - -- For details on above see note [Api annotations] in ApiAnnotation - -- See Note [Located RdrNames] in HsExpr - - | IEThingWith (LIEWrappedName name) - IEWildcard - [LIEWrappedName name] - [Located (FieldLbl name)] - -- ^ Imported or exported Thing With given imported or exported - -- - -- The thing is a Class/Type and the imported or exported things are - -- methods/constructors and record fields; see Note [IEThingWith] - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnComma', - -- 'ApiAnnotation.AnnType' - - -- For details on above see note [Api annotations] in ApiAnnotation - | IEModuleContents (Located ModuleName) - -- ^ Imported or exported module contents - -- - -- (Export Only) - -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule' - - -- For details on above see note [Api annotations] in ApiAnnotation - | IEGroup Int HsDocString -- ^ Doc section heading - | IEDoc HsDocString -- ^ Some documentation - | IEDocNamed String -- ^ Reference to named doc - deriving (Eq, Data) - --- | Imported or Exported Wildcard -data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) - -{- -Note [IEThingWith] -~~~~~~~~~~~~~~~~~~ - -A definition like - - module M ( T(MkT, x) ) where - data T = MkT { x :: Int } - -gives rise to - - IEThingWith T [MkT] [FieldLabel "x" False x)] (without DuplicateRecordFields) - IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)] (with DuplicateRecordFields) - -See Note [Representing fields in AvailInfo] in Avail for more details. --} - -ieName :: IE name -> name -ieName (IEVar (L _ n)) = ieWrappedName n -ieName (IEThingAbs (L _ n)) = ieWrappedName n -ieName (IEThingWith (L _ n) _ _ _) = ieWrappedName n -ieName (IEThingAll (L _ n)) = ieWrappedName n -ieName _ = panic "ieName failed pattern match!" - -ieNames :: IE a -> [a] -ieNames (IEVar (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAbs (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAll (L _ n) ) = [ieWrappedName n] -ieNames (IEThingWith (L _ n) _ ns _) = ieWrappedName n - : map (ieWrappedName . unLoc) ns -ieNames (IEModuleContents _ ) = [] -ieNames (IEGroup _ _ ) = [] -ieNames (IEDoc _ ) = [] -ieNames (IEDocNamed _ ) = [] - -ieWrappedName :: IEWrappedName name -> name -ieWrappedName (IEName (L _ n)) = n -ieWrappedName (IEPattern (L _ n)) = n -ieWrappedName (IEType (L _ n)) = n - -ieLWrappedName :: LIEWrappedName name -> Located name -ieLWrappedName (L l n) = L l (ieWrappedName n) - -replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2 -replaceWrappedName (IEName (L l _)) n = IEName (L l n) -replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n) -replaceWrappedName (IEType (L l _)) n = IEType (L l n) - -replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 -replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') - -instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where - ppr (IEVar var) = ppr (unLoc var) - ppr (IEThingAbs thing) = ppr (unLoc thing) - ppr (IEThingAll thing) = hcat [ppr (unLoc thing), text "(..)"] - ppr (IEThingWith thing wc withs flds) - = ppr (unLoc thing) <> parens (fsep (punctuate comma - (ppWiths ++ - map (ppr . flLabel . unLoc) flds))) - where - ppWiths = - case wc of - NoIEWildcard -> - map (ppr . unLoc) withs - IEWildcard pos -> - let (bs, as) = splitAt pos (map (ppr . unLoc) withs) - in bs ++ [text ".."] ++ as - ppr (IEModuleContents mod') - = text "module" <+> ppr mod' - ppr (IEGroup n _) = text ("") - ppr (IEDoc doc) = ppr doc - ppr (IEDocNamed string) = text ("") - -instance (HasOccName name) => HasOccName (IEWrappedName name) where - occName w = occName (ieWrappedName w) - -instance (OutputableBndr name, HasOccName name) - => OutputableBndr (IEWrappedName name) where - pprBndr bs w = pprBndr bs (ieWrappedName w) - pprPrefixOcc w = pprPrefixOcc (ieWrappedName w) - pprInfixOcc w = pprInfixOcc (ieWrappedName w) - -instance (HasOccName name, OutputableBndr name) - => Outputable (IEWrappedName name) where - ppr (IEName n) = pprPrefixOcc (unLoc n) - ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n) - ppr (IEType n) = text "type" <+> pprPrefixOcc (unLoc n) - -pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc -pprImpExp name = type_pref <+> pprPrefixOcc name - where - occ = occName name - type_pref | isTcOcc occ && isSymOcc occ = text "type" - | otherwise = empty diff --git a/hsSyn/HsLit.hs b/hsSyn/HsLit.hs deleted file mode 100644 --- a/hsSyn/HsLit.hs +++ /dev/null @@ -1,216 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[HsLit]{Abstract syntax: source-language literals} --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} - -module HsLit where - -#include "HsVersions.h" - -import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) -import BasicTypes ( FractionalLit(..),SourceText(..),pprWithSourceText ) -import Type ( Type ) -import Outputable -import FastString -import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) - -import Data.ByteString (ByteString) -import Data.Data hiding ( Fixity ) - -{- -************************************************************************ -* * -\subsection[HsLit]{Literals} -* * -************************************************************************ --} - --- Note [Literal source text] in BasicTypes for SourceText fields in --- the following --- | Haskell Literal -data HsLit - = HsChar SourceText Char - -- ^ Character - | HsCharPrim SourceText Char - -- ^ Unboxed character - | HsString SourceText FastString - -- ^ String - | HsStringPrim SourceText ByteString - -- ^ Packed bytes - | HsInt SourceText Integer - -- ^ Genuinely an Int; arises from - -- @TcGenDeriv@, and from TRANSLATION - | HsIntPrim SourceText Integer - -- ^ literal @Int#@ - | HsWordPrim SourceText Integer - -- ^ literal @Word#@ - | HsInt64Prim SourceText Integer - -- ^ literal @Int64#@ - | HsWord64Prim SourceText Integer - -- ^ literal @Word64#@ - | HsInteger SourceText Integer Type - -- ^ Genuinely an integer; arises only - -- from TRANSLATION (overloaded - -- literals are done with HsOverLit) - | HsRat FractionalLit Type - -- ^ Genuinely a rational; arises only from - -- TRANSLATION (overloaded literals are - -- done with HsOverLit) - | HsFloatPrim FractionalLit - -- ^ Unboxed Float - | HsDoublePrim FractionalLit - -- ^ Unboxed Double - deriving Data - -instance Eq HsLit where - (HsChar _ x1) == (HsChar _ x2) = x1==x2 - (HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2 - (HsString _ x1) == (HsString _ x2) = x1==x2 - (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2 - (HsInt _ x1) == (HsInt _ x2) = x1==x2 - (HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2 - (HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2 - (HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2 - (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2 - (HsInteger _ x1 _) == (HsInteger _ x2 _) = x1==x2 - (HsRat x1 _) == (HsRat x2 _) = x1==x2 - (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 - (HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2 - _ == _ = False - --- | Haskell Overloaded Literal -data HsOverLit id - = OverLit { - ol_val :: OverLitVal, - ol_rebindable :: PostRn id Bool, -- Note [ol_rebindable] - ol_witness :: HsExpr id, -- Note [Overloaded literal witnesses] - ol_type :: PostTc id Type } -deriving instance (DataId id) => Data (HsOverLit id) - --- Note [Literal source text] in BasicTypes for SourceText fields in --- the following --- | Overloaded Literal Value -data OverLitVal - = HsIntegral !SourceText !Integer -- ^ Integer-looking literals; - | HsFractional !FractionalLit -- ^ Frac-looking literals - | HsIsString !SourceText !FastString -- ^ String-looking literals - deriving Data - -overLitType :: HsOverLit a -> PostTc a Type -overLitType = ol_type - -{- -Note [ol_rebindable] -~~~~~~~~~~~~~~~~~~~~ -The ol_rebindable field is True if this literal is actually -using rebindable syntax. Specifically: - - False iff ol_witness is the standard one - True iff ol_witness is non-standard - -Equivalently it's True if - a) RebindableSyntax is on - b) the witness for fromInteger/fromRational/fromString - that happens to be in scope isn't the standard one - -Note [Overloaded literal witnesses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -*Before* type checking, the HsExpr in an HsOverLit is the -name of the coercion function, 'fromInteger' or 'fromRational'. -*After* type checking, it is a witness for the literal, such as - (fromInteger 3) or lit_78 -This witness should replace the literal. - -This dual role is unusual, because we're replacing 'fromInteger' with -a call to fromInteger. Reason: it allows commoning up of the fromInteger -calls, which wouldn't be possible if the desguarar made the application. - -The PostTcType in each branch records the type the overload literal is -found to have. --} - --- Comparison operations are needed when grouping literals --- for compiling pattern-matching (module MatchLit) -instance Eq (HsOverLit id) where - (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2 - -instance Eq OverLitVal where - (HsIntegral _ i1) == (HsIntegral _ i2) = i1 == i2 - (HsFractional f1) == (HsFractional f2) = f1 == f2 - (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 - _ == _ = False - -instance Ord (HsOverLit id) where - compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2 - -instance Ord OverLitVal where - compare (HsIntegral _ i1) (HsIntegral _ i2) = i1 `compare` i2 - compare (HsIntegral _ _) (HsFractional _) = LT - compare (HsIntegral _ _) (HsIsString _ _) = LT - compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2 - compare (HsFractional _) (HsIntegral _ _) = GT - compare (HsFractional _) (HsIsString _ _) = LT - compare (HsIsString _ s1) (HsIsString _ s2) = s1 `compare` s2 - compare (HsIsString _ _) (HsIntegral _ _) = GT - compare (HsIsString _ _) (HsFractional _) = GT - -instance Outputable HsLit where - ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) - ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) - ppr (HsString st s) = pprWithSourceText st (pprHsString s) - ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) - ppr (HsInt st i) = pprWithSourceText st (integer i) - ppr (HsInteger st i _) = pprWithSourceText st (integer i) - ppr (HsRat f _) = ppr f - ppr (HsFloatPrim f) = ppr f <> primFloatSuffix - ppr (HsDoublePrim d) = ppr d <> primDoubleSuffix - ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) - ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) - ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) - ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) - -pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc -pp_st_suffix NoSourceText _ doc = doc -pp_st_suffix (SourceText st) suffix _ = text st <> suffix - --- in debug mode, print the expression that it's resolved to, too -instance (OutputableBndrId id) => Outputable (HsOverLit id) where - ppr (OverLit {ol_val=val, ol_witness=witness}) - = ppr val <+> (ifPprDebug (parens (pprExpr witness))) - -instance Outputable OverLitVal where - ppr (HsIntegral st i) = pprWithSourceText st (integer i) - ppr (HsFractional f) = ppr f - ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) - --- | pmPprHsLit pretty prints literals and is used when pretty printing pattern --- match warnings. All are printed the same (i.e., without hashes if they are --- primitive and not wrapped in constructors if they are boxed). This happens --- mainly for too reasons: --- * We do not want to expose their internal representation --- * The warnings become too messy -pmPprHsLit :: HsLit -> SDoc -pmPprHsLit (HsChar _ c) = pprHsChar c -pmPprHsLit (HsCharPrim _ c) = pprHsChar c -pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s) -pmPprHsLit (HsStringPrim _ s) = pprHsBytes s -pmPprHsLit (HsInt _ i) = integer i -pmPprHsLit (HsIntPrim _ i) = integer i -pmPprHsLit (HsWordPrim _ w) = integer w -pmPprHsLit (HsInt64Prim _ i) = integer i -pmPprHsLit (HsWord64Prim _ w) = integer w -pmPprHsLit (HsInteger _ i _) = integer i -pmPprHsLit (HsRat f _) = ppr f -pmPprHsLit (HsFloatPrim f) = ppr f -pmPprHsLit (HsDoublePrim d) = ppr d diff --git a/hsSyn/HsPat.hs b/hsSyn/HsPat.hs deleted file mode 100644 --- a/hsSyn/HsPat.hs +++ /dev/null @@ -1,721 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[PatSyntax]{Abstract Haskell syntax---patterns} --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} - -module HsPat ( - Pat(..), InPat, OutPat, LPat, - - HsConPatDetails, hsConPatArgs, - HsRecFields(..), HsRecField'(..), LHsRecField', - HsRecField, LHsRecField, - HsRecUpdField, LHsRecUpdField, - hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, - hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, - - mkPrefixConPat, mkCharLitPat, mkNilPat, - - looksLazyPatBind, - isBangedLPat, isBangedPatBind, - hsPatNeedsParens, - isIrrefutableHsPat, - - collectEvVarsPats, - - pprParendLPat, pprConArgs - ) where - -import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice) - --- friends: -import HsBinds -import HsLit -import PlaceHolder -import HsTypes -import TcEvidence -import BasicTypes --- others: -import PprCore ( {- instance OutputableBndr TyVar -} ) -import TysWiredIn -import Var -import RdrName ( RdrName ) -import ConLike -import DataCon -import TyCon -import Outputable -import Type -import SrcLoc -import Bag -- collect ev vars from pats -import DynFlags( gopt, GeneralFlag(..) ) -import Maybes --- libraries: -import Data.Data hiding (TyCon,Fixity) - -type InPat id = LPat id -- No 'Out' constructors -type OutPat id = LPat id -- No 'In' constructors - -type LPat id = Located (Pat id) - --- | Pattern --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' - --- For details on above see note [Api annotations] in ApiAnnotation -data Pat id - = ------------ Simple patterns --------------- - WildPat (PostTc id Type) -- ^ Wildcard Pattern - -- The sole reason for a type on a WildPat is to - -- support hsPatType :: Pat Id -> Type - - | VarPat (Located id) -- ^ Variable Pattern - - -- See Note [Located RdrNames] in HsExpr - | LazyPat (LPat id) -- ^ Lazy Pattern - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | AsPat (Located id) (LPat id) -- ^ As pattern - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | ParPat (LPat id) -- ^ Parenthesised pattern - -- See Note [Parens in HsSyn] in HsExpr - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | BangPat (LPat id) -- ^ Bang pattern - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' - - -- For details on above see note [Api annotations] in ApiAnnotation - - ------------ Lists, tuples, arrays --------------- - | ListPat [LPat id] - (PostTc id Type) -- The type of the elements - (Maybe (PostTc id Type, SyntaxExpr id)) -- For rebindable syntax - -- For OverloadedLists a Just (ty,fn) gives - -- overall type of the pattern, and the toList - -- function to convert the scrutinee to a list value - -- ^ Syntactic List - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | TuplePat [LPat id] -- Tuple sub-patterns - Boxity -- UnitPat is TuplePat [] - [PostTc id Type] -- [] before typechecker, filled in afterwards - -- with the types of the tuple components - -- You might think that the PostTc id Type was redundant, because we can - -- get the pattern type by getting the types of the sub-patterns. - -- But it's essential - -- data T a where - -- T1 :: Int -> T Int - -- f :: (T a, a) -> Int - -- f (T1 x, z) = z - -- When desugaring, we must generate - -- f = /\a. \v::a. case v of (t::T a, w::a) -> - -- case t of (T1 (x::Int)) -> - -- Note the (w::a), NOT (w::Int), because we have not yet - -- refined 'a' to Int. So we must know that the second component - -- of the tuple is of type 'a' not Int. See selectMatchVar - -- (June 14: I'm not sure this comment is right; the sub-patterns - -- will be wrapped in CoPats, no?) - -- ^ Tuple sub-patterns - -- - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, - -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ - - | SumPat (LPat id) -- Sum sub-pattern - ConTag -- Alternative (one-based) - Arity -- Arity - (PostTc id [Type]) -- PlaceHolder before typechecker, filled in - -- afterwards with the types of the - -- alternative - -- ^ Anonymous sum pattern - -- - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'(#'@, - -- 'ApiAnnotation.AnnClose' @'#)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | PArrPat [LPat id] -- Syntactic parallel array - (PostTc id Type) -- The type of the elements - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, - -- 'ApiAnnotation.AnnClose' @':]'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - ------------ Constructor patterns --------------- - | ConPatIn (Located id) - (HsConPatDetails id) - -- ^ Constructor Pattern In - - | ConPatOut { - pat_con :: Located ConLike, - pat_arg_tys :: [Type], -- The universal arg types, 1-1 with the universal - -- tyvars of the constructor/pattern synonym - -- Use (conLikeResTy pat_con pat_arg_tys) to get - -- the type of the pattern - - pat_tvs :: [TyVar], -- Existentially bound type variables - -- in correctly-scoped order e.g. [k:*, x:k] - pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries* - -- One reason for putting coercion variable here, I think, - -- is to ensure their kinds are zonked - - pat_binds :: TcEvBinds, -- Bindings involving those dictionaries - pat_args :: HsConPatDetails id, - pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher - -- Only relevant for pattern-synonyms; - -- ignored for data cons - } - -- ^ Constructor Pattern Out - - ------------ View patterns --------------- - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | ViewPat (LHsExpr id) - (LPat id) - (PostTc id Type) -- The overall type of the pattern - -- (= the argument type of the view function) - -- for hsPatType. - -- ^ View Pattern - - ------------ Pattern splices --------------- - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@ - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | SplicePat (HsSplice id) -- ^ Splice Pattern (Includes quasi-quotes) - - ------------ Literal and n+k patterns --------------- - | LitPat HsLit -- ^ Literal Pattern - -- Used for *non-overloaded* literal patterns: - -- Int#, Char#, Int, Char, String, etc. - - | NPat -- Natural Pattern - -- Used for all overloaded literals, - -- including overloaded strings with -XOverloadedStrings - (Located (HsOverLit id)) -- ALWAYS positive - (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative - -- patterns, Nothing otherwise - (SyntaxExpr id) -- Equality checker, of type t->t->Bool - (PostTc id Type) -- Overall type of pattern. Might be - -- different than the literal's type - -- if (==) or negate changes the type - - -- ^ Natural Pattern - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | NPlusKPat (Located id) -- n+k pattern - (Located (HsOverLit id)) -- It'll always be an HsIntegral - (HsOverLit id) -- See Note [NPlusK patterns] in TcPat - -- NB: This could be (PostTc ...), but that induced a - -- a new hs-boot file. Not worth it. - - (SyntaxExpr id) -- (>=) function, of type t1->t2->Bool - (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) - (PostTc id Type) -- Type of overall pattern - -- ^ n+k pattern - - ------------ Pattern type signatures --------------- - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | SigPatIn (LPat id) -- Pattern with a type signature - (LHsSigWcType id) -- Signature can bind both - -- kind and type vars - -- ^ Pattern with a type signature - - | SigPatOut (LPat id) - Type - -- ^ Pattern with a type signature - - ------------ Pattern coercions (translation only) --------------- - | CoPat HsWrapper -- Coercion Pattern - -- If co :: t1 ~ t2, p :: t2, - -- then (CoPat co p) :: t1 - (Pat id) -- Why not LPat? Ans: existing locn will do - Type -- Type of whole pattern, t1 - -- During desugaring a (CoPat co pat) turns into a cast with 'co' on - -- the scrutinee, followed by a match on 'pat' - -- ^ Coercion Pattern -deriving instance (DataId id) => Data (Pat id) - --- | Haskell Constructor Pattern Details -type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id)) - -hsConPatArgs :: HsConPatDetails id -> [LPat id] -hsConPatArgs (PrefixCon ps) = ps -hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) -hsConPatArgs (InfixCon p1 p2) = [p1,p2] - --- | Haskell Record Fields --- --- HsRecFields is used only for patterns and expressions (not data type --- declarations) -data HsRecFields id arg -- A bunch of record fields - -- { x = 3, y = True } - -- Used for both expressions and patterns - = HsRecFields { rec_flds :: [LHsRecField id arg], - rec_dotdot :: Maybe Int } -- Note [DotDot fields] - deriving (Functor, Foldable, Traversable) -deriving instance (DataId id, Data arg) => Data (HsRecFields id arg) - - --- Note [DotDot fields] --- ~~~~~~~~~~~~~~~~~~~~ --- The rec_dotdot field means this: --- Nothing => the normal case --- Just n => the group uses ".." notation, --- --- In the latter case: --- --- *before* renamer: rec_flds are exactly the n user-written fields --- --- *after* renamer: rec_flds includes *all* fields, with --- the first 'n' being the user-written ones --- and the remainder being 'filled in' implicitly - --- | Located Haskell Record Field -type LHsRecField' id arg = Located (HsRecField' id arg) - --- | Located Haskell Record Field -type LHsRecField id arg = Located (HsRecField id arg) - --- | Located Haskell Record Update Field -type LHsRecUpdField id = Located (HsRecUpdField id) - --- | Haskell Record Field -type HsRecField id arg = HsRecField' (FieldOcc id) arg - --- | Haskell Record Update Field -type HsRecUpdField id = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id) - --- | Haskell Record Field --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', --- --- For details on above see note [Api annotations] in ApiAnnotation -data HsRecField' id arg = HsRecField { - hsRecFieldLbl :: Located id, - hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning - hsRecPun :: Bool -- ^ Note [Punning] - } deriving (Data, Functor, Foldable, Traversable) - - --- Note [Punning] --- ~~~~~~~~~~~~~~ --- If you write T { x, y = v+1 }, the HsRecFields will be --- HsRecField x x True ... --- HsRecField y (v+1) False ... --- That is, for "punned" field x is expanded (in the renamer) --- to x=x; but with a punning flag so we can detect it later --- (e.g. when pretty printing) --- --- If the original field was qualified, we un-qualify it, thus --- T { A.x } means T { A.x = x } - - --- Note [HsRecField and HsRecUpdField] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- A HsRecField (used for record construction and pattern matching) --- contains an unambiguous occurrence of a field (i.e. a FieldOcc). --- We can't just store the Name, because thanks to --- DuplicateRecordFields this may not correspond to the label the user --- wrote. --- --- A HsRecUpdField (used for record update) contains a potentially --- ambiguous occurrence of a field (an AmbiguousFieldOcc). The --- renamer will fill in the selector function if it can, but if the --- selector is ambiguous the renamer will defer to the typechecker. --- After the typechecker, a unique selector will have been determined. --- --- The renamer produces an Unambiguous result if it can, rather than --- just doing the lookup in the typechecker, so that completely --- unambiguous updates can be represented by 'DsMeta.repUpdFields'. --- --- For example, suppose we have: --- --- data S = MkS { x :: Int } --- data T = MkT { x :: Int } --- --- f z = (z { x = 3 }) :: S --- --- The parsed HsRecUpdField corresponding to the record update will have: --- --- hsRecFieldLbl = Unambiguous "x" PlaceHolder :: AmbiguousFieldOcc RdrName --- --- After the renamer, this will become: --- --- hsRecFieldLbl = Ambiguous "x" PlaceHolder :: AmbiguousFieldOcc Name --- --- (note that the Unambiguous constructor is not type-correct here). --- The typechecker will determine the particular selector: --- --- hsRecFieldLbl = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id --- --- See also Note [Disambiguating record fields] in TcExpr. - -hsRecFields :: HsRecFields id arg -> [PostRn id id] -hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) - --- Probably won't typecheck at once, things have changed :/ -hsRecFieldsArgs :: HsRecFields id arg -> [arg] -hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds) - -hsRecFieldSel :: HsRecField name arg -> Located (PostRn name name) -hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl - -hsRecFieldId :: HsRecField Id arg -> Located Id -hsRecFieldId = hsRecFieldSel - -hsRecUpdFieldRdr :: HsRecUpdField id -> Located RdrName -hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl - -hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc Id) arg -> Located Id -hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc - -hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc Id) arg -> LFieldOcc Id -hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl - - -{- -************************************************************************ -* * -* Printing patterns -* * -************************************************************************ --} - -instance (OutputableBndrId name) => Outputable (Pat name) where - ppr = pprPat - -pprPatBndr :: OutputableBndr name => name -> SDoc -pprPatBndr var -- Print with type info if -dppr-debug is on - = getPprStyle $ \ sty -> - if debugStyle sty then - parens (pprBndr LambdaBind var) -- Could pass the site to pprPat - -- but is it worth it? - else - pprPrefixOcc var - -pprParendLPat :: (OutputableBndrId name) => LPat name -> SDoc -pprParendLPat (L _ p) = pprParendPat p - -pprParendPat :: (OutputableBndrId name) => Pat name -> SDoc -pprParendPat p = sdocWithDynFlags $ \ dflags -> - if need_parens dflags p - then parens (pprPat p) - else pprPat p - where - need_parens dflags p - | CoPat {} <- p = gopt Opt_PrintTypecheckerElaboration dflags - | otherwise = hsPatNeedsParens p - -- For a CoPat we need parens if we are going to show it, which - -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper) - -- But otherwise the CoPat is discarded, so it - -- is the pattern inside that matters. Sigh. - -pprPat :: (OutputableBndrId name) => Pat name -> SDoc -pprPat (VarPat (L _ var)) = pprPatBndr var -pprPat (WildPat _) = char '_' -pprPat (LazyPat pat) = char '~' <> pprParendLPat pat -pprPat (BangPat pat) = char '!' <> pprParendLPat pat -pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat] -pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] -pprPat (ParPat pat) = parens (ppr pat) -pprPat (LitPat s) = ppr s -pprPat (NPat l Nothing _ _) = ppr l -pprPat (NPat l (Just _) _ _) = char '-' <> ppr l -pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k] -pprPat (SplicePat splice) = pprSplice splice -pprPat (CoPat co pat _) = pprHsWrapper co (\parens -> if parens - then pprParendPat pat - else pprPat pat) -pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty -pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty -pprPat (ListPat pats _ _) = brackets (interpp'SP pats) -pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) -pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) -pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity) -pprPat (ConPatIn con details) = pprUserCon (unLoc con) details -pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, - pat_binds = binds, pat_args = details }) - = sdocWithDynFlags $ \dflags -> - -- Tiresome; in TcBinds.tcRhs we print out a - -- typechecked Pat in an error message, - -- and we want to make sure it prints nicely - if gopt Opt_PrintTypecheckerElaboration dflags then - ppr con - <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) - , ppr binds]) - <+> pprConArgs details - else pprUserCon (unLoc con) details - - -pprUserCon :: (OutputableBndr con, OutputableBndrId id) - => con -> HsConPatDetails id -> SDoc -pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 -pprUserCon c details = pprPrefixOcc c <+> pprConArgs details - -pprConArgs :: (OutputableBndrId id) => HsConPatDetails id -> SDoc -pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) -pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2] -pprConArgs (RecCon rpats) = ppr rpats - -instance (Outputable arg) - => Outputable (HsRecFields id arg) where - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) - = braces (fsep (punctuate comma (map ppr flds))) - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n }) - = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) - where - dotdot = text ".." <+> ifPprDebug (ppr (drop n flds)) - -instance (Outputable id, Outputable arg) - => Outputable (HsRecField' id arg) where - ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg, - hsRecPun = pun }) - = ppr f <+> (ppUnless pun $ equals <+> ppr arg) - - -{- -************************************************************************ -* * -* Building patterns -* * -************************************************************************ --} - -mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id --- Make a vanilla Prefix constructor pattern -mkPrefixConPat dc pats tys - = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [], - pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats, - pat_arg_tys = tys, pat_wrap = idHsWrapper } - -mkNilPat :: Type -> OutPat id -mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] - -mkCharLitPat :: SourceText -> Char -> OutPat id -mkCharLitPat src c = mkPrefixConPat charDataCon - [noLoc $ LitPat (HsCharPrim src c)] [] - -{- -************************************************************************ -* * -* Predicates for checking things about pattern-lists in EquationInfo * -* * -************************************************************************ - -\subsection[Pat-list-predicates]{Look for interesting things in patterns} - -Unlike in the Wadler chapter, where patterns are either ``variables'' -or ``constructors,'' here we distinguish between: -\begin{description} -\item[unfailable:] -Patterns that cannot fail to match: variables, wildcards, and lazy -patterns. - -These are the irrefutable patterns; the two other categories -are refutable patterns. - -\item[constructor:] -A non-literal constructor pattern (see next category). - -\item[literal patterns:] -At least the numeric ones may be overloaded. -\end{description} - -A pattern is in {\em exactly one} of the above three categories; `as' -patterns are treated specially, of course. - -The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. --} - -isBangedPatBind :: HsBind id -> Bool -isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat -isBangedPatBind _ = False - -isBangedLPat :: LPat id -> Bool -isBangedLPat (L _ (ParPat p)) = isBangedLPat p -isBangedLPat (L _ (BangPat {})) = True -isBangedLPat _ = False - -looksLazyPatBind :: HsBind id -> Bool --- Returns True of anything *except* --- a StrictHsBind (as above) or --- a VarPat --- In particular, returns True of a pattern binding with a compound pattern, like (I# x) --- Looks through AbsBinds -looksLazyPatBind (PatBind { pat_lhs = p }) - = looksLazyLPat p -looksLazyPatBind (AbsBinds { abs_binds = binds }) - = anyBag (looksLazyPatBind . unLoc) binds -looksLazyPatBind (AbsBindsSig { abs_sig_bind = L _ bind }) - = looksLazyPatBind bind -looksLazyPatBind _ - = False - -looksLazyLPat :: LPat id -> Bool -looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p -looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p -looksLazyLPat (L _ (BangPat {})) = False -looksLazyLPat (L _ (VarPat {})) = False -looksLazyLPat (L _ (WildPat {})) = False -looksLazyLPat _ = True - -isIrrefutableHsPat :: (OutputableBndrId id) => LPat id -> Bool --- (isIrrefutableHsPat p) is true if matching against p cannot fail, --- in the sense of falling through to the next pattern. --- (NB: this is not quite the same as the (silly) defn --- in 3.17.2 of the Haskell 98 report.) --- --- WARNING: isIrrefutableHsPat returns False if it's in doubt. --- Specifically on a ConPatIn, which is what it sees for a --- (LPat Name) in the renamer, it doesn't know the size of the --- constructor family, so it returns False. Result: only --- tuple patterns are considered irrefuable at the renamer stage. --- --- But if it returns True, the pattern is definitely irrefutable -isIrrefutableHsPat pat - = go pat - where - go (L _ pat) = go1 pat - - go1 (WildPat {}) = True - go1 (VarPat {}) = True - go1 (LazyPat {}) = True - go1 (BangPat pat) = go pat - go1 (CoPat _ pat _) = go1 pat - go1 (ParPat pat) = go pat - go1 (AsPat _ pat) = go pat - go1 (ViewPat _ pat _) = go pat - go1 (SigPatIn pat _) = go pat - go1 (SigPatOut pat _) = go pat - go1 (TuplePat pats _ _) = all go pats - go1 (SumPat _ _ _ _) = False - -- See Note [Unboxed sum patterns aren't irrefutable] - go1 (ListPat {}) = False - go1 (PArrPat {}) = False -- ? - - go1 (ConPatIn {}) = False -- Conservative - go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details }) - = isJust (tyConSingleDataCon_maybe (dataConTyCon con)) - -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because - -- the latter is false of existentials. See Trac #4439 - && all go (hsConPatArgs details) - go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) }) - = False -- Conservative - - go1 (LitPat {}) = False - go1 (NPat {}) = False - go1 (NPlusKPat {}) = False - - -- We conservatively assume that no TH splices are irrefutable - -- since we cannot know until the splice is evaluated. - go1 (SplicePat {}) = False - -{- Note [Unboxed sum patterns aren't irrefutable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as -patterns. A simple example that demonstrates this is from #14228: - - pattern Just' x = (# x | #) - pattern Nothing' = (# | () #) - - foo x = case x of - Nothing' -> putStrLn "nothing" - Just' -> putStrLn "just" - -In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable, -as does not match an unboxed sum value of the same arity—namely, (# | y #) -(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the -minimum unboxed sum arity is 2. - -Failing to mark unboxed sum patterns as non-irrefutable would cause the Just' -case in foo to be unreachable, as GHC would mistakenly believe that Nothing' -is the only thing that could possibly be matched! --} - -hsPatNeedsParens :: Pat a -> Bool -hsPatNeedsParens (NPlusKPat {}) = True -hsPatNeedsParens (SplicePat {}) = False -hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds -hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p) -hsPatNeedsParens (SigPatIn {}) = True -hsPatNeedsParens (SigPatOut {}) = True -hsPatNeedsParens (ViewPat {}) = True -hsPatNeedsParens (CoPat _ p _) = hsPatNeedsParens p -hsPatNeedsParens (WildPat {}) = False -hsPatNeedsParens (VarPat {}) = False -hsPatNeedsParens (LazyPat {}) = False -hsPatNeedsParens (BangPat {}) = False -hsPatNeedsParens (ParPat {}) = False -hsPatNeedsParens (AsPat {}) = False -hsPatNeedsParens (TuplePat {}) = False -hsPatNeedsParens (SumPat {}) = False -hsPatNeedsParens (ListPat {}) = False -hsPatNeedsParens (PArrPat {}) = False -hsPatNeedsParens (LitPat {}) = False -hsPatNeedsParens (NPat {}) = False - -conPatNeedsParens :: HsConDetails a b -> Bool -conPatNeedsParens (PrefixCon {}) = False -conPatNeedsParens (InfixCon {}) = True -conPatNeedsParens (RecCon {}) = False - -{- -% Collect all EvVars from all constructor patterns --} - --- May need to add more cases -collectEvVarsPats :: [Pat id] -> Bag EvVar -collectEvVarsPats = unionManyBags . map collectEvVarsPat - -collectEvVarsLPat :: LPat id -> Bag EvVar -collectEvVarsLPat (L _ pat) = collectEvVarsPat pat - -collectEvVarsPat :: Pat id -> Bag EvVar -collectEvVarsPat pat = - case pat of - LazyPat p -> collectEvVarsLPat p - AsPat _ p -> collectEvVarsLPat p - ParPat p -> collectEvVarsLPat p - BangPat p -> collectEvVarsLPat p - ListPat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps - TuplePat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps - SumPat p _ _ _ -> collectEvVarsLPat p - PArrPat ps _ -> unionManyBags $ map collectEvVarsLPat ps - ConPatOut {pat_dicts = dicts, pat_args = args} - -> unionBags (listToBag dicts) - $ unionManyBags - $ map collectEvVarsLPat - $ hsConPatArgs args - SigPatOut p _ -> collectEvVarsLPat p - CoPat _ p _ -> collectEvVarsPat p - ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" - SigPatIn _ _ -> panic "foldMapPatBag: SigPatIn" - _other_pat -> emptyBag diff --git a/hsSyn/HsPat.hs-boot b/hsSyn/HsPat.hs-boot deleted file mode 100644 --- a/hsSyn/HsPat.hs-boot +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE CPP, KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RoleAnnotations #-} - -module HsPat where -import SrcLoc( Located ) - -import Data.Data hiding (Fixity) -import Outputable -import PlaceHolder ( DataId, OutputableBndrId ) - -type role Pat nominal -data Pat (i :: *) -type LPat i = Located (Pat i) - -instance (DataId id) => Data (Pat id) -instance (OutputableBndrId name) => Outputable (Pat name) diff --git a/hsSyn/HsSyn.hs b/hsSyn/HsSyn.hs deleted file mode 100644 --- a/hsSyn/HsSyn.hs +++ /dev/null @@ -1,145 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{Haskell abstract syntax definition} - -This module glues together the pieces of the Haskell abstract syntax, -which is declared in the various \tr{Hs*} modules. This module, -therefore, is almost nothing but re-exporting. --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} - -module HsSyn ( - module HsBinds, - module HsDecls, - module HsExpr, - module HsImpExp, - module HsLit, - module HsPat, - module HsTypes, - module HsUtils, - module HsDoc, - module PlaceHolder, - Fixity, - - HsModule(..) -) where - --- friends: -import HsDecls -import HsBinds -import HsExpr -import HsImpExp -import HsLit -import PlaceHolder -import HsPat -import HsTypes -import BasicTypes ( Fixity, WarningTxt ) -import HsUtils -import HsDoc -import OccName ( HasOccName(..) ) - --- others: -import Outputable -import SrcLoc -import Module ( ModuleName ) - --- libraries: -import Data.Data hiding ( Fixity ) - --- | Haskell Module --- --- All we actually declare here is the top-level structure for a module. -data HsModule name - = HsModule { - hsmodName :: Maybe (Located ModuleName), - -- ^ @Nothing@: \"module X where\" is omitted (in which case the next - -- field is Nothing too) - hsmodExports :: Maybe (Located [LIE name]), - -- ^ Export list - -- - -- - @Nothing@: export list omitted, so export everything - -- - -- - @Just []@: export /nothing/ - -- - -- - @Just [...]@: as you would expect... - -- - -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' - -- ,'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - hsmodImports :: [LImportDecl name], - -- ^ We snaffle interesting stuff out of the imported interfaces early - -- on, adding that info to TyDecls/etc; so this list is often empty, - -- downstream. - hsmodDecls :: [LHsDecl name], - -- ^ Type, class, value, and interface signature decls - hsmodDeprecMessage :: Maybe (Located WarningTxt), - -- ^ reason\/explanation for warning/deprecation of this module - -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' - -- ,'ApiAnnotation.AnnClose' - -- - - -- For details on above see note [Api annotations] in ApiAnnotation - hsmodHaddockModHeader :: Maybe LHsDocString - -- ^ Haddock module info and description, unparsed - -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' - -- ,'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - } - -- ^ 'ApiAnnotation.AnnKeywordId's - -- - -- - 'ApiAnnotation.AnnModule','ApiAnnotation.AnnWhere' - -- - -- - 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnClose' for explicit braces and semi around - -- hsmodImports,hsmodDecls if this style is used. - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (HsModule name) - -instance (OutputableBndrId name, HasOccName name) - => Outputable (HsModule name) where - - ppr (HsModule Nothing _ imports decls _ mbDoc) - = pp_mb mbDoc $$ pp_nonnull imports - $$ pp_nonnull decls - - ppr (HsModule (Just name) exports imports decls deprec mbDoc) - = vcat [ - pp_mb mbDoc, - case exports of - Nothing -> pp_header (text "where") - Just es -> vcat [ - pp_header lparen, - nest 8 (fsep (punctuate comma (map ppr (unLoc es)))), - nest 4 (text ") where") - ], - pp_nonnull imports, - pp_nonnull decls - ] - where - pp_header rest = case deprec of - Nothing -> pp_modname <+> rest - Just d -> vcat [ pp_modname, ppr d, rest ] - - pp_modname = text "module" <+> ppr name - -pp_mb :: Outputable t => Maybe t -> SDoc -pp_mb (Just x) = ppr x -pp_mb Nothing = empty - -pp_nonnull :: Outputable t => [t] -> SDoc -pp_nonnull [] = empty -pp_nonnull xs = vcat (map ppr xs) diff --git a/hsSyn/HsTypes.hs b/hsSyn/HsTypes.hs deleted file mode 100644 --- a/hsSyn/HsTypes.hs +++ /dev/null @@ -1,1349 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -HsTypes: Abstract syntax: user-defined types --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} - -module HsTypes ( - HsType(..), LHsType, HsKind, LHsKind, - HsTyVarBndr(..), LHsTyVarBndr, - LHsQTyVars(..), - HsImplicitBndrs(..), - HsWildCardBndrs(..), - LHsSigType, LHsSigWcType, LHsWcType, - HsTupleSort(..), - Promoted(..), - HsContext, LHsContext, - HsTyLit(..), - HsIPName(..), hsIPNameFS, - HsAppType(..),LHsAppType, - - LBangType, BangType, - HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..), - getBangType, getBangStrictness, - - ConDeclField(..), LConDeclField, pprConDeclFields, updateGadtResult, - - HsConDetails(..), - - FieldOcc(..), LFieldOcc, mkFieldOcc, - AmbiguousFieldOcc(..), mkAmbiguousFieldOcc, - rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, - unambiguousFieldOcc, ambiguousFieldOcc, - - HsWildCardInfo(..), mkAnonWildCardTy, - wildCardName, sameWildCard, - - mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, - mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, - mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs, - isHsKindedTyVar, hsTvbAllKinded, - hsScopedTvs, hsWcScopedTvs, dropWildCards, - hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, - hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames, - splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, - splitLHsPatSynTy, - splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy, - splitHsFunType, splitHsAppsTy, - splitHsAppTys, getAppsTyHead_maybe, hsTyGetAppHead_maybe, - mkHsOpTy, mkHsAppTy, mkHsAppTys, - ignoreParens, hsSigType, hsSigWcType, - hsLTyVarBndrToType, hsLTyVarBndrsToTypes, - - -- Printing - pprParendHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra, - pprHsContext, pprHsContextNoArrow, pprHsContextMaybe - ) where - -import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) - -import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..), - OutputableBndrId ) - -import Id ( Id ) -import Name( Name ) -import RdrName ( RdrName ) -import NameSet ( NameSet, emptyNameSet ) -import DataCon( HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..) ) -import TysPrim( funTyConName ) -import Type -import HsDoc -import BasicTypes -import SrcLoc -import Outputable -import FastString -import Maybes( isJust ) - -import Data.Data hiding ( Fixity, Prefix, Infix ) -import Data.Maybe ( fromMaybe ) -import Control.Monad ( unless ) - -{- -************************************************************************ -* * -\subsection{Bang annotations} -* * -************************************************************************ --} - --- | Located Bang Type -type LBangType name = Located (BangType name) - --- | Bang Type -type BangType name = HsType name -- Bangs are in the HsType data type - -getBangType :: LHsType a -> LHsType a -getBangType (L _ (HsBangTy _ ty)) = ty -getBangType ty = ty - -getBangStrictness :: LHsType a -> HsSrcBang -getBangStrictness (L _ (HsBangTy s _)) = s -getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) - -{- -************************************************************************ -* * -\subsection{Data types} -* * -************************************************************************ - -This is the syntax for types as seen in type signatures. - -Note [HsBSig binder lists] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a binder (or pattern) decorated with a type or kind, - \ (x :: a -> a). blah - forall (a :: k -> *) (b :: k). blah -Then we use a LHsBndrSig on the binder, so that the -renamer can decorate it with the variables bound -by the pattern ('a' in the first example, 'k' in the second), -assuming that neither of them is in scope already -See also Note [Kind and type-variable binders] in RnTypes - -Note [HsType binders] -~~~~~~~~~~~~~~~~~~~~~ -The system for recording type and kind-variable binders in HsTypes -is a bit complicated. Here's how it works. - -* In a HsType, - HsForAllTy represents an /explicit, user-written/ 'forall' - e.g. forall a b. ... - HsQualTy represents an /explicit, user-written/ context - e.g. (Eq a, Show a) => ... - The context can be empty if that's what the user wrote - These constructors represent what the user wrote, no more - and no less. - -* HsTyVarBndr describes a quantified type variable written by the - user. For example - f :: forall a (b :: *). blah - here 'a' and '(b::*)' are each a HsTyVarBndr. A HsForAllTy has - a list of LHsTyVarBndrs. - -* HsImplicitBndrs is a wrapper that gives the implicitly-quantified - kind and type variables of the wrapped thing. It is filled in by - the renamer. For example, if the user writes - f :: a -> a - the HsImplicitBinders binds the 'a' (not a HsForAllTy!). - NB: this implicit quantification is purely lexical: we bind any - type or kind variables that are not in scope. The type checker - may subsequently quantify over further kind variables. - -* HsWildCardBndrs is a wrapper that binds the wildcard variables - of the wrapped thing. It is filled in by the renamer - f :: _a -> _ - The enclosing HsWildCardBndrs binds the wildcards _a and _. - -* The explicit presence of these wrappers specifies, in the HsSyn, - exactly where implicit quantification is allowed, and where - wildcards are allowed. - -* LHsQTyVars is used in data/class declarations, where the user gives - explicit *type* variable bindings, but we need to implicitly bind - *kind* variables. For example - class C (a :: k -> *) where ... - The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars - -Note [The wildcard story for types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Types can have wildcards in them, to support partial type signatures, -like f :: Int -> (_ , _a) -> _a - -A wildcard in a type can be - - * An anonymous wildcard, - written '_' - In HsType this is represented by HsWildCardTy. - After the renamer, this contains a Name which uniquely - identifies this particular occurrence. - - * A named wildcard, - written '_a', '_foo', etc - In HsType this is represented by (HsTyVar "_a") - i.e. a perfectly ordinary type variable that happens - to start with an underscore - -Note carefully: - -* When NamedWildCards is off, type variables that start with an - underscore really /are/ ordinary type variables. And indeed, even - when NamedWildCards is on you can bind _a explicitly as an ordinary - type variable: - data T _a _b = MkT _b _a - Or even: - f :: forall _a. _a -> _b - Here _a is an ordinary forall'd binder, but (With NamedWildCards) - _b is a named wildcard. (See the comments in Trac #10982) - -* All wildcards, whether named or anonymous, are bound by the - HsWildCardBndrs construct, which wraps types that are allowed - to have wildcards. - -* After type checking is done, we report what types the wildcards - got unified with. - --} - --- | Located Haskell Context -type LHsContext name = Located (HsContext name) - -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit' - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | Haskell Context -type HsContext name = [LHsType name] - --- | Located Haskell Type -type LHsType name = Located (HsType name) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when - -- in a list - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | Haskell Kind -type HsKind name = HsType name - --- | Located Haskell Kind -type LHsKind name = Located (HsKind name) - -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - --------------------------------------------------- --- LHsQTyVars --- The explicitly-quantified binders in a data/type declaration - --- | Located Haskell Type Variable Binder -type LHsTyVarBndr name = Located (HsTyVarBndr name) - -- See Note [HsType binders] - --- | Located Haskell Quantified Type Variables -data LHsQTyVars name -- See Note [HsType binders] - = HsQTvs { hsq_implicit :: PostRn name [Name] -- implicit (dependent) variables - , hsq_explicit :: [LHsTyVarBndr name] -- explicit variables - -- See Note [HsForAllTy tyvar binders] - , hsq_dependent :: PostRn name NameSet - -- which explicit vars are dependent - -- See Note [Dependent LHsQTyVars] in TcHsType - } - -deriving instance (DataId name) => Data (LHsQTyVars name) - -mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsQTyVars RdrName -mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs - , hsq_dependent = PlaceHolder } - -hsQTvExplicit :: LHsQTyVars name -> [LHsTyVarBndr name] -hsQTvExplicit = hsq_explicit - -emptyLHsQTvs :: LHsQTyVars Name -emptyLHsQTvs = HsQTvs [] [] emptyNameSet - -isEmptyLHsQTvs :: LHsQTyVars Name -> Bool -isEmptyLHsQTvs (HsQTvs [] [] _) = True -isEmptyLHsQTvs _ = False - ------------------------------------------------- --- HsImplicitBndrs --- Used to quantify the binders of a type in cases --- when a HsForAll isn't appropriate: --- * Patterns in a type/data family instance (HsTyPats) --- * Type of a rule binder (RuleBndr) --- * Pattern type signatures (SigPatIn) --- In the last of these, wildcards can happen, so we must accommodate them - --- | Haskell Implicit Binders -data HsImplicitBndrs name thing -- See Note [HsType binders] - = HsIB { hsib_vars :: PostRn name [Name] -- Implicitly-bound kind & type vars - , hsib_body :: thing -- Main payload (type or list of types) - , hsib_closed :: PostRn name Bool -- Taking the hsib_vars into account, - -- is the payload closed? Used in - -- TcHsType.decideKindGeneralisationPlan - } - --- | Haskell Wildcard Binders -data HsWildCardBndrs name thing - -- See Note [HsType binders] - -- See Note [The wildcard story for types] - = HsWC { hswc_wcs :: PostRn name [Name] - -- Wild cards, both named and anonymous - -- after the renamer - - , hswc_body :: thing - -- Main payload (type or list of types) - -- If there is an extra-constraints wildcard, - -- it's still there in the hsc_body. - } - -deriving instance (Data name, Data thing, Data (PostRn name [Name]), Data (PostRn name Bool)) - => Data (HsImplicitBndrs name thing) - -deriving instance (Data name, Data thing, Data (PostRn name [Name])) - => Data (HsWildCardBndrs name thing) - --- | Located Haskell Signature Type -type LHsSigType name = HsImplicitBndrs name (LHsType name) -- Implicit only - --- | Located Haskell Wildcard Type -type LHsWcType name = HsWildCardBndrs name (LHsType name) -- Wildcard only - --- | Located Haskell Signature Wildcard Type -type LHsSigWcType name = HsWildCardBndrs name (LHsSigType name) -- Both - --- See Note [Representing type signatures] - -hsImplicitBody :: HsImplicitBndrs name thing -> thing -hsImplicitBody (HsIB { hsib_body = body }) = body - -hsSigType :: LHsSigType name -> LHsType name -hsSigType = hsImplicitBody - -hsSigWcType :: LHsSigWcType name -> LHsType name -hsSigWcType sig_ty = hsib_body (hswc_body sig_ty) - -dropWildCards :: LHsSigWcType name -> LHsSigType name --- Drop the wildcard part of a LHsSigWcType -dropWildCards sig_ty = hswc_body sig_ty - -{- Note [Representing type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -HsSigType is used to represent an explicit user type signature -such as f :: a -> a - or g (x :: a -> a) = x - -A HsSigType is just a HsImplicitBndrs wrapping a LHsType. - * The HsImplicitBndrs binds the /implicitly/ quantified tyvars - * The LHsType binds the /explicitly/ quantified tyvars - -E.g. For a signature like - f :: forall (a::k). blah -we get - HsIB { hsib_vars = [k] - , hsib_body = HsForAllTy { hst_bndrs = [(a::*)] - , hst_body = blah } -The implicit kind variable 'k' is bound by the HsIB; -the explicitly forall'd tyvar 'a' is bound by the HsForAllTy --} - -mkHsImplicitBndrs :: thing -> HsImplicitBndrs RdrName thing -mkHsImplicitBndrs x = HsIB { hsib_body = x - , hsib_vars = PlaceHolder - , hsib_closed = PlaceHolder } - -mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing -mkHsWildCardBndrs x = HsWC { hswc_body = x - , hswc_wcs = PlaceHolder } - --- Add empty binders. This is a bit suspicious; what if --- the wrapped thing had free type variables? -mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs Name thing -mkEmptyImplicitBndrs x = HsIB { hsib_body = x - , hsib_vars = [] - , hsib_closed = False } - -mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing -mkEmptyWildCardBndrs x = HsWC { hswc_body = x - , hswc_wcs = [] } - - --------------------------------------------------- --- | These names are used early on to store the names of implicit --- parameters. They completely disappear after type-checking. -newtype HsIPName = HsIPName FastString - deriving( Eq, Data ) - -hsIPNameFS :: HsIPName -> FastString -hsIPNameFS (HsIPName n) = n - -instance Outputable HsIPName where - ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters - -instance OutputableBndr HsIPName where - pprBndr _ n = ppr n -- Simple for now - pprInfixOcc n = ppr n - pprPrefixOcc n = ppr n - --------------------------------------------------- - --- | Haskell Type Variable Binder -data HsTyVarBndr name - = UserTyVar -- no explicit kinding - (Located name) - -- See Note [Located RdrNames] in HsExpr - | KindedTyVar - (Located name) - (LHsKind name) -- The user-supplied kind signature - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (HsTyVarBndr name) - --- | Does this 'HsTyVarBndr' come with an explicit kind annotation? -isHsKindedTyVar :: HsTyVarBndr name -> Bool -isHsKindedTyVar (UserTyVar {}) = False -isHsKindedTyVar (KindedTyVar {}) = True - --- | Do all type variables in this 'LHsQTyVars' come with kind annotations? -hsTvbAllKinded :: LHsQTyVars name -> Bool -hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit - --- | Haskell Type -data HsType name - = HsForAllTy -- See Note [HsType binders] - { hst_bndrs :: [LHsTyVarBndr name] -- Explicit, user-supplied 'forall a b c' - , hst_body :: LHsType name -- body type - } - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', - -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsQualTy -- See Note [HsType binders] - { hst_ctxt :: LHsContext name -- Context C => blah - , hst_body :: LHsType name } - - | HsTyVar Promoted -- whether explicitly promoted, for the pretty - -- printer - (Located name) - -- Type variable, type constructor, or data constructor - -- see Note [Promotions (HsTyVar)] - -- See Note [Located RdrNames] in HsExpr - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsAppsTy [LHsAppType name] -- Used only before renaming, - -- Note [HsAppsTy] - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - | HsAppTy (LHsType name) - (LHsType name) - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsFunTy (LHsType name) -- function type - (LHsType name) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsListTy (LHsType name) -- Element type - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, - -- 'ApiAnnotation.AnnClose' @':]'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsTupleTy HsTupleSort - [LHsType name] -- Element types (length gives arity) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@, - -- 'ApiAnnotation.AnnClose' @')' or '#)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsSumTy [LHsType name] -- Element types (length gives arity) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, - -- 'ApiAnnotation.AnnClose' '#)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsOpTy (LHsType name) (Located name) (LHsType name) - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsParTy (LHsType name) -- See Note [Parens in HsSyn] in HsExpr - -- Parenthesis preserved for the precedence re-arrangement in RnTypes - -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsIParamTy (Located HsIPName) -- (?x :: ty) - (LHsType name) -- Implicit parameters as they occur in contexts - -- ^ - -- > (?x :: ty) - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsEqTy (LHsType name) -- ty1 ~ ty2 - (LHsType name) -- Always allowed even without TypeOperators, and has special kinding rule - -- ^ - -- > ty1 ~ ty2 - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsKindSig (LHsType name) -- (ty :: kind) - (LHsKind name) -- A type with a kind signature - -- ^ - -- > (ty :: kind) - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsSpliceTy (HsSplice name) -- Includes quasi-quotes - (PostTc name Kind) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsDocTy (LHsType name) LHsDocString -- A documented type - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsBangTy HsSrcBang (LHsType name) -- Bang-style type annotations - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, - -- 'ApiAnnotation.AnnClose' @'#-}'@ - -- 'ApiAnnotation.AnnBang' @\'!\'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsRecTy [LConDeclField name] -- Only in data type declarations - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCoreTy Type -- An escape hatch for tunnelling a *closed* - -- Core Type through HsSyn. - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsExplicitListTy -- A promoted explicit list - Promoted -- whether explcitly promoted, for pretty printer - (PostTc name Kind) -- See Note [Promoted lists and tuples] - [LHsType name] - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsExplicitTupleTy -- A promoted explicit tuple - [PostTc name Kind] -- See Note [Promoted lists and tuples] - [LHsType name] - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsTyLit HsTyLit -- A promoted numeric literal. - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsWildCardTy (HsWildCardInfo name) -- A type wildcard - -- See Note [The wildcard story for types] - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (HsType name) - --- Note [Literal source text] in BasicTypes for SourceText fields in --- the following --- | Haskell Type Literal -data HsTyLit - = HsNumTy SourceText Integer - | HsStrTy SourceText FastString - deriving Data - -newtype HsWildCardInfo name -- See Note [The wildcard story for types] - = AnonWildCard (PostRn name (Located Name)) - -- A anonymous wild card ('_'). A fresh Name is generated for - -- each individual anonymous wildcard during renaming -deriving instance (DataId name) => Data (HsWildCardInfo name) - --- | Located Haskell Application Type -type LHsAppType name = Located (HsAppType name) - -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSimpleQuote' - --- | Haskell Application Type -data HsAppType name - = HsAppInfix (Located name) -- either a symbol or an id in backticks - | HsAppPrefix (LHsType name) -- anything else, including things like (+) -deriving instance (DataId name) => Data (HsAppType name) - -instance (OutputableBndrId name) => Outputable (HsAppType name) where - ppr = ppr_app_ty TopPrec - -{- -Note [HsForAllTy tyvar binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After parsing: - * Implicit => empty - Explicit => the variables the user wrote - -After renaming - * Implicit => the *type* variables free in the type - Explicit => the variables the user wrote (renamed) - -Qualified currently behaves exactly as Implicit, -but it is deprecated to use it for implicit quantification. -In this case, GHC 7.10 gives a warning; see -Note [Context quantification] in RnTypes, and Trac #4426. -In GHC 8.0, Qualified will no longer bind variables -and this will become an error. - -The kind variables bound in the hsq_implicit field come both - a) from the kind signatures on the kind vars (eg k1) - b) from the scope of the forall (eg k2) -Example: f :: forall (a::k1) b. T a (b::k2) - - -Note [Unit tuples] -~~~~~~~~~~~~~~~~~~ -Consider the type - type instance F Int = () -We want to parse that "()" - as HsTupleTy HsBoxedOrConstraintTuple [], -NOT as HsTyVar unitTyCon - -Why? Because F might have kind (* -> Constraint), so we when parsing we -don't know if that tuple is going to be a constraint tuple or an ordinary -unit tuple. The HsTupleSort flag is specifically designed to deal with -that, but it has to work for unit tuples too. - -Note [Promotions (HsTyVar)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -HsTyVar: A name in a type or kind. - Here are the allowed namespaces for the name. - In a type: - Var: not allowed - Data: promoted data constructor - Tv: type variable - TcCls before renamer: type constructor, class constructor, or promoted data constructor - TcCls after renamer: type constructor or class constructor - In a kind: - Var, Data: not allowed - Tv: kind variable - TcCls: kind constructor or promoted type constructor - - The 'Promoted' field in an HsTyVar captures whether the type was promoted in - the source code by prefixing an apostrophe. - -Note [HsAppsTy] -~~~~~~~~~~~~~~~ -How to parse - - Foo * Int - -? Is it `(*) Foo Int` or `Foo GHC.Types.* Int`? There's no way to know until renaming. -So we just take type expressions like this and put each component in a list, so be -sorted out in the renamer. The sorting out is done by RnTypes.mkHsOpTyRn. This means -that the parser should never produce HsAppTy or HsOpTy. - -Note [Promoted lists and tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice the difference between - HsListTy HsExplicitListTy - HsTupleTy HsExplicitListTupleTy - -E.g. f :: [Int] HsListTy - - g3 :: T '[] All these use - g2 :: T '[True] HsExplicitListTy - g1 :: T '[True,False] - g1a :: T [True,False] (can omit ' where unambiguous) - - kind of T :: [Bool] -> * This kind uses HsListTy! - -E.g. h :: (Int,Bool) HsTupleTy; f is a pair - k :: S '(True,False) HsExplicitTypleTy; S is indexed by - a type-level pair of booleans - kind of S :: (Bool,Bool) -> * This kind uses HsExplicitTupleTy - -Note [Distinguishing tuple kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Apart from promotion, tuples can have one of three different kinds: - - x :: (Int, Bool) -- Regular boxed tuples - f :: Int# -> (# Int#, Int# #) -- Unboxed tuples - g :: (Eq a, Ord a) => a -- Constraint tuples - -For convenience, internally we use a single constructor for all of these, -namely HsTupleTy, but keep track of the tuple kind (in the first argument to -HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing, -because of the #. However, with -XConstraintKinds we can only distinguish -between constraint and boxed tuples during type checking, in general. Hence the -four constructors of HsTupleSort: - - HsUnboxedTuple -> Produced by the parser - HsBoxedTuple -> Certainly a boxed tuple - HsConstraintTuple -> Certainly a constraint tuple - HsBoxedOrConstraintTuple -> Could be a boxed or a constraint - tuple. Produced by the parser only, - disappears after type checking --} - --- | Haskell Tuple Sort -data HsTupleSort = HsUnboxedTuple - | HsBoxedTuple - | HsConstraintTuple - | HsBoxedOrConstraintTuple - deriving Data - - --- | Promoted data types. -data Promoted = Promoted - | NotPromoted - deriving (Data, Eq, Show) - --- | Located Constructor Declaration Field -type LConDeclField name = Located (ConDeclField name) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when - -- in a list - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | Constructor Declaration Field -data ConDeclField name -- Record fields have Haddoc docs on them - = ConDeclField { cd_fld_names :: [LFieldOcc name], - -- ^ See Note [ConDeclField names] - cd_fld_type :: LBangType name, - cd_fld_doc :: Maybe LHsDocString } - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (ConDeclField name) - -instance (OutputableBndrId name) => Outputable (ConDeclField name) where - ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty - --- HsConDetails is used for patterns/expressions *and* for data type --- declarations --- | Haskell Constructor Details -data HsConDetails arg rec - = PrefixCon [arg] -- C p1 p2 p3 - | RecCon rec -- C { x = p1, y = p2 } - | InfixCon arg arg -- p1 `C` p2 - deriving Data - -instance (Outputable arg, Outputable rec) - => Outputable (HsConDetails arg rec) where - ppr (PrefixCon args) = text "PrefixCon" <+> ppr args - ppr (RecCon rec) = text "RecCon:" <+> ppr rec - ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] - --- Takes details and result type of a GADT data constructor as created by the --- parser and rejigs them using information about fixities from the renamer. --- See Note [Sorting out the result type] in RdrHsSyn -updateGadtResult - :: (Monad m) - => (SDoc -> m ()) - -> SDoc - -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) - -- ^ Original details - -> LHsType Name -- ^ Original result type - -> m (HsConDetails (LHsType Name) (Located [LConDeclField Name]), - LHsType Name) -updateGadtResult failWith doc details ty - = do { let (arg_tys, res_ty) = splitHsFunType ty - badConSig = text "Malformed constructor signature" - ; case details of - InfixCon {} -> pprPanic "updateGadtResult" (ppr ty) - - RecCon {} -> do { unless (null arg_tys) - (failWith (doc <+> badConSig)) - ; return (details, res_ty) } - - PrefixCon {} -> return (PrefixCon arg_tys, res_ty)} - -{- -Note [ConDeclField names] -~~~~~~~~~~~~~~~~~~~~~~~~~ - -A ConDeclField contains a list of field occurrences: these always -include the field label as the user wrote it. After the renamer, it -will additionally contain the identity of the selector function in the -second component. - -Due to DuplicateRecordFields, the OccName of the selector function -may have been mangled, which is why we keep the original field label -separately. For example, when DuplicateRecordFields is enabled - - data T = MkT { x :: Int } - -gives - - ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }. --} - ------------------------ --- A valid type must have a for-all at the top of the type, or of the fn arg --- types - ---------------------- -hsWcScopedTvs :: LHsSigWcType Name -> [Name] --- Get the lexically-scoped type variables of a HsSigType --- - the explicitly-given forall'd type variables --- - the implicitly-bound kind variables --- - the named wildcars; see Note [Scoping of named wildcards] --- because they scope in the same way -hsWcScopedTvs sig_ty - | HsWC { hswc_wcs = nwcs, hswc_body = sig_ty1 } <- sig_ty - , HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty1 - = case sig_ty2 of - L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++ - map hsLTyVarName tvs - -- include kind variables only if the type is headed by forall - -- (this is consistent with GHC 7 behaviour) - _ -> nwcs - -hsScopedTvs :: LHsSigType Name -> [Name] --- Same as hsWcScopedTvs, but for a LHsSigType -hsScopedTvs sig_ty - | HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty - , L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2 - = vars ++ map hsLTyVarName tvs - | otherwise - = [] - -{- Note [Scoping of named wildcards] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: _a -> _a - f x = let g :: _a -> _a - g = ... - in ... - -Currently, for better or worse, the "_a" variables are all the same. So -although there is no explicit forall, the "_a" scopes over the definition. -I don't know if this is a good idea, but there it is. --} - ---------------------- -hsTyVarName :: HsTyVarBndr name -> name -hsTyVarName (UserTyVar (L _ n)) = n -hsTyVarName (KindedTyVar (L _ n) _) = n - -hsLTyVarName :: LHsTyVarBndr name -> name -hsLTyVarName = hsTyVarName . unLoc - -hsExplicitLTyVarNames :: LHsQTyVars name -> [name] --- Explicit variables only -hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) - -hsAllLTyVarNames :: LHsQTyVars Name -> [Name] --- All variables -hsAllLTyVarNames (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) - = kvs ++ map hsLTyVarName tvs - -hsLTyVarLocName :: LHsTyVarBndr name -> Located name -hsLTyVarLocName = fmap hsTyVarName - -hsLTyVarLocNames :: LHsQTyVars name -> [Located name] -hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) - --- | Convert a LHsTyVarBndr to an equivalent LHsType. -hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name -hsLTyVarBndrToType = fmap cvt - where cvt (UserTyVar n) = HsTyVar NotPromoted n - cvt (KindedTyVar (L name_loc n) kind) - = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind - --- | Convert a LHsTyVarBndrs to a list of types. --- Works on *type* variable only, no kind vars. -hsLTyVarBndrsToTypes :: LHsQTyVars name -> [LHsType name] -hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs - ---------------------- -wildCardName :: HsWildCardInfo Name -> Name -wildCardName (AnonWildCard (L _ n)) = n - --- Two wild cards are the same when they have the same location -sameWildCard :: Located (HsWildCardInfo name) - -> Located (HsWildCardInfo name) -> Bool -sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2 - -ignoreParens :: LHsType name -> LHsType name -ignoreParens (L _ (HsParTy ty)) = ignoreParens ty -ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty -ignoreParens ty = ty - -{- -************************************************************************ -* * - Building types -* * -************************************************************************ --} - -mkAnonWildCardTy :: HsType RdrName -mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder) - -mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name -mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2 - -mkHsAppTy :: LHsType name -> LHsType name -> LHsType name -mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) - -mkHsAppTys :: LHsType name -> [LHsType name] -> LHsType name -mkHsAppTys = foldl mkHsAppTy - - -{- -************************************************************************ -* * - Decomposing HsTypes -* * -************************************************************************ --} - ---------------------------------- --- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) --- Breaks up any parens in the result type: --- splitHsFunType (a -> (b -> c)) = ([a,b], c) --- Also deals with (->) t1 t2; that is why it only works on LHsType Name --- (see Trac #9096) -splitHsFunType :: LHsType Name -> ([LHsType Name], LHsType Name) -splitHsFunType (L _ (HsParTy ty)) - = splitHsFunType ty - -splitHsFunType (L _ (HsFunTy x y)) - | (args, res) <- splitHsFunType y - = (x:args, res) - -splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) - = go t1 [t2] - where -- Look for (->) t1 t2, possibly with parenthesisation - go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName - , [t1,t2] <- tys - , (args, res) <- splitHsFunType t2 - = (t1:args, res) - go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys) - go (L _ (HsParTy ty)) tys = go ty tys - go _ _ = ([], orig_ty) -- Failure to match - -splitHsFunType other = ([], other) - --------------------------------- --- | Retrieves the head of an HsAppsTy, if this can be done unambiguously, --- without consulting fixities. -getAppsTyHead_maybe :: [LHsAppType name] - -> Maybe (LHsType name, [LHsType name], LexicalFixity) -getAppsTyHead_maybe tys = case splitHsAppsTy tys of - ([app1:apps], []) -> -- no symbols, some normal types - Just (mkHsAppTys app1 apps, [], Prefix) - ([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator - Just ( L loc (HsTyVar NotPromoted (L loc op)) - , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr], Infix) - _ -> -- can't figure it out - Nothing - --- | Splits a [HsAppType name] (the payload of an HsAppsTy) into regions of prefix --- types (normal types) and infix operators. --- If @splitHsAppsTy tys = (non_syms, syms)@, then @tys@ starts with the first --- element of @non_syms@ followed by the first element of @syms@ followed by --- the next element of @non_syms@, etc. It is guaranteed that the non_syms list --- has one more element than the syms list. -splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [Located name]) -splitHsAppsTy = go [] [] [] - where - go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym) - go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest) - = go (ty : acc) acc_non acc_sym rest - go acc acc_non acc_sym (L _ (HsAppInfix op) : rest) - = go [] (reverse acc : acc_non) (op : acc_sym) rest - --- Retrieve the name of the "head" of a nested type application --- somewhat like splitHsAppTys, but a little more thorough --- used to examine the result of a GADT-like datacon, so it doesn't handle --- *all* cases (like lists, tuples, (~), etc.) -hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) -hsTyGetAppHead_maybe = go [] - where - go tys (L _ (HsTyVar _ ln)) = Just (ln, tys) - go tys (L _ (HsAppsTy apps)) - | Just (head, args, _) <- getAppsTyHead_maybe apps - = go (args ++ tys) head - go tys (L _ (HsAppTy l r)) = go (r : tys) l - go tys (L _ (HsOpTy l (L loc n) r)) = Just (L loc n, l : r : tys) - go tys (L _ (HsParTy t)) = go tys t - go tys (L _ (HsKindSig t _)) = go tys t - go _ _ = Nothing - -splitHsAppTys :: LHsType Name -> [LHsType Name] -> (LHsType Name, [LHsType Name]) - -- no need to worry about HsAppsTy here -splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) -splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as -splitHsAppTys f as = (f,as) - --------------------------------- -splitLHsPatSynTy :: LHsType name - -> ( [LHsTyVarBndr name] -- universals - , LHsContext name -- required constraints - , [LHsTyVarBndr name] -- existentials - , LHsContext name -- provided constraints - , LHsType name) -- body type -splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) - where - (univs, ty1) = splitLHsForAllTy ty - (reqs, ty2) = splitLHsQualTy ty1 - (exis, ty3) = splitLHsForAllTy ty2 - (provs, ty4) = splitLHsQualTy ty3 - -splitLHsSigmaTy :: LHsType name -> ([LHsTyVarBndr name], LHsContext name, LHsType name) -splitLHsSigmaTy ty - | (tvs, ty1) <- splitLHsForAllTy ty - , (ctxt, ty2) <- splitLHsQualTy ty1 - = (tvs, ctxt, ty2) - -splitLHsForAllTy :: LHsType name -> ([LHsTyVarBndr name], LHsType name) -splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) -splitLHsForAllTy body = ([], body) - -splitLHsQualTy :: LHsType name -> (LHsContext name, LHsType name) -splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) -splitLHsQualTy body = (noLoc [], body) - -splitLHsInstDeclTy :: LHsSigType Name - -> ([Name], LHsContext Name, LHsType Name) --- Split up an instance decl type, returning the pieces -splitLHsInstDeclTy (HsIB { hsib_vars = itkvs - , hsib_body = inst_ty }) - | (tvs, cxt, body_ty) <- splitLHsSigmaTy inst_ty - = (itkvs ++ map hsLTyVarName tvs, cxt, body_ty) - -- Return implicitly bound type and kind vars - -- For an instance decl, all of them are in scope - -getLHsInstDeclHead :: LHsSigType name -> LHsType name -getLHsInstDeclHead inst_ty - | (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty) - = body_ty - -getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name) --- Works on (HsSigType RdrName) -getLHsInstDeclClass_maybe inst_ty - = do { let head_ty = getLHsInstDeclHead inst_ty - ; (cls, _) <- hsTyGetAppHead_maybe head_ty - ; return cls } - -{- -************************************************************************ -* * - FieldOcc -* * -************************************************************************ --} - --- | Located Field Occurrence -type LFieldOcc name = Located (FieldOcc name) - --- | Field Occurrence --- --- Represents an *occurrence* of an unambiguous field. We store --- both the 'RdrName' the user originally wrote, and after the --- renamer, the selector function. -data FieldOcc name = FieldOcc { rdrNameFieldOcc :: Located RdrName - -- ^ See Note [Located RdrNames] in HsExpr - , selectorFieldOcc :: PostRn name name - } -deriving instance Eq (PostRn name name) => Eq (FieldOcc name) -deriving instance Ord (PostRn name name) => Ord (FieldOcc name) -deriving instance (Data name, Data (PostRn name name)) => Data (FieldOcc name) - -instance Outputable (FieldOcc name) where - ppr = ppr . rdrNameFieldOcc - -mkFieldOcc :: Located RdrName -> FieldOcc RdrName -mkFieldOcc rdr = FieldOcc rdr PlaceHolder - - --- | Ambiguous Field Occurrence --- --- Represents an *occurrence* of a field that is potentially --- ambiguous after the renamer, with the ambiguity resolved by the --- typechecker. We always store the 'RdrName' that the user --- originally wrote, and store the selector function after the renamer --- (for unambiguous occurrences) or the typechecker (for ambiguous --- occurrences). --- --- See Note [HsRecField and HsRecUpdField] in HsPat and --- Note [Disambiguating record fields] in TcExpr. --- See Note [Located RdrNames] in HsExpr -data AmbiguousFieldOcc name - = Unambiguous (Located RdrName) (PostRn name name) - | Ambiguous (Located RdrName) (PostTc name name) -deriving instance ( Data name - , Data (PostRn name name) - , Data (PostTc name name)) - => Data (AmbiguousFieldOcc name) - -instance Outputable (AmbiguousFieldOcc name) where - ppr = ppr . rdrNameAmbiguousFieldOcc - -instance OutputableBndr (AmbiguousFieldOcc name) where - pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc - pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc - -mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc RdrName -mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder - -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc name -> RdrName -rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr -rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr - -selectorAmbiguousFieldOcc :: AmbiguousFieldOcc Id -> Id -selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel -selectorAmbiguousFieldOcc (Ambiguous _ sel) = sel - -unambiguousFieldOcc :: AmbiguousFieldOcc Id -> FieldOcc Id -unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel -unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel - -ambiguousFieldOcc :: FieldOcc name -> AmbiguousFieldOcc name -ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel - -{- -************************************************************************ -* * -\subsection{Pretty printing} -* * -************************************************************************ --} - -instance (OutputableBndrId name) => Outputable (HsType name) where - ppr ty = pprHsType ty - -instance Outputable HsTyLit where - ppr = ppr_tylit - -instance (OutputableBndrId name) => Outputable (LHsQTyVars name) where - ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs - -instance (OutputableBndrId name) => Outputable (HsTyVarBndr name) where - ppr (UserTyVar n) = ppr n - ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k] - -instance (Outputable thing) => Outputable (HsImplicitBndrs name thing) where - ppr (HsIB { hsib_body = ty }) = ppr ty - -instance (Outputable thing) => Outputable (HsWildCardBndrs name thing) where - ppr (HsWC { hswc_body = ty }) = ppr ty - -instance Outputable (HsWildCardInfo name) where - ppr (AnonWildCard _) = char '_' - -pprHsForAll :: (OutputableBndrId name) - => [LHsTyVarBndr name] -> LHsContext name -> SDoc -pprHsForAll = pprHsForAllExtra Nothing - --- | Version of 'pprHsForAll' that can also print an extra-constraints --- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This --- underscore will be printed when the 'Maybe SrcSpan' argument is a 'Just' --- containing the location of the extra-constraints wildcard. A special --- function for this is needed, as the extra-constraints wildcard is removed --- from the actual context and type, and stored in a separate field, thus just --- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: (OutputableBndrId name) - => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name - -> SDoc -pprHsForAllExtra extra qtvs cxt - = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt) - where - show_extra = isJust extra - -pprHsForAllTvs :: (OutputableBndrId name) => [LHsTyVarBndr name] -> SDoc -pprHsForAllTvs qtvs = sdocWithPprDebug $ \debug -> - ppWhen (debug || not (null qtvs)) $ forAllLit <+> interppSP qtvs <> dot - -pprHsContext :: (OutputableBndrId name) => HsContext name -> SDoc -pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe - -pprHsContextNoArrow :: (OutputableBndrId name) => HsContext name -> SDoc -pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe - -pprHsContextMaybe :: (OutputableBndrId name) => HsContext name -> Maybe SDoc -pprHsContextMaybe [] = Nothing -pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred -pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) - --- For use in a HsQualTy, which always gets printed if it exists. -pprHsContextAlways :: (OutputableBndrId name) => HsContext name -> SDoc -pprHsContextAlways [] = parens empty <+> darrow -pprHsContextAlways [L _ ty] = ppr_mono_ty FunPrec ty <+> darrow -pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow - --- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ -pprHsContextExtra :: (OutputableBndrId name) => Bool -> HsContext name -> SDoc -pprHsContextExtra show_extra ctxt - | not show_extra - = pprHsContext ctxt - | null ctxt - = char '_' <+> darrow - | otherwise - = parens (sep (punctuate comma ctxt')) <+> darrow - where - ctxt' = map ppr ctxt ++ [char '_'] - -pprConDeclFields :: (OutputableBndrId name) => [LConDeclField name] -> SDoc -pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) - where - ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, - cd_fld_doc = doc })) - = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc - ppr_names [n] = ppr n - ppr_names ns = sep (punctuate comma (map ppr ns)) - -{- -Note [Printing KindedTyVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Trac #3830 reminded me that we should really only print the kind -signature on a KindedTyVar if the kind signature was put there by the -programmer. During kind inference GHC now adds a PostTcKind to UserTyVars, -rather than converting to KindedTyVars as before. - -(As it happens, the message in #3830 comes out a different way now, -and the problem doesn't show up; but having the flag on a KindedTyVar -seems like the Right Thing anyway.) --} - --- Printing works more-or-less as for Types - -pprHsType, pprParendHsType :: (OutputableBndrId name) => HsType name -> SDoc - -pprHsType ty = ppr_mono_ty TopPrec ty -pprParendHsType ty = ppr_mono_ty TyConPrec ty - -ppr_mono_lty :: (OutputableBndrId name) => TyPrec -> LHsType name -> SDoc -ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) - -ppr_mono_ty :: (OutputableBndrId name) => TyPrec -> HsType name -> SDoc -ppr_mono_ty ctxt_prec (HsForAllTy { hst_bndrs = tvs, hst_body = ty }) - = maybeParen ctxt_prec FunPrec $ - sep [pprHsForAllTvs tvs, ppr_mono_lty TopPrec ty] - -ppr_mono_ty _ctxt_prec (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty }) - = sep [pprHsContextAlways ctxt, ppr_mono_lty TopPrec ty] - -ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty -ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds -ppr_mono_ty _ (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name -ppr_mono_ty _ (HsTyVar Promoted (L _ name)) - = space <> quote (pprPrefixOcc name) - -- We need a space before the ' above, so the parser - -- does not attach it to the previous symbol -ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2 -ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys) - where std_con = case con of - HsUnboxedTuple -> UnboxedTuple - _ -> BoxedTuple -ppr_mono_ty _ (HsSumTy tys) = tupleParens UnboxedTuple (pprWithBars ppr tys) -ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty TopPrec ty <+> dcolon <+> ppr kind) -ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty TopPrec ty) -ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty) -ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty) -ppr_mono_ty _ (HsSpliceTy s _) = pprSplice s -ppr_mono_ty _ (HsCoreTy ty) = ppr ty -ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) - = quote $ brackets (interpp'SP tys) -ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) - = brackets (interpp'SP tys) -ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys) -ppr_mono_ty _ (HsTyLit t) = ppr_tylit t -ppr_mono_ty _ (HsWildCardTy {}) = char '_' - -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) - = maybeParen ctxt_prec TyOpPrec $ - ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2 - -ppr_mono_ty _ctxt_prec (HsAppsTy tys) - = hsep (map (ppr_app_ty TopPrec . unLoc) tys) - -ppr_mono_ty _ctxt_prec (HsAppTy fun_ty arg_ty) - = hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty] - -ppr_mono_ty ctxt_prec (HsOpTy ty1 (L _ op) ty2) - = maybeParen ctxt_prec TyOpPrec $ - sep [ ppr_mono_lty TyOpPrec ty1 - , sep [pprInfixOcc op, ppr_mono_lty TyOpPrec ty2 ] ] - -ppr_mono_ty _ (HsParTy ty) - = parens (ppr_mono_lty TopPrec ty) - -- Put the parens in where the user did - -- But we still use the precedence stuff to add parens because - -- toHsType doesn't put in any HsParTys, so we may still need them - -ppr_mono_ty ctxt_prec (HsDocTy ty doc) - = maybeParen ctxt_prec TyOpPrec $ - ppr_mono_lty TyOpPrec ty <+> ppr (unLoc doc) - -- we pretty print Haddock comments on types as if they were - -- postfix operators - --------------------------- -ppr_fun_ty :: (OutputableBndrId name) - => TyPrec -> LHsType name -> LHsType name -> SDoc -ppr_fun_ty ctxt_prec ty1 ty2 - = let p1 = ppr_mono_lty FunPrec ty1 - p2 = ppr_mono_lty TopPrec ty2 - in - maybeParen ctxt_prec FunPrec $ - sep [p1, text "->" <+> p2] - --------------------------- -ppr_app_ty :: (OutputableBndrId name) => TyPrec -> HsAppType name -> SDoc -ppr_app_ty _ (HsAppInfix (L _ n)) = pprInfixOcc n -ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n)))) - = pprPrefixOcc n -ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar Promoted (L _ n)))) - = space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so - -- the parser does not attach it to the - -- previous symbol -ppr_app_ty ctxt (HsAppPrefix ty) = ppr_mono_lty ctxt ty - --------------------------- -ppr_tylit :: HsTyLit -> SDoc -ppr_tylit (HsNumTy _ i) = integer i -ppr_tylit (HsStrTy _ s) = text (show s) diff --git a/hsSyn/HsUtils.hs b/hsSyn/HsUtils.hs deleted file mode 100644 --- a/hsSyn/HsUtils.hs +++ /dev/null @@ -1,1251 +0,0 @@ -{- -(c) The University of Glasgow, 1992-2006 - - -Here we collect a variety of helper functions that construct or -analyse HsSyn. All these functions deal with generic HsSyn; functions -which deal with the instantiated versions are located elsewhere: - - Parameterised by Module - ---------------- ------------- - RdrName parser/RdrHsSyn - Name rename/RnHsSyn - Id typecheck/TcHsSyn --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -module HsUtils( - -- Terms - mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsCaseAlt, - mkSimpleMatch, unguardedGRHSs, unguardedRHS, - mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, - mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, - mkHsDictLet, mkHsLams, - mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, - mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, - - nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon, - nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, - nlHsIntLit, nlHsVarApps, - nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, - mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - typeToLHsType, - - -- * Constructing general big tuples - -- $big_tuples - mkChunkified, chunkify, - - -- Bindings - mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, - mkPatSynBind, - isInfixFunBind, - - -- Literals - mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, - - -- Patterns - mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, - nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, - nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat, - mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, - - -- Types - mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs, - mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv, - nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp, - - -- Stmts - mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt, - mkLastStmt, - emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, - emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, - - -- Template Haskell - mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice, - mkHsQuasiQuote, unqualQuasiQuote, - - -- Flags - noRebindableInfo, - - -- Collecting binders - isUnliftedHsBind, isBangedBind, - - collectLocalBinders, collectHsValBinders, collectHsBindListBinders, - collectHsIdBinders, - collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, - collectPatBinders, collectPatsBinders, - collectLStmtsBinders, collectStmtsBinders, - collectLStmtBinders, collectStmtBinders, - - hsLTyClDeclBinders, hsTyClForeignBinders, - hsPatSynSelectors, getPatSynBinds, - hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, - hsDataDefnBinders, - - -- Collecting implicit binders - lStmtsImplicits, hsValBindsImplicits, lPatImplicits - ) where - -#include "HsVersions.h" - -import HsDecls -import HsBinds -import HsExpr -import HsPat -import HsTypes -import HsLit -import PlaceHolder - -import TcEvidence -import RdrName -import Var -import TyCoRep -import Type ( filterOutInvisibleTypes ) -import TysWiredIn ( unitTy ) -import TcType -import DataCon -import ConLike -import Id -import Name -import NameSet -import NameEnv -import BasicTypes -import SrcLoc -import FastString -import Util -import Bag -import Outputable -import Constants - -import Data.Either -import Data.Function -import Data.List - -{- -************************************************************************ -* * - Some useful helpers for constructing syntax -* * -************************************************************************ - -These functions attempt to construct a not-completely-useless SrcSpan -from their components, compared with the nl* functions below which -just attach noSrcSpan to everything. --} - -mkHsPar :: LHsExpr id -> LHsExpr id -mkHsPar e = L (getLoc e) (HsPar e) - -mkSimpleMatch :: HsMatchContext (NameOrRdrName id) - -> [LPat id] -> Located (body id) - -> LMatch id (Located (body id)) -mkSimpleMatch ctxt pats rhs - = L loc $ - Match ctxt pats Nothing (unguardedGRHSs rhs) - where - loc = case pats of - [] -> getLoc rhs - (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) - -unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id)) -unguardedGRHSs rhs@(L loc _) - = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds) - -unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))] -unguardedRHS loc rhs = [L loc (GRHS [] rhs)] - -mkMatchGroup :: (PostTc name Type ~ PlaceHolder) - => Origin -> [LMatch name (Located (body name))] - -> MatchGroup name (Located (body name)) -mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches - , mg_arg_tys = [] - , mg_res_ty = placeHolderType - , mg_origin = origin } - -mkLocatedList :: [Located a] -> Located [Located a] -mkLocatedList [] = noLoc [] -mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms - -mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name -mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) - -mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name -mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t) - -mkHsAppTypeOut :: LHsExpr Id -> LHsWcType Name -> LHsExpr Id -mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t) - -mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName -mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) - where - matches = mkMatchGroup Generated - [mkSimpleMatch LambdaExpr pats body] - -mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id -mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars - <.> mkWpLams dicts) expr - --- |A simple case alternative with a single pattern, no binds, no guards; --- pre-typechecking -mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) -mkHsCaseAlt pat expr - = mkSimpleMatch CaseAlt [pat] expr - -nlHsTyApp :: name -> [Type] -> LHsExpr name -nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id))) - -nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name -nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs - ---------- Adding parens --------- -mkLHsPar :: LHsExpr name -> LHsExpr name --- Wrap in parens if hsExprNeedsParens says it needs them --- So 'f x' becomes '(f x)', but '3' stays as '3' -mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le) - | otherwise = le - -mkParPat :: LPat name -> LPat name -mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp) - | otherwise = lp - -nlParPat :: LPat name -> LPat name -nlParPat p = noLoc (ParPat p) - -------------------------------- --- These are the bits of syntax that contain rebindable names --- See RnEnv.lookupSyntaxName - -mkHsIntegral :: SourceText -> Integer -> PostTc RdrName Type - -> HsOverLit RdrName -mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName -mkHsIsString :: SourceText -> FastString -> PostTc RdrName Type - -> HsOverLit RdrName -mkHsDo :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName -mkHsComp :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName - -> HsExpr RdrName - -mkNPat :: Located (HsOverLit RdrName) -> Maybe (SyntaxExpr RdrName) -> Pat RdrName -mkNPlusKPat :: Located RdrName -> Located (HsOverLit RdrName) -> Pat RdrName - -mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) -mkBodyStmt :: Located (bodyR RdrName) - -> StmtLR idL RdrName (Located (bodyR RdrName)) -mkBindStmt :: (PostTc idR Type ~ PlaceHolder) - => LPat idL -> Located (bodyR idR) - -> StmtLR idL idR (Located (bodyR idR)) -mkTcBindStmt :: LPat Id -> Located (bodyR Id) -> StmtLR Id Id (Located (bodyR Id)) - -emptyRecStmt :: StmtLR idL RdrName bodyR -emptyRecStmtName :: StmtLR Name Name bodyR -emptyRecStmtId :: StmtLR Id Id bodyR -mkRecStmt :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR - - -mkHsIntegral src i = OverLit (HsIntegral src i) noRebindableInfo noExpr -mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noExpr -mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noExpr - -noRebindableInfo :: PlaceHolder -noRebindableInfo = PlaceHolder -- Just another placeholder; - -mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType -mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) - where - last_stmt = L (getLoc expr) $ mkLastStmt expr - -mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id -mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b - -mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType -mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType - -mkTransformStmt :: (PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) -mkTransformByStmt :: (PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) -mkGroupUsingStmt :: (PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) -mkGroupByUsingStmt :: (PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) - -emptyTransStmt :: (PostTc idR Type ~ PlaceHolder) => StmtLR idL idR (LHsExpr idR) -emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" - , trS_stmts = [], trS_bndrs = [] - , trS_by = Nothing, trS_using = noLoc noExpr - , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr - , trS_bind_arg_ty = PlaceHolder - , trS_fmap = noExpr } -mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } -mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } -mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } -mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } - -mkLastStmt body = LastStmt body False noSyntaxExpr -mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType -mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder -mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy - -- don't use placeHolderTypeTc above, because that panics during zonking - -emptyRecStmt' :: forall idL idR body. - PostTc idR Type -> StmtLR idL idR body -emptyRecStmt' tyVal = - RecStmt - { recS_stmts = [], recS_later_ids = [] - , recS_rec_ids = [] - , recS_ret_fn = noSyntaxExpr - , recS_mfix_fn = noSyntaxExpr - , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal - , recS_later_rets = [] - , recS_rec_rets = [], recS_ret_ty = tyVal } - -emptyRecStmt = emptyRecStmt' placeHolderType -emptyRecStmtName = emptyRecStmt' placeHolderType -emptyRecStmtId = emptyRecStmt' unitTy -- a panic might trigger during zonking -mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } - -------------------------------- ---- A useful function for building @OpApps@. The operator is always a --- variable, and we don't know the fixity yet. -mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id -mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op))) - (error "mkOpApp:fixity") e2 - -unqualSplice :: RdrName -unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) - -mkUntypedSplice :: SpliceDecoration -> LHsExpr RdrName -> HsSplice RdrName -mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e - -mkHsSpliceE :: SpliceDecoration -> LHsExpr RdrName -> HsExpr RdrName -mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e) - -mkHsSpliceTE :: SpliceDecoration -> LHsExpr RdrName -> HsExpr RdrName -mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e) - -mkHsSpliceTy :: SpliceDecoration -> LHsExpr RdrName -> HsType RdrName -mkHsSpliceTy hasParen e - = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind - -mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName -mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote - -unqualQuasiQuote :: RdrName -unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) - -- A name (uniquified later) to - -- identify the quasi-quote - -mkHsString :: String -> HsLit -mkHsString s = HsString NoSourceText (mkFastString s) - -mkHsStringPrimLit :: FastString -> HsLit -mkHsStringPrimLit fs - = HsStringPrim NoSourceText (fastStringToByteString fs) - -------------- -userHsLTyVarBndrs :: SrcSpan -> [Located name] -> [LHsTyVarBndr name] --- Caller sets location -userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] - -userHsTyVarBndrs :: SrcSpan -> [name] -> [LHsTyVarBndr name] --- Caller sets location -userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] - - -{- -************************************************************************ -* * - Constructing syntax with no location info -* * -************************************************************************ --} - -nlHsVar :: id -> LHsExpr id -nlHsVar n = noLoc (HsVar (noLoc n)) - --- NB: Only for LHsExpr **Id** -nlHsDataCon :: DataCon -> LHsExpr Id -nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con)) - -nlHsLit :: HsLit -> LHsExpr id -nlHsLit n = noLoc (HsLit n) - -nlVarPat :: id -> LPat id -nlVarPat n = noLoc (VarPat (noLoc n)) - -nlLitPat :: HsLit -> LPat id -nlLitPat l = noLoc (LitPat l) - -nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id -nlHsApp f x = noLoc (HsApp f (mkLHsPar x)) - -nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id -nlHsSyntaxApps (SyntaxExpr { syn_expr = fun - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) args - | [] <- arg_wraps -- in the noSyntaxExpr case - = ASSERT( isIdHsWrapper res_wrap ) - foldl nlHsApp (noLoc fun) args - - | otherwise - = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" - mkLHsWrap arg_wraps args)) - -nlHsIntLit :: Integer -> LHsExpr id -nlHsIntLit n = noLoc (HsLit (HsInt NoSourceText n)) - -nlHsApps :: id -> [LHsExpr id] -> LHsExpr id -nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs - -nlHsVarApps :: id -> [id] -> LHsExpr id -nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs)) - where - mk f a = HsApp (noLoc f) (noLoc a) - -nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName -nlConVarPat con vars = nlConPat con (map nlVarPat vars) - -nlConVarPatName :: Name -> [Name] -> LPat Name -nlConVarPatName con vars = nlConPatName con (map nlVarPat vars) - -nlInfixConPat :: id -> LPat id -> LPat id -> LPat id -nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r)) - -nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName -nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats)) - -nlConPatName :: Name -> [LPat Name] -> LPat Name -nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats)) - -nlNullaryConPat :: id -> LPat id -nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) - -nlWildConPat :: DataCon -> LPat RdrName -nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) - (PrefixCon (nOfThem (dataConSourceArity con) - nlWildPat))) - -nlWildPat :: LPat RdrName -nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking - -nlWildPatName :: LPat Name -nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking - -nlWildPatId :: LPat Id -nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking - -nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)] - -> LHsExpr RdrName -nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) - -nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id -nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) - -nlHsLam :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName -nlHsPar :: LHsExpr id -> LHsExpr id -nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id -nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)] - -> LHsExpr RdrName -nlList :: [LHsExpr RdrName] -> LHsExpr RdrName - -nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match])) -nlHsPar e = noLoc (HsPar e) - --- Note [Rebindable nlHsIf] --- nlHsIf should generate if-expressions which are NOT subject to --- RebindableSyntax, so the first field of HsIf is Nothing. (#12080) -nlHsIf cond true false = noLoc (HsIf Nothing cond true false) - -nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches)) -nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) - -nlHsAppTy :: LHsType name -> LHsType name -> LHsType name -nlHsTyVar :: name -> LHsType name -nlHsFunTy :: LHsType name -> LHsType name -> LHsType name -nlHsParTy :: LHsType name -> LHsType name - -nlHsAppTy f t = noLoc (HsAppTy f t) -nlHsTyVar x = noLoc (HsTyVar NotPromoted (noLoc x)) -nlHsFunTy a b = noLoc (HsFunTy a b) -nlHsParTy t = noLoc (HsParTy t) - -nlHsTyConApp :: name -> [LHsType name] -> LHsType name -nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys - -{- -Tuples. All these functions are *pre-typechecker* because they lack -types on the tuple. --} - -mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a --- Makes a pre-typechecker boxed tuple, deals with 1 case -mkLHsTupleExpr [e] = e -mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed - -mkLHsVarTuple :: [a] -> LHsExpr a -mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) - -nlTuplePat :: [LPat id] -> Boxity -> LPat id -nlTuplePat pats box = noLoc (TuplePat pats box []) - -missingTupArg :: HsTupArg RdrName -missingTupArg = Missing placeHolderType - -mkLHsPatTup :: [LPat id] -> LPat id -mkLHsPatTup [] = noLoc $ TuplePat [] Boxed [] -mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed [] - --- The Big equivalents for the source tuple expressions -mkBigLHsVarTup :: [id] -> LHsExpr id -mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) - -mkBigLHsTup :: [LHsExpr id] -> LHsExpr id -mkBigLHsTup = mkChunkified mkLHsTupleExpr - --- The Big equivalents for the source tuple patterns -mkBigLHsVarPatTup :: [id] -> LPat id -mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) - -mkBigLHsPatTup :: [LPat id] -> LPat id -mkBigLHsPatTup = mkChunkified mkLHsPatTup - --- $big_tuples --- #big_tuples# --- --- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but --- we might concievably want to build such a massive tuple as part of the --- output of a desugaring stage (notably that for list comprehensions). --- --- We call tuples above this size \"big tuples\", and emulate them by --- creating and pattern matching on >nested< tuples that are expressible --- by GHC. --- --- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) --- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any --- construction to be big. --- --- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector' --- and 'mkTupleCase' functions to do all your work with tuples you should be --- fine, and not have to worry about the arity limitation at all. - --- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon -mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' - -> [a] -- ^ Possible \"big\" list of things to construct from - -> a -- ^ Constructed thing made possible by recursive decomposition -mkChunkified small_tuple as = mk_big_tuple (chunkify as) - where - -- Each sub-list is short enough to fit in a tuple - mk_big_tuple [as] = small_tuple as - mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) - -chunkify :: [a] -> [[a]] --- ^ Split a list into lists that are small enough to have a corresponding --- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' --- But there may be more than 'mAX_TUPLE_SIZE' sub-lists -chunkify xs - | n_xs <= mAX_TUPLE_SIZE = [xs] - | otherwise = split xs - where - n_xs = length xs - split [] = [] - split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) - -{- -************************************************************************ -* * - LHsSigType and LHsSigWcType -* * -********************************************************************* -} - -mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName -mkLHsSigType ty = mkHsImplicitBndrs ty - -mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName -mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty) - -mkHsSigEnv :: forall a. (LSig Name -> Maybe ([Located Name], a)) - -> [LSig Name] - -> NameEnv a -mkHsSigEnv get_info sigs - = mkNameEnv (mk_pairs ordinary_sigs) - `extendNameEnvList` (mk_pairs gen_dm_sigs) - -- The subtlety is this: in a class decl with a - -- default-method signature as well as a method signature - -- we want the latter to win (Trac #12533) - -- class C x where - -- op :: forall a . x a -> x a - -- default op :: forall b . x b -> x b - -- op x = ...(e :: b -> b)... - -- The scoped type variables of the 'default op', namely 'b', - -- scope over the code for op. The 'forall a' does not! - -- This applies both in the renamer and typechecker, both - -- of which use this function - where - (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs - is_gen_dm_sig (L _ (ClassOpSig True _ _)) = True - is_gen_dm_sig _ = False - - mk_pairs :: [LSig Name] -> [(Name, a)] - mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs - , L _ n <- ns ] - -mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName] --- Convert TypeSig to ClassOpSig --- The former is what is parsed, but the latter is --- what we need in class/instance declarations -mkClassOpSigs sigs - = map fiddle sigs - where - fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty)) - fiddle sig = sig - -typeToLHsType :: Type -> LHsType RdrName --- ^ Converting a Type to an HsType RdrName --- This is needed to implement GeneralizedNewtypeDeriving. --- --- Note that we use 'getRdrName' extensively, which --- generates Exact RdrNames rather than strings. -typeToLHsType ty - = go ty - where - go :: Type -> LHsType RdrName - go ty@(FunTy arg _) - | isPredTy arg - , (theta, tau) <- tcSplitPhiTy ty - = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) - , hst_body = go tau }) - go (FunTy arg res) = nlHsFunTy (go arg) (go res) - go ty@(ForAllTy {}) - | (tvs, tau) <- tcSplitForAllTys ty - = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs - , hst_body = go tau }) - go (TyVarTy tv) = nlHsTyVar (getRdrName tv) - go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) - go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy NoSourceText n) - go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy NoSourceText s) - go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args') - where - args' = filterOutInvisibleTypes tc args - go (CastTy ty _) = go ty - go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co) - - -- Source-language types have _invisible_ kind arguments, - -- so we must remove them here (Trac #8563) - - go_tv :: TyVar -> LHsTyVarBndr RdrName - go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv)) - (go (tyVarKind tv)) - - -{- ********************************************************************* -* * - --------- HsWrappers: type args, dict args, casts --------- -* * -********************************************************************* -} - -mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id -mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) - -mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id -mkHsWrap co_fn e | isIdHsWrapper co_fn = e - | otherwise = HsWrap co_fn e - -mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b - -> HsExpr id -> HsExpr id -mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e - -mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b - -> HsExpr id -> HsExpr id -mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e - -mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id -mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) - -mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id -mkHsCmdWrap w cmd | isIdHsWrapper w = cmd - | otherwise = HsCmdWrap w cmd - -mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id -mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) - -mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id -mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p - | otherwise = CoPat co_fn p ty - -mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id -mkHsWrapPatCo co pat ty | isTcReflCo co = pat - | otherwise = CoPat (mkWpCastN co) pat ty - -mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id -mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr - -{- -l -************************************************************************ -* * - Bindings; with a location at the top -* * -************************************************************************ --} - -mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] - -> HsBind RdrName --- Not infix, with place holders for coercion and free vars -mkFunBind fn ms = FunBind { fun_id = fn - , fun_matches = mkMatchGroup Generated ms - , fun_co_fn = idHsWrapper - , bind_fvs = placeHolderNames - , fun_tick = [] } - -mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)] - -> HsBind Name --- In Name-land, with empty bind_fvs -mkTopFunBind origin fn ms = FunBind { fun_id = fn - , fun_matches = mkMatchGroup origin ms - , fun_co_fn = idHsWrapper - , bind_fvs = emptyNameSet -- NB: closed - -- binding - , fun_tick = [] } - -mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName -mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs - -mkVarBind :: id -> LHsExpr id -> LHsBind id -mkVarBind var rhs = L (getLoc rhs) $ - VarBind { var_id = var, var_rhs = rhs, var_inline = False } - -mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) - -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName -mkPatSynBind name details lpat dir = PatSynBind psb - where - psb = PSB{ psb_id = name - , psb_args = details - , psb_def = lpat - , psb_dir = dir - , psb_fvs = placeHolderNames } - --- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is --- considered infix. -isInfixFunBind :: HsBindLR id1 id2 -> Bool -isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _) - = any (isInfixMatch . unLoc) (unLoc matches) -isInfixFunBind _ = False - - ------------- -mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] - -> LHsExpr RdrName -> LHsBind RdrName -mk_easy_FunBind loc fun pats expr - = L loc $ mkFunBind (L loc fun) - [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr - (noLoc emptyLocalBinds)] - --- | Make a prefix, non-strict function 'HsMatchContext' -mkPrefixFunRhs :: Located id -> HsMatchContext id -mkPrefixFunRhs n = FunRhs n Prefix NoSrcStrict - ------------- -mkMatch :: HsMatchContext (NameOrRdrName id) -> [LPat id] -> LHsExpr id - -> Located (HsLocalBinds id) -> LMatch id (LHsExpr id) -mkMatch ctxt pats expr lbinds - = noLoc (Match ctxt (map paren pats) Nothing - (GRHSs (unguardedRHS noSrcSpan expr) lbinds)) - where - paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) - | otherwise = lp - -{- -************************************************************************ -* * - Collecting binders -* * -************************************************************************ - -Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg. - -... -where - (x, y) = ... - f i j = ... - [a, b] = ... - -it should return [x, y, f, a, b] (remember, order important). - -Note [Collect binders only after renaming] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These functions should only be used on HsSyn *after* the renamer, -to return a [Name] or [Id]. Before renaming the record punning -and wild-card mechanism makes it hard to know what is bound. -So these functions should not be applied to (HsSyn RdrName) - -Note [Unlifted id check in isHsUnliftedBind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose there is a binding with the type (Num a => (# a, a #)). Is this a -strict binding that should be disallowed at the top level? At first glance, -no, because it's a function. But consider how this is desugared via -AbsBinds: - - -- x :: Num a => (# a, a #) - x = (# 3, 4 #) - -becomes - - x = \ $dictNum -> - let x_mono = (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) in - x_mono - -Note that the inner let is strict. And thus if we have a bunch of mutually -recursive bindings of this form, we could end up in trouble. This was shown -up in #9140. - -But if there is a type signature on x, everything changes because of the -desugaring used by AbsBindsSig: - - x :: Num a => (# a, a #) - x = (# 3, 4 #) - -becomes - - x = \ $dictNum -> (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) - -No strictness anymore! The bottom line here is that, for inferred types, we -care about the strictness of the type after the =>. For checked types -(AbsBindsSig), we care about the overall strictness. - -This matters. If we don't separate out the AbsBindsSig case, then GHC runs into -a problem when compiling - - undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a - -Looking only after the =>, we cannot tell if this is strict or not. (GHC panics -if you try.) Looking at the whole type, on the other hand, tells you that this -is a lifted function type, with no trouble at all. - --} - ------------------ Bindings -------------------------- - --- | Should we treat this as an unlifted bind? This will be true for any --- bind that binds an unlifted variable, but we must be careful around --- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage --- information, see Note [Strict binds check] is DsBinds. -isUnliftedHsBind :: HsBind Id -> Bool -- works only over typechecked binds -isUnliftedHsBind (AbsBindsSig { abs_sig_export = id }) - = isUnliftedType (idType id) -isUnliftedHsBind bind - = any is_unlifted_id (collectHsBindBinders bind) - where - is_unlifted_id id - = case tcSplitSigmaTy (idType id) of - (_, _, tau) -> isUnliftedType tau - -- For the is_unlifted check, we need to look inside polymorphism - -- and overloading. E.g. x = (# 1, True #) - -- would get type forall a. Num a => (# a, Bool #) - -- and we want to reject that. See Trac #9140 - --- | Is a binding a strict variable bind (e.g. @!x = ...@)? -isBangedBind :: HsBind Id -> Bool -isBangedBind b | isBangedPatBind b = True -isBangedBind (FunBind {fun_matches = matches}) - | [L _ match] <- unLoc $ mg_alts matches - , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match - = True -isBangedBind _ = False - -collectLocalBinders :: HsLocalBindsLR idL idR -> [idL] -collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds - -- No pattern synonyms here -collectLocalBinders (HsIPBinds _) = [] -collectLocalBinders EmptyLocalBinds = [] - -collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL] --- Collect Id binders only, or Ids + pattern synonyms, respectively -collectHsIdBinders = collect_hs_val_binders True -collectHsValBinders = collect_hs_val_binders False - -collectHsBindBinders :: HsBindLR idL idR -> [idL] --- Collect both Ids and pattern-synonym binders -collectHsBindBinders b = collect_bind False b [] - -collectHsBindsBinders :: LHsBindsLR idL idR -> [idL] -collectHsBindsBinders binds = collect_binds False binds [] - -collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL] --- Same as collectHsBindsBinders, but works over a list of bindings -collectHsBindListBinders = foldr (collect_bind False . unLoc) [] - -collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL] -collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds [] -collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds - -collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id] -collect_out_binds ps = foldr (collect_binds ps . snd) [] - -collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL] --- Collect Ids, or Ids + pattern synonyms, depending on boolean flag -collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds - -collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL] -collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc -collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc -collect_bind _ (VarBind { var_id = f }) acc = f : acc -collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc - -- I don't think we want the binders from the abe_binds - -- The only time we collect binders from a typechecked - -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc -collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc - | omitPatSyn = acc - | otherwise = ps : acc - -collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName] --- Used exclusively for the bindings of an instance decl which are all FunBinds -collectMethodBinders binds = foldrBag (get . unLoc) [] binds - where - get (FunBind { fun_id = f }) fs = f : fs - get _ fs = fs - -- Someone else complains about non-FunBinds - ------------------ Statements -------------------------- -collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL] -collectLStmtsBinders = concatMap collectLStmtBinders - -collectStmtsBinders :: [StmtLR idL idR body] -> [idL] -collectStmtsBinders = concatMap collectStmtBinders - -collectLStmtBinders :: LStmtLR idL idR body -> [idL] -collectLStmtBinders = collectStmtBinders . unLoc - -collectStmtBinders :: StmtLR idL idR body -> [idL] - -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat -collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds -collectStmtBinders (BodyStmt {}) = [] -collectStmtBinders (LastStmt {}) = [] -collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders - $ [s | ParStmtBlock ss _ _ <- xs, s <- ss] -collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts -collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss -collectStmtBinders ApplicativeStmt{} = [] - - ------------------ Patterns -------------------------- -collectPatBinders :: LPat a -> [a] -collectPatBinders pat = collect_lpat pat [] - -collectPatsBinders :: [LPat a] -> [a] -collectPatsBinders pats = foldr collect_lpat [] pats - -------------- -collect_lpat :: LPat name -> [name] -> [name] -collect_lpat (L _ pat) bndrs - = go pat - where - go (VarPat (L _ var)) = var : bndrs - go (WildPat _) = bndrs - go (LazyPat pat) = collect_lpat pat bndrs - go (BangPat pat) = collect_lpat pat bndrs - go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs - go (ViewPat _ pat _) = collect_lpat pat bndrs - go (ParPat pat) = collect_lpat pat bndrs - - go (ListPat pats _ _) = foldr collect_lpat bndrs pats - go (PArrPat pats _) = foldr collect_lpat bndrs pats - go (TuplePat pats _ _) = foldr collect_lpat bndrs pats - go (SumPat pat _ _ _) = collect_lpat pat bndrs - - go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) - go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) - -- See Note [Dictionary binders in ConPatOut] - go (LitPat _) = bndrs - go (NPat {}) = bndrs - go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs - - go (SigPatIn pat _) = collect_lpat pat bndrs - go (SigPatOut pat _) = collect_lpat pat bndrs - - go (SplicePat (HsSpliced _ (HsSplicedPat pat))) - = go pat - go (SplicePat _) = bndrs - go (CoPat _ pat _) = go pat - -{- -Note [Dictionary binders in ConPatOut] See also same Note in DsArrows -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do *not* gather (a) dictionary and (b) dictionary bindings as binders -of a ConPatOut pattern. For most calls it doesn't matter, because -it's pre-typechecker and there are no ConPatOuts. But it does matter -more in the desugarer; for example, DsUtils.mkSelectorBinds uses -collectPatBinders. In a lazy pattern, for example f ~(C x y) = ..., -we want to generate bindings for x,y but not for dictionaries bound by -C. (The type checker ensures they would not be used.) - -Desugaring of arrow case expressions needs these bindings (see DsArrows -and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its -own pat-binder-collector: - -Here's the problem. Consider - -data T a where - C :: Num a => a -> Int -> T a - -f ~(C (n+1) m) = (n,m) - -Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), -and *also* uses that dictionary to match the (n+1) pattern. Yet, the -variables bound by the lazy pattern are n,m, *not* the dictionary d. -So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound. --} - -hsGroupBinders :: HsGroup Name -> [Name] -hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, - hs_fords = foreign_decls }) - = collectHsValBinders val_decls - ++ hsTyClForeignBinders tycl_decls foreign_decls - -hsTyClForeignBinders :: [TyClGroup Name] - -> [LForeignDecl Name] - -> [Name] --- We need to look at instance declarations too, --- because their associated types may bind data constructors -hsTyClForeignBinders tycl_decls foreign_decls - = map unLoc (hsForeignDeclsBinders foreign_decls) - ++ getSelectorNames - (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls - `mappend` - foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) - where - getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name] - getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs - -------------------- -hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name]) --- ^ Returns all the /binding/ names of the decl. The first one is - --- guaranteed to be the name of the decl. The first component --- represents all binding names except record fields; the second --- represents field occurrences. For record fields mentioned in --- multiple constructors, the SrcLoc will be from the first occurrence. --- --- Each returned (Located name) has a SrcSpan for the /whole/ declaration. --- See Note [SrcSpan for binders] - -hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } })) - = ([L loc name], []) -hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], []) -hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name - , tcdSigs = sigs, tcdATs = ats })) - = (L loc cls_name : - [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ - [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ] - , []) -hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })) - = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn - -------------------- -hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name] --- See Note [SrcSpan for binders] -hsForeignDeclsBinders foreign_decls - = [ L decl_loc n - | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls] - - -------------------- -hsPatSynSelectors :: HsValBinds id -> [id] --- Collects record pattern-synonym selectors only; the pattern synonym --- names are collected by collectHsValBinders. -hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors" -hsPatSynSelectors (ValBindsOut binds _) - = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds - -addPatSynSelector:: LHsBind id -> [id] -> [id] -addPatSynSelector bind sels - | L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind - = map (unLoc . recordPatSynSelectorId) as ++ sels - | otherwise = sels - -getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id] -getPatSynBinds binds - = [ psb | (_, lbinds) <- binds - , L _ (PatSynBind psb) <- bagToList lbinds ] - -------------------- -hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name]) -hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })) - = foldMap (hsDataFamInstBinders . unLoc) dfis -hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) - = hsDataFamInstBinders fi -hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty - -------------------- --- the SrcLoc returned are for the whole declarations, not just the names -hsDataFamInstBinders :: DataFamInstDecl name -> ([Located name], [LFieldOcc name]) -hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn }) - = hsDataDefnBinders defn - -- There can't be repeated symbols because only data instances have binders - -------------------- --- the SrcLoc returned are for the whole declarations, not just the names -hsDataDefnBinders :: HsDataDefn name -> ([Located name], [LFieldOcc name]) -hsDataDefnBinders (HsDataDefn { dd_cons = cons }) - = hsConDeclsBinders cons - -- See Note [Binders in family instances] - -------------------- -hsConDeclsBinders :: [LConDecl name] -> ([Located name], [LFieldOcc name]) - -- See hsLTyClDeclBinders for what this does - -- The function is boringly complicated because of the records - -- And since we only have equality, we have to be a little careful -hsConDeclsBinders cons = go id cons - where go :: ([LFieldOcc name] -> [LFieldOcc name]) - -> [LConDecl name] -> ([Located name], [LFieldOcc name]) - go _ [] = ([], []) - go remSeen (r:rs) = - -- don't re-mangle the location of field names, because we don't - -- have a record of the full location of the field declaration anyway - case r of - -- remove only the first occurrence of any seen field in order to - -- avoid circumventing detection of duplicate fields (#9156) - L loc (ConDeclGADT { con_names = names - , con_type = HsIB { hsib_body = res_ty}}) -> - case tau of - L _ (HsFunTy - (L _ (HsAppsTy - [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty) - -> record_gadt flds - L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty) - -> record_gadt flds - - _other -> (map (L loc . unLoc) names ++ ns, fs) - where (ns, fs) = go remSeen rs - where - (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty - record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs) - where r' = remSeen (concatMap (cd_fld_names . unLoc) flds) - remSeen' = foldr (.) remSeen - [deleteBy ((==) `on` - unLoc . rdrNameFieldOcc . unLoc) v - | v <- r'] - (ns, fs) = go remSeen' rs - - L loc (ConDeclH98 { con_name = name - , con_details = RecCon flds }) -> - ([L loc (unLoc name)] ++ ns, r' ++ fs) - where r' = remSeen (concatMap (cd_fld_names . unLoc) - (unLoc flds)) - remSeen' - = foldr (.) remSeen - [deleteBy ((==) `on` - unLoc . rdrNameFieldOcc . unLoc) v | v <- r'] - (ns, fs) = go remSeen' rs - L loc (ConDeclH98 { con_name = name }) -> - ([L loc (unLoc name)] ++ ns, fs) - where (ns, fs) = go remSeen rs - -{- - -Note [SrcSpan for binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -When extracting the (Located RdrNme) for a binder, at least for the -main name (the TyCon of a type declaration etc), we want to give it -the @SrcSpan@ of the whole /declaration/, not just the name itself -(which is how it appears in the syntax tree). This SrcSpan (for the -entire declaration) is used as the SrcSpan for the Name that is -finally produced, and hence for error messages. (See Trac #8607.) - -Note [Binders in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a type or data family instance declaration, the type -constructor is an *occurrence* not a binding site - type instance T Int = Int -> Int -- No binders - data instance S Bool = S1 | S2 -- Binders are S1,S2 - - -************************************************************************ -* * - Collecting binders the user did not write -* * -************************************************************************ - -The job of this family of functions is to run through binding sites and find the set of all Names -that were defined "implicitly", without being explicitly written by the user. - -The main purpose is to find names introduced by record wildcards so that we can avoid -warning the user when they don't use those names (#4404) --} - -lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet -lStmtsImplicits = hs_lstmts - where - hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet - hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet - - hs_stmt :: StmtLR Name idR (Located (body idR)) -> NameSet - hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat - hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args) - where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat - do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts - hs_stmt (LetStmt binds) = hs_local_binds (unLoc binds) - hs_stmt (BodyStmt {}) = emptyNameSet - hs_stmt (LastStmt {}) = emptyNameSet - hs_stmt (ParStmt xs _ _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] - hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts - hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss - - hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds - hs_local_binds (HsIPBinds _) = emptyNameSet - hs_local_binds EmptyLocalBinds = emptyNameSet - -hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet -hsValBindsImplicits (ValBindsOut binds _) - = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds -hsValBindsImplicits (ValBindsIn binds _) - = lhsBindsImplicits binds - -lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet -lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet - where - lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat - lhs_bind _ = emptyNameSet - -lPatImplicits :: LPat Name -> NameSet -lPatImplicits = hs_lpat - where - hs_lpat (L _ pat) = hs_pat pat - - hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet - - hs_pat (LazyPat pat) = hs_lpat pat - hs_pat (BangPat pat) = hs_lpat pat - hs_pat (AsPat _ pat) = hs_lpat pat - hs_pat (ViewPat _ pat _) = hs_lpat pat - hs_pat (ParPat pat) = hs_lpat pat - hs_pat (ListPat pats _ _) = hs_lpats pats - hs_pat (PArrPat pats _) = hs_lpats pats - hs_pat (TuplePat pats _ _) = hs_lpats pats - - hs_pat (SigPatIn pat _) = hs_lpat pat - hs_pat (SigPatOut pat _) = hs_lpat pat - hs_pat (CoPat _ pat _) = hs_pat pat - - hs_pat (ConPatIn _ ps) = details ps - hs_pat (ConPatOut {pat_args=ps}) = details ps - - hs_pat _ = emptyNameSet - - details (PrefixCon ps) = hs_lpats ps - details (RecCon fs) = hs_lpats explicit `unionNameSet` mkNameSet (collectPatsBinders implicit) - where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat - | (i, fld) <- [0..] `zip` rec_flds fs - , let pat = hsRecFieldArg - (unLoc fld) - pat_explicit = maybe True (i<) (rec_dotdot fs)] - details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2 diff --git a/hsSyn/PlaceHolder.hs b/hsSyn/PlaceHolder.hs deleted file mode 100644 --- a/hsSyn/PlaceHolder.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} - -module PlaceHolder where - -import Type ( Type ) -import Outputable -import Name -import NameSet -import RdrName -import Var -import Coercion -import ConLike (ConLike) -import FieldLabel -import SrcLoc (Located) -import TcEvidence ( HsWrapper ) - -import Data.Data hiding ( Fixity ) -import BasicTypes (Fixity) - - -{- -%************************************************************************ -%* * -\subsection{Annotating the syntax} -%* * -%************************************************************************ --} - --- NB: These are intentionally open, allowing API consumers (like Haddock) --- to declare new instances - --- | used as place holder in PostTc and PostRn values -data PlaceHolder = PlaceHolder - deriving (Data) - --- | Types that are not defined until after type checking -type family PostTc id ty -- Note [Pass sensitive types] -type instance PostTc Id ty = ty -type instance PostTc Name ty = PlaceHolder -type instance PostTc RdrName ty = PlaceHolder - --- | Types that are not defined until after renaming -type family PostRn id ty -- Note [Pass sensitive types] -type instance PostRn Id ty = ty -type instance PostRn Name ty = ty -type instance PostRn RdrName ty = PlaceHolder - -placeHolderKind :: PlaceHolder -placeHolderKind = PlaceHolder - -placeHolderFixity :: PlaceHolder -placeHolderFixity = PlaceHolder - -placeHolderType :: PlaceHolder -placeHolderType = PlaceHolder - -placeHolderTypeTc :: Type -placeHolderTypeTc = panic "Evaluated the place holder for a PostTcType" - -placeHolderNames :: PlaceHolder -placeHolderNames = PlaceHolder - -placeHolderNamesTc :: NameSet -placeHolderNamesTc = emptyNameSet - -placeHolderHsWrapper :: PlaceHolder -placeHolderHsWrapper = PlaceHolder - -{- - -Note [Pass sensitive types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the same AST types are re-used through parsing,renaming and type -checking there are naturally some places in the AST that do not have -any meaningful value prior to the pass they are assigned a value. - -Historically these have been filled in with place holder values of the form - - panic "error message" - -This has meant the AST is difficult to traverse using standard generic -programming techniques. The problem is addressed by introducing -pass-specific data types, implemented as a pair of open type families, -one for PostTc and one for PostRn. These are then explicitly populated -with a PlaceHolder value when they do not yet have meaning. - -In terms of actual usage, we have the following - - PostTc id Kind - PostTc id Type - - PostRn id Fixity - PostRn id NameSet - -TcId and Var are synonyms for Id - -Unfortunately the type checker termination checking conditions fail for the -DataId constraint type based on this, so even though it is safe the -UndecidableInstances pragma is required where this is used. --} - -type DataId id = - ( DataIdPost id - , DataIdPost (NameOrRdrName id) - ) - -type DataIdPost id = - ( Data id - , Data (PostRn id NameSet) - , Data (PostRn id Fixity) - , Data (PostRn id Bool) - , Data (PostRn id Name) - , Data (PostRn id (Located Name)) - , Data (PostRn id [Name]) - - , Data (PostRn id id) - , Data (PostTc id Type) - , Data (PostTc id Coercion) - , Data (PostTc id id) - , Data (PostTc id [Type]) - , Data (PostTc id ConLike) - , Data (PostTc id [ConLike]) - , Data (PostTc id HsWrapper) - , Data (PostTc id [FieldLabel]) - ) - - --- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext', --- for printing messages related to a 'Match' -type family NameOrRdrName id where - NameOrRdrName Id = Name - NameOrRdrName Name = Name - NameOrRdrName RdrName = RdrName - --- |Constraint type to bundle up the requirement for 'OutputableBndr' on both --- the @id@ and the 'NameOrRdrName' type for it -type OutputableBndrId id = - ( OutputableBndr id - , OutputableBndr (NameOrRdrName id) - ) diff --git a/iface/BinFingerprint.hs b/iface/BinFingerprint.hs deleted file mode 100644 --- a/iface/BinFingerprint.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Computing fingerprints of values serializeable with GHC's "Binary" module. -module BinFingerprint - ( -- * Computing fingerprints - fingerprintBinMem - , computeFingerprint - , putNameLiterally - ) where - -#include "HsVersions.h" - -import Fingerprint -import Binary -import Name -import Panic -import Util - -fingerprintBinMem :: BinHandle -> IO Fingerprint -fingerprintBinMem bh = withBinBuffer bh f - where - f bs = - -- we need to take care that we force the result here - -- lest a reference to the ByteString may leak out of - -- withBinBuffer. - let fp = fingerprintByteString bs - in fp `seq` return fp - -computeFingerprint :: (Binary a) - => (BinHandle -> Name -> IO ()) - -> a - -> IO Fingerprint -computeFingerprint put_nonbinding_name a = do - bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block - put_ bh a - fp <- fingerprintBinMem bh - return fp - where - set_user_data bh = - setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS - --- | Used when we want to fingerprint a structure without depending on the --- fingerprints of external Names that it refers to. -putNameLiterally :: BinHandle -> Name -> IO () -putNameLiterally bh name = ASSERT( isExternalName name ) do - put_ bh $! nameModule name - put_ bh $! nameOccName name diff --git a/iface/BinIface.hs b/iface/BinIface.hs deleted file mode 100644 --- a/iface/BinIface.hs +++ /dev/null @@ -1,390 +0,0 @@ -{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables #-} - --- --- (c) The University of Glasgow 2002-2006 --- - -{-# OPTIONS_GHC -O #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- | Binary interface file support. -module BinIface ( - writeBinIface, - readBinIface, - getSymtabName, - getDictFastString, - CheckHiWay(..), - TraceBinIFaceReading(..) - ) where - -#include "HsVersions.h" - -import TcRnMonad -import PrelInfo ( isKnownKeyName, lookupKnownKeyName ) -import IfaceEnv -import HscTypes -import Module -import Name -import DynFlags -import UniqFM -import UniqSupply -import Panic -import Binary -import SrcLoc -import ErrUtils -import FastMutInt -import Unique -import Outputable -import NameCache -import Platform -import FastString -import Constants -import Util - -import Data.Bits -import Data.Char -import Data.List -import Data.Word -import Data.Array -import Data.IORef -import Control.Monad - - --- --------------------------------------------------------------------------- --- Reading and writing binary interface files --- - -data CheckHiWay = CheckHiWay | IgnoreHiWay - deriving Eq - -data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading - deriving Eq - --- | Read an interface file -readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath - -> TcRnIf a b ModIface -readBinIface checkHiWay traceBinIFaceReading hi_path = do - ncu <- mkNameCacheUpdater - dflags <- getDynFlags - liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu - -readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath - -> NameCacheUpdater - -> IO ModIface -readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do - let printer :: SDoc -> IO () - printer = case traceBinIFaceReading of - TraceBinIFaceReading -> \sd -> - putLogMsg dflags - NoReason - SevOutput - noSrcSpan - (defaultDumpStyle dflags) - sd - QuietBinIFaceReading -> \_ -> return () - wantedGot :: Outputable a => String -> a -> a -> IO () - wantedGot what wanted got = - printer (text what <> text ": " <> - vcat [text "Wanted " <> ppr wanted <> text ",", - text "got " <> ppr got]) - - errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO () - errorOnMismatch what wanted got = - -- This will be caught by readIface which will emit an error - -- msg containing the iface module name. - when (wanted /= got) $ throwGhcExceptionIO $ ProgramError - (what ++ " (wanted " ++ show wanted - ++ ", got " ++ show got ++ ")") - bh <- Binary.readBinMem hi_path - - -- Read the magic number to check that this really is a GHC .hi file - -- (This magic number does not change when we change - -- GHC interface file format) - magic <- get bh - wantedGot "Magic" (binaryInterfaceMagic dflags) magic - errorOnMismatch "magic number mismatch: old/corrupt interface file?" - (binaryInterfaceMagic dflags) magic - - -- Note [dummy iface field] - -- read a dummy 32/64 bit value. This field used to hold the - -- dictionary pointer in old interface file formats, but now - -- the dictionary pointer is after the version (where it - -- should be). Also, the serialisation of value of type "Bin - -- a" used to depend on the word size of the machine, now they - -- are always 32 bits. - if wORD_SIZE dflags == 4 - then do _ <- Binary.get bh :: IO Word32; return () - else do _ <- Binary.get bh :: IO Word64; return () - - -- Check the interface file version and ways. - check_ver <- get bh - let our_ver = show hiVersion - wantedGot "Version" our_ver check_ver - errorOnMismatch "mismatched interface file versions" our_ver check_ver - - check_way <- get bh - let way_descr = getWayDescr dflags - wantedGot "Way" way_descr check_way - when (checkHiWay == CheckHiWay) $ - errorOnMismatch "mismatched interface file ways" way_descr check_way - - -- Read the dictionary - -- The next word in the file is a pointer to where the dictionary is - -- (probably at the end of the file) - dict_p <- Binary.get bh - data_p <- tellBin bh -- Remember where we are now - seekBin bh dict_p - dict <- getDictionary bh - seekBin bh data_p -- Back to where we were before - - -- Initialise the user-data field of bh - bh <- do - bh <- return $ setUserData bh $ newReadState (error "getSymtabName") - (getDictFastString dict) - symtab_p <- Binary.get bh -- Get the symtab ptr - data_p <- tellBin bh -- Remember where we are now - seekBin bh symtab_p - symtab <- getSymbolTable bh ncu - seekBin bh data_p -- Back to where we were before - - -- It is only now that we know how to get a Name - return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab) - (getDictFastString dict) - - -- Read the interface file - get bh - --- | Write an interface file -writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () -writeBinIface dflags hi_path mod_iface = do - bh <- openBinMem initBinMemSize - put_ bh (binaryInterfaceMagic dflags) - - -- dummy 32/64-bit field before the version/way for - -- compatibility with older interface file formats. - -- See Note [dummy iface field] above. - if wORD_SIZE dflags == 4 - then Binary.put_ bh (0 :: Word32) - else Binary.put_ bh (0 :: Word64) - - -- The version and way descriptor go next - put_ bh (show hiVersion) - let way_descr = getWayDescr dflags - put_ bh way_descr - - -- Remember where the dictionary pointer will go - dict_p_p <- tellBin bh - -- Placeholder for ptr to dictionary - put_ bh dict_p_p - - -- Remember where the symbol table pointer will go - symtab_p_p <- tellBin bh - put_ bh symtab_p_p - - -- Make some intial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 - symtab_map <- newIORef emptyUFM - let bin_symtab = BinSymbolTable { - bin_symtab_next = symtab_next, - bin_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt - writeFastMutInt dict_next_ref 0 - dict_map_ref <- newIORef emptyUFM - let bin_dict = BinDictionary { - bin_dict_next = dict_next_ref, - bin_dict_map = dict_map_ref } - - -- Put the main thing, - bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) - (putName bin_dict bin_symtab) - (putFastString bin_dict) - put_ bh mod_iface - - -- Write the symtab pointer at the front of the file - symtab_p <- tellBin bh -- This is where the symtab will start - putAt bh symtab_p_p symtab_p -- Fill in the placeholder - seekBin bh symtab_p -- Seek back to the end of the file - - -- Write the symbol table itself - symtab_next <- readFastMutInt symtab_next - symtab_map <- readIORef symtab_map - putSymbolTable bh symtab_next symtab_map - debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next - <+> text "Names") - - -- NB. write the dictionary after the symbol table, because - -- writing the symbol table may create more dictionary entries. - - -- Write the dictionary pointer at the fornt of the file - dict_p <- tellBin bh -- This is where the dictionary will start - putAt bh dict_p_p dict_p -- Fill in the placeholder - seekBin bh dict_p -- Seek back to the end of the file - - -- Write the dictionary itself - dict_next <- readFastMutInt dict_next_ref - dict_map <- readIORef dict_map_ref - putDictionary bh dict_next dict_map - debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next - <+> text "dict entries") - - -- And send the result to the file - writeBinMem bh hi_path - --- | Initial ram buffer to allocate for writing interface files -initBinMemSize :: Int -initBinMemSize = 1024 * 1024 - -binaryInterfaceMagic :: DynFlags -> Word32 -binaryInterfaceMagic dflags - | target32Bit (targetPlatform dflags) = 0x1face - | otherwise = 0x1face64 - - --- ----------------------------------------------------------------------------- --- The symbol table --- - -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off - let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab)) - -- It's OK to use nonDetEltsUFM here because the elements have - -- indices that array uses to create order - mapM_ (\n -> serialiseName bh n symtab) names - -getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable -getSymbolTable bh ncu = do - sz <- get bh - od_names <- sequence (replicate sz (get bh)) - updateNameCache ncu $ \namecache -> - let arr = listArray (0,sz-1) names - (namecache', names) = - mapAccumR (fromOnDiskName arr) namecache od_names - in (namecache', arr) - -type OnDiskName = (UnitId, ModuleName, OccName) - -fromOnDiskName :: Array Int Name -> NameCache -> OnDiskName -> (NameCache, Name) -fromOnDiskName _ nc (pid, mod_name, occ) = - let mod = mkModule pid mod_name - cache = nsNames nc - in case lookupOrigNameCache cache mod occ of - Just name -> (nc, name) - Nothing -> - let (uniq, us) = takeUniqFromSupply (nsUniqs nc) - name = mkExternalName uniq mod occ noSrcSpan - new_cache = extendNameCache cache mod occ name - in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) - -serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () -serialiseName bh name _ = do - let mod = ASSERT2( isExternalName name, ppr name ) nameModule name - put_ bh (moduleUnitId mod, moduleName mod, nameOccName name) - - --- Note [Symbol table representation of names] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- An occurrence of a name in an interface file is serialized as a single 32-bit --- word. The format of this word is: --- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx --- A normal name. x is an index into the symbol table --- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy --- A known-key name. x is the Unique's Char, y is the int part. We assume that --- all known-key uniques fit in this space. This is asserted by --- PrelInfo.knownKeyNamesOkay. --- --- During serialization we check for known-key things using isKnownKeyName. --- During deserialization we use lookupKnownKeyName to get from the unique back --- to its corresponding Name. - - --- See Note [Symbol table representation of names] -putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () -putName _dict BinSymbolTable{ - bin_symtab_map = symtab_map_ref, - bin_symtab_next = symtab_next } - bh name - | isKnownKeyName name - , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits - = -- ASSERT(u < 2^(22 :: Int)) - put_ bh (0x80000000 - .|. (fromIntegral (ord c) `shiftL` 22) - .|. (fromIntegral u :: Word32)) - - | otherwise - = do symtab_map <- readIORef symtab_map_ref - case lookupUFM symtab_map name of - Just (off,_) -> put_ bh (fromIntegral off :: Word32) - Nothing -> do - off <- readFastMutInt symtab_next - -- MASSERT(off < 2^(30 :: Int)) - writeFastMutInt symtab_next (off+1) - writeIORef symtab_map_ref - $! addToUFM symtab_map name (off,name) - put_ bh (fromIntegral off :: Word32) - --- See Note [Symbol table representation of names] -getSymtabName :: NameCacheUpdater - -> Dictionary -> SymbolTable - -> BinHandle -> IO Name -getSymtabName _ncu _dict symtab bh = do - i :: Word32 <- get bh - case i .&. 0xC0000000 of - 0x00000000 -> return $! symtab ! fromIntegral i - - 0x80000000 -> - let - tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) - ix = fromIntegral i .&. 0x003FFFFF - u = mkUnique tag ix - in - return $! case lookupKnownKeyName u of - Nothing -> pprPanic "getSymtabName:unknown known-key unique" - (ppr i $$ ppr (unpkUnique u)) - Just n -> n - - _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) - -data BinSymbolTable = BinSymbolTable { - bin_symtab_next :: !FastMutInt, -- The next index to use - bin_symtab_map :: !(IORef (UniqFM (Int,Name))) - -- indexed by Name - } - -putFastString :: BinDictionary -> BinHandle -> FastString -> IO () -putFastString dict bh fs = allocateFastString dict fs >>= put_ bh - -allocateFastString :: BinDictionary -> FastString -> IO Word32 -allocateFastString BinDictionary { bin_dict_next = j_r, - bin_dict_map = out_r} f = do - out <- readIORef out_r - let uniq = getUnique f - case lookupUFM out uniq of - Just (j, _) -> return (fromIntegral j :: Word32) - Nothing -> do - j <- readFastMutInt j_r - writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM out uniq (j, f) - return (fromIntegral j :: Word32) - -getDictFastString :: Dictionary -> BinHandle -> IO FastString -getDictFastString dict bh = do - j <- get bh - return $! (dict ! fromIntegral (j :: Word32)) - -data BinDictionary = BinDictionary { - bin_dict_next :: !FastMutInt, -- The next index to use - bin_dict_map :: !(IORef (UniqFM (Int,FastString))) - -- indexed by FastString - } - -getWayDescr :: DynFlags -> String -getWayDescr dflags - | platformUnregisterised (targetPlatform dflags) = 'u':tag - | otherwise = tag - where tag = buildTag dflags - -- if this is an unregisterised build, make sure our interfaces - -- can't be used by a registerised build. diff --git a/iface/BuildTyCl.hs b/iface/BuildTyCl.hs deleted file mode 100644 --- a/iface/BuildTyCl.hs +++ /dev/null @@ -1,476 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} - -module BuildTyCl ( - buildDataCon, mkDataConUnivTyVarBinders, - buildPatSyn, - TcMethInfo, buildClass, - mkNewTyConRhs, mkDataTyConRhs, - newImplicitBinder, newTyConRepName - ) where - -#include "HsVersions.h" - -import IfaceEnv -import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) -import TysWiredIn( isCTupleTyConName ) -import TysPrim ( voidPrimTy ) -import DataCon -import PatSyn -import Var -import VarSet -import BasicTypes -import Name -import MkId -import Class -import TyCon -import Type -import Id -import TcType - -import SrcLoc( SrcSpan, noSrcSpan ) -import DynFlags -import TcRnMonad -import UniqSupply -import Util -import Outputable - -mkDataTyConRhs :: [DataCon] -> AlgTyConRhs -mkDataTyConRhs cons - = DataTyCon { - data_cons = cons, - is_enum = not (null cons) && all is_enum_con cons - -- See Note [Enumeration types] in TyCon - } - where - is_enum_con con - | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) - <- dataConFullSig con - = null ex_tvs && null eq_spec && null theta && null arg_tys - - -mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs --- ^ Monadic because it makes a Name for the coercion TyCon --- We pass the Name of the parent TyCon, as well as the TyCon itself, --- because the latter is part of a knot, whereas the former is not. -mkNewTyConRhs tycon_name tycon con - = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc - ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs - ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax) - ; return (NewTyCon { data_con = con, - nt_rhs = rhs_ty, - nt_etad_rhs = (etad_tvs, etad_rhs), - nt_co = nt_ax } ) } - -- Coreview looks through newtypes with a Nothing - -- for nt_co, or uses explicit coercions otherwise - where - tvs = tyConTyVars tycon - roles = tyConRoles tycon - inst_con_ty = piResultTys (dataConUserType con) (mkTyVarTys tvs) - rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty - -- Instantiate the data con with the - -- type variables from the tycon - -- NB: a newtype DataCon has a type that must look like - -- forall tvs. -> T tvs - -- Note that we *can't* use dataConInstOrigArgTys here because - -- the newtype arising from class Foo a => Bar a where {} - -- has a single argument (Foo a) that is a *type class*, so - -- dataConInstOrigArgTys returns []. - - etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can - etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty - etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface - (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty - - eta_reduce :: [TyVar] -- Reversed - -> [Role] -- also reversed - -> Type -- Rhs type - -> ([TyVar], [Role], Type) -- Eta-reduced version - -- (tyvars in normal order) - eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty, - Just tv <- getTyVar_maybe arg, - tv == a, - not (a `elemVarSet` tyCoVarsOfType fun) - = eta_reduce as rs fun - eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty) - ------------------------------------------------------- -buildDataCon :: FamInstEnvs - -> Name - -> Bool -- Declared infix - -> TyConRepName - -> [HsSrcBang] - -> Maybe [HsImplBang] - -- See Note [Bangs on imported data constructors] in MkId - -> [FieldLabel] -- Field labels - -> [TyVarBinder] -- Universals - -> [TyVarBinder] -- Existentials - -> [EqSpec] -- Equality spec - -> ThetaType -- Does not include the "stupid theta" - -- or the GADT equalities - -> [Type] -> Type -- Argument and result types - -> TyCon -- Rep tycon - -> TcRnIf m n DataCon --- A wrapper for DataCon.mkDataCon that --- a) makes the worker Id --- b) makes the wrapper Id if necessary, including --- allocating its unique (hence monadic) --- c) Sorts out the TyVarBinders. See mkDataConUnivTyBinders -buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls - univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon - = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc - ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc - -- This last one takes the name of the data constructor in the source - -- code, which (for Haskell source anyway) will be in the DataName name - -- space, and puts it into the VarName name space - - ; traceIf (text "buildDataCon 1" <+> ppr src_name) - ; us <- newUniqueSupply - ; dflags <- getDynFlags - ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs - data_con = mkDataCon src_name declared_infix prom_info - src_bangs field_lbls - univ_tvs ex_tvs eq_spec ctxt - arg_tys res_ty NoRRI rep_tycon - stupid_ctxt dc_wrk dc_rep - dc_wrk = mkDataConWorkId work_name data_con - dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name - impl_bangs data_con) - - ; traceIf (text "buildDataCon 2" <+> ppr src_name) - ; return data_con } - - --- The stupid context for a data constructor should be limited to --- the type variables mentioned in the arg_tys --- ToDo: Or functionally dependent on? --- This whole stupid theta thing is, well, stupid. -mkDataConStupidTheta :: TyCon -> [Type] -> [TyVarBinder] -> [PredType] -mkDataConStupidTheta tycon arg_tys univ_tvs - | null stupid_theta = [] -- The common case - | otherwise = filter in_arg_tys stupid_theta - where - tc_subst = zipTvSubst (tyConTyVars tycon) - (mkTyVarTys (binderVars univ_tvs)) - stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) - -- Start by instantiating the master copy of the - -- stupid theta, taken from the TyCon - - arg_tyvars = tyCoVarsOfTypes arg_tys - in_arg_tys pred = not $ isEmptyVarSet $ - tyCoVarsOfType pred `intersectVarSet` arg_tyvars - - -mkDataConUnivTyVarBinders :: [TyConBinder] -- From the TyCon - -> [TyVarBinder] -- For the DataCon --- See Note [Building the TyBinders for a DataCon] -mkDataConUnivTyVarBinders tc_bndrs - = map mk_binder tc_bndrs - where - mk_binder (TvBndr tv tc_vis) = mkTyVarBinder vis tv - where - vis = case tc_vis of - AnonTCB -> Specified - NamedTCB Required -> Specified - NamedTCB vis -> vis - -{- Note [Building the TyBinders for a DataCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A DataCon needs to keep track of the visibility of its universals and -existentials, so that visible type application can work properly. This -is done by storing the universal and existential TyVarBinders. -See Note [TyVarBinders in DataCons] in DataCon. - -During construction of a DataCon, we often start from the TyBinders of -the parent TyCon. For example - data Maybe a = Nothing | Just a -The DataCons start from the TyBinders of the parent TyCon. - -But the ultimate TyBinders for the DataCon are *different* than those -of the DataCon. Here is an example: - - data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * - -The TyCon has - - tyConTyVars = [ k:*, a:k->*, b:k] - tyConTyBinders = [ Named (TvBndr (k :: *) Inferred), Anon (k->*), Anon k ] - -The TyBinders for App line up with App's kind, given above. - -But the DataCon MkApp has the type - MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b - -That is, its TyBinders should be - - dataConUnivTyVarBinders = [ TvBndr (k:*) Inferred - , TvBndr (a:k->*) Specified - , TvBndr (b:k) Specified ] - -So we want to take the TyCon's TyBinders and the TyCon's TyVars and -merge them, pulling - - variable names from the TyVars - - visibilities from the TyBinders - - but changing Anon/Required to Specified - -The last part about Required->Specified comes from this: - data T k (a:k) b = MkT (a b) -Here k is Required in T's kind, but we don't have Required binders in -the TyBinders for a term (see Note [No Required TyBinder in terms] -in TyCoRep), so we change it to Specified when making MkT's TyBinders - -This merging operation is done by mkDataConUnivTyBinders. In contrast, -the TyBinders passed to mkDataCon are the final TyBinders stored in the -DataCon (mkDataCon does no further work). --} - ------------------------------------------------------- -buildPatSyn :: Name -> Bool - -> (Id,Bool) -> Maybe (Id, Bool) - -> ([TyVarBinder], ThetaType) -- ^ Univ and req - -> ([TyVarBinder], ThetaType) -- ^ Ex and prov - -> [Type] -- ^ Argument types - -> Type -- ^ Result type - -> [FieldLabel] -- ^ Field labels for - -- a record pattern synonym - -> PatSyn -buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder - (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys - pat_ty field_labels - = -- The assertion checks that the matcher is - -- compatible with the pattern synonym - ASSERT2((and [ univ_tvs `equalLength` univ_tvs1 - , ex_tvs `equalLength` ex_tvs1 - , pat_ty `eqType` substTy subst pat_ty1 - , prov_theta `eqTypes` substTys subst prov_theta1 - , req_theta `eqTypes` substTys subst req_theta1 - , compareArgTys arg_tys (substTys subst arg_tys1) - ]) - , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1 - , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1 - , ppr pat_ty <+> twiddle <+> ppr pat_ty1 - , ppr prov_theta <+> twiddle <+> ppr prov_theta1 - , ppr req_theta <+> twiddle <+> ppr req_theta1 - , ppr arg_tys <+> twiddle <+> ppr arg_tys1])) - mkPatSyn src_name declared_infix - (univ_tvs, req_theta) (ex_tvs, prov_theta) - arg_tys pat_ty - matcher builder field_labels - where - ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id - ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau - (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma - (arg_tys1, _) = (tcSplitFunTys cont_tau) - twiddle = char '~' - subst = zipTvSubst (univ_tvs1 ++ ex_tvs1) - (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs))) - - -- For a nullary pattern synonym we add a single void argument to the - -- matcher to preserve laziness in the case of unlifted types. - -- See #12746 - compareArgTys :: [Type] -> [Type] -> Bool - compareArgTys [] [x] = x `eqType` voidPrimTy - compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys - - ------------------------------------------------------- -type TcMethInfo -- A temporary intermediate, to communicate - -- between tcClassSigs and buildClass. - = ( Name -- Name of the class op - , Type -- Type of the class op - , Maybe (DefMethSpec (SrcSpan, Type))) - -- Nothing => no default method - -- - -- Just VanillaDM => There is an ordinary - -- polymorphic default method - -- - -- Just (GenericDM (loc, ty)) => There is a generic default metho - -- Here is its type, and the location - -- of the type signature - -- We need that location /only/ to attach it to the - -- generic default method's Name; and we need /that/ - -- only to give the right location of an ambiguity error - -- for the generic default method, spat out by checkValidClass - -buildClass :: Name -- Name of the class/tycon (they have the same Name) - -> [TyConBinder] -- Of the tycon - -> [Role] - -> [FunDep TyVar] -- Functional dependencies - -- Super classes, associated types, method info, minimal complete def. - -- This is Nothing if the class is abstract. - -> Maybe (ThetaType, [ClassATItem], [TcMethInfo], ClassMinimalDef) - -> TcRnIf m n Class - -buildClass tycon_name binders roles fds Nothing - = fixM $ \ rec_clas -> -- Only name generation inside loop - do { traceIf (text "buildClass") - - ; tc_rep_name <- newTyConRepName tycon_name - ; let univ_bndrs = mkDataConUnivTyVarBinders binders - univ_tvs = binderVars univ_bndrs - tycon = mkClassTyCon tycon_name binders roles - AbstractTyCon rec_clas tc_rep_name - result = mkAbstractClass tycon_name univ_tvs fds tycon - ; traceIf (text "buildClass" <+> ppr tycon) - ; return result } - -buildClass tycon_name binders roles fds - (Just (sc_theta, at_items, sig_stuff, mindef)) - = fixM $ \ rec_clas -> -- Only name generation inside loop - do { traceIf (text "buildClass") - - ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc - ; tc_rep_name <- newTyConRepName tycon_name - - ; op_items <- mapM (mk_op_item rec_clas) sig_stuff - -- Build the selector id and default method id - - -- Make selectors for the superclasses - ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc) - (takeList sc_theta [fIRST_TAG..]) - ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas - | sc_name <- sc_sel_names] - -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we - -- can construct names for the selectors. Thus - -- class (C a, C b) => D a b where ... - -- gives superclass selectors - -- D_sc1, D_sc2 - -- (We used to call them D_C, but now we can have two different - -- superclasses both called C!) - - ; let use_newtype = isSingleton arg_tys - -- Use a newtype if the data constructor - -- (a) has exactly one value field - -- i.e. exactly one operation or superclass taken together - -- (b) that value is of lifted type (which they always are, because - -- we box equality superclasses) - -- See note [Class newtypes and equality predicates] - - -- We treat the dictionary superclasses as ordinary arguments. - -- That means that in the case of - -- class C a => D a - -- we don't get a newtype with no arguments! - args = sc_sel_names ++ op_names - op_tys = [ty | (_,ty,_) <- sig_stuff] - op_names = [op | (op,_,_) <- sig_stuff] - arg_tys = sc_theta ++ op_tys - rec_tycon = classTyCon rec_clas - univ_bndrs = mkDataConUnivTyVarBinders binders - univ_tvs = binderVars univ_bndrs - - ; rep_nm <- newTyConRepName datacon_name - ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") - datacon_name - False -- Not declared infix - rep_nm - (map (const no_bang) args) - (Just (map (const HsLazy) args)) - [{- No fields -}] - univ_bndrs - [{- no existentials -}] - [{- No GADT equalities -}] - [{- No theta -}] - arg_tys - (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) - rec_tycon - - ; rhs <- case () of - _ | use_newtype - -> mkNewTyConRhs tycon_name rec_tycon dict_con - | isCTupleTyConName tycon_name - -> return (TupleTyCon { data_con = dict_con - , tup_sort = ConstraintTuple }) - | otherwise - -> return (mkDataTyConRhs [dict_con]) - - ; let { tycon = mkClassTyCon tycon_name binders roles - rhs rec_clas tc_rep_name - -- A class can be recursive, and in the case of newtypes - -- this matters. For example - -- class C a where { op :: C b => a -> b -> Int } - -- Because C has only one operation, it is represented by - -- a newtype, and it should be a *recursive* newtype. - -- [If we don't make it a recursive newtype, we'll expand the - -- newtype like a synonym, but that will lead to an infinite - -- type] - - ; result = mkClass tycon_name univ_tvs fds - sc_theta sc_sel_ids at_items - op_items mindef tycon - } - ; traceIf (text "buildClass" <+> ppr tycon) - ; return result } - where - no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict - - mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem - mk_op_item rec_clas (op_name, _, dm_spec) - = do { dm_info <- mk_dm_info op_name dm_spec - ; return (mkDictSelId op_name rec_clas, dm_info) } - - mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type)) - -> TcRnIf n m (Maybe (Name, DefMethSpec Type)) - mk_dm_info _ Nothing - = return Nothing - mk_dm_info op_name (Just VanillaDM) - = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc - ; return (Just (dm_name, VanillaDM)) } - mk_dm_info op_name (Just (GenericDM (loc, dm_ty))) - = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc - ; return (Just (dm_name, GenericDM dm_ty)) } - -{- -Note [Class newtypes and equality predicates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class (a ~ F b) => C a b where - op :: a -> b - -We cannot represent this by a newtype, even though it's not -existential, because there are two value fields (the equality -predicate and op. See Trac #2238 - -Moreover, - class (a ~ F b) => C a b where {} -Here we can't use a newtype either, even though there is only -one field, because equality predicates are unboxed, and classes -are boxed. --} - -newImplicitBinder :: Name -- Base name - -> (OccName -> OccName) -- Occurrence name modifier - -> TcRnIf m n Name -- Implicit name --- Called in BuildTyCl to allocate the implicit binders of type/class decls --- For source type/class decls, this is the first occurrence --- For iface ones, the LoadIface has already allocated a suitable name in the cache -newImplicitBinder base_name mk_sys_occ - = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name) - -newImplicitBinderLoc :: Name -- Base name - -> (OccName -> OccName) -- Occurrence name modifier - -> SrcSpan - -> TcRnIf m n Name -- Implicit name --- Just the same, but lets you specify the SrcSpan -newImplicitBinderLoc base_name mk_sys_occ loc - | Just mod <- nameModule_maybe base_name - = newGlobalBinder mod occ loc - | otherwise -- When typechecking a [d| decl bracket |], - -- TH generates types, classes etc with Internal names, - -- so we follow suit for the implicit binders - = do { uniq <- newUnique - ; return (mkInternalName uniq occ loc) } - where - occ = mk_sys_occ (nameOccName base_name) - --- | Make the 'TyConRepName' for this 'TyCon' -newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName -newTyConRepName tc_name - | Just mod <- nameModule_maybe tc_name - , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name) - = newGlobalBinder mod occ noSrcSpan - | otherwise - = newImplicitBinder tc_name mkTyConRepOcc diff --git a/iface/FlagChecker.hs b/iface/FlagChecker.hs deleted file mode 100644 --- a/iface/FlagChecker.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | This module manages storing the various GHC option flags in a modules --- interface file as part of the recompilation checking infrastructure. -module FlagChecker ( - fingerprintDynFlags - ) where - -import Binary -import BinIface () -import DynFlags -import HscTypes -import Module -import Name -import Fingerprint -import BinFingerprint --- import Outputable - -import qualified Data.IntSet as IntSet -import System.FilePath (normalise) - --- | Produce a fingerprint of a @DynFlags@ value. We only base --- the finger print on important fields in @DynFlags@ so that --- the recompilation checker can use this fingerprint. --- --- NB: The 'Module' parameter is the 'Module' recorded by the --- *interface* file, not the actual 'Module' according to our --- 'DynFlags'. -fingerprintDynFlags :: DynFlags -> Module - -> (BinHandle -> Name -> IO ()) - -> IO Fingerprint - -fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = - let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing - -- see #5878 - -- pkgopts = (thisPackage dflags, sort $ packageFlags dflags) - safeHs = setSafeMode safeHaskell - -- oflags = sort $ filter filterOFlags $ flags dflags - - -- *all* the extension flags and the language - lang = (fmap fromEnum language, - IntSet.toList $ extensionFlags) - - -- -I, -D and -U flags affect CPP - cpp = (map normalise includePaths, opt_P dflags ++ picPOpts dflags) - -- normalise: eliminate spurious differences due to "./foo" vs "foo" - - -- Note [path flags and recompilation] - paths = [ hcSuf ] - - -- -fprof-auto etc. - prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0 - - -- -O, see https://ghc.haskell.org/trac/ghc/ticket/10923 - opt = if hscTarget == HscInterpreted || - hscTarget == HscNothing - then 0 - else optLevel - - -- -fhpc, see https://ghc.haskell.org/trac/ghc/ticket/11798 - -- hpcDir is output-only, so we should recompile if it changes - hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing - - -- Nesting just to avoid ever more Binary tuple instances - flags = (mainis, safeHs, lang, cpp, paths, (prof, opt, hpc)) - - in -- pprTrace "flags" (ppr flags) $ - computeFingerprint nameio flags - -{- Note [path flags and recompilation] - -There are several flags that we deliberately omit from the -recompilation check; here we explain why. - --osuf, -odir, -hisuf, -hidir - If GHC decides that it does not need to recompile, then - it must have found an up-to-date .hi file and .o file. - There is no point recording these flags - the user must - have passed the correct ones. Indeed, the user may - have compiled the source file in one-shot mode using - -o to specify the .o file, and then loaded it in GHCi - using -odir. - --stubdir - We omit this one because it is automatically set by -outputdir, and - we don't want changes in -outputdir to automatically trigger - recompilation. This could be wrong, but only in very rare cases. - --i (importPaths) - For the same reason as -osuf etc. above: if GHC decides not to - recompile, then it must have already checked all the .hi files on - which the current module depends, so it must have found them - successfully. It is occasionally useful to be able to cd to a - different directory and use -i flags to enable GHC to find the .hi - files; we don't want this to force recompilation. - -The only path-related flag left is -hcsuf. --} diff --git a/iface/IfaceEnv.hs b/iface/IfaceEnv.hs deleted file mode 100644 --- a/iface/IfaceEnv.hs +++ /dev/null @@ -1,272 +0,0 @@ --- (c) The University of Glasgow 2002-2006 - -{-# LANGUAGE CPP, RankNTypes #-} - -module IfaceEnv ( - newGlobalBinder, newInteractiveBinder, - externaliseName, - lookupIfaceTop, - lookupOrig, lookupOrigNameCache, extendNameCache, - newIfaceName, newIfaceNames, - extendIfaceIdEnv, extendIfaceTyVarEnv, - tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar, - lookupIfaceTyVar, extendIfaceEnvs, - setNameModule, - - ifaceExportNames, - - -- Name-cache stuff - allocateGlobalBinder, updNameCache, - mkNameCacheUpdater, NameCacheUpdater(..), - ) where - -#include "HsVersions.h" - -import TcRnMonad -import HscTypes -import Type -import Var -import Name -import Avail -import Module -import FastString -import FastStringEnv -import IfaceType -import NameCache -import UniqSupply -import SrcLoc - -import Outputable -import Data.List ( partition ) - -{- -********************************************************* -* * - Allocating new Names in the Name Cache -* * -********************************************************* - -See Also: Note [The Name Cache] in NameCache --} - -newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name --- Used for source code and interface files, to make the --- Name for a thing, given its Module and OccName --- See Note [The Name Cache] --- --- The cache may already already have a binding for this thing, --- because we may have seen an occurrence before, but now is the --- moment when we know its Module and SrcLoc in their full glory - -newGlobalBinder mod occ loc - = do { mod `seq` occ `seq` return () -- See notes with lookupOrig - ; name <- updNameCache $ \name_cache -> - allocateGlobalBinder name_cache mod occ loc - ; traceIf (text "newGlobalBinder" <+> - (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name])) - ; return name } - -newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name --- Works in the IO monad, and gets the Module --- from the interactive context -newInteractiveBinder hsc_env occ loc - = do { let mod = icInteractiveModule (hsc_IC hsc_env) - ; updNameCacheIO hsc_env $ \name_cache -> - allocateGlobalBinder name_cache mod occ loc } - -allocateGlobalBinder - :: NameCache - -> Module -> OccName -> SrcSpan - -> (NameCache, Name) --- See Note [The Name Cache] -allocateGlobalBinder name_supply mod occ loc - = case lookupOrigNameCache (nsNames name_supply) mod occ of - -- A hit in the cache! We are at the binding site of the name. - -- This is the moment when we know the SrcLoc - -- of the Name, so we set this field in the Name we return. - -- - -- Then (bogus) multiple bindings of the same Name - -- get different SrcLocs can can be reported as such. - -- - -- Possible other reason: it might be in the cache because we - -- encountered an occurrence before the binding site for an - -- implicitly-imported Name. Perhaps the current SrcLoc is - -- better... but not really: it'll still just say 'imported' - -- - -- IMPORTANT: Don't mess with wired-in names. - -- Their wired-in-ness is in their NameSort - -- and their Module is correct. - - Just name | isWiredInName name - -> (name_supply, name) - | otherwise - -> (new_name_supply, name') - where - uniq = nameUnique name - name' = mkExternalName uniq mod occ loc - -- name' is like name, but with the right SrcSpan - new_cache = extendNameCache (nsNames name_supply) mod occ name' - new_name_supply = name_supply {nsNames = new_cache} - - -- Miss in the cache! - -- Build a completely new Name, and put it in the cache - _ -> (new_name_supply, name) - where - (uniq, us') = takeUniqFromSupply (nsUniqs name_supply) - name = mkExternalName uniq mod occ loc - new_cache = extendNameCache (nsNames name_supply) mod occ name - new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} - -ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] -ifaceExportNames exports = return exports - --- | A function that atomically updates the name cache given a modifier --- function. The second result of the modifier function will be the result --- of the IO action. -newtype NameCacheUpdater - = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c } - -mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater -mkNameCacheUpdater = do { hsc_env <- getTopEnv - ; return (NCU (updNameCacheIO hsc_env)) } - -updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c -updNameCache upd_fn = do { hsc_env <- getTopEnv - ; liftIO $ updNameCacheIO hsc_env upd_fn } - -{- -************************************************************************ -* * - Name cache access -* * -************************************************************************ --} - --- | Look up the 'Name' for a given 'Module' and 'OccName'. --- Consider alternately 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 { -- First ensure that mod and occ are evaluated - -- If not, chaos can ensue: - -- we read the name-cache - -- then pull on mod (say) - -- which does some stuff that modifies the name cache - -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..) - mod `seq` occ `seq` return () - ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) - - ; updNameCache $ \name_cache -> - case lookupOrigNameCache (nsNames name_cache) mod occ of { - Just name -> (name_cache, name); - Nothing -> - case takeUniqFromSupply (nsUniqs name_cache) of { - (uniq, us) -> - let - name = mkExternalName uniq mod occ noSrcSpan - new_cache = extendNameCache (nsNames name_cache) mod occ name - in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) - }}} - -externaliseName :: Module -> Name -> TcRnIf m n Name --- Take an Internal Name and make it an External one, --- with the same unique -externaliseName mod name - = do { let occ = nameOccName name - loc = nameSrcSpan name - uniq = nameUnique name - ; occ `seq` return () -- c.f. seq in newGlobalBinder - ; updNameCache $ \ ns -> - let name' = mkExternalName uniq mod occ loc - ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' } - in (ns', name') } - --- | Set the 'Module' of a 'Name'. -setNameModule :: Maybe Module -> Name -> TcRnIf m n Name -setNameModule Nothing n = return n -setNameModule (Just m) n = - newGlobalBinder m (nameOccName n) (nameSrcSpan n) - -{- -************************************************************************ -* * - Type variables and local Ids -* * -************************************************************************ --} - -tcIfaceLclId :: FastString -> IfL Id -tcIfaceLclId occ - = do { lcl <- getLclEnv - ; case (lookupFsEnv (if_id_env lcl) occ) of - Just ty_var -> return ty_var - Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ) - } - -extendIfaceIdEnv :: [Id] -> IfL a -> IfL a -extendIfaceIdEnv ids thing_inside - = do { env <- getLclEnv - ; let { id_env' = extendFsEnvList (if_id_env env) pairs - ; pairs = [(occNameFS (getOccName id), id) | id <- ids] } - ; setLclEnv (env { if_id_env = id_env' }) thing_inside } - - -tcIfaceTyVar :: FastString -> IfL TyVar -tcIfaceTyVar occ - = do { lcl <- getLclEnv - ; case (lookupFsEnv (if_tv_env lcl) occ) of - Just ty_var -> return ty_var - Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ) - } - -lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar) -lookupIfaceTyVar (occ, _) - = do { lcl <- getLclEnv - ; return (lookupFsEnv (if_tv_env lcl) occ) } - -lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar) -lookupIfaceVar (IfaceIdBndr (occ, _)) - = do { lcl <- getLclEnv - ; return (lookupFsEnv (if_id_env lcl) occ) } -lookupIfaceVar (IfaceTvBndr (occ, _)) - = do { lcl <- getLclEnv - ; return (lookupFsEnv (if_tv_env lcl) occ) } - -extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a -extendIfaceTyVarEnv tyvars thing_inside - = do { env <- getLclEnv - ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs - ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] } - ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside } - -extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a -extendIfaceEnvs tcvs thing_inside - = extendIfaceTyVarEnv tvs $ - extendIfaceIdEnv cvs $ - thing_inside - where - (tvs, cvs) = partition isTyVar tcvs - -{- -************************************************************************ -* * - Getting from RdrNames to Names -* * -************************************************************************ --} - --- | Look up a top-level name from the current Iface module -lookupIfaceTop :: OccName -> IfL Name -lookupIfaceTop occ - = do { env <- getLclEnv; lookupOrig (if_mod env) occ } - -newIfaceName :: OccName -> IfL Name -newIfaceName occ - = do { uniq <- newUnique - ; return $! mkInternalName uniq occ noSrcSpan } - -newIfaceNames :: [OccName] -> IfL [Name] -newIfaceNames occs - = do { uniqs <- newUniqueSupply - ; return [ mkInternalName uniq occ noSrcSpan - | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } diff --git a/iface/IfaceEnv.hs-boot b/iface/IfaceEnv.hs-boot deleted file mode 100644 --- a/iface/IfaceEnv.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -module IfaceEnv where - -import Module -import OccName -import TcRnMonad -import Name -import SrcLoc - -newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name diff --git a/iface/IfaceSyn.hs b/iface/IfaceSyn.hs deleted file mode 100644 --- a/iface/IfaceSyn.hs +++ /dev/null @@ -1,2220 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 --} - -{-# LANGUAGE CPP #-} - -module IfaceSyn ( - module IfaceType, - - IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), - IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, - IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceJoinInfo(..), - IfaceBinding(..), IfaceConAlt(..), - IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), - IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, - IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), - IfaceClassBody(..), - IfaceBang(..), - IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), - IfaceAxBranch(..), - IfaceTyConParent(..), - IfaceCompleteMatch(..), - - -- * Binding names - IfaceTopBndr, - putIfaceTopBndr, getIfaceTopBndr, - - -- Misc - ifaceDeclImplicitBndrs, visibleIfConDecls, - ifaceDeclFingerprints, - - -- Free Names - freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, - - -- Pretty printing - pprIfaceExpr, - pprIfaceDecl, - AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader - ) where - -#include "HsVersions.h" - -import IfaceType -import BinFingerprint -import CoreSyn( IsOrphan, isOrphan ) -import PprCore() -- Printing DFunArgs -import Demand -import Class -import FieldLabel -import NameSet -import CoAxiom ( BranchIndex ) -import Name -import CostCentre -import Literal -import ForeignCall -import Annotations( AnnPayload, AnnTarget ) -import BasicTypes -import Outputable -import Module -import SrcLoc -import Fingerprint -import Binary -import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) -import Var( TyVarBndr(..) ) -import TyCon ( Role (..), Injectivity(..) ) -import Util( filterOut, filterByList ) -import DataCon (SrcStrictness(..), SrcUnpackedness(..)) -import Lexeme (isLexSym) - -import Control.Monad -import System.IO.Unsafe -import Data.Maybe (isJust) - -infixl 3 &&& - -{- -************************************************************************ -* * - Declarations -* * -************************************************************************ --} - --- | A binding top-level 'Name' in an interface file (e.g. the name of an --- 'IfaceDecl'). -type IfaceTopBndr = Name - -- It's convenient to have an Name in the IfaceSyn, although in each - -- case the namespace is implied by the context. However, having an - -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints - -- very convenient. Moreover, having the key of the binder means that - -- we can encode known-key things cleverly in the symbol table. See Note - -- [Symbol table representation of Names] - -- - -- We don't serialise the namespace onto the disk though; rather we - -- drop it when serialising and add it back in when deserialising. - -getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr -getIfaceTopBndr bh = get bh - -putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO () -putIfaceTopBndr bh name = - case getUserData bh of - UserData{ ud_put_binding_name = put_binding_name } -> - --pprTrace "putIfaceTopBndr" (ppr name) $ - put_binding_name bh name - -data IfaceDecl - = IfaceId { ifName :: IfaceTopBndr, - ifType :: IfaceType, - ifIdDetails :: IfaceIdDetails, - ifIdInfo :: IfaceIdInfo } - - | IfaceData { ifName :: IfaceTopBndr, -- Type constructor - ifBinders :: [IfaceTyConBinder], - ifResKind :: IfaceType, -- Result kind of type constructor - ifCType :: Maybe CType, -- C type for CAPI FFI - ifRoles :: [Role], -- Roles - ifCtxt :: IfaceContext, -- The "stupid theta" - ifCons :: IfaceConDecls, -- Includes new/data/data family info - ifGadtSyntax :: Bool, -- True <=> declared using - -- GADT syntax - ifParent :: IfaceTyConParent -- The axiom, for a newtype, - -- or data/newtype family instance - } - - | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor - ifRoles :: [Role], -- Roles - ifBinders :: [IfaceTyConBinder], - ifResKind :: IfaceKind, -- Kind of the *result* - ifSynRhs :: IfaceType } - - | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor - ifResVar :: Maybe IfLclName, -- Result variable name, used - -- only for pretty-printing - -- with --show-iface - ifBinders :: [IfaceTyConBinder], - ifResKind :: IfaceKind, -- Kind of the *tycon* - ifFamFlav :: IfaceFamTyConFlav, - ifFamInj :: Injectivity } -- injectivity information - - | IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon - ifRoles :: [Role], -- Roles - ifBinders :: [IfaceTyConBinder], - ifFDs :: [FunDep IfLclName], -- Functional dependencies - ifBody :: IfaceClassBody -- Methods, superclasses, ATs - } - - | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name - ifTyCon :: IfaceTyCon, -- LHS TyCon - ifRole :: Role, -- Role of axiom - ifAxBranches :: [IfaceAxBranch] -- Branches - } - - | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym - ifPatIsInfix :: Bool, - ifPatMatcher :: (IfExtName, Bool), - ifPatBuilder :: Maybe (IfExtName, Bool), - -- Everything below is redundant, - -- but needed to implement pprIfaceDecl - ifPatUnivBndrs :: [IfaceForAllBndr], - ifPatExBndrs :: [IfaceForAllBndr], - ifPatProvCtxt :: IfaceContext, - ifPatReqCtxt :: IfaceContext, - ifPatArgs :: [IfaceType], - ifPatTy :: IfaceType, - ifFieldLabels :: [FieldLabel] } - --- See also 'ClassBody' -data IfaceClassBody - -- Abstract classes don't specify their body; they only occur in @hs-boot@ and - -- @hsig@ files. - = IfAbstractClass - | IfConcreteClass { - ifClassCtxt :: IfaceContext, -- Super classes - ifATs :: [IfaceAT], -- Associated type families - ifSigs :: [IfaceClassOp], -- Method signatures - ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition - } - -data IfaceTyConParent - = IfNoParent - | IfDataInstance IfExtName - IfaceTyCon - IfaceTcArgs - -data IfaceFamTyConFlav - = IfaceDataFamilyTyCon -- Data family - | IfaceOpenSynFamilyTyCon - | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch])) - -- ^ Name of associated axiom and branches for pretty printing purposes, - -- or 'Nothing' for an empty closed family without an axiom - | IfaceAbstractClosedSynFamilyTyCon - | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only - -data IfaceClassOp - = IfaceClassOp IfaceTopBndr - IfaceType -- Class op type - (Maybe (DefMethSpec IfaceType)) -- Default method - -- The types of both the class op itself, - -- and the default method, are *not* quantified - -- over the class variables - -data IfaceAT = IfaceAT -- See Class.ClassATItem - IfaceDecl -- The associated type declaration - (Maybe IfaceType) -- Default associated type instance, if any - - --- This is just like CoAxBranch -data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] - , ifaxbCoVars :: [IfaceIdBndr] - , ifaxbLHS :: IfaceTcArgs - , ifaxbRoles :: [Role] - , ifaxbRHS :: IfaceType - , ifaxbIncomps :: [BranchIndex] } - -- See Note [Storing compatibility] in CoAxiom - -data IfaceConDecls - = IfAbstractTyCon -- c.f TyCon.AbstractTyCon - | IfDataTyCon [IfaceConDecl] -- Data type decls - | IfNewTyCon IfaceConDecl -- Newtype decls - --- For IfDataTyCon and IfNewTyCon we store: --- * the data constructor(s); --- The field labels are stored individually in the IfaceConDecl --- (there is some redundancy here, because a field label may occur --- in multiple IfaceConDecls and represent the same field label) - -data IfaceConDecl - = IfCon { - ifConName :: IfaceTopBndr, -- Constructor name - ifConWrapper :: Bool, -- True <=> has a wrapper - ifConInfix :: Bool, -- True <=> declared infix - - -- The universal type variables are precisely those - -- of the type constructor of this data constructor - -- This is *easy* to guarantee when creating the IfCon - -- but it's not so easy for the original TyCon/DataCon - -- So this guarantee holds for IfaceConDecl, but *not* for DataCon - - ifConExTvs :: [IfaceForAllBndr], -- Existential tyvars (w/ visibility) - ifConEqSpec :: IfaceEqSpec, -- Equality constraints - ifConCtxt :: IfaceContext, -- Non-stupid context - ifConArgTys :: [IfaceType], -- Arg types - ifConFields :: [FieldLabel], -- ...ditto... (field labels) - ifConStricts :: [IfaceBang], - -- Empty (meaning all lazy), - -- or 1-1 corresp with arg tys - -- See Note [Bangs on imported data constructors] in MkId - ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts - -type IfaceEqSpec = [(IfLclName,IfaceType)] - --- | This corresponds to an HsImplBang; that is, the final --- implementation decision about the data constructor arg -data IfaceBang - = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion - --- | This corresponds to HsSrcBang -data IfaceSrcBang - = IfSrcBang SrcUnpackedness SrcStrictness - -data IfaceClsInst - = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with - ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst - ifDFun :: IfExtName, -- The dfun - ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: IsOrphan } -- See Note [Orphans] in InstEnv - -- There's always a separate IfaceDecl for the DFun, which gives - -- its IdInfo with its full type and version number. - -- The instance declarations taken together have a version number, - -- and we don't want that to wobble gratuitously - -- If this instance decl is *used*, we'll record a usage on the dfun; - -- and if the head does not change it won't be used if it wasn't before - --- The ifFamInstTys field of IfaceFamInst contains a list of the rough --- match types -data IfaceFamInst - = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name - , ifFamInstTys :: [Maybe IfaceTyCon] -- See above - , ifFamInstAxiom :: IfExtName -- The axiom - , ifFamInstOrph :: IsOrphan -- Just like IfaceClsInst - } - -data IfaceRule - = IfaceRule { - ifRuleName :: RuleName, - ifActivation :: Activation, - ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars - ifRuleHead :: IfExtName, -- Head of lhs - ifRuleArgs :: [IfaceExpr], -- Args of LHS - ifRuleRhs :: IfaceExpr, - ifRuleAuto :: Bool, - ifRuleOrph :: IsOrphan -- Just like IfaceClsInst - } - -data IfaceAnnotation - = IfaceAnnotation { - ifAnnotatedTarget :: IfaceAnnTarget, - ifAnnotatedValue :: AnnPayload - } - -type IfaceAnnTarget = AnnTarget OccName - -data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName - -instance Outputable IfaceCompleteMatch where - ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls - <+> dcolon <+> ppr ty - - - - --- Here's a tricky case: --- * Compile with -O module A, and B which imports A.f --- * Change function f in A, and recompile without -O --- * When we read in old A.hi we read in its IdInfo (as a thunk) --- (In earlier GHCs we used to drop IdInfo immediately on reading, --- but we do not do that now. Instead it's discarded when the --- ModIface is read into the various decl pools.) --- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *) --- and so gives a new version. - -data IfaceIdInfo - = NoInfo -- When writing interface file without -O - | HasInfo [IfaceInfoItem] -- Has info, and here it is - -data IfaceInfoItem - = HsArity Arity - | HsStrictness StrictSig - | HsInline InlinePragma - | HsUnfold Bool -- True <=> isStrongLoopBreaker is true - IfaceUnfolding -- See Note [Expose recursive functions] - | HsNoCafRefs - | HsLevity -- Present <=> never levity polymorphic - --- NB: Specialisations and rules come in separately and are --- only later attached to the Id. Partial reason: some are orphans. - -data IfaceUnfolding - = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding - -- Possibly could eliminate the Bool here, the information - -- is also in the InlinePragma. - - | IfCompulsory IfaceExpr -- Only used for default methods, in fact - - | IfInlineRule Arity -- INLINE pragmas - Bool -- OK to inline even if *un*-saturated - Bool -- OK to inline even if context is boring - IfaceExpr - - | IfDFunUnfold [IfaceBndr] [IfaceExpr] - - --- We only serialise the IdDetails of top-level Ids, and even then --- we only need a very limited selection. Notably, none of the --- implicit ones are needed here, because they are not put it --- interface files - -data IfaceIdDetails - = IfVanillaId - | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool - | IfDFunId - -{- -Note [Versioning of instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance#Instances] - - -************************************************************************ -* * - Functions over declarations -* * -************************************************************************ --} - -visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] -visibleIfConDecls IfAbstractTyCon = [] -visibleIfConDecls (IfDataTyCon cs) = cs -visibleIfConDecls (IfNewTyCon c) = [c] - -ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] --- *Excludes* the 'main' name, but *includes* the implicitly-bound names --- Deeply revolting, because it has to predict what gets bound, --- especially the question of whether there's a wrapper for a datacon --- See Note [Implicit TyThings] in HscTypes - --- N.B. the set of names returned here *must* match the set of --- TyThings returned by HscTypes.implicitTyThings, in the sense that --- TyThing.getOccName should define a bijection between the two lists. --- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) --- The order of the list does not matter. - -ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) - = case cons of - IfAbstractTyCon -> [] - IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd - IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds - -ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass }) - = [] - -ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name - , ifBody = IfConcreteClass { - ifClassCtxt = sc_ctxt, - ifSigs = sigs, - ifATs = ats - }}) - = -- (possibly) newtype coercion - co_occs ++ - -- data constructor (DataCon namespace) - -- data worker (Id namespace) - -- no wrapper (class dictionaries never have a wrapper) - [dc_occ, dcww_occ] ++ - -- associated types - [occName (ifName at) | IfaceAT at _ <- ats ] ++ - -- superclass selectors - [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++ - -- operation selectors - [occName op | IfaceClassOp op _ _ <- sigs] - where - cls_tc_occ = occName cls_tc_name - n_ctxt = length sc_ctxt - n_sigs = length sigs - co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ] - | otherwise = [] - dcww_occ = mkDataConWorkerOcc dc_occ - dc_occ = mkClassDataConOcc cls_tc_occ - is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass) - -ifaceDeclImplicitBndrs _ = [] - -ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName] -ifaceConDeclImplicitBndrs (IfCon { - ifConWrapper = has_wrapper, ifConName = con_name }) - = [occName con_name, work_occ] ++ wrap_occs - where - con_occ = occName con_name - work_occ = mkDataConWorkerOcc con_occ -- Id namespace - wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace - | otherwise = [] - --- ----------------------------------------------------------------------------- --- The fingerprints of an IfaceDecl - - -- We better give each name bound by the declaration a - -- different fingerprint! So we calculate the fingerprint of - -- each binder by combining the fingerprint of the whole - -- declaration with the name of the binder. (#5614, #7215) -ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] -ifaceDeclFingerprints hash decl - = (getOccName decl, hash) : - [ (occ, computeFingerprint' (hash,occ)) - | occ <- ifaceDeclImplicitBndrs decl ] - where - computeFingerprint' = - unsafeDupablePerformIO - . computeFingerprint (panic "ifaceDeclFingerprints") - -{- -************************************************************************ -* * - Expressions -* * -************************************************************************ --} - -data IfaceExpr - = IfaceLcl IfLclName - | IfaceExt IfExtName - | IfaceType IfaceType - | IfaceCo IfaceCoercion - | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted - | IfaceLam IfaceLamBndr IfaceExpr - | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr IfLclName [IfaceAlt] - | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] - | IfaceLet IfaceBinding IfaceExpr - | IfaceCast IfaceExpr IfaceCoercion - | IfaceLit Literal - | IfaceFCall ForeignCall IfaceType - | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E - -data IfaceTickish - = IfaceHpcTick Module Int -- from HpcTick x - | IfaceSCC CostCentre Bool Bool -- from ProfNote - | IfaceSource RealSrcSpan String -- from SourceNote - -- no breakpoints: we never export these into interface files - -type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) - -- Note: IfLclName, not IfaceBndr (and same with the case binder) - -- We reconstruct the kind/type of the thing from the context - -- thus saving bulk in interface files - -data IfaceConAlt = IfaceDefault - | IfaceDataAlt IfExtName - | IfaceLitAlt Literal - -data IfaceBinding - = IfaceNonRec IfaceLetBndr IfaceExpr - | IfaceRec [(IfaceLetBndr, IfaceExpr)] - --- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too --- It's used for *non-top-level* let/rec binders --- See Note [IdInfo on nested let-bindings] -data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo - -data IfaceJoinInfo = IfaceNotJoinPoint - | IfaceJoinPoint JoinArity - -{- -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In IfaceSyn an IfaceCase does not record the types of the alternatives, -unlike CorSyn Case. But we need this type if the alternatives are empty. -Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. - -Note [Expose recursive functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For supercompilation we want to put *all* unfoldings in the interface -file, even for functions that are recursive (or big). So we need to -know when an unfolding belongs to a loop-breaker so that we can refrain -from inlining it (except during supercompilation). - -Note [IdInfo on nested let-bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Occasionally we want to preserve IdInfo on nested let bindings. The one -that came up was a NOINLINE pragma on a let-binding inside an INLINE -function. The user (Duncan Coutts) really wanted the NOINLINE control -to cross the separate compilation boundary. - -In general we retain all info that is left by CoreTidy.tidyLetBndr, since -that is what is seen by importing module with --make - - -************************************************************************ -* * - Printing IfaceDecl -* * -************************************************************************ --} - -pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc --- The TyCon might be local (just an OccName), or this might --- be a branch for an imported TyCon, so it would be an ExtName --- So it's easier to take an SDoc here -pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs - , ifaxbCoVars = cvs - , ifaxbLHS = pat_tys - , ifaxbRHS = rhs - , ifaxbIncomps = incomps }) - = hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) - $+$ - nest 2 maybe_incomps - where - ppr_binders - | null tvs && null cvs = empty - | null cvs - = brackets (pprWithCommas (pprIfaceTvBndr True) tvs) - | otherwise - = brackets (pprWithCommas (pprIfaceTvBndr True) tvs <> semi <+> - pprWithCommas pprIfaceIdBndr cvs) - pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys) - maybe_incomps = ppUnless (null incomps) $ parens $ - text "incompatible indices:" <+> ppr incomps - -instance Outputable IfaceAnnotation where - ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value - -instance NamedThing IfaceClassOp where - getName (IfaceClassOp n _ _) = n - -instance HasOccName IfaceClassOp where - occName = getOccName - -instance NamedThing IfaceConDecl where - getName = ifConName - -instance HasOccName IfaceConDecl where - occName = getOccName - -instance NamedThing IfaceDecl where - getName = ifName - -instance HasOccName IfaceDecl where - occName = getOccName - -instance Outputable IfaceDecl where - ppr = pprIfaceDecl showToIface - -{- -Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The minimal complete definition should only be included if a complete -class definition is shown. Since the minimal complete definition is -anonymous we can't reuse the same mechanism that is used for the -filtering of method signatures. Instead we just check if anything at all is -filtered and hide it in that case. --} - -data ShowSub - = ShowSub - { ss_how_much :: ShowHowMuch - , ss_forall :: ShowForAllFlag } - --- See Note [Printing IfaceDecl binders] --- The alternative pretty printer referred to in the note. -newtype AltPpr = AltPpr (Maybe (OccName -> SDoc)) - -data ShowHowMuch - = ShowHeader AltPpr -- ^Header information only, not rhs - | ShowSome [OccName] AltPpr - -- ^ Show only some sub-components. Specifically, - -- - -- [@[]@] Print all sub-components. - -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@; - -- elide other sub-components to @...@ - -- May 14: the list is max 1 element long at the moment - | ShowIface - -- ^Everything including GHC-internal information (used in --show-iface) - -{- -Note [Printing IfaceDecl binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The binders in an IfaceDecl are just OccNames, so we don't know what module they -come from. But when we pretty-print a TyThing by converting to an IfaceDecl -(see PprTyThing), the TyThing may come from some other module so we really need -the module qualifier. We solve this by passing in a pretty-printer for the -binders. - -When printing an interface file (--show-iface), we want to print -everything unqualified, so we can just print the OccName directly. --} - -instance Outputable ShowHowMuch where - ppr (ShowHeader _) = text "ShowHeader" - ppr ShowIface = text "ShowIface" - ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs - -showToHeader :: ShowSub -showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing - , ss_forall = ShowForAllWhen } - -showToIface :: ShowSub -showToIface = ShowSub { ss_how_much = ShowIface - , ss_forall = ShowForAllWhen } - -ppShowIface :: ShowSub -> SDoc -> SDoc -ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc -ppShowIface _ _ = Outputable.empty - --- show if all sub-components or the complete interface is shown -ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition] -ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc -ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc -ppShowAllSubs _ _ = Outputable.empty - -ppShowRhs :: ShowSub -> SDoc -> SDoc -ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty -ppShowRhs _ doc = doc - -showSub :: HasOccName n => ShowSub -> n -> Bool -showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False -showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing -showSub (ShowSub { ss_how_much = _ }) _ = True - -ppr_trim :: [Maybe SDoc] -> [SDoc] --- Collapse a group of Nothings to a single "..." -ppr_trim xs - = snd (foldr go (False, []) xs) - where - go (Just doc) (_, so_far) = (False, doc : so_far) - go Nothing (True, so_far) = (True, so_far) - go Nothing (False, so_far) = (True, text "..." : so_far) - -isIfaceDataInstance :: IfaceTyConParent -> Bool -isIfaceDataInstance IfNoParent = False -isIfaceDataInstance _ = True - -pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc -pprClassRoles ss clas binders roles = - pprRoles (== Nominal) - (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) - binders - roles - -pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc --- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi --- See Note [Pretty-printing TyThings] in PprTyThing -pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, - ifCtxt = context, - ifRoles = roles, ifCons = condecls, - ifParent = parent, - ifGadtSyntax = gadt, - ifBinders = binders }) - - | gadt_style = vcat [ pp_roles - , pp_nd <+> pp_lhs <+> pp_where - , nest 2 (vcat pp_cons) - , nest 2 $ ppShowIface ss pp_extra ] - | otherwise = vcat [ pp_roles - , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) - , nest 2 $ ppShowIface ss pp_extra ] - where - is_data_instance = isIfaceDataInstance parent - - gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons - cons = visibleIfConDecls condecls - pp_where = ppWhen (gadt_style && not (null cons)) $ text "where" - pp_cons = ppr_trim (map show_con cons) :: [SDoc] - - pp_lhs = case parent of - IfNoParent -> pprIfaceDeclHead context ss tycon binders Nothing - _ -> text "instance" <+> pprIfaceTyConParent parent - - pp_roles - | is_data_instance = empty - | otherwise = pprRoles (== Representational) - (pprPrefixIfDeclBndr - (ss_how_much ss) - (occName tycon)) - binders roles - -- Don't display roles for data family instances (yet) - -- See discussion on Trac #8672. - - add_bars [] = Outputable.empty - add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs) - - ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc) - - show_con dc - | ok_con dc = Just $ pprIfaceConDecl ss gadt_style tycon binders parent dc - | otherwise = Nothing - - pp_nd = case condecls of - IfAbstractTyCon{} -> text "data" - IfDataTyCon{} -> text "data" - IfNewTyCon{} -> text "newtype" - - pp_extra = vcat [pprCType ctype] - -pprIfaceDecl ss (IfaceClass { ifName = clas - , ifRoles = roles - , ifFDs = fds - , ifBinders = binders - , ifBody = IfAbstractClass }) - = vcat [ pprClassRoles ss clas binders roles - , text "class" <+> pprIfaceDeclHead [] ss clas binders Nothing - <+> pprFundeps fds ] - -pprIfaceDecl ss (IfaceClass { ifName = clas - , ifRoles = roles - , ifFDs = fds - , ifBinders = binders - , ifBody = IfConcreteClass { - ifATs = ats, - ifSigs = sigs, - ifClassCtxt = context, - ifMinDef = minDef - }}) - = vcat [ pprClassRoles ss clas binders roles - , text "class" <+> pprIfaceDeclHead context ss clas binders Nothing - <+> pprFundeps fds <+> pp_where - , nest 2 (vcat [ vcat asocs, vcat dsigs - , ppShowAllSubs ss (pprMinDef minDef)])] - where - pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") - - asocs = ppr_trim $ map maybeShowAssoc ats - dsigs = ppr_trim $ map maybeShowSig sigs - - maybeShowAssoc :: IfaceAT -> Maybe SDoc - maybeShowAssoc asc@(IfaceAT d _) - | showSub ss d = Just $ pprIfaceAT ss asc - | otherwise = Nothing - - maybeShowSig :: IfaceClassOp -> Maybe SDoc - maybeShowSig sg - | showSub ss sg = Just $ pprIfaceClassOp ss sg - | otherwise = Nothing - - pprMinDef :: BooleanFormula IfLclName -> SDoc - pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions - text "{-# MINIMAL" <+> - pprBooleanFormula - (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+> - text "#-}" - -pprIfaceDecl ss (IfaceSynonym { ifName = tc - , ifBinders = binders - , ifSynRhs = mono_ty - , ifResKind = res_kind}) - = hang (text "type" <+> pprIfaceDeclHead [] ss tc binders Nothing <+> equals) - 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau - , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ]) - where - (tvs, theta, tau) = splitIfaceSigmaTy mono_ty - -pprIfaceDecl ss (IfaceFamily { ifName = tycon - , ifFamFlav = rhs, ifBinders = binders - , ifResKind = res_kind - , ifResVar = res_var, ifFamInj = inj }) - | IfaceDataFamilyTyCon <- rhs - = text "data family" <+> pprIfaceDeclHead [] ss tycon binders Nothing - - | otherwise - = hang (text "type family" <+> pprIfaceDeclHead [] ss tycon binders (Just res_kind)) - 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) - $$ - nest 2 (ppShowRhs ss (pp_branches rhs)) - where - pp_inj Nothing _ = empty - pp_inj (Just res) inj - | Injective injectivity <- inj = hsep [ equals, ppr res - , pp_inj_cond res injectivity] - | otherwise = hsep [ equals, ppr res ] - - pp_inj_cond res inj = case filterByList inj binders of - [] -> empty - tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)] - - pp_rhs IfaceDataFamilyTyCon - = ppShowIface ss (text "data") - pp_rhs IfaceOpenSynFamilyTyCon - = ppShowIface ss (text "open") - pp_rhs IfaceAbstractClosedSynFamilyTyCon - = ppShowIface ss (text "closed, abstract") - pp_rhs (IfaceClosedSynFamilyTyCon {}) - = empty -- see pp_branches - pp_rhs IfaceBuiltInSynFamTyCon - = ppShowIface ss (text "built-in") - - pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) - = hang (text "where") - 2 (vcat (map (pprAxBranch - (pprPrefixIfDeclBndr - (ss_how_much ss) - (occName tycon)) - ) brs) - $$ ppShowIface ss (text "axiom" <+> ppr ax)) - pp_branches _ = Outputable.empty - -pprIfaceDecl _ (IfacePatSyn { ifName = name, - ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs, - ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, - ifPatArgs = arg_tys, - ifPatTy = pat_ty} ) - = sdocWithDynFlags mk_msg - where - mk_msg dflags - = hsep [ text "pattern", pprPrefixOcc name, dcolon - , univ_msg, pprIfaceContextArr req_ctxt - , ppWhen insert_empty_ctxt $ parens empty <+> darrow - , ex_msg, pprIfaceContextArr prov_ctxt - , pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys] - where - univ_msg = pprUserIfaceForAll univ_bndrs - ex_msg = pprUserIfaceForAll ex_bndrs - - insert_empty_ctxt = null req_ctxt - && not (null prov_ctxt && isEmpty dflags ex_msg) - -pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, - ifIdDetails = details, ifIdInfo = info }) - = vcat [ hang (pprPrefixIfDeclBndr (ss_how_much ss) (occName var) <+> dcolon) - 2 (pprIfaceSigmaType (ss_forall ss) ty) - , ppShowIface ss (ppr details) - , ppShowIface ss (ppr info) ] - -pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon - , ifAxBranches = branches }) - = hang (text "axiom" <+> ppr name <> dcolon) - 2 (vcat $ map (pprAxBranch (ppr tycon)) branches) - - -pprCType :: Maybe CType -> SDoc -pprCType Nothing = Outputable.empty -pprCType (Just cType) = text "C type:" <+> ppr cType - --- if, for each role, suppress_if role is True, then suppress the role --- output -pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder] - -> [Role] -> SDoc -pprRoles suppress_if tyCon bndrs roles - = sdocWithDynFlags $ \dflags -> - let froles = suppressIfaceInvisibles dflags bndrs roles - in ppUnless (all suppress_if roles || null froles) $ - text "type role" <+> tyCon <+> hsep (map ppr froles) - -pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc -pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name - = pprInfixVar (isSymOcc name) (ppr_bndr name) -pprInfixIfDeclBndr _ name - = pprInfixVar (isSymOcc name) (ppr name) - -pprPrefixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc -pprPrefixIfDeclBndr (ShowHeader (AltPpr (Just ppr_bndr))) name - = parenSymOcc name (ppr_bndr name) -pprPrefixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name - = parenSymOcc name (ppr_bndr name) -pprPrefixIfDeclBndr _ name - = parenSymOcc name (ppr name) - -instance Outputable IfaceClassOp where - ppr = pprIfaceClassOp showToIface - -pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc -pprIfaceClassOp ss (IfaceClassOp n ty dm) - = pp_sig n ty $$ generic_dm - where - generic_dm | Just (GenericDM dm_ty) <- dm - = text "default" <+> pp_sig n dm_ty - | otherwise - = empty - pp_sig n ty - = pprPrefixIfDeclBndr (ss_how_much ss) (occName n) - <+> dcolon - <+> pprIfaceSigmaType ShowForAllWhen ty - -instance Outputable IfaceAT where - ppr = pprIfaceAT showToIface - -pprIfaceAT :: ShowSub -> IfaceAT -> SDoc -pprIfaceAT ss (IfaceAT d mb_def) - = vcat [ pprIfaceDecl ss d - , case mb_def of - Nothing -> Outputable.empty - Just rhs -> nest 2 $ - text "Default:" <+> ppr rhs ] - -instance Outputable IfaceTyConParent where - ppr p = pprIfaceTyConParent p - -pprIfaceTyConParent :: IfaceTyConParent -> SDoc -pprIfaceTyConParent IfNoParent - = Outputable.empty -pprIfaceTyConParent (IfDataInstance _ tc tys) - = sdocWithDynFlags $ \dflags -> - let ftys = stripInvisArgs dflags tys - in pprIfaceTypeApp TopPrec tc ftys - -pprIfaceDeclHead :: IfaceContext -> ShowSub -> Name - -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression - -> Maybe IfaceKind - -> SDoc -pprIfaceDeclHead context ss tc_occ bndrs m_res_kind - = sdocWithDynFlags $ \ dflags -> - sep [ pprIfaceContextArr context - , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ) - <+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs) - , maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ] - -isVanillaIfaceConDecl :: IfaceConDecl -> Bool -isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs - , ifConEqSpec = eq_spec - , ifConCtxt = ctxt }) - = (null ex_tvs) && (null eq_spec) && (null ctxt) - -pprIfaceConDecl :: ShowSub -> Bool - -> IfaceTopBndr - -> [IfaceTyConBinder] - -> IfaceTyConParent - -> IfaceConDecl -> SDoc -pprIfaceConDecl ss gadt_style tycon tc_binders parent - (IfCon { ifConName = name, ifConInfix = is_infix, - ifConExTvs = ex_tvs, - ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, - ifConStricts = stricts, ifConFields = fields }) - | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty - | not (null fields) = pp_prefix_con <+> pp_field_args - | is_infix - , [ty1, ty2] <- pp_args = sep [ ty1 - , pprInfixIfDeclBndr how_much (occName name) - , ty2] - - | otherwise = pp_prefix_con <+> sep pp_args - where - how_much = ss_how_much ss - tys_w_strs :: [(IfaceBang, IfaceType)] - tys_w_strs = zip stricts arg_tys - pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name) - - (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec - ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr univ_tvs ++ ex_tvs) - ctxt pp_tau - - -- A bit gruesome this, but we can't form the full con_tau, and ppr it, - -- because we don't have a Name for the tycon, only an OccName - pp_tau | null fields - = case pp_args ++ [pp_res_ty] of - (t:ts) -> fsep (t : map (arrow <+>) ts) - [] -> panic "pp_con_taus" - | otherwise - = sep [pp_field_args, arrow <+> pp_res_ty] - - ppr_bang IfNoBang = sdocWithPprDebug $ \dbg -> ppWhen dbg $ char '_' - ppr_bang IfStrict = char '!' - ppr_bang IfUnpack = text "{-# UNPACK #-}" - ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <> - pprParendIfaceCoercion co - - pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty - pprBangTy (bang, ty) = ppr_bang bang <> ppr ty - - pp_args :: [SDoc] -- With parens, e.g (Maybe a) or !(Maybe a) - pp_args = map pprParendBangTy tys_w_strs - - pp_field_args :: SDoc -- Braces form: { x :: !Maybe a, y :: Int } - pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $ - zipWith maybe_show_label fields tys_w_strs - - maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc - maybe_show_label lbl bty - | showSub ss sel = - Just (pprPrefixIfDeclBndr how_much occ <+> dcolon <+> pprBangTy bty) - | otherwise = - Nothing - where - sel = flSelector lbl - occ = mkVarOccFS (flLabel lbl) - - mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc) - -- See Note [Result type of a data family GADT] - mk_user_con_res_ty eq_spec - | IfDataInstance _ tc tys <- parent - = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys))) - | otherwise - = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst)) - where - gadt_subst = mkFsEnv eq_spec - done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv) - con_univ_tvs = filterOut done_univ_tv (map ifTyConBinderTyVar tc_binders) - - ppr_tc_app gadt_subst dflags - = pprPrefixIfDeclBndr how_much (occName tycon) - <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv) - | (tv,_kind) - <- map ifTyConBinderTyVar $ - suppressIfaceInvisibles dflags tc_binders tc_binders ] - -instance Outputable IfaceRule where - ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, - ifRuleOrph = orph }) - = sep [hsep [pprRuleName name, - if isOrphan orph then text "[orphan]" else Outputable.empty, - ppr act, - text "forall" <+> pprIfaceBndrs bndrs], - nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), - text "=" <+> ppr rhs]) - ] - -instance Outputable IfaceClsInst where - ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag - , ifInstCls = cls, ifInstTys = mb_tcs - , ifInstOrph = orph }) - = hang (text "instance" <+> ppr flag - <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) - <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) - 2 (equals <+> ppr dfun_id) - -instance Outputable IfaceFamInst where - ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs - , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph }) - = hang (text "family instance" - <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) - <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) - 2 (equals <+> ppr tycon_ax) - -ppr_rough :: Maybe IfaceTyCon -> SDoc -ppr_rough Nothing = dot -ppr_rough (Just tc) = ppr tc - -tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr -tv_to_forall_bndr tv = TvBndr tv Specified - -{- -Note [Result type of a data family GADT] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T a - data instance T (p,q) where - T1 :: T (Int, Maybe c) - T2 :: T (Bool, q) - -The IfaceDecl actually looks like - - data TPr p q where - T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q - T2 :: forall p q. (p~Bool) => TPr p q - -To reconstruct the result types for T1 and T2 that we -want to pretty print, we substitute the eq-spec -[p->Int, q->Maybe c] in the arg pattern (p,q) to give - T (Int, Maybe c) -Remember that in IfaceSyn, the TyCon and DataCon share the same -universal type variables. - ------------------------------ Printing IfaceExpr ------------------------------------ --} - -instance Outputable IfaceExpr where - ppr e = pprIfaceExpr noParens e - -noParens :: SDoc -> SDoc -noParens pp = pp - -pprParendIfaceExpr :: IfaceExpr -> SDoc -pprParendIfaceExpr = pprIfaceExpr parens - --- | Pretty Print an IfaceExpre --- --- The first argument should be a function that adds parens in context that need --- an atomic value (e.g. function args) -pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc - -pprIfaceExpr _ (IfaceLcl v) = ppr v -pprIfaceExpr _ (IfaceExt v) = ppr v -pprIfaceExpr _ (IfaceLit l) = ppr l -pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) -pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty -pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co - -pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) -pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) - -pprIfaceExpr add_par i@(IfaceLam _ _) - = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, - pprIfaceExpr noParens body]) - where - (bndrs,body) = collect [] i - collect bs (IfaceLam b e) = collect (b:bs) e - collect bs e = (reverse bs, e) - -pprIfaceExpr add_par (IfaceECase scrut ty) - = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut - , text "ret_ty" <+> pprParendIfaceType ty - , text "of {}" ]) - -pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) - = add_par (sep [text "case" - <+> pprIfaceExpr noParens scrut <+> text "of" - <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, - pprIfaceExpr noParens rhs <+> char '}']) - -pprIfaceExpr add_par (IfaceCase scrut bndr alts) - = add_par (sep [text "case" - <+> pprIfaceExpr noParens scrut <+> text "of" - <+> ppr bndr <+> char '{', - nest 2 (sep (map ppr_alt alts)) <+> char '}']) - -pprIfaceExpr _ (IfaceCast expr co) - = sep [pprParendIfaceExpr expr, - nest 2 (text "`cast`"), - pprParendIfaceCoercion co] - -pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) - = add_par (sep [text "let {", - nest 2 (ppr_bind (b, rhs)), - text "} in", - pprIfaceExpr noParens body]) - -pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) - = add_par (sep [text "letrec {", - nest 2 (sep (map ppr_bind pairs)), - text "} in", - pprIfaceExpr noParens body]) - -pprIfaceExpr add_par (IfaceTick tickish e) - = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e) - -ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc -ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, - arrow <+> pprIfaceExpr noParens rhs] - -ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc -ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) - -ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc -ppr_bind (IfLetBndr b ty info ji, rhs) - = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info), - equals <+> pprIfaceExpr noParens rhs] - ------------------- -pprIfaceTickish :: IfaceTickish -> SDoc -pprIfaceTickish (IfaceHpcTick m ix) - = braces (text "tick" <+> ppr m <+> ppr ix) -pprIfaceTickish (IfaceSCC cc tick scope) - = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) -pprIfaceTickish (IfaceSource src _names) - = braces (pprUserRealSpan True src) - ------------------- -pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc -pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $ - nest 2 (pprParendIfaceExpr arg) : args -pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) - ------------------- -instance Outputable IfaceConAlt where - ppr IfaceDefault = text "DEFAULT" - ppr (IfaceLitAlt l) = ppr l - ppr (IfaceDataAlt d) = ppr d - ------------------- -instance Outputable IfaceIdDetails where - ppr IfVanillaId = Outputable.empty - ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc - <+> if b - then text "" - else Outputable.empty - ppr IfDFunId = text "DFunId" - -instance Outputable IfaceIdInfo where - ppr NoInfo = Outputable.empty - ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is - <+> text "-}" - -instance Outputable IfaceInfoItem where - ppr (HsUnfold lb unf) = text "Unfolding" - <> ppWhen lb (text "(loop-breaker)") - <> colon <+> ppr unf - ppr (HsInline prag) = text "Inline:" <+> ppr prag - ppr (HsArity arity) = text "Arity:" <+> int arity - ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str - ppr HsNoCafRefs = text "HasNoCafRefs" - ppr HsLevity = text "Never levity-polymorphic" - -instance Outputable IfaceJoinInfo where - ppr IfaceNotJoinPoint = empty - ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar) - -instance Outputable IfaceUnfolding where - ppr (IfCompulsory e) = text "" <+> parens (ppr e) - ppr (IfCoreUnfold s e) = (if s - then text "" - else Outputable.empty) - <+> parens (ppr e) - ppr (IfInlineRule a uok bok e) = sep [text "InlineRule" - <+> ppr (a,uok,bok), - pprParendIfaceExpr e] - ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot) - 2 (sep (map pprParendIfaceExpr es)) - -{- -************************************************************************ -* * - Finding the Names in IfaceSyn -* * -************************************************************************ - -This is used for dependency analysis in MkIface, so that we -fingerprint a declaration before the things that depend on it. It -is specific to interface-file fingerprinting in the sense that we -don't collect *all* Names: for example, the DFun of an instance is -recorded textually rather than by its fingerprint when -fingerprinting the instance, so DFuns are not dependencies. --} - -freeNamesIfDecl :: IfaceDecl -> NameSet -freeNamesIfDecl (IfaceId _s t d i) = - freeNamesIfType t &&& - freeNamesIfIdInfo i &&& - freeNamesIfIdDetails d -freeNamesIfDecl d@IfaceData{} = - freeNamesIfTyVarBndrs (ifBinders d) &&& - freeNamesIfType (ifResKind d) &&& - freeNamesIfaceTyConParent (ifParent d) &&& - freeNamesIfContext (ifCtxt d) &&& - freeNamesIfConDecls (ifCons d) -freeNamesIfDecl d@IfaceSynonym{} = - freeNamesIfType (ifSynRhs d) &&& - freeNamesIfTyVarBndrs (ifBinders d) &&& - freeNamesIfKind (ifResKind d) -freeNamesIfDecl d@IfaceFamily{} = - freeNamesIfFamFlav (ifFamFlav d) &&& - freeNamesIfTyVarBndrs (ifBinders d) &&& - freeNamesIfKind (ifResKind d) -freeNamesIfDecl d@IfaceClass{ ifBody = IfAbstractClass } = - freeNamesIfTyVarBndrs (ifBinders d) -freeNamesIfDecl d@IfaceClass{ ifBody = d'@IfConcreteClass{} } = - freeNamesIfTyVarBndrs (ifBinders d) &&& - freeNamesIfContext (ifClassCtxt d') &&& - fnList freeNamesIfAT (ifATs d') &&& - fnList freeNamesIfClsSig (ifSigs d') -freeNamesIfDecl d@IfaceAxiom{} = - freeNamesIfTc (ifTyCon d) &&& - fnList freeNamesIfAxBranch (ifAxBranches d) -freeNamesIfDecl d@IfacePatSyn{} = - unitNameSet (fst (ifPatMatcher d)) &&& - maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&& - freeNamesIfTyVarBndrs (ifPatUnivBndrs d) &&& - freeNamesIfTyVarBndrs (ifPatExBndrs d) &&& - freeNamesIfContext (ifPatProvCtxt d) &&& - freeNamesIfContext (ifPatReqCtxt d) &&& - fnList freeNamesIfType (ifPatArgs d) &&& - freeNamesIfType (ifPatTy d) &&& - mkNameSet (map flSelector (ifFieldLabels d)) - -freeNamesIfAxBranch :: IfaceAxBranch -> NameSet -freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars - , ifaxbCoVars = covars - , ifaxbLHS = lhs - , ifaxbRHS = rhs }) - = fnList freeNamesIfTvBndr tyvars &&& - fnList freeNamesIfIdBndr covars &&& - freeNamesIfTcArgs lhs &&& - freeNamesIfType rhs - -freeNamesIfIdDetails :: IfaceIdDetails -> NameSet -freeNamesIfIdDetails (IfRecSelId tc _) = - either freeNamesIfTc freeNamesIfDecl tc -freeNamesIfIdDetails _ = emptyNameSet - --- All other changes are handled via the version info on the tycon -freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet -freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet -freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet -freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br))) - = unitNameSet ax &&& fnList freeNamesIfAxBranch br -freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet -freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet -freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet - -freeNamesIfContext :: IfaceContext -> NameSet -freeNamesIfContext = fnList freeNamesIfType - -freeNamesIfAT :: IfaceAT -> NameSet -freeNamesIfAT (IfaceAT decl mb_def) - = freeNamesIfDecl decl &&& - case mb_def of - Nothing -> emptyNameSet - Just rhs -> freeNamesIfType rhs - -freeNamesIfClsSig :: IfaceClassOp -> NameSet -freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm - -freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet -freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty -freeNamesDM _ = emptyNameSet - -freeNamesIfConDecls :: IfaceConDecls -> NameSet -freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c -freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c -freeNamesIfConDecls _ = emptyNameSet - -freeNamesIfConDecl :: IfaceConDecl -> NameSet -freeNamesIfConDecl (IfCon { ifConExTvs = ex_tvs, ifConCtxt = ctxt - , ifConArgTys = arg_tys - , ifConFields = flds - , ifConEqSpec = eq_spec - , ifConStricts = bangs }) - = freeNamesIfTyVarBndrs ex_tvs &&& - freeNamesIfContext ctxt &&& - fnList freeNamesIfType arg_tys &&& - mkNameSet (map flSelector flds) &&& - fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints - fnList freeNamesIfBang bangs - -freeNamesIfBang :: IfaceBang -> NameSet -freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co -freeNamesIfBang _ = emptyNameSet - -freeNamesIfKind :: IfaceType -> NameSet -freeNamesIfKind = freeNamesIfType - -freeNamesIfTcArgs :: IfaceTcArgs -> NameSet -freeNamesIfTcArgs (ITC_Vis t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts -freeNamesIfTcArgs (ITC_Invis k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks -freeNamesIfTcArgs ITC_Nil = emptyNameSet - -freeNamesIfType :: IfaceType -> NameSet -freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet -freeNamesIfType (IfaceTyVar _) = emptyNameSet -freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t -freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts -freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts -freeNamesIfType (IfaceLitTy _) = emptyNameSet -freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTyVarBndr tv &&& freeNamesIfType t -freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t -freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t -freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c -freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c - -freeNamesIfCoercion :: IfaceCoercion -> NameSet -freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t -freeNamesIfCoercion (IfaceFunCo _ c1 c2) - = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) - = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos -freeNamesIfCoercion (IfaceAppCo c1 c2) - = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceForAllCo _ kind_co co) - = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co -freeNamesIfCoercion (IfaceCoVarCo _) - = emptyNameSet -freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) - = unitNameSet ax &&& fnList freeNamesIfCoercion cos -freeNamesIfCoercion (IfaceUnivCo p _ t1 t2) - = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2 -freeNamesIfCoercion (IfaceSymCo c) - = freeNamesIfCoercion c -freeNamesIfCoercion (IfaceTransCo c1 c2) - = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceNthCo _ co) - = freeNamesIfCoercion co -freeNamesIfCoercion (IfaceLRCo _ co) - = freeNamesIfCoercion co -freeNamesIfCoercion (IfaceInstCo co co2) - = freeNamesIfCoercion co &&& freeNamesIfCoercion co2 -freeNamesIfCoercion (IfaceCoherenceCo c1 c2) - = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceKindCo c) - = freeNamesIfCoercion c -freeNamesIfCoercion (IfaceSubCo co) - = freeNamesIfCoercion co -freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos) - -- the axiom is just a string, so we don't count it as a name. - = fnList freeNamesIfCoercion cos - -freeNamesIfProv :: IfaceUnivCoProv -> NameSet -freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet -freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co -freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co -freeNamesIfProv (IfacePluginProv _) = emptyNameSet -freeNamesIfProv (IfaceHoleProv _) = emptyNameSet - -freeNamesIfTyVarBndr :: TyVarBndr IfaceTvBndr vis -> NameSet -freeNamesIfTyVarBndr (TvBndr tv _) = freeNamesIfTvBndr tv - -freeNamesIfTyVarBndrs :: [TyVarBndr IfaceTvBndr vis] -> NameSet -freeNamesIfTyVarBndrs = fnList freeNamesIfTyVarBndr - -freeNamesIfBndr :: IfaceBndr -> NameSet -freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b -freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b - -freeNamesIfBndrs :: [IfaceBndr] -> NameSet -freeNamesIfBndrs = fnList freeNamesIfBndr - -freeNamesIfLetBndr :: IfaceLetBndr -> NameSet --- Remember IfaceLetBndr is used only for *nested* bindings --- The IdInfo can contain an unfolding (in the case of --- local INLINE pragmas), so look there too -freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty - &&& freeNamesIfIdInfo info - -freeNamesIfTvBndr :: IfaceTvBndr -> NameSet -freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k - -- kinds can have Names inside, because of promotion - -freeNamesIfIdBndr :: IfaceIdBndr -> NameSet -freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k - -freeNamesIfIdInfo :: IfaceIdInfo -> NameSet -freeNamesIfIdInfo NoInfo = emptyNameSet -freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i - -freeNamesItem :: IfaceInfoItem -> NameSet -freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u -freeNamesItem _ = emptyNameSet - -freeNamesIfUnfold :: IfaceUnfolding -> NameSet -freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e -freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e -freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e -freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es - -freeNamesIfExpr :: IfaceExpr -> NameSet -freeNamesIfExpr (IfaceExt v) = unitNameSet v -freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty -freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty -freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co -freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as -freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body -freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a -freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co -freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e -freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty -freeNamesIfExpr (IfaceCase s _ alts) - = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts - where - fn_alt (_con,_bs,r) = freeNamesIfExpr r - - -- Depend on the data constructors. Just one will do! - -- Note [Tracking data constructors] - fn_cons [] = emptyNameSet - fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs - fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con - fn_cons (_ : _ ) = emptyNameSet - -freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) - = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body - -freeNamesIfExpr (IfaceLet (IfaceRec as) x) - = fnList fn_pair as &&& freeNamesIfExpr x - where - fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs - -freeNamesIfExpr _ = emptyNameSet - -freeNamesIfTc :: IfaceTyCon -> NameSet -freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) --- ToDo: shouldn't we include IfaceIntTc & co.? - -freeNamesIfRule :: IfaceRule -> NameSet -freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f - , ifRuleArgs = es, ifRuleRhs = rhs }) - = unitNameSet f &&& - fnList freeNamesIfBndr bs &&& - fnList freeNamesIfExpr es &&& - freeNamesIfExpr rhs - -freeNamesIfFamInst :: IfaceFamInst -> NameSet -freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName - , ifFamInstAxiom = axName }) - = unitNameSet famName &&& - unitNameSet axName - -freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet -freeNamesIfaceTyConParent IfNoParent = emptyNameSet -freeNamesIfaceTyConParent (IfDataInstance ax tc tys) - = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys - --- helpers -(&&&) :: NameSet -> NameSet -> NameSet -(&&&) = unionNameSet - -fnList :: (a -> NameSet) -> [a] -> NameSet -fnList f = foldr (&&&) emptyNameSet . map f - -{- -Note [Tracking data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a case expression - case e of { C a -> ...; ... } -You might think that we don't need to include the datacon C -in the free names, because its type will probably show up in -the free names of 'e'. But in rare circumstances this may -not happen. Here's the one that bit me: - - module DynFlags where - import {-# SOURCE #-} Packages( PackageState ) - data DynFlags = DF ... PackageState ... - - module Packages where - import DynFlags - data PackageState = PS ... - lookupModule (df :: DynFlags) - = case df of - DF ...p... -> case p of - PS ... -> ... - -Now, lookupModule depends on DynFlags, but the transitive dependency -on the *locally-defined* type PackageState is not visible. We need -to take account of the use of the data constructor PS in the pattern match. - - -************************************************************************ -* * - Binary instances -* * -************************************************************************ - -Note that there is a bit of subtlety here when we encode names. While -IfaceTopBndrs is really just a synonym for Name, we need to take care to -encode them with {get,put}IfaceTopBndr. The difference becomes important when -we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for -details. - --} - -instance Binary IfaceDecl where - put_ bh (IfaceId name ty details idinfo) = do - putByte bh 0 - putIfaceTopBndr bh name - lazyPut bh (ty, details, idinfo) - -- See Note [Lazy deserialization of IfaceId] - - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do - putByte bh 2 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - - put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do - putByte bh 3 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - - put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do - putByte bh 4 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - - -- NB: Written in a funny way to avoid an interface change - put_ bh (IfaceClass { - ifName = a2, - ifRoles = a3, - ifBinders = a4, - ifFDs = a5, - ifBody = IfConcreteClass { - ifClassCtxt = a1, - ifATs = a6, - ifSigs = a7, - ifMinDef = a8 - }}) = do - putByte bh 5 - put_ bh a1 - putIfaceTopBndr bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - - put_ bh (IfaceAxiom a1 a2 a3 a4) = do - putByte bh 6 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - - put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do - putByte bh 7 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - put_ bh a10 - put_ bh a11 - - put_ bh (IfaceClass { - ifName = a1, - ifRoles = a2, - ifBinders = a3, - ifFDs = a4, - ifBody = IfAbstractClass }) = do - putByte bh 8 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - - get bh = do - h <- getByte bh - case h of - 0 -> do name <- get bh - ~(ty, details, idinfo) <- lazyGet bh - -- See Note [Lazy deserialization of IfaceId] - return (IfaceId name ty details idinfo) - 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) - 3 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - return (IfaceSynonym a1 a2 a3 a4 a5) - 4 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - return (IfaceFamily a1 a2 a3 a4 a5 a6) - 5 -> do a1 <- get bh - a2 <- getIfaceTopBndr bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - return (IfaceClass { - ifName = a2, - ifRoles = a3, - ifBinders = a4, - ifFDs = a5, - ifBody = IfConcreteClass { - ifClassCtxt = a1, - ifATs = a6, - ifSigs = a7, - ifMinDef = a8 - }}) - 6 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - return (IfaceAxiom a1 a2 a3 a4) - 7 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - a10 <- get bh - a11 <- get bh - return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) - 8 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - return (IfaceClass { - ifName = a1, - ifRoles = a2, - ifBinders = a3, - ifFDs = a4, - ifBody = IfAbstractClass }) - _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) - -{- Note [Lazy deserialization of IfaceId] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The use of lazyPut and lazyGet in the IfaceId Binary instance is -purely for performance reasons, to avoid deserializing details about -identifiers that will never be used. It's not involved in tying the -knot in the type checker. It saved ~1% of the total build time of GHC. - -When we read an interface file, we extend the PTE, a mapping of Names -to TyThings, with the declarations we have read. The extension of the -PTE is strict in the Names, but not in the TyThings themselves. -LoadIface.loadDecl calculates the list of (Name, TyThing) bindings to -add to the PTE. For an IfaceId, there's just one binding to add; and -the ty, details, and idinfo fields of an IfaceId are used only in the -TyThing. So by reading those fields lazily we may be able to save the -work of ever having to deserialize them (into IfaceType, etc.). - -For IfaceData and IfaceClass, loadDecl creates extra implicit bindings -(the constructors and field selectors of the data declaration, or the -methods of the class), whose Names depend on more than just the Name -of the type constructor or class itself. So deserializing them lazily -would be more involved. Similar comments apply to the other -constructors of IfaceDecl with the additional point that they probably -represent a small proportion of all declarations. --} - -instance Binary IfaceFamTyConFlav where - put_ bh IfaceDataFamilyTyCon = putByte bh 0 - put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1 - put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb - put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3 - put_ _ IfaceBuiltInSynFamTyCon - = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty - - get bh = do { h <- getByte bh - ; case h of - 0 -> return IfaceDataFamilyTyCon - 1 -> return IfaceOpenSynFamilyTyCon - 2 -> do { mb <- get bh - ; return (IfaceClosedSynFamilyTyCon mb) } - 3 -> return IfaceAbstractClosedSynFamilyTyCon - _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag" - (ppr (fromIntegral h :: Int)) } - -instance Binary IfaceClassOp where - put_ bh (IfaceClassOp n ty def) = do - putIfaceTopBndr bh n - put_ bh ty - put_ bh def - get bh = do - n <- getIfaceTopBndr bh - ty <- get bh - def <- get bh - return (IfaceClassOp n ty def) - -instance Binary IfaceAT where - put_ bh (IfaceAT dec defs) = do - put_ bh dec - put_ bh defs - get bh = do - dec <- get bh - defs <- get bh - return (IfaceAT dec defs) - -instance Binary IfaceAxBranch where - put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - return (IfaceAxBranch a1 a2 a3 a4 a5 a6) - -instance Binary IfaceConDecls where - put_ bh IfAbstractTyCon = putByte bh 0 - put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs - put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c - get bh = do - h <- getByte bh - case h of - 0 -> return IfAbstractTyCon - 1 -> liftM IfDataTyCon (get bh) - 2 -> liftM IfNewTyCon (get bh) - _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" - -instance Binary IfaceConDecl where - put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh (length a8) - mapM_ (put_ bh) a8 - put_ bh a9 - put_ bh a10 - get bh = do - a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - n_fields <- get bh - a8 <- replicateM n_fields (get bh) - a9 <- get bh - a10 <- get bh - return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) - -instance Binary IfaceBang where - put_ bh IfNoBang = putByte bh 0 - put_ bh IfStrict = putByte bh 1 - put_ bh IfUnpack = putByte bh 2 - put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co - - get bh = do - h <- getByte bh - case h of - 0 -> do return IfNoBang - 1 -> do return IfStrict - 2 -> do return IfUnpack - _ -> do { a <- get bh; return (IfUnpackCo a) } - -instance Binary IfaceSrcBang where - put_ bh (IfSrcBang a1 a2) = - do put_ bh a1 - put_ bh a2 - - get bh = - do a1 <- get bh - a2 <- get bh - return (IfSrcBang a1 a2) - -instance Binary IfaceClsInst where - put_ bh (IfaceClsInst cls tys dfun flag orph) = do - put_ bh cls - put_ bh tys - put_ bh dfun - put_ bh flag - put_ bh orph - get bh = do - cls <- get bh - tys <- get bh - dfun <- get bh - flag <- get bh - orph <- get bh - return (IfaceClsInst cls tys dfun flag orph) - -instance Binary IfaceFamInst where - put_ bh (IfaceFamInst fam tys name orph) = do - put_ bh fam - put_ bh tys - put_ bh name - put_ bh orph - get bh = do - fam <- get bh - tys <- get bh - name <- get bh - orph <- get bh - return (IfaceFamInst fam tys name orph) - -instance Binary IfaceRule where - put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) - -instance Binary IfaceAnnotation where - put_ bh (IfaceAnnotation a1 a2) = do - put_ bh a1 - put_ bh a2 - get bh = do - a1 <- get bh - a2 <- get bh - return (IfaceAnnotation a1 a2) - -instance Binary IfaceIdDetails where - put_ bh IfVanillaId = putByte bh 0 - put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b - put_ bh IfDFunId = putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> return IfVanillaId - 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } - _ -> return IfDFunId - -instance Binary IfaceIdInfo where - put_ bh NoInfo = putByte bh 0 - put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut - - get bh = do - h <- getByte bh - case h of - 0 -> return NoInfo - _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet - -instance Binary IfaceInfoItem where - put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa - put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab - put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad - put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad - put_ bh HsNoCafRefs = putByte bh 4 - put_ bh HsLevity = putByte bh 5 - get bh = do - h <- getByte bh - case h of - 0 -> liftM HsArity $ get bh - 1 -> liftM HsStrictness $ get bh - 2 -> do lb <- get bh - ad <- get bh - return (HsUnfold lb ad) - 3 -> liftM HsInline $ get bh - 4 -> return HsNoCafRefs - _ -> return HsLevity - -instance Binary IfaceUnfolding where - put_ bh (IfCoreUnfold s e) = do - putByte bh 0 - put_ bh s - put_ bh e - put_ bh (IfInlineRule a b c d) = do - putByte bh 1 - put_ bh a - put_ bh b - put_ bh c - put_ bh d - put_ bh (IfDFunUnfold as bs) = do - putByte bh 2 - put_ bh as - put_ bh bs - put_ bh (IfCompulsory e) = do - putByte bh 3 - put_ bh e - get bh = do - h <- getByte bh - case h of - 0 -> do s <- get bh - e <- get bh - return (IfCoreUnfold s e) - 1 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (IfInlineRule a b c d) - 2 -> do as <- get bh - bs <- get bh - return (IfDFunUnfold as bs) - _ -> do e <- get bh - return (IfCompulsory e) - - -instance Binary IfaceExpr where - put_ bh (IfaceLcl aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceType ab) = do - putByte bh 1 - put_ bh ab - put_ bh (IfaceCo ab) = do - putByte bh 2 - put_ bh ab - put_ bh (IfaceTuple ac ad) = do - putByte bh 3 - put_ bh ac - put_ bh ad - put_ bh (IfaceLam (ae, os) af) = do - putByte bh 4 - put_ bh ae - put_ bh os - put_ bh af - put_ bh (IfaceApp ag ah) = do - putByte bh 5 - put_ bh ag - put_ bh ah - put_ bh (IfaceCase ai aj ak) = do - putByte bh 6 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh (IfaceLet al am) = do - putByte bh 7 - put_ bh al - put_ bh am - put_ bh (IfaceTick an ao) = do - putByte bh 8 - put_ bh an - put_ bh ao - put_ bh (IfaceLit ap) = do - putByte bh 9 - put_ bh ap - put_ bh (IfaceFCall as at) = do - putByte bh 10 - put_ bh as - put_ bh at - put_ bh (IfaceExt aa) = do - putByte bh 11 - put_ bh aa - put_ bh (IfaceCast ie ico) = do - putByte bh 12 - put_ bh ie - put_ bh ico - put_ bh (IfaceECase a b) = do - putByte bh 13 - put_ bh a - put_ bh b - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (IfaceLcl aa) - 1 -> do ab <- get bh - return (IfaceType ab) - 2 -> do ab <- get bh - return (IfaceCo ab) - 3 -> do ac <- get bh - ad <- get bh - return (IfaceTuple ac ad) - 4 -> do ae <- get bh - os <- get bh - af <- get bh - return (IfaceLam (ae, os) af) - 5 -> do ag <- get bh - ah <- get bh - return (IfaceApp ag ah) - 6 -> do ai <- get bh - aj <- get bh - ak <- get bh - return (IfaceCase ai aj ak) - 7 -> do al <- get bh - am <- get bh - return (IfaceLet al am) - 8 -> do an <- get bh - ao <- get bh - return (IfaceTick an ao) - 9 -> do ap <- get bh - return (IfaceLit ap) - 10 -> do as <- get bh - at <- get bh - return (IfaceFCall as at) - 11 -> do aa <- get bh - return (IfaceExt aa) - 12 -> do ie <- get bh - ico <- get bh - return (IfaceCast ie ico) - 13 -> do a <- get bh - b <- get bh - return (IfaceECase a b) - _ -> panic ("get IfaceExpr " ++ show h) - -instance Binary IfaceTickish where - put_ bh (IfaceHpcTick m ix) = do - putByte bh 0 - put_ bh m - put_ bh ix - put_ bh (IfaceSCC cc tick push) = do - putByte bh 1 - put_ bh cc - put_ bh tick - put_ bh push - put_ bh (IfaceSource src name) = do - putByte bh 2 - put_ bh (srcSpanFile src) - put_ bh (srcSpanStartLine src) - put_ bh (srcSpanStartCol src) - put_ bh (srcSpanEndLine src) - put_ bh (srcSpanEndCol src) - put_ bh name - - get bh = do - h <- getByte bh - case h of - 0 -> do m <- get bh - ix <- get bh - return (IfaceHpcTick m ix) - 1 -> do cc <- get bh - tick <- get bh - push <- get bh - return (IfaceSCC cc tick push) - 2 -> do file <- get bh - sl <- get bh - sc <- get bh - el <- get bh - ec <- get bh - let start = mkRealSrcLoc file sl sc - end = mkRealSrcLoc file el ec - name <- get bh - return (IfaceSource (mkRealSrcSpan start end) name) - _ -> panic ("get IfaceTickish " ++ show h) - -instance Binary IfaceConAlt where - put_ bh IfaceDefault = putByte bh 0 - put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa - put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceDefault - 1 -> liftM IfaceDataAlt $ get bh - _ -> liftM IfaceLitAlt $ get bh - -instance Binary IfaceBinding where - put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab - put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } - _ -> do { ac <- get bh; return (IfaceRec ac) } - -instance Binary IfaceLetBndr where - put_ bh (IfLetBndr a b c d) = do - put_ bh a - put_ bh b - put_ bh c - put_ bh d - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (IfLetBndr a b c d) - -instance Binary IfaceJoinInfo where - put_ bh IfaceNotJoinPoint = putByte bh 0 - put_ bh (IfaceJoinPoint ar) = do - putByte bh 1 - put_ bh ar - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceNotJoinPoint - _ -> liftM IfaceJoinPoint $ get bh - -instance Binary IfaceTyConParent where - put_ bh IfNoParent = putByte bh 0 - put_ bh (IfDataInstance ax pr ty) = do - putByte bh 1 - put_ bh ax - put_ bh pr - put_ bh ty - get bh = do - h <- getByte bh - case h of - 0 -> return IfNoParent - _ -> do - ax <- get bh - pr <- get bh - ty <- get bh - return $ IfDataInstance ax pr ty - -instance Binary IfaceCompleteMatch where - put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts - get bh = IfaceCompleteMatch <$> get bh <*> get bh diff --git a/iface/IfaceType.hs b/iface/IfaceType.hs deleted file mode 100644 --- a/iface/IfaceType.hs +++ /dev/null @@ -1,1552 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - - -This module defines interface types and binders --} - -{-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-} -{-# LANGUAGE MultiWayIf #-} - -- FlexibleInstances for Binary (DefMethSpec IfaceType) - -module IfaceType ( - IfExtName, IfLclName, - - IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), - IfaceUnivCoProv(..), - IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..), - IfaceTyLit(..), IfaceTcArgs(..), - IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, - IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, - IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..), - - ifTyConBinderTyVar, ifTyConBinderName, - - -- Equality testing - IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes, - eqIfaceTcArgs, eqIfaceTvBndrs, isIfaceLiftedTypeKind, - - -- Conversion from IfaceTcArgs -> [IfaceType] - tcArgsIfaceTypes, - - -- Printing - pprIfaceType, pprParendIfaceType, - pprIfaceContext, pprIfaceContextArr, - pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, - pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs, - pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType, - pprIfaceTyLit, - pprIfaceCoercion, pprParendIfaceCoercion, - splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, - pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, - - suppressIfaceInvisibles, - stripIfaceInvisVars, - stripInvisArgs, - substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst, - eqIfaceTvBndr - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon ) - -import DynFlags -import TyCon hiding ( pprPromotionQuote ) -import CoAxiom -import Var -import PrelNames -import Name -import BasicTypes -import Binary -import Outputable -import FastString -import FastStringEnv -import UniqFM -import Util - -import Data.List (foldl') - -{- -************************************************************************ -* * - Local (nested) binders -* * -************************************************************************ --} - -type IfLclName = FastString -- A local name in iface syntax - -type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn - -- (However Internal or System Names never should) - -data IfaceBndr -- Local (non-top-level) binders - = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr - | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr - -type IfaceIdBndr = (IfLclName, IfaceType) -type IfaceTvBndr = (IfLclName, IfaceKind) - -ifaceTvBndrName :: IfaceTvBndr -> IfLclName -ifaceTvBndrName (n,_) = n - -type IfaceLamBndr = (IfaceBndr, IfaceOneShot) - -data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy - = IfaceNoOneShot -- and Note [The oneShot function] in MkId - | IfaceOneShot - - -{- -%************************************************************************ -%* * - IfaceType -%* * -%************************************************************************ --} - -------------------------------- -type IfaceKind = IfaceType - -data IfaceType -- A kind of universal type, used for types and kinds - = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType] - | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon - | IfaceLitTy IfaceTyLit - | IfaceAppTy IfaceType IfaceType - | IfaceFunTy IfaceType IfaceType - | IfaceDFunTy IfaceType IfaceType - | IfaceForAllTy IfaceForAllBndr IfaceType - | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated - -- Includes newtypes, synonyms, tuples - | IfaceCastTy IfaceType IfaceCoercion - | IfaceCoercionTy IfaceCoercion - - | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp) - TupleSort -- What sort of tuple? - IsPromoted -- A bit like IfaceTyCon - IfaceTcArgs -- arity = length args - -- For promoted data cons, the kind args are omitted - -type IfacePredType = IfaceType -type IfaceContext = [IfacePredType] - -data IfaceTyLit - = IfaceNumTyLit Integer - | IfaceStrTyLit FastString - deriving (Eq) - -type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis -type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag - --- See Note [Suppressing invisible arguments] --- We use a new list type (rather than [(IfaceType,Bool)], because --- it'll be more compact and faster to parse in interface --- files. Rather than two bytes and two decisions (nil/cons, and --- type/kind) there'll just be one. -data IfaceTcArgs - = ITC_Nil - | ITC_Vis IfaceType IfaceTcArgs -- "Vis" means show when pretty-printing - | ITC_Invis IfaceKind IfaceTcArgs -- "Invis" means don't show when pretty-printing - -- except with -fprint-explicit-kinds - -instance Monoid IfaceTcArgs where - mempty = ITC_Nil - ITC_Nil `mappend` xs = xs - ITC_Vis ty rest `mappend` xs = ITC_Vis ty (rest `mappend` xs) - ITC_Invis ki rest `mappend` xs = ITC_Invis ki (rest `mappend` xs) - --- Encodes type constructors, kind constructors, --- coercion constructors, the lot. --- We have to tag them in order to pretty print them --- properly. -data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName - , ifaceTyConInfo :: IfaceTyConInfo } - deriving (Eq) - --- | Is a TyCon a promoted data constructor or just a normal type constructor? -data IsPromoted = IsNotPromoted | IsPromoted - deriving (Eq) - --- | The various types of TyCons which have special, built-in syntax. -data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon - - | IfaceTupleTyCon !Arity !TupleSort - -- ^ e.g. @(a, b, c)@ or @(#a, b, c#)@. - -- The arity is the tuple width, not the tycon arity - -- (which is twice the width in the case of unboxed - -- tuples). - - | IfaceSumTyCon !Arity - -- ^ e.g. @(a | b | c)@ - - | IfaceEqualityTyCon !Bool - -- ^ a type equality. 'True' indicates kind-homogeneous. - -- See Note [Equality predicates in IfaceType] for - -- details. - deriving (Eq) - -{- Note [Free tyvars in IfaceType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to an -IfaceType and pretty printing that. This eliminates a lot of -pretty-print duplication, and it matches what we do with -pretty-printing TyThings. - -It works fine for closed types, but when printing debug traces (e.g. -when using -ddump-tc-trace) we print a lot of /open/ types. These -types are full of TcTyVars, and it's absolutely crucial to print them -in their full glory, with their unique, TcTyVarDetails etc. - -So we simply embed a TyVar in IfaceType with the IfaceFreeTyVar constructor. -Note that: - -* We never expect to serialise an IfaceFreeTyVar into an interface file, nor - to deserialise one. IfaceFreeTyVar is used only in the "convert to IfaceType - and then pretty-print" pipeline. - - -Note [Equality predicates in IfaceType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC has several varieties of type equality (see Note [The equality types story] -in TysPrim for details) which all must be rendered with different surface syntax -during pretty-printing. Which syntax we use depends upon, - - 1. Which predicate tycon was used - 2. Whether the types being compared are of the same kind. - -Unfortunately, determining (2) from an IfaceType isn't possible since we can't -see through type synonyms. Consequently, we need to record whether the equality -is homogeneous or not in IfaceTyConSort for the purposes of pretty-printing. - -Namely we handle these cases, - - Predicate Homogeneous Heterogeneous - ---------------- ----------- ------------- - eqTyCon ~ N/A - heqTyCon ~ ~~ - eqPrimTyCon ~# ~~ - eqReprPrimTyCon Coercible Coercible - --} - -data IfaceTyConInfo -- Used to guide pretty-printing - -- and to disambiguate D from 'D (they share a name) - = IfaceTyConInfo { ifaceTyConIsPromoted :: IsPromoted - , ifaceTyConSort :: IfaceTyConSort } - deriving (Eq) - -data IfaceCoercion - = IfaceReflCo Role IfaceType - | IfaceFunCo Role IfaceCoercion IfaceCoercion - | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] - | IfaceAppCo IfaceCoercion IfaceCoercion - | IfaceForAllCo IfaceTvBndr IfaceCoercion IfaceCoercion - | IfaceCoVarCo IfLclName - | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] - | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType - | IfaceSymCo IfaceCoercion - | IfaceTransCo IfaceCoercion IfaceCoercion - | IfaceNthCo Int IfaceCoercion - | IfaceLRCo LeftOrRight IfaceCoercion - | IfaceInstCo IfaceCoercion IfaceCoercion - | IfaceCoherenceCo IfaceCoercion IfaceCoercion - | IfaceKindCo IfaceCoercion - | IfaceSubCo IfaceCoercion - | IfaceAxiomRuleCo IfLclName [IfaceCoercion] - -data IfaceUnivCoProv - = IfaceUnsafeCoerceProv - | IfacePhantomProv IfaceCoercion - | IfaceProofIrrelProv IfaceCoercion - | IfacePluginProv String - | IfaceHoleProv Unique - -- ^ See Note [Holes in IfaceUnivCoProv] - -{- -Note [Holes in IfaceUnivCoProv] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking fails the typechecker will produce a HoleProv UnivCoProv to -stand in place of the unproven assertion. While we generally don't want to let -these unproven assertions leak into interface files, we still need to be able to -pretty-print them as we use IfaceType's pretty-printer to render Types. For this -reason IfaceUnivCoProv has a IfaceHoleProv constructor; however, we fails when -asked to serialize to a IfaceHoleProv to ensure that they don't end up in an -interface file. To avoid an import loop between IfaceType and TyCoRep we only -keep the hole's Unique, since that is all we need to print. --} - -{- -%************************************************************************ -%* * - Functions over IFaceTypes -* * -************************************************************************ --} - -ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool -ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key - -eqIfaceTvBndr :: IfaceTvBndr -> IfaceTvBndr -> Bool -eqIfaceTvBndr (occ1, _) (occ2, _) = occ1 == occ2 - -isIfaceLiftedTypeKind :: IfaceKind -> Bool -isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil) - = isLiftedTypeKindTyConName (ifaceTyConName tc) -isIfaceLiftedTypeKind (IfaceTyConApp tc - (ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil)) - = tc `ifaceTyConHasKey` tYPETyConKey - && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey -isIfaceLiftedTypeKind _ = False - -splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) --- Mainly for printing purposes -splitIfaceSigmaTy ty - = (bndrs, theta, tau) - where - (bndrs, rho) = split_foralls ty - (theta, tau) = split_rho rho - - split_foralls (IfaceForAllTy bndr ty) - = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } - split_foralls rho = ([], rho) - - split_rho (IfaceDFunTy ty1 ty2) - = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } - split_rho tau = ([], tau) - -suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a] -suppressIfaceInvisibles dflags tys xs - | gopt Opt_PrintExplicitKinds dflags = xs - | otherwise = suppress tys xs - where - suppress _ [] = [] - suppress [] a = a - suppress (k:ks) a@(_:xs) - | isInvisibleTyConBinder k = suppress ks xs - | otherwise = a - -stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder] -stripIfaceInvisVars dflags tyvars - | gopt Opt_PrintExplicitKinds dflags = tyvars - | otherwise = filterOut isInvisibleTyConBinder tyvars - --- | Extract a IfaceTvBndr from a IfaceTyConBinder -ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr -ifTyConBinderTyVar = binderVar - --- | Extract the variable name from a IfaceTyConBinder -ifTyConBinderName :: IfaceTyConBinder -> IfLclName -ifTyConBinderName tcb = ifaceTvBndrName (ifTyConBinderTyVar tcb) - -ifTypeIsVarFree :: IfaceType -> Bool --- Returns True if the type definitely has no variables at all --- Just used to control pretty printing -ifTypeIsVarFree ty = go ty - where - go (IfaceTyVar {}) = False - go (IfaceFreeTyVar {}) = False - go (IfaceAppTy fun arg) = go fun && go arg - go (IfaceFunTy arg res) = go arg && go res - go (IfaceDFunTy arg res) = go arg && go res - go (IfaceForAllTy {}) = False - go (IfaceTyConApp _ args) = go_args args - go (IfaceTupleTy _ _ args) = go_args args - go (IfaceLitTy _) = True - go (IfaceCastTy {}) = False -- Safe - go (IfaceCoercionTy {}) = False -- Safe - - go_args ITC_Nil = True - go_args (ITC_Vis arg args) = go arg && go_args args - go_args (ITC_Invis arg args) = go arg && go_args args - -{- -Substitutions on IfaceType. This is only used during pretty-printing to construct -the result type of a GADT, and does not deal with binders (eg IfaceForAll), so -it doesn't need fancy capture stuff. --} - -type IfaceTySubst = FastStringEnv IfaceType - -mkIfaceTySubst :: [IfaceTvBndr] -> [IfaceType] -> IfaceTySubst -mkIfaceTySubst tvs tys = mkFsEnv $ zipWithEqual "mkIfaceTySubst" (\(fs,_) ty -> (fs,ty)) tvs tys - -substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType -substIfaceType env ty - = go ty - where - go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv - go (IfaceTyVar tv) = substIfaceTyVar env tv - go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2) - go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2) - go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2) - go ty@(IfaceLitTy {}) = ty - go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys) - go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys) - go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) - go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co) - go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co) - - go_co (IfaceReflCo r ty) = IfaceReflCo r (go ty) - go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2) - go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) - go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) - go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) - go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv - go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos) - go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) - go_co (IfaceSymCo co) = IfaceSymCo (go_co co) - go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) - go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co) - go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co) - go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) - go_co (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo (go_co c1) (go_co c2) - go_co (IfaceKindCo co) = IfaceKindCo (go_co co) - go_co (IfaceSubCo co) = IfaceSubCo (go_co co) - go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos) - - go_cos = map go_co - - go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv - go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) - go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) - go_prov (IfacePluginProv str) = IfacePluginProv str - go_prov (IfaceHoleProv h) = IfaceHoleProv h - -substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs -substIfaceTcArgs env args - = go args - where - go ITC_Nil = ITC_Nil - go (ITC_Vis ty tys) = ITC_Vis (substIfaceType env ty) (go tys) - go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys) - -substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType -substIfaceTyVar env tv - | Just ty <- lookupFsEnv env tv = ty - | otherwise = IfaceTyVar tv - -{- -************************************************************************ -* * - Equality over IfaceTypes -* * -************************************************************************ - -Note [No kind check in ifaces] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We check iface types for equality only when checking the consistency -between two user-written signatures. In these cases, there is no possibility -for a kind mismatch. So we omit the kind check (which would be impossible to -write, anyway.) - --} - --- Like an RnEnv2, but mapping from FastString to deBruijn index --- DeBruijn; see eqTypeX -type BoundVar = Int -data IfRnEnv2 - = IRV2 { ifenvL :: UniqFM BoundVar -- from FastString - , ifenvR :: UniqFM BoundVar - , ifenv_next :: BoundVar - } - -emptyIfRnEnv2 :: IfRnEnv2 -emptyIfRnEnv2 = IRV2 { ifenvL = emptyUFM - , ifenvR = emptyUFM - , ifenv_next = 0 } - -rnIfOccL :: IfRnEnv2 -> IfLclName -> Maybe BoundVar -rnIfOccL env = lookupUFM (ifenvL env) - -rnIfOccR :: IfRnEnv2 -> IfLclName -> Maybe BoundVar -rnIfOccR env = lookupUFM (ifenvR env) - -extendIfRnEnv2 :: IfRnEnv2 -> IfLclName -> IfLclName -> IfRnEnv2 -extendIfRnEnv2 IRV2 { ifenvL = lenv - , ifenvR = renv - , ifenv_next = n } tv1 tv2 - = IRV2 { ifenvL = addToUFM lenv tv1 n - , ifenvR = addToUFM renv tv2 n - , ifenv_next = n + 1 - } - --- See Note [No kind check in ifaces] -eqIfaceType :: IfRnEnv2 -> IfaceType -> IfaceType -> Bool -eqIfaceType _ (IfaceFreeTyVar tv1) (IfaceFreeTyVar tv2) - = tv1 == tv2 -- Should not happen -eqIfaceType env (IfaceTyVar tv1) (IfaceTyVar tv2) = - case (rnIfOccL env tv1, rnIfOccR env tv2) of - (Just v1, Just v2) -> v1 == v2 - (Nothing, Nothing) -> tv1 == tv2 - _ -> False -eqIfaceType _ (IfaceLitTy l1) (IfaceLitTy l2) = l1 == l2 -eqIfaceType env (IfaceAppTy t11 t12) (IfaceAppTy t21 t22) - = eqIfaceType env t11 t21 && eqIfaceType env t12 t22 -eqIfaceType env (IfaceFunTy t11 t12) (IfaceFunTy t21 t22) - = eqIfaceType env t11 t21 && eqIfaceType env t12 t22 -eqIfaceType env (IfaceDFunTy t11 t12) (IfaceDFunTy t21 t22) - = eqIfaceType env t11 t21 && eqIfaceType env t12 t22 -eqIfaceType env (IfaceForAllTy bndr1 t1) (IfaceForAllTy bndr2 t2) - = eqIfaceForAllBndr env bndr1 bndr2 (\env' -> eqIfaceType env' t1 t2) -eqIfaceType env (IfaceTyConApp tc1 tys1) (IfaceTyConApp tc2 tys2) - = tc1 == tc2 && eqIfaceTcArgs env tys1 tys2 -eqIfaceType env (IfaceTupleTy s1 tc1 tys1) (IfaceTupleTy s2 tc2 tys2) - = s1 == s2 && tc1 == tc2 && eqIfaceTcArgs env tys1 tys2 -eqIfaceType env (IfaceCastTy t1 _) (IfaceCastTy t2 _) - = eqIfaceType env t1 t2 -eqIfaceType _ (IfaceCoercionTy {}) (IfaceCoercionTy {}) - = True -eqIfaceType _ _ _ = False - -eqIfaceTypes :: IfRnEnv2 -> [IfaceType] -> [IfaceType] -> Bool -eqIfaceTypes env tys1 tys2 = and (zipWith (eqIfaceType env) tys1 tys2) - -eqIfaceForAllBndr :: IfRnEnv2 -> IfaceForAllBndr -> IfaceForAllBndr - -> (IfRnEnv2 -> Bool) -- continuation - -> Bool -eqIfaceForAllBndr env (TvBndr (tv1, k1) vis1) (TvBndr (tv2, k2) vis2) k - = eqIfaceType env k1 k2 && vis1 == vis2 && - k (extendIfRnEnv2 env tv1 tv2) - -eqIfaceTcArgs :: IfRnEnv2 -> IfaceTcArgs -> IfaceTcArgs -> Bool -eqIfaceTcArgs _ ITC_Nil ITC_Nil = True -eqIfaceTcArgs env (ITC_Vis ty1 tys1) (ITC_Vis ty2 tys2) - = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2 -eqIfaceTcArgs env (ITC_Invis ty1 tys1) (ITC_Invis ty2 tys2) - = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2 -eqIfaceTcArgs _ _ _ = False - --- | Similar to 'eqTyVarBndrs', checks that tyvar lists --- are the same length and have matching kinds; if so, extend the --- 'IfRnEnv2'. Returns 'Nothing' if they don't match. -eqIfaceTvBndrs :: IfRnEnv2 -> [IfaceTvBndr] -> [IfaceTvBndr] -> Maybe IfRnEnv2 -eqIfaceTvBndrs env [] [] = Just env -eqIfaceTvBndrs env ((tv1, k1):tvs1) ((tv2, k2):tvs2) - | eqIfaceType env k1 k2 - = eqIfaceTvBndrs (extendIfRnEnv2 env tv1 tv2) tvs1 tvs2 -eqIfaceTvBndrs _ _ _ = Nothing - -{- -************************************************************************ -* * - Functions over IFaceTcArgs -* * -************************************************************************ --} - -stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs -stripInvisArgs dflags tys - | gopt Opt_PrintExplicitKinds dflags = tys - | otherwise = suppress_invis tys - where - suppress_invis c - = case c of - ITC_Invis _ ts -> suppress_invis ts - _ -> c - -tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType] -tcArgsIfaceTypes ITC_Nil = [] -tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts -tcArgsIfaceTypes (ITC_Vis t ts) = t : tcArgsIfaceTypes ts - -ifaceVisTcArgsLength :: IfaceTcArgs -> Int -ifaceVisTcArgsLength = go 0 - where - go !n ITC_Nil = n - go n (ITC_Vis _ rest) = go (n+1) rest - go n (ITC_Invis _ rest) = go n rest - -{- -Note [Suppressing invisible arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use the IfaceTcArgs to specify which of the arguments to a type -constructor should be displayed when pretty-printing, under -the control of -fprint-explicit-kinds. -See also Type.filterOutInvisibleTypes. -For example, given - T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism - 'Just :: forall k. k -> 'Maybe k -- Promoted -we want - T * Tree Int prints as T Tree Int - 'Just * prints as Just * - - -************************************************************************ -* * - Pretty-printing -* * -************************************************************************ --} - -if_print_coercions :: SDoc -- ^ if printing coercions - -> SDoc -- ^ otherwise - -> SDoc -if_print_coercions yes no - = sdocWithDynFlags $ \dflags -> - getPprStyle $ \style -> - if gopt Opt_PrintExplicitCoercions dflags - || dumpStyle style || debugStyle style - then yes - else no - -pprIfaceInfixApp :: (TyPrec -> a -> SDoc) -> TyPrec -> SDoc -> a -> a -> SDoc -pprIfaceInfixApp pp p pp_tc ty1 ty2 - = maybeParen p FunPrec $ - sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2] - -pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc -pprIfacePrefixApp p pp_fun pp_tys - | null pp_tys = pp_fun - | otherwise = maybeParen p TyConPrec $ - hang pp_fun 2 (sep pp_tys) - --- ----------------------------- Printing binders ------------------------------------ - -instance Outputable IfaceBndr where - ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr - ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr False bndr - -pprIfaceBndrs :: [IfaceBndr] -> SDoc -pprIfaceBndrs bs = sep (map ppr bs) - -pprIfaceLamBndr :: IfaceLamBndr -> SDoc -pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b -pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" - -pprIfaceIdBndr :: IfaceIdBndr -> SDoc -pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty) - -pprIfaceTvBndr :: Bool -> IfaceTvBndr -> SDoc -pprIfaceTvBndr use_parens (tv, ki) - | isIfaceLiftedTypeKind ki = ppr tv - | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki) - where - maybe_parens | use_parens = parens - | otherwise = id - -pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc -pprIfaceTyConBinders = sep . map go - where - go tcb = pprIfaceTvBndr True (ifTyConBinderTyVar tcb) - -instance Binary IfaceBndr where - put_ bh (IfaceIdBndr aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceTvBndr ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (IfaceIdBndr aa) - _ -> do ab <- get bh - return (IfaceTvBndr ab) - -instance Binary IfaceOneShot where - put_ bh IfaceNoOneShot = do - putByte bh 0 - put_ bh IfaceOneShot = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return IfaceNoOneShot - _ -> do return IfaceOneShot - --- ----------------------------- Printing IfaceType ------------------------------------ - ---------------------------------- -instance Outputable IfaceType where - ppr ty = pprIfaceType ty - -pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc -pprIfaceType = eliminateRuntimeRep (ppr_ty TopPrec) -pprParendIfaceType = eliminateRuntimeRep (ppr_ty TyConPrec) - -ppr_ty :: TyPrec -> IfaceType -> SDoc -ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reson for IfaceFreeTyVar! -ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [TcTyVars in IfaceType] -ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys -ppr_ty _ (IfaceTupleTy i p tys) = pprTuple i p tys -ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n - -- Function types -ppr_ty ctxt_prec (IfaceFunTy ty1 ty2) - = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. - maybeParen ctxt_prec FunPrec $ - sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)] - where - ppr_fun_tail (IfaceFunTy ty1 ty2) - = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2 - ppr_fun_tail other_ty - = [arrow <+> pprIfaceType other_ty] - -ppr_ty ctxt_prec (IfaceAppTy ty1 ty2) - = if_print_coercions - ppr_app_ty - ppr_app_ty_no_casts - where - ppr_app_ty = - maybeParen ctxt_prec TyConPrec - $ ppr_ty FunPrec ty1 <+> ppr_ty TyConPrec ty2 - - -- Strip any casts from the head of the application - ppr_app_ty_no_casts = - case split_app_tys ty1 (ITC_Vis ty2 ITC_Nil) of - (IfaceCastTy head _, args) -> ppr_ty ctxt_prec (mk_app_tys head args) - _ -> ppr_app_ty - - split_app_tys :: IfaceType -> IfaceTcArgs -> (IfaceType, IfaceTcArgs) - split_app_tys (IfaceAppTy t1 t2) args = split_app_tys t1 (t2 `ITC_Vis` args) - split_app_tys head args = (head, args) - - mk_app_tys :: IfaceType -> IfaceTcArgs -> IfaceType - mk_app_tys (IfaceTyConApp tc tys1) tys2 = - IfaceTyConApp tc (tys1 `mappend` tys2) - mk_app_tys t1 tys2 = - foldl' IfaceAppTy t1 (tcArgsIfaceTypes tys2) - -ppr_ty ctxt_prec (IfaceCastTy ty co) - = if_print_coercions - (parens (ppr_ty TopPrec ty <+> text "|>" <+> ppr co)) - (ppr_ty ctxt_prec ty) - -ppr_ty ctxt_prec (IfaceCoercionTy co) - = if_print_coercions - (ppr_co ctxt_prec co) - (text "<>") - -ppr_ty ctxt_prec ty - = maybeParen ctxt_prec FunPrec (pprIfaceSigmaType ShowForAllMust ty) - -{- -Note [Defaulting RuntimeRep variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -RuntimeRep variables are considered by many (most?) users to be little more than -syntactic noise. When the notion was introduced there was a signficant and -understandable push-back from those with pedagogy in mind, which argued that -RuntimeRep variables would throw a wrench into nearly any teach approach since -they appear in even the lowly ($) function's type, - - ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b - -which is significantly less readable than its non RuntimeRep-polymorphic type of - - ($) :: (a -> b) -> a -> b - -Moreover, unboxed types don't appear all that often in run-of-the-mill Haskell -programs, so it makes little sense to make all users pay this syntactic -overhead. - -For this reason it was decided that we would hide RuntimeRep variables for now -(see #11549). We do this by defaulting all type variables of kind RuntimeRep to -PtrLiftedRep. This is done in a pass right before pretty-printing -(defaultRuntimeRepVars, controlled by -fprint-explicit-runtime-reps) --} - --- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g. --- --- @ --- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). --- (a -> b) -> a -> b --- @ --- --- turns in to, --- --- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ --- --- We do this to prevent RuntimeRep variables from incurring a significant --- syntactic overhead in otherwise simple type signatures (e.g. ($)). See --- Note [Defaulting RuntimeRep variables] and #11549 for further discussion. --- -defaultRuntimeRepVars :: IfaceType -> IfaceType -defaultRuntimeRepVars = go emptyFsEnv - where - go :: FastStringEnv () -> IfaceType -> IfaceType - go subs (IfaceForAllTy bndr ty) - | isRuntimeRep var_kind - = let subs' = extendFsEnv subs var () - in go subs' ty - | otherwise - = IfaceForAllTy (TvBndr (var, go subs var_kind) (binderArgFlag bndr)) - (go subs ty) - where - var :: IfLclName - (var, var_kind) = binderVar bndr - - go subs (IfaceTyVar tv) - | tv `elemFsEnv` subs - = IfaceTyConApp liftedRep ITC_Nil - - go subs (IfaceFunTy kind ty) - = IfaceFunTy (go subs kind) (go subs ty) - - go subs (IfaceAppTy x y) - = IfaceAppTy (go subs x) (go subs y) - - go subs (IfaceDFunTy x y) - = IfaceDFunTy (go subs x) (go subs y) - - go subs (IfaceCastTy x co) - = IfaceCastTy (go subs x) co - - go _ other = other - - liftedRep :: IfaceTyCon - liftedRep = - IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon) - where dc_name = getName liftedRepDataConTyCon - - isRuntimeRep :: IfaceType -> Bool - isRuntimeRep (IfaceTyConApp tc _) = - tc `ifaceTyConHasKey` runtimeRepTyConKey - isRuntimeRep _ = False - -eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc -eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitRuntimeReps dflags - then f ty - else f (defaultRuntimeRepVars ty) - -instance Outputable IfaceTcArgs where - ppr tca = pprIfaceTcArgs tca - -pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc -pprIfaceTcArgs = ppr_tc_args TopPrec -pprParendIfaceTcArgs = ppr_tc_args TyConPrec - -ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc -ppr_tc_args ctx_prec args - = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts - in case args of - ITC_Nil -> empty - ITC_Vis t ts -> pprTys t ts - ITC_Invis t ts -> pprTys t ts - -------------------- -pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc -pprIfaceForAllPart tvs ctxt sdoc - = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc - -pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc -pprIfaceForAllCoPart tvs sdoc - = sep [ pprIfaceForAllCo tvs, sdoc ] - -ppr_iface_forall_part :: ShowForAllFlag - -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc -ppr_iface_forall_part show_forall tvs ctxt sdoc - = sep [ case show_forall of - ShowForAllMust -> pprIfaceForAll tvs - ShowForAllWhen -> pprUserIfaceForAll tvs - , pprIfaceContextArr ctxt - , sdoc] - --- | Render the "forall ... ." or "forall ... ->" bit of a type. -pprIfaceForAll :: [IfaceForAllBndr] -> SDoc -pprIfaceForAll [] = empty -pprIfaceForAll bndrs@(TvBndr _ vis : _) - = add_separator (forAllLit <+> doc) <+> pprIfaceForAll bndrs' - where - (bndrs', doc) = ppr_itv_bndrs bndrs vis - - add_separator stuff = case vis of - Required -> stuff <+> arrow - _inv -> stuff <> dot - - --- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. --- Returns both the list of not-yet-rendered binders and the doc. --- No anonymous binders here! -ppr_itv_bndrs :: [IfaceForAllBndr] - -> ArgFlag -- ^ visibility of the first binder in the list - -> ([IfaceForAllBndr], SDoc) -ppr_itv_bndrs all_bndrs@(bndr@(TvBndr _ vis) : bndrs) vis1 - | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in - (bndrs', pprIfaceForAllBndr bndr <+> doc) - | otherwise = (all_bndrs, empty) -ppr_itv_bndrs [] _ = ([], empty) - -pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc -pprIfaceForAllCo [] = empty -pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot - -pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc -pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs - -pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc -pprIfaceForAllBndr (TvBndr tv Inferred) = sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitForalls dflags - then braces $ pprIfaceTvBndr False tv - else pprIfaceTvBndr True tv -pprIfaceForAllBndr (TvBndr tv _) = pprIfaceTvBndr True tv - -pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc -pprIfaceForAllCoBndr (tv, kind_co) - = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co) - --- | Show forall flag --- --- Unconditionally show the forall quantifier with ('ShowForAllMust') --- or when ('ShowForAllWhen') the names used are free in the binder --- or when compiling with -fprint-explicit-foralls. -data ShowForAllFlag = ShowForAllMust | ShowForAllWhen - -pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc -pprIfaceSigmaType show_forall ty - = ppr_iface_forall_part show_forall tvs theta (ppr tau) - where - (tvs, theta, tau) = splitIfaceSigmaTy ty - -pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc -pprUserIfaceForAll tvs - = sdocWithDynFlags $ \dflags -> - ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $ - pprIfaceForAll tvs - where - tv_has_kind_var (TvBndr (_,kind) _) = not (ifTypeIsVarFree kind) - - -------------------- - --- See equivalent function in TyCoRep.hs -pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc --- Given a type-level list (t1 ': t2), see if we can print --- it in list notation [t1, ...]. --- Precondition: Opt_PrintExplicitKinds is off -pprIfaceTyList ctxt_prec ty1 ty2 - = case gather ty2 of - (arg_tys, Nothing) - -> char '\'' <> brackets (fsep (punctuate comma - (map (ppr_ty TopPrec) (ty1:arg_tys)))) - (arg_tys, Just tl) - -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1) - 2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]]) - where - gather :: IfaceType -> ([IfaceType], Maybe IfaceType) - -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] - -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl - gather (IfaceTyConApp tc tys) - | tc `ifaceTyConHasKey` consDataConKey - , (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys - , (args, tl) <- gather ty2 - = (ty1:args, tl) - | tc `ifaceTyConHasKey` nilDataConKey - = ([], Nothing) - gather ty = ([], Just ty) - -pprIfaceTypeApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc -pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args - -pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc -pprTyTcApp ctxt_prec tc tys = - sdocWithDynFlags $ \dflags -> - getPprStyle $ \style -> - pprTyTcApp' ctxt_prec tc tys dflags style - -pprTyTcApp' :: TyPrec -> IfaceTyCon -> IfaceTcArgs - -> DynFlags -> PprStyle -> SDoc -pprTyTcApp' ctxt_prec tc tys dflags style - | ifaceTyConName tc `hasKey` ipClassKey - , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys - = maybeParen ctxt_prec FunPrec - $ char '?' <> ftext n <> text "::" <> ppr_ty TopPrec ty - - | IfaceTupleTyCon arity sort <- ifaceTyConSort info - , not (debugStyle style) - , arity == ifaceVisTcArgsLength tys - = pprTuple sort (ifaceTyConIsPromoted info) tys - - | IfaceSumTyCon arity <- ifaceTyConSort info - = pprSum arity (ifaceTyConIsPromoted info) tys - - | tc `ifaceTyConHasKey` consDataConKey - , not (gopt Opt_PrintExplicitKinds dflags) - , ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys - = pprIfaceTyList ctxt_prec ty1 ty2 - - | tc `ifaceTyConHasKey` tYPETyConKey - , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys - , rep `ifaceTyConHasKey` liftedRepDataConKey - = kindStar - - | otherwise - = sdocWithPprDebug $ \dbg -> - if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey - -- Suppress detail unles you _really_ want to see - -> text "(TypeError ...)" - - | Just doc <- ppr_equality tc (tcArgsIfaceTypes tys) - -> maybeParen ctxt_prec TyConPrec doc - - | otherwise - -> ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds - where - info = ifaceTyConInfo tc - tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys - --- | Pretty-print a type-level equality. --- --- See Note [Equality predicates in IfaceType]. -ppr_equality :: IfaceTyCon -> [IfaceType] -> Maybe SDoc -ppr_equality tc args - | hetero_eq_tc - , [k1, k2, t1, t2] <- args - = Just $ print_equality (k1, k2, t1, t2) - - | hom_eq_tc - , [k, t1, t2] <- args - = Just $ print_equality (k, k, t1, t2) - - | otherwise - = Nothing - where - homogeneous = case ifaceTyConSort $ ifaceTyConInfo tc of - IfaceEqualityTyCon hom -> hom - _other -> pprPanic "ppr_equality: homogeneity" (ppr tc) - tc_name = ifaceTyConName tc - pp = ppr_ty - hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~) - hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#) - || tc_name `hasKey` eqReprPrimTyConKey -- (~R#) - || tc_name `hasKey` heqTyConKey -- (~~) - - print_equality args = - sdocWithDynFlags - $ \dflags -> getPprStyle - $ \style -> print_equality' args style dflags - - print_equality' (ki1, ki2, ty1, ty2) style dflags - | print_eqs - = ppr_infix_eq (ppr tc) - - | hetero_eq_tc - , print_kinds || not homogeneous - = ppr_infix_eq (text "~~") - - | otherwise - = if tc_name `hasKey` eqReprPrimTyConKey - then text "Coercible" - <+> sep [ pp TyConPrec ty1, pp TyConPrec ty2 ] - else sep [pp TyOpPrec ty1, char '~', pp TyOpPrec ty2] - where - ppr_infix_eq eq_op - = sep [ parens (pp TyOpPrec ty1 <+> dcolon <+> pp TyOpPrec ki1) - , eq_op - , parens (pp TyOpPrec ty2 <+> dcolon <+> pp TyOpPrec ki2) ] - - print_kinds = gopt Opt_PrintExplicitKinds dflags - print_eqs = gopt Opt_PrintEqualityRelations dflags || - dumpStyle style || debugStyle style - - -pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc -pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys - -ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc -ppr_iface_tc_app pp _ tc [ty] - | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) - | tc `ifaceTyConHasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) - -ppr_iface_tc_app pp ctxt_prec tc tys - | tc `ifaceTyConHasKey` starKindTyConKey - || tc `ifaceTyConHasKey` liftedTypeKindTyConKey - || tc `ifaceTyConHasKey` unicodeStarKindTyConKey - = kindStar -- Handle unicode; do not wrap * in parens - - | not (isSymOcc (nameOccName (ifaceTyConName tc))) - = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys) - - | [ty1,ty2] <- tys -- Infix, two arguments; - -- we know nothing of precedence though - = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2 - - | otherwise - = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys) - -pprSum :: Arity -> IsPromoted -> IfaceTcArgs -> SDoc -pprSum _arity is_promoted args - = -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - let tys = tcArgsIfaceTypes args - args' = drop (length tys `div` 2) tys - in pprPromotionQuoteI is_promoted - <> sumParens (pprWithBars (ppr_ty TopPrec) args') - -pprTuple :: TupleSort -> IsPromoted -> IfaceTcArgs -> SDoc -pprTuple ConstraintTuple IsNotPromoted ITC_Nil - = text "() :: Constraint" - --- All promoted constructors have kind arguments -pprTuple sort IsPromoted args - = let tys = tcArgsIfaceTypes args - args' = drop (length tys `div` 2) tys - in pprPromotionQuoteI IsPromoted <> - tupleParens sort (pprWithCommas pprIfaceType args') - -pprTuple sort promoted args - = -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - let tys = tcArgsIfaceTypes args - args' = case sort of - UnboxedTuple -> drop (length tys `div` 2) tys - _ -> tys - in - pprPromotionQuoteI promoted <> - tupleParens sort (pprWithCommas pprIfaceType args') - -pprIfaceTyLit :: IfaceTyLit -> SDoc -pprIfaceTyLit (IfaceNumTyLit n) = integer n -pprIfaceTyLit (IfaceStrTyLit n) = text (show n) - -pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc -pprIfaceCoercion = ppr_co TopPrec -pprParendIfaceCoercion = ppr_co TyConPrec - -ppr_co :: TyPrec -> IfaceCoercion -> SDoc -ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r -ppr_co ctxt_prec (IfaceFunCo r co1 co2) - = maybeParen ctxt_prec FunPrec $ - sep (ppr_co FunPrec co1 : ppr_fun_tail co2) - where - ppr_fun_tail (IfaceFunCo r co1 co2) - = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2 - ppr_fun_tail other_co - = [arrow <> ppr_role r <+> pprIfaceCoercion other_co] - -ppr_co _ (IfaceTyConAppCo r tc cos) - = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r -ppr_co ctxt_prec (IfaceAppCo co1 co2) - = maybeParen ctxt_prec TyConPrec $ - ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2 -ppr_co ctxt_prec co@(IfaceForAllCo {}) - = maybeParen ctxt_prec FunPrec (pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)) - where - (tvs, inner_co) = split_co co - - split_co (IfaceForAllCo (name, _) kind_co co') - = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') - split_co co' = ([], co') - -ppr_co _ (IfaceCoVarCo covar) = ppr covar - -ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2) - = maybeParen ctxt_prec TyConPrec $ - text "UnsafeCo" <+> ppr r <+> - pprParendIfaceType ty1 <+> pprParendIfaceType ty2 - -ppr_co _ctxt_prec (IfaceUnivCo (IfaceHoleProv u) _ _ _) - = braces $ ppr u - -ppr_co _ (IfaceUnivCo _ _ ty1 ty2) - = angleBrackets ( ppr ty1 <> comma <+> ppr ty2 ) - -ppr_co ctxt_prec (IfaceInstCo co ty) - = maybeParen ctxt_prec TyConPrec $ - text "Inst" <+> pprParendIfaceCoercion co - <+> pprParendIfaceCoercion ty - -ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos) - = maybeParen ctxt_prec TyConPrec $ ppr tc <+> parens (interpp'SP cos) - -ppr_co ctxt_prec (IfaceAxiomInstCo n i cos) - = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos -ppr_co ctxt_prec (IfaceSymCo co) - = ppr_special_co ctxt_prec (text "Sym") [co] -ppr_co ctxt_prec (IfaceTransCo co1 co2) - = ppr_special_co ctxt_prec (text "Trans") [co1,co2] -ppr_co ctxt_prec (IfaceNthCo d co) - = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co] -ppr_co ctxt_prec (IfaceLRCo lr co) - = ppr_special_co ctxt_prec (ppr lr) [co] -ppr_co ctxt_prec (IfaceSubCo co) - = ppr_special_co ctxt_prec (text "Sub") [co] -ppr_co ctxt_prec (IfaceCoherenceCo co1 co2) - = ppr_special_co ctxt_prec (text "Coh") [co1,co2] -ppr_co ctxt_prec (IfaceKindCo co) - = ppr_special_co ctxt_prec (text "Kind") [co] - -ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc -ppr_special_co ctxt_prec doc cos - = maybeParen ctxt_prec TyConPrec - (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) - -ppr_role :: Role -> SDoc -ppr_role r = underscore <> pp_role - where pp_role = case r of - Nominal -> char 'N' - Representational -> char 'R' - Phantom -> char 'P' - -------------------- -instance Outputable IfaceTyCon where - ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) - -pprPromotionQuote :: IfaceTyCon -> SDoc -pprPromotionQuote tc = - pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc - -pprPromotionQuoteI :: IsPromoted -> SDoc -pprPromotionQuoteI IsNotPromoted = empty -pprPromotionQuoteI IsPromoted = char '\'' - -instance Outputable IfaceCoercion where - ppr = pprIfaceCoercion - -instance Binary IfaceTyCon where - put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i - - get bh = do n <- get bh - i <- get bh - return (IfaceTyCon n i) - -instance Binary IsPromoted where - put_ bh IsNotPromoted = putByte bh 0 - put_ bh IsPromoted = putByte bh 1 - - get bh = do - n <- getByte bh - case n of - 0 -> return IsNotPromoted - 1 -> return IsPromoted - _ -> fail "Binary(IsPromoted): fail)" - -instance Binary IfaceTyConSort where - put_ bh IfaceNormalTyCon = putByte bh 0 - put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort - put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity - put_ bh (IfaceEqualityTyCon hom) - | hom = putByte bh 3 - | otherwise = putByte bh 4 - - get bh = do - n <- getByte bh - case n of - 0 -> return IfaceNormalTyCon - 1 -> IfaceTupleTyCon <$> get bh <*> get bh - 2 -> IfaceSumTyCon <$> get bh - 3 -> return $ IfaceEqualityTyCon True - 4 -> return $ IfaceEqualityTyCon False - _ -> fail "Binary(IfaceTyConSort): fail" - -instance Binary IfaceTyConInfo where - put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s - - get bh = IfaceTyConInfo <$> get bh <*> get bh - -instance Outputable IfaceTyLit where - ppr = pprIfaceTyLit - -instance Binary IfaceTyLit where - put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n - put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n - - get bh = - do tag <- getByte bh - case tag of - 1 -> do { n <- get bh - ; return (IfaceNumTyLit n) } - 2 -> do { n <- get bh - ; return (IfaceStrTyLit n) } - _ -> panic ("get IfaceTyLit " ++ show tag) - -instance Binary IfaceTcArgs where - put_ bh tk = - case tk of - ITC_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts - ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts - ITC_Nil -> putByte bh 2 - - get bh = - do c <- getByte bh - case c of - 0 -> do - t <- get bh - ts <- get bh - return $! ITC_Vis t ts - 1 -> do - t <- get bh - ts <- get bh - return $! ITC_Invis t ts - 2 -> return ITC_Nil - _ -> panic ("get IfaceTcArgs " ++ show c) - -------------------- - --- Some notes about printing contexts --- --- In the event that we are printing a singleton context (e.g. @Eq a@) we can --- omit parentheses. However, we must take care to set the precedence correctly --- to TyOpPrec, since something like @a :~: b@ must be parenthesized (see --- #9658). --- --- When printing a larger context we use 'fsep' instead of 'sep' so that --- the context doesn't get displayed as a giant column. Rather than, --- instance (Eq a, --- Eq b, --- Eq c, --- Eq d, --- Eq e, --- Eq f, --- Eq g, --- Eq h, --- Eq i, --- Eq j, --- Eq k, --- Eq l) => --- Eq (a, b, c, d, e, f, g, h, i, j, k, l) --- --- we want --- --- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, --- Eq j, Eq k, Eq l) => --- Eq (a, b, c, d, e, f, g, h, i, j, k, l) - - - --- | Prints "(C a, D b) =>", including the arrow. This is used when we want to --- print a context in a type. -pprIfaceContextArr :: [IfacePredType] -> SDoc -pprIfaceContextArr [] = empty -pprIfaceContextArr [pred] = ppr_ty TyOpPrec pred <+> darrow -pprIfaceContextArr preds = - parens (fsep (punctuate comma (map ppr preds))) <+> darrow - --- | Prints a context or @()@ if empty. This is used when, e.g., we want to --- display a context in an error message. -pprIfaceContext :: [IfacePredType] -> SDoc -pprIfaceContext [] = parens empty -pprIfaceContext [pred] = ppr_ty TyOpPrec pred -pprIfaceContext preds = parens (fsep (punctuate comma (map ppr preds))) - -instance Binary IfaceType where - put_ _ (IfaceFreeTyVar tv) - = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv) - - put_ bh (IfaceForAllTy aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (IfaceTyVar ad) = do - putByte bh 1 - put_ bh ad - put_ bh (IfaceAppTy ae af) = do - putByte bh 2 - put_ bh ae - put_ bh af - put_ bh (IfaceFunTy ag ah) = do - putByte bh 3 - put_ bh ag - put_ bh ah - put_ bh (IfaceDFunTy ag ah) = do - putByte bh 4 - put_ bh ag - put_ bh ah - put_ bh (IfaceTyConApp tc tys) - = do { putByte bh 5; put_ bh tc; put_ bh tys } - put_ bh (IfaceCastTy a b) - = do { putByte bh 6; put_ bh a; put_ bh b } - put_ bh (IfaceCoercionTy a) - = do { putByte bh 7; put_ bh a } - put_ bh (IfaceTupleTy s i tys) - = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } - put_ bh (IfaceLitTy n) - = do { putByte bh 9; put_ bh n } - - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (IfaceForAllTy aa ab) - 1 -> do ad <- get bh - return (IfaceTyVar ad) - 2 -> do ae <- get bh - af <- get bh - return (IfaceAppTy ae af) - 3 -> do ag <- get bh - ah <- get bh - return (IfaceFunTy ag ah) - 4 -> do ag <- get bh - ah <- get bh - return (IfaceDFunTy ag ah) - 5 -> do { tc <- get bh; tys <- get bh - ; return (IfaceTyConApp tc tys) } - 6 -> do { a <- get bh; b <- get bh - ; return (IfaceCastTy a b) } - 7 -> do { a <- get bh - ; return (IfaceCoercionTy a) } - - 8 -> do { s <- get bh; i <- get bh; tys <- get bh - ; return (IfaceTupleTy s i tys) } - _ -> do n <- get bh - return (IfaceLitTy n) - -instance Binary IfaceCoercion where - put_ bh (IfaceReflCo a b) = do - putByte bh 1 - put_ bh a - put_ bh b - put_ bh (IfaceFunCo a b c) = do - putByte bh 2 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceTyConAppCo a b c) = do - putByte bh 3 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceAppCo a b) = do - putByte bh 4 - put_ bh a - put_ bh b - put_ bh (IfaceForAllCo a b c) = do - putByte bh 5 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceCoVarCo a) = do - putByte bh 6 - put_ bh a - put_ bh (IfaceAxiomInstCo a b c) = do - putByte bh 7 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceUnivCo a b c d) = do - putByte bh 8 - put_ bh a - put_ bh b - put_ bh c - put_ bh d - put_ bh (IfaceSymCo a) = do - putByte bh 9 - put_ bh a - put_ bh (IfaceTransCo a b) = do - putByte bh 10 - put_ bh a - put_ bh b - put_ bh (IfaceNthCo a b) = do - putByte bh 11 - put_ bh a - put_ bh b - put_ bh (IfaceLRCo a b) = do - putByte bh 12 - put_ bh a - put_ bh b - put_ bh (IfaceInstCo a b) = do - putByte bh 13 - put_ bh a - put_ bh b - put_ bh (IfaceCoherenceCo a b) = do - putByte bh 14 - put_ bh a - put_ bh b - put_ bh (IfaceKindCo a) = do - putByte bh 15 - put_ bh a - put_ bh (IfaceSubCo a) = do - putByte bh 16 - put_ bh a - put_ bh (IfaceAxiomRuleCo a b) = do - putByte bh 17 - put_ bh a - put_ bh b - - get bh = do - tag <- getByte bh - case tag of - 1 -> do a <- get bh - b <- get bh - return $ IfaceReflCo a b - 2 -> do a <- get bh - b <- get bh - c <- get bh - return $ IfaceFunCo a b c - 3 -> do a <- get bh - b <- get bh - c <- get bh - return $ IfaceTyConAppCo a b c - 4 -> do a <- get bh - b <- get bh - return $ IfaceAppCo a b - 5 -> do a <- get bh - b <- get bh - c <- get bh - return $ IfaceForAllCo a b c - 6 -> do a <- get bh - return $ IfaceCoVarCo a - 7 -> do a <- get bh - b <- get bh - c <- get bh - return $ IfaceAxiomInstCo a b c - 8 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return $ IfaceUnivCo a b c d - 9 -> do a <- get bh - return $ IfaceSymCo a - 10-> do a <- get bh - b <- get bh - return $ IfaceTransCo a b - 11-> do a <- get bh - b <- get bh - return $ IfaceNthCo a b - 12-> do a <- get bh - b <- get bh - return $ IfaceLRCo a b - 13-> do a <- get bh - b <- get bh - return $ IfaceInstCo a b - 14-> do a <- get bh - b <- get bh - return $ IfaceCoherenceCo a b - 15-> do a <- get bh - return $ IfaceKindCo a - 16-> do a <- get bh - return $ IfaceSubCo a - 17-> do a <- get bh - b <- get bh - return $ IfaceAxiomRuleCo a b - _ -> panic ("get IfaceCoercion " ++ show tag) - -instance Binary IfaceUnivCoProv where - put_ bh IfaceUnsafeCoerceProv = putByte bh 1 - put_ bh (IfacePhantomProv a) = do - putByte bh 2 - put_ bh a - put_ bh (IfaceProofIrrelProv a) = do - putByte bh 3 - put_ bh a - put_ bh (IfacePluginProv a) = do - putByte bh 4 - put_ bh a - put_ _ (IfaceHoleProv _) = - pprPanic "Binary(IfaceUnivCoProv) hit a hole" empty - -- See Note [Holes in IfaceUnivCoProv] - - get bh = do - tag <- getByte bh - case tag of - 1 -> return $ IfaceUnsafeCoerceProv - 2 -> do a <- get bh - return $ IfacePhantomProv a - 3 -> do a <- get bh - return $ IfaceProofIrrelProv a - 4 -> do a <- get bh - return $ IfacePluginProv a - _ -> panic ("get IfaceUnivCoProv " ++ show tag) - - -instance Binary (DefMethSpec IfaceType) where - put_ bh VanillaDM = putByte bh 0 - put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t - get bh = do - h <- getByte bh - case h of - 0 -> return VanillaDM - _ -> do { t <- get bh; return (GenericDM t) } diff --git a/iface/IfaceType.hs-boot b/iface/IfaceType.hs-boot deleted file mode 100644 --- a/iface/IfaceType.hs-boot +++ /dev/null @@ -1,37 +0,0 @@ --- Exists to allow TyCoRep to import pretty-printers -module IfaceType where - -import Var (TyVarBndr, ArgFlag) -import TyCon (TyConBndrVis) -import BasicTypes (TyPrec) -import Outputable (Outputable, SDoc) -import FastString (FastString) - -type IfLclName = FastString -type IfaceKind = IfaceType -type IfacePredType = IfaceType - -data ShowForAllFlag -data IfaceType -data IfaceTyCon -data IfaceTyLit -data IfaceCoercion -data IfaceTcArgs -type IfaceTvBndr = (IfLclName, IfaceKind) -type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis -type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag - -instance Outputable IfaceType - -pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc -pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc -pprIfaceTyLit :: IfaceTyLit -> SDoc -pprIfaceForAll :: [IfaceForAllBndr] -> SDoc -pprIfaceTvBndr :: Bool -> IfaceTvBndr -> SDoc -pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc -pprIfaceContext :: [IfacePredType] -> SDoc -pprIfaceContextArr :: [IfacePredType] -> SDoc -pprIfaceTypeApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc -pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc -pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc -pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc diff --git a/iface/LoadIface.hs b/iface/LoadIface.hs deleted file mode 100644 --- a/iface/LoadIface.hs +++ /dev/null @@ -1,1184 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Loading interface files --} - -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module LoadIface ( - -- Importing one thing - tcLookupImported_maybe, importDecl, - checkWiredInTyCon, ifCheckWiredInThing, - - -- RnM/TcM functions - loadModuleInterface, loadModuleInterfaces, - loadSrcInterface, loadSrcInterface_maybe, - loadInterfaceForName, loadInterfaceForModule, - - -- IfM functions - loadInterface, - loadSysInterface, loadUserInterface, loadPluginInterface, - findAndReadIface, readIface, -- Used when reading the module's old interface - loadDecls, -- Should move to TcIface and be renamed - initExternalPackageState, - moduleFreeHolesPrecise, - - pprModIfaceSimple, - ifaceStats, pprModIface, showIface - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, - tcIfaceFamInst, tcIfaceVectInfo, - tcIfaceAnnotations, tcIfaceCompleteSigs ) - -import DynFlags -import IfaceSyn -import IfaceEnv -import HscTypes - -import BasicTypes hiding (SuccessFlag(..)) -import TcRnMonad - -import Constants -import PrelNames -import PrelInfo -import PrimOp ( allThePrimOps, primOpFixity, primOpOcc ) -import MkId ( seqId ) -import TysPrim ( funTyConName ) -import Rules -import TyCon -import Annotations -import InstEnv -import FamInstEnv -import Name -import NameEnv -import Avail -import Module -import Maybes -import ErrUtils -import Finder -import UniqFM -import SrcLoc -import Outputable -import BinIface -import Panic -import Util -import FastString -import Fingerprint -import Hooks -import FieldLabel -import RnModIface -import UniqDSet - -import Control.Monad -import Control.Exception -import Data.IORef -import System.FilePath - -{- -************************************************************************ -* * -* tcImportDecl is the key function for "faulting in" * -* imported things -* * -************************************************************************ - -The main idea is this. We are chugging along type-checking source code, and -find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find -it in the EPS type envt. So it - 1 loads GHC.Base.hi - 2 gets the decl for GHC.Base.map - 3 typechecks it via tcIfaceDecl - 4 and adds it to the type env in the EPS - -Note that DURING STEP 4, we may find that map's type mentions a type -constructor that also - -Notice that for imported things we read the current version from the EPS -mutable variable. This is important in situations like - ...$(e1)...$(e2)... -where the code that e1 expands to might import some defns that -also turn out to be needed by the code that e2 expands to. --} - -tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) --- Returns (Failed err) if we can't find the interface file for the thing -tcLookupImported_maybe name - = do { hsc_env <- getTopEnv - ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) - ; case mb_thing of - Just thing -> return (Succeeded thing) - Nothing -> tcImportDecl_maybe name } - -tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) --- Entry point for *source-code* uses of importDecl -tcImportDecl_maybe name - | Just thing <- wiredInNameTyThing_maybe name - = do { when (needWiredInHomeIface thing) - (initIfaceTcRn (loadWiredInHomeIface name)) - -- See Note [Loading instances for wired-in things] - ; return (Succeeded thing) } - | otherwise - = initIfaceTcRn (importDecl name) - -importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing) --- Get the TyThing for this Name from an interface file --- It's not a wired-in thing -- the caller caught that -importDecl name - = ASSERT( not (isWiredInName name) ) - do { traceIf nd_doc - - -- Load the interface, which should populate the PTE - ; mb_iface <- ASSERT2( isExternalName name, ppr name ) - loadInterface nd_doc (nameModule name) ImportBySystem - ; case mb_iface of { - Failed err_msg -> return (Failed err_msg) ; - Succeeded _ -> do - - -- Now look it up again; this time we should find it - { eps <- getEps - ; case lookupTypeEnv (eps_PTE eps) name of - Just thing -> return $ Succeeded thing - Nothing -> let doc = ifPprDebug (found_things_msg eps $$ empty) - $$ not_found_msg - in return $ Failed doc - }}} - where - nd_doc = text "Need decl for" <+> ppr name - not_found_msg = hang (text "Can't find interface-file declaration for" <+> - pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name) - 2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file", - text "Use -ddump-if-trace to get an idea of which file caused the error"]) - found_things_msg eps = - hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon) - 2 (vcat (map ppr $ filter is_interesting $ nameEnvElts $ eps_PTE eps)) - where - is_interesting thing = nameModule name == nameModule (getName thing) - - -{- -************************************************************************ -* * - Checks for wired-in things -* * -************************************************************************ - -Note [Loading instances for wired-in things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to make sure that we have at least *read* the interface files -for any module with an instance decl or RULE that we might want. - -* If the instance decl is an orphan, we have a whole separate mechanism - (loadOrphanModules) - -* If the instance decl is not an orphan, then the act of looking at the - TyCon or Class will force in the defining module for the - TyCon/Class, and hence the instance decl - -* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface; - but we must make sure we read its interface in case it has instances or - rules. That is what LoadIface.loadWiredInHomeIface does. It's called - from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing} - -* HOWEVER, only do this for TyCons. There are no wired-in Classes. There - are some wired-in Ids, but we don't want to load their interfaces. For - example, Control.Exception.Base.recSelError is wired in, but that module - is compiled late in the base library, and we don't want to force it to - load before it's been compiled! - -All of this is done by the type checker. The renamer plays no role. -(It used to, but no longer.) --} - -checkWiredInTyCon :: TyCon -> TcM () --- Ensure that the home module of the TyCon (and hence its instances) --- are loaded. See Note [Loading instances for wired-in things] --- It might not be a wired-in tycon (see the calls in TcUnify), --- in which case this is a no-op. -checkWiredInTyCon tc - | not (isWiredInName tc_name) - = return () - | otherwise - = do { mod <- getModule - ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod) - ; ASSERT( isExternalName tc_name ) - when (mod /= nameModule tc_name) - (initIfaceTcRn (loadWiredInHomeIface tc_name)) - -- Don't look for (non-existent) Float.hi when - -- compiling Float.hs, which mentions Float of course - -- A bit yukky to call initIfaceTcRn here - } - where - tc_name = tyConName tc - -ifCheckWiredInThing :: TyThing -> IfL () --- Even though we are in an interface file, we want to make --- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) --- Ditto want to ensure that RULES are loaded too --- See Note [Loading instances for wired-in things] -ifCheckWiredInThing thing - = do { mod <- getIfModule - -- Check whether we are typechecking the interface for this - -- very module. E.g when compiling the base library in --make mode - -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in - -- the HPT, so without the test we'll demand-load it into the PIT! - -- C.f. the same test in checkWiredInTyCon above - ; let name = getName thing - ; ASSERT2( isExternalName name, ppr name ) - when (needWiredInHomeIface thing && mod /= nameModule name) - (loadWiredInHomeIface name) } - -needWiredInHomeIface :: TyThing -> Bool --- Only for TyCons; see Note [Loading instances for wired-in things] -needWiredInHomeIface (ATyCon {}) = True -needWiredInHomeIface _ = False - - -{- -************************************************************************ -* * - loadSrcInterface, loadOrphanModules, loadInterfaceForName - - These three are called from TcM-land -* * -************************************************************************ --} - --- | Load the interface corresponding to an @import@ directive in --- source code. On a failure, fail in the monad with an error message. -loadSrcInterface :: SDoc - -> ModuleName - -> IsBootInterface -- {-# SOURCE #-} ? - -> Maybe FastString -- "package", if any - -> RnM ModIface - -loadSrcInterface doc mod want_boot maybe_pkg - = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg - ; case res of - Failed err -> failWithTc err - Succeeded iface -> return iface } - --- | Like 'loadSrcInterface', but returns a 'MaybeErr'. -loadSrcInterface_maybe :: SDoc - -> ModuleName - -> IsBootInterface -- {-# SOURCE #-} ? - -> Maybe FastString -- "package", if any - -> RnM (MaybeErr MsgDoc ModIface) - -loadSrcInterface_maybe doc mod want_boot maybe_pkg - -- We must first find which Module this import refers to. This involves - -- calling the Finder, which as a side effect will search the filesystem - -- and create a ModLocation. If successful, loadIface will read the - -- interface; it will call the Finder again, but the ModLocation will be - -- cached from the first search. - = do { hsc_env <- getTopEnv - ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg - ; case res of - Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) - -- TODO: Make sure this error message is good - err -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) } - --- | Load interface directly for a fully qualified 'Module'. (This is a fairly --- rare operation, but in particular it is used to load orphan modules --- in order to pull their instances into the global package table and to --- handle some operations in GHCi). -loadModuleInterface :: SDoc -> Module -> TcM ModIface -loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod) - --- | Load interfaces for a collection of modules. -loadModuleInterfaces :: SDoc -> [Module] -> TcM () -loadModuleInterfaces doc mods - | null mods = return () - | otherwise = initIfaceTcRn (mapM_ load mods) - where - load mod = loadSysInterface (doc <+> parens (ppr mod)) mod - --- | Loads the interface for a given Name. --- Should only be called for an imported name; --- otherwise loadSysInterface may not find the interface -loadInterfaceForName :: SDoc -> Name -> TcRn ModIface -loadInterfaceForName doc name - = do { when debugIsOn $ -- Check pre-condition - do { this_mod <- getModule - ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) } - ; ASSERT2( isExternalName name, ppr name ) - initIfaceTcRn $ loadSysInterface doc (nameModule name) } - --- | Loads the interface for a given Module. -loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface -loadInterfaceForModule doc m - = do - -- Should not be called with this module - when debugIsOn $ do - this_mod <- getModule - MASSERT2( this_mod /= m, ppr m <+> parens doc ) - initIfaceTcRn $ loadSysInterface doc m - -{- -********************************************************* -* * - loadInterface - - The main function to load an interface - for an imported module, and put it in - the External Package State -* * -********************************************************* --} - --- | An 'IfM' function to load the home interface for a wired-in thing, --- so that we're sure that we see its instance declarations and rules --- See Note [Loading instances for wired-in things] -loadWiredInHomeIface :: Name -> IfM lcl () -loadWiredInHomeIface name - = ASSERT( isWiredInName name ) - do _ <- loadSysInterface doc (nameModule name); return () - where - doc = text "Need home interface for wired-in thing" <+> ppr name - ------------------- --- | Loads a system interface and throws an exception if it fails -loadSysInterface :: SDoc -> Module -> IfM lcl ModIface -loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem - ------------------- --- | Loads a user interface and throws an exception if it fails. The first parameter indicates --- whether we should import the boot variant of the module -loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface -loadUserInterface is_boot doc mod_name - = loadInterfaceWithException doc mod_name (ImportByUser is_boot) - -loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface -loadPluginInterface doc mod_name - = loadInterfaceWithException doc mod_name ImportByPlugin - ------------------- --- | A wrapper for 'loadInterface' that throws an exception if it fails -loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface -loadInterfaceWithException doc mod_name where_from - = withException (loadInterface doc mod_name where_from) - ------------------- -loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr MsgDoc ModIface) - --- loadInterface looks in both the HPT and PIT for the required interface --- If not found, it loads it, and puts it in the PIT (always). - --- If it can't find a suitable interface file, we --- a) modify the PackageIfaceTable to have an empty entry --- (to avoid repeated complaints) --- b) return (Left message) --- --- It's not necessarily an error for there not to be an interface --- file -- perhaps the module has changed, and that interface --- is no longer used - -loadInterface doc_str mod from - | isHoleModule mod - -- Hole modules get special treatment - = do dflags <- getDynFlags - -- Redo search for our local hole module - loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from - | otherwise - = do { -- Read the state - (eps,hpt) <- getEpsAndHpt - ; gbl_env <- getGblEnv - - ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) - - -- Check whether we have the interface already - ; dflags <- getDynFlags - ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of { - Just iface - -> return (Succeeded iface) ; -- Already loaded - -- The (src_imp == mi_boot iface) test checks that the already-loaded - -- interface isn't a boot iface. This can conceivably happen, - -- if an earlier import had a before we got to real imports. I think. - _ -> do { - - -- READ THE MODULE IN - ; read_result <- case (wantHiBootFile dflags eps mod from) of - Failed err -> return (Failed err) - Succeeded hi_boot_file -> - -- Stoutly warn against an EPS-updating import - -- of one's own boot file! (one-shot only) - --See Note [Do not update EPS with your own hi-boot] - -- in MkIface. - WARN( hi_boot_file && - fmap fst (if_rec_types gbl_env) == Just mod, - ppr mod ) - computeInterface doc_str hi_boot_file mod - ; case read_result of { - Failed err -> do - { let fake_iface = emptyModIface mod - - ; updateEps_ $ \eps -> - eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } - -- Not found, so add an empty iface to - -- the EPS map so that we don't look again - - ; return (Failed err) } ; - - -- Found and parsed! - -- We used to have a sanity check here that looked for: - -- * System importing .. - -- * a home package module .. - -- * that we know nothing about (mb_dep == Nothing)! - -- - -- But this is no longer valid because thNameToGhcName allows users to - -- cause the system to load arbitrary interfaces (by supplying an appropriate - -- Template Haskell original-name). - Succeeded (iface, loc) -> - let - loc_doc = text loc - in - initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do - - -- Load the new ModIface into the External Package State - -- Even home-package interfaces loaded by loadInterface - -- (which only happens in OneShot mode; in Batch/Interactive - -- mode, home-package modules are loaded one by one into the HPT) - -- are put in the EPS. - -- - -- The main thing is to add the ModIface to the PIT, but - -- we also take the - -- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, IfaceVectInfo - -- out of the ModIface and put them into the big EPS pools - - -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined - --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). - -- If we do loadExport first the wrong info gets into the cache (unless we - -- explicitly tag each export which seems a bit of a bore) - - ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas - ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) - ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) - ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) - ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) - ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface) - ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) (mi_vect_info iface) - ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) - - ; let { final_iface = iface { - mi_decls = panic "No mi_decls in PIT", - mi_insts = panic "No mi_insts in PIT", - mi_fam_insts = panic "No mi_fam_insts in PIT", - mi_rules = panic "No mi_rules in PIT", - mi_anns = panic "No mi_anns in PIT" - } - } - - ; updateEps_ $ \ eps -> - if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface - then eps else - eps { - eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, - eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, - eps_rule_base = extendRuleBaseList (eps_rule_base eps) - new_eps_rules, - eps_complete_matches - = extendCompleteMatchMap - (eps_complete_matches eps) - new_eps_complete_sigs, - eps_inst_env = extendInstEnvList (eps_inst_env eps) - new_eps_insts, - eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) - new_eps_fam_insts, - eps_vect_info = plusVectInfo (eps_vect_info eps) - new_eps_vect_info, - eps_ann_env = extendAnnEnvList (eps_ann_env eps) - new_eps_anns, - eps_mod_fam_inst_env - = let - fam_inst_env = - extendFamInstEnvList emptyFamInstEnv - new_eps_fam_insts - in - extendModuleEnv (eps_mod_fam_inst_env eps) - mod - fam_inst_env, - eps_stats = addEpsInStats (eps_stats eps) - (length new_eps_decls) - (length new_eps_insts) - (length new_eps_rules) } - - ; return (Succeeded final_iface) - }}}} - --- | Returns @True@ if a 'ModIface' comes from an external package. --- In this case, we should NOT load it into the EPS; the entities --- should instead come from the local merged signature interface. -is_external_sig :: DynFlags -> ModIface -> Bool -is_external_sig dflags iface = - -- It's a signature iface... - mi_semantic_module iface /= mi_module iface && - -- and it's not from the local package - moduleUnitId (mi_module iface) /= thisPackage dflags - --- | This is an improved version of 'findAndReadIface' which can also --- handle the case when a user requests @p[A=]:M@ but we only --- have an interface for @p[A=]:M@ (the indefinite interface. --- If we are not trying to build code, we load the interface we have, --- *instantiating it* according to how the holes are specified. --- (Of course, if we're actually building code, this is a hard error.) --- --- In the presence of holes, 'computeInterface' has an important invariant: --- to load module M, its set of transitively reachable requirements must --- have an up-to-date local hi file for that requirement. Note that if --- we are loading the interface of a requirement, this does not --- apply to the requirement itself; e.g., @p[A=]:A@ does not require --- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless --- we are actually typechecking p.) -computeInterface :: - SDoc -> IsBootInterface -> Module - -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) -computeInterface doc_str hi_boot_file mod0 = do - MASSERT( not (isHoleModule mod0) ) - dflags <- getDynFlags - case splitModuleInsts mod0 of - (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do - r <- findAndReadIface doc_str imod mod0 hi_boot_file - case r of - Succeeded (iface0, path) -> do - hsc_env <- getTopEnv - r <- liftIO $ - rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef)) - Nothing iface0 - case r of - Right x -> return (Succeeded (x, path)) - Left errs -> liftIO . throwIO . mkSrcErr $ errs - Failed err -> return (Failed err) - (mod, _) -> - findAndReadIface doc_str mod mod0 hi_boot_file - --- | Compute the signatures which must be compiled in order to --- load the interface for a 'Module'. The output of this function --- is always a subset of 'moduleFreeHoles'; it is more precise --- because in signature @p[A=,B=]:B@, although the free holes --- are A and B, B might not depend on A at all! --- --- If this is invoked on a signature, this does NOT include the --- signature itself; e.g. precise free module holes of --- @p[A=,B=]:B@ never includes B. -moduleFreeHolesPrecise - :: SDoc -> Module - -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName)) -moduleFreeHolesPrecise doc_str mod - | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) - | otherwise = - case splitModuleInsts mod of - (imod, Just indef) -> do - let insts = indefUnitIdInsts (indefModuleUnitId indef) - traceIf (text "Considering whether to load" <+> ppr mod <+> - text "to compute precise free module holes") - (eps, hpt) <- getEpsAndHpt - dflags <- getDynFlags - case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of - Just r -> return (Succeeded r) - Nothing -> readAndCache imod insts - (_, Nothing) -> return (Succeeded emptyUniqDSet) - where - tryEpsAndHpt dflags eps hpt = - fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod) - tryDepsCache eps imod insts = - case lookupInstalledModuleEnv (eps_free_holes eps) imod of - Just ifhs -> Just (renameFreeHoles ifhs insts) - _otherwise -> Nothing - readAndCache imod insts = do - mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False - case mb_iface of - Succeeded (iface, _) -> do - let ifhs = mi_free_holes iface - -- Cache it - updateEps_ (\eps -> - eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs }) - return (Succeeded (renameFreeHoles ifhs insts)) - Failed err -> return (Failed err) - -wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom - -> MaybeErr MsgDoc IsBootInterface --- Figure out whether we want Foo.hi or Foo.hi-boot -wantHiBootFile dflags eps mod from - = case from of - ImportByUser usr_boot - | usr_boot && not this_package - -> Failed (badSourceImport mod) - | otherwise -> Succeeded usr_boot - - ImportByPlugin - -> Succeeded False - - ImportBySystem - | not this_package -- If the module to be imported is not from this package - -> Succeeded False -- don't look it up in eps_is_boot, because that is keyed - -- on the ModuleName of *home-package* modules only. - -- We never import boot modules from other packages! - - | otherwise - -> case lookupUFM (eps_is_boot eps) (moduleName mod) of - Just (_, is_boot) -> Succeeded is_boot - Nothing -> Succeeded False - -- The boot-ness of the requested interface, - -- based on the dependencies in directly-imported modules - where - this_package = thisPackage dflags == moduleUnitId mod - -badSourceImport :: Module -> SDoc -badSourceImport mod - = hang (text "You cannot {-# SOURCE #-} import a module from another package") - 2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package") - <+> quotes (ppr (moduleUnitId mod))) - ------------------------------------------------------ --- Loading type/class/value decls --- We pass the full Module name here, replete with --- its package info, so that we can build a Name for --- each binder with the right package info in it --- All subsequent lookups, including crucially lookups during typechecking --- the declaration itself, will find the fully-glorious Name --- --- We handle ATs specially. They are not main declarations, but also not --- implicit things (in particular, adding them to `implicitTyThings' would mess --- things up in the renaming/type checking of source programs). ------------------------------------------------------ - -addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv -addDeclsToPTE pte things = extendNameEnvList pte things - -loadDecls :: Bool - -> [(Fingerprint, IfaceDecl)] - -> IfL [(Name,TyThing)] -loadDecls ignore_prags ver_decls - = do { thingss <- mapM (loadDecl ignore_prags) ver_decls - ; return (concat thingss) - } - -loadDecl :: Bool -- Don't load pragmas into the decl pool - -> (Fingerprint, IfaceDecl) - -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the - -- TyThings are forkM'd thunks -loadDecl ignore_prags (_version, decl) - = do { -- Populate the name cache with final versions of all - -- the names associated with the decl - let main_name = ifName decl - - -- Typecheck the thing, lazily - -- NB. Firstly, the laziness is there in case we never need the - -- declaration (in one-shot mode), and secondly it is there so that - -- we don't look up the occurrence of a name before calling mk_new_bndr - -- on the binder. This is important because we must get the right name - -- which includes its nameParent. - - ; thing <- forkM doc $ do { bumpDeclStats main_name - ; tcIfaceDecl ignore_prags decl } - - -- Populate the type environment with the implicitTyThings too. - -- - -- Note [Tricky iface loop] - -- ~~~~~~~~~~~~~~~~~~~~~~~~ - -- Summary: The delicate point here is that 'mini-env' must be - -- buildable from 'thing' without demanding any of the things - -- 'forkM'd by tcIfaceDecl. - -- - -- In more detail: Consider the example - -- data T a = MkT { x :: T a } - -- The implicitTyThings of T are: [ , ] - -- (plus their workers, wrappers, coercions etc etc) - -- - -- We want to return an environment - -- [ "MkT" -> , "x" -> , ... ] - -- (where the "MkT" is the *Name* associated with MkT, etc.) - -- - -- We do this by mapping the implicit_names to the associated - -- TyThings. By the invariant on ifaceDeclImplicitBndrs and - -- implicitTyThings, we can use getOccName on the implicit - -- TyThings to make this association: each Name's OccName should - -- be the OccName of exactly one implicitTyThing. So the key is - -- to define a "mini-env" - -- - -- [ 'MkT' -> , 'x' -> , ... ] - -- where the 'MkT' here is the *OccName* associated with MkT. - -- - -- However, there is a subtlety: due to how type checking needs - -- to be staged, we can't poke on the forkM'd thunks inside the - -- implicitTyThings while building this mini-env. - -- If we poke these thunks too early, two problems could happen: - -- (1) When processing mutually recursive modules across - -- hs-boot boundaries, poking too early will do the - -- type-checking before the recursive knot has been tied, - -- so things will be type-checked in the wrong - -- environment, and necessary variables won't be in - -- scope. - -- - -- (2) Looking up one OccName in the mini_env will cause - -- others to be looked up, which might cause that - -- original one to be looked up again, and hence loop. - -- - -- The code below works because of the following invariant: - -- getOccName on a TyThing does not force the suspended type - -- checks in order to extract the name. For example, we don't - -- poke on the "T a" type of on the way to - -- extracting 's OccName. Of course, there is no - -- reason in principle why getting the OccName should force the - -- thunks, but this means we need to be careful in - -- implicitTyThings and its helper functions. - -- - -- All a bit too finely-balanced for my liking. - - -- This mini-env and lookup function mediates between the - --'Name's n and the map from 'OccName's to the implicit TyThings - ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] - lookup n = case lookupOccEnv mini_env (getOccName n) of - Just thing -> thing - Nothing -> - pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl)) - - ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl) - --- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names) - ; return $ (main_name, thing) : - -- uses the invariant that implicit_names and - -- implicitTyThings are bijective - [(n, lookup n) | n <- implicit_names] - } - where - doc = text "Declaration for" <+> ppr (ifName decl) - -bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used -bumpDeclStats name - = do { traceIf (text "Loading decl for" <+> ppr name) - ; updateEps_ (\eps -> let stats = eps_stats eps - in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } }) - } - -{- -********************************************************* -* * -\subsection{Reading an interface file} -* * -********************************************************* - -Note [Home module load error] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the sought-for interface is in the current package (as determined -by -package-name flag) then it jolly well should already be in the HPT -because we process home-package modules in dependency order. (Except -in one-shot mode; see notes with hsc_HPT decl in HscTypes). - -It is possible (though hard) to get this error through user behaviour. - * Suppose package P (modules P1, P2) depends on package Q (modules Q1, - Q2, with Q2 importing Q1) - * We compile both packages. - * Now we edit package Q so that it somehow depends on P - * Now recompile Q with --make (without recompiling P). - * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2 - is a home-package module which is not yet in the HPT! Disaster. - -This actually happened with P=base, Q=ghc-prim, via the AMP warnings. -See Trac #8320. --} - -findAndReadIface :: SDoc - -- The unique identifier of the on-disk module we're - -- looking for - -> InstalledModule - -- The *actual* module we're looking for. We use - -- this to check the consistency of the requirements - -- of the module we read out. - -> Module - -> IsBootInterface -- True <=> Look for a .hi-boot file - -- False <=> Look for .hi file - -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) - -- Nothing <=> file not found, or unreadable, or illegible - -- Just x <=> successfully found and parsed - - -- It *doesn't* add an error to the monad, because - -- sometimes it's ok to fail... see notes with loadInterface -findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file - = do traceIf (sep [hsep [text "Reading", - if hi_boot_file - then text "[boot]" - else Outputable.empty, - text "interface for", - ppr mod <> semi], - nest 4 (text "reason:" <+> doc_str)]) - - -- Check for GHC.Prim, and return its static interface - -- TODO: make this check a function - if mod `installedModuleEq` gHC_PRIM - then do - iface <- getHooked ghcPrimIfaceHook ghcPrimIface - return (Succeeded (iface, - "")) - else do - dflags <- getDynFlags - -- Look for the file - hsc_env <- getTopEnv - mb_found <- liftIO (findExactModule hsc_env mod) - case mb_found of - InstalledFound loc mod -> do - -- Found file, so read it - let file_path = addBootSuffix_maybe hi_boot_file - (ml_hi_file loc) - - -- See Note [Home module load error] - if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags && - not (isOneShot (ghcMode dflags)) - then return (Failed (homeModError mod loc)) - else do r <- read_file file_path - checkBuildDynamicToo r - return r - err -> do - traceIf (text "...not found") - dflags <- getDynFlags - return (Failed (cannotFindInterface dflags - (installedModuleName mod) err)) - where read_file file_path = do - traceIf (text "readIFace" <+> text file_path) - -- Figure out what is recorded in mi_module. If this is - -- a fully definite interface, it'll match exactly, but - -- if it's indefinite, the inside will be uninstantiated! - dflags <- getDynFlags - let wanted_mod = - case splitModuleInsts wanted_mod_with_insts of - (_, Nothing) -> wanted_mod_with_insts - (_, Just indef_mod) -> - indefModuleToModule dflags - (generalizeIndefModule indef_mod) - read_result <- readIface wanted_mod file_path - case read_result of - Failed err -> return (Failed (badIfaceFile file_path err)) - Succeeded iface -> return (Succeeded (iface, file_path)) - -- Don't forget to fill in the package name... - checkBuildDynamicToo (Succeeded (iface, filePath)) = do - dflags <- getDynFlags - -- Indefinite interfaces are ALWAYS non-dynamic, and - -- that's OK. - let is_definite_iface = moduleIsDefinite (mi_module iface) - when is_definite_iface $ - whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do - let ref = canGenerateDynamicToo dflags - dynFilePath = addBootSuffix_maybe hi_boot_file - $ replaceExtension filePath (dynHiSuf dflags) - r <- read_file dynFilePath - case r of - Succeeded (dynIface, _) - | mi_mod_hash iface == mi_mod_hash dynIface -> - return () - | otherwise -> - do traceIf (text "Dynamic hash doesn't match") - liftIO $ writeIORef ref False - Failed err -> - do traceIf (text "Failed to load dynamic interface file:" $$ err) - liftIO $ writeIORef ref False - checkBuildDynamicToo _ = return () - --- @readIface@ tries just the one file. - -readIface :: Module -> FilePath - -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) - -- Failed err <=> file not found, or unreadable, or illegible - -- Succeeded iface <=> successfully found and parsed - -readIface wanted_mod file_path - = do { res <- tryMostM $ - readBinIface CheckHiWay QuietBinIFaceReading file_path - ; dflags <- getDynFlags - ; case res of - Right iface - -- NB: This check is NOT just a sanity check, it is - -- critical for correctness of recompilation checking - -- (it lets us tell when -this-unit-id has changed.) - | wanted_mod == actual_mod - -> return (Succeeded iface) - | otherwise -> return (Failed err) - where - actual_mod = mi_module iface - err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod - - Left exn -> return (Failed (text (showException exn))) - } - -{- -********************************************************* -* * - Wired-in interface for GHC.Prim -* * -********************************************************* --} - -initExternalPackageState :: ExternalPackageState -initExternalPackageState - = EPS { - eps_is_boot = emptyUFM, - eps_PIT = emptyPackageIfaceTable, - eps_free_holes = emptyInstalledModuleEnv, - eps_PTE = emptyTypeEnv, - eps_inst_env = emptyInstEnv, - eps_fam_inst_env = emptyFamInstEnv, - eps_rule_base = mkRuleBase builtinRules, - -- Initialise the EPS rule pool with the built-in rules - eps_mod_fam_inst_env - = emptyModuleEnv, - eps_vect_info = noVectInfo, - eps_complete_matches = emptyUFM, - eps_ann_env = emptyAnnEnv, - eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 - , n_insts_in = 0, n_insts_out = 0 - , n_rules_in = length builtinRules, n_rules_out = 0 } - } - -{- -********************************************************* -* * - Wired-in interface for GHC.Prim -* * -********************************************************* --} - -ghcPrimIface :: ModIface -ghcPrimIface - = (emptyModIface gHC_PRIM) { - mi_exports = ghcPrimExports, - mi_decls = [], - mi_fixities = fixities, - mi_fix_fn = mkIfaceFixCache fixities - } - where - fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR) - -- seq is infixr 0 - : (occName funTyConName, funTyFixity) -- trac #10145 - : mapMaybe mkFixity allThePrimOps - mkFixity op = (,) (primOpOcc op) <$> primOpFixity op - -{- -********************************************************* -* * -\subsection{Statistics} -* * -********************************************************* --} - -ifaceStats :: ExternalPackageState -> SDoc -ifaceStats eps - = hcat [text "Renamer stats: ", msg] - where - stats = eps_stats eps - msg = vcat - [int (n_ifaces_in stats) <+> text "interfaces read", - hsep [ int (n_decls_out stats), text "type/class/variable imported, out of", - int (n_decls_in stats), text "read"], - hsep [ int (n_insts_out stats), text "instance decls imported, out of", - int (n_insts_in stats), text "read"], - hsep [ int (n_rules_out stats), text "rule decls imported, out of", - int (n_rules_in stats), text "read"] - ] - -{- -************************************************************************ -* * - Printing interfaces -* * -************************************************************************ --} - --- | Read binary interface, and print it out -showIface :: HscEnv -> FilePath -> IO () -showIface hsc_env filename = do - -- skip the hi way check; we don't want to worry about profiled vs. - -- non-profiled interfaces, for example. - iface <- initTcRnIf 's' hsc_env () () $ - readBinIface IgnoreHiWay TraceBinIFaceReading filename - let dflags = hsc_dflags hsc_env - putLogMsg dflags NoReason SevDump noSrcSpan - (defaultDumpStyle dflags) (pprModIface iface) - --- Show a ModIface but don't display details; suitable for ModIfaces stored in --- the EPT. -pprModIfaceSimple :: ModIface -> SDoc -pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface))) - -pprModIface :: ModIface -> SDoc --- Show a ModIface -pprModIface iface - = vcat [ text "interface" - <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface) - <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty) - <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty) - <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty) - <+> integer hiVersion - , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface)) - , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface)) - , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface)) - , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface)) - , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface)) - , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) - , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) - , nest 2 (text "where") - , text "exports:" - , nest 2 (vcat (map pprExport (mi_exports iface))) - , pprDeps (mi_deps iface) - , vcat (map pprUsage (mi_usages iface)) - , vcat (map pprIfaceAnnotation (mi_anns iface)) - , pprFixities (mi_fixities iface) - , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface] - , vcat (map ppr (mi_insts iface)) - , vcat (map ppr (mi_fam_insts iface)) - , vcat (map ppr (mi_rules iface)) - , pprVectInfo (mi_vect_info iface) - , ppr (mi_warns iface) - , pprTrustInfo (mi_trust iface) - , pprTrustPkg (mi_trust_pkg iface) - , vcat (map ppr (mi_complete_sigs iface)) - ] - where - pp_hsc_src HsBootFile = text "[boot]" - pp_hsc_src HsigFile = text "[hsig]" - pp_hsc_src HsSrcFile = Outputable.empty - -{- -When printing export lists, we print like this: - Avail f f - AvailTC C [C, x, y] C(x,y) - AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C --} - -pprExport :: IfaceExport -> SDoc -pprExport (Avail n) = ppr n -pprExport (AvailTC _ [] []) = Outputable.empty -pprExport (AvailTC n ns0 fs) - = case ns0 of - (n':ns) | n==n' -> ppr n <> pp_export ns fs - _ -> ppr n <> vbar <> pp_export ns0 fs - where - pp_export [] [] = Outputable.empty - pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs)) - -pprUsage :: Usage -> SDoc -pprUsage usage@UsagePackageModule{} - = pprUsageImport usage usg_mod -pprUsage usage@UsageHomeModule{} - = pprUsageImport usage usg_mod_name $$ - nest 2 ( - maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$ - vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ] - ) -pprUsage usage@UsageFile{} - = hsep [text "addDependentFile", - doubleQuotes (text (usg_file_path usage))] -pprUsage usage@UsageMergedRequirement{} - = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] - -pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc -pprUsageImport usage usg_mod' - = hsep [text "import", safe, ppr (usg_mod' usage), - ppr (usg_mod_hash usage)] - where - safe | usg_safe usage = text "safe" - | otherwise = text " -/ " - -pprDeps :: Dependencies -> SDoc -pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, - dep_finsts = finsts }) - = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods), - text "package dependencies:" <+> fsep (map ppr_pkg pkgs), - text "orphans:" <+> fsep (map ppr orphs), - text "family instance modules:" <+> fsep (map ppr finsts) - ] - where - ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot - ppr_pkg (pkg,trust_req) = ppr pkg <> - (if trust_req then text "*" else Outputable.empty) - ppr_boot True = text "[boot]" - ppr_boot False = Outputable.empty - -pprFixities :: [(OccName, Fixity)] -> SDoc -pprFixities [] = Outputable.empty -pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes - where - pprFix (occ,fix) = ppr fix <+> ppr occ - -pprVectInfo :: IfaceVectInfo -> SDoc -pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars - , ifaceVectInfoTyCon = tycons - , ifaceVectInfoTyConReuse = tyconsReuse - , ifaceVectInfoParallelVars = parallelVars - , ifaceVectInfoParallelTyCons = parallelTyCons - }) = - vcat - [ text "vectorised variables:" <+> hsep (map ppr vars) - , text "vectorised tycons:" <+> hsep (map ppr tycons) - , text "vectorised reused tycons:" <+> hsep (map ppr tyconsReuse) - , text "parallel variables:" <+> hsep (map ppr parallelVars) - , text "parallel tycons:" <+> hsep (map ppr parallelTyCons) - ] - -pprTrustInfo :: IfaceTrustInfo -> SDoc -pprTrustInfo trust = text "trusted:" <+> ppr trust - -pprTrustPkg :: Bool -> SDoc -pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg - -instance Outputable Warnings where - ppr = pprWarns - -pprWarns :: Warnings -> SDoc -pprWarns NoWarnings = Outputable.empty -pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt -pprWarns (WarnSome prs) = text "Warnings" - <+> vcat (map pprWarning prs) - where pprWarning (name, txt) = ppr name <+> ppr txt - -pprIfaceAnnotation :: IfaceAnnotation -> SDoc -pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) - = ppr target <+> text "annotated by" <+> ppr serialized - -{- -********************************************************* -* * -\subsection{Errors} -* * -********************************************************* --} - -badIfaceFile :: String -> SDoc -> SDoc -badIfaceFile file err - = vcat [text "Bad interface file:" <+> text file, - nest 4 err] - -hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc -hiModuleNameMismatchWarn dflags requested_mod read_mod - | moduleUnitId requested_mod == moduleUnitId read_mod = - sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, - text "but we were expecting module" <+> quotes (ppr requested_mod), - sep [text "Probable cause: the source code which generated interface file", - text "has an incompatible module name" - ] - ] - | otherwise = - -- ToDo: This will fail to have enough qualification when the package IDs - -- are the same - withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ - -- we want the Modules below to be qualified with package names, - -- so reset the PrintUnqualified setting. - hsep [ text "Something is amiss; requested module " - , ppr requested_mod - , text "differs from name found in the interface file" - , ppr read_mod - , parens (text "if these names look the same, try again with -dppr-debug") - ] - -homeModError :: InstalledModule -> ModLocation -> SDoc --- See Note [Home module load error] -homeModError mod location - = text "attempting to use module " <> quotes (ppr mod) - <> (case ml_hs_file location of - Just file -> space <> parens (text file) - Nothing -> Outputable.empty) - <+> text "which is not loaded" diff --git a/iface/LoadIface.hs-boot b/iface/LoadIface.hs-boot deleted file mode 100644 --- a/iface/LoadIface.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module LoadIface where -import Module (Module) -import TcRnMonad (IfM) -import HscTypes (ModIface) -import Outputable (SDoc) - -loadSysInterface :: SDoc -> Module -> IfM lcl ModIface diff --git a/iface/MkIface.hs b/iface/MkIface.hs deleted file mode 100644 --- a/iface/MkIface.hs +++ /dev/null @@ -1,1815 +0,0 @@ -{- -(c) The University of Glasgow 2006-2008 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 --} - -{-# LANGUAGE CPP, NondecreasingIndentation #-} - --- | Module for constructing @ModIface@ values (interface files), --- writing them to disk and comparing two versions to see if --- recompilation is required. -module MkIface ( - mkIface, -- Build a ModIface from a ModGuts, - -- including computing version information - - mkIfaceTc, - - writeIfaceFile, -- Write the interface file - - checkOldIface, -- See if recompilation is required, by - -- comparing version information - RecompileRequired(..), recompileRequired, - mkIfaceExports, - - tyThingToIfaceDecl -- Converting things to their Iface equivalents - ) where - -{- - ----------------------------------------------- - Recompilation checking - ----------------------------------------------- - -A complete description of how recompilation checking works can be -found in the wiki commentary: - - http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance - -Please read the above page for a top-down description of how this all -works. Notes below cover specific issues related to the implementation. - -Basic idea: - - * In the mi_usages information in an interface, we record the - fingerprint of each free variable of the module - - * In mkIface, we compute the fingerprint of each exported thing A.f. - For each external thing that A.f refers to, we include the fingerprint - of the external reference when computing the fingerprint of A.f. So - if anything that A.f depends on changes, then A.f's fingerprint will - change. - Also record any dependent files added with - * addDependentFile - * #include - * -optP-include - - * In checkOldIface we compare the mi_usages for the module with - the actual fingerprint for all each thing recorded in mi_usages --} - -#include "HsVersions.h" - -import IfaceSyn -import BinFingerprint -import LoadIface -import ToIface -import FlagChecker - -import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies ) -import Id -import Annotations -import CoreSyn -import Class -import TyCon -import CoAxiom -import ConLike -import DataCon -import Type -import TcType -import InstEnv -import FamInstEnv -import TcRnMonad -import HsSyn -import HscTypes -import Finder -import DynFlags -import VarEnv -import VarSet -import Var -import Name -import Avail -import RdrName -import NameEnv -import NameSet -import Module -import BinIface -import ErrUtils -import Digraph -import SrcLoc -import Outputable -import BasicTypes hiding ( SuccessFlag(..) ) -import Unique -import Util hiding ( eqListBy ) -import FastString -import Maybes -import Binary -import Fingerprint -import Exception -import UniqSet -import Packages - -import Control.Monad -import Data.Function -import Data.List -import qualified Data.Map as Map -import Data.Ord -import Data.IORef -import System.Directory -import System.FilePath - -{- -************************************************************************ -* * -\subsection{Completing an interface} -* * -************************************************************************ --} - -mkIface :: HscEnv - -> Maybe Fingerprint -- The old fingerprint, if we have it - -> ModDetails -- The trimmed, tidied interface - -> ModGuts -- Usages, deprecations, etc - -> IO (ModIface, -- The new one - Bool) -- True <=> there was an old Iface, and the - -- new one is identical, so no need - -- to write it - -mkIface hsc_env maybe_old_fingerprint mod_details - ModGuts{ mg_module = this_mod, - mg_hsc_src = hsc_src, - mg_usages = usages, - mg_used_th = used_th, - mg_deps = deps, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_hpc_info = hpc_info, - mg_safe_haskell = safe_mode, - mg_trust_pkg = self_trust - } - = mkIface_ hsc_env maybe_old_fingerprint - this_mod hsc_src used_th deps rdr_env fix_env - warns hpc_info self_trust - safe_mode usages mod_details - --- | make an interface from the results of typechecking only. Useful --- for non-optimising compilation, or where we aren't generating any --- object code at all ('HscNothing'). -mkIfaceTc :: HscEnv - -> Maybe Fingerprint -- The old fingerprint, if we have it - -> SafeHaskellMode -- The safe haskell mode - -> ModDetails -- gotten from mkBootModDetails, probably - -> TcGblEnv -- Usages, deprecations, etc - -> IO (ModIface, Bool) -mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details - tc_result@TcGblEnv{ tcg_mod = this_mod, - tcg_src = hsc_src, - tcg_imports = imports, - tcg_rdr_env = rdr_env, - tcg_fix_env = fix_env, - tcg_merged = merged, - tcg_warns = warns, - tcg_hpc = other_hpc_info, - tcg_th_splice_used = tc_splice_used, - tcg_dependent_files = dependent_files - } - = do - let used_names = mkUsedNames tc_result - deps <- mkDependencies tc_result - let hpc_info = emptyHpcInfo other_hpc_info - used_th <- readIORef tc_splice_used - dep_files <- (readIORef dependent_files) - -- Do NOT use semantic module here; this_mod in mkUsageInfo - -- is used solely to decide if we should record a dependency - -- or not. When we instantiate a signature, the semantic - -- module is something we want to record dependencies for, - -- but if you pass that in here, we'll decide it's the local - -- module and does not need to be recorded as a dependency. - -- See Note [Identity versus semantic module] - usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files merged - mkIface_ hsc_env maybe_old_fingerprint - this_mod hsc_src - used_th deps rdr_env - fix_env warns hpc_info - (imp_trust_own_pkg imports) safe_mode usages mod_details - - -mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource - -> Bool -> Dependencies -> GlobalRdrEnv - -> NameEnv FixItem -> Warnings -> HpcInfo - -> Bool - -> SafeHaskellMode - -> [Usage] - -> ModDetails - -> IO (ModIface, Bool) -mkIface_ hsc_env maybe_old_fingerprint - this_mod hsc_src used_th deps rdr_env fix_env src_warns - hpc_info pkg_trust_req safe_mode usages - ModDetails{ md_insts = insts, - md_fam_insts = fam_insts, - md_rules = rules, - md_anns = anns, - md_vect_info = vect_info, - md_types = type_env, - md_exports = exports, - md_complete_sigs = complete_sigs } --- NB: notice that mkIface does not look at the bindings --- only at the TypeEnv. The previous Tidy phase has --- put exactly the info into the TypeEnv that we want --- to expose in the interface - - = do - let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod) - entities = typeEnvElts type_env - decls = [ tyThingToIfaceDecl entity - | entity <- entities, - let name = getName entity, - not (isImplicitTyThing entity), - -- No implicit Ids and class tycons in the interface file - not (isWiredInName name), - -- Nor wired-in things; the compiler knows about them anyhow - nameIsLocalOrFrom semantic_mod name ] - -- Sigh: see Note [Root-main Id] in TcRnDriver - -- NB: ABSOLUTELY need to check against semantic_mod, - -- because all of the names in an hsig p[H=]:H - -- are going to be for , not the former id! - -- See Note [Identity versus semantic module] - - fixities = sortBy (comparing fst) - [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] - -- The order of fixities returned from nameEnvElts is not - -- deterministic, so we sort by OccName to canonicalize it. - -- See Note [Deterministic UniqFM] in UniqDFM for more details. - warns = src_warns - iface_rules = map coreRuleToIfaceRule rules - iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts - iface_fam_insts = map famInstToIfaceFamInst fam_insts - iface_vect_info = flattenVectInfo vect_info - trust_info = setSafeMode safe_mode - annotations = map mkIfaceAnnotation anns - icomplete_sigs = map mkIfaceCompleteSig complete_sigs - - intermediate_iface = ModIface { - mi_module = this_mod, - -- Need to record this because it depends on the -instantiated-with flag - -- which could change - mi_sig_of = if semantic_mod == this_mod - then Nothing - else Just semantic_mod, - mi_hsc_src = hsc_src, - mi_deps = deps, - mi_usages = usages, - mi_exports = mkIfaceExports exports, - - -- Sort these lexicographically, so that - -- the result is stable across compilations - mi_insts = sortBy cmp_inst iface_insts, - mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts, - mi_rules = sortBy cmp_rule iface_rules, - - mi_vect_info = iface_vect_info, - - mi_fixities = fixities, - mi_warns = warns, - mi_anns = annotations, - mi_globals = maybeGlobalRdrEnv rdr_env, - - -- Left out deliberately: filled in by addFingerprints - mi_iface_hash = fingerprint0, - mi_mod_hash = fingerprint0, - mi_flag_hash = fingerprint0, - mi_exp_hash = fingerprint0, - mi_used_th = used_th, - mi_orphan_hash = fingerprint0, - mi_orphan = False, -- Always set by addFingerprints, but - -- it's a strict field, so we can't omit it. - mi_finsts = False, -- Ditto - mi_decls = deliberatelyOmitted "decls", - mi_hash_fn = deliberatelyOmitted "hash_fn", - mi_hpc = isHpcUsed hpc_info, - mi_trust = trust_info, - mi_trust_pkg = pkg_trust_req, - - -- And build the cached values - mi_warn_fn = mkIfaceWarnCache warns, - mi_fix_fn = mkIfaceFixCache fixities, - mi_complete_sigs = icomplete_sigs } - - (new_iface, no_change_at_all) - <- {-# SCC "versioninfo" #-} - addFingerprints hsc_env maybe_old_fingerprint - intermediate_iface decls - - -- Debug printing - dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" - (pprModIface new_iface) - - -- bug #1617: on reload we weren't updating the PrintUnqualified - -- correctly. This stems from the fact that the interface had - -- not changed, so addFingerprints returns the old ModIface - -- with the old GlobalRdrEnv (mi_globals). - let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env } - - return (final_iface, no_change_at_all) - where - cmp_rule = comparing ifRuleName - -- Compare these lexicographically by OccName, *not* by unique, - -- because the latter is not stable across compilations: - cmp_inst = comparing (nameOccName . ifDFun) - cmp_fam_inst = comparing (nameOccName . ifFamInstTcName) - - dflags = hsc_dflags hsc_env - - -- We only fill in mi_globals if the module was compiled to byte - -- code. Otherwise, the compiler may not have retained all the - -- top-level bindings and they won't be in the TypeEnv (see - -- Desugar.addExportFlagsAndRules). The mi_globals field is used - -- by GHCi to decide whether the module has its full top-level - -- scope available. (#5534) - maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv - maybeGlobalRdrEnv rdr_env - | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env - | otherwise = Nothing - - deliberatelyOmitted :: String -> a - deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) - - ifFamInstTcName = ifFamInstFam - - flattenVectInfo (VectInfo { vectInfoVar = vVar - , vectInfoTyCon = vTyCon - , vectInfoParallelVars = vParallelVars - , vectInfoParallelTyCons = vParallelTyCons - }) = - IfaceVectInfo - { ifaceVectInfoVar = [Var.varName v | (v, _ ) <- dVarEnvElts vVar] - , ifaceVectInfoTyCon = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t /= t_v] - , ifaceVectInfoTyConReuse = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t == t_v] - , ifaceVectInfoParallelVars = [Var.varName v | v <- dVarSetElems vParallelVars] - , ifaceVectInfoParallelTyCons = nameSetElemsStable vParallelTyCons - } - ------------------------------ -writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO () -writeIfaceFile dflags hi_file_path new_iface - = do createDirectoryIfMissing True (takeDirectory hi_file_path) - writeBinIface dflags hi_file_path new_iface - - --- ----------------------------------------------------------------------------- --- Look up parents and versions of Names - --- This is like a global version of the mi_hash_fn field in each ModIface. --- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get --- the parent and version info. - -mkHashFun - :: HscEnv -- needed to look up versions - -> ExternalPackageState -- ditto - -> (Name -> IO Fingerprint) -mkHashFun hsc_env eps name - | isHoleModule orig_mod - = lookup (mkModule (thisPackage dflags) (moduleName orig_mod)) - | otherwise - = lookup orig_mod - where - dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - pit = eps_PIT eps - occ = nameOccName name - orig_mod = nameModule name - lookup mod = do - MASSERT2( isExternalName name, ppr name ) - iface <- case lookupIfaceByModule dflags hpt pit mod of - Just iface -> return iface - Nothing -> do - -- This can occur when we're writing out ifaces for - -- requirements; we didn't do any /real/ typechecking - -- so there's no guarantee everything is loaded. - -- Kind of a heinous hack. - iface <- initIfaceLoad hsc_env . withException - $ loadInterface (text "lookupVers2") mod ImportBySystem - return iface - return $ snd (mi_hash_fn iface occ `orElse` - pprPanic "lookupVers1" (ppr mod <+> ppr occ)) - --- --------------------------------------------------------------------------- --- Compute fingerprints for the interface - -{- -Note [Fingerprinting IfaceDecls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The general idea here is that we first examine the 'IfaceDecl's and determine -the recursive groups of them. We then walk these groups in dependency order, -serializing each contained 'IfaceDecl' to a "Binary" buffer which we then -hash using MD5 to produce a fingerprint for the group. - -However, the serialization that we use is a bit funny: we override the @putName@ -operation with our own which serializes the hash of a 'Name' instead of the -'Name' itself. This ensures that the fingerprint of a decl changes if anything -in its transitive closure changes. This trick is why we must be careful about -traversing in dependency order: we need to ensure that we have hashes for -everything referenced by the decl which we are fingerprinting. - -Moreover, we need to be careful to distinguish between serialization of binding -Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls -field of a IfaceClsInst): only in the non-binding case should we include the -fingerprint; in the binding case we shouldn't since it is merely the name of the -thing that we are currently fingerprinting. --} - --- | Add fingerprints for top-level declarations to a 'ModIface'. --- --- See Note [Fingerprinting IfaceDecls] -addFingerprints - :: HscEnv - -> Maybe Fingerprint -- the old fingerprint, if any - -> ModIface -- The new interface (lacking decls) - -> [IfaceDecl] -- The new decls - -> IO (ModIface, -- Updated interface - Bool) -- True <=> no changes at all; - -- no need to write Iface - -addFingerprints hsc_env mb_old_fingerprint iface0 new_decls - = do - eps <- hscEPS hsc_env - let - -- The ABI of a declaration represents everything that is made - -- visible about the declaration that a client can depend on. - -- see IfaceDeclABI below. - declABI :: IfaceDecl -> IfaceDeclABI - -- TODO: I'm not sure if this should be semantic_mod or this_mod. - -- See also Note [Identity versus semantic module] - declABI decl = (this_mod, decl, extras) - where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts - non_orph_fis decl - - edges :: [(IfaceDeclABI, Unique, [Unique])] - edges = [ (abi, getUnique (getOccName decl), out) - | decl <- new_decls - , let abi = declABI decl - , let out = localOccs $ freeNamesDeclABI abi - ] - - name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n - localOccs = - map (getUnique . getParent . getOccName) - -- NB: names always use semantic module, so - -- filtering must be on the semantic module! - -- See Note [Identity versus semantic module] - . filter ((== semantic_mod) . name_module) - . nonDetEltsUniqSet - -- It's OK to use nonDetEltsUFM as localOccs is only - -- used to construct the edges and - -- stronglyConnCompFromEdgedVertices is deterministic - -- even with non-deterministic order of edges as - -- explained in Note [Deterministic SCC] in Digraph. - where getParent :: OccName -> OccName - getParent occ = lookupOccEnv parent_map occ `orElse` occ - - -- maps OccNames to their parents in the current module. - -- e.g. a reference to a constructor must be turned into a reference - -- to the TyCon for the purposes of calculating dependencies. - parent_map :: OccEnv OccName - parent_map = foldl' extend emptyOccEnv new_decls - where extend env d = - extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] - where n = getOccName d - - -- strongly-connected groups of declarations, in dependency order - groups :: [SCC IfaceDeclABI] - groups = - stronglyConnCompFromEdgedVerticesUniq edges - - global_hash_fn = mkHashFun hsc_env eps - - -- How to output Names when generating the data to fingerprint. - -- Here we want to output the fingerprint for each top-level - -- Name, whether it comes from the current module or another - -- module. In this way, the fingerprint for a declaration will - -- change if the fingerprint for anything it refers to (transitively) - -- changes. - mk_put_name :: OccEnv (OccName,Fingerprint) - -> BinHandle -> Name -> IO () - mk_put_name local_env bh name - | isWiredInName name = putNameLiterally bh name - -- wired-in names don't have fingerprints - | otherwise - = ASSERT2( isExternalName name, ppr name ) - let hash | nameModule name /= semantic_mod = global_hash_fn name - -- Get it from the REAL interface!! - -- This will trigger when we compile an hsig file - -- and we know a backing impl for it. - -- See Note [Identity versus semantic module] - | semantic_mod /= this_mod - , not (isHoleModule semantic_mod) = global_hash_fn name - | otherwise = return (snd (lookupOccEnv local_env (getOccName name) - `orElse` pprPanic "urk! lookup local fingerprint" - (ppr name $$ ppr local_env))) - -- This panic indicates that we got the dependency - -- analysis wrong, because we needed a fingerprint for - -- an entity that wasn't in the environment. To debug - -- it, turn the panic into a trace, uncomment the - -- pprTraces below, run the compile again, and inspect - -- the output and the generated .hi file with - -- --show-iface. - in hash >>= put_ bh - - -- take a strongly-connected group of declarations and compute - -- its fingerprint. - - fingerprint_group :: (OccEnv (OccName,Fingerprint), - [(Fingerprint,IfaceDecl)]) - -> SCC IfaceDeclABI - -> IO (OccEnv (OccName,Fingerprint), - [(Fingerprint,IfaceDecl)]) - - fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi) - = do let hash_fn = mk_put_name local_env - decl = abiDecl abi - --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do - hash <- computeFingerprint hash_fn abi - env' <- extend_hash_env local_env (hash,decl) - return (env', (hash,decl) : decls_w_hashes) - - fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis) - = do let decls = map abiDecl abis - local_env1 <- foldM extend_hash_env local_env - (zip (repeat fingerprint0) decls) - let hash_fn = mk_put_name local_env1 - -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do - let stable_abis = sortBy cmp_abiNames abis - -- put the cycle in a canonical order - hash <- computeFingerprint hash_fn stable_abis - let pairs = zip (repeat hash) decls - local_env2 <- foldM extend_hash_env local_env pairs - return (local_env2, pairs ++ decls_w_hashes) - - -- we have fingerprinted the whole declaration, but we now need - -- to assign fingerprints to all the OccNames that it binds, to - -- use when referencing those OccNames in later declarations. - -- - extend_hash_env :: OccEnv (OccName,Fingerprint) - -> (Fingerprint,IfaceDecl) - -> IO (OccEnv (OccName,Fingerprint)) - extend_hash_env env0 (hash,d) = do - return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 - (ifaceDeclFingerprints hash d)) - - -- - (local_env, decls_w_hashes) <- - foldM fingerprint_group (emptyOccEnv, []) groups - - -- when calculating fingerprints, we always need to use canonical - -- ordering for lists of things. In particular, the mi_deps has various - -- lists of modules and suchlike, so put these all in canonical order: - let sorted_deps = sortDependencies (mi_deps iface0) - - -- The export hash of a module depends on the orphan hashes of the - -- orphan modules below us in the dependency tree. This is the way - -- that changes in orphans get propagated all the way up the - -- dependency tree. - -- - -- Note [A bad dep_orphs optimization] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- In a previous version of this code, we filtered out orphan modules which - -- were not from the home package, justifying it by saying that "we'd - -- pick up the ABI hashes of the external module instead". This is wrong. - -- Suppose that we have: - -- - -- module External where - -- instance Show (a -> b) - -- - -- module Home1 where - -- import External - -- - -- module Home2 where - -- import Home1 - -- - -- The export hash of Home1 needs to reflect the orphan instances of - -- External. It's true that Home1 will get rebuilt if the orphans - -- of External, but we also need to make sure Home2 gets rebuilt - -- as well. See #12733 for more details. - let orph_mods - = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot] - $ dep_orphs sorted_deps - dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods - - -- Note [Do not update EPS with your own hi-boot] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- (See also Trac #10182). When your hs-boot file includes an orphan - -- instance declaration, you may find that the dep_orphs of a module you - -- import contains reference to yourself. DO NOT actually load this module - -- or add it to the orphan hashes: you're going to provide the orphan - -- instances yourself, no need to consult hs-boot; if you do load the - -- interface into EPS, you will see a duplicate orphan instance. - - orphan_hash <- computeFingerprint (mk_put_name local_env) - (map ifDFun orph_insts, orph_rules, orph_fis) - - -- the export list hash doesn't depend on the fingerprints of - -- the Names it mentions, only the Names themselves, hence putNameLiterally. - export_hash <- computeFingerprint putNameLiterally - (mi_exports iface0, - orphan_hash, - dep_orphan_hashes, - dep_pkgs (mi_deps iface0), - -- See Note [Export hash depends on non-orphan family instances] - dep_finsts (mi_deps iface0), - -- dep_pkgs: see "Package Version Changes" on - -- wiki/Commentary/Compiler/RecompilationAvoidance - mi_trust iface0) - -- Make sure change of Safe Haskell mode causes recomp. - - -- Note [Export hash depends on non-orphan family instances] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- - -- Suppose we have: - -- - -- module A where - -- type instance F Int = Bool - -- - -- module B where - -- import A - -- - -- module C where - -- import B - -- - -- The family instance consistency check for C depends on the dep_finsts of - -- B. If we rename module A to A2, when the dep_finsts of B changes, we need - -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of - -- the exports of B, because C always considers them when checking - -- consistency. - -- - -- A full discussion is in #12723. - -- - -- We do NOT need to hash dep_orphs, because this is implied by - -- dep_orphan_hashes, and we do not need to hash ordinary class instances, - -- because there is no eager consistency check as there is with type families - -- (also we didn't store it anywhere!) - -- - - -- put the declarations in a canonical order, sorted by OccName - let sorted_decls = Map.elems $ Map.fromList $ - [(getOccName d, e) | e@(_, d) <- decls_w_hashes] - - -- the flag hash depends on: - -- - (some of) dflags - -- it returns two hashes, one that shouldn't change - -- the abi hash and one that should - flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally - - -- the ABI hash depends on: - -- - decls - -- - export list - -- - orphans - -- - deprecations - -- - vect info - -- - flag abi hash - mod_hash <- computeFingerprint putNameLiterally - (map fst sorted_decls, - export_hash, -- includes orphan_hash - mi_warns iface0, - mi_vect_info iface0) - - -- The interface hash depends on: - -- - the ABI hash, plus - -- - the module level annotations, - -- - usages - -- - deps (home and external packages, dependent files) - -- - hpc - iface_hash <- computeFingerprint putNameLiterally - (mod_hash, - ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache - mi_usages iface0, - sorted_deps, - mi_hpc iface0) - - let - no_change_at_all = Just iface_hash == mb_old_fingerprint - - final_iface = iface0 { - mi_mod_hash = mod_hash, - mi_iface_hash = iface_hash, - mi_exp_hash = export_hash, - mi_orphan_hash = orphan_hash, - mi_flag_hash = flag_hash, - mi_orphan = not ( all ifRuleAuto orph_rules - -- See Note [Orphans and auto-generated rules] - && null orph_insts - && null orph_fis - && isNoIfaceVectInfo (mi_vect_info iface0)), - mi_finsts = not . null $ mi_fam_insts iface0, - mi_decls = sorted_decls, - mi_hash_fn = lookupOccEnv local_env } - -- - return (final_iface, no_change_at_all) - - where - this_mod = mi_module iface0 - semantic_mod = mi_semantic_module iface0 - dflags = hsc_dflags hsc_env - (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) - (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) - (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0) - fix_fn = mi_fix_fn iface0 - ann_fn = mkIfaceAnnCache (mi_anns iface0) - --- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules --- (in particular, the orphan modules which are transitively imported by the --- current module). --- --- Q: Why do we need the hash at all, doesn't the list of transitively --- imported orphan modules suffice? --- --- A: If one of our transitive imports adds a new orphan instance, our --- export hash must change so that modules which import us rebuild. If we just --- hashed the [Module], the hash would not change even when a new instance was --- added to a module that already had an orphan instance. --- --- Q: Why don't we just hash the orphan hashes of our direct dependencies? --- Why the full transitive closure? --- --- A: Suppose we have these modules: --- --- module A where --- instance Show (a -> b) where --- module B where --- import A -- ** --- module C where --- import A --- import B --- --- Whether or not we add or remove the import to A in B affects the --- orphan hash of B. But it shouldn't really affect the orphan hash --- of C. If we hashed only direct dependencies, there would be no --- way to tell that the net effect was a wash, and we'd be forced --- to recompile C and everything else. -getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] -getOrphanHashes hsc_env mods = do - eps <- hscEPS hsc_env - let - hpt = hsc_HPT hsc_env - pit = eps_PIT eps - dflags = hsc_dflags hsc_env - get_orph_hash mod = - case lookupIfaceByModule dflags hpt pit mod of - Just iface -> return (mi_orphan_hash iface) - Nothing -> do -- similar to 'mkHashFun' - iface <- initIfaceLoad hsc_env . withException - $ loadInterface (text "getOrphanHashes") mod ImportBySystem - return (mi_orphan_hash iface) - - -- - mapM get_orph_hash mods - - -sortDependencies :: Dependencies -> Dependencies -sortDependencies d - = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d), - dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d), - dep_orphs = sortBy stableModuleCmp (dep_orphs d), - dep_finsts = sortBy stableModuleCmp (dep_finsts d) } - --- | Creates cached lookup for the 'mi_anns' field of ModIface --- Hackily, we use "module" as the OccName for any module-level annotations -mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload] -mkIfaceAnnCache anns - = \n -> lookupOccEnv env n `orElse` [] - where - pair (IfaceAnnotation target value) = - (case target of - NamedTarget occn -> occn - ModuleTarget _ -> mkVarOcc "module" - , [value]) - -- flipping (++), so the first argument is always short - env = mkOccEnv_C (flip (++)) (map pair anns) - -{- -************************************************************************ -* * - The ABI of an IfaceDecl -* * -************************************************************************ - -Note [The ABI of an IfaceDecl] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ABI of a declaration consists of: - - (a) the full name of the identifier (inc. module and package, - because these are used to construct the symbol name by which - the identifier is known externally). - - (b) the declaration itself, as exposed to clients. That is, the - definition of an Id is included in the fingerprint only if - it is made available as an unfolding in the interface. - - (c) the fixity of the identifier (if it exists) - (d) for Ids: rules - (e) for classes: instances, fixity & rules for methods - (f) for datatypes: instances, fixity & rules for constrs - -Items (c)-(f) are not stored in the IfaceDecl, but instead appear -elsewhere in the interface file. But they are *fingerprinted* with -the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras, -and fingerprinting that as part of the declaration. --} - -type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras) - -data IfaceDeclExtras - = IfaceIdExtras IfaceIdExtras - - | IfaceDataExtras - (Maybe Fixity) -- Fixity of the tycon itself (if it exists) - [IfaceInstABI] -- Local class and family instances of this tycon - -- See Note [Orphans] in InstEnv - [AnnPayload] -- Annotations of the type itself - [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations - - | IfaceClassExtras - (Maybe Fixity) -- Fixity of the class itself (if it exists) - [IfaceInstABI] -- Local instances of this class *or* - -- of its associated data types - -- See Note [Orphans] in InstEnv - [AnnPayload] -- Annotations of the type itself - [IfaceIdExtras] -- For each class method: fixity, RULES and annotations - - | IfaceSynonymExtras (Maybe Fixity) [AnnPayload] - - | IfaceFamilyExtras (Maybe Fixity) [IfaceInstABI] [AnnPayload] - - | IfaceOtherDeclExtras - -data IfaceIdExtras - = IdExtras - (Maybe Fixity) -- Fixity of the Id (if it exists) - [IfaceRule] -- Rules for the Id - [AnnPayload] -- Annotations for the Id - --- When hashing a class or family instance, we hash only the --- DFunId or CoAxiom, because that depends on all the --- information about the instance. --- -type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance - -abiDecl :: IfaceDeclABI -> IfaceDecl -abiDecl (_, decl, _) = decl - -cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering -cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare` - getOccName (abiDecl abi2) - -freeNamesDeclABI :: IfaceDeclABI -> NameSet -freeNamesDeclABI (_mod, decl, extras) = - freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras - -freeNamesDeclExtras :: IfaceDeclExtras -> NameSet -freeNamesDeclExtras (IfaceIdExtras id_extras) - = freeNamesIdExtras id_extras -freeNamesDeclExtras (IfaceDataExtras _ insts _ subs) - = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs) -freeNamesDeclExtras (IfaceClassExtras _ insts _ subs) - = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs) -freeNamesDeclExtras (IfaceSynonymExtras _ _) - = emptyNameSet -freeNamesDeclExtras (IfaceFamilyExtras _ insts _) - = mkNameSet insts -freeNamesDeclExtras IfaceOtherDeclExtras - = emptyNameSet - -freeNamesIdExtras :: IfaceIdExtras -> NameSet -freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules) - -instance Outputable IfaceDeclExtras where - ppr IfaceOtherDeclExtras = Outputable.empty - ppr (IfaceIdExtras extras) = ppr_id_extras extras - ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns] - ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns] - ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns, - ppr_id_extras_s stuff] - ppr (IfaceClassExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns, - ppr_id_extras_s stuff] - -ppr_insts :: [IfaceInstABI] -> SDoc -ppr_insts _ = text "" - -ppr_id_extras_s :: [IfaceIdExtras] -> SDoc -ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff) - -ppr_id_extras :: IfaceIdExtras -> SDoc -ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns) - --- This instance is used only to compute fingerprints -instance Binary IfaceDeclExtras where - get _bh = panic "no get for IfaceDeclExtras" - put_ bh (IfaceIdExtras extras) = do - putByte bh 1; put_ bh extras - put_ bh (IfaceDataExtras fix insts anns cons) = do - putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons - put_ bh (IfaceClassExtras fix insts anns methods) = do - putByte bh 3; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh methods - put_ bh (IfaceSynonymExtras fix anns) = do - putByte bh 4; put_ bh fix; put_ bh anns - put_ bh (IfaceFamilyExtras fix finsts anns) = do - putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns - put_ bh IfaceOtherDeclExtras = putByte bh 6 - -instance Binary IfaceIdExtras where - get _bh = panic "no get for IfaceIdExtras" - put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns } - -declExtras :: (OccName -> Maybe Fixity) - -> (OccName -> [AnnPayload]) - -> OccEnv [IfaceRule] - -> OccEnv [IfaceClsInst] - -> OccEnv [IfaceFamInst] - -> IfaceDecl - -> IfaceDeclExtras - -declExtras fix_fn ann_fn rule_env inst_env fi_env decl - = case decl of - IfaceId{} -> IfaceIdExtras (id_extras n) - IfaceData{ifCons=cons} -> - IfaceDataExtras (fix_fn n) - (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++ - map ifDFun (lookupOccEnvL inst_env n)) - (ann_fn n) - (map (id_extras . occName . ifConName) (visibleIfConDecls cons)) - IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} -> - IfaceClassExtras (fix_fn n) - (map ifDFun $ (concatMap at_extras ats) - ++ lookupOccEnvL inst_env n) - -- Include instances of the associated types - -- as well as instances of the class (Trac #5147) - (ann_fn n) - [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs] - IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n) - (ann_fn n) - IfaceFamily{} -> IfaceFamilyExtras (fix_fn n) - (map ifFamInstAxiom (lookupOccEnvL fi_env n)) - (ann_fn n) - _other -> IfaceOtherDeclExtras - where - n = getOccName decl - id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ) - at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl) - - -lookupOccEnvL :: OccEnv [v] -> OccName -> [v] -lookupOccEnvL env k = lookupOccEnv env k `orElse` [] - -{- --- for testing: use the md5sum command to generate fingerprints and --- compare the results against our built-in version. - fp' <- oldMD5 dflags bh - if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp') - else return fp - -oldMD5 dflags bh = do - tmp <- newTempName dflags "bin" - writeBinMem bh tmp - tmp2 <- newTempName dflags "md5" - let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2 - r <- system cmd - case r of - ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r) - ExitSuccess -> do - hash_str <- readFile tmp2 - return $! readHexFingerprint hash_str --} - ----------------------- --- mkOrphMap partitions instance decls or rules into --- (a) an OccEnv for ones that are not orphans, --- mapping the local OccName to a list of its decls --- (b) a list of orphan decls -mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl - -> [decl] -- Sorted into canonical order - -> (OccEnv [decl], -- Non-orphan decls associated with their key; - -- each sublist in canonical order - [decl]) -- Orphan decls; in canonical order -mkOrphMap get_key decls - = foldl go (emptyOccEnv, []) decls - where - go (non_orphs, orphs) d - | NotOrphan occ <- get_key d - = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs) - | otherwise = (non_orphs, d:orphs) - -{- -************************************************************************ -* * - COMPLETE Pragmas -* * -************************************************************************ --} - -mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch -mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc - - -{- -************************************************************************ -* * - Keeping track of what we've slurped, and fingerprints -* * -************************************************************************ --} - - -mkIfaceAnnotation :: Annotation -> IfaceAnnotation -mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload }) - = IfaceAnnotation { - ifAnnotatedTarget = fmap nameOccName target, - ifAnnotatedValue = payload - } - -mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical -mkIfaceExports exports - = sortBy stableAvailCmp (map sort_subs exports) - where - sort_subs :: AvailInfo -> AvailInfo - sort_subs (Avail n) = Avail n - sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs) - sort_subs (AvailTC n (m:ms) fs) - | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs) - | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs) - -- Maintain the AvailTC Invariant - - sort_flds = sortBy (stableNameCmp `on` flSelector) - -{- -Note [Original module] -~~~~~~~~~~~~~~~~~~~~~ -Consider this: - module X where { data family T } - module Y( T(..) ) where { import X; data instance T Int = MkT Int } -The exported Avail from Y will look like - X.T{X.T, Y.MkT} -That is, in Y, - - only MkT is brought into scope by the data instance; - - but the parent (used for grouping and naming in T(..) exports) is X.T - - and in this case we export X.T too - -In the result of MkIfaceExports, the names are grouped by defining module, -so we may need to split up a single Avail into multiple ones. - -Note [Internal used_names] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most of the used_names are External Names, but we can have Internal -Names too: see Note [Binders in Template Haskell] in Convert, and -Trac #5362 for an example. Such Names are always - - Such Names are always for locally-defined things, for which we - don't gather usage info, so we can just ignore them in ent_map - - They are always System Names, hence the assert, just as a double check. - - -************************************************************************ -* * - Load the old interface file for this module (unless - we have it already), and check whether it is up to date -* * -************************************************************************ --} - -data RecompileRequired - = UpToDate - -- ^ everything is up to date, recompilation is not required - | MustCompile - -- ^ The .hs file has been touched, or the .o/.hi file does not exist - | RecompBecause String - -- ^ The .o/.hi files are up to date, but something else has changed - -- to force recompilation; the String says what (one-line summary) - deriving Eq - -recompileRequired :: RecompileRequired -> Bool -recompileRequired UpToDate = False -recompileRequired _ = True - - - --- | Top level function to check if the version of an old interface file --- is equivalent to the current source file the user asked us to compile. --- If the same, we can avoid recompilation. We return a tuple where the --- first element is a bool saying if we should recompile the object file --- and the second is maybe the interface file, where Nothng means to --- rebuild the interface file not use the exisitng one. -checkOldIface - :: HscEnv - -> ModSummary - -> SourceModified - -> Maybe ModIface -- Old interface from compilation manager, if any - -> IO (RecompileRequired, Maybe ModIface) - -checkOldIface hsc_env mod_summary source_modified maybe_iface - = do let dflags = hsc_dflags hsc_env - showPass dflags $ - "Checking old interface for " ++ - (showPpr dflags $ ms_mod mod_summary) ++ - " (use -ddump-hi-diffs for more details)" - initIfaceCheck (text "checkOldIface") hsc_env $ - check_old_iface hsc_env mod_summary source_modified maybe_iface - -check_old_iface - :: HscEnv - -> ModSummary - -> SourceModified - -> Maybe ModIface - -> IfG (RecompileRequired, Maybe ModIface) - -check_old_iface hsc_env mod_summary src_modified maybe_iface - = let dflags = hsc_dflags hsc_env - getIface = - case maybe_iface of - Just _ -> do - traceIf (text "We already have the old interface for" <+> - ppr (ms_mod mod_summary)) - return maybe_iface - Nothing -> loadIface - - loadIface = do - let iface_path = msHiFilePath mod_summary - read_result <- readIface (ms_mod mod_summary) iface_path - case read_result of - Failed err -> do - traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err) - traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err) - return Nothing - Succeeded iface -> do - traceIf (text "Read the interface file" <+> text iface_path) - return $ Just iface - - src_changed - | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True - | SourceModified <- src_modified = True - | otherwise = False - in do - when src_changed $ - traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off") - - case src_changed of - -- If the source has changed and we're in interactive mode, - -- avoid reading an interface; just return the one we might - -- have been supplied with. - True | not (isObjectTarget $ hscTarget dflags) -> - return (MustCompile, maybe_iface) - - -- Try and read the old interface for the current module - -- from the .hi file left from the last time we compiled it - True -> do - maybe_iface' <- getIface - return (MustCompile, maybe_iface') - - False -> do - maybe_iface' <- getIface - case maybe_iface' of - -- We can't retrieve the iface - Nothing -> return (MustCompile, Nothing) - - -- We have got the old iface; check its versions - -- even in the SourceUnmodifiedAndStable case we - -- should check versions because some packages - -- might have changed or gone away. - Just iface -> checkVersions hsc_env mod_summary iface - --- | Check if a module is still the same 'version'. --- --- This function is called in the recompilation checker after we have --- determined that the module M being checked hasn't had any changes --- to its source file since we last compiled M. So at this point in general --- two things may have changed that mean we should recompile M: --- * The interface export by a dependency of M has changed. --- * The compiler flags specified this time for M have changed --- in a manner that is significant for recompilation. --- We return not just if we should recompile the object file but also --- if we should rebuild the interface file. -checkVersions :: HscEnv - -> ModSummary - -> ModIface -- Old interface - -> IfG (RecompileRequired, Maybe ModIface) -checkVersions hsc_env mod_summary iface - = do { traceHiDiffs (text "Considering whether compilation is required for" <+> - ppr (mi_module iface) <> colon) - - -- readIface will have verified that the InstalledUnitId matches, - -- but we ALSO must make sure the instantiation matches up. See - -- test case bkpcabal04! - ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env) - then return (RecompBecause "-this-unit-id changed", Nothing) else do { - ; recomp <- checkFlagHash hsc_env iface - ; if recompileRequired recomp then return (recomp, Nothing) else do { - ; recomp <- 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 <- checkDependencies hsc_env mod_summary iface - ; if recompileRequired recomp then return (recomp, Just iface) else do { - - -- Source code unchanged and no errors yet... carry on - -- - -- First put the dependent-module info, read from the old - -- interface, into the envt, so that when we look for - -- interfaces we look for the right one (.hi or .hi-boot) - -- - -- It's just temporary because either the usage check will succeed - -- (in which case we are done with this module) or it'll fail (in which - -- case we'll compile the module from scratch anyhow). - -- - -- We do this regardless of compilation mode, although in --make mode - -- all the dependent modules should be in the HPT already, so it's - -- quite redundant - ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } - ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface] - ; return (recomp, Just iface) - }}}}}} - where - this_pkg = thisPackage (hsc_dflags hsc_env) - -- This is a bit of a hack really - mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface) - mod_deps = mkModDeps (dep_mods (mi_deps iface)) - --- | Check if an hsig file needs recompilation because its --- implementing module has changed. -checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired -checkHsig mod_summary iface = do - dflags <- getDynFlags - let outer_mod = ms_mod mod_summary - inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) - MASSERT( moduleUnitId outer_mod == thisPackage dflags ) - case inner_mod == mi_semantic_module iface of - True -> up_to_date (text "implementing module unchanged") - False -> return (RecompBecause "implementing module changed") - --- | Check the flags haven't changed -checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired -checkFlagHash hsc_env iface = do - let old_hash = mi_flag_hash iface - new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) - (mi_module iface) - putNameLiterally - case old_hash == new_hash of - True -> up_to_date (text "Module flags unchanged") - False -> out_of_date_hash "flags changed" - (text " Module flags have changed") - old_hash new_hash - --- Check that the set of signatures we are merging in match. --- If the -unit-id flags change, this can change too. -checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired -checkMergedSignatures mod_summary iface = do - dflags <- getDynFlags - let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ] - new_merged = case Map.lookup (ms_mod_name mod_summary) - (requirementContext (pkgState dflags)) of - Nothing -> [] - Just r -> sort $ map (indefModuleToModule dflags) r - if old_merged == new_merged - then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged) - else return (RecompBecause "signatures to merge in changed") - --- If the direct imports of this module are resolved to targets that --- are not among the dependencies of the previous interface file, --- then we definitely need to recompile. This catches cases like --- - an exposed package has been upgraded --- - we are compiling with different package flags --- - a home module that was shadowing a package module has been removed --- - a new home module has been added that shadows a package module --- See bug #1372. --- --- Returns (RecompBecause ) if recompilation is required. -checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired -checkDependencies hsc_env summary iface - = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary)) - where - prev_dep_mods = dep_mods (mi_deps iface) - prev_dep_pkgs = dep_pkgs (mi_deps iface) - - this_pkg = thisPackage (hsc_dflags hsc_env) - - dep_missing (mb_pkg, L _ mod) = do - find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg) - let reason = moduleNameString mod ++ " changed" - case find_res of - Found _ mod - | pkg == this_pkg - -> if moduleName mod `notElem` map fst prev_dep_mods - then do traceHiDiffs $ - text "imported module " <> quotes (ppr mod) <> - text " not among previous dependencies" - return (RecompBecause reason) - else - return UpToDate - | otherwise - -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs) - then do traceHiDiffs $ - text "imported module " <> quotes (ppr mod) <> - text " is from package " <> quotes (ppr pkg) <> - text ", which is not among previous dependencies" - return (RecompBecause reason) - else - return UpToDate - where pkg = moduleUnitId mod - _otherwise -> return (RecompBecause reason) - -needInterface :: Module -> (ModIface -> IfG RecompileRequired) - -> IfG RecompileRequired -needInterface mod continue - = do -- Load the imported interface if possible - let doc_str = sep [text "need version info for", ppr mod] - traceHiDiffs (text "Checking usages for module" <+> ppr mod) - - mb_iface <- loadInterface doc_str mod ImportBySystem - -- Load the interface, but don't complain on failure; - -- Instead, get an Either back which we can test - - case mb_iface of - Failed _ -> do - traceHiDiffs (sep [text "Couldn't load interface for module", - ppr mod]) - return MustCompile - -- Couldn't find or parse a module mentioned in the - -- old interface file. Don't complain: it might - -- just be that the current module doesn't need that - -- import and it's been deleted - Succeeded iface -> continue iface - --- | Given the usage information extracted from the old --- M.hi file for the module being compiled, figure out --- whether M needs to be recompiled. -checkModUsage :: UnitId -> Usage -> IfG RecompileRequired -checkModUsage _this_pkg UsagePackageModule{ - usg_mod = mod, - usg_mod_hash = old_mod_hash } - = needInterface mod $ \iface -> do - let reason = moduleNameString (moduleName mod) ++ " changed" - checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface) - -- We only track the ABI hash of package modules, rather than - -- individual entity usages, so if the ABI hash changes we must - -- recompile. This is safe but may entail more recompilation when - -- a dependent package has changed. - -checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } - = needInterface mod $ \iface -> do - let reason = moduleNameString (moduleName mod) ++ " changed (raw)" - checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface) - -checkModUsage this_pkg UsageHomeModule{ - usg_mod_name = mod_name, - usg_mod_hash = old_mod_hash, - usg_exports = maybe_old_export_hash, - usg_entities = old_decl_hash } - = do - let mod = mkModule this_pkg mod_name - needInterface mod $ \iface -> do - - let - new_mod_hash = mi_mod_hash iface - new_decl_hash = mi_hash_fn iface - new_export_hash = mi_exp_hash iface - - reason = moduleNameString mod_name ++ " changed" - - -- CHECK MODULE - recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash - if not (recompileRequired recompile) - then return UpToDate - else do - - -- CHECK EXPORT LIST - checkMaybeHash reason maybe_old_export_hash new_export_hash - (text " Export list changed") $ do - - -- CHECK ITEMS ONE BY ONE - recompile <- checkList [ checkEntityUsage reason new_decl_hash u - | u <- old_decl_hash] - if recompileRequired recompile - then return recompile -- This one failed, so just bail out now - else up_to_date (text " Great! The bits I use are up to date") - - -checkModUsage _this_pkg UsageFile{ usg_file_path = file, - usg_file_hash = old_hash } = - liftIO $ - handleIO handle $ do - new_hash <- getFileHash file - if (old_hash /= new_hash) - then return recomp - else return UpToDate - where - recomp = RecompBecause (file ++ " changed") - handle = -#ifdef DEBUG - \e -> pprTrace "UsageFile" (text (show e)) $ return recomp -#else - \_ -> return recomp -- if we can't find the file, just recompile, don't fail -#endif - ------------------------- -checkModuleFingerprint :: String -> Fingerprint -> Fingerprint - -> IfG RecompileRequired -checkModuleFingerprint reason old_mod_hash new_mod_hash - | new_mod_hash == old_mod_hash - = up_to_date (text "Module fingerprint unchanged") - - | otherwise - = out_of_date_hash reason (text " Module fingerprint has changed") - old_mod_hash new_mod_hash - ------------------------- -checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc - -> IfG RecompileRequired -> IfG RecompileRequired -checkMaybeHash reason maybe_old_hash new_hash doc continue - | Just hash <- maybe_old_hash, hash /= new_hash - = out_of_date_hash reason doc hash new_hash - | otherwise - = continue - ------------------------- -checkEntityUsage :: String - -> (OccName -> Maybe (OccName, Fingerprint)) - -> (OccName, Fingerprint) - -> IfG RecompileRequired -checkEntityUsage reason new_hash (name,old_hash) - = case new_hash name of - - Nothing -> -- We used it before, but it ain't there now - out_of_date reason (sep [text "No longer exported:", ppr name]) - - Just (_, new_hash) -- It's there, but is it up to date? - | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) - return UpToDate - | otherwise -> out_of_date_hash reason (text " Out of date:" <+> ppr name) - old_hash new_hash - -up_to_date :: SDoc -> IfG RecompileRequired -up_to_date msg = traceHiDiffs msg >> return UpToDate - -out_of_date :: String -> SDoc -> IfG RecompileRequired -out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason) - -out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired -out_of_date_hash reason msg old_hash new_hash - = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) - ----------------------- -checkList :: [IfG RecompileRequired] -> IfG RecompileRequired --- This helper is used in two places -checkList [] = return UpToDate -checkList (check:checks) = do recompile <- check - if recompileRequired recompile - then return recompile - else checkList checks - -{- -************************************************************************ -* * - Converting things to their Iface equivalents -* * -************************************************************************ --} - -tyThingToIfaceDecl :: TyThing -> IfaceDecl -tyThingToIfaceDecl (AnId id) = idToIfaceDecl id -tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) -tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax -tyThingToIfaceDecl (AConLike cl) = case cl of - RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only - PatSynCon ps -> patSynToIfaceDecl ps - --------------------------- -idToIfaceDecl :: Id -> IfaceDecl --- The Id is already tidied, so that locally-bound names --- (lambdas, for-alls) already have non-clashing OccNames --- We can't tidy it here, locally, because it may have --- free variables in its type or IdInfo -idToIfaceDecl id - = IfaceId { ifName = getName id, - ifType = toIfaceType (idType id), - ifIdDetails = toIfaceIdDetails (idDetails id), - ifIdInfo = toIfaceIdInfo (idInfo id) } - --------------------------- -dataConToIfaceDecl :: DataCon -> IfaceDecl -dataConToIfaceDecl dataCon - = IfaceId { ifName = getName dataCon, - ifType = toIfaceType (dataConUserType dataCon), - ifIdDetails = IfVanillaId, - ifIdInfo = NoInfo } - --------------------------- -coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl --- We *do* tidy Axioms, because they are not (and cannot --- conveniently be) built in tidy form -coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches - , co_ax_role = role }) - = IfaceAxiom { ifName = getName ax - , ifTyCon = toIfaceTyCon tycon - , ifRole = role - , ifAxBranches = map (coAxBranchToIfaceBranch tycon - (map coAxBranchLHS branch_list)) - branch_list } - where - branch_list = fromBranches branches - --- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches --- to incompatible indices --- See Note [Storing compatibility] in CoAxiom -coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch -coAxBranchToIfaceBranch tc lhs_s - branch@(CoAxBranch { cab_incomps = incomps }) - = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps } - where - iface_incomps = map (expectJust "iface_incomps" - . (flip findIndex lhs_s - . eqTypes) - . coAxBranchLHS) incomps - --- use this one for standalone branches without incompatibles -coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch -coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = lhs - , cab_roles = roles, cab_rhs = rhs }) - = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tidy_tvs - , ifaxbCoVars = map toIfaceIdBndr cvs - , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs - , ifaxbRoles = roles - , ifaxbRHS = tidyToIfaceType env1 rhs - , ifaxbIncomps = [] } - where - (env1, tidy_tvs) = tidyTyCoVarBndrs emptyTidyEnv tvs - -- Don't re-bind in-scope tyvars - -- See Note [CoAxBranch type variables] in CoAxiom - ------------------ -tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) --- We *do* tidy TyCons, because they are not (and cannot --- conveniently be) built in tidy form --- The returned TidyEnv is the one after tidying the tyConTyVars -tyConToIfaceDecl env tycon - | Just clas <- tyConClass_maybe tycon - = classToIfaceDecl env clas - - | Just syn_rhs <- synTyConRhs_maybe tycon - = ( tc_env1 - , IfaceSynonym { ifName = getName tycon, - ifRoles = tyConRoles tycon, - ifSynRhs = if_syn_type syn_rhs, - ifBinders = if_binders, - ifResKind = if_res_kind - }) - - | Just fam_flav <- famTyConFlav_maybe tycon - = ( tc_env1 - , IfaceFamily { ifName = getName tycon, - ifResVar = if_res_var, - ifFamFlav = to_if_fam_flav fam_flav, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifFamInj = familyTyConInjectivityInfo tycon - }) - - | isAlgTyCon tycon - = ( tc_env1 - , IfaceData { ifName = getName tycon, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifCType = tyConCType tycon, - ifRoles = tyConRoles tycon, - ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), - ifCons = ifaceConDecls (algTyConRhs tycon), - ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifParent = parent }) - - | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon - -- We only convert these TyCons to IfaceTyCons when we are - -- just about to pretty-print them, not because we are going - -- to put them into interface files - = ( env - , IfaceData { ifName = getName tycon, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifCType = Nothing, - ifRoles = tyConRoles tycon, - ifCtxt = [], - ifCons = IfDataTyCon [], - ifGadtSyntax = False, - ifParent = IfNoParent }) - where - -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon` - -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause - -- an error. - (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) - tc_tyvars = binderVars tc_binders - if_binders = toIfaceTyVarBinders tc_binders - if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) - if_syn_type ty = tidyToIfaceType tc_env1 ty - if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon - - parent = case tyConFamInstSig_maybe tycon of - Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) - (toIfaceTyCon tc) - (tidyToIfaceTcArgs tc_env1 tc ty) - Nothing -> IfNoParent - - to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon - to_if_fam_flav (ClosedSynFamilyTyCon (Just ax)) - = IfaceClosedSynFamilyTyCon (Just (axn, ibr)) - where defs = fromBranches $ coAxiomBranches ax - ibr = map (coAxBranchToIfaceBranch' tycon) defs - axn = coAxiomName ax - to_if_fam_flav (ClosedSynFamilyTyCon Nothing) - = IfaceClosedSynFamilyTyCon Nothing - to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon - to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon - to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon - - - - ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con] - ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls AbstractTyCon = IfAbstractTyCon - -- The AbstractTyCon case happens when a TyCon has been trimmed - -- during tidying. - -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver - -- for GHCi, when browsing a module, in which case the - -- AbstractTyCon and TupleTyCon cases are perfectly sensible. - -- (Tuple declarations are not serialised into interface files.) - - ifaceConDecl data_con - = IfCon { ifConName = dataConName data_con, - ifConInfix = dataConIsInfix data_con, - ifConWrapper = isJust (dataConWrapId_maybe data_con), - ifConExTvs = map toIfaceForAllBndr ex_bndrs', - ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, - ifConCtxt = tidyToIfaceContext con_env2 theta, - ifConArgTys = map (tidyToIfaceType con_env2) arg_tys, - ifConFields = dataConFieldLabels data_con, - ifConStricts = map (toIfaceBang con_env2) - (dataConImplBangs data_con), - ifConSrcStricts = map toIfaceSrcBang - (dataConSrcBangs data_con)} - where - (univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _) - = dataConFullSig data_con - ex_bndrs = dataConExTyVarBinders data_con - - -- Tidy the univ_tvs of the data constructor to be identical - -- to the tyConTyVars of the type constructor. This means - -- (a) we don't need to redundantly put them into the interface file - -- (b) when pretty-printing an Iface data declaration in H98-style syntax, - -- we know that the type variables will line up - -- The latter (b) is important because we pretty-print type constructors - -- by converting to IfaceSyn and pretty-printing that - con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars)) - -- A bit grimy, perhaps, but it's simple! - - (con_env2, ex_bndrs') = tidyTyVarBinders con_env1 ex_bndrs - to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty) - -classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) -classToIfaceDecl env clas - = ( env1 - , IfaceClass { ifName = getName tycon, - ifRoles = tyConRoles (classTyCon clas), - ifBinders = toIfaceTyVarBinders tc_binders, - ifBody = body, - ifFDs = map toIfaceFD clas_fds }) - where - (_, clas_fds, sc_theta, _, clas_ats, op_stuff) - = classExtraBigSig clas - tycon = classTyCon clas - - body | isAbstractTyCon tycon = IfAbstractClass - | otherwise - = IfConcreteClass { - ifClassCtxt = tidyToIfaceContext env1 sc_theta, - ifATs = map toIfaceAT clas_ats, - ifSigs = map toIfaceClassOp op_stuff, - ifMinDef = fmap getOccFS (classMinimalDef clas) - } - - (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) - - toIfaceAT :: ClassATItem -> IfaceAT - toIfaceAT (ATI tc def) - = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def) - where - (env2, if_decl) = tyConToIfaceDecl env1 tc - - toIfaceClassOp (sel_id, def_meth) - = ASSERT( sel_tyvars == binderVars tc_binders ) - IfaceClassOp (getName sel_id) - (tidyToIfaceType env1 op_ty) - (fmap toDmSpec def_meth) - where - -- Be careful when splitting the type, because of things - -- like class Foo a where - -- op :: (?x :: String) => a -> a - -- and class Baz a where - -- op :: (Ord a) => a -> a - (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) - op_ty = funResultTy rho_ty - - toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType - toDmSpec (_, VanillaDM) = VanillaDM - toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty) - - toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1 - ,map (tidyTyVar env1) tvs2) - --------------------------- - -tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder) --- If the type variable "binder" is in scope, don't re-bind it --- In a class decl, for example, the ATD binders mention --- (amd must mention) the class tyvars -tidyTyConBinder env@(_, subst) tvb@(TvBndr tv vis) - = case lookupVarEnv subst tv of - Just tv' -> (env, TvBndr tv' vis) - Nothing -> tidyTyVarBinder env tvb - -tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) -tidyTyConBinders = mapAccumL tidyTyConBinder - -tidyTyVar :: TidyEnv -> TyVar -> FastString -tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) - --------------------------- -instanceToIfaceInst :: ClsInst -> IfaceClsInst -instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag - , is_cls_nm = cls_name, is_cls = cls - , is_tcs = mb_tcs - , is_orphan = orph }) - = ASSERT( cls_name == className cls ) - IfaceClsInst { ifDFun = dfun_name, - ifOFlag = oflag, - ifInstCls = cls_name, - ifInstTys = map do_rough mb_tcs, - ifInstOrph = orph } - where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name n) - - dfun_name = idName dfun_id - - --------------------------- -famInstToIfaceFamInst :: FamInst -> IfaceFamInst -famInstToIfaceFamInst (FamInst { fi_axiom = axiom, - fi_fam = fam, - fi_tcs = roughs }) - = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom - , ifFamInstFam = fam - , ifFamInstTys = map do_rough roughs - , ifFamInstOrph = orph } - where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name n) - - fam_decl = tyConName $ coAxiomTyCon axiom - mod = ASSERT( isExternalName (coAxiomName axiom) ) - nameModule (coAxiomName axiom) - is_local name = nameIsLocalOrFrom mod name - - lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom) - - orph | is_local fam_decl - = NotOrphan (nameOccName fam_decl) - | otherwise - = chooseOrphanAnchor lhs_names - --------------------------- -coreRuleToIfaceRule :: CoreRule -> IfaceRule -coreRuleToIfaceRule (BuiltinRule { ru_fn = fn}) - = pprTrace "toHsRule: builtin" (ppr fn) $ - bogusIfaceRule fn - -coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, - ru_act = act, ru_bndrs = bndrs, - ru_args = args, ru_rhs = rhs, - ru_orphan = orph, ru_auto = auto }) - = IfaceRule { ifRuleName = name, ifActivation = act, - ifRuleBndrs = map toIfaceBndr bndrs, - ifRuleHead = fn, - ifRuleArgs = map do_arg args, - ifRuleRhs = toIfaceExpr rhs, - ifRuleAuto = auto, - ifRuleOrph = orph } - where - -- For type args we must remove synonyms from the outermost - -- level. Reason: so that when we read it back in we'll - -- construct the same ru_rough field as we have right now; - -- see tcIfaceRule - do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) - do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) - do_arg arg = toIfaceExpr arg - -bogusIfaceRule :: Name -> IfaceRule -bogusIfaceRule id_name - = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive, - ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], - ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan, - ifRuleAuto = True } diff --git a/iface/TcIface.hs b/iface/TcIface.hs deleted file mode 100644 --- a/iface/TcIface.hs +++ /dev/null @@ -1,1875 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Type checking of type signatures in interface files --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE NondecreasingIndentation #-} - -module TcIface ( - tcLookupImported_maybe, - importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, - typecheckIfacesForMerging, - typecheckIfaceForInstantiate, - tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, - tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceCompleteSigs, - tcIfaceExpr, -- Desired by HERMIT (Trac #7683) - tcIfaceGlobal - ) where - -#include "HsVersions.h" - -import TcTypeNats(typeNatCoAxiomRules) -import IfaceSyn -import LoadIface -import IfaceEnv -import BuildTyCl -import TcRnMonad -import TcType -import Type -import Coercion -import CoAxiom -import TyCoRep -- needs to build types & coercions in a knot -import HscTypes -import Annotations -import InstEnv -import FamInstEnv -import CoreSyn -import CoreUtils -import CoreUnfold -import CoreLint -import MkCore -import Id -import MkId -import IdInfo -import Class -import TyCon -import ConLike -import DataCon -import PrelNames -import TysWiredIn -import Literal -import Var -import VarEnv -import VarSet -import Name -import NameEnv -import NameSet -import OccurAnal ( occurAnalyseExpr ) -import Demand -import Module -import UniqFM -import UniqSupply -import Outputable -import Maybes -import SrcLoc -import DynFlags -import Util -import FastString -import BasicTypes hiding ( SuccessFlag(..) ) -import ListSetOps -import GHC.Fingerprint -import qualified BooleanFormula as BF - -import Data.List -import Control.Monad -import qualified Data.Map as Map - -{- -This module takes - - IfaceDecl -> TyThing - IfaceType -> Type - etc - -An IfaceDecl is populated with RdrNames, and these are not renamed to -Names before typechecking, because there should be no scope errors etc. - - -- For (b) consider: f = \$(...h....) - -- where h is imported, and calls f via an hi-boot file. - -- This is bad! But it is not seen as a staging error, because h - -- is indeed imported. We don't want the type-checker to black-hole - -- when simplifying and compiling the splice! - -- - -- Simple solution: discard any unfolding that mentions a variable - -- bound in this module (and hence not yet processed). - -- The discarding happens when forkM finds a type error. - - -************************************************************************ -* * - Type-checking a complete interface -* * -************************************************************************ - -Suppose we discover we don't need to recompile. Then we must type -check the old interface file. This is a bit different to the -incremental type checking we do as we suck in interface files. Instead -we do things similarly as when we are typechecking source decls: we -bring into scope the type envt for the interface all at once, using a -knot. Remember, the decls aren't necessarily in dependency order -- -and even if they were, the type decls might be mutually recursive. - -Note [Knot-tying typecheckIface] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are typechecking an interface A.hi, and we come across -a Name for another entity defined in A.hi. How do we get the -'TyCon', in this case? There are three cases: - - 1) tcHiBootIface in TcIface: We're typechecking an hi-boot file in - preparation of checking if the hs file we're building - is compatible. In this case, we want all of the internal - TyCons to MATCH the ones that we just constructed during - typechecking: the knot is thus tied through if_rec_types. - - 2) retypecheckLoop in GhcMake: We are retypechecking a - mutually recursive cluster of hi files, in order to ensure - that all of the references refer to each other correctly. - In this case, the knot is tied through the HPT passed in, - which contains all of the interfaces we are in the process - of typechecking. - - 3) genModDetails in HscMain: We are typechecking an - old interface to generate the ModDetails. In this case, - we do the same thing as (2) and pass in an HPT with - the HomeModInfo being generated to tie knots. - -The upshot is that the CLIENT of this function is responsible -for making sure that the knot is tied correctly. If you don't, -then you'll get a message saying that we couldn't load the -declaration you wanted. - -BTW, in one-shot mode we never call typecheckIface; instead, -loadInterface handles type-checking interface. In that case, -knots are tied through the EPS. No problem! --} - --- Clients of this function be careful, see Note [Knot-tying typecheckIface] -typecheckIface :: ModIface -- Get the decls from here - -> IfG ModDetails -typecheckIface iface - = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do - { -- Get the right set of decls and rules. If we are compiling without -O - -- we discard pragmas before typechecking, so that we don't "see" - -- information that we shouldn't. From a versioning point of view - -- It's not actually *wrong* to do so, but in fact GHCi is unable - -- to handle unboxed tuples, so it must not see unfoldings. - ignore_prags <- goptM Opt_IgnoreInterfacePragmas - - -- Typecheck the decls. This is done lazily, so that the knot-tying - -- within this single module works out right. It's the callers - -- job to make sure the knot is tied. - ; names_w_things <- loadDecls ignore_prags (mi_decls iface) - ; let type_env = mkNameEnv names_w_things - - -- Now do those rules, instances and annotations - ; insts <- mapM tcIfaceInst (mi_insts iface) - ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) - ; rules <- tcIfaceRules ignore_prags (mi_rules iface) - ; anns <- tcIfaceAnnotations (mi_anns iface) - - -- Vectorisation information - ; vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface) - - -- Exports - ; exports <- ifaceExportNames (mi_exports iface) - - -- Complete Sigs - ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) - - -- Finished - ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface), - -- Careful! If we tug on the TyThing thunks too early - -- we'll infinite loop with hs-boot. See #10083 for - -- an example where this would cause non-termination. - text "Type envt:" <+> ppr (map fst names_w_things)]) - ; return $ ModDetails { md_types = type_env - , md_insts = insts - , md_fam_insts = fam_insts - , md_rules = rules - , md_anns = anns - , md_vect_info = vect_info - , md_exports = exports - , md_complete_sigs = complete_sigs - } - } - -{- -************************************************************************ -* * - Typechecking for merging -* * -************************************************************************ --} - --- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type) -isAbstractIfaceDecl :: IfaceDecl -> Bool -isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True -isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True -isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True -isAbstractIfaceDecl _ = False - -ifMaybeRoles :: IfaceDecl -> Maybe [Role] -ifMaybeRoles IfaceData { ifRoles = rs } = Just rs -ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs -ifMaybeRoles IfaceClass { ifRoles = rs } = Just rs -ifMaybeRoles _ = Nothing - --- | Merge two 'IfaceDecl's together, preferring a non-abstract one. If --- both are non-abstract we pick one arbitrarily (and check for consistency --- later.) -mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl -mergeIfaceDecl d1 d2 - | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1 - | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2 - | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1 - , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2 - = let ops = nameEnvElts $ - plusNameEnv_C mergeIfaceClassOp - (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ]) - (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ]) - in d1 { ifBody = (ifBody d1) { - ifSigs = ops, - ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2] - } - } `withRolesFrom` d2 - -- It doesn't matter; we'll check for consistency later when - -- we merge, see 'mergeSignatures' - | otherwise = d1 `withRolesFrom` d2 - --- Note [Role merging] --- ~~~~~~~~~~~~~~~~~~~ --- First, why might it be necessary to do a non-trivial role --- merge? It may rescue a merge that might otherwise fail: --- --- signature A where --- type role T nominal representational --- data T a b --- --- signature A where --- type role T representational nominal --- data T a b --- --- A module that defines T as representational in both arguments --- would successfully fill both signatures, so it would be better --- if we merged the roles of these types in some nontrivial --- way. --- --- However, we have to be very careful about how we go about --- doing this, because role subtyping is *conditional* on --- the supertype being NOT representationally injective, e.g., --- if we have instead: --- --- signature A where --- type role T nominal representational --- data T a b = T a b --- --- signature A where --- type role T representational nominal --- data T a b = T a b --- --- Should we merge the definitions of T so that the roles are R/R (or N/N)? --- Absolutely not: neither resulting type is a subtype of the original --- types (see Note [Role subtyping]), because data is not representationally --- injective. --- --- Thus, merging only occurs when BOTH TyCons in question are --- representationally injective. If they're not, no merge. - -withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl -d1 `withRolesFrom` d2 - | Just roles1 <- ifMaybeRoles d1 - , Just roles2 <- ifMaybeRoles d2 - , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2) - = d1 { ifRoles = mergeRoles roles1 roles2 } - | otherwise = d1 - where - mergeRoles roles1 roles2 = zipWith max roles1 roles2 - -isRepInjectiveIfaceDecl :: IfaceDecl -> Bool -isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True -isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True -isRepInjectiveIfaceDecl _ = False - -mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp -mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1 -mergeIfaceClassOp _ op2 = op2 - --- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'. -mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl -mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl - --- | This is a very interesting function. Like typecheckIface, we want --- to type check an interface file into a ModDetails. However, the use-case --- for these ModDetails is different: we want to compare all of the --- ModDetails to ensure they define compatible declarations, and then --- merge them together. So in particular, we have to take a different --- strategy for knot-tying: we first speculatively merge the declarations --- to get the "base" truth for what we believe the types will be --- (this is "type computation.") Then we read everything in relative --- to this truth and check for compatibility. --- --- During the merge process, we may need to nondeterministically --- pick a particular declaration to use, if multiple signatures define --- the declaration ('mergeIfaceDecl'). If, for all choices, there --- are no type synonym cycles in the resulting merged graph, then --- we can show that our choice cannot matter. Consider the --- set of entities which the declarations depend on: by assumption --- of acyclicity, we can assume that these have already been shown to be equal --- to each other (otherwise merging will fail). Then it must --- be the case that all candidate declarations here are type-equal --- (the choice doesn't matter) or there is an inequality (in which --- case merging will fail.) --- --- Unfortunately, the choice can matter if there is a cycle. Consider the --- following merge: --- --- signature H where { type A = C; type B = A; data C } --- signature H where { type A = (); data B; type C = B } --- --- If we pick @type A = C@ as our representative, there will be --- a cycle and merging will fail. But if we pick @type A = ()@ as --- our representative, no cycle occurs, and we instead conclude --- that all of the types are unit. So it seems that we either --- (a) need a stronger acyclicity check which considers *all* --- possible choices from a merge, or (b) we must find a selection --- of declarations which is acyclic, and show that this is always --- the "best" choice we could have made (ezyang conjectures this --- is the case but does not have a proof). For now this is --- not implemented. --- --- It's worth noting that at the moment, a data constructor and a --- type synonym are never compatible. Consider: --- --- signature H where { type Int=C; type B = Int; data C = Int} --- signature H where { export Prelude.Int; data B; type C = B; } --- --- This will be rejected, because the reexported Int in the second --- signature (a proper data type) is never considered equal to a --- type synonym. Perhaps this should be relaxed, where a type synonym --- in a signature is considered implemented by a data type declaration --- which matches the reference of the type synonym. -typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails]) -typecheckIfacesForMerging mod ifaces tc_env_var = - -- cannot be boot (False) - initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do - ignore_prags <- goptM Opt_IgnoreInterfacePragmas - -- Build the initial environment - -- NB: Don't include dfuns here, because we don't want to - -- serialize them out. See Note [rnIfaceNeverExported] in RnModIface - -- NB: But coercions are OK, because they will have the right OccName. - let mk_decl_env decls - = mkOccEnv [ (getOccName decl, decl) - | decl <- decls - , case decl of - IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns - _ -> True ] - decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces - :: [OccEnv IfaceDecl] - decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs - :: OccEnv IfaceDecl - -- TODO: change loadDecls to accept w/o Fingerprint - names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x)) - (occEnvElts decl_env)) - let global_type_env = mkNameEnv names_w_things - writeMutVar tc_env_var global_type_env - - -- OK, now typecheck each ModIface using this environment - details <- forM ifaces $ \iface -> do - -- See Note [Resolving never-exported Names in TcIface] - type_env <- fixM $ \type_env -> do - setImplicitEnvM type_env $ do - decls <- loadDecls ignore_prags (mi_decls iface) - return (mkNameEnv decls) - -- But note that we use this type_env to typecheck references to DFun - -- in 'IfaceInst' - setImplicitEnvM type_env $ do - insts <- mapM tcIfaceInst (mi_insts iface) - fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) - rules <- tcIfaceRules ignore_prags (mi_rules iface) - anns <- tcIfaceAnnotations (mi_anns iface) - vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface) - exports <- ifaceExportNames (mi_exports iface) - complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) - return $ ModDetails { md_types = type_env - , md_insts = insts - , md_fam_insts = fam_insts - , md_rules = rules - , md_anns = anns - , md_vect_info = vect_info - , md_exports = exports - , md_complete_sigs = complete_sigs - } - return (global_type_env, details) - --- | Typecheck a signature 'ModIface' under the assumption that we have --- instantiated it under some implementation (recorded in 'mi_semantic_module') --- and want to check if the implementation fills the signature. --- --- This needs to operate slightly differently than 'typecheckIface' --- because (1) we have a 'NameShape', from the exports of the --- implementing module, which we will use to give our top-level --- declarations the correct 'Name's even when the implementor --- provided them with a reexport, and (2) we have to deal with --- DFun silliness (see Note [rnIfaceNeverExported]) -typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails -typecheckIfaceForInstantiate nsubst iface = - initIfaceLclWithSubst (mi_semantic_module iface) - (text "typecheckIfaceForInstantiate") - (mi_boot iface) nsubst $ do - ignore_prags <- goptM Opt_IgnoreInterfacePragmas - -- See Note [Resolving never-exported Names in TcIface] - type_env <- fixM $ \type_env -> do - setImplicitEnvM type_env $ do - decls <- loadDecls ignore_prags (mi_decls iface) - return (mkNameEnv decls) - -- See Note [rnIfaceNeverExported] - setImplicitEnvM type_env $ do - insts <- mapM tcIfaceInst (mi_insts iface) - fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) - rules <- tcIfaceRules ignore_prags (mi_rules iface) - anns <- tcIfaceAnnotations (mi_anns iface) - vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface) - exports <- ifaceExportNames (mi_exports iface) - complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) - return $ ModDetails { md_types = type_env - , md_insts = insts - , md_fam_insts = fam_insts - , md_rules = rules - , md_anns = anns - , md_vect_info = vect_info - , md_exports = exports - , md_complete_sigs = complete_sigs - } - --- Note [Resolving never-exported Names in TcIface] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- For the high-level overview, see --- Note [Handling never-exported TyThings under Backpack] --- --- As described in 'typecheckIfacesForMerging', the splendid innovation --- of signature merging is to rewrite all Names in each of the signatures --- we are merging together to a pre-merged structure; this is the key --- ingredient that lets us solve some problems when merging type --- synonyms. --- --- However, when a 'Name' refers to a NON-exported entity, as is the --- case with the DFun of a ClsInst, or a CoAxiom of a type family, --- this strategy causes problems: if we pick one and rewrite all --- references to a shared 'Name', we will accidentally fail to check --- if the DFun or CoAxioms are compatible, as they will never be --- checked--only exported entities are checked for compatibility, --- and a non-exported TyThing is checked WHEN we are checking the --- ClsInst or type family for compatibility in checkBootDeclM. --- By virtue of the fact that everything's been pointed to the merged --- declaration, you'll never notice there's a difference even if there --- is one. --- --- Fortunately, there are only a few places in the interface declarations --- where this can occur, so we replace those calls with 'tcIfaceImplicit', --- which will consult a local TypeEnv that records any never-exported --- TyThings which we should wire up with. --- --- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a --- type family can refer to a coercion axiom, all of which are done in one go --- when we typecheck 'mi_decls'. An alternate strategy would be to typecheck --- coercions first before type families, but that seemed more fragile. --- - -{- -************************************************************************ -* * - Type and class declarations -* * -************************************************************************ --} - -tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo --- Load the hi-boot iface for the module being compiled, --- if it indeed exists in the transitive closure of imports --- Return the ModDetails; Nothing if no hi-boot iface -tcHiBootIface hsc_src mod - | HsBootFile <- hsc_src -- Already compiling a hs-boot file - = return NoSelfBoot - | otherwise - = do { traceIf (text "loadHiBootInterface" <+> ppr mod) - - ; mode <- getGhcMode - ; if not (isOneShot mode) - -- In --make and interactive mode, if this module has an hs-boot file - -- we'll have compiled it already, and it'll be in the HPT - -- - -- We check wheher the interface is a *boot* interface. - -- It can happen (when using GHC from Visual Studio) that we - -- compile a module in TypecheckOnly mode, with a stable, - -- fully-populated HPT. In that case the boot interface isn't there - -- (it's been replaced by the mother module) so we can't check it. - -- And that's fine, because if M's ModInfo is in the HPT, then - -- it's been compiled once, and we don't need to check the boot iface - then do { hpt <- getHpt - ; case lookupHpt hpt (moduleName mod) of - Just info | mi_boot (hm_iface info) - -> mkSelfBootInfo (hm_iface info) (hm_details info) - _ -> return NoSelfBoot } - else do - - -- OK, so we're in one-shot mode. - -- Re #9245, we always check if there is an hi-boot interface - -- to check consistency against, rather than just when we notice - -- that an hi-boot is necessary due to a circular import. - { read_result <- findAndReadIface - need (fst (splitModuleInsts mod)) mod - True -- Hi-boot file - - ; case read_result of { - Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface - ; mkSelfBootInfo iface tc_iface } ; - Failed err -> - - -- There was no hi-boot file. But if there is circularity in - -- the module graph, there really should have been one. - -- Since we've read all the direct imports by now, - -- eps_is_boot will record if any of our imports mention the - -- current module, which either means a module loop (not - -- a SOURCE import) or that our hi-boot file has mysteriously - -- disappeared. - do { eps <- getEps - ; case lookupUFM (eps_is_boot eps) (moduleName mod) of - Nothing -> return NoSelfBoot -- The typical case - - Just (_, False) -> failWithTc moduleLoop - -- Someone below us imported us! - -- This is a loop with no hi-boot in the way - - Just (_mod, True) -> failWithTc (elaborate err) - -- The hi-boot file has mysteriously disappeared. - }}}} - where - need = text "Need the hi-boot interface for" <+> ppr mod - <+> text "to compare against the Real Thing" - - moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) - <+> text "depends on itself" - - elaborate err = hang (text "Could not find hi-boot interface for" <+> - quotes (ppr mod) <> colon) 4 err - - -mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo -mkSelfBootInfo iface mds - = do -- NB: This is computed DIRECTLY from the ModIface rather - -- than from the ModDetails, so that we can query 'sb_tcs' - -- WITHOUT forcing the contents of the interface. - let tcs = map ifName - . filter isIfaceTyCon - . map snd - $ mi_decls iface - return $ SelfBoot { sb_mds = mds - , sb_tcs = mkNameSet tcs } - where - -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on - -- this 'IfaceDecl', an ATyCon would be returned. - -- NB: This code assumes that a TyCon cannot be implicit. - isIfaceTyCon IfaceId{} = False - isIfaceTyCon IfaceData{} = True - isIfaceTyCon IfaceSynonym{} = True - isIfaceTyCon IfaceFamily{} = True - isIfaceTyCon IfaceClass{} = True - isIfaceTyCon IfaceAxiom{} = False - isIfaceTyCon IfacePatSyn{} = False - -{- -************************************************************************ -* * - Type and class declarations -* * -************************************************************************ - -When typechecking a data type decl, we *lazily* (via forkM) typecheck -the constructor argument types. This is in the hope that we may never -poke on those argument types, and hence may never need to load the -interface files for types mentioned in the arg types. - -E.g. - data Foo.S = MkS Baz.T -Maybe we can get away without even loading the interface for Baz! - -This is not just a performance thing. Suppose we have - data Foo.S = MkS Baz.T - data Baz.T = MkT Foo.S -(in different interface files, of course). -Now, first we load and typecheck Foo.S, and add it to the type envt. -If we do explore MkS's argument, we'll load and typecheck Baz.T. -If we explore MkT's argument we'll find Foo.S already in the envt. - -If we typechecked constructor args eagerly, when loading Foo.S we'd try to -typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S... -which isn't done yet. - -All very cunning. However, there is a rather subtle gotcha which bit -me when developing this stuff. When we typecheck the decl for S, we -extend the type envt with S, MkS, and all its implicit Ids. Suppose -(a bug, but it happened) that the list of implicit Ids depended in -turn on the constructor arg types. Then the following sequence of -events takes place: - * we build a thunk for the constructor arg tys - * we build a thunk for the extended type environment (depends on ) - * we write the extended type envt into the global EPS mutvar - -Now we look something up in the type envt - * that pulls on - * which reads the global type envt out of the global EPS mutvar - * but that depends in turn on - -It's subtle, because, it'd work fine if we typechecked the constructor args -eagerly -- they don't need the extended type envt. They just get the extended -type envt by accident, because they look at it later. - -What this means is that the implicitTyThings MUST NOT DEPEND on any of -the forkM stuff. --} - -tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings - -> IfaceDecl - -> IfL TyThing -tcIfaceDecl = tc_iface_decl Nothing - -tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations - -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings - -> IfaceDecl - -> IfL TyThing -tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type, - ifIdDetails = details, ifIdInfo = info}) - = do { ty <- tcIfaceType iface_type - ; details <- tcIdDetails ty details - ; info <- tcIdInfo ignore_prags name ty info - ; return (AnId (mkGlobalId details name ty info)) } - -tc_iface_decl _ _ (IfaceData {ifName = tc_name, - ifCType = cType, - ifBinders = binders, - ifResKind = res_kind, - ifRoles = roles, - ifCtxt = ctxt, ifGadtSyntax = gadt_syn, - ifCons = rdr_cons, - ifParent = mb_parent }) - = bindIfaceTyConBinders_AT binders $ \ binders' -> do - { res_kind' <- tcIfaceType res_kind - - ; tycon <- fixM $ \ tycon -> do - { stupid_theta <- tcIfaceCtxt ctxt - ; parent' <- tc_parent tc_name mb_parent - ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons - ; return (mkAlgTyCon tc_name binders' res_kind' - roles cType stupid_theta - cons parent' gadt_syn) } - ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) - ; return (ATyCon tycon) } - where - tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav - tc_parent tc_name IfNoParent - = do { tc_rep_name <- newTyConRepName tc_name - ; return (VanillaAlgTyCon tc_rep_name) } - tc_parent _ (IfDataInstance ax_name _ arg_tys) - = do { ax <- tcIfaceCoAxiom ax_name - ; let fam_tc = coAxiomTyCon ax - ax_unbr = toUnbranchedAxiom ax - ; lhs_tys <- tcIfaceTcArgs arg_tys - ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) } - -tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name, - ifRoles = roles, - ifSynRhs = rhs_ty, - ifBinders = binders, - ifResKind = res_kind }) - = bindIfaceTyConBinders_AT binders $ \ binders' -> do - { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] - ; rhs <- forkM (mk_doc tc_name) $ - tcIfaceType rhs_ty - ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs - ; return (ATyCon tycon) } - where - mk_doc n = text "Type synonym" <+> ppr n - -tc_iface_decl parent _ (IfaceFamily {ifName = tc_name, - ifFamFlav = fam_flav, - ifBinders = binders, - ifResKind = res_kind, - ifResVar = res, ifFamInj = inj }) - = bindIfaceTyConBinders_AT binders $ \ binders' -> do - { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] - ; rhs <- forkM (mk_doc tc_name) $ - tc_fam_flav tc_name fam_flav - ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res - ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj - ; return (ATyCon tycon) } - where - mk_doc n = text "Type synonym" <+> ppr n - - tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav - tc_fam_flav tc_name IfaceDataFamilyTyCon - = do { tc_rep_name <- newTyConRepName tc_name - ; return (DataFamilyTyCon tc_rep_name) } - tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon - tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches) - = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches - ; return (ClosedSynFamilyTyCon ax) } - tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon - = return AbstractClosedSynFamilyTyCon - tc_fam_flav _ IfaceBuiltInSynFamTyCon - = pprPanic "tc_iface_decl" - (text "IfaceBuiltInSynFamTyCon in interface file") - -tc_iface_decl _parent _ignore_prags - (IfaceClass {ifName = tc_name, - ifRoles = roles, - ifBinders = binders, - ifFDs = rdr_fds, - ifBody = IfAbstractClass}) - = bindIfaceTyConBinders binders $ \ binders' -> do - { fds <- mapM tc_fd rdr_fds - ; cls <- buildClass tc_name binders' roles fds Nothing - ; return (ATyCon (classTyCon cls)) } - -tc_iface_decl _parent ignore_prags - (IfaceClass {ifName = tc_name, - ifRoles = roles, - ifBinders = binders, - ifFDs = rdr_fds, - ifBody = IfConcreteClass { - ifClassCtxt = rdr_ctxt, - ifATs = rdr_ats, ifSigs = rdr_sigs, - ifMinDef = mindef_occ - }}) - = bindIfaceTyConBinders binders $ \ binders' -> do - { traceIf (text "tc-iface-class1" <+> ppr tc_name) - ; ctxt <- mapM tc_sc rdr_ctxt - ; traceIf (text "tc-iface-class2" <+> ppr tc_name) - ; sigs <- mapM tc_sig rdr_sigs - ; fds <- mapM tc_fd rdr_fds - ; traceIf (text "tc-iface-class3" <+> ppr tc_name) - ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ - ; cls <- fixM $ \ cls -> do - { ats <- mapM (tc_at cls) rdr_ats - ; traceIf (text "tc-iface-class4" <+> ppr tc_name) - ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) } - ; return (ATyCon (classTyCon cls)) } - where - tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) - -- The *length* of the superclasses is used by buildClass, and hence must - -- not be inside the thunk. But the *content* maybe recursive and hence - -- must be lazy (via forkM). Example: - -- class C (T a) => D a where - -- data T a - -- Here the associated type T is knot-tied with the class, and - -- so we must not pull on T too eagerly. See Trac #5970 - - tc_sig :: IfaceClassOp -> IfL TcMethInfo - tc_sig (IfaceClassOp op_name rdr_ty dm) - = do { let doc = mk_op_doc op_name rdr_ty - ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty - -- Must be done lazily for just the same reason as the - -- type of a data con; to avoid sucking in types that - -- it mentions unless it's necessary to do so - ; dm' <- tc_dm doc dm - ; return (op_name, op_ty, dm') } - - tc_dm :: SDoc - -> Maybe (DefMethSpec IfaceType) - -> IfL (Maybe (DefMethSpec (SrcSpan, Type))) - tc_dm _ Nothing = return Nothing - tc_dm _ (Just VanillaDM) = return (Just VanillaDM) - tc_dm doc (Just (GenericDM ty)) - = do { -- Must be done lazily to avoid sucking in types - ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty - ; return (Just (GenericDM (noSrcSpan, ty'))) } - - tc_at cls (IfaceAT tc_decl if_def) - = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl - mb_def <- case if_def of - Nothing -> return Nothing - Just def -> forkM (mk_at_doc tc) $ - extendIfaceTyVarEnv (tyConTyVars tc) $ - do { tc_def <- tcIfaceType def - ; return (Just (tc_def, noSrcSpan)) } - -- Must be done lazily in case the RHS of the defaults mention - -- the type constructor being defined here - -- e.g. type AT a; type AT b = AT [b] Trac #8002 - return (ATI tc mb_def) - - mk_sc_doc pred = text "Superclass" <+> ppr pred - mk_at_doc tc = text "Associated type" <+> ppr tc - mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty] - -tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc - , ifAxBranches = branches, ifRole = role }) - = do { tc_tycon <- tcIfaceTyCon tc - -- Must be done lazily, because axioms are forced when checking - -- for family instance consistency, and the RHS may mention - -- a hs-boot declared type constructor that is going to be - -- defined by this module. - -- e.g. type instance F Int = ToBeDefined - -- See Trac #13803 - ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name) - $ tc_ax_branches branches - ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name - , co_ax_name = tc_name - , co_ax_tc = tc_tycon - , co_ax_role = role - , co_ax_branches = manyBranches tc_branches - , co_ax_implicit = False } - ; return (ACoAxiom axiom) } - -tc_iface_decl _ _ (IfacePatSyn{ ifName = name - , ifPatMatcher = if_matcher - , ifPatBuilder = if_builder - , ifPatIsInfix = is_infix - , ifPatUnivBndrs = univ_bndrs - , ifPatExBndrs = ex_bndrs - , ifPatProvCtxt = prov_ctxt - , ifPatReqCtxt = req_ctxt - , ifPatArgs = args - , ifPatTy = pat_ty - , ifFieldLabels = field_labels }) - = do { traceIf (text "tc_iface_decl" <+> ppr name) - ; matcher <- tc_pr if_matcher - ; builder <- fmapMaybeM tc_pr if_builder - ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do - { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do - { patsyn <- forkM (mk_doc name) $ - do { prov_theta <- tcIfaceCtxt prov_ctxt - ; req_theta <- tcIfaceCtxt req_ctxt - ; pat_ty <- tcIfaceType pat_ty - ; arg_tys <- mapM tcIfaceType args - ; return $ buildPatSyn name is_infix matcher builder - (univ_tvs, req_theta) - (ex_tvs, prov_theta) - arg_tys pat_ty field_labels } - ; return $ AConLike . PatSynCon $ patsyn }}} - where - mk_doc n = text "Pattern synonym" <+> ppr n - tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool) - tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) - ; return (id, b) } - -tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar) -tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 - ; tvs2' <- mapM tcIfaceTyVar tvs2 - ; return (tvs1', tvs2') } - -tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch] -tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches - -tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] -tc_ax_branch prev_branches - (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs - , ifaxbLHS = lhs, ifaxbRHS = rhs - , ifaxbRoles = roles, ifaxbIncomps = incomps }) - = bindIfaceTyConBinders_AT - (map (\b -> TvBndr b (NamedTCB Inferred)) tv_bndrs) $ \ tvs -> - -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom - bindIfaceIds cv_bndrs $ \ cvs -> do - { tc_lhs <- tcIfaceTcArgs lhs - ; tc_rhs <- tcIfaceType rhs - ; let br = CoAxBranch { cab_loc = noSrcSpan - , cab_tvs = binderVars tvs - , cab_cvs = cvs - , cab_lhs = tc_lhs - , cab_roles = roles - , cab_rhs = tc_rhs - , cab_incomps = map (prev_branches `getNth`) incomps } - ; return (prev_branches ++ [br]) } - -tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs -tcIfaceDataCons tycon_name tycon tc_tybinders if_cons - = case if_cons of - IfAbstractTyCon -> return AbstractTyCon - IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons - ; return (mkDataTyConRhs data_cons) } - IfNewTyCon con -> do { data_con <- tc_con_decl con - ; mkNewTyConRhs tycon_name tycon data_con } - where - univ_tv_bndrs :: [TyVarBinder] - univ_tv_bndrs = mkDataConUnivTyVarBinders tc_tybinders - - tc_con_decl (IfCon { ifConInfix = is_infix, - ifConExTvs = ex_bndrs, - ifConName = dc_name, - ifConCtxt = ctxt, ifConEqSpec = spec, - ifConArgTys = args, ifConFields = lbl_names, - ifConStricts = if_stricts, - ifConSrcStricts = if_src_stricts}) - = -- Universally-quantified tyvars are shared with - -- parent TyCon, and are already in scope - bindIfaceForAllBndrs ex_bndrs $ \ ex_tv_bndrs -> do - { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name) - - -- Read the context and argument types, but lazily for two reasons - -- (a) to avoid looking tugging on a recursive use of - -- the type itself, which is knot-tied - -- (b) to avoid faulting in the component types unless - -- they are really needed - ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $ - do { eq_spec <- tcIfaceEqSpec spec - ; theta <- tcIfaceCtxt ctxt - ; arg_tys <- mapM tcIfaceType args - ; stricts <- mapM tc_strict if_stricts - -- The IfBang field can mention - -- the type itself; hence inside forkM - ; return (eq_spec, theta, arg_tys, stricts) } - - -- Remember, tycon is the representation tycon - ; let orig_res_ty = mkFamilyTyConApp tycon - (substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) - (binderVars tc_tybinders)) - - ; prom_rep_name <- newTyConRepName dc_name - - ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name)) - dc_name is_infix prom_rep_name - (map src_strict if_src_stricts) - (Just stricts) - -- Pass the HsImplBangs (i.e. final - -- decisions) to buildDataCon; it'll use - -- these to guide the construction of a - -- worker. - -- See Note [Bangs on imported data constructors] in MkId - lbl_names - univ_tv_bndrs ex_tv_bndrs - eq_spec theta - arg_tys orig_res_ty tycon - ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name) - ; return con } - mk_doc con_name = text "Constructor" <+> ppr con_name - - tc_strict :: IfaceBang -> IfL HsImplBang - tc_strict IfNoBang = return (HsLazy) - tc_strict IfStrict = return (HsStrict) - tc_strict IfUnpack = return (HsUnpack Nothing) - tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co - ; return (HsUnpack (Just co)) } - - src_strict :: IfaceSrcBang -> HsSrcBang - src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang - -tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec] -tcIfaceEqSpec spec - = mapM do_item spec - where - do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ - ; ty <- tcIfaceType if_ty - ; return (mkEqSpec tv ty) } - -{- -Note [Synonym kind loop] -~~~~~~~~~~~~~~~~~~~~~~~~ -Notice that we eagerly grab the *kind* from the interface file, but -build a forkM thunk for the *rhs* (and family stuff). To see why, -consider this (Trac #2412) - -M.hs: module M where { import X; data T = MkT S } -X.hs: module X where { import {-# SOURCE #-} M; type S = T } -M.hs-boot: module M where { data T } - -When kind-checking M.hs we need S's kind. But we do not want to -find S's kind from (typeKind S-rhs), because we don't want to look at -S-rhs yet! Since S is imported from X.hi, S gets just one chance to -be defined, and we must not do that until we've finished with M.T. - -Solution: record S's kind in the interface file; now we can safely -look at it. - -************************************************************************ -* * - Instances -* * -************************************************************************ --} - -tcIfaceInst :: IfaceClsInst -> IfL ClsInst -tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag - , ifInstCls = cls, ifInstTys = mb_tcs - , ifInstOrph = orph }) - = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $ - fmap tyThingId (tcIfaceImplicit dfun_name) - ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) } - -tcIfaceFamInst :: IfaceFamInst -> IfL FamInst -tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs - , ifFamInstAxiom = axiom_name } ) - = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $ - tcIfaceCoAxiom axiom_name - -- will panic if branched, but that's OK - ; let axiom'' = toUnbranchedAxiom axiom' - mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; return (mkImportedFamInst fam mb_tcs' axiom'') } - -{- -************************************************************************ -* * - Rules -* * -************************************************************************ - -We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars -are in the type environment. However, remember that typechecking a Rule may -(as a side effect) augment the type envt, and so we may need to iterate the process. --} - -tcIfaceRules :: Bool -- True <=> ignore rules - -> [IfaceRule] - -> IfL [CoreRule] -tcIfaceRules ignore_prags if_rules - | ignore_prags = return [] - | otherwise = mapM tcIfaceRule if_rules - -tcIfaceRule :: IfaceRule -> IfL CoreRule -tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, - ifRuleAuto = auto, ifRuleOrph = orph }) - = do { ~(bndrs', args', rhs') <- - -- Typecheck the payload lazily, in the hope it'll never be looked at - forkM (text "Rule" <+> pprRuleName name) $ - bindIfaceBndrs bndrs $ \ bndrs' -> - do { args' <- mapM tcIfaceExpr args - ; rhs' <- tcIfaceExpr rhs - ; return (bndrs', args', rhs') } - ; let mb_tcs = map ifTopFreeName args - ; this_mod <- getIfModule - ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, - ru_bndrs = bndrs', ru_args = args', - ru_rhs = occurAnalyseExpr rhs', - ru_rough = mb_tcs, - ru_origin = this_mod, - ru_orphan = orph, - ru_auto = auto, - ru_local = False }) } -- An imported RULE is never for a local Id - -- or, even if it is (module loop, perhaps) - -- we'll just leave it in the non-local set - where - -- This function *must* mirror exactly what Rules.roughTopNames does - -- We could have stored the ru_rough field in the iface file - -- but that would be redundant, I think. - -- The only wrinkle is that we must not be deceived by - -- type synonyms at the top of a type arg. Since - -- we can't tell at this point, we are careful not - -- to write them out in coreRuleToIfaceRule - ifTopFreeName :: IfaceExpr -> Maybe Name - ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) - ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (tcArgsIfaceTypes ts))) - ifTopFreeName (IfaceApp f _) = ifTopFreeName f - ifTopFreeName (IfaceExt n) = Just n - ifTopFreeName _ = Nothing - -{- -************************************************************************ -* * - Annotations -* * -************************************************************************ --} - -tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] -tcIfaceAnnotations = mapM tcIfaceAnnotation - -tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation -tcIfaceAnnotation (IfaceAnnotation target serialized) = do - target' <- tcIfaceAnnTarget target - return $ Annotation { - ann_target = target', - ann_value = serialized - } - -tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name) -tcIfaceAnnTarget (NamedTarget occ) = do - name <- lookupIfaceTop occ - return $ NamedTarget name -tcIfaceAnnTarget (ModuleTarget mod) = do - return $ ModuleTarget mod - -{- -************************************************************************ -* * - Complete Match Pragmas -* * -************************************************************************ --} - -tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch] -tcIfaceCompleteSigs = mapM tcIfaceCompleteSig - -tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch -tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t) - -{- -************************************************************************ -* * - Vectorisation information -* * -************************************************************************ --} - --- We need access to the type environment as we need to look up information about type constructors --- (i.e., their data constructors and whether they are class type constructors). If a vectorised --- type constructor or class is defined in the same module as where it is vectorised, we cannot --- look that information up from the type constructor that we obtained via a 'forkM'ed --- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again --- and again and again... --- -tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo -tcIfaceVectInfo mod typeEnv (IfaceVectInfo - { ifaceVectInfoVar = vars - , ifaceVectInfoTyCon = tycons - , ifaceVectInfoTyConReuse = tyconsReuse - , ifaceVectInfoParallelVars = parallelVars - , ifaceVectInfoParallelTyCons = parallelTyCons - }) - = do { let parallelTyConsSet = mkNameSet parallelTyCons - ; vVars <- mapM vectVarMapping vars - ; let varsSet = mkVarSet (map fst vVars) - ; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons - ; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse - ; vParallelVars <- mapM vectVar parallelVars - ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2) - ; return $ VectInfo - { vectInfoVar = mkDVarEnv vVars `extendDVarEnvList` concat vScSels - , vectInfoTyCon = mkNameEnv vTyCons - , vectInfoDataCon = mkNameEnv (concat vDataCons) - , vectInfoParallelVars = mkDVarSet vParallelVars - , vectInfoParallelTyCons = parallelTyConsSet - } - } - where - vectVarMapping name - = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectOcc name) - ; var <- forkM (text "vect var" <+> ppr name) $ - tcIfaceExtId name - ; vVar <- forkM (text "vect vVar [mod =" <+> - ppr mod <> text "; nameModule =" <+> - ppr (nameModule name) <> text "]" <+> ppr vName) $ - tcIfaceExtId vName - ; return (var, (var, vVar)) - } - -- where - -- lookupLocalOrExternalId name - -- = do { let mb_id = lookupTypeEnv typeEnv name - -- ; case mb_id of - -- -- id is local - -- Just (AnId id) -> return id - -- -- name is not an Id => internal inconsistency - -- Just _ -> notAnIdErr - -- -- Id is external - -- Nothing -> tcIfaceExtId name - -- } - -- - -- notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name) - - vectVar name - = forkM (text "vect scalar var" <+> ppr name) $ - tcIfaceExtId name - - vectTyConVectMapping vars name - = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectTyConOcc name) - ; vectTyConMapping vars name vName - } - - vectTyConReuseMapping vars name - = vectTyConMapping vars name name - - vectTyConMapping vars name vName - = do { tycon <- lookupLocalOrExternalTyCon name - ; vTycon <- forkM (text "vTycon of" <+> ppr vName) $ - lookupLocalOrExternalTyCon vName - - -- Map the data constructors of the original type constructor to those of the - -- vectorised type constructor /unless/ the type constructor was vectorised - -- abstractly; if it was vectorised abstractly, the workers of its data constructors - -- do not appear in the set of vectorised variables. - -- - -- NB: This is lazy! We don't pull at the type constructors before we actually use - -- the data constructor mapping. - ; let isAbstract | isClassTyCon tycon = False - | datacon:_ <- tyConDataCons tycon - = not $ dataConWrapId datacon `elemVarSet` vars - | otherwise = True - vDataCons | isAbstract = [] - | otherwise = [ (dataConName datacon, (datacon, vDatacon)) - | (datacon, vDatacon) <- zip (tyConDataCons tycon) - (tyConDataCons vTycon) - ] - - -- Map the (implicit) superclass and methods selectors as they don't occur in - -- the var map. - vScSels | Just cls <- tyConClass_maybe tycon - , Just vCls <- tyConClass_maybe vTycon - = [ (sel, (sel, vSel)) - | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls) - ] - | otherwise - = [] - - ; return ( (name, (tycon, vTycon)) -- (T, T_v) - , vDataCons -- list of (Ci, Ci_v) - , vScSels -- list of (seli, seli_v) - ) - } - where - -- we need a fully defined version of the type constructor to be able to extract - -- its data constructors etc. - lookupLocalOrExternalTyCon name - = do { let mb_tycon = lookupTypeEnv typeEnv name - ; case mb_tycon of - -- tycon is local - Just (ATyCon tycon) -> return tycon - -- name is not a tycon => internal inconsistency - Just _ -> notATyConErr - -- tycon is external - Nothing -> tcIfaceTyConByName name - } - - notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name) - -{- -************************************************************************ -* * - Types -* * -************************************************************************ --} - -tcIfaceType :: IfaceType -> IfL Type -tcIfaceType = go - where - go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n - go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n) - go (IfaceAppTy t1 t2) = AppTy <$> go t1 <*> go t2 - go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l - go (IfaceFunTy t1 t2) = FunTy <$> go t1 <*> go t2 - go (IfaceDFunTy t1 t2) = FunTy <$> go t1 <*> go t2 - go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks - go (IfaceTyConApp tc tks) - = do { tc' <- tcIfaceTyCon tc - ; tks' <- mapM go (tcArgsIfaceTypes tks) - ; return (mkTyConApp tc' tks') } - go (IfaceForAllTy bndr t) - = bindIfaceForAllBndr bndr $ \ tv' vis -> - ForAllTy (TvBndr tv' vis) <$> go t - go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co - go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co - -tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceTcArgs -> IfL Type -tcIfaceTupleTy sort is_promoted args - = do { args' <- tcIfaceTcArgs args - ; let arity = length args' - ; base_tc <- tcTupleTyCon True sort arity - ; case is_promoted of - IsNotPromoted - -> return (mkTyConApp base_tc args') - - IsPromoted - -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc) - kind_args = map typeKind args' - ; return (mkTyConApp tc (kind_args ++ args')) } } - --- See Note [Unboxed tuple RuntimeRep vars] in TyCon -tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr) - -> TupleSort - -> Arity -- the number of args. *not* the tuple arity. - -> IfL TyCon -tcTupleTyCon in_type sort arity - = case sort of - ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity) - ; return (tyThingTyCon thing) } - BoxedTuple -> return (tupleTyCon Boxed arity) - UnboxedTuple -> return (tupleTyCon Unboxed arity') - where arity' | in_type = arity `div` 2 - | otherwise = arity - -- in expressions, we only have term args - -tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type] -tcIfaceTcArgs = mapM tcIfaceType . tcArgsIfaceTypes - ------------------------------------------ -tcIfaceCtxt :: IfaceContext -> IfL ThetaType -tcIfaceCtxt sts = mapM tcIfaceType sts - ------------------------------------------ -tcIfaceTyLit :: IfaceTyLit -> IfL TyLit -tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) -tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) - -{- -%************************************************************************ -%* * - Coercions -* * -************************************************************************ --} - -tcIfaceCo :: IfaceCoercion -> IfL Coercion -tcIfaceCo = go - where - go (IfaceReflCo r t) = Refl r <$> tcIfaceType t - go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 - go (IfaceTyConAppCo r tc cs) - = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs - go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 - go (IfaceForAllCo tv k c) = do { k' <- go k - ; bindIfaceTyVar tv $ \ tv' -> - ForAllCo tv' k' <$> go c } - go (IfaceCoVarCo n) = CoVarCo <$> go_var n - go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs - go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r - <*> tcIfaceType t1 <*> tcIfaceType t2 - go (IfaceSymCo c) = SymCo <$> go c - go (IfaceTransCo c1 c2) = TransCo <$> go c1 - <*> go c2 - go (IfaceInstCo c1 t2) = InstCo <$> go c1 - <*> go t2 - go (IfaceNthCo d c) = NthCo d <$> go c - go (IfaceLRCo lr c) = LRCo lr <$> go c - go (IfaceCoherenceCo c1 c2) = CoherenceCo <$> go c1 - <*> go c2 - go (IfaceKindCo c) = KindCo <$> go c - go (IfaceSubCo c) = SubCo <$> go c - go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> go_axiom_rule ax - <*> mapM go cos - - go_var :: FastString -> IfL CoVar - go_var = tcIfaceLclId - - go_axiom_rule :: FastString -> IfL CoAxiomRule - go_axiom_rule n = - case Map.lookup n typeNatCoAxiomRules of - Just ax -> return ax - _ -> pprPanic "go_axiom_rule" (ppr n) - -tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance -tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv -tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco -tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco -tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str -tcIfaceUnivCoProv (IfaceHoleProv _) = - pprPanic "tcIfaceUnivCoProv" (text "holes can't occur in interface files") - -{- -************************************************************************ -* * - Core -* * -************************************************************************ --} - -tcIfaceExpr :: IfaceExpr -> IfL CoreExpr -tcIfaceExpr (IfaceType ty) - = Type <$> tcIfaceType ty - -tcIfaceExpr (IfaceCo co) - = Coercion <$> tcIfaceCo co - -tcIfaceExpr (IfaceCast expr co) - = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co - -tcIfaceExpr (IfaceLcl name) - = Var <$> tcIfaceLclId name - -tcIfaceExpr (IfaceExt gbl) - = Var <$> tcIfaceExtId gbl - -tcIfaceExpr (IfaceLit lit) - = do lit' <- tcIfaceLit lit - return (Lit lit') - -tcIfaceExpr (IfaceFCall cc ty) = do - ty' <- tcIfaceType ty - u <- newUnique - dflags <- getDynFlags - return (Var (mkFCallId dflags u cc ty')) - -tcIfaceExpr (IfaceTuple sort args) - = do { args' <- mapM tcIfaceExpr args - ; tc <- tcTupleTyCon False sort arity - ; let con_tys = map exprType args' - some_con_args = map Type con_tys ++ args' - con_args = case sort of - UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args - _ -> some_con_args - -- Put the missing type arguments back in - con_id = dataConWorkId (tyConSingleDataCon tc) - ; return (mkApps (Var con_id) con_args) } - where - arity = length args - -tcIfaceExpr (IfaceLam (bndr, os) body) - = bindIfaceBndr bndr $ \bndr' -> - Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body - where - tcIfaceOneShot IfaceOneShot b = setOneShotLambda b - tcIfaceOneShot _ b = b - -tcIfaceExpr (IfaceApp fun arg) - = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg - -tcIfaceExpr (IfaceECase scrut ty) - = do { scrut' <- tcIfaceExpr scrut - ; ty' <- tcIfaceType ty - ; return (castBottomExpr scrut' ty') } - -tcIfaceExpr (IfaceCase scrut case_bndr alts) = do - scrut' <- tcIfaceExpr scrut - case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) - let - scrut_ty = exprType scrut' - case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty - tc_app = splitTyConApp scrut_ty - -- NB: Won't always succeed (polymorphic case) - -- but won't be demanded in those cases - -- NB: not tcSplitTyConApp; we are looking at Core here - -- look through non-rec newtypes to find the tycon that - -- corresponds to the datacon in this case alternative - - extendIfaceIdEnv [case_bndr'] $ do - alts' <- mapM (tcIfaceAlt scrut' tc_app) alts - return (Case scrut' case_bndr' (coreAltsType alts') alts') - -tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body) - = do { name <- newIfaceName (mkVarOccFS fs) - ; ty' <- tcIfaceType ty - ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} - name ty' info - ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info - `asJoinId_maybe` tcJoinInfo ji - ; rhs' <- tcIfaceExpr rhs - ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) - ; return (Let (NonRec id rhs') body') } - -tcIfaceExpr (IfaceLet (IfaceRec pairs) body) - = do { ids <- mapM tc_rec_bndr (map fst pairs) - ; extendIfaceIdEnv ids $ do - { pairs' <- zipWithM tc_pair pairs ids - ; body' <- tcIfaceExpr body - ; return (Let (Rec pairs') body') } } - where - tc_rec_bndr (IfLetBndr fs ty _ ji) - = do { name <- newIfaceName (mkVarOccFS fs) - ; ty' <- tcIfaceType ty - ; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) } - tc_pair (IfLetBndr _ _ info _, rhs) id - = do { rhs' <- tcIfaceExpr rhs - ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} - (idName id) (idType id) info - ; return (setIdInfo id id_info, rhs') } - -tcIfaceExpr (IfaceTick tickish expr) = do - expr' <- tcIfaceExpr expr - -- If debug flag is not set: Ignore source notes - dbgLvl <- fmap debugLevel getDynFlags - case tickish of - IfaceSource{} | dbgLvl > 0 - -> return expr' - _otherwise -> do - tickish' <- tcIfaceTickish tickish - return (Tick tickish' expr') - -------------------------- -tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id) -tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) -tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) -tcIfaceTickish (IfaceSource src name) = return (SourceNote src name) - -------------------------- -tcIfaceLit :: Literal -> IfL Literal --- Integer literals deserialise to (LitInteger i ) --- so tcIfaceLit just fills in the type. --- See Note [Integer literals] in Literal -tcIfaceLit (LitInteger i _) - = do t <- tcIfaceTyConByName integerTyConName - return (mkLitInteger i (mkTyConTy t)) -tcIfaceLit lit = return lit - -------------------------- -tcIfaceAlt :: CoreExpr -> (TyCon, [Type]) - -> (IfaceConAlt, [FastString], IfaceExpr) - -> IfL (AltCon, [TyVar], CoreExpr) -tcIfaceAlt _ _ (IfaceDefault, names, rhs) - = ASSERT( null names ) do - rhs' <- tcIfaceExpr rhs - return (DEFAULT, [], rhs') - -tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs) - = ASSERT( null names ) do - lit' <- tcIfaceLit lit - rhs' <- tcIfaceExpr rhs - return (LitAlt lit', [], rhs') - --- A case alternative is made quite a bit more complicated --- by the fact that we omit type annotations because we can --- work them out. True enough, but its not that easy! -tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) - = do { con <- tcIfaceDataCon data_occ - ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) - (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) - ; tcIfaceDataAlt con inst_tys arg_strs rhs } - -tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr - -> IfL (AltCon, [TyVar], CoreExpr) -tcIfaceDataAlt con inst_tys arg_strs rhs - = do { us <- newUniqueSupply - ; let uniqs = uniqsFromSupply us - ; let (ex_tvs, arg_ids) - = dataConRepFSInstPat arg_strs uniqs con inst_tys - - ; rhs' <- extendIfaceEnvs ex_tvs $ - extendIfaceIdEnv arg_ids $ - tcIfaceExpr rhs - ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } - -{- -************************************************************************ -* * - IdInfo -* * -************************************************************************ --} - -tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails -tcIdDetails _ IfVanillaId = return VanillaId -tcIdDetails ty IfDFunId - = return (DFunId (isNewTyCon (classTyCon cls))) - where - (_, _, cls, _) = tcSplitDFunTy ty - -tcIdDetails _ (IfRecSelId tc naughty) - = do { tc' <- either (fmap RecSelData . tcIfaceTyCon) - (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False) - tc - ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } - where - tyThingPatSyn (AConLike (PatSynCon ps)) = ps - tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn" - -tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo -tcIdInfo ignore_prags name ty info = do - lcl_env <- getLclEnv - -- Set the CgInfo to something sensible but uninformative before - -- we start; default assumption is that it has CAFs - let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding - | otherwise = vanillaIdInfo - if ignore_prags - then return init_info - else case info of - NoInfo -> return init_info - HasInfo info -> foldlM tcPrag init_info info - where - tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo - tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) - tcPrag info (HsArity arity) = return (info `setArityInfo` arity) - tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str) - tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) - tcPrag info HsLevity = return (info `setNeverLevPoly` ty) - - -- The next two are lazy, so they don't transitively suck stuff in - tcPrag info (HsUnfold lb if_unf) - = do { unf <- tcUnfolding name ty info if_unf - ; let info1 | lb = info `setOccInfo` strongLoopBreaker - | otherwise = info - ; return (info1 `setUnfoldingInfo` unf) } - -tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity -tcJoinInfo (IfaceJoinPoint ar) = Just ar -tcJoinInfo IfaceNotJoinPoint = Nothing - -tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding -tcUnfolding name _ info (IfCoreUnfold stable if_expr) - = do { dflags <- getDynFlags - ; mb_expr <- tcPragExpr name if_expr - ; let unf_src | stable = InlineStable - | otherwise = InlineRhs - ; return $ case mb_expr of - Nothing -> NoUnfolding - Just expr -> mkUnfolding dflags unf_src - True {- Top level -} - (isBottomingSig strict_sig) - expr - } - where - -- Strictness should occur before unfolding! - strict_sig = strictnessInfo info -tcUnfolding name _ _ (IfCompulsory if_expr) - = do { mb_expr <- tcPragExpr name if_expr - ; return (case mb_expr of - Nothing -> NoUnfolding - Just expr -> mkCompulsoryUnfolding expr) } - -tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) - = do { mb_expr <- tcPragExpr name if_expr - ; return (case mb_expr of - Nothing -> NoUnfolding - Just expr -> mkCoreUnfolding InlineStable True expr guidance )} - where - guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - -tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops) - = bindIfaceBndrs bs $ \ bs' -> - do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops - ; return (case mb_ops1 of - Nothing -> noUnfolding - Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) } - where - doc = text "Class ops for dfun" <+> ppr name - (_, _, cls, _) = tcSplitDFunTy dfun_ty - -{- -For unfoldings we try to do the job lazily, so that we never type check -an unfolding that isn't going to be looked at. --} - -tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr) -tcPragExpr name expr - = forkM_maybe doc $ do - core_expr' <- tcIfaceExpr expr - - -- Check for type consistency in the unfolding - whenGOptM Opt_DoCoreLinting $ do - in_scope <- get_in_scope - dflags <- getDynFlags - case lintUnfolding dflags noSrcLoc in_scope core_expr' of - Nothing -> return () - Just fail_msg -> do { mod <- getIfModule - ; pprPanic "Iface Lint failure" - (vcat [ text "In interface for" <+> ppr mod - , hang doc 2 fail_msg - , ppr name <+> equals <+> ppr core_expr' - , text "Iface expr =" <+> ppr expr ]) } - return core_expr' - where - doc = text "Unfolding of" <+> ppr name - - get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting - get_in_scope - = do { (gbl_env, lcl_env) <- getEnvs - ; rec_ids <- case if_rec_types gbl_env of - Nothing -> return [] - Just (_, get_env) -> do - { type_env <- setLclEnv () get_env - ; return (typeEnvIds type_env) } - ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet` - bindingsVars (if_id_env lcl_env) `unionVarSet` - mkVarSet rec_ids) } - - bindingsVars :: FastStringEnv Var -> VarSet - bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm - -- It's OK to use nonDetEltsUFM here because we immediately forget - -- the ordering by creating a set - -{- -************************************************************************ -* * - Getting from Names to TyThings -* * -************************************************************************ --} - -tcIfaceGlobal :: Name -> IfL TyThing -tcIfaceGlobal name - | Just thing <- wiredInNameTyThing_maybe name - -- Wired-in things include TyCons, DataCons, and Ids - -- Even though we are in an interface file, we want to make - -- sure the instances and RULES of this thing (particularly TyCon) are loaded - -- Imagine: f :: Double -> Double - = do { ifCheckWiredInThing thing; return thing } - - | otherwise - = do { env <- getGblEnv - ; case if_rec_types env of { -- Note [Tying the knot] - Just (mod, get_type_env) - | nameIsLocalOrFrom mod name - -> do -- It's defined in the module being compiled - { type_env <- setLclEnv () get_type_env -- yuk - ; case lookupNameEnv type_env name of - Just thing -> return thing - Nothing -> - pprPanic "tcIfaceGlobal (local): not found" - (ifKnotErr name (if_doc env) type_env) - } - - ; _ -> do - - { hsc_env <- getTopEnv - ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) - ; case mb_thing of { - Just thing -> return thing ; - Nothing -> do - - { mb_thing <- importDecl name -- It's imported; go get it - ; case mb_thing of - Failed err -> failIfM err - Succeeded thing -> return thing - }}}}} - -ifKnotErr :: Name -> SDoc -> TypeEnv -> SDoc -ifKnotErr name env_doc type_env = vcat - [ text "You are in a maze of twisty little passages, all alike." - , text "While forcing the thunk for TyThing" <+> ppr name - , text "which was lazily initialized by" <+> env_doc <> text "," - , text "I tried to tie the knot, but I couldn't find" <+> ppr name - , text "in the current type environment." - , text "If you are developing GHC, please read Note [Tying the knot]" - , text "and Note [Type-checking inside the knot]." - , text "Consider rebuilding GHC with profiling for a better stack trace." - , hang (text "Contents of current type environment:") - 2 (ppr type_env) - ] - --- Note [Tying the knot] --- ~~~~~~~~~~~~~~~~~~~~~ --- The if_rec_types field is used when we are compiling M.hs, which indirectly --- imports Foo.hi, which mentions M.T Then we look up M.T in M's type --- environment, which is splatted into if_rec_types after we've built M's type --- envt. --- --- This is a dark and complicated part of GHC type checking, with a lot --- of moving parts. Interested readers should also look at: --- --- * Note [Knot-tying typecheckIface] --- * Note [DFun knot-tying] --- * Note [hsc_type_env_var hack] --- --- There is also a wiki page on the subject, see: --- --- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TyingTheKnot - -tcIfaceTyConByName :: IfExtName -> IfL TyCon -tcIfaceTyConByName name - = do { thing <- tcIfaceGlobal name - ; return (tyThingTyCon thing) } - -tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon (IfaceTyCon name info) - = do { thing <- tcIfaceGlobal name - ; return $ case ifaceTyConIsPromoted info of - IsNotPromoted -> tyThingTyCon thing - IsPromoted -> promoteDataCon $ tyThingDataCon thing } - -tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) -tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name - ; return (tyThingCoAxiom thing) } - -tcIfaceDataCon :: Name -> IfL DataCon -tcIfaceDataCon name = do { thing <- tcIfaceGlobal name - ; case thing of - AConLike (RealDataCon dc) -> return dc - _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } - -tcIfaceExtId :: Name -> IfL Id -tcIfaceExtId name = do { thing <- tcIfaceGlobal name - ; case thing of - AnId id -> return id - _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } - --- See Note [Resolving never-exported Names in TcIface] -tcIfaceImplicit :: Name -> IfL TyThing -tcIfaceImplicit n = do - lcl_env <- getLclEnv - case if_implicits_env lcl_env of - Nothing -> tcIfaceGlobal n - Just tenv -> - case lookupTypeEnv tenv n of - Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv) - Just tything -> return tything - -{- -************************************************************************ -* * - Bindings -* * -************************************************************************ --} - -bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a -bindIfaceId (fs, ty) thing_inside - = do { name <- newIfaceName (mkVarOccFS fs) - ; ty' <- tcIfaceType ty - ; let id = mkLocalIdOrCoVar name ty' - ; extendIfaceIdEnv [id] (thing_inside id) } - -bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a -bindIfaceIds [] thing_inside = thing_inside [] -bindIfaceIds (b:bs) thing_inside - = bindIfaceId b $ \b' -> - bindIfaceIds bs $ \bs' -> - thing_inside (b':bs') - -bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a -bindIfaceBndr (IfaceIdBndr bndr) thing_inside - = bindIfaceId bndr thing_inside -bindIfaceBndr (IfaceTvBndr bndr) thing_inside - = bindIfaceTyVar bndr thing_inside - -bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a -bindIfaceBndrs [] thing_inside = thing_inside [] -bindIfaceBndrs (b:bs) thing_inside - = bindIfaceBndr b $ \ b' -> - bindIfaceBndrs bs $ \ bs' -> - thing_inside (b':bs') - ------------------------ -bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVarBinder] -> IfL a) -> IfL a -bindIfaceForAllBndrs [] thing_inside = thing_inside [] -bindIfaceForAllBndrs (bndr:bndrs) thing_inside - = bindIfaceForAllBndr bndr $ \tv vis -> - bindIfaceForAllBndrs bndrs $ \bndrs' -> - thing_inside (mkTyVarBinder vis tv : bndrs') - -bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> ArgFlag -> IfL a) -> IfL a -bindIfaceForAllBndr (TvBndr tv vis) thing_inside - = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis - -bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a -bindIfaceTyVar (occ,kind) thing_inside - = do { name <- newIfaceName (mkTyVarOccFS occ) - ; tyvar <- mk_iface_tyvar name kind - ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } - -mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar -mk_iface_tyvar name ifKind - = do { kind <- tcIfaceType ifKind - ; return (Var.mkTyVar name kind) } - -bindIfaceTyConBinders :: [IfaceTyConBinder] - -> ([TyConBinder] -> IfL a) -> IfL a -bindIfaceTyConBinders [] thing_inside = thing_inside [] -bindIfaceTyConBinders (b:bs) thing_inside - = bindIfaceTyConBinderX bindIfaceTyVar b $ \ b' -> - bindIfaceTyConBinders bs $ \ bs' -> - thing_inside (b':bs') - -bindIfaceTyConBinders_AT :: [IfaceTyConBinder] - -> ([TyConBinder] -> IfL a) -> IfL a --- Used for type variable in nested associated data/type declarations --- where some of the type variables are already in scope --- class C a where { data T a b } --- Here 'a' is in scope when we look at the 'data T' -bindIfaceTyConBinders_AT [] thing_inside - = thing_inside [] -bindIfaceTyConBinders_AT (b : bs) thing_inside - = bindIfaceTyConBinderX bind_tv b $ \b' -> - bindIfaceTyConBinders_AT bs $ \bs' -> - thing_inside (b':bs') - where - bind_tv tv thing - = do { mb_tv <- lookupIfaceTyVar tv - ; case mb_tv of - Just b' -> thing b' - Nothing -> bindIfaceTyVar tv thing } - -bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a) - -> IfaceTyConBinder - -> (TyConBinder -> IfL a) -> IfL a -bindIfaceTyConBinderX bind_tv (TvBndr tv vis) thing_inside - = bind_tv tv $ \tv' -> - thing_inside (TvBndr tv' vis) diff --git a/iface/TcIface.hs-boot b/iface/TcIface.hs-boot deleted file mode 100644 --- a/iface/TcIface.hs-boot +++ /dev/null @@ -1,20 +0,0 @@ -module TcIface where - -import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, - IfaceAnnotation, IfaceCompleteMatch ) -import TyCoRep ( TyThing ) -import TcRnTypes ( IfL ) -import InstEnv ( ClsInst ) -import FamInstEnv ( FamInst ) -import CoreSyn ( CoreRule ) -import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo, CompleteMatch ) -import Module ( Module ) -import Annotations ( Annotation ) - -tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing -tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] -tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo -tcIfaceInst :: IfaceClsInst -> IfL ClsInst -tcIfaceFamInst :: IfaceFamInst -> IfL FamInst -tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] -tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch] diff --git a/iface/ToIface.hs b/iface/ToIface.hs deleted file mode 100644 --- a/iface/ToIface.hs +++ /dev/null @@ -1,602 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Functions for converting Core things to interface file things. -module ToIface - ( -- * Binders - toIfaceTvBndr - , toIfaceTvBndrs - , toIfaceIdBndr - , toIfaceBndr - , toIfaceForAllBndr - , toIfaceTyVarBinders - , toIfaceTyVar - -- * Types - , toIfaceType, toIfaceTypeX - , toIfaceKind - , toIfaceTcArgs - , toIfaceTyCon - , toIfaceTyCon_name - , toIfaceTyLit - -- * Tidying types - , tidyToIfaceType - , tidyToIfaceContext - , tidyToIfaceTcArgs - -- * Coercions - , toIfaceCoercion - -- * Pattern synonyms - , patSynToIfaceDecl - -- * Expressions - , toIfaceExpr - , toIfaceBang - , toIfaceSrcBang - , toIfaceLetBndr - , toIfaceIdDetails - , toIfaceIdInfo - , toIfUnfolding - , toIfaceOneShot - , toIfaceTickish - , toIfaceBind - , toIfaceAlt - , toIfaceCon - , toIfaceApp - , toIfaceVar - ) where - -#include "HsVersions.h" - -import IfaceSyn -import DataCon -import Id -import IdInfo -import CoreSyn -import TyCon hiding ( pprPromotionQuote ) -import CoAxiom -import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) -import TysWiredIn ( heqTyCon ) -import MkId ( noinlineIdName ) -import PrelNames -import Name -import BasicTypes -import Type -import PatSyn -import Outputable -import FastString -import Util -import Var -import VarEnv -import VarSet -import TyCoRep -import Demand ( isTopSig ) - -import Data.Maybe ( catMaybes ) - ----------------- -toIfaceTvBndr :: TyVar -> IfaceTvBndr -toIfaceTvBndr tyvar = ( occNameFS (getOccName tyvar) - , toIfaceKind (tyVarKind tyvar) - ) - -toIfaceIdBndr :: Id -> (IfLclName, IfaceType) -toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id)) - -toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr] -toIfaceTvBndrs = map toIfaceTvBndr - -toIfaceBndr :: Var -> IfaceBndr -toIfaceBndr var - | isId var = IfaceIdBndr (toIfaceIdBndr var) - | otherwise = IfaceTvBndr (toIfaceTvBndr var) - -toIfaceTyVarBinder :: TyVarBndr TyVar vis -> TyVarBndr IfaceTvBndr vis -toIfaceTyVarBinder (TvBndr tv vis) = TvBndr (toIfaceTvBndr tv) vis - -toIfaceTyVarBinders :: [TyVarBndr TyVar vis] -> [TyVarBndr IfaceTvBndr vis] -toIfaceTyVarBinders = map toIfaceTyVarBinder - -{- -************************************************************************ -* * - Conversion from Type to IfaceType -* * -************************************************************************ --} - -toIfaceKind :: Type -> IfaceType -toIfaceKind = toIfaceType - ---------------------- -toIfaceType :: Type -> IfaceType -toIfaceType = toIfaceTypeX emptyVarSet - -toIfaceTypeX :: VarSet -> Type -> IfaceType --- (toIfaceTypeX free ty) --- translates the tyvars in 'free' as IfaceFreeTyVars --- --- Synonyms are retained in the interface type -toIfaceTypeX fr (TyVarTy tv) -- See Note [TcTyVars in IfaceType] in IfaceType - | tv `elemVarSet` fr = IfaceFreeTyVar tv - | otherwise = IfaceTyVar (toIfaceTyVar tv) -toIfaceTypeX fr (AppTy t1 t2) = IfaceAppTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) -toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n) -toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndr b) - (toIfaceTypeX (fr `delVarSet` binderVar b) t) -toIfaceTypeX fr (FunTy t1 t2) - | isPredTy t1 = IfaceDFunTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) - | otherwise = IfaceFunTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) -toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co) -toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co) - -toIfaceTypeX fr (TyConApp tc tys) - -- tuples - | Just sort <- tyConTuple_maybe tc - , n_tys == arity - = IfaceTupleTy sort IsNotPromoted (toIfaceTcArgsX fr tc tys) - - | Just dc <- isPromotedDataCon_maybe tc - , isTupleDataCon dc - , n_tys == 2*arity - = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys)) - - -- type equalities: see Note [Equality predicates in IfaceType] - | tyConName tc == eqTyConName - = let info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon True) - in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys) - - | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ] - , [k1, k2, _t1, _t2] <- tys - = let homogeneous = k1 `eqType` k2 - info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon homogeneous) - in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys) - - -- other applications - | otherwise - = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys) - where - arity = tyConArity tc - n_tys = length tys - -toIfaceTyVar :: TyVar -> FastString -toIfaceTyVar = occNameFS . getOccName - -toIfaceCoVar :: CoVar -> FastString -toIfaceCoVar = occNameFS . getOccName - -toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr -toIfaceForAllBndr (TvBndr v vis) = TvBndr (toIfaceTvBndr v) vis - ----------------- -toIfaceTyCon :: TyCon -> IfaceTyCon -toIfaceTyCon tc - = IfaceTyCon tc_name info - where - tc_name = tyConName tc - info = IfaceTyConInfo promoted sort - promoted | isPromotedDataCon tc = IsPromoted - | otherwise = IsNotPromoted - - tupleSort :: TyCon -> Maybe IfaceTyConSort - tupleSort tc' = - case tyConTuple_maybe tc' of - Just UnboxedTuple -> let arity = tyConArity tc' `div` 2 - in Just $ IfaceTupleTyCon arity UnboxedTuple - Just sort -> let arity = tyConArity tc' - in Just $ IfaceTupleTyCon arity sort - Nothing -> Nothing - - sort - | Just tsort <- tupleSort tc = tsort - - | Just dcon <- isPromotedDataCon_maybe tc - , let tc' = dataConTyCon dcon - , Just tsort <- tupleSort tc' = tsort - - | isUnboxedSumTyCon tc - , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons) - - | otherwise = IfaceNormalTyCon - - -toIfaceTyCon_name :: Name -> IfaceTyCon -toIfaceTyCon_name n = IfaceTyCon n info - where info = IfaceTyConInfo IsNotPromoted IfaceNormalTyCon - -- Used for the "rough-match" tycon stuff, - -- where pretty-printing is not an issue - -toIfaceTyLit :: TyLit -> IfaceTyLit -toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x -toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x - ----------------- -toIfaceCoercion :: Coercion -> IfaceCoercion -toIfaceCoercion = toIfaceCoercionX emptyVarSet - -toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion --- (toIfaceCoercionX free ty) --- translates the tyvars in 'free' as IfaceFreeTyVars -toIfaceCoercionX fr co - = go co - where - go (Refl r ty) = IfaceReflCo r (toIfaceType ty) - go (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv) - go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) - go (SymCo co) = IfaceSymCo (go co) - go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2) - go (NthCo d co) = IfaceNthCo d (go co) - go (LRCo lr co) = IfaceLRCo lr (go co) - go (InstCo co arg) = IfaceInstCo (go co) (go arg) - go (CoherenceCo c1 c2) = IfaceCoherenceCo (go c1) (go c2) - go (KindCo c) = IfaceKindCo (go c) - go (SubCo co) = IfaceSubCo (go co) - go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs) - go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs) - go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r - (toIfaceTypeX fr t1) - (toIfaceTypeX fr t2) - go (TyConAppCo r tc cos) - | tc `hasKey` funTyConKey - , [_,_,_,_] <- cos = pprPanic "toIfaceCoercion" (ppr co) - | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) - go (FunCo r co1 co2) = IfaceFunCo r (toIfaceCoercion co1) - (toIfaceCoercion co2) - - go (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv) - (toIfaceCoercionX fr' k) - (toIfaceCoercionX fr' co) - where - fr' = fr `delVarSet` tv - - go_prov :: UnivCoProvenance -> IfaceUnivCoProv - go_prov UnsafeCoerceProv = IfaceUnsafeCoerceProv - go_prov (PhantomProv co) = IfacePhantomProv (go co) - go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) - go_prov (PluginProv str) = IfacePluginProv str - go_prov (HoleProv h) = IfaceHoleProv (chUnique h) - -toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs -toIfaceTcArgs = toIfaceTcArgsX emptyVarSet - -toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceTcArgs --- See Note [Suppressing invisible arguments] --- We produce a result list of args describing visiblity --- The awkward case is --- T :: forall k. * -> k --- And consider --- T (forall j. blah) * blib --- Is 'blib' visible? It depends on the visibility flag on j, --- so we have to substitute for k. Annoying! -toIfaceTcArgsX fr tc ty_args - = go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args - where - in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) - - go _ _ [] = ITC_Nil - go env ty ts - | Just ty' <- coreView ty - = go env ty' ts - go env (ForAllTy (TvBndr tv vis) res) (t:ts) - | isVisibleArgFlag vis = ITC_Vis t' ts' - | otherwise = ITC_Invis t' ts' - where - t' = toIfaceTypeX fr t - ts' = go (extendTvSubst env tv t) res ts - - go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps - = ITC_Vis (toIfaceTypeX fr t) (go env res ts) - - go env (TyVarTy tv) ts - | Just ki <- lookupTyVar env tv = go env ki ts - go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args ) - ITC_Vis (toIfaceTypeX fr t) (go env kind ts) -- Ill-kinded - -tidyToIfaceType :: TidyEnv -> Type -> IfaceType -tidyToIfaceType env ty = toIfaceType (tidyType env ty) - -tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs -tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) - -tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext -tidyToIfaceContext env theta = map (tidyToIfaceType env) theta - -{- -************************************************************************ -* * - Conversion of pattern synonyms -* * -************************************************************************ --} - -patSynToIfaceDecl :: PatSyn -> IfaceDecl -patSynToIfaceDecl ps - = IfacePatSyn { ifName = getName $ ps - , ifPatMatcher = to_if_pr (patSynMatcher ps) - , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) - , ifPatIsInfix = patSynIsInfix ps - , ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs' - , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs' - , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta - , ifPatReqCtxt = tidyToIfaceContext env2 req_theta - , ifPatArgs = map (tidyToIfaceType env2) args - , ifPatTy = tidyToIfaceType env2 rhs_ty - , ifFieldLabels = (patSynFieldLabels ps) - } - where - (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps - univ_bndrs = patSynUnivTyVarBinders ps - ex_bndrs = patSynExTyVarBinders ps - (env1, univ_bndrs') = tidyTyVarBinders emptyTidyEnv univ_bndrs - (env2, ex_bndrs') = tidyTyVarBinders env1 ex_bndrs - to_if_pr (id, needs_dummy) = (idName id, needs_dummy) - -{- -************************************************************************ -* * - Conversion of other things -* * -************************************************************************ --} - -toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang -toIfaceBang _ HsLazy = IfNoBang -toIfaceBang _ (HsUnpack Nothing) = IfUnpack -toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) -toIfaceBang _ HsStrict = IfStrict - -toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang -toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang - -toIfaceLetBndr :: Id -> IfaceLetBndr -toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) - (toIfaceType (idType id)) - (toIfaceIdInfo (idInfo id)) - (toIfaceJoinInfo (isJoinId_maybe id)) - -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr - -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn - -toIfaceIdDetails :: IdDetails -> IfaceIdDetails -toIfaceIdDetails VanillaId = IfVanillaId -toIfaceIdDetails (DFunId {}) = IfDFunId -toIfaceIdDetails (RecSelId { sel_naughty = n - , sel_tycon = tc }) = - let iface = case tc of - RecSelData ty_con -> Left (toIfaceTyCon ty_con) - RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) - in IfRecSelId iface n - - -- The remaining cases are all "implicit Ids" which don't - -- appear in interface files at all -toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) - IfVanillaId -- Unexpected; the other - -toIfaceIdInfo :: IdInfo -> IfaceIdInfo -toIfaceIdInfo id_info - = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - inline_hsinfo, unfold_hsinfo, levity_hsinfo] of - [] -> NoInfo - infos -> HasInfo infos - -- NB: strictness and arity must appear in the list before unfolding - -- See TcIface.tcUnfolding - where - ------------ Arity -------------- - arity_info = arityInfo id_info - arity_hsinfo | arity_info == 0 = Nothing - | otherwise = Just (HsArity arity_info) - - ------------ Caf Info -------------- - caf_info = cafInfo id_info - caf_hsinfo = case caf_info of - NoCafRefs -> Just HsNoCafRefs - _other -> Nothing - - ------------ Strictness -------------- - -- No point in explicitly exporting TopSig - sig_info = strictnessInfo id_info - strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) - | otherwise = Nothing - - ------------ Unfolding -------------- - unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) - loop_breaker = isStrongLoopBreaker (occInfo id_info) - - ------------ Inline prag -------------- - inline_prag = inlinePragInfo id_info - inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing - | otherwise = Just (HsInline inline_prag) - - ------------ Levity polymorphism ---------- - levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity - | otherwise = Nothing - -toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo -toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar -toIfaceJoinInfo Nothing = IfaceNotJoinPoint - --------------------------- -toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem -toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs - , uf_src = src - , uf_guidance = guidance }) - = Just $ HsUnfold lb $ - case src of - InlineStable - -> case guidance of - UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - -> IfInlineRule arity unsat_ok boring_ok if_rhs - _other -> IfCoreUnfold True if_rhs - InlineCompulsory -> IfCompulsory if_rhs - InlineRhs -> IfCoreUnfold False if_rhs - -- Yes, even if guidance is UnfNever, expose the unfolding - -- If we didn't want to expose the unfolding, TidyPgm would - -- have stuck in NoUnfolding. For supercompilation we want - -- to see that unfolding! - where - if_rhs = toIfaceExpr rhs - -toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) - = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) - -- No need to serialise the data constructor; - -- we can recover it from the type of the dfun - -toIfUnfolding _ _ - = Nothing - -{- -************************************************************************ -* * - Conversion of expressions -* * -************************************************************************ --} - -toIfaceExpr :: CoreExpr -> IfaceExpr -toIfaceExpr (Var v) = toIfaceVar v -toIfaceExpr (Lit l) = IfaceLit l -toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) -toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) -toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b) -toIfaceExpr (App f a) = toIfaceApp f [a] -toIfaceExpr (Case s x ty as) - | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) - | otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as) -toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) -toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) -toIfaceExpr (Tick t e) - | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e) - | otherwise = toIfaceExpr e - -toIfaceOneShot :: Id -> IfaceOneShot -toIfaceOneShot id | isId id - , OneShotLam <- oneShotInfo (idInfo id) - = IfaceOneShot - | otherwise - = IfaceNoOneShot - ---------------------- -toIfaceTickish :: Tickish Id -> Maybe IfaceTickish -toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) -toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) -toIfaceTickish (SourceNote src names) = Just (IfaceSource src names) -toIfaceTickish (Breakpoint {}) = Nothing - -- Ignore breakpoints, since they are relevant only to GHCi, and - -- should not be serialised (Trac #8333) - ---------------------- -toIfaceBind :: Bind Id -> IfaceBinding -toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) -toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] - ---------------------- -toIfaceAlt :: (AltCon, [Var], CoreExpr) - -> (IfaceConAlt, [FastString], IfaceExpr) -toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r) - ---------------------- -toIfaceCon :: AltCon -> IfaceConAlt -toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc) -toIfaceCon (LitAlt l) = IfaceLitAlt l -toIfaceCon DEFAULT = IfaceDefault - ---------------------- -toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr -toIfaceApp (App f a) as = toIfaceApp f (a:as) -toIfaceApp (Var v) as - = case isDataConWorkId_maybe v of - -- We convert the *worker* for tuples into IfaceTuples - Just dc | saturated - , Just tup_sort <- tyConTuple_maybe tc - -> IfaceTuple tup_sort tup_args - where - val_args = dropWhile isTypeArg as - saturated = val_args `lengthIs` idArity v - tup_args = map toIfaceExpr val_args - tc = dataConTyCon dc - - _ -> mkIfaceApps (toIfaceVar v) as - -toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as - -mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr -mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as - ---------------------- -toIfaceVar :: Id -> IfaceExpr -toIfaceVar v - | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) - -- Foreign calls have special syntax - | isBootUnfolding (idUnfolding v) - = IfaceApp (IfaceApp (IfaceExt noinlineIdName) (IfaceType (toIfaceType (idType v)))) - (IfaceExt name) -- don't use mkIfaceApps, or infinite loop - -- See Note [Inlining and hs-boot files] - | isExternalName name = IfaceExt name - | otherwise = IfaceLcl (getOccFS name) - where name = idName v - - -{- Note [Inlining and hs-boot files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example (Trac #10083, #12789): - - ---------- RSR.hs-boot ------------ - module RSR where - data RSR - eqRSR :: RSR -> RSR -> Bool - - ---------- SR.hs ------------ - module SR where - import {-# SOURCE #-} RSR - data SR = MkSR RSR - eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 - - ---------- RSR.hs ------------ - module RSR where - import SR - data RSR = MkRSR SR -- deriving( Eq ) - eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) - foo x y = not (eqRSR x y) - -When compiling RSR we get this code - - RSR.eqRSR :: RSR -> RSR -> Bool - RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) -> - case ds1 of _ { RSR.MkRSR s1 -> - case ds2 of _ { RSR.MkRSR s2 -> - SR.eqSR s1 s2 }} - - RSR.foo :: RSR -> RSR -> Bool - RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y) - -Now, when optimising foo: - Inline eqRSR (small, non-rec) - Inline eqSR (small, non-rec) -but the result of inlining eqSR from SR is another call to eqRSR, so -everything repeats. Neither eqSR nor eqRSR are (apparently) loop -breakers. - -Solution: in the unfolding of eqSR in SR.hi, replace `eqRSR` in SR -with `noinline eqRSR`, so that eqRSR doesn't get inlined. This means -that when GHC inlines `eqSR`, it will not also inline `eqRSR`, exactly -as would have been the case if `foo` had been defined in SR.hs (and -marked as a loop-breaker). - -But how do we arrange for this to happen? There are two ingredients: - - 1. When we serialize out unfoldings to IfaceExprs (toIfaceVar), - for every variable reference we see if we are referring to an - 'Id' that came from an hs-boot file. If so, we add a `noinline` - to the reference. - - 2. But how do we know if a reference came from an hs-boot file - or not? We could record this directly in the 'IdInfo', but - actually we deduce this by looking at the unfolding: 'Id's - that come from boot files are given a special unfolding - (upon typechecking) 'BootUnfolding' which say that there is - no unfolding, and the reason is because the 'Id' came from - a boot file. - -Here is a solution that doesn't work: when compiling RSR, -add a NOINLINE pragma to every function exported by the boot-file -for RSR (if it exists). Doing so makes the bootstrapped GHC itself -slower by 8% overall (on Trac #9872a-d, and T1969: the reason -is that these NOINLINE'd functions now can't be profitably inlined -outside of the hs-boot loop. - --} diff --git a/iface/ToIface.hs-boot b/iface/ToIface.hs-boot deleted file mode 100644 --- a/iface/ToIface.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -module ToIface where - -import {-# SOURCE #-} TyCoRep -import {-# SOURCE #-} IfaceType -import Var ( TyVar, TyVarBinder ) -import TyCon ( TyCon ) -import VarSet( VarSet ) - --- For TyCoRep -toIfaceType :: Type -> IfaceType -toIfaceTypeX :: VarSet -> Type -> IfaceType -toIfaceTyLit :: TyLit -> IfaceTyLit -toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr -toIfaceTvBndr :: TyVar -> IfaceTvBndr -toIfaceTyCon :: TyCon -> IfaceTyCon -toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs -toIfaceCoercion :: Coercion -> IfaceCoercion diff --git a/jsbits/genSym.js b/jsbits/genSym.js new file mode 100644 --- /dev/null +++ b/jsbits/genSym.js @@ -0,0 +1,18 @@ +//#OPTIONS: CPP +#include "Unique.h" + +// We assume that the unique tag occupies less than 32 bits (should be safe) +#define HIGH_UNIQUE_BITS (32 - UNIQUE_TAG_BITS) +#define HIGH_UNIQUE_MASK ((1 << HIGH_UNIQUE_BITS) - 1) + +// The 'ghc_unique_inc' and 'ghc_unique_counter64' are in the native RTS. It allows them to be +// shared with plugins even if two different instances of the GHC library are +// loaded at the same time (#19940) +// However, cross compilers do not support plugins so we have moved these globals back +// into the compiler. +var h$ghc_unique_inc = h$newByteArray(4); +h$ghc_unique_inc.i3[0] = 1; +var h$ghc_unique_counter64 = h$newByteArray(8); +h$ghc_unique_counter64.i3[0] = 0; +h$ghc_unique_counter64.i3[1] = 0; + diff --git a/llvmGen/Llvm.hs b/llvmGen/Llvm.hs deleted file mode 100644 --- a/llvmGen/Llvm.hs +++ /dev/null @@ -1,64 +0,0 @@ --- ---------------------------------------------------------------------------- --- | This module supplies bindings to generate Llvm IR from Haskell --- (). --- --- Note: this module is developed in a demand driven way. It is no complete --- LLVM binding library in Haskell, but enough to generate code for GHC. --- --- This code is derived from code taken from the Essential Haskell Compiler --- (EHC) project (). --- - -module Llvm ( - - -- * Modules, Functions and Blocks - LlvmModule(..), - - LlvmFunction(..), LlvmFunctionDecl(..), - LlvmFunctions, LlvmFunctionDecls, - LlvmStatement(..), LlvmExpression(..), - LlvmBlocks, LlvmBlock(..), LlvmBlockId, - LlvmParamAttr(..), LlvmParameter, - - -- * Atomic operations - LlvmAtomicOp(..), - - -- * Fence synchronization - LlvmSyncOrdering(..), - - -- * Call Handling - LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..), - LlvmLinkageType(..), LlvmFuncAttr(..), - - -- * Operations and Comparisons - LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..), - - -- * Variables and Type System - LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..), - LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign, - LMConst(..), - - -- ** Some basic types - i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, - - -- ** Metadata types - MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..), - - -- ** Operations on the type system. - isGlobal, getLitType, getVarType, - getLink, getStatType, pVarLift, pVarLower, - pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits, - - -- * Pretty Printing - ppLit, ppName, ppPlainName, - ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, - ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, - ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, - - ) where - -import Llvm.AbsSyn -import Llvm.MetaData -import Llvm.PpLlvm -import Llvm.Types - diff --git a/llvmGen/Llvm/AbsSyn.hs b/llvmGen/Llvm/AbsSyn.hs deleted file mode 100644 --- a/llvmGen/Llvm/AbsSyn.hs +++ /dev/null @@ -1,350 +0,0 @@ --------------------------------------------------------------------------------- --- | The LLVM abstract syntax. --- - -module Llvm.AbsSyn where - -import Llvm.MetaData -import Llvm.Types - -import Unique - --- | Block labels -type LlvmBlockId = Unique - --- | A block of LLVM code. -data LlvmBlock = LlvmBlock { - -- | The code label for this block - blockLabel :: LlvmBlockId, - - -- | A list of LlvmStatement's representing the code for this block. - -- This list must end with a control flow statement. - blockStmts :: [LlvmStatement] - } - -type LlvmBlocks = [LlvmBlock] - --- | An LLVM Module. This is a top level container in LLVM. -data LlvmModule = LlvmModule { - -- | Comments to include at the start of the module. - modComments :: [LMString], - - -- | LLVM Alias type definitions. - modAliases :: [LlvmAlias], - - -- | LLVM meta data. - modMeta :: [MetaDecl], - - -- | Global variables to include in the module. - modGlobals :: [LMGlobal], - - -- | LLVM Functions used in this module but defined in other modules. - modFwdDecls :: LlvmFunctionDecls, - - -- | LLVM Functions defined in this module. - modFuncs :: LlvmFunctions - } - --- | An LLVM Function -data LlvmFunction = LlvmFunction { - -- | The signature of this declared function. - funcDecl :: LlvmFunctionDecl, - - -- | The functions arguments - funcArgs :: [LMString], - - -- | The function attributes. - funcAttrs :: [LlvmFuncAttr], - - -- | The section to put the function into, - funcSect :: LMSection, - - -- | Prefix data - funcPrefix :: Maybe LlvmStatic, - - -- | The body of the functions. - funcBody :: LlvmBlocks - } - -type LlvmFunctions = [LlvmFunction] - -type SingleThreaded = Bool - --- | LLVM ordering types for synchronization purposes. (Introduced in LLVM --- 3.0). Please see the LLVM documentation for a better description. -data LlvmSyncOrdering - -- | Some partial order of operations exists. - = SyncUnord - -- | A single total order for operations at a single address exists. - | SyncMonotonic - -- | Acquire synchronization operation. - | SyncAcquire - -- | Release synchronization operation. - | SyncRelease - -- | Acquire + Release synchronization operation. - | SyncAcqRel - -- | Full sequential Consistency operation. - | SyncSeqCst - deriving (Show, Eq) - --- | LLVM atomic operations. Please see the @atomicrmw@ instruction in --- the LLVM documentation for a complete description. -data LlvmAtomicOp - = LAO_Xchg - | LAO_Add - | LAO_Sub - | LAO_And - | LAO_Nand - | LAO_Or - | LAO_Xor - | LAO_Max - | LAO_Min - | LAO_Umax - | LAO_Umin - deriving (Show, Eq) - --- | Llvm Statements -data LlvmStatement - {- | - Assign an expression to an variable: - * dest: Variable to assign to - * source: Source expression - -} - = Assignment LlvmVar LlvmExpression - - {- | - Memory fence operation - -} - | Fence Bool LlvmSyncOrdering - - {- | - Always branch to the target label - -} - | Branch LlvmVar - - {- | - Branch to label targetTrue if cond is true otherwise to label targetFalse - * cond: condition that will be tested, must be of type i1 - * targetTrue: label to branch to if cond is true - * targetFalse: label to branch to if cond is false - -} - | BranchIf LlvmVar LlvmVar LlvmVar - - {- | - Comment - Plain comment. - -} - | Comment [LMString] - - {- | - Set a label on this position. - * name: Identifier of this label, unique for this module - -} - | MkLabel LlvmBlockId - - {- | - Store variable value in pointer ptr. If value is of type t then ptr must - be of type t*. - * value: Variable/Constant to store. - * ptr: Location to store the value in - -} - | Store LlvmVar LlvmVar - - {- | - Multiway branch - * scrutinee: Variable or constant which must be of integer type that is - determines which arm is chosen. - * def: The default label if there is no match in target. - * target: A list of (value,label) where the value is an integer - constant and label the corresponding label to jump to if the - scrutinee matches the value. - -} - | Switch LlvmVar LlvmVar [(LlvmVar, LlvmVar)] - - {- | - Return a result. - * result: The variable or constant to return - -} - | Return (Maybe LlvmVar) - - {- | - An instruction for the optimizer that the code following is not reachable - -} - | Unreachable - - {- | - Raise an expression to a statement (if don't want result or want to use - Llvm unnamed values. - -} - | Expr LlvmExpression - - {- | - A nop LLVM statement. Useful as its often more efficient to use this - then to wrap LLvmStatement in a Just or []. - -} - | Nop - - {- | - A LLVM statement with metadata attached to it. - -} - | MetaStmt [MetaAnnot] LlvmStatement - - deriving (Eq) - - --- | Llvm Expressions -data LlvmExpression - {- | - Allocate amount * sizeof(tp) bytes on the stack - * tp: LlvmType to reserve room for - * amount: The nr of tp's which must be allocated - -} - = Alloca LlvmType Int - - {- | - Perform the machine operator op on the operands left and right - * op: operator - * left: left operand - * right: right operand - -} - | LlvmOp LlvmMachOp LlvmVar LlvmVar - - {- | - Perform a compare operation on the operands left and right - * op: operator - * left: left operand - * right: right operand - -} - | Compare LlvmCmpOp LlvmVar LlvmVar - - {- | - Extract a scalar element from a vector - * val: The vector - * idx: The index of the scalar within the vector - -} - | Extract LlvmVar LlvmVar - - {- | - Extract a scalar element from a structure - * val: The structure - * idx: The index of the scalar within the structure - Corresponds to "extractvalue" instruction. - -} - | ExtractV LlvmVar Int - - {- | - Insert a scalar element into a vector - * val: The source vector - * elt: The scalar to insert - * index: The index at which to insert the scalar - -} - | Insert LlvmVar LlvmVar LlvmVar - - {- | - Allocate amount * sizeof(tp) bytes on the heap - * tp: LlvmType to reserve room for - * amount: The nr of tp's which must be allocated - -} - | Malloc LlvmType Int - - {- | - Load the value at location ptr - -} - | Load LlvmVar - - {- | - Atomic load of the value at location ptr - -} - | ALoad LlvmSyncOrdering SingleThreaded LlvmVar - - {- | - Navigate in an structure, selecting elements - * inbound: Is the pointer inbounds? (computed pointer doesn't overflow) - * ptr: Location of the structure - * indexes: A list of indexes to select the correct value. - -} - | GetElemPtr Bool LlvmVar [LlvmVar] - - {- | - Cast the variable from to the to type. This is an abstraction of three - cast operators in Llvm, inttoptr, prttoint and bitcast. - * cast: Cast type - * from: Variable to cast - * to: type to cast to - -} - | Cast LlvmCastOp LlvmVar LlvmType - - {- | - Atomic read-modify-write operation - * op: Atomic operation - * addr: Address to modify - * operand: Operand to operation - * ordering: Ordering requirement - -} - | AtomicRMW LlvmAtomicOp LlvmVar LlvmVar LlvmSyncOrdering - - {- | - Compare-and-exchange operation - * addr: Address to modify - * old: Expected value - * new: New value - * suc_ord: Ordering required in success case - * fail_ord: Ordering required in failure case, can be no stronger than - suc_ord - - Result is an @i1@, true if store was successful. - -} - | CmpXChg LlvmVar LlvmVar LlvmVar LlvmSyncOrdering LlvmSyncOrdering - - {- | - Call a function. The result is the value of the expression. - * tailJumps: CallType to signal if the function should be tail called - * fnptrval: An LLVM value containing a pointer to a function to be - invoked. Can be indirect. Should be LMFunction type. - * args: Concrete arguments for the parameters - * attrs: A list of function attributes for the call. Only NoReturn, - NoUnwind, ReadOnly and ReadNone are valid here. - -} - | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr] - - {- | - Call a function as above but potentially taking metadata as arguments. - * tailJumps: CallType to signal if the function should be tail called - * fnptrval: An LLVM value containing a pointer to a function to be - invoked. Can be indirect. Should be LMFunction type. - * args: Arguments that may include metadata. - * attrs: A list of function attributes for the call. Only NoReturn, - NoUnwind, ReadOnly and ReadNone are valid here. - -} - | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr] - - {- | - Merge variables from different basic blocks which are predecessors of this - basic block in a new variable of type tp. - * tp: type of the merged variable, must match the types of the - predecessor variables. - * precessors: A list of variables and the basic block that they originate - from. - -} - | Phi LlvmType [(LlvmVar,LlvmVar)] - - {- | - Inline assembly expression. Syntax is very similar to the style used by GCC. - * assembly: Actual inline assembly code. - * constraints: Operand constraints. - * return ty: Return type of function. - * vars: Any variables involved in the assembly code. - * sideeffect: Does the expression have side effects not visible from the - constraints list. - * alignstack: Should the stack be conservatively aligned before this - expression is executed. - -} - | Asm LMString LMString LlvmType [LlvmVar] Bool Bool - - {- | - A LLVM expression with metadata attached to it. - -} - | MExpr [MetaAnnot] LlvmExpression - - deriving (Eq) - diff --git a/llvmGen/Llvm/MetaData.hs b/llvmGen/Llvm/MetaData.hs deleted file mode 100644 --- a/llvmGen/Llvm/MetaData.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Llvm.MetaData where - -import Llvm.Types -import Outputable - --- The LLVM Metadata System. --- --- The LLVM metadata feature is poorly documented but roughly follows the --- following design: --- * Metadata can be constructed in a few different ways (See below). --- * After which it can either be attached to LLVM statements to pass along --- extra information to the optimizer and code generator OR specifically named --- metadata has an affect on the whole module (i.e., linking behaviour). --- --- --- # Constructing metadata --- Metadata comes largely in three forms: --- --- * Metadata expressions -- these are the raw metadata values that encode --- information. They consist of metadata strings, metadata nodes, regular --- LLVM values (both literals and references to global variables) and --- metadata expressions (i.e., recursive data type). Some examples: --- !{ !"hello", !0, i32 0 } --- !{ !1, !{ i32 0 } } --- --- * Metadata nodes -- global metadata variables that attach a metadata --- expression to a number. For example: --- !0 = !{ [] !} --- --- * Named metadata -- global metadata variables that attach a metadata nodes --- to a name. Used ONLY to communicated module level information to LLVM --- through a meaningful name. For example: --- !llvm.module.linkage = !{ !0, !1 } --- --- --- # Using Metadata --- Using metadata depends on the form it is in: --- --- * Attach to instructions -- metadata can be attached to LLVM instructions --- using a specific reference as follows: --- %l = load i32* @glob, !nontemporal !10 --- %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } } --- Only metadata nodes or expressions can be attached, named metadata cannot. --- Refer to LLVM documentation for which instructions take metadata and its --- meaning. --- --- * As arguments -- llvm functions can take metadata as arguments, for --- example: --- call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1) --- As with instructions, only metadata nodes or expressions can be attached. --- --- * As a named metadata -- Here the metadata is simply declared in global --- scope using a specific name to communicate module level information to LLVM. --- For example: --- !llvm.module.linkage = !{ !0, !1 } --- - --- | A reference to an un-named metadata node. -newtype MetaId = MetaId Int - deriving (Eq, Ord, Enum) - -instance Outputable MetaId where - ppr (MetaId n) = char '!' <> int n - --- | LLVM metadata expressions -data MetaExpr = MetaStr !LMString - | MetaNode !MetaId - | MetaVar !LlvmVar - | MetaStruct [MetaExpr] - deriving (Eq) - -instance Outputable MetaExpr where - ppr (MetaVar (LMLitVar (LMNullLit _))) = text "null" - ppr (MetaStr s ) = char '!' <> doubleQuotes (ftext s) - ppr (MetaNode n ) = ppr n - ppr (MetaVar v ) = ppr v - ppr (MetaStruct es) = char '!' <> braces (ppCommaJoin es) - --- | Associates some metadata with a specific label for attaching to an --- instruction. -data MetaAnnot = MetaAnnot LMString MetaExpr - deriving (Eq) - --- | Metadata declarations. Metadata can only be declared in global scope. -data MetaDecl - -- | Named metadata. Only used for communicating module information to - -- LLVM. ('!name = !{ [!] }' form). - = MetaNamed !LMString [MetaId] - -- | Metadata node declaration. - -- ('!0 = metadata !{ }' form). - | MetaUnnamed !MetaId !MetaExpr diff --git a/llvmGen/Llvm/PpLlvm.hs b/llvmGen/Llvm/PpLlvm.hs deleted file mode 100644 --- a/llvmGen/Llvm/PpLlvm.hs +++ /dev/null @@ -1,497 +0,0 @@ -{-# LANGUAGE CPP #-} - --------------------------------------------------------------------------------- --- | Pretty print LLVM IR Code. --- - -module Llvm.PpLlvm ( - - -- * Top level LLVM objects. - ppLlvmModule, - ppLlvmComments, - ppLlvmComment, - ppLlvmGlobals, - ppLlvmGlobal, - ppLlvmAliases, - ppLlvmAlias, - ppLlvmMetas, - ppLlvmMeta, - ppLlvmFunctionDecls, - ppLlvmFunctionDecl, - ppLlvmFunctions, - ppLlvmFunction, - - ) where - -#include "HsVersions.h" - -import Llvm.AbsSyn -import Llvm.MetaData -import Llvm.Types - -import Data.List ( intersperse ) -import Outputable -import Unique -import FastString ( sLit ) - --------------------------------------------------------------------------------- --- * Top Level Print functions --------------------------------------------------------------------------------- - --- | Print out a whole LLVM module. -ppLlvmModule :: LlvmModule -> SDoc -ppLlvmModule (LlvmModule comments aliases meta globals decls funcs) - = ppLlvmComments comments $+$ newLine - $+$ ppLlvmAliases aliases $+$ newLine - $+$ ppLlvmMetas meta $+$ newLine - $+$ ppLlvmGlobals globals $+$ newLine - $+$ ppLlvmFunctionDecls decls $+$ newLine - $+$ ppLlvmFunctions funcs - --- | Print out a multi-line comment, can be inside a function or on its own -ppLlvmComments :: [LMString] -> SDoc -ppLlvmComments comments = vcat $ map ppLlvmComment comments - --- | Print out a comment, can be inside a function or on its own -ppLlvmComment :: LMString -> SDoc -ppLlvmComment com = semi <+> ftext com - - --- | Print out a list of global mutable variable definitions -ppLlvmGlobals :: [LMGlobal] -> SDoc -ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls - --- | Print out a global mutable variable definition -ppLlvmGlobal :: LMGlobal -> SDoc -ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = - let sect = case x of - Just x' -> text ", section" <+> doubleQuotes (ftext x') - Nothing -> empty - - align = case a of - Just a' -> text ", align" <+> int a' - Nothing -> empty - - rhs = case dat of - Just stat -> pprSpecialStatic stat - Nothing -> ppr (pLower $ getVarType var) - - -- Position of linkage is different for aliases. - const = case c of - Global -> text "global" - Constant -> text "constant" - Alias -> text "alias" - - in ppAssignment var $ ppr link <+> const <+> rhs <> sect <> align - $+$ newLine - -ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags -> - error $ "Non Global var ppr as global! " - ++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val) - - --- | Print out a list of LLVM type aliases. -ppLlvmAliases :: [LlvmAlias] -> SDoc -ppLlvmAliases tys = vcat $ map ppLlvmAlias tys - --- | Print out an LLVM type alias. -ppLlvmAlias :: LlvmAlias -> SDoc -ppLlvmAlias (name, ty) - = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty - - --- | Print out a list of LLVM metadata. -ppLlvmMetas :: [MetaDecl] -> SDoc -ppLlvmMetas metas = vcat $ map ppLlvmMeta metas - --- | Print out an LLVM metadata definition. -ppLlvmMeta :: MetaDecl -> SDoc -ppLlvmMeta (MetaUnnamed n m) - = ppr n <+> equals <+> ppr m - -ppLlvmMeta (MetaNamed n m) - = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes - where - nodes = hcat $ intersperse comma $ map ppr m - - --- | Print out a list of function definitions. -ppLlvmFunctions :: LlvmFunctions -> SDoc -ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs - --- | Print out a function definition. -ppLlvmFunction :: LlvmFunction -> SDoc -ppLlvmFunction fun = - let attrDoc = ppSpaceJoin (funcAttrs fun) - secDoc = case funcSect fun of - Just s' -> text "section" <+> (doubleQuotes $ ftext s') - Nothing -> empty - prefixDoc = case funcPrefix fun of - Just v -> text "prefix" <+> ppr v - Nothing -> empty - in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun) - <+> attrDoc <+> secDoc <+> prefixDoc - $+$ lbrace - $+$ ppLlvmBlocks (funcBody fun) - $+$ rbrace - $+$ newLine - $+$ newLine - --- | Print out a function definition header. -ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc -ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args - = let varg' = case varg of - VarArgs | null p -> sLit "..." - | otherwise -> sLit ", ..." - _otherwise -> sLit "" - align = case a of - Just a' -> text " align " <> ppr a' - Nothing -> empty - args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%' - <> ftext n) - (zip p args) - in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <> - (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align - --- | Print out a list of function declaration. -ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc -ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs - --- | Print out a function declaration. --- Declarations define the function type but don't define the actual body of --- the function. -ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc -ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) - = let varg' = case varg of - VarArgs | null p -> sLit "..." - | otherwise -> sLit ", ..." - _otherwise -> sLit "" - align = case a of - Just a' -> text " align" <+> ppr a' - Nothing -> empty - args = hcat $ intersperse (comma <> space) $ - map (\(t,a) -> ppr t <+> ppSpaceJoin a) p - in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <> - ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine - - --- | Print out a list of LLVM blocks. -ppLlvmBlocks :: LlvmBlocks -> SDoc -ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks - --- | Print out an LLVM block. --- It must be part of a function definition. -ppLlvmBlock :: LlvmBlock -> SDoc -ppLlvmBlock (LlvmBlock blockId stmts) = - let isLabel (MkLabel _) = True - isLabel _ = False - (block, rest) = break isLabel stmts - ppRest = case rest of - MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs) - _ -> empty - in ppLlvmBlockLabel blockId - $+$ (vcat $ map ppLlvmStatement block) - $+$ newLine - $+$ ppRest - --- | Print out an LLVM block label. -ppLlvmBlockLabel :: LlvmBlockId -> SDoc -ppLlvmBlockLabel id = pprUniqueAlways id <> colon - - --- | Print out an LLVM statement. -ppLlvmStatement :: LlvmStatement -> SDoc -ppLlvmStatement stmt = - let ind = (text " " <>) - in case stmt of - Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr) - Fence st ord -> ind $ ppFence st ord - Branch target -> ind $ ppBranch target - BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF - Comment comments -> ind $ ppLlvmComments comments - MkLabel label -> ppLlvmBlockLabel label - Store value ptr -> ind $ ppStore value ptr - Switch scrut def tgs -> ind $ ppSwitch scrut def tgs - Return result -> ind $ ppReturn result - Expr expr -> ind $ ppLlvmExpression expr - Unreachable -> ind $ text "unreachable" - Nop -> empty - MetaStmt meta s -> ppMetaStatement meta s - - --- | Print out an LLVM expression. -ppLlvmExpression :: LlvmExpression -> SDoc -ppLlvmExpression expr - = case expr of - Alloca tp amount -> ppAlloca tp amount - LlvmOp op left right -> ppMachOp op left right - Call tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs - CallM tp fp args attrs -> ppCall tp fp args attrs - Cast op from to -> ppCast op from to - Compare op left right -> ppCmpOp op left right - Extract vec idx -> ppExtract vec idx - ExtractV struct idx -> ppExtractV struct idx - Insert vec elt idx -> ppInsert vec elt idx - GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes - Load ptr -> ppLoad ptr - ALoad ord st ptr -> ppALoad ord st ptr - Malloc tp amount -> ppMalloc tp amount - AtomicRMW aop tgt src ordering -> ppAtomicRMW aop tgt src ordering - CmpXChg addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord - Phi tp precessors -> ppPhi tp precessors - Asm asm c ty v se sk -> ppAsm asm c ty v se sk - MExpr meta expr -> ppMetaExpr meta expr - - --------------------------------------------------------------------------------- --- * Individual print functions --------------------------------------------------------------------------------- - --- | Should always be a function pointer. So a global var of function type --- (since globals are always pointers) or a local var of pointer function type. -ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc -ppCall ct fptr args attrs = case fptr of - -- - -- if local var function pointer, unwrap - LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d - - -- should be function type otherwise - LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d - - -- not pointer or function, so error - _other -> error $ "ppCall called with non LMFunction type!\nMust be " - ++ " called with either global var of function type or " - ++ "local var of pointer function type." - - where - ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = - let tc = if ct == TailCall then text "tail " else empty - ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args - ppArgTy = (ppCommaJoin $ map fst params) <> - (case argTy of - VarArgs -> text ", ..." - FixedArgs -> empty) - fnty = space <> lparen <> ppArgTy <> rparen - attrDoc = ppSpaceJoin attrs - in tc <> text "call" <+> ppr cc <+> ppr ret - <> fnty <+> ppName fptr <> lparen <+> ppValues - <+> rparen <+> attrDoc - - -- Metadata needs to be marked as having the `metadata` type when used - -- in a call argument - ppCallMetaExpr (MetaVar v) = ppr v - ppCallMetaExpr v = text "metadata" <+> ppr v - -ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc -ppMachOp op left right = - (ppr op) <+> (ppr (getVarType left)) <+> ppName left - <> comma <+> ppName right - - -ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc -ppCmpOp op left right = - let cmpOp - | isInt (getVarType left) && isInt (getVarType right) = text "icmp" - | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp" - | otherwise = text "icmp" -- Just continue as its much easier to debug - {- - | otherwise = error ("can't compare different types, left = " - ++ (show $ getVarType left) ++ ", right = " - ++ (show $ getVarType right)) - -} - in cmpOp <+> ppr op <+> ppr (getVarType left) - <+> ppName left <> comma <+> ppName right - - -ppAssignment :: LlvmVar -> SDoc -> SDoc -ppAssignment var expr = ppName var <+> equals <+> expr - -ppFence :: Bool -> LlvmSyncOrdering -> SDoc -ppFence st ord = - let singleThread = case st of True -> text "singlethread" - False -> empty - in text "fence" <+> singleThread <+> ppSyncOrdering ord - -ppSyncOrdering :: LlvmSyncOrdering -> SDoc -ppSyncOrdering SyncUnord = text "unordered" -ppSyncOrdering SyncMonotonic = text "monotonic" -ppSyncOrdering SyncAcquire = text "acquire" -ppSyncOrdering SyncRelease = text "release" -ppSyncOrdering SyncAcqRel = text "acq_rel" -ppSyncOrdering SyncSeqCst = text "seq_cst" - -ppAtomicOp :: LlvmAtomicOp -> SDoc -ppAtomicOp LAO_Xchg = text "xchg" -ppAtomicOp LAO_Add = text "add" -ppAtomicOp LAO_Sub = text "sub" -ppAtomicOp LAO_And = text "and" -ppAtomicOp LAO_Nand = text "nand" -ppAtomicOp LAO_Or = text "or" -ppAtomicOp LAO_Xor = text "xor" -ppAtomicOp LAO_Max = text "max" -ppAtomicOp LAO_Min = text "min" -ppAtomicOp LAO_Umax = text "umax" -ppAtomicOp LAO_Umin = text "umin" - -ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc -ppAtomicRMW aop tgt src ordering = - text "atomicrmw" <+> ppAtomicOp aop <+> ppr tgt <> comma - <+> ppr src <+> ppSyncOrdering ordering - -ppCmpXChg :: LlvmVar -> LlvmVar -> LlvmVar - -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc -ppCmpXChg addr old new s_ord f_ord = - text "cmpxchg" <+> ppr addr <> comma <+> ppr old <> comma <+> ppr new - <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord - --- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but --- we have no way of guaranteeing that this is true with GHC (we would need to --- modify the layout of the stack and closures, change the storage manager, --- etc.). So, we blindly tell LLVM that *any* vector store or load could be --- unaligned. In the future we may be able to guarantee that certain vector --- access patterns are aligned, in which case we will need a more granular way --- of specifying alignment. - -ppLoad :: LlvmVar -> SDoc -ppLoad var = text "load" <+> ppr derefType <> comma <+> ppr var <> align - where - derefType = pLower $ getVarType var - align | isVector . pLower . getVarType $ var = text ", align 1" - | otherwise = empty - -ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc -ppALoad ord st var = sdocWithDynFlags $ \dflags -> - let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8 - align = text ", align" <+> ppr alignment - sThreaded | st = text " singlethread" - | otherwise = empty - derefType = pLower $ getVarType var - in text "load atomic" <+> ppr derefType <> comma <+> ppr var <> sThreaded - <+> ppSyncOrdering ord <> align - -ppStore :: LlvmVar -> LlvmVar -> SDoc -ppStore val dst - | isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <> - comma <+> text "align 1" - | otherwise = text "store" <+> ppr val <> comma <+> ppr dst - where - isVecPtrVar :: LlvmVar -> Bool - isVecPtrVar = isVector . pLower . getVarType - - -ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc -ppCast op from to - = ppr op - <+> ppr (getVarType from) <+> ppName from - <+> text "to" - <+> ppr to - - -ppMalloc :: LlvmType -> Int -> SDoc -ppMalloc tp amount = - let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in text "malloc" <+> ppr tp <> comma <+> ppr amount' - - -ppAlloca :: LlvmType -> Int -> SDoc -ppAlloca tp amount = - let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in text "alloca" <+> ppr tp <> comma <+> ppr amount' - - -ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc -ppGetElementPtr inb ptr idx = - let indexes = comma <+> ppCommaJoin idx - inbound = if inb then text "inbounds" else empty - derefType = pLower $ getVarType ptr - in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppr ptr - <> indexes - - -ppReturn :: Maybe LlvmVar -> SDoc -ppReturn (Just var) = text "ret" <+> ppr var -ppReturn Nothing = text "ret" <+> ppr LMVoid - - -ppBranch :: LlvmVar -> SDoc -ppBranch var = text "br" <+> ppr var - - -ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc -ppBranchIf cond trueT falseT - = text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT - - -ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc -ppPhi tp preds = - let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label - in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds) - - -ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc -ppSwitch scrut dflt targets = - let ppTarget (val, lab) = ppr val <> comma <+> ppr lab - ppTargets xs = brackets $ vcat (map ppTarget xs) - in text "switch" <+> ppr scrut <> comma <+> ppr dflt - <+> ppTargets targets - - -ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc -ppAsm asm constraints rty vars sideeffect alignstack = - let asm' = doubleQuotes $ ftext asm - cons = doubleQuotes $ ftext constraints - rty' = ppr rty - vars' = lparen <+> ppCommaJoin vars <+> rparen - side = if sideeffect then text "sideeffect" else empty - align = if alignstack then text "alignstack" else empty - in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma - <+> cons <> vars' - -ppExtract :: LlvmVar -> LlvmVar -> SDoc -ppExtract vec idx = - text "extractelement" - <+> ppr (getVarType vec) <+> ppName vec <> comma - <+> ppr idx - -ppExtractV :: LlvmVar -> Int -> SDoc -ppExtractV struct idx = - text "extractvalue" - <+> ppr (getVarType struct) <+> ppName struct <> comma - <+> ppr idx - -ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc -ppInsert vec elt idx = - text "insertelement" - <+> ppr (getVarType vec) <+> ppName vec <> comma - <+> ppr (getVarType elt) <+> ppName elt <> comma - <+> ppr idx - - -ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc -ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta - -ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc -ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta - -ppMetaAnnots :: [MetaAnnot] -> SDoc -ppMetaAnnots meta = hcat $ map ppMeta meta - where - ppMeta (MetaAnnot name e) - = comma <+> exclamation <> ftext name <+> - case e of - MetaNode n -> ppr n - MetaStruct ms -> exclamation <> braces (ppCommaJoin ms) - other -> exclamation <> braces (ppr other) -- possible? - - --------------------------------------------------------------------------------- --- * Misc functions --------------------------------------------------------------------------------- - --- | Blank line. -newLine :: SDoc -newLine = empty - --- | Exclamation point. -exclamation :: SDoc -exclamation = char '!' diff --git a/llvmGen/Llvm/Types.hs b/llvmGen/Llvm/Types.hs deleted file mode 100644 --- a/llvmGen/Llvm/Types.hs +++ /dev/null @@ -1,886 +0,0 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} - --------------------------------------------------------------------------------- --- | The LLVM Type System. --- - -module Llvm.Types where - -#include "HsVersions.h" - -import Data.Char -import Data.Int -import Numeric - -import DynFlags -import FastString -import Outputable -import Unique - --- from NCG -import PprBase - -import GHC.Float - --- ----------------------------------------------------------------------------- --- * LLVM Basic Types and Variables --- - --- | A global mutable variable. Maybe defined or external -data LMGlobal = LMGlobal { - getGlobalVar :: LlvmVar, -- ^ Returns the variable of the 'LMGlobal' - getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal' - } - --- | A String in LLVM -type LMString = FastString - --- | A type alias -type LlvmAlias = (LMString, LlvmType) - --- | Llvm Types -data LlvmType - = LMInt Int -- ^ An integer with a given width in bits. - | LMFloat -- ^ 32 bit floating point - | LMDouble -- ^ 64 bit floating point - | LMFloat80 -- ^ 80 bit (x86 only) floating point - | LMFloat128 -- ^ 128 bit floating point - | LMPointer LlvmType -- ^ A pointer to a 'LlvmType' - | LMArray Int LlvmType -- ^ An array of 'LlvmType' - | LMVector Int LlvmType -- ^ A vector of 'LlvmType' - | LMLabel -- ^ A 'LlvmVar' can represent a label (address) - | LMVoid -- ^ Void type - | LMStruct [LlvmType] -- ^ Packed structure type - | LMStructU [LlvmType] -- ^ Unpacked structure type - | LMAlias LlvmAlias -- ^ A type alias - | LMMetadata -- ^ LLVM Metadata - - -- | Function type, used to create pointers to functions - | LMFunction LlvmFunctionDecl - deriving (Eq) - -instance Outputable LlvmType where - ppr (LMInt size ) = char 'i' <> ppr size - ppr (LMFloat ) = text "float" - ppr (LMDouble ) = text "double" - ppr (LMFloat80 ) = text "x86_fp80" - ppr (LMFloat128 ) = text "fp128" - ppr (LMPointer x ) = ppr x <> char '*' - ppr (LMArray nr tp ) = char '[' <> ppr nr <> text " x " <> ppr tp <> char ']' - ppr (LMVector nr tp ) = char '<' <> ppr nr <> text " x " <> ppr tp <> char '>' - ppr (LMLabel ) = text "label" - ppr (LMVoid ) = text "void" - ppr (LMStruct tys ) = text "<{" <> ppCommaJoin tys <> text "}>" - ppr (LMStructU tys ) = text "{" <> ppCommaJoin tys <> text "}" - ppr (LMMetadata ) = text "metadata" - - ppr (LMFunction (LlvmFunctionDecl _ _ _ r varg p _)) - = ppr r <+> lparen <> ppParams varg p <> rparen - - ppr (LMAlias (s,_)) = char '%' <> ftext s - -ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc -ppParams varg p - = let varg' = case varg of - VarArgs | null args -> sLit "..." - | otherwise -> sLit ", ..." - _otherwise -> sLit "" - -- by default we don't print param attributes - args = map fst p - in ppCommaJoin args <> ptext varg' - --- | An LLVM section definition. If Nothing then let LLVM decide the section -type LMSection = Maybe LMString -type LMAlign = Maybe Int - -data LMConst = Global -- ^ Mutable global variable - | Constant -- ^ Constant global variable - | Alias -- ^ Alias of another variable - deriving (Eq) - --- | LLVM Variables -data LlvmVar - -- | Variables with a global scope. - = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst - -- | Variables local to a function or parameters. - | LMLocalVar Unique LlvmType - -- | Named local variables. Sometimes we need to be able to explicitly name - -- variables (e.g for function arguments). - | LMNLocalVar LMString LlvmType - -- | A constant variable - | LMLitVar LlvmLit - deriving (Eq) - -instance Outputable LlvmVar where - ppr (LMLitVar x) = ppr x - ppr (x ) = ppr (getVarType x) <+> ppName x - - --- | Llvm Literal Data. --- --- These can be used inline in expressions. -data LlvmLit - -- | Refers to an integer constant (i64 42). - = LMIntLit Integer LlvmType - -- | Floating point literal - | LMFloatLit Double LlvmType - -- | Literal NULL, only applicable to pointer types - | LMNullLit LlvmType - -- | Vector literal - | LMVectorLit [LlvmLit] - -- | Undefined value, random bit pattern. Useful for optimisations. - | LMUndefLit LlvmType - deriving (Eq) - -instance Outputable LlvmLit where - ppr l@(LMVectorLit {}) = ppLit l - ppr l = ppr (getLitType l) <+> ppLit l - - --- | Llvm Static Data. --- --- These represent the possible global level variables and constants. -data LlvmStatic - = LMComment LMString -- ^ A comment in a static section - | LMStaticLit LlvmLit -- ^ A static variant of a literal value - | LMUninitType LlvmType -- ^ For uninitialised data - | LMStaticStr LMString LlvmType -- ^ Defines a static 'LMString' - | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array - | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type - | LMStaticPointer LlvmVar -- ^ A pointer to other data - - -- static expressions, could split out but leave - -- for moment for ease of use. Not many of them. - - | LMBitc LlvmStatic LlvmType -- ^ Pointer to Pointer conversion - | LMPtoI LlvmStatic LlvmType -- ^ Pointer to Integer conversion - | LMAdd LlvmStatic LlvmStatic -- ^ Constant addition operation - | LMSub LlvmStatic LlvmStatic -- ^ Constant subtraction operation - -instance Outputable LlvmStatic where - ppr (LMComment s) = text "; " <> ftext s - ppr (LMStaticLit l ) = ppr l - ppr (LMUninitType t) = ppr t <> text " undef" - ppr (LMStaticStr s t) = ppr t <> text " c\"" <> ftext s <> text "\\00\"" - ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']' - ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>" - ppr (LMStaticPointer v) = ppr v - ppr (LMBitc v t) - = ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')' - ppr (LMPtoI v t) - = ppr t <> text " ptrtoint (" <> ppr v <> text " to " <> ppr t <> char ')' - - ppr (LMAdd s1 s2) - = pprStaticArith s1 s2 (sLit "add") (sLit "fadd") "LMAdd" - ppr (LMSub s1 s2) - = pprStaticArith s1 s2 (sLit "sub") (sLit "fsub") "LMSub" - - -pprSpecialStatic :: LlvmStatic -> SDoc -pprSpecialStatic (LMBitc v t) = - ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t - <> char ')' -pprSpecialStatic stat = ppr stat - - -pprStaticArith :: LlvmStatic -> LlvmStatic -> LitString -> LitString -> String -> SDoc -pprStaticArith s1 s2 int_op float_op op_name = - let ty1 = getStatType s1 - op = if isFloat ty1 then float_op else int_op - in if ty1 == getStatType s2 - then ppr ty1 <+> ptext op <+> lparen <> ppr s1 <> comma <> ppr s2 <> rparen - else sdocWithDynFlags $ \dflags -> - error $ op_name ++ " with different types! s1: " - ++ showSDoc dflags (ppr s1) ++ ", s2: " ++ showSDoc dflags (ppr s2) - --- ----------------------------------------------------------------------------- --- ** Operations on LLVM Basic Types and Variables --- - --- | Return the variable name or value of the 'LlvmVar' --- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@). -ppName :: LlvmVar -> SDoc -ppName v@(LMGlobalVar {}) = char '@' <> ppPlainName v -ppName v@(LMLocalVar {}) = char '%' <> ppPlainName v -ppName v@(LMNLocalVar {}) = char '%' <> ppPlainName v -ppName v@(LMLitVar {}) = ppPlainName v - --- | Return the variable name or value of the 'LlvmVar' --- in a plain textual representation (e.g. @x@, @y@ or @42@). -ppPlainName :: LlvmVar -> SDoc -ppPlainName (LMGlobalVar x _ _ _ _ _) = ftext x -ppPlainName (LMLocalVar x LMLabel ) = text (show x) -ppPlainName (LMLocalVar x _ ) = text ('l' : show x) -ppPlainName (LMNLocalVar x _ ) = ftext x -ppPlainName (LMLitVar x ) = ppLit x - --- | Print a literal value. No type. -ppLit :: LlvmLit -> SDoc -ppLit (LMIntLit i (LMInt 32)) = ppr (fromInteger i :: Int32) -ppLit (LMIntLit i (LMInt 64)) = ppr (fromInteger i :: Int64) -ppLit (LMIntLit i _ ) = ppr ((fromInteger i)::Int) -ppLit (LMFloatLit r LMFloat ) = ppFloat $ narrowFp r -ppLit (LMFloatLit r LMDouble) = ppDouble r -ppLit f@(LMFloatLit _ _) = sdocWithDynFlags (\dflags -> - error $ "Can't print this float literal!" ++ showSDoc dflags (ppr f)) -ppLit (LMVectorLit ls ) = char '<' <+> ppCommaJoin ls <+> char '>' -ppLit (LMNullLit _ ) = text "null" --- Trac 11487 was an issue where we passed undef for some arguments --- that were actually live. By chance the registers holding those --- arguments usually happened to have the right values anyways, but --- that was not guaranteed. To find such bugs reliably, we set the --- flag below when validating, which replaces undef literals (at --- common types) with values that are likely to cause a crash or test --- failure. -ppLit (LMUndefLit t ) = sdocWithDynFlags f - where f dflags - | gopt Opt_LlvmFillUndefWithGarbage dflags, - Just lit <- garbageLit t = ppLit lit - | otherwise = text "undef" - -garbageLit :: LlvmType -> Maybe LlvmLit -garbageLit t@(LMInt w) = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t) - -- Use a value that looks like an untagged pointer, so we are more - -- likely to try to enter it -garbageLit t - | isFloat t = Just (LMFloatLit 12345678.9 t) -garbageLit t@(LMPointer _) = Just (LMNullLit t) - -- Using null isn't totally ideal, since some functions may check for null. - -- But producing another value is inconvenient since it needs a cast, - -- and the knowledge for how to format casts is in PpLlvm. -garbageLit _ = Nothing - -- More cases could be added, but this should do for now. - --- | Return the 'LlvmType' of the 'LlvmVar' -getVarType :: LlvmVar -> LlvmType -getVarType (LMGlobalVar _ y _ _ _ _) = y -getVarType (LMLocalVar _ y ) = y -getVarType (LMNLocalVar _ y ) = y -getVarType (LMLitVar l ) = getLitType l - --- | Return the 'LlvmType' of a 'LlvmLit' -getLitType :: LlvmLit -> LlvmType -getLitType (LMIntLit _ t) = t -getLitType (LMFloatLit _ t) = t -getLitType (LMVectorLit []) = panic "getLitType" -getLitType (LMVectorLit ls) = LMVector (length ls) (getLitType (head ls)) -getLitType (LMNullLit t) = t -getLitType (LMUndefLit t) = t - --- | Return the 'LlvmType' of the 'LlvmStatic' -getStatType :: LlvmStatic -> LlvmType -getStatType (LMStaticLit l ) = getLitType l -getStatType (LMUninitType t) = t -getStatType (LMStaticStr _ t) = t -getStatType (LMStaticArray _ t) = t -getStatType (LMStaticStruc _ t) = t -getStatType (LMStaticPointer v) = getVarType v -getStatType (LMBitc _ t) = t -getStatType (LMPtoI _ t) = t -getStatType (LMAdd t _) = getStatType t -getStatType (LMSub t _) = getStatType t -getStatType (LMComment _) = error "Can't call getStatType on LMComment!" - --- | Return the 'LlvmLinkageType' for a 'LlvmVar' -getLink :: LlvmVar -> LlvmLinkageType -getLink (LMGlobalVar _ _ l _ _ _) = l -getLink _ = Internal - --- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid' --- cannot be lifted. -pLift :: LlvmType -> LlvmType -pLift LMLabel = error "Labels are unliftable" -pLift LMVoid = error "Voids are unliftable" -pLift LMMetadata = error "Metadatas are unliftable" -pLift x = LMPointer x - --- | Lift a variable to 'LMPointer' type. -pVarLift :: LlvmVar -> LlvmVar -pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c -pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t) -pVarLift (LMNLocalVar s t ) = LMNLocalVar s (pLift t) -pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!" - --- | Remove the pointer indirection of the supplied type. Only 'LMPointer' --- constructors can be lowered. -pLower :: LlvmType -> LlvmType -pLower (LMPointer x) = x -pLower x = pprPanic "llvmGen(pLower)" - $ ppr x <+> text " is a unlowerable type, need a pointer" - --- | Lower a variable of 'LMPointer' type. -pVarLower :: LlvmVar -> LlvmVar -pVarLower (LMGlobalVar s t l x a c) = LMGlobalVar s (pLower t) l x a c -pVarLower (LMLocalVar s t ) = LMLocalVar s (pLower t) -pVarLower (LMNLocalVar s t ) = LMNLocalVar s (pLower t) -pVarLower (LMLitVar _ ) = error $ "Can't lower a literal type!" - --- | Test if the given 'LlvmType' is an integer -isInt :: LlvmType -> Bool -isInt (LMInt _) = True -isInt _ = False - --- | Test if the given 'LlvmType' is a floating point type -isFloat :: LlvmType -> Bool -isFloat LMFloat = True -isFloat LMDouble = True -isFloat LMFloat80 = True -isFloat LMFloat128 = True -isFloat _ = False - --- | Test if the given 'LlvmType' is an 'LMPointer' construct -isPointer :: LlvmType -> Bool -isPointer (LMPointer _) = True -isPointer _ = False - --- | Test if the given 'LlvmType' is an 'LMVector' construct -isVector :: LlvmType -> Bool -isVector (LMVector {}) = True -isVector _ = False - --- | Test if a 'LlvmVar' is global. -isGlobal :: LlvmVar -> Bool -isGlobal (LMGlobalVar _ _ _ _ _ _) = True -isGlobal _ = False - --- | Width in bits of an 'LlvmType', returns 0 if not applicable -llvmWidthInBits :: DynFlags -> LlvmType -> Int -llvmWidthInBits _ (LMInt n) = n -llvmWidthInBits _ (LMFloat) = 32 -llvmWidthInBits _ (LMDouble) = 64 -llvmWidthInBits _ (LMFloat80) = 80 -llvmWidthInBits _ (LMFloat128) = 128 --- Could return either a pointer width here or the width of what --- it points to. We will go with the former for now. --- PMW: At least judging by the way LLVM outputs constants, pointers --- should use the former, but arrays the latter. -llvmWidthInBits dflags (LMPointer _) = llvmWidthInBits dflags (llvmWord dflags) -llvmWidthInBits dflags (LMArray n t) = n * llvmWidthInBits dflags t -llvmWidthInBits dflags (LMVector n ty) = n * llvmWidthInBits dflags ty -llvmWidthInBits _ LMLabel = 0 -llvmWidthInBits _ LMVoid = 0 -llvmWidthInBits dflags (LMStruct tys) = sum $ map (llvmWidthInBits dflags) tys -llvmWidthInBits _ (LMStructU _) = - -- It's not trivial to calculate the bit width of the unpacked structs, - -- since they will be aligned depending on the specified datalayout ( - -- http://llvm.org/docs/LangRef.html#data-layout ). One way we could support - -- this could be to make the LlvmCodeGen.Ppr.moduleLayout be a data type - -- that exposes the alignment information. However, currently the only place - -- we use unpacked structs is LLVM intrinsics that return them (e.g., - -- llvm.sadd.with.overflow.*), so we don't actually need to compute their - -- bit width. - panic "llvmWidthInBits: not implemented for LMStructU" -llvmWidthInBits _ (LMFunction _) = 0 -llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t -llvmWidthInBits _ LMMetadata = panic "llvmWidthInBits: Meta-data has no runtime representation!" - - --- ----------------------------------------------------------------------------- --- ** Shortcut for Common Types --- - -i128, i64, i32, i16, i8, i1, i8Ptr :: LlvmType -i128 = LMInt 128 -i64 = LMInt 64 -i32 = LMInt 32 -i16 = LMInt 16 -i8 = LMInt 8 -i1 = LMInt 1 -i8Ptr = pLift i8 - --- | The target architectures word size -llvmWord, llvmWordPtr :: DynFlags -> LlvmType -llvmWord dflags = LMInt (wORD_SIZE dflags * 8) -llvmWordPtr dflags = pLift (llvmWord dflags) - --- ----------------------------------------------------------------------------- --- * LLVM Function Types --- - --- | An LLVM Function -data LlvmFunctionDecl = LlvmFunctionDecl { - -- | Unique identifier of the function - decName :: LMString, - -- | LinkageType of the function - funcLinkage :: LlvmLinkageType, - -- | The calling convention of the function - funcCc :: LlvmCallConvention, - -- | Type of the returned value - decReturnType :: LlvmType, - -- | Indicates if this function uses varargs - decVarargs :: LlvmParameterListType, - -- | Parameter types and attributes - decParams :: [LlvmParameter], - -- | Function align value, must be power of 2 - funcAlign :: LMAlign - } - deriving (Eq) - -instance Outputable LlvmFunctionDecl where - ppr (LlvmFunctionDecl n l c r varg p a) - = let align = case a of - Just a' -> text " align " <> ppr a' - Nothing -> empty - in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> - lparen <> ppParams varg p <> rparen <> align - -type LlvmFunctionDecls = [LlvmFunctionDecl] - -type LlvmParameter = (LlvmType, [LlvmParamAttr]) - --- | LLVM Parameter Attributes. --- --- Parameter attributes are used to communicate additional information about --- the result or parameters of a function -data LlvmParamAttr - -- | This indicates to the code generator that the parameter or return value - -- should be zero-extended to a 32-bit value by the caller (for a parameter) - -- or the callee (for a return value). - = ZeroExt - -- | This indicates to the code generator that the parameter or return value - -- should be sign-extended to a 32-bit value by the caller (for a parameter) - -- or the callee (for a return value). - | SignExt - -- | This indicates that this parameter or return value should be treated in - -- a special target-dependent fashion during while emitting code for a - -- function call or return (usually, by putting it in a register as opposed - -- to memory). - | InReg - -- | This indicates that the pointer parameter should really be passed by - -- value to the function. - | ByVal - -- | This indicates that the pointer parameter specifies the address of a - -- structure that is the return value of the function in the source program. - | SRet - -- | This indicates that the pointer does not alias any global or any other - -- parameter. - | NoAlias - -- | This indicates that the callee does not make any copies of the pointer - -- that outlive the callee itself - | NoCapture - -- | This indicates that the pointer parameter can be excised using the - -- trampoline intrinsics. - | Nest - deriving (Eq) - -instance Outputable LlvmParamAttr where - ppr ZeroExt = text "zeroext" - ppr SignExt = text "signext" - ppr InReg = text "inreg" - ppr ByVal = text "byval" - ppr SRet = text "sret" - ppr NoAlias = text "noalias" - ppr NoCapture = text "nocapture" - ppr Nest = text "nest" - --- | Llvm Function Attributes. --- --- Function attributes are set to communicate additional information about a --- function. Function attributes are considered to be part of the function, --- not of the function type, so functions with different parameter attributes --- can have the same function type. Functions can have multiple attributes. --- --- Descriptions taken from -data LlvmFuncAttr - -- | This attribute indicates that the inliner should attempt to inline this - -- function into callers whenever possible, ignoring any active inlining - -- size threshold for this caller. - = AlwaysInline - -- | This attribute indicates that the source code contained a hint that - -- inlining this function is desirable (such as the \"inline\" keyword in - -- C/C++). It is just a hint; it imposes no requirements on the inliner. - | InlineHint - -- | This attribute indicates that the inliner should never inline this - -- function in any situation. This attribute may not be used together - -- with the alwaysinline attribute. - | NoInline - -- | This attribute suggests that optimization passes and code generator - -- passes make choices that keep the code size of this function low, and - -- otherwise do optimizations specifically to reduce code size. - | OptSize - -- | This function attribute indicates that the function never returns - -- normally. This produces undefined behavior at runtime if the function - -- ever does dynamically return. - | NoReturn - -- | This function attribute indicates that the function never returns with - -- an unwind or exceptional control flow. If the function does unwind, its - -- runtime behavior is undefined. - | NoUnwind - -- | This attribute indicates that the function computes its result (or - -- decides to unwind an exception) based strictly on its arguments, without - -- dereferencing any pointer arguments or otherwise accessing any mutable - -- state (e.g. memory, control registers, etc) visible to caller functions. - -- It does not write through any pointer arguments (including byval - -- arguments) and never changes any state visible to callers. This means - -- that it cannot unwind exceptions by calling the C++ exception throwing - -- methods, but could use the unwind instruction. - | ReadNone - -- | This attribute indicates that the function does not write through any - -- pointer arguments (including byval arguments) or otherwise modify any - -- state (e.g. memory, control registers, etc) visible to caller functions. - -- It may dereference pointer arguments and read state that may be set in - -- the caller. A readonly function always returns the same value (or unwinds - -- an exception identically) when called with the same set of arguments and - -- global state. It cannot unwind an exception by calling the C++ exception - -- throwing methods, but may use the unwind instruction. - | ReadOnly - -- | This attribute indicates that the function should emit a stack smashing - -- protector. It is in the form of a \"canary\"—a random value placed on the - -- stack before the local variables that's checked upon return from the - -- function to see if it has been overwritten. A heuristic is used to - -- determine if a function needs stack protectors or not. - -- - -- If a function that has an ssp attribute is inlined into a function that - -- doesn't have an ssp attribute, then the resulting function will have an - -- ssp attribute. - | Ssp - -- | This attribute indicates that the function should always emit a stack - -- smashing protector. This overrides the ssp function attribute. - -- - -- If a function that has an sspreq attribute is inlined into a function - -- that doesn't have an sspreq attribute or which has an ssp attribute, - -- then the resulting function will have an sspreq attribute. - | SspReq - -- | This attribute indicates that the code generator should not use a red - -- zone, even if the target-specific ABI normally permits it. - | NoRedZone - -- | This attributes disables implicit floating point instructions. - | NoImplicitFloat - -- | This attribute disables prologue / epilogue emission for the function. - -- This can have very system-specific consequences. - | Naked - deriving (Eq) - -instance Outputable LlvmFuncAttr where - ppr AlwaysInline = text "alwaysinline" - ppr InlineHint = text "inlinehint" - ppr NoInline = text "noinline" - ppr OptSize = text "optsize" - ppr NoReturn = text "noreturn" - ppr NoUnwind = text "nounwind" - ppr ReadNone = text "readnon" - ppr ReadOnly = text "readonly" - ppr Ssp = text "ssp" - ppr SspReq = text "ssqreq" - ppr NoRedZone = text "noredzone" - ppr NoImplicitFloat = text "noimplicitfloat" - ppr Naked = text "naked" - - --- | Different types to call a function. -data LlvmCallType - -- | Normal call, allocate a new stack frame. - = StdCall - -- | Tail call, perform the call in the current stack frame. - | TailCall - deriving (Eq,Show) - --- | Different calling conventions a function can use. -data LlvmCallConvention - -- | The C calling convention. - -- This calling convention (the default if no other calling convention is - -- specified) matches the target C calling conventions. This calling - -- convention supports varargs function calls and tolerates some mismatch in - -- the declared prototype and implemented declaration of the function (as - -- does normal C). - = CC_Ccc - -- | This calling convention attempts to make calls as fast as possible - -- (e.g. by passing things in registers). This calling convention allows - -- the target to use whatever tricks it wants to produce fast code for the - -- target, without having to conform to an externally specified ABI - -- (Application Binary Interface). Implementations of this convention should - -- allow arbitrary tail call optimization to be supported. This calling - -- convention does not support varargs and requires the prototype of al - -- callees to exactly match the prototype of the function definition. - | CC_Fastcc - -- | This calling convention attempts to make code in the caller as efficient - -- as possible under the assumption that the call is not commonly executed. - -- As such, these calls often preserve all registers so that the call does - -- not break any live ranges in the caller side. This calling convention - -- does not support varargs and requires the prototype of all callees to - -- exactly match the prototype of the function definition. - | CC_Coldcc - -- | The GHC-specific 'registerised' calling convention. - | CC_Ghc - -- | Any calling convention may be specified by number, allowing - -- target-specific calling conventions to be used. Target specific calling - -- conventions start at 64. - | CC_Ncc Int - -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it - -- rather than just using CC_Ncc. - | CC_X86_Stdcc - deriving (Eq) - -instance Outputable LlvmCallConvention where - ppr CC_Ccc = text "ccc" - ppr CC_Fastcc = text "fastcc" - ppr CC_Coldcc = text "coldcc" - ppr CC_Ghc = text "ghccc" - ppr (CC_Ncc i) = text "cc " <> ppr i - ppr CC_X86_Stdcc = text "x86_stdcallcc" - - --- | Functions can have a fixed amount of parameters, or a variable amount. -data LlvmParameterListType - -- Fixed amount of arguments. - = FixedArgs - -- Variable amount of arguments. - | VarArgs - deriving (Eq,Show) - - --- | Linkage type of a symbol. --- --- The description of the constructors is copied from the Llvm Assembly Language --- Reference Manual , because --- they correspond to the Llvm linkage types. -data LlvmLinkageType - -- | Global values with internal linkage are only directly accessible by - -- objects in the current module. In particular, linking code into a module - -- with an internal global value may cause the internal to be renamed as - -- necessary to avoid collisions. Because the symbol is internal to the - -- module, all references can be updated. This corresponds to the notion - -- of the @static@ keyword in C. - = Internal - -- | Globals with @linkonce@ linkage are merged with other globals of the - -- same name when linkage occurs. This is typically used to implement - -- inline functions, templates, or other code which must be generated - -- in each translation unit that uses it. Unreferenced linkonce globals are - -- allowed to be discarded. - | LinkOnce - -- | @weak@ linkage is exactly the same as linkonce linkage, except that - -- unreferenced weak globals may not be discarded. This is used for globals - -- that may be emitted in multiple translation units, but that are not - -- guaranteed to be emitted into every translation unit that uses them. One - -- example of this are common globals in C, such as @int X;@ at global - -- scope. - | Weak - -- | @appending@ linkage may only be applied to global variables of pointer - -- to array type. When two global variables with appending linkage are - -- linked together, the two global arrays are appended together. This is - -- the Llvm, typesafe, equivalent of having the system linker append - -- together @sections@ with identical names when .o files are linked. - | Appending - -- | The semantics of this linkage follow the ELF model: the symbol is weak - -- until linked, if not linked, the symbol becomes null instead of being an - -- undefined reference. - | ExternWeak - -- | The symbol participates in linkage and can be used to resolve external - -- symbol references. - | ExternallyVisible - -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM - -- assembly. - | External - -- | Symbol is private to the module and should not appear in the symbol table - | Private - deriving (Eq) - -instance Outputable LlvmLinkageType where - ppr Internal = text "internal" - ppr LinkOnce = text "linkonce" - ppr Weak = text "weak" - ppr Appending = text "appending" - ppr ExternWeak = text "extern_weak" - -- ExternallyVisible does not have a textual representation, it is - -- the linkage type a function resolves to if no other is specified - -- in Llvm. - ppr ExternallyVisible = empty - ppr External = text "external" - ppr Private = text "private" - --- ----------------------------------------------------------------------------- --- * LLVM Operations --- - --- | Llvm binary operators machine operations. -data LlvmMachOp - = LM_MO_Add -- ^ add two integer, floating point or vector values. - | LM_MO_Sub -- ^ subtract two ... - | LM_MO_Mul -- ^ multiply .. - | LM_MO_UDiv -- ^ unsigned integer or vector division. - | LM_MO_SDiv -- ^ signed integer .. - | LM_MO_URem -- ^ unsigned integer or vector remainder (mod) - | LM_MO_SRem -- ^ signed ... - - | LM_MO_FAdd -- ^ add two floating point or vector values. - | LM_MO_FSub -- ^ subtract two ... - | LM_MO_FMul -- ^ multiply ... - | LM_MO_FDiv -- ^ divide ... - | LM_MO_FRem -- ^ remainder ... - - -- | Left shift - | LM_MO_Shl - -- | Logical shift right - -- Shift right, filling with zero - | LM_MO_LShr - -- | Arithmetic shift right - -- The most significant bits of the result will be equal to the sign bit of - -- the left operand. - | LM_MO_AShr - - | LM_MO_And -- ^ AND bitwise logical operation. - | LM_MO_Or -- ^ OR bitwise logical operation. - | LM_MO_Xor -- ^ XOR bitwise logical operation. - deriving (Eq) - -instance Outputable LlvmMachOp where - ppr LM_MO_Add = text "add" - ppr LM_MO_Sub = text "sub" - ppr LM_MO_Mul = text "mul" - ppr LM_MO_UDiv = text "udiv" - ppr LM_MO_SDiv = text "sdiv" - ppr LM_MO_URem = text "urem" - ppr LM_MO_SRem = text "srem" - ppr LM_MO_FAdd = text "fadd" - ppr LM_MO_FSub = text "fsub" - ppr LM_MO_FMul = text "fmul" - ppr LM_MO_FDiv = text "fdiv" - ppr LM_MO_FRem = text "frem" - ppr LM_MO_Shl = text "shl" - ppr LM_MO_LShr = text "lshr" - ppr LM_MO_AShr = text "ashr" - ppr LM_MO_And = text "and" - ppr LM_MO_Or = text "or" - ppr LM_MO_Xor = text "xor" - - --- | Llvm compare operations. -data LlvmCmpOp - = LM_CMP_Eq -- ^ Equal (Signed and Unsigned) - | LM_CMP_Ne -- ^ Not equal (Signed and Unsigned) - | LM_CMP_Ugt -- ^ Unsigned greater than - | LM_CMP_Uge -- ^ Unsigned greater than or equal - | LM_CMP_Ult -- ^ Unsigned less than - | LM_CMP_Ule -- ^ Unsigned less than or equal - | LM_CMP_Sgt -- ^ Signed greater than - | LM_CMP_Sge -- ^ Signed greater than or equal - | LM_CMP_Slt -- ^ Signed less than - | LM_CMP_Sle -- ^ Signed less than or equal - - -- Float comparisons. GHC uses a mix of ordered and unordered float - -- comparisons. - | LM_CMP_Feq -- ^ Float equal - | LM_CMP_Fne -- ^ Float not equal - | LM_CMP_Fgt -- ^ Float greater than - | LM_CMP_Fge -- ^ Float greater than or equal - | LM_CMP_Flt -- ^ Float less than - | LM_CMP_Fle -- ^ Float less than or equal - deriving (Eq) - -instance Outputable LlvmCmpOp where - ppr LM_CMP_Eq = text "eq" - ppr LM_CMP_Ne = text "ne" - ppr LM_CMP_Ugt = text "ugt" - ppr LM_CMP_Uge = text "uge" - ppr LM_CMP_Ult = text "ult" - ppr LM_CMP_Ule = text "ule" - ppr LM_CMP_Sgt = text "sgt" - ppr LM_CMP_Sge = text "sge" - ppr LM_CMP_Slt = text "slt" - ppr LM_CMP_Sle = text "sle" - ppr LM_CMP_Feq = text "oeq" - ppr LM_CMP_Fne = text "une" - ppr LM_CMP_Fgt = text "ogt" - ppr LM_CMP_Fge = text "oge" - ppr LM_CMP_Flt = text "olt" - ppr LM_CMP_Fle = text "ole" - - --- | Llvm cast operations. -data LlvmCastOp - = LM_Trunc -- ^ Integer truncate - | LM_Zext -- ^ Integer extend (zero fill) - | LM_Sext -- ^ Integer extend (sign fill) - | LM_Fptrunc -- ^ Float truncate - | LM_Fpext -- ^ Float extend - | LM_Fptoui -- ^ Float to unsigned Integer - | LM_Fptosi -- ^ Float to signed Integer - | LM_Uitofp -- ^ Unsigned Integer to Float - | LM_Sitofp -- ^ Signed Int to Float - | LM_Ptrtoint -- ^ Pointer to Integer - | LM_Inttoptr -- ^ Integer to Pointer - | LM_Bitcast -- ^ Cast between types where no bit manipulation is needed - deriving (Eq) - -instance Outputable LlvmCastOp where - ppr LM_Trunc = text "trunc" - ppr LM_Zext = text "zext" - ppr LM_Sext = text "sext" - ppr LM_Fptrunc = text "fptrunc" - ppr LM_Fpext = text "fpext" - ppr LM_Fptoui = text "fptoui" - ppr LM_Fptosi = text "fptosi" - ppr LM_Uitofp = text "uitofp" - ppr LM_Sitofp = text "sitofp" - ppr LM_Ptrtoint = text "ptrtoint" - ppr LM_Inttoptr = text "inttoptr" - ppr LM_Bitcast = text "bitcast" - - --- ----------------------------------------------------------------------------- --- * Floating point conversion --- - --- | Convert a Haskell Double to an LLVM hex encoded floating point form. In --- Llvm float literals can be printed in a big-endian hexadecimal format, --- regardless of underlying architecture. --- --- See Note [LLVM Float Types]. -ppDouble :: Double -> SDoc -ppDouble d - = let bs = doubleToBytes d - hex d' = case showHex d' "" of - [] -> error "dToStr: too few hex digits for float" - [x] -> ['0',x] - [x,y] -> [x,y] - _ -> error "dToStr: too many hex digits for float" - - str = map toUpper $ concat $ fixEndian $ map hex bs - in text "0x" <> text str - --- Note [LLVM Float Types] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- We use 'ppDouble' for both printing Float and Double floating point types. This is --- as LLVM expects all floating point constants (single & double) to be in IEEE --- 754 Double precision format. However, for single precision numbers (Float) --- they should be *representable* in IEEE 754 Single precision format. So the --- easiest way to do this is to narrow and widen again. --- (i.e., Double -> Float -> Double). We must be careful doing this that GHC --- doesn't optimize that away. - --- Note [narrowFp & widenFp] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- NOTE: we use float2Double & co directly as GHC likes to optimize away --- successive calls of 'realToFrac', defeating the narrowing. (Bug #7600). --- 'realToFrac' has inconsistent behaviour with optimisation as well that can --- also cause issues, these methods don't. - -narrowFp :: Double -> Float -{-# NOINLINE narrowFp #-} -narrowFp = double2Float - -widenFp :: Float -> Double -{-# NOINLINE widenFp #-} -widenFp = float2Double - -ppFloat :: Float -> SDoc -ppFloat = ppDouble . widenFp - --- | Reverse or leave byte data alone to fix endianness on this target. -fixEndian :: [a] -> [a] -#ifdef WORDS_BIGENDIAN -fixEndian = id -#else -fixEndian = reverse -#endif - - --------------------------------------------------------------------------------- --- * Misc functions --------------------------------------------------------------------------------- - -ppCommaJoin :: (Outputable a) => [a] -> SDoc -ppCommaJoin strs = hsep $ punctuate comma (map ppr strs) - -ppSpaceJoin :: (Outputable a) => [a] -> SDoc -ppSpaceJoin strs = hsep (map ppr strs) diff --git a/llvmGen/LlvmCodeGen.hs b/llvmGen/LlvmCodeGen.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE CPP, TypeFamilies #-} - --- ----------------------------------------------------------------------------- --- | This is the top-level module in the LLVM code generator. --- -module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where - -#include "HsVersions.h" - -import Llvm -import LlvmCodeGen.Base -import LlvmCodeGen.CodeGen -import LlvmCodeGen.Data -import LlvmCodeGen.Ppr -import LlvmCodeGen.Regs -import LlvmMangler - -import BlockId -import CgUtils ( fixStgRegisters ) -import Cmm -import CmmUtils -import Hoopl -import PprCmm - -import BufWrite -import DynFlags -import ErrUtils -import FastString -import Outputable -import UniqSupply -import SysTools ( figureLlvmVersion ) -import qualified Stream - -import Control.Monad ( when ) -import Data.Maybe ( fromMaybe, catMaybes ) -import System.IO - --- ----------------------------------------------------------------------------- --- | Top-level of the LLVM Code generator --- -llvmCodeGen :: DynFlags -> Handle -> UniqSupply - -> Stream.Stream IO RawCmmGroup () - -> IO () -llvmCodeGen dflags h us cmm_stream - = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do - bufh <- newBufHandle h - - -- Pass header - showPass dflags "LLVM CodeGen" - - -- get llvm version, cache for later use - ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags - - -- warn if unsupported - debugTraceMsg dflags 2 - (text "Using LLVM version:" <+> text (show ver)) - let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags - when (ver /= supportedLlvmVersion && doWarn) $ - putMsg dflags (text "You are using an unsupported version of LLVM!" - $+$ text ("Currently only " ++ - llvmVersionStr supportedLlvmVersion ++ - " is supported.") - $+$ text "We will try though...") - - -- run code generation - runLlvm dflags ver bufh us $ - llvmCodeGen' (liftStream cmm_stream) - - bFlush bufh - -llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM () -llvmCodeGen' cmm_stream - = do -- Preamble - renderLlvm pprLlvmHeader - ghcInternalFunctions - cmmMetaLlvmPrelude - - -- Procedures - let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream - _ <- Stream.collect llvmStream - - -- Declare aliases for forward references - renderLlvm . pprLlvmData =<< generateExternDecls - - -- Postamble - cmmUsedLlvmGens - -llvmGroupLlvmGens :: RawCmmGroup -> LlvmM () -llvmGroupLlvmGens cmm = do - - -- Insert functions into map, collect data - let split (CmmData s d' ) = return $ Just (s, d') - split (CmmProc h l live g) = do - -- Set function type - let l' = case mapLookup (g_entry g) h of - Nothing -> l - Just (Statics info_lbl _) -> info_lbl - lml <- strCLabel_llvm l' - funInsert lml =<< llvmFunTy live - return Nothing - cdata <- fmap catMaybes $ mapM split cmm - - {-# SCC "llvm_datas_gen" #-} - cmmDataLlvmGens cdata - {-# SCC "llvm_procs_gen" #-} - mapM_ cmmLlvmGen cmm - --- ----------------------------------------------------------------------------- --- | Do LLVM code generation on all these Cmms data sections. --- -cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM () - -cmmDataLlvmGens statics - = do lmdatas <- mapM genLlvmData statics - - let (gss, tss) = unzip lmdatas - - let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _) - = funInsert l ty - regGlobal _ = return () - mapM_ regGlobal (concat gss) - gss' <- mapM aliasify $ concat gss - - renderLlvm $ pprLlvmData (concat gss', concat tss) - --- | LLVM can't handle entry blocks which loop back to themselves (could be --- seen as an LLVM bug) so we rearrange the code to keep the original entry --- label which branches to a newly generated second label that branches back --- to itself. See: Trac #11649 -fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl -fixBottom cp@(CmmProc hdr entry_lbl live g) = - maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map - where - blk_map = toBlockMap g - - fix_block :: CmmBlock -> LlvmM RawCmmDecl - fix_block blk - | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk - , isEmptyBlock middle - , e_lbl == b_lbl = do - new_lbl <- mkBlockId <$> getUniqueM - - let fst_blk = - BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl) - snd_blk = - BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl) - - pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g) - $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)] - - fix_block _ = pure cp - -fixBottom rcd = pure rcd - --- | Complete LLVM code generation phase for a single top-level chunk of Cmm. -cmmLlvmGen ::RawCmmDecl -> LlvmM () -cmmLlvmGen cmm@CmmProc{} = do - - -- rewrite assignments to global regs - dflags <- getDynFlag id - fixed_cmm <- fixBottom $ - {-# SCC "llvm_fix_regs" #-} - fixStgRegisters dflags cmm - - dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm]) - - -- generate llvm code from cmm - llvmBC <- withClearVars $ genLlvmProc fixed_cmm - - -- pretty print - (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC - - -- Output, note down used variables - renderLlvm (vcat docs) - mapM_ markUsedVar $ concat ivars - -cmmLlvmGen _ = return () - --- ----------------------------------------------------------------------------- --- | Generate meta data nodes --- - -cmmMetaLlvmPrelude :: LlvmM () -cmmMetaLlvmPrelude = do - metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do - -- Generate / lookup meta data IDs - tbaaId <- getMetaUniqueId - setUniqMeta uniq tbaaId - parentId <- maybe (return Nothing) getUniqMeta parent - -- Build definition - return $ MetaUnnamed tbaaId $ MetaStruct $ - case parentId of - Just p -> [ MetaStr name, MetaNode p ] - -- As of LLVM 4.0, a node without parents should be rendered as - -- just a name on its own. Previously `null` was accepted as the - -- name. - Nothing -> [ MetaStr name ] - renderLlvm $ ppLlvmMetas metas - --- ----------------------------------------------------------------------------- --- | Marks variables as used where necessary --- - -cmmUsedLlvmGens :: LlvmM () -cmmUsedLlvmGens = do - - -- LLVM would discard variables that are internal and not obviously - -- used if we didn't provide these hints. This will generate a - -- definition of the form - -- - -- @llvm.used = appending global [42 x i8*] [i8* bitcast to i8*, ...] - -- - -- Which is the LLVM way of protecting them against getting removed. - ivars <- getUsedVars - let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr - ty = (LMArray (length ivars) i8Ptr) - usedArray = LMStaticArray (map cast ivars) ty - sectName = Just $ fsLit "llvm.metadata" - lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant - lmUsed = LMGlobal lmUsedVar (Just usedArray) - if null ivars - then return () - else renderLlvm $ pprLlvmData ([lmUsed], []) diff --git a/llvmGen/LlvmCodeGen/Base.hs b/llvmGen/LlvmCodeGen/Base.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen/Base.hs +++ /dev/null @@ -1,550 +0,0 @@ -{-# LANGUAGE CPP #-} - --- ---------------------------------------------------------------------------- --- | Base LLVM Code Generation module --- --- Contains functions useful through out the code generator. --- - -module LlvmCodeGen.Base ( - - LlvmCmmDecl, LlvmBasicBlock, - LiveGlobalRegs, - LlvmUnresData, LlvmData, UnresLabel, UnresStatic, - - LlvmVersion, supportedLlvmVersion, llvmVersionStr, - - LlvmM, - runLlvm, liftStream, withClearVars, varLookup, varInsert, - markStackReg, checkStackReg, - funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform, - dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars, - ghcInternalFunctions, - - getMetaUniqueId, - setUniqMeta, getUniqMeta, - - cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, - llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, - llvmPtrBits, tysToParams, llvmFunSection, - - strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, - getGlobalPtr, generateExternDecls, - - aliasify, - ) where - -#include "HsVersions.h" -#include "ghcautoconf.h" - -import Llvm -import LlvmCodeGen.Regs - -import CLabel -import CodeGen.Platform ( activeStgRegs ) -import DynFlags -import FastString -import Cmm hiding ( succ ) -import Outputable as Outp -import Platform -import UniqFM -import Unique -import BufWrite ( BufHandle ) -import UniqSet -import UniqSupply -import ErrUtils -import qualified Stream - -import Control.Monad (ap) - --- ---------------------------------------------------------------------------- --- * Some Data Types --- - -type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement) -type LlvmBasicBlock = GenBasicBlock LlvmStatement - --- | Global registers live on proc entry -type LiveGlobalRegs = [GlobalReg] - --- | Unresolved code. --- Of the form: (data label, data type, unresolved data) -type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic]) - --- | Top level LLVM Data (globals and type aliases) -type LlvmData = ([LMGlobal], [LlvmType]) - --- | An unresolved Label. --- --- Labels are unresolved when we haven't yet determined if they are defined in --- the module we are currently compiling, or an external one. -type UnresLabel = CmmLit -type UnresStatic = Either UnresLabel LlvmStatic - --- ---------------------------------------------------------------------------- --- * Type translations --- - --- | Translate a basic CmmType to an LlvmType. -cmmToLlvmType :: CmmType -> LlvmType -cmmToLlvmType ty | isVecType ty = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty)) - | isFloatType ty = widthToLlvmFloat $ typeWidth ty - | otherwise = widthToLlvmInt $ typeWidth ty - --- | Translate a Cmm Float Width to a LlvmType. -widthToLlvmFloat :: Width -> LlvmType -widthToLlvmFloat W32 = LMFloat -widthToLlvmFloat W64 = LMDouble -widthToLlvmFloat W80 = LMFloat80 -widthToLlvmFloat W128 = LMFloat128 -widthToLlvmFloat w = panic $ "widthToLlvmFloat: Bad float size: " ++ show w - --- | Translate a Cmm Bit Width to a LlvmType. -widthToLlvmInt :: Width -> LlvmType -widthToLlvmInt w = LMInt $ widthInBits w - --- | GHC Call Convention for LLVM -llvmGhcCC :: DynFlags -> LlvmCallConvention -llvmGhcCC dflags - | platformUnregisterised (targetPlatform dflags) = CC_Ccc - | otherwise = CC_Ghc - --- | Llvm Function type for Cmm function -llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType -llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible - --- | Llvm Function signature -llvmFunSig :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl -llvmFunSig live lbl link = do - lbl' <- strCLabel_llvm lbl - llvmFunSig' live lbl' link - -llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl -llvmFunSig' live lbl link - = do let toParams x | isPointer x = (x, [NoAlias, NoCapture]) - | otherwise = (x, []) - dflags <- getDynFlags - return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs - (map (toParams . getVarType) (llvmFunArgs dflags live)) - (llvmFunAlign dflags) - --- | Alignment to use for functions -llvmFunAlign :: DynFlags -> LMAlign -llvmFunAlign dflags = Just (wORD_SIZE dflags) - --- | Alignment to use for into tables -llvmInfAlign :: DynFlags -> LMAlign -llvmInfAlign dflags = Just (wORD_SIZE dflags) - --- | Section to use for a function -llvmFunSection :: DynFlags -> LMString -> LMSection -llvmFunSection dflags lbl - | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl]) - | otherwise = Nothing - --- | A Function's arguments -llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar] -llvmFunArgs dflags live = - map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform)) - where platform = targetPlatform dflags - isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live - isPassed r = not (isSSE r) || isLive r - isSSE (FloatReg _) = True - isSSE (DoubleReg _) = True - isSSE (XmmReg _) = True - isSSE (YmmReg _) = True - isSSE (ZmmReg _) = True - isSSE _ = False - --- | Llvm standard fun attributes -llvmStdFunAttrs :: [LlvmFuncAttr] -llvmStdFunAttrs = [NoUnwind] - --- | Convert a list of types to a list of function parameters --- (each with no parameter attributes) -tysToParams :: [LlvmType] -> [LlvmParameter] -tysToParams = map (\ty -> (ty, [])) - --- | Pointer width -llvmPtrBits :: DynFlags -> Int -llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags - --- ---------------------------------------------------------------------------- --- * Llvm Version --- - --- | LLVM Version Number -type LlvmVersion = (Int, Int) - --- | The LLVM Version that is currently supported. -supportedLlvmVersion :: LlvmVersion -supportedLlvmVersion = sUPPORTED_LLVM_VERSION - -llvmVersionStr :: LlvmVersion -> String -llvmVersionStr (major, minor) = show major ++ "." ++ show minor - --- ---------------------------------------------------------------------------- --- * Environment Handling --- - -data LlvmEnv = LlvmEnv - { envVersion :: LlvmVersion -- ^ LLVM version - , envDynFlags :: DynFlags -- ^ Dynamic flags - , envOutput :: BufHandle -- ^ Output buffer - , envUniq :: UniqSupply -- ^ Supply of unique values - , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs - , envUniqMeta :: UniqFM MetaId -- ^ Global metadata nodes - , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type - , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References] - , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@) - - -- the following get cleared for every function (see @withClearVars@) - , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type - , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude) - } - -type LlvmEnvMap = UniqFM LlvmType - --- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad -newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } - -instance Functor LlvmM where - fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env - return (f x, env') - -instance Applicative LlvmM where - pure x = LlvmM $ \env -> return (x, env) - (<*>) = ap - -instance Monad LlvmM where - m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env - runLlvmM (f x) env' - -instance HasDynFlags LlvmM where - getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) - -instance MonadUnique LlvmM where - getUniqueSupplyM = do - us <- getEnv envUniq - let (us1, us2) = splitUniqSupply us - modifyEnv (\s -> s { envUniq = us2 }) - return us1 - - getUniqueM = do - us <- getEnv envUniq - let (u,us') = takeUniqFromSupply us - modifyEnv (\s -> s { envUniq = us' }) - return u - --- | Lifting of IO actions. Not exported, as we want to encapsulate IO. -liftIO :: IO a -> LlvmM a -liftIO m = LlvmM $ \env -> do x <- m - return (x, env) - --- | Get initial Llvm environment. -runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO () -runLlvm dflags ver out us m = do - _ <- runLlvmM m env - return () - where env = LlvmEnv { envFunMap = emptyUFM - , envVarMap = emptyUFM - , envStackRegs = [] - , envUsedVars = [] - , envAliases = emptyUniqSet - , envVersion = ver - , envDynFlags = dflags - , envOutput = out - , envUniq = us - , envFreshMeta = MetaId 0 - , envUniqMeta = emptyUFM - } - --- | Get environment (internal) -getEnv :: (LlvmEnv -> a) -> LlvmM a -getEnv f = LlvmM (\env -> return (f env, env)) - --- | Modify environment (internal) -modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM () -modifyEnv f = LlvmM (\env -> return ((), f env)) - --- | Lift a stream into the LlvmM monad -liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x -liftStream s = Stream.Stream $ do - r <- liftIO $ Stream.runStream s - case r of - Left b -> return (Left b) - Right (a, r2) -> return (Right (a, liftStream r2)) - --- | Clear variables from the environment for a subcomputation -withClearVars :: LlvmM a -> LlvmM a -withClearVars m = LlvmM $ \env -> do - (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] } - return (x, env' { envVarMap = emptyUFM, envStackRegs = [] }) - --- | Insert variables or functions into the environment. -varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM () -varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t } -funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t } - --- | Lookup variables or functions in the environment. -varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType) -varLookup s = getEnv (flip lookupUFM s . envVarMap) -funLookup s = getEnv (flip lookupUFM s . envFunMap) - --- | Set a register as allocated on the stack -markStackReg :: GlobalReg -> LlvmM () -markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env } - --- | Check whether a register is allocated on the stack -checkStackReg :: GlobalReg -> LlvmM Bool -checkStackReg r = getEnv ((elem r) . envStackRegs) - --- | Allocate a new global unnamed metadata identifier -getMetaUniqueId :: LlvmM MetaId -getMetaUniqueId = LlvmM $ \env -> - return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env }) - --- | Get the LLVM version we are generating code for -getLlvmVer :: LlvmM LlvmVersion -getLlvmVer = getEnv envVersion - --- | Get the platform we are generating code for -getDynFlag :: (DynFlags -> a) -> LlvmM a -getDynFlag f = getEnv (f . envDynFlags) - --- | Get the platform we are generating code for -getLlvmPlatform :: LlvmM Platform -getLlvmPlatform = getDynFlag targetPlatform - --- | Dumps the document if the corresponding flag has been set by the user -dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM () -dumpIfSetLlvm flag hdr doc = do - dflags <- getDynFlags - liftIO $ dumpIfSet_dyn dflags flag hdr doc - --- | Prints the given contents to the output handle -renderLlvm :: Outp.SDoc -> LlvmM () -renderLlvm sdoc = do - - -- Write to output - dflags <- getDynFlags - out <- getEnv envOutput - liftIO $ Outp.bufLeftRenderSDoc dflags out - (Outp.mkCodeStyle Outp.CStyle) sdoc - - -- Dump, if requested - dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc - return () - --- | Marks a variable as "used" -markUsedVar :: LlvmVar -> LlvmM () -markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env } - --- | Return all variables marked as "used" so far -getUsedVars :: LlvmM [LlvmVar] -getUsedVars = getEnv envUsedVars - --- | Saves that at some point we didn't know the type of the label and --- generated a reference to a type variable instead -saveAlias :: LMString -> LlvmM () -saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl } - --- | Sets metadata node for a given unique -setUniqMeta :: Unique -> MetaId -> LlvmM () -setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m } - --- | Gets metadata node for given unique -getUniqMeta :: Unique -> LlvmM (Maybe MetaId) -getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta) - --- ---------------------------------------------------------------------------- --- * Internal functions --- - --- | Here we pre-initialise some functions that are used internally by GHC --- so as to make sure they have the most general type in the case that --- user code also uses these functions but with a different type than GHC --- internally. (Main offender is treating return type as 'void' instead of --- 'void *'). Fixes trac #5486. -ghcInternalFunctions :: LlvmM () -ghcInternalFunctions = do - dflags <- getDynFlags - mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] - mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] - mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags] - mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr] - where - mk n ret args = do - let n' = fsLit n `appendFS` fsLit "$def" - decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret - FixedArgs (tysToParams args) Nothing - renderLlvm $ ppLlvmFunctionDecl decl - funInsert n' (LMFunction decl) - --- ---------------------------------------------------------------------------- --- * Label handling --- - --- | Pretty print a 'CLabel'. -strCLabel_llvm :: CLabel -> LlvmM LMString -strCLabel_llvm lbl = do - platform <- getLlvmPlatform - dflags <- getDynFlags - let sdoc = pprCLabel platform lbl - str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle) - return (fsLit str) - -strDisplayName_llvm :: CLabel -> LlvmM LMString -strDisplayName_llvm lbl = do - platform <- getLlvmPlatform - dflags <- getDynFlags - let sdoc = pprCLabel platform lbl - depth = Outp.PartWay 1 - style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth - str = Outp.renderWithStyle dflags sdoc style - return (fsLit (dropInfoSuffix str)) - -dropInfoSuffix :: String -> String -dropInfoSuffix = go - where go "_info" = [] - go "_static_info" = [] - go "_con_info" = [] - go (x:xs) = x:go xs - go [] = [] - -strProcedureName_llvm :: CLabel -> LlvmM LMString -strProcedureName_llvm lbl = do - platform <- getLlvmPlatform - dflags <- getDynFlags - let sdoc = pprCLabel platform lbl - depth = Outp.PartWay 1 - style = Outp.mkUserStyle dflags Outp.neverQualify depth - str = Outp.renderWithStyle dflags sdoc style - return (fsLit str) - --- ---------------------------------------------------------------------------- --- * Global variables / forward references --- - --- | Create/get a pointer to a global value. Might return an alias if --- the value in question hasn't been defined yet. We especially make --- no guarantees on the type of the returned pointer. -getGlobalPtr :: LMString -> LlvmM LlvmVar -getGlobalPtr llvmLbl = do - m_ty <- funLookup llvmLbl - let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing - case m_ty of - -- Directly reference if we have seen it already - Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global - -- Otherwise use a forward alias of it - Nothing -> do - saveAlias llvmLbl - return $ mkGlbVar llvmLbl i8 Alias - --- | Generate definitions for aliases forward-referenced by @getGlobalPtr@. --- --- Must be called at a point where we are sure that no new global definitions --- will be generated anymore! -generateExternDecls :: LlvmM ([LMGlobal], [LlvmType]) -generateExternDecls = do - delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - defss <- flip mapM delayed $ \lbl -> do - m_ty <- funLookup lbl - case m_ty of - -- If we have a definition we've already emitted the proper aliases - -- when the symbol itself was emitted by @aliasify@ - Just _ -> return [] - - -- If we don't have a definition this is an external symbol and we - -- need to emit a declaration - Nothing -> - let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global - in return [LMGlobal var Nothing] - - -- Reset forward list - modifyEnv $ \env -> env { envAliases = emptyUniqSet } - return (concat defss, []) - --- | Here we take a global variable definition, rename it with a --- @$def@ suffix, and generate the appropriate alias. -aliasify :: LMGlobal -> LlvmM [LMGlobal] -aliasify (LMGlobal var val) = do - let i8Ptr = LMPointer (LMInt 8) - LMGlobalVar lbl ty link sect align const = var - - defLbl = lbl `appendFS` fsLit "$def" - defVar = LMGlobalVar defLbl ty Internal sect align const - - defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const - aliasVar = LMGlobalVar lbl (LMPointer i8Ptr) link Nothing Nothing Alias - aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr - - -- we need to mark the $def symbols as used so LLVM doesn't forget which - -- section they need to go in. This will vanish once we switch away from - -- mangling sections for TNTC. - markUsedVar defVar - - return [ LMGlobal defVar val - , LMGlobal aliasVar (Just aliasVal) - ] - --- Note [Llvm Forward References] --- --- The issue here is that LLVM insists on being strongly typed at --- every corner, so the first time we mention something, we have to --- settle what type we assign to it. That makes things awkward, as Cmm --- will often reference things before their definition, and we have no --- idea what (LLVM) type it is going to be before that point. --- --- Our work-around is to define "aliases" of a standard type (i8 *) in --- these kind of situations, which we later tell LLVM to be either --- references to their actual local definitions (involving a cast) or --- an external reference. This obviously only works for pointers. --- --- In particular when we encounter a reference to a symbol in a chunk of --- C-- there are three possible scenarios, --- --- 1. We have already seen a definition for the referenced symbol. This --- means we already know its type. --- --- 2. We have not yet seen a definition but we will find one later in this --- compilation unit. Since we want to be a good consumer of the --- C-- streamed to us from upstream, we don't know the type of the --- symbol at the time when we must emit the reference. --- --- 3. We have not yet seen a definition nor will we find one in this --- compilation unit. In this case the reference refers to an --- external symbol for which we do not know the type. --- --- Let's consider case (2) for a moment: say we see a reference to --- the symbol @fooBar@ for which we have not seen a definition. As we --- do not know the symbol's type, we assume it is of type @i8*@ and emit --- the appropriate casts in @getSymbolPtr@. Later on, when we --- encounter the definition of @fooBar@ we emit it but with a modified --- name, @fooBar$def@ (which we'll call the definition symbol), to --- since we have already had to assume that the symbol @fooBar@ --- is of type @i8*@. We then emit @fooBar@ itself as an alias --- of @fooBar$def@ with appropriate casts. This all happens in --- @aliasify@. --- --- Case (3) is quite similar to (2): References are emitted assuming --- the referenced symbol is of type @i8*@. When we arrive at the end of --- the compilation unit and realize that the symbol is external, we emit --- an LLVM @external global@ declaration for the symbol @fooBar@ --- (handled in @generateExternDecls@). This takes advantage of the --- fact that the aliases produced by @aliasify@ for exported symbols --- have external linkage and can therefore be used as normal symbols. --- --- Historical note: As of release 3.5 LLVM does not allow aliases to --- refer to declarations. This the reason why aliases are produced at the --- point of definition instead of the point of usage, as was previously --- done. See #9142 for details. --- --- Finally, case (1) is trival. As we already have a definition for --- and therefore know the type of the referenced symbol, we can do --- away with casting the alias to the desired type in @getSymbolPtr@ --- and instead just emit a reference to the definition symbol directly. --- This is the @Just@ case in @getSymbolPtr@. diff --git a/llvmGen/LlvmCodeGen/CodeGen.hs b/llvmGen/LlvmCodeGen/CodeGen.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen/CodeGen.hs +++ /dev/null @@ -1,1912 +0,0 @@ -{-# LANGUAGE CPP, GADTs #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} --- ---------------------------------------------------------------------------- --- | Handle conversion of CmmProc to LLVM code. --- -module LlvmCodeGen.CodeGen ( genLlvmProc ) where - -#include "HsVersions.h" - -import Llvm -import LlvmCodeGen.Base -import LlvmCodeGen.Regs - -import BlockId -import CodeGen.Platform ( activeStgRegs, callerSaves ) -import CLabel -import Cmm -import PprCmm -import CmmUtils -import CmmSwitch -import Hoopl - -import DynFlags -import FastString -import ForeignCall -import Outputable hiding (panic, pprPanic) -import qualified Outputable -import Platform -import OrdList -import UniqSupply -import Unique -import Util - -import Control.Monad.Trans.Class -import Control.Monad.Trans.Writer - -#if __GLASGOW_HASKELL__ > 710 -import Data.Semigroup ( Semigroup ) -import qualified Data.Semigroup as Semigroup -#endif -import Data.List ( nub ) -import Data.Maybe ( catMaybes ) - -type Atomic = Bool -type LlvmStatements = OrdList LlvmStatement - --- ----------------------------------------------------------------------------- --- | Top-level of the LLVM proc Code generator --- -genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] -genLlvmProc (CmmProc infos lbl live graph) = do - let blocks = toBlockListEntryFirstFalseFallthrough graph - (lmblocks, lmdata) <- basicBlocksCodeGen live blocks - let info = mapLookup (g_entry graph) infos - proc = CmmProc info lbl live (ListGraph lmblocks) - return (proc:lmdata) - -genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!" - --- ----------------------------------------------------------------------------- --- * Block code generation --- - --- | Generate code for a list of blocks that make up a complete --- procedure. The first block in the list is exepected to be the entry --- point and will get the prologue. -basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock] - -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) -basicBlocksCodeGen _ [] = panic "no entry block!" -basicBlocksCodeGen live (entryBlock:cmmBlocks) - = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks) - - -- Generate code - (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock - (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks - - -- Compose - let entryBlock = BasicBlock bid (fromOL prologue ++ entry) - return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss) - - --- | Generate code for one block -basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] ) -basicBlockCodeGen block - = do let (_, nodes, tail) = blockSplit block - id = entryLabel block - (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes - (tail_instrs, top') <- stmtToInstrs tail - let instrs = fromOL (mid_instrs `appOL` tail_instrs) - return (BasicBlock id instrs, top' ++ top) - --- ----------------------------------------------------------------------------- --- * CmmNode code generation --- - --- A statement conversion return data. --- * LlvmStatements: The compiled LLVM statements. --- * LlvmCmmDecl: Any global data needed. -type StmtData = (LlvmStatements, [LlvmCmmDecl]) - - --- | Convert a list of CmmNode's to LlvmStatement's -stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData -stmtsToInstrs stmts - = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts - return (concatOL instrss, concat topss) - - --- | Convert a CmmStmt to a list of LlvmStatement's -stmtToInstrs :: CmmNode e x -> LlvmM StmtData -stmtToInstrs stmt = case stmt of - - CmmComment _ -> return (nilOL, []) -- nuke comments - CmmTick _ -> return (nilOL, []) - CmmUnwind {} -> return (nilOL, []) - - CmmAssign reg src -> genAssign reg src - CmmStore addr src -> genStore addr src - - CmmBranch id -> genBranch id - CmmCondBranch arg true false likely - -> genCondBranch arg true false likely - CmmSwitch arg ids -> genSwitch arg ids - - -- Foreign Call - CmmUnsafeForeignCall target res args - -> genCall target res args - - -- Tail call - CmmCall { cml_target = arg, - cml_args_regs = live } -> genJump arg live - - _ -> panic "Llvm.CodeGen.stmtToInstrs" - --- | Wrapper function to declare an instrinct function by function type -getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData -getInstrinct2 fname fty@(LMFunction funSig) = do - - let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant - - fn <- funLookup fname - tops <- case fn of - Just _ -> - return [] - Nothing -> do - funInsert fname fty - un <- getUniqueM - let lbl = mkAsmTempLabel un - return [CmmData (Section Data lbl) [([],[fty])]] - - return (fv, nilOL, tops) - -getInstrinct2 _ _ = error "getInstrinct2: Non-function type!" - --- | Declares an instrinct function by return and parameter types -getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData -getInstrinct fname retTy parTys = - let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy - FixedArgs (tysToParams parTys) Nothing - fty = LMFunction funSig - in getInstrinct2 fname fty - --- | Memory barrier instruction for LLVM >= 3.0 -barrier :: LlvmM StmtData -barrier = do - let s = Fence False SyncSeqCst - return (unitOL s, []) - --- | Foreign Calls -genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData - --- Write barrier needs to be handled specially as it is implemented as an LLVM --- intrinsic function. -genCall (PrimTarget MO_WriteBarrier) _ _ = do - platform <- getLlvmPlatform - if platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC] - then return (nilOL, []) - else barrier - -genCall (PrimTarget MO_Touch) _ _ - = return (nilOL, []) - -genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do - dstV <- getCmmRegW (CmmLocal dst) - let ty = cmmToLlvmType $ localRegType dst - width = widthToLlvmFloat w - castV <- lift $ mkLocalVar ty - ve <- exprToVarW e - statement $ Assignment castV $ Cast LM_Uitofp ve width - statement $ Store castV dstV - -genCall (PrimTarget (MO_UF_Conv _)) [_] args = - panic $ "genCall: Too many arguments to MO_UF_Conv. " ++ - "Can only handle 1, given" ++ show (length args) ++ "." - --- Handle prefetching data -genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args - | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ do - let argTy = [i8Ptr, i32, i32, i32] - funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible - CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing - - let (_, arg_hints) = foreignTargetHints t - let args_hints' = zip args arg_hints - argVars <- arg_varsW args_hints' ([], nilOL, []) - fptr <- liftExprData $ getFunPtr funTy t - argVars' <- castVarsW $ zip argVars argTy - - doTrashStmts - let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1] - statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] - | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) - --- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg --- and return types -genCall t@(PrimTarget (MO_PopCnt w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_Clz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_Ctz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_BSwap w)) dsts args = - genCallSimpleCast w t dsts args - -genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do - addrVar <- exprToVarW addr - nVar <- exprToVarW n - let targetTy = widthToLlvmInt width - ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) - ptrVar <- doExprW (pLift targetTy) ptrExpr - dstVar <- getCmmRegW (CmmLocal dst) - let op = case amop of - AMO_Add -> LAO_Add - AMO_Sub -> LAO_Sub - AMO_And -> LAO_And - AMO_Nand -> LAO_Nand - AMO_Or -> LAO_Or - AMO_Xor -> LAO_Xor - retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst - statement $ Store retVar dstVar - -genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do - dstV <- getCmmRegW (CmmLocal dst) - v1 <- genLoadW True addr (localRegType dst) - statement $ Store v1 dstV - -genCall (PrimTarget (MO_Cmpxchg _width)) - [dst] [addr, old, new] = runStmtsDecls $ do - addrVar <- exprToVarW addr - oldVar <- exprToVarW old - newVar <- exprToVarW new - let targetTy = getVarType oldVar - ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) - ptrVar <- doExprW (pLift targetTy) ptrExpr - dstVar <- getCmmRegW (CmmLocal dst) - retVar <- doExprW (LMStructU [targetTy,i1]) - $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst - retVar' <- doExprW targetTy $ ExtractV retVar 0 - statement $ Store retVar' dstVar - -genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do - addrVar <- exprToVarW addr - valVar <- exprToVarW val - let ptrTy = pLift $ getVarType valVar - ptrExpr = Cast LM_Inttoptr addrVar ptrTy - ptrVar <- doExprW ptrTy ptrExpr - statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst - --- Handle memcpy function specifically since llvm's intrinsic version takes --- some extra parameters. -genCall t@(PrimTarget op) [] args - | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do - dflags <- getDynFlags - let isVolTy = [i1] - isVolVal = [mkIntLit i1 0] - argTy | MO_Memset _ <- op = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy - | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy - funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible - CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing - - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - argVars <- arg_varsW args_hints ([], nilOL, []) - fptr <- getFunPtrW funTy t - argVars' <- castVarsW $ zip argVars argTy - - doTrashStmts - let alignVal = mkIntLit i32 align - arguments = argVars' ++ (alignVal:isVolVal) - statement $ Expr $ Call StdCall fptr arguments [] - --- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands --- twice the width (we first zero-extend them), e.g., on 64-bit arch we will --- generate 'mul' on 128-bit operands. Then we only need some plumbing to --- extract the two 64-bit values out of 128-bit result. -genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do - let width = widthToLlvmInt w - bitWidth = widthInBits w - width2x = LMInt (bitWidth * 2) - -- First zero-extend the operands ('mul' instruction requires the operands - -- and the result to be of the same type). Note that we don't use 'castVars' - -- because it tries to do LM_Sext. - lhsVar <- exprToVarW lhs - rhsVar <- exprToVarW rhs - lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x - rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x - -- Do the actual multiplication (note that the result is also 2x width). - retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt - -- Extract the lower bits of the result into retL. - retL <- doExprW width $ Cast LM_Trunc retV width - -- Now we right-shift the higher bits by width. - let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width - retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit - -- And extract them into retH. - retH <- doExprW width $ Cast LM_Trunc retShifted width - dstRegL <- getCmmRegW (CmmLocal dstL) - dstRegH <- getCmmRegW (CmmLocal dstH) - statement $ Store retL dstRegL - statement $ Store retH dstRegH - --- MO_U_QuotRem2 is another case we handle by widening the registers to double --- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The --- main difference here is that we need to combine two words into one register --- and then use both 'udiv' and 'urem' instructions to compute the result. -genCall (PrimTarget (MO_U_QuotRem2 w)) - [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do - let width = widthToLlvmInt w - bitWidth = widthInBits w - width2x = LMInt (bitWidth * 2) - -- First zero-extend all parameters to double width. - let zeroExtend expr = do - var <- exprToVarW expr - doExprW width2x $ Cast LM_Zext var width2x - lhsExtH <- zeroExtend lhsH - lhsExtL <- zeroExtend lhsL - rhsExt <- zeroExtend rhs - -- Now we combine the first two parameters (that represent the high and low - -- bits of the value). So first left-shift the high bits to their position - -- and then bit-or them with the low bits. - let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width - lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit - lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL - -- Finally, we can call 'udiv' and 'urem' to compute the results. - retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt - retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt - -- And since everything is in 2x width, we need to truncate the results and - -- then return them. - let narrow var = doExprW width $ Cast LM_Trunc var width - retDiv <- narrow retExtDiv - retRem <- narrow retExtRem - dstRegQ <- lift $ getCmmReg (CmmLocal dstQ) - dstRegR <- lift $ getCmmReg (CmmLocal dstR) - statement $ Store retDiv dstRegQ - statement $ Store retRem dstRegR - --- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from --- which we need to extract the actual values. -genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] = - genCallWithOverflow t w [dstV, dstO] [lhs, rhs] -genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] = - genCallWithOverflow t w [dstV, dstO] [lhs, rhs] - --- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the --- return tuple to be the overflow bit and the second element to contain the --- actual result of the addition. So we still use genCallWithOverflow but swap --- the return registers. -genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] = - genCallWithOverflow t w [dstV, dstO] [lhs, rhs] - -genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] = - genCallWithOverflow t w [dstV, dstO] [lhs, rhs] - --- Handle all other foreign calls and prim ops. -genCall target res args = runStmtsDecls $ do - dflags <- getDynFlags - - -- parameter types - let arg_type (_, AddrHint) = i8Ptr - -- cast pointers to i8*. Llvm equivalent of void* - arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr - - -- ret type - let ret_type [] = LMVoid - ret_type [(_, AddrHint)] = i8Ptr - ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg - ret_type t = panic $ "genCall: Too many return values! Can only handle" - ++ " 0 or 1, given " ++ show (length t) ++ "." - - -- extract Cmm call convention, and translate to LLVM call convention - platform <- lift $ getLlvmPlatform - let lmconv = case target of - ForeignTarget _ (ForeignConvention conv _ _ _) -> - case conv of - StdCallConv -> case platformArch platform of - ArchX86 -> CC_X86_Stdcc - ArchX86_64 -> CC_X86_Stdcc - _ -> CC_Ccc - CCallConv -> CC_Ccc - CApiConv -> CC_Ccc - PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv" - JavaScriptCallConv -> panic "LlvmCodeGen.CodeGen.genCall: JavaScriptCallConv" - - PrimTarget _ -> CC_Ccc - - {- - CC_Ccc of the possibilities here are a worry with the use of a custom - calling convention for passing STG args. In practice the more - dangerous combinations (e.g StdCall + llvmGhcCC) don't occur. - - The native code generator only handles StdCall and CCallConv. - -} - - -- call attributes - let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs - | otherwise = llvmStdFunAttrs - - never_returns = case target of - ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True - _ -> False - - -- fun type - let (res_hints, arg_hints) = foreignTargetHints target - let args_hints = zip args arg_hints - let ress_hints = zip res res_hints - let ccTy = StdCall -- tail calls should be done through CmmJump - let retTy = ret_type ress_hints - let argTy = tysToParams $ map arg_type args_hints - let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible - lmconv retTy FixedArgs argTy (llvmFunAlign dflags) - - - argVars <- arg_varsW args_hints ([], nilOL, []) - fptr <- getFunPtrW funTy target - - let doReturn | ccTy == TailCall = statement $ Return Nothing - | never_returns = statement $ Unreachable - | otherwise = return () - - doTrashStmts - - -- make the actual call - case retTy of - LMVoid -> do - statement $ Expr $ Call ccTy fptr argVars fnAttrs - - _ -> do - v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs - -- get the return register - let ret_reg [reg] = reg - ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" - ++ " 1, given " ++ show (length t) ++ "." - let creg = ret_reg res - vreg <- getCmmRegW (CmmLocal creg) - if retTy == pLower (getVarType vreg) - then do - statement $ Store v1 vreg - doReturn - else do - let ty = pLower $ getVarType vreg - let op = case ty of - vt | isPointer vt -> LM_Bitcast - | isInt vt -> LM_Ptrtoint - | otherwise -> - panic $ "genCall: CmmReg bad match for" - ++ " returned type!" - - v2 <- doExprW ty $ Cast op v1 ty - statement $ Store v2 vreg - doReturn - --- | Generate a call to an LLVM intrinsic that performs arithmetic operation --- with overflow bit (i.e., returns a struct containing the actual result of the --- operation and an overflow bit). This function will also extract the overflow --- bit and zero-extend it (all the corresponding Cmm PrimOps represent the --- overflow "bit" as a usual Int# or Word#). -genCallWithOverflow - :: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData -genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do - -- So far this was only tested for the following four CallishMachOps. - let valid = op `elem` [ MO_Add2 w - , MO_AddIntC w - , MO_SubIntC w - , MO_SubWordC w - ] - MASSERT(valid) - let width = widthToLlvmInt w - -- This will do most of the work of generating the call to the intrinsic and - -- extracting the values from the struct. - (value, overflowBit, (stmts, top)) <- - genCallExtract t w (lhs, rhs) (width, i1) - -- value is i, but overflowBit is i1, so we need to cast (Cmm expects - -- both to be i) - (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width - dstRegV <- getCmmReg (CmmLocal dstV) - dstRegO <- getCmmReg (CmmLocal dstO) - let storeV = Store value dstRegV - storeO = Store overflow dstRegO - return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top) -genCallWithOverflow _ _ _ _ = - panic "genCallExtract: wrong ForeignTarget or number of arguments" - --- | A helper function for genCallWithOverflow that handles generating the call --- to the LLVM intrinsic and extracting the result from the struct to LlvmVars. -genCallExtract - :: ForeignTarget -- ^ PrimOp - -> Width -- ^ Width of the operands. - -> (CmmActual, CmmActual) -- ^ Actual arguments. - -> (LlvmType, LlvmType) -- ^ LLLVM types of the returned sturct. - -> LlvmM (LlvmVar, LlvmVar, StmtData) -genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do - let width = widthToLlvmInt w - argTy = [width, width] - retTy = LMStructU [llvmTypeA, llvmTypeB] - - -- Process the arguments. - let args_hints = zip [argA, argB] (snd $ foreignTargetHints target) - (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, []) - (argsV2, args2) <- castVars $ zip argsV1 argTy - - -- Get the function and make the call. - fname <- cmmPrimOpFunctions op - (fptr, _, top2) <- getInstrinct fname retTy argTy - -- We use StdCall for primops. See also the last case of genCall. - (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 [] - - -- This will result in a two element struct, we need to use "extractvalue" - -- to get them out of it. - (res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0) - (res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1) - - let stmts = args1 `appOL` args2 `snocOL` call `snocOL` ext1 `snocOL` ext2 - tops = top1 ++ top2 - return (res1, res2, (stmts, tops)) - -genCallExtract _ _ _ _ = - panic "genCallExtract: unsupported ForeignTarget" - --- Handle simple function call that only need simple type casting, of the form: --- truncate arg >>= \a -> call(a) >>= zext --- --- since GHC only really has i32 and i64 types and things like Word8 are backed --- by an i32 and just present a logical i8 range. So we must handle conversions --- from i32 to i8 explicitly as LLVM is strict about types. -genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData -genCallSimpleCast w t@(PrimTarget op) [dst] args = do - let width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - - fname <- cmmPrimOpFunctions op - (fptr, _, top3) <- getInstrinct fname width [width] - - dstV <- getCmmReg (CmmLocal dst) - - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) - (argsV', stmts4) <- castVars $ zip argsV [width] - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - ([retV'], stmts5) <- castVars [(retV,dstTy)] - let s2 = Store retV' dstV - - let stmts = stmts2 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 - return (stmts, top2 ++ top3) -genCallSimpleCast _ _ dsts _ = - panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") - --- | Create a function pointer from a target. -getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget - -> WriterT LlvmAccum LlvmM LlvmVar -getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ - --- | Create a function pointer from a target. -getFunPtr :: (LMString -> LlvmType) -> ForeignTarget - -> LlvmM ExprData -getFunPtr funTy targ = case targ of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do - name <- strCLabel_llvm lbl - getHsFunc' name (funTy name) - - ForeignTarget expr _ -> do - (v1, stmts, top) <- exprToVar expr - dflags <- getDynFlags - let fty = funTy $ fsLit "dynamic" - cast = case getVarType v1 of - ty | isPointer ty -> LM_Bitcast - ty | isInt ty -> LM_Inttoptr - - ty -> panic $ "genCall: Expr is of bad type for function" - ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")" - - (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) - return (v2, stmts `snocOL` s1, top) - - PrimTarget mop -> do - name <- cmmPrimOpFunctions mop - let fty = funTy name - getInstrinct2 name fty - --- | Conversion of call arguments. -arg_varsW :: [(CmmActual, ForeignHint)] - -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -> WriterT LlvmAccum LlvmM [LlvmVar] -arg_varsW xs ys = do - (vars, stmts, decls) <- lift $ arg_vars xs ys - tell $ LlvmAccum stmts decls - return vars - --- | Conversion of call arguments. -arg_vars :: [(CmmActual, ForeignHint)] - -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -arg_vars [] (vars, stmts, tops) - = return (vars, stmts, tops) - -arg_vars ((e, AddrHint):rest) (vars, stmts, tops) - = do (v1, stmts', top') <- exprToVar e - dflags <- getDynFlags - let op = case getVarType v1 of - ty | isPointer ty -> LM_Bitcast - ty | isInt ty -> LM_Inttoptr - - a -> panic $ "genCall: Can't cast llvmType to i8*! (" - ++ showSDoc dflags (ppr a) ++ ")" - - (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr - arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, - tops ++ top') - -arg_vars ((e, _):rest) (vars, stmts, tops) - = do (v1, stmts', top') <- exprToVar e - arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') - - --- | Cast a collection of LLVM variables to specific types. -castVarsW :: [(LlvmVar, LlvmType)] - -> WriterT LlvmAccum LlvmM [LlvmVar] -castVarsW vars = do - (vars, stmts) <- lift $ castVars vars - tell $ LlvmAccum stmts mempty - return vars - --- | Cast a collection of LLVM variables to specific types. -castVars :: [(LlvmVar, LlvmType)] - -> LlvmM ([LlvmVar], LlvmStatements) -castVars vars = do - done <- mapM (uncurry castVar) vars - let (vars', stmts) = unzip done - return (vars', toOL stmts) - --- | Cast an LLVM variable to a specific type, panicing if it can't be done. -castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement) -castVar v t | getVarType v == t - = return (v, Nop) - - | otherwise - = do dflags <- getDynFlags - let op = case (getVarType v, t) of - (LMInt n, LMInt m) - -> if n < m then LM_Sext else LM_Trunc - (vt, _) | isFloat vt && isFloat t - -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t - then LM_Fpext else LM_Fptrunc - (vt, _) | isInt vt && isFloat t -> LM_Sitofp - (vt, _) | isFloat vt && isInt t -> LM_Fptosi - (vt, _) | isInt vt && isPointer t -> LM_Inttoptr - (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint - (vt, _) | isPointer vt && isPointer t -> LM_Bitcast - (vt, _) | isVector vt && isVector t -> LM_Bitcast - - (vt, _) -> panic $ "castVars: Can't cast this type (" - ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")" - doExpr t $ Cast op v t - - --- | Decide what C function to use to implement a CallishMachOp -cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString -cmmPrimOpFunctions mop = do - - dflags <- getDynFlags - let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags) - intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags) - unsupported = panic ("cmmPrimOpFunctions: " ++ show mop - ++ " not supported here") - - return $ case mop of - MO_F32_Exp -> fsLit "expf" - MO_F32_Log -> fsLit "logf" - MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" - MO_F32_Fabs -> fsLit "llvm.fabs.f32" - MO_F32_Pwr -> fsLit "llvm.pow.f32" - - MO_F32_Sin -> fsLit "llvm.sin.f32" - MO_F32_Cos -> fsLit "llvm.cos.f32" - MO_F32_Tan -> fsLit "tanf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - - MO_F64_Exp -> fsLit "exp" - MO_F64_Log -> fsLit "log" - MO_F64_Sqrt -> fsLit "llvm.sqrt.f64" - MO_F64_Fabs -> fsLit "llvm.fabs.f64" - MO_F64_Pwr -> fsLit "llvm.pow.f64" - - MO_F64_Sin -> fsLit "llvm.sin.f64" - MO_F64_Cos -> fsLit "llvm.cos.f64" - MO_F64_Tan -> fsLit "tan" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - - MO_Memcpy _ -> fsLit $ "llvm.memcpy." ++ intrinTy1 - MO_Memmove _ -> fsLit $ "llvm.memmove." ++ intrinTy1 - MO_Memset _ -> fsLit $ "llvm.memset." ++ intrinTy2 - - (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w) - (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w) - (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) - (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) - - (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch" - - MO_AddIntC w -> fsLit $ "llvm.sadd.with.overflow." - ++ showSDoc dflags (ppr $ widthToLlvmInt w) - MO_SubIntC w -> fsLit $ "llvm.ssub.with.overflow." - ++ showSDoc dflags (ppr $ widthToLlvmInt w) - MO_Add2 w -> fsLit $ "llvm.uadd.with.overflow." - ++ showSDoc dflags (ppr $ widthToLlvmInt w) - MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow." - ++ showSDoc dflags (ppr $ widthToLlvmInt w) - - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the - -- appropriate case of genCall. - MO_U_Mul2 {} -> unsupported - MO_WriteBarrier -> unsupported - MO_Touch -> unsupported - MO_UF_Conv _ -> unsupported - - MO_AtomicRead _ -> unsupported - MO_AtomicRMW _ _ -> unsupported - MO_AtomicWrite _ -> unsupported - MO_Cmpxchg _ -> unsupported - --- | Tail function calls -genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData - --- Call to known function -genJump (CmmLit (CmmLabel lbl)) live = do - (vf, stmts, top) <- getHsFunc live lbl - (stgRegs, stgStmts) <- funEpilogue live - let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs - let s2 = Return Nothing - return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) - - --- Call to unknown function / address -genJump expr live = do - fty <- llvmFunTy live - (vf, stmts, top) <- exprToVar expr - dflags <- getDynFlags - - let cast = case getVarType vf of - ty | isPointer ty -> LM_Bitcast - ty | isInt ty -> LM_Inttoptr - - ty -> panic $ "genJump: Expr is of bad type for function call! (" - ++ showSDoc dflags (ppr ty) ++ ")" - - (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) - (stgRegs, stgStmts) <- funEpilogue live - let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs - let s3 = Return Nothing - return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, - top) - - --- | CmmAssign operation --- --- We use stack allocated variables for CmmReg. The optimiser will replace --- these with registers when possible. -genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData -genAssign reg val = do - vreg <- getCmmReg reg - (vval, stmts2, top2) <- exprToVar val - let stmts = stmts2 - - let ty = (pLower . getVarType) vreg - dflags <- getDynFlags - case ty of - -- Some registers are pointer types, so need to cast value to pointer - LMPointer _ | getVarType vval == llvmWord dflags -> do - (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = Store v vreg - return (stmts `snocOL` s1 `snocOL` s2, top2) - - LMVector _ _ -> do - (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty - let s2 = Store v vreg - return (stmts `snocOL` s1 `snocOL` s2, top2) - - _ -> do - let s1 = Store vval vreg - return (stmts `snocOL` s1, top2) - - --- | CmmStore operation -genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData - --- First we try to detect a few common cases and produce better code for --- these then the default case. We are mostly trying to detect Cmm code --- like I32[Sp + n] and use 'getelementptr' operations instead of the --- generic case that uses casts and pointer arithmetic -genStore addr@(CmmReg (CmmGlobal r)) val - = genStore_fast addr r 0 val - -genStore addr@(CmmRegOff (CmmGlobal r) n) val - = genStore_fast addr r n val - -genStore addr@(CmmMachOp (MO_Add _) [ - (CmmReg (CmmGlobal r)), - (CmmLit (CmmInt n _))]) - val - = genStore_fast addr r (fromInteger n) val - -genStore addr@(CmmMachOp (MO_Sub _) [ - (CmmReg (CmmGlobal r)), - (CmmLit (CmmInt n _))]) - val - = genStore_fast addr r (negate $ fromInteger n) val - --- generic case -genStore addr val - = getTBAAMeta topN >>= genStore_slow addr val - --- | CmmStore operation --- This is a special case for storing to a global register pointer --- offset such as I32[Sp+8]. -genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr - -> LlvmM StmtData -genStore_fast addr r n val - = do dflags <- getDynFlags - (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - meta <- getTBAARegMeta r - let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - case isPointer grt && rem == 0 of - True -> do - (vval, stmts, top) <- exprToVar val - (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] - -- We might need a different pointer type, so check - case pLower grt == getVarType vval of - -- were fine - True -> do - let s3 = MetaStmt meta $ Store vval ptr - return (stmts `appOL` s1 `snocOL` s2 - `snocOL` s3, top) - - -- cast to pointer type needed - False -> do - let ty = (pLift . getVarType) vval - (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty - let s4 = MetaStmt meta $ Store vval ptr' - return (stmts `appOL` s1 `snocOL` s2 - `snocOL` s3 `snocOL` s4, top) - - -- If its a bit type then we use the slow method since - -- we can't avoid casting anyway. - False -> genStore_slow addr val meta - - --- | CmmStore operation --- Generic case. Uses casts and pointer arithmetic if needed. -genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData -genStore_slow addr val meta = do - (vaddr, stmts1, top1) <- exprToVar addr - (vval, stmts2, top2) <- exprToVar val - - let stmts = stmts1 `appOL` stmts2 - dflags <- getDynFlags - case getVarType vaddr of - -- sometimes we need to cast an int to a pointer before storing - LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do - (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = MetaStmt meta $ Store v vaddr - return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) - - LMPointer _ -> do - let s1 = MetaStmt meta $ Store vval vaddr - return (stmts `snocOL` s1, top1 ++ top2) - - i@(LMInt _) | i == llvmWord dflags -> do - let vty = pLift $ getVarType vval - (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty - let s2 = MetaStmt meta $ Store vval vptr - return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) - - other -> - pprPanic "genStore: ptr not right type!" - (PprCmm.pprExpr addr <+> text ( - "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ - ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ - ", Var: " ++ showSDoc dflags (ppr vaddr))) - - --- | Unconditional branch -genBranch :: BlockId -> LlvmM StmtData -genBranch id = - let label = blockIdToLlvm id - in return (unitOL $ Branch label, []) - - --- | Conditional branch -genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData -genCondBranch cond idT idF likely = do - let labelT = blockIdToLlvm idT - let labelF = blockIdToLlvm idF - -- See Note [Literals and branch conditions]. - (vc, stmts1, top1) <- exprToVarOpt i1Option cond - if getVarType vc == i1 - then do - (vc', (stmts2, top2)) <- case likely of - Just b -> genExpectLit (if b then 1 else 0) i1 vc - _ -> pure (vc, (nilOL, [])) - let s1 = BranchIf vc' labelT labelF - return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) - else do - dflags <- getDynFlags - panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")" - - --- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var. -genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData) -genExpectLit expLit expTy var = do - dflags <- getDynFlags - - let - lit = LMLitVar $ LMIntLit expLit expTy - - llvmExpectName - | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy) - | otherwise = panic $ "genExpectedLit: Type not an int!" - - (llvmExpect, stmts, top) <- - getInstrinct llvmExpectName expTy [expTy, expTy] - (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] [] - return (var', (stmts `snocOL` call, top)) - -{- Note [Literals and branch conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -It is important that whenever we generate branch conditions for -literals like '1', they are properly narrowed to an LLVM expression of -type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert -a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt -must be certain to return a properly narrowed type. genLit is -responsible for this, in the case of literal integers. - -Often, we won't see direct statements like: - - if(1) { - ... - } else { - ... - } - -at this point in the pipeline, because the Glorious Code Generator -will do trivial branch elimination in the sinking pass (among others,) -which will eliminate the expression entirely. - -However, it's certainly possible and reasonable for this to occur in -hand-written C-- code. Consider something like: - - #ifndef SOME_CONDITIONAL - #define CHECK_THING(x) 1 - #else - #define CHECK_THING(x) some_operation((x)) - #endif - - f() { - - if (CHECK_THING(xyz)) { - ... - } else { - ... - } - - } - -In such an instance, CHECK_THING might result in an *expression* in -one case, and a *literal* in the other, depending on what in -particular was #define'd. So we must be sure to properly narrow the -literal in this case to i1 as it won't be eliminated beforehand. - -For a real example of this, see ./rts/StgStdThunks.cmm - --} - - - --- | Switch branch -genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData -genSwitch cond ids = do - (vc, stmts, top) <- exprToVar cond - let ty = getVarType vc - - let labels = [ (mkIntLit ty ix, blockIdToLlvm b) - | (ix, b) <- switchTargetsCases ids ] - -- out of range is undefined, so let's just branch to first label - let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l - | otherwise = snd (head labels) - - let s1 = Switch vc defLbl labels - return $ (stmts `snocOL` s1, top) - - --- ----------------------------------------------------------------------------- --- * CmmExpr code generation --- - --- | An expression conversion return data: --- * LlvmVar: The var holding the result of the expression --- * LlvmStatements: Any statements needed to evaluate the expression --- * LlvmCmmDecl: Any global data needed for this expression -type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl]) - --- | Values which can be passed to 'exprToVar' to configure its --- behaviour in certain circumstances. --- --- Currently just used for determining if a comparison should return --- a boolean (i1) or a word. See Note [Literals and branch conditions]. -newtype EOption = EOption { i1Expected :: Bool } --- XXX: EOption is an ugly and inefficient solution to this problem. - --- | i1 type expected (condition scrutinee). -i1Option :: EOption -i1Option = EOption True - --- | Word type expected (usual). -wordOption :: EOption -wordOption = EOption False - --- | Convert a CmmExpr to a list of LlvmStatements with the result of the --- expression being stored in the returned LlvmVar. -exprToVar :: CmmExpr -> LlvmM ExprData -exprToVar = exprToVarOpt wordOption - -exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData -exprToVarOpt opt e = case e of - - CmmLit lit - -> genLit opt lit - - CmmLoad e' ty - -> genLoad False e' ty - - -- Cmmreg in expression is the value, so must load. If you want actual - -- reg pointer, call getCmmReg directly. - CmmReg r -> do - (v1, ty, s1) <- getCmmRegVal r - case isPointer ty of - True -> do - -- Cmm wants the value, so pointer types must be cast to ints - dflags <- getDynFlags - (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags) - return (v2, s1 `snocOL` s2, []) - - False -> return (v1, s1, []) - - CmmMachOp op exprs - -> genMachOp opt op exprs - - CmmRegOff r i - -> do dflags <- getDynFlags - exprToVar $ expandCmmReg dflags (r, i) - - CmmStackSlot _ _ - -> panic "exprToVar: CmmStackSlot not supported!" - - --- | Handle CmmMachOp expressions -genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData - --- Unary Machop -genMachOp _ op [x] = case op of - - MO_Not w -> - let all1 = mkIntLit (widthToLlvmInt w) (-1) - in negate (widthToLlvmInt w) all1 LM_MO_Xor - - MO_S_Neg w -> - let all0 = mkIntLit (widthToLlvmInt w) 0 - in negate (widthToLlvmInt w) all0 LM_MO_Sub - - MO_F_Neg w -> - let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w) - in negate (widthToLlvmFloat w) all0 LM_MO_FSub - - MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp - MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi - - MO_SS_Conv from to - -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext - - MO_UU_Conv from to - -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext - - MO_FF_Conv from to - -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext - - MO_VS_Neg len w -> - let ty = widthToLlvmInt w - vecty = LMVector len ty - all0 = LMIntLit (-0) ty - all0s = LMLitVar $ LMVectorLit (replicate len all0) - in negateVec vecty all0s LM_MO_Sub - - MO_VF_Neg len w -> - let ty = widthToLlvmFloat w - vecty = LMVector len ty - all0 = LMFloatLit (-0) ty - all0s = LMLitVar $ LMVectorLit (replicate len all0) - in negateVec vecty all0s LM_MO_FSub - - -- Handle unsupported cases explicitly so we get a warning - -- of missing case when new MachOps added - MO_Add _ -> panicOp - MO_Mul _ -> panicOp - MO_Sub _ -> panicOp - MO_S_MulMayOflo _ -> panicOp - MO_S_Quot _ -> panicOp - MO_S_Rem _ -> panicOp - MO_U_MulMayOflo _ -> panicOp - MO_U_Quot _ -> panicOp - MO_U_Rem _ -> panicOp - - MO_Eq _ -> panicOp - MO_Ne _ -> panicOp - MO_S_Ge _ -> panicOp - MO_S_Gt _ -> panicOp - MO_S_Le _ -> panicOp - MO_S_Lt _ -> panicOp - MO_U_Ge _ -> panicOp - MO_U_Gt _ -> panicOp - MO_U_Le _ -> panicOp - MO_U_Lt _ -> panicOp - - MO_F_Add _ -> panicOp - MO_F_Sub _ -> panicOp - MO_F_Mul _ -> panicOp - MO_F_Quot _ -> panicOp - MO_F_Eq _ -> panicOp - MO_F_Ne _ -> panicOp - MO_F_Ge _ -> panicOp - MO_F_Gt _ -> panicOp - MO_F_Le _ -> panicOp - MO_F_Lt _ -> panicOp - - MO_And _ -> panicOp - MO_Or _ -> panicOp - MO_Xor _ -> panicOp - MO_Shl _ -> panicOp - MO_U_Shr _ -> panicOp - MO_S_Shr _ -> panicOp - - MO_V_Insert _ _ -> panicOp - MO_V_Extract _ _ -> panicOp - - MO_V_Add _ _ -> panicOp - MO_V_Sub _ _ -> panicOp - MO_V_Mul _ _ -> panicOp - - MO_VS_Quot _ _ -> panicOp - MO_VS_Rem _ _ -> panicOp - - MO_VU_Quot _ _ -> panicOp - MO_VU_Rem _ _ -> panicOp - - MO_VF_Insert _ _ -> panicOp - MO_VF_Extract _ _ -> panicOp - - MO_VF_Add _ _ -> panicOp - MO_VF_Sub _ _ -> panicOp - MO_VF_Mul _ _ -> panicOp - MO_VF_Quot _ _ -> panicOp - - where - negate ty v2 negOp = do - (vx, stmts, top) <- exprToVar x - (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx - return (v1, stmts `snocOL` s1, top) - - negateVec ty v2 negOp = do - (vx, stmts1, top) <- exprToVar x - ([vx'], stmts2) <- castVars [(vx, ty)] - (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx' - return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top) - - fiConv ty convOp = do - (vx, stmts, top) <- exprToVar x - (v1, s1) <- doExpr ty $ Cast convOp vx ty - return (v1, stmts `snocOL` s1, top) - - sameConv from ty reduce expand = do - x'@(vx, stmts, top) <- exprToVar x - let sameConv' op = do - (v1, s1) <- doExpr ty $ Cast op vx ty - return (v1, stmts `snocOL` s1, top) - dflags <- getDynFlags - let toWidth = llvmWidthInBits dflags ty - -- LLVM doesn't like trying to convert to same width, so - -- need to check for that as we do get Cmm code doing it. - case widthInBits from of - w | w < toWidth -> sameConv' expand - w | w > toWidth -> sameConv' reduce - _w -> return x' - - panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered" - ++ "with one argument! (" ++ show op ++ ")" - --- Handle GlobalRegs pointers -genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] - = genMachOp_fast opt o r (fromInteger n) e - -genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] - = genMachOp_fast opt o r (negate . fromInteger $ n) e - --- Generic case -genMachOp opt op e = genMachOp_slow opt op e - - --- | Handle CmmMachOp expressions --- This is a specialised method that handles Global register manipulations like --- 'Sp - 16', using the getelementptr instruction. -genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] - -> LlvmM ExprData -genMachOp_fast opt op r n e - = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - dflags <- getDynFlags - let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - case isPointer grt && rem == 0 of - True -> do - (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] - (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags) - return (var, s1 `snocOL` s2 `snocOL` s3, []) - - False -> genMachOp_slow opt op e - - --- | Handle CmmMachOp expressions --- This handles all the cases not handle by the specialised genMachOp_fast. -genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData - --- Element extraction -genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do - vval <- exprToVarW val - vidx <- exprToVarW idx - [vval'] <- castVarsW [(vval, LMVector l ty)] - doExprW ty $ Extract vval' vidx - where - ty = widthToLlvmInt w - -genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do - vval <- exprToVarW val - vidx <- exprToVarW idx - [vval'] <- castVarsW [(vval, LMVector l ty)] - doExprW ty $ Extract vval' vidx - where - ty = widthToLlvmFloat w - --- Element insertion -genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do - vval <- exprToVarW val - velt <- exprToVarW elt - vidx <- exprToVarW idx - [vval'] <- castVarsW [(vval, ty)] - doExprW ty $ Insert vval' velt vidx - where - ty = LMVector l (widthToLlvmInt w) - -genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do - vval <- exprToVarW val - velt <- exprToVarW elt - vidx <- exprToVarW idx - [vval'] <- castVarsW [(vval, ty)] - doExprW ty $ Insert vval' velt vidx - where - ty = LMVector l (widthToLlvmFloat w) - --- Binary MachOp -genMachOp_slow opt op [x, y] = case op of - - MO_Eq _ -> genBinComp opt LM_CMP_Eq - MO_Ne _ -> genBinComp opt LM_CMP_Ne - - MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt - MO_S_Ge _ -> genBinComp opt LM_CMP_Sge - MO_S_Lt _ -> genBinComp opt LM_CMP_Slt - MO_S_Le _ -> genBinComp opt LM_CMP_Sle - - MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt - MO_U_Ge _ -> genBinComp opt LM_CMP_Uge - MO_U_Lt _ -> genBinComp opt LM_CMP_Ult - MO_U_Le _ -> genBinComp opt LM_CMP_Ule - - MO_Add _ -> genBinMach LM_MO_Add - MO_Sub _ -> genBinMach LM_MO_Sub - MO_Mul _ -> genBinMach LM_MO_Mul - - MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!" - - MO_S_MulMayOflo w -> isSMulOK w x y - - MO_S_Quot _ -> genBinMach LM_MO_SDiv - MO_S_Rem _ -> genBinMach LM_MO_SRem - - MO_U_Quot _ -> genBinMach LM_MO_UDiv - MO_U_Rem _ -> genBinMach LM_MO_URem - - MO_F_Eq _ -> genBinComp opt LM_CMP_Feq - MO_F_Ne _ -> genBinComp opt LM_CMP_Fne - MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt - MO_F_Ge _ -> genBinComp opt LM_CMP_Fge - MO_F_Lt _ -> genBinComp opt LM_CMP_Flt - MO_F_Le _ -> genBinComp opt LM_CMP_Fle - - MO_F_Add _ -> genBinMach LM_MO_FAdd - MO_F_Sub _ -> genBinMach LM_MO_FSub - MO_F_Mul _ -> genBinMach LM_MO_FMul - MO_F_Quot _ -> genBinMach LM_MO_FDiv - - MO_And _ -> genBinMach LM_MO_And - MO_Or _ -> genBinMach LM_MO_Or - MO_Xor _ -> genBinMach LM_MO_Xor - MO_Shl _ -> genBinMach LM_MO_Shl - MO_U_Shr _ -> genBinMach LM_MO_LShr - MO_S_Shr _ -> genBinMach LM_MO_AShr - - MO_V_Add l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add - MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub - MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul - - MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv - MO_VS_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem - - MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv - MO_VU_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem - - MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd - MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub - MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul - MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv - - MO_Not _ -> panicOp - MO_S_Neg _ -> panicOp - MO_F_Neg _ -> panicOp - - MO_SF_Conv _ _ -> panicOp - MO_FS_Conv _ _ -> panicOp - MO_SS_Conv _ _ -> panicOp - MO_UU_Conv _ _ -> panicOp - MO_FF_Conv _ _ -> panicOp - - MO_V_Insert {} -> panicOp - MO_V_Extract {} -> panicOp - - MO_VS_Neg {} -> panicOp - - MO_VF_Insert {} -> panicOp - MO_VF_Extract {} -> panicOp - - MO_VF_Neg {} -> panicOp - - where - binLlvmOp ty binOp = runExprData $ do - vx <- exprToVarW x - vy <- exprToVarW y - if getVarType vx == getVarType vy - then do - doExprW (ty vx) $ binOp vx vy - - else do - -- Error. Continue anyway so we can debug the generated ll file. - dflags <- getDynFlags - let style = mkCodeStyle CStyle - toString doc = renderWithStyle dflags doc style - cmmToStr = (lines . toString . PprCmm.pprExpr) - statement $ Comment $ map fsLit $ cmmToStr x - statement $ Comment $ map fsLit $ cmmToStr y - doExprW (ty vx) $ binOp vx vy - - binCastLlvmOp ty binOp = runExprData $ do - vx <- exprToVarW x - vy <- exprToVarW y - [vx', vy'] <- castVarsW [(vx, ty), (vy, ty)] - doExprW ty $ binOp vx' vy' - - -- | Need to use EOption here as Cmm expects word size results from - -- comparisons while LLVM return i1. Need to extend to llvmWord type - -- if expected. See Note [Literals and branch conditions]. - genBinComp opt cmp = do - ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) - dflags <- getDynFlags - if getVarType v1 == i1 - then case i1Expected opt of - True -> return ed - False -> do - let w_ = llvmWord dflags - (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_ - return (v2, stmts `snocOL` s1, top) - else - panic $ "genBinComp: Compare returned type other then i1! " - ++ (showSDoc dflags $ ppr $ getVarType v1) - - genBinMach op = binLlvmOp getVarType (LlvmOp op) - - genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op) - - -- | Detect if overflow will occur in signed multiply of the two - -- CmmExpr's. This is the LLVM assembly equivalent of the NCG - -- implementation. Its much longer due to type information/safety. - -- This should actually compile to only about 3 asm instructions. - isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData - isSMulOK _ x y = runExprData $ do - vx <- exprToVarW x - vy <- exprToVarW y - - dflags <- getDynFlags - let word = getVarType vx - let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) - let shift = llvmWidthInBits dflags word - let shift1 = toIWord dflags (shift - 1) - let shift2 = toIWord dflags shift - - if isInt word - then do - x1 <- doExprW word2 $ Cast LM_Sext vx word2 - y1 <- doExprW word2 $ Cast LM_Sext vy word2 - r1 <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1 - rlow1 <- doExprW word $ Cast LM_Trunc r1 word - rlow2 <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1 - rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2 - rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word - doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2 - - else - panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")" - - panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered" - ++ "with two arguments! (" ++ show op ++ ")" - --- More then two expression, invalid! -genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" - - --- | Handle CmmLoad expression. -genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData - --- First we try to detect a few common cases and produce better code for --- these then the default case. We are mostly trying to detect Cmm code --- like I32[Sp + n] and use 'getelementptr' operations instead of the --- generic case that uses casts and pointer arithmetic -genLoad atomic e@(CmmReg (CmmGlobal r)) ty - = genLoad_fast atomic e r 0 ty - -genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty - = genLoad_fast atomic e r n ty - -genLoad atomic e@(CmmMachOp (MO_Add _) [ - (CmmReg (CmmGlobal r)), - (CmmLit (CmmInt n _))]) - ty - = genLoad_fast atomic e r (fromInteger n) ty - -genLoad atomic e@(CmmMachOp (MO_Sub _) [ - (CmmReg (CmmGlobal r)), - (CmmLit (CmmInt n _))]) - ty - = genLoad_fast atomic e r (negate $ fromInteger n) ty - --- generic case -genLoad atomic e ty - = getTBAAMeta topN >>= genLoad_slow atomic e ty - --- | Handle CmmLoad expression. --- This is a special case for loading from a global register pointer --- offset such as I32[Sp+8]. -genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType - -> LlvmM ExprData -genLoad_fast atomic e r n ty = do - dflags <- getDynFlags - (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - meta <- getTBAARegMeta r - let ty' = cmmToLlvmType ty - (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - case isPointer grt && rem == 0 of - True -> do - (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] - -- We might need a different pointer type, so check - case grt == ty' of - -- were fine - True -> do - (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr) - return (var, s1 `snocOL` s2 `snocOL` s3, - []) - - -- cast to pointer type needed - False -> do - let pty = pLift ty' - (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr') - return (var, s1 `snocOL` s2 `snocOL` s3 - `snocOL` s4, []) - - -- If its a bit type then we use the slow method since - -- we can't avoid casting anyway. - False -> genLoad_slow atomic e ty meta - where - loadInstr ptr | atomic = ALoad SyncSeqCst False ptr - | otherwise = Load ptr - --- | Handle Cmm load expression. --- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData -genLoad_slow atomic e ty meta = runExprData $ do - iptr <- exprToVarW e - dflags <- getDynFlags - case getVarType iptr of - LMPointer _ -> do - doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr) - - i@(LMInt _) | i == llvmWord dflags -> do - let pty = LMPointer $ cmmToLlvmType ty - ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty - doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr) - - other -> do pprPanic "exprToVar: CmmLoad expression is not right type!" - (PprCmm.pprExpr e <+> text ( - "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ - ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ - ", Var: " ++ showSDoc dflags (ppr iptr))) - where - loadInstr ptr | atomic = ALoad SyncSeqCst False ptr - | otherwise = Load ptr - - --- | Handle CmmReg expression. This will return a pointer to the stack --- location of the register. Throws an error if it isn't allocated on --- the stack. -getCmmReg :: CmmReg -> LlvmM LlvmVar -getCmmReg (CmmLocal (LocalReg un _)) - = do exists <- varLookup un - dflags <- getDynFlags - case exists of - Just ety -> return (LMLocalVar un $ pLift ety) - Nothing -> fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!" - -- This should never happen, as every local variable should - -- have been assigned a value at some point, triggering - -- "funPrologue" to allocate it on the stack. - -getCmmReg (CmmGlobal g) - = do onStack <- checkStackReg g - dflags <- getDynFlags - if onStack - then return (lmGlobalRegVar dflags g) - else fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!" - --- | Return the value of a given register, as well as its type. Might --- need to be load from stack. -getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) -getCmmRegVal reg = - case reg of - CmmGlobal g -> do - onStack <- checkStackReg g - dflags <- getDynFlags - if onStack then loadFromStack else do - let r = lmGlobalRegArg dflags g - return (r, getVarType r, nilOL) - _ -> loadFromStack - where loadFromStack = do - ptr <- getCmmReg reg - let ty = pLower $ getVarType ptr - (v, s) <- doExpr ty (Load ptr) - return (v, ty, unitOL s) - --- | Allocate a local CmmReg on the stack -allocReg :: CmmReg -> (LlvmVar, LlvmStatements) -allocReg (CmmLocal (LocalReg un ty)) - = let ty' = cmmToLlvmType ty - var = LMLocalVar un (LMPointer ty') - alc = Alloca ty' 1 - in (var, unitOL $ Assignment var alc) - -allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" - ++ " have been handled elsewhere!" - - --- | Generate code for a literal -genLit :: EOption -> CmmLit -> LlvmM ExprData -genLit opt (CmmInt i w) - -- See Note [Literals and branch conditions]. - = let width | i1Expected opt = i1 - | otherwise = LMInt (widthInBits w) - -- comm = Comment [ fsLit $ "EOption: " ++ show opt - -- , fsLit $ "Width : " ++ show w - -- , fsLit $ "Width' : " ++ show (widthInBits w) - -- ] - in return (mkIntLit width i, nilOL, []) - -genLit _ (CmmFloat r w) - = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), - nilOL, []) - -genLit opt (CmmVec ls) - = do llvmLits <- mapM toLlvmLit ls - return (LMLitVar $ LMVectorLit llvmLits, nilOL, []) - where - toLlvmLit :: CmmLit -> LlvmM LlvmLit - toLlvmLit lit = do - (llvmLitVar, _, _) <- genLit opt lit - case llvmLitVar of - LMLitVar llvmLit -> return llvmLit - _ -> panic "genLit" - -genLit _ cmm@(CmmLabel l) - = do var <- getGlobalPtr =<< strCLabel_llvm l - dflags <- getDynFlags - let lmty = cmmToLlvmType $ cmmLitType dflags cmm - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) - return (v1, unitOL s1, []) - -genLit opt (CmmLabelOff label off) = do - dflags <- getDynFlags - (vlbl, stmts, stat) <- genLit opt (CmmLabel label) - let voff = toIWord dflags off - (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff - return (v1, stmts `snocOL` s1, stat) - -genLit opt (CmmLabelDiffOff l1 l2 off) = do - dflags <- getDynFlags - (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1) - (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2) - let voff = toIWord dflags off - let ty1 = getVarType vl1 - let ty2 = getVarType vl2 - if (isInt ty1) && (isInt ty2) - && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2) - - then do - (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 - (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff - return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, - stat1 ++ stat2) - - else - panic "genLit: CmmLabelDiffOff encountered with different label ty!" - -genLit opt (CmmBlock b) - = genLit opt (CmmLabel $ infoTblLbl b) - -genLit _ CmmHighStackMark - = panic "genStaticLit - CmmHighStackMark unsupported!" - - --- ----------------------------------------------------------------------------- --- * Misc --- - --- | Find CmmRegs that get assigned and allocate them on the stack --- --- Any register that gets written needs to be allcoated on the --- stack. This avoids having to map a CmmReg to an equivalent SSA form --- and avoids having to deal with Phi node insertion. This is also --- the approach recommended by LLVM developers. --- --- On the other hand, this is unnecessarily verbose if the register in --- question is never written. Therefore we skip it where we can to --- save a few lines in the output and hopefully speed compilation up a --- bit. -funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData -funPrologue live cmmBlocks = do - - trash <- getTrashRegs - let getAssignedRegs :: CmmNode O O -> [CmmReg] - getAssignedRegs (CmmAssign reg _) = [reg] - -- Calls will trash all registers. Unfortunately, this needs them to - -- be stack-allocated in the first place. - getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs - getAssignedRegs _ = [] - getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body - assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks - isLive r = r `elem` alwaysLive || r `elem` live - - dflags <- getDynFlags - stmtss <- flip mapM assignedRegs $ \reg -> - case reg of - CmmLocal (LocalReg un _) -> do - let (newv, stmts) = allocReg reg - varInsert un (pLower $ getVarType newv) - return stmts - CmmGlobal r -> do - let reg = lmGlobalRegVar dflags r - arg = lmGlobalRegArg dflags r - ty = (pLower . getVarType) reg - trash = LMLitVar $ LMUndefLit ty - rval = if isLive r then arg else trash - alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - markStackReg r - return $ toOL [alloc, Store rval reg] - - return (concatOL stmtss, []) - --- | Function epilogue. Load STG variables to use as argument for call. --- STG Liveness optimisation done here. -funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) -funEpilogue live = do - - -- Have information and liveness optimisation is enabled? - let liveRegs = alwaysLive ++ live - isSSE (FloatReg _) = True - isSSE (DoubleReg _) = True - isSSE (XmmReg _) = True - isSSE (YmmReg _) = True - isSSE (ZmmReg _) = True - isSSE _ = False - - -- Set to value or "undef" depending on whether the register is - -- actually live - dflags <- getDynFlags - let loadExpr r = do - (v, _, s) <- getCmmRegVal (CmmGlobal r) - return (Just $ v, s) - loadUndef r = do - let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) - return (Just $ LMLitVar $ LMUndefLit ty, nilOL) - platform <- getDynFlag targetPlatform - loads <- flip mapM (activeStgRegs platform) $ \r -> case () of - _ | r `elem` liveRegs -> loadExpr r - | not (isSSE r) -> loadUndef r - | otherwise -> return (Nothing, nilOL) - - let (vars, stmts) = unzip loads - return (catMaybes vars, concatOL stmts) - - --- | A series of statements to trash all the STG registers. --- --- In LLVM we pass the STG registers around everywhere in function calls. --- So this means LLVM considers them live across the entire function, when --- in reality they usually aren't. For Caller save registers across C calls --- the saving and restoring of them is done by the Cmm code generator, --- using Cmm local vars. So to stop LLVM saving them as well (and saving --- all of them since it thinks they're always live, we trash them just --- before the call by assigning the 'undef' value to them. The ones we --- need are restored from the Cmm local var and the ones we don't need --- are fine to be trashed. -getTrashStmts :: LlvmM LlvmStatements -getTrashStmts = do - regs <- getTrashRegs - stmts <- flip mapM regs $ \ r -> do - reg <- getCmmReg (CmmGlobal r) - let ty = (pLower . getVarType) reg - return $ Store (LMLitVar $ LMUndefLit ty) reg - return $ toOL stmts - -getTrashRegs :: LlvmM [GlobalReg] -getTrashRegs = do plat <- getLlvmPlatform - return $ filter (callerSaves plat) (activeStgRegs plat) - --- | Get a function pointer to the CLabel specified. --- --- This is for Haskell functions, function type is assumed, so doesn't work --- with foreign functions. -getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData -getHsFunc live lbl - = do fty <- llvmFunTy live - name <- strCLabel_llvm lbl - getHsFunc' name fty - -getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData -getHsFunc' name fty - = do fun <- getGlobalPtr name - if getVarType fun == fty - then return (fun, nilOL, []) - else do (v1, s1) <- doExpr (pLift fty) - $ Cast LM_Bitcast fun (pLift fty) - return (v1, unitOL s1, []) - --- | Create a new local var -mkLocalVar :: LlvmType -> LlvmM LlvmVar -mkLocalVar ty = do - un <- getUniqueM - return $ LMLocalVar un ty - - --- | Execute an expression, assigning result to a var -doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement) -doExpr ty expr = do - v <- mkLocalVar ty - return (v, Assignment v expr) - - --- | Expand CmmRegOff -expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr -expandCmmReg dflags (reg, off) - = let width = typeWidth (cmmRegType dflags reg) - voff = CmmLit $ CmmInt (fromIntegral off) width - in CmmMachOp (MO_Add width) [CmmReg reg, voff] - - --- | Convert a block id into a appropriate Llvm label -blockIdToLlvm :: BlockId -> LlvmVar -blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel - --- | Create Llvm int Literal -mkIntLit :: Integral a => LlvmType -> a -> LlvmVar -mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty - --- | Convert int type to a LLvmVar of word or i32 size -toI32 :: Integral a => a -> LlvmVar -toI32 = mkIntLit i32 - -toIWord :: Integral a => DynFlags -> a -> LlvmVar -toIWord dflags = mkIntLit (llvmWord dflags) - - --- | Error functions -panic :: String -> a -panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s - -pprPanic :: String -> SDoc -> a -pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d - - --- | Returns TBAA meta data by unique -getTBAAMeta :: Unique -> LlvmM [MetaAnnot] -getTBAAMeta u = do - mi <- getUniqMeta u - return [MetaAnnot tbaa (MetaNode i) | let Just i = mi] - --- | Returns TBAA meta data for given register -getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot] -getTBAARegMeta = getTBAAMeta . getTBAA - - --- | A more convenient way of accumulating LLVM statements and declarations. -data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl] - -#if __GLASGOW_HASKELL__ > 710 -instance Semigroup LlvmAccum where - LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB = - LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB) -#endif - -instance Monoid LlvmAccum where - mempty = LlvmAccum nilOL [] - LlvmAccum stmtsA declsA `mappend` LlvmAccum stmtsB declsB = - LlvmAccum (stmtsA `mappend` stmtsB) (declsA `mappend` declsB) - -liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar -liftExprData action = do - (var, stmts, decls) <- lift action - tell $ LlvmAccum stmts decls - return var - -statement :: LlvmStatement -> WriterT LlvmAccum LlvmM () -statement stmt = tell $ LlvmAccum (unitOL stmt) [] - -doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar -doExprW a b = do - (var, stmt) <- lift $ doExpr a b - statement stmt - return var - -exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar -exprToVarW = liftExprData . exprToVar - -runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData -runExprData action = do - (var, LlvmAccum stmts decls) <- runWriterT action - return (var, stmts, decls) - -runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl]) -runStmtsDecls action = do - LlvmAccum stmts decls <- execWriterT action - return (stmts, decls) - -getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar -getCmmRegW = lift . getCmmReg - -genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar -genLoadW atomic e ty = liftExprData $ genLoad atomic e ty - -doTrashStmts :: WriterT LlvmAccum LlvmM () -doTrashStmts = do - stmts <- lift getTrashStmts - tell $ LlvmAccum stmts mempty diff --git a/llvmGen/LlvmCodeGen/Data.hs b/llvmGen/LlvmCodeGen/Data.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen/Data.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE CPP #-} --- ---------------------------------------------------------------------------- --- | Handle conversion of CmmData to LLVM code. --- - -module LlvmCodeGen.Data ( - genLlvmData, genData - ) where - -#include "HsVersions.h" - -import Llvm -import LlvmCodeGen.Base - -import BlockId -import CLabel -import Cmm -import DynFlags -import Platform - -import FastString -import Outputable - --- ---------------------------------------------------------------------------- --- * Constants --- - --- | The string appended to a variable name to create its structure type alias -structStr :: LMString -structStr = fsLit "_struct" - --- ---------------------------------------------------------------------------- --- * Top level --- - --- | Pass a CmmStatic section to an equivalent Llvm code. -genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData -genLlvmData (sec, Statics lbl xs) = do - label <- strCLabel_llvm lbl - static <- mapM genData xs - lmsec <- llvmSection sec - let types = map getStatType static - - strucTy = LMStruct types - tyAlias = LMAlias ((label `appendFS` structStr), strucTy) - - struct = Just $ LMStaticStruc static tyAlias - link = if (externallyVisibleCLabel lbl) - then ExternallyVisible else Internal - align = case sec of - Section CString _ -> Just 1 - _ -> Nothing - const = if isSecConstant sec then Constant else Global - varDef = LMGlobalVar label tyAlias link lmsec align const - globDef = LMGlobal varDef struct - - return ([globDef], [tyAlias]) - --- | Should a data in this section be considered constant -isSecConstant :: Section -> Bool -isSecConstant (Section t _) = case t of - Text -> True - ReadOnlyData -> True - RelocatableReadOnlyData -> True - ReadOnlyData16 -> True - CString -> True - Data -> False - UninitialisedData -> False - (OtherSection _) -> False - --- | Format the section type part of a Cmm Section -llvmSectionType :: Platform -> SectionType -> FastString -llvmSectionType p t = case t of - Text -> fsLit ".text" - ReadOnlyData -> fsLit ".rodata" - RelocatableReadOnlyData -> fsLit ".data.rel.ro" - ReadOnlyData16 -> fsLit ".rodata.cst16" - Data -> fsLit ".data" - UninitialisedData -> fsLit ".bss" - CString -> case platformOS p of - OSMinGW32 -> fsLit ".rdata" - _ -> fsLit ".rodata.str" - (OtherSection _) -> panic "llvmSectionType: unknown section type" - --- | Format a Cmm Section into a LLVM section name -llvmSection :: Section -> LlvmM LMSection -llvmSection (Section t suffix) = do - dflags <- getDynFlags - let splitSect = gopt Opt_SplitSections dflags - platform = targetPlatform dflags - if not splitSect - then return Nothing - else do - lmsuffix <- strCLabel_llvm suffix - return (Just (concatFS [llvmSectionType platform t, fsLit ".", lmsuffix])) - --- ---------------------------------------------------------------------------- --- * Generate static data --- - --- | Handle static data -genData :: CmmStatic -> LlvmM LlvmStatic - -genData (CmmString str) = do - let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str - ve = v ++ [LMStaticLit $ LMIntLit 0 i8] - return $ LMStaticArray ve (LMArray (length ve) i8) - -genData (CmmUninitialised bytes) - = return $ LMUninitType (LMArray bytes i8) - -genData (CmmStaticLit lit) - = genStaticLit lit - --- | Generate Llvm code for a static literal. --- --- Will either generate the code or leave it unresolved if it is a 'CLabel' --- which isn't yet known. -genStaticLit :: CmmLit -> LlvmM LlvmStatic -genStaticLit (CmmInt i w) - = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) - -genStaticLit (CmmFloat r w) - = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) - -genStaticLit (CmmVec ls) - = do sls <- mapM toLlvmLit ls - return $ LMStaticLit (LMVectorLit sls) - where - toLlvmLit :: CmmLit -> LlvmM LlvmLit - toLlvmLit lit = do - slit <- genStaticLit lit - case slit of - LMStaticLit llvmLit -> return llvmLit - _ -> panic "genStaticLit" - --- Leave unresolved, will fix later -genStaticLit cmm@(CmmLabel l) = do - var <- getGlobalPtr =<< strCLabel_llvm l - dflags <- getDynFlags - let ptr = LMStaticPointer var - lmty = cmmToLlvmType $ cmmLitType dflags cmm - return $ LMPtoI ptr lmty - -genStaticLit (CmmLabelOff label off) = do - dflags <- getDynFlags - var <- genStaticLit (CmmLabel label) - let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) - return $ LMAdd var offset - -genStaticLit (CmmLabelDiffOff l1 l2 off) = do - dflags <- getDynFlags - var1 <- genStaticLit (CmmLabel l1) - var2 <- genStaticLit (CmmLabel l2) - let var = LMSub var1 var2 - offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) - return $ LMAdd var offset - -genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b - -genStaticLit (CmmHighStackMark) - = panic "genStaticLit: CmmHighStackMark unsupported!" diff --git a/llvmGen/LlvmCodeGen/Ppr.hs b/llvmGen/LlvmCodeGen/Ppr.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen/Ppr.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE CPP #-} - --- ---------------------------------------------------------------------------- --- | Pretty print helpers for the LLVM Code generator. --- -module LlvmCodeGen.Ppr ( - pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection - ) where - -#include "HsVersions.h" - -import Llvm -import LlvmCodeGen.Base -import LlvmCodeGen.Data - -import CLabel -import Cmm -import Platform - -import FastString -import Outputable -import Unique - - --- ---------------------------------------------------------------------------- --- * Top level --- - --- | Header code for LLVM modules -pprLlvmHeader :: SDoc -pprLlvmHeader = moduleLayout - - --- | LLVM module layout description for the host target -moduleLayout :: SDoc -moduleLayout = sdocWithPlatform $ \platform -> - case platform of - Platform { platformArch = ArchX86, platformOS = OSDarwin } -> - text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\"" - $+$ text "target triple = \"i386-apple-darwin9.8\"" - Platform { platformArch = ArchX86, platformOS = OSMinGW32 } -> - text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f80:128:128-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\"" - $+$ text "target triple = \"i686-pc-win32\"" - Platform { platformArch = ArchX86, platformOS = OSLinux } -> - text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\"" - $+$ text "target triple = \"i386-pc-linux-gnu\"" - Platform { platformArch = ArchX86_64, platformOS = OSDarwin } -> - text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\"" - $+$ text "target triple = \"x86_64-apple-darwin10.0.0\"" - Platform { platformArch = ArchX86_64, platformOS = OSLinux } -> - text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\"" - $+$ text "target triple = \"x86_64-linux-gnu\"" - Platform { platformArch = ArchARM {}, platformOS = OSLinux } -> - text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" - $+$ text "target triple = \"armv6-unknown-linux-gnueabihf\"" - Platform { platformArch = ArchARM {}, platformOS = OSAndroid } -> - text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" - $+$ text "target triple = \"arm-unknown-linux-androideabi\"" - Platform { platformArch = ArchARM {}, platformOS = OSQNXNTO } -> - text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" - $+$ text "target triple = \"arm-unknown-nto-qnx8.0.0eabi\"" - Platform { platformArch = ArchARM {}, platformOS = OSiOS } -> - text "target datalayout = \"e-m:o-p:32:32-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32\"" - $+$ text "target triple = \"thumbv7-apple-ios7.0.0\"" - Platform { platformArch = ArchARM64, platformOS = OSiOS } -> - text "target datalayout = \"e-m:o-i64:64-i128:128-n32:64-S128\"" - $+$ text "target triple = \"arm64-apple-ios7.0.0\"" - Platform { platformArch = ArchX86, platformOS = OSiOS } -> - text "target datalayout = \"e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128\"" - $+$ text "target triple = \"i386-apple-ios7.0.0\"" - Platform { platformArch = ArchX86_64, platformOS = OSiOS } -> - text "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"" - $+$ text "target triple = \"x86_64-apple-ios7.0.0\"" - Platform { platformArch = ArchARM64, platformOS = OSLinux } -> - text "target datalayout = \"e-m:e-i64:64-i128:128-n32:64-S128\"" - $+$ text "target triple = \"aarch64-unknown-linux-gnu\"" - _ -> - if platformIsCrossCompiling platform - then panic "LlvmCodeGen.Ppr: Cross compiling without valid target info." - else empty - -- If you see the above panic, GHC is missing the required target datalayout - -- and triple information. You can obtain this info by compiling a simple - -- 'hello world' C program with the clang C compiler eg: - -- clang -S hello.c -emit-llvm -o - - -- and the first two lines of hello.ll should provide the 'target datalayout' - -- and 'target triple' lines required. - - --- | Pretty print LLVM data code -pprLlvmData :: LlvmData -> SDoc -pprLlvmData (globals, types) = - let ppLlvmTys (LMAlias a) = ppLlvmAlias a - ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f - ppLlvmTys _other = empty - - types' = vcat $ map ppLlvmTys types - globals' = ppLlvmGlobals globals - in types' $+$ globals' - - --- | Pretty print LLVM code -pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) -pprLlvmCmmDecl (CmmData _ lmdata) - = return (vcat $ map pprLlvmData lmdata, []) - -pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks)) - = do let lbl = case mb_info of - Nothing -> entry_lbl - Just (Statics info_lbl _) -> info_lbl - link = if externallyVisibleCLabel lbl - then ExternallyVisible - else Internal - lmblocks = map (\(BasicBlock id stmts) -> - LlvmBlock (getUnique id) stmts) blks - - funDec <- llvmFunSig live lbl link - dflags <- getDynFlags - let buildArg = fsLit . showSDoc dflags . ppPlainName - funArgs = map buildArg (llvmFunArgs dflags live) - funSect = llvmFunSection dflags (decName funDec) - - -- generate the info table - prefix <- case mb_info of - Nothing -> return Nothing - Just (Statics _ statics) -> do - infoStatics <- mapM genData statics - let infoTy = LMStruct $ map getStatType infoStatics - return $ Just $ LMStaticStruc infoStatics infoTy - - - let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect - prefix lmblocks - name = decName $ funcDecl fun - defName = name `appendFS` fsLit "$def" - funcDecl' = (funcDecl fun) { decName = defName } - fun' = fun { funcDecl = funcDecl' } - funTy = LMFunction funcDecl' - funVar = LMGlobalVar name - (LMPointer funTy) - link - Nothing - Nothing - Alias - defVar = LMGlobalVar defName - (LMPointer funTy) - (funcLinkage funcDecl') - (funcSect fun) - (funcAlign funcDecl') - Alias - alias = LMGlobal funVar - (Just $ LMBitc (LMStaticPointer defVar) - (LMPointer $ LMInt 8)) - - return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', []) - - --- | The section we are putting info tables and their entry code into, should --- be unique since we process the assembly pattern matching this. -infoSection :: String -infoSection = "X98A__STRIP,__me" diff --git a/llvmGen/LlvmCodeGen/Regs.hs b/llvmGen/LlvmCodeGen/Regs.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen/Regs.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE CPP #-} - --------------------------------------------------------------------------------- --- | Deal with Cmm registers --- - -module LlvmCodeGen.Regs ( - lmGlobalRegArg, lmGlobalRegVar, alwaysLive, - stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA - ) where - -#include "HsVersions.h" - -import Llvm - -import CmmExpr -import DynFlags -import FastString -import Outputable ( panic ) -import Unique - --- | Get the LlvmVar function variable storing the real register -lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar -lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var" - --- | Get the LlvmVar function argument storing the real register -lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar -lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg" - -{- Need to make sure the names here can't conflict with the unique generated - names. Uniques generated names containing only base62 chars. So using say - the '_' char guarantees this. --} -lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar -lmGlobalReg dflags suf reg - = case reg of - BaseReg -> ptrGlobal $ "Base" ++ suf - Sp -> ptrGlobal $ "Sp" ++ suf - Hp -> ptrGlobal $ "Hp" ++ suf - VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf - VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf - VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf - VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf - VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf - VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf - VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf - VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf - SpLim -> wordGlobal $ "SpLim" ++ suf - FloatReg 1 -> floatGlobal $"F1" ++ suf - FloatReg 2 -> floatGlobal $"F2" ++ suf - FloatReg 3 -> floatGlobal $"F3" ++ suf - FloatReg 4 -> floatGlobal $"F4" ++ suf - FloatReg 5 -> floatGlobal $"F5" ++ suf - FloatReg 6 -> floatGlobal $"F6" ++ suf - DoubleReg 1 -> doubleGlobal $ "D1" ++ suf - DoubleReg 2 -> doubleGlobal $ "D2" ++ suf - DoubleReg 3 -> doubleGlobal $ "D3" ++ suf - DoubleReg 4 -> doubleGlobal $ "D4" ++ suf - DoubleReg 5 -> doubleGlobal $ "D5" ++ suf - DoubleReg 6 -> doubleGlobal $ "D6" ++ suf - XmmReg 1 -> xmmGlobal $ "XMM1" ++ suf - XmmReg 2 -> xmmGlobal $ "XMM2" ++ suf - XmmReg 3 -> xmmGlobal $ "XMM3" ++ suf - XmmReg 4 -> xmmGlobal $ "XMM4" ++ suf - XmmReg 5 -> xmmGlobal $ "XMM5" ++ suf - XmmReg 6 -> xmmGlobal $ "XMM6" ++ suf - YmmReg 1 -> ymmGlobal $ "YMM1" ++ suf - YmmReg 2 -> ymmGlobal $ "YMM2" ++ suf - YmmReg 3 -> ymmGlobal $ "YMM3" ++ suf - YmmReg 4 -> ymmGlobal $ "YMM4" ++ suf - YmmReg 5 -> ymmGlobal $ "YMM5" ++ suf - YmmReg 6 -> ymmGlobal $ "YMM6" ++ suf - ZmmReg 1 -> zmmGlobal $ "ZMM1" ++ suf - ZmmReg 2 -> zmmGlobal $ "ZMM2" ++ suf - ZmmReg 3 -> zmmGlobal $ "ZMM3" ++ suf - ZmmReg 4 -> zmmGlobal $ "ZMM4" ++ suf - ZmmReg 5 -> zmmGlobal $ "ZMM5" ++ suf - ZmmReg 6 -> zmmGlobal $ "ZMM6" ++ suf - MachSp -> wordGlobal $ "MachSp" ++ suf - _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) - ++ ") not supported!" - -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc - -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg - where - wordGlobal name = LMNLocalVar (fsLit name) (llvmWord dflags) - ptrGlobal name = LMNLocalVar (fsLit name) (llvmWordPtr dflags) - floatGlobal name = LMNLocalVar (fsLit name) LMFloat - doubleGlobal name = LMNLocalVar (fsLit name) LMDouble - xmmGlobal name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32)) - ymmGlobal name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32)) - zmmGlobal name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32)) - --- | A list of STG Registers that should always be considered alive -alwaysLive :: [GlobalReg] -alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] - --- | STG Type Based Alias Analysis hierarchy -stgTBAA :: [(Unique, LMString, Maybe Unique)] -stgTBAA - = [ (rootN, fsLit "root", Nothing) - , (topN, fsLit "top", Just rootN) - , (stackN, fsLit "stack", Just topN) - , (heapN, fsLit "heap", Just topN) - , (rxN, fsLit "rx", Just heapN) - , (baseN, fsLit "base", Just topN) - -- FIX: Not 100% sure if this hierarchy is complete. I think the big thing - -- is Sp is never aliased, so might want to change the hierarchy to have Sp - -- on its own branch that is never aliased (e.g never use top as a TBAA - -- node). - ] - --- | Id values --- The `rootN` node is the root (there can be more than one) of the TBAA --- hierarchy and as of LLVM 4.0 should *only* be referenced by other nodes. It --- should never occur in any LLVM instruction statement. -rootN, topN, stackN, heapN, rxN, baseN :: Unique -rootN = getUnique (fsLit "LlvmCodeGen.Regs.rootN") -topN = getUnique (fsLit "LlvmCodeGen.Regs.topN") -stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN") -heapN = getUnique (fsLit "LlvmCodeGen.Regs.heapN") -rxN = getUnique (fsLit "LlvmCodeGen.Regs.rxN") -baseN = getUnique (fsLit "LlvmCodeGen.Regs.baseN") - --- | The TBAA metadata identifier -tbaa :: LMString -tbaa = fsLit "tbaa" - --- | Get the correct TBAA metadata information for this register type -getTBAA :: GlobalReg -> Unique -getTBAA BaseReg = baseN -getTBAA Sp = stackN -getTBAA Hp = heapN -getTBAA (VanillaReg _ _) = rxN -getTBAA _ = topN diff --git a/llvmGen/LlvmMangler.hs b/llvmGen/LlvmMangler.hs deleted file mode 100644 --- a/llvmGen/LlvmMangler.hs +++ /dev/null @@ -1,127 +0,0 @@ --- ----------------------------------------------------------------------------- --- | GHC LLVM Mangler --- --- This script processes the assembly produced by LLVM, rewriting all symbols --- of type @function to @object. This keeps them from going through the PLT, --- which would be bad due to tables-next-to-code. On x86_64, --- it also rewrites AVX instructions that require alignment to their --- unaligned counterparts, since the stack is only 16-byte aligned but these --- instructions require 32-byte alignment. --- - -module LlvmMangler ( llvmFixupAsm ) where - -import DynFlags ( DynFlags, targetPlatform ) -import Platform ( platformArch, Arch(..) ) -import ErrUtils ( withTiming ) -import Outputable ( text ) - -import Control.Exception -import qualified Data.ByteString.Char8 as B -import System.IO - --- | Read in assembly file and process -llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO () -llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} - withTiming (pure dflags) (text "LLVM Mangler") id $ - withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do - go r w - hClose r - hClose w - return () - where - go :: Handle -> Handle -> IO () - go r w = do - e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString) - let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w - case e_l of - Right l -> writeline l - Left _ -> return () - --- | These are the rewrites that the mangler will perform -rewrites :: [Rewrite] -rewrites = [rewriteSymType, rewriteAVX] - -type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString - --- | Rewrite a line of assembly source with the given rewrites, --- taking the first rewrite that applies. -rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString -rewriteLine dflags rewrites l - -- We disable .subsections_via_symbols on darwin and ios, as the llvm code - -- gen uses prefix data for the info table. This however does not prevent - -- llvm from generating .subsections_via_symbols, which in turn with - -- -dead_strip, strips the info tables, and therefore breaks ghc. - | isSubsectionsViaSymbols l = - (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!") - | otherwise = - case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of - Nothing -> l - Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten] - where - isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols") - - (symbol, rest) = splitLine l - - firstJust :: [Maybe a] -> Maybe a - firstJust (Just x:_) = Just x - firstJust [] = Nothing - firstJust (_:rest) = firstJust rest - --- | This rewrites @.type@ annotations of function symbols to @%object@. --- This is done as the linker can relocate @%functions@ through the --- Procedure Linking Table (PLT). This is bad since we expect that the --- info table will appear directly before the symbol's location. In the --- case that the PLT is used, this will be not an info table but instead --- some random PLT garbage. -rewriteSymType :: Rewrite -rewriteSymType _ l - | isType l = Just $ rewrite '@' $ rewrite '%' l - | otherwise = Nothing - where - isType = B.isPrefixOf (B.pack ".type") - - rewrite :: Char -> B.ByteString -> B.ByteString - rewrite prefix = replaceOnce funcType objType - where - funcType = prefix `B.cons` B.pack "function" - objType = prefix `B.cons` B.pack "object" - --- | This rewrites aligned AVX instructions to their unaligned counterparts on --- x86-64. This is necessary because the stack is not adequately aligned for --- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer --- and disable tail call optimization. Both would be catastrophic here so GHC --- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then --- rewrites the instructions in the mangler. -rewriteAVX :: Rewrite -rewriteAVX dflags s - | not isX86_64 = Nothing - | isVmovdqa s = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s - | isVmovap s = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s - | otherwise = Nothing - where - isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64 - isVmovdqa = B.isPrefixOf (B.pack "vmovdqa") - isVmovap = B.isPrefixOf (B.pack "vmovap") - --- | @replaceOnce match replace bs@ replaces the first occurrence of the --- substring @match@ in @bs@ with @replace@. -replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -replaceOnce matchBS replaceOnceBS = loop - where - loop :: B.ByteString -> B.ByteString - loop cts = - case B.breakSubstring matchBS cts of - (hd,tl) | B.null tl -> hd - | otherwise -> hd `B.append` replaceOnceBS `B.append` - B.drop (B.length matchBS) tl - --- | This function splits a line of assembly code into the label and the --- rest of the code. -splitLine :: B.ByteString -> (B.ByteString, B.ByteString) -splitLine l = (symbol, B.dropWhile isSpace rest) - where - isSpace ' ' = True - isSpace '\t' = True - isSpace _ = False - (symbol, rest) = B.span (not . isSpace) l diff --git a/main/Annotations.hs b/main/Annotations.hs deleted file mode 100644 --- a/main/Annotations.hs +++ /dev/null @@ -1,132 +0,0 @@ --- | --- Support for source code annotation feature of GHC. That is the ANN pragma. --- --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --- -module Annotations ( - -- * Main Annotation data types - Annotation(..), AnnPayload, - AnnTarget(..), CoreAnnTarget, - getAnnTargetName_maybe, - - -- * AnnEnv for collecting and querying Annotations - AnnEnv, - mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, - findAnns, findAnnsByTypeRep, - deserializeAnns - ) where - -import Binary -import Module ( Module ) -import Name -import Outputable -import GHC.Serialized -import UniqFM -import Unique - -import Control.Monad -import Data.Maybe -import Data.Typeable -import Data.Word ( Word8 ) - - --- | Represents an annotation after it has been sufficiently desugared from --- it's initial form of 'HsDecls.AnnDecl' -data Annotation = Annotation { - ann_target :: CoreAnnTarget, -- ^ The target of the annotation - ann_value :: AnnPayload - } - -type AnnPayload = Serialized -- ^ The "payload" of an annotation - -- allows recovery of its value at a given type, - -- and can be persisted to an interface file - --- | An annotation target -data AnnTarget name - = NamedTarget name -- ^ We are annotating something with a name: - -- a type or identifier - | ModuleTarget Module -- ^ We are annotating a particular module - --- | The kind of annotation target found in the middle end of the compiler -type CoreAnnTarget = AnnTarget Name - -instance Functor AnnTarget where - fmap f (NamedTarget nm) = NamedTarget (f nm) - fmap _ (ModuleTarget mod) = ModuleTarget mod - --- | Get the 'name' of an annotation target if it exists. -getAnnTargetName_maybe :: AnnTarget name -> Maybe name -getAnnTargetName_maybe (NamedTarget nm) = Just nm -getAnnTargetName_maybe _ = Nothing - -instance Uniquable name => Uniquable (AnnTarget name) where - getUnique (NamedTarget nm) = getUnique nm - getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0 - -- deriveUnique prevents OccName uniques clashing with NamedTarget - -instance Outputable name => Outputable (AnnTarget name) where - ppr (NamedTarget nm) = text "Named target" <+> ppr nm - ppr (ModuleTarget mod) = text "Module target" <+> ppr mod - -instance Binary name => Binary (AnnTarget name) where - put_ bh (NamedTarget a) = do - putByte bh 0 - put_ bh a - put_ bh (ModuleTarget a) = do - putByte bh 1 - put_ bh a - get bh = do - h <- getByte bh - case h of - 0 -> liftM NamedTarget $ get bh - _ -> liftM ModuleTarget $ get bh - -instance Outputable Annotation where - ppr ann = ppr (ann_target ann) - --- | A collection of annotations --- Can't use a type synonym or we hit bug #2412 due to source import -newtype AnnEnv = MkAnnEnv (UniqFM [AnnPayload]) - --- | An empty annotation environment. -emptyAnnEnv :: AnnEnv -emptyAnnEnv = MkAnnEnv emptyUFM - --- | Construct a new annotation environment that contains the list of --- annotations provided. -mkAnnEnv :: [Annotation] -> AnnEnv -mkAnnEnv = extendAnnEnvList emptyAnnEnv - --- | Add the given annotation to the environment. -extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv -extendAnnEnvList (MkAnnEnv env) anns - = MkAnnEnv $ addListToUFM_C (++) env $ - map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns - --- | Union two annotation environments. -plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv -plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2 - --- | Find the annotations attached to the given target as 'Typeable' --- values of your choice. If no deserializer is specified, --- only transient annotations will be returned. -findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] -findAnns deserialize (MkAnnEnv ann_env) - = (mapMaybe (fromSerialized deserialize)) - . (lookupWithDefaultUFM ann_env []) - --- | Find the annotations attached to the given target as 'Typeable' --- values of your choice. If no deserializer is specified, --- only transient annotations will be returned. -findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] -findAnnsByTypeRep (MkAnnEnv ann_env) target tyrep - = [ ws | Serialized tyrep' ws <- lookupWithDefaultUFM ann_env [] target - , tyrep' == tyrep ] - --- | Deserialize all annotations of a given type. This happens lazily, that is --- no deserialization will take place until the [a] is actually demanded and --- the [a] can also be empty (the UniqFM is not filtered). -deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a] -deserializeAnns deserialize (MkAnnEnv ann_env) - = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env diff --git a/main/CmdLineParser.hs b/main/CmdLineParser.hs deleted file mode 100644 --- a/main/CmdLineParser.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE CPP #-} - -------------------------------------------------------------------------------- --- --- | Command-line parser --- --- This is an abstract command-line parser used by DynFlags. --- --- (c) The University of Glasgow 2005 --- -------------------------------------------------------------------------------- - -module CmdLineParser - ( - processArgs, OptKind(..), GhcFlagMode(..), - CmdLineP(..), getCmdLineState, putCmdLineState, - Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, - errorsToGhcException, - - EwM, runEwM, addErr, addWarn, getArg, getCurLoc, liftEwM, deprecate - ) where - -#include "HsVersions.h" - -import Util -import Outputable -import Panic -import Bag -import SrcLoc - -import Data.Function -import Data.List - -import Control.Monad (liftM, ap) - --------------------------------------------------------- --- The Flag and OptKind types --------------------------------------------------------- - -data Flag m = Flag - { flagName :: String, -- Flag, without the leading "-" - flagOptKind :: OptKind m, -- What to do if we see it - flagGhcMode :: GhcFlagMode -- Which modes this flag affects - } - -defFlag :: String -> OptKind m -> Flag m -defFlag name optKind = Flag name optKind AllModes - -defGhcFlag :: String -> OptKind m -> Flag m -defGhcFlag name optKind = Flag name optKind OnlyGhc - -defGhciFlag :: String -> OptKind m -> Flag m -defGhciFlag name optKind = Flag name optKind OnlyGhci - -defHiddenFlag :: String -> OptKind m -> Flag m -defHiddenFlag name optKind = Flag name optKind HiddenFlag - --- | GHC flag modes describing when a flag has an effect. -data GhcFlagMode - = OnlyGhc -- ^ The flag only affects the non-interactive GHC - | OnlyGhci -- ^ The flag only affects the interactive GHC - | AllModes -- ^ The flag affects multiple ghc modes - | HiddenFlag -- ^ This flag should not be seen in cli completion - -data OptKind m -- Suppose the flag is -f - = NoArg (EwM m ()) -- -f all by itself - | HasArg (String -> EwM m ()) -- -farg or -f arg - | SepArg (String -> EwM m ()) -- -f arg - | Prefix (String -> EwM m ()) -- -farg - | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) - | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn - | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn - | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn - | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn - | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn - | PrefixPred (String -> Bool) (String -> EwM m ()) - | AnySuffixPred (String -> Bool) (String -> EwM m ()) - - --------------------------------------------------------- --- The EwM monad --------------------------------------------------------- - -type Err = Located String -type Warn = Located String -type Errs = Bag Err -type Warns = Bag Warn - --- EwM ("errors and warnings monad") is a monad --- transformer for m that adds an (err, warn) state -newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg - -> Errs -> Warns - -> m (Errs, Warns, a) } - -instance Monad m => Functor (EwM m) where - fmap = liftM - -instance Monad m => Applicative (EwM m) where - pure v = EwM (\_ e w -> return (e, w, v)) - (<*>) = ap - -instance Monad m => Monad (EwM m) where - (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w - unEwM (k r) l e' w') - -runEwM :: EwM m a -> m (Errs, Warns, a) -runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag - -setArg :: Located String -> EwM m () -> EwM m () -setArg l (EwM f) = EwM (\_ es ws -> f l es ws) - -addErr :: Monad m => String -> EwM m () -addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ())) - -addWarn :: Monad m => String -> EwM m () -addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc msg, ())) - -deprecate :: Monad m => String -> EwM m () -deprecate s = do - arg <- getArg - addWarn (arg ++ " is deprecated: " ++ s) - -getArg :: Monad m => EwM m String -getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) - -getCurLoc :: Monad m => EwM m SrcSpan -getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) - -liftEwM :: Monad m => m a -> EwM m a -liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) - - --------------------------------------------------------- --- A state monad for use in the command-line parser --------------------------------------------------------- - --- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m) -newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } - -instance Functor (CmdLineP s) where - fmap = liftM - -instance Applicative (CmdLineP s) where - pure a = CmdLineP $ \s -> (a, s) - (<*>) = ap - -instance Monad (CmdLineP s) where - m >>= k = CmdLineP $ \s -> - let (a, s') = runCmdLine m s - in runCmdLine (k a) s' - - -getCmdLineState :: CmdLineP s s -getCmdLineState = CmdLineP $ \s -> (s,s) -putCmdLineState :: s -> CmdLineP s () -putCmdLineState s = CmdLineP $ \_ -> ((),s) - - --------------------------------------------------------- --- Processing arguments --------------------------------------------------------- - -processArgs :: Monad m - => [Flag m] -- cmdline parser spec - -> [Located String] -- args - -> m ( [Located String], -- spare args - [Located String], -- errors - [Located String] ) -- warnings -processArgs spec args = do - (errs, warns, spare) <- runEwM action - return (spare, bagToList errs, bagToList warns) - where - action = process args [] - - -- process :: [Located String] -> [Located String] -> EwM m [Located String] - process [] spare = return (reverse spare) - - process (locArg@(L _ ('-' : arg)) : args) spare = - case findArg spec arg of - Just (rest, opt_kind) -> - case processOneArg opt_kind rest arg args of - Left err -> - let b = process args spare - in (setArg locArg $ addErr err) >> b - - Right (action,rest) -> - let b = process rest spare - in (setArg locArg $ action) >> b - - Nothing -> process args (locArg : spare) - - process (arg : args) spare = process args (arg : spare) - - -processOneArg :: OptKind m -> String -> String -> [Located String] - -> Either String (EwM m (), [Located String]) -processOneArg opt_kind rest arg args - = let dash_arg = '-' : arg - rest_no_eq = dropEq rest - in case opt_kind of - NoArg a -> ASSERT(null rest) Right (a, args) - - HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args) - | otherwise -> case args of - [] -> missingArgErr dash_arg - (L _ arg1:args1) -> Right (f arg1, args1) - - -- See Trac #9776 - SepArg f -> case args of - [] -> missingArgErr dash_arg - (L _ arg1:args1) -> Right (f arg1, args1) - - Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) - | otherwise -> unknownFlagErr dash_arg - - PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args) - | otherwise -> unknownFlagErr dash_arg - - PassFlag f | notNull rest -> unknownFlagErr dash_arg - | otherwise -> Right (f dash_arg, args) - - OptIntSuffix f | null rest -> Right (f Nothing, args) - | Just n <- parseInt rest_no_eq -> Right (f (Just n), args) - | otherwise -> Left ("malformed integer argument in " ++ dash_arg) - - IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) - | otherwise -> Left ("malformed integer argument in " ++ dash_arg) - - FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) - | otherwise -> Left ("malformed float argument in " ++ dash_arg) - - OptPrefix f -> Right (f rest_no_eq, args) - AnySuffix f -> Right (f dash_arg, args) - AnySuffixPred _ f -> Right (f dash_arg, args) - -findArg :: [Flag m] -> String -> Maybe (String, OptKind m) -findArg spec arg = - case sortBy (compare `on` (length . fst)) -- prefer longest matching flag - [ (removeSpaces rest, optKind) - | flag <- spec, - let optKind = flagOptKind flag, - Just rest <- [stripPrefix (flagName flag) arg], - arg_ok optKind rest arg ] - of - [] -> Nothing - (one:_) -> Just one - -arg_ok :: OptKind t -> [Char] -> String -> Bool -arg_ok (NoArg _) rest _ = null rest -arg_ok (HasArg _) _ _ = True -arg_ok (SepArg _) rest _ = null rest -arg_ok (Prefix _) rest _ = notNull rest -arg_ok (PrefixPred p _) rest _ = notNull rest && p (dropEq rest) -arg_ok (OptIntSuffix _) _ _ = True -arg_ok (IntSuffix _) _ _ = True -arg_ok (FloatSuffix _) _ _ = True -arg_ok (OptPrefix _) _ _ = True -arg_ok (PassFlag _) rest _ = null rest -arg_ok (AnySuffix _) _ _ = True -arg_ok (AnySuffixPred p _) _ arg = p arg - --- | Parse an Int --- --- Looks for "433" or "=342", with no trailing gubbins --- * n or =n => Just n --- * gibberish => Nothing -parseInt :: String -> Maybe Int -parseInt s = case reads s of - ((n,""):_) -> Just n - _ -> Nothing - -parseFloat :: String -> Maybe Float -parseFloat s = case reads s of - ((n,""):_) -> Just n - _ -> Nothing - --- | Discards a leading equals sign -dropEq :: String -> String -dropEq ('=' : s) = s -dropEq s = s - -unknownFlagErr :: String -> Either String a -unknownFlagErr f = Left ("unrecognised flag: " ++ f) - -missingArgErr :: String -> Either String a -missingArgErr f = Left ("missing argument for flag: " ++ f) - --------------------------------------------------------- --- Utils --------------------------------------------------------- - - --- See Note [Handling errors when parsing flags] -errorsToGhcException :: [(String, -- Location - String)] -- Error - -> GhcException -errorsToGhcException errs = - UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ] - -{- Note [Handling errors when parsing commandline flags] - -Parsing of static and mode flags happens before any session is started, i.e., -before the first call to 'GHC.withGhc'. Therefore, to report errors for -invalid usage of these two types of flags, we can not call any function that -needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags -is not set either). So we always print "on the commandline" as the location, -which is true except for Api users, which is probably ok. - -When reporting errors for invalid usage of dynamic flags we /can/ make use of -DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull. - -Before, we called unsafeGlobalDynFlags when an invalid (combination of) -flag(s) was given on the commandline, resulting in panics (#9963). --} diff --git a/main/CodeOutput.hs b/main/CodeOutput.hs deleted file mode 100644 --- a/main/CodeOutput.hs +++ /dev/null @@ -1,281 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section{Code output phase} --} - -{-# LANGUAGE CPP #-} - -module CodeOutput( codeOutput, outputForeignStubs ) where - -#include "HsVersions.h" - -import AsmCodeGen ( nativeCodeGen ) -import LlvmCodeGen ( llvmCodeGen ) - -import UniqSupply ( mkSplitUniqSupply ) - -import Finder ( mkStubPaths ) -import PprC ( writeCs ) -import CmmLint ( cmmLint ) -import Packages -import Cmm ( RawCmmGroup ) -import HscTypes -import DynFlags -import Config -import SysTools -import Stream (Stream) -import qualified Stream - -import ErrUtils -import Outputable -import Module -import SrcLoc - -import Control.Exception -import System.Directory -import System.FilePath -import System.IO -import Control.Monad (forM) - -{- -************************************************************************ -* * -\subsection{Steering} -* * -************************************************************************ --} - -codeOutput :: DynFlags - -> Module - -> FilePath - -> ModLocation - -> ForeignStubs - -> [(ForeignSrcLang, String)] - -- ^ additional files to be compiled with with the C compiler - -> [InstalledUnitId] - -> Stream IO RawCmmGroup () -- Compiled C-- - -> IO (FilePath, - (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), - [(ForeignSrcLang, FilePath)]{-foreign_fps-}) - -codeOutput dflags this_mod filenm location foreign_stubs foreign_files pkg_deps - cmm_stream - = - do { - -- Lint each CmmGroup as it goes past - ; let linted_cmm_stream = - if gopt Opt_DoCmmLinting dflags - then Stream.mapM do_lint cmm_stream - else cmm_stream - - do_lint cmm = withTiming (pure dflags) - (text "CmmLint"<+>brackets (ppr this_mod)) - (const ()) $ do - { case cmmLint dflags cmm of - Just err -> do { log_action dflags - dflags - NoReason - SevDump - noSrcSpan - (defaultDumpStyle dflags) - err - ; ghcExit dflags 1 - } - Nothing -> return () - ; return cmm - } - - ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs - ; foreign_fps <- forM foreign_files $ \(lang, file_contents) -> do - { fp <- outputForeignFile dflags lang file_contents; - ; return (lang, fp); - } - ; case hscTarget dflags of { - HscAsm -> outputAsm dflags this_mod location filenm - linted_cmm_stream; - HscC -> outputC dflags filenm linted_cmm_stream pkg_deps; - HscLlvm -> outputLlvm dflags filenm linted_cmm_stream; - HscInterpreted -> panic "codeOutput: HscInterpreted"; - HscNothing -> panic "codeOutput: HscNothing" - } - ; return (filenm, stubs_exist, foreign_fps) - } - -doOutput :: String -> (Handle -> IO a) -> IO a -doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action - -{- -************************************************************************ -* * -\subsection{C} -* * -************************************************************************ --} - -outputC :: DynFlags - -> FilePath - -> Stream IO RawCmmGroup () - -> [InstalledUnitId] - -> IO () - -outputC dflags filenm cmm_stream packages - = do - -- ToDo: make the C backend consume the C-- incrementally, by - -- pushing the cmm_stream inside (c.f. nativeCodeGen) - rawcmms <- Stream.collect cmm_stream - - -- figure out which header files to #include in the generated .hc file: - -- - -- * extra_includes from packages - -- * -#include options from the cmdline and OPTIONS pragmas - -- * the _stub.h file, if there is one. - -- - let rts = getPackageDetails dflags rtsUnitId - - let cc_injects = unlines (map mk_include (includes rts)) - mk_include h_file = - case h_file of - '"':_{-"-} -> "#include "++h_file - '<':_ -> "#include "++h_file - _ -> "#include \""++h_file++"\"" - - let pkg_names = map installedUnitIdString packages - - doOutput filenm $ \ h -> do - hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") - hPutStr h cc_injects - writeCs dflags h rawcmms - -{- -************************************************************************ -* * -\subsection{Assembler} -* * -************************************************************************ --} - -outputAsm :: DynFlags -> Module -> ModLocation -> FilePath - -> Stream IO RawCmmGroup () - -> IO () -outputAsm dflags this_mod location filenm cmm_stream - | cGhcWithNativeCodeGen == "YES" - = do ncg_uniqs <- mkSplitUniqSupply 'n' - - debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) - - _ <- {-# SCC "OutputAsm" #-} doOutput filenm $ - \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream - return () - - | otherwise - = panic "This compiler was built without a native code generator" - -{- -************************************************************************ -* * -\subsection{LLVM} -* * -************************************************************************ --} - -outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO () -outputLlvm dflags filenm cmm_stream - = do ncg_uniqs <- mkSplitUniqSupply 'n' - - {-# SCC "llvm_output" #-} doOutput filenm $ - \f -> {-# SCC "llvm_CodeGen" #-} - llvmCodeGen dflags f ncg_uniqs cmm_stream - -{- -************************************************************************ -* * -\subsection{Foreign import/export} -* * -************************************************************************ --} - -outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs - -> IO (Bool, -- Header file created - Maybe FilePath) -- C file created -outputForeignStubs dflags mod location stubs - = do - let stub_h = mkStubPaths dflags (moduleName mod) location - stub_c <- newTempName dflags "c" - - case stubs of - NoStubs -> - return (False, Nothing) - - ForeignStubs h_code c_code -> do - let - stub_c_output_d = pprCode CStyle c_code - stub_c_output_w = showSDoc dflags stub_c_output_d - - -- Header file protos for "foreign export"ed functions. - stub_h_output_d = pprCode CStyle h_code - stub_h_output_w = showSDoc dflags stub_h_output_d - - createDirectoryIfMissing True (takeDirectory stub_h) - - dumpIfSet_dyn dflags Opt_D_dump_foreign - "Foreign export header file" stub_h_output_d - - -- we need the #includes from the rts package for the stub files - let rts_includes = - let rts_pkg = getPackageDetails dflags rtsUnitId in - concatMap mk_include (includes rts_pkg) - mk_include i = "#include \"" ++ i ++ "\"\n" - - -- wrapper code mentions the ffi_arg type, which comes from ffi.h - ffi_includes | cLibFFI = "#include \"ffi.h\"\n" - | otherwise = "" - - stub_h_file_exists - <- outputForeignStubs_help stub_h stub_h_output_w - ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr - - dumpIfSet_dyn dflags Opt_D_dump_foreign - "Foreign export stubs" stub_c_output_d - - stub_c_file_exists - <- outputForeignStubs_help stub_c stub_c_output_w - ("#define IN_STG_CODE 0\n" ++ - "#include \"Rts.h\"\n" ++ - rts_includes ++ - ffi_includes ++ - cplusplus_hdr) - cplusplus_ftr - -- We're adding the default hc_header to the stub file, but this - -- isn't really HC code, so we need to define IN_STG_CODE==0 to - -- avoid the register variables etc. being enabled. - - return (stub_h_file_exists, if stub_c_file_exists - then Just stub_c - else Nothing ) - where - cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" - cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n" - - --- Don't use doOutput for dumping the f. export stubs --- since it is more than likely that the stubs file will --- turn out to be empty, in which case no file should be created. -outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool -outputForeignStubs_help _fname "" _header _footer = return False -outputForeignStubs_help fname doc_str header footer - = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") - return True - -outputForeignFile :: DynFlags -> ForeignSrcLang -> String -> IO FilePath -outputForeignFile dflags lang file_contents - = do - extension <- case lang of - LangC -> return "c" - LangCxx -> return "cpp" - LangObjc -> return "m" - LangObjcxx -> return "mm" - fp <- newTempName dflags extension - writeFile fp file_contents - return fp diff --git a/main/Constants.hs b/main/Constants.hs deleted file mode 100644 --- a/main/Constants.hs +++ /dev/null @@ -1,40 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Constants]{Info about this compilation} --} - -module Constants (module Constants) where - -import Config - -hiVersion :: Integer -hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer - --- All pretty arbitrary: - -mAX_TUPLE_SIZE :: Int -mAX_TUPLE_SIZE = 62 -- Should really match the number - -- of decls in Data.Tuple - -mAX_CTUPLE_SIZE :: Int -- Constraint tuples -mAX_CTUPLE_SIZE = 62 -- Should match the number of decls in GHC.Classes - -mAX_SUM_SIZE :: Int -mAX_SUM_SIZE = 62 - --- | Default maximum depth for both class instance search and type family --- reduction. See also Trac #5395. -mAX_REDUCTION_DEPTH :: Int -mAX_REDUCTION_DEPTH = 200 - --- | Default maximum constraint-solver iterations --- Typically there should be very few -mAX_SOLVER_ITERATIONS :: Int -mAX_SOLVER_ITERATIONS = 4 - -wORD64_SIZE :: Int -wORD64_SIZE = 8 - -tARGET_MAX_CHAR :: Int -tARGET_MAX_CHAR = 0x10ffff diff --git a/main/DriverMkDepend.hs b/main/DriverMkDepend.hs deleted file mode 100644 --- a/main/DriverMkDepend.hs +++ /dev/null @@ -1,406 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Makefile Dependency Generation --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module DriverMkDepend ( - doMkDependHS - ) where - -#include "HsVersions.h" - -import qualified GHC -import GhcMonad -import DynFlags -import Util -import HscTypes -import SysTools ( newTempName ) -import qualified SysTools -import Module -import Digraph ( SCC(..) ) -import Finder -import Outputable -import Panic -import SrcLoc -import Data.List -import FastString - -import Exception -import ErrUtils - -import System.Directory -import System.FilePath -import System.IO -import System.IO.Error ( isEOFError ) -import Control.Monad ( when ) -import Data.Maybe ( isJust ) - ------------------------------------------------------------------ --- --- The main function --- ------------------------------------------------------------------ - -doMkDependHS :: GhcMonad m => [FilePath] -> m () -doMkDependHS srcs = do - -- Initialisation - dflags0 <- GHC.getSessionDynFlags - - -- We kludge things a bit for dependency generation. Rather than - -- generating dependencies for each way separately, we generate - -- them once and then duplicate them for each way's osuf/hisuf. - -- We therefore do the initial dependency generation with an empty - -- way and .o/.hi extensions, regardless of any flags that might - -- be specified. - let dflags = dflags0 { - ways = [], - buildTag = mkBuildTag [], - hiSuf = "hi", - objectSuf = "o" - } - _ <- GHC.setSessionDynFlags dflags - - when (null (depSuffixes dflags)) $ liftIO $ - throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix") - - files <- liftIO $ beginMkDependHS dflags - - -- Do the downsweep to find all the modules - targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs - GHC.setTargets targets - let excl_mods = depExcludeMods dflags - mod_summaries <- GHC.depanal excl_mods True {- Allow dup roots -} - - -- Sort into dependency order - -- There should be no cycles - let sorted = GHC.topSortModuleGraph False mod_summaries Nothing - - -- Print out the dependencies if wanted - liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) - - -- Prcess them one by one, dumping results into makefile - -- and complaining about cycles - hsc_env <- getSession - root <- liftIO getCurrentDirectory - mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted - - -- If -ddump-mod-cycles, show cycles in the module graph - liftIO $ dumpModCycles dflags mod_summaries - - -- Tidy up - liftIO $ endMkDependHS dflags files - - -- Unconditional exiting is a bad idea. If an error occurs we'll get an - --exception; if that is not caught it's fine, but at least we have a - --chance to find out exactly what went wrong. Uncomment the following - --line if you disagree. - - --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) - ------------------------------------------------------------------ --- --- beginMkDependHs --- Create a temporary file, --- find the Makefile, --- slurp through it, etc --- ------------------------------------------------------------------ - -data MkDepFiles - = MkDep { mkd_make_file :: FilePath, -- Name of the makefile - mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile - mkd_tmp_file :: FilePath, -- Name of the temporary file - mkd_tmp_hdl :: Handle } -- Handle of the open temporary file - -beginMkDependHS :: DynFlags -> IO MkDepFiles -beginMkDependHS dflags = do - -- open a new temp file in which to stuff the dependency info - -- as we go along. - tmp_file <- newTempName dflags "dep" - tmp_hdl <- openFile tmp_file WriteMode - - -- open the makefile - let makefile = depMakefile dflags - exists <- doesFileExist makefile - mb_make_hdl <- - if not exists - then return Nothing - else do - makefile_hdl <- openFile makefile ReadMode - - -- slurp through until we get the magic start string, - -- copying the contents into dep_makefile - let slurp = do - l <- hGetLine makefile_hdl - if (l == depStartMarker) - then return () - else do hPutStrLn tmp_hdl l; slurp - - -- slurp through until we get the magic end marker, - -- throwing away the contents - let chuck = do - l <- hGetLine makefile_hdl - if (l == depEndMarker) - then return () - else chuck - - catchIO slurp - (\e -> if isEOFError e then return () else ioError e) - catchIO chuck - (\e -> if isEOFError e then return () else ioError e) - - return (Just makefile_hdl) - - - -- write the magic marker into the tmp file - hPutStrLn tmp_hdl depStartMarker - - return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, - mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) - - ------------------------------------------------------------------ --- --- processDeps --- ------------------------------------------------------------------ - -processDeps :: DynFlags - -> HscEnv - -> [ModuleName] - -> FilePath - -> Handle -- Write dependencies to here - -> SCC ModSummary - -> IO () --- Write suitable dependencies to handle --- Always: --- this.o : this.hs --- --- If the dependency is on something other than a .hi file: --- this.o this.p_o ... : dep --- otherwise --- this.o ... : dep.hi --- this.p_o ... : dep.p_hi --- ... --- (where .o is $osuf, and the other suffixes come from --- the cmdline -s options). --- --- For {-# SOURCE #-} imports the "hi" will be "hi-boot". - -processDeps dflags _ _ _ _ (CyclicSCC nodes) - = -- There shouldn't be any cycles; report them - throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes)) - -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) - = do { let extra_suffixes = depSuffixes dflags - include_pkg_deps = depIncludePkgDeps dflags - src_file = msHsFilePath node - obj_file = msObjFilePath node - obj_files = insertSuffixes obj_file extra_suffixes - - do_imp loc is_boot pkg_qual imp_mod - = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod - is_boot include_pkg_deps - ; case mb_hi of { - Nothing -> return () ; - Just hi_file -> do - { let hi_files = insertSuffixes hi_file extra_suffixes - write_dep (obj,hi) = writeDependency root hdl [obj] hi - - -- Add one dependency for each suffix; - -- e.g. A.o : B.hi - -- A.x_o : B.x_hi - ; mapM_ write_dep (obj_files `zip` hi_files) }}} - - - -- Emit std dependency of the object(s) on the source file - -- Something like A.o : A.hs - ; writeDependency root hdl obj_files src_file - - -- Emit a dependency for each import - - ; let do_imps is_boot idecls = sequence_ - [ do_imp loc is_boot mb_pkg mod - | (mb_pkg, L loc mod) <- idecls, - mod `notElem` excl_mods ] - - ; do_imps True (ms_srcimps node) - ; do_imps False (ms_imps node) - } - - -findDependency :: HscEnv - -> SrcSpan - -> Maybe FastString -- package qualifier, if any - -> ModuleName -- Imported module - -> IsBootInterface -- Source import - -> Bool -- Record dependency on package modules - -> IO (Maybe FilePath) -- Interface file file -findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps - = do { -- Find the module; this will be fast because - -- we've done it once during downsweep - r <- findImportedModule hsc_env imp pkg - ; case r of - Found loc _ - -- Home package: just depend on the .hi or hi-boot file - | isJust (ml_hs_file loc) || include_pkg_deps - -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) - - -- Not in this package: we don't need a dependency - | otherwise - -> return Nothing - - fail -> - let dflags = hsc_dflags hsc_env - in throwOneError $ mkPlainErrMsg dflags srcloc $ - cannotFindModule dflags imp fail - } - ------------------------------ -writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () --- (writeDependency r h [t1,t2] dep) writes to handle h the dependency --- t1 t2 : dep -writeDependency root hdl targets dep - = do let -- We need to avoid making deps on - -- c:/foo/... - -- on cygwin as make gets confused by the : - -- Making relative deps avoids some instances of this. - dep' = makeRelative root dep - forOutput = escapeSpaces . reslash Forwards . normalise - output = unwords (map forOutput targets) ++ " : " ++ forOutput dep' - hPutStrLn hdl output - ------------------------------ -insertSuffixes - :: FilePath -- Original filename; e.g. "foo.o" - -> [String] -- Suffix prefixes e.g. ["x_", "y_"] - -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] - -- Note that that the extra bit gets inserted *before* the old suffix - -- We assume the old suffix contains no dots, so we know where to - -- split it -insertSuffixes file_name extras - = [ basename <.> (extra ++ suffix) | extra <- extras ] - where - (basename, suffix) = case splitExtension file_name of - -- Drop the "." from the extension - (b, s) -> (b, drop 1 s) - - ------------------------------------------------------------------ --- --- endMkDependHs --- Complete the makefile, close the tmp file etc --- ------------------------------------------------------------------ - -endMkDependHS :: DynFlags -> MkDepFiles -> IO () - -endMkDependHS dflags - (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, - mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) - = do - -- write the magic marker into the tmp file - hPutStrLn tmp_hdl depEndMarker - - case makefile_hdl of - Nothing -> return () - Just hdl -> do - - -- slurp the rest of the original makefile and copy it into the output - let slurp = do - l <- hGetLine hdl - hPutStrLn tmp_hdl l - slurp - - catchIO slurp - (\e -> if isEOFError e then return () else ioError e) - - hClose hdl - - hClose tmp_hdl -- make sure it's flushed - - -- Create a backup of the original makefile - when (isJust makefile_hdl) - (SysTools.copy dflags ("Backing up " ++ makefile) - makefile (makefile++".bak")) - - -- Copy the new makefile in place - SysTools.copy dflags "Installing new makefile" tmp_file makefile - - ------------------------------------------------------------------ --- Module cycles ------------------------------------------------------------------ - -dumpModCycles :: DynFlags -> [ModSummary] -> IO () -dumpModCycles dflags mod_summaries - | not (dopt Opt_D_dump_mod_cycles dflags) - = return () - - | null cycles - = putMsg dflags (text "No module cycles") - - | otherwise - = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles) - where - - cycles :: [[ModSummary]] - cycles = [ c | CyclicSCC c <- GHC.topSortModuleGraph True mod_summaries Nothing ] - - pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------")) - $$ pprCycle c $$ blankLine - | (n,c) <- [1..] `zip` cycles ] - -pprCycle :: [ModSummary] -> SDoc --- Print a cycle, but show only the imports within the cycle -pprCycle summaries = pp_group (CyclicSCC summaries) - where - cycle_mods :: [ModuleName] -- The modules in this cycle - cycle_mods = map (moduleName . ms_mod) summaries - - pp_group (AcyclicSCC ms) = pp_ms ms - pp_group (CyclicSCC mss) - = ASSERT( not (null boot_only) ) - -- The boot-only list must be non-empty, else there would - -- be an infinite chain of non-boot imoprts, and we've - -- already checked for that in processModDeps - pp_ms loop_breaker $$ vcat (map pp_group groups) - where - (boot_only, others) = partition is_boot_only mss - is_boot_only ms = not (any in_group (map snd (ms_imps ms))) - in_group (L _ m) = m `elem` group_mods - group_mods = map (moduleName . ms_mod) mss - - loop_breaker = head boot_only - all_others = tail boot_only ++ others - groups = GHC.topSortModuleGraph True all_others Nothing - - pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) - <+> (pp_imps empty (map snd (ms_imps summary)) $$ - pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary))) - where - mod_str = moduleNameString (moduleName (ms_mod summary)) - - pp_imps :: SDoc -> [Located ModuleName] -> SDoc - pp_imps _ [] = empty - pp_imps what lms - = case [m | L _ m <- lms, m `elem` cycle_mods] of - [] -> empty - ms -> what <+> text "imports" <+> - pprWithCommas ppr ms - ------------------------------------------------------------------ --- --- Flags --- ------------------------------------------------------------------ - -depStartMarker, depEndMarker :: String -depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" -depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" - diff --git a/main/DriverPhases.hs b/main/DriverPhases.hs deleted file mode 100644 --- a/main/DriverPhases.hs +++ /dev/null @@ -1,375 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- $Id: DriverPhases.hs,v 1.38 2005/05/17 11:01:59 simonmar Exp $ --- --- GHC Driver --- --- (c) The University of Glasgow 2002 --- ------------------------------------------------------------------------------ - -module DriverPhases ( - HscSource(..), isHsBootOrSig, hscSourceString, - Phase(..), - happensBefore, eqPhase, anyHsc, isStopLn, - startPhase, - phaseInputExt, - - isHaskellishSuffix, - isHaskellSrcSuffix, - isBackpackishSuffix, - isObjectSuffix, - isCishSuffix, - isDynLibSuffix, - isHaskellUserSrcSuffix, - isHaskellSigSuffix, - isSourceSuffix, - - isHaskellishTarget, - - isHaskellishFilename, - isHaskellSrcFilename, - isHaskellSigFilename, - isObjectFilename, - isCishFilename, - isDynLibFilename, - isHaskellUserSrcFilename, - isSourceFilename - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} DynFlags -import Outputable -import Platform -import System.FilePath -import Binary -import Util - ------------------------------------------------------------------------------ --- Phases - -{- - Phase of the | Suffix saying | Flag saying | (suffix of) - compilation system | ``start here''| ``stop after''| output file - - literate pre-processor | .lhs | - | - - C pre-processor (opt.) | - | -E | - - Haskell compiler | .hs | -C, -S | .hc, .s - C compiler (opt.) | .hc or .c | -S | .s - assembler | .s or .S | -c | .o - linker | other | - | a.out --} - --- Note [HscSource types] --- ~~~~~~~~~~~~~~~~~~~~~~ --- There are three types of source file for Haskell code: --- --- * HsSrcFile is an ordinary hs file which contains code, --- --- * HsBootFile is an hs-boot file, which is used to break --- recursive module imports (there will always be an --- HsSrcFile associated with it), and --- --- * HsigFile is an hsig file, which contains only type --- signatures and is used to specify signatures for --- modules. --- --- Syntactically, hs-boot files and hsig files are quite similar: they --- only include type signatures and must be associated with an --- actual HsSrcFile. isHsBootOrSig allows us to abstract over code --- which is indifferent to which. However, there are some important --- differences, mostly owing to the fact that hsigs are proper --- modules (you `import Sig` directly) whereas HsBootFiles are --- temporary placeholders (you `import {-# SOURCE #-} Mod). --- When we finish compiling the true implementation of an hs-boot, --- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the --- other hand, is never replaced (in particular, we *cannot* use the --- HomeModInfo of the original HsSrcFile backing the signature, since it --- will export too many symbols.) --- --- Additionally, while HsSrcFile is the only Haskell file --- which has *code*, we do generate .o files for HsigFile, because --- this is how the recompilation checker figures out if a file --- needs to be recompiled. These are fake object files which --- should NOT be linked against. - -data HscSource - = HsSrcFile | HsBootFile | HsigFile - deriving( Eq, Ord, Show ) - -- Ord needed for the finite maps we build in CompManager - -instance Binary HscSource where - put_ bh HsSrcFile = putByte bh 0 - put_ bh HsBootFile = putByte bh 1 - put_ bh HsigFile = putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> return HsSrcFile - 1 -> return HsBootFile - _ -> return HsigFile - -hscSourceString :: HscSource -> String -hscSourceString HsSrcFile = "" -hscSourceString HsBootFile = "[boot]" -hscSourceString HsigFile = "[sig]" - --- See Note [isHsBootOrSig] -isHsBootOrSig :: HscSource -> Bool -isHsBootOrSig HsBootFile = True -isHsBootOrSig HsigFile = True -isHsBootOrSig _ = False - -data Phase - = Unlit HscSource - | Cpp HscSource - | HsPp HscSource - | Hsc HscSource - | Ccxx -- Compile C++ - | Cc -- Compile C - | Cobjc -- Compile Objective-C - | Cobjcxx -- Compile Objective-C++ - | HCc -- Haskellised C (as opposed to vanilla C) compilation - | Splitter -- Assembly file splitter (part of '-split-objs') - | SplitAs -- Assembler for split assembly files (part of '-split-objs') - | As Bool -- Assembler for regular assembly files (Bool: with-cpp) - | LlvmOpt -- Run LLVM opt tool over llvm assembly - | LlvmLlc -- LLVM bitcode to native assembly - | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM - | CmmCpp -- pre-process Cmm source - | Cmm -- parse & compile Cmm code - | MergeForeign -- merge in the foreign object files - - -- The final phase is a pseudo-phase that tells the pipeline to stop. - -- There is no runPhase case for it. - | StopLn -- Stop, but linking will follow, so generate .o file - deriving (Eq, Show) - -instance Outputable Phase where - ppr p = text (show p) - -anyHsc :: Phase -anyHsc = Hsc (panic "anyHsc") - -isStopLn :: Phase -> Bool -isStopLn StopLn = True -isStopLn _ = False - -eqPhase :: Phase -> Phase -> Bool --- Equality of constructors, ignoring the HscSource field --- NB: the HscSource field can be 'bot'; see anyHsc above -eqPhase (Unlit _) (Unlit _) = True -eqPhase (Cpp _) (Cpp _) = True -eqPhase (HsPp _) (HsPp _) = True -eqPhase (Hsc _) (Hsc _) = True -eqPhase Cc Cc = True -eqPhase Cobjc Cobjc = True -eqPhase HCc HCc = True -eqPhase Splitter Splitter = True -eqPhase SplitAs SplitAs = True -eqPhase (As x) (As y) = x == y -eqPhase LlvmOpt LlvmOpt = True -eqPhase LlvmLlc LlvmLlc = True -eqPhase LlvmMangle LlvmMangle = True -eqPhase CmmCpp CmmCpp = True -eqPhase Cmm Cmm = True -eqPhase MergeForeign MergeForeign = True -eqPhase StopLn StopLn = True -eqPhase Ccxx Ccxx = True -eqPhase Cobjcxx Cobjcxx = True -eqPhase _ _ = False - -{- Note [Partial ordering on phases] - -We want to know which phases will occur before which others. This is used for -sanity checking, to ensure that the pipeline will stop at some point (see -DriverPipeline.runPipeline). - -A < B iff A occurs before B in a normal compilation pipeline. - -There is explicitly not a total ordering on phases, because in registerised -builds, the phase `HsC` doesn't happen before nor after any other phase. - -Although we check that a normal user doesn't set the stop_phase to HsC through -use of -C with registerised builds (in Main.checkOptions), it is still -possible for a ghc-api user to do so. So be careful when using the function -happensBefore, and don't think that `not (a <= b)` implies `b < a`. --} -happensBefore :: DynFlags -> Phase -> Phase -> Bool -happensBefore dflags p1 p2 = p1 `happensBefore'` p2 - where StopLn `happensBefore'` _ = False - x `happensBefore'` y = after_x `eqPhase` y - || after_x `happensBefore'` y - where after_x = nextPhase dflags x - -nextPhase :: DynFlags -> Phase -> Phase -nextPhase dflags p - -- A conservative approximation to the next phase, used in happensBefore - = case p of - Unlit sf -> Cpp sf - Cpp sf -> HsPp sf - HsPp sf -> Hsc sf - Hsc _ -> maybeHCc - Splitter -> SplitAs - LlvmOpt -> LlvmLlc - LlvmLlc -> LlvmMangle - LlvmMangle -> As False - SplitAs -> MergeForeign - As _ -> MergeForeign - Ccxx -> As False - Cc -> As False - Cobjc -> As False - Cobjcxx -> As False - CmmCpp -> Cmm - Cmm -> maybeHCc - HCc -> As False - MergeForeign -> StopLn - StopLn -> panic "nextPhase: nothing after StopLn" - where maybeHCc = if platformUnregisterised (targetPlatform dflags) - then HCc - else As False - --- the first compilation phase for a given file is determined --- by its suffix. -startPhase :: String -> Phase -startPhase "lhs" = Unlit HsSrcFile -startPhase "lhs-boot" = Unlit HsBootFile -startPhase "lhsig" = Unlit HsigFile -startPhase "hs" = Cpp HsSrcFile -startPhase "hs-boot" = Cpp HsBootFile -startPhase "hsig" = Cpp HsigFile -startPhase "hscpp" = HsPp HsSrcFile -startPhase "hspp" = Hsc HsSrcFile -startPhase "hc" = HCc -startPhase "c" = Cc -startPhase "cpp" = Ccxx -startPhase "C" = Cc -startPhase "m" = Cobjc -startPhase "M" = Cobjcxx -startPhase "mm" = Cobjcxx -startPhase "cc" = Ccxx -startPhase "cxx" = Ccxx -startPhase "split_s" = Splitter -startPhase "s" = As False -startPhase "S" = As True -startPhase "ll" = LlvmOpt -startPhase "bc" = LlvmLlc -startPhase "lm_s" = LlvmMangle -startPhase "o" = StopLn -startPhase "cmm" = CmmCpp -startPhase "cmmcpp" = Cmm -startPhase _ = StopLn -- all unknown file types - --- This is used to determine the extension for the output from the --- current phase (if it generates a new file). The extension depends --- on the next phase in the pipeline. -phaseInputExt :: Phase -> String -phaseInputExt (Unlit HsSrcFile) = "lhs" -phaseInputExt (Unlit HsBootFile) = "lhs-boot" -phaseInputExt (Unlit HsigFile) = "lhsig" -phaseInputExt (Cpp _) = "lpp" -- intermediate only -phaseInputExt (HsPp _) = "hscpp" -- intermediate only -phaseInputExt (Hsc _) = "hspp" -- intermediate only - -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x - -- because runPipeline uses the StopBefore phase to pick the - -- output filename. That could be fixed, but watch out. -phaseInputExt HCc = "hc" -phaseInputExt Ccxx = "cpp" -phaseInputExt Cobjc = "m" -phaseInputExt Cobjcxx = "mm" -phaseInputExt Cc = "c" -phaseInputExt Splitter = "split_s" -phaseInputExt (As True) = "S" -phaseInputExt (As False) = "s" -phaseInputExt LlvmOpt = "ll" -phaseInputExt LlvmLlc = "bc" -phaseInputExt LlvmMangle = "lm_s" -phaseInputExt SplitAs = "split_s" -phaseInputExt CmmCpp = "cmm" -phaseInputExt Cmm = "cmmcpp" -phaseInputExt MergeForeign = "o" -phaseInputExt StopLn = "o" - -haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, - haskellish_user_src_suffixes, haskellish_sig_suffixes - :: [String] --- When a file with an extension in the haskellish_src_suffixes group is --- loaded in --make mode, its imports will be loaded too. -haskellish_src_suffixes = haskellish_user_src_suffixes ++ - [ "hspp", "hscpp" ] -haskellish_suffixes = haskellish_src_suffixes ++ - [ "hc", "cmm", "cmmcpp" ] -cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] - --- Will not be deleted as temp files: -haskellish_user_src_suffixes = - haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ] -haskellish_sig_suffixes = [ "hsig", "lhsig" ] -backpackish_suffixes = [ "bkp" ] - -objish_suffixes :: Platform -> [String] --- Use the appropriate suffix for the system on which --- the GHC-compiled code will run -objish_suffixes platform = case platformOS platform of - OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] - _ -> [ "o" ] - -dynlib_suffixes :: Platform -> [String] -dynlib_suffixes platform = case platformOS platform of - OSMinGW32 -> ["dll", "DLL"] - OSDarwin -> ["dylib", "so"] - _ -> ["so"] - -isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, - isHaskellUserSrcSuffix, isHaskellSigSuffix - :: String -> Bool -isHaskellishSuffix s = s `elem` haskellish_suffixes -isBackpackishSuffix s = s `elem` backpackish_suffixes -isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes -isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes -isCishSuffix s = s `elem` cish_suffixes -isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes - -isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool -isObjectSuffix platform s = s `elem` objish_suffixes platform -isDynLibSuffix platform s = s `elem` dynlib_suffixes platform - -isSourceSuffix :: String -> Bool -isSourceSuffix suff = isHaskellishSuffix suff - || isCishSuffix suff - || isBackpackishSuffix suff - --- | When we are given files (modified by -x arguments) we need --- to determine if they are Haskellish or not to figure out --- how we should try to compile it. The rules are: --- --- 1. If no -x flag was specified, we check to see if --- the file looks like a module name, has no extension, --- or has a Haskell source extension. --- --- 2. If an -x flag was specified, we just make sure the --- specified suffix is a Haskell one. -isHaskellishTarget :: (String, Maybe Phase) -> Bool -isHaskellishTarget (f,Nothing) = - looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) -isHaskellishTarget (_,Just phase) = - phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm - , StopLn] - -isHaskellishFilename, isHaskellSrcFilename, isCishFilename, - isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename - :: FilePath -> Bool --- takeExtension return .foo, so we drop 1 to get rid of the . -isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) -isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) -isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) -isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) -isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) -isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) - -isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool -isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) -isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f) - diff --git a/main/DriverPipeline.hs b/main/DriverPipeline.hs deleted file mode 100644 --- a/main/DriverPipeline.hs +++ /dev/null @@ -1,2410 +0,0 @@ -{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation #-} -{-# OPTIONS_GHC -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - ------------------------------------------------------------------------------ --- --- GHC Driver --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module DriverPipeline ( - -- Run a series of compilation steps in a pipeline, for a - -- collection of source files. - oneShot, compileFile, - - -- Interfaces for the batch-mode driver - linkBinary, - - -- Interfaces for the compilation manager (interpreted/batch-mode) - preprocess, - compileOne, compileOne', - link, - - -- Exports for hooks to override runPhase and link - PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..), - phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv, - hscPostBackendPhase, getLocation, setModLocation, setDynFlags, - runPhase, exeFileName, - mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary, - maybeCreateManifest, - linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode - ) where - -#include "HsVersions.h" - -import PipelineMonad -import Packages -import HeaderInfo -import DriverPhases -import SysTools -import Elf -import HscMain -import Finder -import HscTypes hiding ( Hsc ) -import Outputable -import Module -import ErrUtils -import DynFlags -import Config -import Panic -import Util -import StringBuffer ( hGetStringBuffer ) -import BasicTypes ( SuccessFlag(..) ) -import Maybes ( expectJust ) -import SrcLoc -import LlvmCodeGen ( llvmFixupAsm ) -import MonadUtils -import Platform -import TcRnTypes -import Hooks -import qualified GHC.LanguageExtensions as LangExt - -import Exception -import System.Directory -import System.FilePath -import System.IO -import Control.Monad -import Data.List ( isSuffixOf ) -import Data.Maybe -import Data.Version - --- --------------------------------------------------------------------------- --- Pre-process - --- | Just preprocess a file, put the result in a temp. file (used by the --- compilation manager during the summary phase). --- --- We return the augmented DynFlags, because they contain the result --- of slurping in the OPTIONS pragmas - -preprocess :: HscEnv - -> (FilePath, Maybe Phase) -- ^ filename and starting phase - -> IO (DynFlags, FilePath) -preprocess hsc_env (filename, mb_phase) = - ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) - runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase) - Nothing Temporary Nothing{-no ModLocation-} []{-no foreign objects-} - --- --------------------------------------------------------------------------- - --- | Compile --- --- Compile a single module, under the control of the compilation manager. --- --- This is the interface between the compilation manager and the --- compiler proper (hsc), where we deal with tedious details like --- reading the OPTIONS pragma from the source file, converting the --- C or assembly that GHC produces into an object file, and compiling --- FFI stub files. --- --- NB. No old interface can also mean that the source has changed. - -compileOne :: HscEnv - -> ModSummary -- ^ summary for module being compiled - -> Int -- ^ module N ... - -> Int -- ^ ... of M - -> Maybe ModIface -- ^ old interface, if we have one - -> Maybe Linkable -- ^ old linkable, if we have one - -> SourceModified - -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful - -compileOne = compileOne' Nothing (Just batchMsg) - -compileOne' :: Maybe TcGblEnv - -> Maybe Messager - -> HscEnv - -> ModSummary -- ^ summary for module being compiled - -> Int -- ^ module N ... - -> Int -- ^ ... of M - -> Maybe ModIface -- ^ old interface, if we have one - -> Maybe Linkable -- ^ old linkable, if we have one - -> SourceModified - -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful - -compileOne' m_tc_result mHscMessage - hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable - source_modified0 - = do - - debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) - - (status, hmi0) <- hscIncrementalCompile - always_do_basic_recompilation_check - m_tc_result mHscMessage - hsc_env summary source_modified mb_old_iface (mod_index, nmods) - - let flags = hsc_dflags hsc_env0 - in do unless (gopt Opt_KeepHiFiles flags) $ - addFilesToClean flags [ml_hi_file $ ms_location summary] - unless (gopt Opt_KeepOFiles flags) $ - addFilesToClean flags [ml_obj_file $ ms_location summary] - - case (status, hsc_lang) of - (HscUpToDate, _) -> - -- TODO recomp014 triggers this assert. What's going on?! - -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) ) - return hmi0 { hm_linkable = maybe_old_linkable } - (HscNotGeneratingCode, HscNothing) -> - let mb_linkable = if isHsBootOrSig src_flavour - then Nothing - -- TODO: Questionable. - else Just (LM (ms_hs_date summary) this_mod []) - in return hmi0 { hm_linkable = mb_linkable } - (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode" - (_, HscNothing) -> panic "compileOne HscNothing" - (HscUpdateBoot, HscInterpreted) -> do - return hmi0 - (HscUpdateBoot, _) -> do - touchObjectFile dflags object_filename - return hmi0 - (HscUpdateSig, HscInterpreted) -> - let linkable = LM (ms_hs_date summary) this_mod [] - in return hmi0 { hm_linkable = Just linkable } - (HscUpdateSig, _) -> do - output_fn <- getOutputFilename next_phase - Temporary basename dflags next_phase (Just location) - - -- #10660: Use the pipeline instead of calling - -- compileEmptyStub directly, so -dynamic-too gets - -- handled properly - _ <- runPipeline StopLn hsc_env - (output_fn, - Just (HscOut src_flavour - mod_name HscUpdateSig)) - (Just basename) - Persistent - (Just location) - [] - o_time <- getModificationUTCTime object_filename - let linkable = LM o_time this_mod [DotO object_filename] - return hmi0 { hm_linkable = Just linkable } - (HscRecomp cgguts summary, HscInterpreted) -> do - (hasStub, comp_bc, spt_entries) <- - hscInteractive hsc_env cgguts summary - - stub_o <- case hasStub of - Nothing -> return [] - Just stub_c -> do - stub_o <- compileStub hsc_env stub_c - return [DotO stub_o] - - let hs_unlinked = [BCOs comp_bc spt_entries] - unlinked_time = ms_hs_date summary - -- Why do we use the timestamp of the source file here, - -- rather than the current time? This works better in - -- the case where the local clock is out of sync - -- with the filesystem's clock. It's just as accurate: - -- if the source is modified, then the linkable will - -- be out of date. - let linkable = LM unlinked_time (ms_mod summary) - (hs_unlinked ++ stub_o) - return hmi0 { hm_linkable = Just linkable } - (HscRecomp cgguts summary, _) -> do - output_fn <- getOutputFilename next_phase - Temporary basename dflags next_phase (Just location) - -- We're in --make mode: finish the compilation pipeline. - _ <- runPipeline StopLn hsc_env - (output_fn, - Just (HscOut src_flavour mod_name (HscRecomp cgguts summary))) - (Just basename) - Persistent - (Just location) - [] - -- The object filename comes from the ModLocation - o_time <- getModificationUTCTime object_filename - let linkable = LM o_time this_mod [DotO object_filename] - return hmi0 { hm_linkable = Just linkable } - - where dflags0 = ms_hspp_opts summary - - this_mod = ms_mod summary - location = ms_location summary - input_fn = expectJust "compile:hs" (ml_hs_file location) - input_fnpp = ms_hspp_file summary - mod_graph = hsc_mod_graph hsc_env0 - needsTH = any (xopt LangExt.TemplateHaskell . ms_hspp_opts) mod_graph - needsQQ = any (xopt LangExt.QuasiQuotes . ms_hspp_opts) mod_graph - needsLinker = needsTH || needsQQ - isDynWay = any (== WayDyn) (ways dflags0) - isProfWay = any (== WayProf) (ways dflags0) - internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0) - - src_flavour = ms_hsc_src summary - mod_name = ms_mod_name summary - next_phase = hscPostBackendPhase dflags src_flavour hsc_lang - object_filename = ml_obj_file location - - -- #8180 - when using TemplateHaskell, switch on -dynamic-too so - -- the linker can correctly load the object files. This isn't necessary - -- when using -fexternal-interpreter. - dflags1 = if needsLinker && dynamicGhc && internalInterpreter && - not isDynWay && not isProfWay - then gopt_set dflags0 Opt_BuildDynamicToo - else dflags0 - - basename = dropExtension input_fn - - -- We add the directory in which the .hs files resides) to the import - -- path. This is needed when we try to compile the .hc file later, if it - -- imports a _stub.h file that we created here. - current_dir = takeDirectory basename - old_paths = includePaths dflags1 - prevailing_dflags = hsc_dflags hsc_env0 - dflags = - dflags1 { includePaths = current_dir : old_paths - , log_action = log_action prevailing_dflags - , log_finaliser = log_finaliser prevailing_dflags } - -- use the prevailing log_action / log_finaliser, - -- not the one cached in the summary. This is so - -- that we can change the log_action without having - -- to re-summarize all the source files. - hsc_env = hsc_env0 {hsc_dflags = dflags} - - -- Figure out what lang we're generating - hsc_lang = hscTarget dflags - - -- -fforce-recomp should also work with --make - force_recomp = gopt Opt_ForceRecomp dflags - source_modified - | force_recomp = SourceModified - | otherwise = source_modified0 - - always_do_basic_recompilation_check = case hsc_lang of - HscInterpreted -> True - _ -> False - ------------------------------------------------------------------------------ --- stub .h and .c files (for foreign export support), and cc files. - --- The _stub.c file is derived from the haskell source file, possibly taking --- into account the -stubdir option. --- --- The object file created by compiling the _stub.c file is put into a --- temporary file, which will be later combined with the main .o file --- (see the MergeForeigns phase). --- --- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files --- from TH, that are then compiled and linked to the module. This is --- useful to implement facilities such as inline-c. - -compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath -compileForeign hsc_env lang stub_c = do - let phase = case lang of - LangC -> Cc - LangCxx -> Ccxx - LangObjc -> Cobjc - LangObjcxx -> Cobjcxx - (_, stub_o) <- runPipeline StopLn hsc_env - (stub_c, Just (RealPhase phase)) - Nothing Temporary Nothing{-no ModLocation-} [] - - return stub_o - -compileStub :: HscEnv -> FilePath -> IO FilePath -compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c - -compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () -compileEmptyStub dflags hsc_env basename location mod_name = do - -- To maintain the invariant that every Haskell file - -- compiles to object code, we make an empty (but - -- valid) stub object file for signatures. However, - -- we make sure this object file has a unique symbol, - -- so that ranlib on OS X doesn't complain, see - -- http://ghc.haskell.org/trac/ghc/ticket/12673 - -- and https://github.com/haskell/cabal/issues/2257 - empty_stub <- newTempName dflags "c" - let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;" - writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) - _ <- runPipeline StopLn hsc_env - (empty_stub, Nothing) - (Just basename) - Persistent - (Just location) - [] - return () - --- --------------------------------------------------------------------------- --- Link - -link :: GhcLink -- interactive or batch - -> DynFlags -- dynamic flags - -> Bool -- attempt linking in batch mode? - -> HomePackageTable -- what to link - -> IO SuccessFlag - --- For the moment, in the batch linker, we don't bother to tell doLink --- which packages to link -- it just tries all that are available. --- batch_attempt_linking should only be *looked at* in batch mode. It --- should only be True if the upsweep was successful and someone --- exports main, i.e., we have good reason to believe that linking --- will succeed. - -link ghcLink dflags - = lookupHook linkHook l dflags ghcLink dflags - where - l LinkInMemory _ _ _ - = if cGhcWithInterpreter == "YES" - then -- Not Linking...(demand linker will do the job) - return Succeeded - else panicBadLink LinkInMemory - - l NoLink _ _ _ - = return Succeeded - - l LinkBinary dflags batch_attempt_linking hpt - = link' dflags batch_attempt_linking hpt - - l LinkStaticLib dflags batch_attempt_linking hpt - = link' dflags batch_attempt_linking hpt - - l LinkDynLib dflags batch_attempt_linking hpt - = link' dflags batch_attempt_linking hpt - -panicBadLink :: GhcLink -> a -panicBadLink other = panic ("link: GHC not built to link this way: " ++ - show other) - -link' :: DynFlags -- dynamic flags - -> Bool -- attempt linking in batch mode? - -> HomePackageTable -- what to link - -> IO SuccessFlag - -link' dflags batch_attempt_linking hpt - | batch_attempt_linking - = do - let - staticLink = case ghcLink dflags of - LinkStaticLib -> True - _ -> platformBinariesAreStaticLibs (targetPlatform dflags) - - home_mod_infos = eltsHpt hpt - - -- the packages we depend on - pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos - - -- the linkables to link - linkables = map (expectJust "link".hm_linkable) home_mod_infos - - debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) - - -- check for the -no-link flag - if isNoLink (ghcLink dflags) - then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") - return Succeeded - else do - - let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) - obj_files = concatMap getOfiles linkables - - exe_file = exeFileName staticLink dflags - - linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps - - if not (gopt Opt_ForceRecomp dflags) && not linking_needed - then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.") - return Succeeded - else do - - compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...") - - -- Don't showPass in Batch mode; doLink will do that for us. - let link = case ghcLink dflags of - LinkBinary -> linkBinary - LinkStaticLib -> linkStaticLibCheck - LinkDynLib -> linkDynLibCheck - other -> panicBadLink other - link dflags obj_files pkg_deps - - debugTraceMsg dflags 3 (text "link: done") - - -- linkBinary only returns if it succeeds - return Succeeded - - | otherwise - = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ - text " Main.main not exported; not linking.") - return Succeeded - - -linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool -linkingNeeded dflags staticLink linkables pkg_deps = do - -- if the modification time on the executable is later than the - -- modification times on all of the objects and libraries, then omit - -- linking (unless the -fforce-recomp flag was given). - let exe_file = exeFileName staticLink dflags - e_exe_time <- tryIO $ getModificationUTCTime exe_file - case e_exe_time of - Left _ -> return True - Right t -> do - -- first check object files and extra_ld_inputs - let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] - e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs - let (errs,extra_times) = splitEithers e_extra_times - let obj_times = map linkableTime linkables ++ extra_times - if not (null errs) || any (t <) obj_times - then return True - else do - - -- next, check libraries. XXX this only checks Haskell libraries, - -- not extra_libraries or -l things from the command line. - let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib) - | Just c <- map (lookupInstalledPackage dflags) pkg_deps, - lib <- packageHsLibs dflags c ] - - pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs - if any isNothing pkg_libfiles then return True else do - e_lib_times <- mapM (tryIO . getModificationUTCTime) - (catMaybes pkg_libfiles) - let (lib_errs,lib_times) = splitEithers e_lib_times - if not (null lib_errs) || any (t <) lib_times - then return True - else checkLinkInfo dflags pkg_deps exe_file - --- Returns 'False' if it was, and we can avoid linking, because the --- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool -checkLinkInfo dflags pkg_deps exe_file - | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - -- ToDo: Windows and OS X do not use the ELF binary format, so - -- readelf does not work there. We need to find another way to do - -- this. - = return False -- conservatively we should return True, but not - -- linking in this case was the behaviour for a long - -- time so we leave it as-is. - | otherwise - = do - link_info <- getLinkInfo dflags pkg_deps - debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString dflags exe_file - ghcLinkInfoSectionName ghcLinkInfoNoteName - let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg dflags 3 $ case m_exe_link_info of - Nothing -> text "Exe link info: Not found" - Just s - | sameLinkInfo -> text ("Exe link info is the same") - | otherwise -> text ("Exe link info is different: " ++ s) - return (not sameLinkInfo) - -platformSupportsSavingLinkOpts :: OS -> Bool -platformSupportsSavingLinkOpts os - | os == OSSolaris2 = False -- see #5382 - | otherwise = osElfTarget os - --- See Note [LinkInfo section] -ghcLinkInfoSectionName :: String -ghcLinkInfoSectionName = ".debug-ghc-link-info" - -- if we use the ".debug" prefix, then strip will strip it by default - --- Identifier for the note (see Note [LinkInfo section]) -ghcLinkInfoNoteName :: String -ghcLinkInfoNoteName = "GHC link info" - -findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath) -findHSLib dflags dirs lib = do - let batch_lib_file = if WayDyn `notElem` ways dflags - then "lib" ++ lib <.> "a" - else mkSOName (targetPlatform dflags) lib - found <- filterM doesFileExist (map ( batch_lib_file) dirs) - case found of - [] -> return Nothing - (x:_) -> return (Just x) - --- ----------------------------------------------------------------------------- --- Compile files in one-shot mode. - -oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () -oneShot hsc_env stop_phase srcs = do - o_files <- mapM (compileFile hsc_env stop_phase) srcs - doLink (hsc_dflags hsc_env) stop_phase o_files - -compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath -compileFile hsc_env stop_phase (src, mb_phase) = do - exists <- doesFileExist src - when (not exists) $ - throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) - - let - dflags = hsc_dflags hsc_env - split = gopt Opt_SplitObjs dflags - mb_o_file = outputFile dflags - ghc_link = ghcLink dflags -- Set by -c or -no-link - - -- When linking, the -o argument refers to the linker's output. - -- otherwise, we use it as the name for the pipeline's output. - output - -- If we are dong -fno-code, then act as if the output is - -- 'Temporary'. This stops GHC trying to copy files to their - -- final location. - | HscNothing <- hscTarget dflags = Temporary - | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent - -- -o foo applies to linker - | isJust mb_o_file = SpecificFile - -- -o foo applies to the file we are compiling now - | otherwise = Persistent - - stop_phase' = case stop_phase of - As _ | split -> SplitAs - _ -> stop_phase - - ( _, out_file) <- runPipeline stop_phase' hsc_env - (src, fmap RealPhase mb_phase) Nothing output - Nothing{-no ModLocation-} [] - return out_file - - -doLink :: DynFlags -> Phase -> [FilePath] -> IO () -doLink dflags stop_phase o_files - | not (isStopLn stop_phase) - = return () -- We stopped before the linking phase - - | otherwise - = case ghcLink dflags of - NoLink -> return () - LinkBinary -> linkBinary dflags o_files [] - LinkStaticLib -> linkStaticLibCheck dflags o_files [] - LinkDynLib -> linkDynLibCheck dflags o_files [] - other -> panicBadLink other - - --- --------------------------------------------------------------------------- - --- | Run a compilation pipeline, consisting of multiple phases. --- --- This is the interface to the compilation pipeline, which runs --- a series of compilation steps on a single source file, specifying --- at which stage to stop. --- --- The DynFlags can be modified by phases in the pipeline (eg. by --- OPTIONS_GHC pragmas), and the changes affect later phases in the --- pipeline. -runPipeline - :: Phase -- ^ When to stop - -> HscEnv -- ^ Compilation environment - -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix) - -> Maybe FilePath -- ^ original basename (if different from ^^^) - -> PipelineOutput -- ^ Output filename - -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module - -> [FilePath] -- ^ foreign objects - -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) -runPipeline stop_phase hsc_env0 (input_fn, mb_phase) - mb_basename output maybe_loc foreign_os - - = do let - dflags0 = hsc_dflags hsc_env0 - - -- Decide where dump files should go based on the pipeline output - dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } - hsc_env = hsc_env0 {hsc_dflags = dflags} - - (input_basename, suffix) = splitExtension input_fn - suffix' = drop 1 suffix -- strip off the . - basename | Just b <- mb_basename = b - | otherwise = input_basename - - -- If we were given a -x flag, then use that phase to start from - start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase - - isHaskell (RealPhase (Unlit _)) = True - isHaskell (RealPhase (Cpp _)) = True - isHaskell (RealPhase (HsPp _)) = True - isHaskell (RealPhase (Hsc _)) = True - isHaskell (HscOut {}) = True - isHaskell _ = False - - isHaskellishFile = isHaskell start_phase - - env = PipeEnv{ stop_phase, - src_filename = input_fn, - src_basename = basename, - src_suffix = suffix', - output_spec = output } - - when (isBackpackishSuffix suffix') $ - throwGhcExceptionIO (UsageError - ("use --backpack to process " ++ input_fn)) - - -- We want to catch cases of "you can't get there from here" before - -- we start the pipeline, because otherwise it will just run off the - -- end. - let happensBefore' = happensBefore dflags - case start_phase of - RealPhase start_phase' -> - -- See Note [Partial ordering on phases] - -- Not the same as: (stop_phase `happensBefore` start_phase') - when (not (start_phase' `happensBefore'` stop_phase || - start_phase' `eqPhase` stop_phase)) $ - throwGhcExceptionIO (UsageError - ("cannot compile this file to desired target: " - ++ input_fn)) - HscOut {} -> return () - - debugTraceMsg dflags 4 (text "Running the pipeline") - r <- runPipeline' start_phase hsc_env env input_fn - maybe_loc foreign_os - - -- If we are compiling a Haskell module, and doing - -- -dynamic-too, but couldn't do the -dynamic-too fast - -- path, then rerun the pipeline for the dyn way - let dflags = hsc_dflags hsc_env - -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) - when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do - when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do - debugTraceMsg dflags 4 - (text "Running the pipeline again for -dynamic-too") - let dflags' = dynamicTooMkDynamicDynFlags dflags - hsc_env' <- newHscEnv dflags' - _ <- runPipeline' start_phase hsc_env' env input_fn - maybe_loc foreign_os - return () - return r - -runPipeline' - :: PhasePlus -- ^ When to start - -> HscEnv -- ^ Compilation environment - -> PipeEnv - -> FilePath -- ^ Input filename - -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module - -> [FilePath] -- ^ foreign objects, if we have one - -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) -runPipeline' start_phase hsc_env env input_fn - maybe_loc foreign_os - = do - -- Execute the pipeline... - let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os } - - evalP (pipeLoop start_phase input_fn) env state - --- --------------------------------------------------------------------------- --- outer pipeline loop - --- | pipeLoop runs phases until we reach the stop phase -pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath) -pipeLoop phase input_fn = do - env <- getPipeEnv - dflags <- getDynFlags - -- See Note [Partial ordering on phases] - let happensBefore' = happensBefore dflags - stopPhase = stop_phase env - case phase of - RealPhase realPhase | realPhase `eqPhase` stopPhase -- All done - -> -- Sometimes, a compilation phase doesn't actually generate any output - -- (eg. the CPP phase when -fcpp is not turned on). If we end on this - -- stage, but we wanted to keep the output, then we have to explicitly - -- copy the file, remembering to prepend a {-# LINE #-} pragma so that - -- further compilation stages can tell what the original filename was. - case output_spec env of - Temporary -> - return (dflags, input_fn) - output -> - do pst <- getPipeState - final_fn <- liftIO $ getOutputFilename - stopPhase output (src_basename env) - dflags stopPhase (maybe_loc pst) - when (final_fn /= input_fn) $ do - let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'") - line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n") - liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn - return (dflags, final_fn) - - - | not (realPhase `happensBefore'` stopPhase) - -- Something has gone wrong. We'll try to cover all the cases when - -- this could happen, so if we reach here it is a panic. - -- eg. it might happen if the -C flag is used on a source file that - -- has {-# OPTIONS -fasm #-}. - -> panic ("pipeLoop: at phase " ++ show realPhase ++ - " but I wanted to stop at phase " ++ show stopPhase) - - _ - -> do liftIO $ debugTraceMsg dflags 4 - (text "Running phase" <+> ppr phase) - (next_phase, output_fn) <- runHookedPhase phase input_fn dflags - r <- pipeLoop next_phase output_fn - case phase of - HscOut {} -> - whenGeneratingDynamicToo dflags $ do - setDynFlags $ dynamicTooMkDynamicDynFlags dflags - -- TODO shouldn't ignore result: - _ <- pipeLoop phase input_fn - return () - _ -> - return () - return r - -runHookedPhase :: PhasePlus -> FilePath -> DynFlags - -> CompPipeline (PhasePlus, FilePath) -runHookedPhase pp input dflags = - lookupHook runPhaseHook runPhase dflags pp input dflags - --- ----------------------------------------------------------------------------- --- In each phase, we need to know into what filename to generate the --- output. All the logic about which filenames we generate output --- into is embodied in the following function. - --- | Computes the next output filename after we run @next_phase@. --- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad --- (which specifies all of the ambient information.) -phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath -phaseOutputFilename next_phase = do - PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv - PipeState{maybe_loc, hsc_env} <- getPipeState - let dflags = hsc_dflags hsc_env - liftIO $ getOutputFilename stop_phase output_spec - src_basename dflags next_phase maybe_loc - --- | Computes the next output filename for something in the compilation --- pipeline. This is controlled by several variables: --- --- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This --- is used to tell if we're in the last phase or not, because --- in that case flags like @-o@ may be important. --- 2. 'PipelineOutput': is this intended to be a 'Temporary' or --- 'Persistent' build output? Temporary files just go in --- a fresh temporary name. --- 3. 'String': what was the basename of the original input file? --- 4. 'DynFlags': the obvious thing --- 5. 'Phase': the phase we want to determine the output filename of. --- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're --- compiling; this can be used to override the default output --- of an object file. (TODO: do we actually need this?) -getOutputFilename - :: Phase -> PipelineOutput -> String - -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath -getOutputFilename stop_phase output basename dflags next_phase maybe_location - | is_last_phase, Persistent <- output = persistent_fn - | is_last_phase, SpecificFile <- output = case outputFile dflags of - Just f -> return f - Nothing -> - panic "SpecificFile: No filename" - | keep_this_output = persistent_fn - | otherwise = newTempName dflags suffix - where - hcsuf = hcSuf dflags - odir = objectDir dflags - osuf = objectSuf dflags - keep_hc = gopt Opt_KeepHcFiles 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 - _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 - --- ----------------------------------------------------------------------------- --- | Each phase in the pipeline returns the next phase to execute, and the --- name of the file in which the output was placed. --- --- We must do things dynamically this way, because we often don't know --- what the rest of the phases will be until part-way through the --- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning --- of a source file can change the latter stages of the pipeline from --- taking the LLVM route to using the native code generator. --- -runPhase :: PhasePlus -- ^ Run this phase - -> FilePath -- ^ name of the input file - -> DynFlags -- ^ for convenience, we pass the current dflags in - -> CompPipeline (PhasePlus, -- next phase to run - FilePath) -- output filename - - -- Invariant: the output filename always contains the output - -- Interesting case: Hsc when there is no recompilation to do - -- Then the output filename is still a .o file - - -------------------------------------------------------------------------------- --- Unlit phase - -runPhase (RealPhase (Unlit sf)) input_fn dflags - = do - output_fn <- phaseOutputFilename (Cpp sf) - - let flags = [ -- The -h option passes the file name for unlit to - -- put in a #line directive - SysTools.Option "-h" - -- See Note [Don't normalise input filenames]. - , SysTools.Option $ escape input_fn - , SysTools.FileOption "" input_fn - , SysTools.FileOption "" output_fn - ] - - liftIO $ SysTools.runUnlit dflags flags - - return (RealPhase (Cpp sf), output_fn) - where - -- escape the characters \, ", and ', but don't try to escape - -- Unicode or anything else (so we don't use Util.charToC - -- here). If we get this wrong, then in - -- Coverage.isGoodTickSrcSpan where we check that the filename in - -- a SrcLoc is the same as the source filenaame, the two will - -- look bogusly different. See test: - -- libraries/hpc/tests/function/subdir/tough2.hs - escape ('\\':cs) = '\\':'\\': escape cs - escape ('\"':cs) = '\\':'\"': escape cs - escape ('\'':cs) = '\\':'\'': escape cs - escape (c:cs) = c : escape cs - escape [] = [] - -------------------------------------------------------------------------------- --- Cpp phase : (a) gets OPTIONS out of file --- (b) runs cpp if necessary - -runPhase (RealPhase (Cpp sf)) input_fn dflags0 - = do - src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn - (dflags1, unhandled_flags, warns) - <- liftIO $ parseDynamicFilePragma dflags0 src_opts - setDynFlags dflags1 - liftIO $ checkProcessArgsResult dflags1 unhandled_flags - - if not (xopt LangExt.Cpp dflags1) then do - -- we have to be careful to emit warnings only once. - unless (gopt Opt_Pp dflags1) $ - liftIO $ handleFlagWarnings dflags1 warns - - -- no need to preprocess CPP, just pass input file along - -- to the next phase of the pipeline. - return (RealPhase (HsPp sf), input_fn) - else do - output_fn <- phaseOutputFilename (HsPp sf) - liftIO $ doCpp dflags1 True{-raw-} - input_fn output_fn - -- re-read the pragmas now that we've preprocessed the file - -- See #2464,#3457 - src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn - (dflags2, unhandled_flags, warns) - <- liftIO $ parseDynamicFilePragma dflags0 src_opts - liftIO $ checkProcessArgsResult dflags2 unhandled_flags - unless (gopt Opt_Pp dflags2) $ - liftIO $ handleFlagWarnings dflags2 warns - -- the HsPp pass below will emit warnings - - setDynFlags dflags2 - - return (RealPhase (HsPp sf), output_fn) - -------------------------------------------------------------------------------- --- HsPp phase - -runPhase (RealPhase (HsPp sf)) input_fn dflags - = do - if not (gopt Opt_Pp dflags) then - -- no need to preprocess, just pass input file along - -- to the next phase of the pipeline. - return (RealPhase (Hsc sf), input_fn) - else do - PipeEnv{src_basename, src_suffix} <- getPipeEnv - let orig_fn = src_basename <.> src_suffix - output_fn <- phaseOutputFilename (Hsc sf) - liftIO $ SysTools.runPp dflags - ( [ SysTools.Option orig_fn - , SysTools.Option input_fn - , SysTools.FileOption "" output_fn - ] - ) - - -- re-read pragmas now that we've parsed the file (see #3674) - src_opts <- liftIO $ getOptionsFromFile dflags output_fn - (dflags1, unhandled_flags, warns) - <- liftIO $ parseDynamicFilePragma dflags src_opts - setDynFlags dflags1 - liftIO $ checkProcessArgsResult dflags1 unhandled_flags - liftIO $ handleFlagWarnings dflags1 warns - - return (RealPhase (Hsc sf), output_fn) - ------------------------------------------------------------------------------ --- Hsc phase - --- Compilation of a single module, in "legacy" mode (_not_ under --- the direction of the compilation manager). -runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 - = do -- normal Hsc mode, not mkdependHS - - PipeEnv{ stop_phase=stop, - src_basename=basename, - src_suffix=suff } <- getPipeEnv - - -- we add the current directory (i.e. the directory in which - -- the .hs files resides) to the include path, since this is - -- what gcc does, and it's probably what you want. - let current_dir = takeDirectory basename - paths = includePaths dflags0 - dflags = dflags0 { includePaths = current_dir : paths } - - setDynFlags dflags - - -- gather the imports and module name - (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do - do - buf <- hGetStringBuffer input_fn - (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff) - return (Just buf, mod_name, imps, src_imps) - - -- Take -o into account if present - -- Very like -ohi, but we must *only* do this if we aren't linking - -- (If we're linking then the -o applies to the linked thing, not to - -- the object file for one module.) - -- Note the nasty duplication with the same computation in compileFile above - location <- getLocation src_flavour mod_name - - let o_file = ml_obj_file location -- The real object file - hi_file = ml_hi_file location - 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 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_exists <- doesFileExist dest_file - if not dest_file_exists - then return SourceModified -- Need to recompile - else do t2 <- getModificationUTCTime dest_file - if t2 > src_timestamp - then return SourceUnmodified - else return SourceModified - - 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_textual_imps = imps, - ms_srcimps = src_imps } - - -- run the compiler! - let msg hsc_env _ what _ = oneShotMsg hsc_env what - (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' - mod_summary source_unchanged Nothing (1,1) - - return (HscOut src_flavour mod_name result, - panic "HscOut doesn't have an input filename") - -runPhase (HscOut src_flavour mod_name result) _ dflags = do - location <- getLocation src_flavour mod_name - setModLocation location - - let o_file = ml_obj_file location -- The real object file - hsc_lang = hscTarget dflags - next_phase = hscPostBackendPhase dflags src_flavour hsc_lang - - case result of - HscNotGeneratingCode -> - return (RealPhase StopLn, - panic "No output filename from Hsc when no-code") - HscUpToDate -> - do liftIO $ touchObjectFile dflags o_file - -- The .o file must have a later modification date - -- than the source file (else we wouldn't get Nothing) - -- but we touch it anyway, to keep 'make' happy (we think). - return (RealPhase StopLn, o_file) - HscUpdateBoot -> - do -- In the case of hs-boot files, generate a dummy .o-boot - -- stamp file for the benefit of Make - liftIO $ touchObjectFile dflags o_file - return (RealPhase StopLn, o_file) - HscUpdateSig -> - do -- We need to create a REAL but empty .o file - -- because we are going to attempt to put it in a library - PipeState{hsc_env=hsc_env'} <- getPipeState - let input_fn = expectJust "runPhase" (ml_hs_file location) - basename = dropExtension input_fn - liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name - return (RealPhase StopLn, o_file) - HscRecomp cgguts mod_summary - -> do output_fn <- phaseOutputFilename next_phase - - PipeState{hsc_env=hsc_env'} <- getPipeState - - (outputFilename, mStub, foreign_files) <- liftIO $ - hscGenHardCode hsc_env' cgguts mod_summary output_fn - stub_o <- liftIO (mapM (compileStub hsc_env') mStub) - foreign_os <- liftIO $ - mapM (uncurry (compileForeign hsc_env')) foreign_files - setForeignOs (maybe [] return stub_o ++ foreign_os) - - return (RealPhase next_phase, outputFilename) - ------------------------------------------------------------------------------ --- Cmm phase - -runPhase (RealPhase CmmCpp) input_fn dflags - = do - output_fn <- phaseOutputFilename Cmm - liftIO $ doCpp dflags False{-not raw-} - input_fn output_fn - return (RealPhase Cmm, output_fn) - -runPhase (RealPhase Cmm) input_fn dflags - = do - let hsc_lang = hscTarget dflags - - let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang - - output_fn <- phaseOutputFilename next_phase - - PipeState{hsc_env} <- getPipeState - - liftIO $ hscCompileCmmFile hsc_env input_fn output_fn - - return (RealPhase next_phase, output_fn) - ------------------------------------------------------------------------------ --- Cc phase - --- we don't support preprocessing .c files (with -E) now. Doing so introduces --- way too many hacks, and I can't say I've ever used it anyway. - -runPhase (RealPhase cc_phase) input_fn dflags - | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx] - = do - let platform = targetPlatform dflags - hcc = cc_phase `eqPhase` HCc - - let cmdline_include_paths = includePaths dflags - - -- HC files have the dependent packages stamped into them - pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return [] - - -- add package include paths even if we're just compiling .c - -- files; this is the Value Add(TM) that using ghc instead of - -- gcc gives you :) - pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs - let include_paths = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (cmdline_include_paths ++ pkg_include_dirs) - - let gcc_extra_viac_flags = extraGccViaCFlags dflags - let pic_c_flags = picCCOpts dflags - - let verbFlags = getVerbFlags dflags - - -- cc-options are not passed when compiling .hc files. Our - -- hc code doesn't not #include any header files anyway, so these - -- options aren't necessary. - pkg_extra_cc_opts <- liftIO $ - if cc_phase `eqPhase` HCc - then return [] - else getPackageExtraCcOpts dflags pkgs - - framework_paths <- - if platformUsesFrameworks platform - then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs - let cmdlineFrameworkPaths = frameworkPaths dflags - return $ map ("-F"++) - (cmdlineFrameworkPaths ++ pkgFrameworkPaths) - else return [] - - let split_objs = gopt Opt_SplitObjs dflags - split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ] - | 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 - - let gcc_lang_opt | cc_phase `eqPhase` Ccxx = "c++" - | cc_phase `eqPhase` Cobjc = "objective-c" - | cc_phase `eqPhase` Cobjcxx = "objective-c++" - | otherwise = "c" - liftIO $ SysTools.runCc dflags ( - -- force the C compiler to interpret this file as C when - -- compiling .hc files, by adding the -x c option. - -- Also useful for plain .c files, just in case GHC saw a - -- -x c option. - [ SysTools.Option "-x", SysTools.Option gcc_lang_opt - , SysTools.FileOption "" input_fn - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option ( - pic_c_flags - - -- Stub files generated for foreign exports references the runIO_closure - -- and runNonIO_closure symbols, which are defined in the base package. - -- These symbols are imported into the stub.c file via RtsAPI.h, and the - -- way we do the import depends on whether we're currently compiling - -- the base package or not. - ++ (if platformOS platform == OSMinGW32 && - thisPackage dflags == baseUnitId - then [ "-DCOMPILING_BASE_PACKAGE" ] - else []) - - -- We only support SparcV9 and better because V8 lacks an atomic CAS - -- instruction. Note that the user can still override this - -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag - -- regardless of the ordering. - -- - -- This is a temporary hack. See #2872, commit - -- 5bd3072ac30216a505151601884ac88bf404c9f2 - ++ (if platformArch platform == ArchSPARC - then ["-mcpu=v9"] - else []) - - -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. - ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) - then ["-Wimplicit"] - else []) - - ++ (if hcc - then gcc_extra_viac_flags ++ more_hcc_opts - else []) - ++ verbFlags - ++ [ "-S" ] - ++ cc_opt - ++ [ "-include", ghcVersionH ] - ++ framework_paths - ++ split_opt - ++ include_paths - ++ pkg_extra_cc_opts - )) - - return (RealPhase next_phase, output_fn) - ------------------------------------------------------------------------------ --- Splitting phase - -runPhase (RealPhase Splitter) input_fn dflags - = do -- tmp_pfx is the prefix used for the split .s files - - split_s_prefix <- liftIO $ SysTools.newTempName dflags "split" - let n_files_fn = split_s_prefix - - liftIO $ SysTools.runSplit dflags - [ SysTools.FileOption "" input_fn - , SysTools.FileOption "" split_s_prefix - , SysTools.FileOption "" n_files_fn - ] - - -- Save the number of split files for future references - s <- liftIO $ readFile n_files_fn - let n_files = read s :: Int - dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) } - - setDynFlags dflags' - - -- Remember to delete all these files - liftIO $ addFilesToClean dflags' - [ split_s_prefix ++ "__" ++ show n ++ ".s" - | n <- [1..n_files]] - - return (RealPhase SplitAs, - "**splitter**") -- we don't use the filename in SplitAs - ------------------------------------------------------------------------------ --- As, SpitAs phase : Assembler - --- This is for calling the assembler on a regular assembly file (not split). -runPhase (RealPhase (As with_cpp)) input_fn dflags - = do - -- LLVM from version 3.0 onwards doesn't support the OS X system - -- assembler, so we use clang as the assembler instead. (#5636) - let whichAsProg | hscTarget dflags == HscLlvm && - platformOS (targetPlatform dflags) == OSDarwin - = return SysTools.runClang - | otherwise = return SysTools.runAs - - as_prog <- whichAsProg - let cmdline_include_paths = includePaths dflags - let pic_c_flags = picCCOpts dflags - - next_phase <- maybeMergeForeign - output_fn <- phaseOutputFilename next_phase - - -- we create directories for the object file, because it - -- might be a hierarchical module. - liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) - - ccInfo <- liftIO $ getCompilerInfo dflags - let runAssembler inputFilename outputFilename - = liftIO $ as_prog dflags - ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] - - -- See Note [-fPIC for assembler] - ++ map SysTools.Option pic_c_flags - - -- We only support SparcV9 and better because V8 lacks an atomic CAS - -- instruction so we have to make sure that the assembler accepts the - -- instruction set. Note that the user can still override this - -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag - -- regardless of the ordering. - -- - -- This is a temporary hack. - ++ (if platformArch (targetPlatform dflags) == ArchSPARC - then [SysTools.Option "-mcpu=v9"] - else []) - ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51] - then [SysTools.Option "-Qunused-arguments"] - else []) - ++ [ SysTools.Option "-x" - , if with_cpp - then SysTools.Option "assembler-with-cpp" - else SysTools.Option "assembler" - , SysTools.Option "-c" - , SysTools.FileOption "" inputFilename - , SysTools.Option "-o" - , SysTools.FileOption "" outputFilename - ]) - - liftIO $ debugTraceMsg dflags 4 (text "Running the assembler") - runAssembler input_fn output_fn - return (RealPhase next_phase, output_fn) - - --- This is for calling the assembler on a split assembly file (so a collection --- of assembly files) -runPhase (RealPhase SplitAs) _input_fn dflags - = do - -- we'll handle the stub_o file in this phase, so don't MergeForeign, - -- just jump straight to StopLn afterwards. - let next_phase = StopLn - output_fn <- phaseOutputFilename next_phase - - let base_o = dropExtension output_fn - osuf = objectSuf dflags - split_odir = base_o ++ "_" ++ osuf ++ "_split" - - let pic_c_flags = picCCOpts dflags - - -- this also creates the hierarchy - liftIO $ createDirectoryIfMissing True split_odir - - -- remove M_split/ *.o, because we're going to archive M_split/ *.o - -- later and we don't want to pick up any old objects. - fs <- liftIO $ getDirectoryContents split_odir - liftIO $ mapM_ removeFile $ - map (split_odir ) $ filter (osuf `isSuffixOf`) fs - - let (split_s_prefix, n) = case splitInfo dflags of - Nothing -> panic "No split info" - Just x -> x - - let split_s n = split_s_prefix ++ "__" ++ show n <.> "s" - - split_obj :: Int -> FilePath - split_obj n = split_odir - takeFileName base_o ++ "__" ++ show n <.> osuf - - let assemble_file n - = SysTools.runAs dflags ( - - -- We only support SparcV9 and better because V8 lacks an atomic CAS - -- instruction so we have to make sure that the assembler accepts the - -- instruction set. Note that the user can still override this - -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag - -- regardless of the ordering. - -- - -- This is a temporary hack. - (if platformArch (targetPlatform dflags) == ArchSPARC - then [SysTools.Option "-mcpu=v9"] - else []) ++ - - -- See Note [-fPIC for assembler] - map SysTools.Option pic_c_flags ++ - - [ SysTools.Option "-c" - , SysTools.Option "-o" - , SysTools.FileOption "" (split_obj n) - , SysTools.FileOption "" (split_s n) - ]) - - liftIO $ mapM_ assemble_file [1..n] - - -- Note [pipeline-split-init] - -- If we have a stub file -- which will be part of foreign_os -- - -- it may contain constructor - -- functions for initialisation of this module. We can't - -- simply leave the stub as a separate object file, because it - -- will never be linked in: nothing refers to it. We need to - -- ensure that if we ever refer to the data in this module - -- that needs initialisation, then we also pull in the - -- initialisation routine. - -- - -- To that end, we make a DANGEROUS ASSUMPTION here: the data - -- that needs to be initialised is all in the FIRST split - -- object. See Note [codegen-split-init]. - -- - -- We also merge in all the foreign objects since we're at it. - - PipeState{foreign_os} <- getPipeState - if null foreign_os - then return () - else liftIO $ do - tmp_split_1 <- newTempName dflags osuf - let split_1 = split_obj 1 - copyFile split_1 tmp_split_1 - removeFile split_1 - joinObjectFiles dflags (tmp_split_1 : foreign_os) split_1 - - -- join them into a single .o file - liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn - - return (RealPhase next_phase, output_fn) - ------------------------------------------------------------------------------ --- LlvmOpt phase - -runPhase (RealPhase LlvmOpt) input_fn dflags - = do - let opt_lvl = max 0 (min 2 $ optLevel 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 SysTools.Option $ words (llvmOpts !! opt_lvl) - else [] - tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" - | otherwise = "--enable-tbaa=false" - - - output_fn <- phaseOutputFilename LlvmLlc - - liftIO $ SysTools.runLlvmOpt dflags - ([ SysTools.FileOption "" input_fn, - SysTools.Option "-o", - SysTools.FileOption "" output_fn] - ++ optFlag - ++ [SysTools.Option tbaa]) - - return (RealPhase LlvmLlc, output_fn) - where - -- we always (unless -optlo specified) run Opt since we rely on it to - -- fix up some pretty big deficiencies in the code we generate - llvmOpts = [ "-mem2reg -globalopt" - , "-O1 -globalopt" - , "-O2" - ] - ------------------------------------------------------------------------------ --- LlvmLlc phase - -runPhase (RealPhase LlvmLlc) input_fn dflags - = do - let opt_lvl = max 0 (min 2 $ optLevel dflags) - -- iOS requires external references to be loaded indirectly from the - -- DATA segment or dyld traps at runtime writing into TEXT: see #7722 - rmodel | platformOS (targetPlatform dflags) == OSiOS = "dynamic-no-pic" - | positionIndependent dflags = "pic" - | WayDyn `elem` ways dflags = "dynamic-no-pic" - | otherwise = "static" - tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" - | otherwise = "--enable-tbaa=false" - - -- hidden debugging flag '-dno-llvm-mangler' to skip mangling - let next_phase = case gopt Opt_NoLlvmMangler dflags of - False -> LlvmMangle - True | gopt Opt_SplitObjs dflags -> Splitter - True -> As False - - output_fn <- phaseOutputFilename next_phase - - liftIO $ SysTools.runLlvmLlc dflags - ([ SysTools.Option (llvmOpts !! opt_lvl), - SysTools.Option $ "-relocation-model=" ++ rmodel, - SysTools.FileOption "" input_fn, - SysTools.Option "-o", SysTools.FileOption "" output_fn] - ++ [SysTools.Option tbaa] - ++ map SysTools.Option fpOpts - ++ map SysTools.Option abiOpts - ++ map SysTools.Option sseOpts - ++ map SysTools.Option avxOpts - ++ map SysTools.Option avx512Opts - ++ map SysTools.Option stackAlignOpts) - - return (RealPhase next_phase, output_fn) - where - -- Bug in LLVM at O3 on OSX. - llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin - then ["-O1", "-O2", "-O2"] - else ["-O1", "-O2", "-O3"] - -- On ARMv7 using LLVM, LLVM fails to allocate floating point registers - -- while compiling GHC source code. It's probably due to fact that it - -- does not enable VFP by default. Let's do this manually here - fpOpts = case platformArch (targetPlatform dflags) of - ArchARM ARMv7 ext _ -> if (elem VFPv3 ext) - then ["-mattr=+v7,+vfp3"] - else if (elem VFPv3D16 ext) - then ["-mattr=+v7,+vfp3,+d16"] - else [] - ArchARM ARMv6 ext _ -> if (elem VFPv2 ext) - then ["-mattr=+v6,+vfp2"] - else ["-mattr=+v6"] - _ -> [] - -- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still - -- compiles into soft-float ABI. We need to explicitly set abi - -- to hard - abiOpts = case platformArch (targetPlatform dflags) of - ArchARM _ _ HARD -> ["-float-abi=hard"] - ArchARM _ _ _ -> [] - _ -> [] - - sseOpts | isSse4_2Enabled dflags = ["-mattr=+sse42"] - | isSse2Enabled dflags = ["-mattr=+sse2"] - | isSseEnabled dflags = ["-mattr=+sse"] - | otherwise = [] - - avxOpts | isAvx512fEnabled dflags = ["-mattr=+avx512f"] - | isAvx2Enabled dflags = ["-mattr=+avx2"] - | isAvxEnabled dflags = ["-mattr=+avx"] - | otherwise = [] - - avx512Opts = - [ "-mattr=+avx512cd" | isAvx512cdEnabled dflags ] ++ - [ "-mattr=+avx512er" | isAvx512erEnabled dflags ] ++ - [ "-mattr=+avx512pf" | isAvx512pfEnabled dflags ] - - stackAlignOpts = - case platformArch (targetPlatform dflags) of - ArchX86_64 | isAvxEnabled dflags -> ["-stack-alignment=32"] - _ -> [] - ------------------------------------------------------------------------------ --- LlvmMangle phase - -runPhase (RealPhase LlvmMangle) input_fn dflags - = do - let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False - output_fn <- phaseOutputFilename next_phase - liftIO $ llvmFixupAsm dflags input_fn output_fn - return (RealPhase next_phase, output_fn) - ------------------------------------------------------------------------------ --- merge in stub objects - -runPhase (RealPhase MergeForeign) input_fn dflags - = do - PipeState{foreign_os} <- getPipeState - output_fn <- phaseOutputFilename StopLn - liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) - if null foreign_os - then panic "runPhase(MergeForeign): no foreign objects" - else do - liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn - return (RealPhase StopLn, output_fn) - --- warning suppression -runPhase (RealPhase other) _input_fn _dflags = - panic ("runPhase: don't know how to run phase " ++ show other) - -maybeMergeForeign :: CompPipeline Phase -maybeMergeForeign - = do - PipeState{foreign_os} <- getPipeState - if null foreign_os then return StopLn else return MergeForeign - -getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation -getLocation src_flavour mod_name = do - dflags <- getDynFlags - - PipeEnv{ src_basename=basename, - src_suffix=suff } <- getPipeEnv - - -- 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, and this is as good a way - -- as any to generate them, and better than most. (e.g. takes - -- into account the -osuf flags) - location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff - - -- Boot-ify it if necessary - let location2 | HsBootFile <- src_flavour = addBootSuffixLocn 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 - -mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath -mkExtraObj dflags extn xs - = do cFile <- newTempName dflags extn - oFile <- newTempName dflags "o" - writeFile cFile xs - ccInfo <- liftIO $ getCompilerInfo dflags - SysTools.runCc dflags - ([Option "-c", - FileOption "" cFile, - Option "-o", - FileOption "" oFile] - ++ if extn /= "s" - then cOpts - else asmOpts ccInfo) - return oFile - where - -- Pass a different set of options to the C compiler depending one whether - -- we're compiling C or assembler. When compiling C, we pass the usual - -- set of include directories and PIC flags. - cOpts = map Option (picCCOpts dflags) - ++ map (FileOption "-I") - (includeDirs $ getPackageDetails dflags rtsUnitId) - - -- When compiling assembler code, we drop the usual C options, and if the - -- compiler is Clang, we add an extra argument to tell Clang to ignore - -- unused command line options. See trac #11684. - asmOpts ccInfo = - if any (ccInfo ==) [Clang, AppleClang, AppleClang51] - then [Option "-Qunused-arguments"] - else [] - - --- When linking a binary, we need to create a C main() function that --- starts everything off. This used to be compiled statically as part --- of the RTS, but that made it hard to change the -rtsopts setting, --- so now we generate and compile a main() stub as part of every --- binary and pass the -rtsopts setting directly to the RTS (#5373) --- -mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath -mkExtraObjToLinkIntoBinary dflags = do - when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) - (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ - text " Call hs_init_ghc() from your main() function to set these options.") - - mkExtraObj dflags "c" (showSDoc dflags main) - - where - main - | gopt Opt_NoHsMain dflags = Outputable.empty - | otherwise = vcat [ - text "#include \"Rts.h\"", - text "extern StgClosure ZCMain_main_closure;", - text "int main(int argc, char *argv[])", - char '{', - text " RtsConfig __conf = defaultRtsConfig;", - text " __conf.rts_opts_enabled = " - <> text (show (rtsOptsEnabled dflags)) <> semi, - text " __conf.rts_opts_suggestions = " - <> text (if rtsOptsSuggestions dflags - then "true" - else "false") <> semi, - case rtsOpts dflags of - Nothing -> Outputable.empty - Just opts -> text " __conf.rts_opts= " <> - text (show opts) <> semi, - text " __conf.rts_hs_main = true;", - text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", - char '}', - char '\n' -- final newline, to keep gcc happy - ] - --- Write out the link info section into a new assembly file. Previously --- this was included as inline assembly in the main.c file but this --- is pretty fragile. gas gets upset trying to calculate relative offsets --- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath] -mkNoteObjsToLinkIntoBinary dflags dep_packages = do - link_info <- getLinkInfo dflags dep_packages - - if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) - else return [] - - where - link_opts info = hcat [ - -- "link info" section (see Note [LinkInfo section]) - makeElfNote dflags ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, - - -- ALL generated assembly must have this section to disable - -- executable stacks. See also - -- compiler/nativeGen/AsmCodeGen.hs for another instance - -- where we need to do this. - if platformHasGnuNonexecStack (targetPlatform dflags) - then text ".section .note.GNU-stack,\"\",@progbits\n" - else Outputable.empty - ] - --- | Return the "link info" string --- --- See Note [LinkInfo section] -getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String -getLinkInfo dflags dep_packages = do - package_link_opts <- getPackageLinkOpts dflags dep_packages - pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) - then getPackageFrameworks dflags dep_packages - else return [] - let extra_ld_inputs = ldInputs dflags - let - link_info = (package_link_opts, - pkg_frameworks, - rtsOpts dflags, - rtsOptsEnabled dflags, - gopt Opt_NoHsMain dflags, - map showOpt extra_ld_inputs, - getOpts dflags opt_l) - -- - return (show link_info) - - -{- Note [LinkInfo section] - ~~~~~~~~~~~~~~~~~~~~~~~ - -The "link info" is a string representing the parameters of the link. We save -this information in the binary, and the next time we link, if nothing else has -changed, we use the link info stored in the existing binary to decide whether -to re-link or not. - -The "link info" string is stored in a ELF section called ".debug-ghc-link-info" -(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to -not follow the specified record-based format (see #11022). - --} - - ------------------------------------------------------------------------------ --- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file - -getHCFilePackages :: FilePath -> IO [InstalledUnitId] -getHCFilePackages filename = - Exception.bracket (openFile filename ReadMode) hClose $ \h -> do - l <- hGetLine h - case l of - '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> - return (map stringToInstalledUnitId (words rest)) - _other -> - return [] - ------------------------------------------------------------------------------ --- Static linking, of .o files - --- The list of packages passed to link is the list of packages on --- which this program depends, as discovered by the compilation --- manager. It is combined with the list of packages that the user --- specifies on the command line with -package flags. --- --- In one-shot linking mode, we can't discover the package --- dependencies (because we haven't actually done any compilation or --- read any interface files), so the user must explicitly specify all --- the packages. - -{- -Note [-Xlinker -rpath vs -Wl,-rpath] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --Wl takes a comma-separated list of options which in the case of --Wl,-rpath -Wl,some,path,with,commas parses the the path with commas -as separate options. -Buck, the build system, produces paths with commas in them. - --Xlinker doesn't have this disadvantage and as far as I can tell -it is supported by both gcc and clang. Anecdotally nvcc supports --Xlinker, but not -Wl. --} - -linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () -linkBinary = linkBinary' False - -linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () -linkBinary' staticLink dflags o_files dep_packages = do - let platform = targetPlatform dflags - mySettings = settings dflags - verbFlags = getVerbFlags dflags - output_fn = exeFileName staticLink dflags - - -- get the full list of packages to link with, by combining the - -- explicit packages with the auto packages and all of their - -- dependencies, and eliminating duplicates. - - full_output_fn <- if isAbsolute output_fn - then return output_fn - else do d <- getCurrentDirectory - return $ normalise (d output_fn) - pkg_lib_paths <- getPackageLibraryPath dflags dep_packages - let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths - get_pkg_lib_path_opts l - | osElfTarget (platformOS platform) && - dynLibLoader dflags == SystemDependent && - WayDyn `elem` ways dflags - = let libpath = if gopt Opt_RelativeDynlibPaths dflags - then "$ORIGIN" - (l `makeRelativeTo` full_output_fn) - else l - -- See Note [-Xlinker -rpath vs -Wl,-rpath] - rpath = if gopt Opt_RPath dflags - then ["-Xlinker", "-rpath", "-Xlinker", libpath] - else [] - -- Solaris 11's linker does not support -rpath-link option. It silently - -- ignores it and then complains about next option which is -l as being a directory and not expected object file, E.g - -- ld: elf error: file - -- /tmp/ghc-src/libraries/base/dist-install/build: - -- elf_begin: I/O error: region read: Is a directory - rpathlink = if (platformOS platform) == OSSolaris2 - then [] - else ["-Xlinker", "-rpath-link", "-Xlinker", l] - in ["-L" ++ l] ++ rpathlink ++ rpath - | osMachOTarget (platformOS platform) && - dynLibLoader dflags == SystemDependent && - WayDyn `elem` ways dflags && - gopt Opt_RPath dflags - = let libpath = if gopt Opt_RelativeDynlibPaths dflags - then "@loader_path" - (l `makeRelativeTo` full_output_fn) - else l - in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath] - | otherwise = ["-L" ++ l] - - let - dead_strip - | gopt Opt_WholeArchiveHsLibs dflags = [] - | otherwise = if osSubsectionsViaSymbols (platformOS platform) - then ["-Wl,-dead_strip"] - else [] - let lib_paths = libraryPaths dflags - let lib_path_opts = map ("-L"++) lib_paths - - extraLinkObj <- mkExtraObjToLinkIntoBinary dflags - noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages - - let - (pre_hs_libs, post_hs_libs) - | gopt Opt_WholeArchiveHsLibs dflags - = if platformOS platform == OSDarwin - then (["-Wl,-all_load"], []) - -- OS X does not have a flag to turn off -all_load - else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"]) - | otherwise - = ([],[]) - - pkg_link_opts <- do - (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages - return $ if staticLink - then package_hs_libs -- If building an executable really means making a static - -- library (e.g. iOS), then we only keep the -l options for - -- HS packages, because libtool doesn't accept other options. - -- In the case of iOS these need to be added by hand to the - -- final link in Xcode. - else other_flags ++ dead_strip - ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs - ++ extra_libs - -- -Wl,-u, contained in other_flags - -- needs to be put before -l, - -- otherwise Solaris linker fails linking - -- a binary with unresolved symbols in RTS - -- which are defined in base package - -- the reason for this is a note in ld(1) about - -- '-u' option: "The placement of this option - -- on the command line is significant. - -- This option must be placed before the library - -- that defines the symbol." - - -- frameworks - pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages - let framework_opts = getFrameworkOpts dflags platform - - -- probably _stub.o files - let extra_ld_inputs = ldInputs dflags - - -- Here are some libs that need to be linked at the *end* of - -- the command line, because they contain symbols that are referred to - -- by the RTS. We can't therefore use the ordinary way opts for these. - let - debug_opts | WayDebug `elem` ways dflags = [ -#if defined(HAVE_LIBBFD) - "-lbfd", "-liberty" -#endif - ] - | otherwise = [] - - let thread_opts - | WayThreaded `elem` ways dflags = - let os = platformOS (targetPlatform dflags) - in if os `elem` [OSMinGW32, OSFreeBSD, OSOpenBSD, OSAndroid, - OSNetBSD, OSHaiku, OSQNXNTO, OSiOS, OSDarwin] - then [] - else ["-lpthread"] - | otherwise = [] - - rc_objs <- maybeCreateManifest dflags output_fn - - let link = if staticLink - then SysTools.runLibtool - else SysTools.runLink - link dflags ( - map SysTools.Option verbFlags - ++ [ SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ libmLinkOpts - ++ map SysTools.Option ( - [] - - -- See Note [No PIE when linking] - ++ picCCOpts dflags - - -- Permit the linker to auto link _symbol to _imp_symbol. - -- This lets us link against DLLs without needing an "import library". - ++ (if platformOS platform == OSMinGW32 - then ["-Wl,--enable-auto-import"] - else []) - - -- '-no_compact_unwind' - -- C++/Objective-C exceptions cannot use optimised - -- stack unwinding code. The optimised form is the - -- default in Xcode 4 on at least x86_64, and - -- without this flag we're also seeing warnings - -- like - -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog - -- on x86. - ++ (if sLdSupportsCompactUnwind mySettings && - not staticLink && - (platformOS platform == OSDarwin || platformOS platform == OSiOS) && - case platformArch platform of - ArchX86 -> True - ArchX86_64 -> True - ArchARM {} -> True - ArchARM64 -> True - _ -> False - then ["-Wl,-no_compact_unwind"] - else []) - - -- '-no_pie' - -- iOS uses 'dynamic-no-pic', so we must pass this to ld to suppress a warning; see #7722 - ++ (if platformOS platform == OSiOS && - not staticLink - then ["-Wl,-no_pie"] - else []) - - -- '-Wl,-read_only_relocs,suppress' - -- ld gives loads of warnings like: - -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure - -- when linking any program. We're not sure - -- whether this is something we ought to fix, but - -- for now this flags silences them. - ++ (if platformOS platform == OSDarwin && - platformArch platform == ArchX86 && - not staticLink - then ["-Wl,-read_only_relocs,suppress"] - else []) - - ++ (if sLdIsGnuLd mySettings && - not (gopt Opt_WholeArchiveHsLibs dflags) - then ["-Wl,--gc-sections"] - else []) - - ++ o_files - ++ lib_path_opts) - ++ extra_ld_inputs - ++ map SysTools.Option ( - rc_objs - ++ framework_opts - ++ pkg_lib_path_opts - ++ extraLinkObj:noteLinkObjs - ++ pkg_link_opts - ++ pkg_framework_opts - ++ debug_opts - ++ thread_opts - )) - -exeFileName :: Bool -> DynFlags -> FilePath -exeFileName staticLink dflags - | Just s <- outputFile dflags = - case platformOS (targetPlatform dflags) of - OSMinGW32 -> s "exe" - _ -> if staticLink - then s "a" - else s - | otherwise = - if platformOS (targetPlatform dflags) == OSMinGW32 - then "main.exe" - else if staticLink - then "liba.a" - else "a.out" - where s ext | null (takeExtension s) = s <.> ext - | otherwise = s - -maybeCreateManifest - :: DynFlags - -> FilePath -- filename of executable - -> IO [FilePath] -- extra objects to embed, maybe -maybeCreateManifest dflags exe_filename - | platformOS (targetPlatform dflags) == OSMinGW32 && - gopt Opt_GenManifest dflags - = do let manifest_filename = exe_filename <.> "manifest" - - writeFile manifest_filename $ - "\n"++ - " \n"++ - " \n\n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - "\n" - - -- Windows will find the manifest file if it is named - -- foo.exe.manifest. However, for extra robustness, and so that - -- we can move the binary around, we can embed the manifest in - -- the binary itself using windres: - if not (gopt Opt_EmbedManifest dflags) then return [] else do - - rc_filename <- newTempName dflags "rc" - rc_obj_filename <- newTempName dflags (objectSuf dflags) - - writeFile rc_filename $ - "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" - -- magic numbers :-) - -- show is a bit hackish above, but we need to escape the - -- backslashes in the path. - - runWindres dflags $ map SysTools.Option $ - ["--input="++rc_filename, - "--output="++rc_obj_filename, - "--output-format=coff"] - -- no FileOptions here: windres doesn't like seeing - -- backslashes, apparently - - removeFile manifest_filename - - return [rc_obj_filename] - | otherwise = return [] - - -linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO () -linkDynLibCheck dflags o_files dep_packages - = do - when (haveRtsOptsFlags dflags) $ do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) - (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ - text " Call hs_init_ghc() from your main() function to set these options.") - - linkDynLib dflags o_files dep_packages - -linkStaticLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO () -linkStaticLibCheck dflags o_files dep_packages - = do - when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $ - throwGhcExceptionIO (ProgramError "Static archive creation only supported on Darwin/OS X/iOS") - linkBinary' True dflags o_files dep_packages - --- ----------------------------------------------------------------------------- --- Running CPP - -doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags raw input_fn output_fn = do - let hscpp_opts = picPOpts dflags - let cmdline_include_paths = includePaths dflags - - pkg_include_dirs <- getPackageIncludePath dflags [] - let include_paths = foldr (\ x xs -> "-I" : x : xs) [] - (cmdline_include_paths ++ pkg_include_dirs) - - let verbFlags = getVerbFlags dflags - - let cpp_prog args | raw = SysTools.runCpp dflags args - | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) - - let target_defs = - [ "-D" ++ HOST_OS ++ "_BUILD_OS", - "-D" ++ HOST_ARCH ++ "_BUILD_ARCH", - "-D" ++ TARGET_OS ++ "_HOST_OS", - "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ] - -- remember, in code we *compile*, the HOST is the same our TARGET, - -- and BUILD is the same as our HOST. - - let sse_defs = - [ "-D__SSE__" | isSseEnabled dflags ] ++ - [ "-D__SSE2__" | isSse2Enabled dflags ] ++ - [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] - - let avx_defs = - [ "-D__AVX__" | isAvxEnabled dflags ] ++ - [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ - [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ - [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ - [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ - [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - - backend_defs <- getBackendDefs dflags - - let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] - -- Default CPP defines in Haskell source - ghcVersionH <- getGhcVersionPathName dflags - let hsSourceCppOpts = [ "-include", ghcVersionH ] - - -- MIN_VERSION macros - let uids = explicitPackages (pkgState dflags) - pkgs = catMaybes (map (lookupPackage dflags) uids) - mb_macro_include <- - if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName dflags "h" - writeFile macro_stub (generatePackageVersionMacros pkgs) - -- Include version macros for every *exposed* package. - -- Without -hide-all-packages and with a package database - -- size of 1000 packages, it takes cpp an estimated 2 - -- milliseconds to process this file. See Trac #10970 - -- comment 8. - return [SysTools.FileOption "-include" macro_stub] - else return [] - - cpp_prog ( map SysTools.Option verbFlags - ++ map SysTools.Option include_paths - ++ map SysTools.Option hsSourceCppOpts - ++ map SysTools.Option target_defs - ++ map SysTools.Option backend_defs - ++ map SysTools.Option th_defs - ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option sse_defs - ++ map SysTools.Option avx_defs - ++ mb_macro_include - -- Set the language mode to assembler-with-cpp when preprocessing. This - -- alleviates some of the C99 macro rules relating to whitespace and the hash - -- operator, which we tend to abuse. Clang in particular is not very happy - -- about this. - ++ [ SysTools.Option "-x" - , SysTools.Option "assembler-with-cpp" - , SysTools.Option input_fn - -- We hackily use Option instead of FileOption here, so that the file - -- name is not back-slashed on Windows. cpp is capable of - -- dealing with / in filenames, so it works fine. Furthermore - -- if we put in backslashes, cpp outputs #line directives - -- with *double* backslashes. And that in turn means that - -- our error messages get double backslashes in them. - -- In due course we should arrange that the lexer deals - -- with these \\ escapes properly. - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ]) - -getBackendDefs :: DynFlags -> IO [String] -getBackendDefs dflags | hscTarget dflags == HscLlvm = do - llvmVer <- figureLlvmVersion dflags - return $ case llvmVer of - Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] - _ -> [] - where - format (major, minor) - | minor >= 100 = error "getBackendDefs: Unsupported minor version" - | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int - -getBackendDefs _ = - return [] - --- --------------------------------------------------------------------------- --- Macros (cribbed from Cabal) - -generatePackageVersionMacros :: [PackageConfig] -> String -generatePackageVersionMacros pkgs = concat - -- Do not add any C-style comments. See Trac #3389. - [ generateMacros "" pkgname version - | pkg <- pkgs - , let version = packageVersion pkg - pkgname = map fixchar (packageNameString pkg) - ] - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c - -generateMacros :: String -> String -> Version -> String -generateMacros prefix name version = - concat - ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" - ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - where - (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - --- --------------------------------------------------------------------------- --- join object files into a single relocatable object file, using ld -r - -joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () -joinObjectFiles dflags o_files output_fn = do - let mySettings = settings dflags - ldIsGnuLd = sLdIsGnuLd mySettings - osInfo = platformOS (targetPlatform dflags) - ld_r args cc = SysTools.runLink dflags ([ - SysTools.Option "-nostdlib", - SysTools.Option "-Wl,-r" - ] - -- See Note [No PIE while linking] in SysTools - ++ (if sGccSupportsNoPie mySettings - then [SysTools.Option "-no-pie"] - else []) - - ++ (if any (cc ==) [Clang, AppleClang, AppleClang51] - then [] - else [SysTools.Option "-nodefaultlibs"]) - ++ (if osInfo == OSFreeBSD - then [SysTools.Option "-L/usr/lib"] - else []) - -- gcc on sparc sets -Wl,--relax implicitly, but - -- -r and --relax are incompatible for ld, so - -- disable --relax explicitly. - ++ (if platformArch (targetPlatform dflags) - `elem` [ArchSPARC, ArchSPARC64] - && ldIsGnuLd - then [SysTools.Option "-Wl,-no-relax"] - else []) - ++ map SysTools.Option ld_build_id - ++ [ SysTools.Option "-o", - SysTools.FileOption "" output_fn ] - ++ args) - - -- suppress the generation of the .note.gnu.build-id section, - -- which we don't need and sometimes causes ld to emit a - -- warning: - ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"] - | otherwise = [] - - ccInfo <- getCompilerInfo dflags - if ldIsGnuLd - then do - script <- newTempName dflags "ldscript" - cwd <- getCurrentDirectory - let o_files_abs = map (\x -> "\"" ++ (cwd x) ++ "\"") o_files - writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" - ld_r [SysTools.FileOption "" script] ccInfo - else if sLdSupportsFilelist mySettings - then do - filelist <- newTempName dflags "filelist" - writeFile filelist $ unlines o_files - ld_r [SysTools.Option "-Wl,-filelist", - SysTools.FileOption "-Wl," filelist] ccInfo - else do - ld_r (map (SysTools.FileOption "") o_files) ccInfo - --- ----------------------------------------------------------------------------- --- Misc. - -writeInterfaceOnlyMode :: DynFlags -> Bool -writeInterfaceOnlyMode dflags = - gopt Opt_WriteInterface dflags && - HscNothing == hscTarget dflags - --- | What phase to run after one of the backend code generators has run -hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase -hscPostBackendPhase _ HsBootFile _ = StopLn -hscPostBackendPhase _ HsigFile _ = StopLn -hscPostBackendPhase dflags _ hsc_lang = - case hsc_lang of - HscC -> HCc - HscAsm | gopt Opt_SplitObjs dflags -> Splitter - | otherwise -> As False - HscLlvm -> LlvmOpt - HscNothing -> StopLn - HscInterpreted -> StopLn - -touchObjectFile :: DynFlags -> FilePath -> IO () -touchObjectFile dflags path = do - createDirectoryIfMissing True $ takeDirectory path - SysTools.touch dflags "Touching object file" path - -haveRtsOptsFlags :: DynFlags -> Bool -haveRtsOptsFlags dflags = - isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of - RtsOptsSafeOnly -> False - _ -> True - --- | Find out path to @ghcversion.h@ file -getGhcVersionPathName :: DynFlags -> IO FilePath -getGhcVersionPathName dflags = do - dirs <- getPackageIncludePath dflags [toInstalledUnitId rtsUnitId] - - found <- filterM doesFileExist (map ( "ghcversion.h") dirs) - case found of - [] -> throwGhcExceptionIO (InstallationError ("ghcversion.h missing")) - (x:_) -> return x - --- Note [-fPIC for assembler] --- When compiling .c source file GHC's driver pipeline basically --- does the following two things: --- 1. ${CC} -S 'PIC_CFLAGS' source.c --- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S --- --- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler? --- Because on some architectures (at least sparc32) assembler also chooses --- the relocation type! --- Consider the following C module: --- --- /* pic-sample.c */ --- int v; --- void set_v (int n) { v = n; } --- int get_v (void) { return v; } --- --- $ gcc -S -fPIC pic-sample.c --- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary --- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary --- --- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od --- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od --- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od --- --- Most of architectures won't show any difference in this test, but on sparc32 --- the following assembly snippet: --- --- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7 --- --- generates two kinds or relocations, only 'R_SPARC_PC22' is correct: --- --- 3c: 2f 00 00 00 sethi %hi(0), %l7 --- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8 --- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8 - -{- Note [Don't normalise input filenames] - -Summary - We used to normalise input filenames when starting the unlit phase. This - broke hpc in `--make` mode with imported literate modules (#2991). - -Introduction - 1) --main - When compiling a module with --main, GHC scans its imports to find out which - other modules it needs to compile too. It turns out that there is a small - difference between saying `ghc --make A.hs`, when `A` imports `B`, and - specifying both modules on the command line with `ghc --make A.hs B.hs`. In - the former case, the filename for B is inferred to be './B.hs' instead of - 'B.hs'. - - 2) unlit - When GHC compiles a literate haskell file, the source code first needs to go - through unlit, which turns it into normal Haskell source code. At the start - of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the - option `-h` and the name of the original file. We used to normalise this - filename using System.FilePath.normalise, which among other things removes - an initial './'. unlit then uses that filename in #line directives that it - inserts in the transformed source code. - - 3) SrcSpan - A SrcSpan represents a portion of a source code file. It has fields - linenumber, start column, end column, and also a reference to the file it - originated from. The SrcSpans for a literate haskell file refer to the - filename that was passed to unlit -h. - - 4) -fhpc - At some point during compilation with -fhpc, in the function - `deSugar.Coverage.isGoodTickSrcSpan`, we compare the filename that a - `SrcSpan` refers to with the name of the file we are currently compiling. - For some reason I don't yet understand, they can sometimes legitimally be - different, and then hpc ignores that SrcSpan. - -Problem - When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate - module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the - start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2). - Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are - still compiling `./B.lhs`. Hpc thinks these two filenames are different (4), - doesn't include ticks for B, and we have unhappy customers (#2991). - -Solution - Do not normalise `input_fn` when starting the unlit phase. - -Alternative solution - Another option would be to not compare the two filenames on equality, but to - use System.FilePath.equalFilePath. That function first normalises its - arguments. The problem is that by the time we need to do the comparison, the - filenames have been turned into FastStrings, probably for performance - reasons, so System.FilePath.equalFilePath can not be used directly. - -Archeology - The call to `normalise` was added in a commit called "Fix slash - direction on Windows with the new filePath code" (c9b6b5e8). The problem - that commit was addressing has since been solved in a different manner, in a - commit called "Fix the filename passed to unlit" (1eedbc6b). So the - `normalise` is no longer necessary. --} diff --git a/main/DynFlags.hs b/main/DynFlags.hs deleted file mode 100644 --- a/main/DynFlags.hs +++ /dev/null @@ -1,5357 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} - -------------------------------------------------------------------------------- --- --- | Dynamic flags --- --- Most flags are dynamic flags, which means they can change from compilation --- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each --- session can be using different dynamic flags. Dynamic flags can also be set --- at the prompt in GHCi. --- --- (c) The University of Glasgow 2005 --- -------------------------------------------------------------------------------- - -{-# OPTIONS_GHC -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - -module DynFlags ( - -- * Dynamic flags and associated configuration types - DumpFlag(..), - GeneralFlag(..), - WarningFlag(..), WarnReason(..), - Language(..), - PlatformConstants(..), - FatalMessager, LogAction, LogFinaliser, FlushOut(..), FlushErr(..), - ProfAuto(..), - glasgowExtsFlags, - warningGroups, warningHierarchies, - hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, - dopt, dopt_set, dopt_unset, - gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag', - wopt, wopt_set, wopt_unset, - wopt_fatal, - xopt, xopt_set, xopt_unset, - lang_set, - useUnicodeSyntax, - whenGeneratingDynamicToo, ifGeneratingDynamicToo, - whenCannotGenerateDynamicToo, - dynamicTooMkDynamicDynFlags, - DynFlags(..), - FlagSpec(..), - HasDynFlags(..), ContainsDynFlags(..), - RtsOptsEnabled(..), - HscTarget(..), isObjectTarget, defaultObjectTarget, - targetRetainsAllBindings, - GhcMode(..), isOneShot, - GhcLink(..), isNoLink, - PackageFlag(..), PackageArg(..), ModRenaming(..), - packageFlagsChanged, - IgnorePackageFlag(..), TrustFlag(..), - PackageDBFlag(..), PkgConfRef(..), - Option(..), showOpt, - DynLibLoader(..), - fFlags, fLangFlags, xFlags, - wWarningFlags, - dynFlagDependencies, - tablesNextToCode, mkTablesNextToCode, - makeDynFlagsConsistent, - shouldUseColor, - positionIndependent, - - Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, - wayGeneralFlags, wayUnsetGeneralFlags, - - thisPackage, thisComponentId, thisUnitIdInsts, - - -- ** Log output - putLogMsg, - - -- ** Safe Haskell - SafeHaskellMode(..), - safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn, - packageTrustOn, - safeDirectImpsReq, safeImplicitImpsReq, - unsafeFlags, unsafeFlagsForInfer, - - -- ** System tool settings and locations - Settings(..), - targetPlatform, programName, projectVersion, - ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, - versionedAppDir, - extraGccViaCFlags, systemPackageConfig, - pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, - pgm_windres, pgm_libtool, pgm_lo, pgm_lc, pgm_i, - opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i, - opt_windres, opt_lo, opt_lc, - - - -- ** Manipulating DynFlags - defaultDynFlags, -- Settings -> DynFlags - defaultWays, - interpWays, - interpreterProfiled, interpreterDynamic, - initDynFlags, -- DynFlags -> IO DynFlags - defaultFatalMessager, - defaultLogAction, - defaultLogActionHPrintDoc, - defaultLogActionHPutStrDoc, - defaultFlushOut, - defaultFlushErr, - - getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] - getVerbFlags, - updOptLevel, - setTmpDir, - setUnitId, - interpretPackageEnv, - canonicalizeHomeModule, - - -- ** Parsing DynFlags - parseDynamicFlagsCmdLine, - parseDynamicFilePragma, - parseDynamicFlagsFull, - - -- ** Available DynFlags - allNonDeprecatedFlags, - flagsAll, - flagsDynamic, - flagsPackage, - flagsForCompletion, - - supportedLanguagesAndExtensions, - languageExtensions, - - -- ** DynFlags C compiler options - picCCOpts, picPOpts, - - -- * Compiler configuration suitable for display to the user - compilerInfo, - - rtsIsProfiled, - dynamicGhc, - -#include "GHCConstantsHaskellExports.hs" - bLOCK_SIZE_W, - wORD_SIZE_IN_BITS, - tAG_MASK, - mAX_PTR_TAG, - tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD, - - unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, - - -- * SSE and AVX - isSseEnabled, - isSse2Enabled, - isSse4_2Enabled, - isAvxEnabled, - isAvx2Enabled, - isAvx512cdEnabled, - isAvx512erEnabled, - isAvx512fEnabled, - isAvx512pfEnabled, - - -- * Linker/compiler information - LinkerInfo(..), - CompilerInfo(..), - ) where - -#include "HsVersions.h" - -import Platform -import PlatformConstants -import Module -import PackageConfig -import {-# SOURCE #-} Hooks -import {-# SOURCE #-} PrelNames ( mAIN ) -import {-# SOURCE #-} Packages (PackageState, emptyPackageState) -import DriverPhases ( Phase(..), phaseInputExt ) -import Config -import CmdLineParser -import Constants -import Panic -import qualified PprColour as Col -import Util -import Maybes -import MonadUtils -import qualified Pretty -import SrcLoc -import BasicTypes ( IntWithInf, treatZeroAsInf ) -import FastString -import Outputable -import Foreign.C ( CInt(..) ) -import System.IO.Unsafe ( unsafeDupablePerformIO ) -import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn - , getCaretDiagnostic, dumpSDoc ) -import Json -import SysTools.Terminal ( stderrSupportsAnsiColors ) - -import System.IO.Unsafe ( unsafePerformIO ) -import Data.IORef -import Control.Arrow ((&&&)) -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Except -import Control.Exception (throwIO) - -import Data.Ord -import Data.Bits -import Data.Char -import Data.Int -import Data.List -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Word -import System.FilePath -import System.Directory -import System.Environment (getEnv, lookupEnv) -import System.IO -import System.IO.Error -import Text.ParserCombinators.ReadP hiding (char) -import Text.ParserCombinators.ReadP as R - -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - -import GHC.Foreign (withCString, peekCString) -import qualified GHC.LanguageExtensions as LangExt - -import Foreign (Ptr) -- needed for 2nd stage - --- Note [Updating flag description in the User's Guide] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- If you modify anything in this file please make sure that your changes are --- described in the User's Guide. Usually at least two sections need to be --- updated: --- --- * Flag Reference section generated from the modules in --- utils/mkUserGuidePart/Options --- --- * Flag description in docs/users_guide/using.rst provides a detailed --- explanation of flags' usage. - --- Note [Supporting CLI completion] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- The command line interface completion (in for example bash) is an easy way --- for the developer to learn what flags are available from GHC. --- GHC helps by separating which flags are available when compiling with GHC, --- and which flags are available when using GHCi. --- A flag is assumed to either work in both these modes, or only in one of them. --- When adding or changing a flag, please consider for which mode the flag will --- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag, --- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec. - --- Note [Adding a language extension] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- There are a few steps to adding (or removing) a language extension, --- --- * Adding the extension to GHC.LanguageExtensions --- --- The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs --- is the canonical list of language extensions known by GHC. --- --- * Adding a flag to DynFlags.xFlags --- --- This is fairly self-explanatory. The name should be concise, memorable, --- and consistent with any previous implementations of the similar idea in --- other Haskell compilers. --- --- * Adding the flag to the documentation --- --- This is the same as any other flag. See --- Note [Updating flag description in the User's Guide] --- --- * Adding the flag to Cabal --- --- The Cabal library has its own list of all language extensions supported --- by all major compilers. This is the list that user code being uploaded --- to Hackage is checked against to ensure language extension validity. --- Consequently, it is very important that this list remains up-to-date. --- --- To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs) --- whose job it is to ensure these GHC's extensions are consistent with --- Cabal. --- --- The recommended workflow is, --- --- 1. Temporarily add your new language extension to the --- expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't --- break while Cabal is updated. --- --- 2. After your GHC change is accepted, submit a Cabal pull request adding --- your new extension to Cabal's list (found in --- Cabal/Language/Haskell/Extension.hs). --- --- 3. After your Cabal change is accepted, let the GHC developers know so --- they can update the Cabal submodule and remove the extensions from --- expectedGhcOnlyExtensions. --- --- * Adding the flag to the GHC Wiki --- --- There is a change log tracking language extension additions and removals --- on the GHC wiki: https://ghc.haskell.org/trac/ghc/wiki/LanguagePragmaHistory --- --- See Trac #4437 and #8176. - --- ----------------------------------------------------------------------------- --- DynFlags - -data DumpFlag --- See Note [Updating flag description in the User's Guide] - - -- debugging flags - = Opt_D_dump_cmm - | Opt_D_dump_cmm_from_stg - | Opt_D_dump_cmm_raw - | Opt_D_dump_cmm_verbose - -- All of the cmm subflags (there are a lot!) automatically - -- enabled if you run -ddump-cmm-verbose - -- Each flag corresponds to exact stage of Cmm pipeline. - | Opt_D_dump_cmm_cfg - | Opt_D_dump_cmm_cbe - | Opt_D_dump_cmm_switch - | Opt_D_dump_cmm_proc - | Opt_D_dump_cmm_sp - | Opt_D_dump_cmm_sink - | Opt_D_dump_cmm_caf - | Opt_D_dump_cmm_procmap - | Opt_D_dump_cmm_split - | Opt_D_dump_cmm_info - | Opt_D_dump_cmm_cps - -- end cmm subflags - | Opt_D_dump_asm - | Opt_D_dump_asm_native - | Opt_D_dump_asm_liveness - | Opt_D_dump_asm_regalloc - | Opt_D_dump_asm_regalloc_stages - | Opt_D_dump_asm_conflicts - | Opt_D_dump_asm_stats - | Opt_D_dump_asm_expanded - | Opt_D_dump_llvm - | Opt_D_dump_core_stats - | Opt_D_dump_deriv - | Opt_D_dump_ds - | Opt_D_dump_foreign - | Opt_D_dump_inlinings - | Opt_D_dump_rule_firings - | Opt_D_dump_rule_rewrites - | Opt_D_dump_simpl_trace - | Opt_D_dump_occur_anal - | Opt_D_dump_parsed - | Opt_D_dump_parsed_ast - | Opt_D_dump_rn - | Opt_D_dump_rn_ast - | Opt_D_dump_shape - | Opt_D_dump_simpl - | Opt_D_dump_simpl_iterations - | Opt_D_dump_spec - | Opt_D_dump_prep - | Opt_D_dump_stg - | Opt_D_dump_call_arity - | Opt_D_dump_stranal - | Opt_D_dump_str_signatures - | Opt_D_dump_tc - | Opt_D_dump_tc_ast - | Opt_D_dump_types - | Opt_D_dump_rules - | Opt_D_dump_cse - | Opt_D_dump_worker_wrapper - | Opt_D_dump_rn_trace - | Opt_D_dump_rn_stats - | Opt_D_dump_opt_cmm - | Opt_D_dump_simpl_stats - | Opt_D_dump_cs_trace -- Constraint solver in type checker - | Opt_D_dump_tc_trace - | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker - | Opt_D_dump_if_trace - | Opt_D_dump_vt_trace - | Opt_D_dump_splices - | Opt_D_th_dec_file - | Opt_D_dump_BCOs - | Opt_D_dump_vect - | Opt_D_dump_ticked - | Opt_D_dump_rtti - | Opt_D_source_stats - | Opt_D_verbose_stg2stg - | Opt_D_dump_hi - | Opt_D_dump_hi_diffs - | Opt_D_dump_mod_cycles - | Opt_D_dump_mod_map - | Opt_D_dump_view_pattern_commoning - | Opt_D_verbose_core2core - | Opt_D_dump_debug - | Opt_D_dump_json - | Opt_D_ppr_debug - | Opt_D_no_debug_output - deriving (Eq, Show, Enum) - --- | Enumerates the simple on-or-off dynamic flags -data GeneralFlag --- See Note [Updating flag description in the User's Guide] - - = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. - | Opt_D_faststring_stats - | Opt_D_dump_minimal_imports - | Opt_DoCoreLinting - | Opt_DoStgLinting - | Opt_DoCmmLinting - | Opt_DoAsmLinting - | Opt_DoAnnotationLinting - | Opt_NoLlvmMangler -- hidden flag - - | Opt_WarnIsError -- -Werror; makes warnings fatal - | Opt_ShowWarnGroups -- Show the group a warning belongs to - | Opt_HideSourcePaths -- Hide module source/object paths - - | Opt_PrintExplicitForalls - | Opt_PrintExplicitKinds - | Opt_PrintExplicitCoercions - | Opt_PrintExplicitRuntimeReps - | Opt_PrintEqualityRelations - | Opt_PrintUnicodeSyntax - | Opt_PrintExpandedSynonyms - | Opt_PrintPotentialInstances - | Opt_PrintTypecheckerElaboration - - -- optimisation opts - | Opt_CallArity - | Opt_Strictness - | Opt_LateDmdAnal - | Opt_KillAbsence - | Opt_KillOneShot - | Opt_FullLaziness - | Opt_FloatIn - | Opt_Specialise - | Opt_SpecialiseAggressively - | Opt_CrossModuleSpecialise - | Opt_StaticArgumentTransformation - | Opt_CSE - | Opt_StgCSE - | Opt_LiberateCase - | Opt_SpecConstr - | Opt_SpecConstrKeen - | Opt_DoLambdaEtaExpansion - | Opt_IgnoreAsserts - | Opt_DoEtaReduction - | Opt_CaseMerge - | Opt_CaseFolding -- Constant folding through case-expressions - | Opt_UnboxStrictFields - | Opt_UnboxSmallStrictFields - | Opt_DictsCheap - | Opt_EnableRewriteRules -- Apply rewrite rules during simplification - | Opt_Vectorise - | Opt_VectorisationAvoidance - | Opt_RegsGraph -- do graph coloring register allocation - | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation - | Opt_PedanticBottoms -- Be picky about how we treat bottom - | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA (hidden flag) - | Opt_LlvmPassVectorsInRegisters -- Pass SIMD vectors in registers (requires a patched LLVM) (hidden flag) - | Opt_LlvmFillUndefWithGarbage -- Testing for undef bugs (hidden flag) - | Opt_IrrefutableTuples - | Opt_CmmSink - | Opt_CmmElimCommonBlocks - | Opt_OmitYields - | Opt_FunToThunk -- allow WwLib.mkWorkerArgs to remove all value lambdas - | Opt_DictsStrict -- be strict in argument dictionaries - | Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors - | Opt_Loopification -- See Note [Self-recursive tail calls] - | Opt_CprAnal - | Opt_WorkerWrapper - | Opt_SolveConstantDicts - - -- Interface files - | Opt_IgnoreInterfacePragmas - | Opt_OmitInterfacePragmas - | Opt_ExposeAllUnfoldings - | Opt_WriteInterface -- forces .hi files to be written even with -fno-code - - -- profiling opts - | Opt_AutoSccsOnIndividualCafs - | Opt_ProfCountEntries - - -- misc opts - | Opt_Pp - | Opt_ForceRecomp - | Opt_ExcessPrecision - | Opt_EagerBlackHoling - | Opt_NoHsMain - | Opt_SplitObjs - | Opt_SplitSections - | Opt_StgStats - | Opt_HideAllPackages - | Opt_HideAllPluginPackages - | Opt_PrintBindResult - | Opt_Haddock - | Opt_HaddockOptions - | Opt_BreakOnException - | Opt_BreakOnError - | Opt_PrintEvldWithShow - | Opt_PrintBindContents - | Opt_GenManifest - | Opt_EmbedManifest - | Opt_SharedImplib - | Opt_BuildingCabalPackage - | Opt_IgnoreDotGhci - | Opt_GhciSandbox - | Opt_GhciHistory - | Opt_LocalGhciHistory - | Opt_HelpfulErrors - | Opt_DeferTypeErrors - | Opt_DeferTypedHoles - | Opt_DeferOutOfScopeVariables - | Opt_PIC -- ^ @-fPIC@ - | Opt_PIE -- ^ @-fPIE@ - | Opt_PICExecutable -- ^ @-pie@ - | Opt_SccProfilingOn - | Opt_Ticky - | Opt_Ticky_Allocd - | Opt_Ticky_LNE - | Opt_Ticky_Dyn_Thunk - | Opt_RPath - | Opt_RelativeDynlibPaths - | Opt_Hpc - | Opt_FlatCache - | Opt_ExternalInterpreter - | Opt_OptimalApplicativeDo - | Opt_VersionMacros - | Opt_WholeArchiveHsLibs - - -- PreInlining is on by default. The option is there just to see how - -- bad things get if you turn it off! - | Opt_SimplPreInlining - - -- output style opts - | Opt_ErrorSpans -- Include full span info in error messages, - -- instead of just the start position. - | Opt_DiagnosticsShowCaret -- Show snippets of offending code - | Opt_PprCaseAsLet - | Opt_PprShowTicks - | Opt_ShowHoleConstraints - | Opt_ShowLoadedModules - - -- Suppress all coercions, them replacing with '...' - | Opt_SuppressCoercions - | Opt_SuppressVarKinds - -- Suppress module id prefixes on variables. - | Opt_SuppressModulePrefixes - -- Suppress type applications. - | Opt_SuppressTypeApplications - -- Suppress info such as arity and unfoldings on identifiers. - | Opt_SuppressIdInfo - -- Suppress separate type signatures in core, but leave types on - -- lambda bound vars - | Opt_SuppressUnfoldings - -- Suppress the details of even stable unfoldings - | Opt_SuppressTypeSignatures - -- Suppress unique ids on variables. - -- Except for uniques, as some simplifier phases introduce new - -- variables that have otherwise identical names. - | Opt_SuppressUniques - | Opt_SuppressTicks -- Replaces Opt_PprShowTicks - - -- temporary flags - | Opt_AutoLinkPackages - | Opt_ImplicitImportQualified - - -- keeping stuff - | Opt_KeepHiDiffs - | Opt_KeepHcFiles - | Opt_KeepSFiles - | Opt_KeepTmpFiles - | Opt_KeepRawTokenStream - | Opt_KeepLlvmFiles - | Opt_KeepHiFiles - | Opt_KeepOFiles - - | Opt_BuildDynamicToo - - -- safe haskell flags - | Opt_DistrustAllPackages - | Opt_PackageTrust - - | Opt_G_NoStateHack - | Opt_G_NoOptCoercion - deriving (Eq, Show, Enum) - --- | Used when outputting warnings: if a reason is given, it is --- displayed. If a warning isn't controlled by a flag, this is made --- explicit at the point of use. -data WarnReason = NoReason | Reason !WarningFlag - deriving Show - -instance Outputable WarnReason where - ppr = text . show - -instance ToJson WarnReason where - json NoReason = JSNull - json (Reason wf) = JSString (show wf) - -data WarningFlag = --- See Note [Updating flag description in the User's Guide] - Opt_WarnDuplicateExports - | Opt_WarnDuplicateConstraints - | Opt_WarnRedundantConstraints - | Opt_WarnHiShadows - | Opt_WarnImplicitPrelude - | Opt_WarnIncompletePatterns - | Opt_WarnIncompleteUniPatterns - | Opt_WarnIncompletePatternsRecUpd - | Opt_WarnOverflowedLiterals - | Opt_WarnEmptyEnumerations - | Opt_WarnMissingFields - | Opt_WarnMissingImportList - | Opt_WarnMissingMethods - | Opt_WarnMissingSignatures - | Opt_WarnMissingLocalSignatures - | Opt_WarnNameShadowing - | Opt_WarnOverlappingPatterns - | Opt_WarnTypeDefaults - | Opt_WarnMonomorphism - | Opt_WarnUnusedTopBinds - | Opt_WarnUnusedLocalBinds - | Opt_WarnUnusedPatternBinds - | Opt_WarnUnusedImports - | Opt_WarnUnusedMatches - | Opt_WarnUnusedTypePatterns - | Opt_WarnUnusedForalls - | Opt_WarnWarningsDeprecations - | Opt_WarnDeprecatedFlags - | Opt_WarnAMP -- Introduced in GHC 7.8, obsolete since 7.10 - | Opt_WarnMissingMonadFailInstances -- since 8.0 - | Opt_WarnSemigroup -- since 8.0 - | Opt_WarnDodgyExports - | Opt_WarnDodgyImports - | Opt_WarnOrphans - | Opt_WarnAutoOrphans - | Opt_WarnIdentities - | Opt_WarnTabs - | Opt_WarnUnrecognisedPragmas - | Opt_WarnDodgyForeignImports - | Opt_WarnUnusedDoBind - | Opt_WarnWrongDoBind - | Opt_WarnAlternativeLayoutRuleTransitional - | Opt_WarnUnsafe - | Opt_WarnSafe - | Opt_WarnTrustworthySafe - | Opt_WarnMissedSpecs - | Opt_WarnAllMissedSpecs - | Opt_WarnUnsupportedCallingConventions - | Opt_WarnUnsupportedLlvmVersion - | Opt_WarnInlineRuleShadowing - | Opt_WarnTypedHoles - | Opt_WarnPartialTypeSignatures - | Opt_WarnMissingExportedSignatures - | Opt_WarnUntickedPromotedConstructors - | Opt_WarnDerivingTypeable - | Opt_WarnDeferredTypeErrors - | Opt_WarnDeferredOutOfScopeVariables - | Opt_WarnNonCanonicalMonadInstances -- since 8.0 - | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0 - | Opt_WarnNonCanonicalMonoidInstances -- since 8.0 - | Opt_WarnMissingPatternSynonymSignatures -- since 8.0 - | Opt_WarnUnrecognisedWarningFlags -- since 8.0 - | Opt_WarnSimplifiableClassConstraints -- Since 8.2 - | Opt_WarnCPPUndef -- Since 8.2 - | Opt_WarnUnbangedStrictPatterns -- Since 8.2 - | Opt_WarnMissingHomeModules -- Since 8.2 - deriving (Eq, Show, Enum) - -data Language = Haskell98 | Haskell2010 - deriving (Eq, Enum, Show) - -instance Outputable Language where - ppr = text . show - --- | The various Safe Haskell modes -data SafeHaskellMode - = Sf_None - | Sf_Unsafe - | Sf_Trustworthy - | Sf_Safe - deriving (Eq) - -instance Show SafeHaskellMode where - show Sf_None = "None" - show Sf_Unsafe = "Unsafe" - show Sf_Trustworthy = "Trustworthy" - show Sf_Safe = "Safe" - -instance Outputable SafeHaskellMode where - ppr = text . show - --- | Contains not only a collection of 'GeneralFlag's but also a plethora of --- information relating to the compilation of a single file or GHC session -data DynFlags = DynFlags { - ghcMode :: GhcMode, - ghcLink :: GhcLink, - hscTarget :: HscTarget, - settings :: Settings, - verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] - optLevel :: Int, -- ^ Optimisation level - debugLevel :: Int, -- ^ How much debug information to produce - simplPhases :: Int, -- ^ Number of simplifier phases - maxSimplIterations :: Int, -- ^ Max simplifier iterations - maxPmCheckIterations :: Int, -- ^ Max no iterations for pm checking - ruleCheck :: Maybe String, - strictnessBefore :: [Int], -- ^ Additional demand analysis - - parMakeCount :: Maybe Int, -- ^ The number of modules to compile in parallel - -- in --make mode, where Nothing ==> compile as - -- many in parallel as there are CPUs. - - enableTimeStats :: Bool, -- ^ Enable RTS timing statistics? - ghcHeapSize :: Maybe Int, -- ^ The heap size to set. - - maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt - -- to show in type error messages - maxUncoveredPatterns :: Int, -- ^ Maximum number of unmatched patterns to show - -- in non-exhaustiveness warnings - simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks - specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr - specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function - specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types - -- Not optional; otherwise ForceSpecConstr can diverge. - liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase - floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating - -- See CoreMonad.FloatOutSwitches - - historySize :: Int, -- ^ Simplification history size - - importPaths :: [FilePath], - mainModIs :: Module, - mainFunIs :: Maybe String, - reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth - solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver - -- Typically only 1 is needed - - thisInstalledUnitId :: InstalledUnitId, - thisComponentId_ :: Maybe ComponentId, - thisUnitIdInsts_ :: Maybe [(ModuleName, Module)], - - -- ways - ways :: [Way], -- ^ Way flags from the command line - buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) - rtsBuildTag :: String, -- ^ The RTS \"way\" - - -- For object splitting - splitInfo :: Maybe (String,Int), - - -- paths etc. - objectDir :: Maybe String, - dylibInstallName :: Maybe String, - hiDir :: Maybe String, - stubDir :: Maybe String, - dumpDir :: Maybe String, - - objectSuf :: String, - hcSuf :: String, - hiSuf :: String, - - canGenerateDynamicToo :: IORef Bool, - dynObjectSuf :: String, - dynHiSuf :: String, - - -- Packages.isDllName needs to know whether a call is within a - -- single DLL or not. Normally it does this by seeing if the call - -- is to the same package, but for the ghc package, we split the - -- package between 2 DLLs. The dllSplit tells us which sets of - -- modules are in which package. - dllSplitFile :: Maybe FilePath, - dllSplit :: Maybe [Set String], - - outputFile :: Maybe String, - dynOutputFile :: Maybe String, - outputHi :: Maybe String, - dynLibLoader :: DynLibLoader, - - -- | This is set by 'DriverPipeline.runPipeline' based on where - -- its output is going. - dumpPrefix :: Maybe FilePath, - - -- | Override the 'dumpPrefix' set by 'DriverPipeline.runPipeline'. - -- Set by @-ddump-file-prefix@ - dumpPrefixForce :: Maybe FilePath, - - ldInputs :: [Option], - - includePaths :: [String], - libraryPaths :: [String], - frameworkPaths :: [String], -- used on darwin only - cmdlineFrameworks :: [String], -- ditto - - rtsOpts :: Maybe String, - rtsOptsEnabled :: RtsOptsEnabled, - rtsOptsSuggestions :: Bool, - - hpcDir :: String, -- ^ Path to store the .mix files - - -- Plugins - pluginModNames :: [ModuleName], - pluginModNameOpts :: [(ModuleName,String)], - frontendPluginOpts :: [String], - -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* - -- order that they're specified on the command line. - - -- GHC API hooks - hooks :: Hooks, - - -- For ghc -M - depMakefile :: FilePath, - depIncludePkgDeps :: Bool, - depExcludeMods :: [ModuleName], - depSuffixes :: [String], - - -- Package flags - packageDBFlags :: [PackageDBFlag], - -- ^ The @-package-db@ flags given on the command line, In - -- *reverse* order that they're specified on the command line. - -- This is intended to be applied with the list of "initial" - -- package databases derived from @GHC_PACKAGE_PATH@; see - -- 'getPackageConfRefs'. - - ignorePackageFlags :: [IgnorePackageFlag], - -- ^ The @-ignore-package@ flags from the command line. - -- In *reverse* order that they're specified on the command line. - packageFlags :: [PackageFlag], - -- ^ The @-package@ and @-hide-package@ flags from the command-line. - -- In *reverse* order that they're specified on the command line. - pluginPackageFlags :: [PackageFlag], - -- ^ The @-plugin-package-id@ flags from command line. - -- In *reverse* order that they're specified on the command line. - trustFlags :: [TrustFlag], - -- ^ The @-trust@ and @-distrust@ flags. - -- In *reverse* order that they're specified on the command line. - packageEnv :: Maybe FilePath, - -- ^ Filepath to the package environment file (if overriding default) - - -- Package state - -- NB. do not modify this field, it is calculated by - -- Packages.initPackages - pkgDatabase :: Maybe [(FilePath, [PackageConfig])], - pkgState :: PackageState, - - -- Temporary files - -- These have to be IORefs, because the defaultCleanupHandler needs to - -- know what to clean when an exception happens - filesToClean :: IORef [FilePath], - dirsToClean :: IORef (Map FilePath FilePath), - filesToNotIntermediateClean :: IORef [FilePath], - -- The next available suffix to uniquely name a temp file, updated atomically - nextTempSuffix :: IORef Int, - - -- Names of files which were generated from -ddump-to-file; used to - -- track which ones we need to truncate because it's our first run - -- through - generatedDumps :: IORef (Set FilePath), - - -- hsc dynamic flags - dumpFlags :: IntSet, - generalFlags :: IntSet, - warningFlags :: IntSet, - fatalWarningFlags :: IntSet, - -- Don't change this without updating extensionFlags: - language :: Maybe Language, - -- | Safe Haskell mode - safeHaskell :: SafeHaskellMode, - safeInfer :: Bool, - safeInferred :: Bool, - -- We store the location of where some extension and flags were turned on so - -- we can produce accurate error messages when Safe Haskell fails due to - -- them. - thOnLoc :: SrcSpan, - newDerivOnLoc :: SrcSpan, - overlapInstLoc :: SrcSpan, - incoherentOnLoc :: SrcSpan, - pkgTrustOnLoc :: SrcSpan, - warnSafeOnLoc :: SrcSpan, - warnUnsafeOnLoc :: SrcSpan, - trustworthyOnLoc :: SrcSpan, - -- Don't change this without updating extensionFlags: - extensions :: [OnOff LangExt.Extension], - -- extensionFlags should always be equal to - -- flattenExtensionFlags language extensions - -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used - -- by template-haskell - extensionFlags :: IntSet, - - -- Unfolding control - -- See Note [Discounts and thresholds] in CoreUnfold - ufCreationThreshold :: Int, - ufUseThreshold :: Int, - ufFunAppDiscount :: Int, - ufDictDiscount :: Int, - ufKeenessFactor :: Float, - ufDearOp :: Int, - ufVeryAggressive :: Bool, - - maxWorkerArgs :: Int, - - ghciHistSize :: Int, - - -- | MsgDoc output action: use "ErrUtils" instead of this if you can - initLogAction :: IO (Maybe LogOutput), - log_action :: LogAction, - log_finaliser :: LogFinaliser, - flushOut :: FlushOut, - flushErr :: FlushErr, - - haddockOptions :: Maybe String, - - -- | GHCi scripts specified by -ghci-script, in reverse order - ghciScripts :: [String], - - -- Output style options - pprUserLength :: Int, - pprCols :: Int, - - useUnicode :: Bool, - useColor :: OverridingBool, - canUseColor :: Bool, - colScheme :: Col.Scheme, - - -- | what kind of {-# SCC #-} to add automatically - profAuto :: ProfAuto, - - interactivePrint :: Maybe String, - - nextWrapperNum :: IORef (ModuleEnv Int), - - -- | Machine dependent flags (-m stuff) - sseVersion :: Maybe SseVersion, - avx :: Bool, - avx2 :: Bool, - avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. - avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. - avx512f :: Bool, -- Enable AVX-512 instructions. - avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. - - -- | Run-time linker information (what options we need, etc.) - rtldInfo :: IORef (Maybe LinkerInfo), - - -- | Run-time compiler information - rtccInfo :: IORef (Maybe CompilerInfo), - - -- Constants used to control the amount of optimization done. - - -- | Max size, in bytes, of inline array allocations. - maxInlineAllocSize :: Int, - - -- | Only inline memcpy if it generates no more than this many - -- pseudo (roughly: Cmm) instructions. - maxInlineMemcpyInsns :: Int, - - -- | Only inline memset if it generates no more than this many - -- pseudo (roughly: Cmm) instructions. - maxInlineMemsetInsns :: Int, - - -- | Reverse the order of error messages in GHC/GHCi - reverseErrors :: Bool, - - -- | Limit the maximum number of errors to show - maxErrors :: Maybe Int, - - -- | Unique supply configuration for testing build determinism - initialUnique :: Int, - uniqueIncrement :: Int -} - -class HasDynFlags m where - getDynFlags :: m DynFlags - -{- It would be desirable to have the more generalised - - instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where - getDynFlags = lift getDynFlags - -instance definition. However, that definition would overlap with the -`HasDynFlags (GhcT m)` instance. Instead we define instances for a -couple of common Monad transformers explicitly. -} - -instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where - getDynFlags = lift getDynFlags - -instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where - getDynFlags = lift getDynFlags - -instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where - getDynFlags = lift getDynFlags - -instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where - getDynFlags = lift getDynFlags - -class ContainsDynFlags t where - extractDynFlags :: t -> DynFlags - -data ProfAuto - = NoProfAuto -- ^ no SCC annotations added - | ProfAutoAll -- ^ top-level and nested functions are annotated - | ProfAutoTop -- ^ top-level functions annotated only - | ProfAutoExports -- ^ exported functions annotated only - | ProfAutoCalls -- ^ annotate call-sites - deriving (Eq,Enum) - -data Settings = Settings { - sTargetPlatform :: Platform, -- Filled in by SysTools - sGhcUsagePath :: FilePath, -- Filled in by SysTools - sGhciUsagePath :: FilePath, -- ditto - sTopDir :: FilePath, - sTmpDir :: String, -- no trailing '/' - sProgramName :: String, - sProjectVersion :: String, - -- You shouldn't need to look things up in rawSettings directly. - -- They should have their own fields instead. - sRawSettings :: [(String, String)], - sExtraGccViaCFlags :: [String], - sSystemPackageConfig :: FilePath, - sLdSupportsCompactUnwind :: Bool, - sLdSupportsBuildId :: Bool, - sLdSupportsFilelist :: Bool, - sLdIsGnuLd :: Bool, - sGccSupportsNoPie :: Bool, - -- commands for particular phases - sPgm_L :: String, - sPgm_P :: (String,[Option]), - sPgm_F :: String, - sPgm_c :: (String,[Option]), - sPgm_s :: (String,[Option]), - sPgm_a :: (String,[Option]), - sPgm_l :: (String,[Option]), - sPgm_dll :: (String,[Option]), - sPgm_T :: String, - sPgm_windres :: String, - sPgm_libtool :: String, - sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser - sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler - sPgm_i :: String, - -- options for particular phases - sOpt_L :: [String], - sOpt_P :: [String], - sOpt_F :: [String], - sOpt_c :: [String], - sOpt_a :: [String], - sOpt_l :: [String], - sOpt_windres :: [String], - sOpt_lo :: [String], -- LLVM: llvm optimiser - sOpt_lc :: [String], -- LLVM: llc static compiler - sOpt_i :: [String], -- iserv options - - sPlatformConstants :: PlatformConstants - } - -targetPlatform :: DynFlags -> Platform -targetPlatform dflags = sTargetPlatform (settings dflags) -programName :: DynFlags -> String -programName dflags = sProgramName (settings dflags) -projectVersion :: DynFlags -> String -projectVersion dflags = sProjectVersion (settings dflags) -ghcUsagePath :: DynFlags -> FilePath -ghcUsagePath dflags = sGhcUsagePath (settings dflags) -ghciUsagePath :: DynFlags -> FilePath -ghciUsagePath dflags = sGhciUsagePath (settings dflags) -topDir :: DynFlags -> FilePath -topDir dflags = sTopDir (settings dflags) -tmpDir :: DynFlags -> String -tmpDir dflags = sTmpDir (settings dflags) -rawSettings :: DynFlags -> [(String, String)] -rawSettings dflags = sRawSettings (settings dflags) -extraGccViaCFlags :: DynFlags -> [String] -extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags) -systemPackageConfig :: DynFlags -> FilePath -systemPackageConfig dflags = sSystemPackageConfig (settings dflags) -pgm_L :: DynFlags -> String -pgm_L dflags = sPgm_L (settings dflags) -pgm_P :: DynFlags -> (String,[Option]) -pgm_P dflags = sPgm_P (settings dflags) -pgm_F :: DynFlags -> String -pgm_F dflags = sPgm_F (settings dflags) -pgm_c :: DynFlags -> (String,[Option]) -pgm_c dflags = sPgm_c (settings dflags) -pgm_s :: DynFlags -> (String,[Option]) -pgm_s dflags = sPgm_s (settings dflags) -pgm_a :: DynFlags -> (String,[Option]) -pgm_a dflags = sPgm_a (settings dflags) -pgm_l :: DynFlags -> (String,[Option]) -pgm_l dflags = sPgm_l (settings dflags) -pgm_dll :: DynFlags -> (String,[Option]) -pgm_dll dflags = sPgm_dll (settings dflags) -pgm_T :: DynFlags -> String -pgm_T dflags = sPgm_T (settings dflags) -pgm_windres :: DynFlags -> String -pgm_windres dflags = sPgm_windres (settings dflags) -pgm_libtool :: DynFlags -> String -pgm_libtool dflags = sPgm_libtool (settings dflags) -pgm_lo :: DynFlags -> (String,[Option]) -pgm_lo dflags = sPgm_lo (settings dflags) -pgm_lc :: DynFlags -> (String,[Option]) -pgm_lc dflags = sPgm_lc (settings dflags) -pgm_i :: DynFlags -> String -pgm_i dflags = sPgm_i (settings dflags) -opt_L :: DynFlags -> [String] -opt_L dflags = sOpt_L (settings dflags) -opt_P :: DynFlags -> [String] -opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) - ++ sOpt_P (settings dflags) -opt_F :: DynFlags -> [String] -opt_F dflags = sOpt_F (settings dflags) -opt_c :: DynFlags -> [String] -opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags) - ++ sOpt_c (settings dflags) -opt_a :: DynFlags -> [String] -opt_a dflags = sOpt_a (settings dflags) -opt_l :: DynFlags -> [String] -opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) - ++ sOpt_l (settings dflags) -opt_windres :: DynFlags -> [String] -opt_windres dflags = sOpt_windres (settings dflags) -opt_lo :: DynFlags -> [String] -opt_lo dflags = sOpt_lo (settings dflags) -opt_lc :: DynFlags -> [String] -opt_lc dflags = sOpt_lc (settings dflags) -opt_i :: DynFlags -> [String] -opt_i dflags = sOpt_i (settings dflags) - --- | The directory for this version of ghc in the user's app directory --- (typically something like @~/.ghc/x86_64-linux-7.6.3@) --- -versionedAppDir :: DynFlags -> MaybeT IO FilePath -versionedAppDir dflags = do - -- Make sure we handle the case the HOME isn't set (see #11678) - appdir <- tryMaybeT $ getAppUserDataDirectory (programName dflags) - return $ appdir versionedFilePath dflags - --- | A filepath like @x86_64-linux-7.6.3@ with the platform string to use when --- constructing platform-version-dependent files that need to co-exist. --- -versionedFilePath :: DynFlags -> FilePath -versionedFilePath dflags = TARGET_ARCH - ++ '-':TARGET_OS - ++ '-':projectVersion dflags - -- NB: This functionality is reimplemented in Cabal, so if you - -- change it, be sure to update Cabal. - --- | The target code type of the compilation (if any). --- --- Whenever you change the target, also make sure to set 'ghcLink' to --- something sensible. --- --- 'HscNothing' can be used to avoid generating any output, however, note --- that: --- --- * If a program uses Template Haskell the typechecker may try to run code --- from an imported module. This will fail if no code has been generated --- for this module. You can use 'GHC.needsTemplateHaskell' to detect --- whether this might be the case and choose to either switch to a --- different target or avoid typechecking such modules. (The latter may be --- preferable for security reasons.) --- -data HscTarget - = HscC -- ^ Generate C code. - | HscAsm -- ^ Generate assembly using the native code generator. - | HscLlvm -- ^ Generate assembly using the llvm code generator. - | HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory') - | HscNothing -- ^ Don't generate any code. See notes above. - deriving (Eq, Show) - --- | Will this target result in an object file on the disk? -isObjectTarget :: HscTarget -> Bool -isObjectTarget HscC = True -isObjectTarget HscAsm = True -isObjectTarget HscLlvm = True -isObjectTarget _ = False - --- | Does this target retain *all* top-level bindings for a module, --- rather than just the exported bindings, in the TypeEnv and compiled --- code (if any)? In interpreted mode we do this, so that GHCi can --- call functions inside a module. In HscNothing mode we also do it, --- so that Haddock can get access to the GlobalRdrEnv for a module --- after typechecking it. -targetRetainsAllBindings :: HscTarget -> Bool -targetRetainsAllBindings HscInterpreted = True -targetRetainsAllBindings HscNothing = True -targetRetainsAllBindings _ = False - --- | The 'GhcMode' tells us whether we're doing multi-module --- compilation (controlled via the "GHC" API) or one-shot --- (single-module) compilation. This makes a difference primarily to --- the "Finder": in one-shot mode we look for interface files for --- imported modules, but in multi-module mode we look for source files --- in order to check whether they need to be recompiled. -data GhcMode - = CompManager -- ^ @\-\-make@, GHCi, etc. - | OneShot -- ^ @ghc -c Foo.hs@ - | MkDepend -- ^ @ghc -M@, see "Finder" for why we need this - deriving Eq - -instance Outputable GhcMode where - ppr CompManager = text "CompManager" - ppr OneShot = text "OneShot" - ppr MkDepend = text "MkDepend" - -isOneShot :: GhcMode -> Bool -isOneShot OneShot = True -isOneShot _other = False - --- | What to do in the link step, if there is one. -data GhcLink - = NoLink -- ^ Don't link at all - | LinkBinary -- ^ Link object code into a binary - | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both - -- bytecode and object code). - | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) - | LinkStaticLib -- ^ Link objects into a static lib - deriving (Eq, Show) - -isNoLink :: GhcLink -> Bool -isNoLink NoLink = True -isNoLink _ = False - --- | We accept flags which make packages visible, but how they select --- the package varies; this data type reflects what selection criterion --- is used. -data PackageArg = - PackageArg String -- ^ @-package@, by 'PackageName' - | UnitIdArg UnitId -- ^ @-package-id@, by 'UnitId' - deriving (Eq, Show) -instance Outputable PackageArg where - ppr (PackageArg pn) = text "package" <+> text pn - ppr (UnitIdArg uid) = text "unit" <+> ppr uid - --- | Represents the renaming that may be associated with an exposed --- package, e.g. the @rns@ part of @-package "foo (rns)"@. --- --- Here are some example parsings of the package flags (where --- a string literal is punned to be a 'ModuleName': --- --- * @-package foo@ is @ModRenaming True []@ --- * @-package foo ()@ is @ModRenaming False []@ --- * @-package foo (A)@ is @ModRenaming False [("A", "A")]@ --- * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@ --- * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@ -data ModRenaming = ModRenaming { - modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? - modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope - -- under name @n@. - } deriving (Eq) -instance Outputable ModRenaming where - ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) - --- | Flags for manipulating the set of non-broken packages. -newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@ - deriving (Eq) - --- | Flags for manipulating package trust. -data TrustFlag - = TrustPackage String -- ^ @-trust@ - | DistrustPackage String -- ^ @-distrust@ - deriving (Eq) - --- | Flags for manipulating packages visibility. -data PackageFlag - = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ - | HidePackage String -- ^ @-hide-package@ - deriving (Eq) -- NB: equality instance is used by packageFlagsChanged - -data PackageDBFlag - = PackageDB PkgConfRef - | NoUserPackageDB - | NoGlobalPackageDB - | ClearPackageDBs - deriving (Eq) - -packageFlagsChanged :: DynFlags -> DynFlags -> Bool -packageFlagsChanged idflags1 idflags0 = - packageFlags idflags1 /= packageFlags idflags0 || - ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 || - pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 || - trustFlags idflags1 /= trustFlags idflags0 || - packageDBFlags idflags1 /= packageDBFlags idflags0 || - packageGFlags idflags1 /= packageGFlags idflags0 - where - packageGFlags dflags = map (`gopt` dflags) - [ Opt_HideAllPackages - , Opt_HideAllPluginPackages - , Opt_AutoLinkPackages ] - -instance Outputable PackageFlag where - ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) - ppr (HidePackage str) = text "-hide-package" <+> text str - -defaultHscTarget :: Platform -> HscTarget -defaultHscTarget = defaultObjectTarget - --- | The 'HscTarget' value corresponding to the default way to create --- object files on the current platform. -defaultObjectTarget :: Platform -> HscTarget -defaultObjectTarget platform - | platformUnregisterised platform = HscC - | cGhcWithNativeCodeGen == "YES" = HscAsm - | otherwise = HscLlvm - -tablesNextToCode :: DynFlags -> Bool -tablesNextToCode dflags - = mkTablesNextToCode (platformUnregisterised (targetPlatform dflags)) - --- Determines whether we will be compiling --- info tables that reside just before the entry code, or with an --- indirection to the entry code. See TABLES_NEXT_TO_CODE in --- includes/rts/storage/InfoTables.h. -mkTablesNextToCode :: Bool -> Bool -mkTablesNextToCode unregisterised - = not unregisterised && cGhcEnableTablesNextToCode == "YES" - -data DynLibLoader - = Deployable - | SystemDependent - deriving Eq - -data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll - deriving (Show) - -shouldUseColor :: DynFlags -> Bool -shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags) - --- | Are we building with @-fPIE@ or @-fPIC@ enabled? -positionIndependent :: DynFlags -> Bool -positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags - ------------------------------------------------------------------------------ --- Ways - --- The central concept of a "way" is that all objects in a given --- program must be compiled in the same "way". Certain options change --- parameters of the virtual machine, eg. profiling adds an extra word --- to the object header, so profiling objects cannot be linked with --- non-profiling objects. - --- After parsing the command-line options, we determine which "way" we --- are building - this might be a combination way, eg. profiling+threaded. - --- We then find the "build-tag" associated with this way, and this --- becomes the suffix used to find .hi files and libraries used in --- this compilation. - -data Way - = WayCustom String -- for GHC API clients building custom variants - | WayThreaded - | WayDebug - | WayProf - | WayEventLog - | WayDyn - deriving (Eq, Ord, Show) - -allowed_combination :: [Way] -> Bool -allowed_combination way = and [ x `allowedWith` y - | x <- way, y <- way, x < y ] - where - -- Note ordering in these tests: the left argument is - -- <= the right argument, according to the Ord instance - -- on Way above. - - -- dyn is allowed with everything - _ `allowedWith` WayDyn = True - WayDyn `allowedWith` _ = True - - -- debug is allowed with everything - _ `allowedWith` WayDebug = True - WayDebug `allowedWith` _ = True - - (WayCustom {}) `allowedWith` _ = True - WayThreaded `allowedWith` WayProf = True - WayThreaded `allowedWith` WayEventLog = True - WayProf `allowedWith` WayEventLog = True - _ `allowedWith` _ = False - -mkBuildTag :: [Way] -> String -mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) - -wayTag :: Way -> String -wayTag (WayCustom xs) = xs -wayTag WayThreaded = "thr" -wayTag WayDebug = "debug" -wayTag WayDyn = "dyn" -wayTag WayProf = "p" -wayTag WayEventLog = "l" - -wayRTSOnly :: Way -> Bool -wayRTSOnly (WayCustom {}) = False -wayRTSOnly WayThreaded = True -wayRTSOnly WayDebug = True -wayRTSOnly WayDyn = False -wayRTSOnly WayProf = False -wayRTSOnly WayEventLog = True - -wayDesc :: Way -> String -wayDesc (WayCustom xs) = xs -wayDesc WayThreaded = "Threaded" -wayDesc WayDebug = "Debug" -wayDesc WayDyn = "Dynamic" -wayDesc WayProf = "Profiling" -wayDesc WayEventLog = "RTS Event Logging" - --- Turn these flags on when enabling this way -wayGeneralFlags :: Platform -> Way -> [GeneralFlag] -wayGeneralFlags _ (WayCustom {}) = [] -wayGeneralFlags _ WayThreaded = [] -wayGeneralFlags _ WayDebug = [] -wayGeneralFlags _ WayDyn = [Opt_PIC] - -- We could get away without adding -fPIC when compiling the - -- modules of a program that is to be linked with -dynamic; the - -- program itself does not need to be position-independent, only - -- the libraries need to be. HOWEVER, GHCi links objects into a - -- .so before loading the .so using the system linker. Since only - -- PIC objects can be linked into a .so, we have to compile even - -- modules of the main program with -fPIC when using -dynamic. -wayGeneralFlags _ WayProf = [Opt_SccProfilingOn] -wayGeneralFlags _ WayEventLog = [] - --- Turn these flags off when enabling this way -wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] -wayUnsetGeneralFlags _ (WayCustom {}) = [] -wayUnsetGeneralFlags _ WayThreaded = [] -wayUnsetGeneralFlags _ WayDebug = [] -wayUnsetGeneralFlags _ WayDyn = [-- There's no point splitting objects - -- when we're going to be dynamically - -- linking. Plus it breaks compilation - -- on OSX x86. - Opt_SplitObjs, - -- If splitobjs wasn't useful for this, - -- assume sections aren't either. - Opt_SplitSections] -wayUnsetGeneralFlags _ WayProf = [] -wayUnsetGeneralFlags _ WayEventLog = [] - -wayOptc :: Platform -> Way -> [String] -wayOptc _ (WayCustom {}) = [] -wayOptc platform WayThreaded = case platformOS platform of - OSOpenBSD -> ["-pthread"] - OSNetBSD -> ["-pthread"] - _ -> [] -wayOptc _ WayDebug = [] -wayOptc _ WayDyn = [] -wayOptc _ WayProf = ["-DPROFILING"] -wayOptc _ WayEventLog = ["-DTRACING"] - -wayOptl :: Platform -> Way -> [String] -wayOptl _ (WayCustom {}) = [] -wayOptl platform WayThreaded = - case platformOS platform of - OSFreeBSD -> ["-pthread"] - OSOpenBSD -> ["-pthread"] - OSNetBSD -> ["-pthread"] - _ -> [] -wayOptl _ WayDebug = [] -wayOptl _ WayDyn = [] -wayOptl _ WayProf = [] -wayOptl _ WayEventLog = [] - -wayOptP :: Platform -> Way -> [String] -wayOptP _ (WayCustom {}) = [] -wayOptP _ WayThreaded = [] -wayOptP _ WayDebug = [] -wayOptP _ WayDyn = [] -wayOptP _ WayProf = ["-DPROFILING"] -wayOptP _ WayEventLog = ["-DTRACING"] - -whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m () -whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ()) - -ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a -ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g - -whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m () -whenCannotGenerateDynamicToo dflags f - = ifCannotGenerateDynamicToo dflags f (return ()) - -ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a -ifCannotGenerateDynamicToo dflags f g - = generateDynamicTooConditional dflags g f g - -generateDynamicTooConditional :: MonadIO m - => DynFlags -> m a -> m a -> m a -> m a -generateDynamicTooConditional dflags canGen cannotGen notTryingToGen - = if gopt Opt_BuildDynamicToo dflags - then do let ref = canGenerateDynamicToo dflags - b <- liftIO $ readIORef ref - if b then canGen else cannotGen - else notTryingToGen - -dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags -dynamicTooMkDynamicDynFlags dflags0 - = let dflags1 = addWay' WayDyn dflags0 - dflags2 = dflags1 { - outputFile = dynOutputFile dflags1, - hiSuf = dynHiSuf dflags1, - objectSuf = dynObjectSuf dflags1 - } - dflags3 = updateWays dflags2 - dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo - in dflags4 - ------------------------------------------------------------------------------ - --- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value -initDynFlags :: DynFlags -> IO DynFlags -initDynFlags dflags = do - let -- We can't build with dynamic-too on Windows, as labels before - -- the fork point are different depending on whether we are - -- building dynamically or not. - platformCanGenerateDynamicToo - = platformOS (targetPlatform dflags) /= OSMinGW32 - refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo - refNextTempSuffix <- newIORef 0 - refFilesToClean <- newIORef [] - refDirsToClean <- newIORef Map.empty - refFilesToNotIntermediateClean <- newIORef [] - refGeneratedDumps <- newIORef Set.empty - refRtldInfo <- newIORef Nothing - refRtccInfo <- newIORef Nothing - wrapperNum <- newIORef emptyModuleEnv - canUseUnicode <- do let enc = localeEncoding - str = "‘’" - (withCString enc str $ \cstr -> - do str' <- peekCString enc cstr - return (str == str')) - `catchIOError` \_ -> return False - canUseColor <- stderrSupportsAnsiColors - maybeGhcColorsEnv <- lookupEnv "GHC_COLORS" - maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS" - let adjustCols (Just env) = Col.parseScheme env - adjustCols Nothing = id - let (useColor', colScheme') = - (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv) - (useColor dflags, colScheme dflags) - return dflags{ - canGenerateDynamicToo = refCanGenerateDynamicToo, - nextTempSuffix = refNextTempSuffix, - filesToClean = refFilesToClean, - dirsToClean = refDirsToClean, - filesToNotIntermediateClean = refFilesToNotIntermediateClean, - generatedDumps = refGeneratedDumps, - nextWrapperNum = wrapperNum, - useUnicode = canUseUnicode, - useColor = useColor', - canUseColor = canUseColor, - colScheme = colScheme', - rtldInfo = refRtldInfo, - rtccInfo = refRtccInfo - } - --- | The normal 'DynFlags'. Note that they are not suitable for use in this form --- and must be fully initialized by 'GHC.runGhc' first. -defaultDynFlags :: Settings -> DynFlags -defaultDynFlags mySettings = --- See Note [Updating flag description in the User's Guide] - DynFlags { - ghcMode = CompManager, - ghcLink = LinkBinary, - hscTarget = defaultHscTarget (sTargetPlatform mySettings), - verbosity = 0, - optLevel = 0, - debugLevel = 0, - simplPhases = 2, - maxSimplIterations = 4, - maxPmCheckIterations = 2000000, - ruleCheck = Nothing, - maxRelevantBinds = Just 6, - maxUncoveredPatterns = 4, - simplTickFactor = 100, - specConstrThreshold = Just 2000, - specConstrCount = Just 3, - specConstrRecursive = 3, - liberateCaseThreshold = Just 2000, - floatLamArgs = Just 0, -- Default: float only if no fvs - - historySize = 20, - strictnessBefore = [], - - parMakeCount = Just 1, - - enableTimeStats = False, - ghcHeapSize = Nothing, - - importPaths = ["."], - mainModIs = mAIN, - mainFunIs = Nothing, - reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, - solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, - - thisInstalledUnitId = toInstalledUnitId mainUnitId, - thisUnitIdInsts_ = Nothing, - thisComponentId_ = Nothing, - - objectDir = Nothing, - dylibInstallName = Nothing, - hiDir = Nothing, - stubDir = Nothing, - dumpDir = Nothing, - - objectSuf = phaseInputExt StopLn, - hcSuf = phaseInputExt HCc, - hiSuf = "hi", - - canGenerateDynamicToo = panic "defaultDynFlags: No canGenerateDynamicToo", - dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, - dynHiSuf = "dyn_hi", - - dllSplitFile = Nothing, - dllSplit = Nothing, - - pluginModNames = [], - pluginModNameOpts = [], - frontendPluginOpts = [], - hooks = emptyHooks, - - outputFile = Nothing, - dynOutputFile = Nothing, - outputHi = Nothing, - dynLibLoader = SystemDependent, - dumpPrefix = Nothing, - dumpPrefixForce = Nothing, - ldInputs = [], - includePaths = [], - libraryPaths = [], - frameworkPaths = [], - cmdlineFrameworks = [], - rtsOpts = Nothing, - rtsOptsEnabled = RtsOptsSafeOnly, - rtsOptsSuggestions = True, - - hpcDir = ".hpc", - - packageDBFlags = [], - packageFlags = [], - pluginPackageFlags = [], - ignorePackageFlags = [], - trustFlags = [], - packageEnv = Nothing, - pkgDatabase = Nothing, - -- This gets filled in with GHC.setSessionDynFlags - pkgState = emptyPackageState, - ways = defaultWays mySettings, - buildTag = mkBuildTag (defaultWays mySettings), - rtsBuildTag = mkBuildTag (defaultWays mySettings), - splitInfo = Nothing, - settings = mySettings, - -- ghc -M values - depMakefile = "Makefile", - depIncludePkgDeps = False, - depExcludeMods = [], - depSuffixes = [], - -- end of ghc -M values - nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix", - filesToClean = panic "defaultDynFlags: No filesToClean", - dirsToClean = panic "defaultDynFlags: No dirsToClean", - filesToNotIntermediateClean = panic "defaultDynFlags: No filesToNotIntermediateClean", - generatedDumps = panic "defaultDynFlags: No generatedDumps", - haddockOptions = Nothing, - dumpFlags = IntSet.empty, - generalFlags = IntSet.fromList (map fromEnum (defaultFlags mySettings)), - warningFlags = IntSet.fromList (map fromEnum standardWarnings), - fatalWarningFlags = IntSet.empty, - ghciScripts = [], - language = Nothing, - safeHaskell = Sf_None, - safeInfer = True, - safeInferred = True, - thOnLoc = noSrcSpan, - newDerivOnLoc = noSrcSpan, - overlapInstLoc = noSrcSpan, - incoherentOnLoc = noSrcSpan, - pkgTrustOnLoc = noSrcSpan, - warnSafeOnLoc = noSrcSpan, - warnUnsafeOnLoc = noSrcSpan, - trustworthyOnLoc = noSrcSpan, - extensions = [], - extensionFlags = flattenExtensionFlags Nothing [], - - -- The ufCreationThreshold threshold must be reasonably high to - -- take account of possible discounts. - -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline - -- into Csg.calc (The unfolding for sqr never makes it into the - -- interface file.) - ufCreationThreshold = 750, - ufUseThreshold = 60, - ufFunAppDiscount = 60, - -- Be fairly keen to inline a function if that means - -- we'll be able to pick the right method from a dictionary - ufDictDiscount = 30, - ufKeenessFactor = 1.5, - ufDearOp = 40, - ufVeryAggressive = False, - - maxWorkerArgs = 10, - - ghciHistSize = 50, -- keep a log of length 50 by default - - -- Logging - - initLogAction = defaultLogOutput, - - log_action = defaultLogAction, - log_finaliser = \ _ -> return (), - - flushOut = defaultFlushOut, - flushErr = defaultFlushErr, - pprUserLength = 5, - pprCols = 100, - useUnicode = False, - useColor = Auto, - canUseColor = False, - colScheme = Col.defaultScheme, - profAuto = NoProfAuto, - interactivePrint = Nothing, - nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", - sseVersion = Nothing, - avx = False, - avx2 = False, - avx512cd = False, - avx512er = False, - avx512f = False, - avx512pf = False, - rtldInfo = panic "defaultDynFlags: no rtldInfo", - rtccInfo = panic "defaultDynFlags: no rtccInfo", - - maxInlineAllocSize = 128, - maxInlineMemcpyInsns = 32, - maxInlineMemsetInsns = 32, - - initialUnique = 0, - uniqueIncrement = 1, - - reverseErrors = False, - maxErrors = Nothing - } - -defaultWays :: Settings -> [Way] -defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) - then [WayDyn] - else [] - -interpWays :: [Way] -interpWays - | dynamicGhc = [WayDyn] - | rtsIsProfiled = [WayProf] - | otherwise = [] - -interpreterProfiled :: DynFlags -> Bool -interpreterProfiled dflags - | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags - | otherwise = rtsIsProfiled - -interpreterDynamic :: DynFlags -> Bool -interpreterDynamic dflags - | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags - | otherwise = dynamicGhc - --------------------------------------------------------------------------- --- --- Note [JSON Error Messages] --- --- When the user requests the compiler output to be dumped as json --- we modify the log_action to collect all the messages in an IORef --- and then finally in GHC.withCleanupSession the log_finaliser is --- called which prints out the messages together. --- --- Before the compiler calls log_action, it has already turned the `ErrMsg` --- into a formatted message. This means that we lose some possible --- information to provide to the user but refactoring log_action is quite --- invasive as it is called in many places. So, for now I left it alone --- and we can refine its behaviour as users request different output. - -type FatalMessager = String -> IO () - -data LogOutput = LogOutput - { getLogAction :: LogAction - , getLogFinaliser :: LogFinaliser - } - -defaultLogOutput :: IO (Maybe LogOutput) -defaultLogOutput = return $ Nothing - -type LogAction = DynFlags - -> WarnReason - -> Severity - -> SrcSpan - -> PprStyle - -> MsgDoc - -> IO () - -type LogFinaliser = DynFlags -> IO () - -defaultFatalMessager :: FatalMessager -defaultFatalMessager = hPutStrLn stderr - - --- See Note [JSON Error Messages] -jsonLogOutput :: IO (Maybe LogOutput) -jsonLogOutput = do - ref <- newIORef [] - return . Just $ LogOutput (jsonLogAction ref) (jsonLogFinaliser ref) - -jsonLogAction :: IORef [SDoc] -> LogAction -jsonLogAction iref dflags reason severity srcSpan style msg - = do - addMessage . withPprStyle (mkCodeStyle CStyle) . renderJSON $ - JSObject [ ( "span", json srcSpan ) - , ( "doc" , JSString (showSDoc dflags msg) ) - , ( "severity", json severity ) - , ( "reason" , json reason ) - ] - defaultLogAction dflags reason severity srcSpan style msg - where - addMessage m = modifyIORef iref (m:) - - -jsonLogFinaliser :: IORef [SDoc] -> DynFlags -> IO () -jsonLogFinaliser iref dflags = do - msgs <- readIORef iref - let fmt_msgs = brackets $ pprWithCommas (blankLine $$) msgs - output fmt_msgs - where - -- dumpSDoc uses log_action to output the dump - dflags' = dflags { log_action = defaultLogAction } - output doc = dumpSDoc dflags' neverQualify Opt_D_dump_json "" doc - - -defaultLogAction :: LogAction -defaultLogAction dflags reason severity srcSpan style msg - = case severity of - SevOutput -> printOut msg style - SevDump -> printOut (msg $$ blankLine) style - SevInteractive -> putStrSDoc msg style - SevInfo -> printErrs msg style - SevFatal -> printErrs msg style - _ -> do -- otherwise (i.e. SevError or SevWarning) - hPutChar stderr '\n' - caretDiagnostic <- - if gopt Opt_DiagnosticsShowCaret dflags - then getCaretDiagnostic severity srcSpan - else pure empty - printErrs (message $+$ caretDiagnostic) - (setStyleColoured True style) - -- careful (#2302): printErrs prints in UTF-8, - -- whereas converting to string first and using - -- hPutStr would just emit the low 8 bits of - -- each unicode char. - where printOut = defaultLogActionHPrintDoc dflags stdout - printErrs = defaultLogActionHPrintDoc dflags stderr - putStrSDoc = defaultLogActionHPutStrDoc dflags stdout - -- Pretty print the warning flag, if any (#10752) - message = mkLocMessageAnn flagMsg severity srcSpan msg - flagMsg = case reason of - NoReason -> Nothing - Reason flag -> (\spec -> "-W" ++ flagSpecName spec ++ flagGrp flag) <$> - flagSpecOf flag - - flagGrp flag - | gopt Opt_ShowWarnGroups dflags = - case smallestGroups flag of - [] -> "" - groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" - | otherwise = "" - --- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. -defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () -defaultLogActionHPrintDoc dflags h d sty - = defaultLogActionHPutStrDoc dflags h (d $$ text "") sty - -defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () -defaultLogActionHPutStrDoc dflags h d sty - -- Don't add a newline at the end, so that successive - -- calls to this log-action can output all on the same line - = printSDoc Pretty.PageMode dflags h sty d - -newtype FlushOut = FlushOut (IO ()) - -defaultFlushOut :: FlushOut -defaultFlushOut = FlushOut $ hFlush stdout - -newtype FlushErr = FlushErr (IO ()) - -defaultFlushErr :: FlushErr -defaultFlushErr = FlushErr $ hFlush stderr - -{- -Note [Verbosity levels] -~~~~~~~~~~~~~~~~~~~~~~~ - 0 | print errors & warnings only - 1 | minimal verbosity: print "compiling M ... done." for each module. - 2 | equivalent to -dshow-passes - 3 | equivalent to existing "ghc -v" - 4 | "ghc -v -ddump-most" - 5 | "ghc -v -ddump-all" --} - -data OnOff a = On a - | Off a - deriving (Eq, Show) - -instance Outputable a => Outputable (OnOff a) where - ppr (On x) = text "On" <+> ppr x - ppr (Off x) = text "Off" <+> ppr x - --- OnOffs accumulate in reverse order, so we use foldr in order to --- process them in the right order -flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> IntSet -flattenExtensionFlags ml = foldr f defaultExtensionFlags - where f (On f) flags = IntSet.insert (fromEnum f) flags - f (Off f) flags = IntSet.delete (fromEnum f) flags - defaultExtensionFlags = IntSet.fromList (map fromEnum (languageExtensions ml)) - -languageExtensions :: Maybe Language -> [LangExt.Extension] - -languageExtensions Nothing - -- Nothing => the default case - = LangExt.NondecreasingIndentation -- This has been on by default for some time - : delete LangExt.DatatypeContexts -- The Haskell' committee decided to - -- remove datatype contexts from the - -- language: - -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html - (languageExtensions (Just Haskell2010)) - - -- NB: MonoPatBinds is no longer the default - -languageExtensions (Just Haskell98) - = [LangExt.ImplicitPrelude, - LangExt.MonomorphismRestriction, - LangExt.NPlusKPatterns, - LangExt.DatatypeContexts, - LangExt.TraditionalRecordSyntax, - LangExt.NondecreasingIndentation - -- strictly speaking non-standard, but we always had this - -- on implicitly before the option was added in 7.1, and - -- turning it off breaks code, so we're keeping it on for - -- backwards compatibility. Cabal uses -XHaskell98 by - -- default unless you specify another language. - ] - -languageExtensions (Just Haskell2010) - = [LangExt.ImplicitPrelude, - LangExt.MonomorphismRestriction, - LangExt.DatatypeContexts, - LangExt.TraditionalRecordSyntax, - LangExt.EmptyDataDecls, - LangExt.ForeignFunctionInterface, - LangExt.PatternGuards, - LangExt.DoAndIfThenElse, - LangExt.RelaxedPolyRec] - -hasPprDebug :: DynFlags -> Bool -hasPprDebug = dopt Opt_D_ppr_debug - -hasNoDebugOutput :: DynFlags -> Bool -hasNoDebugOutput = dopt Opt_D_no_debug_output - -hasNoStateHack :: DynFlags -> Bool -hasNoStateHack = gopt Opt_G_NoStateHack - -hasNoOptCoercion :: DynFlags -> Bool -hasNoOptCoercion = gopt Opt_G_NoOptCoercion - - --- | Test whether a 'DumpFlag' is set -dopt :: DumpFlag -> DynFlags -> Bool -dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags) - || (verbosity dflags >= 4 && enableIfVerbose f) - where enableIfVerbose Opt_D_dump_tc_trace = False - enableIfVerbose Opt_D_dump_rn_trace = False - enableIfVerbose Opt_D_dump_cs_trace = False - enableIfVerbose Opt_D_dump_if_trace = False - enableIfVerbose Opt_D_dump_vt_trace = False - enableIfVerbose Opt_D_dump_tc = False - enableIfVerbose Opt_D_dump_rn = False - enableIfVerbose Opt_D_dump_shape = False - enableIfVerbose Opt_D_dump_rn_stats = False - enableIfVerbose Opt_D_dump_hi_diffs = False - enableIfVerbose Opt_D_verbose_core2core = False - enableIfVerbose Opt_D_verbose_stg2stg = False - enableIfVerbose Opt_D_dump_splices = False - enableIfVerbose Opt_D_th_dec_file = False - enableIfVerbose Opt_D_dump_rule_firings = False - enableIfVerbose Opt_D_dump_rule_rewrites = False - enableIfVerbose Opt_D_dump_simpl_trace = False - enableIfVerbose Opt_D_dump_rtti = False - enableIfVerbose Opt_D_dump_inlinings = False - enableIfVerbose Opt_D_dump_core_stats = False - enableIfVerbose Opt_D_dump_asm_stats = False - enableIfVerbose Opt_D_dump_types = False - enableIfVerbose Opt_D_dump_simpl_iterations = False - enableIfVerbose Opt_D_dump_ticked = False - enableIfVerbose Opt_D_dump_view_pattern_commoning = False - enableIfVerbose Opt_D_dump_mod_cycles = False - enableIfVerbose Opt_D_dump_mod_map = False - enableIfVerbose Opt_D_dump_ec_trace = False - enableIfVerbose _ = True - --- | Set a 'DumpFlag' -dopt_set :: DynFlags -> DumpFlag -> DynFlags -dopt_set dfs f = dfs{ dumpFlags = IntSet.insert (fromEnum f) (dumpFlags dfs) } - --- | Unset a 'DumpFlag' -dopt_unset :: DynFlags -> DumpFlag -> DynFlags -dopt_unset dfs f = dfs{ dumpFlags = IntSet.delete (fromEnum f) (dumpFlags dfs) } - --- | Test whether a 'GeneralFlag' is set -gopt :: GeneralFlag -> DynFlags -> Bool -gopt f dflags = fromEnum f `IntSet.member` generalFlags dflags - --- | Set a 'GeneralFlag' -gopt_set :: DynFlags -> GeneralFlag -> DynFlags -gopt_set dfs f = dfs{ generalFlags = IntSet.insert (fromEnum f) (generalFlags dfs) } - --- | Unset a 'GeneralFlag' -gopt_unset :: DynFlags -> GeneralFlag -> DynFlags -gopt_unset dfs f = dfs{ generalFlags = IntSet.delete (fromEnum f) (generalFlags dfs) } - --- | Test whether a 'WarningFlag' is set -wopt :: WarningFlag -> DynFlags -> Bool -wopt f dflags = fromEnum f `IntSet.member` warningFlags dflags - --- | Set a 'WarningFlag' -wopt_set :: DynFlags -> WarningFlag -> DynFlags -wopt_set dfs f = dfs{ warningFlags = IntSet.insert (fromEnum f) (warningFlags dfs) } - --- | Unset a 'WarningFlag' -wopt_unset :: DynFlags -> WarningFlag -> DynFlags -wopt_unset dfs f = dfs{ warningFlags = IntSet.delete (fromEnum f) (warningFlags dfs) } - --- | Test whether a 'WarningFlag' is set as fatal -wopt_fatal :: WarningFlag -> DynFlags -> Bool -wopt_fatal f dflags = fromEnum f `IntSet.member` fatalWarningFlags dflags - --- | Mark a 'WarningFlag' as fatal (do not set the flag) -wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags -wopt_set_fatal dfs f - = dfs { fatalWarningFlags = - IntSet.insert (fromEnum f) (fatalWarningFlags dfs) } - --- | Mark a 'WarningFlag' as not fatal -wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags -wopt_unset_fatal dfs f - = dfs { fatalWarningFlags = - IntSet.delete (fromEnum f) (fatalWarningFlags dfs) } - --- | Test whether a 'LangExt.Extension' is set -xopt :: LangExt.Extension -> DynFlags -> Bool -xopt f dflags = fromEnum f `IntSet.member` extensionFlags dflags - --- | Set a 'LangExt.Extension' -xopt_set :: DynFlags -> LangExt.Extension -> DynFlags -xopt_set dfs f - = let onoffs = On f : extensions dfs - in dfs { extensions = onoffs, - extensionFlags = flattenExtensionFlags (language dfs) onoffs } - --- | Unset a 'LangExt.Extension' -xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags -xopt_unset dfs f - = let onoffs = Off f : extensions dfs - in dfs { extensions = onoffs, - extensionFlags = flattenExtensionFlags (language dfs) onoffs } - -lang_set :: DynFlags -> Maybe Language -> DynFlags -lang_set dflags lang = - dflags { - language = lang, - extensionFlags = flattenExtensionFlags lang (extensions dflags) - } - --- | An internal helper to check whether to use unicode syntax for output. --- --- Note: You should very likely be using 'Outputable.unicodeSyntax' instead --- of this function. -useUnicodeSyntax :: DynFlags -> Bool -useUnicodeSyntax = gopt Opt_PrintUnicodeSyntax - --- | Set the Haskell language standard to use -setLanguage :: Language -> DynP () -setLanguage l = upd (`lang_set` Just l) - --- | Some modules have dependencies on others through the DynFlags rather than textual imports -dynFlagDependencies :: DynFlags -> [ModuleName] -dynFlagDependencies = pluginModNames - --- | Is the -fpackage-trust mode on -packageTrustOn :: DynFlags -> Bool -packageTrustOn = gopt Opt_PackageTrust - --- | Is Safe Haskell on in some way (including inference mode) -safeHaskellOn :: DynFlags -> Bool -safeHaskellOn dflags = safeHaskell dflags /= Sf_None || safeInferOn dflags - --- | Is the Safe Haskell safe language in use -safeLanguageOn :: DynFlags -> Bool -safeLanguageOn dflags = safeHaskell dflags == Sf_Safe - --- | Is the Safe Haskell safe inference mode active -safeInferOn :: DynFlags -> Bool -safeInferOn = safeInfer - --- | Test if Safe Imports are on in some form -safeImportsOn :: DynFlags -> Bool -safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe || - safeHaskell dflags == Sf_Trustworthy || - safeHaskell dflags == Sf_Safe - --- | Set a 'Safe Haskell' flag -setSafeHaskell :: SafeHaskellMode -> DynP () -setSafeHaskell s = updM f - where f dfs = do - let sf = safeHaskell dfs - safeM <- combineSafeFlags sf s - case s of - Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } - -- leave safe inferrence on in Trustworthy mode so we can warn - -- if it could have been inferred safe. - Sf_Trustworthy -> do - l <- getCurLoc - return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } - -- leave safe inference on in Unsafe mode as well. - _ -> return $ dfs { safeHaskell = safeM } - --- | Are all direct imports required to be safe for this Safe Haskell mode? --- Direct imports are when the code explicitly imports a module -safeDirectImpsReq :: DynFlags -> Bool -safeDirectImpsReq d = safeLanguageOn d - --- | Are all implicit imports required to be safe for this Safe Haskell mode? --- Implicit imports are things in the prelude. e.g System.IO when print is used. -safeImplicitImpsReq :: DynFlags -> Bool -safeImplicitImpsReq d = safeLanguageOn d - --- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. --- This makes Safe Haskell very much a monoid but for now I prefer this as I don't --- want to export this functionality from the module but do want to export the --- type constructors. -combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode -combineSafeFlags a b | a == Sf_None = return b - | b == Sf_None = return a - | a == b = return a - | otherwise = addErr errm >> pure a - where errm = "Incompatible Safe Haskell flags! (" - ++ show a ++ ", " ++ show b ++ ")" - --- | A list of unsafe flags under Safe Haskell. Tuple elements are: --- * name of the flag --- * function to get srcspan that enabled the flag --- * function to test if the flag is on --- * function to turn the flag off -unsafeFlags, unsafeFlagsForInfer - :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] -unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc, - xopt LangExt.GeneralizedNewtypeDeriving, - flip xopt_unset LangExt.GeneralizedNewtypeDeriving) - , ("-XTemplateHaskell", thOnLoc, - xopt LangExt.TemplateHaskell, - flip xopt_unset LangExt.TemplateHaskell) - ] -unsafeFlagsForInfer = unsafeFlags - - --- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order -getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from - -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors - -> [a] -- ^ Correctly ordered extracted options -getOpts dflags opts = reverse (opts dflags) - -- We add to the options from the front, so we need to reverse the list - --- | Gets the verbosity flag for the current verbosity level. This is fed to --- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included -getVerbFlags :: DynFlags -> [String] -getVerbFlags dflags - | verbosity dflags >= 4 = ["-v"] - | otherwise = [] - -setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, - setDynObjectSuf, setDynHiSuf, - setDylibInstallName, - setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, - setPgmP, addOptl, addOptc, addOptP, - addCmdlineFramework, addHaddockOpts, addGhciScript, - setInteractivePrint - :: String -> DynFlags -> DynFlags -setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce - :: Maybe String -> DynFlags -> DynFlags - -setObjectDir f d = d { objectDir = Just f} -setHiDir f d = d { hiDir = Just f} -setStubDir f d = d { stubDir = Just f, includePaths = f : includePaths d } - -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file - -- \#included from the .hc file when compiling via C (i.e. unregisterised - -- builds). -setDumpDir f d = d { dumpDir = Just f} -setOutputDir f = setObjectDir f . setHiDir f . setStubDir f . setDumpDir f -setDylibInstallName f d = d { dylibInstallName = Just f} - -setObjectSuf f d = d { objectSuf = f} -setDynObjectSuf f d = d { dynObjectSuf = f} -setHiSuf f d = d { hiSuf = f} -setDynHiSuf f d = d { dynHiSuf = f} -setHcSuf f d = d { hcSuf = f} - -setOutputFile f d = d { outputFile = f} -setDynOutputFile f d = d { dynOutputFile = f} -setOutputHi f d = d { outputHi = f} - -setJsonLogAction :: DynFlags -> DynFlags -setJsonLogAction d = d { initLogAction = jsonLogOutput } - -thisComponentId :: DynFlags -> ComponentId -thisComponentId dflags = - case thisComponentId_ dflags of - Just cid -> cid - Nothing -> - case thisUnitIdInsts_ dflags of - Just _ -> - throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") - Nothing -> ComponentId (unitIdFS (thisPackage dflags)) - -thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)] -thisUnitIdInsts dflags = - case thisUnitIdInsts_ dflags of - Just insts -> insts - Nothing -> [] - -thisPackage :: DynFlags -> UnitId -thisPackage dflags = - case thisUnitIdInsts_ dflags of - Nothing -> default_uid - Just insts - | all (\(x,y) -> mkHoleModule x == y) insts - -> newUnitId (thisComponentId dflags) insts - | otherwise - -> default_uid - where - default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags)) - -parseUnitIdInsts :: String -> [(ModuleName, Module)] -parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of - [(r, "")] -> r - _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) - where parse = sepBy parseEntry (R.char ',') - parseEntry = do - n <- parseModuleName - _ <- R.char '=' - m <- parseModuleId - return (n, m) - -setUnitIdInsts :: String -> DynFlags -> DynFlags -setUnitIdInsts s d = - d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) } - -setComponentId :: String -> DynFlags -> DynFlags -setComponentId s d = - d { thisComponentId_ = Just (ComponentId (fsLit s)) } - -addPluginModuleName :: String -> DynFlags -> DynFlags -addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } - -addPluginModuleNameOption :: String -> DynFlags -> DynFlags -addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } - where (m, rest) = break (== ':') optflag - option = case rest of - [] -> "" -- should probably signal an error - (_:plug_opt) -> plug_opt -- ignore the ':' from break - -addFrontendPluginOption :: String -> DynFlags -> DynFlags -addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d } - -parseDynLibLoaderMode f d = - case splitAt 8 f of - ("deploy", "") -> d { dynLibLoader = Deployable } - ("sysdep", "") -> d { dynLibLoader = SystemDependent } - _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f)) - -setDumpPrefixForce f d = d { dumpPrefixForce = f} - --- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] --- Config.hs should really use Option. -setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) -addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s}) -addOptc f = alterSettings (\s -> s { sOpt_c = f : sOpt_c s}) -addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s}) - - -setDepMakefile :: FilePath -> DynFlags -> DynFlags -setDepMakefile f d = d { depMakefile = f } - -setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags -setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } - -addDepExcludeMod :: String -> DynFlags -> DynFlags -addDepExcludeMod m d - = d { depExcludeMods = mkModuleName m : depExcludeMods d } - -addDepSuffix :: FilePath -> DynFlags -> DynFlags -addDepSuffix s d = d { depSuffixes = s : depSuffixes d } - -addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d} - -addHaddockOpts f d = d { haddockOptions = Just f} - -addGhciScript f d = d { ghciScripts = f : ghciScripts d} - -setInteractivePrint f d = d { interactivePrint = Just f} - --- ----------------------------------------------------------------------------- --- Command-line options - --- | When invoking external tools as part of the compilation pipeline, we --- pass these a sequence of options on the command-line. Rather than --- just using a list of Strings, we use a type that allows us to distinguish --- between filepaths and 'other stuff'. The reason for this is that --- this type gives us a handle on transforming filenames, and filenames only, --- to whatever format they're expected to be on a particular platform. -data Option - = FileOption -- an entry that _contains_ filename(s) / filepaths. - String -- a non-filepath prefix that shouldn't be - -- transformed (e.g., "/out=") - String -- the filepath/filename portion - | Option String - deriving ( Eq ) - -showOpt :: Option -> String -showOpt (FileOption pre f) = pre ++ f -showOpt (Option s) = s - ------------------------------------------------------------------------------ --- Setting the optimisation level - -updOptLevel :: Int -> DynFlags -> DynFlags --- ^ Sets the 'DynFlags' to be appropriate to the optimisation level -updOptLevel n dfs - = dfs2{ optLevel = final_n } - where - final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 - dfs1 = foldr (flip gopt_unset) dfs remove_gopts - dfs2 = foldr (flip gopt_set) dfs1 extra_gopts - - extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] - remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] - -{- ********************************************************************** -%* * - DynFlags parser -%* * -%********************************************************************* -} - --- ----------------------------------------------------------------------------- --- Parsing the dynamic flags. - - --- | Parse dynamic flags from a list of command line arguments. Returns the --- the parsed 'DynFlags', the left-over arguments, and a list of warnings. --- Throws a 'UsageError' if errors occurred during parsing (such as unknown --- flags or missing arguments). -parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Located String]) - -- ^ Updated 'DynFlags', left-over arguments, and - -- list of warnings. -parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True - - --- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags --- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). --- Used to parse flags set in a modules pragma. -parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Located String]) - -- ^ Updated 'DynFlags', left-over arguments, and - -- list of warnings. -parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False - - --- | Parses the dynamically set flags for GHC. This is the most general form of --- the dynamic flag parser that the other methods simply wrap. It allows --- saying which flags are valid flags and indicating if we are parsing --- arguments from the command line or from a file pragma. -parseDynamicFlagsFull :: MonadIO m - => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against - -> Bool -- ^ are the arguments from the command line? - -> DynFlags -- ^ current dynamic flags - -> [Located String] -- ^ arguments to parse - -> m (DynFlags, [Located String], [Located String]) -parseDynamicFlagsFull activeFlags cmdline dflags0 args = do - let ((leftover, errs, warns), dflags1) - = runCmdLine (processArgs activeFlags args) dflags0 - - -- See Note [Handling errors when parsing commandline flags] - unless (null errs) $ liftIO $ throwGhcExceptionIO $ - errorsToGhcException . map (showPpr dflags0 . getLoc &&& unLoc) $ errs - - -- check for disabled flags in safe haskell - let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 - dflags3 = updateWays dflags2 - theWays = ways dflags3 - - unless (allowed_combination theWays) $ liftIO $ - throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ - intercalate "/" (map wayDesc theWays))) - - let chooseOutput - | isJust (outputFile dflags3) -- Only iff user specified -o ... - , not (isJust (dynOutputFile dflags3)) -- but not -dyno - = return $ dflags3 { dynOutputFile = Just $ dynOut (fromJust $ outputFile dflags3) } - | otherwise - = return dflags3 - where - dynOut = flip addExtension (dynObjectSuf dflags3) . dropExtension - dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3) - - let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4 - - dflags6 <- case dllSplitFile dflags5 of - Nothing -> return (dflags5 { dllSplit = Nothing }) - Just f -> - case dllSplit dflags5 of - Just _ -> - -- If dllSplit is out of date then it would have - -- been set to Nothing. As it's a Just, it must be - -- up-to-date. - return dflags5 - Nothing -> - do xs <- liftIO $ readFile f - let ss = map (Set.fromList . words) (lines xs) - return $ dflags5 { dllSplit = Just ss } - - -- Set timer stats & heap size - when (enableTimeStats dflags6) $ liftIO enableTimingStats - case (ghcHeapSize dflags6) of - Just x -> liftIO (setHeapSize x) - _ -> return () - - dflags7 <- liftIO $ setLogAction dflags6 - - liftIO $ setUnsafeGlobalDynFlags dflags7 - - return (dflags7, leftover, consistency_warnings ++ sh_warns ++ warns) - -setLogAction :: DynFlags -> IO DynFlags -setLogAction dflags = do - mlogger <- initLogAction dflags - return $ - maybe - dflags - (\logger -> - dflags - { log_action = getLogAction logger - , log_finaliser = getLogFinaliser logger - , initLogAction = return $ Nothing -- Don't initialise it twice - }) - mlogger - --- | Write an error or warning to the 'LogOutput'. -putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle - -> MsgDoc -> IO () -putLogMsg dflags = log_action dflags dflags - -updateWays :: DynFlags -> DynFlags -updateWays dflags - = let theWays = sort $ nub $ ways dflags - in dflags { - ways = theWays, - buildTag = mkBuildTag (filter (not . wayRTSOnly) theWays), - rtsBuildTag = mkBuildTag theWays - } - --- | Check (and potentially disable) any extensions that aren't allowed --- in safe mode. --- --- The bool is to indicate if we are parsing command line flags (false means --- file pragma). This allows us to generate better warnings. -safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) -safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) - where - -- Handle illegal flags under safe language. - (dflagsUnset, warns) = foldl check_method (dflags, []) unsafeFlags - - check_method (df, warns) (str,loc,test,fix) - | test df = (fix df, warns ++ safeFailure (loc df) str) - | otherwise = (df, warns) - - safeFailure loc str - = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " - ++ str] - -safeFlagCheck cmdl dflags = - case (safeInferOn dflags) of - True | safeFlags -> (dflags', warn) - True -> (dflags' { safeInferred = False }, warn) - False -> (dflags', warn) - - where - -- dynflags and warn for when -fpackage-trust by itself with no safe - -- haskell flag - (dflags', warn) - | safeHaskell dflags == Sf_None && not cmdl && packageTrustOn dflags - = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) - | otherwise = (dflags, []) - - pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ - "-fpackage-trust ignored;" ++ - " must be specified with a Safe Haskell flag"] - - -- Have we inferred Unsafe? See Note [HscMain . Safe Haskell Inference] - safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer - - -{- ********************************************************************** -%* * - DynFlags specifications -%* * -%********************************************************************* -} - --- | All dynamic flags option strings without the deprecated ones. --- These are the user facing strings for enabling and disabling options. -allNonDeprecatedFlags :: [String] -allNonDeprecatedFlags = allFlagsDeps False - --- | All flags with possibility to filter deprecated ones -allFlagsDeps :: Bool -> [String] -allFlagsDeps keepDeprecated = [ '-':flagName flag - | (deprecated, flag) <- flagsAllDeps - , ok (flagOptKind flag) - , keepDeprecated || not (isDeprecated deprecated)] - where ok (PrefixPred _ _) = False - ok _ = True - isDeprecated Deprecated = True - isDeprecated _ = False - -{- - - Below we export user facing symbols for GHC dynamic flags for use with the - - GHC API. - -} - --- All dynamic flags present in GHC. -flagsAll :: [Flag (CmdLineP DynFlags)] -flagsAll = map snd flagsAllDeps - --- All dynamic flags present in GHC with deprecation information. -flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] -flagsAllDeps = package_flags_deps ++ dynamic_flags_deps - - --- All dynamic flags, minus package flags, present in GHC. -flagsDynamic :: [Flag (CmdLineP DynFlags)] -flagsDynamic = map snd dynamic_flags_deps - --- ALl package flags present in GHC. -flagsPackage :: [Flag (CmdLineP DynFlags)] -flagsPackage = map snd package_flags_deps - -----------------Helpers to make flags and keep deprecation information---------- - -type FlagMaker m = String -> OptKind m -> Flag m -type DynFlagMaker = FlagMaker (CmdLineP DynFlags) -data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord) - --- Make a non-deprecated flag -make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) - -> (Deprecation, Flag (CmdLineP DynFlags)) -make_ord_flag fm name kind = (NotDeprecated, fm name kind) - --- Make a deprecated flag -make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String - -> (Deprecation, Flag (CmdLineP DynFlags)) -make_dep_flag fm name kind message = (Deprecated, - fm name $ add_dep_message kind message) - -add_dep_message :: OptKind (CmdLineP DynFlags) -> String - -> OptKind (CmdLineP DynFlags) -add_dep_message (NoArg f) message = NoArg $ f >> deprecate message -add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message -add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message -add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message -add_dep_message (OptPrefix f) message = - OptPrefix $ \s -> f s >> deprecate message -add_dep_message (OptIntSuffix f) message = - OptIntSuffix $ \oi -> f oi >> deprecate message -add_dep_message (IntSuffix f) message = - IntSuffix $ \i -> f i >> deprecate message -add_dep_message (FloatSuffix f) message = - FloatSuffix $ \fl -> f fl >> deprecate message -add_dep_message (PassFlag f) message = - PassFlag $ \s -> f s >> deprecate message -add_dep_message (AnySuffix f) message = - AnySuffix $ \s -> f s >> deprecate message -add_dep_message (PrefixPred pred f) message = - PrefixPred pred $ \s -> f s >> deprecate message -add_dep_message (AnySuffixPred pred f) message = - AnySuffixPred pred $ \s -> f s >> deprecate message - ------------------------ The main flags themselves ------------------------------ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] -dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] -dynamic_flags_deps = [ - make_dep_flag defFlag "n" (NoArg $ return ()) - "The -n flag is deprecated and no longer has any effect" - , make_ord_flag defFlag "cpp" (NoArg (setExtensionFlag LangExt.Cpp)) - , make_ord_flag defFlag "F" (NoArg (setGeneralFlag Opt_Pp)) - , (Deprecated, defFlag "#include" - (HasArg (\_s -> - addWarn ("-#include and INCLUDE pragmas are " ++ - "deprecated: They no longer have any effect")))) - , make_ord_flag defFlag "v" (OptIntSuffix setVerbosity) - - , make_ord_flag defGhcFlag "j" (OptIntSuffix - (\n -> case n of - Just n - | n > 0 -> upd (\d -> d { parMakeCount = Just n }) - | otherwise -> addErr "Syntax: -j[n] where n > 0" - Nothing -> upd (\d -> d { parMakeCount = Nothing }))) - -- When the number of parallel builds - -- is omitted, it is the same - -- as specifing that the number of - -- parallel builds is equal to the - -- result of getNumProcessors - , make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts) - , make_ord_flag defFlag "this-component-id" (sepArg setComponentId) - - -- RTS options ------------------------------------------------------------- - , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> - d { ghcHeapSize = Just $ fromIntegral (decodeSize s)}))) - - , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d -> - d { enableTimeStats = True }))) - - ------- ways --------------------------------------------------------------- - , make_ord_flag defGhcFlag "prof" (NoArg (addWay WayProf)) - , make_ord_flag defGhcFlag "eventlog" (NoArg (addWay WayEventLog)) - , make_dep_flag defGhcFlag "smp" - (NoArg $ addWay WayThreaded) "Use -threaded instead" - , make_ord_flag defGhcFlag "debug" (NoArg (addWay WayDebug)) - , make_ord_flag defGhcFlag "threaded" (NoArg (addWay WayThreaded)) - - , make_ord_flag defGhcFlag "ticky" - (NoArg (setGeneralFlag Opt_Ticky >> addWay WayDebug)) - - -- -ticky enables ticky-ticky code generation, and also implies -debug which - -- is required to get the RTS ticky support. - - ----- Linker -------------------------------------------------------- - , make_ord_flag defGhcFlag "static" (NoArg removeWayDyn) - , make_ord_flag defGhcFlag "dynamic" (NoArg (addWay WayDyn)) - , make_ord_flag defGhcFlag "rdynamic" $ noArg $ -#ifdef linux_HOST_OS - addOptl "-rdynamic" -#elif defined (mingw32_HOST_OS) - addOptl "-Wl,--export-all-symbols" -#else - -- ignored for compat w/ gcc: - id -#endif - , make_ord_flag defGhcFlag "relative-dynlib-paths" - (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) - , make_ord_flag defGhcFlag "pie" (NoArg (setGeneralFlag Opt_PICExecutable)) - , make_ord_flag defGhcFlag "no-pie" (NoArg (unSetGeneralFlag Opt_PICExecutable)) - - ------- Specific phases -------------------------------------------- - -- need to appear before -pgmL to be parsed as LLVM flags. - , make_ord_flag defFlag "pgmlo" - (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) - , make_ord_flag defFlag "pgmlc" - (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) - , make_ord_flag defFlag "pgmi" - (hasArg (\f -> alterSettings (\s -> s { sPgm_i = f}))) - , make_ord_flag defFlag "pgmL" - (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) - , make_ord_flag defFlag "pgmP" - (hasArg setPgmP) - , make_ord_flag defFlag "pgmF" - (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) - , make_ord_flag defFlag "pgmc" - (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) - , make_ord_flag defFlag "pgms" - (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) - , make_ord_flag defFlag "pgma" - (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) - , make_ord_flag defFlag "pgml" - (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) - , make_ord_flag defFlag "pgmdll" - (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) - , make_ord_flag defFlag "pgmwindres" - (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) - , make_ord_flag defFlag "pgmlibtool" - (hasArg (\f -> alterSettings (\s -> s { sPgm_libtool = f}))) - - -- need to appear before -optl/-opta to be parsed as LLVM flags. - , make_ord_flag defFlag "optlo" - (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) - , make_ord_flag defFlag "optlc" - (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) - , make_ord_flag defFlag "opti" - (hasArg (\f -> alterSettings (\s -> s { sOpt_i = f : sOpt_i s}))) - , make_ord_flag defFlag "optL" - (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) - , make_ord_flag defFlag "optP" - (hasArg addOptP) - , make_ord_flag defFlag "optF" - (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) - , make_ord_flag defFlag "optc" - (hasArg addOptc) - , make_ord_flag defFlag "opta" - (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) - , make_ord_flag defFlag "optl" - (hasArg addOptl) - , make_ord_flag defFlag "optwindres" - (hasArg (\f -> - alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) - - , make_ord_flag defGhcFlag "split-objs" - (NoArg (if can_split - then setGeneralFlag Opt_SplitObjs - else addWarn "ignoring -fsplit-objs")) - - , make_ord_flag defGhcFlag "split-sections" - (noArgM (\dflags -> do - if platformHasSubsectionsViaSymbols (targetPlatform dflags) - then do addErr $ - "-split-sections is not useful on this platform " ++ - "since it always uses subsections via symbols." - return dflags - else return (gopt_set dflags Opt_SplitSections))) - - -------- ghc -M ----------------------------------------------------- - , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) - , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) - , make_ord_flag defGhcFlag "include-pkg-deps" - (noArg (setDepIncludePkgDeps True)) - , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) - - -------- Linking ---------------------------------------------------- - , make_ord_flag defGhcFlag "no-link" - (noArg (\d -> d { ghcLink=NoLink })) - , make_ord_flag defGhcFlag "shared" - (noArg (\d -> d { ghcLink=LinkDynLib })) - , make_ord_flag defGhcFlag "staticlib" - (noArg (\d -> d { ghcLink=LinkStaticLib })) - , make_ord_flag defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) - , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) - -- -dll-split is an internal flag, used only during the GHC build - , make_ord_flag defHiddenFlag "dll-split" - (hasArg (\f d -> d { dllSplitFile = Just f, dllSplit = Nothing })) - - ------- Libraries --------------------------------------------------- - , make_ord_flag defFlag "L" (Prefix addLibraryPath) - , make_ord_flag defFlag "l" (hasArg (addLdInputs . Option . ("-l" ++))) - - ------- Frameworks -------------------------------------------------- - -- -framework-path should really be -F ... - , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath) - , make_ord_flag defFlag "framework" (hasArg addCmdlineFramework) - - ------- Output Redirection ------------------------------------------ - , make_ord_flag defGhcFlag "odir" (hasArg setObjectDir) - , make_ord_flag defGhcFlag "o" (sepArg (setOutputFile . Just)) - , make_ord_flag defGhcFlag "dyno" - (sepArg (setDynOutputFile . Just)) - , make_ord_flag defGhcFlag "ohi" - (hasArg (setOutputHi . Just )) - , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) - , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) - , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf) - , make_ord_flag defGhcFlag "hisuf" (hasArg setHiSuf) - , make_ord_flag defGhcFlag "dynhisuf" (hasArg setDynHiSuf) - , make_ord_flag defGhcFlag "hidir" (hasArg setHiDir) - , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) - , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) - , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) - , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) - , make_ord_flag defGhcFlag "ddump-file-prefix" - (hasArg (setDumpPrefixForce . Just)) - - , make_ord_flag defGhcFlag "dynamic-too" - (NoArg (setGeneralFlag Opt_BuildDynamicToo)) - - ------- Keeping temporary files ------------------------------------- - -- These can be singular (think ghc -c) or plural (think ghc --make) - , make_ord_flag defGhcFlag "keep-hc-file" - (NoArg (setGeneralFlag Opt_KeepHcFiles)) - , make_ord_flag defGhcFlag "keep-hc-files" - (NoArg (setGeneralFlag Opt_KeepHcFiles)) - , make_ord_flag defGhcFlag "keep-s-file" - (NoArg (setGeneralFlag Opt_KeepSFiles)) - , make_ord_flag defGhcFlag "keep-s-files" - (NoArg (setGeneralFlag Opt_KeepSFiles)) - , make_ord_flag defGhcFlag "keep-llvm-file" - (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) - , make_ord_flag defGhcFlag "keep-llvm-files" - (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) - -- This only makes sense as plural - , make_ord_flag defGhcFlag "keep-tmp-files" - (NoArg (setGeneralFlag Opt_KeepTmpFiles)) - , make_ord_flag defGhcFlag "keep-hi-file" - (NoArg (setGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "no-keep-hi-file" - (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "keep-hi-files" - (NoArg (setGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "no-keep-hi-files" - (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "keep-o-file" - (NoArg (setGeneralFlag Opt_KeepOFiles)) - , make_ord_flag defGhcFlag "no-keep-o-file" - (NoArg (unSetGeneralFlag Opt_KeepOFiles)) - , make_ord_flag defGhcFlag "keep-o-files" - (NoArg (setGeneralFlag Opt_KeepOFiles)) - , make_ord_flag defGhcFlag "no-keep-o-files" - (NoArg (unSetGeneralFlag Opt_KeepOFiles)) - - ------- Miscellaneous ---------------------------------------------- - , make_ord_flag defGhcFlag "no-auto-link-packages" - (NoArg (unSetGeneralFlag Opt_AutoLinkPackages)) - , make_ord_flag defGhcFlag "no-hs-main" - (NoArg (setGeneralFlag Opt_NoHsMain)) - , make_ord_flag defGhcFlag "fno-state-hack" - (NoArg (setGeneralFlag Opt_G_NoStateHack)) - , make_ord_flag defGhcFlag "fno-opt-coercion" - (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) - , make_ord_flag defGhcFlag "with-rtsopts" - (HasArg setRtsOpts) - , make_ord_flag defGhcFlag "rtsopts" - (NoArg (setRtsOptsEnabled RtsOptsAll)) - , make_ord_flag defGhcFlag "rtsopts=all" - (NoArg (setRtsOptsEnabled RtsOptsAll)) - , make_ord_flag defGhcFlag "rtsopts=some" - (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) - , make_ord_flag defGhcFlag "rtsopts=none" - (NoArg (setRtsOptsEnabled RtsOptsNone)) - , make_ord_flag defGhcFlag "no-rtsopts" - (NoArg (setRtsOptsEnabled RtsOptsNone)) - , make_ord_flag defGhcFlag "no-rtsopts-suggestions" - (noArg (\d -> d {rtsOptsSuggestions = False})) - - , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) - , make_ord_flag defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) - , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) - , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) - , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) - , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) - , make_ord_flag defGhcFlag "ticky-allocd" - (NoArg (setGeneralFlag Opt_Ticky_Allocd)) - , make_ord_flag defGhcFlag "ticky-LNE" - (NoArg (setGeneralFlag Opt_Ticky_LNE)) - , make_ord_flag defGhcFlag "ticky-dyn-thunk" - (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) - ------- recompilation checker -------------------------------------- - , make_dep_flag defGhcFlag "recomp" - (NoArg $ unSetGeneralFlag Opt_ForceRecomp) - "Use -fno-force-recomp instead" - , make_dep_flag defGhcFlag "no-recomp" - (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead" - , make_ord_flag defFlag "fmax-errors" - (intSuffix (\n d -> d { maxErrors = Just (max 1 n) })) - , make_ord_flag defFlag "fno-max-errors" - (noArg (\d -> d { maxErrors = Nothing })) - , make_ord_flag defFlag "freverse-errors" - (noArg (\d -> d {reverseErrors = True} )) - , make_ord_flag defFlag "fno-reverse-errors" - (noArg (\d -> d {reverseErrors = False} )) - - ------ HsCpp opts --------------------------------------------------- - , make_ord_flag defFlag "D" (AnySuffix (upd . addOptP)) - , make_ord_flag defFlag "U" (AnySuffix (upd . addOptP)) - - ------- Include/Import Paths ---------------------------------------- - , make_ord_flag defFlag "I" (Prefix addIncludePath) - , make_ord_flag defFlag "i" (OptPrefix addImportPath) - - ------ Output style options ----------------------------------------- - , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d -> - d { pprUserLength = n })) - , make_ord_flag defFlag "dppr-cols" (intSuffix (\n d -> - d { pprCols = n })) - , make_ord_flag defFlag "fdiagnostics-color=auto" - (NoArg (upd (\d -> d { useColor = Auto }))) - , make_ord_flag defFlag "fdiagnostics-color=always" - (NoArg (upd (\d -> d { useColor = Always }))) - , make_ord_flag defFlag "fdiagnostics-color=never" - (NoArg (upd (\d -> d { useColor = Never }))) - - -- Suppress all that is suppressable in core dumps. - -- Except for uniques, as some simplifier phases introduce new variables that - -- have otherwise identical names. - , make_ord_flag defGhcFlag "dsuppress-all" - (NoArg $ do setGeneralFlag Opt_SuppressCoercions - setGeneralFlag Opt_SuppressVarKinds - setGeneralFlag Opt_SuppressModulePrefixes - setGeneralFlag Opt_SuppressTypeApplications - setGeneralFlag Opt_SuppressIdInfo - setGeneralFlag Opt_SuppressTicks - setGeneralFlag Opt_SuppressTypeSignatures) - - ------ Debugging ---------------------------------------------------- - , make_ord_flag defGhcFlag "dstg-stats" - (NoArg (setGeneralFlag Opt_StgStats)) - - , make_ord_flag defGhcFlag "ddump-cmm" - (setDumpFlag Opt_D_dump_cmm) - , make_ord_flag defGhcFlag "ddump-cmm-from-stg" - (setDumpFlag Opt_D_dump_cmm_from_stg) - , make_ord_flag defGhcFlag "ddump-cmm-raw" - (setDumpFlag Opt_D_dump_cmm_raw) - , make_ord_flag defGhcFlag "ddump-cmm-verbose" - (setDumpFlag Opt_D_dump_cmm_verbose) - , make_ord_flag defGhcFlag "ddump-cmm-cfg" - (setDumpFlag Opt_D_dump_cmm_cfg) - , make_ord_flag defGhcFlag "ddump-cmm-cbe" - (setDumpFlag Opt_D_dump_cmm_cbe) - , make_ord_flag defGhcFlag "ddump-cmm-switch" - (setDumpFlag Opt_D_dump_cmm_switch) - , make_ord_flag defGhcFlag "ddump-cmm-proc" - (setDumpFlag Opt_D_dump_cmm_proc) - , make_ord_flag defGhcFlag "ddump-cmm-sp" - (setDumpFlag Opt_D_dump_cmm_sp) - , make_ord_flag defGhcFlag "ddump-cmm-sink" - (setDumpFlag Opt_D_dump_cmm_sink) - , make_ord_flag defGhcFlag "ddump-cmm-caf" - (setDumpFlag Opt_D_dump_cmm_caf) - , make_ord_flag defGhcFlag "ddump-cmm-procmap" - (setDumpFlag Opt_D_dump_cmm_procmap) - , make_ord_flag defGhcFlag "ddump-cmm-split" - (setDumpFlag Opt_D_dump_cmm_split) - , make_ord_flag defGhcFlag "ddump-cmm-info" - (setDumpFlag Opt_D_dump_cmm_info) - , make_ord_flag defGhcFlag "ddump-cmm-cps" - (setDumpFlag Opt_D_dump_cmm_cps) - , make_ord_flag defGhcFlag "ddump-core-stats" - (setDumpFlag Opt_D_dump_core_stats) - , make_ord_flag defGhcFlag "ddump-asm" - (setDumpFlag Opt_D_dump_asm) - , make_ord_flag defGhcFlag "ddump-asm-native" - (setDumpFlag Opt_D_dump_asm_native) - , make_ord_flag defGhcFlag "ddump-asm-liveness" - (setDumpFlag Opt_D_dump_asm_liveness) - , make_ord_flag defGhcFlag "ddump-asm-regalloc" - (setDumpFlag Opt_D_dump_asm_regalloc) - , make_ord_flag defGhcFlag "ddump-asm-conflicts" - (setDumpFlag Opt_D_dump_asm_conflicts) - , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages" - (setDumpFlag Opt_D_dump_asm_regalloc_stages) - , make_ord_flag defGhcFlag "ddump-asm-stats" - (setDumpFlag Opt_D_dump_asm_stats) - , make_ord_flag defGhcFlag "ddump-asm-expanded" - (setDumpFlag Opt_D_dump_asm_expanded) - , make_ord_flag defGhcFlag "ddump-llvm" - (NoArg $ setObjTarget HscLlvm >> setDumpFlag' Opt_D_dump_llvm) - , make_ord_flag defGhcFlag "ddump-deriv" - (setDumpFlag Opt_D_dump_deriv) - , make_ord_flag defGhcFlag "ddump-ds" - (setDumpFlag Opt_D_dump_ds) - , make_ord_flag defGhcFlag "ddump-foreign" - (setDumpFlag Opt_D_dump_foreign) - , make_ord_flag defGhcFlag "ddump-inlinings" - (setDumpFlag Opt_D_dump_inlinings) - , make_ord_flag defGhcFlag "ddump-rule-firings" - (setDumpFlag Opt_D_dump_rule_firings) - , make_ord_flag defGhcFlag "ddump-rule-rewrites" - (setDumpFlag Opt_D_dump_rule_rewrites) - , make_ord_flag defGhcFlag "ddump-simpl-trace" - (setDumpFlag Opt_D_dump_simpl_trace) - , make_ord_flag defGhcFlag "ddump-occur-anal" - (setDumpFlag Opt_D_dump_occur_anal) - , make_ord_flag defGhcFlag "ddump-parsed" - (setDumpFlag Opt_D_dump_parsed) - , make_ord_flag defGhcFlag "ddump-parsed-ast" - (setDumpFlag Opt_D_dump_parsed_ast) - , make_ord_flag defGhcFlag "ddump-rn" - (setDumpFlag Opt_D_dump_rn) - , make_ord_flag defGhcFlag "ddump-rn-ast" - (setDumpFlag Opt_D_dump_rn_ast) - , make_ord_flag defGhcFlag "ddump-simpl" - (setDumpFlag Opt_D_dump_simpl) - , make_ord_flag defGhcFlag "ddump-simpl-iterations" - (setDumpFlag Opt_D_dump_simpl_iterations) - , make_ord_flag defGhcFlag "ddump-spec" - (setDumpFlag Opt_D_dump_spec) - , make_ord_flag defGhcFlag "ddump-prep" - (setDumpFlag Opt_D_dump_prep) - , make_ord_flag defGhcFlag "ddump-stg" - (setDumpFlag Opt_D_dump_stg) - , make_ord_flag defGhcFlag "ddump-call-arity" - (setDumpFlag Opt_D_dump_call_arity) - , make_ord_flag defGhcFlag "ddump-stranal" - (setDumpFlag Opt_D_dump_stranal) - , make_ord_flag defGhcFlag "ddump-str-signatures" - (setDumpFlag Opt_D_dump_str_signatures) - , make_ord_flag defGhcFlag "ddump-tc" - (setDumpFlag Opt_D_dump_tc) - , make_ord_flag defGhcFlag "ddump-tc-ast" - (setDumpFlag Opt_D_dump_tc_ast) - , make_ord_flag defGhcFlag "ddump-types" - (setDumpFlag Opt_D_dump_types) - , make_ord_flag defGhcFlag "ddump-rules" - (setDumpFlag Opt_D_dump_rules) - , make_ord_flag defGhcFlag "ddump-cse" - (setDumpFlag Opt_D_dump_cse) - , make_ord_flag defGhcFlag "ddump-worker-wrapper" - (setDumpFlag Opt_D_dump_worker_wrapper) - , make_ord_flag defGhcFlag "ddump-rn-trace" - (setDumpFlag Opt_D_dump_rn_trace) - , make_ord_flag defGhcFlag "ddump-shape" - (setDumpFlag Opt_D_dump_shape) - , make_ord_flag defGhcFlag "ddump-if-trace" - (setDumpFlag Opt_D_dump_if_trace) - , make_ord_flag defGhcFlag "ddump-cs-trace" - (setDumpFlag Opt_D_dump_cs_trace) - , make_ord_flag defGhcFlag "ddump-tc-trace" - (NoArg (do setDumpFlag' Opt_D_dump_tc_trace - setDumpFlag' Opt_D_dump_cs_trace)) - , make_ord_flag defGhcFlag "ddump-ec-trace" - (setDumpFlag Opt_D_dump_ec_trace) - , make_ord_flag defGhcFlag "ddump-vt-trace" - (setDumpFlag Opt_D_dump_vt_trace) - , make_ord_flag defGhcFlag "ddump-splices" - (setDumpFlag Opt_D_dump_splices) - , make_ord_flag defGhcFlag "dth-dec-file" - (setDumpFlag Opt_D_th_dec_file) - - , make_ord_flag defGhcFlag "ddump-rn-stats" - (setDumpFlag Opt_D_dump_rn_stats) - , make_ord_flag defGhcFlag "ddump-opt-cmm" - (setDumpFlag Opt_D_dump_opt_cmm) - , make_ord_flag defGhcFlag "ddump-simpl-stats" - (setDumpFlag Opt_D_dump_simpl_stats) - , make_ord_flag defGhcFlag "ddump-bcos" - (setDumpFlag Opt_D_dump_BCOs) - , make_ord_flag defGhcFlag "dsource-stats" - (setDumpFlag Opt_D_source_stats) - , make_ord_flag defGhcFlag "dverbose-core2core" - (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core) - , make_ord_flag defGhcFlag "dverbose-stg2stg" - (setDumpFlag Opt_D_verbose_stg2stg) - , make_ord_flag defGhcFlag "ddump-hi" - (setDumpFlag Opt_D_dump_hi) - , make_ord_flag defGhcFlag "ddump-minimal-imports" - (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) - , make_ord_flag defGhcFlag "ddump-vect" - (setDumpFlag Opt_D_dump_vect) - , make_ord_flag defGhcFlag "ddump-hpc" - (setDumpFlag Opt_D_dump_ticked) -- back compat - , make_ord_flag defGhcFlag "ddump-ticked" - (setDumpFlag Opt_D_dump_ticked) - , make_ord_flag defGhcFlag "ddump-mod-cycles" - (setDumpFlag Opt_D_dump_mod_cycles) - , make_ord_flag defGhcFlag "ddump-mod-map" - (setDumpFlag Opt_D_dump_mod_map) - , make_ord_flag defGhcFlag "ddump-view-pattern-commoning" - (setDumpFlag Opt_D_dump_view_pattern_commoning) - , make_ord_flag defGhcFlag "ddump-to-file" - (NoArg (setGeneralFlag Opt_DumpToFile)) - , make_ord_flag defGhcFlag "ddump-hi-diffs" - (setDumpFlag Opt_D_dump_hi_diffs) - , make_ord_flag defGhcFlag "ddump-rtti" - (setDumpFlag Opt_D_dump_rtti) - , make_ord_flag defGhcFlag "dcore-lint" - (NoArg (setGeneralFlag Opt_DoCoreLinting)) - , make_ord_flag defGhcFlag "dstg-lint" - (NoArg (setGeneralFlag Opt_DoStgLinting)) - , make_ord_flag defGhcFlag "dcmm-lint" - (NoArg (setGeneralFlag Opt_DoCmmLinting)) - , make_ord_flag defGhcFlag "dasm-lint" - (NoArg (setGeneralFlag Opt_DoAsmLinting)) - , make_ord_flag defGhcFlag "dannot-lint" - (NoArg (setGeneralFlag Opt_DoAnnotationLinting)) - , make_ord_flag defGhcFlag "dshow-passes" - (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) - , make_ord_flag defGhcFlag "dfaststring-stats" - (NoArg (setGeneralFlag Opt_D_faststring_stats)) - , make_ord_flag defGhcFlag "dno-llvm-mangler" - (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag - , make_ord_flag defGhcFlag "ddump-debug" - (setDumpFlag Opt_D_dump_debug) - , make_ord_flag defGhcFlag "ddump-json" - (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) ) - , make_ord_flag defGhcFlag "dppr-debug" - (setDumpFlag Opt_D_ppr_debug) - , make_ord_flag defGhcFlag "dno-debug-output" - (setDumpFlag Opt_D_no_debug_output) - - ------ Machine dependent (-m) stuff --------------------------- - - , make_ord_flag defGhcFlag "msse" (noArg (\d -> - d { sseVersion = Just SSE1 })) - , make_ord_flag defGhcFlag "msse2" (noArg (\d -> - d { sseVersion = Just SSE2 })) - , make_ord_flag defGhcFlag "msse3" (noArg (\d -> - d { sseVersion = Just SSE3 })) - , make_ord_flag defGhcFlag "msse4" (noArg (\d -> - d { sseVersion = Just SSE4 })) - , make_ord_flag defGhcFlag "msse4.2" (noArg (\d -> - d { sseVersion = Just SSE42 })) - , make_ord_flag defGhcFlag "mavx" (noArg (\d -> d { avx = True })) - , make_ord_flag defGhcFlag "mavx2" (noArg (\d -> d { avx2 = True })) - , make_ord_flag defGhcFlag "mavx512cd" (noArg (\d -> - d { avx512cd = True })) - , make_ord_flag defGhcFlag "mavx512er" (noArg (\d -> - d { avx512er = True })) - , make_ord_flag defGhcFlag "mavx512f" (noArg (\d -> d { avx512f = True })) - , make_ord_flag defGhcFlag "mavx512pf" (noArg (\d -> - d { avx512pf = True })) - - ------ Warning opts ------------------------------------------------- - , make_ord_flag defFlag "W" (NoArg (mapM_ setWarningFlag minusWOpts)) - , make_ord_flag defFlag "Werror" - (NoArg (do { setGeneralFlag Opt_WarnIsError - ; mapM_ setFatalWarningFlag minusWeverythingOpts })) - , make_ord_flag defFlag "Wwarn" - (NoArg (do { unSetGeneralFlag Opt_WarnIsError - ; mapM_ unSetFatalWarningFlag minusWeverythingOpts })) - -- Opt_WarnIsError is still needed to pass -Werror - -- to CPP; see runCpp in SysTools - , make_dep_flag defFlag "Wnot" (NoArg (upd (\d -> - d {warningFlags = IntSet.empty}))) - "Use -w or -Wno-everything instead" - , make_ord_flag defFlag "w" (NoArg (upd (\d -> - d {warningFlags = IntSet.empty}))) - - -- New-style uniform warning sets - -- - -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything - , make_ord_flag defFlag "Weverything" (NoArg (mapM_ - setWarningFlag minusWeverythingOpts)) - , make_ord_flag defFlag "Wno-everything" - (NoArg (upd (\d -> d {warningFlags = IntSet.empty}))) - - , make_ord_flag defFlag "Wall" (NoArg (mapM_ - setWarningFlag minusWallOpts)) - , make_ord_flag defFlag "Wno-all" (NoArg (mapM_ - unSetWarningFlag minusWallOpts)) - - , make_ord_flag defFlag "Wextra" (NoArg (mapM_ - setWarningFlag minusWOpts)) - , make_ord_flag defFlag "Wno-extra" (NoArg (mapM_ - unSetWarningFlag minusWOpts)) - - , make_ord_flag defFlag "Wdefault" (NoArg (mapM_ - setWarningFlag standardWarnings)) - , make_ord_flag defFlag "Wno-default" (NoArg (mapM_ - unSetWarningFlag standardWarnings)) - - , make_ord_flag defFlag "Wcompat" (NoArg (mapM_ - setWarningFlag minusWcompatOpts)) - , make_ord_flag defFlag "Wno-compat" (NoArg (mapM_ - unSetWarningFlag minusWcompatOpts)) - - ------ Plugin flags ------------------------------------------------ - , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption) - , make_ord_flag defGhcFlag "fplugin" (hasArg addPluginModuleName) - , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption) - - ------ Optimisation flags ------------------------------------------ - , make_ord_flag defGhcFlag "O" (noArgM (setOptLevel 1)) - , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) - "Use -O0 instead" - , make_ord_flag defGhcFlag "Odph" (noArgM setDPHOpt) - , make_ord_flag defGhcFlag "O" (optIntSuffixM (\mb_n -> - setOptLevel (mb_n `orElse` 1))) - -- If the number is missing, use 1 - - - , make_ord_flag defFlag "fmax-relevant-binds" - (intSuffix (\n d -> d { maxRelevantBinds = Just n })) - , make_ord_flag defFlag "fno-max-relevant-binds" - (noArg (\d -> d { maxRelevantBinds = Nothing })) - , make_ord_flag defFlag "fmax-uncovered-patterns" - (intSuffix (\n d -> d { maxUncoveredPatterns = n })) - , make_ord_flag defFlag "fsimplifier-phases" - (intSuffix (\n d -> d { simplPhases = n })) - , make_ord_flag defFlag "fmax-simplifier-iterations" - (intSuffix (\n d -> d { maxSimplIterations = n })) - , make_ord_flag defFlag "fmax-pmcheck-iterations" - (intSuffix (\n d -> d{ maxPmCheckIterations = n })) - , make_ord_flag defFlag "fsimpl-tick-factor" - (intSuffix (\n d -> d { simplTickFactor = n })) - , make_ord_flag defFlag "fspec-constr-threshold" - (intSuffix (\n d -> d { specConstrThreshold = Just n })) - , make_ord_flag defFlag "fno-spec-constr-threshold" - (noArg (\d -> d { specConstrThreshold = Nothing })) - , make_ord_flag defFlag "fspec-constr-count" - (intSuffix (\n d -> d { specConstrCount = Just n })) - , make_ord_flag defFlag "fno-spec-constr-count" - (noArg (\d -> d { specConstrCount = Nothing })) - , make_ord_flag defFlag "fspec-constr-recursive" - (intSuffix (\n d -> d { specConstrRecursive = n })) - , make_ord_flag defFlag "fliberate-case-threshold" - (intSuffix (\n d -> d { liberateCaseThreshold = Just n })) - , make_ord_flag defFlag "fno-liberate-case-threshold" - (noArg (\d -> d { liberateCaseThreshold = Nothing })) - , make_ord_flag defFlag "frule-check" - (sepArg (\s d -> d { ruleCheck = Just s })) - , make_ord_flag defFlag "freduction-depth" - (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n })) - , make_ord_flag defFlag "fconstraint-solver-iterations" - (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n })) - , (Deprecated, defFlag "fcontext-stack" - (intSuffixM (\n d -> - do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" - ; return $ d { reductionDepth = treatZeroAsInf n } }))) - , (Deprecated, defFlag "ftype-function-depth" - (intSuffixM (\n d -> - do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" - ; return $ d { reductionDepth = treatZeroAsInf n } }))) - , make_ord_flag defFlag "fstrictness-before" - (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d })) - , make_ord_flag defFlag "ffloat-lam-args" - (intSuffix (\n d -> d { floatLamArgs = Just n })) - , make_ord_flag defFlag "ffloat-all-lams" - (noArg (\d -> d { floatLamArgs = Nothing })) - , make_ord_flag defFlag "fhistory-size" - (intSuffix (\n d -> d { historySize = n })) - , make_ord_flag defFlag "funfolding-creation-threshold" - (intSuffix (\n d -> d {ufCreationThreshold = n})) - , make_ord_flag defFlag "funfolding-use-threshold" - (intSuffix (\n d -> d {ufUseThreshold = n})) - , make_ord_flag defFlag "funfolding-fun-discount" - (intSuffix (\n d -> d {ufFunAppDiscount = n})) - , make_ord_flag defFlag "funfolding-dict-discount" - (intSuffix (\n d -> d {ufDictDiscount = n})) - , make_ord_flag defFlag "funfolding-keeness-factor" - (floatSuffix (\n d -> d {ufKeenessFactor = n})) - , make_ord_flag defFlag "fmax-worker-args" - (intSuffix (\n d -> d {maxWorkerArgs = n})) - , make_ord_flag defGhciFlag "fghci-hist-size" - (intSuffix (\n d -> d {ghciHistSize = n})) - , make_ord_flag defGhcFlag "fmax-inline-alloc-size" - (intSuffix (\n d -> d { maxInlineAllocSize = n })) - , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns" - (intSuffix (\n d -> d { maxInlineMemcpyInsns = n })) - , make_ord_flag defGhcFlag "fmax-inline-memset-insns" - (intSuffix (\n d -> d { maxInlineMemsetInsns = n })) - , make_ord_flag defGhcFlag "dinitial-unique" - (intSuffix (\n d -> d { initialUnique = n })) - , make_ord_flag defGhcFlag "dunique-increment" - (intSuffix (\n d -> d { uniqueIncrement = n })) - - ------ Profiling ---------------------------------------------------- - - -- OLD profiling flags - , make_dep_flag defGhcFlag "auto-all" - (noArg (\d -> d { profAuto = ProfAutoAll } )) - "Use -fprof-auto instead" - , make_dep_flag defGhcFlag "no-auto-all" - (noArg (\d -> d { profAuto = NoProfAuto } )) - "Use -fno-prof-auto instead" - , make_dep_flag defGhcFlag "auto" - (noArg (\d -> d { profAuto = ProfAutoExports } )) - "Use -fprof-auto-exported instead" - , make_dep_flag defGhcFlag "no-auto" - (noArg (\d -> d { profAuto = NoProfAuto } )) - "Use -fno-prof-auto instead" - , make_dep_flag defGhcFlag "caf-all" - (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs)) - "Use -fprof-cafs instead" - , make_dep_flag defGhcFlag "no-caf-all" - (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs)) - "Use -fno-prof-cafs instead" - - -- NEW profiling flags - , make_ord_flag defGhcFlag "fprof-auto" - (noArg (\d -> d { profAuto = ProfAutoAll } )) - , make_ord_flag defGhcFlag "fprof-auto-top" - (noArg (\d -> d { profAuto = ProfAutoTop } )) - , make_ord_flag defGhcFlag "fprof-auto-exported" - (noArg (\d -> d { profAuto = ProfAutoExports } )) - , make_ord_flag defGhcFlag "fprof-auto-calls" - (noArg (\d -> d { profAuto = ProfAutoCalls } )) - , make_ord_flag defGhcFlag "fno-prof-auto" - (noArg (\d -> d { profAuto = NoProfAuto } )) - - ------ Compiler flags ----------------------------------------------- - - , make_ord_flag defGhcFlag "fasm" (NoArg (setObjTarget HscAsm)) - , make_ord_flag defGhcFlag "fvia-c" (NoArg - (addWarn $ "The -fvia-c flag does nothing; " ++ - "it will be removed in a future GHC release")) - , make_ord_flag defGhcFlag "fvia-C" (NoArg - (addWarn $ "The -fvia-C flag does nothing; " ++ - "it will be removed in a future GHC release")) - , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjTarget HscLlvm)) - - , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> - d { ghcLink=NoLink }) >> setTarget HscNothing)) - , make_ord_flag defFlag "fbyte-code" (NoArg (setTarget HscInterpreted)) - , make_ord_flag defFlag "fobject-code" (NoArg (setTargetWithPlatform - defaultHscTarget)) - , make_dep_flag defFlag "fglasgow-exts" - (NoArg enableGlasgowExts) "Use individual extensions instead" - , make_dep_flag defFlag "fno-glasgow-exts" - (NoArg disableGlasgowExts) "Use individual extensions instead" - , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds) - , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds) - , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds) - , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg - disableUnusedBinds) - - ------ Safe Haskell flags ------------------------------------------- - , make_ord_flag defFlag "fpackage-trust" (NoArg setPackageTrust) - , make_ord_flag defFlag "fno-safe-infer" (noArg (\d -> - d { safeInfer = False })) - , make_ord_flag defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) - , make_ord_flag defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) - , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIC)) - , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIC)) - - ------ Debugging flags ---------------------------------------------- - , make_ord_flag defGhcFlag "g" (OptIntSuffix setDebugLevel) - ] - ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlagsDeps - ++ map (mkFlag turnOff "no-" unSetGeneralFlag ) negatableFlagsDeps - ++ map (mkFlag turnOn "d" setGeneralFlag ) dFlagsDeps - ++ map (mkFlag turnOff "dno-" unSetGeneralFlag ) dFlagsDeps - ++ map (mkFlag turnOn "f" setGeneralFlag ) fFlagsDeps - ++ map (mkFlag turnOff "fno-" unSetGeneralFlag ) fFlagsDeps - ++ map (mkFlag turnOn "W" setWarningFlag ) wWarningFlagsDeps - ++ map (mkFlag turnOff "Wno-" unSetWarningFlag ) wWarningFlagsDeps - ++ map (mkFlag turnOn "Werror=" (\flag -> do { - ; setWarningFlag flag - ; setFatalWarningFlag flag })) - wWarningFlagsDeps - ++ map (mkFlag turnOn "Wwarn=" unSetFatalWarningFlag ) - wWarningFlagsDeps - ++ map (mkFlag turnOn "Wno-error=" unSetFatalWarningFlag ) - wWarningFlagsDeps - ++ map (mkFlag turnOn "fwarn-" setWarningFlag . hideFlag) - wWarningFlagsDeps - ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag) - wWarningFlagsDeps - ++ [ (NotDeprecated, unrecognisedWarning "W"), - (Deprecated, unrecognisedWarning "fwarn-"), - (Deprecated, unrecognisedWarning "fno-warn-") ] - ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlagsDeps - ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlagsDeps - ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlagsDeps - ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlagsDeps - ++ map (mkFlag turnOn "X" setLanguage ) languageFlagsDeps - ++ map (mkFlag turnOn "X" setSafeHaskell ) safeHaskellFlagsDeps - ++ [ make_dep_flag defFlag "XGenerics" - (NoArg $ return ()) - ("it does nothing; look into -XDefaultSignatures " ++ - "and -XDeriveGeneric for generic programming support.") - , make_dep_flag defFlag "XNoGenerics" - (NoArg $ return ()) - ("it does nothing; look into -XDefaultSignatures and " ++ - "-XDeriveGeneric for generic programming support.") ] - --- | This is where we handle unrecognised warning flags. We only issue a warning --- if -Wunrecognised-warning-flags is set. See Trac #11429 for context. -unrecognisedWarning :: String -> Flag (CmdLineP DynFlags) -unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action) - where - action :: String -> EwM (CmdLineP DynFlags) () - action flag = do - f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState - when f $ addWarn $ "unrecognised warning flag: -" ++ prefix ++ flag - --- See Note [Supporting CLI completion] -package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] -package_flags_deps = [ - ------- Packages ---------------------------------------------------- - make_ord_flag defFlag "package-db" - (HasArg (addPkgConfRef . PkgConfFile)) - , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgConf) - , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgConf) - , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgConf) - , make_ord_flag defFlag "global-package-db" - (NoArg (addPkgConfRef GlobalPkgConf)) - , make_ord_flag defFlag "user-package-db" - (NoArg (addPkgConfRef UserPkgConf)) - -- backwards compat with GHC<=7.4 : - , make_dep_flag defFlag "package-conf" - (HasArg $ addPkgConfRef . PkgConfFile) "Use -package-db instead" - , make_dep_flag defFlag "no-user-package-conf" - (NoArg removeUserPkgConf) "Use -no-user-package-db instead" - , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> do - upd (setUnitId name)) - -- TODO: Since we JUST deprecated - -- -this-package-key, let's keep this - -- undeprecated for another cycle. - -- Deprecate this eventually. - -- deprecate "Use -this-unit-id instead") - , make_dep_flag defGhcFlag "this-package-key" (HasArg $ upd . setUnitId) - "Use -this-unit-id instead" - , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) - , make_ord_flag defFlag "package" (HasArg exposePackage) - , make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId) - , make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage) - , make_ord_flag defFlag "package-id" (HasArg exposePackageId) - , make_ord_flag defFlag "hide-package" (HasArg hidePackage) - , make_ord_flag defFlag "hide-all-packages" - (NoArg (setGeneralFlag Opt_HideAllPackages)) - , make_ord_flag defFlag "hide-all-plugin-packages" - (NoArg (setGeneralFlag Opt_HideAllPluginPackages)) - , make_ord_flag defFlag "package-env" (HasArg setPackageEnv) - , make_ord_flag defFlag "ignore-package" (HasArg ignorePackage) - , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead" - , make_ord_flag defFlag "distrust-all-packages" - (NoArg (setGeneralFlag Opt_DistrustAllPackages)) - , make_ord_flag defFlag "trust" (HasArg trustPackage) - , make_ord_flag defFlag "distrust" (HasArg distrustPackage) - ] - where - setPackageEnv env = upd $ \s -> s { packageEnv = Just env } - --- | Make a list of flags for shell completion. --- Filter all available flags into two groups, for interactive GHC vs all other. -flagsForCompletion :: Bool -> [String] -flagsForCompletion isInteractive - = [ '-':flagName flag - | flag <- flagsAll - , modeFilter (flagGhcMode flag) - ] - where - modeFilter AllModes = True - modeFilter OnlyGhci = isInteractive - modeFilter OnlyGhc = not isInteractive - modeFilter HiddenFlag = False - -type TurnOnFlag = Bool -- True <=> we are turning the flag on - -- False <=> we are turning the flag off -turnOn :: TurnOnFlag; turnOn = True -turnOff :: TurnOnFlag; turnOff = False - -data FlagSpec flag - = FlagSpec - { flagSpecName :: String -- ^ Flag in string form - , flagSpecFlag :: flag -- ^ Flag in internal form - , flagSpecAction :: (TurnOnFlag -> DynP ()) - -- ^ Extra action to run when the flag is found - -- Typically, emit a warning or error - , flagSpecGhcMode :: GhcFlagMode - -- ^ In which ghc mode the flag has effect - } - --- | Define a new flag. -flagSpec :: String -> flag -> (Deprecation, FlagSpec flag) -flagSpec name flag = flagSpec' name flag nop - --- | Define a new flag with an effect. -flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) - -> (Deprecation, FlagSpec flag) -flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes) - --- | Define a new deprecated flag with an effect. -depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String - -> (Deprecation, FlagSpec flag) -depFlagSpecOp name flag act dep = - (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep))) - --- | Define a new deprecated flag. -depFlagSpec :: String -> flag -> String - -> (Deprecation, FlagSpec flag) -depFlagSpec name flag dep = depFlagSpecOp name flag nop dep - --- | Define a new deprecated flag with an effect where the deprecation message --- depends on the flag value -depFlagSpecOp' :: String - -> flag - -> (TurnOnFlag -> DynP ()) - -> (TurnOnFlag -> String) - -> (Deprecation, FlagSpec flag) -depFlagSpecOp' name flag act dep = - (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f)) - AllModes) - --- | Define a new deprecated flag where the deprecation message --- depends on the flag value -depFlagSpec' :: String - -> flag - -> (TurnOnFlag -> String) - -> (Deprecation, FlagSpec flag) -depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep - - --- | Define a new deprecated flag where the deprecation message --- is shown depending on the flag value -depFlagSpecCond :: String - -> flag - -> (TurnOnFlag -> Bool) - -> String - -> (Deprecation, FlagSpec flag) -depFlagSpecCond name flag cond dep = - (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep) - AllModes) - --- | Define a new flag for GHCi. -flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag) -flagGhciSpec name flag = flagGhciSpec' name flag nop - --- | Define a new flag for GHCi with an effect. -flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) - -> (Deprecation, FlagSpec flag) -flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci) - --- | Define a new flag invisible to CLI completion. -flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag) -flagHiddenSpec name flag = flagHiddenSpec' name flag nop - --- | Define a new flag invisible to CLI completion with an effect. -flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) - -> (Deprecation, FlagSpec flag) -flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act - HiddenFlag) - --- | Hide a 'FlagSpec' from being displayed in @--show-options@. --- --- This is for example useful for flags that are obsolete, but should not --- (yet) be deprecated for compatibility reasons. -hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a) -hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag }) - -mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on - -> String -- ^ The flag prefix - -> (flag -> DynP ()) -- ^ What to do when the flag is found - -> (Deprecation, FlagSpec flag) -- ^ Specification of - -- this particular flag - -> (Deprecation, Flag (CmdLineP DynFlags)) -mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode)) - = (dep, - Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) - -deprecatedForExtension :: String -> TurnOnFlag -> String -deprecatedForExtension lang turn_on - = "use -X" ++ flag ++ - " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead" - where - flag | turn_on = lang - | otherwise = "No" ++ lang - -useInstead :: String -> TurnOnFlag -> String -useInstead flag turn_on - = "Use -f" ++ no ++ flag ++ " instead" - where - no = if turn_on then "" else "no-" - -nop :: TurnOnFlag -> DynP () -nop _ = return () - --- | Find the 'FlagSpec' for a 'WarningFlag'. -flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag) -flagSpecOf flag = listToMaybe $ filter check wWarningFlags - where - check fs = flagSpecFlag fs == flag - --- | These @-W\@ flags can all be reversed with @-Wno-\@ -wWarningFlags :: [FlagSpec WarningFlag] -wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) - -wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)] -wWarningFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] --- Please keep the list of flags below sorted alphabetically - flagSpec "alternative-layout-rule-transitional" - Opt_WarnAlternativeLayoutRuleTransitional, - depFlagSpec "amp" Opt_WarnAMP - "it has no effect", - depFlagSpec "auto-orphans" Opt_WarnAutoOrphans - "it has no effect", - flagSpec "cpp-undef" Opt_WarnCPPUndef, - flagSpec "unbanged-strict-patterns" Opt_WarnUnbangedStrictPatterns, - flagSpec "deferred-type-errors" Opt_WarnDeferredTypeErrors, - flagSpec "deferred-out-of-scope-variables" - Opt_WarnDeferredOutOfScopeVariables, - flagSpec "deprecations" Opt_WarnWarningsDeprecations, - flagSpec "deprecated-flags" Opt_WarnDeprecatedFlags, - flagSpec "deriving-typeable" Opt_WarnDerivingTypeable, - flagSpec "dodgy-exports" Opt_WarnDodgyExports, - flagSpec "dodgy-foreign-imports" Opt_WarnDodgyForeignImports, - flagSpec "dodgy-imports" Opt_WarnDodgyImports, - flagSpec "empty-enumerations" Opt_WarnEmptyEnumerations, - depFlagSpec "duplicate-constraints" Opt_WarnDuplicateConstraints - "it is subsumed by -Wredundant-constraints", - flagSpec "redundant-constraints" Opt_WarnRedundantConstraints, - flagSpec "duplicate-exports" Opt_WarnDuplicateExports, - flagSpec "hi-shadowing" Opt_WarnHiShadows, - flagSpec "implicit-prelude" Opt_WarnImplicitPrelude, - flagSpec "incomplete-patterns" Opt_WarnIncompletePatterns, - flagSpec "incomplete-record-updates" Opt_WarnIncompletePatternsRecUpd, - flagSpec "incomplete-uni-patterns" Opt_WarnIncompleteUniPatterns, - flagSpec "inline-rule-shadowing" Opt_WarnInlineRuleShadowing, - flagSpec "identities" Opt_WarnIdentities, - flagSpec "missing-fields" Opt_WarnMissingFields, - flagSpec "missing-import-lists" Opt_WarnMissingImportList, - depFlagSpec "missing-local-sigs" Opt_WarnMissingLocalSignatures - "it is replaced by -Wmissing-local-signatures", - flagSpec "missing-local-signatures" Opt_WarnMissingLocalSignatures, - flagSpec "missing-methods" Opt_WarnMissingMethods, - flagSpec "missing-monadfail-instances" Opt_WarnMissingMonadFailInstances, - flagSpec "semigroup" Opt_WarnSemigroup, - flagSpec "missing-signatures" Opt_WarnMissingSignatures, - depFlagSpec "missing-exported-sigs" Opt_WarnMissingExportedSignatures - "it is replaced by -Wmissing-exported-signatures", - flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures, - flagSpec "monomorphism-restriction" Opt_WarnMonomorphism, - flagSpec "name-shadowing" Opt_WarnNameShadowing, - flagSpec "noncanonical-monad-instances" - Opt_WarnNonCanonicalMonadInstances, - flagSpec "noncanonical-monadfail-instances" - Opt_WarnNonCanonicalMonadFailInstances, - flagSpec "noncanonical-monoid-instances" - Opt_WarnNonCanonicalMonoidInstances, - flagSpec "orphans" Opt_WarnOrphans, - flagSpec "overflowed-literals" Opt_WarnOverflowedLiterals, - flagSpec "overlapping-patterns" Opt_WarnOverlappingPatterns, - flagSpec "missed-specialisations" Opt_WarnMissedSpecs, - flagSpec "missed-specializations" Opt_WarnMissedSpecs, - flagSpec "all-missed-specialisations" Opt_WarnAllMissedSpecs, - flagSpec "all-missed-specializations" Opt_WarnAllMissedSpecs, - flagSpec' "safe" Opt_WarnSafe setWarnSafe, - flagSpec "trustworthy-safe" Opt_WarnTrustworthySafe, - flagSpec "tabs" Opt_WarnTabs, - flagSpec "type-defaults" Opt_WarnTypeDefaults, - flagSpec "typed-holes" Opt_WarnTypedHoles, - flagSpec "partial-type-signatures" Opt_WarnPartialTypeSignatures, - flagSpec "unrecognised-pragmas" Opt_WarnUnrecognisedPragmas, - flagSpec' "unsafe" Opt_WarnUnsafe setWarnUnsafe, - flagSpec "unsupported-calling-conventions" - Opt_WarnUnsupportedCallingConventions, - flagSpec "unsupported-llvm-version" Opt_WarnUnsupportedLlvmVersion, - flagSpec "unticked-promoted-constructors" - Opt_WarnUntickedPromotedConstructors, - flagSpec "unused-do-bind" Opt_WarnUnusedDoBind, - flagSpec "unused-foralls" Opt_WarnUnusedForalls, - flagSpec "unused-imports" Opt_WarnUnusedImports, - flagSpec "unused-local-binds" Opt_WarnUnusedLocalBinds, - flagSpec "unused-matches" Opt_WarnUnusedMatches, - flagSpec "unused-pattern-binds" Opt_WarnUnusedPatternBinds, - flagSpec "unused-top-binds" Opt_WarnUnusedTopBinds, - flagSpec "unused-type-patterns" Opt_WarnUnusedTypePatterns, - flagSpec "warnings-deprecations" Opt_WarnWarningsDeprecations, - flagSpec "wrong-do-bind" Opt_WarnWrongDoBind, - flagSpec "missing-pattern-synonym-signatures" - Opt_WarnMissingPatternSynonymSignatures, - flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints, - flagSpec "missing-home-modules" Opt_WarnMissingHomeModules, - flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags ] - --- | These @-\@ flags can all be reversed with @-no-\@ -negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] -negatableFlagsDeps = [ - flagGhciSpec "ignore-dot-ghci" Opt_IgnoreDotGhci ] - --- | These @-d\@ flags can all be reversed with @-dno-\@ -dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] -dFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] --- Please keep the list of flags below sorted alphabetically - flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, - depFlagSpec' "ppr-ticks" Opt_PprShowTicks - (\turn_on -> useInstead "suppress-ticks" (not turn_on)), - flagSpec "suppress-ticks" Opt_SuppressTicks, - flagSpec "suppress-coercions" Opt_SuppressCoercions, - flagSpec "suppress-idinfo" Opt_SuppressIdInfo, - flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings, - flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, - flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, - flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, - flagSpec "suppress-uniques" Opt_SuppressUniques, - flagSpec "suppress-var-kinds" Opt_SuppressVarKinds] - --- | These @-f\@ flags can all be reversed with @-fno-\@ -fFlags :: [FlagSpec GeneralFlag] -fFlags = map snd fFlagsDeps - -fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] -fFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] --- Please keep the list of flags below sorted alphabetically - flagGhciSpec "break-on-error" Opt_BreakOnError, - flagGhciSpec "break-on-exception" Opt_BreakOnException, - flagSpec "building-cabal-package" Opt_BuildingCabalPackage, - flagSpec "call-arity" Opt_CallArity, - flagSpec "case-merge" Opt_CaseMerge, - flagSpec "case-folding" Opt_CaseFolding, - flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, - flagSpec "cmm-sink" Opt_CmmSink, - flagSpec "cse" Opt_CSE, - flagSpec "stg-cse" Opt_StgCSE, - flagSpec "cpr-anal" Opt_CprAnal, - flagSpec "defer-type-errors" Opt_DeferTypeErrors, - flagSpec "defer-typed-holes" Opt_DeferTypedHoles, - flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables, - flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret, - flagSpec "dicts-cheap" Opt_DictsCheap, - flagSpec "dicts-strict" Opt_DictsStrict, - flagSpec "dmd-tx-dict-sel" Opt_DmdTxDictSel, - flagSpec "do-eta-reduction" Opt_DoEtaReduction, - flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, - flagSpec "eager-blackholing" Opt_EagerBlackHoling, - flagSpec "embed-manifest" Opt_EmbedManifest, - flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, - flagSpec "error-spans" Opt_ErrorSpans, - flagSpec "excess-precision" Opt_ExcessPrecision, - flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, - flagSpec "external-interpreter" Opt_ExternalInterpreter, - flagSpec "flat-cache" Opt_FlatCache, - flagSpec "float-in" Opt_FloatIn, - flagSpec "force-recomp" Opt_ForceRecomp, - flagSpec "full-laziness" Opt_FullLaziness, - flagSpec "fun-to-thunk" Opt_FunToThunk, - flagSpec "gen-manifest" Opt_GenManifest, - flagSpec "ghci-history" Opt_GhciHistory, - flagGhciSpec "local-ghci-history" Opt_LocalGhciHistory, - flagSpec "ghci-sandbox" Opt_GhciSandbox, - flagSpec "helpful-errors" Opt_HelpfulErrors, - flagSpec "hpc" Opt_Hpc, - flagSpec "ignore-asserts" Opt_IgnoreAsserts, - flagSpec "ignore-interface-pragmas" Opt_IgnoreInterfacePragmas, - flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, - flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, - flagSpec "kill-absence" Opt_KillAbsence, - flagSpec "kill-one-shot" Opt_KillOneShot, - flagSpec "late-dmd-anal" Opt_LateDmdAnal, - flagSpec "liberate-case" Opt_LiberateCase, - flagHiddenSpec "llvm-pass-vectors-in-regs" Opt_LlvmPassVectorsInRegisters, - flagHiddenSpec "llvm-tbaa" Opt_LlvmTBAA, - flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage, - flagSpec "loopification" Opt_Loopification, - flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas, - flagSpec "omit-yields" Opt_OmitYields, - flagSpec "optimal-applicative-do" Opt_OptimalApplicativeDo, - flagSpec "pedantic-bottoms" Opt_PedanticBottoms, - flagSpec "pre-inlining" Opt_SimplPreInlining, - flagGhciSpec "print-bind-contents" Opt_PrintBindContents, - flagGhciSpec "print-bind-result" Opt_PrintBindResult, - flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, - flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, - flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, - flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, - flagSpec "print-explicit-runtime-reps" Opt_PrintExplicitRuntimeReps, - flagSpec "print-equality-relations" Opt_PrintEqualityRelations, - flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, - flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, - flagSpec "print-potential-instances" Opt_PrintPotentialInstances, - flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, - flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, - flagSpec "prof-count-entries" Opt_ProfCountEntries, - flagSpec "regs-graph" Opt_RegsGraph, - flagSpec "regs-iterative" Opt_RegsIterative, - depFlagSpec' "rewrite-rules" Opt_EnableRewriteRules - (useInstead "enable-rewrite-rules"), - flagSpec "shared-implib" Opt_SharedImplib, - flagSpec "spec-constr" Opt_SpecConstr, - flagSpec "spec-constr-keen" Opt_SpecConstrKeen, - flagSpec "specialise" Opt_Specialise, - flagSpec "specialize" Opt_Specialise, - flagSpec "specialise-aggressively" Opt_SpecialiseAggressively, - flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, - flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, - flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise, - flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, - flagSpec "strictness" Opt_Strictness, - flagSpec "use-rpaths" Opt_RPath, - flagSpec "write-interface" Opt_WriteInterface, - flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, - flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, - flagSpec "vectorisation-avoidance" Opt_VectorisationAvoidance, - flagSpec "vectorise" Opt_Vectorise, - flagSpec "version-macros" Opt_VersionMacros, - flagSpec "worker-wrapper" Opt_WorkerWrapper, - flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, - flagSpec "show-warning-groups" Opt_ShowWarnGroups, - flagSpec "hide-source-paths" Opt_HideSourcePaths, - flagSpec "show-hole-constraints" Opt_ShowHoleConstraints, - flagSpec "show-loaded-modules" Opt_ShowLoadedModules, - flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs - ] - --- | These @-f\@ flags can all be reversed with @-fno-\@ -fLangFlags :: [FlagSpec LangExt.Extension] -fLangFlags = map snd fLangFlagsDeps - -fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] -fLangFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] - depFlagSpecOp' "th" LangExt.TemplateHaskell - checkTemplateHaskellOk - (deprecatedForExtension "TemplateHaskell"), - depFlagSpec' "fi" LangExt.ForeignFunctionInterface - (deprecatedForExtension "ForeignFunctionInterface"), - depFlagSpec' "ffi" LangExt.ForeignFunctionInterface - (deprecatedForExtension "ForeignFunctionInterface"), - depFlagSpec' "arrows" LangExt.Arrows - (deprecatedForExtension "Arrows"), - depFlagSpec' "implicit-prelude" LangExt.ImplicitPrelude - (deprecatedForExtension "ImplicitPrelude"), - depFlagSpec' "bang-patterns" LangExt.BangPatterns - (deprecatedForExtension "BangPatterns"), - depFlagSpec' "monomorphism-restriction" LangExt.MonomorphismRestriction - (deprecatedForExtension "MonomorphismRestriction"), - depFlagSpec' "mono-pat-binds" LangExt.MonoPatBinds - (deprecatedForExtension "MonoPatBinds"), - depFlagSpec' "extended-default-rules" LangExt.ExtendedDefaultRules - (deprecatedForExtension "ExtendedDefaultRules"), - depFlagSpec' "implicit-params" LangExt.ImplicitParams - (deprecatedForExtension "ImplicitParams"), - depFlagSpec' "scoped-type-variables" LangExt.ScopedTypeVariables - (deprecatedForExtension "ScopedTypeVariables"), - depFlagSpec' "parr" LangExt.ParallelArrays - (deprecatedForExtension "ParallelArrays"), - depFlagSpec' "PArr" LangExt.ParallelArrays - (deprecatedForExtension "ParallelArrays"), - depFlagSpec' "allow-overlapping-instances" LangExt.OverlappingInstances - (deprecatedForExtension "OverlappingInstances"), - depFlagSpec' "allow-undecidable-instances" LangExt.UndecidableInstances - (deprecatedForExtension "UndecidableInstances"), - depFlagSpec' "allow-incoherent-instances" LangExt.IncoherentInstances - (deprecatedForExtension "IncoherentInstances") - ] - -supportedLanguages :: [String] -supportedLanguages = map (flagSpecName . snd) languageFlagsDeps - -supportedLanguageOverlays :: [String] -supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps - -supportedExtensions :: [String] -supportedExtensions = concatMap toFlagSpecNamePair xFlags - where - toFlagSpecNamePair flg - | otherwise = [name, noName] - where - noName = "No" ++ name - name = flagSpecName flg - -supportedLanguagesAndExtensions :: [String] -supportedLanguagesAndExtensions = - supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions - --- | These -X flags cannot be reversed with -XNo -languageFlagsDeps :: [(Deprecation, FlagSpec Language)] -languageFlagsDeps = [ - flagSpec "Haskell98" Haskell98, - flagSpec "Haskell2010" Haskell2010 - ] - --- | These -X flags cannot be reversed with -XNo --- They are used to place hard requirements on what GHC Haskell language --- features can be used. -safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)] -safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] - where mkF flag = flagSpec (show flag) flag - --- | These -X flags can all be reversed with -XNo -xFlags :: [FlagSpec LangExt.Extension] -xFlags = map snd xFlagsDeps - -xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] -xFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] --- See Note [Adding a language extension] --- Please keep the list of flags below sorted alphabetically - flagSpec "AllowAmbiguousTypes" LangExt.AllowAmbiguousTypes, - flagSpec "AlternativeLayoutRule" LangExt.AlternativeLayoutRule, - flagSpec "AlternativeLayoutRuleTransitional" - LangExt.AlternativeLayoutRuleTransitional, - flagSpec "Arrows" LangExt.Arrows, - flagSpec "AutoDeriveTypeable" LangExt.AutoDeriveTypeable, - flagSpec "BangPatterns" LangExt.BangPatterns, - flagSpec "BinaryLiterals" LangExt.BinaryLiterals, - flagSpec "CApiFFI" LangExt.CApiFFI, - flagSpec "CPP" LangExt.Cpp, - flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods, - flagSpec "ConstraintKinds" LangExt.ConstraintKinds, - flagSpec "DataKinds" LangExt.DataKinds, - depFlagSpecCond "DatatypeContexts" LangExt.DatatypeContexts - id - ("It was widely considered a misfeature, " ++ - "and has been removed from the Haskell language."), - flagSpec "DefaultSignatures" LangExt.DefaultSignatures, - flagSpec "DeriveAnyClass" LangExt.DeriveAnyClass, - flagSpec "DeriveDataTypeable" LangExt.DeriveDataTypeable, - flagSpec "DeriveFoldable" LangExt.DeriveFoldable, - flagSpec "DeriveFunctor" LangExt.DeriveFunctor, - flagSpec "DeriveGeneric" LangExt.DeriveGeneric, - flagSpec "DeriveLift" LangExt.DeriveLift, - flagSpec "DeriveTraversable" LangExt.DeriveTraversable, - flagSpec "DerivingStrategies" LangExt.DerivingStrategies, - flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, - flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, - depFlagSpec' "DoRec" LangExt.RecursiveDo - (deprecatedForExtension "RecursiveDo"), - flagSpec "DuplicateRecordFields" LangExt.DuplicateRecordFields, - flagSpec "EmptyCase" LangExt.EmptyCase, - flagSpec "EmptyDataDecls" LangExt.EmptyDataDecls, - flagSpec "ExistentialQuantification" LangExt.ExistentialQuantification, - flagSpec "ExplicitForAll" LangExt.ExplicitForAll, - flagSpec "ExplicitNamespaces" LangExt.ExplicitNamespaces, - flagSpec "ExtendedDefaultRules" LangExt.ExtendedDefaultRules, - flagSpec "FlexibleContexts" LangExt.FlexibleContexts, - flagSpec "FlexibleInstances" LangExt.FlexibleInstances, - flagSpec "ForeignFunctionInterface" LangExt.ForeignFunctionInterface, - flagSpec "FunctionalDependencies" LangExt.FunctionalDependencies, - flagSpec "GADTSyntax" LangExt.GADTSyntax, - flagSpec "GADTs" LangExt.GADTs, - flagSpec "GHCForeignImportPrim" LangExt.GHCForeignImportPrim, - flagSpec' "GeneralizedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving - setGenDeriving, - flagSpec "ImplicitParams" LangExt.ImplicitParams, - flagSpec "ImplicitPrelude" LangExt.ImplicitPrelude, - flagSpec "ImpredicativeTypes" LangExt.ImpredicativeTypes, - flagSpec' "IncoherentInstances" LangExt.IncoherentInstances - setIncoherentInsts, - flagSpec "TypeFamilyDependencies" LangExt.TypeFamilyDependencies, - flagSpec "InstanceSigs" LangExt.InstanceSigs, - flagSpec "ApplicativeDo" LangExt.ApplicativeDo, - flagSpec "InterruptibleFFI" LangExt.InterruptibleFFI, - flagSpec "JavaScriptFFI" LangExt.JavaScriptFFI, - flagSpec "KindSignatures" LangExt.KindSignatures, - flagSpec "LambdaCase" LangExt.LambdaCase, - flagSpec "LiberalTypeSynonyms" LangExt.LiberalTypeSynonyms, - flagSpec "MagicHash" LangExt.MagicHash, - flagSpec "MonadComprehensions" LangExt.MonadComprehensions, - flagSpec "MonadFailDesugaring" LangExt.MonadFailDesugaring, - flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds, - depFlagSpecCond "MonoPatBinds" LangExt.MonoPatBinds - id - "Experimental feature now removed; has no effect", - flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, - flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, - flagSpec "MultiWayIf" LangExt.MultiWayIf, - flagSpec "NPlusKPatterns" LangExt.NPlusKPatterns, - flagSpec "NamedFieldPuns" LangExt.RecordPuns, - flagSpec "NamedWildCards" LangExt.NamedWildCards, - flagSpec "NegativeLiterals" LangExt.NegativeLiterals, - flagSpec "NondecreasingIndentation" LangExt.NondecreasingIndentation, - depFlagSpec' "NullaryTypeClasses" LangExt.NullaryTypeClasses - (deprecatedForExtension "MultiParamTypeClasses"), - flagSpec "NumDecimals" LangExt.NumDecimals, - depFlagSpecOp "OverlappingInstances" LangExt.OverlappingInstances - setOverlappingInsts - "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS", - flagSpec "OverloadedLabels" LangExt.OverloadedLabels, - flagSpec "OverloadedLists" LangExt.OverloadedLists, - flagSpec "OverloadedStrings" LangExt.OverloadedStrings, - flagSpec "PackageImports" LangExt.PackageImports, - flagSpec "ParallelArrays" LangExt.ParallelArrays, - flagSpec "ParallelListComp" LangExt.ParallelListComp, - flagSpec "PartialTypeSignatures" LangExt.PartialTypeSignatures, - flagSpec "PatternGuards" LangExt.PatternGuards, - depFlagSpec' "PatternSignatures" LangExt.ScopedTypeVariables - (deprecatedForExtension "ScopedTypeVariables"), - flagSpec "PatternSynonyms" LangExt.PatternSynonyms, - flagSpec "PolyKinds" LangExt.PolyKinds, - flagSpec "PolymorphicComponents" LangExt.RankNTypes, - flagSpec "PostfixOperators" LangExt.PostfixOperators, - flagSpec "QuasiQuotes" LangExt.QuasiQuotes, - flagSpec "Rank2Types" LangExt.RankNTypes, - flagSpec "RankNTypes" LangExt.RankNTypes, - flagSpec "RebindableSyntax" LangExt.RebindableSyntax, - depFlagSpec' "RecordPuns" LangExt.RecordPuns - (deprecatedForExtension "NamedFieldPuns"), - flagSpec "RecordWildCards" LangExt.RecordWildCards, - flagSpec "RecursiveDo" LangExt.RecursiveDo, - flagSpec "RelaxedLayout" LangExt.RelaxedLayout, - depFlagSpecCond "RelaxedPolyRec" LangExt.RelaxedPolyRec - not - "You can't turn off RelaxedPolyRec any more", - flagSpec "RoleAnnotations" LangExt.RoleAnnotations, - flagSpec "ScopedTypeVariables" LangExt.ScopedTypeVariables, - flagSpec "StandaloneDeriving" LangExt.StandaloneDeriving, - flagSpec "StaticPointers" LangExt.StaticPointers, - flagSpec "Strict" LangExt.Strict, - flagSpec "StrictData" LangExt.StrictData, - flagSpec' "TemplateHaskell" LangExt.TemplateHaskell - checkTemplateHaskellOk, - flagSpec "TemplateHaskellQuotes" LangExt.TemplateHaskellQuotes, - flagSpec "TraditionalRecordSyntax" LangExt.TraditionalRecordSyntax, - flagSpec "TransformListComp" LangExt.TransformListComp, - flagSpec "TupleSections" LangExt.TupleSections, - flagSpec "TypeApplications" LangExt.TypeApplications, - flagSpec "TypeInType" LangExt.TypeInType, - flagSpec "TypeFamilies" LangExt.TypeFamilies, - flagSpec "TypeOperators" LangExt.TypeOperators, - flagSpec "TypeSynonymInstances" LangExt.TypeSynonymInstances, - flagSpec "UnboxedTuples" LangExt.UnboxedTuples, - flagSpec "UnboxedSums" LangExt.UnboxedSums, - flagSpec "UndecidableInstances" LangExt.UndecidableInstances, - flagSpec "UndecidableSuperClasses" LangExt.UndecidableSuperClasses, - flagSpec "UnicodeSyntax" LangExt.UnicodeSyntax, - flagSpec "UnliftedFFITypes" LangExt.UnliftedFFITypes, - flagSpec "ViewPatterns" LangExt.ViewPatterns - ] - -defaultFlags :: Settings -> [GeneralFlag] -defaultFlags settings --- See Note [Updating flag description in the User's Guide] - = [ Opt_AutoLinkPackages, - Opt_DiagnosticsShowCaret, - Opt_EmbedManifest, - Opt_FlatCache, - Opt_GenManifest, - Opt_GhciHistory, - Opt_GhciSandbox, - Opt_HelpfulErrors, - Opt_KeepHiFiles, - Opt_KeepOFiles, - Opt_OmitYields, - Opt_PrintBindContents, - Opt_ProfCountEntries, - Opt_RPath, - Opt_SharedImplib, - Opt_SimplPreInlining, - Opt_VersionMacros - ] - - ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] - -- The default -O0 options - - ++ default_PIC platform - - ++ concatMap (wayGeneralFlags platform) (defaultWays settings) - - where platform = sTargetPlatform settings - -default_PIC :: Platform -> [GeneralFlag] -default_PIC platform = - case (platformOS platform, platformArch platform) of - (OSDarwin, ArchX86_64) -> [Opt_PIC] - (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in - -- OpenBSD since 5.3 release - -- (1 May 2013) we need to - -- always generate PIC. See - -- #10597 for more - -- information. - _ -> [] - --- General flags that are switched on/off when other general flags are switched --- on -impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) - ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) - ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) - ] - --- General flags that are switched on/off when other general flags are switched --- off -impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] - -impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] -impliedXFlags --- See Note [Updating flag description in the User's Guide] - = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) - , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) - , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) - , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) - , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances) - , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses) - , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. Trac #7854 - , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies) - - , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! - - , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) - , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) - , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) - - , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures - , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds - , (LangExt.TypeInType, turnOn, LangExt.DataKinds) - , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) - , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) - - -- AutoDeriveTypeable is not very useful without DeriveDataTypeable - , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) - - -- We turn this on so that we can export associated type - -- type synonyms in subordinates (e.g. MyClass(type AssocType)) - , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces) - , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces) - - , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) - - -- Record wild-cards implies field disambiguation - -- Otherwise if you write (C {..}) you may well get - -- stuff like " 'a' not in scope ", which is a bit silly - -- if the compiler has just filled in field 'a' of constructor 'C' - , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields) - - , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp) - - , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI) - - , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor) - , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable) - - -- Duplicate record fields require field disambiguation - , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields) - - , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes) - , (LangExt.Strict, turnOn, LangExt.StrictData) - ] - --- Note [Documenting optimisation flags] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- If you change the list of flags enabled for particular optimisation levels --- please remember to update the User's Guide. The relevant files are: --- --- * utils/mkUserGuidePart/Options/ --- * docs/users_guide/using.rst --- --- The first contains the Flag Refrence section, which breifly lists all --- available flags. The second contains a detailed description of the --- flags. Both places should contain information whether a flag is implied by --- -O0, -O or -O2. - -optLevelFlags :: [([Int], GeneralFlag)] -optLevelFlags -- see Note [Documenting optimisation flags] - = [ ([0,1,2], Opt_DoLambdaEtaExpansion) - , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] - , ([0,1,2], Opt_DmdTxDictSel) - , ([0,1,2], Opt_LlvmTBAA) - , ([0,1,2], Opt_VectorisationAvoidance) - -- This one is important for a tiresome reason: - -- we want to make sure that the bindings for data - -- constructors are eta-expanded. This is probably - -- a good thing anyway, but it seems fragile. - - , ([0], Opt_IgnoreInterfacePragmas) - , ([0], Opt_OmitInterfacePragmas) - - , ([1,2], Opt_CallArity) - , ([1,2], Opt_CaseMerge) - , ([1,2], Opt_CaseFolding) - , ([1,2], Opt_CmmElimCommonBlocks) - , ([1,2], Opt_CmmSink) - , ([1,2], Opt_CSE) - , ([1,2], Opt_StgCSE) - , ([1,2], Opt_EnableRewriteRules) -- Off for -O0; see Note [Scoping for Builtin rules] - -- in PrelRules - , ([1,2], Opt_FloatIn) - , ([1,2], Opt_FullLaziness) - , ([1,2], Opt_IgnoreAsserts) - , ([1,2], Opt_Loopification) - , ([1,2], Opt_Specialise) - , ([1,2], Opt_CrossModuleSpecialise) - , ([1,2], Opt_Strictness) - , ([1,2], Opt_UnboxSmallStrictFields) - , ([1,2], Opt_CprAnal) - , ([1,2], Opt_WorkerWrapper) - , ([1,2], Opt_SolveConstantDicts) - - , ([2], Opt_LiberateCase) - , ([2], Opt_SpecConstr) --- , ([2], Opt_RegsGraph) --- RegsGraph suffers performance regression. See #7679 --- , ([2], Opt_StaticArgumentTransformation) --- Static Argument Transformation needs investigation. See #9374 - ] - -{- Note [Eta-reduction in -O0] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Trac #11562 showed an example which tripped an ASSERT in CoreToStg; a -function was marked as MayHaveCafRefs when in fact it obviously -didn't. Reason was: - * Eta reduction wasn't happening in the simplifier, but it was - happening in CorePrep, on - $fBla = MkDict (/\a. K a) - * Result: rhsIsStatic told TidyPgm that $fBla might have CAF refs - but the eta-reduced version (MkDict K) obviously doesn't -Simple solution: just let the simplifier do eta-reduction even in -O0. -After all, CorePrep does it unconditionally! Not a big deal, but -removes an assertion failure. -} - - --- ----------------------------------------------------------------------------- --- Standard sets of warning options - --- Note [Documenting warning flags] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- If you change the list of warning enabled by default --- please remember to update the User's Guide. The relevant file is: --- --- * utils/mkUserGuidePart/ --- * docs/users_guide/using-warnings.rst - --- | Warning groups. --- --- As all warnings are in the Weverything set, it is ignored when --- displaying to the user which group a warning is in. -warningGroups :: [(String, [WarningFlag])] -warningGroups = - [ ("compat", minusWcompatOpts) - , ("unused-binds", unusedBindsFlags) - , ("default", standardWarnings) - , ("extra", minusWOpts) - , ("all", minusWallOpts) - , ("everything", minusWeverythingOpts) - ] - --- | Warning group hierarchies, where there is an explicit inclusion --- relation. --- --- Each inner list is a hierarchy of warning groups, ordered from --- smallest to largest, where each group is a superset of the one --- before it. --- --- Separating this from 'warningGroups' allows for multiple --- hierarchies with no inherent relation to be defined. --- --- The special-case Weverything group is not included. -warningHierarchies :: [[String]] -warningHierarchies = hierarchies ++ map (:[]) rest - where - hierarchies = [["default", "extra", "all"]] - rest = filter (`notElem` "everything" : concat hierarchies) $ - map fst warningGroups - --- | Find the smallest group in every hierarchy which a warning --- belongs to, excluding Weverything. -smallestGroups :: WarningFlag -> [String] -smallestGroups flag = mapMaybe go warningHierarchies where - -- Because each hierarchy is arranged from smallest to largest, - -- the first group we find in a hierarchy which contains the flag - -- is the smallest. - go (group:rest) = fromMaybe (go rest) $ do - flags <- lookup group warningGroups - guard (flag `elem` flags) - pure (Just group) - go [] = Nothing - --- | Warnings enabled unless specified otherwise -standardWarnings :: [WarningFlag] -standardWarnings -- see Note [Documenting warning flags] - = [ Opt_WarnOverlappingPatterns, - Opt_WarnWarningsDeprecations, - Opt_WarnDeprecatedFlags, - Opt_WarnDeferredTypeErrors, - Opt_WarnTypedHoles, - Opt_WarnDeferredOutOfScopeVariables, - Opt_WarnPartialTypeSignatures, - Opt_WarnUnrecognisedPragmas, - Opt_WarnDuplicateExports, - Opt_WarnOverflowedLiterals, - Opt_WarnEmptyEnumerations, - Opt_WarnMissingFields, - Opt_WarnMissingMethods, - Opt_WarnWrongDoBind, - Opt_WarnUnsupportedCallingConventions, - Opt_WarnDodgyForeignImports, - Opt_WarnInlineRuleShadowing, - Opt_WarnAlternativeLayoutRuleTransitional, - Opt_WarnUnsupportedLlvmVersion, - Opt_WarnTabs, - Opt_WarnUnrecognisedWarningFlags, - Opt_WarnSimplifiableClassConstraints - ] - --- | Things you get with -W -minusWOpts :: [WarningFlag] -minusWOpts - = standardWarnings ++ - [ Opt_WarnUnusedTopBinds, - Opt_WarnUnusedLocalBinds, - Opt_WarnUnusedPatternBinds, - Opt_WarnUnusedMatches, - Opt_WarnUnusedForalls, - Opt_WarnUnusedImports, - Opt_WarnIncompletePatterns, - Opt_WarnDodgyExports, - Opt_WarnDodgyImports, - Opt_WarnUnbangedStrictPatterns - ] - --- | Things you get with -Wall -minusWallOpts :: [WarningFlag] -minusWallOpts - = minusWOpts ++ - [ Opt_WarnTypeDefaults, - Opt_WarnNameShadowing, - Opt_WarnMissingSignatures, - Opt_WarnHiShadows, - Opt_WarnOrphans, - Opt_WarnUnusedDoBind, - Opt_WarnTrustworthySafe, - Opt_WarnUntickedPromotedConstructors, - Opt_WarnMissingPatternSynonymSignatures - ] - --- | Things you get with -Weverything, i.e. *all* known warnings flags -minusWeverythingOpts :: [WarningFlag] -minusWeverythingOpts = [ toEnum 0 .. ] - --- | Things you get with -Wcompat. --- --- This is intended to group together warnings that will be enabled by default --- at some point in the future, so that library authors eager to make their --- code future compatible to fix issues before they even generate warnings. -minusWcompatOpts :: [WarningFlag] -minusWcompatOpts - = [ Opt_WarnMissingMonadFailInstances - , Opt_WarnSemigroup - , Opt_WarnNonCanonicalMonoidInstances - ] - -enableUnusedBinds :: DynP () -enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags - -disableUnusedBinds :: DynP () -disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags - --- Things you get with -Wunused-binds -unusedBindsFlags :: [WarningFlag] -unusedBindsFlags = [ Opt_WarnUnusedTopBinds - , Opt_WarnUnusedLocalBinds - , Opt_WarnUnusedPatternBinds - ] - -enableGlasgowExts :: DynP () -enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls - mapM_ setExtensionFlag glasgowExtsFlags - -disableGlasgowExts :: DynP () -disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls - mapM_ unSetExtensionFlag glasgowExtsFlags - -glasgowExtsFlags :: [LangExt.Extension] -glasgowExtsFlags = [ - LangExt.ConstrainedClassMethods - , LangExt.DeriveDataTypeable - , LangExt.DeriveFoldable - , LangExt.DeriveFunctor - , LangExt.DeriveGeneric - , LangExt.DeriveTraversable - , LangExt.EmptyDataDecls - , LangExt.ExistentialQuantification - , LangExt.ExplicitNamespaces - , LangExt.FlexibleContexts - , LangExt.FlexibleInstances - , LangExt.ForeignFunctionInterface - , LangExt.FunctionalDependencies - , LangExt.GeneralizedNewtypeDeriving - , LangExt.ImplicitParams - , LangExt.KindSignatures - , LangExt.LiberalTypeSynonyms - , LangExt.MagicHash - , LangExt.MultiParamTypeClasses - , LangExt.ParallelListComp - , LangExt.PatternGuards - , LangExt.PostfixOperators - , LangExt.RankNTypes - , LangExt.RecursiveDo - , LangExt.ScopedTypeVariables - , LangExt.StandaloneDeriving - , LangExt.TypeOperators - , LangExt.TypeSynonymInstances - , LangExt.UnboxedTuples - , LangExt.UnicodeSyntax - , LangExt.UnliftedFFITypes ] - -foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt - --- | Was the runtime system built with profiling enabled? -rtsIsProfiled :: Bool -rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 - --- Consult the RTS to find whether GHC itself has been built with --- dynamic linking. This can't be statically known at compile-time, --- because we build both the static and dynamic versions together with --- -dynamic-too. -foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO CInt - -dynamicGhc :: Bool -dynamicGhc = unsafeDupablePerformIO rtsIsDynamicIO /= 0 - -setWarnSafe :: Bool -> DynP () -setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) -setWarnSafe False = return () - -setWarnUnsafe :: Bool -> DynP () -setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) -setWarnUnsafe False = return () - -setPackageTrust :: DynP () -setPackageTrust = do - setGeneralFlag Opt_PackageTrust - l <- getCurLoc - upd $ \d -> d { pkgTrustOnLoc = l } - -setGenDeriving :: TurnOnFlag -> DynP () -setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) -setGenDeriving False = return () - -setOverlappingInsts :: TurnOnFlag -> DynP () -setOverlappingInsts False = return () -setOverlappingInsts True = do - l <- getCurLoc - upd (\d -> d { overlapInstLoc = l }) - -setIncoherentInsts :: TurnOnFlag -> DynP () -setIncoherentInsts False = return () -setIncoherentInsts True = do - l <- getCurLoc - upd (\d -> d { incoherentOnLoc = l }) - -checkTemplateHaskellOk :: TurnOnFlag -> DynP () -checkTemplateHaskellOk _turn_on - = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) - -{- ********************************************************************** -%* * - DynFlags constructors -%* * -%********************************************************************* -} - -type DynP = EwM (CmdLineP DynFlags) - -upd :: (DynFlags -> DynFlags) -> DynP () -upd f = liftEwM (do dflags <- getCmdLineState - putCmdLineState $! f dflags) - -updM :: (DynFlags -> DynP DynFlags) -> DynP () -updM f = do dflags <- liftEwM getCmdLineState - dflags' <- f dflags - liftEwM $ putCmdLineState $! dflags' - ---------------- Constructor functions for OptKind ----------------- -noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -noArg fn = NoArg (upd fn) - -noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) -noArgM fn = NoArg (updM fn) - -hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -hasArg fn = HasArg (upd . fn) - -sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -sepArg fn = SepArg (upd . fn) - -intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -intSuffix fn = IntSuffix (\n -> upd (fn n)) - -intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) -intSuffixM fn = IntSuffix (\n -> updM (fn n)) - -floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -floatSuffix fn = FloatSuffix (\n -> upd (fn n)) - -optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) - -> OptKind (CmdLineP DynFlags) -optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) - -setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags) -setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) - --------------------------- -addWay :: Way -> DynP () -addWay w = upd (addWay' w) - -addWay' :: Way -> DynFlags -> DynFlags -addWay' w dflags0 = let platform = targetPlatform dflags0 - dflags1 = dflags0 { ways = w : ways dflags0 } - dflags2 = foldr setGeneralFlag' dflags1 - (wayGeneralFlags platform w) - dflags3 = foldr unSetGeneralFlag' dflags2 - (wayUnsetGeneralFlags platform w) - in dflags3 - -removeWayDyn :: DynP () -removeWayDyn = upd (\dfs -> dfs { ways = filter (WayDyn /=) (ways dfs) }) - --------------------------- -setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () -setGeneralFlag f = upd (setGeneralFlag' f) -unSetGeneralFlag f = upd (unSetGeneralFlag' f) - -setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags -setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps - where - deps = [ if turn_on then setGeneralFlag' d - else unSetGeneralFlag' d - | (f', turn_on, d) <- impliedGFlags, f' == f ] - -- When you set f, set the ones it implies - -- NB: use setGeneralFlag recursively, in case the implied flags - -- implies further flags - -unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags -unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps - where - deps = [ if turn_on then setGeneralFlag' d - else unSetGeneralFlag' d - | (f', turn_on, d) <- impliedOffGFlags, f' == f ] - -- In general, when you un-set f, we don't un-set the things it implies. - -- There are however some exceptions, e.g., -fno-strictness implies - -- -fno-worker-wrapper. - -- - -- NB: use unSetGeneralFlag' recursively, in case the implied off flags - -- imply further flags. - --------------------------- -setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () -setWarningFlag f = upd (\dfs -> wopt_set dfs f) -unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) - -setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP () -setFatalWarningFlag f = upd (\dfs -> wopt_set_fatal dfs f) -unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f) - --------------------------- -setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP () -setExtensionFlag f = upd (setExtensionFlag' f) -unSetExtensionFlag f = upd (unSetExtensionFlag' f) - -setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags -setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps - where - deps = [ if turn_on then setExtensionFlag' d - else unSetExtensionFlag' d - | (f', turn_on, d) <- impliedXFlags, f' == f ] - -- When you set f, set the ones it implies - -- NB: use setExtensionFlag recursively, in case the implied flags - -- implies further flags - -unSetExtensionFlag' f dflags = xopt_unset dflags f - -- When you un-set f, however, we don't un-set the things it implies - -- (except for -fno-glasgow-exts, which is treated specially) - --------------------------- -alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags -alterSettings f dflags = dflags { settings = f (settings dflags) } - --------------------------- -setDumpFlag' :: DumpFlag -> DynP () -setDumpFlag' dump_flag - = do upd (\dfs -> dopt_set dfs dump_flag) - when want_recomp forceRecompile - where -- Certain dumpy-things are really interested in what's going - -- on during recompilation checking, so in those cases we - -- don't want to turn it off. - want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, - Opt_D_dump_hi_diffs, - Opt_D_no_debug_output] - -forceRecompile :: DynP () --- Whenver we -ddump, force recompilation (by switching off the --- recompilation checker), else you don't see the dump! However, --- don't switch it off in --make mode, else *everything* gets --- recompiled which probably isn't what you want -forceRecompile = do dfs <- liftEwM getCmdLineState - when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp) - where - force_recomp dfs = isOneShot (ghcMode dfs) - - -setVerboseCore2Core :: DynP () -setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core - -setVerbosity :: Maybe Int -> DynP () -setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) - -setDebugLevel :: Maybe Int -> DynP () -setDebugLevel mb_n = upd (\dfs -> dfs{ debugLevel = mb_n `orElse` 2 }) - -data PkgConfRef - = GlobalPkgConf - | UserPkgConf - | PkgConfFile FilePath - deriving Eq - -addPkgConfRef :: PkgConfRef -> DynP () -addPkgConfRef p = upd $ \s -> - s { packageDBFlags = PackageDB p : packageDBFlags s } - -removeUserPkgConf :: DynP () -removeUserPkgConf = upd $ \s -> - s { packageDBFlags = NoUserPackageDB : packageDBFlags s } - -removeGlobalPkgConf :: DynP () -removeGlobalPkgConf = upd $ \s -> - s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s } - -clearPkgConf :: DynP () -clearPkgConf = upd $ \s -> - s { packageDBFlags = ClearPackageDBs : packageDBFlags s } - -parsePackageFlag :: String -- the flag - -> ReadP PackageArg -- type of argument - -> String -- string to parse - -> PackageFlag -parsePackageFlag flag arg_parse str - = case filter ((=="").snd) (readP_to_S parse str) of - [(r, "")] -> r - _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) - where doc = flag ++ " " ++ str - parse = do - pkg_arg <- tok arg_parse - let mk_expose = ExposePackage doc pkg_arg - ( do _ <- tok $ string "with" - fmap (mk_expose . ModRenaming True) parseRns - <++ fmap (mk_expose . ModRenaming False) parseRns - <++ return (mk_expose (ModRenaming True []))) - parseRns = do _ <- tok $ R.char '(' - rns <- tok $ sepBy parseItem (tok $ R.char ',') - _ <- tok $ R.char ')' - return rns - parseItem = do - orig <- tok $ parseModuleName - (do _ <- tok $ string "as" - new <- tok $ parseModuleName - return (orig, new) - +++ - return (orig, orig)) - tok m = m >>= \x -> skipSpaces >> return x - -exposePackage, exposePackageId, hidePackage, - exposePluginPackage, exposePluginPackageId, - ignorePackage, - trustPackage, distrustPackage :: String -> DynP () -exposePackage p = upd (exposePackage' p) -exposePackageId p = - upd (\s -> s{ packageFlags = - parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s }) -exposePluginPackage p = - upd (\s -> s{ pluginPackageFlags = - parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) -exposePluginPackageId p = - upd (\s -> s{ pluginPackageFlags = - parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s }) -hidePackage p = - upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) -ignorePackage p = - upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s }) - -trustPackage p = exposePackage p >> -- both trust and distrust also expose a package - upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s }) -distrustPackage p = exposePackage p >> - upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s }) - -exposePackage' :: String -> DynFlags -> DynFlags -exposePackage' p dflags - = dflags { packageFlags = - parsePackageFlag "-package" parsePackageArg p : packageFlags dflags } - -parsePackageArg :: ReadP PackageArg -parsePackageArg = - fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) - -parseUnitIdArg :: ReadP PackageArg -parseUnitIdArg = - fmap UnitIdArg parseUnitId - -setUnitId :: String -> DynFlags -> DynFlags -setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p } - --- | Given a 'ModuleName' of a signature in the home library, find --- out how it is instantiated. E.g., the canonical form of --- A in @p[A=q[]:A]@ is @q[]:A@. -canonicalizeHomeModule :: DynFlags -> ModuleName -> Module -canonicalizeHomeModule dflags mod_name = - case lookup mod_name (thisUnitIdInsts dflags) of - Nothing -> mkModule (thisPackage dflags) mod_name - Just mod -> mod - - --- ----------------------------------------------------------------------------- --- | Find the package environment (if one exists) --- --- We interpret the package environment as a set of package flags; to be --- specific, if we find a package environment file like --- --- > clear-package-db --- > global-package-db --- > package-db blah/package.conf.d --- > package-id id1 --- > package-id id2 --- --- we interpret this as --- --- > [ -hide-all-packages --- > , -clear-package-db --- > , -global-package-db --- > , -package-db blah/package.conf.d --- > , -package-id id1 --- > , -package-id id2 --- > ] --- --- There's also an older syntax alias for package-id, which is just an --- unadorned package id --- --- > id1 --- > id2 --- -interpretPackageEnv :: DynFlags -> IO DynFlags -interpretPackageEnv dflags = do - mPkgEnv <- runMaybeT $ msum $ [ - getCmdLineArg >>= \env -> msum [ - probeEnvFile env - , probeEnvName env - , cmdLineError env - ] - , getEnvVar >>= \env -> msum [ - probeEnvFile env - , probeEnvName env - , envError env - ] - , notIfHideAllPackages >> msum [ - findLocalEnvFile >>= probeEnvFile - , probeEnvName defaultEnvName - ] - ] - case mPkgEnv of - Nothing -> - -- No environment found. Leave DynFlags unchanged. - return dflags - Just envfile -> do - content <- readFile envfile - let setFlags :: DynP () - setFlags = do - setGeneralFlag Opt_HideAllPackages - parseEnvFile envfile content - - (_, dflags') = runCmdLine (runEwM setFlags) dflags - - return dflags' - where - -- Loading environments (by name or by location) - - namedEnvPath :: String -> MaybeT IO FilePath - namedEnvPath name = do - appdir <- versionedAppDir dflags - return $ appdir "environments" name - - probeEnvName :: String -> MaybeT IO FilePath - probeEnvName name = probeEnvFile =<< namedEnvPath name - - probeEnvFile :: FilePath -> MaybeT IO FilePath - probeEnvFile path = do - guard =<< liftMaybeT (doesFileExist path) - return path - - parseEnvFile :: FilePath -> String -> DynP () - parseEnvFile envfile = mapM_ parseEntry . lines - where - parseEntry str = case words str of - ("package-db": _) -> addPkgConfRef (PkgConfFile (envdir db)) - -- relative package dbs are interpreted relative to the env file - where envdir = takeDirectory envfile - db = drop 11 str - ["clear-package-db"] -> clearPkgConf - ["global-package-db"] -> addPkgConfRef GlobalPkgConf - ["user-package-db"] -> addPkgConfRef UserPkgConf - ["package-id", pkgid] -> exposePackageId pkgid - (('-':'-':_):_) -> return () -- comments - -- and the original syntax introduced in 7.10: - [pkgid] -> exposePackageId pkgid - [] -> return () - _ -> throwGhcException $ CmdLineError $ - "Can't parse environment file entry: " - ++ envfile ++ ": " ++ str - - -- Various ways to define which environment to use - - getCmdLineArg :: MaybeT IO String - getCmdLineArg = MaybeT $ return $ packageEnv dflags - - getEnvVar :: MaybeT IO String - getEnvVar = do - mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT" - case mvar of - Right var -> return var - Left err -> if isDoesNotExistError err then mzero - else liftMaybeT $ throwIO err - - notIfHideAllPackages :: MaybeT IO () - notIfHideAllPackages = - guard (not (gopt Opt_HideAllPackages dflags)) - - defaultEnvName :: String - defaultEnvName = "default" - - -- e.g. .ghc.environment.x86_64-linux-7.6.3 - localEnvFileName :: FilePath - localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags - - -- Search for an env file, starting in the current dir and looking upwards. - -- Fail if we get to the users home dir or the filesystem root. That is, - -- we don't look for an env file in the user's home dir. The user-wide - -- env lives in ghc's versionedAppDir/environments/default - findLocalEnvFile :: MaybeT IO FilePath - findLocalEnvFile = do - curdir <- liftMaybeT getCurrentDirectory - homedir <- tryMaybeT getHomeDirectory - let probe dir | isDrive dir || dir == homedir - = mzero - probe dir = do - let file = dir localEnvFileName - exists <- liftMaybeT (doesFileExist file) - if exists - then return file - else probe (takeDirectory dir) - probe curdir - - -- Error reporting - - cmdLineError :: String -> MaybeT IO a - cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ - "Package environment " ++ show env ++ " not found" - - envError :: String -> MaybeT IO a - envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ - "Package environment " - ++ show env - ++ " (specified in GHC_ENVIRONMENT) not found" - - --- If we're linking a binary, then only targets that produce object --- code are allowed (requests for other target types are ignored). -setTarget :: HscTarget -> DynP () -setTarget l = setTargetWithPlatform (const l) - -setTargetWithPlatform :: (Platform -> HscTarget) -> DynP () -setTargetWithPlatform f = upd set - where - set dfs = let l = f (targetPlatform dfs) - in if ghcLink dfs /= LinkBinary || isObjectTarget l - then dfs{ hscTarget = l } - else dfs - --- Changes the target only if we're compiling object code. This is --- used by -fasm and -fllvm, which switch from one to the other, but --- not from bytecode to object-code. The idea is that -fasm/-fllvm --- can be safely used in an OPTIONS_GHC pragma. -setObjTarget :: HscTarget -> DynP () -setObjTarget l = updM set - where - set dflags - | isObjectTarget (hscTarget dflags) - = return $ dflags { hscTarget = l } - | otherwise = return dflags - -setOptLevel :: Int -> DynFlags -> DynP DynFlags -setOptLevel n dflags = return (updOptLevel n dflags) - -checkOptLevel :: Int -> DynFlags -> Either String DynFlags -checkOptLevel n dflags - | hscTarget dflags == HscInterpreted && n > 0 - = Left "-O conflicts with --interactive; -O ignored." - | otherwise - = Right dflags - --- -Odph is equivalent to --- --- -O2 optimise as much as possible --- -fmax-simplifier-iterations20 this is necessary sometimes --- -fsimplifier-phases=3 we use an additional simplifier phase for fusion --- -setDPHOpt :: DynFlags -> DynP DynFlags -setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 - , simplPhases = 3 - }) - -setMainIs :: String -> DynP () -setMainIs arg - | not (null main_fn) && isLower (head main_fn) - -- The arg looked like "Foo.Bar.baz" - = upd $ \d -> d { mainFunIs = Just main_fn, - mainModIs = mkModule mainUnitId (mkModuleName main_mod) } - - | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" - = upd $ \d -> d { mainModIs = mkModule mainUnitId (mkModuleName arg) } - - | otherwise -- The arg looked like "baz" - = upd $ \d -> d { mainFunIs = Just arg } - where - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - -addLdInputs :: Option -> DynFlags -> DynFlags -addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} - ------------------------------------------------------------------------------ --- Paths & Libraries - -addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP () - --- -i on its own deletes the import paths -addImportPath "" = upd (\s -> s{importPaths = []}) -addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) - -addLibraryPath p = - upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) - -addIncludePath p = - upd (\s -> s{includePaths = includePaths s ++ splitPathList p}) - -addFrameworkPath p = - upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) - -#ifndef mingw32_TARGET_OS -split_marker :: Char -split_marker = ':' -- not configurable (ToDo) -#endif - -splitPathList :: String -> [String] -splitPathList s = filter notNull (splitUp s) - -- empty paths are ignored: there might be a trailing - -- ':' in the initial list, for example. Empty paths can - -- cause confusion when they are translated into -I options - -- for passing to gcc. - where -#ifndef mingw32_TARGET_OS - splitUp xs = split split_marker xs -#else - -- Windows: 'hybrid' support for DOS-style paths in directory lists. - -- - -- That is, if "foo:bar:baz" is used, this interpreted as - -- consisting of three entries, 'foo', 'bar', 'baz'. - -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted - -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" - -- - -- Notice that no attempt is made to fully replace the 'standard' - -- split marker ':' with the Windows / DOS one, ';'. The reason being - -- that this will cause too much breakage for users & ':' will - -- work fine even with DOS paths, if you're not insisting on being silly. - -- So, use either. - splitUp [] = [] - splitUp (x:':':div:xs) | div `elem` dir_markers - = ((x:':':div:p): splitUp rs) - where - (p,rs) = findNextPath xs - -- we used to check for existence of the path here, but that - -- required the IO monad to be threaded through the command-line - -- parser which is quite inconvenient. The - splitUp xs = cons p (splitUp rs) - where - (p,rs) = findNextPath xs - - cons "" xs = xs - cons x xs = x:xs - - -- will be called either when we've consumed nought or the - -- ":/" part of a DOS path, so splitting is just a Q of - -- finding the next split marker. - findNextPath xs = - case break (`elem` split_markers) xs of - (p, _:ds) -> (p, ds) - (p, xs) -> (p, xs) - - split_markers :: [Char] - split_markers = [':', ';'] - - dir_markers :: [Char] - dir_markers = ['/', '\\'] -#endif - --- ----------------------------------------------------------------------------- --- tmpDir, where we store temporary files. - -setTmpDir :: FilePath -> DynFlags -> DynFlags -setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir }) - -- we used to fix /cygdrive/c/.. on Windows, but this doesn't - -- seem necessary now --SDM 7/2/2008 - ------------------------------------------------------------------------------ --- RTS opts - -setRtsOpts :: String -> DynP () -setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} - -setRtsOptsEnabled :: RtsOptsEnabled -> DynP () -setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} - ------------------------------------------------------------------------------ --- Hpc stuff - -setOptHpcDir :: String -> DynP () -setOptHpcDir arg = upd $ \ d -> d {hpcDir = arg} - ------------------------------------------------------------------------------ --- Via-C compilation stuff - --- There are some options that we need to pass to gcc when compiling --- Haskell code via C, but are only supported by recent versions of --- gcc. The configure script decides which of these options we need, --- and puts them in the "settings" file in $topdir. The advantage of --- having these in a separate file is that the file can be created at --- install-time depending on the available gcc version, and even --- re-generated later if gcc is upgraded. --- --- The options below are not dependent on the version of gcc, only the --- platform. - -picCCOpts :: DynFlags -> [String] -picCCOpts dflags = pieOpts ++ picOpts - where - picOpts = - case platformOS (targetPlatform dflags) of - OSDarwin - -- Apple prefers to do things the other way round. - -- PIC is on by default. - -- -mdynamic-no-pic: - -- Turn off PIC code generation. - -- -fno-common: - -- Don't generate "common" symbols - these are unwanted - -- in dynamic libraries. - - | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] - | otherwise -> ["-mdynamic-no-pic"] - OSMinGW32 -- no -fPIC for Windows - | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] - | otherwise -> [] - _ - -- we need -fPIC for C files when we are compiling with -dynamic, - -- otherwise things like stub.c files don't get compiled - -- correctly. They need to reference data in the Haskell - -- objects, but can't without -fPIC. See - -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode - | gopt Opt_PIC dflags || WayDyn `elem` ways dflags -> - ["-fPIC", "-U__PIC__", "-D__PIC__"] - | otherwise -> [] - - pieOpts - | gopt Opt_PICExecutable dflags = ["-pie"] - -- See Note [No PIE when linking] - | sGccSupportsNoPie (settings dflags) = ["-no-pie"] - | otherwise = [] - - -{- -Note [No PIE while linking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by -default in their gcc builds. This is incompatible with -r as it implies that we -are producing an executable. Consequently, we must manually pass -no-pie to gcc -when joining object files or linking dynamic libraries. Unless, of course, the -user has explicitly requested a PIE executable with -pie. See #12759. --} - -picPOpts :: DynFlags -> [String] -picPOpts dflags - | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] - | otherwise = [] - --- ----------------------------------------------------------------------------- --- Splitting - -can_split :: Bool -can_split = cSupportsSplitObjs == "YES" - --- ----------------------------------------------------------------------------- --- Compiler Info - -compilerInfo :: DynFlags -> [(String, String)] -compilerInfo dflags - = -- We always make "Project name" be first to keep parsing in - -- other languages simple, i.e. when looking for other fields, - -- you don't have to worry whether there is a leading '[' or not - ("Project name", cProjectName) - -- Next come the settings, so anything else can be overridden - -- in the settings file (as "lookup" uses the first match for the - -- key) - : rawSettings dflags - ++ [("Project version", projectVersion dflags), - ("Project Git commit id", cProjectGitCommitId), - ("Booter version", cBooterVersion), - ("Stage", cStage), - ("Build platform", cBuildPlatformString), - ("Host platform", cHostPlatformString), - ("Target platform", cTargetPlatformString), - ("Have interpreter", cGhcWithInterpreter), - ("Object splitting supported", cSupportsSplitObjs), - ("Have native code generator", cGhcWithNativeCodeGen), - ("Support SMP", cGhcWithSMP), - ("Tables next to code", cGhcEnableTablesNextToCode), - ("RTS ways", cGhcRTSWays), - ("RTS expects libdw", showBool cGhcRtsWithLibdw), - -- Whether or not we support @-dynamic-too@ - ("Support dynamic-too", showBool $ not isWindows), - -- Whether or not we support the @-j@ flag with @--make@. - ("Support parallel --make", "YES"), - -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in - -- installed package info. - ("Support reexported-modules", "YES"), - -- Whether or not we support extended @-package foo (Foo)@ syntax. - ("Support thinning and renaming package flags", "YES"), - -- Whether or not we support Backpack. - ("Support Backpack", "YES"), - -- If true, we require that the 'id' field in installed package info - -- match what is passed to the @-this-unit-id@ flag for modules - -- built in it - ("Requires unified installed package IDs", "YES"), - -- Whether or not we support the @-this-package-key@ flag. Prefer - -- "Uses unit IDs" over it. - ("Uses package keys", "YES"), - -- Whether or not we support the @-this-unit-id@ flag - ("Uses unit IDs", "YES"), - -- Whether or not GHC compiles libraries as dynamic by default - ("Dynamic by default", showBool $ dYNAMIC_BY_DEFAULT dflags), - -- Whether or not GHC was compiled using -dynamic - ("GHC Dynamic", showBool dynamicGhc), - -- Whether or not GHC was compiled using -prof - ("GHC Profiled", showBool rtsIsProfiled), - ("Leading underscore", cLeadingUnderscore), - ("Debug on", show debugIsOn), - ("LibDir", topDir dflags), - -- The path of the global package database used by GHC - ("Global Package DB", systemPackageConfig dflags) - ] - where - showBool True = "YES" - showBool False = "NO" - isWindows = platformOS (targetPlatform dflags) == OSMinGW32 - --- Produced by deriveConstants -#include "GHCConstantsHaskellWrappers.hs" - -bLOCK_SIZE_W :: DynFlags -> Int -bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags - -wORD_SIZE_IN_BITS :: DynFlags -> Int -wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 - -tAG_MASK :: DynFlags -> Int -tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 - -mAX_PTR_TAG :: DynFlags -> Int -mAX_PTR_TAG = tAG_MASK - --- Might be worth caching these in targetPlatform? -tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer -tARGET_MIN_INT dflags - = case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (minBound :: Int32) - 8 -> toInteger (minBound :: Int64) - w -> panic ("tARGET_MIN_INT: Unknown platformWordSize: " ++ show w) -tARGET_MAX_INT dflags - = case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (maxBound :: Int32) - 8 -> toInteger (maxBound :: Int64) - w -> panic ("tARGET_MAX_INT: Unknown platformWordSize: " ++ show w) -tARGET_MAX_WORD dflags - = case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (maxBound :: Word32) - 8 -> toInteger (maxBound :: Word64) - w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w) - - -{- ----------------------------------------------------------------------------- -Note [DynFlags consistency] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a number of number of DynFlags configurations which either -do not make sense or lead to unimplemented or buggy codepaths in the -compiler. makeDynFlagsConsistent is responsible for verifying the validity -of a set of DynFlags, fixing any issues, and reporting them back to the -caller. - -GHCi and -O ---------------- - -When using optimization, the compiler can introduce several things -(such as unboxed tuples) into the intermediate code, which GHCi later -chokes on since the bytecode interpreter can't handle this (and while -this is arguably a bug these aren't handled, there are no plans to fix -it.) - -While the driver pipeline always checks for this particular erroneous -combination when parsing flags, we also need to check when we update -the flags; this is because API clients may parse flags but update the -DynFlags afterwords, before finally running code inside a session (see -T10052 and #10052). --} - --- | Resolve any internal inconsistencies in a set of 'DynFlags'. --- Returns the consistent 'DynFlags' as well as a list of warnings --- to report to the user. -makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String]) --- Whenever makeDynFlagsConsistent does anything, it starts over, to --- ensure that a later change doesn't invalidate an earlier check. --- Be careful not to introduce potential loops! -makeDynFlagsConsistent dflags - -- Disable -dynamic-too on Windows (#8228, #7134, #5987) - | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags - = let dflags' = gopt_unset dflags Opt_BuildDynamicToo - warn = "-dynamic-too is not supported on Windows" - in loop dflags' warn - | hscTarget dflags == HscC && - not (platformUnregisterised (targetPlatform dflags)) - = if cGhcWithNativeCodeGen == "YES" - then let dflags' = dflags { hscTarget = HscAsm } - warn = "Compiler not unregisterised, so using native code generator rather than compiling via C" - in loop dflags' warn - else let dflags' = dflags { hscTarget = HscLlvm } - warn = "Compiler not unregisterised, so using LLVM rather than compiling via C" - in loop dflags' warn - | gopt Opt_Hpc dflags && hscTarget dflags == HscInterpreted - = let dflags' = gopt_unset dflags Opt_Hpc - warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc." - in loop dflags' warn - | hscTarget dflags `elem` [HscAsm, HscLlvm] && - platformUnregisterised (targetPlatform dflags) - = loop (dflags { hscTarget = HscC }) - "Compiler unregisterised, so compiling via C" - | hscTarget dflags == HscAsm && - cGhcWithNativeCodeGen /= "YES" - = let dflags' = dflags { hscTarget = HscLlvm } - warn = "No native code generator, so using LLVM" - in loop dflags' warn - | not (osElfTarget os) && gopt Opt_PIE dflags - = loop (gopt_unset dflags Opt_PIE) - "Position-independent only supported on ELF platforms" - | os == OSDarwin && - arch == ArchX86_64 && - not (gopt Opt_PIC dflags) - = loop (gopt_set dflags Opt_PIC) - "Enabling -fPIC as it is always on for this platform" - | Left err <- checkOptLevel (optLevel dflags) dflags - = loop (updOptLevel 0 dflags) err - - | LinkInMemory <- ghcLink dflags - , not (gopt Opt_ExternalInterpreter dflags) - , rtsIsProfiled - , isObjectTarget (hscTarget dflags) - , WayProf `notElem` ways dflags - = loop dflags{ways = WayProf : ways dflags} - "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" - - | otherwise = (dflags, []) - where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") - loop updated_dflags warning - = case makeDynFlagsConsistent updated_dflags of - (dflags', ws) -> (dflags', L loc warning : ws) - platform = targetPlatform dflags - arch = platformArch platform - os = platformOS platform - - --------------------------------------------------------------------------- --- Do not use unsafeGlobalDynFlags! --- --- unsafeGlobalDynFlags is a hack, necessary because we need to be able --- to show SDocs when tracing, but we don't always have DynFlags --- available. --- --- Do not use it if you can help it. You may get the wrong value, or this --- panic! - --- | This is the value that 'unsafeGlobalDynFlags' takes before it is --- initialized. -defaultGlobalDynFlags :: DynFlags -defaultGlobalDynFlags = - (defaultDynFlags settings) { verbosity = 2 } - where - settings = panic "v_unsafeGlobalDynFlags: not initialised" - -#if STAGE < 2 -GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags) -#else -SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags - , getOrSetLibHSghcGlobalDynFlags - , "getOrSetLibHSghcGlobalDynFlags" - , defaultGlobalDynFlags - , DynFlags ) -#endif - -unsafeGlobalDynFlags :: DynFlags -unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags - -setUnsafeGlobalDynFlags :: DynFlags -> IO () -setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags - --- ----------------------------------------------------------------------------- --- SSE and AVX - --- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to --- check if SSE is enabled, we might have x86-64 imply the -msse2 --- flag. - -data SseVersion = SSE1 - | SSE2 - | SSE3 - | SSE4 - | SSE42 - deriving (Eq, Ord) - -isSseEnabled :: DynFlags -> Bool -isSseEnabled dflags = case platformArch (targetPlatform dflags) of - ArchX86_64 -> True - ArchX86 -> sseVersion dflags >= Just SSE1 - _ -> False - -isSse2Enabled :: DynFlags -> Bool -isSse2Enabled dflags = case platformArch (targetPlatform dflags) of - ArchX86_64 -> -- SSE2 is fixed on for x86_64. It would be - -- possible to make it optional, but we'd need to - -- fix at least the foreign call code where the - -- calling convention specifies the use of xmm regs, - -- and possibly other places. - True - ArchX86 -> sseVersion dflags >= Just SSE2 - _ -> False - -isSse4_2Enabled :: DynFlags -> Bool -isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 - -isAvxEnabled :: DynFlags -> Bool -isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags - -isAvx2Enabled :: DynFlags -> Bool -isAvx2Enabled dflags = avx2 dflags || avx512f dflags - -isAvx512cdEnabled :: DynFlags -> Bool -isAvx512cdEnabled dflags = avx512cd dflags - -isAvx512erEnabled :: DynFlags -> Bool -isAvx512erEnabled dflags = avx512er dflags - -isAvx512fEnabled :: DynFlags -> Bool -isAvx512fEnabled dflags = avx512f dflags - -isAvx512pfEnabled :: DynFlags -> Bool -isAvx512pfEnabled dflags = avx512pf dflags - --- ----------------------------------------------------------------------------- --- Linker/compiler information - --- LinkerInfo contains any extra options needed by the system linker. -data LinkerInfo - = GnuLD [Option] - | GnuGold [Option] - | DarwinLD [Option] - | SolarisLD [Option] - | AixLD [Option] - | UnknownLD - deriving Eq - --- CompilerInfo tells us which C compiler we're using -data CompilerInfo - = GCC - | Clang - | AppleClang - | AppleClang51 - | UnknownCC - deriving Eq - --- ----------------------------------------------------------------------------- --- RTS hooks - --- Convert sizes like "3.5M" into integers -decodeSize :: String -> Integer -decodeSize str - | c == "" = truncate n - | c == "K" || c == "k" = truncate (n * 1000) - | c == "M" || c == "m" = truncate (n * 1000 * 1000) - | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) - | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str)) - where (m, c) = span pred str - n = readRational m - pred c = isDigit c || c == '.' - -foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () -foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () diff --git a/main/DynFlags.hs-boot b/main/DynFlags.hs-boot deleted file mode 100644 --- a/main/DynFlags.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ - -module DynFlags where - -import Platform - -data DynFlags -data DumpFlag - -targetPlatform :: DynFlags -> Platform -pprUserLength :: DynFlags -> Int -pprCols :: DynFlags -> Int -unsafeGlobalDynFlags :: DynFlags -useUnicode :: DynFlags -> Bool -useUnicodeSyntax :: DynFlags -> Bool -shouldUseColor :: DynFlags -> Bool -hasPprDebug :: DynFlags -> Bool -hasNoDebugOutput :: DynFlags -> Bool diff --git a/main/DynamicLoading.hs b/main/DynamicLoading.hs deleted file mode 100644 --- a/main/DynamicLoading.hs +++ /dev/null @@ -1,269 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} - --- | Dynamically lookup up values from modules and loading them. -module DynamicLoading ( -#ifdef GHCI - -- * Loading plugins - loadPlugins, - loadFrontendPlugin, - - -- * Force loading information - forceLoadModuleInterfaces, - forceLoadNameModuleInterface, - forceLoadTyCon, - - -- * Finding names - lookupRdrNameInModuleForPlugins, - - -- * Loading values - getValueSafely, - getHValueSafely, - lessUnsafeCoerce -#else - pluginError, -#endif - ) where - -#ifdef GHCI -import Linker ( linkModule, getHValue ) -import GHCi ( wormhole ) -import SrcLoc ( noSrcSpan ) -import Finder ( findPluginModule, cannotFindModule ) -import TcRnMonad ( initTcInteractive, initIfaceTcRn ) -import LoadIface ( loadPluginInterface ) -import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..) - , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName - , gre_name, mkRdrQual ) -import OccName ( OccName, mkVarOcc ) -import RnNames ( gresFromAvails ) -import DynFlags -import Plugins ( Plugin, FrontendPlugin, CommandLineOption ) -import PrelNames ( pluginTyConName, frontendPluginTyConName ) - -import HscTypes -import GHCi.RemoteTypes ( HValue ) -import Type ( Type, eqType, mkTyConTy, pprTyThingCategory ) -import TyCon ( TyCon ) -import Name ( Name, nameModule_maybe ) -import Id ( idType ) -import Module ( Module, ModuleName ) -import Panic -import FastString -import ErrUtils -import Outputable -import Exception -import Hooks - -import Data.Maybe ( mapMaybe ) -import GHC.Exts ( unsafeCoerce# ) - -#else - -import Module ( ModuleName, moduleNameString ) -import Panic - -import Data.List ( intercalate ) - -#endif - -#ifdef GHCI - -loadPlugins :: HscEnv -> IO [(ModuleName, Plugin, [CommandLineOption])] -loadPlugins hsc_env - = do { plugins <- mapM (loadPlugin hsc_env) to_load - ; return $ zipWith attachOptions to_load plugins } - where - dflags = hsc_dflags hsc_env - to_load = pluginModNames dflags - - attachOptions mod_nm plug = (mod_nm, plug, options) - where - options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags - , opt_mod_nm == mod_nm ] - -loadPlugin :: HscEnv -> ModuleName -> IO Plugin -loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName - -loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin -loadFrontendPlugin = loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName - -loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO a -loadPlugin' occ_name plugin_name hsc_env mod_name - = do { let plugin_rdr_name = mkRdrQual mod_name occ_name - dflags = hsc_dflags hsc_env - ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name - plugin_rdr_name - ; case mb_name of { - Nothing -> - throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep - [ text "The module", ppr mod_name - , text "did not export the plugin name" - , ppr plugin_rdr_name ]) ; - Just name -> - - do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name - ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) - ; case mb_plugin of - Nothing -> - throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep - [ text "The value", ppr name - , text "did not have the type" - , ppr pluginTyConName, text "as required"]) - Just plugin -> return plugin } } } - - --- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used --- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. -forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () -forceLoadModuleInterfaces hsc_env doc modules - = (initTcInteractive hsc_env $ - initIfaceTcRn $ - mapM_ (loadPluginInterface doc) modules) - >> return () - --- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used --- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. -forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO () -forceLoadNameModuleInterface hsc_env reason name = do - let name_modules = mapMaybe nameModule_maybe [name] - forceLoadModuleInterfaces hsc_env reason name_modules - --- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if: --- --- * The interface could not be loaded --- * The name is not that of a 'TyCon' --- * The name did not exist in the loaded module -forceLoadTyCon :: HscEnv -> Name -> IO TyCon -forceLoadTyCon hsc_env con_name = do - forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name - - mb_con_thing <- lookupTypeHscEnv hsc_env con_name - case mb_con_thing of - Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name - Just (ATyCon tycon) -> return tycon - Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing - where dflags = hsc_dflags hsc_env - --- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety --- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! --- --- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception: --- --- * If we could not load the names module --- * If the thing being loaded is not a value --- * If the Name does not exist in the module --- * If the link failed - -getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) -getValueSafely hsc_env val_name expected_type = do - mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type - case mb_hval of - Nothing -> return Nothing - Just hval -> do - value <- lessUnsafeCoerce dflags "getValueSafely" hval - return (Just value) - where - dflags = hsc_dflags hsc_env - -getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue) -getHValueSafely hsc_env val_name expected_type = do - forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name - -- Now look up the names for the value and type constructor in the type environment - mb_val_thing <- lookupTypeHscEnv hsc_env val_name - case mb_val_thing of - Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name - Just (AnId id) -> do - -- Check the value type in the interface against the type recovered from the type constructor - -- before finally casting the value to the type we assume corresponds to that constructor - if expected_type `eqType` idType id - then do - -- Link in the module that contains the value, if it has such a module - case nameModule_maybe val_name of - Just mod -> do linkModule hsc_env mod - return () - Nothing -> return () - -- Find the value that we just linked in and cast it given that we have proved it's type - hval <- getHValue hsc_env val_name >>= wormhole dflags - return (Just hval) - else return Nothing - Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing - where dflags = hsc_dflags hsc_env - --- | Coerce a value as usual, but: --- --- 1) Evaluate it immediately to get a segfault early if the coercion was wrong --- --- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened --- if it /does/ segfault -lessUnsafeCoerce :: DynFlags -> String -> a -> IO b -lessUnsafeCoerce dflags context what = do - debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <> - (text "...") - output <- evaluate (unsafeCoerce# what) - debugTraceMsg dflags 3 (text "Successfully evaluated coercion") - return output - - --- | Finds the 'Name' corresponding to the given 'RdrName' in the --- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name' --- could be found. Any other condition results in an exception: --- --- * If the module could not be found --- * If we could not determine the imports of the module --- --- Can only be used for looking up names while loading plugins (and is --- *not* suitable for use within plugins). The interface file is --- loaded very partially: just enough that it can be used, without its --- rules and instances affecting (and being linked from!) the module --- being compiled. This was introduced by 57d6798. -lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name) -lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do - -- First find the package the module resides in by searching exposed packages and home modules - found_module <- findPluginModule hsc_env mod_name - case found_module of - Found _ mod -> do - -- Find the exports of the module - (_, mb_iface) <- initTcInteractive hsc_env $ - initIfaceTcRn $ - loadPluginInterface doc mod - case mb_iface of - Just iface -> do - -- Try and find the required name in the exports - let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name - , is_qual = False, is_dloc = noSrcSpan } - imp_spec = ImpSpec decl_spec ImpAll - env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface)) - case lookupGRE_RdrName rdr_name env of - [gre] -> return (Just (gre_name gre)) - [] -> return Nothing - _ -> panic "lookupRdrNameInModule" - - Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] - err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err - where - dflags = hsc_dflags hsc_env - doc = text "contains a name used in an invocation of lookupRdrNameInModule" - -wrongTyThingError :: Name -> TyThing -> SDoc -wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] - -missingTyThingError :: Name -> SDoc -missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] - -throwCmdLineErrorS :: DynFlags -> SDoc -> IO a -throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags - -throwCmdLineError :: String -> IO a -throwCmdLineError = throwGhcExceptionIO . CmdLineError - -#else - -pluginError :: [ModuleName] -> a -pluginError modnames = throwGhcException (CmdLineError msg) - where - msg = "not built for interactive use - can't load plugins (" - -- module names are not z-encoded - ++ intercalate ", " (map moduleNameString modnames) - ++ ")" - -#endif diff --git a/main/Elf.hs b/main/Elf.hs deleted file mode 100644 --- a/main/Elf.hs +++ /dev/null @@ -1,471 +0,0 @@ -{- ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2015 --- --- ELF format tools --- ------------------------------------------------------------------------------ --} - -module Elf ( - readElfSectionByName, - readElfNoteAsString, - makeElfNote - ) where - -import Exception -import DynFlags -import Platform -import ErrUtils -import Maybes (MaybeT(..),runMaybeT) -import Util (charToC) -import Outputable (text,hcat,SDoc) - -import Control.Monad (when) -import Data.Binary.Get -import Data.Word -import Data.Char (ord) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as B8 - -{- Note [ELF specification] - ~~~~~~~~~~~~~~~~~~~~~~~~ - - ELF (Executable and Linking Format) is described in the System V Application - Binary Interface (or ABI). The latter is composed of two parts: a generic - part and a processor specific part. The generic ABI describes the parts of - the interface that remain constant across all hardware implementations of - System V. - - The latest release of the specification of the generic ABI is the version - 4.1 from March 18, 1997: - - - http://www.sco.com/developers/devspecs/gabi41.pdf - - Since 1997, snapshots of the draft for the "next" version are published: - - - http://www.sco.com/developers/gabi/ - - Quoting the notice on the website: "There is more than one instance of these - chapters to permit references to older instances to remain valid. All - modifications to these chapters are forward-compatible, so that correct use - of an older specification will not be invalidated by a newer instance. - Approximately on a yearly basis, a new instance will be saved, as it reaches - what appears to be a stable state." - - Nevertheless we will see that since 1998 it is not true for Note sections. - - Many ELF sections - ----------------- - - ELF-4.1: the normal section number fields in ELF are limited to 16 bits, - which runs out of bits when you try to cram in more sections than that. Two - fields are concerned: the one containing the number of the sections and the - one containing the index of the section that contains section's names. (The - same thing applies to the field containing the number of segments, but we - don't care about it here). - - ELF-next: to solve this, theses fields in the ELF header have an escape - value (different for each case), and the actual section number is stashed - into unused fields in the first section header. - - We support this extension as it is forward-compatible with ELF-4.1. - Moreover, GHC may generate objects with a lot of sections with the - "function-sections" feature (one section per function). - - Note sections - ------------- - - Sections with type "note" (SHT_NOTE in the specification) are used to add - arbitrary data into an ELF file. An entry in a note section is composed of a - name, a type and a value. - - ELF-4.1: "The note information in sections and program header elements holds - any number of entries, each of which is an array of 4-byte words in the - format of the target processor." Each entry has the following format: - | namesz | Word32: size of the name string (including the ending \0) - | descsz | Word32: size of the value - | type | Word32: type of the note - | name | Name string (with \0 padding to ensure 4-byte alignment) - | ... | - | desc | Value (with \0 padding to ensure 4-byte alignment) - | ... | - - ELF-next: "The note information in sections and program header elements - holds a variable amount of entries. In 64-bit objects (files with - e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte - words in the format of the target processor. In 32-bit objects (files with - e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte - words in the format of the target processor." (from 1998-2015 snapshots) - - This is not forward-compatible with ELF-4.1. In practice, for almost all - platforms namesz, descz and type fields are 4-byte words for both 32-bit and - 64-bit objects (see elf.h and readelf source code). - - The only exception in readelf source code is for IA_64 machines with OpenVMS - OS: "This OS has so many departures from the ELF standard that we test it at - many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz, - descsz and type fields are 8-byte words and name and value fields are padded - to ensure 8-byte alignment. - - We don't support this platform in the following code. Reading a note section - could be done easily (by testing Machine and OS fields in the ELF header). - Writing a note section, however, requires that we generate a different - assembly code for GAS depending on the target platform and this is a little - bit more involved. - --} - - --- | ELF header --- --- The ELF header indicates the native word size (32-bit or 64-bit) and the --- endianness of the target machine. We directly store getters for words of --- different sizes as it is more convenient to use. We also store the word size --- as it is useful to skip some uninteresting fields. --- --- Other information such as the target machine and OS are left out as we don't --- use them yet. We could add them in the future if we ever need them. -data ElfHeader = ElfHeader - { gw16 :: Get Word16 -- ^ Get a Word16 with the correct endianness - , gw32 :: Get Word32 -- ^ Get a Word32 with the correct endianness - , gwN :: Get Word64 -- ^ Get a Word with the correct word size - -- and endianness - , wordSize :: Int -- ^ Word size in bytes - } - - --- | Read the ELF header -readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader) -readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF header") - return Nothing - where - getHeader = do - magic <- getWord32be - ws <- getWord8 - endian <- getWord8 - version <- getWord8 - skip 9 -- skip OSABI, ABI version and padding - when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header" - - case (ws, endian) of - -- ELF 32, little endian - (1,1) -> return . Just $ ElfHeader - getWord16le - getWord32le - (fmap fromIntegral getWord32le) 4 - -- ELF 32, big endian - (1,2) -> return . Just $ ElfHeader - getWord16be - getWord32be - (fmap fromIntegral getWord32be) 4 - -- ELF 64, little endian - (2,1) -> return . Just $ ElfHeader - getWord16le - getWord32le - (fmap fromIntegral getWord64le) 8 - -- ELF 64, big endian - (2,2) -> return . Just $ ElfHeader - getWord16be - getWord32be - (fmap fromIntegral getWord64be) 8 - _ -> fail "Invalid ELF header" - - ------------------- --- SECTIONS ------------------- - - --- | Description of the section table -data SectionTable = SectionTable - { sectionTableOffset :: Word64 -- ^ offset of the table describing sections - , sectionEntrySize :: Word16 -- ^ size of an entry in the section table - , sectionEntryCount :: Word64 -- ^ number of sections - , sectionNameIndex :: Word32 -- ^ index of a special section which - -- contains section's names - } - --- | Read the ELF section table -readElfSectionTable :: DynFlags - -> ElfHeader - -> ByteString - -> IO (Maybe SectionTable) - -readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF section table") - return Nothing - where - getSectionTable :: Get SectionTable - getSectionTable = do - skip (24 + 2*wordSize hdr) -- skip header and some other fields - secTableOffset <- gwN hdr - skip 10 - entrySize <- gw16 hdr - entryCount <- gw16 hdr - secNameIndex <- gw16 hdr - return (SectionTable secTableOffset entrySize - (fromIntegral entryCount) - (fromIntegral secNameIndex)) - - action = do - secTable <- runGetOrThrow getSectionTable bs - -- In some cases, the number of entries and the index of the section - -- containing section's names must be found in unused fields of the first - -- section entry (see Note [ELF specification]) - let - offSize0 = fromIntegral $ sectionTableOffset secTable + 8 - + 3 * fromIntegral (wordSize hdr) - offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr) - - entryCount' <- if sectionEntryCount secTable /= 0 - then return (sectionEntryCount secTable) - else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs) - entryNameIndex' <- if sectionNameIndex secTable /= 0xffff - then return (sectionNameIndex secTable) - else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs) - return (Just $ secTable - { sectionEntryCount = entryCount' - , sectionNameIndex = entryNameIndex' - }) - - --- | A section -data Section = Section - { entryName :: ByteString -- ^ Name of the section - , entryBS :: ByteString -- ^ Content of the section - } - --- | Read a ELF section -readElfSectionByIndex :: DynFlags - -> ElfHeader - -> SectionTable - -> Word64 - -> ByteString - -> IO (Maybe Section) - -readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF section") - return Nothing - where - -- read an entry from the section table - getEntry = do - nameIndex <- gw32 hdr - skip (4+2*wordSize hdr) - offset <- fmap fromIntegral $ gwN hdr - size <- fmap fromIntegral $ gwN hdr - let bs' = LBS.take size (LBS.drop offset bs) - return (nameIndex,bs') - - -- read the entry with the given index in the section table - getEntryByIndex x = runGetOrThrow getEntry bs' - where - bs' = LBS.drop off bs - off = fromIntegral $ sectionTableOffset secTable + - x * fromIntegral (sectionEntrySize secTable) - - -- Get the name of a section - getEntryName nameIndex = do - let idx = fromIntegral (sectionNameIndex secTable) - (_,nameTable) <- getEntryByIndex idx - let bs' = LBS.drop nameIndex nameTable - runGetOrThrow getLazyByteStringNul bs' - - action = do - (nameIndex,bs') <- getEntryByIndex (fromIntegral i) - name <- getEntryName (fromIntegral nameIndex) - return (Just $ Section name bs') - - --- | Find a section from its name. Return the section contents. --- --- We do not perform any check on the section type. -findSectionFromName :: DynFlags - -> ElfHeader - -> SectionTable - -> String - -> ByteString - -> IO (Maybe ByteString) -findSectionFromName dflags hdr secTable name bs = - rec [0..sectionEntryCount secTable - 1] - where - -- convert the required section name into a ByteString to perform - -- ByteString comparison instead of String comparison - name' = B8.pack name - - -- compare recursively each section name and return the contents of - -- the matching one, if any - rec [] = return Nothing - rec (x:xs) = do - me <- readElfSectionByIndex dflags hdr secTable x bs - case me of - Just e | entryName e == name' -> return (Just (entryBS e)) - _ -> rec xs - - --- | Given a section name, read its contents as a ByteString. --- --- If the section isn't found or if there is any parsing error, we return --- Nothing -readElfSectionByName :: DynFlags - -> ByteString - -> String - -> IO (Maybe LBS.ByteString) - -readElfSectionByName dflags bs name = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF section \"" ++ name ++ "\"") - return Nothing - where - action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader dflags bs - secTable <- MaybeT $ readElfSectionTable dflags hdr bs - MaybeT $ findSectionFromName dflags hdr secTable name bs - ------------------- --- NOTE SECTIONS ------------------- - --- | read a Note as a ByteString --- --- If you try to read a note from a section which does not support the Note --- format, the parsing is likely to fail and Nothing will be returned -readElfNoteBS :: DynFlags - -> ByteString - -> String - -> String - -> IO (Maybe LBS.ByteString) - -readElfNoteBS dflags bs sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF note \"" ++ noteId ++ - "\" in section \"" ++ sectionName ++ "\"") - return Nothing - where - -- align the getter on n bytes - align n = do - m <- bytesRead - if m `mod` n == 0 - then return () - else skip 1 >> align n - - -- noteId as a bytestring - noteId' = B8.pack noteId - - -- read notes recursively until the one with a valid identifier is found - findNote hdr = do - align 4 - namesz <- gw32 hdr - descsz <- gw32 hdr - _ <- gw32 hdr -- we don't use the note type - name <- if namesz == 0 - then return LBS.empty - else getLazyByteStringNul - align 4 - desc <- if descsz == 0 - then return LBS.empty - else getLazyByteString (fromIntegral descsz) - if name == noteId' - then return $ Just desc - else findNote hdr - - - action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader dflags bs - sec <- MaybeT $ readElfSectionByName dflags bs sectionName - MaybeT $ runGetOrThrow (findNote hdr) sec - --- | read a Note as a String --- --- If you try to read a note from a section which does not support the Note --- format, the parsing is likely to fail and Nothing will be returned -readElfNoteAsString :: DynFlags - -> FilePath - -> String - -> String - -> IO (Maybe String) - -readElfNoteAsString dflags path sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF note \"" ++ noteId ++ - "\" in section \"" ++ sectionName ++ "\"") - return Nothing - where - action = do - bs <- LBS.readFile path - note <- readElfNoteBS dflags bs sectionName noteId - return (fmap B8.unpack note) - - --- | Generate the GAS code to create a Note section --- --- Header fields for notes are 32-bit long (see Note [ELF specification]). --- --- It seems there is no easy way to force GNU AS to generate a 32-bit word in --- every case. Hence we use .int directive to create them: however "The byte --- order and bit size of the number depends on what kind of target the assembly --- is for." (https://sourceware.org/binutils/docs/as/Int.html#Int) --- --- If we add new target platforms, we need to check that the generated words --- are 32-bit long, otherwise we need to use platform specific directives to --- force 32-bit .int in asWord32. -makeElfNote :: DynFlags -> String -> String -> Word32 -> String -> SDoc -makeElfNote dflags sectionName noteName typ contents = hcat [ - text "\t.section ", - text sectionName, - text ",\"\",", - text elfSectionNote, - text "\n", - - -- note name length (+ 1 for ending \0) - asWord32 (length noteName + 1), - - -- note contents size - asWord32 (length contents), - - -- note type - asWord32 typ, - - -- note name (.asciz for \0 ending string) + padding - text "\t.asciz \"", - text noteName, - text "\"\n", - text "\t.align 4\n", - - -- note contents (.ascii to avoid ending \0) + padding - text "\t.ascii \"", - text (escape contents), - text "\"\n", - text "\t.align 4\n"] - where - escape :: String -> String - escape = concatMap (charToC.fromIntegral.ord) - - asWord32 :: Show a => a -> SDoc - asWord32 x = hcat [ - text "\t.int ", - text (show x), - text "\n"] - - elfSectionNote :: String - elfSectionNote = case platformArch (targetPlatform dflags) of - ArchARM _ _ _ -> "%note" - _ -> "@note" - - - ------------------- --- Helpers ------------------- - --- | runGet in IO monad that throws an IOException on failure -runGetOrThrow :: Get a -> LBS.ByteString -> IO a -runGetOrThrow g bs = case runGetOrFail g bs of - Left _ -> fail "Error while reading file" - Right (_,_,a) -> return a diff --git a/main/ErrUtils.hs b/main/ErrUtils.hs deleted file mode 100644 --- a/main/ErrUtils.hs +++ /dev/null @@ -1,675 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1994-1998 - -\section[ErrsUtils]{Utilities for error reporting} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RecordWildCards #-} - -module ErrUtils ( - -- * Basic types - Validity(..), andValid, allValid, isValid, getInvalids, - Severity(..), - - -- * Messages - ErrMsg, errMsgDoc, - ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary, - WarnMsg, MsgDoc, - Messages, ErrorMessages, WarningMessages, - unionMessages, - errMsgSpan, errMsgContext, - errorsFound, isEmptyMessages, - isWarnMsgFatal, - - -- ** Formatting - pprMessageBag, pprErrMsgBagWithLoc, - pprLocErrMsg, printBagOfErrors, - formatErrDoc, - - -- ** Construction - emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning, - mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg, - mkPlainWarnMsg, - warnIsErrorMsg, mkLongWarnMsg, - - -- * Utilities - doIfSet, doIfSet_dyn, - getCaretDiagnostic, - - -- * Dump files - dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, - mkDumpDoc, dumpSDoc, - - -- * Issuing messages during compilation - putMsg, printInfoForUser, printOutputForUser, - logInfo, logOutput, - errorMsg, warningMsg, - fatalErrorMsg, fatalErrorMsg'', - compilationProgressMsg, - showPass, withTiming, - debugTraceMsg, - ghcExit, - prettyPrintGhcErrors, - ) where - -#include "HsVersions.h" - -import Bag -import Exception -import Outputable -import Panic -import qualified PprColour as Col -import SrcLoc -import DynFlags -import FastString (unpackFS) -import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) -import Json - -import System.Directory -import System.Exit ( ExitCode(..), exitWith ) -import System.FilePath ( takeDirectory, () ) -import Data.List -import qualified Data.Set as Set -import Data.IORef -import Data.Maybe ( fromMaybe ) -import Data.Ord -import Data.Time -import Control.Monad -import Control.Monad.IO.Class -import System.IO -import System.IO.Error ( catchIOError ) -import GHC.Conc ( getAllocationCounter ) -import System.CPUTime - -------------------------- -type MsgDoc = SDoc - -------------------------- -data Validity - = IsValid -- ^ Everything is fine - | NotValid MsgDoc -- ^ A problem, and some indication of why - -isValid :: Validity -> Bool -isValid IsValid = True -isValid (NotValid {}) = False - -andValid :: Validity -> Validity -> Validity -andValid IsValid v = v -andValid v _ = v - --- | If they aren't all valid, return the first -allValid :: [Validity] -> Validity -allValid [] = IsValid -allValid (v : vs) = v `andValid` allValid vs - -getInvalids :: [Validity] -> [MsgDoc] -getInvalids vs = [d | NotValid d <- vs] - --- ----------------------------------------------------------------------------- --- Basic error messages: just render a message with a source location. - -type Messages = (WarningMessages, ErrorMessages) -type WarningMessages = Bag WarnMsg -type ErrorMessages = Bag ErrMsg - -unionMessages :: Messages -> Messages -> Messages -unionMessages (warns1, errs1) (warns2, errs2) = - (warns1 `unionBags` warns2, errs1 `unionBags` errs2) - -data ErrMsg = ErrMsg { - errMsgSpan :: SrcSpan, - errMsgContext :: PrintUnqualified, - errMsgDoc :: ErrDoc, - -- | This has the same text as errDocImportant . errMsgDoc. - errMsgShortString :: String, - errMsgSeverity :: Severity, - errMsgReason :: WarnReason - } - -- The SrcSpan is used for sorting errors into line-number order - - --- | Categorise error msgs by their importance. This is so each section can --- be rendered visually distinct. See Note [Error report] for where these come --- from. -data ErrDoc = ErrDoc { - -- | Primary error msg. - errDocImportant :: [MsgDoc], - -- | Context e.g. \"In the second argument of ...\". - errDocContext :: [MsgDoc], - -- | Supplementary information, e.g. \"Relevant bindings include ...\". - errDocSupplementary :: [MsgDoc] - } - -errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc -errDoc = ErrDoc - -type WarnMsg = ErrMsg - -data Severity - = SevOutput - | SevFatal - | SevInteractive - - | SevDump - -- ^ Log messagse intended for compiler developers - -- No file/line/column stuff - - | SevInfo - -- ^ Log messages intended for end users. - -- No file/line/column stuff. - - | SevWarning - | SevError - -- ^ SevWarning and SevError are used for warnings and errors - -- o The message has a file/line/column heading, - -- plus "warning:" or "error:", - -- added by mkLocMessags - -- o Output is intended for end users - deriving Show - - -instance ToJson Severity where - json s = JSString (show s) - - -instance Show ErrMsg where - show em = errMsgShortString em - -pprMessageBag :: Bag MsgDoc -> SDoc -pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) - --- | Make an unannotated error message with location info. -mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc -mkLocMessage = mkLocMessageAnn Nothing - --- | Make a possibly annotated error message with location info. -mkLocMessageAnn - :: Maybe String -- ^ optional annotation - -> Severity -- ^ severity - -> SrcSpan -- ^ location - -> MsgDoc -- ^ message - -> MsgDoc - -- Always print the location, even if it is unhelpful. Error messages - -- are supposed to be in a standard format, and one without a location - -- would look strange. Better to say explicitly "". -mkLocMessageAnn ann severity locn msg - = sdocWithDynFlags $ \dflags -> - let locn' = if gopt Opt_ErrorSpans dflags - then ppr locn - else ppr (srcSpanStart locn) - - sevColour = getSeverityColour severity (colScheme dflags) - - -- Add optional information - optAnn = case ann of - Nothing -> text "" - Just i -> text " [" <> coloured sevColour (text i) <> text "]" - - -- Add prefixes, like Foo.hs:34: warning: - -- - header = locn' <> colon <+> - coloured sevColour sevText <> optAnn - - in coloured (Col.sMessage (colScheme dflags)) - (hang (coloured (Col.sHeader (colScheme dflags)) header) 4 - msg) - - where - sevText = - case severity of - SevWarning -> text "warning:" - SevError -> text "error:" - SevFatal -> text "fatal:" - _ -> empty - -getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour -getSeverityColour SevWarning = Col.sWarning -getSeverityColour SevError = Col.sError -getSeverityColour SevFatal = Col.sFatal -getSeverityColour _ = const mempty - -getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc -getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic severity (RealSrcSpan span) = do - caretDiagnostic <$> getSrcLine (srcSpanFile span) row - - where - getSrcLine fn i = - getLine i (unpackFS fn) - `catchIOError` \_ -> - pure Nothing - - getLine i fn = do - -- StringBuffer has advantages over readFile: - -- (a) no lazy IO, otherwise IO exceptions may occur in pure code - -- (b) always UTF-8, rather than some system-dependent encoding - -- (Haskell source code must be UTF-8 anyway) - content <- hGetStringBuffer fn - case atLine i content of - Just at_line -> pure $ - case lines (fix <$> lexemeToString at_line (len at_line)) of - srcLine : _ -> Just srcLine - _ -> Nothing - _ -> pure Nothing - - -- allow user to visibly see that their code is incorrectly encoded - -- (StringBuffer.nextChar uses \0 to represent undecodable characters) - fix '\0' = '\xfffd' - fix c = c - - row = srcSpanStartLine span - rowStr = show row - multiline = row /= srcSpanEndLine span - - caretDiagnostic Nothing = empty - caretDiagnostic (Just srcLineWithNewline) = - sdocWithDynFlags $ \ dflags -> - let sevColour = getSeverityColour severity (colScheme dflags) - marginColour = Col.sMargin (colScheme dflags) - in - coloured marginColour (text marginSpace) <> - text ("\n") <> - coloured marginColour (text marginRow) <> - text (" " ++ srcLinePre) <> - coloured sevColour (text srcLineSpan) <> - text (srcLinePost ++ "\n") <> - coloured marginColour (text marginSpace) <> - coloured sevColour (text (" " ++ caretLine)) - - where - - -- expand tabs in a device-independent manner #13664 - expandTabs tabWidth i s = - case s of - "" -> "" - '\t' : cs -> replicate effectiveWidth ' ' ++ - expandTabs tabWidth (i + effectiveWidth) cs - c : cs -> c : expandTabs tabWidth (i + 1) cs - where effectiveWidth = tabWidth - i `mod` tabWidth - - srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline) - - start = srcSpanStartCol span - 1 - end | multiline = length srcLine - | otherwise = srcSpanEndCol span - 1 - width = max 1 (end - start) - - marginWidth = length rowStr - marginSpace = replicate marginWidth ' ' ++ " |" - marginRow = rowStr ++ " |" - - (srcLinePre, srcLineRest) = splitAt start srcLine - (srcLineSpan, srcLinePost) = splitAt width srcLineRest - - caretEllipsis | multiline = "..." - | otherwise = "" - caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis - -makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg -makeIntoWarning reason err = err - { errMsgSeverity = SevWarning - , errMsgReason = reason } - --- ----------------------------------------------------------------------------- --- Collecting up messages for later ordering and printing. - -mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg -mk_err_msg dflags sev locn print_unqual doc - = ErrMsg { errMsgSpan = locn - , errMsgContext = print_unqual - , errMsgDoc = doc - , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc)) - , errMsgSeverity = sev - , errMsgReason = NoReason } - -mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg -mkErrDoc dflags = mk_err_msg dflags SevError - -mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg --- ^ A long (multi-line) error message -mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg --- ^ A short (one-line) error message -mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg --- ^ Variant that doesn't care about qualified/unqualified names - -mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra]) -mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] []) -mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] []) -mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra]) -mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] []) -mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] []) - ----------------- -emptyMessages :: Messages -emptyMessages = (emptyBag, emptyBag) - -isEmptyMessages :: Messages -> Bool -isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs - -warnIsErrorMsg :: DynFlags -> ErrMsg -warnIsErrorMsg dflags - = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.") - -errorsFound :: DynFlags -> Messages -> Bool -errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) - -printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () -printBagOfErrors dflags bag_of_errors - = sequence_ [ let style = mkErrStyle dflags unqual - in putLogMsg dflags reason sev s style (formatErrDoc dflags doc) - | ErrMsg { errMsgSpan = s, - errMsgDoc = doc, - errMsgSeverity = sev, - errMsgReason = reason, - errMsgContext = unqual } <- sortMsgBag (Just dflags) - bag_of_errors ] - -formatErrDoc :: DynFlags -> ErrDoc -> SDoc -formatErrDoc dflags (ErrDoc important context supplementary) - = case msgs of - [msg] -> vcat msg - _ -> vcat $ map starred msgs - where - msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags)) - [important, context, supplementary] - starred = (bullet<+>) . vcat - -pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc] -pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ] - -pprLocErrMsg :: ErrMsg -> SDoc -pprLocErrMsg (ErrMsg { errMsgSpan = s - , errMsgDoc = doc - , errMsgSeverity = sev - , errMsgContext = unqual }) - = sdocWithDynFlags $ \dflags -> - withPprStyle (mkErrStyle dflags unqual) $ - mkLocMessage sev s (formatErrDoc dflags doc) - -sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg] -sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList - where maybeFlip :: (a -> a -> b) -> (a -> a -> b) - maybeFlip - | fromMaybe False (fmap reverseErrors dflags) = flip - | otherwise = id - cmp = comparing errMsgSpan - maybeLimit = case join (fmap maxErrors dflags) of - Nothing -> id - Just err_limit -> take err_limit - -ghcExit :: DynFlags -> Int -> IO () -ghcExit dflags val - | val == 0 = exitWith ExitSuccess - | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") - exitWith (ExitFailure val) - -doIfSet :: Bool -> IO () -> IO () -doIfSet flag action | flag = action - | otherwise = return () - -doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO() -doIfSet_dyn dflags flag action | gopt flag dflags = action - | otherwise = return () - --- ----------------------------------------------------------------------------- --- Dumping - -dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () -dumpIfSet dflags flag hdr doc - | not flag = return () - | otherwise = putLogMsg dflags - NoReason - SevDump - noSrcSpan - (defaultDumpStyle dflags) - (mkDumpDoc hdr doc) - --- | a wrapper around 'dumpSDoc'. --- First check whether the dump flag is set --- Do nothing if it is unset -dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO () -dumpIfSet_dyn dflags flag hdr doc - = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc - --- | a wrapper around 'dumpSDoc'. --- First check whether the dump flag is set --- Do nothing if it is unset --- --- Unlike 'dumpIfSet_dyn', --- has a printer argument but no header argument -dumpIfSet_dyn_printer :: PrintUnqualified - -> DynFlags -> DumpFlag -> SDoc -> IO () -dumpIfSet_dyn_printer printer dflags flag doc - = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc - -mkDumpDoc :: String -> SDoc -> SDoc -mkDumpDoc hdr doc - = vcat [blankLine, - line <+> text hdr <+> line, - doc, - blankLine] - where - line = text (replicate 20 '=') - - --- | Write out a dump. --- If --dump-to-file is set then this goes to a file. --- otherwise emit to stdout. --- --- When @hdr@ is empty, we print in a more compact format (no separators and --- blank lines) --- --- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@ --- is used; it is not used to decide whether to dump the output -dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () -dumpSDoc dflags print_unqual flag hdr doc - = do let mFile = chooseDumpFile dflags flag - dump_style = mkDumpStyle dflags print_unqual - case mFile of - Just fileName - -> do - let gdref = generatedDumps dflags - gd <- readIORef gdref - let append = Set.member fileName gd - mode = if append then AppendMode else WriteMode - unless append $ - writeIORef gdref (Set.insert fileName gd) - createDirectoryIfMissing True (takeDirectory fileName) - handle <- openFile fileName mode - - -- We do not want the dump file to be affected by - -- environment variables, but instead to always use - -- UTF8. See: - -- https://ghc.haskell.org/trac/ghc/ticket/10762 - hSetEncoding handle utf8 - - doc' <- if null hdr - then return doc - else do t <- getCurrentTime - let d = text (show t) - $$ blankLine - $$ doc - return $ mkDumpDoc hdr d - defaultLogActionHPrintDoc dflags handle doc' dump_style - hClose handle - - -- write the dump to stdout - Nothing -> do - let (doc', severity) - | null hdr = (doc, SevOutput) - | otherwise = (mkDumpDoc hdr doc, SevDump) - putLogMsg dflags NoReason severity noSrcSpan dump_style doc' - - --- | Choose where to put a dump file based on DynFlags --- -chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath -chooseDumpFile dflags flag - - | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file - , Just prefix <- getPrefix - = Just $ setDir (prefix ++ (beautifyDumpName flag)) - - | otherwise - = Nothing - - where getPrefix - -- dump file location is being forced - -- by the --ddump-file-prefix flag. - | Just prefix <- dumpPrefixForce dflags - = Just prefix - -- dump file location chosen by DriverPipeline.runPipeline - | Just prefix <- dumpPrefix dflags - = Just prefix - -- we haven't got a place to put a dump file. - | otherwise - = Nothing - setDir f = case dumpDir dflags of - Just d -> d f - Nothing -> f - --- | Build a nice file name from name of a 'DumpFlag' constructor -beautifyDumpName :: DumpFlag -> String -beautifyDumpName Opt_D_th_dec_file = "th.hs" -beautifyDumpName flag - = let str = show flag - suff = case stripPrefix "Opt_D_" str of - Just x -> x - Nothing -> panic ("Bad flag name: " ++ str) - dash = map (\c -> if c == '_' then '-' else c) suff - in dash - - --- ----------------------------------------------------------------------------- --- Outputting messages from the compiler - --- We want all messages to go through one place, so that we can --- redirect them if necessary. For example, when GHC is used as a --- library we might want to catch all messages that GHC tries to --- output and do something else with them. - -ifVerbose :: DynFlags -> Int -> IO () -> IO () -ifVerbose dflags val act - | verbosity dflags >= val = act - | otherwise = return () - -errorMsg :: DynFlags -> MsgDoc -> IO () -errorMsg dflags msg - = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg - -warningMsg :: DynFlags -> MsgDoc -> IO () -warningMsg dflags msg - = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg - -fatalErrorMsg :: DynFlags -> MsgDoc -> IO () -fatalErrorMsg dflags msg = - putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg - -fatalErrorMsg'' :: FatalMessager -> String -> IO () -fatalErrorMsg'' fm msg = fm msg - -compilationProgressMsg :: DynFlags -> String -> IO () -compilationProgressMsg dflags msg - = ifVerbose dflags 1 $ - logOutput dflags (defaultUserStyle dflags) (text msg) - -showPass :: DynFlags -> String -> IO () -showPass dflags what - = ifVerbose dflags 2 $ - logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon) - --- | Time a compilation phase. --- --- When timings are enabled (e.g. with the @-v2@ flag), the allocations --- and CPU time used by the phase will be reported to stderr. Consider --- a typical usage: @withTiming getDynFlags (text "simplify") force pass@. --- When timings are enabled the following costs are included in the --- produced accounting, --- --- - The cost of executing @pass@ to a result @r@ in WHNF --- - The cost of evaluating @force r@ to WHNF (e.g. @()@) --- --- The choice of the @force@ function depends upon the amount of forcing --- desired; the goal here is to ensure that the cost of evaluating the result --- is, to the greatest extent possible, included in the accounting provided by --- 'withTiming'. Often the pass already sufficiently forces its result during --- construction; in this case @const ()@ is a reasonable choice. --- In other cases, it is necessary to evaluate the result to normal form, in --- which case something like @Control.DeepSeq.rnf@ is appropriate. --- --- To avoid adversely affecting compiler performance when timings are not --- requested, the result is only forced when timings are enabled. -withTiming :: MonadIO m - => m DynFlags -- ^ A means of getting a 'DynFlags' (often - -- 'getDynFlags' will work here) - -> SDoc -- ^ The name of the phase - -> (a -> ()) -- ^ A function to force the result - -- (often either @const ()@ or 'rnf') - -> m a -- ^ The body of the phase to be timed - -> m a -withTiming getDFlags what force_result action - = do dflags <- getDFlags - if verbosity dflags >= 2 - then do liftIO $ logInfo dflags (defaultUserStyle dflags) - $ text "***" <+> what <> colon - alloc0 <- liftIO getAllocationCounter - start <- liftIO getCPUTime - !r <- action - () <- pure $ force_result r - end <- liftIO getCPUTime - alloc1 <- liftIO getAllocationCounter - -- recall that allocation counter counts down - let alloc = alloc0 - alloc1 - liftIO $ logInfo dflags (defaultUserStyle dflags) - (text "!!!" <+> what <> colon <+> text "finished in" - <+> doublePrec 2 (realToFrac (end - start) * 1e-9) - <+> text "milliseconds" - <> comma - <+> text "allocated" - <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) - <+> text "megabytes") - pure r - else action - -debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () -debugTraceMsg dflags val msg = ifVerbose dflags val $ - logInfo dflags (defaultDumpStyle dflags) msg -putMsg :: DynFlags -> MsgDoc -> IO () -putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg - -printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () -printInfoForUser dflags print_unqual msg - = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg - -printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () -printOutputForUser dflags print_unqual msg - = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg - -logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO () -logInfo dflags sty msg - = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg - -logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO () --- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' -logOutput dflags sty msg - = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg - -prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a -prettyPrintGhcErrors dflags - = ghandle $ \e -> case e of - PprPanic str doc -> - pprDebugAndThen dflags panic (text str) doc - PprSorry str doc -> - pprDebugAndThen dflags sorry (text str) doc - PprProgramError str doc -> - pprDebugAndThen dflags pgmError (text str) doc - _ -> - liftIO $ throwIO e - --- | Checks if given 'WarnMsg' is a fatal warning. -isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool -isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag} - = wopt_fatal wflag dflags -isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags diff --git a/main/ErrUtils.hs-boot b/main/ErrUtils.hs-boot deleted file mode 100644 --- a/main/ErrUtils.hs-boot +++ /dev/null @@ -1,25 +0,0 @@ -module ErrUtils where - -import Outputable (SDoc, PrintUnqualified ) -import SrcLoc (SrcSpan) -import Json -import {-# SOURCE #-} DynFlags ( DynFlags, DumpFlag ) - -data Severity - = SevOutput - | SevFatal - | SevInteractive - | SevDump - | SevInfo - | SevWarning - | SevError - - -type MsgDoc = SDoc - -mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc -mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc -getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc -dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () - -instance ToJson Severity diff --git a/main/Finder.hs b/main/Finder.hs deleted file mode 100644 --- a/main/Finder.hs +++ /dev/null @@ -1,776 +0,0 @@ -{- -(c) The University of Glasgow, 2000-2006 - -\section[Finder]{Module Finder} --} - -{-# LANGUAGE CPP #-} - -module Finder ( - flushFinderCaches, - FindResult(..), - findImportedModule, - findPluginModule, - findExactModule, - findHomeModule, - findExposedPackageModule, - mkHomeModLocation, - mkHomeModLocation2, - mkHiOnlyModLocation, - mkHiPath, - mkObjPath, - addHomeModuleToFinder, - uncacheModule, - mkStubPaths, - - findObjectLinkableMaybe, - findObjectLinkable, - - cannotFindModule, - cannotFindInterface, - - ) where - -#include "HsVersions.h" - -import Module -import HscTypes -import Packages -import FastString -import Util -import PrelNames ( gHC_PRIM ) -import DynFlags -import Outputable -import Maybes ( expectJust ) - -import Data.IORef ( IORef, readIORef, atomicModifyIORef' ) -import System.Directory -import System.FilePath -import Control.Monad -import Data.Time -import Data.List ( foldl' ) - - -type FileExt = String -- Filename extension -type BaseName = String -- Basename of file - --- ----------------------------------------------------------------------------- --- The Finder - --- The Finder provides a thin filesystem abstraction to the rest of --- the compiler. For a given module, it can tell you where the --- source, interface, and object files for that module live. - --- It does *not* know which particular package a module lives in. Use --- Packages.lookupModuleInAllPackages for that. - --- ----------------------------------------------------------------------------- --- The finder's cache - --- remove all the home modules from the cache; package modules are --- assumed to not move around during a session. -flushFinderCaches :: HscEnv -> IO () -flushFinderCaches hsc_env = - atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) - where - this_pkg = thisPackage (hsc_dflags hsc_env) - fc_ref = hsc_FC hsc_env - is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True - | otherwise = False - -addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO () -addToFinderCache ref key val = - atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) - -removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO () -removeFromFinderCache ref key = - atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) - -lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult) -lookupFinderCache ref key = do - c <- readIORef ref - return $! lookupInstalledModuleEnv c key - --- ----------------------------------------------------------------------------- --- The three external entry points - --- | Locate a module that was imported by the user. We have the --- module's name, and possibly a package name. Without a package --- name, this function will use the search path and the known exposed --- packages to find the module, if a package is specified then only --- that package is searched for the module. - -findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult -findImportedModule hsc_env mod_name mb_pkg = - case mb_pkg of - Nothing -> unqual_import - Just pkg | pkg == fsLit "this" -> home_import -- "this" is special - | otherwise -> pkg_import - where - home_import = findHomeModule hsc_env mod_name - - pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg - - unqual_import = home_import - `orIfNotFound` - findExposedPackageModule hsc_env mod_name Nothing - --- | Locate a plugin module requested by the user, for a compiler --- plugin. This consults the same set of exposed packages as --- 'findImportedModule', unless @-hide-all-plugin-packages@ or --- @-plugin-package@ are specified. -findPluginModule :: HscEnv -> ModuleName -> IO FindResult -findPluginModule hsc_env mod_name = - findHomeModule hsc_env mod_name - `orIfNotFound` - findExposedPluginPackageModule hsc_env mod_name - --- | Locate a specific 'Module'. The purpose of this function is to --- create a 'ModLocation' for a given 'Module', that is to find out --- where the files associated with this module live. It is used when --- reading the interface for a module mentioned by another interface, --- for example (a "system import"). - -findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult -findExactModule hsc_env mod = - let dflags = hsc_dflags hsc_env - in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags - then findInstalledHomeModule hsc_env (installedModuleName mod) - else findPackageModule hsc_env mod - --- ----------------------------------------------------------------------------- --- Helpers - --- | Given a monadic actions @this@ and @or_this@, first execute --- @this@. If the returned 'FindResult' is successful, return --- it; otherwise, execute @or_this@. If both failed, this function --- also combines their failure messages in a reasonable way. -orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult -orIfNotFound this or_this = do - res <- this - case res of - NotFound { fr_paths = paths1, fr_mods_hidden = mh1 - , fr_pkgs_hidden = ph1, fr_suggestions = s1 } - -> do res2 <- or_this - case res2 of - NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 - , fr_pkgs_hidden = ph2, fr_suggestions = s2 } - -> return (NotFound { fr_paths = paths1 ++ paths2 - , fr_pkg = mb_pkg2 -- snd arg is the package search - , fr_mods_hidden = mh1 ++ mh2 - , fr_pkgs_hidden = ph1 ++ ph2 - , fr_suggestions = s1 ++ s2 }) - _other -> return res2 - _other -> return res - --- | Helper function for 'findHomeModule': this function wraps an IO action --- which would look up @mod_name@ in the file system (the home package), --- and first consults the 'hsc_FC' cache to see if the lookup has already --- been done. Otherwise, do the lookup (with the IO action) and save --- the result in the finder cache and the module location cache (if it --- was successful.) -homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult -homeSearchCache hsc_env mod_name do_this = do - let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name - modLocationCache hsc_env mod do_this - -findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString - -> IO FindResult -findExposedPackageModule hsc_env mod_name mb_pkg - = findLookupResult hsc_env - $ lookupModuleWithSuggestions - (hsc_dflags hsc_env) mod_name mb_pkg - -findExposedPluginPackageModule :: HscEnv -> ModuleName - -> IO FindResult -findExposedPluginPackageModule hsc_env mod_name - = findLookupResult hsc_env - $ lookupPluginModuleWithSuggestions - (hsc_dflags hsc_env) mod_name Nothing - -findLookupResult :: HscEnv -> LookupResult -> IO FindResult -findLookupResult hsc_env r = case r of - LookupFound m pkg_conf -> do - let im = fst (splitModuleInsts m) - r' <- findPackageModule_ hsc_env im pkg_conf - case r' of - -- TODO: ghc -M is unlikely to do the right thing - -- with just the location of the thing that was - -- instantiated; you probably also need all of the - -- implicit locations from the instances - InstalledFound loc _ -> return (Found loc m) - InstalledNoPackage _ -> return (NoPackage (moduleUnitId m)) - InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m) - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_suggestions = []}) - LookupMultiple rs -> - return (FoundMultiple rs) - LookupHidden pkg_hiddens mod_hiddens -> - return (NotFound{ fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens - , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens - , fr_suggestions = [] }) - LookupNotFound suggest -> - return (NotFound{ fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_suggestions = suggest }) - -modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult -modLocationCache hsc_env mod do_this = do - m <- lookupFinderCache (hsc_FC hsc_env) mod - case m of - Just result -> return result - Nothing -> do - result <- do_this - addToFinderCache (hsc_FC hsc_env) mod result - return result - -mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule -mkHomeInstalledModule dflags mod_name = - let iuid = fst (splitUnitIdInsts (thisPackage dflags)) - in InstalledModule iuid mod_name - --- This returns a module because it's more convenient for users -addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module -addHomeModuleToFinder hsc_env mod_name loc = do - let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name - addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod) - return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name) - -uncacheModule :: HscEnv -> ModuleName -> IO () -uncacheModule hsc_env mod_name = do - let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name - removeFromFinderCache (hsc_FC hsc_env) mod - --- ----------------------------------------------------------------------------- --- The internal workers - -findHomeModule :: HscEnv -> ModuleName -> IO FindResult -findHomeModule hsc_env mod_name = do - r <- findInstalledHomeModule hsc_env mod_name - return $ case r of - InstalledFound loc _ -> Found loc (mkModule uid mod_name) - InstalledNoPackage _ -> NoPackage uid -- impossible - InstalledNotFound fps _ -> NotFound { - fr_paths = fps, - fr_pkg = Just uid, - fr_mods_hidden = [], - fr_pkgs_hidden = [], - fr_suggestions = [] - } - where - dflags = hsc_dflags hsc_env - uid = thisPackage dflags - --- | Implements the search for a module name in the home package only. Calling --- this function directly is usually *not* what you want; currently, it's used --- as a building block for the following operations: --- --- 1. When you do a normal package lookup, we first check if the module --- is available in the home module, before looking it up in the package --- database. --- --- 2. When you have a package qualified import with package name "this", --- we shortcut to the home module. --- --- 3. When we look up an exact 'Module', if the unit id associated with --- the module is the current home module do a look up in the home module. --- --- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to --- call this.) -findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult -findInstalledHomeModule hsc_env mod_name = - homeSearchCache hsc_env mod_name $ - let - dflags = hsc_dflags hsc_env - home_path = importPaths dflags - hisuf = hiSuf dflags - mod = mkHomeInstalledModule dflags mod_name - - source_exts = - [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") - , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") - , ("hsig", mkHomeModLocationSearched dflags mod_name "hsig") - , ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig") - ] - - hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) - , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) - ] - - -- In compilation manager modes, we look for source files in the home - -- package because we can compile these automatically. In one-shot - -- compilation mode we look for .hi and .hi-boot files only. - exts | isOneShot (ghcMode dflags) = hi_exts - | otherwise = source_exts - in - - -- special case for GHC.Prim; we won't find it in the filesystem. - -- This is important only when compiling the base package (where GHC.Prim - -- is a home module). - if mod `installedModuleEq` gHC_PRIM - then return (InstalledFound (error "GHC.Prim ModLocation") mod) - else searchPathExts home_path mod exts - - --- | Search for a module in external packages only. -findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult -findPackageModule hsc_env mod = do - let - dflags = hsc_dflags hsc_env - pkg_id = installedModuleUnitId mod - -- - case lookupInstalledPackage dflags pkg_id of - Nothing -> return (InstalledNoPackage pkg_id) - Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf - --- | Look up the interface file associated with module @mod@. This function --- requires a few invariants to be upheld: (1) the 'Module' in question must --- be the module identifier of the *original* implementation of a module, --- not a reexport (this invariant is upheld by @Packages.hs@) and (2) --- the 'PackageConfig' must be consistent with the unit id in the 'Module'. --- The redundancy is to avoid an extra lookup in the package state --- for the appropriate config. -findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult -findPackageModule_ hsc_env mod pkg_conf = - ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) ) - modLocationCache hsc_env mod $ - - -- special case for GHC.Prim; we won't find it in the filesystem. - if mod `installedModuleEq` gHC_PRIM - then return (InstalledFound (error "GHC.Prim ModLocation") mod) - else - - let - dflags = hsc_dflags hsc_env - tag = buildTag dflags - - -- hi-suffix for packages depends on the build tag. - package_hisuf | null tag = "hi" - | otherwise = tag ++ "_hi" - - mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf - - import_dirs = importDirs pkg_conf - -- we never look for a .hi-boot file in an external package; - -- .hi-boot files only make sense for the home package. - in - case import_dirs of - [one] | MkDepend <- ghcMode dflags -> do - -- there's only one place that this .hi file can be, so - -- don't bother looking for it. - let basename = moduleNameSlashes (installedModuleName mod) - loc <- mk_hi_loc one basename - return (InstalledFound loc mod) - _otherwise -> - searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] - --- ----------------------------------------------------------------------------- --- General path searching - -searchPathExts - :: [FilePath] -- paths to search - -> InstalledModule -- module name - -> [ ( - FileExt, -- suffix - FilePath -> BaseName -> IO ModLocation -- action - ) - ] - -> IO InstalledFindResult - -searchPathExts paths mod exts - = do result <- search to_search -{- - hPutStrLn stderr (showSDoc $ - vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) - , nest 2 (vcat (map text paths)) - , case result of - Succeeded (loc, p) -> text "Found" <+> ppr loc - Failed fs -> text "not found"]) --} - return result - - where - basename = moduleNameSlashes (installedModuleName mod) - - to_search :: [(FilePath, IO ModLocation)] - to_search = [ (file, fn path basename) - | path <- paths, - (ext,fn) <- exts, - let base | path == "." = basename - | otherwise = path basename - file = base <.> ext - ] - - search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod))) - - search ((file, mk_result) : rest) = do - b <- doesFileExist file - if b - then do { loc <- mk_result; return (InstalledFound loc mod) } - else search rest - -mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt - -> FilePath -> BaseName -> IO ModLocation -mkHomeModLocationSearched dflags mod suff path basename = do - mkHomeModLocation2 dflags mod (path basename) suff - --- ----------------------------------------------------------------------------- --- Constructing a home module location - --- This is where we construct the ModLocation for a module in the home --- package, for which we have a source file. It is called from three --- places: --- --- (a) Here in the finder, when we are searching for a module to import, --- using the search path (-i option). --- --- (b) The compilation manager, when constructing the ModLocation for --- a "root" module (a source file named explicitly on the command line --- or in a :load command in GHCi). --- --- (c) The driver in one-shot mode, when we need to construct a --- ModLocation for a source file named on the command-line. --- --- Parameters are: --- --- mod --- The name of the module --- --- path --- (a): The search path component where the source file was found. --- (b) and (c): "." --- --- src_basename --- (a): (moduleNameSlashes mod) --- (b) and (c): The filename of the source file, minus its extension --- --- ext --- The filename extension of the source file (usually "hs" or "lhs"). - -mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation -mkHomeModLocation dflags mod src_filename = do - let (basename,extension) = splitExtension src_filename - mkHomeModLocation2 dflags mod basename extension - -mkHomeModLocation2 :: DynFlags - -> ModuleName - -> FilePath -- Of source module, without suffix - -> String -- Suffix - -> IO ModLocation -mkHomeModLocation2 dflags mod src_basename ext = do - let mod_basename = moduleNameSlashes mod - - obj_fn = mkObjPath dflags src_basename mod_basename - hi_fn = mkHiPath dflags src_basename mod_basename - - return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), - ml_hi_file = hi_fn, - ml_obj_file = obj_fn }) - -mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String - -> IO ModLocation -mkHiOnlyModLocation dflags hisuf path basename - = do let full_basename = path basename - obj_fn = mkObjPath dflags full_basename basename - return ModLocation{ ml_hs_file = Nothing, - ml_hi_file = full_basename <.> hisuf, - -- Remove the .hi-boot suffix from - -- hi_file, if it had one. We always - -- want the name of the real .hi file - -- in the ml_hi_file field. - ml_obj_file = obj_fn - } - --- | Constructs the filename of a .o file for a given source file. --- Does /not/ check whether the .o file exists -mkObjPath - :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes - -> FilePath -mkObjPath dflags basename mod_basename = obj_basename <.> osuf - where - odir = objectDir dflags - osuf = objectSuf dflags - - obj_basename | Just dir <- odir = dir mod_basename - | otherwise = basename - - --- | Constructs the filename of a .hi file for a given source file. --- Does /not/ check whether the .hi file exists -mkHiPath - :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes - -> FilePath -mkHiPath dflags basename mod_basename = hi_basename <.> hisuf - where - hidir = hiDir dflags - hisuf = hiSuf dflags - - hi_basename | Just dir <- hidir = dir mod_basename - | otherwise = basename - - - --- ----------------------------------------------------------------------------- --- Filenames of the stub files - --- We don't have to store these in ModLocations, because they can be derived --- from other available information, and they're only rarely needed. - -mkStubPaths - :: DynFlags - -> ModuleName - -> ModLocation - -> FilePath - -mkStubPaths dflags mod location - = let - stubdir = stubDir dflags - - mod_basename = moduleNameSlashes mod - src_basename = dropExtension $ expectJust "mkStubPaths" - (ml_hs_file location) - - stub_basename0 - | Just dir <- stubdir = dir mod_basename - | otherwise = src_basename - - stub_basename = stub_basename0 ++ "_stub" - in - stub_basename <.> "h" - --- ----------------------------------------------------------------------------- --- findLinkable isn't related to the other stuff in here, --- but there's no other obvious place for it - -findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) -findObjectLinkableMaybe mod locn - = do let obj_fn = ml_obj_file locn - maybe_obj_time <- modificationTimeIfExists obj_fn - case maybe_obj_time of - Nothing -> return Nothing - Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) - --- Make an object linkable when we know the object file exists, and we know --- its modification time. -findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable -findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) - -- We used to look for _stub.o files here, but that was a bug (#706) - -- Now GHC merges the stub.o into the main .o (#3687) - --- ----------------------------------------------------------------------------- --- Error messages - -cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc -cannotFindModule = cantFindErr (sLit "Could not find module") - (sLit "Ambiguous module name") - -cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc -cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") - (sLit "Ambiguous interface for") - -cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult - -> SDoc -cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) - | Just pkgs <- unambiguousPackages - = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - sep [text "it was found in multiple packages:", - hsep (map ppr pkgs) ] - ) - | otherwise - = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - vcat (map pprMod mods) - ) - where - unambiguousPackages = foldl' unambiguousPackage (Just []) mods - unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) - = Just (moduleUnitId m : xs) - unambiguousPackage _ _ = Nothing - - pprMod (m, o) = text "it is bound as" <+> ppr m <+> - text "by" <+> pprOrigin m o - pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" - pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( - if e == Just True - then [text "package" <+> ppr (moduleUnitId m)] - else [] ++ - map ((text "a reexport in package" <+>) - .ppr.packageConfigId) res ++ - if f then [text "a package flag"] else [] - ) - -cantFindErr cannot_find _ dflags mod_name find_result - = ptext cannot_find <+> quotes (ppr mod_name) - $$ more_info - where - more_info - = case find_result of - NoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" - - NotFound { fr_paths = files, fr_pkg = mb_pkg - , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens - , fr_suggestions = suggest } - | Just pkg <- mb_pkg, pkg /= thisPackage dflags - -> not_found_in_package pkg files - - | not (null suggest) - -> pp_suggestions suggest $$ tried_these files - - | null files && null mod_hiddens && null pkg_hiddens - -> 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) $$ - tried_these files - - _ -> panic "cantFindErr" - - build_tag = buildTag dflags - - not_found_in_package pkg files - | build_tag /= "" - = let - build = if build_tag == "p" then "profiling" - else "\"" ++ build_tag ++ "\"" - in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files - - | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files - - tried_these files - | null files = Outputable.empty - | verbosity dflags < 3 = - text "Use -v to see a list of the files searched for." - | otherwise = - hang (text "Locations searched:") 2 $ vcat (map text files) - - pkg_hidden :: UnitId -> SDoc - pkg_hidden pkgid = - text "It is a member of the hidden package" - <+> quotes (ppr pkgid) - --FIXME: we don't really want to show the unit id here we should - -- show the source package id or installed package id if it's ambiguous - <> dot $$ cabal_pkg_hidden_hint pkgid - cabal_pkg_hidden_hint pkgid - | gopt Opt_BuildingCabalPackage dflags - = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid) - in text "Perhaps you need to add" <+> - quotes (ppr (packageName pkg)) <+> - text "to the build-depends in your .cabal file." - | otherwise = Outputable.empty - - mod_hidden pkg = - text "it is a hidden module in the package" <+> quotes (ppr pkg) - - 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 (ModOrigin{ fromOrigPackage = e, - fromExposedReexport = res, - fromPackageFlag = f }) - | Just True <- e - = parens (text "from" <+> ppr (moduleUnitId mod)) - | f && moduleName mod == m - = parens (text "from" <+> ppr (moduleUnitId mod)) - | (pkg:_) <- res - = parens (text "from" <+> ppr (packageConfigId pkg) - <> comma <+> text "reexporting" <+> ppr mod) - | f - = parens (text "defined via package flags to be" - <+> ppr mod) - | otherwise = Outputable.empty - pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModOrigin{ fromOrigPackage = e, - fromHiddenReexport = rhs }) - | Just False <- e - = parens (text "needs flag -package-key" - <+> ppr (moduleUnitId mod)) - | (pkg:_) <- rhs - = parens (text "needs flag -package-id" - <+> ppr (packageConfigId pkg)) - | otherwise = Outputable.empty - -cantFindInstalledErr :: LitString -> LitString -> DynFlags -> ModuleName -> InstalledFindResult - -> SDoc -cantFindInstalledErr cannot_find _ dflags mod_name find_result - = ptext cannot_find <+> quotes (ppr mod_name) - $$ more_info - where - more_info - = case find_result of - InstalledNoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" $$ looks_like_srcpkgid pkg - - InstalledNotFound files mb_pkg - | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags) - -> not_found_in_package pkg files - - | null files - -> text "It is not a module in the current program, or in any known package." - - | otherwise - -> tried_these files - - _ -> panic "cantFindInstalledErr" - - build_tag = buildTag dflags - - looks_like_srcpkgid :: InstalledUnitId -> SDoc - looks_like_srcpkgid pk - -- Unsafely coerce a unit id FastString into a source package ID - -- FastString and see if it means anything. - | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk)) - = parens (text "This unit ID looks like the source package ID;" $$ - text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$ - (if null pkgs then Outputable.empty - else text "and" <+> int (length pkgs) <+> text "other candidates")) - -- Todo: also check if it looks like a package name! - | otherwise = Outputable.empty - - not_found_in_package pkg files - | build_tag /= "" - = let - build = if build_tag == "p" then "profiling" - else "\"" ++ build_tag ++ "\"" - in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files - - | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files - - tried_these files - | null files = Outputable.empty - | verbosity dflags < 3 = - text "Use -v to see a list of the files searched for." - | otherwise = - hang (text "Locations searched:") 2 $ vcat (map text files) diff --git a/main/GHC.hs b/main/GHC.hs deleted file mode 100644 --- a/main/GHC.hs +++ /dev/null @@ -1,1541 +0,0 @@ -{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, - NamedFieldPuns, TupleSections #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2012 --- --- The GHC API --- --- ----------------------------------------------------------------------------- - -module GHC ( - -- * Initialisation - defaultErrorHandler, - defaultCleanupHandler, - prettyPrintGhcErrors, - withSignalHandlers, - withCleanupSession, - - -- * GHC Monad - Ghc, GhcT, GhcMonad(..), HscEnv, - runGhc, runGhcT, initGhcMonad, - gcatch, gbracket, gfinally, - printException, - handleSourceError, - needsTemplateHaskell, - - -- * Flags and settings - DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt, - GhcMode(..), GhcLink(..), defaultObjectTarget, - parseDynamicFlags, - getSessionDynFlags, setSessionDynFlags, - getProgramDynFlags, setProgramDynFlags, setLogAction, - getInteractiveDynFlags, setInteractiveDynFlags, - - -- * Targets - Target(..), TargetId(..), Phase, - setTargets, - getTargets, - addTarget, - removeTarget, - guessTarget, - - -- * Loading\/compiling the program - depanal, - load, LoadHowMuch(..), InteractiveImport(..), - SuccessFlag(..), succeeded, failed, - defaultWarnErrLogger, WarnErrLogger, - workingDirectoryChanged, - parseModule, typecheckModule, desugarModule, loadModule, - ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), - TypecheckedSource, ParsedSource, RenamedSource, -- ditto - TypecheckedMod, ParsedMod, - moduleInfo, renamedSource, typecheckedSource, - parsedSource, coreModule, - - -- ** Compiling to Core - CoreModule(..), - compileToCoreModule, compileToCoreSimplified, - - -- * Inspecting the module structure of the program - ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), - getModSummary, - getModuleGraph, - isLoaded, - topSortModuleGraph, - - -- * Inspecting modules - ModuleInfo, - getModuleInfo, - modInfoTyThings, - modInfoTopLevelScope, - modInfoExports, - modInfoExportsWithSelectors, - modInfoInstances, - modInfoIsExportedName, - modInfoLookupName, - modInfoIface, - modInfoSafe, - lookupGlobalName, - findGlobalAnns, - mkPrintUnqualifiedForModule, - ModIface(..), - SafeHaskellMode(..), - - -- * Querying the environment - -- packageDbModules, - - -- * Printing - PrintUnqualified, alwaysQualify, - - -- * Interactive evaluation - - -- ** Executing statements - execStmt, ExecOptions(..), execOptions, ExecResult(..), - resumeExec, - - -- ** Adding new declarations - runDecls, runDeclsWithLocation, - - -- ** Get/set the current context - parseImportDecl, - setContext, getContext, - setGHCiMonad, getGHCiMonad, - - -- ** Inspecting the current context - getBindings, getInsts, getPrintUnqual, - findModule, lookupModule, - isModuleTrusted, moduleTrustReqs, - getNamesInScope, - getRdrNamesInScope, - getGRE, - moduleIsInterpreted, - getInfo, - showModule, - moduleIsBootOrNotObjectLinkable, - getNameToInstancesIndex, - - -- ** Inspecting types and kinds - exprType, TcRnExprMode(..), - typeKind, - - -- ** Looking up a Name - parseName, - lookupName, - - -- ** Compiling expressions - HValue, parseExpr, compileParsedExpr, - InteractiveEval.compileExpr, dynCompileExpr, - ForeignHValue, - compileExprRemote, compileParsedExprRemote, - - -- ** Other - runTcInteractive, -- Desired by some clients (Trac #8878) - isStmt, hasImport, isImport, isDecl, - - -- ** The debugger - SingleStep(..), - Resume(..), - History(historyBreakInfo, historyEnclosingDecls), - GHC.getHistorySpan, getHistoryModule, - abandon, abandonAll, - getResumeContext, - GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, - modInfoModBreaks, - ModBreaks(..), BreakIndex, - BreakInfo(breakInfo_number, breakInfo_module), - InteractiveEval.back, - InteractiveEval.forward, - - -- * Abstract syntax elements - - -- ** Packages - UnitId, - - -- ** Modules - Module, mkModule, pprModule, moduleName, moduleUnitId, - ModuleName, mkModuleName, moduleNameString, - - -- ** Names - Name, - isExternalName, nameModule, pprParenSymName, nameSrcSpan, - NamedThing(..), - RdrName(Qual,Unqual), - - -- ** Identifiers - Id, idType, - isImplicitId, isDeadBinder, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, - isPrimOpId, isFCallId, isClassOpId_maybe, - isDataConWorkId, idDataCon, - isBottomingId, isDictonaryId, - recordSelectorTyCon, - - -- ** Type constructors - TyCon, - tyConTyVars, tyConDataCons, tyConArity, - isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon, - isPrimTyCon, isFunTyCon, - isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon, - tyConClass_maybe, - synTyConRhs_maybe, synTyConDefn_maybe, tyConKind, - - -- ** Type variables - TyVar, - alphaTyVars, - - -- ** Data constructors - DataCon, - dataConSig, dataConType, dataConTyCon, dataConFieldLabels, - dataConIsInfix, isVanillaDataCon, dataConUserType, - dataConSrcBangs, - StrictnessMark(..), isMarkedStrict, - - -- ** Classes - Class, - classMethods, classSCTheta, classTvsFds, classATs, - pprFundeps, - - -- ** Instances - ClsInst, - instanceDFunId, - pprInstance, pprInstanceHdr, - pprFamInst, - - FamInst, - - -- ** Types and Kinds - Type, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, - Kind, - PredType, - ThetaType, pprForAll, pprThetaArrowTy, - - -- ** Entities - TyThing(..), - - -- ** Syntax - module HsSyn, -- ToDo: remove extraneous bits - - -- ** Fixities - FixityDirection(..), - defaultFixity, maxPrecedence, - negateFixity, - compareFixity, - LexicalFixity(..), - - -- ** Source locations - SrcLoc(..), RealSrcLoc, - mkSrcLoc, noSrcLoc, - srcLocFile, srcLocLine, srcLocCol, - SrcSpan(..), RealSrcSpan, - mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, - srcSpanStart, srcSpanEnd, - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, - srcSpanStartCol, srcSpanEndCol, - - -- ** Located - GenLocated(..), Located, - - -- *** Constructing Located - noLoc, mkGeneralLocated, - - -- *** Deconstructing Located - getLoc, unLoc, - - -- *** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, - leftmost_smallest, leftmost_largest, rightmost, - spans, isSubspanOf, - - -- * Exceptions - GhcException(..), showGhcException, - - -- * Token stream manipulations - Token, - getTokenStream, getRichTokenStream, - showRichTokenStream, addSourceToTokens, - - -- * Pure interface to the parser - parser, - - -- * API Annotations - ApiAnns,AnnKeywordId(..),AnnotationComment(..), - getAnnotation, getAndRemoveAnnotation, - getAnnotationComments, getAndRemoveAnnotationComments, - unicodeAnn, - - -- * Miscellaneous - --sessionHscEnv, - cyclicModuleErr, - ) where - -{- - ToDo: - - * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. --} - -#include "HsVersions.h" - -import ByteCodeTypes -import InteractiveEval -import InteractiveEvalTypes -import TcRnDriver ( runTcInteractive ) -import GHCi -import GHCi.RemoteTypes - -import PprTyThing ( pprFamInst ) -import HscMain -import GhcMake -import DriverPipeline ( compileOne' ) -import GhcMonad -import TcRnMonad ( finalSafeMode, fixSafeInstances ) -import TcRnTypes -import Packages -import NameSet -import RdrName -import HsSyn -import Type hiding( typeKind ) -import TcType hiding( typeKind ) -import Id -import TysPrim ( alphaTyVars ) -import TyCon -import Class -import DataCon -import Name hiding ( varName ) -import Avail -import InstEnv -import FamInstEnv ( FamInst ) -import SrcLoc -import CoreSyn -import TidyPgm -import DriverPhases ( Phase(..), isHaskellSrcFilename ) -import Finder -import HscTypes -import DynFlags -import SysTools -import Annotations -import Module -import Panic -import Platform -import Bag ( listToBag, unitBag ) -import ErrUtils -import MonadUtils -import Util -import StringBuffer -import Outputable -import BasicTypes -import Maybes ( expectJust ) -import FastString -import qualified Parser -import Lexer -import ApiAnnotation -import qualified GHC.LanguageExtensions as LangExt -import NameEnv -import CoreFVs ( orphNamesOfFamInst ) -import FamInstEnv ( famInstEnvElts ) -import TcRnDriver -import Inst -import FamInst - -import Data.Foldable -import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Sequence as Seq -import System.Directory ( doesFileExist ) -import Data.Maybe -import Data.List ( find ) -import Data.Time -import Data.Typeable ( Typeable ) -import Data.Word ( Word8 ) -import Control.Monad -import System.Exit ( exitWith, ExitCode(..) ) -import Exception -import Data.IORef -import System.FilePath -import System.IO -import Prelude hiding (init) - - --- %************************************************************************ --- %* * --- Initialisation: exception handlers --- %* * --- %************************************************************************ - - --- | Install some default exception handlers and run the inner computation. --- Unless you want to handle exceptions yourself, you should wrap this around --- the top level of your program. The default handlers output the error --- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m) - => FatalMessager -> FlushOut -> m a -> m a -defaultErrorHandler fm (FlushOut flushOut) inner = - -- top-level exception handler: any unrecognised exception is a compiler bug. - ghandle (\exception -> liftIO $ do - flushOut - case fromException exception of - -- an IO exception probably isn't our fault, so don't panic - Just (ioe :: IOException) -> - fatalErrorMsg'' fm (show ioe) - _ -> case fromException exception of - Just UserInterrupt -> - -- Important to let this one propagate out so our - -- calling process knows we were interrupted by ^C - liftIO $ throwIO UserInterrupt - Just StackOverflow -> - fatalErrorMsg'' fm "stack overflow: use +RTS -K to increase it" - _ -> case fromException exception of - Just (ex :: ExitCode) -> liftIO $ throwIO ex - _ -> - fatalErrorMsg'' fm - (show (Panic (show exception))) - exitWith (ExitFailure 1) - ) $ - - -- error messages propagated as exceptions - handleGhcException - (\ge -> liftIO $ do - flushOut - case ge of - Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg'' fm (show ge) - exitWith (ExitFailure 1) - ) $ - inner - --- | This function is no longer necessary, cleanup is now done by --- runGhc/runGhcT. -{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-} -defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a -defaultCleanupHandler _ m = m - where _warning_suppression = m `gonException` undefined - - --- %************************************************************************ --- %* * --- The Ghc Monad --- %* * --- %************************************************************************ - --- | Run function for the 'Ghc' monad. --- --- It initialises the GHC session and warnings via 'initGhcMonad'. Each call --- to this function will create a new session which should not be shared among --- several threads. --- --- Any errors not handled inside the 'Ghc' action are propagated as IO --- exceptions. - -runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. - -> Ghc a -- ^ The action to perform. - -> IO a -runGhc mb_top_dir ghc = do - ref <- newIORef (panic "empty session") - let session = Session ref - flip unGhc session $ withSignalHandlers $ do -- catch ^C - initGhcMonad mb_top_dir - withCleanupSession ghc - --- | Run function for 'GhcT' monad transformer. --- --- It initialises the GHC session and warnings via 'initGhcMonad'. Each call --- to this function will create a new session which should not be shared among --- several threads. - -runGhcT :: ExceptionMonad m => - Maybe FilePath -- ^ See argument to 'initGhcMonad'. - -> GhcT m a -- ^ The action to perform. - -> m a -runGhcT mb_top_dir ghct = do - ref <- liftIO $ newIORef (panic "empty session") - let session = Session ref - flip unGhcT session $ withSignalHandlers $ do -- catch ^C - initGhcMonad mb_top_dir - withCleanupSession ghct - -withCleanupSession :: GhcMonad m => m a -> m a -withCleanupSession ghc = ghc `gfinally` cleanup - where - cleanup = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - liftIO $ do - cleanTempFiles dflags - cleanTempDirs dflags - stopIServ hsc_env -- shut down the IServ - log_finaliser dflags dflags - -- exceptions will be blocked while we clean the temporary files, - -- so there shouldn't be any difficulty if we receive further - -- signals. - --- | Initialise a GHC session. --- --- If you implement a custom 'GhcMonad' you must call this function in the --- monad run function. It will initialise the session variable and clear all --- warnings. --- --- The first argument should point to the directory where GHC's library files --- reside. More precisely, this should be the output of @ghc --print-libdir@ --- of the version of GHC the module using this API is compiled with. For --- portability, you should use the @ghc-paths@ package, available at --- . - -initGhcMonad :: GhcMonad m => Maybe FilePath -> m () -initGhcMonad mb_top_dir - = do { env <- liftIO $ - do { mySettings <- initSysTools mb_top_dir - ; dflags <- initDynFlags (defaultDynFlags mySettings) - ; checkBrokenTablesNextToCode dflags - ; setUnsafeGlobalDynFlags dflags - -- c.f. DynFlags.parseDynamicFlagsFull, which - -- creates DynFlags and sets the UnsafeGlobalDynFlags - ; newHscEnv dflags } - ; setSession env } - --- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which --- breaks tables-next-to-code in dynamically linked modules. This --- check should be more selective but there is currently no released --- version where this bug is fixed. --- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and --- https://ghc.haskell.org/trac/ghc/ticket/4210#comment:29 -checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m () -checkBrokenTablesNextToCode dflags - = do { broken <- checkBrokenTablesNextToCode' dflags - ; when broken - $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr - ; fail "unsupported linker" - } - } - where - invalidLdErr = text "Tables-next-to-code not supported on ARM" <+> - text "when using binutils ld (please see:" <+> - text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" - -checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool -checkBrokenTablesNextToCode' dflags - | not (isARM arch) = return False - | WayDyn `notElem` ways dflags = return False - | not (tablesNextToCode dflags) = return False - | otherwise = do - linkerInfo <- liftIO $ getLinkerInfo dflags - case linkerInfo of - GnuLD _ -> return True - _ -> return False - where platform = targetPlatform dflags - arch = platformArch platform - - --- %************************************************************************ --- %* * --- Flags & settings --- %* * --- %************************************************************************ - --- $DynFlags --- --- The GHC session maintains two sets of 'DynFlags': --- --- * The "interactive" @DynFlags@, which are used for everything --- related to interactive evaluation, including 'runStmt', --- 'runDecls', 'exprType', 'lookupName' and so on (everything --- under \"Interactive evaluation\" in this module). --- --- * The "program" @DynFlags@, which are used when loading --- whole modules with 'load' --- --- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the --- interactive @DynFlags@. --- --- 'setProgramDynFlags', 'getProgramDynFlags' work with the --- program @DynFlags@. --- --- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' --- retrieves the program @DynFlags@ (for backwards compatibility). - - --- | Updates both the interactive and program DynFlags in a Session. --- This also reads the package database (unless it has already been --- read), and prepares the compilers knowledge about packages. It can --- be called again to load new packages: just add new package flags to --- (packageFlags dflags). --- --- Returns a list of new packages that may need to be linked in using --- the dynamic linker (see 'linkPackages') as a result of new package --- flags. If you are not doing linking or doing static linking, you --- can ignore the list of packages returned. --- -setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] -setSessionDynFlags dflags = do - dflags' <- checkNewDynFlags dflags - (dflags'', preload) <- liftIO $ initPackages dflags' - modifySession $ \h -> h{ hsc_dflags = dflags'' - , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } } - invalidateModSummaryCache - return preload - --- | Sets the program 'DynFlags'. Note: this invalidates the internal --- cached module graph, causing more work to be done the next time --- 'load' is called. -setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] -setProgramDynFlags dflags = setProgramDynFlags_ True dflags - --- | Set the action taken when the compiler produces a message. This --- can also be accomplished using 'setProgramDynFlags', but using --- 'setLogAction' avoids invalidating the cached module graph. -setLogAction :: GhcMonad m => LogAction -> LogFinaliser -> m () -setLogAction action finaliser = do - dflags' <- getProgramDynFlags - void $ setProgramDynFlags_ False $ - dflags' { log_action = action - , log_finaliser = finaliser } - -setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId] -setProgramDynFlags_ invalidate_needed dflags = do - dflags' <- checkNewDynFlags dflags - dflags_prev <- getProgramDynFlags - (dflags'', preload) <- - if (packageFlagsChanged dflags_prev dflags') - then liftIO $ initPackages dflags' - else return (dflags', []) - modifySession $ \h -> h{ hsc_dflags = dflags'' } - when invalidate_needed $ invalidateModSummaryCache - return preload - - --- When changing the DynFlags, we want the changes to apply to future --- loads, but without completely discarding the program. But the --- DynFlags are cached in each ModSummary in the hsc_mod_graph, so --- after a change to DynFlags, the changes would apply to new modules --- but not existing modules; this seems undesirable. --- --- Furthermore, the GHC API client might expect that changing --- log_action would affect future compilation messages, but for those --- modules we have cached ModSummaries for, we'll continue to use the --- old log_action. This is definitely wrong (#7478). --- --- Hence, we invalidate the ModSummary cache after changing the --- DynFlags. We do this by tweaking the date on each ModSummary, so --- that the next downsweep will think that all the files have changed --- and preprocess them again. This won't necessarily cause everything --- to be recompiled, because by the time we check whether we need to --- recopmile a module, we'll have re-summarised the module and have a --- correct ModSummary. --- -invalidateModSummaryCache :: GhcMonad m => m () -invalidateModSummaryCache = - modifySession $ \h -> h { hsc_mod_graph = map inval (hsc_mod_graph h) } - where - inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) } - --- | Returns the program 'DynFlags'. -getProgramDynFlags :: GhcMonad m => m DynFlags -getProgramDynFlags = getSessionDynFlags - --- | Set the 'DynFlags' used to evaluate interactive expressions. --- Note: this cannot be used for changes to packages. Use --- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the --- 'pkgState' into the interactive @DynFlags@. -setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () -setInteractiveDynFlags dflags = do - dflags' <- checkNewDynFlags dflags - dflags'' <- checkNewInteractiveDynFlags dflags' - modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }} - --- | Get the 'DynFlags' used to evaluate interactive expressions. -getInteractiveDynFlags :: GhcMonad m => m DynFlags -getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) - - -parseDynamicFlags :: MonadIO m => - DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Located String]) -parseDynamicFlags = parseDynamicFlagsCmdLine - --- | Checks the set of new DynFlags for possibly erroneous option --- combinations when invoking 'setSessionDynFlags' and friends, and if --- found, returns a fixed copy (if possible). -checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewDynFlags dflags = do - -- See Note [DynFlags consistency] - let (dflags', warnings) = makeDynFlagsConsistent dflags - liftIO $ handleFlagWarnings dflags warnings - return dflags' - -checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewInteractiveDynFlags dflags0 = do - dflags1 <- - if xopt LangExt.StaticPointers dflags0 - then do liftIO $ printOrThrowWarnings dflags0 $ listToBag - [mkPlainWarnMsg dflags0 interactiveSrcSpan - $ text "StaticPointers is not supported in GHCi interactive expressions."] - return $ xopt_unset dflags0 LangExt.StaticPointers - else return dflags0 - return dflags1 - - --- %************************************************************************ --- %* * --- Setting, getting, and modifying the targets --- %* * --- %************************************************************************ - --- ToDo: think about relative vs. absolute file paths. And what --- happens when the current directory changes. - --- | Sets the targets for this session. Each target may be a module name --- or a filename. The targets correspond to the set of root modules for --- the program\/library. Unloading the current program is achieved by --- setting the current set of targets to be empty, followed by 'load'. -setTargets :: GhcMonad m => [Target] -> m () -setTargets targets = modifySession (\h -> h{ hsc_targets = targets }) - --- | Returns the current set of targets -getTargets :: GhcMonad m => m [Target] -getTargets = withSession (return . hsc_targets) - --- | Add another target. -addTarget :: GhcMonad m => Target -> m () -addTarget target - = modifySession (\h -> h{ hsc_targets = target : hsc_targets h }) - --- | Remove a target -removeTarget :: GhcMonad m => TargetId -> m () -removeTarget target_id - = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) }) - where - filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ] - --- | Attempts to guess what Target a string refers to. This function --- implements the @--make@/GHCi command-line syntax for filenames: --- --- - if the string looks like a Haskell source filename, then interpret it --- as such --- --- - if adding a .hs or .lhs suffix yields the name of an existing file, --- then use that --- --- - otherwise interpret the string as a module name --- -guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target -guessTarget str (Just phase) - = return (Target (TargetFile str (Just phase)) True Nothing) -guessTarget str Nothing - | isHaskellSrcFilename file - = return (target (TargetFile file Nothing)) - | otherwise - = do exists <- liftIO $ doesFileExist hs_file - if exists - then return (target (TargetFile hs_file Nothing)) - else do - exists <- liftIO $ doesFileExist lhs_file - if exists - then return (target (TargetFile lhs_file Nothing)) - else do - if looksLikeModuleName file - then return (target (TargetModule (mkModuleName file))) - else do - dflags <- getDynFlags - liftIO $ throwGhcExceptionIO - (ProgramError (showSDoc dflags $ - text "target" <+> quotes (text file) <+> - text "is not a module name or a source file")) - where - (file,obj_allowed) - | '*':rest <- str = (rest, False) - | otherwise = (str, True) - - hs_file = file <.> "hs" - lhs_file = file <.> "lhs" - - target tid = Target tid obj_allowed Nothing - - --- | Inform GHC that the working directory has changed. GHC will flush --- its cache of module locations, since it may no longer be valid. --- --- Note: Before changing the working directory make sure all threads running --- in the same session have stopped. If you change the working directory, --- you should also unload the current program (set targets to empty, --- followed by load). -workingDirectoryChanged :: GhcMonad m => m () -workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) - - --- %************************************************************************ --- %* * --- Running phases one at a time --- %* * --- %************************************************************************ - -class ParsedMod m where - modSummary :: m -> ModSummary - parsedSource :: m -> ParsedSource - -class ParsedMod m => TypecheckedMod m where - renamedSource :: m -> Maybe RenamedSource - typecheckedSource :: m -> TypecheckedSource - moduleInfo :: m -> ModuleInfo - tm_internals :: m -> (TcGblEnv, ModDetails) - -- ToDo: improvements that could be made here: - -- if the module succeeded renaming but not typechecking, - -- we can still get back the GlobalRdrEnv and exports, so - -- perhaps the ModuleInfo should be split up into separate - -- fields. - -class TypecheckedMod m => DesugaredMod m where - coreModule :: m -> ModGuts - --- | The result of successful parsing. -data ParsedModule = - ParsedModule { pm_mod_summary :: ModSummary - , pm_parsed_source :: ParsedSource - , pm_extra_src_files :: [FilePath] - , pm_annotations :: ApiAnns } - -- See Note [Api annotations] in ApiAnnotation.hs - -instance ParsedMod ParsedModule where - modSummary m = pm_mod_summary m - parsedSource m = pm_parsed_source m - --- | The result of successful typechecking. It also contains the parser --- result. -data TypecheckedModule = - TypecheckedModule { tm_parsed_module :: ParsedModule - , tm_renamed_source :: Maybe RenamedSource - , tm_typechecked_source :: TypecheckedSource - , tm_checked_module_info :: ModuleInfo - , tm_internals_ :: (TcGblEnv, ModDetails) - } - -instance ParsedMod TypecheckedModule where - modSummary m = modSummary (tm_parsed_module m) - parsedSource m = parsedSource (tm_parsed_module m) - -instance TypecheckedMod TypecheckedModule where - renamedSource m = tm_renamed_source m - typecheckedSource m = tm_typechecked_source m - moduleInfo m = tm_checked_module_info m - tm_internals m = tm_internals_ m - --- | The result of successful desugaring (i.e., translation to core). Also --- contains all the information of a typechecked module. -data DesugaredModule = - DesugaredModule { dm_typechecked_module :: TypecheckedModule - , dm_core_module :: ModGuts - } - -instance ParsedMod DesugaredModule where - modSummary m = modSummary (dm_typechecked_module m) - parsedSource m = parsedSource (dm_typechecked_module m) - -instance TypecheckedMod DesugaredModule where - renamedSource m = renamedSource (dm_typechecked_module m) - typecheckedSource m = typecheckedSource (dm_typechecked_module m) - moduleInfo m = moduleInfo (dm_typechecked_module m) - tm_internals m = tm_internals_ (dm_typechecked_module m) - -instance DesugaredMod DesugaredModule where - coreModule m = dm_core_module m - -type ParsedSource = Located (HsModule RdrName) -type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], - Maybe LHsDocString) -type TypecheckedSource = LHsBinds Id - --- NOTE: --- - things that aren't in the output of the typechecker right now: --- - the export list --- - the imports --- - type signatures --- - type/data/newtype declarations --- - class declarations --- - instances --- - extra things in the typechecker's output: --- - default methods are turned into top-level decls. --- - dictionary bindings - --- | Return the 'ModSummary' of a module with the given name. --- --- The module must be part of the module graph (see 'hsc_mod_graph' and --- 'ModuleGraph'). If this is not the case, this function will throw a --- 'GhcApiError'. --- --- This function ignores boot modules and requires that there is only one --- non-boot module with the given name. -getModSummary :: GhcMonad m => ModuleName -> m ModSummary -getModSummary mod = do - mg <- liftM hsc_mod_graph getSession - case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of - [] -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph") - [ms] -> return ms - multiple -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple) - --- | Parse a module. --- --- Throws a 'SourceError' on parse error. -parseModule :: GhcMonad m => ModSummary -> m ParsedModule -parseModule ms = do - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - hpm <- liftIO $ hscParse hsc_env_tmp ms - return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm) - (hpm_annotations hpm)) - -- See Note [Api annotations] in ApiAnnotation.hs - --- | Typecheck and rename a parsed module. --- --- Throws a 'SourceError' if either fails. -typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule -typecheckModule pmod = do - let ms = modSummary pmod - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - (tc_gbl_env, rn_info) - <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ - HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod, - hpm_annotations = pm_annotations pmod } - details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env - safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env - - return $ - TypecheckedModule { - tm_internals_ = (tc_gbl_env, details), - tm_parsed_module = pmod, - tm_renamed_source = rn_info, - tm_typechecked_source = tcg_binds tc_gbl_env, - tm_checked_module_info = - ModuleInfo { - minf_type_env = md_types details, - minf_exports = md_exports details, - minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), - minf_instances = fixSafeInstances safe $ md_insts details, - minf_iface = Nothing, - minf_safe = safe, - minf_modBreaks = emptyModBreaks - }} - --- | Desugar a typechecked module. -desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule -desugarModule tcm = do - let ms = modSummary tcm - let (tcg, _) = tm_internals tcm - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg - return $ - DesugaredModule { - dm_typechecked_module = tcm, - dm_core_module = guts - } - --- | Load a module. Input doesn't need to be desugared. --- --- A module must be loaded before dependent modules can be typechecked. This --- always includes generating a 'ModIface' and, depending on the --- 'DynFlags.hscTarget', may also include code generation. --- --- This function will always cause recompilation and will always overwrite --- previous compilation results (potentially files on disk). --- -loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod -loadModule tcm = do - let ms = modSummary tcm - let mod = ms_mod_name ms - let loc = ms_location ms - let (tcg, _details) = tm_internals tcm - - mb_linkable <- case ms_obj_date ms of - Just t | t > ms_hs_date ms -> do - l <- liftIO $ findObjectLinkable (ms_mod ms) - (ml_obj_file loc) t - return (Just l) - _otherwise -> return Nothing - - let source_modified | isNothing mb_linkable = SourceModified - | otherwise = SourceUnmodified - -- we can't determine stability here - - -- compile doesn't change the session - hsc_env <- getSession - mod_info <- liftIO $ compileOne' (Just tcg) Nothing - hsc_env ms 1 1 Nothing mb_linkable - source_modified - - modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info } - return tcm - - --- %************************************************************************ --- %* * --- Dealing with Core --- %* * --- %************************************************************************ - --- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for --- the 'GHC.compileToCoreModule' interface. -data CoreModule - = CoreModule { - -- | Module name - cm_module :: !Module, - -- | Type environment for types declared in this module - cm_types :: !TypeEnv, - -- | Declarations - cm_binds :: CoreProgram, - -- | Safe Haskell mode - cm_safe :: SafeHaskellMode - } - -instance Outputable CoreModule where - ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, - cm_safe = sf}) - = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te - $$ vcat (map ppr cb) - --- | This is the way to get access to the Core bindings corresponding --- to a module. 'compileToCore' parses, typechecks, and --- desugars the module, then returns the resulting Core module (consisting of --- the module name, type declarations, and function declarations) if --- successful. -compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule -compileToCoreModule = compileCore False - --- | Like compileToCoreModule, but invokes the simplifier, so --- as to return simplified and tidied Core. -compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule -compileToCoreSimplified = compileCore True - -compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule -compileCore simplify fn = do - -- First, set the target to the desired filename - target <- guessTarget fn Nothing - addTarget target - _ <- load LoadAllTargets - -- Then find dependencies - modGraph <- depanal [] True - case find ((== fn) . msHsFilePath) modGraph of - Just modSummary -> do - -- Now we have the module name; - -- parse, typecheck and desugar the module - mod_guts <- coreModule `fmap` - -- TODO: space leaky: call hsc* directly? - (desugarModule =<< typecheckModule =<< parseModule modSummary) - liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ - if simplify - then do - -- If simplify is true: simplify (hscSimplify), then tidy - -- (tidyProgram). - hsc_env <- getSession - simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts - tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts - return $ Left tidy_guts - else - return $ Right mod_guts - - Nothing -> panic "compileToCoreModule: target FilePath not found in\ - module dependency graph" - where -- two versions, based on whether we simplify (thus run tidyProgram, - -- which returns a (CgGuts, ModDetails) pair, or not (in which case - -- we just have a ModGuts. - gutsToCoreModule :: SafeHaskellMode - -> Either (CgGuts, ModDetails) ModGuts - -> CoreModule - gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { - cm_module = cg_module cg, - cm_types = md_types md, - cm_binds = cg_binds cg, - cm_safe = safe_mode - } - gutsToCoreModule safe_mode (Right mg) = CoreModule { - cm_module = mg_module mg, - cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) - (mg_tcs mg) - (mg_fam_insts mg), - cm_binds = mg_binds mg, - cm_safe = safe_mode - } - --- %************************************************************************ --- %* * --- Inspecting the session --- %* * --- %************************************************************************ - --- | Get the module dependency graph. -getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary -getModuleGraph = liftM hsc_mod_graph getSession - --- | Determines whether a set of modules requires Template Haskell. --- --- Note that if the session's 'DynFlags' enabled Template Haskell when --- 'depanal' was called, then each module in the returned module graph will --- have Template Haskell enabled whether it is actually needed or not. -needsTemplateHaskell :: ModuleGraph -> Bool -needsTemplateHaskell ms = - any (xopt LangExt.TemplateHaskell . ms_hspp_opts) ms - --- | Return @True@ <==> module is loaded. -isLoaded :: GhcMonad m => ModuleName -> m Bool -isLoaded m = withSession $ \hsc_env -> - return $! isJust (lookupHpt (hsc_HPT hsc_env) m) - --- | Return the bindings for the current interactive session. -getBindings :: GhcMonad m => m [TyThing] -getBindings = withSession $ \hsc_env -> - return $ icInScopeTTs $ hsc_IC hsc_env - --- | Return the instances for the current interactive session. -getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) -getInsts = withSession $ \hsc_env -> - return $ ic_instances (hsc_IC hsc_env) - -getPrintUnqual :: GhcMonad m => m PrintUnqualified -getPrintUnqual = withSession $ \hsc_env -> - return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) - --- | Container for information about a 'Module'. -data ModuleInfo = ModuleInfo { - minf_type_env :: TypeEnv, - minf_exports :: [AvailInfo], - minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface, - minf_safe :: SafeHaskellMode, - minf_modBreaks :: ModBreaks - } - -- We don't want HomeModInfo here, because a ModuleInfo applies - -- to package modules too. - --- | Request information about a loaded 'Module' -getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X -getModuleInfo mdl = withSession $ \hsc_env -> do - let mg = hsc_mod_graph hsc_env - if mdl `elem` map ms_mod mg - then liftIO $ getHomeModuleInfo hsc_env mdl - else do - {- if isHomeModule (hsc_dflags hsc_env) mdl - then return Nothing - else -} liftIO $ getPackageModuleInfo hsc_env mdl - -- ToDo: we don't understand what the following comment means. - -- (SDM, 19/7/2011) - -- getPackageModuleInfo will attempt to find the interface, so - -- we don't want to call it for a home module, just in case there - -- was a problem loading the module and the interface doesn't - -- exist... hence the isHomeModule test here. (ToDo: reinstate) - -getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getPackageModuleInfo hsc_env mdl - = do eps <- hscEPS hsc_env - iface <- hscGetModuleInterface hsc_env mdl - let - avails = mi_exports iface - pte = eps_PTE eps - tys = [ ty | name <- concatMap availNames avails, - Just ty <- [lookupTypeEnv pte name] ] - -- - return (Just (ModuleInfo { - minf_type_env = mkTypeEnv tys, - minf_exports = avails, - minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, - minf_instances = error "getModuleInfo: instances for package module unimplemented", - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface, - minf_modBreaks = emptyModBreaks - })) - -getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getHomeModuleInfo hsc_env mdl = - case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of - Nothing -> return Nothing - Just hmi -> do - let details = hm_details hmi - iface = hm_iface hmi - return (Just (ModuleInfo { - minf_type_env = md_types details, - minf_exports = md_exports details, - minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details, - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface - ,minf_modBreaks = getModBreaks hmi - })) - --- | The list of top-level entities defined in a module -modInfoTyThings :: ModuleInfo -> [TyThing] -modInfoTyThings minf = typeEnvElts (minf_type_env minf) - -modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] -modInfoTopLevelScope minf - = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) - -modInfoExports :: ModuleInfo -> [Name] -modInfoExports minf = concatMap availNames $! minf_exports minf - -modInfoExportsWithSelectors :: ModuleInfo -> [Name] -modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf - --- | Returns the instances defined by the specified module. --- Warning: currently unimplemented for package modules. -modInfoInstances :: ModuleInfo -> [ClsInst] -modInfoInstances = minf_instances - -modInfoIsExportedName :: ModuleInfo -> Name -> Bool -modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) - -mkPrintUnqualifiedForModule :: GhcMonad m => - ModuleInfo - -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X -mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do - return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) - -modInfoLookupName :: GhcMonad m => - ModuleInfo -> Name - -> m (Maybe TyThing) -- XXX: returns a Maybe X -modInfoLookupName minf name = withSession $ \hsc_env -> do - case lookupTypeEnv (minf_type_env minf) name of - Just tyThing -> return (Just tyThing) - Nothing -> do - eps <- liftIO $ readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_dflags hsc_env) - (hsc_HPT hsc_env) (eps_PTE eps) name - -modInfoIface :: ModuleInfo -> Maybe ModIface -modInfoIface = minf_iface - --- | Retrieve module safe haskell mode -modInfoSafe :: ModuleInfo -> SafeHaskellMode -modInfoSafe = minf_safe - -modInfoModBreaks :: ModuleInfo -> ModBreaks -modInfoModBreaks = minf_modBreaks - -isDictonaryId :: Id -> Bool -isDictonaryId id - = case tcSplitSigmaTy (idType id) of { - (_tvs, _theta, tau) -> isDictTy tau } - --- | Looks up a global name: that is, any top-level name in any --- visible module. Unlike 'lookupName', lookupGlobalName does not use --- the interactive context, and therefore does not require a preceding --- 'setContext'. -lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupGlobalName name = withSession $ \hsc_env -> do - liftIO $ lookupTypeHscEnv hsc_env name - -findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] -findGlobalAnns deserialize target = withSession $ \hsc_env -> do - ann_env <- liftIO $ prepareAnnotations hsc_env Nothing - return (findAnns deserialize ann_env target) - --- | get the GlobalRdrEnv for a session -getGRE :: GhcMonad m => m GlobalRdrEnv -getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) - --- | Retrieve all type and family instances in the environment, indexed --- by 'Name'. Each name's lists will contain every instance in which that name --- is mentioned in the instance head. -getNameToInstancesIndex :: GhcMonad m - => m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))) -getNameToInstancesIndex = do - hsc_env <- getSession - liftIO $ runTcInteractive hsc_env $ - do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) - ; InstEnvs {ie_global, ie_local, ie_visible} <- tcGetInstEnvs - ; (pkg_fie, home_fie) <- tcGetFamInstEnvs - -- We use Data.Sequence.Seq because we are creating left associated - -- mappends. - -- cls_index and fam_index below are adapted from TcRnDriver.lookupInsts - ; let cls_index = Map.fromListWith mappend - [ (n, Seq.singleton ispec) - | ispec <- instEnvElts ie_local ++ instEnvElts ie_global - , instIsVisible ie_visible ispec - , n <- nameSetElemsStable $ orphNamesOfClsInst ispec - ] - ; let fam_index = Map.fromListWith mappend - [ (n, Seq.singleton fispec) - | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie - , n <- nameSetElemsStable $ orphNamesOfFamInst fispec - ] - ; return $ mkNameEnv $ - [ (nm, (toList clss, toList fams)) - | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend - (fmap (,Seq.empty) cls_index) - (fmap (Seq.empty,) fam_index) - ] } - --- ----------------------------------------------------------------------------- - -{- ToDo: Move the primary logic here to compiler/main/Packages.hs --- | Return all /external/ modules available in the package database. --- Modules from the current session (i.e., from the 'HomePackageTable') are --- not included. This includes module names which are reexported by packages. -packageDbModules :: GhcMonad m => - Bool -- ^ Only consider exposed packages. - -> m [Module] -packageDbModules only_exposed = do - dflags <- getSessionDynFlags - let pkgs = eltsUFM (pkgIdMap (pkgState dflags)) - return $ - [ mkModule pid modname - | p <- pkgs - , not only_exposed || exposed p - , let pid = packageConfigId p - , modname <- exposedModules p - ++ map exportName (reexportedModules p) ] - -} - --- ----------------------------------------------------------------------------- --- Misc exported utils - -dataConType :: DataCon -> Type -dataConType dc = idType (dataConWrapId dc) - --- | print a 'NamedThing', adding parentheses if the name is an operator. -pprParenSymName :: NamedThing a => a -> SDoc -pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) - --- ---------------------------------------------------------------------------- - -#if 0 - --- ToDo: --- - Data and Typeable instances for HsSyn. - --- ToDo: check for small transformations that happen to the syntax in --- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) - --- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way --- to get from TyCons, Ids etc. to TH syntax (reify). - --- :browse will use either lm_toplev or inspect lm_interface, depending --- on whether the module is interpreted or not. - -#endif - --- Extract the filename, stringbuffer content and dynflags associed to a module --- --- XXX: Explain pre-conditions -getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags) -getModuleSourceAndFlags mod = do - m <- getModSummary (moduleName mod) - case ml_hs_file $ ms_location m of - Nothing -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod) - Just sourceFile -> do - source <- liftIO $ hGetStringBuffer sourceFile - return (sourceFile, source, ms_hspp_opts m) - - --- | Return module source as token stream, including comments. --- --- The module must be in the module graph and its source must be available. --- Throws a 'HscTypes.SourceError' on parse error. -getTokenStream :: GhcMonad m => Module -> m [Located Token] -getTokenStream mod = do - (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 - case lexTokenStream source startLoc flags of - POk _ ts -> return ts - PFailed span err -> - do dflags <- getDynFlags - liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err) - --- | Give even more information on the source than 'getTokenStream' --- This function allows reconstructing the source completely with --- 'showRichTokenStream'. -getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] -getRichTokenStream mod = do - (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 - case lexTokenStream source startLoc flags of - POk _ ts -> return $ addSourceToTokens startLoc source ts - PFailed span err -> - do dflags <- getDynFlags - liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err) - --- | Given a source location and a StringBuffer corresponding to this --- location, return a rich token stream with the source associated to the --- tokens. -addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] - -> [(Located Token, String)] -addSourceToTokens _ _ [] = [] -addSourceToTokens loc buf (t@(L span _) : ts) - = case span of - UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts - RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts - where - (newLoc, newBuf, str) = go "" loc buf - start = realSrcSpanStart s - end = realSrcSpanEnd s - go acc loc buf | loc < start = go acc nLoc nBuf - | start <= loc && loc < end = go (ch:acc) nLoc nBuf - | otherwise = (loc, buf, reverse acc) - where (ch, nBuf) = nextChar buf - nLoc = advanceSrcLoc loc ch - - --- | Take a rich token stream such as produced from 'getRichTokenStream' and --- return source code almost identical to the original code (except for --- insignificant whitespace.) -showRichTokenStream :: [(Located Token, String)] -> String -showRichTokenStream ts = go startLoc ts "" - where sourceFile = getFile $ map (getLoc . fst) ts - getFile [] = panic "showRichTokenStream: No source file found" - getFile (UnhelpfulSpan _ : xs) = getFile xs - getFile (RealSrcSpan s : _) = srcSpanFile s - startLoc = mkRealSrcLoc sourceFile 1 1 - go _ [] = id - go loc ((L span _, str):ts) - = case span of - UnhelpfulSpan _ -> go loc ts - RealSrcSpan s - | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) - . (str ++) - . go tokEnd ts - | otherwise -> ((replicate (tokLine - locLine) '\n') ++) - . ((replicate (tokCol - 1) ' ') ++) - . (str ++) - . go tokEnd ts - where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) - (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s) - tokEnd = realSrcSpanEnd s - --- ----------------------------------------------------------------------------- --- Interactive evaluation - --- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the --- filesystem and package database to find the corresponding 'Module', --- using the algorithm that is used for an @import@ declaration. -findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -findModule mod_name maybe_pkg = withSession $ \hsc_env -> do - let - dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags - -- - case maybe_pkg of - Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found _ m -> return m - err -> throwOneError $ noModError dflags noSrcSpan mod_name err - _otherwise -> do - home <- lookupLoadedHomeModule mod_name - case home of - Just m -> return m - Nothing -> liftIO $ do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found loc m | moduleUnitId m /= this_pkg -> return m - | otherwise -> modNotLoadedError dflags m loc - err -> throwOneError $ noModError dflags noSrcSpan mod_name err - -modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a -modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ - text "module is not loaded:" <+> - quotes (ppr (moduleName m)) <+> - parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) - --- | Like 'findModule', but differs slightly when the module refers to --- a source file, and the file has not been loaded via 'load'. In --- this case, 'findModule' will throw an error (module not loaded), --- but 'lookupModule' will check to see whether the module can also be --- found in a package, and if so, that package 'Module' will be --- returned. If not, the usual module-not-found error will be thrown. --- -lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) -lookupModule mod_name Nothing = withSession $ \hsc_env -> do - home <- lookupLoadedHomeModule mod_name - case home of - Just m -> return m - Nothing -> liftIO $ do - res <- findExposedPackageModule hsc_env mod_name Nothing - case res of - Found _ m -> return m - err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err - -lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) -lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> - case lookupHpt (hsc_HPT hsc_env) mod_name of - Just mod_info -> return (Just (mi_module (hm_iface mod_info))) - _not_a_home_module -> return Nothing - --- | Check that a module is safe to import (according to Safe Haskell). --- --- We return True to indicate the import is safe and False otherwise --- although in the False case an error may be thrown first. -isModuleTrusted :: GhcMonad m => Module -> m Bool -isModuleTrusted m = withSession $ \hsc_env -> - liftIO $ hscCheckSafe hsc_env m noSrcSpan - --- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId) -moduleTrustReqs m = withSession $ \hsc_env -> - liftIO $ hscGetSafe hsc_env m noSrcSpan - --- | Set the monad GHCi lifts user statements into. --- --- Checks that a type (in string form) is an instance of the --- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is, --- throws an error otherwise. -setGHCiMonad :: GhcMonad m => String -> m () -setGHCiMonad name = withSession $ \hsc_env -> do - ty <- liftIO $ hscIsGHCiMonad hsc_env name - modifySession $ \s -> - let ic = (hsc_IC s) { ic_monad = ty } - in s { hsc_IC = ic } - --- | Get the monad GHCi lifts user statements into. -getGHCiMonad :: GhcMonad m => m Name -getGHCiMonad = fmap (ic_monad . hsc_IC) getSession - -getHistorySpan :: GhcMonad m => History -> m SrcSpan -getHistorySpan h = withSession $ \hsc_env -> - return $ InteractiveEval.getHistorySpan hsc_env h - -obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term -obtainTermFromVal bound force ty a = withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a - -obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term -obtainTermFromId bound force id = withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id - - --- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any --- entity known to GHC, including 'Name's defined using 'runStmt'. -lookupName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupName name = - withSession $ \hsc_env -> - liftIO $ hscTcRcLookupName hsc_env name - --- ----------------------------------------------------------------------------- --- Pure API - --- | A pure interface to the module parser. --- -parser :: String -- ^ Haskell module source text (full Unicode is supported) - -> DynFlags -- ^ the flags - -> FilePath -- ^ the filename (for source locations) - -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) - -parser str dflags filename = - let - loc = mkRealSrcLoc (mkFastString filename) 1 1 - buf = stringToStringBuffer str - in - case unP Parser.parseModule (mkPState dflags buf loc) of - - PFailed span err -> - Left (unitBag (mkPlainErrMsg dflags span err)) - - POk pst rdr_module -> - let (warns,_) = getMessages pst dflags in - Right (warns, rdr_module) diff --git a/main/GhcMake.hs b/main/GhcMake.hs deleted file mode 100644 --- a/main/GhcMake.hs +++ /dev/null @@ -1,2304 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} --- NB: we specifically ignore deprecations. GHC 7.6 marks the .QSem module as --- deprecated, although it became un-deprecated later. As a result, using 7.6 --- as your bootstrap compiler throws annoying warnings. - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2011 --- --- This module implements multi-module compilation, and is used --- by --make and GHCi. --- --- ----------------------------------------------------------------------------- -module GhcMake( - depanal, - load, load', LoadHowMuch(..), - - topSortModuleGraph, - - ms_home_srcimps, ms_home_imps, - - IsBoot(..), - summariseModule, - hscSourceToIsBoot, - findExtraSigImports, - implicitRequirements, - - noModError, cyclicModuleErr, - moduleGraphNodes, SummaryNode - ) where - -#include "HsVersions.h" - -import qualified Linker ( unload ) - -import DriverPhases -import DriverPipeline -import DynFlags -import ErrUtils -import Finder -import GhcMonad -import HeaderInfo -import HscTypes -import Module -import TcIface ( typecheckIface ) -import TcRnMonad ( initIfaceCheck ) -import HscMain - -import Bag ( listToBag ) -import BasicTypes -import Digraph -import Exception ( tryIO, gbracket, gfinally ) -import FastString -import Maybes ( expectJust ) -import Name -import MonadUtils ( allM, MonadIO ) -import Outputable -import Panic -import SrcLoc -import StringBuffer -import SysTools -import UniqFM -import UniqDSet -import TcBackpack -import Packages -import UniqSet -import Util -import qualified GHC.LanguageExtensions as LangExt -import NameEnv - -import Data.Either ( rights, partitionEithers ) -import qualified Data.Map as Map -import Data.Map (Map) -import qualified Data.Set as Set -import qualified FiniteMap as Map ( insertListWith ) - -import Control.Concurrent ( forkIOWithUnmask, killThread ) -import qualified GHC.Conc as CC -import Control.Concurrent.MVar -import Control.Concurrent.QSem -import Control.Exception -import Control.Monad -import Data.IORef -import Data.List -import qualified Data.List as List -import Data.Maybe -import Data.Ord ( comparing ) -import Data.Time -import System.Directory -import System.FilePath -import System.IO ( fixIO ) -import System.IO.Error ( isDoesNotExistError ) - -import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) - -label_self :: String -> IO () -label_self thread_name = do - self_tid <- CC.myThreadId - CC.labelThread self_tid thread_name - --- ----------------------------------------------------------------------------- --- Loading the program - --- | Perform a dependency analysis starting from the current targets --- and update the session with the new module graph. --- --- Dependency analysis entails parsing the @import@ directives and may --- therefore require running certain preprocessors. --- --- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. --- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the --- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want --- changes to the 'DynFlags' to take effect you need to call this function --- again. --- -depanal :: GhcMonad m => - [ModuleName] -- ^ excluded modules - -> Bool -- ^ allow duplicate roots - -> m ModuleGraph -depanal excluded_mods allow_dup_roots = do - hsc_env <- getSession - let - dflags = hsc_dflags hsc_env - targets = hsc_targets hsc_env - old_graph = hsc_mod_graph hsc_env - - withTiming (pure dflags) (text "Chasing dependencies") (const ()) $ do - liftIO $ debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) - - mod_graphE <- liftIO $ downsweep hsc_env old_graph - excluded_mods allow_dup_roots - mod_graph <- reportImportErrors mod_graphE - - warnMissingHomeModules hsc_env mod_graph - - setSession hsc_env { hsc_mod_graph = mod_graph } - return mod_graph - --- Note [Missing home modules] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Sometimes user doesn't want GHC to pick up modules, not explicitly listed --- in a command line. For example, cabal may want to enable this warning --- when building a library, so that GHC warns user about modules, not listed --- neither in `exposed-modules`, nor in `other-modules`. --- --- Here "home module" means a module, that doesn't come from an other package. --- --- For example, if GHC is invoked with modules "A" and "B" as targets, --- but "A" imports some other module "C", then GHC will issue a warning --- about module "C" not being listed in a command line. --- --- The warning in enabled by `-Wmissing-home-modules`. See Trac #13129 -warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m () -warnMissingHomeModules hsc_env mod_graph = - when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $ - logWarnings (listToBag [warn]) - where - dflags = hsc_dflags hsc_env - targets = map targetId (hsc_targets hsc_env) - - is_known_module mod = any (is_my_target mod) targets - - -- We need to be careful to handle the case where (possibly - -- path-qualified) filenames (aka 'TargetFile') rather than module - -- names are being passed on the GHC command-line. - -- - -- For instance, `ghc --make src-exe/Main.hs` and - -- `ghc --make -isrc-exe Main` are supposed to be equivalent. - -- Note also that we can't always infer the associated module name - -- directly from the filename argument. See Trac #13727. - is_my_target mod (TargetModule name) - = moduleName (ms_mod mod) == name - is_my_target mod (TargetFile target_file _) - | Just mod_file <- ml_hs_file (ms_location mod) - = target_file == mod_file || - -- We can get a file target even if a module name was - -- originally specified in a command line because it can - -- be converted in guessTarget (by appending .hs/.lhs). - -- So let's convert it back and compare with module name - mkModuleName (fst $ splitExtension target_file) - == moduleName (ms_mod mod) - is_my_target _ _ = False - - missing = map (moduleName . ms_mod) $ - filter (not . is_known_module) mod_graph - - msg - | gopt Opt_BuildingCabalPackage dflags - = text "These modules are needed for compilation but not listed in your .cabal file's other-modules: " - <> sep (map ppr missing) - | otherwise - = text "Modules are not listed in command line but needed for compilation: " - <> sep (map ppr missing) - warn = makeIntoWarning - (Reason Opt_WarnMissingHomeModules) - (mkPlainErrMsg dflags noSrcSpan msg) - --- | Describes which modules of the module graph need to be loaded. -data LoadHowMuch - = LoadAllTargets - -- ^ Load all targets and its dependencies. - | LoadUpTo ModuleName - -- ^ Load only the given module and its dependencies. - | LoadDependenciesOf ModuleName - -- ^ Load only the dependencies of the given module, but not the module - -- itself. - --- | Try to load the program. See 'LoadHowMuch' for the different modes. --- --- This function implements the core of GHC's @--make@ mode. It preprocesses, --- compiles and loads the specified modules, avoiding re-compilation wherever --- possible. Depending on the target (see 'DynFlags.hscTarget') compiling --- and loading may result in files being created on disk. --- --- Calls the 'defaultWarnErrLogger' after each compiling each module, whether --- successful or not. --- --- Throw a 'SourceError' if errors are encountered before the actual --- compilation starts (e.g., during dependency analysis). All other errors --- are reported using the 'defaultWarnErrLogger'. --- -load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = do - mod_graph <- depanal [] False - load' how_much (Just batchMsg) mod_graph - --- | Generalized version of 'load' which also supports a custom --- 'Messager' (for reporting progress) and 'ModuleGraph' (generally --- produced by calling 'depanal'. -load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag -load' how_much mHscMessage mod_graph = do - modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } - guessOutputFile - hsc_env <- getSession - - let hpt1 = hsc_HPT hsc_env - let dflags = hsc_dflags hsc_env - - -- The "bad" boot modules are the ones for which we have - -- B.hs-boot in the module graph, but no B.hs - -- The downsweep should have ensured this does not happen - -- (see msDeps) - let all_home_mods = [ms_mod_name s - | s <- mod_graph, not (isBootSummary s)] - -- TODO: Figure out what the correct form of this assert is. It's violated - -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot - -- files without corresponding hs files. - -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s, - -- not (ms_mod_name s `elem` all_home_mods)] - -- ASSERT( null bad_boot_mods ) return () - - -- check that the module given in HowMuch actually exists, otherwise - -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m - checkHowMuch _ = id - - checkMod m and_then - | m `elem` all_home_mods = and_then - | otherwise = do - liftIO $ errorMsg dflags (text "no such module:" <+> - quotes (ppr m)) - return Failed - - checkHowMuch how_much $ do - - -- mg2_with_srcimps drops the hi-boot nodes, returning a - -- graph with cycles. Among other things, it is used for - -- backing out partially complete cycles following a failed - -- upsweep, and for removing from hpt all the modules - -- not in strict downwards closure, during calls to compile. - let mg2_with_srcimps :: [SCC ModSummary] - mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing - - -- If we can determine that any of the {-# SOURCE #-} imports - -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports mg2_with_srcimps - - let - -- check the stability property for each module. - stable_mods@(stable_obj,stable_bco) - = checkStability hpt1 mg2_with_srcimps all_home_mods - - -- prune bits of the HPT which are definitely redundant now, - -- to save space. - pruned_hpt = pruneHomePackageTable hpt1 - (flattenSCCs mg2_with_srcimps) - stable_mods - - _ <- liftIO $ evaluate pruned_hpt - - -- before we unload anything, make sure we don't leave an old - -- interactive context around pointing to dead bindings. Also, - -- write the pruned HPT to allow the old HPT to be GC'd. - setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt } - - liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ - text "Stable BCO:" <+> ppr stable_bco) - - -- Unload any modules which are going to be re-linked this time around. - let stable_linkables = [ linkable - | m <- stable_obj++stable_bco, - Just hmi <- [lookupHpt pruned_hpt m], - Just linkable <- [hm_linkable hmi] ] - liftIO $ unload hsc_env stable_linkables - - -- We could at this point detect cycles which aren't broken by - -- a source-import, and complain immediately, but it seems better - -- to let upsweep_mods do this, so at least some useful work gets - -- done before the upsweep is abandoned. - --hPutStrLn stderr "after tsort:\n" - --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) - - -- Now do the upsweep, calling compile for each module in - -- turn. Final result is version 3 of everything. - - -- Topologically sort the module graph, this time including hi-boot - -- nodes, and possibly just including the portion of the graph - -- reachable from the module specified in the 2nd argument to load. - -- This graph should be cycle-free. - -- If we're restricting the upsweep to a portion of the graph, we - -- also want to retain everything that is still stable. - let full_mg :: [SCC ModSummary] - full_mg = topSortModuleGraph False mod_graph Nothing - - maybe_top_mod = case how_much of - LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m - _ -> Nothing - - partial_mg0 :: [SCC ModSummary] - partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod - - -- LoadDependenciesOf m: we want the upsweep to stop just - -- short of the specified module (unless the specified module - -- is stable). - partial_mg - | LoadDependenciesOf _mod <- how_much - = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) - List.init partial_mg0 - | otherwise - = partial_mg0 - - stable_mg = - [ AcyclicSCC ms - | AcyclicSCC ms <- full_mg, - ms_mod_name ms `elem` stable_obj++stable_bco ] - - -- the modules from partial_mg that are not also stable - -- NB. also keep cycles, we need to emit an error message later - unstable_mg = filter not_stable partial_mg - where not_stable (CyclicSCC _) = True - not_stable (AcyclicSCC ms) - = ms_mod_name ms `notElem` stable_obj++stable_bco - - -- Load all the stable modules first, before attempting to load - -- an unstable module (#7231). - mg = stable_mg ++ unstable_mg - - -- clean up between compilations - let cleanup hsc_env = intermediateCleanTempFiles (hsc_dflags hsc_env) - (flattenSCCs mg2_with_srcimps) - hsc_env - - liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") - 2 (ppr mg)) - - n_jobs <- case parMakeCount dflags of - Nothing -> liftIO getNumProcessors - Just n -> return n - let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs - | otherwise = upsweep - - setSession hsc_env{ hsc_HPT = emptyHomePackageTable } - (upsweep_ok, modsUpswept) - <- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg - - -- Make modsDone be the summaries for each home module now - -- available; this should equal the domain of hpt3. - -- Get in in a roughly top .. bottom order (hence reverse). - - let modsDone = reverse modsUpswept - - -- Try and do linking in some form, depending on whether the - -- upsweep was completely or only partially successful. - - if succeeded upsweep_ok - - then - -- Easy; just relink it all. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") - - -- Clean up after ourselves - hsc_env1 <- getSession - liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 - - -- Issue a warning for the confusing case where the user - -- said '-o foo' but we're not going to do any linking. - -- We attempt linking if either (a) one of the modules is - -- called Main, or (b) the user said -no-hs-main, indicating - -- that main() is going to come from somewhere else. - -- - let ofile = outputFile dflags - let no_hs_main = gopt Opt_NoHsMain dflags - let - main_mod = mainModIs dflags - a_root_is_Main = any ((==main_mod).ms_mod) mod_graph - do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib - - -- link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - - if ghcLink dflags == LinkBinary && isJust ofile && not do_linking - then do - liftIO $ errorMsg dflags $ text - ("output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ - moduleNameString (moduleName main_mod) ++ " module.") - -- This should be an error, not a warning (#10895). - loadFinish Failed linkresult - else - loadFinish Succeeded linkresult - - else - -- Tricky. We need to back out the effects of compiling any - -- half-done cycles, both so as to clean up the top level envs - -- and to avoid telling the interactive linker to link them. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") - - let modsDone_names - = map ms_mod modsDone - let mods_to_zap_names - = findPartiallyCompletedCycles modsDone_names - mg2_with_srcimps - let mods_to_keep - = filter ((`Set.notMember` mods_to_zap_names).ms_mod) - modsDone - - hsc_env1 <- getSession - let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) - (hsc_HPT hsc_env1) - - -- Clean up after ourselves - liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 - - -- 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) - hpt4) - ASSERT( just_linkables ) do - - -- Link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 - - modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } - loadFinish Failed linkresult - - --- | Finish up after a load. -loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag - --- If the link failed, unload everything and return. -loadFinish _all_ok Failed - = do hsc_env <- getSession - liftIO $ unload hsc_env [] - modifySession discardProg - return Failed - --- Empty the interactive context and set the module context to the topmost --- newly loaded module, or the Prelude if none were loaded. -loadFinish all_ok Succeeded - = do modifySession discardIC - return all_ok - - --- | Forget the current program, but retain the persistent info in HscEnv -discardProg :: HscEnv -> HscEnv -discardProg hsc_env - = discardIC $ hsc_env { hsc_mod_graph = emptyMG - , hsc_HPT = emptyHomePackageTable } - --- | Discard the contents of the InteractiveContext, but keep the DynFlags. --- It will also keep ic_int_print and ic_monad if their names are from --- external packages. -discardIC :: HscEnv -> HscEnv -discardIC hsc_env - = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print - , ic_monad = new_ic_monad } } - where - -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic - !new_ic_int_print = keep_external_name ic_int_print - !new_ic_monad = keep_external_name ic_monad - dflags = ic_dflags old_ic - old_ic = hsc_IC hsc_env - empty_ic = emptyInteractiveContext dflags - keep_external_name ic_name - | nameIsFromExternalPackage this_pkg old_name = old_name - | otherwise = ic_name empty_ic - where - this_pkg = thisPackage dflags - old_name = ic_name old_ic - -intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () -intermediateCleanTempFiles dflags summaries hsc_env - = do notIntermediate <- readIORef (filesToNotIntermediateClean dflags) - cleanTempFilesExcept dflags (notIntermediate ++ except) - where - except = - -- Save preprocessed files. The preprocessed file *might* be - -- the same as the source file, but that doesn't do any - -- harm. - map ms_hspp_file summaries ++ - -- Save object files for loaded modules. The point of this - -- is that we might have generated and compiled a stub C - -- file, and in the case of GHCi the object file will be a - -- temporary file which we must not remove because we need - -- to load/link it later. - hptObjs (hsc_HPT hsc_env) - --- | 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 - let isMain = (== mainModIs dflags) . ms_mod - [ms] <- return (filter isMain mod_graph) - ml_hs_file (ms_location ms) - name = fmap dropExtension mainModuleSrcPath - - name_exe = do -#if defined(mingw32_HOST_OS) - -- we must add the .exe extension unconditionally here, otherwise - -- when name has an extension of its own, the .exe extension will - -- not be added by DriverPipeline.exeFileName. See #2248 - name' <- fmap (<.> "exe") name -#else - name' <- name -#endif - mainModuleSrcPath' <- mainModuleSrcPath - -- #9930: don't clobber input files (unless they ask for it) - if name' == mainModuleSrcPath' - then throwGhcException . UsageError $ - "default output name would overwrite the input file; " ++ - "must specify -o explicitly" - else Just name' - in - case outputFile dflags of - Just _ -> env - Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } - --- ----------------------------------------------------------------------------- --- --- | Prune the HomePackageTable --- --- Before doing an upsweep, we can throw away: --- --- - For non-stable modules: --- - all ModDetails, all linked code --- - all unlinked code that is out of date with respect to --- the source file --- --- This is VERY IMPORTANT otherwise we'll end up requiring 2x the --- space at the end of the upsweep, because the topmost ModDetails of the --- old HPT holds on to the entire type environment from the previous --- compilation. -pruneHomePackageTable :: HomePackageTable - -> [ModSummary] - -> ([ModuleName],[ModuleName]) - -> HomePackageTable -pruneHomePackageTable hpt summ (stable_obj, stable_bco) - = mapHpt prune hpt - where prune hmi - | is_stable modl = hmi' - | otherwise = hmi'{ hm_details = emptyModDetails } - where - modl = moduleName (mi_module (hm_iface hmi)) - hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms - = hmi{ hm_linkable = Nothing } - | otherwise - = hmi - where ms = expectJust "prune" (lookupUFM ms_map modl) - - ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] - - is_stable m = m `elem` stable_obj || m `elem` stable_bco - --- ----------------------------------------------------------------------------- --- --- | Return (names of) all those in modsDone who are part of a cycle as defined --- by theGraph. -findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module -findPartiallyCompletedCycles modsDone theGraph - = Set.unions - [mods_in_this_cycle - | CyclicSCC vs <- theGraph -- Acyclic? Not interesting. - , let names_in_this_cycle = Set.fromList (map ms_mod vs) - mods_in_this_cycle = - Set.intersection (Set.fromList modsDone) names_in_this_cycle - -- If size mods_in_this_cycle == size names_in_this_cycle, - -- then this cycle has already been completed and we're not - -- interested. - , Set.size mods_in_this_cycle < Set.size names_in_this_cycle] - - --- --------------------------------------------------------------------------- --- --- | Unloading -unload :: HscEnv -> [Linkable] -> IO () -unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - = case ghcLink (hsc_dflags hsc_env) of - LinkInMemory -> Linker.unload hsc_env stable_linkables - _other -> return () - --- ----------------------------------------------------------------------------- -{- | - - Stability tells us which modules definitely do not need to be recompiled. - There are two main reasons for having stability: - - - avoid doing a complete upsweep of the module graph in GHCi when - modules near the bottom of the tree have not changed. - - - to tell GHCi when it can load object code: we can only load object code - for a module when we also load object code fo all of the imports of the - module. So we need to know that we will definitely not be recompiling - any of these modules, and we can use the object code. - - The stability check is as follows. Both stableObject and - stableBCO are used during the upsweep phase later. - -@ - stable m = stableObject m || stableBCO m - - stableObject m = - all stableObject (imports m) - && old linkable does not exist, or is == on-disk .o - && date(on-disk .o) > date(.hs) - - stableBCO m = - all stable (imports m) - && date(BCO) > date(.hs) -@ - - These properties embody the following ideas: - - - if a module is stable, then: - - - if it has been compiled in a previous pass (present in HPT) - then it does not need to be compiled or re-linked. - - - if it has not been compiled in a previous pass, - then we only need to read its .hi file from disk and - link it to produce a 'ModDetails'. - - - if a modules is not stable, we will definitely be at least - re-linking, and possibly re-compiling it during the 'upsweep'. - All non-stable modules can (and should) therefore be unlinked - before the 'upsweep'. - - - Note that objects are only considered stable if they only depend - on other objects. We can't link object code against byte code. - - - Note that even if an object is stable, we may end up recompiling - if the interface is out of date because an *external* interface - has changed. The current code in GhcMake handles this case - fairly poorly, so be careful. --} -checkStability - :: HomePackageTable -- HPT from last compilation - -> [SCC ModSummary] -- current module graph (cyclic) - -> [ModuleName] -- all home modules - -> ([ModuleName], -- stableObject - [ModuleName]) -- stableBCO - -checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs - where - checkSCC (stable_obj, stable_bco) scc0 - | stableObjects = (scc_mods ++ stable_obj, stable_bco) - | stableBCOs = (stable_obj, scc_mods ++ stable_bco) - | otherwise = (stable_obj, stable_bco) - where - scc = flattenSCC scc0 - scc_mods = map ms_mod_name scc - home_module m = m `elem` 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 (`elem` stable_obj) scc_allimps - stable_bco_imps = map (`elem` stable_bco) scc_allimps - - stableObjects = - and stable_obj_imps - && all object_ok scc - - stableBCOs = - and (zipWith (||) stable_obj_imps stable_bco_imps) - && all bco_ok scc - - object_ok ms - | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False - | Just t <- ms_obj_date ms = t >= ms_hs_date ms - && same_as_prev t - | otherwise = False - where - same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi - -> isObjectLinkable l && t == linkableTime l - _other -> True - -- why '>=' rather than '>' above? If the filesystem stores - -- times to the nearset second, we may occasionally find that - -- the object & source have the same modification time, - -- especially if the source was automatically generated - -- and compiled. Using >= is slightly unsafe, but it matches - -- make's behaviour. - -- - -- But see #5527, where someone ran into this and it caused - -- a problem. - - bco_ok ms - | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False - | otherwise = case lookupHpt hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi -> - not (isObjectLinkable l) && - linkableTime l >= ms_hs_date ms - _other -> False - -{- Parallel Upsweep - - - - The parallel upsweep attempts to concurrently compile the modules in the - - compilation graph using multiple Haskell threads. - - - - The Algorithm - - - - A Haskell thread is spawned for each module in the module graph, waiting for - - its direct dependencies to finish building before it itself begins to build. - - - - Each module is associated with an initially empty MVar that stores the - - result of that particular module's compile. If the compile succeeded, then - - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that - - module, and the module's HMI is deleted from the old HPT (synchronized by an - - IORef) to save space. - - - - Instead of immediately outputting messages to the standard handles, all - - compilation output is deferred to a per-module TQueue. A QSem is used to - - limit the number of workers that are compiling simultaneously. - - - - Meanwhile, the main thread sequentially loops over all the modules in the - - module graph, outputting the messages stored in each module's TQueue. --} - --- | Each module is given a unique 'LogQueue' to redirect compilation messages --- to. A 'Nothing' value contains the result of compilation, and denotes the --- end of the message queue. -data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)]) - !(MVar ()) - --- | The graph of modules to compile and their corresponding result 'MVar' and --- 'LogQueue'. -type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)] - --- | Build a 'CompilationGraph' out of a list of strongly-connected modules, --- also returning the first, if any, encountered module cycle. -buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary]) -buildCompGraph [] = return ([], Nothing) -buildCompGraph (scc:sccs) = case scc of - AcyclicSCC ms -> do - mvar <- newEmptyMVar - log_queue <- do - ref <- newIORef [] - sem <- newEmptyMVar - return (LogQueue ref sem) - (rest,cycle) <- buildCompGraph sccs - return ((ms,mvar,log_queue):rest, cycle) - CyclicSCC mss -> return ([], Just mss) - --- A Module and whether it is a boot module. -type BuildModule = (Module, IsBoot) - --- | 'Bool' indicating if a module is a boot module or not. We need to treat --- boot modules specially when building compilation graphs, since they break --- cycles. Regular source files and signature files are treated equivalently. -data IsBoot = IsBoot | NotBoot - deriving (Ord, Eq, Show, Read) - --- | Tests if an 'HscSource' is a boot file, primarily for constructing --- elements of 'BuildModule'. -hscSourceToIsBoot :: HscSource -> IsBoot -hscSourceToIsBoot HsBootFile = IsBoot -hscSourceToIsBoot _ = NotBoot - -mkBuildModule :: ModSummary -> BuildModule -mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot) - --- | The entry point to the parallel upsweep. --- --- See also the simpler, sequential 'upsweep'. -parUpsweep - :: GhcMonad m - => Int - -- ^ The number of workers we wish to run in parallel - -> Maybe Messager - -> HomePackageTable - -> ([ModuleName],[ModuleName]) - -> (HscEnv -> IO ()) - -> [SCC ModSummary] - -> m (SuccessFlag, - [ModSummary]) -parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - - when (not (null (unitIdsToCheck dflags))) $ - throwGhcException (ProgramError "Backpack typechecking not supported with -j") - - -- The bits of shared state we'll be using: - - -- The global HscEnv is updated with the module's HMI when a module - -- successfully compiles. - hsc_env_var <- liftIO $ newMVar hsc_env - - -- The old HPT is used for recompilation checking in upsweep_mod. When a - -- module successfully gets compiled, its HMI is pruned from the old HPT. - old_hpt_var <- liftIO $ newIORef old_hpt - - -- What we use to limit parallelism with. - par_sem <- liftIO $ newQSem n_jobs - - - let updNumCapabilities = liftIO $ do - n_capabilities <- getNumCapabilities - n_cpus <- getNumProcessors - -- Setting number of capabilities more than - -- CPU count usually leads to high userspace - -- lock contention. Trac #9221 - let n_caps = min n_jobs n_cpus - unless (n_capabilities /= 1) $ setNumCapabilities n_caps - return n_capabilities - -- Reset the number of capabilities once the upsweep ends. - let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n - - gbracket updNumCapabilities resetNumCapabilities $ \_ -> do - - -- Sync the global session with the latest HscEnv once the upsweep ends. - let finallySyncSession io = io `gfinally` do - hsc_env <- liftIO $ readMVar hsc_env_var - setSession hsc_env - - finallySyncSession $ do - - -- Build the compilation graph out of the list of SCCs. Module cycles are - -- handled at the very end, after some useful work gets done. Note that - -- this list is topologically sorted (by virtue of 'sccs' being sorted so). - (comp_graph,cycle) <- liftIO $ buildCompGraph sccs - let comp_graph_w_idx = zip comp_graph [1..] - - -- The list of all loops in the compilation graph. - -- NB: For convenience, the last module of each loop (aka the module that - -- finishes the loop) is prepended to the beginning of the loop. - let comp_graph_loops = go (map fstOf3 (reverse comp_graph)) - where - go [] = [] - go (ms:mss) | Just loop <- getModLoop ms (ms:mss) - = map mkBuildModule (ms:loop) : go mss - | otherwise - = go mss - - -- Build a Map out of the compilation graph with which we can efficiently - -- look up the result MVar associated with a particular home module. - let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int) - home_mod_map = - Map.fromList [ (mkBuildModule ms, (mvar, idx)) - | ((ms,mvar,_),idx) <- comp_graph_w_idx ] - - - liftIO $ label_self "main --make thread" - -- For each module in the module graph, spawn a worker thread that will - -- compile this module. - let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) -> - forkIOWithUnmask $ \unmask -> do - liftIO $ label_self $ unwords - [ "worker --make thread" - , "for module" - , show (moduleNameString (ms_mod_name mod)) - , "number" - , show mod_idx - ] - -- Replace the default log_action with one that writes each - -- message to the module's log_queue. The main thread will - -- deal with synchronously printing these messages. - -- - -- Use a local filesToClean var so that we can clean up - -- intermediate files in a timely fashion (as soon as - -- compilation for that module is finished) without having to - -- worry about accidentally deleting a simultaneous compile's - -- important files. - lcl_files_to_clean <- newIORef [] - let lcl_dflags = dflags { log_action = parLogAction log_queue - , filesToClean = lcl_files_to_clean } - - -- Unmask asynchronous exceptions and perform the thread-local - -- work to compile the module (see parUpsweep_one). - m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $ - parUpsweep_one mod home_mod_map comp_graph_loops - lcl_dflags mHscMessage cleanup - par_sem hsc_env_var old_hpt_var - stable_mods mod_idx (length sccs) - - res <- case m_res of - Right flag -> return flag - Left exc -> do - -- Don't print ThreadKilled exceptions: they are used - -- to kill the worker thread in the event of a user - -- interrupt, and the user doesn't have to be informed - -- about that. - when (fromException exc /= Just ThreadKilled) - (errorMsg lcl_dflags (text (show exc))) - return Failed - - -- Populate the result MVar. - putMVar mvar res - - -- Write the end marker to the message queue, telling the main - -- thread that it can stop waiting for messages from this - -- particular compile. - writeLogQueue log_queue Nothing - - -- Add the remaining files that weren't cleaned up to the - -- global filesToClean ref, for cleanup later. - files_kept <- readIORef (filesToClean lcl_dflags) - addFilesToClean dflags files_kept - - - -- Kill all the workers, masking interrupts (since killThread is - -- interruptible). XXX: This is not ideal. - ; killWorkers = uninterruptibleMask_ . mapM_ killThread } - - - -- Spawn the workers, making sure to kill them later. Collect the results - -- of each compile. - results <- liftIO $ bracket spawnWorkers killWorkers $ \_ -> - -- Loop over each module in the compilation graph in order, printing - -- each message from its log_queue. - forM comp_graph $ \(mod,mvar,log_queue) -> do - printLogs dflags log_queue - result <- readMVar mvar - if succeeded result then return (Just mod) else return Nothing - - - -- Collect and return the ModSummaries of all the successful compiles. - -- NB: Reverse this list to maintain output parity with the sequential upsweep. - let ok_results = reverse (catMaybes results) - - -- Handle any cycle in the original compilation graph and return the result - -- of the upsweep. - case cycle of - Just mss -> do - liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss) - return (Failed,ok_results) - Nothing -> do - let success_flag = successIf (all isJust results) - return (success_flag,ok_results) - - where - writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO () - writeLogQueue (LogQueue ref sem) msg = do - atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) - _ <- tryPutMVar sem () - return () - - -- The log_action callback that is used to synchronize messages from a - -- worker thread. - parLogAction :: LogQueue -> LogAction - parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do - writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg)) - - -- Print each message from the log_queue using the log_action from the - -- session's DynFlags. - printLogs :: DynFlags -> LogQueue -> IO () - printLogs !dflags (LogQueue ref sem) = read_msgs - where read_msgs = do - takeMVar sem - msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs) - print_loop msgs - - print_loop [] = read_msgs - print_loop (x:xs) = case x of - Just (reason,severity,srcSpan,style,msg) -> do - putLogMsg dflags reason severity srcSpan style msg - print_loop xs - -- Exit the loop once we encounter the end marker. - Nothing -> return () - --- The interruptible subset of the worker threads' work. -parUpsweep_one - :: ModSummary - -- ^ The module we wish to compile - -> Map BuildModule (MVar SuccessFlag, Int) - -- ^ The map of home modules and their result MVar - -> [[BuildModule]] - -- ^ The list of all module loops within the compilation graph. - -> DynFlags - -- ^ The thread-local DynFlags - -> Maybe Messager - -- ^ The messager - -> (HscEnv -> IO ()) - -- ^ The callback for cleaning up intermediate files - -> QSem - -- ^ The semaphore for limiting the number of simultaneous compiles - -> MVar HscEnv - -- ^ The MVar that synchronizes updates to the global HscEnv - -> IORef HomePackageTable - -- ^ The old HPT - -> ([ModuleName],[ModuleName]) - -- ^ Lists of stable objects and BCOs - -> Int - -- ^ The index of this module - -> Int - -- ^ The total number of modules - -> IO SuccessFlag - -- ^ The result of this compile -parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem - hsc_env_var old_hpt_var stable_mods mod_index num_mods = do - - let this_build_mod = mkBuildModule mod - - let home_imps = map unLoc $ ms_home_imps mod - let home_src_imps = map unLoc $ ms_home_srcimps mod - - -- All the textual imports of this module. - let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $ - zip home_imps (repeat NotBoot) ++ - zip home_src_imps (repeat IsBoot) - - -- Dealing with module loops - -- ~~~~~~~~~~~~~~~~~~~~~~~~~ - -- - -- Not only do we have to deal with explicit textual dependencies, we also - -- have to deal with implicit dependencies introduced by import cycles that - -- are broken by an hs-boot file. We have to ensure that: - -- - -- 1. A module that breaks a loop must depend on all the modules in the - -- loop (transitively or otherwise). This is normally always fulfilled - -- by the module's textual dependencies except in degenerate loops, - -- e.g.: - -- - -- A.hs imports B.hs-boot - -- B.hs doesn't import A.hs - -- C.hs imports A.hs, B.hs - -- - -- In this scenario, getModLoop will detect the module loop [A,B] but - -- the loop finisher B doesn't depend on A. So we have to explicitly add - -- A in as a dependency of B when we are compiling B. - -- - -- 2. A module that depends on a module in an external loop can't proceed - -- until the entire loop is re-typechecked. - -- - -- These two invariants have to be maintained to correctly build a - -- compilation graph with one or more loops. - - - -- The loop that this module will finish. After this module successfully - -- compiles, this loop is going to get re-typechecked. - let finish_loop = listToMaybe - [ tail loop | loop <- comp_graph_loops - , head loop == this_build_mod ] - - -- If this module finishes a loop then it must depend on all the other - -- modules in that loop because the entire module loop is going to be - -- re-typechecked once this module gets compiled. These extra dependencies - -- are this module's "internal" loop dependencies, because this module is - -- inside the loop in question. - let int_loop_deps = Set.fromList $ - case finish_loop of - Nothing -> [] - Just loop -> filter (/= this_build_mod) loop - - -- If this module depends on a module within a loop then it must wait for - -- that loop to get re-typechecked, i.e. it must wait on the module that - -- finishes that loop. These extra dependencies are this module's - -- "external" loop dependencies, because this module is outside of the - -- loop(s) in question. - let ext_loop_deps = Set.fromList - [ head loop | loop <- comp_graph_loops - , any (`Set.member` textual_deps) loop - , this_build_mod `notElem` loop ] - - - let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps] - - -- All of the module's home-module dependencies. - let home_deps_with_idx = - [ home_dep | dep <- Set.toList all_deps - , Just home_dep <- [Map.lookup dep home_mod_map] ] - - -- Sort the list of dependencies in reverse-topological order. This way, by - -- the time we get woken up by the result of an earlier dependency, - -- subsequent dependencies are more likely to have finished. This step - -- effectively reduces the number of MVars that each thread blocks on. - let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx - - -- Wait for the all the module's dependencies to finish building. - deps_ok <- allM (fmap succeeded . readMVar) home_deps - - -- We can't build this module if any of its dependencies failed to build. - if not deps_ok - then return Failed - else do - -- Any hsc_env at this point is OK to use since we only really require - -- that the HPT contains the HMIs of our dependencies. - hsc_env <- readMVar hsc_env_var - old_hpt <- readIORef old_hpt_var - - let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err) - - -- Limit the number of parallel compiles. - let withSem sem = bracket_ (waitQSem sem) (signalQSem sem) - mb_mod_info <- withSem par_sem $ - handleSourceError (\err -> do logger err; return Nothing) $ do - -- Have the ModSummary and HscEnv point to our local log_action - -- and filesToClean var. - let lcl_mod = localize_mod mod - let lcl_hsc_env = localize_hsc_env hsc_env - - -- Re-typecheck the loop - -- This is necessary to make sure the knot is tied when - -- we close a recursive module loop, see bug #12035. - type_env_var <- liftIO $ newIORef emptyNameEnv - let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var = - Just (ms_mod lcl_mod, type_env_var) } - lcl_hsc_env'' <- case finish_loop of - Nothing -> return lcl_hsc_env' - -- In the non-parallel case, the retypecheck prior to - -- typechecking the loop closer includes all modules - -- EXCEPT the loop closer. However, our precomputed - -- SCCs include the loop closer, so we have to filter - -- it out. - Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $ - filter (/= moduleName (fst this_build_mod)) $ - map (moduleName . fst) loop - - -- Compile the module. - mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods - lcl_mod mod_index num_mods - return (Just mod_info) - - case mb_mod_info of - Nothing -> return Failed - Just mod_info -> do - let this_mod = ms_mod_name mod - - -- Prune the old HPT unless this is an hs-boot module. - unless (isBootSummary mod) $ - atomicModifyIORef' old_hpt_var $ \old_hpt -> - (delFromHpt old_hpt this_mod, ()) - - -- Update and fetch the global HscEnv. - lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do - let hsc_env' = hsc_env - { hsc_HPT = addToHpt (hsc_HPT hsc_env) - this_mod mod_info } - -- We've finished typechecking the module, now we must - -- retypecheck the loop AGAIN to ensure unfoldings are - -- updated. This time, however, we include the loop - -- closer! - hsc_env'' <- case finish_loop of - Nothing -> return hsc_env' - Just loop -> typecheckLoop lcl_dflags hsc_env' $ - map (moduleName . fst) loop - return (hsc_env'', localize_hsc_env hsc_env'') - - -- Clean up any intermediate files. - cleanup lcl_hsc_env' - return Succeeded - - where - localize_mod mod - = mod { ms_hspp_opts = (ms_hspp_opts mod) - { log_action = log_action lcl_dflags - , filesToClean = filesToClean lcl_dflags } } - - localize_hsc_env hsc_env - = hsc_env { hsc_dflags = (hsc_dflags hsc_env) - { log_action = log_action lcl_dflags - , filesToClean = filesToClean lcl_dflags } } - --- ----------------------------------------------------------------------------- --- --- | The upsweep --- --- This is where we compile each module in the module graph, in a pass --- from the bottom to the top of the graph. --- --- There better had not be any cyclic groups here -- we check for them. -upsweep - :: GhcMonad m - => Maybe Messager - -> HomePackageTable -- ^ HPT from last time round (pruned) - -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) - -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files - -> [SCC ModSummary] -- ^ Mods to do (the worklist) - -> m (SuccessFlag, - [ModSummary]) - -- ^ Returns: - -- - -- 1. A flag whether the complete upsweep was successful. - -- 2. The 'HscEnv' in the monad has an updated HPT - -- 3. A list of modules which succeeded loading. - -upsweep mHscMessage old_hpt stable_mods cleanup sccs = do - dflags <- getSessionDynFlags - (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) - (unitIdsToCheck dflags) done_holes - return (res, reverse done) - where - done_holes = emptyUniqSet - - upsweep' _old_hpt done - [] _ _ uids_to_check _ - = do hsc_env <- getSession - liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check - return (Succeeded, done) - - upsweep' _old_hpt done - (CyclicSCC ms:_) _ _ _ _ - = do dflags <- getSessionDynFlags - liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) - return (Failed, done) - - upsweep' old_hpt done - (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes - = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleUserString.moduleName.mi_module.hm_iface) - -- (moduleEnvElts (hsc_HPT hsc_env))) - let logger _mod = defaultWarnErrLogger - - hsc_env <- getSession - - -- TODO: Cache this, so that we don't repeatedly re-check - -- our imports when you run --make. - let (ready_uids, uids_to_check') - = partition (\uid -> isEmptyUniqDSet - (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes)) - uids_to_check - done_holes' - | ms_hsc_src mod == HsigFile - = addOneToUniqSet done_holes (ms_mod_name mod) - | otherwise = done_holes - liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids - - -- Remove unwanted tmp files between compilations - liftIO (cleanup hsc_env) - - -- Get ready to tie the knot - type_env_var <- liftIO $ newIORef emptyNameEnv - let hsc_env1 = hsc_env { hsc_type_env_var = - Just (ms_mod mod, type_env_var) } - setSession hsc_env1 - - -- Lazily reload the HPT modules participating in the loop. - -- See Note [Tying the knot]--if we don't throw out the old HPT - -- and reinitalize the knot-tying process, anything that was forced - -- while we were previously typechecking won't get updated, this - -- was bug #12035. - hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done - setSession hsc_env2 - - mb_mod_info - <- handleSourceError - (\err -> do logger mod (Just err); return Nothing) $ do - mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods - mod mod_index nmods - logger mod Nothing -- log warnings - return (Just mod_info) - - case mb_mod_info of - Nothing -> return (Failed, done) - Just mod_info -> do - let this_mod = ms_mod_name mod - - -- Add new info to hsc_env - hpt1 = addToHpt (hsc_HPT hsc_env2) this_mod mod_info - hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing } - - -- Space-saving: delete the old HPT entry - -- for mod BUT if mod is a hs-boot - -- node, don't delete it. For the - -- interface, the HPT entry is probaby for the - -- main Haskell source file. Deleting it - -- would force the real module to be recompiled - -- every time. - old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delFromHpt old_hpt this_mod - - done' = mod:done - - -- fixup our HomePackageTable after we've finished compiling - -- a mutually-recursive loop. We have to do this again - -- to make sure we have the final unfoldings, which may - -- not have been computed accurately in the previous - -- retypecheck. - hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done' - setSession hsc_env4 - - -- Add any necessary entries to the static pointer - -- table. See Note [Grand plan for static forms] in - -- StaticPtrTable. - when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $ - liftIO $ hscAddSptEntries hsc_env4 - [ spt - | Just linkable <- pure $ hm_linkable mod_info - , unlinked <- linkableUnlinked linkable - , BCOs _ spts <- pure unlinked - , spt <- spts - ] - - upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes' - -unitIdsToCheck :: DynFlags -> [UnitId] -unitIdsToCheck dflags = - nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags)) - where - goUnitId uid = - case splitUnitIdInsts uid of - (_, Just indef) -> - let insts = indefUnitIdInsts indef - in uid : concatMap (goUnitId . moduleUnitId . snd) insts - _ -> [] - -maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) -maybeGetIfaceDate dflags location - | writeInterfaceOnlyMode dflags - -- Minor optimization: it should be harmless to check the hi file location - -- always, but it's better to avoid hitting the filesystem if possible. - = modificationTimeIfExists (ml_hi_file location) - | otherwise - = return Nothing - --- | Compile a single module. Always produce a Linkable for it if --- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: HscEnv - -> Maybe Messager - -> HomePackageTable - -> ([ModuleName],[ModuleName]) - -> 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 `elem` stable_obj - is_stable_bco = this_mod_name `elem` stable_bco - - old_hmi = lookupHpt old_hpt this_mod_name - - -- We're using the dflags for this module now, obtained by - -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. - dflags = ms_hspp_opts summary - prevailing_target = hscTarget (hsc_dflags hsc_env) - local_target = hscTarget dflags - - -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that - -- we don't do anything dodgy: these should only work to change - -- from -fllvm to -fasm and vice-versa, otherwise we could - -- end up trying to link object code to byte code. - target = if prevailing_target /= local_target - && (not (isObjectTarget prevailing_target) - || not (isObjectTarget local_target)) - then prevailing_target - else local_target - - -- store the corrected hscTarget into the summary - summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } - - -- The old interface is ok if - -- a) we're compiling a source file, and the old HPT - -- entry is for a source file - -- b) we're compiling a hs-boot file - -- Case (b) allows an hs-boot file to get the interface of its - -- real source file on the second iteration of the compilation - -- manager, but that does no harm. Otherwise the hs-boot file - -- will always be recompiled - - mb_old_iface - = case old_hmi of - Nothing -> Nothing - Just hm_info | isBootSummary summary -> Just iface - | not (mi_boot iface) -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info - - compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo - compile_it mb_linkable src_modified = - compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods - mb_old_iface mb_linkable src_modified - - compile_it_discard_iface :: Maybe Linkable -> SourceModified - -> IO HomeModInfo - compile_it_discard_iface mb_linkable src_modified = - compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods - Nothing mb_linkable src_modified - - -- With the HscNothing target we create empty linkables to avoid - -- recompilation. We have to detect these to recompile anyway if - -- the target changed since the last compile. - is_fake_linkable - | Just hmi <- old_hmi, Just l <- hm_linkable hmi = - null (linkableUnlinked l) - | otherwise = - -- we have no linkable, so it cannot be fake - False - - implies False _ = True - implies True x = x - - in - case () of - _ - -- Regardless of whether we're generating object code or - -- byte code, we can always use an existing object file - -- if it is *stable* (see checkStability). - | is_stable_obj, Just hmi <- old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable obj mod:" <+> ppr this_mod_name) - return hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling stable on-disk mod:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn - (expectJust "upsweep1" mb_obj_date) - compile_it (Just linkable) SourceUnmodifiedAndStable - -- object is stable, but we need to load the interface - -- off disk to make a HMI. - - | not (isObjectTarget target), is_stable_bco, - (target /= HscNothing) `implies` not is_fake_linkable -> - ASSERT(isJust old_hmi) -- must be in the old_hpt - let Just hmi = old_hmi in do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable BCO mod:" <+> ppr this_mod_name) - return hmi - -- BCO is stable: nothing to do - - | not (isObjectTarget target), - Just hmi <- old_hmi, - Just l <- hm_linkable hmi, - not (isObjectLinkable l), - (target /= HscNothing) `implies` not is_fake_linkable, - linkableTime l >= ms_hs_date summary -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) - compile_it (Just l) SourceUnmodified - -- we have an old BCO that is up to date with respect - -- to the source: do a recompilation check as normal. - - -- When generating object code, if there's an up-to-date - -- object file on the disk, then we can use it. - -- However, if the object file is new (compared to any - -- linkable we had from a previous compilation), then we - -- must discard any in-memory interface, because this - -- means the user has compiled the source file - -- separately and generated a new interface, that we must - -- read from the disk. - -- - | isObjectTarget target, - Just obj_date <- mb_obj_date, - obj_date >= hs_date -> do - case old_hmi of - Just hmi - | Just l <- hm_linkable hmi, - isObjectLinkable l && linkableTime l == obj_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) - compile_it (Just l) SourceUnmodified - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date - compile_it_discard_iface (Just linkable) SourceUnmodified - - -- See Note [Recompilation checking when typechecking only] - | writeInterfaceOnlyMode dflags, - Just if_date <- mb_if_date, - if_date >= hs_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping tc'd mod:" <+> ppr this_mod_name) - compile_it Nothing SourceUnmodified - - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod:" <+> ppr this_mod_name) - compile_it Nothing SourceModified - --- Note [Recompilation checking when typechecking only] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- If we are compiling with -fno-code -fwrite-interface, there won't --- be any object code that we can compare against, nor should there --- be: we're *just* generating interface files. In this case, we --- want to check if the interface file is new, in lieu of the object --- file. See also Trac #9243. - - --- Filter modules in the HPT -retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable -retainInTopLevelEnvs keep_these hpt - = listToHpt [ (mod, expectJust "retain" mb_mod_info) - | mod <- keep_these - , let mb_mod_info = lookupHpt hpt mod - , isJust mb_mod_info ] - --- --------------------------------------------------------------------------- --- Typecheck module loops -{- -See bug #930. This code fixes a long-standing bug in --make. The -problem is that when compiling the modules *inside* a loop, a data -type that is only defined at the top of the loop looks opaque; but -after the loop is done, the structure of the data type becomes -apparent. - -The difficulty is then that two different bits of code have -different notions of what the data type looks like. - -The idea is that after we compile a module which also has an .hs-boot -file, we re-generate the ModDetails for each of the modules that -depends on the .hs-boot file, so that everyone points to the proper -TyCons, Ids etc. defined by the real module, not the boot module. -Fortunately re-generating a ModDetails from a ModIface is easy: the -function TcIface.typecheckIface does exactly that. - -Picking the modules to re-typecheck is slightly tricky. Starting from -the module graph consisting of the modules that have already been -compiled, we reverse the edges (so they point from the imported module -to the importing module), and depth-first-search from the .hs-boot -node. This gives us all the modules that depend transitively on the -.hs-boot module, and those are exactly the modules that we need to -re-typecheck. - -Following this fix, GHC can compile itself with --make -O2. --} - -reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv -reTypecheckLoop hsc_env ms graph - | Just loop <- getModLoop ms graph - -- SOME hs-boot files should still - -- get used, just not the loop-closer. - , let non_boot = filter (\l -> not (isBootSummary l && - ms_mod l == ms_mod ms)) loop - = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot) - | otherwise - = return hsc_env - --- | 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 -> ModuleGraph -> Maybe [ModSummary] -getModLoop ms graph - | not (isBootSummary ms) - , any (\m -> ms_mod m == this_mod && isBootSummary m) graph - , let mss = reachableBackwards (ms_mod_name ms) graph - = Just mss - | otherwise - = Nothing - where - this_mod = ms_mod ms - --- NB: sometimes mods has duplicates; this is harmless because --- any duplicates get clobbered in addListToHpt and never get forced. -typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv -typecheckLoop dflags hsc_env mods = do - debugTraceMsg dflags 2 $ - text "Re-typechecking loop: " <> ppr mods - new_hpt <- - fixIO $ \new_hpt -> do - let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } - mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $ - mapM (typecheckIface . hm_iface) hmis - let new_hpt = addListToHpt old_hpt - (zip mods [ hmi{ hm_details = details } - | (hmi,details) <- zip hmis mds ]) - return new_hpt - return hsc_env{ hsc_HPT = new_hpt } - where - old_hpt = hsc_HPT hsc_env - hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods - -reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] -reachableBackwards mod summaries - = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] - where -- the rest just sets up the graph: - (graph, lookup_node) = moduleGraphNodes False summaries - root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) - --- --------------------------------------------------------------------------- --- --- | Topological sort of the module graph -topSortModuleGraph - :: Bool - -- ^ Drop hi-boot nodes? (see below) - -> [ModSummary] - -> Maybe ModuleName - -- ^ Root module name. If @Nothing@, use the full graph. - -> [SCC ModSummary] --- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes --- The resulting list of strongly-connected-components is in topologically --- sorted order, starting with the module(s) at the bottom of the --- dependency graph (ie compile them first) and ending with the ones at --- the top. --- --- Drop hi-boot nodes (first boolean arg)? --- --- - @False@: treat the hi-boot summaries as nodes of the graph, --- so the graph must be acyclic --- --- - @True@: eliminate the hi-boot nodes, and instead pretend --- the a source-import of Foo is an import of Foo --- The resulting graph has no hi-boot nodes, but can be cyclic - -topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod - = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph - where - -- stronglyConnCompG flips the original order, so if we reverse - -- the summaries we get a stable topological sort. - (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes (reverse summaries) - - initial_graph = case mb_root_mod of - Nothing -> graph - Just root_mod -> - -- restrict the graph to just those modules reachable from - -- the specified module. We do this by building a graph with - -- the full set of nodes, and determining the reachable set from - -- the specified node. - let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node - | otherwise = throwGhcException (ProgramError "module does not exist") - in graphFromEdgedVerticesUniq (seq root (reachableG graph root)) - -type SummaryNode = (ModSummary, Int, [Int]) - -summaryNodeKey :: SummaryNode -> Int -summaryNodeKey (_, k, _) = k - -summaryNodeSummary :: SummaryNode -> ModSummary -summaryNodeSummary (s, _, _) = s - -moduleGraphNodes :: Bool -> [ModSummary] - -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) -moduleGraphNodes drop_hs_boot_nodes summaries = - (graphFromEdgedVerticesUniq nodes, lookup_node) - where - numbered_summaries = zip summaries [1..] - - lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode - lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map - - lookup_key :: HscSource -> ModuleName -> Maybe Int - lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) - - node_map :: NodeMap SummaryNode - node_map = Map.fromList [ ((moduleName (ms_mod s), - hscSourceToIsBoot (ms_hsc_src s)), node) - | node@(s, _, _) <- nodes ] - - -- We use integers as the keys for the SCC algorithm - nodes :: [SummaryNode] - nodes = [ (s, key, out_keys) - | (s, key) <- numbered_summaries - -- Drop the hi-boot ones if told to do so - , not (isBootSummary s && drop_hs_boot_nodes) - , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ - (-- see [boot-edges] below - if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile - then [] - else case lookup_key HsBootFile (ms_mod_name s) of - Nothing -> [] - Just k -> [k]) ] - - -- [boot-edges] if this is a .hs and there is an equivalent - -- .hs-boot, add a link from the former to the latter. This - -- has the effect of detecting bogus cases where the .hs-boot - -- depends on the .hs, by introducing a cycle. Additionally, - -- it ensures that we will always process the .hs-boot before - -- the .hs, and so the HomePackageTable will always have the - -- most up to date information. - - -- Drop hs-boot nodes by using HsSrcFile as the key - hs_boot_key | drop_hs_boot_nodes = HsSrcFile - | otherwise = HsBootFile - - out_edge_keys :: HscSource -> [ModuleName] -> [Int] - out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms - -- If we want keep_hi_boot_nodes, then we do lookup_key with - -- IsBoot; else NotBoot - --- The nodes of the graph are keyed by (mod, is boot?) pairs --- NB: hsig files show up as *normal* nodes (not boot!), since they don't --- participate in cycles (for now) -type NodeKey = (ModuleName, IsBoot) -type NodeMap a = Map.Map NodeKey a - -msKey :: ModSummary -> NodeKey -msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) - = (moduleName mod, hscSourceToIsBoot boot) - -mkNodeMap :: [ModSummary] -> NodeMap ModSummary -mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] - -nodeMapElts :: NodeMap a -> [a] -nodeMapElts = Map.elems - --- | If there are {-# SOURCE #-} imports between strongly connected --- components in the topological sort, then those imports can --- definitely be replaced by ordinary non-SOURCE imports: if SOURCE --- were necessary, then the edge would be part of a cycle. -warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () -warnUnnecessarySourceImports sccs = do - dflags <- getDynFlags - when (wopt Opt_WarnUnusedImports dflags) - (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs))) - where check dflags ms = - let mods_in_this_cycle = map ms_mod_name ms in - [ warn dflags i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] - - warn :: DynFlags -> Located ModuleName -> WarnMsg - warn dflags (L loc mod) = - mkPlainErrMsg dflags loc - (text "Warning: {-# SOURCE #-} unnecessary in import of " - <+> quotes (ppr mod)) - - -reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b] -reportImportErrors xs | null errs = return oks - | otherwise = throwManyErrors errs - where (errs, oks) = partitionEithers xs - -throwManyErrors :: MonadIO m => [ErrMsg] -> m ab -throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs - - ------------------------------------------------------------------------------ --- --- | Downsweep (dependency analysis) --- --- Chase downwards from the specified root set, returning summaries --- for all home modules encountered. Only follow source-import --- links. --- --- We pass in the previous collection of summaries, which is used as a --- cache to avoid recalculating a module summary if the source is --- unchanged. --- --- The returned list of [ModSummary] nodes has one node for each home-package --- module, plus one for any hs-boot files. The imports of these nodes --- are all there, including the imports of non-home-package modules. -downsweep :: HscEnv - -> [ModSummary] -- Old summaries - -> [ModuleName] -- Ignore dependencies on these; treat - -- them as if they were package modules - -> Bool -- True <=> allow multiple targets to have - -- the same module name; this is - -- very useful for ghc -M - -> IO [Either ErrMsg ModSummary] - -- The elts of [ModSummary] all have distinct - -- (Modules, IsBoot) identifiers, unless the Bool is true - -- in which case there can be repeats -downsweep hsc_env old_summaries excl_mods allow_dup_roots - = do - rootSummaries <- mapM getRootSummary roots - rootSummariesOk <- reportImportErrors rootSummaries - let root_map = mkRootMap rootSummariesOk - checkDuplicates root_map - summs <- loop (concatMap calcDeps rootSummariesOk) root_map - return summs - where - calcDeps = msDeps - - dflags = hsc_dflags hsc_env - roots = hsc_targets hsc_env - - old_summary_map :: NodeMap ModSummary - old_summary_map = mkNodeMap old_summaries - - getRootSummary :: Target -> IO (Either ErrMsg ModSummary) - getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) - = do exists <- liftIO $ doesFileExist file - if exists - then Right `fmap` summariseFile hsc_env old_summaries file mb_phase - obj_allowed maybe_buf - else return $ Left $ mkPlainErrMsg dflags noSrcSpan $ - text "can't find file:" <+> text file - getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) - = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot - (L rootLoc modl) obj_allowed - maybe_buf excl_mods - case maybe_summary of - Nothing -> return $ Left $ moduleNotFoundErr dflags modl - Just s -> return s - - rootLoc = mkGeneralSrcSpan (fsLit "") - - -- In a root module, the filename is allowed to diverge from the module - -- name, so we have to check that there aren't multiple root files - -- defining the same module (otherwise the duplicates will be silently - -- ignored, leading to confusing behaviour). - checkDuplicates :: NodeMap [Either ErrMsg ModSummary] -> IO () - checkDuplicates root_map - | allow_dup_roots = return () - | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr dflags (head dup_roots) - where - dup_roots :: [[ModSummary]] -- Each at least of length 2 - dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map - - loop :: [(Located ModuleName,IsBoot)] - -- Work list: process these modules - -> NodeMap [Either ErrMsg ModSummary] - -- Visited set; the range is a list because - -- the roots can have the same module names - -- if allow_dup_roots is True - -> IO [Either ErrMsg ModSummary] - -- The result includes the worklist, except - -- for those mentioned in the visited set - loop [] done = return (concat (nodeMapElts done)) - loop ((wanted_mod, is_boot) : ss) done - | Just summs <- Map.lookup key done - = if isSingleton summs then - loop ss done - else - do { multiRootsErr dflags (rights summs); return [] } - | otherwise - = do mb_s <- summariseModule hsc_env old_summary_map - is_boot wanted_mod True - Nothing excl_mods - case mb_s of - Nothing -> loop ss done - Just (Left e) -> loop ss (Map.insert key [Left e] done) - Just (Right s)-> loop (calcDeps s ++ ss) - (Map.insert key [Right s] done) - where - key = (unLoc wanted_mod, is_boot) - -mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary] -mkRootMap summaries = Map.insertListWith (flip (++)) - [ (msKey s, [Right s]) | s <- summaries ] - Map.empty - --- | Returns the dependencies of the ModSummary s. --- A wrinkle is that for a {-# SOURCE #-} import we return --- *both* the hs-boot file --- *and* the source file --- as "dependencies". That ensures that the list of all relevant --- modules always contains B.hs if it contains B.hs-boot. --- Remember, this pass isn't doing the topological sort. It's --- just gathering the list of all relevant ModSummaries -msDeps :: ModSummary -> [(Located ModuleName, IsBoot)] -msDeps s = - concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ] - ++ [ (m,NotBoot) | m <- ms_home_imps s ] - -home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName] -home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps, - isLocal mb_pkg ] - where isLocal Nothing = True - isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special - isLocal _ = False - -ms_home_allimps :: ModSummary -> [ModuleName] -ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) - --- | Like 'ms_home_imps', but for SOURCE imports. -ms_home_srcimps :: ModSummary -> [Located ModuleName] -ms_home_srcimps = home_imps . ms_srcimps - --- | All of the (possibly) home module imports from a --- 'ModSummary'; that is to say, each of these module names --- could be a home import if an appropriately named file --- existed. (This is in contrast to package qualified --- imports, which are guaranteed not to be home imports.) -ms_home_imps :: ModSummary -> [Located ModuleName] -ms_home_imps = home_imps . ms_imps - ------------------------------------------------------------------------------ --- Summarising modules - --- We have two types of summarisation: --- --- * Summarise a file. This is used for the root module(s) passed to --- cmLoadModules. The file is read, and used to determine the root --- module name. The module name may differ from the filename. --- --- * Summarise a module. We are given a module name, and must provide --- a summary. The finder is used to locate the file in which the module --- resides. - -summariseFile - :: HscEnv - -> [ModSummary] -- old summaries - -> FilePath -- source file name - -> Maybe Phase -- start phase - -> Bool -- object code allowed? - -> Maybe (StringBuffer,UTCTime) - -> IO ModSummary - -summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - -- we can use a cached summary if one is available and the - -- source file hasn't changed, But we have to look up the summary - -- by source file, rather than module name as we do in summarise. - | Just old_summary <- findSummaryBySourceFile old_summaries file - = do - let location = ms_location old_summary - dflags = hsc_dflags hsc_env - - src_timestamp <- get_src_timestamp - -- The file exists; we checked in getRootSummary above. - -- If it gets removed subsequently, then this - -- getModificationUTCTime may fail, but that's the right - -- behaviour. - - -- return the cached summary if the source didn't change - if ms_hs_date old_summary == src_timestamp && - not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) - then do -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location NotBoot - else return Nothing - hi_timestamp <- maybeGetIfaceDate dflags location - return old_summary{ ms_obj_date = obj_timestamp - , ms_iface_date = hi_timestamp } - else - new_summary src_timestamp - - | otherwise - = do src_timestamp <- get_src_timestamp - new_summary src_timestamp - where - get_src_timestamp = case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationUTCTime file - -- getModificationUTCTime may fail - - new_summary src_timestamp = do - let dflags = hsc_dflags hsc_env - - let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile - - (dflags', hspp_fn, buf) - <- preprocessFile hsc_env file mb_phase maybe_buf - - (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file - - -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation dflags mod_name file - - -- Tell the Finder cache where it is, so that subsequent calls - -- to findModule will find it, even if it's not on any search path - mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location - - -- when the user asks to load a source file by name, we only - -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ modificationTimeIfExists (ml_obj_file location) - else return Nothing - - hi_timestamp <- maybeGetIfaceDate dflags location - - extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name - required_by_imports <- implicitRequirements hsc_env the_imps - - return (ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_parsed_mod = Nothing, - ms_srcimps = srcimps, - ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports, - ms_hs_date = src_timestamp, - ms_iface_date = hi_timestamp, - ms_obj_date = obj_timestamp }) - -findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary -findSummaryBySourceFile summaries file - = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], - expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of - [] -> Nothing - (x:_) -> Just x - --- Summarise a module, and pick up source and timestamp. -summariseModule - :: HscEnv - -> NodeMap ModSummary -- Map of old summaries - -> IsBoot -- IsBoot <=> a {-# SOURCE #-} import - -> Located ModuleName -- Imported module to be summarised - -> Bool -- object code allowed? - -> Maybe (StringBuffer, UTCTime) - -> [ModuleName] -- Modules to exclude - -> IO (Maybe (Either ErrMsg ModSummary)) -- Its new summary - -summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) - obj_allowed maybe_buf excl_mods - | wanted_mod `elem` excl_mods - = return Nothing - - | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map - = do -- Find its new timestamp; all the - -- ModSummaries in the old map have valid ml_hs_files - let location = ms_location old_summary - src_fn = expectJust "summariseModule" (ml_hs_file location) - - -- check the modification time on the source file, and - -- return the cached summary if it hasn't changed. If the - -- file has disappeared, we need to call the Finder again. - case maybe_buf of - Just (_,t) -> check_timestamp old_summary location src_fn t - Nothing -> do - m <- tryIO (getModificationUTCTime src_fn) - case m of - Right t -> check_timestamp old_summary location src_fn t - Left e | isDoesNotExistError e -> find_it - | otherwise -> ioError e - - | otherwise = find_it - where - dflags = hsc_dflags hsc_env - - check_timestamp old_summary location src_fn src_timestamp - | ms_hs_date old_summary == src_timestamp && - not (gopt Opt_ForceRecomp dflags) = do - -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - hi_timestamp <- maybeGetIfaceDate dflags location - return (Just (Right old_summary{ ms_obj_date = obj_timestamp - , ms_iface_date = hi_timestamp})) - | otherwise = - -- source changed: re-summarise. - new_summary location (ms_mod old_summary) src_fn src_timestamp - - find_it = do - -- Don't use the Finder's cache this time. If the module was - -- previously a package module, it may have now appeared on the - -- search path, so we want to consider it to be a home module. If - -- the module was previously a home module, it may have moved. - uncacheModule hsc_env wanted_mod - found <- findImportedModule hsc_env wanted_mod Nothing - case found of - Found location mod - | isJust (ml_hs_file location) -> - -- Home package - just_found location mod - - _ -> return Nothing - -- Not found - -- (If it is TRULY not found at all, we'll - -- error when we actually try to compile) - - just_found location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so - let location' | IsBoot <- is_boot = addBootSuffixLocn location - | otherwise = location - src_fn = expectJust "summarise2" (ml_hs_file location') - - -- Check that it exists - -- It might have been deleted since the Finder last found it - maybe_t <- modificationTimeIfExists src_fn - case maybe_t of - Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn - Just t -> new_summary location' mod src_fn t - - - new_summary location mod src_fn src_timestamp - = do - -- Preprocess the source file and get its imports - -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn - - -- NB: Despite the fact that is_boot is a top-level parameter, we - -- don't actually know coming into this function what the HscSource - -- of the module in question is. This is because we may be processing - -- this module because another module in the graph imported it: in this - -- case, we know if it's a boot or not because of the {-# SOURCE #-} - -- annotation, but we don't know if it's a signature or a regular - -- module until we actually look it up on the filesystem. - let hsc_src = case is_boot of - IsBoot -> HsBootFile - _ | isHaskellSigFilename src_fn -> HsigFile - | otherwise -> HsSrcFile - - when (mod_name /= wanted_mod) $ - throwOneError $ mkPlainErrMsg dflags' mod_loc $ - text "File name does not match module name:" - $$ text "Saw:" <+> quotes (ppr mod_name) - $$ text "Expected:" <+> quotes (ppr wanted_mod) - - when (hsc_src == HsigFile && isNothing (lookup mod_name (thisUnitIdInsts dflags))) $ - let suggested_instantiated_with = - hcat (punctuate comma $ - [ ppr k <> text "=" <> ppr v - | (k,v) <- ((mod_name, mkHoleModule mod_name) - : thisUnitIdInsts dflags) - ]) - in throwOneError $ mkPlainErrMsg dflags' mod_loc $ - text "Unexpected signature:" <+> quotes (ppr mod_name) - $$ if gopt Opt_BuildingCabalPackage dflags - then parens (text "Try adding" <+> quotes (ppr mod_name) - <+> text "to the" - <+> quotes (text "signatures") - <+> text "field in your Cabal file.") - else parens (text "Try passing -instantiated-with=\"" <> - suggested_instantiated_with <> text "\"" $$ - text "replacing <" <> ppr mod_name <> text "> as necessary.") - - -- Find the object timestamp, and return the summary - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - - hi_timestamp <- maybeGetIfaceDate dflags location - - extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name - required_by_imports <- implicitRequirements hsc_env the_imps - - return (Just (Right (ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_parsed_mod = Nothing, - ms_srcimps = srcimps, - ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports, - ms_hs_date = src_timestamp, - ms_iface_date = hi_timestamp, - ms_obj_date = obj_timestamp }))) - - -getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime) -getObjTimestamp location is_boot - = if is_boot == IsBoot then return Nothing - else modificationTimeIfExists (ml_obj_file location) - - -preprocessFile :: HscEnv - -> FilePath - -> Maybe Phase -- ^ Starting phase - -> Maybe (StringBuffer,UTCTime) - -> IO (DynFlags, FilePath, StringBuffer) -preprocessFile hsc_env src_fn mb_phase Nothing - = do - (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- hGetStringBuffer hspp_fn - return (dflags', hspp_fn, buf) - -preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) - = do - let dflags = hsc_dflags hsc_env - let local_opts = getOptions dflags buf src_fn - - (dflags', leftovers, warns) - <- parseDynamicFilePragma dflags local_opts - checkProcessArgsResult dflags leftovers - handleFlagWarnings dflags' warns - - let needs_preprocessing - | Just (Unlit _) <- mb_phase = True - | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True - -- note: local_opts is only required if there's no Unlit phase - | xopt LangExt.Cpp dflags' = True - | gopt Opt_Pp dflags' = True - | otherwise = False - - when needs_preprocessing $ - throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled") - - return (dflags', src_fn, buf) - - ------------------------------------------------------------------------------ --- Error messages ------------------------------------------------------------------------------ - -noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg --- ToDo: we don't have a proper line number for this error -noModError dflags loc wanted_mod err - = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err - -noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg -noHsFileErr dflags loc path - = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path - -moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg -moduleNotFoundErr dflags mod - = mkPlainErrMsg dflags noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" - -multiRootsErr :: DynFlags -> [ModSummary] -> IO () -multiRootsErr _ [] = panic "multiRootsErr" -multiRootsErr dflags summs@(summ1:_) - = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> - text "is defined in multiple files:" <+> - sep (map text files) - where - mod = ms_mod summ1 - files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs - -cyclicModuleErr :: [ModSummary] -> SDoc --- From a strongly connected component we find --- a single cycle to report -cyclicModuleErr mss - = ASSERT( not (null mss) ) - case findCycle graph of - Nothing -> text "Unexpected non-cycle" <+> ppr mss - Just path -> vcat [ text "Module imports form a cycle:" - , nest 2 (show_path path) ] - where - graph :: [Node NodeKey ModSummary] - graph = [(ms, msKey ms, get_deps ms) | ms <- mss] - - get_deps :: ModSummary -> [NodeKey] - get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++ - [ (unLoc m, NotBoot) | m <- ms_home_imps ms ]) - - show_path [] = panic "show_path" - show_path [m] = text "module" <+> ppr_ms m - <+> text "imports itself" - show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1) - : nest 6 (text "imports" <+> ppr_ms m2) - : go ms ) - where - go [] = [text "which imports" <+> ppr_ms m1] - go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms - - - ppr_ms :: ModSummary -> SDoc - ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> - (parens (text (msHsFilePath ms))) diff --git a/main/GhcMonad.hs b/main/GhcMonad.hs deleted file mode 100644 --- a/main/GhcMonad.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# LANGUAGE CPP, RankNTypes #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2010 --- --- The Session type and related functionality --- --- ----------------------------------------------------------------------------- - -module GhcMonad ( - -- * 'Ghc' monad stuff - GhcMonad(..), - Ghc(..), - GhcT(..), liftGhcT, - reflectGhc, reifyGhc, - getSessionDynFlags, - liftIO, - Session(..), withSession, modifySession, withTempSession, - - -- ** Warnings - logWarnings, printException, - WarnErrLogger, defaultWarnErrLogger - ) where - -import MonadUtils -import HscTypes -import DynFlags -import Exception -import ErrUtils - -import Control.Monad -import Data.IORef - --- ----------------------------------------------------------------------------- --- | A monad that has all the features needed by GHC API calls. --- --- In short, a GHC monad --- --- - allows embedding of IO actions, --- --- - can log warnings, --- --- - allows handling of (extensible) exceptions, and --- --- - maintains a current session. --- --- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' --- before any call to the GHC API functions can occur. --- -class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where - getSession :: m HscEnv - setSession :: HscEnv -> m () - --- | Call the argument with the current session. -withSession :: GhcMonad m => (HscEnv -> m a) -> m a -withSession f = getSession >>= f - --- | Grabs the DynFlags from the Session -getSessionDynFlags :: GhcMonad m => m DynFlags -getSessionDynFlags = withSession (return . hsc_dflags) - --- | Set the current session to the result of applying the current session to --- the argument. -modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () -modifySession f = do h <- getSession - setSession $! f h - -withSavedSession :: GhcMonad m => m a -> m a -withSavedSession m = do - saved_session <- getSession - m `gfinally` setSession saved_session - --- | Call an action with a temporarily modified Session. -withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a -withTempSession f m = - withSavedSession $ modifySession f >> m - --- ----------------------------------------------------------------------------- --- | A monad that allows logging of warnings. - -logWarnings :: GhcMonad m => WarningMessages -> m () -logWarnings warns = do - dflags <- getSessionDynFlags - liftIO $ printOrThrowWarnings dflags warns - --- ----------------------------------------------------------------------------- --- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, --- e.g., to maintain additional state consider wrapping this monad or using --- 'GhcT'. -newtype Ghc a = Ghc { unGhc :: Session -> IO a } - --- | The Session is a handle to the complete state of a compilation --- session. A compilation session consists of a set of modules --- constituting the current program or library, the context for --- interactive evaluation, and various caches. -data Session = Session !(IORef HscEnv) - -instance Functor Ghc where - fmap f m = Ghc $ \s -> f `fmap` unGhc m s - -instance Applicative Ghc where - pure a = Ghc $ \_ -> return a - g <*> m = do f <- g; a <- m; return (f a) - -instance Monad Ghc where - m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s - -instance MonadIO Ghc where - liftIO ioA = Ghc $ \_ -> ioA - -instance MonadFix Ghc where - mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s) - -instance ExceptionMonad Ghc where - gcatch act handle = - Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s - gmask f = - Ghc $ \s -> gmask $ \io_restore -> - let - g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) - in - unGhc (f g_restore) s - -instance HasDynFlags Ghc where - getDynFlags = getSessionDynFlags - -instance GhcMonad Ghc where - getSession = Ghc $ \(Session r) -> readIORef r - setSession s' = Ghc $ \(Session r) -> writeIORef r s' - --- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. --- --- You can use this to call functions returning an action in the 'Ghc' monad --- inside an 'IO' action. This is needed for some (too restrictive) callback --- arguments of some library functions: --- --- > libFunc :: String -> (Int -> IO a) -> IO a --- > ghcFunc :: Int -> Ghc a --- > --- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a --- > ghcFuncUsingLibFunc str = --- > reifyGhc $ \s -> --- > libFunc $ \i -> do --- > reflectGhc (ghcFunc i) s --- -reflectGhc :: Ghc a -> Session -> IO a -reflectGhc m = unGhc m - --- > Dual to 'reflectGhc'. See its documentation. -reifyGhc :: (Session -> IO a) -> Ghc a -reifyGhc act = Ghc $ act - --- ----------------------------------------------------------------------------- --- | A monad transformer to add GHC specific features to another monad. --- --- Note that the wrapped monad must support IO and handling of exceptions. -newtype GhcT m a = GhcT { unGhcT :: Session -> m a } - -liftGhcT :: m a -> GhcT m a -liftGhcT m = GhcT $ \_ -> m - -instance Functor m => Functor (GhcT m) where - fmap f m = GhcT $ \s -> f `fmap` unGhcT m s - -instance Applicative m => Applicative (GhcT m) where - pure x = GhcT $ \_ -> pure x - g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s - -instance Monad m => Monad (GhcT m) where - m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s - -instance MonadIO m => MonadIO (GhcT m) where - liftIO ioA = GhcT $ \_ -> liftIO ioA - -instance ExceptionMonad m => ExceptionMonad (GhcT m) where - gcatch act handle = - GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s - gmask f = - GhcT $ \s -> gmask $ \io_restore -> - let - g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) - in - unGhcT (f g_restore) s - -instance MonadIO m => HasDynFlags (GhcT m) where - getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) - -instance ExceptionMonad m => GhcMonad (GhcT m) where - getSession = GhcT $ \(Session r) -> liftIO $ readIORef r - setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' - - --- | Print the error message and all warnings. Useful inside exception --- handlers. Clears warnings after printing. -printException :: GhcMonad m => SourceError -> m () -printException err = do - dflags <- getSessionDynFlags - liftIO $ printBagOfErrors dflags (srcErrorMessages err) - --- | A function called to log warnings and errors. -type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () - -defaultWarnErrLogger :: WarnErrLogger -defaultWarnErrLogger Nothing = return () -defaultWarnErrLogger (Just e) = printException e - diff --git a/main/GhcPlugins.hs b/main/GhcPlugins.hs deleted file mode 100644 --- a/main/GhcPlugins.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} - --- | This module is not used by GHC itself. Rather, it exports all of --- the functions and types you are likely to need when writing a --- plugin for GHC. So authors of plugins can probably get away simply --- with saying "import GhcPlugins". --- --- Particularly interesting modules for plugin writers include --- "CoreSyn" and "CoreMonad". -module GhcPlugins( - module Plugins, - module RdrName, module OccName, module Name, module Var, module Id, module IdInfo, - module CoreMonad, module CoreSyn, module Literal, module DataCon, - module CoreUtils, module MkCore, module CoreFVs, module CoreSubst, - module Rules, module Annotations, - module DynFlags, module Packages, - module Module, module Type, module TyCon, module Coercion, - module TysWiredIn, module HscTypes, module BasicTypes, - module VarSet, module VarEnv, module NameSet, module NameEnv, - module UniqSet, module UniqFM, module FiniteMap, - module Util, module GHC.Serialized, module SrcLoc, module Outputable, - module UniqSupply, module Unique, module FastString - ) where - --- Plugin stuff itself -import Plugins - --- Variable naming -import RdrName -import OccName hiding ( varName {- conflicts with Var.varName -} ) -import Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) -import Var -import Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} ) -import IdInfo - --- Core -import CoreMonad -import CoreSyn -import Literal -import DataCon -import CoreUtils -import MkCore -import CoreFVs -import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst ) - -- These names are also exported by Type - --- Core "extras" -import Rules -import Annotations - --- Pipeline-related stuff -import DynFlags -import Packages - --- Important GHC types -import Module -import Type hiding {- conflict with CoreSubst -} - ( substTy, extendTvSubst, extendTvSubstList, isInScope ) -import Coercion hiding {- conflict with CoreSubst -} - ( substCo ) -import TyCon -import TysWiredIn -import HscTypes -import BasicTypes hiding ( Version {- conflicts with Packages.Version -} ) - --- Collections and maps -import VarSet -import VarEnv -import NameSet -import NameEnv -import UniqSet -import UniqFM --- Conflicts with UniqFM: ---import LazyUniqFM -import FiniteMap - --- Common utilities -import Util -import GHC.Serialized -import SrcLoc -import Outputable -import UniqSupply -import Unique ( Unique, Uniquable(..) ) -import FastString diff --git a/main/HeaderInfo.hs b/main/HeaderInfo.hs deleted file mode 100644 --- a/main/HeaderInfo.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- | Parsing the top of a Haskell source file to get its module name, --- imports and options. --- --- (c) Simon Marlow 2005 --- (c) Lemmih 2006 --- ------------------------------------------------------------------------------ - -module HeaderInfo ( getImports - , mkPrelImports -- used by the renamer too - , getOptionsFromFile, getOptions - , optionsErrorMsgs, - checkProcessArgsResult ) where - -#include "HsVersions.h" - -import RdrName -import HscTypes -import Parser ( parseHeader ) -import Lexer -import FastString -import HsSyn -import Module -import PrelNames -import StringBuffer -import SrcLoc -import DynFlags -import ErrUtils -import Util -import Outputable -import Pretty () -import Maybes -import Bag ( emptyBag, listToBag, unitBag ) -import MonadUtils -import Exception -import BasicTypes -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import System.IO -import System.IO.Unsafe -import Data.List - ------------------------------------------------------------------------------- - --- | Parse the imports of a source file. --- --- Throws a 'SourceError' if parsing fails. -getImports :: DynFlags - -> StringBuffer -- ^ Parse this. - -> FilePath -- ^ Filename the buffer came from. Used for - -- reporting parse error locations. - -> FilePath -- ^ The original source filename (used for locations - -- in the function result) - -> IO ([(Maybe FastString, Located ModuleName)], - [(Maybe FastString, Located ModuleName)], - Located ModuleName) - -- ^ The source imports, normal imports, and the module name. -getImports dflags buf filename source_filename = do - let loc = mkRealSrcLoc (mkFastString filename) 1 1 - case unP parseHeader (mkPState dflags buf loc) of - PFailed span err -> parseError dflags span err - POk pst rdr_module -> do - let _ms@(_warns, errs) = getMessages pst dflags - -- don't log warnings: they'll be reported when we parse the file - -- for real. See #2500. - ms = (emptyBag, errs) - -- logWarnings warns - if errorsFound dflags ms - then throwIO $ mkSrcErr errs - else - case rdr_module of - L _ hsmod -> - let - mb_mod = hsmodName hsmod - imps = hsmodImports hsmod - main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1) - mod = mb_mod `orElse` L main_loc mAIN_NAME - (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps - - -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) - ord_idecls - - implicit_prelude = xopt LangExt.ImplicitPrelude dflags - implicit_imports = mkPrelImports (unLoc mod) main_loc - implicit_prelude imps - convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) - in - return (map convImport src_idecls, - map convImport (implicit_imports ++ ordinary_imps), - mod) - -mkPrelImports :: ModuleName - -> SrcSpan -- Attribute the "import Prelude" to this location - -> Bool -> [LImportDecl RdrName] - -> [LImportDecl RdrName] --- Construct the implicit declaration "import Prelude" (or not) --- --- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); --- because the former doesn't even look at Prelude.hi for instance --- declarations, whereas the latter does. -mkPrelImports this_mod loc implicit_prelude import_decls - | this_mod == pRELUDE_NAME - || explicit_prelude_import - || not implicit_prelude - = [] - | otherwise = [preludeImportDecl] - where - explicit_prelude_import - = notNull [ () | L _ (ImportDecl { ideclName = mod - , ideclPkgQual = Nothing }) - <- import_decls - , unLoc mod == pRELUDE_NAME ] - - preludeImportDecl :: LImportDecl RdrName - preludeImportDecl - = L loc $ ImportDecl { ideclSourceSrc = NoSourceText, - ideclName = L loc pRELUDE_NAME, - ideclPkgQual = Nothing, - ideclSource = False, - ideclSafe = False, -- Not a safe import - ideclQualified = False, - ideclImplicit = True, -- Implicit! - ideclAs = Nothing, - ideclHiding = Nothing } - -parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a -parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err - --------------------------------------------------------------- --- Get options --------------------------------------------------------------- - --- | Parse OPTIONS and LANGUAGE pragmas of the source file. --- --- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) -getOptionsFromFile :: DynFlags - -> FilePath -- ^ Input file - -> IO [Located String] -- ^ Parsed options, if any. -getOptionsFromFile dflags filename - = Exception.bracket - (openBinaryFile filename ReadMode) - (hClose) - (\handle -> do - opts <- fmap (getOptions' dflags) - (lazyGetToks dflags' filename handle) - seqList opts $ return opts) - where -- We don't need to get haddock doc tokens when we're just - -- getting the options from pragmas, and lazily lexing them - -- correctly is a little tricky: If there is "\n" or "\n-" - -- left at the end of a buffer then the haddock doc may - -- continue past the end of the buffer, despite the fact that - -- we already have an apparently-complete token. - -- We therefore just turn Opt_Haddock off when doing the lazy - -- lex. - dflags' = gopt_unset dflags Opt_Haddock - -blockSize :: Int --- blockSize = 17 -- for testing :-) -blockSize = 1024 - -lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token] -lazyGetToks dflags filename handle = do - buf <- hGetStringBufferBlock handle blockSize - unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize - where - loc = mkRealSrcLoc (mkFastString filename) 1 1 - - lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] - lazyLexBuf handle state eof size = do - case unP (lexer False return) state of - POk state' t -> do - -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) - if atEnd (buffer state') && not eof - -- if this token reached the end of the buffer, and we haven't - -- necessarily read up to the end of the file, then the token might - -- be truncated, so read some more of the file and lex it again. - then getMore handle state size - else case t of - L _ ITeof -> return [t] - _other -> do rest <- lazyLexBuf handle state' eof size - return (t : rest) - _ | not eof -> getMore handle state size - | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof] - -- parser assumes an ITeof sentinel at the end - - getMore :: Handle -> PState -> Int -> IO [Located Token] - getMore handle state size = do - -- pprTrace "getMore" (text (show (buffer state))) (return ()) - let new_size = size * 2 - -- double the buffer size each time we read a new block. This - -- counteracts the quadratic slowdown we otherwise get for very - -- large module names (#5981) - nextbuf <- hGetStringBufferBlock handle new_size - if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do - newbuf <- appendStringBuffers (buffer state) nextbuf - unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size - - -getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] -getToks dflags filename buf = lexAll (pragState dflags buf loc) - where - loc = mkRealSrcLoc (mkFastString filename) 1 1 - - lexAll state = case unP (lexer False return) state of - POk _ t@(L _ ITeof) -> [t] - POk state' t -> t : lexAll state' - _ -> [L (RealSrcSpan (last_loc state)) ITeof] - - --- | Parse OPTIONS and LANGUAGE pragmas of the source file. --- --- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) -getOptions :: DynFlags - -> StringBuffer -- ^ Input Buffer - -> FilePath -- ^ Source filename. Used for location info. - -> [Located String] -- ^ Parsed options. -getOptions dflags buf filename - = getOptions' dflags (getToks dflags filename buf) - --- The token parser is written manually because Happy can't --- return a partial result when it encounters a lexer error. --- We want to extract options before the buffer is passed through --- CPP, so we can't use the same trick as 'getImports'. -getOptions' :: DynFlags - -> [Located Token] -- Input buffer - -> [Located String] -- Options. -getOptions' dflags toks - = parseToks toks - where - getToken (L _loc tok) = tok - getLoc (L loc _tok) = loc - - parseToks (open:close:xs) - | IToptions_prag str <- getToken open - , ITclose_prag <- getToken close - = case toArgs str of - Left err -> panic ("getOptions'.parseToks: " ++ err) - Right args -> map (L (getLoc open)) args ++ parseToks xs - parseToks (open:close:xs) - | ITinclude_prag str <- getToken open - , ITclose_prag <- getToken close - = map (L (getLoc open)) ["-#include",removeSpaces str] ++ - parseToks xs - parseToks (open:close:xs) - | ITdocOptions str <- getToken open - , ITclose_prag <- getToken close - = map (L (getLoc open)) ["-haddock-opts", removeSpaces str] - ++ parseToks xs - parseToks (open:xs) - | ITlanguage_prag <- getToken open - = parseLanguage xs - parseToks (comment:xs) -- Skip over comments - | isComment (getToken comment) - = parseToks xs - parseToks _ = [] - parseLanguage (L loc (ITconid fs):rest) - = checkExtension dflags (L loc fs) : - case rest of - (L _loc ITcomma):more -> parseLanguage more - (L _loc ITclose_prag):more -> parseToks more - (L loc _):_ -> languagePragParseError dflags loc - [] -> panic "getOptions'.parseLanguage(1) went past eof token" - parseLanguage (tok:_) - = languagePragParseError dflags (getLoc tok) - parseLanguage [] - = panic "getOptions'.parseLanguage(2) went past eof token" - - isComment :: Token -> Bool - isComment c = - case c of - (ITlineComment {}) -> True - (ITblockComment {}) -> True - (ITdocCommentNext {}) -> True - (ITdocCommentPrev {}) -> True - (ITdocCommentNamed {}) -> True - (ITdocSection {}) -> True - _ -> False - ------------------------------------------------------------------------------ - --- | Complain about non-dynamic flags in OPTIONS pragmas. --- --- Throws a 'SourceError' if the input list is non-empty claiming that the --- input flags are unknown. -checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () -checkProcessArgsResult dflags flags - = when (notNull flags) $ - liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags - where mkMsg (L loc flag) - = mkPlainErrMsg dflags loc $ - (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> - text flag) - ------------------------------------------------------------------------------ - -checkExtension :: DynFlags -> Located FastString -> Located String -checkExtension dflags (L l ext) --- Checks if a given extension is valid, and if so returns --- its corresponding flag. Otherwise it throws an exception. - = let ext' = unpackFS ext in - if ext' `elem` supportedLanguagesAndExtensions - then L l ("-X"++ext') - else unsupportedExtnError dflags l ext' - -languagePragParseError :: DynFlags -> SrcSpan -> a -languagePragParseError dflags loc = - throw $ mkSrcErr $ unitBag $ - (mkPlainErrMsg dflags loc $ - vcat [ text "Cannot parse LANGUAGE pragma" - , text "Expecting comma-separated list of language options," - , text "each starting with a capital letter" - , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]) - -unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a -unsupportedExtnError dflags loc unsup = - throw $ mkSrcErr $ unitBag $ - mkPlainErrMsg dflags loc $ - text "Unsupported extension: " <> text unsup $$ - if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) - where - suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions - - -optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages -optionsErrorMsgs dflags unhandled_flags flags_lines _filename - = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) - where unhandled_flags_lines = [ L l f | f <- unhandled_flags, - L l f' <- flags_lines, f == f' ] - mkMsg (L flagSpan flag) = - ErrUtils.mkPlainErrMsg dflags flagSpan $ - text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag - diff --git a/main/Hooks.hs b/main/Hooks.hs deleted file mode 100644 --- a/main/Hooks.hs +++ /dev/null @@ -1,96 +0,0 @@ --- \section[Hooks]{Low level API hooks} - --- NB: this module is SOURCE-imported by DynFlags, and should primarily --- refer to *types*, rather than *code* --- If you import too muchhere , then the revolting compiler_stage2_dll0_MODULES --- stuff in compiler/ghc.mk makes DynFlags link to too much stuff - -{-# LANGUAGE CPP #-} -module Hooks ( Hooks - , emptyHooks - , lookupHook - , getHooked - -- the hooks: - , dsForeignsHook - , tcForeignImportsHook - , tcForeignExportsHook - , hscFrontendHook - , hscCompileCoreExprHook - , ghcPrimIfaceHook - , runPhaseHook - , runMetaHook - , linkHook - , runRnSpliceHook - , getValueSafelyHook - , createIservProcessHook - ) where - -import DynFlags -import Name -import PipelineMonad -import HscTypes -import HsDecls -import HsBinds -import HsExpr -import OrdList -import Id -import TcRnTypes -import Bag -import RdrName -import CoreSyn -import GHCi.RemoteTypes -import SrcLoc -import Type -import System.Process -import BasicTypes - -import Data.Maybe - -{- -************************************************************************ -* * -\subsection{Hooks} -* * -************************************************************************ --} - --- | Hooks can be used by GHC API clients to replace parts of --- the compiler pipeline. If a hook is not installed, GHC --- uses the default built-in behaviour - -emptyHooks :: Hooks -emptyHooks = Hooks - { dsForeignsHook = Nothing - , tcForeignImportsHook = Nothing - , tcForeignExportsHook = Nothing - , hscFrontendHook = Nothing - , hscCompileCoreExprHook = Nothing - , ghcPrimIfaceHook = Nothing - , runPhaseHook = Nothing - , runMetaHook = Nothing - , linkHook = Nothing - , runRnSpliceHook = Nothing - , getValueSafelyHook = Nothing - , createIservProcessHook = Nothing - } - -data Hooks = Hooks - { dsForeignsHook :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) - , tcForeignImportsHook :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)) - , tcForeignExportsHook :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)) - , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) - , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) - , ghcPrimIfaceHook :: Maybe ModIface - , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)) - , runMetaHook :: Maybe (MetaHook TcM) - , linkHook :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag) - , runRnSpliceHook :: Maybe (HsSplice Name -> RnM (HsSplice Name)) - , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue)) - , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) - } - -getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a -getHooked hook def = fmap (lookupHook hook def) getDynFlags - -lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a -lookupHook hook def = fromMaybe def . hook . hooks diff --git a/main/Hooks.hs-boot b/main/Hooks.hs-boot deleted file mode 100644 --- a/main/Hooks.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Hooks where - -data Hooks - -emptyHooks :: Hooks diff --git a/main/HscMain.hs b/main/HscMain.hs deleted file mode 100644 --- a/main/HscMain.hs +++ /dev/null @@ -1,1806 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-} -{-# OPTIONS_GHC -fprof-auto-top #-} - -------------------------------------------------------------------------------- --- --- | Main API for compiling plain Haskell source code. --- --- This module implements compilation of a Haskell source. It is --- /not/ concerned with preprocessing of source files; this is handled --- in "DriverPipeline". --- --- There are various entry points depending on what mode we're in: --- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and --- "interactive" mode (GHCi). There are also entry points for --- individual passes: parsing, typechecking/renaming, desugaring, and --- simplification. --- --- All the functions here take an 'HscEnv' as a parameter, but none of --- them return a new one: 'HscEnv' is treated as an immutable value --- from here on in (although it has mutable components, for the --- caches). --- --- We use the Hsc monad to deal with warning messages consistently: --- specifically, while executing within an Hsc monad, warnings are --- collected. When a Hsc monad returns to an IO monad, the --- warnings are printed, or compilation aborts if the @-Werror@ --- flag is enabled. --- --- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 --- -------------------------------------------------------------------------------- - -module HscMain - ( - -- * Making an HscEnv - newHscEnv - - -- * Compiling complete source files - , Messager, batchMsg - , HscStatus (..) - , hscIncrementalCompile - , hscCompileCmmFile - - , hscGenHardCode - , hscInteractive - - -- * Running passes separately - , hscParse - , hscTypecheckRename - , hscDesugar - , makeSimpleDetails - , hscSimplify -- ToDo, shouldn't really export this - - -- * Safe Haskell - , hscCheckSafe - , hscGetSafe - - -- * Support for interactive evaluation - , hscParseIdentifier - , hscTcRcLookupName - , hscTcRnGetInfo - , hscIsGHCiMonad - , hscGetModuleInterface - , hscRnImportDecls - , hscTcRnLookupRdrName - , hscStmt, hscStmtWithLocation, hscParsedStmt - , hscDecls, hscDeclsWithLocation - , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType - , hscParseExpr - , hscCompileCoreExpr - -- * Low-level exports for hooks - , hscCompileCoreExpr' - -- We want to make sure that we export enough to be able to redefine - -- hscFileFrontEnd in client code - , hscParse', hscSimplify', hscDesugar', tcRnModule' - , getHscEnv - , hscSimpleIface', hscNormalIface' - , oneShotMsg - , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats - , ioMsgMaybe - , showModuleIndex - , hscAddSptEntries - ) where - -import Data.Data hiding (Fixity, TyCon) -import Id -import GHCi ( addSptEntry ) -import GHCi.RemoteTypes ( ForeignHValue ) -import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) -import Linker -import CoreTidy ( tidyExpr ) -import Type ( Type ) -import {- Kind parts of -} Type ( Kind ) -import CoreLint ( lintInteractiveExpr ) -import VarEnv ( emptyTidyEnv ) -import Panic -import ConLike -import Control.Concurrent - -import Module -import Packages -import RdrName -import HsSyn -import HsDumpAst -import CoreSyn -import StringBuffer -import Parser -import Lexer -import SrcLoc -import TcRnDriver -import TcIface ( typecheckIface ) -import TcRnMonad -import NameCache ( initNameCache ) -import LoadIface ( ifaceStats, initExternalPackageState ) -import PrelInfo -import MkIface -import Desugar -import SimplCore -import TidyPgm -import CorePrep -import CoreToStg ( coreToStg ) -import qualified StgCmm ( codeGen ) -import StgSyn -import CostCentre -import ProfInit -import TyCon -import Name -import SimplStg ( stg2stg ) -import Cmm -import CmmParse ( parseCmmFile ) -import CmmBuildInfoTables -import CmmPipeline -import CmmInfo -import CodeOutput -import InstEnv -import FamInstEnv -import Fingerprint ( Fingerprint ) -import Hooks -import TcEnv - -import DynFlags -import ErrUtils -import Platform ( platformOS, osSubsectionsViaSymbols ) - -import Outputable -import NameEnv -import HscStats ( ppSourceStats ) -import HscTypes -import FastString -import UniqSupply -import Bag -import Exception -import qualified Stream -import Stream (Stream) - -import Util - -import Data.List -import Control.Monad -import Data.IORef -import System.FilePath as FilePath -import System.Directory -import System.IO (fixIO) -import qualified Data.Map as Map -import qualified Data.Set as S -import Data.Set (Set) - -#include "HsVersions.h" - - -{- ********************************************************************** -%* * - Initialisation -%* * -%********************************************************************* -} - -newHscEnv :: DynFlags -> IO HscEnv -newHscEnv dflags = do - eps_var <- newIORef initExternalPackageState - us <- mkSplitUniqSupply 'r' - nc_var <- newIORef (initNameCache us knownKeyNames) - fc_var <- newIORef emptyInstalledModuleEnv - iserv_mvar <- newMVar Nothing - return HscEnv { hsc_dflags = dflags - , hsc_targets = [] - , hsc_mod_graph = [] - , hsc_IC = emptyInteractiveContext dflags - , hsc_HPT = emptyHomePackageTable - , hsc_EPS = eps_var - , hsc_NC = nc_var - , hsc_FC = fc_var - , hsc_type_env_var = Nothing - , hsc_iserv = iserv_mvar - } - --- ----------------------------------------------------------------------------- - -getWarnings :: Hsc WarningMessages -getWarnings = Hsc $ \_ w -> return (w, w) - -clearWarnings :: Hsc () -clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) - -logWarnings :: WarningMessages -> Hsc () -logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) - -getHscEnv :: Hsc HscEnv -getHscEnv = Hsc $ \e w -> return (e, w) - -handleWarnings :: Hsc () -handleWarnings = do - dflags <- getDynFlags - w <- getWarnings - liftIO $ printOrThrowWarnings dflags w - clearWarnings - --- | log warning in the monad, and if there are errors then --- throw a SourceError exception. -logWarningsReportErrors :: Messages -> Hsc () -logWarningsReportErrors (warns,errs) = do - logWarnings warns - when (not $ isEmptyBag errs) $ throwErrors errs - --- | Throw some errors. -throwErrors :: ErrorMessages -> Hsc a -throwErrors = liftIO . throwIO . mkSrcErr - --- | Deal with errors and warnings returned by a compilation step --- --- In order to reduce dependencies to other parts of the compiler, functions --- outside the "main" parts of GHC return warnings and errors as a parameter --- and signal success via by wrapping the result in a 'Maybe' type. This --- function logs the returned warnings and propagates errors as exceptions --- (of type 'SourceError'). --- --- This function assumes the following invariants: --- --- 1. If the second result indicates success (is of the form 'Just x'), --- there must be no error messages in the first result. --- --- 2. If there are no error messages, but the second result indicates failure --- there should be warnings in the first result. That is, if the action --- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a -ioMsgMaybe ioA = do - ((warns,errs), mb_r) <- liftIO ioA - logWarnings warns - case mb_r of - Nothing -> throwErrors errs - Just r -> ASSERT( isEmptyBag errs ) return r - --- | like ioMsgMaybe, except that we ignore error messages and return --- 'Nothing' instead. -ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a) -ioMsgMaybe' ioA = do - ((warns,_errs), mb_r) <- liftIO $ ioA - logWarnings warns - return mb_r - --- ----------------------------------------------------------------------------- --- | Lookup things in the compiler's environment - -hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name] -hscTcRnLookupRdrName hsc_env0 rdr_name - = runInteractiveHsc hsc_env0 $ - do { hsc_env <- getHscEnv - ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name } - -hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) -hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ioMsgMaybe' $ tcRnLookupName hsc_env name - -- ignore errors: the only error we're likely to get is - -- "name not found", and the Maybe in the return type - -- is used to indicate that. - -hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst])) -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 RdrName] -> IO GlobalRdrEnv -hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ioMsgMaybe $ tcRnImportDecls hsc_env import_decls - --- ----------------------------------------------------------------------------- --- | parse a file, returning the abstract syntax - -hscParse :: HscEnv -> ModSummary -> IO HsParsedModule -hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary - --- internal version, that doesn't fail due to -Werror -hscParse' :: ModSummary -> Hsc HsParsedModule -hscParse' mod_summary - | Just r <- ms_parsed_mod mod_summary = return r - | otherwise = {-# SCC "Parser" #-} - withTiming getDynFlags - (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) - (const ()) $ do - dflags <- getDynFlags - let src_filename = ms_hspp_file mod_summary - maybe_src_buf = ms_hspp_buf mod_summary - - -------------------------- Parser ---------------- - -- sometimes we already have the buffer in memory, perhaps - -- because we needed to parse the imports out of it, or get the - -- module name. - buf <- case maybe_src_buf of - Just b -> return b - Nothing -> liftIO $ hGetStringBuffer src_filename - - let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 - let parseMod | HsigFile == ms_hsc_src mod_summary - = parseSignature - | otherwise = parseModule - - case unP parseMod (mkPState dflags buf loc) of - PFailed span err -> - liftIO $ throwOneError (mkPlainErrMsg dflags span err) - - POk pst rdr_module -> do - logWarningsReportErrors (getMessages pst dflags) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $ - ppr rdr_module - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $ - text (showAstData NoBlankSrcSpan rdr_module) - liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $ - ppSourceStats False rdr_module - - -- To get the list of extra source files, we take the list - -- that the parser gave us, - -- - eliminate files beginning with '<'. gcc likes to use - -- pseudo-filenames like "" and "" - -- - normalise them (elimiante 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 - - return HsParsedModule { - hpm_module = rdr_module, - hpm_src_files = srcs2, - hpm_annotations - = (Map.fromListWith (++) $ annotations pst, - Map.fromList $ ((noSrcSpan,comment_q pst) - :(annotations_comments pst))) - } - --- XXX: should this really be a Maybe X? Check under which circumstances this --- can become a Nothing and decide whether this should instead throw an --- exception/signal an error. -type RenamedStuff = - (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], - Maybe LHsDocString)) - --- ----------------------------------------------------------------------------- --- | If the renamed source has been kept, extract it. Dump it if requested. -extract_renamed_stuff :: TcGblEnv -> Hsc (TcGblEnv, RenamedStuff) -extract_renamed_stuff tc_result = do - - -- This 'do' is in the Maybe monad! - let rn_info = do decl <- tcg_rn_decls tc_result - let imports = tcg_rn_imports tc_result - exports = tcg_rn_exports tc_result - doc_hdr = tcg_doc_hdr tc_result - return (decl,imports,exports,doc_hdr) - - dflags <- getDynFlags - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $ - text (showAstData NoBlankSrcSpan rn_info) - - return (tc_result, rn_info) - - --- ----------------------------------------------------------------------------- --- | Rename and typecheck a module, additionally returning the renamed syntax -hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule - -> IO (TcGblEnv, RenamedStuff) -hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do - tc_result <- hscTypecheck True mod_summary (Just rdr_module) - extract_renamed_stuff tc_result - - -hscTypecheck :: Bool -- ^ Keep renamed source? - -> ModSummary -> Maybe HsParsedModule - -> Hsc TcGblEnv -hscTypecheck keep_rn mod_summary mb_rdr_module = do - tc_result <- hscTypecheck' keep_rn mod_summary mb_rdr_module - _ <- extract_renamed_stuff tc_result - return tc_result - - -hscTypecheck' :: Bool -- ^ Keep renamed source? - -> ModSummary -> Maybe HsParsedModule - -> Hsc TcGblEnv -hscTypecheck' keep_rn mod_summary mb_rdr_module = do - hsc_env <- getHscEnv - let hsc_src = ms_hsc_src mod_summary - dflags = hsc_dflags hsc_env - outer_mod = ms_mod mod_summary - mod_name = moduleName outer_mod - outer_mod' = mkModule (thisPackage dflags) mod_name - inner_mod = canonicalizeHomeModule dflags mod_name - src_filename = ms_hspp_file mod_summary - real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 - MASSERT( moduleUnitId outer_mod == thisPackage dflags ) - if hsc_src == HsigFile && not (isHoleModule inner_mod) - then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc - else - do hpm <- case mb_rdr_module of - Just hpm -> return hpm - Nothing -> hscParse' mod_summary - tc_result0 <- tcRnModule' hsc_env mod_summary keep_rn hpm - if hsc_src == HsigFile - then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing - ioMsgMaybe $ - tcRnMergeSignatures hsc_env hpm tc_result0 iface - else return tc_result0 - --- wrapper around tcRnModule to handle safe haskell extras -tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule - -> Hsc TcGblEnv -tcRnModule' hsc_env sum save_rn_syntax mod = do - tcg_res <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src 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) - dflags <- getDynFlags - 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 $ do - case wopt Opt_WarnSafe dflags of - True -> (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnSafe) $ - mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ - errSafe tcg_res') - False | safeHaskell dflags == Sf_Trustworthy && - wopt Opt_WarnTrustworthySafe dflags -> - (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ - mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $ - errTwthySafe tcg_res') - False -> return () - return tcg_res' - where - pprMod t = ppr $ moduleName $ tcg_mod t - errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" - errTwthySafe t = quotes (pprMod t) - <+> text "is marked as Trustworthy but has been inferred as safe!" - --- | Convert a typechecked module to Core -hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts -hscDesugar hsc_env mod_summary tc_result = - runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result - -hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts -hscDesugar' mod_location tc_result = do - hsc_env <- getHscEnv - r <- ioMsgMaybe $ - {-# SCC "deSugar" #-} - deSugar hsc_env mod_location tc_result - - -- always check -Werror after desugaring, this is the last opportunity for - -- warnings to arise before the backend. - handleWarnings - return r - --- | Make a 'ModDetails' from the results of typechecking. Used when --- typechecking only, as opposed to full compilation. -makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails -makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result - - -{- ********************************************************************** -%* * - The main compiler pipeline -%* * -%********************************************************************* -} - -{- - -------------------------------- - The compilation proper - -------------------------------- - -It's the task of the compilation proper to compile Haskell, hs-boot and core -files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all -(the module is still parsed and type-checked. This feature is mostly used by -IDE's and the likes). Compilation can happen in either 'one-shot', 'batch', -'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' -mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode -targets byte-code. - -The modes are kept separate because of their different types and meanings: - - * In 'one-shot' mode, we're only compiling a single file and can therefore - discard the new ModIface and ModDetails. This is also the reason it only - targets hard-code; compiling to byte-code or nothing doesn't make sense when - we discard the result. - - * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface - and ModDetails. 'Batch' mode doesn't target byte-code since that require us to - return the newly compiled byte-code. - - * 'Nothing' mode has exactly the same type as 'batch' mode but they're still - kept separate. This is because compiling to nothing is fairly special: We - don't output any interface files, we don't run the simplifier and we don't - generate any code. - - * 'Interactive' mode is similar to 'batch' mode except that we return the - compiled byte-code together with the ModIface and ModDetails. - -Trying to compile a hs-boot file to byte-code will result in a run-time error. -This is the only thing that isn't caught by the type-system. --} - - -type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO () - --- | This function runs GHC's frontend with recompilation --- avoidance. Specifically, it checks if recompilation is needed, --- and if it is, it parses and typechecks the input module. --- It does not write out the results of typechecking (See --- compileOne and hscIncrementalCompile). -hscIncrementalFrontend :: Bool -- always do basic recompilation check? - -> Maybe TcGblEnv - -> Maybe Messager - -> ModSummary - -> SourceModified - -> Maybe ModIface -- Old interface, if available - -> (Int,Int) -- (i,n) = module i of n (for msgs) - -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint)) - -hscIncrementalFrontend - always_do_basic_recompilation_check m_tc_result - mHscMessage mod_summary source_modified mb_old_iface mod_index - = do - hsc_env <- getHscEnv - - let msg what = case mHscMessage of - Just hscMessage -> hscMessage hsc_env mod_index what mod_summary - Nothing -> return () - - skip iface = do - liftIO $ msg UpToDate - return $ Left iface - - compile mb_old_hash reason = do - liftIO $ msg reason - result <- genericHscFrontend mod_summary - return $ Right (result, mb_old_hash) - - stable = case source_modified of - SourceUnmodifiedAndStable -> True - _ -> False - - case m_tc_result of - Just tc_result - | not always_do_basic_recompilation_check -> - return $ Right (FrontendTypecheck tc_result, Nothing) - _ -> do - (recomp_reqd, mb_checked_iface) - <- {-# SCC "checkOldIface" #-} - liftIO $ checkOldIface hsc_env mod_summary - source_modified mb_old_iface - -- save the interface that comes back from checkOldIface. - -- In one-shot mode we don't have the old iface until this - -- point, when checkOldIface reads it from the disk. - let mb_old_hash = fmap mi_iface_hash mb_checked_iface - - case mb_checked_iface of - Just iface | not (recompileRequired recomp_reqd) -> - -- If the module used TH splices when it was last - -- compiled, then the recompilation check is not - -- accurate enough (#481) and we must ignore - -- it. However, if the module is stable (none of - -- the modules it depends on, directly or - -- indirectly, changed), then we *can* skip - -- recompilation. This is why the SourceModified - -- type contains SourceUnmodifiedAndStable, and - -- it's pretty important: otherwise ghc --make - -- would always recompile TH modules, even if - -- nothing at all has changed. Stability is just - -- the same check that make is doing for us in - -- one-shot mode. - case m_tc_result of - Nothing - | mi_used_th iface && not stable -> - compile mb_old_hash (RecompBecause "TH") - _ -> - skip iface - _ -> - case m_tc_result of - Nothing -> compile mb_old_hash recomp_reqd - Just tc_result -> - return $ Right (FrontendTypecheck tc_result, mb_old_hash) - -genericHscFrontend :: ModSummary -> Hsc FrontendResult -genericHscFrontend mod_summary = - getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary) - -genericHscFrontend' :: ModSummary -> Hsc FrontendResult -genericHscFrontend' mod_summary - = FrontendTypecheck `fmap` hscFileFrontEnd mod_summary - --------------------------------------------------------------- --- Compilers --------------------------------------------------------------- - --- Compile Haskell/boot in OneShot mode. -hscIncrementalCompile :: Bool - -> Maybe TcGblEnv - -> Maybe Messager - -> HscEnv - -> ModSummary - -> SourceModified - -> Maybe ModIface - -> (Int,Int) - -- HomeModInfo does not contain linkable, since we haven't - -- code-genned yet - -> IO (HscStatus, HomeModInfo) -hscIncrementalCompile always_do_basic_recompilation_check m_tc_result - mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index - = do - -- One-shot mode needs a knot-tying mutable variable for interface - -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. - -- See also Note [hsc_type_env_var hack] - type_env_var <- newIORef emptyNameEnv - let mod = ms_mod mod_summary - hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env')) - = hsc_env' { hsc_type_env_var = Just (mod, type_env_var) } - | otherwise - = hsc_env' - - -- NB: enter Hsc monad here so that we don't bail out early with - -- -Werror on typechecker warnings; we also want to run the desugarer - -- to get those warnings too. (But we'll always exit at that point - -- because the desugarer runs ioMsgMaybe.) - runHsc hsc_env $ do - let dflags = hsc_dflags hsc_env - - e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage - mod_summary source_modified mb_old_iface mod_index - case e of - -- We didn't need to do any typechecking; the old interface - -- file on disk was good enough. - Left iface -> do - -- Knot tying! See Note [Knot-tying typecheckIface] - hmi <- liftIO . fixIO $ \hmi' -> do - let hsc_env' = - hsc_env { - hsc_HPT = addToHpt (hsc_HPT hsc_env) - (ms_mod_name mod_summary) hmi' - } - -- NB: This result is actually not that useful - -- in one-shot mode, since we're not going to do - -- any further typechecking. It's much more useful - -- in make mode, since this HMI will go into the HPT. - details <- genModDetails hsc_env' iface - return HomeModInfo{ - hm_details = details, - hm_iface = iface, - hm_linkable = Nothing } - return (HscUpToDate, hmi) - -- We finished type checking. (mb_old_hash is the hash of - -- the interface that existed on disk; it's possible we had - -- to retypecheck but the resulting interface is exactly - -- the same.) - Right (FrontendTypecheck tc_result, mb_old_hash) -> do - (status, hmi, no_change) - <- case ms_hsc_src mod_summary of - HsSrcFile | hscTarget dflags /= HscNothing -> - finish hsc_env mod_summary tc_result mb_old_hash - _ -> - finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash - liftIO $ hscMaybeWriteIface dflags (hm_iface hmi) no_change mod_summary - return (status, hmi) - --- Generates and writes out the final interface for a typecheck. -finishTypecheckOnly :: HscEnv - -> ModSummary - -> TcGblEnv - -> Maybe Fingerprint - -> Hsc (HscStatus, HomeModInfo, Bool) -finishTypecheckOnly hsc_env summary tc_result mb_old_hash = do - let dflags = hsc_dflags hsc_env - (iface, changed, details) <- liftIO $ hscSimpleIface hsc_env tc_result mb_old_hash - let hsc_status = - case (hscTarget dflags, ms_hsc_src summary) of - (HscNothing, _) -> HscNotGeneratingCode - (_, HsBootFile) -> HscUpdateBoot - (_, HsigFile) -> HscUpdateSig - _ -> panic "finishTypecheckOnly" - return (hsc_status, - HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Nothing }, - changed) - --- Runs the post-typechecking frontend (desugar and simplify), --- and then generates and writes out the final interface. We want --- to write the interface AFTER simplification so we can get --- as up-to-date and good unfoldings and other info as possible --- in the interface file. This is only ever run for HsSrcFile, --- and NOT for HscNothing. -finish :: HscEnv - -> ModSummary - -> TcGblEnv - -> Maybe Fingerprint - -> Hsc (HscStatus, HomeModInfo, Bool) -finish hsc_env summary tc_result mb_old_hash = do - let dflags = hsc_dflags hsc_env - MASSERT( ms_hsc_src summary == HsSrcFile ) - MASSERT( hscTarget dflags /= HscNothing ) - guts0 <- hscDesugar' (ms_location summary) tc_result - guts <- hscSimplify' guts0 - (iface, changed, details, cgguts) <- liftIO $ hscNormalIface hsc_env guts mb_old_hash - - return (HscRecomp cgguts summary, - HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Nothing }, - changed) - -hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO () -hscMaybeWriteIface dflags iface changed summary = - let force_write_interface = gopt Opt_WriteInterface dflags - write_interface = case hscTarget dflags of - HscNothing -> False - HscInterpreted -> False - _ -> True - in when (write_interface || force_write_interface) $ - hscWriteIface dflags iface changed summary - --------------------------------------------------------------- --- NoRecomp handlers --------------------------------------------------------------- - --- NB: this must be knot-tied appropriately, see hscIncrementalCompile -genModDetails :: HscEnv -> ModIface -> IO ModDetails -genModDetails hsc_env old_iface - = do - new_details <- {-# SCC "tcRnIface" #-} - initIfaceLoad hsc_env (typecheckIface old_iface) - dumpIfaceStats hsc_env - return new_details - --------------------------------------------------------------- --- Progress displayers. --------------------------------------------------------------- - -oneShotMsg :: HscEnv -> RecompileRequired -> IO () -oneShotMsg hsc_env recomp = - case recomp of - UpToDate -> - compilationProgressMsg (hsc_dflags hsc_env) $ - "compilation IS NOT required" - _ -> - return () - -batchMsg :: Messager -batchMsg hsc_env mod_index recomp mod_summary = - case recomp of - MustCompile -> showMsg "Compiling " "" - UpToDate - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" - | otherwise -> return () - RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") - where - dflags = hsc_dflags hsc_env - showMsg msg reason = - compilationProgressMsg dflags $ - (showModuleIndex mod_index ++ - msg ++ showModMsg dflags (hscTarget dflags) - (recompileRequired recomp) mod_summary) - ++ reason - --------------------------------------------------------------- --- FrontEnds --------------------------------------------------------------- - --- | Given a 'ModSummary', parses and typechecks it, returning the --- 'TcGblEnv' resulting from type-checking. -hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv -hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing - --------------------------------------------------------------- --- Safe Haskell --------------------------------------------------------------- - --- Note [Safe Haskell Trust Check] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Safe Haskell checks that an import is trusted according to the following --- rules for an import of module M that resides in Package P: --- --- * If M is recorded as Safe and all its trust dependencies are OK --- then M is considered safe. --- * If M is recorded as Trustworthy and P is considered trusted and --- all M's trust dependencies are OK then M is considered safe. --- --- By trust dependencies we mean that the check is transitive. So if --- a module M that is Safe relies on a module N that is trustworthy, --- importing module M will first check (according to the second case) --- that N is trusted before checking M is trusted. --- --- This is a minimal description, so please refer to the user guide --- for more details. The user guide is also considered the authoritative --- source in this matter, not the comments or code. - - --- Note [Safe Haskell Inference] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Safe Haskell does Safe inference on modules that don't have any specific --- safe haskell mode flag. The basic approach to this is: --- * When deciding if we need to do a Safe language check, treat --- an unmarked module as having -XSafe mode specified. --- * For checks, don't throw errors but return them to the caller. --- * Caller checks if there are errors: --- * For modules explicitly marked -XSafe, we throw the errors. --- * For unmarked modules (inference mode), we drop the errors --- and mark the module as being Unsafe. --- --- It used to be that we only did safe inference on modules that had no Safe --- Haskell flags, but now we perform safe inference on all modules as we want --- to allow users to set the `-Wsafe`, `-Wunsafe` and --- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a --- user can ensure their assumptions are correct and see reasons for why a --- module is safe or unsafe. --- --- This is tricky as we must be careful when we should throw an error compared --- to just warnings. For checking safe imports we manage it as two steps. First --- we check any imports that are required to be safe, then we check all other --- imports to see if we can infer them to be safe. - - --- | Check that the safe imports of the module being compiled are valid. --- If not we either issue a compilation error if the module is explicitly --- using Safe Haskell, or mark the module as unsafe if we're in safe --- inference mode. -hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv -hscCheckSafeImports tcg_env = do - dflags <- getDynFlags - tcg_env' <- checkSafeImports dflags tcg_env - checkRULES dflags tcg_env' - - where - checkRULES dflags tcg_env' = do - case safeLanguageOn dflags of - True -> do - -- XSafe: we nuke user written RULES - logWarnings $ warns dflags (tcg_rules tcg_env') - return tcg_env' { tcg_rules = [] } - False - -- SafeInferred: user defined RULES, so not safe - | safeInferOn dflags && not (null $ tcg_rules tcg_env') - -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') - - -- Trustworthy OR SafeInferred: with no RULES - | otherwise - -> return tcg_env' - - warns dflags rules = listToBag $ map (warnRules dflags) rules - warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) = - mkPlainWarnMsg dflags 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 pacakge --- is trusted. See the Note [Safe Haskell Trust Check] above for more --- information. --- --- The code for this is quite tricky as the whole algorithm is done in a few --- distinct phases in different parts of the code base. See --- RnNames.rnImportDecl for where package trust dependencies for a module are --- collected and unioned. Specifically see the Note [RnNames . Tracking Trust --- Transitively] and the Note [RnNames . Trust Own Package]. -checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv -checkSafeImports dflags tcg_env - = do - imps <- mapM condense imports' - let (safeImps, regImps) = partition (\(_,_,s) -> s) imps - - -- We want to use the warning state specifically for detecting if safe - -- inference has failed, so store and clear any existing warnings. - oldErrs <- getWarnings - clearWarnings - - -- Check safe imports are correct - safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps - safeErrs <- getWarnings - clearWarnings - - -- Check non-safe imports are correct if inferring safety - -- See the Note [Safe Haskell Inference] - (infErrs, infPkgs) <- case (safeInferOn dflags) of - False -> return (emptyBag, S.empty) - True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps - infErrs <- getWarnings - clearWarnings - return (infErrs, infPkgs) - - -- restore old errors - logWarnings oldErrs - - case (isEmptyBag safeErrs) of - -- Failed safe check - False -> liftIO . throwIO . mkSrcErr $ safeErrs - - -- Passed safe check - True -> do - let infPassed = isEmptyBag infErrs - tcg_env' <- case (not infPassed) of - True -> markUnsafeInfer tcg_env infErrs - False -> return tcg_env - when (packageTrustOn dflags) $ checkPkgTrust dflags pkgReqs - let newTrust = pkgTrustReqs safePkgs infPkgs infPassed - return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } - - where - impInfo = tcg_imports tcg_env -- ImportAvails - imports = imp_mods impInfo -- ImportedMods - imports1 = moduleEnvToList imports -- (Module, [ImportedBy]) - imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal]) - pkgReqs = imp_trust_pkgs impInfo -- [UnitId] - - condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) - condense (_, []) = panic "HscMain.condense: Pattern match failure!" - condense (m, x:xs) = do imv <- foldlM cond' x xs - return (m, imv_span imv, imv_is_safe imv) - - -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) - cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal - cond' v1 v2 - | imv_is_safe v1 /= imv_is_safe v2 - = throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1) - (text "Module" <+> ppr (imv_name v1) <+> - (text $ "is imported both as a safe and unsafe import!")) - | otherwise - = return v1 - - -- easier interface to work with - checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId) - checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l - - -- what pkg's to add to our trust requirements - pkgTrustReqs :: Set InstalledUnitId -> Set InstalledUnitId -> Bool -> ImportAvails - pkgTrustReqs req inf infPassed | safeInferOn dflags - && safeHaskell dflags == Sf_None && infPassed - = emptyImportAvails { - imp_trust_pkgs = req `S.union` inf - } - pkgTrustReqs _ _ _ | 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' dflags m l - when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs - errs <- getWarnings - return $ isEmptyBag errs - --- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId) -hscGetSafe hsc_env m l = runHsc hsc_env $ do - dflags <- getDynFlags - (self, pkgs) <- hscCheckSafe' dflags 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' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId) -hscCheckSafe' dflags m l = do - (tw, pkgs) <- isModSafe m l - case tw of - False -> return (Nothing, pkgs) - True | isHomePkg m -> return (Nothing, pkgs) - -- TODO: do we also have to check the trust of the instantiation? - -- Not necessary if that is reflected in dependencies - | otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs) - where - isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId) - isModSafe m l = do - iface <- lookup' m - case iface of - -- can't load iface to check trust! - Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l - $ text "Can't load the interface file for" <+> ppr m - <> text ", to check that it can be safely imported" - - -- got iface, check trust - Just iface' -> - let trust = getSafeMode $ mi_trust iface' - trust_own_pkg = mi_trust_pkg iface' - -- check module is trusted - safeM = trust `elem` [Sf_Safe, Sf_Trustworthy] - -- check package is trusted - safeP = packageTrusted trust trust_own_pkg m - -- pkg trust reqs - pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface' - -- General errors we throw but Safe errors we log - errs = case (safeM, safeP) of - (True, True ) -> emptyBag - (True, False) -> pkgTrustErr - (False, _ ) -> modTrustErr - in do - logWarnings errs - return (trust == Sf_Trustworthy, pkgRs) - - where - pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ - sep [ ppr (moduleName m) - <> text ": Can't be safely imported!" - , text "The package (" <> ppr (moduleUnitId m) - <> text ") the module resides in isn't trusted." - ] - modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ - sep [ ppr (moduleName m) - <> text ": Can't be safely imported!" - , text "The module itself isn't safe." ] - - -- | Check the package a module resides in is trusted. Safe compiled - -- modules are trusted without requiring that their package is trusted. For - -- trustworthy modules, modules in the home package are trusted but - -- otherwise we check the package trust flag. - packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool - packageTrusted Sf_None _ _ = False -- shouldn't hit these cases - packageTrusted Sf_Unsafe _ _ = False -- prefer for completeness. - packageTrusted _ _ _ - | not (packageTrustOn dflags) = True - packageTrusted Sf_Safe False _ = True - packageTrusted _ _ m - | isHomePkg m = True - | otherwise = trusted $ getPackageDetails dflags (moduleUnitId 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 dflags homePkgT pkgIfaceT m - -- the 'lookupIfaceByModule' method will always fail when calling from GHCi - -- as the compiler hasn't filled in the various module tables - -- so we need to call 'getModuleInterface' to load from disk - iface' <- case iface of - Just _ -> return iface - Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) - return iface' - - - isHomePkg :: Module -> Bool - isHomePkg m - | thisPackage dflags == moduleUnitId m = True - | otherwise = False - --- | Check the list of packages are trusted. -checkPkgTrust :: DynFlags -> Set InstalledUnitId -> Hsc () -checkPkgTrust dflags pkgs = - case errors of - [] -> return () - _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors - where - errors = S.foldr go [] pkgs - go pkg acc - | trusted $ getInstalledPackageDetails dflags pkg - = acc - | otherwise - = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags) - $ text "The package (" <> ppr pkg <> text ") is required" <> - text " to be trusted but it isn't!" - --- | Set module to unsafe and (potentially) wipe trust information. --- --- Make sure to call this method to set a module to inferred unsafe, it should --- be a central and single failure method. We only wipe the trust information --- when we aren't in a specific Safe Haskell mode. --- --- While we only use this for recording that a module was inferred unsafe, we --- may call it on modules using Trustworthy or Unsafe flags so as to allow --- warning flags for safety to function correctly. See Note [Safe Haskell --- Inference]. -markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv -markUnsafeInfer tcg_env whyUnsafe = do - dflags <- getDynFlags - - when (wopt Opt_WarnUnsafe dflags) - (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $ - mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) - - liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe) - -- NOTE: Only wipe trust when not in an explicity 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 safeHaskell dflags == Sf_None of - True -> return $ tcg_env { tcg_imports = wiped_trust } - False -> return tcg_env - - where - wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } - pprMod = ppr $ moduleName $ tcg_mod tcg_env - whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" - , text "Reason:" - , nest 4 $ (vcat $ badFlags df) $+$ - (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$ - (vcat $ badInsts $ tcg_insts tcg_env) - ] - badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer - badFlag df (str,loc,on,_) - | on df = [mkLocMessage SevOutput (loc df) $ - text str <+> text "is not allowed in Safe Haskell"] - | otherwise = [] - badInsts insts = concat $ map badInst insts - - checkOverlap (NoOverlap _) = False - checkOverlap _ = True - - badInst ins | checkOverlap (overlapMode (is_flag ins)) - = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $ - ppr (overlapMode $ is_flag ins) <+> - text "overlap mode isn't allowed in Safe Haskell"] - | otherwise = [] - - --- | Figure out the final correct safe haskell mode -hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode -hscGetSafeMode tcg_env = do - dflags <- getDynFlags - liftIO $ finalSafeMode dflags tcg_env - --------------------------------------------------------------- --- Simplifiers --------------------------------------------------------------- - -hscSimplify :: HscEnv -> ModGuts -> IO ModGuts -hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts - -hscSimplify' :: ModGuts -> Hsc ModGuts -hscSimplify' ds_result = do - hsc_env <- getHscEnv - {-# SCC "Core2Core" #-} - liftIO $ core2core hsc_env ds_result - --------------------------------------------------------------- --- Interface generators --------------------------------------------------------------- - -hscSimpleIface :: HscEnv - -> TcGblEnv - -> Maybe Fingerprint - -> IO (ModIface, Bool, ModDetails) -hscSimpleIface hsc_env tc_result mb_old_iface - = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface - -hscSimpleIface' :: TcGblEnv - -> Maybe Fingerprint - -> Hsc (ModIface, Bool, ModDetails) -hscSimpleIface' tc_result mb_old_iface = do - hsc_env <- getHscEnv - details <- liftIO $ mkBootModDetailsTc hsc_env tc_result - safe_mode <- hscGetSafeMode tc_result - (new_iface, no_change) - <- {-# SCC "MkFinalIface" #-} - liftIO $ - mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result - -- And the answer is ... - liftIO $ dumpIfaceStats hsc_env - return (new_iface, no_change, details) - -hscNormalIface :: HscEnv - -> ModGuts - -> Maybe Fingerprint - -> IO (ModIface, Bool, ModDetails, CgGuts) -hscNormalIface hsc_env simpl_result mb_old_iface = - runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface - -hscNormalIface' :: ModGuts - -> Maybe Fingerprint - -> Hsc (ModIface, Bool, ModDetails, CgGuts) -hscNormalIface' simpl_result mb_old_iface = do - hsc_env <- getHscEnv - (cg_guts, details) <- {-# SCC "CoreTidy" #-} - liftIO $ tidyProgram hsc_env simpl_result - - -- BUILD THE NEW ModIface and ModDetails - -- and emit external core if necessary - -- This has to happen *after* code gen so that the back-end - -- info has been set. Not yet clear if it matters waiting - -- until after code output - (new_iface, no_change) - <- {-# SCC "MkFinalIface" #-} - liftIO $ - mkIface hsc_env mb_old_iface details simpl_result - - liftIO $ dumpIfaceStats hsc_env - - -- Return the prepared code. - return (new_iface, no_change, details, cg_guts) - --------------------------------------------------------------- --- BackEnd combinators --------------------------------------------------------------- - -hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO () -hscWriteIface dflags iface no_change mod_summary = do - let ifaceFile = ml_hi_file (ms_location mod_summary) - unless no_change $ - {-# SCC "writeIface" #-} - writeIfaceFile dflags ifaceFile iface - whenGeneratingDynamicToo dflags $ do - -- TODO: We should do a no_change check for the dynamic - -- interface file too - -- TODO: Should handle the dynamic hi filename properly - let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags) - dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile - dynDflags = dynamicTooMkDynamicDynFlags dflags - writeIfaceFile dynDflags dynIfaceFile' iface - --- | Compile to hard-code. -hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath - -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)]) - -- ^ @Just f@ <=> _stub.c is f -hscGenHardCode hsc_env cgguts mod_summary output_filename = do - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, - cg_binds = core_binds, - cg_tycons = tycons, - cg_foreign = foreign_stubs0, - cg_foreign_files = foreign_files, - cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info } = cgguts - dflags = hsc_dflags hsc_env - location = ms_location mod_summary - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes - - ------------------- - -- PREPARE FOR CODE GENERATION - -- Do saturation and convert to A-normal form - prepd_binds <- {-# SCC "CorePrep" #-} - corePrepPgm hsc_env this_mod location - core_binds data_tycons - ----------------- Convert to STG ------------------ - (stg_binds, cost_centre_info) - <- {-# SCC "CoreToStg" #-} - myCoreToStg dflags this_mod prepd_binds - - let prof_init = profilingInitCode this_mod cost_centre_info - foreign_stubs = foreign_stubs0 `appendStubC` prof_init - - ------------------ Code generation ------------------ - - -- The back-end is streamed: each top-level function goes - -- from Stg all the way to asm before dealing with the next - -- top-level function, so showPass isn't very useful here. - -- Hence we have one showPass for the whole backend, the - -- next showPass after this will be "Assembler". - withTiming (pure dflags) - (text "CodeGen"<+>brackets (ppr this_mod)) - (const ()) $ do - cmms <- {-# SCC "StgCmm" #-} - doCodeGen hsc_env this_mod data_tycons - cost_centre_info - stg_binds hpc_info - - ------------------ Code output ----------------------- - rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - cmmToRawCmm dflags cmms - - let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" - (ppr a) - return a - rawcmms1 = Stream.mapM dump rawcmms0 - - (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps) - <- {-# SCC "codeOutput" #-} - codeOutput dflags this_mod output_filename location - foreign_stubs foreign_files dependencies rawcmms1 - return (output_filename, stub_c_exists, foreign_fps) - - -hscInteractive :: HscEnv - -> CgGuts - -> ModSummary - -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]) -hscInteractive hsc_env cgguts mod_summary = do - let dflags = hsc_dflags hsc_env - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, - cg_binds = core_binds, - cg_tycons = tycons, - cg_foreign = foreign_stubs, - cg_modBreaks = mod_breaks, - cg_spt_entries = spt_entries } = cgguts - - location = ms_location mod_summary - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes - - ------------------- - -- PREPARE FOR CODE GENERATION - -- Do saturation and convert to A-normal form - prepd_binds <- {-# SCC "CorePrep" #-} - corePrepPgm hsc_env this_mod location core_binds data_tycons - ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks - ------------------ Create f-x-dynamic C-side stuff ----- - (_istub_h_exists, istub_c_exists) - <- outputForeignStubs dflags this_mod location foreign_stubs - return (istub_c_exists, comp_bc, spt_entries) - ------------------------------- - -hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () -hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do - let dflags = hsc_dflags hsc_env - cmm <- ioMsgMaybe $ parseCmmFile dflags filename - liftIO $ do - us <- mkSplitUniqSupply 'S' - let initTopSRT = initUs_ us emptySRT - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm) - (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm - rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup) - let -- Make up a module name to give the NCG. We can't pass bottom here - -- lest we reproduce #11784. - mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename - cmm_mod = mkModule (thisPackage dflags) mod_name - _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] - rawCmms - return () - where - no_loc = ModLocation{ ml_hs_file = Just filename, - ml_hi_file = panic "hscCompileCmmFile: no hi file", - ml_obj_file = panic "hscCompileCmmFile: no obj file" } - --------------------- Stuff for new code gen --------------------- - -doCodeGen :: HscEnv -> Module -> [TyCon] - -> CollectedCCs - -> [StgTopBinding] - -> HpcInfo - -> IO (Stream IO CmmGroup ()) - -- Note we produce a 'Stream' of CmmGroups, so that the - -- backend can be run incrementally. Otherwise it generates all - -- the C-- up front, which has a significant space cost. -doCodeGen hsc_env this_mod data_tycons - cost_centre_info stg_binds hpc_info = do - let dflags = hsc_dflags hsc_env - - let cmm_stream :: Stream IO CmmGroup () - cmm_stream = {-# SCC "StgCmm" #-} - StgCmm.codeGen dflags this_mod data_tycons - cost_centre_info stg_binds hpc_info - - -- codegen consumes a stream of CmmGroup, and produces a new - -- stream of CmmGroup (not necessarily synchronised: one - -- CmmGroup on input may produce many CmmGroups on output due - -- to proc-point splitting). - - let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg - "Cmm produced by codegen" (ppr a) - return a - - ppr_stream1 = Stream.mapM dump1 cmm_stream - - -- We are building a single SRT for the entire module, so - -- we must thread it through all the procedures as we cps-convert them. - us <- mkSplitUniqSupply 'S' - - -- When splitting, we generate one SRT per split chunk, otherwise - -- we generate one SRT for the whole module. - let - pipeline_stream - | gopt Opt_SplitObjs dflags || gopt Opt_SplitSections dflags || - osSubsectionsViaSymbols (platformOS (targetPlatform dflags)) - = {-# SCC "cmmPipeline" #-} - let run_pipeline us cmmgroup = do - let (topSRT', us') = initUs us emptySRT - (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup - let srt | isEmptySRT topSRT = [] - | otherwise = srtToData topSRT - return (us', srt ++ cmmgroup) - - in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1 - return () - - | otherwise - = {-# SCC "cmmPipeline" #-} - let initTopSRT = initUs_ us emptySRT - run_pipeline = cmmPipeline hsc_env - in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1 - Stream.yield (srtToData topSRT) - - let - dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm - "Output Cmm" (ppr a) - return a - - ppr_stream2 = Stream.mapM dump2 pipeline_stream - - return ppr_stream2 - - - -myCoreToStg :: DynFlags -> Module -> CoreProgram - -> IO ( [StgTopBinding] -- output program - , CollectedCCs) -- cost centre info (declared and used) -myCoreToStg dflags this_mod prepd_binds = do - let stg_binds - = {-# SCC "Core2Stg" #-} - coreToStg dflags this_mod prepd_binds - - (stg_binds2, cost_centre_info) - <- {-# SCC "Stg2Stg" #-} - stg2stg dflags this_mod stg_binds - - return (stg_binds2, cost_centre_info) - - -{- ********************************************************************** -%* * -\subsection{Compiling a do-statement} -%* * -%********************************************************************* -} - -{- -When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When -you run it you get a list of HValues that should be the same length as the list -of names; add them to the ClosureEnv. - -A naked expression returns a singleton Name [it]. The stmt is lifted into the -IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes --} - --- | Compile a stmt all the way to an HValue, but don't run it --- --- We return Nothing to indicate an empty statement (or comment only), not a --- parse error. -hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv)) -hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "" 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 RdrName -- ^ The parsed statement - -> IO ( Maybe ([Id] - , ForeignHValue {- IO [HValue] -} - , FixityEnv)) -hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do - -- Rename and typecheck it - (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt - - -- Desugar it - ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr - liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr) - handleWarnings - - -- Then code-gen, and link it - -- It's important NOT to have package 'interactive' as thisUnitId - -- for linking, else we try to link 'main' and can't find it. - -- Whereas the linker already knows to ignore 'interactive' - let src_span = srcLocSpan interactiveSrcLoc - hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr - - return $ Just (ids, hval, fix_env) - --- | Compile a decls -hscDecls :: HscEnv - -> String -- ^ The statement - -> IO ([TyThing], InteractiveContext) -hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "" 1 - --- | Compile a decls -hscDeclsWithLocation :: HscEnv - -> String -- ^ The statement - -> String -- ^ The source - -> Int -- ^ Starting line - -> IO ([TyThing], InteractiveContext) -hscDeclsWithLocation hsc_env0 str source linenumber = - runInteractiveHsc hsc_env0 $ do - L _ (HsModule{ hsmodDecls = decls }) <- - hscParseThingWithLocation source linenumber parseModule str - - {- Rename and typecheck it -} - hsc_env <- getHscEnv - tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls - - {- Grab the new instances -} - -- We grab the whole environment because of the overlapping that may have - -- been done. See the notes at the definition of InteractiveContext - -- (ic_instances) for more details. - let defaults = tcg_default tc_gblenv - - {- Desugar it -} - -- We use a basically null location for iNTERACTIVE - let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, - ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file", - ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"} - ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv - - {- Simplify -} - simpl_mg <- liftIO $ hscSimplify hsc_env ds_result - - {- Tidy -} - (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg - - let !CgGuts{ cg_module = this_mod, - cg_binds = core_binds, - cg_tycons = tycons, - cg_modBreaks = mod_breaks } = tidy_cg - - !ModDetails { md_insts = cls_insts - , md_fam_insts = fam_insts } = mod_details - -- Get the *tidied* cls_insts and fam_insts - - data_tycons = filter isDataTyCon tycons - - {- Prepare For Code Generation -} - -- Do saturation and convert to A-normal form - prepd_binds <- {-# SCC "CorePrep" #-} - liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons - - {- Generate byte code -} - cbc <- liftIO $ byteCodeGen hsc_env this_mod - prepd_binds data_tycons mod_breaks - - let src_span = srcLocSpan interactiveSrcLoc - liftIO $ linkDecls hsc_env src_span cbc - - {- Load static pointer table entries -} - liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) - - let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) - patsyns = mg_patsyns simpl_mg - - ext_ids = [ id | id <- bindersOfBinds core_binds - , isExternalName (idName id) - , not (isDFunId id || isImplicitId id) ] - -- We only need to keep around the external bindings - -- (as decided by TidyPgm), since those are the only ones - -- that might later be looked up by name. But we can exclude - -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes - -- - Implicit Ids, which are implicit in tcs - -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv - - new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns - ictxt = hsc_IC hsc_env - -- See Note [Fixity declarations in GHCi] - fix_env = tcg_fix_env tc_gblenv - new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts - fam_insts defaults fix_env - return (new_tythings, new_ictxt) - --- | Load the given static-pointer table entries into the interpreter. --- See Note [Grand plan for static forms] in StaticPtrTable. -hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () -hscAddSptEntries hsc_env entries = do - let add_spt_entry :: SptEntry -> IO () - add_spt_entry (SptEntry i fpr) = do - val <- getHValue hsc_env (idName i) - addSptEntry hsc_env fpr val - mapM_ add_spt_entry entries - -{- - Note [Fixity declarations in GHCi] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - To support fixity declarations on types defined within GHCi (as requested - in #10018) we record the fixity environment in InteractiveContext. - When we want to evaluate something TcRnDriver.runTcInteractive pulls out this - fixity environment and uses it to initialize the global typechecker environment. - After the typechecker has finished its business, an updated fixity environment - (reflecting whatever fixity declarations were present in the statements we - passed it) will be returned from hscParsedStmt. This is passed to - updateFixityEnv, which will stuff it back into InteractiveContext, to be - used in evaluating the next statement. - --} - -hscImport :: HscEnv -> String -> IO (ImportDecl RdrName) -hscImport hsc_env str = runInteractiveHsc hsc_env $ do - (L _ (HsModule{hsmodImports=is})) <- - hscParseThing parseModule str - case is of - [L _ i] -> return i - _ -> liftIO $ throwOneError $ - mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ - text "parse error in import declaration" - --- | Typecheck an expression (but don't run it) -hscTcExpr :: HscEnv - -> TcRnExprMode - -> String -- ^ The expression - -> IO Type -hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - parsed_expr <- hscParseExpr expr - ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr - --- | Find the kind of a type --- Currently this does *not* generalise the kinds of the type -hscKcType - :: HscEnv - -> Bool -- ^ Normalise the type - -> String -- ^ The type as a string - -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind -hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ty <- hscParseType str - ioMsgMaybe $ tcRnType hsc_env normalise ty - -hscParseExpr :: String -> Hsc (LHsExpr RdrName) -hscParseExpr expr = do - hsc_env <- getHscEnv - maybe_stmt <- hscParseStmt expr - case maybe_stmt of - Just (L _ (BodyStmt expr _ _ _)) -> return expr - _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan - (text "not an expression:" <+> quotes (text expr)) - -hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName)) -hscParseStmt = hscParseThing parseStmt - -hscParseStmtWithLocation :: String -> Int -> String - -> Hsc (Maybe (GhciLStmt RdrName)) -hscParseStmtWithLocation source linenumber stmt = - hscParseThingWithLocation source linenumber parseStmt stmt - -hscParseType :: String -> Hsc (LHsType RdrName) -hscParseType = hscParseThing parseType - -hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) -hscParseIdentifier hsc_env str = - runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str - -hscParseThing :: (Outputable thing, Data thing) - => Lexer.P thing -> String -> Hsc thing -hscParseThing = hscParseThingWithLocation "" 1 - -hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int - -> Lexer.P thing -> String -> Hsc thing -hscParseThingWithLocation source linenumber parser str - = withTiming getDynFlags - (text "Parser [source]") - (const ()) $ {-# SCC "Parser" #-} do - dflags <- getDynFlags - - let buf = stringToStringBuffer str - loc = mkRealSrcLoc (fsLit source) linenumber 1 - - case unP parser (mkPState dflags buf loc) of - PFailed span err -> do - let msg = mkPlainErrMsg dflags span err - throwErrors $ unitBag msg - - POk pst thing -> do - logWarningsReportErrors (getMessages pst dflags) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $ - text $ showAstData NoBlankSrcSpan thing - return thing - - -{- ********************************************************************** -%* * - Desugar, simplify, convert to bytecode, and link an expression -%* * -%********************************************************************* -} - -hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue -hscCompileCoreExpr hsc_env = - lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env - -hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue -hscCompileCoreExpr' hsc_env srcspan ds_expr - = do { let dflags = hsc_dflags hsc_env - - {- Simplify it -} - ; simpl_expr <- simplifyExpr dflags ds_expr - - {- Tidy it (temporary, until coreSat does cloning) -} - ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr - - {- Prepare for codegen -} - ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr - - {- Lint if necessary -} - ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr - - {- Convert to BCOs -} - ; bcos <- coreExprToBCOs hsc_env - (icInteractiveModule (hsc_IC hsc_env)) prepd_expr - - {- link it -} - ; hval <- linkExpr hsc_env srcspan bcos - - ; return hval } - - -{- ********************************************************************** -%* * - Statistics on reading interfaces -%* * -%********************************************************************* -} - -dumpIfaceStats :: HscEnv -> IO () -dumpIfaceStats hsc_env = do - eps <- readIORef (hsc_EPS hsc_env) - dumpIfSet dflags (dump_if_trace || dump_rn_stats) - "Interface statistics" - (ifaceStats eps) - where - dflags = hsc_dflags hsc_env - dump_rn_stats = dopt Opt_D_dump_rn_stats dflags - dump_if_trace = dopt Opt_D_dump_if_trace dflags - - -{- ********************************************************************** -%* * - Progress Messages: Module i of n -%* * -%********************************************************************* -} - -showModuleIndex :: (Int, Int) -> String -showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] " - where - n_str = show n - i_str = show i - padded = replicate (length n_str - length i_str) ' ' ++ i_str diff --git a/main/HscStats.hs b/main/HscStats.hs deleted file mode 100644 --- a/main/HscStats.hs +++ /dev/null @@ -1,180 +0,0 @@ --- | --- Statistics for per-module compilations --- --- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 --- - -{-# LANGUAGE FlexibleContexts #-} - -module HscStats ( ppSourceStats ) where - -import Bag -import HsSyn -import Outputable -import RdrName -import SrcLoc -import Util - -import Data.Char -import Data.Foldable (foldl') - --- | Source Statistics -ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc -ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) - = (if short then hcat else vcat) - (map pp_val - [("ExportAll ", export_all), -- 1 if no export list - ("ExportDecls ", export_ds), - ("ExportModules ", export_ms), - ("Imports ", imp_no), - (" ImpSafe ", imp_safe), - (" ImpQual ", imp_qual), - (" ImpAs ", imp_as), - (" ImpAll ", imp_all), - (" ImpPartial ", imp_partial), - (" ImpHiding ", imp_hiding), - ("FixityDecls ", fixity_sigs), - ("DefaultDecls ", default_ds), - ("TypeDecls ", type_ds), - ("DataDecls ", data_ds), - ("NewTypeDecls ", newt_ds), - ("TypeFamilyDecls ", type_fam_ds), - ("DataConstrs ", data_constrs), - ("DataDerivings ", data_derivs), - ("ClassDecls ", class_ds), - ("ClassMethods ", class_method_ds), - ("DefaultMethods ", default_method_ds), - ("InstDecls ", inst_ds), - ("InstMethods ", inst_method_ds), - ("InstType ", inst_type_ds), - ("InstData ", inst_data_ds), - ("TypeSigs ", bind_tys), - ("ClassOpSigs ", generic_sigs), - ("ValBinds ", val_bind_ds), - ("FunBinds ", fn_bind_ds), - ("PatSynBinds ", patsyn_ds), - ("InlineMeths ", method_inlines), - ("InlineBinds ", bind_inlines), - ("SpecialisedMeths ", method_specs), - ("SpecialisedBinds ", bind_specs) - ]) - where - decls = map unLoc ldecls - - pp_val (_, 0) = empty - pp_val (str, n) - | not short = hcat [text str, int n] - | otherwise = hcat [text (trim str), equals, int n, semi] - - trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) - - (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) - = count_sigs [d | SigD d <- decls] - -- NB: this omits fixity decls on local bindings and - -- in class decls. ToDo - - tycl_decls = [d | TyClD d <- decls] - (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = - countTyClDecls tycl_decls - - inst_decls = [d | InstD d <- decls] - inst_ds = length inst_decls - default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls - val_decls = [d | ValD d <- decls] - - real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } - n_exports = length real_exports - export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False}) - real_exports - export_ds = n_exports - export_ms - export_all = case exports of { Nothing -> 1; _ -> 0 } - - (val_bind_ds, fn_bind_ds, patsyn_ds) - = sum3 (map count_bind val_decls) - - (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) - = sum7 (map import_info imports) - (data_constrs, data_derivs) - = sum2 (map data_info tycl_decls) - (class_method_ds, default_method_ds) - = sum2 (map class_info tycl_decls) - (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) - = sum5 (map inst_info inst_decls) - - count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0,0) - count_bind (PatBind {}) = (0,1,0) - count_bind (FunBind {}) = (0,1,0) - count_bind (PatSynBind {}) = (0,0,1) - count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) - - count_sigs sigs = sum5 (map sig_info sigs) - - sig_info (FixSig {}) = (1,0,0,0,0) - sig_info (TypeSig {}) = (0,1,0,0,0) - sig_info (SpecSig {}) = (0,0,1,0,0) - sig_info (InlineSig {}) = (0,0,0,1,0) - sig_info (ClassOpSig {}) = (0,0,0,0,1) - sig_info _ = (0,0,0,0,0) - - import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual - , ideclAs = as, ideclHiding = spec })) - = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) - safe_info = qual_info - qual_info False = 0 - qual_info True = 1 - as_info Nothing = 0 - as_info (Just _) = 1 - spec_info Nothing = (0,0,0,0,1,0,0) - spec_info (Just (False, _)) = (0,0,0,0,0,1,0) - spec_info (Just (True, _)) = (0,0,0,0,0,0,1) - - data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs - , dd_derivs = L _ derivs}}) - = ( length cs - , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) - 0 derivs ) - data_info _ = (0,0) - - class_info decl@(ClassDecl {}) - = (classops, addpr (sum3 (map count_bind methods))) - where - methods = map unLoc $ bagToList (tcdMeths decl) - (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl)) - class_info _ = (0,0) - - inst_info (TyFamInstD {}) = (0,0,0,1,0) - inst_info (DataFamInstD {}) = (0,0,0,0,1) - inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths - , cid_sigs = inst_sigs - , cid_tyfam_insts = ats - , cid_datafam_insts = adts } }) - = case count_sigs (map unLoc inst_sigs) of - (_,_,ss,is,_) -> - (addpr (sum3 (map count_bind methods)), - ss, is, length ats, length adts) - where - methods = map unLoc $ bagToList inst_meths - - -- TODO: use Sum monoid - addpr :: (Int,Int,Int) -> Int - sum2 :: [(Int, Int)] -> (Int, Int) - sum3 :: [(Int, Int, Int)] -> (Int, Int, Int) - sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int) - sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int) - add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int) - -> (Int, Int, Int, Int, Int, Int, Int) - - addpr (x,y,z) = x+y+z - sum2 = foldr add2 (0,0) - where - add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) - sum3 = foldr add3 (0,0,0) - where - add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) - sum5 = foldr add5 (0,0,0,0,0) - where - add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) - sum7 = foldr add7 (0,0,0,0,0,0,0) - - add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) - diff --git a/main/HscTypes.hs b/main/HscTypes.hs deleted file mode 100644 --- a/main/HscTypes.hs +++ /dev/null @@ -1,3115 +0,0 @@ -{- -(c) The University of Glasgow, 2006 - -\section[HscTypes]{Types for the per-module compiler} --} - -{-# LANGUAGE CPP, ScopedTypeVariables #-} - --- | Types for the per-module compiler -module HscTypes ( - -- * compilation state - HscEnv(..), hscEPS, - FinderCache, FindResult(..), InstalledFindResult(..), - Target(..), TargetId(..), pprTarget, pprTargetId, - ModuleGraph, emptyMG, - HscStatus(..), - IServ(..), - - -- * Hsc monad - Hsc(..), runHsc, runInteractiveHsc, - - -- * Information about modules - ModDetails(..), emptyModDetails, - ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, - ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..), - ForeignSrcLang(..), - - ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary, - msHsFilePath, msHiFilePath, msObjFilePath, - SourceModified(..), - - -- * Information about the module being compiled - -- (re-exported from DriverPhases) - HscSource(..), isHsBootOrSig, hscSourceString, - - - -- * State relating to modules in this package - HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt, - addToHpt, addListToHpt, lookupHptDirectly, listToHpt, - hptCompleteSigs, - hptInstances, hptRules, hptVectInfo, pprHPT, - hptObjs, - - -- * State relating to known packages - ExternalPackageState(..), EpsStats(..), addEpsInStats, - PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, - lookupIfaceByModule, emptyModIface, lookupHptByModule, - - PackageInstEnv, PackageFamInstEnv, PackageRuleBase, - PackageCompleteMatchMap, - - mkSOName, mkHsSOName, soExt, - - -- * Metaprogramming - MetaRequest(..), - MetaResult, -- data constructors not exported to ensure correct response type - metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW, - MetaHook, - - -- * Annotations - prepareAnnotations, - - -- * Interactive context - InteractiveContext(..), emptyInteractiveContext, - icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv, - extendInteractiveContext, extendInteractiveContextWithIds, - substInteractiveContext, - setInteractivePrintName, icInteractiveModule, - InteractiveImport(..), setInteractivePackage, - mkPrintUnqualified, pprModulePrefix, - mkQualPackage, mkQualModule, pkgQual, - - -- * Interfaces - ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, - emptyIfaceWarnCache, mi_boot, mi_fix, - mi_semantic_module, - mi_free_holes, - renameFreeHoles, - - -- * Fixity - FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, - - -- * TyThings and type environments - TyThing(..), tyThingAvailInfo, - tyThingTyCon, tyThingDataCon, tyThingConLike, - tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars, - implicitTyThings, implicitTyConThings, implicitClassThings, - isImplicitTyThing, - - TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, - typeEnvFromEntities, mkTypeEnvWithImplicits, - extendTypeEnv, extendTypeEnvList, - extendTypeEnvWithIds, plusTypeEnv, - lookupTypeEnv, - typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns, - typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, - - -- * MonadThings - MonadThings(..), - - -- * Information on imports and exports - WhetherHasOrphans, IsBootInterface, Usage(..), - Dependencies(..), noDependencies, - updNameCacheIO, - IfaceExport, - - -- * Warnings - Warnings(..), WarningTxt(..), plusWarns, - - -- * Linker stuff - Linkable(..), isObjectLinkable, linkableObjs, - Unlinked(..), CompiledByteCode, - isObject, nameOfObject, isInterpretable, byteCodeOfObject, - - -- * Program coverage - HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, - - -- * Breakpoints - ModBreaks (..), emptyModBreaks, - - -- * Vectorisation information - VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, - noIfaceVectInfo, isNoIfaceVectInfo, - - -- * Safe Haskell information - IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, - trustInfoToNum, numToTrustInfo, IsSafeImport, - - -- * result of the parser - HsParsedModule(..), - - -- * Compilation errors and warnings - SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, - throwOneError, handleSourceError, - handleFlagWarnings, printOrThrowWarnings, - - -- * COMPLETE signature - CompleteMatch(..), CompleteMatchMap, - mkCompleteMatchMap, extendCompleteMatchMap - ) where - -#include "HsVersions.h" - -import ByteCodeTypes -import InteractiveEvalTypes ( Resume ) -import GHCi.Message ( Pipe ) -import GHCi.RemoteTypes -import GHC.ForeignSrcLang - -import UniqFM -import HsSyn -import RdrName -import Avail -import Module -import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) -import FamInstEnv -import CoreSyn ( CoreProgram, RuleBase, CoreRule, CoreVect ) -import Name -import NameEnv -import NameSet -import VarEnv -import VarSet -import Var -import Id -import IdInfo ( IdDetails(..), RecSelParent(..)) -import Type - -import ApiAnnotation ( ApiAnns ) -import Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) -import Class -import TyCon -import CoAxiom -import ConLike -import DataCon -import PatSyn -import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule - , eqTyConName ) -import TysWiredIn -import Packages hiding ( Version(..) ) -import DynFlags -import DriverPhases ( Phase, HscSource(..), isHsBootOrSig, hscSourceString ) -import BasicTypes -import IfaceSyn -import Maybes -import Outputable -import SrcLoc -import Unique -import UniqDFM -import FastString -import StringBuffer ( StringBuffer ) -import Fingerprint -import MonadUtils -import Bag -import Binary -import ErrUtils -import NameCache -import Platform -import Util -import UniqDSet -import GHC.Serialized ( Serialized ) - -import Foreign -import Control.Monad ( guard, liftM, when, ap ) -import Data.Foldable ( foldl' ) -import Data.IORef -import Data.Time -import Exception -import System.FilePath -import Control.Concurrent -import System.Process ( ProcessHandle ) - --- ----------------------------------------------------------------------------- --- Compilation state --- ----------------------------------------------------------------------------- - --- | Status of a compilation to hard-code -data HscStatus - = HscNotGeneratingCode - | HscUpToDate - | HscUpdateBoot - | HscUpdateSig - | HscRecomp CgGuts ModSummary - --- ----------------------------------------------------------------------------- --- The Hsc monad: Passing an environment and warning state - -newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) - -instance Functor Hsc where - fmap = liftM - -instance Applicative Hsc where - pure a = Hsc $ \_ w -> return (a, w) - (<*>) = ap - -instance Monad Hsc where - Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w - case k a of - Hsc k' -> k' e w1 - -instance MonadIO Hsc where - liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) - -instance HasDynFlags Hsc where - getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) - -runHsc :: HscEnv -> Hsc a -> IO a -runHsc hsc_env (Hsc hsc) = do - (a, w) <- hsc hsc_env emptyBag - printOrThrowWarnings (hsc_dflags hsc_env) w - return a - -runInteractiveHsc :: HscEnv -> Hsc a -> IO a --- A variant of runHsc that switches in the DynFlags from the --- InteractiveContext before running the Hsc computation. -runInteractiveHsc hsc_env - = runHsc (hsc_env { hsc_dflags = interactive_dflags }) - where - interactive_dflags = ic_dflags (hsc_IC hsc_env) - --- ----------------------------------------------------------------------------- --- Source Errors - --- When the compiler (HscMain) discovers errors, it throws an --- exception in the IO monad. - -mkSrcErr :: ErrorMessages -> SourceError -mkSrcErr = SourceError - -srcErrorMessages :: SourceError -> ErrorMessages -srcErrorMessages (SourceError msgs) = msgs - -mkApiErr :: DynFlags -> SDoc -> GhcApiError -mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) - -throwOneError :: MonadIO m => ErrMsg -> m ab -throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err - --- | A source error is an error that is caused by one or more errors in the --- source code. A 'SourceError' is thrown by many functions in the --- compilation pipeline. Inside GHC these errors are merely printed via --- 'log_action', but API clients may treat them differently, for example, --- insert them into a list box. If you want the default behaviour, use the --- idiom: --- --- > handleSourceError printExceptionAndWarnings $ do --- > ... api calls that may fail ... --- --- The 'SourceError's error messages can be accessed via 'srcErrorMessages'. --- This list may be empty if the compiler failed due to @-Werror@ --- ('Opt_WarnIsError'). --- --- See 'printExceptionAndWarnings' for more information on what to take care --- of when writing a custom error handler. -newtype SourceError = SourceError ErrorMessages - -instance Show SourceError where - show (SourceError msgs) = unlines . map show . bagToList $ msgs - -instance Exception SourceError - --- | Perform the given action and call the exception handler if the action --- throws a 'SourceError'. See 'SourceError' for more information. -handleSourceError :: (ExceptionMonad m) => - (SourceError -> m a) -- ^ exception handler - -> m a -- ^ action to perform - -> m a -handleSourceError handler act = - gcatch act (\(e :: SourceError) -> handler e) - --- | An error thrown if the GHC API is used in an incorrect fashion. -newtype GhcApiError = GhcApiError String - -instance Show GhcApiError where - show (GhcApiError msg) = msg - -instance Exception GhcApiError - --- | Given a bag of warnings, turn them into an exception if --- -Werror is enabled, or print them out otherwise. -printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () -printOrThrowWarnings dflags warns - | anyBag (isWarnMsgFatal dflags) warns - = throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags - | otherwise - = printBagOfErrors dflags warns - -handleFlagWarnings :: DynFlags -> [Located String] -> IO () -handleFlagWarnings dflags warns - = when (wopt Opt_WarnDeprecatedFlags dflags) $ do - -- It would be nicer if warns :: [Located MsgDoc], but that - -- has circular import problems. - let bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) - | L loc warn <- warns ] - - printOrThrowWarnings dflags bag - -{- -************************************************************************ -* * -\subsection{HscEnv} -* * -************************************************************************ --} - --- | HscEnv is like 'Session', except that some of the fields are immutable. --- An HscEnv is used to compile a single module from plain Haskell source --- code (after preprocessing) to either C, assembly or C--. Things like --- the module graph don't change during a single compilation. --- --- Historical note: \"hsc\" used to be the name of the compiler binary, --- when there was a separate driver and compiler. To compile a single --- module, the driver would invoke hsc on the source code... so nowadays --- we think of hsc as the layer of the compiler that deals with compiling --- a single module. -data HscEnv - = HscEnv { - hsc_dflags :: DynFlags, - -- ^ The dynamic flag settings - - hsc_targets :: [Target], - -- ^ The targets (or roots) of the current session - - hsc_mod_graph :: ModuleGraph, - -- ^ The module graph of the current session - - hsc_IC :: InteractiveContext, - -- ^ The context for evaluating interactive statements - - hsc_HPT :: HomePackageTable, - -- ^ The home package table describes already-compiled - -- home-package modules, /excluding/ the module we - -- are compiling right now. - -- (In one-shot mode the current module is the only - -- home-package module, so hsc_HPT is empty. All other - -- modules count as \"external-package\" modules. - -- However, even in GHCi mode, hi-boot interfaces are - -- demand-loaded into the external-package table.) - -- - -- 'hsc_HPT' is not mutable because we only demand-load - -- external packages; the home package is eagerly - -- loaded, module by module, by the compilation manager. - -- - -- The HPT may contain modules compiled earlier by @--make@ - -- but not actually below the current module in the dependency - -- graph. - -- - -- (This changes a previous invariant: changed Jan 05.) - - hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState), - -- ^ Information about the currently loaded external packages. - -- This is mutable because packages will be demand-loaded during - -- a compilation run as required. - - hsc_NC :: {-# UNPACK #-} !(IORef NameCache), - -- ^ As with 'hsc_EPS', this is side-effected by compiling to - -- reflect sucking in interface files. They cache the state of - -- external interface files, in effect. - - hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), - -- ^ The cached result of performing finding in the file system - - hsc_type_env_var :: Maybe (Module, IORef TypeEnv) - -- ^ Used for one-shot compilation only, to initialise - -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for - -- 'TcRnTypes.TcGblEnv'. See also Note [hsc_type_env_var hack] - - , hsc_iserv :: MVar (Maybe IServ) - -- ^ interactive server process. Created the first - -- time it is needed. - } - --- Note [hsc_type_env_var hack] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- hsc_type_env_var is used to initialize tcg_type_env_var, and --- eventually it is the mutable variable that is queried from --- if_rec_types to get a TypeEnv. So, clearly, it's something --- related to knot-tying (see Note [Tying the knot]). --- hsc_type_env_var is used in two places: initTcRn (where --- it initializes tcg_type_env_var) and initIfaceCheck --- (where it initializes if_rec_types). --- --- But why do we need a way to feed a mutable variable in? Why --- can't we just initialize tcg_type_env_var when we start --- typechecking? The problem is we need to knot-tie the --- EPS, and we may start adding things to the EPS before type --- checking starts. --- --- Here is a concrete example. Suppose we are running --- "ghc -c A.hs", and we have this file system state: --- --- A.hs-boot A.hi-boot **up to date** --- B.hs B.hi **up to date** --- A.hs A.hi **stale** --- --- The first thing we do is run checkOldIface on A.hi. --- checkOldIface will call loadInterface on B.hi so it can --- get its hands on the fingerprints, to find out if A.hi --- needs recompilation. But loadInterface also populates --- the EPS! And so if compilation turns out to be necessary, --- as it is in this case, the thunks we put into the EPS for --- B.hi need to have the correct if_rec_types mutable variable --- to query. --- --- If the mutable variable is only allocated WHEN we start --- typechecking, then that's too late: we can't get the --- information to the thunks. So we need to pre-commit --- to a type variable in 'hscIncrementalCompile' BEFORE we --- check the old interface. --- --- This is all a massive hack because arguably checkOldIface --- should not populate the EPS. But that's a refactor for --- another day. - - -data IServ = IServ - { iservPipe :: Pipe - , iservProcess :: ProcessHandle - , iservLookupSymbolCache :: IORef (UniqFM (Ptr ())) - , iservPendingFrees :: [HValueRef] - } - --- | Retrieve the ExternalPackageState cache. -hscEPS :: HscEnv -> IO ExternalPackageState -hscEPS hsc_env = readIORef (hsc_EPS hsc_env) - --- | A compilation target. --- --- A target may be supplied with the actual text of the --- module. If so, use this instead of the file contents (this --- is for use in an IDE where the file hasn't been saved by --- the user yet). -data Target - = Target { - targetId :: TargetId, -- ^ module or filename - targetAllowObjCode :: Bool, -- ^ object code allowed? - targetContents :: Maybe (StringBuffer,UTCTime) - -- ^ in-memory text buffer? - } - -data TargetId - = TargetModule ModuleName - -- ^ A module name: search for the file - | TargetFile FilePath (Maybe Phase) - -- ^ A filename: preprocess & parse it to find the module name. - -- If specified, the Phase indicates how to compile this file - -- (which phase to start from). Nothing indicates the starting phase - -- should be determined from the suffix of the filename. - deriving Eq - -pprTarget :: Target -> SDoc -pprTarget (Target id obj _) = - (if obj then char '*' else empty) <> pprTargetId id - -instance Outputable Target where - ppr = pprTarget - -pprTargetId :: TargetId -> SDoc -pprTargetId (TargetModule m) = ppr m -pprTargetId (TargetFile f _) = text f - -instance Outputable TargetId where - ppr = pprTargetId - -{- -************************************************************************ -* * -\subsection{Package and Module Tables} -* * -************************************************************************ --} - --- | Helps us find information about modules in the home package -type HomePackageTable = DModuleNameEnv HomeModInfo - -- Domain = modules in the home package that have been fully compiled - -- "home" unit id cached here for convenience - --- | Helps us find information about modules in the imported packages -type PackageIfaceTable = ModuleEnv ModIface - -- Domain = modules in the imported packages - --- | Constructs an empty HomePackageTable -emptyHomePackageTable :: HomePackageTable -emptyHomePackageTable = emptyUDFM - --- | Constructs an empty PackageIfaceTable -emptyPackageIfaceTable :: PackageIfaceTable -emptyPackageIfaceTable = emptyModuleEnv - -pprHPT :: HomePackageTable -> SDoc --- A bit arbitrary for now -pprHPT hpt = pprUDFM hpt $ \hms -> - vcat [ hang (ppr (mi_module (hm_iface hm))) - 2 (ppr (md_types (hm_details hm))) - | hm <- hms ] - -lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo -lookupHpt = lookupUDFM - -lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo -lookupHptDirectly = lookupUDFM_Directly - -eltsHpt :: HomePackageTable -> [HomeModInfo] -eltsHpt = eltsUDFM - -filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable -filterHpt = filterUDFM - -allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool -allHpt = allUDFM - -mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable -mapHpt = mapUDFM - -delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable -delFromHpt = delFromUDFM - -addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable -addToHpt = addToUDFM - -addListToHpt - :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable -addListToHpt = addListToUDFM - -listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable -listToHpt = listToUDFM - -lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo --- The HPT is indexed by ModuleName, not Module, --- we must check for a hit on the right Module -lookupHptByModule hpt mod - = case lookupHpt hpt (moduleName mod) of - Just hm | mi_module (hm_iface hm) == mod -> Just hm - _otherwise -> Nothing - --- | Information about modules in the package being compiled -data HomeModInfo - = HomeModInfo { - hm_iface :: !ModIface, - -- ^ The basic loaded interface file: every loaded module has one of - -- these, even if it is imported from another package - hm_details :: !ModDetails, - -- ^ Extra information that has been created from the 'ModIface' for - -- the module, typically during typechecking - hm_linkable :: !(Maybe Linkable) - -- ^ The actual artifact we would like to link to access things in - -- this module. - -- - -- 'hm_linkable' might be Nothing: - -- - -- 1. If this is an .hs-boot module - -- - -- 2. Temporarily during compilation if we pruned away - -- the old linkable because it was out of date. - -- - -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields - -- in the 'HomePackageTable' will be @Just@. - -- - -- When re-linking a module ('HscMain.HscNoRecomp'), we construct the - -- 'HomeModInfo' by building a new 'ModDetails' from the old - -- 'ModIface' (only). - } - --- | Find the 'ModIface' for a 'Module', searching in both the loaded home --- and external package module information -lookupIfaceByModule - :: DynFlags - -> HomePackageTable - -> PackageIfaceTable - -> Module - -> Maybe ModIface -lookupIfaceByModule _dflags hpt pit mod - = case lookupHptByModule hpt mod of - Just hm -> Just (hm_iface hm) - Nothing -> lookupModuleEnv pit mod - --- If the module does come from the home package, why do we look in the PIT as well? --- (a) In OneShot mode, even home-package modules accumulate in the PIT --- (b) Even in Batch (--make) mode, there is *one* case where a home-package --- module is in the PIT, namely GHC.Prim when compiling the base package. --- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package --- of its own, but it doesn't seem worth the bother. - -hptCompleteSigs :: HscEnv -> [CompleteMatch] -hptCompleteSigs = hptAllThings (md_complete_sigs . hm_details) - --- | Find all the instance declarations (of classes and families) from --- the Home Package Table filtered by the provided predicate function. --- Used in @tcRnImports@, to select the instances that are in the --- transitive closure of imports from the currently compiled module. -hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) -hptInstances hsc_env want_this_module - = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do - guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) - let details = hm_details mod_info - return (md_insts details, md_fam_insts details) - in (concat insts, concat famInsts) - --- | Get the combined VectInfo of all modules in the home package table. In --- contrast to instances and rules, we don't care whether the modules are --- "below" us in the dependency sense. The VectInfo of those modules not "below" --- us does not affect the compilation of the current module. -hptVectInfo :: HscEnv -> VectInfo -hptVectInfo = concatVectInfo . hptAllThings ((: []) . md_vect_info . hm_details) - --- | Get rules from modules "below" this one (in the dependency sense) -hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] -hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False - - --- | Get annotations from modules "below" this one (in the dependency sense) -hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation] -hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps -hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env - -hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] -hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env)) - --- | Get things from modules "below" this one (in the dependency sense) --- C.f Inst.hptInstances -hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a] -hptSomeThingsBelowUs extract include_hi_boot hsc_env deps - | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] - - | otherwise - = let hpt = hsc_HPT hsc_env - in - [ thing - | -- Find each non-hi-boot module below me - (mod, is_boot_mod) <- deps - , include_hi_boot || not is_boot_mod - - -- unsavoury: when compiling the base package with --make, we - -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't - -- be in the HPT, because we never compile it; it's in the EPT - -- instead. ToDo: clean up, and remove this slightly bogus filter: - , mod /= moduleName gHC_PRIM - - -- Look it up in the HPT - , let things = case lookupHpt hpt mod of - Just info -> extract info - Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg [] - msg = vcat [text "missing module" <+> ppr mod, - text "Probable cause: out-of-date interface files"] - -- This really shouldn't happen, but see Trac #962 - - -- And get its dfuns - , thing <- things ] - -hptObjs :: HomePackageTable -> [FilePath] -hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsHpt hpt)) - -{- -************************************************************************ -* * -\subsection{Metaprogramming} -* * -************************************************************************ --} - --- | The supported metaprogramming result types -data MetaRequest - = MetaE (LHsExpr RdrName -> MetaResult) - | MetaP (LPat RdrName -> MetaResult) - | MetaT (LHsType RdrName -> MetaResult) - | MetaD ([LHsDecl RdrName] -> MetaResult) - | MetaAW (Serialized -> MetaResult) - --- | data constructors not exported to ensure correct result type -data MetaResult - = MetaResE { unMetaResE :: LHsExpr RdrName } - | MetaResP { unMetaResP :: LPat RdrName } - | MetaResT { unMetaResT :: LHsType RdrName } - | MetaResD { unMetaResD :: [LHsDecl RdrName] } - | MetaResAW { unMetaResAW :: Serialized } - -type MetaHook f = MetaRequest -> LHsExpr Id -> f MetaResult - -metaRequestE :: Functor f => MetaHook f -> LHsExpr Id -> f (LHsExpr RdrName) -metaRequestE h = fmap unMetaResE . h (MetaE MetaResE) - -metaRequestP :: Functor f => MetaHook f -> LHsExpr Id -> f (LPat RdrName) -metaRequestP h = fmap unMetaResP . h (MetaP MetaResP) - -metaRequestT :: Functor f => MetaHook f -> LHsExpr Id -> f (LHsType RdrName) -metaRequestT h = fmap unMetaResT . h (MetaT MetaResT) - -metaRequestD :: Functor f => MetaHook f -> LHsExpr Id -> f [LHsDecl RdrName] -metaRequestD h = fmap unMetaResD . h (MetaD MetaResD) - -metaRequestAW :: Functor f => MetaHook f -> LHsExpr Id -> f Serialized -metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW) - -{- -************************************************************************ -* * -\subsection{Dealing with Annotations} -* * -************************************************************************ --} - --- | Deal with gathering annotations in from all possible places --- and combining them into a single 'AnnEnv' -prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv -prepareAnnotations hsc_env mb_guts = do - eps <- hscEPS hsc_env - let -- Extract annotations from the module being compiled if supplied one - mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts - -- Extract dependencies of the module if we are supplied one, - -- otherwise load annotations from all home package table - -- entries regardless of dependency ordering. - home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts - other_pkg_anns = eps_ann_env eps - ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, - Just home_pkg_anns, - Just other_pkg_anns] - return ann_env - -{- -************************************************************************ -* * -\subsection{The Finder cache} -* * -************************************************************************ --} - --- | The 'FinderCache' maps modules to the result of --- searching for that module. It records the results of searching for --- modules along the search path. On @:load@, we flush the entire --- contents of this cache. --- -type FinderCache = InstalledModuleEnv InstalledFindResult - -data InstalledFindResult - = InstalledFound ModLocation InstalledModule - | InstalledNoPackage InstalledUnitId - | InstalledNotFound [FilePath] (Maybe InstalledUnitId) - --- | The result of searching for an imported module. --- --- NB: FindResult manages both user source-import lookups --- (which can result in 'Module') as well as direct imports --- for interfaces (which always result in 'InstalledModule'). -data FindResult - = Found ModLocation Module - -- ^ The module was found - | NoPackage UnitId - -- ^ The requested package was not found - | FoundMultiple [(Module, ModuleOrigin)] - -- ^ _Error_: both in multiple packages - - -- | Not found - | NotFound - { fr_paths :: [FilePath] -- Places where I looked - - , fr_pkg :: Maybe UnitId -- Just p => module is in this package's - -- manifest, but couldn't find - -- the .hi file - - , fr_mods_hidden :: [UnitId] -- Module is in these packages, - -- but the *module* is hidden - - , fr_pkgs_hidden :: [UnitId] -- Module is in these packages, - -- but the *package* is hidden - - , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules - } - -{- -************************************************************************ -* * -\subsection{Symbol tables and Module details} -* * -************************************************************************ --} - --- | A 'ModIface' plus a 'ModDetails' summarises everything we know --- about a compiled module. The 'ModIface' is the stuff *before* linking, --- and can be written out to an interface file. The 'ModDetails is after --- linking and can be completely recovered from just the 'ModIface'. --- --- When we read an interface file, we also construct a 'ModIface' from it, --- except that we explicitly make the 'mi_decls' and a few other fields empty; --- as when reading we consolidate the declarations etc. into a number of indexed --- maps and environments in the 'ExternalPackageState'. -data ModIface - = ModIface { - mi_module :: !Module, -- ^ Name of the module we are for - mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod? - mi_iface_hash :: !Fingerprint, -- ^ Hash of the whole interface - mi_mod_hash :: !Fingerprint, -- ^ Hash of the ABI only - mi_flag_hash :: !Fingerprint, -- ^ Hash of the important flags - -- used when compiling this module - - mi_orphan :: !WhetherHasOrphans, -- ^ Whether this module has orphans - mi_finsts :: !WhetherHasFamInst, - -- ^ Whether this module has family instances. - -- See Note [The type family instance consistency story]. - mi_hsc_src :: !HscSource, -- ^ Boot? Signature? - - mi_deps :: Dependencies, - -- ^ The dependencies of the module. This is - -- consulted for directly-imported modules, but not - -- for anything else (hence lazy) - - mi_usages :: [Usage], - -- ^ Usages; kept sorted so that it's easy to decide - -- whether to write a new iface file (changing usages - -- doesn't affect the hash of this module) - -- NOT STRICT! we read this field lazily from the interface file - -- It is *only* consulted by the recompilation checker - - mi_exports :: ![IfaceExport], - -- ^ Exports - -- Kept sorted by (mod,occ), to make version comparisons easier - -- Records the modules that are the declaration points for things - -- exported by this module, and the 'OccName's of those things - - mi_exp_hash :: !Fingerprint, - -- ^ Hash of export list - - mi_used_th :: !Bool, - -- ^ Module required TH splices when it was compiled. - -- This disables recompilation avoidance (see #481). - - mi_fixities :: [(OccName,Fixity)], - -- ^ Fixities - -- NOT STRICT! we read this field lazily from the interface file - - mi_warns :: Warnings, - -- ^ Warnings - -- NOT STRICT! we read this field lazily from the interface file - - mi_anns :: [IfaceAnnotation], - -- ^ Annotations - -- NOT STRICT! we read this field lazily from the interface file - - - mi_decls :: [(Fingerprint,IfaceDecl)], - -- ^ Type, class and variable declarations - -- The hash of an Id changes if its fixity or deprecations change - -- (as well as its type of course) - -- Ditto data constructors, class operations, except that - -- the hash of the parent class/tycon changes - - mi_globals :: !(Maybe GlobalRdrEnv), - -- ^ Binds all the things defined at the top level in - -- the /original source/ code for this module. which - -- is NOT the same as mi_exports, nor mi_decls (which - -- may contains declarations for things not actually - -- defined by the user). Used for GHCi and for inspecting - -- the contents of modules via the GHC API only. - -- - -- (We need the source file to figure out the - -- top-level environment, if we didn't compile this module - -- from source then this field contains @Nothing@). - -- - -- Strictly speaking this field should live in the - -- 'HomeModInfo', but that leads to more plumbing. - - -- Instance declarations and rules - mi_insts :: [IfaceClsInst], -- ^ Sorted class instance - mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances - mi_rules :: [IfaceRule], -- ^ Sorted rules - mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules, class and family - -- instances, and vectorise pragmas combined - - mi_vect_info :: !IfaceVectInfo, -- ^ Vectorisation information - - -- Cached environments for easy lookup - -- These are computed (lazily) from other fields - -- and are not put into the interface file - mi_warn_fn :: OccName -> Maybe WarningTxt, - -- ^ Cached lookup for 'mi_warns' - mi_fix_fn :: OccName -> Maybe Fixity, - -- ^ Cached lookup for 'mi_fixities' - mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint), - -- ^ Cached lookup for 'mi_decls'. - -- The @Nothing@ in 'mi_hash_fn' means that the thing - -- isn't in decls. It's useful to know that when - -- seeing if we are up to date wrt. the old interface. - -- The 'OccName' is the parent of the name, if it has one. - - mi_hpc :: !AnyHpcUsage, - -- ^ True if this program uses Hpc at any point in the program. - - mi_trust :: !IfaceTrustInfo, - -- ^ Safe Haskell Trust information for this module. - - mi_trust_pkg :: !Bool, - -- ^ Do we require the package this module resides in be trusted - -- to trust this module? This is used for the situation where a - -- module is Safe (so doesn't require the package be trusted - -- itself) but imports some trustworthy modules from its own - -- package (which does require its own package be trusted). - -- See Note [RnNames . Trust Own Package] - mi_complete_sigs :: [IfaceCompleteMatch] - } - --- | Old-style accessor for whether or not the ModIface came from an hs-boot --- file. -mi_boot :: ModIface -> Bool -mi_boot iface = mi_hsc_src iface == HsBootFile - --- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be --- found, 'defaultFixity' is returned instead. -mi_fix :: ModIface -> OccName -> Fixity -mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity - --- | The semantic module for this interface; e.g., if it's a interface --- for a signature, if 'mi_module' is @p[A=]:A@, 'mi_semantic_module' --- will be @@. -mi_semantic_module :: ModIface -> Module -mi_semantic_module iface = case mi_sig_of iface of - Nothing -> mi_module iface - Just mod -> mod - --- | The "precise" free holes, e.g., the signatures that this --- 'ModIface' depends on. -mi_free_holes :: ModIface -> UniqDSet ModuleName -mi_free_holes iface = - case splitModuleInsts (mi_module iface) of - (_, Just indef) - -- A mini-hack: we rely on the fact that 'renameFreeHoles' - -- drops things that aren't holes. - -> renameFreeHoles (mkUniqDSet cands) (indefUnitIdInsts (indefModuleUnitId indef)) - _ -> emptyUniqDSet - where - cands = map fst (dep_mods (mi_deps iface)) - --- | Given a set of free holes, and a unit identifier, rename --- the free holes according to the instantiation of the unit --- identifier. For example, if we have A and B free, and --- our unit identity is @p[A=,B=impl:B]@, the renamed free --- holes are just C. -renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName -renameFreeHoles fhs insts = - unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs)) - where - hmap = listToUFM insts - lookup_impl mod_name - | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod - -- It wasn't actually a hole - | otherwise = emptyUniqDSet - -instance Binary ModIface where - put_ bh (ModIface { - mi_module = mod, - mi_sig_of = sig_of, - mi_hsc_src = hsc_src, - mi_iface_hash= iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_deps = deps, - mi_usages = usages, - mi_exports = exports, - mi_exp_hash = exp_hash, - mi_used_th = used_th, - mi_fixities = fixities, - mi_warns = warns, - mi_anns = anns, - mi_decls = decls, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, - mi_orphan_hash = orphan_hash, - mi_vect_info = vect_info, - mi_hpc = hpc_info, - mi_trust = trust, - mi_trust_pkg = trust_pkg, - mi_complete_sigs = complete_sigs }) = do - put_ bh mod - put_ bh sig_of - put_ bh hsc_src - put_ bh iface_hash - put_ bh mod_hash - put_ bh flag_hash - put_ bh orphan - put_ bh hasFamInsts - lazyPut bh deps - lazyPut bh usages - put_ bh exports - put_ bh exp_hash - put_ bh used_th - put_ bh fixities - lazyPut bh warns - lazyPut bh anns - put_ bh decls - put_ bh insts - put_ bh fam_insts - lazyPut bh rules - put_ bh orphan_hash - put_ bh vect_info - put_ bh hpc_info - put_ bh trust - put_ bh trust_pkg - put_ bh complete_sigs - - get bh = do - mod <- get bh - sig_of <- get bh - hsc_src <- get bh - iface_hash <- get bh - mod_hash <- get bh - flag_hash <- get bh - orphan <- get bh - hasFamInsts <- get bh - deps <- lazyGet bh - usages <- {-# SCC "bin_usages" #-} lazyGet bh - exports <- {-# SCC "bin_exports" #-} get bh - exp_hash <- get bh - used_th <- get bh - fixities <- {-# SCC "bin_fixities" #-} get bh - warns <- {-# SCC "bin_warns" #-} lazyGet bh - anns <- {-# SCC "bin_anns" #-} lazyGet bh - decls <- {-# SCC "bin_tycldecls" #-} get bh - insts <- {-# SCC "bin_insts" #-} get bh - fam_insts <- {-# SCC "bin_fam_insts" #-} get bh - rules <- {-# SCC "bin_rules" #-} lazyGet bh - orphan_hash <- get bh - vect_info <- get bh - hpc_info <- get bh - trust <- get bh - trust_pkg <- get bh - complete_sigs <- get bh - return (ModIface { - mi_module = mod, - mi_sig_of = sig_of, - mi_hsc_src = hsc_src, - mi_iface_hash = iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_deps = deps, - mi_usages = usages, - mi_exports = exports, - mi_exp_hash = exp_hash, - mi_used_th = used_th, - mi_anns = anns, - mi_fixities = fixities, - mi_warns = warns, - mi_decls = decls, - mi_globals = Nothing, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, - mi_orphan_hash = orphan_hash, - mi_vect_info = vect_info, - mi_hpc = hpc_info, - mi_trust = trust, - mi_trust_pkg = trust_pkg, - -- And build the cached values - mi_warn_fn = mkIfaceWarnCache warns, - mi_fix_fn = mkIfaceFixCache fixities, - mi_hash_fn = mkIfaceHashCache decls, - mi_complete_sigs = complete_sigs }) - --- | The original names declared of a certain module that are exported -type IfaceExport = AvailInfo - --- | Constructs an empty ModIface -emptyModIface :: Module -> ModIface -emptyModIface mod - = ModIface { mi_module = mod, - mi_sig_of = Nothing, - mi_iface_hash = fingerprint0, - mi_mod_hash = fingerprint0, - mi_flag_hash = fingerprint0, - mi_orphan = False, - mi_finsts = False, - mi_hsc_src = HsSrcFile, - mi_deps = noDependencies, - mi_usages = [], - mi_exports = [], - mi_exp_hash = fingerprint0, - mi_used_th = False, - mi_fixities = [], - mi_warns = NoWarnings, - mi_anns = [], - mi_insts = [], - mi_fam_insts = [], - mi_rules = [], - mi_decls = [], - mi_globals = Nothing, - mi_orphan_hash = fingerprint0, - mi_vect_info = noIfaceVectInfo, - mi_warn_fn = emptyIfaceWarnCache, - mi_fix_fn = emptyIfaceFixCache, - mi_hash_fn = emptyIfaceHashCache, - mi_hpc = False, - mi_trust = noIfaceTrustInfo, - mi_trust_pkg = False, - mi_complete_sigs = [] } - - --- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' -mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] - -> (OccName -> Maybe (OccName, Fingerprint)) -mkIfaceHashCache pairs - = \occ -> lookupOccEnv env occ - where - env = foldl' add_decl emptyOccEnv pairs - add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d) - where - add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash) - -emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) -emptyIfaceHashCache _occ = Nothing - - --- | The 'ModDetails' is essentially a cache for information in the 'ModIface' --- for home modules only. Information relating to packages will be loaded into --- global environments in 'ExternalPackageState'. -data ModDetails - = ModDetails { - -- The next two fields are created by the typechecker - md_exports :: [AvailInfo], - md_types :: !TypeEnv, -- ^ Local type environment for this particular module - -- Includes Ids, TyCons, PatSyns - md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module - md_fam_insts :: ![FamInst], - md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules - md_anns :: ![Annotation], -- ^ Annotations present in this module: currently - -- they only annotate things also declared in this module - md_vect_info :: !VectInfo, -- ^ Module vectorisation information - md_complete_sigs :: [CompleteMatch] - -- ^ Complete match pragmas for this module - } - --- | Constructs an empty ModDetails -emptyModDetails :: ModDetails -emptyModDetails - = ModDetails { md_types = emptyTypeEnv, - md_exports = [], - md_insts = [], - md_rules = [], - md_fam_insts = [], - md_anns = [], - md_vect_info = noVectInfo, - md_complete_sigs = [] } - --- | Records the modules directly imported by a module for extracting e.g. --- usage information, and also to give better error message -type ImportedMods = ModuleEnv [ImportedBy] - --- | If a module was "imported" by the user, we associate it with --- more detailed usage information 'ImportedModsVal'; a module --- imported by the system only gets used for usage information. -data ImportedBy - = ImportedByUser ImportedModsVal - | ImportedBySystem - -importedByUser :: [ImportedBy] -> [ImportedModsVal] -importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys -importedByUser (ImportedBySystem : bys) = importedByUser bys -importedByUser [] = [] - -data ImportedModsVal - = ImportedModsVal { - imv_name :: ModuleName, -- ^ The name the module is imported with - imv_span :: SrcSpan, -- ^ the source span of the whole import - imv_is_safe :: IsSafeImport, -- ^ whether this is a safe import - imv_is_hiding :: Bool, -- ^ whether this is an "hiding" import - imv_all_exports :: GlobalRdrEnv, -- ^ all the things the module could provide - imv_qualified :: Bool -- ^ whether this is a qualified import - } - --- | A ModGuts is carried through the compiler, accumulating stuff as it goes --- There is only one ModGuts at any time, the one for the module --- being compiled right now. Once it is compiled, a 'ModIface' and --- 'ModDetails' are extracted and the ModGuts is discarded. -data ModGuts - = ModGuts { - mg_module :: !Module, -- ^ Module being compiled - mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module - mg_loc :: SrcSpan, -- ^ For error messages from inner passes - mg_exports :: ![AvailInfo], -- ^ What it exports - mg_deps :: !Dependencies, -- ^ What it depends on, directly or - -- otherwise - mg_usages :: ![Usage], -- ^ What was used? Used for interfaces. - - mg_used_th :: !Bool, -- ^ Did we run a TH splice? - mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment - - -- These fields all describe the things **declared in this module** - mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module. - -- Used for creating interface files. - mg_tcs :: ![TyCon], -- ^ TyCons declared in this module - -- (includes TyCons for classes) - mg_insts :: ![ClsInst], -- ^ Class instances declared in this module - mg_fam_insts :: ![FamInst], - -- ^ Family instances declared in this module - mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module - mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains - -- See Note [Overall plumbing for rules] in Rules.hs - mg_binds :: !CoreProgram, -- ^ Bindings for this module - mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module - mg_foreign_files :: ![(ForeignSrcLang, String)], - -- ^ Files to be compiled with the C compiler - mg_warns :: !Warnings, -- ^ Warnings declared in the module - mg_anns :: [Annotation], -- ^ Annotations declared in this module - mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches - mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module - mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module - mg_vect_decls:: ![CoreVect], -- ^ Vectorisation declarations in this module - -- (produced by desugarer & consumed by vectoriser) - mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module - - -- The next two fields are unusual, because they give instance - -- environments for *all* modules in the home package, including - -- this module, rather than for *just* this module. - -- Reason: when looking up an instance we don't want to have to - -- look at each module in the home package in turn - mg_inst_env :: InstEnv, -- ^ Class instance environment for - -- /home-package/ modules (including this - -- one); c.f. 'tcg_inst_env' - mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance environment for - -- /home-package/ modules (including this - -- one); c.f. 'tcg_fam_inst_env' - - mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode - mg_trust_pkg :: Bool -- ^ Do we need to trust our - -- own package for Safe Haskell? - -- See Note [RnNames . Trust Own Package] - } - --- The ModGuts takes on several slightly different forms: --- --- After simplification, the following fields change slightly: --- mg_rules Orphan rules only (local ones now attached to binds) --- mg_binds With rules attached - ---------------------------------------------------------- --- The Tidy pass forks the information about this module: --- * one lot goes to interface file generation (ModIface) --- and later compilations (ModDetails) --- * the other lot goes to code generation (CgGuts) - --- | A restricted form of 'ModGuts' for code generation purposes -data CgGuts - = CgGuts { - cg_module :: !Module, - -- ^ Module being compiled - - cg_tycons :: [TyCon], - -- ^ Algebraic data types (including ones that started - -- life as classes); generate constructors and info - -- tables. Includes newtypes, just for the benefit of - -- External Core - - cg_binds :: CoreProgram, - -- ^ The tidied main bindings, including - -- previously-implicit bindings for record and class - -- selectors, and data constructor wrappers. But *not* - -- data constructor workers; reason: we we regard them - -- as part of the code-gen of tycons - - cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs - cg_foreign_files :: ![(ForeignSrcLang, String)], - cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to - -- generate #includes for C code gen - cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information - cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints - cg_spt_entries :: [SptEntry] - -- ^ Static pointer table entries for static forms defined in - -- the module. - -- See Note [Grand plan for static forms] in StaticPtrTable - } - ------------------------------------ --- | Foreign export stubs -data ForeignStubs - = NoStubs - -- ^ We don't have any stubs - | ForeignStubs SDoc SDoc - -- ^ There are some stubs. Parameters: - -- - -- 1) Header file prototypes for - -- "foreign exported" functions - -- - -- 2) C stubs to use when calling - -- "foreign exported" functions - -appendStubC :: ForeignStubs -> SDoc -> ForeignStubs -appendStubC NoStubs c_code = ForeignStubs empty c_code -appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) - --- | An entry to be inserted into a module's static pointer table. --- See Note [Grand plan for static forms] in StaticPtrTable. -data SptEntry = SptEntry Id Fingerprint - -instance Outputable SptEntry where - ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr - -{- -************************************************************************ -* * - The interactive context -* * -************************************************************************ - -Note [The interactive package] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type, class, and value declarations at the command prompt are treated -as if they were defined in modules - interactive:Ghci1 - interactive:Ghci2 - ...etc... -with each bunch of declarations using a new module, all sharing a -common package 'interactive' (see Module.interactiveUnitId, and -PrelNames.mkInteractiveModule). - -This scheme deals well with shadowing. For example: - - ghci> data T = A - ghci> data T = B - ghci> :i A - data Ghci1.T = A -- Defined at :2:10 - -Here we must display info about constructor A, but its type T has been -shadowed by the second declaration. But it has a respectable -qualified name (Ghci1.T), and its source location says where it was -defined. - -So the main invariant continues to hold, that in any session an -original name M.T only refers to one unique thing. (In a previous -iteration both the T's above were called :Interactive.T, albeit with -different uniques, which gave rise to all sorts of trouble.) - -The details are a bit tricky though: - - * The field ic_mod_index counts which Ghci module we've got up to. - It is incremented when extending ic_tythings - - * ic_tythings contains only things from the 'interactive' package. - - * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go - in the Home Package Table (HPT). When you say :load, that's when we - extend the HPT. - - * The 'thisPackage' field of DynFlags is *not* set to 'interactive'. - It stays as 'main' (or whatever -this-unit-id says), and is the - package to which :load'ed modules are added to. - - * So how do we arrange that declarations at the command prompt get to - be in the 'interactive' package? Simply by setting the tcg_mod - field of the TcGblEnv to "interactive:Ghci1". This is done by the - call to initTc in initTcInteractive, which in turn get the module - from it 'icInteractiveModule' field of the interactive context. - - The 'thisPackage' field stays as 'main' (or whatever -this-unit-id says. - - * The main trickiness is that the type environment (tcg_type_env) and - fixity envt (tcg_fix_env), now contain entities from all the - interactive-package modules (Ghci1, Ghci2, ...) together, rather - than just a single module as is usually the case. So you can't use - "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs - the HPT/PTE. This is a change, but not a problem provided you - know. - -* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields - of the TcGblEnv, which collect "things defined in this module", all - refer to stuff define in a single GHCi command, *not* all the commands - so far. - - In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from - all GhciN modules, which makes sense -- they are all "home package" - modules. - - -Note [Interactively-bound Ids in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Ids bound by previous Stmts in GHCi are currently - a) GlobalIds, with - b) An External Name, like Ghci4.foo - See Note [The interactive package] above - c) A tidied type - - (a) They must be GlobalIds (not LocalIds) otherwise when we come to - compile an expression using these ids later, the byte code - generator will consider the occurrences to be free rather than - global. - - (b) Having an External Name is important because of Note - [GlobalRdrEnv shadowing] in RdrName - - (c) Their types are tidied. This is important, because :info may ask - to look at them, and :info expects the things it looks up to have - tidy types - -Where do interactively-bound Ids come from? - - - GHCi REPL Stmts e.g. - ghci> let foo x = x+1 - These start with an Internal Name because a Stmt is a local - construct, so the renamer naturally builds an Internal name for - each of its binders. Then in tcRnStmt they are externalised via - TcRnDriver.externaliseAndTidyId, so they get Names like Ghic4.foo. - - - Ids bound by the debugger etc have Names constructed by - IfaceEnv.newInteractiveBinder; at the call sites it is followed by - mkVanillaGlobal or mkVanillaGlobalWithInfo. So again, they are - all Global, External. - - - TyCons, Classes, and Ids bound by other top-level declarations in - GHCi (eg foreign import, record selectors) also get External - Names, with Ghci9 (or 8, or 7, etc) as the module name. - - -Note [ic_tythings] -~~~~~~~~~~~~~~~~~~ -The ic_tythings field contains - * The TyThings declared by the user at the command prompt - (eg Ids, TyCons, Classes) - - * The user-visible Ids that arise from such things, which - *don't* come from 'implicitTyThings', notably: - - record selectors - - class ops - The implicitTyThings are readily obtained from the TyThings - but record selectors etc are not - -It does *not* contain - * DFunIds (they can be gotten from ic_instances) - * CoAxioms (ditto) - -See also Note [Interactively-bound Ids in GHCi] - -Note [Override identical instances in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you declare a new instance in GHCi that is identical to a previous one, -we simply override the previous one; we don't regard it as overlapping. -e.g. Prelude> data T = A | B - Prelude> instance Eq T where ... - Prelude> instance Eq T where ... -- This one overrides - -It's exactly the same for type-family instances. See Trac #7102 --} - --- | Interactive context, recording information about the state of the --- context in which statements are executed in a GHC session. -data InteractiveContext - = InteractiveContext { - ic_dflags :: DynFlags, - -- ^ The 'DynFlags' used to evaluate interative expressions - -- and statements. - - ic_mod_index :: Int, - -- ^ Each GHCi stmt or declaration brings some new things into - -- scope. We give them names like interactive:Ghci9.T, - -- where the ic_index is the '9'. The ic_mod_index is - -- incremented whenever we add something to ic_tythings - -- See Note [The interactive package] - - ic_imports :: [InteractiveImport], - -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with - -- these imports - -- - -- This field is only stored here so that the client - -- can retrieve it with GHC.getContext. GHC itself doesn't - -- use it, but does reset it to empty sometimes (such - -- as before a GHC.load). The context is set with GHC.setContext. - - ic_tythings :: [TyThing], - -- ^ TyThings defined by the user, in reverse order of - -- definition (ie most recent at the front) - -- See Note [ic_tythings] - - ic_rn_gbl_env :: GlobalRdrEnv, - -- ^ The cached 'GlobalRdrEnv', built by - -- 'InteractiveEval.setContext' and updated regularly - -- It contains everything in scope at the command line, - -- including everything in ic_tythings - - ic_instances :: ([ClsInst], [FamInst]), - -- ^ All instances and family instances created during - -- this session. These are grabbed en masse after each - -- update to be sure that proper overlapping is retained. - -- That is, rather than re-check the overlapping each - -- time we update the context, we just take the results - -- from the instance code that already does that. - - ic_fix_env :: FixityEnv, - -- ^ Fixities declared in let statements - - ic_default :: Maybe [Type], - -- ^ The current default types, set by a 'default' declaration - - ic_resume :: [Resume], - -- ^ The stack of breakpoint contexts - - ic_monad :: Name, - -- ^ The monad that GHCi is executing in - - ic_int_print :: Name, - -- ^ The function that is used for printing results - -- of expressions in ghci and -e mode. - - ic_cwd :: Maybe FilePath - -- virtual CWD of the program - } - -data InteractiveImport - = IIDecl (ImportDecl RdrName) - -- ^ Bring the exports of a particular module - -- (filtered by an import decl) into scope - - | IIModule ModuleName - -- ^ Bring into scope the entire top-level envt of - -- of this module, including the things imported - -- into it. - - --- | Constructs an empty InteractiveContext. -emptyInteractiveContext :: DynFlags -> InteractiveContext -emptyInteractiveContext dflags - = InteractiveContext { - ic_dflags = dflags, - ic_imports = [], - ic_rn_gbl_env = emptyGlobalRdrEnv, - ic_mod_index = 1, - ic_tythings = [], - ic_instances = ([],[]), - ic_fix_env = emptyNameEnv, - ic_monad = ioTyConName, -- IO monad by default - ic_int_print = printName, -- System.IO.print by default - ic_default = Nothing, - ic_resume = [], - ic_cwd = Nothing } - -icInteractiveModule :: InteractiveContext -> Module -icInteractiveModule (InteractiveContext { ic_mod_index = index }) - = mkInteractiveModule index - --- | This function returns the list of visible TyThings (useful for --- e.g. showBindings) -icInScopeTTs :: InteractiveContext -> [TyThing] -icInScopeTTs = ic_tythings - --- | Get the PrintUnqualified function based on the flags and this InteractiveContext -icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified -icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = - mkPrintUnqualified dflags grenv - --- | extendInteractiveContext is called with new TyThings recently defined to update the --- InteractiveContext to include them. Ids are easily removed when shadowed, --- but Classes and TyCons are not. Some work could be done to determine --- whether they are entirely shadowed, but as you could still have references --- to them (e.g. instances for classes or values of the type for TyCons), it's --- not clear whether removing them is even the appropriate behavior. -extendInteractiveContext :: InteractiveContext - -> [TyThing] - -> [ClsInst] -> [FamInst] - -> Maybe [Type] - -> FixityEnv - -> InteractiveContext -extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env - = ictxt { ic_mod_index = ic_mod_index ictxt + 1 - -- Always bump this; even instances should create - -- a new mod_index (Trac #9426) - , ic_tythings = new_tythings ++ ic_tythings ictxt - , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings - , ic_instances = ( new_cls_insts ++ old_cls_insts - , new_fam_insts ++ fam_insts ) - -- we don't shadow old family instances (#7102), - -- so don't need to remove them here - , ic_default = defaults - , ic_fix_env = fix_env -- See Note [Fixity declarations in GHCi] - } - where - - -- Discard old instances that have been fully overridden - -- See Note [Override identical instances in GHCi] - (cls_insts, fam_insts) = ic_instances ictxt - old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts - -extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext --- Just a specialised version -extendInteractiveContextWithIds ictxt new_ids - | null new_ids = ictxt - | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1 - , ic_tythings = new_tythings ++ ic_tythings ictxt - , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings } - where - new_tythings = map AnId new_ids - -setInteractivePackage :: HscEnv -> HscEnv --- Set the 'thisPackage' DynFlag to 'interactive' -setInteractivePackage hsc_env - = hsc_env { hsc_dflags = (hsc_dflags hsc_env) - { thisInstalledUnitId = toInstalledUnitId interactiveUnitId } } - -setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext -setInteractivePrintName ic n = ic{ic_int_print = n} - - -- ToDo: should not add Ids to the gbl env here - --- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing --- later ones, and shadowing existing entries in the GlobalRdrEnv. -icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv -icExtendGblRdrEnv env tythings - = foldr add env tythings -- Foldr makes things in the front of - -- the list shadow things at the back - where - -- One at a time, to ensure each shadows the previous ones - add thing env - | is_sub_bndr thing - = env - | otherwise - = foldl extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) - where - env1 = shadowNames env (concatMap availNames avail) - avail = tyThingAvailInfo thing - - -- Ugh! The new_tythings may include record selectors, since they - -- are not implicit-ids, and must appear in the TypeEnv. But they - -- will also be brought into scope by the corresponding (ATyCon - -- tc). And we want the latter, because that has the correct - -- parent (Trac #10520) - is_sub_bndr (AnId f) = case idDetails f of - RecSelId {} -> True - ClassOpId {} -> True - _ -> False - is_sub_bndr _ = False - -substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext -substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst - | isEmptyTCvSubst subst = ictxt - | otherwise = ictxt { ic_tythings = map subst_ty tts } - where - subst_ty (AnId id) = AnId $ id `setIdType` substTyUnchecked subst (idType id) - subst_ty tt = tt - -instance Outputable InteractiveImport where - ppr (IIModule m) = char '*' <> ppr m - ppr (IIDecl d) = ppr d - -{- -************************************************************************ -* * - Building a PrintUnqualified -* * -************************************************************************ - -Note [Printing original names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deciding how to print names is pretty tricky. We are given a name -P:M.T, where P is the package name, M is the defining module, and T is -the occurrence name, and we have to decide in which form to display -the name given a GlobalRdrEnv describing the current scope. - -Ideally we want to display the name in the form in which it is in -scope. However, the name might not be in scope at all, and that's -where it gets tricky. Here are the cases: - - 1. T uniquely maps to P:M.T ---> "T" NameUnqual - 2. There is an X for which X.T - uniquely maps to P:M.T ---> "X.T" NameQual X - 3. There is no binding for "M.T" ---> "M.T" NameNotInScope1 - 4. Otherwise ---> "P:M.T" NameNotInScope2 - -(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at -all. In these cases we still want to refer to the name as "M.T", *but* -"M.T" might mean something else in the current scope (e.g. if there's -an "import X as M"), so to avoid confusion we avoid using "M.T" if -there's already a binding for it. Instead we write P:M.T. - -There's one further subtlety: in case (3), what if there are two -things around, P1:M.T and P2:M.T? Then we don't want to print both of -them as M.T! However only one of the modules P1:M and P2:M can be -exposed (say P2), so we use M.T for that, and P1:M.T for the other one. -This is handled by the qual_mod component of PrintUnqualified, inside -the (ppr mod) of case (3), in Name.pprModulePrefix - -Note [Printing unit ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the old days, original names were tied to PackageIds, which directly -corresponded to the entities that users wrote in Cabal files, and were perfectly -suitable for printing when we need to disambiguate packages. However, with -UnitId, the situation can be different: if the key is instantiated with -some holes, we should try to give the user some more useful information. --} - --- | Creates some functions that work out the best ways to format --- names for the user according to a set of heuristics. -mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified dflags env = QueryQualify qual_name - (mkQualModule dflags) - (mkQualPackage dflags) - where - qual_name mod occ - | [gre] <- unqual_gres - , right_name gre - = NameUnqual -- If there's a unique entity that's in scope - -- unqualified with 'occ' AND that entity is - -- the right one, then we can use the unqualified name - - | [] <- unqual_gres - , any is_name forceUnqualNames - , not (isDerivedOccName occ) - = NameUnqual -- Don't qualify names that come from modules - -- that come with GHC, often appear in error messages, - -- but aren't typically in scope. Doing this does not - -- cause ambiguity, and it reduces the amount of - -- qualification in error messages thus improving - -- readability. - -- - -- A motivating example is 'Constraint'. It's often not - -- in scope, but printing GHC.Prim.Constraint seems - -- overkill. - - | [gre] <- qual_gres - = NameQual (greQualModName gre) - - | null qual_gres - = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) - then NameNotInScope1 - else NameNotInScope2 - - | otherwise - = NameNotInScope1 -- Can happen if 'f' is bound twice in the module - -- Eg f = True; g = 0; f = False - where - is_name :: Name -> Bool - is_name name = ASSERT2( isExternalName name, ppr name ) - nameModule name == mod && nameOccName name == occ - - forceUnqualNames :: [Name] - forceUnqualNames = - map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon - , starKindTyCon, unicodeStarKindTyCon ] - ++ [ eqTyConName ] - - right_name gre = nameModule_maybe (gre_name gre) == Just mod - - unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env - qual_gres = filter right_name (lookupGlobalRdrEnv env occ) - - -- we can mention a module P:M without the P: qualifier iff - -- "import M" would resolve unambiguously to P:M. (if P is the - -- current package we can just assume it is unqualified). - --- | Creates a function for formatting modules based on two heuristics: --- (1) if the module is the current module, don't qualify, and (2) if there --- is only one exposed package which exports this module, don't qualify. -mkQualModule :: DynFlags -> QueryQualifyModule -mkQualModule dflags mod - | moduleUnitId mod == thisPackage dflags = False - - | [(_, pkgconfig)] <- lookup, - packageConfigId pkgconfig == moduleUnitId mod - -- this says: we are given a module P:M, is there just one exposed package - -- that exposes a module M, and is it package P? - = False - - | otherwise = True - where lookup = lookupModuleInAllPackages dflags (moduleName mod) - --- | Creates a function for formatting packages based on two heuristics: --- (1) don't qualify if the package in question is "main", and (2) only qualify --- with a unit id if the package ID would be ambiguous. -mkQualPackage :: DynFlags -> QueryQualifyPackage -mkQualPackage dflags pkg_key - | pkg_key == mainUnitId || pkg_key == interactiveUnitId - -- Skip the lookup if it's main, since it won't be in the package - -- database! - = False - | Just pkgid <- mb_pkgid - , searchPackageId dflags pkgid `lengthIs` 1 - -- this says: we are given a package pkg-0.1@MMM, are there only one - -- exposed packages whose package ID is pkg-0.1? - = False - | otherwise - = True - where mb_pkgid = fmap sourcePackageId (lookupPackage dflags pkg_key) - --- | A function which only qualifies package names if necessary; but --- qualifies all other identifiers. -pkgQual :: DynFlags -> PrintUnqualified -pkgQual dflags = alwaysQualify { - queryQualifyPackage = mkQualPackage dflags - } - -{- -************************************************************************ -* * - Implicit TyThings -* * -************************************************************************ - -Note [Implicit TyThings] -~~~~~~~~~~~~~~~~~~~~~~~~ - DEFINITION: An "implicit" TyThing is one that does not have its own - IfaceDecl in an interface file. Instead, its binding in the type - environment is created as part of typechecking the IfaceDecl for - some other thing. - -Examples: - * All DataCons are implicit, because they are generated from the - IfaceDecl for the data/newtype. Ditto class methods. - - * Record selectors are *not* implicit, because they get their own - free-standing IfaceDecl. - - * Associated data/type families are implicit because they are - included in the IfaceDecl of the parent class. (NB: the - IfaceClass decl happens to use IfaceDecl recursively for the - associated types, but that's irrelevant here.) - - * Dictionary function Ids are not implicit. - - * Axioms for newtypes are implicit (same as above), but axioms - for data/type family instances are *not* implicit (like DFunIds). --} - --- | Determine the 'TyThing's brought into scope by another 'TyThing' --- /other/ than itself. For example, Id's don't have any implicit TyThings --- as they just bring themselves into scope, but classes bring their --- dictionary datatype, type constructor and some selector functions into --- scope, just for a start! - --- N.B. the set of TyThings returned here *must* match the set of --- names returned by LoadIface.ifaceDeclImplicitBndrs, in the sense that --- TyThing.getOccName should define a bijection between the two lists. --- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) --- The order of the list does not matter. -implicitTyThings :: TyThing -> [TyThing] -implicitTyThings (AnId _) = [] -implicitTyThings (ACoAxiom _cc) = [] -implicitTyThings (ATyCon tc) = implicitTyConThings tc -implicitTyThings (AConLike cl) = implicitConLikeThings cl - -implicitConLikeThings :: ConLike -> [TyThing] -implicitConLikeThings (RealDataCon dc) - = dataConImplicitTyThings dc - -implicitConLikeThings (PatSynCon {}) - = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher - -- are not "implicit"; they are simply new top-level bindings, - -- and they have their own declaration in an interface file - -- Unless a record pat syn when there are implicit selectors - -- They are still not included here as `implicitConLikeThings` is - -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked - -- by `tcTopValBinds`. - -implicitClassThings :: Class -> [TyThing] -implicitClassThings cl - = -- Does not include default methods, because those Ids may have - -- their own pragmas, unfoldings etc, not derived from the Class object - - -- associated types - -- No recursive call for the classATs, because they - -- are only the family decls; they have no implicit things - map ATyCon (classATs cl) ++ - - -- superclass and operation selectors - map AnId (classAllSelIds cl) - -implicitTyConThings :: TyCon -> [TyThing] -implicitTyConThings tc - = class_stuff ++ - -- fields (names of selectors) - - -- (possibly) implicit newtype axioms - -- or type family axioms - implicitCoTyCon tc ++ - - -- for each data constructor in order, - -- the constructor, worker, and (possibly) wrapper - [ thing | dc <- tyConDataCons tc - , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ] - -- NB. record selectors are *not* implicit, they have fully-fledged - -- bindings that pass through the compilation pipeline as normal. - where - class_stuff = case tyConClass_maybe tc of - Nothing -> [] - Just cl -> implicitClassThings cl - --- For newtypes and closed type families (only) add the implicit coercion tycon -implicitCoTyCon :: TyCon -> [TyThing] -implicitCoTyCon tc - | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] - | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc - = [ACoAxiom co] - | otherwise = [] - --- | Returns @True@ if there should be no interface-file declaration --- for this thing on its own: either it is built-in, or it is part --- of some other declaration, or it is generated implicitly by some --- other declaration. -isImplicitTyThing :: TyThing -> Bool -isImplicitTyThing (AConLike cl) = case cl of - RealDataCon {} -> True - PatSynCon {} -> False -isImplicitTyThing (AnId id) = isImplicitId id -isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc -isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax - --- | tyThingParent_maybe x returns (Just p) --- when pprTyThingInContext should print a declaration for p --- (albeit with some "..." in it) when asked to show x --- It returns the *immediate* parent. So a datacon returns its tycon --- but the tycon could be the associated type of a class, so it in turn --- might have a parent. -tyThingParent_maybe :: TyThing -> Maybe TyThing -tyThingParent_maybe (AConLike cl) = case cl of - RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) - PatSynCon{} -> Nothing -tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of - Just cls -> Just (ATyCon (classTyCon cls)) - Nothing -> Nothing -tyThingParent_maybe (AnId id) = case idDetails id of - RecSelId { sel_tycon = RecSelData tc } -> - Just (ATyCon tc) - ClassOpId cls -> - Just (ATyCon (classTyCon cls)) - _other -> Nothing -tyThingParent_maybe _other = Nothing - -tyThingsTyCoVars :: [TyThing] -> TyCoVarSet -tyThingsTyCoVars tts = - unionVarSets $ map ttToVarSet tts - where - ttToVarSet (AnId id) = tyCoVarsOfType $ idType id - ttToVarSet (AConLike cl) = case cl of - RealDataCon dc -> tyCoVarsOfType $ dataConRepType dc - PatSynCon{} -> emptyVarSet - ttToVarSet (ATyCon tc) - = case tyConClass_maybe tc of - Just cls -> (mkVarSet . fst . classTvsFds) cls - Nothing -> tyCoVarsOfType $ tyConKind tc - ttToVarSet (ACoAxiom _) = emptyVarSet - --- | The Names that a TyThing should bring into scope. Used to build --- the GlobalRdrEnv for the InteractiveContext. -tyThingAvailInfo :: TyThing -> [AvailInfo] -tyThingAvailInfo (ATyCon t) - = case tyConClass_maybe t of - Just c -> [AvailTC n (n : map getName (classMethods c) - ++ map getName (classATs c)) - [] ] - where n = getName c - Nothing -> [AvailTC n (n : map getName dcs) flds] - where n = getName t - dcs = tyConDataCons t - flds = tyConFieldLabels t -tyThingAvailInfo (AConLike (PatSynCon p)) - = map avail ((getName p) : map flSelector (patSynFieldLabels p)) -tyThingAvailInfo t - = [avail (getName t)] - -{- -************************************************************************ -* * - TypeEnv -* * -************************************************************************ --} - --- | A map from 'Name's to 'TyThing's, constructed by typechecking --- local declarations or interface files -type TypeEnv = NameEnv TyThing - -emptyTypeEnv :: TypeEnv -typeEnvElts :: TypeEnv -> [TyThing] -typeEnvTyCons :: TypeEnv -> [TyCon] -typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched] -typeEnvIds :: TypeEnv -> [Id] -typeEnvPatSyns :: TypeEnv -> [PatSyn] -typeEnvDataCons :: TypeEnv -> [DataCon] -typeEnvClasses :: TypeEnv -> [Class] -lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing - -emptyTypeEnv = emptyNameEnv -typeEnvElts env = nameEnvElts env -typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] -typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] -typeEnvIds env = [id | AnId id <- typeEnvElts env] -typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env] -typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env] -typeEnvClasses env = [cl | tc <- typeEnvTyCons env, - Just cl <- [tyConClass_maybe tc]] - -mkTypeEnv :: [TyThing] -> TypeEnv -mkTypeEnv things = extendTypeEnvList emptyTypeEnv things - -mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv -mkTypeEnvWithImplicits things = - mkTypeEnv things - `plusNameEnv` - mkTypeEnv (concatMap implicitTyThings things) - -typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv -typeEnvFromEntities ids tcs famInsts = - mkTypeEnv ( map AnId ids - ++ map ATyCon all_tcs - ++ concatMap implicitTyConThings all_tcs - ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts - ) - where - all_tcs = tcs ++ famInstsRepTyCons famInsts - -lookupTypeEnv = lookupNameEnv - --- Extend the type environment -extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv -extendTypeEnv env thing = extendNameEnv env (getName thing) thing - -extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv -extendTypeEnvList env things = foldl extendTypeEnv env things - -extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv -extendTypeEnvWithIds env ids - = extendNameEnvList env [(getName id, AnId id) | id <- ids] - -plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv -plusTypeEnv env1 env2 = plusNameEnv env1 env2 - --- | Find the 'TyThing' for the given 'Name' by using all the resources --- at our disposal: the compiled modules in the 'HomePackageTable' and the --- compiled modules in other packages that live in 'PackageTypeEnv'. Note --- that this does NOT look up the 'TyThing' in the module being compiled: you --- have to do that yourself, if desired -lookupType :: DynFlags - -> HomePackageTable - -> PackageTypeEnv - -> Name - -> Maybe TyThing - -lookupType dflags hpt pte name - | isOneShot (ghcMode dflags) -- in one-shot, we don't use the HPT - = lookupNameEnv pte name - | otherwise - = case lookupHptByModule hpt mod of - Just hm -> lookupNameEnv (md_types (hm_details hm)) name - Nothing -> lookupNameEnv pte name - where - mod = ASSERT2( isExternalName name, ppr name ) - if isHoleName name - then mkModule (thisPackage dflags) (moduleName (nameModule name)) - else nameModule name - --- | As 'lookupType', but with a marginally easier-to-use interface --- if you have a 'HscEnv' -lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing) -lookupTypeHscEnv hsc_env name = do - eps <- readIORef (hsc_EPS hsc_env) - return $! lookupType dflags hpt (eps_PTE eps) name - where - dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - --- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise -tyThingTyCon :: TyThing -> TyCon -tyThingTyCon (ATyCon tc) = tc -tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) - --- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise -tyThingCoAxiom :: TyThing -> CoAxiom Branched -tyThingCoAxiom (ACoAxiom ax) = ax -tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (ppr other) - --- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise -tyThingDataCon :: TyThing -> DataCon -tyThingDataCon (AConLike (RealDataCon dc)) = dc -tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) - --- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing. --- Panics otherwise -tyThingConLike :: TyThing -> ConLike -tyThingConLike (AConLike dc) = dc -tyThingConLike other = pprPanic "tyThingConLike" (ppr other) - --- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise -tyThingId :: TyThing -> Id -tyThingId (AnId id) = id -tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc -tyThingId other = pprPanic "tyThingId" (ppr other) - -{- -************************************************************************ -* * -\subsection{MonadThings and friends} -* * -************************************************************************ --} - --- | Class that abstracts out the common ability of the monads in GHC --- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides --- a number of related convenience functions for accessing particular --- kinds of 'TyThing' -class Monad m => MonadThings m where - lookupThing :: Name -> m TyThing - - lookupId :: Name -> m Id - lookupId = liftM tyThingId . lookupThing - - lookupDataCon :: Name -> m DataCon - lookupDataCon = liftM tyThingDataCon . lookupThing - - lookupTyCon :: Name -> m TyCon - lookupTyCon = liftM tyThingTyCon . lookupThing - -{- -************************************************************************ -* * -\subsection{Auxiliary types} -* * -************************************************************************ - -These types are defined here because they are mentioned in ModDetails, -but they are mostly elaborated elsewhere --} - ------------------- Warnings ------------------------- --- | Warning information for a module -data Warnings - = NoWarnings -- ^ Nothing deprecated - | WarnAll WarningTxt -- ^ Whole module deprecated - | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated - - -- Only an OccName is needed because - -- (1) a deprecation always applies to a binding - -- defined in the module in which the deprecation appears. - -- (2) deprecations are only reported outside the defining module. - -- this is important because, otherwise, if we saw something like - -- - -- {-# DEPRECATED f "" #-} - -- f = ... - -- h = f - -- g = let f = undefined in f - -- - -- we'd need more information than an OccName to know to say something - -- about the use of f in h but not the use of the locally bound f in g - -- - -- however, because we only report about deprecations from the outside, - -- and a module can only export one value called f, - -- an OccName suffices. - -- - -- this is in contrast with fixity declarations, where we need to map - -- a Name to its fixity declaration. - deriving( Eq ) - -instance Binary Warnings where - put_ bh NoWarnings = putByte bh 0 - put_ bh (WarnAll t) = do - putByte bh 1 - put_ bh t - put_ bh (WarnSome ts) = do - putByte bh 2 - put_ bh ts - - get bh = do - h <- getByte bh - case h of - 0 -> return NoWarnings - 1 -> do aa <- get bh - return (WarnAll aa) - _ -> do aa <- get bh - return (WarnSome aa) - --- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' -mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt -mkIfaceWarnCache NoWarnings = \_ -> Nothing -mkIfaceWarnCache (WarnAll t) = \_ -> Just t -mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) - -emptyIfaceWarnCache :: OccName -> Maybe WarningTxt -emptyIfaceWarnCache _ = Nothing - -plusWarns :: Warnings -> Warnings -> Warnings -plusWarns d NoWarnings = d -plusWarns NoWarnings d = d -plusWarns _ (WarnAll t) = WarnAll t -plusWarns (WarnAll t) _ = WarnAll t -plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) - --- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface' -mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity -mkIfaceFixCache pairs - = \n -> lookupOccEnv env n - where - env = mkOccEnv pairs - -emptyIfaceFixCache :: OccName -> Maybe Fixity -emptyIfaceFixCache _ = Nothing - --- | Fixity environment mapping names to their fixities -type FixityEnv = NameEnv FixItem - --- | Fixity information for an 'Name'. We keep the OccName in the range --- so that we can generate an interface from it -data FixItem = FixItem OccName Fixity - -instance Outputable FixItem where - ppr (FixItem occ fix) = ppr fix <+> ppr occ - -emptyFixityEnv :: FixityEnv -emptyFixityEnv = emptyNameEnv - -lookupFixity :: FixityEnv -> Name -> Fixity -lookupFixity env n = case lookupNameEnv env n of - Just (FixItem _ fix) -> fix - Nothing -> defaultFixity - -{- -************************************************************************ -* * -\subsection{WhatsImported} -* * -************************************************************************ --} - --- | Records whether a module has orphans. An \"orphan\" is one of: --- --- * An instance declaration in a module other than the definition --- module for one of the type constructors or classes in the instance head --- --- * A transformation rule in a module other than the one defining --- the function in the head of the rule --- --- * A vectorisation pragma -type WhetherHasOrphans = Bool - --- | Does this module define family instances? -type WhetherHasFamInst = Bool - --- | Did this module originate from a *-boot file? -type IsBootInterface = Bool - --- | Dependency information about ALL modules and packages below this one --- in the import hierarchy. --- --- Invariant: the dependencies of a module @M@ never includes @M@. --- --- Invariant: none of the lists contain duplicates. -data Dependencies - = Deps { dep_mods :: [(ModuleName, IsBootInterface)] - -- ^ All home-package modules transitively below this one - -- I.e. modules that this one imports, or that are in the - -- dep_mods of those directly-imported modules - - , dep_pkgs :: [(InstalledUnitId, Bool)] - -- ^ All packages transitively below this module - -- I.e. packages to which this module's direct imports belong, - -- or that are in the dep_pkgs of those modules - -- The bool indicates if the package is required to be - -- trusted when the module is imported as a safe import - -- (Safe Haskell). See Note [RnNames . Tracking Trust Transitively] - - , dep_orphs :: [Module] - -- ^ Transitive closure of orphan modules (whether - -- home or external pkg). - -- - -- (Possible optimization: don't include family - -- instance orphans as they are anyway included in - -- 'dep_finsts'. But then be careful about code - -- which relies on dep_orphs having the complete list!) - -- This does NOT include us, unlike 'imp_orphs'. - - , dep_finsts :: [Module] - -- ^ Transitive closure of depended upon modules which - -- contain family instances (whether home or external). - -- This is used by 'checkFamInstConsistency'. This - -- does NOT include us, unlike 'imp_finsts'. See Note - -- [The type family instance consistency story]. - } - deriving( Eq ) - -- Equality used only for old/new comparison in MkIface.addFingerprints - -- See 'TcRnTypes.ImportAvails' for details on dependencies. - -instance Binary Dependencies where - put_ bh deps = do put_ bh (dep_mods deps) - put_ bh (dep_pkgs deps) - put_ bh (dep_orphs deps) - put_ bh (dep_finsts deps) - - get bh = do ms <- get bh - ps <- get bh - os <- get bh - fis <- get bh - return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, - dep_finsts = fis }) - -noDependencies :: Dependencies -noDependencies = Deps [] [] [] [] - --- | Records modules for which changes may force recompilation of this module --- See wiki: http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance --- --- This differs from Dependencies. A module X may be in the dep_mods of this --- module (via an import chain) but if we don't use anything from X it won't --- appear in our Usage -data Usage - -- | Module from another package - = UsagePackageModule { - usg_mod :: Module, - -- ^ External package module depended on - usg_mod_hash :: Fingerprint, - -- ^ Cached module fingerprint - usg_safe :: IsSafeImport - -- ^ Was this module imported as a safe import - } - -- | Module from the current package - | UsageHomeModule { - usg_mod_name :: ModuleName, - -- ^ Name of the module - usg_mod_hash :: Fingerprint, - -- ^ Cached module fingerprint - usg_entities :: [(OccName,Fingerprint)], - -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. - -- NB: usages are for parent names only, e.g. type constructors - -- but not the associated data constructors. - usg_exports :: Maybe Fingerprint, - -- ^ Fingerprint for the export list of this module, - -- if we directly imported it (and hence we depend on its export list) - usg_safe :: IsSafeImport - -- ^ Was this module imported as a safe import - } -- ^ Module from the current package - -- | A file upon which the module depends, e.g. a CPP #include, or using TH's - -- 'addDependentFile' - | UsageFile { - usg_file_path :: FilePath, - -- ^ External file dependency. From a CPP #include or TH - -- addDependentFile. Should be absolute. - usg_file_hash :: Fingerprint - -- ^ 'Fingerprint' of the file contents. - - -- Note: We don't consider things like modification timestamps - -- here, because there's no reason to recompile if the actual - -- contents don't change. This previously lead to odd - -- recompilation behaviors; see #8114 - } - -- | A requirement which was merged into this one. - | UsageMergedRequirement { - usg_mod :: Module, - usg_mod_hash :: Fingerprint - } - deriving( Eq ) - -- The export list field is (Just v) if we depend on the export list: - -- i.e. we imported the module directly, whether or not we - -- enumerated the things we imported, or just imported - -- everything - -- We need to recompile if M's exports change, because - -- if the import was import M, we might now have a name clash - -- in the importing module. - -- if the import was import M(x) M might no longer export x - -- The only way we don't depend on the export list is if we have - -- import M() - -- And of course, for modules that aren't imported directly we don't - -- depend on their export lists - -instance Binary Usage where - put_ bh usg@UsagePackageModule{} = do - putByte bh 0 - put_ bh (usg_mod usg) - put_ bh (usg_mod_hash usg) - put_ bh (usg_safe usg) - - put_ bh usg@UsageHomeModule{} = do - putByte bh 1 - put_ bh (usg_mod_name usg) - put_ bh (usg_mod_hash usg) - put_ bh (usg_exports usg) - put_ bh (usg_entities usg) - put_ bh (usg_safe usg) - - put_ bh usg@UsageFile{} = do - putByte bh 2 - put_ bh (usg_file_path usg) - put_ bh (usg_file_hash usg) - - put_ bh usg@UsageMergedRequirement{} = do - putByte bh 3 - put_ bh (usg_mod usg) - put_ bh (usg_mod_hash usg) - - get bh = do - h <- getByte bh - case h of - 0 -> do - nm <- get bh - mod <- get bh - safe <- get bh - return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } - 1 -> do - nm <- get bh - mod <- get bh - exps <- get bh - ents <- get bh - safe <- get bh - return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, - usg_exports = exps, usg_entities = ents, usg_safe = safe } - 2 -> do - fp <- get bh - hash <- get bh - return UsageFile { usg_file_path = fp, usg_file_hash = hash } - 3 -> do - mod <- get bh - hash <- get bh - return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } - i -> error ("Binary.get(Usage): " ++ show i) - -{- -************************************************************************ -* * - The External Package State -* * -************************************************************************ --} - -type PackageTypeEnv = TypeEnv -type PackageRuleBase = RuleBase -type PackageInstEnv = InstEnv -type PackageFamInstEnv = FamInstEnv -type PackageVectInfo = VectInfo -type PackageAnnEnv = AnnEnv -type PackageCompleteMatchMap = CompleteMatchMap - --- | Information about other packages that we have slurped in by reading --- their interface files -data ExternalPackageState - = EPS { - eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)), - -- ^ In OneShot mode (only), home-package modules - -- accumulate in the external package state, and are - -- sucked in lazily. For these home-pkg modules - -- (only) we need to record which are boot modules. - -- We set this field after loading all the - -- explicitly-imported interfaces, but before doing - -- anything else - -- - -- The 'ModuleName' part is not necessary, but it's useful for - -- debug prints, and it's convenient because this field comes - -- direct from 'TcRnTypes.imp_dep_mods' - - eps_PIT :: !PackageIfaceTable, - -- ^ The 'ModIface's for modules in external packages - -- whose interfaces we have opened. - -- The declarations in these interface files are held in the - -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules' - -- fields of this record, not in the 'mi_decls' fields of the - -- interface we have sucked in. - -- - -- What /is/ in the PIT is: - -- - -- * The Module - -- - -- * Fingerprint info - -- - -- * Its exports - -- - -- * Fixities - -- - -- * Deprecations and warnings - - eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName), - -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on - -- the 'eps_PIT' for this information, EXCEPT that when - -- we do dependency analysis, we need to look at the - -- 'Dependencies' of our imports to determine what their - -- precise free holes are ('moduleFreeHolesPrecise'). We - -- don't want to repeatedly reread in the interface - -- for every import, so cache it here. When the PIT - -- gets filled in we can drop these entries. - - eps_PTE :: !PackageTypeEnv, - -- ^ Result of typechecking all the external package - -- interface files we have sucked in. The domain of - -- the mapping is external-package modules - - eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated - -- from all the external-package modules - eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated - -- from all the external-package modules - eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated - -- from all the external-package modules - eps_vect_info :: !PackageVectInfo, -- ^ The total 'VectInfo' accumulated - -- from all the external-package modules - eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated - -- from all the external-package modules - eps_complete_matches :: !PackageCompleteMatchMap, - -- ^ The total 'CompleteMatchMap' accumulated - -- from all the external-package modules - - eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external - -- packages, keyed off the module that declared them - - eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages - } - --- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. --- \"In\" means stuff that is just /read/ from interface files, --- \"Out\" means actually sucked in and type-checked -data EpsStats = EpsStats { n_ifaces_in - , n_decls_in, n_decls_out - , n_rules_in, n_rules_out - , n_insts_in, n_insts_out :: !Int } - -addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats --- ^ Add stats for one newly-read interface -addEpsInStats stats n_decls n_insts n_rules - = stats { n_ifaces_in = n_ifaces_in stats + 1 - , n_decls_in = n_decls_in stats + n_decls - , n_insts_in = n_insts_in stats + n_insts - , n_rules_in = n_rules_in stats + n_rules } - -{- -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. --} - -updNameCacheIO :: HscEnv - -> (NameCache -> (NameCache, c)) -- The updating function - -> IO c -updNameCacheIO hsc_env upd_fn - = atomicModifyIORef' (hsc_NC hsc_env) upd_fn - -mkSOName :: Platform -> FilePath -> FilePath -mkSOName platform root - = case platformOS platform of - OSMinGW32 -> root <.> soExt platform - _ -> ("lib" ++ root) <.> soExt platform - -mkHsSOName :: Platform -> FilePath -> FilePath -mkHsSOName platform root = ("lib" ++ root) <.> soExt platform - -soExt :: Platform -> FilePath -soExt platform - = case platformOS platform of - OSDarwin -> "dylib" - OSiOS -> "dylib" - OSMinGW32 -> "dll" - _ -> "so" - -{- -************************************************************************ -* * - The module graph and ModSummary type - A ModSummary is a node in the compilation manager's - dependency graph, and it's also passed to hscMain -* * -************************************************************************ --} - --- | A ModuleGraph contains all the nodes from the home package (only). --- There will be a node for each source module, plus a node for each hi-boot --- module. --- --- The graph is not necessarily stored in topologically-sorted order. Use --- 'GHC.topSortModuleGraph' and 'Digraph.flattenSCC' to achieve this. -type ModuleGraph = [ModSummary] - -emptyMG :: ModuleGraph -emptyMG = [] - --- | A single node in a 'ModuleGraph'. The nodes of the module graph --- are one of: --- --- * A regular Haskell source module --- * A hi-boot source module --- -data ModSummary - = ModSummary { - ms_mod :: Module, - -- ^ Identity of the module - ms_hsc_src :: HscSource, - -- ^ The module source either plain Haskell or hs-boot - ms_location :: ModLocation, - -- ^ Location of the various files belonging to the module - ms_hs_date :: UTCTime, - -- ^ Timestamp of source file - ms_obj_date :: Maybe UTCTime, - -- ^ Timestamp of object, if we have one - ms_iface_date :: Maybe UTCTime, - -- ^ Timestamp of hi file, if we *only* are typechecking (it is - -- 'Nothing' otherwise. - -- See Note [Recompilation checking when typechecking only] and #9243 - ms_srcimps :: [(Maybe FastString, Located ModuleName)], - -- ^ Source imports of the module - ms_textual_imps :: [(Maybe FastString, Located ModuleName)], - -- ^ Non-source imports of the module from the module *text* - ms_parsed_mod :: Maybe HsParsedModule, - -- ^ The parsed, nonrenamed source, if we have it. This is also - -- used to support "inline module syntax" in Backpack files. - ms_hspp_file :: FilePath, - -- ^ Filename of preprocessed source file - ms_hspp_opts :: DynFlags, - -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@ - -- pragmas in the modules source code - ms_hspp_buf :: Maybe StringBuffer - -- ^ The actual preprocessed source, if we have it - } - -ms_installed_mod :: ModSummary -> InstalledModule -ms_installed_mod = fst . splitModuleInsts . ms_mod - -ms_mod_name :: ModSummary -> ModuleName -ms_mod_name = moduleName . ms_mod - -ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)] -ms_imps ms = - ms_textual_imps ms ++ - map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) - where - mk_additional_import mod_nm = (Nothing, noLoc mod_nm) - --- The ModLocation contains both the original source filename and the --- filename of the cleaned-up source file after all preprocessing has been --- done. The point is that the summariser will have to cpp/unlit/whatever --- all files anyway, and there's no point in doing this twice -- just --- park the result in a temp file, put the name of it in the location, --- and let @compile@ read from that file on the way back up. - --- The ModLocation is stable over successive up-sweeps in GHCi, wheres --- the ms_hs_date and imports can, of course, change - -msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath -msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) -msHiFilePath ms = ml_hi_file (ms_location ms) -msObjFilePath ms = ml_obj_file (ms_location ms) - --- | Did this 'ModSummary' originate from a hs-boot file? -isBootSummary :: ModSummary -> Bool -isBootSummary ms = ms_hsc_src ms == HsBootFile - -instance Outputable ModSummary where - ppr ms - = sep [text "ModSummary {", - nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), - text "ms_mod =" <+> ppr (ms_mod ms) - <> text (hscSourceString (ms_hsc_src ms)) <> comma, - text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), - text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), - char '}' - ] - -showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String -showModMsg dflags target recomp mod_summary = showSDoc dflags $ - if gopt Opt_HideSourcePaths dflags - then text mod_str - else hsep - [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') - , char '(' - , text (op $ msHsFilePath mod_summary) <> char ',' - , case target of - HscInterpreted | recomp -> text "interpreted" - HscNothing -> text "nothing" - _ -> text (op $ msObjFilePath mod_summary) - , char ')' - ] - where - op = normalise - mod = moduleName (ms_mod mod_summary) - mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) - -{- -************************************************************************ -* * -\subsection{Recmpilation} -* * -************************************************************************ --} - --- | Indicates whether a given module's source has been modified since it --- was last compiled. -data SourceModified - = SourceModified - -- ^ the source has been modified - | SourceUnmodified - -- ^ the source has not been modified. Compilation may or may - -- not be necessary, depending on whether any dependencies have - -- changed since we last compiled. - | SourceUnmodifiedAndStable - -- ^ the source has not been modified, and furthermore all of - -- its (transitive) dependencies are up to date; it definitely - -- does not need to be recompiled. This is important for two - -- reasons: (a) we can omit the version check in checkOldIface, - -- and (b) if the module used TH splices we don't need to force - -- recompilation. - -{- -************************************************************************ -* * -\subsection{Hpc Support} -* * -************************************************************************ --} - --- | Information about a modules use of Haskell Program Coverage -data HpcInfo - = HpcInfo - { hpcInfoTickCount :: Int - , hpcInfoHash :: Int - } - | NoHpcInfo - { hpcUsed :: AnyHpcUsage -- ^ Is hpc used anywhere on the module \*tree\*? - } - --- | This is used to signal if one of my imports used HPC instrumentation --- even if there is no module-local HPC usage -type AnyHpcUsage = Bool - -emptyHpcInfo :: AnyHpcUsage -> HpcInfo -emptyHpcInfo = NoHpcInfo - --- | Find out if HPC is used by this module or any of the modules --- it depends upon -isHpcUsed :: HpcInfo -> AnyHpcUsage -isHpcUsed (HpcInfo {}) = True -isHpcUsed (NoHpcInfo { hpcUsed = used }) = used - -{- -************************************************************************ -* * -\subsection{Vectorisation Support} -* * -************************************************************************ - -The following information is generated and consumed by the vectorisation -subsystem. It communicates the vectorisation status of declarations from one -module to another. - -Why do we need both f and f_v in the ModGuts/ModDetails/EPS version VectInfo -below? We need to know `f' when converting to IfaceVectInfo. However, during -vectorisation, we need to know `f_v', whose `Var' we cannot lookup based -on just the OccName easily in a Core pass. --} - --- |Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'; see also --- documentation at 'Vectorise.Env.GlobalEnv'. --- --- NB: The following tables may also include 'Var's, 'TyCon's and 'DataCon's from imported modules, --- which have been subsequently vectorised in the current module. --- -data VectInfo - = VectInfo - { vectInfoVar :: DVarEnv (Var , Var ) -- ^ @(f, f_v)@ keyed on @f@ - , vectInfoTyCon :: NameEnv (TyCon , TyCon) -- ^ @(T, T_v)@ keyed on @T@ - , vectInfoDataCon :: NameEnv (DataCon, DataCon) -- ^ @(C, C_v)@ keyed on @C@ - , vectInfoParallelVars :: DVarSet -- ^ set of parallel variables - , vectInfoParallelTyCons :: NameSet -- ^ set of parallel type constructors - } - --- |Vectorisation information for 'ModIface'; i.e, the vectorisation information propagated --- across module boundaries. --- --- NB: The field 'ifaceVectInfoVar' explicitly contains the workers of data constructors as well as --- class selectors — i.e., their mappings are /not/ implicitly generated from the data types. --- Moreover, whether the worker of a data constructor is in 'ifaceVectInfoVar' determines --- whether that data constructor was vectorised (or is part of an abstractly vectorised type --- constructor). --- -data IfaceVectInfo - = IfaceVectInfo - { ifaceVectInfoVar :: [Name] -- ^ All variables in here have a vectorised variant - , ifaceVectInfoTyCon :: [Name] -- ^ All 'TyCon's in here have a vectorised variant; - -- the name of the vectorised variant and those of its - -- data constructors are determined by - -- 'OccName.mkVectTyConOcc' and - -- 'OccName.mkVectDataConOcc'; the names of the - -- isomorphisms are determined by 'OccName.mkVectIsoOcc' - , ifaceVectInfoTyConReuse :: [Name] -- ^ The vectorised form of all the 'TyCon's in here - -- coincides with the unconverted form; the name of the - -- isomorphisms is determined by 'OccName.mkVectIsoOcc' - , ifaceVectInfoParallelVars :: [Name] -- iface version of 'vectInfoParallelVar' - , ifaceVectInfoParallelTyCons :: [Name] -- iface version of 'vectInfoParallelTyCon' - } - -noVectInfo :: VectInfo -noVectInfo - = VectInfo emptyDVarEnv emptyNameEnv emptyNameEnv emptyDVarSet emptyNameSet - -plusVectInfo :: VectInfo -> VectInfo -> VectInfo -plusVectInfo vi1 vi2 = - VectInfo (vectInfoVar vi1 `plusDVarEnv` vectInfoVar vi2) - (vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2) - (vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2) - (vectInfoParallelVars vi1 `unionDVarSet` vectInfoParallelVars vi2) - (vectInfoParallelTyCons vi1 `unionNameSet` vectInfoParallelTyCons vi2) - -concatVectInfo :: [VectInfo] -> VectInfo -concatVectInfo = foldr plusVectInfo noVectInfo - -noIfaceVectInfo :: IfaceVectInfo -noIfaceVectInfo = IfaceVectInfo [] [] [] [] [] - -isNoIfaceVectInfo :: IfaceVectInfo -> Bool -isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5) - = null l1 && null l2 && null l3 && null l4 && null l5 - -instance Outputable VectInfo where - ppr info = vcat - [ text "variables :" <+> ppr (vectInfoVar info) - , text "tycons :" <+> ppr (vectInfoTyCon info) - , text "datacons :" <+> ppr (vectInfoDataCon info) - , text "parallel vars :" <+> ppr (vectInfoParallelVars info) - , text "parallel tycons :" <+> ppr (vectInfoParallelTyCons info) - ] - -instance Outputable IfaceVectInfo where - ppr info = vcat - [ text "variables :" <+> ppr (ifaceVectInfoVar info) - , text "tycons :" <+> ppr (ifaceVectInfoTyCon info) - , text "tycons reuse :" <+> ppr (ifaceVectInfoTyConReuse info) - , text "parallel vars :" <+> ppr (ifaceVectInfoParallelVars info) - , text "parallel tycons :" <+> ppr (ifaceVectInfoParallelTyCons info) - ] - - -instance Binary IfaceVectInfo where - put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - return (IfaceVectInfo a1 a2 a3 a4 a5) - -{- -************************************************************************ -* * -\subsection{Safe Haskell Support} -* * -************************************************************************ - -This stuff here is related to supporting the Safe Haskell extension, -primarily about storing under what trust type a module has been compiled. --} - --- | Is an import a safe import? -type IsSafeImport = Bool - --- | Safe Haskell information for 'ModIface' --- Simply a wrapper around SafeHaskellMode to sepperate iface and flags -newtype IfaceTrustInfo = TrustInfo SafeHaskellMode - -getSafeMode :: IfaceTrustInfo -> SafeHaskellMode -getSafeMode (TrustInfo x) = x - -setSafeMode :: SafeHaskellMode -> IfaceTrustInfo -setSafeMode = TrustInfo - -noIfaceTrustInfo :: IfaceTrustInfo -noIfaceTrustInfo = setSafeMode Sf_None - -trustInfoToNum :: IfaceTrustInfo -> Word8 -trustInfoToNum it - = case getSafeMode it of - Sf_None -> 0 - Sf_Unsafe -> 1 - Sf_Trustworthy -> 2 - Sf_Safe -> 3 - -numToTrustInfo :: Word8 -> IfaceTrustInfo -numToTrustInfo 0 = setSafeMode Sf_None -numToTrustInfo 1 = setSafeMode Sf_Unsafe -numToTrustInfo 2 = setSafeMode Sf_Trustworthy -numToTrustInfo 3 = setSafeMode Sf_Safe -numToTrustInfo 4 = setSafeMode Sf_Safe -- retained for backwards compat, used - -- to be Sf_SafeInfered but we no longer - -- differentiate. -numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" - -instance Outputable IfaceTrustInfo where - ppr (TrustInfo Sf_None) = text "none" - ppr (TrustInfo Sf_Unsafe) = text "unsafe" - ppr (TrustInfo Sf_Trustworthy) = text "trustworthy" - ppr (TrustInfo Sf_Safe) = text "safe" - -instance Binary IfaceTrustInfo where - put_ bh iftrust = putByte bh $ trustInfoToNum iftrust - get bh = getByte bh >>= (return . numToTrustInfo) - -{- -************************************************************************ -* * -\subsection{Parser result} -* * -************************************************************************ --} - -data HsParsedModule = HsParsedModule { - hpm_module :: Located (HsModule RdrName), - hpm_src_files :: [FilePath], - -- ^ extra source files (e.g. from #includes). The lexer collects - -- these from '# ' pragmas, which the C preprocessor - -- leaves behind. These files and their timestamps are stored in - -- the .hi file, so that we can force recompilation if any of - -- them change (#3589) - hpm_annotations :: ApiAnns - -- See note [Api annotations] in ApiAnnotation.hs - } - -{- -************************************************************************ -* * -\subsection{Linkable stuff} -* * -************************************************************************ - -This stuff is in here, rather than (say) in Linker.hs, because the Linker.hs -stuff is the *dynamic* linker, and isn't present in a stage-1 compiler --} - --- | Information we can use to dynamically link modules into the compiler -data Linkable = LM { - linkableTime :: UTCTime, -- ^ Time at which this linkable was built - -- (i.e. when the bytecodes were produced, - -- or the mod date on the files) - linkableModule :: Module, -- ^ The linkable module itself - linkableUnlinked :: [Unlinked] - -- ^ Those files and chunks of code we have yet to link. - -- - -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. - -- If this list is empty, the Linkable represents a fake linkable, which - -- is generated in HscNothing mode to avoid recompiling modules. - -- - -- ToDo: Do items get removed from this list when they get linked? - } - -isObjectLinkable :: Linkable -> Bool -isObjectLinkable l = not (null unlinked) && all isObject unlinked - where unlinked = linkableUnlinked l - -- A linkable with no Unlinked's is treated as a BCO. We can - -- generate a linkable with no Unlinked's as a result of - -- compiling a module in HscNothing mode, and this choice - -- happens to work well with checkStability in module GHC. - -linkableObjs :: Linkable -> [FilePath] -linkableObjs l = [ f | DotO f <- linkableUnlinked l ] - -instance Outputable Linkable where - ppr (LM when_made mod unlinkeds) - = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) - $$ nest 3 (ppr unlinkeds) - -------------------------------------------- - --- | Objects which have yet to be linked by the compiler -data Unlinked - = DotO FilePath -- ^ An object file (.o) - | DotA FilePath -- ^ Static archive file (.a) - | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) - | BCOs CompiledByteCode - [SptEntry] -- ^ A byte-code object, lives only in memory. Also - -- carries some static pointer table entries which - -- should be loaded along with the BCOs. - -- See Note [Grant plan for static forms] in - -- StaticPtrTable. - -instance Outputable Unlinked where - ppr (DotO path) = text "DotO" <+> text path - ppr (DotA path) = text "DotA" <+> text path - ppr (DotDLL path) = text "DotDLL" <+> text path - ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt - --- | Is this an actual file on disk we can link in somehow? -isObject :: Unlinked -> Bool -isObject (DotO _) = True -isObject (DotA _) = True -isObject (DotDLL _) = True -isObject _ = False - --- | Is this a bytecode linkable with no file on disk? -isInterpretable :: Unlinked -> Bool -isInterpretable = not . isObject - --- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object -nameOfObject :: Unlinked -> FilePath -nameOfObject (DotO fn) = fn -nameOfObject (DotA fn) = fn -nameOfObject (DotDLL fn) = fn -nameOfObject other = pprPanic "nameOfObject" (ppr other) - --- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable -byteCodeOfObject :: Unlinked -> CompiledByteCode -byteCodeOfObject (BCOs bc _) = bc -byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) - - -------------------------------------------- - --- | A list of conlikes which represents a complete pattern match. --- These arise from @COMPLETE@ signatures. - --- See Note [Implementation of COMPLETE signatures] -data CompleteMatch = CompleteMatch { - completeMatchConLikes :: [Name] - -- ^ The ConLikes that form a covering family - -- (e.g. Nothing, Just) - , completeMatchTyCon :: Name - -- ^ The TyCon that they cover (e.g. Maybe) - } - -instance Outputable CompleteMatch where - ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl - <+> dcolon <+> ppr ty - --- | A map keyed by the 'completeMatchTyCon'. - --- See Note [Implementation of COMPLETE signatures] -type CompleteMatchMap = UniqFM [CompleteMatch] - -mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap -mkCompleteMatchMap = extendCompleteMatchMap emptyUFM - -extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch] - -> CompleteMatchMap -extendCompleteMatchMap = foldl' insertMatch - where - insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap - insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c] - -{- -Note [Implementation of COMPLETE signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A COMPLETE signature represents a set of conlikes (i.e., constructors or -pattern synonyms) such that if they are all pattern-matched against in a -function, it gives rise to a total function. An example is: - - newtype Boolean = Boolean Int - pattern F, T :: Boolean - pattern F = Boolean 0 - pattern T = Boolean 1 - {-# COMPLETE F, T #-} - - -- This is a total function - booleanToInt :: Boolean -> Int - booleanToInt F = 0 - booleanToInt T = 1 - -COMPLETE sets are represented internally in GHC with the CompleteMatch data -type. For example, {-# COMPLETE F, T #-} would be represented as: - - CompleteMatch { complateMatchConLikes = [F, T] - , completeMatchTyCon = Boolean } - -Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the -cases in which it's ambiguous, you can also explicitly specify it in the source -language by writing this: - - {-# COMPLETE F, T :: Boolean #-} - -For efficiency purposes, GHC collects all of the CompleteMatches that it knows -about into a CompleteMatchMap, which is a map that is keyed by the -completeMatchTyCon. In other words, you could have a multiple COMPLETE sets -for the same TyCon: - - {-# COMPLETE F, T1 :: Boolean #-} - {-# COMPLETE F, T2 :: Boolean #-} - -And looking up the values in the CompleteMatchMap associated with Boolean -would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean]. -dsGetCompleteMatches in DsMeta accomplishes this lookup. - -Also see Note [Typechecking Complete Matches] in TcBinds for a more detailed -explanation for how GHC ensures that all the conlikes in a COMPLETE set are -consistent. --} diff --git a/main/InteractiveEval.hs b/main/InteractiveEval.hs deleted file mode 100644 --- a/main/InteractiveEval.hs +++ /dev/null @@ -1,937 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples, - RecordWildCards, BangPatterns #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2007 --- --- Running statements interactively --- --- ----------------------------------------------------------------------------- - -module InteractiveEval ( - Resume(..), History(..), - execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec, - runDecls, runDeclsWithLocation, - isStmt, hasImport, isImport, isDecl, - parseImportDecl, SingleStep(..), - abandon, abandonAll, - getResumeContext, - getHistorySpan, - getModBreaks, - getHistoryModule, - back, forward, - setContext, getContext, - availsToGlobalRdrEnv, - getNamesInScope, - getRdrNamesInScope, - moduleIsInterpreted, - getInfo, - exprType, - typeKind, - parseName, - showModule, - moduleIsBootOrNotObjectLinkable, - parseExpr, compileParsedExpr, - compileExpr, dynCompileExpr, - compileExprRemote, compileParsedExprRemote, - Term(..), obtainTermFromId, obtainTermFromVal, reconstructType - ) where - -#include "HsVersions.h" - -import InteractiveEvalTypes - -import GHCi -import GHCi.Message -import GHCi.RemoteTypes -import GhcMonad -import HscMain -import HsSyn -import HscTypes -import InstEnv -import IfaceEnv ( newInteractiveBinder ) -import FamInstEnv ( FamInst ) -import CoreFVs ( orphNamesOfFamInst ) -import TyCon -import Type hiding( typeKind ) -import RepType -import TcType hiding( typeKind ) -import Var -import Id -import Name hiding ( varName ) -import NameSet -import Avail -import RdrName -import VarEnv -import ByteCodeTypes -import Linker -import DynFlags -import Unique -import UniqSupply -import MonadUtils -import Module -import PrelNames ( toDynName, pretendNameIsInScope ) -import Panic -import Maybes -import ErrUtils -import SrcLoc -import RtClosureInspect -import Outputable -import FastString -import Bag -import qualified Lexer (P (..), ParseResult(..), unP, mkPState) -import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport) - -import System.Directory -import Data.Dynamic -import Data.Either -import qualified Data.IntMap as IntMap -import Data.List (find,intercalate) -import StringBuffer (stringToStringBuffer) -import Control.Monad -import GHC.Exts -import Data.Array -import Exception - --- ----------------------------------------------------------------------------- --- running a statement interactively - -getResumeContext :: GhcMonad m => m [Resume] -getResumeContext = withSession (return . ic_resume . hsc_IC) - -mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History -mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi) - -getHistoryModule :: History -> Module -getHistoryModule = breakInfo_module . historyBreakInfo - -getHistorySpan :: HscEnv -> History -> SrcSpan -getHistorySpan hsc_env History{..} = - let BreakInfo{..} = historyBreakInfo in - case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of - Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number - _ -> panic "getHistorySpan" - -getModBreaks :: HomeModInfo -> ModBreaks -getModBreaks hmi - | Just linkable <- hm_linkable hmi, - [BCOs cbc _] <- linkableUnlinked linkable - = fromMaybe emptyModBreaks (bc_breaks cbc) - | otherwise - = emptyModBreaks -- probably object code - -{- | Finds the enclosing top level function name -} --- ToDo: a better way to do this would be to keep hold of the decl_path computed --- by the coverage pass, which gives the list of lexically-enclosing bindings --- for each tick. -findEnclosingDecls :: HscEnv -> BreakInfo -> [String] -findEnclosingDecls hsc_env (BreakInfo modl ix) = - let hmi = expectJust "findEnclosingDecls" $ - lookupHpt (hsc_HPT hsc_env) (moduleName modl) - mb = getModBreaks hmi - in modBreaks_decls mb ! ix - --- | Update fixity environment in the current interactive context. -updateFixityEnv :: GhcMonad m => FixityEnv -> m () -updateFixityEnv fix_env = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } } - --- ----------------------------------------------------------------------------- --- execStmt - --- | default ExecOptions -execOptions :: ExecOptions -execOptions = ExecOptions - { execSingleStep = RunToCompletion - , execSourceFile = "" - , execLineNumber = 1 - , execWrap = EvalThis -- just run the statement, don't wrap it in anything - } - --- | Run a statement in the current interactive context. -execStmt - :: GhcMonad m - => String -- ^ a statement (bind or expression) - -> ExecOptions - -> m ExecResult -execStmt stmt ExecOptions{..} = do - hsc_env <- getSession - - -- Turn off -fwarn-unused-local-binds when running a statement, to hide - -- warnings about the implicit bindings we introduce. - let ic = hsc_IC hsc_env -- use the interactive dflags - idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds - hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } } - - -- compile to value (IO [HValue]), don't run - r <- liftIO $ hscStmtWithLocation hsc_env' stmt - execSourceFile execLineNumber - - case r of - -- empty statement / comment - Nothing -> return (ExecComplete (Right []) 0) - - Just (ids, hval, fix_env) -> do - updateFixityEnv fix_env - - status <- - withVirtualCWD $ - liftIO $ - evalStmt hsc_env' (isStep execSingleStep) (execWrap hval) - - let ic = hsc_IC hsc_env - bindings = (ic_tythings ic, ic_rn_gbl_env ic) - - size = ghciHistSize idflags' - - handleRunStatus execSingleStep stmt bindings ids - status (emptyHistory size) - - -runDecls :: GhcMonad m => String -> m [Name] -runDecls = runDeclsWithLocation "" 1 - --- | Run some declarations and return any user-visible names that were brought --- into scope. -runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] -runDeclsWithLocation source linenumber expr = - do - hsc_env <- getSession - (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber - - setSession $ hsc_env { hsc_IC = ic } - hsc_env <- getSession - hsc_env' <- liftIO $ rttiEnvironment hsc_env - setSession hsc_env' - return $ filter (not . isDerivedOccName . nameOccName) - -- For this filter, see Note [What to show to users] - $ map getName tyThings - -{- Note [What to show to users] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't want to display internally-generated bindings to users. -Things like the coercion axiom for newtypes. These bindings all get -OccNames that users can't write, to avoid the possiblity of name -clashes (in linker symbols). That gives a convenient way to suppress -them. The relevant predicate is OccName.isDerivedOccName. -See Trac #11051 for more background and examples. --} - -withVirtualCWD :: GhcMonad m => m a -> m a -withVirtualCWD m = do - hsc_env <- getSession - - -- a virtual CWD is only necessary when we're running interpreted code in - -- the same process as the compiler. - if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do - - let ic = hsc_IC hsc_env - let set_cwd = do - dir <- liftIO $ getCurrentDirectory - case ic_cwd ic of - Just dir -> liftIO $ setCurrentDirectory dir - Nothing -> return () - return dir - - reset_cwd orig_dir = do - virt_dir <- liftIO $ getCurrentDirectory - hsc_env <- getSession - let old_IC = hsc_IC hsc_env - setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } - liftIO $ setCurrentDirectory orig_dir - - gbracket set_cwd reset_cwd $ \_ -> m - -parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName) -parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr - -emptyHistory :: Int -> BoundedList History -emptyHistory size = nilBL size - -handleRunStatus :: GhcMonad m - => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id] - -> EvalStatus_ [ForeignHValue] [HValueRef] - -> BoundedList History - -> m ExecResult - -handleRunStatus step expr bindings final_ids status history - | RunAndLogSteps <- step = tracing - | otherwise = not_tracing - where - tracing - | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status - , not is_exception - = do - hsc_env <- getSession - let hmi = expectJust "handleRunStatus" $ - lookupHptDirectly (hsc_HPT hsc_env) - (mkUniqueGrimily mod_uniq) - modl = mi_module (hm_iface hmi) - breaks = getModBreaks hmi - - b <- liftIO $ - breakpointStatus hsc_env (modBreaks_flags breaks) ix - if b - then not_tracing - -- This breakpoint is explicitly enabled; we want to stop - -- instead of just logging it. - else do - apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref - let bi = BreakInfo modl ix - !history' = mkHistory hsc_env apStack_fhv bi `consBL` history - -- history is strict, otherwise our BoundedList is pointless. - fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt - status <- liftIO $ GHCi.resumeStmt hsc_env True fhv - handleRunStatus RunAndLogSteps expr bindings final_ids - status history' - | otherwise - = not_tracing - - not_tracing - -- Hit a breakpoint - | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status - = do - hsc_env <- getSession - resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt - apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref - let hmi = expectJust "handleRunStatus" $ - lookupHptDirectly (hsc_HPT hsc_env) - (mkUniqueGrimily mod_uniq) - modl = mi_module (hm_iface hmi) - bp | is_exception = Nothing - | otherwise = Just (BreakInfo modl ix) - (hsc_env1, names, span, decl) <- liftIO $ - bindLocalsAtBreakpoint hsc_env apStack_fhv bp - let - resume = Resume - { resumeStmt = expr, resumeContext = resume_ctxt_fhv - , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack_fhv - , resumeBreakInfo = bp - , resumeSpan = span, resumeHistory = toListBL history - , resumeDecl = decl - , resumeCCS = ccs - , resumeHistoryIx = 0 } - hsc_env2 = pushResume hsc_env1 resume - - setSession hsc_env2 - return (ExecBreak names bp) - - -- Completed successfully - | EvalComplete allocs (EvalSuccess hvals) <- status - = do hsc_env <- getSession - let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids - final_names = map getName final_ids - liftIO $ Linker.extendLinkEnv (zip final_names hvals) - hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} - setSession hsc_env' - return (ExecComplete (Right final_names) allocs) - - -- Completed with an exception - | EvalComplete alloc (EvalException e) <- status - = return (ExecComplete (Left (fromSerializableException e)) alloc) - - | otherwise - = panic "not_tracing" -- actually exhaustive, but GHC can't tell - - -resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult -resumeExec canLogSpan step - = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - resume = ic_resume ic - - case resume of - [] -> liftIO $ - throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") - (r:rs) -> do - -- unbind the temporary locals by restoring the TypeEnv from - -- before the breakpoint, and drop this Resume from the - -- InteractiveContext. - let (resume_tmp_te,resume_rdr_env) = resumeBindings r - ic' = ic { ic_tythings = resume_tmp_te, - ic_rn_gbl_env = resume_rdr_env, - ic_resume = rs } - setSession hsc_env{ hsc_IC = ic' } - - -- remove any bindings created since the breakpoint from the - -- linker's environment - let old_names = map getName resume_tmp_te - new_names = [ n | thing <- ic_tythings ic - , let n = getName thing - , not (n `elem` old_names) ] - liftIO $ Linker.deleteFromLinkEnv new_names - - case r of - Resume { resumeStmt = expr, resumeContext = fhv - , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack, resumeBreakInfo = mb_brkpt - , resumeSpan = span - , resumeHistory = hist } -> do - withVirtualCWD $ do - status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv - let prevHistoryLst = fromListBL 50 hist - hist' = case mb_brkpt of - Nothing -> prevHistoryLst - Just bi - | not $canLogSpan span -> prevHistoryLst - | otherwise -> mkHistory hsc_env apStack bi `consBL` - fromListBL 50 hist - handleRunStatus step expr bindings final_ids status hist' - -back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) -back n = moveHist (+n) - -forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) -forward n = moveHist (subtract n) - -moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String) -moveHist fn = do - hsc_env <- getSession - case ic_resume (hsc_IC hsc_env) of - [] -> liftIO $ - throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") - (r:rs) -> do - let ix = resumeHistoryIx r - history = resumeHistory r - new_ix = fn ix - -- - when (new_ix > length history) $ liftIO $ - throwGhcExceptionIO (ProgramError "no more logged breakpoints") - when (new_ix < 0) $ liftIO $ - throwGhcExceptionIO (ProgramError "already at the beginning of the history") - - let - update_ic apStack mb_info = do - (hsc_env1, names, span, decl) <- - liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info - let ic = hsc_IC hsc_env1 - r' = r { resumeHistoryIx = new_ix } - ic' = ic { ic_resume = r':rs } - - setSession hsc_env1{ hsc_IC = ic' } - - return (names, new_ix, span, decl) - - -- careful: we want apStack to be the AP_STACK itself, not a thunk - -- around it, hence the cases are carefully constructed below to - -- make this the case. ToDo: this is v. fragile, do something better. - if new_ix == 0 - then case r of - Resume { resumeApStack = apStack, - resumeBreakInfo = mb_brkpt } -> - update_ic apStack mb_brkpt - else case history !! (new_ix - 1) of - History{..} -> - update_ic historyApStack (Just historyBreakInfo) - - --- ----------------------------------------------------------------------------- --- After stopping at a breakpoint, add free variables to the environment - -result_fs :: FastString -result_fs = fsLit "_result" - -bindLocalsAtBreakpoint - :: HscEnv - -> ForeignHValue - -> Maybe BreakInfo - -> IO (HscEnv, [Name], SrcSpan, String) - --- Nothing case: we stopped when an exception was raised, not at a --- breakpoint. We have no location information or local variables to --- bind, all we can do is bind a local variable to the exception --- value. -bindLocalsAtBreakpoint hsc_env apStack Nothing = do - let exn_occ = mkVarOccFS (fsLit "_exception") - span = mkGeneralSrcSpan (fsLit "") - exn_name <- newInteractiveBinder hsc_env exn_occ span - - let e_fs = fsLit "e" - e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span - e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind - exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) - - ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] - -- - Linker.extendLinkEnv [(exn_name, apStack)] - return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "") - --- Just case: we stopped at a breakpoint, we have information about the location --- of the breakpoint and the free variables of the expression. -bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do - let - hmi = expectJust "bindLocalsAtBreakpoint" $ - lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) - breaks = getModBreaks hmi - info = expectJust "bindLocalsAtBreakpoint2" $ - IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks) - vars = cgb_vars info - result_ty = cgb_resty info - occs = modBreaks_vars breaks ! breakInfo_number - span = modBreaks_locs breaks ! breakInfo_number - decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number - - -- Filter out any unboxed ids; - -- we can't bind these at the prompt - pointers = filter (\(id,_) -> isPointer id) vars - isPointer id | [rep] <- typePrimRep (idType id) - , isGcPtrRep rep = True - | otherwise = False - - (ids, offsets) = unzip pointers - - free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids) - - -- It might be that getIdValFromApStack fails, because the AP_STACK - -- has been accidentally evaluated, or something else has gone wrong. - -- So that we don't fall over in a heap when this happens, just don't - -- bind any free variables instead, and we emit a warning. - mb_hValues <- - mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets - when (any isNothing mb_hValues) $ - debugTraceMsg (hsc_dflags hsc_env) 1 $ - text "Warning: _result has been evaluated, some bindings have been lost" - - us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time - let tv_subst = newTyVars us free_tvs - filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ] - (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $ - map (substTy tv_subst . idType) filtered_ids - - new_ids <- zipWith3M mkNewId occs tidy_tys filtered_ids - result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span - - let result_id = Id.mkVanillaGlobal result_name - (substTy tv_subst result_ty) - result_ok = isPointer result_id - - final_ids | result_ok = result_id : new_ids - | otherwise = new_ids - ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids - names = map idName new_ids - - let fhvs = catMaybes mb_hValues - Linker.extendLinkEnv (zip names fhvs) - when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)] - hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, if result_ok then result_name:names else names, span, decl) - where - -- We need a fresh Unique for each Id we bind, because the linker - -- state is single-threaded and otherwise we'd spam old bindings - -- whenever we stop at a breakpoint. The InteractveContext is properly - -- saved/restored, but not the linker state. See #1743, test break026. - mkNewId :: OccName -> Type -> Id -> IO Id - mkNewId occ ty old_id - = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id) - ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) } - - newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst - -- Similarly, clone the type variables mentioned in the types - -- we have here, *and* make them all RuntimeUnk tyvars - newTyVars us tvs - = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv))) - | (tv, uniq) <- tvs `zip` uniqsFromSupply us - , let name = setNameUnique (tyVarName tv) uniq ] - -rttiEnvironment :: HscEnv -> IO HscEnv -rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do - let tmp_ids = [id | AnId id <- ic_tythings ic] - incompletelyTypedIds = - [id | id <- tmp_ids - , not $ noSkolems id - , (occNameFS.nameOccName.idName) id /= result_fs] - hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) - return hsc_env' - where - noSkolems = noFreeVarsOfType . idType - improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do - let tmp_ids = [id | AnId id <- ic_tythings ic] - Just id = find (\i -> idName i == name) tmp_ids - if noSkolems id - then return hsc_env - else do - mb_new_ty <- reconstructType hsc_env 10 id - let old_ty = idType id - case mb_new_ty of - Nothing -> return hsc_env - Just new_ty -> do - case improveRTTIType hsc_env old_ty new_ty of - Nothing -> return $ - WARN(True, text (":print failed to calculate the " - ++ "improvement for a type")) hsc_env - Just subst -> do - let dflags = hsc_dflags hsc_env - when (dopt Opt_D_dump_rtti dflags) $ - printInfoForUser dflags alwaysQualify $ - fsep [text "RTTI Improvement for", ppr id, equals, ppr subst] - - let ic' = substInteractiveContext ic subst - return hsc_env{hsc_IC=ic'} - -pushResume :: HscEnv -> Resume -> HscEnv -pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } - where - ictxt0 = hsc_IC hsc_env - ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 } - --- ----------------------------------------------------------------------------- --- Abandoning a resume context - -abandon :: GhcMonad m => m Bool -abandon = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - resume = ic_resume ic - case resume of - [] -> return False - r:rs -> do - setSession hsc_env{ hsc_IC = ic { ic_resume = rs } } - liftIO $ abandonStmt hsc_env (resumeContext r) - return True - -abandonAll :: GhcMonad m => m Bool -abandonAll = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - resume = ic_resume ic - case resume of - [] -> return False - rs -> do - setSession hsc_env{ hsc_IC = ic { ic_resume = [] } } - liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs - return True - --- ----------------------------------------------------------------------------- --- Bounded list, optimised for repeated cons - -data BoundedList a = BL - {-# UNPACK #-} !Int -- length - {-# UNPACK #-} !Int -- bound - [a] -- left - [a] -- right, list is (left ++ reverse right) - -nilBL :: Int -> BoundedList a -nilBL bound = BL 0 bound [] [] - -consBL :: a -> BoundedList a -> BoundedList a -consBL a (BL len bound left right) - | len < bound = BL (len+1) bound (a:left) right - | null right = BL len bound [a] $! tail (reverse left) - | otherwise = BL len bound (a:left) $! tail right - -toListBL :: BoundedList a -> [a] -toListBL (BL _ _ left right) = left ++ reverse right - -fromListBL :: Int -> [a] -> BoundedList a -fromListBL bound l = BL (length l) bound l [] - --- lenBL (BL len _ _ _) = len - --- ----------------------------------------------------------------------------- --- | Set the interactive evaluation context. --- --- (setContext imports) sets the ic_imports field (which in turn --- determines what is in scope at the prompt) to 'imports', and --- constructs the ic_rn_glb_env environment to reflect it. --- --- We retain in scope all the things defined at the prompt, and kept --- in ic_tythings. (Indeed, they shadow stuff from ic_imports.) - -setContext :: GhcMonad m => [InteractiveImport] -> m () -setContext imports - = do { hsc_env <- getSession - ; let dflags = hsc_dflags hsc_env - ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports - ; case all_env_err of - Left (mod, err) -> - liftIO $ throwGhcExceptionIO (formatError dflags mod err) - Right all_env -> do { - ; let old_ic = hsc_IC hsc_env - !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic - ; setSession - hsc_env{ hsc_IC = old_ic { ic_imports = imports - , ic_rn_gbl_env = final_rdr_env }}}} - where - formatError dflags mod err = ProgramError . showSDoc dflags $ - text "Cannot add module" <+> ppr mod <+> - text "to context:" <+> text err - -findGlobalRdrEnv :: HscEnv -> [InteractiveImport] - -> IO (Either (ModuleName, String) GlobalRdrEnv) --- Compute the GlobalRdrEnv for the interactive context -findGlobalRdrEnv hsc_env imports - = do { idecls_env <- hscRnImportDecls hsc_env idecls - -- This call also loads any orphan modules - ; return $ case partitionEithers (map mkEnv imods) of - ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) - (err : _, _) -> Left err } - where - idecls :: [LImportDecl RdrName] - idecls = [noLoc d | IIDecl d <- imports] - - imods :: [ModuleName] - imods = [m | IIModule m <- imports] - - mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of - Left err -> Left (mod, err) - Right env -> Right env - -availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv -availsToGlobalRdrEnv mod_name avails - = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails) - where - -- We're building a GlobalRdrEnv as if the user imported - -- all the specified modules into the global interactive module - imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} - decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, - is_qual = False, - is_dloc = srcLocSpan interactiveSrcLoc } - -mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv -mkTopLevEnv hpt modl - = case lookupHpt hpt modl of - Nothing -> Left "not a home module" - Just details -> - case mi_globals (hm_iface details) of - Nothing -> Left "not interpreted" - Just env -> Right env - --- | Get the interactive evaluation context, consisting of a pair of the --- set of modules from which we take the full top-level scope, and the set --- of modules from which we take just the exports respectively. -getContext :: GhcMonad m => m [InteractiveImport] -getContext = withSession $ \HscEnv{ hsc_IC=ic } -> - return (ic_imports ic) - --- | Returns @True@ if the specified module is interpreted, and hence has --- its full top-level scope available. -moduleIsInterpreted :: GhcMonad m => Module -> m Bool -moduleIsInterpreted modl = withSession $ \h -> - if moduleUnitId modl /= thisPackage (hsc_dflags h) - then return False - else case lookupHpt (hsc_HPT h) (moduleName modl) of - Just details -> return (isJust (mi_globals (hm_iface details))) - _not_a_home_module -> return False - --- | Looks up an identifier in the current interactive context (for :info) --- Filter the instances by the ones whose tycons (or clases resp) --- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! --- The exact choice of which ones to show, and which to hide, is a judgement call. --- (see Trac #1581) -getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) -getInfo allInfo name - = withSession $ \hsc_env -> - do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name - case mb_stuff of - Nothing -> return Nothing - Just (thing, fixity, cls_insts, fam_insts) -> do - let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) - - -- Filter the instances based on whether the constituent names of their - -- instance heads are all in scope. - let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts - fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts - return (Just (thing, fixity, cls_insts', fam_insts')) - where - plausible rdr_env names - -- Dfun involving only names that are in ic_rn_glb_env - = allInfo - || nameSetAll ok names - where -- A name is ok if it's in the rdr_env, - -- whether qualified or not - ok n | n == name = True - -- The one we looked for in the first place! - | pretendNameIsInScope n = True - | isBuiltInSyntax n = True - | isExternalName n = isJust (lookupGRE_Name rdr_env n) - | otherwise = True - --- | Returns all names in scope in the current interactive context -getNamesInScope :: GhcMonad m => m [Name] -getNamesInScope = withSession $ \hsc_env -> do - return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) - --- | Returns all 'RdrName's in scope in the current interactive --- context, excluding any that are internally-generated. -getRdrNamesInScope :: GhcMonad m => m [RdrName] -getRdrNamesInScope = withSession $ \hsc_env -> do - let - ic = hsc_IC hsc_env - gbl_rdrenv = ic_rn_gbl_env ic - gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv - -- Exclude internally generated names; see e.g. Trac #11328 - return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names) - - --- | Parses a string as an identifier, and returns the list of 'Name's that --- the identifier can refer to in the current interactive context. -parseName :: GhcMonad m => String -> m [Name] -parseName str = withSession $ \hsc_env -> liftIO $ - do { lrdr_name <- hscParseIdentifier hsc_env str - ; hscTcRnLookupRdrName hsc_env lrdr_name } - --- | Returns @True@ if passed string is a statement. -isStmt :: DynFlags -> String -> Bool -isStmt dflags stmt = - case parseThing Parser.parseStmt dflags stmt of - Lexer.POk _ _ -> True - Lexer.PFailed _ _ -> False - --- | Returns @True@ if passed string has an import declaration. -hasImport :: DynFlags -> String -> Bool -hasImport dflags stmt = - case parseThing Parser.parseModule dflags stmt of - Lexer.POk _ thing -> hasImports thing - Lexer.PFailed _ _ -> False - where - hasImports = not . null . hsmodImports . unLoc - --- | Returns @True@ if passed string is an import declaration. -isImport :: DynFlags -> String -> Bool -isImport dflags stmt = - case parseThing Parser.parseImport dflags stmt of - Lexer.POk _ _ -> True - Lexer.PFailed _ _ -> False - --- | Returns @True@ if passed string is a declaration but __/not a splice/__. -isDecl :: DynFlags -> String -> Bool -isDecl dflags stmt = do - case parseThing Parser.parseDeclaration dflags stmt of - Lexer.POk _ thing -> - case unLoc thing of - SpliceD _ -> False - _ -> True - Lexer.PFailed _ _ -> False - -parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing -parseThing parser dflags stmt = do - let buf = stringToStringBuffer stmt - loc = mkRealSrcLoc (fsLit "") 1 1 - - Lexer.unP parser (Lexer.mkPState dflags buf loc) - --- ----------------------------------------------------------------------------- --- Getting the type of an expression - --- | Get the type of an expression --- Returns the type as described by 'TcRnExprMode' -exprType :: GhcMonad m => TcRnExprMode -> String -> m Type -exprType mode expr = withSession $ \hsc_env -> do - ty <- liftIO $ hscTcExpr hsc_env mode expr - return $ tidyType emptyTidyEnv ty - --- ----------------------------------------------------------------------------- --- Getting the kind of a type - --- | Get the kind of a type -typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind) -typeKind normalise str = withSession $ \hsc_env -> do - liftIO $ hscKcType hsc_env normalise str - ------------------------------------------------------------------------------ --- Compile an expression, run it and deliver the result - --- | Parse an expression, the parsed expression can be further processed and --- passed to compileParsedExpr. -parseExpr :: GhcMonad m => String -> m (LHsExpr RdrName) -parseExpr expr = withSession $ \hsc_env -> do - liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr - --- | Compile an expression, run it and deliver the resulting HValue. -compileExpr :: GhcMonad m => String -> m HValue -compileExpr expr = do - parsed_expr <- parseExpr expr - compileParsedExpr parsed_expr - --- | Compile an expression, run it and deliver the resulting HValue. -compileExprRemote :: GhcMonad m => String -> m ForeignHValue -compileExprRemote expr = do - parsed_expr <- parseExpr expr - compileParsedExprRemote parsed_expr - --- | Compile an parsed expression (before renaming), run it and deliver --- the resulting HValue. -compileParsedExprRemote :: GhcMonad m => LHsExpr RdrName -> m ForeignHValue -compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do - -- > let _compileParsedExpr = expr - -- Create let stmt from expr to make hscParsedStmt happy. - -- We will ignore the returned [Id], namely [expr_id], and not really - -- create a new binding. - let expr_fs = fsLit "_compileParsedExpr" - expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc - let_stmt = L loc . LetStmt . L loc . HsValBinds $ - ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] - - Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt - updateFixityEnv fix_env - status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io) - case status of - EvalComplete _ (EvalSuccess [hval]) -> return hval - EvalComplete _ (EvalException e) -> - liftIO $ throwIO (fromSerializableException e) - _ -> panic "compileParsedExpr" - -compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue -compileParsedExpr expr = do - fhv <- compileParsedExprRemote expr - dflags <- getDynFlags - liftIO $ wormhole dflags fhv - --- | Compile an expression, run it and return the result as a Dynamic. -dynCompileExpr :: GhcMonad m => String -> m Dynamic -dynCompileExpr expr = do - parsed_expr <- parseExpr expr - -- > Data.Dynamic.toDyn expr - let loc = getLoc parsed_expr - to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName) - parsed_expr - hval <- compileParsedExpr to_dyn_expr - return (unsafeCoerce# hval :: Dynamic) - ------------------------------------------------------------------------------ --- show a module and it's source/object filenames - -showModule :: GhcMonad m => ModSummary -> m String -showModule mod_summary = - withSession $ \hsc_env -> do - interpreted <- moduleIsBootOrNotObjectLinkable mod_summary - let dflags = hsc_dflags hsc_env - return (showModMsg dflags (hscTarget dflags) interpreted mod_summary) - -moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool -moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> - case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of - Nothing -> panic "missing linkable" - Just mod_info -> return $ case hm_linkable mod_info of - Nothing -> True - Just linkable -> not (isObjectLinkable linkable) - ----------------------------------------------------------------------------- --- RTTI primitives - -obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term -obtainTermFromVal hsc_env bound force ty x = - cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) - -obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term -obtainTermFromId hsc_env bound force id = do - let dflags = hsc_dflags hsc_env - hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags - 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 - let dflags = hsc_dflags hsc_env - hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags - cvReconstructType hsc_env bound (idType id) hv - -mkRuntimeUnkTyVar :: Name -> Kind -> TyVar -mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk diff --git a/main/InteractiveEvalTypes.hs b/main/InteractiveEvalTypes.hs deleted file mode 100644 --- a/main/InteractiveEvalTypes.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE CPP #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2007 --- --- Running statements interactively --- --- ----------------------------------------------------------------------------- - -module InteractiveEvalTypes ( - Resume(..), History(..), ExecResult(..), - SingleStep(..), isStep, ExecOptions(..), - BreakInfo(..) - ) where - -import GHCi.RemoteTypes -import GHCi.Message (EvalExpr, ResumeContext) -import Id -import Name -import Module -import RdrName -import Type -import SrcLoc -import Exception - -import Data.Word -#if MIN_VERSION_base(4,9,0) -import GHC.Stack.CCS -#else -import GHC.Stack as GHC.Stack.CCS -#endif - -data ExecOptions - = ExecOptions - { execSingleStep :: SingleStep -- ^ stepping mode - , execSourceFile :: String -- ^ filename (for errors) - , execLineNumber :: Int -- ^ line number (for errors) - , execWrap :: ForeignHValue -> EvalExpr ForeignHValue - } - -data SingleStep - = RunToCompletion - | SingleStep - | RunAndLogSteps - -isStep :: SingleStep -> Bool -isStep RunToCompletion = False -isStep _ = True - -data ExecResult - = ExecComplete - { execResult :: Either SomeException [Name] - , execAllocation :: Word64 - } - | ExecBreak - { breakNames :: [Name] - , breakInfo :: Maybe BreakInfo - } - -data BreakInfo = BreakInfo - { breakInfo_module :: Module - , breakInfo_number :: Int - } - -data Resume = Resume - { resumeStmt :: String -- the original statement - , resumeContext :: ForeignRef (ResumeContext [HValueRef]) - , resumeBindings :: ([TyThing], GlobalRdrEnv) - , resumeFinalIds :: [Id] -- [Id] to bind on completion - , resumeApStack :: ForeignHValue -- The object from which we can get - -- value of the free variables. - , resumeBreakInfo :: Maybe BreakInfo - -- the breakpoint we stopped at - -- (module, index) - -- (Nothing <=> exception) - , resumeSpan :: SrcSpan -- just a copy of the SrcSpan - -- from the ModBreaks, - -- otherwise it's a pain to - -- fetch the ModDetails & - -- ModBreaks to get this. - , resumeDecl :: String -- ditto - , resumeCCS :: RemotePtr CostCentreStack - , resumeHistory :: [History] - , resumeHistoryIx :: Int -- 0 <==> at the top of the history - } - -data History - = History { - historyApStack :: ForeignHValue, - historyBreakInfo :: BreakInfo, - historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint - } diff --git a/main/PackageConfig.hs b/main/PackageConfig.hs deleted file mode 100644 --- a/main/PackageConfig.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-} - --- | --- Package configuration information: essentially the interface to Cabal, with --- some utilities --- --- (c) The University of Glasgow, 2004 --- -module PackageConfig ( - -- $package_naming - - -- * UnitId - packageConfigId, - expandedPackageConfigId, - definitePackageConfigId, - installedPackageConfigId, - - -- * The PackageConfig type: information about a package - PackageConfig, - InstalledPackageInfo(..), - ComponentId(..), - SourcePackageId(..), - PackageName(..), - Version(..), - defaultPackageConfig, - sourcePackageIdString, - packageNameString, - pprPackageConfig, - ) where - -#include "HsVersions.h" - -import GHC.PackageDb -import Data.Version - -import FastString -import Outputable -import Module -import Unique - --- ----------------------------------------------------------------------------- --- Our PackageConfig type is the InstalledPackageInfo from ghc-boot, --- which is similar to a subset of the InstalledPackageInfo type from Cabal. - -type PackageConfig = InstalledPackageInfo - ComponentId - SourcePackageId - PackageName - Module.InstalledUnitId - Module.UnitId - Module.ModuleName - Module.Module - --- TODO: there's no need for these to be FastString, as we don't need the uniq --- feature, but ghc doesn't currently have convenient support for any --- other compact string types, e.g. plain ByteString or Text. - -newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord) -newtype PackageName = PackageName FastString deriving (Eq, Ord) - -instance BinaryStringRep SourcePackageId where - fromStringRep = SourcePackageId . mkFastStringByteString - toStringRep (SourcePackageId s) = fastStringToByteString s - -instance BinaryStringRep PackageName where - fromStringRep = PackageName . mkFastStringByteString - toStringRep (PackageName s) = fastStringToByteString s - -instance Uniquable SourcePackageId where - getUnique (SourcePackageId n) = getUnique n - -instance Uniquable PackageName where - getUnique (PackageName n) = getUnique n - -instance Outputable SourcePackageId where - ppr (SourcePackageId str) = ftext str - -instance Outputable PackageName where - ppr (PackageName str) = ftext str - -defaultPackageConfig :: PackageConfig -defaultPackageConfig = emptyInstalledPackageInfo - -sourcePackageIdString :: PackageConfig -> String -sourcePackageIdString pkg = unpackFS str - where - SourcePackageId str = sourcePackageId pkg - -packageNameString :: PackageConfig -> String -packageNameString pkg = unpackFS str - where - PackageName str = packageName pkg - -pprPackageConfig :: PackageConfig -> SDoc -pprPackageConfig InstalledPackageInfo {..} = - vcat [ - field "name" (ppr packageName), - field "version" (text (showVersion packageVersion)), - field "id" (ppr unitId), - field "exposed" (ppr exposed), - field "exposed-modules" (ppr exposedModules), - field "hidden-modules" (fsep (map ppr hiddenModules)), - field "trusted" (ppr trusted), - field "import-dirs" (fsep (map text importDirs)), - field "library-dirs" (fsep (map text libraryDirs)), - field "dynamic-library-dirs" (fsep (map text libraryDynDirs)), - field "hs-libraries" (fsep (map text hsLibraries)), - field "extra-libraries" (fsep (map text extraLibraries)), - field "extra-ghci-libraries" (fsep (map text extraGHCiLibraries)), - field "include-dirs" (fsep (map text includeDirs)), - field "includes" (fsep (map text includes)), - field "depends" (fsep (map ppr depends)), - field "cc-options" (fsep (map text ccOptions)), - field "ld-options" (fsep (map text ldOptions)), - field "framework-dirs" (fsep (map text frameworkDirs)), - field "frameworks" (fsep (map text frameworks)), - field "haddock-interfaces" (fsep (map text haddockInterfaces)), - field "haddock-html" (fsep (map text haddockHTMLs)) - ] - where - field name body = text name <> colon <+> nest 4 body - --- ----------------------------------------------------------------------------- --- UnitId (package names, versions and dep hash) - --- $package_naming --- #package_naming# --- Mostly the compiler deals in terms of 'UnitId's, which are md5 hashes --- of a package ID, keys of its dependencies, and Cabal flags. You're expected --- to pass in the unit id in the @-this-unit-id@ flag. However, for --- wired-in packages like @base@ & @rts@, we don't necessarily know what the --- version is, so these are handled specially; see #wired_in_packages#. - --- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig' -installedPackageConfigId :: PackageConfig -> InstalledUnitId -installedPackageConfigId = unitId - -packageConfigId :: PackageConfig -> UnitId -packageConfigId p = - if indefinite p - then newUnitId (componentId p) (instantiatedWith p) - else DefiniteUnitId (DefUnitId (unitId p)) - -expandedPackageConfigId :: PackageConfig -> UnitId -expandedPackageConfigId p = - newUnitId (componentId p) (instantiatedWith p) - -definitePackageConfigId :: PackageConfig -> Maybe DefUnitId -definitePackageConfigId p = - case packageConfigId p of - DefiniteUnitId def_uid -> Just def_uid - _ -> Nothing diff --git a/main/PackageConfig.hs-boot b/main/PackageConfig.hs-boot deleted file mode 100644 --- a/main/PackageConfig.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module PackageConfig where -import FastString -import {-# SOURCE #-} Module -import GHC.PackageDb -newtype PackageName = PackageName FastString -newtype SourcePackageId = SourcePackageId FastString -type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName UnitId ModuleName Module diff --git a/main/Packages.hs b/main/Packages.hs deleted file mode 100644 --- a/main/Packages.hs +++ /dev/null @@ -1,2044 +0,0 @@ --- (c) The University of Glasgow, 2006 - -{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} - --- | Package manipulation -module Packages ( - module PackageConfig, - - -- * Reading the package config, and processing cmdline args - PackageState(preloadPackages, explicitPackages, requirementContext), - PackageConfigMap, - emptyPackageState, - initPackages, - readPackageConfigs, - getPackageConfRefs, - resolvePackageConfig, - readPackageConfig, - listPackageConfigMap, - - -- * Querying the package config - lookupPackage, - lookupPackage', - lookupInstalledPackage, - lookupPackageName, - improveUnitId, - searchPackageId, - getPackageDetails, - getInstalledPackageDetails, - componentIdString, - displayInstalledUnitId, - listVisibleModuleNames, - lookupModuleInAllPackages, - lookupModuleWithSuggestions, - lookupPluginModuleWithSuggestions, - LookupResult(..), - ModuleSuggestion(..), - ModuleOrigin(..), - - -- * Inspecting the set of packages in scope - getPackageIncludePath, - getPackageLibraryPath, - getPackageLinkOpts, - getPackageExtraCcOpts, - getPackageFrameworkPath, - getPackageFrameworks, - getPackageConfigMap, - getPreloadPackagesAnd, - - collectIncludeDirs, collectLibraryPaths, collectLinkOpts, - packageHsLibs, - - -- * Utils - unwireUnitId, - pprFlag, - pprPackages, - pprPackagesSimple, - pprModuleMap, - isDllName - ) -where - -#include "HsVersions.h" - -import GHC.PackageDb -import PackageConfig -import DynFlags -import Name ( Name, nameModule_maybe ) -import UniqFM -import UniqDFM -import UniqSet -import Module -import Util -import Panic -import Outputable -import Maybes - -import System.Environment ( getEnv ) -import FastString -import ErrUtils ( debugTraceMsg, MsgDoc, printInfoForUser ) -import Exception - -import System.Directory -import System.FilePath as FilePath -import qualified System.FilePath.Posix as FilePath.Posix -import Control.Monad -import Data.Graph (stronglyConnComp, SCC(..)) -import Data.Char ( toUpper ) -import Data.List as List -import Data.Map (Map) -import Data.Set (Set) -import Data.Maybe (mapMaybe) -import Data.Monoid (First(..)) -#if __GLASGOW_HASKELL__ > 710 -import Data.Semigroup ( Semigroup ) -import qualified Data.Semigroup as Semigroup -#endif -import qualified Data.Map as Map -import qualified Data.Map.Strict as MapStrict -import qualified Data.Set as Set -import Data.Version - --- --------------------------------------------------------------------------- --- The Package state - --- | Package state is all stored in 'DynFlags', including the details of --- all packages, which packages are exposed, and which modules they --- provide. --- --- The package state is computed by 'initPackages', and kept in DynFlags. --- It is influenced by various package flags: --- --- * @-package @ and @-package-id @ cause @@ to become exposed. --- If @-hide-all-packages@ was not specified, these commands also cause --- all other packages with the same name to become hidden. --- --- * @-hide-package @ causes @@ to become hidden. --- --- * (there are a few more flags, check below for their semantics) --- --- The package state has the following properties. --- --- * Let @exposedPackages@ be the set of packages thus exposed. --- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of --- their dependencies. --- --- * When searching for a module from an preload import declaration, --- only the exposed modules in @exposedPackages@ are valid. --- --- * When searching for a module from an implicit import, all modules --- from @depExposedPackages@ are valid. --- --- * When linking in a compilation manager mode, we link in packages the --- program depends on (the compiler knows this list by the --- time it gets to the link step). Also, we link in all packages --- which were mentioned with preload @-package@ flags on the command-line, --- or are a transitive dependency of same, or are \"base\"\/\"rts\". --- The reason for this is that we might need packages which don't --- contain any Haskell modules, and therefore won't be discovered --- by the normal mechanism of dependency tracking. - --- Notes on DLLs --- ~~~~~~~~~~~~~ --- When compiling module A, which imports module B, we need to --- know whether B will be in the same DLL as A. --- If it's in the same DLL, we refer to B_f_closure --- If it isn't, we refer to _imp__B_f_closure --- When compiling A, we record in B's Module value whether it's --- in a different DLL, by setting the DLL flag. - --- | Given a module name, there may be multiple ways it came into scope, --- possibly simultaneously. This data type tracks all the possible ways --- it could have come into scope. Warning: don't use the record functions, --- they're partial! -data ModuleOrigin = - -- | Module is hidden, and thus never will be available for import. - -- (But maybe the user didn't realize), so we'll still keep track - -- of these modules.) - ModHidden - -- | Module is public, and could have come from some places. - | ModOrigin { - -- | @Just False@ means that this module is in - -- someone's @exported-modules@ list, but that package is hidden; - -- @Just True@ means that it is available; @Nothing@ means neither - -- applies. - fromOrigPackage :: Maybe Bool - -- | Is the module available from a reexport of an exposed package? - -- There could be multiple. - , fromExposedReexport :: [PackageConfig] - -- | Is the module available from a reexport of a hidden package? - , fromHiddenReexport :: [PackageConfig] - -- | Did the module export come from a package flag? (ToDo: track - -- more information. - , fromPackageFlag :: Bool - } - -instance Outputable ModuleOrigin where - ppr ModHidden = text "hidden module" - ppr (ModOrigin e res rhs f) = sep (punctuate comma ( - (case e of - Nothing -> [] - Just False -> [text "hidden package"] - Just True -> [text "exposed package"]) ++ - (if null res - then [] - else [text "reexport by" <+> - sep (map (ppr . packageConfigId) res)]) ++ - (if null rhs - then [] - else [text "hidden reexport by" <+> - sep (map (ppr . packageConfigId) res)]) ++ - (if f then [text "package flag"] else []) - )) - --- | Smart constructor for a module which is in @exposed-modules@. Takes --- as an argument whether or not the defining package is exposed. -fromExposedModules :: Bool -> ModuleOrigin -fromExposedModules e = ModOrigin (Just e) [] [] False - --- | Smart constructor for a module which is in @reexported-modules@. Takes --- as an argument whether or not the reexporting package is expsed, and --- also its 'PackageConfig'. -fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin -fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False -fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False - --- | Smart constructor for a module which was bound by a package flag. -fromFlag :: ModuleOrigin -fromFlag = ModOrigin Nothing [] [] True - -#if __GLASGOW_HASKELL__ > 710 -instance Semigroup ModuleOrigin where - ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' = - ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') - where g (Just b) (Just b') - | b == b' = Just b - | otherwise = panic "ModOrigin: package both exposed/hidden" - g Nothing x = x - g x Nothing = x - _x <> _y = panic "ModOrigin: hidden module redefined" -#endif - -instance Monoid ModuleOrigin where - mempty = ModOrigin Nothing [] [] False - mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') = - ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') - where g (Just b) (Just b') - | b == b' = Just b - | otherwise = panic "ModOrigin: package both exposed/hidden" - g Nothing x = x - g x Nothing = x - mappend _ _ = panic "ModOrigin: hidden module redefined" - --- | Is the name from the import actually visible? (i.e. does it cause --- ambiguity, or is it only relevant when we're making suggestions?) -originVisible :: ModuleOrigin -> Bool -originVisible ModHidden = False -originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f - --- | Are there actually no providers for this module? This will never occur --- except when we're filtering based on package imports. -originEmpty :: ModuleOrigin -> Bool -originEmpty (ModOrigin Nothing [] [] False) = True -originEmpty _ = False - --- | 'UniqFM' map from 'InstalledUnitId' -type InstalledUnitIdMap = UniqDFM - --- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus --- the transitive closure of preload packages. -data PackageConfigMap = PackageConfigMap { - unPackageConfigMap :: InstalledUnitIdMap PackageConfig, - -- | The set of transitively reachable packages according - -- to the explicitly provided command line arguments. - -- See Note [UnitId to InstalledUnitId improvement] - preloadClosure :: UniqSet InstalledUnitId - } - --- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'. -type VisibilityMap = Map UnitId UnitVisibility - --- | 'UnitVisibility' records the various aspects of visibility of a particular --- 'UnitId'. -data UnitVisibility = UnitVisibility - { uv_expose_all :: Bool - -- ^ Should all modules in exposed-modules should be dumped into scope? - , uv_renamings :: [(ModuleName, ModuleName)] - -- ^ Any custom renamings that should bring extra 'ModuleName's into - -- scope. - , uv_package_name :: First FastString - -- ^ The package name is associated with the 'UnitId'. This is used - -- to implement legacy behavior where @-package foo-0.1@ implicitly - -- hides any packages named @foo@ - , uv_requirements :: Map ModuleName (Set IndefModule) - -- ^ The signatures which are contributed to the requirements context - -- from this unit ID. - , uv_explicit :: Bool - -- ^ Whether or not this unit was explicitly brought into scope, - -- as opposed to implicitly via the 'exposed' fields in the - -- package database (when @-hide-all-packages@ is not passed.) - } - -instance Outputable UnitVisibility where - ppr (UnitVisibility { - uv_expose_all = b, - uv_renamings = rns, - uv_package_name = First mb_pn, - uv_requirements = reqs, - uv_explicit = explicit - }) = ppr (b, rns, mb_pn, reqs, explicit) -instance Monoid UnitVisibility where - mempty = UnitVisibility - { uv_expose_all = False - , uv_renamings = [] - , uv_package_name = First Nothing - , uv_requirements = Map.empty - , uv_explicit = False - } - mappend uv1 uv2 - = UnitVisibility - { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 - , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 - , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) - , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) - , uv_explicit = uv_explicit uv1 || uv_explicit uv2 - } - -type WiredUnitId = DefUnitId -type PreloadUnitId = InstalledUnitId - --- | Map from 'ModuleName' to 'Module' to all the origins of the bindings --- in scope. The 'PackageConf' is not cached, mostly for convenience reasons --- (since this is the slow path, we'll just look it up again). -type ModuleToPkgConfAll = - Map ModuleName (Map Module ModuleOrigin) - -data PackageState = PackageState { - -- | A mapping of 'UnitId' to 'PackageConfig'. This list is adjusted - -- so that only valid packages are here. 'PackageConfig' reflects - -- what was stored *on disk*, except for the 'trusted' flag, which - -- is adjusted at runtime. (In particular, some packages in this map - -- may have the 'exposed' flag be 'False'.) - pkgIdMap :: PackageConfigMap, - - -- | A mapping of 'PackageName' to 'ComponentId'. This is used when - -- users refer to packages in Backpack includes. - packageNameMap :: Map PackageName ComponentId, - - -- | A mapping from wired in names to the original names from the - -- package database. - unwireMap :: Map WiredUnitId WiredUnitId, - - -- | The packages we're going to link in eagerly. This list - -- should be in reverse dependency order; that is, a package - -- is always mentioned before the packages it depends on. - preloadPackages :: [PreloadUnitId], - - -- | Packages which we explicitly depend on (from a command line flag). - -- We'll use this to generate version macros. - explicitPackages :: [UnitId], - - -- | This is a full map from 'ModuleName' to all modules which may possibly - -- be providing it. These providers may be hidden (but we'll still want - -- to report them in error messages), or it may be an ambiguous import. - moduleToPkgConfAll :: !ModuleToPkgConfAll, - - -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility. - pluginModuleToPkgConfAll :: !ModuleToPkgConfAll, - - -- | A map saying, for each requirement, what interfaces must be merged - -- together when we use them. For example, if our dependencies - -- are @p[A=]@ and @q[A=,B=r[C=]:B]@, then the interfaces - -- to merge for A are @p[A=]:A@, @q[A=,B=r[C=]:B]:A@ - -- and @r[C=]:C@. - -- - -- There's an entry in this map for each hole in our home library. - requirementContext :: Map ModuleName [IndefModule] - } - -emptyPackageState :: PackageState -emptyPackageState = PackageState { - pkgIdMap = emptyPackageConfigMap, - packageNameMap = Map.empty, - unwireMap = Map.empty, - preloadPackages = [], - explicitPackages = [], - moduleToPkgConfAll = Map.empty, - pluginModuleToPkgConfAll = Map.empty, - requirementContext = Map.empty - } - -type InstalledPackageIndex = Map InstalledUnitId PackageConfig - --- | Empty package configuration map -emptyPackageConfigMap :: PackageConfigMap -emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet - --- | Find the package we know about with the given unit id, if any -lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig -lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags)) - --- | A more specialized interface, which takes a boolean specifying --- whether or not to look for on-the-fly renamed interfaces, and --- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can --- be used while we're initializing 'DynFlags' -lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig -lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid -lookupPackage' True m@(PackageConfigMap pkg_map _) uid = - case splitUnitIdInsts uid of - (iuid, Just indef) -> - fmap (renamePackage m (indefUnitIdInsts indef)) - (lookupUDFM pkg_map iuid) - (_, Nothing) -> lookupUDFM pkg_map uid - -{- --- | Find the indefinite package for a given 'ComponentId'. --- The way this works is just by fiat'ing that every indefinite package's --- unit key is precisely its component ID; and that they share uniques. -lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig -lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs - where - PackageConfigMap pkg_map = pkgIdMap (pkgState dflags) --} - --- | Find the package we know about with the given package name (e.g. @foo@), if any --- (NB: there might be a locally defined unit name which overrides this) -lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId -lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags)) - --- | Search for packages with a given package ID (e.g. \"foo-0.1\") -searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig] -searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) - (listPackageConfigMap dflags) - --- | Extends the package configuration map with a list of package configs. -extendPackageConfigMap - :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap -extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs - = PackageConfigMap (foldl add pkg_map new_pkgs) closure - -- We also add the expanded version of the packageConfigId, so that - -- 'improveUnitId' can find it. - where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p) - (installedPackageConfigId p) p - --- | Looks up the package with the given id in the package state, panicing if it is --- not found -getPackageDetails :: DynFlags -> UnitId -> PackageConfig -getPackageDetails dflags pid = - expectJust "getPackageDetails" (lookupPackage dflags pid) - -lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig -lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid - -lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig -lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid - -getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig -getInstalledPackageDetails dflags uid = - expectJust "getInstalledPackageDetails" $ - lookupInstalledPackage dflags uid - --- | Get a list of entries from the package database. NB: be careful with --- this function, although all packages in this map are "visible", this --- does not imply that the exposed-modules of the package are available --- (they may have been thinned or renamed). -listPackageConfigMap :: DynFlags -> [PackageConfig] -listPackageConfigMap dflags = eltsUDFM pkg_map - where - PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags) - --- ---------------------------------------------------------------------------- --- Loading the package db files and building up the package state - --- | Call this after 'DynFlags.parseDynFlags'. It reads the package --- database files, and sets up various internal tables of package --- information, according to the package-related flags on the --- command-line (@-package@, @-hide-package@ etc.) --- --- Returns a list of packages to link in if we're doing dynamic linking. --- This list contains the packages that the user explicitly mentioned with --- @-package@ flags. --- --- 'initPackages' can be called again subsequently after updating the --- 'packageFlags' field of the 'DynFlags', and it will update the --- 'pkgState' in 'DynFlags' and return a list of packages to --- link in. -initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId]) -initPackages dflags0 = do - dflags <- interpretPackageEnv dflags0 - pkg_db <- - case pkgDatabase dflags of - Nothing -> readPackageConfigs dflags - Just db -> return $ map (\(p, pkgs) - -> (p, setBatchPackageFlags dflags pkgs)) db - (pkg_state, preload, insts) - <- mkPackageState dflags pkg_db [] - return (dflags{ pkgDatabase = Just pkg_db, - pkgState = pkg_state, - thisUnitIdInsts_ = insts }, - preload) - --- ----------------------------------------------------------------------------- --- Reading the package database(s) - -readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])] -readPackageConfigs dflags = do - conf_refs <- getPackageConfRefs dflags - confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs - mapM (readPackageConfig dflags) confs - - -getPackageConfRefs :: DynFlags -> IO [PkgConfRef] -getPackageConfRefs dflags = do - let system_conf_refs = [UserPkgConf, GlobalPkgConf] - - e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH") - let base_conf_refs = case e_pkg_path of - Left _ -> system_conf_refs - Right path - | not (null path) && isSearchPathSeparator (last path) - -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs - | otherwise - -> map PkgConfFile (splitSearchPath path) - - -- Apply the package DB-related flags from the command line to get the - -- final list of package DBs. - -- - -- Notes on ordering: - -- * The list of flags is reversed (later ones first) - -- * We work with the package DB list in "left shadows right" order - -- * and finally reverse it at the end, to get "right shadows left" - -- - return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags)) - where - doFlag (PackageDB p) dbs = p : dbs - doFlag NoUserPackageDB dbs = filter isNotUser dbs - doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs - doFlag ClearPackageDBs _ = [] - - isNotUser UserPkgConf = False - isNotUser _ = True - - isNotGlobal GlobalPkgConf = False - isNotGlobal _ = True - -resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath) -resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags) --- NB: This logic is reimplemented in Cabal, so if you change it, --- make sure you update Cabal. (Or, better yet, dump it in the --- compiler info so Cabal can use the info.) -resolvePackageConfig dflags UserPkgConf = runMaybeT $ do - dir <- versionedAppDir dflags - let pkgconf = dir "package.conf.d" - exist <- tryMaybeT $ doesDirectoryExist pkgconf - if exist then return pkgconf else mzero -resolvePackageConfig _ (PkgConfFile name) = return $ Just name - -readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig]) -readPackageConfig dflags conf_file = do - isdir <- doesDirectoryExist conf_file - - proto_pkg_configs <- - if isdir - then readDirStylePackageConfig conf_file - else do - isfile <- doesFileExist conf_file - if isfile - then do - mpkgs <- tryReadOldFileStylePackageConfig - case mpkgs of - Just pkgs -> return pkgs - Nothing -> throwGhcExceptionIO $ InstallationError $ - "ghc no longer supports single-file style package " ++ - "databases (" ++ conf_file ++ - ") use 'ghc-pkg init' to create the database with " ++ - "the correct format." - else throwGhcExceptionIO $ InstallationError $ - "can't find a package database at " ++ conf_file - - let - top_dir = topDir dflags - pkgroot = takeDirectory conf_file - pkg_configs1 = map (mungePackageConfig top_dir pkgroot) - proto_pkg_configs - pkg_configs2 = setBatchPackageFlags dflags pkg_configs1 - -- - return (conf_file, pkg_configs2) - where - readDirStylePackageConfig conf_dir = do - let filename = conf_dir "package.cache" - cache_exists <- doesFileExist filename - if cache_exists - then do - debugTraceMsg dflags 2 $ text "Using binary package database:" - <+> text filename - readPackageDbForGhc filename - else do - -- If there is no package.cache file, we check if the database is not - -- empty by inspecting if the directory contains any .conf file. If it - -- does, something is wrong and we fail. Otherwise we assume that the - -- database is empty. - debugTraceMsg dflags 2 $ text "There is no package.cache in" - <+> text conf_dir - <> text ", checking if the database is empty" - db_empty <- all (not . isSuffixOf ".conf") - <$> getDirectoryContents conf_dir - if db_empty - then do - debugTraceMsg dflags 3 $ text "There are no .conf files in" - <+> text conf_dir <> text ", treating" - <+> text "package database as empty" - return [] - else do - throwGhcExceptionIO $ InstallationError $ - "there is no package.cache in " ++ conf_dir ++ - " even though package database is not empty" - - - -- Single-file style package dbs have been deprecated for some time, but - -- it turns out that Cabal was using them in one place. So this is a - -- workaround to allow older Cabal versions to use this newer ghc. - -- We check if the file db contains just "[]" and if so, we look for a new - -- dir-style db in conf_file.d/, ie in a dir next to the given file. - -- We cannot just replace the file with a new dir style since Cabal still - -- assumes it's a file and tries to overwrite with 'writeFile'. - -- ghc-pkg also cooperates with this workaround. - tryReadOldFileStylePackageConfig = do - content <- readFile conf_file `catchIO` \_ -> return "" - if take 2 content == "[]" - then do - let conf_dir = conf_file <.> "d" - direxists <- doesDirectoryExist conf_dir - if direxists - then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) - liftM Just (readDirStylePackageConfig conf_dir) - else return (Just []) -- ghc-pkg will create it when it's updated - else return Nothing - -setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] -setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs - where - maybeDistrustAll pkgs' - | gopt Opt_DistrustAllPackages dflags = map distrust pkgs' - | otherwise = pkgs' - - distrust pkg = pkg{ trusted = False } - -mungePackageConfig :: FilePath -> FilePath - -> PackageConfig -> PackageConfig -mungePackageConfig top_dir pkgroot = - mungeDynLibFields - . mungePackagePaths top_dir pkgroot - -mungeDynLibFields :: PackageConfig -> PackageConfig -mungeDynLibFields pkg = - pkg { - libraryDynDirs = libraryDynDirs pkg - `orIfNull` libraryDirs pkg - } - where - orIfNull [] flags = flags - orIfNull flags _ = flags - --- TODO: This code is duplicated in utils/ghc-pkg/Main.hs -mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig --- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec --- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) --- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. --- The "pkgroot" is the directory containing the package database. --- --- Also perform a similar substitution for the older GHC-specific --- "$topdir" variable. The "topdir" is the location of the ghc --- installation (obtained from the -B option). -mungePackagePaths top_dir pkgroot pkg = - pkg { - importDirs = munge_paths (importDirs pkg), - includeDirs = munge_paths (includeDirs pkg), - libraryDirs = munge_paths (libraryDirs pkg), - libraryDynDirs = munge_paths (libraryDynDirs pkg), - frameworkDirs = munge_paths (frameworkDirs pkg), - haddockInterfaces = munge_paths (haddockInterfaces pkg), - haddockHTMLs = munge_urls (haddockHTMLs pkg) - } - where - munge_paths = map munge_path - munge_urls = map munge_url - - munge_path p - | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' - | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' - | otherwise = p - - munge_url p - | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' - | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' - | otherwise = p - - toUrlPath r p = "file:///" - -- URLs always use posix style '/' separators: - ++ FilePath.Posix.joinPath - (r : -- We need to drop a leading "/" or "\\" - -- if there is one: - dropWhile (all isPathSeparator) - (FilePath.splitDirectories p)) - - -- We could drop the separator here, and then use above. However, - -- by leaving it in and using ++ we keep the same path separator - -- rather than letting FilePath change it to use \ as the separator - stripVarPrefix var path = case stripPrefix var path of - Just [] -> Just [] - Just cs@(c : _) | isPathSeparator c -> Just cs - _ -> Nothing - - --- ----------------------------------------------------------------------------- --- Modify our copy of the package database based on trust flags, --- -trust and -distrust. - -applyTrustFlag - :: DynFlags - -> PackagePrecedenceIndex - -> UnusablePackages - -> [PackageConfig] - -> TrustFlag - -> IO [PackageConfig] -applyTrustFlag dflags prec_map unusable pkgs flag = - case flag of - -- we trust all matching packages. Maybe should only trust first one? - -- and leave others the same or set them untrusted - TrustPackage str -> - case selectPackages prec_map (PackageArg str) pkgs unusable of - Left ps -> trustFlagErr dflags flag ps - Right (ps,qs) -> return (map trust ps ++ qs) - where trust p = p {trusted=True} - - DistrustPackage str -> - case selectPackages prec_map (PackageArg str) pkgs unusable of - Left ps -> trustFlagErr dflags flag ps - Right (ps,qs) -> return (map distrust ps ++ qs) - where distrust p = p {trusted=False} - --- | A little utility to tell if the 'thisPackage' is indefinite --- (if it is not, we should never use on-the-fly renaming.) -isIndefinite :: DynFlags -> Bool -isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags)) - -applyPackageFlag - :: DynFlags - -> PackagePrecedenceIndex - -> PackageConfigMap - -> UnusablePackages - -> Bool -- if False, if you expose a package, it implicitly hides - -- any previously exposed packages with the same name - -> [PackageConfig] - -> VisibilityMap -- Initially exposed - -> PackageFlag -- flag to apply - -> IO VisibilityMap -- Now exposed - -applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag = - case flag of - ExposePackage _ arg (ModRenaming b rns) -> - case findPackages prec_map pkg_db arg pkgs unusable of - Left ps -> packageFlagErr dflags flag ps - Right (p:_) -> return vm' - where - n = fsPackageName p - - -- If a user says @-unit-id p[A=]@, this imposes - -- a requirement on us: whatever our signature A is, - -- it must fulfill all of p[A=]:A's requirements. - -- This method is responsible for computing what our - -- inherited requirements are. - reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid - | otherwise = Map.empty - - collectHoles uid = case splitUnitIdInsts uid of - (_, Just indef) -> - let local = [ Map.singleton - (moduleName mod) - (Set.singleton $ IndefModule indef mod_name) - | (mod_name, mod) <- indefUnitIdInsts indef - , isHoleModule mod ] - recurse = [ collectHoles (moduleUnitId mod) - | (_, mod) <- indefUnitIdInsts indef ] - in Map.unionsWith Set.union $ local ++ recurse - -- Other types of unit identities don't have holes - (_, Nothing) -> Map.empty - - - uv = UnitVisibility - { uv_expose_all = b - , uv_renamings = rns - , uv_package_name = First (Just n) - , uv_requirements = reqs - , uv_explicit = True - } - vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared - -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` - -- (or if p-0.1 was registered in the pkgdb as exposed: True), - -- the second package flag would override the first one and you - -- would only see p-0.2 in exposed modules. This is good for - -- usability. - -- - -- However, with thinning and renaming (or Backpack), there might be - -- situations where you legitimately want to see two versions of a - -- package at the same time, and this behavior would make it - -- impossible to do so. So we decided that if you pass - -- -hide-all-packages, this should turn OFF the overriding behavior - -- where an exposed package hides all other packages with the same - -- name. This should not affect Cabal at all, which only ever - -- exposes one package at a time. - -- - -- NB: Why a variable no_hide_others? We have to apply this logic to - -- -plugin-package too, and it's more consistent if the switch in - -- behavior is based off of - -- -hide-all-packages/-hide-all-plugin-packages depending on what - -- flag is in question. - vm_cleared | no_hide_others = vm - -- NB: renamings never clear - | (_:_) <- rns = vm - | otherwise = Map.filterWithKey - (\k uv -> k == packageConfigId p - || First (Just n) /= uv_package_name uv) vm - _ -> panic "applyPackageFlag" - - HidePackage str -> - case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of - Left ps -> packageFlagErr dflags flag ps - Right ps -> return vm' - where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps) - --- | Like 'selectPackages', but doesn't return a list of unmatched --- packages. Furthermore, any packages it returns are *renamed* --- if the 'UnitArg' has a renaming associated with it. -findPackages :: PackagePrecedenceIndex - -> PackageConfigMap -> PackageArg -> [PackageConfig] - -> UnusablePackages - -> Either [(PackageConfig, UnusablePackageReason)] - [PackageConfig] -findPackages prec_map pkg_db arg pkgs unusable - = let ps = mapMaybe (finder arg) pkgs - in if null ps - then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) - (Map.elems unusable)) - else Right (sortByPreference prec_map ps) - where - finder (PackageArg str) p - = if str == sourcePackageIdString p || str == packageNameString p - then Just p - else Nothing - finder (UnitIdArg uid) p - = let (iuid, mb_indef) = splitUnitIdInsts uid - in if iuid == installedPackageConfigId p - then Just (case mb_indef of - Nothing -> p - Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p) - else Nothing - -selectPackages :: PackagePrecedenceIndex -> PackageArg -> [PackageConfig] - -> UnusablePackages - -> Either [(PackageConfig, UnusablePackageReason)] - ([PackageConfig], [PackageConfig]) -selectPackages prec_map arg pkgs unusable - = let matches = matching arg - (ps,rest) = partition matches pkgs - in if null ps - then Left (filter (matches.fst) (Map.elems unusable)) - else Right (sortByPreference prec_map ps, rest) - --- | Rename a 'PackageConfig' according to some module instantiation. -renamePackage :: PackageConfigMap -> [(ModuleName, Module)] - -> PackageConfig -> PackageConfig -renamePackage pkg_map insts conf = - let hsubst = listToUFM insts - smod = renameHoleModule' pkg_map hsubst - new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf) - in conf { - instantiatedWith = new_insts, - exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) - (exposedModules conf) - } - - --- A package named on the command line can either include the --- version, or just the name if it is unambiguous. -matchingStr :: String -> PackageConfig -> Bool -matchingStr str p - = str == sourcePackageIdString p - || str == packageNameString p - -matchingId :: InstalledUnitId -> PackageConfig -> Bool -matchingId uid p = uid == installedPackageConfigId p - -matching :: PackageArg -> PackageConfig -> Bool -matching (PackageArg str) = matchingStr str -matching (UnitIdArg (DefiniteUnitId (DefUnitId uid))) = matchingId uid -matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case - --- | This sorts a list of packages, putting "preferred" packages first. --- See 'compareByPreference' for the semantics of "preference". -sortByPreference :: PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig] -sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) - --- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking --- which should be "active". Here is the order of preference: --- --- 1. First, prefer the latest version --- 2. If the versions are the same, prefer the package that --- came in the latest package database. --- --- Pursuant to #12518, we could change this policy to, for example, remove --- the version preference, meaning that we would always prefer the packages --- in alter package database. --- -compareByPreference - :: PackagePrecedenceIndex - -> PackageConfig - -> PackageConfig - -> Ordering -compareByPreference prec_map pkg pkg' = - case comparing packageVersion pkg pkg' of - GT -> GT - EQ | Just prec <- Map.lookup (unitId pkg) prec_map - , Just prec' <- Map.lookup (unitId pkg') prec_map - -- Prefer the package from the later DB flag (i.e., higher - -- precedence) - -> compare prec prec' - | otherwise - -> EQ - LT -> LT - -comparing :: Ord a => (t -> a) -> t -> t -> Ordering -comparing f a b = f a `compare` f b - -packageFlagErr :: DynFlags - -> PackageFlag - -> [(PackageConfig, UnusablePackageReason)] - -> IO a - --- for missing DPH package we emit a more helpful error message, because --- this may be the result of using -fdph-par or -fdph-seq. -packageFlagErr dflags (ExposePackage _ (PackageArg pkg) _) [] - | is_dph_package pkg - = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err)) - where dph_err = text "the " <> text pkg <> text " package is not installed." - $$ text "To install it: \"cabal install dph\"." - is_dph_package pkg = "dph" `isPrefixOf` pkg -packageFlagErr dflags flag reasons - = packageFlagErr' dflags (pprFlag flag) reasons - -trustFlagErr :: DynFlags - -> TrustFlag - -> [(PackageConfig, UnusablePackageReason)] - -> IO a -trustFlagErr dflags flag reasons - = packageFlagErr' dflags (pprTrustFlag flag) reasons - -packageFlagErr' :: DynFlags - -> SDoc - -> [(PackageConfig, UnusablePackageReason)] - -> IO a -packageFlagErr' dflags flag_doc reasons - = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err)) - where err = text "cannot satisfy " <> flag_doc <> - (if null reasons then Outputable.empty else text ": ") $$ - nest 4 (ppr_reasons $$ - text "(use -v for more information)") - ppr_reasons = vcat (map ppr_reason reasons) - ppr_reason (p, reason) = - pprReason (ppr (unitId p) <+> text "is") reason - -pprFlag :: PackageFlag -> SDoc -pprFlag flag = case flag of - HidePackage p -> text "-hide-package " <> text p - ExposePackage doc _ _ -> text doc - -pprTrustFlag :: TrustFlag -> SDoc -pprTrustFlag flag = case flag of - TrustPackage p -> text "-trust " <> text p - DistrustPackage p -> text "-distrust " <> text p - --- ----------------------------------------------------------------------------- --- Wired-in packages - -wired_in_pkgids :: [String] -wired_in_pkgids = map unitIdString wiredInUnitIds - -type WiredPackagesMap = Map WiredUnitId WiredUnitId - -findWiredInPackages - :: DynFlags - -> PackagePrecedenceIndex - -> [PackageConfig] -- database - -> VisibilityMap -- info on what packages are visible - -- for wired in selection - -> IO ([PackageConfig], -- package database updated for wired in - WiredPackagesMap) -- map from unit id to wired identity - -findWiredInPackages dflags prec_map pkgs vis_map = do - -- - -- Now we must find our wired-in packages, and rename them to - -- their canonical names (eg. base-1.0 ==> base). - -- - let - matches :: PackageConfig -> String -> Bool - pc `matches` pid = packageNameString pc == pid - - -- find which package corresponds to each wired-in package - -- delete any other packages with the same name - -- update the package and any dependencies to point to the new - -- one. - -- - -- When choosing which package to map to a wired-in package - -- name, we try to pick the latest version of exposed packages. - -- However, if there are no exposed wired in packages available - -- (e.g. -hide-all-packages was used), we can't bail: we *have* - -- to assign a package for the wired-in package: so we try again - -- with hidden packages included to (and pick the latest - -- version). - -- - -- You can also override the default choice by using -ignore-package: - -- this works even when there is no exposed wired in package - -- available. - -- - findWiredInPackage :: [PackageConfig] -> String - -> IO (Maybe PackageConfig) - findWiredInPackage pkgs wired_pkg = - let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] - all_exposed_ps = - [ p | p <- all_ps - , Map.member (packageConfigId p) vis_map ] in - case all_exposed_ps of - [] -> case all_ps of - [] -> notfound - many -> pick (head (sortByPreference prec_map many)) - many -> pick (head (sortByPreference prec_map many)) - where - notfound = do - debugTraceMsg dflags 2 $ - text "wired-in package " - <> text wired_pkg - <> text " not found." - return Nothing - pick :: PackageConfig - -> IO (Maybe PackageConfig) - pick pkg = do - debugTraceMsg dflags 2 $ - text "wired-in package " - <> text wired_pkg - <> text " mapped to " - <> ppr (unitId pkg) - return (Just pkg) - - - mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids - let - wired_in_pkgs = catMaybes mb_wired_in_pkgs - wired_in_ids = mapMaybe definitePackageConfigId wired_in_pkgs - - -- this is old: we used to assume that if there were - -- multiple versions of wired-in packages installed that - -- they were mutually exclusive. Now we're assuming that - -- you have one "main" version of each wired-in package - -- (the latest version), and the others are backward-compat - -- wrappers that depend on this one. e.g. base-4.0 is the - -- latest, base-3.0 is a compat wrapper depending on base-4.0. - {- - deleteOtherWiredInPackages pkgs = filterOut bad pkgs - where bad p = any (p `matches`) wired_in_pkgids - && package p `notElem` map fst wired_in_ids - -} - - wiredInMap :: Map WiredUnitId WiredUnitId - wiredInMap = foldl' add_mapping Map.empty pkgs - where add_mapping m pkg - | Just key <- definitePackageConfigId pkg - , key `elem` wired_in_ids - = Map.insert key (DefUnitId (stringToInstalledUnitId (packageNameString pkg))) m - | otherwise = m - - updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs - where upd_pkg pkg - | Just def_uid <- definitePackageConfigId pkg - , def_uid `elem` wired_in_ids - = let PackageName fs = packageName pkg - in pkg { - unitId = fsToInstalledUnitId fs, - componentId = ComponentId fs - } - | otherwise - = pkg - upd_deps pkg = pkg { - -- temporary harmless DefUnitId invariant violation - depends = map (unDefUnitId . upd_wired_in wiredInMap . DefUnitId) (depends pkg), - exposedModules - = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) - (exposedModules pkg) - } - - - return (updateWiredInDependencies pkgs, wiredInMap) - --- Helper functions for rewiring Module and UnitId. These --- rewrite UnitIds of modules in wired-in packages to the form known to the --- compiler. For instance, base-4.9.0.0 will be rewritten to just base, to match --- what appears in PrelNames. - -upd_wired_in_mod :: WiredPackagesMap -> Module -> Module -upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m - -upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId -upd_wired_in_uid wiredInMap (DefiniteUnitId def_uid) = - DefiniteUnitId (upd_wired_in wiredInMap def_uid) -upd_wired_in_uid wiredInMap (IndefiniteUnitId indef_uid) = - IndefiniteUnitId $ newIndefUnitId - (indefUnitIdComponentId indef_uid) - (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (indefUnitIdInsts indef_uid)) - -upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId -upd_wired_in wiredInMap key - | Just key' <- Map.lookup key wiredInMap = key' - | otherwise = key - -updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap -updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) - where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of - Nothing -> vm - Just r -> Map.insert (DefiniteUnitId to) r - (Map.delete (DefiniteUnitId from) vm) - - --- ---------------------------------------------------------------------------- - --- | The reason why a package is unusable. -data UnusablePackageReason - = -- | We ignored it explicitly using @-ignore-package@. - IgnoredWithFlag - -- | This package transitively depends on a package that was never present - -- in any of the provided databases. - | BrokenDependencies [InstalledUnitId] - -- | This package transitively depends on a package involved in a cycle. - -- Note that the list of 'InstalledUnitId' reports the direct dependencies - -- of this package that (transitively) depended on the cycle, and not - -- the actual cycle itself (which we report separately at high verbosity.) - | CyclicDependencies [InstalledUnitId] - -- | This package transitively depends on a package which was ignored. - | IgnoredDependencies [InstalledUnitId] - -- | This package transitively depends on a package which was - -- shadowed by an ABI-incompatible package. - | ShadowedDependencies [InstalledUnitId] - -instance Outputable UnusablePackageReason where - ppr IgnoredWithFlag = text "[ignored with flag]" - ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) - ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) - ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) - ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) - -type UnusablePackages = Map InstalledUnitId - (PackageConfig, UnusablePackageReason) - -pprReason :: SDoc -> UnusablePackageReason -> SDoc -pprReason pref reason = case reason of - IgnoredWithFlag -> - pref <+> text "ignored due to an -ignore-package flag" - BrokenDependencies deps -> - pref <+> text "unusable due to missing dependencies:" $$ - nest 2 (hsep (map ppr deps)) - CyclicDependencies deps -> - pref <+> text "unusable due to cyclic dependencies:" $$ - nest 2 (hsep (map ppr deps)) - IgnoredDependencies deps -> - pref <+> text "unusable due to ignored dependencies:" $$ - nest 2 (hsep (map ppr deps)) - ShadowedDependencies deps -> - pref <+> text "unusable due to shadowed dependencies:" $$ - nest 2 (hsep (map ppr deps)) - -reportCycles :: DynFlags -> [SCC PackageConfig] -> IO () -reportCycles dflags sccs = mapM_ report sccs - where - report (AcyclicSCC _) = return () - report (CyclicSCC vs) = - debugTraceMsg dflags 2 $ - text "these packages are involved in a cycle:" $$ - nest 2 (hsep (map (ppr . unitId) vs)) - -reportUnusable :: DynFlags -> UnusablePackages -> IO () -reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) - where - report (ipid, (_, reason)) = - debugTraceMsg dflags 2 $ - pprReason - (text "package" <+> ppr ipid <+> text "is") reason - --- ---------------------------------------------------------------------------- --- --- Utilities on the database --- - --- | A reverse dependency index, mapping an 'InstalledUnitId' to --- the 'InstalledUnitId's which have a dependency on it. -type RevIndex = Map InstalledUnitId [InstalledUnitId] - --- | Compute the reverse dependency index of a package database. -reverseDeps :: InstalledPackageIndex -> RevIndex -reverseDeps db = Map.foldl' go Map.empty db - where - go r pkg = foldl' (go' (unitId pkg)) r (depends pkg) - go' from r to = Map.insertWith (++) to [from] r - --- | Given a list of 'InstalledUnitId's to remove, a database, --- and a reverse dependency index (as computed by 'reverseDeps'), --- remove those packages, plus any packages which depend on them. --- Returns the pruned database, as well as a list of 'PackageConfig's --- that was removed. -removePackages :: [InstalledUnitId] -> RevIndex - -> InstalledPackageIndex - -> (InstalledPackageIndex, [PackageConfig]) -removePackages uids index m = go uids (m,[]) - where - go [] (m,pkgs) = (m,pkgs) - go (uid:uids) (m,pkgs) - | Just pkg <- Map.lookup uid m - = case Map.lookup uid index of - Nothing -> go uids (Map.delete uid m, pkg:pkgs) - Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs) - | otherwise - = go uids (m,pkgs) - --- | Given a 'PackageConfig' from some 'InstalledPackageIndex', --- return all entries in 'depends' which correspond to packages --- that do not exist in the index. -depsNotAvailable :: InstalledPackageIndex - -> PackageConfig - -> [InstalledUnitId] -depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (depends pkg) - --- | Given a 'PackageConfig' from some 'InstalledPackageIndex' --- return all entries in 'abiDepends' which correspond to packages --- that do not exist, OR have mismatching ABIs. -depsAbiMismatch :: InstalledPackageIndex - -> PackageConfig - -> [InstalledUnitId] -depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ abiDepends pkg - where - abiMatch (dep_uid, abi) - | Just dep_pkg <- Map.lookup dep_uid pkg_map - = abiHash dep_pkg == abi - | otherwise - = False - --- ----------------------------------------------------------------------------- --- Ignore packages - -ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages -ignorePackages flags pkgs = Map.fromList (concatMap doit flags) - where - doit (IgnorePackage str) = - case partition (matchingStr str) pkgs of - (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) - | p <- ps ] - -- missing package is not an error for -ignore-package, - -- because a common usage is to -ignore-package P as - -- a preventative measure just in case P exists. - --- ---------------------------------------------------------------------------- --- --- Merging databases --- - --- | For each package, a mapping from uid -> i indicates that this --- package was brought into GHC by the ith @-package-db@ flag on --- the command line. We use this mapping to make sure we prefer --- packages that were defined later on the command line, if there --- is an ambiguity. -type PackagePrecedenceIndex = Map InstalledUnitId Int - --- | Given a list of databases, merge them together, where --- packages with the same unit id in later databases override --- earlier ones. This does NOT check if the resulting database --- makes sense (that's done by 'validateDatabase'). -mergeDatabases :: DynFlags -> [(FilePath, [PackageConfig])] - -> IO (InstalledPackageIndex, PackagePrecedenceIndex) -mergeDatabases dflags = foldM merge (Map.empty, Map.empty) . zip [1..] - where - merge (pkg_map, prec_map) (i, (db_path, db)) = do - debugTraceMsg dflags 2 $ - text "loading package database" <+> text db_path - forM_ (Set.toList override_set) $ \pkg -> - debugTraceMsg dflags 2 $ - text "package" <+> ppr pkg <+> - text "overrides a previously defined package" - return (pkg_map', prec_map') - where - db_map = mk_pkg_map db - mk_pkg_map = Map.fromList . map (\p -> (unitId p, p)) - - -- The set of UnitIds which appear in both db and pkgs. These are the - -- ones that get overridden. Compute this just to give some - -- helpful debug messages at -v2 - override_set :: Set InstalledUnitId - override_set = Set.intersection (Map.keysSet db_map) - (Map.keysSet pkg_map) - - -- Now merge the sets together (NB: in case of duplicate, - -- first argument preferred) - pkg_map' :: InstalledPackageIndex - pkg_map' = Map.union db_map pkg_map - - prec_map' :: PackagePrecedenceIndex - prec_map' = Map.union (Map.map (const i) db_map) prec_map - --- | Validates a database, removing unusable packages from it --- (this includes removing packages that the user has explicitly --- ignored.) Our general strategy: --- --- 1. Remove all broken packages (dangling dependencies) --- 2. Remove all packages that are cyclic --- 3. Apply ignore flags --- 4. Remove all packages which have deps with mismatching ABIs --- -validateDatabase :: DynFlags -> InstalledPackageIndex - -> (InstalledPackageIndex, UnusablePackages, [SCC PackageConfig]) -validateDatabase dflags pkg_map1 = - (pkg_map5, unusable, sccs) - where - ignore_flags = reverse (ignorePackageFlags dflags) - - -- Compute the reverse dependency index - index = reverseDeps pkg_map1 - - -- Helper function - mk_unusable mk_err dep_matcher m uids = - Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) - | pkg <- uids ] - - -- Find broken packages - directly_broken = filter (not . null . depsNotAvailable pkg_map1) - (Map.elems pkg_map1) - (pkg_map2, broken) = removePackages (map unitId directly_broken) index pkg_map1 - unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken - - -- Find recursive packages - sccs = stronglyConnComp [ (pkg, unitId pkg, depends pkg) - | pkg <- Map.elems pkg_map2 ] - getCyclicSCC (CyclicSCC vs) = map unitId vs - getCyclicSCC (AcyclicSCC _) = [] - (pkg_map3, cyclic) = removePackages (concatMap getCyclicSCC sccs) index pkg_map2 - unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic - - -- Apply ignore flags - directly_ignored = ignorePackages ignore_flags (Map.elems pkg_map3) - (pkg_map4, ignored) = removePackages (Map.keys directly_ignored) index pkg_map3 - unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored - - -- Knock out packages whose dependencies don't agree with ABI - -- (i.e., got invalidated due to shadowing) - directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) - (Map.elems pkg_map4) - (pkg_map5, shadowed) = removePackages (map unitId directly_shadowed) index pkg_map4 - unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed - - unusable = directly_ignored `Map.union` unusable_ignored - `Map.union` unusable_broken - `Map.union` unusable_cyclic - `Map.union` unusable_shadowed - --- ----------------------------------------------------------------------------- --- When all the command-line options are in, we can process our package --- settings and populate the package state. - -mkPackageState - :: DynFlags - -- initial databases, in the order they were specified on - -- the command line (later databases shadow earlier ones) - -> [(FilePath, [PackageConfig])] - -> [PreloadUnitId] -- preloaded packages - -> IO (PackageState, - [PreloadUnitId], -- new packages to preload - Maybe [(ModuleName, Module)]) - -mkPackageState dflags dbs preload0 = do -{- - Plan. - - There are two main steps for making the package state: - - 1. We want to build a single, unified package database based - on all of the input databases, which upholds the invariant that - there is only one package per any UnitId and there are no - dangling dependencies. We'll do this by merging, and - then successively filtering out bad dependencies. - - a) Merge all the databases together. - If an input database defines unit ID that is already in - the unified database, that package SHADOWS the existing - package in the current unified database. Note that - order is important: packages defined later in the list of - command line arguments shadow those defined earlier. - - b) Remove all packages with missing dependencies, or - mutually recursive dependencies. - - b) Remove packages selected by -ignore-package from input database - - c) Remove all packages which depended on packages that are now - shadowed by an ABI-incompatible package - - d) report (with -v) any packages that were removed by steps 1-3 - - 2. We want to look at the flags controlling package visibility, - and build a mapping of what module names are in scope and - where they live. - - a) on the final, unified database, we apply -trust/-distrust - flags directly, modifying the database so that the 'trusted' - field has the correct value. - - b) we use the -package/-hide-package flags to compute a - visibility map, stating what packages are "exposed" for - the purposes of computing the module map. - * if any flag refers to a package which was removed by 1-5, then - we can give an error message explaining why - * if -hide-all-packages what not specified, this step also - hides packages which are superseded by later exposed packages - * this step is done TWICE if -plugin-package/-hide-all-plugin-packages - are used - - c) based on the visibility map, we pick wired packages and rewrite - them to have the expected unitId. - - d) finally, using the visibility map and the package database, - we build a mapping saying what every in scope module name points to. --} - - -- This, and the other reverse's that you will see, are due to the face that - -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order - -- than they are on the command line. - let other_flags = reverse (packageFlags dflags) - debugTraceMsg dflags 2 $ - text "package flags" <+> ppr other_flags - - -- Merge databases together, without checking validity - (pkg_map1, prec_map) <- mergeDatabases dflags dbs - - -- Now that we've merged everything together, prune out unusable - -- packages. - let (pkg_map2, unusable, sccs) = validateDatabase dflags pkg_map1 - - reportCycles dflags sccs - reportUnusable dflags unusable - - -- Apply trust flags (these flags apply regardless of whether - -- or not packages are visible or not) - pkgs1 <- foldM (applyTrustFlag dflags prec_map unusable) - (Map.elems pkg_map2) (reverse (trustFlags dflags)) - let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1 - - -- - -- Calculate the initial set of packages, prior to any package flags. - -- This set contains the latest version of all valid (not unusable) packages, - -- or is empty if we have -hide-all-packages - -- - let preferLater pkg pkg' = - case compareByPreference prec_map pkg pkg' of - GT -> pkg - _ -> pkg' - calcInitial m pkg = addToUDFM_C preferLater m (fsPackageName pkg) pkg - initial = if gopt Opt_HideAllPackages dflags - then emptyUDFM - else foldl' calcInitial emptyUDFM pkgs1 - vis_map1 = foldUDFM (\p vm -> - -- Note: we NEVER expose indefinite packages by - -- default, because it's almost assuredly not - -- what you want (no mix-in linking has occurred). - if exposed p && unitIdIsDefinite (packageConfigId p) - then Map.insert (packageConfigId p) - UnitVisibility { - uv_expose_all = True, - uv_renamings = [], - uv_package_name = First (Just (fsPackageName p)), - uv_requirements = Map.empty, - uv_explicit = False - } - vm - else vm) - Map.empty initial - - -- - -- Compute a visibility map according to the command-line flags (-package, - -- -hide-package). This needs to know about the unusable packages, since if a - -- user tries to enable an unusable package, we should let them know. - -- - vis_map2 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable - (gopt Opt_HideAllPackages dflags) pkgs1) - vis_map1 other_flags - - -- - -- Sort out which packages are wired in. This has to be done last, since - -- it modifies the unit ids of wired in packages, but when we process - -- package arguments we need to key against the old versions. - -- - (pkgs2, wired_map) <- findWiredInPackages dflags prec_map pkgs1 vis_map2 - let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2 - - -- Update the visibility map, so we treat wired packages as visible. - let vis_map = updateVisibilityMap wired_map vis_map2 - - let hide_plugin_pkgs = gopt Opt_HideAllPluginPackages dflags - plugin_vis_map <- - case pluginPackageFlags dflags of - -- common case; try to share the old vis_map - [] | not hide_plugin_pkgs -> return vis_map - | otherwise -> return Map.empty - _ -> do let plugin_vis_map1 - | hide_plugin_pkgs = Map.empty - -- Use the vis_map PRIOR to wired in, - -- because otherwise applyPackageFlag - -- won't work. - | otherwise = vis_map2 - plugin_vis_map2 - <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable - (gopt Opt_HideAllPluginPackages dflags) pkgs1) - plugin_vis_map1 - (reverse (pluginPackageFlags dflags)) - -- Updating based on wired in packages is mostly - -- good hygiene, because it won't matter: no wired in - -- package has a compiler plugin. - -- TODO: If a wired in package had a compiler plugin, - -- and you tried to pick different wired in packages - -- with the plugin flags and the normal flags... what - -- would happen? I don't know! But this doesn't seem - -- likely to actually happen. - return (updateVisibilityMap wired_map plugin_vis_map2) - - -- - -- Here we build up a set of the packages mentioned in -package - -- flags on the command line; these are called the "preload" - -- packages. we link these packages in eagerly. The preload set - -- should contain at least rts & base, which is why we pretend that - -- the command line contains -package rts & -package base. - -- - -- NB: preload IS important even for type-checking, because we - -- need the correct include path to be set. - -- - let preload1 = Map.keys (Map.filter uv_explicit vis_map) - - let pkgname_map = foldl add Map.empty pkgs2 - where add pn_map p - = Map.insert (packageName p) (componentId p) pn_map - - -- The explicitPackages accurately reflects the set of packages we have turned - -- on; as such, it also is the only way one can come up with requirements. - -- The requirement context is directly based off of this: we simply - -- look for nested unit IDs that are directly fed holes: the requirements - -- of those units are precisely the ones we need to track - let explicit_pkgs = Map.keys vis_map - req_ctx = Map.map (Set.toList) - $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map)) - - - let preload2 = preload1 - - let - -- add base & rts to the preload packages - basicLinkedPackages - | gopt Opt_AutoLinkPackages dflags - = filter (flip elemUDFM (unPackageConfigMap pkg_db)) - [baseUnitId, rtsUnitId] - | otherwise = [] - -- but in any case remove the current package from the set of - -- preloaded packages so that base/rts does not end up in the - -- set up preloaded package when we are just building it - -- (NB: since this is only relevant for base/rts it doesn't matter - -- that thisUnitIdInsts_ is not wired yet) - -- - preload3 = nub $ filter (/= thisPackage dflags) - $ (basicLinkedPackages ++ preload2) - - -- Close the preload packages with their dependencies - dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing)) - let new_dep_preload = filter (`notElem` preload0) dep_preload - - let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map - when (dopt Opt_D_dump_mod_map dflags) $ - printInfoForUser (dflags { pprCols = 200 }) - alwaysQualify (pprModuleMap mod_map) - - -- Force pstate to avoid leaking the dflags0 passed to mkPackageState - let !pstate = PackageState{ - preloadPackages = dep_preload, - explicitPackages = explicit_pkgs, - pkgIdMap = pkg_db, - moduleToPkgConfAll = mod_map, - pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map, - packageNameMap = pkgname_map, - unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ], - requirementContext = req_ctx - } - let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags) - return (pstate, new_dep_preload, new_insts) - --- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId' --- that it was recorded as in the package database. -unwireUnitId :: DynFlags -> UnitId -> UnitId -unwireUnitId dflags uid@(DefiniteUnitId def_uid) = - maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags))) -unwireUnitId _ uid = uid - --- ----------------------------------------------------------------------------- --- | Makes the mapping from module to package info - --- Slight irritation: we proceed by leafing through everything --- in the installed package database, which makes handling indefinite --- packages a bit bothersome. - -mkModuleToPkgConfAll - :: DynFlags - -> PackageConfigMap - -> VisibilityMap - -> ModuleToPkgConfAll -mkModuleToPkgConfAll dflags pkg_db vis_map = - Map.foldlWithKey extend_modmap emptyMap vis_map - where - emptyMap = Map.empty - sing pk m _ = Map.singleton (mkModule pk m) - addListTo = foldl' merge - merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m - setOrigins m os = fmap (const os) m - extend_modmap modmap uid - UnitVisibility { uv_expose_all = b, uv_renamings = rns } - = addListTo modmap theBindings - where - pkg = pkg_lookup uid - - theBindings :: [(ModuleName, Map Module ModuleOrigin)] - theBindings = newBindings b rns - - newBindings :: Bool - -> [(ModuleName, ModuleName)] - -> [(ModuleName, Map Module ModuleOrigin)] - newBindings e rns = es e ++ hiddens ++ map rnBinding rns - - rnBinding :: (ModuleName, ModuleName) - -> (ModuleName, Map Module ModuleOrigin) - rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) - where origEntry = case lookupUFM esmap orig of - Just r -> r - Nothing -> throwGhcException (CmdLineError (showSDoc dflags - (text "package flag: could not find module name" <+> - ppr orig <+> text "in package" <+> ppr pk))) - - es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] - es e = do - (m, exposedReexport) <- exposed_mods - let (pk', m', pkg', origin') = - case exposedReexport of - Nothing -> (pk, m, pkg, fromExposedModules e) - Just (Module pk' m') -> - let pkg' = pkg_lookup pk' - in (pk', m', pkg', fromReexportedModules e pkg') - return (m, sing pk' m' pkg' origin') - - esmap :: UniqFM (Map Module ModuleOrigin) - esmap = listToUFM (es False) -- parameter here doesn't matter, orig will - -- be overwritten - - hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods] - - pk = packageConfigId pkg - pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid - `orElse` pprPanic "pkg_lookup" (ppr uid) - - exposed_mods = exposedModules pkg - hidden_mods = hiddenModules pkg - --- ----------------------------------------------------------------------------- --- Extracting information from the packages in scope - --- Many of these functions take a list of packages: in those cases, --- the list is expected to contain the "dependent packages", --- i.e. those packages that were found to be depended on by the --- current module/program. These can be auto or non-auto packages, it --- doesn't really matter. The list is always combined with the list --- of preload (command-line) packages to determine which packages to --- use. - --- | Find all the include directories in these and the preload packages -getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String] -getPackageIncludePath dflags pkgs = - collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs - -collectIncludeDirs :: [PackageConfig] -> [FilePath] -collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps)) - --- | Find all the library paths in these and the preload packages -getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String] -getPackageLibraryPath dflags pkgs = - collectLibraryPaths dflags `fmap` getPreloadPackagesAnd dflags pkgs - -collectLibraryPaths :: DynFlags -> [PackageConfig] -> [FilePath] -collectLibraryPaths dflags = nub . filter notNull - . concatMap (libraryDirsForWay dflags) - --- | Find all the link options in these and the preload packages, --- returning (package hs lib options, extra library options, other flags) -getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String]) -getPackageLinkOpts dflags pkgs = - collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs - -collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String]) -collectLinkOpts dflags ps = - ( - concatMap (map ("-l" ++) . packageHsLibs dflags) ps, - concatMap (map ("-l" ++) . extraLibraries) ps, - concatMap ldOptions ps - ) - -packageHsLibs :: DynFlags -> PackageConfig -> [String] -packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) - where - ways0 = ways dflags - - ways1 = filter (/= WayDyn) ways0 - -- the name of a shared library is libHSfoo-ghc.so - -- we leave out the _dyn, because it is superfluous - - -- debug and profiled RTSs include support for -eventlog - ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1 - = filter (/= WayEventLog) ways1 - | otherwise - = ways1 - - tag = mkBuildTag (filter (not . wayRTSOnly) ways2) - rts_tag = mkBuildTag ways2 - - mkDynName x - | WayDyn `notElem` ways dflags = x - | "HS" `isPrefixOf` x = - x ++ '-':programName dflags ++ projectVersion dflags - -- For non-Haskell libraries, we use the name "Cfoo". The .a - -- file is libCfoo.a, and the .so is libfoo.so. That way the - -- linker knows what we mean for the vanilla (-lCfoo) and dyn - -- (-lfoo) ways. We therefore need to strip the 'C' off here. - | Just x' <- stripPrefix "C" x = x' - | otherwise - = panic ("Don't understand library name " ++ x) - - addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) - addSuffix other_lib = other_lib ++ (expandTag tag) - - expandTag t | null t = "" - | otherwise = '_':t - --- | Either the 'libraryDirs' or 'libraryDynDirs' as appropriate for the way. -libraryDirsForWay :: DynFlags -> PackageConfig -> [String] -libraryDirsForWay dflags - | WayDyn `elem` ways dflags = libraryDynDirs - | otherwise = libraryDirs - --- | Find all the C-compiler options in these and the preload packages -getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String] -getPackageExtraCcOpts dflags pkgs = do - ps <- getPreloadPackagesAnd dflags pkgs - return (concatMap ccOptions ps) - --- | Find all the package framework paths in these and the preload packages -getPackageFrameworkPath :: DynFlags -> [PreloadUnitId] -> IO [String] -getPackageFrameworkPath dflags pkgs = do - ps <- getPreloadPackagesAnd dflags pkgs - return (nub (filter notNull (concatMap frameworkDirs ps))) - --- | Find all the package frameworks in these and the preload packages -getPackageFrameworks :: DynFlags -> [PreloadUnitId] -> IO [String] -getPackageFrameworks dflags pkgs = do - ps <- getPreloadPackagesAnd dflags pkgs - return (concatMap frameworks ps) - --- ----------------------------------------------------------------------------- --- Package Utils - --- | Takes a 'ModuleName', and if the module is in any package returns --- list of modules which take that name. -lookupModuleInAllPackages :: DynFlags - -> ModuleName - -> [(Module, PackageConfig)] -lookupModuleInAllPackages dflags m - = case lookupModuleWithSuggestions dflags m Nothing of - LookupFound a b -> [(a,b)] - LookupMultiple rs -> map f rs - where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags - (moduleUnitId m))) - _ -> [] - --- | The result of performing a lookup -data LookupResult = - -- | Found the module uniquely, nothing else to do - LookupFound Module PackageConfig - -- | Multiple modules with the same name in scope - | LookupMultiple [(Module, ModuleOrigin)] - -- | No modules found, but there were some hidden ones with - -- an exact name match. First is due to package hidden, second - -- is due to module being hidden - | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] - -- | Nothing found, here are some suggested different names - | LookupNotFound [ModuleSuggestion] -- suggestions - -data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin - | SuggestHidden ModuleName Module ModuleOrigin - -lookupModuleWithSuggestions :: DynFlags - -> ModuleName - -> Maybe FastString - -> LookupResult -lookupModuleWithSuggestions dflags - = lookupModuleWithSuggestions' dflags - (moduleToPkgConfAll (pkgState dflags)) - -lookupPluginModuleWithSuggestions :: DynFlags - -> ModuleName - -> Maybe FastString - -> LookupResult -lookupPluginModuleWithSuggestions dflags - = lookupModuleWithSuggestions' dflags - (pluginModuleToPkgConfAll (pkgState dflags)) - -lookupModuleWithSuggestions' :: DynFlags - -> ModuleToPkgConfAll - -> ModuleName - -> Maybe FastString - -> LookupResult -lookupModuleWithSuggestions' dflags mod_map m mb_pn - = case Map.lookup m mod_map of - Nothing -> LookupNotFound suggestions - Just xs -> - case foldl' classify ([],[],[]) (Map.toList xs) of - ([], [], []) -> LookupNotFound suggestions - (_, _, [(m, _)]) -> LookupFound m (mod_pkg m) - (_, _, exposed@(_:_)) -> LookupMultiple exposed - (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod - where - classify (hidden_pkg, hidden_mod, exposed) (m, origin0) = - let origin = filterOrigin mb_pn (mod_pkg m) origin0 - x = (m, origin) - in case origin of - ModHidden -> (hidden_pkg, x:hidden_mod, exposed) - _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed) - | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed) - | otherwise -> (x:hidden_pkg, hidden_mod, exposed) - - pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) - mod_pkg = pkg_lookup . moduleUnitId - - -- Filters out origins which are not associated with the given package - -- qualifier. No-op if there is no package qualifier. Test if this - -- excluded all origins with 'originEmpty'. - filterOrigin :: Maybe FastString - -> PackageConfig - -> ModuleOrigin - -> ModuleOrigin - filterOrigin Nothing _ o = o - filterOrigin (Just pn) pkg o = - case o of - ModHidden -> if go pkg then ModHidden else mempty - ModOrigin { fromOrigPackage = e, fromExposedReexport = res, - fromHiddenReexport = rhs } - -> ModOrigin { - fromOrigPackage = if go pkg then e else Nothing - , fromExposedReexport = filter go res - , fromHiddenReexport = filter go rhs - , fromPackageFlag = False -- always excluded - } - where go pkg = pn == fsPackageName pkg - - suggestions - | gopt Opt_HelpfulErrors dflags = - fuzzyLookup (moduleNameString m) all_mods - | otherwise = [] - - all_mods :: [(String, ModuleSuggestion)] -- All modules - all_mods = sortBy (comparing fst) $ - [ (moduleNameString m, suggestion) - | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) - , suggestion <- map (getSuggestion m) (Map.toList e) - ] - getSuggestion name (mod, origin) = - (if originVisible origin then SuggestVisible else SuggestHidden) - name mod origin - -listVisibleModuleNames :: DynFlags -> [ModuleName] -listVisibleModuleNames dflags = - map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags)))) - where visible (_, ms) = any originVisible (Map.elems ms) - --- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of --- 'PackageConfig's -getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig] -getPreloadPackagesAnd dflags pkgids0 = - let - pkgids = pkgids0 ++ map (toInstalledUnitId . moduleUnitId . snd) - (thisUnitIdInsts dflags) - state = pkgState dflags - pkg_map = pkgIdMap state - preload = preloadPackages state - pairs = zip pkgids (repeat Nothing) - in do - all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) - return (map (getInstalledPackageDetails dflags) all_pkgs) - --- Takes a list of packages, and returns the list with dependencies included, --- in reverse dependency order (a package appears before those it depends on). -closeDeps :: DynFlags - -> PackageConfigMap - -> [(InstalledUnitId, Maybe InstalledUnitId)] - -> IO [InstalledUnitId] -closeDeps dflags pkg_map ps - = throwErr dflags (closeDepsErr dflags pkg_map ps) - -throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a -throwErr dflags m - = case m of - Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e)) - Succeeded r -> return r - -closeDepsErr :: DynFlags - -> PackageConfigMap - -> [(InstalledUnitId,Maybe InstalledUnitId)] - -> MaybeErr MsgDoc [InstalledUnitId] -closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps - --- internal helper -add_package :: DynFlags - -> PackageConfigMap - -> [PreloadUnitId] - -> (PreloadUnitId,Maybe PreloadUnitId) - -> MaybeErr MsgDoc [PreloadUnitId] -add_package dflags pkg_db ps (p, mb_parent) - | p `elem` ps = return ps -- Check if we've already added this package - | otherwise = - case lookupInstalledPackage' pkg_db p of - Nothing -> Failed (missingPackageMsg p <> - missingDependencyMsg mb_parent) - Just pkg -> do - -- Add the package's dependents also - ps' <- foldM add_unit_key ps (depends pkg) - return (p : ps') - where - add_unit_key ps key - = add_package dflags pkg_db ps (key, Just p) - -missingPackageMsg :: Outputable pkgid => pkgid -> SDoc -missingPackageMsg p = text "unknown package:" <+> ppr p - -missingDependencyMsg :: Maybe InstalledUnitId -> SDoc -missingDependencyMsg Nothing = Outputable.empty -missingDependencyMsg (Just parent) - = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent)) - --- ----------------------------------------------------------------------------- - -componentIdString :: DynFlags -> ComponentId -> Maybe String -componentIdString dflags cid = do - conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid) - return $ - case sourceLibName conf of - Nothing -> sourcePackageIdString conf - Just (PackageName libname) -> - packageNameString conf - ++ "-" ++ showVersion (packageVersion conf) - ++ ":" ++ unpackFS libname - -displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String -displayInstalledUnitId dflags uid = - fmap sourcePackageIdString (lookupInstalledPackage dflags uid) - --- | Will the 'Name' come from a dynamically linked library? -isDllName :: DynFlags -> Module -> Name -> Bool --- Despite the "dll", I think this function just means that --- the symbol comes from another dynamically-linked package, --- and applies on all platforms, not just Windows -isDllName dflags this_mod name - | WayDyn `notElem` ways dflags = False - | Just mod <- nameModule_maybe name - -- Issue #8696 - when GHC is dynamically linked, it will attempt - -- to load the dynamic dependencies of object files at compile - -- time for things like QuasiQuotes or - -- TemplateHaskell. Unfortunately, this interacts badly with - -- intra-package linking, because we don't generate indirect - -- (dynamic) symbols for intra-package calls. This means that if a - -- module with an intra-package call is loaded without its - -- dependencies, then GHC fails to link. This is the cause of # - -- - -- In the mean time, always force dynamic indirections to be - -- generated: when the module name isn't the module being - -- compiled, references are dynamic. - = if mod /= this_mod - then True - else case dllSplit dflags of - Nothing -> False - Just ss -> - let findMod m = let modStr = moduleNameString (moduleName m) - in case find (modStr `Set.member`) ss of - Just i -> i - Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split") - in findMod mod /= findMod this_mod - - | otherwise = False -- no, it is not even an external name - --- ----------------------------------------------------------------------------- --- Displaying packages - --- | Show (very verbose) package info -pprPackages :: DynFlags -> SDoc -pprPackages = pprPackagesWith pprPackageConfig - -pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc -pprPackagesWith pprIPI dflags = - vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags))) - --- | Show simplified package info. --- --- The idea is to only print package id, and any information that might --- be different from the package databases (exposure, trust) -pprPackagesSimple :: DynFlags -> SDoc -pprPackagesSimple = pprPackagesWith pprIPI - where pprIPI ipi = let i = installedUnitIdFS (unitId ipi) - e = if exposed ipi then text "E" else text " " - t = if trusted ipi then text "T" else text " " - in e <> t <> text " " <> ftext i - --- | Show the mapping of modules to where they come from. -pprModuleMap :: ModuleToPkgConfAll -> SDoc -pprModuleMap mod_map = - vcat (map pprLine (Map.toList mod_map)) - where - pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) - pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc - pprEntry m (m',o) - | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o) - | otherwise = ppr m' <+> parens (ppr o) - -fsPackageName :: PackageConfig -> FastString -fsPackageName = mkFastString . packageNameString - --- | Given a fully instantiated 'UnitId', improve it into a --- 'InstalledUnitId' if we can find it in the package database. -improveUnitId :: PackageConfigMap -> UnitId -> UnitId -improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit -improveUnitId pkg_map uid = - -- Do NOT lookup indefinite ones, they won't be useful! - case lookupPackage' False pkg_map uid of - Nothing -> uid - Just pkg -> - -- Do NOT improve if the indefinite unit id is not - -- part of the closure unique set. See - -- Note [UnitId to InstalledUnitId improvement] - if installedPackageConfigId pkg `elementOfUniqSet` preloadClosure pkg_map - then packageConfigId pkg - else uid - --- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used --- in the @hs-boot@ loop-breaker. -getPackageConfigMap :: DynFlags -> PackageConfigMap -getPackageConfigMap = pkgIdMap . pkgState diff --git a/main/Packages.hs-boot b/main/Packages.hs-boot deleted file mode 100644 --- a/main/Packages.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module Packages where -import {-# SOURCE #-} DynFlags(DynFlags) -import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId) -data PackageState -data PackageConfigMap -emptyPackageState :: PackageState -componentIdString :: DynFlags -> ComponentId -> Maybe String -displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String -improveUnitId :: PackageConfigMap -> UnitId -> UnitId -getPackageConfigMap :: DynFlags -> PackageConfigMap diff --git a/main/PipelineMonad.hs b/main/PipelineMonad.hs deleted file mode 100644 --- a/main/PipelineMonad.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} --- | The CompPipeline monad and associated ops --- --- Defined in separate module so that it can safely be imported from Hooks -module PipelineMonad ( - CompPipeline(..), evalP - , PhasePlus(..) - , PipeEnv(..), PipeState(..), PipelineOutput(..) - , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs - ) where - -import MonadUtils -import Outputable -import DynFlags -import DriverPhases -import HscTypes -import Module - -import Control.Monad - -newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } - -evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a -evalP f env st = liftM snd $ unP f env st - -instance Functor CompPipeline where - fmap = liftM - -instance Applicative CompPipeline where - pure a = P $ \_env state -> return (state, a) - (<*>) = ap - -instance Monad CompPipeline where - P m >>= k = P $ \env state -> do (state',a) <- m env state - unP (k a) env state' - -instance MonadIO CompPipeline where - liftIO m = P $ \_env state -> do a <- m; return (state, a) - -data PhasePlus = RealPhase Phase - | HscOut HscSource ModuleName HscStatus - -instance Outputable PhasePlus where - ppr (RealPhase p) = ppr p - ppr (HscOut {}) = text "HscOut" - --- ----------------------------------------------------------------------------- --- The pipeline uses a monad to carry around various bits of information - --- PipeEnv: invariant information passed down -data PipeEnv = PipeEnv { - stop_phase :: Phase, -- ^ Stop just before this phase - src_filename :: String, -- ^ basename of original input source - src_basename :: String, -- ^ basename of original input source - src_suffix :: String, -- ^ its extension - output_spec :: PipelineOutput -- ^ says where to put the pipeline output - } - --- PipeState: information that might change during a pipeline run -data PipeState = PipeState { - hsc_env :: HscEnv, - -- ^ only the DynFlags change in the HscEnv. The DynFlags change - -- at various points, for example when we read the OPTIONS_GHC - -- pragmas in the Cpp phase. - maybe_loc :: Maybe ModLocation, - -- ^ the ModLocation. This is discovered during compilation, - -- in the Hsc phase where we read the module header. - foreign_os :: [FilePath] - -- ^ additional object files resulting from compiling foreign - -- code. They come from two sources: foreign stubs, and - -- add{C,Cxx,Objc,Objcxx}File from template haskell - } - -data PipelineOutput - = Temporary - -- ^ Output should be to a temporary file: we're going to - -- run more compilation steps on this output later. - | Persistent - -- ^ We want a persistent file, i.e. a file in the current directory - -- derived from the input filename, but with the appropriate extension. - -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. - | SpecificFile - -- ^ The output must go into the specific outputFile in DynFlags. - -- We don't store the filename in the constructor as it changes - -- when doing -dynamic-too. - deriving Show - -getPipeEnv :: CompPipeline PipeEnv -getPipeEnv = P $ \env state -> return (state, env) - -getPipeState :: CompPipeline PipeState -getPipeState = P $ \_env state -> return (state, state) - -instance HasDynFlags CompPipeline where - getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) - -setDynFlags :: DynFlags -> CompPipeline () -setDynFlags dflags = P $ \_env state -> - return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) - -setModLocation :: ModLocation -> CompPipeline () -setModLocation loc = P $ \_env state -> - return (state{ maybe_loc = Just loc }, ()) - -setForeignOs :: [FilePath] -> CompPipeline () -setForeignOs os = P $ \_env state -> - return (state{ foreign_os = os }, ()) diff --git a/main/PlatformConstants.hs b/main/PlatformConstants.hs deleted file mode 100644 --- a/main/PlatformConstants.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE CPP #-} - -------------------------------------------------------------------------------- --- --- | Platform constants --- --- (c) The University of Glasgow 2013 --- -------------------------------------------------------------------------------- - -module PlatformConstants (PlatformConstants(..)) where - --- Produced by deriveConstants -#include "GHCConstantsHaskellType.hs" - diff --git a/main/Plugins.hs b/main/Plugins.hs deleted file mode 100644 --- a/main/Plugins.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Plugins ( - FrontendPlugin(..), defaultFrontendPlugin, - Plugin(..), CommandLineOption, - defaultPlugin - ) where - -import CoreMonad ( CoreToDo, CoreM ) -import TcRnTypes ( TcPlugin ) -import GhcMonad -import DriverPhases - - --- | Command line options gathered from the -PModule.Name:stuff syntax --- are given to you as this type -type CommandLineOption = String - --- | 'Plugin' is the core compiler plugin data type. Try to avoid --- constructing one of these directly, and just modify some fields of --- 'defaultPlugin' instead: this is to try and preserve source-code --- compatibility when we add fields to this. --- --- Nonetheless, this API is preliminary and highly likely to change in --- the future. -data Plugin = Plugin { - installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] - -- ^ Modify the Core pipeline that will be used for compilation. - -- This is called as the Core pipeline is built for every module - -- being compiled, and plugins get the opportunity to modify the - -- pipeline in a nondeterministic order. - , tcPlugin :: [CommandLineOption] -> Maybe TcPlugin - -- ^ An optional typechecker plugin, which may modify the - -- behaviour of the constraint solver. - } - --- | Default plugin: does nothing at all! For compatibility reasons --- you should base all your plugin definitions on this default value. -defaultPlugin :: Plugin -defaultPlugin = Plugin { - installCoreToDos = const return - , tcPlugin = const Nothing - } - -type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () -data FrontendPlugin = FrontendPlugin { - frontend :: FrontendPluginAction - } -defaultFrontendPlugin :: FrontendPlugin -defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () } diff --git a/main/PprTyThing.hs b/main/PprTyThing.hs deleted file mode 100644 --- a/main/PprTyThing.hs +++ /dev/null @@ -1,171 +0,0 @@ ------------------------------------------------------------------------------ --- --- Pretty-printing TyThings --- --- (c) The GHC Team 2005 --- ------------------------------------------------------------------------------ - -{-# LANGUAGE CPP #-} -module PprTyThing ( - pprTyThing, - pprTyThingInContext, - pprTyThingLoc, - pprTyThingInContextLoc, - pprTyThingHdr, - pprTypeForUser, - pprFamInst - ) where - -#include "HsVersions.h" - -import Type ( TyThing(..) ) -import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..) - , showToHeader, pprIfaceDecl ) -import CoAxiom ( coAxiomTyCon ) -import HscTypes( tyThingParent_maybe ) -import MkIface ( tyThingToIfaceDecl ) -import Type ( tidyOpenType ) -import FamInstEnv( FamInst(..), FamFlavor(..) ) -import Type( Type, pprTypeApp, pprSigmaType ) -import Name -import VarEnv( emptyTidyEnv ) -import Outputable - --- ----------------------------------------------------------------------------- --- Pretty-printing entities that we get from the GHC API - -{- Note [Pretty-printing TyThings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pretty-print a TyThing by converting it to an IfaceDecl, -and pretty-printing that (see ppr_ty_thing below). -Here is why: - -* When pretty-printing (a type, say), the idiomatic solution is not to - "rename type variables on the fly", but rather to "tidy" the type - (which gives each variable a distinct print-name), and then - pretty-print it (without renaming). Separate the two - concerns. Functions like tidyType do this. - -* Alas, for type constructors, TyCon, tidying does not work well, - because a TyCon includes DataCons which include Types, which mention - TyCons. And tidying can't tidy a mutually recursive data structure - graph, only trees. - -* One alternative would be to ensure that TyCons get type variables - with distinct print-names. That's ok for type variables but less - easy for kind variables. Processing data type declarations is - already so complicated that I don't think it's sensible to add the - extra requirement that it generates only "pretty" types and kinds. - -* One place the non-pretty names can show up is in GHCi. But another - is in interface files. Look at MkIface.tyThingToIfaceDecl which - converts a TyThing (i.e. TyCon, Class etc) to an IfaceDecl. And it - already does tidying as part of that conversion! Why? Because - interface files contains fast-strings, not uniques, so the names - must at least be distinct. - -So if we convert to IfaceDecl, we get a nice tidy IfaceDecl, and can -print that. Of course, that means that pretty-printing IfaceDecls -must be careful to display nice user-friendly results, but that's ok. - -See #7730, #8776 for details -} - --------------------- --- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location. -pprFamInst :: FamInst -> SDoc --- * For data instances we go via pprTyThing of the representational TyCon, --- because there is already much cleverness associated with printing --- data type declarations that I don't want to duplicate --- * For type instances we print directly here; there is no TyCon --- to give to pprTyThing --- --- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes - -pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc }) - = pprTyThingInContextLoc (ATyCon rep_tc) - -pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom - , fi_tys = lhs_tys, fi_rhs = rhs }) - = showWithLoc (pprDefinedAt (getName axiom)) $ - hang (text "type instance" <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) - 2 (equals <+> ppr rhs) - ----------------------------- --- | Pretty-prints a 'TyThing' with its defining location. -pprTyThingLoc :: TyThing -> SDoc -pprTyThingLoc tyThing - = showWithLoc (pprDefinedAt (getName tyThing)) - (pprTyThing showToHeader tyThing) - --- | Pretty-prints the 'TyThing' header. For functions and data constructors --- the function is equivalent to 'pprTyThing' but for type constructors --- and classes it prints only the header part of the declaration. -pprTyThingHdr :: TyThing -> SDoc -pprTyThingHdr = pprTyThing showToHeader - --- | Pretty-prints a 'TyThing' in context: that is, if the entity --- is a data constructor, record selector, or class method, then --- the entity's parent declaration is pretty-printed with irrelevant --- parts omitted. -pprTyThingInContext :: ShowSub -> TyThing -> SDoc -pprTyThingInContext show_sub thing - = go [] thing - where - go ss thing - = case tyThingParent_maybe thing of - Just parent -> - go (getOccName thing : ss) parent - Nothing -> - pprTyThing - (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) }) - thing - --- | Like 'pprTyThingInContext', but adds the defining location. -pprTyThingInContextLoc :: TyThing -> SDoc -pprTyThingInContextLoc tyThing - = showWithLoc (pprDefinedAt (getName tyThing)) - (pprTyThingInContext showToHeader tyThing) - --- | Pretty-prints a 'TyThing'. -pprTyThing :: ShowSub -> TyThing -> SDoc --- We pretty-print 'TyThing' via 'IfaceDecl' --- See Note [Pretty-printing TyThings] -pprTyThing ss ty_thing - = pprIfaceDecl ss' (tyThingToIfaceDecl ty_thing) - where - ss' = case ss_how_much ss of - ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' } - ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' } - _ -> ss - - ppr' = AltPpr $ ppr_bndr $ getName ty_thing - - ppr_bndr :: Name -> Maybe (OccName -> SDoc) - ppr_bndr name - | isBuiltInSyntax name - = Nothing - | otherwise - = case nameModule_maybe name of - Just mod -> Just $ \occ -> getPprStyle $ \sty -> - pprModulePrefix sty mod occ <> ppr occ - Nothing -> WARN( True, ppr name ) Nothing - -- Nothing is unexpected here; TyThings have External names - -pprTypeForUser :: Type -> SDoc --- The type is tidied -pprTypeForUser ty - = pprSigmaType tidy_ty - where - (_, tidy_ty) = tidyOpenType emptyTidyEnv ty - -- Often the types/kinds we print in ghci are fully generalised - -- and have no free variables, but it turns out that we sometimes - -- print un-generalised kinds (eg when doing :k T), so it's - -- better to use tidyOpenType here - -showWithLoc :: SDoc -> SDoc -> SDoc -showWithLoc loc doc - = hang doc 2 (char '\t' <> comment <+> loc) - -- The tab tries to make them line up a bit - where - comment = text "--" diff --git a/main/StaticPtrTable.hs b/main/StaticPtrTable.hs deleted file mode 100644 --- a/main/StaticPtrTable.hs +++ /dev/null @@ -1,290 +0,0 @@ --- | Code generation for the Static Pointer Table --- --- (c) 2014 I/O Tweag --- --- Each module that uses 'static' keyword declares an initialization function of --- the form hs_spt_init_() which is emitted into the _stub.c file and --- annotated with __attribute__((constructor)) so that it gets executed at --- startup time. --- --- The function's purpose is to call hs_spt_insert to insert the static --- pointers of this module in the hashtable of the RTS, and it looks something --- like this: --- --- > static void hs_hpc_init_Main(void) __attribute__((constructor)); --- > static void hs_hpc_init_Main(void) { --- > --- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; --- > extern StgPtr Main_r2wb_closure; --- > hs_spt_insert(k0, &Main_r2wb_closure); --- > --- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; --- > extern StgPtr Main_r2wc_closure; --- > hs_spt_insert(k1, &Main_r2wc_closure); --- > --- > } --- --- where the constants are fingerprints produced from the static forms. --- --- The linker must find the definitions matching the @extern StgPtr @ --- declarations. For this to work, the identifiers of static pointers need to be --- exported. This is done in SetLevels.newLvlVar. --- --- There is also a finalization function for the time when the module is --- unloaded. --- --- > static void hs_hpc_fini_Main(void) __attribute__((destructor)); --- > static void hs_hpc_fini_Main(void) { --- > --- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; --- > hs_spt_remove(k0); --- > --- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; --- > hs_spt_remove(k1); --- > --- > } --- - -{-# LANGUAGE ViewPatterns, TupleSections #-} -module StaticPtrTable - ( sptCreateStaticBinds - , sptModuleInitCode - ) where - -{- Note [Grand plan for static forms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Static forms go through the compilation phases as follows. -Here is a running example: - - f x = let k = map toUpper - in ...(static k)... - -* The renamer looks for out-of-scope names in the body of the static - form, as always If all names are in scope, the free variables of the - body are stored in AST at the location of the static form. - -* The typechecker verifies that all free variables occurring in the - static form are floatable to top level (see Note [Meaning of - IdBindingInfo] in TcRnTypes). In our example, 'k' is floatable, even - though it is bound in a nested let, we are fine. - -* The desugarer replaces the static form with an application of the - function 'makeStatic' (defined in module GHC.StaticPtr.Internal of - base). So we get - - f x = let k = map toUpper - in ...fromStaticPtr (makeStatic location k)... - -* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic' - to the top level. Thus the FloatOut pass is always executed, even when - optimizations are disabled. So we get - - k = map toUpper - static_ptr = makeStatic location k - f x = ...fromStaticPtr static_ptr... - - The FloatOut pass is careful to produce an /exported/ Id for a floated - 'makeStatic' call, so the binding is not removed or inlined by the - simplifier. - E.g. the code for `f` above might look like - - static_ptr = makeStatic location k - f x = ...(case static_ptr of ...)... - - which might be simplified to - - f x = ...(case makeStatic location k of ...)... - - BUT the top-level binding for static_ptr must remain, so that it can be - collected to populate the Static Pointer Table. - - Making the binding exported also has a necessary effect during the - CoreTidy pass. - -* The CoreTidy pass replaces all bindings of the form - - b = /\ ... -> makeStatic location value - - with - - b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value - - where a distinct key is generated for each binding. - -* If we are compiling to object code we insert a C stub (generated by - sptModuleInitCode) into the final object which runs when the module is loaded, - inserting the static forms defined by the module into the RTS's static pointer - table. - -* If we are compiling for the byte-code interpreter, we instead explicitly add - the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter - process' SPT table using the addSptEntry interpreter message. This happens - in upsweep after we have compiled the module (see GhcMake.upsweep'). --} - -import CLabel -import CoreSyn -import CoreUtils (collectMakeStaticArgs) -import DataCon -import DynFlags -import HscTypes -import Id -import MkCore (mkStringExprFSWith) -import Module -import Name -import Outputable -import Platform -import PrelNames -import TcEnv (lookupGlobal) -import Type - -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State -import Data.List -import Data.Maybe -import GHC.Fingerprint -import qualified GHC.LanguageExtensions as LangExt - --- | Replaces all bindings of the form --- --- > b = /\ ... -> makeStatic location value --- --- with --- --- > b = /\ ... -> --- > StaticPtr key (StaticPtrInfo "pkg key" "module" location) value --- --- where a distinct key is generated for each binding. --- --- It also yields the C stub that inserts these bindings into the static --- pointer table. -sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram - -> IO ([SptEntry], CoreProgram) -sptCreateStaticBinds hsc_env this_mod binds - | not (xopt LangExt.StaticPointers dflags) = - return ([], binds) - | otherwise = do - -- Make sure the required interface files are loaded. - _ <- lookupGlobal hsc_env unpackCStringName - (fps, binds') <- evalStateT (go [] [] binds) 0 - return (fps, binds') - where - go fps bs xs = case xs of - [] -> return (reverse fps, reverse bs) - bnd : xs' -> do - (fps', bnd') <- replaceStaticBind bnd - go (reverse fps' ++ fps) (bnd' : bs) xs' - - dflags = hsc_dflags hsc_env - - -- Generates keys and replaces 'makeStatic' with 'StaticPtr'. - -- - -- The 'Int' state is used to produce a different key for each binding. - replaceStaticBind :: CoreBind - -> StateT Int IO ([SptEntry], CoreBind) - replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e - return (maybeToList mfp, NonRec b' e') - replaceStaticBind (Rec rbs) = do - (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs - return (catMaybes mfps, Rec rbs') - - replaceStatic :: Id -> CoreExpr - -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr)) - replaceStatic b e@(collectTyBinders -> (tvs, e0)) = - case collectMakeStaticArgs e0 of - Nothing -> return (Nothing, (b, e)) - Just (_, t, info, arg) -> do - (fp, e') <- mkStaticBind t info arg - return (Just (SptEntry b fp), (b, foldr Lam e' tvs)) - - mkStaticBind :: Type -> CoreExpr -> CoreExpr - -> StateT Int IO (Fingerprint, CoreExpr) - mkStaticBind t srcLoc e = do - i <- get - put (i + 1) - staticPtrInfoDataCon <- - lift $ lookupDataConHscEnv staticPtrInfoDataConName - let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i - info <- mkConApp staticPtrInfoDataCon <$> - (++[srcLoc]) <$> - mapM (mkStringExprFSWith (lift . lookupIdHscEnv)) - [ unitIdFS $ moduleUnitId this_mod - , moduleNameFS $ moduleName this_mod - ] - - -- The module interface of GHC.StaticPtr should be loaded at least - -- when looking up 'fromStatic' during type-checking. - staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName - return (fp, mkConApp staticPtrDataCon - [ Type t - , mkWord64LitWordRep dflags w0 - , mkWord64LitWordRep dflags w1 - , info - , e ]) - - mkStaticPtrFingerprint :: Int -> Fingerprint - mkStaticPtrFingerprint n = fingerprintString $ intercalate ":" - [ unitIdString $ moduleUnitId this_mod - , moduleNameString $ moduleName this_mod - , show n - ] - - -- Choose either 'Word64#' or 'Word#' to represent the arguments of the - -- 'Fingerprint' data constructor. - mkWord64LitWordRep dflags - | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64 - | otherwise = mkWordLit dflags . toInteger - - lookupIdHscEnv :: Name -> IO Id - lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>= - maybe (getError n) (return . tyThingId) - - lookupDataConHscEnv :: Name -> IO DataCon - lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>= - maybe (getError n) (return . tyThingDataCon) - - getError n = pprPanic "sptCreateStaticBinds.get: not found" $ - text "Couldn't find" <+> ppr n - --- | @sptModuleInitCode module fps@ is a C stub to insert the static entries --- of @module@ into the static pointer table. --- --- @fps@ is a list associating each binding corresponding to a static entry with --- its fingerprint. -sptModuleInitCode :: Module -> [SptEntry] -> SDoc -sptModuleInitCode _ [] = Outputable.empty -sptModuleInitCode this_mod entries = vcat - [ text "static void hs_spt_init_" <> ppr this_mod - <> text "(void) __attribute__((constructor));" - , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)" - , braces $ vcat $ - [ text "static StgWord64 k" <> int i <> text "[2] = " - <> pprFingerprint fp <> semi - $$ text "extern StgPtr " - <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi - $$ text "hs_spt_insert" <> parens - (hcat $ punctuate comma - [ char 'k' <> int i - , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n)) - ] - ) - <> semi - | (i, SptEntry n fp) <- zip [0..] entries - ] - , text "static void hs_spt_fini_" <> ppr this_mod - <> text "(void) __attribute__((destructor));" - , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)" - , braces $ vcat $ - [ text "StgWord64 k" <> int i <> text "[2] = " - <> pprFingerprint fp <> semi - $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi - | (i, (SptEntry _ fp)) <- zip [0..] entries - ] - ] - where - pprFingerprint :: Fingerprint -> SDoc - pprFingerprint (Fingerprint w1 w2) = - braces $ hcat $ punctuate comma - [ integer (fromIntegral w1) <> text "ULL" - , integer (fromIntegral w2) <> text "ULL" - ] diff --git a/main/SysTools.hs b/main/SysTools.hs deleted file mode 100644 --- a/main/SysTools.hs +++ /dev/null @@ -1,1794 +0,0 @@ -{- ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2001-2003 --- --- Access to system tools: gcc, cp, rm etc --- ------------------------------------------------------------------------------ --} - -{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-} - -module SysTools ( - -- Initialisation - initSysTools, - - -- Interface to system tools - runUnlit, runCpp, runCc, -- [Option] -> IO () - runPp, -- [Option] -> IO () - runSplit, -- [Option] -> IO () - runAs, runLink, runLibtool, -- [Option] -> IO () - runMkDLL, - runWindres, - runLlvmOpt, - runLlvmLlc, - runClang, - figureLlvmVersion, - - getLinkerInfo, - getCompilerInfo, - - linkDynLib, - - askLd, - - touch, -- String -> String -> IO () - copy, - copyWithHeader, - - -- Temporary-file management - setTmpDir, - newTempName, newTempLibName, - cleanTempDirs, cleanTempFiles, cleanTempFilesExcept, - addFilesToClean, - - Option(..), - - -- platform-specifics - libmLinkOpts, - - -- frameworks - getPkgFrameworkOpts, - getFrameworkOpts - - - ) where - -#include "HsVersions.h" - -import DriverPhases -import Module -import Packages -import Config -import Outputable -import ErrUtils -import Panic -import Platform -import Util -import DynFlags -import Exception - -import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion) - -import Data.IORef -import Control.Monad -import System.Exit -import System.Environment -import System.FilePath -import System.IO -import System.IO.Error as IO -import System.Directory -import Data.Char -import Data.List -import qualified Data.Map as Map -import qualified Data.Set as Set - -#ifndef mingw32_HOST_OS -import qualified System.Posix.Internals -#else /* Must be Win32 */ -import Foreign -import Foreign.C.String -#if MIN_VERSION_Win32(2,5,0) -import qualified System.Win32.Types as Win32 -#else -import qualified System.Win32.Info as Win32 -#endif -import System.Win32.Types (DWORD, LPTSTR, HANDLE) -import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE) -import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS ) -import System.Win32.DLL (loadLibrary, getProcAddress) -#endif - -import System.Process -import Control.Concurrent -import FastString -import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) - -#ifdef mingw32_HOST_OS -# if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -# else -# error Unknown mingw32 arch -# endif -#endif - -{- -How GHC finds its files -~~~~~~~~~~~~~~~~~~~~~~~ - -[Note topdir] - -GHC needs various support files (library packages, RTS etc), plus -various auxiliary programs (cp, gcc, etc). It starts by finding topdir, -the root of GHC's support files - -On Unix: - - ghc always has a shell wrapper that passes a -B option - -On Windows: - - ghc never has a shell wrapper. - - we can find the location of the ghc binary, which is - $topdir//.exe - where may be "ghc", "ghc-stage2", or similar - - we strip off the "/.exe" to leave $topdir. - -from topdir we can find package.conf, ghc-asm, etc. - - -SysTools.initSysProgs figures out exactly where all the auxiliary programs -are, and initialises mutable variables to make it easy to call them. -To to this, it makes use of definitions in Config.hs, which is a Haskell -file containing variables whose value is figured out by the build system. - -Config.hs contains two sorts of things - - cGCC, The *names* of the programs - cCPP e.g. cGCC = gcc - cUNLIT cCPP = gcc -E - etc They do *not* include paths - - - cUNLIT_DIR The *path* to the directory containing unlit, split etc - cSPLIT_DIR *relative* to the root of the build tree, - for use when running *in-place* in a build tree (only) - - - ---------------------------------------------- -NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): - -Another hair-brained scheme for simplifying the current tool location -nightmare in GHC: Simon originally suggested using another -configuration file along the lines of GCC's specs file - which is fine -except that it means adding code to read yet another configuration -file. What I didn't notice is that the current package.conf is -general enough to do this: - -Package - {name = "tools", import_dirs = [], source_dirs = [], - library_dirs = [], hs_libraries = [], extra_libraries = [], - include_dirs = [], c_includes = [], package_deps = [], - extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.], - extra_cc_opts = [], extra_ld_opts = []} - -Which would have the advantage that we get to collect together in one -place the path-specific package stuff with the path-specific tool -stuff. - End of NOTES ---------------------------------------------- - -************************************************************************ -* * -\subsection{Initialisation} -* * -************************************************************************ --} - -initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) - -> IO Settings -- Set all the mutable variables above, holding - -- (a) the system programs - -- (b) the package-config file - -- (c) the GHC usage message -initSysTools mbMinusB - = do top_dir <- findTopDir mbMinusB - -- see [Note topdir] - -- NB: top_dir is assumed to be in standard Unix - -- format, '/' separated - - let settingsFile = top_dir "settings" - platformConstantsFile = top_dir "platformConstants" - installed :: FilePath -> FilePath - installed file = top_dir file - libexec :: FilePath -> FilePath - libexec file = top_dir "bin" file - - settingsStr <- readFile settingsFile - platformConstantsStr <- readFile platformConstantsFile - mySettings <- case maybeReadFuzzy settingsStr of - Just s -> - return s - Nothing -> - pgmError ("Can't parse " ++ show settingsFile) - platformConstants <- case maybeReadFuzzy platformConstantsStr of - Just s -> - return s - Nothing -> - pgmError ("Can't parse " ++ - show platformConstantsFile) - let getSetting key = case lookup key mySettings of - Just xs -> - return $ case stripPrefix "$topdir" xs of - Just [] -> - top_dir - Just xs'@(c:_) - | isPathSeparator c -> - top_dir ++ xs' - _ -> - xs - Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) - getBooleanSetting key = case lookup key mySettings of - Just "YES" -> return True - Just "NO" -> return False - Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs) - Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) - readSetting key = case lookup key mySettings of - Just xs -> - case maybeRead xs of - Just v -> return v - Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs) - Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) - crossCompiling <- getBooleanSetting "cross compiling" - targetArch <- readSetting "target arch" - targetOS <- readSetting "target os" - targetWordSize <- readSetting "target word size" - targetUnregisterised <- getBooleanSetting "Unregisterised" - targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack" - targetHasIdentDirective <- readSetting "target has .ident directive" - targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols" - myExtraGccViaCFlags <- getSetting "GCC extra via C opts" - -- On Windows, mingw is distributed with GHC, - -- so we look in TopDir/../mingw/bin - -- It would perhaps be nice to be able to override this - -- with the settings file, but it would be a little fiddly - -- to make that possible, so for now you can't. - gcc_prog <- getSetting "C compiler command" - gcc_args_str <- getSetting "C compiler flags" - gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" - cpp_prog <- getSetting "Haskell CPP command" - cpp_args_str <- getSetting "Haskell CPP flags" - let unreg_gcc_args = if targetUnregisterised - then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] - else [] - -- TABLES_NEXT_TO_CODE affects the info table layout. - tntc_gcc_args - | mkTablesNextToCode targetUnregisterised - = ["-DTABLES_NEXT_TO_CODE"] - | otherwise = [] - cpp_args= map Option (words cpp_args_str) - gcc_args = map Option (words gcc_args_str - ++ unreg_gcc_args - ++ tntc_gcc_args) - ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" - ldSupportsBuildId <- getBooleanSetting "ld supports build-id" - ldSupportsFilelist <- getBooleanSetting "ld supports filelist" - ldIsGnuLd <- getBooleanSetting "ld is GNU ld" - perl_path <- getSetting "perl command" - - let pkgconfig_path = installed "package.conf.d" - ghc_usage_msg_path = installed "ghc-usage.txt" - ghci_usage_msg_path = installed "ghci-usage.txt" - - -- For all systems, unlit, split, mangle are GHC utilities - -- architecture-specific stuff is done when building Config.hs - unlit_path = libexec cGHC_UNLIT_PGM - - -- split is a Perl script - split_script = libexec cGHC_SPLIT_PGM - - windres_path <- getSetting "windres command" - libtool_path <- getSetting "libtool command" - - tmpdir <- getTemporaryDirectory - - touch_path <- getSetting "touch command" - - let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend - -- a call to Perl to get the invocation of split. - -- On Unix, scripts are invoked using the '#!' method. Binary - -- installations of GHC on Unix place the correct line on the - -- front of the script at installation time, so we don't want - -- to wire-in our knowledge of $(PERL) on the host system here. - (split_prog, split_args) - | isWindowsHost = (perl_path, [Option split_script]) - | otherwise = (split_script, []) - mkdll_prog <- getSetting "dllwrap command" - let mkdll_args = [] - - -- cpp is derived from gcc on all platforms - -- HACK, see setPgmP below. We keep 'words' here to remember to fix - -- Config.hs one day. - - - -- Other things being equal, as and ld are simply gcc - gcc_link_args_str <- getSetting "C compiler link flags" - let as_prog = gcc_prog - as_args = gcc_args - ld_prog = gcc_prog - ld_args = gcc_args ++ map Option (words gcc_link_args_str) - - -- We just assume on command line - lc_prog <- getSetting "LLVM llc command" - lo_prog <- getSetting "LLVM opt command" - - let iserv_prog = libexec "ghc-iserv" - - let platform = Platform { - platformArch = targetArch, - platformOS = targetOS, - platformWordSize = targetWordSize, - platformUnregisterised = targetUnregisterised, - platformHasGnuNonexecStack = targetHasGnuNonexecStack, - platformHasIdentDirective = targetHasIdentDirective, - platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols, - platformIsCrossCompiling = crossCompiling - } - - return $ Settings { - sTargetPlatform = platform, - sTmpDir = normalise tmpdir, - sGhcUsagePath = ghc_usage_msg_path, - sGhciUsagePath = ghci_usage_msg_path, - sTopDir = top_dir, - sRawSettings = mySettings, - sExtraGccViaCFlags = words myExtraGccViaCFlags, - sSystemPackageConfig = pkgconfig_path, - sLdSupportsCompactUnwind = ldSupportsCompactUnwind, - sLdSupportsBuildId = ldSupportsBuildId, - sLdSupportsFilelist = ldSupportsFilelist, - sLdIsGnuLd = ldIsGnuLd, - sGccSupportsNoPie = gccSupportsNoPie, - sProgramName = "ghc", - sProjectVersion = cProjectVersion, - sPgm_L = unlit_path, - sPgm_P = (cpp_prog, cpp_args), - sPgm_F = "", - sPgm_c = (gcc_prog, gcc_args), - sPgm_s = (split_prog,split_args), - sPgm_a = (as_prog, as_args), - sPgm_l = (ld_prog, ld_args), - sPgm_dll = (mkdll_prog,mkdll_args), - sPgm_T = touch_path, - sPgm_windres = windres_path, - sPgm_libtool = libtool_path, - sPgm_lo = (lo_prog,[]), - sPgm_lc = (lc_prog,[]), - sPgm_i = iserv_prog, - sOpt_L = [], - sOpt_P = [], - sOpt_F = [], - sOpt_c = [], - sOpt_a = [], - sOpt_l = [], - sOpt_windres = [], - sOpt_lo = [], - sOpt_lc = [], - sOpt_i = [], - sPlatformConstants = platformConstants - } - --- returns a Unix-format path (relying on getBaseDir to do so too) -findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). - -> IO String -- TopDir (in Unix format '/' separated) -findTopDir (Just minusb) = return (normalise minusb) -findTopDir Nothing - = do -- Get directory of executable - maybe_exec_dir <- getBaseDir - case maybe_exec_dir of - -- "Just" on Windows, "Nothing" on unix - Nothing -> throwGhcExceptionIO (InstallationError "missing -B option") - Just dir -> return dir - -{- -************************************************************************ -* * -\subsection{Running an external program} -* * -************************************************************************ --} - -runUnlit :: DynFlags -> [Option] -> IO () -runUnlit dflags args = do - let prog = pgm_L dflags - opts = getOpts dflags opt_L - runSomething dflags "Literate pre-processor" prog - (map Option opts ++ args) - -runCpp :: DynFlags -> [Option] -> IO () -runCpp dflags args = do - let (p,args0) = pgm_P dflags - args1 = map Option (getOpts dflags opt_P) - args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] - ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "C pre-processor" p - (args0 ++ args1 ++ args2 ++ args) mb_env - -runPp :: DynFlags -> [Option] -> IO () -runPp dflags args = do - let prog = pgm_F dflags - opts = map Option (getOpts dflags opt_F) - runSomething dflags "Haskell pre-processor" prog (args ++ opts) - -runCc :: DynFlags -> [Option] -> IO () -runCc dflags args = do - let (p,args0) = pgm_c dflags - args1 = map Option (getOpts dflags opt_c) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env - where - -- discard some harmless warnings from gcc that we can't turn off - cc_filter = unlines . doFilter . lines - - {- - gcc gives warnings in chunks like so: - In file included from /foo/bar/baz.h:11, - from /foo/bar/baz2.h:22, - from wibble.c:33: - /foo/flibble:14: global register variable ... - /foo/flibble:15: warning: call-clobbered r... - We break it up into its chunks, remove any call-clobbered register - warnings from each chunk, and then delete any chunks that we have - emptied of warnings. - -} - doFilter = unChunkWarnings . filterWarnings . chunkWarnings [] - -- We can't assume that the output will start with an "In file inc..." - -- line, so we start off expecting a list of warnings rather than a - -- location stack. - chunkWarnings :: [String] -- The location stack to use for the next - -- list of warnings - -> [String] -- The remaining lines to look at - -> [([String], [String])] - chunkWarnings loc_stack [] = [(loc_stack, [])] - chunkWarnings loc_stack xs - = case break loc_stack_start xs of - (warnings, lss:xs') -> - case span loc_start_continuation xs' of - (lsc, xs'') -> - (loc_stack, warnings) : chunkWarnings (lss : lsc) xs'' - _ -> [(loc_stack, xs)] - - filterWarnings :: [([String], [String])] -> [([String], [String])] - filterWarnings [] = [] - -- If the warnings are already empty then we are probably doing - -- something wrong, so don't delete anything - filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs - filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of - [] -> filterWarnings zs - ys' -> (xs, ys') : filterWarnings zs - - unChunkWarnings :: [([String], [String])] -> [String] - unChunkWarnings [] = [] - unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs - - loc_stack_start s = "In file included from " `isPrefixOf` s - loc_start_continuation s = " from " `isPrefixOf` s - wantedWarning w - | "warning: call-clobbered register used" `isContainedIn` w = False - | otherwise = True - -isContainedIn :: String -> String -> Bool -xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) - --- | Run the linker with some arguments and return the output -askLd :: DynFlags -> [Option] -> IO String -askLd dflags args = do - let (p,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingWith dflags "gcc" p args2 $ \real_args -> - readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } - --- Similar to System.Process.readCreateProcessWithExitCode, but stderr is --- inherited from the parent process, and output to stderr is not captured. -readCreateProcessWithExitCode' - :: CreateProcess - -> IO (ExitCode, String) -- ^ stdout -readCreateProcessWithExitCode' proc = do - (_, Just outh, _, pid) <- - createProcess proc{ std_out = CreatePipe } - - -- fork off a thread to start consuming the output - output <- hGetContents outh - outMVar <- newEmptyMVar - _ <- forkIO $ evaluate (length output) >> putMVar outMVar () - - -- wait on the output - takeMVar outMVar - hClose outh - - -- wait on the process - ex <- waitForProcess pid - - return (ex, output) - -replaceVar :: (String, String) -> [(String, String)] -> [(String, String)] -replaceVar (var, value) env = - (var, value) : filter (\(var',_) -> var /= var') env - --- | Version of @System.Process.readProcessWithExitCode@ that takes a --- key-value tuple to insert into the environment. -readProcessEnvWithExitCode - :: String -- ^ program path - -> [String] -- ^ program args - -> (String, String) -- ^ addition to the environment - -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) -readProcessEnvWithExitCode prog args env_update = do - current_env <- getEnvironment - readCreateProcessWithExitCode (proc prog args) { - env = Just (replaceVar env_update current_env) } "" - --- Don't let gcc localize version info string, #8825 -c_locale_env :: (String, String) -c_locale_env = ("LANGUAGE", "C") - --- If the -B option is set, add to PATH. This works around --- a bug in gcc on Windows Vista where it can't find its auxiliary --- binaries (see bug #1110). -getGccEnv :: [Option] -> IO (Maybe [(String,String)]) -getGccEnv opts = - if null b_dirs - then return Nothing - else do env <- getEnvironment - return (Just (map mangle_path env)) - where - (b_dirs, _) = partitionWith get_b_opt opts - - get_b_opt (Option ('-':'B':dir)) = Left dir - get_b_opt other = Right other - - mangle_path (path,paths) | map toUpper path == "PATH" - = (path, '\"' : head b_dirs ++ "\";" ++ paths) - mangle_path other = other - -runSplit :: DynFlags -> [Option] -> IO () -runSplit dflags args = do - let (p,args0) = pgm_s dflags - runSomething dflags "Splitter" p (args0++args) - -runAs :: DynFlags -> [Option] -> IO () -runAs dflags args = do - let (p,args0) = pgm_a dflags - args1 = map Option (getOpts dflags opt_a) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Assembler" p args2 mb_env - --- | Run the LLVM Optimiser -runLlvmOpt :: DynFlags -> [Option] -> IO () -runLlvmOpt dflags args = do - let (p,args0) = pgm_lo dflags - args1 = map Option (getOpts dflags opt_lo) - runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args) - --- | Run the LLVM Compiler -runLlvmLlc :: DynFlags -> [Option] -> IO () -runLlvmLlc dflags args = do - let (p,args0) = pgm_lc dflags - args1 = map Option (getOpts dflags opt_lc) - runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) - --- | Run the clang compiler (used as an assembler for the LLVM --- backend on OS X as LLVM doesn't support the OS X system --- assembler) -runClang :: DynFlags -> [Option] -> IO () -runClang dflags args = do - -- we simply assume its available on the PATH - let clang = "clang" - -- be careful what options we call clang with - -- see #5903 and #7617 for bugs caused by this. - (_,args0) = pgm_a dflags - args1 = map Option (getOpts dflags opt_a) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - Exception.catch (do - runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env - ) - (\(err :: SomeException) -> do - errorMsg dflags $ - text ("Error running clang! you need clang installed to use the" ++ - " LLVM backend") $+$ - text "(or GHC tried to execute clang incorrectly)" - throwIO err - ) - --- | Figure out which version of LLVM we are running this session -figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int)) -figureLlvmVersion dflags = do - let (pgm,opts) = pgm_lc dflags - args = filter notNull (map showOpt opts) - -- we grab the args even though they should be useless just in - -- case the user is using a customised 'llc' that requires some - -- of the options they've specified. llc doesn't care what other - -- options are specified when '-version' is used. - args' = args ++ ["-version"] - ver <- catchIO (do - (pin, pout, perr, _) <- runInteractiveProcess pgm args' - Nothing Nothing - {- > llc -version - LLVM (http://llvm.org/): - LLVM version 3.5.2 - ... - -} - hSetBinaryMode pout False - _ <- hGetLine pout - vline <- dropWhile (not . isDigit) `fmap` hGetLine pout - v <- case span (/= '.') vline of - ("",_) -> fail "no digits!" - (x,y) -> return (read x - , read $ takeWhile isDigit $ drop 1 y) - - hClose pin - hClose pout - hClose perr - return $ Just v - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out LLVM version):" <+> - text (show err)) - errorMsg dflags $ vcat - [ text "Warning:", nest 9 $ - text "Couldn't figure out LLVM version!" $$ - text ("Make sure you have installed LLVM " ++ - llvmVersionStr supportedLlvmVersion) ] - return Nothing) - return ver - -{- Note [Windows stack usage] - -See: Trac #8870 (and #8834 for related info) and #12186 - -On Windows, occasionally we need to grow the stack. In order to do -this, we would normally just bump the stack pointer - but there's a -catch on Windows. - -If the stack pointer is bumped by more than a single page, then the -pages between the initial pointer and the resulting location must be -properly committed by the Windows virtual memory subsystem. This is -only needed in the event we bump by more than one page (i.e 4097 bytes -or more). - -Windows compilers solve this by emitting a call to a special function -called _chkstk, which does this committing of the pages for you. - -The reason this was causing a segfault was because due to the fact the -new code generator tends to generate larger functions, we needed more -stack space in GHC itself. In the x86 codegen, we needed approximately -~12kb of stack space in one go, which caused the process to segfault, -as the intervening pages were not committed. - -GCC can emit such a check for us automatically but only when the flag --fstack-check is used. - -See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html -for more information. - --} - -{- Note [Run-time linker info] - -See also: Trac #5240, Trac #6063, Trac #10110 - -Before 'runLink', we need to be sure to get the relevant information -about the linker we're using at runtime to see if we need any extra -options. For example, GNU ld requires '--reduce-memory-overheads' and -'--hash-size=31' in order to use reasonable amounts of memory (see -trac #5240.) But this isn't supported in GNU gold. - -Generally, the linker changing from what was detected at ./configure -time has always been possible using -pgml, but on Linux it can happen -'transparently' by installing packages like binutils-gold, which -change what /usr/bin/ld actually points to. - -Clang vs GCC notes: - -For gcc, 'gcc -Wl,--version' gives a bunch of output about how to -invoke the linker before the version information string. For 'clang', -the version information for 'ld' is all that's output. For this -reason, we typically need to slurp up all of the standard error output -and look through it. - -Other notes: - -We cache the LinkerInfo inside DynFlags, since clients may link -multiple times. The definition of LinkerInfo is there to avoid a -circular dependency. - --} - -{- Note [ELF needed shared libs] - -Some distributions change the link editor's default handling of -ELF DT_NEEDED tags to include only those shared objects that are -needed to resolve undefined symbols. For Template Haskell we need -the last temporary shared library also if it is not needed for the -currently linked temporary shared library. We specify --no-as-needed -to override the default. This flag exists in GNU ld and GNU gold. - -The flag is only needed on ELF systems. On Windows (PE) and Mac OS X -(Mach-O) the flag is not needed. - --} - -{- Note [Windows static libGCC] - -The GCC versions being upgraded to in #10726 are configured with -dynamic linking of libgcc supported. This results in libgcc being -linked dynamically when a shared library is created. - -This introduces thus an extra dependency on GCC dll that was not -needed before by shared libraries created with GHC. This is a particular -issue on Windows because you get a non-obvious error due to this missing -dependency. This dependent dll is also not commonly on your path. - -For this reason using the static libgcc is preferred as it preserves -the same behaviour that existed before. There are however some very good -reasons to have the shared version as well as described on page 181 of -https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf : - -"There are several situations in which an application should use the - shared ‘libgcc’ instead of the static version. The most common of these - is when the application wishes to throw and catch exceptions across different - shared libraries. In that case, each of the libraries as well as the application - itself should use the shared ‘libgcc’. " - --} - -neededLinkArgs :: LinkerInfo -> [Option] -neededLinkArgs (GnuLD o) = o -neededLinkArgs (GnuGold o) = o -neededLinkArgs (DarwinLD o) = o -neededLinkArgs (SolarisLD o) = o -neededLinkArgs (AixLD o) = o -neededLinkArgs UnknownLD = [] - --- Grab linker info and cache it in DynFlags. -getLinkerInfo :: DynFlags -> IO LinkerInfo -getLinkerInfo dflags = do - info <- readIORef (rtldInfo dflags) - case info of - Just v -> return v - Nothing -> do - v <- getLinkerInfo' dflags - writeIORef (rtldInfo dflags) (Just v) - return v - --- See Note [Run-time linker info]. -getLinkerInfo' :: DynFlags -> IO LinkerInfo -getLinkerInfo' dflags = do - let platform = targetPlatform dflags - os = platformOS platform - (pgm,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 - args3 = filter notNull (map showOpt args2) - - -- Try to grab the info from the process output. - parseLinkerInfo stdo _stde _exitc - | any ("GNU ld" `isPrefixOf`) stdo = - -- GNU ld specifically needs to use less memory. This especially - -- hurts on small object files. Trac #5240. - -- Set DT_NEEDED for all shared libraries. Trac #10110. - -- TODO: Investigate if these help or hurt when using split sections. - return (GnuLD $ map Option ["-Wl,--hash-size=31", - "-Wl,--reduce-memory-overheads", - -- ELF specific flag - -- see Note [ELF needed shared libs] - "-Wl,--no-as-needed"]) - - | any ("GNU gold" `isPrefixOf`) stdo = - -- GNU gold only needs --no-as-needed. Trac #10110. - -- ELF specific flag, see Note [ELF needed shared libs] - return (GnuGold [Option "-Wl,--no-as-needed"]) - - -- Unknown linker. - | otherwise = fail "invalid --version output, or linker is unsupported" - - -- Process the executable call - info <- catchIO (do - case os of - OSSolaris2 -> - -- Solaris uses its own Solaris linker. Even all - -- GNU C are recommended to configure with Solaris - -- linker instead of using GNU binutils linker. Also - -- all GCC distributed with Solaris follows this rule - -- precisely so we assume here, the Solaris linker is - -- used. - return $ SolarisLD [] - OSAIX -> - -- IBM AIX uses its own non-binutils linker as well - return $ AixLD [] - OSDarwin -> - -- Darwin has neither GNU Gold or GNU LD, but a strange linker - -- that doesn't support --version. We can just assume that's - -- what we're using. - return $ DarwinLD [] - OSiOS -> - -- Ditto for iOS - return $ DarwinLD [] - OSMinGW32 -> - -- GHC doesn't support anything but GNU ld on Windows anyway. - -- Process creation is also fairly expensive on win32, so - -- we short-circuit here. - return $ GnuLD $ map Option - [ -- Reduce ld memory usage - "-Wl,--hash-size=31" - , "-Wl,--reduce-memory-overheads" - -- Emit gcc stack checks - -- Note [Windows stack usage] - , "-fstack-check" - -- Force static linking of libGCC - -- Note [Windows static libGCC] - , "-static-libgcc" ] - _ -> do - -- In practice, we use the compiler as the linker here. Pass - -- -Wl,--version to get linker version info. - (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm - (["-Wl,--version"] ++ args3) - c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. In particular, 'clang' and 'gcc' - -- have slightly different outputs for '-Wl,--version', but - -- it's still easy to figure out. - parseLinkerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out linker information):" <+> - text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ - text "Couldn't figure out linker information!" $$ - text "Make sure you're using GNU ld, GNU gold" <+> - text "or the built in OS X linker, etc." - return UnknownLD) - return info - --- Grab compiler info and cache it in DynFlags. -getCompilerInfo :: DynFlags -> IO CompilerInfo -getCompilerInfo dflags = do - info <- readIORef (rtccInfo dflags) - case info of - Just v -> return v - Nothing -> do - v <- getCompilerInfo' dflags - writeIORef (rtccInfo dflags) (Just v) - return v - --- See Note [Run-time linker info]. -getCompilerInfo' :: DynFlags -> IO CompilerInfo -getCompilerInfo' dflags = do - let (pgm,_) = pgm_c dflags - -- Try to grab the info from the process output. - parseCompilerInfo _stdo stde _exitc - -- Regular GCC - | any ("gcc version" `isInfixOf`) stde = - return GCC - -- Regular clang - | any ("clang version" `isInfixOf`) stde = - return Clang - -- XCode 5.1 clang - | any ("Apple LLVM version 5.1" `isPrefixOf`) stde = - return AppleClang51 - -- XCode 5 clang - | any ("Apple LLVM version" `isPrefixOf`) stde = - return AppleClang - -- XCode 4.1 clang - | any ("Apple clang version" `isPrefixOf`) stde = - return AppleClang - -- Unknown linker. - | otherwise = fail "invalid -v output, or compiler is unsupported" - - -- Process the executable call - info <- catchIO (do - (exitc, stdo, stde) <- - readProcessEnvWithExitCode pgm ["-v"] c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. - parseCompilerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out C compiler information):" <+> - text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ - text "Couldn't figure out C compiler information!" $$ - text "Make sure you're using GNU gcc, or clang" - return UnknownCC) - return info - -runLink :: DynFlags -> [Option] -> IO () -runLink dflags args = do - -- See Note [Run-time linker info] - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags - let (p,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ linkargs ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env - where - ld_filter = case (platformOS (targetPlatform dflags)) of - OSSolaris2 -> sunos_ld_filter - _ -> id -{- - SunOS/Solaris ld emits harmless warning messages about unresolved - symbols in case of compiling into shared library when we do not - link against all the required libs. That is the case of GHC which - does not link against RTS library explicitly in order to be able to - choose the library later based on binary application linking - parameters. The warnings look like: - -Undefined first referenced - symbol in file -stg_ap_n_fast ./T2386_Lib.o -stg_upd_frame_info ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o -newCAF ./T2386_Lib.o -stg_bh_upd_frame_info ./T2386_Lib.o -stg_ap_ppp_fast ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o -stg_ap_p_fast ./T2386_Lib.o -stg_ap_pp_fast ./T2386_Lib.o -ld: warning: symbol referencing errors - - this is actually coming from T2386 testcase. The emitting of those - warnings is also a reason why so many TH testcases fail on Solaris. - - Following filter code is SunOS/Solaris linker specific and should - filter out only linker warnings. Please note that the logic is a - little bit more complex due to the simple reason that we need to preserve - any other linker emitted messages. If there are any. Simply speaking - if we see "Undefined" and later "ld: warning:..." then we omit all - text between (including) the marks. Otherwise we copy the whole output. --} - sunos_ld_filter :: String -> String - sunos_ld_filter = unlines . sunos_ld_filter' . lines - sunos_ld_filter' x = if (undefined_found x && ld_warning_found x) - then (ld_prefix x) ++ (ld_postfix x) - else x - breakStartsWith x y = break (isPrefixOf x) y - ld_prefix = fst . breakStartsWith "Undefined" - undefined_found = not . null . snd . breakStartsWith "Undefined" - ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" - ld_postfix = tail . snd . ld_warn_break - ld_warning_found = not . null . snd . ld_warn_break - - -runLibtool :: DynFlags -> [Option] -> IO () -runLibtool dflags args = do - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags - let args1 = map Option (getOpts dflags opt_l) - args2 = [Option "-static"] ++ args1 ++ args ++ linkargs - libtool = pgm_libtool dflags - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Linker" libtool args2 mb_env - -runMkDLL :: DynFlags -> [Option] -> IO () -runMkDLL dflags args = do - let (p,args0) = pgm_dll dflags - args1 = args0 ++ args - mb_env <- getGccEnv (args0++args) - runSomethingFiltered dflags id "Make DLL" p args1 mb_env - -runWindres :: DynFlags -> [Option] -> IO () -runWindres dflags args = do - let (gcc, gcc_args) = pgm_c dflags - windres = pgm_windres dflags - opts = map Option (getOpts dflags opt_windres) - quote x = "\"" ++ x ++ "\"" - args' = -- If windres.exe and gcc.exe are in a directory containing - -- spaces then windres fails to run gcc. We therefore need - -- to tell it what command to use... - Option ("--preprocessor=" ++ - unwords (map quote (gcc : - map showOpt gcc_args ++ - map showOpt opts ++ - ["-E", "-xc", "-DRC_INVOKED"]))) - -- ...but if we do that then if windres calls popen then - -- it can't understand the quoting, so we have to use - -- --use-temp-file so that it interprets it correctly. - -- See #1828. - : Option "--use-temp-file" - : args - mb_env <- getGccEnv gcc_args - runSomethingFiltered dflags id "Windres" windres args' mb_env - -touch :: DynFlags -> String -> String -> IO () -touch dflags purpose arg = - runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] - -copy :: DynFlags -> String -> FilePath -> FilePath -> IO () -copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to - -copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath - -> IO () -copyWithHeader dflags purpose maybe_header from to = do - showPass dflags purpose - - hout <- openBinaryFile to WriteMode - hin <- openBinaryFile from ReadMode - ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up - maybe (return ()) (header hout) maybe_header - hPutStr hout ls - hClose hout - hClose hin - where - -- write the header string in UTF-8. The header is something like - -- {-# LINE "foo.hs" #-} - -- and we want to make sure a Unicode filename isn't mangled. - header h str = do - hSetEncoding h utf8 - hPutStr h str - hSetBinaryMode h True - - - -{- -************************************************************************ -* * -\subsection{Managing temporary files -* * -************************************************************************ --} - -cleanTempDirs :: DynFlags -> IO () -cleanTempDirs dflags - = unless (gopt Opt_KeepTmpFiles dflags) - $ mask_ - $ do let ref = dirsToClean dflags - ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) - removeTmpDirs dflags (Map.elems ds) - -cleanTempFiles :: DynFlags -> IO () -cleanTempFiles dflags - = unless (gopt Opt_KeepTmpFiles dflags) - $ mask_ - $ do let ref = filesToClean dflags - fs <- atomicModifyIORef' ref $ \fs -> ([],fs) - removeTmpFiles dflags fs - -cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO () -cleanTempFilesExcept dflags dont_delete - = unless (gopt Opt_KeepTmpFiles dflags) - $ mask_ - $ do let ref = filesToClean dflags - to_delete <- atomicModifyIORef' ref $ \files -> - let res@(_to_keep, _to_delete) = - partition (`Set.member` dont_delete_set) files - in res - removeTmpFiles dflags to_delete - where dont_delete_set = Set.fromList dont_delete - - --- Return a unique numeric temp file suffix -newTempSuffix :: DynFlags -> IO Int -newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n) - --- Find a temporary name that doesn't already exist. -newTempName :: DynFlags -> Suffix -> IO FilePath -newTempName dflags extn - = do d <- getTempDir dflags - findTempName (d "ghc_") -- See Note [Deterministic base name] - where - findTempName :: FilePath -> IO FilePath - findTempName prefix - = do n <- newTempSuffix dflags - let filename = prefix ++ show n <.> extn - b <- doesFileExist filename - if b then findTempName prefix - else do -- clean it up later - consIORef (filesToClean dflags) filename - return filename - -newTempLibName :: DynFlags -> Suffix -> IO (FilePath, FilePath, String) -newTempLibName dflags extn - = do d <- getTempDir dflags - findTempName d ("ghc_") - where - findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) - findTempName dir prefix - = do n <- newTempSuffix dflags -- See Note [Deterministic base name] - let libname = prefix ++ show n - filename = dir "lib" ++ libname <.> extn - b <- doesFileExist filename - if b then findTempName dir prefix - else do -- clean it up later - consIORef (filesToClean dflags) filename - return (filename, dir, libname) - - --- Return our temporary directory within tmp_dir, creating one if we --- don't have one yet. -getTempDir :: DynFlags -> IO FilePath -getTempDir dflags = do - mapping <- readIORef dir_ref - case Map.lookup tmp_dir mapping of - Nothing -> do - pid <- getProcessID - let prefix = tmp_dir "ghc" ++ show pid ++ "_" - mask_ $ mkTempDir prefix - Just dir -> return dir - where - tmp_dir = tmpDir dflags - dir_ref = dirsToClean dflags - - mkTempDir :: FilePath -> IO FilePath - mkTempDir prefix = do - n <- newTempSuffix dflags - let our_dir = prefix ++ show n - - -- 1. Speculatively create our new directory. - createDirectory our_dir - - -- 2. Update the dirsToClean mapping unless an entry already exists - -- (i.e. unless another thread beat us to it). - their_dir <- atomicModifyIORef' dir_ref $ \mapping -> - case Map.lookup tmp_dir mapping of - Just dir -> (mapping, Just dir) - Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing) - - -- 3. If there was an existing entry, return it and delete the - -- directory we created. Otherwise return the directory we created. - case their_dir of - Nothing -> do - debugTraceMsg dflags 2 $ - text "Created temporary directory:" <+> text our_dir - return our_dir - Just dir -> do - removeDirectory our_dir - return dir - `catchIO` \e -> if isAlreadyExistsError e - then mkTempDir prefix else ioError e - --- Note [Deterministic base name] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- The filename of temporary files, especially the basename of C files, can end --- up in the output in some form, e.g. as part of linker debug information. In the --- interest of bit-wise exactly reproducible compilation (#4012), the basename of --- the temporary file no longer contains random information (it used to contain --- the process id). --- --- This is ok, as the temporary directory used contains the pid (see getTempDir). - -addFilesToClean :: DynFlags -> [FilePath] -> IO () --- May include wildcards [used by DriverPipeline.run_phase SplitMangle] -addFilesToClean dflags new_files - = atomicModifyIORef' (filesToClean dflags) $ \files -> (new_files++files, ()) - -removeTmpDirs :: DynFlags -> [FilePath] -> IO () -removeTmpDirs dflags ds - = traceCmd dflags "Deleting temp dirs" - ("Deleting: " ++ unwords ds) - (mapM_ (removeWith dflags removeDirectory) ds) - -removeTmpFiles :: DynFlags -> [FilePath] -> IO () -removeTmpFiles dflags fs - = warnNon $ - traceCmd dflags "Deleting temp files" - ("Deleting: " ++ unwords deletees) - (mapM_ (removeWith dflags removeFile) deletees) - where - -- Flat out refuse to delete files that are likely to be source input - -- files (is there a worse bug than having a compiler delete your source - -- files?) - -- - -- Deleting source files is a sign of a bug elsewhere, so prominently flag - -- the condition. - warnNon act - | null non_deletees = act - | otherwise = do - putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees)) - act - - (non_deletees, deletees) = partition isHaskellUserSrcFilename fs - -removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () -removeWith dflags remover f = remover f `catchIO` - (\e -> - let msg = if isDoesNotExistError e - then text "Warning: deleting non-existent" <+> text f - else text "Warning: exception raised when deleting" - <+> text f <> colon - $$ text (show e) - in debugTraceMsg dflags 2 msg - ) - ------------------------------------------------------------------------------ --- Running an external program - -runSomething :: DynFlags - -> String -- For -v message - -> String -- Command name (possibly a full path) - -- assumed already dos-ified - -> [Option] -- Arguments - -- runSomething will dos-ify them - -> IO () - -runSomething dflags phase_name pgm args = - runSomethingFiltered dflags id phase_name pgm args Nothing - --- | Run a command, placing the arguments in an external response file. --- --- This command is used in order to avoid overlong command line arguments on --- Windows. The command line arguments are first written to an external, --- temporary response file, and then passed to the linker via @filepath. --- response files for passing them in. See: --- --- https://gcc.gnu.org/wiki/Response_Files --- https://ghc.haskell.org/trac/ghc/ticket/10777 -runSomethingResponseFile - :: DynFlags -> (String->String) -> String -> String -> [Option] - -> Maybe [(String,String)] -> IO () - -runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = - runSomethingWith dflags phase_name pgm args $ \real_args -> do - fp <- getResponseFile real_args - let args = ['@':fp] - r <- builderMainLoop dflags filter_fn pgm args mb_env - return (r,()) - where - getResponseFile args = do - fp <- newTempName dflags "rsp" - withFile fp WriteMode $ \h -> do -#if defined(mingw32_HOST_OS) - hSetEncoding h latin1 -#else - hSetEncoding h utf8 -#endif - hPutStr h $ unlines $ map escape args - return fp - - -- Note: Response files have backslash-escaping, double quoting, and are - -- whitespace separated (some implementations use newline, others any - -- whitespace character). Therefore, escape any backslashes, newlines, and - -- double quotes in the argument, and surround the content with double - -- quotes. - -- - -- Another possibility that could be considered would be to convert - -- backslashes in the argument to forward slashes. This would generally do - -- the right thing, since backslashes in general only appear in arguments - -- as part of file paths on Windows, and the forward slash is accepted for - -- those. However, escaping is more reliable, in case somehow a backslash - -- appears in a non-file. - escape x = concat - [ "\"" - , concatMap - (\c -> - case c of - '\\' -> "\\\\" - '\n' -> "\\n" - '\"' -> "\\\"" - _ -> [c]) - x - , "\"" - ] - -runSomethingFiltered - :: DynFlags -> (String->String) -> String -> String -> [Option] - -> Maybe [(String,String)] -> IO () - -runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do - runSomethingWith dflags phase_name pgm args $ \real_args -> do - r <- builderMainLoop dflags filter_fn pgm real_args mb_env - return (r,()) - -runSomethingWith - :: DynFlags -> String -> String -> [Option] - -> ([String] -> IO (ExitCode, a)) - -> IO a - -runSomethingWith dflags phase_name pgm args io = do - let real_args = filter notNull (map showOpt args) - cmdLine = showCommandForUser pgm real_args - traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args - -handleProc :: String -> String -> IO (ExitCode, r) -> IO r -handleProc pgm phase_name proc = do - (rc, r) <- proc `catchIO` handler - case rc of - ExitSuccess{} -> return r - ExitFailure n -> throwGhcExceptionIO ( - ProgramError ("`" ++ takeFileName pgm ++ "'" ++ - " failed in phase `" ++ phase_name ++ "'." ++ - " (Exit code: " ++ show n ++ ")")) - where - handler err = - if IO.isDoesNotExistError err - then does_not_exist - else throwGhcExceptionIO (ProgramError $ show err) - - does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) - - -builderMainLoop :: DynFlags -> (String -> String) -> FilePath - -> [String] -> Maybe [(String, String)] - -> IO ExitCode -builderMainLoop dflags filter_fn pgm real_args mb_env = do - chan <- newChan - (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env - - -- and run a loop piping the output from the compiler to the log_action in DynFlags - hSetBuffering hStdOut LineBuffering - hSetBuffering hStdErr LineBuffering - _ <- forkIO (readerProc chan hStdOut filter_fn) - _ <- forkIO (readerProc chan hStdErr filter_fn) - -- we don't want to finish until 2 streams have been completed - -- (stdout and stderr) - -- nor until 1 exit code has been retrieved. - rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess - -- after that, we're done here. - hClose hStdIn - hClose hStdOut - hClose hStdErr - return rc - where - -- status starts at zero, and increments each time either - -- a reader process gets EOF, or the build proc exits. We wait - -- for all of these to happen (status==3). - -- ToDo: we should really have a contingency plan in case any of - -- the threads dies, such as a timeout. - loop _ _ 0 0 exitcode = return exitcode - loop chan hProcess t p exitcode = do - mb_code <- if p > 0 - then getProcessExitCode hProcess - else return Nothing - case mb_code of - Just code -> loop chan hProcess t (p-1) code - Nothing - | t > 0 -> do - msg <- readChan chan - case msg of - BuildMsg msg -> do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) msg - loop chan hProcess t p exitcode - BuildError loc msg -> do - putLogMsg dflags NoReason SevError (mkSrcSpan loc loc) - (defaultUserStyle dflags) msg - loop chan hProcess t p exitcode - EOF -> - loop chan hProcess (t-1) p exitcode - | otherwise -> loop chan hProcess t p exitcode - -readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO () -readerProc chan hdl filter_fn = - (do str <- hGetContents hdl - loop (linesPlatform (filter_fn str)) Nothing) - `finally` - writeChan chan EOF - -- ToDo: check errors more carefully - -- ToDo: in the future, the filter should be implemented as - -- a stream transformer. - where - loop [] Nothing = return () - loop [] (Just err) = writeChan chan err - loop (l:ls) in_err = - case in_err of - Just err@(BuildError srcLoc msg) - | leading_whitespace l -> do - loop ls (Just (BuildError srcLoc (msg $$ text l))) - | otherwise -> do - writeChan chan err - checkError l ls - Nothing -> do - checkError l ls - _ -> panic "readerProc/loop" - - checkError l ls - = case parseError l of - Nothing -> do - writeChan chan (BuildMsg (text l)) - loop ls Nothing - Just (file, lineNum, colNum, msg) -> do - let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum - loop ls (Just (BuildError srcLoc (text msg))) - - leading_whitespace [] = False - leading_whitespace (x:_) = isSpace x - -parseError :: String -> Maybe (String, Int, Int, String) -parseError s0 = case breakColon s0 of - Just (filename, s1) -> - case breakIntColon s1 of - Just (lineNum, s2) -> - case breakIntColon s2 of - Just (columnNum, s3) -> - Just (filename, lineNum, columnNum, s3) - Nothing -> - Just (filename, lineNum, 0, s2) - Nothing -> Nothing - Nothing -> Nothing - -breakColon :: String -> Maybe (String, String) -breakColon xs = case break (':' ==) xs of - (ys, _:zs) -> Just (ys, zs) - _ -> Nothing - -breakIntColon :: String -> Maybe (Int, String) -breakIntColon xs = case break (':' ==) xs of - (ys, _:zs) - | not (null ys) && all isAscii ys && all isDigit ys -> - Just (read ys, zs) - _ -> Nothing - -data BuildMessage - = BuildMsg !SDoc - | BuildError !SrcLoc !SDoc - | EOF - -traceCmd :: DynFlags -> String -> String -> IO a -> IO a --- trace the command (at two levels of verbosity) -traceCmd dflags phase_name cmd_line action - = do { let verb = verbosity dflags - ; showPass dflags phase_name - ; debugTraceMsg dflags 3 (text cmd_line) - ; case flushErr dflags of - FlushErr io -> io - - -- And run it! - ; action `catchIO` handle_exn verb - } - where - handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') - ; debugTraceMsg dflags 2 (text "Failed:" <+> text cmd_line <+> text (show exn)) - ; throwGhcExceptionIO (ProgramError (show exn))} - -{- -************************************************************************ -* * -\subsection{Support code} -* * -************************************************************************ --} - ------------------------------------------------------------------------------ --- Define getBaseDir :: IO (Maybe String) - -getBaseDir :: IO (Maybe String) -#if defined(mingw32_HOST_OS) --- Assuming we are running ghc, accessed by path $(stuff)//ghc.exe, --- return the path $(stuff)/lib. -getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. - where - try_size size = allocaArray (fromIntegral size) $ \buf -> do - ret <- c_GetModuleFileName nullPtr buf size - case ret of - 0 -> return Nothing - _ | ret < size -> do - path <- peekCWString buf - real <- getFinalPath path -- try to resolve symlinks paths - let libdir = (rootDir . sanitize . maybe path id) real - exists <- doesDirectoryExist libdir - if exists - then return $ Just libdir - else fail path - | otherwise -> try_size (size * 2) - - -- getFinalPath returns paths in full raw form. - -- Unfortunately GHC isn't set up to handle these - -- So if the call succeeded, we need to drop the - -- \\?\ prefix. - sanitize s = if "\\\\?\\" `isPrefixOf` s - then drop 4 s - else s - - rootDir s = case splitFileName $ normalise s of - (d, ghc_exe) - | lower ghc_exe `elem` ["ghc.exe", - "ghc-stage1.exe", - "ghc-stage2.exe", - "ghc-stage3.exe"] -> - case splitFileName $ takeDirectory d of - -- ghc is in $topdir/bin/ghc.exe - (d', _) -> takeDirectory d' "lib" - _ -> fail s - - fail s = panic ("can't decompose ghc.exe path: " ++ show s) - lower = map toLower - -foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" - c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 - --- Attempt to resolve symlinks in order to find the actual location GHC --- is located at. See Trac #11759. -getFinalPath :: FilePath -> IO (Maybe FilePath) -getFinalPath name = do - dllHwnd <- failIfNull "LoadLibray" $ loadLibrary "kernel32.dll" - -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista. - -- This means that we can't bind directly to it since it may be missing. - -- Instead try to find it's address at runtime and if we don't succeed consider the - -- function failed. - addr_m <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW") - `catch` (\(_ :: SomeException) -> return Nothing) - case addr_m of - Nothing -> return Nothing - Just addr -> do handle <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile" - $ createFile name - gENERIC_READ - fILE_SHARE_READ - Nothing - oPEN_EXISTING - (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS) - Nothing - let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr - -- First try to resolve the path to get the actual path - -- of any symlinks or other file system redirections that - -- may be in place. However this function can fail, and in - -- the event it does fail, we need to try using the - -- original path and see if we can decompose that. - -- If the call fails Win32.try will raise an exception - -- that needs to be caught. See #14159 - path <- (Win32.try "GetFinalPathName" - (\buf len -> fnPtr handle buf len 0) 512 - `finally` closeHandle handle) - `catch` - (\(_ :: IOException) -> return name) - return $ Just path - -type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD - -foreign import WINDOWS_CCONV unsafe "dynamic" - makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath -#else -getBaseDir = return Nothing -#endif - -#ifdef mingw32_HOST_OS -foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows -#else -getProcessID :: IO Int -getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral -#endif - --- Divvy up text stream into lines, taking platform dependent --- line termination into account. -linesPlatform :: String -> [String] -#if !defined(mingw32_HOST_OS) -linesPlatform ls = lines ls -#else -linesPlatform "" = [] -linesPlatform xs = - case lineBreak xs of - (as,xs1) -> as : linesPlatform xs1 - where - lineBreak "" = ("","") - lineBreak ('\r':'\n':xs) = ([],xs) - lineBreak ('\n':xs) = ([],xs) - lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs) - -#endif - -linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () -linkDynLib dflags0 o_files dep_packages - = do - let -- This is a rather ugly hack to fix dynamically linked - -- GHC on Windows. If GHC is linked with -threaded, then - -- it links against libHSrts_thr. But if base is linked - -- against libHSrts, then both end up getting loaded, - -- and things go wrong. We therefore link the libraries - -- with the same RTS flags that we link GHC with. - dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0 - else dflags0 - dflags2 = if cGhcDebugged then addWay' WayDebug dflags1 - else dflags1 - dflags = updateWays dflags2 - - verbFlags = getVerbFlags dflags - o_file = outputFile dflags - - pkgs <- getPreloadPackagesAnd dflags dep_packages - - let pkg_lib_paths = collectLibraryPaths dflags pkgs - let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths - get_pkg_lib_path_opts l - | ( osElfTarget (platformOS (targetPlatform dflags)) || - osMachOTarget (platformOS (targetPlatform dflags)) ) && - dynLibLoader dflags == SystemDependent && - WayDyn `elem` ways dflags - = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l] - -- See Note [-Xlinker -rpath vs -Wl,-rpath] - | otherwise = ["-L" ++ l] - - let lib_paths = libraryPaths dflags - let lib_path_opts = map ("-L"++) lib_paths - - -- We don't want to link our dynamic libs against the RTS package, - -- because the RTS lib comes in several flavours and we want to be - -- able to pick the flavour when a binary is linked. - -- On Windows we need to link the RTS import lib as Windows does - -- not allow undefined symbols. - -- The RTS library path is still added to the library search path - -- above in case the RTS is being explicitly linked in (see #3807). - let platform = targetPlatform dflags - os = platformOS platform - pkgs_no_rts = case os of - OSMinGW32 -> - pkgs - _ -> - filter ((/= rtsUnitId) . packageConfigId) pkgs - let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts - in package_hs_libs ++ extra_libs ++ other_flags - - -- probably _stub.o files - -- and last temporary shared object file - let extra_ld_inputs = ldInputs dflags - - -- frameworks - pkg_framework_opts <- getPkgFrameworkOpts dflags platform - (map unitId pkgs) - let framework_opts = getFrameworkOpts dflags platform - - case os of - OSMinGW32 -> do - ------------------------------------------------------------- - -- Making a DLL - ------------------------------------------------------------- - let output_fn = case o_file of - Just s -> s - Nothing -> "HSdll.dll" - - runLink dflags ( - map Option verbFlags - ++ [ Option "-o" - , FileOption "" output_fn - , Option "-shared" - ] ++ - [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a") - | gopt Opt_SharedImplib dflags - ] - ++ map (FileOption "") o_files - - -- Permit the linker to auto link _symbol to _imp_symbol - -- This lets us link against DLLs without needing an "import library" - ++ [Option "-Wl,--enable-auto-import"] - - ++ extra_ld_inputs - ++ map Option ( - lib_path_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) - OSDarwin -> do - ------------------------------------------------------------------- - -- Making a darwin dylib - ------------------------------------------------------------------- - -- About the options used for Darwin: - -- -dynamiclib - -- Apple's way of saying -shared - -- -undefined dynamic_lookup: - -- Without these options, we'd have to specify the correct - -- dependencies for each of the dylibs. Note that we could - -- (and should) do without this for all libraries except - -- the RTS; all we need to do is to pass the correct - -- HSfoo_dyn.dylib files to the link command. - -- This feature requires Mac OS X 10.3 or later; there is - -- a similar feature, -flat_namespace -undefined suppress, - -- which works on earlier versions, but it has other - -- disadvantages. - -- -single_module - -- Build the dynamic library as a single "module", i.e. no - -- dynamic binding nonsense when referring to symbols from - -- within the library. The NCG assumes that this option is - -- specified (on i386, at least). - -- -install_name - -- Mac OS/X stores the path where a dynamic library is (to - -- be) installed in the library itself. It's called the - -- "install name" of the library. Then any library or - -- executable that links against it before it's installed - -- will search for it in its ultimate install location. - -- By default we set the install name to the absolute path - -- at build time, but it can be overridden by the - -- -dylib-install-name option passed to ghc. Cabal does - -- this. - ------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - - instName <- case dylibInstallName dflags of - Just n -> return n - Nothing -> return $ "@rpath" `combine` (takeFileName output_fn) - runLink dflags ( - map Option verbFlags - ++ [ Option "-dynamiclib" - , Option "-o" - , FileOption "" output_fn - ] - ++ map Option o_files - ++ [ Option "-undefined", - Option "dynamic_lookup", - Option "-single_module" ] - ++ (if platformArch platform == ArchX86_64 - then [ ] - else [ Option "-Wl,-read_only_relocs,suppress" ]) - ++ [ Option "-install_name", Option instName ] - ++ map Option lib_path_opts - ++ extra_ld_inputs - ++ map Option framework_opts - ++ map Option pkg_lib_path_opts - ++ map Option pkg_link_opts - ++ map Option pkg_framework_opts - ) - OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target") - _ -> do - ------------------------------------------------------------------- - -- Making a DSO - ------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - let bsymbolicFlag = -- we need symbolic linking to resolve - -- non-PIC intra-package-relocations - ["-Wl,-Bsymbolic"] - - runLink dflags ( - map Option verbFlags - ++ libmLinkOpts - ++ [ Option "-o" - , FileOption "" output_fn - ] - ++ map Option o_files - ++ [ Option "-shared" ] - ++ map Option bsymbolicFlag - -- Set the library soname. We use -h rather than -soname as - -- Solaris 10 doesn't support the latter: - ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ] - ++ extra_ld_inputs - ++ map Option lib_path_opts - ++ map Option pkg_lib_path_opts - ++ map Option pkg_link_opts - ) - --- | Some platforms require that we explicitly link against @libm@ if any --- math-y things are used (which we assume to include all programs). See #14022. -libmLinkOpts :: [Option] -libmLinkOpts = -#if defined(HAVE_LIBM) - [Option "-lm"] -#else - [] -#endif - -getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String] -getPkgFrameworkOpts dflags platform dep_packages - | platformUsesFrameworks platform = do - pkg_framework_path_opts <- do - pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages - return $ map ("-F" ++) pkg_framework_paths - - pkg_framework_opts <- do - pkg_frameworks <- getPackageFrameworks dflags dep_packages - return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ] - - return (pkg_framework_path_opts ++ pkg_framework_opts) - - | otherwise = return [] - -getFrameworkOpts :: DynFlags -> Platform -> [String] -getFrameworkOpts dflags platform - | platformUsesFrameworks platform = framework_path_opts ++ framework_opts - | otherwise = [] - where - framework_paths = frameworkPaths dflags - framework_path_opts = map ("-F" ++) framework_paths - - frameworks = cmdlineFrameworks dflags - -- reverse because they're added in reverse order from the cmd line: - framework_opts = concat [ ["-framework", fw] - | fw <- reverse frameworks ] diff --git a/main/SysTools/Terminal.hs b/main/SysTools/Terminal.hs deleted file mode 100644 --- a/main/SysTools/Terminal.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -module SysTools.Terminal (stderrSupportsAnsiColors) where -#if defined MIN_VERSION_terminfo -import Control.Exception (catch) -import Data.Maybe (fromMaybe) -import System.Console.Terminfo (SetupTermError, Terminal, getCapability, - setupTermFromEnv, termColors) -import System.Posix (queryTerminal, stdError) -#elif defined mingw32_HOST_OS -import Control.Exception (catch, try) -import Data.Bits ((.|.), (.&.)) -import Data.List (isInfixOf, isPrefixOf, isSuffixOf) -import Foreign (FunPtr, Ptr, allocaBytes, castPtrToFunPtr, - peek, plusPtr, sizeOf, with) -import Foreign.C (CInt(..), CWchar, peekCWStringLen) -import qualified Graphics.Win32 as Win32 -import qualified System.Win32 as Win32 -#endif - -#if defined mingw32_HOST_OS && !defined WINAPI -# if defined i386_HOST_ARCH -# define WINAPI stdcall -# elif defined x86_64_HOST_ARCH -# define WINAPI ccall -# else -# error unknown architecture -# endif -#endif - --- | Check if ANSI escape sequences can be used to control color in stderr. -stderrSupportsAnsiColors :: IO Bool -stderrSupportsAnsiColors = do -#if defined MIN_VERSION_terminfo - queryTerminal stdError `andM` do - (termSupportsColors <$> setupTermFromEnv) - `catch` \ (_ :: SetupTermError) -> - pure False - - where - - andM :: Monad m => m Bool -> m Bool -> m Bool - andM mx my = do - x <- mx - if x - then my - else pure x - - termSupportsColors :: Terminal -> Bool - termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0 - -#elif defined mingw32_HOST_OS - h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE - `catch` \ (_ :: IOError) -> - pure Win32.nullHANDLE - if h == Win32.nullHANDLE - then pure False - else do - eMode <- try (getConsoleMode h) - case eMode of - Left (_ :: IOError) -> queryCygwinTerminal h - Right mode - | modeHasVTP mode -> pure True - | otherwise -> enableVTP h mode - - where - - queryCygwinTerminal :: Win32.HANDLE -> IO Bool - queryCygwinTerminal h = do - fileType <- Win32.getFileType h - if fileType /= Win32.fILE_TYPE_PIPE - then pure False - else do - fn <- getFileNameByHandle h - pure (("\\cygwin-" `isPrefixOf` fn || "\\msys-" `isPrefixOf` fn) && - "-pty" `isInfixOf` fn && - "-master" `isSuffixOf` fn) - `catch` \ (_ :: IOError) -> - pure False - - enableVTP :: Win32.HANDLE -> Win32.DWORD -> IO Bool - enableVTP h mode = do - setConsoleMode h (modeAddVTP mode) - modeHasVTP <$> getConsoleMode h - `catch` \ (_ :: IOError) -> - pure False - - modeHasVTP :: Win32.DWORD -> Bool - modeHasVTP mode = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 - - modeAddVTP :: Win32.DWORD -> Win32.DWORD - modeAddVTP mode = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING - -eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD -eNABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 - -getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD -getConsoleMode h = with 64 $ \ mode -> do - Win32.failIfFalse_ "GetConsoleMode" (c_GetConsoleMode h mode) - peek mode - -setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO () -setConsoleMode h mode = do - Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode) - -foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode - :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL - -foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode - :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL - -fileNameInfo :: CInt -fileNameInfo = 2 - -mAX_PATH :: Num a => a -mAX_PATH = 260 - -getFileNameByHandle :: Win32.HANDLE -> IO String -getFileNameByHandle h = do - let sizeOfDWORD = sizeOf (undefined :: Win32.DWORD) - let sizeOfWchar = sizeOf (undefined :: CWchar) - -- note: implicitly assuming that DWORD has stronger alignment than wchar_t - let bufSize = sizeOfDWORD + mAX_PATH * sizeOfWchar - allocaBytes bufSize $ \ buf -> do - getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize) - len :: Win32.DWORD <- peek buf - let len' = fromIntegral len `div` sizeOfWchar - peekCWStringLen (buf `plusPtr` sizeOfDWORD, min len' mAX_PATH) - -getFileInformationByHandleEx - :: Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO () -getFileInformationByHandleEx h cls buf bufSize = do - lib <- Win32.getModuleHandle (Just "kernel32.dll") - ptr <- Win32.getProcAddress lib "GetFileInformationByHandleEx" - let c_GetFileInformationByHandleEx = - mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr) - Win32.failIfFalse_ "getFileInformationByHandleEx" - (c_GetFileInformationByHandleEx h cls buf bufSize) - -type F_GetFileInformationByHandleEx a = - Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO Win32.BOOL - -foreign import WINAPI "dynamic" - mk_GetFileInformationByHandleEx - :: FunPtr (F_GetFileInformationByHandleEx a) - -> F_GetFileInformationByHandleEx a - -#else - pure False -#endif diff --git a/main/TidyPgm.hs b/main/TidyPgm.hs deleted file mode 100644 --- a/main/TidyPgm.hs +++ /dev/null @@ -1,1492 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{Tidying up Core} --} - -{-# LANGUAGE CPP, ViewPatterns #-} - -module TidyPgm ( - mkBootModDetailsTc, tidyProgram, globaliseAndTidyId - ) where - -#include "HsVersions.h" - -import TcRnTypes -import DynFlags -import CoreSyn -import CoreUnfold -import CoreFVs -import CoreTidy -import CoreMonad -import CorePrep -import CoreUtils (rhsIsStatic) -import CoreStats (coreBindsStats, CoreStats(..)) -import CoreSeq (seqBinds) -import CoreLint -import Literal -import Rules -import PatSyn -import ConLike -import CoreArity ( exprArity, exprBotStrictness_maybe ) -import StaticPtrTable -import VarEnv -import VarSet -import Var -import Id -import MkId ( mkDictSelRhs ) -import IdInfo -import InstEnv -import FamInstEnv -import Type ( tidyTopType ) -import Demand ( appIsBottom, isTopSig, isBottomingSig ) -import BasicTypes -import Name hiding (varName) -import NameSet -import NameEnv -import NameCache -import Avail -import IfaceEnv -import TcEnv -import TcRnMonad -import DataCon -import TyCon -import Class -import Module -import Packages( isDllName ) -import HscTypes -import Maybes -import UniqSupply -import ErrUtils (Severity(..)) -import Outputable -import UniqDFM -import SrcLoc -import qualified ErrUtils as Err - -import Control.Monad -import Data.Function -import Data.List ( sortBy ) -import Data.IORef ( atomicModifyIORef' ) - -{- -Constructing the TypeEnv, Instances, Rules, VectInfo from which the -ModIface is constructed, and which goes on to subsequent modules in ---make mode. - -Most of the interface file is obtained simply by serialising the -TypeEnv. One important consequence is that if the *interface file* -has pragma info if and only if the final TypeEnv does. This is not so -important for *this* module, but it's essential for ghc --make: -subsequent compilations must not see (e.g.) the arity if the interface -file does not contain arity If they do, they'll exploit the arity; -then the arity might change, but the iface file doesn't change => -recompilation does not happen => disaster. - -For data types, the final TypeEnv will have a TyThing for the TyCon, -plus one for each DataCon; the interface file will contain just one -data type declaration, but it is de-serialised back into a collection -of TyThings. - -************************************************************************ -* * - Plan A: simpleTidyPgm -* * -************************************************************************ - - -Plan A: mkBootModDetails: omit pragmas, make interfaces small -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Ignore the bindings - -* Drop all WiredIn things from the TypeEnv - (we never want them in interface files) - -* Retain all TyCons and Classes in the TypeEnv, to avoid - having to find which ones are mentioned in the - types of exported Ids - -* Trim off the constructors of non-exported TyCons, both - from the TyCon and from the TypeEnv - -* Drop non-exported Ids from the TypeEnv - -* Tidy the types of the DFunIds of Instances, - make them into GlobalIds, (they already have External Names) - and add them to the TypeEnv - -* Tidy the types of the (exported) Ids in the TypeEnv, - make them into GlobalIds (they already have External Names) - -* Drop rules altogether - -* Tidy the bindings, to ensure that the Caf and Arity - information is correct for each top-level binder; the - code generator needs it. And to ensure that local names have - distinct OccNames in case of object-file splitting - -* If this an hsig file, drop the instances altogether too (they'll - get pulled in by the implicit module import. --} - --- This is Plan A: make a small type env when typechecking only, --- or when compiling a hs-boot file, or simply when not using -O --- --- We don't look at the bindings at all -- there aren't any --- for hs-boot files - -mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails -mkBootModDetailsTc hsc_env - TcGblEnv{ tcg_exports = exports, - tcg_type_env = type_env, -- just for the Ids - tcg_tcs = tcs, - tcg_patsyns = pat_syns, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_mod = this_mod - } - = -- This timing isn't terribly useful since the result isn't forced, but - -- the message is useful to locating oneself in the compilation process. - Err.withTiming (pure dflags) - (text "CoreTidy"<+>brackets (ppr this_mod)) - (const ()) $ - do { let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts - ; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns - ; type_env1 = mkBootTypeEnv (availsToNameSet exports) - (typeEnvIds type_env) tcs fam_insts - ; type_env2 = extendTypeEnvWithPatSyns pat_syns' type_env1 - ; dfun_ids = map instanceDFunId insts' - ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids - } - ; return (ModDetails { md_types = type_env' - , md_insts = insts' - , md_fam_insts = fam_insts - , md_rules = [] - , md_anns = [] - , md_exports = exports - , md_vect_info = noVectInfo - , md_complete_sigs = [] - }) - } - where - dflags = hsc_dflags hsc_env - -mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv -mkBootTypeEnv exports ids tcs fam_insts - = tidyTypeEnv True $ - typeEnvFromEntities final_ids tcs fam_insts - where - -- Find the LocalIds in the type env that are exported - -- Make them into GlobalIds, and tidy their types - -- - -- It's very important to remove the non-exported ones - -- because we don't tidy the OccNames, and if we don't remove - -- the non-exported ones we'll get many things with the - -- same name in the interface file, giving chaos. - -- - -- Do make sure that we keep Ids that are already Global. - -- When typechecking an .hs-boot file, the Ids come through as - -- GlobalIds. - final_ids = [ (if isLocalId id then globaliseAndTidyId id - else id) - `setIdUnfolding` BootUnfolding - | id <- ids - , keep_it id ] - - -- default methods have their export flag set, but everything - -- else doesn't (yet), because this is pre-desugaring, so we - -- must test both. - keep_it id = isExportedId id || idName id `elemNameSet` exports - - - -globaliseAndTidyId :: Id -> Id --- Takes an LocalId with an External Name, --- makes it into a GlobalId --- * unchanged Name (might be Internal or External) --- * unchanged details --- * VanillaIdInfo (makes a conservative assumption about Caf-hood) -globaliseAndTidyId id - = Id.setIdType (globaliseId id) tidy_type - where - tidy_type = tidyTopType (idType id) - -{- -************************************************************************ -* * - Plan B: tidy bindings, make TypeEnv full of IdInfo -* * -************************************************************************ - -Plan B: include pragmas, make interfaces -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Figure out which Ids are externally visible - -* Tidy the bindings, externalising appropriate Ids - -* Drop all Ids from the TypeEnv, and add all the External Ids from - the bindings. (This adds their IdInfo to the TypeEnv; and adds - floated-out Ids that weren't even in the TypeEnv before.) - -Step 1: Figure out external Ids -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note [choosing external names] - -See also the section "Interface stability" in the -RecompilationAvoidance commentary: - http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance - -First we figure out which Ids are "external" Ids. An -"external" Id is one that is visible from outside the compilation -unit. These are - a) the user exported ones - b) the ones bound to static forms - c) ones mentioned in the unfoldings, workers, - rules of externally-visible ones , - or vectorised versions of externally-visible ones - -While figuring out which Ids are external, we pick a "tidy" OccName -for each one. That is, we make its OccName distinct from the other -external OccNames in this module, so that in interface files and -object code we can refer to it unambiguously by its OccName. The -OccName for each binder is prefixed by the name of the exported Id -that references it; e.g. if "f" references "x" in its unfolding, then -"x" is renamed to "f_x". This helps distinguish the different "x"s -from each other, and means that if "f" is later removed, things that -depend on the other "x"s will not need to be recompiled. Of course, -if there are multiple "f_x"s, then we have to disambiguate somehow; we -use "f_x0", "f_x1" etc. - -As far as possible we should assign names in a deterministic fashion. -Each time this module is compiled with the same options, we should end -up with the same set of external names with the same types. That is, -the ABI hash in the interface should not change. This turns out to be -quite tricky, since the order of the bindings going into the tidy -phase is already non-deterministic, as it is based on the ordering of -Uniques, which are assigned unpredictably. - -To name things in a stable way, we do a depth-first-search of the -bindings, starting from the exports sorted by name. This way, as long -as the bindings themselves are deterministic (they sometimes aren't!), -the order in which they are presented to the tidying phase does not -affect the names we assign. - -Step 2: Tidy the program -~~~~~~~~~~~~~~~~~~~~~~~~ -Next we traverse the bindings top to bottom. For each *top-level* -binder - - 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, - reflecting the fact that from now on we regard it as a global, - not local, Id - - 2. Give it a system-wide Unique. - [Even non-exported things need system-wide Uniques because the - byte-code generator builds a single Name->BCO symbol table.] - - We use the NameCache kept in the HscEnv as the - source of such system-wide uniques. - - For external Ids, use the original-name cache in the NameCache - to ensure that the unique assigned is the same as the Id had - in any previous compilation run. - - 3. Rename top-level Ids according to the names we chose in step 1. - If it's an external Id, make it have a External Name, otherwise - make it have an Internal Name. This is used by the code generator - to decide whether to make the label externally visible - - 4. Give it its UTTERLY FINAL IdInfo; in ptic, - * its unfolding, if it should have one - - * its arity, computed from the number of visible lambdas - - * its CAF info, computed from what is free in its RHS - - -Finally, substitute these new top-level binders consistently -throughout, including in unfoldings. We also tidy binders in -RHSs, so that they print nicely in interfaces. --} - -tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) -tidyProgram hsc_env (ModGuts { mg_module = mod - , mg_exports = exports - , mg_rdr_env = rdr_env - , mg_tcs = tcs - , mg_insts = cls_insts - , mg_fam_insts = fam_insts - , mg_binds = binds - , mg_patsyns = patsyns - , mg_rules = imp_rules - , mg_vect_info = vect_info - , mg_anns = anns - , mg_complete_sigs = complete_sigs - , mg_deps = deps - , mg_foreign = foreign_stubs - , mg_foreign_files = foreign_files - , mg_hpc_info = hpc_info - , mg_modBreaks = modBreaks - }) - - = Err.withTiming (pure dflags) - (text "CoreTidy"<+>brackets (ppr mod)) - (const ()) $ - do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags - ; expose_all = gopt Opt_ExposeAllUnfoldings dflags - ; print_unqual = mkPrintUnqualified dflags rdr_env - } - - ; let { type_env = typeEnvFromEntities [] tcs fam_insts - - ; implicit_binds - = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++ - concatMap getTyConImplicitBinds (typeEnvTyCons type_env) - } - - ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env mod omit_prags expose_all - binds implicit_binds imp_rules (vectInfoVar vect_info) - ; let { (trimmed_binds, trimmed_rules) - = findExternalRules omit_prags binds imp_rules unfold_env } - - ; (tidy_env, tidy_binds) - <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds - - ; let { final_ids = [ id | id <- bindersOfBinds tidy_binds, - isExternalName (idName id)] - ; type_env1 = extendTypeEnvWithIds type_env final_ids - - ; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts - -- A DFunId will have a binding in tidy_binds, and so will now be in - -- tidy_type_env, replete with IdInfo. Its name will be unchanged since - -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the - -- tidy_cls_insts. Similarly the Ids inside a PatSyn. - - ; tidy_rules = tidyRules tidy_env trimmed_rules - -- You might worry that the tidy_env contains IdInfo-rich stuff - -- and indeed it does, but if omit_prags is on, ext_rules is - -- empty - - ; tidy_vect_info = tidyVectInfo tidy_env vect_info - - -- Tidy the Ids inside each PatSyn, very similarly to DFunIds - -- and then override the PatSyns in the type_env with the new tidy ones - -- This is really the only reason we keep mg_patsyns at all; otherwise - -- they could just stay in type_env - ; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns - ; type_env2 = extendTypeEnvWithPatSyns tidy_patsyns type_env1 - - ; tidy_type_env = tidyTypeEnv omit_prags type_env2 - } - -- See Note [Grand plan for static forms] in StaticPtrTable. - ; (spt_entries, tidy_binds') <- - sptCreateStaticBinds hsc_env mod tidy_binds - ; let { spt_init_code = sptModuleInitCode mod spt_entries - ; add_spt_init_code = - case hscTarget dflags of - -- If we are compiling for the interpreter we will insert - -- any necessary SPT entries dynamically - HscInterpreted -> id - -- otherwise add a C stub to do so - _ -> (`appendStubC` spt_init_code) - } - - ; let { -- See Note [Injecting implicit bindings] - all_tidy_binds = implicit_binds ++ tidy_binds' - - -- Get the TyCons to generate code for. Careful! We must use - -- the untidied TypeEnv here, because we need - -- (a) implicit TyCons arising from types and classes defined - -- in this module - -- (b) wired-in TyCons, which are normally removed from the - -- TypeEnv we put in the ModDetails - -- (c) Constructors even if they are not exported (the - -- tidied TypeEnv has trimmed these away) - ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) - } - - ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules - - -- If the endPass didn't print the rules, but ddump-rules is - -- on, print now - ; unless (dopt Opt_D_dump_simpl dflags) $ - Err.dumpIfSet_dyn dflags Opt_D_dump_rules - (showSDoc dflags (ppr CoreTidy <+> text "rules")) - (pprRulesForUser dflags tidy_rules) - - -- Print one-line size info - ; let cs = coreBindsStats tidy_binds - ; when (dopt Opt_D_dump_core_stats dflags) - (putLogMsg dflags NoReason SevDump noSrcSpan - (defaultDumpStyle dflags) - (text "Tidy size (terms,types,coercions)" - <+> ppr (moduleName mod) <> colon - <+> int (cs_tm cs) - <+> int (cs_ty cs) - <+> int (cs_co cs) )) - - ; return (CgGuts { cg_module = mod, - cg_tycons = alg_tycons, - cg_binds = all_tidy_binds, - cg_foreign = add_spt_init_code foreign_stubs, - cg_foreign_files = foreign_files, - cg_dep_pkgs = map fst $ dep_pkgs deps, - cg_hpc_info = hpc_info, - cg_modBreaks = modBreaks, - cg_spt_entries = spt_entries }, - - ModDetails { md_types = tidy_type_env, - md_rules = tidy_rules, - md_insts = tidy_cls_insts, - md_vect_info = tidy_vect_info, - md_fam_insts = fam_insts, - md_exports = exports, - md_anns = anns, -- are already tidy - md_complete_sigs = complete_sigs - }) - } - where - dflags = hsc_dflags hsc_env - -tidyTypeEnv :: Bool -- Compiling without -O, so omit prags - -> TypeEnv -> TypeEnv - --- The competed type environment is gotten from --- a) the types and classes defined here (plus implicit things) --- b) adding Ids with correct IdInfo, including unfoldings, --- gotten from the bindings --- From (b) we keep only those Ids with External names; --- the CoreTidy pass makes sure these are all and only --- the externally-accessible ones --- This truncates the type environment to include only the --- exported Ids and things needed from them, which saves space --- --- See Note [Don't attempt to trim data types] - -tidyTypeEnv omit_prags type_env - = let - type_env1 = filterNameEnv (not . isWiredInName . getName) type_env - -- (1) remove wired-in things - type_env2 | omit_prags = mapNameEnv trimThing type_env1 - | otherwise = type_env1 - -- (2) trimmed if necessary - in - type_env2 - --------------------------- -trimThing :: TyThing -> TyThing --- Trim off inessentials, for boot files and no -O -trimThing (AnId id) - | not (isImplicitId id) - = AnId (id `setIdInfo` vanillaIdInfo) - -trimThing other_thing - = other_thing - -extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv -extendTypeEnvWithPatSyns tidy_patsyns type_env - = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] - -tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo -tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars - , vectInfoParallelVars = parallelVars - }) - = info { vectInfoVar = tidy_vars - , vectInfoParallelVars = tidy_parallelVars - } - where - -- we only export mappings whose domain and co-domain is exported (otherwise, the iface is - -- inconsistent) - tidy_vars = mkDVarEnv [ (tidy_var, (tidy_var, tidy_var_v)) - | (var, var_v) <- eltsUDFM vars - , let tidy_var = lookup_var var - tidy_var_v = lookup_var var_v - , isExternalId tidy_var && isExportedId tidy_var - , isExternalId tidy_var_v && isExportedId tidy_var_v - , isDataConWorkId var || not (isImplicitId var) - ] - - tidy_parallelVars = mkDVarSet - [ tidy_var - | var <- dVarSetElems parallelVars - , let tidy_var = lookup_var var - , isExternalId tidy_var && isExportedId tidy_var - ] - - lookup_var var = lookupWithDefaultVarEnv var_env var var - - -- We need to make sure that all names getting into the iface version of 'VectInfo' are - -- external; otherwise, 'MkIface' will bomb out. - isExternalId = isExternalName . idName - -{- -Note [Don't attempt to trim data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For some time GHC tried to avoid exporting the data constructors -of a data type if it wasn't strictly necessary to do so; see Trac #835. -But "strictly necessary" accumulated a longer and longer list -of exceptions, and finally I gave up the battle: - - commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11 - Author: Simon Peyton Jones - Date: Thu Dec 6 16:03:16 2012 +0000 - - Stop attempting to "trim" data types in interface files - - Without -O, we previously tried to make interface files smaller - by not including the data constructors of data types. But - there are a lot of exceptions, notably when Template Haskell is - involved or, more recently, DataKinds. - - However Trac #7445 shows that even without TemplateHaskell, using - the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ - is enough to require us to expose the data constructors. - - So I've given up on this "optimisation" -- it's probably not - important anyway. Now I'm simply not attempting to trim off - the data constructors. The gain in simplicity is worth the - modest cost in interface file growth, which is limited to the - bits reqd to describe those data constructors. - -************************************************************************ -* * - Implicit bindings -* * -************************************************************************ - -Note [Injecting implicit bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We inject the implicit bindings right at the end, in CoreTidy. -Some of these bindings, notably record selectors, are not -constructed in an optimised form. E.g. record selector for - data T = MkT { x :: {-# UNPACK #-} !Int } -Then the unfolding looks like - x = \t. case t of MkT x1 -> let x = I# x1 in x -This generates bad code unless it's first simplified a bit. That is -why CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of -optimisation first. (Only matters when the selector is used curried; -eg map x ys.) See Trac #2070. - -[Oct 09: in fact, record selectors are no longer implicit Ids at all, -because we really do want to optimise them properly. They are treated -much like any other Id. But doing "light" optimisation on an implicit -Id still makes sense.] - -At one time I tried injecting the implicit bindings *early*, at the -beginning of SimplCore. But that gave rise to real difficulty, -because GlobalIds are supposed to have *fixed* IdInfo, but the -simplifier and other core-to-core passes mess with IdInfo all the -time. The straw that broke the camels back was when a class selector -got the wrong arity -- ie the simplifier gave it arity 2, whereas -importing modules were expecting it to have arity 1 (Trac #2844). -It's much safer just to inject them right at the end, after tidying. - -Oh: two other reasons for injecting them late: - - - If implicit Ids are already in the bindings when we start TidyPgm, - we'd have to be careful not to treat them as external Ids (in - the sense of chooseExternalIds); else the Ids mentioned in *their* - RHSs will be treated as external and you get an interface file - saying a18 = - but nothing referring to a18 (because the implicit Id is the - one that does, and implicit Ids don't appear in interface files). - - - More seriously, the tidied type-envt will include the implicit - Id replete with a18 in its unfolding; but we won't take account - of a18 when computing a fingerprint for the class; result chaos. - -There is one sort of implicit binding that is injected still later, -namely those for data constructor workers. Reason (I think): it's -really just a code generation trick.... binding itself makes no sense. -See Note [Data constructor workers] in CorePrep. --} - -getTyConImplicitBinds :: TyCon -> [CoreBind] -getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) - -getClassImplicitBinds :: Class -> [CoreBind] -getClassImplicitBinds cls - = [ NonRec op (mkDictSelRhs cls val_index) - | (op, val_index) <- classAllSelIds cls `zip` [0..] ] - -get_defn :: Id -> CoreBind -get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) - -{- -************************************************************************ -* * -\subsection{Step 1: finding externals} -* * -************************************************************************ - -See Note [Choosing external names]. --} - -type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) - -- Maps each top-level Id to its new Name (the Id is tidied in step 2) - -- The Unique is unchanged. If the new Name is external, it will be - -- visible in the interface file. - -- - -- Bool => expose unfolding or not. - -chooseExternalIds :: HscEnv - -> Module - -> Bool -> Bool - -> [CoreBind] - -> [CoreBind] - -> [CoreRule] - -> DVarEnv (Var, Var) - -> IO (UnfoldEnv, TidyOccEnv) - -- Step 1 from the notes above - -chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules vect_vars - = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env - ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders - ; tidy_internal internal_ids unfold_env1 occ_env1 } - where - nc_var = hsc_NC hsc_env - - -- init_ext_ids is the intial list of Ids that should be - -- externalised. It serves as the starting point for finding a - -- deterministic, tidy, renaming for all external Ids in this - -- module. - -- - -- It is sorted, so that it has adeterministic order (i.e. it's the - -- same list every time this module is compiled), in contrast to the - -- bindings, which are ordered non-deterministically. - init_work_list = zip init_ext_ids init_ext_ids - init_ext_ids = sortBy (compare `on` getOccName) $ filter is_external binders - - -- An Id should be external if either (a) it is exported, - -- (b) it appears in the RHS of a local rule for an imported Id, or - -- (c) it is the vectorised version of an imported Id. - -- See Note [Which rules to expose] - is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars - || id `elemVarSet` vect_var_vs - - rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules - vect_var_vs = mkVarSet [var_v | (var, var_v) <- eltsUDFM vect_vars, isGlobalId var] - - binders = map fst $ flattenBinds binds - implicit_binders = bindersOfBinds implicit_binds - binder_set = mkVarSet binders - - avoids = [getOccName name | bndr <- binders ++ implicit_binders, - let name = idName bndr, - isExternalName name ] - -- In computing our "avoids" list, we must include - -- all implicit Ids - -- all things with global names (assigned once and for - -- all by the renamer) - -- since their names are "taken". - -- The type environment is a convenient source of such things. - -- In particular, the set of binders doesn't include - -- implicit Ids at this stage. - - -- We also make sure to avoid any exported binders. Consider - -- f{-u1-} = 1 -- Local decl - -- ... - -- f{-u2-} = 2 -- Exported decl - -- - -- The second exported decl must 'get' the name 'f', so we - -- have to put 'f' in the avoids list before we get to the first - -- decl. tidyTopId then does a no-op on exported binders. - init_occ_env = initTidyOccEnv avoids - - - search :: [(Id,Id)] -- The work-list: (external id, referring id) - -- Make a tidy, external Name for the external id, - -- add it to the UnfoldEnv, and do the same for the - -- transitive closure of Ids it refers to - -- The referring id is used to generate a tidy - --- name for the external id - -> UnfoldEnv -- id -> (new Name, show_unfold) - -> TidyOccEnv -- occ env for choosing new Names - -> IO (UnfoldEnv, TidyOccEnv) - - search [] unfold_env occ_env = return (unfold_env, occ_env) - - search ((idocc,referrer) : rest) unfold_env occ_env - | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env - | otherwise = do - (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc - let - (new_ids, show_unfold) - | omit_prags = ([], False) - | otherwise = addExternal expose_all refined_id - - -- add vectorised version if any exists - new_ids' = new_ids ++ maybeToList (fmap snd $ lookupDVarEnv vect_vars idocc) - - -- 'idocc' is an *occurrence*, but we need to see the - -- unfolding in the *definition*; so look up in binder_set - refined_id = case lookupVarSet binder_set idocc of - Just id -> id - Nothing -> WARN( True, ppr idocc ) idocc - - unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold) - referrer' | isExportedId refined_id = refined_id - | otherwise = referrer - -- - search (zip new_ids' (repeat referrer') ++ rest) unfold_env' occ_env' - - tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv - -> IO (UnfoldEnv, TidyOccEnv) - tidy_internal [] unfold_env occ_env = return (unfold_env,occ_env) - tidy_internal (id:ids) unfold_env occ_env = do - (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id - let unfold_env' = extendVarEnv unfold_env id (name',False) - tidy_internal ids unfold_env' occ_env' - -addExternal :: Bool -> Id -> ([Id], Bool) -addExternal expose_all id = (new_needed_ids, show_unfold) - where - new_needed_ids = bndrFvsInOrder show_unfold id - idinfo = idInfo id - show_unfold = show_unfolding (unfoldingInfo idinfo) - never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) - loop_breaker = isStrongLoopBreaker (occInfo idinfo) - bottoming_fn = isBottomingSig (strictnessInfo idinfo) - - -- Stuff to do with the Id's unfolding - -- We leave the unfolding there even if there is a worker - -- In GHCi the unfolding is used by importers - - show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) - = expose_all -- 'expose_all' says to expose all - -- unfoldings willy-nilly - - || isStableSource src -- Always expose things whose - -- source is an inline rule - - || not (bottoming_fn -- No need to inline bottom functions - || never_active -- Or ones that say not to - || loop_breaker -- Or that are loop breakers - || neverUnfoldGuidance guidance) - show_unfolding (DFunUnfolding {}) = True - show_unfolding _ = False - -{- -************************************************************************ -* * - Deterministic free variables -* * -************************************************************************ - -We want a deterministic free-variable list. exprFreeVars gives us -a VarSet, which is in a non-deterministic order when converted to a -list. Hence, here we define a free-variable finder that returns -the free variables in the order that they are encountered. - -See Note [Choosing external names] --} - -bndrFvsInOrder :: Bool -> Id -> [Id] -bndrFvsInOrder show_unfold id - = run (dffvLetBndr show_unfold id) - -run :: DFFV () -> [Id] -run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of - ((_,ids),_) -> ids - -newtype DFFV a - = DFFV (VarSet -- Envt: non-top-level things that are in scope - -- we don't want to record these as free vars - -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far - -> ((VarSet,[Var]),a)) -- Output state - -instance Functor DFFV where - fmap = liftM - -instance Applicative DFFV where - pure a = DFFV $ \_ st -> (st, a) - (<*>) = ap - -instance Monad DFFV where - (DFFV m) >>= k = DFFV $ \env st -> - case m env st of - (st',a) -> case k a of - DFFV f -> f env st' - -extendScope :: Var -> DFFV a -> DFFV a -extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st) - -extendScopeList :: [Var] -> DFFV a -> DFFV a -extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) - -insert :: Var -> DFFV () -insert v = DFFV $ \ env (set, ids) -> - let keep_me = isLocalId v && - not (v `elemVarSet` env) && - not (v `elemVarSet` set) - in if keep_me - then ((extendVarSet set v, v:ids), ()) - else ((set, ids), ()) - - -dffvExpr :: CoreExpr -> DFFV () -dffvExpr (Var v) = insert v -dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 -dffvExpr (Lam v e) = extendScope v (dffvExpr e) -dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e -dffvExpr (Tick _other e) = dffvExpr e -dffvExpr (Cast e _) = dffvExpr e -dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) -dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ - (mapM_ dffvBind prs >> dffvExpr e) -dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) -dffvExpr _other = return () - -dffvAlt :: (t, [Var], CoreExpr) -> DFFV () -dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r) - -dffvBind :: (Id, CoreExpr) -> DFFV () -dffvBind(x,r) - | not (isId x) = dffvExpr r - | otherwise = dffvLetBndr False x >> dffvExpr r - -- Pass False because we are doing the RHS right here - -- If you say True you'll get *exponential* behaviour! - -dffvLetBndr :: Bool -> Id -> DFFV () --- Gather the free vars of the RULES and unfolding of a binder --- We always get the free vars of a *stable* unfolding, but --- for a *vanilla* one (InlineRhs), the flag controls what happens: --- True <=> get fvs of even a *vanilla* unfolding --- False <=> ignore an InlineRhs --- For nested bindings (call from dffvBind) we always say "False" because --- we are taking the fvs of the RHS anyway --- For top-level bindings (call from addExternal, via bndrFvsInOrder) --- we say "True" if we are exposing that unfolding -dffvLetBndr vanilla_unfold id - = do { go_unf (unfoldingInfo idinfo) - ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) } - where - idinfo = idInfo id - - go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - = case src of - InlineRhs | vanilla_unfold -> dffvExpr rhs - | otherwise -> return () - _ -> dffvExpr rhs - - go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) - = extendScopeList bndrs $ mapM_ dffvExpr args - go_unf _ = return () - - go_rule (BuiltinRule {}) = return () - go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) - = extendScopeList bndrs (dffvExpr rhs) - -{- -************************************************************************ -* * - findExternalRules -* * -************************************************************************ - -Note [Finding external rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The complete rules are gotten by combining - a) local rules for imported Ids - b) rules embedded in the top-level Ids - -There are two complications: - * Note [Which rules to expose] - * Note [Trimming auto-rules] - -Note [Which rules to expose] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The function 'expose_rule' filters out rules that mention, on the LHS, -Ids that aren't externally visible; these rules can't fire in a client -module. - -The externally-visible binders are computed (by chooseExternalIds) -assuming that all orphan rules are externalised (see init_ext_ids in -function 'search'). So in fact it's a bit conservative and we may -export more than we need. (It's a sort of mutual recursion.) - -Note [Trimming auto-rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Second, with auto-specialisation we may specialise local or imported -dfuns or INLINE functions, and then later inline them. That may leave -behind something like - RULE "foo" forall d. f @ Int d = f_spec -where f is either local or imported, and there is no remaining -reference to f_spec except from the RULE. - -Now that RULE *might* be useful to an importing module, but that is -purely speculative, and meanwhile the code is taking up space and -codegen time. I found that binary sizes jumped by 6-10% when I -started to specialise INLINE functions (again, Note [Inline -specialisations] in Specialise). - -So it seems better to drop the binding for f_spec, and the rule -itself, if the auto-generated rule is the *only* reason that it is -being kept alive. - -(The RULE still might have been useful in the past; that is, it was -the right thing to have generated it in the first place. See Note -[Inline specialisations] in Specialise. But now it has served its -purpose, and can be discarded.) - -So findExternalRules does this: - * Remove all bindings that are kept alive *only* by isAutoRule rules - (this is done in trim_binds) - * Remove all auto rules that mention bindings that have been removed - (this is done by filtering by keep_rule) - -NB: if a binding is kept alive for some *other* reason (e.g. f_spec is -called in the final code), we keep the rule too. - -This stuff is the only reason for the ru_auto field in a Rule. --} - -findExternalRules :: Bool -- Omit pragmas - -> [CoreBind] - -> [CoreRule] -- Local rules for imported fns - -> UnfoldEnv -- Ids that are exported, so we need their rules - -> ([CoreBind], [CoreRule]) --- See Note [Finding external rules] -findExternalRules omit_prags binds imp_id_rules unfold_env - = (trimmed_binds, filter keep_rule all_rules) - where - imp_rules = filter expose_rule imp_id_rules - imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules - - user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet - | otherwise = ruleRhsFreeVars rule - - (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds - - keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs - -- Remove rules that make no sense, because they mention a - -- local binder (on LHS or RHS) that we have now discarded. - -- (NB: ruleFreeVars only includes LocalIds) - -- - -- LHS: we have already filtered out rules that mention internal Ids - -- on LHS but that isn't enough because we might have by now - -- discarded a binding with an external Id. (How? - -- chooseExternalIds is a bit conservative.) - -- - -- RHS: the auto rules that might mention a binder that has - -- been discarded; see Note [Trimming auto-rules] - - expose_rule rule - | omit_prags = False - | otherwise = all is_external_id (ruleLhsFreeIdsList rule) - -- Don't expose a rule whose LHS mentions a locally-defined - -- Id that is completely internal (i.e. not visible to an - -- importing module). NB: ruleLhsFreeIds only returns LocalIds. - -- See Note [Which rules to expose] - - is_external_id id = case lookupVarEnv unfold_env id of - Just (name, _) -> isExternalName name - Nothing -> False - - trim_binds :: [CoreBind] - -> ( [CoreBind] -- Trimmed bindings - , VarSet -- Binders of those bindings - , VarSet -- Free vars of those bindings + rhs of user rules - -- (we don't bother to delete the binders) - , [CoreRule]) -- All rules, imported + from the bindings - -- This function removes unnecessary bindings, and gathers up rules from - -- the bindings we keep. See Note [Trimming auto-rules] - trim_binds [] -- Base case, start with imp_user_rule_fvs - = ([], emptyVarSet, imp_user_rule_fvs, imp_rules) - - trim_binds (bind:binds) - | any needed bndrs -- Keep binding - = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules ) - | otherwise -- Discard binding altogether - = stuff - where - stuff@(binds', bndr_set, needed_fvs, rules) - = trim_binds binds - needed bndr = isExportedId bndr || bndr `elemVarSet` needed_fvs - - bndrs = bindersOf bind - rhss = rhssOfBind bind - bndr_set' = bndr_set `extendVarSetList` bndrs - - needed_fvs' = needed_fvs `unionVarSet` - mapUnionVarSet idUnfoldingVars bndrs `unionVarSet` - -- Ignore type variables in the type of bndrs - mapUnionVarSet exprFreeVars rhss `unionVarSet` - mapUnionVarSet user_rule_rhs_fvs local_rules - -- In needed_fvs', we don't bother to delete binders from the fv set - - local_rules = [ rule - | id <- bndrs - , is_external_id id -- Only collect rules for external Ids - , rule <- idCoreRules id - , expose_rule rule ] -- and ones that can fire in a client - -{- -************************************************************************ -* * - tidyTopName -* * -************************************************************************ - -This is where we set names to local/global based on whether they really are -externally visible (see comment at the top of this module). If the name -was previously local, we have to give it a unique occurrence name if -we intend to externalise it. --} - -tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv - -> Id -> IO (TidyOccEnv, Name) -tidyTopName mod nc_var maybe_ref occ_env id - | global && internal = return (occ_env, localiseName name) - - | global && external = return (occ_env, name) - -- Global names are assumed to have been allocated by the renamer, - -- so they already have the "right" unique - -- And it's a system-wide unique too - - -- Now we get to the real reason that all this is in the IO Monad: - -- we have to update the name cache in a nice atomic fashion - - | local && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local - ; return (occ_env', new_local_name) } - -- Even local, internal names must get a unique occurrence, because - -- if we do -split-objs we externalise the name later, in the code generator - -- - -- Similarly, we must make sure it has a system-wide Unique, because - -- the byte-code generator builds a system-wide Name->BCO symbol table - - | local && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external - ; return (occ_env', new_external_name) } - - | otherwise = panic "tidyTopName" - where - name = idName id - external = isJust maybe_ref - global = isExternalName name - local = not global - internal = not external - loc = nameSrcSpan name - - old_occ = nameOccName name - new_occ | Just ref <- maybe_ref - , ref /= id - = mkOccName (occNameSpace old_occ) $ - let - ref_str = occNameString (getOccName ref) - occ_str = occNameString old_occ - in - case occ_str of - '$':'w':_ -> occ_str - -- workers: the worker for a function already - -- includes the occname for its parent, so there's - -- no need to prepend the referrer. - _other | isSystemName name -> ref_str - | otherwise -> ref_str ++ '_' : occ_str - -- If this name was system-generated, then don't bother - -- to retain its OccName, just use the referrer. These - -- system-generated names will become "f1", "f2", etc. for - -- a referrer "f". - | otherwise = old_occ - - (occ_env', occ') = tidyOccName occ_env new_occ - - mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc) - where - (uniq, us) = takeUniqFromSupply (nsUniqs nc) - - mk_new_external nc = allocateGlobalBinder nc mod occ' loc - -- If we want to externalise a currently-local name, check - -- whether we have already assigned a unique for it. - -- If so, use it; if not, extend the table. - -- All this is done by allcoateGlobalBinder. - -- This is needed when *re*-compiling a module in GHCi; we must - -- use the same name for externally-visible things as we did before. - -{- -************************************************************************ -* * -\subsection{Step 2: top-level tidying} -* * -************************************************************************ --} - --- TopTidyEnv: when tidying we need to know --- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. --- These may have arisen because the --- renamer read in an interface file mentioning M.$wf, say, --- and assigned it unique r77. If, on this compilation, we've --- invented an Id whose name is $wf (but with a different unique) --- we want to rename it to have unique r77, so that we can do easy --- comparisons with stuff from the interface file --- --- * occ_env: The TidyOccEnv, which tells us which local occurrences --- are 'used' --- --- * subst_env: A Var->Var mapping that substitutes the new Var for the old - -tidyTopBinds :: HscEnv - -> Module - -> UnfoldEnv - -> TidyOccEnv - -> CoreProgram - -> IO (TidyEnv, CoreProgram) - -tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds - = do mkIntegerId <- lookupMkIntegerName dflags hsc_env - integerSDataCon <- lookupIntegerSDataConName dflags hsc_env - let cvt_integer = cvtLitInteger dflags mkIntegerId integerSDataCon - result = tidy cvt_integer init_env binds - seqBinds (snd result) `seq` return result - -- This seqBinds avoids a spike in space usage (see #13564) - where - dflags = hsc_dflags hsc_env - - init_env = (init_occ_env, emptyVarEnv) - - tidy _ env [] = (env, []) - tidy cvt_integer env (b:bs) - = let (env1, b') = tidyTopBind dflags this_mod - cvt_integer unfold_env env b - (env2, bs') = tidy cvt_integer env1 bs - in (env2, b':bs') - ------------------------- -tidyTopBind :: DynFlags - -> Module - -> (Integer -> CoreExpr) - -> UnfoldEnv - -> TidyEnv - -> CoreBind - -> (TidyEnv, CoreBind) - -tidyTopBind dflags this_mod cvt_integer unfold_env - (occ_env,subst1) (NonRec bndr rhs) - = (tidy_env2, NonRec bndr' rhs') - where - Just (name',show_unfold) = lookupVarEnv unfold_env bndr - caf_info = hasCafRefs dflags this_mod (subst1, cvt_integer) - (idArity bndr) rhs - (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' - (bndr, rhs) - subst2 = extendVarEnv subst1 bndr bndr' - tidy_env2 = (occ_env, subst2) - -tidyTopBind dflags this_mod cvt_integer unfold_env - (occ_env, subst1) (Rec prs) - = (tidy_env2, Rec prs') - where - prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs) - | (id,rhs) <- prs, - let (name',show_unfold) = - expectJust "tidyTopBind" $ lookupVarEnv unfold_env id - ] - - subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs') - tidy_env2 = (occ_env, subst2) - - bndrs = map fst prs - - -- the CafInfo for a recursive group says whether *any* rhs in - -- the group may refer indirectly to a CAF (because then, they all do). - caf_info - | or [ mayHaveCafRefs (hasCafRefs dflags this_mod - (subst1, cvt_integer) - (idArity bndr) rhs) - | (bndr,rhs) <- prs ] = MayHaveCafRefs - | otherwise = NoCafRefs - ------------------------------------------------------------ -tidyTopPair :: DynFlags - -> Bool -- show unfolding - -> TidyEnv -- The TidyEnv is used to tidy the IdInfo - -- It is knot-tied: don't look at it! - -> CafInfo - -> Name -- New name - -> (Id, CoreExpr) -- Binder and RHS before tidying - -> (Id, CoreExpr) - -- This function is the heart of Step 2 - -- The rec_tidy_env is the one to use for the IdInfo - -- It's necessary because when we are dealing with a recursive - -- group, a variable late in the group might be mentioned - -- in the IdInfo of one early in the group - -tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs) - = (bndr1, rhs1) - where - bndr1 = mkGlobalId details name' ty' idinfo' - details = idDetails bndr -- Preserve the IdDetails - ty' = tidyTopType (idType bndr) - rhs1 = tidyExpr rhs_tidy_env rhs - idinfo' = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr) - show_unfold caf_info - --- tidyTopIdInfo creates the final IdInfo for top-level --- binders. There are two delicate pieces: --- --- * Arity. After CoreTidy, this arity must not change any more. --- Indeed, CorePrep must eta expand where necessary to make --- the manifest arity equal to the claimed arity. --- --- * CAF info. This must also remain valid through to code generation. --- We add the info here so that it propagates to all --- occurrences of the binders in RHSs, and hence to occurrences in --- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. --- CoreToStg makes use of this when constructing SRTs. -tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr - -> IdInfo -> Bool -> CafInfo -> IdInfo -tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info - | not is_external -- For internal Ids (not externally visible) - = vanillaIdInfo -- we only need enough info for code generation - -- Arity and strictness info are enough; - -- c.f. CoreTidy.tidyLetBndr - `setCafInfo` caf_info - `setArityInfo` arity - `setStrictnessInfo` final_sig - - | otherwise -- Externally-visible Ids get the whole lot - = vanillaIdInfo - `setCafInfo` caf_info - `setArityInfo` arity - `setStrictnessInfo` final_sig - `setOccInfo` robust_occ_info - `setInlinePragInfo` (inlinePragInfo idinfo) - `setUnfoldingInfo` unfold_info - -- NB: we throw away the Rules - -- They have already been extracted by findExternalRules - where - is_external = isExternalName name - - --------- OccInfo ------------ - robust_occ_info = zapFragileOcc (occInfo idinfo) - -- It's important to keep loop-breaker information - -- when we are doing -fexpose-all-unfoldings - - --------- Strictness ------------ - mb_bot_str = exprBotStrictness_maybe orig_rhs - - sig = strictnessInfo idinfo - final_sig | not $ isTopSig sig - = WARN( _bottom_hidden sig , ppr name ) sig - -- try a cheap-and-cheerful bottom analyser - | Just (_, nsig) <- mb_bot_str = nsig - | otherwise = sig - - _bottom_hidden id_sig = case mb_bot_str of - Nothing -> False - Just (arity, _) -> not (appIsBottom id_sig arity) - - --------- Unfolding ------------ - unf_info = unfoldingInfo idinfo - unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs - | otherwise = noUnfolding - unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs - is_bot = isBottomingSig final_sig - -- NB: do *not* expose the worker if show_unfold is off, - -- because that means this thing is a loop breaker or - -- marked NOINLINE or something like that - -- This is important: if you expose the worker for a loop-breaker - -- then you can make the simplifier go into an infinite loop, because - -- in effect the unfolding is exposed. See Trac #1709 - -- - -- You might think that if show_unfold is False, then the thing should - -- not be w/w'd in the first place. But a legitimate reason is this: - -- the function returns bottom - -- In this case, show_unfold will be false (we don't expose unfoldings - -- for bottoming functions), but we might still have a worker/wrapper - -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs - - --------- Arity ------------ - -- Usually the Id will have an accurate arity on it, because - -- the simplifier has just run, but not always. - -- One case I found was when the last thing the simplifier - -- did was to let-bind a non-atomic argument and then float - -- it to the top level. So it seems more robust just to - -- fix it here. - arity = exprArity orig_rhs - -{- -************************************************************************ -* * - Figuring out CafInfo for an expression -* * -************************************************************************ - -hasCafRefs decides whether a top-level closure can point into the dynamic heap. -We mark such things as `MayHaveCafRefs' because this information is -used to decide whether a particular closure needs to be referenced -in an SRT or not. - -There are two reasons for setting MayHaveCafRefs: - a) The RHS is a CAF: a top-level updatable thunk. - b) The RHS refers to something that MayHaveCafRefs - -Possible improvement: In an effort to keep the number of CAFs (and -hence the size of the SRTs) down, we could also look at the expression and -decide whether it requires a small bounded amount of heap, so we can ignore -it as a CAF. In these cases however, we would need to use an additional -CAF list to keep track of non-collectable CAFs. - -Note [Disgusting computation of CafRefs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We compute hasCafRefs here, because IdInfo is supposed to be finalised -after TidyPgm. But CorePrep does some transformations that affect CAF-hood. -So we have to *predict* the result here, which is revolting. - -In particular CorePrep expands Integer literals. So in the prediction code -here we resort to applying the same expansion (cvt_integer). Ugh! --} - -type CafRefEnv = (VarEnv Id, Integer -> CoreExpr) - -- The env finds the Caf-ness of the Id - -- The Integer -> CoreExpr is the desugaring function for Integer literals - -- See Note [Disgusting computation of CafRefs] - -hasCafRefs :: DynFlags -> Module - -> CafRefEnv -> Arity -> CoreExpr - -> CafInfo -hasCafRefs dflags this_mod p@(_,cvt_integer) arity expr - | is_caf || mentions_cafs = MayHaveCafRefs - | otherwise = NoCafRefs - where - mentions_cafs = cafRefsE p expr - is_dynamic_name = isDllName dflags this_mod - is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name cvt_integer expr) - - -- NB. we pass in the arity of the expression, which is expected - -- to be calculated by exprArity. This is because exprArity - -- knows how much eta expansion is going to be done by - -- CorePrep later on, and we don't want to duplicate that - -- knowledge in rhsIsStatic below. - -cafRefsE :: CafRefEnv -> Expr a -> Bool -cafRefsE p (Var id) = cafRefsV p id -cafRefsE p (Lit lit) = cafRefsL p lit -cafRefsE p (App f a) = cafRefsE p f || cafRefsE p a -cafRefsE p (Lam _ e) = cafRefsE p e -cafRefsE p (Let b e) = cafRefsEs p (rhssOfBind b) || cafRefsE p e -cafRefsE p (Case e _ _ alts) = cafRefsE p e || cafRefsEs p (rhssOfAlts alts) -cafRefsE p (Tick _n e) = cafRefsE p e -cafRefsE p (Cast e _co) = cafRefsE p e -cafRefsE _ (Type _) = False -cafRefsE _ (Coercion _) = False - -cafRefsEs :: CafRefEnv -> [Expr a] -> Bool -cafRefsEs _ [] = False -cafRefsEs p (e:es) = cafRefsE p e || cafRefsEs p es - -cafRefsL :: CafRefEnv -> Literal -> Bool --- Don't forget that mk_integer id might have Caf refs! --- We first need to convert the Integer into its final form, to --- see whether mkInteger is used. -cafRefsL p@(_, cvt_integer) (LitInteger i _) = cafRefsE p (cvt_integer i) -cafRefsL _ _ = False - -cafRefsV :: CafRefEnv -> Id -> Bool -cafRefsV (subst, _) id - | not (isLocalId id) = mayHaveCafRefs (idCafInfo id) - | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id') - | otherwise = False - - -{- -************************************************************************ -* * - Old, dead, type-trimming code -* * -************************************************************************ - -We used to try to "trim off" the constructors of data types that are -not exported, to reduce the size of interface files, at least without --O. But that is not always possible: see the old Note [When we can't -trim types] below for exceptions. - -Then (Trac #7445) I realised that the TH problem arises for any data type -that we have deriving( Data ), because we can invoke - Language.Haskell.TH.Quote.dataToExpQ -to get a TH Exp representation of a value built from that data type. -You don't even need {-# LANGUAGE TemplateHaskell #-}. - -At this point I give up. The pain of trimming constructors just -doesn't seem worth the gain. So I've dumped all the code, and am just -leaving it here at the end of the module in case something like this -is ever resurrected. - - -Note [When we can't trim types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea of type trimming is to export algebraic data types -abstractly (without their data constructors) when compiling without --O, unless of course they are explicitly exported by the user. - -We always export synonyms, because they can be mentioned in the type -of an exported Id. We could do a full dependency analysis starting -from the explicit exports, but that's quite painful, and not done for -now. - -But there are some times we can't do that, indicated by the 'no_trim_types' flag. - -First, Template Haskell. Consider (Trac #2386) this - module M(T, makeOne) where - data T = Yay String - makeOne = [| Yay "Yep" |] -Notice that T is exported abstractly, but makeOne effectively exports it too! -A module that splices in $(makeOne) will then look for a declaration of Yay, -so it'd better be there. Hence, brutally but simply, we switch off type -constructor trimming if TH is enabled in this module. - -Second, data kinds. Consider (Trac #5912) - {-# LANGUAGE DataKinds #-} - module M() where - data UnaryTypeC a = UnaryDataC a - type Bug = 'UnaryDataC -We always export synonyms, so Bug is exposed, and that means that -UnaryTypeC must be too, even though it's not explicitly exported. In -effect, DataKinds means that we'd need to do a full dependency analysis -to see what data constructors are mentioned. But we don't do that yet. - -In these two cases we just switch off type trimming altogether. - -mustExposeTyCon :: Bool -- Type-trimming flag - -> NameSet -- Exports - -> TyCon -- The tycon - -> Bool -- Can its rep be hidden? --- We are compiling without -O, and thus trying to write as little as --- possible into the interface file. But we must expose the details of --- any data types whose constructors or fields are exported -mustExposeTyCon no_trim_types exports tc - | no_trim_types -- See Note [When we can't trim types] - = True - - | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to - -- figure out whether it was mentioned in the type - -- of any other exported thing) - = True - - | isEnumerationTyCon tc -- For an enumeration, exposing the constructors - = True -- won't lead to the need for further exposure - - | isFamilyTyCon tc -- Open type family - = True - - -- Below here we just have data/newtype decls or family instances - - | null data_cons -- Ditto if there are no data constructors - = True -- (NB: empty data types do not count as enumerations - -- see Note [Enumeration types] in TyCon - - | any exported_con data_cons -- Expose rep if any datacon or field is exported - = True - - | isNewTyCon tc && isFFITy (snd (newTyConRhs tc)) - = True -- Expose the rep for newtypes if the rep is an FFI type. - -- For a very annoying reason. 'Foreign import' is meant to - -- be able to look through newtypes transparently, but it - -- can only do that if it can "see" the newtype representation - - | otherwise - = False - where - data_cons = tyConDataCons tc - exported_con con = any (`elemNameSet` exports) - (dataConName con : dataConFieldLabels con) --} diff --git a/nativeGen/AsmCodeGen.hs b/nativeGen/AsmCodeGen.hs deleted file mode 100644 --- a/nativeGen/AsmCodeGen.hs +++ /dev/null @@ -1,1227 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1993-2004 --- --- This is the top-level module in the native code generator. --- --- ----------------------------------------------------------------------------- - -{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, UnboxedTuples #-} - -module AsmCodeGen ( - -- * Module entry point - nativeCodeGen - - -- * Test-only exports: see trac #12744 - -- used by testGraphNoSpills, which needs to access - -- the register allocator intermediate data structures - -- cmmNativeGen emits - , cmmNativeGen - , NcgImpl(..) - , x86NcgImpl - ) where - -#include "HsVersions.h" -#include "nativeGen/NCG.h" - - -import qualified X86.CodeGen -import qualified X86.Regs -import qualified X86.Instr -import qualified X86.Ppr - -import qualified SPARC.CodeGen -import qualified SPARC.Regs -import qualified SPARC.Instr -import qualified SPARC.Ppr -import qualified SPARC.ShortcutJump -import qualified SPARC.CodeGen.Expand - -import qualified PPC.CodeGen -import qualified PPC.Regs -import qualified PPC.RegInfo -import qualified PPC.Instr -import qualified PPC.Ppr - -import RegAlloc.Liveness -import qualified RegAlloc.Linear.Main as Linear - -import qualified GraphColor as Color -import qualified RegAlloc.Graph.Main as Color -import qualified RegAlloc.Graph.Stats as Color -import qualified RegAlloc.Graph.TrivColorable as Color - -import TargetReg -import Platform -import Config -import Instruction -import PIC -import Reg -import NCGMonad -import Dwarf -import Debug - -import BlockId -import CgUtils ( fixStgRegisters ) -import Cmm -import CmmUtils -import Hoopl -import CmmOpt ( cmmMachOpFold ) -import PprCmm -import CLabel - -import UniqFM -import UniqSupply -import DynFlags -import Util -import Unique - -import BasicTypes ( Alignment ) -import Digraph -import qualified Pretty -import BufWrite -import Outputable -import FastString -import UniqSet -import ErrUtils -import Module -import Stream (Stream) -import qualified Stream - --- DEBUGGING ONLY ---import OrdList - -import Data.List -import Data.Maybe -import Data.Ord ( comparing ) -import Control.Exception -import Control.Monad -import System.IO - -{- -The native-code generator has machine-independent and -machine-dependent modules. - -This module ("AsmCodeGen") is the top-level machine-independent -module. Before entering machine-dependent land, we do some -machine-independent optimisations (defined below) on the -'CmmStmts's. - -We convert to the machine-specific 'Instr' datatype with -'cmmCodeGen', assuming an infinite supply of registers. We then use -a machine-independent register allocator ('regAlloc') to rejoin -reality. Obviously, 'regAlloc' has machine-specific helper -functions (see about "RegAllocInfo" below). - -Finally, we order the basic blocks of the function so as to minimise -the number of jumps between blocks, by utilising fallthrough wherever -possible. - -The machine-dependent bits break down as follows: - - * ["MachRegs"] Everything about the target platform's machine - registers (and immediate operands, and addresses, which tend to - intermingle/interact with registers). - - * ["MachInstrs"] Includes the 'Instr' datatype (possibly should - have a module of its own), plus a miscellany of other things - (e.g., 'targetDoubleSize', 'smStablePtrTable', ...) - - * ["MachCodeGen"] is where 'Cmm' stuff turns into - machine instructions. - - * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really - a 'SDoc'). - - * ["RegAllocInfo"] In the register allocator, we manipulate - 'MRegsState's, which are 'BitSet's, one bit per machine register. - When we want to say something about a specific machine register - (e.g., ``it gets clobbered by this instruction''), we set/unset - its bit. Obviously, we do this 'BitSet' thing for efficiency - reasons. - - The 'RegAllocInfo' module collects together the machine-specific - info needed to do register allocation. - - * ["RegisterAlloc"] The (machine-independent) register allocator. --} - --- ----------------------------------------------------------------------------- --- Top-level of the native codegen - -data NcgImpl statics instr jumpDest = NcgImpl { - cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr], - generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr), - getJumpDestBlockId :: jumpDest -> Maybe BlockId, - canShortcut :: instr -> Maybe jumpDest, - shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, - shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, - pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc, - maxSpillSlots :: Int, - allocatableRegs :: [RealReg], - ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], - ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], - ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr), - ncgMakeFarBranches :: LabelMap CmmStatics - -> [NatBasicBlock instr] -> [NatBasicBlock instr], - extractUnwindPoints :: [instr] -> [UnwindPoint] - -- ^ given the instruction sequence of a block, produce a list of - -- the block's 'UnwindPoint's - -- See Note [What is this unwinding business?] in Debug - -- and Note [Unwinding information in the NCG] in this module. - } - --------------------- -nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply - -> Stream IO RawCmmGroup () - -> IO UniqSupply -nativeCodeGen dflags this_mod modLoc h us cmms - = let platform = targetPlatform dflags - nCG' :: (Outputable statics, Outputable instr, Instruction instr) - => NcgImpl statics instr jumpDest -> IO UniqSupply - nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms - in case platformArch platform of - ArchX86 -> nCG' (x86NcgImpl dflags) - ArchX86_64 -> nCG' (x86_64NcgImpl dflags) - ArchPPC -> nCG' (ppcNcgImpl dflags) - ArchSPARC -> nCG' (sparcNcgImpl dflags) - ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64" - ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" - ArchARM64 -> panic "nativeCodeGen: No NCG for ARM64" - ArchPPC_64 _ -> nCG' (ppcNcgImpl dflags) - ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha" - ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" - ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel" - ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" - ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" - -x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest -x86NcgImpl dflags - = (x86_64NcgImpl dflags) { ncg_x86fp_kludge = map x86fp_kludge } - -x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest -x86_64NcgImpl dflags - = NcgImpl { - cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen - ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags - ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId - ,canShortcut = X86.Instr.canShortcut - ,shortcutStatics = X86.Instr.shortcutStatics - ,shortcutJump = X86.Instr.shortcutJump - ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl - ,maxSpillSlots = X86.Instr.maxSpillSlots dflags - ,allocatableRegs = X86.Regs.allocatableRegs platform - ,ncg_x86fp_kludge = id - ,ncgAllocMoreStack = X86.Instr.allocMoreStack platform - ,ncgExpandTop = id - ,ncgMakeFarBranches = const id - ,extractUnwindPoints = X86.CodeGen.extractUnwindPoints - } - where platform = targetPlatform dflags - -ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest -ppcNcgImpl dflags - = NcgImpl { - cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen - ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags - ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId - ,canShortcut = PPC.RegInfo.canShortcut - ,shortcutStatics = PPC.RegInfo.shortcutStatics - ,shortcutJump = PPC.RegInfo.shortcutJump - ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl - ,maxSpillSlots = PPC.Instr.maxSpillSlots dflags - ,allocatableRegs = PPC.Regs.allocatableRegs platform - ,ncg_x86fp_kludge = id - ,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform - ,ncgExpandTop = id - ,ncgMakeFarBranches = PPC.Instr.makeFarBranches - ,extractUnwindPoints = const [] - } - where platform = targetPlatform dflags - -sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest -sparcNcgImpl dflags - = NcgImpl { - cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen - ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags - ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId - ,canShortcut = SPARC.ShortcutJump.canShortcut - ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics - ,shortcutJump = SPARC.ShortcutJump.shortcutJump - ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl - ,maxSpillSlots = SPARC.Instr.maxSpillSlots dflags - ,allocatableRegs = SPARC.Regs.allocatableRegs - ,ncg_x86fp_kludge = id - ,ncgAllocMoreStack = noAllocMoreStack - ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop - ,ncgMakeFarBranches = const id - ,extractUnwindPoints = const [] - } - --- --- Allocating more stack space for spilling is currently only --- supported for the linear register allocator on x86/x86_64, the rest --- default to the panic below. To support allocating extra stack on --- more platforms provide a definition of ncgAllocMoreStack. --- -noAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr) -noAllocMoreStack amount _ - = panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n" - ++ " If you are trying to compile SHA1.hs from the crypto library then this\n" - ++ " is a known limitation in the linear allocator.\n" - ++ "\n" - ++ " Try enabling the graph colouring allocator with -fregs-graph instead." - ++ " You can still file a bug report if you like.\n" - - --- | Data accumulated during code generation. Mostly about statistics, --- but also collects debug data for DWARF generation. -data NativeGenAcc statics instr - = NGS { ngs_imports :: ![[CLabel]] - , ngs_natives :: ![[NatCmmDecl statics instr]] - -- ^ Native code generated, for statistics. This might - -- hold a lot of data, so it is important to clear this - -- field as early as possible if it isn't actually - -- required. - , ngs_colorStats :: ![[Color.RegAllocStats statics instr]] - , ngs_linearStats :: ![[Linear.RegAllocStats]] - , ngs_labels :: ![Label] - , ngs_debug :: ![DebugBlock] - , ngs_dwarfFiles :: !DwarfFiles - , ngs_unwinds :: !(LabelMap [UnwindPoint]) - -- ^ see Note [Unwinding information in the NCG] - -- and Note [What is this unwinding business?] in Debug. - } - -{- -Note [Unwinding information in the NCG] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Unwind information is a type of metadata which allows a debugging tool -to reconstruct the values of machine registers at the time a procedure was -entered. For the most part, the production of unwind information is handled by -the Cmm stage, where it is represented by CmmUnwind nodes. - -Unfortunately, the Cmm stage doesn't know everything necessary to produce -accurate unwinding information. For instance, the x86-64 calling convention -requires that the stack pointer be aligned to 16 bytes, which in turn means that -GHC must sometimes add padding to $sp prior to performing a foreign call. When -this happens unwind information must be updated accordingly. -For this reason, we make the NCG backends responsible for producing -unwinding tables (with the extractUnwindPoints function in NcgImpl). - -We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds -field of NativeGenAcc. This is a label map which contains an entry for each -procedure, containing a list of unwinding points (e.g. a label and an associated -unwinding table). - -See also Note [What is this unwinding business?] in Debug. --} - -nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) - => DynFlags - -> Module -> ModLocation - -> NcgImpl statics instr jumpDest - -> Handle - -> UniqSupply - -> Stream IO RawCmmGroup () - -> IO UniqSupply -nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms - = do - -- BufHandle is a performance hack. We could hide it inside - -- Pretty if it weren't for the fact that we do lots of little - -- printDocs here (in order to do codegen in constant space). - bufh <- newBufHandle h - let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty - (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us - cmms ngs0 - finishNativeGen dflags modLoc bufh us' ngs - -finishNativeGen :: Instruction instr - => DynFlags - -> ModLocation - -> BufHandle - -> UniqSupply - -> NativeGenAcc statics instr - -> IO UniqSupply -finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs - = do - -- Write debug data and finish - let emitDw = debugLevel dflags > 0 && not (gopt Opt_SplitObjs dflags) - us' <- if not emitDw then return us else do - (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs) - emitNativeCode dflags bufh dwarf - return us' - bFlush bufh - - -- dump global NCG stats for graph coloring allocator - let stats = concat (ngs_colorStats ngs) - when (not (null stats)) $ do - - -- build the global register conflict graph - let graphGlobal - = foldl Color.union Color.initGraph - $ [ Color.raGraph stat - | stat@Color.RegAllocStatsStart{} <- stats] - - dump_stats (Color.pprStats stats graphGlobal) - - let platform = targetPlatform dflags - dumpIfSet_dyn dflags - Opt_D_dump_asm_conflicts "Register conflict graph" - $ Color.dotGraph - (targetRegDotColor platform) - (Color.trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - $ graphGlobal - - - -- dump global NCG stats for linear allocator - let linearStats = concat (ngs_linearStats ngs) - when (not (null linearStats)) $ - dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats) - - -- write out the imports - printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle) - $ makeImportsDoc dflags (concat (ngs_imports ngs)) - return us' - where - dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats" - -cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) - => DynFlags - -> Module -> ModLocation - -> NcgImpl statics instr jumpDest - -> BufHandle - -> UniqSupply - -> Stream IO RawCmmGroup () - -> NativeGenAcc statics instr - -> IO (NativeGenAcc statics instr, UniqSupply) - -cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs - = do r <- Stream.runStream cmm_stream - case r of - Left () -> - return (ngs { ngs_imports = reverse $ ngs_imports ngs - , ngs_natives = reverse $ ngs_natives ngs - , ngs_colorStats = reverse $ ngs_colorStats ngs - , ngs_linearStats = reverse $ ngs_linearStats ngs - }, - us) - Right (cmms, cmm_stream') -> do - - -- Generate debug information - let debugFlag = debugLevel dflags > 0 - !ndbgs | debugFlag = cmmDebugGen modLoc cmms - | otherwise = [] - dbgMap = debugToMap ndbgs - - -- Insert split marker, generate native code - let splitObjs = gopt Opt_SplitObjs dflags - split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] $ - ofBlockList (panic "split_marker_entry") [] - cmms' | splitObjs = split_marker : cmms - | otherwise = cmms - (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h - dbgMap us cmms' ngs 0 - - -- Link native code information into debug blocks - -- See Note [What is this unwinding business?] in Debug. - let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs - dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" - (vcat $ map ppr ldbgs) - - -- Emit & clear DWARF information when generating split - -- object files, as we need it to land in the same object file - -- When using split sections, note that we do not split the debug - -- info but emit all the info at once in finishNativeGen. - (ngs'', us'') <- - if debugFlag && splitObjs - then do (dwarf, us'') <- dwarfGen dflags modLoc us ldbgs - emitNativeCode dflags h dwarf - return (ngs' { ngs_debug = [] - , ngs_dwarfFiles = emptyUFM - , ngs_labels = [] }, - us'') - else return (ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs - , ngs_labels = [] }, - us') - - cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'' - cmm_stream' ngs'' - --- | Do native code generation on all these cmms. --- -cmmNativeGens :: forall statics instr jumpDest. - (Outputable statics, Outputable instr, Instruction instr) - => DynFlags - -> Module -> ModLocation - -> NcgImpl statics instr jumpDest - -> BufHandle - -> LabelMap DebugBlock - -> UniqSupply - -> [RawCmmDecl] - -> NativeGenAcc statics instr - -> Int - -> IO (NativeGenAcc statics instr, UniqSupply) - -cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go - where - go :: UniqSupply -> [RawCmmDecl] - -> NativeGenAcc statics instr -> Int - -> IO (NativeGenAcc statics instr, UniqSupply) - - go us [] ngs !_ = - return (ngs, us) - - go us (cmm : cmms) ngs count = do - let fileIds = ngs_dwarfFiles ngs - (us', fileIds', native, imports, colorStats, linearStats, unwinds) - <- {-# SCC "cmmNativeGen" #-} - cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap - cmm count - - -- Generate .file directives for every new file that has been - -- used. Note that it is important that we generate these in - -- ascending order, as Clang's 3.6 assembler complains. - let newFileIds = sortBy (comparing snd) $ - nonDetEltsUFM $ fileIds' `minusUFM` fileIds - -- See Note [Unique Determinism and code generation] - pprDecl (f,n) = text "\t.file " <> ppr n <+> - doubleQuotes (ftext f) - - emitNativeCode dflags h $ vcat $ - map pprDecl newFileIds ++ - map (pprNatCmmDecl ncgImpl) native - - -- force evaluation all this stuff to avoid space leaks - {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports) - - let !labels' = if debugLevel dflags > 0 - then cmmDebugLabels isMetaInstr native else [] - !natives' = if dopt Opt_D_dump_asm_stats dflags - then native : ngs_natives ngs else [] - - mCon = maybe id (:) - ngs' = ngs{ ngs_imports = imports : ngs_imports ngs - , ngs_natives = natives' - , ngs_colorStats = colorStats `mCon` ngs_colorStats ngs - , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs - , ngs_labels = ngs_labels ngs ++ labels' - , ngs_dwarfFiles = fileIds' - , ngs_unwinds = ngs_unwinds ngs `mapUnion` unwinds - } - go us' cmms ngs' (count + 1) - - seqString [] = () - seqString (x:xs) = x `seq` seqString xs - - -emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO () -emitNativeCode dflags h sdoc = do - - {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h - (mkCodeStyle AsmStyle) sdoc - - -- dump native code - dumpIfSet_dyn dflags - Opt_D_dump_asm "Asm code" - sdoc - --- | Complete native code generation phase for a single top-level chunk of Cmm. --- Dumping the output of each stage along the way. --- Global conflict graph and NGC stats -cmmNativeGen - :: (Outputable statics, Outputable instr, Instruction instr) - => DynFlags - -> Module -> ModLocation - -> NcgImpl statics instr jumpDest - -> UniqSupply - -> DwarfFiles - -> LabelMap DebugBlock - -> RawCmmDecl -- ^ the cmm to generate code for - -> Int -- ^ sequence number of this top thing - -> IO ( UniqSupply - , DwarfFiles - , [NatCmmDecl statics instr] -- native code - , [CLabel] -- things imported by this cmm - , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator - , Maybe [Linear.RegAllocStats] -- stats for the linear register allocators - , LabelMap [UnwindPoint] -- unwinding information for blocks - ) - -cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count - = do - let platform = targetPlatform dflags - - -- rewrite assignments to global regs - let fixed_cmm = - {-# SCC "fixStgRegisters" #-} - fixStgRegisters dflags cmm - - -- cmm to cmm optimisations - let (opt_cmm, imports) = - {-# SCC "cmmToCmm" #-} - cmmToCmm dflags this_mod fixed_cmm - - dumpIfSet_dyn dflags - Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmmGroup [opt_cmm]) - - -- generate native code from cmm - let ((native, lastMinuteImports, fileIds'), usGen) = - {-# SCC "genMachCode" #-} - initUs us $ genMachCode dflags this_mod modLoc - (cmmTopCodeGen ncgImpl) - fileIds dbgMap opt_cmm - - dumpIfSet_dyn dflags - Opt_D_dump_asm_native "Native code" - (vcat $ map (pprNatCmmDecl ncgImpl) native) - - -- tag instructions with register liveness information - let (withLiveness, usLive) = - {-# SCC "regLiveness" #-} - initUs usGen - $ mapM (regLiveness platform) - $ map natCmmTopToLive native - - dumpIfSet_dyn dflags - Opt_D_dump_asm_liveness "Liveness annotations added" - (vcat $ map ppr withLiveness) - - -- allocate registers - (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- - if ( gopt Opt_RegsGraph dflags - || gopt Opt_RegsIterative dflags ) - then do - -- the regs usable for allocation - let (alloc_regs :: UniqFM (UniqSet RealReg)) - = foldr (\r -> plusUFM_C unionUniqSets - $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) - emptyUFM - $ allocatableRegs ncgImpl - - -- do the graph coloring register allocation - let ((alloced, regAllocStats), usAlloc) - = {-# SCC "RegAlloc-color" #-} - initUs usLive - $ Color.regAlloc - dflags - alloc_regs - (mkUniqSet [0 .. maxSpillSlots ncgImpl]) - withLiveness - - -- dump out what happened during register allocation - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (pprNatCmmDecl ncgImpl) alloced) - - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc_stages "Build/spill stages" - (vcat $ map (\(stage, stats) - -> text "# --------------------------" - $$ text "# cmm " <> int count <> text " Stage " <> int stage - $$ ppr stats) - $ zip [0..] regAllocStats) - - let mPprStats = - if dopt Opt_D_dump_asm_stats dflags - then Just regAllocStats else Nothing - - -- force evaluation of the Maybe to avoid space leak - mPprStats `seq` return () - - return ( alloced, usAlloc - , mPprStats - , Nothing) - - else do - -- do linear register allocation - let reg_alloc proc = do - (alloced, maybe_more_stack, ra_stats) <- - Linear.regAlloc dflags proc - case maybe_more_stack of - Nothing -> return ( alloced, ra_stats ) - Just amount -> do - alloced' <- ncgAllocMoreStack ncgImpl amount alloced - return (alloced', ra_stats ) - - let ((alloced, regAllocStats), usAlloc) - = {-# SCC "RegAlloc-linear" #-} - initUs usLive - $ liftM unzip - $ mapM reg_alloc withLiveness - - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (pprNatCmmDecl ncgImpl) alloced) - - let mPprStats = - if dopt Opt_D_dump_asm_stats dflags - then Just (catMaybes regAllocStats) else Nothing - - -- force evaluation of the Maybe to avoid space leak - mPprStats `seq` return () - - return ( alloced, usAlloc - , Nothing - , mPprStats) - - ---- x86fp_kludge. This pass inserts ffree instructions to clear - ---- the FPU stack on x86. The x86 ABI requires that the FPU stack - ---- is clear, and library functions can return odd results if it - ---- isn't. - ---- - ---- NB. must happen before shortcutBranches, because that - ---- generates JXX_GBLs which we can't fix up in x86fp_kludge. - let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced - - ---- generate jump tables - let tabled = - {-# SCC "generateJumpTables" #-} - generateJumpTables ncgImpl kludged - - ---- shortcut branches - let shorted = - {-# SCC "shortcutBranches" #-} - shortcutBranches dflags ncgImpl tabled - - ---- sequence blocks - let sequenced = - {-# SCC "sequenceBlocks" #-} - map (sequenceTop ncgImpl) shorted - - ---- expansion of SPARC synthetic instrs - let expanded = - {-# SCC "sparc_expand" #-} - ncgExpandTop ncgImpl sequenced - - dumpIfSet_dyn dflags - Opt_D_dump_asm_expanded "Synthetic instructions expanded" - (vcat $ map (pprNatCmmDecl ncgImpl) expanded) - - -- generate unwinding information from cmm - let unwinds :: BlockMap [UnwindPoint] - unwinds = - {-# SCC "unwindingInfo" #-} - foldl' addUnwind mapEmpty expanded - where - addUnwind acc proc = - acc `mapUnion` computeUnwinding dflags ncgImpl proc - - return ( usAlloc - , fileIds' - , expanded - , lastMinuteImports ++ imports - , ppr_raStatsColor - , ppr_raStatsLinear - , unwinds ) - - -x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -x86fp_kludge top@(CmmData _ _) = top -x86fp_kludge (CmmProc info lbl live (ListGraph code)) = - CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code) - --- | Compute unwinding tables for the blocks of a procedure -computeUnwinding :: Instruction instr - => DynFlags -> NcgImpl statics instr jumpDest - -> NatCmmDecl statics instr - -- ^ the native code generated for the procedure - -> LabelMap [UnwindPoint] - -- ^ unwinding tables for all points of all blocks of the - -- procedure -computeUnwinding dflags _ _ - | debugLevel dflags == 0 = mapEmpty -computeUnwinding _ _ (CmmData _ _) = mapEmpty -computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) = - -- In general we would need to push unwinding information down the - -- block-level call-graph to ensure that we fully account for all - -- relevant register writes within a procedure. - -- - -- However, the only unwinding information that we care about in GHC is for - -- Sp. The fact that CmmLayoutStack already ensures that we have unwind - -- information at the beginning of every block means that there is no need - -- to perform this sort of push-down. - mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs) - | BasicBlock blk_lbl instrs <- blks ] - --- | Build a doc for all the imports. --- -makeImportsDoc :: DynFlags -> [CLabel] -> SDoc -makeImportsDoc dflags imports - = dyld_stubs imports - $$ - -- On recent versions of Darwin, the linker supports - -- dead-stripping of code and data on a per-symbol basis. - -- There's a hack to make this work in PprMach.pprNatCmmDecl. - (if platformHasSubsectionsViaSymbols platform - then text ".subsections_via_symbols" - else Outputable.empty) - $$ - -- On recent GNU ELF systems one can mark an object file - -- as not requiring an executable stack. If all objects - -- linked into a program have this note then the program - -- will not use an executable stack, which is good for - -- security. GHC generated code does not need an executable - -- stack so add the note in: - (if platformHasGnuNonexecStack platform - then text ".section .note.GNU-stack,\"\",@progbits" - else Outputable.empty) - $$ - -- And just because every other compiler does, let's stick in - -- an identifier directive: .ident "GHC x.y.z" - (if platformHasIdentDirective platform - then let compilerIdent = text "GHC" <+> text cProjectVersion - in text ".ident" <+> doubleQuotes compilerIdent - else Outputable.empty) - - where - platform = targetPlatform dflags - arch = platformArch platform - os = platformOS platform - - -- Generate "symbol stubs" for all external symbols that might - -- come from a dynamic library. - dyld_stubs :: [CLabel] -> SDoc -{- dyld_stubs imps = vcat $ map pprDyldSymbolStub $ - map head $ group $ sort imps-} - -- (Hack) sometimes two Labels pretty-print the same, but have - -- different uniques; so we compare their text versions... - dyld_stubs imps - | needImportedSymbols dflags arch os - = vcat $ - (pprGotDeclaration dflags arch os :) $ - map ( pprImportedSymbol dflags platform . fst . head) $ - groupBy (\(_,a) (_,b) -> a == b) $ - sortBy (\(_,a) (_,b) -> compare a b) $ - map doPpr $ - imps - | otherwise - = Outputable.empty - - doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle) - astyle = mkCodeStyle AsmStyle - - --- ----------------------------------------------------------------------------- --- Sequencing the basic blocks - --- Cmm BasicBlocks are self-contained entities: they always end in a --- jump, either non-local or to another basic block in the same proc. --- In this phase, we attempt to place the basic blocks in a sequence --- such that as many of the local jumps as possible turn into --- fallthroughs. - -sequenceTop - :: Instruction instr - => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr - -sequenceTop _ top@(CmmData _ _) = top -sequenceTop ncgImpl (CmmProc info lbl live (ListGraph blocks)) = - CmmProc info lbl live (ListGraph $ ncgMakeFarBranches ncgImpl info $ sequenceBlocks info blocks) - --- The algorithm is very simple (and stupid): we make a graph out of --- the blocks where there is an edge from one block to another iff the --- first block ends by jumping to the second. Then we topologically --- sort this graph. Then traverse the list: for each block, we first --- output the block, then if it has an out edge, we move the --- destination of the out edge to the front of the list, and continue. - --- FYI, the classic layout for basic blocks uses postorder DFS; this --- algorithm is implemented in Hoopl. - -sequenceBlocks - :: Instruction instr - => LabelMap i - -> [NatBasicBlock instr] - -> [NatBasicBlock instr] - -sequenceBlocks _ [] = [] -sequenceBlocks infos (entry:blocks) = - seqBlocks infos (mkNode entry : reverse (flattenSCCs (sccBlocks blocks))) - -- the first block is the entry point ==> it must remain at the start. - - -sccBlocks - :: Instruction instr - => [NatBasicBlock instr] - -> [SCC ( NatBasicBlock instr - , BlockId - , [BlockId])] - -sccBlocks blocks = stronglyConnCompFromEdgedVerticesUniqR (map mkNode blocks) - --- we're only interested in the last instruction of --- the block, and only if it has a single destination. -getOutEdges - :: Instruction instr - => [instr] -> [BlockId] - -getOutEdges instrs - = case jumpDestsOfInstr (last instrs) of - [one] -> [one] - _many -> [] - -mkNode :: (Instruction t) - => GenBasicBlock t - -> (GenBasicBlock t, BlockId, [BlockId]) -mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs) - -seqBlocks :: LabelMap i -> [(GenBasicBlock t1, BlockId, [BlockId])] - -> [GenBasicBlock t1] -seqBlocks infos blocks = placeNext pullable0 todo0 - where - -- pullable: Blocks that are not yet placed - -- todo: Original order of blocks, to be followed if we have no good - -- reason not to; - -- may include blocks that have already been placed, but then - -- these are not in pullable - pullable0 = listToUFM [ (i,(b,n)) | (b,i,n) <- blocks ] - todo0 = [i | (_,i,_) <- blocks ] - - placeNext _ [] = [] - placeNext pullable (i:rest) - | Just (block, pullable') <- lookupDeleteUFM pullable i - = place pullable' rest block - | otherwise - -- We already placed this block, so ignore - = placeNext pullable rest - - place pullable todo (block,[]) - = block : placeNext pullable todo - place pullable todo (block@(BasicBlock id instrs),[next]) - | mapMember next infos - = block : placeNext pullable todo - | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next - = BasicBlock id (init instrs) : place pullable' todo nextBlock - | otherwise - = block : placeNext pullable todo - place _ _ (_,tooManyNextNodes) - = pprPanic "seqBlocks" (ppr tooManyNextNodes) - - -lookupDeleteUFM :: Uniquable key => UniqFM elt -> key -> Maybe (elt, UniqFM elt) -lookupDeleteUFM m k = do -- Maybe monad - v <- lookupUFM m k - return (v, delFromUFM m k) - --- ----------------------------------------------------------------------------- --- Generate jump tables - --- Analyzes all native code and generates data sections for all jump --- table instructions. -generateJumpTables - :: NcgImpl statics instr jumpDest - -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] -generateJumpTables ncgImpl xs = concatMap f xs - where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs - f p = [p] - g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs) - --- ----------------------------------------------------------------------------- --- Shortcut branches - -shortcutBranches - :: DynFlags - -> NcgImpl statics instr jumpDest - -> [NatCmmDecl statics instr] - -> [NatCmmDecl statics instr] - -shortcutBranches dflags ncgImpl tops - | optLevel dflags < 1 = tops -- only with -O or higher - | otherwise = map (apply_mapping ncgImpl mapping) tops' - where - (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops - mapping = foldr plusUFM emptyUFM mappings - -build_mapping :: NcgImpl statics instr jumpDest - -> GenCmmDecl d (LabelMap t) (ListGraph instr) - -> (GenCmmDecl d (LabelMap t) (ListGraph instr), UniqFM jumpDest) -build_mapping _ top@(CmmData _ _) = (top, emptyUFM) -build_mapping _ (CmmProc info lbl live (ListGraph [])) - = (CmmProc info lbl live (ListGraph []), emptyUFM) -build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks))) - = (CmmProc info lbl live (ListGraph (head:others)), mapping) - -- drop the shorted blocks, but don't ever drop the first one, - -- because it is pointed to by a global label. - where - -- find all the blocks that just consist of a jump that can be - -- shorted. - -- Don't completely eliminate loops here -- that can leave a dangling jump! - (_, shortcut_blocks, others) = - foldl split (setEmpty :: LabelSet, [], []) blocks - split (s, shortcut_blocks, others) b@(BasicBlock id [insn]) - | Just jd <- canShortcut ncgImpl insn, - Just dest <- getJumpDestBlockId ncgImpl jd, - not (has_info id), - (setMember dest s) || dest == id -- loop checks - = (s, shortcut_blocks, b : others) - split (s, shortcut_blocks, others) (BasicBlock id [insn]) - | Just dest <- canShortcut ncgImpl insn, - not (has_info id) - = (setInsert id s, (id,dest) : shortcut_blocks, others) - split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others) - - -- do not eliminate blocks that have an info table - has_info l = mapMember l info - - -- build a mapping from BlockId to JumpDest for shorting branches - mapping = foldl add emptyUFM shortcut_blocks - add ufm (id,dest) = addToUFM ufm id dest - -apply_mapping :: NcgImpl statics instr jumpDest - -> UniqFM jumpDest - -> GenCmmDecl statics h (ListGraph instr) - -> GenCmmDecl statics h (ListGraph instr) -apply_mapping ncgImpl ufm (CmmData sec statics) - = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics) -apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks)) - = CmmProc info lbl live (ListGraph $ map short_bb blocks) - where - short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns - short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i - -- shortcutJump should apply the mapping repeatedly, - -- just in case we can short multiple branches. - --- ----------------------------------------------------------------------------- --- Instruction selection - --- Native code instruction selection for a chunk of stix code. For --- this part of the computation, we switch from the UniqSM monad to --- the NatM monad. The latter carries not only a Unique, but also an --- Int denoting the current C stack pointer offset in the generated --- code; this is needed for creating correct spill offsets on --- architectures which don't offer, or for which it would be --- prohibitively expensive to employ, a frame pointer register. Viz, --- x86. - --- The offset is measured in bytes, and indicates the difference --- between the current (simulated) C stack-ptr and the value it was at --- the beginning of the block. For stacks which grow down, this value --- should be either zero or negative. - --- Along with the stack pointer offset, we also carry along a LabelMap of --- DebugBlocks, which we read to generate .location directives. --- --- Switching between the two monads whilst carrying along the same --- Unique supply breaks abstraction. Is that bad? - -genMachCode - :: DynFlags - -> Module -> ModLocation - -> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) - -> DwarfFiles - -> LabelMap DebugBlock - -> RawCmmDecl - -> UniqSM - ( [NatCmmDecl statics instr] - , [CLabel] - , DwarfFiles) - -genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top - = do { initial_us <- getUniqueSupplyM - ; let initial_st = mkNatM_State initial_us 0 dflags this_mod - modLoc fileIds dbgMap - (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) - final_delta = natm_delta final_st - final_imports = natm_imports final_st - ; if final_delta == 0 - then return (new_tops, final_imports, natm_fileid final_st) - else pprPanic "genMachCode: nonzero final delta" (int final_delta) - } - --- ----------------------------------------------------------------------------- --- Generic Cmm optimiser - -{- -Here we do: - - (a) Constant folding - (c) Position independent code and dynamic linking - (i) introduce the appropriate indirections - and position independent refs - (ii) compile a list of imported symbols - (d) Some arch-specific optimizations - -(a) will be moving to the new Hoopl pipeline, however, (c) and -(d) are only needed by the native backend and will continue to live -here. - -Ideas for other things we could do (put these in Hoopl please!): - - - shortcut jumps-to-jumps - - simple CSE: if an expr is assigned to a temp, then replace later occs of - that expr with the temp, until the expr is no longer valid (can push through - temp assignments, and certain assigns to mem...) --} - -cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel]) -cmmToCmm _ _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags this_mod (CmmProc info lbl live graph) - = runCmmOpt dflags this_mod $ - do blocks' <- mapM cmmBlockConFold (toBlockList graph) - return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') - -newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #)) - -instance Functor CmmOptM where - fmap = liftM - -instance Applicative CmmOptM where - pure x = CmmOptM $ \_ _ imports -> (# x, imports #) - (<*>) = ap - -instance Monad CmmOptM where - (CmmOptM f) >>= g = - CmmOptM $ \dflags this_mod imports -> - case f dflags this_mod imports of - (# x, imports' #) -> - case g x of - CmmOptM g' -> g' dflags this_mod imports' - -instance CmmMakeDynamicReferenceM CmmOptM where - addImport = addImportCmmOpt - getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #) - -addImportCmmOpt :: CLabel -> CmmOptM () -addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #) - -instance HasDynFlags CmmOptM where - getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #) - -runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel]) -runCmmOpt dflags this_mod (CmmOptM f) = case f dflags this_mod [] of - (# result, imports #) -> (result, imports) - -cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock -cmmBlockConFold block = do - let (entry, middle, last) = blockSplit block - stmts = blockToList middle - stmts' <- mapM cmmStmtConFold stmts - last' <- cmmStmtConFold last - return $ blockJoin entry (blockFromList stmts') last' - --- This does three optimizations, but they're very quick to check, so we don't --- bother turning them off even when the Hoopl code is active. Since --- this is on the old Cmm representation, we can't reuse the code either: --- * reg = reg --> nop --- * if 0 then jump --> nop --- * if 1 then jump --> jump --- We might be tempted to skip this step entirely of not Opt_PIC, but --- there is some PowerPC code for the non-PIC case, which would also --- have to be separated. -cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x) -cmmStmtConFold stmt - = case stmt of - CmmAssign reg src - -> do src' <- cmmExprConFold DataReference src - return $ case src' of - CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop") - new_src -> CmmAssign reg new_src - - CmmStore addr src - -> do addr' <- cmmExprConFold DataReference addr - src' <- cmmExprConFold DataReference src - return $ CmmStore addr' src' - - CmmCall { cml_target = addr } - -> do addr' <- cmmExprConFold JumpReference addr - return $ stmt { cml_target = addr' } - - CmmUnsafeForeignCall target regs args - -> do target' <- case target of - ForeignTarget e conv -> do - e' <- cmmExprConFold CallReference e - return $ ForeignTarget e' conv - PrimTarget _ -> - return target - args' <- mapM (cmmExprConFold DataReference) args - return $ CmmUnsafeForeignCall target' regs args' - - CmmCondBranch test true false likely - -> do test' <- cmmExprConFold DataReference test - return $ case test' of - CmmLit (CmmInt 0 _) -> CmmBranch false - CmmLit (CmmInt _ _) -> CmmBranch true - _other -> CmmCondBranch test' true false likely - - CmmSwitch expr ids - -> do expr' <- cmmExprConFold DataReference expr - return $ CmmSwitch expr' ids - - other - -> return other - -cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr -cmmExprConFold referenceKind expr = do - dflags <- getDynFlags - - -- With -O1 and greater, the cmmSink pass does constant-folding, so - -- we don't need to do it again here. - let expr' = if optLevel dflags >= 1 - then expr - else cmmExprCon dflags expr - - cmmExprNative referenceKind expr' - -cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr -cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep -cmmExprCon dflags (CmmMachOp mop args) - = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args) -cmmExprCon _ other = other - --- handles both PIC and non-PIC cases... a very strange mixture --- of things to do. -cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr -cmmExprNative referenceKind expr = do - dflags <- getDynFlags - let platform = targetPlatform dflags - arch = platformArch platform - case expr of - CmmLoad addr rep - -> do addr' <- cmmExprNative DataReference addr - return $ CmmLoad addr' rep - - CmmMachOp mop args - -> do args' <- mapM (cmmExprNative DataReference) args - return $ CmmMachOp mop args' - - CmmLit (CmmBlock id) - -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id))) - -- we must convert block Ids to CLabels here, because we - -- might have to do the PIC transformation. Hence we must - -- not modify BlockIds beyond this point. - - CmmLit (CmmLabel lbl) - -> do - cmmMakeDynamicReference dflags referenceKind lbl - CmmLit (CmmLabelOff lbl off) - -> do - dynRef <- cmmMakeDynamicReference dflags referenceKind lbl - -- need to optimize here, since it's late - return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [ - dynRef, - (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags)) - ] - - -- On powerpc (non-PIC), it's easier to jump directly to a label than - -- to use the register table, so we replace these registers - -- with the corresponding labels: - CmmReg (CmmGlobal EagerBlackholeInfo) - | arch == ArchPPC && not (positionIndependent dflags) - -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info"))) - CmmReg (CmmGlobal GCEnter1) - | arch == ArchPPC && not (positionIndependent dflags) - -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1"))) - CmmReg (CmmGlobal GCFun) - | arch == ArchPPC && not (positionIndependent dflags) - -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun"))) - - other - -> return other diff --git a/nativeGen/CPrim.hs b/nativeGen/CPrim.hs deleted file mode 100644 --- a/nativeGen/CPrim.hs +++ /dev/null @@ -1,101 +0,0 @@ --- | Generating C symbol names emitted by the compiler. -module CPrim - ( atomicReadLabel - , atomicWriteLabel - , atomicRMWLabel - , cmpxchgLabel - , popCntLabel - , bSwapLabel - , clzLabel - , ctzLabel - , word2FloatLabel - ) where - -import CmmType -import CmmMachOp -import Outputable - -popCntLabel :: Width -> String -popCntLabel w = "hs_popcnt" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "popCntLabel: Unsupported word width " (ppr w) - -bSwapLabel :: Width -> String -bSwapLabel w = "hs_bswap" ++ pprWidth w - where - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "bSwapLabel: Unsupported word width " (ppr w) - -clzLabel :: Width -> String -clzLabel w = "hs_clz" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "clzLabel: Unsupported word width " (ppr w) - -ctzLabel :: Width -> String -ctzLabel w = "hs_ctz" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "ctzLabel: Unsupported word width " (ppr w) - -word2FloatLabel :: Width -> String -word2FloatLabel w = "hs_word2float" ++ pprWidth w - where - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "word2FloatLabel: Unsupported word width " (ppr w) - -atomicRMWLabel :: Width -> AtomicMachOp -> String -atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) - - pprFunName AMO_Add = "add" - pprFunName AMO_Sub = "sub" - pprFunName AMO_And = "and" - pprFunName AMO_Nand = "nand" - pprFunName AMO_Or = "or" - pprFunName AMO_Xor = "xor" - -cmpxchgLabel :: Width -> String -cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) - -atomicReadLabel :: Width -> String -atomicReadLabel w = "hs_atomicread" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "atomicReadLabel: Unsupported word width " (ppr w) - -atomicWriteLabel :: Width -> String -atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w) diff --git a/nativeGen/Dwarf.hs b/nativeGen/Dwarf.hs deleted file mode 100644 --- a/nativeGen/Dwarf.hs +++ /dev/null @@ -1,259 +0,0 @@ -module Dwarf ( - dwarfGen - ) where - -import CLabel -import CmmExpr ( GlobalReg(..) ) -import Config ( cProjectName, cProjectVersion ) -import CoreSyn ( Tickish(..) ) -import Debug -import DynFlags -import Module -import Outputable -import Platform -import Unique -import UniqSupply - -import Dwarf.Constants -import Dwarf.Types - -import Control.Arrow ( first ) -import Control.Monad ( mfilter ) -import Data.Maybe -import Data.List ( sortBy ) -import Data.Ord ( comparing ) -import qualified Data.Map as Map -import System.FilePath -import System.Directory ( getCurrentDirectory ) - -import qualified Compiler.Hoopl as H - --- | Generate DWARF/debug information -dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock] - -> IO (SDoc, UniqSupply) -dwarfGen _ _ us [] = return (empty, us) -dwarfGen df modLoc us blocks = do - - -- Convert debug data structures to DWARF info records - -- We strip out block information when running with -g0 or -g1. - let procs = debugSplitProcs blocks - stripBlocks dbg - | debugLevel df < 2 = dbg { dblBlocks = [] } - | otherwise = dbg - compPath <- getCurrentDirectory - let lowLabel = dblCLabel $ head procs - highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs - dwarfUnit = DwarfCompileUnit - { dwChildren = map (procToDwarf df) (map stripBlocks procs) - , dwName = fromMaybe "" (ml_hs_file modLoc) - , dwCompDir = addTrailingPathSeparator compPath - , dwProducer = cProjectName ++ " " ++ cProjectVersion - , dwLowLabel = lowLabel - , dwHighLabel = highLabel - , dwLineLabel = dwarfLineLabel - } - - -- Check whether we have any source code information, so we do not - -- end up writing a pointer to an empty .debug_line section - -- (dsymutil on Mac Os gets confused by this). - let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk) - || any haveSrcIn (dblBlocks blk) - haveSrc = any haveSrcIn procs - - -- .debug_abbrev section: Declare the format we're using - let abbrevSct = pprAbbrevDecls haveSrc - - -- .debug_info section: Information records on procedures and blocks - let -- unique to identify start and end compilation unit .debug_inf - (unitU, us') = takeUniqFromSupply us - infoSct = vcat [ ptext dwarfInfoLabel <> colon - , dwarfInfoSection - , compileUnitHeader unitU - , pprDwarfInfo haveSrc dwarfUnit - , compileUnitFooter unitU - ] - - -- .debug_line section: Generated mainly by the assembler, but we - -- need to label it - let lineSct = dwarfLineSection $$ - ptext dwarfLineLabel <> colon - - -- .debug_frame section: Information about the layout of the GHC stack - let (framesU, us'') = takeUniqFromSupply us' - frameSct = dwarfFrameSection $$ - ptext dwarfFrameLabel <> colon $$ - pprDwarfFrame (debugFrame framesU procs) - - -- .aranges section: Information about the bounds of compilation units - let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs - | otherwise = [DwarfARange lowLabel highLabel] - let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU - - return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'') - --- | Build an address range entry for one proc. --- With split sections, each proc needs its own entry, since they may get --- scattered in the final binary. Without split sections, we could make a --- single arange based on the first/last proc. -mkDwarfARange :: DebugBlock -> DwarfARange -mkDwarfARange proc = DwarfARange start end - where - start = dblCLabel proc - end = mkAsmTempEndLabel start - --- | Header for a compilation unit, establishing global format --- parameters -compileUnitHeader :: Unique -> SDoc -compileUnitHeader unitU = sdocWithPlatform $ \plat -> - let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field - length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel - <> text "-4" -- length of initialLength field - in vcat [ ppr cuLabel <> colon - , text "\t.long " <> length -- compilation unit size - , pprHalf 3 -- DWARF version - , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel) - -- abbrevs offset - , text "\t.byte " <> ppr (platformWordSize plat) -- word size - ] - --- | Compilation unit footer, mainly establishing size of debug sections -compileUnitFooter :: Unique -> SDoc -compileUnitFooter unitU = - let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU - in ppr cuEndLabel <> colon - --- | Splits the blocks by procedures. In the result all nested blocks --- will come from the same procedure as the top-level block. See --- Note [Splitting DebugBlocks] for details. -debugSplitProcs :: [DebugBlock] -> [DebugBlock] -debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b - where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty - split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock] - split parent blk = H.mapInsert prc [blk'] nested - where prc = dblProcedure blk - blk' = blk { dblBlocks = own_blks - , dblParent = parent - } - own_blks = fromMaybe [] $ H.mapLookup prc nested - nested = mergeMaps $ map (split parent') $ dblBlocks blk - -- Figure out who should be the parent of nested blocks. - -- If @blk@ is optimized out then it isn't a good choice - -- and we just use its parent. - parent' - | Nothing <- dblPosition blk = parent - | otherwise = Just blk - -{- -Note [Splitting DebugBlocks] - -DWARF requires that we break up the the nested DebugBlocks produced from -the C-- AST. For instance, we begin with tick trees containing nested procs. -For example, - - proc A [tick1, tick2] - block B [tick3] - proc C [tick4] - -when producing DWARF we need to procs (which are represented in DWARF as -TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for -this transform, pulling out the nested procs into top-level procs. - -However, in doing this we need to be careful to preserve the parentage of the -nested procs. This is the reason DebugBlocks carry the dblParent field, allowing -us to reorganize the above tree as, - - proc A [tick1, tick2] - block B [tick3] - proc C [tick4] parent=B - -Here we have annotated the new proc C with an attribute giving its original -parent, B. --} - --- | Generate DWARF info for a procedure debug block -procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo -procToDwarf df prc - = DwarfSubprogram { dwChildren = map (blockToDwarf df) (dblBlocks prc) - , dwName = case dblSourceTick prc of - Just s@SourceNote{} -> sourceName s - _otherwise -> showSDocDump df $ ppr $ dblLabel prc - , dwLabel = dblCLabel prc - , dwParent = fmap mkAsmTempDieLabel - $ mfilter (/= dblCLabel prc) - $ fmap dblCLabel (dblParent prc) - -- Omit parent if it would be self-referential - } - --- | Generate DWARF info for a block -blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo -blockToDwarf df blk - = DwarfBlock { dwChildren = concatMap (tickToDwarf df) (dblTicks blk) - ++ map (blockToDwarf df) (dblBlocks blk) - , dwLabel = dblCLabel blk - , dwMarker = marker - } - where - marker - | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk - | otherwise = Nothing -- block was optimized out - -tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo] -tickToDwarf _ (SourceNote ss _) = [DwarfSrcNote ss] -tickToDwarf _ _ = [] - --- | Generates the data for the debug frame section, which encodes the --- desired stack unwind behaviour for the debugger -debugFrame :: Unique -> [DebugBlock] -> DwarfFrame -debugFrame u procs - = DwarfFrame { dwCieLabel = mkAsmTempLabel u - , dwCieInit = initUws - , dwCieProcs = map (procToFrame initUws) procs - } - where - initUws :: UnwindTable - initUws = Map.fromList [(Sp, Just (UwReg Sp 0))] - --- | Generates unwind information for a procedure debug block -procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc -procToFrame initUws blk - = DwarfFrameProc { dwFdeProc = dblCLabel blk - , dwFdeHasInfo = dblHasInfoTbl blk - , dwFdeBlocks = map (uncurry blockToFrame) - (setHasInfo blockUws) - } - where blockUws :: [(DebugBlock, [UnwindPoint])] - blockUws = map snd $ sortBy (comparing fst) $ flatten blk - - flatten :: DebugBlock - -> [(Int, (DebugBlock, [UnwindPoint]))] - flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks } - | Just p <- pos = (p, (b, uws')):nested - | otherwise = nested -- block was optimized out - where uws' = addDefaultUnwindings initUws uws - nested = concatMap flatten blocks - - -- | If the current procedure has an info table, then we also say that - -- its first block has one to ensure that it gets the necessary -1 - -- offset applied to its start address. - -- See Note [Info Offset] in Dwarf.Types. - setHasInfo :: [(DebugBlock, [UnwindPoint])] - -> [(DebugBlock, [UnwindPoint])] - setHasInfo [] = [] - setHasInfo (c0:cs) = first setIt c0 : cs - where - setIt child = - child { dblHasInfoTbl = dblHasInfoTbl child - || dblHasInfoTbl blk } - -blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock -blockToFrame blk uws - = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk - , dwFdeUnwind = uws - } - -addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint] -addDefaultUnwindings tbl pts = - [ UnwindPoint lbl (tbl' `mappend` tbl) - -- mappend is left-biased - | UnwindPoint lbl tbl' <- pts - ] diff --git a/nativeGen/Dwarf/Constants.hs b/nativeGen/Dwarf/Constants.hs deleted file mode 100644 --- a/nativeGen/Dwarf/Constants.hs +++ /dev/null @@ -1,225 +0,0 @@ --- | Constants describing the DWARF format. Most of this simply --- mirrors /usr/include/dwarf.h. - -module Dwarf.Constants where - -import FastString -import Platform -import Outputable - -import Reg -import X86.Regs - -import Data.Word - --- | Language ID used for Haskell. -dW_LANG_Haskell :: Word -dW_LANG_Haskell = 0x18 - -- Thanks to Nathan Howell for getting us our very own language ID! - --- * Dwarf tags -dW_TAG_compile_unit, dW_TAG_subroutine_type, - dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block, - dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type, - dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef, - dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable, - dW_TAG_ghc_src_note :: Word -dW_TAG_array_type = 1 -dW_TAG_lexical_block = 11 -dW_TAG_pointer_type = 15 -dW_TAG_compile_unit = 17 -dW_TAG_structure_type = 19 -dW_TAG_typedef = 22 -dW_TAG_subroutine_type = 32 -dW_TAG_subrange_type = 33 -dW_TAG_base_type = 36 -dW_TAG_file_type = 41 -dW_TAG_subprogram = 46 -dW_TAG_variable = 52 -dW_TAG_auto_variable = 256 -dW_TAG_arg_variable = 257 - -dW_TAG_ghc_src_note = 0x5b00 - --- * Dwarf attributes -dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language, - dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base, - dW_AT_use_UTF8, dW_AT_MIPS_linkage_name :: Word -dW_AT_name = 0x03 -dW_AT_stmt_list = 0x10 -dW_AT_low_pc = 0x11 -dW_AT_high_pc = 0x12 -dW_AT_language = 0x13 -dW_AT_comp_dir = 0x1b -dW_AT_producer = 0x25 -dW_AT_external = 0x3f -dW_AT_frame_base = 0x40 -dW_AT_use_UTF8 = 0x53 -dW_AT_MIPS_linkage_name = 0x2007 - --- * Custom DWARF attributes --- Chosen a more or less random section of the vendor-extensible region - --- ** Describing C-- blocks --- These appear in DW_TAG_lexical_scope DIEs corresponding to C-- blocks -dW_AT_ghc_tick_parent :: Word -dW_AT_ghc_tick_parent = 0x2b20 - --- ** Describing source notes --- These appear in DW_TAG_ghc_src_note DIEs -dW_AT_ghc_span_file, dW_AT_ghc_span_start_line, - dW_AT_ghc_span_start_col, dW_AT_ghc_span_end_line, - dW_AT_ghc_span_end_col :: Word -dW_AT_ghc_span_file = 0x2b00 -dW_AT_ghc_span_start_line = 0x2b01 -dW_AT_ghc_span_start_col = 0x2b02 -dW_AT_ghc_span_end_line = 0x2b03 -dW_AT_ghc_span_end_col = 0x2b04 - - --- * Abbrev declarations -dW_CHILDREN_no, dW_CHILDREN_yes :: Word8 -dW_CHILDREN_no = 0 -dW_CHILDREN_yes = 1 - -dW_FORM_addr, dW_FORM_data2, dW_FORM_data4, dW_FORM_string, dW_FORM_flag, - dW_FORM_block1, dW_FORM_ref4, dW_FORM_ref_addr, dW_FORM_flag_present :: Word -dW_FORM_addr = 0x01 -dW_FORM_data2 = 0x05 -dW_FORM_data4 = 0x06 -dW_FORM_string = 0x08 -dW_FORM_flag = 0x0c -dW_FORM_block1 = 0x0a -dW_FORM_ref_addr = 0x10 -dW_FORM_ref4 = 0x13 -dW_FORM_flag_present = 0x19 - --- * Dwarf native types -dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed, - dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word -dW_ATE_address = 1 -dW_ATE_boolean = 2 -dW_ATE_float = 4 -dW_ATE_signed = 5 -dW_ATE_signed_char = 6 -dW_ATE_unsigned = 7 -dW_ATE_unsigned_char = 8 - --- * Call frame information -dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value, - dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression, - dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf, - dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression, - dW_CFA_offset :: Word8 -dW_CFA_set_loc = 0x01 -dW_CFA_undefined = 0x07 -dW_CFA_same_value = 0x08 -dW_CFA_def_cfa = 0x0c -dW_CFA_def_cfa_offset = 0x0e -dW_CFA_def_cfa_expression = 0x0f -dW_CFA_expression = 0x10 -dW_CFA_offset_extended_sf = 0x11 -dW_CFA_def_cfa_sf = 0x12 -dW_CFA_def_cfa_offset_sf = 0x13 -dW_CFA_val_offset = 0x14 -dW_CFA_val_expression = 0x16 -dW_CFA_offset = 0x80 - --- * Operations -dW_OP_addr, dW_OP_deref, dW_OP_consts, - dW_OP_minus, dW_OP_mul, dW_OP_plus, - dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8 -dW_OP_addr = 0x03 -dW_OP_deref = 0x06 -dW_OP_consts = 0x11 -dW_OP_minus = 0x1c -dW_OP_mul = 0x1e -dW_OP_plus = 0x22 -dW_OP_lit0 = 0x30 -dW_OP_breg0 = 0x70 -dW_OP_call_frame_cfa = 0x9c - --- * Dwarf section declarations -dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection, - dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc -dwarfInfoSection = dwarfSection "info" -dwarfAbbrevSection = dwarfSection "abbrev" -dwarfLineSection = dwarfSection "line" -dwarfFrameSection = dwarfSection "frame" -dwarfGhcSection = dwarfSection "ghc" -dwarfARangesSection = dwarfSection "aranges" - -dwarfSection :: String -> SDoc -dwarfSection name = sdocWithPlatform $ \plat -> ftext $ mkFastString $ - case platformOS plat of - os | osElfTarget os - -> "\t.section .debug_" ++ name ++ ",\"\",@progbits" - | osMachOTarget os - -> "\t.section __DWARF,__debug_" ++ name ++ ",regular,debug" - | otherwise - -> "\t.section .debug_" ++ name ++ ",\"dr\"" - --- * Dwarf section labels -dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: LitString -dwarfInfoLabel = sLit ".Lsection_info" -dwarfAbbrevLabel = sLit ".Lsection_abbrev" -dwarfLineLabel = sLit ".Lsection_line" -dwarfFrameLabel = sLit ".Lsection_frame" - --- | Mapping of registers to DWARF register numbers -dwarfRegNo :: Platform -> Reg -> Word8 -dwarfRegNo p r = case platformArch p of - ArchX86 - | r == eax -> 0 - | r == ecx -> 1 -- yes, no typo - | r == edx -> 2 - | r == ebx -> 3 - | r == esp -> 4 - | r == ebp -> 5 - | r == esi -> 6 - | r == edi -> 7 - ArchX86_64 - | r == rax -> 0 - | r == rdx -> 1 -- this neither. The order GCC allocates registers in? - | r == rcx -> 2 - | r == rbx -> 3 - | r == rsi -> 4 - | r == rdi -> 5 - | r == rbp -> 6 - | r == rsp -> 7 - | r == r8 -> 8 - | r == r9 -> 9 - | r == r10 -> 10 - | r == r11 -> 11 - | r == r12 -> 12 - | r == r13 -> 13 - | r == r14 -> 14 - | r == r15 -> 15 - | r == xmm0 -> 17 - | r == xmm1 -> 18 - | r == xmm2 -> 19 - | r == xmm3 -> 20 - | r == xmm4 -> 21 - | r == xmm5 -> 22 - | r == xmm6 -> 23 - | r == xmm7 -> 24 - | r == xmm8 -> 25 - | r == xmm9 -> 26 - | r == xmm10 -> 27 - | r == xmm11 -> 28 - | r == xmm12 -> 29 - | r == xmm13 -> 30 - | r == xmm14 -> 31 - | r == xmm15 -> 32 - _other -> error "dwarfRegNo: Unsupported platform or unknown register!" - --- | Virtual register number to use for return address. -dwarfReturnRegNo :: Platform -> Word8 -dwarfReturnRegNo p - -- We "overwrite" IP with our pseudo register - that makes sense, as - -- when using this mechanism gdb already knows the IP anyway. Clang - -- does this too, so it must be safe. - = case platformArch p of - ArchX86 -> 8 -- eip - ArchX86_64 -> 16 -- rip - _other -> error "dwarfReturnRegNo: Unsupported platform!" diff --git a/nativeGen/Dwarf/Types.hs b/nativeGen/Dwarf/Types.hs deleted file mode 100644 --- a/nativeGen/Dwarf/Types.hs +++ /dev/null @@ -1,602 +0,0 @@ -module Dwarf.Types - ( -- * Dwarf information - DwarfInfo(..) - , pprDwarfInfo - , pprAbbrevDecls - -- * Dwarf address range table - , DwarfARange(..) - , pprDwarfARanges - -- * Dwarf frame - , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..) - , pprDwarfFrame - -- * Utilities - , pprByte - , pprHalf - , pprData4' - , pprDwWord - , pprWord - , pprLEBWord - , pprLEBInt - , wordAlign - , sectionOffset - ) - where - -import Debug -import CLabel -import CmmExpr ( GlobalReg(..) ) -import Encoding -import FastString -import Outputable -import Platform -import Unique -import Reg -import SrcLoc - -import Dwarf.Constants - -import qualified Control.Monad.Trans.State.Strict as S -import Control.Monad (zipWithM, join) -import Data.Bits -import qualified Data.Map as Map -import Data.Word -import Data.Char - -import CodeGen.Platform - --- | Individual dwarf records. Each one will be encoded as an entry in --- the @.debug_info@ section. -data DwarfInfo - = DwarfCompileUnit { dwChildren :: [DwarfInfo] - , dwName :: String - , dwProducer :: String - , dwCompDir :: String - , dwLowLabel :: CLabel - , dwHighLabel :: CLabel - , dwLineLabel :: LitString } - | DwarfSubprogram { dwChildren :: [DwarfInfo] - , dwName :: String - , dwLabel :: CLabel - , dwParent :: Maybe CLabel - -- ^ label of DIE belonging to the parent tick - } - | DwarfBlock { dwChildren :: [DwarfInfo] - , dwLabel :: CLabel - , dwMarker :: Maybe CLabel - } - | DwarfSrcNote { dwSrcSpan :: RealSrcSpan - } - --- | Abbreviation codes used for encoding above records in the --- @.debug_info@ section. -data DwarfAbbrev - = DwAbbrNull -- ^ Pseudo, used for marking the end of lists - | DwAbbrCompileUnit - | DwAbbrSubprogram - | DwAbbrSubprogramWithParent - | DwAbbrBlockWithoutCode - | DwAbbrBlock - | DwAbbrGhcSrcNote - deriving (Eq, Enum) - --- | Generate assembly for the given abbreviation code -pprAbbrev :: DwarfAbbrev -> SDoc -pprAbbrev = pprLEBWord . fromIntegral . fromEnum - --- | Abbreviation declaration. This explains the binary encoding we --- use for representing 'DwarfInfo'. Be aware that this must be updated --- along with 'pprDwarfInfo'. -pprAbbrevDecls :: Bool -> SDoc -pprAbbrevDecls haveDebugLine = - let mkAbbrev abbr tag chld flds = - let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form - in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$ - vcat (map fld flds) $$ pprByte 0 $$ pprByte 0 - -- These are shared between DwAbbrSubprogram and - -- DwAbbrSubprogramWithParent - subprogramAttrs = - [ (dW_AT_name, dW_FORM_string) - , (dW_AT_MIPS_linkage_name, dW_FORM_string) - , (dW_AT_external, dW_FORM_flag) - , (dW_AT_low_pc, dW_FORM_addr) - , (dW_AT_high_pc, dW_FORM_addr) - , (dW_AT_frame_base, dW_FORM_block1) - ] - in dwarfAbbrevSection $$ - ptext dwarfAbbrevLabel <> colon $$ - mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes - ([(dW_AT_name, dW_FORM_string) - , (dW_AT_producer, dW_FORM_string) - , (dW_AT_language, dW_FORM_data4) - , (dW_AT_comp_dir, dW_FORM_string) - , (dW_AT_use_UTF8, dW_FORM_flag_present) -- not represented in body - , (dW_AT_low_pc, dW_FORM_addr) - , (dW_AT_high_pc, dW_FORM_addr) - ] ++ - (if haveDebugLine - then [ (dW_AT_stmt_list, dW_FORM_data4) ] - else [])) $$ - mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes - subprogramAttrs $$ - mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes - (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$ - mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes - [ (dW_AT_name, dW_FORM_string) - ] $$ - mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes - [ (dW_AT_name, dW_FORM_string) - , (dW_AT_low_pc, dW_FORM_addr) - , (dW_AT_high_pc, dW_FORM_addr) - ] $$ - mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no - [ (dW_AT_ghc_span_file, dW_FORM_string) - , (dW_AT_ghc_span_start_line, dW_FORM_data4) - , (dW_AT_ghc_span_start_col, dW_FORM_data2) - , (dW_AT_ghc_span_end_line, dW_FORM_data4) - , (dW_AT_ghc_span_end_col, dW_FORM_data2) - ] $$ - pprByte 0 - --- | Generate assembly for DWARF data -pprDwarfInfo :: Bool -> DwarfInfo -> SDoc -pprDwarfInfo haveSrc d - = case d of - DwarfCompileUnit {} -> hasChildren - DwarfSubprogram {} -> hasChildren - DwarfBlock {} -> hasChildren - DwarfSrcNote {} -> noChildren - where - hasChildren = - pprDwarfInfoOpen haveSrc d $$ - vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$ - pprDwarfInfoClose - noChildren = pprDwarfInfoOpen haveSrc d - --- | Prints assembler data corresponding to DWARF info records. Note --- that the binary format of this is parameterized in @abbrevDecls@ and --- has to be kept in synch. -pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc -pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel - highLabel lineLbl) = - pprAbbrev DwAbbrCompileUnit - $$ pprString name - $$ pprString producer - $$ pprData4 dW_LANG_Haskell - $$ pprString compDir - $$ pprWord (ppr lowLabel) - $$ pprWord (ppr highLabel) - $$ if haveSrc - then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel) - else empty -pprDwarfInfoOpen _ (DwarfSubprogram _ name label - parent) = sdocWithDynFlags $ \df -> - ppr (mkAsmTempDieLabel label) <> colon - $$ pprAbbrev abbrev - $$ pprString name - $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle)) - $$ pprFlag (externallyVisibleCLabel label) - $$ pprWord (ppr label) - $$ pprWord (ppr $ mkAsmTempEndLabel label) - $$ pprByte 1 - $$ pprByte dW_OP_call_frame_cfa - $$ parentValue - where - abbrev = case parent of Nothing -> DwAbbrSubprogram - Just _ -> DwAbbrSubprogramWithParent - parentValue = maybe empty pprParentDie parent - pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel) -pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df -> - ppr (mkAsmTempDieLabel label) <> colon - $$ pprAbbrev DwAbbrBlockWithoutCode - $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle)) -pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df -> - ppr (mkAsmTempDieLabel label) <> colon - $$ pprAbbrev DwAbbrBlock - $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle)) - $$ pprWord (ppr marker) - $$ pprWord (ppr $ mkAsmTempEndLabel marker) -pprDwarfInfoOpen _ (DwarfSrcNote ss) = - pprAbbrev DwAbbrGhcSrcNote - $$ pprString' (ftext $ srcSpanFile ss) - $$ pprData4 (fromIntegral $ srcSpanStartLine ss) - $$ pprHalf (fromIntegral $ srcSpanStartCol ss) - $$ pprData4 (fromIntegral $ srcSpanEndLine ss) - $$ pprHalf (fromIntegral $ srcSpanEndCol ss) - --- | Close a DWARF info record with children -pprDwarfInfoClose :: SDoc -pprDwarfInfoClose = pprAbbrev DwAbbrNull - --- | A DWARF address range. This is used by the debugger to quickly locate --- which compilation unit a given address belongs to. This type assumes --- a non-segmented address-space. -data DwarfARange - = DwarfARange - { dwArngStartLabel :: CLabel - , dwArngEndLabel :: CLabel - } - --- | Print assembler directives corresponding to a DWARF @.debug_aranges@ --- address table entry. -pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc -pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat -> - let wordSize = platformWordSize plat - paddingSize = 4 :: Int - -- header is 12 bytes long. - -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform). - -- pad such that first entry begins at multiple of entry size. - pad n = vcat $ replicate n $ pprByte 0 - initialLength = 8 + paddingSize + 2*2*wordSize - in pprDwWord (ppr initialLength) - $$ pprHalf 2 - $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU) - (ptext dwarfInfoLabel) - $$ pprByte (fromIntegral wordSize) - $$ pprByte 0 - $$ pad paddingSize - -- body - $$ vcat (map pprDwarfARange arngs) - -- terminus - $$ pprWord (char '0') - $$ pprWord (char '0') - -pprDwarfARange :: DwarfARange -> SDoc -pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length - where - length = ppr (dwArngEndLabel arng) - <> char '-' <> ppr (dwArngStartLabel arng) - --- | Information about unwind instructions for a procedure. This --- corresponds to a "Common Information Entry" (CIE) in DWARF. -data DwarfFrame - = DwarfFrame - { dwCieLabel :: CLabel - , dwCieInit :: UnwindTable - , dwCieProcs :: [DwarfFrameProc] - } - --- | Unwind instructions for an individual procedure. Corresponds to a --- "Frame Description Entry" (FDE) in DWARF. -data DwarfFrameProc - = DwarfFrameProc - { dwFdeProc :: CLabel - , dwFdeHasInfo :: Bool - , dwFdeBlocks :: [DwarfFrameBlock] - -- ^ List of blocks. Order must match asm! - } - --- | Unwind instructions for a block. Will become part of the --- containing FDE. -data DwarfFrameBlock - = DwarfFrameBlock - { dwFdeBlkHasInfo :: Bool - , dwFdeUnwind :: [UnwindPoint] - -- ^ these unwind points must occur in the same order as they occur - -- in the block - } - -instance Outputable DwarfFrameBlock where - ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds - --- | Header for the @.debug_frame@ section. Here we emit the "Common --- Information Entry" record that etablishes general call frame --- parameters and the default stack layout. -pprDwarfFrame :: DwarfFrame -> SDoc -pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} - = sdocWithPlatform $ \plat -> - let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start") - cieEndLabel = mkAsmTempEndLabel cieLabel - length = ppr cieEndLabel <> char '-' <> ppr cieStartLabel - spReg = dwarfGlobalRegNo plat Sp - retReg = dwarfReturnRegNo plat - wordSize = platformWordSize plat - pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc - pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw) - - -- Preserve C stack pointer: This necessary to override that default - -- unwinding behavior of setting $sp = CFA. - preserveSp = case platformArch plat of - ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4 - ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7 - _ -> empty - in vcat [ ppr cieLabel <> colon - , pprData4' length -- Length of CIE - , ppr cieStartLabel <> colon - , pprData4' (text "-1") - -- Common Information Entry marker (-1 = 0xf..f) - , pprByte 3 -- CIE version (we require DWARF 3) - , pprByte 0 -- Augmentation (none) - , pprByte 1 -- Code offset multiplicator - , pprByte (128-fromIntegral wordSize) - -- Data offset multiplicator - -- (stacks grow down => "-w" in signed LEB128) - , pprByte retReg -- virtual register holding return address - ] $$ - -- Initial unwind table - vcat (map pprInit $ Map.toList cieInit) $$ - vcat [ -- RET = *CFA - pprByte (dW_CFA_offset+retReg) - , pprByte 0 - - -- Preserve C stack pointer - , preserveSp - - -- Sp' = CFA - -- (we need to set this manually as our (STG) Sp register is - -- often not the architecture's default stack register) - , pprByte dW_CFA_val_offset - , pprLEBWord (fromIntegral spReg) - , pprLEBWord 0 - ] $$ - wordAlign $$ - ppr cieEndLabel <> colon $$ - -- Procedure unwind tables - vcat (map (pprFrameProc cieLabel cieInit) procs) - --- | Writes a "Frame Description Entry" for a procedure. This consists --- mainly of referencing the CIE and writing state machine --- instructions to describe how the frame base (CFA) changes. -pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc -pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) - = let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde") - fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end") - procEnd = mkAsmTempEndLabel procLbl - ifInfo str = if hasInfo then text str else empty - -- see [Note: Info Offset] - in vcat [ ifPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon - , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel) - , ppr fdeLabel <> colon - , pprData4' (ppr frameLbl <> char '-' <> - ptext dwarfFrameLabel) -- Reference to CIE - , pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer - , pprWord (ppr procEnd <> char '-' <> - ppr procLbl <> ifInfo "+1") -- Block byte length - ] $$ - vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$ - wordAlign $$ - ppr fdeEndLabel <> colon - --- | Generates unwind information for a block. We only generate --- instructions where unwind information actually changes. This small --- optimisations saves a lot of space, as subsequent blocks often have --- the same unwind information. -pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc -pprFrameBlock (DwarfFrameBlock hasInfo uws0) = - vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0 - where - pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc - pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws -> - let -- Did a register's unwind expression change? - isChanged :: GlobalReg -> Maybe UnwindExpr - -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr) - isChanged g new - -- the value didn't change - | Just new == old = Nothing - -- the value was and still is undefined - | Nothing <- old - , Nothing <- new = Nothing - -- the value changed - | otherwise = Just (join old, new) - where - old = Map.lookup g oldUws - - changed = Map.toList $ Map.mapMaybeWithKey isChanged uws - - in if oldUws == uws - then (empty, oldUws) - else let -- see [Note: Info Offset] - needsOffset = firstDecl && hasInfo - lblDoc = ppr lbl <> - if needsOffset then text "-1" else empty - doc = sdocWithPlatform $ \plat -> - pprByte dW_CFA_set_loc $$ pprWord lblDoc $$ - vcat (map (uncurry $ pprSetUnwind plat) changed) - in (doc, uws) - --- Note [Info Offset] --- --- GDB was pretty much written with C-like programs in mind, and as a --- result they assume that once you have a return address, it is a --- good idea to look at (PC-1) to unwind further - as that's where the --- "call" instruction is supposed to be. --- --- Now on one hand, code generated by GHC looks nothing like what GDB --- expects, and in fact going up from a return pointer is guaranteed --- to land us inside an info table! On the other hand, that actually --- gives us some wiggle room, as we expect IP to never *actually* end --- up inside the info table, so we can "cheat" by putting whatever GDB --- expects to see there. This is probably pretty safe, as GDB cannot --- assume (PC-1) to be a valid code pointer in the first place - and I --- have seen no code trying to correct this. --- --- Note that this will not prevent GDB from failing to look-up the --- correct function name for the frame, as that uses the symbol table, --- which we can not manipulate as easily. - --- | Get DWARF register ID for a given GlobalReg -dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8 -dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p -dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg - --- | Generate code for setting the unwind information for a register, --- optimized using its known old value in the table. Note that "Sp" is --- special: We see it as synonym for the CFA. -pprSetUnwind :: Platform - -> GlobalReg - -- ^ the register to produce an unwinding table entry for - -> (Maybe UnwindExpr, Maybe UnwindExpr) - -- ^ the old and new values of the register - -> SDoc -pprSetUnwind plat g (_, Nothing) - = pprUndefUnwind plat g -pprSetUnwind _ Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s' - = if o' >= 0 - then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o') - else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o' -pprSetUnwind plat Sp (_, Just (UwReg s' o')) - = if o' >= 0 - then pprByte dW_CFA_def_cfa $$ - pprLEBRegNo plat s' $$ - pprLEBWord (fromIntegral o') - else pprByte dW_CFA_def_cfa_sf $$ - pprLEBRegNo plat s' $$ - pprLEBInt o' -pprSetUnwind _ Sp (_, Just uw) - = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw -pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o))) - | o < 0 && ((-o) `mod` platformWordSize plat) == 0 -- expected case - = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$ - pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat)) - | otherwise - = pprByte dW_CFA_offset_extended_sf $$ - pprLEBRegNo plat g $$ - pprLEBInt o -pprSetUnwind plat g (_, Just (UwDeref uw)) - = pprByte dW_CFA_expression $$ - pprLEBRegNo plat g $$ - pprUnwindExpr True uw -pprSetUnwind plat g (_, Just (UwReg g' 0)) - | g == g' - = pprByte dW_CFA_same_value $$ - pprLEBRegNo plat g -pprSetUnwind plat g (_, Just uw) - = pprByte dW_CFA_val_expression $$ - pprLEBRegNo plat g $$ - pprUnwindExpr True uw - --- | Print the register number of the given 'GlobalReg' as an unsigned LEB128 --- encoded number. -pprLEBRegNo :: Platform -> GlobalReg -> SDoc -pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat - --- | Generates a DWARF expression for the given unwind expression. If --- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets --- mentioned. -pprUnwindExpr :: Bool -> UnwindExpr -> SDoc -pprUnwindExpr spIsCFA expr - = sdocWithPlatform $ \plat -> - let pprE (UwConst i) - | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i) - | otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy... - pprE (UwReg Sp i) | spIsCFA - = if i == 0 - then pprByte dW_OP_call_frame_cfa - else pprE (UwPlus (UwReg Sp 0) (UwConst i)) - pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$ - pprLEBInt i - pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref - pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord (ppr l) - pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus - pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus - pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul - in text "\t.uleb128 1f-.-1" $$ -- DW_FORM_block length - pprE expr $$ - text "1:" - --- | Generate code for re-setting the unwind information for a --- register to @undefined@ -pprUndefUnwind :: Platform -> GlobalReg -> SDoc -pprUndefUnwind plat g = pprByte dW_CFA_undefined $$ - pprLEBRegNo plat g - - --- | Align assembly at (machine) word boundary -wordAlign :: SDoc -wordAlign = sdocWithPlatform $ \plat -> - text "\t.align " <> case platformOS plat of - OSDarwin -> case platformWordSize plat of - 8 -> text "3" - 4 -> text "2" - _other -> error "wordAlign: Unsupported word size!" - _other -> ppr (platformWordSize plat) - --- | Assembly for a single byte of constant DWARF data -pprByte :: Word8 -> SDoc -pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word) - --- | Assembly for a two-byte constant integer -pprHalf :: Word16 -> SDoc -pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word) - --- | Assembly for a constant DWARF flag -pprFlag :: Bool -> SDoc -pprFlag f = pprByte (if f then 0xff else 0x00) - --- | Assembly for 4 bytes of dynamic DWARF data -pprData4' :: SDoc -> SDoc -pprData4' x = text "\t.long " <> x - --- | Assembly for 4 bytes of constant DWARF data -pprData4 :: Word -> SDoc -pprData4 = pprData4' . ppr - --- | Assembly for a DWARF word of dynamic data. This means 32 bit, as --- we are generating 32 bit DWARF. -pprDwWord :: SDoc -> SDoc -pprDwWord = pprData4' - --- | Assembly for a machine word of dynamic data. Depends on the --- architecture we are currently generating code for. -pprWord :: SDoc -> SDoc -pprWord s = (<> s) . sdocWithPlatform $ \plat -> - case platformWordSize plat of - 4 -> text "\t.long " - 8 -> text "\t.quad " - n -> panic $ "pprWord: Unsupported target platform word length " ++ - show n ++ "!" - --- | Prints a number in "little endian base 128" format. The idea is --- to optimize for small numbers by stopping once all further bytes --- would be 0. The highest bit in every byte signals whether there --- are further bytes to read. -pprLEBWord :: Word -> SDoc -pprLEBWord x | x < 128 = pprByte (fromIntegral x) - | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ - pprLEBWord (x `shiftR` 7) - --- | Same as @pprLEBWord@, but for a signed number -pprLEBInt :: Int -> SDoc -pprLEBInt x | x >= -64 && x < 64 - = pprByte (fromIntegral (x .&. 127)) - | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ - pprLEBInt (x `shiftR` 7) - --- | Generates a dynamic null-terminated string. If required the --- caller needs to make sure that the string is escaped properly. -pprString' :: SDoc -> SDoc -pprString' str = text "\t.asciz \"" <> str <> char '"' - --- | Generate a string constant. We take care to escape the string. -pprString :: String -> SDoc -pprString str - = pprString' $ hcat $ map escapeChar $ - if utf8EncodedLength str == length str - then str - else map (chr . fromIntegral) $ bytesFS $ mkFastString str - --- | Escape a single non-unicode character -escapeChar :: Char -> SDoc -escapeChar '\\' = text "\\\\" -escapeChar '\"' = text "\\\"" -escapeChar '\n' = text "\\n" -escapeChar c - | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings - = char c - | otherwise - = char '\\' <> char (intToDigit (ch `div` 64)) <> - char (intToDigit ((ch `div` 8) `mod` 8)) <> - char (intToDigit (ch `mod` 8)) - where ch = ord c - --- | Generate an offset into another section. This is tricky because --- this is handled differently depending on platform: Mac Os expects --- us to calculate the offset using assembler arithmetic. Linux expects --- us to just reference the target directly, and will figure out on --- their own that we actually need an offset. Finally, Windows has --- a special directive to refer to relative offsets. Fun. -sectionOffset :: SDoc -> SDoc -> SDoc -sectionOffset target section = sdocWithPlatform $ \plat -> - case platformOS plat of - OSDarwin -> pprDwWord (target <> char '-' <> section) - OSMinGW32 -> text "\t.secrel32 " <> target - _other -> pprDwWord target diff --git a/nativeGen/Format.hs b/nativeGen/Format.hs deleted file mode 100644 --- a/nativeGen/Format.hs +++ /dev/null @@ -1,104 +0,0 @@ --- | Formats on this architecture --- A Format is a combination of width and class --- --- TODO: Signed vs unsigned? --- --- TODO: This module is currenly shared by all architectures because --- NCGMonad need to know about it to make a VReg. It would be better --- to have architecture specific formats, and do the overloading --- properly. eg SPARC doesn't care about FF80. --- -module Format ( - Format(..), - intFormat, - floatFormat, - isFloatFormat, - cmmTypeFormat, - formatToWidth, - formatInBytes -) - -where - -import Cmm -import Outputable - --- It looks very like the old MachRep, but it's now of purely local --- significance, here in the native code generator. You can change it --- without global consequences. --- --- A major use is as an opcode qualifier; thus the opcode --- mov.l a b --- might be encoded --- MOV II32 a b --- where the Format field encodes the ".l" part. - --- ToDo: it's not clear to me that we need separate signed-vs-unsigned formats --- here. I've removed them from the x86 version, we'll see what happens --SDM - --- ToDo: quite a few occurrences of Format could usefully be replaced by Width - -data Format - = II8 - | II16 - | II32 - | II64 - | FF32 - | FF64 - | FF80 - deriving (Show, Eq) - - --- | Get the integer format of this width. -intFormat :: Width -> Format -intFormat width - = case width of - W8 -> II8 - W16 -> II16 - W32 -> II32 - W64 -> II64 - other -> sorry $ "The native code generator cannot " ++ - "produce code for Format.intFormat " ++ show other - ++ "\n\tConsider using the llvm backend with -fllvm" - - --- | Get the float format of this width. -floatFormat :: Width -> Format -floatFormat width - = case width of - W32 -> FF32 - W64 -> FF64 - other -> pprPanic "Format.floatFormat" (ppr other) - - --- | Check if a format represents a floating point value. -isFloatFormat :: Format -> Bool -isFloatFormat format - = case format of - FF32 -> True - FF64 -> True - FF80 -> True - _ -> False - - --- | Convert a Cmm type to a Format. -cmmTypeFormat :: CmmType -> Format -cmmTypeFormat ty - | isFloatType ty = floatFormat (typeWidth ty) - | otherwise = intFormat (typeWidth ty) - - --- | Get the Width of a Format. -formatToWidth :: Format -> Width -formatToWidth format - = case format of - II8 -> W8 - II16 -> W16 - II32 -> W32 - II64 -> W64 - FF32 -> W32 - FF64 -> W64 - FF80 -> W80 - -formatInBytes :: Format -> Int -formatInBytes = widthInBytes . formatToWidth diff --git a/nativeGen/Instruction.hs b/nativeGen/Instruction.hs deleted file mode 100644 --- a/nativeGen/Instruction.hs +++ /dev/null @@ -1,201 +0,0 @@ - -module Instruction ( - RegUsage(..), - noUsage, - GenBasicBlock(..), blockId, - ListGraph(..), - NatCmm, - NatCmmDecl, - NatBasicBlock, - topInfoTable, - entryBlocks, - Instruction(..) -) - -where - -import Reg - -import BlockId -import Hoopl -import DynFlags -import Cmm hiding (topInfoTable) -import Platform - --- | Holds a list of source and destination registers used by a --- particular instruction. --- --- Machine registers that are pre-allocated to stgRegs are filtered --- out, because they are uninteresting from a register allocation --- standpoint. (We wouldn't want them to end up on the free list!) --- --- As far as we are concerned, the fixed registers simply don't exist --- (for allocation purposes, anyway). --- -data RegUsage - = RU [Reg] [Reg] - --- | No regs read or written to. -noUsage :: RegUsage -noUsage = RU [] [] - --- Our flavours of the Cmm types --- Type synonyms for Cmm populated with native code -type NatCmm instr - = GenCmmGroup - CmmStatics - (LabelMap CmmStatics) - (ListGraph instr) - -type NatCmmDecl statics instr - = GenCmmDecl - statics - (LabelMap CmmStatics) - (ListGraph instr) - - -type NatBasicBlock instr - = GenBasicBlock instr - - --- | Returns the info table associated with the CmmDecl's entry point, --- if any. -topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i -topInfoTable (CmmProc infos _ _ (ListGraph (b:_))) - = mapLookup (blockId b) infos -topInfoTable _ - = Nothing - --- | Return the list of BlockIds in a CmmDecl that are entry points --- for this proc (i.e. they may be jumped to from outside this proc). -entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId] -entryBlocks (CmmProc info _ _ (ListGraph code)) = entries - where - infos = mapKeys info - entries = case code of - [] -> infos - BasicBlock entry _ : _ -- first block is the entry point - | entry `elem` infos -> infos - | otherwise -> entry : infos -entryBlocks _ = [] - --- | Common things that we can do with instructions, on all architectures. --- These are used by the shared parts of the native code generator, --- specifically the register allocators. --- -class Instruction instr where - - -- | Get the registers that are being used by this instruction. - -- regUsage doesn't need to do any trickery for jumps and such. - -- Just state precisely the regs read and written by that insn. - -- The consequences of control flow transfers, as far as register - -- allocation goes, are taken care of by the register allocator. - -- - regUsageOfInstr - :: Platform - -> instr - -> RegUsage - - - -- | Apply a given mapping to all the register references in this - -- instruction. - patchRegsOfInstr - :: instr - -> (Reg -> Reg) - -> instr - - - -- | Checks whether this instruction is a jump/branch instruction. - -- One that can change the flow of control in a way that the - -- register allocator needs to worry about. - isJumpishInstr - :: instr -> Bool - - - -- | Give the possible destinations of this jump instruction. - -- Must be defined for all jumpish instructions. - jumpDestsOfInstr - :: instr -> [BlockId] - - - -- | Change the destination of this jump instruction. - -- Used in the linear allocator when adding fixup blocks for join - -- points. - patchJumpInstr - :: instr - -> (BlockId -> BlockId) - -> instr - - - -- | An instruction to spill a register into a spill slot. - mkSpillInstr - :: DynFlags - -> Reg -- ^ the reg to spill - -> Int -- ^ the current stack delta - -> Int -- ^ spill slot to use - -> instr - - - -- | An instruction to reload a register from a spill slot. - mkLoadInstr - :: DynFlags - -> Reg -- ^ the reg to reload. - -> Int -- ^ the current stack delta - -> Int -- ^ the spill slot to use - -> instr - - -- | See if this instruction is telling us the current C stack delta - takeDeltaInstr - :: instr - -> Maybe Int - - -- | Check whether this instruction is some meta thing inserted into - -- the instruction stream for other purposes. - -- - -- Not something that has to be treated as a real machine instruction - -- and have its registers allocated. - -- - -- eg, comments, delta, ldata, etc. - isMetaInstr - :: instr - -> Bool - - - - -- | Copy the value in a register to another one. - -- Must work for all register classes. - mkRegRegMoveInstr - :: Platform - -> Reg -- ^ source register - -> Reg -- ^ destination register - -> instr - - -- | Take the source and destination from this reg -> reg move instruction - -- or Nothing if it's not one - takeRegRegMoveInstr - :: instr - -> Maybe (Reg, Reg) - - -- | Make an unconditional jump instruction. - -- For architectures with branch delay slots, its ok to put - -- a NOP after the jump. Don't fill the delay slot with an - -- instruction that references regs or you'll confuse the - -- linear allocator. - mkJumpInstr - :: BlockId - -> [instr] - - - -- Subtract an amount from the C stack pointer - mkStackAllocInstr - :: Platform -- TODO: remove (needed by x86/x86_64 - -- because they share an Instr type) - -> Int - -> instr - - -- Add an amount to the C stack pointer - mkStackDeallocInstr - :: Platform -- TODO: remove (needed by x86/x86_64 - -- because they share an Instr type) - -> Int - -> instr diff --git a/nativeGen/NCG.h b/nativeGen/NCG.h deleted file mode 100644 --- a/nativeGen/NCG.h +++ /dev/null @@ -1,14 +0,0 @@ -/* ----------------------------------------------------------------------------- - - (c) The University of Glasgow, 1994-2004 - - Native-code generator header file - just useful macros for now. - - -------------------------------------------------------------------------- */ - -#ifndef NCG_H -#define NCG_H - -#include "ghc_boot_platform.h" - -#endif diff --git a/nativeGen/NCGMonad.hs b/nativeGen/NCGMonad.hs deleted file mode 100644 --- a/nativeGen/NCGMonad.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE CPP #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1993-2004 --- --- The native code generator's monad. --- --- ----------------------------------------------------------------------------- - -module NCGMonad ( - NatM_State(..), mkNatM_State, - - NatM, -- instance Monad - initNat, - addImportNat, - getUniqueNat, - mapAccumLNat, - setDeltaNat, - getDeltaNat, - getThisModuleNat, - getBlockIdNat, - getNewLabelNat, - getNewRegNat, - getNewRegPairNat, - getPicBaseMaybeNat, - getPicBaseNat, - getDynFlags, - getModLoc, - getFileId, - getDebugBlock, - - DwarfFiles -) - -where - -#include "HsVersions.h" - -import Reg -import Format -import TargetReg - -import BlockId -import Hoopl -import CLabel ( CLabel, mkAsmTempLabel ) -import Debug -import FastString ( FastString ) -import UniqFM -import UniqSupply -import Unique ( Unique ) -import DynFlags -import Module - -import Control.Monad ( liftM, ap ) - -import Compiler.Hoopl ( LabelMap, Label ) - -data NatM_State - = NatM_State { - natm_us :: UniqSupply, - natm_delta :: Int, - natm_imports :: [(CLabel)], - natm_pic :: Maybe Reg, - natm_dflags :: DynFlags, - natm_this_module :: Module, - natm_modloc :: ModLocation, - natm_fileid :: DwarfFiles, - natm_debug_map :: LabelMap DebugBlock - } - -type DwarfFiles = UniqFM (FastString, Int) - -newtype NatM result = NatM (NatM_State -> (result, NatM_State)) - -unNat :: NatM a -> NatM_State -> (a, NatM_State) -unNat (NatM a) = a - -mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation -> - DwarfFiles -> LabelMap DebugBlock -> NatM_State -mkNatM_State us delta dflags this_mod - = NatM_State us delta [] Nothing dflags this_mod - -initNat :: NatM_State -> NatM a -> (a, NatM_State) -initNat init_st m - = case unNat m init_st of { (r,st) -> (r,st) } - -instance Functor NatM where - fmap = liftM - -instance Applicative NatM where - pure = returnNat - (<*>) = ap - -instance Monad NatM where - (>>=) = thenNat - -instance MonadUnique NatM where - getUniqueSupplyM = NatM $ \st -> - case splitUniqSupply (natm_us st) of - (us1, us2) -> (us1, st {natm_us = us2}) - - getUniqueM = NatM $ \st -> - case takeUniqFromSupply (natm_us st) of - (uniq, us') -> (uniq, st {natm_us = us'}) - -thenNat :: NatM a -> (a -> NatM b) -> NatM b -thenNat expr cont - = NatM $ \st -> case unNat expr st of - (result, st') -> unNat (cont result) st' - -returnNat :: a -> NatM a -returnNat result - = NatM $ \st -> (result, st) - -mapAccumLNat :: (acc -> x -> NatM (acc, y)) - -> acc - -> [x] - -> NatM (acc, [y]) - -mapAccumLNat _ b [] - = return (b, []) -mapAccumLNat f b (x:xs) - = do (b__2, x__2) <- f b x - (b__3, xs__2) <- mapAccumLNat f b__2 xs - return (b__3, x__2:xs__2) - -getUniqueNat :: NatM Unique -getUniqueNat = NatM $ \ st -> - case takeUniqFromSupply $ natm_us st of - (uniq, us') -> (uniq, st {natm_us = us'}) - -instance HasDynFlags NatM where - getDynFlags = NatM $ \ st -> (natm_dflags st, st) - - -getDeltaNat :: NatM Int -getDeltaNat = NatM $ \ st -> (natm_delta st, st) - - -setDeltaNat :: Int -> NatM () -setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta}) - - -getThisModuleNat :: NatM Module -getThisModuleNat = NatM $ \ st -> (natm_this_module st, st) - - -addImportNat :: CLabel -> NatM () -addImportNat imp - = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st}) - - -getBlockIdNat :: NatM BlockId -getBlockIdNat - = do u <- getUniqueNat - return (mkBlockId u) - - -getNewLabelNat :: NatM CLabel -getNewLabelNat - = do u <- getUniqueNat - return (mkAsmTempLabel u) - - -getNewRegNat :: Format -> NatM Reg -getNewRegNat rep - = do u <- getUniqueNat - dflags <- getDynFlags - return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) - - -getNewRegPairNat :: Format -> NatM (Reg,Reg) -getNewRegPairNat rep - = do u <- getUniqueNat - dflags <- getDynFlags - let vLo = targetMkVirtualReg (targetPlatform dflags) u rep - let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep - let hi = RegVirtual $ getHiVirtualRegFromLo vLo - return (lo, hi) - - -getPicBaseMaybeNat :: NatM (Maybe Reg) -getPicBaseMaybeNat - = NatM (\state -> (natm_pic state, state)) - - -getPicBaseNat :: Format -> NatM Reg -getPicBaseNat rep - = do mbPicBase <- getPicBaseMaybeNat - case mbPicBase of - Just picBase -> return picBase - Nothing - -> do - reg <- getNewRegNat rep - NatM (\state -> (reg, state { natm_pic = Just reg })) - -getModLoc :: NatM ModLocation -getModLoc - = NatM $ \ st -> (natm_modloc st, st) - -getFileId :: FastString -> NatM Int -getFileId f = NatM $ \st -> - case lookupUFM (natm_fileid st) f of - Just (_,n) -> (n, st) - Nothing -> let n = 1 + sizeUFM (natm_fileid st) - fids = addToUFM (natm_fileid st) f (f,n) - in n `seq` fids `seq` (n, st { natm_fileid = fids }) - -getDebugBlock :: Label -> NatM (Maybe DebugBlock) -getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st) diff --git a/nativeGen/PIC.hs b/nativeGen/PIC.hs deleted file mode 100644 --- a/nativeGen/PIC.hs +++ /dev/null @@ -1,899 +0,0 @@ -{- - This module handles generation of position independent code and - dynamic-linking related issues for the native code generator. - - This depends both the architecture and OS, so we define it here - instead of in one of the architecture specific modules. - - Things outside this module which are related to this: - - + module CLabel - - PIC base label (pretty printed as local label 1) - - DynamicLinkerLabels - several kinds: - CodeStub, SymbolPtr, GotSymbolPtr, GotSymbolOffset - - labelDynamic predicate - + module Cmm - - The GlobalReg datatype has a PicBaseReg constructor - - The CmmLit datatype has a CmmLabelDiffOff constructor - + codeGen & RTS - - When tablesNextToCode, no absolute addresses are stored in info tables - any more. Instead, offsets from the info label are used. - - For Win32 only, SRTs might contain addresses of __imp_ symbol pointers - because Win32 doesn't support external references in data sections. - TODO: make sure this still works, it might be bitrotted - + NCG - - The cmmToCmm pass in AsmCodeGen calls cmmMakeDynamicReference for all - labels. - - nativeCodeGen calls pprImportedSymbol and pprGotDeclaration to output - all the necessary stuff for imported symbols. - - The NCG monad keeps track of a list of imported symbols. - - MachCodeGen invokes initializePicBase to generate code to initialize - the PIC base register when needed. - - MachCodeGen calls cmmMakeDynamicReference whenever it uses a CLabel - that wasn't in the original Cmm code (e.g. floating point literals). --} - -module PIC ( - cmmMakeDynamicReference, - CmmMakeDynamicReferenceM(..), - ReferenceKind(..), - needImportedSymbols, - pprImportedSymbol, - pprGotDeclaration, - - initializePicBase_ppc, - initializePicBase_x86 -) - -where - -import qualified PPC.Instr as PPC -import qualified PPC.Regs as PPC - -import qualified X86.Instr as X86 - -import Platform -import Instruction -import Reg -import NCGMonad - - -import Hoopl -import Cmm -import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, - mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..), - dynamicLinkerLabelInfo, mkPicBaseLabel, - labelDynamic, externallyVisibleCLabel ) - -import CLabel ( mkForeignLabel ) - - -import BasicTypes -import Module - -import Outputable - -import DynFlags -import FastString - - - --------------------------------------------------------------------------------- --- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm --- code. It does The Right Thing(tm) to convert the CmmLabel into a --- position-independent, dynamic-linking-aware reference to the thing --- in question. --- Note that this also has to be called from MachCodeGen in order to --- access static data like floating point literals (labels that were --- created after the cmmToCmm pass). --- The function must run in a monad that can keep track of imported symbols --- A function for recording an imported symbol must be passed in: --- - addImportCmmOpt for the CmmOptM monad --- - addImportNat for the NatM monad. - -data ReferenceKind - = DataReference - | CallReference - | JumpReference - deriving(Eq) - -class Monad m => CmmMakeDynamicReferenceM m where - addImport :: CLabel -> m () - getThisModule :: m Module - -instance CmmMakeDynamicReferenceM NatM where - addImport = addImportNat - getThisModule = getThisModuleNat - -cmmMakeDynamicReference - :: CmmMakeDynamicReferenceM m - => DynFlags - -> ReferenceKind -- whether this is the target of a jump - -> CLabel -- the label - -> m CmmExpr - -cmmMakeDynamicReference dflags referenceKind lbl - | Just _ <- dynamicLinkerLabelInfo lbl - = return $ CmmLit $ CmmLabel lbl -- already processed it, pass through - - | otherwise - = do this_mod <- getThisModule - case howToAccessLabel - dflags - (platformArch $ targetPlatform dflags) - (platformOS $ targetPlatform dflags) - this_mod - referenceKind lbl of - - AccessViaStub -> do - let stub = mkDynamicLinkerLabel CodeStub lbl - addImport stub - return $ CmmLit $ CmmLabel stub - - AccessViaSymbolPtr -> do - let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl - addImport symbolPtr - return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags) - - AccessDirectly -> case referenceKind of - -- for data, we might have to make some calculations: - DataReference -> return $ cmmMakePicReference dflags lbl - -- all currently supported processors support - -- PC-relative branch and call instructions, - -- so just jump there if it's a call or a jump - _ -> return $ CmmLit $ CmmLabel lbl - - --- ----------------------------------------------------------------------------- --- Create a position independent reference to a label. --- (but do not bother with dynamic linking). --- We calculate the label's address by adding some (platform-dependent) --- offset to our base register; this offset is calculated by --- the function picRelative in the platform-dependent part below. - -cmmMakePicReference :: DynFlags -> CLabel -> CmmExpr -cmmMakePicReference dflags lbl - - -- Windows doesn't need PIC, - -- everything gets relocated at runtime - | OSMinGW32 <- platformOS $ targetPlatform dflags - = CmmLit $ CmmLabel lbl - - | OSAIX <- platformOS $ targetPlatform dflags - = CmmMachOp (MO_Add W32) - [ CmmReg (CmmGlobal PicBaseReg) - , CmmLit $ picRelative - (platformArch $ targetPlatform dflags) - (platformOS $ targetPlatform dflags) - lbl ] - - -- both ABI versions default to medium code model - | ArchPPC_64 _ <- platformArch $ targetPlatform dflags - = CmmMachOp (MO_Add W32) -- code model medium - [ CmmReg (CmmGlobal PicBaseReg) - , CmmLit $ picRelative - (platformArch $ targetPlatform dflags) - (platformOS $ targetPlatform dflags) - lbl ] - - | (positionIndependent dflags || WayDyn `elem` ways dflags) && absoluteLabel lbl - = CmmMachOp (MO_Add (wordWidth dflags)) - [ CmmReg (CmmGlobal PicBaseReg) - , CmmLit $ picRelative - (platformArch $ targetPlatform dflags) - (platformOS $ targetPlatform dflags) - lbl ] - - | otherwise - = CmmLit $ CmmLabel lbl - - -absoluteLabel :: CLabel -> Bool -absoluteLabel lbl - = case dynamicLinkerLabelInfo lbl of - Just (GotSymbolPtr, _) -> False - Just (GotSymbolOffset, _) -> False - _ -> True - - --------------------------------------------------------------------------------- --- Knowledge about how special dynamic linker labels like symbol --- pointers, code stubs and GOT offsets look like is located in the --- module CLabel. - --- We have to decide which labels need to be accessed --- indirectly or via a piece of stub code. -data LabelAccessStyle - = AccessViaStub - | AccessViaSymbolPtr - | AccessDirectly - -howToAccessLabel - :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle - - --- Windows --- In Windows speak, a "module" is a set of objects linked into the --- same Portable Exectuable (PE) file. (both .exe and .dll files are PEs). --- --- If we're compiling a multi-module program then symbols from other modules --- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the --- following. --- --- (in the local module) --- __imp_SYMBOL: addr of SYMBOL --- --- (in the other module) --- SYMBOL: the real function / data. --- --- To access the function at SYMBOL from our local module, we just need to --- dereference the local __imp_SYMBOL. --- --- If not compiling with -dynamic we assume that all our code will be linked --- into the same .exe file. In this case we always access symbols directly, --- and never use __imp_SYMBOL. --- -howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl - - -- Assume all symbols will be in the same PE, so just access them directly. - | WayDyn `notElem` ways dflags - = AccessDirectly - - -- If the target symbol is in another PE we need to access it via the - -- appropriate __imp_SYMBOL pointer. - | labelDynamic dflags this_mod lbl - = AccessViaSymbolPtr - - -- Target symbol is in the same PE as the caller, so just access it directly. - | otherwise - = AccessDirectly - - --- Mach-O (Darwin, Mac OS X) --- --- Indirect access is required in the following cases: --- * things imported from a dynamic library --- * (not on x86_64) data from a different module, if we're generating PIC code --- It is always possible to access something indirectly, --- even when it's not necessary. --- -howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl - -- data access to a dynamic library goes via a symbol pointer - | labelDynamic dflags this_mod lbl - = AccessViaSymbolPtr - - -- when generating PIC code, all cross-module data references must - -- must go via a symbol pointer, too, because the assembler - -- cannot generate code for a label difference where one - -- label is undefined. Doesn't apply t x86_64. - -- Unfortunately, we don't know whether it's cross-module, - -- so we do it for all externally visible labels. - -- This is a slight waste of time and space, but otherwise - -- we'd need to pass the current Module all the way in to - -- this function. - | arch /= ArchX86_64 - , positionIndependent dflags && externallyVisibleCLabel lbl - = AccessViaSymbolPtr - - | otherwise - = AccessDirectly - -howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl - -- dyld code stubs don't work for tailcalls because the - -- stack alignment is only right for regular calls. - -- Therefore, we have to go via a symbol pointer: - | arch == ArchX86 || arch == ArchX86_64 - , labelDynamic dflags this_mod lbl - = AccessViaSymbolPtr - - -howToAccessLabel dflags arch OSDarwin this_mod _ lbl - -- Code stubs are the usual method of choice for imported code; - -- not needed on x86_64 because Apple's new linker, ld64, generates - -- them automatically. - | arch /= ArchX86_64 - , labelDynamic dflags this_mod lbl - = AccessViaStub - - | otherwise - = AccessDirectly - - ----------------------------------------------------------------------------- --- AIX - --- quite simple (for now) -howToAccessLabel _dflags _arch OSAIX _this_mod kind _lbl - = case kind of - DataReference -> AccessViaSymbolPtr - CallReference -> AccessDirectly - JumpReference -> AccessDirectly - --- ELF (Linux) --- --- ELF tries to pretend to the main application code that dynamic linking does --- not exist. While this may sound convenient, it tends to mess things up in --- very bad ways, so we have to be careful when we generate code for a non-PIE --- main program (-dynamic but no -fPIC). --- --- Indirect access is required for references to imported symbols --- from position independent code. It is also required from the main program --- when dynamic libraries containing Haskell code are used. - -howToAccessLabel _ (ArchPPC_64 _) os _ kind _ - | osElfTarget os - = case kind of - -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC - DataReference -> AccessViaSymbolPtr - -- RTLD does not generate stubs for function descriptors - -- in tail calls. Create a symbol pointer and generate - -- the code to load the function descriptor at the call site. - JumpReference -> AccessViaSymbolPtr - -- regular calls are handled by the runtime linker - _ -> AccessDirectly - -howToAccessLabel dflags _ os _ _ _ - -- no PIC -> the dynamic linker does everything for us; - -- if we don't dynamically link to Haskell code, - -- it actually manages to do so without messing things up. - | osElfTarget os - , not (positionIndependent dflags) && WayDyn `notElem` ways dflags - = AccessDirectly - -howToAccessLabel dflags arch os this_mod DataReference lbl - | osElfTarget os - = case () of - -- A dynamic label needs to be accessed via a symbol pointer. - _ | labelDynamic dflags this_mod lbl - -> AccessViaSymbolPtr - - -- For PowerPC32 -fPIC, we have to access even static data - -- via a symbol pointer (see below for an explanation why - -- PowerPC32 Linux is especially broken). - | arch == ArchPPC - , positionIndependent dflags - -> AccessViaSymbolPtr - - | otherwise - -> AccessDirectly - - - -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons: - -- on i386, the position-independent symbol stubs in the Procedure Linkage Table - -- require the address of the GOT to be loaded into register %ebx on entry. - -- The linker will take any reference to the symbol stub as a hint that - -- the label in question is a code label. When linking executables, this - -- will cause the linker to replace even data references to the label with - -- references to the symbol stub. - - -- This leaves calling a (foreign) function from non-PIC code - -- (AccessDirectly, because we get an implicit symbol stub) - -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) - -howToAccessLabel dflags arch os this_mod CallReference lbl - | osElfTarget os - , labelDynamic dflags this_mod lbl && not (positionIndependent dflags) - = AccessDirectly - - | osElfTarget os - , arch /= ArchX86 - , labelDynamic dflags this_mod lbl - , positionIndependent dflags - = AccessViaStub - -howToAccessLabel dflags _ os this_mod _ lbl - | osElfTarget os - = if labelDynamic dflags this_mod lbl - then AccessViaSymbolPtr - else AccessDirectly - --- all other platforms -howToAccessLabel dflags _ _ _ _ _ - | not (positionIndependent dflags) - = AccessDirectly - - | otherwise - = panic "howToAccessLabel: PIC not defined for this platform" - - - --- ------------------------------------------------------------------- --- | Says what we we have to add to our 'PIC base register' in order to --- get the address of a label. - -picRelative :: Arch -> OS -> CLabel -> CmmLit - --- Darwin, but not x86_64: --- The PIC base register points to the PIC base label at the beginning --- of the current CmmDecl. We just have to use a label difference to --- get the offset. --- We have already made sure that all labels that are not from the current --- module are accessed indirectly ('as' can't calculate differences between --- undefined labels). -picRelative arch OSDarwin lbl - | arch /= ArchX86_64 - = CmmLabelDiffOff lbl mkPicBaseLabel 0 - --- On AIX we use an indirect local TOC anchored by 'gotLabel'. --- This way we use up only one global TOC entry per compilation-unit --- (this is quite similiar to GCC's @-mminimal-toc@ compilation mode) -picRelative _ OSAIX lbl - = CmmLabelDiffOff lbl gotLabel 0 - --- PowerPC Linux: --- The PIC base register points to our fake GOT. Use a label difference --- to get the offset. --- We have made sure that *everything* is accessed indirectly, so this --- is only used for offsets from the GOT to symbol pointers inside the --- GOT. -picRelative ArchPPC os lbl - | osElfTarget os - = CmmLabelDiffOff lbl gotLabel 0 - - --- Most Linux versions: --- The PIC base register points to the GOT. Use foo@got for symbol --- pointers, and foo@gotoff for everything else. --- Linux and Darwin on x86_64: --- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers, --- and a GotSymbolOffset label for other things. --- For reasons of tradition, the symbol offset label is written as a plain label. -picRelative arch os lbl - | osElfTarget os || (os == OSDarwin && arch == ArchX86_64) - = let result - | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl - = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl' - - | otherwise - = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl - - in result - -picRelative _ _ _ - = panic "PositionIndependentCode.picRelative undefined for this platform" - - - --------------------------------------------------------------------------------- - -needImportedSymbols :: DynFlags -> Arch -> OS -> Bool -needImportedSymbols dflags arch os - | os == OSDarwin - , arch /= ArchX86_64 - = True - - | os == OSAIX - = True - - -- PowerPC Linux: -fPIC or -dynamic - | osElfTarget os - , arch == ArchPPC - = positionIndependent dflags || WayDyn `elem` ways dflags - - -- PowerPC 64 Linux: always - | osElfTarget os - , arch == ArchPPC_64 ELF_V1 || arch == ArchPPC_64 ELF_V2 - = True - - -- i386 (and others?): -dynamic but not -fPIC - | osElfTarget os - , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - = WayDyn `elem` ways dflags && not (positionIndependent dflags) - - | otherwise - = False - --- gotLabel --- The label used to refer to our "fake GOT" from --- position-independent code. -gotLabel :: CLabel -gotLabel - -- HACK: this label isn't really foreign - = mkForeignLabel - (fsLit ".LCTOC1") - Nothing ForeignLabelInThisPackage IsData - - - --------------------------------------------------------------------------------- --- We don't need to declare any offset tables. --- However, for PIC on x86, we need a small helper function. -pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc -pprGotDeclaration dflags ArchX86 OSDarwin - | positionIndependent dflags - = vcat [ - text ".section __TEXT,__textcoal_nt,coalesced,no_toc", - text ".weak_definition ___i686.get_pc_thunk.ax", - text ".private_extern ___i686.get_pc_thunk.ax", - text "___i686.get_pc_thunk.ax:", - text "\tmovl (%esp), %eax", - text "\tret" ] - -pprGotDeclaration _ _ OSDarwin - = empty - --- Emit XCOFF TOC section -pprGotDeclaration _ _ OSAIX - = vcat $ [ text ".toc" - , text ".tc ghc_toc_table[TC],.LCTOC1" - , text ".csect ghc_toc_table[RW]" - -- See Note [.LCTOC1 in PPC PIC code] - , text ".set .LCTOC1,$+0x8000" - ] - - --- PPC 64 ELF v1 needs a Table Of Contents (TOC) on Linux -pprGotDeclaration _ (ArchPPC_64 ELF_V1) OSLinux - = text ".section \".toc\",\"aw\"" --- In ELF v2 we also need to tell the assembler that we want ABI --- version 2. This would normally be done at the top of the file --- right after a file directive, but I could not figure out how --- to do that. -pprGotDeclaration _ (ArchPPC_64 ELF_V2) OSLinux - = vcat [ text ".abiversion 2", - text ".section \".toc\",\"aw\"" - ] -pprGotDeclaration _ (ArchPPC_64 _) _ - = panic "pprGotDeclaration: ArchPPC_64 only Linux supported" - --- Emit GOT declaration --- Output whatever needs to be output once per .s file. -pprGotDeclaration dflags arch os - | osElfTarget os - , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - , not (positionIndependent dflags) - = empty - - | osElfTarget os - , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - = vcat [ - -- See Note [.LCTOC1 in PPC PIC code] - text ".section \".got2\",\"aw\"", - text ".LCTOC1 = .+32768" ] - -pprGotDeclaration _ _ _ - = panic "pprGotDeclaration: no match" - - --------------------------------------------------------------------------------- --- On Darwin, we have to generate our own stub code for lazy binding.. --- For each processor architecture, there are two versions, one for PIC --- and one for non-PIC. --- --- Whenever you change something in this assembler output, make sure --- the splitter in driver/split/ghc-split.pl recognizes the new output - -pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc -pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC, platformOS = OSDarwin }) importedLbl - | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl - = case positionIndependent dflags of - False -> - vcat [ - text ".symbol_stub", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\tlis r11,ha16(L" <> pprCLabel platform lbl - <> text "$lazy_ptr)", - text "\tlwz r12,lo16(L" <> pprCLabel platform lbl - <> text "$lazy_ptr)(r11)", - text "\tmtctr r12", - text "\taddi r11,r11,lo16(L" <> pprCLabel platform lbl - <> text "$lazy_ptr)", - text "\tbctr" - ] - True -> - vcat [ - text ".section __TEXT,__picsymbolstub1," - <> text "symbol_stubs,pure_instructions,32", - text "\t.align 2", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\tmflr r0", - text "\tbcl 20,31,L0$" <> pprCLabel platform lbl, - text "L0$" <> pprCLabel platform lbl <> char ':', - text "\tmflr r11", - text "\taddis r11,r11,ha16(L" <> pprCLabel platform lbl - <> text "$lazy_ptr-L0$" <> pprCLabel platform lbl <> char ')', - text "\tmtlr r0", - text "\tlwzu r12,lo16(L" <> pprCLabel platform lbl - <> text "$lazy_ptr-L0$" <> pprCLabel platform lbl - <> text ")(r11)", - text "\tmtctr r12", - text "\tbctr" - ] - $+$ vcat [ - text ".lazy_symbol_pointer", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\t.long dyld_stub_binding_helper"] - - | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl - = vcat [ - text ".non_lazy_symbol_pointer", - char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:", - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\t.long\t0"] - - | otherwise - = empty - - -pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl - | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl - = case positionIndependent dflags of - False -> - vcat [ - text ".symbol_stub", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\tjmp *L" <> pprCLabel platform lbl - <> text "$lazy_ptr", - text "L" <> pprCLabel platform lbl - <> text "$stub_binder:", - text "\tpushl $L" <> pprCLabel platform lbl - <> text "$lazy_ptr", - text "\tjmp dyld_stub_binding_helper" - ] - True -> - vcat [ - text ".section __TEXT,__picsymbolstub2," - <> text "symbol_stubs,pure_instructions,25", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\tcall ___i686.get_pc_thunk.ax", - text "1:", - text "\tmovl L" <> pprCLabel platform lbl - <> text "$lazy_ptr-1b(%eax),%edx", - text "\tjmp *%edx", - text "L" <> pprCLabel platform lbl - <> text "$stub_binder:", - text "\tlea L" <> pprCLabel platform lbl - <> text "$lazy_ptr-1b(%eax),%eax", - text "\tpushl %eax", - text "\tjmp dyld_stub_binding_helper" - ] - $+$ vcat [ text ".section __DATA, __la_sym_ptr" - <> (if positionIndependent dflags then int 2 else int 3) - <> text ",lazy_symbol_pointers", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\t.long L" <> pprCLabel platform lbl - <> text "$stub_binder"] - - | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl - = vcat [ - text ".non_lazy_symbol_pointer", - char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:", - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\t.long\t0"] - - | otherwise - = empty - - -pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _ - = empty - --- XCOFF / AIX --- --- Similiar to PPC64 ELF v1, there's dedicated TOC register (r2). To --- workaround the limitation of a global TOC we use an indirect TOC --- with the label `ghc_toc_table`. --- --- See also GCC's `-mminimal-toc` compilation mode or --- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/ --- --- NB: No DSO-support yet - -pprImportedSymbol _ platform@(Platform { platformOS = OSAIX }) importedLbl - = case dynamicLinkerLabelInfo importedLbl of - Just (SymbolPtr, lbl) - -> vcat [ - text "LC.." <> pprCLabel platform lbl <> char ':', - text "\t.long" <+> pprCLabel platform lbl ] - _ -> empty - --- ELF / Linux --- --- In theory, we don't need to generate any stubs or symbol pointers --- by hand for Linux. --- --- Reality differs from this in two areas. --- --- 1) If we just use a dynamically imported symbol directly in a read-only --- section of the main executable (as GCC does), ld generates R_*_COPY --- relocations, which are fundamentally incompatible with reversed info --- tables. Therefore, we need a table of imported addresses in a writable --- section. --- The "official" GOT mechanism (label@got) isn't intended to be used --- in position dependent code, so we have to create our own "fake GOT" --- when not Opt_PIC && WayDyn `elem` ways dflags. --- --- 2) PowerPC Linux is just plain broken. --- While it's theoretically possible to use GOT offsets larger --- than 16 bit, the standard crt*.o files don't, which leads to --- linker errors as soon as the GOT size exceeds 16 bit. --- Also, the assembler doesn't support @gotoff labels. --- In order to be able to use a larger GOT, we have to circumvent the --- entire GOT mechanism and do it ourselves (this is also what GCC does). - - --- When needImportedSymbols is defined, --- the NCG will keep track of all DynamicLinkerLabels it uses --- and output each of them using pprImportedSymbol. - -pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 _ }) - importedLbl - | osElfTarget (platformOS platform) - = case dynamicLinkerLabelInfo importedLbl of - Just (SymbolPtr, lbl) - -> vcat [ - text ".section \".toc\", \"aw\"", - text ".LC_" <> pprCLabel platform lbl <> char ':', - text "\t.quad" <+> pprCLabel platform lbl ] - _ -> empty - -pprImportedSymbol dflags platform importedLbl - | osElfTarget (platformOS platform) - = case dynamicLinkerLabelInfo importedLbl of - Just (SymbolPtr, lbl) - -> let symbolSize = case wordWidth dflags of - W32 -> sLit "\t.long" - W64 -> sLit "\t.quad" - _ -> panic "Unknown wordRep in pprImportedSymbol" - - in vcat [ - text ".section \".got2\", \"aw\"", - text ".LC_" <> pprCLabel platform lbl <> char ':', - ptext symbolSize <+> pprCLabel platform lbl ] - - -- PLT code stubs are generated automatically by the dynamic linker. - _ -> empty - -pprImportedSymbol _ _ _ - = panic "PIC.pprImportedSymbol: no match" - --------------------------------------------------------------------------------- --- Generate code to calculate the address that should be put in the --- PIC base register. --- This is called by MachCodeGen for every CmmProc that accessed the --- PIC base register. It adds the appropriate instructions to the --- top of the CmmProc. - --- It is assumed that the first NatCmmDecl in the input list is a Proc --- and the rest are CmmDatas. - --- Darwin is simple: just fetch the address of a local label. --- The FETCHPC pseudo-instruction is expanded to multiple instructions --- during pretty-printing so that we don't have to deal with the --- local label: - --- PowerPC version: --- bcl 20,31,1f. --- 1: mflr picReg - --- i386 version: --- call 1f --- 1: popl %picReg - - - --- Get a pointer to our own fake GOT, which is defined on a per-module basis. --- This is exactly how GCC does it in linux. - -initializePicBase_ppc - :: Arch -> OS -> Reg - -> [NatCmmDecl CmmStatics PPC.Instr] - -> NatM [NatCmmDecl CmmStatics PPC.Instr] - -initializePicBase_ppc ArchPPC os picReg - (CmmProc info lab live (ListGraph blocks) : statics) - | osElfTarget os - = do - let - gotOffset = PPC.ImmConstantDiff - (PPC.ImmCLbl gotLabel) - (PPC.ImmCLbl mkPicBaseLabel) - - blocks' = case blocks of - [] -> [] - (b:bs) -> fetchPC b : map maybeFetchPC bs - - maybeFetchPC b@(BasicBlock bID _) - | bID `mapMember` info = fetchPC b - | otherwise = b - - -- GCC does PIC prologs thusly: - -- bcl 20,31,.L1 - -- .L1: - -- mflr 30 - -- addis 30,30,.LCTOC1-.L1@ha - -- addi 30,30,.LCTOC1-.L1@l - -- TODO: below we use it over temporary register, - -- it can and should be optimised by picking - -- correct PIC reg. - fetchPC (BasicBlock bID insns) = - BasicBlock bID (PPC.FETCHPC picReg - : PPC.ADDIS picReg picReg (PPC.HA gotOffset) - : PPC.ADD picReg picReg - (PPC.RIImm (PPC.LO gotOffset)) - : PPC.MR PPC.r30 picReg - : insns) - - return (CmmProc info lab live (ListGraph blocks') : statics) - - -initializePicBase_ppc ArchPPC OSDarwin picReg - (CmmProc info lab live (ListGraph (entry:blocks)) : statics) -- just one entry because of splitting - = return (CmmProc info lab live (ListGraph (b':blocks)) : statics) - - where BasicBlock bID insns = entry - b' = BasicBlock bID (PPC.FETCHPC picReg : insns) - -------------------------------------------------------------------------- --- Load TOC into register 2 --- PowerPC 64-bit ELF ABI 2.0 requires the address of the callee --- in register 12. --- We pass the label to FETCHTOC and create a .localentry too. --- TODO: Explain this better and refer to ABI spec! -{- -We would like to do approximately this, but spill slot allocation -might be added before the first BasicBlock. That violates the ABI. - -For now we will emit the prologue code in the pretty printer, -which is also what we do for ELF v1. -initializePicBase_ppc (ArchPPC_64 ELF_V2) OSLinux picReg - (CmmProc info lab live (ListGraph (entry:blocks)) : statics) - = do - bID <-getUniqueM - return (CmmProc info lab live (ListGraph (b':entry:blocks)) - : statics) - where BasicBlock entryID _ = entry - b' = BasicBlock bID [PPC.FETCHTOC picReg lab, - PPC.BCC PPC.ALWAYS entryID] --} - -initializePicBase_ppc _ _ _ _ - = panic "initializePicBase_ppc: not needed" - - --- We cheat a bit here by defining a pseudo-instruction named FETCHGOT --- which pretty-prints as: --- call 1f --- 1: popl %picReg --- addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg --- (See PprMach.hs) - -initializePicBase_x86 - :: Arch -> OS -> Reg - -> [NatCmmDecl (Alignment, CmmStatics) X86.Instr] - -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr] - -initializePicBase_x86 ArchX86 os picReg - (CmmProc info lab live (ListGraph blocks) : statics) - | osElfTarget os - = return (CmmProc info lab live (ListGraph blocks') : statics) - where blocks' = case blocks of - [] -> [] - (b:bs) -> fetchGOT b : map maybeFetchGOT bs - - -- we want to add a FETCHGOT instruction to the beginning of - -- every block that is an entry point, which corresponds to - -- the blocks that have entries in the info-table mapping. - maybeFetchGOT b@(BasicBlock bID _) - | bID `mapMember` info = fetchGOT b - | otherwise = b - - fetchGOT (BasicBlock bID insns) = - BasicBlock bID (X86.FETCHGOT picReg : insns) - -initializePicBase_x86 ArchX86 OSDarwin picReg - (CmmProc info lab live (ListGraph (entry:blocks)) : statics) - = return (CmmProc info lab live (ListGraph (block':blocks)) : statics) - - where BasicBlock bID insns = entry - block' = BasicBlock bID (X86.FETCHPC picReg : insns) - -initializePicBase_x86 _ _ _ _ - = panic "initializePicBase_x86: not needed" - diff --git a/nativeGen/PPC/CodeGen.hs b/nativeGen/PPC/CodeGen.hs deleted file mode 100644 --- a/nativeGen/PPC/CodeGen.hs +++ /dev/null @@ -1,2307 +0,0 @@ -{-# LANGUAGE CPP, GADTs #-} - ------------------------------------------------------------------------------ --- --- Generating machine code (instruction selection) --- --- (c) The University of Glasgow 1996-2004 --- ------------------------------------------------------------------------------ - --- This is a big module, but, if you pay attention to --- (a) the sectioning, and (b) the type signatures, --- the structure should not be too overwhelming. - -module PPC.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - InstrBlock -) - -where - -#include "HsVersions.h" -#include "nativeGen/NCG.h" -#include "MachDeps.h" - --- NCG stuff: -import CodeGen.Platform -import PPC.Instr -import PPC.Cond -import PPC.Regs -import CPrim -import NCGMonad -import Instruction -import PIC -import Format -import RegClass -import Reg -import TargetReg -import Platform - --- Our intermediate code: -import BlockId -import PprCmm ( pprExpr ) -import Cmm -import CmmUtils -import CmmSwitch -import CLabel -import Hoopl - --- The rest: -import OrdList -import Outputable -import Unique -import DynFlags - -import Control.Monad ( mapAndUnzipM, when ) -import Data.Bits -import Data.Word - -import BasicTypes -import FastString -import Util - --- ----------------------------------------------------------------------------- --- Top-level of the instruction selector - --- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal (pre-order?) yields the insns in the correct --- order. - -cmmTopCodeGen - :: RawCmmDecl - -> NatM [NatCmmDecl CmmStatics Instr] - -cmmTopCodeGen (CmmProc info lab live graph) = do - let blocks = toBlockListEntryFirst graph - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - dflags <- getDynFlags - let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) - tops = proc : concat statics - os = platformOS $ targetPlatform dflags - arch = platformArch $ targetPlatform dflags - case arch of - ArchPPC | os == OSAIX -> return tops - | otherwise -> do - picBaseMb <- getPicBaseMaybeNat - case picBaseMb of - Just picBase -> initializePicBase_ppc arch os picBase tops - Nothing -> return tops - ArchPPC_64 ELF_V1 -> return tops - -- generating function descriptor is handled in - -- pretty printer - ArchPPC_64 ELF_V2 -> return tops - -- generating function prologue is handled in - -- pretty printer - _ -> panic "PPC.cmmTopCodeGen: unknown arch" - -cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic - -basicBlockCodeGen - :: Block CmmNode C C - -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl CmmStatics Instr]) - -basicBlockCodeGen block = do - let (_, nodes, tail) = blockSplit block - id = entryLabel block - stmts = blockToList nodes - mid_instrs <- stmtsToInstrs stmts - tail_instrs <- stmtToInstrs tail - let instrs = mid_instrs `appOL` tail_instrs - -- code generation may introduce new basic block boundaries, which - -- are indicated by the NEWBLOCK instruction. We must split up the - -- instruction stream into basic blocks again. Also, we extract - -- LDATAs here too. - let - (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) - return (BasicBlock id top : other_blocks, statics) - -stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock -stmtsToInstrs stmts - = do instrss <- mapM stmtToInstrs stmts - return (concatOL instrss) - -stmtToInstrs :: CmmNode e x -> NatM InstrBlock -stmtToInstrs stmt = do - dflags <- getDynFlags - case stmt of - CmmComment s -> return (unitOL (COMMENT s)) - CmmTick {} -> return nilOL - CmmUnwind {} -> return nilOL - - CmmAssign reg src - | isFloatType ty -> assignReg_FltCode format reg src - | target32Bit (targetPlatform dflags) && - isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType dflags reg - format = cmmTypeFormat ty - - CmmStore addr src - | isFloatType ty -> assignMem_FltCode format addr src - | target32Bit (targetPlatform dflags) && - isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode format addr src - where ty = cmmExprType dflags src - format = cmmTypeFormat ty - - CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args - - CmmBranch id -> genBranch id - CmmCondBranch arg true false _ -> do - b1 <- genCondJump true arg - b2 <- genBranch false - return (b1 `appOL` b2) - CmmSwitch arg ids -> do dflags <- getDynFlags - genSwitch dflags arg ids - CmmCall { cml_target = arg } -> genJump arg - _ -> - panic "stmtToInstrs: statement should have been cps'd away" - - --------------------------------------------------------------------------------- --- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. --- -type InstrBlock - = OrdList Instr - - --- | Register's passed up the tree. If the stix code forces the register --- to live in a pre-decided machine register, it comes out as @Fixed@; --- otherwise, it comes out as @Any@, and the parent can decide which --- register to put it in. --- -data Register - = Fixed Format Reg InstrBlock - | Any Format (Reg -> InstrBlock) - - -swizzleRegisterRep :: Register -> Format -> Register -swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code -swizzleRegisterRep (Any _ codefn) format = Any format codefn - - --- | Grab the Reg for a CmmReg -getRegisterReg :: Platform -> CmmReg -> Reg - -getRegisterReg _ (CmmLocal (LocalReg u pk)) - = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) - -getRegisterReg platform (CmmGlobal mid) - = case globalRegMaybe platform mid of - Just reg -> RegReal reg - Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) - -- By this stage, the only MagicIds remaining should be the - -- ones which map to a real machine register on this - -- platform. Hence ... - --- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic -jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) -jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = mkAsmTempLabel (getUnique blockid) - - - --- ----------------------------------------------------------------------------- --- General things for putting together code sequences - --- Expand CmmRegOff. ToDo: should we do it this way around, or convert --- CmmExprs into CmmRegOff? -mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr -mangleIndexTree dflags (CmmRegOff reg off) - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType dflags reg) - -mangleIndexTree _ _ - = panic "PPC.CodeGen.mangleIndexTree: no match" - --- ----------------------------------------------------------------------------- --- Code gen for 64-bit arithmetic on 32-bit platforms - -{- -Simple support for generating 64-bit code (ie, 64 bit values and 64 -bit assignments) on 32-bit platforms. Unlike the main code generator -we merely shoot for generating working code as simply as possible, and -pay little attention to code quality. Specifically, there is no -attempt to deal cleverly with the fixed-vs-floating register -distinction; all values are generated into (pairs of) floating -registers, even if this would mean some redundant reg-reg moves as a -result. Only one of the VRegUniques is returned, since it will be -of the VRegUniqueLo form, and the upper-half VReg can be determined -by applying getHiVRegFromLo to it. --} - -data ChildCode64 -- a.k.a "Register64" - = ChildCode64 - InstrBlock -- code - Reg -- the lower 32-bit temporary which contains the - -- result; use getHiVRegFromLo to find the other - -- VRegUnique. Rules of this simplified insn - -- selection game are therefore that the returned - -- Reg may be modified - - --- | Compute an expression into a register, but --- we don't mind which one it is. -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getSomeReg expr = do - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) - -getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock) -getI64Amodes addrTree = do - Amode hi_addr addr_code <- getAmode D addrTree - case addrOffset hi_addr 4 of - Just lo_addr -> return (hi_addr, lo_addr, addr_code) - Nothing -> do (hi_ptr, code) <- getSomeReg addrTree - return (AddrRegImm hi_ptr (ImmInt 0), - AddrRegImm hi_ptr (ImmInt 4), - code) - - -assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_I64Code addrTree valueTree = do - (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree - ChildCode64 vcode rlo <- iselExpr64 valueTree - let - rhi = getHiVRegFromLo rlo - - -- Big-endian store - mov_hi = ST II32 rhi hi_addr - mov_lo = ST II32 rlo lo_addr - return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) - - -assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do - ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let - r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 - r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = MR r_dst_lo r_src_lo - mov_hi = MR r_dst_hi r_src_hi - return ( - vcode `snocOL` mov_lo `snocOL` mov_hi - ) - -assignReg_I64Code _ _ - = panic "assignReg_I64Code(powerpc): invalid lvalue" - - -iselExpr64 :: CmmExpr -> NatM ChildCode64 -iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do - (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree - (rlo, rhi) <- getNewRegPairNat II32 - let mov_hi = LD II32 rhi hi_addr - mov_lo = LD II32 rlo lo_addr - return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) - rlo - -iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty - = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32)) - -iselExpr64 (CmmLit (CmmInt i _)) = do - (rlo,rhi) <- getNewRegPairNat II32 - let - half0 = fromIntegral (fromIntegral i :: Word16) - half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) - half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16) - half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16) - - code = toOL [ - LIS rlo (ImmInt half1), - OR rlo rlo (RIImm $ ImmInt half0), - LIS rhi (ImmInt half3), - OR rhi rhi (RIImm $ ImmInt half2) - ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do - ChildCode64 code1 r1lo <- iselExpr64 e1 - ChildCode64 code2 r2lo <- iselExpr64 e2 - (rlo,rhi) <- getNewRegPairNat II32 - let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ ADDC rlo r1lo r2lo, - ADDE rhi r1hi r2hi ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do - ChildCode64 code1 r1lo <- iselExpr64 e1 - ChildCode64 code2 r2lo <- iselExpr64 e2 - (rlo,rhi) <- getNewRegPairNat II32 - let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ SUBFC rlo r2lo (RIReg r1lo), - SUBFE rhi r2hi r1hi ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do - (expr_reg,expr_code) <- getSomeReg expr - (rlo, rhi) <- getNewRegPairNat II32 - let mov_hi = LI rhi (ImmInt 0) - mov_lo = MR rlo expr_reg - return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) - rlo -iselExpr64 expr - = pprPanic "iselExpr64(powerpc)" (pprExpr expr) - - - -getRegister :: CmmExpr -> NatM Register -getRegister e = do dflags <- getDynFlags - getRegister' dflags e - -getRegister' :: DynFlags -> CmmExpr -> NatM Register - -getRegister' dflags (CmmReg (CmmGlobal PicBaseReg)) - | OSAIX <- platformOS (targetPlatform dflags) = do - let code dst = toOL [ LD II32 dst tocAddr ] - tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]")) - return (Any II32 code) - | target32Bit (targetPlatform dflags) = do - reg <- getPicBaseNat $ archWordFormat (target32Bit (targetPlatform dflags)) - return (Fixed (archWordFormat (target32Bit (targetPlatform dflags))) - reg nilOL) - | otherwise = return (Fixed II64 toc nilOL) - -getRegister' dflags (CmmReg reg) - = return (Fixed (cmmTypeFormat (cmmRegType dflags reg)) - (getRegisterReg (targetPlatform dflags) reg) nilOL) - -getRegister' dflags tree@(CmmRegOff _ _) - = getRegister' dflags (mangleIndexTree dflags tree) - - -- for 32-bit architectuers, support some 64 -> 32 bit conversions: - -- TO_W_(x), TO_W_(x >> 32) - -getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) - | target32Bit (targetPlatform dflags) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) - | target32Bit (targetPlatform dflags) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x]) - | target32Bit (targetPlatform dflags) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x]) - | target32Bit (targetPlatform dflags) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister' dflags (CmmLoad mem pk) - | not (isWord64 pk) = do - let platform = targetPlatform dflags - Amode addr addr_code <- getAmode D mem - let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk) - addr_code `snocOL` LD format dst addr - return (Any format code) - | not (target32Bit (targetPlatform dflags)) = do - Amode addr addr_code <- getAmode DS mem - let code dst = addr_code `snocOL` LD II64 dst addr - return (Any II64 code) - - where format = cmmTypeFormat pk - --- catch simple cases of zero- or sign-extended load -getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) - -getRegister' _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) - --- Note: there is no Load Byte Arithmetic instruction, so no signed case here - -getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr)) - -getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr)) - -getRegister' _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr)) - -getRegister' _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr)) - -getRegister' _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr)) - -getRegister' _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do - -- lwa is DS-form. See Note [Power instruction format] - Amode addr addr_code <- getAmode DS mem - return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr)) - -getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps - = case mop of - MO_Not rep -> triv_ucode_int rep NOT - - MO_F_Neg w -> triv_ucode_float w FNEG - MO_S_Neg w -> triv_ucode_int w NEG - - MO_FF_Conv W64 W32 -> trivialUCode FF32 FRSP x - MO_FF_Conv W32 W64 -> conversionNop FF64 x - - MO_FS_Conv from to -> coerceFP2Int from to x - MO_SF_Conv from to -> coerceInt2FP from to x - - MO_SS_Conv from to - | from == to -> conversionNop (intFormat to) x - - -- narrowing is a nop: we treat the high bits as undefined - MO_SS_Conv W64 to - | arch32 -> panic "PPC.CodeGen.getRegister no 64 bit int register" - | otherwise -> conversionNop (intFormat to) x - MO_SS_Conv W32 to - | arch32 -> conversionNop (intFormat to) x - | otherwise -> case to of - W64 -> triv_ucode_int to (EXTS II32) - W16 -> conversionNop II16 x - W8 -> conversionNop II8 x - _ -> panic "PPC.CodeGen.getRegister: no match" - MO_SS_Conv W16 W8 -> conversionNop II8 x - MO_SS_Conv W8 to -> triv_ucode_int to (EXTS II8) - MO_SS_Conv W16 to -> triv_ucode_int to (EXTS II16) - - MO_UU_Conv from to - | from == to -> conversionNop (intFormat to) x - -- narrowing is a nop: we treat the high bits as undefined - MO_UU_Conv W64 to - | arch32 -> panic "PPC.CodeGen.getRegister no 64 bit target" - | otherwise -> conversionNop (intFormat to) x - MO_UU_Conv W32 to - | arch32 -> conversionNop (intFormat to) x - | otherwise -> - case to of - W64 -> trivialCode to False AND x (CmmLit (CmmInt 4294967295 W64)) - W16 -> conversionNop II16 x - W8 -> conversionNop II8 x - _ -> panic "PPC.CodeGen.getRegister: no match" - MO_UU_Conv W16 W8 -> conversionNop II8 x - MO_UU_Conv W8 to -> trivialCode to False AND x (CmmLit (CmmInt 255 W32)) - MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32)) - _ -> panic "PPC.CodeGen.getRegister: no match" - - where - triv_ucode_int width instr = trivialUCode (intFormat width) instr x - triv_ucode_float width instr = trivialUCode (floatFormat width) instr x - - conversionNop new_format expr - = do e_code <- getRegister' dflags expr - return (swizzleRegisterRep e_code new_format) - arch32 = target32Bit $ targetPlatform dflags - -getRegister' dflags (CmmMachOp mop [x, y]) -- dyadic PrimOps - = case mop of - MO_F_Eq _ -> condFltReg EQQ x y - MO_F_Ne _ -> condFltReg NE x y - MO_F_Gt _ -> condFltReg GTT x y - MO_F_Ge _ -> condFltReg GE x y - MO_F_Lt _ -> condFltReg LTT x y - MO_F_Le _ -> condFltReg LE x y - - MO_Eq rep -> condIntReg EQQ (extendUExpr dflags rep x) - (extendUExpr dflags rep y) - MO_Ne rep -> condIntReg NE (extendUExpr dflags rep x) - (extendUExpr dflags rep y) - - MO_S_Gt rep -> condIntReg GTT (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - MO_S_Ge rep -> condIntReg GE (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - MO_S_Lt rep -> condIntReg LTT (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - MO_S_Le rep -> condIntReg LE (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - - MO_U_Gt rep -> condIntReg GU (extendUExpr dflags rep x) - (extendUExpr dflags rep y) - MO_U_Ge rep -> condIntReg GEU (extendUExpr dflags rep x) - (extendUExpr dflags rep y) - MO_U_Lt rep -> condIntReg LU (extendUExpr dflags rep x) - (extendUExpr dflags rep y) - MO_U_Le rep -> condIntReg LEU (extendUExpr dflags rep x) - (extendUExpr dflags rep y) - - MO_F_Add w -> triv_float w FADD - MO_F_Sub w -> triv_float w FSUB - MO_F_Mul w -> triv_float w FMUL - MO_F_Quot w -> triv_float w FDIV - - -- optimize addition with 32-bit immediate - -- (needed for PIC) - MO_Add W32 -> - case y of - CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True imm - -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep) - CmmLit lit - -> do - (src, srcCode) <- getSomeReg x - let imm = litToImm lit - code dst = srcCode `appOL` toOL [ - ADDIS dst src (HA imm), - ADD dst dst (RIImm (LO imm)) - ] - return (Any II32 code) - _ -> trivialCode W32 True ADD x y - - MO_Add rep -> trivialCode rep True ADD x y - MO_Sub rep -> - case y of - CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm) - -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep) - _ -> case x of - CmmLit (CmmInt imm _) - | Just _ <- makeImmediate rep True imm - -- subfi ('substract from' with immediate) doesn't exist - -> trivialCode rep True SUBFC y x - _ -> trivialCodeNoImm' (intFormat rep) SUBF y x - - MO_Mul rep -> shiftMulCode rep True MULL x y - MO_S_MulMayOflo rep -> do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - format = intFormat rep - code dst = code1 `appOL` code2 - `appOL` toOL [ MULLO format dst src1 src2 - , MFOV format dst - ] - return (Any format code) - - MO_S_Quot rep -> trivialCodeNoImmSign (intFormat rep) True DIV - (extendSExpr dflags rep x) (extendSExpr dflags rep y) - MO_U_Quot rep -> trivialCodeNoImmSign (intFormat rep) False DIV - (extendUExpr dflags rep x) (extendUExpr dflags rep y) - - MO_S_Rem rep -> remainderCode rep True (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - MO_U_Rem rep -> remainderCode rep False (extendUExpr dflags rep x) - (extendUExpr dflags rep y) - - MO_And rep -> case y of - (CmmLit (CmmInt imm _)) | imm == -8 || imm == -4 - -> do - (src, srcCode) <- getSomeReg x - let clear_mask = if imm == -4 then 2 else 3 - fmt = intFormat rep - code dst = srcCode - `appOL` unitOL (CLRRI fmt dst src clear_mask) - return (Any fmt code) - _ -> trivialCode rep False AND x y - MO_Or rep -> trivialCode rep False OR x y - MO_Xor rep -> trivialCode rep False XOR x y - - MO_Shl rep -> shiftMulCode rep False SL x y - MO_S_Shr rep -> shiftMulCode rep False SRA (extendSExpr dflags rep x) y - MO_U_Shr rep -> shiftMulCode rep False SR (extendUExpr dflags rep x) y - _ -> panic "PPC.CodeGen.getRegister: no match" - - where - triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register - triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y - -getRegister' _ (CmmLit (CmmInt i rep)) - | Just imm <- makeImmediate rep True i - = let - code dst = unitOL (LI dst imm) - in - return (Any (intFormat rep) code) - -getRegister' _ (CmmLit (CmmFloat f frep)) = do - lbl <- getNewLabelNat - dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - Amode addr addr_code <- getAmode D dynRef - let format = floatFormat frep - code dst = - LDATA (Section ReadOnlyData lbl) - (Statics lbl [CmmStaticLit (CmmFloat f frep)]) - `consOL` (addr_code `snocOL` LD format dst addr) - return (Any format code) - -getRegister' dflags (CmmLit lit) - | target32Bit (targetPlatform dflags) - = let rep = cmmLitType dflags lit - imm = litToImm lit - code dst = toOL [ - LIS dst (HA imm), - ADD dst dst (RIImm (LO imm)) - ] - in return (Any (cmmTypeFormat rep) code) - | otherwise - = do lbl <- getNewLabelNat - dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - Amode addr addr_code <- getAmode D dynRef - let rep = cmmLitType dflags lit - format = cmmTypeFormat rep - code dst = - LDATA (Section ReadOnlyData lbl) (Statics lbl [CmmStaticLit lit]) - `consOL` (addr_code `snocOL` LD format dst addr) - return (Any format code) - -getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other) - - -- extend?Rep: wrap integer expression of type rep - -- in a conversion to II32 or II64 resp. -extendSExpr :: DynFlags -> Width -> CmmExpr -> CmmExpr -extendSExpr dflags W32 x - | target32Bit (targetPlatform dflags) = x - -extendSExpr dflags W64 x - | not (target32Bit (targetPlatform dflags)) = x - -extendSExpr dflags rep x = - let size = if target32Bit $ targetPlatform dflags - then W32 - else W64 - in CmmMachOp (MO_SS_Conv rep size) [x] - -extendUExpr :: DynFlags -> Width -> CmmExpr -> CmmExpr -extendUExpr dflags W32 x - | target32Bit (targetPlatform dflags) = x -extendUExpr dflags W64 x - | not (target32Bit (targetPlatform dflags)) = x -extendUExpr dflags rep x = - let size = if target32Bit $ targetPlatform dflags - then W32 - else W64 - in CmmMachOp (MO_UU_Conv rep size) [x] - --- ----------------------------------------------------------------------------- --- The 'Amode' type: Memory addressing modes passed up the tree. - -data Amode - = Amode AddrMode InstrBlock - -{- -Now, given a tree (the argument to an CmmLoad) that references memory, -produce a suitable addressing mode. - -A Rule of the Game (tm) for Amodes: use of the addr bit must -immediately follow use of the code part, since the code part puts -values in registers which the addr then refers to. So you can't put -anything in between, lest it overwrite some of those registers. If -you need to do some other computation between the code part and use of -the addr bit, first store the effective address from the amode in a -temporary, then do the other computation, and then use the temporary: - - code - LEA amode, tmp - ... other computation ... - ... (tmp) ... --} - -{- Note [Power instruction format] -In some instructions the 16 bit offset must be a multiple of 4, i.e. -the two least significant bits must be zero. The "Power ISA" specification -calls these instruction formats "DS-FORM" and the instructions with -arbitrary 16 bit offsets are "D-FORM". - -The Power ISA specification document can be obtained from www.power.org. --} -data InstrForm = D | DS - -getAmode :: InstrForm -> CmmExpr -> NatM Amode -getAmode inf tree@(CmmRegOff _ _) - = do dflags <- getDynFlags - getAmode inf (mangleIndexTree dflags tree) - -getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W32 True (-i) - = do - (reg, code) <- getSomeReg x - return (Amode (AddrRegImm reg off) code) - - -getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W32 True i - = do - (reg, code) <- getSomeReg x - return (Amode (AddrRegImm reg off) code) - -getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W64 True (-i) - = do - (reg, code) <- getSomeReg x - return (Amode (AddrRegImm reg off) code) - - -getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W64 True i - = do - (reg, code) <- getSomeReg x - return (Amode (AddrRegImm reg off) code) - -getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W64 True (-i) - = do - (reg, code) <- getSomeReg x - (reg', off', code') <- - if i `mod` 4 == 0 - then do return (reg, off, code) - else do - tmp <- getNewRegNat II64 - return (tmp, ImmInt 0, - code `snocOL` ADD tmp reg (RIImm off)) - return (Amode (AddrRegImm reg' off') code') - -getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W64 True i - = do - (reg, code) <- getSomeReg x - (reg', off', code') <- - if i `mod` 4 == 0 - then do return (reg, off, code) - else do - tmp <- getNewRegNat II64 - return (tmp, ImmInt 0, - code `snocOL` ADD tmp reg (RIImm off)) - return (Amode (AddrRegImm reg' off') code') - - -- optimize addition with 32-bit immediate - -- (needed for PIC) -getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit]) - = do - dflags <- getDynFlags - (src, srcCode) <- getSomeReg x - let imm = litToImm lit - case () of - _ | OSAIX <- platformOS (targetPlatform dflags) - , isCmmLabelType lit -> - -- HA16/LO16 relocations on labels not supported on AIX - return (Amode (AddrRegImm src imm) srcCode) - | otherwise -> do - tmp <- getNewRegNat II32 - let code = srcCode `snocOL` ADDIS tmp src (HA imm) - return (Amode (AddrRegImm tmp (LO imm)) code) - where - isCmmLabelType (CmmLabel {}) = True - isCmmLabelType (CmmLabelOff {}) = True - isCmmLabelType (CmmLabelDiffOff {}) = True - isCmmLabelType _ = False - -getAmode _ (CmmLit lit) - = do - dflags <- getDynFlags - case platformArch $ targetPlatform dflags of - ArchPPC -> do - tmp <- getNewRegNat II32 - let imm = litToImm lit - code = unitOL (LIS tmp (HA imm)) - return (Amode (AddrRegImm tmp (LO imm)) code) - _ -> do -- TODO: Load from TOC, - -- see getRegister' _ (CmmLit lit) - tmp <- getNewRegNat II64 - let imm = litToImm lit - code = toOL [ - LIS tmp (HIGHESTA imm), - OR tmp tmp (RIImm (HIGHERA imm)), - SL II64 tmp tmp (RIImm (ImmInt 32)), - ORIS tmp tmp (HA imm) - ] - return (Amode (AddrRegImm tmp (LO imm)) code) - -getAmode _ (CmmMachOp (MO_Add W32) [x, y]) - = do - (regX, codeX) <- getSomeReg x - (regY, codeY) <- getSomeReg y - return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) - -getAmode _ (CmmMachOp (MO_Add W64) [x, y]) - = do - (regX, codeX) <- getSomeReg x - (regY, codeY) <- getSomeReg y - return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) - -getAmode _ other - = do - (reg, code) <- getSomeReg other - let - off = ImmInt 0 - return (Amode (AddrRegImm reg off) code) - - --- The 'CondCode' type: Condition codes passed up the tree. -data CondCode - = CondCode Bool Cond InstrBlock - --- Set up a condition code for a conditional branch. - -getCondCode :: CmmExpr -> NatM CondCode - --- almost the same as everywhere else - but we need to --- extend small integers to 32 bit or 64 bit first - -getCondCode (CmmMachOp mop [x, y]) - = do - dflags <- getDynFlags - case mop of - MO_F_Eq W32 -> condFltCode EQQ x y - MO_F_Ne W32 -> condFltCode NE x y - MO_F_Gt W32 -> condFltCode GTT x y - MO_F_Ge W32 -> condFltCode GE x y - MO_F_Lt W32 -> condFltCode LTT x y - MO_F_Le W32 -> condFltCode LE x y - - MO_F_Eq W64 -> condFltCode EQQ x y - MO_F_Ne W64 -> condFltCode NE x y - MO_F_Gt W64 -> condFltCode GTT x y - MO_F_Ge W64 -> condFltCode GE x y - MO_F_Lt W64 -> condFltCode LTT x y - MO_F_Le W64 -> condFltCode LE x y - - MO_Eq rep -> condIntCode EQQ (extendUExpr dflags rep x) - (extendUExpr dflags rep y) - MO_Ne rep -> condIntCode NE (extendUExpr dflags rep x) - (extendUExpr dflags rep y) - - MO_S_Gt rep -> condIntCode GTT (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - MO_S_Ge rep -> condIntCode GE (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - MO_S_Lt rep -> condIntCode LTT (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - MO_S_Le rep -> condIntCode LE (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - - MO_U_Gt rep -> condIntCode GU (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - MO_U_Ge rep -> condIntCode GEU (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - MO_U_Lt rep -> condIntCode LU (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - MO_U_Le rep -> condIntCode LEU (extendSExpr dflags rep x) - (extendSExpr dflags rep y) - - _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop) - -getCondCode _ = panic "getCondCode(2)(powerpc)" - - --- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be --- passed back up the tree. - -condIntCode, condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode - --- optimize pointer tag checks. Operation andi. sets condition register --- so cmpi ..., 0 is redundant. -condIntCode cond (CmmMachOp (MO_And _) [x, CmmLit (CmmInt imm rep)]) - (CmmLit (CmmInt 0 _)) - | not $ condUnsigned cond, - Just src2 <- makeImmediate rep False imm - = do - (src1, code) <- getSomeReg x - let code' = code `snocOL` AND r0 src1 (RIImm src2) - return (CondCode False cond code') - -condIntCode cond x (CmmLit (CmmInt y rep)) - | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y - = do - (src1, code) <- getSomeReg x - dflags <- getDynFlags - let format = archWordFormat $ target32Bit $ targetPlatform dflags - code' = code `snocOL` - (if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2) - return (CondCode False cond code') - -condIntCode cond x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - dflags <- getDynFlags - let format = archWordFormat $ target32Bit $ targetPlatform dflags - code' = code1 `appOL` code2 `snocOL` - (if condUnsigned cond then CMPL else CMP) format src1 (RIReg src2) - return (CondCode False cond code') - -condFltCode cond x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code' = code1 `appOL` code2 `snocOL` FCMP src1 src2 - code'' = case cond of -- twiddle CR to handle unordered case - GE -> code' `snocOL` CRNOR ltbit eqbit gtbit - LE -> code' `snocOL` CRNOR gtbit eqbit ltbit - _ -> code' - where - ltbit = 0 ; eqbit = 2 ; gtbit = 1 - return (CondCode True cond code'') - - - --- ----------------------------------------------------------------------------- --- Generating assignments - --- Assignments are really at the heart of the whole code generation --- business. Almost all top-level nodes of any real importance are --- assignments, which correspond to loads, stores, or register --- transfers. If we're really lucky, some of the register transfers --- will go away, because we can use the destination register to --- complete the code generation for the right hand side. This only --- fails when the right hand side is forced into a fixed register --- (e.g. the result of a call). - -assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock - -assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock - -assignMem_IntCode pk addr src = do - (srcReg, code) <- getSomeReg src - Amode dstAddr addr_code <- case pk of - II64 -> getAmode DS addr - _ -> getAmode D addr - return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr - --- dst is a reg, but src could be anything -assignReg_IntCode _ reg src - = do - dflags <- getDynFlags - let dst = getRegisterReg (targetPlatform dflags) reg - r <- getRegister src - return $ case r of - Any _ code -> code dst - Fixed _ freg fcode -> fcode `snocOL` MR dst freg - - - --- Easy, isn't it? -assignMem_FltCode = assignMem_IntCode -assignReg_FltCode = assignReg_IntCode - - - -genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock - -genJump (CmmLit (CmmLabel lbl)) - = return (unitOL $ JMP lbl) - -genJump tree - = do - dflags <- getDynFlags - genJump' tree (platformToGCP (targetPlatform dflags)) - -genJump' :: CmmExpr -> GenCCallPlatform -> NatM InstrBlock - -genJump' tree (GCPLinux64ELF 1) - = do - (target,code) <- getSomeReg tree - return (code - `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0)) - `snocOL` LD II64 toc (AddrRegImm target (ImmInt 8)) - `snocOL` MTCTR r11 - `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16)) - `snocOL` BCTR [] Nothing) - -genJump' tree (GCPLinux64ELF 2) - = do - (target,code) <- getSomeReg tree - return (code - `snocOL` MR r12 target - `snocOL` MTCTR r12 - `snocOL` BCTR [] Nothing) - -genJump' tree _ - = do - (target,code) <- getSomeReg tree - return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing) - --- ----------------------------------------------------------------------------- --- Unconditional branches -genBranch :: BlockId -> NatM InstrBlock -genBranch = return . toOL . mkJumpInstr - - --- ----------------------------------------------------------------------------- --- Conditional jumps - -{- -Conditional jumps are always to local labels, so we can use branch -instructions. We peek at the arguments to decide what kind of -comparison to do. --} - - -genCondJump - :: BlockId -- the branch target - -> CmmExpr -- the condition on which to branch - -> NatM InstrBlock - -genCondJump id bool = do - CondCode _ cond code <- getCondCode bool - return (code `snocOL` BCC cond id) - - - --- ----------------------------------------------------------------------------- --- Generating C calls - --- Now the biggest nightmare---calls. Most of the nastiness is buried in --- @get_arg@, which moves the arguments to the correct registers/stack --- locations. Apart from that, the code is easy. - -genCCall :: ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock -genCCall (PrimTarget MO_WriteBarrier) _ _ - = return $ unitOL LWSYNC - -genCCall (PrimTarget MO_Touch) _ _ - = return $ nilOL - -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ - = return $ nilOL - -genCCall (PrimTarget (MO_Clz width)) [dst] [src] - = do dflags <- getDynFlags - let platform = targetPlatform dflags - reg_dst = getRegisterReg platform (CmmLocal dst) - if target32Bit platform && width == W64 - then do - ChildCode64 code vr_lo <- iselExpr64 src - lbl1 <- getBlockIdNat - lbl2 <- getBlockIdNat - lbl3 <- getBlockIdNat - let vr_hi = getHiVRegFromLo vr_lo - cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0)) - , BCC NE lbl2 - , BCC ALWAYS lbl1 - - , NEWBLOCK lbl1 - , CNTLZ II32 reg_dst vr_lo - , ADD reg_dst reg_dst (RIImm (ImmInt 32)) - , BCC ALWAYS lbl3 - - , NEWBLOCK lbl2 - , CNTLZ II32 reg_dst vr_hi - , BCC ALWAYS lbl3 - - , NEWBLOCK lbl3 - ] - return $ code `appOL` cntlz - else do - let format = if width == W64 then II64 else II32 - (s_reg, s_code) <- getSomeReg src - (pre, reg , post) <- - case width of - W64 -> return (nilOL, s_reg, nilOL) - W32 -> return (nilOL, s_reg, nilOL) - W16 -> do - reg_tmp <- getNewRegNat format - return - ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535)) - , reg_tmp - , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-16))) - ) - W8 -> do - reg_tmp <- getNewRegNat format - return - ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255)) - , reg_tmp - , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-24))) - ) - _ -> panic "genCall: Clz wrong format" - let cntlz = unitOL (CNTLZ format reg_dst reg) - return $ s_code `appOL` pre `appOL` cntlz `appOL` post - -genCCall (PrimTarget (MO_Ctz width)) [dst] [src] - = do dflags <- getDynFlags - let platform = targetPlatform dflags - reg_dst = getRegisterReg platform (CmmLocal dst) - if target32Bit platform && width == W64 - then do - let format = II32 - ChildCode64 code vr_lo <- iselExpr64 src - lbl1 <- getBlockIdNat - lbl2 <- getBlockIdNat - lbl3 <- getBlockIdNat - x' <- getNewRegNat format - x'' <- getNewRegNat format - r' <- getNewRegNat format - cnttzlo <- cnttz format reg_dst vr_lo - let vr_hi = getHiVRegFromLo vr_lo - cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0)) - , BCC NE lbl2 - , BCC ALWAYS lbl1 - - , NEWBLOCK lbl1 - , ADD x' vr_hi (RIImm (ImmInt (-1))) - , ANDC x'' x' vr_hi - , CNTLZ format r' x'' - -- 32 + (32 - clz(x'')) - , SUBFC reg_dst r' (RIImm (ImmInt 64)) - , BCC ALWAYS lbl3 - - , NEWBLOCK lbl2 - ] - `appOL` cnttzlo `appOL` - toOL [ BCC ALWAYS lbl3 - - , NEWBLOCK lbl3 - ] - return $ code `appOL` cnttz64 - else do - let format = if width == W64 then II64 else II32 - (s_reg, s_code) <- getSomeReg src - (reg_ctz, pre_code) <- - case width of - W64 -> return (s_reg, nilOL) - W32 -> return (s_reg, nilOL) - W16 -> do - reg_tmp <- getNewRegNat format - return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1)) - W8 -> do - reg_tmp <- getNewRegNat format - return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256))) - _ -> panic "genCall: Ctz wrong format" - ctz_code <- cnttz format reg_dst reg_ctz - return $ s_code `appOL` pre_code `appOL` ctz_code - where - -- cnttz(x) = sizeof(x) - cntlz(~x & (x - 1)) - -- see Henry S. Warren, Hacker's Delight, p 107 - cnttz format dst src = do - let format_bits = 8 * formatInBytes format - x' <- getNewRegNat format - x'' <- getNewRegNat format - r' <- getNewRegNat format - return $ toOL [ ADD x' src (RIImm (ImmInt (-1))) - , ANDC x'' x' src - , CNTLZ format r' x'' - , SUBFC dst r' (RIImm (ImmInt (format_bits))) - ] - -genCCall target dest_regs argsAndHints - = do dflags <- getDynFlags - let platform = targetPlatform dflags - case target of - PrimTarget (MO_S_QuotRem width) -> divOp1 platform True width - dest_regs argsAndHints - PrimTarget (MO_U_QuotRem width) -> divOp1 platform False width - dest_regs argsAndHints - PrimTarget (MO_U_QuotRem2 width) -> divOp2 platform width dest_regs - argsAndHints - PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs - argsAndHints - PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints - PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints - PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width - dest_regs argsAndHints - PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO platform width - dest_regs argsAndHints - PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints - PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints - _ -> genCCall' dflags (platformToGCP platform) - target dest_regs argsAndHints - where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y] - = do let reg_q = getRegisterReg platform (CmmLocal res_q) - reg_r = getRegisterReg platform (CmmLocal res_r) - fmt = intFormat width - (x_reg, x_code) <- getSomeReg arg_x - (y_reg, y_code) <- getSomeReg arg_y - return $ y_code `appOL` x_code - `appOL` toOL [ DIV fmt signed reg_q x_reg y_reg - , MULL fmt reg_r reg_q (RIReg y_reg) - , SUBF reg_r reg_r x_reg - ] - - divOp1 _ _ _ _ _ - = panic "genCCall: Wrong number of arguments for divOp1" - divOp2 platform width [res_q, res_r] - [arg_x_high, arg_x_low, arg_y] - = do let reg_q = getRegisterReg platform (CmmLocal res_q) - reg_r = getRegisterReg platform (CmmLocal res_r) - fmt = intFormat width - half = 4 * (formatInBytes fmt) - (xh_reg, xh_code) <- getSomeReg arg_x_high - (xl_reg, xl_code) <- getSomeReg arg_x_low - (y_reg, y_code) <- getSomeReg arg_y - s <- getNewRegNat fmt - b <- getNewRegNat fmt - v <- getNewRegNat fmt - vn1 <- getNewRegNat fmt - vn0 <- getNewRegNat fmt - un32 <- getNewRegNat fmt - tmp <- getNewRegNat fmt - un10 <- getNewRegNat fmt - un1 <- getNewRegNat fmt - un0 <- getNewRegNat fmt - q1 <- getNewRegNat fmt - rhat <- getNewRegNat fmt - tmp1 <- getNewRegNat fmt - q0 <- getNewRegNat fmt - un21 <- getNewRegNat fmt - again1 <- getBlockIdNat - no1 <- getBlockIdNat - then1 <- getBlockIdNat - endif1 <- getBlockIdNat - again2 <- getBlockIdNat - no2 <- getBlockIdNat - then2 <- getBlockIdNat - endif2 <- getBlockIdNat - return $ y_code `appOL` xl_code `appOL` xh_code `appOL` - -- see Hacker's Delight p 196 Figure 9-3 - toOL [ -- b = 2 ^ (bits_in_word / 2) - LI b (ImmInt 1) - , SL fmt b b (RIImm (ImmInt half)) - -- s = clz(y) - , CNTLZ fmt s y_reg - -- v = y << s - , SL fmt v y_reg (RIReg s) - -- vn1 = upper half of v - , SR fmt vn1 v (RIImm (ImmInt half)) - -- vn0 = lower half of v - , CLRLI fmt vn0 v half - -- un32 = (u1 << s) - -- | (u0 >> (bits_in_word - s)) - , SL fmt un32 xh_reg (RIReg s) - , SUBFC tmp s - (RIImm (ImmInt (8 * formatInBytes fmt))) - , SR fmt tmp xl_reg (RIReg tmp) - , OR un32 un32 (RIReg tmp) - -- un10 = u0 << s - , SL fmt un10 xl_reg (RIReg s) - -- un1 = upper half of un10 - , SR fmt un1 un10 (RIImm (ImmInt half)) - -- un0 = lower half of un10 - , CLRLI fmt un0 un10 half - -- q1 = un32/vn1 - , DIV fmt False q1 un32 vn1 - -- rhat = un32 - q1*vn1 - , MULL fmt tmp q1 (RIReg vn1) - , SUBF rhat tmp un32 - , BCC ALWAYS again1 - - , NEWBLOCK again1 - -- if (q1 >= b || q1*vn0 > b*rhat + un1) - , CMPL fmt q1 (RIReg b) - , BCC GEU then1 - , BCC ALWAYS no1 - - , NEWBLOCK no1 - , MULL fmt tmp q1 (RIReg vn0) - , SL fmt tmp1 rhat (RIImm (ImmInt half)) - , ADD tmp1 tmp1 (RIReg un1) - , CMPL fmt tmp (RIReg tmp1) - , BCC LEU endif1 - , BCC ALWAYS then1 - - , NEWBLOCK then1 - -- q1 = q1 - 1 - , ADD q1 q1 (RIImm (ImmInt (-1))) - -- rhat = rhat + vn1 - , ADD rhat rhat (RIReg vn1) - -- if (rhat < b) goto again1 - , CMPL fmt rhat (RIReg b) - , BCC LTT again1 - , BCC ALWAYS endif1 - - , NEWBLOCK endif1 - -- un21 = un32*b + un1 - q1*v - , SL fmt un21 un32 (RIImm (ImmInt half)) - , ADD un21 un21 (RIReg un1) - , MULL fmt tmp q1 (RIReg v) - , SUBF un21 tmp un21 - -- compute second quotient digit - -- q0 = un21/vn1 - , DIV fmt False q0 un21 vn1 - -- rhat = un21- q0*vn1 - , MULL fmt tmp q0 (RIReg vn1) - , SUBF rhat tmp un21 - , BCC ALWAYS again2 - - , NEWBLOCK again2 - -- if (q0>b || q0*vn0 > b*rhat + un0) - , CMPL fmt q0 (RIReg b) - , BCC GEU then2 - , BCC ALWAYS no2 - - , NEWBLOCK no2 - , MULL fmt tmp q0 (RIReg vn0) - , SL fmt tmp1 rhat (RIImm (ImmInt half)) - , ADD tmp1 tmp1 (RIReg un0) - , CMPL fmt tmp (RIReg tmp1) - , BCC LEU endif2 - , BCC ALWAYS then2 - - , NEWBLOCK then2 - -- q0 = q0 - 1 - , ADD q0 q0 (RIImm (ImmInt (-1))) - -- rhat = rhat + vn1 - , ADD rhat rhat (RIReg vn1) - -- if (rhat> s - , SL fmt reg_r un21 (RIImm (ImmInt half)) - , ADD reg_r reg_r (RIReg un0) - , MULL fmt tmp q0 (RIReg v) - , SUBF reg_r tmp reg_r - , SR fmt reg_r reg_r (RIReg s) - -- compute quotient - -- q = q1*b + q0 - , SL fmt reg_q q1 (RIImm (ImmInt half)) - , ADD reg_q reg_q (RIReg q0) - ] - divOp2 _ _ _ _ - = panic "genCCall: Wrong number of arguments for divOp2" - multOp2 platform width [res_h, res_l] [arg_x, arg_y] - = do let reg_h = getRegisterReg platform (CmmLocal res_h) - reg_l = getRegisterReg platform (CmmLocal res_l) - fmt = intFormat width - (x_reg, x_code) <- getSomeReg arg_x - (y_reg, y_code) <- getSomeReg arg_y - return $ y_code `appOL` x_code - `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg) - , MULHU fmt reg_h x_reg y_reg - ] - multOp2 _ _ _ _ - = panic "genCall: Wrong number of arguments for multOp2" - add2Op platform [res_h, res_l] [arg_x, arg_y] - = do let reg_h = getRegisterReg platform (CmmLocal res_h) - reg_l = getRegisterReg platform (CmmLocal res_l) - (x_reg, x_code) <- getSomeReg arg_x - (y_reg, y_code) <- getSomeReg arg_y - return $ y_code `appOL` x_code - `appOL` toOL [ LI reg_h (ImmInt 0) - , ADDC reg_l x_reg y_reg - , ADDZE reg_h reg_h - ] - add2Op _ _ _ - = panic "genCCall: Wrong number of arguments/results for add2" - - -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1, - -- which is 0 for borrow and 1 otherwise. We need 1 and 0 - -- so xor with 1. - subcOp platform [res_r, res_c] [arg_x, arg_y] - = do let reg_r = getRegisterReg platform (CmmLocal res_r) - reg_c = getRegisterReg platform (CmmLocal res_c) - (x_reg, x_code) <- getSomeReg arg_x - (y_reg, y_code) <- getSomeReg arg_y - return $ y_code `appOL` x_code - `appOL` toOL [ LI reg_c (ImmInt 0) - , SUBFC reg_r y_reg (RIReg x_reg) - , ADDZE reg_c reg_c - , XOR reg_c reg_c (RIImm (ImmInt 1)) - ] - subcOp _ _ _ - = panic "genCCall: Wrong number of arguments/results for subc" - addSubCOp instr platform width [res_r, res_c] [arg_x, arg_y] - = do let reg_r = getRegisterReg platform (CmmLocal res_r) - reg_c = getRegisterReg platform (CmmLocal res_c) - (x_reg, x_code) <- getSomeReg arg_x - (y_reg, y_code) <- getSomeReg arg_y - return $ y_code `appOL` x_code - `appOL` toOL [ instr reg_r y_reg x_reg, - -- SUBFO argument order reversed! - MFOV (intFormat width) reg_c - ] - addSubCOp _ _ _ _ _ - = panic "genCall: Wrong number of arguments/results for addC" - fabs platform [res] [arg] - = do let res_r = getRegisterReg platform (CmmLocal res) - (arg_reg, arg_code) <- getSomeReg arg - return $ arg_code `snocOL` FABS res_r arg_reg - fabs _ _ _ - = panic "genCall: Wrong number of arguments/results for fabs" - --- TODO: replace 'Int' by an enum such as 'PPC_64ABI' -data GenCCallPlatform = GCPLinux | GCPDarwin | GCPLinux64ELF !Int | GCPAIX - -platformToGCP :: Platform -> GenCCallPlatform -platformToGCP platform = case platformOS platform of - OSLinux -> case platformArch platform of - ArchPPC -> GCPLinux - ArchPPC_64 ELF_V1 -> GCPLinux64ELF 1 - ArchPPC_64 ELF_V2 -> GCPLinux64ELF 2 - _ -> panic "PPC.CodeGen.platformToGCP: Unknown Linux" - OSAIX -> GCPAIX - OSDarwin -> GCPDarwin - _ -> panic "PPC.CodeGen.platformToGCP: not defined for this OS" - - -genCCall' - :: DynFlags - -> GenCCallPlatform - -> ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock - -{- - The PowerPC calling convention for Darwin/Mac OS X - is described in Apple's document - "Inside Mac OS X - Mach-O Runtime Architecture". - - PowerPC Linux uses the System V Release 4 Calling Convention - for PowerPC. It is described in the - "System V Application Binary Interface PowerPC Processor Supplement". - - Both conventions are similar: - Parameters may be passed in general-purpose registers starting at r3, in - floating point registers starting at f1, or on the stack. - - But there are substantial differences: - * The number of registers used for parameter passing and the exact set of - nonvolatile registers differs (see MachRegs.hs). - * On Darwin, stack space is always reserved for parameters, even if they are - passed in registers. The called routine may choose to save parameters from - registers to the corresponding space on the stack. - * On Darwin, a corresponding amount of GPRs is skipped when a floating point - parameter is passed in an FPR. - * SysV insists on either passing I64 arguments on the stack, or in two GPRs, - starting with an odd-numbered GPR. It may skip a GPR to achieve this. - Darwin just treats an I64 like two separate II32s (high word first). - * I64 and FF64 arguments are 8-byte aligned on the stack for SysV, but only - 4-byte aligned like everything else on Darwin. - * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on - PowerPC Linux does not agree, so neither do we. - - PowerPC 64 Linux uses the System V Release 4 Calling Convention for - 64-bit PowerPC. It is specified in - "64-bit PowerPC ELF Application Binary Interface Supplement 1.9" - (PPC64 ELF v1.9). - PowerPC 64 Linux in little endian mode uses the "Power Architecture 64-Bit - ELF V2 ABI Specification -- OpenPOWER ABI for Linux Supplement" - (PPC64 ELF v2). - AIX follows the "PowerOpen ABI: Application Binary Interface Big-Endian - 32-Bit Hardware Implementation" - - According to all conventions, the parameter area should be part of the - caller's stack frame, allocated in the caller's prologue code (large enough - to hold the parameter lists for all called routines). The NCG already - uses the stack for register spilling, leaving 64 bytes free at the top. - If we need a larger parameter area than that, we just allocate a new stack - frame just before ccalling. --} - - -genCCall' dflags gcp target dest_regs args - = ASSERT(not $ any (`elem` [II16]) $ map cmmTypeFormat argReps) - -- we rely on argument promotion in the codeGen - do - (finalStack,passArgumentsCode,usedRegs) <- passArguments - (zip args argReps) - allArgRegs - (allFPArgRegs platform) - initialStackOffset - (toOL []) [] - - (labelOrExpr, reduceToFF32) <- case target of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do - uses_pic_base_implicitly - return (Left lbl, False) - ForeignTarget expr _ -> do - uses_pic_base_implicitly - return (Right expr, False) - PrimTarget mop -> outOfLineMachOp mop - - let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode - codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 - - case labelOrExpr of - Left lbl -> do -- the linker does all the work for us - return ( codeBefore - `snocOL` BL lbl usedRegs - `appOL` maybeNOP -- some ABI require a NOP after BL - `appOL` codeAfter) - Right dyn -> do -- implement call through function pointer - (dynReg, dynCode) <- getSomeReg dyn - case gcp of - GCPLinux64ELF 1 -> return ( dynCode - `appOL` codeBefore - `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 40)) - `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 0)) - `snocOL` LD II64 toc (AddrRegImm dynReg (ImmInt 8)) - `snocOL` MTCTR r11 - `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 16)) - `snocOL` BCTRL usedRegs - `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 40)) - `appOL` codeAfter) - GCPLinux64ELF 2 -> return ( dynCode - `appOL` codeBefore - `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 24)) - `snocOL` MR r12 dynReg - `snocOL` MTCTR r12 - `snocOL` BCTRL usedRegs - `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 24)) - `appOL` codeAfter) - GCPAIX -> return ( dynCode - -- AIX/XCOFF follows the PowerOPEN ABI - -- which is quite similiar to LinuxPPC64/ELFv1 - `appOL` codeBefore - `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20)) - `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0)) - `snocOL` LD II32 toc (AddrRegImm dynReg (ImmInt 4)) - `snocOL` MTCTR r11 - `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 8)) - `snocOL` BCTRL usedRegs - `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 20)) - `appOL` codeAfter) - _ -> return ( dynCode - `snocOL` MTCTR dynReg - `appOL` codeBefore - `snocOL` BCTRL usedRegs - `appOL` codeAfter) - where - platform = targetPlatform dflags - - uses_pic_base_implicitly = do - -- See Note [implicit register in PPC PIC code] - -- on why we claim to use PIC register here - when (positionIndependent dflags && target32Bit platform) $ do - _ <- getPicBaseNat $ archWordFormat True - return () - - initialStackOffset = case gcp of - GCPAIX -> 24 - GCPDarwin -> 24 - GCPLinux -> 8 - GCPLinux64ELF 1 -> 48 - GCPLinux64ELF 2 -> 32 - _ -> panic "genCall': unknown calling convention" - -- size of linkage area + size of arguments, in bytes - stackDelta finalStack = case gcp of - GCPAIX -> - roundTo 16 $ (24 +) $ max 32 $ sum $ - map (widthInBytes . typeWidth) argReps - GCPDarwin -> - roundTo 16 $ (24 +) $ max 32 $ sum $ - map (widthInBytes . typeWidth) argReps - GCPLinux -> roundTo 16 finalStack - GCPLinux64ELF 1 -> - roundTo 16 $ (48 +) $ max 64 $ sum $ - map (roundTo 8 . widthInBytes . typeWidth) - argReps - GCPLinux64ELF 2 -> - roundTo 16 $ (32 +) $ max 64 $ sum $ - map (roundTo 8 . widthInBytes . typeWidth) - argReps - _ -> panic "genCall': unknown calling conv." - - argReps = map (cmmExprType dflags) args - - roundTo a x | x `mod` a == 0 = x - | otherwise = x + a - (x `mod` a) - - spFormat = if target32Bit platform then II32 else II64 - - -- TODO: Do not create a new stack frame if delta is too large. - move_sp_down finalStack - | delta > stackFrameHeaderSize dflags = - toOL [STU spFormat sp (AddrRegImm sp (ImmInt (-delta))), - DELTA (-delta)] - | otherwise = nilOL - where delta = stackDelta finalStack - move_sp_up finalStack - | delta > stackFrameHeaderSize dflags = - toOL [ADD sp sp (RIImm (ImmInt delta)), - DELTA 0] - | otherwise = nilOL - where delta = stackDelta finalStack - - -- A NOP instruction is required after a call (bl instruction) - -- on AIX and 64-Bit Linux. - -- If the call is to a function with a different TOC (r2) the - -- link editor replaces the NOP instruction with a load of the TOC - -- from the stack to restore the TOC. - maybeNOP = case gcp of - -- See Section 3.9.4 of OpenPower ABI - GCPAIX -> unitOL NOP - -- See Section 3.5.11 of PPC64 ELF v1.9 - GCPLinux64ELF 1 -> unitOL NOP - -- See Section 2.3.6 of PPC64 ELF v2 - GCPLinux64ELF 2 -> unitOL NOP - _ -> nilOL - - passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed) - passArguments ((arg,arg_ty):args) gprs fprs stackOffset - accumCode accumUsed | isWord64 arg_ty - && target32Bit (targetPlatform dflags) = - do - ChildCode64 code vr_lo <- iselExpr64 arg - let vr_hi = getHiVRegFromLo vr_lo - - case gcp of - GCPAIX -> -- same as for Darwin - do let storeWord vr (gpr:_) _ = MR gpr vr - storeWord vr [] offset - = ST II32 vr (AddrRegImm sp (ImmInt offset)) - passArguments args - (drop 2 gprs) - fprs - (stackOffset+8) - (accumCode `appOL` code - `snocOL` storeWord vr_hi gprs stackOffset - `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4)) - ((take 2 gprs) ++ accumUsed) - GCPDarwin -> - do let storeWord vr (gpr:_) _ = MR gpr vr - storeWord vr [] offset - = ST II32 vr (AddrRegImm sp (ImmInt offset)) - passArguments args - (drop 2 gprs) - fprs - (stackOffset+8) - (accumCode `appOL` code - `snocOL` storeWord vr_hi gprs stackOffset - `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4)) - ((take 2 gprs) ++ accumUsed) - GCPLinux -> - do let stackOffset' = roundTo 8 stackOffset - stackCode = accumCode `appOL` code - `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset')) - `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4))) - regCode hireg loreg = - accumCode `appOL` code - `snocOL` MR hireg vr_hi - `snocOL` MR loreg vr_lo - - case gprs of - hireg : loreg : regs | even (length gprs) -> - passArguments args regs fprs stackOffset - (regCode hireg loreg) (hireg : loreg : accumUsed) - _skipped : hireg : loreg : regs -> - passArguments args regs fprs stackOffset - (regCode hireg loreg) (hireg : loreg : accumUsed) - _ -> -- only one or no regs left - passArguments args [] fprs (stackOffset'+8) - stackCode accumUsed - GCPLinux64ELF _ -> panic "passArguments: 32 bit code" - - passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed - | reg : _ <- regs = do - register <- getRegister arg - let code = case register of - Fixed _ freg fcode -> fcode `snocOL` MR reg freg - Any _ acode -> acode reg - stackOffsetRes = case gcp of - -- The Darwin ABI requires that we reserve - -- stack slots for register parameters - GCPDarwin -> stackOffset + stackBytes - -- ... so does the PowerOpen ABI. - GCPAIX -> stackOffset + stackBytes - -- ... the SysV ABI 32-bit doesn't. - GCPLinux -> stackOffset - -- ... but SysV ABI 64-bit does. - GCPLinux64ELF _ -> stackOffset + stackBytes - passArguments args - (drop nGprs gprs) - (drop nFprs fprs) - stackOffsetRes - (accumCode `appOL` code) - (reg : accumUsed) - | otherwise = do - (vr, code) <- getSomeReg arg - passArguments args - (drop nGprs gprs) - (drop nFprs fprs) - (stackOffset' + stackBytes) - (accumCode `appOL` code `snocOL` ST (cmmTypeFormat rep) vr stackSlot) - accumUsed - where - stackOffset' = case gcp of - GCPDarwin -> - -- stackOffset is at least 4-byte aligned - -- The Darwin ABI is happy with that. - stackOffset - GCPAIX -> - -- The 32bit PowerOPEN ABI is happy with - -- 32bit-alignment as well... - stackOffset - GCPLinux - -- ... the SysV ABI requires 8-byte - -- alignment for doubles. - | isFloatType rep && typeWidth rep == W64 -> - roundTo 8 stackOffset - | otherwise -> - stackOffset - GCPLinux64ELF _ -> - -- Everything on the stack is mapped to - -- 8-byte aligned doublewords - stackOffset - stackOffset'' - | isFloatType rep && typeWidth rep == W32 = - case gcp of - -- The ELF v1 ABI Section 3.2.3 requires: - -- "Single precision floating point values - -- are mapped to the second word in a single - -- doubleword" - GCPLinux64ELF 1 -> stackOffset' + 4 - _ -> stackOffset' - | otherwise = stackOffset' - - stackSlot = AddrRegImm sp (ImmInt stackOffset'') - (nGprs, nFprs, stackBytes, regs) - = case gcp of - GCPAIX -> - case cmmTypeFormat rep of - II8 -> (1, 0, 4, gprs) - II16 -> (1, 0, 4, gprs) - II32 -> (1, 0, 4, gprs) - -- The PowerOpen ABI requires that we skip a - -- corresponding number of GPRs when we use - -- the FPRs. - -- - -- E.g. for a `double` two GPRs are skipped, - -- whereas for a `float` one GPR is skipped - -- when parameters are assigned to - -- registers. - -- - -- The PowerOpen ABI specification can be found at - -- ftp://www.sourceware.org/pub/binutils/ppc-docs/ppc-poweropen/ - FF32 -> (1, 1, 4, fprs) - FF64 -> (2, 1, 8, fprs) - II64 -> panic "genCCall' passArguments II64" - FF80 -> panic "genCCall' passArguments FF80" - GCPDarwin -> - case cmmTypeFormat rep of - II8 -> (1, 0, 4, gprs) - II16 -> (1, 0, 4, gprs) - II32 -> (1, 0, 4, gprs) - -- The Darwin ABI requires that we skip a - -- corresponding number of GPRs when we use - -- the FPRs. - FF32 -> (1, 1, 4, fprs) - FF64 -> (2, 1, 8, fprs) - II64 -> panic "genCCall' passArguments II64" - FF80 -> panic "genCCall' passArguments FF80" - GCPLinux -> - case cmmTypeFormat rep of - II8 -> (1, 0, 4, gprs) - II16 -> (1, 0, 4, gprs) - II32 -> (1, 0, 4, gprs) - -- ... the SysV ABI doesn't. - FF32 -> (0, 1, 4, fprs) - FF64 -> (0, 1, 8, fprs) - II64 -> panic "genCCall' passArguments II64" - FF80 -> panic "genCCall' passArguments FF80" - GCPLinux64ELF _ -> - case cmmTypeFormat rep of - II8 -> (1, 0, 8, gprs) - II16 -> (1, 0, 8, gprs) - II32 -> (1, 0, 8, gprs) - II64 -> (1, 0, 8, gprs) - -- The ELFv1 ABI requires that we skip a - -- corresponding number of GPRs when we use - -- the FPRs. - FF32 -> (1, 1, 8, fprs) - FF64 -> (1, 1, 8, fprs) - FF80 -> panic "genCCall' passArguments FF80" - - moveResult reduceToFF32 = - case dest_regs of - [] -> nilOL - [dest] - | reduceToFF32 && isFloat32 rep -> unitOL (FRSP r_dest f1) - | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1) - | isWord64 rep && target32Bit (targetPlatform dflags) - -> toOL [MR (getHiVRegFromLo r_dest) r3, - MR r_dest r4] - | otherwise -> unitOL (MR r_dest r3) - where rep = cmmRegType dflags (CmmLocal dest) - r_dest = getRegisterReg platform (CmmLocal dest) - _ -> panic "genCCall' moveResult: Bad dest_regs" - - outOfLineMachOp mop = - do - dflags <- getDynFlags - mopExpr <- cmmMakeDynamicReference dflags CallReference $ - mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction - let mopLabelOrExpr = case mopExpr of - CmmLit (CmmLabel lbl) -> Left lbl - _ -> Right mopExpr - return (mopLabelOrExpr, reduce) - where - (functionName, reduce) = case mop of - MO_F32_Exp -> (fsLit "exp", True) - MO_F32_Log -> (fsLit "log", True) - MO_F32_Sqrt -> (fsLit "sqrt", True) - MO_F32_Fabs -> unsupported - - MO_F32_Sin -> (fsLit "sin", True) - MO_F32_Cos -> (fsLit "cos", True) - MO_F32_Tan -> (fsLit "tan", True) - - MO_F32_Asin -> (fsLit "asin", True) - MO_F32_Acos -> (fsLit "acos", True) - MO_F32_Atan -> (fsLit "atan", True) - - MO_F32_Sinh -> (fsLit "sinh", True) - MO_F32_Cosh -> (fsLit "cosh", True) - MO_F32_Tanh -> (fsLit "tanh", True) - MO_F32_Pwr -> (fsLit "pow", True) - - MO_F64_Exp -> (fsLit "exp", False) - MO_F64_Log -> (fsLit "log", False) - MO_F64_Sqrt -> (fsLit "sqrt", False) - MO_F64_Fabs -> unsupported - - MO_F64_Sin -> (fsLit "sin", False) - MO_F64_Cos -> (fsLit "cos", False) - MO_F64_Tan -> (fsLit "tan", False) - - MO_F64_Asin -> (fsLit "asin", False) - MO_F64_Acos -> (fsLit "acos", False) - MO_F64_Atan -> (fsLit "atan", False) - - MO_F64_Sinh -> (fsLit "sinh", False) - MO_F64_Cosh -> (fsLit "cosh", False) - MO_F64_Tanh -> (fsLit "tanh", False) - MO_F64_Pwr -> (fsLit "pow", False) - - MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False) - - MO_Memcpy _ -> (fsLit "memcpy", False) - MO_Memset _ -> (fsLit "memset", False) - MO_Memmove _ -> (fsLit "memmove", False) - - MO_BSwap w -> (fsLit $ bSwapLabel w, False) - MO_PopCnt w -> (fsLit $ popCntLabel w, False) - MO_Clz w -> (fsLit $ clzLabel w, False) - MO_Ctz w -> (fsLit $ ctzLabel w, False) - MO_AtomicRMW w amop -> (fsLit $ atomicRMWLabel w amop, False) - MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False) - MO_AtomicRead w -> (fsLit $ atomicReadLabel w, False) - MO_AtomicWrite w -> (fsLit $ atomicWriteLabel w, False) - - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - MO_Add2 {} -> unsupported - MO_SubWordC {} -> unsupported - MO_AddIntC {} -> unsupported - MO_SubIntC {} -> unsupported - MO_U_Mul2 {} -> unsupported - MO_WriteBarrier -> unsupported - MO_Touch -> unsupported - (MO_Prefetch_Data _ ) -> unsupported - unsupported = panic ("outOfLineCmmOp: " ++ show mop - ++ " not supported") - --- ----------------------------------------------------------------------------- --- Generating a table-branch - -genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch dflags expr targets - | OSAIX <- platformOS (targetPlatform dflags) - = do - (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) - let fmt = archWordFormat $ target32Bit $ targetPlatform dflags - sha = if target32Bit $ targetPlatform dflags then 2 else 3 - tmp <- getNewRegNat fmt - lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - (tableReg,t_code) <- getSomeReg $ dynRef - let code = e_code `appOL` t_code `appOL` toOL [ - SL fmt tmp reg (RIImm (ImmInt sha)), - LD fmt tmp (AddrRegReg tableReg tmp), - MTCTR tmp, - BCTR ids (Just lbl) - ] - return code - - | (positionIndependent dflags) || (not $ target32Bit $ targetPlatform dflags) - = do - (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) - let fmt = archWordFormat $ target32Bit $ targetPlatform dflags - sha = if target32Bit $ targetPlatform dflags then 2 else 3 - tmp <- getNewRegNat fmt - lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - (tableReg,t_code) <- getSomeReg $ dynRef - let code = e_code `appOL` t_code `appOL` toOL [ - SL fmt tmp reg (RIImm (ImmInt sha)), - LD fmt tmp (AddrRegReg tableReg tmp), - ADD tmp tmp (RIReg tableReg), - MTCTR tmp, - BCTR ids (Just lbl) - ] - return code - | otherwise - = do - (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) - let fmt = archWordFormat $ target32Bit $ targetPlatform dflags - sha = if target32Bit $ targetPlatform dflags then 2 else 3 - tmp <- getNewRegNat fmt - lbl <- getNewLabelNat - let code = e_code `appOL` toOL [ - SL fmt tmp reg (RIImm (ImmInt sha)), - ADDIS tmp tmp (HA (ImmCLbl lbl)), - LD fmt tmp (AddrRegImm tmp (LO (ImmCLbl lbl))), - MTCTR tmp, - BCTR ids (Just lbl) - ] - return code - where (offset, ids) = switchTargetsToTable targets - -generateJumpTableForInstr :: DynFlags -> Instr - -> Maybe (NatCmmDecl CmmStatics Instr) -generateJumpTableForInstr dflags (BCTR ids (Just lbl)) = - let jumpTable - | (positionIndependent dflags) - || (not $ target32Bit $ targetPlatform dflags) - = map jumpTableEntryRel ids - | otherwise = map (jumpTableEntry dflags) ids - where jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 (wordWidth dflags)) - jumpTableEntryRel (Just blockid) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) - where blockLabel = mkAsmTempLabel (getUnique blockid) - in Just (CmmData (Section ReadOnlyData lbl) (Statics lbl jumpTable)) -generateJumpTableForInstr _ _ = Nothing - --- ----------------------------------------------------------------------------- --- 'condIntReg' and 'condFltReg': condition codes into registers - --- Turn those condition codes into integers now (when they appear on --- the right hand side of an assignment). - -condIntReg, condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register - -condReg :: NatM CondCode -> NatM Register -condReg getCond = do - CondCode _ cond cond_code <- getCond - dflags <- getDynFlags - let - code dst = cond_code - `appOL` negate_code - `appOL` toOL [ - MFCR dst, - RLWINM dst dst (bit + 1) 31 31 - ] - - negate_code | do_negate = unitOL (CRNOR bit bit bit) - | otherwise = nilOL - - (bit, do_negate) = case cond of - LTT -> (0, False) - LE -> (1, True) - EQQ -> (2, False) - GE -> (0, True) - GTT -> (1, False) - - NE -> (2, True) - - LU -> (0, False) - LEU -> (1, True) - GEU -> (0, True) - GU -> (1, False) - _ -> panic "PPC.CodeGen.codeReg: no match" - - format = archWordFormat $ target32Bit $ targetPlatform dflags - return (Any format code) - -condIntReg cond x y = condReg (condIntCode cond x y) -condFltReg cond x y = condReg (condFltCode cond x y) - - - --- ----------------------------------------------------------------------------- --- 'trivial*Code': deal with trivial instructions - --- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', --- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. --- Only look for constants on the right hand side, because that's --- where the generic optimizer will have put them. - --- Similarly, for unary instructions, we don't have to worry about --- matching an StInt as the argument, because genericOpt will already --- have handled the constant-folding. - - - -{- -Wolfgang's PowerPC version of The Rules: - -A slightly modified version of The Rules to take advantage of the fact -that PowerPC instructions work on all registers and don't implicitly -clobber any fixed registers. - -* The only expression for which getRegister returns Fixed is (CmmReg reg). - -* If getRegister returns Any, then the code it generates may modify only: - (a) fresh temporaries - (b) the destination register - It may *not* modify global registers, unless the global - register happens to be the destination register. - It may not clobber any other registers. In fact, only ccalls clobber any - fixed registers. - Also, it may not modify the counter register (used by genCCall). - - Corollary: If a getRegister for a subexpression returns Fixed, you need - not move it to a fresh temporary before evaluating the next subexpression. - The Fixed register won't be modified. - Therefore, we don't need a counterpart for the x86's getStableReg on PPC. - -* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on - the value of the destination register. --} - -trivialCode - :: Width - -> Bool - -> (Reg -> Reg -> RI -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - -trivialCode rep signed instr x (CmmLit (CmmInt y _)) - | Just imm <- makeImmediate rep signed y - = do - (src1, code1) <- getSomeReg x - let code dst = code1 `snocOL` instr dst src1 (RIImm imm) - return (Any (intFormat rep) code) - -trivialCode rep _ instr x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2) - return (Any (intFormat rep) code) - -shiftMulCode - :: Width - -> Bool - -> (Format-> Reg -> Reg -> RI -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register -shiftMulCode width sign instr x (CmmLit (CmmInt y _)) - | Just imm <- makeImmediate width sign y - = do - (src1, code1) <- getSomeReg x - let format = intFormat width - let code dst = code1 `snocOL` instr format dst src1 (RIImm imm) - return (Any format code) - -shiftMulCode width _ instr x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let format = intFormat width - let code dst = code1 `appOL` code2 `snocOL` instr format dst src1 (RIReg src2) - return (Any format code) - -trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialCodeNoImm' format instr x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2 - return (Any format code) - -trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialCodeNoImm format instr x y = trivialCodeNoImm' format (instr format) x y - -trivialCodeNoImmSign :: Format -> Bool - -> (Format -> Bool -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialCodeNoImmSign format sgn instr x y - = trivialCodeNoImm' format (instr format sgn) x y - - -trivialUCode - :: Format - -> (Reg -> Reg -> Instr) - -> CmmExpr - -> NatM Register -trivialUCode rep instr x = do - (src, code) <- getSomeReg x - let code' dst = code `snocOL` instr dst src - return (Any rep code') - --- There is no "remainder" instruction on the PPC, so we have to do --- it the hard way. --- The "sgn" parameter is the signedness for the division instruction - -remainderCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register -remainderCode rep sgn x y = do - let fmt = intFormat rep - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let code dst = code1 `appOL` code2 `appOL` toOL [ - DIV fmt sgn dst src1 src2, - MULL fmt dst dst (RIReg src2), - SUBF dst dst src1 - ] - return (Any (intFormat rep) code) - -coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register -coerceInt2FP fromRep toRep x = do - dflags <- getDynFlags - let arch = platformArch $ targetPlatform dflags - coerceInt2FP' arch fromRep toRep x - -coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register -coerceInt2FP' ArchPPC fromRep toRep x = do - (src, code) <- getSomeReg x - lbl <- getNewLabelNat - itmp <- getNewRegNat II32 - ftmp <- getNewRegNat FF64 - dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - Amode addr addr_code <- getAmode D dynRef - let - code' dst = code `appOL` maybe_exts `appOL` toOL [ - LDATA (Section ReadOnlyData lbl) $ Statics lbl - [CmmStaticLit (CmmInt 0x43300000 W32), - CmmStaticLit (CmmInt 0x80000000 W32)], - XORIS itmp src (ImmInt 0x8000), - ST II32 itmp (spRel dflags 3), - LIS itmp (ImmInt 0x4330), - ST II32 itmp (spRel dflags 2), - LD FF64 ftmp (spRel dflags 2) - ] `appOL` addr_code `appOL` toOL [ - LD FF64 dst addr, - FSUB FF64 dst ftmp dst - ] `appOL` maybe_frsp dst - - maybe_exts = case fromRep of - W8 -> unitOL $ EXTS II8 src src - W16 -> unitOL $ EXTS II16 src src - W32 -> nilOL - _ -> panic "PPC.CodeGen.coerceInt2FP: no match" - - maybe_frsp dst - = case toRep of - W32 -> unitOL $ FRSP dst dst - W64 -> nilOL - _ -> panic "PPC.CodeGen.coerceInt2FP: no match" - - return (Any (floatFormat toRep) code') - --- On an ELF v1 Linux we use the compiler doubleword in the stack frame --- this is the TOC pointer doubleword on ELF v2 Linux. The latter is only --- set right before a call and restored right after return from the call. --- So it is fine. -coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do - (src, code) <- getSomeReg x - dflags <- getDynFlags - let - code' dst = code `appOL` maybe_exts `appOL` toOL [ - ST II64 src (spRel dflags 3), - LD FF64 dst (spRel dflags 3), - FCFID dst dst - ] `appOL` maybe_frsp dst - - maybe_exts = case fromRep of - W8 -> unitOL $ EXTS II8 src src - W16 -> unitOL $ EXTS II16 src src - W32 -> unitOL $ EXTS II32 src src - W64 -> nilOL - _ -> panic "PPC.CodeGen.coerceInt2FP: no match" - - maybe_frsp dst - = case toRep of - W32 -> unitOL $ FRSP dst dst - W64 -> nilOL - _ -> panic "PPC.CodeGen.coerceInt2FP: no match" - - return (Any (floatFormat toRep) code') - -coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch" - - -coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register -coerceFP2Int fromRep toRep x = do - dflags <- getDynFlags - let arch = platformArch $ targetPlatform dflags - coerceFP2Int' arch fromRep toRep x - -coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register -coerceFP2Int' ArchPPC _ toRep x = do - dflags <- getDynFlags - -- the reps don't really matter: F*->FF64 and II32->I* are no-ops - (src, code) <- getSomeReg x - tmp <- getNewRegNat FF64 - let - code' dst = code `appOL` toOL [ - -- convert to int in FP reg - FCTIWZ tmp src, - -- store value (64bit) from FP to stack - ST FF64 tmp (spRel dflags 2), - -- read low word of value (high word is undefined) - LD II32 dst (spRel dflags 3)] - return (Any (intFormat toRep) code') - -coerceFP2Int' (ArchPPC_64 _) _ toRep x = do - dflags <- getDynFlags - -- the reps don't really matter: F*->FF64 and II64->I* are no-ops - (src, code) <- getSomeReg x - tmp <- getNewRegNat FF64 - let - code' dst = code `appOL` toOL [ - -- convert to int in FP reg - FCTIDZ tmp src, - -- store value (64bit) from FP to compiler word on stack - ST FF64 tmp (spRel dflags 3), - LD II64 dst (spRel dflags 3)] - return (Any (intFormat toRep) code') - -coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch" - --- Note [.LCTOC1 in PPC PIC code] --- The .LCTOC1 label is defined to point 32768 bytes into the GOT table --- to make the most of the PPC's 16-bit displacements. --- As 16-bit signed offset is used (usually via addi/lwz instructions) --- first element will have '-32768' offset against .LCTOC1. - --- Note [implicit register in PPC PIC code] --- PPC generates calls by labels in assembly --- in form of: --- bl puts+32768@plt --- in this form it's not seen directly (by GHC NCG) --- that r30 (PicBaseReg) is used, --- but r30 is a required part of PLT code setup: --- puts+32768@plt: --- lwz r11,-30484(r30) ; offset in .LCTOC1 --- mtctr r11 --- bctr diff --git a/nativeGen/PPC/Cond.hs b/nativeGen/PPC/Cond.hs deleted file mode 100644 --- a/nativeGen/PPC/Cond.hs +++ /dev/null @@ -1,61 +0,0 @@ -module PPC.Cond ( - Cond(..), - condNegate, - condUnsigned, - condToSigned, - condToUnsigned, -) - -where - -import Panic - -data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - deriving Eq - - -condNegate :: Cond -> Cond -condNegate ALWAYS = panic "condNegate: ALWAYS" -condNegate EQQ = NE -condNegate GE = LTT -condNegate GEU = LU -condNegate GTT = LE -condNegate GU = LEU -condNegate LE = GTT -condNegate LEU = GU -condNegate LTT = GE -condNegate LU = GEU -condNegate NE = EQQ - --- Condition utils -condUnsigned :: Cond -> Bool -condUnsigned GU = True -condUnsigned LU = True -condUnsigned GEU = True -condUnsigned LEU = True -condUnsigned _ = False - -condToSigned :: Cond -> Cond -condToSigned GU = GTT -condToSigned LU = LTT -condToSigned GEU = GE -condToSigned LEU = LE -condToSigned x = x - -condToUnsigned :: Cond -> Cond -condToUnsigned GTT = GU -condToUnsigned LTT = LU -condToUnsigned GE = GEU -condToUnsigned LE = LEU -condToUnsigned x = x diff --git a/nativeGen/PPC/Instr.hs b/nativeGen/PPC/Instr.hs deleted file mode 100644 --- a/nativeGen/PPC/Instr.hs +++ /dev/null @@ -1,686 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Machine-dependent assembly language --- --- (c) The University of Glasgow 1993-2004 --- ------------------------------------------------------------------------------ - -#include "HsVersions.h" -#include "nativeGen/NCG.h" - -module PPC.Instr ( - archWordFormat, - RI(..), - Instr(..), - stackFrameHeaderSize, - maxSpillSlots, - allocMoreStack, - makeFarBranches -) - -where - -import PPC.Regs -import PPC.Cond -import Instruction -import Format -import TargetReg -import RegClass -import Reg - -import CodeGen.Platform -import BlockId -import Hoopl -import DynFlags -import Cmm -import CmmInfo -import FastString -import CLabel -import Outputable -import Platform -import UniqFM (listToUFM, lookupUFM) -import UniqSupply - -import Control.Monad (replicateM) -import Data.Maybe (fromMaybe) - --------------------------------------------------------------------------------- --- Format of a PPC memory address. --- -archWordFormat :: Bool -> Format -archWordFormat is32Bit - | is32Bit = II32 - | otherwise = II64 - - --- | Instruction instance for powerpc -instance Instruction Instr where - regUsageOfInstr = ppc_regUsageOfInstr - patchRegsOfInstr = ppc_patchRegsOfInstr - isJumpishInstr = ppc_isJumpishInstr - jumpDestsOfInstr = ppc_jumpDestsOfInstr - patchJumpInstr = ppc_patchJumpInstr - mkSpillInstr = ppc_mkSpillInstr - mkLoadInstr = ppc_mkLoadInstr - takeDeltaInstr = ppc_takeDeltaInstr - isMetaInstr = ppc_isMetaInstr - mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr - takeRegRegMoveInstr = ppc_takeRegRegMoveInstr - mkJumpInstr = ppc_mkJumpInstr - mkStackAllocInstr = ppc_mkStackAllocInstr - mkStackDeallocInstr = ppc_mkStackDeallocInstr - - -ppc_mkStackAllocInstr :: Platform -> Int -> Instr -ppc_mkStackAllocInstr platform amount - = ppc_mkStackAllocInstr' platform (-amount) - -ppc_mkStackDeallocInstr :: Platform -> Int -> Instr -ppc_mkStackDeallocInstr platform amount - = ppc_mkStackAllocInstr' platform amount - -ppc_mkStackAllocInstr' :: Platform -> Int -> Instr -ppc_mkStackAllocInstr' platform amount - = case platformArch platform of - ArchPPC -> UPDATE_SP II32 (ImmInt amount) - ArchPPC_64 _ -> UPDATE_SP II64 (ImmInt amount) - _ -> panic $ "ppc_mkStackAllocInstr' " - ++ show (platformArch platform) - --- --- See note [extra spill slots] in X86/Instr.hs --- -allocMoreStack - :: Platform - -> Int - -> NatCmmDecl statics PPC.Instr.Instr - -> UniqSM (NatCmmDecl statics PPC.Instr.Instr) - -allocMoreStack _ _ top@(CmmData _ _) = return top -allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do - let - infos = mapKeys info - entries = case code of - [] -> infos - BasicBlock entry _ : _ -- first block is the entry point - | entry `elem` infos -> infos - | otherwise -> entry : infos - - uniqs <- replicateM (length entries) getUniqueM - - let - delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up - where x = slots * spillSlotSize -- sp delta - - alloc = mkStackAllocInstr platform delta - dealloc = mkStackDeallocInstr platform delta - - new_blockmap :: LabelMap BlockId - new_blockmap = mapFromList (zip entries (map mkBlockId uniqs)) - - insert_stack_insns (BasicBlock id insns) - | Just new_blockid <- mapLookup id new_blockmap - = [ BasicBlock id [alloc, BCC ALWAYS new_blockid] - , BasicBlock new_blockid block' - ] - | otherwise - = [ BasicBlock id block' ] - where - block' = foldr insert_dealloc [] insns - - insert_dealloc insn r - -- BCTR might or might not be a non-local jump. For - -- "labeled-goto" we use JMP, and for "computed-goto" we - -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'. - = case insn of - JMP _ -> dealloc : insn : r - BCTR [] Nothing -> dealloc : insn : r - BCTR ids label -> BCTR (map (fmap retarget) ids) label : r - BCCFAR cond b -> BCCFAR cond (retarget b) : r - BCC cond b -> BCC cond (retarget b) : r - _ -> insn : r - -- BL and BCTRL are call-like instructions rather than - -- jumps, and are used only for C calls. - - retarget :: BlockId -> BlockId - retarget b - = fromMaybe b (mapLookup b new_blockmap) - - new_code - = concatMap insert_stack_insns code - - -- in - return (CmmProc info lbl live (ListGraph new_code)) - - --- ----------------------------------------------------------------------------- --- Machine's assembly language - --- We have a few common "instructions" (nearly all the pseudo-ops) but --- mostly all of 'Instr' is machine-specific. - --- Register or immediate -data RI - = RIReg Reg - | RIImm Imm - -data Instr - -- comment pseudo-op - = COMMENT FastString - - -- some static data spat out during code - -- generation. Will be extracted before - -- pretty-printing. - | LDATA Section CmmStatics - - -- start a new basic block. Useful during - -- codegen, removed later. Preceding - -- instruction should be a jump, as per the - -- invariants for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- specify current stack offset for - -- benefit of subsequent passes - | DELTA Int - - -- Loads and stores. - | LD Format Reg AddrMode -- Load format, dst, src - | LDFAR Format Reg AddrMode -- Load format, dst, src 32 bit offset - | LA Format Reg AddrMode -- Load arithmetic format, dst, src - | ST Format Reg AddrMode -- Store format, src, dst - | STFAR Format Reg AddrMode -- Store format, src, dst 32 bit offset - | STU Format Reg AddrMode -- Store with Update format, src, dst - | LIS Reg Imm -- Load Immediate Shifted dst, src - | LI Reg Imm -- Load Immediate dst, src - | MR Reg Reg -- Move Register dst, src -- also for fmr - - | CMP Format Reg RI -- format, src1, src2 - | CMPL Format Reg RI -- format, src1, src2 - - | BCC Cond BlockId - | BCCFAR Cond BlockId - | JMP CLabel -- same as branch, - -- but with CLabel instead of block ID - | MTCTR Reg - | BCTR [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary - | BL CLabel [Reg] -- with list of argument regs - | BCTRL [Reg] - - | ADD Reg Reg RI -- dst, src1, src2 - | ADDO Reg Reg Reg -- add and set overflow - | ADDC Reg Reg Reg -- (carrying) dst, src1, src2 - | ADDE Reg Reg Reg -- (extended) dst, src1, src2 - | ADDZE Reg Reg -- (to zero extended) dst, src - | ADDIS Reg Reg Imm -- Add Immediate Shifted dst, src1, src2 - | SUBF Reg Reg Reg -- dst, src1, src2 ; dst = src2 - src1 - | SUBFO Reg Reg Reg -- subtract from and set overflow - | SUBFC Reg Reg RI -- (carrying) dst, src1, src2 ; - -- dst = src2 - src1 - | SUBFE Reg Reg Reg -- (extended) dst, src1, src2 ; - -- dst = src2 - src1 - | MULL Format Reg Reg RI - | MULLO Format Reg Reg Reg -- multiply and set overflow - | MFOV Format Reg -- move overflow bit (1|33) to register - -- pseudo-instruction; pretty printed as - -- mfxer dst - -- extr[w|d]i dst, dst, 1, [1|33] - | MULHU Format Reg Reg Reg - | DIV Format Bool Reg Reg Reg - | AND Reg Reg RI -- dst, src1, src2 - | ANDC Reg Reg Reg -- AND with complement, dst = src1 & ~ src2 - | OR Reg Reg RI -- dst, src1, src2 - | ORIS Reg Reg Imm -- OR Immediate Shifted dst, src1, src2 - | XOR Reg Reg RI -- dst, src1, src2 - | XORIS Reg Reg Imm -- XOR Immediate Shifted dst, src1, src2 - - | EXTS Format Reg Reg - | CNTLZ Format Reg Reg - - | NEG Reg Reg - | NOT Reg Reg - - | SL Format Reg Reg RI -- shift left - | SR Format Reg Reg RI -- shift right - | SRA Format Reg Reg RI -- shift right arithmetic - - | RLWINM Reg Reg Int Int Int -- Rotate Left Word Immediate then AND with Mask - | CLRLI Format Reg Reg Int -- clear left immediate (extended mnemonic) - | CLRRI Format Reg Reg Int -- clear right immediate (extended mnemonic) - - | FADD Format Reg Reg Reg - | FSUB Format Reg Reg Reg - | FMUL Format Reg Reg Reg - | FDIV Format Reg Reg Reg - | FABS Reg Reg -- abs is the same for single and double - | FNEG Reg Reg -- negate is the same for single and double prec. - - | FCMP Reg Reg - - | FCTIWZ Reg Reg -- convert to integer word - | FCTIDZ Reg Reg -- convert to integer double word - | FCFID Reg Reg -- convert from integer double word - | FRSP Reg Reg -- reduce to single precision - -- (but destination is a FP register) - - | CRNOR Int Int Int -- condition register nor - | MFCR Reg -- move from condition register - - | MFLR Reg -- move from link register - | FETCHPC Reg -- pseudo-instruction: - -- bcl to next insn, mflr reg - | LWSYNC -- memory barrier - | NOP -- no operation, PowerPC 64 bit - -- needs this as place holder to - -- reload TOC pointer - | UPDATE_SP Format Imm -- expand/shrink spill area on C stack - -- pseudo-instruction - --- | Get the registers that are being used by this instruction. --- regUsage doesn't need to do any trickery for jumps and such. --- Just state precisely the regs read and written by that insn. --- The consequences of control flow transfers, as far as register --- allocation goes, are taken care of by the register allocator. --- -ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage -ppc_regUsageOfInstr platform instr - = case instr of - LD _ reg addr -> usage (regAddr addr, [reg]) - LDFAR _ reg addr -> usage (regAddr addr, [reg]) - LA _ reg addr -> usage (regAddr addr, [reg]) - ST _ reg addr -> usage (reg : regAddr addr, []) - STFAR _ reg addr -> usage (reg : regAddr addr, []) - STU _ reg addr -> usage (reg : regAddr addr, []) - LIS reg _ -> usage ([], [reg]) - LI reg _ -> usage ([], [reg]) - MR reg1 reg2 -> usage ([reg2], [reg1]) - CMP _ reg ri -> usage (reg : regRI ri,[]) - CMPL _ reg ri -> usage (reg : regRI ri,[]) - BCC _ _ -> noUsage - BCCFAR _ _ -> noUsage - MTCTR reg -> usage ([reg],[]) - BCTR _ _ -> noUsage - BL _ params -> usage (params, callClobberedRegs platform) - BCTRL params -> usage (params, callClobberedRegs platform) - - ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - ADDO reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - ADDC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - ADDE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - ADDZE reg1 reg2 -> usage ([reg2], [reg1]) - ADDIS reg1 reg2 _ -> usage ([reg2], [reg1]) - SUBF reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - SUBFO reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - SUBFC reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - SUBFE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - MULL _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - MULLO _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - MFOV _ reg -> usage ([], [reg]) - MULHU _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - DIV _ _ reg1 reg2 reg3 - -> usage ([reg2,reg3], [reg1]) - - AND reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - ANDC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - OR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - ORIS reg1 reg2 _ -> usage ([reg2], [reg1]) - XOR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - XORIS reg1 reg2 _ -> usage ([reg2], [reg1]) - EXTS _ reg1 reg2 -> usage ([reg2], [reg1]) - CNTLZ _ reg1 reg2 -> usage ([reg2], [reg1]) - NEG reg1 reg2 -> usage ([reg2], [reg1]) - NOT reg1 reg2 -> usage ([reg2], [reg1]) - SL _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - SR _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - SRA _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - RLWINM reg1 reg2 _ _ _ -> usage ([reg2], [reg1]) - CLRLI _ reg1 reg2 _ -> usage ([reg2], [reg1]) - CLRRI _ reg1 reg2 _ -> usage ([reg2], [reg1]) - - FADD _ r1 r2 r3 -> usage ([r2,r3], [r1]) - FSUB _ r1 r2 r3 -> usage ([r2,r3], [r1]) - FMUL _ r1 r2 r3 -> usage ([r2,r3], [r1]) - FDIV _ r1 r2 r3 -> usage ([r2,r3], [r1]) - FABS r1 r2 -> usage ([r2], [r1]) - FNEG r1 r2 -> usage ([r2], [r1]) - FCMP r1 r2 -> usage ([r1,r2], []) - FCTIWZ r1 r2 -> usage ([r2], [r1]) - FCTIDZ r1 r2 -> usage ([r2], [r1]) - FCFID r1 r2 -> usage ([r2], [r1]) - FRSP r1 r2 -> usage ([r2], [r1]) - MFCR reg -> usage ([], [reg]) - MFLR reg -> usage ([], [reg]) - FETCHPC reg -> usage ([], [reg]) - UPDATE_SP _ _ -> usage ([], [sp]) - _ -> noUsage - where - usage (src, dst) = RU (filter (interesting platform) src) - (filter (interesting platform) dst) - regAddr (AddrRegReg r1 r2) = [r1, r2] - regAddr (AddrRegImm r1 _) = [r1] - - regRI (RIReg r) = [r] - regRI _ = [] - -interesting :: Platform -> Reg -> Bool -interesting _ (RegVirtual _) = True -interesting platform (RegReal (RealRegSingle i)) = freeReg platform i -interesting _ (RegReal (RealRegPair{})) - = panic "PPC.Instr.interesting: no reg pairs on this arch" - - - --- | Apply a given mapping to all the register references in this --- instruction. -ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr -ppc_patchRegsOfInstr instr env - = case instr of - LD fmt reg addr -> LD fmt (env reg) (fixAddr addr) - LDFAR fmt reg addr -> LDFAR fmt (env reg) (fixAddr addr) - LA fmt reg addr -> LA fmt (env reg) (fixAddr addr) - ST fmt reg addr -> ST fmt (env reg) (fixAddr addr) - STFAR fmt reg addr -> STFAR fmt (env reg) (fixAddr addr) - STU fmt reg addr -> STU fmt (env reg) (fixAddr addr) - LIS reg imm -> LIS (env reg) imm - LI reg imm -> LI (env reg) imm - MR reg1 reg2 -> MR (env reg1) (env reg2) - CMP fmt reg ri -> CMP fmt (env reg) (fixRI ri) - CMPL fmt reg ri -> CMPL fmt (env reg) (fixRI ri) - BCC cond lbl -> BCC cond lbl - BCCFAR cond lbl -> BCCFAR cond lbl - MTCTR reg -> MTCTR (env reg) - BCTR targets lbl -> BCTR targets lbl - BL imm argRegs -> BL imm argRegs -- argument regs - BCTRL argRegs -> BCTRL argRegs -- cannot be remapped - ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri) - ADDO reg1 reg2 reg3 -> ADDO (env reg1) (env reg2) (env reg3) - ADDC reg1 reg2 reg3 -> ADDC (env reg1) (env reg2) (env reg3) - ADDE reg1 reg2 reg3 -> ADDE (env reg1) (env reg2) (env reg3) - ADDZE reg1 reg2 -> ADDZE (env reg1) (env reg2) - ADDIS reg1 reg2 imm -> ADDIS (env reg1) (env reg2) imm - SUBF reg1 reg2 reg3 -> SUBF (env reg1) (env reg2) (env reg3) - SUBFO reg1 reg2 reg3 -> SUBFO (env reg1) (env reg2) (env reg3) - SUBFC reg1 reg2 ri -> SUBFC (env reg1) (env reg2) (fixRI ri) - SUBFE reg1 reg2 reg3 -> SUBFE (env reg1) (env reg2) (env reg3) - MULL fmt reg1 reg2 ri - -> MULL fmt (env reg1) (env reg2) (fixRI ri) - MULLO fmt reg1 reg2 reg3 - -> MULLO fmt (env reg1) (env reg2) (env reg3) - MFOV fmt reg -> MFOV fmt (env reg) - MULHU fmt reg1 reg2 reg3 - -> MULHU fmt (env reg1) (env reg2) (env reg3) - DIV fmt sgn reg1 reg2 reg3 - -> DIV fmt sgn (env reg1) (env reg2) (env reg3) - - AND reg1 reg2 ri -> AND (env reg1) (env reg2) (fixRI ri) - ANDC reg1 reg2 reg3 -> ANDC (env reg1) (env reg2) (env reg3) - OR reg1 reg2 ri -> OR (env reg1) (env reg2) (fixRI ri) - ORIS reg1 reg2 imm -> ORIS (env reg1) (env reg2) imm - XOR reg1 reg2 ri -> XOR (env reg1) (env reg2) (fixRI ri) - XORIS reg1 reg2 imm -> XORIS (env reg1) (env reg2) imm - EXTS fmt reg1 reg2 -> EXTS fmt (env reg1) (env reg2) - CNTLZ fmt reg1 reg2 -> CNTLZ fmt (env reg1) (env reg2) - NEG reg1 reg2 -> NEG (env reg1) (env reg2) - NOT reg1 reg2 -> NOT (env reg1) (env reg2) - SL fmt reg1 reg2 ri - -> SL fmt (env reg1) (env reg2) (fixRI ri) - SR fmt reg1 reg2 ri - -> SR fmt (env reg1) (env reg2) (fixRI ri) - SRA fmt reg1 reg2 ri - -> SRA fmt (env reg1) (env reg2) (fixRI ri) - RLWINM reg1 reg2 sh mb me - -> RLWINM (env reg1) (env reg2) sh mb me - CLRLI fmt reg1 reg2 n -> CLRLI fmt (env reg1) (env reg2) n - CLRRI fmt reg1 reg2 n -> CLRRI fmt (env reg1) (env reg2) n - FADD fmt r1 r2 r3 -> FADD fmt (env r1) (env r2) (env r3) - FSUB fmt r1 r2 r3 -> FSUB fmt (env r1) (env r2) (env r3) - FMUL fmt r1 r2 r3 -> FMUL fmt (env r1) (env r2) (env r3) - FDIV fmt r1 r2 r3 -> FDIV fmt (env r1) (env r2) (env r3) - FABS r1 r2 -> FABS (env r1) (env r2) - FNEG r1 r2 -> FNEG (env r1) (env r2) - FCMP r1 r2 -> FCMP (env r1) (env r2) - FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2) - FCTIDZ r1 r2 -> FCTIDZ (env r1) (env r2) - FCFID r1 r2 -> FCFID (env r1) (env r2) - FRSP r1 r2 -> FRSP (env r1) (env r2) - MFCR reg -> MFCR (env reg) - MFLR reg -> MFLR (env reg) - FETCHPC reg -> FETCHPC (env reg) - _ -> instr - where - fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - - fixRI (RIReg r) = RIReg (env r) - fixRI other = other - - --------------------------------------------------------------------------------- --- | Checks whether this instruction is a jump/branch instruction. --- One that can change the flow of control in a way that the --- register allocator needs to worry about. -ppc_isJumpishInstr :: Instr -> Bool -ppc_isJumpishInstr instr - = case instr of - BCC{} -> True - BCCFAR{} -> True - BCTR{} -> True - BCTRL{} -> True - BL{} -> True - JMP{} -> True - _ -> False - - --- | Checks whether this instruction is a jump/branch instruction. --- One that can change the flow of control in a way that the --- register allocator needs to worry about. -ppc_jumpDestsOfInstr :: Instr -> [BlockId] -ppc_jumpDestsOfInstr insn - = case insn of - BCC _ id -> [id] - BCCFAR _ id -> [id] - BCTR targets _ -> [id | Just id <- targets] - _ -> [] - - --- | Change the destination of this jump instruction. --- Used in the linear allocator when adding fixup blocks for join --- points. -ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr -ppc_patchJumpInstr insn patchF - = case insn of - BCC cc id -> BCC cc (patchF id) - BCCFAR cc id -> BCCFAR cc (patchF id) - BCTR ids lbl -> BCTR (map (fmap patchF) ids) lbl - _ -> insn - - --- ----------------------------------------------------------------------------- - --- | An instruction to spill a register into a spill slot. -ppc_mkSpillInstr - :: DynFlags - -> Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr - -ppc_mkSpillInstr dflags reg delta slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot - arch = platformArch platform - in - let fmt = case targetClassOfReg platform reg of - RcInteger -> case arch of - ArchPPC -> II32 - _ -> II64 - RcDouble -> FF64 - _ -> panic "PPC.Instr.mkSpillInstr: no match" - instr = case makeImmediate W32 True (off-delta) of - Just _ -> ST - Nothing -> STFAR -- pseudo instruction: 32 bit offsets - - in instr fmt reg (AddrRegImm sp (ImmInt (off-delta))) - - -ppc_mkLoadInstr - :: DynFlags - -> Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr - -ppc_mkLoadInstr dflags reg delta slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot - arch = platformArch platform - in - let fmt = case targetClassOfReg platform reg of - RcInteger -> case arch of - ArchPPC -> II32 - _ -> II64 - RcDouble -> FF64 - _ -> panic "PPC.Instr.mkLoadInstr: no match" - instr = case makeImmediate W32 True (off-delta) of - Just _ -> LD - Nothing -> LDFAR -- pseudo instruction: 32 bit offsets - - in instr fmt reg (AddrRegImm sp (ImmInt (off-delta))) - - --- | The size of a minimal stackframe header including minimal --- parameter save area. -stackFrameHeaderSize :: DynFlags -> Int -stackFrameHeaderSize dflags - = case platformOS platform of - OSLinux -> case platformArch platform of - -- header + parameter save area - ArchPPC -> 64 -- TODO: check ABI spec - ArchPPC_64 ELF_V1 -> 48 + 8 * 8 - ArchPPC_64 ELF_V2 -> 32 + 8 * 8 - _ -> panic "PPC.stackFrameHeaderSize: Unknown Linux" - OSAIX -> 24 + 8 * 4 - OSDarwin -> 64 -- TODO: check ABI spec - _ -> panic "PPC.stackFrameHeaderSize: not defined for this OS" - where platform = targetPlatform dflags - --- | The maximum number of bytes required to spill a register. PPC32 --- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and --- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike --- x86. Note that AltiVec's vector registers are 128-bit wide so we --- must not use this to spill them. -spillSlotSize :: Int -spillSlotSize = 8 - --- | The number of spill slots available without allocating more. -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = ((rESERVED_C_STACK_BYTES dflags - stackFrameHeaderSize dflags) - `div` spillSlotSize) - 1 --- = 0 -- useful for testing allocMoreStack - --- | The number of bytes that the stack pointer should be aligned --- to. This is 16 both on PPC32 and PPC64 at least for Darwin, and --- Linux (see ELF processor specific supplements). -stackAlign :: Int -stackAlign = 16 - --- | Convert a spill slot number to a *byte* offset, with no sign. -spillSlotToOffset :: DynFlags -> Int -> Int -spillSlotToOffset dflags slot - = stackFrameHeaderSize dflags + spillSlotSize * slot - - --------------------------------------------------------------------------------- --- | See if this instruction is telling us the current C stack delta -ppc_takeDeltaInstr - :: Instr - -> Maybe Int - -ppc_takeDeltaInstr instr - = case instr of - DELTA i -> Just i - _ -> Nothing - - -ppc_isMetaInstr - :: Instr - -> Bool - -ppc_isMetaInstr instr - = case instr of - COMMENT{} -> True - LDATA{} -> True - NEWBLOCK{} -> True - DELTA{} -> True - _ -> False - - --- | Copy the value in a register to another one. --- Must work for all register classes. -ppc_mkRegRegMoveInstr - :: Reg - -> Reg - -> Instr - -ppc_mkRegRegMoveInstr src dst - = MR dst src - - --- | Make an unconditional jump instruction. --- For architectures with branch delay slots, its ok to put --- a NOP after the jump. Don't fill the delay slot with an --- instruction that references regs or you'll confuse the --- linear allocator. -ppc_mkJumpInstr - :: BlockId - -> [Instr] - -ppc_mkJumpInstr id - = [BCC ALWAYS id] - - --- | Take the source and destination from this reg -> reg move instruction --- or Nothing if it's not one -ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) -ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst) -ppc_takeRegRegMoveInstr _ = Nothing - --- ----------------------------------------------------------------------------- --- Making far branches - --- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too --- big, we have to work around this limitation. - -makeFarBranches - :: LabelMap CmmStatics - -> [NatBasicBlock Instr] - -> [NatBasicBlock Instr] -makeFarBranches info_env blocks - | last blockAddresses < nearLimit = blocks - | otherwise = zipWith handleBlock blockAddresses blocks - where - blockAddresses = scanl (+) 0 $ map blockLen blocks - blockLen (BasicBlock _ instrs) = length instrs - - handleBlock addr (BasicBlock id instrs) - = BasicBlock id (zipWith makeFar [addr..] instrs) - - makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt - makeFar addr (BCC cond tgt) - | abs (addr - targetAddr) >= nearLimit - = BCCFAR cond tgt - | otherwise - = BCC cond tgt - where Just targetAddr = lookupUFM blockAddressMap tgt - makeFar _ other = other - - -- 8192 instructions are allowed; let's keep some distance, as - -- we have a few pseudo-insns that are pretty-printed as - -- multiple instructions, and it's just not worth the effort - -- to calculate things exactly - nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW - - blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses diff --git a/nativeGen/PPC/Ppr.hs b/nativeGen/PPC/Ppr.hs deleted file mode 100644 --- a/nativeGen/PPC/Ppr.hs +++ /dev/null @@ -1,1041 +0,0 @@ ------------------------------------------------------------------------------ --- --- Pretty-printing assembly language --- --- (c) The University of Glasgow 1993-2005 --- ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module PPC.Ppr (pprNatCmmDecl) where - -import PPC.Regs -import PPC.Instr -import PPC.Cond -import PprBase -import Instruction -import Format -import Reg -import RegClass -import TargetReg - -import Cmm hiding (topInfoTable) -import Hoopl - -import CLabel - -import Unique ( pprUniqueAlways, Uniquable(..) ) -import Platform -import FastString -import Outputable -import DynFlags - -import Data.Word -import Data.Int -import Data.Bits - --- ----------------------------------------------------------------------------- --- Printing this stuff out - -pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc -pprNatCmmDecl (CmmData section dats) = - pprSectionAlign section $$ pprDatas dats - -pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - case topInfoTable proc of - Nothing -> - sdocWithPlatform $ \platform -> - case blocks of - [] -> -- special case for split markers: - pprLabel lbl - blocks -> -- special case for code without info table: - pprSectionAlign (Section Text lbl) $$ - (case platformArch platform of - ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl - ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl - _ -> pprLabel lbl) $$ -- blocks guaranteed not null, - -- so label needed - vcat (map (pprBasicBlock top_info) blocks) - - Just (Statics info_lbl _) -> - sdocWithPlatform $ \platform -> - pprSectionAlign (Section Text info_lbl) $$ - (if platformHasSubsectionsViaSymbols platform - then ppr (mkDeadStripPreventer info_lbl) <> char ':' - else empty) $$ - vcat (map (pprBasicBlock top_info) blocks) $$ - -- above: Even the first block gets a label, because with branch-chain - -- elimination, it might be the target of a goto. - (if platformHasSubsectionsViaSymbols platform - then - -- See Note [Subsections Via Symbols] in X86/Ppr.hs - text "\t.long " - <+> ppr info_lbl - <+> char '-' - <+> ppr (mkDeadStripPreventer info_lbl) - else empty) - -pprFunctionDescriptor :: CLabel -> SDoc -pprFunctionDescriptor lab = pprGloblDecl lab - $$ text ".section \".opd\",\"aw\"" - $$ text ".align 3" - $$ ppr lab <> char ':' - $$ text ".quad ." - <> ppr lab - <> text ",.TOC.@tocbase,0" - $$ text ".previous" - $$ text ".type " - <> ppr lab - <> text ", @function" - $$ char '.' - <> ppr lab - <> char ':' - -pprFunctionPrologue :: CLabel ->SDoc -pprFunctionPrologue lab = pprGloblDecl lab - $$ text ".type " - <> ppr lab - <> text ", @function" - $$ ppr lab <> char ':' - $$ text "0:\taddis\t" <> pprReg toc - <> text ",12,.TOC.-0b@ha" - $$ text "\taddi\t" <> pprReg toc - <> char ',' <> pprReg toc <> text ",.TOC.-0b@l" - $$ text "\t.localentry\t" <> ppr lab - <> text ",.-" <> ppr lab - -pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock info_env (BasicBlock blockid instrs) - = maybe_infotable $$ - pprLabel (mkAsmTempLabel (getUnique blockid)) $$ - vcat (map pprInstr instrs) - where - maybe_infotable = case mapLookup blockid info_env of - Nothing -> empty - Just (Statics info_lbl info) -> - pprAlignForSection Text $$ - vcat (map pprData info) $$ - pprLabel info_lbl - - - -pprDatas :: CmmStatics -> SDoc -pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) - -pprData :: CmmStatic -> SDoc -pprData (CmmString str) = pprASCII str -pprData (CmmUninitialised bytes) = keyword <> int bytes - where keyword = sdocWithPlatform $ \platform -> - case platformOS platform of - OSDarwin -> text ".space " - OSAIX -> text ".space " - _ -> text ".skip " -pprData (CmmStaticLit lit) = pprDataItem lit - -pprGloblDecl :: CLabel -> SDoc -pprGloblDecl lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> ppr lbl - -pprTypeAndSizeDecl :: CLabel -> SDoc -pprTypeAndSizeDecl lbl - = sdocWithPlatform $ \platform -> - if platformOS platform == OSLinux && externallyVisibleCLabel lbl - then text ".type " <> - ppr lbl <> text ", @object" - else empty - -pprLabel :: CLabel -> SDoc -pprLabel lbl = pprGloblDecl lbl - $$ pprTypeAndSizeDecl lbl - $$ (ppr lbl <> char ':') - - -pprASCII :: [Word8] -> SDoc -pprASCII str - = vcat (map do1 str) $$ do1 0 - where - do1 :: Word8 -> SDoc - do1 w = text "\t.byte\t" <> int (fromIntegral w) - - --- ----------------------------------------------------------------------------- --- pprInstr: print an 'Instr' - -instance Outputable Instr where - ppr instr = pprInstr instr - - -pprReg :: Reg -> SDoc - -pprReg r - = case r of - RegReal (RealRegSingle i) -> ppr_reg_no i - RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch" - RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u - RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u - RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u - RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u - RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUniqueAlways u - where - ppr_reg_no :: Int -> SDoc - ppr_reg_no i = - sdocWithPlatform $ \platform -> - case platformOS platform of - OSDarwin -> - ptext - (case i of { - 0 -> sLit "r0"; 1 -> sLit "r1"; - 2 -> sLit "r2"; 3 -> sLit "r3"; - 4 -> sLit "r4"; 5 -> sLit "r5"; - 6 -> sLit "r6"; 7 -> sLit "r7"; - 8 -> sLit "r8"; 9 -> sLit "r9"; - 10 -> sLit "r10"; 11 -> sLit "r11"; - 12 -> sLit "r12"; 13 -> sLit "r13"; - 14 -> sLit "r14"; 15 -> sLit "r15"; - 16 -> sLit "r16"; 17 -> sLit "r17"; - 18 -> sLit "r18"; 19 -> sLit "r19"; - 20 -> sLit "r20"; 21 -> sLit "r21"; - 22 -> sLit "r22"; 23 -> sLit "r23"; - 24 -> sLit "r24"; 25 -> sLit "r25"; - 26 -> sLit "r26"; 27 -> sLit "r27"; - 28 -> sLit "r28"; 29 -> sLit "r29"; - 30 -> sLit "r30"; 31 -> sLit "r31"; - 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 powerpc register" - }) - _ - | i <= 31 -> int i -- GPRs - | i <= 63 -> int (i-32) -- FPRs - | otherwise -> text "very naughty powerpc register" - - - -pprFormat :: Format -> SDoc -pprFormat x - = ptext (case x of - II8 -> sLit "b" - II16 -> sLit "h" - II32 -> sLit "w" - II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprFormat: no match") - - -pprCond :: Cond -> SDoc -pprCond c - = ptext (case c of { - ALWAYS -> sLit ""; - EQQ -> sLit "eq"; NE -> sLit "ne"; - LTT -> sLit "lt"; GE -> sLit "ge"; - GTT -> sLit "gt"; LE -> sLit "le"; - LU -> sLit "lt"; GEU -> sLit "ge"; - GU -> sLit "gt"; LEU -> sLit "le"; }) - - -pprImm :: Imm -> SDoc - -pprImm (ImmInt i) = int i -pprImm (ImmInteger i) = integer i -pprImm (ImmCLbl l) = ppr l -pprImm (ImmIndex l i) = ppr l <> char '+' <> int i -pprImm (ImmLit s) = s - -pprImm (ImmFloat _) = text "naughty float immediate" -pprImm (ImmDouble _) = text "naughty double immediate" - -pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b -pprImm (ImmConstantDiff a b) = pprImm a <> char '-' - <> lparen <> pprImm b <> rparen - -pprImm (LO (ImmInt i)) = pprImm (LO (ImmInteger (toInteger i))) -pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16)) - where - lo16 = fromInteger (i .&. 0xffff) :: Int16 - -pprImm (LO i) - = sdocWithPlatform $ \platform -> - if platformOS platform == OSDarwin - then hcat [ text "lo16(", pprImm i, rparen ] - else pprImm i <> text "@l" - -pprImm (HI i) - = sdocWithPlatform $ \platform -> - if platformOS platform == OSDarwin - then hcat [ text "hi16(", pprImm i, rparen ] - else pprImm i <> text "@h" - -pprImm (HA (ImmInt i)) = pprImm (HA (ImmInteger (toInteger i))) -pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16) - where - ha16 = if lo16 >= 0x8000 then hi16+1 else hi16 - hi16 = (i `shiftR` 16) - lo16 = i .&. 0xffff - -pprImm (HA i) - = sdocWithPlatform $ \platform -> - if platformOS platform == OSDarwin - then hcat [ text "ha16(", pprImm i, rparen ] - else pprImm i <> text "@ha" - -pprImm (HIGHERA i) - = sdocWithPlatform $ \platform -> - if platformOS platform == OSDarwin - then panic "PPC.pprImm: highera not implemented on Darwin" - else pprImm i <> text "@highera" - -pprImm (HIGHESTA i) - = sdocWithPlatform $ \platform -> - if platformOS platform == OSDarwin - then panic "PPC.pprImm: highesta not implemented on Darwin" - else pprImm i <> text "@highesta" - - -pprAddr :: AddrMode -> SDoc -pprAddr (AddrRegReg r1 r2) - = pprReg r1 <+> text ", " <+> pprReg r2 - -pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ] -pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ] -pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ] - - -pprSectionAlign :: Section -> SDoc -pprSectionAlign sec@(Section seg _) = - sdocWithPlatform $ \platform -> - pprSectionHeader platform sec $$ - pprAlignForSection seg - --- | Print appropriate alignment for the given section type. -pprAlignForSection :: SectionType -> SDoc -pprAlignForSection seg = - sdocWithPlatform $ \platform -> - let osDarwin = platformOS platform == OSDarwin - ppc64 = not $ target32Bit platform - in ptext $ case seg of - Text -> sLit ".align 2" - Data - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" - ReadOnlyData - | osDarwin -> sLit ".align 2" - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" - RelocatableReadOnlyData - | osDarwin -> sLit ".align 2" - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" - UninitialisedData - | osDarwin -> sLit ".align 2" - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" - ReadOnlyData16 - | osDarwin -> sLit ".align 4" - | otherwise -> sLit ".align 4" - -- TODO: This is copied from the ReadOnlyData case, but it can likely be - -- made more efficient. - CString - | osDarwin -> sLit ".align 2" - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" - OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section" - -pprDataItem :: CmmLit -> SDoc -pprDataItem lit - = sdocWithDynFlags $ \dflags -> - vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit dflags) - where - imm = litToImm lit - archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags - - ppr_item II8 _ _ = [text "\t.byte\t" <> pprImm imm] - - ppr_item II32 _ _ = [text "\t.long\t" <> pprImm imm] - - ppr_item II64 _ dflags - | archPPC_64 dflags = [text "\t.quad\t" <> pprImm imm] - - - ppr_item FF32 (CmmFloat r _) _ - = let bs = floatToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item FF64 (CmmFloat r _) _ - = let bs = doubleToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item II16 _ _ = [text "\t.short\t" <> pprImm imm] - - ppr_item II64 (CmmInt x _) dflags - | not(archPPC_64 dflags) = - [text "\t.long\t" - <> int (fromIntegral - (fromIntegral (x `shiftR` 32) :: Word32)), - text "\t.long\t" - <> int (fromIntegral (fromIntegral x :: Word32))] - - ppr_item _ _ _ - = panic "PPC.Ppr.pprDataItem: no match" - - -pprInstr :: Instr -> SDoc - -pprInstr (COMMENT _) = empty -- nuke 'em -{- -pprInstr (COMMENT s) = - if platformOS platform == OSLinux - then text "# " <> ftext s - else text "; " <> ftext s --} -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) - -pprInstr (NEWBLOCK _) - = panic "PprMach.pprInstr: NEWBLOCK" - -pprInstr (LDATA _ _) - = panic "PprMach.pprInstr: LDATA" - -{- -pprInstr (SPILL reg slot) - = hcat [ - text "\tSPILL", - char '\t', - pprReg reg, - comma, - text "SLOT" <> parens (int slot)] - -pprInstr (RELOAD slot reg) - = hcat [ - text "\tRELOAD", - char '\t', - text "SLOT" <> parens (int slot), - comma, - pprReg reg] --} - -pprInstr (LD fmt reg addr) = hcat [ - char '\t', - text "l", - ptext (case fmt of - II8 -> sLit "bz" - II16 -> sLit "hz" - II32 -> sLit "wz" - II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprInstr: no match" - ), - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', - char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] -pprInstr (LDFAR fmt reg (AddrRegImm source off)) = - sdocWithPlatform $ \platform -> vcat [ - pprInstr (ADDIS (tmpReg platform) source (HA off)), - pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off))) - ] - -pprInstr (LDFAR _ _ _) = - panic "PPC.Ppr.pprInstr LDFAR: no match" - -pprInstr (LA fmt reg addr) = hcat [ - char '\t', - text "l", - ptext (case fmt of - II8 -> sLit "ba" - II16 -> sLit "ha" - II32 -> sLit "wa" - II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprInstr: no match" - ), - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', - char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] -pprInstr (ST fmt reg addr) = hcat [ - char '\t', - text "st", - pprFormat fmt, - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', - char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] -pprInstr (STFAR fmt reg (AddrRegImm source off)) = - sdocWithPlatform $ \platform -> vcat [ - pprInstr (ADDIS (tmpReg platform) source (HA off)), - pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off))) - ] -pprInstr (STFAR _ _ _) = - panic "PPC.Ppr.pprInstr STFAR: no match" -pprInstr (STU fmt reg addr) = hcat [ - char '\t', - text "st", - pprFormat fmt, - char 'u', - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', - char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] -pprInstr (LIS reg imm) = hcat [ - char '\t', - text "lis", - char '\t', - pprReg reg, - text ", ", - pprImm imm - ] -pprInstr (LI reg imm) = hcat [ - char '\t', - text "li", - char '\t', - pprReg reg, - text ", ", - pprImm imm - ] -pprInstr (MR reg1 reg2) - | reg1 == reg2 = empty - | otherwise = hcat [ - char '\t', - sdocWithPlatform $ \platform -> - case targetClassOfReg platform reg1 of - RcInteger -> text "mr" - _ -> text "fmr", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2 - ] -pprInstr (CMP fmt reg ri) = hcat [ - char '\t', - op, - char '\t', - pprReg reg, - text ", ", - pprRI ri - ] - where - op = hcat [ - text "cmp", - pprFormat fmt, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i' - ] -pprInstr (CMPL fmt reg ri) = hcat [ - char '\t', - op, - char '\t', - pprReg reg, - text ", ", - pprRI ri - ] - where - op = hcat [ - text "cmpl", - pprFormat fmt, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i' - ] -pprInstr (BCC cond blockid) = hcat [ - char '\t', - text "b", - pprCond cond, - char '\t', - ppr lbl - ] - where lbl = mkAsmTempLabel (getUnique blockid) - -pprInstr (BCCFAR cond blockid) = vcat [ - hcat [ - text "\tb", - pprCond (condNegate cond), - text "\t$+8" - ], - hcat [ - text "\tb\t", - ppr lbl - ] - ] - where lbl = mkAsmTempLabel (getUnique blockid) - -pprInstr (JMP lbl) - -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL" - | isForeignLabel lbl = panic "PPC.Ppr.pprInstr: JMP to ForeignLabel" - | otherwise = - hcat [ -- an alias for b that takes a CLabel - char '\t', - text "b", - char '\t', - ppr lbl - ] - -pprInstr (MTCTR reg) = hcat [ - char '\t', - text "mtctr", - char '\t', - pprReg reg - ] -pprInstr (BCTR _ _) = hcat [ - char '\t', - text "bctr" - ] -pprInstr (BL lbl _) = do - sdocWithPlatform $ \platform -> case platformOS platform of - OSAIX -> - -- On AIX, "printf" denotes a function-descriptor (for use - -- by function pointers), whereas the actual entry-code - -- address is denoted by the dot-prefixed ".printf" label. - -- Moreover, the PPC NCG only ever emits a BL instruction - -- for calling C ABI functions. Most of the time these calls - -- originate from FFI imports and have a 'ForeignLabel', - -- but when profiling the codegen inserts calls via - -- 'emitRtsCallGen' which are 'CmmLabel's even though - -- they'd technically be more like 'ForeignLabel's. - hcat [ - text "\tbl\t.", - ppr lbl - ] - _ -> - hcat [ - text "\tbl\t", - ppr lbl - ] -pprInstr (BCTRL _) = hcat [ - char '\t', - text "bctrl" - ] -pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri -pprInstr (ADDIS reg1 reg2 imm) = hcat [ - char '\t', - text "addis", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] - -pprInstr (ADDO reg1 reg2 reg3) = pprLogic (sLit "addo") reg1 reg2 (RIReg reg3) -pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) -pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) -pprInstr (ADDZE reg1 reg2) = pprUnary (sLit "addze") reg1 reg2 -pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) -pprInstr (SUBFO reg1 reg2 reg3) = pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3) -pprInstr (SUBFC reg1 reg2 ri) = hcat [ - char '\t', - text "subf", - case ri of - RIReg _ -> empty - RIImm _ -> char 'i', - text "c\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprRI ri - ] -pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3) -pprInstr (MULL fmt reg1 reg2 ri) = pprMul fmt reg1 reg2 ri -pprInstr (MULLO fmt reg1 reg2 reg3) = hcat [ - char '\t', - text "mull", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - text "o\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprReg reg3 - ] -pprInstr (MFOV fmt reg) = vcat [ - hcat [ - char '\t', - text "mfxer", - char '\t', - pprReg reg - ], - hcat [ - char '\t', - text "extr", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - text "i\t", - pprReg reg, - text ", ", - pprReg reg, - text ", 1, ", - case fmt of - II32 -> text "1" - II64 -> text "33" - _ -> panic "PPC: illegal format" - ] - ] - -pprInstr (MULHU fmt reg1 reg2 reg3) = hcat [ - char '\t', - text "mulh", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - text "u\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprReg reg3 - ] - -pprInstr (DIV fmt sgn reg1 reg2 reg3) = pprDiv fmt sgn reg1 reg2 reg3 - - -- for some reason, "andi" doesn't exist. - -- we'll use "andi." instead. -pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ - char '\t', - text "andi.", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] -pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri -pprInstr (ANDC reg1 reg2 reg3) = pprLogic (sLit "andc") reg1 reg2 (RIReg reg3) - -pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri -pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri - -pprInstr (ORIS reg1 reg2 imm) = hcat [ - char '\t', - text "oris", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] - -pprInstr (XORIS reg1 reg2 imm) = hcat [ - char '\t', - text "xoris", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] - -pprInstr (EXTS fmt reg1 reg2) = hcat [ - char '\t', - text "exts", - pprFormat fmt, - char '\t', - pprReg reg1, - text ", ", - pprReg reg2 - ] -pprInstr (CNTLZ fmt reg1 reg2) = hcat [ - char '\t', - text "cntlz", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2 - ] - -pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 -pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 - -pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = - -- Handle the case where we are asked to shift a 32 bit register by - -- less than zero or more than 31 bits. We convert this into a clear - -- of the destination register. - -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900 - pprInstr (XOR reg1 reg2 (RIReg reg2)) - -pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = - -- As above for SR, but for left shifts. - -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870 - pprInstr (XOR reg1 reg2 (RIReg reg2)) - -pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 = - -- PT: I don't know what to do for negative shift amounts: - -- For now just panic. - -- - -- For shift amounts greater than 31 set all bit to the - -- value of the sign bit, this also what sraw does. - pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31))) - -pprInstr (SL fmt reg1 reg2 ri) = - let op = case fmt of - II32 -> "slw" - II64 -> "sld" - _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) - -pprInstr (SR fmt reg1 reg2 ri) = - let op = case fmt of - II32 -> "srw" - II64 -> "srd" - _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) - -pprInstr (SRA fmt reg1 reg2 ri) = - let op = case fmt of - II32 -> "sraw" - II64 -> "srad" - _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) - -pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ - text "\trlwinm\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - int sh, - text ", ", - int mb, - text ", ", - int me - ] - -pprInstr (CLRLI fmt reg1 reg2 n) = hcat [ - text "\tclrl", - pprFormat fmt, - text "i ", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - int n - ] -pprInstr (CLRRI fmt reg1 reg2 n) = hcat [ - text "\tclrr", - pprFormat fmt, - text "i ", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - int n - ] - -pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3 -pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3 -pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3 -pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3 -pprInstr (FABS reg1 reg2) = pprUnary (sLit "fabs") reg1 reg2 -pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 - -pprInstr (FCMP reg1 reg2) = hcat [ - char '\t', - text "fcmpu\t0, ", - -- Note: we're using fcmpu, not fcmpo - -- The difference is with fcmpo, compare with NaN is an invalid operation. - -- We don't handle invalid fp ops, so we don't care. - -- Morever, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for - -- better portability since some non-GNU assembler (such as - -- IBM's `as`) tend not to support the symbolic register name cr0. - -- This matches the syntax that GCC seems to emit for PPC targets. - pprReg reg1, - text ", ", - pprReg reg2 - ] - -pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 -pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2 -pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2 -pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 - -pprInstr (CRNOR dst src1 src2) = hcat [ - text "\tcrnor\t", - int dst, - text ", ", - int src1, - text ", ", - int src2 - ] - -pprInstr (MFCR reg) = hcat [ - char '\t', - text "mfcr", - char '\t', - pprReg reg - ] - -pprInstr (MFLR reg) = hcat [ - char '\t', - text "mflr", - char '\t', - pprReg reg - ] - -pprInstr (FETCHPC reg) = vcat [ - text "\tbcl\t20,31,1f", - hcat [ text "1:\tmflr\t", pprReg reg ] - ] - -pprInstr LWSYNC = text "\tlwsync" - -pprInstr NOP = text "\tnop" - -pprInstr (UPDATE_SP fmt amount@(ImmInt offset)) - | fits16Bits offset = vcat [ - pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))), - pprInstr (STU fmt r0 (AddrRegImm sp amount)) - ] - -pprInstr (UPDATE_SP fmt amount) - = sdocWithPlatform $ \platform -> - let tmp = tmpReg platform in - vcat [ - pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))), - pprInstr (ADDIS tmp sp (HA amount)), - pprInstr (ADD tmp tmp (RIImm (LO amount))), - pprInstr (STU fmt r0 (AddrRegReg sp tmp)) - ] - --- pprInstr _ = panic "pprInstr (ppc)" - - -pprLogic :: LitString -> Reg -> Reg -> RI -> SDoc -pprLogic op reg1 reg2 ri = hcat [ - char '\t', - ptext op, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i', - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprRI ri - ] - - -pprMul :: Format -> Reg -> Reg -> RI -> SDoc -pprMul fmt reg1 reg2 ri = hcat [ - char '\t', - text "mull", - case ri of - RIReg _ -> case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format" - RIImm _ -> char 'i', - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprRI ri - ] - - -pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc -pprDiv fmt sgn reg1 reg2 reg3 = hcat [ - char '\t', - text "div", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - if sgn then empty else char 'u', - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprReg reg3 - ] - - -pprUnary :: LitString -> Reg -> Reg -> SDoc -pprUnary op reg1 reg2 = hcat [ - char '\t', - ptext op, - char '\t', - pprReg reg1, - text ", ", - pprReg reg2 - ] - - -pprBinaryF :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc -pprBinaryF op fmt reg1 reg2 reg3 = hcat [ - char '\t', - ptext op, - pprFFormat fmt, - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprReg reg3 - ] - -pprRI :: RI -> SDoc -pprRI (RIReg r) = pprReg r -pprRI (RIImm r) = pprImm r - - -pprFFormat :: Format -> SDoc -pprFFormat FF64 = empty -pprFFormat FF32 = char 's' -pprFFormat _ = panic "PPC.Ppr.pprFFormat: no match" - - -- limit immediate argument for shift instruction to range 0..63 - -- for 64 bit size and 0..32 otherwise -limitShiftRI :: Format -> RI -> RI -limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 = - panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed." -limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 = - panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed." -limitShiftRI _ x = x diff --git a/nativeGen/PPC/RegInfo.hs b/nativeGen/PPC/RegInfo.hs deleted file mode 100644 --- a/nativeGen/PPC/RegInfo.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Machine-specific parts of the register allocator --- --- (c) The University of Glasgow 1996-2004 --- ------------------------------------------------------------------------------ -module PPC.RegInfo ( - JumpDest( DestBlockId ), getJumpDestBlockId, - canShortcut, - shortcutJump, - - shortcutStatics -) - -where - -#include "nativeGen/NCG.h" -#include "HsVersions.h" - -import PPC.Instr - -import BlockId -import Cmm -import CLabel - -import Unique - -data JumpDest = DestBlockId BlockId - -getJumpDestBlockId :: JumpDest -> Maybe BlockId -getJumpDestBlockId (DestBlockId bid) = Just bid - -canShortcut :: Instr -> Maybe JumpDest -canShortcut _ = Nothing - -shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr -shortcutJump _ other = other - - --- Here because it knows about JumpDest -shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics -shortcutStatics fn (Statics lbl statics) - = Statics lbl $ map (shortcutStatic fn) statics - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. - -shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel -shortcutLabel fn lab - | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) - | 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)) - = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) - -- 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 -> mkAsmTempLabel uq - Just (DestBlockId blockid') -> shortBlockId fn blockid' - where uq = getUnique blockid diff --git a/nativeGen/PPC/Regs.hs b/nativeGen/PPC/Regs.hs deleted file mode 100644 --- a/nativeGen/PPC/Regs.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# LANGUAGE CPP #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1994-2004 --- --- ----------------------------------------------------------------------------- - -module PPC.Regs ( - -- squeeze functions - virtualRegSqueeze, - realRegSqueeze, - - mkVirtualReg, - regDotColor, - - -- immediates - Imm(..), - strImmLit, - litToImm, - - -- addressing modes - AddrMode(..), - addrOffset, - - -- registers - spRel, - argRegs, - allArgRegs, - callClobberedRegs, - allMachRegNos, - classOfRealReg, - showReg, - - -- machine specific - allFPArgRegs, - fits16Bits, - makeImmediate, - fReg, - r0, sp, toc, r3, r4, r11, r12, r27, r28, r30, - tmpReg, - f1, f20, f21, - - allocatableRegs - -) - -where - -#include "nativeGen/NCG.h" -#include "HsVersions.h" - -import Reg -import RegClass -import Format - -import Cmm -import CLabel ( CLabel ) -import Unique - -import CodeGen.Platform -import DynFlags -import Outputable -import Platform - -import Data.Word ( Word8, Word16, Word32, Word64 ) -import Data.Int ( Int8, Int16, Int32, Int64 ) - - --- squeese functions for the graph allocator ----------------------------------- - --- | regSqueeze_class reg --- Calculuate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. --- -{-# INLINE virtualRegSqueeze #-} -virtualRegSqueeze :: RegClass -> VirtualReg -> Int -virtualRegSqueeze cls vr - = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> 1 - VirtualRegHi{} -> 1 - _other -> 0 - - RcDouble - -> case vr of - VirtualRegD{} -> 1 - VirtualRegF{} -> 0 - _other -> 0 - - _other -> 0 - -{-# INLINE realRegSqueeze #-} -realRegSqueeze :: RegClass -> RealReg -> Int -realRegSqueeze cls rr - = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 1 -- first fp reg is 32 - | otherwise -> 0 - - RealRegPair{} -> 0 - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 0 - | otherwise -> 1 - - RealRegPair{} -> 0 - - _other -> 0 - -mkVirtualReg :: Unique -> Format -> VirtualReg -mkVirtualReg u format - | not (isFloatFormat format) = VirtualRegI u - | otherwise - = case format of - FF32 -> VirtualRegD u - FF64 -> VirtualRegD u - _ -> panic "mkVirtualReg" - -regDotColor :: RealReg -> SDoc -regDotColor reg - = case classOfRealReg reg of - RcInteger -> text "blue" - RcFloat -> text "red" - RcDouble -> text "green" - RcDoubleSSE -> text "yellow" - - --- immediates ------------------------------------------------------------------ -data Imm - = ImmInt Int - | ImmInteger Integer -- Sigh. - | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit SDoc -- Simple string - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm - | LO Imm - | HI Imm - | HA Imm {- high halfword adjusted -} - | HIGHERA Imm - | HIGHESTA Imm - - -strImmLit :: String -> Imm -strImmLit s = ImmLit (text s) - - -litToImm :: CmmLit -> Imm -litToImm (CmmInt i w) = ImmInteger (narrowS w i) - -- narrow to the width: a CmmInt might be out of - -- range, but we assume that ImmInteger only contains - -- in-range values. A signed value should be fine here. -litToImm (CmmFloat f W32) = ImmFloat f -litToImm (CmmFloat f W64) = ImmDouble f -litToImm (CmmLabel l) = ImmCLbl l -litToImm (CmmLabelOff l off) = ImmIndex l off -litToImm (CmmLabelDiffOff l1 l2 off) - = ImmConstantSum - (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) - (ImmInt off) -litToImm _ = panic "PPC.Regs.litToImm: no match" - - --- addressing modes ------------------------------------------------------------ - -data AddrMode - = AddrRegReg Reg Reg - | AddrRegImm Reg Imm - - -addrOffset :: AddrMode -> Int -> Maybe AddrMode -addrOffset addr off - = case addr of - AddrRegImm r (ImmInt n) - | fits16Bits n2 -> Just (AddrRegImm r (ImmInt n2)) - | otherwise -> Nothing - where n2 = n + off - - AddrRegImm r (ImmInteger n) - | fits16Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) - | otherwise -> Nothing - where n2 = n + toInteger off - - _ -> Nothing - - --- registers ------------------------------------------------------------------- --- @spRel@ gives us a stack relative addressing mode for volatile --- temporaries and for excess call arguments. @fpRel@, where --- applicable, is the same but for the frame pointer. - -spRel :: DynFlags - -> Int -- desired stack offset in words, positive or negative - -> AddrMode - -spRel dflags n = AddrRegImm sp (ImmInt (n * wORD_SIZE dflags)) - - --- argRegs is the set of regs which are read for an n-argument call to C. --- For archs which pass all args on the stack (x86), is empty. --- Sparc passes up to the first 6 args in regs. -argRegs :: RegNo -> [Reg] -argRegs 0 = [] -argRegs 1 = map regSingle [3] -argRegs 2 = map regSingle [3,4] -argRegs 3 = map regSingle [3..5] -argRegs 4 = map regSingle [3..6] -argRegs 5 = map regSingle [3..7] -argRegs 6 = map regSingle [3..8] -argRegs 7 = map regSingle [3..9] -argRegs 8 = map regSingle [3..10] -argRegs _ = panic "MachRegs.argRegs(powerpc): don't know about >8 arguments!" - - -allArgRegs :: [Reg] -allArgRegs = map regSingle [3..10] - - --- these are the regs which we cannot assume stay alive over a C call. -callClobberedRegs :: Platform -> [Reg] -callClobberedRegs platform - = case platformOS platform of - OSAIX -> map regSingle (0:[2..12] ++ map fReg [0..13]) - OSDarwin -> map regSingle (0:[2..12] ++ map fReg [0..13]) - OSLinux -> map regSingle (0:[2..13] ++ map fReg [0..13]) - _ -> panic "PPC.Regs.callClobberedRegs: not defined for this architecture" - - -allMachRegNos :: [RegNo] -allMachRegNos = [0..63] - - -{-# INLINE classOfRealReg #-} -classOfRealReg :: RealReg -> RegClass -classOfRealReg (RealRegSingle i) - | i < 32 = RcInteger - | otherwise = RcDouble - -classOfRealReg (RealRegPair{}) - = panic "regClass(ppr): no reg pairs on this architecture" - -showReg :: RegNo -> String -showReg n - | n >= 0 && n <= 31 = "%r" ++ show n - | n >= 32 && n <= 63 = "%f" ++ show (n - 32) - | otherwise = "%unknown_powerpc_real_reg_" ++ show n - - - --- machine specific ------------------------------------------------------------ - -allFPArgRegs :: Platform -> [Reg] -allFPArgRegs platform - = case platformOS platform of - OSAIX -> map (regSingle . fReg) [1..13] - OSDarwin -> map (regSingle . fReg) [1..13] - OSLinux -> case platformArch platform of - ArchPPC -> map (regSingle . fReg) [1..8] - ArchPPC_64 _ -> map (regSingle . fReg) [1..13] - _ -> panic "PPC.Regs.allFPArgRegs: unknown PPC Linux" - _ -> panic "PPC.Regs.allFPArgRegs: not defined for this architecture" - -fits16Bits :: Integral a => a -> Bool -fits16Bits x = x >= -32768 && x < 32768 - -makeImmediate :: Integral a => Width -> Bool -> a -> Maybe Imm -makeImmediate rep signed x = fmap ImmInt (toI16 rep signed) - where - narrow W64 False = fromIntegral (fromIntegral x :: Word64) - narrow W32 False = fromIntegral (fromIntegral x :: Word32) - narrow W16 False = fromIntegral (fromIntegral x :: Word16) - narrow W8 False = fromIntegral (fromIntegral x :: Word8) - narrow W64 True = fromIntegral (fromIntegral x :: Int64) - narrow W32 True = fromIntegral (fromIntegral x :: Int32) - narrow W16 True = fromIntegral (fromIntegral x :: Int16) - narrow W8 True = fromIntegral (fromIntegral x :: Int8) - narrow _ _ = panic "PPC.Regs.narrow: no match" - - narrowed = narrow rep signed - - toI16 W32 True - | narrowed >= -32768 && narrowed < 32768 = Just narrowed - | otherwise = Nothing - toI16 W32 False - | narrowed >= 0 && narrowed < 65536 = Just narrowed - | otherwise = Nothing - toI16 W64 True - | narrowed >= -32768 && narrowed < 32768 = Just narrowed - | otherwise = Nothing - toI16 W64 False - | narrowed >= 0 && narrowed < 65536 = Just narrowed - | otherwise = Nothing - toI16 _ _ = Just narrowed - - -{- -The PowerPC has 64 registers of interest; 32 integer registers and 32 floating -point registers. --} - -fReg :: Int -> RegNo -fReg x = (32 + x) - -r0, sp, toc, r3, r4, r11, r12, r27, r28, r30, f1, f20, f21 :: Reg -r0 = regSingle 0 -sp = regSingle 1 -toc = regSingle 2 -r3 = regSingle 3 -r4 = regSingle 4 -r11 = regSingle 11 -r12 = regSingle 12 -r27 = regSingle 27 -r28 = regSingle 28 -r30 = regSingle 30 -f1 = regSingle $ fReg 1 -f20 = regSingle $ fReg 20 -f21 = regSingle $ fReg 21 - --- allocatableRegs is allMachRegNos with the fixed-use regs removed. --- i.e., these are the regs for which we are prepared to allow the --- register allocator to attempt to map VRegs to. -allocatableRegs :: Platform -> [RealReg] -allocatableRegs platform - = let isFree i = freeReg platform i - in map RealRegSingle $ filter isFree allMachRegNos - --- temporary register for compiler use -tmpReg :: Platform -> Reg -tmpReg platform = - case platformArch platform of - ArchPPC -> regSingle 13 - ArchPPC_64 _ -> regSingle 30 - _ -> panic "PPC.Regs.tmpReg: unknowm arch" diff --git a/nativeGen/PprBase.hs b/nativeGen/PprBase.hs deleted file mode 100644 --- a/nativeGen/PprBase.hs +++ /dev/null @@ -1,153 +0,0 @@ ------------------------------------------------------------------------------ --- --- Pretty-printing assembly language --- --- (c) The University of Glasgow 1993-2005 --- ------------------------------------------------------------------------------ - -module PprBase ( - castFloatToWord8Array, - castDoubleToWord8Array, - floatToBytes, - doubleToBytes, - pprSectionHeader -) - -where - -import CLabel -import Cmm -import DynFlags -import FastString -import Outputable -import Platform - -import qualified Data.Array.Unsafe as U ( castSTUArray ) -import Data.Array.ST - -import Control.Monad.ST - -import Data.Word - - - --- ----------------------------------------------------------------------------- --- Converting floating-point literals to integrals for printing - -castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8) -castFloatToWord8Array = U.castSTUArray - -castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8) -castDoubleToWord8Array = U.castSTUArray - --- floatToBytes and doubleToBytes convert to the host's byte --- order. Providing that we're not cross-compiling for a --- target with the opposite endianness, this should work ok --- on all targets. - --- ToDo: this stuff is very similar to the shenanigans in PprAbs, --- could they be merged? - -floatToBytes :: Float -> [Int] -floatToBytes f - = runST (do - arr <- newArray_ ((0::Int),3) - writeArray arr 0 f - arr <- castFloatToWord8Array arr - i0 <- readArray arr 0 - i1 <- readArray arr 1 - i2 <- readArray arr 2 - i3 <- readArray arr 3 - return (map fromIntegral [i0,i1,i2,i3]) - ) - -doubleToBytes :: Double -> [Int] -doubleToBytes d - = runST (do - arr <- newArray_ ((0::Int),7) - writeArray arr 0 d - arr <- castDoubleToWord8Array arr - i0 <- readArray arr 0 - i1 <- readArray arr 1 - i2 <- readArray arr 2 - i3 <- readArray arr 3 - i4 <- readArray arr 4 - i5 <- readArray arr 5 - i6 <- readArray arr 6 - i7 <- readArray arr 7 - return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7]) - ) - --- ---------------------------------------------------------------------------- --- Printing section headers. --- --- If -split-section was specified, include the suffix label, otherwise just --- print the section type. For Darwin, where subsections-for-symbols are --- used instead, only print section type. --- --- For string literals, additional flags are specified to enable merging of --- identical strings in the linker. With -split-sections each string also gets --- a unique section to allow strings from unused code to be GC'd. - -pprSectionHeader :: Platform -> Section -> SDoc -pprSectionHeader platform (Section t suffix) = - case platformOS platform of - OSAIX -> pprXcoffSectionHeader t - OSDarwin -> pprDarwinSectionHeader t - _ -> pprGNUSectionHeader t suffix - -pprGNUSectionHeader :: SectionType -> CLabel -> SDoc -pprGNUSectionHeader t suffix = sdocWithDynFlags $ \dflags -> - let splitSections = gopt Opt_SplitSections dflags - subsection | splitSections = char '.' <> ppr suffix - | otherwise = empty - in text ".section " <> ptext (header dflags) <> subsection <> - flags dflags - where - header dflags = case t of - Text -> sLit ".text" - Data -> sLit ".data" - ReadOnlyData -> sLit ".rodata" - RelocatableReadOnlyData -> sLit ".data.rel.ro" - UninitialisedData -> sLit ".bss" - ReadOnlyData16 -> sLit ".rodata.cst16" - CString - | OSMinGW32 <- platformOS (targetPlatform dflags) - -> sLit ".rdata" - | otherwise -> sLit ".rodata.str" - OtherSection _ -> - panic "PprBase.pprGNUSectionHeader: unknown section type" - flags dflags = case t of - CString - | OSMinGW32 <- platformOS (targetPlatform dflags) - -> text ",\"dr\"" - | otherwise -> text ",\"aMS\",@progbits,1" - _ -> empty - --- XCOFF doesn't support relocating label-differences, so we place all --- RO sections into .text[PR] sections -pprXcoffSectionHeader :: SectionType -> SDoc -pprXcoffSectionHeader t = text $ case t of - Text -> ".csect .text[PR]" - Data -> ".csect .data[RW]" - ReadOnlyData -> ".csect .text[PR] # ReadOnlyData" - RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData" - ReadOnlyData16 -> ".csect .text[PR] # ReadOnlyData16" - CString -> ".csect .text[PR] # CString" - UninitialisedData -> ".csect .data[BS]" - OtherSection _ -> - panic "PprBase.pprXcoffSectionHeader: unknown section type" - -pprDarwinSectionHeader :: SectionType -> SDoc -pprDarwinSectionHeader t = - ptext $ case t of - Text -> sLit ".text" - Data -> sLit ".data" - ReadOnlyData -> sLit ".const" - RelocatableReadOnlyData -> sLit ".const_data" - UninitialisedData -> sLit ".data" - ReadOnlyData16 -> sLit ".const" - CString -> sLit ".section\t__TEXT,__cstring,cstring_literals" - OtherSection _ -> - panic "PprBase.pprDarwinSectionHeader: unknown section type" diff --git a/nativeGen/Reg.hs b/nativeGen/Reg.hs deleted file mode 100644 --- a/nativeGen/Reg.hs +++ /dev/null @@ -1,239 +0,0 @@ --- | An architecture independent description of a register. --- This needs to stay architecture independent because it is used --- by NCGMonad and the register allocators, which are shared --- by all architectures. --- -module Reg ( - RegNo, - Reg(..), - regPair, - regSingle, - isRealReg, takeRealReg, - isVirtualReg, takeVirtualReg, - - VirtualReg(..), - renameVirtualReg, - classOfVirtualReg, - getHiVirtualRegFromLo, - getHiVRegFromLo, - - RealReg(..), - regNosOfRealReg, - realRegsAlias, - - liftPatchFnToRegReg -) - -where - -import Outputable -import Unique -import RegClass -import Data.List - --- | An identifier for a primitive real machine register. -type RegNo - = Int - --- VirtualRegs are virtual registers. The register allocator will --- eventually have to map them into RealRegs, or into spill slots. --- --- VirtualRegs are allocated on the fly, usually to represent a single --- value in the abstract assembly code (i.e. dynamic registers are --- usually single assignment). --- --- The single assignment restriction isn't necessary to get correct code, --- although a better register allocation will result if single --- assignment is used -- because the allocator maps a VirtualReg into --- a single RealReg, even if the VirtualReg has multiple live ranges. --- --- Virtual regs can be of either class, so that info is attached. --- -data VirtualReg - = VirtualRegI {-# UNPACK #-} !Unique - | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register - | VirtualRegF {-# UNPACK #-} !Unique - | VirtualRegD {-# UNPACK #-} !Unique - | VirtualRegSSE {-# UNPACK #-} !Unique - deriving (Eq, Show) - --- This is laborious, but necessary. We can't derive Ord because --- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the --- implementation. See Note [No Ord for Unique] --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] -instance Ord VirtualReg where - compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b - compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b - compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b - compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b - compare (VirtualRegSSE a) (VirtualRegSSE b) = nonDetCmpUnique a b - compare VirtualRegI{} _ = LT - compare _ VirtualRegI{} = GT - compare VirtualRegHi{} _ = LT - compare _ VirtualRegHi{} = GT - compare VirtualRegF{} _ = LT - compare _ VirtualRegF{} = GT - compare VirtualRegD{} _ = LT - compare _ VirtualRegD{} = GT - - -instance Uniquable VirtualReg where - getUnique reg - = case reg of - VirtualRegI u -> u - VirtualRegHi u -> u - VirtualRegF u -> u - VirtualRegD u -> u - VirtualRegSSE u -> u - -instance Outputable VirtualReg where - ppr reg - = case reg of - VirtualRegI u -> text "%vI_" <> pprUniqueAlways u - VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u - VirtualRegF u -> text "%vF_" <> pprUniqueAlways u - VirtualRegD u -> text "%vD_" <> pprUniqueAlways u - VirtualRegSSE u -> text "%vSSE_" <> pprUniqueAlways u - - -renameVirtualReg :: Unique -> VirtualReg -> VirtualReg -renameVirtualReg u r - = case r of - VirtualRegI _ -> VirtualRegI u - VirtualRegHi _ -> VirtualRegHi u - VirtualRegF _ -> VirtualRegF u - VirtualRegD _ -> VirtualRegD u - VirtualRegSSE _ -> VirtualRegSSE u - - -classOfVirtualReg :: VirtualReg -> RegClass -classOfVirtualReg vr - = case vr of - VirtualRegI{} -> RcInteger - VirtualRegHi{} -> RcInteger - VirtualRegF{} -> RcFloat - VirtualRegD{} -> RcDouble - VirtualRegSSE{} -> RcDoubleSSE - - --- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform --- when supplied with the vreg for the lower-half of the quantity. --- (NB. Not reversible). -getHiVirtualRegFromLo :: VirtualReg -> VirtualReg -getHiVirtualRegFromLo reg - = case reg of - -- makes a pseudo-unique with tag 'H' - VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') - _ -> panic "Reg.getHiVirtualRegFromLo" - -getHiVRegFromLo :: Reg -> Reg -getHiVRegFromLo reg - = case reg of - RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) - RegReal _ -> panic "Reg.getHiVRegFromLo" - - ------------------------------------------------------------------------------------- --- | RealRegs are machine regs which are available for allocation, in --- the usual way. We know what class they are, because that's part of --- the processor's architecture. --- --- RealRegPairs are pairs of real registers that are allocated together --- to hold a larger value, such as with Double regs on SPARC. --- -data RealReg - = RealRegSingle {-# UNPACK #-} !RegNo - | RealRegPair {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo - deriving (Eq, Show, Ord) - -instance Uniquable RealReg where - getUnique reg - = case reg of - RealRegSingle i -> mkRegSingleUnique i - RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) - -instance Outputable RealReg where - ppr reg - = case reg of - RealRegSingle i -> text "%r" <> int i - RealRegPair r1 r2 -> text "%r(" <> int r1 - <> vbar <> int r2 <> text ")" - -regNosOfRealReg :: RealReg -> [RegNo] -regNosOfRealReg rr - = case rr of - RealRegSingle r1 -> [r1] - RealRegPair r1 r2 -> [r1, r2] - - -realRegsAlias :: RealReg -> RealReg -> Bool -realRegsAlias rr1 rr2 - = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2) - --------------------------------------------------------------------------------- --- | A register, either virtual or real -data Reg - = RegVirtual !VirtualReg - | RegReal !RealReg - deriving (Eq, Ord) - -regSingle :: RegNo -> Reg -regSingle regNo = RegReal $ RealRegSingle regNo - -regPair :: RegNo -> RegNo -> Reg -regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2 - - --- We like to have Uniques for Reg so that we can make UniqFM and UniqSets --- in the register allocator. -instance Uniquable Reg where - getUnique reg - = case reg of - RegVirtual vr -> getUnique vr - RegReal rr -> getUnique rr - --- | Print a reg in a generic manner --- If you want the architecture specific names, then use the pprReg --- function from the appropriate Ppr module. -instance Outputable Reg where - ppr reg - = case reg of - RegVirtual vr -> ppr vr - RegReal rr -> ppr rr - - -isRealReg :: Reg -> Bool -isRealReg reg - = case reg of - RegReal _ -> True - RegVirtual _ -> False - -takeRealReg :: Reg -> Maybe RealReg -takeRealReg reg - = case reg of - RegReal rr -> Just rr - _ -> Nothing - - -isVirtualReg :: Reg -> Bool -isVirtualReg reg - = case reg of - RegReal _ -> False - RegVirtual _ -> True - -takeVirtualReg :: Reg -> Maybe VirtualReg -takeVirtualReg reg - = case reg of - RegReal _ -> Nothing - RegVirtual vr -> Just vr - - --- | The patch function supplied by the allocator maps VirtualReg to RealReg --- regs, but sometimes we want to apply it to plain old Reg. --- -liftPatchFnToRegReg :: (VirtualReg -> RealReg) -> (Reg -> Reg) -liftPatchFnToRegReg patchF reg - = case reg of - RegVirtual vr -> RegReal (patchF vr) - RegReal _ -> reg diff --git a/nativeGen/RegAlloc/Graph/ArchBase.hs b/nativeGen/RegAlloc/Graph/ArchBase.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/ArchBase.hs +++ /dev/null @@ -1,159 +0,0 @@ - --- | Utils for calculating general worst, bound, squeese and free, functions. --- --- as per: "A Generalized Algorithm for Graph-Coloring Register Allocation" --- Michael Smith, Normal Ramsey, Glenn Holloway. --- PLDI 2004 --- --- These general versions are not used in GHC proper because they are too slow. --- Instead, hand written optimised versions are provided for each architecture --- in MachRegs*.hs --- --- This code is here because we can test the architecture specific code against --- it. --- -module RegAlloc.Graph.ArchBase ( - RegClass(..), - Reg(..), - RegSub(..), - - worst, - bound, - squeese -) where -import UniqSet -import UniqFM -import Unique - - --- Some basic register classes. --- These aren't nessesarally in 1-to-1 correspondance with the allocatable --- RegClasses in MachRegs.hs -data RegClass - -- general purpose regs - = ClassG32 -- 32 bit GPRs - | ClassG16 -- 16 bit GPRs - | ClassG8 -- 8 bit GPRs - - -- floating point regs - | ClassF64 -- 64 bit FPRs - deriving (Show, Eq, Enum) - - --- | A register of some class -data Reg - -- a register of some class - = Reg RegClass Int - - -- a sub-component of one of the other regs - | RegSub RegSub Reg - deriving (Show, Eq) - - --- | so we can put regs in UniqSets -instance Uniquable Reg where - getUnique (Reg c i) - = mkRegSingleUnique - $ fromEnum c * 1000 + i - - getUnique (RegSub s (Reg c i)) - = mkRegSubUnique - $ fromEnum s * 10000 + fromEnum c * 1000 + i - - getUnique (RegSub _ (RegSub _ _)) - = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg." - - --- | A subcomponent of another register -data RegSub - = SubL16 -- lowest 16 bits - | SubL8 -- lowest 8 bits - | SubL8H -- second lowest 8 bits - deriving (Show, Enum, Ord, Eq) - - --- | Worst case displacement --- --- a node N of classN has some number of neighbors, --- all of which are from classC. --- --- (worst neighbors classN classC) is the maximum number of potential --- colors for N that can be lost by coloring its neighbors. --- --- This should be hand coded/cached for each particular architecture, --- because the compute time is very long.. -worst :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> Int -> RegClass -> RegClass -> Int - -worst regsOfClass regAlias neighbors classN classC - = let regAliasS regs = unionManyUniqSets - $ map regAlias - $ nonDetEltsUniqSet regs - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - -- all the regs in classes N, C - regsN = regsOfClass classN - regsC = regsOfClass classC - - -- all the possible subsets of c which have size < m - regsS = filter (\s -> sizeUniqSet s >= 1 - && sizeUniqSet s <= neighbors) - $ powersetLS regsC - - -- for each of the subsets of C, the regs which conflict - -- with posiblities for N - regsS_conflict - = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS - - in maximum $ map sizeUniqSet $ regsS_conflict - - --- | For a node N of classN and neighbors of classesC --- (bound classN classesC) is the maximum number of potential --- colors for N that can be lost by coloring its neighbors. -bound :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> RegClass -> [RegClass] -> Int - -bound regsOfClass regAlias classN classesC - = let regAliasS regs = unionManyUniqSets - $ map regAlias - $ nonDetEltsUFM regs - -- See Note [Unique Determinism and code generation] - - regsC_aliases - = unionManyUniqSets - $ map (regAliasS . getUniqSet . regsOfClass) classesC - - overlap = intersectUniqSets (regsOfClass classN) regsC_aliases - - in sizeUniqSet overlap - - --- | The total squeese on a particular node with a list of neighbors. --- --- A version of this should be constructed for each particular architecture, --- possibly including uses of bound, so that alised registers don't get --- counted twice, as per the paper. -squeese :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> RegClass -> [(Int, RegClass)] -> Int - -squeese regsOfClass regAlias classN countCs - = sum - $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC) - $ countCs - - --- | powerset (for lists) -powersetL :: [a] -> [[a]] -powersetL = map concat . mapM (\x -> [[],[x]]) - - --- | powersetLS (list of sets) -powersetLS :: Uniquable a => UniqSet a -> [UniqSet a] -powersetLS s = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s - -- See Note [Unique Determinism and code generation] diff --git a/nativeGen/RegAlloc/Graph/ArchX86.hs b/nativeGen/RegAlloc/Graph/ArchX86.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/ArchX86.hs +++ /dev/null @@ -1,146 +0,0 @@ - --- | A description of the register set of the X86. --- --- This isn't used directly in GHC proper. --- --- See RegArchBase.hs for the reference. --- See MachRegs.hs for the actual trivColorable function used in GHC. --- -module RegAlloc.Graph.ArchX86 ( - classOfReg, - regsOfClass, - regName, - regAlias, - worst, - squeese, -) where -import RegAlloc.Graph.ArchBase (Reg(..), RegSub(..), RegClass(..)) -import UniqSet - - --- | 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-> Just $ [ "eax", "ebx", "ecx", "edx" - , "ebp", "esi", "edi", "esp" ] !! i - - RegSub SubL16 (Reg ClassG32 i) - | i <= 7 -> Just $ [ "ax", "bx", "cx", "dx" - , "bp", "si", "di", "sp"] !! i - - RegSub SubL8 (Reg ClassG32 i) - | i <= 3 -> Just $ [ "al", "bl", "cl", "dl"] !! i - - RegSub SubL8H (Reg ClassG32 i) - | i <= 3 -> Just $ [ "ah", "bh", "ch", "dh"] !! i - - _ -> Nothing - - --- | Which regs alias what other regs. -regAlias :: Reg -> UniqSet Reg -regAlias reg - = case reg of - - -- 32 bit regs alias all of the subregs - Reg ClassG32 i - - -- for eax, ebx, ecx, eds - | i <= 3 - -> mkUniqSet - $ [ Reg ClassG32 i, RegSub SubL16 reg - , RegSub SubL8 reg, RegSub SubL8H reg ] - - -- for esi, edi, esp, ebp - | 4 <= i && i <= 7 - -> mkUniqSet - $ [ Reg ClassG32 i, RegSub SubL16 reg ] - - -- 16 bit subregs alias the whole reg - RegSub SubL16 r@(Reg ClassG32 _) - -> regAlias r - - -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg - RegSub SubL8 r@(Reg ClassG32 _) - -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ] - - RegSub SubL8H r@(Reg ClassG32 _) - -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ] - - -- fp - Reg ClassF64 _ - -> unitUniqSet reg - - _ -> error "regAlias: invalid register" - - --- | Optimised versions of RegColorBase.{worst, squeese} specific to x86 -worst :: Int -> RegClass -> RegClass -> Int -worst n classN classC - = case classN of - ClassG32 - -> case classC of - ClassG32 -> min n 8 - ClassG16 -> min n 8 - ClassG8 -> min n 4 - ClassF64 -> 0 - - ClassG16 - -> case classC of - ClassG32 -> min n 8 - ClassG16 -> min n 8 - ClassG8 -> min n 4 - ClassF64 -> 0 - - ClassG8 - -> case classC of - ClassG32 -> min (n*2) 8 - ClassG16 -> min (n*2) 8 - ClassG8 -> min n 8 - ClassF64 -> 0 - - ClassF64 - -> case classC of - ClassF64 -> min n 6 - _ -> 0 - -squeese :: RegClass -> [(Int, RegClass)] -> Int -squeese classN countCs - = sum (map (\(i, classC) -> worst i classN classC) countCs) - diff --git a/nativeGen/RegAlloc/Graph/Coalesce.hs b/nativeGen/RegAlloc/Graph/Coalesce.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/Coalesce.hs +++ /dev/null @@ -1,99 +0,0 @@ --- | Register coalescing. -module RegAlloc.Graph.Coalesce ( - regCoalesce, - slurpJoinMovs -) where -import RegAlloc.Liveness -import Instruction -import Reg - -import Cmm -import Bag -import Digraph -import UniqFM -import UniqSet -import UniqSupply - -import Data.List - - --- | Do register coalescing on this top level thing --- --- For Reg -> Reg moves, if the first reg dies at the same time the --- second reg is born then the mov only serves to join live ranges. --- The two regs can be renamed to be the same and the move instruction --- safely erased. -regCoalesce - :: Instruction instr - => [LiveCmmDecl statics instr] - -> UniqSM [LiveCmmDecl statics instr] - -regCoalesce code - = do - let joins = foldl' unionBags emptyBag - $ map slurpJoinMovs code - - let alloc = foldl' buildAlloc emptyUFM - $ bagToList joins - - let patched = map (patchEraseLive (sinkReg alloc)) code - - return patched - - --- | Add a v1 = v2 register renaming to the map. --- The register with the lowest lexical name is set as the --- canonical version. -buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg -buildAlloc fm (r1, r2) - = let rmin = min r1 r2 - rmax = max r1 r2 - in addToUFM fm rmax rmin - - --- | Determine the canonical name for a register by following --- v1 = v2 renamings in this map. -sinkReg :: UniqFM Reg -> Reg -> Reg -sinkReg fm r - = case lookupUFM fm r of - Nothing -> r - Just r' -> sinkReg fm r' - - --- | Slurp out mov instructions that only serve to join live ranges. --- --- During a mov, if the source reg dies and the destiation reg is --- born then we can rename the two regs to the same thing and --- eliminate the move. -slurpJoinMovs - :: Instruction instr - => LiveCmmDecl statics instr - -> Bag (Reg, Reg) - -slurpJoinMovs live - = slurpCmm emptyBag live - where - slurpCmm rs CmmData{} - = rs - - slurpCmm rs (CmmProc _ _ _ sccs) - = foldl' slurpBlock rs (flattenSCCs sccs) - - slurpBlock rs (BasicBlock _ instrs) - = foldl' slurpLI rs instrs - - slurpLI rs (LiveInstr _ Nothing) = rs - slurpLI rs (LiveInstr instr (Just live)) - | Just (r1, r2) <- takeRegRegMoveInstr instr - , elementOfUniqSet r1 $ liveDieRead live - , elementOfUniqSet r2 $ liveBorn live - - -- only coalesce movs between two virtuals for now, - -- else we end up with allocatable regs in the live - -- regs list.. - , isVirtualReg r1 && isVirtualReg r2 - = consBag (r1, r2) rs - - | otherwise - = rs - diff --git a/nativeGen/RegAlloc/Graph/Main.hs b/nativeGen/RegAlloc/Graph/Main.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/Main.hs +++ /dev/null @@ -1,453 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | Graph coloring register allocator. -module RegAlloc.Graph.Main ( - regAlloc -) where -import qualified GraphColor as Color -import RegAlloc.Liveness -import RegAlloc.Graph.Spill -import RegAlloc.Graph.SpillClean -import RegAlloc.Graph.SpillCost -import RegAlloc.Graph.Stats -import RegAlloc.Graph.TrivColorable -import Instruction -import TargetReg -import RegClass -import Reg - -import Bag -import DynFlags -import Outputable -import Platform -import UniqFM -import UniqSet -import UniqSupply -import Util (seqList) - -import Data.List -import Data.Maybe -import Control.Monad - - --- | The maximum number of build\/spill cycles we'll allow. --- --- It should only take 3 or 4 cycles for the allocator to converge. --- If it takes any longer than this it's probably in an infinite loop, --- so it's better just to bail out and report a bug. -maxSpinCount :: Int -maxSpinCount = 10 - - --- | The top level of the graph coloring register allocator. -regAlloc - :: (Outputable statics, Outputable instr, Instruction instr) - => DynFlags - -> UniqFM (UniqSet RealReg) -- ^ registers we can use for allocation - -> UniqSet Int -- ^ set of available spill slots. - -> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information. - -> UniqSM ( [NatCmmDecl statics instr], [RegAllocStats statics instr] ) - -- ^ code with registers allocated and stats for each stage of - -- allocation - -regAlloc dflags regsFree slotsFree code - = do - -- TODO: the regClass function is currently hard coded to the default - -- target architecture. Would prefer to determine this from dflags. - -- There are other uses of targetRegClass later in this module. - let platform = targetPlatform dflags - triv = trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform) - - (code_final, debug_codeGraphs, _) - <- regAlloc_spin dflags 0 - triv - regsFree slotsFree [] code - - return ( code_final - , reverse debug_codeGraphs ) - - --- | Perform solver iterations for the graph coloring allocator. --- --- We extract a register confict graph from the provided cmm code, --- and try to colour it. If that works then we use the solution rewrite --- the code with real hregs. If coloring doesn't work we add spill code --- and try to colour it again. After `maxSpinCount` iterations we give up. --- -regAlloc_spin - :: (Instruction instr, - Outputable instr, - Outputable statics) - => DynFlags - -> Int -- ^ Number of solver iterations we've already performed. - -> Color.Triv VirtualReg RegClass RealReg - -- ^ Function for calculating whether a register is trivially - -- colourable. - -> UniqFM (UniqSet RealReg) -- ^ Free registers that we can allocate. - -> UniqSet Int -- ^ Free stack slots that we can use. - -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to. - -> [LiveCmmDecl statics instr] -- ^ Liveness annotated code to allocate. - -> UniqSM ( [NatCmmDecl statics instr] - , [RegAllocStats statics instr] - , Color.Graph VirtualReg RegClass RealReg) - -regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code - = do - let platform = targetPlatform dflags - - -- If any of these dump flags are turned on we want to hang on to - -- intermediate structures in the allocator - otherwise tell the - -- allocator to ditch them early so we don't end up creating space leaks. - let dump = or - [ dopt Opt_D_dump_asm_regalloc_stages dflags - , dopt Opt_D_dump_asm_stats dflags - , dopt Opt_D_dump_asm_conflicts dflags ] - - -- Check that we're not running off down the garden path. - when (spinCount > maxSpinCount) - $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded." - ( text "It looks like the register allocator is stuck in an infinite loop." - $$ text "max cycles = " <> int maxSpinCount - $$ text "regsFree = " <> (hcat $ punctuate space $ map ppr - $ nonDetEltsUniqSet $ unionManyUniqSets - $ nonDetEltsUFM regsFree) - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) - - -- Build the register conflict graph from the cmm code. - (graph :: Color.Graph VirtualReg RegClass RealReg) - <- {-# SCC "BuildGraph" #-} buildGraph code - - -- VERY IMPORTANT: - -- We really do want the graph to be fully evaluated _before_ we - -- start coloring. If we don't do this now then when the call to - -- Color.colorGraph forces bits of it, the heap will be filled with - -- half evaluated pieces of graph and zillions of apply thunks. - seqGraph graph `seq` return () - - -- Build a map of the cost of spilling each instruction. - -- This is a lazy binding, so the map will only be computed if we - -- actually have to spill to the stack. - let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo - $ map (slurpSpillCostInfo platform) code - - -- The function to choose regs to leave uncolored. - let spill = chooseSpill spillCosts - - -- Record startup state in our log. - let stat1 - = if spinCount == 0 - then Just $ RegAllocStatsStart - { raLiveCmm = code - , raGraph = graph - , raSpillCosts = spillCosts } - else Nothing - - -- Try and color the graph. - let (graph_colored, rsSpill, rmCoalesce) - = {-# SCC "ColorGraph" #-} - Color.colorGraph - (gopt Opt_RegsIterative dflags) - spinCount - regsFree triv spill graph - - -- Rewrite registers in the code that have been coalesced. - let patchF reg - | RegVirtual vr <- reg - = case lookupUFM rmCoalesce vr of - Just vr' -> patchF (RegVirtual vr') - Nothing -> reg - - | otherwise - = reg - - let code_coalesced - = map (patchEraseLive patchF) code - - -- Check whether we've found a coloring. - if isEmptyUniqSet rsSpill - - -- Coloring was successful because no registers needed to be spilled. - then do - -- if -fasm-lint is turned on then validate the graph. - -- This checks for bugs in the graph allocator itself. - let graph_colored_lint = - if gopt Opt_DoAsmLinting dflags - then Color.validateGraph (text "") - True -- Require all nodes to be colored. - graph_colored - else graph_colored - - -- Rewrite the code to use real hregs, using the colored graph. - let code_patched - = map (patchRegsFromGraph platform graph_colored_lint) - code_coalesced - - -- Clean out unneeded SPILL/RELOAD meta instructions. - -- The spill code generator just spills the entire live range - -- of a vreg, but it might not need to be on the stack for - -- its entire lifetime. - let code_spillclean - = map (cleanSpills platform) code_patched - - -- Strip off liveness information from the allocated code. - -- Also rewrite SPILL/RELOAD meta instructions into real machine - -- instructions along the way - let code_final - = map (stripLive dflags) code_spillclean - - -- Record what happened in this stage for debugging - let stat - = RegAllocStatsColored - { raCode = code - , raGraph = graph - , raGraphColored = graph_colored_lint - , raCoalesced = rmCoalesce - , raCodeCoalesced = code_coalesced - , raPatched = code_patched - , raSpillClean = code_spillclean - , raFinal = code_final - , raSRMs = foldl' addSRM (0, 0, 0) - $ map countSRMs code_spillclean } - - -- Bundle up all the register allocator statistics. - -- .. but make sure to drop them on the floor if they're not - -- needed, otherwise we'll get a space leak. - let statList = - if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs - else [] - - -- Ensure all the statistics are evaluated, to avoid space leaks. - seqList statList (return ()) - - return ( code_final - , statList - , graph_colored_lint) - - -- Coloring was unsuccessful. We need to spill some register to the - -- stack, make a new graph, and try to color it again. - else do - -- if -fasm-lint is turned on then validate the graph - let graph_colored_lint = - if gopt Opt_DoAsmLinting dflags - then Color.validateGraph (text "") - False -- don't require nodes to be colored - graph_colored - else graph_colored - - -- Spill uncolored regs to the stack. - (code_spilled, slotsFree', spillStats) - <- regSpill platform code_coalesced slotsFree rsSpill - - -- Recalculate liveness information. - -- NOTE: we have to reverse the SCCs here to get them back into - -- the reverse-dependency order required by computeLiveness. - -- If they're not in the correct order that function will panic. - code_relive <- mapM (regLiveness platform . reverseBlocksInTops) - code_spilled - - -- Record what happened in this stage for debugging. - let stat = - RegAllocStatsSpill - { raCode = code - , raGraph = graph_colored_lint - , raCoalesced = rmCoalesce - , raSpillStats = spillStats - , raSpillCosts = spillCosts - , raSpilled = code_spilled } - - -- Bundle up all the register allocator statistics. - -- .. but make sure to drop them on the floor if they're not - -- needed, otherwise we'll get a space leak. - let statList = - if dump - then [stat] ++ maybeToList stat1 ++ debug_codeGraphs - else [] - - -- Ensure all the statistics are evaluated, to avoid space leaks. - seqList statList (return ()) - - regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree' - statList - code_relive - - --- | Build a graph from the liveness and coalesce information in this code. -buildGraph - :: Instruction instr - => [LiveCmmDecl statics instr] - -> UniqSM (Color.Graph VirtualReg RegClass RealReg) - -buildGraph code - = do - -- Slurp out the conflicts and reg->reg moves from this code. - let (conflictList, moveList) = - unzip $ map slurpConflicts code - - -- Slurp out the spill/reload coalesces. - let moveList2 = map slurpReloadCoalesce code - - -- Add the reg-reg conflicts to the graph. - let conflictBag = unionManyBags conflictList - let graph_conflict - = foldrBag graphAddConflictSet Color.initGraph conflictBag - - -- Add the coalescences edges to the graph. - let moveBag - = unionBags (unionManyBags moveList2) - (unionManyBags moveList) - - let graph_coalesce - = foldrBag graphAddCoalesce graph_conflict moveBag - - return graph_coalesce - - --- | Add some conflict edges to the graph. --- Conflicts between virtual and real regs are recorded as exclusions. -graphAddConflictSet - :: UniqSet Reg - -> Color.Graph VirtualReg RegClass RealReg - -> Color.Graph VirtualReg RegClass RealReg - -graphAddConflictSet set graph - = let virtuals = mkUniqSet - [ vr | RegVirtual vr <- nonDetEltsUniqSet set ] - - graph1 = Color.addConflicts virtuals classOfVirtualReg graph - - graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2) - graph1 - [ (vr, rr) - | RegVirtual vr <- nonDetEltsUniqSet set - , RegReal rr <- nonDetEltsUniqSet set] - -- See Note [Unique Determinism and code generation] - - in graph2 - - --- | Add some coalesence edges to the graph --- Coalesences between virtual and real regs are recorded as preferences. -graphAddCoalesce - :: (Reg, Reg) - -> Color.Graph VirtualReg RegClass RealReg - -> Color.Graph VirtualReg RegClass RealReg - -graphAddCoalesce (r1, r2) graph - | RegReal rr <- r1 - , RegVirtual vr <- r2 - = Color.addPreference (vr, classOfVirtualReg vr) rr graph - - | RegReal rr <- r2 - , RegVirtual vr <- r1 - = Color.addPreference (vr, classOfVirtualReg vr) rr graph - - | RegVirtual vr1 <- r1 - , RegVirtual vr2 <- r2 - = Color.addCoalesce - (vr1, classOfVirtualReg vr1) - (vr2, classOfVirtualReg vr2) - graph - - -- We can't coalesce two real regs, but there could well be existing - -- hreg,hreg moves in the input code. We'll just ignore these - -- for coalescing purposes. - | RegReal _ <- r1 - , RegReal _ <- r2 - = graph - - | otherwise - = panic "graphAddCoalesce" - - --- | Patch registers in code using the reg -> reg mapping in this graph. -patchRegsFromGraph - :: (Outputable statics, Outputable instr, Instruction instr) - => Platform -> Color.Graph VirtualReg RegClass RealReg - -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr - -patchRegsFromGraph platform graph code - = patchEraseLive patchF code - where - -- Function to lookup the hardreg for a virtual reg from the graph. - patchF reg - -- leave real regs alone. - | RegReal{} <- reg - = reg - - -- this virtual has a regular node in the graph. - | RegVirtual vr <- reg - , Just node <- Color.lookupNode graph vr - = case Color.nodeColor node of - Just color -> RegReal color - Nothing -> RegVirtual vr - - -- no node in the graph for this virtual, bad news. - | otherwise - = pprPanic "patchRegsFromGraph: register mapping failed." - ( text "There is no node in the graph for register " - <> ppr reg - $$ ppr code - $$ Color.dotGraph - (\_ -> text "white") - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - graph) - - ------ --- for when laziness just isn't what you wanted... --- We need to deepSeq the whole graph before trying to colour it to avoid --- space leaks. -seqGraph :: Color.Graph VirtualReg RegClass RealReg -> () -seqGraph graph = seqNodes (nonDetEltsUFM (Color.graphMap graph)) - -- See Note [Unique Determinism and code generation] - -seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> () -seqNodes ns - = case ns of - [] -> () - (n : ns) -> seqNode n `seq` seqNodes ns - -seqNode :: Color.Node VirtualReg RegClass RealReg -> () -seqNode node - = seqVirtualReg (Color.nodeId node) - `seq` seqRegClass (Color.nodeClass node) - `seq` seqMaybeRealReg (Color.nodeColor node) - `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node))) - `seq` (seqRealRegList (nonDetEltsUniqSet (Color.nodeExclusions node))) - `seq` (seqRealRegList (Color.nodePreference node)) - `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node))) - -- It's OK to use nonDetEltsUniqSet for seq - -seqVirtualReg :: VirtualReg -> () -seqVirtualReg reg = reg `seq` () - -seqRealReg :: RealReg -> () -seqRealReg reg = reg `seq` () - -seqRegClass :: RegClass -> () -seqRegClass c = c `seq` () - -seqMaybeRealReg :: Maybe RealReg -> () -seqMaybeRealReg mr - = case mr of - Nothing -> () - Just r -> seqRealReg r - -seqVirtualRegList :: [VirtualReg] -> () -seqVirtualRegList rs - = case rs of - [] -> () - (r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs - -seqRealRegList :: [RealReg] -> () -seqRealRegList rs - = case rs of - [] -> () - (r : rs) -> seqRealReg r `seq` seqRealRegList rs diff --git a/nativeGen/RegAlloc/Graph/Spill.hs b/nativeGen/RegAlloc/Graph/Spill.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/Spill.hs +++ /dev/null @@ -1,379 +0,0 @@ - --- | When there aren't enough registers to hold all the vregs we have to spill --- some of those vregs to slots on the stack. This module is used modify the --- code to use those slots. -module RegAlloc.Graph.Spill ( - regSpill, - SpillStats(..), - accSpillSL -) where -import RegAlloc.Liveness -import Instruction -import Reg -import Cmm hiding (RegSet) -import BlockId -import Hoopl - -import MonadUtils -import State -import Unique -import UniqFM -import UniqSet -import UniqSupply -import Outputable -import Platform - -import Data.List -import Data.Maybe -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - - --- | Spill all these virtual regs to stack slots. --- --- TODO: See if we can split some of the live ranges instead of just globally --- spilling the virtual reg. This might make the spill cleaner's job easier. --- --- TODO: On CISCy x86 and x86_64 we don't nessesarally have to add a mov instruction --- when making spills. If an instr is using a spilled virtual we may be able to --- address the spill slot directly. --- -regSpill - :: Instruction instr - => Platform - -> [LiveCmmDecl statics instr] -- ^ the code - -> UniqSet Int -- ^ available stack slots - -> UniqSet VirtualReg -- ^ the regs to spill - -> UniqSM - ([LiveCmmDecl statics instr] - -- code with SPILL and RELOAD meta instructions added. - , UniqSet Int -- left over slots - , SpillStats ) -- stats about what happened during spilling - -regSpill platform code slotsFree regs - - -- Not enough slots to spill these regs. - | sizeUniqSet slotsFree < sizeUniqSet regs - = pprPanic "regSpill: out of spill slots!" - ( text " regs to spill = " <> ppr (sizeUniqSet regs) - $$ text " slots left = " <> ppr (sizeUniqSet slotsFree)) - - | otherwise - = do - -- Allocate a slot for each of the spilled regs. - let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree - let regSlotMap = listToUFM - $ zip (nonDetEltsUniqSet regs) slots - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - -- Grab the unique supply from the monad. - us <- getUniqueSupplyM - - -- Run the spiller on all the blocks. - let (code', state') = - runState (mapM (regSpill_top platform regSlotMap) code) - (initSpillS us) - - return ( code' - , minusUniqSet slotsFree (mkUniqSet slots) - , makeSpillStats state') - - --- | Spill some registers to stack slots in a top-level thing. -regSpill_top - :: Instruction instr - => Platform - -> RegMap Int - -- ^ map of vregs to slots they're being spilled to. - -> LiveCmmDecl statics instr - -- ^ the top level thing. - -> SpillM (LiveCmmDecl statics instr) - -regSpill_top platform regSlotMap cmm - = case cmm of - CmmData{} - -> return cmm - - CmmProc info label live sccs - | LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info - -> do - -- We should only passed Cmms with the liveness maps filled in, - -- but we'll create empty ones if they're not there just in case. - let liveVRegsOnEntry = fromMaybe mapEmpty mLiveVRegsOnEntry - - -- The liveVRegsOnEntry contains the set of vregs that are live - -- on entry to each basic block. If we spill one of those vregs - -- we remove it from that set and add the corresponding slot - -- number to the liveSlotsOnEntry set. The spill cleaner needs - -- this information to erase unneeded spill and reload instructions - -- after we've done a successful allocation. - let liveSlotsOnEntry' :: BlockMap IntSet - liveSlotsOnEntry' - = mapFoldWithKey patchLiveSlot - liveSlotsOnEntry liveVRegsOnEntry - - let info' - = LiveInfo static firstId - (Just liveVRegsOnEntry) - liveSlotsOnEntry' - - -- Apply the spiller to all the basic blocks in the CmmProc. - sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs - - return $ CmmProc info' label live sccs' - - where -- Given a BlockId and the set of registers live in it, - -- if registers in this block are being spilled to stack slots, - -- then record the fact that these slots are now live in those blocks - -- in the given slotmap. - patchLiveSlot - :: BlockId -> RegSet - -> BlockMap IntSet -> BlockMap IntSet - - patchLiveSlot blockId regsLive slotMap - = let - -- Slots that are already recorded as being live. - curSlotsLive = fromMaybe IntSet.empty - $ mapLookup blockId slotMap - - moreSlotsLive = IntSet.fromList - $ catMaybes - $ map (lookupUFM regSlotMap) - $ nonDetEltsUniqSet regsLive - -- See Note [Unique Determinism and code generation] - - slotMap' - = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive) - slotMap - - in slotMap' - - --- | Spill some registers to stack slots in a basic block. -regSpill_block - :: Instruction instr - => Platform - -> UniqFM Int -- ^ map of vregs to slots they're being spilled to. - -> LiveBasicBlock instr - -> SpillM (LiveBasicBlock instr) - -regSpill_block platform regSlotMap (BasicBlock i instrs) - = do instrss' <- mapM (regSpill_instr platform regSlotMap) instrs - return $ BasicBlock i (concat instrss') - - --- | Spill some registers to stack slots in a single instruction. --- If the instruction uses registers that need to be spilled, then it is --- prefixed (or postfixed) with the appropriate RELOAD or SPILL meta --- instructions. -regSpill_instr - :: Instruction instr - => Platform - -> UniqFM Int -- ^ map of vregs to slots they're being spilled to. - -> LiveInstr instr - -> SpillM [LiveInstr instr] - -regSpill_instr _ _ li@(LiveInstr _ Nothing) - = do return [li] - -regSpill_instr platform regSlotMap - (LiveInstr instr (Just _)) - = do - -- work out which regs are read and written in this instr - let RU rlRead rlWritten = regUsageOfInstr platform instr - - -- sometimes a register is listed as being read more than once, - -- nub this so we don't end up inserting two lots of spill code. - let rsRead_ = nub rlRead - let rsWritten_ = nub rlWritten - - -- if a reg is modified, it appears in both lists, want to undo this.. - let rsRead = rsRead_ \\ rsWritten_ - let rsWritten = rsWritten_ \\ rsRead_ - let rsModify = intersect rsRead_ rsWritten_ - - -- work out if any of the regs being used are currently being spilled. - let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead - let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten - let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify - - -- rewrite the instr and work out spill code. - (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead - (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten - (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify - - let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3) - let prefixes = concat mPrefixes - let postfixes = concat mPostfixes - - -- final code - let instrs' = prefixes - ++ [LiveInstr instr3 Nothing] - ++ postfixes - - return $ instrs' - - --- | Add a RELOAD met a instruction to load a value for an instruction that --- writes to a vreg that is being spilled. -spillRead - :: Instruction instr - => UniqFM Int - -> instr - -> Reg - -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) - -spillRead regSlotMap instr reg - | Just slot <- lookupUFM regSlotMap reg - = do (instr', nReg) <- patchInstr reg instr - - modify $ \s -> s - { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) } - - return ( instr' - , ( [LiveInstr (RELOAD slot nReg) Nothing] - , []) ) - - | otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg" - - --- | Add a SPILL meta instruction to store a value for an instruction that --- writes to a vreg that is being spilled. -spillWrite - :: Instruction instr - => UniqFM Int - -> instr - -> Reg - -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) - -spillWrite regSlotMap instr reg - | Just slot <- lookupUFM regSlotMap reg - = do (instr', nReg) <- patchInstr reg instr - - modify $ \s -> s - { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) } - - return ( instr' - , ( [] - , [LiveInstr (SPILL nReg slot) Nothing])) - - | otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg" - - --- | Add both RELOAD and SPILL meta instructions for an instruction that --- both reads and writes to a vreg that is being spilled. -spillModify - :: Instruction instr - => UniqFM Int - -> instr - -> Reg - -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) - -spillModify regSlotMap instr reg - | Just slot <- lookupUFM regSlotMap reg - = do (instr', nReg) <- patchInstr reg instr - - modify $ \s -> s - { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) } - - return ( instr' - , ( [LiveInstr (RELOAD slot nReg) Nothing] - , [LiveInstr (SPILL nReg slot) Nothing])) - - | otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg" - - --- | Rewrite uses of this virtual reg in an instr to use a different --- virtual reg. -patchInstr - :: Instruction instr - => Reg -> instr -> SpillM (instr, Reg) - -patchInstr reg instr - = do nUnique <- newUnique - - -- The register we're rewriting is suppoed to be virtual. - -- If it's not then something has gone horribly wrong. - let nReg - = case reg of - RegVirtual vr - -> RegVirtual (renameVirtualReg nUnique vr) - - RegReal{} - -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg" - - let instr' = patchReg1 reg nReg instr - return (instr', nReg) - - -patchReg1 - :: Instruction instr - => Reg -> Reg -> instr -> instr - -patchReg1 old new instr - = let patchF r - | r == old = new - | otherwise = r - in patchRegsOfInstr instr patchF - - --- Spiller monad -------------------------------------------------------------- --- | State monad for the spill code generator. -type SpillM a - = State SpillS a - --- | Spill code generator state. -data SpillS - = SpillS - { -- | Unique supply for generating fresh vregs. - stateUS :: UniqSupply - - -- | Spilled vreg vs the number of times it was loaded, stored. - , stateSpillSL :: UniqFM (Reg, Int, Int) } - - --- | Create a new spiller state. -initSpillS :: UniqSupply -> SpillS -initSpillS uniqueSupply - = SpillS - { stateUS = uniqueSupply - , stateSpillSL = emptyUFM } - - --- | Allocate a new unique in the spiller monad. -newUnique :: SpillM Unique -newUnique - = do us <- gets stateUS - case takeUniqFromSupply us of - (uniq, us') - -> do modify $ \s -> s { stateUS = us' } - return uniq - - --- | Add a spill/reload count to a stats record for a register. -accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int) -accSpillSL (r1, s1, l1) (_, s2, l2) - = (r1, s1 + s2, l1 + l2) - - --- Spiller stats -------------------------------------------------------------- --- | Spiller statistics. --- Tells us what registers were spilled. -data SpillStats - = SpillStats - { spillStoreLoad :: UniqFM (Reg, Int, Int) } - - --- | Extract spiller statistics from the spiller state. -makeSpillStats :: SpillS -> SpillStats -makeSpillStats s - = SpillStats - { spillStoreLoad = stateSpillSL s } - - -instance Outputable SpillStats where - ppr stats - = pprUFM (spillStoreLoad stats) - (vcat . map (\(r, s, l) -> ppr r <+> int s <+> int l)) diff --git a/nativeGen/RegAlloc/Graph/SpillClean.hs b/nativeGen/RegAlloc/Graph/SpillClean.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/SpillClean.hs +++ /dev/null @@ -1,612 +0,0 @@ - --- | Clean out unneeded spill\/reload instructions. --- --- Handling of join points --- ~~~~~~~~~~~~~~~~~~~~~~~ --- --- B1: B2: --- ... ... --- RELOAD SLOT(0), %r1 RELOAD SLOT(0), %r1 --- ... A ... ... B ... --- jump B3 jump B3 --- --- B3: ... C ... --- RELOAD SLOT(0), %r1 --- ... --- --- The Plan --- ~~~~~~~~ --- As long as %r1 hasn't been written to in A, B or C then we don't need --- the reload in B3. --- --- What we really care about here is that on the entry to B3, %r1 will --- always have the same value that is in SLOT(0) (ie, %r1 is _valid_) --- --- This also works if the reloads in B1\/B2 were spills instead, because --- spilling %r1 to a slot makes that slot have the same value as %r1. --- -module RegAlloc.Graph.SpillClean ( - cleanSpills -) where -import RegAlloc.Liveness -import Instruction -import Reg - -import BlockId -import Hoopl -import Cmm -import UniqSet -import UniqFM -import Unique -import State -import Outputable -import Platform - -import Data.List -import Data.Maybe -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - - --- | The identification number of a spill slot. --- A value is stored in a spill slot when we don't have a free --- register to hold it. -type Slot = Int - - --- | Clean out unneeded spill\/reloads from this top level thing. -cleanSpills - :: Instruction instr - => Platform - -> LiveCmmDecl statics instr - -> LiveCmmDecl statics instr - -cleanSpills platform cmm - = evalState (cleanSpin platform 0 cmm) initCleanS - - --- | Do one pass of cleaning. -cleanSpin - :: Instruction instr - => Platform - -> Int -- ^ Iteration number for the cleaner. - -> LiveCmmDecl statics instr -- ^ Liveness annotated code to clean. - -> CleanM (LiveCmmDecl statics instr) - -cleanSpin platform spinCount code - = do - -- Initialise count of cleaned spill and reload instructions. - modify $ \s -> s - { sCleanedSpillsAcc = 0 - , sCleanedReloadsAcc = 0 - , sReloadedBy = emptyUFM } - - code_forward <- mapBlockTopM (cleanBlockForward platform) code - code_backward <- cleanTopBackward code_forward - - -- During the cleaning of each block we collected information about - -- what regs were valid across each jump. Based on this, work out - -- whether it will be safe to erase reloads after join points for - -- the next pass. - collateJoinPoints - - -- Remember how many spill and reload instructions we cleaned in this pass. - spills <- gets sCleanedSpillsAcc - reloads <- gets sCleanedReloadsAcc - modify $ \s -> s - { sCleanedCount = (spills, reloads) : sCleanedCount s } - - -- If nothing was cleaned in this pass or the last one - -- then we're done and it's time to bail out. - cleanedCount <- gets sCleanedCount - if take 2 cleanedCount == [(0, 0), (0, 0)] - then return code - - -- otherwise go around again - else cleanSpin platform (spinCount + 1) code_backward - - -------------------------------------------------------------------------------- --- | Clean out unneeded reload instructions, --- while walking forward over the code. -cleanBlockForward - :: Instruction instr - => Platform - -> LiveBasicBlock instr - -> CleanM (LiveBasicBlock instr) - -cleanBlockForward platform (BasicBlock blockId instrs) - = do - -- See if we have a valid association for the entry to this block. - jumpValid <- gets sJumpValid - let assoc = case lookupUFM jumpValid blockId of - Just assoc -> assoc - Nothing -> emptyAssoc - - instrs_reload <- cleanForward platform blockId assoc [] instrs - return $ BasicBlock blockId instrs_reload - - - --- | Clean out unneeded reload instructions. --- --- Walking forwards across the code --- On a reload, if we know a reg already has the same value as a slot --- then we don't need to do the reload. --- -cleanForward - :: Instruction instr - => Platform - -> BlockId -- ^ the block that we're currently in - -> Assoc Store -- ^ two store locations are associated if - -- they have the same value - -> [LiveInstr instr] -- ^ acc - -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) - -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) - -cleanForward _ _ _ acc [] - = return acc - --- Rewrite live range joins via spill slots to just a spill and a reg-reg move --- hopefully the spill will be also be cleaned in the next pass -cleanForward platform blockId assoc acc (li1 : li2 : instrs) - - | LiveInstr (SPILL reg1 slot1) _ <- li1 - , LiveInstr (RELOAD slot2 reg2) _ <- li2 - , slot1 == slot2 - = do - modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - cleanForward platform blockId assoc acc - $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing - : instrs - -cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs) - | Just (r1, r2) <- takeRegRegMoveInstr i1 - = if r1 == r2 - -- Erase any left over nop reg reg moves while we're here - -- this will also catch any nop moves that the previous case - -- happens to add. - then cleanForward platform blockId assoc acc instrs - - -- If r1 has the same value as some slots and we copy r1 to r2, - -- then r2 is now associated with those slots instead - else do let assoc' = addAssoc (SReg r1) (SReg r2) - $ delAssoc (SReg r2) - $ assoc - - cleanForward platform blockId assoc' (li : acc) instrs - - -cleanForward platform blockId assoc acc (li : instrs) - - -- Update association due to the spill. - | LiveInstr (SPILL reg slot) _ <- li - = let assoc' = addAssoc (SReg reg) (SSlot slot) - $ delAssoc (SSlot slot) - $ assoc - in cleanForward platform blockId assoc' (li : acc) instrs - - -- Clean a reload instr. - | LiveInstr (RELOAD{}) _ <- li - = do (assoc', mli) <- cleanReload platform blockId assoc li - case mli of - Nothing -> cleanForward platform blockId assoc' acc - instrs - - Just li' -> cleanForward platform blockId assoc' (li' : acc) - instrs - - -- Remember the association over a jump. - | LiveInstr instr _ <- li - , targets <- jumpDestsOfInstr instr - , not $ null targets - = do mapM_ (accJumpValid assoc) targets - cleanForward platform blockId assoc (li : acc) instrs - - -- Writing to a reg changes its value. - | LiveInstr instr _ <- li - , RU _ written <- regUsageOfInstr platform instr - = let assoc' = foldr delAssoc assoc (map SReg $ nub written) - in cleanForward platform blockId assoc' (li : acc) instrs - - - --- | Try and rewrite a reload instruction to something more pleasing -cleanReload - :: Instruction instr - => Platform - -> BlockId - -> Assoc Store - -> LiveInstr instr - -> CleanM (Assoc Store, Maybe (LiveInstr instr)) - -cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _) - - -- If the reg we're reloading already has the same value as the slot - -- then we can erase the instruction outright. - | elemAssoc (SSlot slot) (SReg reg) assoc - = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - return (assoc, Nothing) - - -- If we can find another reg with the same value as this slot then - -- do a move instead of a reload. - | Just reg2 <- findRegOfSlot assoc slot - = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - - let assoc' = addAssoc (SReg reg) (SReg reg2) - $ delAssoc (SReg reg) - $ assoc - - return ( assoc' - , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing) - - -- Gotta keep this instr. - | otherwise - = do -- Update the association. - let assoc' - = addAssoc (SReg reg) (SSlot slot) - -- doing the reload makes reg and slot the same value - $ delAssoc (SReg reg) - -- reg value changes on reload - $ assoc - - -- Remember that this block reloads from this slot. - accBlockReloadsSlot blockId slot - - return (assoc', Just li) - -cleanReload _ _ _ _ - = panic "RegSpillClean.cleanReload: unhandled instr" - - -------------------------------------------------------------------------------- --- | Clean out unneeded spill instructions, --- while walking backwards over the code. --- --- If there were no reloads from a slot between a spill and the last one --- then the slot was never read and we don't need the spill. --- --- SPILL r0 -> s1 --- RELOAD s1 -> r2 --- SPILL r3 -> s1 <--- don't need this spill --- SPILL r4 -> s1 --- RELOAD s1 -> r5 --- --- Maintain a set of --- "slots which were spilled to but not reloaded from yet" --- --- Walking backwards across the code: --- a) On a reload from a slot, remove it from the set. --- --- a) On a spill from a slot --- If the slot is in set then we can erase the spill, --- because it won't be reloaded from until after the next spill. --- --- otherwise --- keep the spill and add the slot to the set --- --- TODO: This is mostly inter-block --- we should really be updating the noReloads set as we cross jumps also. --- --- TODO: generate noReloads from liveSlotsOnEntry --- -cleanTopBackward - :: Instruction instr - => LiveCmmDecl statics instr - -> CleanM (LiveCmmDecl statics instr) - -cleanTopBackward cmm - = case cmm of - CmmData{} - -> return cmm - - CmmProc info label live sccs - | LiveInfo _ _ _ liveSlotsOnEntry <- info - -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs - return $ CmmProc info label live sccs' - - -cleanBlockBackward - :: Instruction instr - => BlockMap IntSet - -> LiveBasicBlock instr - -> CleanM (LiveBasicBlock instr) - -cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs) - = do instrs_spill <- cleanBackward liveSlotsOnEntry emptyUniqSet [] instrs - return $ BasicBlock blockId instrs_spill - - - -cleanBackward - :: Instruction instr - => BlockMap IntSet -- ^ Slots live on entry to each block - -> UniqSet Int -- ^ Slots that have been spilled, but not reloaded from - -> [LiveInstr instr] -- ^ acc - -> [LiveInstr instr] -- ^ Instrs to clean (in forwards order) - -> CleanM [LiveInstr instr] -- ^ Cleaned instrs (in backwards order) - -cleanBackward liveSlotsOnEntry noReloads acc lis - = do reloadedBy <- gets sReloadedBy - cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis - - -cleanBackward' - :: Instruction instr - => BlockMap IntSet - -> UniqFM [BlockId] - -> UniqSet Int - -> [LiveInstr instr] - -> [LiveInstr instr] - -> State CleanS [LiveInstr instr] - -cleanBackward' _ _ _ acc [] - = return acc - -cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs) - - -- If nothing ever reloads from this slot then we don't need the spill. - | LiveInstr (SPILL _ slot) _ <- li - , Nothing <- lookupUFM reloadedBy (SSlot slot) - = do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } - cleanBackward liveSlotsOnEntry noReloads acc instrs - - | LiveInstr (SPILL _ slot) _ <- li - = if elementOfUniqSet slot noReloads - - -- We can erase this spill because the slot won't be read until - -- after the next one - then do - modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } - cleanBackward liveSlotsOnEntry noReloads acc instrs - - else do - -- This slot is being spilled to, but we haven't seen any reloads yet. - let noReloads' = addOneToUniqSet noReloads slot - cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs - - -- if we reload from a slot then it's no longer unused - | LiveInstr (RELOAD slot _) _ <- li - , noReloads' <- delOneFromUniqSet noReloads slot - = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs - - -- If a slot is live in a jump target then assume it's reloaded there. - -- - -- TODO: A real dataflow analysis would do a better job here. - -- If the target block _ever_ used the slot then we assume - -- it always does, but if those reloads are cleaned the slot - -- liveness map doesn't get updated. - | LiveInstr instr _ <- li - , targets <- jumpDestsOfInstr instr - = do - let slotsReloadedByTargets - = IntSet.unions - $ catMaybes - $ map (flip mapLookup liveSlotsOnEntry) - $ targets - - let noReloads' - = foldl' delOneFromUniqSet noReloads - $ IntSet.toList slotsReloadedByTargets - - cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs - - -- some other instruction - | otherwise - = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs - - --- | Combine the associations from all the inward control flow edges. --- -collateJoinPoints :: CleanM () -collateJoinPoints - = modify $ \s -> s - { sJumpValid = mapUFM intersects (sJumpValidAcc s) - , sJumpValidAcc = emptyUFM } - -intersects :: [Assoc Store] -> Assoc Store -intersects [] = emptyAssoc -intersects assocs = foldl1' intersectAssoc assocs - - --- | See if we have a reg with the same value as this slot in the association table. -findRegOfSlot :: Assoc Store -> Int -> Maybe Reg -findRegOfSlot assoc slot - | close <- closeAssoc (SSlot slot) assoc - , Just (SReg reg) <- find isStoreReg $ nonDetEltsUniqSet close - -- See Note [Unique Determinism and code generation] - = Just reg - - | otherwise - = Nothing - - -------------------------------------------------------------------------------- --- | Cleaner monad. -type CleanM - = State CleanS - --- | Cleaner state. -data CleanS - = CleanS - { -- | Regs which are valid at the start of each block. - sJumpValid :: UniqFM (Assoc Store) - - -- | Collecting up what regs were valid across each jump. - -- in the next pass we can collate these and write the results - -- to sJumpValid. - , sJumpValidAcc :: UniqFM [Assoc Store] - - -- | Map of (slot -> blocks which reload from this slot) - -- used to decide if whether slot spilled to will ever be - -- reloaded from on this path. - , sReloadedBy :: UniqFM [BlockId] - - -- | Spills and reloads cleaned each pass (latest at front) - , sCleanedCount :: [(Int, Int)] - - -- | Spills and reloads that have been cleaned in this pass so far. - , sCleanedSpillsAcc :: Int - , sCleanedReloadsAcc :: Int } - - --- | Construct the initial cleaner state. -initCleanS :: CleanS -initCleanS - = CleanS - { sJumpValid = emptyUFM - , sJumpValidAcc = emptyUFM - - , sReloadedBy = emptyUFM - - , sCleanedCount = [] - - , sCleanedSpillsAcc = 0 - , sCleanedReloadsAcc = 0 } - - --- | Remember the associations before a jump. -accJumpValid :: Assoc Store -> BlockId -> CleanM () -accJumpValid assocs target - = modify $ \s -> s { - sJumpValidAcc = addToUFM_C (++) - (sJumpValidAcc s) - target - [assocs] } - - -accBlockReloadsSlot :: BlockId -> Slot -> CleanM () -accBlockReloadsSlot blockId slot - = modify $ \s -> s { - sReloadedBy = addToUFM_C (++) - (sReloadedBy s) - (SSlot slot) - [blockId] } - - -------------------------------------------------------------------------------- --- A store location can be a stack slot or a register -data Store - = SSlot Int - | SReg Reg - - --- | Check if this is a reg store. -isStoreReg :: Store -> Bool -isStoreReg ss - = case ss of - SSlot _ -> False - SReg _ -> True - - --- Spill cleaning is only done once all virtuals have been allocated to realRegs -instance Uniquable Store where - getUnique (SReg r) - | RegReal (RealRegSingle i) <- r - = mkRegSingleUnique i - - | RegReal (RealRegPair r1 r2) <- r - = mkRegPairUnique (r1 * 65535 + r2) - - | otherwise - = error $ "RegSpillClean.getUnique: found virtual reg during spill clean," - ++ "only real regs expected." - - getUnique (SSlot i) = mkRegSubUnique i -- [SLPJ] I hope "SubUnique" is ok - - -instance Outputable Store where - ppr (SSlot i) = text "slot" <> int i - ppr (SReg r) = ppr r - - -------------------------------------------------------------------------------- --- Association graphs. --- In the spill cleaner, two store locations are associated if they are known --- to hold the same value. --- -type Assoc a = UniqFM (UniqSet a) - --- | An empty association -emptyAssoc :: Assoc a -emptyAssoc = emptyUFM - - --- | Add an association between these two things. -addAssoc :: Uniquable a - => a -> a -> Assoc a -> Assoc a - -addAssoc a b m - = let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b) - m2 = addToUFM_C unionUniqSets m1 b (unitUniqSet a) - in m2 - - --- | Delete all associations to a node. -delAssoc :: (Uniquable a) - => a -> Assoc a -> Assoc a - -delAssoc a m - | Just aSet <- lookupUFM m a - , m1 <- delFromUFM m a - = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet - -- It's OK to use nonDetFoldUFM here because deletion is commutative - - | otherwise = m - - --- | Delete a single association edge (a -> b). -delAssoc1 :: Uniquable a - => a -> a -> Assoc a -> Assoc a - -delAssoc1 a b m - | Just aSet <- lookupUFM m a - = addToUFM m a (delOneFromUniqSet aSet b) - - | otherwise = m - - --- | Check if these two things are associated. -elemAssoc :: (Uniquable a) - => a -> a -> Assoc a -> Bool - -elemAssoc a b m - = elementOfUniqSet b (closeAssoc a m) - - --- | Find the refl. trans. closure of the association from this point. -closeAssoc :: (Uniquable a) - => a -> Assoc a -> UniqSet a - -closeAssoc a assoc - = closeAssoc' assoc emptyUniqSet (unitUniqSet a) - where - closeAssoc' assoc visited toVisit - = case nonDetEltsUniqSet toVisit of - -- See Note [Unique Determinism and code generation] - - -- nothing else to visit, we're done - [] -> visited - - (x:_) - -- we've already seen this node - | elementOfUniqSet x visited - -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x) - - -- haven't seen this node before, - -- remember to visit all its neighbors - | otherwise - -> let neighbors - = case lookupUFM assoc x of - Nothing -> emptyUniqSet - Just set -> set - - in closeAssoc' assoc - (addOneToUniqSet visited x) - (unionUniqSets toVisit neighbors) - --- | Intersect two associations. -intersectAssoc :: Assoc a -> Assoc a -> Assoc a -intersectAssoc a b - = intersectUFM_C (intersectUniqSets) a b - diff --git a/nativeGen/RegAlloc/Graph/SpillCost.hs b/nativeGen/RegAlloc/Graph/SpillCost.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/SpillCost.hs +++ /dev/null @@ -1,291 +0,0 @@ - -module RegAlloc.Graph.SpillCost ( - SpillCostRecord, - plusSpillCostRecord, - pprSpillCostRecord, - - SpillCostInfo, - zeroSpillCostInfo, - plusSpillCostInfo, - - slurpSpillCostInfo, - chooseSpill, - - lifeMapFromSpillCostInfo -) where -import RegAlloc.Liveness -import Instruction -import RegClass -import Reg - -import GraphBase - -import Hoopl (mapLookup) -import Cmm -import UniqFM -import UniqSet -import Digraph (flattenSCCs) -import Outputable -import Platform -import State - -import Data.List (nub, minimumBy) -import Data.Maybe - - --- | Records the expected cost to spill some regster. -type SpillCostRecord - = ( VirtualReg -- register name - , Int -- number of writes to this reg - , Int -- number of reads from this reg - , Int) -- number of instrs this reg was live on entry to - - --- | Map of `SpillCostRecord` -type SpillCostInfo - = UniqFM SpillCostRecord - - --- | An empty map of spill costs. -zeroSpillCostInfo :: SpillCostInfo -zeroSpillCostInfo = emptyUFM - - --- | Add two spill cost infos. -plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo -plusSpillCostInfo sc1 sc2 - = plusUFM_C plusSpillCostRecord sc1 sc2 - - --- | Add two spill cost records. -plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord -plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) - | r1 == r2 = (r1, a1 + a2, b1 + b2, c1 + c2) - | otherwise = error "RegSpillCost.plusRegInt: regs don't match" - - --- | Slurp out information used for determining spill costs. --- --- For each vreg, the number of times it was written to, read from, --- and the number of instructions it was live on entry to (lifetime) --- -slurpSpillCostInfo :: (Outputable instr, Instruction instr) - => Platform - -> LiveCmmDecl statics instr - -> SpillCostInfo - -slurpSpillCostInfo platform cmm - = execState (countCmm cmm) zeroSpillCostInfo - where - countCmm CmmData{} = return () - countCmm (CmmProc info _ _ sccs) - = mapM_ (countBlock info) - $ flattenSCCs sccs - - -- Lookup the regs that are live on entry to this block in - -- the info table from the CmmProc. - countBlock info (BasicBlock blockId instrs) - | LiveInfo _ _ (Just blockLive) _ <- info - , Just rsLiveEntry <- mapLookup blockId blockLive - , rsLiveEntry_virt <- takeVirtuals rsLiveEntry - = countLIs rsLiveEntry_virt instrs - - | otherwise - = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block" - - countLIs _ [] - = return () - - -- Skip over comment and delta pseudo instrs. - countLIs rsLive (LiveInstr instr Nothing : lis) - | isMetaInstr instr - = countLIs rsLive lis - - | otherwise - = pprPanic "RegSpillCost.slurpSpillCostInfo" - $ text "no liveness information on instruction " <> ppr instr - - countLIs rsLiveEntry (LiveInstr instr (Just live) : lis) - = do - -- Increment the lifetime counts for regs live on entry to this instr. - mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - -- Increment counts for what regs were read/written from. - let (RU read written) = regUsageOfInstr platform instr - mapM_ incUses $ catMaybes $ map takeVirtualReg $ nub read - mapM_ incDefs $ catMaybes $ map takeVirtualReg $ nub written - - -- Compute liveness for entry to next instruction. - let liveDieRead_virt = takeVirtuals (liveDieRead live) - let liveDieWrite_virt = takeVirtuals (liveDieWrite live) - let liveBorn_virt = takeVirtuals (liveBorn live) - - let rsLiveAcross - = rsLiveEntry `minusUniqSet` liveDieRead_virt - - let rsLiveNext - = (rsLiveAcross `unionUniqSets` liveBorn_virt) - `minusUniqSet` liveDieWrite_virt - - countLIs rsLiveNext lis - - incDefs reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 1, 0, 0) - incUses reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 1, 0) - incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1) - - --- | Take all the virtual registers from this set. -takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg -takeVirtuals set = mkUniqSet - [ vr | RegVirtual vr <- nonDetEltsUniqSet set ] - -- See Note [Unique Determinism and code generation] - - --- | Choose a node to spill from this graph -chooseSpill - :: SpillCostInfo - -> Graph VirtualReg RegClass RealReg - -> VirtualReg - -chooseSpill info graph - = let cost = spillCost_length info graph - node = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2)) - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - in nodeId node - - -------------------------------------------------------------------------------- --- | Chaitins spill cost function is: --- --- cost = sum loadCost * freq (u) + sum storeCost * freq (d) --- u <- uses (v) d <- defs (v) --- --- There are no loops in our code at the momemnt, so we can set the freq's to 1. --- --- If we don't have live range splitting then Chaitins function performs badly --- if we have lots of nested live ranges and very few registers. --- --- v1 v2 v3 --- def v1 . --- use v1 . --- def v2 . . --- def v3 . . . --- use v1 . . . --- use v3 . . . --- use v2 . . --- use v1 . --- --- defs uses degree cost --- v1: 1 3 3 1.5 --- v2: 1 2 3 1.0 --- v3: 1 1 3 0.666 --- --- v3 has the lowest cost, but if we only have 2 hardregs and we insert --- spill code for v3 then this isn't going to improve the colorability of --- the graph. --- --- When compiling SHA1, which as very long basic blocks and some vregs --- with very long live ranges the allocator seems to try and spill from --- the inside out and eventually run out of stack slots. --- --- Without live range splitting, its's better to spill from the outside --- in so set the cost of very long live ranges to zero --- -{- -spillCost_chaitin - :: SpillCostInfo - -> Graph Reg RegClass Reg - -> Reg - -> Float - -spillCost_chaitin info graph reg - -- Spilling a live range that only lives for 1 instruction - -- isn't going to help us at all - and we definitely want to avoid - -- trying to re-spill previously inserted spill code. - | lifetime <= 1 = 1/0 - - -- It's unlikely that we'll find a reg for a live range this long - -- better to spill it straight up and not risk trying to keep it around - -- and have to go through the build/color cycle again. - | lifetime > allocatableRegsInClass (regClass reg) * 10 - = 0 - - -- Otherwise revert to chaitin's regular cost function. - | otherwise = fromIntegral (uses + defs) - / fromIntegral (nodeDegree graph reg) - where (_, defs, uses, lifetime) - = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg --} - --- Just spill the longest live range. -spillCost_length - :: SpillCostInfo - -> Graph VirtualReg RegClass RealReg - -> VirtualReg - -> Float - -spillCost_length info _ reg - | lifetime <= 1 = 1/0 - | otherwise = 1 / fromIntegral lifetime - where (_, _, _, lifetime) - = fromMaybe (reg, 0, 0, 0) - $ lookupUFM info reg - - --- | Extract a map of register lifetimes from a `SpillCostInfo`. -lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int) -lifeMapFromSpillCostInfo info - = listToUFM - $ map (\(r, _, _, life) -> (r, (r, life))) - $ nonDetEltsUFM info - -- See Note [Unique Determinism and code generation] - - --- | Determine the degree (number of neighbors) of this node which --- have the same class. -nodeDegree - :: (VirtualReg -> RegClass) - -> Graph VirtualReg RegClass RealReg - -> VirtualReg - -> Int - -nodeDegree classOfVirtualReg graph reg - | Just node <- lookupUFM (graphMap graph) reg - - , virtConflicts - <- length - $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg) - $ nonDetEltsUniqSet - -- See Note [Unique Determinism and code generation] - $ nodeConflicts node - - = virtConflicts + sizeUniqSet (nodeExclusions node) - - | otherwise - = 0 - - --- | Show a spill cost record, including the degree from the graph --- and final calulated spill cost. -pprSpillCostRecord - :: (VirtualReg -> RegClass) - -> (Reg -> SDoc) - -> Graph VirtualReg RegClass RealReg - -> SpillCostRecord - -> SDoc - -pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life) - = hsep - [ pprReg (RegVirtual reg) - , ppr uses - , ppr defs - , ppr life - , ppr $ nodeDegree regClass graph reg - , text $ show $ (fromIntegral (uses + defs) - / fromIntegral (nodeDegree regClass graph reg) :: Float) ] - diff --git a/nativeGen/RegAlloc/Graph/Stats.hs b/nativeGen/RegAlloc/Graph/Stats.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/Stats.hs +++ /dev/null @@ -1,348 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP #-} - --- | Carries interesting info for debugging / profiling of the --- graph coloring register allocator. -module RegAlloc.Graph.Stats ( - RegAllocStats (..), - - pprStats, - pprStatsSpills, - pprStatsLifetimes, - pprStatsConflict, - pprStatsLifeConflict, - - countSRMs, addSRM -) where - -#include "nativeGen/NCG.h" - -import qualified GraphColor as Color -import RegAlloc.Liveness -import RegAlloc.Graph.Spill -import RegAlloc.Graph.SpillCost -import RegAlloc.Graph.TrivColorable -import Instruction -import RegClass -import Reg -import TargetReg - -import PprCmm() -import Outputable -import UniqFM -import UniqSet -import State - -import Data.List - - --- | Holds interesting statistics from the register allocator. -data RegAllocStats statics instr - - -- Information about the initial conflict graph. - = RegAllocStatsStart - { -- | Initial code, with liveness. - raLiveCmm :: [LiveCmmDecl statics instr] - - -- | The initial, uncolored graph. - , raGraph :: Color.Graph VirtualReg RegClass RealReg - - -- | Information to help choose which regs to spill. - , raSpillCosts :: SpillCostInfo } - - - -- Information about an intermediate graph. - -- This is one that we couldn't color, so had to insert spill code - -- instruction stream. - | RegAllocStatsSpill - { -- | Code we tried to allocate registers for. - raCode :: [LiveCmmDecl statics instr] - - -- | Partially colored graph. - , raGraph :: Color.Graph VirtualReg RegClass RealReg - - -- | The regs that were coalesced. - , raCoalesced :: UniqFM VirtualReg - - -- | Spiller stats. - , raSpillStats :: SpillStats - - -- | Number of instructions each reg lives for. - , raSpillCosts :: SpillCostInfo - - -- | Code with spill instructions added. - , raSpilled :: [LiveCmmDecl statics instr] } - - - -- a successful coloring - | RegAllocStatsColored - { -- | Code we tried to allocate registers for. - raCode :: [LiveCmmDecl statics instr] - - -- | Uncolored graph. - , raGraph :: Color.Graph VirtualReg RegClass RealReg - - -- | Coalesced and colored graph. - , raGraphColored :: Color.Graph VirtualReg RegClass RealReg - - -- | Regs that were coalesced. - , raCoalesced :: UniqFM VirtualReg - - -- | Code with coalescings applied. - , raCodeCoalesced :: [LiveCmmDecl statics instr] - - -- | Code with vregs replaced by hregs. - , raPatched :: [LiveCmmDecl statics instr] - - -- | Code with unneeded spill\/reloads cleaned out. - , raSpillClean :: [LiveCmmDecl statics instr] - - -- | Final code. - , raFinal :: [NatCmmDecl statics instr] - - -- | Spill\/reload\/reg-reg moves present in this code. - , raSRMs :: (Int, Int, Int) } - - -instance (Outputable statics, Outputable instr) - => Outputable (RegAllocStats statics instr) where - - ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform -> - text "# Start" - $$ text "# Native code with liveness information." - $$ ppr (raLiveCmm s) - $$ text "" - $$ text "# Initial register conflict graph." - $$ Color.dotGraph - (targetRegDotColor platform) - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - (raGraph s) - - - ppr (s@RegAllocStatsSpill{}) = - text "# Spill" - - $$ text "# Code with liveness information." - $$ ppr (raCode s) - $$ text "" - - $$ (if (not $ isNullUFM $ raCoalesced s) - then text "# Registers coalesced." - $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr) - $$ text "" - else empty) - - $$ text "# Spills inserted." - $$ ppr (raSpillStats s) - $$ text "" - - $$ text "# Code with spills inserted." - $$ ppr (raSpilled s) - - - ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) - = sdocWithPlatform $ \platform -> - text "# Colored" - - $$ text "# Code with liveness information." - $$ ppr (raCode s) - $$ text "" - - $$ text "# Register conflict graph (colored)." - $$ Color.dotGraph - (targetRegDotColor platform) - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - (raGraphColored s) - $$ text "" - - $$ (if (not $ isNullUFM $ raCoalesced s) - then text "# Registers coalesced." - $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr) - $$ text "" - else empty) - - $$ text "# Native code after coalescings applied." - $$ ppr (raCodeCoalesced s) - $$ text "" - - $$ text "# Native code after register allocation." - $$ ppr (raPatched s) - $$ text "" - - $$ text "# Clean out unneeded spill/reloads." - $$ ppr (raSpillClean s) - $$ text "" - - $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ ppr (raFinal s) - $$ text "" - $$ text "# Score:" - $$ (text "# spills inserted: " <> int spills) - $$ (text "# reloads inserted: " <> int reloads) - $$ (text "# reg-reg moves remaining: " <> int moves) - $$ text "" - - --- | Do all the different analysis on this list of RegAllocStats -pprStats - :: [RegAllocStats statics instr] - -> Color.Graph VirtualReg RegClass RealReg - -> SDoc - -pprStats stats graph - = let outSpills = pprStatsSpills stats - outLife = pprStatsLifetimes stats - outConflict = pprStatsConflict stats - outScatter = pprStatsLifeConflict stats graph - - in vcat [outSpills, outLife, outConflict, outScatter] - - --- | Dump a table of how many spill loads \/ stores were inserted for each vreg. -pprStatsSpills - :: [RegAllocStats statics instr] -> SDoc - -pprStatsSpills stats - = let - finals = [ s | s@RegAllocStatsColored{} <- stats] - - -- sum up how many stores\/loads\/reg-reg-moves were left in the code - total = foldl' addSRM (0, 0, 0) - $ map raSRMs finals - - in ( text "-- spills-added-total" - $$ text "-- (stores, loads, reg_reg_moves_remaining)" - $$ ppr total - $$ text "") - - --- | Dump a table of how long vregs tend to live for in the initial code. -pprStatsLifetimes - :: [RegAllocStats statics instr] -> SDoc - -pprStatsLifetimes stats - = let info = foldl' plusSpillCostInfo zeroSpillCostInfo - [ raSpillCosts s - | s@RegAllocStatsStart{} <- stats ] - - lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info - - in ( text "-- vreg-population-lifetimes" - $$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)" - $$ pprUFM lifeBins (vcat . map ppr) - $$ text "\n") - - -binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int) -binLifetimeCount fm - = let lifes = map (\l -> (l, (l, 1))) - $ map snd - $ nonDetEltsUFM fm - -- See Note [Unique Determinism and code generation] - - in addListToUFM_C - (\(l1, c1) (_, c2) -> (l1, c1 + c2)) - emptyUFM - lifes - - --- | Dump a table of how many conflicts vregs tend to have in the initial code. -pprStatsConflict - :: [RegAllocStats statics instr] -> SDoc - -pprStatsConflict stats - = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) - emptyUFM - $ map Color.slurpNodeConflictCount - [ raGraph s | s@RegAllocStatsStart{} <- stats ] - - in ( text "-- vreg-conflicts" - $$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)" - $$ pprUFM confMap (vcat . map ppr) - $$ text "\n") - - --- | For every vreg, dump it's how many conflicts it has and its lifetime --- good for making a scatter plot. -pprStatsLifeConflict - :: [RegAllocStats statics instr] - -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph - -> SDoc - -pprStatsLifeConflict stats graph - = let lifeMap = lifeMapFromSpillCostInfo - $ foldl' plusSpillCostInfo zeroSpillCostInfo - $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ] - - scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of - Just (_, l) -> l - Nothing -> 0 - Just node = Color.lookupNode graph r - in parens $ hcat $ punctuate (text ", ") - [ doubleQuotes $ ppr $ Color.nodeId node - , ppr $ sizeUniqSet (Color.nodeConflicts node) - , ppr $ lifetime ]) - $ map Color.nodeId - $ nonDetEltsUFM - -- See Note [Unique Determinism and code generation] - $ Color.graphMap graph - - in ( text "-- vreg-conflict-lifetime" - $$ text "-- (vreg, vreg_conflicts, vreg_lifetime)" - $$ (vcat scatter) - $$ text "\n") - - --- | Count spill/reload/reg-reg moves. --- Lets us see how well the register allocator has done. -countSRMs - :: Instruction instr - => LiveCmmDecl statics instr -> (Int, Int, Int) - -countSRMs cmm - = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) - - -countSRM_block - :: Instruction instr - => GenBasicBlock (LiveInstr instr) - -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr)) - -countSRM_block (BasicBlock i instrs) - = do instrs' <- mapM countSRM_instr instrs - return $ BasicBlock i instrs' - - -countSRM_instr - :: Instruction instr - => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr) - -countSRM_instr li - | LiveInstr SPILL{} _ <- li - = do modify $ \(s, r, m) -> (s + 1, r, m) - return li - - | LiveInstr RELOAD{} _ <- li - = do modify $ \(s, r, m) -> (s, r + 1, m) - return li - - | LiveInstr instr _ <- li - , Just _ <- takeRegRegMoveInstr instr - = do modify $ \(s, r, m) -> (s, r, m + 1) - return li - - | otherwise - = return li - - --- sigh.. -addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int) -addSRM (s1, r1, m1) (s2, r2, m2) - = let !s = s1 + s2 - !r = r1 + r2 - !m = m1 + m2 - in (s, r, m) - diff --git a/nativeGen/RegAlloc/Graph/TrivColorable.hs b/nativeGen/RegAlloc/Graph/TrivColorable.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE CPP #-} - -module RegAlloc.Graph.TrivColorable ( - trivColorable, -) - -where - -#include "HsVersions.h" - -import RegClass -import Reg - -import GraphBase - -import UniqSet -import Platform -import Panic - --- trivColorable --------------------------------------------------------------- - --- trivColorable function for the graph coloring allocator --- --- This gets hammered by scanGraph during register allocation, --- so needs to be fairly efficient. --- --- NOTE: This only works for arcitectures with just RcInteger and RcDouble --- (which are disjoint) ie. x86, x86_64 and ppc --- --- The number of allocatable regs is hard coded in here so we can do --- a fast comparison in trivColorable. --- --- It's ok if these numbers are _less_ than the actual number of free --- regs, but they can't be more or the register conflict --- graph won't color. --- --- If the graph doesn't color then the allocator will panic, but it won't --- generate bad object code or anything nasty like that. --- --- There is an allocatableRegsInClass :: RegClass -> Int, but doing --- the unboxing is too slow for us here. --- TODO: Is that still true? Could we use allocatableRegsInClass --- without losing performance now? --- --- Look at includes/stg/MachRegs.h to get the numbers. --- - - --- Disjoint registers ---------------------------------------------------------- --- --- The definition has been unfolded into individual cases for speed. --- Each architecture has a different register setup, so we use a --- different regSqueeze function for each. --- -accSqueeze - :: Int - -> Int - -> (reg -> Int) - -> UniqSet reg - -> Int - -accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us) - -- See Note [Unique Determinism and code generation] - where acc count [] = count - acc count _ | count >= maxCount = count - acc count (r:rs) = acc (count + squeeze r) rs - -{- Note [accSqueeze] -~~~~~~~~~~~~~~~~~~~~ -BL 2007/09 -Doing a nice fold over the UniqSet makes trivColorable use -32% of total compile time and 42% of total alloc when compiling SHA1.hs from darcs. -Therefore the UniqFM is made non-abstract and we use custom fold. - -MS 2010/04 -When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal -representation any more. But it is imperative that the accSqueeze stops -the folding if the count gets greater or equal to maxCount. We thus convert -UniqFM to a (lazy) list, do the fold and stops if necessary, which was -the most efficient variant tried. Benchmark compiling 10-times SHA1.hs follows. -(original = previous implementation, folding = fold of the whole UFM, - lazyFold = the current implementation, - hackFold = using internal representation of Data.IntMap) - - original folding hackFold lazyFold - -O -fasm (used everywhere) 31.509s 30.387s 30.791s 30.603s - 100.00% 96.44% 97.72% 97.12% - -fregs-graph 67.938s 74.875s 62.673s 64.679s - 100.00% 110.21% 92.25% 95.20% - -fregs-iterative 89.761s 143.913s 81.075s 86.912s - 100.00% 160.33% 90.32% 96.83% - -fnew-codegen 38.225s 37.142s 37.551s 37.119s - 100.00% 97.17% 98.24% 97.11% - -fnew-codegen -fregs-graph 91.786s 91.51s 87.368s 86.88s - 100.00% 99.70% 95.19% 94.65% - -fnew-codegen -fregs-iterative 206.72s 343.632s 194.694s 208.677s - 100.00% 166.23% 94.18% 100.95% --} - -trivColorable - :: Platform - -> (RegClass -> VirtualReg -> Int) - -> (RegClass -> RealReg -> Int) - -> Triv VirtualReg RegClass RealReg - -trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions - | let cALLOCATABLE_REGS_INTEGER - = (case platformArch platform of - ArchX86 -> 3 - ArchX86_64 -> 5 - ArchPPC -> 16 - ArchSPARC -> 14 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" - ArchPPC_64 _ -> 15 - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchARM64 -> panic "trivColorable ArchARM64" - ArchAlpha -> panic "trivColorable ArchAlpha" - ArchMipseb -> panic "trivColorable ArchMipseb" - ArchMipsel -> panic "trivColorable ArchMipsel" - ArchJavaScript-> panic "trivColorable ArchJavaScript" - ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER - (virtualRegSqueeze RcInteger) - conflicts - - , count3 <- accSqueeze count2 cALLOCATABLE_REGS_INTEGER - (realRegSqueeze RcInteger) - exclusions - - = count3 < cALLOCATABLE_REGS_INTEGER - -trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions - | let cALLOCATABLE_REGS_FLOAT - = (case platformArch platform of - ArchX86 -> 0 - ArchX86_64 -> 0 - ArchPPC -> 0 - ArchSPARC -> 22 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" - ArchPPC_64 _ -> 0 - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchARM64 -> panic "trivColorable ArchARM64" - ArchAlpha -> panic "trivColorable ArchAlpha" - ArchMipseb -> panic "trivColorable ArchMipseb" - ArchMipsel -> panic "trivColorable ArchMipsel" - ArchJavaScript-> panic "trivColorable ArchJavaScript" - ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT - (virtualRegSqueeze RcFloat) - conflicts - - , count3 <- accSqueeze count2 cALLOCATABLE_REGS_FLOAT - (realRegSqueeze RcFloat) - exclusions - - = count3 < cALLOCATABLE_REGS_FLOAT - -trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions - | let cALLOCATABLE_REGS_DOUBLE - = (case platformArch platform of - ArchX86 -> 6 - ArchX86_64 -> 0 - ArchPPC -> 26 - ArchSPARC -> 11 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" - ArchPPC_64 _ -> 20 - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchARM64 -> panic "trivColorable ArchARM64" - ArchAlpha -> panic "trivColorable ArchAlpha" - ArchMipseb -> panic "trivColorable ArchMipseb" - ArchMipsel -> panic "trivColorable ArchMipsel" - ArchJavaScript-> panic "trivColorable ArchJavaScript" - ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE - (virtualRegSqueeze RcDouble) - conflicts - - , count3 <- accSqueeze count2 cALLOCATABLE_REGS_DOUBLE - (realRegSqueeze RcDouble) - exclusions - - = count3 < cALLOCATABLE_REGS_DOUBLE - -trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions - | let cALLOCATABLE_REGS_SSE - = (case platformArch platform of - ArchX86 -> 8 - ArchX86_64 -> 10 - ArchPPC -> 0 - ArchSPARC -> 0 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" - ArchPPC_64 _ -> 0 - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchARM64 -> panic "trivColorable ArchARM64" - ArchAlpha -> panic "trivColorable ArchAlpha" - ArchMipseb -> panic "trivColorable ArchMipseb" - ArchMipsel -> panic "trivColorable ArchMipsel" - ArchJavaScript-> panic "trivColorable ArchJavaScript" - ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze 0 cALLOCATABLE_REGS_SSE - (virtualRegSqueeze RcDoubleSSE) - conflicts - - , count3 <- accSqueeze count2 cALLOCATABLE_REGS_SSE - (realRegSqueeze RcDoubleSSE) - exclusions - - = count3 < cALLOCATABLE_REGS_SSE - - --- Specification Code ---------------------------------------------------------- --- --- The trivColorable function for each particular architecture should --- implement the following function, but faster. --- - -{- -trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool -trivColorable classN conflicts exclusions - = let - - acc :: Reg -> (Int, Int) -> (Int, Int) - acc r (cd, cf) - = case regClass r of - RcInteger -> (cd+1, cf) - RcFloat -> (cd, cf+1) - _ -> panic "Regs.trivColorable: reg class not handled" - - tmp = nonDetFoldUFM acc (0, 0) conflicts - (countInt, countFloat) = nonDetFoldUFM acc tmp exclusions - - squeese = worst countInt classN RcInteger - + worst countFloat classN RcFloat - - in squeese < allocatableRegsInClass classN - --- | Worst case displacement --- node N of classN has n neighbors of class C. --- --- We currently only have RcInteger and RcDouble, which don't conflict at all. --- This is a bit boring compared to what's in RegArchX86. --- -worst :: Int -> RegClass -> RegClass -> Int -worst n classN classC - = case classN of - RcInteger - -> case classC of - RcInteger -> min n (allocatableRegsInClass RcInteger) - RcFloat -> 0 - - RcDouble - -> case classC of - RcFloat -> min n (allocatableRegsInClass RcFloat) - RcInteger -> 0 - --- allocatableRegs is allMachRegNos with the fixed-use regs removed. --- i.e., these are the regs for which we are prepared to allow the --- register allocator to attempt to map VRegs to. -allocatableRegs :: [RegNo] -allocatableRegs - = let isFree i = freeReg i - in filter isFree allMachRegNos - - --- | The number of regs in each class. --- We go via top level CAFs to ensure that we're not recomputing --- the length of these lists each time the fn is called. -allocatableRegsInClass :: RegClass -> Int -allocatableRegsInClass cls - = case cls of - RcInteger -> allocatableRegsInteger - RcFloat -> allocatableRegsDouble - -allocatableRegsInteger :: Int -allocatableRegsInteger - = length $ filter (\r -> regClass r == RcInteger) - $ map RealReg allocatableRegs - -allocatableRegsFloat :: Int -allocatableRegsFloat - = length $ filter (\r -> regClass r == RcFloat - $ map RealReg allocatableRegs --} diff --git a/nativeGen/RegAlloc/Linear/Base.hs b/nativeGen/RegAlloc/Linear/Base.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/Base.hs +++ /dev/null @@ -1,132 +0,0 @@ - --- | Put common type definitions here to break recursive module dependencies. - -module RegAlloc.Linear.Base ( - BlockAssignment, - - Loc(..), - regsOfLoc, - - -- for stats - SpillReason(..), - RegAllocStats(..), - - -- the allocator monad - RA_State(..), -) - -where - -import RegAlloc.Linear.StackMap -import RegAlloc.Liveness -import Reg - -import DynFlags -import Outputable -import Unique -import UniqFM -import UniqSupply - - --- | Used to store the register assignment on entry to a basic block. --- We use this to handle join points, where multiple branch instructions --- target a particular label. We have to insert fixup code to make --- the register assignments from the different sources match up. --- -type BlockAssignment freeRegs - = BlockMap (freeRegs, RegMap Loc) - - --- | Where a vreg is currently stored --- A temporary can be marked as living in both a register and memory --- (InBoth), for example if it was recently loaded from a spill location. --- This makes it cheap to spill (no save instruction required), but we --- have to be careful to turn this into InReg if the value in the --- register is changed. - --- This is also useful when a temporary is about to be clobbered. We --- save it in a spill location, but mark it as InBoth because the current --- instruction might still want to read it. --- -data Loc - -- | vreg is in a register - = InReg !RealReg - - -- | vreg is held in a stack slot - | InMem {-# UNPACK #-} !StackSlot - - - -- | vreg is held in both a register and a stack slot - | InBoth !RealReg - {-# UNPACK #-} !StackSlot - deriving (Eq, Show, Ord) - -instance Outputable Loc where - ppr l = text (show l) - - --- | Get the reg numbers stored in this Loc. -regsOfLoc :: Loc -> [RealReg] -regsOfLoc (InReg r) = [r] -regsOfLoc (InBoth r _) = [r] -regsOfLoc (InMem _) = [] - - --- | Reasons why instructions might be inserted by the spiller. --- Used when generating stats for -ddrop-asm-stats. --- -data SpillReason - -- | vreg was spilled to a slot so we could use its - -- current hreg for another vreg - = SpillAlloc !Unique - - -- | vreg was moved because its hreg was clobbered - | SpillClobber !Unique - - -- | vreg was loaded from a spill slot - | SpillLoad !Unique - - -- | reg-reg move inserted during join to targets - | SpillJoinRR !Unique - - -- | reg-mem move inserted during join to targets - | SpillJoinRM !Unique - - --- | Used to carry interesting stats out of the register allocator. -data RegAllocStats - = RegAllocStats - { ra_spillInstrs :: UniqFM [Int] } - - --- | The register allocator state -data RA_State freeRegs - = RA_State - - { - -- | the current mapping from basic blocks to - -- the register assignments at the beginning of that block. - ra_blockassig :: BlockAssignment freeRegs - - -- | free machine registers - , ra_freeregs :: !freeRegs - - -- | assignment of temps to locations - , ra_assig :: RegMap Loc - - -- | current stack delta - , ra_delta :: Int - - -- | free stack slots for spilling - , ra_stack :: StackMap - - -- | unique supply for generating names for join point fixup blocks. - , ra_us :: UniqSupply - - -- | Record why things were spilled, for -ddrop-asm-stats. - -- Just keep a list here instead of a map of regs -> reasons. - -- We don't want to slow down the allocator if we're not going to emit the stats. - , ra_spills :: [SpillReason] - , ra_DynFlags :: DynFlags } - - diff --git a/nativeGen/RegAlloc/Linear/FreeRegs.hs b/nativeGen/RegAlloc/Linear/FreeRegs.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE CPP #-} - -module RegAlloc.Linear.FreeRegs ( - FR(..), - maxSpillSlots -) - -#include "HsVersions.h" - -where - -import Reg -import RegClass - -import DynFlags -import Panic -import Platform - --- ----------------------------------------------------------------------------- --- The free register set --- This needs to be *efficient* --- Here's an inefficient 'executable specification' of the FreeRegs data type: --- --- type FreeRegs = [RegNo] --- noFreeRegs = 0 --- releaseReg n f = if n `elem` f then f else (n : f) --- initFreeRegs = allocatableRegs --- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f --- allocateReg f r = filter (/= r) f - -import qualified RegAlloc.Linear.PPC.FreeRegs as PPC -import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC -import qualified RegAlloc.Linear.X86.FreeRegs as X86 -import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64 - -import qualified PPC.Instr -import qualified SPARC.Instr -import qualified X86.Instr - -class Show freeRegs => FR freeRegs where - frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs - frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg] - frInitFreeRegs :: Platform -> freeRegs - frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs - -instance FR X86.FreeRegs where - frAllocateReg = \_ -> X86.allocateReg - frGetFreeRegs = X86.getFreeRegs - frInitFreeRegs = X86.initFreeRegs - frReleaseReg = \_ -> X86.releaseReg - -instance FR X86_64.FreeRegs where - frAllocateReg = \_ -> X86_64.allocateReg - frGetFreeRegs = X86_64.getFreeRegs - frInitFreeRegs = X86_64.initFreeRegs - frReleaseReg = \_ -> X86_64.releaseReg - -instance FR PPC.FreeRegs where - frAllocateReg = \_ -> PPC.allocateReg - frGetFreeRegs = \_ -> PPC.getFreeRegs - frInitFreeRegs = PPC.initFreeRegs - frReleaseReg = \_ -> PPC.releaseReg - -instance FR SPARC.FreeRegs where - frAllocateReg = SPARC.allocateReg - frGetFreeRegs = \_ -> SPARC.getFreeRegs - frInitFreeRegs = SPARC.initFreeRegs - frReleaseReg = SPARC.releaseReg - -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = case platformArch (targetPlatform dflags) of - ArchX86 -> X86.Instr.maxSpillSlots dflags - ArchX86_64 -> X86.Instr.maxSpillSlots dflags - ArchPPC -> PPC.Instr.maxSpillSlots dflags - ArchSPARC -> SPARC.Instr.maxSpillSlots dflags - ArchSPARC64 -> panic "maxSpillSlots ArchSPARC64" - ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" - ArchARM64 -> panic "maxSpillSlots ArchARM64" - ArchPPC_64 _ -> PPC.Instr.maxSpillSlots dflags - ArchAlpha -> panic "maxSpillSlots ArchAlpha" - ArchMipseb -> panic "maxSpillSlots ArchMipseb" - ArchMipsel -> panic "maxSpillSlots ArchMipsel" - ArchJavaScript-> panic "maxSpillSlots ArchJavaScript" - ArchUnknown -> panic "maxSpillSlots ArchUnknown" - diff --git a/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/nativeGen/RegAlloc/Linear/JoinToTargets.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ /dev/null @@ -1,368 +0,0 @@ - --- | Handles joining of a jump instruction to its targets. - --- The first time we encounter a jump to a particular basic block, we --- record the assignment of temporaries. The next time we encounter a --- jump to the same block, we compare our current assignment to the --- stored one. They might be different if spilling has occurred in one --- branch; so some fixup code will be required to match up the assignments. --- -module RegAlloc.Linear.JoinToTargets (joinToTargets) where - -import RegAlloc.Linear.State -import RegAlloc.Linear.Base -import RegAlloc.Linear.FreeRegs -import RegAlloc.Liveness -import Instruction -import Reg - -import BlockId -import Hoopl -import Digraph -import DynFlags -import Outputable -import Unique -import UniqFM -import UniqSet - -import Data.Foldable (foldl') - --- | For a jump instruction at the end of a block, generate fixup code so its --- vregs are in the correct regs for its destination. --- -joinToTargets - :: (FR freeRegs, Instruction instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs - -- that are known to be live on the entry to each block. - - -> BlockId -- ^ id of the current block - -> instr -- ^ branch instr on the end of the source block. - - -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code. - , instr) -- the original branch - -- instruction, but maybe - -- patched to jump - -- to a fixup block first. - -joinToTargets block_live id instr - - -- we only need to worry about jump instructions. - | not $ isJumpishInstr instr - = return ([], instr) - - | otherwise - = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) - ------ -joinToTargets' - :: (FR freeRegs, Instruction instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs - -- that are known to be live on the entry to each block. - - -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. - - -> BlockId -- ^ id of the current block - -> instr -- ^ branch instr on the end of the source block. - - -> [BlockId] -- ^ branch destinations still to consider. - - -> RegM freeRegs ([NatBasicBlock instr], instr) - --- no more targets to consider. all done. -joinToTargets' _ new_blocks _ instr [] - = return (new_blocks, instr) - --- handle a branch target. -joinToTargets' block_live new_blocks block_id instr (dest:dests) - = do - -- get the map of where the vregs are stored on entry to each basic block. - block_assig <- getBlockAssigR - - -- get the assignment on entry to the branch instruction. - assig <- getAssigR - - -- adjust the current assignment to remove any vregs that are not live - -- on entry to the destination block. - let Just live_set = mapLookup dest block_live - let still_live uniq _ = uniq `elemUniqSet_Directly` live_set - let adjusted_assig = filterUFM_Directly still_live assig - - -- and free up those registers which are now free. - let to_free = - [ r | (reg, loc) <- nonDetUFMToList assig - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - , not (elemUniqSet_Directly reg live_set) - , r <- regsOfLoc loc ] - - case mapLookup dest block_assig of - Nothing - -> joinToTargets_first - block_live new_blocks block_id instr dest dests - block_assig adjusted_assig to_free - - Just (_, dest_assig) - -> joinToTargets_again - block_live new_blocks block_id instr dest dests - adjusted_assig dest_assig - - --- this is the first time we jumped to this block. -joinToTargets_first :: (FR freeRegs, Instruction instr) - => BlockMap RegSet - -> [NatBasicBlock instr] - -> BlockId - -> instr - -> BlockId - -> [BlockId] - -> BlockAssignment freeRegs - -> RegMap Loc - -> [RealReg] - -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_first block_live new_blocks block_id instr dest dests - block_assig src_assig - to_free - - = do dflags <- getDynFlags - let platform = targetPlatform dflags - - -- free up the regs that are not live on entry to this block. - freeregs <- getFreeRegsR - let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free - - -- remember the current assignment on entry to this block. - setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) - - joinToTargets' block_live new_blocks block_id instr dests - - --- we've jumped to this block before -joinToTargets_again :: (Instruction instr, FR freeRegs) - => BlockMap RegSet - -> [NatBasicBlock instr] - -> BlockId - -> instr - -> BlockId - -> [BlockId] - -> UniqFM Loc - -> UniqFM Loc - -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_again - block_live new_blocks block_id instr dest dests - src_assig dest_assig - - -- the assignments already match, no problem. - | nonDetUFMToList dest_assig == nonDetUFMToList src_assig - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - = joinToTargets' block_live new_blocks block_id instr dests - - -- assignments don't match, need fixup code - | otherwise - = do - - -- make a graph of what things need to be moved where. - let graph = makeRegMovementGraph src_assig dest_assig - - -- look for cycles in the graph. This can happen if regs need to be swapped. - -- Note that we depend on the fact that this function does a - -- bottom up traversal of the tree-like portions of the graph. - -- - -- eg, if we have - -- R1 -> R2 -> R3 - -- - -- ie move value in R1 to R2 and value in R2 to R3. - -- - -- We need to do the R2 -> R3 move before R1 -> R2. - -- - let sccs = stronglyConnCompFromEdgedVerticesOrdR graph - -{- -- debugging - pprTrace - ("joinToTargets: making fixup code") - (vcat [ text " in block: " <> ppr block_id - , text " jmp instruction: " <> ppr instr - , text " src assignment: " <> ppr src_assig - , text " dest assignment: " <> ppr dest_assig - , text " movement graph: " <> ppr graph - , text " sccs of graph: " <> ppr sccs - , text ""]) - (return ()) --} - delta <- getDeltaR - fixUpInstrs_ <- mapM (handleComponent delta instr) sccs - let fixUpInstrs = concat fixUpInstrs_ - - -- make a new basic block containing the fixup code. - -- A the end of the current block we will jump to the fixup one, - -- then that will jump to our original destination. - fixup_block_id <- getUniqueR - let block = BasicBlock (mkBlockId fixup_block_id) - $ fixUpInstrs ++ mkJumpInstr dest - -{- pprTrace - ("joinToTargets: fixup code is:") - (vcat [ ppr block - , text ""]) - (return ()) --} - -- if we didn't need any fixups, then don't include the block - case fixUpInstrs of - [] -> joinToTargets' block_live new_blocks block_id instr dests - - -- patch the original branch instruction so it goes to our - -- fixup block instead. - _ -> let instr' = patchJumpInstr instr - (\bid -> if bid == dest - then mkBlockId fixup_block_id - else bid) -- no change! - - in joinToTargets' block_live (block : new_blocks) block_id instr' dests - - --- | Construct a graph of register\/spill movements. --- --- Cyclic components seem to occur only very rarely. --- --- We cut some corners by not handling memory-to-memory moves. --- This shouldn't happen because every temporary gets its own stack slot. --- -makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])] -makeRegMovementGraph adjusted_assig dest_assig - = [ node | (vreg, src) <- nonDetUFMToList adjusted_assig - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - -- source reg might not be needed at the dest: - , Just loc <- [lookupUFM_Directly dest_assig vreg] - , node <- expandNode vreg src loc ] - - --- | Expand out the destination, so InBoth destinations turn into --- a combination of InReg and InMem. - --- The InBoth handling is a little tricky here. If the destination is --- InBoth, then we must ensure that the value ends up in both locations. --- An InBoth destination must conflict with an InReg or InMem source, so --- we expand an InBoth destination as necessary. --- --- An InBoth source is slightly different: we only care about the register --- that the source value is in, so that we can move it to the destinations. --- -expandNode - :: a - -> Loc -- ^ source of move - -> Loc -- ^ destination of move - -> [(a, Loc, [Loc])] - -expandNode vreg loc@(InReg src) (InBoth dst mem) - | src == dst = [(vreg, loc, [InMem mem])] - | otherwise = [(vreg, loc, [InReg dst, InMem mem])] - -expandNode vreg loc@(InMem src) (InBoth dst mem) - | src == mem = [(vreg, loc, [InReg dst])] - | otherwise = [(vreg, loc, [InReg dst, InMem mem])] - -expandNode _ (InBoth _ src) (InMem dst) - | src == dst = [] -- guaranteed to be true - -expandNode _ (InBoth src _) (InReg dst) - | src == dst = [] - -expandNode vreg (InBoth src _) dst - = expandNode vreg (InReg src) dst - -expandNode vreg src dst - | src == dst = [] - | otherwise = [(vreg, src, [dst])] - - --- | Generate fixup code for a particular component in the move graph --- This component tells us what values need to be moved to what --- destinations. We have eliminated any possibility of single-node --- cycles in expandNode above. --- -handleComponent - :: Instruction instr - => Int -> instr -> SCC (Unique, Loc, [Loc]) - -> RegM freeRegs [instr] - --- If the graph is acyclic then we won't get the swapping problem below. --- In this case we can just do the moves directly, and avoid having to --- go via a spill slot. --- -handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) - = mapM (makeMove delta vreg src) dsts - - --- Handle some cyclic moves. --- This can happen if we have two regs that need to be swapped. --- eg: --- vreg source loc dest loc --- (vreg1, InReg r1, [InReg r2]) --- (vreg2, InReg r2, [InReg r1]) --- --- To avoid needing temp register, we just spill all the source regs, then --- reaload them into their destination regs. --- --- Note that we can not have cycles that involve memory locations as --- sources as single destination because memory locations (stack slots) --- are allocated exclusively for a virtual register and therefore can not --- require a fixup. --- -handleComponent delta instr - (CyclicSCC ((vreg, InReg sreg, (InReg dreg: _)) : rest)) - -- dest list may have more than one element, if the reg is also InMem. - = do - -- spill the source into its slot - (instrSpill, slot) - <- spillR (RegReal sreg) vreg - - -- reload into destination reg - instrLoad <- loadR (RegReal dreg) slot - - remainingFixUps <- mapM (handleComponent delta instr) - (stronglyConnCompFromEdgedVerticesOrdR rest) - - -- make sure to do all the reloads after all the spills, - -- so we don't end up clobbering the source values. - return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) - -handleComponent _ _ (CyclicSCC _) - = panic "Register Allocator: handleComponent cyclic" - - --- | Move a vreg between these two locations. --- -makeMove - :: Instruction instr - => Int -- ^ current C stack delta. - -> Unique -- ^ unique of the vreg that we're moving. - -> Loc -- ^ source location. - -> Loc -- ^ destination location. - -> RegM freeRegs instr -- ^ move instruction. - -makeMove delta vreg src dst - = do dflags <- getDynFlags - let platform = targetPlatform dflags - - case (src, dst) of - (InReg s, InReg d) -> - do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d) - (InMem s, InReg d) -> - do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr dflags (RegReal d) delta s - (InReg s, InMem d) -> - do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr dflags (RegReal s) delta d - _ -> - -- we don't handle memory to memory moves. - -- they shouldn't happen because we don't share - -- stack slots between vregs. - panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" - ++ show dst ++ ")" - ++ " we don't handle mem->mem moves.") - diff --git a/nativeGen/RegAlloc/Linear/Main.hs b/nativeGen/RegAlloc/Linear/Main.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/Main.hs +++ /dev/null @@ -1,907 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- --- The register allocator --- --- (c) The University of Glasgow 2004 --- ------------------------------------------------------------------------------ - -{- -The algorithm is roughly: - - 1) Compute strongly connected components of the basic block list. - - 2) Compute liveness (mapping from pseudo register to - point(s) of death?). - - 3) Walk instructions in each basic block. We keep track of - (a) Free real registers (a bitmap?) - (b) Current assignment of temporaries to machine registers and/or - spill slots (call this the "assignment"). - (c) Partial mapping from basic block ids to a virt-to-loc mapping. - When we first encounter a branch to a basic block, - we fill in its entry in this table with the current mapping. - - For each instruction: - (a) For each temporary *read* by the instruction: - If the temporary does not have a real register allocation: - - Allocate a real register from the free list. If - the list is empty: - - Find a temporary to spill. Pick one that is - not used in this instruction (ToDo: not - used for a while...) - - generate a spill instruction - - If the temporary was previously spilled, - generate an instruction to read the temp from its spill loc. - (optimisation: if we can see that a real register is going to - be used soon, then don't use it for allocation). - - (b) For each real register clobbered by this instruction: - If a temporary resides in it, - If the temporary is live after this instruction, - Move the temporary to another (non-clobbered & free) reg, - or spill it to memory. Mark the temporary as residing - in both memory and a register if it was spilled (it might - need to be read by this instruction). - - (ToDo: this is wrong for jump instructions?) - - We do this after step (a), because if we start with - movq v1, %rsi - which is an instruction that clobbers %rsi, if v1 currently resides - in %rsi we want to get - movq %rsi, %freereg - movq %rsi, %rsi -- will disappear - instead of - movq %rsi, %freereg - movq %freereg, %rsi - - (c) Update the current assignment - - (d) If the instruction is a branch: - if the destination block already has a register assignment, - Generate a new block with fixup code and redirect the - jump to the new block. - else, - Update the block id->assignment mapping with the current - assignment. - - (e) Delete all register assignments for temps which are read - (only) and die here. Update the free register list. - - (f) Mark all registers clobbered by this instruction as not free, - and mark temporaries which have been spilled due to clobbering - as in memory (step (a) marks then as in both mem & reg). - - (g) For each temporary *written* by this instruction: - Allocate a real register as for (b), spilling something - else if necessary. - - except when updating the assignment, drop any memory - locations that the temporary was previously in, since - they will be no longer valid after this instruction. - - (h) Delete all register assignments for temps which are - written and die here (there should rarely be any). Update - the free register list. - - (i) Rewrite the instruction with the new mapping. - - (j) For each spilled reg known to be now dead, re-add its stack slot - to the free list. - --} - -module RegAlloc.Linear.Main ( - regAlloc, - module RegAlloc.Linear.Base, - module RegAlloc.Linear.Stats - ) where - -#include "HsVersions.h" - - -import RegAlloc.Linear.State -import RegAlloc.Linear.Base -import RegAlloc.Linear.StackMap -import RegAlloc.Linear.FreeRegs -import RegAlloc.Linear.Stats -import RegAlloc.Linear.JoinToTargets -import qualified RegAlloc.Linear.PPC.FreeRegs as PPC -import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC -import qualified RegAlloc.Linear.X86.FreeRegs as X86 -import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64 -import TargetReg -import RegAlloc.Liveness -import Instruction -import Reg - -import BlockId -import Hoopl -import Cmm hiding (RegSet) - -import Digraph -import DynFlags -import Unique -import UniqSet -import UniqFM -import UniqSupply -import Outputable -import Platform - -import Data.Maybe -import Data.List -import Control.Monad - --- ----------------------------------------------------------------------------- --- Top level of the register allocator - --- Allocate registers -regAlloc - :: (Outputable instr, Instruction instr) - => DynFlags - -> LiveCmmDecl statics instr - -> UniqSM ( NatCmmDecl statics instr - , Maybe Int -- number of extra stack slots required, - -- beyond maxSpillSlots - , Maybe RegAllocStats) - -regAlloc _ (CmmData sec d) - = return - ( CmmData sec d - , Nothing - , Nothing ) - -regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) - = return ( CmmProc info lbl live (ListGraph []) - , Nothing - , Nothing ) - -regAlloc dflags (CmmProc static lbl live sccs) - | LiveInfo info entry_ids@(first_id:_) (Just block_live) _ <- static - = do - -- do register allocation on each component. - (final_blocks, stats, stack_use) - <- linearRegAlloc dflags entry_ids block_live sccs - - -- make sure the block that was first in the input list - -- stays at the front of the output - let ((first':_), rest') - = partition ((== first_id) . blockId) final_blocks - - let max_spill_slots = maxSpillSlots dflags - extra_stack - | stack_use > max_spill_slots - = Just (stack_use - max_spill_slots) - | otherwise - = Nothing - - return ( CmmProc info lbl live (ListGraph (first' : rest')) - , extra_stack - , Just stats) - --- bogus. to make non-exhaustive match warning go away. -regAlloc _ (CmmProc _ _ _ _) - = panic "RegAllocLinear.regAlloc: no match" - - --- ----------------------------------------------------------------------------- --- Linear sweep to allocate registers - - --- | Do register allocation on some basic blocks. --- But be careful to allocate a block in an SCC only if it has --- an entry in the block map or it is the first block. --- -linearRegAlloc - :: (Outputable instr, Instruction instr) - => DynFlags - -> [BlockId] -- ^ entry points - -> BlockMap RegSet - -- ^ live regs on entry to each basic block - -> [SCC (LiveBasicBlock instr)] - -- ^ instructions annotated with "deaths" - -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) - -linearRegAlloc dflags entry_ids block_live sccs - = case platformArch platform of - ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs) - ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs) - ArchSPARC -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs) - ArchSPARC64 -> panic "linearRegAlloc ArchSPARC64" - ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) - ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" - ArchARM64 -> panic "linearRegAlloc ArchARM64" - ArchPPC_64 _ -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) - ArchAlpha -> panic "linearRegAlloc ArchAlpha" - ArchMipseb -> panic "linearRegAlloc ArchMipseb" - ArchMipsel -> panic "linearRegAlloc ArchMipsel" - ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" - ArchUnknown -> panic "linearRegAlloc ArchUnknown" - where - go f = linearRegAlloc' dflags f entry_ids block_live sccs - platform = targetPlatform dflags - -linearRegAlloc' - :: (FR freeRegs, Outputable instr, Instruction instr) - => DynFlags - -> freeRegs - -> [BlockId] -- ^ entry points - -> BlockMap RegSet -- ^ live regs on entry to each basic block - -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" - -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) - -linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs - = do us <- getUniqueSupplyM - let (_, stack, stats, blocks) = - runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us - $ linearRA_SCCs entry_ids block_live [] sccs - return (blocks, stats, getStackUse stack) - - -linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) - => [BlockId] - -> BlockMap RegSet - -> [NatBasicBlock instr] - -> [SCC (LiveBasicBlock instr)] - -> RegM freeRegs [NatBasicBlock instr] - -linearRA_SCCs _ _ blocksAcc [] - = return $ reverse blocksAcc - -linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs) - = do blocks' <- processBlock block_live block - linearRA_SCCs entry_ids block_live - ((reverse blocks') ++ blocksAcc) - sccs - -linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) - = do - blockss' <- process entry_ids block_live blocks [] (return []) False - linearRA_SCCs entry_ids block_live - (reverse (concat blockss') ++ blocksAcc) - sccs - -{- from John Dias's patch 2008/10/16: - The linear-scan allocator sometimes allocates a block - before allocating one of its predecessors, which could lead to - inconsistent allocations. Make it so a block is only allocated - if a predecessor has set the "incoming" assignments for the block, or - if it's the procedure's entry block. - - BL 2009/02: Careful. If the assignment for a block doesn't get set for - some reason then this function will loop. We should probably do some - more sanity checking to guard against this eventuality. --} - -process :: (FR freeRegs, Instruction instr, Outputable instr) - => [BlockId] - -> BlockMap RegSet - -> [GenBasicBlock (LiveInstr instr)] - -> [GenBasicBlock (LiveInstr instr)] - -> [[NatBasicBlock instr]] - -> Bool - -> RegM freeRegs [[NatBasicBlock instr]] - -process _ _ [] [] accum _ - = return $ reverse accum - -process entry_ids block_live [] next_round accum madeProgress - | not madeProgress - - {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. - pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." - ( text "Unreachable blocks:" - $$ vcat (map ppr next_round)) -} - = return $ reverse accum - - | otherwise - = process entry_ids block_live - next_round [] accum False - -process entry_ids block_live (b@(BasicBlock id _) : blocks) - next_round accum madeProgress - = do - block_assig <- getBlockAssigR - - if isJust (mapLookup id block_assig) - || id `elem` entry_ids - then do - b' <- processBlock block_live b - process entry_ids block_live blocks - next_round (b' : accum) True - - else process entry_ids block_live blocks - (b : next_round) accum madeProgress - - --- | Do register allocation on this basic block --- -processBlock - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ live regs on entry to each basic block - -> LiveBasicBlock instr -- ^ block to do register allocation on - -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated - -processBlock block_live (BasicBlock id instrs) - = do initBlock id block_live - (instrs', fixups) - <- linearRA block_live [] [] id instrs - return $ BasicBlock id instrs' : fixups - - --- | Load the freeregs and current reg assignment into the RegM state --- for the basic block with this BlockId. -initBlock :: FR freeRegs - => BlockId -> BlockMap RegSet -> RegM freeRegs () -initBlock id block_live - = do dflags <- getDynFlags - let platform = targetPlatform dflags - block_assig <- getBlockAssigR - case mapLookup id block_assig of - -- no prior info about this block: we must consider - -- any fixed regs to be allocated, but we can ignore - -- virtual regs (presumably this is part of a loop, - -- and we'll iterate again). The assignment begins - -- empty. - Nothing - -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) - case mapLookup id block_live of - Nothing -> - setFreeRegsR (frInitFreeRegs platform) - Just live -> - setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform) - [ r | RegReal r <- nonDetEltsUniqSet live ] - -- See Note [Unique Determinism and code generation] - setAssigR emptyRegMap - - -- load info about register assignments leading into this block. - Just (freeregs, assig) - -> do setFreeRegsR freeregs - setAssigR assig - - --- | Do allocation for a sequence of instructions. -linearRA - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. - -> [instr] -- ^ accumulator for instructions already processed. - -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. - -> BlockId -- ^ id of the current block, for debugging. - -> [LiveInstr instr] -- ^ liveness annotated instructions in this block. - - -> RegM freeRegs - ( [instr] -- instructions after register allocation - , [NatBasicBlock instr]) -- fresh blocks of fixup code. - - -linearRA _ accInstr accFixup _ [] - = return - ( reverse accInstr -- instrs need to be returned in the correct order. - , accFixup) -- it doesn't matter what order the fixup blocks are returned in. - - -linearRA block_live accInstr accFixups id (instr:instrs) - = do - (accInstr', new_fixups) <- raInsn block_live accInstr id instr - - linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs - - --- | Do allocation for a single instruction. -raInsn - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. - -> [instr] -- ^ accumulator for instructions already processed. - -> BlockId -- ^ the id of the current block, for debugging - -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. - -> RegM freeRegs - ( [instr] -- new instructions - , [NatBasicBlock instr]) -- extra fixup blocks - -raInsn _ new_instrs _ (LiveInstr ii Nothing) - | Just n <- takeDeltaInstr ii - = do setDeltaR n - return (new_instrs, []) - -raInsn _ new_instrs _ (LiveInstr ii@(Instr i) Nothing) - | isMetaInstr ii - = return (i : new_instrs, []) - - -raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) - = do - assig <- getAssigR - - -- If we have a reg->reg move between virtual registers, where the - -- src register is not live after this instruction, and the dst - -- register does not already have an assignment, - -- and the source register is assigned to a register, not to a spill slot, - -- then we can eliminate the instruction. - -- (we can't eliminate it if the source register is on the stack, because - -- we do not want to use one spill slot for different virtual registers) - case takeRegRegMoveInstr instr of - Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), - isVirtualReg dst, - not (dst `elemUFM` assig), - isRealReg src || isInReg src assig -> do - case src of - (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr)) - -- if src is a fixed reg, then we just map dest to this - -- reg in the assignment. src must be an allocatable reg, - -- otherwise it wouldn't be in r_dying. - _virt -> case lookupUFM assig src of - Nothing -> panic "raInsn" - Just loc -> - setAssigR (addToUFM (delFromUFM assig src) dst loc) - - -- we have eliminated this instruction - {- - freeregs <- getFreeRegsR - assig <- getAssigR - pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) - $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do - -} - return (new_instrs, []) - - _ -> genRaInsn block_live new_instrs id instr - (nonDetEltsUniqSet $ liveDieRead live) - (nonDetEltsUniqSet $ liveDieWrite live) - -- See Note [Unique Determinism and code generation] - -raInsn _ _ _ instr - = pprPanic "raInsn" (text "no match for:" <> ppr instr) - --- ToDo: what can we do about --- --- R1 = x --- jump I64[x] // [R1] --- --- where x is mapped to the same reg as R1. We want to coalesce x and --- R1, but the register allocator doesn't know whether x will be --- assigned to again later, in which case x and R1 should be in --- different registers. Right now we assume the worst, and the --- assignment to R1 will clobber x, so we'll spill x into another reg, --- generating another reg->reg move. - - -isInReg :: Reg -> RegMap Loc -> Bool -isInReg src assig | Just (InReg _) <- lookupUFM assig src = True - | otherwise = False - - -genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockMap RegSet - -> [instr] - -> BlockId - -> instr - -> [Reg] - -> [Reg] - -> RegM freeRegs ([instr], [NatBasicBlock instr]) - -genRaInsn block_live new_instrs block_id instr r_dying w_dying = do - dflags <- getDynFlags - let platform = targetPlatform dflags - case regUsageOfInstr platform instr of { RU read written -> - do - let real_written = [ rr | (RegReal rr) <- written ] - let virt_written = [ vr | (RegVirtual vr) <- written ] - - -- we don't need to do anything with real registers that are - -- only read by this instr. (the list is typically ~2 elements, - -- so using nub isn't a problem). - let virt_read = nub [ vr | (RegVirtual vr) <- read ] - - -- debugging -{- freeregs <- getFreeRegsR - assig <- getAssigR - pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform }) trace "genRaInsn" - (ppr instr - $$ text "r_dying = " <+> ppr r_dying - $$ text "w_dying = " <+> ppr w_dying - $$ text "virt_read = " <+> ppr virt_read - $$ text "virt_written = " <+> ppr virt_written - $$ text "freeregs = " <+> text (show freeregs) - $$ text "assig = " <+> ppr assig) - $ do --} - - -- (a), (b) allocate real regs for all regs read by this instruction. - (r_spills, r_allocd) <- - allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read - - -- (c) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps real_written r_dying - - -- (d) Update block map for new destinations - -- NB. do this before removing dead regs from the assignment, because - -- these dead regs might in fact be live in the jump targets (they're - -- only dead in the code that follows in the current basic block). - (fixup_blocks, adjusted_instr) - <- joinToTargets block_live block_id instr - - -- (e) Delete all register assignments for temps which are read - -- (only) and die here. Update the free register list. - releaseRegs r_dying - - -- (f) Mark regs which are clobbered as unallocatable - clobberRegs real_written - - -- (g) Allocate registers for temporaries *written* (only) - (w_spills, w_allocd) <- - allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written - - -- (h) Release registers for temps which are written here and not - -- used again. - releaseRegs w_dying - - let - -- (i) Patch the instruction - patch_map - = listToUFM - [ (t, RegReal r) - | (t, r) <- zip virt_read r_allocd - ++ zip virt_written w_allocd ] - - patched_instr - = patchRegsOfInstr adjusted_instr patchLookup - - patchLookup x - = case lookupUFM patch_map x of - Nothing -> x - Just y -> y - - - -- (j) free up stack slots for dead spilled regs - -- TODO (can't be bothered right now) - - -- erase reg->reg moves where the source and destination are the same. - -- If the src temp didn't die in this instr but happened to be allocated - -- to the same real reg as the destination, then we can erase the move anyway. - let squashed_instr = case takeRegRegMoveInstr patched_instr of - Just (src, dst) - | src == dst -> [] - _ -> [patched_instr] - - let code = squashed_instr ++ w_spills ++ reverse r_spills - ++ clobber_saves ++ new_instrs - --- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do --- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do - - return (code, fixup_blocks) - - } - --- ----------------------------------------------------------------------------- --- releaseRegs - -releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () -releaseRegs regs = do - dflags <- getDynFlags - let platform = targetPlatform dflags - assig <- getAssigR - free <- getFreeRegsR - let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return () - loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs - loop assig !free (r:rs) = - case lookupUFM assig r of - Just (InBoth real _) -> loop (delFromUFM assig r) - (frReleaseReg platform real free) rs - Just (InReg real) -> loop (delFromUFM assig r) - (frReleaseReg platform real free) rs - _ -> loop (delFromUFM assig r) free rs - loop assig free regs - - --- ----------------------------------------------------------------------------- --- Clobber real registers - --- For each temp in a register that is going to be clobbered: --- - if the temp dies after this instruction, do nothing --- - otherwise, put it somewhere safe (another reg if possible, --- otherwise spill and record InBoth in the assignment). --- - for allocateRegs on the temps *read*, --- - clobbered regs are allocatable. --- --- for allocateRegs on the temps *written*, --- - clobbered regs are not allocatable. --- - -saveClobberedTemps - :: (Instruction instr, FR freeRegs) - => [RealReg] -- real registers clobbered by this instruction - -> [Reg] -- registers which are no longer live after this insn - -> RegM freeRegs [instr] -- return: instructions to spill any temps that will - -- be clobbered. - -saveClobberedTemps [] _ - = return [] - -saveClobberedTemps clobbered dying - = do - assig <- getAssigR - let to_spill - = [ (temp,reg) - | (temp, InReg reg) <- nonDetUFMToList assig - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - , any (realRegsAlias reg) clobbered - , temp `notElem` map getUnique dying ] - - (instrs,assig') <- clobber assig [] to_spill - setAssigR assig' - return instrs - - where - clobber assig instrs [] - = return (instrs, assig) - - clobber assig instrs ((temp, reg) : rest) - = do dflags <- getDynFlags - let platform = targetPlatform dflags - - freeRegs <- getFreeRegsR - let regclass = targetClassOfRealReg platform reg - freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs - - case filter (`notElem` clobbered) freeRegs_thisClass of - - -- (1) we have a free reg of the right class that isn't - -- clobbered by this instruction; use it to save the - -- clobbered value. - (my_reg : _) -> do - setFreeRegsR (frAllocateReg platform my_reg freeRegs) - - let new_assign = addToUFM assig temp (InReg my_reg) - let instr = mkRegRegMoveInstr platform - (RegReal reg) (RegReal my_reg) - - clobber new_assign (instr : instrs) rest - - -- (2) no free registers: spill the value - [] -> do - (spill, slot) <- spillR (RegReal reg) temp - - -- record why this reg was spilled for profiling - recordSpill (SpillClobber temp) - - let new_assign = addToUFM assig temp (InBoth reg slot) - - clobber new_assign (spill : instrs) rest - - - --- | Mark all these real regs as allocated, --- and kick out their vreg assignments. --- -clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs () -clobberRegs [] - = return () - -clobberRegs clobbered - = do dflags <- getDynFlags - let platform = targetPlatform dflags - - freeregs <- getFreeRegsR - setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered - - assig <- getAssigR - setAssigR $! clobber assig (nonDetUFMToList assig) - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - where - -- if the temp was InReg and clobbered, then we will have - -- saved it in saveClobberedTemps above. So the only case - -- we have to worry about here is InBoth. Note that this - -- also catches temps which were loaded up during allocation - -- of read registers, not just those saved in saveClobberedTemps. - - clobber assig [] - = assig - - clobber assig ((temp, InBoth reg slot) : rest) - | any (realRegsAlias reg) clobbered - = clobber (addToUFM assig temp (InMem slot)) rest - - clobber assig (_:rest) - = clobber assig rest - --- ----------------------------------------------------------------------------- --- allocateRegsAndSpill - --- Why are we performing a spill? -data SpillLoc = ReadMem StackSlot -- reading from register only in memory - | WriteNew -- writing to a new variable - | WriteMem -- writing to register only in memory --- Note that ReadNew is not valid, since you don't want to be reading --- from an uninitialized register. We also don't need the location of --- the register in memory, since that will be invalidated by the write. --- Technically, we could coalesce WriteNew and WriteMem into a single --- entry as well. -- EZY - --- This function does several things: --- For each temporary referred to by this instruction, --- we allocate a real register (spilling another temporary if necessary). --- We load the temporary up from memory if necessary. --- We also update the register assignment in the process, and --- the list of free registers and free stack slots. - -allocateRegsAndSpill - :: (FR freeRegs, Outputable instr, Instruction instr) - => Bool -- True <=> reading (load up spilled regs) - -> [VirtualReg] -- don't push these out - -> [instr] -- spill insns - -> [RealReg] -- real registers allocated (accum.) - -> [VirtualReg] -- temps to allocate - -> RegM freeRegs ( [instr] , [RealReg]) - -allocateRegsAndSpill _ _ spills alloc [] - = return (spills, reverse alloc) - -allocateRegsAndSpill reading keep spills alloc (r:rs) - = do assig <- getAssigR - let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig - case lookupUFM assig r of - -- case (1a): already in a register - Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignment to be - -- InReg, because the memory value is no longer valid. - -- NB2. This is why we must process written registers here, even if they - -- are also read by the same instruction. - Just (InBoth my_reg _) - -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- Not already in a register, so we need to find a free one... - Just (InMem slot) | reading -> doSpill (ReadMem slot) - | otherwise -> doSpill WriteMem - Nothing | reading -> - pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) - -- NOTE: if the input to the NCG contains some - -- unreachable blocks with junk code, this panic - -- might be triggered. Make sure you only feed - -- sensible code into the NCG. In CmmPipeline we - -- call removeUnreachableBlocks at the end for this - -- reason. - - | otherwise -> doSpill WriteNew - - --- reading is redundant with reason, but we keep it around because it's --- convenient and it maintains the recursive structure of the allocator. -- EZY -allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) - => Bool - -> [VirtualReg] - -> [instr] - -> [RealReg] - -> VirtualReg - -> [VirtualReg] - -> UniqFM Loc - -> SpillLoc - -> RegM freeRegs ([instr], [RealReg]) -allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc - = do dflags <- getDynFlags - let platform = targetPlatform dflags - freeRegs <- getFreeRegsR - let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs - - case freeRegs_thisClass of - - -- case (2): we have a free register - (my_reg : _) -> - do spills' <- loadTemp r spill_loc my_reg spills - - setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) - setFreeRegsR $ frAllocateReg platform my_reg freeRegs - - allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs - - - -- case (3): we need to push something out to free up a register - [] -> - do let keep' = map getUnique keep - - -- the vregs we could kick out that are already in a slot - let candidates_inBoth - = [ (temp, reg, mem) - | (temp, InBoth reg mem) <- nonDetUFMToList assig - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - , temp `notElem` keep' - , targetClassOfRealReg platform reg == classOfVirtualReg r ] - - -- the vregs we could kick out that are only in a reg - -- this would require writing the reg to a new slot before using it. - let candidates_inReg - = [ (temp, reg) - | (temp, InReg reg) <- nonDetUFMToList assig - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - , temp `notElem` keep' - , targetClassOfRealReg platform reg == classOfVirtualReg r ] - - let result - - -- we have a temporary that is in both register and mem, - -- just free up its register for use. - | (temp, my_reg, slot) : _ <- candidates_inBoth - = do spills' <- loadTemp r spill_loc my_reg spills - let assig1 = addToUFM assig temp (InMem slot) - let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg - - setAssigR assig2 - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs - - -- otherwise, we need to spill a temporary that currently - -- resides in a register. - | (temp_to_push_out, (my_reg :: RealReg)) : _ - <- candidates_inReg - = do - (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out - let spill_store = (if reading then id else reverse) - [ -- COMMENT (fsLit "spill alloc") - spill_insn ] - - -- record that this temp was spilled - recordSpill (SpillAlloc temp_to_push_out) - - -- update the register assignment - let assig1 = addToUFM assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg - setAssigR assig2 - - -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp r spill_loc my_reg spills - - allocateRegsAndSpill reading keep - (spill_store ++ spills') - (my_reg:alloc) rs - - - -- there wasn't anything to spill, so we're screwed. - | otherwise - = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n") - $ vcat - [ text "allocating vreg: " <> text (show r) - , text "assignment: " <> ppr assig - , text "freeRegs: " <> text (show freeRegs) - , text "initFreeRegs: " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ] - - result - - --- | Calculate a new location after a register has been loaded. -newLocation :: SpillLoc -> RealReg -> Loc --- if the tmp was read from a slot, then now its in a reg as well -newLocation (ReadMem slot) my_reg = InBoth my_reg slot --- writes will always result in only the register being available -newLocation _ my_reg = InReg my_reg - --- | Load up a spilled temporary if we need to (read from memory). -loadTemp - :: (Instruction instr) - => VirtualReg -- the temp being loaded - -> SpillLoc -- the current location of this temp - -> RealReg -- the hreg to load the temp into - -> [instr] - -> RegM freeRegs [instr] - -loadTemp vreg (ReadMem slot) hreg spills - = do - insn <- loadR (RegReal hreg) slot - recordSpill (SpillLoad $ getUnique vreg) - return $ {- COMMENT (fsLit "spill load") : -} insn : spills - -loadTemp _ _ _ spills = - return spills - diff --git a/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs +++ /dev/null @@ -1,60 +0,0 @@ --- | Free regs map for PowerPC -module RegAlloc.Linear.PPC.FreeRegs -where - -import PPC.Regs -import RegClass -import Reg - -import Outputable -import Platform - -import Data.Word -import Data.Bits -import Data.Foldable (foldl') - --- The PowerPC has 32 integer and 32 floating point registers. --- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much --- better. --- Note that when getFreeRegs scans for free registers, it starts at register --- 31 and counts down. This is a hack for the PowerPC - the higher-numbered --- registers are callee-saves, while the lower regs are caller-saves, so it --- makes sense to start at the high end. --- Apart from that, the code does nothing PowerPC-specific, so feel free to --- add your favourite platform to the #if (if you have 64 registers but only --- 32-bit words). - -data FreeRegs = FreeRegs !Word32 !Word32 - deriving( Show ) -- The Show is used in an ASSERT - -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 0 - -releaseReg :: RealReg -> FreeRegs -> FreeRegs -releaseReg (RealRegSingle r) (FreeRegs g f) - | r > 31 = FreeRegs g (f .|. (1 `shiftL` (r - 32))) - | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f - -releaseReg _ _ - = panic "RegAlloc.Linear.PPC.releaseReg: bad reg" - -initFreeRegs :: Platform -> FreeRegs -initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) - -getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs cls (FreeRegs g f) - | RcDouble <- cls = go f (0x80000000) 63 - | RcInteger <- cls = go g (0x80000000) 31 - | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls) - where - go _ 0 _ = [] - go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1) - | otherwise = go x (m `shiftR` 1) $! i-1 - -allocateReg :: RealReg -> FreeRegs -> FreeRegs -allocateReg (RealRegSingle r) (FreeRegs g f) - | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (r - 32))) - | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f - -allocateReg _ _ - = panic "RegAlloc.Linear.PPC.allocateReg: bad reg" diff --git a/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs +++ /dev/null @@ -1,186 +0,0 @@ - --- | Free regs map for SPARC -module RegAlloc.Linear.SPARC.FreeRegs -where - -import SPARC.Regs -import RegClass -import Reg - -import CodeGen.Platform -import Outputable -import Platform - -import Data.Word -import Data.Bits -import Data.Foldable (foldl') - - --------------------------------------------------------------------------------- --- SPARC is like PPC, except for twinning of floating point regs. --- When we allocate a double reg we must take an even numbered --- float reg, as well as the one after it. - - --- Holds bitmaps showing what registers are currently allocated. --- The float and double reg bitmaps overlap, but we only alloc --- float regs into the float map, and double regs into the double map. --- --- Free regs have a bit set in the corresponding bitmap. --- -data FreeRegs - = FreeRegs - !Word32 -- int reg bitmap regs 0..31 - !Word32 -- float reg bitmap regs 32..63 - !Word32 -- double reg bitmap regs 32..63 - -instance Show FreeRegs where - show = showFreeRegs - --- | A reg map where no regs are free to be allocated. -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 0 0 - - --- | The initial set of free regs. -initFreeRegs :: Platform -> FreeRegs -initFreeRegs platform - = foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs - - --- | Get all the free registers of this class. -getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs cls (FreeRegs g f d) - | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0 - | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32 - | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32 - | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls) - where - go _ _ 0 _ - = [] - - go step bitmap mask ix - | bitmap .&. mask /= 0 - = ix : (go step bitmap (mask `shiftL` step) $! ix + step) - - | otherwise - = go step bitmap (mask `shiftL` step) $! ix + step - - --- | Grab a register. -allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs -allocateReg platform - reg@(RealRegSingle r) - (FreeRegs g f d) - - -- can't allocate free regs - | not $ freeReg platform r - = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg) - - -- a general purpose reg - | r <= 31 - = let mask = complement (bitMask r) - in FreeRegs - (g .&. mask) - f - d - - -- a float reg - | r >= 32, r <= 63 - = let mask = complement (bitMask (r - 32)) - - -- the mask of the double this FP reg aliases - maskLow = if r `mod` 2 == 0 - then complement (bitMask (r - 32)) - else complement (bitMask (r - 32 - 1)) - in FreeRegs - g - (f .&. mask) - (d .&. maskLow) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) - -allocateReg _ - reg@(RealRegPair r1 r2) - (FreeRegs g f d) - - | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 - , r2 >= 32, r2 <= 63 - = let mask1 = complement (bitMask (r1 - 32)) - mask2 = complement (bitMask (r2 - 32)) - in - FreeRegs - g - ((f .&. mask1) .&. mask2) - (d .&. mask1) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) - - - --- | Release a register from allocation. --- The register liveness information says that most regs die after a C call, --- but we still don't want to allocate to some of them. --- -releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs -releaseReg platform - reg@(RealRegSingle r) - regs@(FreeRegs g f d) - - -- don't release pinned reg - | not $ freeReg platform r - = regs - - -- a general purpose reg - | r <= 31 - = let mask = bitMask r - in FreeRegs (g .|. mask) f d - - -- a float reg - | r >= 32, r <= 63 - = let mask = bitMask (r - 32) - - -- the mask of the double this FP reg aliases - maskLow = if r `mod` 2 == 0 - then bitMask (r - 32) - else bitMask (r - 32 - 1) - in FreeRegs - g - (f .|. mask) - (d .|. maskLow) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) - -releaseReg _ - reg@(RealRegPair r1 r2) - (FreeRegs g f d) - - | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 - , r2 >= 32, r2 <= 63 - = let mask1 = bitMask (r1 - 32) - mask2 = bitMask (r2 - 32) - in - FreeRegs - g - ((f .|. mask1) .|. mask2) - (d .|. mask1) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) - - - -bitMask :: Int -> Word32 -bitMask n = 1 `shiftL` n - - -showFreeRegs :: FreeRegs -> String -showFreeRegs regs - = "FreeRegs\n" - ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n" - ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n" - ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n" - diff --git a/nativeGen/RegAlloc/Linear/StackMap.hs b/nativeGen/RegAlloc/Linear/StackMap.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/StackMap.hs +++ /dev/null @@ -1,59 +0,0 @@ - --- | The assignment of virtual registers to stack slots - --- We have lots of stack slots. Memory-to-memory moves are a pain on most --- architectures. Therefore, we avoid having to generate memory-to-memory moves --- by simply giving every virtual register its own stack slot. - --- The StackMap stack map keeps track of virtual register - stack slot --- associations and of which stack slots are still free. Once it has been --- associated, a stack slot is never "freed" or removed from the StackMap again, --- it remains associated until we are done with the current CmmProc. --- -module RegAlloc.Linear.StackMap ( - StackSlot, - StackMap(..), - emptyStackMap, - getStackSlotFor, - getStackUse -) - -where - -import DynFlags -import UniqFM -import Unique - - --- | Identifier for a stack slot. -type StackSlot = Int - -data StackMap - = StackMap - { -- | The slots that are still available to be allocated. - stackMapNextFreeSlot :: !Int - - -- | Assignment of vregs to stack slots. - , stackMapAssignment :: UniqFM StackSlot } - - --- | An empty stack map, with all slots available. -emptyStackMap :: DynFlags -> StackMap -emptyStackMap _ = StackMap 0 emptyUFM - - --- | If this vreg unique already has a stack assignment then return the slot number, --- otherwise allocate a new slot, and update the map. --- -getStackSlotFor :: StackMap -> Unique -> (StackMap, Int) - -getStackSlotFor fs@(StackMap _ reserved) reg - | Just slot <- lookupUFM reserved reg = (fs, slot) - -getStackSlotFor (StackMap freeSlot reserved) reg = - (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot) - --- | Return the number of stack slots that were allocated -getStackUse :: StackMap -> Int -getStackUse (StackMap freeSlot _) = freeSlot - diff --git a/nativeGen/RegAlloc/Linear/State.hs b/nativeGen/RegAlloc/Linear/State.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/State.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE UnboxedTuples #-} - --- | State monad for the linear register allocator. - --- Here we keep all the state that the register allocator keeps track --- of as it walks the instructions in a basic block. - -module RegAlloc.Linear.State ( - RA_State(..), - RegM, - runR, - - spillR, - loadR, - - getFreeRegsR, - setFreeRegsR, - - getAssigR, - setAssigR, - - getBlockAssigR, - setBlockAssigR, - - setDeltaR, - getDeltaR, - - getUniqueR, - - recordSpill -) -where - -import RegAlloc.Linear.Stats -import RegAlloc.Linear.StackMap -import RegAlloc.Linear.Base -import RegAlloc.Liveness -import Instruction -import Reg - -import DynFlags -import Unique -import UniqSupply - -import Control.Monad (liftM, ap) - --- | The register allocator monad type. -newtype RegM freeRegs a - = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) } - -instance Functor (RegM freeRegs) where - fmap = liftM - -instance Applicative (RegM freeRegs) where - pure a = RegM $ \s -> (# s, a #) - (<*>) = ap - -instance Monad (RegM freeRegs) where - m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s } - -instance HasDynFlags (RegM a) where - getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #) - - --- | Run a computation in the RegM register allocator monad. -runR :: DynFlags - -> BlockAssignment freeRegs - -> freeRegs - -> RegMap Loc - -> StackMap - -> UniqSupply - -> RegM freeRegs a - -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a) - -runR dflags block_assig freeregs assig stack us thing = - case unReg thing - (RA_State - { ra_blockassig = block_assig - , ra_freeregs = freeregs - , ra_assig = assig - , ra_delta = 0{-???-} - , ra_stack = stack - , ra_us = us - , ra_spills = [] - , ra_DynFlags = dflags }) - of - (# state'@RA_State - { ra_blockassig = block_assig - , ra_stack = stack' } - , returned_thing #) - - -> (block_assig, stack', makeRAStats state', returned_thing) - - --- | Make register allocator stats from its final state. -makeRAStats :: RA_State freeRegs -> RegAllocStats -makeRAStats state - = RegAllocStats - { ra_spillInstrs = binSpillReasons (ra_spills state) } - - -spillR :: Instruction instr - => Reg -> Unique -> RegM freeRegs (instr, Int) - -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> - let dflags = ra_DynFlags s - (stack',slot) = getStackSlotFor stack temp - instr = mkSpillInstr dflags reg delta slot - in - (# s{ra_stack=stack'}, (instr,slot) #) - - -loadR :: Instruction instr - => Reg -> Int -> RegM freeRegs instr - -loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> - let dflags = ra_DynFlags s - in (# s, mkLoadInstr dflags reg delta slot #) - -getFreeRegsR :: RegM freeRegs freeRegs -getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> - (# s, freeregs #) - -setFreeRegsR :: freeRegs -> RegM freeRegs () -setFreeRegsR regs = RegM $ \ s -> - (# s{ra_freeregs = regs}, () #) - -getAssigR :: RegM freeRegs (RegMap Loc) -getAssigR = RegM $ \ s@RA_State{ra_assig = assig} -> - (# s, assig #) - -setAssigR :: RegMap Loc -> RegM freeRegs () -setAssigR assig = RegM $ \ s -> - (# s{ra_assig=assig}, () #) - -getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) -getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} -> - (# s, assig #) - -setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs () -setBlockAssigR assig = RegM $ \ s -> - (# s{ra_blockassig = assig}, () #) - -setDeltaR :: Int -> RegM freeRegs () -setDeltaR n = RegM $ \ s -> - (# s{ra_delta = n}, () #) - -getDeltaR :: RegM freeRegs Int -getDeltaR = RegM $ \s -> (# s, ra_delta s #) - -getUniqueR :: RegM freeRegs Unique -getUniqueR = RegM $ \s -> - case takeUniqFromSupply (ra_us s) of - (uniq, us) -> (# s{ra_us = us}, uniq #) - - --- | Record that a spill instruction was inserted, for profiling. -recordSpill :: SpillReason -> RegM freeRegs () -recordSpill spill - = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #) - diff --git a/nativeGen/RegAlloc/Linear/Stats.hs b/nativeGen/RegAlloc/Linear/Stats.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/Stats.hs +++ /dev/null @@ -1,86 +0,0 @@ -module RegAlloc.Linear.Stats ( - binSpillReasons, - countRegRegMovesNat, - pprStats -) - -where - -import RegAlloc.Linear.Base -import RegAlloc.Liveness -import Instruction - -import UniqFM -import Outputable - -import Data.List -import State - --- | Build a map of how many times each reg was alloced, clobbered, loaded etc. -binSpillReasons - :: [SpillReason] -> UniqFM [Int] - -binSpillReasons reasons - = addListToUFM_C - (zipWith (+)) - emptyUFM - (map (\reason -> case reason of - SpillAlloc r -> (r, [1, 0, 0, 0, 0]) - SpillClobber r -> (r, [0, 1, 0, 0, 0]) - SpillLoad r -> (r, [0, 0, 1, 0, 0]) - SpillJoinRR r -> (r, [0, 0, 0, 1, 0]) - SpillJoinRM r -> (r, [0, 0, 0, 0, 1])) reasons) - - --- | Count reg-reg moves remaining in this code. -countRegRegMovesNat - :: Instruction instr - => NatCmmDecl statics instr -> Int - -countRegRegMovesNat cmm - = execState (mapGenBlockTopM countBlock cmm) 0 - where - countBlock b@(BasicBlock _ instrs) - = do mapM_ countInstr instrs - return b - - countInstr instr - | Just _ <- takeRegRegMoveInstr instr - = do modify (+ 1) - return instr - - | otherwise - = return instr - - --- | Pretty print some RegAllocStats -pprStats - :: Instruction instr - => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc - -pprStats code statss - = let -- sum up all the instrs inserted by the spiller - spills = foldl' (plusUFM_C (zipWith (+))) - emptyUFM - $ map ra_spillInstrs statss - - spillTotals = foldl' (zipWith (+)) - [0, 0, 0, 0, 0] - $ nonDetEltsUFM spills - -- See Note [Unique Determinism and code generation] - - -- count how many reg-reg-moves remain in the code - moves = sum $ map countRegRegMovesNat code - - pprSpill (reg, spills) - = parens $ (hcat $ punctuate (text ", ") (doubleQuotes (ppr reg) : map ppr spills)) - - in ( text "-- spills-added-total" - $$ text "-- (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)" - $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves]))) - $$ text "" - $$ text "-- spills-added" - $$ text "-- (reg_name, allocs, clobbers, loads, joinRR, joinRM)" - $$ (pprUFMWithKeys spills (vcat . map pprSpill)) - $$ text "") - diff --git a/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs +++ /dev/null @@ -1,52 +0,0 @@ - --- | Free regs map for i386 -module RegAlloc.Linear.X86.FreeRegs -where - -import X86.Regs -import RegClass -import Reg -import Panic -import Platform - -import Data.Word -import Data.Bits -import Data.Foldable (foldl') - -newtype FreeRegs = FreeRegs Word32 - deriving Show - -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 - -releaseReg :: RealReg -> FreeRegs -> FreeRegs -releaseReg (RealRegSingle n) (FreeRegs f) - = FreeRegs (f .|. (1 `shiftL` n)) - -releaseReg _ _ - = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg" - -initFreeRegs :: Platform -> FreeRegs -initFreeRegs platform - = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) - -getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs platform cls (FreeRegs f) = go f 0 - - where go 0 _ = [] - go n m - | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls - = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) - - | otherwise - = go (n `shiftR` 1) $! (m+1) - -- ToDo: there's no point looking through all the integer registers - -- in order to find a floating-point one. - -allocateReg :: RealReg -> FreeRegs -> FreeRegs -allocateReg (RealRegSingle r) (FreeRegs f) - = FreeRegs (f .&. complement (1 `shiftL` r)) - -allocateReg _ _ - = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg" - diff --git a/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs b/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs +++ /dev/null @@ -1,53 +0,0 @@ - --- | Free regs map for x86_64 -module RegAlloc.Linear.X86_64.FreeRegs -where - -import X86.Regs -import RegClass -import Reg -import Panic -import Platform - -import Data.Foldable (foldl') -import Data.Word -import Data.Bits - -newtype FreeRegs = FreeRegs Word64 - deriving Show - -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 - -releaseReg :: RealReg -> FreeRegs -> FreeRegs -releaseReg (RealRegSingle n) (FreeRegs f) - = FreeRegs (f .|. (1 `shiftL` n)) - -releaseReg _ _ - = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg" - -initFreeRegs :: Platform -> FreeRegs -initFreeRegs platform - = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) - -getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs platform cls (FreeRegs f) = go f 0 - - where go 0 _ = [] - go n m - | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls - = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) - - | otherwise - = go (n `shiftR` 1) $! (m+1) - -- ToDo: there's no point looking through all the integer registers - -- in order to find a floating-point one. - -allocateReg :: RealReg -> FreeRegs -> FreeRegs -allocateReg (RealRegSingle r) (FreeRegs f) - = FreeRegs (f .&. complement (1 `shiftL` r)) - -allocateReg _ _ - = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg" - - diff --git a/nativeGen/RegAlloc/Liveness.hs b/nativeGen/RegAlloc/Liveness.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Liveness.hs +++ /dev/null @@ -1,1009 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - ------------------------------------------------------------------------------ --- --- The register liveness determinator --- --- (c) The University of Glasgow 2004-2013 --- ------------------------------------------------------------------------------ - -module RegAlloc.Liveness ( - RegSet, - RegMap, emptyRegMap, - BlockMap, mapEmpty, - LiveCmmDecl, - InstrSR (..), - LiveInstr (..), - Liveness (..), - LiveInfo (..), - LiveBasicBlock, - - mapBlockTop, mapBlockTopM, mapSCCM, - mapGenBlockTop, mapGenBlockTopM, - stripLive, - stripLiveBlock, - slurpConflicts, - slurpReloadCoalesce, - eraseDeltasLive, - patchEraseLive, - patchRegsLiveInstr, - reverseBlocksInTops, - regLiveness, - natCmmTopToLive - ) where -import Reg -import Instruction - -import BlockId -import Hoopl -import Cmm hiding (RegSet, emptyRegSet) -import PprCmm() - -import Digraph -import DynFlags -import MonadUtils -import Outputable -import Platform -import UniqSet -import UniqFM -import UniqSupply -import Bag -import State - -import Data.List -import Data.Maybe -import Data.IntSet (IntSet) - ------------------------------------------------------------------------------ -type RegSet = UniqSet Reg - -type RegMap a = UniqFM a - -emptyRegMap :: UniqFM a -emptyRegMap = emptyUFM - -emptyRegSet :: RegSet -emptyRegSet = emptyUniqSet - -type BlockMap a = LabelMap a - - --- | A top level thing which carries liveness information. -type LiveCmmDecl statics instr - = GenCmmDecl - statics - LiveInfo - [SCC (LiveBasicBlock instr)] - - --- | The register allocator also wants to use SPILL/RELOAD meta instructions, --- so we'll keep those here. -data InstrSR instr - -- | A real machine instruction - = Instr instr - - -- | spill this reg to a stack slot - | SPILL Reg Int - - -- | reload this reg from a stack slot - | RELOAD Int Reg - -instance Instruction instr => Instruction (InstrSR instr) where - regUsageOfInstr platform i - = case i of - Instr instr -> regUsageOfInstr platform instr - SPILL reg _ -> RU [reg] [] - RELOAD _ reg -> RU [] [reg] - - patchRegsOfInstr i f - = case i of - Instr instr -> Instr (patchRegsOfInstr instr f) - SPILL reg slot -> SPILL (f reg) slot - RELOAD slot reg -> RELOAD slot (f reg) - - isJumpishInstr i - = case i of - Instr instr -> isJumpishInstr instr - _ -> False - - jumpDestsOfInstr i - = case i of - Instr instr -> jumpDestsOfInstr instr - _ -> [] - - patchJumpInstr i f - = case i of - Instr instr -> Instr (patchJumpInstr instr f) - _ -> i - - mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" - mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" - - takeDeltaInstr i - = case i of - Instr instr -> takeDeltaInstr instr - _ -> Nothing - - isMetaInstr i - = case i of - Instr instr -> isMetaInstr instr - _ -> False - - mkRegRegMoveInstr platform r1 r2 - = Instr (mkRegRegMoveInstr platform r1 r2) - - takeRegRegMoveInstr i - = case i of - Instr instr -> takeRegRegMoveInstr instr - _ -> Nothing - - mkJumpInstr target = map Instr (mkJumpInstr target) - - mkStackAllocInstr platform amount = - Instr (mkStackAllocInstr platform amount) - - mkStackDeallocInstr platform amount = - Instr (mkStackDeallocInstr platform amount) - - --- | An instruction with liveness information. -data LiveInstr instr - = LiveInstr (InstrSR instr) (Maybe Liveness) - --- | Liveness information. --- The regs which die are ones which are no longer live in the *next* instruction --- in this sequence. --- (NB. if the instruction is a jump, these registers might still be live --- at the jump target(s) - you have to check the liveness at the destination --- block to find out). - -data Liveness - = Liveness - { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). - , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. - , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. - - --- | Stash regs live on entry to each basic block in the info part of the cmm code. -data LiveInfo - = LiveInfo - (LabelMap CmmStatics) -- cmm info table static stuff - [BlockId] -- entry points (first one is the - -- entry point for the proc). - (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block - (BlockMap IntSet) -- stack slots live on entry to this block - - --- | A basic block with liveness information. -type LiveBasicBlock instr - = GenBasicBlock (LiveInstr instr) - - -instance Outputable instr - => Outputable (InstrSR instr) where - - ppr (Instr realInstr) - = ppr realInstr - - ppr (SPILL reg slot) - = hcat [ - text "\tSPILL", - char ' ', - ppr reg, - comma, - text "SLOT" <> parens (int slot)] - - ppr (RELOAD slot reg) - = hcat [ - text "\tRELOAD", - char ' ', - text "SLOT" <> parens (int slot), - comma, - ppr reg] - -instance Outputable instr - => Outputable (LiveInstr instr) where - - ppr (LiveInstr instr Nothing) - = ppr instr - - ppr (LiveInstr instr (Just live)) - = ppr instr - $$ (nest 8 - $ vcat - [ pprRegs (text "# born: ") (liveBorn live) - , pprRegs (text "# r_dying: ") (liveDieRead live) - , pprRegs (text "# w_dying: ") (liveDieWrite live) ] - $+$ space) - - where pprRegs :: SDoc -> RegSet -> SDoc - pprRegs name regs - | isEmptyUniqSet regs = empty - | otherwise = name <> - (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr)) - -instance Outputable LiveInfo where - ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) - = (ppr mb_static) - $$ text "# entryIds = " <> ppr entryIds - $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry - $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) - - - --- | map a function across all the basic blocks in this code --- -mapBlockTop - :: (LiveBasicBlock instr -> LiveBasicBlock instr) - -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr - -mapBlockTop f cmm - = evalState (mapBlockTopM (\x -> return $ f x) cmm) () - - --- | map a function across all the basic blocks in this code (monadic version) --- -mapBlockTopM - :: Monad m - => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) - -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr) - -mapBlockTopM _ cmm@(CmmData{}) - = return cmm - -mapBlockTopM f (CmmProc header label live sccs) - = do sccs' <- mapM (mapSCCM f) sccs - return $ CmmProc header label live sccs' - -mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) -mapSCCM f (AcyclicSCC x) - = do x' <- f x - return $ AcyclicSCC x' - -mapSCCM f (CyclicSCC xs) - = do xs' <- mapM f xs - return $ CyclicSCC xs' - - --- map a function across all the basic blocks in this code -mapGenBlockTop - :: (GenBasicBlock i -> GenBasicBlock i) - -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i)) - -mapGenBlockTop f cmm - = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () - - --- | map a function across all the basic blocks in this code (monadic version) -mapGenBlockTopM - :: Monad m - => (GenBasicBlock i -> m (GenBasicBlock i)) - -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))) - -mapGenBlockTopM _ cmm@(CmmData{}) - = return cmm - -mapGenBlockTopM f (CmmProc header label live (ListGraph blocks)) - = do blocks' <- mapM f blocks - return $ CmmProc header label live (ListGraph blocks') - - --- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. --- Slurping of conflicts and moves is wrapped up together so we don't have --- to make two passes over the same code when we want to build the graph. --- -slurpConflicts - :: Instruction instr - => LiveCmmDecl statics instr - -> (Bag (UniqSet Reg), Bag (Reg, Reg)) - -slurpConflicts live - = slurpCmm (emptyBag, emptyBag) live - - where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ _ sccs) - = foldl' (slurpSCC info) rs sccs - - slurpSCC info rs (AcyclicSCC b) - = slurpBlock info rs b - - slurpSCC info rs (CyclicSCC bs) - = foldl' (slurpBlock info) rs bs - - slurpBlock info rs (BasicBlock blockId instrs) - | LiveInfo _ _ (Just blockLive) _ <- info - , Just rsLiveEntry <- mapLookup blockId blockLive - , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs - = (consBag rsLiveEntry conflicts, moves) - - | otherwise - = panic "Liveness.slurpConflicts: bad block" - - slurpLIs rsLive (conflicts, moves) [] - = (consBag rsLive conflicts, moves) - - slurpLIs rsLive rs (LiveInstr _ Nothing : lis) - = slurpLIs rsLive rs lis - - slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) - = let - -- regs that die because they are read for the last time at the start of an instruction - -- are not live across it. - rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) - - -- regs live on entry to the next instruction. - -- be careful of orphans, make sure to delete dying regs _after_ unioning - -- in the ones that are born here. - rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) - `minusUniqSet` (liveDieWrite live) - - -- orphan vregs are the ones that die in the same instruction they are born in. - -- these are likely to be results that are never used, but we still - -- need to assign a hreg to them.. - rsOrphans = intersectUniqSets - (liveBorn live) - (unionUniqSets (liveDieWrite live) (liveDieRead live)) - - -- - rsConflicts = unionUniqSets rsLiveNext rsOrphans - - in case takeRegRegMoveInstr instr of - Just rr -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , consBag rr moves) lis - - Nothing -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , moves) lis - - --- | For spill\/reloads --- --- SPILL v1, slot1 --- ... --- RELOAD slot1, v2 --- --- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely --- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. --- --- -slurpReloadCoalesce - :: forall statics instr. Instruction instr - => LiveCmmDecl statics instr - -> Bag (Reg, Reg) - -slurpReloadCoalesce live - = slurpCmm emptyBag live - - where - slurpCmm :: Bag (Reg, Reg) - -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)] - -> Bag (Reg, Reg) - slurpCmm cs CmmData{} = cs - slurpCmm cs (CmmProc _ _ _ sccs) - = slurpComp cs (flattenSCCs sccs) - - slurpComp :: Bag (Reg, Reg) - -> [LiveBasicBlock instr] - -> Bag (Reg, Reg) - slurpComp cs blocks - = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM - in unionManyBags (cs : moveBags) - - slurpCompM :: [LiveBasicBlock instr] - -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)] - slurpCompM blocks - = do -- run the analysis once to record the mapping across jumps. - mapM_ (slurpBlock False) blocks - - -- run it a second time while using the information from the last pass. - -- We /could/ run this many more times to deal with graphical control - -- flow and propagating info across multiple jumps, but it's probably - -- not worth the trouble. - mapM (slurpBlock True) blocks - - slurpBlock :: Bool -> LiveBasicBlock instr - -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg)) - slurpBlock propagate (BasicBlock blockId instrs) - = do -- grab the slot map for entry to this block - slotMap <- if propagate - then getSlotMap blockId - else return emptyUFM - - (_, mMoves) <- mapAccumLM slurpLI slotMap instrs - return $ listToBag $ catMaybes mMoves - - slurpLI :: UniqFM Reg -- current slotMap - -> LiveInstr instr - -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] - -- for tracking slotMaps across jumps - - ( UniqFM Reg -- new slotMap - , Maybe (Reg, Reg)) -- maybe a new coalesce edge - - slurpLI slotMap li - - -- remember what reg was stored into the slot - | LiveInstr (SPILL reg slot) _ <- li - , slotMap' <- addToUFM slotMap slot reg - = return (slotMap', Nothing) - - -- add an edge between the this reg and the last one stored into the slot - | LiveInstr (RELOAD slot reg) _ <- li - = case lookupUFM slotMap slot of - Just reg2 - | reg /= reg2 -> return (slotMap, Just (reg, reg2)) - | otherwise -> return (slotMap, Nothing) - - Nothing -> return (slotMap, Nothing) - - -- if we hit a jump, remember the current slotMap - | LiveInstr (Instr instr) _ <- li - , targets <- jumpDestsOfInstr instr - , not $ null targets - = do mapM_ (accSlotMap slotMap) targets - return (slotMap, Nothing) - - | otherwise - = return (slotMap, Nothing) - - -- record a slotmap for an in edge to this block - accSlotMap slotMap blockId - = modify (\s -> addToUFM_C (++) s blockId [slotMap]) - - -- work out the slot map on entry to this block - -- if we have slot maps for multiple in-edges then we need to merge them. - getSlotMap blockId - = do map <- get - let slotMaps = fromMaybe [] (lookupUFM map blockId) - return $ foldr mergeSlotMaps emptyUFM slotMaps - - mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg - mergeSlotMaps map1 map2 - = listToUFM - $ [ (k, r1) - | (k, r1) <- nonDetUFMToList map1 - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - , case lookupUFM map2 k of - Nothing -> False - Just r2 -> r1 == r2 ] - - --- | Strip away liveness information, yielding NatCmmDecl -stripLive - :: (Outputable statics, Outputable instr, Instruction instr) - => DynFlags - -> LiveCmmDecl statics instr - -> NatCmmDecl statics instr - -stripLive dflags live - = stripCmm live - - where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) - => LiveCmmDecl statics instr -> NatCmmDecl statics instr - stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs) - = let final_blocks = flattenSCCs sccs - - -- make sure the block that was first in the input list - -- stays at the front of the output. This is the entry point - -- of the proc, and it needs to come first. - ((first':_), rest') - = partition ((== first_id) . blockId) final_blocks - - in CmmProc info label live - (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') - - -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info [] _ _) label live []) - = CmmProc info label live (ListGraph []) - - -- If the proc has blocks but we don't know what the first one was, then we're dead. - stripCmm proc - = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) - --- | Strip away liveness information from a basic block, --- and make real spill instructions out of SPILL, RELOAD pseudos along the way. - -stripLiveBlock - :: Instruction instr - => DynFlags - -> LiveBasicBlock instr - -> NatBasicBlock instr - -stripLiveBlock dflags (BasicBlock i lis) - = BasicBlock i instrs' - - where (instrs', _) - = runState (spillNat [] lis) 0 - - spillNat acc [] - = return (reverse acc) - - spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) - = do delta <- get - spillNat (mkSpillInstr dflags reg delta slot : acc) instrs - - spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) - = do delta <- get - spillNat (mkLoadInstr dflags reg delta slot : acc) instrs - - spillNat acc (LiveInstr (Instr instr) _ : instrs) - | Just i <- takeDeltaInstr instr - = do put i - spillNat acc instrs - - spillNat acc (LiveInstr (Instr instr) _ : instrs) - = spillNat (instr : acc) instrs - - --- | Erase Delta instructions. - -eraseDeltasLive - :: Instruction instr - => LiveCmmDecl statics instr - -> LiveCmmDecl statics instr - -eraseDeltasLive cmm - = mapBlockTop eraseBlock cmm - where - eraseBlock (BasicBlock id lis) - = BasicBlock id - $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) - $ lis - - --- | Patch the registers in this code according to this register mapping. --- also erase reg -> reg moves when the reg is the same. --- also erase reg -> reg moves when the destination dies in this instr. -patchEraseLive - :: Instruction instr - => (Reg -> Reg) - -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr - -patchEraseLive patchF cmm - = patchCmm cmm - where - patchCmm cmm@CmmData{} = cmm - - patchCmm (CmmProc info label live sccs) - | LiveInfo static id (Just blockMap) mLiveSlots <- info - = let - patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set - -- See Note [Unique Determinism and code generation] - blockMap' = mapMap (patchRegSet . getUniqSet) blockMap - - info' = LiveInfo static id (Just blockMap') mLiveSlots - in CmmProc info' label live $ map patchSCC sccs - - | otherwise - = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" - - patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) - patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) - - patchBlock (BasicBlock id lis) - = BasicBlock id $ patchInstrs lis - - patchInstrs [] = [] - patchInstrs (li : lis) - - | LiveInstr i (Just live) <- li' - , Just (r1, r2) <- takeRegRegMoveInstr i - , eatMe r1 r2 live - = patchInstrs lis - - | otherwise - = li' : patchInstrs lis - - where li' = patchRegsLiveInstr patchF li - - eatMe r1 r2 live - -- source and destination regs are the same - | r1 == r2 = True - - -- destination reg is never used - | elementOfUniqSet r2 (liveBorn live) - , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) - = True - - | otherwise = False - - --- | Patch registers in this LiveInstr, including the liveness information. --- -patchRegsLiveInstr - :: Instruction instr - => (Reg -> Reg) - -> LiveInstr instr -> LiveInstr instr - -patchRegsLiveInstr patchF li - = case li of - LiveInstr instr Nothing - -> LiveInstr (patchRegsOfInstr instr patchF) Nothing - - LiveInstr instr (Just live) - -> LiveInstr - (patchRegsOfInstr instr patchF) - (Just live - { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg - liveBorn = mapUniqSet patchF $ liveBorn live - , liveDieRead = mapUniqSet patchF $ liveDieRead live - , liveDieWrite = mapUniqSet patchF $ liveDieWrite live }) - -- See Note [Unique Determinism and code generation] - - --------------------------------------------------------------------------------- --- | Convert a NatCmmDecl to a LiveCmmDecl, with empty liveness information - -natCmmTopToLive - :: Instruction instr - => NatCmmDecl statics instr - -> LiveCmmDecl statics instr - -natCmmTopToLive (CmmData i d) - = CmmData i d - -natCmmTopToLive (CmmProc info lbl live (ListGraph [])) - = CmmProc (LiveInfo info [] Nothing mapEmpty) lbl live [] - -natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _))) - = let first_id = blockId first - all_entry_ids = entryBlocks proc - sccs = sccBlocks blocks all_entry_ids - entry_ids = filter (/= first_id) all_entry_ids - sccsLive = map (fmap (\(BasicBlock l instrs) -> - BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) - $ sccs - - in CmmProc (LiveInfo info (first_id : entry_ids) Nothing mapEmpty) - lbl live sccsLive - - --- --- Compute the liveness graph of the set of basic blocks. Important: --- we also discard any unreachable code here, starting from the entry --- points (the first block in the list, and any blocks with info --- tables). Unreachable code arises when code blocks are orphaned in --- earlier optimisation passes, and may confuse the register allocator --- by referring to registers that are not initialised. It's easy to --- discard the unreachable code as part of the SCC pass, so that's --- exactly what we do. (#7574) --- -sccBlocks - :: Instruction instr - => [NatBasicBlock instr] - -> [BlockId] - -> [SCC (NatBasicBlock instr)] - -sccBlocks blocks entries = map (fmap get_node) sccs - where - -- nodes :: [(NatBasicBlock instr, Unique, [Unique])] - nodes = [ (block, id, getOutEdges instrs) - | block@(BasicBlock id instrs) <- blocks ] - - g1 = graphFromEdgedVerticesUniq nodes - - reachable :: LabelSet - reachable = setFromList [ id | (_,id,_) <- reachablesG g1 roots ] - - g2 = graphFromEdgedVerticesUniq [ node | node@(_,id,_) <- nodes - , id `setMember` reachable ] - - sccs = stronglyConnCompG g2 - - get_node (n, _, _) = n - - getOutEdges :: Instruction instr => [instr] -> [BlockId] - getOutEdges instrs = concat $ map jumpDestsOfInstr instrs - - -- This is truly ugly, but I don't see a good alternative. - -- Digraph just has the wrong API. We want to identify nodes - -- by their keys (BlockId), but Digraph requires the whole - -- node: (NatBasicBlock, BlockId, [BlockId]). This takes - -- advantage of the fact that Digraph only looks at the key, - -- even though it asks for the whole triple. - roots = [(panic "sccBlocks",b,panic "sccBlocks") | b <- entries ] - - - --------------------------------------------------------------------------------- --- Annotate code with register liveness information --- -regLiveness - :: (Outputable instr, Instruction instr) - => Platform - -> LiveCmmDecl statics instr - -> UniqSM (LiveCmmDecl statics instr) - -regLiveness _ (CmmData i d) - = return $ CmmData i d - -regLiveness _ (CmmProc info lbl live []) - | LiveInfo static mFirst _ _ <- info - = return $ CmmProc - (LiveInfo static mFirst (Just mapEmpty) mapEmpty) - lbl live [] - -regLiveness platform (CmmProc info lbl live sccs) - | LiveInfo static mFirst _ liveSlotsOnEntry <- info - = let (ann_sccs, block_live) = computeLiveness platform sccs - - in return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) - lbl live ann_sccs - - --- ----------------------------------------------------------------------------- --- | Check ordering of Blocks --- The computeLiveness function requires SCCs to be in reverse --- dependent order. If they're not the liveness information will be --- wrong, and we'll get a bad allocation. Better to check for this --- precondition explicitly or some other poor sucker will waste a --- day staring at bad assembly code.. --- -checkIsReverseDependent - :: Instruction instr - => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. - -> Maybe BlockId -- ^ BlockIds that fail the test (if any) - -checkIsReverseDependent sccs' - = go emptyUniqSet sccs' - - where go _ [] - = Nothing - - go blocksSeen (AcyclicSCC block : sccs) - = let dests = slurpJumpDestsOfBlock block - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] - badDests = dests `minusUniqSet` blocksSeen' - in case nonDetEltsUniqSet badDests of - -- See Note [Unique Determinism and code generation] - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - go blocksSeen (CyclicSCC blocks : sccs) - = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks - badDests = dests `minusUniqSet` blocksSeen' - in case nonDetEltsUniqSet badDests of - -- See Note [Unique Determinism and code generation] - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - slurpJumpDestsOfBlock (BasicBlock _ instrs) - = unionManyUniqSets - $ map (mkUniqSet . jumpDestsOfInstr) - [ i | LiveInstr i _ <- instrs] - - --- | If we've compute liveness info for this code already we have to reverse --- the SCCs in each top to get them back to the right order so we can do it again. -reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr -reverseBlocksInTops top - = case top of - CmmData{} -> top - CmmProc info lbl live sccs -> CmmProc info lbl live (reverse sccs) - - --- | Computing liveness --- --- On entry, the SCCs must be in "reverse" order: later blocks may transfer --- control to earlier ones only, else `panic`. --- --- The SCCs returned are in the *opposite* order, which is exactly what we --- want for the next pass. --- -computeLiveness - :: (Outputable instr, Instruction instr) - => Platform - -> [SCC (LiveBasicBlock instr)] - -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers - -- which are "dead after this instruction". - BlockMap RegSet) -- blocks annotated with set of live registers - -- on entry to the block. - -computeLiveness platform sccs - = case checkIsReverseDependent sccs of - Nothing -> livenessSCCs platform mapEmpty [] sccs - Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" - (vcat [ text "SCCs aren't in reverse dependent order" - , text "bad blockId" <+> ppr bad - , ppr sccs]) - -livenessSCCs - :: Instruction instr - => Platform - -> BlockMap RegSet - -> [SCC (LiveBasicBlock instr)] -- accum - -> [SCC (LiveBasicBlock instr)] - -> ( [SCC (LiveBasicBlock instr)] - , BlockMap RegSet) - -livenessSCCs _ blockmap done [] - = (done, blockmap) - -livenessSCCs platform blockmap done (AcyclicSCC block : sccs) - = let (blockmap', block') = livenessBlock platform blockmap block - in livenessSCCs platform blockmap' (AcyclicSCC block' : done) sccs - -livenessSCCs platform blockmap done - (CyclicSCC blocks : sccs) = - livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs - where (blockmap', blocks') - = iterateUntilUnchanged linearLiveness equalBlockMaps - blockmap blocks - - iterateUntilUnchanged - :: (a -> b -> (a,c)) -> (a -> a -> Bool) - -> a -> b - -> (a,c) - - iterateUntilUnchanged f eq a b - = head $ - concatMap tail $ - groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ - iterate (\(a, _) -> f a b) $ - (a, panic "RegLiveness.livenessSCCs") - - - linearLiveness - :: Instruction instr - => BlockMap RegSet -> [LiveBasicBlock instr] - -> (BlockMap RegSet, [LiveBasicBlock instr]) - - linearLiveness = mapAccumL (livenessBlock platform) - - -- probably the least efficient way to compare two - -- BlockMaps for equality. - equalBlockMaps a b - = a' == b' - where a' = map f $ mapToList a - b' = map f $ mapToList b - f (key,elt) = (key, nonDetEltsUniqSet elt) - -- See Note [Unique Determinism and code generation] - - - --- | Annotate a basic block with register liveness information. --- -livenessBlock - :: Instruction instr - => Platform - -> BlockMap RegSet - -> LiveBasicBlock instr - -> (BlockMap RegSet, LiveBasicBlock instr) - -livenessBlock platform blockmap (BasicBlock block_id instrs) - = let - (regsLiveOnEntry, instrs1) - = livenessBack platform emptyUniqSet blockmap [] (reverse instrs) - blockmap' = mapInsert block_id regsLiveOnEntry blockmap - - instrs2 = livenessForward platform regsLiveOnEntry instrs1 - - output = BasicBlock block_id instrs2 - - in ( blockmap', output) - --- | Calculate liveness going forwards, --- filling in when regs are born - -livenessForward - :: Instruction instr - => Platform - -> RegSet -- regs live on this instr - -> [LiveInstr instr] -> [LiveInstr instr] - -livenessForward _ _ [] = [] -livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis) - | Just live <- mLive - = let - RU _ written = regUsageOfInstr platform instr - -- Regs that are written to but weren't live on entry to this instruction - -- are recorded as being born here. - rsBorn = mkUniqSet - $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written - - rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) - `minusUniqSet` (liveDieRead live) - `minusUniqSet` (liveDieWrite live) - - in LiveInstr instr (Just live { liveBorn = rsBorn }) - : livenessForward platform rsLiveNext lis - - | otherwise - = li : livenessForward platform rsLiveEntry lis - - --- | Calculate liveness going backwards, --- filling in when regs die, and what regs are live across each instruction - -livenessBack - :: Instruction instr - => Platform - -> RegSet -- regs live on this instr - -> BlockMap RegSet -- regs live on entry to other BBs - -> [LiveInstr instr] -- instructions (accum) - -> [LiveInstr instr] -- instructions - -> (RegSet, [LiveInstr instr]) - -livenessBack _ liveregs _ done [] = (liveregs, done) - -livenessBack platform liveregs blockmap acc (instr : instrs) - = let (liveregs', instr') = liveness1 platform liveregs blockmap instr - in livenessBack platform liveregs' blockmap (instr' : acc) instrs - - --- don't bother tagging comments or deltas with liveness -liveness1 - :: Instruction instr - => Platform - -> RegSet - -> BlockMap RegSet - -> LiveInstr instr - -> (RegSet, LiveInstr instr) - -liveness1 _ liveregs _ (LiveInstr instr _) - | isMetaInstr instr - = (liveregs, LiveInstr instr Nothing) - -liveness1 platform liveregs blockmap (LiveInstr instr _) - - | not_a_branch - = (liveregs1, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying - , liveDieWrite = mkUniqSet w_dying })) - - | otherwise - = (liveregs_br, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying_br - , liveDieWrite = mkUniqSet w_dying })) - - where - !(RU read written) = regUsageOfInstr platform instr - - -- registers that were written here are dead going backwards. - -- registers that were read here are live going backwards. - liveregs1 = (liveregs `delListFromUniqSet` written) - `addListToUniqSet` read - - -- registers that are not live beyond this point, are recorded - -- as dying here. - r_dying = [ reg | reg <- read, reg `notElem` written, - not (elementOfUniqSet reg liveregs) ] - - w_dying = [ reg | reg <- written, - not (elementOfUniqSet reg liveregs) ] - - -- union in the live regs from all the jump destinations of this - -- instruction. - targets = jumpDestsOfInstr instr -- where we go from here - not_a_branch = null targets - - targetLiveRegs target - = case mapLookup target blockmap of - Just ra -> ra - Nothing -> emptyRegSet - - live_from_branch = unionManyUniqSets (map targetLiveRegs targets) - - liveregs_br = liveregs1 `unionUniqSets` live_from_branch - - -- registers that are live only in the branch targets should - -- be listed as dying here. - live_branch_only = live_from_branch `minusUniqSet` liveregs - r_dying_br = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets` - live_branch_only) - -- See Note [Unique Determinism and code generation] - - diff --git a/nativeGen/RegClass.hs b/nativeGen/RegClass.hs deleted file mode 100644 --- a/nativeGen/RegClass.hs +++ /dev/null @@ -1,33 +0,0 @@ --- | An architecture independent description of a register's class. -module RegClass - ( RegClass (..) ) - -where - -import Outputable -import Unique - - --- | The class of a register. --- Used in the register allocator. --- We treat all registers in a class as being interchangable. --- -data RegClass - = RcInteger - | RcFloat - | RcDouble - | RcDoubleSSE -- x86 only: the SSE regs are a separate class - deriving Eq - - -instance Uniquable RegClass where - getUnique RcInteger = mkRegClassUnique 0 - getUnique RcFloat = mkRegClassUnique 1 - getUnique RcDouble = mkRegClassUnique 2 - getUnique RcDoubleSSE = mkRegClassUnique 3 - -instance Outputable RegClass where - ppr RcInteger = Outputable.text "I" - ppr RcFloat = Outputable.text "F" - ppr RcDouble = Outputable.text "D" - ppr RcDoubleSSE = Outputable.text "S" diff --git a/nativeGen/SPARC/AddrMode.hs b/nativeGen/SPARC/AddrMode.hs deleted file mode 100644 --- a/nativeGen/SPARC/AddrMode.hs +++ /dev/null @@ -1,42 +0,0 @@ - -module SPARC.AddrMode ( - AddrMode(..), - addrOffset -) - -where - -import SPARC.Imm -import SPARC.Base -import Reg - --- addressing modes ------------------------------------------------------------ - --- | Represents a memory address in an instruction. --- Being a RISC machine, the SPARC addressing modes are very regular. --- -data AddrMode - = AddrRegReg Reg Reg -- addr = r1 + r2 - | AddrRegImm Reg Imm -- addr = r1 + imm - - --- | Add an integer offset to the address in an AddrMode. --- -addrOffset :: AddrMode -> Int -> Maybe AddrMode -addrOffset addr off - = case addr of - AddrRegImm r (ImmInt n) - | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2)) - | otherwise -> Nothing - where n2 = n + off - - AddrRegImm r (ImmInteger n) - | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) - | otherwise -> Nothing - where n2 = n + toInteger off - - AddrRegReg r (RegReal (RealRegSingle 0)) - | fits13Bits off -> Just (AddrRegImm r (ImmInt off)) - | otherwise -> Nothing - - _ -> Nothing diff --git a/nativeGen/SPARC/Base.hs b/nativeGen/SPARC/Base.hs deleted file mode 100644 --- a/nativeGen/SPARC/Base.hs +++ /dev/null @@ -1,75 +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 main/Constants - -module SPARC.Base ( - wordLength, - wordLengthInBits, - spillAreaLength, - spillSlotSize, - extraStackArgsHere, - fits13Bits, - is32BitInteger, - largeOffsetError -) - -where - -import DynFlags -import Panic - -import Data.Int - - --- On 32 bit SPARC, pointers are 32 bits. -wordLength :: Int -wordLength = 4 - -wordLengthInBits :: Int -wordLengthInBits - = wordLength * 8 - --- Size of the available spill area -spillAreaLength :: DynFlags -> Int -spillAreaLength - = rESERVED_C_STACK_BYTES - --- | We need 8 bytes because our largest registers are 64 bit. -spillSlotSize :: Int -spillSlotSize = 8 - - --- | We (allegedly) put the first six C-call arguments in registers; --- where do we start putting the rest of them? -extraStackArgsHere :: Int -extraStackArgsHere = 23 - - -{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-} --- | Check whether an offset is representable with 13 bits. -fits13Bits :: Integral a => a -> Bool -fits13Bits x = x >= -4096 && x < 4096 - --- | Check whether an integer will fit in 32 bits. --- A CmmInt is intended to be truncated to the appropriate --- number of bits, so here we truncate it to Int64. This is --- important because e.g. -1 as a CmmInt might be either --- -1 or 18446744073709551615. --- -is32BitInteger :: Integer -> Bool -is32BitInteger i - = i64 <= 0x7fffffff && i64 >= -0x80000000 - where i64 = fromIntegral i :: Int64 - - --- | Sadness. -largeOffsetError :: (Show a) => a -> b -largeOffsetError i - = panic ("ERROR: SPARC native-code generator cannot handle large offset (" - ++ show i ++ ");\nprobably because of large constant data structures;" ++ - "\nworkaround: use -fllvm on this module.\n") - - diff --git a/nativeGen/SPARC/CodeGen.hs b/nativeGen/SPARC/CodeGen.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen.hs +++ /dev/null @@ -1,674 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Generating machine code (instruction selection) --- --- (c) The University of Glasgow 1996-2013 --- ------------------------------------------------------------------------------ - -{-# LANGUAGE GADTs #-} -module SPARC.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - InstrBlock -) - -where - -#include "HsVersions.h" -#include "nativeGen/NCG.h" -#include "MachDeps.h" - --- NCG stuff: -import SPARC.Base -import SPARC.CodeGen.Sanity -import SPARC.CodeGen.Amode -import SPARC.CodeGen.CondCode -import SPARC.CodeGen.Gen64 -import SPARC.CodeGen.Gen32 -import SPARC.CodeGen.Base -import SPARC.Ppr () -import SPARC.Instr -import SPARC.Imm -import SPARC.AddrMode -import SPARC.Regs -import SPARC.Stack -import Instruction -import Format -import NCGMonad - --- Our intermediate code: -import BlockId -import Cmm -import CmmUtils -import CmmSwitch -import Hoopl -import PIC -import Reg -import CLabel -import CPrim - --- The rest: -import BasicTypes -import DynFlags -import FastString -import OrdList -import Outputable -import Platform -import Unique - -import Control.Monad ( mapAndUnzipM ) - --- | Top level code generation -cmmTopCodeGen :: RawCmmDecl - -> NatM [NatCmmDecl CmmStatics Instr] - -cmmTopCodeGen (CmmProc info lab live graph) - = do let blocks = toBlockListEntryFirst graph - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - - let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) - let tops = proc : concat statics - - return tops - -cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic - - --- | Do code generation on a single block of CMM code. --- code generation may introduce new basic block boundaries, which --- are indicated by the NEWBLOCK instruction. We must split up the --- instruction stream into basic blocks again. Also, we extract --- LDATAs here too. -basicBlockCodeGen :: CmmBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl CmmStatics Instr]) - -basicBlockCodeGen block = do - let (_, nodes, tail) = blockSplit block - id = entryLabel block - stmts = blockToList nodes - mid_instrs <- stmtsToInstrs stmts - tail_instrs <- stmtToInstrs tail - let instrs = mid_instrs `appOL` tail_instrs - let - (top,other_blocks,statics) - = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) - - -- do intra-block sanity checking - blocksChecked - = map (checkBlock block) - $ BasicBlock id top : other_blocks - - return (blocksChecked, statics) - - --- | Convert some Cmm statements to SPARC instructions. -stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock -stmtsToInstrs stmts - = do instrss <- mapM stmtToInstrs stmts - return (concatOL instrss) - - -stmtToInstrs :: CmmNode e x -> NatM InstrBlock -stmtToInstrs stmt = do - dflags <- getDynFlags - case stmt of - CmmComment s -> return (unitOL (COMMENT s)) - CmmTick {} -> return nilOL - CmmUnwind {} -> return nilOL - - CmmAssign reg src - | isFloatType ty -> assignReg_FltCode format reg src - | isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType dflags reg - format = cmmTypeFormat ty - - CmmStore addr src - | isFloatType ty -> assignMem_FltCode format addr src - | isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode format addr src - where ty = cmmExprType dflags src - format = cmmTypeFormat ty - - CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args - - CmmBranch id -> genBranch id - CmmCondBranch arg true false _ -> do - b1 <- genCondJump true arg - b2 <- genBranch false - return (b1 `appOL` b2) - CmmSwitch arg ids -> do dflags <- getDynFlags - genSwitch dflags arg ids - CmmCall { cml_target = arg } -> genJump arg - - _ - -> panic "stmtToInstrs: statement should have been cps'd away" - - -{- -Now, given a tree (the argument to an CmmLoad) that references memory, -produce a suitable addressing mode. - -A Rule of the Game (tm) for Amodes: use of the addr bit must -immediately follow use of the code part, since the code part puts -values in registers which the addr then refers to. So you can't put -anything in between, lest it overwrite some of those registers. If -you need to do some other computation between the code part and use of -the addr bit, first store the effective address from the amode in a -temporary, then do the other computation, and then use the temporary: - - code - LEA amode, tmp - ... other computation ... - ... (tmp) ... --} - - - --- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic -jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) -jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = mkAsmTempLabel (getUnique blockid) - - - --- ----------------------------------------------------------------------------- --- Generating assignments - --- Assignments are really at the heart of the whole code generation --- business. Almost all top-level nodes of any real importance are --- assignments, which correspond to loads, stores, or register --- transfers. If we're really lucky, some of the register transfers --- will go away, because we can use the destination register to --- complete the code generation for the right hand side. This only --- fails when the right hand side is forced into a fixed register --- (e.g. the result of a call). - -assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_IntCode pk addr src = do - (srcReg, code) <- getSomeReg src - Amode dstAddr addr_code <- getAmode addr - return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr - - -assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_IntCode _ reg src = do - dflags <- getDynFlags - r <- getRegister src - let dst = getRegisterReg (targetPlatform dflags) reg - return $ case r of - Any _ code -> code dst - Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst - - - --- Floating point assignment to memory -assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_FltCode pk addr src = do - dflags <- getDynFlags - Amode dst__2 code1 <- getAmode addr - (src__2, code2) <- getSomeReg src - tmp1 <- getNewRegNat pk - let - pk__2 = cmmExprType dflags src - code__2 = code1 `appOL` code2 `appOL` - if formatToWidth pk == typeWidth pk__2 - then unitOL (ST pk src__2 dst__2) - else toOL [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1 - , ST pk tmp1 dst__2] - return code__2 - --- Floating point assignment to a register/temporary -assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_FltCode pk dstCmmReg srcCmmExpr = do - dflags <- getDynFlags - let platform = targetPlatform dflags - srcRegister <- getRegister srcCmmExpr - let dstReg = getRegisterReg platform dstCmmReg - - return $ case srcRegister of - Any _ code -> code dstReg - Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg - - - - -genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock - -genJump (CmmLit (CmmLabel lbl)) - = return (toOL [CALL (Left target) 0 True, NOP]) - where - target = ImmCLbl lbl - -genJump tree - = do - (target, code) <- getSomeReg tree - return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) - --- ----------------------------------------------------------------------------- --- Unconditional branches - -genBranch :: BlockId -> NatM InstrBlock -genBranch = return . toOL . mkJumpInstr - - --- ----------------------------------------------------------------------------- --- Conditional jumps - -{- -Conditional jumps are always to local labels, so we can use branch -instructions. We peek at the arguments to decide what kind of -comparison to do. - -SPARC: First, we have to ensure that the condition codes are set -according to the supplied comparison operation. We generate slightly -different code for floating point comparisons, because a floating -point operation cannot directly precede a @BF@. We assume the worst -and fill that slot with a @NOP@. - -SPARC: Do not fill the delay slots here; you will confuse the register -allocator. --} - - -genCondJump - :: BlockId -- the branch target - -> CmmExpr -- the condition on which to branch - -> NatM InstrBlock - - - -genCondJump bid bool = do - CondCode is_float cond code <- getCondCode bool - return ( - code `appOL` - toOL ( - if is_float - then [NOP, BF cond False bid, NOP] - else [BI cond False bid, NOP] - ) - ) - - - --- ----------------------------------------------------------------------------- --- Generating a table-branch - -genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch dflags expr targets - | positionIndependent dflags - = error "MachCodeGen: sparc genSwitch PIC not finished\n" - - | otherwise - = do (e_reg, e_code) <- getSomeReg (cmmOffset dflags expr offset) - - base_reg <- getNewRegNat II32 - offset_reg <- getNewRegNat II32 - dst <- getNewRegNat II32 - - label <- getNewLabelNat - - return $ e_code `appOL` - toOL - [ -- load base of jump table - SETHI (HI (ImmCLbl label)) base_reg - , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg - - -- the addrs in the table are 32 bits wide.. - , SLL e_reg (RIImm $ ImmInt 2) offset_reg - - -- load and jump to the destination - , LD II32 (AddrRegReg base_reg offset_reg) dst - , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label - , NOP ] - where (offset, ids) = switchTargetsToTable targets - -generateJumpTableForInstr :: DynFlags -> Instr - -> Maybe (NatCmmDecl CmmStatics Instr) -generateJumpTableForInstr dflags (JMP_TBL _ ids label) = - let jumpTable = map (jumpTableEntry dflags) ids - in Just (CmmData (Section ReadOnlyData label) (Statics label jumpTable)) -generateJumpTableForInstr _ _ = Nothing - - - --- ----------------------------------------------------------------------------- --- Generating C calls - -{- - Now the biggest nightmare---calls. Most of the nastiness is buried in - @get_arg@, which moves the arguments to the correct registers/stack - locations. Apart from that, the code is easy. - - The SPARC calling convention is an absolute - nightmare. The first 6x32 bits of arguments are mapped into - %o0 through %o5, and the remaining arguments are dumped to the - stack, beginning at [%sp+92]. (Note that %o6 == %sp.) - - If we have to put args on the stack, move %o6==%sp down by - the number of words to go on the stack, to ensure there's enough space. - - According to Fraser and Hanson's lcc book, page 478, fig 17.2, - 16 words above the stack pointer is a word for the address of - a structure return value. I use this as a temporary location - for moving values from float to int regs. Certainly it isn't - safe to put anything in the 16 words starting at %sp, since - this area can get trashed at any time due to window overflows - caused by signal handlers. - - A final complication (if the above isn't enough) is that - we can't blithely calculate the arguments one by one into - %o0 .. %o5. Consider the following nested calls: - - fff a (fff b c) - - Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately - the inner call will itself use %o0, which trashes the value put there - in preparation for the outer call. Upshot: we need to calculate the - args into temporary regs, and move those to arg regs or onto the - stack only immediately prior to the call proper. Sigh. --} - -genCCall - :: ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock - - - --- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream --- are guaranteed to take place before writes afterwards (unlike on PowerPC). --- Ref: Section 8.4 of the SPARC V9 Architecture manual. --- --- In the SPARC case we don't need a barrier. --- -genCCall (PrimTarget MO_WriteBarrier) _ _ - = return $ nilOL - -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ - = return $ nilOL - -genCCall target dest_regs args - = do -- work out the arguments, and assign them to integer regs - argcode_and_vregs <- mapM arg_to_int_vregs args - let (argcodes, vregss) = unzip argcode_and_vregs - let vregs = concat vregss - - let n_argRegs = length allArgRegs - let n_argRegs_used = min (length vregs) n_argRegs - - - -- deal with static vs dynamic call targets - callinsns <- case target of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - ForeignTarget expr _ - -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - PrimTarget mop - -> do res <- outOfLineMachOp mop - lblOrMopExpr <- case res of - Left lbl -> do - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - Right mopExpr -> do - (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - return lblOrMopExpr - - let argcode = concatOL argcodes - - let (move_sp_down, move_sp_up) - = let diff = length vregs - n_argRegs - nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment - in if nn <= 0 - then (nilOL, nilOL) - else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) - - let transfer_code - = toOL (move_final vregs allArgRegs extraStackArgsHere) - - dflags <- getDynFlags - return - $ argcode `appOL` - move_sp_down `appOL` - transfer_code `appOL` - callinsns `appOL` - unitOL NOP `appOL` - move_sp_up `appOL` - assign_code (targetPlatform dflags) dest_regs - - --- | Generate code to calculate an argument, and move it into one --- or two integer vregs. -arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs arg = do dflags <- getDynFlags - arg_to_int_vregs' dflags arg - -arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs' dflags arg - - -- If the expr produces a 64 bit int, then we can just use iselExpr64 - | isWord64 (cmmExprType dflags arg) - = do (ChildCode64 code r_lo) <- iselExpr64 arg - let r_hi = getHiVRegFromLo r_lo - return (code, [r_hi, r_lo]) - - | otherwise - = do (src, code) <- getSomeReg arg - let pk = cmmExprType dflags arg - - case cmmTypeFormat pk of - - -- Load a 64 bit float return value into two integer regs. - FF64 -> do - v1 <- getNewRegNat II32 - v2 <- getNewRegNat II32 - - let code2 = - code `snocOL` - FMOV FF64 src f0 `snocOL` - ST FF32 f0 (spRel 16) `snocOL` - LD II32 (spRel 16) v1 `snocOL` - ST FF32 f1 (spRel 16) `snocOL` - LD II32 (spRel 16) v2 - - return (code2, [v1,v2]) - - -- Load a 32 bit float return value into an integer reg - FF32 -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - ST FF32 src (spRel 16) `snocOL` - LD II32 (spRel 16) v1 - - return (code2, [v1]) - - -- Move an integer return value into its destination reg. - _ -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - OR False g0 (RIReg src) v1 - - return (code2, [v1]) - - --- | Move args from the integer vregs into which they have been --- marshalled, into %o0 .. %o5, and the rest onto the stack. --- -move_final :: [Reg] -> [Reg] -> Int -> [Instr] - --- all args done -move_final [] _ _ - = [] - --- out of aregs; move to stack -move_final (v:vs) [] offset - = ST II32 v (spRel offset) - : move_final vs [] (offset+1) - --- move into an arg (%o[0..5]) reg -move_final (v:vs) (a:az) offset - = OR False g0 (RIReg v) a - : move_final vs az offset - - --- | Assign results returned from the call into their --- destination regs. --- -assign_code :: Platform -> [LocalReg] -> OrdList Instr - -assign_code _ [] = nilOL - -assign_code platform [dest] - = let rep = localRegType dest - width = typeWidth rep - r_dest = getRegisterReg platform (CmmLocal dest) - - result - | isFloatType rep - , W32 <- width - = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest - - | isFloatType rep - , W64 <- width - = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest - - | not $ isFloatType rep - , W32 <- width - = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest - - | not $ isFloatType rep - , W64 <- width - , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi - , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] - - | otherwise - = panic "SPARC.CodeGen.GenCCall: no match" - - in result - -assign_code _ _ - = panic "SPARC.CodeGen.GenCCall: no match" - - - --- | Generate a call to implement an out-of-line floating point operation -outOfLineMachOp - :: CallishMachOp - -> NatM (Either CLabel CmmExpr) - -outOfLineMachOp mop - = do let functionName - = outOfLineMachOp_table mop - - dflags <- getDynFlags - mopExpr <- cmmMakeDynamicReference dflags CallReference - $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction - - let mopLabelOrExpr - = case mopExpr of - CmmLit (CmmLabel lbl) -> Left lbl - _ -> Right mopExpr - - return mopLabelOrExpr - - --- | Decide what C function to use to implement a CallishMachOp --- -outOfLineMachOp_table - :: CallishMachOp - -> FastString - -outOfLineMachOp_table mop - = case mop of - MO_F32_Exp -> fsLit "expf" - MO_F32_Log -> fsLit "logf" - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Fabs -> unsupported - MO_F32_Pwr -> fsLit "powf" - - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" - MO_F32_Tan -> fsLit "tanf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - - MO_F64_Exp -> fsLit "exp" - MO_F64_Log -> fsLit "log" - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Fabs -> unsupported - MO_F64_Pwr -> fsLit "pow" - - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" - MO_F64_Tan -> fsLit "tan" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - - MO_UF_Conv w -> fsLit $ word2FloatLabel w - - MO_Memcpy _ -> fsLit "memcpy" - MO_Memset _ -> fsLit "memset" - MO_Memmove _ -> fsLit "memmove" - - MO_BSwap w -> fsLit $ bSwapLabel w - MO_PopCnt w -> fsLit $ popCntLabel w - MO_Clz w -> fsLit $ clzLabel w - MO_Ctz w -> fsLit $ ctzLabel w - MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop - MO_Cmpxchg w -> fsLit $ cmpxchgLabel w - MO_AtomicRead w -> fsLit $ atomicReadLabel w - MO_AtomicWrite w -> fsLit $ atomicWriteLabel w - - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - MO_Add2 {} -> unsupported - MO_SubWordC {} -> unsupported - MO_AddIntC {} -> unsupported - MO_SubIntC {} -> unsupported - MO_U_Mul2 {} -> unsupported - MO_WriteBarrier -> unsupported - MO_Touch -> unsupported - (MO_Prefetch_Data _) -> unsupported - where unsupported = panic ("outOfLineCmmOp: " ++ show mop - ++ " not supported here") - diff --git a/nativeGen/SPARC/CodeGen/Amode.hs b/nativeGen/SPARC/CodeGen/Amode.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Amode.hs +++ /dev/null @@ -1,72 +0,0 @@ -module SPARC.CodeGen.Amode ( - getAmode -) - -where - -import {-# SOURCE #-} SPARC.CodeGen.Gen32 -import SPARC.CodeGen.Base -import SPARC.AddrMode -import SPARC.Imm -import SPARC.Instr -import SPARC.Regs -import SPARC.Base -import NCGMonad -import Format - -import Cmm - -import OrdList - - --- | Generate code to reference a memory address. -getAmode - :: CmmExpr -- ^ expr producing an address - -> NatM Amode - -getAmode tree@(CmmRegOff _ _) - = do dflags <- getDynFlags - getAmode (mangleIndexTree dflags tree) - -getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)]) - | fits13Bits (-i) - = do - (reg, code) <- getSomeReg x - let - off = ImmInt (-(fromInteger i)) - return (Amode (AddrRegImm reg off) code) - - -getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)]) - | fits13Bits i - = do - (reg, code) <- getSomeReg x - let - off = ImmInt (fromInteger i) - return (Amode (AddrRegImm reg off) code) - -getAmode (CmmMachOp (MO_Add _) [x, y]) - = do - (regX, codeX) <- getSomeReg x - (regY, codeY) <- getSomeReg y - let - code = codeX `appOL` codeY - return (Amode (AddrRegReg regX regY) code) - -getAmode (CmmLit lit) - = do - let imm__2 = litToImm lit - tmp1 <- getNewRegNat II32 - tmp2 <- getNewRegNat II32 - - let code = toOL [ SETHI (HI imm__2) tmp1 - , OR False tmp1 (RIImm (LO imm__2)) tmp2] - - return (Amode (AddrRegReg tmp2 g0) code) - -getAmode other - = do - (reg, code) <- getSomeReg other - let - off = ImmInt 0 - return (Amode (AddrRegImm reg off) code) diff --git a/nativeGen/SPARC/CodeGen/Base.hs b/nativeGen/SPARC/CodeGen/Base.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Base.hs +++ /dev/null @@ -1,117 +0,0 @@ -module SPARC.CodeGen.Base ( - InstrBlock, - CondCode(..), - ChildCode64(..), - Amode(..), - - Register(..), - setFormatOfRegister, - - getRegisterReg, - mangleIndexTree -) - -where - -import SPARC.Instr -import SPARC.Cond -import SPARC.AddrMode -import SPARC.Regs -import Format -import Reg - -import CodeGen.Platform -import DynFlags -import Cmm -import PprCmmExpr () -import Platform - -import Outputable -import OrdList - --------------------------------------------------------------------------------- --- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. --- -type InstrBlock - = OrdList Instr - - --- | Condition codes passed up the tree. --- -data CondCode - = CondCode Bool Cond InstrBlock - - --- | a.k.a "Register64" --- Reg is the lower 32-bit temporary which contains the result. --- Use getHiVRegFromLo to find the other VRegUnique. --- --- Rules of this simplified insn selection game are therefore that --- the returned Reg may be modified --- -data ChildCode64 - = ChildCode64 - InstrBlock - Reg - - --- | Holds code that references a memory address. -data Amode - = Amode - -- the AddrMode we can use in the instruction - -- that does the real load\/store. - AddrMode - - -- other setup code we have to run first before we can use the - -- above AddrMode. - InstrBlock - - - --------------------------------------------------------------------------------- --- | Code to produce a result into a register. --- If the result must go in a specific register, it comes out as Fixed. --- Otherwise, the parent can decide which register to put it in. --- -data Register - = Fixed Format Reg InstrBlock - | Any Format (Reg -> InstrBlock) - - --- | Change the format field in a Register. -setFormatOfRegister - :: Register -> Format -> Register - -setFormatOfRegister reg format - = case reg of - Fixed _ reg code -> Fixed format reg code - Any _ codefn -> Any format codefn - - --------------------------------------------------------------------------------- --- | Grab the Reg for a CmmReg -getRegisterReg :: Platform -> CmmReg -> Reg - -getRegisterReg _ (CmmLocal (LocalReg u pk)) - = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) - -getRegisterReg platform (CmmGlobal mid) - = case globalRegMaybe platform mid of - Just reg -> RegReal reg - Nothing -> pprPanic - "SPARC.CodeGen.Base.getRegisterReg: global is in memory" - (ppr $ CmmGlobal mid) - - --- Expand CmmRegOff. ToDo: should we do it this way around, or convert --- CmmExprs into CmmRegOff? -mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr - -mangleIndexTree dflags (CmmRegOff reg off) - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType dflags reg) - -mangleIndexTree _ _ - = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" diff --git a/nativeGen/SPARC/CodeGen/CondCode.hs b/nativeGen/SPARC/CodeGen/CondCode.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/CondCode.hs +++ /dev/null @@ -1,108 +0,0 @@ -module SPARC.CodeGen.CondCode ( - getCondCode, - condIntCode, - condFltCode -) - -where - -import {-# SOURCE #-} SPARC.CodeGen.Gen32 -import SPARC.CodeGen.Base -import SPARC.Instr -import SPARC.Regs -import SPARC.Cond -import SPARC.Imm -import SPARC.Base -import NCGMonad -import Format - -import Cmm - -import OrdList -import Outputable - - -getCondCode :: CmmExpr -> NatM CondCode -getCondCode (CmmMachOp mop [x, y]) - = - case mop of - MO_F_Eq W32 -> condFltCode EQQ x y - MO_F_Ne W32 -> condFltCode NE x y - MO_F_Gt W32 -> condFltCode GTT x y - MO_F_Ge W32 -> condFltCode GE x y - MO_F_Lt W32 -> condFltCode LTT x y - MO_F_Le W32 -> condFltCode LE x y - - MO_F_Eq W64 -> condFltCode EQQ x y - MO_F_Ne W64 -> condFltCode NE x y - MO_F_Gt W64 -> condFltCode GTT x y - MO_F_Ge W64 -> condFltCode GE x y - MO_F_Lt W64 -> condFltCode LTT x y - MO_F_Le W64 -> condFltCode LE x y - - MO_Eq _ -> condIntCode EQQ x y - MO_Ne _ -> condIntCode NE x y - - MO_S_Gt _ -> condIntCode GTT x y - MO_S_Ge _ -> condIntCode GE x y - MO_S_Lt _ -> condIntCode LTT x y - MO_S_Le _ -> condIntCode LE x y - - MO_U_Gt _ -> condIntCode GU x y - MO_U_Ge _ -> condIntCode GEU x y - MO_U_Lt _ -> condIntCode LU x y - MO_U_Le _ -> condIntCode LEU x y - - _ -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y])) - -getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other) - - - - - --- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be --- passed back up the tree. - -condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condIntCode cond x (CmmLit (CmmInt y _)) - | fits13Bits y - = do - (src1, code) <- getSomeReg x - let - src2 = ImmInt (fromInteger y) - code' = code `snocOL` SUB False True src1 (RIImm src2) g0 - return (CondCode False cond code') - -condIntCode cond x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 = code1 `appOL` code2 `snocOL` - SUB False True src1 (RIReg src2) g0 - return (CondCode False cond code__2) - - -condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condFltCode cond x y = do - dflags <- getDynFlags - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - tmp <- getNewRegNat FF64 - let - promote x = FxTOy FF32 FF64 x tmp - - pk1 = cmmExprType dflags x - pk2 = cmmExprType dflags y - - code__2 = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - FCMP True (cmmTypeFormat pk1) src1 src2 - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - FCMP True FF64 tmp src2 - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - FCMP True FF64 src1 tmp - return (CondCode True cond code__2) diff --git a/nativeGen/SPARC/CodeGen/Expand.hs b/nativeGen/SPARC/CodeGen/Expand.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Expand.hs +++ /dev/null @@ -1,153 +0,0 @@ --- | Expand out synthetic instructions into single machine instrs. -module SPARC.CodeGen.Expand ( - expandTop -) - -where - -import SPARC.Instr -import SPARC.Imm -import SPARC.AddrMode -import SPARC.Regs -import SPARC.Ppr () -import Instruction -import Reg -import Format -import Cmm - - -import Outputable -import OrdList - --- | Expand out synthetic instructions in this top level thing -expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr -expandTop top@(CmmData{}) - = top - -expandTop (CmmProc info lbl live (ListGraph blocks)) - = CmmProc info lbl live (ListGraph $ map expandBlock blocks) - - --- | Expand out synthetic instructions in this block -expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr - -expandBlock (BasicBlock label instrs) - = let instrs_ol = expandBlockInstrs instrs - instrs' = fromOL instrs_ol - in BasicBlock label instrs' - - --- | Expand out some instructions -expandBlockInstrs :: [Instr] -> OrdList Instr -expandBlockInstrs [] = nilOL - -expandBlockInstrs (ii:is) - = let ii_doubleRegs = remapRegPair ii - is_misaligned = expandMisalignedDoubles ii_doubleRegs - - in is_misaligned `appOL` expandBlockInstrs is - - - --- | In the SPARC instruction set the FP register pairs that are used --- to hold 64 bit floats are refered to by just the first reg --- of the pair. Remap our internal reg pairs to the appropriate reg. --- --- For example: --- ldd [%l1], (%f0 | %f1) --- --- gets mapped to --- ldd [$l1], %f0 --- -remapRegPair :: Instr -> Instr -remapRegPair instr - = let patchF reg - = case reg of - RegReal (RealRegSingle _) - -> reg - - RegReal (RealRegPair r1 r2) - - -- sanity checking - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - , r2 == r1 + 1 - -> RegReal (RealRegSingle r1) - - | otherwise - -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg) - - RegVirtual _ - -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg) - - in patchRegsOfInstr instr patchF - - - - --- Expand out 64 bit load/stores into individual instructions to handle --- possible double alignment problems. --- --- TODO: It'd be better to use a scratch reg instead of the add/sub thing. --- We might be able to do this faster if we use the UA2007 instr set --- instead of restricting ourselves to SPARC V9. --- -expandMisalignedDoubles :: Instr -> OrdList Instr -expandMisalignedDoubles instr - - -- Translate to: - -- add g1,g2,g1 - -- ld [g1],%fn - -- ld [g1+4],%f(n+1) - -- sub g1,g2,g1 -- to restore g1 - | LD FF64 (AddrRegReg r1 r2) fReg <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , LD FF32 (AddrRegReg r1 g0) fReg - , LD FF32 (AddrRegImm r1 (ImmInt 4)) (fRegHi fReg) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | LD FF64 addr fReg <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ LD FF32 addr fReg - , LD FF32 addr' (fRegHi fReg) ] - - -- Translate to: - -- add g1,g2,g1 - -- st %fn,[g1] - -- st %f(n+1),[g1+4] - -- sub g1,g2,g1 -- to restore g1 - | ST FF64 fReg (AddrRegReg r1 r2) <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , ST FF32 fReg (AddrRegReg r1 g0) - , ST FF32 (fRegHi fReg) (AddrRegImm r1 (ImmInt 4)) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | ST FF64 fReg addr <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ ST FF32 fReg addr - , ST FF32 (fRegHi fReg) addr' ] - - -- some other instr - | otherwise - = unitOL instr - - - --- | The the high partner for this float reg. -fRegHi :: Reg -> Reg -fRegHi (RegReal (RealRegSingle r1)) - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - = (RegReal $ RealRegSingle (r1 + 1)) - --- Can't take high partner for non-low reg. -fRegHi reg - = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) diff --git a/nativeGen/SPARC/CodeGen/Gen32.hs b/nativeGen/SPARC/CodeGen/Gen32.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Gen32.hs +++ /dev/null @@ -1,690 +0,0 @@ --- | Evaluation of 32 bit values. -module SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister -) - -where - -import SPARC.CodeGen.CondCode -import SPARC.CodeGen.Amode -import SPARC.CodeGen.Gen64 -import SPARC.CodeGen.Base -import SPARC.Stack -import SPARC.Instr -import SPARC.Cond -import SPARC.AddrMode -import SPARC.Imm -import SPARC.Regs -import SPARC.Base -import NCGMonad -import Format -import Reg - -import Cmm - -import Control.Monad (liftM) -import DynFlags -import OrdList -import Outputable - --- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getSomeReg expr = do - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) - - - --- | Make code to evaluate a 32 bit expression. --- -getRegister :: CmmExpr -> NatM Register - -getRegister (CmmReg reg) - = do dflags <- getDynFlags - let platform = targetPlatform dflags - return (Fixed (cmmTypeFormat (cmmRegType dflags reg)) - (getRegisterReg platform reg) nilOL) - -getRegister tree@(CmmRegOff _ _) - = do dflags <- getDynFlags - getRegister (mangleIndexTree dflags tree) - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - - --- Load a literal float into a float register. --- The actual literal is stored in a new data area, and we load it --- at runtime. -getRegister (CmmLit (CmmFloat f W32)) = do - - -- a label for the new data area - lbl <- getNewLabelNat - tmp <- getNewRegNat II32 - - let code dst = toOL [ - -- the data area - LDATA (Section ReadOnlyData lbl) $ Statics lbl - [CmmStaticLit (CmmFloat f W32)], - - -- load the literal - SETHI (HI (ImmCLbl lbl)) tmp, - LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] - - return (Any FF32 code) - -getRegister (CmmLit (CmmFloat d W64)) = do - lbl <- getNewLabelNat - tmp <- getNewRegNat II32 - let code dst = toOL [ - LDATA (Section ReadOnlyData lbl) $ Statics lbl - [CmmStaticLit (CmmFloat d W64)], - SETHI (HI (ImmCLbl lbl)) tmp, - LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] - return (Any FF64 code) - - --- Unary machine ops -getRegister (CmmMachOp mop [x]) - = case mop of - -- Floating point negation ------------------------- - MO_F_Neg W32 -> trivialUFCode FF32 (FNEG FF32) x - MO_F_Neg W64 -> trivialUFCode FF64 (FNEG FF64) x - - - -- Integer negation -------------------------------- - MO_S_Neg rep -> trivialUCode (intFormat rep) (SUB False False g0) x - MO_Not rep -> trivialUCode (intFormat rep) (XNOR False g0) x - - - -- Float word size conversion ---------------------- - MO_FF_Conv W64 W32 -> coerceDbl2Flt x - MO_FF_Conv W32 W64 -> coerceFlt2Dbl x - - - -- Float <-> Signed Int conversion ----------------- - MO_FS_Conv from to -> coerceFP2Int from to x - MO_SF_Conv from to -> coerceInt2FP from to x - - - -- Unsigned integer word size conversions ---------- - - -- If it's the same size, then nothing needs to be done. - MO_UU_Conv from to - | from == to -> conversionNop (intFormat to) x - - -- To narrow an unsigned word, mask out the high bits to simulate what would - -- happen if we copied the value into a smaller register. - MO_UU_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - - -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8 - -- case because the only way we can load it is via SETHI, which needs 2 ops. - -- Do some shifts to chop out the high bits instead. - MO_UU_Conv W32 W16 - -> do tmpReg <- getNewRegNat II32 - (xReg, xCode) <- getSomeReg x - let code dst - = xCode - `appOL` toOL - [ SLL xReg (RIImm $ ImmInt 16) tmpReg - , SRL tmpReg (RIImm $ ImmInt 16) dst] - - return $ Any II32 code - - -- trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - - -- To widen an unsigned word we don't have to do anything. - -- Just leave it in the same register and mark the result as the new size. - MO_UU_Conv W8 W16 -> conversionNop (intFormat W16) x - MO_UU_Conv W8 W32 -> conversionNop (intFormat W32) x - MO_UU_Conv W16 W32 -> conversionNop (intFormat W32) x - - - -- Signed integer word size conversions ------------ - - -- Mask out high bits when narrowing them - MO_SS_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W16 -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - - -- Sign extend signed words when widening them. - MO_SS_Conv W8 W16 -> integerExtend W8 W16 x - MO_SS_Conv W8 W32 -> integerExtend W8 W32 x - MO_SS_Conv W16 W32 -> integerExtend W16 W32 x - - _ -> panic ("Unknown unary mach op: " ++ show mop) - - --- Binary machine ops -getRegister (CmmMachOp mop [x, y]) - = case mop of - MO_Eq _ -> condIntReg EQQ x y - MO_Ne _ -> condIntReg NE x y - - MO_S_Gt _ -> condIntReg GTT x y - MO_S_Ge _ -> condIntReg GE x y - MO_S_Lt _ -> condIntReg LTT x y - MO_S_Le _ -> condIntReg LE x y - - MO_U_Gt W32 -> condIntReg GU x y - MO_U_Ge W32 -> condIntReg GEU x y - MO_U_Lt W32 -> condIntReg LU x y - MO_U_Le W32 -> condIntReg LEU x y - - MO_U_Gt W16 -> condIntReg GU x y - MO_U_Ge W16 -> condIntReg GEU x y - MO_U_Lt W16 -> condIntReg LU x y - MO_U_Le W16 -> condIntReg LEU x y - - MO_Add W32 -> trivialCode W32 (ADD False False) x y - MO_Sub W32 -> trivialCode W32 (SUB False False) x y - - MO_S_MulMayOflo rep -> imulMayOflo rep x y - - MO_S_Quot W32 -> idiv True False x y - MO_U_Quot W32 -> idiv False False x y - - MO_S_Rem W32 -> irem True x y - MO_U_Rem W32 -> irem False x y - - MO_F_Eq _ -> condFltReg EQQ x y - MO_F_Ne _ -> condFltReg NE x y - - MO_F_Gt _ -> condFltReg GTT x y - MO_F_Ge _ -> condFltReg GE x y - MO_F_Lt _ -> condFltReg LTT x y - MO_F_Le _ -> condFltReg LE x y - - MO_F_Add w -> trivialFCode w FADD x y - MO_F_Sub w -> trivialFCode w FSUB x y - MO_F_Mul w -> trivialFCode w FMUL x y - MO_F_Quot w -> trivialFCode w FDIV x y - - MO_And rep -> trivialCode rep (AND False) x y - MO_Or rep -> trivialCode rep (OR False) x y - MO_Xor rep -> trivialCode rep (XOR False) x y - - MO_Mul rep -> trivialCode rep (SMUL False) x y - - MO_Shl rep -> trivialCode rep SLL x y - MO_U_Shr rep -> trivialCode rep SRL x y - MO_S_Shr rep -> trivialCode rep SRA x y - - _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) - -getRegister (CmmLoad mem pk) = do - Amode src code <- getAmode mem - let - code__2 dst = code `snocOL` LD (cmmTypeFormat pk) src dst - return (Any (cmmTypeFormat pk) code__2) - -getRegister (CmmLit (CmmInt i _)) - | fits13Bits i - = let - src = ImmInt (fromInteger i) - code dst = unitOL (OR False g0 (RIImm src) dst) - in - return (Any II32 code) - -getRegister (CmmLit lit) - = let imm = litToImm lit - code dst = toOL [ - SETHI (HI imm) dst, - OR False dst (RIImm (LO imm)) dst] - in return (Any II32 code) - - -getRegister _ - = panic "SPARC.CodeGen.Gen32.getRegister: no match" - - --- | sign extend and widen -integerExtend - :: Width -- ^ width of source expression - -> Width -- ^ width of result - -> CmmExpr -- ^ source expression - -> NatM Register - -integerExtend from to expr - = do -- load the expr into some register - (reg, e_code) <- getSomeReg expr - tmp <- getNewRegNat II32 - let bitCount - = case (from, to) of - (W8, W32) -> 24 - (W16, W32) -> 16 - (W8, W16) -> 24 - _ -> panic "SPARC.CodeGen.Gen32: no match" - let code dst - = e_code - - -- local shift word left to load the sign bit - `snocOL` SLL reg (RIImm (ImmInt bitCount)) tmp - - -- arithmetic shift right to sign extend - `snocOL` SRA tmp (RIImm (ImmInt bitCount)) dst - - return (Any (intFormat to) code) - - --- | For nop word format conversions we set the resulting value to have the --- required size, but don't need to generate any actual code. --- -conversionNop - :: Format -> CmmExpr -> NatM Register - -conversionNop new_rep expr - = do e_code <- getRegister expr - return (setFormatOfRegister e_code new_rep) - - - --- | Generate an integer division instruction. -idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register - --- For unsigned division with a 32 bit numerator, --- we can just clear the Y register. -idiv False cc x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) - - --- For _signed_ division with a 32 bit numerator, --- we have to sign extend the numerator into the Y register. -idiv True cc x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp -- sign extend - , SRA tmp (RIImm (ImmInt 16)) tmp - - , WRY tmp g0 - , SDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) - - --- | Do an integer remainder. --- --- NOTE: The SPARC v8 architecture manual says that integer division --- instructions _may_ generate a remainder, depending on the implementation. --- If so it is _recommended_ that the remainder is placed in the Y register. --- --- The UltraSparc 2007 manual says Y is _undefined_ after division. --- --- The SPARC T2 doesn't store the remainder, not sure about the others. --- It's probably best not to worry about it, and just generate our own --- remainders. --- -irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register - --- For unsigned operands: --- Division is between a 64 bit numerator and a 32 bit denominator, --- so we still have to clear the Y register. -irem False x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp_reg <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV False a_reg (RIReg b_reg) tmp_reg - , UMUL False tmp_reg (RIReg b_reg) tmp_reg - , SUB False False a_reg (RIReg tmp_reg) dst] - - return (Any II32 code) - - - --- For signed operands: --- Make sure to sign extend into the Y register, or the remainder --- will have the wrong sign when the numerator is negative. --- --- TODO: When sign extending, GCC only shifts the a_reg right by 17 bits, --- not the full 32. Not sure why this is, something to do with overflow? --- If anyone cares enough about the speed of signed remainder they --- can work it out themselves (then tell me). -- BL 2009/01/20 -irem True x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp1_reg <- getNewRegNat II32 - tmp2_reg <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , SRA tmp1_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , WRY tmp1_reg g0 - - , SDIV False a_reg (RIReg b_reg) tmp2_reg - , SMUL False tmp2_reg (RIReg b_reg) tmp2_reg - , SUB False False a_reg (RIReg tmp2_reg) dst] - - return (Any II32 code) - - -imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register -imulMayOflo rep a b - = do - (a_reg, a_code) <- getSomeReg a - (b_reg, b_code) <- getSomeReg b - res_lo <- getNewRegNat II32 - res_hi <- getNewRegNat II32 - - let shift_amt = case rep of - W32 -> 31 - W64 -> 63 - _ -> panic "shift_amt" - - let code dst = a_code `appOL` b_code `appOL` - toOL [ - SMUL False a_reg (RIReg b_reg) res_lo, - RDY res_hi, - SRA res_lo (RIImm (ImmInt shift_amt)) res_lo, - SUB False False res_lo (RIReg res_hi) dst - ] - return (Any II32 code) - - --- ----------------------------------------------------------------------------- --- 'trivial*Code': deal with trivial instructions - --- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', --- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. --- Only look for constants on the right hand side, because that's --- where the generic optimizer will have put them. - --- Similarly, for unary instructions, we don't have to worry about --- matching an StInt as the argument, because genericOpt will already --- have handled the constant-folding. - -trivialCode - :: Width - -> (Reg -> RI -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - -trivialCode _ instr x (CmmLit (CmmInt y _)) - | fits13Bits y - = do - (src1, code) <- getSomeReg x - let - src2 = ImmInt (fromInteger y) - code__2 dst = code `snocOL` instr src1 (RIImm src2) dst - return (Any II32 code__2) - - -trivialCode _ instr x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `snocOL` - instr src1 (RIReg src2) dst - return (Any II32 code__2) - - -trivialFCode - :: Width - -> (Format -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - -trivialFCode pk instr x y = do - dflags <- getDynFlags - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - tmp <- getNewRegNat FF64 - let - promote x = FxTOy FF32 FF64 x tmp - - pk1 = cmmExprType dflags x - pk2 = cmmExprType dflags y - - code__2 dst = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - instr (floatFormat pk) src1 src2 dst - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - instr FF64 tmp src2 dst - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - instr FF64 src1 tmp dst - return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) - code__2) - - - -trivialUCode - :: Format - -> (RI -> Reg -> Instr) - -> CmmExpr - -> NatM Register - -trivialUCode format instr x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `snocOL` instr (RIReg src) dst - return (Any format code__2) - - -trivialUFCode - :: Format - -> (Reg -> Reg -> Instr) - -> CmmExpr - -> NatM Register - -trivialUFCode pk instr x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `snocOL` instr src dst - return (Any pk code__2) - - - - --- Coercions ------------------------------------------------------------------- - --- | Coerce a integer value to floating point -coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register -coerceInt2FP width1 width2 x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - ST (intFormat width1) src (spRel (-2)), - LD (intFormat width1) (spRel (-2)) dst, - FxTOy (intFormat width1) (floatFormat width2) dst dst] - return (Any (floatFormat $ width2) code__2) - - - --- | Coerce a floating point value to integer --- --- NOTE: On sparc v9 there are no instructions to move a value from an --- FP register directly to an int register, so we have to use a load/store. --- -coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register -coerceFP2Int width1 width2 x - = do let fformat1 = floatFormat width1 - fformat2 = floatFormat width2 - - iformat2 = intFormat width2 - - (fsrc, code) <- getSomeReg x - fdst <- getNewRegNat fformat2 - - let code2 dst - = code - `appOL` toOL - -- convert float to int format, leaving it in a float reg. - [ FxTOy fformat1 iformat2 fsrc fdst - - -- store the int into mem, then load it back to move - -- it into an actual int reg. - , ST fformat2 fdst (spRel (-2)) - , LD iformat2 (spRel (-2)) dst] - - return (Any iformat2 code2) - - --- | Coerce a double precision floating point value to single precision. -coerceDbl2Flt :: CmmExpr -> NatM Register -coerceDbl2Flt x = do - (src, code) <- getSomeReg x - return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) - - --- | Coerce a single precision floating point value to double precision -coerceFlt2Dbl :: CmmExpr -> NatM Register -coerceFlt2Dbl x = do - (src, code) <- getSomeReg x - return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst)) - - - - --- Condition Codes ------------------------------------------------------------- --- --- Evaluate a comparison, and get the result into a register. --- --- Do not fill the delay slots here. you will confuse the register allocator. --- -condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register -condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] - return (Any II32 code__2) - -condIntReg EQQ x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] - return (Any II32 code__2) - -condIntReg NE x (CmmLit (CmmInt 0 _)) = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] - return (Any II32 code__2) - -condIntReg NE x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] - return (Any II32 code__2) - -condIntReg cond x y = do - bid1 <- liftM (\a -> seq a a) getBlockIdNat - bid2 <- liftM (\a -> seq a a) getBlockIdNat - CondCode _ cond cond_code <- condIntCode cond x y - let - code__2 dst - = cond_code - `appOL` toOL - [ BI cond False bid1 - , NOP - - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid2] - - return (Any II32 code__2) - - -condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register -condFltReg cond x y = do - bid1 <- liftM (\a -> seq a a) getBlockIdNat - bid2 <- liftM (\a -> seq a a) getBlockIdNat - - CondCode _ cond cond_code <- condFltCode cond x y - let - code__2 dst - = cond_code - `appOL` toOL - [ NOP - , BF cond False bid1 - , NOP - - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid2 ] - - return (Any II32 code__2) diff --git a/nativeGen/SPARC/CodeGen/Gen32.hs-boot b/nativeGen/SPARC/CodeGen/Gen32.hs-boot deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Gen32.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ - -module SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister -) - -where - -import SPARC.CodeGen.Base -import NCGMonad -import Reg - -import Cmm - -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getRegister :: CmmExpr -> NatM Register diff --git a/nativeGen/SPARC/CodeGen/Gen64.hs b/nativeGen/SPARC/CodeGen/Gen64.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Gen64.hs +++ /dev/null @@ -1,196 +0,0 @@ --- | Evaluation of 64 bit values on 32 bit platforms. -module SPARC.CodeGen.Gen64 ( - assignMem_I64Code, - assignReg_I64Code, - iselExpr64 -) - -where - -import {-# SOURCE #-} SPARC.CodeGen.Gen32 -import SPARC.CodeGen.Base -import SPARC.CodeGen.Amode -import SPARC.Regs -import SPARC.AddrMode -import SPARC.Imm -import SPARC.Instr -import SPARC.Ppr() -import NCGMonad -import Instruction -import Format -import Reg - -import Cmm - -import DynFlags -import OrdList -import Outputable - --- | Code to assign a 64 bit value to memory. -assignMem_I64Code - :: CmmExpr -- ^ expr producing the destination address - -> CmmExpr -- ^ expr producing the source value. - -> NatM InstrBlock - -assignMem_I64Code addrTree valueTree - = do - ChildCode64 vcode rlo <- iselExpr64 valueTree - - (src, acode) <- getSomeReg addrTree - let - rhi = getHiVRegFromLo rlo - - -- Big-endian store - mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0)) - mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4)) - - code = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo - -{- pprTrace "assignMem_I64Code" - (vcat [ text "addrTree: " <+> ppr addrTree - , text "valueTree: " <+> ppr valueTree - , text "vcode:" - , vcat $ map ppr $ fromOL vcode - , text "" - , text "acode:" - , vcat $ map ppr $ fromOL acode ]) - $ -} - return code - - --- | Code to assign a 64 bit value to a register. -assignReg_I64Code - :: CmmReg -- ^ the destination register - -> CmmExpr -- ^ expr producing the source value - -> NatM InstrBlock - -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree - = do - ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let - r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk) - r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = mkMOV r_src_lo r_dst_lo - mov_hi = mkMOV r_src_hi r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - - return (vcode `snocOL` mov_hi `snocOL` mov_lo) - -assignReg_I64Code _ _ - = panic "assignReg_I64Code(sparc): invalid lvalue" - - - - --- | Get the value of an expression into a 64 bit register. - -iselExpr64 :: CmmExpr -> NatM ChildCode64 - --- Load a 64 bit word -iselExpr64 (CmmLoad addrTree ty) - | isWord64 ty - = do Amode amode addr_code <- getAmode addrTree - let result - - | AddrRegReg r1 r2 <- amode - = do rlo <- getNewRegNat II32 - tmp <- getNewRegNat II32 - let rhi = getHiVRegFromLo rlo - - return $ ChildCode64 - ( addr_code - `appOL` toOL - [ ADD False False r1 (RIReg r2) tmp - , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi - , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ]) - rlo - - | AddrRegImm r1 (ImmInt i) <- amode - = do rlo <- getNewRegNat II32 - let rhi = getHiVRegFromLo rlo - - return $ ChildCode64 - ( addr_code - `appOL` toOL - [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi - , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ]) - rlo - - | otherwise - = panic "SPARC.CodeGen.Gen64: no match" - - result - - --- Add a literal to a 64 bit integer -iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) - = do ChildCode64 code1 r1_lo <- iselExpr64 e1 - let r1_hi = getHiVRegFromLo r1_lo - - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - let code = code1 - `appOL` toOL - [ ADD False True r1_lo (RIImm (ImmInteger i)) r_dst_lo - , ADD True False r1_hi (RIReg g0) r_dst_hi ] - - return $ ChildCode64 code r_dst_lo - - --- Addition of II64 -iselExpr64 (CmmMachOp (MO_Add _) [e1, e2]) - = do ChildCode64 code1 r1_lo <- iselExpr64 e1 - let r1_hi = getHiVRegFromLo r1_lo - - ChildCode64 code2 r2_lo <- iselExpr64 e2 - let r2_hi = getHiVRegFromLo r2_lo - - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - let code = code1 - `appOL` code2 - `appOL` toOL - [ ADD False True r1_lo (RIReg r2_lo) r_dst_lo - , ADD True False r1_hi (RIReg r2_hi) r_dst_hi ] - - return $ ChildCode64 code r_dst_lo - - -iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) - | isWord64 ty - = do - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_lo = RegVirtual $ mkVirtualReg uq II32 - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = mkMOV r_src_lo r_dst_lo - mov_hi = mkMOV r_src_hi r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - return ( - ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo - ) - --- Convert something into II64 -iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) - = do - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - -- compute expr and load it into r_dst_lo - (a_reg, a_code) <- getSomeReg expr - - dflags <- getDynFlags - let platform = targetPlatform dflags - code = a_code - `appOL` toOL - [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits - , mkRegRegMoveInstr platform a_reg r_dst_lo ] - - return $ ChildCode64 code r_dst_lo - - -iselExpr64 expr - = pprPanic "iselExpr64(sparc)" (ppr expr) diff --git a/nativeGen/SPARC/CodeGen/Sanity.hs b/nativeGen/SPARC/CodeGen/Sanity.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Sanity.hs +++ /dev/null @@ -1,67 +0,0 @@ --- | One ounce of sanity checking is worth 10000000000000000 ounces --- of staring blindly at assembly code trying to find the problem.. -module SPARC.CodeGen.Sanity ( - checkBlock -) - -where - -import SPARC.Instr -import SPARC.Ppr () -import Instruction - -import Cmm - -import Outputable - - --- | Enforce intra-block invariants. --- -checkBlock :: CmmBlock - -> NatBasicBlock Instr - -> NatBasicBlock Instr - -checkBlock cmm block@(BasicBlock _ instrs) - | checkBlockInstrs instrs - = block - - | otherwise - = pprPanic - ("SPARC.CodeGen: bad block\n") - ( vcat [ text " -- cmm -----------------\n" - , ppr cmm - , text " -- native code ---------\n" - , ppr block ]) - - -checkBlockInstrs :: [Instr] -> Bool -checkBlockInstrs ii - - -- An unconditional jumps end the block. - -- There must be an unconditional jump in the block, otherwise - -- the register liveness determinator will get the liveness - -- information wrong. - -- - -- If the block ends with a cmm call that never returns - -- then there can be unreachable instructions after the jump, - -- but we don't mind here. - -- - | instr : NOP : _ <- ii - , isUnconditionalJump instr - = True - - -- All jumps must have a NOP in their branch delay slot. - -- The liveness determinator and register allocators aren't smart - -- enough to handle branch delay slots. - -- - | instr : NOP : is <- ii - , isJumpishInstr instr - = checkBlockInstrs is - - -- keep checking - | _:i2:is <- ii - = checkBlockInstrs (i2:is) - - -- this block is no good - | otherwise - = False diff --git a/nativeGen/SPARC/Cond.hs b/nativeGen/SPARC/Cond.hs deleted file mode 100644 --- a/nativeGen/SPARC/Cond.hs +++ /dev/null @@ -1,52 +0,0 @@ -module SPARC.Cond ( - Cond(..), - condUnsigned, - condToSigned, - condToUnsigned -) - -where - --- | Branch condition codes. -data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - | NEG - | NEVER - | POS - | VC - | VS - deriving Eq - - -condUnsigned :: Cond -> Bool -condUnsigned GU = True -condUnsigned LU = True -condUnsigned GEU = True -condUnsigned LEU = True -condUnsigned _ = False - - -condToSigned :: Cond -> Cond -condToSigned GU = GTT -condToSigned LU = LTT -condToSigned GEU = GE -condToSigned LEU = LE -condToSigned x = x - - -condToUnsigned :: Cond -> Cond -condToUnsigned GTT = GU -condToUnsigned LTT = LU -condToUnsigned GE = GEU -condToUnsigned LE = LEU -condToUnsigned x = x diff --git a/nativeGen/SPARC/Imm.hs b/nativeGen/SPARC/Imm.hs deleted file mode 100644 --- a/nativeGen/SPARC/Imm.hs +++ /dev/null @@ -1,65 +0,0 @@ -module SPARC.Imm ( - -- immediate values - Imm(..), - strImmLit, - litToImm -) - -where - -import Cmm -import CLabel - -import Outputable - --- | An immediate value. --- Not all of these are directly representable by the machine. --- Things like ImmLit are slurped out and put in a data segment instead. --- -data Imm - = ImmInt Int - - -- Sigh. - | ImmInteger Integer - - -- AbstractC Label (with baggage) - | ImmCLbl CLabel - - -- Simple string - | ImmLit SDoc - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational - - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm - - | LO Imm - | HI Imm - - --- | Create a ImmLit containing this string. -strImmLit :: String -> Imm -strImmLit s = ImmLit (text s) - - --- | Convert a CmmLit to an Imm. --- Narrow to the width: a CmmInt might be out of --- range, but we assume that ImmInteger only contains --- in-range values. A signed value should be fine here. --- -litToImm :: CmmLit -> Imm -litToImm lit - = case lit of - CmmInt i w -> ImmInteger (narrowS w i) - CmmFloat f W32 -> ImmFloat f - CmmFloat f W64 -> ImmDouble f - CmmLabel l -> ImmCLbl l - CmmLabelOff l off -> ImmIndex l off - - CmmLabelDiffOff l1 l2 off - -> ImmConstantSum - (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) - (ImmInt off) - - _ -> panic "SPARC.Regs.litToImm: no match" diff --git a/nativeGen/SPARC/Instr.hs b/nativeGen/SPARC/Instr.hs deleted file mode 100644 --- a/nativeGen/SPARC/Instr.hs +++ /dev/null @@ -1,483 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Machine-dependent assembly language --- --- (c) The University of Glasgow 1993-2004 --- ------------------------------------------------------------------------------ -#include "HsVersions.h" -#include "nativeGen/NCG.h" - -module SPARC.Instr ( - RI(..), - riZero, - - fpRelEA, - moveSp, - - isUnconditionalJump, - - Instr(..), - maxSpillSlots -) - -where - -import SPARC.Stack -import SPARC.Imm -import SPARC.AddrMode -import SPARC.Cond -import SPARC.Regs -import SPARC.Base -import TargetReg -import Instruction -import RegClass -import Reg -import Format - -import CLabel -import CodeGen.Platform -import BlockId -import DynFlags -import Cmm -import FastString -import Outputable -import Platform - - --- | Register or immediate -data RI - = RIReg Reg - | RIImm Imm - --- | Check if a RI represents a zero value. --- - a literal zero --- - register %g0, which is always zero. --- -riZero :: RI -> Bool -riZero (RIImm (ImmInt 0)) = True -riZero (RIImm (ImmInteger 0)) = True -riZero (RIReg (RegReal (RealRegSingle 0))) = True -riZero _ = False - - --- | Calculate the effective address which would be used by the --- corresponding fpRel sequence. -fpRelEA :: Int -> Reg -> Instr -fpRelEA n dst - = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst - - --- | Code to shift the stack pointer by n words. -moveSp :: Int -> Instr -moveSp n - = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp - --- | An instruction that will cause the one after it never to be exectuted -isUnconditionalJump :: Instr -> Bool -isUnconditionalJump ii - = case ii of - CALL{} -> True - JMP{} -> True - JMP_TBL{} -> True - BI ALWAYS _ _ -> True - BF ALWAYS _ _ -> True - _ -> False - - --- | instance for sparc instruction set -instance Instruction Instr where - regUsageOfInstr = sparc_regUsageOfInstr - patchRegsOfInstr = sparc_patchRegsOfInstr - isJumpishInstr = sparc_isJumpishInstr - jumpDestsOfInstr = sparc_jumpDestsOfInstr - patchJumpInstr = sparc_patchJumpInstr - mkSpillInstr = sparc_mkSpillInstr - mkLoadInstr = sparc_mkLoadInstr - takeDeltaInstr = sparc_takeDeltaInstr - isMetaInstr = sparc_isMetaInstr - mkRegRegMoveInstr = sparc_mkRegRegMoveInstr - takeRegRegMoveInstr = sparc_takeRegRegMoveInstr - mkJumpInstr = sparc_mkJumpInstr - mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" - mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" - - --- | SPARC instruction set. --- Not complete. This is only the ones we need. --- -data Instr - - -- meta ops -------------------------------------------------- - -- comment pseudo-op - = COMMENT FastString - - -- some static data spat out during code generation. - -- Will be extracted before pretty-printing. - | LDATA Section CmmStatics - - -- Start a new basic block. Useful during codegen, removed later. - -- Preceding instruction should be a jump, as per the invariants - -- for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- specify current stack offset for benefit of subsequent passes. - | DELTA Int - - -- real instrs ----------------------------------------------- - -- Loads and stores. - | LD Format AddrMode Reg -- format, src, dst - | ST Format Reg AddrMode -- format, src, dst - - -- Int Arithmetic. - -- x: add/sub with carry bit. - -- In SPARC V9 addx and friends were renamed addc. - -- - -- cc: modify condition codes - -- - | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - - | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst - | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst - - - -- The SPARC divide instructions perform 64bit by 32bit division - -- The Y register is xored into the first operand. - - -- On _some implementations_ the Y register is overwritten by - -- the remainder, so we have to make sure it is 0 each time. - - -- dst <- ((Y `shiftL` 32) `or` src1) `div` src2 - | UDIV Bool Reg RI Reg -- cc?, src1, src2, dst - | SDIV Bool Reg RI Reg -- cc?, src1, src2, dst - - | RDY Reg -- move contents of Y register to reg - | WRY Reg Reg -- Y <- src1 `xor` src2 - - -- Logic operations. - | AND Bool Reg RI Reg -- cc?, src1, src2, dst - | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst - | OR Bool Reg RI Reg -- cc?, src1, src2, dst - | ORN Bool Reg RI Reg -- cc?, src1, src2, dst - | XOR Bool Reg RI Reg -- cc?, src1, src2, dst - | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst - | SLL Reg RI Reg -- src1, src2, dst - | SRL Reg RI Reg -- src1, src2, dst - | SRA Reg RI Reg -- src1, src2, dst - - -- Load immediates. - | SETHI Imm Reg -- src, dst - - -- Do nothing. - -- Implemented by the assembler as SETHI 0, %g0, but worth an alias - | NOP - - -- Float Arithmetic. - -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single - -- instructions right up until we spit them out. - -- - | FABS Format Reg Reg -- src dst - | FADD Format Reg Reg Reg -- src1, src2, dst - | FCMP Bool Format Reg Reg -- exception?, src1, src2, dst - | FDIV Format Reg Reg Reg -- src1, src2, dst - | FMOV Format Reg Reg -- src, dst - | FMUL Format Reg Reg Reg -- src1, src2, dst - | FNEG Format Reg Reg -- src, dst - | FSQRT Format Reg Reg -- src, dst - | FSUB Format Reg Reg Reg -- src1, src2, dst - | FxTOy Format Format Reg Reg -- src, dst - - -- Jumping around. - | BI Cond Bool BlockId -- cond, annul?, target - | BF Cond Bool BlockId -- cond, annul?, target - - | JMP AddrMode -- target - - -- With a tabled jump we know all the possible destinations. - -- We also need this info so we can work out what regs are live across the jump. - -- - | JMP_TBL AddrMode [Maybe BlockId] CLabel - - | CALL (Either Imm Reg) Int Bool -- target, args, terminal - - --- | regUsage returns the sets of src and destination registers used --- by a particular instruction. Machine registers that are --- pre-allocated to stgRegs are filtered out, because they are --- uninteresting from a register allocation standpoint. (We wouldn't --- want them to end up on the free list!) As far as we are concerned, --- the fixed registers simply don't exist (for allocation purposes, --- anyway). - --- regUsage doesn't need to do any trickery for jumps and such. Just --- state precisely the regs read and written by that insn. The --- consequences of control flow transfers, as far as register --- allocation goes, are taken care of by the register allocator. --- -sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage -sparc_regUsageOfInstr platform instr - = case instr of - LD _ addr reg -> usage (regAddr addr, [reg]) - ST _ reg addr -> usage (reg : regAddr addr, []) - ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - RDY rd -> usage ([], [rd]) - WRY r1 r2 -> usage ([r1, r2], []) - AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SETHI _ reg -> usage ([], [reg]) - FABS _ r1 r2 -> usage ([r1], [r2]) - FADD _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FCMP _ _ r1 r2 -> usage ([r1, r2], []) - FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FMOV _ r1 r2 -> usage ([r1], [r2]) - FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FNEG _ r1 r2 -> usage ([r1], [r2]) - FSQRT _ r1 r2 -> usage ([r1], [r2]) - FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FxTOy _ _ r1 r2 -> usage ([r1], [r2]) - - JMP addr -> usage (regAddr addr, []) - JMP_TBL addr _ _ -> usage (regAddr addr, []) - - CALL (Left _ ) _ True -> noUsage - CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) - CALL (Right reg) _ True -> usage ([reg], []) - CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs) - _ -> noUsage - - where - usage (src, dst) - = RU (filter (interesting platform) src) - (filter (interesting platform) dst) - - regAddr (AddrRegReg r1 r2) = [r1, r2] - regAddr (AddrRegImm r1 _) = [r1] - - regRI (RIReg r) = [r] - regRI _ = [] - - --- | Interesting regs are virtuals, or ones that are allocatable --- by the register allocator. -interesting :: Platform -> Reg -> Bool -interesting platform reg - = case reg of - RegVirtual _ -> True - RegReal (RealRegSingle r1) -> freeReg platform r1 - RegReal (RealRegPair r1 _) -> freeReg platform r1 - - - --- | Apply a given mapping to tall the register references in this instruction. -sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr -sparc_patchRegsOfInstr instr env = case instr of - LD fmt addr reg -> LD fmt (fixAddr addr) (env reg) - ST fmt reg addr -> ST fmt (env reg) (fixAddr addr) - - ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) - SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) - UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2) - SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2) - UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2) - SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2) - RDY rd -> RDY (env rd) - WRY r1 r2 -> WRY (env r1) (env r2) - AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) - ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) - OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) - ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) - XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) - XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) - SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) - SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) - SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) - - SETHI imm reg -> SETHI imm (env reg) - - FABS s r1 r2 -> FABS s (env r1) (env r2) - FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) - FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) - FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) - FMOV s r1 r2 -> FMOV s (env r1) (env r2) - FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) - FNEG s r1 r2 -> FNEG s (env r1) (env r2) - FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) - FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) - FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) - - JMP addr -> JMP (fixAddr addr) - JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l - - CALL (Left i) n t -> CALL (Left i) n t - CALL (Right r) n t -> CALL (Right (env r)) n t - _ -> instr - - where - fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - - fixRI (RIReg r) = RIReg (env r) - fixRI other = other - - --------------------------------------------------------------------------------- -sparc_isJumpishInstr :: Instr -> Bool -sparc_isJumpishInstr instr - = case instr of - BI{} -> True - BF{} -> True - JMP{} -> True - JMP_TBL{} -> True - CALL{} -> True - _ -> False - -sparc_jumpDestsOfInstr :: Instr -> [BlockId] -sparc_jumpDestsOfInstr insn - = case insn of - BI _ _ id -> [id] - BF _ _ id -> [id] - JMP_TBL _ ids _ -> [id | Just id <- ids] - _ -> [] - - -sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr -sparc_patchJumpInstr insn patchF - = case insn of - BI cc annul id -> BI cc annul (patchF id) - BF cc annul id -> BF cc annul (patchF id) - JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l - _ -> insn - - --------------------------------------------------------------------------------- --- | Make a spill instruction. --- On SPARC we spill below frame pointer leaving 2 words/spill -sparc_mkSpillInstr - :: DynFlags - -> Reg -- ^ register to spill - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr - -sparc_mkSpillInstr dflags reg _ slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot - off_w = 1 + (off `div` 4) - fmt = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - _ -> panic "sparc_mkSpillInstr" - - in ST fmt reg (fpRel (negate off_w)) - - --- | Make a spill reload instruction. -sparc_mkLoadInstr - :: DynFlags - -> Reg -- ^ register to load into - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr - -sparc_mkLoadInstr dflags reg _ slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot - off_w = 1 + (off `div` 4) - fmt = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - _ -> panic "sparc_mkLoadInstr" - - in LD fmt (fpRel (- off_w)) reg - - --------------------------------------------------------------------------------- --- | See if this instruction is telling us the current C stack delta -sparc_takeDeltaInstr - :: Instr - -> Maybe Int - -sparc_takeDeltaInstr instr - = case instr of - DELTA i -> Just i - _ -> Nothing - - -sparc_isMetaInstr - :: Instr - -> Bool - -sparc_isMetaInstr instr - = case instr of - COMMENT{} -> True - LDATA{} -> True - NEWBLOCK{} -> True - DELTA{} -> True - _ -> False - - --- | Make a reg-reg move instruction. --- On SPARC v8 there are no instructions to move directly between --- floating point and integer regs. If we need to do that then we --- have to go via memory. --- -sparc_mkRegRegMoveInstr - :: Platform - -> Reg - -> Reg - -> Instr - -sparc_mkRegRegMoveInstr platform src dst - | srcClass <- targetClassOfReg platform src - , dstClass <- targetClassOfReg platform dst - , srcClass == dstClass - = case srcClass of - RcInteger -> ADD False False src (RIReg g0) dst - RcDouble -> FMOV FF64 src dst - RcFloat -> FMOV FF32 src dst - _ -> panic "sparc_mkRegRegMoveInstr" - - | otherwise - = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" - - --- | Check whether an instruction represents a reg-reg move. --- The register allocator attempts to eliminate reg->reg moves whenever it can, --- by assigning the src and dest temporaries to the same real register. --- -sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) -sparc_takeRegRegMoveInstr instr - = case instr of - ADD False False src (RIReg src2) dst - | g0 == src2 -> Just (src, dst) - - FMOV FF64 src dst -> Just (src, dst) - FMOV FF32 src dst -> Just (src, dst) - _ -> Nothing - - --- | Make an unconditional branch instruction. -sparc_mkJumpInstr - :: BlockId - -> [Instr] - -sparc_mkJumpInstr id - = [BI ALWAYS False id - , NOP] -- fill the branch delay slot. diff --git a/nativeGen/SPARC/Ppr.hs b/nativeGen/SPARC/Ppr.hs deleted file mode 100644 --- a/nativeGen/SPARC/Ppr.hs +++ /dev/null @@ -1,647 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Pretty-printing assembly language --- --- (c) The University of Glasgow 1993-2005 --- ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module SPARC.Ppr ( - pprNatCmmDecl, - pprBasicBlock, - pprData, - pprInstr, - pprFormat, - pprImm, - pprDataItem -) - -where - -#include "HsVersions.h" -#include "nativeGen/NCG.h" - -import SPARC.Regs -import SPARC.Instr -import SPARC.Cond -import SPARC.Imm -import SPARC.AddrMode -import SPARC.Base -import Instruction -import Reg -import Format -import PprBase - -import Cmm hiding (topInfoTable) -import PprCmm() -import CLabel -import Hoopl - -import Unique ( Uniquable(..), pprUniqueAlways ) -import Outputable -import Platform -import FastString -import Data.Word - --- ----------------------------------------------------------------------------- --- Printing this stuff out - -pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc -pprNatCmmDecl (CmmData section dats) = - pprSectionAlign section $$ pprDatas dats - -pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - case topInfoTable proc of - Nothing -> - case blocks of - [] -> -- special case for split markers: - pprLabel lbl - blocks -> -- special case for code without info table: - pprSectionAlign (Section Text lbl) $$ - pprLabel lbl $$ -- blocks guaranteed not null, so label needed - vcat (map (pprBasicBlock top_info) blocks) - - Just (Statics info_lbl _) -> - sdocWithPlatform $ \platform -> - (if platformHasSubsectionsViaSymbols platform - then pprSectionAlign dspSection $$ - ppr (mkDeadStripPreventer info_lbl) <> char ':' - else empty) $$ - vcat (map (pprBasicBlock top_info) blocks) $$ - -- above: Even the first block gets a label, because with branch-chain - -- elimination, it might be the target of a goto. - (if platformHasSubsectionsViaSymbols platform - then - -- See Note [Subsections Via Symbols] in X86/Ppr.hs - text "\t.long " - <+> ppr info_lbl - <+> char '-' - <+> ppr (mkDeadStripPreventer info_lbl) - else empty) - -dspSection :: Section -dspSection = Section Text $ - panic "subsections-via-symbols doesn't combine with split-sections" - -pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock info_env (BasicBlock blockid instrs) - = maybe_infotable $$ - pprLabel (mkAsmTempLabel (getUnique blockid)) $$ - vcat (map pprInstr instrs) - where - maybe_infotable = case mapLookup blockid info_env of - Nothing -> empty - Just (Statics info_lbl info) -> - pprAlignForSection Text $$ - vcat (map pprData info) $$ - pprLabel info_lbl - - -pprDatas :: CmmStatics -> SDoc -pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) - -pprData :: CmmStatic -> SDoc -pprData (CmmString str) = pprASCII str -pprData (CmmUninitialised bytes) = text ".skip " <> int bytes -pprData (CmmStaticLit lit) = pprDataItem lit - -pprGloblDecl :: CLabel -> SDoc -pprGloblDecl lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".global " <> ppr lbl - -pprTypeAndSizeDecl :: CLabel -> SDoc -pprTypeAndSizeDecl lbl - = sdocWithPlatform $ \platform -> - if platformOS platform == OSLinux && externallyVisibleCLabel lbl - then text ".type " <> ppr lbl <> ptext (sLit ", @object") - else empty - -pprLabel :: CLabel -> SDoc -pprLabel lbl = pprGloblDecl lbl - $$ pprTypeAndSizeDecl lbl - $$ (ppr lbl <> char ':') - - -pprASCII :: [Word8] -> SDoc -pprASCII str - = vcat (map do1 str) $$ do1 0 - where - do1 :: Word8 -> SDoc - do1 w = text "\t.byte\t" <> int (fromIntegral w) - - --- ----------------------------------------------------------------------------- --- pprInstr: print an 'Instr' - -instance Outputable Instr where - ppr instr = pprInstr instr - - --- | Pretty print a register. -pprReg :: Reg -> SDoc -pprReg reg - = case reg of - RegVirtual vr - -> case vr of - VirtualRegI u -> text "%vI_" <> pprUniqueAlways u - VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u - VirtualRegF u -> text "%vF_" <> pprUniqueAlways u - VirtualRegD u -> text "%vD_" <> pprUniqueAlways u - VirtualRegSSE u -> text "%vSSE_" <> pprUniqueAlways u - - RegReal rr - -> case rr of - RealRegSingle r1 - -> pprReg_ofRegNo r1 - - RealRegPair r1 r2 - -> text "(" <> pprReg_ofRegNo r1 - <> vbar <> pprReg_ofRegNo r2 - <> text ")" - - - --- | Pretty print a register name, based on this register number. --- The definition has been unfolded so we get a jump-table in the --- object code. This function is called quite a lot when emitting --- the asm file.. --- -pprReg_ofRegNo :: Int -> SDoc -pprReg_ofRegNo i - = ptext - (case i of { - 0 -> sLit "%g0"; 1 -> sLit "%g1"; - 2 -> sLit "%g2"; 3 -> sLit "%g3"; - 4 -> sLit "%g4"; 5 -> sLit "%g5"; - 6 -> sLit "%g6"; 7 -> sLit "%g7"; - 8 -> sLit "%o0"; 9 -> sLit "%o1"; - 10 -> sLit "%o2"; 11 -> sLit "%o3"; - 12 -> sLit "%o4"; 13 -> sLit "%o5"; - 14 -> sLit "%o6"; 15 -> sLit "%o7"; - 16 -> sLit "%l0"; 17 -> sLit "%l1"; - 18 -> sLit "%l2"; 19 -> sLit "%l3"; - 20 -> sLit "%l4"; 21 -> sLit "%l5"; - 22 -> sLit "%l6"; 23 -> sLit "%l7"; - 24 -> sLit "%i0"; 25 -> sLit "%i1"; - 26 -> sLit "%i2"; 27 -> sLit "%i3"; - 28 -> sLit "%i4"; 29 -> sLit "%i5"; - 30 -> sLit "%i6"; 31 -> sLit "%i7"; - 32 -> sLit "%f0"; 33 -> sLit "%f1"; - 34 -> sLit "%f2"; 35 -> sLit "%f3"; - 36 -> sLit "%f4"; 37 -> sLit "%f5"; - 38 -> sLit "%f6"; 39 -> sLit "%f7"; - 40 -> sLit "%f8"; 41 -> sLit "%f9"; - 42 -> sLit "%f10"; 43 -> sLit "%f11"; - 44 -> sLit "%f12"; 45 -> sLit "%f13"; - 46 -> sLit "%f14"; 47 -> sLit "%f15"; - 48 -> sLit "%f16"; 49 -> sLit "%f17"; - 50 -> sLit "%f18"; 51 -> sLit "%f19"; - 52 -> sLit "%f20"; 53 -> sLit "%f21"; - 54 -> sLit "%f22"; 55 -> sLit "%f23"; - 56 -> sLit "%f24"; 57 -> sLit "%f25"; - 58 -> sLit "%f26"; 59 -> sLit "%f27"; - 60 -> sLit "%f28"; 61 -> sLit "%f29"; - 62 -> sLit "%f30"; 63 -> sLit "%f31"; - _ -> sLit "very naughty sparc register" }) - - --- | Pretty print a format for an instruction suffix. -pprFormat :: Format -> SDoc -pprFormat x - = ptext - (case x of - II8 -> sLit "ub" - II16 -> sLit "uh" - II32 -> sLit "" - II64 -> sLit "d" - FF32 -> sLit "" - FF64 -> sLit "d" - _ -> panic "SPARC.Ppr.pprFormat: no match") - - --- | Pretty print a format for an instruction suffix. --- eg LD is 32bit on sparc, but LDD is 64 bit. -pprStFormat :: Format -> SDoc -pprStFormat x - = ptext - (case x of - II8 -> sLit "b" - II16 -> sLit "h" - II32 -> sLit "" - II64 -> sLit "x" - FF32 -> sLit "" - FF64 -> sLit "d" - _ -> panic "SPARC.Ppr.pprFormat: no match") - - --- | Pretty print a condition code. -pprCond :: Cond -> SDoc -pprCond c - = ptext - (case c of - ALWAYS -> sLit "" - NEVER -> sLit "n" - GEU -> sLit "geu" - LU -> sLit "lu" - EQQ -> sLit "e" - GTT -> sLit "g" - GE -> sLit "ge" - GU -> sLit "gu" - LTT -> sLit "l" - LE -> sLit "le" - LEU -> sLit "leu" - NE -> sLit "ne" - NEG -> sLit "neg" - POS -> sLit "pos" - VC -> sLit "vc" - VS -> sLit "vs") - - --- | Pretty print an address mode. -pprAddr :: AddrMode -> SDoc -pprAddr am - = case am of - AddrRegReg r1 (RegReal (RealRegSingle 0)) - -> pprReg r1 - - AddrRegReg r1 r2 - -> hcat [ pprReg r1, char '+', pprReg r2 ] - - AddrRegImm r1 (ImmInt i) - | i == 0 -> pprReg r1 - | not (fits13Bits i) -> largeOffsetError i - | otherwise -> hcat [ pprReg r1, pp_sign, int i ] - where - pp_sign = if i > 0 then char '+' else empty - - AddrRegImm r1 (ImmInteger i) - | i == 0 -> pprReg r1 - | not (fits13Bits i) -> largeOffsetError i - | otherwise -> hcat [ pprReg r1, pp_sign, integer i ] - where - pp_sign = if i > 0 then char '+' else empty - - AddrRegImm r1 imm - -> hcat [ pprReg r1, char '+', pprImm imm ] - - --- | Pretty print an immediate value. -pprImm :: Imm -> SDoc -pprImm imm - = case imm of - ImmInt i -> int i - ImmInteger i -> integer i - ImmCLbl l -> ppr l - ImmIndex l i -> ppr l <> char '+' <> int i - ImmLit s -> s - - ImmConstantSum a b - -> pprImm a <> char '+' <> pprImm b - - ImmConstantDiff a b - -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen - - LO i - -> hcat [ text "%lo(", pprImm i, rparen ] - - HI i - -> hcat [ text "%hi(", pprImm i, rparen ] - - -- these should have been converted to bytes and placed - -- in the data section. - ImmFloat _ -> text "naughty float immediate" - ImmDouble _ -> text "naughty double immediate" - - --- | Pretty print a section \/ segment header. --- On SPARC all the data sections must be at least 8 byte aligned --- incase we store doubles in them. --- -pprSectionAlign :: Section -> SDoc -pprSectionAlign sec@(Section seg _) = - sdocWithPlatform $ \platform -> - pprSectionHeader platform sec $$ - pprAlignForSection seg - --- | Print appropriate alignment for the given section type. -pprAlignForSection :: SectionType -> SDoc -pprAlignForSection seg = - ptext (case seg of - Text -> sLit ".align 4" - Data -> sLit ".align 8" - ReadOnlyData -> sLit ".align 8" - RelocatableReadOnlyData - -> sLit ".align 8" - UninitialisedData -> sLit ".align 8" - ReadOnlyData16 -> sLit ".align 16" - -- TODO: This is copied from the ReadOnlyData case, but it can likely be - -- made more efficient. - CString -> sLit ".align 8" - OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section") - --- | Pretty print a data item. -pprDataItem :: CmmLit -> SDoc -pprDataItem lit - = sdocWithDynFlags $ \dflags -> - vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit) - where - imm = litToImm lit - - ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] - ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] - - ppr_item FF32 (CmmFloat r _) - = let bs = floatToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item FF64 (CmmFloat r _) - = let bs = doubleToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item II16 _ = [text "\t.short\t" <> pprImm imm] - ppr_item II64 _ = [text "\t.quad\t" <> pprImm imm] - ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match" - - --- | Pretty print an instruction. -pprInstr :: Instr -> SDoc - --- nuke comments. -pprInstr (COMMENT _) - = empty - -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) - --- Newblocks and LData should have been slurped out before producing the .s file. -pprInstr (NEWBLOCK _) - = panic "X86.Ppr.pprInstr: NEWBLOCK" - -pprInstr (LDATA _ _) - = panic "PprMach.pprInstr: LDATA" - --- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand -pprInstr (LD FF64 _ reg) - | RegReal (RealRegSingle{}) <- reg - = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" - -pprInstr (LD format addr reg) - = hcat [ - text "\tld", - pprFormat format, - char '\t', - lbrack, - pprAddr addr, - pp_rbracket_comma, - pprReg reg - ] - --- 64 bit FP storees are expanded into individual instructions in CodeGen.Expand -pprInstr (ST FF64 reg _) - | RegReal (RealRegSingle{}) <- reg - = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" - --- no distinction is made between signed and unsigned bytes on stores for the --- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), --- so we call a special-purpose pprFormat for ST.. -pprInstr (ST format reg addr) - = hcat [ - text "\tst", - pprStFormat format, - char '\t', - pprReg reg, - pp_comma_lbracket, - pprAddr addr, - rbrack - ] - - -pprInstr (ADD x cc reg1 ri reg2) - | not x && not cc && riZero ri - = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] - - | otherwise - = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2 - - -pprInstr (SUB x cc reg1 ri reg2) - | not x && cc && reg2 == g0 - = hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI ri ] - - | not x && not cc && riZero ri - = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] - - | otherwise - = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2 - -pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2 - -pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2 - -pprInstr (OR b reg1 ri reg2) - | not b && reg1 == g0 - = let doit = hcat [ text "\tmov\t", pprRI ri, comma, pprReg reg2 ] - in case ri of - RIReg rrr | rrr == reg2 -> empty - _ -> doit - - | otherwise - = pprRegRIReg (sLit "or") b reg1 ri reg2 - -pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2 - -pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2 -pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2 - -pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2 -pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2 -pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2 - -pprInstr (RDY rd) = text "\trd\t%y," <> pprReg rd -pprInstr (WRY reg1 reg2) - = text "\twr\t" - <> pprReg reg1 - <> char ',' - <> pprReg reg2 - <> char ',' - <> text "%y" - -pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2 -pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2 -pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2 -pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2 - -pprInstr (SETHI imm reg) - = hcat [ - text "\tsethi\t", - pprImm imm, - comma, - pprReg reg - ] - -pprInstr NOP - = text "\tnop" - -pprInstr (FABS format reg1 reg2) - = pprFormatRegReg (sLit "fabs") format reg1 reg2 - -pprInstr (FADD format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3 - -pprInstr (FCMP e format reg1 reg2) - = pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp") - format reg1 reg2 - -pprInstr (FDIV format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3 - -pprInstr (FMOV format reg1 reg2) - = pprFormatRegReg (sLit "fmov") format reg1 reg2 - -pprInstr (FMUL format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3 - -pprInstr (FNEG format reg1 reg2) - = pprFormatRegReg (sLit "fneg") format reg1 reg2 - -pprInstr (FSQRT format reg1 reg2) - = pprFormatRegReg (sLit "fsqrt") format reg1 reg2 - -pprInstr (FSUB format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3 - -pprInstr (FxTOy format1 format2 reg1 reg2) - = hcat [ - text "\tf", - ptext - (case format1 of - II32 -> sLit "ito" - FF32 -> sLit "sto" - FF64 -> sLit "dto" - _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), - ptext - (case format2 of - II32 -> sLit "i\t" - II64 -> sLit "x\t" - FF32 -> sLit "s\t" - FF64 -> sLit "d\t" - _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), - pprReg reg1, comma, pprReg reg2 - ] - - -pprInstr (BI cond b blockid) - = hcat [ - text "\tb", pprCond cond, - if b then pp_comma_a else empty, - char '\t', - ppr (mkAsmTempLabel (getUnique blockid)) - ] - -pprInstr (BF cond b blockid) - = hcat [ - text "\tfb", pprCond cond, - if b then pp_comma_a else empty, - char '\t', - ppr (mkAsmTempLabel (getUnique blockid)) - ] - -pprInstr (JMP addr) = text "\tjmp\t" <> pprAddr addr -pprInstr (JMP_TBL op _ _) = pprInstr (JMP op) - -pprInstr (CALL (Left imm) n _) - = hcat [ text "\tcall\t", pprImm imm, comma, int n ] - -pprInstr (CALL (Right reg) n _) - = hcat [ text "\tcall\t", pprReg reg, comma, int n ] - - --- | Pretty print a RI -pprRI :: RI -> SDoc -pprRI (RIReg r) = pprReg r -pprRI (RIImm r) = pprImm r - - --- | Pretty print a two reg instruction. -pprFormatRegReg :: LitString -> 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 :: LitString -> 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 :: LitString -> Bool -> Reg -> RI -> Reg -> SDoc -pprRegRIReg name b reg1 ri reg2 - = hcat [ - char '\t', - ptext name, - if b then text "cc\t" else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -{- -pprRIReg :: LitString -> Bool -> RI -> Reg -> SDoc -pprRIReg name b ri reg1 - = hcat [ - char '\t', - ptext name, - if b then text "cc\t" else char '\t', - pprRI ri, - comma, - pprReg reg1 - ] --} - -{- -pp_ld_lbracket :: SDoc -pp_ld_lbracket = text "\tld\t[" --} - -pp_rbracket_comma :: SDoc -pp_rbracket_comma = text "]," - - -pp_comma_lbracket :: SDoc -pp_comma_lbracket = text ",[" - - -pp_comma_a :: SDoc -pp_comma_a = text ",a" - diff --git a/nativeGen/SPARC/Regs.hs b/nativeGen/SPARC/Regs.hs deleted file mode 100644 --- a/nativeGen/SPARC/Regs.hs +++ /dev/null @@ -1,259 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1994-2004 --- --- ----------------------------------------------------------------------------- - -module SPARC.Regs ( - -- registers - showReg, - virtualRegSqueeze, - realRegSqueeze, - classOfRealReg, - allRealRegs, - - -- machine specific info - gReg, iReg, lReg, oReg, fReg, - fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27, - - -- allocatable - allocatableRegs, - - -- args - argRegs, - allArgRegs, - callClobberedRegs, - - -- - mkVirtualReg, - regDotColor -) - -where - - -import CodeGen.Platform.SPARC -import Reg -import RegClass -import Format - -import Unique -import Outputable - -{- - The SPARC has 64 registers of interest; 32 integer registers and 32 - floating point registers. The mapping of STG registers to SPARC - machine registers is defined in StgRegs.h. We are, of course, - prepared for any eventuality. - - The whole fp-register pairing thing on sparcs is a huge nuisance. See - includes/stg/MachRegs.h for a description of what's going on - here. --} - - --- | Get the standard name for the register with this number. -showReg :: RegNo -> String -showReg n - | n >= 0 && n < 8 = "%g" ++ show n - | n >= 8 && n < 16 = "%o" ++ show (n-8) - | n >= 16 && n < 24 = "%l" ++ show (n-16) - | n >= 24 && n < 32 = "%i" ++ show (n-24) - | n >= 32 && n < 64 = "%f" ++ show (n-32) - | otherwise = panic "SPARC.Regs.showReg: unknown sparc register" - - --- Get the register class of a certain real reg -classOfRealReg :: RealReg -> RegClass -classOfRealReg reg - = case reg of - RealRegSingle i - | i < 32 -> RcInteger - | otherwise -> RcFloat - - RealRegPair{} -> RcDouble - - --- | regSqueeze_class reg --- Calculuate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. --- -{-# INLINE virtualRegSqueeze #-} -virtualRegSqueeze :: RegClass -> VirtualReg -> Int - -virtualRegSqueeze cls vr - = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> 1 - VirtualRegHi{} -> 1 - _other -> 0 - - RcFloat - -> case vr of - VirtualRegF{} -> 1 - VirtualRegD{} -> 2 - _other -> 0 - - RcDouble - -> case vr of - VirtualRegF{} -> 1 - VirtualRegD{} -> 1 - _other -> 0 - - _other -> 0 - -{-# INLINE realRegSqueeze #-} -realRegSqueeze :: RegClass -> RealReg -> Int - -realRegSqueeze cls rr - = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 1 - | otherwise -> 0 - - RealRegPair{} -> 0 - - RcFloat - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 0 - | otherwise -> 1 - - RealRegPair{} -> 2 - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 0 - | otherwise -> 1 - - RealRegPair{} -> 1 - - _other -> 0 - --- | All the allocatable registers in the machine, --- including register pairs. -allRealRegs :: [RealReg] -allRealRegs - = [ (RealRegSingle i) | i <- [0..63] ] - ++ [ (RealRegPair i (i+1)) | i <- [32, 34 .. 62 ] ] - - --- | Get the regno for this sort of reg -gReg, lReg, iReg, oReg, fReg :: Int -> RegNo - -gReg x = x -- global regs -oReg x = (8 + x) -- output regs -lReg x = (16 + x) -- local regs -iReg x = (24 + x) -- input regs -fReg x = (32 + x) -- float regs - - --- | Some specific regs used by the code generator. -g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg - -f6 = RegReal (RealRegSingle (fReg 6)) -f8 = RegReal (RealRegSingle (fReg 8)) -f22 = RegReal (RealRegSingle (fReg 22)) -f26 = RegReal (RealRegSingle (fReg 26)) -f27 = RegReal (RealRegSingle (fReg 27)) - --- g0 is always zero, and writes to it vanish. -g0 = RegReal (RealRegSingle (gReg 0)) -g1 = RegReal (RealRegSingle (gReg 1)) -g2 = RegReal (RealRegSingle (gReg 2)) - --- FP, SP, int and float return (from C) regs. -fp = RegReal (RealRegSingle (iReg 6)) -sp = RegReal (RealRegSingle (oReg 6)) -o0 = RegReal (RealRegSingle (oReg 0)) -o1 = RegReal (RealRegSingle (oReg 1)) -f0 = RegReal (RealRegSingle (fReg 0)) -f1 = RegReal (RealRegSingle (fReg 1)) - --- | Produce the second-half-of-a-double register given the first half. -{- -fPair :: Reg -> Maybe Reg -fPair (RealReg n) - | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) - -fPair (VirtualRegD u) - = Just (VirtualRegHi u) - -fPair reg - = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) - Nothing --} - - --- | All the regs that the register allocator can allocate to, --- with the the fixed use regs removed. --- -allocatableRegs :: [RealReg] -allocatableRegs - = let isFree rr - = case rr of - RealRegSingle r -> freeReg r - RealRegPair r1 r2 -> freeReg r1 && freeReg r2 - in filter isFree allRealRegs - - --- | The registers to place arguments for function calls, --- for some number of arguments. --- -argRegs :: RegNo -> [Reg] -argRegs r - = case r of - 0 -> [] - 1 -> map (RegReal . RealRegSingle . oReg) [0] - 2 -> map (RegReal . RealRegSingle . oReg) [0,1] - 3 -> map (RegReal . RealRegSingle . oReg) [0,1,2] - 4 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3] - 5 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4] - 6 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5] - _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" - - --- | All all the regs that could possibly be returned by argRegs --- -allArgRegs :: [Reg] -allArgRegs - = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] - - --- These are the regs that we cannot assume stay alive over a C call. --- TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02 --- -callClobberedRegs :: [Reg] -callClobberedRegs - = map (RegReal . RealRegSingle) - ( oReg 7 : - [oReg i | i <- [0..5]] ++ - [gReg i | i <- [1..7]] ++ - [fReg i | i <- [0..31]] ) - - - --- | Make a virtual reg with this format. -mkVirtualReg :: Unique -> Format -> VirtualReg -mkVirtualReg u format - | not (isFloatFormat format) - = VirtualRegI u - - | otherwise - = case format of - FF32 -> VirtualRegF u - FF64 -> VirtualRegD u - _ -> panic "mkVReg" - - -regDotColor :: RealReg -> SDoc -regDotColor reg - = case classOfRealReg reg of - RcInteger -> text "blue" - RcFloat -> text "red" - _other -> text "green" diff --git a/nativeGen/SPARC/ShortcutJump.hs b/nativeGen/SPARC/ShortcutJump.hs deleted file mode 100644 --- a/nativeGen/SPARC/ShortcutJump.hs +++ /dev/null @@ -1,69 +0,0 @@ -module SPARC.ShortcutJump ( - JumpDest(..), getJumpDestBlockId, - canShortcut, - shortcutJump, - shortcutStatics, - shortBlockId -) - -where - -import SPARC.Instr -import SPARC.Imm - -import CLabel -import BlockId -import Cmm - -import Panic -import Unique - - - -data JumpDest - = DestBlockId BlockId - | DestImm Imm - -getJumpDestBlockId :: JumpDest -> Maybe BlockId -getJumpDestBlockId (DestBlockId bid) = Just bid -getJumpDestBlockId _ = Nothing - - -canShortcut :: Instr -> Maybe JumpDest -canShortcut _ = Nothing - - -shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr -shortcutJump _ other = other - - - -shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics -shortcutStatics fn (Statics lbl statics) - = Statics lbl $ map (shortcutStatic fn) statics - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. - -shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel -shortcutLabel fn lab - | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) - | 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)) - = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) --- 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 -> mkAsmTempLabel (getUnique blockid) - Just (DestBlockId blockid') -> shortBlockId fn blockid' - Just (DestImm (ImmCLbl lbl)) -> lbl - _other -> panic "shortBlockId" diff --git a/nativeGen/SPARC/Stack.hs b/nativeGen/SPARC/Stack.hs deleted file mode 100644 --- a/nativeGen/SPARC/Stack.hs +++ /dev/null @@ -1,57 +0,0 @@ -module SPARC.Stack ( - spRel, - fpRel, - spillSlotToOffset, - maxSpillSlots -) - -where - -import SPARC.AddrMode -import SPARC.Regs -import SPARC.Base -import SPARC.Imm - -import DynFlags -import Outputable - --- | Get an AddrMode relative to the address in sp. --- This gives us a stack relative addressing mode for volatile --- temporaries and for excess call arguments. --- -spRel :: Int -- ^ stack offset in words, positive or negative - -> AddrMode - -spRel n = AddrRegImm sp (ImmInt (n * wordLength)) - - --- | Get an address relative to the frame pointer. --- This doesn't work work for offsets greater than 13 bits; we just hope for the best --- -fpRel :: Int -> AddrMode -fpRel n - = AddrRegImm fp (ImmInt (n * wordLength)) - - --- | Convert a spill slot number to a *byte* offset, with no sign. --- -spillSlotToOffset :: DynFlags -> Int -> Int -spillSlotToOffset dflags slot - | slot >= 0 && slot < maxSpillSlots dflags - = 64 + spillSlotSize * slot - - | otherwise - = pprPanic "spillSlotToOffset:" - ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) - - --- | The maximum number of spill slots available on the C stack. --- If we use up all of the slots, then we're screwed. --- --- Why do we reserve 64 bytes, instead of using the whole thing?? --- -- BL 2009/02/15 --- -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1 diff --git a/nativeGen/TargetReg.hs b/nativeGen/TargetReg.hs deleted file mode 100644 --- a/nativeGen/TargetReg.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE CPP #-} --- | Hard wired things related to registers. --- This is module is preventing the native code generator being able to --- emit code for non-host architectures. --- --- TODO: Do a better job of the overloading, and eliminate this module. --- We'd probably do better with a Register type class, and hook this to --- Instruction somehow. --- --- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable -module TargetReg ( - targetVirtualRegSqueeze, - targetRealRegSqueeze, - targetClassOfRealReg, - targetMkVirtualReg, - targetRegDotColor, - targetClassOfReg -) - -where - -#include "HsVersions.h" - -import Reg -import RegClass -import Format - -import Outputable -import Unique -import Platform - -import qualified X86.Regs as X86 -import qualified X86.RegInfo as X86 - -import qualified PPC.Regs as PPC - -import qualified SPARC.Regs as SPARC - -targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int -targetVirtualRegSqueeze platform - = case platformArch platform of - ArchX86 -> X86.virtualRegSqueeze - ArchX86_64 -> X86.virtualRegSqueeze - ArchPPC -> PPC.virtualRegSqueeze - ArchSPARC -> SPARC.virtualRegSqueeze - ArchSPARC64 -> panic "targetVirtualRegSqueeze ArchSPARC64" - ArchPPC_64 _ -> PPC.virtualRegSqueeze - ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM" - ArchARM64 -> panic "targetVirtualRegSqueeze ArchARM64" - ArchAlpha -> panic "targetVirtualRegSqueeze ArchAlpha" - ArchMipseb -> panic "targetVirtualRegSqueeze ArchMipseb" - ArchMipsel -> panic "targetVirtualRegSqueeze ArchMipsel" - ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript" - ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" - - -targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> Int -targetRealRegSqueeze platform - = case platformArch platform of - ArchX86 -> X86.realRegSqueeze - ArchX86_64 -> X86.realRegSqueeze - ArchPPC -> PPC.realRegSqueeze - ArchSPARC -> SPARC.realRegSqueeze - ArchSPARC64 -> panic "targetRealRegSqueeze ArchSPARC64" - ArchPPC_64 _ -> PPC.realRegSqueeze - ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM" - ArchARM64 -> panic "targetRealRegSqueeze ArchARM64" - ArchAlpha -> panic "targetRealRegSqueeze ArchAlpha" - ArchMipseb -> panic "targetRealRegSqueeze ArchMipseb" - ArchMipsel -> panic "targetRealRegSqueeze ArchMipsel" - ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript" - ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" - -targetClassOfRealReg :: Platform -> RealReg -> RegClass -targetClassOfRealReg platform - = case platformArch platform of - ArchX86 -> X86.classOfRealReg platform - ArchX86_64 -> X86.classOfRealReg platform - ArchPPC -> PPC.classOfRealReg - ArchSPARC -> SPARC.classOfRealReg - ArchSPARC64 -> panic "targetClassOfRealReg ArchSPARC64" - ArchPPC_64 _ -> PPC.classOfRealReg - ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" - ArchARM64 -> panic "targetClassOfRealReg ArchARM64" - ArchAlpha -> panic "targetClassOfRealReg ArchAlpha" - ArchMipseb -> panic "targetClassOfRealReg ArchMipseb" - ArchMipsel -> panic "targetClassOfRealReg ArchMipsel" - ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript" - ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" - -targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg -targetMkVirtualReg platform - = case platformArch platform of - ArchX86 -> X86.mkVirtualReg - ArchX86_64 -> X86.mkVirtualReg - ArchPPC -> PPC.mkVirtualReg - ArchSPARC -> SPARC.mkVirtualReg - ArchSPARC64 -> panic "targetMkVirtualReg ArchSPARC64" - ArchPPC_64 _ -> PPC.mkVirtualReg - ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM" - ArchARM64 -> panic "targetMkVirtualReg ArchARM64" - ArchAlpha -> panic "targetMkVirtualReg ArchAlpha" - ArchMipseb -> panic "targetMkVirtualReg ArchMipseb" - ArchMipsel -> panic "targetMkVirtualReg ArchMipsel" - ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript" - ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" - -targetRegDotColor :: Platform -> RealReg -> SDoc -targetRegDotColor platform - = case platformArch platform of - ArchX86 -> X86.regDotColor platform - ArchX86_64 -> X86.regDotColor platform - ArchPPC -> PPC.regDotColor - ArchSPARC -> SPARC.regDotColor - ArchSPARC64 -> panic "targetRegDotColor ArchSPARC64" - ArchPPC_64 _ -> PPC.regDotColor - ArchARM _ _ _ -> panic "targetRegDotColor ArchARM" - ArchARM64 -> panic "targetRegDotColor ArchARM64" - ArchAlpha -> panic "targetRegDotColor ArchAlpha" - ArchMipseb -> panic "targetRegDotColor ArchMipseb" - ArchMipsel -> panic "targetRegDotColor ArchMipsel" - ArchJavaScript-> panic "targetRegDotColor ArchJavaScript" - ArchUnknown -> panic "targetRegDotColor ArchUnknown" - - -targetClassOfReg :: Platform -> Reg -> RegClass -targetClassOfReg platform reg - = case reg of - RegVirtual vr -> classOfVirtualReg vr - RegReal rr -> targetClassOfRealReg platform rr diff --git a/nativeGen/X86/CodeGen.hs b/nativeGen/X86/CodeGen.hs deleted file mode 100644 --- a/nativeGen/X86/CodeGen.hs +++ /dev/null @@ -1,3121 +0,0 @@ -{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-} - --- The default iteration limit is a bit too low for the definitions --- in this module. -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-} -#endif - ------------------------------------------------------------------------------ --- --- Generating machine code (instruction selection) --- --- (c) The University of Glasgow 1996-2004 --- ------------------------------------------------------------------------------ - --- This is a big module, but, if you pay attention to --- (a) the sectioning, and (b) the type signatures, the --- structure should not be too overwhelming. - -module X86.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - extractUnwindPoints, - InstrBlock -) - -where - -#include "HsVersions.h" -#include "nativeGen/NCG.h" -#include "MachDeps.h" - --- NCG stuff: -import X86.Instr -import X86.Cond -import X86.Regs -import X86.RegInfo -import CodeGen.Platform -import CPrim -import Debug ( DebugBlock(..), UnwindPoint(..), UnwindTable - , UnwindExpr(UwReg), toUnwindExpr ) -import Instruction -import PIC -import NCGMonad -import Format -import Reg -import Platform - --- Our intermediate code: -import BasicTypes -import BlockId -import Module ( primUnitId ) -import PprCmm () -import CmmUtils -import CmmSwitch -import Cmm -import Hoopl -import CLabel -import CoreSyn ( Tickish(..) ) -import SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) - --- The rest: -import ForeignCall ( CCallConv(..) ) -import OrdList -import Outputable -import Unique -import FastString -import DynFlags -import Util -import UniqSupply ( getUniqueM ) - -import Control.Monad -import Data.Bits -import Data.Foldable (fold) -import Data.Int -import Data.Maybe -import Data.Word - -import qualified Data.Map as M - -is32BitPlatform :: NatM Bool -is32BitPlatform = do - dflags <- getDynFlags - return $ target32Bit (targetPlatform dflags) - -sse2Enabled :: NatM Bool -sse2Enabled = do - dflags <- getDynFlags - return (isSse2Enabled dflags) - -sse4_2Enabled :: NatM Bool -sse4_2Enabled = do - dflags <- getDynFlags - return (isSse4_2Enabled dflags) - -if_sse2 :: NatM a -> NatM a -> NatM a -if_sse2 sse2 x87 = do - b <- sse2Enabled - if b then sse2 else x87 - -cmmTopCodeGen - :: RawCmmDecl - -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr] - -cmmTopCodeGen (CmmProc info lab live graph) = do - let blocks = toBlockListEntryFirst graph - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - picBaseMb <- getPicBaseMaybeNat - dflags <- getDynFlags - let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) - tops = proc : concat statics - os = platformOS $ targetPlatform dflags - - case picBaseMb of - Just picBase -> initializePicBase_x86 ArchX86 os picBase tops - Nothing -> return tops - -cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic - - -basicBlockCodeGen - :: CmmBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl (Alignment, CmmStatics) Instr]) - -basicBlockCodeGen block = do - let (_, nodes, tail) = blockSplit block - id = entryLabel block - stmts = blockToList nodes - -- Generate location directive - dbg <- getDebugBlock (entryLabel block) - loc_instrs <- case dblSourceTick =<< dbg of - Just (SourceNote span name) - -> do fileId <- getFileId (srcSpanFile span) - let line = srcSpanStartLine span; col = srcSpanStartCol span - return $ unitOL $ LOCATION fileId line col name - _ -> return nilOL - mid_instrs <- stmtsToInstrs stmts - tail_instrs <- stmtToInstrs tail - let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs - instrs' <- fold <$> traverse addSpUnwindings instrs - -- code generation may introduce new basic block boundaries, which - -- are indicated by the NEWBLOCK instruction. We must split up the - -- instruction stream into basic blocks again. Also, we extract - -- LDATAs here too. - let - (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs' - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) - return (BasicBlock id top : other_blocks, statics) - --- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes --- in the @sp@ register. See Note [What is this unwinding business?] in Debug --- for details. -addSpUnwindings :: Instr -> NatM (OrdList Instr) -addSpUnwindings instr@(DELTA d) = do - dflags <- getDynFlags - if debugLevel dflags >= 1 - then do lbl <- mkAsmTempLabel <$> getUniqueM - let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d) - return $ toOL [ instr, UNWIND lbl unwind ] - else return (unitOL instr) -addSpUnwindings instr = return $ unitOL instr - -stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock -stmtsToInstrs stmts - = do instrss <- mapM stmtToInstrs stmts - return (concatOL instrss) - - -stmtToInstrs :: CmmNode e x -> NatM InstrBlock -stmtToInstrs stmt = do - dflags <- getDynFlags - is32Bit <- is32BitPlatform - case stmt of - CmmComment s -> return (unitOL (COMMENT s)) - CmmTick {} -> return nilOL - - CmmUnwind regs -> do - let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable - to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr) - case foldMap to_unwind_entry regs of - tbl | M.null tbl -> return nilOL - | otherwise -> do - lbl <- mkAsmTempLabel <$> getUniqueM - return $ unitOL $ UNWIND lbl tbl - - CmmAssign reg src - | isFloatType ty -> assignReg_FltCode format reg src - | is32Bit && isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType dflags reg - format = cmmTypeFormat ty - - CmmStore addr src - | isFloatType ty -> assignMem_FltCode format addr src - | is32Bit && isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode format addr src - where ty = cmmExprType dflags src - format = cmmTypeFormat ty - - CmmUnsafeForeignCall target result_regs args - -> genCCall dflags is32Bit target result_regs args - - CmmBranch id -> genBranch id - CmmCondBranch arg true false _ -> do - b1 <- genCondJump true arg - b2 <- genBranch false - return (b1 `appOL` b2) - CmmSwitch arg ids -> do dflags <- getDynFlags - genSwitch dflags arg ids - CmmCall { cml_target = arg - , cml_args_regs = gregs } -> do - dflags <- getDynFlags - genJump arg (jumpRegs dflags gregs) - _ -> - panic "stmtToInstrs: statement should have been cps'd away" - - -jumpRegs :: DynFlags -> [GlobalReg] -> [Reg] -jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] - where platform = targetPlatform dflags - --------------------------------------------------------------------------------- --- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. --- -type InstrBlock - = OrdList Instr - - --- | Condition codes passed up the tree. --- -data CondCode - = CondCode Bool Cond InstrBlock - - --- | a.k.a "Register64" --- Reg is the lower 32-bit temporary which contains the result. --- Use getHiVRegFromLo to find the other VRegUnique. --- --- Rules of this simplified insn selection game are therefore that --- the returned Reg may be modified --- -data ChildCode64 - = ChildCode64 - InstrBlock - Reg - - --- | Register's passed up the tree. If the stix code forces the register --- to live in a pre-decided machine register, it comes out as @Fixed@; --- otherwise, it comes out as @Any@, and the parent can decide which --- register to put it in. --- -data Register - = Fixed Format Reg InstrBlock - | Any Format (Reg -> InstrBlock) - - -swizzleRegisterRep :: Register -> Format -> Register -swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code -swizzleRegisterRep (Any _ codefn) format = Any format codefn - - --- | Grab the Reg for a CmmReg -getRegisterReg :: Platform -> Bool -> CmmReg -> Reg - -getRegisterReg _ use_sse2 (CmmLocal (LocalReg u pk)) - = let fmt = cmmTypeFormat pk in - if isFloatFormat fmt && not use_sse2 - then RegVirtual (mkVirtualReg u FF80) - else RegVirtual (mkVirtualReg u fmt) - -getRegisterReg platform _ (CmmGlobal mid) - = case globalRegMaybe platform mid of - Just reg -> RegReal $ reg - Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) - -- By this stage, the only MagicIds remaining should be the - -- ones which map to a real machine register on this - -- platform. Hence ... - - --- | Memory addressing modes passed up the tree. -data Amode - = Amode AddrMode InstrBlock - -{- -Now, given a tree (the argument to an CmmLoad) that references memory, -produce a suitable addressing mode. - -A Rule of the Game (tm) for Amodes: use of the addr bit must -immediately follow use of the code part, since the code part puts -values in registers which the addr then refers to. So you can't put -anything in between, lest it overwrite some of those registers. If -you need to do some other computation between the code part and use of -the addr bit, first store the effective address from the amode in a -temporary, then do the other computation, and then use the temporary: - - code - LEA amode, tmp - ... other computation ... - ... (tmp) ... --} - - --- | Check whether an integer will fit in 32 bits. --- A CmmInt is intended to be truncated to the appropriate --- number of bits, so here we truncate it to Int64. This is --- important because e.g. -1 as a CmmInt might be either --- -1 or 18446744073709551615. --- -is32BitInteger :: Integer -> Bool -is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 - where i64 = fromIntegral i :: Int64 - - --- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic -jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) -jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = mkAsmTempLabel (getUnique blockid) - - --- ----------------------------------------------------------------------------- --- General things for putting together code sequences - --- Expand CmmRegOff. ToDo: should we do it this way around, or convert --- CmmExprs into CmmRegOff? -mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr -mangleIndexTree dflags reg off - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType dflags reg) - --- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getSomeReg expr = do - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) - - -assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_I64Code addrTree valueTree = do - Amode addr addr_code <- getAmode addrTree - ChildCode64 vcode rlo <- iselExpr64 valueTree - let - rhi = getHiVRegFromLo rlo - - -- Little-endian store - mov_lo = MOV II32 (OpReg rlo) (OpAddr addr) - mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4))) - return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) - - -assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do - ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let - r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 - r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo) - mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi) - return ( - vcode `snocOL` mov_lo `snocOL` mov_hi - ) - -assignReg_I64Code _ _ - = panic "assignReg_I64Code(i386): invalid lvalue" - - -iselExpr64 :: CmmExpr -> NatM ChildCode64 -iselExpr64 (CmmLit (CmmInt i _)) = do - (rlo,rhi) <- getNewRegPairNat II32 - let - r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) - code = toOL [ - MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), - MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) - ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do - Amode addr addr_code <- getAmode addrTree - (rlo,rhi) <- getNewRegPairNat II32 - let - mov_lo = MOV II32 (OpAddr addr) (OpReg rlo) - mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi) - return ( - ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) - rlo - ) - -iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty - = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32)) - --- we handle addition, but rather badly -iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do - ChildCode64 code1 r1lo <- iselExpr64 e1 - (rlo,rhi) <- getNewRegPairNat II32 - let - r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) - r1hi = getHiVRegFromLo r1lo - code = code1 `appOL` - toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), - ADD II32 (OpImm (ImmInteger r)) (OpReg rlo), - MOV II32 (OpReg r1hi) (OpReg rhi), - ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do - ChildCode64 code1 r1lo <- iselExpr64 e1 - ChildCode64 code2 r2lo <- iselExpr64 e2 - (rlo,rhi) <- getNewRegPairNat II32 - let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), - ADD II32 (OpReg r2lo) (OpReg rlo), - MOV II32 (OpReg r1hi) (OpReg rhi), - ADC II32 (OpReg r2hi) (OpReg rhi) ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do - ChildCode64 code1 r1lo <- iselExpr64 e1 - ChildCode64 code2 r2lo <- iselExpr64 e2 - (rlo,rhi) <- getNewRegPairNat II32 - let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), - SUB II32 (OpReg r2lo) (OpReg rlo), - MOV II32 (OpReg r1hi) (OpReg rhi), - SBB II32 (OpReg r2hi) (OpReg rhi) ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do - fn <- getAnyReg expr - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - code = fn r_dst_lo - return ( - ChildCode64 (code `snocOL` - MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi)) - r_dst_lo - ) - -iselExpr64 expr - = pprPanic "iselExpr64(i386)" (ppr expr) - - --------------------------------------------------------------------------------- -getRegister :: CmmExpr -> NatM Register -getRegister e = do dflags <- getDynFlags - is32Bit <- is32BitPlatform - getRegister' dflags is32Bit e - -getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register - -getRegister' dflags is32Bit (CmmReg reg) - = case reg of - CmmGlobal PicBaseReg - | is32Bit -> - -- on x86_64, we have %rip for PicBaseReg, but it's not - -- a full-featured register, it can only be used for - -- rip-relative addressing. - do reg' <- getPicBaseNat (archWordFormat is32Bit) - return (Fixed (archWordFormat is32Bit) reg' nilOL) - _ -> - do use_sse2 <- sse2Enabled - let - fmt = cmmTypeFormat (cmmRegType dflags reg) - format | not use_sse2 && isFloatFormat fmt = FF80 - | otherwise = fmt - -- - let platform = targetPlatform dflags - return (Fixed format - (getRegisterReg platform use_sse2 reg) - nilOL) - - -getRegister' dflags is32Bit (CmmRegOff r n) - = getRegister' dflags is32Bit $ mangleIndexTree dflags r n - --- for 32-bit architectuers, support some 64 -> 32 bit conversions: --- TO_W_(x), TO_W_(x >> 32) - -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) - | is32Bit = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) - | is32Bit = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) - | is32Bit = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) - | is32Bit = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister' _ _ (CmmLit lit@(CmmFloat f w)) = - if_sse2 float_const_sse2 float_const_x87 - where - float_const_sse2 - | f == 0.0 = do - let - format = floatFormat w - code dst = unitOL (XOR format (OpReg dst) (OpReg dst)) - -- I don't know why there are xorpd, xorps, and pxor instructions. - -- They all appear to do the same thing --SDM - return (Any format code) - - | otherwise = do - Amode addr code <- memConstant (widthInBytes w) lit - loadFloatAmode True w addr code - - float_const_x87 = case w of - W64 - | f == 0.0 -> - let code dst = unitOL (GLDZ dst) - in return (Any FF80 code) - - | f == 1.0 -> - let code dst = unitOL (GLD1 dst) - in return (Any FF80 code) - - _otherwise -> do - Amode addr code <- memConstant (widthInBytes w) lit - loadFloatAmode False w addr code - --- catch simple cases of zero- or sign-extended load -getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do - code <- intLoadCode (MOVZxL II8) addr - return (Any II32 code) - -getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do - code <- intLoadCode (MOVSxL II8) addr - return (Any II32 code) - -getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do - code <- intLoadCode (MOVZxL II16) addr - return (Any II32 code) - -getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do - code <- intLoadCode (MOVSxL II16) addr - return (Any II32 code) - --- catch simple cases of zero- or sign-extended load -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOVZxL II8) addr - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOVSxL II8) addr - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOVZxL II16) addr - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOVSxL II16) addr - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOVSxL II32) addr - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), - CmmLit displacement]) - | not is32Bit = do - return $ Any II64 (\dst -> unitOL $ - LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) - -getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps - sse2 <- sse2Enabled - case mop of - MO_F_Neg w - | sse2 -> sse2NegCode w x - | otherwise -> trivialUFCode FF80 (GNEG FF80) x - - MO_S_Neg w -> triv_ucode NEGI (intFormat w) - MO_Not w -> triv_ucode NOT (intFormat w) - - -- Nop conversions - MO_UU_Conv W32 W8 -> toI8Reg W32 x - MO_SS_Conv W32 W8 -> toI8Reg W32 x - MO_UU_Conv W16 W8 -> toI8Reg W16 x - MO_SS_Conv W16 W8 -> toI8Reg W16 x - MO_UU_Conv W32 W16 -> toI16Reg W32 x - MO_SS_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_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x - MO_SS_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_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x - MO_SS_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 - - 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. - - MO_FF_Conv W32 W64 - | sse2 -> coerceFP2FP W64 x - | otherwise -> conversionNop FF80 x - - MO_FF_Conv W64 W32 -> coerceFP2FP W32 x - - MO_FS_Conv from to -> coerceFP2Int from to x - MO_SF_Conv from to -> coerceInt2FP from to x - - MO_V_Insert {} -> needLlvm - MO_V_Extract {} -> needLlvm - MO_V_Add {} -> needLlvm - MO_V_Sub {} -> needLlvm - MO_V_Mul {} -> needLlvm - MO_VS_Quot {} -> needLlvm - MO_VS_Rem {} -> needLlvm - MO_VS_Neg {} -> needLlvm - MO_VU_Quot {} -> needLlvm - MO_VU_Rem {} -> needLlvm - MO_VF_Insert {} -> needLlvm - MO_VF_Extract {} -> needLlvm - MO_VF_Add {} -> needLlvm - MO_VF_Sub {} -> needLlvm - MO_VF_Mul {} -> needLlvm - MO_VF_Quot {} -> needLlvm - MO_VF_Neg {} -> needLlvm - - _other -> pprPanic "getRegister" (pprMachOp mop) - where - triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register - triv_ucode instr format = trivialUCode format (instr format) x - - -- signed or unsigned extension. - integerExtend :: Width -> Width - -> (Format -> Operand -> Operand -> Instr) - -> CmmExpr -> NatM Register - integerExtend from to instr expr = do - (reg,e_code) <- if from == W8 then getByteReg expr - else getSomeReg expr - let - code dst = - e_code `snocOL` - instr (intFormat from) (OpReg reg) (OpReg dst) - return (Any (intFormat to) code) - - toI8Reg :: Width -> CmmExpr -> NatM Register - toI8Reg new_rep expr - = do codefn <- getAnyReg expr - return (Any (intFormat new_rep) codefn) - -- HACK: use getAnyReg to get a byte-addressable register. - -- If the source was a Fixed register, this will add the - -- mov instruction to put it into the desired destination. - -- We're assuming that the destination won't be a fixed - -- non-byte-addressable register; it won't be, because all - -- fixed registers are word-sized. - - toI16Reg = toI8Reg -- for now - - conversionNop :: Format -> CmmExpr -> NatM Register - conversionNop new_format expr - = do e_code <- getRegister' dflags is32Bit expr - return (swizzleRegisterRep e_code new_format) - - -getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps - sse2 <- sse2Enabled - case mop of - MO_F_Eq _ -> condFltReg is32Bit EQQ x y - MO_F_Ne _ -> condFltReg is32Bit NE x y - MO_F_Gt _ -> condFltReg is32Bit GTT x y - MO_F_Ge _ -> condFltReg is32Bit GE x y - MO_F_Lt _ -> condFltReg is32Bit LTT x y - MO_F_Le _ -> condFltReg is32Bit LE x y - - MO_Eq _ -> condIntReg EQQ x y - MO_Ne _ -> condIntReg NE x y - - MO_S_Gt _ -> condIntReg GTT x y - MO_S_Ge _ -> condIntReg GE x y - MO_S_Lt _ -> condIntReg LTT x y - MO_S_Le _ -> condIntReg LE x y - - MO_U_Gt _ -> condIntReg GU x y - MO_U_Ge _ -> condIntReg GEU x y - MO_U_Lt _ -> condIntReg LU x y - MO_U_Le _ -> condIntReg LEU x y - - MO_F_Add w | sse2 -> trivialFCode_sse2 w ADD x y - | otherwise -> trivialFCode_x87 GADD x y - MO_F_Sub w | sse2 -> trivialFCode_sse2 w SUB x y - | otherwise -> trivialFCode_x87 GSUB x y - MO_F_Quot w | sse2 -> trivialFCode_sse2 w FDIV x y - | otherwise -> trivialFCode_x87 GDIV x y - MO_F_Mul w | sse2 -> trivialFCode_sse2 w MUL x y - | otherwise -> trivialFCode_x87 GMUL x y - - MO_Add rep -> add_code rep x y - MO_Sub rep -> sub_code rep x y - - MO_S_Quot rep -> div_code rep True True x y - MO_S_Rem rep -> div_code rep True False x y - MO_U_Quot rep -> div_code rep False True x y - MO_U_Rem rep -> div_code rep False False x y - - MO_S_MulMayOflo rep -> imulMayOflo rep x y - - MO_Mul 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) - - imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register - imulMayOflo rep a b = do - (a_reg, a_code) <- getNonClobberedReg a - b_code <- getAnyReg b - let - shift_amt = case rep of - W32 -> 31 - W64 -> 63 - _ -> panic "shift_amt" - - format = intFormat rep - code = a_code `appOL` b_code eax `appOL` - toOL [ - IMUL2 format (OpReg a_reg), -- result in %edx:%eax - SAR format (OpImm (ImmInt shift_amt)) (OpReg eax), - -- sign extend lower part - SUB format (OpReg edx) (OpReg eax) - -- compare against upper - -- eax==0 if high part == sign extended low part - ] - return (Fixed format eax code) - - -------------------- - shift_code :: Width - -> (Format -> Operand -> Operand -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - - {- Case1: shift length as immediate -} - shift_code width instr x (CmmLit lit) = do - x_code <- getAnyReg x - let - format = intFormat width - code dst - = x_code dst `snocOL` - instr format (OpImm (litToImm lit)) (OpReg dst) - return (Any format code) - - {- Case2: shift length is complex (non-immediate) - * y must go in %ecx. - * we cannot do y first *and* put its result in %ecx, because - %ecx might be clobbered by x. - * if we do y second, then x cannot be - in a clobbered reg. Also, we cannot clobber x's reg - with the instruction itself. - * so we can either: - - do y first, put its result in a fresh tmp, then copy it to %ecx later - - do y second and put its result into %ecx. x gets placed in a fresh - tmp. This is likely to be better, because the reg alloc can - eliminate this reg->reg move here (it won't eliminate the other one, - because the move is into the fixed %ecx). - -} - shift_code width instr x y{-amount-} = do - x_code <- getAnyReg x - let format = intFormat width - tmp <- getNewRegNat format - y_code <- getAnyReg y - let - code = x_code tmp `appOL` - y_code ecx `snocOL` - instr format (OpReg ecx) (OpReg tmp) - return (Fixed format tmp code) - - -------------------- - add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register - add_code rep x (CmmLit (CmmInt y _)) - | is32BitInteger y = add_int rep x y - add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y - where format = intFormat rep - -- TODO: There are other interesting patterns we want to replace - -- with a LEA, e.g. `(x + offset) + (y << shift)`. - - -------------------- - sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register - sub_code rep x (CmmLit (CmmInt y _)) - | is32BitInteger (-y) = add_int rep x (-y) - sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y - - -- our three-operand add instruction: - add_int width x y = do - (x_reg, x_code) <- getSomeReg x - let - format = intFormat width - imm = ImmInt (fromInteger y) - code dst - = x_code `snocOL` - LEA format - (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm)) - (OpReg dst) - -- - return (Any format code) - - ---------------------- - div_code width signed quotient x y = do - (y_op, y_code) <- getRegOrMem y -- cannot be clobbered - x_code <- getAnyReg x - let - format = intFormat width - widen | signed = CLTD format - | otherwise = XOR format (OpReg edx) (OpReg edx) - - instr | signed = IDIV - | otherwise = DIV - - code = y_code `appOL` - x_code eax `appOL` - toOL [widen, instr format y_op] - - result | quotient = eax - | otherwise = edx - - return (Fixed format result code) - - -getRegister' _ _ (CmmLoad mem pk) - | isFloatType pk - = do - Amode addr mem_code <- getAmode mem - use_sse2 <- sse2Enabled - loadFloatAmode use_sse2 (typeWidth pk) addr mem_code - -getRegister' _ is32Bit (CmmLoad mem pk) - | is32Bit && not (isWord64 pk) - = do - code <- intLoadCode instr mem - return (Any format code) - where - width = typeWidth pk - format = intFormat width - instr = case width of - W8 -> MOVZxL II8 - _other -> MOV format - -- We always zero-extend 8-bit loads, if we - -- can't think of anything better. This is because - -- we can't guarantee access to an 8-bit variant of every register - -- (esi and edi don't have 8-bit variants), so to make things - -- simpler we do our 8-bit arithmetic with full 32-bit registers. - --- Simpler memory load code on x86_64 -getRegister' _ is32Bit (CmmLoad mem pk) - | not is32Bit - = do - code <- intLoadCode (MOV format) mem - return (Any format code) - where format = intFormat $ typeWidth pk - -getRegister' _ is32Bit (CmmLit (CmmInt 0 width)) - = let - format = intFormat width - - -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits - format1 = if is32Bit then format - else case format of - II64 -> II32 - _ -> format - code dst - = unitOL (XOR format1 (OpReg dst) (OpReg dst)) - in - return (Any format code) - - -- optimisation for loading small literals on x86_64: take advantage - -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit - -- instruction forms are shorter. -getRegister' dflags is32Bit (CmmLit lit) - | not is32Bit, isWord64 (cmmLitType dflags lit), not (isBigLit lit) - = let - imm = litToImm lit - code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) - in - return (Any II64 code) - where - isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff - isBigLit _ = False - -- note1: not the same as (not.is32BitLit), because that checks for - -- signed literals that fit in 32 bits, but we want unsigned - -- literals here. - -- note2: all labels are small, because we're assuming the - -- small memory model (see gcc docs, -mcmodel=small). - -getRegister' dflags _ (CmmLit lit) - = do let format = cmmTypeFormat (cmmLitType dflags lit) - imm = litToImm lit - code dst = unitOL (MOV format (OpImm imm) (OpReg dst)) - return (Any format code) - -getRegister' _ _ other - | isVecExpr other = needLlvm - | otherwise = pprPanic "getRegister(x86)" (ppr other) - - -intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr - -> NatM (Reg -> InstrBlock) -intLoadCode instr mem = do - Amode src mem_code <- getAmode mem - return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst)) - --- Compute an expression into *any* register, adding the appropriate --- move instruction if necessary. -getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock) -getAnyReg expr = do - r <- getRegister expr - anyReg r - -anyReg :: Register -> NatM (Reg -> InstrBlock) -anyReg (Any _ code) = return code -anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst) - --- A bit like getSomeReg, but we want a reg that can be byte-addressed. --- Fixed registers might not be byte-addressable, so we make sure we've --- got a temporary, inserting an extra reg copy if necessary. -getByteReg :: CmmExpr -> NatM (Reg, InstrBlock) -getByteReg expr = do - is32Bit <- is32BitPlatform - if is32Bit - then do r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed rep reg code - | isVirtualReg reg -> return (reg,code) - | otherwise -> do - tmp <- getNewRegNat rep - return (tmp, code `snocOL` reg2reg rep reg tmp) - -- ToDo: could optimise slightly by checking for - -- byte-addressable real registers, but that will - -- happen very rarely if at all. - else getSomeReg expr -- all regs are byte-addressable on x86_64 - --- Another variant: this time we want the result in a register that cannot --- be modified by code to evaluate an arbitrary expression. -getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock) -getNonClobberedReg expr = do - dflags <- getDynFlags - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed rep reg code - -- only certain regs can be clobbered - | reg `elem` instrClobberedRegs (targetPlatform dflags) - -> do - tmp <- getNewRegNat rep - return (tmp, code `snocOL` reg2reg rep reg tmp) - | otherwise -> - return (reg, code) - -reg2reg :: Format -> Reg -> Reg -> Instr -reg2reg format src dst - | format == FF80 = GMOV src dst - | otherwise = MOV format (OpReg src) (OpReg dst) - - --------------------------------------------------------------------------------- -getAmode :: CmmExpr -> NatM Amode -getAmode e = do is32Bit <- is32BitPlatform - getAmode' is32Bit e - -getAmode' :: Bool -> CmmExpr -> NatM Amode -getAmode' _ (CmmRegOff r n) = do dflags <- getDynFlags - getAmode $ mangleIndexTree dflags r n - -getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), - CmmLit displacement]) - | not is32Bit - = return $ Amode (ripRel (litToImm displacement)) nilOL - - --- This is all just ridiculous, since it carefully undoes --- what mangleIndexTree has just done. -getAmode' is32Bit (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]) - | is32BitLit is32Bit lit - -- ASSERT(rep == II32)??? - = do (x_reg, x_code) <- getSomeReg x - let off = ImmInt (-(fromInteger i)) - return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) - -getAmode' is32Bit (CmmMachOp (MO_Add _rep) [x, CmmLit lit]) - | is32BitLit is32Bit lit - -- ASSERT(rep == II32)??? - = do (x_reg, x_code) <- getSomeReg x - let off = litToImm lit - return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) - --- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be --- recognised by the next rule. -getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), - b@(CmmLit _)]) - = getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a]) - --- Matches: (x + offset) + (y << shift) -getAmode' _ (CmmMachOp (MO_Add _) [CmmRegOff x offset, - CmmMachOp (MO_Shl _) - [y, CmmLit (CmmInt shift _)]]) - | shift == 0 || shift == 1 || shift == 2 || shift == 3 - = x86_complex_amode (CmmReg x) y shift (fromIntegral offset) - -getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) - [y, CmmLit (CmmInt shift _)]]) - | shift == 0 || shift == 1 || shift == 2 || shift == 3 - = x86_complex_amode x y shift 0 - -getAmode' _ (CmmMachOp (MO_Add _) - [x, CmmMachOp (MO_Add _) - [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)], - CmmLit (CmmInt offset _)]]) - | shift == 0 || shift == 1 || shift == 2 || shift == 3 - && is32BitInteger offset - = x86_complex_amode x y shift offset - -getAmode' _ (CmmMachOp (MO_Add _) [x,y]) - = x86_complex_amode x y 0 0 - -getAmode' is32Bit (CmmLit lit) | is32BitLit is32Bit lit - = return (Amode (ImmAddr (litToImm lit) 0) nilOL) - -getAmode' _ expr = do - (reg,code) <- getSomeReg expr - return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) - --- | Like 'getAmode', but on 32-bit use simple register addressing --- (i.e. no index register). This stops us from running out of --- registers on x86 when using instructions such as cmpxchg, which can --- use up to three virtual registers and one fixed register. -getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode -getSimpleAmode dflags is32Bit addr - | is32Bit = do - addr_code <- getAnyReg addr - addr_r <- getNewRegNat (intFormat (wordWidth dflags)) - let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0) - return $! Amode amode (addr_code addr_r) - | otherwise = getAmode addr - -x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode -x86_complex_amode base index shift offset - = do (x_reg, x_code) <- getNonClobberedReg base - -- x must be in a temp, because it has to stay live over y_code - -- we could compre x_reg and y_reg and do something better here... - (y_reg, y_code) <- getSomeReg index - let - code = x_code `appOL` y_code - base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8; - n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")" - return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset))) - code) - - - - --- ----------------------------------------------------------------------------- --- getOperand: sometimes any operand will do. - --- getNonClobberedOperand: the value of the operand will remain valid across --- the computation of an arbitrary expression, unless the expression --- is computed directly into a register which the operand refers to --- (see trivialCode where this function is used for an example). - -getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) -getNonClobberedOperand (CmmLit lit) = do - use_sse2 <- sse2Enabled - if use_sse2 && isSuitableFloatingPointLit lit - then do - let CmmFloat _ w = lit - Amode addr code <- memConstant (widthInBytes w) lit - return (OpAddr addr, code) - else do - - is32Bit <- is32BitPlatform - dflags <- getDynFlags - if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit)) - then return (OpImm (litToImm lit), nilOL) - else getNonClobberedOperand_generic (CmmLit lit) - -getNonClobberedOperand (CmmLoad mem pk) = do - is32Bit <- is32BitPlatform - use_sse2 <- sse2Enabled - if (not (isFloatType pk) || use_sse2) - && (if is32Bit then not (isWord64 pk) else True) - then do - dflags <- getDynFlags - let platform = targetPlatform dflags - Amode src mem_code <- getAmode mem - (src',save_code) <- - if (amodeCouldBeClobbered platform src) - then do - tmp <- getNewRegNat (archWordFormat is32Bit) - return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), - unitOL (LEA (archWordFormat is32Bit) - (OpAddr src) - (OpReg tmp))) - else - return (src, nilOL) - return (OpAddr src', mem_code `appOL` save_code) - else do - getNonClobberedOperand_generic (CmmLoad mem pk) - -getNonClobberedOperand e = getNonClobberedOperand_generic e - -getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) -getNonClobberedOperand_generic e = do - (reg, code) <- getNonClobberedReg e - return (OpReg reg, code) - -amodeCouldBeClobbered :: Platform -> AddrMode -> Bool -amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode) - -regClobbered :: Platform -> Reg -> Bool -regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr -regClobbered _ _ = False - --- getOperand: the operand is not required to remain valid across the --- computation of an arbitrary expression. -getOperand :: CmmExpr -> NatM (Operand, InstrBlock) - -getOperand (CmmLit lit) = do - use_sse2 <- sse2Enabled - if (use_sse2 && isSuitableFloatingPointLit lit) - then do - let CmmFloat _ w = lit - Amode addr code <- memConstant (widthInBytes w) lit - return (OpAddr addr, code) - else do - - is32Bit <- is32BitPlatform - dflags <- getDynFlags - if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit)) - then return (OpImm (litToImm lit), nilOL) - else getOperand_generic (CmmLit lit) - -getOperand (CmmLoad mem pk) = do - is32Bit <- is32BitPlatform - use_sse2 <- sse2Enabled - if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True) - then do - Amode src mem_code <- getAmode mem - return (OpAddr src, mem_code) - else - getOperand_generic (CmmLoad mem pk) - -getOperand e = getOperand_generic e - -getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) -getOperand_generic e = do - (reg, code) <- getSomeReg e - return (OpReg reg, code) - -isOperand :: Bool -> CmmExpr -> Bool -isOperand _ (CmmLoad _ _) = True -isOperand is32Bit (CmmLit lit) = is32BitLit is32Bit lit - || isSuitableFloatingPointLit lit -isOperand _ _ = False - -memConstant :: Int -> CmmLit -> NatM Amode -memConstant align lit = do - lbl <- getNewLabelNat - let rosection = Section ReadOnlyData lbl - dflags <- getDynFlags - (addr, addr_code) <- if target32Bit (targetPlatform dflags) - then do dynRef <- cmmMakeDynamicReference - dflags - DataReference - lbl - Amode addr addr_code <- getAmode dynRef - return (addr, addr_code) - else return (ripRel (ImmCLbl lbl), nilOL) - let code = - LDATA rosection (align, Statics lbl [CmmStaticLit lit]) - `consOL` addr_code - return (Amode addr code) - - -loadFloatAmode :: Bool -> Width -> AddrMode -> InstrBlock -> NatM Register -loadFloatAmode use_sse2 w addr addr_code = do - let format = floatFormat w - code dst = addr_code `snocOL` - if use_sse2 - then MOV format (OpAddr addr) (OpReg dst) - else GLD format addr dst - return (Any (if use_sse2 then format else FF80) code) - - --- if we want a floating-point literal as an operand, we can --- use it directly from memory. However, if the literal is --- zero, we're better off generating it into a register using --- xor. -isSuitableFloatingPointLit :: CmmLit -> Bool -isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0 -isSuitableFloatingPointLit _ = False - -getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock) -getRegOrMem e@(CmmLoad mem pk) = do - is32Bit <- is32BitPlatform - use_sse2 <- sse2Enabled - if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True) - then do - Amode src mem_code <- getAmode mem - return (OpAddr src, mem_code) - else do - (reg, code) <- getNonClobberedReg e - return (OpReg reg, code) -getRegOrMem e = do - (reg, code) <- getNonClobberedReg e - return (OpReg reg, code) - -is32BitLit :: Bool -> CmmLit -> Bool -is32BitLit is32Bit (CmmInt i W64) - | not is32Bit - = -- assume that labels are in the range 0-2^31-1: this assumes the - -- small memory model (see gcc docs, -mcmodel=small). - is32BitInteger i -is32BitLit _ _ = True - - - - --- Set up a condition code for a conditional branch. - -getCondCode :: CmmExpr -> NatM CondCode - --- yes, they really do seem to want exactly the same! - -getCondCode (CmmMachOp mop [x, y]) - = - case mop of - MO_F_Eq W32 -> condFltCode EQQ x y - MO_F_Ne W32 -> condFltCode NE x y - MO_F_Gt W32 -> condFltCode GTT x y - MO_F_Ge W32 -> condFltCode GE x y - 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 - - _ -> condIntCode (machOpToCond mop) x y - -getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other) - -machOpToCond :: MachOp -> Cond -machOpToCond mo = case mo of - MO_Eq _ -> EQQ - MO_Ne _ -> NE - MO_S_Gt _ -> GTT - MO_S_Ge _ -> GE - MO_S_Lt _ -> LTT - MO_S_Le _ -> LE - MO_U_Gt _ -> GU - MO_U_Ge _ -> GEU - MO_U_Lt _ -> LU - MO_U_Le _ -> LEU - _other -> pprPanic "machOpToCond" (pprMachOp mo) - - --- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be --- passed back up the tree. - -condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condIntCode cond x y = do is32Bit <- is32BitPlatform - condIntCode' is32Bit cond x y - -condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode - --- memory vs immediate -condIntCode' is32Bit cond (CmmLoad x pk) (CmmLit lit) - | is32BitLit is32Bit lit = do - Amode x_addr x_code <- getAmode x - let - imm = litToImm lit - code = x_code `snocOL` - CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr) - -- - return (CondCode False cond code) - --- anything vs zero, using a mask --- TODO: Add some sanity checking!!!! -condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk)) - | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit - = do - (x_reg, x_code) <- getSomeReg x - let - code = x_code `snocOL` - TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg) - -- - return (CondCode False cond code) - --- anything vs zero -condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do - (x_reg, x_code) <- getSomeReg x - let - code = x_code `snocOL` - TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg) - -- - return (CondCode False cond code) - --- anything vs operand -condIntCode' is32Bit cond x y - | isOperand is32Bit y = do - dflags <- getDynFlags - (x_reg, x_code) <- getNonClobberedReg x - (y_op, y_code) <- getOperand y - let - code = x_code `appOL` y_code `snocOL` - CMP (cmmTypeFormat (cmmExprType dflags x)) y_op (OpReg x_reg) - return (CondCode False cond code) --- operand vs. anything: invert the comparison so that we can use a --- single comparison instruction. - | isOperand is32Bit x - , Just revcond <- maybeFlipCond cond = do - dflags <- getDynFlags - (y_reg, y_code) <- getNonClobberedReg y - (x_op, x_code) <- getOperand x - let - code = y_code `appOL` x_code `snocOL` - CMP (cmmTypeFormat (cmmExprType dflags x)) x_op (OpReg y_reg) - return (CondCode False revcond code) - --- anything vs anything -condIntCode' _ cond x y = do - dflags <- getDynFlags - (y_reg, y_code) <- getNonClobberedReg y - (x_op, x_code) <- getRegOrMem x - let - code = y_code `appOL` - x_code `snocOL` - CMP (cmmTypeFormat (cmmExprType dflags x)) (OpReg y_reg) x_op - return (CondCode False cond code) - - - --------------------------------------------------------------------------------- -condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode - -condFltCode cond x y - = if_sse2 condFltCode_sse2 condFltCode_x87 - where - - condFltCode_x87 - = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do - (x_reg, x_code) <- getNonClobberedReg x - (y_reg, y_code) <- getSomeReg y - let - code = x_code `appOL` y_code `snocOL` - GCMP cond x_reg y_reg - -- The GCMP insn does the test and sets the zero flag if comparable - -- and true. Hence we always supply EQQ as the condition to test. - return (CondCode True EQQ code) - - -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be - -- an operand, but the right must be a reg. We can probably do better - -- than this general case... - condFltCode_sse2 = do - dflags <- getDynFlags - (x_reg, x_code) <- getNonClobberedReg x - (y_op, y_code) <- getOperand y - let - code = x_code `appOL` - y_code `snocOL` - CMP (floatFormat $ cmmExprWidth dflags x) y_op (OpReg x_reg) - -- NB(1): we need to use the unsigned comparison operators on the - -- result of this comparison. - return (CondCode True (condToUnsigned cond) code) - --- ----------------------------------------------------------------------------- --- Generating assignments - --- Assignments are really at the heart of the whole code generation --- business. Almost all top-level nodes of any real importance are --- assignments, which correspond to loads, stores, or register --- transfers. If we're really lucky, some of the register transfers --- will go away, because we can use the destination register to --- complete the code generation for the right hand side. This only --- fails when the right hand side is forced into a fixed register --- (e.g. the result of a call). - -assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock - -assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock - - --- integer assignment to memory - --- specific case of adding/subtracting an integer to a particular address. --- ToDo: catch other cases where we can use an operation directly on a memory --- address. -assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _, - CmmLit (CmmInt i _)]) - | addr == addr2, pk /= II64 || is32BitInteger i, - Just instr <- check op - = do Amode amode code_addr <- getAmode addr - let code = code_addr `snocOL` - instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode) - return code - where - check (MO_Add _) = Just ADD - check (MO_Sub _) = Just SUB - check _ = Nothing - -- ToDo: more? - --- general case -assignMem_IntCode pk addr src = do - is32Bit <- is32BitPlatform - Amode addr code_addr <- getAmode addr - (code_src, op_src) <- get_op_RI is32Bit src - let - code = code_src `appOL` - code_addr `snocOL` - MOV pk op_src (OpAddr addr) - -- NOTE: op_src is stable, so it will still be valid - -- after code_addr. This may involve the introduction - -- of an extra MOV to a temporary register, but we hope - -- the register allocator will get rid of it. - -- - return code - where - get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand) -- code, operator - get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit - = return (nilOL, OpImm (litToImm lit)) - get_op_RI _ op - = do (reg,code) <- getNonClobberedReg op - return (code, OpReg reg) - - --- Assign; dst is a reg, rhs is mem -assignReg_IntCode pk reg (CmmLoad src _) = do - load_code <- intLoadCode (MOV pk) src - dflags <- getDynFlags - let platform = targetPlatform dflags - return (load_code (getRegisterReg platform False{-no sse2-} reg)) - --- dst is a reg, but src could be anything -assignReg_IntCode _ reg src = do - dflags <- getDynFlags - let platform = targetPlatform dflags - code <- getAnyReg src - return (code (getRegisterReg platform False{-no sse2-} reg)) - - --- Floating point assignment to memory -assignMem_FltCode pk addr src = do - (src_reg, src_code) <- getNonClobberedReg src - Amode addr addr_code <- getAmode addr - use_sse2 <- sse2Enabled - let - code = src_code `appOL` - addr_code `snocOL` - if use_sse2 then MOV pk (OpReg src_reg) (OpAddr addr) - else GST pk src_reg addr - return code - --- Floating point assignment to a register/temporary -assignReg_FltCode _ reg src = do - use_sse2 <- sse2Enabled - src_code <- getAnyReg src - dflags <- getDynFlags - let platform = targetPlatform dflags - return (src_code (getRegisterReg platform use_sse2 reg)) - - -genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock - -genJump (CmmLoad mem _) regs = do - Amode target code <- getAmode mem - return (code `snocOL` JMP (OpAddr target) regs) - -genJump (CmmLit lit) regs = do - return (unitOL (JMP (OpImm (litToImm lit)) regs)) - -genJump expr regs = do - (reg,code) <- getSomeReg expr - return (code `snocOL` JMP (OpReg reg) regs) - - --- ----------------------------------------------------------------------------- --- Unconditional branches - -genBranch :: BlockId -> 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. - -I386: First, we have to ensure that the condition -codes are set according to the supplied comparison operation. --} - -genCondJump - :: BlockId -- the branch target - -> CmmExpr -- the condition on which to branch - -> NatM InstrBlock - -genCondJump id expr = do - is32Bit <- is32BitPlatform - genCondJump' is32Bit id expr - -genCondJump' :: Bool -> BlockId -> CmmExpr -> NatM InstrBlock - --- 64-bit integer comparisons on 32-bit -genCondJump' is32Bit true (CmmMachOp mop [e1,e2]) - | is32Bit, Just W64 <- maybeIntComparison mop = do - ChildCode64 code1 r1_lo <- iselExpr64 e1 - ChildCode64 code2 r2_lo <- iselExpr64 e2 - let r1_hi = getHiVRegFromLo r1_lo - r2_hi = getHiVRegFromLo r2_lo - cond = machOpToCond mop - Just cond' = maybeFlipCond cond - false <- getBlockIdNat - return $ code1 `appOL` code2 `appOL` toOL [ - CMP II32 (OpReg r2_hi) (OpReg r1_hi), - JXX cond true, - JXX cond' false, - CMP II32 (OpReg r2_lo) (OpReg r1_lo), - JXX cond true, - NEWBLOCK false ] - -genCondJump' _ id 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) - else do - lbl <- getBlockIdNat - - -- see comment with condFltReg - let code = case cond of - NE -> or_unordered - GU -> plain_test - GEU -> plain_test - _ -> and_ordered - - plain_test = unitOL ( - JXX cond id - ) - or_unordered = toOL [ - JXX cond id, - JXX PARITY id - ] - and_ordered = toOL [ - JXX PARITY lbl, - JXX cond id, - JXX ALWAYS lbl, - NEWBLOCK lbl - ] - return (cond_code `appOL` code) - --- ----------------------------------------------------------------------------- --- Generating C calls - --- Now the biggest nightmare---calls. Most of the nastiness is buried in --- @get_arg@, which moves the arguments to the correct registers/stack --- locations. Apart from that, the code is easy. --- --- (If applicable) Do not fill the delay slots here; you will confuse the --- register allocator. - -genCCall - :: DynFlags - -> Bool -- 32 bit platform? - -> ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --- Unroll memcpy calls if the source and destination pointers are at --- least DWORD aligned and the number of bytes to copy isn't too --- large. Otherwise, call C's memcpy. -genCCall dflags is32Bit (PrimTarget (MO_Memcpy align)) _ - [dst, src, CmmLit (CmmInt n _)] - | fromInteger insns <= maxInlineMemcpyInsns dflags && align .&. 3 == 0 = do - code_dst <- getAnyReg dst - dst_r <- getNewRegNat format - code_src <- getAnyReg src - src_r <- getNewRegNat format - tmp_r <- getNewRegNat format - return $ code_dst dst_r `appOL` code_src src_r `appOL` - go dst_r src_r tmp_r (fromInteger n) - where - -- The number of instructions we will generate (approx). We need 2 - -- instructions per move. - insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes) - - format = if align .&. 4 /= 0 then II32 else (archWordFormat is32Bit) - - -- The size of each move, in bytes. - sizeBytes :: Integer - sizeBytes = fromIntegral (formatInBytes format) - - go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr - go dst src tmp i - | i >= sizeBytes = - unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL` - unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL` - go dst src tmp (i - sizeBytes) - -- Deal with remaining bytes. - | i >= 4 = -- Will never happen on 32-bit - unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL` - unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL` - go dst src tmp (i - 4) - | i >= 2 = - unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL` - unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL` - go dst src tmp (i - 2) - | i >= 1 = - unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL` - unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL` - go dst src tmp (i - 1) - | otherwise = nilOL - where - src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone - (ImmInteger (n - i)) - dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone - (ImmInteger (n - i)) - -genCCall dflags _ (PrimTarget (MO_Memset align)) _ - [dst, - CmmLit (CmmInt c _), - CmmLit (CmmInt n _)] - | fromInteger insns <= maxInlineMemsetInsns dflags && align .&. 3 == 0 = do - code_dst <- getAnyReg dst - dst_r <- getNewRegNat format - return $ code_dst dst_r `appOL` go dst_r (fromInteger n) - where - (format, val) = case align .&. 3 of - 2 -> (II16, c2) - 0 -> (II32, c4) - _ -> (II8, c) - c2 = c `shiftL` 8 .|. c - c4 = c2 `shiftL` 16 .|. c2 - - -- The number of instructions we will generate (approx). We need 1 - -- instructions per move. - insns = (n + sizeBytes - 1) `div` sizeBytes - - -- The size of each move, in bytes. - sizeBytes :: Integer - sizeBytes = fromIntegral (formatInBytes format) - - go :: Reg -> Integer -> OrdList Instr - go dst i - -- TODO: Add movabs instruction and support 64-bit sets. - | i >= sizeBytes = -- This might be smaller than the below sizes - unitOL (MOV format (OpImm (ImmInteger val)) (OpAddr dst_addr)) `appOL` - go dst (i - sizeBytes) - | i >= 4 = -- Will never happen on 32-bit - unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr dst_addr)) `appOL` - go dst (i - 4) - | i >= 2 = - unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr dst_addr)) `appOL` - go dst (i - 2) - | i >= 1 = - unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr dst_addr)) `appOL` - go dst (i - 1) - | otherwise = nilOL - where - dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone - (ImmInteger (n - i)) - -genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ = return nilOL - -- write barrier compiles to no code on x86/x86-64; - -- we keep it this long in order to prevent earlier optimisations. - -genCCall _ _ (PrimTarget MO_Touch) _ _ = return nilOL - -genCCall _ is32bit (PrimTarget (MO_Prefetch_Data n )) _ [src] = - case n of - 0 -> genPrefetch src $ PREFETCH NTA format - 1 -> genPrefetch src $ PREFETCH Lvl2 format - 2 -> genPrefetch src $ PREFETCH Lvl1 format - 3 -> genPrefetch src $ PREFETCH Lvl0 format - l -> panic $ "unexpected prefetch level in genCCall MO_Prefetch_Data: " ++ (show l) - -- the c / llvm prefetch convention is 0, 1, 2, and 3 - -- the x86 corresponding names are : NTA, 2 , 1, and 0 - where - format = archWordFormat is32bit - -- need to know what register width for pointers! - genPrefetch inRegSrc prefetchCTor = - do - code_src <- getAnyReg inRegSrc - src_r <- getNewRegNat format - return $ code_src src_r `appOL` - (unitOL (prefetchCTor (OpAddr - ((AddrBaseIndex (EABaseReg src_r ) EAIndexNone (ImmInt 0)))) )) - -- prefetch always takes an address - -genCCall dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] = do - let platform = targetPlatform dflags - let dst_r = getRegisterReg platform False (CmmLocal dst) - case width of - W64 | is32Bit -> do - ChildCode64 vcode rlo <- iselExpr64 src - let dst_rhi = getHiVRegFromLo dst_r - rhi = getHiVRegFromLo rlo - return $ vcode `appOL` - toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi), - MOV II32 (OpReg rhi) (OpReg dst_r), - BSWAP II32 dst_rhi, - BSWAP II32 dst_r ] - W16 -> do code_src <- getAnyReg src - return $ code_src dst_r `appOL` - unitOL (BSWAP II32 dst_r) `appOL` - unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r)) - _ -> do code_src <- getAnyReg src - return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r) - where - format = intFormat width - -genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] - args@[src] = do - sse4_2 <- sse4_2Enabled - let platform = targetPlatform dflags - if sse4_2 - then do code_src <- getAnyReg src - src_r <- getNewRegNat format - let dst_r = getRegisterReg platform False (CmmLocal dst) - return $ code_src src_r `appOL` - (if width == W8 then - -- The POPCNT instruction doesn't take a r/m8 - unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL` - unitOL (POPCNT II16 (OpReg src_r) dst_r) - else - unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL` - (if width == W8 || width == W16 then - -- We used a 16-bit destination register above, - -- so zero-extend - unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) - else nilOL) - else do - targetExpr <- cmmMakeDynamicReference dflags - CallReference lbl - let target = ForeignTarget targetExpr (ForeignConvention CCallConv - [NoHint] [NoHint] - CmmMayReturn) - genCCall dflags is32Bit target dest_regs args - where - format = intFormat width - lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width)) - -genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] - | is32Bit && width == W64 = do - -- Fallback to `hs_clz64` on i386 - targetExpr <- cmmMakeDynamicReference dflags CallReference lbl - let target = ForeignTarget targetExpr (ForeignConvention CCallConv - [NoHint] [NoHint] - CmmMayReturn) - genCCall dflags is32Bit target dest_regs args - - | otherwise = do - code_src <- getAnyReg src - src_r <- getNewRegNat format - tmp_r <- getNewRegNat format - let dst_r = getRegisterReg platform False (CmmLocal dst) - - -- The following insn sequence makes sure 'clz 0' has a defined value. - -- starting with Haswell, one could use the LZCNT insn instead. - return $ code_src src_r `appOL` toOL - ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ - [ BSR format (OpReg src_r) tmp_r - , MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r) - , CMOV NE format (OpReg tmp_r) dst_r - , XOR format (OpImm (ImmInt (bw-1))) (OpReg dst_r) - ]) -- NB: We don't need to zero-extend the result for the - -- W8/W16 cases because the 'MOV' insn already - -- took care of implicitly clearing the upper bits - where - bw = widthInBits width - platform = targetPlatform dflags - format = if width == W8 then II16 else intFormat width - lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width)) - -genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] - | is32Bit, width == W64 = do - ChildCode64 vcode rlo <- iselExpr64 src - let rhi = getHiVRegFromLo rlo - dst_r = getRegisterReg platform False (CmmLocal dst) - lbl1 <- getBlockIdNat - lbl2 <- getBlockIdNat - tmp_r <- getNewRegNat format - - -- The following instruction sequence corresponds to the pseudo-code - -- - -- if (src) { - -- dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32); - -- } else { - -- dst = 64; - -- } - return $ vcode `appOL` toOL - ([ MOV II32 (OpReg rhi) (OpReg tmp_r) - , OR II32 (OpReg rlo) (OpReg tmp_r) - , MOV II32 (OpImm (ImmInt 64)) (OpReg dst_r) - , JXX EQQ lbl2 - , JXX ALWAYS lbl1 - - , NEWBLOCK lbl1 - , BSF II32 (OpReg rhi) dst_r - , ADD II32 (OpImm (ImmInt 32)) (OpReg dst_r) - , BSF II32 (OpReg rlo) tmp_r - , CMOV NE II32 (OpReg tmp_r) dst_r - , JXX ALWAYS lbl2 - - , NEWBLOCK lbl2 - ]) - - | otherwise = do - code_src <- getAnyReg src - src_r <- getNewRegNat format - tmp_r <- getNewRegNat format - let dst_r = getRegisterReg platform False (CmmLocal dst) - - -- The following insn sequence makes sure 'ctz 0' has a defined value. - -- starting with Haswell, one could use the TZCNT insn instead. - return $ code_src src_r `appOL` toOL - ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ - [ BSF format (OpReg src_r) tmp_r - , MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r) - , CMOV NE format (OpReg tmp_r) dst_r - ]) -- NB: We don't need to zero-extend the result for the - -- W8/W16 cases because the 'MOV' insn already - -- took care of implicitly clearing the upper bits - where - bw = widthInBits width - platform = targetPlatform dflags - format = if width == W8 then II16 else intFormat width - -genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do - targetExpr <- cmmMakeDynamicReference dflags - CallReference lbl - let target = ForeignTarget targetExpr (ForeignConvention CCallConv - [NoHint] [NoHint] - CmmMayReturn) - genCCall dflags is32Bit target dest_regs args - where - lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width)) - -genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do - Amode amode addr_code <- - if amop `elem` [AMO_Add, AMO_Sub] - then getAmode addr - else getSimpleAmode dflags is32Bit addr -- See genCCall for MO_Cmpxchg - arg <- getNewRegNat format - arg_code <- getAnyReg n - use_sse2 <- sse2Enabled - let platform = targetPlatform dflags - dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) - code <- op_code dst_r arg amode - return $ addr_code `appOL` arg_code arg `appOL` code - where - -- Code for the operation - op_code :: Reg -- Destination reg - -> Reg -- Register containing argument - -> AddrMode -- Address of location to mutate - -> NatM (OrdList Instr) - op_code dst_r arg amode = case amop of - -- In the common case where dst_r is a virtual register the - -- final move should go away, because it's the last use of arg - -- and the first use of dst_r. - AMO_Add -> return $ toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode)) - , MOV format (OpReg arg) (OpReg dst_r) - ] - AMO_Sub -> return $ toOL [ NEGI format (OpReg arg) - , LOCK (XADD format (OpReg arg) (OpAddr amode)) - , MOV format (OpReg arg) (OpReg dst_r) - ] - AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst) - AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst - , NOT format dst - ]) - AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst) - AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst) - where - -- Simulate operation that lacks a dedicated instruction using - -- cmpxchg. - cmpxchg_code :: (Operand -> Operand -> OrdList Instr) - -> NatM (OrdList Instr) - cmpxchg_code instrs = do - lbl <- getBlockIdNat - tmp <- getNewRegNat format - return $ toOL - [ MOV format (OpAddr amode) (OpReg eax) - , JXX ALWAYS lbl - , NEWBLOCK lbl - -- Keep old value so we can return it: - , MOV format (OpReg eax) (OpReg dst_r) - , MOV format (OpReg eax) (OpReg tmp) - ] - `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL - [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode)) - , JXX NE lbl - ] - - format = intFormat width - -genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] = do - load_code <- intLoadCode (MOV (intFormat width)) addr - let platform = targetPlatform dflags - use_sse2 <- sse2Enabled - return (load_code (getRegisterReg platform use_sse2 (CmmLocal dst))) - -genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do - code <- assignMem_IntCode (intFormat width) addr val - return $ code `snocOL` MFENCE - -genCCall dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = do - -- On x86 we don't have enough registers to use cmpxchg with a - -- complicated addressing mode, so on that architecture we - -- pre-compute the address first. - Amode amode addr_code <- getSimpleAmode dflags is32Bit addr - newval <- getNewRegNat format - newval_code <- getAnyReg new - oldval <- getNewRegNat format - oldval_code <- getAnyReg old - use_sse2 <- sse2Enabled - let platform = targetPlatform dflags - dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) - code = toOL - [ MOV format (OpReg oldval) (OpReg eax) - , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode)) - , MOV format (OpReg eax) (OpReg dst_r) - ] - return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval - `appOL` code - where - format = intFormat width - -genCCall _ is32Bit target dest_regs args = do - dflags <- getDynFlags - let platform = targetPlatform dflags - sse2 = isSse2Enabled dflags - case (target, dest_regs) of - -- void return type prim op - (PrimTarget op, []) -> - outOfLineCmmOp op Nothing args - -- we only cope with a single result for foreign calls - (PrimTarget op, [r]) - | sse2 -> case op of - MO_F32_Fabs -> case args of - [x] -> sse2FabsCode W32 x - _ -> panic "genCCall: Wrong number of arguments for fabs" - MO_F64_Fabs -> case args of - [x] -> sse2FabsCode W64 x - _ -> panic "genCCall: Wrong number of arguments for fabs" - _other_op -> outOfLineCmmOp op (Just r) args - | otherwise -> do - l1 <- getNewLabelNat - l2 <- getNewLabelNat - if sse2 - then - outOfLineCmmOp op (Just r) args - else case op of - MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args - MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args - - MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args - MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args - - MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args - MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args - - MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args - MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args - - _other_op -> outOfLineCmmOp op (Just r) args - - where - actuallyInlineFloatOp instr format [x] - = do res <- trivialUFCode format (instr format) x - any <- anyReg res - return (any (getRegisterReg platform False (CmmLocal r))) - - actuallyInlineFloatOp _ _ args - = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" - ++ show (length args) ++ ")" - - sse2FabsCode :: Width -> CmmExpr -> NatM InstrBlock - sse2FabsCode w x = do - let fmt = floatFormat w - x_code <- getAnyReg x - let - const | FF32 <- fmt = CmmInt 0x7fffffff W32 - | otherwise = CmmInt 0x7fffffffffffffff W64 - Amode amode amode_code <- memConstant (widthInBytes w) const - tmp <- getNewRegNat fmt - let - code dst = x_code dst `appOL` amode_code `appOL` toOL [ - MOV fmt (OpAddr amode) (OpReg tmp), - AND fmt (OpReg tmp) (OpReg dst) - ] - - return $ code (getRegisterReg platform True (CmmLocal r)) - - (PrimTarget (MO_S_QuotRem width), _) -> divOp1 platform True width dest_regs args - (PrimTarget (MO_U_QuotRem width), _) -> divOp1 platform False width dest_regs args - (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args - (PrimTarget (MO_Add2 width), [res_h, res_l]) -> - case args of - [arg_x, arg_y] -> - do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) - let format = intFormat width - lCode <- anyReg =<< trivialCode width (ADD_CC format) - (Just (ADD_CC format)) arg_x arg_y - let reg_l = getRegisterReg platform True (CmmLocal res_l) - reg_h = getRegisterReg platform True (CmmLocal res_h) - code = hCode reg_h `appOL` - lCode reg_l `snocOL` - ADC format (OpImm (ImmInteger 0)) (OpReg reg_h) - return code - _ -> panic "genCCall: Wrong number of arguments/results for add2" - (PrimTarget (MO_SubWordC width), [res_r, res_c]) -> - addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args - (PrimTarget (MO_AddIntC width), [res_r, res_c]) -> - addSubIntC platform ADD_CC (Just . ADD_CC) OFLO width res_r res_c args - (PrimTarget (MO_SubIntC width), [res_r, res_c]) -> - addSubIntC platform SUB_CC (const Nothing) OFLO width res_r res_c args - (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) -> - case args of - [arg_x, arg_y] -> - do (y_reg, y_code) <- getRegOrMem arg_y - x_code <- getAnyReg arg_x - let format = intFormat width - reg_h = getRegisterReg platform True (CmmLocal res_h) - reg_l = getRegisterReg platform True (CmmLocal res_l) - code = y_code `appOL` - x_code rax `appOL` - toOL [MUL2 format y_reg, - MOV format (OpReg rdx) (OpReg reg_h), - MOV format (OpReg rax) (OpReg reg_l)] - return code - _ -> panic "genCCall: Wrong number of arguments/results for mul2" - - _ -> if is32Bit - then genCCall32' dflags target dest_regs args - else genCCall64' dflags target dest_regs args - - where divOp1 platform signed width results [arg_x, arg_y] - = divOp platform signed width results Nothing arg_x arg_y - divOp1 _ _ _ _ _ - = panic "genCCall: Wrong number of arguments for divOp1" - divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y] - = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y - divOp2 _ _ _ _ _ - = panic "genCCall: Wrong number of arguments for divOp2" - divOp platform signed width [res_q, res_r] - m_arg_x_high arg_x_low arg_y - = do let format = intFormat width - reg_q = getRegisterReg platform True (CmmLocal res_q) - reg_r = getRegisterReg platform True (CmmLocal res_r) - widen | signed = CLTD format - | otherwise = XOR format (OpReg rdx) (OpReg rdx) - instr | signed = IDIV - | otherwise = DIV - (y_reg, y_code) <- getRegOrMem arg_y - x_low_code <- getAnyReg arg_x_low - x_high_code <- case m_arg_x_high of - Just arg_x_high -> - getAnyReg arg_x_high - Nothing -> - return $ const $ unitOL widen - return $ y_code `appOL` - x_low_code rax `appOL` - x_high_code rdx `appOL` - toOL [instr format y_reg, - MOV format (OpReg rax) (OpReg reg_q), - MOV format (OpReg rdx) (OpReg reg_r)] - divOp _ _ _ _ _ _ _ - = panic "genCCall: Wrong number of results for divOp" - - addSubIntC platform instr mrevinstr cond width - res_r res_c [arg_x, arg_y] - = do let format = intFormat width - rCode <- anyReg =<< trivialCode width (instr format) - (mrevinstr format) arg_x arg_y - reg_tmp <- getNewRegNat II8 - let reg_c = getRegisterReg platform True (CmmLocal res_c) - reg_r = getRegisterReg platform True (CmmLocal res_r) - code = rCode reg_r `snocOL` - SETCC cond (OpReg reg_tmp) `snocOL` - MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c) - - return code - addSubIntC _ _ _ _ _ _ _ _ - = panic "genCCall: Wrong number of arguments/results for addSubIntC" - -genCCall32' :: DynFlags - -> ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock -genCCall32' dflags target dest_regs args = do - let - prom_args = map (maybePromoteCArg dflags W32) args - - -- Align stack to 16n for calls, assuming a starting stack - -- alignment of 16n - word_size on procedure entry. Which we - -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] - sizes = map (arg_size . cmmExprType dflags) (reverse args) - raw_arg_size = sum sizes + wORD_SIZE dflags - arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size - tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE dflags - delta0 <- getDeltaNat - setDeltaNat (delta0 - arg_pad_size) - - use_sse2 <- sse2Enabled - push_codes <- mapM (push_arg use_sse2) (reverse prom_args) - delta <- getDeltaNat - MASSERT(delta == delta0 - tot_arg_size) - - -- deal with static vs dynamic call targets - (callinsns,cconv) <- - case target of - ForeignTarget (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) []), conv) - where fn_imm = ImmCLbl lbl - ForeignTarget expr conv - -> do { (dyn_r, dyn_c) <- getSomeReg expr - ; ASSERT( isWord32 (cmmExprType dflags expr) ) - return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } - PrimTarget _ - -> panic $ "genCCall: Can't handle PrimTarget call type here, error " - ++ "probably because too many return values." - - let push_code - | arg_pad_size /= 0 - = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), - DELTA (delta0 - arg_pad_size)] - `appOL` concatOL push_codes - | otherwise - = concatOL push_codes - - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - -- - -- We have to pop any stack padding we added - -- even if we are doing stdcall, though (#5052) - pop_size - | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size - | otherwise = tot_arg_size - - call = callinsns `appOL` - toOL ( - (if pop_size==0 then [] else - [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) - ++ - [DELTA delta0] - ) - setDeltaNat delta0 - - dflags <- getDynFlags - let platform = targetPlatform dflags - - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [dest] - | isFloatType ty = - if use_sse2 - then let tmp_amode = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - fmt = floatFormat w - in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), - DELTA (delta0 - b), - GST fmt fake0 tmp_amode, - MOV fmt (OpAddr tmp_amode) (OpReg r_dest), - ADD II32 (OpImm (ImmInt b)) (OpReg esp), - DELTA delta0] - else unitOL (GMOV fake0 r_dest) - | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), - MOV II32 (OpReg edx) (OpReg r_dest_hi)] - | otherwise = unitOL (MOV (intFormat w) - (OpReg eax) - (OpReg r_dest)) - where - ty = localRegType dest - w = typeWidth ty - b = widthInBytes w - r_dest_hi = getHiVRegFromLo r_dest - r_dest = getRegisterReg platform use_sse2 (CmmLocal dest) - assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) - - return (push_code `appOL` - call `appOL` - assign_code dest_regs) - - where - arg_size :: CmmType -> Int -- Width in bytes - arg_size ty = widthInBytes (typeWidth ty) - - roundTo a x | x `mod` a == 0 = x - | otherwise = x + a - (x `mod` a) - - push_arg :: Bool -> CmmActual {-current argument-} - -> NatM InstrBlock -- code - - push_arg use_sse2 arg -- we don't need the hints on x86 - | isWord64 arg_ty = do - ChildCode64 code r_lo <- iselExpr64 arg - delta <- getDeltaNat - setDeltaNat (delta - 8) - let r_hi = getHiVRegFromLo r_lo - return ( code `appOL` - toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), - PUSH II32 (OpReg r_lo), DELTA (delta - 8), - DELTA (delta-8)] - ) - - | isFloatType arg_ty = do - (reg, code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `appOL` - toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), - DELTA (delta-size), - let addr = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - format = floatFormat (typeWidth arg_ty) - in - if use_sse2 - then MOV format (OpReg reg) (OpAddr addr) - else GST format reg addr - ] - ) - - | otherwise = do - (operand, code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `snocOL` - PUSH II32 operand `snocOL` - DELTA (delta-size)) - - where - arg_ty = cmmExprType dflags arg - size = arg_size arg_ty -- Byte size - -genCCall64' :: DynFlags - -> ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock -genCCall64' dflags target dest_regs args = do - -- load up the register arguments - let prom_args = map (maybePromoteCArg dflags W32) args - - (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code) - <- - if platformOS platform == OSMinGW32 - then load_args_win prom_args [] [] (allArgRegs platform) nilOL - else do - (stack_args, aregs, fregs, load_args_code, assign_args_code) - <- load_args prom_args (allIntArgRegs platform) - (allFPArgRegs platform) - nilOL nilOL - let used_regs rs as = reverse (drop (length rs) (reverse as)) - fregs_used = used_regs fregs (allFPArgRegs platform) - aregs_used = used_regs aregs (allIntArgRegs platform) - return (stack_args, aregs_used, fregs_used, load_args_code - , assign_args_code) - - let - arg_regs_used = int_regs_used ++ fp_regs_used - arg_regs = [eax] ++ arg_regs_used - -- for annotating the call instruction with - sse_regs = length fp_regs_used - arg_stack_slots = if platformOS platform == OSMinGW32 - then length stack_args + length (allArgRegs platform) - else length stack_args - tot_arg_size = arg_size * arg_stack_slots - - - -- Align stack to 16n for calls, assuming a starting stack - -- alignment of 16n - word_size on procedure entry. Which we - -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86] - (real_size, adjust_rsp) <- - if (tot_arg_size + wORD_SIZE dflags) `rem` 16 == 0 - then return (tot_arg_size, nilOL) - else do -- we need to adjust... - delta <- getDeltaNat - setDeltaNat (delta - wORD_SIZE dflags) - return (tot_arg_size + wORD_SIZE dflags, toOL [ - SUB II64 (OpImm (ImmInt (wORD_SIZE dflags))) (OpReg rsp), - DELTA (delta - wORD_SIZE dflags) ]) - - -- push the stack args, right to left - push_code <- push_args (reverse stack_args) nilOL - -- On Win64, we also have to leave stack space for the arguments - -- that we are passing in registers - lss_code <- if platformOS platform == OSMinGW32 - then leaveStackSpace (length (allArgRegs platform)) - else return nilOL - delta <- getDeltaNat - - -- deal with static vs dynamic call targets - (callinsns,_cconv) <- - case target of - ForeignTarget (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) arg_regs), conv) - where fn_imm = ImmCLbl lbl - ForeignTarget expr conv - -> do (dyn_r, dyn_c) <- getSomeReg expr - return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) - PrimTarget _ - -> panic $ "genCCall: Can't handle PrimTarget call type here, error " - ++ "probably because too many return values." - - let - -- The x86_64 ABI requires us to set %al to the number of SSE2 - -- registers that contain arguments, if the called routine - -- is a varargs function. We don't know whether it's a - -- varargs function or not, so we have to assume it is. - -- - -- It's not safe to omit this assignment, even if the number - -- of SSE2 regs in use is zero. If %al is larger than 8 - -- on entry to a varargs function, seg faults ensue. - assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) - - let call = callinsns `appOL` - toOL ( - -- Deallocate parameters after call for ccall; - -- stdcall has callee do it, but is not supported on - -- x86_64 target (see #3336) - (if real_size==0 then [] else - [ADD (intFormat (wordWidth dflags)) (OpImm (ImmInt real_size)) (OpReg esp)]) - ++ - [DELTA (delta + real_size)] - ) - setDeltaNat (delta + real_size) - - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [dest] = - case typeWidth rep of - W32 | isFloatType rep -> unitOL (MOV (floatFormat W32) - (OpReg xmm0) - (OpReg r_dest)) - W64 | isFloatType rep -> unitOL (MOV (floatFormat W64) - (OpReg xmm0) - (OpReg r_dest)) - _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest)) - where - rep = localRegType dest - r_dest = getRegisterReg platform True (CmmLocal dest) - assign_code _many = panic "genCCall.assign_code many" - - return (adjust_rsp `appOL` - push_code `appOL` - load_args_code `appOL` - assign_args_code `appOL` - lss_code `appOL` - assign_eax sse_regs `appOL` - call `appOL` - assign_code dest_regs) - - where platform = targetPlatform dflags - arg_size = 8 -- always, at the mo - - - load_args :: [CmmExpr] - -> [Reg] -- int regs avail for args - -> [Reg] -- FP regs avail for args - -> InstrBlock -- code computing args - -> InstrBlock -- code assigning args to ABI regs - -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock) - -- no more regs to use - load_args args [] [] code acode = - return (args, [], [], code, acode) - - -- no more args to push - load_args [] aregs fregs code acode = - return ([], aregs, fregs, code, acode) - - load_args (arg : rest) aregs fregs code acode - | isFloatType arg_rep = case fregs of - [] -> push_this_arg - (r:rs) -> do - (code',acode') <- reg_this_arg r - load_args rest aregs rs code' acode' - | otherwise = case aregs of - [] -> push_this_arg - (r:rs) -> do - (code',acode') <- reg_this_arg r - load_args rest rs fregs code' acode' - where - - -- put arg into the list of stack pushed args - push_this_arg = do - (args',ars,frs,code',acode') - <- load_args rest aregs fregs code acode - return (arg:args', ars, frs, code', acode') - - -- pass the arg into the given register - reg_this_arg r - -- "operand" args can be directly assigned into r - | isOperand False arg = do - arg_code <- getAnyReg arg - return (code, (acode `appOL` arg_code r)) - -- The last non-operand arg can be directly assigned after its - -- computation without going into a temporary register - | all (isOperand False) rest = do - arg_code <- getAnyReg arg - return (code `appOL` arg_code r,acode) - - -- other args need to be computed beforehand to avoid clobbering - -- previously assigned registers used to pass parameters (see - -- #11792, #12614). They are assigned into temporary registers - -- and get assigned to proper call ABI registers after they all - -- have been computed. - | otherwise = do - arg_code <- getAnyReg arg - tmp <- getNewRegNat arg_fmt - let - code' = code `appOL` arg_code tmp - acode' = acode `snocOL` reg2reg arg_fmt tmp r - return (code',acode') - - arg_rep = cmmExprType dflags arg - arg_fmt = cmmTypeFormat arg_rep - - load_args_win :: [CmmExpr] - -> [Reg] -- used int regs - -> [Reg] -- used FP regs - -> [(Reg, Reg)] -- (int, FP) regs avail for args - -> InstrBlock - -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock) - load_args_win args usedInt usedFP [] code - = return (args, usedInt, usedFP, code, nilOL) - -- no more regs to use - load_args_win [] usedInt usedFP _ code - = return ([], usedInt, usedFP, code, nilOL) - -- no more args to push - load_args_win (arg : rest) usedInt usedFP - ((ireg, freg) : regs) code - | isFloatType arg_rep = do - arg_code <- getAnyReg arg - load_args_win rest (ireg : usedInt) (freg : usedFP) regs - (code `appOL` - arg_code freg `snocOL` - -- If we are calling a varargs function - -- then we need to define ireg as well - -- as freg - MOV II64 (OpReg freg) (OpReg ireg)) - | otherwise = do - arg_code <- getAnyReg arg - load_args_win rest (ireg : usedInt) usedFP regs - (code `appOL` arg_code ireg) - where - arg_rep = cmmExprType dflags arg - - push_args [] code = return code - push_args (arg:rest) code - | isFloatType arg_rep = do - (arg_reg, arg_code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - SUB (intFormat (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp), - DELTA (delta-arg_size), - MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel dflags 0))] - push_args rest code' - - | otherwise = do - ASSERT(width == W64) return () - (arg_op, arg_code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - PUSH II64 arg_op, - DELTA (delta-arg_size)] - push_args rest code' - where - arg_rep = cmmExprType dflags arg - width = typeWidth arg_rep - - leaveStackSpace n = do - delta <- getDeltaNat - setDeltaNat (delta - n * arg_size) - return $ toOL [ - SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp), - DELTA (delta - n * arg_size)] - -maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr -maybePromoteCArg dflags wto arg - | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg] - | otherwise = arg - where - wfrom = cmmExprWidth dflags arg - -outOfLineCmmOp :: CallishMachOp -> Maybe CmmFormal -> [CmmActual] -> NatM InstrBlock -outOfLineCmmOp mop res args - = do - dflags <- getDynFlags - targetExpr <- cmmMakeDynamicReference dflags CallReference lbl - let target = ForeignTarget targetExpr - (ForeignConvention CCallConv [] [] CmmMayReturn) - - stmtToInstrs (CmmUnsafeForeignCall target (catMaybes [res]) args) - where - -- Assume we can call these functions directly, and that they're not in a dynamic library. - -- TODO: Why is this ok? Under linux this code will be in libm.so - -- Is it because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 - lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction - - fn = case mop of - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Fabs -> fsLit "fabsf" - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" - MO_F32_Tan -> fsLit "tanf" - MO_F32_Exp -> fsLit "expf" - MO_F32_Log -> fsLit "logf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - MO_F32_Pwr -> fsLit "powf" - - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Fabs -> fsLit "fabs" - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" - MO_F64_Tan -> fsLit "tan" - MO_F64_Exp -> fsLit "exp" - MO_F64_Log -> fsLit "log" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - MO_F64_Pwr -> fsLit "pow" - - MO_Memcpy _ -> fsLit "memcpy" - MO_Memset _ -> fsLit "memset" - MO_Memmove _ -> fsLit "memmove" - - MO_PopCnt _ -> fsLit "popcnt" - MO_BSwap _ -> fsLit "bswap" - MO_Clz w -> fsLit $ clzLabel w - MO_Ctz _ -> unsupported - - MO_AtomicRMW _ _ -> fsLit "atomicrmw" - MO_AtomicRead _ -> fsLit "atomicread" - MO_AtomicWrite _ -> fsLit "atomicwrite" - MO_Cmpxchg _ -> fsLit "cmpxchg" - - MO_UF_Conv _ -> unsupported - - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - MO_Add2 {} -> unsupported - MO_AddIntC {} -> unsupported - MO_SubIntC {} -> unsupported - MO_SubWordC {} -> unsupported - MO_U_Mul2 {} -> unsupported - MO_WriteBarrier -> unsupported - MO_Touch -> unsupported - (MO_Prefetch_Data _ ) -> unsupported - unsupported = panic ("outOfLineCmmOp: " ++ show mop - ++ " not supported here") - --- ----------------------------------------------------------------------------- --- Generating a table-branch - -genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock - -genSwitch dflags expr targets - | positionIndependent dflags - = do - (reg,e_code) <- getNonClobberedReg (cmmOffset dflags expr offset) - -- getNonClobberedReg because it needs to survive across t_code - lbl <- getNewLabelNat - dflags <- getDynFlags - let is32bit = target32Bit (targetPlatform dflags) - os = platformOS (targetPlatform dflags) - -- Might want to use .rodata. instead, but as - -- long as it's something unique it'll work out since the - -- references to the jump table are in the appropriate section. - rosection = case os of - -- on Mac OS X/x86_64, put the jump table in the text section to - -- work around a limitation of the linker. - -- ld64 is unable to handle the relocations for - -- .quad L1 - L0 - -- if L0 is not preceded by a non-anonymous label in its section. - OSDarwin | not is32bit -> Section Text lbl - _ -> Section ReadOnlyData lbl - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - (tableReg,t_code) <- getSomeReg $ dynRef - let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) - (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0)) - - offsetReg <- getNewRegNat (intFormat (wordWidth dflags)) - return $ if is32bit || os == OSDarwin - then e_code `appOL` t_code `appOL` toOL [ - ADD (intFormat (wordWidth dflags)) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids rosection lbl - ] - else -- HACK: On x86_64 binutils<2.17 is only able to generate - -- PC32 relocations, hence we only get 32-bit offsets in - -- the jump table. As these offsets are always negative - -- we need to properly sign extend them to 64-bit. This - -- hack should be removed in conjunction with the hack in - -- PprMach.hs/pprDataItem once binutils 2.17 is standard. - e_code `appOL` t_code `appOL` toOL [ - MOVSxL II32 op (OpReg offsetReg), - ADD (intFormat (wordWidth dflags)) - (OpReg offsetReg) - (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids rosection lbl - ] - | otherwise - = do - (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) - lbl <- getNewLabelNat - let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl)) - code = e_code `appOL` toOL [ - JMP_TBL op ids (Section ReadOnlyData lbl) lbl - ] - return code - where (offset, ids) = switchTargetsToTable targets - -generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr) -generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl) - = Just (createJumpTable dflags ids section lbl) -generateJumpTableForInstr _ _ = Nothing - -createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel - -> GenCmmDecl (Alignment, CmmStatics) h g -createJumpTable dflags ids section lbl - = let jumpTable - | positionIndependent dflags = - let jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 (wordWidth dflags)) - jumpTableEntryRel (Just blockid) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) - where blockLabel = mkAsmTempLabel (getUnique blockid) - in map jumpTableEntryRel ids - | otherwise = map (jumpTableEntry dflags) ids - in CmmData section (1, Statics lbl jumpTable) - -extractUnwindPoints :: [Instr] -> [UnwindPoint] -extractUnwindPoints instrs = - [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs] - --- ----------------------------------------------------------------------------- --- 'condIntReg' and 'condFltReg': condition codes into registers - --- Turn those condition codes into integers now (when they appear on --- the right hand side of an assignment). --- --- (If applicable) Do not fill the delay slots here; you will confuse the --- register allocator. - -condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register - -condIntReg cond x y = do - CondCode _ cond cond_code <- condIntCode cond x y - tmp <- getNewRegNat II8 - let - code dst = cond_code `appOL` toOL [ - SETCC cond (OpReg tmp), - MOVZxL II8 (OpReg tmp) (OpReg dst) - ] - return (Any II32 code) - - - -condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register -condFltReg is32Bit cond x y = if_sse2 condFltReg_sse2 condFltReg_x87 - where - condFltReg_x87 = do - CondCode _ cond cond_code <- condFltCode cond x y - tmp <- getNewRegNat II8 - let - code dst = cond_code `appOL` toOL [ - SETCC cond (OpReg tmp), - MOVZxL II8 (OpReg tmp) (OpReg dst) - ] - return (Any II32 code) - - condFltReg_sse2 = do - CondCode _ cond cond_code <- condFltCode cond x y - tmp1 <- getNewRegNat (archWordFormat is32Bit) - tmp2 <- getNewRegNat (archWordFormat is32Bit) - let - -- 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. - -- - -- ToDo: by reversing comparisons we could avoid testing the - -- parity flag in more cases. - - code dst = - cond_code `appOL` - (case cond of - NE -> or_unordered dst - GU -> plain_test dst - GEU -> plain_test dst - _ -> and_ordered dst) - - plain_test dst = toOL [ - SETCC cond (OpReg tmp1), - MOVZxL II8 (OpReg tmp1) (OpReg dst) - ] - or_unordered dst = toOL [ - SETCC cond (OpReg tmp1), - SETCC PARITY (OpReg tmp2), - OR II8 (OpReg tmp1) (OpReg tmp2), - MOVZxL II8 (OpReg tmp2) (OpReg dst) - ] - and_ordered dst = toOL [ - SETCC cond (OpReg tmp1), - SETCC NOTPARITY (OpReg tmp2), - AND II8 (OpReg tmp1) (OpReg tmp2), - MOVZxL II8 (OpReg tmp2) (OpReg dst) - ] - return (Any II32 code) - - --- ----------------------------------------------------------------------------- --- 'trivial*Code': deal with trivial instructions - --- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', --- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. --- Only look for constants on the right hand side, because that's --- where the generic optimizer will have put them. - --- Similarly, for unary instructions, we don't have to worry about --- matching an StInt as the argument, because genericOpt will already --- have handled the constant-folding. - - -{- -The Rules of the Game are: - -* You cannot assume anything about the destination register dst; - it may be anything, including a fixed reg. - -* You may compute an operand into a fixed reg, but you may not - subsequently change the contents of that fixed reg. If you - want to do so, first copy the value either to a temporary - or into dst. You are free to modify dst even if it happens - to be a fixed reg -- that's not your problem. - -* You cannot assume that a fixed reg will stay live over an - arbitrary computation. The same applies to the dst reg. - -* Temporary regs obtained from getNewRegNat are distinct from - each other and from all other regs, and stay live over - arbitrary computations. - --------------------- - -SDM's version of The Rules: - -* If getRegister returns Any, that means it can generate correct - code which places the result in any register, period. Even if that - register happens to be read during the computation. - - Corollary #1: this means that if you are generating code for an - operation with two arbitrary operands, you cannot assign the result - of the first operand into the destination register before computing - the second operand. The second operand might require the old value - of the destination register. - - Corollary #2: A function might be able to generate more efficient - code if it knows the destination register is a new temporary (and - therefore not read by any of the sub-computations). - -* If getRegister returns Any, then the code it generates may modify only: - (a) fresh temporaries - (b) the destination register - (c) known registers (eg. %ecx is used by shifts) - In particular, it may *not* modify global registers, unless the global - register happens to be the destination register. --} - -trivialCode :: Width -> (Operand -> Operand -> Instr) - -> Maybe (Operand -> Operand -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialCode width instr m a b - = do is32Bit <- is32BitPlatform - trivialCode' is32Bit width instr m a b - -trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr) - -> Maybe (Operand -> Operand -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b - | is32BitLit is32Bit lit_a = do - b_code <- getAnyReg b - let - code dst - = b_code dst `snocOL` - revinstr (OpImm (litToImm lit_a)) (OpReg dst) - return (Any (intFormat width) code) - -trivialCode' _ width instr _ a b - = genTrivialCode (intFormat width) instr a b - --- This is re-used for floating pt instructions too. -genTrivialCode :: Format -> (Operand -> Operand -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -genTrivialCode rep instr a b = do - (b_op, b_code) <- getNonClobberedOperand b - a_code <- getAnyReg a - tmp <- getNewRegNat rep - let - -- We want the value of b to stay alive across the computation of a. - -- But, we want to calculate a straight into the destination register, - -- because the instruction only has two operands (dst := dst `op` src). - -- The troublesome case is when the result of b is in the same register - -- as the destination reg. In this case, we have to save b in a - -- new temporary across the computation of a. - code dst - | dst `regClashesWithOp` b_op = - b_code `appOL` - unitOL (MOV rep b_op (OpReg tmp)) `appOL` - a_code dst `snocOL` - instr (OpReg tmp) (OpReg dst) - | otherwise = - b_code `appOL` - a_code dst `snocOL` - instr b_op (OpReg dst) - return (Any rep code) - -regClashesWithOp :: Reg -> Operand -> Bool -reg `regClashesWithOp` OpReg reg2 = reg == reg2 -reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) -_ `regClashesWithOp` _ = False - ------------ - -trivialUCode :: Format -> (Operand -> Instr) - -> CmmExpr -> NatM Register -trivialUCode rep instr x = do - x_code <- getAnyReg x - let - code dst = - x_code dst `snocOL` - instr (OpReg dst) - return (Any rep code) - ------------ - -trivialFCode_x87 :: (Format -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialFCode_x87 instr x y = do - (x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too - (y_reg, y_code) <- getSomeReg y - let - format = FF80 -- always, on x87 - code dst = - x_code `appOL` - y_code `snocOL` - instr format x_reg y_reg dst - return (Any format code) - -trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialFCode_sse2 pk instr x y - = genTrivialCode format (instr format) x y - where format = floatFormat pk - - -trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register -trivialUFCode format instr x = do - (x_reg, x_code) <- getSomeReg x - let - code dst = - x_code `snocOL` - instr x_reg dst - return (Any format code) - - --------------------------------------------------------------------------------- -coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register -coerceInt2FP from to x = if_sse2 coerce_sse2 coerce_x87 - where - coerce_x87 = do - (x_reg, x_code) <- getSomeReg x - let - opc = case to of W32 -> GITOF; W64 -> GITOD; - n -> panic $ "coerceInt2FP.x87: unhandled width (" - ++ show n ++ ")" - code dst = x_code `snocOL` opc x_reg dst - -- ToDo: works for non-II32 reps? - return (Any FF80 code) - - coerce_sse2 = do - (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand - let - opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD - n -> panic $ "coerceInt2FP.sse: unhandled width (" - ++ show n ++ ")" - code dst = x_code `snocOL` opc (intFormat from) x_op dst - return (Any (floatFormat to) code) - -- works even if the destination rep is Width -> CmmExpr -> NatM Register -coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87 - where - coerceFP2Int_x87 = do - (x_reg, x_code) <- getSomeReg x - let - opc = case from of W32 -> GFTOI; W64 -> GDTOI - n -> panic $ "coerceFP2Int.x87: unhandled width (" - ++ show n ++ ")" - code dst = x_code `snocOL` opc x_reg dst - -- ToDo: works for non-II32 reps? - return (Any (intFormat to) code) - - coerceFP2Int_sse2 = do - (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand - let - opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ; - n -> panic $ "coerceFP2Init.sse: unhandled width (" - ++ show n ++ ")" - code dst = x_code `snocOL` opc (intFormat to) x_op dst - return (Any (intFormat to) code) - -- works even if the destination rep is CmmExpr -> NatM Register -coerceFP2FP to x = do - use_sse2 <- sse2Enabled - (x_reg, x_code) <- getSomeReg x - let - opc | use_sse2 = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD; - n -> panic $ "coerceFP2FP: unhandled width (" - ++ show n ++ ")" - | otherwise = GDTOF - code dst = x_code `snocOL` opc x_reg dst - return (Any (if use_sse2 then floatFormat to else FF80) code) - --------------------------------------------------------------------------------- - -sse2NegCode :: Width -> CmmExpr -> NatM Register -sse2NegCode w x = do - let fmt = floatFormat w - x_code <- getAnyReg x - -- This is how gcc does it, so it can't be that bad: - let - const = case fmt of - FF32 -> CmmInt 0x80000000 W32 - FF64 -> CmmInt 0x8000000000000000 W64 - x@II8 -> wrongFmt x - x@II16 -> wrongFmt x - x@II32 -> wrongFmt x - x@II64 -> wrongFmt x - x@FF80 -> wrongFmt x - where - wrongFmt x = panic $ "sse2NegCode: " ++ show x - Amode amode amode_code <- memConstant (widthInBytes w) const - tmp <- getNewRegNat fmt - let - code dst = x_code dst `appOL` amode_code `appOL` toOL [ - MOV fmt (OpAddr amode) (OpReg tmp), - XOR fmt (OpReg tmp) (OpReg dst) - ] - -- - return (Any fmt code) - -isVecExpr :: CmmExpr -> Bool -isVecExpr (CmmMachOp (MO_V_Insert {}) _) = True -isVecExpr (CmmMachOp (MO_V_Extract {}) _) = True -isVecExpr (CmmMachOp (MO_V_Add {}) _) = True -isVecExpr (CmmMachOp (MO_V_Sub {}) _) = True -isVecExpr (CmmMachOp (MO_V_Mul {}) _) = True -isVecExpr (CmmMachOp (MO_VS_Quot {}) _) = True -isVecExpr (CmmMachOp (MO_VS_Rem {}) _) = True -isVecExpr (CmmMachOp (MO_VS_Neg {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Insert {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Add {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Sub {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Mul {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Quot {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Neg {}) _) = True -isVecExpr (CmmMachOp _ [e]) = isVecExpr e -isVecExpr _ = False - -needLlvm :: NatM a -needLlvm = - sorry $ unlines ["The native code generator does not support vector" - ,"instructions. Please use -fllvm."] diff --git a/nativeGen/X86/Cond.hs b/nativeGen/X86/Cond.hs deleted file mode 100644 --- a/nativeGen/X86/Cond.hs +++ /dev/null @@ -1,68 +0,0 @@ -module X86.Cond ( - Cond(..), - condUnsigned, - condToSigned, - condToUnsigned, - maybeFlipCond -) - -where - -data Cond - = ALWAYS -- What's really used? ToDo - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - | NEG - | POS - | CARRY - | OFLO - | PARITY - | NOTPARITY - deriving Eq - -condUnsigned :: Cond -> Bool -condUnsigned GU = True -condUnsigned LU = True -condUnsigned GEU = True -condUnsigned LEU = True -condUnsigned _ = False - - -condToSigned :: Cond -> Cond -condToSigned GU = GTT -condToSigned LU = LTT -condToSigned GEU = GE -condToSigned LEU = LE -condToSigned x = x - - -condToUnsigned :: Cond -> Cond -condToUnsigned GTT = GU -condToUnsigned LTT = LU -condToUnsigned GE = GEU -condToUnsigned LE = LEU -condToUnsigned x = x - --- | @maybeFlipCond c@ returns @Just c'@ if it is possible to flip the --- arguments to the conditional @c@, and the new condition should be @c'@. -maybeFlipCond :: Cond -> Maybe Cond -maybeFlipCond cond = case cond of - EQQ -> Just EQQ - NE -> Just NE - LU -> Just GU - GU -> Just LU - LEU -> Just GEU - GEU -> Just LEU - LTT -> Just GTT - GTT -> Just LTT - LE -> Just GE - GE -> Just LE - _other -> Nothing diff --git a/nativeGen/X86/Instr.hs b/nativeGen/X86/Instr.hs deleted file mode 100644 --- a/nativeGen/X86/Instr.hs +++ /dev/null @@ -1,1059 +0,0 @@ -{-# LANGUAGE CPP, TypeFamilies #-} - ------------------------------------------------------------------------------ --- --- Machine-dependent assembly language --- --- (c) The University of Glasgow 1993-2004 --- ------------------------------------------------------------------------------ - -module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest, - getJumpDestBlockId, canShortcut, shortcutStatics, - shortcutJump, i386_insert_ffrees, allocMoreStack, - maxSpillSlots, archWordFormat) -where - -#include "HsVersions.h" -#include "nativeGen/NCG.h" - -import X86.Cond -import X86.Regs -import Instruction -import Format -import RegClass -import Reg -import TargetReg - -import BlockId -import Hoopl -import CodeGen.Platform -import Cmm -import FastString -import Outputable -import Platform - -import BasicTypes (Alignment) -import CLabel -import DynFlags -import UniqSet -import Unique -import UniqSupply -import Debug (UnwindTable) - -import Control.Monad -import Data.Maybe (fromMaybe) - --- Format of an x86/x86_64 memory address, in bytes. --- -archWordFormat :: Bool -> Format -archWordFormat is32Bit - | is32Bit = II32 - | otherwise = II64 - --- | Instruction instance for x86 instruction set. -instance Instruction Instr where - regUsageOfInstr = x86_regUsageOfInstr - patchRegsOfInstr = x86_patchRegsOfInstr - isJumpishInstr = x86_isJumpishInstr - jumpDestsOfInstr = x86_jumpDestsOfInstr - patchJumpInstr = x86_patchJumpInstr - mkSpillInstr = x86_mkSpillInstr - mkLoadInstr = x86_mkLoadInstr - takeDeltaInstr = x86_takeDeltaInstr - isMetaInstr = x86_isMetaInstr - mkRegRegMoveInstr = x86_mkRegRegMoveInstr - takeRegRegMoveInstr = x86_takeRegRegMoveInstr - mkJumpInstr = x86_mkJumpInstr - mkStackAllocInstr = x86_mkStackAllocInstr - mkStackDeallocInstr = x86_mkStackDeallocInstr - - --- ----------------------------------------------------------------------------- --- Intel x86 instructions - -{- -Intel, in their infinite wisdom, selected a stack model for floating -point registers on x86. That might have made sense back in 1979 -- -nowadays we can see it for the nonsense it really is. A stack model -fits poorly with the existing nativeGen infrastructure, which assumes -flat integer and FP register sets. Prior to this commit, nativeGen -could not generate correct x86 FP code -- to do so would have meant -somehow working the register-stack paradigm into the register -allocator and spiller, which sounds very difficult. - -We have decided to cheat, and go for a simple fix which requires no -infrastructure modifications, at the expense of generating ropey but -correct FP code. All notions of the x86 FP stack and its insns have -been removed. Instead, we pretend (to the instruction selector and -register allocator) that x86 has six floating point registers, %fake0 -.. %fake5, which can be used in the usual flat manner. We further -claim that x86 has floating point instructions very similar to SPARC -and Alpha, that is, a simple 3-operand register-register arrangement. -Code generation and register allocation proceed on this basis. - -When we come to print out the final assembly, our convenient fiction -is converted to dismal reality. Each fake instruction is -independently converted to a series of real x86 instructions. -%fake0 .. %fake5 are mapped to %st(0) .. %st(5). To do reg-reg -arithmetic operations, the two operands are pushed onto the top of the -FP stack, the operation done, and the result copied back into the -relevant register. There are only six %fake registers because 2 are -needed for the translation, and x86 has 8 in total. - -The translation is inefficient but is simple and it works. A cleverer -translation would handle a sequence of insns, simulating the FP stack -contents, would not impose a fixed mapping from %fake to %st regs, and -hopefully could avoid most of the redundant reg-reg moves of the -current translation. - -We might as well make use of whatever unique FP facilities Intel have -chosen to bless us with (let's not be churlish, after all). -Hence GLDZ and GLD1. Bwahahahahahahaha! --} - -{- -Note [x86 Floating point precision] - -Intel's internal floating point registers are by default 80 bit -extended precision. This means that all operations done on values in -registers are done at 80 bits, and unless the intermediate values are -truncated to the appropriate size (32 or 64 bits) by storing in -memory, calculations in registers will give different results from -calculations which pass intermediate values in memory (eg. via -function calls). - -One solution is to set the FPU into 64 bit precision mode. Some OSs -do this (eg. FreeBSD) and some don't (eg. Linux). The problem here is -that this will only affect 64-bit precision arithmetic; 32-bit -calculations will still be done at 64-bit precision in registers. So -it doesn't solve the whole problem. - -There's also the issue of what the C library is expecting in terms of -precision. It seems to be the case that glibc on Linux expects the -FPU to be set to 80 bit precision, so setting it to 64 bit could have -unexpected effects. Changing the default could have undesirable -effects on other 3rd-party library code too, so the right thing would -be to save/restore the FPU control word across Haskell code if we were -to do this. - -gcc's -ffloat-store gives consistent results by always storing the -results of floating-point calculations in memory, which works for both -32 and 64-bit precision. However, it only affects the values of -user-declared floating point variables in C, not intermediate results. -GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision -flag). - -Another problem is how to spill floating point registers in the -register allocator. Should we spill the whole 80 bits, or just 64? -On an OS which is set to 64 bit precision, spilling 64 is fine. On -Linux, spilling 64 bits will round the results of some operations. -This is what gcc does. Spilling at 80 bits requires taking up a full -128 bit slot (so we get alignment). We spill at 80-bits and ignore -the alignment problems. - -In the future [edit: now available in GHC 7.0.1, with the -msse2 -flag], we'll use the SSE registers for floating point. This requires -a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision -float ops), which means P4 or Xeon and above. Using SSE will solve -all these problems, because the SSE registers use fixed 32 bit or 64 -bit precision. - ---SDM 1/2003 --} - -data Instr - -- comment pseudo-op - = COMMENT FastString - - -- location pseudo-op (file, line, col, name) - | LOCATION Int Int Int String - - -- some static data spat out during code - -- generation. Will be extracted before - -- pretty-printing. - | LDATA Section (Alignment, CmmStatics) - - -- start a new basic block. Useful during - -- codegen, removed later. Preceding - -- instruction should be a jump, as per the - -- invariants for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- unwinding information - -- See Note [Unwinding information in the NCG]. - | UNWIND CLabel UnwindTable - - -- specify current stack offset for benefit of subsequent passes. - -- This carries a BlockId so it can be used in unwinding information. - | DELTA Int - - -- Moves. - | MOV Format Operand Operand - | CMOV Cond Format Operand Reg - | MOVZxL Format Operand Operand -- format is the size of operand 1 - | MOVSxL Format Operand Operand -- format is the size of operand 1 - -- x86_64 note: plain mov into a 32-bit register always zero-extends - -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which - -- don't affect the high bits of the register. - - -- Load effective address (also a very useful three-operand add instruction :-) - | LEA Format Operand Operand - - -- Int Arithmetic. - | ADD Format Operand Operand - | ADC Format Operand Operand - | SUB Format Operand Operand - | SBB Format Operand Operand - - | MUL Format Operand Operand - | MUL2 Format Operand -- %edx:%eax = operand * %rax - | IMUL Format Operand Operand -- signed int mul - | IMUL2 Format Operand -- %edx:%eax = operand * %eax - - | DIV Format Operand -- eax := eax:edx/op, edx := eax:edx%op - | IDIV Format Operand -- ditto, but signed - - -- Int Arithmetic, where the effects on the condition register - -- are important. Used in specialized sequences such as MO_Add2. - -- Do not rewrite these instructions to "equivalent" ones that - -- have different effect on the condition register! (See #9013.) - | ADD_CC Format Operand Operand - | SUB_CC Format Operand Operand - - -- Simple bit-twiddling. - | AND Format Operand Operand - | OR Format Operand Operand - | XOR Format Operand Operand - | NOT Format Operand - | NEGI Format Operand -- NEG instruction (name clash with Cond) - | BSWAP Format Reg - - -- Shifts (amount may be immediate or %cl only) - | SHL Format Operand{-amount-} Operand - | SAR Format Operand{-amount-} Operand - | SHR Format Operand{-amount-} Operand - - | BT Format Imm Operand - | NOP - - -- x86 Float Arithmetic. - -- Note that we cheat by treating G{ABS,MOV,NEG} of doubles - -- as single instructions right up until we spit them out. - -- all the 3-operand fake fp insns are src1 src2 dst - -- and furthermore are constrained to be fp regs only. - -- IMPORTANT: keep is_G_insn up to date with any changes here - | GMOV Reg Reg -- src(fpreg), dst(fpreg) - | GLD Format AddrMode Reg -- src, dst(fpreg) - | GST Format Reg AddrMode -- src(fpreg), dst - - | GLDZ Reg -- dst(fpreg) - | GLD1 Reg -- dst(fpreg) - - | GFTOI Reg Reg -- src(fpreg), dst(intreg) - | GDTOI Reg Reg -- src(fpreg), dst(intreg) - - | GITOF Reg Reg -- src(intreg), dst(fpreg) - | GITOD Reg Reg -- src(intreg), dst(fpreg) - - | GDTOF Reg Reg -- src(fpreg), dst(fpreg) - - | GADD Format Reg Reg Reg -- src1, src2, dst - | GDIV Format Reg Reg Reg -- src1, src2, dst - | GSUB Format Reg Reg Reg -- src1, src2, dst - | GMUL Format Reg Reg Reg -- src1, src2, dst - - -- FP compare. Cond must be `elem` [EQQ, NE, LE, LTT, GE, GTT] - -- Compare src1 with src2; set the Zero flag iff the numbers are - -- comparable and the comparison is True. Subsequent code must - -- test the %eflags zero flag regardless of the supplied Cond. - | GCMP Cond Reg Reg -- src1, src2 - - | GABS Format Reg Reg -- src, dst - | GNEG Format Reg Reg -- src, dst - | GSQRT Format Reg Reg -- src, dst - | GSIN Format CLabel CLabel Reg Reg -- src, dst - | GCOS Format CLabel CLabel Reg Reg -- src, dst - | GTAN Format CLabel CLabel Reg Reg -- src, dst - - | GFREE -- do ffree on all x86 regs; an ugly hack - - - -- SSE2 floating point: we use a restricted set of the available SSE2 - -- instructions for floating-point. - -- use MOV for moving (either movss or movsd (movlpd better?)) - | CVTSS2SD Reg Reg -- F32 to F64 - | CVTSD2SS Reg Reg -- F64 to F32 - | CVTTSS2SIQ Format Operand Reg -- F32 to I32/I64 (with truncation) - | CVTTSD2SIQ Format Operand Reg -- F64 to I32/I64 (with truncation) - | CVTSI2SS Format Operand Reg -- I32/I64 to F32 - | CVTSI2SD Format Operand Reg -- I32/I64 to F64 - - -- use ADD & SUB for arithmetic. In both cases, operands - -- are Operand Reg. - - -- SSE2 floating-point division: - | FDIV Format Operand Operand -- divisor, dividend(dst) - - -- use CMP for comparisons. ucomiss and ucomisd instructions - -- compare single/double prec floating point respectively. - - | SQRT Format Operand Reg -- src, dst - - - -- Comparison - | TEST Format Operand Operand - | CMP Format Operand Operand - | SETCC Cond Operand - - -- Stack Operations. - | PUSH Format Operand - | POP Format Operand - -- both unused (SDM): - -- | PUSHA - -- | POPA - - -- Jumping around. - | JMP Operand [Reg] -- including live Regs at the call - | JXX Cond BlockId -- includes unconditional branches - | JXX_GBL Cond Imm -- non-local version of JXX - -- Table jump - | JMP_TBL Operand -- Address to jump to - [Maybe BlockId] -- Blocks in the jump table - Section -- Data section jump table should be put in - CLabel -- Label of jump table - | CALL (Either Imm Reg) [Reg] - - -- Other things. - | CLTD Format -- sign extend %eax into %edx:%eax - - | FETCHGOT Reg -- pseudo-insn for ELF position-independent code - -- pretty-prints as - -- call 1f - -- 1: popl %reg - -- addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg - | FETCHPC Reg -- pseudo-insn for Darwin position-independent code - -- pretty-prints as - -- call 1f - -- 1: popl %reg - - -- bit counting instructions - | POPCNT Format Operand Reg -- [SSE4.2] count number of bits set to 1 - | BSF Format Operand Reg -- bit scan forward - | BSR Format Operand Reg -- bit scan reverse - - -- prefetch - | PREFETCH PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch - -- variant can be NTA, Lvl0, Lvl1, or Lvl2 - - | LOCK Instr -- lock prefix - | XADD Format Operand Operand -- src (r), dst (r/m) - | CMPXCHG Format Operand Operand -- src (r), dst (r/m), eax implicit - | MFENCE - -data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 - - -data Operand - = OpReg Reg -- register - | OpImm Imm -- immediate value - | OpAddr AddrMode -- memory reference - - - --- | Returns which registers are read and written as a (read, written) --- pair. -x86_regUsageOfInstr :: Platform -> Instr -> RegUsage -x86_regUsageOfInstr platform instr - = case instr of - MOV _ src dst -> usageRW src dst - CMOV _ _ src dst -> mkRU (use_R src [dst]) [dst] - MOVZxL _ src dst -> usageRW src dst - MOVSxL _ src dst -> usageRW src dst - LEA _ src dst -> usageRW src dst - ADD _ src dst -> usageRM src dst - ADC _ src dst -> usageRM src dst - SUB _ src dst -> usageRM src dst - SBB _ src dst -> usageRM src dst - IMUL _ src dst -> usageRM src dst - IMUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] - MUL _ src dst -> usageRM src dst - MUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] - DIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] - IDIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] - ADD_CC _ src dst -> usageRM src dst - SUB_CC _ src dst -> usageRM src dst - AND _ src dst -> usageRM src dst - OR _ src dst -> usageRM src dst - - XOR _ (OpReg src) (OpReg dst) - | src == dst -> mkRU [] [dst] - - XOR _ src dst -> usageRM src dst - NOT _ op -> usageM op - BSWAP _ reg -> mkRU [reg] [reg] - NEGI _ op -> usageM op - SHL _ imm dst -> usageRM imm dst - SAR _ imm dst -> usageRM imm dst - SHR _ imm dst -> usageRM imm dst - BT _ _ src -> mkRUR (use_R src []) - - PUSH _ op -> mkRUR (use_R op []) - POP _ op -> mkRU [] (def_W op) - TEST _ src dst -> mkRUR (use_R src $! use_R dst []) - CMP _ src dst -> mkRUR (use_R src $! use_R dst []) - SETCC _ op -> mkRU [] (def_W op) - JXX _ _ -> mkRU [] [] - JXX_GBL _ _ -> mkRU [] [] - JMP op regs -> mkRUR (use_R op regs) - JMP_TBL op _ _ _ -> mkRUR (use_R op []) - CALL (Left _) params -> mkRU params (callClobberedRegs platform) - CALL (Right reg) params -> mkRU (reg:params) (callClobberedRegs platform) - CLTD _ -> mkRU [eax] [edx] - NOP -> mkRU [] [] - - GMOV src dst -> mkRU [src] [dst] - GLD _ src dst -> mkRU (use_EA src []) [dst] - GST _ src dst -> mkRUR (src : use_EA dst []) - - GLDZ dst -> mkRU [] [dst] - GLD1 dst -> mkRU [] [dst] - - GFTOI src dst -> mkRU [src] [dst] - GDTOI src dst -> mkRU [src] [dst] - - GITOF src dst -> mkRU [src] [dst] - GITOD src dst -> mkRU [src] [dst] - - GDTOF src dst -> mkRU [src] [dst] - - GADD _ s1 s2 dst -> mkRU [s1,s2] [dst] - GSUB _ s1 s2 dst -> mkRU [s1,s2] [dst] - GMUL _ s1 s2 dst -> mkRU [s1,s2] [dst] - GDIV _ s1 s2 dst -> mkRU [s1,s2] [dst] - - GCMP _ src1 src2 -> mkRUR [src1,src2] - GABS _ src dst -> mkRU [src] [dst] - GNEG _ src dst -> mkRU [src] [dst] - GSQRT _ src dst -> mkRU [src] [dst] - GSIN _ _ _ src dst -> mkRU [src] [dst] - GCOS _ _ _ src dst -> mkRU [src] [dst] - GTAN _ _ _ src dst -> mkRU [src] [dst] - - CVTSS2SD src dst -> mkRU [src] [dst] - CVTSD2SS src dst -> mkRU [src] [dst] - CVTTSS2SIQ _ src dst -> mkRU (use_R src []) [dst] - CVTTSD2SIQ _ src dst -> mkRU (use_R src []) [dst] - CVTSI2SS _ src dst -> mkRU (use_R src []) [dst] - CVTSI2SD _ src dst -> mkRU (use_R src []) [dst] - FDIV _ src dst -> usageRM src dst - - FETCHGOT reg -> mkRU [] [reg] - FETCHPC reg -> mkRU [] [reg] - - COMMENT _ -> noUsage - LOCATION{} -> noUsage - UNWIND{} -> noUsage - DELTA _ -> noUsage - - POPCNT _ src dst -> mkRU (use_R src []) [dst] - BSF _ src dst -> mkRU (use_R src []) [dst] - BSR _ src dst -> mkRU (use_R src []) [dst] - - -- note: might be a better way to do this - PREFETCH _ _ src -> mkRU (use_R src []) [] - LOCK i -> x86_regUsageOfInstr platform i - XADD _ src dst -> usageMM src dst - CMPXCHG _ src dst -> usageRMM src dst (OpReg eax) - MFENCE -> noUsage - - _other -> panic "regUsage: unrecognised instr" - where - -- # Definitions - -- - -- Written: If the operand is a register, it's written. If it's an - -- address, registers mentioned in the address are read. - -- - -- Modified: If the operand is a register, it's both read and - -- written. If it's an address, registers mentioned in the address - -- are read. - - -- 2 operand form; first operand Read; second Written - usageRW :: Operand -> Operand -> RegUsage - usageRW op (OpReg reg) = mkRU (use_R op []) [reg] - usageRW op (OpAddr ea) = mkRUR (use_R op $! use_EA ea []) - usageRW _ _ = panic "X86.RegInfo.usageRW: no match" - - -- 2 operand form; first operand Read; second Modified - usageRM :: Operand -> Operand -> RegUsage - usageRM op (OpReg reg) = mkRU (use_R op [reg]) [reg] - usageRM op (OpAddr ea) = mkRUR (use_R op $! use_EA ea []) - usageRM _ _ = panic "X86.RegInfo.usageRM: no match" - - -- 2 operand form; first operand Modified; second Modified - usageMM :: Operand -> Operand -> RegUsage - usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst] - usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src] - usageMM _ _ = panic "X86.RegInfo.usageMM: no match" - - -- 3 operand form; first operand Read; second Modified; third Modified - usageRMM :: Operand -> Operand -> Operand -> RegUsage - usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg] - usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg] - usageRMM _ _ _ = panic "X86.RegInfo.usageRMM: no match" - - -- 1 operand form; operand Modified - usageM :: Operand -> RegUsage - usageM (OpReg reg) = mkRU [reg] [reg] - usageM (OpAddr ea) = mkRUR (use_EA ea []) - usageM _ = panic "X86.RegInfo.usageM: no match" - - -- Registers defd when an operand is written. - def_W (OpReg reg) = [reg] - def_W (OpAddr _ ) = [] - def_W _ = panic "X86.RegInfo.def_W: no match" - - -- Registers used when an operand is read. - use_R (OpReg reg) tl = reg : tl - use_R (OpImm _) tl = tl - use_R (OpAddr ea) tl = use_EA ea tl - - -- Registers used to compute an effective address. - use_EA (ImmAddr _ _) tl = tl - use_EA (AddrBaseIndex base index _) tl = - use_base base $! use_index index tl - where use_base (EABaseReg r) tl = r : tl - use_base _ tl = tl - use_index EAIndexNone tl = tl - use_index (EAIndex i _) tl = i : tl - - mkRUR src = src' `seq` RU src' [] - where src' = filter (interesting platform) src - - mkRU src dst = src' `seq` dst' `seq` RU src' dst' - where src' = filter (interesting platform) src - dst' = filter (interesting platform) dst - --- | Is this register interesting for the register allocator? -interesting :: Platform -> Reg -> Bool -interesting _ (RegVirtual _) = True -interesting platform (RegReal (RealRegSingle i)) = freeReg platform i -interesting _ (RegReal (RealRegPair{})) = panic "X86.interesting: no reg pairs on this arch" - - - --- | Applies the supplied function to all registers in instructions. --- Typically used to change virtual registers to real registers. -x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr -x86_patchRegsOfInstr instr env - = case instr of - MOV fmt src dst -> patch2 (MOV fmt) src dst - CMOV cc fmt src dst -> CMOV cc fmt (patchOp src) (env dst) - MOVZxL fmt src dst -> patch2 (MOVZxL fmt) src dst - MOVSxL fmt src dst -> patch2 (MOVSxL fmt) src dst - LEA fmt src dst -> patch2 (LEA fmt) src dst - ADD fmt src dst -> patch2 (ADD fmt) src dst - ADC fmt src dst -> patch2 (ADC fmt) src dst - SUB fmt src dst -> patch2 (SUB fmt) src dst - SBB fmt src dst -> patch2 (SBB fmt) src dst - IMUL fmt src dst -> patch2 (IMUL fmt) src dst - IMUL2 fmt src -> patch1 (IMUL2 fmt) src - MUL fmt src dst -> patch2 (MUL fmt) src dst - MUL2 fmt src -> patch1 (MUL2 fmt) src - IDIV fmt op -> patch1 (IDIV fmt) op - DIV fmt op -> patch1 (DIV fmt) op - ADD_CC fmt src dst -> patch2 (ADD_CC fmt) src dst - SUB_CC fmt src dst -> patch2 (SUB_CC fmt) src dst - AND fmt src dst -> patch2 (AND fmt) src dst - OR fmt src dst -> patch2 (OR fmt) src dst - XOR fmt src dst -> patch2 (XOR fmt) src dst - NOT fmt op -> patch1 (NOT fmt) op - BSWAP fmt reg -> BSWAP fmt (env reg) - NEGI fmt op -> patch1 (NEGI fmt) op - SHL fmt imm dst -> patch1 (SHL fmt imm) dst - SAR fmt imm dst -> patch1 (SAR fmt imm) dst - SHR fmt imm dst -> patch1 (SHR fmt imm) dst - BT fmt imm src -> patch1 (BT fmt imm) src - TEST fmt src dst -> patch2 (TEST fmt) src dst - CMP fmt src dst -> patch2 (CMP fmt) src dst - PUSH fmt op -> patch1 (PUSH fmt) op - POP fmt op -> patch1 (POP fmt) op - SETCC cond op -> patch1 (SETCC cond) op - JMP op regs -> JMP (patchOp op) regs - JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl - - GMOV src dst -> GMOV (env src) (env dst) - GLD fmt src dst -> GLD fmt (lookupAddr src) (env dst) - GST fmt src dst -> GST fmt (env src) (lookupAddr dst) - - GLDZ dst -> GLDZ (env dst) - GLD1 dst -> GLD1 (env dst) - - GFTOI src dst -> GFTOI (env src) (env dst) - GDTOI src dst -> GDTOI (env src) (env dst) - - GITOF src dst -> GITOF (env src) (env dst) - GITOD src dst -> GITOD (env src) (env dst) - - GDTOF src dst -> GDTOF (env src) (env dst) - - GADD fmt s1 s2 dst -> GADD fmt (env s1) (env s2) (env dst) - GSUB fmt s1 s2 dst -> GSUB fmt (env s1) (env s2) (env dst) - GMUL fmt s1 s2 dst -> GMUL fmt (env s1) (env s2) (env dst) - GDIV fmt s1 s2 dst -> GDIV fmt (env s1) (env s2) (env dst) - - GCMP fmt src1 src2 -> GCMP fmt (env src1) (env src2) - GABS fmt src dst -> GABS fmt (env src) (env dst) - GNEG fmt src dst -> GNEG fmt (env src) (env dst) - GSQRT fmt src dst -> GSQRT fmt (env src) (env dst) - GSIN fmt l1 l2 src dst -> GSIN fmt l1 l2 (env src) (env dst) - GCOS fmt l1 l2 src dst -> GCOS fmt l1 l2 (env src) (env dst) - GTAN fmt l1 l2 src dst -> GTAN fmt l1 l2 (env src) (env dst) - - CVTSS2SD src dst -> CVTSS2SD (env src) (env dst) - CVTSD2SS src dst -> CVTSD2SS (env src) (env dst) - CVTTSS2SIQ fmt src dst -> CVTTSS2SIQ fmt (patchOp src) (env dst) - CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst) - CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst) - CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst) - FDIV fmt src dst -> FDIV fmt (patchOp src) (patchOp dst) - - CALL (Left _) _ -> instr - CALL (Right reg) p -> CALL (Right (env reg)) p - - FETCHGOT reg -> FETCHGOT (env reg) - FETCHPC reg -> FETCHPC (env reg) - - NOP -> instr - COMMENT _ -> instr - LOCATION {} -> instr - UNWIND {} -> instr - DELTA _ -> instr - - JXX _ _ -> instr - JXX_GBL _ _ -> instr - CLTD _ -> instr - - POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst) - BSF fmt src dst -> BSF fmt (patchOp src) (env dst) - BSR fmt src dst -> BSR fmt (patchOp src) (env dst) - - PREFETCH lvl format src -> PREFETCH lvl format (patchOp src) - - LOCK i -> LOCK (x86_patchRegsOfInstr i env) - XADD fmt src dst -> patch2 (XADD fmt) src dst - CMPXCHG fmt src dst -> patch2 (CMPXCHG fmt) src dst - MFENCE -> instr - - _other -> panic "patchRegs: unrecognised instr" - - where - patch1 :: (Operand -> a) -> Operand -> a - patch1 insn op = insn $! patchOp op - patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a - patch2 insn src dst = (insn $! patchOp src) $! patchOp dst - - patchOp (OpReg reg) = OpReg $! env reg - patchOp (OpImm imm) = OpImm imm - patchOp (OpAddr ea) = OpAddr $! lookupAddr ea - - lookupAddr (ImmAddr imm off) = ImmAddr imm off - lookupAddr (AddrBaseIndex base index disp) - = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp - where - lookupBase EABaseNone = EABaseNone - lookupBase EABaseRip = EABaseRip - lookupBase (EABaseReg r) = EABaseReg $! env r - - lookupIndex EAIndexNone = EAIndexNone - lookupIndex (EAIndex r i) = (EAIndex $! env r) i - - --------------------------------------------------------------------------------- -x86_isJumpishInstr - :: Instr -> Bool - -x86_isJumpishInstr instr - = case instr of - JMP{} -> True - JXX{} -> True - JXX_GBL{} -> True - JMP_TBL{} -> True - CALL{} -> True - _ -> False - - -x86_jumpDestsOfInstr - :: Instr - -> [BlockId] - -x86_jumpDestsOfInstr insn - = case insn of - JXX _ id -> [id] - JMP_TBL _ ids _ _ -> [id | Just id <- ids] - _ -> [] - - -x86_patchJumpInstr - :: Instr -> (BlockId -> BlockId) -> Instr - -x86_patchJumpInstr insn patchF - = case insn of - JXX cc id -> JXX cc (patchF id) - JMP_TBL op ids section lbl - -> JMP_TBL op (map (fmap patchF) ids) section lbl - _ -> insn - - - - --- ----------------------------------------------------------------------------- --- | Make a spill instruction. -x86_mkSpillInstr - :: DynFlags - -> Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr - -x86_mkSpillInstr dflags reg delta slot - = let off = spillSlotToOffset platform slot - delta - in - case targetClassOfReg platform reg of - RcInteger -> MOV (archWordFormat is32Bit) - (OpReg reg) (OpAddr (spRel dflags off)) - RcDouble -> GST FF80 reg (spRel dflags off) {- RcFloat/RcDouble -} - RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off)) - _ -> panic "X86.mkSpillInstr: no match" - where platform = targetPlatform dflags - is32Bit = target32Bit platform - --- | Make a spill reload instruction. -x86_mkLoadInstr - :: DynFlags - -> Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr - -x86_mkLoadInstr dflags reg delta slot - = let off = spillSlotToOffset platform slot - delta - in - case targetClassOfReg platform reg of - RcInteger -> MOV (archWordFormat is32Bit) - (OpAddr (spRel dflags off)) (OpReg reg) - RcDouble -> GLD FF80 (spRel dflags off) reg {- RcFloat/RcDouble -} - RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg) - _ -> panic "X86.x86_mkLoadInstr" - where platform = targetPlatform dflags - is32Bit = target32Bit platform - -spillSlotSize :: Platform -> Int -spillSlotSize dflags = if is32Bit then 12 else 8 - where is32Bit = target32Bit dflags - -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize (targetPlatform dflags)) - 1 --- = 0 -- useful for testing allocMoreStack - --- number of bytes that the stack pointer should be aligned to -stackAlign :: Int -stackAlign = 16 - --- convert a spill slot number to a *byte* offset, with no sign: --- decide on a per arch basis whether you are spilling above or below --- the C stack pointer. -spillSlotToOffset :: Platform -> Int -> Int -spillSlotToOffset platform slot - = 64 + spillSlotSize platform * slot - --------------------------------------------------------------------------------- - --- | See if this instruction is telling us the current C stack delta -x86_takeDeltaInstr - :: Instr - -> Maybe Int - -x86_takeDeltaInstr instr - = case instr of - DELTA i -> Just i - _ -> Nothing - - -x86_isMetaInstr - :: Instr - -> Bool - -x86_isMetaInstr instr - = case instr of - COMMENT{} -> True - LOCATION{} -> True - LDATA{} -> True - NEWBLOCK{} -> True - UNWIND{} -> True - DELTA{} -> True - _ -> False - - - --- | Make a reg-reg move instruction. --- On SPARC v8 there are no instructions to move directly between --- floating point and integer regs. If we need to do that then we --- have to go via memory. --- -x86_mkRegRegMoveInstr - :: Platform - -> Reg - -> Reg - -> Instr - -x86_mkRegRegMoveInstr platform src dst - = case targetClassOfReg platform src of - RcInteger -> case platformArch platform of - ArchX86 -> MOV II32 (OpReg src) (OpReg dst) - ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst) - _ -> panic "x86_mkRegRegMoveInstr: Bad arch" - RcDouble -> GMOV src dst - RcDoubleSSE -> MOV FF64 (OpReg src) (OpReg dst) - _ -> panic "X86.RegInfo.mkRegRegMoveInstr: no match" - --- | Check whether an instruction represents a reg-reg move. --- The register allocator attempts to eliminate reg->reg moves whenever it can, --- by assigning the src and dest temporaries to the same real register. --- -x86_takeRegRegMoveInstr - :: Instr - -> Maybe (Reg,Reg) - -x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2)) - = Just (r1,r2) - -x86_takeRegRegMoveInstr _ = Nothing - - --- | Make an unconditional branch instruction. -x86_mkJumpInstr - :: BlockId - -> [Instr] - -x86_mkJumpInstr id - = [JXX ALWAYS id] - - -x86_mkStackAllocInstr - :: Platform - -> Int - -> Instr -x86_mkStackAllocInstr platform amount - = case platformArch platform of - ArchX86 -> SUB II32 (OpImm (ImmInt amount)) (OpReg esp) - ArchX86_64 -> SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) - _ -> panic "x86_mkStackAllocInstr" - -x86_mkStackDeallocInstr - :: Platform - -> Int - -> Instr -x86_mkStackDeallocInstr platform amount - = case platformArch platform of - ArchX86 -> ADD II32 (OpImm (ImmInt amount)) (OpReg esp) - ArchX86_64 -> ADD II64 (OpImm (ImmInt amount)) (OpReg rsp) - _ -> panic "x86_mkStackDeallocInstr" - -i386_insert_ffrees - :: [GenBasicBlock Instr] - -> [GenBasicBlock Instr] - -i386_insert_ffrees blocks - | any (any is_G_instr) [ instrs | BasicBlock _ instrs <- blocks ] - = map insertGFREEs blocks - | otherwise - = blocks - where - insertGFREEs (BasicBlock id insns) - = BasicBlock id (insertBeforeNonlocalTransfers GFREE insns) - -insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr] -insertBeforeNonlocalTransfers insert insns - = foldr p [] insns - where p insn r = case insn of - CALL _ _ -> insert : insn : r - JMP _ _ -> insert : insn : r - JXX_GBL _ _ -> panic "insertBeforeNonlocalTransfers: cannot handle JXX_GBL" - _ -> insn : r - - --- if you ever add a new FP insn to the fake x86 FP insn set, --- you must update this too -is_G_instr :: Instr -> Bool -is_G_instr instr - = case instr of - GMOV{} -> True - GLD{} -> True - GST{} -> True - GLDZ{} -> True - GLD1{} -> True - GFTOI{} -> True - GDTOI{} -> True - GITOF{} -> True - GITOD{} -> True - GDTOF{} -> True - GADD{} -> True - GDIV{} -> True - GSUB{} -> True - GMUL{} -> True - GCMP{} -> True - GABS{} -> True - GNEG{} -> True - GSQRT{} -> True - GSIN{} -> True - GCOS{} -> True - GTAN{} -> True - GFREE -> panic "is_G_instr: GFREE (!)" - _ -> False - - --- --- Note [extra spill slots] --- --- If the register allocator used more spill slots than we have --- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more --- C stack space on entry and exit from this proc. Therefore we --- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp" --- before every non-local jump. --- --- This became necessary when the new codegen started bundling entire --- functions together into one proc, because the register allocator --- assigns a different stack slot to each virtual reg within a proc. --- To avoid using so many slots we could also: --- --- - split up the proc into connected components before code generator --- --- - rename the virtual regs, so that we re-use vreg names and hence --- stack slots for non-overlapping vregs. --- --- Note that when a block is both a non-local entry point (with an --- info table) and a local branch target, we have to split it into --- two, like so: --- --- --- L: --- --- --- becomes --- --- --- L: --- subl $rsp, N --- jmp Lnew --- Lnew: --- --- --- and all branches pointing to L are retargetted to point to Lnew. --- Otherwise, we would repeat the $rsp adjustment for each branch to --- L. --- -allocMoreStack - :: Platform - -> Int - -> NatCmmDecl statics X86.Instr.Instr - -> UniqSM (NatCmmDecl statics X86.Instr.Instr) - -allocMoreStack _ _ top@(CmmData _ _) = return top -allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do - let entries = entryBlocks proc - - uniqs <- replicateM (length entries) getUniqueM - - let - delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up - where x = slots * spillSlotSize platform -- sp delta - - alloc = mkStackAllocInstr platform delta - dealloc = mkStackDeallocInstr platform delta - - new_blockmap :: LabelMap BlockId - new_blockmap = mapFromList (zip entries (map mkBlockId uniqs)) - - insert_stack_insns (BasicBlock id insns) - | Just new_blockid <- mapLookup id new_blockmap - = [ BasicBlock id [alloc, JXX ALWAYS new_blockid] - , BasicBlock new_blockid block' ] - | otherwise - = [ BasicBlock id block' ] - where - block' = foldr insert_dealloc [] insns - - insert_dealloc insn r = case insn of - JMP _ _ -> dealloc : insn : r - JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL" - _other -> x86_patchJumpInstr insn retarget : r - where retarget b = fromMaybe b (mapLookup b new_blockmap) - - new_code = concatMap insert_stack_insns code - -- in - return (CmmProc info lbl live (ListGraph new_code)) - - -data JumpDest = DestBlockId BlockId | DestImm Imm - -getJumpDestBlockId :: JumpDest -> Maybe BlockId -getJumpDestBlockId (DestBlockId bid) = Just bid -getJumpDestBlockId _ = Nothing - -canShortcut :: Instr -> Maybe JumpDest -canShortcut (JXX ALWAYS id) = Just (DestBlockId id) -canShortcut (JMP (OpImm imm) _) = Just (DestImm imm) -canShortcut _ = Nothing - - --- This helper shortcuts a sequence of branches. --- The blockset helps avoid following cycles. -shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr -shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn - where shortcutJump' fn seen insn@(JXX cc id) = - if setMember id seen then insn - else case fn id of - Nothing -> insn - Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id') - Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm) - where seen' = setInsert id seen - shortcutJump' _ _ other = other - --- Here because it knows about JumpDest -shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics) -shortcutStatics fn (align, Statics lbl statics) - = (align, Statics lbl $ map (shortcutStatic fn) statics) - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. - -shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel -shortcutLabel fn lab - | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq) - | 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)) - = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) - -- slightly dodgy, we're ignoring the second label, but this - -- works with the way we use CmmLabelDiffOff for jump tables now. -shortcutStatic _ other_static - = other_static - -shortBlockId - :: (BlockId -> Maybe JumpDest) - -> UniqSet Unique - -> BlockId - -> CLabel - -shortBlockId fn seen blockid = - case (elementOfUniqSet uq seen, fn blockid) of - (True, _) -> mkAsmTempLabel uq - (_, Nothing) -> mkAsmTempLabel uq - (_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid' - (_, Just (DestImm (ImmCLbl lbl))) -> lbl - (_, _other) -> panic "shortBlockId" - where uq = getUnique blockid diff --git a/nativeGen/X86/Ppr.hs b/nativeGen/X86/Ppr.hs deleted file mode 100644 --- a/nativeGen/X86/Ppr.hs +++ /dev/null @@ -1,1303 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Pretty-printing assembly language --- --- (c) The University of Glasgow 1993-2005 --- ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module X86.Ppr ( - pprNatCmmDecl, - pprData, - pprInstr, - pprFormat, - pprImm, - pprDataItem, -) - -where - -#include "HsVersions.h" -#include "nativeGen/NCG.h" - -import X86.Regs -import X86.Instr -import X86.Cond -import Instruction -import Format -import Reg -import PprBase - - -import Hoopl -import BasicTypes (Alignment) -import DynFlags -import Cmm hiding (topInfoTable) -import CLabel -import Unique ( pprUniqueAlways, Uniquable(..) ) -import Platform -import FastString -import Outputable - -import Data.Word - -import Data.Char - -import Data.Bits - --- ----------------------------------------------------------------------------- --- Printing this stuff out --- --- --- Note [Subsections Via Symbols] --- --- If we are using the .subsections_via_symbols directive --- (available on recent versions of Darwin), --- we have to make sure that there is some kind of reference --- from the entry code to a label on the _top_ of of the info table, --- so that the linker will not think it is unreferenced and dead-strip --- it. That's why the label is called a DeadStripPreventer (_dsp). --- --- The LLVM code gen already creates `iTableSuf` symbols, where --- the X86 would generate the DeadStripPreventer (_dsp) symbol. --- Therefore all that is left for llvm code gen, is to ensure --- that all the `iTableSuf` symbols are marked as used. --- As of this writing the documentation regarding the --- .subsections_via_symbols and -dead_strip can be found at --- - -pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc -pprNatCmmDecl (CmmData section dats) = - pprSectionAlign section $$ pprDatas dats - -pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - sdocWithDynFlags $ \dflags -> - case topInfoTable proc of - Nothing -> - case blocks of - [] -> -- special case for split markers: - pprLabel lbl - blocks -> -- special case for code without info table: - pprSectionAlign (Section Text lbl) $$ - pprLabel lbl $$ -- blocks guaranteed not null, so label needed - vcat (map (pprBasicBlock top_info) blocks) $$ - (if debugLevel dflags > 0 - then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ - pprSizeDecl lbl - - Just (Statics info_lbl _) -> - sdocWithPlatform $ \platform -> - pprSectionAlign (Section Text info_lbl) $$ - (if platformHasSubsectionsViaSymbols platform - then ppr (mkDeadStripPreventer info_lbl) <> char ':' - else empty) $$ - vcat (map (pprBasicBlock top_info) blocks) $$ - -- above: Even the first block gets a label, because with branch-chain - -- elimination, it might be the target of a goto. - (if platformHasSubsectionsViaSymbols platform - then -- See Note [Subsections Via Symbols] - text "\t.long " - <+> ppr info_lbl - <+> char '-' - <+> ppr (mkDeadStripPreventer info_lbl) - else empty) $$ - (if debugLevel dflags > 0 - then ppr (mkAsmTempEndLabel info_lbl) <> char ':' else empty) $$ - pprSizeDecl info_lbl - --- | Output the ELF .size directive. -pprSizeDecl :: CLabel -> SDoc -pprSizeDecl lbl - = sdocWithPlatform $ \platform -> - if osElfTarget (platformOS platform) - then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl - else empty - -pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock info_env (BasicBlock blockid instrs) - = sdocWithDynFlags $ \dflags -> - maybe_infotable $$ - pprLabel asmLbl $$ - vcat (map pprInstr instrs) $$ - (if debugLevel dflags > 0 - then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty) - where - asmLbl = mkAsmTempLabel (getUnique blockid) - maybe_infotable = case mapLookup blockid info_env of - Nothing -> empty - Just (Statics info_lbl info) -> - pprAlignForSection Text $$ - infoTableLoc $$ - vcat (map pprData info) $$ - pprLabel info_lbl - -- Make sure the info table has the right .loc for the block - -- coming right after it. See [Note: Info Offset] - infoTableLoc = case instrs of - (l@LOCATION{} : _) -> pprInstr l - _other -> empty - -pprDatas :: (Alignment, CmmStatics) -> SDoc -pprDatas (align, (Statics lbl dats)) - = vcat (pprAlign align : pprLabel lbl : map pprData dats) - -pprData :: CmmStatic -> SDoc -pprData (CmmString str) - = ptext (sLit "\t.asciz ") <> doubleQuotes (pprASCII str) - -pprData (CmmUninitialised bytes) - = sdocWithPlatform $ \platform -> - if platformOS platform == OSDarwin then text ".space " <> int bytes - else text ".skip " <> int bytes - -pprData (CmmStaticLit lit) = pprDataItem lit - -pprGloblDecl :: CLabel -> SDoc -pprGloblDecl lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> ppr lbl - -pprTypeAndSizeDecl :: CLabel -> SDoc -pprTypeAndSizeDecl lbl - = sdocWithPlatform $ \platform -> - if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then text ".type " <> ppr lbl <> ptext (sLit ", @object") - else empty - -pprLabel :: CLabel -> SDoc -pprLabel lbl = pprGloblDecl lbl - $$ pprTypeAndSizeDecl lbl - $$ (ppr lbl <> char ':') - - -pprASCII :: [Word8] -> SDoc -pprASCII str - = hcat (map (do1 . fromIntegral) str) - where - do1 :: Int -> SDoc - do1 w | '\t' <- chr w = ptext (sLit "\\t") - do1 w | '\n' <- chr w = ptext (sLit "\\n") - do1 w | '"' <- chr w = ptext (sLit "\\\"") - do1 w | '\\' <- chr w = ptext (sLit "\\\\") - do1 w | isPrint (chr w) = char (chr w) - do1 w | otherwise = char '\\' <> octal w - - octal :: Int -> SDoc - octal w = int ((w `div` 64) `mod` 8) - <> int ((w `div` 8) `mod` 8) - <> int (w `mod` 8) - -pprAlign :: Int -> SDoc -pprAlign bytes - = sdocWithPlatform $ \platform -> - text ".align " <> int (alignment platform) - where - alignment platform = if platformOS platform == OSDarwin - then log2 bytes - else bytes - - log2 :: Int -> Int -- cache the common ones - log2 1 = 0 - log2 2 = 1 - log2 4 = 2 - log2 8 = 3 - log2 n = 1 + log2 (n `quot` 2) - --- ----------------------------------------------------------------------------- --- pprInstr: print an 'Instr' - -instance Outputable Instr where - ppr instr = pprInstr instr - - -pprReg :: Format -> Reg -> SDoc -pprReg f r - = case r of - RegReal (RealRegSingle i) -> - sdocWithPlatform $ \platform -> - if target32Bit platform then ppr32_reg_no f i - else ppr64_reg_no f i - RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" - RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u - RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u - RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u - RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u - RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUniqueAlways u - where - ppr32_reg_no :: Format -> Int -> SDoc - ppr32_reg_no II8 = ppr32_reg_byte - ppr32_reg_no II16 = ppr32_reg_word - ppr32_reg_no _ = ppr32_reg_long - - ppr32_reg_byte i = ptext - (case i of { - 0 -> sLit "%al"; 1 -> sLit "%bl"; - 2 -> sLit "%cl"; 3 -> sLit "%dl"; - _ -> sLit "very naughty I386 byte register" - }) - - ppr32_reg_word i = ptext - (case i of { - 0 -> sLit "%ax"; 1 -> sLit "%bx"; - 2 -> sLit "%cx"; 3 -> sLit "%dx"; - 4 -> sLit "%si"; 5 -> sLit "%di"; - 6 -> sLit "%bp"; 7 -> sLit "%sp"; - _ -> sLit "very naughty I386 word register" - }) - - ppr32_reg_long i = ptext - (case i of { - 0 -> sLit "%eax"; 1 -> sLit "%ebx"; - 2 -> sLit "%ecx"; 3 -> sLit "%edx"; - 4 -> sLit "%esi"; 5 -> sLit "%edi"; - 6 -> sLit "%ebp"; 7 -> sLit "%esp"; - _ -> ppr_reg_float i - }) - - ppr64_reg_no :: Format -> Int -> SDoc - ppr64_reg_no II8 = ppr64_reg_byte - ppr64_reg_no II16 = ppr64_reg_word - ppr64_reg_no II32 = ppr64_reg_long - ppr64_reg_no _ = ppr64_reg_quad - - ppr64_reg_byte i = ptext - (case i of { - 0 -> sLit "%al"; 1 -> sLit "%bl"; - 2 -> sLit "%cl"; 3 -> sLit "%dl"; - 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs! - 6 -> sLit "%bpl"; 7 -> sLit "%spl"; - 8 -> sLit "%r8b"; 9 -> sLit "%r9b"; - 10 -> sLit "%r10b"; 11 -> sLit "%r11b"; - 12 -> sLit "%r12b"; 13 -> sLit "%r13b"; - 14 -> sLit "%r14b"; 15 -> sLit "%r15b"; - _ -> sLit "very naughty x86_64 byte register" - }) - - ppr64_reg_word i = ptext - (case i of { - 0 -> sLit "%ax"; 1 -> sLit "%bx"; - 2 -> sLit "%cx"; 3 -> sLit "%dx"; - 4 -> sLit "%si"; 5 -> sLit "%di"; - 6 -> sLit "%bp"; 7 -> sLit "%sp"; - 8 -> sLit "%r8w"; 9 -> sLit "%r9w"; - 10 -> sLit "%r10w"; 11 -> sLit "%r11w"; - 12 -> sLit "%r12w"; 13 -> sLit "%r13w"; - 14 -> sLit "%r14w"; 15 -> sLit "%r15w"; - _ -> sLit "very naughty x86_64 word register" - }) - - ppr64_reg_long i = ptext - (case i of { - 0 -> sLit "%eax"; 1 -> sLit "%ebx"; - 2 -> sLit "%ecx"; 3 -> sLit "%edx"; - 4 -> sLit "%esi"; 5 -> sLit "%edi"; - 6 -> sLit "%ebp"; 7 -> sLit "%esp"; - 8 -> sLit "%r8d"; 9 -> sLit "%r9d"; - 10 -> sLit "%r10d"; 11 -> sLit "%r11d"; - 12 -> sLit "%r12d"; 13 -> sLit "%r13d"; - 14 -> sLit "%r14d"; 15 -> sLit "%r15d"; - _ -> sLit "very naughty x86_64 register" - }) - - ppr64_reg_quad i = ptext - (case i of { - 0 -> sLit "%rax"; 1 -> sLit "%rbx"; - 2 -> sLit "%rcx"; 3 -> sLit "%rdx"; - 4 -> sLit "%rsi"; 5 -> sLit "%rdi"; - 6 -> sLit "%rbp"; 7 -> sLit "%rsp"; - 8 -> sLit "%r8"; 9 -> sLit "%r9"; - 10 -> sLit "%r10"; 11 -> sLit "%r11"; - 12 -> sLit "%r12"; 13 -> sLit "%r13"; - 14 -> sLit "%r14"; 15 -> sLit "%r15"; - _ -> ppr_reg_float i - }) - -ppr_reg_float :: Int -> LitString -ppr_reg_float i = case i of - 16 -> sLit "%fake0"; 17 -> sLit "%fake1" - 18 -> sLit "%fake2"; 19 -> sLit "%fake3" - 20 -> sLit "%fake4"; 21 -> sLit "%fake5" - 24 -> sLit "%xmm0"; 25 -> sLit "%xmm1" - 26 -> sLit "%xmm2"; 27 -> sLit "%xmm3" - 28 -> sLit "%xmm4"; 29 -> sLit "%xmm5" - 30 -> sLit "%xmm6"; 31 -> sLit "%xmm7" - 32 -> sLit "%xmm8"; 33 -> sLit "%xmm9" - 34 -> sLit "%xmm10"; 35 -> sLit "%xmm11" - 36 -> sLit "%xmm12"; 37 -> sLit "%xmm13" - 38 -> sLit "%xmm14"; 39 -> sLit "%xmm15" - _ -> sLit "very naughty x86 register" - -pprFormat :: Format -> SDoc -pprFormat x - = ptext (case x of - II8 -> sLit "b" - II16 -> sLit "w" - II32 -> sLit "l" - II64 -> sLit "q" - FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2) - FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2) - FF80 -> sLit "t" - ) - -pprFormat_x87 :: Format -> SDoc -pprFormat_x87 x - = ptext $ case x of - FF32 -> sLit "s" - FF64 -> sLit "l" - FF80 -> sLit "t" - _ -> panic "X86.Ppr.pprFormat_x87" - -pprCond :: Cond -> SDoc -pprCond c - = ptext (case c of { - GEU -> sLit "ae"; LU -> sLit "b"; - EQQ -> sLit "e"; GTT -> sLit "g"; - GE -> sLit "ge"; GU -> sLit "a"; - LTT -> sLit "l"; LE -> sLit "le"; - LEU -> sLit "be"; NE -> sLit "ne"; - NEG -> sLit "s"; POS -> sLit "ns"; - CARRY -> sLit "c"; OFLO -> sLit "o"; - PARITY -> sLit "p"; NOTPARITY -> sLit "np"; - ALWAYS -> sLit "mp"}) - - -pprImm :: Imm -> SDoc -pprImm (ImmInt i) = int i -pprImm (ImmInteger i) = integer i -pprImm (ImmCLbl l) = ppr l -pprImm (ImmIndex l i) = ppr l <> char '+' <> int i -pprImm (ImmLit s) = s - -pprImm (ImmFloat _) = text "naughty float immediate" -pprImm (ImmDouble _) = text "naughty double immediate" - -pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b -pprImm (ImmConstantDiff a b) = pprImm a <> char '-' - <> lparen <> pprImm b <> rparen - - - -pprAddr :: AddrMode -> SDoc -pprAddr (ImmAddr imm off) - = let pp_imm = pprImm imm - in - if (off == 0) then - pp_imm - else if (off < 0) then - pp_imm <> int off - else - pp_imm <> char '+' <> int off - -pprAddr (AddrBaseIndex base index displacement) - = sdocWithPlatform $ \platform -> - let - pp_disp = ppr_disp displacement - pp_off p = pp_disp <> char '(' <> p <> char ')' - pp_reg r = pprReg (archWordFormat (target32Bit platform)) r - in - case (base, index) of - (EABaseNone, EAIndexNone) -> pp_disp - (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b) - (EABaseRip, EAIndexNone) -> pp_off (text "%rip") - (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i) - (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r - <> comma <> int i) - _ -> panic "X86.Ppr.pprAddr: no match" - - where - ppr_disp (ImmInt 0) = empty - ppr_disp imm = pprImm imm - --- | Print section header and appropriate alignment for that section. -pprSectionAlign :: Section -> SDoc -pprSectionAlign (Section (OtherSection _) _) = - panic "X86.Ppr.pprSectionAlign: unknown section" -pprSectionAlign sec@(Section seg _) = - sdocWithPlatform $ \platform -> - pprSectionHeader platform sec $$ - pprAlignForSection seg - --- | Print appropriate alignment for the given section type. -pprAlignForSection :: SectionType -> SDoc -pprAlignForSection seg = - sdocWithPlatform $ \platform -> - text ".align " <> - case platformOS platform of - -- Darwin: alignments are given as shifts. - OSDarwin - | target32Bit platform -> - case seg of - ReadOnlyData16 -> int 4 - CString -> int 1 - _ -> int 2 - | otherwise -> - case seg of - ReadOnlyData16 -> int 4 - CString -> int 1 - _ -> int 3 - -- Other: alignments are given as bytes. - _ - | target32Bit platform -> - case seg of - Text -> text "4,0x90" - ReadOnlyData16 -> int 16 - CString -> int 1 - _ -> int 4 - | otherwise -> - case seg of - ReadOnlyData16 -> int 16 - CString -> int 1 - _ -> int 8 - -pprDataItem :: CmmLit -> SDoc -pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit - -pprDataItem' :: DynFlags -> CmmLit -> SDoc -pprDataItem' dflags lit - = vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit) - where - platform = targetPlatform dflags - imm = litToImm lit - - -- These seem to be common: - ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] - ppr_item II16 _ = [text "\t.word\t" <> pprImm imm] - ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] - - ppr_item FF32 (CmmFloat r _) - = let bs = floatToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item FF64 (CmmFloat r _) - = let bs = doubleToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item II64 _ - = case platformOS platform of - OSDarwin - | target32Bit platform -> - case lit of - CmmInt x _ -> - [text "\t.long\t" - <> int (fromIntegral (fromIntegral x :: Word32)), - text "\t.long\t" - <> int (fromIntegral - (fromIntegral (x `shiftR` 32) :: Word32))] - _ -> panic "X86.Ppr.ppr_item: no match for II64" - | otherwise -> - [text "\t.quad\t" <> pprImm imm] - _ - | target32Bit platform -> - [text "\t.quad\t" <> pprImm imm] - | otherwise -> - -- x86_64: binutils can't handle the R_X86_64_PC64 - -- relocation type, which means we can't do - -- pc-relative 64-bit addresses. Fortunately we're - -- assuming the small memory model, in which all such - -- offsets will fit into 32 bits, so we have to stick - -- to 32-bit offset fields and modify the RTS - -- appropriately - -- - -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h - -- - case lit of - -- A relative relocation: - CmmLabelDiffOff _ _ _ -> - [text "\t.long\t" <> pprImm imm, - text "\t.long\t0"] - _ -> - [text "\t.quad\t" <> pprImm imm] - - ppr_item _ _ - = panic "X86.Ppr.ppr_item: no match" - - -asmComment :: SDoc -> SDoc -asmComment c = ifPprDebug $ text "# " <> c - -pprInstr :: Instr -> SDoc - -pprInstr (COMMENT s) - = asmComment (ftext s) - -pprInstr (LOCATION file line col _name) - = text "\t.loc " <> ppr file <+> ppr line <+> ppr col - -pprInstr (DELTA d) - = asmComment $ text ("\tdelta = " ++ show d) - -pprInstr (NEWBLOCK _) - = panic "PprMach.pprInstr: NEWBLOCK" - -pprInstr (UNWIND lbl d) - = asmComment (text "\tunwind = " <> ppr d) - $$ ppr lbl <> colon - -pprInstr (LDATA _ _) - = panic "PprMach.pprInstr: LDATA" - -{- -pprInstr (SPILL reg slot) - = hcat [ - text "\tSPILL", - char ' ', - pprUserReg reg, - comma, - text "SLOT" <> parens (int slot)] - -pprInstr (RELOAD slot reg) - = hcat [ - text "\tRELOAD", - char ' ', - text "SLOT" <> parens (int slot), - comma, - pprUserReg reg] --} - --- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper. --- The code generator catches most of these already, but not all. -pprInstr (MOV format (OpImm (ImmInt 0)) dst@(OpReg _)) - = pprInstr (XOR format' dst dst) - where format' = case format of - II64 -> II32 -- 32-bit version is equivalent, and smaller - _ -> format -pprInstr (MOV format src dst) - = pprFormatOpOp (sLit "mov") format src dst - -pprInstr (CMOV cc format src dst) - = pprCondOpReg (sLit "cmov") format cc src dst - -pprInstr (MOVZxL II32 src dst) = pprFormatOpOp (sLit "mov") II32 src dst - -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple - -- movl. But we represent it as a MOVZxL instruction, because - -- the reg alloc would tend to throw away a plain reg-to-reg - -- move, and we still want it to do that. - -pprInstr (MOVZxL formats src dst) - = pprFormatOpOpCoerce (sLit "movz") formats II32 src dst - -- zero-extension only needs to extend to 32 bits: on x86_64, - -- the remaining zero-extension to 64 bits is automatic, and the 32-bit - -- instruction is shorter. - -pprInstr (MOVSxL formats src dst) - = sdocWithPlatform $ \platform -> - pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst - --- here we do some patching, since the physical registers are only set late --- in the code generation. -pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) - | reg1 == reg3 - = pprFormatOpOp (sLit "add") format (OpReg reg2) dst - -pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) - | reg2 == reg3 - = pprFormatOpOp (sLit "add") format (OpReg reg1) dst - -pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) - | reg1 == reg3 - = pprInstr (ADD format (OpImm displ) dst) - -pprInstr (LEA format src dst) = pprFormatOpOp (sLit "lea") format src dst - -pprInstr (ADD format (OpImm (ImmInt (-1))) dst) - = pprFormatOp (sLit "dec") format dst -pprInstr (ADD format (OpImm (ImmInt 1)) dst) - = pprFormatOp (sLit "inc") format dst -pprInstr (ADD format src dst) = pprFormatOpOp (sLit "add") format src dst -pprInstr (ADC format src dst) = pprFormatOpOp (sLit "adc") format src dst -pprInstr (SUB format src dst) = pprFormatOpOp (sLit "sub") format src dst -pprInstr (SBB format src dst) = pprFormatOpOp (sLit "sbb") format src dst -pprInstr (IMUL format op1 op2) = pprFormatOpOp (sLit "imul") format op1 op2 - -pprInstr (ADD_CC format src dst) - = pprFormatOpOp (sLit "add") format src dst -pprInstr (SUB_CC format src dst) - = pprFormatOpOp (sLit "sub") format src dst - -{- A hack. The Intel documentation says that "The two and three - operand forms [of IMUL] may also be used with unsigned operands - because the lower half of the product is the same regardless if - (sic) the operands are signed or unsigned. The CF and OF flags, - however, cannot be used to determine if the upper half of the - result is non-zero." So there. --} - --- Use a 32-bit instruction when possible as it saves a byte. --- Notably, extracting the tag bits of a pointer has this form. --- TODO: we could save a byte in a subsequent CMP instruction too, --- but need something like a peephole pass for this -pprInstr (AND II64 src@(OpImm (ImmInteger mask)) dst) - | 0 <= mask && mask < 0xffffffff - = pprInstr (AND II32 src dst) -pprInstr (AND FF32 src dst) = pprOpOp (sLit "andps") FF32 src dst -pprInstr (AND FF64 src dst) = pprOpOp (sLit "andpd") FF64 src dst -pprInstr (AND format src dst) = pprFormatOpOp (sLit "and") format src dst -pprInstr (OR format src dst) = pprFormatOpOp (sLit "or") format src dst - -pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst -pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst -pprInstr (XOR format src dst) = pprFormatOpOp (sLit "xor") format src dst - -pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst) -pprInstr (BSF format src dst) = pprOpOp (sLit "bsf") format src (OpReg dst) -pprInstr (BSR format src dst) = pprOpOp (sLit "bsr") format src (OpReg dst) - -pprInstr (PREFETCH NTA format src ) = pprFormatOp_ (sLit "prefetchnta") format src -pprInstr (PREFETCH Lvl0 format src) = pprFormatOp_ (sLit "prefetcht0") format src -pprInstr (PREFETCH Lvl1 format src) = pprFormatOp_ (sLit "prefetcht1") format src -pprInstr (PREFETCH Lvl2 format src) = pprFormatOp_ (sLit "prefetcht2") format src - -pprInstr (NOT format op) = pprFormatOp (sLit "not") format op -pprInstr (BSWAP format op) = pprFormatOp (sLit "bswap") format (OpReg op) -pprInstr (NEGI format op) = pprFormatOp (sLit "neg") format op - -pprInstr (SHL format src dst) = pprShift (sLit "shl") format src dst -pprInstr (SAR format src dst) = pprShift (sLit "sar") format src dst -pprInstr (SHR format src dst) = pprShift (sLit "shr") format src dst - -pprInstr (BT format imm src) = pprFormatImmOp (sLit "bt") format imm src - -pprInstr (CMP format src dst) - | isFloatFormat format = pprFormatOpOp (sLit "ucomi") format src dst -- SSE2 - | otherwise = pprFormatOpOp (sLit "cmp") format src dst - -pprInstr (TEST format src dst) = sdocWithPlatform $ \platform -> - let format' = case (src,dst) of - -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'. - -- We can replace them by equivalent, but smaller instructions - -- by reducing the size of the immediate operand as far as possible. - -- (We could handle masks larger than a single byte too, - -- but it would complicate the code considerably - -- and tag checks are by far the most common case.) - -- The mask must have the high bit clear for this smaller encoding - -- to be completely equivalent to the original; in particular so - -- that the signed comparison condition bits are the same as they - -- would be if doing a full word comparison. See Trac #13425. - (OpImm (ImmInteger mask), OpReg dstReg) - | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg - _ -> format - in pprFormatOpOp (sLit "test") format' src dst - where - minSizeOfReg platform (RegReal (RealRegSingle i)) - | target32Bit platform && i <= 3 = II8 -- al, bl, cl, dl - | target32Bit platform && i <= 7 = II16 -- si, di, bp, sp - | not (target32Bit platform) && i <= 15 = II8 -- al .. r15b - minSizeOfReg _ _ = format -- other - -pprInstr (PUSH format op) = pprFormatOp (sLit "push") format op -pprInstr (POP format op) = pprFormatOp (sLit "pop") format op - --- both unused (SDM): --- pprInstr PUSHA = text "\tpushal" --- pprInstr POPA = text "\tpopal" - -pprInstr NOP = text "\tnop" -pprInstr (CLTD II32) = text "\tcltd" -pprInstr (CLTD II64) = text "\tcqto" - -pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) - -pprInstr (JXX cond blockid) - = pprCondInstr (sLit "j") cond (ppr lab) - where lab = mkAsmTempLabel (getUnique blockid) - -pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) - -pprInstr (JMP (OpImm imm) _) = text "\tjmp " <> pprImm imm -pprInstr (JMP op _) = sdocWithPlatform $ \platform -> - text "\tjmp *" - <> pprOperand (archWordFormat (target32Bit platform)) op -pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op []) -pprInstr (CALL (Left imm) _) = text "\tcall " <> pprImm imm -pprInstr (CALL (Right reg) _) = sdocWithPlatform $ \platform -> - text "\tcall *" - <> pprReg (archWordFormat (target32Bit platform)) reg - -pprInstr (IDIV fmt op) = pprFormatOp (sLit "idiv") fmt op -pprInstr (DIV fmt op) = pprFormatOp (sLit "div") fmt op -pprInstr (IMUL2 fmt op) = pprFormatOp (sLit "imul") fmt op - --- x86_64 only -pprInstr (MUL format op1 op2) = pprFormatOpOp (sLit "mul") format op1 op2 -pprInstr (MUL2 format op) = pprFormatOp (sLit "mul") format op - -pprInstr (FDIV format op1 op2) = pprFormatOpOp (sLit "div") format op1 op2 - -pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to -pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to -pprInstr (CVTTSS2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to -pprInstr (CVTTSD2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to -pprInstr (CVTSI2SS fmt from to) = pprFormatOpReg (sLit "cvtsi2ss") fmt from to -pprInstr (CVTSI2SD fmt from to) = pprFormatOpReg (sLit "cvtsi2sd") fmt from to - - -- FETCHGOT for PIC on ELF platforms -pprInstr (FETCHGOT reg) - = vcat [ text "\tcall 1f", - hcat [ text "1:\tpopl\t", pprReg II32 reg ], - hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ", - pprReg II32 reg ] - ] - - -- FETCHPC for PIC on Darwin/x86 - -- get the instruction pointer into a register - -- (Terminology note: the IP is called Program Counter on PPC, - -- and it's a good thing to use the same name on both platforms) -pprInstr (FETCHPC reg) - = vcat [ text "\tcall 1f", - hcat [ text "1:\tpopl\t", pprReg II32 reg ] - ] - - --- ----------------------------------------------------------------------------- --- i386 floating-point - --- Simulating a flat register set on the x86 FP stack is tricky. --- you have to free %st(7) before pushing anything on the FP reg stack --- so as to preclude the possibility of a FP stack overflow exception. -pprInstr g@(GMOV src dst) - | src == dst - = empty - | otherwise - = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1]) - --- GLD fmt addr dst ==> FLDsz addr ; FSTP (dst+1) -pprInstr g@(GLD fmt addr dst) - = pprG g (hcat [gtab, text "fld", pprFormat_x87 fmt, gsp, - pprAddr addr, gsemi, gpop dst 1]) - --- GST fmt src addr ==> FLD dst ; FSTPsz addr -pprInstr g@(GST fmt src addr) - | src == fake0 && fmt /= FF80 -- fstt instruction doesn't exist - = pprG g (hcat [gtab, - text "fst", pprFormat_x87 fmt, gsp, pprAddr addr]) - | otherwise - = pprG g (hcat [gtab, gpush src 0, gsemi, - text "fstp", pprFormat_x87 fmt, gsp, pprAddr addr]) - -pprInstr g@(GLDZ dst) - = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1]) -pprInstr g@(GLD1 dst) - = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1]) - -pprInstr (GFTOI src dst) - = pprInstr (GDTOI src dst) - -pprInstr g@(GDTOI src dst) - = pprG g (vcat [ - hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"], - hcat [gtab, gpush src 0], - hcat [gtab, text "movzwl 4(%esp), ", reg, - text " ; orl $0xC00, ", reg], - hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"], - hcat [gtab, text "fistpl 0(%esp)"], - hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg], - hcat [gtab, text "addl $8, %esp"] - ]) - where - reg = pprReg II32 dst - -pprInstr (GITOF src dst) - = pprInstr (GITOD src dst) - -pprInstr g@(GITOD src dst) - = pprG g (hcat [gtab, text "pushl ", pprReg II32 src, - text " ; fildl (%esp) ; ", - gpop dst 1, text " ; addl $4,%esp"]) - -pprInstr g@(GDTOF src dst) - = pprG g (vcat [gtab <> gpush src 0, - gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;", - gtab <> gpop dst 1]) - -{- Gruesome swamp follows. If you're unfortunate enough to have ventured - this far into the jungle AND you give a Rat's Ass (tm) what's going - on, here's the deal. Generate code to do a floating point comparison - of src1 and src2, of kind cond, and set the Zero flag if true. - - The complications are to do with handling NaNs correctly. We want the - property that if either argument is NaN, then the result of the - comparison is False ... except if we're comparing for inequality, - in which case the answer is True. - - Here's how the general (non-inequality) case works. As an - example, consider generating the an equality test: - - pushl %eax -- we need to mess with this - - fcomp and pop pushed src1 - -- Result of comparison is in FPU Status Register bits - -- C3 C2 and C0 - fstsw %ax -- Move FPU Status Reg to %ax - sahf -- move C3 C2 C0 from %ax to integer flag reg - -- now the serious magic begins - setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0 - sete %al -- %al = if arg1 == arg2 then 1 else 0 - andb %ah,%al -- %al &= %ah - -- so %al == 1 iff (comparable && same); else it holds 0 - decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same); - else %al == 0xFF, ZeroFlag=0 - -- the zero flag is now set as we desire. - popl %eax - - The special case of inequality differs thusly: - - setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0 - setne %al -- %al = if arg1 /= arg2 then 1 else 0 - orb %ah,%al -- %al = if (incomparable || different) then 1 else 0 - decb %al -- if (incomparable || different) then (%al == 0, ZF=1) - else (%al == 0xFF, ZF=0) --} -pprInstr g@(GCMP cond src1 src2) - | case cond of { NE -> True; _ -> False } - = pprG g (vcat [ - hcat [gtab, text "pushl %eax ; ",gpush src1 0], - hcat [gtab, text "fcomp ", greg src2 1, - text "; fstsw %ax ; sahf ; setpe %ah"], - hcat [gtab, text "setne %al ; ", - text "orb %ah,%al ; decb %al ; popl %eax"] - ]) - | otherwise - = pprG g (vcat [ - hcat [gtab, text "pushl %eax ; ",gpush src1 0], - hcat [gtab, text "fcomp ", greg src2 1, - text "; fstsw %ax ; sahf ; setpo %ah"], - hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ", - text "andb %ah,%al ; decb %al ; popl %eax"] - ]) - where - {- On the 486, the flags set by FP compare are the unsigned ones! - (This looks like a HACK to me. WDP 96/03) - -} - fix_FP_cond :: Cond -> Cond - fix_FP_cond GE = GEU - fix_FP_cond GTT = GU - fix_FP_cond LTT = LU - fix_FP_cond LE = LEU - fix_FP_cond EQQ = EQQ - fix_FP_cond NE = NE - fix_FP_cond _ = panic "X86.Ppr.fix_FP_cond: no match" - -- there should be no others - - -pprInstr g@(GABS _ src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) - -pprInstr g@(GNEG _ src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1]) - -pprInstr g@(GSQRT fmt src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$ - hcat [gtab, gcoerceto fmt, gpop dst 1]) - -pprInstr g@(GSIN fmt l1 l2 src dst) - = pprG g (pprTrigOp "fsin" False l1 l2 src dst fmt) - -pprInstr g@(GCOS fmt l1 l2 src dst) - = pprG g (pprTrigOp "fcos" False l1 l2 src dst fmt) - -pprInstr g@(GTAN fmt l1 l2 src dst) - = pprG g (pprTrigOp "fptan" True l1 l2 src dst fmt) - --- In the translations for GADD, GMUL, GSUB and GDIV, --- the first two cases are mere optimisations. The otherwise clause --- generates correct code under all circumstances. - -pprInstr g@(GADD _ src1 src2 dst) - | src1 == dst - = pprG g (text "\t#GADD-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; faddp %st(0),", greg src1 1]) - | src2 == dst - = pprG g (text "\t#GADD-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; faddp %st(0),", greg src2 1]) - | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fadd ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) - - -pprInstr g@(GMUL _ src1 src2 dst) - | src1 == dst - = pprG g (text "\t#GMUL-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fmulp %st(0),", greg src1 1]) - | src2 == dst - = pprG g (text "\t#GMUL-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fmulp %st(0),", greg src2 1]) - | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fmul ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) - - -pprInstr g@(GSUB _ src1 src2 dst) - | src1 == dst - = pprG g (text "\t#GSUB-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fsubrp %st(0),", greg src1 1]) - | src2 == dst - = pprG g (text "\t#GSUB-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fsubp %st(0),", greg src2 1]) - | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fsub ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) - - -pprInstr g@(GDIV _ src1 src2 dst) - | src1 == dst - = pprG g (text "\t#GDIV-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fdivrp %st(0),", greg src1 1]) - | src2 == dst - = pprG g (text "\t#GDIV-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fdivp %st(0),", greg src2 1]) - | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fdiv ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) - - -pprInstr GFREE - = vcat [ text "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)", - text "\tffree %st(4) ;ffree %st(5)" - ] - --- Atomics - -pprInstr (LOCK i) = text "\tlock" $$ pprInstr i - -pprInstr MFENCE = text "\tmfence" - -pprInstr (XADD format src dst) = pprFormatOpOp (sLit "xadd") format src dst - -pprInstr (CMPXCHG format src dst) - = pprFormatOpOp (sLit "cmpxchg") format src dst - -pprInstr _ - = panic "X86.Ppr.pprInstr: no match" - - -pprTrigOp :: String -> Bool -> CLabel -> CLabel - -> Reg -> Reg -> Format -> SDoc -pprTrigOp op -- fsin, fcos or fptan - isTan -- we need a couple of extra steps if we're doing tan - l1 l2 -- internal labels for us to use - src dst fmt - = -- We'll be needing %eax later on - hcat [gtab, text "pushl %eax;"] $$ - -- tan is going to use an extra space on the FP stack - (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$ - -- First put the value in %st(0) and try to apply the op to it - hcat [gpush src 0, text ("; " ++ op)] $$ - -- Now look to see if C2 was set (overflow, |value| >= 2^63) - hcat [gtab, text "fnstsw %ax"] $$ - hcat [gtab, text "test $0x400,%eax"] $$ - -- If we were in bounds then jump to the end - hcat [gtab, text "je " <> ppr l1] $$ - -- Otherwise we need to shrink the value. Start by - -- loading pi, doubleing it (by adding it to itself), - -- and then swapping pi with the value, so the value we - -- want to apply op to is in %st(0) again - hcat [gtab, text "ffree %st(7); fldpi"] $$ - hcat [gtab, text "fadd %st(0),%st"] $$ - hcat [gtab, text "fxch %st(1)"] $$ - -- Now we have a loop in which we make the value smaller, - -- see if it's small enough, and loop if not - (ppr l2 <> char ':') $$ - hcat [gtab, text "fprem1"] $$ - -- My Debian libc uses fstsw here for the tan code, but I can't - -- see any reason why it should need to be different for tan. - hcat [gtab, text "fnstsw %ax"] $$ - hcat [gtab, text "test $0x400,%eax"] $$ - hcat [gtab, text "jne " <> ppr l2] $$ - hcat [gtab, text "fstp %st(1)"] $$ - hcat [gtab, text op] $$ - (ppr l1 <> char ':') $$ - -- Pop the 1.0 tan gave us - (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$ - -- Restore %eax - hcat [gtab, text "popl %eax;"] $$ - -- And finally make the result the right size - hcat [gtab, gcoerceto fmt, gpop dst 1] - --------------------------- - --- coerce %st(0) to the specified size -gcoerceto :: Format -> SDoc -gcoerceto FF64 = empty -gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; " -gcoerceto _ = panic "X86.Ppr.gcoerceto: no match" - -gpush :: Reg -> RegNo -> SDoc -gpush reg offset - = hcat [text "fld ", greg reg offset] - -gpop :: Reg -> RegNo -> SDoc -gpop reg offset - = hcat [text "fstp ", greg reg offset] - -greg :: Reg -> RegNo -> SDoc -greg reg offset = text "%st(" <> int (gregno reg - firstfake+offset) <> char ')' - -gsemi :: SDoc -gsemi = text " ; " - -gtab :: SDoc -gtab = char '\t' - -gsp :: SDoc -gsp = char ' ' - -gregno :: Reg -> RegNo -gregno (RegReal (RealRegSingle i)) = i -gregno _ = --pprPanic "gregno" (ppr other) - 999 -- bogus; only needed for debug printing - -pprG :: Instr -> SDoc -> SDoc -pprG fake actual - = (char '#' <> pprGInstr fake) $$ actual - - -pprGInstr :: Instr -> SDoc -pprGInstr (GMOV src dst) = pprFormatRegReg (sLit "gmov") FF64 src dst -pprGInstr (GLD fmt src dst) = pprFormatAddrReg (sLit "gld") fmt src dst -pprGInstr (GST fmt src dst) = pprFormatRegAddr (sLit "gst") fmt src dst - -pprGInstr (GLDZ dst) = pprFormatReg (sLit "gldz") FF64 dst -pprGInstr (GLD1 dst) = pprFormatReg (sLit "gld1") FF64 dst - -pprGInstr (GFTOI src dst) = pprFormatFormatRegReg (sLit "gftoi") FF32 II32 src dst -pprGInstr (GDTOI src dst) = pprFormatFormatRegReg (sLit "gdtoi") FF64 II32 src dst - -pprGInstr (GITOF src dst) = pprFormatFormatRegReg (sLit "gitof") II32 FF32 src dst -pprGInstr (GITOD src dst) = pprFormatFormatRegReg (sLit "gitod") II32 FF64 src dst -pprGInstr (GDTOF src dst) = pprFormatFormatRegReg (sLit "gdtof") FF64 FF32 src dst - -pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst -pprGInstr (GABS fmt src dst) = pprFormatRegReg (sLit "gabs") fmt src dst -pprGInstr (GNEG fmt src dst) = pprFormatRegReg (sLit "gneg") fmt src dst -pprGInstr (GSQRT fmt src dst) = pprFormatRegReg (sLit "gsqrt") fmt src dst -pprGInstr (GSIN fmt _ _ src dst) = pprFormatRegReg (sLit "gsin") fmt src dst -pprGInstr (GCOS fmt _ _ src dst) = pprFormatRegReg (sLit "gcos") fmt src dst -pprGInstr (GTAN fmt _ _ src dst) = pprFormatRegReg (sLit "gtan") fmt src dst - -pprGInstr (GADD fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gadd") fmt src1 src2 dst -pprGInstr (GSUB fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gsub") fmt src1 src2 dst -pprGInstr (GMUL fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gmul") fmt src1 src2 dst -pprGInstr (GDIV fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gdiv") fmt src1 src2 dst - -pprGInstr _ = panic "X86.Ppr.pprGInstr: no match" - -pprDollImm :: Imm -> SDoc -pprDollImm i = text "$" <> pprImm i - - -pprOperand :: Format -> Operand -> SDoc -pprOperand f (OpReg r) = pprReg f r -pprOperand _ (OpImm i) = pprDollImm i -pprOperand _ (OpAddr ea) = pprAddr ea - - -pprMnemonic_ :: LitString -> SDoc -pprMnemonic_ name = - char '\t' <> ptext name <> space - - -pprMnemonic :: LitString -> Format -> SDoc -pprMnemonic name format = - char '\t' <> ptext name <> pprFormat format <> space - - -pprFormatImmOp :: LitString -> Format -> Imm -> Operand -> SDoc -pprFormatImmOp name format imm op1 - = hcat [ - pprMnemonic name format, - char '$', - pprImm imm, - comma, - pprOperand format op1 - ] - - -pprFormatOp_ :: LitString -> Format -> Operand -> SDoc -pprFormatOp_ name format op1 - = hcat [ - pprMnemonic_ name , - pprOperand format op1 - ] - -pprFormatOp :: LitString -> Format -> Operand -> SDoc -pprFormatOp name format op1 - = hcat [ - pprMnemonic name format, - pprOperand format op1 - ] - - -pprFormatOpOp :: LitString -> Format -> Operand -> Operand -> SDoc -pprFormatOpOp name format op1 op2 - = hcat [ - pprMnemonic name format, - pprOperand format op1, - comma, - pprOperand format op2 - ] - - -pprOpOp :: LitString -> Format -> Operand -> Operand -> SDoc -pprOpOp name format op1 op2 - = hcat [ - pprMnemonic_ name, - pprOperand format op1, - comma, - pprOperand format op2 - ] - - -pprFormatReg :: LitString -> Format -> Reg -> SDoc -pprFormatReg name format reg1 - = hcat [ - pprMnemonic name format, - pprReg format reg1 - ] - - -pprFormatRegReg :: LitString -> Format -> Reg -> Reg -> SDoc -pprFormatRegReg name format reg1 reg2 - = hcat [ - pprMnemonic name format, - pprReg format reg1, - comma, - pprReg format reg2 - ] - - -pprRegReg :: LitString -> Reg -> Reg -> SDoc -pprRegReg name reg1 reg2 - = sdocWithPlatform $ \platform -> - hcat [ - pprMnemonic_ name, - pprReg (archWordFormat (target32Bit platform)) reg1, - comma, - pprReg (archWordFormat (target32Bit platform)) reg2 - ] - - -pprFormatOpReg :: LitString -> Format -> Operand -> Reg -> SDoc -pprFormatOpReg name format op1 reg2 - = sdocWithPlatform $ \platform -> - hcat [ - pprMnemonic name format, - pprOperand format op1, - comma, - pprReg (archWordFormat (target32Bit platform)) reg2 - ] - -pprCondOpReg :: LitString -> Format -> Cond -> Operand -> Reg -> SDoc -pprCondOpReg name format cond op1 reg2 - = hcat [ - char '\t', - ptext name, - pprCond cond, - space, - pprOperand format op1, - comma, - pprReg format reg2 - ] - -pprCondRegReg :: LitString -> Format -> Cond -> Reg -> Reg -> SDoc -pprCondRegReg name format cond reg1 reg2 - = hcat [ - char '\t', - ptext name, - pprCond cond, - space, - pprReg format reg1, - comma, - pprReg format reg2 - ] - -pprFormatFormatRegReg :: LitString -> Format -> Format -> Reg -> Reg -> SDoc -pprFormatFormatRegReg name format1 format2 reg1 reg2 - = hcat [ - char '\t', - ptext name, - pprFormat format1, - pprFormat format2, - space, - pprReg format1 reg1, - comma, - pprReg format2 reg2 - ] - -pprFormatFormatOpReg :: LitString -> Format -> Format -> Operand -> Reg -> SDoc -pprFormatFormatOpReg name format1 format2 op1 reg2 - = hcat [ - pprMnemonic name format2, - pprOperand format1 op1, - comma, - pprReg format2 reg2 - ] - -pprFormatRegRegReg :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc -pprFormatRegRegReg name format reg1 reg2 reg3 - = hcat [ - pprMnemonic name format, - pprReg format reg1, - comma, - pprReg format reg2, - comma, - pprReg format reg3 - ] - - -pprFormatAddrReg :: LitString -> Format -> AddrMode -> Reg -> SDoc -pprFormatAddrReg name format op dst - = hcat [ - pprMnemonic name format, - pprAddr op, - comma, - pprReg format dst - ] - - -pprFormatRegAddr :: LitString -> Format -> Reg -> AddrMode -> SDoc -pprFormatRegAddr name format src op - = hcat [ - pprMnemonic name format, - pprReg format src, - comma, - pprAddr op - ] - - -pprShift :: LitString -> Format -> Operand -> Operand -> SDoc -pprShift name format src dest - = hcat [ - pprMnemonic name format, - pprOperand II8 src, -- src is 8-bit sized - comma, - pprOperand format dest - ] - - -pprFormatOpOpCoerce :: LitString -> Format -> Format -> Operand -> Operand -> SDoc -pprFormatOpOpCoerce name format1 format2 op1 op2 - = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space, - pprOperand format1 op1, - comma, - pprOperand format2 op2 - ] - - -pprCondInstr :: LitString -> Cond -> SDoc -> SDoc -pprCondInstr name cond arg - = hcat [ char '\t', ptext name, pprCond cond, space, arg] - diff --git a/nativeGen/X86/RegInfo.hs b/nativeGen/X86/RegInfo.hs deleted file mode 100644 --- a/nativeGen/X86/RegInfo.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE CPP #-} -module X86.RegInfo ( - mkVirtualReg, - regDotColor -) - -where - -#include "nativeGen/NCG.h" -#include "HsVersions.h" - -import Format -import Reg - -import Outputable -import Platform -import Unique - -import UniqFM -import X86.Regs - - -mkVirtualReg :: Unique -> Format -> VirtualReg -mkVirtualReg u format - = case format of - FF32 -> VirtualRegSSE u - FF64 -> VirtualRegSSE u - FF80 -> VirtualRegD u - _other -> VirtualRegI u - -regDotColor :: Platform -> RealReg -> SDoc -regDotColor platform reg - = let Just str = lookupUFM (regColors platform) reg - in text str - -regColors :: Platform -> UniqFM [Char] -regColors platform = listToUFM (normalRegColors platform ++ fpRegColors) - -normalRegColors :: Platform -> [(Reg,String)] -normalRegColors platform - | target32Bit platform = [ (eax, "#00ff00") - , (ebx, "#0000ff") - , (ecx, "#00ffff") - , (edx, "#0080ff") ] - | otherwise = [ (rax, "#00ff00"), (eax, "#00ff00") - , (rbx, "#0000ff"), (ebx, "#0000ff") - , (rcx, "#00ffff"), (ecx, "#00ffff") - , (rdx, "#0080ff"), (edx, "#00ffff") - , (r8, "#00ff80") - , (r9, "#008080") - , (r10, "#0040ff") - , (r11, "#00ff40") - , (r12, "#008040") - , (r13, "#004080") - , (r14, "#004040") - , (r15, "#002080") ] - -fpRegColors :: [(Reg,String)] -fpRegColors = - [ (fake0, "#ff00ff") - , (fake1, "#ff00aa") - , (fake2, "#aa00ff") - , (fake3, "#aa00aa") - , (fake4, "#ff0055") - , (fake5, "#5500ff") ] - - ++ zip (map regSingle [24..39]) (repeat "red") diff --git a/nativeGen/X86/Regs.hs b/nativeGen/X86/Regs.hs deleted file mode 100644 --- a/nativeGen/X86/Regs.hs +++ /dev/null @@ -1,449 +0,0 @@ -{-# LANGUAGE CPP #-} - -module X86.Regs ( - -- squeese functions for the graph allocator - virtualRegSqueeze, - realRegSqueeze, - - -- immediates - Imm(..), - strImmLit, - litToImm, - - -- addressing modes - AddrMode(..), - addrOffset, - - -- registers - spRel, - argRegs, - allArgRegs, - allIntArgRegs, - callClobberedRegs, - instrClobberedRegs, - allMachRegNos, - classOfRealReg, - showReg, - - -- machine specific - EABase(..), EAIndex(..), addrModeRegs, - - eax, ebx, ecx, edx, esi, edi, ebp, esp, - fake0, fake1, fake2, fake3, fake4, fake5, firstfake, - - rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp, - r8, r9, r10, r11, r12, r13, r14, r15, - xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7, - xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15, - xmm, - - ripRel, - allFPArgRegs, - - allocatableRegs -) - -where - -#include "nativeGen/NCG.h" -#include "HsVersions.h" - -import CodeGen.Platform -import Reg -import RegClass - -import Cmm -import CLabel ( CLabel ) -import DynFlags -import Outputable -import Platform - --- | regSqueeze_class reg --- Calculuate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. --- -{-# INLINE virtualRegSqueeze #-} -virtualRegSqueeze :: RegClass -> VirtualReg -> Int - -virtualRegSqueeze cls vr - = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> 1 - VirtualRegHi{} -> 1 - _other -> 0 - - RcDouble - -> case vr of - VirtualRegD{} -> 1 - VirtualRegF{} -> 0 - _other -> 0 - - RcDoubleSSE - -> case vr of - VirtualRegSSE{} -> 1 - _other -> 0 - - _other -> 0 - -{-# INLINE realRegSqueeze #-} -realRegSqueeze :: RegClass -> RealReg -> Int -realRegSqueeze cls rr - = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < firstfake -> 1 - | otherwise -> 0 - - RealRegPair{} -> 0 - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo >= firstfake && regNo <= lastfake -> 1 - | otherwise -> 0 - - RealRegPair{} -> 0 - - RcDoubleSSE - -> case rr of - RealRegSingle regNo | regNo >= firstxmm -> 1 - _otherwise -> 0 - - _other -> 0 - --- ----------------------------------------------------------------------------- --- Immediates - -data Imm - = ImmInt Int - | ImmInteger Integer -- Sigh. - | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit SDoc -- Simple string - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm - - -strImmLit :: String -> Imm -strImmLit s = ImmLit (text s) - - -litToImm :: CmmLit -> Imm -litToImm (CmmInt i w) = ImmInteger (narrowS w i) - -- narrow to the width: a CmmInt might be out of - -- range, but we assume that ImmInteger only contains - -- in-range values. A signed value should be fine here. -litToImm (CmmFloat f W32) = ImmFloat f -litToImm (CmmFloat f W64) = ImmDouble f -litToImm (CmmLabel l) = ImmCLbl l -litToImm (CmmLabelOff l off) = ImmIndex l off -litToImm (CmmLabelDiffOff l1 l2 off) - = ImmConstantSum - (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) - (ImmInt off) -litToImm _ = panic "X86.Regs.litToImm: no match" - --- addressing modes ------------------------------------------------------------ - -data AddrMode - = AddrBaseIndex EABase EAIndex Displacement - | ImmAddr Imm Int - -data EABase = EABaseNone | EABaseReg Reg | EABaseRip -data EAIndex = EAIndexNone | EAIndex Reg Int -type Displacement = Imm - - -addrOffset :: AddrMode -> Int -> Maybe AddrMode -addrOffset addr off - = case addr of - ImmAddr i off0 -> Just (ImmAddr i (off0 + off)) - - AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off))) - AddrBaseIndex r i (ImmInteger n) - -> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off)))) - - AddrBaseIndex r i (ImmCLbl lbl) - -> Just (AddrBaseIndex r i (ImmIndex lbl off)) - - AddrBaseIndex r i (ImmIndex lbl ix) - -> Just (AddrBaseIndex r i (ImmIndex lbl (ix+off))) - - _ -> Nothing -- in theory, shouldn't happen - - -addrModeRegs :: AddrMode -> [Reg] -addrModeRegs (AddrBaseIndex b i _) = b_regs ++ i_regs - where - b_regs = case b of { EABaseReg r -> [r]; _ -> [] } - i_regs = case i of { EAIndex r _ -> [r]; _ -> [] } -addrModeRegs _ = [] - - --- registers ------------------------------------------------------------------- - --- @spRel@ gives us a stack relative addressing mode for volatile --- temporaries and for excess call arguments. @fpRel@, where --- applicable, is the same but for the frame pointer. - - -spRel :: DynFlags - -> Int -- ^ desired stack offset in bytes, positive or negative - -> AddrMode -spRel dflags n - | target32Bit (targetPlatform dflags) - = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n) - | otherwise - = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n) - --- The register numbers must fit into 32 bits on x86, so that we can --- use a Word32 to represent the set of free registers in the register --- allocator. - -firstfake, lastfake :: RegNo -firstfake = 16 -lastfake = 21 - -firstxmm :: RegNo -firstxmm = 24 - -lastxmm :: Platform -> RegNo -lastxmm platform - | target32Bit platform = 31 - | otherwise = 39 - -lastint :: Platform -> RegNo -lastint platform - | target32Bit platform = 7 -- not %r8..%r15 - | otherwise = 15 - -intregnos :: Platform -> [RegNo] -intregnos platform = [0 .. lastint platform] - -fakeregnos :: [RegNo] -fakeregnos = [firstfake .. lastfake] - -xmmregnos :: Platform -> [RegNo] -xmmregnos platform = [firstxmm .. lastxmm platform] - -floatregnos :: Platform -> [RegNo] -floatregnos platform = fakeregnos ++ xmmregnos platform - - --- argRegs is the set of regs which are read for an n-argument call to C. --- For archs which pass all args on the stack (x86), is empty. --- Sparc passes up to the first 6 args in regs. -argRegs :: RegNo -> [Reg] -argRegs _ = panic "MachRegs.argRegs(x86): should not be used!" - --- | The complete set of machine registers. -allMachRegNos :: Platform -> [RegNo] -allMachRegNos platform = intregnos platform ++ floatregnos platform - --- | Take the class of a register. -{-# INLINE classOfRealReg #-} -classOfRealReg :: Platform -> RealReg -> RegClass --- On x86, we might want to have an 8-bit RegClass, which would --- contain just regs 1-4 (the others don't have 8-bit versions). --- However, we can get away without this at the moment because the --- only allocatable integer regs are also 8-bit compatible (1, 3, 4). -classOfRealReg platform reg - = case reg of - RealRegSingle i - | i <= lastint platform -> RcInteger - | i <= lastfake -> RcDouble - | otherwise -> RcDoubleSSE - - RealRegPair{} -> panic "X86.Regs.classOfRealReg: RegPairs on this arch" - --- | Get the name of the register with this number. -showReg :: Platform -> RegNo -> String -showReg platform n - | n >= firstxmm = "%xmm" ++ show (n-firstxmm) - | n >= firstfake = "%fake" ++ show (n-firstfake) - | n >= 8 = "%r" ++ show n - | otherwise = regNames platform !! n - -regNames :: Platform -> [String] -regNames platform - = if target32Bit platform - then ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"] - else ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"] - - - --- machine specific ------------------------------------------------------------ - - -{- -Intel x86 architecture: -- All registers except 7 (esp) are available for use. -- Only ebx, esi, edi and esp are available across a C call (they are callee-saves). -- Registers 0-7 have 16-bit counterparts (ax, bx etc.) -- Registers 0-3 have 8 bit counterparts (ah, bh etc.) -- Registers fake0..fake5 are fakes; we pretend x86 has 6 conventionally-addressable - fp registers, and 3-operand insns for them, and we translate this into - real stack-based x86 fp code after register allocation. - -The fp registers are all Double registers; we don't have any RcFloat class -regs. @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should -never generate them. --} - -fake0, fake1, fake2, fake3, fake4, fake5, - eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg - -eax = regSingle 0 -ebx = regSingle 1 -ecx = regSingle 2 -edx = regSingle 3 -esi = regSingle 4 -edi = regSingle 5 -ebp = regSingle 6 -esp = regSingle 7 -fake0 = regSingle 16 -fake1 = regSingle 17 -fake2 = regSingle 18 -fake3 = regSingle 19 -fake4 = regSingle 20 -fake5 = regSingle 21 - - - -{- -AMD x86_64 architecture: -- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values: - - 8 16 32 64 - --------------------- - al ax eax rax - bl bx ebx rbx - cl cx ecx rcx - dl dx edx rdx - sil si esi rsi - dil si edi rdi - bpl bp ebp rbp - spl sp esp rsp - r10b r10w r10d r10 - r11b r11w r11d r11 - r12b r12w r12d r12 - r13b r13w r13d r13 - r14b r14w r14d r14 - r15b r15w r15d r15 --} - -rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi, - r8, r9, r10, r11, r12, r13, r14, r15, - xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7, - xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15 :: Reg - -rax = regSingle 0 -rbx = regSingle 1 -rcx = regSingle 2 -rdx = regSingle 3 -rsi = regSingle 4 -rdi = regSingle 5 -rbp = regSingle 6 -rsp = regSingle 7 -r8 = regSingle 8 -r9 = regSingle 9 -r10 = regSingle 10 -r11 = regSingle 11 -r12 = regSingle 12 -r13 = regSingle 13 -r14 = regSingle 14 -r15 = regSingle 15 -xmm0 = regSingle 24 -xmm1 = regSingle 25 -xmm2 = regSingle 26 -xmm3 = regSingle 27 -xmm4 = regSingle 28 -xmm5 = regSingle 29 -xmm6 = regSingle 30 -xmm7 = regSingle 31 -xmm8 = regSingle 32 -xmm9 = regSingle 33 -xmm10 = regSingle 34 -xmm11 = regSingle 35 -xmm12 = regSingle 36 -xmm13 = regSingle 37 -xmm14 = regSingle 38 -xmm15 = regSingle 39 - -ripRel :: Displacement -> AddrMode -ripRel imm = AddrBaseIndex EABaseRip EAIndexNone imm - - - -- so we can re-use some x86 code: -{- -eax = rax -ebx = rbx -ecx = rcx -edx = rdx -esi = rsi -edi = rdi -ebp = rbp -esp = rsp --} - -xmm :: RegNo -> Reg -xmm n = regSingle (firstxmm+n) - - - - --- | these are the regs which we cannot assume stay alive over a C call. -callClobberedRegs :: Platform -> [Reg] --- caller-saves registers -callClobberedRegs platform - | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform) - | platformOS platform == OSMinGW32 - = [rax,rcx,rdx,r8,r9,r10,r11] - ++ map regSingle (floatregnos platform) - | otherwise - -- all xmm regs are caller-saves - -- caller-saves registers - = [rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11] - ++ map regSingle (floatregnos platform) - -allArgRegs :: Platform -> [(Reg, Reg)] -allArgRegs platform - | platformOS platform == OSMinGW32 = zip [rcx,rdx,r8,r9] - (map regSingle [firstxmm ..]) - | otherwise = panic "X86.Regs.allArgRegs: not defined for this arch" - -allIntArgRegs :: Platform -> [Reg] -allIntArgRegs platform - | (platformOS platform == OSMinGW32) || target32Bit platform - = panic "X86.Regs.allIntArgRegs: not defined for this platform" - | otherwise = [rdi,rsi,rdx,rcx,r8,r9] - -allFPArgRegs :: Platform -> [Reg] -allFPArgRegs platform - | platformOS platform == OSMinGW32 - = panic "X86.Regs.allFPArgRegs: not defined for this platform" - | otherwise = map regSingle [firstxmm .. firstxmm+7] - --- Machine registers which might be clobbered by instructions that --- generate results into fixed registers, or need arguments in a fixed --- register. -instrClobberedRegs :: Platform -> [Reg] -instrClobberedRegs platform - | target32Bit platform = [ eax, ecx, edx ] - | otherwise = [ rax, rcx, rdx ] - --- - --- allocatableRegs is allMachRegNos with the fixed-use regs removed. --- i.e., these are the regs for which we are prepared to allow the --- register allocator to attempt to map VRegs to. -allocatableRegs :: Platform -> [RealReg] -allocatableRegs platform - = let isFree i = freeReg platform i - in map RealRegSingle $ filter isFree (allMachRegNos platform) - diff --git a/parser/ApiAnnotation.hs b/parser/ApiAnnotation.hs deleted file mode 100644 --- a/parser/ApiAnnotation.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module ApiAnnotation ( - getAnnotation, getAndRemoveAnnotation, - getAnnotationComments,getAndRemoveAnnotationComments, - ApiAnns, - ApiAnnKey, - AnnKeywordId(..), - AnnotationComment(..), - IsUnicodeSyntax(..), - unicodeAnn, - HasE(..), - LRdrName -- Exists for haddocks only - ) where - -import RdrName -import Outputable -import SrcLoc -import qualified Data.Map as Map -import Data.Data - - -{- -Note [Api annotations] -~~~~~~~~~~~~~~~~~~~~~~ -Given a parse tree of a Haskell module, how can we reconstruct -the original Haskell source code, retaining all whitespace and -source code comments? We need to track the locations of all -elements from the original source: this includes keywords such as -'let' / 'in' / 'do' etc as well as punctuation such as commas and -braces, and also comments. We collectively refer to this -metadata as the "API annotations". - -Rather than annotate the resulting parse tree with these locations -directly (this would be a major change to some fairly core data -structures in GHC), we instead capture locations for these elements in a -structure separate from the parse tree, and returned in the -pm_annotations field of the ParsedModule type. - -The full ApiAnns type is - -> type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan] -- non-comments -> , Map.Map SrcSpan [Located AnnotationComment]) -- comments - -NON-COMMENT ELEMENTS - -Intuitively, every AST element directly contains a bag of keywords -(keywords can show up more than once in a node: a semicolon i.e. newline -can show up multiple times before the next AST element), each of which -needs to be associated with its location in the original source code. - -Consequently, the structure that records non-comment elements is logically -a two level map, from the SrcSpan of the AST element containing it, to -a map from keywords ('AnnKeyWord') to all locations of the keyword directly -in the AST element: - -> type ApiAnnKey = (SrcSpan,AnnKeywordId) -> -> Map.Map ApiAnnKey [SrcSpan] - -So - -> let x = 1 in 2 *x - -would result in the AST element - - L span (HsLet (binds for x = 1) (2 * x)) - -and the annotations - - (span,AnnLet) having the location of the 'let' keyword - (span,AnnEqual) having the location of the '=' sign - (span,AnnIn) having the location of the 'in' keyword - -For any given element in the AST, there is only a set number of -keywords that are applicable for it (e.g., you'll never see an -'import' keyword associated with a let-binding.) The set of allowed -keywords is documented in a comment associated with the constructor -of a given AST element, although the ground truth is in Parser -and RdrHsSyn (which actually add the annotations; see #13012). - -COMMENT ELEMENTS - -Every comment is associated with a *located* AnnotationComment. -We associate comments with the lowest (most specific) AST element -enclosing them: - -> Map.Map SrcSpan [Located AnnotationComment] - -PARSER STATE - -There are three fields in PState (the parser state) which play a role -with annotations. - -> annotations :: [(ApiAnnKey,[SrcSpan])], -> comment_q :: [Located AnnotationComment], -> annotations_comments :: [(SrcSpan,[Located AnnotationComment])] - -The 'annotations' and 'annotations_comments' fields are simple: they simply -accumulate annotations that will end up in 'ApiAnns' at the end -(after they are passed to Map.fromList). - -The 'comment_q' field captures comments as they are seen in the token stream, -so that when they are ready to be allocated via the parser they are -available (at the time we lex a comment, we don't know what the enclosing -AST node of it is, so we can't associate it with a SrcSpan in -annotations_comments). - -PARSER EMISSION OF ANNOTATIONS - -The parser interacts with the lexer using the function - -> addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () - -which takes the AST element SrcSpan, the annotation keyword and the -target SrcSpan. - -This adds the annotation to the `annotations` field of `PState` and -transfers any comments in `comment_q` WHICH ARE ENCLOSED by -the SrcSpan of this element to the `annotations_comments` -field. (Comments which are outside of this annotation are deferred -until later. 'allocateComments' in 'Lexer' is responsible for -making sure we only attach comments that actually fit in the 'SrcSpan'.) - -The wiki page describing this feature is -https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations - --} --- --------------------------------------------------------------------- - --- If you update this, update the Note [Api annotations] above -type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan] - , Map.Map SrcSpan [Located AnnotationComment]) - --- If you update this, update the Note [Api annotations] above -type ApiAnnKey = (SrcSpan,AnnKeywordId) - - --- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' --- of the annotated AST element, and the known type of the annotation. -getAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan] -getAnnotation (anns,_) span ann - = case Map.lookup (span,ann) anns of - Nothing -> [] - Just ss -> ss - --- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' --- of the annotated AST element, and the known type of the annotation. --- The list is removed from the annotations. -getAndRemoveAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId - -> ([SrcSpan],ApiAnns) -getAndRemoveAnnotation (anns,cs) span ann - = case Map.lookup (span,ann) anns of - Nothing -> ([],(anns,cs)) - Just ss -> (ss,(Map.delete (span,ann) anns,cs)) - --- |Retrieve the comments allocated to the current 'SrcSpan' --- --- Note: A given 'SrcSpan' may appear in multiple AST elements, --- beware of duplicates -getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment] -getAnnotationComments (_,anns) span = - case Map.lookup span anns of - Just cs -> cs - Nothing -> [] - --- |Retrieve the comments allocated to the current 'SrcSpan', and --- remove them from the annotations -getAndRemoveAnnotationComments :: ApiAnns -> SrcSpan - -> ([Located AnnotationComment],ApiAnns) -getAndRemoveAnnotationComments (anns,canns) span = - case Map.lookup span canns of - Just cs -> (cs,(anns,Map.delete span canns)) - Nothing -> ([],(anns,canns)) - --- -------------------------------------------------------------------- - --- | API Annotations exist so that tools can perform source to source --- conversions of Haskell code. They are used to keep track of the --- various syntactic keywords that are not captured in the existing --- AST. --- --- The annotations, together with original source comments are made --- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@. --- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in --- @'DynFlags.DynFlags'@ before parsing. --- --- The wiki page describing this feature is --- https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations --- --- Note: in general the names of these are taken from the --- corresponding token, unless otherwise noted --- See note [Api annotations] above for details of the usage -data AnnKeywordId - = AnnAnyclass - | AnnAs - | AnnAt - | AnnBang -- ^ '!' - | AnnBackquote -- ^ '`' - | AnnBy - | AnnCase -- ^ case or lambda case - | AnnClass - | AnnClose -- ^ '\#)' or '\#-}' etc - | AnnCloseB -- ^ '|)' - | AnnCloseBU -- ^ '|)', unicode variant - | AnnCloseC -- ^ '}' - | AnnCloseQ -- ^ '|]' - | AnnCloseQU -- ^ '|]', unicode variant - | AnnCloseP -- ^ ')' - | AnnCloseS -- ^ ']' - | AnnColon - | AnnComma -- ^ as a list separator - | AnnCommaTuple -- ^ in a RdrName for a tuple - | AnnDarrow -- ^ '=>' - | AnnDarrowU -- ^ '=>', unicode variant - | AnnData - | AnnDcolon -- ^ '::' - | AnnDcolonU -- ^ '::', unicode variant - | AnnDefault - | AnnDeriving - | AnnDo - | AnnDot -- ^ '.' - | AnnDotdot -- ^ '..' - | AnnElse - | AnnEqual - | AnnExport - | AnnFamily - | AnnForall - | AnnForallU -- ^ Unicode variant - | AnnForeign - | AnnFunId -- ^ for function name in matches where there are - -- multiple equations for the function. - | AnnGroup - | AnnHeader -- ^ for CType - | AnnHiding - | AnnIf - | AnnImport - | AnnIn - | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr' - | AnnInstance - | AnnLam - | AnnLarrow -- ^ '<-' - | AnnLarrowU -- ^ '<-', unicode variant - | AnnLet - | AnnMdo - | AnnMinus -- ^ '-' - | AnnModule - | AnnNewtype - | AnnName -- ^ where a name loses its location in the AST, this carries it - | AnnOf - | AnnOpen -- ^ '(\#' or '{-\# LANGUAGE' etc - | AnnOpenB -- ^ '(|' - | AnnOpenBU -- ^ '(|', unicode variant - | AnnOpenC -- ^ '{' - | AnnOpenE -- ^ '[e|' or '[e||' - | AnnOpenEQ -- ^ '[|' - | AnnOpenEQU -- ^ '[|', unicode variant - | AnnOpenP -- ^ '(' - | AnnOpenPE -- ^ '$(' - | AnnOpenPTE -- ^ '$$(' - | AnnOpenS -- ^ '[' - | AnnPackageName - | AnnPattern - | AnnProc - | AnnQualified - | AnnRarrow -- ^ '->' - | AnnRarrowU -- ^ '->', unicode variant - | AnnRec - | AnnRole - | AnnSafe - | AnnSemi -- ^ ';' - | AnnSimpleQuote -- ^ ''' - | AnnSignature - | AnnStatic -- ^ 'static' - | AnnStock - | AnnThen - | AnnThIdSplice -- ^ '$' - | AnnThIdTySplice -- ^ '$$' - | AnnThTyQuote -- ^ double ''' - | AnnTilde -- ^ '~' - | AnnTildehsh -- ^ '~#' - | AnnType - | AnnUnit -- ^ '()' for types - | AnnUsing - | AnnVal -- ^ e.g. INTEGER - | AnnValStr -- ^ String value, will need quotes when output - | AnnVbar -- ^ '|' - | AnnWhere - | Annlarrowtail -- ^ '-<' - | AnnlarrowtailU -- ^ '-<', unicode variant - | Annrarrowtail -- ^ '->' - | AnnrarrowtailU -- ^ '->', unicode variant - | AnnLarrowtail -- ^ '-<<' - | AnnLarrowtailU -- ^ '-<<', unicode variant - | AnnRarrowtail -- ^ '>>-' - | AnnRarrowtailU -- ^ '>>-', unicode variant - | AnnEofPos - deriving (Eq, Ord, Data, Show) - -instance Outputable AnnKeywordId where - ppr x = text (show x) - --- --------------------------------------------------------------------- - -data AnnotationComment = - -- Documentation annotations - AnnDocCommentNext String -- ^ something beginning '-- |' - | AnnDocCommentPrev String -- ^ something beginning '-- ^' - | AnnDocCommentNamed String -- ^ something beginning '-- $' - | AnnDocSection Int String -- ^ a section heading - | AnnDocOptions String -- ^ doc options (prune, ignore-exports, etc) - | AnnLineComment String -- ^ comment starting by "--" - | AnnBlockComment String -- ^ comment in {- -} - deriving (Eq, Ord, Data, Show) --- Note: these are based on the Token versions, but the Token type is --- defined in Lexer.x and bringing it in here would create a loop - -instance Outputable AnnotationComment where - ppr x = text (show x) - --- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', --- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma', --- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnTildehsh', --- 'ApiAnnotation.AnnTilde' --- - May have 'ApiAnnotation.AnnComma' when in a list -type LRdrName = Located RdrName - - --- | Certain tokens can have alternate representations when unicode syntax is --- enabled. This flag is attached to those tokens in the lexer so that the --- original source representation can be reproduced in the corresponding --- 'ApiAnnotation' -data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax - deriving (Eq, Ord, Data, Show) - --- | Convert a normal annotation into its unicode equivalent one -unicodeAnn :: AnnKeywordId -> AnnKeywordId -unicodeAnn AnnForall = AnnForallU -unicodeAnn AnnDcolon = AnnDcolonU -unicodeAnn AnnLarrow = AnnLarrowU -unicodeAnn AnnRarrow = AnnRarrowU -unicodeAnn AnnDarrow = AnnDarrowU -unicodeAnn Annlarrowtail = AnnlarrowtailU -unicodeAnn Annrarrowtail = AnnrarrowtailU -unicodeAnn AnnLarrowtail = AnnLarrowtailU -unicodeAnn AnnRarrowtail = AnnRarrowtailU -unicodeAnn AnnOpenB = AnnOpenBU -unicodeAnn AnnCloseB = AnnCloseBU -unicodeAnn AnnOpenEQ = AnnOpenEQU -unicodeAnn AnnCloseQ = AnnCloseQU -unicodeAnn ann = ann - - --- | Some template haskell tokens have two variants, one with an `e` the other --- not: --- --- > [| or [e| --- > [|| or [e|| --- --- This type indicates whether the 'e' is present or not. -data HasE = HasE | NoE - deriving (Eq, Ord, Data, Show) diff --git a/parser/Ctype.hs b/parser/Ctype.hs deleted file mode 100644 --- a/parser/Ctype.hs +++ /dev/null @@ -1,216 +0,0 @@ --- Character classification -{-# LANGUAGE CPP #-} -module Ctype - ( is_ident -- Char# -> Bool - , is_symbol -- Char# -> Bool - , is_any -- Char# -> Bool - , is_space -- Char# -> Bool - , is_lower -- Char# -> Bool - , is_upper -- Char# -> Bool - , is_digit -- Char# -> Bool - , is_alphanum -- Char# -> Bool - - , is_decdigit, is_hexdigit, is_octdigit, is_bindigit - , hexDigit, octDecDigit - ) where - -#include "HsVersions.h" - -import Data.Int ( Int32 ) -import Data.Bits ( Bits((.&.)) ) -import Data.Char ( ord, chr ) -import Panic - --- Bit masks - -cIdent, cSymbol, cAny, cSpace, cLower, cUpper, cDigit :: Int -cIdent = 1 -cSymbol = 2 -cAny = 4 -cSpace = 8 -cLower = 16 -cUpper = 32 -cDigit = 64 - --- | The predicates below look costly, but aren't, GHC+GCC do a great job --- at the big case below. - -{-# INLINE is_ctype #-} -is_ctype :: Int -> Char -> Bool -is_ctype mask c = (fromIntegral (charType c) .&. fromIntegral mask) /= (0::Int32) - -is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit, - is_alphanum :: Char -> Bool -is_ident = is_ctype cIdent -is_symbol = is_ctype cSymbol -is_any = is_ctype cAny -is_space = is_ctype cSpace -is_lower = is_ctype cLower -is_upper = is_ctype cUpper -is_digit = is_ctype cDigit -is_alphanum = is_ctype (cLower+cUpper+cDigit) - --- Utils - -hexDigit :: Char -> Int -hexDigit c | is_decdigit c = ord c - ord '0' - | otherwise = ord (to_lower c) - ord 'a' + 10 - -octDecDigit :: Char -> Int -octDecDigit c = ord c - ord '0' - -is_decdigit :: Char -> Bool -is_decdigit c - = c >= '0' && c <= '9' - -is_hexdigit :: Char -> Bool -is_hexdigit c - = is_decdigit c - || (c >= 'a' && c <= 'f') - || (c >= 'A' && c <= 'F') - -is_octdigit :: Char -> Bool -is_octdigit c = c >= '0' && c <= '7' - -is_bindigit :: Char -> Bool -is_bindigit c = c == '0' || c == '1' - -to_lower :: Char -> Char -to_lower c - | c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a')) - | otherwise = c - --- | We really mean .|. instead of + below, but GHC currently doesn't do --- any constant folding with bitops. *sigh* - -charType :: Char -> Int -charType c = case c of - '\0' -> 0 -- \000 - '\1' -> 0 -- \001 - '\2' -> 0 -- \002 - '\3' -> 0 -- \003 - '\4' -> 0 -- \004 - '\5' -> 0 -- \005 - '\6' -> 0 -- \006 - '\7' -> 0 -- \007 - '\8' -> 0 -- \010 - '\9' -> cSpace -- \t (not allowed in strings, so !cAny) - '\10' -> cSpace -- \n (ditto) - '\11' -> cSpace -- \v (ditto) - '\12' -> cSpace -- \f (ditto) - '\13' -> cSpace -- ^M (ditto) - '\14' -> 0 -- \016 - '\15' -> 0 -- \017 - '\16' -> 0 -- \020 - '\17' -> 0 -- \021 - '\18' -> 0 -- \022 - '\19' -> 0 -- \023 - '\20' -> 0 -- \024 - '\21' -> 0 -- \025 - '\22' -> 0 -- \026 - '\23' -> 0 -- \027 - '\24' -> 0 -- \030 - '\25' -> 0 -- \031 - '\26' -> 0 -- \032 - '\27' -> 0 -- \033 - '\28' -> 0 -- \034 - '\29' -> 0 -- \035 - '\30' -> 0 -- \036 - '\31' -> 0 -- \037 - '\32' -> cAny + cSpace -- - '\33' -> cAny + cSymbol -- ! - '\34' -> cAny -- " - '\35' -> cAny + cSymbol -- # - '\36' -> cAny + cSymbol -- $ - '\37' -> cAny + cSymbol -- % - '\38' -> cAny + cSymbol -- & - '\39' -> cAny + cIdent -- ' - '\40' -> cAny -- ( - '\41' -> cAny -- ) - '\42' -> cAny + cSymbol -- * - '\43' -> cAny + cSymbol -- + - '\44' -> cAny -- , - '\45' -> cAny + cSymbol -- - - '\46' -> cAny + cSymbol -- . - '\47' -> cAny + cSymbol -- / - '\48' -> cAny + cIdent + cDigit -- 0 - '\49' -> cAny + cIdent + cDigit -- 1 - '\50' -> cAny + cIdent + cDigit -- 2 - '\51' -> cAny + cIdent + cDigit -- 3 - '\52' -> cAny + cIdent + cDigit -- 4 - '\53' -> cAny + cIdent + cDigit -- 5 - '\54' -> cAny + cIdent + cDigit -- 6 - '\55' -> cAny + cIdent + cDigit -- 7 - '\56' -> cAny + cIdent + cDigit -- 8 - '\57' -> cAny + cIdent + cDigit -- 9 - '\58' -> cAny + cSymbol -- : - '\59' -> cAny -- ; - '\60' -> cAny + cSymbol -- < - '\61' -> cAny + cSymbol -- = - '\62' -> cAny + cSymbol -- > - '\63' -> cAny + cSymbol -- ? - '\64' -> cAny + cSymbol -- @ - '\65' -> cAny + cIdent + cUpper -- A - '\66' -> cAny + cIdent + cUpper -- B - '\67' -> cAny + cIdent + cUpper -- C - '\68' -> cAny + cIdent + cUpper -- D - '\69' -> cAny + cIdent + cUpper -- E - '\70' -> cAny + cIdent + cUpper -- F - '\71' -> cAny + cIdent + cUpper -- G - '\72' -> cAny + cIdent + cUpper -- H - '\73' -> cAny + cIdent + cUpper -- I - '\74' -> cAny + cIdent + cUpper -- J - '\75' -> cAny + cIdent + cUpper -- K - '\76' -> cAny + cIdent + cUpper -- L - '\77' -> cAny + cIdent + cUpper -- M - '\78' -> cAny + cIdent + cUpper -- N - '\79' -> cAny + cIdent + cUpper -- O - '\80' -> cAny + cIdent + cUpper -- P - '\81' -> cAny + cIdent + cUpper -- Q - '\82' -> cAny + cIdent + cUpper -- R - '\83' -> cAny + cIdent + cUpper -- S - '\84' -> cAny + cIdent + cUpper -- T - '\85' -> cAny + cIdent + cUpper -- U - '\86' -> cAny + cIdent + cUpper -- V - '\87' -> cAny + cIdent + cUpper -- W - '\88' -> cAny + cIdent + cUpper -- X - '\89' -> cAny + cIdent + cUpper -- Y - '\90' -> cAny + cIdent + cUpper -- Z - '\91' -> cAny -- [ - '\92' -> cAny + cSymbol -- backslash - '\93' -> cAny -- ] - '\94' -> cAny + cSymbol -- ^ - '\95' -> cAny + cIdent + cLower -- _ - '\96' -> cAny -- ` - '\97' -> cAny + cIdent + cLower -- a - '\98' -> cAny + cIdent + cLower -- b - '\99' -> cAny + cIdent + cLower -- c - '\100' -> cAny + cIdent + cLower -- d - '\101' -> cAny + cIdent + cLower -- e - '\102' -> cAny + cIdent + cLower -- f - '\103' -> cAny + cIdent + cLower -- g - '\104' -> cAny + cIdent + cLower -- h - '\105' -> cAny + cIdent + cLower -- i - '\106' -> cAny + cIdent + cLower -- j - '\107' -> cAny + cIdent + cLower -- k - '\108' -> cAny + cIdent + cLower -- l - '\109' -> cAny + cIdent + cLower -- m - '\110' -> cAny + cIdent + cLower -- n - '\111' -> cAny + cIdent + cLower -- o - '\112' -> cAny + cIdent + cLower -- p - '\113' -> cAny + cIdent + cLower -- q - '\114' -> cAny + cIdent + cLower -- r - '\115' -> cAny + cIdent + cLower -- s - '\116' -> cAny + cIdent + cLower -- t - '\117' -> cAny + cIdent + cLower -- u - '\118' -> cAny + cIdent + cLower -- v - '\119' -> cAny + cIdent + cLower -- w - '\120' -> cAny + cIdent + cLower -- x - '\121' -> cAny + cIdent + cLower -- y - '\122' -> cAny + cIdent + cLower -- z - '\123' -> cAny -- { - '\124' -> cAny + cSymbol -- | - '\125' -> cAny -- } - '\126' -> cAny + cSymbol -- ~ - '\127' -> 0 -- \177 - _ -> panic ("charType: " ++ show c) diff --git a/parser/HaddockUtils.hs b/parser/HaddockUtils.hs deleted file mode 100644 --- a/parser/HaddockUtils.hs +++ /dev/null @@ -1,32 +0,0 @@ - -module HaddockUtils where - -import HsSyn -import SrcLoc - -import Control.Monad - --- ----------------------------------------------------------------------------- --- Adding documentation to record fields (used in parsing). - -addFieldDoc :: LConDeclField a -> Maybe LHsDocString -> LConDeclField a -addFieldDoc (L l fld) doc - = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }) - -addFieldDocs :: [LConDeclField a] -> Maybe LHsDocString -> [LConDeclField a] -addFieldDocs [] _ = [] -addFieldDocs (x:xs) doc = addFieldDoc x doc : xs - - -addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a -addConDoc decl Nothing = decl -addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } ) - -addConDocs :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] -addConDocs [] _ = [] -addConDocs [x] doc = [addConDoc x doc] -addConDocs (x:xs) doc = x : addConDocs xs doc - -addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] -addConDocFirst [] _ = [] -addConDocFirst (x:xs) doc = addConDoc x doc : xs diff --git a/parser/Lexer.x b/parser/Lexer.x deleted file mode 100644 --- a/parser/Lexer.x +++ /dev/null @@ -1,2968 +0,0 @@ ------------------------------------------------------------------------------ --- (c) The University of Glasgow, 2006 --- --- GHC's lexer for Haskell 2010 [1]. --- --- This is a combination of an Alex-generated lexer [2] from a regex --- definition, with some hand-coded bits. [3] --- --- Completely accurate information about token-spans within the source --- file is maintained. Every token has a start and end RealSrcLoc --- attached to it. --- --- References: --- [1] https://www.haskell.org/onlinereport/haskell2010/haskellch2.html --- [2] http://www.haskell.org/alex/ --- [3] https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/Parser --- ------------------------------------------------------------------------------ - --- ToDo / known bugs: --- - parsing integers is a bit slow --- - readRational is a bit slow --- --- Known bugs, that were also in the previous version: --- - M... should be 3 tokens, not 1. --- - pragma-end should be only valid in a pragma - --- qualified operator NOTES. --- --- - If M.(+) is a single lexeme, then.. --- - Probably (+) should be a single lexeme too, for consistency. --- Otherwise ( + ) would be a prefix operator, but M.( + ) would not be. --- - But we have to rule out reserved operators, otherwise (..) becomes --- a different lexeme. --- - Should we therefore also rule out reserved operators in the qualified --- form? This is quite difficult to achieve. We don't do it for --- qualified varids. - - --- ----------------------------------------------------------------------------- --- Alex "Haskell code fragment top" - -{ -{-# LANGUAGE BangPatterns #-} - --- See Note [Warnings in code generated by Alex] in compiler/parser/Lexer.x -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -{-# OPTIONS_GHC -funbox-strict-fields #-} - -module Lexer ( - Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..), - P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getSrcLoc, - getPState, extopt, withThisPackage, - failLocMsgP, failSpanMsgP, srcParseFail, - getMessages, - popContext, pushModuleContext, setLastToken, setSrcLoc, - activeContext, nextIsEOF, - getLexState, popLexState, pushLexState, - extension, bangPatEnabled, datatypeContextsEnabled, - traditionalRecordSyntaxEnabled, - explicitForallEnabled, - inRulePrag, - explicitNamespacesEnabled, - patternSynonymsEnabled, - sccProfilingOn, hpcEnabled, - addWarning, - lexTokenStream, - addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn, - commentToAnnotation, - moveAnnotations - ) where - --- base -import Control.Monad -#if __GLASGOW_HASKELL__ > 710 -import Control.Monad.Fail -#endif -import Data.Bits -import Data.Char -import Data.List -import Data.Maybe -import Data.Word - -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - --- ghc-boot -import qualified GHC.LanguageExtensions as LangExt - --- bytestring -import Data.ByteString (ByteString) - --- containers -import Data.Map (Map) -import qualified Data.Map as Map - --- compiler/utils -import Bag -import Outputable -import StringBuffer -import FastString -import UniqFM -import Util ( readRational ) - --- compiler/main -import ErrUtils -import DynFlags - --- compiler/basicTypes -import SrcLoc -import Module -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..), - SourceText(..) ) - --- compiler/parser -import Ctype - -import ApiAnnotation -} - --- ----------------------------------------------------------------------------- --- Alex "Character set macros" - --- NB: The logic behind these definitions is also reflected in basicTypes/Lexeme.hs --- Any changes here should likely be reflected there. -$unispace = \x05 -- Trick Alex into handling Unicode. See alexGetByte. -$nl = [\n\r\f] -$whitechar = [$nl\v\ $unispace] -$white_no_nl = $whitechar # \n -- TODO #8424 -$tab = \t - -$ascdigit = 0-9 -$unidigit = \x03 -- Trick Alex into handling Unicode. See alexGetByte. -$decdigit = $ascdigit -- for now, should really be $digit (ToDo) -$digit = [$ascdigit $unidigit] - -$special = [\(\)\,\;\[\]\`\{\}] -$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] -$unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetByte. -$symbol = [$ascsymbol $unisymbol] # [$special \_\"\'] - -$unilarge = \x01 -- Trick Alex into handling Unicode. See alexGetByte. -$asclarge = [A-Z] -$large = [$asclarge $unilarge] - -$unismall = \x02 -- Trick Alex into handling Unicode. See alexGetByte. -$ascsmall = [a-z] -$small = [$ascsmall $unismall \_] - -$unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetByte. -$graphic = [$small $large $symbol $digit $special $unigraphic \"\'] - -$binit = 0-1 -$octit = 0-7 -$hexit = [$decdigit A-F a-f] - -$uniidchar = \x07 -- Trick Alex into handling Unicode. See alexGetByte. -$idchar = [$small $large $digit $uniidchar \'] - -$pragmachar = [$small $large $digit] - -$docsym = [\| \^ \* \$] - - --- ----------------------------------------------------------------------------- --- Alex "Regular expression macros" - -@varid = $small $idchar* -- variable identifiers -@conid = $large $idchar* -- constructor identifiers - -@varsym = ($symbol # \:) $symbol* -- variable (operator) symbol -@consym = \: $symbol* -- constructor (operator) symbol - -@decimal = $decdigit+ -@binary = $binit+ -@octal = $octit+ -@hexadecimal = $hexit+ -@exponent = [eE] [\-\+]? @decimal - -@qual = (@conid \.)+ -@qvarid = @qual @varid -@qconid = @qual @conid -@qvarsym = @qual @varsym -@qconsym = @qual @consym - -@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent - --- normal signed numerical literals can only be explicitly negative, --- not explicitly positive (contrast @exponent) -@negative = \- -@signed = @negative ? - - --- ----------------------------------------------------------------------------- --- Alex "Identifier" - -haskell :- - - --- ----------------------------------------------------------------------------- --- Alex "Rules" - --- everywhere: skip whitespace -$white_no_nl+ ; -$tab { warnTab } - --- Everywhere: deal with nested comments. We explicitly rule out --- pragmas, "{-#", so that we don't accidentally treat them as comments. --- (this can happen even though pragmas will normally take precedence due to --- longest-match, because pragmas aren't valid in every state, but comments --- are). We also rule out nested Haddock comments, if the -haddock flag is --- set. - -"{-" / { isNormalComment } { nested_comment lexToken } - --- Single-line comments are a bit tricky. Haskell 98 says that two or --- more dashes followed by a symbol should be parsed as a varsym, so we --- have to exclude those. - --- Since Haddock comments aren't valid in every state, we need to rule them --- out here. - --- The following two rules match comments that begin with two dashes, but --- continue with a different character. The rules test that this character --- is not a symbol (in which case we'd have a varsym), and that it's not a --- space followed by a Haddock comment symbol (docsym) (in which case we'd --- have a Haddock comment). The rules then munch the rest of the line. - -"-- " ~$docsym .* { lineCommentToken } -"--" [^$symbol \ ] .* { lineCommentToken } - --- Next, match Haddock comments if no -haddock flag - -"-- " $docsym .* / { ifExtension (not . haddockEnabled) } { lineCommentToken } - --- Now, when we've matched comments that begin with 2 dashes and continue --- with a different character, we need to match comments that begin with three --- or more dashes (which clearly can't be Haddock comments). We only need to --- make sure that the first non-dash character isn't a symbol, and munch the --- rest of the line. - -"---"\-* ~$symbol .* { lineCommentToken } - --- Since the previous rules all match dashes followed by at least one --- character, we also need to match a whole line filled with just dashes. - -"--"\-* / { atEOL } { lineCommentToken } - --- We need this rule since none of the other single line comment rules --- actually match this case. - -"-- " / { atEOL } { lineCommentToken } - --- 'bol' state: beginning of a line. Slurp up all the whitespace (including --- blank lines) until we find a non-whitespace character, then do layout --- processing. --- --- One slight wibble here: what if the line begins with {-#? In --- theory, we have to lex the pragma to see if it's one we recognise, --- and if it is, then we backtrack and do_bol, otherwise we treat it --- as a nested comment. We don't bother with this: if the line begins --- with {-#, then we'll assume it's a pragma we know about and go for do_bol. - { - \n ; - ^\# line { begin line_prag1 } - ^\# / { followedByDigit } { begin line_prag1 } - ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently - ^\# \! .* \n ; -- #!, for scripts - () { do_bol } -} - --- after a layout keyword (let, where, do, of), we begin a new layout --- context if the curly brace is missing. --- Careful! This stuff is quite delicate. - { - \{ / { notFollowedBy '-' } { hopefully_open_brace } - -- we might encounter {-# here, but {- has been handled already - \n ; - ^\# (line)? { begin line_prag1 } -} - --- after an 'if', a vertical bar starts a layout context for MultiWayIf - { - \| / { notFollowedBySymbol } { new_layout_context True dontGenerateSemic ITvbar } - () { pop } -} - --- do is treated in a subtly different way, see new_layout_context - () { new_layout_context True generateSemic ITvocurly } - () { new_layout_context False generateSemic ITvocurly } - --- after a new layout context which was found to be to the left of the --- previous context, we have generated a '{' token, and we now need to --- generate a matching '}' token. - () { do_layout_left } - -<0,option_prags> \n { begin bol } - -"{-#" $whitechar* $pragmachar+ / { known_pragma linePrags } - { dispatch_pragmas linePrags } - --- single-line line pragmas, of the form --- # "" \n - @decimal { setLine line_prag1a } - \" [$graphic \ ]* \" { setFile line_prag1b } - .* { pop } - --- Haskell-style line pragmas, of the form --- {-# LINE "" #-} - @decimal { setLine line_prag2a } - \" [$graphic \ ]* \" { setFile line_prag2b } - "#-}"|"-}" { pop } - -- NOTE: accept -} at the end of a LINE pragma, for compatibility - -- with older versions of GHC which generated these. - --- Haskell-style column pragmas, of the form --- {-# COLUMN #-} - @decimal $whitechar* "#-}" { setColumn } - -<0,option_prags> { - "{-#" $whitechar* $pragmachar+ - $whitechar+ $pragmachar+ / { known_pragma twoWordPrags } - { dispatch_pragmas twoWordPrags } - - "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags } - { dispatch_pragmas oneWordPrags } - - -- We ignore all these pragmas, but don't generate a warning for them - "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags } - { dispatch_pragmas ignoredPrags } - - -- ToDo: should only be valid inside a pragma: - "#-}" { endPrag } -} - - { - "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } - { dispatch_pragmas fileHeaderPrags } -} - -<0> { - -- In the "0" mode we ignore these pragmas - "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } - { nested_comment lexToken } -} - -<0,option_prags> { - "{-#" { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma") - (nested_comment lexToken) } -} - --- '0' state: ordinary lexemes - --- Haddock comments - -<0,option_prags> { - "-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment } - "{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment } -} - --- "special" symbols - -<0> { - "[:" / { ifExtension parrEnabled } { token ITopabrack } - ":]" / { ifExtension parrEnabled } { token ITcpabrack } -} - -<0> { - "[|" / { ifExtension thQuotesEnabled } { token (ITopenExpQuote NoE - NormalSyntax) } - "[||" / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote NoE) } - "[e|" / { ifExtension thQuotesEnabled } { token (ITopenExpQuote HasE - NormalSyntax) } - "[e||" / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote HasE) } - "[p|" / { ifExtension thQuotesEnabled } { token ITopenPatQuote } - "[d|" / { ifExtension thQuotesEnabled } { layout_token ITopenDecQuote } - "[t|" / { ifExtension thQuotesEnabled } { token ITopenTypQuote } - "|]" / { ifExtension thQuotesEnabled } { token (ITcloseQuote - NormalSyntax) } - "||]" / { ifExtension thQuotesEnabled } { token ITcloseTExpQuote } - \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } - "$$" @varid / { ifExtension thEnabled } { skip_two_varid ITidTyEscape } - "$(" / { ifExtension thEnabled } { token ITparenEscape } - "$$(" / { ifExtension thEnabled } { token ITparenTyEscape } - - "[" @varid "|" / { ifExtension qqEnabled } - { lex_quasiquote_tok } - - -- qualified quasi-quote (#5555) - "[" @qvarid "|" / { ifExtension qqEnabled } - { lex_qquasiquote_tok } - - $unigraphic -- ⟦ - / { ifCurrentChar '⟦' `alexAndPred` - ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) } - { token (ITopenExpQuote NoE UnicodeSyntax) } - $unigraphic -- ⟧ - / { ifCurrentChar '⟧' `alexAndPred` - ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) } - { token (ITcloseQuote UnicodeSyntax) } -} - - -- See Note [Lexing type applications] -<0> { - [^ $idchar \) ] ^ - "@" - / { ifExtension typeApplicationEnabled `alexAndPred` notFollowedBySymbol } - { token ITtypeApp } -} - -<0> { - "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol } - { special (IToparenbar NormalSyntax) } - "|)" / { ifExtension arrowsEnabled } { special (ITcparenbar NormalSyntax) } - - $unigraphic -- ⦇ - / { ifCurrentChar '⦇' `alexAndPred` - ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) } - { special (IToparenbar UnicodeSyntax) } - $unigraphic -- ⦈ - / { ifCurrentChar '⦈' `alexAndPred` - ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) } - { special (ITcparenbar UnicodeSyntax) } -} - -<0> { - \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } -} - -<0> { - "#" @varid / { ifExtension overloadedLabelsEnabled } - { skip_one_varid ITlabelvarid } -} - -<0> { - "(#" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled } - { token IToubxparen } - "#)" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled } - { token ITcubxparen } -} - -<0,option_prags> { - \( { special IToparen } - \) { special ITcparen } - \[ { special ITobrack } - \] { special ITcbrack } - \, { special ITcomma } - \; { special ITsemi } - \` { special ITbackquote } - - \{ { open_brace } - \} { close_brace } -} - -<0,option_prags> { - @qvarid { idtoken qvarid } - @qconid { idtoken qconid } - @varid { varid } - @conid { idtoken conid } -} - -<0> { - @qvarid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid } - @qconid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid } - @varid "#"+ / { ifExtension magicHashEnabled } { varid } - @conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid } -} - --- ToDo: - move `var` and (sym) into lexical syntax? --- - remove backquote from $special? -<0> { - @qvarsym { idtoken qvarsym } - @qconsym { idtoken qconsym } - @varsym { varsym } - @consym { consym } -} - --- For the normal boxed literals we need to be careful --- when trying to be close to Haskell98 -<0> { - -- Normal integral literals (:: Num a => a, from Integer) - @decimal { tok_num positive 0 0 decimal } - 0[bB] @binary / { ifExtension binaryLiteralsEnabled } { tok_num positive 2 2 binary } - 0[oO] @octal { tok_num positive 2 2 octal } - 0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal } - @negative @decimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 1 1 decimal } - @negative 0[bB] @binary / { ifExtension negativeLiteralsEnabled `alexAndPred` - ifExtension binaryLiteralsEnabled } { tok_num negative 3 3 binary } - @negative 0[oO] @octal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal } - @negative 0[xX] @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal } - - -- Normal rational literals (:: Fractional a => a, from Rational) - @floating_point { strtoken tok_float } - @negative @floating_point / { ifExtension negativeLiteralsEnabled } { strtoken tok_float } -} - -<0> { - -- Unboxed ints (:: Int#) and words (:: Word#) - -- It's simpler (and faster?) to give separate cases to the negatives, - -- especially considering octal/hexadecimal prefixes. - @decimal \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal } - 0[bB] @binary \# / { ifExtension magicHashEnabled `alexAndPred` - ifExtension binaryLiteralsEnabled } { tok_primint positive 2 3 binary } - 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal } - 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal } - @negative @decimal \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal } - @negative 0[bB] @binary \# / { ifExtension magicHashEnabled `alexAndPred` - ifExtension binaryLiteralsEnabled } { tok_primint negative 3 4 binary } - @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal } - @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal } - - @decimal \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal } - 0[bB] @binary \# \# / { ifExtension magicHashEnabled `alexAndPred` - ifExtension binaryLiteralsEnabled } { tok_primword 2 4 binary } - 0[oO] @octal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal } - 0[xX] @hexadecimal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal } - - -- Unboxed floats and doubles (:: Float#, :: Double#) - -- prim_{float,double} work with signed literals - @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat } - @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble } -} - --- Strings and chars are lexed by hand-written code. The reason is --- that even if we recognise the string or char here in the regex --- lexer, we would still have to parse the string afterward in order --- to convert it to a String. -<0> { - \' { lex_char_tok } - \" { lex_string_tok } -} - --- Note [Lexing type applications] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The desired syntax for type applications is to prefix the type application --- with '@', like this: --- --- foo @Int @Bool baz bum --- --- This, of course, conflicts with as-patterns. The conflict arises because --- expressions and patterns use the same parser, and also because we want --- to allow type patterns within expression patterns. --- --- Disambiguation is accomplished by requiring *something* to appear between --- type application and the preceding token. This something must end with --- a character that cannot be the end of the variable bound in an as-pattern. --- Currently (June 2015), this means that the something cannot end with a --- $idchar or a close-paren. (The close-paren is necessary if the as-bound --- identifier is symbolic.) --- --- Note that looking for whitespace before the '@' is insufficient, because --- of this pathological case: --- --- foo {- hi -}@Int --- --- This design is predicated on the fact that as-patterns are generally --- whitespace-free, and also that this whole thing is opt-in, with the --- TypeApplications extension. - --- ----------------------------------------------------------------------------- --- Alex "Haskell code fragment bottom" - -{ - --- ----------------------------------------------------------------------------- --- The token type - -data Token - = ITas -- Haskell keywords - | ITcase - | ITclass - | ITdata - | ITdefault - | ITderiving - | ITdo - | ITelse - | IThiding - | ITforeign - | ITif - | ITimport - | ITin - | ITinfix - | ITinfixl - | ITinfixr - | ITinstance - | ITlet - | ITmodule - | ITnewtype - | ITof - | ITqualified - | ITthen - | ITtype - | ITwhere - - | ITforall IsUnicodeSyntax -- GHC extension keywords - | ITexport - | ITlabel - | ITdynamic - | ITsafe - | ITinterruptible - | ITunsafe - | ITstdcallconv - | ITccallconv - | ITcapiconv - | ITprimcallconv - | ITjavascriptcallconv - | ITmdo - | ITfamily - | ITrole - | ITgroup - | ITby - | ITusing - | ITpattern - | ITstatic - | ITstock - | ITanyclass - - -- Backpack tokens - | ITunit - | ITsignature - | ITdependency - | ITrequires - - -- Pragmas, see note [Pragma source text] in BasicTypes - | ITinline_prag SourceText InlineSpec RuleMatchInfo - | ITspec_prag SourceText -- SPECIALISE - | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) - | ITsource_prag SourceText - | ITrules_prag SourceText - | ITwarning_prag SourceText - | ITdeprecated_prag SourceText - | ITline_prag - | ITscc_prag SourceText - | ITgenerated_prag SourceText - | ITcore_prag SourceText -- hdaume: core annotations - | ITunpack_prag SourceText - | ITnounpack_prag SourceText - | ITann_prag SourceText - | ITcomplete_prag SourceText - | ITclose_prag - | IToptions_prag String - | ITinclude_prag String - | ITlanguage_prag - | ITvect_prag SourceText - | ITvect_scalar_prag SourceText - | ITnovect_prag SourceText - | ITminimal_prag SourceText - | IToverlappable_prag SourceText -- instance overlap mode - | IToverlapping_prag SourceText -- instance overlap mode - | IToverlaps_prag SourceText -- instance overlap mode - | ITincoherent_prag SourceText -- instance overlap mode - | ITctype SourceText - - | ITdotdot -- reserved symbols - | ITcolon - | ITdcolon IsUnicodeSyntax - | ITequal - | ITlam - | ITlcase - | ITvbar - | ITlarrow IsUnicodeSyntax - | ITrarrow IsUnicodeSyntax - | ITat - | ITtilde - | ITtildehsh - | ITdarrow IsUnicodeSyntax - | ITminus - | ITbang - | ITdot - - | ITbiglam -- GHC-extension symbols - - | ITocurly -- special symbols - | ITccurly - | ITvocurly - | ITvccurly - | ITobrack - | ITopabrack -- [:, for parallel arrays with -XParallelArrays - | ITcpabrack -- :], for parallel arrays with -XParallelArrays - | ITcbrack - | IToparen - | ITcparen - | IToubxparen - | ITcubxparen - | ITsemi - | ITcomma - | ITunderscore - | ITbackquote - | ITsimpleQuote -- ' - - | ITvarid FastString -- identifiers - | ITconid FastString - | ITvarsym FastString - | ITconsym FastString - | ITqvarid (FastString,FastString) - | ITqconid (FastString,FastString) - | ITqvarsym (FastString,FastString) - | ITqconsym (FastString,FastString) - - | ITdupipvarid FastString -- GHC extension: implicit param: ?x - | ITlabelvarid FastString -- Overloaded label: #x - - | ITchar SourceText Char -- Note [Literal source text] in BasicTypes - | ITstring SourceText FastString -- Note [Literal source text] in BasicTypes - | ITinteger SourceText Integer -- Note [Literal source text] in BasicTypes - | ITrational FractionalLit - - | ITprimchar SourceText Char -- Note [Literal source text] in BasicTypes - | ITprimstring SourceText ByteString -- Note [Literal source text] @BasicTypes - | ITprimint SourceText Integer -- Note [Literal source text] in BasicTypes - | ITprimword SourceText Integer -- Note [Literal source text] in BasicTypes - | ITprimfloat FractionalLit - | ITprimdouble FractionalLit - - -- Template Haskell extension tokens - | ITopenExpQuote HasE IsUnicodeSyntax -- [| or [e| - | ITopenPatQuote -- [p| - | ITopenDecQuote -- [d| - | ITopenTypQuote -- [t| - | ITcloseQuote IsUnicodeSyntax -- |] - | ITopenTExpQuote HasE -- [|| or [e|| - | ITcloseTExpQuote -- ||] - | ITidEscape FastString -- $x - | ITparenEscape -- $( - | ITidTyEscape FastString -- $$x - | ITparenTyEscape -- $$( - | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,RealSrcSpan) - -- ITquasiQuote(quoter, quote, loc) - -- represents a quasi-quote of the form - -- [quoter| quote |] - | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan) - -- ITqQuasiQuote(Qual, quoter, quote, loc) - -- represents a qualified quasi-quote of the form - -- [Qual.quoter| quote |] - - -- Arrow notation extension - | ITproc - | ITrec - | IToparenbar IsUnicodeSyntax -- (| - | ITcparenbar IsUnicodeSyntax -- |) - | ITlarrowtail IsUnicodeSyntax -- -< - | ITrarrowtail IsUnicodeSyntax -- >- - | ITLarrowtail IsUnicodeSyntax -- -<< - | ITRarrowtail IsUnicodeSyntax -- >>- - - -- type application '@' (lexed differently than as-pattern '@', - -- due to checking for preceding whitespace) - | ITtypeApp - - - | ITunknown String -- Used when the lexer can't make sense of it - | ITeof -- end of file token - - -- Documentation annotations - | ITdocCommentNext String -- something beginning '-- |' - | ITdocCommentPrev String -- something beginning '-- ^' - | ITdocCommentNamed String -- something beginning '-- $' - | ITdocSection Int String -- a section heading - | ITdocOptions String -- doc options (prune, ignore-exports, etc) - | ITlineComment String -- comment starting by "--" - | ITblockComment String -- comment in {- -} - - deriving Show - -instance Outputable Token where - ppr x = text (show x) - - --- the bitmap provided as the third component indicates whether the --- corresponding extension keyword is valid under the extension options --- provided to the compiler; if the extension corresponding to *any* of the --- bits set in the bitmap is enabled, the keyword is valid (this setup --- facilitates using a keyword in two different extensions that can be --- activated independently) --- -reservedWordsFM :: UniqFM (Token, ExtsBitmap) -reservedWordsFM = listToUFM $ - map (\(x, y, z) -> (mkFastString x, (y, z))) - [( "_", ITunderscore, 0 ), - ( "as", ITas, 0 ), - ( "case", ITcase, 0 ), - ( "class", ITclass, 0 ), - ( "data", ITdata, 0 ), - ( "default", ITdefault, 0 ), - ( "deriving", ITderiving, 0 ), - ( "do", ITdo, 0 ), - ( "else", ITelse, 0 ), - ( "hiding", IThiding, 0 ), - ( "if", ITif, 0 ), - ( "import", ITimport, 0 ), - ( "in", ITin, 0 ), - ( "infix", ITinfix, 0 ), - ( "infixl", ITinfixl, 0 ), - ( "infixr", ITinfixr, 0 ), - ( "instance", ITinstance, 0 ), - ( "let", ITlet, 0 ), - ( "module", ITmodule, 0 ), - ( "newtype", ITnewtype, 0 ), - ( "of", ITof, 0 ), - ( "qualified", ITqualified, 0 ), - ( "then", ITthen, 0 ), - ( "type", ITtype, 0 ), - ( "where", ITwhere, 0 ), - - ( "forall", ITforall NormalSyntax, - xbit ExplicitForallBit .|. - xbit InRulePragBit), - ( "mdo", ITmdo, xbit RecursiveDoBit), - -- See Note [Lexing type pseudo-keywords] - ( "family", ITfamily, 0 ), - ( "role", ITrole, 0 ), - ( "pattern", ITpattern, xbit PatternSynonymsBit), - ( "static", ITstatic, 0 ), - ( "stock", ITstock, 0 ), - ( "anyclass", ITanyclass, 0 ), - ( "group", ITgroup, xbit TransformComprehensionsBit), - ( "by", ITby, xbit TransformComprehensionsBit), - ( "using", ITusing, xbit TransformComprehensionsBit), - - ( "foreign", ITforeign, xbit FfiBit), - ( "export", ITexport, xbit FfiBit), - ( "label", ITlabel, xbit FfiBit), - ( "dynamic", ITdynamic, xbit FfiBit), - ( "safe", ITsafe, xbit FfiBit .|. - xbit SafeHaskellBit), - ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), - ( "unsafe", ITunsafe, xbit FfiBit), - ( "stdcall", ITstdcallconv, xbit FfiBit), - ( "ccall", ITccallconv, xbit FfiBit), - ( "capi", ITcapiconv, xbit CApiFfiBit), - ( "prim", ITprimcallconv, xbit FfiBit), - ( "javascript", ITjavascriptcallconv, xbit FfiBit), - - ( "unit", ITunit, 0 ), - ( "dependency", ITdependency, 0 ), - ( "signature", ITsignature, 0 ), - - ( "rec", ITrec, xbit ArrowsBit .|. - xbit RecursiveDoBit), - ( "proc", ITproc, xbit ArrowsBit) - ] - -{----------------------------------- -Note [Lexing type pseudo-keywords] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -One might think that we wish to treat 'family' and 'role' as regular old -varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively. -But, there is no need to do so. These pseudo-keywords are not stolen syntax: -they are only used after the keyword 'type' at the top-level, where varids are -not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that -type families and role annotations are never declared without their extensions -on. In fact, by unconditionally lexing these pseudo-keywords as special, we -can get better error messages. - -Also, note that these are included in the `varid` production in the parser -- -a key detail to make all this work. --------------------------------------} - -reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool) -reservedSymsFM = listToUFM $ - map (\ (x,y,z) -> (mkFastString x,(y,z))) - [ ("..", ITdotdot, always) - -- (:) is a reserved op, meaning only list cons - ,(":", ITcolon, always) - ,("::", ITdcolon NormalSyntax, always) - ,("=", ITequal, always) - ,("\\", ITlam, always) - ,("|", ITvbar, always) - ,("<-", ITlarrow NormalSyntax, always) - ,("->", ITrarrow NormalSyntax, always) - ,("@", ITat, always) - ,("~", ITtilde, always) - ,("~#", ITtildehsh, magicHashEnabled) - ,("=>", ITdarrow NormalSyntax, always) - ,("-", ITminus, always) - ,("!", ITbang, always) - - -- For 'forall a . t' - ,(".", ITdot, always) -- \i -> explicitForallEnabled i || inRulePrag i) - - ,("-<", ITlarrowtail NormalSyntax, arrowsEnabled) - ,(">-", ITrarrowtail NormalSyntax, arrowsEnabled) - ,("-<<", ITLarrowtail NormalSyntax, arrowsEnabled) - ,(">>-", ITRarrowtail NormalSyntax, arrowsEnabled) - - ,("∷", ITdcolon UnicodeSyntax, unicodeSyntaxEnabled) - ,("⇒", ITdarrow UnicodeSyntax, unicodeSyntaxEnabled) - ,("∀", ITforall UnicodeSyntax, unicodeSyntaxEnabled) - ,("→", ITrarrow UnicodeSyntax, unicodeSyntaxEnabled) - ,("←", ITlarrow UnicodeSyntax, unicodeSyntaxEnabled) - - ,("⤙", ITlarrowtail UnicodeSyntax, - \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - ,("⤚", ITrarrowtail UnicodeSyntax, - \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - ,("⤛", ITLarrowtail UnicodeSyntax, - \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - ,("⤜", ITRarrowtail UnicodeSyntax, - \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - - -- ToDo: ideally, → and ∷ should be "specials", so that they cannot - -- form part of a large operator. This would let us have a better - -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). - ] - --- ----------------------------------------------------------------------------- --- Lexer actions - -type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) - -special :: Token -> Action -special tok span _buf _len = return (L span tok) - -token, layout_token :: Token -> Action -token t span _buf _len = return (L span t) -layout_token t span _buf _len = pushLexState layout >> return (L span t) - -idtoken :: (StringBuffer -> Int -> Token) -> Action -idtoken f span buf len = return (L span $! (f buf len)) - -skip_one_varid :: (FastString -> Token) -> Action -skip_one_varid f span buf len - = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) - -skip_two_varid :: (FastString -> Token) -> Action -skip_two_varid f span buf len - = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) - -strtoken :: (String -> Token) -> Action -strtoken f span buf len = - return (L span $! (f $! lexemeToString buf len)) - -init_strtoken :: Int -> (String -> Token) -> Action --- like strtoken, but drops the last N character(s) -init_strtoken drop f span buf len = - return (L span $! (f $! lexemeToString buf (len-drop))) - -begin :: Int -> Action -begin code _span _str _len = do pushLexState code; lexToken - -pop :: Action -pop _span _buf _len = do _ <- popLexState - lexToken - -hopefully_open_brace :: Action -hopefully_open_brace span buf len - = do relaxed <- extension relaxedLayout - ctx <- getContext - (AI l _) <- getInput - let offset = srcLocCol l - isOK = relaxed || - case ctx of - Layout prev_off _ : _ -> prev_off < offset - _ -> True - if isOK then pop_and open_brace span buf len - else failSpanMsgP (RealSrcSpan span) (text "Missing block") - -pop_and :: Action -> Action -pop_and act span buf len = do _ <- popLexState - act span buf len - -{-# INLINE nextCharIs #-} -nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool -nextCharIs buf p = not (atEnd buf) && p (currentChar buf) - -{-# INLINE nextCharIsNot #-} -nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool -nextCharIsNot buf p = not (nextCharIs buf p) - -notFollowedBy :: Char -> AlexAccPred ExtsBitmap -notFollowedBy char _ _ _ (AI _ buf) - = nextCharIsNot buf (== char) - -notFollowedBySymbol :: AlexAccPred ExtsBitmap -notFollowedBySymbol _ _ _ (AI _ buf) - = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") - -followedByDigit :: AlexAccPred ExtsBitmap -followedByDigit _ _ _ (AI _ buf) - = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9'])) - -ifCurrentChar :: Char -> AlexAccPred ExtsBitmap -ifCurrentChar char _ (AI _ buf) _ _ - = nextCharIs buf (== char) - --- We must reject doc comments as being ordinary comments everywhere. --- In some cases the doc comment will be selected as the lexeme due to --- maximal munch, but not always, because the nested comment rule is --- valid in all states, but the doc-comment rules are only valid in --- the non-layout states. -isNormalComment :: AlexAccPred ExtsBitmap -isNormalComment bits _ _ (AI _ buf) - | haddockEnabled bits = notFollowedByDocOrPragma - | otherwise = nextCharIsNot buf (== '#') - where - notFollowedByDocOrPragma - = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) - -afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool -afterOptionalSpace buf p - = if nextCharIs buf (== ' ') - then p (snd (nextChar buf)) - else p buf - -atEOL :: AlexAccPred ExtsBitmap -atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' - -ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap -ifExtension pred bits _ _ _ = pred bits - -orExtensions :: (ExtsBitmap -> Bool) -> (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap -orExtensions pred1 pred2 bits _ _ _ = pred1 bits || pred2 bits - -multiline_doc_comment :: Action -multiline_doc_comment span buf _len = withLexedDocType (worker "") - where - worker commentAcc input docType checkNextLine = case alexGetChar' input of - Just ('\n', input') - | checkNextLine -> case checkIfCommentLine input' of - Just input -> worker ('\n':commentAcc) input docType checkNextLine - Nothing -> docCommentEnd input commentAcc docType buf span - | otherwise -> docCommentEnd input commentAcc docType buf span - Just (c, input) -> worker (c:commentAcc) input docType checkNextLine - Nothing -> docCommentEnd input commentAcc docType buf span - - -- Check if the next line of input belongs to this doc comment as well. - -- A doc comment continues onto the next line when the following - -- conditions are met: - -- * The line starts with "--" - -- * The line doesn't start with "---". - -- * The line doesn't start with "-- $", because that would be the - -- start of a /new/ named haddock chunk (#10398). - checkIfCommentLine :: AlexInput -> Maybe AlexInput - checkIfCommentLine input = check (dropNonNewlineSpace input) - where - check input = do - ('-', input) <- alexGetChar' input - ('-', input) <- alexGetChar' input - (c, after_c) <- alexGetChar' input - case c of - '-' -> Nothing - ' ' -> case alexGetChar' after_c of - Just ('$', _) -> Nothing - _ -> Just input - _ -> Just input - - dropNonNewlineSpace input = case alexGetChar' input of - Just (c, input') - | isSpace c && c /= '\n' -> dropNonNewlineSpace input' - | otherwise -> input - Nothing -> input - -lineCommentToken :: Action -lineCommentToken span buf len = do - b <- extension rawTokenStreamEnabled - if b then strtoken ITlineComment span buf len else lexToken - -{- - nested comments require traversing by hand, they can't be parsed - using regular expressions. --} -nested_comment :: P (RealLocated Token) -> Action -nested_comment cont span buf len = do - input <- getInput - go (reverse $ lexemeToString buf len) (1::Int) input - where - go commentAcc 0 input = do - setInput input - b <- extension rawTokenStreamEnabled - if b - then docCommentEnd input commentAcc ITblockComment buf span - else cont - go commentAcc n input = case alexGetChar' input of - Nothing -> errBrace input span - Just ('-',input) -> case alexGetChar' input of - Nothing -> errBrace input span - Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' - Just (_,_) -> go ('-':commentAcc) n input - Just ('\123',input) -> case alexGetChar' input of -- '{' char - Nothing -> errBrace input span - Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input - Just (_,_) -> go ('\123':commentAcc) n input - Just (c,input) -> go (c:commentAcc) n input - -nested_doc_comment :: Action -nested_doc_comment span buf _len = withLexedDocType (go "") - where - go commentAcc input docType _ = case alexGetChar' input of - Nothing -> errBrace input span - Just ('-',input) -> case alexGetChar' input of - Nothing -> errBrace input span - Just ('\125',input) -> - docCommentEnd input commentAcc docType buf span - Just (_,_) -> go ('-':commentAcc) input docType False - Just ('\123', input) -> case alexGetChar' input of - Nothing -> errBrace input span - Just ('-',input) -> do - setInput input - let cont = do input <- getInput; go commentAcc input docType False - nested_comment cont span buf _len - Just (_,_) -> go ('\123':commentAcc) input docType False - Just (c,input) -> go (c:commentAcc) input docType False - -withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token)) - -> P (RealLocated Token) -withLexedDocType lexDocComment = do - input@(AI _ buf) <- getInput - case prevChar buf ' ' of - -- The `Bool` argument to lexDocComment signals whether or not the next - -- line of input might also belong to this doc comment. - '|' -> lexDocComment input ITdocCommentNext True - '^' -> lexDocComment input ITdocCommentPrev True - '$' -> lexDocComment input ITdocCommentNamed True - '*' -> lexDocSection 1 input - _ -> panic "withLexedDocType: Bad doc type" - where - lexDocSection n input = case alexGetChar' input of - Just ('*', input) -> lexDocSection (n+1) input - Just (_, _) -> lexDocComment input (ITdocSection n) False - Nothing -> do setInput input; lexToken -- eof reached, lex it normally - --- RULES pragmas turn on the forall and '.' keywords, and we turn them --- off again at the end of the pragma. -rulePrag :: Action -rulePrag span buf len = do - setExts (.|. xbit InRulePragBit) - let !src = lexemeToString buf len - return (L span (ITrules_prag (SourceText src))) - -endPrag :: Action -endPrag span _buf _len = do - setExts (.&. complement (xbit InRulePragBit)) - return (L span ITclose_prag) - --- docCommentEnd -------------------------------------------------------------------------------- --- This function is quite tricky. We can't just return a new token, we also --- need to update the state of the parser. Why? Because the token is longer --- than what was lexed by Alex, and the lexToken function doesn't know this, so --- it writes the wrong token length to the parser state. This function is --- called afterwards, so it can just update the state. - -docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> - RealSrcSpan -> P (RealLocated Token) -docCommentEnd input commentAcc docType buf span = do - setInput input - let (AI loc nextBuf) = input - comment = reverse commentAcc - span' = mkRealSrcSpan (realSrcSpanStart span) loc - last_len = byteDiff buf nextBuf - - span `seq` setLastToken span' last_len - return (L span' (docType comment)) - -errBrace :: AlexInput -> RealSrcSpan -> P a -errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" - -open_brace, close_brace :: Action -open_brace span _str _len = do - ctx <- getContext - setContext (NoLayout:ctx) - return (L span ITocurly) -close_brace span _str _len = do - popContext - return (L span ITccurly) - -qvarid, qconid :: StringBuffer -> Int -> Token -qvarid buf len = ITqvarid $! splitQualName buf len False -qconid buf len = ITqconid $! splitQualName buf len False - -splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) --- takes a StringBuffer and a length, and returns the module name --- and identifier parts of a qualified name. Splits at the *last* dot, --- because of hierarchical module names. -splitQualName orig_buf len parens = split orig_buf orig_buf - where - split buf dot_buf - | orig_buf `byteDiff` buf >= len = done dot_buf - | c == '.' = found_dot buf' - | otherwise = split buf' dot_buf - where - (c,buf') = nextChar buf - - -- careful, we might get names like M.... - -- so, if the character after the dot is not upper-case, this is - -- the end of the qualifier part. - found_dot buf -- buf points after the '.' - | isUpper c = split buf' buf - | otherwise = done buf - where - (c,buf') = nextChar buf - - done dot_buf = - (lexemeToFastString orig_buf (qual_size - 1), - if parens -- Prelude.(+) - then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) - else lexemeToFastString dot_buf (len - qual_size)) - where - qual_size = orig_buf `byteDiff` dot_buf - -varid :: Action -varid span buf len = - case lookupUFM reservedWordsFM fs of - Just (ITcase, _) -> do - lambdaCase <- extension lambdaCaseEnabled - keyword <- if lambdaCase - then do - lastTk <- getLastTk - return $ case lastTk of - Just ITlam -> ITlcase - _ -> ITcase - else - return ITcase - maybe_layout keyword - return $ L span keyword - Just (ITstatic, _) -> do - staticPointers <- extension staticPointersEnabled - if staticPointers - then return $ L span ITstatic - else return $ L span $ ITvarid fs - Just (keyword, 0) -> do - maybe_layout keyword - return $ L span keyword - Just (keyword, exts) -> do - extsEnabled <- extension $ \i -> exts .&. i /= 0 - if extsEnabled - then do - maybe_layout keyword - return $ L span keyword - else - return $ L span $ ITvarid fs - Nothing -> - return $ L span $ ITvarid fs - where - !fs = lexemeToFastString buf len - -conid :: StringBuffer -> Int -> Token -conid buf len = ITconid $! lexemeToFastString buf len - -qvarsym, qconsym :: StringBuffer -> Int -> Token -qvarsym buf len = ITqvarsym $! splitQualName buf len False -qconsym buf len = ITqconsym $! splitQualName buf len False - -varsym, consym :: Action -varsym = sym ITvarsym -consym = sym ITconsym - -sym :: (FastString -> Token) -> Action -sym con span buf len = - case lookupUFM reservedSymsFM fs of - Just (keyword, exts) -> do - extsEnabled <- extension exts - let !tk | extsEnabled = keyword - | otherwise = con fs - return $ L span tk - Nothing -> - return $ L span $! con fs - where - !fs = lexemeToFastString buf len - --- Variations on the integral numeric literal. -tok_integral :: (SourceText -> Integer -> Token) - -> (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char -> Int)) - -> Action -tok_integral itint transint transbuf translen (radix,char_to_int) span buf len - = return $ L span $ itint (SourceText $ lexemeToString buf len) - $! transint $ parseUnsignedInteger - (offsetBytes transbuf buf) (subtract translen len) radix char_to_int - --- some conveniences for use with tok_integral -tok_num :: (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_num = tok_integral ITinteger -tok_primint :: (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_primint = tok_integral ITprimint -tok_primword :: Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_primword = tok_integral ITprimword positive -positive, negative :: (Integer -> Integer) -positive = id -negative = negate -decimal, octal, hexadecimal :: (Integer, Char -> Int) -decimal = (10,octDecDigit) -binary = (2,octDecDigit) -octal = (8,octDecDigit) -hexadecimal = (16,hexDigit) - --- readRational can understand negative rationals, exponents, everything. -tok_float, tok_primfloat, tok_primdouble :: String -> Token -tok_float str = ITrational $! readFractionalLit str -tok_primfloat str = ITprimfloat $! readFractionalLit str -tok_primdouble str = ITprimdouble $! readFractionalLit str - -readFractionalLit :: String -> FractionalLit -readFractionalLit str = (FL $! str) $! readRational str - --- ----------------------------------------------------------------------------- --- Layout processing - --- we're at the first token on a line, insert layout tokens if necessary -do_bol :: Action -do_bol span _str _len = do - (pos, gen_semic) <- getOffside - case pos of - LT -> do - --trace "layout: inserting '}'" $ do - popContext - -- do NOT pop the lex state, we might have a ';' to insert - return (L span ITvccurly) - EQ | gen_semic -> do - --trace "layout: inserting ';'" $ do - _ <- popLexState - return (L span ITsemi) - _ -> do - _ <- popLexState - lexToken - --- certain keywords put us in the "layout" state, where we might --- add an opening curly brace. -maybe_layout :: Token -> P () -maybe_layout t = do -- If the alternative layout rule is enabled then - -- we never create an implicit layout context here. - -- Layout is handled XXX instead. - -- The code for closing implicit contexts, or - -- inserting implicit semi-colons, is therefore - -- irrelevant as it only applies in an implicit - -- context. - alr <- extension alternativeLayoutRule - unless alr $ f t - where f ITdo = pushLexState layout_do - f ITmdo = pushLexState layout_do - f ITof = pushLexState layout - f ITlcase = pushLexState layout - f ITlet = pushLexState layout - f ITwhere = pushLexState layout - f ITrec = pushLexState layout - f ITif = pushLexState layout_if - f _ = return () - --- Pushing a new implicit layout context. If the indentation of the --- next token is not greater than the previous layout context, then --- Haskell 98 says that the new layout context should be empty; that is --- the lexer must generate {}. --- --- We are slightly more lenient than this: when the new context is started --- by a 'do', then we allow the new context to be at the same indentation as --- the previous context. This is what the 'strict' argument is for. -new_layout_context :: Bool -> Bool -> Token -> Action -new_layout_context strict gen_semic tok span _buf len = do - _ <- popLexState - (AI l _) <- getInput - let offset = srcLocCol l - len - ctx <- getContext - nondecreasing <- extension nondecreasingIndentation - let strict' = strict || not nondecreasing - case ctx of - Layout prev_off _ : _ | - (strict' && prev_off >= offset || - not strict' && prev_off > offset) -> do - -- token is indented to the left of the previous context. - -- we must generate a {} sequence now. - pushLexState layout_left - return (L span tok) - _ -> do setContext (Layout offset gen_semic : ctx) - return (L span tok) - -do_layout_left :: Action -do_layout_left span _buf _len = do - _ <- popLexState - pushLexState bol -- we must be at the start of a line - return (L span ITvccurly) - --- ----------------------------------------------------------------------------- --- LINE pragmas - -setLine :: Int -> Action -setLine code span buf len = do - let line = parseUnsignedInteger buf len 10 octDecDigit - setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line - _ <- popLexState - pushLexState code - lexToken - -setColumn :: Action -setColumn span buf len = do - let column = - case reads (lexemeToString buf len) of - [(column, _)] -> column - _ -> error "setColumn: expected integer" -- shouldn't happen - setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span) - (fromIntegral (column :: Integer))) - _ <- popLexState - lexToken - -setFile :: Int -> Action -setFile code span buf len = do - let file = mkFastString (go (lexemeToString (stepOn buf) (len-2))) - where go ('\\':c:cs) = c : go cs - go (c:cs) = c : go cs - go [] = [] - -- decode escapes in the filename. e.g. on Windows - -- when our filenames have backslashes in, gcc seems to - -- escape the backslashes. One symptom of not doing this - -- is that filenames in error messages look a bit strange: - -- C:\\foo\bar.hs - -- only the first backslash is doubled, because we apply - -- System.FilePath.normalise before printing out - -- filenames and it does not remove duplicate - -- backslashes after the drive letter (should it?). - setAlrLastLoc $ alrInitialLoc file - setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) - addSrcFile file - _ <- popLexState - pushLexState code - lexToken - -alrInitialLoc :: FastString -> RealSrcSpan -alrInitialLoc file = mkRealSrcSpan loc loc - where -- This is a hack to ensure that the first line in a file - -- looks like it is after the initial location: - loc = mkRealSrcLoc file (-1) (-1) - --- ----------------------------------------------------------------------------- --- Options, includes and language pragmas. - -lex_string_prag :: (String -> Token) -> Action -lex_string_prag mkTok span _buf _len - = do input <- getInput - start <- getSrcLoc - tok <- go [] input - end <- getSrcLoc - return (L (mkRealSrcSpan start end) tok) - where go acc input - = if isString input "#-}" - then do setInput input - return (mkTok (reverse acc)) - else case alexGetChar input of - Just (c,i) -> go (c:acc) i - Nothing -> err input - isString _ [] = True - isString i (x:xs) - = case alexGetChar i of - Just (c,i') | c == x -> isString i' xs - _other -> False - err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma" - - --- ----------------------------------------------------------------------------- --- Strings & Chars - --- This stuff is horrible. I hates it. - -lex_string_tok :: Action -lex_string_tok span buf _len = do - tok <- lex_string "" - (AI end bufEnd) <- getInput - let - tok' = case tok of - ITprimstring _ bs -> ITprimstring (SourceText src) bs - ITstring _ s -> ITstring (SourceText src) s - _ -> panic "lex_string_tok" - src = lexemeToString buf (cur bufEnd - cur buf) - return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok') - -lex_string :: String -> P Token -lex_string s = do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i - - Just ('"',i) -> do - setInput i - magicHash <- extension magicHashEnabled - if magicHash - then do - i <- getInput - case alexGetChar' i of - Just ('#',i) -> do - setInput i - if any (> '\xFF') s - then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" - else let bs = unsafeMkByteString (reverse s) - in return (ITprimstring (SourceText (reverse s)) bs) - _other -> - return (ITstring (SourceText (reverse s)) - (mkFastString (reverse s))) - else - return (ITstring (SourceText (reverse s)) - (mkFastString (reverse s))) - - Just ('\\',i) - | Just ('&',i) <- next -> do - setInput i; lex_string s - | Just (c,i) <- next, c <= '\x7f' && is_space c -> do - -- is_space only works for <= '\x7f' (#3751, #5425) - setInput i; lex_stringgap s - where next = alexGetChar' i - - Just (c, i1) -> do - case c of - '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) - c | isAny c -> do setInput i1; lex_string (c:s) - _other -> lit_error i - -lex_stringgap :: String -> P Token -lex_stringgap s = do - i <- getInput - c <- getCharOrFail i - case c of - '\\' -> lex_string s - c | c <= '\x7f' && is_space c -> lex_stringgap s - -- is_space only works for <= '\x7f' (#3751, #5425) - _other -> lit_error i - - -lex_char_tok :: Action --- Here we are basically parsing character literals, such as 'x' or '\n' --- but we additionally spot 'x and ''T, returning ITsimpleQuote and --- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part --- (the parser does that). --- So we have to do two characters of lookahead: when we see 'x we need to --- see if there's a trailing quote -lex_char_tok span buf _len = do -- We've seen ' - i1 <- getInput -- Look ahead to first character - let loc = realSrcSpanStart span - case alexGetChar' i1 of - Nothing -> lit_error i1 - - Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' - setInput i2 - return (L (mkRealSrcSpan loc end2) ITtyQuote) - - Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash - setInput i2 - lit_ch <- lex_escape - i3 <- getInput - mc <- getCharOrFail i3 -- Trailing quote - if mc == '\'' then finish_char_tok buf loc lit_ch - else lit_error i3 - - Just (c, i2@(AI _end2 _)) - | not (isAny c) -> lit_error i1 - | otherwise -> - - -- We've seen 'x, where x is a valid character - -- (i.e. not newline etc) but not a quote or backslash - case alexGetChar' i2 of -- Look ahead one more character - Just ('\'', i3) -> do -- We've seen 'x' - setInput i3 - finish_char_tok buf loc c - _other -> do -- We've seen 'x not followed by quote - -- (including the possibility of EOF) - -- Just parse the quote only - let (AI end _) = i1 - return (L (mkRealSrcSpan loc end) ITsimpleQuote) - -finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token) -finish_char_tok buf loc ch -- We've already seen the closing quote - -- Just need to check for trailing # - = do magicHash <- extension magicHashEnabled - i@(AI end bufEnd) <- getInput - let src = lexemeToString buf (cur bufEnd - cur buf) - if magicHash then do - case alexGetChar' i of - Just ('#',i@(AI end _)) -> do - setInput i - return (L (mkRealSrcSpan loc end) - (ITprimchar (SourceText src) ch)) - _other -> - return (L (mkRealSrcSpan loc end) - (ITchar (SourceText src) ch)) - else do - return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch)) - -isAny :: Char -> Bool -isAny c | c > '\x7f' = isPrint c - | otherwise = is_any c - -lex_escape :: P Char -lex_escape = do - i0 <- getInput - c <- getCharOrFail i0 - case c of - 'a' -> return '\a' - 'b' -> return '\b' - 'f' -> return '\f' - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'v' -> return '\v' - '\\' -> return '\\' - '"' -> return '\"' - '\'' -> return '\'' - '^' -> do i1 <- getInput - c <- getCharOrFail i1 - if c >= '@' && c <= '_' - then return (chr (ord c - ord '@')) - else lit_error i1 - - 'x' -> readNum is_hexdigit 16 hexDigit - 'o' -> readNum is_octdigit 8 octDecDigit - x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) - - c1 -> do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i0 - Just (c2,i2) -> - case alexGetChar' i2 of - Nothing -> do lit_error i0 - Just (c3,i3) -> - let str = [c1,c2,c3] in - case [ (c,rest) | (p,c) <- silly_escape_chars, - Just rest <- [stripPrefix p str] ] of - (escape_char,[]):_ -> do - setInput i3 - return escape_char - (escape_char,_:_):_ -> do - setInput i2 - return escape_char - [] -> lit_error i0 - -readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char -readNum is_digit base conv = do - i <- getInput - c <- getCharOrFail i - if is_digit c - then readNum2 is_digit base conv (conv c) - else lit_error i - -readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char -readNum2 is_digit base conv i = do - input <- getInput - read i input - where read i input = do - case alexGetChar' input of - Just (c,input') | is_digit c -> do - let i' = i*base + conv c - if i' > 0x10ffff - then setInput input >> lexError "numeric escape sequence out of range" - else read i' input' - _other -> do - setInput input; return (chr i) - - -silly_escape_chars :: [(String, Char)] -silly_escape_chars = [ - ("NUL", '\NUL'), - ("SOH", '\SOH'), - ("STX", '\STX'), - ("ETX", '\ETX'), - ("EOT", '\EOT'), - ("ENQ", '\ENQ'), - ("ACK", '\ACK'), - ("BEL", '\BEL'), - ("BS", '\BS'), - ("HT", '\HT'), - ("LF", '\LF'), - ("VT", '\VT'), - ("FF", '\FF'), - ("CR", '\CR'), - ("SO", '\SO'), - ("SI", '\SI'), - ("DLE", '\DLE'), - ("DC1", '\DC1'), - ("DC2", '\DC2'), - ("DC3", '\DC3'), - ("DC4", '\DC4'), - ("NAK", '\NAK'), - ("SYN", '\SYN'), - ("ETB", '\ETB'), - ("CAN", '\CAN'), - ("EM", '\EM'), - ("SUB", '\SUB'), - ("ESC", '\ESC'), - ("FS", '\FS'), - ("GS", '\GS'), - ("RS", '\RS'), - ("US", '\US'), - ("SP", '\SP'), - ("DEL", '\DEL') - ] - --- before calling lit_error, ensure that the current input is pointing to --- the position of the error in the buffer. This is so that we can report --- a correct location to the user, but also so we can detect UTF-8 decoding --- errors if they occur. -lit_error :: AlexInput -> P a -lit_error i = do setInput i; lexError "lexical error in string/character literal" - -getCharOrFail :: AlexInput -> P Char -getCharOrFail i = do - case alexGetChar' i of - Nothing -> lexError "unexpected end-of-file in string/character literal" - Just (c,i) -> do setInput i; return c - --- ----------------------------------------------------------------------------- --- QuasiQuote - -lex_qquasiquote_tok :: Action -lex_qquasiquote_tok span buf len = do - let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False - quoteStart <- getSrcLoc - quote <- lex_quasiquote quoteStart "" - end <- getSrcLoc - return (L (mkRealSrcSpan (realSrcSpanStart span) end) - (ITqQuasiQuote (qual, - quoter, - mkFastString (reverse quote), - mkRealSrcSpan quoteStart end))) - -lex_quasiquote_tok :: Action -lex_quasiquote_tok span buf len = do - let quoter = tail (lexemeToString buf (len - 1)) - -- 'tail' drops the initial '[', - -- while the -1 drops the trailing '|' - quoteStart <- getSrcLoc - quote <- lex_quasiquote quoteStart "" - end <- getSrcLoc - return (L (mkRealSrcSpan (realSrcSpanStart span) end) - (ITquasiQuote (mkFastString quoter, - mkFastString (reverse quote), - mkRealSrcSpan quoteStart end))) - -lex_quasiquote :: RealSrcLoc -> String -> P String -lex_quasiquote start s = do - i <- getInput - case alexGetChar' i of - Nothing -> quasiquote_error start - - -- NB: The string "|]" terminates the quasiquote, - -- with absolutely no escaping. See the extensive - -- discussion on Trac #5348 for why there is no - -- escape handling. - Just ('|',i) - | Just (']',i) <- alexGetChar' i - -> do { setInput i; return s } - - Just (c, i) -> do - setInput i; lex_quasiquote start (c : s) - -quasiquote_error :: RealSrcLoc -> P a -quasiquote_error start = do - (AI end buf) <- getInput - reportLexError start end buf "unterminated quasiquotation" - --- ----------------------------------------------------------------------------- --- Warnings - -warnTab :: Action -warnTab srcspan _buf _len = do - addTabWarning srcspan - lexToken - -warnThen :: WarningFlag -> SDoc -> Action -> Action -warnThen option warning action srcspan buf len = do - addWarning option (RealSrcSpan srcspan) warning - action srcspan buf len - --- ----------------------------------------------------------------------------- --- The Parse Monad - --- | Do we want to generate ';' layout tokens? In some cases we just want to --- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates --- alternatives (unlike a `case` expression where we need ';' to as a separator --- between alternatives). -type GenSemic = Bool - -generateSemic, dontGenerateSemic :: GenSemic -generateSemic = True -dontGenerateSemic = False - -data LayoutContext - = NoLayout - | Layout !Int !GenSemic - deriving Show - -data ParseResult a - = POk PState a - | PFailed - SrcSpan -- The start and end of the text span related to - -- the error. Might be used in environments which can - -- show this span, e.g. by highlighting it. - MsgDoc -- The error message - --- | Test whether a 'WarningFlag' is set -warnopt :: WarningFlag -> ParserFlags -> Bool -warnopt f options = fromEnum f `IntSet.member` pWarningFlags options - --- | Test whether a 'LangExt.Extension' is set -extopt :: LangExt.Extension -> ParserFlags -> Bool -extopt f options = fromEnum f `IntSet.member` pExtensionFlags options - --- | The subset of the 'DynFlags' used by the parser -data ParserFlags = ParserFlags { - pWarningFlags :: IntSet - , pExtensionFlags :: IntSet - , pThisPackage :: UnitId -- ^ key of package currently being compiled - , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions - } - -data PState = PState { - buffer :: StringBuffer, - options :: ParserFlags, - -- This needs to take DynFlags as an argument until - -- we have a fix for #10143 - messages :: DynFlags -> Messages, - tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file - tab_count :: !Int, -- number of tab warnings in the file - last_tk :: Maybe Token, - last_loc :: RealSrcSpan, -- pos of previous token - last_len :: !Int, -- len of previous token - loc :: RealSrcLoc, -- current loc (end of prev token + 1) - context :: [LayoutContext], - lex_state :: [Int], - srcfiles :: [FastString], - -- Used in the alternative layout rule: - -- These tokens are the next ones to be sent out. They are - -- just blindly emitted, without the rule looking at them again: - alr_pending_implicit_tokens :: [RealLocated Token], - -- This is the next token to be considered or, if it is Nothing, - -- we need to get the next token from the input stream: - alr_next_token :: Maybe (RealLocated Token), - -- This is what we consider to be the location of the last token - -- emitted: - alr_last_loc :: RealSrcSpan, - -- The stack of layout contexts: - alr_context :: [ALRContext], - -- Are we expecting a '{'? If it's Just, then the ALRLayout tells - -- us what sort of layout the '{' will open: - alr_expecting_ocurly :: Maybe ALRLayout, - -- Have we just had the '}' for a let block? If so, than an 'in' - -- token doesn't need to close anything: - alr_justClosedExplicitLetBlock :: Bool, - - -- The next three are used to implement Annotations giving the - -- locations of 'noise' tokens in the source, so that users of - -- the GHC API can do source to source conversions. - -- See note [Api annotations] in ApiAnnotation.hs - annotations :: [(ApiAnnKey,[SrcSpan])], - comment_q :: [Located AnnotationComment], - annotations_comments :: [(SrcSpan,[Located AnnotationComment])] - } - -- last_loc and last_len are used when generating error messages, - -- and in pushCurrentContext only. Sigh, if only Happy passed the - -- current token to happyError, we could at least get rid of last_len. - -- Getting rid of last_loc would require finding another way to - -- implement pushCurrentContext (which is only called from one place). - -data ALRContext = ALRNoLayout Bool{- does it contain commas? -} - Bool{- is it a 'let' block? -} - | ALRLayout ALRLayout Int -data ALRLayout = ALRLayoutLet - | ALRLayoutWhere - | ALRLayoutOf - | ALRLayoutDo - -newtype P a = P { unP :: PState -> ParseResult a } - -instance Functor P where - fmap = liftM - -instance Applicative P where - pure = returnP - (<*>) = ap - -instance Monad P where - (>>=) = thenP - fail = failP - -#if __GLASGOW_HASKELL__ > 710 -instance MonadFail P where - fail = failP -#endif - -returnP :: a -> P a -returnP a = a `seq` (P $ \s -> POk s a) - -thenP :: P a -> (a -> P b) -> P b -(P m) `thenP` k = P $ \ s -> - case m s of - POk s1 a -> (unP (k a)) s1 - PFailed span err -> PFailed span err - -failP :: String -> P a -failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) - -failMsgP :: String -> P a -failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) - -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a -failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) - -failSpanMsgP :: SrcSpan -> SDoc -> P a -failSpanMsgP span msg = P $ \_ -> PFailed span msg - -getPState :: P PState -getPState = P $ \s -> POk s s - -withThisPackage :: (UnitId -> a) -> P a -withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o)) - -extension :: (ExtsBitmap -> Bool) -> P Bool -extension p = P $ \s -> POk s (p $! (pExtsBitmap . options) s) - -getExts :: P ExtsBitmap -getExts = P $ \s -> POk s (pExtsBitmap . options $ s) - -setExts :: (ExtsBitmap -> ExtsBitmap) -> P () -setExts f = P $ \s -> POk s { - options = - let p = options s - in p { pExtsBitmap = f (pExtsBitmap p) } - } () - -setSrcLoc :: RealSrcLoc -> P () -setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () - -getSrcLoc :: P RealSrcLoc -getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc - -addSrcFile :: FastString -> P () -addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () - -setLastToken :: RealSrcSpan -> Int -> P () -setLastToken loc len = P $ \s -> POk s { - last_loc=loc, - last_len=len - } () - -setLastTk :: Token -> P () -setLastTk tk = P $ \s -> POk s { last_tk = Just tk } () - -getLastTk :: P (Maybe Token) -getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk - -data AlexInput = AI RealSrcLoc StringBuffer - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (AI _ buf) = prevChar buf '\n' - --- backwards compatibility for Alex 2.x -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar inp = case alexGetByte inp of - Nothing -> Nothing - Just (b,i) -> c `seq` Just (c,i) - where c = chr $ fromIntegral b - -alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) -alexGetByte (AI loc s) - | atEnd s = Nothing - | otherwise = byte `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (byte, (AI loc' s')) - where (c,s') = nextChar s - loc' = advanceSrcLoc loc c - byte = fromIntegral $ ord adj_c - - non_graphic = '\x00' - upper = '\x01' - lower = '\x02' - digit = '\x03' - symbol = '\x04' - space = '\x05' - other_graphic = '\x06' - uniidchar = '\x07' - - adj_c - | c <= '\x07' = non_graphic - | c <= '\x7f' = c - -- Alex doesn't handle Unicode, so when Unicode - -- character is encountered we output these values - -- with the actual character value hidden in the state. - | otherwise = - -- NB: The logic behind these definitions is also reflected - -- in basicTypes/Lexeme.hs - -- Any changes here should likely be reflected there. - - case generalCategory c of - UppercaseLetter -> upper - LowercaseLetter -> lower - TitlecaseLetter -> upper - ModifierLetter -> uniidchar -- see #10196 - OtherLetter -> lower -- see #1103 - NonSpacingMark -> uniidchar -- see #7650 - SpacingCombiningMark -> other_graphic - EnclosingMark -> other_graphic - DecimalNumber -> digit - LetterNumber -> other_graphic - OtherNumber -> digit -- see #4373 - ConnectorPunctuation -> symbol - DashPunctuation -> symbol - OpenPunctuation -> other_graphic - ClosePunctuation -> other_graphic - InitialQuote -> other_graphic - FinalQuote -> other_graphic - OtherPunctuation -> symbol - MathSymbol -> symbol - CurrencySymbol -> symbol - ModifierSymbol -> symbol - OtherSymbol -> symbol - Space -> space - _other -> non_graphic - --- This version does not squash unicode characters, it is used when --- lexing strings. -alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar' (AI loc s) - | atEnd s = Nothing - | otherwise = c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (c, (AI loc' s')) - where (c,s') = nextChar s - loc' = advanceSrcLoc loc c - -getInput :: P AlexInput -getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) - -setInput :: AlexInput -> P () -setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () - -nextIsEOF :: P Bool -nextIsEOF = do - AI _ s <- getInput - return $ atEnd s - -pushLexState :: Int -> P () -pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () - -popLexState :: P Int -popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls - -getLexState :: P Int -getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls - -popNextToken :: P (Maybe (RealLocated Token)) -popNextToken - = P $ \s@PState{ alr_next_token = m } -> - POk (s {alr_next_token = Nothing}) m - -activeContext :: P Bool -activeContext = do - ctxt <- getALRContext - expc <- getAlrExpectingOCurly - impt <- implicitTokenPending - case (ctxt,expc) of - ([],Nothing) -> return impt - _other -> return True - -setAlrLastLoc :: RealSrcSpan -> P () -setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () - -getAlrLastLoc :: P RealSrcSpan -getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l - -getALRContext :: P [ALRContext] -getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs - -setALRContext :: [ALRContext] -> P () -setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () - -getALRTransitional :: P Bool -getALRTransitional = P $ \s@PState {options = o} -> - POk s (extopt LangExt.AlternativeLayoutRuleTransitional o) - -getJustClosedExplicitLetBlock :: P Bool -getJustClosedExplicitLetBlock - = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b - -setJustClosedExplicitLetBlock :: Bool -> P () -setJustClosedExplicitLetBlock b - = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () - -setNextToken :: RealLocated Token -> P () -setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () - -implicitTokenPending :: P Bool -implicitTokenPending - = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> - case ts of - [] -> POk s False - _ -> POk s True - -popPendingImplicitToken :: P (Maybe (RealLocated Token)) -popPendingImplicitToken - = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> - case ts of - [] -> POk s Nothing - (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) - -setPendingImplicitTokens :: [RealLocated Token] -> P () -setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () - -getAlrExpectingOCurly :: P (Maybe ALRLayout) -getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b - -setAlrExpectingOCurly :: Maybe ALRLayout -> P () -setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () - --- for reasons of efficiency, flags indicating language extensions (eg, --- -fglasgow-exts or -XParallelArrays) are represented by a bitmap --- stored in an unboxed Word64 -type ExtsBitmap = Word64 - -xbit :: ExtBits -> ExtsBitmap -xbit = bit . fromEnum - -xtest :: ExtBits -> ExtsBitmap -> Bool -xtest ext xmap = testBit xmap (fromEnum ext) - -data ExtBits - = FfiBit - | InterruptibleFfiBit - | CApiFfiBit - | ParrBit - | ArrowsBit - | ThBit - | ThQuotesBit - | IpBit - | OverloadedLabelsBit -- #x overloaded labels - | ExplicitForallBit -- the 'forall' keyword and '.' symbol - | BangPatBit -- Tells the parser to understand bang-patterns - -- (doesn't affect the lexer) - | PatternSynonymsBit -- pattern synonyms - | HaddockBit-- Lex and parse Haddock comments - | MagicHashBit -- "#" in both functions and operators - | RecursiveDoBit -- mdo - | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc - | UnboxedTuplesBit -- (# and #) - | UnboxedSumsBit -- (# and #) - | DatatypeContextsBit - | TransformComprehensionsBit - | QqBit -- enable quasiquoting - | InRulePragBit - | RawTokenStreamBit -- producing a token stream with all comments included - | SccProfilingOnBit - | HpcBit - | AlternativeLayoutRuleBit - | RelaxedLayoutBit - | NondecreasingIndentationBit - | SafeHaskellBit - | TraditionalRecordSyntaxBit - | ExplicitNamespacesBit - | LambdaCaseBit - | BinaryLiteralsBit - | NegativeLiteralsBit - | TypeApplicationsBit - | StaticPointersBit - deriving Enum - - -always :: ExtsBitmap -> Bool -always _ = True -parrEnabled :: ExtsBitmap -> Bool -parrEnabled = xtest ParrBit -arrowsEnabled :: ExtsBitmap -> Bool -arrowsEnabled = xtest ArrowsBit -thEnabled :: ExtsBitmap -> Bool -thEnabled = xtest ThBit -thQuotesEnabled :: ExtsBitmap -> Bool -thQuotesEnabled = xtest ThQuotesBit -ipEnabled :: ExtsBitmap -> Bool -ipEnabled = xtest IpBit -overloadedLabelsEnabled :: ExtsBitmap -> Bool -overloadedLabelsEnabled = xtest OverloadedLabelsBit -explicitForallEnabled :: ExtsBitmap -> Bool -explicitForallEnabled = xtest ExplicitForallBit -bangPatEnabled :: ExtsBitmap -> Bool -bangPatEnabled = xtest BangPatBit -haddockEnabled :: ExtsBitmap -> Bool -haddockEnabled = xtest HaddockBit -magicHashEnabled :: ExtsBitmap -> Bool -magicHashEnabled = xtest MagicHashBit -unicodeSyntaxEnabled :: ExtsBitmap -> Bool -unicodeSyntaxEnabled = xtest UnicodeSyntaxBit -unboxedTuplesEnabled :: ExtsBitmap -> Bool -unboxedTuplesEnabled = xtest UnboxedTuplesBit -unboxedSumsEnabled :: ExtsBitmap -> Bool -unboxedSumsEnabled = xtest UnboxedSumsBit -datatypeContextsEnabled :: ExtsBitmap -> Bool -datatypeContextsEnabled = xtest DatatypeContextsBit -qqEnabled :: ExtsBitmap -> Bool -qqEnabled = xtest QqBit -inRulePrag :: ExtsBitmap -> Bool -inRulePrag = xtest InRulePragBit -rawTokenStreamEnabled :: ExtsBitmap -> Bool -rawTokenStreamEnabled = xtest RawTokenStreamBit -alternativeLayoutRule :: ExtsBitmap -> Bool -alternativeLayoutRule = xtest AlternativeLayoutRuleBit -hpcEnabled :: ExtsBitmap -> Bool -hpcEnabled = xtest HpcBit -relaxedLayout :: ExtsBitmap -> Bool -relaxedLayout = xtest RelaxedLayoutBit -nondecreasingIndentation :: ExtsBitmap -> Bool -nondecreasingIndentation = xtest NondecreasingIndentationBit -sccProfilingOn :: ExtsBitmap -> Bool -sccProfilingOn = xtest SccProfilingOnBit -traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool -traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit - -explicitNamespacesEnabled :: ExtsBitmap -> Bool -explicitNamespacesEnabled = xtest ExplicitNamespacesBit -lambdaCaseEnabled :: ExtsBitmap -> Bool -lambdaCaseEnabled = xtest LambdaCaseBit -binaryLiteralsEnabled :: ExtsBitmap -> Bool -binaryLiteralsEnabled = xtest BinaryLiteralsBit -negativeLiteralsEnabled :: ExtsBitmap -> Bool -negativeLiteralsEnabled = xtest NegativeLiteralsBit -patternSynonymsEnabled :: ExtsBitmap -> Bool -patternSynonymsEnabled = xtest PatternSynonymsBit -typeApplicationEnabled :: ExtsBitmap -> Bool -typeApplicationEnabled = xtest TypeApplicationsBit -staticPointersEnabled :: ExtsBitmap -> Bool -staticPointersEnabled = xtest StaticPointersBit - --- PState for parsing options pragmas --- -pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState -pragState dynflags buf loc = (mkPState dynflags buf loc) { - lex_state = [bol, option_prags, 0] - } - --- | Extracts the flag information needed for parsing -mkParserFlags :: DynFlags -> ParserFlags -mkParserFlags flags = - ParserFlags { - pWarningFlags = DynFlags.warningFlags flags - , pExtensionFlags = DynFlags.extensionFlags flags - , pThisPackage = DynFlags.thisPackage flags - , pExtsBitmap = bitmap - } - where - bitmap = FfiBit `setBitIf` xopt LangExt.ForeignFunctionInterface flags - .|. InterruptibleFfiBit `setBitIf` xopt LangExt.InterruptibleFFI flags - .|. CApiFfiBit `setBitIf` xopt LangExt.CApiFFI flags - .|. ParrBit `setBitIf` xopt LangExt.ParallelArrays flags - .|. ArrowsBit `setBitIf` xopt LangExt.Arrows flags - .|. ThBit `setBitIf` xopt LangExt.TemplateHaskell flags - .|. ThQuotesBit `setBitIf` xopt LangExt.TemplateHaskellQuotes flags - .|. QqBit `setBitIf` xopt LangExt.QuasiQuotes flags - .|. IpBit `setBitIf` xopt LangExt.ImplicitParams flags - .|. OverloadedLabelsBit `setBitIf` xopt LangExt.OverloadedLabels flags - .|. ExplicitForallBit `setBitIf` xopt LangExt.ExplicitForAll flags - .|. BangPatBit `setBitIf` xopt LangExt.BangPatterns flags - .|. HaddockBit `setBitIf` gopt Opt_Haddock flags - .|. MagicHashBit `setBitIf` xopt LangExt.MagicHash flags - .|. RecursiveDoBit `setBitIf` xopt LangExt.RecursiveDo flags - .|. UnicodeSyntaxBit `setBitIf` xopt LangExt.UnicodeSyntax flags - .|. UnboxedTuplesBit `setBitIf` xopt LangExt.UnboxedTuples flags - .|. UnboxedSumsBit `setBitIf` xopt LangExt.UnboxedSums flags - .|. DatatypeContextsBit `setBitIf` xopt LangExt.DatatypeContexts flags - .|. TransformComprehensionsBit `setBitIf` xopt LangExt.TransformListComp flags - .|. TransformComprehensionsBit `setBitIf` xopt LangExt.MonadComprehensions flags - .|. RawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags - .|. HpcBit `setBitIf` gopt Opt_Hpc flags - .|. AlternativeLayoutRuleBit `setBitIf` xopt LangExt.AlternativeLayoutRule flags - .|. RelaxedLayoutBit `setBitIf` xopt LangExt.RelaxedLayout flags - .|. SccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags - .|. NondecreasingIndentationBit `setBitIf` xopt LangExt.NondecreasingIndentation flags - .|. SafeHaskellBit `setBitIf` safeImportsOn flags - .|. TraditionalRecordSyntaxBit `setBitIf` xopt LangExt.TraditionalRecordSyntax flags - .|. ExplicitNamespacesBit `setBitIf` xopt LangExt.ExplicitNamespaces flags - .|. LambdaCaseBit `setBitIf` xopt LangExt.LambdaCase flags - .|. BinaryLiteralsBit `setBitIf` xopt LangExt.BinaryLiterals flags - .|. NegativeLiteralsBit `setBitIf` xopt LangExt.NegativeLiterals flags - .|. PatternSynonymsBit `setBitIf` xopt LangExt.PatternSynonyms flags - .|. TypeApplicationsBit `setBitIf` xopt LangExt.TypeApplications flags - .|. StaticPointersBit `setBitIf` xopt LangExt.StaticPointers flags - - setBitIf :: ExtBits -> Bool -> ExtsBitmap - b `setBitIf` cond | cond = xbit b - | otherwise = 0 - --- | Creates a parse state from a 'DynFlags' value -mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState -mkPState flags = mkPStatePure (mkParserFlags flags) - --- | Creates a parse state from a 'ParserFlags' value -mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState -mkPStatePure options buf loc = - PState { - buffer = buf, - options = options, - messages = const emptyMessages, - tab_first = Nothing, - tab_count = 0, - last_tk = Nothing, - last_loc = mkRealSrcSpan loc loc, - last_len = 0, - loc = loc, - context = [], - lex_state = [bol, 0], - srcfiles = [], - alr_pending_implicit_tokens = [], - alr_next_token = Nothing, - alr_last_loc = alrInitialLoc (fsLit ""), - alr_context = [], - alr_expecting_ocurly = Nothing, - alr_justClosedExplicitLetBlock = False, - annotations = [], - comment_q = [], - annotations_comments = [] - } - -addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () -addWarning option srcspan warning - = P $ \s@PState{messages=m, options=o} -> - let - m' d = - let (ws, es) = m d - warning' = makeIntoWarning (Reason option) $ - mkWarnMsg d srcspan alwaysQualify warning - ws' = if warnopt option o then ws `snocBag` warning' else ws - in (ws', es) - in POk s{messages=m'} () - -addTabWarning :: RealSrcSpan -> P () -addTabWarning srcspan - = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> - let tf' = if isJust tf then tf else Just srcspan - tc' = tc + 1 - s' = if warnopt Opt_WarnTabs o - then s{tab_first = tf', tab_count = tc'} - else s - in POk s' () - -mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg -mkTabWarning PState{tab_first=tf, tab_count=tc} d = - let middle = if tc == 1 - then text "" - else text ", and in" <+> speakNOf (tc - 1) (text "further location") - message = text "Tab character found here" - <> middle - <> text "." - $+$ text "Please use spaces instead." - in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $ - mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf - -getMessages :: PState -> DynFlags -> Messages -getMessages p@PState{messages=m} d = - let (ws, es) = m d - tabwarning = mkTabWarning p d - ws' = maybe ws (`consBag` ws) tabwarning - in (ws', es) - -getContext :: P [LayoutContext] -getContext = P $ \s@PState{context=ctx} -> POk s ctx - -setContext :: [LayoutContext] -> P () -setContext ctx = P $ \s -> POk s{context=ctx} () - -popContext :: P () -popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, - last_len = len, last_loc = last_loc }) -> - case ctx of - (_:tl) -> POk s{ context = tl } () - [] -> PFailed (RealSrcSpan last_loc) (srcParseErr o buf len) - --- Push a new layout context at the indentation of the last token read. -pushCurrentContext :: GenSemic -> P () -pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } -> - POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} () - --- This is only used at the outer level of a module when the 'module' keyword is --- missing. -pushModuleContext :: P () -pushModuleContext = pushCurrentContext generateSemic - -getOffside :: P (Ordering, Bool) -getOffside = P $ \s@PState{last_loc=loc, context=stk} -> - let offs = srcSpanStartCol loc in - let ord = case stk of - Layout n gen_semic : _ -> - --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ - (compare offs n, gen_semic) - _ -> - (GT, dontGenerateSemic) - in POk s ord - --- --------------------------------------------------------------------------- --- Construct a parse error - -srcParseErr - :: ParserFlags - -> StringBuffer -- current buffer (placed just after the last token) - -> Int -- length of the previous token - -> MsgDoc -srcParseErr options buf len - = if null token - then text "parse error (possibly incorrect indentation or mismatched brackets)" - else text "parse error on input" <+> quotes (text token) - $$ ppWhen (not th_enabled && token == "$") -- #7396 - (text "Perhaps you intended to use TemplateHaskell") - $$ ppWhen (token == "<-") - (text "Perhaps this statement should be within a 'do' block?") - $$ ppWhen (token == "=") - (text "Perhaps you need a 'let' in a 'do' block?" - $$ text "e.g. 'let x = 5' instead of 'x = 5'") - $$ ppWhen (not ps_enabled && pattern == "pattern") -- #12429 - (text "Perhaps you intended to use PatternSynonyms") - where token = lexemeToString (offsetBytes (-len) buf) len - pattern = lexemeToString (offsetBytes (-len - 8) buf) 7 - th_enabled = extopt LangExt.TemplateHaskell options - ps_enabled = extopt LangExt.PatternSynonyms options - --- Report a parse failure, giving the span of the previous token as --- the location of the error. This is the entry point for errors --- detected during parsing. -srcParseFail :: P a -srcParseFail = P $ \PState{ buffer = buf, options = o, last_len = len, - last_loc = last_loc } -> - PFailed (RealSrcSpan last_loc) (srcParseErr o buf len) - --- A lexical error is reported at a particular position in the source file, --- not over a token range. -lexError :: String -> P a -lexError str = do - loc <- getSrcLoc - (AI end buf) <- getInput - reportLexError loc end buf str - --- ----------------------------------------------------------------------------- --- This is the top-level function: called from the parser each time a --- new token is to be read from the input. - -lexer :: Bool -> (Located Token -> P a) -> P a -lexer queueComments cont = do - alr <- extension alternativeLayoutRule - let lexTokenFun = if alr then lexTokenAlr else lexToken - (L span tok) <- lexTokenFun - --trace ("token: " ++ show tok) $ do - - case tok of - ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span) - _ -> return () - - if (queueComments && isDocComment tok) - then queueComment (L (RealSrcSpan span) tok) - else return () - - if (queueComments && isComment tok) - then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont - else cont (L (RealSrcSpan span) tok) - -lexTokenAlr :: P (RealLocated Token) -lexTokenAlr = do mPending <- popPendingImplicitToken - t <- case mPending of - Nothing -> - do mNext <- popNextToken - t <- case mNext of - Nothing -> lexToken - Just next -> return next - alternativeLayoutRuleToken t - Just t -> - return t - setAlrLastLoc (getLoc t) - case unLoc t of - ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) - ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) - ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) - ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo) - ITmdo -> setAlrExpectingOCurly (Just ALRLayoutDo) - ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) - _ -> return () - return t - -alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) -alternativeLayoutRuleToken t - = do context <- getALRContext - lastLoc <- getAlrLastLoc - mExpectingOCurly <- getAlrExpectingOCurly - transitional <- getALRTransitional - justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock - setJustClosedExplicitLetBlock False - let thisLoc = getLoc t - thisCol = srcSpanStartCol thisLoc - newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc - case (unLoc t, context, mExpectingOCurly) of - -- This case handles a GHC extension to the original H98 - -- layout rule... - (ITocurly, _, Just alrLayout) -> - do setAlrExpectingOCurly Nothing - let isLet = case alrLayout of - ALRLayoutLet -> True - _ -> False - setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) - return t - -- ...and makes this case unnecessary - {- - -- I think our implicit open-curly handling is slightly - -- different to John's, in how it interacts with newlines - -- and "in" - (ITocurly, _, Just _) -> - do setAlrExpectingOCurly Nothing - setNextToken t - lexTokenAlr - -} - (_, ALRLayout _ col : _ls, Just expectingOCurly) - | (thisCol > col) || - (thisCol == col && - isNonDecreasingIntentation expectingOCurly) -> - do setAlrExpectingOCurly Nothing - setALRContext (ALRLayout expectingOCurly thisCol : context) - setNextToken t - return (L thisLoc ITocurly) - | otherwise -> - do setAlrExpectingOCurly Nothing - setPendingImplicitTokens [L lastLoc ITccurly] - setNextToken t - return (L lastLoc ITocurly) - (_, _, Just expectingOCurly) -> - do setAlrExpectingOCurly Nothing - setALRContext (ALRLayout expectingOCurly thisCol : context) - setNextToken t - return (L thisLoc ITocurly) - -- We do the [] cases earlier than in the spec, as we - -- have an actual EOF token - (ITeof, ALRLayout _ _ : ls, _) -> - do setALRContext ls - setNextToken t - return (L thisLoc ITccurly) - (ITeof, _, _) -> - return t - -- the other ITeof case omitted; general case below covers it - (ITin, _, _) - | justClosedExplicitLetBlock -> - return t - (ITin, ALRLayout ALRLayoutLet _ : ls, _) - | newLine -> - do setPendingImplicitTokens [t] - setALRContext ls - return (L thisLoc ITccurly) - -- This next case is to handle a transitional issue: - (ITwhere, ALRLayout _ col : ls, _) - | newLine && thisCol == col && transitional -> - do addWarning Opt_WarnAlternativeLayoutRuleTransitional - (RealSrcSpan thisLoc) - (transitionalAlternativeLayoutWarning - "`where' clause at the same depth as implicit layout block") - setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITccurly) - -- This next case is to handle a transitional issue: - (ITvbar, ALRLayout _ col : ls, _) - | newLine && thisCol == col && transitional -> - do addWarning Opt_WarnAlternativeLayoutRuleTransitional - (RealSrcSpan thisLoc) - (transitionalAlternativeLayoutWarning - "`|' at the same depth as implicit layout block") - setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITccurly) - (_, ALRLayout _ col : ls, _) - | newLine && thisCol == col -> - do setNextToken t - return (L thisLoc ITsemi) - | newLine && thisCol < col -> - do setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITccurly) - -- We need to handle close before open, as 'then' is both - -- an open and a close - (u, _, _) - | isALRclose u -> - case context of - ALRLayout _ _ : ls -> - do setALRContext ls - setNextToken t - return (L thisLoc ITccurly) - ALRNoLayout _ isLet : ls -> - do let ls' = if isALRopen u - then ALRNoLayout (containsCommas u) False : ls - else ls - setALRContext ls' - when isLet $ setJustClosedExplicitLetBlock True - return t - [] -> - do let ls = if isALRopen u - then [ALRNoLayout (containsCommas u) False] - else [] - setALRContext ls - -- XXX This is an error in John's code, but - -- it looks reachable to me at first glance - return t - (u, _, _) - | isALRopen u -> - do setALRContext (ALRNoLayout (containsCommas u) False : context) - return t - (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> - do setALRContext ls - setPendingImplicitTokens [t] - return (L thisLoc ITccurly) - (ITin, ALRLayout _ _ : ls, _) -> - do setALRContext ls - setNextToken t - return (L thisLoc ITccurly) - -- the other ITin case omitted; general case below covers it - (ITcomma, ALRLayout _ _ : ls, _) - | topNoLayoutContainsCommas ls -> - do setALRContext ls - setNextToken t - return (L thisLoc ITccurly) - (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> - do setALRContext ls - setPendingImplicitTokens [t] - return (L thisLoc ITccurly) - -- the other ITwhere case omitted; general case below covers it - (_, _, _) -> return t - -transitionalAlternativeLayoutWarning :: String -> SDoc -transitionalAlternativeLayoutWarning msg - = text "transitional layout will not be accepted in the future:" - $$ text msg - -isALRopen :: Token -> Bool -isALRopen ITcase = True -isALRopen ITif = True -isALRopen ITthen = True -isALRopen IToparen = True -isALRopen ITobrack = True -isALRopen ITocurly = True --- GHC Extensions: -isALRopen IToubxparen = True -isALRopen ITparenEscape = True -isALRopen ITparenTyEscape = True -isALRopen _ = False - -isALRclose :: Token -> Bool -isALRclose ITof = True -isALRclose ITthen = True -isALRclose ITelse = True -isALRclose ITcparen = True -isALRclose ITcbrack = True -isALRclose ITccurly = True --- GHC Extensions: -isALRclose ITcubxparen = True -isALRclose _ = False - -isNonDecreasingIntentation :: ALRLayout -> Bool -isNonDecreasingIntentation ALRLayoutDo = True -isNonDecreasingIntentation _ = False - -containsCommas :: Token -> Bool -containsCommas IToparen = True -containsCommas ITobrack = True --- John doesn't have {} as containing commas, but records contain them, --- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs --- (defaultInstallDirs). -containsCommas ITocurly = True --- GHC Extensions: -containsCommas IToubxparen = True -containsCommas _ = False - -topNoLayoutContainsCommas :: [ALRContext] -> Bool -topNoLayoutContainsCommas [] = False -topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls -topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b - -lexToken :: P (RealLocated Token) -lexToken = do - inp@(AI loc1 buf) <- getInput - sc <- getLexState - exts <- getExts - case alexScanUser exts inp sc of - AlexEOF -> do - let span = mkRealSrcSpan loc1 loc1 - setLastToken span 0 - return (L span ITeof) - AlexError (AI loc2 buf) -> - reportLexError loc1 loc2 buf "lexical error" - AlexSkip inp2 _ -> do - setInput inp2 - lexToken - AlexToken inp2@(AI end buf2) _ t -> do - setInput inp2 - let span = mkRealSrcSpan loc1 end - let bytes = byteDiff buf buf2 - span `seq` setLastToken span bytes - lt <- t span buf bytes - case unLoc lt of - ITlineComment _ -> return lt - ITblockComment _ -> return lt - lt' -> do - setLastTk lt' - return lt - -reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a -reportLexError loc1 loc2 buf str - | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") - | otherwise = - let c = fst (nextChar buf) - in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# - then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") - else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) - -lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] -lexTokenStream buf loc dflags = unP go initState - where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream - initState = mkPState dflags' buf loc - go = do - ltok <- lexer False return - case ltok of - L _ ITeof -> return [] - _ -> liftM (ltok:) go - -linePrags = Map.singleton "line" (begin line_prag2) - -fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), - ("options_ghc", lex_string_prag IToptions_prag), - ("options_haddock", lex_string_prag ITdocOptions), - ("language", token ITlanguage_prag), - ("include", lex_string_prag ITinclude_prag)]) - -ignoredPrags = Map.fromList (map ignored pragmas) - where ignored opt = (opt, nested_comment lexToken) - impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] - options_pragmas = map ("options_" ++) impls - -- CFILES is a hugs-only thing. - pragmas = options_pragmas ++ ["cfiles", "contract"] - -oneWordPrags = Map.fromList [ - ("rules", rulePrag), - ("inline", - strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))), - ("inlinable", - strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), - ("inlineable", - strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), - -- Spelling variant - ("notinline", - strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))), - ("specialize", strtoken (\s -> ITspec_prag (SourceText s))), - ("source", strtoken (\s -> ITsource_prag (SourceText s))), - ("warning", strtoken (\s -> ITwarning_prag (SourceText s))), - ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))), - ("scc", strtoken (\s -> ITscc_prag (SourceText s))), - ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))), - ("core", strtoken (\s -> ITcore_prag (SourceText s))), - ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))), - ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))), - ("ann", strtoken (\s -> ITann_prag (SourceText s))), - ("vectorize", strtoken (\s -> ITvect_prag (SourceText s))), - ("novectorize", strtoken (\s -> ITnovect_prag (SourceText s))), - ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))), - ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))), - ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))), - ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))), - ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))), - ("ctype", strtoken (\s -> ITctype (SourceText s))), - ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))), - ("column", begin column_prag) - ] - -twoWordPrags = Map.fromList([ - ("inline conlike", - strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))), - ("notinline conlike", - strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))), - ("specialize inline", - strtoken (\s -> (ITspec_inline_prag (SourceText s) True))), - ("specialize notinline", - strtoken (\s -> (ITspec_inline_prag (SourceText s) False))), - ("vectorize scalar", - strtoken (\s -> ITvect_scalar_prag (SourceText s)))]) - -dispatch_pragmas :: Map String Action -> Action -dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of - Just found -> found span buf len - Nothing -> lexError "unknown pragma" - -known_pragma :: Map String Action -> AlexAccPred ExtsBitmap -known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) - = isKnown && nextCharIsNot curbuf pragmaNameChar - where l = lexemeToString startbuf (byteDiff startbuf curbuf) - isKnown = isJust $ Map.lookup (clean_pragma l) prags - pragmaNameChar c = isAlphaNum c || c == '_' - -clean_pragma :: String -> String -clean_pragma prag = canon_ws (map toLower (unprefix prag)) - where unprefix prag' = case stripPrefix "{-#" prag' of - Just rest -> rest - Nothing -> prag' - canonical prag' = case prag' of - "noinline" -> "notinline" - "specialise" -> "specialize" - "vectorise" -> "vectorize" - "novectorise" -> "novectorize" - "constructorlike" -> "conlike" - _ -> prag' - canon_ws s = unwords (map canonical (words s)) - - - -{- -%************************************************************************ -%* * - Helper functions for generating annotations in the parser -%* * -%************************************************************************ --} - --- | Encapsulated call to addAnnotation, requiring only the SrcSpan of --- the AST construct the annotation belongs to; together with the --- AnnKeywordId, this is the key of the annotation map. --- --- This type is useful for places in the parser where it is not yet --- known what SrcSpan an annotation should be added to. The most --- common situation is when we are parsing a list: the annotations --- need to be associated with the AST element that *contains* the --- list, not the list itself. 'AddAnn' lets us defer adding the --- annotations until we finish parsing the list and are now parsing --- the enclosing element; we then apply the 'AddAnn' to associate --- the annotations. Another common situation is where a common fragment of --- the AST has been factored out but there is no separate AST node for --- this fragment (this occurs in class and data declarations). In this --- case, the annotation belongs to the parent data declaration. --- --- The usual way an 'AddAnn' is created is using the 'mj' ("make jump") --- function, and then it can be discharged using the 'ams' function. -type AddAnn = SrcSpan -> P () - -addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct - -> AnnKeywordId -- The first two parameters are the key - -> SrcSpan -- The location of the keyword itself - -> P () -addAnnotation l a v = do - addAnnotationOnly l a v - allocateComments l - -addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () -addAnnotationOnly l a v = P $ \s -> POk s { - annotations = ((l,a), [v]) : annotations s - } () - --- |Given a location and a list of AddAnn, apply them all to the location. -addAnnsAt :: SrcSpan -> [AddAnn] -> P () -addAnnsAt loc anns = mapM_ (\a -> a loc) anns - --- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate --- 'AddAnn' values for the opening and closing bordering on the start --- and end of the span -mkParensApiAnn :: SrcSpan -> [AddAnn] -mkParensApiAnn (UnhelpfulSpan _) = [] -mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc] - where - mj a l = (\s -> addAnnotation s a l) - f = srcSpanFile ss - sl = srcSpanStartLine ss - sc = srcSpanStartCol ss - el = srcSpanEndLine ss - ec = srcSpanEndCol ss - lo = mkSrcSpan (srcSpanStart s) (mkSrcLoc f sl (sc+1)) - lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s) - --- | Move the annotations and comments belonging to the @old@ span to the @new@ --- one. -moveAnnotations :: SrcSpan -> SrcSpan -> P () -moveAnnotations old new = P $ \s -> - let - updateAnn ((l,a),v) - | l == old = ((new,a),v) - | otherwise = ((l,a),v) - updateComment (l,c) - | l == old = (new,c) - | otherwise = (l,c) - in - POk s { - annotations = map updateAnn (annotations s) - , annotations_comments = map updateComment (annotations_comments s) - } () - -queueComment :: Located Token -> P() -queueComment c = P $ \s -> POk s { - comment_q = commentToAnnotation c : comment_q s - } () - --- | Go through the @comment_q@ in @PState@ and remove all comments --- that belong within the given span -allocateComments :: SrcSpan -> P () -allocateComments ss = P $ \s -> - let - (before,rest) = break (\(L l _) -> isSubspanOf l ss) (comment_q s) - (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest - comment_q' = before ++ after - newAnns = if null middle then [] - else [(ss,middle)] - in - POk s { - comment_q = comment_q' - , annotations_comments = newAnns ++ (annotations_comments s) - } () - -commentToAnnotation :: Located Token -> Located AnnotationComment -commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) -commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s) -commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s) -commentToAnnotation (L l (ITdocSection n s)) = L l (AnnDocSection n s) -commentToAnnotation (L l (ITdocOptions s)) = L l (AnnDocOptions s) -commentToAnnotation (L l (ITlineComment s)) = L l (AnnLineComment s) -commentToAnnotation (L l (ITblockComment s)) = L l (AnnBlockComment s) -commentToAnnotation _ = panic "commentToAnnotation" - --- --------------------------------------------------------------------- - -isComment :: Token -> Bool -isComment (ITlineComment _) = True -isComment (ITblockComment _) = True -isComment _ = False - -isDocComment :: Token -> Bool -isDocComment (ITdocCommentNext _) = True -isDocComment (ITdocCommentPrev _) = True -isDocComment (ITdocCommentNamed _) = True -isDocComment (ITdocSection _ _) = True -isDocComment (ITdocOptions _) = True -isDocComment _ = False - -{- Note [Warnings in code generated by Alex] - -We add the following warning suppression flags to all code generated by Alex: - -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -Without these flags, current versions of Alex will generate code that is not -warning free. Note that this is the result of Alex' internals, not of the way -we have written our (Lexer).x files. - -As always, we need code to be warning free when validating with -Werror. - -The list of flags is as short as possible (at the time of writing), to try to -avoid suppressing warnings for bugs in our own code. - -TODO. Reevaluate this situation once Alex >3.1.4 is released. Hopefully you -can remove these flags from all (Lexer).x files in the repository, and also -delete this Note. Don't forget to update aclocal.m4, and send a HEADS UP -message to ghc-devs. - -The first release of Alex after 3.1.4 will either suppress all warnings itself -[1] (bad), or most warnings will be fixed and only a few select ones will be -suppressed by default [2] (better). - -[1] https://github.com/simonmar/alex/commit/1eefcde22ba1bb9b51d523814415714e20f0761e -[2] https://github.com/simonmar/alex/pull/69 --} -} diff --git a/parser/Parser.y b/parser/Parser.y deleted file mode 100644 --- a/parser/Parser.y +++ /dev/null @@ -1,3723 +0,0 @@ --- -*-haskell-*- --- --------------------------------------------------------------------------- --- (c) The University of Glasgow 1997-2003 ---- --- The GHC grammar. --- --- Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999 --- --------------------------------------------------------------------------- - -{ --- | This module provides the generated Happy parser for Haskell. It exports --- a number of parsers which may be used in any library that uses the GHC API. --- A common usage pattern is to initialize the parser state with a given string --- and then parse that string: --- --- @ --- runParser :: DynFlags -> String -> P a -> ParseResult a --- runParser flags str parser = unP parser parseState --- where --- filename = "\" --- location = mkRealSrcLoc (mkFastString filename) 1 1 --- buffer = stringToStringBuffer str --- parseState = mkPState flags buffer location --- @ -module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBackpack, - parseDeclaration, parseExpression, parsePattern, - parseTypeSignature, - parseStmt, parseIdentifier, - parseType, parseHeader) where - --- base -import Control.Monad ( unless, liftM ) -import GHC.Exts -import Data.Char -import Control.Monad ( mplus ) -import Control.Applicative ((<$)) - --- compiler/hsSyn -import HsSyn - --- compiler/main -import HscTypes ( IsBootInterface, WarningTxt(..) ) -import DynFlags -import BkpSyn -import PackageConfig - --- compiler/utils -import OrdList -import BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue ) -import FastString -import Maybes ( orElse ) -import Outputable - --- compiler/basicTypes -import RdrName -import OccName ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) -import DataCon ( DataCon, dataConName ) -import SrcLoc -import Module -import BasicTypes - --- compiler/types -import Type ( funTyCon ) -import Kind ( Kind ) -import Class ( FunDep ) - --- compiler/parser -import RdrHsSyn -import Lexer -import HaddockUtils -import ApiAnnotation - --- compiler/typecheck -import TcEvidence ( emptyTcEvBinds ) - --- compiler/prelude -import ForeignCall -import TysPrim ( eqPrimTyCon ) -import PrelNames ( eqTyCon_RDR ) -import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, - unboxedUnitTyCon, unboxedUnitDataCon, - listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR ) - --- compiler/utils -import Util ( looksLikePackageName ) -import Prelude - -import qualified GHC.LanguageExtensions as LangExt -} - -%expect 36 -- shift/reduce conflicts - -{- Last updated: 3 Aug 2016 - -If you modify this parser and add a conflict, please update this comment. -You can learn more about the conflicts by passing 'happy' the -i flag: - - happy -agc --strict compiler/parser/Parser.y -idetailed-info - -How is this section formatted? Look up the state the conflict is -reported at, and copy the list of applicable rules (at the top, without the -rule numbers). Mark *** for the rule that is the conflicting reduction (that -is, the interpretation which is NOT taken). NB: Happy doesn't print a rule -in a state if it is empty, but you should include it in the list (you can -look these up in the Grammar section of the info file). - -Obviously the state numbers are not stable across modifications to the parser, -the idea is to reproduce enough information on each conflict so you can figure -out what happened if the states were renumbered. Try not to gratuitously move -productions around in this file. - -------------------------------------------------------------------------------- - -state 0 contains 1 shift/reduce conflicts. - - Conflicts: DOCNEXT (empty missing_module_keyword reduces) - -Ambiguity when the source file starts with "-- | doc". We need another -token of lookahead to determine if a top declaration or the 'module' keyword -follows. Shift parses as if the 'module' keyword follows. - -------------------------------------------------------------------------------- - -state 48 contains 2 shift/reduce conflicts. - - *** strict_mark -> unpackedness . - strict_mark -> unpackedness . strictness - - Conflicts: '~' '!' - -------------------------------------------------------------------------------- - -state 52 contains 1 shift/reduce conflict. - - context -> btype . - *** type -> btype . - type -> btype . '->' ctype - - Conflicts: '->' - -------------------------------------------------------------------------------- - -state 53 contains 9 shift/reduce conflicts. - - *** btype -> tyapps . - tyapps -> tyapps . tyapp - - Conflicts: ':' '-' '!' '.' '`' VARSYM CONSYM QVARSYM QCONSYM - -------------------------------------------------------------------------------- - -state 134 contains 14 shift/reduce conflicts. - - exp -> infixexp . '::' sigtype - exp -> infixexp . '-<' exp - exp -> infixexp . '>-' exp - exp -> infixexp . '-<<' exp - exp -> infixexp . '>>-' exp - *** exp -> infixexp . - infixexp -> infixexp . qop exp10 - - Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-' - '.' '`' VARSYM CONSYM QVARSYM QCONSYM - -Examples of ambiguity: - 'if x then y else z -< e' - 'if x then y else z :: T' - 'if x then y else z + 1' (NB: '+' is in VARSYM) - -Shift parses as (per longest-parse rule): - 'if x then y else (z -< T)' - 'if x then y else (z :: T)' - 'if x then y else (z + 1)' - -------------------------------------------------------------------------------- - -state 299 contains 1 shift/reduce conflicts. - - rule -> STRING . rule_activation rule_forall infixexp '=' exp - - Conflict: '[' (empty rule_activation reduces) - -We don't know whether the '[' starts the activation or not: it -might be the start of the declaration with the activation being -empty. --SDM 1/4/2002 - -Example ambiguity: - '{-# RULE [0] f = ... #-}' - -We parse this as having a [0] rule activation for rewriting 'f', rather -a rule instructing how to rewrite the expression '[0] f'. - -------------------------------------------------------------------------------- - -state 309 contains 1 shift/reduce conflict. - - *** type -> btype . - type -> btype . '->' ctype - - Conflict: '->' - -Same as state 50 but without contexts. - -------------------------------------------------------------------------------- - -state 348 contains 1 shift/reduce conflicts. - - tup_exprs -> commas . tup_tail - sysdcon_nolist -> '(' commas . ')' - commas -> commas . ',' - - Conflict: ')' (empty tup_tail reduces) - -A tuple section with NO free variables '(,,)' is indistinguishable -from the Haskell98 data constructor for a tuple. Shift resolves in -favor of sysdcon, which is good because a tuple section will get rejected -if -XTupleSections is not specified. - -------------------------------------------------------------------------------- - -state 402 contains 1 shift/reduce conflicts. - - tup_exprs -> commas . tup_tail - sysdcon_nolist -> '(#' commas . '#)' - commas -> commas . ',' - - Conflict: '#)' (empty tup_tail reduces) - -Same as State 324 for unboxed tuples. - -------------------------------------------------------------------------------- - -state 477 contains 1 shift/reduce conflict. - - oqtycon -> '(' qtyconsym . ')' - *** qtyconop -> qtyconsym . - - Conflict: ')' - -TODO: Why? - -------------------------------------------------------------------------------- - -state 658 contains 1 shift/reduce conflicts. - - *** aexp2 -> ipvar . - dbind -> ipvar . '=' exp - - Conflict: '=' - -Example ambiguity: 'let ?x ...' - -The parser can't tell whether the ?x is the lhs of a normal binding or -an implicit binding. Fortunately, resolving as shift gives it the only -sensible meaning, namely the lhs of an implicit binding. - -------------------------------------------------------------------------------- - -state 731 contains 1 shift/reduce conflicts. - - rule -> STRING rule_activation . rule_forall infixexp '=' exp - - Conflict: 'forall' (empty rule_forall reduces) - -Example ambiguity: '{-# RULES "name" forall = ... #-}' - -'forall' is a valid variable name---we don't know whether -to treat a forall on the input as the beginning of a quantifier -or the beginning of the rule itself. Resolving to shift means -it's always treated as a quantifier, hence the above is disallowed. -This saves explicitly defining a grammar for the rule lhs that -doesn't include 'forall'. - -------------------------------------------------------------------------------- - -state 963 contains 1 shift/reduce conflicts. - - transformqual -> 'then' 'group' . 'using' exp - transformqual -> 'then' 'group' . 'by' exp 'using' exp - *** special_id -> 'group' . - - Conflict: 'by' - -------------------------------------------------------------------------------- - -state 1303 contains 1 shift/reduce conflict. - - *** atype -> tyvar . - tv_bndr -> '(' tyvar . '::' kind ')' - - Conflict: '::' - -TODO: Why? - -------------------------------------------------------------------------------- --- API Annotations --- - -A lot of the productions are now cluttered with calls to -aa,am,ams,amms etc. - -These are helper functions to make sure that the locations of the -various keywords such as do / let / in are captured for use by tools -that want to do source to source conversions, such as refactorers or -structured editors. - -The helper functions are defined at the bottom of this file. - -See - https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations and - https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations -for some background. - -If you modify the parser and want to ensure that the API annotations are processed -correctly, see the README in (REPO)/utils/check-api-annotations for details on -how to set up a test using the check-api-annotations utility, and interpret the -output it generates. - -Note [Parsing lists] ---------------------- -You might be wondering why we spend so much effort encoding our lists this -way: - -importdecls - : importdecls ';' importdecl - | importdecls ';' - | importdecl - | {- empty -} - -This might seem like an awfully roundabout way to declare a list; plus, to add -insult to injury you have to reverse the results at the end. The answer is that -left recursion prevents us from running out of stack space when parsing long -sequences. See: https://www.haskell.org/happy/doc/html/sec-sequences.html for -more guidance. - -By adding/removing branches, you can affect what lists are accepted. Here -are the most common patterns, rewritten as regular expressions for clarity: - - -- Equivalent to: ';'* (x ';'+)* x? (can be empty, permits leading/trailing semis) - xs : xs ';' x - | xs ';' - | x - | {- empty -} - - -- Equivalent to x (';' x)* ';'* (non-empty, permits trailing semis) - xs : xs ';' x - | xs ';' - | x - - -- Equivalent to ';'* alts (';' alts)* ';'* (non-empty, permits leading/trailing semis) - alts : alts1 - | ';' alts - alts1 : alts1 ';' alt - | alts1 ';' - | alt - - -- Equivalent to x (',' x)+ (non-empty, no trailing semis) - xs : x - | x ',' xs - --- ----------------------------------------------------------------------------- - --} - -%token - '_' { L _ ITunderscore } -- Haskell keywords - 'as' { L _ ITas } - 'case' { L _ ITcase } - 'class' { L _ ITclass } - 'data' { L _ ITdata } - 'default' { L _ ITdefault } - 'deriving' { L _ ITderiving } - 'do' { L _ ITdo } - 'else' { L _ ITelse } - 'hiding' { L _ IThiding } - 'if' { L _ ITif } - 'import' { L _ ITimport } - 'in' { L _ ITin } - 'infix' { L _ ITinfix } - 'infixl' { L _ ITinfixl } - 'infixr' { L _ ITinfixr } - 'instance' { L _ ITinstance } - 'let' { L _ ITlet } - 'module' { L _ ITmodule } - 'newtype' { L _ ITnewtype } - 'of' { L _ ITof } - 'qualified' { L _ ITqualified } - 'then' { L _ ITthen } - 'type' { L _ ITtype } - 'where' { L _ ITwhere } - - 'forall' { L _ (ITforall _) } -- GHC extension keywords - 'foreign' { L _ ITforeign } - 'export' { L _ ITexport } - 'label' { L _ ITlabel } - 'dynamic' { L _ ITdynamic } - 'safe' { L _ ITsafe } - 'interruptible' { L _ ITinterruptible } - 'unsafe' { L _ ITunsafe } - 'mdo' { L _ ITmdo } - 'family' { L _ ITfamily } - 'role' { L _ ITrole } - 'stdcall' { L _ ITstdcallconv } - 'ccall' { L _ ITccallconv } - 'capi' { L _ ITcapiconv } - 'prim' { L _ ITprimcallconv } - 'javascript' { L _ ITjavascriptcallconv } - 'proc' { L _ ITproc } -- for arrow notation extension - 'rec' { L _ ITrec } -- for arrow notation extension - 'group' { L _ ITgroup } -- for list transform extension - 'by' { L _ ITby } -- for list transform extension - 'using' { L _ ITusing } -- for list transform extension - 'pattern' { L _ ITpattern } -- for pattern synonyms - 'static' { L _ ITstatic } -- for static pointers extension - 'stock' { L _ ITstock } -- for DerivingStrategies extension - 'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension - - 'unit' { L _ ITunit } - 'signature' { L _ ITsignature } - 'dependency' { L _ ITdependency } - - '{-# INLINE' { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE - '{-# SPECIALISE' { L _ (ITspec_prag _) } - '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _ _) } - '{-# SOURCE' { L _ (ITsource_prag _) } - '{-# RULES' { L _ (ITrules_prag _) } - '{-# CORE' { L _ (ITcore_prag _) } -- hdaume: annotated core - '{-# SCC' { L _ (ITscc_prag _)} - '{-# GENERATED' { L _ (ITgenerated_prag _) } - '{-# DEPRECATED' { L _ (ITdeprecated_prag _) } - '{-# WARNING' { L _ (ITwarning_prag _) } - '{-# UNPACK' { L _ (ITunpack_prag _) } - '{-# NOUNPACK' { L _ (ITnounpack_prag _) } - '{-# ANN' { L _ (ITann_prag _) } - '{-# VECTORISE' { L _ (ITvect_prag _) } - '{-# VECTORISE_SCALAR' { L _ (ITvect_scalar_prag _) } - '{-# NOVECTORISE' { L _ (ITnovect_prag _) } - '{-# MINIMAL' { L _ (ITminimal_prag _) } - '{-# CTYPE' { L _ (ITctype _) } - '{-# OVERLAPPING' { L _ (IToverlapping_prag _) } - '{-# OVERLAPPABLE' { L _ (IToverlappable_prag _) } - '{-# OVERLAPS' { L _ (IToverlaps_prag _) } - '{-# INCOHERENT' { L _ (ITincoherent_prag _) } - '{-# COMPLETE' { L _ (ITcomplete_prag _) } - '#-}' { L _ ITclose_prag } - - '..' { L _ ITdotdot } -- reserved symbols - ':' { L _ ITcolon } - '::' { L _ (ITdcolon _) } - '=' { L _ ITequal } - '\\' { L _ ITlam } - 'lcase' { L _ ITlcase } - '|' { L _ ITvbar } - '<-' { L _ (ITlarrow _) } - '->' { L _ (ITrarrow _) } - '@' { L _ ITat } - '~' { L _ ITtilde } - '~#' { L _ ITtildehsh } - '=>' { L _ (ITdarrow _) } - '-' { L _ ITminus } - '!' { L _ ITbang } - '-<' { L _ (ITlarrowtail _) } -- for arrow notation - '>-' { L _ (ITrarrowtail _) } -- for arrow notation - '-<<' { L _ (ITLarrowtail _) } -- for arrow notation - '>>-' { L _ (ITRarrowtail _) } -- for arrow notation - '.' { L _ ITdot } - TYPEAPP { L _ ITtypeApp } - - '{' { L _ ITocurly } -- special symbols - '}' { L _ ITccurly } - vocurly { L _ ITvocurly } -- virtual open curly (from layout) - vccurly { L _ ITvccurly } -- virtual close curly (from layout) - '[' { L _ ITobrack } - ']' { L _ ITcbrack } - '[:' { L _ ITopabrack } - ':]' { L _ ITcpabrack } - '(' { L _ IToparen } - ')' { L _ ITcparen } - '(#' { L _ IToubxparen } - '#)' { L _ ITcubxparen } - '(|' { L _ (IToparenbar _) } - '|)' { L _ (ITcparenbar _) } - ';' { L _ ITsemi } - ',' { L _ ITcomma } - '`' { L _ ITbackquote } - SIMPLEQUOTE { L _ ITsimpleQuote } -- 'x - - VARID { L _ (ITvarid _) } -- identifiers - CONID { L _ (ITconid _) } - VARSYM { L _ (ITvarsym _) } - CONSYM { L _ (ITconsym _) } - QVARID { L _ (ITqvarid _) } - QCONID { L _ (ITqconid _) } - QVARSYM { L _ (ITqvarsym _) } - QCONSYM { L _ (ITqconsym _) } - - IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension - LABELVARID { L _ (ITlabelvarid _) } - - CHAR { L _ (ITchar _ _) } - STRING { L _ (ITstring _ _) } - INTEGER { L _ (ITinteger _ _) } - RATIONAL { L _ (ITrational _) } - - PRIMCHAR { L _ (ITprimchar _ _) } - PRIMSTRING { L _ (ITprimstring _ _) } - PRIMINTEGER { L _ (ITprimint _ _) } - PRIMWORD { L _ (ITprimword _ _) } - PRIMFLOAT { L _ (ITprimfloat _) } - PRIMDOUBLE { L _ (ITprimdouble _) } - - DOCNEXT { L _ (ITdocCommentNext _) } - DOCPREV { L _ (ITdocCommentPrev _) } - DOCNAMED { L _ (ITdocCommentNamed _) } - DOCSECTION { L _ (ITdocSection _ _) } - --- Template Haskell -'[|' { L _ (ITopenExpQuote _ _) } -'[p|' { L _ ITopenPatQuote } -'[t|' { L _ ITopenTypQuote } -'[d|' { L _ ITopenDecQuote } -'|]' { L _ (ITcloseQuote _) } -'[||' { L _ (ITopenTExpQuote _) } -'||]' { L _ ITcloseTExpQuote } -TH_ID_SPLICE { L _ (ITidEscape _) } -- $x -'$(' { L _ ITparenEscape } -- $( exp ) -TH_ID_TY_SPLICE { L _ (ITidTyEscape _) } -- $$x -'$$(' { L _ ITparenTyEscape } -- $$( exp ) -TH_TY_QUOTE { L _ ITtyQuote } -- ''T -TH_QUASIQUOTE { L _ (ITquasiQuote _) } -TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } - -%monad { P } { >>= } { return } -%lexer { (lexer True) } { L _ ITeof } -%tokentype { (Located Token) } - --- Exported parsers -%name parseModule module -%name parseSignature signature -%name parseImport importdecl -%name parseStatement stmt -%name parseDeclaration topdecl -%name parseExpression exp -%name parsePattern pat -%name parseTypeSignature sigdecl -%name parseStmt maybe_stmt -%name parseIdentifier identifier -%name parseType ctype -%name parseBackpack backpack -%partial parseHeader header -%% - ------------------------------------------------------------------------------ --- Identifiers; one of the entry points -identifier :: { Located RdrName } - : qvar { $1 } - | qcon { $1 } - | qvarop { $1 } - | qconop { $1 } - | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) - [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] } - ------------------------------------------------------------------------------ --- Backpack stuff - -backpack :: { [LHsUnit PackageName] } - : implicit_top units close { fromOL $2 } - | '{' units '}' { fromOL $2 } - -units :: { OrdList (LHsUnit PackageName) } - : units ';' unit { $1 `appOL` unitOL $3 } - | units ';' { $1 } - | unit { unitOL $1 } - -unit :: { LHsUnit PackageName } - : 'unit' pkgname 'where' unitbody - { sL1 $1 $ HsUnit { hsunitName = $2 - , hsunitBody = fromOL $4 } } - -unitid :: { LHsUnitId PackageName } - : pkgname { sL1 $1 $ HsUnitId $1 [] } - | pkgname '[' msubsts ']' { sLL $1 $> $ HsUnitId $1 (fromOL $3) } - -msubsts :: { OrdList (LHsModuleSubst PackageName) } - : msubsts ',' msubst { $1 `appOL` unitOL $3 } - | msubsts ',' { $1 } - | msubst { unitOL $1 } - -msubst :: { LHsModuleSubst PackageName } - : modid '=' moduleid { sLL $1 $> $ ($1, $3) } - | modid VARSYM modid VARSYM { sLL $1 $> $ ($1, sLL $2 $> $ HsModuleVar $3) } - -moduleid :: { LHsModuleId PackageName } - : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar $2 } - | unitid ':' modid { sLL $1 $> $ HsModuleId $1 $3 } - -pkgname :: { Located PackageName } - : STRING { sL1 $1 $ PackageName (getSTRING $1) } - | litpkgname { sL1 $1 $ PackageName (unLoc $1) } - -litpkgname_segment :: { Located FastString } - : VARID { sL1 $1 $ getVARID $1 } - | CONID { sL1 $1 $ getCONID $1 } - | special_id { $1 } - -litpkgname :: { Located FastString } - : litpkgname_segment { $1 } - -- a bit of a hack, means p - b is parsed same as p-b, enough for now. - | litpkgname_segment '-' litpkgname { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) } - -mayberns :: { Maybe [LRenaming] } - : {- empty -} { Nothing } - | '(' rns ')' { Just (fromOL $2) } - -rns :: { OrdList LRenaming } - : rns ',' rn { $1 `appOL` unitOL $3 } - | rns ',' { $1 } - | rn { unitOL $1 } - -rn :: { LRenaming } - : modid 'as' modid { sLL $1 $> $ Renaming $1 (Just $3) } - | modid { sL1 $1 $ Renaming $1 Nothing } - -unitbody :: { OrdList (LHsUnitDecl PackageName) } - : '{' unitdecls '}' { $2 } - | vocurly unitdecls close { $2 } - -unitdecls :: { OrdList (LHsUnitDecl PackageName) } - : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 } - | unitdecls ';' { $1 } - | unitdecl { unitOL $1 } - -unitdecl :: { LHsUnitDecl PackageName } - : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body - -- XXX not accurate - { sL1 $2 $ DeclD ModuleD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) } - | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body - { sL1 $2 $ DeclD SignatureD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) } - -- NB: MUST have maybedocheader here, otherwise shift-reduce conflict - -- will prevent us from parsing both forms. - | maybedocheader 'module' modid - { sL1 $2 $ DeclD ModuleD $3 Nothing } - | maybedocheader 'signature' modid - { sL1 $2 $ DeclD SignatureD $3 Nothing } - | 'dependency' unitid mayberns - { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2 - , idModRenaming = $3 - , idSignatureInclude = False }) } - | 'dependency' 'signature' unitid - { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3 - , idModRenaming = Nothing - , idSignatureInclude = True }) } - ------------------------------------------------------------------------------ --- Module Header - --- The place for module deprecation is really too restrictive, but if it --- was allowed at its natural place just before 'module', we get an ugly --- s/r conflict with the second alternative. Another solution would be the --- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice, --- either, and DEPRECATED is only expected to be used by people who really --- know what they are doing. :-) - -signature :: { Located (HsModule RdrName) } - : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body - {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) - (snd $ snd $7) $4 $1) - ) - ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) } - -module :: { Located (HsModule RdrName) } - : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body - {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) - (snd $ snd $7) $4 $1) - ) - ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) } - | body2 - {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule Nothing Nothing - (fst $ snd $1) (snd $ snd $1) Nothing Nothing)) - (fst $1) } - -maybedocheader :: { Maybe LHsDocString } - : moduleheader { $1 } - | {- empty -} { Nothing } - -missing_module_keyword :: { () } - : {- empty -} {% pushModuleContext } - -implicit_top :: { () } - : {- empty -} {% pushModuleContext } - -maybemodwarning :: { Maybe (Located WarningTxt) } - : '{-# DEPRECATED' strings '#-}' - {% ajs (Just (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2))) - (mo $1:mc $3: (fst $ unLoc $2)) } - | '{-# WARNING' strings '#-}' - {% ajs (Just (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2))) - (mo $1:mc $3 : (fst $ unLoc $2)) } - | {- empty -} { Nothing } - -body :: { ([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName])) } - : '{' top '}' { (moc $1:mcc $3:(fst $2) - , snd $2) } - | vocurly top close { (fst $2, snd $2) } - -body2 :: { ([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName])) } - : '{' top '}' { (moc $1:mcc $3 - :(fst $2), snd $2) } - | missing_module_keyword top close { ([],snd $2) } - - -top :: { ([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName])) } - : semis top1 { ($1, $2) } - -top1 :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } - : importdecls_semi topdecls_semi { (reverse $1, cvTopDecls $2) } - | importdecls_semi topdecls { (reverse $1, cvTopDecls $2) } - | importdecls { (reverse $1, []) } - ------------------------------------------------------------------------------ --- Module declaration & imports only - -header :: { Located (HsModule RdrName) } - : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body - {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 - )) [mj AnnModule $2,mj AnnWhere $6] } - | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body - {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 - )) [mj AnnModule $2,mj AnnWhere $6] } - | header_body2 - {% fileSrcSpan >>= \ loc -> - return (L loc (HsModule Nothing Nothing $1 [] Nothing - Nothing)) } - -header_body :: { [LImportDecl RdrName] } - : '{' header_top { $2 } - | vocurly header_top { $2 } - -header_body2 :: { [LImportDecl RdrName] } - : '{' header_top { $2 } - | missing_module_keyword header_top { $2 } - -header_top :: { [LImportDecl RdrName] } - : semis header_top_importdecls { $2 } - -header_top_importdecls :: { [LImportDecl RdrName] } - : importdecls_semi { $1 } - | importdecls { $1 } - ------------------------------------------------------------------------------ --- The Export List - -maybeexports :: { (Maybe (Located [LIE RdrName])) } - : '(' exportlist ')' {% ams (sLL $1 $> ()) [mop $1,mcp $3] >> - return (Just (sLL $1 $> (fromOL $2))) } - | {- empty -} { Nothing } - -exportlist :: { OrdList (LIE RdrName) } - : expdoclist ',' expdoclist {% addAnnotation (oll $1) AnnComma (gl $2) - >> return ($1 `appOL` $3) } - | exportlist1 { $1 } - -exportlist1 :: { OrdList (LIE RdrName) } - : expdoclist export expdoclist ',' exportlist1 - {% (addAnnotation (oll ($1 `appOL` $2 `appOL` $3)) - AnnComma (gl $4) ) >> - return ($1 `appOL` $2 `appOL` $3 `appOL` $5) } - | expdoclist export expdoclist { $1 `appOL` $2 `appOL` $3 } - | expdoclist { $1 } - -expdoclist :: { OrdList (LIE RdrName) } - : exp_doc expdoclist { $1 `appOL` $2 } - | {- empty -} { nilOL } - -exp_doc :: { OrdList (LIE RdrName) } - : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) } - | docnamed { unitOL (sL1 $1 (IEDocNamed ((fst . unLoc) $1))) } - | docnext { unitOL (sL1 $1 (IEDoc (unLoc $1))) } - - - -- No longer allow things like [] and (,,,) to be exported - -- They are built in syntax, always available -export :: { OrdList (LIE RdrName) } - : qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2) - >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) } - | 'module' modid {% amsu (sLL $1 $> (IEModuleContents $2)) - [mj AnnModule $1] } - | 'pattern' qcon {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $2)))) - [mj AnnPattern $1] } - -export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } - : {- empty -} { sL0 ([],ImpExpAbs) } - | '(' qcnames ')' {% mkImpExpSubSpec (reverse (snd $2)) - >>= \(as,ie) -> return $ sLL $1 $> - (as ++ [mop $1,mcp $3] ++ fst $2, ie) } - - -qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) } - : {- empty -} { ([],[]) } - | qcnames1 { $1 } - -qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list - : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of - l@(L _ ImpExpQcWildcard) -> - return ([mj AnnComma $2, mj AnnDotdot l] - ,(snd (unLoc $3) : snd $1)) - l -> (ams (head (snd $1)) [mj AnnComma $2] >> - return (fst $1 ++ fst (unLoc $3), - snd (unLoc $3) : snd $1)) } - - - -- Annotations re-added in mkImpExpSubSpec - | qcname_ext_w_wildcard { (fst (unLoc $1),[snd (unLoc $1)]) } - --- Variable, data constructor or wildcard --- or tagged type constructor -qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) } - : qcname_ext { sL1 $1 ([],$1) } - | '..' { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard) } - -qcname_ext :: { Located ImpExpQcSpec } - : qcname { sL1 $1 (ImpExpQcName $1) } - | 'type' oqtycon {% do { n <- mkTypeImpExp $2 - ; ams (sLL $1 $> (ImpExpQcType n)) - [mj AnnType $1] } } - -qcname :: { Located RdrName } -- Variable or type constructor - : qvar { $1 } -- Things which look like functions - -- Note: This includes record selectors but - -- also (-.->), see #11432 - | oqtycon_no_varcon { $1 } -- see Note [Type constructors in export list] - ------------------------------------------------------------------------------ --- Import Declarations - --- importdecls and topdecls must contain at least one declaration; --- top handles the fact that these may be optional. - --- One or more semicolons -semis1 :: { [AddAnn] } -semis1 : semis1 ';' { mj AnnSemi $2 : $1 } - | ';' { [mj AnnSemi $1] } - --- Zero or more semicolons -semis :: { [AddAnn] } -semis : semis ';' { mj AnnSemi $2 : $1 } - | {- empty -} { [] } - --- No trailing semicolons, non-empty -importdecls :: { [LImportDecl RdrName] } -importdecls - : importdecls_semi importdecl - { $2 : $1 } - --- May have trailing semicolons, can be empty -importdecls_semi :: { [LImportDecl RdrName] } -importdecls_semi - : importdecls_semi importdecl semis1 - {% ams $2 $3 >> return ($2 : $1) } - | {- empty -} { [] } - -importdecl :: { LImportDecl RdrName } - : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec - {% ams (L (comb4 $1 $6 (snd $7) $8) $ - ImportDecl { ideclSourceSrc = snd $ fst $2 - , ideclName = $6, ideclPkgQual = snd $5 - , ideclSource = snd $2, ideclSafe = snd $3 - , ideclQualified = snd $4, ideclImplicit = False - , ideclAs = unLoc (snd $7) - , ideclHiding = unLoc $8 }) - ((mj AnnImport $1 : (fst $ fst $2) ++ fst $3 ++ fst $4 - ++ fst $5 ++ fst $7)) } - -maybe_src :: { (([AddAnn],SourceText),IsBootInterface) } - : '{-# SOURCE' '#-}' { (([mo $1,mc $2],getSOURCE_PRAGs $1) - ,True) } - | {- empty -} { (([],NoSourceText),False) } - -maybe_safe :: { ([AddAnn],Bool) } - : 'safe' { ([mj AnnSafe $1],True) } - | {- empty -} { ([],False) } - -maybe_pkg :: { ([AddAnn],Maybe StringLiteral) } - : STRING {% let pkgFS = getSTRING $1 in - if looksLikePackageName (unpackFS pkgFS) - then return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) - else parseErrorSDoc (getLoc $1) $ vcat [ - text "parse error" <> colon <+> quotes (ppr pkgFS), - text "Version number or non-alphanumeric" <+> - text "character in package name"] } - | {- empty -} { ([],Nothing) } - -optqualified :: { ([AddAnn],Bool) } - : 'qualified' { ([mj AnnQualified $1],True) } - | {- empty -} { ([],False) } - -maybeas :: { ([AddAnn],Located (Maybe (Located ModuleName))) } - : 'as' modid { ([mj AnnAs $1] - ,sLL $1 $> (Just $2)) } - | {- empty -} { ([],noLoc Nothing) } - -maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) } - : impspec {% let (b, ie) = unLoc $1 in - checkImportSpec ie - >>= \checkedIe -> - return (L (gl $1) (Just (b, checkedIe))) } - | {- empty -} { noLoc Nothing } - -impspec :: { Located (Bool, Located [LIE RdrName]) } - : '(' exportlist ')' {% ams (sLL $1 $> (False, - sLL $1 $> $ fromOL $2)) - [mop $1,mcp $3] } - | 'hiding' '(' exportlist ')' {% ams (sLL $1 $> (True, - sLL $1 $> $ fromOL $3)) - [mj AnnHiding $1,mop $2,mcp $4] } - ------------------------------------------------------------------------------ --- Fixity Declarations - -prec :: { Located (SourceText,Int) } - : {- empty -} { noLoc (NoSourceText,9) } - | INTEGER - {% checkPrecP (sL1 $1 (getINTEGERs $1,fromInteger (getINTEGER $1))) } - -infix :: { Located FixityDirection } - : 'infix' { sL1 $1 InfixN } - | 'infixl' { sL1 $1 InfixL } - | 'infixr' { sL1 $1 InfixR } - -ops :: { Located (OrdList (Located RdrName)) } - : ops ',' op {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))} - | op { sL1 $1 (unitOL $1) } - ------------------------------------------------------------------------------ --- Top-Level Declarations - --- No trailing semicolons, non-empty -topdecls :: { OrdList (LHsDecl RdrName) } - : topdecls_semi topdecl { $1 `snocOL` $2 } - --- May have trailing semicolons, can be empty -topdecls_semi :: { OrdList (LHsDecl RdrName) } - : topdecls_semi topdecl semis1 {% ams $2 $3 >> return ($1 `snocOL` $2) } - | {- empty -} { nilOL } - -topdecl :: { LHsDecl RdrName } - : cl_decl { sL1 $1 (TyClD (unLoc $1)) } - | ty_decl { sL1 $1 (TyClD (unLoc $1)) } - | inst_decl { sL1 $1 (InstD (unLoc $1)) } - | stand_alone_deriving { sLL $1 $> (DerivD (unLoc $1)) } - | role_annot { sL1 $1 (RoleAnnotD (unLoc $1)) } - | 'default' '(' comma_types0 ')' {% ams (sLL $1 $> (DefD (DefaultDecl $3))) - [mj AnnDefault $1 - ,mop $2,mcp $4] } - | 'foreign' fdecl {% ams (sLL $1 $> (snd $ unLoc $2)) - (mj AnnForeign $1:(fst $ unLoc $2)) } - | '{-# DEPRECATED' deprecations '#-}' {% ams (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2))) - [mo $1,mc $3] } - | '{-# WARNING' warnings '#-}' {% ams (sLL $1 $> $ WarningD (Warnings (getWARNING_PRAGs $1) (fromOL $2))) - [mo $1,mc $3] } - | '{-# RULES' rules '#-}' {% ams (sLL $1 $> $ RuleD (HsRules (getRULES_PRAGs $1) (fromOL $2))) - [mo $1,mc $3] } - | '{-# VECTORISE' qvar '=' exp '#-}' {% ams (sLL $1 $> $ VectD (HsVect (getVECT_PRAGs $1) $2 $4)) - [mo $1,mj AnnEqual $3 - ,mc $5] } - | '{-# NOVECTORISE' qvar '#-}' {% ams (sLL $1 $> $ VectD (HsNoVect (getNOVECT_PRAGs $1) $2)) - [mo $1,mc $3] } - | '{-# VECTORISE' 'type' gtycon '#-}' - {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 Nothing)) - [mo $1,mj AnnType $2,mc $4] } - - | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}' - {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 Nothing)) - [mo $1,mj AnnType $2,mc $4] } - - | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}' - {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 (Just $5))) - [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] } - | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}' - {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 (Just $5))) - [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] } - - | '{-# VECTORISE' 'class' gtycon '#-}' - {% ams (sLL $1 $> $ VectD (HsVectClassIn (getVECT_PRAGs $1) $3)) - [mo $1,mj AnnClass $2,mc $4] } - | annotation { $1 } - | decl_no_th { $1 } - - -- Template Haskell Extension - -- The $(..) form is one possible form of infixexp - -- but we treat an arbitrary expression just as if - -- it had a $(..) wrapped around it - | infixexp_top { sLL $1 $> $ mkSpliceDecl $1 } - --- Type classes --- -cl_decl :: { LTyClDecl RdrName } - : 'class' tycl_hdr fds where_cls - {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4)) - (mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) } - --- Type declarations (toplevel) --- -ty_decl :: { LTyClDecl RdrName } - -- ordinary type synonyms - : 'type' type '=' ctypedoc - -- Note ctype, not sigtype, on the right of '=' - -- We allow an explicit for-all but we don't insert one - -- in type Foo a = (b,b) - -- Instead we just say b is out of scope - -- - -- Note the use of type for the head; this allows - -- infix type constructors to be declared - {% amms (mkTySynonym (comb2 $1 $4) $2 $4) - [mj AnnType $1,mj AnnEqual $3] } - - -- type family declarations - | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info - where_type_family - -- Note the use of type for the head; this allows - -- infix type constructors to be declared - {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $6) $3 - (snd $ unLoc $4) (snd $ unLoc $5)) - (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4) - ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) } - - -- ordinary data type or newtype declaration - | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings - {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3 - Nothing (reverse (snd $ unLoc $4)) - (fmap reverse $5)) - -- We need the location on tycl_hdr in case - -- constrs and deriving are both empty - ((fst $ unLoc $1):(fst $ unLoc $4)) } - - -- ordinary GADT declaration - | data_or_newtype capi_ctype tycl_hdr opt_kind_sig - gadt_constrlist - maybe_derivings - {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3 - (snd $ unLoc $4) (snd $ unLoc $5) - (fmap reverse $6) ) - -- We need the location on tycl_hdr in case - -- constrs and deriving are both empty - ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } - - -- data/newtype family - | 'data' 'family' type opt_datafam_kind_sig - {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 - (snd $ unLoc $4) Nothing) - (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) } - -inst_decl :: { LInstDecl RdrName } - : 'instance' overlap_pragma inst_type where_inst - {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4) - ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds - , cid_sigs = mkClassOpSigs sigs - , cid_tyfam_insts = ats - , cid_overlap_mode = $2 - , cid_datafam_insts = adts } - ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_inst = cid })) - (mj AnnInstance $1 : (fst $ unLoc $4)) } } - - -- type instance declarations - | 'type' 'instance' ty_fam_inst_eqn - {% ams $3 (fst $ unLoc $3) - >> amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)) - (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } - - -- data/newtype instance declaration - | data_or_newtype 'instance' capi_ctype tycl_hdr constrs - maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4 - Nothing (reverse (snd $ unLoc $5)) - (fmap reverse $6)) - ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) } - - -- GADT instance declaration - | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig - gadt_constrlist - maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4 - (snd $ unLoc $5) (snd $ unLoc $6) - (fmap reverse $7)) - ((fst $ unLoc $1):mj AnnInstance $2 - :(fst $ unLoc $5)++(fst $ unLoc $6)) } - -overlap_pragma :: { Maybe (Located OverlapMode) } - : '{-# OVERLAPPABLE' '#-}' {% ajs (Just (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))) - [mo $1,mc $2] } - | '{-# OVERLAPPING' '#-}' {% ajs (Just (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))) - [mo $1,mc $2] } - | '{-# OVERLAPS' '#-}' {% ajs (Just (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))) - [mo $1,mc $2] } - | '{-# INCOHERENT' '#-}' {% ajs (Just (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))) - [mo $1,mc $2] } - | {- empty -} { Nothing } - -deriv_strategy :: { Maybe (Located DerivStrategy) } - : 'stock' {% ajs (Just (sL1 $1 StockStrategy)) - [mj AnnStock $1] } - | 'anyclass' {% ajs (Just (sL1 $1 AnyclassStrategy)) - [mj AnnAnyclass $1] } - | 'newtype' {% ajs (Just (sL1 $1 NewtypeStrategy)) - [mj AnnNewtype $1] } - | {- empty -} { Nothing } - --- Injective type families - -opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn RdrName)) } - : {- empty -} { noLoc ([], Nothing) } - | '|' injectivity_cond { sLL $1 $> ([mj AnnVbar $1] - , Just ($2)) } - -injectivity_cond :: { LInjectivityAnn RdrName } - : tyvarid '->' inj_varids - {% ams (sLL $1 $> (InjectivityAnn $1 (reverse (unLoc $3)))) - [mu AnnRarrow $2] } - -inj_varids :: { Located [Located RdrName] } - : inj_varids tyvarid { sLL $1 $> ($2 : unLoc $1) } - | tyvarid { sLL $1 $> [$1] } - --- Closed type families - -where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) } - : {- empty -} { noLoc ([],OpenTypeFamily) } - | 'where' ty_fam_inst_eqn_list - { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) - ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) } - -ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn RdrName]) } - : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3] - ,Just (unLoc $2)) } - | vocurly ty_fam_inst_eqns close { let L loc _ = $2 in - L loc ([],Just (unLoc $2)) } - | '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2 - ,mcc $3],Nothing) } - | vocurly '..' close { let L loc _ = $2 in - L loc ([mj AnnDotdot $2],Nothing) } - -ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] } - : ty_fam_inst_eqns ';' ty_fam_inst_eqn - {% asl (unLoc $1) $2 (snd $ unLoc $3) - >> ams $3 (fst $ unLoc $3) - >> return (sLL $1 $> ((snd $ unLoc $3) : unLoc $1)) } - | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) - >> return (sLL $1 $> (unLoc $1)) } - | ty_fam_inst_eqn {% ams $1 (fst $ unLoc $1) - >> return (sLL $1 $> [snd $ unLoc $1]) } - | {- empty -} { noLoc [] } - -ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn RdrName) } - : type '=' ctype - -- Note the use of type for the head; this allows - -- infix type constructors and type patterns - {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3 - ; return (sLL $1 $> (mj AnnEqual $2:ann, sLL $1 $> eqn)) } } - --- Associated type family declarations --- --- * They have a different syntax than on the toplevel (no family special --- identifier). --- --- * They also need to be separate from instances; otherwise, data family --- declarations without a kind signature cause parsing conflicts with empty --- data declarations. --- -at_decl_cls :: { LHsDecl RdrName } - : -- data family declarations, with optional 'family' keyword - 'data' opt_family type opt_datafam_kind_sig - {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3 - (snd $ unLoc $4) Nothing)) - (mj AnnData $1:$2++(fst $ unLoc $4)) } - - -- type family declarations, with optional 'family' keyword - -- (can't use opt_instance because you get shift/reduce errors - | 'type' type opt_at_kind_inj_sig - {% amms (liftM mkTyClD - (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2 - (fst . snd $ unLoc $3) - (snd . snd $ unLoc $3))) - (mj AnnType $1:(fst $ unLoc $3)) } - | 'type' 'family' type opt_at_kind_inj_sig - {% amms (liftM mkTyClD - (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3 - (fst . snd $ unLoc $4) - (snd . snd $ unLoc $4))) - (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) } - - -- default type instances, with optional 'instance' keyword - | 'type' ty_fam_inst_eqn - {% ams $2 (fst $ unLoc $2) >> - amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2))) - (mj AnnType $1:(fst $ unLoc $2)) } - | 'type' 'instance' ty_fam_inst_eqn - {% ams $3 (fst $ unLoc $3) >> - amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))) - (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } - -opt_family :: { [AddAnn] } - : {- empty -} { [] } - | 'family' { [mj AnnFamily $1] } - --- Associated type instances --- -at_decl_inst :: { LInstDecl RdrName } - -- type instance declarations - : 'type' ty_fam_inst_eqn - -- Note the use of type for the head; this allows - -- infix type constructors and type patterns - {% ams $2 (fst $ unLoc $2) >> - amms (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2)) - (mj AnnType $1:(fst $ unLoc $2)) } - - -- data/newtype instance declaration - | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3 - Nothing (reverse (snd $ unLoc $4)) - (fmap reverse $5)) - ((fst $ unLoc $1):(fst $ unLoc $4)) } - - -- GADT instance declaration - | data_or_newtype capi_ctype tycl_hdr opt_kind_sig - gadt_constrlist - maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 - $3 (snd $ unLoc $4) (snd $ unLoc $5) - (fmap reverse $6)) - ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } - -data_or_newtype :: { Located (AddAnn, NewOrData) } - : 'data' { sL1 $1 (mj AnnData $1,DataType) } - | 'newtype' { sL1 $1 (mj AnnNewtype $1,NewType) } - --- Family result/return kind signatures - -opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind RdrName)) } - : { noLoc ([] , Nothing) } - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], Just $2) } - -opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) } - : { noLoc ([] , noLoc NoSig )} - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))} - -opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) } - : { noLoc ([] , noLoc NoSig )} - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))} - | '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig $2))} - -opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig RdrName - , Maybe (LInjectivityAnn RdrName)))} - : { noLoc ([], (noLoc NoSig, Nothing)) } - | '::' kind { sLL $1 $> ( [mu AnnDcolon $1] - , (sLL $2 $> (KindSig $2), Nothing)) } - | '=' tv_bndr '|' injectivity_cond - { sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3] - , (sLL $1 $2 (TyVarSig $2), Just $4))} - --- tycl_hdr parses the header of a class or data type decl, --- which takes the form --- T a b --- Eq a => T a --- (Eq a, Ord b) => T a b --- T Int [a] -- for associated types --- Rather a lot of inlining here, else we get reduce/reduce errors -tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } - : context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) - >> (return (sLL $1 $> (Just $1, $3))) - } - | type { sL1 $1 (Nothing, $1) } - -capi_ctype :: { Maybe (Located CType) } -capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2))) - (getSTRINGs $3,getSTRING $3)))) - [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] } - - | '{-# CTYPE' STRING '#-}' - {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))) - [mo $1,mj AnnVal $2,mc $3] } - - | { Nothing } - ------------------------------------------------------------------------------ --- Stand-alone deriving - --- Glasgow extension: stand-alone deriving declarations -stand_alone_deriving :: { LDerivDecl RdrName } - : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type - {% do { let { err = text "in the stand-alone deriving instance" - <> colon <+> quotes (ppr $5) } - ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4)) - [mj AnnDeriving $1, mj AnnInstance $3] } } - ------------------------------------------------------------------------------ --- Role annotations - -role_annot :: { LRoleAnnotDecl RdrName } -role_annot : 'type' 'role' oqtycon maybe_roles - {% amms (mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4))) - [mj AnnType $1,mj AnnRole $2] } - --- Reversed! -maybe_roles :: { Located [Located (Maybe FastString)] } -maybe_roles : {- empty -} { noLoc [] } - | roles { $1 } - -roles :: { Located [Located (Maybe FastString)] } -roles : role { sLL $1 $> [$1] } - | roles role { sLL $1 $> $ $2 : unLoc $1 } - --- read it in as a varid for better error messages -role :: { Located (Maybe FastString) } -role : VARID { sL1 $1 $ Just $ getVARID $1 } - | '_' { sL1 $1 Nothing } - --- Pattern synonyms - --- Glasgow extension: pattern synonyms -pattern_synonym_decl :: { LHsDecl RdrName } - : 'pattern' pattern_synonym_lhs '=' pat - {% let (name, args,as ) = $2 in - ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 - ImplicitBidirectional) - (as ++ [mj AnnPattern $1, mj AnnEqual $3]) - } - - | 'pattern' pattern_synonym_lhs '<-' pat - {% let (name, args, as) = $2 in - ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional) - (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) } - - | 'pattern' pattern_synonym_lhs '<-' pat where_decls - {% do { let (name, args, as) = $2 - ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5) - ; ams (sLL $1 $> . ValD $ - mkPatSynBind name args $4 (ExplicitBidirectional mg)) - (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) ) - }} - -pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) } - : con vars0 { ($1, PrefixPatSyn $2, []) } - | varid conop varid { ($2, InfixPatSyn $1 $3, []) } - | con '{' cvars1 '}' { ($1, RecordPatSyn $3, [moc $2, mcc $4] ) } - -vars0 :: { [Located RdrName] } - : {- empty -} { [] } - | varid vars0 { $1 : $2 } - -cvars1 :: { [RecordPatSynField (Located RdrName)] } - : varid { [RecordPatSynField $1 $1] } - | varid ',' cvars1 {% addAnnotation (getLoc $1) AnnComma (getLoc $2) >> - return ((RecordPatSynField $1 $1) : $3 )} - -where_decls :: { Located ([AddAnn] - , Located (OrdList (LHsDecl RdrName))) } - : 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2 - :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) } - | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) - ,sL1 $3 (snd $ unLoc $3)) } - -pattern_synonym_sig :: { LSig RdrName } - : 'pattern' con_list '::' sigtypedoc - {% ams (sLL $1 $> $ PatSynSig (unLoc $2) (mkLHsSigType $4)) - [mj AnnPattern $1, mu AnnDcolon $3] } - ------------------------------------------------------------------------------ --- Nested declarations - --- Declaration in class bodies --- -decl_cls :: { LHsDecl RdrName } -decl_cls : at_decl_cls { $1 } - | decl { $1 } - - -- A 'default' signature used with the generic-programming extension - | 'default' infixexp '::' sigtypedoc - {% do { v <- checkValSigLhs $2 - ; let err = text "in default signature" <> colon <+> - quotes (ppr $2) - ; ams (sLL $1 $> $ SigD $ ClassOpSig True [v] $ mkLHsSigType $4) - [mj AnnDefault $1,mu AnnDcolon $3] } } - -decls_cls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed - : decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - , unitOL $3)) - else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] - >> return (sLL $1 $> (fst $ unLoc $1 - ,(snd $ unLoc $1) `appOL` unitOL $3)) } - | decls_cls ';' {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,snd $ unLoc $1)) - else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] - >> return (sLL $1 $> (unLoc $1)) } - | decl_cls { sL1 $1 ([], unitOL $1) } - | {- empty -} { noLoc ([],nilOL) } - -decllist_cls - :: { Located ([AddAnn] - , OrdList (LHsDecl RdrName)) } -- Reversed - : '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) - ,snd $ unLoc $2) } - | vocurly decls_cls close { $2 } - --- Class body --- -where_cls :: { Located ([AddAnn] - ,(OrdList (LHsDecl RdrName))) } -- Reversed - -- No implicit parameters - -- May have type declarations - : 'where' decllist_cls { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) - ,snd $ unLoc $2) } - | {- empty -} { noLoc ([],nilOL) } - --- Declarations in instance bodies --- -decl_inst :: { Located (OrdList (LHsDecl RdrName)) } -decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD (unLoc $1)))) } - | decl { sLL $1 $> (unitOL $1) } - -decls_inst :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed - : decls_inst ';' decl_inst {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - , unLoc $3)) - else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return - (sLL $1 $> (fst $ unLoc $1 - ,(snd $ unLoc $1) `appOL` unLoc $3)) } - | decls_inst ';' {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,snd $ unLoc $1)) - else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return (sLL $1 $> (unLoc $1)) } - | decl_inst { sL1 $1 ([],unLoc $1) } - | {- empty -} { noLoc ([],nilOL) } - -decllist_inst - :: { Located ([AddAnn] - , OrdList (LHsDecl RdrName)) } -- Reversed - : '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) } - | vocurly decls_inst close { L (gl $2) (unLoc $2) } - --- Instance body --- -where_inst :: { Located ([AddAnn] - , OrdList (LHsDecl RdrName)) } -- Reversed - -- No implicit parameters - -- May have type declarations - : 'where' decllist_inst { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) - ,(snd $ unLoc $2)) } - | {- empty -} { noLoc ([],nilOL) } - --- Declarations in binding groups other than classes and instances --- -decls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } - : decls ';' decl {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - , unitOL $3)) - else do ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return ( - let { this = unitOL $3; - rest = snd $ unLoc $1; - these = rest `appOL` this } - in rest `seq` this `seq` these `seq` - (sLL $1 $> (fst $ unLoc $1,these))) } - | decls ';' {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> ((mj AnnSemi $2:(fst $ unLoc $1) - ,snd $ unLoc $1))) - else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return (sLL $1 $> (unLoc $1)) } - | decl { sL1 $1 ([], unitOL $1) } - | {- empty -} { noLoc ([],nilOL) } - -decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl RdrName))) } - : '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) - ,sL1 $2 $ snd $ unLoc $2) } - | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } - --- Binding groups other than those of class and instance declarations --- -binds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) } - -- May have implicit parameters - -- No type declarations - : decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1) - ; return (sL1 $1 (fst $ unLoc $1 - ,sL1 $1 $ HsValBinds val_binds)) } } - - | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] - ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2) - emptyTcEvBinds)) } - - | vocurly dbinds close { L (getLoc $2) ([] - ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2) - emptyTcEvBinds)) } - - -wherebinds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) } - -- May have implicit parameters - -- No type declarations - : 'where' binds { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2) - ,snd $ unLoc $2) } - | {- empty -} { noLoc ([],noLoc emptyLocalBinds) } - - ------------------------------------------------------------------------------ --- Transformation Rules - -rules :: { OrdList (LRuleDecl RdrName) } - : rules ';' rule {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return ($1 `snocOL` $3) } - | rules ';' {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return $1 } - | rule { unitOL $1 } - | {- empty -} { nilOL } - -rule :: { LRuleDecl RdrName } - : STRING rule_activation rule_forall infixexp '=' exp - {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRINGs $1,getSTRING $1)) - ((snd $2) `orElse` AlwaysActive) - (snd $3) $4 placeHolderNames $6 - placeHolderNames)) - (mj AnnEqual $5 : (fst $2) ++ (fst $3)) } - --- Rules can be specified to be NeverActive, unlike inline/specialize pragmas -rule_activation :: { ([AddAnn],Maybe Activation) } - : {- empty -} { ([],Nothing) } - | rule_explicit_activation { (fst $1,Just (snd $1)) } - -rule_explicit_activation :: { ([AddAnn] - ,Activation) } -- In brackets - : '[' INTEGER ']' { ([mos $1,mj AnnVal $2,mcs $3] - ,ActiveAfter (getINTEGERs $2) (fromInteger (getINTEGER $2))) } - | '[' '~' INTEGER ']' { ([mos $1,mj AnnTilde $2,mj AnnVal $3,mcs $4] - ,ActiveBefore (getINTEGERs $3) (fromInteger (getINTEGER $3))) } - | '[' '~' ']' { ([mos $1,mj AnnTilde $2,mcs $3] - ,NeverActive) } - -rule_forall :: { ([AddAnn],[LRuleBndr RdrName]) } - : 'forall' rule_var_list '.' { ([mu AnnForall $1,mj AnnDot $3],$2) } - | {- empty -} { ([],[]) } - -rule_var_list :: { [LRuleBndr RdrName] } - : rule_var { [$1] } - | rule_var rule_var_list { $1 : $2 } - -rule_var :: { LRuleBndr RdrName } - : varid { sLL $1 $> (RuleBndr $1) } - | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig $2 - (mkLHsSigWcType $4))) - [mop $1,mu AnnDcolon $3,mcp $5] } - ------------------------------------------------------------------------------ --- Warnings and deprecations (c.f. rules) - -warnings :: { OrdList (LWarnDecl RdrName) } - : warnings ';' warning {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return ($1 `appOL` $3) } - | warnings ';' {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return $1 } - | warning { $1 } - | {- empty -} { nilOL } - --- SUP: TEMPORARY HACK, not checking for `module Foo' -warning :: { OrdList (LWarnDecl RdrName) } - : namelist strings - {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) - (fst $ unLoc $2) } - -deprecations :: { OrdList (LWarnDecl RdrName) } - : deprecations ';' deprecation - {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return ($1 `appOL` $3) } - | deprecations ';' {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return $1 } - | deprecation { $1 } - | {- empty -} { nilOL } - --- SUP: TEMPORARY HACK, not checking for `module Foo' -deprecation :: { OrdList (LWarnDecl RdrName) } - : namelist strings - {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) - (fst $ unLoc $2) } - -strings :: { Located ([AddAnn],[Located StringLiteral]) } - : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) } - | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) } - -stringlist :: { Located (OrdList (Located StringLiteral)) } - : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> (unLoc $1 `snocOL` - (L (gl $3) (getStringLiteral $3)))) } - | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) } - | {- empty -} { noLoc nilOL } - ------------------------------------------------------------------------------ --- Annotations -annotation :: { LHsDecl RdrName } - : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation - (getANN_PRAGs $1) - (ValueAnnProvenance $2) $3)) - [mo $1,mc $4] } - - | '{-# ANN' 'type' tycon aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation - (getANN_PRAGs $1) - (TypeAnnProvenance $3) $4)) - [mo $1,mj AnnType $2,mc $5] } - - | '{-# ANN' 'module' aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation - (getANN_PRAGs $1) - ModuleAnnProvenance $3)) - [mo $1,mj AnnModule $2,mc $4] } - - ------------------------------------------------------------------------------ --- Foreign import and export declarations - -fdecl :: { Located ([AddAnn],HsDecl RdrName) } -fdecl : 'import' callconv safety fspec - {% mkImport $2 $3 (snd $ unLoc $4) >>= \i -> - return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) } - | 'import' callconv fspec - {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3); - return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }} - | 'export' callconv fspec - {% mkExport $2 (snd $ unLoc $3) >>= \i -> - return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) } - -callconv :: { Located CCallConv } - : 'stdcall' { sLL $1 $> StdCallConv } - | 'ccall' { sLL $1 $> CCallConv } - | 'capi' { sLL $1 $> CApiConv } - | 'prim' { sLL $1 $> PrimCallConv} - | 'javascript' { sLL $1 $> JavaScriptCallConv } - -safety :: { Located Safety } - : 'unsafe' { sLL $1 $> PlayRisky } - | 'safe' { sLL $1 $> PlaySafe } - | 'interruptible' { sLL $1 $> PlayInterruptible } - -fspec :: { Located ([AddAnn] - ,(Located StringLiteral, Located RdrName, LHsSigType RdrName)) } - : STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3] - ,(L (getLoc $1) - (getStringLiteral $1), $2, mkLHsSigType $4)) } - | var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2] - ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) } - -- if the entity string is missing, it defaults to the empty string; - -- the meaning of an empty entity string depends on the calling - -- convention - ------------------------------------------------------------------------------ --- Type signatures - -opt_sig :: { ([AddAnn], Maybe (LHsType RdrName)) } - : {- empty -} { ([],Nothing) } - | '::' sigtype { ([mu AnnDcolon $1],Just $2) } - -opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) } - : {- empty -} { ([],Nothing) } - | '::' atype { ([mu AnnDcolon $1],Just $2) } - -opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) } - : {- empty -} { ([], Nothing) } - | '::' gtycon { ([mu AnnDcolon $1], Just $2) } - -sigtype :: { LHsType RdrName } - : ctype { $1 } - -sigtypedoc :: { LHsType RdrName } - : ctypedoc { $1 } - - -sig_vars :: { Located [Located RdrName] } -- Returned in reversed order - : sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1) - AnnComma (gl $2) - >> return (sLL $1 $> ($3 : unLoc $1)) } - | var { sL1 $1 [$1] } - -sigtypes1 :: { (OrdList (LHsSigType RdrName)) } - : sigtype { unitOL (mkLHsSigType $1) } - | sigtype ',' sigtypes1 {% addAnnotation (gl $1) AnnComma (gl $2) - >> return (unitOL (mkLHsSigType $1) `appOL` $3) } - ------------------------------------------------------------------------------ --- Types - -strict_mark :: { Located ([AddAnn],HsSrcBang) } - : strictness { sL1 $1 (let (a, str) = unLoc $1 in (a, HsSrcBang NoSourceText NoSrcUnpack str)) } - | unpackedness { sL1 $1 (let (a, prag, unpk) = unLoc $1 in (a, HsSrcBang prag unpk NoSrcStrict)) } - | unpackedness strictness { sLL $1 $> (let { (a, prag, unpk) = unLoc $1 - ; (a', str) = unLoc $2 } - in (a ++ a', HsSrcBang prag unpk str)) } - -- Although UNPACK with no '!' without StrictData and UNPACK with '~' are illegal, - -- we get a better error message if we parse them here - -strictness :: { Located ([AddAnn], SrcStrictness) } - : '!' { sL1 $1 ([mj AnnBang $1], SrcStrict) } - | '~' { sL1 $1 ([mj AnnTilde $1], SrcLazy) } - -unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) } - : '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getUNPACK_PRAGs $1, SrcUnpack) } - | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) } - --- A ctype is a for-all type -ctype :: { LHsType RdrName } - : 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >> - ams (sLL $1 $> $ - HsForAllTy { hst_bndrs = $2 - , hst_body = $4 }) - [mu AnnForall $1, mj AnnDot $3] } - | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) - >> return (sLL $1 $> $ - HsQualTy { hst_ctxt = $1 - , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3)) - [mu AnnDcolon $2] } - | type { $1 } - ----------------------- --- Notes for 'ctypedoc' --- It would have been nice to simplify the grammar by unifying `ctype` and --- ctypedoc` into one production, allowing comments on types everywhere (and --- rejecting them after parsing, where necessary). This is however not possible --- since it leads to ambiguity. The reason is the support for comments on record --- fields: --- data R = R { field :: Int -- ^ comment on the field } --- If we allow comments on types here, it's not clear if the comment applies --- to 'field' or to 'Int'. So we must use `ctype` to describe the type. - -ctypedoc :: { LHsType RdrName } - : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >> - ams (sLL $1 $> $ - HsForAllTy { hst_bndrs = $2 - , hst_body = $4 }) - [mu AnnForall $1,mj AnnDot $3] } - | context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) - >> return (sLL $1 $> $ - HsQualTy { hst_ctxt = $1 - , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3)) - [mu AnnDcolon $2] } - | typedoc { $1 } - ----------------------- --- Notes for 'context' --- We parse a context as a btype so that we don't get reduce/reduce --- errors in ctype. The basic problem is that --- (Eq a, Ord a) --- looks so much like a tuple type. We can't tell until we find the => - --- We have the t1 ~ t2 form both in 'context' and in type, --- to permit an individual equational constraint without parenthesis. --- Thus for some reason we allow f :: a~b => blah --- but not f :: ?x::Int => blah --- See Note [Parsing ~] -context :: { LHsContext RdrName } - : btype {% do { (anns,ctx) <- checkContext $1 - ; if null (unLoc ctx) - then addAnnotation (gl $1) AnnUnit (gl $1) - else return () - ; ams ctx anns - } } - -context_no_ops :: { LHsContext RdrName } - : btype_no_ops {% do { ty <- splitTilde $1 - ; (anns,ctx) <- checkContext ty - ; if null (unLoc ctx) - then addAnnotation (gl ty) AnnUnit (gl ty) - else return () - ; ams ctx anns - } } - -{- Note [GADT decl discards annotations] -~~~~~~~~~~~~~~~~~~~~~ -The type production for - - btype `->` btype - -adds the AnnRarrow annotation twice, in different places. - -This is because if the type is processed as usual, it belongs on the annotations -for the type as a whole. - -But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and -the top-level annotation will be disconnected. Hence for this specific case it -is connected to the first type too. --} - -type :: { LHsType RdrName } - : btype { $1 } - | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy $1 $3) - [mu AnnRarrow $2] } - - -typedoc :: { LHsType RdrName } - : btype { $1 } - | btype docprev { sLL $1 $> $ HsDocTy $1 $2 } - | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3) - [mu AnnRarrow $2] } - | btype docprev '->' ctypedoc {% ams (sLL $1 $> $ - HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) - $4) - [mu AnnRarrow $3] } - --- See Note [Parsing ~] -btype :: { LHsType RdrName } - : tyapps {% splitTildeApps (reverse (unLoc $1)) >>= - \ts -> return $ sL1 $1 $ HsAppsTy ts } - --- Used for parsing Haskell98-style data constructors, --- in order to forbid the blasphemous --- > data Foo = Int :+ Char :* Bool --- See also Note [Parsing data constructors is hard] in RdrHsSyn -btype_no_ops :: { LHsType RdrName } - : btype_no_ops atype { sLL $1 $> $ HsAppTy $1 $2 } - | atype { $1 } - -tyapps :: { Located [LHsAppType RdrName] } -- NB: This list is reversed - : tyapp { sL1 $1 [$1] } - | tyapps tyapp { sLL $1 $> $ $2 : (unLoc $1) } - --- See Note [HsAppsTy] in HsTypes -tyapp :: { LHsAppType RdrName } - : atype { sL1 $1 $ HsAppPrefix $1 } - | qtyconop { sL1 $1 $ HsAppInfix $1 } - | tyvarop { sL1 $1 $ HsAppInfix $1 } - | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix $2) - [mj AnnSimpleQuote $1] } - | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix $2) - [mj AnnSimpleQuote $1] } - -atype :: { LHsType RdrName } - : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples - | tyvar { sL1 $1 (HsTyVar NotPromoted $1) } -- (See Note [Unit tuples]) - | strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2)) - (fst $ unLoc $1) } -- Constructor sigs only - | '{' fielddecls '}' {% amms (checkRecordSyntax - (sLL $1 $> $ HsRecTy $2)) - -- Constructor sigs only - [moc $1,mcc $3] } - | '(' ')' {% ams (sLL $1 $> $ HsTupleTy - HsBoxedOrConstraintTuple []) - [mop $1,mcp $2] } - | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma - (gl $3) >> - ams (sLL $1 $> $ HsTupleTy - HsBoxedOrConstraintTuple ($2 : $4)) - [mop $1,mcp $5] } - | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple []) - [mo $1,mc $2] } - | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2) - [mo $1,mc $3] } - | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy $2) - [mo $1,mc $3] } - | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy $2) [mos $1,mcs $3] } - | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy $2) [mo $1,mc $3] } - | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] } - | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig $2 $4) - [mop $1,mu AnnDcolon $3,mcp $5] } - | quasiquote { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) } - | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2) - [mj AnnOpenPE $1,mj AnnCloseP $3] } - | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar $ - (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1)))) - [mj AnnThIdSplice $1] } - -- see Note [Promotion] for the followings - | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' - {% addAnnotation (gl $3) AnnComma (gl $4) >> - ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5)) - [mj AnnSimpleQuote $1,mop $2,mcp $6] } - | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy Promoted - placeHolderKind $3) - [mj AnnSimpleQuote $1,mos $2,mcs $4] } - | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar Promoted $2) - [mj AnnSimpleQuote $1,mj AnnName $2] } - - -- Two or more [ty, ty, ty] must be a promoted list type, just as - -- if you had written '[ty, ty, ty] - -- (One means a list type, zero means the list type constructor, - -- so you have to quote those.) - | '[' ctype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma - (gl $3) >> - ams (sLL $1 $> $ HsExplicitListTy NotPromoted - placeHolderKind ($2 : $4)) - [mos $1,mcs $5] } - | INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1) - (getINTEGER $1) } - | STRING { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1) - (getSTRING $1) } - | '_' { sL1 $1 $ mkAnonWildCardTy } - --- An inst_type is what occurs in the head of an instance decl --- e.g. (Foo a, Gaz b) => Wibble a b --- It's kept as a single type for convenience. -inst_type :: { LHsSigType RdrName } - : sigtype { mkLHsSigType $1 } - -deriv_types :: { [LHsSigType RdrName] } - : typedoc { [mkLHsSigType $1] } - - | typedoc ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2) - >> return (mkLHsSigType $1 : $3) } - -comma_types0 :: { [LHsType RdrName] } -- Zero or more: ty,ty,ty - : comma_types1 { $1 } - | {- empty -} { [] } - -comma_types1 :: { [LHsType RdrName] } -- One or more: ty,ty,ty - : ctype { [$1] } - | ctype ',' comma_types1 {% addAnnotation (gl $1) AnnComma (gl $2) - >> return ($1 : $3) } - -bar_types2 :: { [LHsType RdrName] } -- Two or more: ty|ty|ty - : ctype '|' ctype {% addAnnotation (gl $1) AnnVbar (gl $2) - >> return [$1,$3] } - | ctype '|' bar_types2 {% addAnnotation (gl $1) AnnVbar (gl $2) - >> return ($1 : $3) } - -tv_bndrs :: { [LHsTyVarBndr RdrName] } - : tv_bndr tv_bndrs { $1 : $2 } - | {- empty -} { [] } - -tv_bndr :: { LHsTyVarBndr RdrName } - : tyvar { sL1 $1 (UserTyVar $1) } - | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar $2 $4)) - [mop $1,mu AnnDcolon $3 - ,mcp $5] } - -fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) } - : {- empty -} { noLoc ([],[]) } - | '|' fds1 { (sLL $1 $> ([mj AnnVbar $1] - ,reverse (unLoc $2))) } - -fds1 :: { Located [Located (FunDep (Located RdrName))] } - : fds1 ',' fd {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) - >> return (sLL $1 $> ($3 : unLoc $1)) } - | fd { sL1 $1 [$1] } - -fd :: { Located (FunDep (Located RdrName)) } - : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3) - (reverse (unLoc $1), reverse (unLoc $3))) - [mu AnnRarrow $2] } - -varids0 :: { Located [Located RdrName] } - : {- empty -} { noLoc [] } - | varids0 tyvar { sLL $1 $> ($2 : unLoc $1) } - -{- -Note [Parsing ~] -~~~~~~~~~~~~~~~~ - -Due to parsing conflicts between laziness annotations in data type -declarations (see strict_mark) and equality types ~'s are always -parsed as laziness annotations, and turned into HsEqTy's in the -correct places using RdrHsSyn.splitTilde. - -Since strict_mark is parsed as part of atype which is part of type, -typedoc and context (where HsEqTy previously appeared) it made most -sense and was simplest to parse ~ as part of strict_mark and later -turn them into HsEqTy's. - --} - - ------------------------------------------------------------------------------ --- Kinds - -kind :: { LHsKind RdrName } - : ctype { $1 } - -{- Note [Promotion] - ~~~~~~~~~~~~~~~~ - -- Syntax of promoted qualified names -We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified -names. Moreover ticks are only allowed in types, not in kinds, for a -few reasons: - 1. we don't need quotes since we cannot define names in kinds - 2. if one day we merge types and kinds, tick would mean look in DataName - 3. we don't have a kind namespace anyway - -- Name resolution -When the user write Zero instead of 'Zero in types, we parse it a -HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We -deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not -bounded in the type level, then we look for it in the term level (we -change its namespace to DataName, see Note [Demotion] in OccName). And -both become a HsTyVar ("Zero", DataName) after the renamer. - --} - - ------------------------------------------------------------------------------ --- Datatype declarations - -gadt_constrlist :: { Located ([AddAnn] - ,[LConDecl RdrName]) } -- Returned in order - : 'where' '{' gadt_constrs '}' { L (comb2 $1 $3) - ([mj AnnWhere $1 - ,moc $2 - ,mcc $4] - , unLoc $3) } - | 'where' vocurly gadt_constrs close { L (comb2 $1 $3) - ([mj AnnWhere $1] - , unLoc $3) } - | {- empty -} { noLoc ([],[]) } - -gadt_constrs :: { Located [LConDecl RdrName] } - : gadt_constr_with_doc ';' gadt_constrs - {% addAnnotation (gl $1) AnnSemi (gl $2) - >> return (L (comb2 $1 $3) ($1 : unLoc $3)) } - | gadt_constr_with_doc { L (gl $1) [$1] } - | {- empty -} { noLoc [] } - --- We allow the following forms: --- C :: Eq a => a -> T a --- C :: forall a. Eq a => !a -> T a --- D { x,y :: a } :: T a --- forall a. Eq a => D { x,y :: a } :: T a - -gadt_constr_with_doc :: { LConDecl RdrName } -gadt_constr_with_doc - : maybe_docnext ';' gadt_constr - {% return $ addConDoc $3 $1 } - | gadt_constr - {% return $1 } - -gadt_constr :: { LConDecl RdrName } - -- see Note [Difference in parsing GADT and data constructors] - -- Returns a list because of: C,D :: ty - : con_list '::' sigtype - {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3))) - [mu AnnDcolon $2] } - -{- Note [Difference in parsing GADT and data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GADT constructors have simpler syntax than usual data constructors: -in GADTs, types cannot occur to the left of '::', so they cannot be mixed -with constructor names (see Note [Parsing data constructors is hard]). - -Due to simplified syntax, GADT constructor names (left-hand side of '::') -use simpler grammar production than usual data constructor names. As a -consequence, GADT constructor names are resticted (names like '(*)' are -allowed in usual data constructors, but not in GADTs). --} - -constrs :: { Located ([AddAnn],[LConDecl RdrName]) } - : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2] - ,addConDocs (unLoc $3) $1)} - -constrs1 :: { Located [LConDecl RdrName] } - : constrs1 maybe_docnext '|' maybe_docprev constr - {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $3) - >> return (sLL $1 $> (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4)) } - | constr { sL1 $1 [$1] } - -constr :: { LConDecl RdrName } - : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev - {% ams (let (con,details) = unLoc $5 in - addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con - (snd $ unLoc $2) $3 details)) - ($1 `mplus` $6)) - (mu AnnDarrow $4:(fst $ unLoc $2)) } - | maybe_docnext forall constr_stuff maybe_docprev - {% ams ( let (con,details) = unLoc $3 in - addConDoc (L (comb2 $2 $3) (mkConDeclH98 con - (snd $ unLoc $2) (noLoc []) details)) - ($1 `mplus` $4)) - (fst $ unLoc $2) } - -forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr RdrName]) } - : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) } - | {- empty -} { noLoc ([], Nothing) } - -constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } - -- See Note [Parsing data constructors is hard] in RdrHsSyn - : btype_no_ops {% do { c <- splitCon $1 - ; return $ sLL $1 $> c } } - | btype_no_ops conop btype_no_ops {% do { ty <- splitTilde $1 - ; return $ sLL $1 $> ($2, InfixCon ty $3) } } - -fielddecls :: { [LConDeclField RdrName] } - : {- empty -} { [] } - | fielddecls1 { $1 } - -fielddecls1 :: { [LConDeclField RdrName] } - : fielddecl maybe_docnext ',' maybe_docprev fielddecls1 - {% addAnnotation (gl $1) AnnComma (gl $3) >> - return ((addFieldDoc $1 $4) : addFieldDocs $5 $2) } - | fielddecl { [$1] } - -fielddecl :: { LConDeclField RdrName } - -- A list because of f,g :: Int - : maybe_docnext sig_vars '::' ctype maybe_docprev - {% ams (L (comb2 $2 $4) - (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc ln PlaceHolder) (unLoc $2))) $4 ($1 `mplus` $5))) - [mu AnnDcolon $3] } - --- Reversed! -maybe_derivings :: { HsDeriving RdrName } - : {- empty -} { noLoc [] } - | derivings { $1 } - --- A list of one or more deriving clauses at the end of a datatype -derivings :: { HsDeriving RdrName } - : derivings deriving { sLL $1 $> $ $2 : unLoc $1 } - | deriving { sLL $1 $> [$1] } - --- The outer Located is just to allow the caller to --- know the rightmost extremity of the 'deriving' clause -deriving :: { LHsDerivingClause RdrName } - : 'deriving' deriv_strategy qtycondoc - {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause $2 $ L full_loc - [mkLHsSigType $3]) - [mj AnnDeriving $1] } - - | 'deriving' deriv_strategy '(' ')' - {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause $2 $ L full_loc []) - [mj AnnDeriving $1,mop $3,mcp $4] } - - | 'deriving' deriv_strategy '(' deriv_types ')' - {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause $2 $ L full_loc $4) - [mj AnnDeriving $1,mop $3,mcp $5] } - -- Glasgow extension: allow partial - -- applications in derivings - ------------------------------------------------------------------------------ --- Value definitions - -{- Note [Declaration/signature overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's an awkward overlap with a type signature. Consider - f :: Int -> Int = ...rhs... - Then we can't tell whether it's a type signature or a value - definition with a result signature until we see the '='. - So we have to inline enough to postpone reductions until we know. --} - -{- - ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var - instead of qvar, we get another shift/reduce-conflict. Consider the - following programs: - - { (^^) :: Int->Int ; } Type signature; only var allowed - - { (^^) :: Int->Int = ... ; } Value defn with result signature; - qvar allowed (because of instance decls) - - We can't tell whether to reduce var to qvar until after we've read the signatures. --} - -docdecl :: { LHsDecl RdrName } - : docdecld { sL1 $1 (DocD (unLoc $1)) } - -docdecld :: { LDocDecl } - : docnext { sL1 $1 (DocCommentNext (unLoc $1)) } - | docprev { sL1 $1 (DocCommentPrev (unLoc $1)) } - | docnamed { sL1 $1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) } - | docsection { sL1 $1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) } - -decl_no_th :: { LHsDecl RdrName } - : sigdecl { $1 } - - | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) - -- Turn it all into an expression so that - -- checkPattern can check that bangs are enabled - ; l = comb2 $1 $> }; - (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ; - -- Depending upon what the pattern looks like we might get either - -- a FunBind or PatBind back from checkValDef. See Note - -- [Varieties of binding pattern matches] - case r of { - (FunBind n _ _ _ _) -> - ams (L l ()) [mj AnnFunId n] >> return () ; - (PatBind (L lh _lhs) _rhs _ _ _) -> - ams (L lh ()) [] >> return () } ; - - _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; - return $! (sL l $ ValD r) } } - - | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3; - let { l = comb2 $1 $> }; - -- Depending upon what the pattern looks like we might get either - -- a FunBind or PatBind back from checkValDef. See Note - -- [Varieties of binding pattern matches] - case r of { - (FunBind n _ _ _ _) -> - ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ; - (PatBind (L lh _lhs) _rhs _ _ _) -> - ams (L lh ()) (fst $2) >> return () } ; - _ <- ams (L l ()) (ann ++ (fst $ unLoc $3)); - return $! (sL l $ ValD r) } } - | pattern_synonym_decl { $1 } - | docdecl { $1 } - -decl :: { LHsDecl RdrName } - : decl_no_th { $1 } - - -- Why do we only allow naked declaration splices in top-level - -- declarations and not here? Short answer: because readFail009 - -- fails terribly with a panic in cvBindsAndSigs otherwise. - | splice_exp { sLL $1 $> $ mkSpliceDecl $1 } - -rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) } - : '=' exp wherebinds { sL (comb3 $1 $2 $3) - ((mj AnnEqual $1 : (fst $ unLoc $3)) - ,GRHSs (unguardedRHS (comb3 $1 $2 $3) $2) - (snd $ unLoc $3)) } - | gdrhs wherebinds { sLL $1 $> (fst $ unLoc $2 - ,GRHSs (reverse (unLoc $1)) - (snd $ unLoc $2)) } - -gdrhs :: { Located [LGRHS RdrName (LHsExpr RdrName)] } - : gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) } - | gdrh { sL1 $1 [$1] } - -gdrh :: { LGRHS RdrName (LHsExpr RdrName) } - : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4) - [mj AnnVbar $1,mj AnnEqual $3] } - -sigdecl :: { LHsDecl RdrName } - : - -- See Note [Declaration/signature overlap] for why we need infixexp here - infixexp_top '::' sigtypedoc - {% do v <- checkValSigLhs $1 - ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2] - ; return (sLL $1 $> $ SigD $ - TypeSig [v] (mkLHsSigWcType $3)) } - - | var ',' sig_vars '::' sigtypedoc - {% do { let sig = TypeSig ($1 : reverse (unLoc $3)) - (mkLHsSigWcType $5) - ; addAnnotation (gl $1) AnnComma (gl $2) - ; ams ( sLL $1 $> $ SigD sig ) - [mu AnnDcolon $4] } } - - | infix prec ops - {% ams (sLL $1 $> $ SigD - (FixSig (FixitySig (fromOL $ unLoc $3) - (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) - [mj AnnInfix $1,mj AnnVal $2] } - - | pattern_synonym_sig { sLL $1 $> . SigD . unLoc $ $1 } - - | '{-# COMPLETE' con_list opt_tyconsig '#-}' - {% let (dcolon, tc) = $3 - in ams - (sLL $1 $> - (SigD (CompleteMatchSig (getCOMPLETE_PRAGs $1) $2 tc))) - ([ mo $1 ] ++ dcolon ++ [mc $4]) } - - -- This rule is for both INLINE and INLINABLE pragmas - | '{-# INLINE' activation qvar '#-}' - {% ams ((sLL $1 $> $ SigD (InlineSig $3 - (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1) - (snd $2))))) - ((mo $1:fst $2) ++ [mc $4]) } - - | '{-# SCC' qvar '#-}' - {% ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 Nothing))) - [mo $1, mc $3] } - - | '{-# SCC' qvar STRING '#-}' - {% do { scc <- getSCC $3 - ; let str_lit = StringLiteral (getSTRINGs $3) scc - ; ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) - [mo $1, mc $4] } } - - | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' - {% ams ( - let inl_prag = mkInlinePragma (getSPEC_PRAGs $1) - (EmptyInlineSpec, FunLike) (snd $2) - in sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag)) - (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } - - | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - {% ams (sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) - (mkInlinePragma (getSPEC_INLINE_PRAGs $1) - (getSPEC_INLINE $1) (snd $2)))) - (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } - - | '{-# SPECIALISE' 'instance' inst_type '#-}' - {% ams (sLL $1 $> - $ SigD (SpecInstSig (getSPEC_PRAGs $1) $3)) - [mo $1,mj AnnInstance $2,mc $4] } - - -- A minimal complete definition - | '{-# MINIMAL' name_boolformula_opt '#-}' - {% ams (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) $2)) - [mo $1,mc $3] } - -activation :: { ([AddAnn],Maybe Activation) } - : {- empty -} { ([],Nothing) } - | explicit_activation { (fst $1,Just (snd $1)) } - -explicit_activation :: { ([AddAnn],Activation) } -- In brackets - : '[' INTEGER ']' { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3] - ,ActiveAfter (getINTEGERs $2) (fromInteger (getINTEGER $2))) } - | '[' '~' INTEGER ']' { ([mj AnnOpenS $1,mj AnnTilde $2,mj AnnVal $3 - ,mj AnnCloseS $4] - ,ActiveBefore (getINTEGERs $3) (fromInteger (getINTEGER $3))) } - ------------------------------------------------------------------------------ --- Expressions - -quasiquote :: { Located (HsSplice RdrName) } - : TH_QUASIQUOTE { let { loc = getLoc $1 - ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 - ; quoterId = mkUnqual varName quoter } - in sL1 $1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } - | TH_QQUASIQUOTE { let { loc = getLoc $1 - ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1 - ; quoterId = mkQual varName (qual, quoter) } - in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } - -exp :: { LHsExpr RdrName } - : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3)) - [mu AnnDcolon $2] } - | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType - HsFirstOrderApp True) - [mu Annlarrowtail $2] } - | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType - HsFirstOrderApp False) - [mu Annrarrowtail $2] } - | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType - HsHigherOrderApp True) - [mu AnnLarrowtail $2] } - | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType - HsHigherOrderApp False) - [mu AnnRarrowtail $2] } - | infixexp { $1 } - -infixexp :: { LHsExpr RdrName } - : exp10 { $1 } - | infixexp qop exp10 {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3)) - [mj AnnVal $2] } - -- AnnVal annotation for NPlusKPat, which discards the operator - -infixexp_top :: { LHsExpr RdrName } - : exp10_top { $1 } - | infixexp_top qop exp10_top - {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3)) - [mj AnnVal $2] } - -exp10_top :: { LHsExpr RdrName } - : '\\' apat apats opt_asig '->' exp - {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource - [sLL $1 $> $ Match { m_ctxt = LambdaExpr - , m_pats = $2:$3 - , m_type = snd $4 - , m_grhss = unguardedGRHSs $6 }])) - (mj AnnLam $1:mu AnnRarrow $5:(fst $4)) } - - | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) - (mj AnnLet $1:mj AnnIn $3 - :(fst $ unLoc $2)) } - | '\\' 'lcase' altslist - {% ams (sLL $1 $> $ HsLamCase - (mkMatchGroup FromSource (snd $ unLoc $3))) - (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } - | 'if' exp optSemi 'then' exp optSemi 'else' exp - {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >> - ams (sLL $1 $> $ mkHsIf $2 $5 $8) - (mj AnnIf $1:mj AnnThen $4 - :mj AnnElse $7 - :(map (\l -> mj AnnSemi l) (fst $3)) - ++(map (\l -> mj AnnSemi l) (fst $6))) } - | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> - ams (sLL $1 $> $ HsMultiIf - placeHolderType - (reverse $ snd $ unLoc $2)) - (mj AnnIf $1:(fst $ unLoc $2)) } - | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup - FromSource (snd $ unLoc $4))) - (mj AnnCase $1:mj AnnOf $3 - :(fst $ unLoc $4)) } - | '-' fexp {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr) - [mj AnnMinus $1] } - - | 'do' stmtlist {% ams (L (comb2 $1 $2) - (mkHsDo DoExpr (snd $ unLoc $2))) - (mj AnnDo $1:(fst $ unLoc $2)) } - | 'mdo' stmtlist {% ams (L (comb2 $1 $2) - (mkHsDo MDoExpr (snd $ unLoc $2))) - (mj AnnMdo $1:(fst $ unLoc $2)) } - - | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1) - (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) - (fst $ fst $ fst $ unLoc $1) } - - | 'proc' aexp '->' exp - {% checkPattern empty $2 >>= \ p -> - checkCommand $4 >>= \ cmd -> - ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType - placeHolderType [])) - -- TODO: is LL right here? - [mj AnnProc $1,mu AnnRarrow $3] } - - | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4) - [mo $1,mj AnnVal $2 - ,mc $3] } - -- hdaume: core annotation - | fexp { $1 } - -exp10 :: { LHsExpr RdrName } - : exp10_top { $1 } - | scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) - (fst $ fst $ unLoc $1) } - -optSemi :: { ([Located a],Bool) } - : ';' { ([$1],True) } - | {- empty -} { ([],False) } - -scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) } - : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2 - ; return $ sLL $1 $> - (([mo $1,mj AnnValStr $2 - ,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) } - | '{-# SCC' VARID '#-}' { sLL $1 $> (([mo $1,mj AnnVal $2 - ,mc $3],getSCC_PRAGs $1) - ,(StringLiteral NoSourceText (getVARID $2))) } - -hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))), - ((SourceText,SourceText),(SourceText,SourceText)) - ) } - : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - { sLL $1 $> $ ((([mo $1,mj AnnVal $2 - ,mj AnnVal $3,mj AnnColon $4 - ,mj AnnVal $5,mj AnnMinus $6 - ,mj AnnVal $7,mj AnnColon $8 - ,mj AnnVal $9,mc $10], - getGENERATED_PRAGs $1) - ,((getStringLiteral $2) - ,( fromInteger $ getINTEGER $3 - , fromInteger $ getINTEGER $5 - ) - ,( fromInteger $ getINTEGER $7 - , fromInteger $ getINTEGER $9 - ) - )) - , (( getINTEGERs $3 - , getINTEGERs $5 - ) - ,( getINTEGERs $7 - , getINTEGERs $9 - ))) - } - -fexp :: { LHsExpr RdrName } - : fexp aexp { sLL $1 $> $ HsApp $1 $2 } - | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3)) - [mj AnnAt $2] } - | 'static' aexp {% ams (sLL $1 $> $ HsStatic placeHolderNames $2) - [mj AnnStatic $1] } - | aexp { $1 } - -aexp :: { LHsExpr RdrName } - : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] } - -- If you change the parsing, make sure to understand - -- Note [Lexing type applications] in Lexer.x - - | '~' aexp {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] } - | aexp1 { $1 } - -aexp1 :: { LHsExpr RdrName } - : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) - (snd $3) - ; _ <- ams (sLL $1 $> ()) (moc $2:mcc $4:(fst $3)) - ; checkRecordSyntax (sLL $1 $> r) }} - | aexp2 { $1 } - -aexp2 :: { LHsExpr RdrName } - : qvar { sL1 $1 (HsVar $! $1) } - | qcon { sL1 $1 (HsVar $! $1) } - | ipvar { sL1 $1 (HsIPVar $! unLoc $1) } - | overloaded_label { sL1 $1 (HsOverLabel Nothing $! unLoc $1) } - | literal { sL1 $1 (HsLit $! unLoc $1) } --- This will enable overloaded strings permanently. Normally the renamer turns HsString --- into HsOverLit when -foverloaded-strings is on. --- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) --- (getSTRING $1) placeHolderType) } - | INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGERs $1) - (getINTEGER $1) placeHolderType) } - | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional - (getRATIONAL $1) placeHolderType) } - - -- N.B.: sections get parsed by these next two productions. - -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't - -- correct Haskell (you'd have to write '((+ 3), (4 -))') - -- but the less cluttered version fell out of having texps. - | '(' texp ')' {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] } - | '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2) - ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } } - - | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple [L (gl $2) - (Present $2)] Unboxed)) - [mo $1,mc $3] } - | '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2) - ; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } } - - | '[' list ']' {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) } - | '[:' parr ':]' {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) } - | '_' { sL1 $1 EWildPat } - - -- Template Haskell Extension - | splice_exp { $1 } - - | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket (ExpBr $2)) - (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] - else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) } - | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) - (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } - | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mu AnnCloseQ $3] } - | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p -> - ams (sLL $1 $> $ HsBracket (PatBr p)) - [mo $1,mu AnnCloseQ $3] } - | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket (DecBrL (snd $2))) - (mo $1:mu AnnCloseQ $3:fst $2) } - | quasiquote { sL1 $1 (HsSpliceE (unLoc $1)) } - - -- arrow notation extension - | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm $2 - Nothing (reverse $3)) - [mu AnnOpenB $1,mu AnnCloseB $4] } - -splice_exp :: { LHsExpr RdrName } - : TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE HasDollar - (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName - (getTH_ID_SPLICE $1))))) - [mj AnnThIdSplice $1] } - | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2) - [mj AnnOpenPE $1,mj AnnCloseP $3] } - | TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE HasDollar - (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName - (getTH_ID_TY_SPLICE $1))))) - [mj AnnThIdTySplice $1] } - | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2) - [mj AnnOpenPTE $1,mj AnnCloseP $3] } - -cmdargs :: { [LHsCmdTop RdrName] } - : cmdargs acmd { $2 : $1 } - | {- empty -} { [] } - -acmd :: { LHsCmdTop RdrName } - : aexp2 {% checkCommand $1 >>= \ cmd -> - return (sL1 $1 $ HsCmdTop cmd - placeHolderType placeHolderType []) } - -cvtopbody :: { ([AddAnn],[LHsDecl RdrName]) } - : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 - ,mj AnnCloseC $3],$2) } - | vocurly cvtopdecls0 close { ([],$2) } - -cvtopdecls0 :: { [LHsDecl RdrName] } - : topdecls_semi { cvTopDecls $1 } - | topdecls { cvTopDecls $1 } - ------------------------------------------------------------------------------ --- Tuple expressions - --- "texp" is short for tuple expressions: --- things that can appear unparenthesized as long as they're --- inside parens or delimitted by commas -texp :: { LHsExpr RdrName } - : exp { $1 } - - -- Note [Parsing sections] - -- ~~~~~~~~~~~~~~~~~~~~~~~ - -- We include left and right sections here, which isn't - -- technically right according to the Haskell standard. - -- For example (3 +, True) isn't legal. - -- However, we want to parse bang patterns like - -- (!x, !y) - -- and it's convenient to do so here as a section - -- Then when converting expr to pattern we unravel it again - -- Meanwhile, the renamer checks that real sections appear - -- inside parens. - | infixexp qop { sLL $1 $> $ SectionL $1 $2 } - | qopm infixexp { sLL $1 $> $ SectionR $1 $2 } - - -- View patterns get parenthesized above - | exp '->' texp {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] } - --- Always at least one comma or bar. -tup_exprs :: { ([AddAnn],SumOrTuple) } - : texp commas_tup_tail - {% do { addAnnotation (gl $1) AnnComma (fst $2) - ; return ([],Tuple ((sL1 $1 (Present $1)) : snd $2)) } } - - | texp bars { (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) } - - | commas tup_tail - {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) - ; return - ([],Tuple (map (\l -> L l missingTupArg) (fst $1) ++ $2)) } } - - | bars texp bars0 - { (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } - --- Always starts with commas; always follows an expr -commas_tup_tail :: { (SrcSpan,[LHsTupArg RdrName]) } -commas_tup_tail : commas tup_tail - {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) - ; return ( - (head $ fst $1 - ,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ $2)) } } - --- Always follows a comma -tup_tail :: { [LHsTupArg RdrName] } - : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >> - return ((L (gl $1) (Present $1)) : snd $2) } - | texp { [L (gl $1) (Present $1)] } - | {- empty -} { [noLoc missingTupArg] } - ------------------------------------------------------------------------------ --- List expressions - --- The rules below are little bit contorted to keep lexps left-recursive while --- avoiding another shift/reduce-conflict. -list :: { ([AddAnn],HsExpr RdrName) } - : texp { ([],ExplicitList placeHolderType Nothing [$1]) } - | lexps { ([],ExplicitList placeHolderType Nothing - (reverse (unLoc $1))) } - | texp '..' { ([mj AnnDotdot $2], - ArithSeq noPostTcExpr Nothing (From $1)) } - | texp ',' exp '..' { ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noPostTcExpr Nothing - (FromThen $1 $3)) } - | texp '..' exp { ([mj AnnDotdot $2], - ArithSeq noPostTcExpr Nothing - (FromTo $1 $3)) } - | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noPostTcExpr Nothing - (FromThenTo $1 $3 $5)) } - | texp '|' flattenedpquals - {% checkMonadComp >>= \ ctxt -> - return ([mj AnnVbar $2], - mkHsComp ctxt (unLoc $3) $1) } - -lexps :: { Located [LHsExpr RdrName] } - : lexps ',' texp {% addAnnotation (gl $ head $ unLoc $1) - AnnComma (gl $2) >> - return (sLL $1 $> (((:) $! $3) $! unLoc $1)) } - | texp ',' texp {% addAnnotation (gl $1) AnnComma (gl $2) >> - return (sLL $1 $> [$3,$1]) } - ------------------------------------------------------------------------------ --- List Comprehensions - -flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } - : pquals { case (unLoc $1) of - [qs] -> sL1 $1 qs - -- We just had one thing in our "parallel" list so - -- we simply return that thing directly - - qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr | - qs <- qss] - noExpr noSyntaxExpr placeHolderType] - -- We actually found some actual parallel lists so - -- we wrap them into as a ParStmt - } - -pquals :: { Located [[LStmt RdrName (LHsExpr RdrName)]] } - : squals '|' pquals - {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >> - return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) } - | squals { L (getLoc $1) [reverse (unLoc $1)] } - -squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, because the last - -- one can "grab" the earlier ones - : squals ',' transformqual - {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> - ams (sLL $1 $> ()) (fst $ unLoc $3) >> - return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) } - | squals ',' qual - {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> ($3 : unLoc $1)) } - | transformqual {% ams $1 (fst $ unLoc $1) >> - return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) } - | qual { sL1 $1 [$1] } --- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) } --- | '{|' pquals '|}' { sL1 $1 [$2] } - --- It is possible to enable bracketing (associating) qualifier lists --- by uncommenting the lines with {| |} above. Due to a lack of --- consensus on the syntax, this feature is not being used until we --- get user demand. - -transformqual :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName)) } - -- Function is applied to a list of stmts *in order* - : 'then' exp { sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) } - | 'then' exp 'by' exp { sLL $1 $> ([mj AnnThen $1,mj AnnBy $3],\ss -> (mkTransformByStmt ss $2 $4)) } - | 'then' 'group' 'using' exp - { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], \ss -> (mkGroupUsingStmt ss $4)) } - - | 'then' 'group' 'by' exp 'using' exp - { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], \ss -> (mkGroupByUsingStmt ss $4 $6)) } - --- Note that 'group' is a special_id, which means that you can enable --- TransformListComp while still using Data.List.group. However, this --- introduces a shift/reduce conflict. Happy chooses to resolve the conflict --- in by choosing the "group by" variant, which is what we want. - ------------------------------------------------------------------------------ --- Parallel array expressions - --- The rules below are little bit contorted; see the list case for details. --- Note that, in contrast to lists, we only have finite arithmetic sequences. --- Moreover, we allow explicit arrays with no element (represented by the nil --- constructor in the list case). - -parr :: { ([AddAnn],HsExpr RdrName) } - : { ([],ExplicitPArr placeHolderType []) } - | texp { ([],ExplicitPArr placeHolderType [$1]) } - | lexps { ([],ExplicitPArr placeHolderType - (reverse (unLoc $1))) } - | texp '..' exp { ([mj AnnDotdot $2] - ,PArrSeq noPostTcExpr (FromTo $1 $3)) } - | texp ',' exp '..' exp - { ([mj AnnComma $2,mj AnnDotdot $4] - ,PArrSeq noPostTcExpr (FromThenTo $1 $3 $5)) } - | texp '|' flattenedpquals - { ([mj AnnVbar $2],mkHsComp PArrComp (unLoc $3) $1) } - --- We are reusing `lexps' and `flattenedpquals' from the list case. - ------------------------------------------------------------------------------ --- Guards - -guardquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } - : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) } - -guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] } - : guardquals1 ',' qual {% addAnnotation (gl $ head $ unLoc $1) AnnComma - (gl $2) >> - return (sLL $1 $> ($3 : unLoc $1)) } - | qual { sL1 $1 [$1] } - ------------------------------------------------------------------------------ --- Case alternatives - -altslist :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } - : '{' alts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) - ,(reverse (snd $ unLoc $2))) } - | vocurly alts close { L (getLoc $2) (fst $ unLoc $2 - ,(reverse (snd $ unLoc $2))) } - | '{' '}' { noLoc ([moc $1,mcc $2],[]) } - | vocurly close { noLoc ([],[]) } - -alts :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } - : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)) - ,snd $ unLoc $2) } - -alts1 :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } - : alts1 ';' alt {% if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,[$3])) - else (ams (head $ snd $ unLoc $1) - (mj AnnSemi $2:(fst $ unLoc $1)) - >> return (sLL $1 $> ([],$3 : (snd $ unLoc $1))) ) } - | alts1 ';' {% if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,snd $ unLoc $1)) - else (ams (head $ snd $ unLoc $1) - (mj AnnSemi $2:(fst $ unLoc $1)) - >> return (sLL $1 $> ([],snd $ unLoc $1))) } - | alt { sL1 $1 ([],[$1]) } - -alt :: { LMatch RdrName (LHsExpr RdrName) } - : pat opt_asig alt_rhs {%ams (sLL $1 $> (Match { m_ctxt = CaseAlt - , m_pats = [$1] - , m_type = snd $2 - , m_grhss = snd $ unLoc $3 })) - (fst $2 ++ (fst $ unLoc $3))} - -alt_rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) } - : ralt wherebinds { sLL $1 $> (fst $ unLoc $2, - GRHSs (unLoc $1) (snd $ unLoc $2)) } - -ralt :: { Located [LGRHS RdrName (LHsExpr RdrName)] } - : '->' exp {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) - [mu AnnRarrow $1] } - | gdpats { sL1 $1 (reverse (unLoc $1)) } - -gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] } - : gdpats gdpat { sLL $1 $> ($2 : unLoc $1) } - | gdpat { sL1 $1 [$1] } - --- layout for MultiWayIf doesn't begin with an open brace, because it's hard to --- generate the open brace in addition to the vertical bar in the lexer, and --- we don't need it. -ifgdpats :: { Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)]) } - : '{' gdpats '}' { sLL $1 $> ([moc $1,mcc $3],unLoc $2) } - | gdpats close { sL1 $1 ([],unLoc $1) } - -gdpat :: { LGRHS RdrName (LHsExpr RdrName) } - : '|' guardquals '->' exp - {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4) - [mj AnnVbar $1,mu AnnRarrow $3] } - --- 'pat' recognises a pattern, including one with a bang at the top --- e.g. "!x" or "!(x,y)" or "C a b" etc --- Bangs inside are parsed as infix operator applications, so that --- we parse them right when bang-patterns are off -pat :: { LPat RdrName } -pat : exp {% checkPattern empty $1 } - | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR - (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) - [mj AnnBang $1] } - -bindpat :: { LPat RdrName } -bindpat : exp {% checkPattern - (text "Possibly caused by a missing 'do'?") $1 } - | '!' aexp {% amms (checkPattern - (text "Possibly caused by a missing 'do'?") - (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) - [mj AnnBang $1] } - -apat :: { LPat RdrName } -apat : aexp {% checkPattern empty $1 } - | '!' aexp {% amms (checkPattern empty - (sLL $1 $> (SectionR - (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) - [mj AnnBang $1] } - -apats :: { [LPat RdrName] } - : apat apats { $1 : $2 } - | {- empty -} { [] } - ------------------------------------------------------------------------------ --- Statement sequences - -stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } - : '{' stmts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) - ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? - | vocurly stmts close { L (gl $2) (fst $ unLoc $2 - ,reverse $ snd $ unLoc $2) } - --- do { ;; s ; s ; ; s ;; } --- The last Stmt should be an expression, but that's hard to enforce --- here, because we need too much lookahead if we see do { e ; } --- So we use BodyStmts throughout, and switch the last one over --- in ParseUtils.checkDo instead - -stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } - : stmts ';' stmt {% if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,$3 : (snd $ unLoc $1))) - else do - { ams (head $ snd $ unLoc $1) [mj AnnSemi $2] - ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }} - - | stmts ';' {% if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1),snd $ unLoc $1)) - else do - { ams (head $ snd $ unLoc $1) - [mj AnnSemi $2] - ; return $1 } } - | stmt { sL1 $1 ([],[$1]) } - | {- empty -} { noLoc ([],[]) } - - --- For typing stmts at the GHCi prompt, where --- the input may consist of just comments. -maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) } - : stmt { Just $1 } - | {- nothing -} { Nothing } - -stmt :: { LStmt RdrName (LHsExpr RdrName) } - : qual { $1 } - | 'rec' stmtlist {% ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2)) - (mj AnnRec $1:(fst $ unLoc $2)) } - -qual :: { LStmt RdrName (LHsExpr RdrName) } - : bindpat '<-' exp {% ams (sLL $1 $> $ mkBindStmt $1 $3) - [mu AnnLarrow $2] } - | exp { sL1 $1 $ mkBodyStmt $1 } - | 'let' binds {% ams (sLL $1 $>$ LetStmt (snd $ unLoc $2)) - (mj AnnLet $1:(fst $ unLoc $2)) } - ------------------------------------------------------------------------------ --- Record Field Update/Construction - -fbinds :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) } - : fbinds1 { $1 } - | {- empty -} { ([],([], False)) } - -fbinds1 :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) } - : fbind ',' fbinds1 - {% addAnnotation (gl $1) AnnComma (gl $2) >> - return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } - | fbind { ([],([$1], False)) } - | '..' { ([mj AnnDotdot $1],([], True)) } - -fbind :: { LHsRecField RdrName (LHsExpr RdrName) } - : qvar '=' texp {% ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) - [mj AnnEqual $2] } - -- RHS is a 'texp', allowing view patterns (Trac #6038) - -- and, incidentally, sections. Eg - -- f (R { x = show -> s }) = ... - - | qvar { sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) placeHolderPunRhs True } - -- In the punning case, use a place-holder - -- The renamer fills in the final value - ------------------------------------------------------------------------------ --- Implicit Parameter Bindings - -dbinds :: { Located [LIPBind RdrName] } - : dbinds ';' dbind - {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >> - return (let { this = $3; rest = unLoc $1 } - in rest `seq` this `seq` sLL $1 $> (this : rest)) } - | dbinds ';' {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >> - return (sLL $1 $> (unLoc $1)) } - | dbind { let this = $1 in this `seq` sL1 $1 [this] } --- | {- empty -} { [] } - -dbind :: { LIPBind RdrName } -dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left $1) $3)) - [mj AnnEqual $2] } - -ipvar :: { Located HsIPName } - : IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) } - ------------------------------------------------------------------------------ --- Overloaded labels - -overloaded_label :: { Located FastString } - : LABELVARID { sL1 $1 (getLABELVARID $1) } - ------------------------------------------------------------------------------ --- Warnings and deprecations - -name_boolformula_opt :: { LBooleanFormula (Located RdrName) } - : name_boolformula { $1 } - | {- empty -} { noLoc mkTrue } - -name_boolformula :: { LBooleanFormula (Located RdrName) } - : name_boolformula_and { $1 } - | name_boolformula_and '|' name_boolformula - {% aa $1 (AnnVbar, $2) - >> return (sLL $1 $> (Or [$1,$3])) } - -name_boolformula_and :: { LBooleanFormula (Located RdrName) } - : name_boolformula_and_list - { sLL (head $1) (last $1) (And ($1)) } - -name_boolformula_and_list :: { [LBooleanFormula (Located RdrName)] } - : name_boolformula_atom { [$1] } - | name_boolformula_atom ',' name_boolformula_and_list - {% aa $1 (AnnComma, $2) >> return ($1 : $3) } - -name_boolformula_atom :: { LBooleanFormula (Located RdrName) } - : '(' name_boolformula ')' {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] } - | name_var { sL1 $1 (Var $1) } - -namelist :: { Located [Located RdrName] } -namelist : name_var { sL1 $1 [$1] } - | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >> - return (sLL $1 $> ($1 : unLoc $3)) } - -name_var :: { Located RdrName } -name_var : var { $1 } - | con { $1 } - ------------------------------------------ --- Data constructors --- There are two different productions here as lifted list constructors --- are parsed differently. - -qcon_nowiredlist :: { Located RdrName } - : gen_qcon { $1 } - | sysdcon_nolist { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } - -qcon :: { Located RdrName } - : gen_qcon { $1} - | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } - -gen_qcon :: { Located RdrName } - : qconid { $1 } - | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - --- The case of '[:' ':]' is part of the production `parr' - -con :: { Located RdrName } - : conid { $1 } - | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } - -con_list :: { Located [Located RdrName] } -con_list : con { sL1 $1 [$1] } - | con ',' con_list {% addAnnotation (gl $1) AnnComma (gl $2) >> - return (sLL $1 $> ($1 : unLoc $3)) } - -sysdcon_nolist :: { Located DataCon } -- Wired in data constructors - : '(' ')' {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] } - | '(' commas ')' {% ams (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1)) - (mop $1:mcp $3:(mcommas (fst $2))) } - | '(#' '#)' {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] } - | '(#' commas '#)' {% ams (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1)) - (mo $1:mc $3:(mcommas (fst $2))) } - -sysdcon :: { Located DataCon } - : sysdcon_nolist { $1 } - | '[' ']' {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] } - -conop :: { Located RdrName } - : consym { $1 } - | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -qconop :: { Located RdrName } - : qconsym { $1 } - | '`' qconid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - ----------------------------------------------------------------------------- --- Type constructors - - --- See Note [Unit tuples] in HsTypes for the distinction --- between gtycon and ntgtycon -gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples - : ntgtycon { $1 } - | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) - [mop $1,mcp $2] } - | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) - [mo $1,mc $2] } - -ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples - : oqtycon { $1 } - | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed - (snd $2 + 1))) - (mop $1:mcp $3:(mcommas (fst $2))) } - | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed - (snd $2 + 1))) - (mo $1:mc $3:(mcommas (fst $2))) } - | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) - [mop $1,mu AnnRarrow $2,mcp $3] } - | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] } - | '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] } - | '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon) - [mop $1,mj AnnTildehsh $2,mcp $3] } - -oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon; - -- These can appear in export lists - : qtycon { $1 } - | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) - [mop $1,mj AnnVal $2,mcp $3] } - -oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mistaken - -- for variable constructor in export lists - -- see Note [Type constructors in export list] - : qtycon { $1 } - | '(' QCONSYM ')' {% let name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' CONSYM ')' {% let name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' ':' ')' {% let name = sL1 $2 $! consDataCon_RDR - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] } - -{- Note [Type constructors in export list] -~~~~~~~~~~~~~~~~~~~~~ -Mixing type constructors and data constructors in export lists introduces -ambiguity in grammar: e.g. (*) may be both a type constructor and a function. - --XExplicitNamespaces allows to disambiguate by explicitly prefixing type -constructors with 'type' keyword. - -This ambiguity causes reduce/reduce conflicts in parser, which are always -resolved in favour of data constructors. To get rid of conflicts we demand -that ambiguous type constructors (those, which are formed by the same -productions as variable constructors) are always prefixed with 'type' keyword. -Unambiguous type constructors may occur both with or without 'type' keyword. - -Note that in the parser we still parse data constructors as type -constructors. As such, they still end up in the type constructor namespace -until after renaming when we resolve the proper namespace for each exported -child. --} - -qtyconop :: { Located RdrName } -- Qualified or unqualified - : qtyconsym { $1 } - | '`' qtycon '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -qtycon :: { Located RdrName } -- Qualified or unqualified - : QCONID { sL1 $1 $! mkQual tcClsName (getQCONID $1) } - | tycon { $1 } - -qtycondoc :: { LHsType RdrName } -- Qualified or unqualified - : qtycon { sL1 $1 (HsTyVar NotPromoted $1) } - | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) } - -tycon :: { Located RdrName } -- Unqualified - : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } - -qtyconsym :: { Located RdrName } - : QCONSYM { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) } - | QVARSYM { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) } - | tyconsym { $1 } - --- Does not include "!", because that is used for strictness marks --- or ".", because that separates the quantified type vars from the rest -tyconsym :: { Located RdrName } - : CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) } - | VARSYM { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) } - | ':' { sL1 $1 $! consDataCon_RDR } - | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") } - - ------------------------------------------------------------------------------ --- Operators - -op :: { Located RdrName } -- used in infix decls - : varop { $1 } - | conop { $1 } - -varop :: { Located RdrName } - : varsym { $1 } - | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -qop :: { LHsExpr RdrName } -- used in sections - : qvarop { sL1 $1 $ HsVar $1 } - | qconop { sL1 $1 $ HsVar $1 } - | '`' '_' '`' {% ams (sLL $1 $> EWildPat) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -qopm :: { LHsExpr RdrName } -- used in sections - : qvaropm { sL1 $1 $ HsVar $1 } - | qconop { sL1 $1 $ HsVar $1 } - -qvarop :: { Located RdrName } - : qvarsym { $1 } - | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -qvaropm :: { Located RdrName } - : qvarsym_no_minus { $1 } - | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - ------------------------------------------------------------------------------ --- Type variables - -tyvar :: { Located RdrName } -tyvar : tyvarid { $1 } - -tyvarop :: { Located RdrName } -tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - | '.' {% hintExplicitForall' (getLoc $1) } - -tyvarid :: { Located RdrName } - : VARID { sL1 $1 $! mkUnqual tvName (getVARID $1) } - | special_id { sL1 $1 $! mkUnqual tvName (unLoc $1) } - | 'unsafe' { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") } - | 'safe' { sL1 $1 $! mkUnqual tvName (fsLit "safe") } - | 'interruptible' { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") } - ------------------------------------------------------------------------------ --- Variables - -var :: { Located RdrName } - : varid { $1 } - | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - - -- Lexing type applications depends subtly on what characters can possibly - -- end a qvar. Currently (June 2015), only $idchars and ")" can end a qvar. - -- If you're changing this, please see Note [Lexing type applications] in - -- Lexer.x. -qvar :: { Located RdrName } - : qvarid { $1 } - | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - | '(' qvarsym1 ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } --- We've inlined qvarsym here so that the decision about --- whether it's a qvar or a var can be postponed until --- *after* we see the close paren. - -qvarid :: { Located RdrName } - : varid { $1 } - | QVARID { sL1 $1 $! mkQual varName (getQVARID $1) } - --- Note that 'role' and 'family' get lexed separately regardless of --- the use of extensions. However, because they are listed here, --- this is OK and they can be used as normal varids. --- See Note [Lexing type pseudo-keywords] in Lexer.x -varid :: { Located RdrName } - : VARID { sL1 $1 $! mkUnqual varName (getVARID $1) } - | special_id { sL1 $1 $! mkUnqual varName (unLoc $1) } - | 'unsafe' { sL1 $1 $! mkUnqual varName (fsLit "unsafe") } - | 'safe' { sL1 $1 $! mkUnqual varName (fsLit "safe") } - | 'interruptible' { sL1 $1 $! mkUnqual varName (fsLit "interruptible")} - | 'forall' { sL1 $1 $! mkUnqual varName (fsLit "forall") } - | 'family' { sL1 $1 $! mkUnqual varName (fsLit "family") } - | 'role' { sL1 $1 $! mkUnqual varName (fsLit "role") } - -qvarsym :: { Located RdrName } - : varsym { $1 } - | qvarsym1 { $1 } - -qvarsym_no_minus :: { Located RdrName } - : varsym_no_minus { $1 } - | qvarsym1 { $1 } - -qvarsym1 :: { Located RdrName } -qvarsym1 : QVARSYM { sL1 $1 $ mkQual varName (getQVARSYM $1) } - -varsym :: { Located RdrName } - : varsym_no_minus { $1 } - | '-' { sL1 $1 $ mkUnqual varName (fsLit "-") } - -varsym_no_minus :: { Located RdrName } -- varsym not including '-' - : VARSYM { sL1 $1 $ mkUnqual varName (getVARSYM $1) } - | special_sym { sL1 $1 $ mkUnqual varName (unLoc $1) } - - --- These special_ids are treated as keywords in various places, --- but as ordinary ids elsewhere. 'special_id' collects all these --- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and --- 'anyclass', whose treatment differs depending on context -special_id :: { Located FastString } -special_id - : 'as' { sL1 $1 (fsLit "as") } - | 'qualified' { sL1 $1 (fsLit "qualified") } - | 'hiding' { sL1 $1 (fsLit "hiding") } - | 'export' { sL1 $1 (fsLit "export") } - | 'label' { sL1 $1 (fsLit "label") } - | 'dynamic' { sL1 $1 (fsLit "dynamic") } - | 'stdcall' { sL1 $1 (fsLit "stdcall") } - | 'ccall' { sL1 $1 (fsLit "ccall") } - | 'capi' { sL1 $1 (fsLit "capi") } - | 'prim' { sL1 $1 (fsLit "prim") } - | 'javascript' { sL1 $1 (fsLit "javascript") } - | 'group' { sL1 $1 (fsLit "group") } - | 'stock' { sL1 $1 (fsLit "stock") } - | 'anyclass' { sL1 $1 (fsLit "anyclass") } - | 'unit' { sL1 $1 (fsLit "unit") } - | 'dependency' { sL1 $1 (fsLit "dependency") } - | 'signature' { sL1 $1 (fsLit "signature") } - -special_sym :: { Located FastString } -special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] } - | '.' { sL1 $1 (fsLit ".") } - ------------------------------------------------------------------------------ --- Data constructors - -qconid :: { Located RdrName } -- Qualified or unqualified - : conid { $1 } - | QCONID { sL1 $1 $! mkQual dataName (getQCONID $1) } - -conid :: { Located RdrName } - : CONID { sL1 $1 $ mkUnqual dataName (getCONID $1) } - -qconsym :: { Located RdrName } -- Qualified or unqualified - : consym { $1 } - | QCONSYM { sL1 $1 $ mkQual dataName (getQCONSYM $1) } - -consym :: { Located RdrName } - : CONSYM { sL1 $1 $ mkUnqual dataName (getCONSYM $1) } - - -- ':' means only list cons - | ':' { sL1 $1 $ consDataCon_RDR } - - ------------------------------------------------------------------------------ --- Literals - -literal :: { Located HsLit } - : CHAR { sL1 $1 $ HsChar (getCHARs $1) $ getCHAR $1 } - | STRING { sL1 $1 $ HsString (getSTRINGs $1) - $ getSTRING $1 } - | PRIMINTEGER { sL1 $1 $ HsIntPrim (getPRIMINTEGERs $1) - $ getPRIMINTEGER $1 } - | PRIMWORD { sL1 $1 $ HsWordPrim (getPRIMWORDs $1) - $ getPRIMWORD $1 } - | PRIMCHAR { sL1 $1 $ HsCharPrim (getPRIMCHARs $1) - $ getPRIMCHAR $1 } - | PRIMSTRING { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1) - $ getPRIMSTRING $1 } - | PRIMFLOAT { sL1 $1 $ HsFloatPrim $ getPRIMFLOAT $1 } - | PRIMDOUBLE { sL1 $1 $ HsDoublePrim $ getPRIMDOUBLE $1 } - ------------------------------------------------------------------------------ --- Layout - -close :: { () } - : vccurly { () } -- context popped in lexer. - | error {% popContext } - ------------------------------------------------------------------------------ --- Miscellaneous (mostly renamings) - -modid :: { Located ModuleName } - : CONID { sL1 $1 $ mkModuleNameFS (getCONID $1) } - | QCONID { sL1 $1 $ let (mod,c) = getQCONID $1 in - mkModuleNameFS - (mkFastString - (unpackFS mod ++ '.':unpackFS c)) - } - -commas :: { ([SrcSpan],Int) } -- One or more commas - : commas ',' { ((fst $1)++[gl $2],snd $1 + 1) } - | ',' { ([gl $1],1) } - -bars0 :: { ([SrcSpan],Int) } -- Zero or more bars - : bars { $1 } - | { ([], 0) } - -bars :: { ([SrcSpan],Int) } -- One or more bars - : bars '|' { ((fst $1)++[gl $2],snd $1 + 1) } - | '|' { ([gl $1],1) } - ------------------------------------------------------------------------------ --- Documentation comments - -docnext :: { LHsDocString } - : DOCNEXT {% return (sL1 $1 (HsDocString (mkFastString (getDOCNEXT $1)))) } - -docprev :: { LHsDocString } - : DOCPREV {% return (sL1 $1 (HsDocString (mkFastString (getDOCPREV $1)))) } - -docnamed :: { Located (String, HsDocString) } - : DOCNAMED {% - let string = getDOCNAMED $1 - (name, rest) = break isSpace string - in return (sL1 $1 (name, HsDocString (mkFastString rest))) } - -docsection :: { Located (Int, HsDocString) } - : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in - return (sL1 $1 (n, HsDocString (mkFastString doc))) } - -moduleheader :: { Maybe LHsDocString } - : DOCNEXT {% let string = getDOCNEXT $1 in - return (Just (sL1 $1 (HsDocString (mkFastString string)))) } - -maybe_docprev :: { Maybe LHsDocString } - : docprev { Just $1 } - | {- empty -} { Nothing } - -maybe_docnext :: { Maybe LHsDocString } - : docnext { Just $1 } - | {- empty -} { Nothing } - -{ -happyError :: P a -happyError = srcParseFail - -getVARID (L _ (ITvarid x)) = x -getCONID (L _ (ITconid x)) = x -getVARSYM (L _ (ITvarsym x)) = x -getCONSYM (L _ (ITconsym x)) = x -getQVARID (L _ (ITqvarid x)) = x -getQCONID (L _ (ITqconid x)) = x -getQVARSYM (L _ (ITqvarsym x)) = x -getQCONSYM (L _ (ITqconsym x)) = x -getIPDUPVARID (L _ (ITdupipvarid x)) = x -getLABELVARID (L _ (ITlabelvarid x)) = x -getCHAR (L _ (ITchar _ x)) = x -getSTRING (L _ (ITstring _ x)) = x -getINTEGER (L _ (ITinteger _ x)) = x -getRATIONAL (L _ (ITrational x)) = x -getPRIMCHAR (L _ (ITprimchar _ x)) = x -getPRIMSTRING (L _ (ITprimstring _ x)) = x -getPRIMINTEGER (L _ (ITprimint _ x)) = x -getPRIMWORD (L _ (ITprimword _ x)) = x -getPRIMFLOAT (L _ (ITprimfloat x)) = x -getPRIMDOUBLE (L _ (ITprimdouble x)) = x -getTH_ID_SPLICE (L _ (ITidEscape x)) = x -getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x -getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) -getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) -getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) -getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x - -getDOCNEXT (L _ (ITdocCommentNext x)) = x -getDOCPREV (L _ (ITdocCommentPrev x)) = x -getDOCNAMED (L _ (ITdocCommentNamed x)) = x -getDOCSECTION (L _ (ITdocSection n x)) = (n, x) - -getCHARs (L _ (ITchar src _)) = src -getSTRINGs (L _ (ITstring src _)) = src -getINTEGERs (L _ (ITinteger src _)) = src -getPRIMCHARs (L _ (ITprimchar src _)) = src -getPRIMSTRINGs (L _ (ITprimstring src _)) = src -getPRIMINTEGERs (L _ (ITprimint src _)) = src -getPRIMWORDs (L _ (ITprimword src _)) = src - --- See Note [Pragma source text] in BasicTypes for the following -getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src -getSPEC_PRAGs (L _ (ITspec_prag src)) = src -getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src -getSOURCE_PRAGs (L _ (ITsource_prag src)) = src -getRULES_PRAGs (L _ (ITrules_prag src)) = src -getWARNING_PRAGs (L _ (ITwarning_prag src)) = src -getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src -getSCC_PRAGs (L _ (ITscc_prag src)) = src -getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src -getCORE_PRAGs (L _ (ITcore_prag src)) = src -getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src -getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src -getANN_PRAGs (L _ (ITann_prag src)) = src -getVECT_PRAGs (L _ (ITvect_prag src)) = src -getVECT_SCALAR_PRAGs (L _ (ITvect_scalar_prag src)) = src -getNOVECT_PRAGs (L _ (ITnovect_prag src)) = src -getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src -getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src -getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src -getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src -getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src -getCTYPEs (L _ (ITctype src)) = src - -getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) - -isUnicode :: Located Token -> Bool -isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax -isUnicode _ = False - -hasE :: Located Token -> Bool -hasE (L _ (ITopenExpQuote HasE _)) = True -hasE (L _ (ITopenTExpQuote HasE)) = True -hasE _ = False - -getSCC :: Located Token -> P FastString -getSCC lt = do let s = getSTRING lt - err = "Spaces are not allowed in SCCs" - -- We probably actually want to be more restrictive than this - if ' ' `elem` unpackFS s - then failSpanMsgP (getLoc lt) (text err) - else return s - --- Utilities for combining source spans -comb2 :: Located a -> Located b -> SrcSpan -comb2 a b = a `seq` b `seq` combineLocs a b - -comb3 :: Located a -> Located b -> Located c -> SrcSpan -comb3 a b c = a `seq` b `seq` c `seq` - combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) - -comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan -comb4 a b c d = a `seq` b `seq` c `seq` d `seq` - (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ - combineSrcSpans (getLoc c) (getLoc d)) - --- strict constructor version: -{-# INLINE sL #-} -sL :: SrcSpan -> a -> Located a -sL span a = span `seq` a `seq` L span a - --- See Note [Adding location info] for how these utility functions are used - --- replaced last 3 CPP macros in this file -{-# INLINE sL0 #-} -sL0 :: a -> Located a -sL0 = L noSrcSpan -- #define L0 L noSrcSpan - -{-# INLINE sL1 #-} -sL1 :: Located a -> b -> Located b -sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) - -{-# INLINE sLL #-} -sLL :: Located a -> Located b -> c -> Located c -sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) - -{- Note [Adding location info] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -This is done using the three functions below, sL0, sL1 -and sLL. Note that these functions were mechanically -converted from the three macros that used to exist before, -namely L0, L1 and LL. - -They each add a SrcSpan to their argument. - - sL0 adds 'noSrcSpan', used for empty productions - -- This doesn't seem to work anymore -=chak - - sL1 for a production with a single token on the lhs. Grabs the SrcSpan - from that token. - - sLL for a production with >1 token on the lhs. Makes up a SrcSpan from - the first and last tokens. - -These suffice for the majority of cases. However, we must be -especially careful with empty productions: sLL won't work if the first -or last token on the lhs can represent an empty span. In these cases, -we have to calculate the span using more of the tokens from the lhs, eg. - - | 'newtype' tycl_hdr '=' newconstr deriving - { L (comb3 $1 $4 $5) - (mkTyData NewType (unLoc $2) $4 (unLoc $5)) } - -We provide comb3 and comb4 functions which are useful in such cases. - -Be careful: there's no checking that you actually got this right, the -only symptom will be that the SrcSpans of your syntax will be -incorrect. - --} - --- Make a source location for the file. We're a bit lazy here and just --- make a point SrcSpan at line 1, column 0. Strictly speaking we should --- try to find the span of the whole file (ToDo). -fileSrcSpan :: P SrcSpan -fileSrcSpan = do - l <- getSrcLoc; - let loc = mkSrcLoc (srcLocFile l) 1 1; - return (mkSrcSpan loc loc) - --- Hint about the MultiWayIf extension -hintMultiWayIf :: SrcSpan -> P () -hintMultiWayIf span = do - mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState - unless mwiEnabled $ parseErrorSDoc span $ - text "Multi-way if-expressions need MultiWayIf turned on" - --- Hint about if usage for beginners -hintIf :: SrcSpan -> String -> P (LHsExpr RdrName) -hintIf span msg = do - mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState - if mwiEnabled - then parseErrorSDoc span $ text $ "parse error in if statement" - else parseErrorSDoc span $ text $ "parse error in if statement: "++msg - --- Hint about explicit-forall, assuming UnicodeSyntax is on -hintExplicitForall :: SrcSpan -> P () -hintExplicitForall span = do - forall <- extension explicitForallEnabled - rulePrag <- extension inRulePrag - unless (forall || rulePrag) $ parseErrorSDoc span $ vcat - [ text "Illegal symbol '\x2200' in type" -- U+2200 FOR ALL - , text "Perhaps you intended to use RankNTypes or a similar language" - , text "extension to enable explicit-forall syntax: \x2200 . " - ] - --- Hint about explicit-forall, assuming UnicodeSyntax is off -hintExplicitForall' :: SrcSpan -> P (GenLocated SrcSpan RdrName) -hintExplicitForall' span = do - forall <- extension explicitForallEnabled - let illegalDot = "Illegal symbol '.' in type" - if forall - then parseErrorSDoc span $ vcat - [ text illegalDot - , text "Perhaps you meant to write 'forall . '?" - ] - else parseErrorSDoc span $ vcat - [ text illegalDot - , text "Perhaps you intended to use RankNTypes or a similar language" - , text "extension to enable explicit-forall syntax: forall . " - ] - -{- -%************************************************************************ -%* * - Helper functions for generating annotations in the parser -%* * -%************************************************************************ - -For the general principles of the following routines, see Note [Api annotations] -in ApiAnnotation.hs - --} - --- |Construct an AddAnn from the annotation keyword and the location --- of the keyword itself -mj :: AnnKeywordId -> Located e -> AddAnn -mj a l s = addAnnotation s a (gl l) - --- |Construct an AddAnn from the annotation keyword and the Located Token. If --- the token has a unicode equivalent and this has been used, provide the --- unicode variant of the annotation. -mu :: AnnKeywordId -> Located Token -> AddAnn -mu a lt@(L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l) - --- | If the 'Token' is using its unicode variant return the unicode variant of --- the annotation -toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId -toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a - -gl = getLoc - --- |Add an annotation to the located element, and return the located --- element as a pass through -aa :: Located a -> (AnnKeywordId,Located c) -> P (Located a) -aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a - --- |Add an annotation to a located element resulting from a monadic action -am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a) -am a (b,s) = do - av@(L l _) <- a - addAnnotation l b (gl s) - return av - --- | Add a list of AddAnns to the given AST element. For example, --- the parsing rule for @let@ looks like: --- --- @ --- | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) --- (mj AnnLet $1:mj AnnIn $3 --- :(fst $ unLoc $2)) } --- @ --- --- This adds an AnnLet annotation for @let@, an AnnIn for @in@, as well --- as any annotations that may arise in the binds. This will include open --- and closing braces if they are used to delimit the let expressions. --- -ams :: Located a -> [AddAnn] -> P (Located a) -ams a@(L l _) bs = addAnnsAt l bs >> return a - --- |Add all [AddAnn] to an AST element wrapped in a Just -aljs :: Located (Maybe a) -> [AddAnn] -> P (Located (Maybe a)) -aljs a@(L l _) bs = addAnnsAt l bs >> return a - --- |Add all [AddAnn] to an AST element wrapped in a Just -ajs a@(Just (L l _)) bs = addAnnsAt l bs >> return a - --- |Add a list of AddAnns to the given AST element, where the AST element is the --- result of a monadic action -amms :: P (Located a) -> [AddAnn] -> P (Located a) -amms a bs = do { av@(L l _) <- a - ; addAnnsAt l bs - ; return av } - --- |Add a list of AddAnns to the AST element, and return the element as a --- OrdList -amsu :: Located a -> [AddAnn] -> P (OrdList (Located a)) -amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a) - --- |Synonyms for AddAnn versions of AnnOpen and AnnClose -mo,mc :: Located Token -> AddAnn -mo ll = mj AnnOpen ll -mc ll = mj AnnClose ll - -moc,mcc :: Located Token -> AddAnn -moc ll = mj AnnOpenC ll -mcc ll = mj AnnCloseC ll - -mop,mcp :: Located Token -> AddAnn -mop ll = mj AnnOpenP ll -mcp ll = mj AnnCloseP ll - -mos,mcs :: Located Token -> AddAnn -mos ll = mj AnnOpenS ll -mcs ll = mj AnnCloseS ll - --- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma --- entry for each SrcSpan -mcommas :: [SrcSpan] -> [AddAnn] -mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss - --- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar --- entry for each SrcSpan -mvbars :: [SrcSpan] -> [AddAnn] -mvbars ss = map (\s -> mj AnnVbar (L s ())) ss - --- |Get the location of the last element of a OrdList, or noSrcSpan -oll :: OrdList (Located a) -> SrcSpan -oll l = - if isNilOL l then noSrcSpan - else getLoc (lastOL l) - --- |Add a semicolon annotation in the right place in a list. If the --- leading list is empty, add it to the tail -asl :: [Located a] -> Located b -> Located a -> P() -asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls -asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls -} diff --git a/parser/RdrHsSyn.hs b/parser/RdrHsSyn.hs deleted file mode 100644 --- a/parser/RdrHsSyn.hs +++ /dev/null @@ -1,1562 +0,0 @@ --- --- (c) The University of Glasgow 2002-2006 --- - --- Functions over HsSyn specialised to RdrName. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -module RdrHsSyn ( - mkHsOpApp, - mkHsIntegral, mkHsFractional, mkHsIsString, - mkHsDo, mkSpliceDecl, - mkRoleAnnotDecl, - mkClassDecl, - mkTyData, mkDataFamInst, - mkTySynonym, mkTyFamInstEqn, - mkTyFamInst, - mkFamDecl, mkLHsSigType, - splitCon, mkInlinePragma, - mkPatSynMatchGroup, - mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp - mkTyClD, mkInstD, - mkRdrRecordCon, mkRdrRecordUpd, - setRdrNameSpace, - - cvBindGroup, - cvBindsAndSigs, - cvTopDecls, - placeHolderPunRhs, - - -- Stuff to do with Foreign declarations - mkImport, - parseCImport, - mkExport, - mkExtName, -- RdrName -> CLabelString - mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName - mkConDeclH98, - mkATDefault, - - -- Bunch of functions in the parser monad for - -- checking and constructing values - checkPrecP, -- Int -> P Int - checkContext, -- HsType -> P HsContext - checkPattern, -- HsExp -> P HsPat - bang_RDR, - checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] - checkMonadComp, -- P (HsStmtContext RdrName) - checkCommand, -- LHsExpr RdrName -> P (LHsCmd RdrName) - checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl - checkValSigLhs, - checkDoAndIfThenElse, - checkRecordSyntax, - parseErrorSDoc, - splitTilde, splitTildeApps, - - -- Help with processing exports - ImpExpSubSpec(..), - ImpExpQcSpec(..), - mkModuleImpExp, - mkTypeImpExp, - mkImpExpSubSpec, - checkImportSpec, - - SumOrTuple (..), mkSumOrTuple - - ) where - -import HsSyn -- Lots of it -import Class ( FunDep ) -import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) -import DataCon ( DataCon, dataConTyCon ) -import ConLike ( ConLike(..) ) -import CoAxiom ( Role, fsFromRole ) -import RdrName -import Name -import BasicTypes -import TcEvidence ( idHsWrapper ) -import Lexer -import Lexeme ( isLexCon ) -import Type ( TyThing(..) ) -import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, - nilDataConName, nilDataConKey, - listTyConName, listTyConKey, - starKindTyConName, unicodeStarKindTyConName ) -import ForeignCall -import PrelNames ( forall_tv_RDR, eqTyCon_RDR, allNameStrings ) -import SrcLoc -import Unique ( hasKey ) -import OrdList ( OrdList, fromOL ) -import Bag ( emptyBag, consBag ) -import Outputable -import FastString -import Maybes -import Util -import ApiAnnotation -import Data.List -import qualified GHC.LanguageExtensions as LangExt -import MonadUtils - -import Control.Monad -import Text.ParserCombinators.ReadP as ReadP -import Data.Char - -import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) - -#include "HsVersions.h" - - -{- ********************************************************************** - - Construction functions for Rdr stuff - - ********************************************************************* -} - --- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and --- datacon by deriving them from the name of the class. We fill in the names --- for the tycon and datacon corresponding to the class, by deriving them --- from the name of the class itself. This saves recording the names in the --- interface file (which would be equally good). - --- Similarly for mkConDecl, mkClassOpSig and default-method names. - --- *** See Note [The Naming story] in HsDecls **** - -mkTyClD :: LTyClDecl n -> LHsDecl n -mkTyClD (L loc d) = L loc (TyClD d) - -mkInstD :: LInstDecl n -> LHsDecl n -mkInstD (L loc d) = L loc (InstD d) - -mkClassDecl :: SrcSpan - -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Located (a,[Located (FunDep (Located RdrName))]) - -> OrdList (LHsDecl RdrName) - -> P (LTyClDecl RdrName) - -mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls - = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls - ; let cxt = fromMaybe (noLoc []) mcxt - ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr - ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan - ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams - ; at_defs <- mapM (eitherToP . mkATDefault) at_insts - ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdFDs = snd (unLoc fds) - , tcdSigs = mkClassOpSigs sigs - , tcdMeths = binds - , tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs - , tcdFVs = placeHolderNames })) } - -mkATDefault :: LTyFamInstDecl RdrName - -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName) --- Take a type-family instance declaration and turn it into --- a type-family default equation for a class declaration --- We parse things as the former and use this function to convert to the latter --- --- We use the Either monad because this also called --- from Convert.hs -mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) - | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity - , tfe_rhs = rhs } <- e - = do { tvs <- checkTyVars (text "default") equalsDots tc (hsib_body pats) - ; return (L loc (TyFamEqn { tfe_tycon = tc - , tfe_pats = tvs - , tfe_fixity = fixity - , tfe_rhs = rhs })) } - -mkTyData :: SrcSpan - -> NewOrData - -> Maybe (Located CType) - -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe (LHsKind RdrName) - -> [LConDecl RdrName] - -> HsDeriving RdrName - -> P (LTyClDecl RdrName) -mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan - ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdDataDefn = defn, - tcdDataCusk = PlaceHolder, - tcdFVs = placeHolderNames })) } - -mkDataDefn :: NewOrData - -> Maybe (Located CType) - -> Maybe (LHsContext RdrName) - -> Maybe (LHsKind RdrName) - -> [LConDecl RdrName] - -> HsDeriving RdrName - -> P (HsDataDefn RdrName) -mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - = do { checkDatatypeContext mcxt - ; let cxt = fromMaybe (noLoc []) mcxt - ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = cxt - , dd_cons = data_cons - , dd_kindSig = ksig - , dd_derivs = maybe_deriv }) } - - -mkTySynonym :: SrcSpan - -> LHsType RdrName -- LHS - -> LHsType RdrName -- RHS - -> P (LTyClDecl RdrName) -mkTySynonym loc lhs rhs - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan - ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams - ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdRhs = rhs, tcdFVs = placeHolderNames })) } - -mkTyFamInstEqn :: LHsType RdrName - -> LHsType RdrName - -> P (TyFamInstEqn RdrName,[AddAnn]) -mkTyFamInstEqn lhs rhs - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; return (TyFamEqn { tfe_tycon = tc - , tfe_pats = mkHsImplicitBndrs tparams - , tfe_fixity = fixity - , tfe_rhs = rhs }, - ann) } - -mkDataFamInst :: SrcSpan - -> NewOrData - -> Maybe (Located CType) - -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe (LHsKind RdrName) - -> [LConDecl RdrName] - -> HsDeriving RdrName - -> P (LInstDecl RdrName) -mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataFamInstD ( - DataFamInstDecl { dfid_tycon = tc - , dfid_pats = mkHsImplicitBndrs tparams - , dfid_fixity = fixity - , dfid_defn = defn, dfid_fvs = placeHolderNames }))) } - -mkTyFamInst :: SrcSpan - -> LTyFamInstEqn RdrName - -> P (LInstDecl RdrName) -mkTyFamInst loc eqn - = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn - , tfid_fvs = placeHolderNames }))) - -mkFamDecl :: SrcSpan - -> FamilyInfo RdrName - -> LHsType RdrName -- LHS - -> Located (FamilyResultSig RdrName) -- Optional result signature - -> Maybe (LInjectivityAnn RdrName) -- Injectivity annotation - -> P (LTyClDecl RdrName) -mkFamDecl loc info lhs ksig injAnn - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan - ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams - ; return (L loc (FamDecl (FamilyDecl{ fdInfo = info, fdLName = tc - , fdTyVars = tyvars - , fdFixity = fixity - , fdResultSig = ksig - , fdInjectivityAnn = injAnn }))) } - where - equals_or_where = case info of - DataFamily -> empty - OpenTypeFamily -> empty - ClosedTypeFamily {} -> whereDots - -mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName --- If the user wrote --- [pads| ... ] then return a QuasiQuoteD --- $(e) then return a SpliceD --- but if she wrote, say, --- f x then behave as if she'd written $(f x) --- ie a SpliceD --- --- Typed splices are not allowed at the top level, thus we do not represent them --- as spliced declaration. See #10945 -mkSpliceDecl lexpr@(L loc expr) - | HsSpliceE splice@(HsUntypedSplice {}) <- expr - = SpliceD (SpliceDecl (L loc splice) ExplicitSplice) - - | HsSpliceE splice@(HsQuasiQuote {}) <- expr - = SpliceD (SpliceDecl (L loc splice) ExplicitSplice) - - | otherwise - = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice) - -mkRoleAnnotDecl :: SrcSpan - -> Located RdrName -- type being annotated - -> [Located (Maybe FastString)] -- roles - -> P (LRoleAnnotDecl RdrName) -mkRoleAnnotDecl loc tycon roles - = do { roles' <- mapM parse_role roles - ; return $ L loc $ RoleAnnotDecl tycon roles' } - where - role_data_type = dataTypeOf (undefined :: Role) - all_roles = map fromConstr $ dataTypeConstrs role_data_type - possible_roles = [(fsFromRole role, role) | role <- all_roles] - - parse_role (L loc_role Nothing) = return $ L loc_role Nothing - parse_role (L loc_role (Just role)) - = case lookup role possible_roles of - Just found_role -> return $ L loc_role $ Just found_role - Nothing -> - let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in - parseErrorSDoc loc_role - (text "Illegal role name" <+> quotes (ppr role) $$ - suggestions nearby) - - suggestions [] = empty - suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r) - -- will this last case ever happen?? - suggestions list = hang (text "Perhaps you meant one of these:") - 2 (pprWithCommas (quotes . ppr) list) - -{- ********************************************************************** - - #cvBinds-etc# Converting to @HsBinds@, etc. - - ********************************************************************* -} - --- | Function definitions are restructured here. Each is assumed to be recursive --- initially, and non recursive definitions are discovered by the dependency --- analyser. - - --- | Groups together bindings for a single function -cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName] -cvTopDecls decls = go (fromOL decls) - where - go :: [LHsDecl RdrName] -> [LHsDecl RdrName] - go [] = [] - go (L l (ValD b) : ds) = L l' (ValD b') : go ds' - where (L l' b', ds') = getMonoBind (L l b) ds - go (d : ds) = d : go ds - --- Declaration list may only contain value bindings and signatures. -cvBindGroup :: OrdList (LHsDecl RdrName) -> P (HsValBinds RdrName) -cvBindGroup binding - = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding - ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) - return $ ValBindsIn mbs sigs } - -cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> P (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName] - , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl]) --- Input decls contain just value bindings and signatures --- and in case of class or instance declarations also --- associated type declarations. They might also contain Haddock comments. -cvBindsAndSigs fb = go (fromOL fb) - where - go [] = return (emptyBag, [], [], [], [], []) - go (L l (ValD b) : ds) - = do { (bs, ss, ts, tfis, dfis, docs) <- go ds' - ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) } - where - (b', ds') = getMonoBind (L l b) ds - go (L l decl : ds) - = do { (bs, ss, ts, tfis, dfis, docs) <- go ds - ; case decl of - SigD s - -> return (bs, L l s : ss, ts, tfis, dfis, docs) - TyClD (FamDecl t) - -> return (bs, ss, L l t : ts, tfis, dfis, docs) - InstD (TyFamInstD { tfid_inst = tfi }) - -> return (bs, ss, ts, L l tfi : tfis, dfis, docs) - InstD (DataFamInstD { dfid_inst = dfi }) - -> return (bs, ss, ts, tfis, L l dfi : dfis, docs) - DocD d - -> return (bs, ss, ts, tfis, dfis, L l d : docs) - SpliceD d - -> parseErrorSDoc l $ - hang (text "Declaration splices are allowed only" <+> - text "at the top level:") - 2 (ppr d) - _ -> pprPanic "cvBindsAndSigs" (ppr decl) } - ------------------------------------------------------------------------------ --- Group function bindings into equation groups - -getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] - -> (LHsBind RdrName, [LHsDecl RdrName]) --- Suppose (b',ds') = getMonoBind b ds --- ds is a list of parsed bindings --- b is a MonoBinds that has just been read off the front - --- Then b' is the result of grouping more equations from ds that --- belong with b into a single MonoBinds, and ds' is the depleted --- list of parsed bindings. --- --- All Haddock comments between equations inside the group are --- discarded. --- --- No AndMonoBinds or EmptyMonoBinds here; just single equations - -getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), - fun_matches - = MG { mg_alts = L _ mtchs1 } })) binds - | has_args mtchs1 - = go mtchs1 loc1 binds [] - where - go mtchs loc - (L loc2 (ValD (FunBind { fun_id = L _ f2, - fun_matches - = MG { mg_alts = L _ mtchs2 } })) : binds) _ - | f1 == f2 = go (mtchs2 ++ mtchs) - (combineSrcSpans loc loc2) binds [] - go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls - = let doc_decls' = doc_decl : doc_decls - in go mtchs (combineSrcSpans loc loc2) binds doc_decls' - go mtchs loc binds doc_decls - = ( L loc (makeFunBind fun_id1 (reverse mtchs)) - , (reverse doc_decls) ++ binds) - -- Reverse the final matches, to get it back in the right order - -- Do the same thing with the trailing doc comments - -getMonoBind bind binds = (bind, binds) - -has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool -has_args [] = panic "RdrHsSyn:has_args" -has_args ((L _ (Match _ args _ _)) : _) = not (null args) - -- Don't group together FunBinds if they have - -- no arguments. This is necessary now that variable bindings - -- with no arguments are now treated as FunBinds rather - -- than pattern bindings (tests/rename/should_fail/rnfail002). - -{- ********************************************************************** - - #PrefixToHS-utils# Utilities for conversion - - ********************************************************************* -} - -{- Note [Parsing data constructors is hard] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We parse the RHS of the constructor declaration - data T = C t1 t2 -as a btype_no_ops (treating C as a type constructor) and then convert C to be -a data constructor. Reason: it might continue like this: - data T = C t1 t2 :% D Int -in which case C really /would/ be a type constructor. We can't resolve this -ambiguity till we come across the constructor oprerator :% (or not, more usually) - -So the plan is: - -* Parse the data constructor declration as a type (actually btype_no_ops) - -* Use 'splitCon' to rejig it into the data constructor and the args - -* In doing so, we use 'tyConToDataCon' to convert the RdrName for - the data con, which has been parsed as a tycon, back to a datacon. - This is more than just adjusting the name space; for operators we - need to check that it begins with a colon. E.g. - data T = (+++) - will parse ok (since tycons can be operators), but we should reject - it (Trac #12051). --} - -splitCon :: LHsType RdrName - -> P (Located RdrName, HsConDeclDetails RdrName) --- See Note [Parsing data constructors is hard] --- This gets given a "type" that should look like --- C Int Bool --- or C { x::Int, y::Bool } --- and returns the pieces -splitCon ty - = split ty [] - where - -- This is used somewhere where HsAppsTy is not used - split (L _ (HsAppTy t u)) ts = split t (u : ts) - split (L l (HsTyVar _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc - return (data_con, mk_rest ts) - split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) [] - = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts) - split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty) - - mk_rest [L l (HsRecTy flds)] = RecCon (L l flds) - mk_rest ts = PrefixCon ts - -tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) --- See Note [Parsing data constructors is hard] --- Data constructor RHSs are parsed as types -tyConToDataCon loc tc - | isTcOcc occ - , isLexCon (occNameFS occ) - = return (L loc (setRdrNameSpace tc srcDataName)) - - | otherwise - = parseErrorSDoc loc (msg $$ extra) - where - occ = rdrNameOcc tc - - msg = text "Not a data constructor:" <+> quotes (ppr tc) - extra | tc == forall_tv_RDR - = text "Perhaps you intended to use ExistentialQuantification" - | otherwise = empty - -mkPatSynMatchGroup :: Located RdrName - -> Located (OrdList (LHsDecl RdrName)) - -> P (MatchGroup RdrName (LHsExpr RdrName)) -mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = - do { matches <- mapM fromDecl (fromOL decls) - ; when (null matches) (wrongNumberErr loc) - ; return $ mkMatchGroup FromSource matches } - where - fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _ _ _))) = - do { unless (name == patsyn_name) $ - wrongNameBindingErr loc decl - ; match <- case details of - PrefixCon pats -> - return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs - InfixCon pat1 pat2 -> - return $ Match (FunRhs ln Infix NoSrcStrict) [pat1, pat2] Nothing rhs - RecCon{} -> recordPatSynErr loc pat - ; return $ L loc match } - fromDecl (L loc decl) = extraDeclErr loc decl - - extraDeclErr loc decl = - parseErrorSDoc loc $ - text "pattern synonym 'where' clause must contain a single binding:" $$ - ppr decl - - wrongNameBindingErr loc decl = - parseErrorSDoc loc $ - text "pattern synonym 'where' clause must bind the pattern synonym's name" <+> - quotes (ppr patsyn_name) $$ ppr decl - - wrongNumberErr loc = - parseErrorSDoc loc $ - text "pattern synonym 'where' clause cannot be empty" $$ - text "In the pattern synonym declaration for: " <+> ppr (patsyn_name) - -recordPatSynErr :: SrcSpan -> LPat RdrName -> P a -recordPatSynErr loc pat = - parseErrorSDoc loc $ - text "record syntax not supported for pattern synonym declarations:" $$ - ppr pat - -mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName] - -> LHsContext RdrName -> HsConDeclDetails RdrName - -> ConDecl RdrName - -mkConDeclH98 name mb_forall cxt details - = ConDeclH98 { con_name = name - , con_qvars = fmap mkHsQTvs mb_forall - , con_cxt = Just cxt - -- AZ:TODO: when can cxt be Nothing? - -- remembering that () is a valid context. - , con_details = details - , con_doc = Nothing } - -mkGadtDecl :: [Located RdrName] - -> LHsSigType RdrName -- Always a HsForAllTy - -> ConDecl RdrName -mkGadtDecl names ty = ConDeclGADT { con_names = names - , con_type = ty - , con_doc = Nothing } - -setRdrNameSpace :: RdrName -> NameSpace -> RdrName --- ^ This rather gruesome function is used mainly by the parser. --- When parsing: --- --- > data T a = T | T1 Int --- --- we parse the data constructors as /types/ because of parser ambiguities, --- so then we need to change the /type constr/ to a /data constr/ --- --- The exact-name case /can/ occur when parsing: --- --- > data [] a = [] | a : [a] --- --- For the exact-name case we return an original name. -setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) -setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) -setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns - | Just thing <- wiredInNameTyThing_maybe n - = setWiredInNameSpace thing ns - -- Preserve Exact Names for wired-in things, - -- notably tuples and lists - - | isExternalName n - = Orig (nameModule n) occ - - | otherwise -- This can happen when quoting and then - -- splicing a fixity declaration for a type - = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) - where - occ = setOccNameSpace ns (nameOccName n) - -setWiredInNameSpace :: TyThing -> NameSpace -> RdrName -setWiredInNameSpace (ATyCon tc) ns - | isDataConNameSpace ns - = ty_con_data_con tc - | isTcClsNameSpace ns - = Exact (getName tc) -- No-op - -setWiredInNameSpace (AConLike (RealDataCon dc)) ns - | isTcClsNameSpace ns - = data_con_ty_con dc - | isDataConNameSpace ns - = Exact (getName dc) -- No-op - -setWiredInNameSpace thing ns - = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) - -ty_con_data_con :: TyCon -> RdrName -ty_con_data_con tc - | isTupleTyCon tc - , Just dc <- tyConSingleDataCon_maybe tc - = Exact (getName dc) - - | tc `hasKey` listTyConKey - = Exact nilDataConName - - | otherwise -- See Note [setRdrNameSpace for wired-in names] - = Unqual (setOccNameSpace srcDataName (getOccName tc)) - -data_con_ty_con :: DataCon -> RdrName -data_con_ty_con dc - | let tc = dataConTyCon dc - , isTupleTyCon tc - = Exact (getName tc) - - | dc `hasKey` nilDataConKey - = Exact listTyConName - - | otherwise -- See Note [setRdrNameSpace for wired-in names] - = Unqual (setOccNameSpace tcClsName (getOccName dc)) - - -{- Note [setRdrNameSpace for wired-in names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHC.Types, which declares (:), we have - infixr 5 : -The ambiguity about which ":" is meant is resolved by parsing it as a -data constructor, but then using dataTcOccs to try the type constructor too; -and that in turn calls setRdrNameSpace to change the name-space of ":" to -tcClsName. There isn't a corresponding ":" type constructor, but it's painful -to make setRdrNameSpace partial, so we just make an Unqual name instead. It -really doesn't matter! --} - --- | Note [Sorting out the result type] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In a GADT declaration which is not a record, we put the whole constr type --- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once --- it has sorted out operator fixities. Consider for example --- C :: a :*: b -> a :*: b -> a :+: b --- Initially this type will parse as --- a :*: (b -> (a :*: (b -> (a :+: b)))) --- --- so it's hard to split up the arguments until we've done the precedence --- resolution (in the renamer). On the other hand, for a record --- { x,y :: Int } -> a :*: b --- there is no doubt. AND we need to sort records out so that --- we can bring x,y into scope. So: --- * For PrefixCon we keep all the args in the res_ty --- * For RecCon we do not - -checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName) --- Same as checkTyVars, but in the P monad -checkTyVarsP pp_what equals_or_where tc tparms - = eitherToP $ checkTyVars pp_what equals_or_where tc tparms - -eitherToP :: Either (SrcSpan, SDoc) a -> P a --- Adapts the Either monad to the P monad -eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc -eitherToP (Right thing) = return thing - -checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] - -> Either (SrcSpan, SDoc) (LHsQTyVars RdrName) --- Check whether the given list of type parameters are all type variables --- (possibly with a kind signature) --- We use the Either monad because it's also called (via mkATDefault) from --- Convert.hs -checkTyVars pp_what equals_or_where tc tparms - = do { tvs <- mapM chk tparms - ; return (mkHsQTvs tvs) } - where - - chk (L _ (HsParTy ty)) = chk ty - chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty - - -- Check that the name space is correct! - chk (L l (HsKindSig - (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k)) - | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k)) - chk (L l (HsTyVar _ (L ltv tv))) - | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv))) - chk t@(L loc _) - = Left (loc, - vcat [ text "Unexpected type" <+> quotes (ppr t) - , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc) - , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form")) - , nest 2 (pp_what <+> ppr tc - <+> hsep (map text (takeList tparms allNameStrings)) - <+> equals_or_where) ] ]) - -whereDots, equalsDots :: SDoc --- Second argument to checkTyVars -whereDots = text "where ..." -equalsDots = text "= ..." - -checkDatatypeContext :: Maybe (LHsContext RdrName) -> P () -checkDatatypeContext Nothing = return () -checkDatatypeContext (Just (L loc c)) - = do allowed <- extension datatypeContextsEnabled - unless allowed $ - parseErrorSDoc loc - (text "Illegal datatype context (use DatatypeContexts):" <+> - pprHsContext c) - -checkRecordSyntax :: Outputable a => Located a -> P (Located a) -checkRecordSyntax lr@(L loc r) - = do allowed <- extension traditionalRecordSyntaxEnabled - if allowed - then return lr - else parseErrorSDoc loc - (text "Illegal record syntax (use TraditionalRecordSyntax):" <+> - ppr r) - -checkTyClHdr :: Bool -- True <=> class header - -- False <=> type header - -> LHsType RdrName - -> P (Located RdrName, -- the head symbol (type or class name) - [LHsType RdrName], -- parameters of head symbol - LexicalFixity, -- the declaration is in infix format - [AddAnn]) -- API Annotation for HsParTy when stripping parens --- Well-formedness check and decomposition of type and class heads. --- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) --- Int :*: Bool into (:*:, [Int, Bool]) --- returning the pieces -checkTyClHdr is_cls ty - = goL ty [] [] Prefix - where - goL (L l ty) acc ann fix = go l ty acc ann fix - - go l (HsTyVar _ (L _ tc)) acc ann fix - | isRdrTc tc = return (L l tc, acc, fix, ann) - go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix - | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann) - go l (HsParTy ty) acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix - go _ (HsAppTy t1 t2) acc ann fix = goL t1 (t2:acc) ann fix - go _ (HsAppsTy ts) acc ann _fix - | Just (head, args, fixity) <- getAppsTyHead_maybe ts - = goL head (args ++ acc) ann fixity - - go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix - | occNameFS (rdrNameOcc star) == fsLit "*" - = return (L loc (nameRdrName starKindTyConName), [], fix, ann) - | occNameFS (rdrNameOcc star) == fsLit "★" - = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann) - - go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix - = return (L l (nameRdrName tup_name), ts, fix, ann) - where - arity = length ts - tup_name | is_cls = cTupleTyConName arity - | otherwise = getName (tupleTyCon Boxed arity) - -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?) - go l _ _ _ _ - = parseErrorSDoc l (text "Malformed head of type or class declaration:" - <+> ppr ty) - -checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName) -checkContext (L l orig_t) - = check [] (L l orig_t) - where - check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type - = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () - - -- don't let HsAppsTy get in the way - check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) - = check anns ty - - check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way - = check anns' ty - where anns' = if l == lp1 then anns - else (anns ++ mkParensApiAnn lp1) - - check _anns _ - = return ([],L l [L l orig_t]) -- no need for anns, returning original - --- ------------------------------------------------------------------------- --- Checking Patterns. - --- We parse patterns as expressions and check for valid patterns below, --- converting the expression into a pattern at the same time. - -checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName) -checkPattern msg e = checkLPat msg e - -checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName] -checkPatterns msg es = mapM (checkPattern msg) es - -checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName) -checkLPat msg e@(L l _) = checkPat msg l e [] - -checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName] - -> P (LPat RdrName) -checkPat _ loc (L l (HsVar (L _ c))) args - | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) -checkPat msg loc e args -- OK to let this happen even if bang-patterns - -- are not enabled, because there is no valid - -- non-bang-pattern parse of (C ! e) - | Just (e', args') <- splitBang e - = do { args'' <- checkPatterns msg args' - ; checkPat msg loc e' (args'' ++ args) } -checkPat msg loc (L _ (HsApp f e)) args - = do p <- checkLPat msg e - checkPat msg loc f (p : args) -checkPat msg loc (L _ e) [] - = do p <- checkAPat msg loc e - return (L loc p) -checkPat msg loc e _ - = patFail msg loc (unLoc e) - -checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName) -checkAPat msg loc e0 = do - pState <- getPState - let opts = options pState - case e0 of - EWildPat -> return (WildPat placeHolderType) - HsVar x -> return (VarPat x) - HsLit (HsStringPrim _ _) -- (#13260) - -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0) - - HsLit l -> return (LitPat l) - - -- Overloaded numeric patterns (e.g. f 0 x = x) - -- Negation is recorded separately, so that the literal is zero or +ve - -- NB. Negative *primitive* literals are already handled by the lexer - HsOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing) - NegApp (L l (HsOverLit pos_lit)) _ - -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr)) - - SectionR (L lb (HsVar (L _ bang))) e -- (! x) - | bang == bang_RDR - -> do { bang_on <- extension bangPatEnabled - ; if bang_on then do { e' <- checkLPat msg e - ; addAnnotation loc AnnBang lb - ; return (BangPat e') } - else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) } - - ELazyPat e -> checkLPat msg e >>= (return . LazyPat) - EAsPat n e -> checkLPat msg e >>= (return . AsPat n) - -- view pattern is well-formed if the pattern is - EViewPat expr patE -> checkLPat msg patE >>= - (return . (\p -> ViewPat expr p placeHolderType)) - ExprWithTySig e t -> do e <- checkLPat msg e - return (SigPatIn e t) - - -- n+k patterns - OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _ - (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) - | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR) - -> return (mkNPlusKPat (L nloc n) (L lloc lit)) - - OpApp l op _fix r -> do l <- checkLPat msg l - r <- checkLPat msg r - case op of - L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c) - -> return (ConPatIn (L cl c) (InfixCon l r)) - _ -> patFail msg loc e0 - - HsPar e -> checkLPat msg e >>= (return . ParPat) - ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es - return (ListPat ps placeHolderType Nothing) - ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es - return (PArrPat ps placeHolderType) - - ExplicitTuple es b - | all tupArgPresent es -> do ps <- mapM (checkLPat msg) - [e | L _ (Present e) <- es] - return (TuplePat ps b []) - | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) - - ExplicitSum alt arity expr _ -> do - p <- checkLPat msg expr - return (SumPat p alt arity placeHolderType) - - RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd } - -> do fs <- mapM (checkPatField msg) fs - return (ConPatIn c (RecCon (HsRecFields fs dd))) - HsSpliceE s | not (isTypedSplice s) - -> return (SplicePat s) - _ -> patFail msg loc e0 - -placeHolderPunRhs :: LHsExpr RdrName --- The RHS of a punned record field will be filled in by the renamer --- It's better not to make it an error, in case we want to print it when debugging -placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR)) - -plus_RDR, bang_RDR, pun_RDR :: RdrName -plus_RDR = mkUnqual varName (fsLit "+") -- Hack -bang_RDR = mkUnqual varName (fsLit "!") -- Hack -pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") - -checkPatField :: SDoc -> LHsRecField RdrName (LHsExpr RdrName) - -> P (LHsRecField RdrName (LPat RdrName)) -checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) - return (L l (fld { hsRecFieldArg = p })) - -patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a -patFail msg loc e = parseErrorSDoc loc err - where err = text "Parse error in pattern:" <+> ppr e - $$ msg - - ---------------------------------------------------------------------------- --- Check Equation Syntax - -checkValDef :: SDoc - -> SrcStrictness - -> LHsExpr RdrName - -> Maybe (LHsType RdrName) - -> Located (a,GRHSs RdrName (LHsExpr RdrName)) - -> P ([AddAnn],HsBind RdrName) - -checkValDef msg _strictness lhs (Just sig) grhss - -- x :: ty = rhs parses as a *pattern* binding - = checkPatBind msg (L (combineLocs lhs sig) - (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss - -checkValDef msg strictness lhs opt_sig g@(L l (_,grhss)) - = do { mb_fun <- isFunLhs lhs - ; case mb_fun of - Just (fun, is_infix, pats, ann) -> - checkFunBind msg strictness ann (getLoc lhs) - fun is_infix pats opt_sig (L l grhss) - Nothing -> checkPatBind msg lhs g } - -checkFunBind :: SDoc - -> SrcStrictness - -> [AddAnn] - -> SrcSpan - -> Located RdrName - -> LexicalFixity - -> [LHsExpr RdrName] - -> Maybe (LHsType RdrName) - -> Located (GRHSs RdrName (LHsExpr RdrName)) - -> P ([AddAnn],HsBind RdrName) -checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) - = do ps <- checkPatterns msg pats - let match_span = combineSrcSpans lhs_loc rhs_span - -- Add back the annotations stripped from any HsPar values in the lhs - -- mapM_ (\a -> a match_span) ann - return (ann, makeFunBind fun - [L match_span (Match { m_ctxt = FunRhs fun is_infix strictness - , m_pats = ps - , m_type = opt_sig - , m_grhss = grhss })]) - -- The span of the match covers the entire equation. - -- That isn't quite right, but it'll do for now. - -makeFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] - -> HsBind RdrName --- Like HsUtils.mkFunBind, but we need to be able to set the fixity too -makeFunBind fn ms - = FunBind { fun_id = fn, - fun_matches = mkMatchGroup FromSource ms, - fun_co_fn = idHsWrapper, - bind_fvs = placeHolderNames, - fun_tick = [] } - -checkPatBind :: SDoc - -> LHsExpr RdrName - -> Located (a,GRHSs RdrName (LHsExpr RdrName)) - -> P ([AddAnn],HsBind RdrName) -checkPatBind msg lhs (L _ (_,grhss)) - = do { lhs <- checkPattern msg lhs - ; return ([],PatBind lhs grhss placeHolderType placeHolderNames - ([],[])) } - -checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName) -checkValSigLhs (L _ (HsVar lrdr@(L _ v))) - | isUnqual v - , not (isDataOcc (rdrNameOcc v)) - = return lrdr - -checkValSigLhs lhs@(L l _) - = parseErrorSDoc l ((text "Invalid type signature:" <+> - ppr lhs <+> text ":: ...") - $$ text hint) - where - hint | foreign_RDR `looks_like` lhs - = "Perhaps you meant to use ForeignFunctionInterface?" - | default_RDR `looks_like` lhs - = "Perhaps you meant to use DefaultSignatures?" - | pattern_RDR `looks_like` lhs - = "Perhaps you meant to use PatternSynonyms?" - | otherwise - = "Should be of form :: " - - -- A common error is to forget the ForeignFunctionInterface flag - -- so check for that, and suggest. cf Trac #3805 - -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword - looks_like s (L _ (HsVar (L _ v))) = v == s - looks_like s (L _ (HsApp lhs _)) = looks_like s lhs - looks_like _ _ = False - - foreign_RDR = mkUnqual varName (fsLit "foreign") - default_RDR = mkUnqual varName (fsLit "default") - pattern_RDR = mkUnqual varName (fsLit "pattern") - - -checkDoAndIfThenElse :: LHsExpr RdrName - -> Bool - -> LHsExpr RdrName - -> Bool - -> LHsExpr RdrName - -> P () -checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr - | semiThen || semiElse - = do pState <- getPState - unless (extopt LangExt.DoAndIfThenElse (options pState)) $ do - parseErrorSDoc (combineLocs guardExpr elseExpr) - (text "Unexpected semi-colons in conditional:" - $$ nest 4 expr - $$ text "Perhaps you meant to use DoAndIfThenElse?") - | otherwise = return () - where pprOptSemi True = semi - pprOptSemi False = empty - expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> - text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> - text "else" <+> ppr elseExpr - - - -- The parser left-associates, so there should - -- not be any OpApps inside the e's -splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName]) --- Splits (f ! g a b) into (f, [(! g), a, b]) -splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg)) - | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns) - where - l' = combineLocs bang arg1 - (arg1,argns) = split_bang r_arg [] - split_bang (L _ (HsApp f e)) es = split_bang f (e:es) - split_bang e es = (e,es) -splitBang _ = Nothing - -isFunLhs :: LHsExpr RdrName - -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr RdrName],[AddAnn])) --- A variable binding is parsed as a FunBind. --- Just (fun, is_infix, arg_pats) if e is a function LHS --- --- The whole LHS is parsed as a single expression. --- Any infix operators on the LHS will parse left-associatively --- E.g. f !x y !z --- will parse (rather strangely) as --- (f ! x y) ! z --- It's up to isFunLhs to sort out the mess --- --- a .!. !b - -isFunLhs e = go e [] [] - where - go (L loc (HsVar (L _ f))) es ann - | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) - go (L _ (HsApp f e)) es ann = go f (e:es) ann - go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) - - -- Things of the form `!x` are also FunBinds - -- See Note [Varieties of binding pattern matches] - go (L _ (SectionR (L _ (HsVar (L _ bang))) (L l (HsVar (L _ var))))) [] ann - | bang == bang_RDR - , not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann)) - - -- For infix function defns, there should be only one infix *function* - -- (though there may be infix *datacons* involved too). So we don't - -- need fixity info to figure out which function is being defined. - -- a `K1` b `op` c `K2` d - -- must parse as - -- (a `K1` b) `op` (c `K2` d) - -- The renamer checks later that the precedences would yield such a parse. - -- - -- There is a complication to deal with bang patterns. - -- - -- ToDo: what about this? - -- x + 1 `op` y = ... - - go e@(L loc (OpApp l (L loc' (HsVar (L _ op))) fix r)) es ann - | Just (e',es') <- splitBang e - = do { bang_on <- extension bangPatEnabled - ; if bang_on then go e' (es' ++ es) ann - else return (Just (L loc' op, Infix, (l:r:es), ann)) } - -- No bangs; behave just like the next case - | not (isRdrDataCon op) -- We have found the function! - = return (Just (L loc' op, Infix, (l:r:es), ann)) - | otherwise -- Infix data con; keep going - = do { mb_l <- go l es ann - ; case mb_l of - Just (op', Infix, j : k : es', ann') - -> return (Just (op', Infix, j : op_app : es', ann')) - where - op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r) - _ -> return Nothing } - go _ _ _ = return Nothing - - --- | Transform btype_no_ops with strict_mark's into HsEqTy's --- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d -splitTilde :: LHsType RdrName -> P (LHsType RdrName) -splitTilde t = go t - where go (L loc (HsAppTy t1 t2)) - | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2') - <- t2 - = do - moveAnnotations lo loc - t1' <- go t1 - return (L loc (HsEqTy t1' t2')) - | otherwise - = do - t1' <- go t1 - case t1' of - (L lo (HsEqTy tl tr)) -> do - let lr = combineLocs tr t2 - moveAnnotations lo loc - return (L loc (HsEqTy tl (L lr (HsAppTy tr t2)))) - t -> do - return (L loc (HsAppTy t t2)) - - go t = return t - - --- | Transform tyapps with strict_marks into uses of twiddle --- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d -splitTildeApps :: [LHsAppType RdrName] -> P [LHsAppType RdrName] -splitTildeApps [] = return [] -splitTildeApps (t : rest) = do - rest' <- concatMapM go rest - return (t : rest') - where go (L l (HsAppPrefix - (L loc (HsBangTy - (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) - ty)))) - = addAnnotation l AnnTilde tilde_loc >> - return - [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)), - L l (HsAppPrefix ty)] - -- NOTE: no annotation is attached to an HsAppPrefix, so the - -- surrounding SrcSpan is not critical - where - tilde_loc = srcSpanFirstCharacter loc - - go t = return [t] - - - ---------------------------------------------------------------------------- --- Check for monad comprehensions --- --- If the flag MonadComprehensions is set, return a `MonadComp' context, --- otherwise use the usual `ListComp' context - -checkMonadComp :: P (HsStmtContext Name) -checkMonadComp = do - pState <- getPState - return $ if extopt LangExt.MonadComprehensions (options pState) - then MonadComp - else ListComp - --- ------------------------------------------------------------------------- --- Checking arrow syntax. - --- We parse arrow syntax as expressions and check for valid syntax below, --- converting the expression into a pattern at the same time. - -checkCommand :: LHsExpr RdrName -> P (LHsCmd RdrName) -checkCommand lc = locMap checkCmd lc - -locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b) -locMap f (L l a) = f l a >>= (\b -> return $ L l b) - -checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName) -checkCmd _ (HsArrApp e1 e2 ptt haat b) = - return $ HsCmdArrApp e1 e2 ptt haat b -checkCmd _ (HsArrForm e mf args) = - return $ HsCmdArrForm e Prefix mf args -checkCmd _ (HsApp e1 e2) = - checkCommand e1 >>= (\c -> return $ HsCmdApp c e2) -checkCmd _ (HsLam mg) = - checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg') -checkCmd _ (HsPar e) = - checkCommand e >>= (\c -> return $ HsCmdPar c) -checkCmd _ (HsCase e mg) = - checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg') -checkCmd _ (HsIf cf ep et ee) = do - pt <- checkCommand et - pe <- checkCommand ee - return $ HsCmdIf cf ep pt pe -checkCmd _ (HsLet lb e) = - checkCommand e >>= (\c -> return $ HsCmdLet lb c) -checkCmd _ (HsDo DoExpr (L l stmts) ty) = - mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty) - -checkCmd _ (OpApp eLeft op _fixity eRight) = do - -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it - c1 <- checkCommand eLeft - c2 <- checkCommand eRight - let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType [] - arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType [] - return $ HsCmdArrForm op Infix Nothing [arg1, arg2] - -checkCmd l e = cmdFail l e - -checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName) -checkCmdLStmt = locMap checkCmdStmt - -checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName) -checkCmdStmt _ (LastStmt e s r) = - checkCommand e >>= (\c -> return $ LastStmt c s r) -checkCmdStmt _ (BindStmt pat e b f t) = - checkCommand e >>= (\c -> return $ BindStmt pat c b f t) -checkCmdStmt _ (BodyStmt e t g ty) = - checkCommand e >>= (\c -> return $ BodyStmt c t g ty) -checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds -checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do - ss <- mapM checkCmdLStmt stmts - return $ stmt { recS_stmts = ss } -checkCmdStmt l stmt = cmdStmtFail l stmt - -checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName)) -checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do - ms' <- mapM (locMap $ const convert) ms - return $ mg { mg_alts = L l ms' } - where convert (Match mf pat mty grhss) = do - grhss' <- checkCmdGRHSs grhss - return $ Match mf pat mty grhss' - -checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName)) -checkCmdGRHSs (GRHSs grhss binds) = do - grhss' <- mapM checkCmdGRHS grhss - return $ GRHSs grhss' binds - -checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName)) -checkCmdGRHS = locMap $ const convert - where - convert (GRHS stmts e) = do - c <- checkCommand e --- cmdStmts <- mapM checkCmdLStmt stmts - return $ GRHS {- cmdStmts -} stmts c - - -cmdFail :: SrcSpan -> HsExpr RdrName -> P a -cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e) -cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a -cmdStmtFail loc e = parseErrorSDoc loc - (text "Parse error in command statement:" <+> ppr e) - ---------------------------------------------------------------------------- --- Miscellaneous utilities - -checkPrecP :: Located (SourceText,Int) -> P (Located (SourceText,Int)) -checkPrecP (L l (src,i)) - | 0 <= i && i <= maxPrecedence = return (L l (src,i)) - | otherwise - = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) - -mkRecConstrOrUpdate - :: LHsExpr RdrName - -> SrcSpan - -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool) - -> P (HsExpr RdrName) - -mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd) - | isRdrDataCon c - = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) -mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) - | dd = parseErrorSDoc l (text "You cannot use `..' in a record update") - | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) - -mkRdrRecordUpd :: LHsExpr RdrName -> [LHsRecUpdField RdrName] -> HsExpr RdrName -mkRdrRecordUpd exp flds - = RecordUpd { rupd_expr = exp - , rupd_flds = flds - , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder - , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder } - -mkRdrRecordCon :: Located RdrName -> HsRecordBinds RdrName -> HsExpr RdrName -mkRdrRecordCon con flds - = RecordCon { rcon_con_name = con, rcon_flds = flds - , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder } - -mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg -mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } -mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } - -mk_rec_upd_field :: HsRecField RdrName (LHsExpr RdrName) -> HsRecUpdField RdrName -mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun) - = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun - -mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation - -> InlinePragma --- The (Maybe Activation) is because the user can omit --- the activation spec (and usually does) -mkInlinePragma src (inl, match_info) mb_act - = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes - , inl_inline = inl - , inl_sat = Nothing - , inl_act = act - , inl_rule = match_info } - where - act = case mb_act of - Just act -> act - Nothing -> -- No phase specified - case inl of - NoInline -> NeverActive - _other -> AlwaysActive - ------------------------------------------------------------------------------ --- utilities for foreign declarations - --- construct a foreign import declaration --- -mkImport :: Located CCallConv - -> Located Safety - -> (Located StringLiteral, Located RdrName, LHsSigType RdrName) - -> P (HsDecl RdrName) -mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = - case cconv of - L _ CCallConv -> mkCImport - L _ CApiConv -> mkCImport - L _ StdCallConv -> mkCImport - L _ PrimCallConv -> mkOtherImport - L _ JavaScriptCallConv -> mkOtherImport - where - -- Parse a C-like entity string of the following form: - -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper" - -- If 'cid' is missing, the function name 'v' is used instead as symbol - -- name (cf section 8.5.1 in Haskell 2010 report). - mkCImport = do - let e = unpackFS entity - case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of - Nothing -> parseErrorSDoc loc (text "Malformed entity string") - Just importSpec -> returnSpec importSpec - - -- currently, all the other import conventions only support a symbol name in - -- the entity string. If it is missing, we use the function name instead. - mkOtherImport = returnSpec importSpec - where - entity' = if nullFS entity - then mkExtName (unLoc v) - else entity - funcTarget = CFunction (StaticTarget esrc entity' Nothing True) - importSpec = CImport cconv safety Nothing funcTarget (L loc esrc) - - returnSpec spec = return $ ForD $ ForeignImport - { fd_name = v - , fd_sig_ty = ty - , fd_co = noForeignImportCoercionYet - , fd_fi = spec - } - - - --- the string "foo" is ambiguous: either a header or a C identifier. The --- C identifier case comes first in the alternatives below, so we pick --- that one. -parseCImport :: Located CCallConv -> Located Safety -> FastString -> String - -> Located SourceText - -> Maybe ForeignImport -parseCImport cconv safety nm str sourceText = - listToMaybe $ map fst $ filter (null.snd) $ - readP_to_S parse str - where - parse = do - skipSpaces - r <- choice [ - string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), - string "wrapper" >> return (mk Nothing CWrapper), - do optional (token "static" >> skipSpaces) - ((mk Nothing <$> cimp nm) +++ - (do h <- munch1 hdr_char - skipSpaces - mk (Just (Header (SourceText h) (mkFastString h))) - <$> cimp nm)) - ] - skipSpaces - return r - - token str = do _ <- string str - toks <- look - case toks of - c : _ - | id_char c -> pfail - _ -> return () - - mk h n = CImport cconv safety h n sourceText - - hdr_char c = not (isSpace c) -- header files are filenames, which can contain - -- pretty much any char (depending on the platform), - -- so just accept any non-space character - id_first_char c = isAlpha c || c == '_' - id_char c = isAlphaNum c || c == '_' - - cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ (do isFun <- case cconv of - L _ CApiConv -> - option True - (do token "value" - skipSpaces - return False) - _ -> return True - cid' <- cid - return (CFunction (StaticTarget NoSourceText cid' - Nothing isFun))) - where - cid = return nm +++ - (do c <- satisfy id_first_char - cs <- many (satisfy id_char) - return (mkFastString (c:cs))) - - --- construct a foreign export declaration --- -mkExport :: Located CCallConv - -> (Located StringLiteral, Located RdrName, LHsSigType RdrName) - -> P (HsDecl RdrName) -mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) - = return $ ForD $ - ForeignExport { fd_name = v, fd_sig_ty = ty - , fd_co = noForeignExportCoercionYet - , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv)) - (L le esrc) } - where - entity' | nullFS entity = mkExtName (unLoc v) - | otherwise = entity - --- Supplying the ext_name in a foreign decl is optional; if it --- isn't there, the Haskell name is assumed. Note that no transformation --- of the Haskell name is then performed, so if you foreign export (++), --- it's external name will be "++". Too bad; it's important because we don't --- want z-encoding (e.g. names with z's in them shouldn't be doubled) --- -mkExtName :: RdrName -> CLabelString -mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) - --------------------------------------------------------------------------------- --- Help with module system imports/exports - -data ImpExpSubSpec = ImpExpAbs - | ImpExpAll - | ImpExpList [Located ImpExpQcSpec] - | ImpExpAllWith [Located ImpExpQcSpec] - -data ImpExpQcSpec = ImpExpQcName (Located RdrName) - | ImpExpQcType (Located RdrName) - | ImpExpQcWildcard - -mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE RdrName) -mkModuleImpExp (L l specname) subs = - case subs of - ImpExpAbs - | isVarNameSpace (rdrNameSpace name) - -> return $ IEVar (L l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs . L l <$> nameT - ImpExpAll -> IEThingAll . L l <$> nameT - ImpExpList xs -> - (\newName -> IEThingWith (L l newName) NoIEWildcard (wrapped xs) []) - <$> nameT - ImpExpAllWith xs -> - do allowed <- extension patternSynonymsEnabled - if allowed - then - let withs = map unLoc xs - pos = maybe NoIEWildcard IEWildcard - (findIndex isImpExpQcWildcard withs) - ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs - in (\newName -> IEThingWith (L l newName) pos ies []) <$> nameT - else parseErrorSDoc l - (text "Illegal export form (use PatternSynonyms to enable)") - where - name = ieNameVal specname - nameT = - if isVarNameSpace (rdrNameSpace name) - then parseErrorSDoc l - (text "Expecting a type constructor but found a variable," - <+> quotes (ppr name) <> text "." - $$ if isSymOcc $ rdrNameOcc name - then text "If" <+> quotes (ppr name) <+> text "is a type constructor" - <+> text "then enable ExplicitNamespaces and use the 'type' keyword." - else empty) - else return $ ieNameFromSpec specname - - ieNameVal (ImpExpQcName ln) = unLoc ln - ieNameVal (ImpExpQcType ln) = unLoc ln - ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" - - ieNameFromSpec (ImpExpQcName ln) = IEName ln - ieNameFromSpec (ImpExpQcType ln) = IEType ln - ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" - - wrapped = map (\(L l x) -> L l (ieNameFromSpec x)) - -mkTypeImpExp :: Located RdrName -- TcCls or Var name space - -> P (Located RdrName) -mkTypeImpExp name = - do allowed <- extension explicitNamespacesEnabled - if allowed - then return (fmap (`setRdrNameSpace` tcClsName) name) - else parseErrorSDoc (getLoc name) - (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)") - -checkImportSpec :: Located [LIE RdrName] -> P (Located [LIE RdrName]) -checkImportSpec ie@(L _ specs) = - case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of - [] -> return ie - (l:_) -> importSpecError l - where - importSpecError l = - parseErrorSDoc l - (text "Illegal import form, this syntax can only be used to bundle" - $+$ text "pattern synonyms with types in module exports.") - --- In the correct order -mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) -mkImpExpSubSpec [] = return ([], ImpExpList []) -mkImpExpSubSpec [L _ ImpExpQcWildcard] = - return ([], ImpExpAll) -mkImpExpSubSpec xs = - if (any (isImpExpQcWildcard . unLoc) xs) - then return $ ([], ImpExpAllWith xs) - else return $ ([], ImpExpList xs) - -isImpExpQcWildcard :: ImpExpQcSpec -> Bool -isImpExpQcWildcard ImpExpQcWildcard = True -isImpExpQcWildcard _ = False - ------------------------------------------------------------------------------ --- Misc utils - -parseErrorSDoc :: SrcSpan -> SDoc -> P a -parseErrorSDoc span s = failSpanMsgP span s - -data SumOrTuple - = Sum ConTag Arity (LHsExpr RdrName) - | Tuple [LHsTupArg RdrName] - -mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr RdrName) - --- Tuple -mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity) - --- Sum -mkSumOrTuple Unboxed _ (Sum alt arity e) = - return (ExplicitSum alt arity e PlaceHolder) -mkSumOrTuple Boxed l (Sum alt arity (L _ e)) = - parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e)) - where - ppr_boxed_sum :: ConTag -> Arity -> HsExpr RdrName -> SDoc - ppr_boxed_sum alt arity e = - text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")" - - ppr_bars n = hsep (replicate n (Outputable.char '|')) diff --git a/parser/cutils.c b/parser/cutils.c deleted file mode 100644 --- a/parser/cutils.c +++ /dev/null @@ -1,47 +0,0 @@ -/* -These utility routines are used various -places in the GHC library. -*/ - -#include "Rts.h" - -#include "HsFFI.h" - -#include - -#ifdef HAVE_UNISTD_H -#include -#endif - -/* -Calling 'strlen' and 'memcpy' directly gives problems with GCC's inliner, -and causes gcc to require too many registers on x84 -*/ - -HsInt -ghc_strlen( HsPtr a ) -{ - return (strlen((char *)a)); -} - -HsInt -ghc_memcmp( HsPtr a1, HsPtr a2, HsInt len ) -{ - return (memcmp((char *)a1, a2, len)); -} - -void -enableTimingStats( void ) /* called from the driver */ -{ - RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS; -} - -void -setHeapSize( HsInt size ) -{ - RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE; - if (RtsFlags.GcFlags.maxHeapSize != 0 && - RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { - RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; - } -} diff --git a/parser/cutils.h b/parser/cutils.h deleted file mode 100644 --- a/parser/cutils.h +++ /dev/null @@ -1,15 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * Utility C functions. - * - * -------------------------------------------------------------------------- */ - -#include "HsFFI.h" - -// Out-of-line string functions, see compiler/utils/FastString.hs -HsInt ghc_strlen( HsAddr a ); -HsInt ghc_memcmp( HsAddr a1, HsAddr a2, HsInt len ); - - -void enableTimingStats( void ); -void setHeapSize( HsInt size ); diff --git a/prelude/ForeignCall.hs b/prelude/ForeignCall.hs deleted file mode 100644 --- a/prelude/ForeignCall.hs +++ /dev/null @@ -1,346 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Foreign]{Foreign calls} --} - -{-# LANGUAGE DeriveDataTypeable #-} - -module ForeignCall ( - ForeignCall(..), isSafeForeignCall, - Safety(..), playSafe, playInterruptible, - - CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, - CCallSpec(..), - CCallTarget(..), isDynamicTarget, - CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, - - Header(..), CType(..), - ) where - -import FastString -import Binary -import Outputable -import Module -import BasicTypes ( SourceText, pprWithSourceText ) - -import Data.Char -import Data.Data - -{- -************************************************************************ -* * -\subsubsection{Data types} -* * -************************************************************************ --} - -newtype ForeignCall = CCall CCallSpec - deriving Eq - -isSafeForeignCall :: ForeignCall -> Bool -isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe - --- We may need more clues to distinguish foreign calls --- but this simple printer will do for now -instance Outputable ForeignCall where - ppr (CCall cc) = ppr cc - -data Safety - = PlaySafe -- Might invoke Haskell GC, or do a call back, or - -- switch threads, etc. So make sure things are - -- tidy before the call. Additionally, in the threaded - -- RTS we arrange for the external call to be executed - -- by a separate OS thread, i.e., _concurrently_ to the - -- execution of other Haskell threads. - - | PlayInterruptible -- Like PlaySafe, but additionally - -- the worker thread running this foreign call may - -- be unceremoniously killed, so it must be scheduled - -- on an unbound thread. - - | PlayRisky -- None of the above can happen; the call will return - -- without interacting with the runtime system at all - deriving ( Eq, Show, Data ) - -- Show used just for Show Lex.Token, I think - -instance Outputable Safety where - ppr PlaySafe = text "safe" - ppr PlayInterruptible = text "interruptible" - ppr PlayRisky = text "unsafe" - -playSafe :: Safety -> Bool -playSafe PlaySafe = True -playSafe PlayInterruptible = True -playSafe PlayRisky = False - -playInterruptible :: Safety -> Bool -playInterruptible PlayInterruptible = True -playInterruptible _ = False - -{- -************************************************************************ -* * -\subsubsection{Calling C} -* * -************************************************************************ --} - -data CExportSpec - = CExportStatic -- foreign export ccall foo :: ty - SourceText -- of the CLabelString. - -- See note [Pragma source text] in BasicTypes - CLabelString -- C Name of exported function - CCallConv - deriving Data - -data CCallSpec - = CCallSpec CCallTarget -- What to call - CCallConv -- Calling convention to use. - Safety - deriving( Eq ) - --- The call target: - --- | How to call a particular function in C-land. -data CCallTarget - -- An "unboxed" ccall# to named function in a particular package. - = StaticTarget - SourceText -- of the CLabelString. - -- See note [Pragma source text] in BasicTypes - CLabelString -- C-land name of label. - - (Maybe UnitId) -- What package the function is in. - -- If Nothing, then it's taken to be in the current package. - -- Note: This information is only used for PrimCalls on Windows. - -- See CLabel.labelDynamic and CoreToStg.coreToStgApp - -- for the difference in representation between PrimCalls - -- and ForeignCalls. If the CCallTarget is representing - -- a regular ForeignCall then it's safe to set this to Nothing. - - -- The first argument of the import is the name of a function pointer (an Addr#). - -- Used when importing a label as "foreign import ccall "dynamic" ..." - Bool -- True => really a function - -- False => a value; only - -- allowed in CAPI imports - | DynamicTarget - - deriving( Eq, Data ) - -isDynamicTarget :: CCallTarget -> Bool -isDynamicTarget DynamicTarget = True -isDynamicTarget _ = False - -{- -Stuff to do with calling convention: - -ccall: Caller allocates parameters, *and* deallocates them. - -stdcall: Caller allocates parameters, callee deallocates. - Function name has @N after it, where N is number of arg bytes - e.g. _Foo@8. This convention is x86 (win32) specific. - -See: http://www.programmersheaven.com/2/Calling-conventions --} - --- any changes here should be replicated in the CallConv type in template haskell -data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv - deriving (Eq, Data) - -instance Outputable CCallConv where - ppr StdCallConv = text "stdcall" - ppr CCallConv = text "ccall" - ppr CApiConv = text "capi" - ppr PrimCallConv = text "prim" - ppr JavaScriptCallConv = text "javascript" - -defaultCCallConv :: CCallConv -defaultCCallConv = CCallConv - -ccallConvToInt :: CCallConv -> Int -ccallConvToInt StdCallConv = 0 -ccallConvToInt CCallConv = 1 -ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" -ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" -ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" - -{- -Generate the gcc attribute corresponding to the given -calling convention (used by PprAbsC): --} - -ccallConvAttribute :: CCallConv -> SDoc -ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" -ccallConvAttribute CCallConv = empty -ccallConvAttribute CApiConv = empty -ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" -ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" - -type CLabelString = FastString -- A C label, completely unencoded - -pprCLabelString :: CLabelString -> SDoc -pprCLabelString lbl = ftext lbl - -isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label -isCLabelString lbl - = all ok (unpackFS lbl) - where - ok c = isAlphaNum c || c == '_' || c == '.' - -- The '.' appears in e.g. "foo.so" in the - -- module part of a ExtName. Maybe it should be separate - --- Printing into C files: - -instance Outputable CExportSpec where - ppr (CExportStatic _ str _) = pprCLabelString str - -instance Outputable CCallSpec where - ppr (CCallSpec fun cconv safety) - = hcat [ ifPprDebug callconv, ppr_fun fun ] - where - callconv = text "{-" <> ppr cconv <> text "-}" - - gc_suf | playSafe safety = text "_GC" - | otherwise = empty - - ppr_fun (StaticTarget st _fn mPkgId isFun) - = text (if isFun then "__pkg_ccall" - else "__pkg_ccall_value") - <> gc_suf - <+> (case mPkgId of - Nothing -> empty - Just pkgId -> ppr pkgId) - <+> (pprWithSourceText st empty) - - ppr_fun DynamicTarget - = text "__dyn_ccall" <> gc_suf <+> text "\"\"" - --- The filename for a C header file --- Note [Pragma source text] in BasicTypes -data Header = Header SourceText FastString - deriving (Eq, Data) - -instance Outputable Header where - ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) - --- | A C type, used in CAPI FFI calls --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@, --- 'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal', --- 'ApiAnnotation.AnnClose' @'\#-}'@, - --- For details on above see note [Api annotations] in ApiAnnotation -data CType = CType SourceText -- Note [Pragma source text] in BasicTypes - (Maybe Header) -- header to include for this type - (SourceText,FastString) -- the type itself - deriving (Eq, Data) - -instance Outputable CType where - ppr (CType stp mh (stct,ct)) - = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc - <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" - where hDoc = case mh of - Nothing -> empty - Just h -> ppr h - -{- -************************************************************************ -* * -\subsubsection{Misc} -* * -************************************************************************ --} - -instance Binary ForeignCall where - put_ bh (CCall aa) = put_ bh aa - get bh = do aa <- get bh; return (CCall aa) - -instance Binary Safety where - put_ bh PlaySafe = do - putByte bh 0 - put_ bh PlayInterruptible = do - putByte bh 1 - put_ bh PlayRisky = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return PlaySafe - 1 -> do return PlayInterruptible - _ -> do return PlayRisky - -instance Binary CExportSpec where - put_ bh (CExportStatic ss aa ab) = do - put_ bh ss - put_ bh aa - put_ bh ab - get bh = do - ss <- get bh - aa <- get bh - ab <- get bh - return (CExportStatic ss aa ab) - -instance Binary CCallSpec where - put_ bh (CCallSpec aa ab ac) = do - put_ bh aa - put_ bh ab - put_ bh ac - get bh = do - aa <- get bh - ab <- get bh - ac <- get bh - return (CCallSpec aa ab ac) - -instance Binary CCallTarget where - put_ bh (StaticTarget ss aa ab ac) = do - putByte bh 0 - put_ bh ss - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh DynamicTarget = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do ss <- get bh - aa <- get bh - ab <- get bh - ac <- get bh - return (StaticTarget ss aa ab ac) - _ -> do return DynamicTarget - -instance Binary CCallConv where - put_ bh CCallConv = do - putByte bh 0 - put_ bh StdCallConv = do - putByte bh 1 - put_ bh PrimCallConv = do - putByte bh 2 - put_ bh CApiConv = do - putByte bh 3 - put_ bh JavaScriptCallConv = do - putByte bh 4 - get bh = do - h <- getByte bh - case h of - 0 -> do return CCallConv - 1 -> do return StdCallConv - 2 -> do return PrimCallConv - 3 -> do return CApiConv - _ -> do return JavaScriptCallConv - -instance Binary CType where - put_ bh (CType s mh fs) = do put_ bh s - put_ bh mh - put_ bh fs - get bh = do s <- get bh - mh <- get bh - fs <- get bh - return (CType s mh fs) - -instance Binary Header where - put_ bh (Header s h) = put_ bh s >> put_ bh h - get bh = do s <- get bh - h <- get bh - return (Header s h) diff --git a/prelude/KnownUniques.hs b/prelude/KnownUniques.hs deleted file mode 100644 --- a/prelude/KnownUniques.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | This is where we define a mapping from Uniques to their associated --- known-key Names for things associated with tuples and sums. We use this --- mapping while deserializing known-key Names in interface file symbol tables, --- which are encoded as their Unique. See Note [Symbol table representation of --- names] for details. --- - -module KnownUniques - ( -- * Looking up known-key names - knownUniqueName - - -- * Getting the 'Unique's of 'Name's - -- ** Anonymous sums - , mkSumTyConUnique - , mkSumDataConUnique - -- ** Tuples - -- *** Vanilla - , mkTupleTyConUnique - , mkTupleDataConUnique - -- *** Constraint - , mkCTupleTyConUnique - , mkCTupleDataConUnique - ) where - -#include "HsVersions.h" - -import TysWiredIn -import TyCon -import DataCon -import Id -import BasicTypes -import Outputable -import Unique -import Name -import Util - -import Data.Bits -import Data.Maybe - --- | Get the 'Name' associated with a known-key 'Unique'. -knownUniqueName :: Unique -> Maybe Name -knownUniqueName u = - case tag of - 'z' -> Just $ getUnboxedSumName n - '4' -> Just $ getTupleTyConName Boxed n - '5' -> Just $ getTupleTyConName Unboxed n - '7' -> Just $ getTupleDataConName Boxed n - '8' -> Just $ getTupleDataConName Unboxed n - 'k' -> Just $ getCTupleTyConName n - 'm' -> Just $ getCTupleDataConUnique n - _ -> Nothing - where - (tag, n) = unpkUnique u - --------------------------------------------------- --- Anonymous sums --- --- Sum arities start from 2. The encoding is a bit funny: we break up the --- integral part into bitfields for the arity, an alternative index (which is --- taken to be 0xff in the case of the TyCon), and, in the case of a datacon, a --- tag (used to identify the sum's TypeRep binding). --- --- This layout is chosen to remain compatible with the usual unique allocation --- for wired-in data constructors described in Unique.hs --- --- TyCon for sum of arity k: --- 00000000 kkkkkkkk 11111100 - --- TypeRep of TyCon for sum of arity k: --- 00000000 kkkkkkkk 11111101 --- --- DataCon for sum of arity k and alternative n (zero-based): --- 00000000 kkkkkkkk nnnnnn00 --- --- TypeRep for sum DataCon of arity k and alternative n (zero-based): --- 00000000 kkkkkkkk nnnnnn10 - -mkSumTyConUnique :: Arity -> Unique -mkSumTyConUnique arity = - ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the - -- alternative - mkUnique 'z' (arity `shiftL` 8 .|. 0xfc) - -mkSumDataConUnique :: ConTagZ -> Arity -> Unique -mkSumDataConUnique alt arity - | alt >= arity - = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity) - | otherwise - = mkUnique 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -} - -getUnboxedSumName :: Int -> Name -getUnboxedSumName n - | n .&. 0xfc == 0xfc - = case tag of - 0x0 -> tyConName $ sumTyCon arity - 0x1 -> getRep $ sumTyCon arity - _ -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag) - | tag == 0x0 - = dataConName $ sumDataCon (alt + 1) arity - | tag == 0x1 - = getName $ dataConWrapId $ sumDataCon (alt + 1) arity - | tag == 0x2 - = getRep $ promoteDataCon $ sumDataCon (alt + 1) arity - | otherwise - = pprPanic "getUnboxedSumName" (ppr n) - where - arity = n `shiftR` 8 - alt = (n .&. 0xfc) `shiftR` 2 - tag = 0x3 .&. n - getRep tycon = - fromMaybe (pprPanic "getUnboxedSumName(getRep)" (ppr tycon)) - $ tyConRepName_maybe tycon - --- Note [Uniques for tuple type and data constructors] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Wired-in type constructor keys occupy *two* slots: --- * u: the TyCon itself --- * u+1: the TyConRepName of the TyCon --- --- Wired-in tuple data constructor keys occupy *three* slots: --- * u: the DataCon itself --- * u+1: its worker Id --- * u+2: the TyConRepName of the promoted TyCon - --------------------------------------------------- --- Constraint tuples - -mkCTupleTyConUnique :: Arity -> Unique -mkCTupleTyConUnique a = mkUnique 'k' (2*a) - -mkCTupleDataConUnique :: Arity -> Unique -mkCTupleDataConUnique a = mkUnique 'm' (3*a) - -getCTupleTyConName :: Int -> Name -getCTupleTyConName n = - case n `divMod` 2 of - (arity, 0) -> cTupleTyConName arity - (arity, 1) -> mkPrelTyConRepName $ cTupleTyConName arity - _ -> panic "getCTupleTyConName: impossible" - -getCTupleDataConUnique :: Int -> Name -getCTupleDataConUnique n = - case n `divMod` 3 of - (arity, 0) -> cTupleDataConName arity - (_arity, 1) -> panic "getCTupleDataConName: no worker" - (arity, 2) -> mkPrelTyConRepName $ cTupleDataConName arity - _ -> panic "getCTupleDataConName: impossible" - --------------------------------------------------- --- Normal tuples - -mkTupleDataConUnique :: Boxity -> Arity -> Unique -mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- may be used in C labels -mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a) - -mkTupleTyConUnique :: Boxity -> Arity -> Unique -mkTupleTyConUnique Boxed a = mkUnique '4' (2*a) -mkTupleTyConUnique Unboxed a = mkUnique '5' (2*a) - -getTupleTyConName :: Boxity -> Int -> Name -getTupleTyConName boxity n = - case n `divMod` 2 of - (arity, 0) -> tyConName $ tupleTyCon boxity arity - (arity, 1) -> fromMaybe (panic "getTupleTyConName") - $ tyConRepName_maybe $ tupleTyCon boxity arity - _ -> panic "getTupleTyConName: impossible" - -getTupleDataConName :: Boxity -> Int -> Name -getTupleDataConName boxity n = - case n `divMod` 3 of - (arity, 0) -> dataConName $ tupleDataCon boxity arity - (arity, 1) -> idName $ dataConWorkId $ tupleDataCon boxity arity - (arity, 2) -> fromMaybe (panic "getTupleDataCon") - $ tyConRepName_maybe $ promotedTupleDataCon boxity arity - _ -> panic "getTupleDataConName: impossible" diff --git a/prelude/KnownUniques.hs-boot b/prelude/KnownUniques.hs-boot deleted file mode 100644 --- a/prelude/KnownUniques.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -module KnownUniques where - -import Unique -import Name -import BasicTypes - --- Needed by TysWiredIn -knownUniqueName :: Unique -> Maybe Name - -mkSumTyConUnique :: Arity -> Unique -mkSumDataConUnique :: ConTagZ -> Arity -> Unique - -mkCTupleTyConUnique :: Arity -> Unique -mkCTupleDataConUnique :: Arity -> Unique - -mkTupleTyConUnique :: Boxity -> Arity -> Unique -mkTupleDataConUnique :: Boxity -> Arity -> Unique diff --git a/prelude/PrelInfo.hs b/prelude/PrelInfo.hs deleted file mode 100644 --- a/prelude/PrelInfo.hs +++ /dev/null @@ -1,266 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - --} - -{-# LANGUAGE CPP #-} - --- | The @PrelInfo@ interface to the compiler's prelude knowledge. --- --- This module serves as the central gathering point for names which the --- compiler knows something about. This includes functions for, --- --- * discerning whether a 'Name' is known-key --- --- * given a 'Unique', looking up its corresponding known-key 'Name' --- --- See Note [Known-key names] and Note [About wired-in things] for information --- about the two types of prelude things in GHC. --- -module PrelInfo ( - -- * Known-key names - isKnownKeyName, - lookupKnownKeyName, - - -- ** Internal use - -- | 'knownKeyNames' is exported to seed the original name cache only; - -- if you find yourself wanting to look at it you might consider using - -- 'lookupKnownKeyName' or 'isKnownKeyName'. - knownKeyNames, - - -- * Miscellaneous - wiredInIds, ghcPrimIds, - primOpRules, builtinRules, - - ghcPrimExports, - primOpId, - - -- * Random other things - maybeCharLikeCon, maybeIntLikeCon, - - -- * Class categories - isNumericClass, isStandardClass - - ) where - -#include "HsVersions.h" - -import KnownUniques -import Unique ( isValidKnownKeyUnique ) - -import ConLike ( ConLike(..) ) -import THNames ( templateHaskellNames ) -import PrelNames -import PrelRules -import Avail -import PrimOp -import DataCon -import Id -import Name -import NameEnv -import MkId -import TysPrim -import TysWiredIn -import HscTypes -import Class -import TyCon -import UniqFM -import Util -import Panic -import {-# SOURCE #-} TcTypeNats ( typeNatTyCons ) - -import Control.Applicative ((<|>)) -import Data.List ( intercalate ) -import Data.Array -import Data.Maybe - -{- -************************************************************************ -* * -\subsection[builtinNameInfo]{Lookup built-in names} -* * -************************************************************************ - -Note [About wired-in things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Wired-in things are Ids\/TyCons that are completely known to the compiler. - They are global values in GHC, (e.g. listTyCon :: TyCon). - -* A wired in Name contains the thing itself inside the Name: - see Name.wiredInNameTyThing_maybe - (E.g. listTyConName contains listTyCon. - -* The name cache is initialised with (the names of) all wired-in things - (except tuples and sums; see Note [Known-]) - -* The type environment itself contains no wired in things. The type - checker sees if the Name is wired in before looking up the name in - the type environment. - -* MkIface prunes out wired-in things before putting them in an interface file. - So interface files never contain wired-in things. --} - - --- | This list is used to ensure that when you say "Prelude.map" in your source --- code, or in an interface file, you get a Name with the correct known key (See --- Note [Known-key names] in PrelNames) -knownKeyNames :: [Name] -knownKeyNames - | debugIsOn - , Just badNamesStr <- knownKeyNamesOkay all_names - = panic ("badAllKnownKeyNames:\n" ++ badNamesStr) - -- NB: We can't use ppr here, because this is sometimes evaluated in a - -- context where there are no DynFlags available, leading to a cryptic - -- "<
>" error. (This seems to happen only in the - -- stage 2 compiler, for reasons I [Richard] have no clue of.) - | otherwise - = all_names - where - all_names = - concat [ wired_tycon_kk_names funTyCon - , concatMap wired_tycon_kk_names primTyCons - - , concatMap wired_tycon_kk_names wiredInTyCons - -- Does not include tuples - - , concatMap wired_tycon_kk_names typeNatTyCons - - , map idName wiredInIds - , map (idName . primOpId) allThePrimOps - , basicKnownKeyNames - , templateHaskellNames - ] - -- All of the names associated with a wired-in TyCon. - -- This includes the TyCon itself, its DataCons and promoted TyCons. - wired_tycon_kk_names :: TyCon -> [Name] - wired_tycon_kk_names tc = - tyConName tc : (rep_names tc ++ implicits) - where implicits = concatMap thing_kk_names (implicitTyConThings tc) - - wired_datacon_kk_names :: DataCon -> [Name] - wired_datacon_kk_names dc = - dataConName dc : rep_names (promoteDataCon dc) - - thing_kk_names :: TyThing -> [Name] - thing_kk_names (ATyCon tc) = wired_tycon_kk_names tc - thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc - thing_kk_names thing = [getName thing] - - -- The TyConRepName for a known-key TyCon has a known key, - -- but isn't itself an implicit thing. Yurgh. - -- NB: if any of the wired-in TyCons had record fields, the record - -- field names would be in a similar situation. Ditto class ops. - -- But it happens that there aren't any - rep_names tc = case tyConRepName_maybe tc of - Just n -> [n] - Nothing -> [] - --- | Check the known-key names list of consistency. -knownKeyNamesOkay :: [Name] -> Maybe String -knownKeyNamesOkay all_names - | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names - = Just $ " Out-of-range known-key uniques: [" - ++ intercalate ", " (map (occNameString . nameOccName) ns) ++ - "]" - | null badNamesPairs - = Nothing - | otherwise - = Just badNamesStr - where - namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n) - emptyUFM all_names - badNamesEnv = filterNameEnv (\ns -> length ns > 1) namesEnv - badNamesPairs = nonDetUFMToList badNamesEnv - -- It's OK to use nonDetUFMToList here because the ordering only affects - -- the message when we get a panic - badNamesStrs = map pairToStr badNamesPairs - badNamesStr = unlines badNamesStrs - - pairToStr (uniq, ns) = " " ++ - show uniq ++ - ": [" ++ - intercalate ", " (map (occNameString . nameOccName) ns) ++ - "]" - --- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a --- known-key thing. -lookupKnownKeyName :: Unique -> Maybe Name -lookupKnownKeyName u = - knownUniqueName u <|> lookupUFM knownKeysMap u - --- | Is a 'Name' known-key? -isKnownKeyName :: Name -> Bool -isKnownKeyName n = - isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap - -knownKeysMap :: UniqFM Name -knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ] - -{- -We let a lot of "non-standard" values be visible, so that we can make -sense of them in interface pragmas. It's cool, though they all have -"non-standard" names, so they won't get past the parser in user code. - -************************************************************************ -* * - PrimOpIds -* * -************************************************************************ --} - -primOpIds :: Array Int Id --- A cache of the PrimOp Ids, indexed by PrimOp tag -primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) - | op <- allThePrimOps ] - -primOpId :: PrimOp -> Id -primOpId op = primOpIds ! primOpTag op - -{- -************************************************************************ -* * - Export lists for pseudo-modules (GHC.Prim) -* * -************************************************************************ - -GHC.Prim "exports" all the primops and primitive types, some -wired-in Ids. --} - -ghcPrimExports :: [IfaceExport] -ghcPrimExports - = map (avail . idName) ghcPrimIds ++ - map (avail . idName . primOpId) allThePrimOps ++ - [ AvailTC n [n] [] - | tc <- funTyCon : primTyCons, let n = tyConName tc ] - -{- -************************************************************************ -* * - Built-in keys -* * -************************************************************************ - -ToDo: make it do the ``like'' part properly (as in 0.26 and before). --} - -maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool -maybeCharLikeCon con = con `hasKey` charDataConKey -maybeIntLikeCon con = con `hasKey` intDataConKey - -{- -************************************************************************ -* * - Class predicates -* * -************************************************************************ --} - -isNumericClass, isStandardClass :: Class -> Bool - -isNumericClass clas = classKey clas `is_elem` numericClassKeys -isStandardClass clas = classKey clas `is_elem` standardClassKeys - -is_elem :: Eq a => a -> [a] -> Bool -is_elem = isIn "is_X_Class" diff --git a/prelude/PrelNames.hs b/prelude/PrelNames.hs deleted file mode 100644 --- a/prelude/PrelNames.hs +++ /dev/null @@ -1,2457 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[PrelNames]{Definitions of prelude modules and names} - - -Nota Bene: all Names defined in here should come from the base package - - - ModuleNames for prelude modules, - e.g. pREL_BASE_Name :: ModuleName - - - Modules for prelude modules - e.g. pREL_Base :: Module - - - Uniques for Ids, DataCons, TyCons and Classes that the compiler - "knows about" in some way - e.g. intTyConKey :: Unique - minusClassOpKey :: Unique - - - Names for Ids, DataCons, TyCons and Classes that the compiler - "knows about" in some way - e.g. intTyConName :: Name - minusName :: Name - One of these Names contains - (a) the module and occurrence name of the thing - (b) its Unique - The may way the compiler "knows about" one of these things is - where the type checker or desugarer needs to look it up. For - example, when desugaring list comprehensions the desugarer - needs to conjure up 'foldr'. It does this by looking up - foldrName in the environment. - - - RdrNames for Ids, DataCons etc that the compiler may emit into - generated code (e.g. for deriving). It's not necessary to know - the uniques for these guys, only their names - - -Note [Known-key names] -~~~~~~~~~~~~~~~~~~~~~~ -It is *very* important that the compiler gives wired-in things and -things with "known-key" names the correct Uniques wherever they -occur. We have to be careful about this in exactly two places: - - 1. When we parse some source code, renaming the AST better yield an - AST whose Names have the correct uniques - - 2. When we read an interface file, the read-in gubbins better have - the right uniques - -This is accomplished through a combination of mechanisms: - - 1. When parsing source code, the RdrName-decorated AST has some - RdrNames which are Exact. These are wired-in RdrNames where the - we could directly tell from the parsed syntax what Name to - use. For example, when we parse a [] in a type we can just insert - an Exact RdrName Name with the listTyConKey. - - Currently, I believe this is just an optimisation: it would be - equally valid to just output Orig RdrNames that correctly record - the module etc we expect the final Name to come from. However, - were we to eliminate isBuiltInOcc_maybe it would become essential - (see point 3). - - 2. The knownKeyNames (which consist of the basicKnownKeyNames from - the module, and those names reachable via the wired-in stuff from - TysWiredIn) are used to initialise the "OrigNameCache" in - IfaceEnv. This initialization ensures that when the type checker - or renamer (both of which use IfaceEnv) look up an original name - (i.e. a pair of a Module and an OccName) for a known-key name - they get the correct Unique. - - This is the most important mechanism for ensuring that known-key - stuff gets the right Unique, and is why it is so important to - place your known-key names in the appropriate lists. - - 3. For "infinite families" of known-key names (i.e. tuples and sums), we - have to be extra careful. Because there are an infinite number of - these things, we cannot add them to the list of known-key names - used to initialise the OrigNameCache. Instead, we have to - rely on never having to look them up in that cache. See - Note [Infinite families of known-key names] for details. - - -Note [Infinite families of known-key names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Infinite families of known-key things (e.g. tuples and sums) pose a tricky -problem: we can't add them to the knownKeyNames finite map which we use to -ensure that, e.g., a reference to (,) gets assigned the right unique (if this -doesn't sound familiar see Note [Known-key names] above). - -We instead handle tuples and sums separately from the "vanilla" known-key -things, - - a) The parser recognises them specially and generates an Exact Name (hence not - looked up in the orig-name cache) - - b) The known infinite families of names are specially serialised by - BinIface.putName, with that special treatment detected when we read back to - ensure that we get back to the correct uniques. See Note [Symbol table - representation of names] in BinIface and Note [How tuples work] in - TysWiredIn. - -Most of the infinite families cannot occur in source code, so mechanisms (a) and (b) -suffice to ensure that they always have the right Unique. In particular, -implicit param TyCon names, constraint tuples and Any TyCons cannot be mentioned -by the user. For those things that *can* appear in source programs, - - c) IfaceEnv.lookupOrigNameCache uses isBuiltInOcc_maybe to map built-in syntax - directly onto the corresponding name, rather than trying to find it in the - original-name cache. - - See also Note [Built-in syntax and the OrigNameCache] --} - -{-# LANGUAGE CPP #-} - -module PrelNames ( - Unique, Uniquable(..), hasKey, -- Re-exported for convenience - - ----------------------------------------------------------- - module PrelNames, -- A huge bunch of (a) Names, e.g. intTyConName - -- (b) Uniques e.g. intTyConKey - -- (c) Groups of classes and types - -- (d) miscellaneous things - -- So many that we export them all - ) where - -#include "HsVersions.h" - -import Module -import OccName -import RdrName -import Unique -import Name -import SrcLoc -import FastString -import Config ( cIntegerLibraryType, IntegerLibrary(..) ) -import Panic ( panic ) - -{- -************************************************************************ -* * - allNameStrings -* * -************************************************************************ --} - -allNameStrings :: [String] --- Infinite list of a,b,c...z, aa, ab, ac, ... etc -allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ] - -{- -************************************************************************ -* * -\subsection{Local Names} -* * -************************************************************************ - -This *local* name is used by the interactive stuff --} - -itName :: Unique -> SrcSpan -> Name -itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc - --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: OccName -> Name -mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan - -isUnboundName :: Name -> Bool -isUnboundName name = name `hasKey` unboundKey - -{- -************************************************************************ -* * -\subsection{Known key Names} -* * -************************************************************************ - -This section tells what the compiler knows about the association of -names with uniques. These ones are the *non* wired-in ones. The -wired in ones are defined in TysWiredIn etc. --} - -basicKnownKeyNames :: [Name] -basicKnownKeyNames - = genericTyConNames - ++ [ -- Classes. *Must* include: - -- classes that are grabbed by key (e.g., eqClassKey) - -- classes in "Class.standardClassKeys" (quite a few) - eqClassName, -- mentioned, derivable - ordClassName, -- derivable - boundedClassName, -- derivable - numClassName, -- mentioned, numeric - enumClassName, -- derivable - monadClassName, - functorClassName, - realClassName, -- numeric - integralClassName, -- numeric - fractionalClassName, -- numeric - floatingClassName, -- numeric - realFracClassName, -- numeric - realFloatClassName, -- numeric - dataClassName, - isStringClassName, - applicativeClassName, - alternativeClassName, - foldableClassName, - traversableClassName, - semigroupClassName, sappendName, - monoidClassName, memptyName, mappendName, mconcatName, - - -- The IO type - -- See Note [TyConRepNames for non-wired-in TyCons] - ioTyConName, ioDataConName, - runMainIOName, - - -- Type representation types - trModuleTyConName, trModuleDataConName, - trNameTyConName, trNameSDataConName, trNameDDataConName, - trTyConTyConName, trTyConDataConName, - - -- Typeable - typeableClassName, - typeRepTyConName, - someTypeRepTyConName, - someTypeRepDataConName, - kindRepTyConName, - kindRepTyConAppDataConName, - kindRepVarDataConName, - kindRepAppDataConName, - kindRepFunDataConName, - kindRepTYPEDataConName, - kindRepTypeLitSDataConName, - kindRepTypeLitDDataConName, - typeLitSortTyConName, - typeLitSymbolDataConName, - typeLitNatDataConName, - typeRepIdName, - mkTrConName, - mkTrAppName, - mkTrFunName, - typeSymbolTypeRepName, typeNatTypeRepName, - trGhcPrimModuleName, - - -- KindReps for common cases - starKindRepName, - starArrStarKindRepName, - starArrStarArrStarKindRepName, - - -- Dynamic - toDynName, - - -- Numeric stuff - negateName, minusName, geName, eqName, - - -- Conversion functions - rationalTyConName, - ratioTyConName, ratioDataConName, - fromRationalName, fromIntegerName, - toIntegerName, toRationalName, - fromIntegralName, realToFracName, - - -- Int# stuff - divIntName, modIntName, - - -- String stuff - fromStringName, - - -- Enum stuff - enumFromName, enumFromThenName, - enumFromThenToName, enumFromToName, - - -- Applicative stuff - pureAName, apAName, thenAName, - - -- Functor stuff - fmapName, - - -- Monad stuff - thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName, - returnMName, joinMName, - - -- MonadFail - monadFailClassName, failMName, failMName_preMFP, - - -- MonadFix - monadFixClassName, mfixName, - - -- Arrow stuff - arrAName, composeAName, firstAName, - appAName, choiceAName, loopAName, - - -- Ix stuff - ixClassName, - - -- Show stuff - showClassName, - - -- Read stuff - readClassName, - - -- Stable pointers - newStablePtrName, - - -- GHC Extensions - groupWithName, - - -- Strings and lists - unpackCStringName, - unpackCStringFoldrName, unpackCStringUtf8Name, - - -- Overloaded lists - isListClassName, - fromListName, - fromListNName, - toListName, - - -- List operations - concatName, filterName, mapName, - zipName, foldrName, buildName, augmentName, appendName, - - -- FFI primitive types that are not wired-in. - stablePtrTyConName, ptrTyConName, funPtrTyConName, - int8TyConName, int16TyConName, int32TyConName, int64TyConName, - word16TyConName, word32TyConName, word64TyConName, - - -- Others - otherwiseIdName, inlineIdName, - eqStringName, assertName, breakpointName, breakpointCondName, - breakpointAutoName, opaqueTyConName, - assertErrorName, - printName, fstName, sndName, - - -- Integer - integerTyConName, mkIntegerName, - integerToWord64Name, integerToInt64Name, - word64ToIntegerName, int64ToIntegerName, - plusIntegerName, timesIntegerName, smallIntegerName, - wordToIntegerName, - integerToWordName, integerToIntName, minusIntegerName, - negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, - absIntegerName, signumIntegerName, - leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, - compareIntegerName, quotRemIntegerName, divModIntegerName, - quotIntegerName, remIntegerName, divIntegerName, modIntegerName, - floatFromIntegerName, doubleFromIntegerName, - encodeFloatIntegerName, encodeDoubleIntegerName, - decodeDoubleIntegerName, - gcdIntegerName, lcmIntegerName, - andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, - shiftLIntegerName, shiftRIntegerName, bitIntegerName, - - -- Natural - naturalTyConName, - naturalFromIntegerName, - - -- Float/Double - rationalToFloatName, - rationalToDoubleName, - - -- Other classes - randomClassName, randomGenClassName, monadPlusClassName, - - -- Type-level naturals - knownNatClassName, knownSymbolClassName, - - -- Overloaded labels - isLabelClassName, - - -- Implicit Parameters - ipClassName, - - -- Overloaded record fields - hasFieldClassName, - - -- Call Stacks - callStackTyConName, - emptyCallStackName, pushCallStackName, - - -- Source Locations - srcLocDataConName, - - -- Annotation type checking - toAnnotationWrapperName - - -- The Ordering type - , orderingTyConName - , ltDataConName, eqDataConName, gtDataConName - - -- The SPEC type for SpecConstr - , specTyConName - - -- The Either type - , eitherTyConName, leftDataConName, rightDataConName - - -- Plugins - , pluginTyConName - , frontendPluginTyConName - - -- Generics - , genClassName, gen1ClassName - , datatypeClassName, constructorClassName, selectorClassName - - -- Monad comprehensions - , guardMName - , liftMName - , mzipName - - -- GHCi Sandbox - , ghciIoClassName, ghciStepIoMName - - -- StaticPtr - , makeStaticName - , staticPtrTyConName - , staticPtrDataConName, staticPtrInfoDataConName - , fromStaticPtrName - - -- Fingerprint - , fingerprintDataConName - - -- Custom type errors - , errorMessageTypeErrorFamName - , typeErrorTextDataConName - , typeErrorAppendDataConName - , typeErrorVAppendDataConName - , typeErrorShowTypeDataConName - - -- homogeneous equality - , eqTyConName - - ] ++ case cIntegerLibraryType of - IntegerGMP -> [integerSDataConName] - IntegerSimple -> [] - -genericTyConNames :: [Name] -genericTyConNames = [ - v1TyConName, u1TyConName, par1TyConName, rec1TyConName, - k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, - d1TyConName, c1TyConName, s1TyConName, noSelTyConName, - repTyConName, rep1TyConName, uRecTyConName, - uAddrTyConName, uCharTyConName, uDoubleTyConName, - uFloatTyConName, uIntTyConName, uWordTyConName, - prefixIDataConName, infixIDataConName, leftAssociativeDataConName, - rightAssociativeDataConName, notAssociativeDataConName, - sourceUnpackDataConName, sourceNoUnpackDataConName, - noSourceUnpackednessDataConName, sourceLazyDataConName, - sourceStrictDataConName, noSourceStrictnessDataConName, - decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, - metaDataDataConName, metaConsDataConName, metaSelDataConName - ] - -{- -************************************************************************ -* * -\subsection{Module names} -* * -************************************************************************ - - ---MetaHaskell Extension Add a new module here --} - -pRELUDE :: Module -pRELUDE = mkBaseModule_ pRELUDE_NAME - -gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, - gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING, - gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_NATURAL, gHC_LIST, - gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, - dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, dATA_SEMIGROUP, - gHC_CONC, gHC_IO, gHC_IO_Exception, - gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, - gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, - tYPEABLE, tYPEABLE_INTERNAL, gENERICS, - rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL, - aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, - cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPENATS, dATA_TYPE_EQUALITY, - dATA_COERCE :: Module - -gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values -gHC_TYPES = mkPrimModule (fsLit "GHC.Types") -gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") -gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") -gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") - -gHC_BASE = mkBaseModule (fsLit "GHC.Base") -gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") -gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi") -gHC_SHOW = mkBaseModule (fsLit "GHC.Show") -gHC_READ = mkBaseModule (fsLit "GHC.Read") -gHC_NUM = mkBaseModule (fsLit "GHC.Num") -gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") -gHC_NATURAL = mkBaseModule (fsLit "GHC.Natural") -gHC_LIST = mkBaseModule (fsLit "GHC.List") -gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") -dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") -dATA_EITHER = mkBaseModule (fsLit "Data.Either") -dATA_STRING = mkBaseModule (fsLit "Data.String") -dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") -dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") -dATA_SEMIGROUP = mkBaseModule (fsLit "Data.Semigroup") -dATA_MONOID = mkBaseModule (fsLit "Data.Monoid") -gHC_CONC = mkBaseModule (fsLit "GHC.Conc") -gHC_IO = mkBaseModule (fsLit "GHC.IO") -gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception") -gHC_ST = mkBaseModule (fsLit "GHC.ST") -gHC_ARR = mkBaseModule (fsLit "GHC.Arr") -gHC_STABLE = mkBaseModule (fsLit "GHC.Stable") -gHC_PTR = mkBaseModule (fsLit "GHC.Ptr") -gHC_ERR = mkBaseModule (fsLit "GHC.Err") -gHC_REAL = mkBaseModule (fsLit "GHC.Real") -gHC_FLOAT = mkBaseModule (fsLit "GHC.Float") -gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") -sYSTEM_IO = mkBaseModule (fsLit "System.IO") -dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") -tYPEABLE = mkBaseModule (fsLit "Data.Typeable") -tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal") -gENERICS = mkBaseModule (fsLit "Data.Data") -rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") -lEX = mkBaseModule (fsLit "Text.Read.Lex") -gHC_INT = mkBaseModule (fsLit "GHC.Int") -gHC_WORD = mkBaseModule (fsLit "GHC.Word") -mONAD = mkBaseModule (fsLit "Control.Monad") -mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") -mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") -mONAD_FAIL = mkBaseModule (fsLit "Control.Monad.Fail") -aRROW = mkBaseModule (fsLit "Control.Arrow") -cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") -gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") -rANDOM = mkBaseModule (fsLit "System.Random") -gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") -cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") -gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics") -gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") -gHC_TYPENATS = mkBaseModule (fsLit "GHC.TypeNats") -dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality") -dATA_COERCE = mkBaseModule (fsLit "Data.Coerce") - -gHC_PARR' :: Module -gHC_PARR' = mkBaseModule (fsLit "GHC.PArr") - -gHC_SRCLOC :: Module -gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc") - -gHC_STACK, gHC_STACK_TYPES :: Module -gHC_STACK = mkBaseModule (fsLit "GHC.Stack") -gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types") - -gHC_STATICPTR :: Module -gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr") - -gHC_STATICPTR_INTERNAL :: Module -gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal") - -gHC_FINGERPRINT_TYPE :: Module -gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type") - -gHC_OVER_LABELS :: Module -gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels") - -gHC_RECORDS :: Module -gHC_RECORDS = mkBaseModule (fsLit "GHC.Records") - -mAIN, rOOT_MAIN :: Module -mAIN = mkMainModule_ mAIN_NAME -rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation - -mkInteractiveModule :: Int -> Module --- (mkInteractiveMoudule 9) makes module 'interactive:M9' -mkInteractiveModule n = mkModule interactiveUnitId (mkModuleName ("Ghci" ++ show n)) - -pRELUDE_NAME, mAIN_NAME :: ModuleName -pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") -mAIN_NAME = mkModuleNameFS (fsLit "Main") - -dATA_ARRAY_PARALLEL_NAME, dATA_ARRAY_PARALLEL_PRIM_NAME :: ModuleName -dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel") -dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim") - -mkPrimModule :: FastString -> Module -mkPrimModule m = mkModule primUnitId (mkModuleNameFS m) - -mkIntegerModule :: FastString -> Module -mkIntegerModule m = mkModule integerUnitId (mkModuleNameFS m) - -mkBaseModule :: FastString -> Module -mkBaseModule m = mkModule baseUnitId (mkModuleNameFS m) - -mkBaseModule_ :: ModuleName -> Module -mkBaseModule_ m = mkModule baseUnitId m - -mkThisGhcModule :: FastString -> Module -mkThisGhcModule m = mkModule thisGhcUnitId (mkModuleNameFS m) - -mkThisGhcModule_ :: ModuleName -> Module -mkThisGhcModule_ m = mkModule thisGhcUnitId m - -mkMainModule :: FastString -> Module -mkMainModule m = mkModule mainUnitId (mkModuleNameFS m) - -mkMainModule_ :: ModuleName -> Module -mkMainModule_ m = mkModule mainUnitId m - -{- -************************************************************************ -* * - RdrNames -* * -************************************************************************ --} - -main_RDR_Unqual :: RdrName -main_RDR_Unqual = mkUnqual varName (fsLit "main") - -- We definitely don't want an Orig RdrName, because - -- main might, in principle, be imported into module Main - -forall_tv_RDR, dot_tv_RDR :: RdrName -forall_tv_RDR = mkUnqual tvName (fsLit "forall") -dot_tv_RDR = mkUnqual tvName (fsLit ".") - -eq_RDR, ge_RDR, ne_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, - ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName -eq_RDR = nameRdrName eqName -ge_RDR = nameRdrName geName -ne_RDR = varQual_RDR gHC_CLASSES (fsLit "/=") -le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") -lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") -gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") -compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") -ltTag_RDR = dataQual_RDR gHC_TYPES (fsLit "LT") -eqTag_RDR = dataQual_RDR gHC_TYPES (fsLit "EQ") -gtTag_RDR = dataQual_RDR gHC_TYPES (fsLit "GT") - -eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR - :: RdrName -eqClass_RDR = nameRdrName eqClassName -numClass_RDR = nameRdrName numClassName -ordClass_RDR = nameRdrName ordClassName -enumClass_RDR = nameRdrName enumClassName -monadClass_RDR = nameRdrName monadClassName - -map_RDR, append_RDR :: RdrName -map_RDR = varQual_RDR gHC_BASE (fsLit "map") -append_RDR = varQual_RDR gHC_BASE (fsLit "++") - -foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR_preMFP, failM_RDR:: RdrName -foldr_RDR = nameRdrName foldrName -build_RDR = nameRdrName buildName -returnM_RDR = nameRdrName returnMName -bindM_RDR = nameRdrName bindMName -failM_RDR_preMFP = nameRdrName failMName_preMFP -failM_RDR = nameRdrName failMName - -left_RDR, right_RDR :: RdrName -left_RDR = nameRdrName leftDataConName -right_RDR = nameRdrName rightDataConName - -fromEnum_RDR, toEnum_RDR :: RdrName -fromEnum_RDR = varQual_RDR gHC_ENUM (fsLit "fromEnum") -toEnum_RDR = varQual_RDR gHC_ENUM (fsLit "toEnum") - -enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName -enumFrom_RDR = nameRdrName enumFromName -enumFromTo_RDR = nameRdrName enumFromToName -enumFromThen_RDR = nameRdrName enumFromThenName -enumFromThenTo_RDR = nameRdrName enumFromThenToName - -ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR :: RdrName -ratioDataCon_RDR = nameRdrName ratioDataConName -plusInteger_RDR = nameRdrName plusIntegerName -timesInteger_RDR = nameRdrName timesIntegerName - -ioDataCon_RDR :: RdrName -ioDataCon_RDR = nameRdrName ioDataConName - -eqString_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, - unpackCStringUtf8_RDR :: RdrName -eqString_RDR = nameRdrName eqStringName -unpackCString_RDR = nameRdrName unpackCStringName -unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName -unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name - -newStablePtr_RDR :: RdrName -newStablePtr_RDR = nameRdrName newStablePtrName - -bindIO_RDR, returnIO_RDR :: RdrName -bindIO_RDR = nameRdrName bindIOName -returnIO_RDR = nameRdrName returnIOName - -fromInteger_RDR, fromRational_RDR, minus_RDR, times_RDR, plus_RDR :: RdrName -fromInteger_RDR = nameRdrName fromIntegerName -fromRational_RDR = nameRdrName fromRationalName -minus_RDR = nameRdrName minusName -times_RDR = varQual_RDR gHC_NUM (fsLit "*") -plus_RDR = varQual_RDR gHC_NUM (fsLit "+") - -toInteger_RDR, toRational_RDR, fromIntegral_RDR :: RdrName -toInteger_RDR = nameRdrName toIntegerName -toRational_RDR = nameRdrName toRationalName -fromIntegral_RDR = nameRdrName fromIntegralName - -stringTy_RDR, fromString_RDR :: RdrName -stringTy_RDR = tcQual_RDR gHC_BASE (fsLit "String") -fromString_RDR = nameRdrName fromStringName - -fromList_RDR, fromListN_RDR, toList_RDR :: RdrName -fromList_RDR = nameRdrName fromListName -fromListN_RDR = nameRdrName fromListNName -toList_RDR = nameRdrName toListName - -compose_RDR :: RdrName -compose_RDR = varQual_RDR gHC_BASE (fsLit ".") - -not_RDR, getTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR, - and_RDR, range_RDR, inRange_RDR, index_RDR, - unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName -and_RDR = varQual_RDR gHC_CLASSES (fsLit "&&") -not_RDR = varQual_RDR gHC_CLASSES (fsLit "not") -getTag_RDR = varQual_RDR gHC_BASE (fsLit "getTag") -succ_RDR = varQual_RDR gHC_ENUM (fsLit "succ") -pred_RDR = varQual_RDR gHC_ENUM (fsLit "pred") -minBound_RDR = varQual_RDR gHC_ENUM (fsLit "minBound") -maxBound_RDR = varQual_RDR gHC_ENUM (fsLit "maxBound") -range_RDR = varQual_RDR gHC_ARR (fsLit "range") -inRange_RDR = varQual_RDR gHC_ARR (fsLit "inRange") -index_RDR = varQual_RDR gHC_ARR (fsLit "index") -unsafeIndex_RDR = varQual_RDR gHC_ARR (fsLit "unsafeIndex") -unsafeRangeSize_RDR = varQual_RDR gHC_ARR (fsLit "unsafeRangeSize") - -readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR, - readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName -readList_RDR = varQual_RDR gHC_READ (fsLit "readList") -readListDefault_RDR = varQual_RDR gHC_READ (fsLit "readListDefault") -readListPrec_RDR = varQual_RDR gHC_READ (fsLit "readListPrec") -readListPrecDefault_RDR = varQual_RDR gHC_READ (fsLit "readListPrecDefault") -readPrec_RDR = varQual_RDR gHC_READ (fsLit "readPrec") -parens_RDR = varQual_RDR gHC_READ (fsLit "parens") -choose_RDR = varQual_RDR gHC_READ (fsLit "choose") -lexP_RDR = varQual_RDR gHC_READ (fsLit "lexP") -expectP_RDR = varQual_RDR gHC_READ (fsLit "expectP") - -punc_RDR, ident_RDR, symbol_RDR :: RdrName -punc_RDR = dataQual_RDR lEX (fsLit "Punc") -ident_RDR = dataQual_RDR lEX (fsLit "Ident") -symbol_RDR = dataQual_RDR lEX (fsLit "Symbol") - -step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName -step_RDR = varQual_RDR rEAD_PREC (fsLit "step") -alt_RDR = varQual_RDR rEAD_PREC (fsLit "+++") -reset_RDR = varQual_RDR rEAD_PREC (fsLit "reset") -prec_RDR = varQual_RDR rEAD_PREC (fsLit "prec") -pfail_RDR = varQual_RDR rEAD_PREC (fsLit "pfail") - -showList_RDR, showList___RDR, showsPrec_RDR, shows_RDR, showString_RDR, - showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName -showList_RDR = varQual_RDR gHC_SHOW (fsLit "showList") -showList___RDR = varQual_RDR gHC_SHOW (fsLit "showList__") -showsPrec_RDR = varQual_RDR gHC_SHOW (fsLit "showsPrec") -shows_RDR = varQual_RDR gHC_SHOW (fsLit "shows") -showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString") -showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") -showCommaSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showCommaSpace") -showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") - -undefined_RDR :: RdrName -undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") - -error_RDR :: RdrName -error_RDR = varQual_RDR gHC_ERR (fsLit "error") - --- Generics (constructors and functions) -u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, - k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, - prodDataCon_RDR, comp1DataCon_RDR, - unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, - from_RDR, from1_RDR, to_RDR, to1_RDR, - datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR, - conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR, - prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, - rightAssocDataCon_RDR, notAssocDataCon_RDR, - uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR, - uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR, - uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR, - uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName - -u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1") -par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1") -rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1") -k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1") -m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1") - -l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1") -r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") - -prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") -comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") - -unPar1_RDR = varQual_RDR gHC_GENERICS (fsLit "unPar1") -unRec1_RDR = varQual_RDR gHC_GENERICS (fsLit "unRec1") -unK1_RDR = varQual_RDR gHC_GENERICS (fsLit "unK1") -unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1") - -from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") -from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") -to_RDR = varQual_RDR gHC_GENERICS (fsLit "to") -to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1") - -datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName") -moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName") -packageName_RDR = varQual_RDR gHC_GENERICS (fsLit "packageName") -isNewtypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "isNewtype") -selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName") -conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName") -conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity") -conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord") - -prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix") -infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix") -leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative") -rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative") -notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative") - -uAddrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UAddr") -uCharDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UChar") -uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble") -uFloatDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UFloat") -uIntDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UInt") -uWordDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UWord") - -uAddrHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uAddr#") -uCharHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uChar#") -uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#") -uFloatHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uFloat#") -uIntHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uInt#") -uWordHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uWord#") - -fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, - foldMap_RDR, traverse_RDR, mempty_RDR, mappend_RDR :: RdrName -fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") -replace_RDR = varQual_RDR gHC_BASE (fsLit "<$") -pure_RDR = nameRdrName pureAName -ap_RDR = nameRdrName apAName -liftA2_RDR = varQual_RDR gHC_BASE (fsLit "liftA2") -foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr") -foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap") -traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") -mempty_RDR = varQual_RDR gHC_BASE (fsLit "mempty") -mappend_RDR = varQual_RDR gHC_BASE (fsLit "mappend") - -eqTyCon_RDR :: RdrName -eqTyCon_RDR = tcQual_RDR dATA_TYPE_EQUALITY (fsLit "~") - ----------------------- -varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR - :: Module -> FastString -> RdrName -varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) -tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str) -clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str) -dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) - -{- -************************************************************************ -* * -\subsection{Known-key names} -* * -************************************************************************ - -Many of these Names are not really "built in", but some parts of the -compiler (notably the deriving mechanism) need to mention their names, -and it's convenient to write them all down in one place. - ---MetaHaskell Extension add the constrs and the lower case case --- guys as well (perhaps) e.g. see trueDataConName below --} - -wildCardName :: Name -wildCardName = mkSystemVarName wildCardKey (fsLit "wild") - -runMainIOName :: Name -runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey - -orderingTyConName, ltDataConName, eqDataConName, gtDataConName :: Name -orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey -ltDataConName = dcQual gHC_TYPES (fsLit "LT") ltDataConKey -eqDataConName = dcQual gHC_TYPES (fsLit "EQ") eqDataConKey -gtDataConName = dcQual gHC_TYPES (fsLit "GT") gtDataConKey - -specTyConName :: Name -specTyConName = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey - -eitherTyConName, leftDataConName, rightDataConName :: Name -eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey -leftDataConName = dcQual dATA_EITHER (fsLit "Left") leftDataConKey -rightDataConName = dcQual dATA_EITHER (fsLit "Right") rightDataConKey - --- Generics (types) -v1TyConName, u1TyConName, par1TyConName, rec1TyConName, - k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, - d1TyConName, c1TyConName, s1TyConName, noSelTyConName, - repTyConName, rep1TyConName, uRecTyConName, - uAddrTyConName, uCharTyConName, uDoubleTyConName, - uFloatTyConName, uIntTyConName, uWordTyConName, - prefixIDataConName, infixIDataConName, leftAssociativeDataConName, - rightAssociativeDataConName, notAssociativeDataConName, - sourceUnpackDataConName, sourceNoUnpackDataConName, - noSourceUnpackednessDataConName, sourceLazyDataConName, - sourceStrictDataConName, noSourceStrictnessDataConName, - decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, - metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name - -v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey -u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey -par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey -rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey -k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey -m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey - -sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey -prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey -compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey - -rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey -dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey -cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey -sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey - -rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey -d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey -c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey -s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey -noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey - -repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey -rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey - -uRecTyConName = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey -uAddrTyConName = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey -uCharTyConName = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey -uDoubleTyConName = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey -uFloatTyConName = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey -uIntTyConName = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey -uWordTyConName = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey - -prefixIDataConName = dcQual gHC_GENERICS (fsLit "PrefixI") prefixIDataConKey -infixIDataConName = dcQual gHC_GENERICS (fsLit "InfixI") infixIDataConKey -leftAssociativeDataConName = dcQual gHC_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey -rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey -notAssociativeDataConName = dcQual gHC_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey - -sourceUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceUnpack") sourceUnpackDataConKey -sourceNoUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceNoUnpack") sourceNoUnpackDataConKey -noSourceUnpackednessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey -sourceLazyDataConName = dcQual gHC_GENERICS (fsLit "SourceLazy") sourceLazyDataConKey -sourceStrictDataConName = dcQual gHC_GENERICS (fsLit "SourceStrict") sourceStrictDataConKey -noSourceStrictnessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceStrictness") noSourceStrictnessDataConKey -decidedLazyDataConName = dcQual gHC_GENERICS (fsLit "DecidedLazy") decidedLazyDataConKey -decidedStrictDataConName = dcQual gHC_GENERICS (fsLit "DecidedStrict") decidedStrictDataConKey -decidedUnpackDataConName = dcQual gHC_GENERICS (fsLit "DecidedUnpack") decidedUnpackDataConKey - -metaDataDataConName = dcQual gHC_GENERICS (fsLit "MetaData") metaDataDataConKey -metaConsDataConName = dcQual gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey -metaSelDataConName = dcQual gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey - --- Primitive Int -divIntName, modIntName :: Name -divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey -modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey - --- Base strings Strings -unpackCStringName, unpackCStringFoldrName, - unpackCStringUtf8Name, eqStringName :: Name -unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey -unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey -unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey -eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey - --- The 'inline' function -inlineIdName :: Name -inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey - --- Base classes (Eq, Ord, Functor) -fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name -eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey -eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey -ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey -geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey -functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey -fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey - --- Class Monad -monadClassName, thenMName, bindMName, returnMName, failMName_preMFP :: Name -monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey -thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey -bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey -returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey -failMName_preMFP = varQual gHC_BASE (fsLit "fail") failMClassOpKey_preMFP - --- Class MonadFail -monadFailClassName, failMName :: Name -monadFailClassName = clsQual mONAD_FAIL (fsLit "MonadFail") monadFailClassKey -failMName = varQual mONAD_FAIL (fsLit "fail") failMClassOpKey - --- Class Applicative -applicativeClassName, pureAName, apAName, thenAName :: Name -applicativeClassName = clsQual gHC_BASE (fsLit "Applicative") applicativeClassKey -apAName = varQual gHC_BASE (fsLit "<*>") apAClassOpKey -pureAName = varQual gHC_BASE (fsLit "pure") pureAClassOpKey -thenAName = varQual gHC_BASE (fsLit "*>") thenAClassOpKey - --- Classes (Foldable, Traversable) -foldableClassName, traversableClassName :: Name -foldableClassName = clsQual dATA_FOLDABLE (fsLit "Foldable") foldableClassKey -traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") traversableClassKey - --- Classes (Semigroup, Monoid) -semigroupClassName, sappendName :: Name -semigroupClassName = clsQual dATA_SEMIGROUP (fsLit "Semigroup") semigroupClassKey -sappendName = varQual dATA_SEMIGROUP (fsLit "<>") sappendClassOpKey -monoidClassName, memptyName, mappendName, mconcatName :: Name -monoidClassName = clsQual gHC_BASE (fsLit "Monoid") monoidClassKey -memptyName = varQual gHC_BASE (fsLit "mempty") memptyClassOpKey -mappendName = varQual gHC_BASE (fsLit "mappend") mappendClassOpKey -mconcatName = varQual gHC_BASE (fsLit "mconcat") mconcatClassOpKey - - - --- AMP additions - -joinMName, alternativeClassName :: Name -joinMName = varQual gHC_BASE (fsLit "join") joinMIdKey -alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey - --- -joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey, - alternativeClassKey :: Unique -joinMIdKey = mkPreludeMiscIdUnique 750 -apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*> -pureAClassOpKey = mkPreludeMiscIdUnique 752 -thenAClassOpKey = mkPreludeMiscIdUnique 753 -alternativeClassKey = mkPreludeMiscIdUnique 754 - - --- Functions for GHC extensions -groupWithName :: Name -groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey - --- Random PrelBase functions -fromStringName, otherwiseIdName, foldrName, buildName, augmentName, - mapName, appendName, assertName, - breakpointName, breakpointCondName, breakpointAutoName, - opaqueTyConName :: Name -fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey -otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey -foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey -buildName = varQual gHC_BASE (fsLit "build") buildIdKey -augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey -mapName = varQual gHC_BASE (fsLit "map") mapIdKey -appendName = varQual gHC_BASE (fsLit "++") appendIdKey -assertName = varQual gHC_BASE (fsLit "assert") assertIdKey -breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey -breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey -breakpointAutoName= varQual gHC_BASE (fsLit "breakpointAuto") breakpointAutoIdKey -opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey - -breakpointJumpName :: Name -breakpointJumpName - = mkInternalName - breakpointJumpIdKey - (mkOccNameFS varName (fsLit "breakpointJump")) - noSrcSpan -breakpointCondJumpName :: Name -breakpointCondJumpName - = mkInternalName - breakpointCondJumpIdKey - (mkOccNameFS varName (fsLit "breakpointCondJump")) - noSrcSpan -breakpointAutoJumpName :: Name -breakpointAutoJumpName - = mkInternalName - breakpointAutoJumpIdKey - (mkOccNameFS varName (fsLit "breakpointAutoJump")) - noSrcSpan - --- PrelTup -fstName, sndName :: Name -fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey -sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey - --- Module GHC.Num -numClassName, fromIntegerName, minusName, negateName :: Name -numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey -fromIntegerName = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey -minusName = varQual gHC_NUM (fsLit "-") minusClassOpKey -negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey - -integerTyConName, mkIntegerName, integerSDataConName, - integerToWord64Name, integerToInt64Name, - word64ToIntegerName, int64ToIntegerName, - plusIntegerName, timesIntegerName, smallIntegerName, - wordToIntegerName, - integerToWordName, integerToIntName, minusIntegerName, - negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, - absIntegerName, signumIntegerName, - leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, - compareIntegerName, quotRemIntegerName, divModIntegerName, - quotIntegerName, remIntegerName, divIntegerName, modIntegerName, - floatFromIntegerName, doubleFromIntegerName, - encodeFloatIntegerName, encodeDoubleIntegerName, - decodeDoubleIntegerName, - gcdIntegerName, lcmIntegerName, - andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, - shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name -integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey -integerSDataConName = dcQual gHC_INTEGER_TYPE (fsLit n) integerSDataConKey - where n = case cIntegerLibraryType of - IntegerGMP -> "S#" - IntegerSimple -> panic "integerSDataConName evaluated for integer-simple" -mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey -integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey -integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey -word64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "word64ToInteger") word64ToIntegerIdKey -int64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "int64ToInteger") int64ToIntegerIdKey -plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey -timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey -smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey -wordToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "wordToInteger") wordToIntegerIdKey -integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") integerToWordIdKey -integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey -minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey -negateIntegerName = varQual gHC_INTEGER_TYPE (fsLit "negateInteger") negateIntegerIdKey -eqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#") eqIntegerPrimIdKey -neqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#") neqIntegerPrimIdKey -absIntegerName = varQual gHC_INTEGER_TYPE (fsLit "absInteger") absIntegerIdKey -signumIntegerName = varQual gHC_INTEGER_TYPE (fsLit "signumInteger") signumIntegerIdKey -leIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "leInteger#") leIntegerPrimIdKey -gtIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#") gtIntegerPrimIdKey -ltIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#") ltIntegerPrimIdKey -geIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "geInteger#") geIntegerPrimIdKey -compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey -quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey -divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey -quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey -remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey -divIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divInteger") divIntegerIdKey -modIntegerName = varQual gHC_INTEGER_TYPE (fsLit "modInteger") modIntegerIdKey -floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey -doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey -encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey -encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey -decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey -gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey -lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey -andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey -orIntegerName = varQual gHC_INTEGER_TYPE (fsLit "orInteger") orIntegerIdKey -xorIntegerName = varQual gHC_INTEGER_TYPE (fsLit "xorInteger") xorIntegerIdKey -complementIntegerName = varQual gHC_INTEGER_TYPE (fsLit "complementInteger") complementIntegerIdKey -shiftLIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftLInteger") shiftLIntegerIdKey -shiftRIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger") shiftRIntegerIdKey -bitIntegerName = varQual gHC_INTEGER_TYPE (fsLit "bitInteger") bitIntegerIdKey - --- GHC.Natural types -naturalTyConName :: Name -naturalTyConName = tcQual gHC_NATURAL (fsLit "Natural") naturalTyConKey - -naturalFromIntegerName :: Name -naturalFromIntegerName = varQual gHC_NATURAL (fsLit "naturalFromInteger") naturalFromIntegerIdKey - --- GHC.Real types and classes -rationalTyConName, ratioTyConName, ratioDataConName, realClassName, - integralClassName, realFracClassName, fractionalClassName, - fromRationalName, toIntegerName, toRationalName, fromIntegralName, - realToFracName :: Name -rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey -ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey -ratioDataConName = dcQual gHC_REAL (fsLit ":%") ratioDataConKey -realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey -integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey -realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey -fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey -fromRationalName = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey -toIntegerName = varQual gHC_REAL (fsLit "toInteger") toIntegerClassOpKey -toRationalName = varQual gHC_REAL (fsLit "toRational") toRationalClassOpKey -fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey -realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey - --- PrelFloat classes -floatingClassName, realFloatClassName :: Name -floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey -realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey - --- other GHC.Float functions -rationalToFloatName, rationalToDoubleName :: Name -rationalToFloatName = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey -rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey - --- Class Ix -ixClassName :: Name -ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey - --- Typeable representation types -trModuleTyConName - , trModuleDataConName - , trNameTyConName - , trNameSDataConName - , trNameDDataConName - , trTyConTyConName - , trTyConDataConName - :: Name -trModuleTyConName = tcQual gHC_TYPES (fsLit "Module") trModuleTyConKey -trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey -trNameTyConName = tcQual gHC_TYPES (fsLit "TrName") trNameTyConKey -trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey -trNameDDataConName = dcQual gHC_TYPES (fsLit "TrNameD") trNameDDataConKey -trTyConTyConName = tcQual gHC_TYPES (fsLit "TyCon") trTyConTyConKey -trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey - -kindRepTyConName - , kindRepTyConAppDataConName - , kindRepVarDataConName - , kindRepAppDataConName - , kindRepFunDataConName - , kindRepTYPEDataConName - , kindRepTypeLitSDataConName - , kindRepTypeLitDDataConName - :: Name -kindRepTyConName = tcQual gHC_TYPES (fsLit "KindRep") kindRepTyConKey -kindRepTyConAppDataConName = dcQual gHC_TYPES (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey -kindRepVarDataConName = dcQual gHC_TYPES (fsLit "KindRepVar") kindRepVarDataConKey -kindRepAppDataConName = dcQual gHC_TYPES (fsLit "KindRepApp") kindRepAppDataConKey -kindRepFunDataConName = dcQual gHC_TYPES (fsLit "KindRepFun") kindRepFunDataConKey -kindRepTYPEDataConName = dcQual gHC_TYPES (fsLit "KindRepTYPE") kindRepTYPEDataConKey -kindRepTypeLitSDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey -kindRepTypeLitDDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey - -typeLitSortTyConName - , typeLitSymbolDataConName - , typeLitNatDataConName - :: Name -typeLitSortTyConName = tcQual gHC_TYPES (fsLit "TypeLitSort") typeLitSortTyConKey -typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey -typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey - --- Class Typeable, and functions for constructing `Typeable` dictionaries -typeableClassName - , typeRepTyConName - , someTypeRepTyConName - , someTypeRepDataConName - , mkTrConName - , mkTrAppName - , mkTrFunName - , typeRepIdName - , typeNatTypeRepName - , typeSymbolTypeRepName - , trGhcPrimModuleName - :: Name -typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey -typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey -someTypeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey -someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey -typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey -mkTrConName = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey -mkTrAppName = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp") mkTrAppKey -mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey -typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey -typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey --- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) --- See Note [Grand plan for Typeable] in TcTypeable. -trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey - --- Typeable KindReps for some common cases -starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName :: Name -starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey -starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey -starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey - --- Custom type errors -errorMessageTypeErrorFamName - , typeErrorTextDataConName - , typeErrorAppendDataConName - , typeErrorVAppendDataConName - , typeErrorShowTypeDataConName - :: Name - -errorMessageTypeErrorFamName = - tcQual gHC_TYPELITS (fsLit "TypeError") errorMessageTypeErrorFamKey - -typeErrorTextDataConName = - dcQual gHC_TYPELITS (fsLit "Text") typeErrorTextDataConKey - -typeErrorAppendDataConName = - dcQual gHC_TYPELITS (fsLit ":<>:") typeErrorAppendDataConKey - -typeErrorVAppendDataConName = - dcQual gHC_TYPELITS (fsLit ":$$:") typeErrorVAppendDataConKey - -typeErrorShowTypeDataConName = - dcQual gHC_TYPELITS (fsLit "ShowType") typeErrorShowTypeDataConKey - - - --- Dynamic -toDynName :: Name -toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey - --- Class Data -dataClassName :: Name -dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey - --- Error module -assertErrorName :: Name -assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey - --- Enum module (Enum, Bounded) -enumClassName, enumFromName, enumFromToName, enumFromThenName, - enumFromThenToName, boundedClassName :: Name -enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey -enumFromName = varQual gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey -enumFromToName = varQual gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey -enumFromThenName = varQual gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey -enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey -boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey - --- List functions -concatName, filterName, zipName :: Name -concatName = varQual gHC_LIST (fsLit "concat") concatIdKey -filterName = varQual gHC_LIST (fsLit "filter") filterIdKey -zipName = varQual gHC_LIST (fsLit "zip") zipIdKey - --- Overloaded lists -isListClassName, fromListName, fromListNName, toListName :: Name -isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey -fromListName = varQual gHC_EXTS (fsLit "fromList") fromListClassOpKey -fromListNName = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey -toListName = varQual gHC_EXTS (fsLit "toList") toListClassOpKey - --- Class Show -showClassName :: Name -showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey - --- Class Read -readClassName :: Name -readClassName = clsQual gHC_READ (fsLit "Read") readClassKey - --- Classes Generic and Generic1, Datatype, Constructor and Selector -genClassName, gen1ClassName, datatypeClassName, constructorClassName, - selectorClassName :: Name -genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey -gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey - -datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey -constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey -selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey - -genericClassNames :: [Name] -genericClassNames = [genClassName, gen1ClassName] - --- GHCi things -ghciIoClassName, ghciStepIoMName :: Name -ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey -ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey - --- IO things -ioTyConName, ioDataConName, - thenIOName, bindIOName, returnIOName, failIOName :: Name -ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey -ioDataConName = dcQual gHC_TYPES (fsLit "IO") ioDataConKey -thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey -bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey -returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey -failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey - --- IO things -printName :: Name -printName = varQual sYSTEM_IO (fsLit "print") printIdKey - --- Int, Word, and Addr things -int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name -int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey -int16TyConName = tcQual gHC_INT (fsLit "Int16") int16TyConKey -int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey -int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey - --- Word module -word16TyConName, word32TyConName, word64TyConName :: Name -word16TyConName = tcQual gHC_WORD (fsLit "Word16") word16TyConKey -word32TyConName = tcQual gHC_WORD (fsLit "Word32") word32TyConKey -word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey - --- PrelPtr module -ptrTyConName, funPtrTyConName :: Name -ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey -funPtrTyConName = tcQual gHC_PTR (fsLit "FunPtr") funPtrTyConKey - --- Foreign objects and weak pointers -stablePtrTyConName, newStablePtrName :: Name -stablePtrTyConName = tcQual gHC_STABLE (fsLit "StablePtr") stablePtrTyConKey -newStablePtrName = varQual gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey - --- Recursive-do notation -monadFixClassName, mfixName :: Name -monadFixClassName = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey -mfixName = varQual mONAD_FIX (fsLit "mfix") mfixIdKey - --- Arrow notation -arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name -arrAName = varQual aRROW (fsLit "arr") arrAIdKey -composeAName = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey -firstAName = varQual aRROW (fsLit "first") firstAIdKey -appAName = varQual aRROW (fsLit "app") appAIdKey -choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey -loopAName = varQual aRROW (fsLit "loop") loopAIdKey - --- Monad comprehensions -guardMName, liftMName, mzipName :: Name -guardMName = varQual mONAD (fsLit "guard") guardMIdKey -liftMName = varQual mONAD (fsLit "liftM") liftMIdKey -mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey - - --- Annotation type checking -toAnnotationWrapperName :: Name -toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey - --- Other classes, needed for type defaulting -monadPlusClassName, randomClassName, randomGenClassName, - isStringClassName :: Name -monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey -randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey -randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey -isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey - --- Type-level naturals -knownNatClassName :: Name -knownNatClassName = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey -knownSymbolClassName :: Name -knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey - --- Overloaded labels -isLabelClassName :: Name -isLabelClassName - = clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey - --- Implicit Parameters -ipClassName :: Name -ipClassName - = clsQual gHC_CLASSES (fsLit "IP") ipClassKey - --- Overloaded record fields -hasFieldClassName :: Name -hasFieldClassName - = clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey - --- Source Locations -callStackTyConName, emptyCallStackName, pushCallStackName, - srcLocDataConName :: Name -callStackTyConName - = tcQual gHC_STACK_TYPES (fsLit "CallStack") callStackTyConKey -emptyCallStackName - = varQual gHC_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey -pushCallStackName - = varQual gHC_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey -srcLocDataConName - = dcQual gHC_STACK_TYPES (fsLit "SrcLoc") srcLocDataConKey - --- plugins -pLUGINS :: Module -pLUGINS = mkThisGhcModule (fsLit "Plugins") -pluginTyConName :: Name -pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey -frontendPluginTyConName :: Name -frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey - --- Static pointers -makeStaticName :: Name -makeStaticName = - varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey - -staticPtrInfoTyConName :: Name -staticPtrInfoTyConName = - tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey - -staticPtrInfoDataConName :: Name -staticPtrInfoDataConName = - dcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey - -staticPtrTyConName :: Name -staticPtrTyConName = - tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey - -staticPtrDataConName :: Name -staticPtrDataConName = - dcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey - -fromStaticPtrName :: Name -fromStaticPtrName = - varQual gHC_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey - -fingerprintDataConName :: Name -fingerprintDataConName = - dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey - --- homogeneous equality. See Note [The equality types story] in TysPrim -eqTyConName :: Name -eqTyConName = tcQual dATA_TYPE_EQUALITY (fsLit "~") eqTyConKey - -{- -************************************************************************ -* * -\subsection{Local helpers} -* * -************************************************************************ - -All these are original names; hence mkOrig --} - -varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name -varQual = mk_known_key_name varName -tcQual = mk_known_key_name tcName -clsQual = mk_known_key_name clsName -dcQual = mk_known_key_name dataName - -mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name -mk_known_key_name space modu str unique - = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan - - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} -* * -************************************************************************ ---MetaHaskell extension hand allocate keys here --} - -boundedClassKey, enumClassKey, eqClassKey, floatingClassKey, - fractionalClassKey, integralClassKey, monadClassKey, dataClassKey, - functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey, - realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique -boundedClassKey = mkPreludeClassUnique 1 -enumClassKey = mkPreludeClassUnique 2 -eqClassKey = mkPreludeClassUnique 3 -floatingClassKey = mkPreludeClassUnique 5 -fractionalClassKey = mkPreludeClassUnique 6 -integralClassKey = mkPreludeClassUnique 7 -monadClassKey = mkPreludeClassUnique 8 -dataClassKey = mkPreludeClassUnique 9 -functorClassKey = mkPreludeClassUnique 10 -numClassKey = mkPreludeClassUnique 11 -ordClassKey = mkPreludeClassUnique 12 -readClassKey = mkPreludeClassUnique 13 -realClassKey = mkPreludeClassUnique 14 -realFloatClassKey = mkPreludeClassUnique 15 -realFracClassKey = mkPreludeClassUnique 16 -showClassKey = mkPreludeClassUnique 17 -ixClassKey = mkPreludeClassUnique 18 - -typeableClassKey, typeable1ClassKey, typeable2ClassKey, typeable3ClassKey, - typeable4ClassKey, typeable5ClassKey, typeable6ClassKey, typeable7ClassKey - :: Unique -typeableClassKey = mkPreludeClassUnique 20 -typeable1ClassKey = mkPreludeClassUnique 21 -typeable2ClassKey = mkPreludeClassUnique 22 -typeable3ClassKey = mkPreludeClassUnique 23 -typeable4ClassKey = mkPreludeClassUnique 24 -typeable5ClassKey = mkPreludeClassUnique 25 -typeable6ClassKey = mkPreludeClassUnique 26 -typeable7ClassKey = mkPreludeClassUnique 27 - -monadFixClassKey :: Unique -monadFixClassKey = mkPreludeClassUnique 28 - -monadFailClassKey :: Unique -monadFailClassKey = mkPreludeClassUnique 29 - -monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique -monadPlusClassKey = mkPreludeClassUnique 30 -randomClassKey = mkPreludeClassUnique 31 -randomGenClassKey = mkPreludeClassUnique 32 - -isStringClassKey :: Unique -isStringClassKey = mkPreludeClassUnique 33 - -applicativeClassKey, foldableClassKey, traversableClassKey :: Unique -applicativeClassKey = mkPreludeClassUnique 34 -foldableClassKey = mkPreludeClassUnique 35 -traversableClassKey = mkPreludeClassUnique 36 - -genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, - selectorClassKey :: Unique -genClassKey = mkPreludeClassUnique 37 -gen1ClassKey = mkPreludeClassUnique 38 - -datatypeClassKey = mkPreludeClassUnique 39 -constructorClassKey = mkPreludeClassUnique 40 -selectorClassKey = mkPreludeClassUnique 41 - --- KnownNat: see Note [KnowNat & KnownSymbol and EvLit] in TcEvidence -knownNatClassNameKey :: Unique -knownNatClassNameKey = mkPreludeClassUnique 42 - --- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in TcEvidence -knownSymbolClassNameKey :: Unique -knownSymbolClassNameKey = mkPreludeClassUnique 43 - -ghciIoClassKey :: Unique -ghciIoClassKey = mkPreludeClassUnique 44 - -isLabelClassNameKey :: Unique -isLabelClassNameKey = mkPreludeClassUnique 45 - -semigroupClassKey, monoidClassKey :: Unique -semigroupClassKey = mkPreludeClassUnique 46 -monoidClassKey = mkPreludeClassUnique 47 - --- Implicit Parameters -ipClassKey :: Unique -ipClassKey = mkPreludeClassUnique 48 - --- Overloaded record fields -hasFieldClassNameKey :: Unique -hasFieldClassNameKey = mkPreludeClassUnique 49 - - ----------------- Template Haskell ------------------- --- THNames.hs: USES ClassUniques 200-299 ------------------------------------------------------ - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} -* * -************************************************************************ --} - -addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, - byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, - doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey, - intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, - int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, - integerTyConKey, naturalTyConKey, - listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, - weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, - mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, - ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, - stablePtrTyConKey, eqTyConKey, heqTyConKey, - smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey :: Unique -addrPrimTyConKey = mkPreludeTyConUnique 1 -arrayPrimTyConKey = mkPreludeTyConUnique 3 -boolTyConKey = mkPreludeTyConUnique 4 -byteArrayPrimTyConKey = mkPreludeTyConUnique 5 -charPrimTyConKey = mkPreludeTyConUnique 7 -charTyConKey = mkPreludeTyConUnique 8 -doublePrimTyConKey = mkPreludeTyConUnique 9 -doubleTyConKey = mkPreludeTyConUnique 10 -floatPrimTyConKey = mkPreludeTyConUnique 11 -floatTyConKey = mkPreludeTyConUnique 12 -funTyConKey = mkPreludeTyConUnique 13 -intPrimTyConKey = mkPreludeTyConUnique 14 -intTyConKey = mkPreludeTyConUnique 15 -int8TyConKey = mkPreludeTyConUnique 16 -int16TyConKey = mkPreludeTyConUnique 17 -int32PrimTyConKey = mkPreludeTyConUnique 18 -int32TyConKey = mkPreludeTyConUnique 19 -int64PrimTyConKey = mkPreludeTyConUnique 20 -int64TyConKey = mkPreludeTyConUnique 21 -integerTyConKey = mkPreludeTyConUnique 22 -naturalTyConKey = mkPreludeTyConUnique 23 - -listTyConKey = mkPreludeTyConUnique 24 -foreignObjPrimTyConKey = mkPreludeTyConUnique 25 -maybeTyConKey = mkPreludeTyConUnique 26 -weakPrimTyConKey = mkPreludeTyConUnique 27 -mutableArrayPrimTyConKey = mkPreludeTyConUnique 28 -mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 29 -orderingTyConKey = mkPreludeTyConUnique 30 -mVarPrimTyConKey = mkPreludeTyConUnique 31 -ratioTyConKey = mkPreludeTyConUnique 32 -rationalTyConKey = mkPreludeTyConUnique 33 -realWorldTyConKey = mkPreludeTyConUnique 34 -stablePtrPrimTyConKey = mkPreludeTyConUnique 35 -stablePtrTyConKey = mkPreludeTyConUnique 36 -eqTyConKey = mkPreludeTyConUnique 38 -heqTyConKey = mkPreludeTyConUnique 39 -arrayArrayPrimTyConKey = mkPreludeTyConUnique 40 -mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 41 - -statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, - mutVarPrimTyConKey, ioTyConKey, - wordPrimTyConKey, wordTyConKey, word8TyConKey, word16TyConKey, - word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey, - liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, - typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, - funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, - eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey, - compactPrimTyConKey :: Unique -statePrimTyConKey = mkPreludeTyConUnique 50 -stableNamePrimTyConKey = mkPreludeTyConUnique 51 -stableNameTyConKey = mkPreludeTyConUnique 52 -eqPrimTyConKey = mkPreludeTyConUnique 53 -eqReprPrimTyConKey = mkPreludeTyConUnique 54 -eqPhantPrimTyConKey = mkPreludeTyConUnique 55 -mutVarPrimTyConKey = mkPreludeTyConUnique 56 -ioTyConKey = mkPreludeTyConUnique 57 -voidPrimTyConKey = mkPreludeTyConUnique 58 -wordPrimTyConKey = mkPreludeTyConUnique 59 -wordTyConKey = mkPreludeTyConUnique 60 -word8TyConKey = mkPreludeTyConUnique 61 -word16TyConKey = mkPreludeTyConUnique 62 -word32PrimTyConKey = mkPreludeTyConUnique 63 -word32TyConKey = mkPreludeTyConUnique 64 -word64PrimTyConKey = mkPreludeTyConUnique 65 -word64TyConKey = mkPreludeTyConUnique 66 -liftedConKey = mkPreludeTyConUnique 67 -unliftedConKey = mkPreludeTyConUnique 68 -anyBoxConKey = mkPreludeTyConUnique 69 -kindConKey = mkPreludeTyConUnique 70 -boxityConKey = mkPreludeTyConUnique 71 -typeConKey = mkPreludeTyConUnique 72 -threadIdPrimTyConKey = mkPreludeTyConUnique 73 -bcoPrimTyConKey = mkPreludeTyConUnique 74 -ptrTyConKey = mkPreludeTyConUnique 75 -funPtrTyConKey = mkPreludeTyConUnique 76 -tVarPrimTyConKey = mkPreludeTyConUnique 77 -compactPrimTyConKey = mkPreludeTyConUnique 78 - --- Parallel array type constructor -parrTyConKey :: Unique -parrTyConKey = mkPreludeTyConUnique 82 - --- dotnet interop -objectTyConKey :: Unique -objectTyConKey = mkPreludeTyConUnique 83 - -eitherTyConKey :: Unique -eitherTyConKey = mkPreludeTyConUnique 84 - --- Kind constructors -liftedTypeKindTyConKey, tYPETyConKey, - constraintKindTyConKey, - starKindTyConKey, unicodeStarKindTyConKey, runtimeRepTyConKey, - vecCountTyConKey, vecElemTyConKey :: Unique -liftedTypeKindTyConKey = mkPreludeTyConUnique 87 -tYPETyConKey = mkPreludeTyConUnique 88 -constraintKindTyConKey = mkPreludeTyConUnique 92 -starKindTyConKey = mkPreludeTyConUnique 93 -unicodeStarKindTyConKey = mkPreludeTyConUnique 94 -runtimeRepTyConKey = mkPreludeTyConUnique 95 -vecCountTyConKey = mkPreludeTyConUnique 96 -vecElemTyConKey = mkPreludeTyConUnique 97 - -pluginTyConKey, frontendPluginTyConKey :: Unique -pluginTyConKey = mkPreludeTyConUnique 102 -frontendPluginTyConKey = mkPreludeTyConUnique 103 - -unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey, - opaqueTyConKey :: Unique -unknownTyConKey = mkPreludeTyConUnique 129 -unknown1TyConKey = mkPreludeTyConUnique 130 -unknown2TyConKey = mkPreludeTyConUnique 131 -unknown3TyConKey = mkPreludeTyConUnique 132 -opaqueTyConKey = mkPreludeTyConUnique 133 - --- Generics (Unique keys) -v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, - k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, - compTyConKey, rTyConKey, dTyConKey, - cTyConKey, sTyConKey, rec0TyConKey, - d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, - repTyConKey, rep1TyConKey, uRecTyConKey, - uAddrTyConKey, uCharTyConKey, uDoubleTyConKey, - uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique - -v1TyConKey = mkPreludeTyConUnique 135 -u1TyConKey = mkPreludeTyConUnique 136 -par1TyConKey = mkPreludeTyConUnique 137 -rec1TyConKey = mkPreludeTyConUnique 138 -k1TyConKey = mkPreludeTyConUnique 139 -m1TyConKey = mkPreludeTyConUnique 140 - -sumTyConKey = mkPreludeTyConUnique 141 -prodTyConKey = mkPreludeTyConUnique 142 -compTyConKey = mkPreludeTyConUnique 143 - -rTyConKey = mkPreludeTyConUnique 144 -dTyConKey = mkPreludeTyConUnique 146 -cTyConKey = mkPreludeTyConUnique 147 -sTyConKey = mkPreludeTyConUnique 148 - -rec0TyConKey = mkPreludeTyConUnique 149 -d1TyConKey = mkPreludeTyConUnique 151 -c1TyConKey = mkPreludeTyConUnique 152 -s1TyConKey = mkPreludeTyConUnique 153 -noSelTyConKey = mkPreludeTyConUnique 154 - -repTyConKey = mkPreludeTyConUnique 155 -rep1TyConKey = mkPreludeTyConUnique 156 - -uRecTyConKey = mkPreludeTyConUnique 157 -uAddrTyConKey = mkPreludeTyConUnique 158 -uCharTyConKey = mkPreludeTyConUnique 159 -uDoubleTyConKey = mkPreludeTyConUnique 160 -uFloatTyConKey = mkPreludeTyConUnique 161 -uIntTyConKey = mkPreludeTyConUnique 162 -uWordTyConKey = mkPreludeTyConUnique 163 - --- Type-level naturals -typeNatKindConNameKey, typeSymbolKindConNameKey, - typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, - typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey - , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey - :: Unique -typeNatKindConNameKey = mkPreludeTyConUnique 164 -typeSymbolKindConNameKey = mkPreludeTyConUnique 165 -typeNatAddTyFamNameKey = mkPreludeTyConUnique 166 -typeNatMulTyFamNameKey = mkPreludeTyConUnique 167 -typeNatExpTyFamNameKey = mkPreludeTyConUnique 168 -typeNatLeqTyFamNameKey = mkPreludeTyConUnique 169 -typeNatSubTyFamNameKey = mkPreludeTyConUnique 170 -typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171 -typeNatCmpTyFamNameKey = mkPreludeTyConUnique 172 - --- Custom user type-errors -errorMessageTypeErrorFamKey :: Unique -errorMessageTypeErrorFamKey = mkPreludeTyConUnique 173 - - - -ntTyConKey:: Unique -ntTyConKey = mkPreludeTyConUnique 174 -coercibleTyConKey :: Unique -coercibleTyConKey = mkPreludeTyConUnique 175 - -proxyPrimTyConKey :: Unique -proxyPrimTyConKey = mkPreludeTyConUnique 176 - -specTyConKey :: Unique -specTyConKey = mkPreludeTyConUnique 177 - -anyTyConKey :: Unique -anyTyConKey = mkPreludeTyConUnique 178 - -smallArrayPrimTyConKey = mkPreludeTyConUnique 179 -smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 180 - -staticPtrTyConKey :: Unique -staticPtrTyConKey = mkPreludeTyConUnique 181 - -staticPtrInfoTyConKey :: Unique -staticPtrInfoTyConKey = mkPreludeTyConUnique 182 - -callStackTyConKey :: Unique -callStackTyConKey = mkPreludeTyConUnique 183 - --- Typeables -typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique -typeRepTyConKey = mkPreludeTyConUnique 184 -someTypeRepTyConKey = mkPreludeTyConUnique 185 -someTypeRepDataConKey = mkPreludeTyConUnique 186 - - -typeSymbolAppendFamNameKey :: Unique -typeSymbolAppendFamNameKey = mkPreludeTyConUnique 187 - ----------------- Template Haskell ------------------- --- THNames.hs: USES TyConUniques 200-299 ------------------------------------------------------ - ------------------------ SIMD ------------------------ --- USES TyConUniques 300-399 ------------------------------------------------------ - -#include "primop-vector-uniques.hs-incl" - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} -* * -************************************************************************ --} - -charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, - floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey, - ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, - word8DataConKey, ioDataConKey, integerDataConKey, heqDataConKey, - coercibleDataConKey, nothingDataConKey, justDataConKey :: Unique - -charDataConKey = mkPreludeDataConUnique 1 -consDataConKey = mkPreludeDataConUnique 2 -doubleDataConKey = mkPreludeDataConUnique 3 -falseDataConKey = mkPreludeDataConUnique 4 -floatDataConKey = mkPreludeDataConUnique 5 -intDataConKey = mkPreludeDataConUnique 6 -integerSDataConKey = mkPreludeDataConUnique 7 -nothingDataConKey = mkPreludeDataConUnique 8 -justDataConKey = mkPreludeDataConUnique 9 -nilDataConKey = mkPreludeDataConUnique 11 -ratioDataConKey = mkPreludeDataConUnique 12 -word8DataConKey = mkPreludeDataConUnique 13 -stableNameDataConKey = mkPreludeDataConUnique 14 -trueDataConKey = mkPreludeDataConUnique 15 -wordDataConKey = mkPreludeDataConUnique 16 -ioDataConKey = mkPreludeDataConUnique 17 -integerDataConKey = mkPreludeDataConUnique 18 -heqDataConKey = mkPreludeDataConUnique 19 - --- Generic data constructors -crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique -crossDataConKey = mkPreludeDataConUnique 20 -inlDataConKey = mkPreludeDataConUnique 21 -inrDataConKey = mkPreludeDataConUnique 22 -genUnitDataConKey = mkPreludeDataConUnique 23 - --- Data constructor for parallel arrays -parrDataConKey :: Unique -parrDataConKey = mkPreludeDataConUnique 24 - -leftDataConKey, rightDataConKey :: Unique -leftDataConKey = mkPreludeDataConUnique 25 -rightDataConKey = mkPreludeDataConUnique 26 - -ltDataConKey, eqDataConKey, gtDataConKey :: Unique -ltDataConKey = mkPreludeDataConUnique 27 -eqDataConKey = mkPreludeDataConUnique 28 -gtDataConKey = mkPreludeDataConUnique 29 - -coercibleDataConKey = mkPreludeDataConUnique 32 - -staticPtrDataConKey :: Unique -staticPtrDataConKey = mkPreludeDataConUnique 33 - -staticPtrInfoDataConKey :: Unique -staticPtrInfoDataConKey = mkPreludeDataConUnique 34 - -fingerprintDataConKey :: Unique -fingerprintDataConKey = mkPreludeDataConUnique 35 - -srcLocDataConKey :: Unique -srcLocDataConKey = mkPreludeDataConUnique 37 - -trTyConTyConKey, trTyConDataConKey, - trModuleTyConKey, trModuleDataConKey, - trNameTyConKey, trNameSDataConKey, trNameDDataConKey, - trGhcPrimModuleKey, kindRepTyConKey, - typeLitSortTyConKey :: Unique -trTyConTyConKey = mkPreludeDataConUnique 40 -trTyConDataConKey = mkPreludeDataConUnique 41 -trModuleTyConKey = mkPreludeDataConUnique 42 -trModuleDataConKey = mkPreludeDataConUnique 43 -trNameTyConKey = mkPreludeDataConUnique 44 -trNameSDataConKey = mkPreludeDataConUnique 45 -trNameDDataConKey = mkPreludeDataConUnique 46 -trGhcPrimModuleKey = mkPreludeDataConUnique 47 -kindRepTyConKey = mkPreludeDataConUnique 48 -typeLitSortTyConKey = mkPreludeDataConUnique 49 - -typeErrorTextDataConKey, - typeErrorAppendDataConKey, - typeErrorVAppendDataConKey, - typeErrorShowTypeDataConKey - :: Unique -typeErrorTextDataConKey = mkPreludeDataConUnique 50 -typeErrorAppendDataConKey = mkPreludeDataConUnique 51 -typeErrorVAppendDataConKey = mkPreludeDataConUnique 52 -typeErrorShowTypeDataConKey = mkPreludeDataConUnique 53 - -prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey, - rightAssociativeDataConKey, notAssociativeDataConKey, - sourceUnpackDataConKey, sourceNoUnpackDataConKey, - noSourceUnpackednessDataConKey, sourceLazyDataConKey, - sourceStrictDataConKey, noSourceStrictnessDataConKey, - decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey, - metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique -prefixIDataConKey = mkPreludeDataConUnique 54 -infixIDataConKey = mkPreludeDataConUnique 55 -leftAssociativeDataConKey = mkPreludeDataConUnique 56 -rightAssociativeDataConKey = mkPreludeDataConUnique 57 -notAssociativeDataConKey = mkPreludeDataConUnique 58 -sourceUnpackDataConKey = mkPreludeDataConUnique 59 -sourceNoUnpackDataConKey = mkPreludeDataConUnique 60 -noSourceUnpackednessDataConKey = mkPreludeDataConUnique 61 -sourceLazyDataConKey = mkPreludeDataConUnique 62 -sourceStrictDataConKey = mkPreludeDataConUnique 63 -noSourceStrictnessDataConKey = mkPreludeDataConUnique 64 -decidedLazyDataConKey = mkPreludeDataConUnique 65 -decidedStrictDataConKey = mkPreludeDataConUnique 66 -decidedUnpackDataConKey = mkPreludeDataConUnique 67 -metaDataDataConKey = mkPreludeDataConUnique 68 -metaConsDataConKey = mkPreludeDataConUnique 69 -metaSelDataConKey = mkPreludeDataConUnique 70 - -vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey :: Unique -vecRepDataConKey = mkPreludeDataConUnique 71 -tupleRepDataConKey = mkPreludeDataConUnique 72 -sumRepDataConKey = mkPreludeDataConUnique 73 - --- See Note [Wiring in RuntimeRep] in TysWiredIn -runtimeRepSimpleDataConKeys :: [Unique] -liftedRepDataConKey :: Unique -runtimeRepSimpleDataConKeys@( - liftedRepDataConKey : _) - = map mkPreludeDataConUnique [74..82] - --- See Note [Wiring in RuntimeRep] in TysWiredIn --- VecCount -vecCountDataConKeys :: [Unique] -vecCountDataConKeys = map mkPreludeDataConUnique [83..88] - --- See Note [Wiring in RuntimeRep] in TysWiredIn --- VecElem -vecElemDataConKeys :: [Unique] -vecElemDataConKeys = map mkPreludeDataConUnique [89..98] - --- Typeable things -kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, - kindRepFunDataConKey, kindRepTYPEDataConKey, - kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey - :: Unique -kindRepTyConAppDataConKey = mkPreludeDataConUnique 100 -kindRepVarDataConKey = mkPreludeDataConUnique 101 -kindRepAppDataConKey = mkPreludeDataConUnique 102 -kindRepFunDataConKey = mkPreludeDataConUnique 103 -kindRepTYPEDataConKey = mkPreludeDataConUnique 104 -kindRepTypeLitSDataConKey = mkPreludeDataConUnique 105 -kindRepTypeLitDDataConKey = mkPreludeDataConUnique 106 - -typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique -typeLitSymbolDataConKey = mkPreludeDataConUnique 107 -typeLitNatDataConKey = mkPreludeDataConUnique 108 - - ----------------- Template Haskell ------------------- --- THNames.hs: USES DataUniques 200-250 ------------------------------------------------------ - - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} -* * -************************************************************************ --} - -wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, - buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey, - seqIdKey, irrefutPatErrorIdKey, eqStringIdKey, - noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, - runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey, - realWorldPrimIdKey, recConErrorIdKey, - unpackCStringUtf8IdKey, unpackCStringAppendIdKey, - unpackCStringFoldrIdKey, unpackCStringIdKey, - typeErrorIdKey, divIntIdKey, modIntIdKey :: Unique - -wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] -absentErrorIdKey = mkPreludeMiscIdUnique 1 -augmentIdKey = mkPreludeMiscIdUnique 2 -appendIdKey = mkPreludeMiscIdUnique 3 -buildIdKey = mkPreludeMiscIdUnique 4 -errorIdKey = mkPreludeMiscIdUnique 5 -foldrIdKey = mkPreludeMiscIdUnique 6 -recSelErrorIdKey = mkPreludeMiscIdUnique 7 -seqIdKey = mkPreludeMiscIdUnique 8 -irrefutPatErrorIdKey = mkPreludeMiscIdUnique 9 -eqStringIdKey = mkPreludeMiscIdUnique 10 -noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 -nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 -runtimeErrorIdKey = mkPreludeMiscIdUnique 13 -patErrorIdKey = mkPreludeMiscIdUnique 14 -realWorldPrimIdKey = mkPreludeMiscIdUnique 15 -recConErrorIdKey = mkPreludeMiscIdUnique 16 -unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 17 -unpackCStringAppendIdKey = mkPreludeMiscIdUnique 18 -unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19 -unpackCStringIdKey = mkPreludeMiscIdUnique 20 -voidPrimIdKey = mkPreludeMiscIdUnique 21 -typeErrorIdKey = mkPreludeMiscIdUnique 22 -divIntIdKey = mkPreludeMiscIdUnique 23 -modIntIdKey = mkPreludeMiscIdUnique 24 - -unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, - returnIOIdKey, newStablePtrIdKey, - printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey, - fstIdKey, sndIdKey, otherwiseIdKey, assertIdKey :: Unique -unsafeCoerceIdKey = mkPreludeMiscIdUnique 30 -concatIdKey = mkPreludeMiscIdUnique 31 -filterIdKey = mkPreludeMiscIdUnique 32 -zipIdKey = mkPreludeMiscIdUnique 33 -bindIOIdKey = mkPreludeMiscIdUnique 34 -returnIOIdKey = mkPreludeMiscIdUnique 35 -newStablePtrIdKey = mkPreludeMiscIdUnique 36 -printIdKey = mkPreludeMiscIdUnique 37 -failIOIdKey = mkPreludeMiscIdUnique 38 -nullAddrIdKey = mkPreludeMiscIdUnique 39 -voidArgIdKey = mkPreludeMiscIdUnique 40 -fstIdKey = mkPreludeMiscIdUnique 41 -sndIdKey = mkPreludeMiscIdUnique 42 -otherwiseIdKey = mkPreludeMiscIdUnique 43 -assertIdKey = mkPreludeMiscIdUnique 44 - -mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey, - integerToWordIdKey, integerToIntIdKey, - integerToWord64IdKey, integerToInt64IdKey, - word64ToIntegerIdKey, int64ToIntegerIdKey, - plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, - negateIntegerIdKey, - eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey, - leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey, - compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey, - quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey, - floatFromIntegerIdKey, doubleFromIntegerIdKey, - encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey, - decodeDoubleIntegerIdKey, - gcdIntegerIdKey, lcmIntegerIdKey, - andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey, - shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique -mkIntegerIdKey = mkPreludeMiscIdUnique 60 -smallIntegerIdKey = mkPreludeMiscIdUnique 61 -integerToWordIdKey = mkPreludeMiscIdUnique 62 -integerToIntIdKey = mkPreludeMiscIdUnique 63 -integerToWord64IdKey = mkPreludeMiscIdUnique 64 -integerToInt64IdKey = mkPreludeMiscIdUnique 65 -plusIntegerIdKey = mkPreludeMiscIdUnique 66 -timesIntegerIdKey = mkPreludeMiscIdUnique 67 -minusIntegerIdKey = mkPreludeMiscIdUnique 68 -negateIntegerIdKey = mkPreludeMiscIdUnique 69 -eqIntegerPrimIdKey = mkPreludeMiscIdUnique 70 -neqIntegerPrimIdKey = mkPreludeMiscIdUnique 71 -absIntegerIdKey = mkPreludeMiscIdUnique 72 -signumIntegerIdKey = mkPreludeMiscIdUnique 73 -leIntegerPrimIdKey = mkPreludeMiscIdUnique 74 -gtIntegerPrimIdKey = mkPreludeMiscIdUnique 75 -ltIntegerPrimIdKey = mkPreludeMiscIdUnique 76 -geIntegerPrimIdKey = mkPreludeMiscIdUnique 77 -compareIntegerIdKey = mkPreludeMiscIdUnique 78 -quotIntegerIdKey = mkPreludeMiscIdUnique 79 -remIntegerIdKey = mkPreludeMiscIdUnique 80 -divIntegerIdKey = mkPreludeMiscIdUnique 81 -modIntegerIdKey = mkPreludeMiscIdUnique 82 -divModIntegerIdKey = mkPreludeMiscIdUnique 83 -quotRemIntegerIdKey = mkPreludeMiscIdUnique 84 -floatFromIntegerIdKey = mkPreludeMiscIdUnique 85 -doubleFromIntegerIdKey = mkPreludeMiscIdUnique 86 -encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 87 -encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 88 -gcdIntegerIdKey = mkPreludeMiscIdUnique 89 -lcmIntegerIdKey = mkPreludeMiscIdUnique 90 -andIntegerIdKey = mkPreludeMiscIdUnique 91 -orIntegerIdKey = mkPreludeMiscIdUnique 92 -xorIntegerIdKey = mkPreludeMiscIdUnique 93 -complementIntegerIdKey = mkPreludeMiscIdUnique 94 -shiftLIntegerIdKey = mkPreludeMiscIdUnique 95 -shiftRIntegerIdKey = mkPreludeMiscIdUnique 96 -wordToIntegerIdKey = mkPreludeMiscIdUnique 97 -word64ToIntegerIdKey = mkPreludeMiscIdUnique 98 -int64ToIntegerIdKey = mkPreludeMiscIdUnique 99 -decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100 - -rootMainKey, runMainKey :: Unique -rootMainKey = mkPreludeMiscIdUnique 101 -runMainKey = mkPreludeMiscIdUnique 102 - -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique -thenIOIdKey = mkPreludeMiscIdUnique 103 -lazyIdKey = mkPreludeMiscIdUnique 104 -assertErrorIdKey = mkPreludeMiscIdUnique 105 -oneShotKey = mkPreludeMiscIdUnique 106 -runRWKey = mkPreludeMiscIdUnique 107 - -breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey, - breakpointJumpIdKey, breakpointCondJumpIdKey, - breakpointAutoJumpIdKey :: Unique -breakpointIdKey = mkPreludeMiscIdUnique 110 -breakpointCondIdKey = mkPreludeMiscIdUnique 111 -breakpointAutoIdKey = mkPreludeMiscIdUnique 112 -breakpointJumpIdKey = mkPreludeMiscIdUnique 113 -breakpointCondJumpIdKey = mkPreludeMiscIdUnique 114 -breakpointAutoJumpIdKey = mkPreludeMiscIdUnique 115 - -inlineIdKey, noinlineIdKey :: Unique -inlineIdKey = mkPreludeMiscIdUnique 120 --- see below - -mapIdKey, groupWithIdKey, dollarIdKey :: Unique -mapIdKey = mkPreludeMiscIdUnique 121 -groupWithIdKey = mkPreludeMiscIdUnique 122 -dollarIdKey = mkPreludeMiscIdUnique 123 - -coercionTokenIdKey :: Unique -coercionTokenIdKey = mkPreludeMiscIdUnique 124 - -noinlineIdKey = mkPreludeMiscIdUnique 125 - -rationalToFloatIdKey, rationalToDoubleIdKey :: Unique -rationalToFloatIdKey = mkPreludeMiscIdUnique 130 -rationalToDoubleIdKey = mkPreludeMiscIdUnique 131 - --- dotnet interop -unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey, - unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique -unmarshalObjectIdKey = mkPreludeMiscIdUnique 150 -marshalObjectIdKey = mkPreludeMiscIdUnique 151 -marshalStringIdKey = mkPreludeMiscIdUnique 152 -unmarshalStringIdKey = mkPreludeMiscIdUnique 153 -checkDotnetResNameIdKey = mkPreludeMiscIdUnique 154 - -undefinedKey :: Unique -undefinedKey = mkPreludeMiscIdUnique 155 - -magicDictKey :: Unique -magicDictKey = mkPreludeMiscIdUnique 156 - -coerceKey :: Unique -coerceKey = mkPreludeMiscIdUnique 157 - -{- -Certain class operations from Prelude classes. They get their own -uniques so we can look them up easily when we want to conjure them up -during type checking. --} - --- Just a placeholder for unbound variables produced by the renamer: -unboundKey :: Unique -unboundKey = mkPreludeMiscIdUnique 158 - -fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, - enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, - enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, - failMClassOpKey_preMFP, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, - fmapClassOpKey - :: Unique -fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 -minusClassOpKey = mkPreludeMiscIdUnique 161 -fromRationalClassOpKey = mkPreludeMiscIdUnique 162 -enumFromClassOpKey = mkPreludeMiscIdUnique 163 -enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 -enumFromToClassOpKey = mkPreludeMiscIdUnique 165 -enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 -eqClassOpKey = mkPreludeMiscIdUnique 167 -geClassOpKey = mkPreludeMiscIdUnique 168 -negateClassOpKey = mkPreludeMiscIdUnique 169 -failMClassOpKey_preMFP = mkPreludeMiscIdUnique 170 -bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) -thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) -fmapClassOpKey = mkPreludeMiscIdUnique 173 -returnMClassOpKey = mkPreludeMiscIdUnique 174 - --- Recursive do notation -mfixIdKey :: Unique -mfixIdKey = mkPreludeMiscIdUnique 175 - --- MonadFail operations -failMClassOpKey :: Unique -failMClassOpKey = mkPreludeMiscIdUnique 176 - --- Arrow notation -arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, - loopAIdKey :: Unique -arrAIdKey = mkPreludeMiscIdUnique 180 -composeAIdKey = mkPreludeMiscIdUnique 181 -- >>> -firstAIdKey = mkPreludeMiscIdUnique 182 -appAIdKey = mkPreludeMiscIdUnique 183 -choiceAIdKey = mkPreludeMiscIdUnique 184 -- ||| -loopAIdKey = mkPreludeMiscIdUnique 185 - -fromStringClassOpKey :: Unique -fromStringClassOpKey = mkPreludeMiscIdUnique 186 - --- Annotation type checking -toAnnotationWrapperIdKey :: Unique -toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 187 - --- Conversion functions -fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique -fromIntegralIdKey = mkPreludeMiscIdUnique 190 -realToFracIdKey = mkPreludeMiscIdUnique 191 -toIntegerClassOpKey = mkPreludeMiscIdUnique 192 -toRationalClassOpKey = mkPreludeMiscIdUnique 193 - --- Monad comprehensions -guardMIdKey, liftMIdKey, mzipIdKey :: Unique -guardMIdKey = mkPreludeMiscIdUnique 194 -liftMIdKey = mkPreludeMiscIdUnique 195 -mzipIdKey = mkPreludeMiscIdUnique 196 - --- GHCi -ghciStepIoMClassOpKey :: Unique -ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 - --- Overloaded lists -isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique -isListClassKey = mkPreludeMiscIdUnique 198 -fromListClassOpKey = mkPreludeMiscIdUnique 199 -fromListNClassOpKey = mkPreludeMiscIdUnique 500 -toListClassOpKey = mkPreludeMiscIdUnique 501 - -proxyHashKey :: Unique -proxyHashKey = mkPreludeMiscIdUnique 502 - ----------------- Template Haskell ------------------- --- THNames.hs: USES IdUniques 200-499 ------------------------------------------------------ - --- Used to make `Typeable` dictionaries -mkTyConKey - , mkTrConKey - , mkTrAppKey - , mkTrFunKey - , typeNatTypeRepKey - , typeSymbolTypeRepKey - , typeRepIdKey - :: Unique -mkTyConKey = mkPreludeMiscIdUnique 503 -mkTrConKey = mkPreludeMiscIdUnique 504 -mkTrAppKey = mkPreludeMiscIdUnique 505 -typeNatTypeRepKey = mkPreludeMiscIdUnique 506 -typeSymbolTypeRepKey = mkPreludeMiscIdUnique 507 -typeRepIdKey = mkPreludeMiscIdUnique 508 -mkTrFunKey = mkPreludeMiscIdUnique 509 - --- Representations for primitive types -trTYPEKey - ,trTYPE'PtrRepLiftedKey - , trRuntimeRepKey - , tr'PtrRepLiftedKey - :: Unique -trTYPEKey = mkPreludeMiscIdUnique 510 -trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 511 -trRuntimeRepKey = mkPreludeMiscIdUnique 512 -tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 513 - --- KindReps for common cases -starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique -starKindRepKey = mkPreludeMiscIdUnique 520 -starArrStarKindRepKey = mkPreludeMiscIdUnique 521 -starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522 - --- Dynamic -toDynIdKey :: Unique -toDynIdKey = mkPreludeMiscIdUnique 550 - -bitIntegerIdKey :: Unique -bitIntegerIdKey = mkPreludeMiscIdUnique 551 - -heqSCSelIdKey, coercibleSCSelIdKey :: Unique -heqSCSelIdKey = mkPreludeMiscIdUnique 552 -coercibleSCSelIdKey = mkPreludeMiscIdUnique 553 - -sappendClassOpKey :: Unique -sappendClassOpKey = mkPreludeMiscIdUnique 554 - -memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique -memptyClassOpKey = mkPreludeMiscIdUnique 555 -mappendClassOpKey = mkPreludeMiscIdUnique 556 -mconcatClassOpKey = mkPreludeMiscIdUnique 557 - -emptyCallStackKey, pushCallStackKey :: Unique -emptyCallStackKey = mkPreludeMiscIdUnique 558 -pushCallStackKey = mkPreludeMiscIdUnique 559 - -fromStaticPtrClassOpKey :: Unique -fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560 - -makeStaticKey :: Unique -makeStaticKey = mkPreludeMiscIdUnique 561 - --- Natural -naturalFromIntegerIdKey :: Unique -naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562 - -{- -************************************************************************ -* * -\subsection[Class-std-groups]{Standard groups of Prelude classes} -* * -************************************************************************ - -NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ -even though every numeric class has these two as a superclass, -because the list of ambiguous dictionaries hasn't been simplified. --} - -numericClassKeys :: [Unique] -numericClassKeys = - [ numClassKey - , realClassKey - , integralClassKey - ] - ++ fractionalClassKeys - -fractionalClassKeys :: [Unique] -fractionalClassKeys = - [ fractionalClassKey - , floatingClassKey - , realFracClassKey - , realFloatClassKey - ] - --- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), --- and are: "classes defined in the Prelude or a standard library" -standardClassKeys :: [Unique] -standardClassKeys = derivableClassKeys ++ numericClassKeys - ++ [randomClassKey, randomGenClassKey, - functorClassKey, - monadClassKey, monadPlusClassKey, monadFailClassKey, - semigroupClassKey, monoidClassKey, - isStringClassKey, - applicativeClassKey, foldableClassKey, - traversableClassKey, alternativeClassKey - ] - -{- -@derivableClassKeys@ is also used in checking \tr{deriving} constructs -(@TcDeriv@). --} - -derivableClassKeys :: [Unique] -derivableClassKeys - = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, - boundedClassKey, showClassKey, readClassKey ] - - --- These are the "interactive classes" that are consulted when doing --- defaulting. Does not include Num or IsString, which have special --- handling. -interactiveClassNames :: [Name] -interactiveClassNames - = [ showClassName, eqClassName, ordClassName, foldableClassName - , traversableClassName ] - -interactiveClassKeys :: [Unique] -interactiveClassKeys = map getUnique interactiveClassNames - -{- -************************************************************************ -* * - Semi-builtin names -* * -************************************************************************ - -The following names should be considered by GHCi to be in scope always. - --} - -pretendNameIsInScope :: Name -> Bool -pretendNameIsInScope n - = any (n `hasKey`) - [ starKindTyConKey, liftedTypeKindTyConKey, tYPETyConKey - , runtimeRepTyConKey, liftedRepDataConKey ] diff --git a/prelude/PrelNames.hs-boot b/prelude/PrelNames.hs-boot deleted file mode 100644 --- a/prelude/PrelNames.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -module PrelNames where - -import Module -import Unique - -mAIN :: Module -starKindTyConKey :: Unique -unicodeStarKindTyConKey :: Unique diff --git a/prelude/PrelRules.hs b/prelude/PrelRules.hs deleted file mode 100644 --- a/prelude/PrelRules.hs +++ /dev/null @@ -1,1477 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[ConFold]{Constant Folder} - -Conceptually, constant folding should be parameterized with the kind -of target machine to get identical behaviour during compilation time -and runtime. We cheat a little bit here... - -ToDo: - check boundaries before folding, e.g. we can fold the Float addition - (i1 + i2) only if it results in a valid Float. --} - -{-# LANGUAGE CPP, RankNTypes #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} - -module PrelRules - ( primOpRules - , builtinRules - , caseRules - ) -where - -#include "HsVersions.h" -#include "MachDeps.h" - -import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId ) - -import CoreSyn -import MkCore -import Id -import Literal -import CoreOpt ( exprIsLiteral_maybe ) -import PrimOp ( PrimOp(..), tagToEnumKey ) -import TysWiredIn -import TysPrim -import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe ) -import DataCon ( dataConTag, dataConTyCon, dataConWorkId ) -import CoreUtils ( cheapEqExpr, exprIsHNF ) -import CoreUnfold ( exprIsConApp_maybe ) -import Type -import OccName ( occNameFS ) -import PrelNames -import Maybes ( orElse ) -import Name ( Name, nameOccName ) -import Outputable -import FastString -import BasicTypes -import DynFlags -import Platform -import Util -import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) - -import Control.Applicative ( Alternative(..) ) - -import Control.Monad -#if __GLASGOW_HASKELL__ > 710 -import qualified Control.Monad.Fail as MonadFail -#endif -import Data.Bits as Bits -import qualified Data.ByteString as BS -import Data.Int -import Data.Ratio -import Data.Word - -{- -Note [Constant folding] -~~~~~~~~~~~~~~~~~~~~~~~ -primOpRules generates a rewrite rule for each primop -These rules do what is often called "constant folding" -E.g. the rules for +# might say - 4 +# 5 = 9 -Well, of course you'd need a lot of rules if you did it -like that, so we use a BuiltinRule instead, so that we -can match in any two literal values. So the rule is really -more like - (Lit x) +# (Lit y) = Lit (x+#y) -where the (+#) on the rhs is done at compile time - -That is why these rules are built in here. --} - -primOpRules :: Name -> PrimOp -> Maybe CoreRule - -- ToDo: something for integer-shift ops? - -- NotOp -primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ] -primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ] - --- Int operations -primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) - , identityDynFlags zeroi ] -primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) - , rightIdentityDynFlags zeroi - , equalArgs >> retLit zeroi ] -primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) - , zeroElem zeroi - , identityDynFlags onei ] -primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) - , leftZero zeroi - , rightIdentityDynFlags onei - , equalArgs >> retLit onei ] -primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) - , leftZero zeroi - , do l <- getLiteral 1 - dflags <- getDynFlags - guard (l == onei dflags) - retLit zeroi - , equalArgs >> retLit zeroi - , equalArgs >> retLit zeroi ] -primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) - , idempotent - , zeroElem zeroi ] -primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) - , idempotent - , identityDynFlags zeroi ] -primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) - , identityDynFlags zeroi - , equalArgs >> retLit zeroi ] -primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp - , inversePrimOp NotIOp ] -primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp IntNegOp ] -primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL) - , rightIdentityDynFlags zeroi ] -primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR) - , rightIdentityDynFlags zeroi ] -primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical) - , rightIdentityDynFlags zeroi ] - --- Word operations -primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) - , identityDynFlags zerow ] -primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) - , rightIdentityDynFlags zerow - , equalArgs >> retLit zerow ] -primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) - , identityDynFlags onew ] -primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) - , rightIdentityDynFlags onew ] -primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) - , leftZero zerow - , do l <- getLiteral 1 - dflags <- getDynFlags - guard (l == onew dflags) - retLit zerow - , equalArgs >> retLit zerow ] -primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) - , idempotent - , zeroElem zerow ] -primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) - , idempotent - , identityDynFlags zerow ] -primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) - , identityDynFlags zerow - , equalArgs >> retLit zerow ] -primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp - , inversePrimOp NotOp ] -primOpRules nm SllOp = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ] -primOpRules nm SrlOp = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ] - --- coercions -primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit - , inversePrimOp Int2WordOp ] -primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit - , inversePrimOp Word2IntOp ] -primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit - , subsumedByPrimOp Narrow8IntOp - , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp - , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ] -primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit - , subsumedByPrimOp Narrow8IntOp - , subsumedByPrimOp Narrow16IntOp - , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ] -primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit - , subsumedByPrimOp Narrow8IntOp - , subsumedByPrimOp Narrow16IntOp - , subsumedByPrimOp Narrow32IntOp - , removeOp32 ] -primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit - , subsumedByPrimOp Narrow8WordOp - , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp - , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ] -primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit - , subsumedByPrimOp Narrow8WordOp - , subsumedByPrimOp Narrow16WordOp - , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ] -primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit - , subsumedByPrimOp Narrow8WordOp - , subsumedByPrimOp Narrow16WordOp - , subsumedByPrimOp Narrow32WordOp - , removeOp32 ] -primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit - , inversePrimOp ChrOp ] -primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs - guard (litFitsInChar lit) - liftLit int2CharLit - , inversePrimOp OrdOp ] -primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ] -primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ] -primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ] -primOpRules nm Int2DoubleOp = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ] --- SUP: Not sure what the standard says about precision in the following 2 cases -primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ] -primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ] - --- Float -primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) - , identity zerof ] -primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) - , rightIdentity zerof ] -primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) - , identity onef - , strengthReduction twof FloatAddOp ] - -- zeroElem zerof doesn't hold because of NaN -primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) - , rightIdentity onef ] -primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp FloatNegOp ] - --- Double -primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) - , identity zerod ] -primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) - , rightIdentity zerod ] -primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) - , identity oned - , strengthReduction twod DoubleAddOp ] - -- zeroElem zerod doesn't hold because of NaN -primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) - , rightIdentity oned ] -primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp DoubleNegOp ] - --- Relational operators - -primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ] -primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm CharNeOp = mkRelOpRule nm (/=) [ litEq False ] - -primOpRules nm IntGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm IntGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm IntLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm IntLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] - -primOpRules nm CharGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] - -primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) -primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) -primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) -primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) -primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) -primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) - -primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) -primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) -primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) -primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) -primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) -primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) - -primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm WordLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm WordLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] -primOpRules nm WordEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm WordNeOp = mkRelOpRule nm (/=) [ litEq False ] - -primOpRules nm AddrAddOp = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ] - -primOpRules nm SeqOp = mkPrimOpRule nm 4 [ seqRule ] -primOpRules nm SparkOp = mkPrimOpRule nm 4 [ sparkRule ] - -primOpRules _ _ = Nothing - -{- -************************************************************************ -* * -\subsection{Doing the business} -* * -************************************************************************ --} - --- useful shorthands -mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule -mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) - -mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) - -> [RuleM CoreExpr] -> Maybe CoreRule -mkRelOpRule nm cmp extra - = mkPrimOpRule nm 2 $ - binaryCmpLit cmp : equal_rule : extra - where - -- x `cmp` x does not depend on x, so - -- compute it for the arbitrary value 'True' - -- and use that result - equal_rule = do { equalArgs - ; dflags <- getDynFlags - ; return (if cmp True True - then trueValInt dflags - else falseValInt dflags) } - -{- Note [Rules for floating-point comparisons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need different rules for floating-point values because for floats -it is not true that x = x (for NaNs); so we do not want the equal_rule -rule that mkRelOpRule uses. - -Note also that, in the case of equality/inequality, we do /not/ -want to switch to a case-expression. For example, we do not want -to convert - case (eqFloat# x 3.8#) of - True -> this - False -> that -to - case x of - 3.8#::Float# -> this - _ -> that -See Trac #9238. Reason: comparing floating-point values for equality -delicate, and we don't want to implement that delicacy in the code for -case expressions. So we make it an invariant of Core that a case -expression never scrutinises a Float# or Double#. - -This transformation is what the litEq rule does; -see Note [The litEq rule: converting equality to case]. -So we /refrain/ from using litEq for mkFloatingRelOpRule. --} - -mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) - -> Maybe CoreRule --- See Note [Rules for floating-point comparisons] -mkFloatingRelOpRule nm cmp - = mkPrimOpRule nm 2 [binaryCmpLit cmp] - --- common constants -zeroi, onei, zerow, onew :: DynFlags -> Literal -zeroi dflags = mkMachInt dflags 0 -onei dflags = mkMachInt dflags 1 -zerow dflags = mkMachWord dflags 0 -onew dflags = mkMachWord dflags 1 - -zerof, onef, twof, zerod, oned, twod :: Literal -zerof = mkMachFloat 0.0 -onef = mkMachFloat 1.0 -twof = mkMachFloat 2.0 -zerod = mkMachDouble 0.0 -oned = mkMachDouble 1.0 -twod = mkMachDouble 2.0 - -cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool) - -> Literal -> Literal -> Maybe CoreExpr -cmpOp dflags cmp = go - where - done True = Just $ trueValInt dflags - done False = Just $ falseValInt dflags - - -- These compares are at different types - go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2) - go (MachInt i1) (MachInt i2) = done (i1 `cmp` i2) - go (MachInt64 i1) (MachInt64 i2) = done (i1 `cmp` i2) - go (MachWord i1) (MachWord i2) = done (i1 `cmp` i2) - go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2) - go (MachFloat i1) (MachFloat i2) = done (i1 `cmp` i2) - go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2) - go _ _ = Nothing - --------------------------- - -negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate -negOp _ (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational -negOp dflags (MachFloat f) = Just (mkFloatVal dflags (-f)) -negOp _ (MachDouble 0.0) = Nothing -negOp dflags (MachDouble d) = Just (mkDoubleVal dflags (-d)) -negOp dflags (MachInt i) = intResult dflags (-i) -negOp _ _ = Nothing - -complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement -complementOp dflags (MachWord i) = wordResult dflags (complement i) -complementOp dflags (MachInt i) = intResult dflags (complement i) -complementOp _ _ = Nothing - --------------------------- -intOp2 :: (Integral a, Integral b) - => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -intOp2 = intOp2' . const - -intOp2' :: (Integral a, Integral b) - => (DynFlags -> a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -intOp2' op dflags (MachInt i1) (MachInt i2) = - let o = op dflags - in intResult dflags (fromInteger i1 `o` fromInteger i2) -intOp2' _ _ _ _ = Nothing -- Could find LitLit - -shiftRightLogical :: DynFlags -> Integer -> Int -> Integer --- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do --- Do this by converting to Word and back. Obviously this won't work for big --- values, but its ok as we use it here -shiftRightLogical dflags x n - | wordSizeInBits dflags == 32 = fromIntegral (fromInteger x `shiftR` n :: Word32) - | wordSizeInBits dflags == 64 = fromIntegral (fromInteger x `shiftR` n :: Word64) - | otherwise = panic "shiftRightLogical: unsupported word size" - --------------------------- -retLit :: (DynFlags -> Literal) -> RuleM CoreExpr -retLit l = do dflags <- getDynFlags - return $ Lit $ l dflags - -wordOp2 :: (Integral a, Integral b) - => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -wordOp2 op dflags (MachWord w1) (MachWord w2) - = wordResult dflags (fromInteger w1 `op` fromInteger w2) -wordOp2 _ _ _ _ = Nothing -- Could find LitLit - -wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr - -- Shifts take an Int; hence third arg of op is Int --- See Note [Guarding against silly shifts] -wordShiftRule shift_op - = do { dflags <- getDynFlags - ; [e1, Lit (MachInt shift_len)] <- getArgs - ; case e1 of - _ | shift_len == 0 - -> return e1 - | shift_len < 0 || wordSizeInBits dflags < shift_len - -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy - ("Bad shift length" ++ show shift_len)) - Lit (MachWord x) - -> let op = shift_op dflags - in liftMaybe $ wordResult dflags (x `op` fromInteger shift_len) - -- Do the shift at type Integer, but shift length is Int - _ -> mzero } - -wordSizeInBits :: DynFlags -> Integer -wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3) - --------------------------- -floatOp2 :: (Rational -> Rational -> Rational) - -> DynFlags -> Literal -> Literal - -> Maybe (Expr CoreBndr) -floatOp2 op dflags (MachFloat f1) (MachFloat f2) - = Just (mkFloatVal dflags (f1 `op` f2)) -floatOp2 _ _ _ _ = Nothing - --------------------------- -doubleOp2 :: (Rational -> Rational -> Rational) - -> DynFlags -> Literal -> Literal - -> Maybe (Expr CoreBndr) -doubleOp2 op dflags (MachDouble f1) (MachDouble f2) - = Just (mkDoubleVal dflags (f1 `op` f2)) -doubleOp2 _ _ _ _ = Nothing - --------------------------- -{- Note [The litEq rule: converting equality to case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This stuff turns - n ==# 3# -into - case n of - 3# -> True - m -> False - -This is a Good Thing, because it allows case-of case things -to happen, and case-default absorption to happen. For -example: - - if (n ==# 3#) || (n ==# 4#) then e1 else e2 -will transform to - case n of - 3# -> e1 - 4# -> e1 - m -> e2 -(modulo the usual precautions to avoid duplicating e1) --} - -litEq :: Bool -- True <=> equality, False <=> inequality - -> RuleM CoreExpr -litEq is_eq = msum - [ do [Lit lit, expr] <- getArgs - dflags <- getDynFlags - do_lit_eq dflags lit expr - , do [expr, Lit lit] <- getArgs - dflags <- getDynFlags - do_lit_eq dflags lit expr ] - where - do_lit_eq dflags lit expr = do - guard (not (litIsLifted lit)) - return (mkWildCase expr (literalType lit) intPrimTy - [(DEFAULT, [], val_if_neq), - (LitAlt lit, [], val_if_eq)]) - where - val_if_eq | is_eq = trueValInt dflags - | otherwise = falseValInt dflags - val_if_neq | is_eq = falseValInt dflags - | otherwise = trueValInt dflags - - --- | Check if there is comparison with minBound or maxBound, that is --- always true or false. For instance, an Int cannot be smaller than its --- minBound, so we can replace such comparison with False. -boundsCmp :: Comparison -> RuleM CoreExpr -boundsCmp op = do - dflags <- getDynFlags - [a, b] <- getArgs - liftMaybe $ mkRuleFn dflags op a b - -data Comparison = Gt | Ge | Lt | Le - -mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr -mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags -mkRuleFn _ _ _ _ = Nothing - -isMinBound :: DynFlags -> Literal -> Bool -isMinBound _ (MachChar c) = c == minBound -isMinBound dflags (MachInt i) = i == tARGET_MIN_INT dflags -isMinBound _ (MachInt64 i) = i == toInteger (minBound :: Int64) -isMinBound _ (MachWord i) = i == 0 -isMinBound _ (MachWord64 i) = i == 0 -isMinBound _ _ = False - -isMaxBound :: DynFlags -> Literal -> Bool -isMaxBound _ (MachChar c) = c == maxBound -isMaxBound dflags (MachInt i) = i == tARGET_MAX_INT dflags -isMaxBound _ (MachInt64 i) = i == toInteger (maxBound :: Int64) -isMaxBound dflags (MachWord i) = i == tARGET_MAX_WORD dflags -isMaxBound _ (MachWord64 i) = i == toInteger (maxBound :: Word64) -isMaxBound _ _ = False - - --- Note [Word/Int underflow/overflow] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and --- unsigned integral types): "All arithmetic is performed modulo 2^n, where n is --- the number of bits in the type." --- --- GHC stores Word# and Int# constant values as Integer. Core optimizations such --- as constant folding must ensure that the Integer value remains in the valid --- target Word/Int range (see #13172). The following functions are used to --- ensure this. --- --- Note that we *don't* warn the user about overflow. It's not done at runtime --- either, and compilation of completely harmless things like --- ((124076834 :: Word32) + (2147483647 :: Word32)) --- doesn't yield a warning. Instead we simply squash the value into the *target* --- Int/Word range. - --- | Ensure the given Integer is in the target Int range -intResult' :: DynFlags -> Integer -> Integer -intResult' dflags result = case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (fromInteger result :: Int32) - 8 -> toInteger (fromInteger result :: Int64) - w -> panic ("intResult: Unknown platformWordSize: " ++ show w) - --- | Ensure the given Integer is in the target Word range -wordResult' :: DynFlags -> Integer -> Integer -wordResult' dflags result = case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (fromInteger result :: Word32) - 8 -> toInteger (fromInteger result :: Word64) - w -> panic ("wordResult: Unknown platformWordSize: " ++ show w) - --- | Create an Int literal expression while ensuring the given Integer is in the --- target Int range -intResult :: DynFlags -> Integer -> Maybe CoreExpr -intResult dflags result = Just (mkIntVal dflags (intResult' dflags result)) - --- | Create a Word literal expression while ensuring the given Integer is in the --- target Word range -wordResult :: DynFlags -> Integer -> Maybe CoreExpr -wordResult dflags result = Just (mkWordVal dflags (wordResult' dflags result)) - - - - -inversePrimOp :: PrimOp -> RuleM CoreExpr -inversePrimOp primop = do - [Var primop_id `App` e] <- getArgs - matchPrimOpId primop primop_id - return e - -subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr -this `subsumesPrimOp` that = do - [Var primop_id `App` e] <- getArgs - matchPrimOpId that primop_id - return (Var (mkPrimOpId this) `App` e) - -subsumedByPrimOp :: PrimOp -> RuleM CoreExpr -subsumedByPrimOp primop = do - [e@(Var primop_id `App` _)] <- getArgs - matchPrimOpId primop primop_id - return e - -idempotent :: RuleM CoreExpr -idempotent = do [e1, e2] <- getArgs - guard $ cheapEqExpr e1 e2 - return e1 - -{- -Note [Guarding against silly shifts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this code: - - import Data.Bits( (.|.), shiftL ) - chunkToBitmap :: [Bool] -> Word32 - chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] - -This optimises to: -Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) -> - case w1_sCT of _ { - [] -> 0##; - : x_aAW xs_aAX -> - case x_aAW of _ { - GHC.Types.False -> - case w_sCS of wild2_Xh { - __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX; - 9223372036854775807 -> 0## }; - GHC.Types.True -> - case GHC.Prim.>=# w_sCS 64 of _ { - GHC.Types.False -> - case w_sCS of wild3_Xh { - __DEFAULT -> - case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT -> - GHC.Prim.or# (GHC.Prim.narrow32Word# - (GHC.Prim.uncheckedShiftL# 1## wild3_Xh)) - ww_sCW - }; - 9223372036854775807 -> - GHC.Prim.narrow32Word# -!!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807) - }; - GHC.Types.True -> - case w_sCS of wild3_Xh { - __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX; - 9223372036854775807 -> 0## - } } } } - -Note the massive shift on line "!!!!". It can't happen, because we've checked -that w < 64, but the optimiser didn't spot that. We DO NO want to constant-fold this! -Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we -can't constant fold it, but if it gets to the assember we get - Error: operand type mismatch for `shl' - -So the best thing to do is to rewrite the shift with a call to error, -when the second arg is stupid. - -************************************************************************ -* * -\subsection{Vaguely generic functions} -* * -************************************************************************ --} - -mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule --- Gives the Rule the same name as the primop itself -mkBasicRule op_name n_args rm - = BuiltinRule { ru_name = occNameFS (nameOccName op_name), - ru_fn = op_name, - ru_nargs = n_args, - ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope } - -newtype RuleM r = RuleM - { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r } - -instance Functor RuleM where - fmap = liftM - -instance Applicative RuleM where - pure x = RuleM $ \_ _ _ -> Just x - (<*>) = ap - -instance Monad RuleM where - RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of - Nothing -> Nothing - Just r -> runRuleM (g r) dflags iu e - fail _ = mzero - -#if __GLASGOW_HASKELL__ > 710 -instance MonadFail.MonadFail RuleM where - fail _ = mzero -#endif - -instance Alternative RuleM where - empty = RuleM $ \_ _ _ -> Nothing - RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args -> - f1 dflags iu args <|> f2 dflags iu args - -instance MonadPlus RuleM - -instance HasDynFlags RuleM where - getDynFlags = RuleM $ \dflags _ _ -> Just dflags - -liftMaybe :: Maybe a -> RuleM a -liftMaybe Nothing = mzero -liftMaybe (Just x) = return x - -liftLit :: (Literal -> Literal) -> RuleM CoreExpr -liftLit f = liftLitDynFlags (const f) - -liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr -liftLitDynFlags f = do - dflags <- getDynFlags - [Lit lit] <- getArgs - return $ Lit (f dflags lit) - -removeOp32 :: RuleM CoreExpr -removeOp32 = do - dflags <- getDynFlags - if wordSizeInBits dflags == 32 - then do - [e] <- getArgs - return e - else mzero - -getArgs :: RuleM [CoreExpr] -getArgs = RuleM $ \_ _ args -> Just args - -getInScopeEnv :: RuleM InScopeEnv -getInScopeEnv = RuleM $ \_ iu _ -> Just iu - --- return the n-th argument of this rule, if it is a literal --- argument indices start from 0 -getLiteral :: Int -> RuleM Literal -getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of - (Lit l:_) -> Just l - _ -> Nothing - -unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr -unaryLit op = do - dflags <- getDynFlags - [Lit l] <- getArgs - liftMaybe $ op dflags (convFloating dflags l) - -binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr -binaryLit op = do - dflags <- getDynFlags - [Lit l1, Lit l2] <- getArgs - liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2) - -binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr -binaryCmpLit op = do - dflags <- getDynFlags - binaryLit (\_ -> cmpOp dflags op) - -leftIdentity :: Literal -> RuleM CoreExpr -leftIdentity id_lit = leftIdentityDynFlags (const id_lit) - -rightIdentity :: Literal -> RuleM CoreExpr -rightIdentity id_lit = rightIdentityDynFlags (const id_lit) - -identity :: Literal -> RuleM CoreExpr -identity lit = leftIdentity lit `mplus` rightIdentity lit - -leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -leftIdentityDynFlags id_lit = do - dflags <- getDynFlags - [Lit l1, e2] <- getArgs - guard $ l1 == id_lit dflags - return e2 - -rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -rightIdentityDynFlags id_lit = do - dflags <- getDynFlags - [e1, Lit l2] <- getArgs - guard $ l2 == id_lit dflags - return e1 - -identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit - -leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr -leftZero zero = do - dflags <- getDynFlags - [Lit l1, _] <- getArgs - guard $ l1 == zero dflags - return $ Lit l1 - -rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr -rightZero zero = do - dflags <- getDynFlags - [_, Lit l2] <- getArgs - guard $ l2 == zero dflags - return $ Lit l2 - -zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr -zeroElem lit = leftZero lit `mplus` rightZero lit - -equalArgs :: RuleM () -equalArgs = do - [e1, e2] <- getArgs - guard $ e1 `cheapEqExpr` e2 - -nonZeroLit :: Int -> RuleM () -nonZeroLit n = getLiteral n >>= guard . not . isZeroLit - --- When excess precision is not requested, cut down the precision of the --- Rational value to that of Float/Double. We confuse host architecture --- and target architecture here, but it's convenient (and wrong :-). -convFloating :: DynFlags -> Literal -> Literal -convFloating dflags (MachFloat f) | not (gopt Opt_ExcessPrecision dflags) = - MachFloat (toRational (fromRational f :: Float )) -convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) = - MachDouble (toRational (fromRational d :: Double)) -convFloating _ l = l - -guardFloatDiv :: RuleM () -guardFloatDiv = do - [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs - guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero] - && f2 /= 0 -- avoid NaN and Infinity/-Infinity - -guardDoubleDiv :: RuleM () -guardDoubleDiv = do - [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs - guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero] - && d2 /= 0 -- avoid NaN and Infinity/-Infinity --- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to --- zero, but we might want to preserve the negative zero here which --- is representable in Float/Double but not in (normalised) --- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? - -strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr -strengthReduction two_lit add_op = do -- Note [Strength reduction] - arg <- msum [ do [arg, Lit mult_lit] <- getArgs - guard (mult_lit == two_lit) - return arg - , do [Lit mult_lit, arg] <- getArgs - guard (mult_lit == two_lit) - return arg ] - return $ Var (mkPrimOpId add_op) `App` arg `App` arg - --- Note [Strength reduction] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- This rule turns floating point multiplications of the form 2.0 * x and --- x * 2.0 into x + x addition, because addition costs less than multiplication. --- See #7116 - --- Note [What's true and false] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- trueValInt and falseValInt represent true and false values returned by --- comparison primops for Char, Int, Word, Integer, Double, Float and Addr. --- True is represented as an unboxed 1# literal, while false is represented --- as 0# literal. --- We still need Bool data constructors (True and False) to use in a rule --- for constant folding of equal Strings - -trueValInt, falseValInt :: DynFlags -> Expr CoreBndr -trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false] -falseValInt dflags = Lit $ zeroi dflags - -trueValBool, falseValBool :: Expr CoreBndr -trueValBool = Var trueDataConId -- see Note [What's true and false] -falseValBool = Var falseDataConId - -ltVal, eqVal, gtVal :: Expr CoreBndr -ltVal = Var ltDataConId -eqVal = Var eqDataConId -gtVal = Var gtDataConId - -mkIntVal :: DynFlags -> Integer -> Expr CoreBndr -mkIntVal dflags i = Lit (mkMachInt dflags i) -mkWordVal :: DynFlags -> Integer -> Expr CoreBndr -mkWordVal dflags w = Lit (mkMachWord dflags w) -mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr -mkFloatVal dflags f = Lit (convFloating dflags (MachFloat f)) -mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr -mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d)) - -matchPrimOpId :: PrimOp -> Id -> RuleM () -matchPrimOpId op id = do - op' <- liftMaybe $ isPrimOpId_maybe id - guard $ op == op' - -{- -************************************************************************ -* * -\subsection{Special rules for seq, tagToEnum, dataToTag} -* * -************************************************************************ - -Note [tagToEnum#] -~~~~~~~~~~~~~~~~~ -Nasty check to ensure that tagToEnum# is applied to a type that is an -enumeration TyCon. Unification may refine the type later, but this -check won't see that, alas. It's crude but it works. - -Here's are two cases that should fail - f :: forall a. a - f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable - - g :: Int - g = tagToEnum# 0 -- Int is not an enumeration - -We used to make this check in the type inference engine, but it's quite -ugly to do so, because the delayed constraint solving means that we don't -really know what's going on until the end. It's very much a corner case -because we don't expect the user to call tagToEnum# at all; we merely -generate calls in derived instances of Enum. So we compromise: a -rewrite rule rewrites a bad instance of tagToEnum# to an error call, -and emits a warning. --} - -tagToEnumRule :: RuleM CoreExpr --- If data T a = A | B | C --- then tag2Enum# (T ty) 2# --> B ty -tagToEnumRule = do - [Type ty, Lit (MachInt i)] <- getArgs - case splitTyConApp_maybe ty of - Just (tycon, tc_args) | isEnumerationTyCon tycon -> do - let tag = fromInteger i - correct_tag dc = (dataConTag dc - fIRST_TAG) == tag - (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) - ASSERT(null rest) return () - return $ mkTyApps (Var (dataConWorkId dc)) tc_args - - -- See Note [tagToEnum#] - _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty ) - return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" - -{- -For dataToTag#, we can reduce if either - - (a) the argument is a constructor - (b) the argument is a variable whose unfolding is a known constructor --} - -dataToTagRule :: RuleM CoreExpr -dataToTagRule = a `mplus` b - where - a = do - [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs - guard $ tag_to_enum `hasKey` tagToEnumKey - guard $ ty1 `eqType` ty2 - return tag -- dataToTag (tagToEnum x) ==> x - b = do - dflags <- getDynFlags - [_, val_arg] <- getArgs - in_scope <- getInScopeEnv - (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg - ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () - return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG)) - -{- -************************************************************************ -* * -\subsection{Rules for seq# and spark#} -* * -************************************************************************ --} - --- seq# :: forall a s . a -> State# s -> (# State# s, a #) -seqRule :: RuleM CoreExpr -seqRule = do - [Type ty_a, Type ty_s, a, s] <- getArgs - guard $ exprIsHNF a - return $ mkCoreUbxTup [mkStatePrimTy ty_s, ty_a] [s, a] - --- spark# :: forall a s . a -> State# s -> (# State# s, a #) -sparkRule :: RuleM CoreExpr -sparkRule = seqRule -- reduce on HNF, just the same - -- XXX perhaps we shouldn't do this, because a spark eliminated by - -- this rule won't be counted as a dud at runtime? - -{- -************************************************************************ -* * -\subsection{Built in rules} -* * -************************************************************************ - -Note [Scoping for Builtin rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When compiling a (base-package) module that defines one of the -functions mentioned in the RHS of a built-in rule, there's a danger -that we'll see - - f = ...(eq String x).... - - ....and lower down... - - eqString = ... - -Then a rewrite would give - - f = ...(eqString x)... - ....and lower down... - eqString = ... - -and lo, eqString is not in scope. This only really matters when we get to code -generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole -set of bindings, which sorts out the dependency. Without -O we don't do any rule -rewriting so again we are fine. - -(This whole thing doesn't show up for non-built-in rules because their dependencies -are explicit.) --} - -builtinRules :: [CoreRule] --- Rules for non-primops that can't be expressed using a RULE pragma -builtinRules - = [BuiltinRule { ru_name = fsLit "AppendLitString", - ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_append_lit }, - BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = match_eq_string }, - BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, - BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId, - ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }, - mkBasicRule divIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 div) - , leftZero zeroi - , do - [arg, Lit (MachInt d)] <- getArgs - Just n <- return $ exactLog2 d - dflags <- getDynFlags - return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n - ], - mkBasicRule modIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 mod) - , leftZero zeroi - , do - [arg, Lit (MachInt d)] <- getArgs - Just _ <- return $ exactLog2 d - dflags <- getDynFlags - return $ Var (mkPrimOpId AndIOp) - `App` arg `App` mkIntVal dflags (d - 1) - ] - ] - ++ builtinIntegerRules - -builtinIntegerRules :: [CoreRule] -builtinIntegerRules = - [rule_IntToInteger "smallInteger" smallIntegerName, - rule_WordToInteger "wordToInteger" wordToIntegerName, - rule_Int64ToInteger "int64ToInteger" int64ToIntegerName, - rule_Word64ToInteger "word64ToInteger" word64ToIntegerName, - rule_convert "integerToWord" integerToWordName mkWordLitWord, - rule_convert "integerToInt" integerToIntName mkIntLitInt, - rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64), - rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64), - rule_binop "plusInteger" plusIntegerName (+), - rule_binop "minusInteger" minusIntegerName (-), - rule_binop "timesInteger" timesIntegerName (*), - rule_unop "negateInteger" negateIntegerName negate, - rule_binop_Prim "eqInteger#" eqIntegerPrimName (==), - rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=), - rule_unop "absInteger" absIntegerName abs, - rule_unop "signumInteger" signumIntegerName signum, - rule_binop_Prim "leInteger#" leIntegerPrimName (<=), - rule_binop_Prim "gtInteger#" gtIntegerPrimName (>), - rule_binop_Prim "ltInteger#" ltIntegerPrimName (<), - rule_binop_Prim "geInteger#" geIntegerPrimName (>=), - rule_binop_Ordering "compareInteger" compareIntegerName compare, - rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, - rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat), - rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, - rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, - rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble), - rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr, - rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr, - rule_binop "gcdInteger" gcdIntegerName gcd, - rule_binop "lcmInteger" lcmIntegerName lcm, - rule_binop "andInteger" andIntegerName (.&.), - rule_binop "orInteger" orIntegerName (.|.), - rule_binop "xorInteger" xorIntegerName xor, - rule_unop "complementInteger" complementIntegerName complement, - rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL, - rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR, - rule_bitInteger "bitInteger" bitIntegerName, - -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs - rule_divop_one "quotInteger" quotIntegerName quot, - rule_divop_one "remInteger" remIntegerName rem, - rule_divop_one "divInteger" divIntegerName div, - rule_divop_one "modInteger" modIntegerName mod, - rule_divop_both "divModInteger" divModIntegerName divMod, - rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, - -- These rules below don't actually have to be built in, but if we - -- put them in the Haskell source then we'd have to duplicate them - -- between all Integer implementations - rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName, - rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName, - rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName, - rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName, - rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp, - rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp, - rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp - ] - where rule_convert str name convert - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Integer_convert convert } - rule_IntToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_IntToInteger } - rule_WordToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_WordToInteger } - rule_Int64ToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Int64ToInteger } - rule_Word64ToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Word64ToInteger } - rule_unop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Integer_unop op } - rule_bitInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_IntToInteger_unop (bit . fromIntegral) } - rule_binop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop op } - rule_divop_both str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_divop_both op } - rule_divop_one str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_divop_one op } - rule_Int_binop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_Int_binop op } - rule_binop_Prim str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop_Prim op } - rule_binop_Ordering str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop_Ordering op } - rule_encodeFloat str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_Int_encodeFloat op } - rule_decodeDouble str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_decodeDouble } - rule_XToIntegerToX str name toIntegerName - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_XToIntegerToX toIntegerName } - rule_smallIntegerTo str name primOp - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_smallIntegerTo primOp } - rule_rationalTo str name mkLit - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_rationalTo mkLit } - ---------------------------------------------------- --- The rule is this: --- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) --- = unpackFoldrCString# "foobaz" c n - -match_append_lit :: RuleFun -match_append_lit _ id_unf _ - [ Type ty1 - , lit1 - , c1 - , Var unpk `App` Type ty2 - `App` lit2 - `App` c2 - `App` n - ] - | unpk `hasKey` unpackCStringFoldrIdKey && - c1 `cheapEqExpr` c2 - , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1 - , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2 - = ASSERT( ty1 `eqType` ty2 ) - Just (Var unpk `App` Type ty1 - `App` Lit (MachStr (s1 `BS.append` s2)) - `App` c1 - `App` n) - -match_append_lit _ _ _ _ = Nothing - ---------------------------------------------------- --- The rule is this: --- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 - -match_eq_string :: RuleFun -match_eq_string _ id_unf _ - [Var unpk1 `App` lit1, Var unpk2 `App` lit2] - | unpk1 `hasKey` unpackCStringIdKey - , unpk2 `hasKey` unpackCStringIdKey - , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1 - , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2 - = Just (if s1 == s2 then trueValBool else falseValBool) - -match_eq_string _ _ _ _ = Nothing - - ---------------------------------------------------- --- The rule is this: --- inline f_ty (f a b c) = a b c --- (if f has an unfolding, EVEN if it's a loop breaker) --- --- It's important to allow the argument to 'inline' to have args itself --- (a) because its more forgiving to allow the programmer to write --- inline f a b c --- or inline (f a b c) --- (b) because a polymorphic f wll get a type argument that the --- programmer can't avoid --- --- Also, don't forget about 'inline's type argument! -match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline (Type _ : e : _) - | (Var f, args1) <- collectArgs e, - Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) - -- Ignore the IdUnfoldingFun here! - = Just (mkApps unf args1) - -match_inline _ = Nothing - - --- See Note [magicDictId magic] in `basicTypes/MkId.hs` --- for a description of what is going on here. -match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] - | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap - , Just (dictTy, _) <- splitFunTy_maybe fieldTy - , Just dictTc <- tyConAppTyCon_maybe dictTy - , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc - = Just - $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] [])) - `App` y - -match_magicDict _ = Nothing - -------------------------------------------------- --- Integer rules --- smallInteger (79::Int#) = 79::Integer --- wordToInteger (79::Word#) = 79::Integer --- Similarly Int64, Word64 - -match_IntToInteger :: RuleFun -match_IntToInteger = match_IntToInteger_unop id - -match_WordToInteger :: RuleFun -match_WordToInteger _ id_unf id [xl] - | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> - Just (Lit (LitInteger x integerTy)) - _ -> - panic "match_WordToInteger: Id has the wrong type" -match_WordToInteger _ _ _ _ = Nothing - -match_Int64ToInteger :: RuleFun -match_Int64ToInteger _ id_unf id [xl] - | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> - Just (Lit (LitInteger x integerTy)) - _ -> - panic "match_Int64ToInteger: Id has the wrong type" -match_Int64ToInteger _ _ _ _ = Nothing - -match_Word64ToInteger :: RuleFun -match_Word64ToInteger _ id_unf id [xl] - | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> - Just (Lit (LitInteger x integerTy)) - _ -> - panic "match_Word64ToInteger: Id has the wrong type" -match_Word64ToInteger _ _ _ _ = Nothing - -------------------------------------------------- -match_Integer_convert :: Num a - => (DynFlags -> a -> Expr CoreBndr) - -> RuleFun -match_Integer_convert convert dflags id_unf _ [xl] - | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - = Just (convert dflags (fromInteger x)) -match_Integer_convert _ _ _ _ _ = Nothing - -match_Integer_unop :: (Integer -> Integer) -> RuleFun -match_Integer_unop unop _ id_unf _ [xl] - | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl - = Just (Lit (LitInteger (unop x) i)) -match_Integer_unop _ _ _ _ _ = Nothing - -{- Note [Rewriting bitInteger] - -For most types the bitInteger operation can be implemented in terms of shifts. -The integer-gmp package, however, can do substantially better than this if -allowed to provide its own implementation. However, in so doing it previously lost -constant-folding (see Trac #8832). The bitInteger rule above provides constant folding -specifically for this function. - -There is, however, a bit of trickiness here when it comes to ranges. While the -AST encodes all integers (even MachInts) as Integers, `bit` expects the bit -index to be given as an Int. Hence we coerce to an Int in the rule definition. -This will behave a bit funny for constants larger than the word size, but the user -should expect some funniness given that they will have at very least ignored a -warning in this case. --} - -match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun -match_IntToInteger_unop unop _ id_unf fn [xl] - | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType fn) of - Just (_, integerTy) -> - Just (Lit (LitInteger (unop x) integerTy)) - _ -> - panic "match_IntToInteger_unop: Id has the wrong type" -match_IntToInteger_unop _ _ _ _ _ = Nothing - -match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun -match_Integer_binop binop _ id_unf _ [xl,yl] - | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (LitInteger (x `binop` y) i)) -match_Integer_binop _ _ _ _ _ = Nothing - --- This helper is used for the quotRem and divMod functions -match_Integer_divop_both - :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun -match_Integer_divop_both divop _ id_unf _ [xl,yl] - | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - , (r,s) <- x `divop` y - = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)] -match_Integer_divop_both _ _ _ _ _ = Nothing - --- This helper is used for the quot and rem functions -match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun -match_Integer_divop_one divop _ id_unf _ [xl,yl] - | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - = Just (Lit (LitInteger (x `divop` y) i)) -match_Integer_divop_one _ _ _ _ _ = Nothing - -match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun -match_Integer_Int_binop binop _ id_unf _ [xl,yl] - | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (LitInteger (x `binop` fromIntegral y) i)) -match_Integer_Int_binop _ _ _ _ _ = Nothing - -match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun -match_Integer_binop_Prim binop dflags id_unf _ [xl, yl] - | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just (if x `binop` y then trueValInt dflags else falseValInt dflags) -match_Integer_binop_Prim _ _ _ _ _ = Nothing - -match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun -match_Integer_binop_Ordering binop _ id_unf _ [xl, yl] - | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just $ case x `binop` y of - LT -> ltVal - EQ -> eqVal - GT -> gtVal -match_Integer_binop_Ordering _ _ _ _ _ = Nothing - -match_Integer_Int_encodeFloat :: RealFloat a - => (a -> Expr CoreBndr) - -> RuleFun -match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl] - | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl - = Just (mkLit $ encodeFloat x (fromInteger y)) -match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing - ---------------------------------------------------- --- constant folding for Float/Double --- --- This turns --- rationalToFloat n d --- into a literal Float, and similarly for Doubles. --- --- it's important to not match d == 0, because that may represent a --- literal "0/0" or similar, and we can't produce a literal value for --- NaN or +-Inf -match_rationalTo :: RealFloat a - => (a -> Expr CoreBndr) - -> RuleFun -match_rationalTo mkLit _ id_unf _ [xl, yl] - | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - = Just (mkLit (fromRational (x % y))) -match_rationalTo _ _ _ _ _ = Nothing - -match_decodeDouble :: RuleFun -match_decodeDouble _ id_unf fn [xl] - | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType fn) of - Just (_, res) - | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res - -> case decodeFloat (fromRational x :: Double) of - (y, z) -> - Just $ mkCoreUbxTup [integerTy, intHashTy] - [Lit (LitInteger y integerTy), - Lit (MachInt (toInteger z))] - _ -> - pprPanic "match_decodeDouble: Id has the wrong type" - (ppr fn <+> dcolon <+> ppr (idType fn)) -match_decodeDouble _ _ _ _ = Nothing - -match_XToIntegerToX :: Name -> RuleFun -match_XToIntegerToX n _ _ _ [App (Var x) y] - | idName x == n - = Just y -match_XToIntegerToX _ _ _ _ _ = Nothing - -match_smallIntegerTo :: PrimOp -> RuleFun -match_smallIntegerTo primOp _ _ _ [App (Var x) y] - | idName x == smallIntegerName - = Just $ App (Var (mkPrimOpId primOp)) y -match_smallIntegerTo _ _ _ _ _ = Nothing - - - --------------------------------------------------------- --- Constant folding through case-expressions --- --- cf Scrutinee Constant Folding in simplCore/SimplUtils --------------------------------------------------------- - --- | Match the scrutinee of a case and potentially return a new scrutinee and a --- function to apply to each literal alternative. -caseRules :: DynFlags -> CoreExpr -> Maybe (CoreExpr, Integer -> Integer) -caseRules dflags scrut = case scrut of - - -- We need to call wordResult' and intResult' to ensure that the literal - -- alternatives remain in Word/Int target ranges (cf Note [Word/Int - -- underflow/overflow] and #13172). - - -- v `op` x# - App (App (Var f) v) (Lit l) - | Just op <- isPrimOpId_maybe f - , Just x <- isLitValue_maybe l -> - case op of - WordAddOp -> Just (v, \y -> wordResult' dflags $ y-x ) - IntAddOp -> Just (v, \y -> intResult' dflags $ y-x ) - WordSubOp -> Just (v, \y -> wordResult' dflags $ y+x ) - IntSubOp -> Just (v, \y -> intResult' dflags $ y+x ) - XorOp -> Just (v, \y -> wordResult' dflags $ y `xor` x) - XorIOp -> Just (v, \y -> intResult' dflags $ y `xor` x) - _ -> Nothing - - -- x# `op` v - App (App (Var f) (Lit l)) v - | Just op <- isPrimOpId_maybe f - , Just x <- isLitValue_maybe l -> - case op of - WordAddOp -> Just (v, \y -> wordResult' dflags $ y-x ) - IntAddOp -> Just (v, \y -> intResult' dflags $ y-x ) - WordSubOp -> Just (v, \y -> wordResult' dflags $ x-y ) - IntSubOp -> Just (v, \y -> intResult' dflags $ x-y ) - XorOp -> Just (v, \y -> wordResult' dflags $ y `xor` x) - XorIOp -> Just (v, \y -> intResult' dflags $ y `xor` x) - _ -> Nothing - - -- op v - App (Var f) v - | Just op <- isPrimOpId_maybe f -> - case op of - NotOp -> Just (v, \y -> wordResult' dflags $ complement y) - NotIOp -> Just (v, \y -> intResult' dflags $ complement y) - IntNegOp -> Just (v, \y -> intResult' dflags $ negate y ) - _ -> Nothing - - _ -> Nothing diff --git a/prelude/PrimOp.hs b/prelude/PrimOp.hs deleted file mode 100644 --- a/prelude/PrimOp.hs +++ /dev/null @@ -1,629 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[PrimOp]{Primitive operations (machine-level)} --} - -{-# LANGUAGE CPP #-} - --- The default is a bit too low for the quite large primOpInfo definition -#if __GLASGOW_HASKELL__ >= 801 -{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-} -#endif - -module PrimOp ( - PrimOp(..), PrimOpVecCat(..), allThePrimOps, - primOpType, primOpSig, - primOpTag, maxPrimOpTag, primOpOcc, - - tagToEnumKey, - - primOpOutOfLine, primOpCodeSize, - primOpOkForSpeculation, primOpOkForSideEffects, - primOpIsCheap, primOpFixity, - - getPrimOpResultInfo, PrimOpResultInfo(..), - - PrimCall(..) - ) where - -#include "HsVersions.h" - -import TysPrim -import TysWiredIn - -import CmmType -import Demand -import OccName ( OccName, pprOccName, mkVarOccFS ) -import TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) -import Type -import RepType ( typePrimRep1, tyConPrimRep1 ) -import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..), - SourceText(..) ) -import ForeignCall ( CLabelString ) -import Unique ( Unique, mkPrimOpIdUnique ) -import Outputable -import FastString -import Module ( UnitId ) - -{- -************************************************************************ -* * -\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)} -* * -************************************************************************ - -These are in \tr{state-interface.verb} order. --} - --- supplies: --- data PrimOp = ... -#include "primop-data-decl.hs-incl" - --- supplies --- primOpTag :: PrimOp -> Int -#include "primop-tag.hs-incl" -primOpTag _ = error "primOpTag: unknown primop" - - -instance Eq PrimOp where - op1 == op2 = primOpTag op1 == primOpTag op2 - -instance Ord PrimOp where - op1 < op2 = primOpTag op1 < primOpTag op2 - op1 <= op2 = primOpTag op1 <= primOpTag op2 - op1 >= op2 = primOpTag op1 >= primOpTag op2 - op1 > op2 = primOpTag op1 > primOpTag op2 - op1 `compare` op2 | op1 < op2 = LT - | op1 == op2 = EQ - | otherwise = GT - -instance Outputable PrimOp where - ppr op = pprPrimOp op - -data PrimOpVecCat = IntVec - | WordVec - | FloatVec - --- An @Enum@-derived list would be better; meanwhile... (ToDo) - -allThePrimOps :: [PrimOp] -allThePrimOps = -#include "primop-list.hs-incl" - -tagToEnumKey :: Unique -tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp) - -{- -************************************************************************ -* * -\subsection[PrimOp-info]{The essential info about each @PrimOp@} -* * -************************************************************************ - -The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may -refer to the primitive operation. The conventional \tr{#}-for- -unboxed ops is added on later. - -The reason for the funny characters in the names is so we do not -interfere with the programmer's Haskell name spaces. - -We use @PrimKinds@ for the ``type'' information, because they're -(slightly) more convenient to use than @TyCons@. --} - -data PrimOpInfo - = Dyadic OccName -- string :: T -> T -> T - Type - | Monadic OccName -- string :: T -> T - Type - | Compare OccName -- string :: T -> T -> Int# - Type - | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T - [TyVar] - [Type] - Type - -mkDyadic, mkMonadic, mkCompare :: FastString -> Type -> PrimOpInfo -mkDyadic str ty = Dyadic (mkVarOccFS str) ty -mkMonadic str ty = Monadic (mkVarOccFS str) ty -mkCompare str ty = Compare (mkVarOccFS str) ty - -mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo -mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty - -{- -************************************************************************ -* * -\subsubsection{Strictness} -* * -************************************************************************ - -Not all primops are strict! --} - -primOpStrictness :: PrimOp -> Arity -> StrictSig - -- See Demand.StrictnessInfo for discussion of what the results - -- The arity should be the arity of the primop; that's why - -- this function isn't exported. -#include "primop-strictness.hs-incl" - -{- -************************************************************************ -* * -\subsubsection{Fixity} -* * -************************************************************************ --} - -primOpFixity :: PrimOp -> Maybe Fixity -#include "primop-fixity.hs-incl" - -{- -************************************************************************ -* * -\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops} -* * -************************************************************************ - -@primOpInfo@ gives all essential information (from which everything -else, notably a type, can be constructed) for each @PrimOp@. --} - -primOpInfo :: PrimOp -> PrimOpInfo -#include "primop-primop-info.hs-incl" -primOpInfo _ = error "primOpInfo: unknown primop" - -{- -Here are a load of comments from the old primOp info: - -A @Word#@ is an unsigned @Int#@. - -@decodeFloat#@ is given w/ Integer-stuff (it's similar). - -@decodeDouble#@ is given w/ Integer-stuff (it's similar). - -Decoding of floating-point numbers is sorta Integer-related. Encoding -is done with plain ccalls now (see PrelNumExtra.hs). - -A @Weak@ Pointer is created by the @mkWeak#@ primitive: - - mkWeak# :: k -> v -> f -> State# RealWorld - -> (# State# RealWorld, Weak# v #) - -In practice, you'll use the higher-level - - data Weak v = Weak# v - mkWeak :: k -> v -> IO () -> IO (Weak v) - -The following operation dereferences a weak pointer. The weak pointer -may have been finalized, so the operation returns a result code which -must be inspected before looking at the dereferenced value. - - deRefWeak# :: Weak# v -> State# RealWorld -> - (# State# RealWorld, v, Int# #) - -Only look at v if the Int# returned is /= 0 !! - -The higher-level op is - - deRefWeak :: Weak v -> IO (Maybe v) - -Weak pointers can be finalized early by using the finalize# operation: - - finalizeWeak# :: Weak# v -> State# RealWorld -> - (# State# RealWorld, Int#, IO () #) - -The Int# returned is either - - 0 if the weak pointer has already been finalized, or it has no - finalizer (the third component is then invalid). - - 1 if the weak pointer is still alive, with the finalizer returned - as the third component. - -A {\em stable name/pointer} is an index into a table of stable name -entries. Since the garbage collector is told about stable pointers, -it is safe to pass a stable pointer to external systems such as C -routines. - -\begin{verbatim} -makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) -freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld -deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) -eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int# -\end{verbatim} - -It may seem a bit surprising that @makeStablePtr#@ is a @IO@ -operation since it doesn't (directly) involve IO operations. The -reason is that if some optimisation pass decided to duplicate calls to -@makeStablePtr#@ and we only pass one of the stable pointers over, a -massive space leak can result. Putting it into the IO monad -prevents this. (Another reason for putting them in a monad is to -ensure correct sequencing wrt the side-effecting @freeStablePtr@ -operation.) - -An important property of stable pointers is that if you call -makeStablePtr# twice on the same object you get the same stable -pointer back. - -Note that we can implement @freeStablePtr#@ using @_ccall_@ (and, -besides, it's not likely to be used from Haskell) so it's not a -primop. - -Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR] - -Stable Names -~~~~~~~~~~~~ - -A stable name is like a stable pointer, but with three important differences: - - (a) You can't deRef one to get back to the original object. - (b) You can convert one to an Int. - (c) You don't need to 'freeStableName' - -The existence of a stable name doesn't guarantee to keep the object it -points to alive (unlike a stable pointer), hence (a). - -Invariants: - - (a) makeStableName always returns the same value for a given - object (same as stable pointers). - - (b) if two stable names are equal, it implies that the objects - from which they were created were the same. - - (c) stableNameToInt always returns the same Int for a given - stable name. - - -These primops are pretty weird. - - dataToTag# :: a -> Int (arg must be an evaluated data type) - tagToEnum# :: Int -> a (result type must be an enumerated type) - -The constraints aren't currently checked by the front end, but the -code generator will fall over if they aren't satisfied. - -************************************************************************ -* * - Which PrimOps are out-of-line -* * -************************************************************************ - -Some PrimOps need to be called out-of-line because they either need to -perform a heap check or they block. --} - -primOpOutOfLine :: PrimOp -> Bool -#include "primop-out-of-line.hs-incl" - -{- -************************************************************************ -* * - Failure and side effects -* * -************************************************************************ - -Note [PrimOp can_fail and has_side_effects] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Both can_fail and has_side_effects mean that the primop has -some effect that is not captured entirely by its result value. - ----------- has_side_effects --------------------- -A primop "has_side_effects" if it has some *write* effect, visible -elsewhere - - writing to the world (I/O) - - writing to a mutable data structure (writeIORef) - - throwing a synchronous Haskell exception - -Often such primops have a type like - State -> input -> (State, output) -so the state token guarantees ordering. In general we rely *only* on -data dependencies of the state token to enforce write-effect ordering - - * NB1: if you inline unsafePerformIO, you may end up with - side-effecting ops whose 'state' output is discarded. - And programmers may do that by hand; see Trac #9390. - That is why we (conservatively) do not discard write-effecting - primops even if both their state and result is discarded. - - * NB2: We consider primops, such as raiseIO#, that can raise a - (Haskell) synchronous exception to "have_side_effects" but not - "can_fail". We must be careful about not discarding such things; - see the paper "A semantics for imprecise exceptions". - - * NB3: *Read* effects (like reading an IORef) don't count here, - because it doesn't matter if we don't do them, or do them more than - once. *Sequencing* is maintained by the data dependency of the state - token. - ----------- can_fail ---------------------------- -A primop "can_fail" if it can fail with an *unchecked* exception on -some elements of its input domain. Main examples: - division (fails on zero demoninator) - array indexing (fails if the index is out of bounds) - -An "unchecked exception" is one that is an outright error, (not -turned into a Haskell exception,) such as seg-fault or -divide-by-zero error. Such can_fail primops are ALWAYS surrounded -with a test that checks for the bad cases, but we need to be -very careful about code motion that might move it out of -the scope of the test. - -Note [Transformations affected by can_fail and has_side_effects] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The can_fail and has_side_effects properties have the following effect -on program transformations. Summary table is followed by details. - - can_fail has_side_effects -Discard YES NO -Float in YES YES -Float out NO NO -Duplicate YES NO - -* Discarding. case (a `op` b) of _ -> rhs ===> rhs - You should not discard a has_side_effects primop; e.g. - case (writeIntArray# a i v s of (# _, _ #) -> True - Arguably you should be able to discard this, since the - returned stat token is not used, but that relies on NEVER - inlining unsafePerformIO, and programmers sometimes write - this kind of stuff by hand (Trac #9390). So we (conservatively) - never discard a has_side_effects primop. - - However, it's fine to discard a can_fail primop. For example - case (indexIntArray# a i) of _ -> True - We can discard indexIntArray#; it has can_fail, but not - has_side_effects; see Trac #5658 which was all about this. - Notice that indexIntArray# is (in a more general handling of - effects) read effect, but we don't care about that here, and - treat read effects as *not* has_side_effects. - - Similarly (a `/#` b) can be discarded. It can seg-fault or - cause a hardware exception, but not a synchronous Haskell - exception. - - - - Synchronous Haskell exceptions, e.g. from raiseIO#, are treated - as has_side_effects and hence are not discarded. - -* Float in. You can float a can_fail or has_side_effects primop - *inwards*, but not inside a lambda (see Duplication below). - -* Float out. You must not float a can_fail primop *outwards* lest - you escape the dynamic scope of the test. Example: - case d ># 0# of - True -> case x /# d of r -> r +# 1 - False -> 0 - Here we must not float the case outwards to give - case x/# d of r -> - case d ># 0# of - True -> r +# 1 - False -> 0 - - Nor can you float out a has_side_effects primop. For example: - if blah then case writeMutVar# v True s0 of (# s1 #) -> s1 - else s0 - Notice that s0 is mentioned in both branches of the 'if', but - only one of these two will actually be consumed. But if we - float out to - case writeMutVar# v True s0 of (# s1 #) -> - if blah then s1 else s0 - the writeMutVar will be performed in both branches, which is - utterly wrong. - -* Duplication. You cannot duplicate a has_side_effect primop. You - might wonder how this can occur given the state token threading, but - just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get - something like this - p = case readMutVar# s v of - (# s', r #) -> (S# s', r) - s' = case p of (s', r) -> s' - r = case p of (s', r) -> r - - (All these bindings are boxed.) If we inline p at its two call - sites, we get a catastrophe: because the read is performed once when - s' is demanded, and once when 'r' is demanded, which may be much - later. Utterly wrong. Trac #3207 is real example of this happening. - - However, it's fine to duplicate a can_fail primop. That is really - the only difference between can_fail and has_side_effects. - -Note [Implementation: how can_fail/has_side_effects affect transformations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How do we ensure that that floating/duplication/discarding are done right -in the simplifier? - -Two main predicates on primpops test these flags: - primOpOkForSideEffects <=> not has_side_effects - primOpOkForSpeculation <=> not (has_side_effects || can_fail) - - * The "no-float-out" thing is achieved by ensuring that we never - let-bind a can_fail or has_side_effects primop. The RHS of a - let-binding (which can float in and out freely) satisfies - exprOkForSpeculation; this is the let/app invariant. And - exprOkForSpeculation is false of can_fail and has_side_effects. - - * So can_fail and has_side_effects primops will appear only as the - scrutinees of cases, and that's why the FloatIn pass is capable - of floating case bindings inwards. - - * The no-duplicate thing is done via primOpIsCheap, by making - has_side_effects things (very very very) not-cheap! --} - -primOpHasSideEffects :: PrimOp -> Bool -#include "primop-has-side-effects.hs-incl" - -primOpCanFail :: PrimOp -> Bool -#include "primop-can-fail.hs-incl" - -primOpOkForSpeculation :: PrimOp -> Bool - -- See Note [PrimOp can_fail and has_side_effects] - -- See comments with CoreUtils.exprOkForSpeculation - -- primOpOkForSpeculation => primOpOkForSideEffects -primOpOkForSpeculation op - = primOpOkForSideEffects op - && not (primOpOutOfLine op || primOpCanFail op) - -- I think the "out of line" test is because out of line things can - -- be expensive (eg sine, cosine), and so we may not want to speculate them - -primOpOkForSideEffects :: PrimOp -> Bool -primOpOkForSideEffects op - = not (primOpHasSideEffects op) - -{- -Note [primOpIsCheap] -~~~~~~~~~~~~~~~~~~~~ -@primOpIsCheap@, as used in \tr{SimplUtils.hs}. For now (HACK -WARNING), we just borrow some other predicates for a -what-should-be-good-enough test. "Cheap" means willing to call it more -than once, and/or push it inside a lambda. The latter could change the -behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. --} - -primOpIsCheap :: PrimOp -> Bool --- See Note [PrimOp can_fail and has_side_effects] -primOpIsCheap op = primOpOkForSpeculation op --- In March 2001, we changed this to --- primOpIsCheap op = False --- thereby making *no* primops seem cheap. But this killed eta --- expansion on case (x ==# y) of True -> \s -> ... --- which is bad. In particular a loop like --- doLoop n = loop 0 --- where --- loop i | i == n = return () --- | otherwise = bar i >> loop (i+1) --- allocated a closure every time round because it doesn't eta expand. --- --- The problem that originally gave rise to the change was --- let x = a +# b *# c in x +# x --- were we don't want to inline x. But primopIsCheap doesn't control --- that (it's exprIsDupable that does) so the problem doesn't occur --- even if primOpIsCheap sometimes says 'True'. - -{- -************************************************************************ -* * - PrimOp code size -* * -************************************************************************ - -primOpCodeSize -~~~~~~~~~~~~~~ -Gives an indication of the code size of a primop, for the purposes of -calculating unfolding sizes; see CoreUnfold.sizeExpr. --} - -primOpCodeSize :: PrimOp -> Int -#include "primop-code-size.hs-incl" - -primOpCodeSizeDefault :: Int -primOpCodeSizeDefault = 1 - -- CoreUnfold.primOpSize already takes into account primOpOutOfLine - -- and adds some further costs for the args in that case. - -primOpCodeSizeForeignCall :: Int -primOpCodeSizeForeignCall = 4 - -{- -************************************************************************ -* * - PrimOp types -* * -************************************************************************ --} - -primOpType :: PrimOp -> Type -- you may want to use primOpSig instead -primOpType op - = case primOpInfo op of - Dyadic _occ ty -> dyadic_fun_ty ty - Monadic _occ ty -> monadic_fun_ty ty - Compare _occ ty -> compare_fun_ty ty - - GenPrimOp _occ tyvars arg_tys res_ty -> - mkSpecForAllTys tyvars (mkFunTys arg_tys res_ty) - -primOpOcc :: PrimOp -> OccName -primOpOcc op = case primOpInfo op of - Dyadic occ _ -> occ - Monadic occ _ -> occ - Compare occ _ -> occ - GenPrimOp occ _ _ _ -> occ - --- primOpSig is like primOpType but gives the result split apart: --- (type variables, argument types, result type) --- It also gives arity, strictness info - -primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig) -primOpSig op - = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) - where - arity = length arg_tys - (tyvars, arg_tys, res_ty) - = case (primOpInfo op) of - Monadic _occ ty -> ([], [ty], ty ) - Dyadic _occ ty -> ([], [ty,ty], ty ) - Compare _occ ty -> ([], [ty,ty], intPrimTy) - GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) - -data PrimOpResultInfo - = ReturnsPrim PrimRep - | ReturnsAlg TyCon - --- Some PrimOps need not return a manifest primitive or algebraic value --- (i.e. they might return a polymorphic value). These PrimOps *must* --- be out of line, or the code generator won't work. - -getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo -getPrimOpResultInfo op - = case (primOpInfo op) of - Dyadic _ ty -> ReturnsPrim (typePrimRep1 ty) - Monadic _ ty -> ReturnsPrim (typePrimRep1 ty) - Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) - GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) - | otherwise -> ReturnsAlg tc - where - tc = tyConAppTyCon ty - -- All primops return a tycon-app result - -- The tycon can be an unboxed tuple or sum, though, - -- which gives rise to a ReturnAlg - -{- -We do not currently make use of whether primops are commutable. - -We used to try to move constants to the right hand side for strength -reduction. --} - -{- -commutableOp :: PrimOp -> Bool -#include "primop-commutable.hs-incl" --} - --- Utils: - -dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type -dyadic_fun_ty ty = mkFunTys [ty, ty] ty -monadic_fun_ty ty = mkFunTy ty ty -compare_fun_ty ty = mkFunTys [ty, ty] intPrimTy - --- Output stuff: - -pprPrimOp :: PrimOp -> SDoc -pprPrimOp other_op = pprOccName (primOpOcc other_op) - -{- -************************************************************************ -* * -\subsubsection[PrimCall]{User-imported primitive calls} -* * -************************************************************************ --} - -data PrimCall = PrimCall CLabelString UnitId - -instance Outputable PrimCall where - ppr (PrimCall lbl pkgId) - = text "__primcall" <+> ppr pkgId <+> ppr lbl diff --git a/prelude/PrimOp.hs-boot b/prelude/PrimOp.hs-boot deleted file mode 100644 --- a/prelude/PrimOp.hs-boot +++ /dev/null @@ -1,3 +0,0 @@ -module PrimOp where - -data PrimOp diff --git a/prelude/THNames.hs b/prelude/THNames.hs deleted file mode 100644 --- a/prelude/THNames.hs +++ /dev/null @@ -1,1088 +0,0 @@ --- %************************************************************************ --- %* * --- The known-key names for Template Haskell --- %* * --- %************************************************************************ - -module THNames where - -import PrelNames( mk_known_key_name ) -import Module( Module, mkModuleNameFS, mkModule, thUnitId ) -import Name( Name ) -import OccName( tcName, clsName, dataName, varName ) -import RdrName( RdrName, nameRdrName ) -import Unique -import FastString - --- To add a name, do three things --- --- 1) Allocate a key --- 2) Make a "Name" --- 3) Add the name to templateHaskellNames - -templateHaskellNames :: [Name] --- The names that are implicitly mentioned by ``bracket'' --- Should stay in sync with the import list of DsMeta - -templateHaskellNames = [ - returnQName, bindQName, sequenceQName, newNameName, liftName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, - mkNameSName, - liftStringName, - unTypeName, - unTypeQName, - unsafeTExpCoerceName, - - -- Lit - charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, - charPrimLName, - -- Pat - litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, - conPName, tildePName, bangPName, infixPName, - asPName, wildPName, recPName, listPName, sigPName, viewPName, - -- FieldPat - fieldPatName, - -- Match - matchName, - -- Clause - clauseName, - -- Exp - varEName, conEName, litEName, appEName, appTypeEName, infixEName, - infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, - tupEName, unboxedTupEName, unboxedSumEName, - condEName, multiIfEName, letEName, caseEName, doEName, compEName, - fromEName, fromThenEName, fromToEName, fromThenToEName, - listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName, - -- FieldExp - fieldExpName, - -- Body - guardedBName, normalBName, - -- Guard - normalGEName, patGEName, - -- Stmt - bindSName, letSName, noBindSName, parSName, - -- Dec - funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceWithOverlapDName, - standaloneDerivWithStrategyDName, sigDName, forImpDName, - pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, - pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, - dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, - dataInstDName, newtypeInstDName, tySynInstDName, - infixLDName, infixRDName, infixNDName, - roleAnnotDName, patSynDName, patSynSigDName, - -- Cxt - cxtName, - - -- SourceUnpackedness - noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName, - -- SourceStrictness - noSourceStrictnessName, sourceLazyName, sourceStrictName, - -- Con - normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName, - -- Bang - bangName, - -- BangType - bangTypeName, - -- VarBangType - varBangTypeName, - -- PatSynDir (for pattern synonyms) - unidirPatSynName, implBidirPatSynName, explBidirPatSynName, - -- PatSynArgs (for pattern synonyms) - prefixPatSynName, infixPatSynName, recordPatSynName, - -- Type - forallTName, varTName, conTName, appTName, equalityTName, - tupleTName, unboxedTupleTName, unboxedSumTName, - arrowTName, listTName, sigTName, litTName, - promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, - wildCardTName, - -- TyLit - numTyLitName, strTyLitName, - -- TyVarBndr - plainTVName, kindedTVName, - -- Role - nominalRName, representationalRName, phantomRName, inferRName, - -- Kind - varKName, conKName, tupleKName, arrowKName, listKName, appKName, - starKName, constraintKName, - -- FamilyResultSig - noSigName, kindSigName, tyVarSigName, - -- InjectivityAnn - injectivityAnnName, - -- Callconv - cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName, - -- Safety - unsafeName, - safeName, - interruptibleName, - -- Inline - noInlineDataConName, inlineDataConName, inlinableDataConName, - -- RuleMatch - conLikeDataConName, funLikeDataConName, - -- Phases - allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName, - -- Overlap - overlappableDataConName, overlappingDataConName, overlapsDataConName, - incoherentDataConName, - -- DerivStrategy - stockStrategyDataConName, anyclassStrategyDataConName, - newtypeStrategyDataConName, - -- TExp - tExpDataConName, - -- RuleBndr - ruleVarName, typedRuleVarName, - -- FunDep - funDepName, - -- FamFlavour - typeFamName, dataFamName, - -- TySynEqn - tySynEqnName, - -- AnnTarget - valueAnnotationName, typeAnnotationName, moduleAnnotationName, - -- DerivClause - derivClauseName, - - -- The type classes - liftClassName, - - -- And the tycons - qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, - clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName, - stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName, - varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName, - typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, - patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, - predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, - roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName, - overlapTyConName, derivClauseQTyConName, derivStrategyTyConName, - - -- Quasiquoting - quoteDecName, quoteTypeName, quoteExpName, quotePatName] - -thSyn, thLib, qqLib :: Module -thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") -thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib") -qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") - -mkTHModule :: FastString -> Module -mkTHModule m = mkModule thUnitId (mkModuleNameFS m) - -libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name -libFun = mk_known_key_name OccName.varName thLib -libTc = mk_known_key_name OccName.tcName thLib -thFun = mk_known_key_name OccName.varName thSyn -thTc = mk_known_key_name OccName.tcName thSyn -thCls = mk_known_key_name OccName.clsName thSyn -thCon = mk_known_key_name OccName.dataName thSyn -qqFun = mk_known_key_name OccName.varName qqLib - --------------------- TH.Syntax ----------------------- -liftClassName :: Name -liftClassName = thCls (fsLit "Lift") liftClassKey - -qTyConName, nameTyConName, fieldExpTyConName, patTyConName, - fieldPatTyConName, expTyConName, decTyConName, typeTyConName, - tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName, - predTyConName, tExpTyConName, injAnnTyConName, kindTyConName, - overlapTyConName, derivStrategyTyConName :: Name -qTyConName = thTc (fsLit "Q") qTyConKey -nameTyConName = thTc (fsLit "Name") nameTyConKey -fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey -patTyConName = thTc (fsLit "Pat") patTyConKey -fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey -expTyConName = thTc (fsLit "Exp") expTyConKey -decTyConName = thTc (fsLit "Dec") decTyConKey -typeTyConName = thTc (fsLit "Type") typeTyConKey -tyVarBndrTyConName = thTc (fsLit "TyVarBndr") tyVarBndrTyConKey -matchTyConName = thTc (fsLit "Match") matchTyConKey -clauseTyConName = thTc (fsLit "Clause") clauseTyConKey -funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey -predTyConName = thTc (fsLit "Pred") predTyConKey -tExpTyConName = thTc (fsLit "TExp") tExpTyConKey -injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey -kindTyConName = thTc (fsLit "Kind") kindTyConKey -overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey -derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey - -returnQName, bindQName, sequenceQName, newNameName, liftName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, - mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName, - unsafeTExpCoerceName :: Name -returnQName = thFun (fsLit "returnQ") returnQIdKey -bindQName = thFun (fsLit "bindQ") bindQIdKey -sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey -newNameName = thFun (fsLit "newName") newNameIdKey -liftName = thFun (fsLit "lift") liftIdKey -liftStringName = thFun (fsLit "liftString") liftStringIdKey -mkNameName = thFun (fsLit "mkName") mkNameIdKey -mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey -mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey -mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey -mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey -mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey -unTypeName = thFun (fsLit "unType") unTypeIdKey -unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey -unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey - - --------------------- TH.Lib ----------------------- --- data Lit = ... -charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, - charPrimLName :: Name -charLName = libFun (fsLit "charL") charLIdKey -stringLName = libFun (fsLit "stringL") stringLIdKey -integerLName = libFun (fsLit "integerL") integerLIdKey -intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey -wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey -floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey -doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey -rationalLName = libFun (fsLit "rationalL") rationalLIdKey -stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey -charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey - --- data Pat = ... -litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName, - infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName, - sigPName, viewPName :: Name -litPName = libFun (fsLit "litP") litPIdKey -varPName = libFun (fsLit "varP") varPIdKey -tupPName = libFun (fsLit "tupP") tupPIdKey -unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey -unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey -conPName = libFun (fsLit "conP") conPIdKey -infixPName = libFun (fsLit "infixP") infixPIdKey -tildePName = libFun (fsLit "tildeP") tildePIdKey -bangPName = libFun (fsLit "bangP") bangPIdKey -asPName = libFun (fsLit "asP") asPIdKey -wildPName = libFun (fsLit "wildP") wildPIdKey -recPName = libFun (fsLit "recP") recPIdKey -listPName = libFun (fsLit "listP") listPIdKey -sigPName = libFun (fsLit "sigP") sigPIdKey -viewPName = libFun (fsLit "viewP") viewPIdKey - --- type FieldPat = ... -fieldPatName :: Name -fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey - --- data Match = ... -matchName :: Name -matchName = libFun (fsLit "match") matchIdKey - --- data Clause = ... -clauseName :: Name -clauseName = libFun (fsLit "clause") clauseIdKey - --- data Exp = ... -varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName, - sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, - unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName, - caseEName, doEName, compEName, staticEName, unboundVarEName :: Name -varEName = libFun (fsLit "varE") varEIdKey -conEName = libFun (fsLit "conE") conEIdKey -litEName = libFun (fsLit "litE") litEIdKey -appEName = libFun (fsLit "appE") appEIdKey -appTypeEName = libFun (fsLit "appTypeE") appTypeEIdKey -infixEName = libFun (fsLit "infixE") infixEIdKey -infixAppName = libFun (fsLit "infixApp") infixAppIdKey -sectionLName = libFun (fsLit "sectionL") sectionLIdKey -sectionRName = libFun (fsLit "sectionR") sectionRIdKey -lamEName = libFun (fsLit "lamE") lamEIdKey -lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey -tupEName = libFun (fsLit "tupE") tupEIdKey -unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey -unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey -condEName = libFun (fsLit "condE") condEIdKey -multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey -letEName = libFun (fsLit "letE") letEIdKey -caseEName = libFun (fsLit "caseE") caseEIdKey -doEName = libFun (fsLit "doE") doEIdKey -compEName = libFun (fsLit "compE") compEIdKey --- ArithSeq skips a level -fromEName, fromThenEName, fromToEName, fromThenToEName :: Name -fromEName = libFun (fsLit "fromE") fromEIdKey -fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey -fromToEName = libFun (fsLit "fromToE") fromToEIdKey -fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey --- end ArithSeq -listEName, sigEName, recConEName, recUpdEName :: Name -listEName = libFun (fsLit "listE") listEIdKey -sigEName = libFun (fsLit "sigE") sigEIdKey -recConEName = libFun (fsLit "recConE") recConEIdKey -recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey -staticEName = libFun (fsLit "staticE") staticEIdKey -unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey - --- type FieldExp = ... -fieldExpName :: Name -fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey - --- data Body = ... -guardedBName, normalBName :: Name -guardedBName = libFun (fsLit "guardedB") guardedBIdKey -normalBName = libFun (fsLit "normalB") normalBIdKey - --- data Guard = ... -normalGEName, patGEName :: Name -normalGEName = libFun (fsLit "normalGE") normalGEIdKey -patGEName = libFun (fsLit "patGE") patGEIdKey - --- data Stmt = ... -bindSName, letSName, noBindSName, parSName :: Name -bindSName = libFun (fsLit "bindS") bindSIdKey -letSName = libFun (fsLit "letS") letSIdKey -noBindSName = libFun (fsLit "noBindS") noBindSIdKey -parSName = libFun (fsLit "parS") parSIdKey - --- data Dec = ... -funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, - instanceWithOverlapDName, sigDName, forImpDName, pragInlDName, - pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, - pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, - dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName, - openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName, - infixNDName, roleAnnotDName, patSynDName, patSynSigDName, - pragCompleteDName :: Name -funDName = libFun (fsLit "funD") funDIdKey -valDName = libFun (fsLit "valD") valDIdKey -dataDName = libFun (fsLit "dataD") dataDIdKey -newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey -tySynDName = libFun (fsLit "tySynD") tySynDIdKey -classDName = libFun (fsLit "classD") classDIdKey -instanceWithOverlapDName - = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey -standaloneDerivWithStrategyDName = libFun - (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey -sigDName = libFun (fsLit "sigD") sigDIdKey -defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey -forImpDName = libFun (fsLit "forImpD") forImpDIdKey -pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey -pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey -pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey -pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey -pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey -pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey -pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey -dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey -newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey -tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey -openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey -closedTypeFamilyDName= libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey -dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey -infixLDName = libFun (fsLit "infixLD") infixLDIdKey -infixRDName = libFun (fsLit "infixRD") infixRDIdKey -infixNDName = libFun (fsLit "infixND") infixNDIdKey -roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey -patSynDName = libFun (fsLit "patSynD") patSynDIdKey -patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey - --- type Ctxt = ... -cxtName :: Name -cxtName = libFun (fsLit "cxt") cxtIdKey - --- data SourceUnpackedness = ... -noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name -noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey -sourceNoUnpackName = libFun (fsLit "sourceNoUnpack") sourceNoUnpackKey -sourceUnpackName = libFun (fsLit "sourceUnpack") sourceUnpackKey - --- data SourceStrictness = ... -noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name -noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey -sourceLazyName = libFun (fsLit "sourceLazy") sourceLazyKey -sourceStrictName = libFun (fsLit "sourceStrict") sourceStrictKey - --- data Con = ... -normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name -normalCName = libFun (fsLit "normalC" ) normalCIdKey -recCName = libFun (fsLit "recC" ) recCIdKey -infixCName = libFun (fsLit "infixC" ) infixCIdKey -forallCName = libFun (fsLit "forallC" ) forallCIdKey -gadtCName = libFun (fsLit "gadtC" ) gadtCIdKey -recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey - --- data Bang = ... -bangName :: Name -bangName = libFun (fsLit "bang") bangIdKey - --- type BangType = ... -bangTypeName :: Name -bangTypeName = libFun (fsLit "bangType") bangTKey - --- type VarBangType = ... -varBangTypeName :: Name -varBangTypeName = libFun (fsLit "varBangType") varBangTKey - --- data PatSynDir = ... -unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name -unidirPatSynName = libFun (fsLit "unidir") unidirPatSynIdKey -implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey -explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey - --- data PatSynArgs = ... -prefixPatSynName, infixPatSynName, recordPatSynName :: Name -prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey -infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey -recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey - --- data Type = ... -forallTName, varTName, conTName, tupleTName, unboxedTupleTName, - unboxedSumTName, arrowTName, listTName, appTName, sigTName, equalityTName, - litTName, promotedTName, promotedTupleTName, promotedNilTName, - promotedConsTName, wildCardTName :: Name -forallTName = libFun (fsLit "forallT") forallTIdKey -varTName = libFun (fsLit "varT") varTIdKey -conTName = libFun (fsLit "conT") conTIdKey -tupleTName = libFun (fsLit "tupleT") tupleTIdKey -unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey -unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey -arrowTName = libFun (fsLit "arrowT") arrowTIdKey -listTName = libFun (fsLit "listT") listTIdKey -appTName = libFun (fsLit "appT") appTIdKey -sigTName = libFun (fsLit "sigT") sigTIdKey -equalityTName = libFun (fsLit "equalityT") equalityTIdKey -litTName = libFun (fsLit "litT") litTIdKey -promotedTName = libFun (fsLit "promotedT") promotedTIdKey -promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey -promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey -promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey -wildCardTName = libFun (fsLit "wildCardT") wildCardTIdKey - --- data TyLit = ... -numTyLitName, strTyLitName :: Name -numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey -strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey - --- data TyVarBndr = ... -plainTVName, kindedTVName :: Name -plainTVName = libFun (fsLit "plainTV") plainTVIdKey -kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey - --- data Role = ... -nominalRName, representationalRName, phantomRName, inferRName :: Name -nominalRName = libFun (fsLit "nominalR") nominalRIdKey -representationalRName = libFun (fsLit "representationalR") representationalRIdKey -phantomRName = libFun (fsLit "phantomR") phantomRIdKey -inferRName = libFun (fsLit "inferR") inferRIdKey - --- data Kind = ... -varKName, conKName, tupleKName, arrowKName, listKName, appKName, - starKName, constraintKName :: Name -varKName = libFun (fsLit "varK") varKIdKey -conKName = libFun (fsLit "conK") conKIdKey -tupleKName = libFun (fsLit "tupleK") tupleKIdKey -arrowKName = libFun (fsLit "arrowK") arrowKIdKey -listKName = libFun (fsLit "listK") listKIdKey -appKName = libFun (fsLit "appK") appKIdKey -starKName = libFun (fsLit "starK") starKIdKey -constraintKName = libFun (fsLit "constraintK") constraintKIdKey - --- data FamilyResultSig = ... -noSigName, kindSigName, tyVarSigName :: Name -noSigName = libFun (fsLit "noSig") noSigIdKey -kindSigName = libFun (fsLit "kindSig") kindSigIdKey -tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey - --- data InjectivityAnn = ... -injectivityAnnName :: Name -injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey - --- data Callconv = ... -cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name -cCallName = libFun (fsLit "cCall") cCallIdKey -stdCallName = libFun (fsLit "stdCall") stdCallIdKey -cApiCallName = libFun (fsLit "cApi") cApiCallIdKey -primCallName = libFun (fsLit "prim") primCallIdKey -javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey - --- data Safety = ... -unsafeName, safeName, interruptibleName :: Name -unsafeName = libFun (fsLit "unsafe") unsafeIdKey -safeName = libFun (fsLit "safe") safeIdKey -interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey - --- newtype TExp a = ... -tExpDataConName :: Name -tExpDataConName = thCon (fsLit "TExp") tExpDataConKey - --- data RuleBndr = ... -ruleVarName, typedRuleVarName :: Name -ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey -typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey - --- data FunDep = ... -funDepName :: Name -funDepName = libFun (fsLit "funDep") funDepIdKey - --- data FamFlavour = ... -typeFamName, dataFamName :: Name -typeFamName = libFun (fsLit "typeFam") typeFamIdKey -dataFamName = libFun (fsLit "dataFam") dataFamIdKey - --- data TySynEqn = ... -tySynEqnName :: Name -tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey - --- data AnnTarget = ... -valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name -valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey -typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey -moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey - --- type DerivClause = ... -derivClauseName :: Name -derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey - -matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, - decQTyConName, conQTyConName, bangTypeQTyConName, - varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName, - patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName, - ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName, - derivClauseQTyConName :: Name -matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey -clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey -expQTyConName = libTc (fsLit "ExpQ") expQTyConKey -stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey -decQTyConName = libTc (fsLit "DecQ") decQTyConKey -decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] -conQTyConName = libTc (fsLit "ConQ") conQTyConKey -bangTypeQTyConName = libTc (fsLit "BangTypeQ") bangTypeQTyConKey -varBangTypeQTyConName = libTc (fsLit "VarBangTypeQ") varBangTypeQTyConKey -typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey -fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey -patQTyConName = libTc (fsLit "PatQ") patQTyConKey -fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey -predQTyConName = libTc (fsLit "PredQ") predQTyConKey -ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey -tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey -roleTyConName = libTc (fsLit "Role") roleTyConKey -derivClauseQTyConName = libTc (fsLit "DerivClauseQ") derivClauseQTyConKey - --- quasiquoting -quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name -quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey -quotePatName = qqFun (fsLit "quotePat") quotePatKey -quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey -quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey - --- data Inline = ... -noInlineDataConName, inlineDataConName, inlinableDataConName :: Name -noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey -inlineDataConName = thCon (fsLit "Inline") inlineDataConKey -inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey - --- data RuleMatch = ... -conLikeDataConName, funLikeDataConName :: Name -conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey -funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey - --- data Phases = ... -allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name -allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey -fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey -beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey - --- data Overlap = ... -overlappableDataConName, - overlappingDataConName, - overlapsDataConName, - incoherentDataConName :: Name -overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey -overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey -overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey -incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey - --- data DerivStrategy = ... -stockStrategyDataConName, anyclassStrategyDataConName, - newtypeStrategyDataConName :: Name -stockStrategyDataConName = thCon (fsLit "StockStrategy") stockDataConKey -anyclassStrategyDataConName = thCon (fsLit "AnyclassStrategy") anyclassDataConKey -newtypeStrategyDataConName = thCon (fsLit "NewtypeStrategy") newtypeDataConKey - -{- ********************************************************************* -* * - Class keys -* * -********************************************************************* -} - --- ClassUniques available: 200-299 --- Check in PrelNames if you want to change this - -liftClassKey :: Unique -liftClassKey = mkPreludeClassUnique 200 - -{- ********************************************************************* -* * - TyCon keys -* * -********************************************************************* -} - --- TyConUniques available: 200-299 --- Check in PrelNames if you want to change this - -expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, - decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey, - stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey, - decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey, - fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, - fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, - predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey, - roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey, - overlapTyConKey, derivClauseQTyConKey, derivStrategyTyConKey :: Unique -expTyConKey = mkPreludeTyConUnique 200 -matchTyConKey = mkPreludeTyConUnique 201 -clauseTyConKey = mkPreludeTyConUnique 202 -qTyConKey = mkPreludeTyConUnique 203 -expQTyConKey = mkPreludeTyConUnique 204 -decQTyConKey = mkPreludeTyConUnique 205 -patTyConKey = mkPreludeTyConUnique 206 -matchQTyConKey = mkPreludeTyConUnique 207 -clauseQTyConKey = mkPreludeTyConUnique 208 -stmtQTyConKey = mkPreludeTyConUnique 209 -conQTyConKey = mkPreludeTyConUnique 210 -typeQTyConKey = mkPreludeTyConUnique 211 -typeTyConKey = mkPreludeTyConUnique 212 -decTyConKey = mkPreludeTyConUnique 213 -bangTypeQTyConKey = mkPreludeTyConUnique 214 -varBangTypeQTyConKey = mkPreludeTyConUnique 215 -fieldExpTyConKey = mkPreludeTyConUnique 216 -fieldPatTyConKey = mkPreludeTyConUnique 217 -nameTyConKey = mkPreludeTyConUnique 218 -patQTyConKey = mkPreludeTyConUnique 219 -fieldPatQTyConKey = mkPreludeTyConUnique 220 -fieldExpQTyConKey = mkPreludeTyConUnique 221 -funDepTyConKey = mkPreludeTyConUnique 222 -predTyConKey = mkPreludeTyConUnique 223 -predQTyConKey = mkPreludeTyConUnique 224 -tyVarBndrTyConKey = mkPreludeTyConUnique 225 -decsQTyConKey = mkPreludeTyConUnique 226 -ruleBndrQTyConKey = mkPreludeTyConUnique 227 -tySynEqnQTyConKey = mkPreludeTyConUnique 228 -roleTyConKey = mkPreludeTyConUnique 229 -tExpTyConKey = mkPreludeTyConUnique 230 -injAnnTyConKey = mkPreludeTyConUnique 231 -kindTyConKey = mkPreludeTyConUnique 232 -overlapTyConKey = mkPreludeTyConUnique 233 -derivClauseQTyConKey = mkPreludeTyConUnique 234 -derivStrategyTyConKey = mkPreludeTyConUnique 235 - -{- ********************************************************************* -* * - DataCon keys -* * -********************************************************************* -} - --- DataConUniques available: 100-150 --- If you want to change this, make sure you check in PrelNames - --- data Inline = ... -noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique -noInlineDataConKey = mkPreludeDataConUnique 200 -inlineDataConKey = mkPreludeDataConUnique 201 -inlinableDataConKey = mkPreludeDataConUnique 202 - --- data RuleMatch = ... -conLikeDataConKey, funLikeDataConKey :: Unique -conLikeDataConKey = mkPreludeDataConUnique 203 -funLikeDataConKey = mkPreludeDataConUnique 204 - --- data Phases = ... -allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique -allPhasesDataConKey = mkPreludeDataConUnique 205 -fromPhaseDataConKey = mkPreludeDataConUnique 206 -beforePhaseDataConKey = mkPreludeDataConUnique 207 - --- newtype TExp a = ... -tExpDataConKey :: Unique -tExpDataConKey = mkPreludeDataConUnique 208 - --- data Overlap = .. -overlappableDataConKey, - overlappingDataConKey, - overlapsDataConKey, - incoherentDataConKey :: Unique -overlappableDataConKey = mkPreludeDataConUnique 209 -overlappingDataConKey = mkPreludeDataConUnique 210 -overlapsDataConKey = mkPreludeDataConUnique 211 -incoherentDataConKey = mkPreludeDataConUnique 212 - --- data DerivStrategy = ... -stockDataConKey, anyclassDataConKey, newtypeDataConKey :: Unique -stockDataConKey = mkPreludeDataConUnique 213 -anyclassDataConKey = mkPreludeDataConUnique 214 -newtypeDataConKey = mkPreludeDataConUnique 215 - -{- ********************************************************************* -* * - Id keys -* * -********************************************************************* -} - --- IdUniques available: 200-499 --- If you want to change this, make sure you check in PrelNames - -returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, - mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, - mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey, - unsafeTExpCoerceIdKey :: Unique -returnQIdKey = mkPreludeMiscIdUnique 200 -bindQIdKey = mkPreludeMiscIdUnique 201 -sequenceQIdKey = mkPreludeMiscIdUnique 202 -liftIdKey = mkPreludeMiscIdUnique 203 -newNameIdKey = mkPreludeMiscIdUnique 204 -mkNameIdKey = mkPreludeMiscIdUnique 205 -mkNameG_vIdKey = mkPreludeMiscIdUnique 206 -mkNameG_dIdKey = mkPreludeMiscIdUnique 207 -mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 -mkNameLIdKey = mkPreludeMiscIdUnique 209 -mkNameSIdKey = mkPreludeMiscIdUnique 210 -unTypeIdKey = mkPreludeMiscIdUnique 211 -unTypeQIdKey = mkPreludeMiscIdUnique 212 -unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213 - - --- data Lit = ... -charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, - floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey, - charPrimLIdKey:: Unique -charLIdKey = mkPreludeMiscIdUnique 220 -stringLIdKey = mkPreludeMiscIdUnique 221 -integerLIdKey = mkPreludeMiscIdUnique 222 -intPrimLIdKey = mkPreludeMiscIdUnique 223 -wordPrimLIdKey = mkPreludeMiscIdUnique 224 -floatPrimLIdKey = mkPreludeMiscIdUnique 225 -doublePrimLIdKey = mkPreludeMiscIdUnique 226 -rationalLIdKey = mkPreludeMiscIdUnique 227 -stringPrimLIdKey = mkPreludeMiscIdUnique 228 -charPrimLIdKey = mkPreludeMiscIdUnique 229 - -liftStringIdKey :: Unique -liftStringIdKey = mkPreludeMiscIdUnique 230 - --- data Pat = ... -litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey, - infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, - listPIdKey, sigPIdKey, viewPIdKey :: Unique -litPIdKey = mkPreludeMiscIdUnique 240 -varPIdKey = mkPreludeMiscIdUnique 241 -tupPIdKey = mkPreludeMiscIdUnique 242 -unboxedTupPIdKey = mkPreludeMiscIdUnique 243 -unboxedSumPIdKey = mkPreludeMiscIdUnique 244 -conPIdKey = mkPreludeMiscIdUnique 245 -infixPIdKey = mkPreludeMiscIdUnique 246 -tildePIdKey = mkPreludeMiscIdUnique 247 -bangPIdKey = mkPreludeMiscIdUnique 248 -asPIdKey = mkPreludeMiscIdUnique 249 -wildPIdKey = mkPreludeMiscIdUnique 250 -recPIdKey = mkPreludeMiscIdUnique 251 -listPIdKey = mkPreludeMiscIdUnique 252 -sigPIdKey = mkPreludeMiscIdUnique 253 -viewPIdKey = mkPreludeMiscIdUnique 254 - --- type FieldPat = ... -fieldPatIdKey :: Unique -fieldPatIdKey = mkPreludeMiscIdUnique 260 - --- data Match = ... -matchIdKey :: Unique -matchIdKey = mkPreludeMiscIdUnique 261 - --- data Clause = ... -clauseIdKey :: Unique -clauseIdKey = mkPreludeMiscIdUnique 262 - - --- data Exp = ... -varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey, - infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, - tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey, - letEIdKey, caseEIdKey, doEIdKey, compEIdKey, - fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, - listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey, - unboundVarEIdKey :: Unique -varEIdKey = mkPreludeMiscIdUnique 270 -conEIdKey = mkPreludeMiscIdUnique 271 -litEIdKey = mkPreludeMiscIdUnique 272 -appEIdKey = mkPreludeMiscIdUnique 273 -appTypeEIdKey = mkPreludeMiscIdUnique 274 -infixEIdKey = mkPreludeMiscIdUnique 275 -infixAppIdKey = mkPreludeMiscIdUnique 276 -sectionLIdKey = mkPreludeMiscIdUnique 277 -sectionRIdKey = mkPreludeMiscIdUnique 278 -lamEIdKey = mkPreludeMiscIdUnique 279 -lamCaseEIdKey = mkPreludeMiscIdUnique 280 -tupEIdKey = mkPreludeMiscIdUnique 281 -unboxedTupEIdKey = mkPreludeMiscIdUnique 282 -unboxedSumEIdKey = mkPreludeMiscIdUnique 283 -condEIdKey = mkPreludeMiscIdUnique 284 -multiIfEIdKey = mkPreludeMiscIdUnique 285 -letEIdKey = mkPreludeMiscIdUnique 286 -caseEIdKey = mkPreludeMiscIdUnique 287 -doEIdKey = mkPreludeMiscIdUnique 288 -compEIdKey = mkPreludeMiscIdUnique 289 -fromEIdKey = mkPreludeMiscIdUnique 290 -fromThenEIdKey = mkPreludeMiscIdUnique 291 -fromToEIdKey = mkPreludeMiscIdUnique 292 -fromThenToEIdKey = mkPreludeMiscIdUnique 293 -listEIdKey = mkPreludeMiscIdUnique 294 -sigEIdKey = mkPreludeMiscIdUnique 295 -recConEIdKey = mkPreludeMiscIdUnique 296 -recUpdEIdKey = mkPreludeMiscIdUnique 297 -staticEIdKey = mkPreludeMiscIdUnique 298 -unboundVarEIdKey = mkPreludeMiscIdUnique 299 - --- type FieldExp = ... -fieldExpIdKey :: Unique -fieldExpIdKey = mkPreludeMiscIdUnique 305 - --- data Body = ... -guardedBIdKey, normalBIdKey :: Unique -guardedBIdKey = mkPreludeMiscIdUnique 306 -normalBIdKey = mkPreludeMiscIdUnique 307 - --- data Guard = ... -normalGEIdKey, patGEIdKey :: Unique -normalGEIdKey = mkPreludeMiscIdUnique 308 -patGEIdKey = mkPreludeMiscIdUnique 309 - --- data Stmt = ... -bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique -bindSIdKey = mkPreludeMiscIdUnique 310 -letSIdKey = mkPreludeMiscIdUnique 311 -noBindSIdKey = mkPreludeMiscIdUnique 312 -parSIdKey = mkPreludeMiscIdUnique 313 - --- data Dec = ... -funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, - instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, - pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, - pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, - openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey, - newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey, - infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey, - patSynSigDIdKey, pragCompleteDIdKey :: Unique -funDIdKey = mkPreludeMiscIdUnique 320 -valDIdKey = mkPreludeMiscIdUnique 321 -dataDIdKey = mkPreludeMiscIdUnique 322 -newtypeDIdKey = mkPreludeMiscIdUnique 323 -tySynDIdKey = mkPreludeMiscIdUnique 324 -classDIdKey = mkPreludeMiscIdUnique 325 -instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 326 -instanceDIdKey = mkPreludeMiscIdUnique 327 -sigDIdKey = mkPreludeMiscIdUnique 328 -forImpDIdKey = mkPreludeMiscIdUnique 329 -pragInlDIdKey = mkPreludeMiscIdUnique 330 -pragSpecDIdKey = mkPreludeMiscIdUnique 331 -pragSpecInlDIdKey = mkPreludeMiscIdUnique 332 -pragSpecInstDIdKey = mkPreludeMiscIdUnique 333 -pragRuleDIdKey = mkPreludeMiscIdUnique 334 -pragAnnDIdKey = mkPreludeMiscIdUnique 335 -dataFamilyDIdKey = mkPreludeMiscIdUnique 336 -openTypeFamilyDIdKey = mkPreludeMiscIdUnique 337 -dataInstDIdKey = mkPreludeMiscIdUnique 338 -newtypeInstDIdKey = mkPreludeMiscIdUnique 339 -tySynInstDIdKey = mkPreludeMiscIdUnique 340 -closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 341 -infixLDIdKey = mkPreludeMiscIdUnique 342 -infixRDIdKey = mkPreludeMiscIdUnique 343 -infixNDIdKey = mkPreludeMiscIdUnique 344 -roleAnnotDIdKey = mkPreludeMiscIdUnique 345 -standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346 -defaultSigDIdKey = mkPreludeMiscIdUnique 347 -patSynDIdKey = mkPreludeMiscIdUnique 348 -patSynSigDIdKey = mkPreludeMiscIdUnique 349 -pragCompleteDIdKey = mkPreludeMiscIdUnique 350 - --- type Cxt = ... -cxtIdKey :: Unique -cxtIdKey = mkPreludeMiscIdUnique 351 - --- data SourceUnpackedness = ... -noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique -noSourceUnpackednessKey = mkPreludeMiscIdUnique 352 -sourceNoUnpackKey = mkPreludeMiscIdUnique 353 -sourceUnpackKey = mkPreludeMiscIdUnique 354 - --- data SourceStrictness = ... -noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique -noSourceStrictnessKey = mkPreludeMiscIdUnique 355 -sourceLazyKey = mkPreludeMiscIdUnique 356 -sourceStrictKey = mkPreludeMiscIdUnique 357 - --- data Con = ... -normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey, - recGadtCIdKey :: Unique -normalCIdKey = mkPreludeMiscIdUnique 358 -recCIdKey = mkPreludeMiscIdUnique 359 -infixCIdKey = mkPreludeMiscIdUnique 360 -forallCIdKey = mkPreludeMiscIdUnique 361 -gadtCIdKey = mkPreludeMiscIdUnique 362 -recGadtCIdKey = mkPreludeMiscIdUnique 363 - --- data Bang = ... -bangIdKey :: Unique -bangIdKey = mkPreludeMiscIdUnique 364 - --- type BangType = ... -bangTKey :: Unique -bangTKey = mkPreludeMiscIdUnique 365 - --- type VarBangType = ... -varBangTKey :: Unique -varBangTKey = mkPreludeMiscIdUnique 366 - --- data PatSynDir = ... -unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique -unidirPatSynIdKey = mkPreludeMiscIdUnique 367 -implBidirPatSynIdKey = mkPreludeMiscIdUnique 368 -explBidirPatSynIdKey = mkPreludeMiscIdUnique 369 - --- data PatSynArgs = ... -prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique -prefixPatSynIdKey = mkPreludeMiscIdUnique 370 -infixPatSynIdKey = mkPreludeMiscIdUnique 371 -recordPatSynIdKey = mkPreludeMiscIdUnique 372 - --- data Type = ... -forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, - unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey, - equalityTIdKey, litTIdKey, promotedTIdKey, promotedTupleTIdKey, - promotedNilTIdKey, promotedConsTIdKey, wildCardTIdKey :: Unique -forallTIdKey = mkPreludeMiscIdUnique 381 -varTIdKey = mkPreludeMiscIdUnique 382 -conTIdKey = mkPreludeMiscIdUnique 383 -tupleTIdKey = mkPreludeMiscIdUnique 384 -unboxedTupleTIdKey = mkPreludeMiscIdUnique 385 -unboxedSumTIdKey = mkPreludeMiscIdUnique 386 -arrowTIdKey = mkPreludeMiscIdUnique 387 -listTIdKey = mkPreludeMiscIdUnique 388 -appTIdKey = mkPreludeMiscIdUnique 389 -sigTIdKey = mkPreludeMiscIdUnique 390 -equalityTIdKey = mkPreludeMiscIdUnique 391 -litTIdKey = mkPreludeMiscIdUnique 392 -promotedTIdKey = mkPreludeMiscIdUnique 393 -promotedTupleTIdKey = mkPreludeMiscIdUnique 394 -promotedNilTIdKey = mkPreludeMiscIdUnique 395 -promotedConsTIdKey = mkPreludeMiscIdUnique 396 -wildCardTIdKey = mkPreludeMiscIdUnique 397 - --- data TyLit = ... -numTyLitIdKey, strTyLitIdKey :: Unique -numTyLitIdKey = mkPreludeMiscIdUnique 400 -strTyLitIdKey = mkPreludeMiscIdUnique 401 - --- data TyVarBndr = ... -plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 402 -kindedTVIdKey = mkPreludeMiscIdUnique 403 - --- data Role = ... -nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique -nominalRIdKey = mkPreludeMiscIdUnique 404 -representationalRIdKey = mkPreludeMiscIdUnique 405 -phantomRIdKey = mkPreludeMiscIdUnique 406 -inferRIdKey = mkPreludeMiscIdUnique 407 - --- data Kind = ... -varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey, - starKIdKey, constraintKIdKey :: Unique -varKIdKey = mkPreludeMiscIdUnique 408 -conKIdKey = mkPreludeMiscIdUnique 409 -tupleKIdKey = mkPreludeMiscIdUnique 410 -arrowKIdKey = mkPreludeMiscIdUnique 411 -listKIdKey = mkPreludeMiscIdUnique 412 -appKIdKey = mkPreludeMiscIdUnique 413 -starKIdKey = mkPreludeMiscIdUnique 414 -constraintKIdKey = mkPreludeMiscIdUnique 415 - --- data FamilyResultSig = ... -noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique -noSigIdKey = mkPreludeMiscIdUnique 416 -kindSigIdKey = mkPreludeMiscIdUnique 417 -tyVarSigIdKey = mkPreludeMiscIdUnique 418 - --- data InjectivityAnn = ... -injectivityAnnIdKey :: Unique -injectivityAnnIdKey = mkPreludeMiscIdUnique 419 - --- data Callconv = ... -cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, - javaScriptCallIdKey :: Unique -cCallIdKey = mkPreludeMiscIdUnique 420 -stdCallIdKey = mkPreludeMiscIdUnique 421 -cApiCallIdKey = mkPreludeMiscIdUnique 422 -primCallIdKey = mkPreludeMiscIdUnique 423 -javaScriptCallIdKey = mkPreludeMiscIdUnique 424 - --- data Safety = ... -unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique -unsafeIdKey = mkPreludeMiscIdUnique 430 -safeIdKey = mkPreludeMiscIdUnique 431 -interruptibleIdKey = mkPreludeMiscIdUnique 432 - --- data FunDep = ... -funDepIdKey :: Unique -funDepIdKey = mkPreludeMiscIdUnique 440 - --- data FamFlavour = ... -typeFamIdKey, dataFamIdKey :: Unique -typeFamIdKey = mkPreludeMiscIdUnique 450 -dataFamIdKey = mkPreludeMiscIdUnique 451 - --- data TySynEqn = ... -tySynEqnIdKey :: Unique -tySynEqnIdKey = mkPreludeMiscIdUnique 460 - --- quasiquoting -quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 470 -quotePatKey = mkPreludeMiscIdUnique 471 -quoteDecKey = mkPreludeMiscIdUnique 472 -quoteTypeKey = mkPreludeMiscIdUnique 473 - --- data RuleBndr = ... -ruleVarIdKey, typedRuleVarIdKey :: Unique -ruleVarIdKey = mkPreludeMiscIdUnique 480 -typedRuleVarIdKey = mkPreludeMiscIdUnique 481 - --- data AnnTarget = ... -valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique -valueAnnotationIdKey = mkPreludeMiscIdUnique 490 -typeAnnotationIdKey = mkPreludeMiscIdUnique 491 -moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 - --- type DerivPred = ... -derivClauseIdKey :: Unique -derivClauseIdKey = mkPreludeMiscIdUnique 493 - -{- -************************************************************************ -* * - RdrNames -* * -************************************************************************ --} - -lift_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName -lift_RDR = nameRdrName liftName -mkNameG_dRDR = nameRdrName mkNameG_dName -mkNameG_vRDR = nameRdrName mkNameG_vName - --- data Exp = ... -conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName -conE_RDR = nameRdrName conEName -litE_RDR = nameRdrName litEName -appE_RDR = nameRdrName appEName -infixApp_RDR = nameRdrName infixAppName - --- data Lit = ... -stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR, - doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName -stringL_RDR = nameRdrName stringLName -intPrimL_RDR = nameRdrName intPrimLName -wordPrimL_RDR = nameRdrName wordPrimLName -floatPrimL_RDR = nameRdrName floatPrimLName -doublePrimL_RDR = nameRdrName doublePrimLName -stringPrimL_RDR = nameRdrName stringPrimLName -charPrimL_RDR = nameRdrName charPrimLName diff --git a/prelude/TysPrim.hs b/prelude/TysPrim.hs deleted file mode 100644 --- a/prelude/TysPrim.hs +++ /dev/null @@ -1,1003 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1994-1998 - - -\section[TysPrim]{Wired-in knowledge about primitive types} --} - -{-# LANGUAGE CPP #-} - --- | This module defines TyCons that can't be expressed in Haskell. --- They are all, therefore, wired-in TyCons. C.f module TysWiredIn -module TysPrim( - mkPrimTyConName, -- For implicit parameters in TysWiredIn only - - mkTemplateKindVars, mkTemplateTyVars, mkTemplateTyVarsFrom, - mkTemplateKiTyVars, - - mkTemplateTyConBinders, mkTemplateKindTyConBinders, - mkTemplateAnonTyConBinders, - - alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, - alphaTys, alphaTy, betaTy, gammaTy, deltaTy, - runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty, - openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, - - -- Kind constructors... - tYPETyCon, tYPETyConName, - - -- Kinds - tYPE, primRepToRuntimeRep, - - funTyCon, funTyConName, - primTyCons, - - charPrimTyCon, charPrimTy, charPrimTyConName, - intPrimTyCon, intPrimTy, intPrimTyConName, - wordPrimTyCon, wordPrimTy, wordPrimTyConName, - addrPrimTyCon, addrPrimTy, addrPrimTyConName, - floatPrimTyCon, floatPrimTy, floatPrimTyConName, - doublePrimTyCon, doublePrimTy, doublePrimTyConName, - - voidPrimTyCon, voidPrimTy, - statePrimTyCon, mkStatePrimTy, - realWorldTyCon, realWorldTy, realWorldStatePrimTy, - - proxyPrimTyCon, mkProxyPrimTy, - - arrayPrimTyCon, mkArrayPrimTy, - byteArrayPrimTyCon, byteArrayPrimTy, - arrayArrayPrimTyCon, mkArrayArrayPrimTy, - smallArrayPrimTyCon, mkSmallArrayPrimTy, - mutableArrayPrimTyCon, mkMutableArrayPrimTy, - mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy, - mutableArrayArrayPrimTyCon, mkMutableArrayArrayPrimTy, - smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy, - mutVarPrimTyCon, mkMutVarPrimTy, - - mVarPrimTyCon, mkMVarPrimTy, - tVarPrimTyCon, mkTVarPrimTy, - stablePtrPrimTyCon, mkStablePtrPrimTy, - stableNamePrimTyCon, mkStableNamePrimTy, - compactPrimTyCon, compactPrimTy, - bcoPrimTyCon, bcoPrimTy, - weakPrimTyCon, mkWeakPrimTy, - threadIdPrimTyCon, threadIdPrimTy, - - int32PrimTyCon, int32PrimTy, - word32PrimTyCon, word32PrimTy, - - int64PrimTyCon, int64PrimTy, - word64PrimTyCon, word64PrimTy, - - eqPrimTyCon, -- ty1 ~# ty2 - eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational) - eqPhantPrimTyCon, -- ty1 ~P# ty2 (at role Phantom) - - -- * SIMD -#include "primop-vector-tys-exports.hs-incl" - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TysWiredIn - ( runtimeRepTy, unboxedTupleKind, liftedTypeKind - , vecRepDataConTyCon, tupleRepDataConTyCon - , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy - , wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy - , floatRepDataConTy, doubleRepDataConTy - , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy - , vec64DataConTy - , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy - , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy - , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy - , doubleElemRepDataConTy - , mkPromotedListTy ) - -import Var ( TyVar, TyVarBndr(TvBndr), mkTyVar ) -import Name -import TyCon -import SrcLoc -import Unique -import PrelNames -import FastString -import Outputable -import TyCoRep -- Doesn't need special access, but this is easier to avoid - -- import loops which show up if you import Type instead - -import Data.Char - -{- -************************************************************************ -* * -\subsection{Primitive type constructors} -* * -************************************************************************ --} - -primTyCons :: [TyCon] -primTyCons - = [ addrPrimTyCon - , arrayPrimTyCon - , byteArrayPrimTyCon - , arrayArrayPrimTyCon - , smallArrayPrimTyCon - , charPrimTyCon - , doublePrimTyCon - , floatPrimTyCon - , intPrimTyCon - , int32PrimTyCon - , int64PrimTyCon - , bcoPrimTyCon - , weakPrimTyCon - , mutableArrayPrimTyCon - , mutableByteArrayPrimTyCon - , mutableArrayArrayPrimTyCon - , smallMutableArrayPrimTyCon - , mVarPrimTyCon - , tVarPrimTyCon - , mutVarPrimTyCon - , realWorldTyCon - , stablePtrPrimTyCon - , stableNamePrimTyCon - , compactPrimTyCon - , statePrimTyCon - , voidPrimTyCon - , proxyPrimTyCon - , threadIdPrimTyCon - , wordPrimTyCon - , word32PrimTyCon - , word64PrimTyCon - , eqPrimTyCon - , eqReprPrimTyCon - , eqPhantPrimTyCon - - , tYPETyCon - -#include "primop-vector-tycons.hs-incl" - ] - -mkPrimTc :: FastString -> Unique -> TyCon -> Name -mkPrimTc fs unique tycon - = mkWiredInName gHC_PRIM (mkTcOccFS fs) - unique - (ATyCon tycon) -- Relevant TyCon - UserSyntax - -mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name -mkBuiltInPrimTc fs unique tycon - = mkWiredInName gHC_PRIM (mkTcOccFS fs) - unique - (ATyCon tycon) -- Relevant TyCon - BuiltInSyntax - - -charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name -charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon -intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon -int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon -int64PrimTyConName = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon -wordPrimTyConName = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon -word32PrimTyConName = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon -word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon -addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon -floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon -doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon -statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon -voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon -proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon -eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon -eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon -eqPhantPrimTyConName = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKey eqPhantPrimTyCon -realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon -arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon -byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon -arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon -smallArrayPrimTyConName = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon -mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon -mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon -mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon -smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon -mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon -mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon -tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon -stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon -stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon -compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon -bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon -weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon -threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon - -{- -************************************************************************ -* * -\subsection{Support code} -* * -************************************************************************ - -alphaTyVars is a list of type variables for use in templates: - ["a", "b", ..., "z", "t1", "t2", ... ] --} - -mkTemplateKindVars :: [Kind] -> [TyVar] --- k0 with unique (mkAlphaTyVarUnique 0) --- k1 with unique (mkAlphaTyVarUnique 1) --- ... etc -mkTemplateKindVars kinds - = [ mkTyVar name kind - | (kind, u) <- kinds `zip` [0..] - , let occ = mkTyVarOccFS (mkFastString ('k' : show u)) - name = mkInternalName (mkAlphaTyVarUnique u) occ noSrcSpan - ] - -mkTemplateTyVarsFrom :: Int -> [Kind] -> [TyVar] --- a with unique (mkAlphaTyVarUnique n) --- b with unique (mkAlphaTyVarUnique n+1) --- ... etc --- Typically called as --- mkTemplateTyVarsFrom (legth kv_bndrs) kinds --- where kv_bndrs are the kind-level binders of a TyCon -mkTemplateTyVarsFrom n kinds - = [ mkTyVar name kind - | (kind, index) <- zip kinds [0..], - let ch_ord = index + ord 'a' - name_str | ch_ord <= ord 'z' = [chr ch_ord] - | otherwise = 't':show index - uniq = mkAlphaTyVarUnique (index + n) - name = mkInternalName uniq occ noSrcSpan - occ = mkTyVarOccFS (mkFastString name_str) - ] - -mkTemplateTyVars :: [Kind] -> [TyVar] -mkTemplateTyVars = mkTemplateTyVarsFrom 1 - -mkTemplateTyConBinders - :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars - -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] - -- same length as first arg - -- Result is anon arg kinds - -> [TyConBinder] -mkTemplateTyConBinders kind_var_kinds mk_anon_arg_kinds - = kv_bndrs ++ tv_bndrs - where - kv_bndrs = mkTemplateKindTyConBinders kind_var_kinds - anon_kinds = mk_anon_arg_kinds (mkTyVarTys (binderVars kv_bndrs)) - tv_bndrs = mkTemplateAnonTyConBindersFrom (length kv_bndrs) anon_kinds - -mkTemplateKiTyVars - :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars - -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] - -- same length as first arg - -- Result is anon arg kinds [ak1, .., akm] - -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] --- Example: if you want the tyvars for --- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah --- call mkTemplateKiTyVars [RuntimeRep] (\[r]. [TYPE r, *) -mkTemplateKiTyVars kind_var_kinds mk_arg_kinds - = kv_bndrs ++ tv_bndrs - where - kv_bndrs = mkTemplateKindVars kind_var_kinds - anon_kinds = mk_arg_kinds (mkTyVarTys kv_bndrs) - tv_bndrs = mkTemplateTyVarsFrom (length kv_bndrs) anon_kinds - -mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder] --- Makes named, Specified binders -mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds] - -mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder] -mkTemplateAnonTyConBinders kinds = map mkAnonTyConBinder (mkTemplateTyVars kinds) - -mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder] -mkTemplateAnonTyConBindersFrom n kinds = map mkAnonTyConBinder (mkTemplateTyVarsFrom n kinds) - -alphaTyVars :: [TyVar] -alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind - -alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar -(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars - -alphaTys :: [Type] -alphaTys = mkTyVarTys alphaTyVars -alphaTy, betaTy, gammaTy, deltaTy :: Type -(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys - -runtimeRep1TyVar, runtimeRep2TyVar :: TyVar -(runtimeRep1TyVar : runtimeRep2TyVar : _) - = drop 16 (mkTemplateTyVars (repeat runtimeRepTy)) -- selects 'q','r' - -runtimeRep1Ty, runtimeRep2Ty :: Type -runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar -runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar - -openAlphaTyVar, openBetaTyVar :: TyVar -[openAlphaTyVar,openBetaTyVar] - = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty] - -openAlphaTy, openBetaTy :: Type -openAlphaTy = mkTyVarTy openAlphaTyVar -openBetaTy = mkTyVarTy openBetaTyVar - -{- -************************************************************************ -* * - FunTyCon -* * -************************************************************************ --} - -funTyConName :: Name -funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon - --- | The @(->)@ type constructor. --- --- @ --- (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). --- TYPE rep1 -> TYPE rep2 -> * --- @ -funTyCon :: TyCon -funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm - where - tc_bndrs = [ TvBndr runtimeRep1TyVar (NamedTCB Inferred) - , TvBndr runtimeRep2TyVar (NamedTCB Inferred) - ] - ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty - , tYPE runtimeRep2Ty - ] - tc_rep_nm = mkPrelTyConRepName funTyConName - -{- -************************************************************************ -* * - Kinds -* * -************************************************************************ - -Note [TYPE and RuntimeRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -All types that classify values have a kind of the form (TYPE rr), where - - data RuntimeRep -- Defined in ghc-prim:GHC.Types - = LiftedRep - | UnliftedRep - | IntRep - | FloatRep - .. etc .. - - rr :: RuntimeRep - - TYPE :: RuntimeRep -> TYPE 'LiftedRep -- Built in - -So for example: - Int :: TYPE 'LiftedRep - Array# Int :: TYPE 'UnliftedRep - Int# :: TYPE 'IntRep - Float# :: TYPE 'FloatRep - Maybe :: TYPE 'LiftedRep -> TYPE 'LiftedRep - (# , #) :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2]) - -We abbreviate '*' specially: - type * = TYPE 'LiftedRep - -The 'rr' parameter tells us how the value is represented at runime. - -Generally speaking, you can't be polymorphic in 'rr'. E.g - f :: forall (rr:RuntimeRep) (a:TYPE rr). a -> [a] - f = /\(rr:RuntimeRep) (a:rr) \(a:rr). ... -This is no good: we could not generate code code for 'f', because the -calling convention for 'f' varies depending on whether the argument is -a a Int, Int#, or Float#. (You could imagine generating specialised -code, one for each instantiation of 'rr', but we don't do that.) - -Certain functions CAN be runtime-rep-polymorphic, because the code -generator never has to manipulate a value of type 'a :: TYPE rr'. - -* error :: forall (rr:RuntimeRep) (a:TYPE rr). String -> a - Code generator never has to manipulate the return value. - -* unsafeCoerce#, defined in MkId.unsafeCoerceId: - Always inlined to be a no-op - unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) - (a :: TYPE r1) (b :: TYPE r2). - a -> b - -* Unboxed tuples, and unboxed sums, defined in TysWiredIn - Always inlined, and hence specialised to the call site - (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) - (a :: TYPE r1) (b :: TYPE r2). - a -> b -> TYPE ('TupleRep '[r1, r2]) - -Note [PrimRep and kindPrimRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As part of its source code, in TyCon, GHC has - data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc... - -Notice that - * RuntimeRep is part of the syntax tree of the program being compiled - (defined in a library: ghc-prim:GHC.Types) - * PrimRep is part of GHC's source code. - (defined in TyCon) - -We need to get from one to the other; that is what kindPrimRep does. -Suppose we have a value - (v :: t) where (t :: k) -Given this kind - k = TyConApp "TYPE" [rep] -GHC needs to be able to figure out how 'v' is represented at runtime. -It expects 'rep' to be form - TyConApp rr_dc args -where 'rr_dc' is a promoteed data constructor from RuntimeRep. So -now we need to go from 'dc' to the corresponding PrimRep. We store this -PrimRep in the promoted data constructor itself: see TyCon.promDcRepInfo. - --} - -tYPETyCon :: TyCon -tYPETyConName :: Name - -tYPETyCon = mkKindTyCon tYPETyConName - (mkTemplateAnonTyConBinders [runtimeRepTy]) - liftedTypeKind - [Nominal] - (mkPrelTyConRepName tYPETyConName) - --------------------------- --- ... and now their names - --- If you edit these, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -tYPETyConName = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon - -mkPrimTyConName :: FastString -> Unique -> TyCon -> Name -mkPrimTyConName = mkPrimTcName BuiltInSyntax - -- All of the super kinds and kinds are defined in Prim, - -- and use BuiltInSyntax, because they are never in scope in the source - -mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name -mkPrimTcName built_in_syntax occ key tycon - = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax - ------------------------------ --- | Given a RuntimeRep, applies TYPE to it. --- see Note [TYPE and RuntimeRep] -tYPE :: Type -> Type -tYPE rr = TyConApp tYPETyCon [rr] - -{- -************************************************************************ -* * -\subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)} -* * -************************************************************************ --} - --- only used herein -pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon -pcPrimTyCon name roles rep - = mkPrimTyCon name binders result_kind roles - where - binders = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles) - result_kind = tYPE (primRepToRuntimeRep rep) - --- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep --- Defined here to avoid (more) module loops -primRepToRuntimeRep :: PrimRep -> Type -primRepToRuntimeRep rep = case rep of - VoidRep -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] - LiftedRep -> liftedRepDataConTy - UnliftedRep -> unliftedRepDataConTy - IntRep -> intRepDataConTy - WordRep -> wordRepDataConTy - Int64Rep -> int64RepDataConTy - Word64Rep -> word64RepDataConTy - AddrRep -> addrRepDataConTy - FloatRep -> floatRepDataConTy - DoubleRep -> doubleRepDataConTy - VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem'] - where - n' = case n of - 2 -> vec2DataConTy - 4 -> vec4DataConTy - 8 -> vec8DataConTy - 16 -> vec16DataConTy - 32 -> vec32DataConTy - 64 -> vec64DataConTy - _ -> pprPanic "Disallowed VecCount" (ppr n) - - elem' = case elem of - Int8ElemRep -> int8ElemRepDataConTy - Int16ElemRep -> int16ElemRepDataConTy - Int32ElemRep -> int32ElemRepDataConTy - Int64ElemRep -> int64ElemRepDataConTy - Word8ElemRep -> word8ElemRepDataConTy - Word16ElemRep -> word16ElemRepDataConTy - Word32ElemRep -> word32ElemRepDataConTy - Word64ElemRep -> word64ElemRepDataConTy - FloatElemRep -> floatElemRepDataConTy - DoubleElemRep -> doubleElemRepDataConTy - -pcPrimTyCon0 :: Name -> PrimRep -> TyCon -pcPrimTyCon0 name rep - = pcPrimTyCon name [] rep - -charPrimTy :: Type -charPrimTy = mkTyConTy charPrimTyCon -charPrimTyCon :: TyCon -charPrimTyCon = pcPrimTyCon0 charPrimTyConName WordRep - -intPrimTy :: Type -intPrimTy = mkTyConTy intPrimTyCon -intPrimTyCon :: TyCon -intPrimTyCon = pcPrimTyCon0 intPrimTyConName IntRep - -int32PrimTy :: Type -int32PrimTy = mkTyConTy int32PrimTyCon -int32PrimTyCon :: TyCon -int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName IntRep - -int64PrimTy :: Type -int64PrimTy = mkTyConTy int64PrimTyCon -int64PrimTyCon :: TyCon -int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName Int64Rep - -wordPrimTy :: Type -wordPrimTy = mkTyConTy wordPrimTyCon -wordPrimTyCon :: TyCon -wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName WordRep - -word32PrimTy :: Type -word32PrimTy = mkTyConTy word32PrimTyCon -word32PrimTyCon :: TyCon -word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName WordRep - -word64PrimTy :: Type -word64PrimTy = mkTyConTy word64PrimTyCon -word64PrimTyCon :: TyCon -word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep - -addrPrimTy :: Type -addrPrimTy = mkTyConTy addrPrimTyCon -addrPrimTyCon :: TyCon -addrPrimTyCon = pcPrimTyCon0 addrPrimTyConName AddrRep - -floatPrimTy :: Type -floatPrimTy = mkTyConTy floatPrimTyCon -floatPrimTyCon :: TyCon -floatPrimTyCon = pcPrimTyCon0 floatPrimTyConName FloatRep - -doublePrimTy :: Type -doublePrimTy = mkTyConTy doublePrimTyCon -doublePrimTyCon :: TyCon -doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep - -{- -************************************************************************ -* * -\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)} -* * -************************************************************************ - -Note [The equality types story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC sports a veritable menagerie of equality types: - - Hetero? Levity Result Role Defining module - ------------------------------------------------------------ - ~# hetero unlifted # nominal GHC.Prim - ~~ hetero lifted Constraint nominal GHC.Types - ~ homo lifted Constraint nominal Data.Type.Equality - :~: homo lifted * nominal Data.Type.Equality - - ~R# hetero unlifted # repr GHC.Prim - Coercible homo lifted Constraint repr GHC.Types - Coercion homo lifted * repr Data.Type.Coercion - - ~P# hetero unlifted phantom GHC.Prim - -Recall that "hetero" means the equality can related types of different -kinds. Knowing that (t1 ~# t2) or (t1 ~R# t2) or even that (t1 ~P# t2) -also means that (k1 ~# k2), where (t1 :: k1) and (t2 :: k2). - -To produce less confusion for end users, when not dumping and without --fprint-equality-relations, each of these groups is printed as the bottommost -listed equality. That is, (~#) and (~~) are both rendered as (~) in -error messages, and (~R#) is rendered as Coercible. - -Let's take these one at a time: - - -------------------------- - (~#) :: forall k1 k2. k1 -> k2 -> # - -------------------------- -This is The Type Of Equality in GHC. It classifies nominal coercions. -This type is used in the solver for recording equality constraints. -It responds "yes" to Type.isEqPred and classifies as an EqPred in -Type.classifyPredType. - -All wanted constraints of this type are built with coercion holes. -(See Note [Coercion holes] in TyCoRep.) But see also -Note [Deferred errors for coercion holes] in TcErrors to see how -equality constraints are deferred. - -Within GHC, ~# is called eqPrimTyCon, and it is defined in TysPrim. - - - -------------------------- - (~~) :: forall k1 k2. k1 -> k2 -> Constraint - -------------------------- -This is (almost) an ordinary class, defined as if by - class a ~# b => a ~~ b - instance a ~# b => a ~~ b -Here's what's unusual about it: - * We can't actually declare it that way because we don't have syntax for ~#. - And ~# isn't a constraint, so even if we could write it, it wouldn't kind - check. - - * Users cannot write instances of it. - - * It is "naturally coherent". This means that the solver won't hesitate to - solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the - context. (Normally, it waits to learn more, just in case the given - influences what happens next.) This is quite like having - IncoherentInstances enabled. - - * It always terminates. That is, in the UndecidableInstances checks, we - don't worry if a (~~) constraint is too big, as we know that solving - equality terminates. - -On the other hand, this behaves just like any class w.r.t. eager superclass -unpacking in the solver. So a lifted equality given quickly becomes an unlifted -equality given. This is good, because the solver knows all about unlifted -equalities. There is some special-casing in TcInteract.matchClassInst to -pretend that there is an instance of this class, as we can't write the instance -in Haskell. - -Within GHC, ~~ is called heqTyCon, and it is defined in TysWiredIn. - - - -------------------------- - (~) :: forall k. k -> k -> Constraint - -------------------------- -This is defined in Data.Type.Equality: - class a ~~ b => (a :: k) ~ (b :: k) - instance a ~~ b => a ~ b -This is even more so an ordinary class than (~~), with the following exceptions: - * Users cannot write instances of it. - - * It is "naturally coherent". (See (~~).) - - * (~) is magical syntax, as ~ is a reserved symbol. It cannot be exported - or imported. - - * It always terminates. - -Within GHC, ~ is called eqTyCon, and it is defined in PrelNames. Note that -it is *not* wired in. - - - -------------------------- - (:~:) :: forall k. k -> k -> * - -------------------------- -This is a perfectly ordinary GADT, wrapping (~). It is not defined within -GHC at all. - - - -------------------------- - (~R#) :: forall k1 k2. k1 -> k2 -> # - -------------------------- -The is the representational analogue of ~#. This is the type of representational -equalities that the solver works on. All wanted constraints of this type are -built with coercion holes. - -Within GHC, ~R# is called eqReprPrimTyCon, and it is defined in TysPrim. - - - -------------------------- - Coercible :: forall k. k -> k -> Constraint - -------------------------- -This is quite like (~~) in the way it's defined and treated within GHC, but -it's homogeneous. Homogeneity helps with type inference (as GHC can solve one -kind from the other) and, in my (Richard's) estimation, will be more intuitive -for users. - -An alternative design included HCoercible (like (~~)) and Coercible (like (~)). -One annoyance was that we want `coerce :: Coercible a b => a -> b`, and -we need the type of coerce to be fully wired-in. So the HCoercible/Coercible -split required that both types be fully wired-in. Instead of doing this, -I just got rid of HCoercible, as I'm not sure who would use it, anyway. - -Within GHC, Coercible is called coercibleTyCon, and it is defined in -TysWiredIn. - - - -------------------------- - Coercion :: forall k. k -> k -> * - -------------------------- -This is a perfectly ordinary GADT, wrapping Coercible. It is not defined -within GHC at all. - - - -------------------------- - (~P#) :: forall k1 k2. k1 -> k2 -> # - -------------------------- -This is the phantom analogue of ~# and it is barely used at all. -(The solver has no idea about this one.) Here is the motivation: - - data Phant a = MkPhant - type role Phant phantom - - Phant _P :: Phant Int ~P# Phant Bool - -We just need to have something to put on that last line. You probably -don't need to worry about it. - - - -Note [The State# TyCon] -~~~~~~~~~~~~~~~~~~~~~~~ -State# is the primitive, unlifted type of states. It has one type parameter, -thus - State# RealWorld -or - State# s - -where s is a type variable. The only purpose of the type parameter is to -keep different state threads separate. It is represented by nothing at all. - -The type parameter to State# is intended to keep separate threads separate. -Even though this parameter is not used in the definition of State#, it is -given role Nominal to enforce its intended use. --} - -mkStatePrimTy :: Type -> Type -mkStatePrimTy ty = TyConApp statePrimTyCon [ty] - -statePrimTyCon :: TyCon -- See Note [The State# TyCon] -statePrimTyCon = pcPrimTyCon statePrimTyConName [Nominal] VoidRep - -{- -RealWorld is deeply magical. It is *primitive*, but it is not -*unlifted* (hence ptrArg). We never manipulate values of type -RealWorld; it's only used in the type system, to parameterise State#. --} - -realWorldTyCon :: TyCon -realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName [] liftedTypeKind [] -realWorldTy :: Type -realWorldTy = mkTyConTy realWorldTyCon -realWorldStatePrimTy :: Type -realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld - --- Note: the ``state-pairing'' types are not truly primitive, --- so they are defined in \tr{TysWiredIn.hs}, not here. - - -voidPrimTy :: Type -voidPrimTy = TyConApp voidPrimTyCon [] - -voidPrimTyCon :: TyCon -voidPrimTyCon = pcPrimTyCon voidPrimTyConName [] VoidRep - -mkProxyPrimTy :: Type -> Type -> Type -mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] - -proxyPrimTyCon :: TyCon -proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Nominal] - where - -- Kind: forall k. k -> Void# - binders = mkTemplateTyConBinders [liftedTypeKind] (\ks-> ks) - res_kind = unboxedTupleKind [] - - -{- ********************************************************************* -* * - Primitive equality constraints - See Note [The equality types story] -* * -********************************************************************* -} - -eqPrimTyCon :: TyCon -- The representation type for equality predicates - -- See Note [The equality types story] -eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles - where - -- Kind :: forall k1 k2. k1 -> k2 -> Void# - binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks) - res_kind = unboxedTupleKind [] - roles = [Nominal, Nominal, Nominal, Nominal] - --- like eqPrimTyCon, but the type for *Representational* coercions --- this should only ever appear as the type of a covar. Its role is --- interpreted in coercionRole -eqReprPrimTyCon :: TyCon -- See Note [The equality types story] -eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles - where - -- Kind :: forall k1 k2. k1 -> k2 -> Void# - binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks) - res_kind = unboxedTupleKind [] - roles = [Nominal, Nominal, Representational, Representational] - --- like eqPrimTyCon, but the type for *Phantom* coercions. --- This is only used to make higher-order equalities. Nothing --- should ever actually have this type! -eqPhantPrimTyCon :: TyCon -eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles - where - -- Kind :: forall k1 k2. k1 -> k2 -> Void# - binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks) - res_kind = unboxedTupleKind [] - roles = [Nominal, Nominal, Phantom, Phantom] - -{- ********************************************************************* -* * - The primitive array types -* * -********************************************************************* -} - -arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon, - byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon, - smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon -arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] UnliftedRep -mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] UnliftedRep -mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] UnliftedRep -byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName UnliftedRep -arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName UnliftedRep -mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] UnliftedRep -smallArrayPrimTyCon = pcPrimTyCon smallArrayPrimTyConName [Representational] UnliftedRep -smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] UnliftedRep - -mkArrayPrimTy :: Type -> Type -mkArrayPrimTy elt = TyConApp arrayPrimTyCon [elt] -byteArrayPrimTy :: Type -byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon -mkArrayArrayPrimTy :: Type -mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon -mkSmallArrayPrimTy :: Type -> Type -mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [elt] -mkMutableArrayPrimTy :: Type -> Type -> Type -mkMutableArrayPrimTy s elt = TyConApp mutableArrayPrimTyCon [s, elt] -mkMutableByteArrayPrimTy :: Type -> Type -mkMutableByteArrayPrimTy s = TyConApp mutableByteArrayPrimTyCon [s] -mkMutableArrayArrayPrimTy :: Type -> Type -mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s] -mkSmallMutableArrayPrimTy :: Type -> Type -> Type -mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt] - - -{- ********************************************************************* -* * - The mutable variable type -* * -********************************************************************* -} - -mutVarPrimTyCon :: TyCon -mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] UnliftedRep - -mkMutVarPrimTy :: Type -> Type -> Type -mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] - -{- -************************************************************************ -* * -\subsection[TysPrim-synch-var]{The synchronizing variable type} -* * -************************************************************************ --} - -mVarPrimTyCon :: TyCon -mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] UnliftedRep - -mkMVarPrimTy :: Type -> Type -> Type -mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt] - -{- -************************************************************************ -* * -\subsection[TysPrim-stm-var]{The transactional variable type} -* * -************************************************************************ --} - -tVarPrimTyCon :: TyCon -tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] UnliftedRep - -mkTVarPrimTy :: Type -> Type -> Type -mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt] - -{- -************************************************************************ -* * -\subsection[TysPrim-stable-ptrs]{The stable-pointer type} -* * -************************************************************************ --} - -stablePtrPrimTyCon :: TyCon -stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep - -mkStablePtrPrimTy :: Type -> Type -mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty] - -{- -************************************************************************ -* * -\subsection[TysPrim-stable-names]{The stable-name type} -* * -************************************************************************ --} - -stableNamePrimTyCon :: TyCon -stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] UnliftedRep - -mkStableNamePrimTy :: Type -> Type -mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty] - -{- -************************************************************************ -* * -\subsection[TysPrim-compact-nfdata]{The Compact NFData (CNF) type} -* * -************************************************************************ --} - -compactPrimTyCon :: TyCon -compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep - -compactPrimTy :: Type -compactPrimTy = mkTyConTy compactPrimTyCon - -{- -************************************************************************ -* * -\subsection[TysPrim-BCOs]{The ``bytecode object'' type} -* * -************************************************************************ --} - -bcoPrimTy :: Type -bcoPrimTy = mkTyConTy bcoPrimTyCon -bcoPrimTyCon :: TyCon -bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep - -{- -************************************************************************ -* * -\subsection[TysPrim-Weak]{The ``weak pointer'' type} -* * -************************************************************************ --} - -weakPrimTyCon :: TyCon -weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] UnliftedRep - -mkWeakPrimTy :: Type -> Type -mkWeakPrimTy v = TyConApp weakPrimTyCon [v] - -{- -************************************************************************ -* * -\subsection[TysPrim-thread-ids]{The ``thread id'' type} -* * -************************************************************************ - -A thread id is represented by a pointer to the TSO itself, to ensure -that they are always unique and we can always find the TSO for a given -thread id. However, this has the unfortunate consequence that a -ThreadId# for a given thread is treated as a root by the garbage -collector and can keep TSOs around for too long. - -Hence the programmer API for thread manipulation uses a weak pointer -to the thread id internally. --} - -threadIdPrimTy :: Type -threadIdPrimTy = mkTyConTy threadIdPrimTyCon -threadIdPrimTyCon :: TyCon -threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName UnliftedRep - -{- -************************************************************************ -* * -\subsection{SIMD vector types} -* * -************************************************************************ --} - -#include "primop-vector-tys.hs-incl" diff --git a/prelude/TysWiredIn.hs b/prelude/TysWiredIn.hs deleted file mode 100644 --- a/prelude/TysWiredIn.hs +++ /dev/null @@ -1,1653 +0,0 @@ -{- -(c) The GRASP Project, Glasgow University, 1994-1998 - -\section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - --- | This module is about types that can be defined in Haskell, but which --- must be wired into the compiler nonetheless. C.f module TysPrim -module TysWiredIn ( - -- * Helper functions defined here - mkWiredInTyConName, -- This is used in TcTypeNats to define the - -- built-in functions for evaluation. - - mkWiredInIdName, -- used in MkId - - mkFunKind, mkForAllKind, - - -- * All wired in things - wiredInTyCons, isBuiltInOcc_maybe, - - -- * Bool - boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, - trueDataCon, trueDataConId, true_RDR, - falseDataCon, falseDataConId, false_RDR, - promotedFalseDataCon, promotedTrueDataCon, - - -- * Ordering - orderingTyCon, - ltDataCon, ltDataConId, - eqDataCon, eqDataConId, - gtDataCon, gtDataConId, - promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, - - -- * Boxing primitive types - boxingDataCon_maybe, - - -- * Char - charTyCon, charDataCon, charTyCon_RDR, - charTy, stringTy, charTyConName, - - -- * Double - doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, - - -- * Float - floatTyCon, floatDataCon, floatTy, floatTyConName, - - -- * Int - intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, - intTy, - - -- * Word - wordTyCon, wordDataCon, wordTyConName, wordTy, - - -- * Word8 - word8TyCon, word8DataCon, word8TyConName, word8Ty, - - -- * List - listTyCon, listTyCon_RDR, listTyConName, listTyConKey, - nilDataCon, nilDataConName, nilDataConKey, - consDataCon_RDR, consDataCon, consDataConName, - promotedNilDataCon, promotedConsDataCon, - mkListTy, mkPromotedListTy, - - -- * Maybe - maybeTyCon, maybeTyConName, - nothingDataCon, nothingDataConName, promotedNothingDataCon, - justDataCon, justDataConName, promotedJustDataCon, - - -- * Tuples - mkTupleTy, mkBoxedTupleTy, - tupleTyCon, tupleDataCon, tupleTyConName, - promotedTupleDataCon, - unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, - pairTyCon, - unboxedUnitTyCon, unboxedUnitDataCon, - unboxedTupleKind, unboxedSumKind, - - -- ** Constraint tuples - cTupleTyConName, cTupleTyConNames, isCTupleTyConName, - cTupleDataConName, cTupleDataConNames, - - -- * Any - anyTyCon, anyTy, anyTypeOfKind, - - -- * Sums - mkSumTy, sumTyCon, sumDataCon, - - -- * Kinds - typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, - isLiftedTypeKindTyConName, liftedTypeKind, constraintKind, - starKindTyCon, starKindTyConName, - unicodeStarKindTyCon, unicodeStarKindTyConName, - liftedTypeKindTyCon, constraintKindTyCon, - - -- * Parallel arrays - mkPArrTy, - parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, - parrTyCon_RDR, parrTyConName, - - -- * Equality predicates - heqTyCon, heqClass, heqDataCon, - coercibleTyCon, coercibleDataCon, coercibleClass, - - -- * RuntimeRep and friends - runtimeRepTyCon, vecCountTyCon, vecElemTyCon, - - runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon, - - vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, - - liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, - wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy, - - vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, - vec64DataConTy, - - int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, - int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, - word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - doubleElemRepDataConTy - - ) where - -#include "HsVersions.h" -#include "MachDeps.h" - -import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId ) - --- friends: -import PrelNames -import TysPrim -import {-# SOURCE #-} KnownUniques - --- others: -import CoAxiom -import Id -import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) -import Module ( Module ) -import Type -import RepType -import DataCon -import {-# SOURCE #-} ConLike -import TyCon -import Class ( Class, mkClass ) -import RdrName -import Name -import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv ) -import NameSet ( NameSet, mkNameSet, elemNameSet ) -import BasicTypes ( Arity, Boxity(..), TupleSort(..), ConTagZ, - SourceText(..) ) -import ForeignCall -import SrcLoc ( noSrcSpan ) -import Unique -import Data.Array -import FastString -import Outputable -import Util -import BooleanFormula ( mkAnd ) - -import qualified Data.ByteString.Char8 as BS -#if !MIN_VERSION_bytestring(0,10,8) -import qualified Data.ByteString.Internal as BSI -import qualified Data.ByteString.Unsafe as BSU -#endif - -alpha_tyvar :: [TyVar] -alpha_tyvar = [alphaTyVar] - -alpha_ty :: [Type] -alpha_ty = [alphaTy] - -{- -Note [Wiring in RuntimeRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors, -making it a pain to wire in. To ease the pain somewhat, we use lists of -the different bits, like Uniques, Names, DataCons. These lists must be -kept in sync with each other. The rule is this: use the order as declared -in GHC.Types. All places where such lists exist should contain a reference -to this Note, so a search for this Note's name should find all the lists. - -************************************************************************ -* * -\subsection{Wired in type constructors} -* * -************************************************************************ - -If you change which things are wired in, make sure you change their -names in PrelNames, so they use wTcQual, wDataQual, etc --} - --- This list is used only to define PrelInfo.wiredInThings. That in turn --- is used to initialise the name environment carried around by the renamer. --- This means that if we look up the name of a TyCon (or its implicit binders) --- that occurs in this list that name will be assigned the wired-in key we --- define here. --- --- Because of their infinite nature, this list excludes tuples, Any and implicit --- parameter TyCons (see Note [Built-in syntax and the OrigNameCache]). --- --- See also Note [Known-key names] -wiredInTyCons :: [TyCon] - -wiredInTyCons = [ -- Units are not treated like other tuples, because then - -- are defined in GHC.Base, and there's only a few of them. We - -- put them in wiredInTyCons so that they will pre-populate - -- the name cache, so the parser in isBuiltInOcc_maybe doesn't - -- need to look out for them. - unitTyCon - , unboxedUnitTyCon - , anyTyCon - , boolTyCon - , charTyCon - , doubleTyCon - , floatTyCon - , intTyCon - , wordTyCon - , word8TyCon - , listTyCon - , maybeTyCon - , parrTyCon - , heqTyCon - , coercibleTyCon - , typeNatKindCon - , typeSymbolKindCon - , runtimeRepTyCon - , vecCountTyCon - , vecElemTyCon - , constraintKindTyCon - , liftedTypeKindTyCon - , starKindTyCon - , unicodeStarKindTyCon - ] - -mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name -mkWiredInTyConName built_in modu fs unique tycon - = mkWiredInName modu (mkTcOccFS fs) unique - (ATyCon tycon) -- Relevant TyCon - built_in - -mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name -mkWiredInDataConName built_in modu fs unique datacon - = mkWiredInName modu (mkDataOccFS fs) unique - (AConLike (RealDataCon datacon)) -- Relevant DataCon - built_in - -mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name -mkWiredInIdName mod fs uniq id - = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax - --- See Note [Kind-changing of (~) and Coercible] --- in libraries/ghc-prim/GHC/Types.hs -heqTyConName, heqDataConName, heqSCSelIdName :: Name -heqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~~") heqTyConKey heqTyCon -heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") heqDataConKey heqDataCon -heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "HEq_sc") heqSCSelIdKey heqSCSelId - --- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs -coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name -coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon -coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon -coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "Coercible_sc") coercibleSCSelIdKey coercibleSCSelId - -charTyConName, charDataConName, intTyConName, intDataConName :: Name -charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon -charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon -intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon -intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon - -boolTyConName, falseDataConName, trueDataConName :: Name -boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon -falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon -trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon - -listTyConName, nilDataConName, consDataConName :: Name -listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon -nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon -consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon - -maybeTyConName, nothingDataConName, justDataConName :: Name -maybeTyConName = mkWiredInTyConName UserSyntax gHC_BASE (fsLit "Maybe") - maybeTyConKey maybeTyCon -nothingDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Nothing") - nothingDataConKey nothingDataCon -justDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Just") - justDataConKey justDataCon - -wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name -wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon -wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon -word8TyConName = mkWiredInTyConName UserSyntax gHC_WORD (fsLit "Word8") word8TyConKey word8TyCon -word8DataConName = mkWiredInDataConName UserSyntax gHC_WORD (fsLit "W8#") word8DataConKey word8DataCon - -floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name -floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon -floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon -doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon -doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon - --- Any - -{- -Note [Any types] -~~~~~~~~~~~~~~~~ -The type constructor Any, - - type family Any :: k where { } - -It has these properties: - - * Note that 'Any' is kind polymorphic since in some program we may - need to use Any to fill in a type variable of some kind other than * - (see #959 for examples). Its kind is thus `forall k. k``. - - * It is defined in module GHC.Types, and exported so that it is - available to users. For this reason it's treated like any other - wired-in type: - - has a fixed unique, anyTyConKey, - - lives in the global name cache - - * It is a *closed* type family, with no instances. This means that - if ty :: '(k1, k2) we add a given coercion - g :: ty ~ (Fst ty, Snd ty) - If Any was a *data* type, then we'd get inconsistency because 'ty' - could be (Any '(k1,k2)) and then we'd have an equality with Any on - one side and '(,) on the other. See also #9097 and #9636. - - * When instantiated at a lifted type it is inhabited by at least one value, - namely bottom - - * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce. - - * It does not claim to be a *data* type, and that's important for - the code generator, because the code gen may *enter* a data value - but never enters a function value. - - * It is wired-in so we can easily refer to it where we don't have a name - environment (e.g. see Rules.matchRule for one example) - - * If (Any k) is the type of a value, it must be a /lifted/ value. So - if we have (Any @(TYPE rr)) then rr must be 'LiftedRep. See - Note [TYPE and RuntimeRep] in TysPrim. This is a convenient - invariant, and makes isUnliftedTyCon well-defined; otherwise what - would (isUnliftedTyCon Any) be? - -It's used to instantiate un-constrained type variables after type checking. For -example, 'length' has type - - length :: forall a. [a] -> Int - -and the list datacon for the empty list has type - - [] :: forall a. [a] - -In order to compose these two terms as @length []@ a type -application is required, but there is no constraint on the -choice. In this situation GHC uses 'Any', - -> length (Any *) ([] (Any *)) - -Above, we print kinds explicitly, as if with --fprint-explicit-kinds. - -The Any tycon used to be quite magic, but we have since been able to -implement it merely with an empty kind polymorphic type family. See #10886 for a -bit of history. --} - - -anyTyConName :: Name -anyTyConName = - mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon - -anyTyCon :: TyCon -anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing - (ClosedSynFamilyTyCon Nothing) - Nothing - NotInjective - where - binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind] - res_kind = mkTyVarTy (binderVar kv) - -anyTy :: Type -anyTy = mkTyConTy anyTyCon - -anyTypeOfKind :: Kind -> Type -anyTypeOfKind kind = mkTyConApp anyTyCon [kind] - --- Kinds -typeNatKindConName, typeSymbolKindConName :: Name -typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Nat") typeNatKindConNameKey typeNatKindCon -typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon - -constraintKindTyConName :: Name -constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon - -liftedTypeKindTyConName, starKindTyConName, unicodeStarKindTyConName - :: Name -liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon -starKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "*") starKindTyConKey starKindTyCon -unicodeStarKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "★") unicodeStarKindTyConKey unicodeStarKindTyCon - -runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name -runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon -vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon -tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon -sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon - --- See Note [Wiring in RuntimeRep] -runtimeRepSimpleDataConNames :: [Name] -runtimeRepSimpleDataConNames - = zipWith3Lazy mk_special_dc_name - [ fsLit "LiftedRep", fsLit "UnliftedRep" - , fsLit "IntRep" - , fsLit "WordRep", fsLit "Int64Rep", fsLit "Word64Rep" - , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep" ] - runtimeRepSimpleDataConKeys - runtimeRepSimpleDataCons - -vecCountTyConName :: Name -vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon - --- See Note [Wiring in RuntimeRep] -vecCountDataConNames :: [Name] -vecCountDataConNames = zipWith3Lazy mk_special_dc_name - [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8" - , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ] - vecCountDataConKeys - vecCountDataCons - -vecElemTyConName :: Name -vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon - --- See Note [Wiring in RuntimeRep] -vecElemDataConNames :: [Name] -vecElemDataConNames = zipWith3Lazy mk_special_dc_name - [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep" - , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep" - , fsLit "Word32ElemRep", fsLit "Word64ElemRep" - , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] - vecElemDataConKeys - vecElemDataCons - -mk_special_dc_name :: FastString -> Unique -> DataCon -> Name -mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc - -parrTyConName, parrDataConName :: Name -parrTyConName = mkWiredInTyConName BuiltInSyntax - gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon -parrDataConName = mkWiredInDataConName UserSyntax - gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon - -boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, - intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR :: RdrName -boolTyCon_RDR = nameRdrName boolTyConName -false_RDR = nameRdrName falseDataConName -true_RDR = nameRdrName trueDataConName -intTyCon_RDR = nameRdrName intTyConName -charTyCon_RDR = nameRdrName charTyConName -intDataCon_RDR = nameRdrName intDataConName -listTyCon_RDR = nameRdrName listTyConName -consDataCon_RDR = nameRdrName consDataConName -parrTyCon_RDR = nameRdrName parrTyConName - -{- -************************************************************************ -* * -\subsection{mkWiredInTyCon} -* * -************************************************************************ --} - -pcNonEnumTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon --- Not an enumeration -pcNonEnumTyCon = pcTyCon False - --- This function assumes that the types it creates have all parameters at --- Representational role, and that there is no kind polymorphism. -pcTyCon :: Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon -pcTyCon is_enum name cType tyvars cons - = mkAlgTyCon name - (mkAnonTyConBinders tyvars) - liftedTypeKind - (map (const Representational) tyvars) - cType - [] -- No stupid theta - (DataTyCon cons is_enum) - (VanillaAlgTyCon (mkPrelTyConRepName name)) - False -- Not in GADT syntax - -pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon -pcDataCon n univs = pcDataConWithFixity False n univs [] -- no ex_tvs - -pcDataConWithFixity :: Bool -- ^ declared infix? - -> Name -- ^ datacon name - -> [TyVar] -- ^ univ tyvars - -> [TyVar] -- ^ ex tyvars - -> [Type] -- ^ args - -> TyCon - -> DataCon -pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (nameUnique n)) - NoRRI --- The Name's unique is the first of two free uniques; --- the first is used for the datacon itself, --- the second is used for the "worker name" --- --- To support this the mkPreludeDataConUnique function "allocates" --- one DataCon unique per pair of Ints. - -pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo - -> [TyVar] -> [TyVar] - -> [Type] -> TyCon -> DataCon --- The Name should be in the DataName name space; it's the name --- of the DataCon itself. - -pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys tycon - = data_con - where - data_con = mkDataCon dc_name declared_infix prom_info - (map (const no_bang) arg_tys) - [] -- No labelled fields - (mkTyVarBinders Specified tyvars) - (mkTyVarBinders Specified ex_tyvars) - [] -- No equality spec - [] -- No theta - arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) - rri - tycon - [] -- No stupid theta - (mkDataConWorkId wrk_name data_con) - NoDataConRep -- Wired-in types are too simple to need wrappers - - no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict - - wrk_name = mkDataConWorkerName data_con wrk_key - - prom_info = mkPrelTyConRepName dc_name - -mkDataConWorkerName :: DataCon -> Unique -> Name -mkDataConWorkerName data_con wrk_key = - mkWiredInName modu wrk_occ wrk_key - (AnId (dataConWorkId data_con)) UserSyntax - where - modu = ASSERT( isExternalName dc_name ) - nameModule dc_name - dc_name = dataConName data_con - dc_occ = nameOccName dc_name - wrk_occ = mkDataConWorkerOcc dc_occ - --- used for RuntimeRep and friends -pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon -pcSpecialDataCon dc_name arg_tys tycon rri - = pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri - [] [] arg_tys tycon - -{- -************************************************************************ -* * - Kinds -* * -************************************************************************ --} - -typeNatKindCon, typeSymbolKindCon :: TyCon --- data Nat --- data Symbol -typeNatKindCon = pcTyCon False typeNatKindConName Nothing [] [] -typeSymbolKindCon = pcTyCon False typeSymbolKindConName Nothing [] [] - -typeNatKind, typeSymbolKind :: Kind -typeNatKind = mkTyConTy typeNatKindCon -typeSymbolKind = mkTyConTy typeSymbolKindCon - -constraintKindTyCon :: TyCon -constraintKindTyCon = pcTyCon False constraintKindTyConName - Nothing [] [] - -liftedTypeKind, constraintKind :: Kind -liftedTypeKind = tYPE liftedRepTy -constraintKind = mkTyConApp constraintKindTyCon [] - --- mkFunKind and mkForAllKind are defined here --- solely so that TyCon can use them via a SOURCE import -mkFunKind :: Kind -> Kind -> Kind -mkFunKind = mkFunTy - -mkForAllKind :: TyVar -> ArgFlag -> Kind -> Kind -mkForAllKind = mkForAllTy - -{- -************************************************************************ -* * - Stuff for dealing with tuples -* * -************************************************************************ - -Note [How tuples work] See also Note [Known-key names] in PrelNames -~~~~~~~~~~~~~~~~~~~~~~ -* There are three families of tuple TyCons and corresponding - DataCons, expressed by the type BasicTypes.TupleSort: - data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple - -* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon - -* BoxedTuples - - A wired-in type - - Data type declarations in GHC.Tuple - - The data constructors really have an info table - -* UnboxedTuples - - A wired-in type - - Have a pretend DataCon, defined in GHC.Prim, - but no actual declaration and no info table - -* ConstraintTuples - - Are known-key rather than wired-in. Reason: it's awkward to - have all the superclass selectors wired-in. - - Declared as classes in GHC.Classes, e.g. - class (c1,c2) => (c1,c2) - - Given constraints: the superclasses automatically become available - - Wanted constraints: there is a built-in instance - instance (c1,c2) => (c1,c2) - See TcInteract.matchCTuple - - Currently just go up to 62; beyond that - you have to use manual nesting - - Their OccNames look like (%,,,%), so they can easily be - distinguished from term tuples. But (following Haskell) we - pretty-print saturated constraint tuples with round parens; - see BasicTypes.tupleParens. - -* In quite a lot of places things are restrcted just to - BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish - E.g. tupleTyCon has a Boxity argument - -* When looking up an OccName in the original-name cache - (IfaceEnv.lookupOrigNameCache), we spot the tuple OccName to make sure - we get the right wired-in name. This guy can't tell the difference - between BoxedTuple and ConstraintTuple (same OccName!), so tuples - are not serialised into interface files using OccNames at all. - -* Serialization to interface files works via the usual mechanism for known-key - things: instead of serializing the OccName we just serialize the key. During - deserialization we lookup the Name associated with the unique with the logic - in KnownUniques. See Note [Symbol table representation of names] for details. - -Note [One-tuples] -~~~~~~~~~~~~~~~~~ -GHC supports both boxed and unboxed one-tuples: - - Unboxed one-tuples are sometimes useful when returning a - single value after CPR analysis - - A boxed one-tuple is used by DsUtils.mkSelectorBinds, when - there is just one binder -Basically it keeps everythig uniform. - -However the /naming/ of the type/data constructors for one-tuples is a -bit odd: - 3-tuples: (,,) (,,)# - 2-tuples: (,) (,)# - 1-tuples: ?? - 0-tuples: () ()# - -Zero-tuples have used up the logical name. So we use 'Unit' and 'Unit#' -for one-tuples. So in ghc-prim:GHC.Tuple we see the declarations: - data () = () - data Unit a = Unit a - data (a,b) = (a,b) - -NB (Feb 16): for /constraint/ one-tuples I have 'Unit%' but no class -decl in GHC.Classes, so I think this part may not work properly. But -it's unused I think. --} - --- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names --- with BuiltInSyntax. However, this should only be necessary while resolving --- names produced by Template Haskell splices since we take care to encode --- built-in syntax names specially in interface files. See --- Note [Symbol table representation of names]. --- --- Moreover, there is no need to include names of things that the user can't --- write (e.g. type representation bindings like $tc(,,,)). -isBuiltInOcc_maybe :: OccName -> Maybe Name -isBuiltInOcc_maybe occ = - case name of - "[]" -> Just $ choose_ns listTyConName nilDataConName - ":" -> Just consDataConName - - "[::]" -> Just parrTyConName - - -- boxed tuple data/tycon - "()" -> Just $ tup_name Boxed 0 - _ | Just rest <- "(" `stripPrefix` name - , (commas, rest') <- BS.span (==',') rest - , ")" <- rest' - -> Just $ tup_name Boxed (1+BS.length commas) - - -- unboxed tuple data/tycon - "(##)" -> Just $ tup_name Unboxed 0 - "Unit#" -> Just $ tup_name Unboxed 1 - _ | Just rest <- "(#" `stripPrefix` name - , (commas, rest') <- BS.span (==',') rest - , "#)" <- rest' - -> Just $ tup_name Unboxed (1+BS.length commas) - - -- unboxed sum tycon - _ | Just rest <- "(#" `stripPrefix` name - , (pipes, rest') <- BS.span (=='|') rest - , "#)" <- rest' - -> Just $ tyConName $ sumTyCon (1+BS.length pipes) - - -- unboxed sum datacon - _ | Just rest <- "(#" `stripPrefix` name - , (pipes1, rest') <- BS.span (=='|') rest - , Just rest'' <- "_" `stripPrefix` rest' - , (pipes2, rest''') <- BS.span (=='|') rest'' - , "#)" <- rest''' - -> let arity = BS.length pipes1 + BS.length pipes2 + 1 - alt = BS.length pipes1 + 1 - in Just $ dataConName $ sumDataCon alt arity - _ -> Nothing - where - -- TODO: Drop when bytestring 0.10.8 can be assumed -#if MIN_VERSION_bytestring(0,10,8) - stripPrefix = BS.stripPrefix -#else - stripPrefix bs1@(BSI.PS _ _ l1) bs2 - | bs1 `BS.isPrefixOf` bs2 = Just (BSU.unsafeDrop l1 bs2) - | otherwise = Nothing -#endif - - name = fastStringToByteString $ occNameFS occ - - choose_ns :: Name -> Name -> Name - choose_ns tc dc - | isTcClsNameSpace ns = tc - | isDataConNameSpace ns = dc - | otherwise = pprPanic "tup_name" (ppr occ) - where ns = occNameSpace occ - - tup_name boxity arity - = choose_ns (getName (tupleTyCon boxity arity)) - (getName (tupleDataCon boxity arity)) - -mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName --- No need to cache these, the caching is done in mk_tuple -mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ar) -mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar) - -mkCTupleOcc :: NameSpace -> Arity -> OccName -mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) - -mkBoxedTupleStr :: Arity -> String -mkBoxedTupleStr 0 = "()" -mkBoxedTupleStr 1 = "Unit" -- See Note [One-tuples] -mkBoxedTupleStr ar = '(' : commas ar ++ ")" - -mkUnboxedTupleStr :: Arity -> String -mkUnboxedTupleStr 0 = "(##)" -mkUnboxedTupleStr 1 = "Unit#" -- See Note [One-tuples] -mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)" - -mkConstraintTupleStr :: Arity -> String -mkConstraintTupleStr 0 = "(%%)" -mkConstraintTupleStr 1 = "Unit%" -- See Note [One-tuples] -mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)" - -commas :: Arity -> String -commas ar = take (ar-1) (repeat ',') - -cTupleTyConName :: Arity -> Name -cTupleTyConName arity - = mkExternalName (mkCTupleTyConUnique arity) gHC_CLASSES - (mkCTupleOcc tcName arity) noSrcSpan - -cTupleTyConNames :: [Name] -cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE]) - -cTupleTyConNameSet :: NameSet -cTupleTyConNameSet = mkNameSet cTupleTyConNames - -isCTupleTyConName :: Name -> Bool --- Use Type.isCTupleClass where possible -isCTupleTyConName n - = ASSERT2( isExternalName n, ppr n ) - nameModule n == gHC_CLASSES - && n `elemNameSet` cTupleTyConNameSet - -cTupleDataConName :: Arity -> Name -cTupleDataConName arity - = mkExternalName (mkCTupleDataConUnique arity) gHC_CLASSES - (mkCTupleOcc dataName arity) noSrcSpan - -cTupleDataConNames :: [Name] -cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE]) - -tupleTyCon :: Boxity -> Arity -> TyCon -tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially -tupleTyCon Boxed i = fst (boxedTupleArr ! i) -tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) - -tupleTyConName :: TupleSort -> Arity -> Name -tupleTyConName ConstraintTuple a = cTupleTyConName a -tupleTyConName BoxedTuple a = tyConName (tupleTyCon Boxed a) -tupleTyConName UnboxedTuple a = tyConName (tupleTyCon Unboxed a) - -promotedTupleDataCon :: Boxity -> Arity -> TyCon -promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i) - -tupleDataCon :: Boxity -> Arity -> DataCon -tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially -tupleDataCon Boxed i = snd (boxedTupleArr ! i) -tupleDataCon Unboxed i = snd (unboxedTupleArr ! i) - -boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) -boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] -unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] - --- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed --- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type --- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep --- [IntRep, LiftedRep])@ -unboxedTupleSumKind :: TyCon -> [Type] -> Kind -unboxedTupleSumKind tc rr_tys - = tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) - --- | Specialization of 'unboxedTupleSumKind' for tuples -unboxedTupleKind :: [Type] -> Kind -unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon - -mk_tuple :: Boxity -> Int -> (TyCon,DataCon) -mk_tuple Boxed arity = (tycon, tuple_con) - where - tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con - BoxedTuple flavour - - tc_binders = mkTemplateAnonTyConBinders (nOfThem arity liftedTypeKind) - tc_res_kind = liftedTypeKind - tc_arity = arity - flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) - - dc_tvs = binderVars tc_binders - dc_arg_tys = mkTyVarTys dc_tvs - tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon - - boxity = Boxed - modu = gHC_TUPLE - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq - (ATyCon tycon) BuiltInSyntax - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax - tc_uniq = mkTupleTyConUnique boxity arity - dc_uniq = mkTupleDataConUnique boxity arity - -mk_tuple Unboxed arity = (tycon, tuple_con) - where - tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con - UnboxedTuple flavour - - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> # - tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy) - (\ks -> map tYPE ks) - - tc_res_kind = unboxedTupleKind rr_tys - - tc_arity = arity * 2 - flavour = UnboxedAlgTyCon $ Just (mkPrelTyConRepName tc_name) - - dc_tvs = binderVars tc_binders - (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs) - tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon - - boxity = Unboxed - modu = gHC_PRIM - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq - (ATyCon tycon) BuiltInSyntax - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax - tc_uniq = mkTupleTyConUnique boxity arity - dc_uniq = mkTupleDataConUnique boxity arity - -unitTyCon :: TyCon -unitTyCon = tupleTyCon Boxed 0 - -unitTyConKey :: Unique -unitTyConKey = getUnique unitTyCon - -unitDataCon :: DataCon -unitDataCon = head (tyConDataCons unitTyCon) - -unitDataConId :: Id -unitDataConId = dataConWorkId unitDataCon - -pairTyCon :: TyCon -pairTyCon = tupleTyCon Boxed 2 - -unboxedUnitTyCon :: TyCon -unboxedUnitTyCon = tupleTyCon Unboxed 0 - -unboxedUnitDataCon :: DataCon -unboxedUnitDataCon = tupleDataCon Unboxed 0 - - -{- ********************************************************************* -* * - Unboxed sums -* * -********************************************************************* -} - --- | OccName for n-ary unboxed sum type constructor. -mkSumTyConOcc :: Arity -> OccName -mkSumTyConOcc n = mkOccName tcName str - where - -- No need to cache these, the caching is done in mk_sum - str = '(' : '#' : bars ++ "#)" - bars = replicate (n-1) '|' - --- | OccName for i-th alternative of n-ary unboxed sum data constructor. -mkSumDataConOcc :: ConTag -> Arity -> OccName -mkSumDataConOcc alt n = mkOccName dataName str - where - -- No need to cache these, the caching is done in mk_sum - str = '(' : '#' : bars alt ++ '_' : bars (n - alt - 1) ++ "#)" - bars i = replicate i '|' - --- | Type constructor for n-ary unboxed sum. -sumTyCon :: Arity -> TyCon -sumTyCon arity - | arity > mAX_SUM_SIZE - = fst (mk_sum arity) -- Build one specially - - | arity < 2 - = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")") - - | otherwise - = fst (unboxedSumArr ! arity) - --- | Data constructor for i-th alternative of a n-ary unboxed sum. -sumDataCon :: ConTag -- Alternative - -> Arity -- Arity - -> DataCon -sumDataCon alt arity - | alt > arity - = panic ("sumDataCon: index out of bounds: alt: " - ++ show alt ++ " > arity " ++ show arity) - - | alt <= 0 - = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt - ++ ", arity: " ++ show arity ++ ")") - - | arity < 2 - = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt - ++ ", arity: " ++ show arity ++ ")") - - | arity > mAX_SUM_SIZE - = snd (mk_sum arity) ! (alt - 1) -- Build one specially - - | otherwise - = snd (unboxedSumArr ! arity) ! (alt - 1) - --- | Cached type and data constructors for sums. The outer array is --- indexed by the arity of the sum and the inner array is indexed by --- the alternative. -unboxedSumArr :: Array Int (TyCon, Array Int DataCon) -unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]] - --- | Specialization of 'unboxedTupleSumKind' for sums -unboxedSumKind :: [Type] -> Kind -unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon - --- | Create type constructor and data constructors for n-ary unboxed sum. -mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) -mk_sum arity = (tycon, sum_cons) - where - tycon = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons) - (UnboxedAlgTyCon rep_name) - - -- Unboxed sums are currently not Typeable due to efficiency concerns. See #13276. - rep_name = Nothing -- Just $ mkPrelTyConRepName tc_name - - tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy) - (\ks -> map tYPE ks) - - tyvars = binderVars tc_binders - - tc_res_kind = unboxedSumKind rr_tys - - (rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars) - - tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq - (ATyCon tycon) BuiltInSyntax - - sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]] - sum_con i = let dc = pcDataCon dc_name - tyvars -- univ tyvars - [tyvar_tys !! i] -- arg types - tycon - - dc_name = mkWiredInName gHC_PRIM - (mkSumDataConOcc i arity) - (dc_uniq i) - (AConLike (RealDataCon dc)) - BuiltInSyntax - in dc - - tc_uniq = mkSumTyConUnique arity - dc_uniq i = mkSumDataConUnique i arity - -{- -************************************************************************ -* * - Equality types and classes -* * -********************************************************************* -} - --- See Note [The equality types story] in TysPrim --- (:~~: :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint) --- --- It's tempting to put functional dependencies on (~~), but it's not --- necessary because the functional-dependency coverage check looks --- through superclasses, and (~#) is handled in that check. - -heqTyCon, coercibleTyCon :: TyCon -heqClass, coercibleClass :: Class -heqDataCon, coercibleDataCon :: DataCon -heqSCSelId, coercibleSCSelId :: Id - -(heqTyCon, heqClass, heqDataCon, heqSCSelId) - = (tycon, klass, datacon, sc_sel_id) - where - tycon = mkClassTyCon heqTyConName binders roles - rhs klass - (mkPrelTyConRepName heqTyConName) - klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataCon heqDataConName tvs [sc_pred] tycon - - -- Kind: forall k1 k2. k1 -> k2 -> Constraint - binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks) - roles = [Nominal, Nominal, Nominal, Nominal] - rhs = DataTyCon { data_cons = [datacon], is_enum = False } - - tvs = binderVars binders - sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs) - sc_sel_id = mkDictSelId heqSCSelIdName klass - -(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId) - = (tycon, klass, datacon, sc_sel_id) - where - tycon = mkClassTyCon coercibleTyConName binders roles - rhs klass - (mkPrelTyConRepName coercibleTyConName) - klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon - - -- Kind: forall k. k -> k -> Constraint - binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) - roles = [Nominal, Representational, Representational] - rhs = DataTyCon { data_cons = [datacon], is_enum = False } - - tvs@[k,a,b] = binderVars binders - sc_pred = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b]) - sc_sel_id = mkDictSelId coercibleSCSelIdName klass - -mk_class :: TyCon -> PredType -> Id -> Class -mk_class tycon sc_pred sc_sel_id - = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id] - [] [] (mkAnd []) tycon - -{- ********************************************************************* -* * - Kinds and RuntimeRep -* * -********************************************************************* -} - --- For information about the usage of the following type, --- see Note [TYPE and RuntimeRep] in module TysPrim -runtimeRepTy :: Type -runtimeRepTy = mkTyConTy runtimeRepTyCon - -liftedTypeKindTyCon, starKindTyCon, unicodeStarKindTyCon :: TyCon - --- Type syononyms; see Note [TYPE and RuntimeRep] in TysPrim --- type Type = tYPE 'LiftedRep --- type * = tYPE 'LiftedRep --- type * = tYPE 'LiftedRep -- Unicode variant - -liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName - [] liftedTypeKind [] - (tYPE liftedRepTy) - -starKindTyCon = buildSynTyCon starKindTyConName - [] liftedTypeKind [] - (tYPE liftedRepTy) - -unicodeStarKindTyCon = buildSynTyCon unicodeStarKindTyConName - [] liftedTypeKind [] - (tYPE liftedRepTy) - -runtimeRepTyCon :: TyCon -runtimeRepTyCon = pcNonEnumTyCon runtimeRepTyConName Nothing [] - (vecRepDataCon : tupleRepDataCon : - sumRepDataCon : runtimeRepSimpleDataCons) - -vecRepDataCon :: DataCon -vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon - , mkTyConTy vecElemTyCon ] - runtimeRepTyCon - (RuntimeRep prim_rep_fun) - where - prim_rep_fun [count, elem] - | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count) - , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem) - = [VecRep n e] - prim_rep_fun args - = pprPanic "vecRepDataCon" (ppr args) - -vecRepDataConTyCon :: TyCon -vecRepDataConTyCon = promoteDataCon vecRepDataCon - -tupleRepDataCon :: DataCon -tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] - runtimeRepTyCon (RuntimeRep prim_rep_fun) - where - prim_rep_fun [rr_ty_list] - = concatMap (runtimeRepPrimRep doc) rr_tys - where - rr_tys = extractPromotedList rr_ty_list - doc = text "tupleRepDataCon" <+> ppr rr_tys - prim_rep_fun args - = pprPanic "tupleRepDataCon" (ppr args) - -tupleRepDataConTyCon :: TyCon -tupleRepDataConTyCon = promoteDataCon tupleRepDataCon - -sumRepDataCon :: DataCon -sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] - runtimeRepTyCon (RuntimeRep prim_rep_fun) - where - prim_rep_fun [rr_ty_list] - = map slotPrimRep (ubxSumRepType prim_repss) - where - rr_tys = extractPromotedList rr_ty_list - doc = text "sumRepDataCon" <+> ppr rr_tys - prim_repss = map (runtimeRepPrimRep doc) rr_tys - prim_rep_fun args - = pprPanic "sumRepDataCon" (ppr args) - -sumRepDataConTyCon :: TyCon -sumRepDataConTyCon = promoteDataCon sumRepDataCon - --- See Note [Wiring in RuntimeRep] -runtimeRepSimpleDataCons :: [DataCon] -liftedRepDataCon :: DataCon -runtimeRepSimpleDataCons@(liftedRepDataCon : _) - = zipWithLazy mk_runtime_rep_dc - [ LiftedRep, UnliftedRep, IntRep, WordRep, Int64Rep - , Word64Rep, AddrRep, FloatRep, DoubleRep ] - runtimeRepSimpleDataConNames - where - mk_runtime_rep_dc primrep name - = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) - --- See Note [Wiring in RuntimeRep] -liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, wordRepDataConTy, int64RepDataConTy, - word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type -[liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, wordRepDataConTy, int64RepDataConTy, - word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy] - = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons - -vecCountTyCon :: TyCon -vecCountTyCon = pcTyCon True vecCountTyConName Nothing [] - vecCountDataCons - --- See Note [Wiring in RuntimeRep] -vecCountDataCons :: [DataCon] -vecCountDataCons = zipWithLazy mk_vec_count_dc - [ 2, 4, 8, 16, 32, 64 ] - vecCountDataConNames - where - mk_vec_count_dc n name - = pcSpecialDataCon name [] vecCountTyCon (VecCount n) - --- See Note [Wiring in RuntimeRep] -vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, - vec64DataConTy :: Type -[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, - vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons - -vecElemTyCon :: TyCon -vecElemTyCon = pcTyCon True vecElemTyConName Nothing [] vecElemDataCons - --- See Note [Wiring in RuntimeRep] -vecElemDataCons :: [DataCon] -vecElemDataCons = zipWithLazy mk_vec_elem_dc - [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep - , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep - , FloatElemRep, DoubleElemRep ] - vecElemDataConNames - where - mk_vec_elem_dc elem name - = pcSpecialDataCon name [] vecElemTyCon (VecElem elem) - --- See Note [Wiring in RuntimeRep] -int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, - int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, - word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - doubleElemRepDataConTy :: Type -[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, - int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, - word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) - vecElemDataCons - -liftedRepDataConTyCon :: TyCon -liftedRepDataConTyCon = promoteDataCon liftedRepDataCon - --- The type ('LiftedRep) -liftedRepTy :: Type -liftedRepTy = mkTyConTy liftedRepDataConTyCon - -{- ********************************************************************* -* * - The boxed primitive types: Char, Int, etc -* * -********************************************************************* -} - -boxingDataCon_maybe :: TyCon -> Maybe DataCon --- boxingDataCon_maybe Char# = C# --- boxingDataCon_maybe Int# = I# --- ... etc ... --- See Note [Boxing primitive types] -boxingDataCon_maybe tc - = lookupNameEnv boxing_constr_env (tyConName tc) - -boxing_constr_env :: NameEnv DataCon -boxing_constr_env - = mkNameEnv [(charPrimTyConName , charDataCon ) - ,(intPrimTyConName , intDataCon ) - ,(wordPrimTyConName , wordDataCon ) - ,(floatPrimTyConName , floatDataCon ) - ,(doublePrimTyConName, doubleDataCon) ] - -{- Note [Boxing primitive types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a handful of primitive types (Int, Char, Word, Flaot, Double), -we can readily box and an unboxed version (Int#, Char# etc) using -the corresponding data constructor. This is useful in a couple -of places, notably let-floating -} - - -charTy :: Type -charTy = mkTyConTy charTyCon - -charTyCon :: TyCon -charTyCon = pcNonEnumTyCon charTyConName - (Just (CType NoSourceText Nothing - (NoSourceText,fsLit "HsChar"))) - [] [charDataCon] -charDataCon :: DataCon -charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon - -stringTy :: Type -stringTy = mkListTy charTy -- convenience only - -intTy :: Type -intTy = mkTyConTy intTyCon - -intTyCon :: TyCon -intTyCon = pcNonEnumTyCon intTyConName - (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt"))) - [] [intDataCon] -intDataCon :: DataCon -intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon - -wordTy :: Type -wordTy = mkTyConTy wordTyCon - -wordTyCon :: TyCon -wordTyCon = pcNonEnumTyCon wordTyConName - (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord"))) - [] [wordDataCon] -wordDataCon :: DataCon -wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon - -word8Ty :: Type -word8Ty = mkTyConTy word8TyCon - -word8TyCon :: TyCon -word8TyCon = pcNonEnumTyCon word8TyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsWord8"))) [] - [word8DataCon] -word8DataCon :: DataCon -word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon - -floatTy :: Type -floatTy = mkTyConTy floatTyCon - -floatTyCon :: TyCon -floatTyCon = pcNonEnumTyCon floatTyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsFloat"))) [] - [floatDataCon] -floatDataCon :: DataCon -floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon - -doubleTy :: Type -doubleTy = mkTyConTy doubleTyCon - -doubleTyCon :: TyCon -doubleTyCon = pcNonEnumTyCon doubleTyConName - (Just (CType NoSourceText Nothing - (NoSourceText,fsLit "HsDouble"))) [] - [doubleDataCon] - -doubleDataCon :: DataCon -doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon - -{- -************************************************************************ -* * - The Bool type -* * -************************************************************************ - -An ordinary enumeration type, but deeply wired in. There are no -magical operations on @Bool@ (just the regular Prelude code). - -{\em BEGIN IDLE SPECULATION BY SIMON} - -This is not the only way to encode @Bool@. A more obvious coding makes -@Bool@ just a boxed up version of @Bool#@, like this: -\begin{verbatim} -type Bool# = Int# -data Bool = MkBool Bool# -\end{verbatim} - -Unfortunately, this doesn't correspond to what the Report says @Bool@ -looks like! Furthermore, we get slightly less efficient code (I -think) with this coding. @gtInt@ would look like this: - -\begin{verbatim} -gtInt :: Int -> Int -> Bool -gtInt x y = case x of I# x# -> - case y of I# y# -> - case (gtIntPrim x# y#) of - b# -> MkBool b# -\end{verbatim} - -Notice that the result of the @gtIntPrim@ comparison has to be turned -into an integer (here called @b#@), and returned in a @MkBool@ box. - -The @if@ expression would compile to this: -\begin{verbatim} -case (gtInt x y) of - MkBool b# -> case b# of { 1# -> e1; 0# -> e2 } -\end{verbatim} - -I think this code is a little less efficient than the previous code, -but I'm not certain. At all events, corresponding with the Report is -important. The interesting thing is that the language is expressive -enough to describe more than one alternative; and that a type doesn't -necessarily need to be a straightforwardly boxed version of its -primitive counterpart. - -{\em END IDLE SPECULATION BY SIMON} --} - -boolTy :: Type -boolTy = mkTyConTy boolTyCon - -boolTyCon :: TyCon -boolTyCon = pcTyCon True boolTyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsBool"))) - [] [falseDataCon, trueDataCon] - -falseDataCon, trueDataCon :: DataCon -falseDataCon = pcDataCon falseDataConName [] [] boolTyCon -trueDataCon = pcDataCon trueDataConName [] [] boolTyCon - -falseDataConId, trueDataConId :: Id -falseDataConId = dataConWorkId falseDataCon -trueDataConId = dataConWorkId trueDataCon - -orderingTyCon :: TyCon -orderingTyCon = pcTyCon True orderingTyConName Nothing - [] [ltDataCon, eqDataCon, gtDataCon] - -ltDataCon, eqDataCon, gtDataCon :: DataCon -ltDataCon = pcDataCon ltDataConName [] [] orderingTyCon -eqDataCon = pcDataCon eqDataConName [] [] orderingTyCon -gtDataCon = pcDataCon gtDataConName [] [] orderingTyCon - -ltDataConId, eqDataConId, gtDataConId :: Id -ltDataConId = dataConWorkId ltDataCon -eqDataConId = dataConWorkId eqDataCon -gtDataConId = dataConWorkId gtDataCon - -{- -************************************************************************ -* * - The List type - Special syntax, deeply wired in, - but otherwise an ordinary algebraic data type -* * -************************************************************************ - - data [] a = [] | a : (List a) --} - -mkListTy :: Type -> Type -mkListTy ty = mkTyConApp listTyCon [ty] - -listTyCon :: TyCon -listTyCon = buildAlgTyCon listTyConName alpha_tyvar [Representational] - Nothing [] - (DataTyCon [nilDataCon, consDataCon] False ) - False - (VanillaAlgTyCon $ mkPrelTyConRepName listTyConName) - -nilDataCon :: DataCon -nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon - -consDataCon :: DataCon -consDataCon = pcDataConWithFixity True {- Declared infix -} - consDataConName - alpha_tyvar [] [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon --- Interesting: polymorphic recursion would help here. --- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy --- gets the over-specific type (Type -> Type) - --- Wired-in type Maybe - -maybeTyCon :: TyCon -maybeTyCon = pcTyCon False maybeTyConName Nothing alpha_tyvar - [nothingDataCon, justDataCon] - -nothingDataCon :: DataCon -nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon - -justDataCon :: DataCon -justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon - -{- -** ********************************************************************* -* * - The tuple types -* * -************************************************************************ - -The tuple types are definitely magic, because they form an infinite -family. - -\begin{itemize} -\item -They have a special family of type constructors, of type @TyCon@ -These contain the tycon arity, but don't require a Unique. - -\item -They have a special family of constructors, of type -@Id@. Again these contain their arity but don't need a Unique. - -\item -There should be a magic way of generating the info tables and -entry code for all tuples. - -But at the moment we just compile a Haskell source -file\srcloc{lib/prelude/...} containing declarations like: -\begin{verbatim} -data Tuple0 = Tup0 -data Tuple2 a b = Tup2 a b -data Tuple3 a b c = Tup3 a b c -data Tuple4 a b c d = Tup4 a b c d -... -\end{verbatim} -The print-names associated with the magic @Id@s for tuple constructors -``just happen'' to be the same as those generated by these -declarations. - -\item -The instance environment should have a magic way to know -that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and -so on. \ToDo{Not implemented yet.} - -\item -There should also be a way to generate the appropriate code for each -of these instances, but (like the info tables and entry code) it is -done by enumeration\srcloc{lib/prelude/InTup?.hs}. -\end{itemize} --} - --- | Make a tuple type. The list of types should /not/ include any --- RuntimeRep specifications. -mkTupleTy :: Boxity -> [Type] -> Type --- Special case for *boxed* 1-tuples, which are represented by the type itself -mkTupleTy Boxed [ty] = ty -mkTupleTy Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys -mkTupleTy Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys)) - (map getRuntimeRep tys ++ tys) - --- | Build the type of a small tuple that holds the specified type of thing -mkBoxedTupleTy :: [Type] -> Type -mkBoxedTupleTy tys = mkTupleTy Boxed tys - -unitTy :: Type -unitTy = mkTupleTy Boxed [] - -{- ********************************************************************* -* * - The sum types -* * -************************************************************************ --} - -mkSumTy :: [Type] -> Type -mkSumTy tys = mkTyConApp (sumTyCon (length tys)) - (map getRuntimeRep tys ++ tys) - -{- ********************************************************************* -* * - The parallel-array type, [::] -* * -************************************************************************ - -Special syntax for parallel arrays needs some wired in definitions. --} - --- | Construct a type representing the application of the parallel array constructor -mkPArrTy :: Type -> Type -mkPArrTy ty = mkTyConApp parrTyCon [ty] - --- | Represents the type constructor of parallel arrays --- --- * This must match the definition in @PrelPArr@ --- --- NB: Although the constructor is given here, it will not be accessible in --- user code as it is not in the environment of any compiled module except --- @PrelPArr@. --- -parrTyCon :: TyCon -parrTyCon = pcNonEnumTyCon parrTyConName Nothing alpha_tyvar [parrDataCon] - -parrDataCon :: DataCon -parrDataCon = pcDataCon - parrDataConName - alpha_tyvar -- forall'ed type variables - [intTy, -- 1st argument: Int - mkTyConApp -- 2nd argument: Array# a - arrayPrimTyCon - alpha_ty] - parrTyCon - --- | Check whether a type constructor is the constructor for parallel arrays -isPArrTyCon :: TyCon -> Bool -isPArrTyCon tc = tyConName tc == parrTyConName - --- | Fake array constructors --- --- * These constructors are never really used to represent array values; --- however, they are very convenient during desugaring (and, in particular, --- in the pattern matching compiler) to treat array pattern just like --- yet another constructor pattern --- -parrFakeCon :: Arity -> DataCon -parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially -parrFakeCon i = parrFakeConArr!i - --- pre-defined set of constructors --- -parrFakeConArr :: Array Int DataCon -parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i) - | i <- [0..mAX_TUPLE_SIZE]] - --- build a fake parallel array constructor for the given arity --- -mkPArrFakeCon :: Int -> DataCon -mkPArrFakeCon arity = data_con - where - data_con = pcDataCon name [tyvar] tyvarTys parrTyCon - tyvar = head alphaTyVars - tyvarTys = replicate arity $ mkTyVarTy tyvar - nameStr = mkFastString ("MkPArr" ++ show arity) - name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique - (AConLike (RealDataCon data_con)) UserSyntax - unique = mkPArrDataConUnique arity - --- | Checks whether a data constructor is a fake constructor for parallel arrays -isPArrFakeCon :: DataCon -> Bool -isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) - --- Promoted Booleans - -promotedFalseDataCon, promotedTrueDataCon :: TyCon -promotedTrueDataCon = promoteDataCon trueDataCon -promotedFalseDataCon = promoteDataCon falseDataCon - --- Promoted Maybe -promotedNothingDataCon, promotedJustDataCon :: TyCon -promotedNothingDataCon = promoteDataCon nothingDataCon -promotedJustDataCon = promoteDataCon justDataCon - --- Promoted Ordering - -promotedLTDataCon - , promotedEQDataCon - , promotedGTDataCon - :: TyCon -promotedLTDataCon = promoteDataCon ltDataCon -promotedEQDataCon = promoteDataCon eqDataCon -promotedGTDataCon = promoteDataCon gtDataCon - --- Promoted List -promotedConsDataCon, promotedNilDataCon :: TyCon -promotedConsDataCon = promoteDataCon consDataCon -promotedNilDataCon = promoteDataCon nilDataCon - --- | Make a *promoted* list. -mkPromotedListTy :: Kind -- ^ of the elements of the list - -> [Type] -- ^ elements - -> Type -mkPromotedListTy k tys - = foldr cons nil tys - where - cons :: Type -- element - -> Type -- list - -> Type - cons elt list = mkTyConApp promotedConsDataCon [k, elt, list] - - nil :: Type - nil = mkTyConApp promotedNilDataCon [k] - --- | Extract the elements of a promoted list. Panics if the type is not a --- promoted list -extractPromotedList :: Type -- ^ The promoted list - -> [Type] -extractPromotedList tys = go tys - where - go list_ty - | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty - = ASSERT( tc `hasKey` consDataConKey ) - t : go ts - - | Just (tc, [_k]) <- splitTyConApp_maybe list_ty - = ASSERT( tc `hasKey` nilDataConKey ) - [] - - | otherwise - = pprPanic "extractPromotedList" (ppr tys) diff --git a/prelude/TysWiredIn.hs-boot b/prelude/TysWiredIn.hs-boot deleted file mode 100644 --- a/prelude/TysWiredIn.hs-boot +++ /dev/null @@ -1,37 +0,0 @@ -module TysWiredIn where - -import Var( TyVar, ArgFlag ) -import {-# SOURCE #-} TyCon ( TyCon ) -import {-# SOURCE #-} TyCoRep (Type, Kind) - - -mkFunKind :: Kind -> Kind -> Kind -mkForAllKind :: TyVar -> ArgFlag -> Kind -> Kind - -listTyCon :: TyCon -typeNatKind, typeSymbolKind :: Type -mkBoxedTupleTy :: [Type] -> Type - -liftedTypeKind :: Kind -constraintKind :: Kind - -runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon -runtimeRepTy :: Type - -liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon - -liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, - wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy :: Type - -vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, - vec64DataConTy :: Type - -int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, - int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, - word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - doubleElemRepDataConTy :: Type - -anyTypeOfKind :: Kind -> Type -unboxedTupleKind :: [Type] -> Type -mkPromotedListTy :: Type -> [Type] -> Type diff --git a/profiling/CostCentre.hs b/profiling/CostCentre.hs deleted file mode 100644 --- a/profiling/CostCentre.hs +++ /dev/null @@ -1,326 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module CostCentre ( - CostCentre(..), CcName, IsCafCC(..), - -- All abstract except to friend: ParseIface.y - - CostCentreStack, - CollectedCCs, - noCCS, currentCCS, dontCareCCS, - noCCSAttached, isCurrentCCS, - maybeSingletonCCS, - - mkUserCC, mkAutoCC, mkAllCafsCC, - mkSingletonCCS, - isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, - - pprCostCentreCore, - costCentreUserName, costCentreUserNameFS, - costCentreSrcSpan, - - cmpCostCentre -- used for removing dups in a list - ) where - -import Binary -import Var -import Name -import Module -import Unique -import Outputable -import SrcLoc -import FastString -import Util - -import Data.Data - ------------------------------------------------------------------------------ --- Cost Centres - --- | A Cost Centre is a single @{-# SCC #-}@ annotation. - -data CostCentre - = NormalCC { - cc_key :: {-# UNPACK #-} !Int, - -- ^ Two cost centres may have the same name and - -- module but different SrcSpans, so we need a way to - -- distinguish them easily and give them different - -- object-code labels. So every CostCentre has a - -- Unique that is distinct from every other - -- CostCentre in the same module. - -- - -- XXX: should really be using Unique here, but we - -- need to derive Data below and there's no Data - -- instance for Unique. - cc_name :: CcName, -- ^ Name of the cost centre itself - cc_mod :: Module, -- ^ Name of module defining this CC. - cc_loc :: SrcSpan, - cc_is_caf :: IsCafCC -- see below - } - - | AllCafsCC { - cc_mod :: Module, -- Name of module defining this CC. - cc_loc :: SrcSpan - } - deriving Data - -type CcName = FastString - -data IsCafCC = NotCafCC | CafCC - deriving (Eq, Ord, Data) - - -instance Eq CostCentre where - c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } - -instance Ord CostCentre where - compare = cmpCostCentre - -cmpCostCentre :: CostCentre -> CostCentre -> Ordering - -cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) - = m1 `compare` m2 - -cmpCostCentre NormalCC {cc_key = n1, cc_mod = m1} - NormalCC {cc_key = n2, cc_mod = m2} - -- first key is module name, then the integer key - = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) - -cmpCostCentre other_1 other_2 - = let - tag1 = tag_CC other_1 - tag2 = tag_CC other_2 - in - if tag1 < tag2 then LT else GT - where - tag_CC :: CostCentre -> Int - tag_CC (NormalCC {}) = 0 - tag_CC (AllCafsCC {}) = 1 - - ------------------------------------------------------------------------------ --- Predicates on CostCentre - -isCafCC :: CostCentre -> Bool -isCafCC (AllCafsCC {}) = True -isCafCC (NormalCC {cc_is_caf = CafCC}) = True -isCafCC _ = False - --- | Is this a cost-centre which records scc counts -isSccCountCC :: CostCentre -> Bool -isSccCountCC cc | isCafCC cc = False - | otherwise = True - --- | Is this a cost-centre which can be sccd ? -sccAbleCC :: CostCentre -> Bool -sccAbleCC cc | isCafCC cc = False - | otherwise = True - -ccFromThisModule :: CostCentre -> Module -> Bool -ccFromThisModule cc m = cc_mod cc == m - - ------------------------------------------------------------------------------ --- Building cost centres - -mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre -mkUserCC cc_name mod loc key - = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod = mod, cc_loc = loc, - cc_is_caf = NotCafCC {-might be changed-} - } - -mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre -mkAutoCC id mod is_caf - = NormalCC { cc_key = getKey (getUnique id), - cc_name = str, cc_mod = mod, - cc_loc = nameSrcSpan (getName id), - cc_is_caf = is_caf - } - where - name = getName id - -- beware: only external names are guaranteed to have unique - -- Occnames. If the name is not external, we must append its - -- Unique. - -- See bug #249, tests prof001, prof002, also #2411 - str | isExternalName name = occNameFS (getOccName id) - | otherwise = occNameFS (getOccName id) - `appendFS` - mkFastString ('_' : show (getUnique name)) -mkAllCafsCC :: Module -> SrcSpan -> CostCentre -mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } - ------------------------------------------------------------------------------ --- Cost Centre Stacks - --- | A Cost Centre Stack is something that can be attached to a closure. --- This is either: --- --- * the current cost centre stack (CCCS) --- * a pre-defined cost centre stack (there are several --- pre-defined CCSs, see below). - -data CostCentreStack - = NoCCS - - | CurrentCCS -- Pinned on a let(rec)-bound - -- thunk/function/constructor, this says that the - -- cost centre to be attached to the object, when it - -- is allocated, is whatever is in the - -- current-cost-centre-stack register. - - | DontCareCCS -- We need a CCS to stick in static closures - -- (for data), but we *don't* expect them to - -- accumulate any costs. But we still need - -- the placeholder. This CCS is it. - - | SingletonCCS CostCentre - - deriving (Eq, Ord) -- needed for Ord on CLabel - - --- synonym for triple which describes the cost centre info in the generated --- code for a module. -type CollectedCCs - = ( [CostCentre] -- local cost-centres that need to be decl'd - , [CostCentre] -- "extern" cost-centres - , [CostCentreStack] -- pre-defined "singleton" cost centre stacks - ) - - -noCCS, currentCCS, dontCareCCS :: CostCentreStack - -noCCS = NoCCS -currentCCS = CurrentCCS -dontCareCCS = DontCareCCS - ------------------------------------------------------------------------------ --- Predicates on Cost-Centre Stacks - -noCCSAttached :: CostCentreStack -> Bool -noCCSAttached NoCCS = True -noCCSAttached _ = False - -isCurrentCCS :: CostCentreStack -> Bool -isCurrentCCS CurrentCCS = True -isCurrentCCS _ = False - -isCafCCS :: CostCentreStack -> Bool -isCafCCS (SingletonCCS cc) = isCafCC cc -isCafCCS _ = False - -maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre -maybeSingletonCCS (SingletonCCS cc) = Just cc -maybeSingletonCCS _ = Nothing - -mkSingletonCCS :: CostCentre -> CostCentreStack -mkSingletonCCS cc = SingletonCCS cc - - ------------------------------------------------------------------------------ --- Printing Cost Centre Stacks. - --- The outputable instance for CostCentreStack prints the CCS as a C --- expression. - -instance Outputable CostCentreStack where - ppr NoCCS = text "NO_CCS" - ppr CurrentCCS = text "CCCS" - ppr DontCareCCS = text "CCS_DONT_CARE" - ppr (SingletonCCS cc) = ppr cc <> text "_ccs" - - ------------------------------------------------------------------------------ --- Printing Cost Centres --- --- There are several different ways in which we might want to print a --- cost centre: --- --- - the name of the cost centre, for profiling output (a C string) --- - the label, i.e. C label for cost centre in .hc file. --- - the debugging name, for output in -ddump things --- - the interface name, for printing in _scc_ exprs in iface files. --- --- The last 3 are derived from costCentreStr below. The first is given --- by costCentreName. - -instance Outputable CostCentre where - ppr cc = getPprStyle $ \ sty -> - if codeStyle sty - then ppCostCentreLbl cc - else text (costCentreUserName cc) - --- Printing in Core -pprCostCentreCore :: CostCentre -> SDoc -pprCostCentreCore (AllCafsCC {cc_mod = m}) - = text "__sccC" <+> braces (ppr m) -pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc, - cc_is_caf = caf}) - = text "__scc" <+> braces (hsep [ - ppr m <> char '.' <> ftext n, - ifPprDebug (ppr key), - pp_caf caf, - ifPprDebug (ppr loc) - ]) - -pp_caf :: IsCafCC -> SDoc -pp_caf CafCC = text "__C" -pp_caf _ = empty - --- Printing as a C label -ppCostCentreLbl :: CostCentre -> SDoc -ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" -ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m, - cc_is_caf = is_caf}) - = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> - case is_caf of { CafCC -> text "CAF"; _ -> ppr (mkUniqueGrimily k)} <> text "_cc" - --- This is the name to go in the user-displayed string, --- recorded in the cost centre declaration -costCentreUserName :: CostCentre -> String -costCentreUserName = unpackFS . costCentreUserNameFS - -costCentreUserNameFS :: CostCentre -> FastString -costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" -costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf}) - = case is_caf of - CafCC -> mkFastString "CAF:" `appendFS` name - _ -> name - -costCentreSrcSpan :: CostCentre -> SrcSpan -costCentreSrcSpan = cc_loc - -instance Binary IsCafCC where - put_ bh CafCC = do - putByte bh 0 - put_ bh NotCafCC = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return CafCC - _ -> do return NotCafCC - -instance Binary CostCentre where - put_ bh (NormalCC aa ab ac _ad ae) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh ae - put_ bh (AllCafsCC ae _af) = do - putByte bh 1 - put_ bh ae - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - ac <- get bh - ae <- get bh - return (NormalCC aa ab ac noSrcSpan ae) - _ -> do ae <- get bh - return (AllCafsCC ae noSrcSpan) - - -- We ignore the SrcSpans in CostCentres when we serialise them, - -- and set the SrcSpans to noSrcSpan when deserialising. This is - -- ok, because we only need the SrcSpan when declaring the - -- CostCentre in the original module, it is not used by importing - -- modules. diff --git a/profiling/ProfInit.hs b/profiling/ProfInit.hs deleted file mode 100644 --- a/profiling/ProfInit.hs +++ /dev/null @@ -1,46 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2011 --- --- Generate code to initialise cost centres --- --- ----------------------------------------------------------------------------- - -module ProfInit (profilingInitCode) where - -import CLabel -import CostCentre -import DynFlags -import Outputable -import FastString -import Module - --- ----------------------------------------------------------------------------- --- Initialising cost centres - --- We must produce declarations for the cost-centres defined in this --- module; - -profilingInitCode :: Module -> CollectedCCs -> SDoc -profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs) - = sdocWithDynFlags $ \dflags -> - if not (gopt Opt_SccProfilingOn dflags) - then empty - else vcat - [ text "static void prof_init_" <> ppr this_mod - <> text "(void) __attribute__((constructor));" - , text "static void prof_init_" <> ppr this_mod <> text "(void)" - , braces (vcat ( - map emitRegisterCC local_CCs ++ - map emitRegisterCCS singleton_CCSs - )) - ] - where - emitRegisterCC cc = - text "extern CostCentre " <> cc_lbl <> ptext (sLit "[];") $$ - text "REGISTER_CC(" <> cc_lbl <> char ')' <> semi - where cc_lbl = ppr (mkCCLabel cc) - emitRegisterCCS ccs = - text "extern CostCentreStack " <> ccs_lbl <> ptext (sLit "[];") $$ - text "REGISTER_CCS(" <> ccs_lbl <> char ')' <> semi - where ccs_lbl = ppr (mkCCSLabel ccs) diff --git a/profiling/SCCfinal.hs b/profiling/SCCfinal.hs deleted file mode 100644 --- a/profiling/SCCfinal.hs +++ /dev/null @@ -1,285 +0,0 @@ --- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- Modify and collect code generation for final STG program - -{- - This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg. - - - Traverses the STG program collecting the cost centres. These are required - to declare the cost centres at the start of code generation. - - Note: because of cross-module unfolding, some of these cost centres may be - from other modules. - - - Puts on CAF cost-centres if the user has asked for individual CAF - cost-centres. --} - -module SCCfinal ( stgMassageForProfiling ) where - -#include "HsVersions.h" - -import StgSyn - -import CostCentre -- lots of things -import Id -import Name -import Module -import UniqSupply ( UniqSupply ) -import ListSetOps ( removeDups ) -import Outputable -import DynFlags -import CoreSyn ( Tickish(..) ) -import FastString -import SrcLoc -import Util - -import Control.Monad (liftM, ap) - -stgMassageForProfiling - :: DynFlags - -> Module -- module name - -> UniqSupply -- unique supply - -> [StgTopBinding] -- input - -> (CollectedCCs, [StgTopBinding]) - -stgMassageForProfiling dflags mod_name _us stg_binds - = let - ((local_ccs, extern_ccs, cc_stacks), - stg_binds2) - = initMM mod_name (do_top_bindings stg_binds) - - (fixed_ccs, fixed_cc_stacks) - = if gopt Opt_AutoSccsOnIndividualCafs dflags - then ([],[]) -- don't need "all CAFs" CC - else ([all_cafs_cc], [all_cafs_ccs]) - - local_ccs_no_dups = fst (removeDups cmpCostCentre local_ccs) - extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs) - in - ((fixed_ccs ++ local_ccs_no_dups, - extern_ccs_no_dups, - fixed_cc_stacks ++ cc_stacks), stg_binds2) - where - - span = mkGeneralSrcSpan (mkFastString "") -- XXX do better - all_cafs_cc = mkAllCafsCC mod_name span - all_cafs_ccs = mkSingletonCCS all_cafs_cc - - ---------- - do_top_bindings :: [StgTopBinding] -> MassageM [StgTopBinding] - - do_top_bindings [] = return [] - - do_top_bindings (StgTopLifted (StgNonRec b rhs) : bs) = do - rhs' <- do_top_rhs b rhs - bs' <- do_top_bindings bs - return (StgTopLifted (StgNonRec b rhs') : bs') - - do_top_bindings (StgTopLifted (StgRec pairs) : bs) = do - pairs2 <- mapM do_pair pairs - bs' <- do_top_bindings bs - return (StgTopLifted (StgRec pairs2) : bs') - where - do_pair (b, rhs) = do - rhs2 <- do_top_rhs b rhs - return (b, rhs2) - - do_top_bindings (b@StgTopStringLit{} : bs) = do - bs' <- do_top_bindings bs - return (b : bs') - - ---------- - do_top_rhs :: Id -> StgRhs -> MassageM StgRhs - - do_top_rhs _ (StgRhsClosure _ _ _ _ [] - (StgTick (ProfNote _cc False{-not tick-} _push) - (StgConApp con args _))) - | not (isDllConApp dflags mod_name con args) - -- Trivial _scc_ around nothing but static data - -- Eliminate _scc_ ... and turn into StgRhsCon - - -- isDllConApp checks for LitLit args too - = return (StgRhsCon dontCareCCS con args) - - do_top_rhs binder (StgRhsClosure _ bi fv u [] body) - = do - -- Top level CAF without a cost centre attached - -- Attach CAF cc (collect if individual CAF ccs) - caf_ccs <- if gopt Opt_AutoSccsOnIndividualCafs dflags - then let cc = mkAutoCC binder modl CafCC - ccs = mkSingletonCCS cc - -- careful: the binder might be :Main.main, - -- which doesn't belong to module mod_name. - -- bug #249, tests prof001, prof002 - modl | Just m <- nameModule_maybe (idName binder) = m - | otherwise = mod_name - in do - collectNewCC cc - collectCCS ccs - return ccs - else - return all_cafs_ccs - body' <- do_expr body - return (StgRhsClosure caf_ccs bi fv u [] body') - - do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body) - = do body' <- do_expr body - return (StgRhsClosure dontCareCCS bi fv u args body') - - do_top_rhs _ (StgRhsCon _ con args) - -- Top-level (static) data is not counted in heap - -- profiles; nor do we set CCCS from it; so we - -- just slam in dontCareCostCentre - = return (StgRhsCon dontCareCCS con args) - - ------ - do_expr :: StgExpr -> MassageM StgExpr - - do_expr (StgLit l) = return (StgLit l) - - do_expr (StgApp fn args) - = return (StgApp fn args) - - do_expr (StgConApp con args ty_args) - = return (StgConApp con args ty_args) - - do_expr (StgOpApp con args res_ty) - = return (StgOpApp con args res_ty) - - do_expr (StgTick note@(ProfNote cc _ _) expr) = do - -- Ha, we found a cost centre! - collectCC cc - expr' <- do_expr expr - return (StgTick note expr') - - do_expr (StgTick ti expr) = do - expr' <- do_expr expr - return (StgTick ti expr') - - do_expr (StgCase expr bndr alt_type alts) = do - expr' <- do_expr expr - alts' <- mapM do_alt alts - return (StgCase expr' bndr alt_type alts') - where - do_alt (id, bs, e) = do - e' <- do_expr e - return (id, bs, e') - - do_expr (StgLet b e) = do - (b,e) <- do_let b e - return (StgLet b e) - - do_expr (StgLetNoEscape b e) = do - (b,e) <- do_let b e - return (StgLetNoEscape b e) - - do_expr other = pprPanic "SCCfinal.do_expr" (ppr other) - - ---------------------------------- - - do_let (StgNonRec b rhs) e = do - rhs' <- do_rhs rhs - e' <- do_expr e - return (StgNonRec b rhs',e') - - do_let (StgRec pairs) e = do - pairs' <- mapM do_pair pairs - e' <- do_expr e - return (StgRec pairs', e') - where - do_pair (b, rhs) = do - rhs2 <- do_rhs rhs - return (b, rhs2) - - ---------------------------------- - do_rhs :: StgRhs -> MassageM StgRhs - -- We play much the same game as we did in do_top_rhs above; - -- but we don't have to worry about cafs etc. - - -- throw away the SCC if we don't have to count entries. This - -- is a little bit wrong, because we're attributing the - -- allocation of the constructor to the wrong place (XXX) - -- We should really attach (PushCC cc CurrentCCS) to the rhs, - -- but need to reinstate PushCC for that. - do_rhs (StgRhsClosure _closure_cc _bi _fv _u [] - (StgTick (ProfNote cc False{-not tick-} _push) - (StgConApp con args _))) - = do collectCC cc - return (StgRhsCon currentCCS con args) - - do_rhs (StgRhsClosure _ bi fv u args expr) = do - expr' <- do_expr expr - return (StgRhsClosure currentCCS bi fv u args expr') - - do_rhs (StgRhsCon _ con args) - = return (StgRhsCon currentCCS con args) - - --- ----------------------------------------------------------------------------- --- Boring monad stuff for this - -newtype MassageM result - = MassageM { - unMassageM :: Module -- module name - -> CollectedCCs - -> (CollectedCCs, result) - } - -instance Functor MassageM where - fmap = liftM - -instance Applicative MassageM where - pure x = MassageM (\_ ccs -> (ccs, x)) - (<*>) = ap - (*>) = thenMM_ - -instance Monad MassageM where - (>>=) = thenMM - (>>) = (*>) - --- the initMM function also returns the final CollectedCCs - -initMM :: Module -- module name, which we may consult - -> MassageM a - -> (CollectedCCs, a) - -initMM mod_name (MassageM m) = m mod_name ([],[],[]) - -thenMM :: MassageM a -> (a -> MassageM b) -> MassageM b -thenMM_ :: MassageM a -> (MassageM b) -> MassageM b - -thenMM expr cont = MassageM $ \mod ccs -> - case unMassageM expr mod ccs of { (ccs2, result) -> - unMassageM (cont result) mod ccs2 } - -thenMM_ expr cont = MassageM $ \mod ccs -> - case unMassageM expr mod ccs of { (ccs2, _) -> - unMassageM cont mod ccs2 } - - -collectCC :: CostCentre -> MassageM () -collectCC cc - = MassageM $ \mod_name (local_ccs, extern_ccs, ccss) - -> if (cc `ccFromThisModule` mod_name) then - ((cc : local_ccs, extern_ccs, ccss), ()) - else -- must declare it "extern" - ((local_ccs, cc : extern_ccs, ccss), ()) - --- Version of collectCC used when we definitely want to declare this --- CC as local, even if its module name is not the same as the current --- module name (eg. the special :Main module) see bug #249, #1472, --- test prof001,prof002. -collectNewCC :: CostCentre -> MassageM () -collectNewCC cc - = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss) - -> ((cc : local_ccs, extern_ccs, ccss), ()) - -collectCCS :: CostCentreStack -> MassageM () - -collectCCS ccs - = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss) - -> ASSERT(not (noCCSAttached ccs)) - ((local_ccs, extern_ccs, ccs : ccss), ()) diff --git a/rename/RnBinds.hs b/rename/RnBinds.hs deleted file mode 100644 --- a/rename/RnBinds.hs +++ /dev/null @@ -1,1234 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} - -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnBinds]{Renaming and dependency analysis of bindings} - -This module does renaming and dependency analysis on value bindings in -the abstract syntax. It does {\em not} do cycle-checks on class or -type-synonym declarations; those cannot be done at this stage because -they may be affected by renaming (which isn't fully worked out yet). --} - -module RnBinds ( - -- Renaming top-level bindings - rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS, - - -- Renaming local bindings - rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, - - -- Other bindings - rnMethodBinds, renameSigs, - rnMatchGroup, rnGRHSs, rnGRHS, - makeMiniFixityEnv, MiniFixityEnv, - HsSigCtxt(..) - ) where - -import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) - -import HsSyn -import TcRnMonad -import TcEvidence ( emptyTcEvBinds ) -import RnTypes -import RnPat -import RnNames -import RnEnv -import DynFlags -import Module -import Name -import NameEnv -import NameSet -import RdrName ( RdrName, rdrNameOcc ) -import SrcLoc -import ListSetOps ( findDupsEq ) -import BasicTypes ( RecFlag(..), LexicalFixity(..) ) -import Digraph ( SCC(..) ) -import Bag -import Util -import Outputable -import FastString -import UniqSet -import Maybes ( orElse ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.List ( partition, sort ) - -{- --- ToDo: Put the annotations into the monad, so that they arrive in the proper --- place and can be used when complaining. - -The code tree received by the function @rnBinds@ contains definitions -in where-clauses which are all apparently mutually recursive, but which may -not really depend upon each other. For example, in the top level program -\begin{verbatim} -f x = y where a = x - y = x -\end{verbatim} -the definitions of @a@ and @y@ do not depend on each other at all. -Unfortunately, the typechecker cannot always check such definitions. -\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive -definitions. In Proceedings of the International Symposium on Programming, -Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} -However, the typechecker usually can check definitions in which only the -strongly connected components have been collected into recursive bindings. -This is precisely what the function @rnBinds@ does. - -ToDo: deal with case where a single monobinds binds the same variable -twice. - -The vertag tag is a unique @Int@; the tags only need to be unique -within one @MonoBinds@, so that unique-Int plumbing is done explicitly -(heavy monad machinery not needed). - - -************************************************************************ -* * -* naming conventions * -* * -************************************************************************ - -\subsection[name-conventions]{Name conventions} - -The basic algorithm involves walking over the tree and returning a tuple -containing the new tree plus its free variables. Some functions, such -as those walking polymorphic bindings (HsBinds) and qualifier lists in -list comprehensions (@Quals@), return the variables bound in local -environments. These are then used to calculate the free variables of the -expression evaluated in these environments. - -Conventions for variable names are as follows: -\begin{itemize} -\item -new code is given a prime to distinguish it from the old. - -\item -a set of variables defined in @Exp@ is written @dvExp@ - -\item -a set of variables free in @Exp@ is written @fvExp@ -\end{itemize} - -************************************************************************ -* * -* analysing polymorphic bindings (HsBindGroup, HsBind) -* * -************************************************************************ - -\subsubsection[dep-HsBinds]{Polymorphic bindings} - -Non-recursive expressions are reconstructed without any changes at top -level, although their component expressions may have to be altered. -However, non-recursive expressions are currently not expected as -\Haskell{} programs, and this code should not be executed. - -Monomorphic bindings contain information that is returned in a tuple -(a @FlatMonoBinds@) containing: - -\begin{enumerate} -\item -a unique @Int@ that serves as the ``vertex tag'' for this binding. - -\item -the name of a function or the names in a pattern. These are a set -referred to as @dvLhs@, the defined variables of the left hand side. - -\item -the free variables of the body. These are referred to as @fvBody@. - -\item -the definition's actual code. This is referred to as just @code@. -\end{enumerate} - -The function @nonRecDvFv@ returns two sets of variables. The first is -the set of variables defined in the set of monomorphic bindings, while the -second is the set of free variables in those bindings. - -The set of variables defined in a non-recursive binding is just the -union of all of them, as @union@ removes duplicates. However, the -free variables in each successive set of cumulative bindings is the -union of those in the previous set plus those of the newest binding after -the defined variables of the previous set have been removed. - -@rnMethodBinds@ deals only with the declarations in class and -instance declarations. It expects only to see @FunMonoBind@s, and -it expects the global environment to contain bindings for the binders -(which are all class operations). - -************************************************************************ -* * -\subsubsection{ Top-level bindings} -* * -************************************************************************ --} - --- for top-level bindings, we need to make top-level names, --- so we have a different entry point than for local bindings -rnTopBindsLHS :: MiniFixityEnv - -> HsValBinds RdrName - -> RnM (HsValBindsLR Name RdrName) -rnTopBindsLHS fix_env binds - = rnValBindsLHS (topRecNameMaker fix_env) binds - -rnTopBindsBoot :: NameSet -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) --- A hs-boot file has no bindings. --- Return a single HsBindGroup with empty binds and renamed signatures -rnTopBindsBoot bound_names (ValBindsIn mbinds sigs) - = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) - ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs - ; return (ValBindsOut [] sigs', usesOnly fvs) } -rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) - -{- -********************************************************* -* * - HsLocalBinds -* * -********************************************************* --} - -rnLocalBindsAndThen :: HsLocalBinds RdrName - -> (HsLocalBinds Name -> FreeVars -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) --- This version (a) assumes that the binding vars are *not* already in scope --- (b) removes the binders from the free vars of the thing inside --- The parser doesn't produce ThenBinds -rnLocalBindsAndThen EmptyLocalBinds thing_inside = - thing_inside EmptyLocalBinds emptyNameSet - -rnLocalBindsAndThen (HsValBinds val_binds) thing_inside - = rnLocalValBindsAndThen val_binds $ \ val_binds' -> - thing_inside (HsValBinds val_binds') - -rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do - (binds',fv_binds) <- rnIPBinds binds - (thing, fvs_thing) <- thing_inside (HsIPBinds binds') fv_binds - return (thing, fvs_thing `plusFV` fv_binds) - -rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars) -rnIPBinds (IPBinds ip_binds _no_dict_binds) = do - (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds - return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s) - -rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars) -rnIPBind (IPBind ~(Left n) expr) = do - (expr',fvExpr) <- rnLExpr expr - return (IPBind (Left n) expr', fvExpr) - -{- -************************************************************************ -* * - ValBinds -* * -************************************************************************ --} - --- Renaming local binding groups --- Does duplicate/shadow check -rnLocalValBindsLHS :: MiniFixityEnv - -> HsValBinds RdrName - -> RnM ([Name], HsValBindsLR Name RdrName) -rnLocalValBindsLHS fix_env binds - = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds - - -- Check for duplicates and shadowing - -- Must do this *after* renaming the patterns - -- See Note [Collect binders only after renaming] in HsUtils - - -- We need to check for dups here because we - -- don't don't bind all of the variables from the ValBinds at once - -- with bindLocatedLocals any more. - -- - -- Note that we don't want to do this at the top level, since - -- sorting out duplicates and shadowing there happens elsewhere. - -- The behavior is even different. For example, - -- import A(f) - -- f = ... - -- should not produce a shadowing warning (but it will produce - -- an ambiguity warning if you use f), but - -- import A(f) - -- g = let f = ... in f - -- should. - ; let bound_names = collectHsValBinders binds' - -- There should be only Ids, but if there are any bogus - -- pattern synonyms, we'll collect them anyway, so that - -- we don't generate subsequent out-of-scope messages - ; envs <- getRdrEnvs - ; checkDupAndShadowedNames envs bound_names - - ; return (bound_names, binds') } - --- renames the left-hand sides --- generic version used both at the top level and for local binds --- does some error checking, but not what gets done elsewhere at the top level -rnValBindsLHS :: NameMaker - -> HsValBinds RdrName - -> RnM (HsValBindsLR Name RdrName) -rnValBindsLHS topP (ValBindsIn mbinds sigs) - = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds - ; return $ ValBindsIn mbinds' sigs } - where - bndrs = collectHsBindsBinders mbinds - doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs - -rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) - --- General version used both from the top-level and for local things --- Assumes the LHS vars are in scope --- --- Does not bind the local fixity declarations -rnValBindsRHS :: HsSigCtxt - -> HsValBindsLR Name RdrName - -> RnM (HsValBinds Name, DefUses) - -rnValBindsRHS ctxt (ValBindsIn mbinds sigs) - = do { (sigs', sig_fvs) <- renameSigs ctxt sigs - ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds - ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus - - ; let patsyn_fvs = foldr (unionNameSet . psb_fvs) emptyNameSet $ - getPatSynBinds anal_binds - -- The uses in binds_w_dus for PatSynBinds do not include - -- variables used in the patsyn builders; see - -- Note [Pattern synonym builders don't yield dependencies] - -- But psb_fvs /does/ include those builder fvs. So we - -- add them back in here to avoid bogus warnings about - -- unused variables (Trac #12548) - - valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs - `plusDU` usesOnly patsyn_fvs - -- Put the sig uses *after* the bindings - -- so that the binders are removed from - -- the uses in the sigs - - ; return (ValBindsOut anal_binds sigs', valbind'_dus) } - -rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) - --- Wrapper for local binds --- --- The *client* of this function is responsible for checking for unused binders; --- it doesn't (and can't: we don't have the thing inside the binds) happen here --- --- The client is also responsible for bringing the fixities into scope -rnLocalValBindsRHS :: NameSet -- names bound by the LHSes - -> HsValBindsLR Name RdrName - -> RnM (HsValBinds Name, DefUses) -rnLocalValBindsRHS bound_names binds - = rnValBindsRHS (LocalBindCtxt bound_names) binds - --- for local binds --- wrapper that does both the left- and right-hand sides --- --- here there are no local fixity decls passed in; --- the local fixity decls come from the ValBinds sigs -rnLocalValBindsAndThen - :: HsValBinds RdrName - -> (HsValBinds Name -> FreeVars -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) -rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside - = do { -- (A) Create the local fixity environment - new_fixities <- makeMiniFixityEnv [L loc sig - | L loc (FixSig sig) <- sigs] - - -- (B) Rename the LHSes - ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds - - -- ...and bring them (and their fixities) into scope - ; bindLocalNamesFV bound_names $ - addLocalFixities new_fixities bound_names $ do - - { -- (C) Do the RHS and thing inside - (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs - ; (result, result_fvs) <- thing_inside binds' (allUses dus) - - -- Report unused bindings based on the (accurate) - -- findUses. E.g. - -- let x = x in 3 - -- should report 'x' unused - ; let real_uses = findUses dus result_fvs - -- Insert fake uses for variables introduced implicitly by - -- wildcards (#4404) - implicit_uses = hsValBindsImplicits binds' - ; warnUnusedLocalBinds bound_names - (real_uses `unionNameSet` implicit_uses) - - ; let - -- The variables "used" in the val binds are: - -- (1) the uses of the binds (allUses) - -- (2) the FVs of the thing-inside - all_uses = allUses dus `plusFV` result_fvs - -- Note [Unused binding hack] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Note that *in contrast* to the above reporting of - -- unused bindings, (1) above uses duUses to return *all* - -- the uses, even if the binding is unused. Otherwise consider: - -- x = 3 - -- y = let p = x in 'x' -- NB: p not used - -- If we don't "see" the dependency of 'y' on 'x', we may put the - -- bindings in the wrong order, and the type checker will complain - -- that x isn't in scope - -- - -- But note that this means we won't report 'x' as unused, - -- whereas we would if we had { x = 3; p = x; y = 'x' } - - ; return (result, all_uses) }} - -- The bound names are pruned out of all_uses - -- by the bindLocalNamesFV call above - -rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) - - ---------------------- - --- renaming a single bind - -rnBindLHS :: NameMaker - -> SDoc - -> HsBind RdrName - -- returns the renamed left-hand side, - -- and the FreeVars *of the LHS* - -- (i.e., any free variables of the pattern) - -> RnM (HsBindLR Name RdrName) - -rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) - = do - -- we don't actually use the FV processing of rnPatsAndThen here - (pat',pat'_fvs) <- rnBindPat name_maker pat - return (bind { pat_lhs = pat', bind_fvs = pat'_fvs }) - -- We temporarily store the pat's FVs in bind_fvs; - -- gets updated to the FVs of the whole bind - -- when doing the RHS below - -rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) - = do { name <- applyNameMaker name_maker rdr_name - ; return (bind { fun_id = name - , bind_fvs = placeHolderNamesTc }) } - -rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname }) - | isTopRecNameMaker name_maker - = do { addLocM checkConName rdrname - ; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already - ; return (PatSynBind psb{ psb_id = name }) } - - | otherwise -- Pattern synonym, not at top level - = do { addErr localPatternSynonymErr -- Complain, but make up a fake - -- name so that we can carry on - ; name <- applyNameMaker name_maker rdrname - ; return (PatSynBind psb{ psb_id = name }) } - where - localPatternSynonymErr :: SDoc - localPatternSynonymErr - = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) - 2 (text "Pattern synonym declarations are only valid at top level") - -rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) - -rnLBind :: (Name -> [Name]) -- Signature tyvar function - -> LHsBindLR Name RdrName - -> RnM (LHsBind Name, [Name], Uses) -rnLBind sig_fn (L loc bind) - = setSrcSpan loc $ - do { (bind', bndrs, dus) <- rnBind sig_fn bind - ; return (L loc bind', bndrs, dus) } - --- assumes the left-hands-side vars are in scope -rnBind :: (Name -> [Name]) -- Signature tyvar function - -> HsBindLR Name RdrName - -> RnM (HsBind Name, [Name], Uses) -rnBind _ bind@(PatBind { pat_lhs = pat - , pat_rhs = grhss - -- pat fvs were stored in bind_fvs - -- after processing the LHS - , bind_fvs = pat_fvs }) - = do { mod <- getModule - ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss - - -- No scoped type variables for pattern bindings - ; let all_fvs = pat_fvs `plusFV` rhs_fvs - fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - bndrs = collectPatBinders pat - bind' = bind { pat_rhs = grhss', - pat_rhs_ty = placeHolderType, bind_fvs = fvs' } - is_wild_pat = case pat of - L _ (WildPat {}) -> True - L _ (BangPat (L _ (WildPat {}))) -> True -- #9127 - _ -> False - - -- Warn if the pattern binds no variables, except for the - -- entirely-explicit idiom _ = rhs - -- which (a) is not that different from _v = rhs - -- (b) is sometimes used to give a type sig for, - -- or an occurrence of, a variable on the RHS - ; whenWOptM Opt_WarnUnusedPatternBinds $ - when (null bndrs && not is_wild_pat) $ - addWarn (Reason Opt_WarnUnusedPatternBinds) $ unusedPatBindWarn bind' - - ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind', bndrs, all_fvs) } - -rnBind sig_fn bind@(FunBind { fun_id = name - , fun_matches = matches }) - -- invariant: no free vars here when it's a FunBind - = do { let plain_name = unLoc name - - ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ - -- bindSigTyVars tests for LangExt.ScopedTyVars - rnMatchGroup (mkPrefixFunRhs name) - rnLExpr matches - ; let is_infix = isInfixFunBind bind - ; when is_infix $ checkPrecMatch plain_name matches' - - ; mod <- getModule - ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - - ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind { fun_matches = matches' - , bind_fvs = fvs' }, - [plain_name], rhs_fvs) - } - -rnBind sig_fn (PatSynBind bind) - = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind - ; return (PatSynBind bind', name, fvs) } - -rnBind _ b = pprPanic "rnBind" (ppr b) - -{- -Note [Free-variable space leak] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have - fvs' = trim fvs -and we seq fvs' before turning it as part of a record. - -The reason is that trim is sometimes something like - \xs -> intersectNameSet (mkNameSet bound_names) xs -and we don't want to retain the list bound_names. This showed up in -trac ticket #1136. --} - -{- ********************************************************************* -* * - Dependency analysis and other support functions -* * -********************************************************************* -} - -depAnalBinds :: Bag (LHsBind Name, [Name], Uses) - -> ([(RecFlag, LHsBinds Name)], DefUses) --- Dependency analysis; this is important so that --- unused-binding reporting is accurate -depAnalBinds binds_w_dus - = (map get_binds sccs, map get_du sccs) - where - sccs = depAnal (\(_, defs, _) -> defs) - (\(_, _, uses) -> nonDetEltsUniqSet uses) - -- It's OK to use nonDetEltsUniqSet here as explained in - -- Note [depAnal determinism] in NameEnv. - (bagToList binds_w_dus) - - get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) - get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus]) - - get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) - get_du (CyclicSCC binds_w_dus) = (Just defs, uses) - where - defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] - uses = unionNameSets [u | (_,_,u) <- binds_w_dus] - ---------------------- --- Bind the top-level forall'd type variables in the sigs. --- E.g f :: a -> a --- f = rhs --- The 'a' scopes over the rhs --- --- NB: there'll usually be just one (for a function binding) --- but if there are many, one may shadow the rest; too bad! --- e.g x :: [a] -> [a] --- y :: [(a,a)] -> a --- (x,y) = e --- In e, 'a' will be in scope, and it'll be the one from 'y'! - -mkSigTvFn :: [LSig Name] -> (Name -> [Name]) --- Return a lookup function that maps an Id Name to the names --- of the type variables that should scope over its body. -mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] - where - env = mkHsSigEnv get_scoped_tvs sigs - - get_scoped_tvs :: LSig Name -> Maybe ([Located Name], [Name]) - -- Returns (binders, scoped tvs for those binders) - get_scoped_tvs (L _ (ClassOpSig _ names sig_ty)) - = Just (names, hsScopedTvs sig_ty) - get_scoped_tvs (L _ (TypeSig names sig_ty)) - = Just (names, hsWcScopedTvs sig_ty) - get_scoped_tvs (L _ (PatSynSig names sig_ty)) - = Just (names, hsScopedTvs sig_ty) - get_scoped_tvs _ = Nothing - --- Process the fixity declarations, making a FastString -> (Located Fixity) map --- (We keep the location around for reporting duplicate fixity declarations.) --- --- Checks for duplicates, but not that only locally defined things are fixed. --- Note: for local fixity declarations, duplicates would also be checked in --- check_sigs below. But we also use this function at the top level. - -makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv - -makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls - where - add_one_sig env (L loc (FixitySig names fixity)) = - foldlM add_one env [ (loc,name_loc,name,fixity) - | L name_loc name <- names ] - - add_one env (loc, name_loc, name,fixity) = do - { -- this fixity decl is a duplicate iff - -- the ReaderName's OccName's FastString is already in the env - -- (we only need to check the local fix_env because - -- definitions of non-local will be caught elsewhere) - let { fs = occNameFS (rdrNameOcc name) - ; fix_item = L loc fixity }; - - case lookupFsEnv env fs of - Nothing -> return $ extendFsEnv env fs fix_item - Just (L loc' _) -> do - { setSrcSpan loc $ - addErrAt name_loc (dupFixityDecl loc' name) - ; return env} - } - -dupFixityDecl :: SrcSpan -> RdrName -> SDoc -dupFixityDecl loc rdr_name - = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr loc] - - -{- ********************************************************************* -* * - Pattern synonym bindings -* * -********************************************************************* -} - -rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function - -> PatSynBind Name RdrName - -> RnM (PatSynBind Name Name, [Name], Uses) -rnPatSynBind sig_fn bind@(PSB { psb_id = L l name - , psb_args = details - , psb_def = pat - , psb_dir = dir }) - -- invariant: no free vars here when it's a FunBind - = do { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms - ; unless pattern_synonym_ok (addErr patternSynonymErr) - ; let sig_tvs = sig_fn name - - ; ((pat', details'), fvs1) <- bindSigTyVarsFV sig_tvs $ - rnPat PatSyn pat $ \pat' -> - -- We check the 'RdrName's instead of the 'Name's - -- so that the binding locations are reported - -- from the left-hand side - case details of - PrefixPatSyn vars -> - do { checkDupRdrNames vars - ; names <- mapM lookupVar vars - ; return ( (pat', PrefixPatSyn names) - , mkFVs (map unLoc names)) } - InfixPatSyn var1 var2 -> - do { checkDupRdrNames [var1, var2] - ; name1 <- lookupVar var1 - ; name2 <- lookupVar var2 - -- ; checkPrecMatch -- TODO - ; return ( (pat', InfixPatSyn name1 name2) - , mkFVs (map unLoc [name1, name2])) } - RecordPatSyn vars -> - do { checkDupRdrNames (map recordPatSynSelectorId vars) - ; let rnRecordPatSynField - (RecordPatSynField { recordPatSynSelectorId = visible - , recordPatSynPatVar = hidden }) - = do { visible' <- lookupLocatedTopBndrRn visible - ; hidden' <- lookupVar hidden - ; return $ RecordPatSynField { recordPatSynSelectorId = visible' - , recordPatSynPatVar = hidden' } } - ; names <- mapM rnRecordPatSynField vars - ; return ( (pat', RecordPatSyn names) - , mkFVs (map (unLoc . recordPatSynPatVar) names)) } - - ; (dir', fvs2) <- case dir of - Unidirectional -> return (Unidirectional, emptyFVs) - ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) - ExplicitBidirectional mg -> - do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $ - rnMatchGroup (mkPrefixFunRhs (L l name)) - rnLExpr mg - ; return (ExplicitBidirectional mg', fvs) } - - ; mod <- getModule - ; let fvs = fvs1 `plusFV` fvs2 - fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - - bind' = bind{ psb_args = details' - , psb_def = pat' - , psb_dir = dir' - , psb_fvs = fvs' } - selector_names = case details' of - RecordPatSyn names -> - map (unLoc . recordPatSynSelectorId) names - _ -> [] - - ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind', name : selector_names , fvs1) - -- Why fvs1? See Note [Pattern synonym builders don't yield dependencies] - } - where - lookupVar = wrapLocM lookupOccRn - - patternSynonymErr :: SDoc - patternSynonymErr - = hang (text "Illegal pattern synonym declaration") - 2 (text "Use -XPatternSynonyms to enable this extension") - -{- -Note [Pattern synonym builders don't yield dependencies] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When renaming a pattern synonym that has an explicit builder, -references in the builder definition should not be used when -calculating dependencies. For example, consider the following pattern -synonym definition: - -pattern P x <- C1 x where - P x = f (C1 x) - -f (P x) = C2 x - -In this case, 'P' needs to be typechecked in two passes: - -1. Typecheck the pattern definition of 'P', which fully determines the - type of 'P'. This step doesn't require knowing anything about 'f', - since the builder definition is not looked at. - -2. Typecheck the builder definition, which needs the typechecked - definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind - in TcBinds.tcValBinds. - -This behaviour is implemented in 'tcValBinds', but it crucially -depends on 'P' not being put in a recursive group with 'f' (which -would make it look like a recursive pattern synonym a la 'pattern P = -P' which is unsound and rejected). - -So: - * We do not include builder fvs in the Uses returned by rnPatSynBind - (which is then used for dependency analysis) - * But we /do/ include them in the psb_fvs for the PatSynBind - * In rnValBinds we record these builder uses, to avoid bogus - unused-variable warnings (Trac #12548) --} - -{- ********************************************************************* -* * - Class/instance method bindings -* * -********************************************************************* -} - -{- @rnMethodBinds@ is used for the method bindings of a class and an instance -declaration. Like @rnBinds@ but without dependency analysis. - -NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. -That's crucial when dealing with an instance decl: -\begin{verbatim} - instance Foo (T a) where - op x = ... -\end{verbatim} -This might be the {\em sole} occurrence of @op@ for an imported class @Foo@, -and unless @op@ occurs we won't treat the type signature of @op@ in the class -decl for @Foo@ as a source of instance-decl gates. But we should! Indeed, -in many ways the @op@ in an instance decl is just like an occurrence, not -a binder. --} - -rnMethodBinds :: Bool -- True <=> is a class declaration - -> Name -- Class name - -> [Name] -- Type variables from the class/instance header - -> LHsBinds RdrName -- Binds - -> [LSig RdrName] -- and signatures/pragmas - -> RnM (LHsBinds Name, [LSig Name], FreeVars) --- Used for --- * the default method bindings in a class decl --- * the method bindings in an instance decl -rnMethodBinds is_cls_decl cls ktv_names binds sigs - = do { checkDupRdrNames (collectMethodBinders binds) - -- Check that the same method is not given twice in the - -- same instance decl instance C T where - -- f x = ... - -- g y = ... - -- f x = ... - -- We must use checkDupRdrNames because the Name of the - -- method is the Name of the class selector, whose SrcSpan - -- points to the class declaration; and we use rnMethodBinds - -- for instance decls too - - -- Rename the bindings LHSs - ; binds' <- foldrBagM (rnMethodBindLHS is_cls_decl cls) emptyBag binds - - -- Rename the pragmas and signatures - -- Annoyingly the type variables /are/ in scope for signatures, but - -- /are not/ in scope in the SPECIALISE instance pramas; e.g. - -- instance Eq a => Eq (T a) where - -- (==) :: a -> a -> a - -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} - ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs - bound_nms = mkNameSet (collectHsBindsBinders binds') - sig_ctxt | is_cls_decl = ClsDeclCtxt cls - | otherwise = InstDeclCtxt bound_nms - ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags - ; (other_sigs', sig_fvs) <- extendTyVarEnvFVRn ktv_names $ - renameSigs sig_ctxt other_sigs - - -- Rename the bindings RHSs. Again there's an issue about whether the - -- type variables from the class/instance head are in scope. - -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables - ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables - ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $ - do { binds_w_dus <- mapBagM (rnLBind (mkSigTvFn other_sigs')) binds' - ; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2) - emptyFVs binds_w_dus - ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } - - ; return ( binds'', spec_inst_prags' ++ other_sigs' - , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) } - where - -- For the method bindings in class and instance decls, we extend - -- the type variable environment iff -XScopedTypeVariables - maybe_extend_tyvar_env scoped_tvs thing_inside - | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside - | otherwise = thing_inside - -rnMethodBindLHS :: Bool -> Name - -> LHsBindLR RdrName RdrName - -> LHsBindsLR Name RdrName - -> RnM (LHsBindsLR Name RdrName) -rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest - = setSrcSpan loc $ do - do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name - -- We use the selector name as the binder - ; let bind' = bind { fun_id = sel_name - , bind_fvs = placeHolderNamesTc } - - ; return (L loc bind' `consBag` rest ) } - --- Report error for all other forms of bindings --- This is why we use a fold rather than map -rnMethodBindLHS is_cls_decl _ (L loc bind) rest - = do { addErrAt loc $ - vcat [ what <+> text "not allowed in" <+> decl_sort - , nest 2 (ppr bind) ] - ; return rest } - where - decl_sort | is_cls_decl = text "class declaration:" - | otherwise = text "instance declaration:" - what = case bind of - PatBind {} -> text "Pattern bindings (except simple variables)" - PatSynBind {} -> text "Pattern synonyms" - -- Associated pattern synonyms are not implemented yet - _ -> pprPanic "rnMethodBind" (ppr bind) - -{- -************************************************************************ -* * -\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} -* * -************************************************************************ - -@renameSigs@ checks for: -\begin{enumerate} -\item more than one sig for one thing; -\item signatures given for things not bound here; -\end{enumerate} - -At the moment we don't gather free-var info from the types in -signatures. We'd only need this if we wanted to report unused tyvars. --} - -renameSigs :: HsSigCtxt - -> [LSig RdrName] - -> RnM ([LSig Name], FreeVars) --- Renames the signatures and performs error checks -renameSigs ctxt sigs - = do { mapM_ dupSigDeclErr (findDupSigs sigs) - - ; checkDupMinimalSigs sigs - - ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs - - ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' - ; mapM_ misplacedSigErr bad_sigs -- Misplaced - - ; return (good_sigs, sig_fvs) } - ----------------------- --- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory --- because this won't work for: --- instance Foo T where --- {-# INLINE op #-} --- Baz.op = ... --- We'll just rename the INLINE prag to refer to whatever other 'op' --- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) --- Doesn't seem worth much trouble to sort this. - -renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars) --- FixitySig is renamed elsewhere. -renameSig _ (IdSig x) - = return (IdSig x, emptyFVs) -- Actually this never occurs - -renameSig ctxt sig@(TypeSig vs ty) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; let doc = TypeSigCtx (ppr_sig_bndrs vs) - ; (new_ty, fvs) <- rnHsSigWcType doc ty - ; return (TypeSig new_vs new_ty, fvs) } - -renameSig ctxt sig@(ClassOpSig is_deflt vs ty) - = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures - ; when (is_deflt && not defaultSigs_on) $ - addErr (defaultSigErr sig) - ; new_v <- mapM (lookupSigOccRn ctxt sig) vs - ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty - ; return (ClassOpSig is_deflt new_v new_ty, fvs) } - where - (v1:_) = vs - ty_ctxt = GenericCtx (text "a class method signature for" - <+> quotes (ppr v1)) - -renameSig _ (SpecInstSig src ty) - = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty - ; return (SpecInstSig src new_ty,fvs) } - --- {-# SPECIALISE #-} pragmas can refer to imported Ids --- so, in the top-level case (when mb_names is Nothing) --- we use lookupOccRn. If there's both an imported and a local 'f' --- then the SPECIALISE pragma is ambiguous, unlike all other signatures -renameSig ctxt sig@(SpecSig v tys inl) - = do { new_v <- case ctxt of - TopSigCtxt {} -> lookupLocatedOccRn v - _ -> lookupSigOccRn ctxt sig v - ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys - ; return (SpecSig new_v new_ty inl, fvs) } - where - ty_ctxt = GenericCtx (text "a SPECIALISE signature for" - <+> quotes (ppr v)) - do_one (tys,fvs) ty - = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty - ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } - -renameSig ctxt sig@(InlineSig v s) - = do { new_v <- lookupSigOccRn ctxt sig v - ; return (InlineSig new_v s, emptyFVs) } - -renameSig ctxt sig@(FixSig (FixitySig vs f)) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; return (FixSig (FixitySig new_vs f), emptyFVs) } - -renameSig ctxt sig@(MinimalSig s (L l bf)) - = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf - return (MinimalSig s (L l new_bf), emptyFVs) - -renameSig ctxt sig@(PatSynSig vs ty) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; (ty', fvs) <- rnHsSigType ty_ctxt ty - ; return (PatSynSig new_vs ty', fvs) } - where - ty_ctxt = GenericCtx (text "a pattern synonym signature for" - <+> ppr_sig_bndrs vs) - -renameSig ctxt sig@(SCCFunSig st v s) - = do { new_v <- lookupSigOccRn ctxt sig v - ; return (SCCFunSig st new_v s, emptyFVs) } - --- COMPLETE Sigs can refer to imported IDs which is why we use --- lookupLocatedOccRn rather than lookupSigOccRn -renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty) - = do new_bf <- traverse lookupLocatedOccRn bf - new_mty <- traverse lookupLocatedOccRn mty - - this_mod <- fmap tcg_mod getGblEnv - unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do - -- Why 'any'? See Note [Orphan COMPLETE pragmas] - addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError - - return (CompleteMatchSig s (L l new_bf) new_mty, emptyFVs) - where - orphanError :: SDoc - orphanError = - text "Orphan COMPLETE pragmas not supported" $$ - text "A COMPLETE pragma must mention at least one data constructor" $$ - text "or pattern synonym defined in the same module." - -{- -Note [Orphan COMPLETE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We define a COMPLETE pragma to be a non-orphan if it includes at least -one conlike defined in the current module. Why is this sufficient? -Well if you have a pattern match - - case expr of - P1 -> ... - P2 -> ... - P3 -> ... - -any COMPLETE pragma which mentions a conlike other than P1, P2 or P3 -will not be of any use in verifying that the pattern match is -exhaustive. So as we have certainly read the interface files that -define P1, P2 and P3, we will have loaded all non-orphan COMPLETE -pragmas that could be relevant to this pattern match. - -For now we simply disallow orphan COMPLETE pragmas, as the added -complexity of supporting them properly doesn't seem worthwhile. --} - -ppr_sig_bndrs :: [Located RdrName] -> SDoc -ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) - -okHsSig :: HsSigCtxt -> LSig a -> Bool -okHsSig ctxt (L _ sig) - = case (sig, ctxt) of - (ClassOpSig {}, ClsDeclCtxt {}) -> True - (ClassOpSig {}, InstDeclCtxt {}) -> True - (ClassOpSig {}, _) -> False - - (TypeSig {}, ClsDeclCtxt {}) -> False - (TypeSig {}, InstDeclCtxt {}) -> False - (TypeSig {}, _) -> True - - (PatSynSig {}, TopSigCtxt{}) -> True - (PatSynSig {}, _) -> False - - (FixSig {}, InstDeclCtxt {}) -> False - (FixSig {}, _) -> True - - (IdSig {}, TopSigCtxt {}) -> True - (IdSig {}, InstDeclCtxt {}) -> True - (IdSig {}, _) -> False - - (InlineSig {}, HsBootCtxt {}) -> False - (InlineSig {}, _) -> True - - (SpecSig {}, TopSigCtxt {}) -> True - (SpecSig {}, LocalBindCtxt {}) -> True - (SpecSig {}, InstDeclCtxt {}) -> True - (SpecSig {}, _) -> False - - (SpecInstSig {}, InstDeclCtxt {}) -> True - (SpecInstSig {}, _) -> False - - (MinimalSig {}, ClsDeclCtxt {}) -> True - (MinimalSig {}, _) -> False - - (SCCFunSig {}, HsBootCtxt {}) -> False - (SCCFunSig {}, _) -> True - - (CompleteMatchSig {}, TopSigCtxt {} ) -> True - (CompleteMatchSig {}, _) -> False - -------------------- -findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]] --- Check for duplicates on RdrName version, --- because renamed version has unboundName for --- not-in-scope binders, which gives bogus dup-sig errors --- NB: in a class decl, a 'generic' sig is not considered --- equal to an ordinary sig, so we allow, say --- class C a where --- op :: a -> a --- default op :: Eq a => a -> a -findDupSigs sigs - = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) - where - expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig) - expand_sig sig@(InlineSig n _) = [(n,sig)] - expand_sig sig@(TypeSig ns _) = [(n,sig) | n <- ns] - expand_sig sig@(ClassOpSig _ ns _) = [(n,sig) | n <- ns] - expand_sig sig@(PatSynSig ns _ ) = [(n,sig) | n <- ns] - expand_sig sig@(SCCFunSig _ n _) = [(n,sig)] - expand_sig _ = [] - - matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 - mtch (FixSig {}) (FixSig {}) = True - mtch (InlineSig {}) (InlineSig {}) = True - mtch (TypeSig {}) (TypeSig {}) = True - mtch (ClassOpSig d1 _ _) (ClassOpSig d2 _ _) = d1 == d2 - mtch (PatSynSig _ _) (PatSynSig _ _) = True - mtch (SCCFunSig{}) (SCCFunSig{}) = True - mtch _ _ = False - --- Warn about multiple MINIMAL signatures -checkDupMinimalSigs :: [LSig RdrName] -> RnM () -checkDupMinimalSigs sigs - = case filter isMinimalLSig sigs of - minSigs@(_:_:_) -> dupMinimalSigErr minSigs - _ -> return () - -{- -************************************************************************ -* * -\subsection{Match} -* * -************************************************************************ --} - -rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> MatchGroup RdrName (Located (body RdrName)) - -> RnM (MatchGroup Name (Located (body Name)), FreeVars) -rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) - = do { empty_case_ok <- xoptM LangExt.EmptyCase - ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) - ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms - ; return (mkMatchGroup origin new_ms, ms_fvs) } - -rnMatch :: Outputable (body RdrName) => HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> LMatch RdrName (Located (body RdrName)) - -> RnM (LMatch Name (Located (body Name)), FreeVars) -rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) - -rnMatch' :: Outputable (body RdrName) => HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> Match RdrName (Located (body RdrName)) - -> RnM (Match Name (Located (body Name)), FreeVars) -rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats - , m_type = maybe_rhs_sig, m_grhss = grhss }) - = do { -- Result type signatures are no longer supported - case maybe_rhs_sig of - Nothing -> return () - Just (L loc ty) -> addErrAt loc (resSigErr match ty) - - ; let fixity = if isInfixMatch match then Infix else Prefix - -- Now the main event - -- Note that there are no local fixity decls for matches - ; rnPats ctxt pats $ \ pats' -> do - { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss - ; let mf' = case (ctxt,mf) of - (FunRhs (L _ funid) _ _,FunRhs (L lf _) _ strict) - -> FunRhs (L lf funid) fixity strict - _ -> ctxt - ; return (Match { m_ctxt = mf', m_pats = pats' - , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }} - -emptyCaseErr :: HsMatchContext Name -> SDoc -emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) - 2 (text "Use EmptyCase to allow this") - where - pp_ctxt = case ctxt of - CaseAlt -> text "case expression" - LambdaExpr -> text "\\case expression" - _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt - - -resSigErr :: Outputable body - => Match RdrName body -> HsType RdrName -> SDoc -resSigErr match ty - = vcat [ text "Illegal result type signature" <+> quotes (ppr ty) - , nest 2 $ ptext (sLit - "Result signatures are no longer supported in pattern matches") - , pprMatchInCtxt match ] - -{- -************************************************************************ -* * -\subsubsection{Guarded right-hand sides (GRHSs)} -* * -************************************************************************ --} - -rnGRHSs :: HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> GRHSs RdrName (Located (body RdrName)) - -> RnM (GRHSs Name (Located (body Name)), FreeVars) -rnGRHSs ctxt rnBody (GRHSs grhss (L l binds)) - = rnLocalBindsAndThen binds $ \ binds' _ -> do - (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss - return (GRHSs grhss' (L l binds'), fvGRHSs) - -rnGRHS :: HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> LGRHS RdrName (Located (body RdrName)) - -> RnM (LGRHS Name (Located (body Name)), FreeVars) -rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) - -rnGRHS' :: HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> GRHS RdrName (Located (body RdrName)) - -> RnM (GRHS Name (Located (body Name)), FreeVars) -rnGRHS' ctxt rnBody (GRHS guards rhs) - = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards - ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> - rnBody rhs - - ; unless (pattern_guards_allowed || is_standard_guard guards') - (addWarn NoReason (nonStdGuardErr guards')) - - ; return (GRHS guards' rhs', fvs) } - where - -- Standard Haskell 1.4 guards are just a single boolean - -- expression, rather than a list of qualifiers as in the - -- Glasgow extension - is_standard_guard [] = True - is_standard_guard [L _ (BodyStmt _ _ _ _)] = True - is_standard_guard _ = False - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM () -dupSigDeclErr pairs@((L loc name, sig) : _) - = addErrAt loc $ - vcat [ text "Duplicate" <+> what_it_is - <> text "s for" <+> quotes (ppr name) - , text "at" <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ] - where - what_it_is = hsSigDoc sig - -dupSigDeclErr [] = panic "dupSigDeclErr" - -misplacedSigErr :: LSig Name -> RnM () -misplacedSigErr (L loc sig) - = addErrAt loc $ - sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] - -defaultSigErr :: Sig RdrName -> SDoc -defaultSigErr sig = vcat [ hang (text "Unexpected default signature:") - 2 (ppr sig) - , text "Use DefaultSignatures to enable default signatures" ] - -bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc -bindsInHsBootFile mbinds - = hang (text "Bindings in hs-boot files are not allowed") - 2 (ppr mbinds) - -nonStdGuardErr :: Outputable body => [LStmtLR Name Name body] -> SDoc -nonStdGuardErr guards - = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") - 4 (interpp'SP guards) - -unusedPatBindWarn :: HsBind Name -> SDoc -unusedPatBindWarn bind - = hang (text "This pattern-binding binds no variables:") - 2 (ppr bind) - -dupMinimalSigErr :: [LSig RdrName] -> RnM () -dupMinimalSigErr sigs@(L loc _ : _) - = addErrAt loc $ - vcat [ text "Multiple minimal complete definitions" - , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs) - , text "Combine alternative minimal complete definitions with `|'" ] -dupMinimalSigErr [] = panic "dupMinimalSigErr" diff --git a/rename/RnEnv.hs b/rename/RnEnv.hs deleted file mode 100644 --- a/rename/RnEnv.hs +++ /dev/null @@ -1,2350 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-2006 - -\section[RnEnv]{Environment manipulation for the renamer monad} --} - -{-# LANGUAGE CPP, MultiWayIf #-} - -module RnEnv ( - newTopSrcBinder, - lookupLocatedTopBndrRn, lookupTopBndrRn, - lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe, - lookupLocalOccRn_maybe, lookupInfoOccRn, - lookupLocalOccThLvl_maybe, - lookupTypeOccRn, lookupKindOccRn, - lookupGlobalOccRn, lookupGlobalOccRn_maybe, - lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc, - reportUnboundName, unknownNameSuggestions, - addNameClashErrRn, - - HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, - lookupSigCtxtOccRn, - - lookupFixityRn, lookupFixityRn_help, - lookupFieldFixityRn, lookupTyFixityRn, - lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName, - lookupConstructorFields, - lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames, - lookupIfThenElse, - lookupGreAvailRn, - getLookupOccRn,mkUnboundName, mkUnboundNameRdr, isUnboundName, - addUsedGRE, addUsedGREs, addUsedDataCons, - - newLocalBndrRn, newLocalBndrsRn, - bindLocalNames, bindLocalNamesFV, - MiniFixityEnv, - addLocalFixities, - bindLocatedLocalsFV, bindLocatedLocalsRn, - extendTyVarEnvFVRn, - - -- Role annotations - RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, - lookupRoleAnnot, getRoleAnnots, - - checkDupRdrNames, checkShadowedRdrNames, - checkDupNames, checkDupAndShadowedNames, dupNamesErr, - checkTupSize, - addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, - warnUnusedMatches, warnUnusedTypePatterns, - warnUnusedTopBinds, warnUnusedLocalBinds, - mkFieldEnv, - dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr, - HsDocContext(..), pprHsDocContext, - inHsDocContext, withHsDocContext - ) where - -#include "HsVersions.h" - -import LoadIface ( loadInterfaceForName, loadSrcInterface_maybe ) -import IfaceEnv -import HsSyn -import RdrName -import HscTypes -import TcEnv -import TcRnMonad -import RdrHsSyn ( setRdrNameSpace ) -import TysWiredIn ( starKindTyConName, unicodeStarKindTyConName ) -import Name -import NameSet -import NameEnv -import Avail -import Module -import ConLike -import DataCon -import TyCon -import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR ) -import ErrUtils ( MsgDoc ) -import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, - defaultFixity, pprWarningTxtForMsg, SourceText(..) ) -import SrcLoc -import Outputable -import Util -import Maybes -import BasicTypes ( TopLevelFlag(..) ) -import ListSetOps ( removeDups ) -import DynFlags -import FastString -import Control.Monad -import Data.List -import Data.Function ( on ) -import ListSetOps ( minusList ) -import Constants ( mAX_TUPLE_SIZE ) -import qualified GHC.LanguageExtensions as LangExt -import Data.Maybe (isJust) - -{- -********************************************************* -* * - Source-code binders -* * -********************************************************* - -Note [Signature lazy interface loading] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GHC's lazy interface loading can be a bit confusing, so this Note is an -empirical description of what happens in one interesting case. When -compiling a signature module against an its implementation, we do NOT -load interface files associated with its names until after the type -checking phase. For example: - - module ASig where - data T - f :: T -> T - -Suppose we compile this with -sig-of "A is ASig": - - module B where - data T = T - f T = T - - module A(module B) where - import B - -During type checking, we'll load A.hi because we need to know what the -RdrEnv for the module is, but we DO NOT load the interface for B.hi! -It's wholly unnecessary: our local definition 'data T' in ASig is all -the information we need to finish type checking. This is contrast to -type checking of ordinary Haskell files, in which we would not have the -local definition "data T" and would need to consult B.hi immediately. -(Also, this situation never occurs for hs-boot files, since you're not -allowed to reexport from another module.) - -After type checking, we then check that the types we provided are -consistent with the backing implementation (in checkHiBootOrHsigIface). -At this point, B.hi is loaded, because we need something to compare -against. - -I discovered this behavior when trying to figure out why type class -instances for Data.Map weren't in the EPS when I was type checking a -test very much like ASig (sigof02dm): the associated interface hadn't -been loaded yet! (The larger issue is a moot point, since an instance -declared in a signature can never be a duplicate.) - -This behavior might change in the future. Consider this -alternate module B: - - module B where - {-# DEPRECATED T, f "Don't use" #-} - data T = T - f T = T - -One might conceivably want to report deprecation warnings when compiling -ASig with -sig-of B, in which case we need to look at B.hi to find the -deprecation warnings during renaming. At the moment, you don't get any -warning until you use the identifier further downstream. This would -require adjusting addUsedGRE so that during signature compilation, -we do not report deprecation warnings for LocalDef. See also -Note [Handling of deprecations] --} - -newTopSrcBinder :: Located RdrName -> RnM Name -newTopSrcBinder (L loc rdr_name) - | Just name <- isExact_maybe rdr_name - = -- This is here to catch - -- (a) Exact-name binders created by Template Haskell - -- (b) The PrelBase defn of (say) [] and similar, for which - -- the parser reads the special syntax and returns an Exact RdrName - -- We are at a binding site for the name, so check first that it - -- the current module is the correct one; otherwise GHC can get - -- very confused indeed. This test rejects code like - -- data T = (,) Int Int - -- unless we are in GHC.Tup - if isExternalName name then - do { this_mod <- getModule - ; unless (this_mod == nameModule name) - (addErrAt loc (badOrigBinding rdr_name)) - ; return name } - else -- See Note [Binders in Template Haskell] in Convert.hs - do { this_mod <- getModule - ; externaliseName this_mod name } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { this_mod <- getModule - ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) - (addErrAt loc (badOrigBinding rdr_name)) - -- When reading External Core we get Orig names as binders, - -- but they should agree with the module gotten from the monad - -- - -- We can get built-in syntax showing up here too, sadly. If you type - -- data T = (,,,) - -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon - -- uses setRdrNameSpace to make it into a data constructors. At that point - -- the nice Exact name for the TyCon gets swizzled to an Orig name. - -- Hence the badOrigBinding error message. - -- - -- Except for the ":Main.main = ..." definition inserted into - -- the Main module; ugh! - - -- Because of this latter case, we call newGlobalBinder with a module from - -- the RdrName, not from the environment. In principle, it'd be fine to - -- have an arbitrary mixture of external core definitions in a single module, - -- (apart from module-initialisation issues, perhaps). - ; newGlobalBinder rdr_mod rdr_occ loc } - - | otherwise - = do { unless (not (isQual rdr_name)) - (addErrAt loc (badQualBndrErr rdr_name)) - -- Binders should not be qualified; if they are, and with a different - -- module name, we we get a confusing "M.T is not in scope" error later - - ; stage <- getStage - ; if isBrackStage stage then - -- We are inside a TH bracket, so make an *Internal* name - -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames - do { uniq <- newUnique - ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } - else - do { this_mod <- getModule - ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc) - ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } - } - -{- -********************************************************* -* * - Source code occurrences -* * -********************************************************* - -Looking up a name in the RnEnv. - -Note [Type and class operator definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to reject all of these unless we have -XTypeOperators (Trac #3265) - data a :*: b = ... - class a :*: b where ... - data (:*:) a b = .... - class (:*:) a b where ... -The latter two mean that we are not just looking for a -*syntactically-infix* declaration, but one that uses an operator -OccName. We use OccName.isSymOcc to detect that case, which isn't -terribly efficient, but there seems to be no better way. --} - -lookupTopBndrRn :: RdrName -> RnM Name -lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n - case nopt of - Just n' -> return n' - Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n) - unboundName WL_LocalTop n - -lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) -lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn - -lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name) --- Look up a top-level source-code binder. We may be looking up an unqualified 'f', --- and there may be several imported 'f's too, which must not confuse us. --- For example, this is OK: --- import Foo( f ) --- infix 9 f -- The 'f' here does not need to be qualified --- f x = x -- Nor here, of course --- So we have to filter out the non-local ones. --- --- A separate function (importsFromLocalDecls) reports duplicate top level --- decls, so here it's safe just to choose an arbitrary one. --- --- There should never be a qualified name in a binding position in Haskell, --- but there can be if we have read in an external-Core file. --- The Haskell parser checks for the illegal qualified name in Haskell --- source files, so we don't need to do so here. - -lookupTopBndrRn_maybe rdr_name - | Just name <- isExact_maybe rdr_name - = do { name' <- lookupExactOcc name; return (Just name') } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - -- This deals with the case of derived bindings, where - -- we don't bother to call newTopSrcBinder first - -- We assume there is no "parent" name - = do { loc <- getSrcSpanM - ; n <- newGlobalBinder rdr_mod rdr_occ loc - ; return (Just n)} - - | otherwise - = do { -- Check for operators in type or class declarations - -- See Note [Type and class operator definitions] - let occ = rdrNameOcc rdr_name - ; when (isTcOcc occ && isSymOcc occ) - (do { op_ok <- xoptM LangExt.TypeOperators - ; unless op_ok (addErr (opDeclErr rdr_name)) }) - - ; env <- getGlobalRdrEnv - ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of - [gre] -> return (Just (gre_name gre)) - _ -> return Nothing -- Ambiguous (can't happen) or unbound - } - ------------------------------------------------ --- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. --- This adds an error if the name cannot be found. -lookupExactOcc :: Name -> RnM Name -lookupExactOcc name - = do { result <- lookupExactOcc_either name - ; case result of - Left err -> do { addErr err - ; return name } - Right name' -> return name' } - --- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. --- This never adds an error, but it may return one. -lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name) --- See Note [Looking up Exact RdrNames] -lookupExactOcc_either name - | Just thing <- wiredInNameTyThing_maybe name - , Just tycon <- case thing of - ATyCon tc -> Just tc - AConLike (RealDataCon dc) -> Just (dataConTyCon dc) - _ -> Nothing - , isTupleTyCon tycon - = do { checkTupSize (tyConArity tycon) - ; return (Right name) } - - | isExternalName name - = return (Right name) - - | otherwise - = do { env <- getGlobalRdrEnv - ; let -- See Note [Splicing Exact names] - main_occ = nameOccName name - demoted_occs = case demoteOccName main_occ of - Just occ -> [occ] - Nothing -> [] - gres = [ gre | occ <- main_occ : demoted_occs - , gre <- lookupGlobalRdrEnv env occ - , gre_name gre == name ] - ; case gres of - [gre] -> return (Right (gre_name gre)) - - [] -> -- See Note [Splicing Exact names] - do { lcl_env <- getLocalRdrEnv - ; if name `inLocalRdrEnvScope` lcl_env - then return (Right name) - else - do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; th_topnames <- readTcRef th_topnames_var - ; if name `elemNameSet` th_topnames - then return (Right name) - else return (Left exact_nm_err) - } - } - gres -> return (Left (sameNameErr gres)) -- Ugh! See Note [Template Haskell ambiguity] - } - where - exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope")) - 2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), " - , text "perhaps via newName, but did not bind it" - , text "If that's it, then -ddump-splices might be useful" ]) - -sameNameErr :: [GlobalRdrElt] -> MsgDoc -sameNameErr [] = panic "addSameNameErr: empty list" -sameNameErr gres@(_ : _) - = hang (text "Same exact name in multiple name-spaces:") - 2 (vcat (map pp_one sorted_names) $$ th_hint) - where - sorted_names = sortWith nameSrcLoc (map gre_name gres) - pp_one name - = hang (pprNameSpace (occNameSpace (getOccName name)) - <+> quotes (ppr name) <> comma) - 2 (text "declared at:" <+> ppr (nameSrcLoc name)) - - th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU)," - , text "perhaps via newName, in different name-spaces." - , text "If that's it, then -ddump-splices might be useful" ] - - ------------------------------------------------ -lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name --- This is called on the method name on the left-hand side of an --- instance declaration binding. eg. instance Functor T where --- fmap = ... --- ^^^^ called on this --- Regardless of how many unqualified fmaps are in scope, we want --- the one that comes from the Functor class. --- --- Furthermore, note that we take no account of whether the --- name is only in scope qualified. I.e. even if method op is --- in scope as M.op, we still allow plain 'op' on the LHS of --- an instance decl --- --- The "what" parameter says "method" or "associated type", --- depending on what we are looking up -lookupInstDeclBndr cls what rdr - = do { when (isQual rdr) - (addErr (badQualBndrErr rdr)) - -- In an instance decl you aren't allowed - -- to use a qualified name for the method - -- (Although it'd make perfect sense.) - ; mb_name <- lookupSubBndrOcc - False -- False => we don't give deprecated - -- warnings when a deprecated class - -- method is defined. We only warn - -- when it's used - cls doc rdr - ; case mb_name of - Left err -> do { addErr err; return (mkUnboundNameRdr rdr) } - Right nm -> return nm } - where - doc = what <+> text "of class" <+> quotes (ppr cls) - - ------------------------------------------------ -lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name) --- Used for TyData and TySynonym family instances only, --- See Note [Family instance binders] -lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f RnBinds.rnMethodBind - = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr -lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* - = lookupLocatedOccRn tc_rdr - ------------------------------------------------ -lookupConstructorFields :: Name -> RnM [FieldLabel] --- Look up the fields of a given constructor --- * For constructors from this module, use the record field env, --- which is itself gathered from the (as yet un-typechecked) --- data type decls --- --- * For constructors from imported modules, use the *type* environment --- since imported modles are already compiled, the info is conveniently --- right there - -lookupConstructorFields con_name - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod con_name then - do { field_env <- getRecFieldEnv - ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env) - ; return (lookupNameEnv field_env con_name `orElse` []) } - else - do { con <- tcLookupConLike con_name - ; traceTc "lookupCF 2" (ppr con) - ; return (conLikeFieldLabels con) } } - ------------------------------------------------ --- Used for record construction and pattern matching --- When the -XDisambiguateRecordFields flag is on, take account of the --- constructor name to disambiguate which field to use; it's just the --- same as for instance decls --- --- NB: Consider this: --- module Foo where { data R = R { fld :: Int } } --- module Odd where { import Foo; fld x = x { fld = 3 } } --- Arguably this should work, because the reference to 'fld' is --- unambiguous because there is only one field id 'fld' in scope. --- But currently it's rejected. - -lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual - -- Just tycon => use tycon to disambiguate - -> SDoc -> RdrName - -> RnM Name -lookupRecFieldOcc parent doc rdr_name - | Just tc_name <- parent - = do { mb_name <- lookupSubBndrOcc True tc_name doc rdr_name - ; case mb_name of - Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) } - Right n -> return n } - - | otherwise - = lookupGlobalOccRn rdr_name - -lookupSubBndrOcc :: Bool - -> Name -- Parent - -> SDoc - -> RdrName - -> RnM (Either MsgDoc Name) --- Find all the things the rdr-name maps to --- and pick the one with the right parent namep -lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = do { n <- lookupExactOcc n - ; return (Right n) } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n <- lookupOrig rdr_mod rdr_occ - ; return (Right n) } - - | isUnboundName the_parent - -- Avoid an error cascade from malformed decls: - -- instance Int where { foo = e } - -- We have already generated an error in rnLHsInstDecl - = return (Right (mkUnboundNameRdr rdr_name)) - - | otherwise - = do { env <- getGlobalRdrEnv - ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName! - -- The latter does pickGREs, but we want to allow 'x' - -- even if only 'M.x' is in scope - ; traceRn "lookupSubBndrOcc" - (vcat [ ppr the_parent, ppr rdr_name - , ppr gres, ppr (pick_gres rdr_name gres)]) - ; case pick_gres rdr_name gres of - (gre:_) -> do { addUsedGRE warn_if_deprec gre - -- Add a usage; this is an *occurrence* site - -- Note [Usage for sub-bndrs] - ; return (Right (gre_name gre)) } - -- If there is more than one local GRE for the - -- same OccName 'f', that will be reported separately - -- as a duplicate top-level binding for 'f' - [] -> do { ns <- lookupQualifiedNameGHCi rdr_name - ; case ns of - (n:_) -> return (Right n) -- Unlikely to be more than one...? - [] -> return (Left (unknownSubordinateErr doc rdr_name)) - } } - where - -- If Parent = NoParent, just do a normal lookup - -- If Parent = Parent p then find all GREs that - -- (a) have parent p - -- (b) for Unqual, are in scope qualified or unqualified - -- for Qual, are in scope with that qualification - pick_gres rdr_name gres - | isUnqual rdr_name = filter right_parent gres - | otherwise = filter right_parent (pickGREs rdr_name gres) - - right_parent (GRE { gre_par = p }) - | ParentIs parent <- p = parent == the_parent - | FldParent { par_is = parent } <- p = parent == the_parent - | otherwise = False - -{- -Note [Family instance binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family F a - data instance F T = X1 | X2 - -The 'data instance' decl has an *occurrence* of F (and T), and *binds* -X1 and X2. (This is unlike a normal data type declaration which would -bind F too.) So we want an AvailTC F [X1,X2]. - -Now consider a similar pair: - class C a where - data G a - instance C S where - data G S = Y1 | Y2 - -The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. - -But there is a small complication: in an instance decl, we don't use -qualified names on the LHS; instead we use the class to disambiguate. -Thus: - module M where - import Blib( G ) - class C a where - data G a - instance C S where - data G S = Y1 | Y2 -Even though there are two G's in scope (M.G and Blib.G), the occurrence -of 'G' in the 'instance C S' decl is unambiguous, because C has only -one associated type called G. This is exactly what happens for methods, -and it is only consistent to do the same thing for types. That's the -role of the function lookupTcdName; the (Maybe Name) give the class of -the encloseing instance decl, if any. - -Note [Looking up Exact RdrNames] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Exact RdrNames are generated by Template Haskell. See Note [Binders -in Template Haskell] in Convert. - -For data types and classes have Exact system Names in the binding -positions for constructors, TyCons etc. For example - [d| data T = MkT Int |] -when we splice in and Convert to HsSyn RdrName, we'll get - data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... -These System names are generated by Convert.thRdrName - -But, constructors and the like need External Names, not System Names! -So we do the following - - * In RnEnv.newTopSrcBinder we spot Exact RdrNames that wrap a - non-External Name, and make an External name for it. This is - the name that goes in the GlobalRdrEnv - - * When looking up an occurrence of an Exact name, done in - RnEnv.lookupExactOcc, we find the Name with the right unique in the - GlobalRdrEnv, and use the one from the envt -- it will be an - External Name in the case of the data type/constructor above. - - * Exact names are also use for purely local binders generated - by TH, such as \x_33. x_33 - Both binder and occurrence are Exact RdrNames. The occurrence - gets looked up in the LocalRdrEnv by RnEnv.lookupOccRn, and - misses, because lookupLocalRdrEnv always returns Nothing for - an Exact Name. Now we fall through to lookupExactOcc, which - will find the Name is not in the GlobalRdrEnv, so we just use - the Exact supplied Name. - -Note [Splicing Exact names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the splice $(do { x <- newName "x"; return (VarE x) }) -This will generate a (HsExpr RdrName) term that mentions the -Exact RdrName "x_56" (or whatever), but does not bind it. So -when looking such Exact names we want to check that it's in scope, -otherwise the type checker will get confused. To do this we need to -keep track of all the Names in scope, and the LocalRdrEnv does just that; -we consult it with RdrName.inLocalRdrEnvScope. - -There is another wrinkle. With TH and -XDataKinds, consider - $( [d| data Nat = Zero - data T = MkT (Proxy 'Zero) |] ) -After splicing, but before renaming we get this: - data Nat_77{tc} = Zero_78{d} - data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) -The occurrence of 'Zero in the data type for T has the right unique, -but it has a TcClsName name-space in its OccName. (This is set by -the ctxt_ns argument of Convert.thRdrName.) When we check that is -in scope in the GlobalRdrEnv, we need to look up the DataName namespace -too. (An alternative would be to make the GlobalRdrEnv also have -a Name -> GRE mapping.) - -Note [Template Haskell ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The GlobalRdrEnv invariant says that if - occ -> [gre1, ..., gren] -then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv). -This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre). - -So how can we get multiple gres in lookupExactOcc_maybe? Because in -TH we might use the same TH NameU in two different name spaces. -eg (Trac #7241): - $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) -Here we generate a type constructor and data constructor with the same -unique, but differnt name spaces. - -It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would -mean looking up the OccName in every name-space, just in case, and that -seems a bit brutal. So it's just done here on lookup. But we might -need to revisit that choice. - -Note [Usage for sub-bndrs] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you have this - import qualified M( C( f ) ) - instance M.C T where - f x = x -then is the qualified import M.f used? Obviously yes. -But the RdrName used in the instance decl is unqualified. In effect, -we fill in the qualification by looking for f's whose class is M.C -But when adding to the UsedRdrNames we must make that qualification -explicit (saying "used M.f"), otherwise we get "Redundant import of M.f". - -So we make up a suitable (fake) RdrName. But be careful - import qualified M - import M( C(f) ) - instance C T where - f x = x -Here we want to record a use of 'f', not of 'M.f', otherwise -we'll miss the fact that the qualified import is redundant. - --------------------------------------------------- --- Occurrences --------------------------------------------------- --} - -getLookupOccRn :: RnM (Name -> Maybe Name) -getLookupOccRn - = do local_env <- getLocalRdrEnv - return (lookupLocalRdrOcc local_env . nameOccName) - -mkUnboundNameRdr :: RdrName -> Name -mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) - -lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) -lookupLocatedOccRn = wrapLocM lookupOccRn - -lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) --- Just look in the local environment -lookupLocalOccRn_maybe rdr_name - = do { local_env <- getLocalRdrEnv - ; return (lookupLocalRdrEnv local_env rdr_name) } - -lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel)) --- Just look in the local environment -lookupLocalOccThLvl_maybe name - = do { lcl_env <- getLclEnv - ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) } - --- lookupOccRn looks up an occurrence of a RdrName -lookupOccRn :: RdrName -> RnM Name -lookupOccRn rdr_name - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> reportUnboundName rdr_name } - -lookupKindOccRn :: RdrName -> RnM Name --- Looking up a name occurring in a kind -lookupKindOccRn rdr_name - | isVarOcc (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] - = badVarInType rdr_name - | otherwise - = do { typeintype <- xoptM LangExt.TypeInType - ; if | typeintype -> lookupTypeOccRn rdr_name - -- With -XNoTypeInType, treat any usage of * in kinds as in scope - -- this is a dirty hack, but then again so was the old * kind. - | is_star rdr_name -> return starKindTyConName - | is_uni_star rdr_name -> return unicodeStarKindTyConName - | otherwise -> lookupOccRn rdr_name } - --- lookupPromotedOccRn looks up an optionally promoted RdrName. -lookupTypeOccRn :: RdrName -> RnM Name --- see Note [Demotion] -lookupTypeOccRn rdr_name - | isVarOcc (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] - = badVarInType rdr_name - | otherwise - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of { - Just name -> return name ; - Nothing -> do { dflags <- getDynFlags - ; lookup_demoted rdr_name dflags } } } - -lookup_demoted :: RdrName -> DynFlags -> RnM Name -lookup_demoted rdr_name dflags - | Just demoted_rdr <- demoteRdrName rdr_name - -- Maybe it's the name of a *data* constructor - = do { data_kinds <- xoptM LangExt.DataKinds - ; if data_kinds - then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr - ; case mb_demoted_name of - Nothing -> unboundNameX WL_Any rdr_name star_info - Just demoted_name -> - do { whenWOptM Opt_WarnUntickedPromotedConstructors $ - addWarn - (Reason Opt_WarnUntickedPromotedConstructors) - (untickedPromConstrWarn demoted_name) - ; return demoted_name } } - else do { -- We need to check if a data constructor of this name is - -- in scope to give good error messages. However, we do - -- not want to give an additional error if the data - -- constructor happens to be out of scope! See #13947. - mb_demoted_name <- discardErrs $ - lookupOccRn_maybe demoted_rdr - ; let suggestion | isJust mb_demoted_name = suggest_dk - | otherwise = star_info - ; unboundNameX WL_Any rdr_name suggestion } } - - | otherwise - = reportUnboundName rdr_name - - where - suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?" - untickedPromConstrWarn name = - text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot - $$ - hsep [ text "Use" - , quotes (char '\'' <> ppr name) - , text "instead of" - , quotes (ppr name) <> dot ] - - star_info - | is_star rdr_name || is_uni_star rdr_name - = if xopt LangExt.TypeInType dflags - then text "NB: With TypeInType, you must import" <+> - ppr rdr_name <+> text "from Data.Kind" - else empty - - | otherwise - = empty - -is_star, is_uni_star :: RdrName -> Bool -is_star = (fsLit "*" ==) . occNameFS . rdrNameOcc -is_uni_star = (fsLit "★" ==) . occNameFS . rdrNameOcc - -badVarInType :: RdrName -> RnM Name -badVarInType rdr_name - = do { addErr (text "Illegal promoted term variable in a type:" - <+> ppr rdr_name) - ; return (mkUnboundNameRdr rdr_name) } - -{- Note [Promoted variables in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (Trac #12686): - x = True - data Bad = Bad 'x - -The parser treats the quote in 'x as saying "use the term -namespace", so we'll get (Bad x{v}), with 'x' in the -VarName namespace. If we don't test for this, the renamer -will happily rename it to the x bound at top level, and then -the typecheck falls over because it doesn't have 'x' in scope -when kind-checking. - -Note [Demotion] -~~~~~~~~~~~~~~~ -When the user writes: - data Nat = Zero | Succ Nat - foo :: f Zero -> Int - -'Zero' in the type signature of 'foo' is parsed as: - HsTyVar ("Zero", TcClsName) - -When the renamer hits this occurrence of 'Zero' it's going to realise -that it's not in scope. But because it is renaming a type, it knows -that 'Zero' might be a promoted data constructor, so it will demote -its namespace to DataName and do a second lookup. - -The final result (after the renamer) will be: - HsTyVar ("Zero", DataName) --} - --- Use this version to get tracing --- --- lookupOccRn_maybe, lookupOccRn_maybe' :: RdrName -> RnM (Maybe Name) --- lookupOccRn_maybe rdr_name --- = do { mb_res <- lookupOccRn_maybe' rdr_name --- ; gbl_rdr_env <- getGlobalRdrEnv --- ; local_rdr_env <- getLocalRdrEnv --- ; traceRn $ text "lookupOccRn_maybe" <+> --- vcat [ ppr rdr_name <+> ppr (getUnique (rdrNameOcc rdr_name)) --- , ppr mb_res --- , text "Lcl env" <+> ppr local_rdr_env --- , text "Gbl env" <+> ppr [ (getUnique (nameOccName (gre_name (head gres'))),gres') | gres <- occEnvElts gbl_rdr_env --- , let gres' = filter isLocalGRE gres, not (null gres') ] ] --- ; return mb_res } - -lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) --- lookupOccRn looks up an occurrence of a RdrName -lookupOccRn_maybe rdr_name - = do { local_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv local_env rdr_name of { - Just name -> return (Just name) ; - Nothing -> do - ; lookupGlobalOccRn_maybe rdr_name } } - -lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) --- Looks up a RdrName occurrence in the top-level --- environment, including using lookupQualifiedNameGHCi --- for the GHCi case --- No filter function; does not report an error on failure --- Uses addUsedRdrName to record use and deprecations -lookupGlobalOccRn_maybe rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = do { n' <- lookupExactOcc n; return (Just n') } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n <- lookupOrig rdr_mod rdr_occ - ; return (Just n) } - - | otherwise - = do { mb_gre <- lookupGreRn_maybe rdr_name - ; case mb_gre of { - Just gre -> return (Just (gre_name gre)) ; - Nothing -> - do { ns <- lookupQualifiedNameGHCi rdr_name - -- This test is not expensive, - -- and only happens for failed lookups - ; case ns of - (n:_) -> return (Just n) -- Unlikely to be more than one...? - [] -> return Nothing } } } - -lookupGlobalOccRn :: RdrName -> RnM Name --- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment. Adds an error message if the RdrName is not in scope. -lookupGlobalOccRn rdr_name - = do { mb_name <- lookupGlobalOccRn_maybe rdr_name - ; case mb_name of - Just n -> return n - Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) - ; unboundName WL_Global rdr_name } } - -lookupInfoOccRn :: RdrName -> RnM [Name] --- lookupInfoOccRn is intended for use in GHCi's ":info" command --- It finds all the GREs that RdrName could mean, not complaining --- about ambiguity, but rather returning them all --- C.f. Trac #9881 -lookupInfoOccRn rdr_name - | Just n <- isExact_maybe rdr_name -- e.g. (->) - = return [n] - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n <- lookupOrig rdr_mod rdr_occ - ; return [n] } - - | otherwise - = do { rdr_env <- getGlobalRdrEnv - ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env) - ; qual_ns <- lookupQualifiedNameGHCi rdr_name - ; return (ns ++ (qual_ns `minusList` ns)) } - --- | Like 'lookupOccRn_maybe', but with a more informative result if --- the 'RdrName' happens to be a record selector: --- --- * Nothing -> name not in scope (no error reported) --- * Just (Left x) -> name uniquely refers to x, --- or there is a name clash (reported) --- * Just (Right xs) -> name refers to one or more record selectors; --- if overload_ok was False, this list will be --- a singleton. -lookupOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name])) -lookupOccRn_overloaded overload_ok rdr_name - = do { local_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv local_env rdr_name of { - Just name -> return (Just (Left name)) ; - Nothing -> do - { mb_name <- lookupGlobalOccRn_overloaded overload_ok rdr_name - ; case mb_name of { - Just name -> return (Just name) ; - Nothing -> do - { ns <- lookupQualifiedNameGHCi rdr_name - -- This test is not expensive, - -- and only happens for failed lookups - ; case ns of - (n:_) -> return $ Just $ Left n -- Unlikely to be more than one...? - [] -> return Nothing } } } } } - -lookupGlobalOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name])) -lookupGlobalOccRn_overloaded overload_ok rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = do { n' <- lookupExactOcc n; return (Just (Left n')) } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n <- lookupOrig rdr_mod rdr_occ - ; return (Just (Left n)) } - - | otherwise - = do { env <- getGlobalRdrEnv - ; case lookupGRE_RdrName rdr_name env of - [] -> return Nothing - [gre] | isRecFldGRE gre - -> do { addUsedGRE True gre - ; let - fld_occ :: FieldOcc Name - fld_occ - = FieldOcc (noLoc rdr_name) (gre_name gre) - ; return (Just (Right [fld_occ])) } - | otherwise - -> do { addUsedGRE True gre - ; return (Just (Left (gre_name gre))) } - gres | all isRecFldGRE gres && overload_ok - -- Don't record usage for ambiguous selectors - -- until we know which is meant - -> return - (Just (Right - (map (FieldOcc (noLoc rdr_name) . gre_name) - gres))) - gres -> do { addNameClashErrRn rdr_name gres - ; return (Just (Left (gre_name (head gres)))) } } - - --------------------------------------------------- --- Lookup in the Global RdrEnv of the module --------------------------------------------------- - -lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) --- Look up the RdrName in the GlobalRdrEnv --- Exactly one binding: records it as "used", return (Just gre) --- No bindings: return Nothing --- Many bindings: report "ambiguous", return an arbitrary (Just gre) --- (This API is a bit strange; lookupGRERn2_maybe is simpler. --- But it works and I don't want to fiddle too much.) --- Uses addUsedRdrName to record use and deprecations -lookupGreRn_maybe rdr_name - = do { env <- getGlobalRdrEnv - ; case lookupGRE_RdrName rdr_name env of - [] -> return Nothing - [gre] -> do { addUsedGRE True gre - ; return (Just gre) } - gres -> do { addNameClashErrRn rdr_name gres - ; traceRn "lookupGreRn:name clash" - (ppr rdr_name $$ ppr gres $$ ppr env) - ; return (Just (head gres)) } } - -lookupGreRn2_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) --- Look up the RdrName in the GlobalRdrEnv --- Exactly one binding: record it as "used", return (Just gre) --- No bindings: report "not in scope", return Nothing --- Many bindings: report "ambiguous", return Nothing --- Uses addUsedRdrName to record use and deprecations -lookupGreRn2_maybe rdr_name - = do { env <- getGlobalRdrEnv - ; case lookupGRE_RdrName rdr_name env of - [] -> do { _ <- unboundName WL_Global rdr_name - ; return Nothing } - [gre] -> do { addUsedGRE True gre - ; return (Just gre) } - gres -> do { addNameClashErrRn rdr_name gres - ; traceRn "lookupGreRn_maybe:name clash" - (ppr rdr_name $$ ppr gres $$ ppr env) - ; return Nothing } } - -lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo) --- Used in export lists --- If not found or ambiguous, add error message, and fake with UnboundName --- Uses addUsedRdrName to record use and deprecations -lookupGreAvailRn rdr_name - = do { mb_gre <- lookupGreRn2_maybe rdr_name - ; case mb_gre of { - Just gre -> return (gre_name gre, availFromGRE gre) ; - Nothing -> - do { traceRn "lookupGreAvailRn" (ppr rdr_name) - ; let name = mkUnboundNameRdr rdr_name - ; return (name, avail name) } } } - -{- -********************************************************* -* * - Deprecations -* * -********************************************************* - -Note [Handling of deprecations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* We report deprecations at each *occurrence* of the deprecated thing - (see Trac #5867) - -* We do not report deprecations for locally-defined names. For a - start, we may be exporting a deprecated thing. Also we may use a - deprecated thing in the defn of another deprecated things. We may - even use a deprecated thing in the defn of a non-deprecated thing, - when changing a module's interface. - -* addUsedGREs: we do not report deprecations for sub-binders: - - the ".." completion for records - - the ".." in an export item 'T(..)' - - the things exported by a module export 'module M' --} - -addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM () --- Remember use of in-scope data constructors (Trac #7969) -addUsedDataCons rdr_env tycon - = addUsedGREs [ gre - | dc <- tyConDataCons tycon - , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ] - -addUsedGRE :: Bool -> GlobalRdrElt -> RnM () --- Called for both local and imported things --- Add usage *and* warn if deprecated -addUsedGRE warn_if_deprec gre - = do { when warn_if_deprec (warnIfDeprecated gre) - ; unless (isLocalGRE gre) $ - do { env <- getGblEnv - ; traceRn "addUsedGRE" (ppr gre) - ; updMutVar (tcg_used_gres env) (gre :) } } - -addUsedGREs :: [GlobalRdrElt] -> RnM () --- Record uses of any *imported* GREs --- Used for recording used sub-bndrs --- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] -addUsedGREs gres - | null imp_gres = return () - | otherwise = do { env <- getGblEnv - ; traceRn "addUsedGREs" (ppr imp_gres) - ; updMutVar (tcg_used_gres env) (imp_gres ++) } - where - imp_gres = filterOut isLocalGRE gres - -warnIfDeprecated :: GlobalRdrElt -> RnM () -warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) - | (imp_spec : _) <- iss - = do { dflags <- getDynFlags - ; this_mod <- getModule - ; when (wopt Opt_WarnWarningsDeprecations dflags && - not (nameIsLocalOrFrom this_mod name)) $ - -- See Note [Handling of deprecations] - do { iface <- loadInterfaceForName doc name - ; case lookupImpDeprec iface gre of - Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations) - (mk_msg imp_spec txt) - Nothing -> return () } } - | otherwise - = return () - where - occ = greOccName gre - name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name - doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly") - - mk_msg imp_spec txt - = sep [ sep [ text "In the use of" - <+> pprNonVarNameSpace (occNameSpace occ) - <+> quotes (ppr occ) - , parens imp_msg <> colon ] - , pprWarningTxtForMsg txt ] - where - imp_mod = importSpecModule imp_spec - imp_msg = text "imported from" <+> ppr imp_mod <> extra - extra | imp_mod == moduleName name_mod = Outputable.empty - | otherwise = text ", but defined in" <+> ppr name_mod - -lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt -lookupImpDeprec iface gre - = mi_warn_fn iface (greOccName gre) `mplus` -- Bleat if the thing, - case gre_par gre of -- or its parent, is warn'd - ParentIs p -> mi_warn_fn iface (nameOccName p) - FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p) - NoParent -> Nothing - -{- -Note [Used names with interface not loaded] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's (just) possible to find a used -Name whose interface hasn't been loaded: - -a) It might be a WiredInName; in that case we may not load - its interface (although we could). - -b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger - These are seen as "used" by the renamer (if -XRebindableSyntax) - is on), but the typechecker may discard their uses - if in fact the in-scope fromRational is GHC.Read.fromRational, - (see tcPat.tcOverloadedLit), and the typechecker sees that the type - is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). - In that obscure case it won't force the interface in. - -In both cases we simply don't permit deprecations; -this is, after all, wired-in stuff. - - -********************************************************* -* * - GHCi support -* * -********************************************************* - -A qualified name on the command line can refer to any module at -all: we try to load the interface if we don't already have it, just -as if there was an "import qualified M" declaration for every -module. - -If we fail we just return Nothing, rather than bleating -about "attempting to use module ‘D’ (./D.hs) which is not loaded" -which is what loadSrcInterface does. - -Note [Safe Haskell and GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We DONT do this Safe Haskell as we need to check imports. We can -and should instead check the qualified import but at the moment -this requires some refactoring so leave as a TODO --} - -lookupQualifiedNameGHCi :: RdrName -> RnM [Name] -lookupQualifiedNameGHCi rdr_name - = -- We want to behave as we would for a source file import here, - -- and respect hiddenness of modules/packages, hence loadSrcInterface. - do { dflags <- getDynFlags - ; is_ghci <- getIsGHCi - ; go_for_it dflags is_ghci } - - where - go_for_it dflags is_ghci - | Just (mod,occ) <- isQual_maybe rdr_name - , is_ghci - , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour - , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] - = do { res <- loadSrcInterface_maybe doc mod False Nothing - ; case res of - Succeeded iface - -> return [ name - | avail <- mi_exports iface - , name <- availNames avail - , nameOccName name == occ ] - - _ -> -- Either we couldn't load the interface, or - -- we could but we didn't find the name in it - do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name) - ; return [] } } - - | otherwise - = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name) - ; return [] } - - doc = text "Need to find" <+> ppr rdr_name - -{- -Note [Looking up signature names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -lookupSigOccRn is used for type signatures and pragmas -Is this valid? - module A - import M( f ) - f :: Int -> Int - f x = x -It's clear that the 'f' in the signature must refer to A.f -The Haskell98 report does not stipulate this, but it will! -So we must treat the 'f' in the signature in the same way -as the binding occurrence of 'f', using lookupBndrRn - -However, consider this case: - import M( f ) - f :: Int -> Int - g x = x -We don't want to say 'f' is out of scope; instead, we want to -return the imported 'f', so that later on the reanamer will -correctly report "misplaced type sig". - -Note [Signatures for top level things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -data HsSigCtxt = ... | TopSigCtxt NameSet | .... - -* The NameSet says what is bound in this group of bindings. - We can't use isLocalGRE from the GlobalRdrEnv, because of this: - f x = x - $( ...some TH splice... ) - f :: Int -> Int - When we encounter the signature for 'f', the binding for 'f' - will be in the GlobalRdrEnv, and will be a LocalDef. Yet the - signature is mis-placed - -* For type signatures the NameSet should be the names bound by the - value bindings; for fixity declarations, the NameSet should also - include class sigs and record selectors - - infix 3 `f` -- Yes, ok - f :: C a => a -> a -- No, not ok - class C a where - f :: a -> a --} - -data HsSigCtxt - = TopSigCtxt NameSet -- At top level, binding these names - -- See Note [Signatures for top level things] - | LocalBindCtxt NameSet -- In a local binding, binding these names - | ClsDeclCtxt Name -- Class decl for this class - | InstDeclCtxt NameSet -- Instance decl whose user-written method - -- bindings are for these methods - | HsBootCtxt NameSet -- Top level of a hs-boot file, binding these names - | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types - -- in the group - -instance Outputable HsSigCtxt where - ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns - ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns - ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n - ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns - ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns - ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns - -lookupSigOccRn :: HsSigCtxt - -> Sig RdrName - -> Located RdrName -> RnM (Located Name) -lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) - --- | Lookup a name in relation to the names in a 'HsSigCtxt' -lookupSigCtxtOccRn :: HsSigCtxt - -> SDoc -- ^ description of thing we're looking up, - -- like "type family" - -> Located RdrName -> RnM (Located Name) -lookupSigCtxtOccRn ctxt what - = wrapLocM $ \ rdr_name -> - do { mb_name <- lookupBindGroupOcc ctxt what rdr_name - ; case mb_name of - Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) } - Right name -> return name } - -lookupBindGroupOcc :: HsSigCtxt - -> SDoc - -> RdrName -> RnM (Either MsgDoc Name) --- Looks up the RdrName, expecting it to resolve to one of the --- bound names passed in. If not, return an appropriate error message --- --- See Note [Looking up signature names] -lookupBindGroupOcc ctxt what rdr_name - | Just n <- isExact_maybe rdr_name - = lookupExactOcc_either n -- allow for the possibility of missing Exacts; - -- see Note [dataTcOccs and Exact Names] - -- Maybe we should check the side conditions - -- but it's a pain, and Exact things only show - -- up when you know what you are doing - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n' <- lookupOrig rdr_mod rdr_occ - ; return (Right n') } - - | otherwise - = case ctxt of - HsBootCtxt ns -> lookup_top (`elemNameSet` ns) - TopSigCtxt ns -> lookup_top (`elemNameSet` ns) - RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) - LocalBindCtxt ns -> lookup_group ns - ClsDeclCtxt cls -> lookup_cls_op cls - InstDeclCtxt ns -> lookup_top (`elemNameSet` ns) - where - lookup_cls_op cls - = lookupSubBndrOcc True cls doc rdr_name - where - doc = text "method of class" <+> quotes (ppr cls) - - lookup_top keep_me - = do { env <- getGlobalRdrEnv - ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - ; case filter (keep_me . gre_name) all_gres of - [] | null all_gres -> bale_out_with Outputable.empty - | otherwise -> bale_out_with local_msg - (gre:_) -> return (Right (gre_name gre)) } - - lookup_group bound_names -- Look in the local envt (not top level) - = do { local_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv local_env rdr_name of - Just n - | n `elemNameSet` bound_names -> return (Right n) - | otherwise -> bale_out_with local_msg - Nothing -> bale_out_with Outputable.empty } - - bale_out_with msg - = return (Left (sep [ text "The" <+> what - <+> text "for" <+> quotes (ppr rdr_name) - , nest 2 $ text "lacks an accompanying binding"] - $$ nest 2 msg)) - - local_msg = parens $ text "The" <+> what <+> ptext (sLit "must be given where") - <+> quotes (ppr rdr_name) <+> text "is declared" - - ---------------- -lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] --- GHC extension: look up both the tycon and data con or variable. --- Used for top-level fixity signatures and deprecations. --- Complain if neither is in scope. --- See Note [Fixity signature lookup] -lookupLocalTcNames ctxt what rdr_name - = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) - ; let (errs, names) = splitEithers mb_gres - ; when (null names) $ addErr (head errs) -- Bleat about one only - ; return names } - where - lookup rdr = do { name <- lookupBindGroupOcc ctxt what rdr - ; return (fmap ((,) rdr) name) } - -dataTcOccs :: RdrName -> [RdrName] --- Return both the given name and the same name promoted to the TcClsName --- namespace. This is useful when we aren't sure which we are looking at. --- See also Note [dataTcOccs and Exact Names] -dataTcOccs rdr_name - | isDataOcc occ || isVarOcc occ - = [rdr_name, rdr_name_tc] - | otherwise - = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName - -{- -Note [dataTcOccs and Exact Names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Exact RdrNames can occur in code generated by Template Haskell, and generally -those references are, well, exact. However, the TH `Name` type isn't expressive -enough to always track the correct namespace information, so we sometimes get -the right Unique but wrong namespace. Thus, we still have to do the double-lookup -for Exact RdrNames. - -There is also an awkward situation for built-in syntax. Example in GHCi - :info [] -This parses as the Exact RdrName for nilDataCon, but we also want -the list type constructor. - -Note that setRdrNameSpace on an Exact name requires the Name to be External, -which it always is for built in syntax. - -********************************************************* -* * - Fixities -* * -********************************************************* - -Note [Fixity signature lookup] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A fixity declaration like - - infixr 2 ? - -can refer to a value-level operator, e.g.: - - (?) :: String -> String -> String - -or a type-level operator, like: - - data (?) a b = A a | B b - -so we extend the lookup of the reader name '?' to the TcClsName namespace, as -well as the original namespace. - -The extended lookup is also used in other places, like resolution of -deprecation declarations, and lookup of names in GHCi. --} - --------------------------------- -type MiniFixityEnv = FastStringEnv (Located Fixity) - -- Mini fixity env for the names we're about - -- to bind, in a single binding group - -- - -- It is keyed by the *FastString*, not the *OccName*, because - -- the single fixity decl infix 3 T - -- affects both the data constructor T and the type constrctor T - -- - -- We keep the location so that if we find - -- a duplicate, we can report it sensibly - --------------------------------- --- Used for nested fixity decls to bind names along with their fixities. --- the fixities are given as a UFM from an OccName's FastString to a fixity decl - -addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a -addLocalFixities mini_fix_env names thing_inside - = extendFixityEnv (mapMaybe find_fixity names) thing_inside - where - find_fixity name - = case lookupFsEnv mini_fix_env (occNameFS occ) of - Just (L _ fix) -> Just (name, FixItem occ fix) - Nothing -> Nothing - where - occ = nameOccName name - -{- --------------------------------- -lookupFixity is a bit strange. - -* Nested local fixity decls are put in the local fixity env, which we - find with getFixtyEnv - -* Imported fixities are found in the PIT - -* Top-level fixity decls in this module may be for Names that are - either Global (constructors, class operations) - or Local/Exported (everything else) - (See notes with RnNames.getLocalDeclBinders for why we have this split.) - We put them all in the local fixity environment --} - -lookupFixityRn :: Name -> RnM Fixity -lookupFixityRn name = lookupFixityRn' name (nameOccName name) - -lookupFixityRn' :: Name -> OccName -> RnM Fixity -lookupFixityRn' name = fmap snd . lookupFixityRn_help' name - --- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity' --- in a local environment or from an interface file. Otherwise, it returns --- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without --- user-supplied fixity declarations). -lookupFixityRn_help :: Name - -> RnM (Bool, Fixity) -lookupFixityRn_help name = - lookupFixityRn_help' name (nameOccName name) - -lookupFixityRn_help' :: Name - -> OccName - -> RnM (Bool, Fixity) -lookupFixityRn_help' name occ - | isUnboundName name - = return (False, Fixity NoSourceText minPrecedence InfixL) - -- Minimise errors from ubound names; eg - -- a>0 `foo` b>0 - -- where 'foo' is not in scope, should not give an error (Trac #7937) - - | otherwise - = do { local_fix_env <- getFixityEnv - ; case lookupNameEnv local_fix_env name of { - Just (FixItem _ fix) -> return (True, fix) ; - Nothing -> - - do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod name - -- Local (and interactive) names are all in the - -- fixity env, and don't have entries in the HPT - then return (False, defaultFixity) - else lookup_imported } } } - where - lookup_imported - -- For imported names, we have to get their fixities by doing a - -- loadInterfaceForName, and consulting the Ifaces that comes back - -- from that, because the interface file for the Name might not - -- have been loaded yet. Why not? Suppose you import module A, - -- which exports a function 'f', thus; - -- module CurrentModule where - -- import A( f ) - -- module A( f ) where - -- import B( f ) - -- Then B isn't loaded right away (after all, it's possible that - -- nothing from B will be used). When we come across a use of - -- 'f', we need to know its fixity, and it's then, and only - -- then, that we load B.hi. That is what's happening here. - -- - -- loadInterfaceForName will find B.hi even if B is a hidden module, - -- and that's what we want. - = do { iface <- loadInterfaceForName doc name - ; let mb_fix = mi_fix_fn iface occ - ; let msg = case mb_fix of - Nothing -> - text "looking up name" <+> ppr name - <+> text "in iface, but found no fixity for it." - <+> text "Using default fixity instead." - Just f -> - text "looking up name in iface and found:" - <+> vcat [ppr name, ppr f] - ; traceRn "lookupFixityRn_either:" msg - ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) } - - doc = text "Checking fixity for" <+> ppr name - ---------------- -lookupTyFixityRn :: Located Name -> RnM Fixity -lookupTyFixityRn (L _ n) = lookupFixityRn n - --- | Look up the fixity of a (possibly ambiguous) occurrence of a record field --- selector. We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as --- the field label, which might be different to the 'OccName' of the selector --- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are --- multiple possible selectors with different fixities, generate an error. -lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity -lookupFieldFixityRn (Unambiguous (L _ rdr) n) - = lookupFixityRn' n (rdrNameOcc rdr) -lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr - where - get_ambiguous_fixity :: RdrName -> RnM Fixity - get_ambiguous_fixity rdr_name = do - traceRn "get_ambiguous_fixity" (ppr rdr_name) - rdr_env <- getGlobalRdrEnv - let elts = lookupGRE_RdrName rdr_name rdr_env - - fixities <- groupBy ((==) `on` snd) . zip elts - <$> mapM lookup_gre_fixity elts - - case fixities of - -- There should always be at least one fixity. - -- Something's very wrong if there are no fixity candidates, so panic - [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName" - [ (_, fix):_ ] -> return fix - ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs) - >> return (Fixity NoSourceText minPrecedence InfixL) - - lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre) - - ambiguous_fixity_err rn ambigs - = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn) - , hang (text "Conflicts: ") 2 . vcat . - map format_ambig $ concat ambigs ] - - format_ambig (elt, fix) = hang (ppr fix) - 2 (pprNameProvenance elt) - - -{- ********************************************************************* -* * - Role annotations -* * -********************************************************************* -} - -type RoleAnnotEnv = NameEnv (LRoleAnnotDecl Name) - -mkRoleAnnotEnv :: [LRoleAnnotDecl Name] -> RoleAnnotEnv -mkRoleAnnotEnv role_annot_decls - = mkNameEnv [ (name, ra_decl) - | ra_decl <- role_annot_decls - , let name = roleAnnotDeclName (unLoc ra_decl) - , not (isUnboundName name) ] - -- Some of the role annots will be unbound; - -- we don't wish to include these - -emptyRoleAnnotEnv :: RoleAnnotEnv -emptyRoleAnnotEnv = emptyNameEnv - -lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl Name) -lookupRoleAnnot = lookupNameEnv - -getRoleAnnots :: [Name] -> RoleAnnotEnv -> ([LRoleAnnotDecl Name], RoleAnnotEnv) -getRoleAnnots bndrs role_env - = ( mapMaybe (lookupRoleAnnot role_env) bndrs - , delListFromNameEnv role_env bndrs ) - - -{- -************************************************************************ -* * - Rebindable names - Dealing with rebindable syntax is driven by the - Opt_RebindableSyntax dynamic flag. - - In "deriving" code we don't want to use rebindable syntax - so we switch off the flag locally - -* * -************************************************************************ - -Haskell 98 says that when you say "3" you get the "fromInteger" from the -Standard Prelude, regardless of what is in scope. However, to experiment -with having a language that is less coupled to the standard prelude, we're -trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" -happens to be in scope. Then you can - import Prelude () - import MyPrelude as Prelude -to get the desired effect. - -At the moment this just happens for - * fromInteger, fromRational on literals (in expressions and patterns) - * negate (in expressions) - * minus (arising from n+k patterns) - * "do" notation - -We store the relevant Name in the HsSyn tree, in - * HsIntegral/HsFractional/HsIsString - * NegApp - * NPlusKPat - * HsDo -respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName, -fromRationalName etc), but the renamer changes this to the appropriate user -name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does. - -We treat the original (standard) names as free-vars too, because the type checker -checks the type of the user thing against the type of the standard thing. --} - -lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars) --- Different to lookupSyntaxName because in the non-rebindable --- case we desugar directly rather than calling an existing function --- Hence the (Maybe (SyntaxExpr Name)) return type -lookupIfThenElse - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on - then return (Nothing, emptyFVs) - else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) - ; return ( Just (mkRnSyntaxExpr ite) - , unitFV ite ) } } - -lookupSyntaxName' :: Name -- ^ The standard name - -> RnM Name -- ^ Possibly a non-standard name -lookupSyntaxName' std_name - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on then - return std_name - else - -- Get the similarly named thing from the local environment - lookupOccRn (mkRdrUnqual (nameOccName std_name)) } - -lookupSyntaxName :: Name -- The standard name - -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name -lookupSyntaxName std_name - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on then - return (mkRnSyntaxExpr std_name, emptyFVs) - else - -- Get the similarly named thing from the local environment - do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) - ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } } - -lookupSyntaxNames :: [Name] -- Standard names - -> RnM ([HsExpr Name], FreeVars) -- See comments with HsExpr.ReboundNames - -- this works with CmdTop, which wants HsExprs, not SyntaxExprs -lookupSyntaxNames std_names - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on then - return (map (HsVar . noLoc) std_names, emptyFVs) - else - do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names - ; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } } - -{- -********************************************************* -* * -\subsection{Binding} -* * -********************************************************* --} - -newLocalBndrRn :: Located RdrName -> RnM Name --- Used for non-top-level binders. These should --- never be qualified. -newLocalBndrRn (L loc rdr_name) - | Just name <- isExact_maybe rdr_name - = return name -- This happens in code generated by Template Haskell - -- See Note [Binders in Template Haskell] in Convert.hs - | otherwise - = do { unless (isUnqual rdr_name) - (addErrAt loc (badQualBndrErr rdr_name)) - ; uniq <- newUnique - ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } - -newLocalBndrsRn :: [Located RdrName] -> RnM [Name] -newLocalBndrsRn = mapM newLocalBndrRn - ---------------------- -bindLocatedLocalsRn :: [Located RdrName] - -> ([Name] -> RnM a) - -> RnM a -bindLocatedLocalsRn rdr_names_w_loc enclosed_scope - = do { checkDupRdrNames rdr_names_w_loc - ; checkShadowedRdrNames rdr_names_w_loc - - -- Make fresh Names and extend the environment - ; names <- newLocalBndrsRn rdr_names_w_loc - ; bindLocalNames names (enclosed_scope names) } - -bindLocalNames :: [Name] -> RnM a -> RnM a -bindLocalNames names enclosed_scope - = do { lcl_env <- getLclEnv - ; let th_level = thLevel (tcl_th_ctxt lcl_env) - th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) - [ (n, (NotTopLevel, th_level)) | n <- names ] - rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names - ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs' - , tcl_rdr = rdr_env' }) - enclosed_scope } - -bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -bindLocalNamesFV names enclosed_scope - = do { (result, fvs) <- bindLocalNames names enclosed_scope - ; return (result, delFVs names fvs) } - - -------------------------------------- - -- binLocalsFVRn is the same as bindLocalsRn - -- except that it deals with free vars -bindLocatedLocalsFV :: [Located RdrName] - -> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars) -bindLocatedLocalsFV rdr_names enclosed_scope - = bindLocatedLocalsRn rdr_names $ \ names -> - do (thing, fvs) <- enclosed_scope names - return (thing, delFVs names fvs) - -------------------------------------- - -extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) - -- This function is used only in rnSourceDecl on InstDecl -extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside - -------------------------------------- -checkDupRdrNames :: [Located RdrName] -> RnM () --- Check for duplicated names in a binding group -checkDupRdrNames rdr_names_w_loc - = mapM_ (dupNamesErr getLoc) dups - where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc - -checkDupNames :: [Name] -> RnM () --- Check for duplicated names in a binding group -checkDupNames names = check_dup_names (filterOut isSystemName names) - -- See Note [Binders in Template Haskell] in Convert - -check_dup_names :: [Name] -> RnM () -check_dup_names names - = mapM_ (dupNamesErr nameSrcSpan) dups - where - (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names - ---------------------- -checkShadowedRdrNames :: [Located RdrName] -> RnM () -checkShadowedRdrNames loc_rdr_names - = do { envs <- getRdrEnvs - ; checkShadowedOccs envs get_loc_occ filtered_rdrs } - where - filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names - -- See Note [Binders in Template Haskell] in Convert - get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) - -checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () -checkDupAndShadowedNames envs names - = do { check_dup_names filtered_names - ; checkShadowedOccs envs get_loc_occ filtered_names } - where - filtered_names = filterOut isSystemName names - -- See Note [Binders in Template Haskell] in Convert - get_loc_occ name = (nameSrcSpan name, nameOccName name) - -------------------------------------- -checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) - -> (a -> (SrcSpan, OccName)) - -> [a] -> RnM () -checkShadowedOccs (global_env,local_env) get_loc_occ ns - = whenWOptM Opt_WarnNameShadowing $ - do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns)) - ; mapM_ check_shadow ns } - where - check_shadow n - | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" - -- See Trac #3262 - | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)] - | otherwise = do { gres' <- filterM is_shadowed_gre gres - ; complain (map pprNameProvenance gres') } - where - (loc,occ) = get_loc_occ n - mb_local = lookupLocalRdrOcc local_env occ - gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env - -- Make an Unqualified RdrName and look that up, so that - -- we don't find any GREs that are in scope qualified-only - - complain [] = return () - complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing) - loc - (shadowedNameWarn occ pp_locs) - - is_shadowed_gre :: GlobalRdrElt -> RnM Bool - -- Returns False for record selectors that are shadowed, when - -- punning or wild-cards are on (cf Trac #2723) - is_shadowed_gre gre | isRecFldGRE gre - = do { dflags <- getDynFlags - ; return $ not (xopt LangExt.RecordPuns dflags - || xopt LangExt.RecordWildCards dflags) } - is_shadowed_gre _other = return True - -{- -************************************************************************ -* * - What to do when a lookup fails -* * -************************************************************************ --} - -data WhereLooking = WL_Any -- Any binding - | WL_Global -- Any top-level binding (local or imported) - | WL_LocalTop -- Any top-level binding in this module - -reportUnboundName :: RdrName -> RnM Name -reportUnboundName rdr = unboundName WL_Any rdr - -unboundName :: WhereLooking -> RdrName -> RnM Name -unboundName wl rdr = unboundNameX wl rdr Outputable.empty - -unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name -unboundNameX where_look rdr_name extra - = do { dflags <- getDynFlags - ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags - what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - err = unknownNameErr what rdr_name $$ extra - ; if not show_helpful_errors - then addErr err - else do { local_env <- getLocalRdrEnv - ; global_env <- getGlobalRdrEnv - ; impInfo <- getImports - ; let suggestions = unknownNameSuggestions_ where_look - dflags global_env local_env impInfo rdr_name - ; addErr (err $$ suggestions) } - ; return (mkUnboundNameRdr rdr_name) } - -unknownNameErr :: SDoc -> RdrName -> SDoc -unknownNameErr what rdr_name - = vcat [ hang (text "Not in scope:") - 2 (what <+> quotes (ppr rdr_name)) - , extra ] - where - extra | rdr_name == forall_tv_RDR = perhapsForallMsg - | otherwise = Outputable.empty - -type HowInScope = Either SrcSpan ImpDeclSpec - -- Left loc => locally bound at loc - -- Right ispec => imported as specified by ispec - - --- | Called from the typechecker (TcErrors) when we find an unbound variable -unknownNameSuggestions :: DynFlags - -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> SDoc -unknownNameSuggestions = unknownNameSuggestions_ WL_Any - -unknownNameSuggestions_ :: WhereLooking -> DynFlags - -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> SDoc -unknownNameSuggestions_ where_look dflags global_env local_env imports tried_rdr_name = - similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$ - importSuggestions dflags imports tried_rdr_name - - -similarNameSuggestions :: WhereLooking -> DynFlags - -> GlobalRdrEnv -> LocalRdrEnv - -> RdrName -> SDoc -similarNameSuggestions where_look dflags global_env - local_env tried_rdr_name - = case suggest of - [] -> Outputable.empty - [p] -> perhaps <+> pp_item p - ps -> sep [ perhaps <+> text "one of these:" - , nest 2 (pprWithCommas pp_item ps) ] - where - all_possibilities :: [(String, (RdrName, HowInScope))] - all_possibilities - = [ (showPpr dflags r, (r, Left loc)) - | (r,loc) <- local_possibilities local_env ] - ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] - - suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities - perhaps = text "Perhaps you meant" - - pp_item :: (RdrName, HowInScope) -> SDoc - pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined - where loc' = case loc of - UnhelpfulSpan l -> parens (ppr l) - RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l)) - pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported - parens (text "imported from" <+> ppr (is_mod is)) - - pp_ns :: RdrName -> SDoc - pp_ns rdr | ns /= tried_ns = pprNameSpace ns - | otherwise = Outputable.empty - where ns = rdrNameSpace rdr - - tried_occ = rdrNameOcc tried_rdr_name - tried_is_sym = isSymOcc tried_occ - tried_ns = occNameSpace tried_occ - tried_is_qual = isQual tried_rdr_name - - correct_name_space occ = nameSpacesRelated (occNameSpace occ) tried_ns - && isSymOcc occ == tried_is_sym - -- Treat operator and non-operators as non-matching - -- This heuristic avoids things like - -- Not in scope 'f'; perhaps you meant '+' (from Prelude) - - local_ok = case where_look of { WL_Any -> True; _ -> False } - local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)] - local_possibilities env - | tried_is_qual = [] - | not local_ok = [] - | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name) - | name <- localRdrEnvElts env - , let occ = nameOccName name - , correct_name_space occ] - - gre_ok :: GlobalRdrElt -> Bool - gre_ok = case where_look of - WL_LocalTop -> isLocalGRE - _ -> \_ -> True - - global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))] - global_possibilities global_env - | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) - | gre <- globalRdrEnvElts global_env - , gre_ok gre - , let name = gre_name gre - occ = nameOccName name - , correct_name_space occ - , (mod, how) <- quals_in_scope gre - , let rdr_qual = mkRdrQual mod occ ] - - | otherwise = [ (rdr_unqual, pair) - | gre <- globalRdrEnvElts global_env - , gre_ok gre - , let name = gre_name gre - occ = nameOccName name - rdr_unqual = mkRdrUnqual occ - , correct_name_space occ - , pair <- case (unquals_in_scope gre, quals_only gre) of - (how:_, _) -> [ (rdr_unqual, how) ] - ([], pr:_) -> [ pr ] -- See Note [Only-quals] - ([], []) -> [] ] - - -- Note [Only-quals] - -- The second alternative returns those names with the same - -- OccName as the one we tried, but live in *qualified* imports - -- e.g. if you have: - -- - -- > import qualified Data.Map as Map - -- > foo :: Map - -- - -- then we suggest @Map.Map@. - - -------------------- - unquals_in_scope :: GlobalRdrElt -> [HowInScope] - unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }) - | lcl = [ Left (nameSrcSpan n) ] - | otherwise = [ Right ispec - | i <- is, let ispec = is_decl i - , not (is_qual ispec) ] - - -------------------- - quals_in_scope :: GlobalRdrElt -> [(ModuleName, HowInScope)] - -- Ones for which the qualified version is in scope - quals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }) - | lcl = case nameModule_maybe n of - Nothing -> [] - Just m -> [(moduleName m, Left (nameSrcSpan n))] - | otherwise = [ (is_as ispec, Right ispec) - | i <- is, let ispec = is_decl i ] - - -------------------- - quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)] - -- Ones for which *only* the qualified version is in scope - quals_only (GRE { gre_name = n, gre_imp = is }) - = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec) - | i <- is, let ispec = is_decl i, is_qual ispec ] - --- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. -importSuggestions :: DynFlags -> ImportAvails -> RdrName -> SDoc -importSuggestions _dflags imports rdr_name - | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty - | null interesting_imports - , Just name <- mod_name - = hsep - [ text "No module named" - , quotes (ppr name) - , text "is imported." - ] - | is_qualified - , null helpful_imports - , [(mod,_)] <- interesting_imports - = hsep - [ text "Module" - , quotes (ppr mod) - , text "does not export" - , quotes (ppr occ_name) <> dot - ] - | is_qualified - , null helpful_imports - , mods <- map fst interesting_imports - = hsep - [ text "Neither" - , quotedListWithNor (map ppr mods) - , text "exports" - , quotes (ppr occ_name) <> dot - ] - | [(mod,imv)] <- helpful_imports_non_hiding - = fsep - [ text "Perhaps you want to add" - , quotes (ppr occ_name) - , text "to the import list" - , text "in the import of" - , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot - ] - | not (null helpful_imports_non_hiding) - = fsep - [ text "Perhaps you want to add" - , quotes (ppr occ_name) - , text "to one of these import lists:" - ] - $$ - nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) - | (mod,imv) <- helpful_imports_non_hiding - ]) - | [(mod,imv)] <- helpful_imports_hiding - = fsep - [ text "Perhaps you want to remove" - , quotes (ppr occ_name) - , text "from the explicit hiding list" - , text "in the import of" - , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot - ] - | not (null helpful_imports_hiding) - = fsep - [ text "Perhaps you want to remove" - , quotes (ppr occ_name) - , text "from the hiding clauses" - , text "in one of these imports:" - ] - $$ - nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) - | (mod,imv) <- helpful_imports_hiding - ]) - | otherwise - = Outputable.empty - where - is_qualified = isQual rdr_name - (mod_name, occ_name) = case rdr_name of - Unqual occ_name -> (Nothing, occ_name) - Qual mod_name occ_name -> (Just mod_name, occ_name) - _ -> error "importSuggestions: dead code" - - - -- What import statements provide "Mod" at all - -- or, if this is an unqualified name, are not qualified imports - interesting_imports = [ (mod, imp) - | (mod, mod_imports) <- moduleEnvToList (imp_mods imports) - , Just imp <- return $ pick (importedByUser mod_imports) - ] - - -- We want to keep only one for each original module; preferably one with an - -- explicit import list (for no particularly good reason) - pick :: [ImportedModsVal] -> Maybe ImportedModsVal - pick = listToMaybe . sortBy (compare `on` prefer) . filter select - where select imv = case mod_name of Just name -> imv_name imv == name - Nothing -> not (imv_qualified imv) - prefer imv = (imv_is_hiding imv, imv_span imv) - - -- Which of these would export a 'foo' - -- (all of these are restricted imports, because if they were not, we - -- wouldn't have an out-of-scope error in the first place) - helpful_imports = filter helpful interesting_imports - where helpful (_,imv) - = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name - - -- Which of these do that because of an explicit hiding list resp. an - -- explicit import list - (helpful_imports_hiding, helpful_imports_non_hiding) - = partition (imv_is_hiding . snd) helpful_imports - -{- -************************************************************************ -* * -\subsection{Free variable manipulation} -* * -************************************************************************ --} - --- A useful utility -addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars) -addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside - ; return (res, fvs1 `plusFV` fvs2) } - -mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) -mapFvRn f xs = do stuff <- mapM f xs - case unzip stuff of - (ys, fvs_s) -> return (ys, plusFVs fvs_s) - -mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) -mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) -mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) } - --- because some of the rename functions are CPSed: --- maps the function across the list from left to right; --- collects all the free vars into one set -mapFvRnCPS :: (a -> (b -> RnM c) -> RnM c) - -> [a] -> ([b] -> RnM c) -> RnM c - -mapFvRnCPS _ [] cont = cont [] -mapFvRnCPS f (x:xs) cont = f x $ \ x' -> - mapFvRnCPS f xs $ \ xs' -> - cont (x':xs') - -{- -************************************************************************ -* * -\subsection{Envt utility functions} -* * -************************************************************************ --} - -warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () -warnUnusedTopBinds gres - = whenWOptM Opt_WarnUnusedTopBinds - $ do env <- getGblEnv - let isBoot = tcg_src env == HsBootFile - let noParent gre = case gre_par gre of - NoParent -> True - _ -> False - -- Don't warn about unused bindings with parents in - -- .hs-boot files, as you are sometimes required to give - -- unused bindings (trac #3449). - -- HOWEVER, in a signature file, you are never obligated to put a - -- definition in the main text. Thus, if you define something - -- and forget to export it, we really DO want to warn. - gres' = if isBoot then filter noParent gres - else gres - warnUnusedGREs gres' - -warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns - :: [Name] -> FreeVars -> RnM () -warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds -warnUnusedMatches = check_unused Opt_WarnUnusedMatches -warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns - -check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () -check_unused flag bound_names used_names - = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names) - bound_names)) - -------------------------- --- Helpers -warnUnusedGREs :: [GlobalRdrElt] -> RnM () -warnUnusedGREs gres = mapM_ warnUnusedGRE gres - -warnUnused :: WarningFlag -> [Name] -> RnM () -warnUnused flag names = do - fld_env <- mkFieldEnv <$> getGlobalRdrEnv - mapM_ (warnUnused1 flag fld_env) names - -warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM () -warnUnused1 flag fld_env name - = when (reportable name occ) $ - addUnusedWarning flag - occ (nameSrcSpan name) - (text "Defined but not used") - where - occ = case lookupNameEnv fld_env name of - Just (fl, _) -> mkVarOccFS fl - Nothing -> nameOccName name - -warnUnusedGRE :: GlobalRdrElt -> RnM () -warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) - | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv - warnUnused1 Opt_WarnUnusedTopBinds fld_env name - | otherwise = when (reportable name occ) (mapM_ warn is) - where - occ = greOccName gre - warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg - where - span = importSpecLoc spec - pp_mod = quotes (ppr (importSpecModule spec)) - msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used") - --- | Make a map from selector names to field labels and parent tycon --- names, to be used when reporting unused record fields. -mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name) -mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre))) - | gres <- occEnvElts rdr_env - , gre <- gres - , Just lbl <- [greLabel gre] - ] - --- | Should we report the fact that this 'Name' is unused? The --- 'OccName' may differ from 'nameOccName' due to --- DuplicateRecordFields. -reportable :: Name -> OccName -> Bool -reportable name occ - | isWiredInName name = False -- Don't report unused wired-in names - -- Otherwise we get a zillion warnings - -- from Data.Tuple - | otherwise = not (startsWithUnderscore occ) - -addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () -addUnusedWarning flag occ span msg - = addWarnAt (Reason flag) span $ - sep [msg <> colon, - nest 2 $ pprNonVarNameSpace (occNameSpace occ) - <+> quotes (ppr occ)] - -addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () -addNameClashErrRn rdr_name gres - | all isLocalGRE gres && not (all isRecFldGRE gres) - -- If there are two or more *local* defns, we'll have reported - = return () -- that already, and we don't want an error cascade - | otherwise - = addErr (vcat [text "Ambiguous occurrence" <+> quotes (ppr rdr_name), - text "It could refer to" <+> vcat (msg1 : msgs)]) - where - (np1:nps) = gres - msg1 = ptext (sLit "either") <+> mk_ref np1 - msgs = [text " or" <+> mk_ref np | np <- nps] - mk_ref gre = sep [nom <> comma, pprNameProvenance gre] - where nom = case gre_par gre of - FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl) - _ -> quotes (ppr (gre_name gre)) - -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)] - -perhapsForallMsg :: SDoc -perhapsForallMsg - = vcat [ text "Perhaps you intended to use ExplicitForAll or similar flag" - , text "to enable explicit-forall syntax: forall . "] - -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 - -badOrigBinding :: RdrName -> SDoc -badOrigBinding name - = text "Illegal binding of built-in syntax:" <+> ppr (rdrNameOcc name) - -- The rdrNameOcc is because we don't want to print Prelude.(,) - -dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM () -dupNamesErr get_loc names - = addErrAt big_loc $ - vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)), - locations] - where - locs = map get_loc names - big_loc = foldr1 combineSrcSpans locs - locations = text "Bound at:" <+> vcat (map ppr (sort locs)) - -kindSigErr :: Outputable a => a -> SDoc -kindSigErr thing - = hang (text "Illegal kind signature for" <+> quotes (ppr thing)) - 2 (text "Perhaps you intended to use KindSignatures") - -badQualBndrErr :: RdrName -> SDoc -badQualBndrErr rdr_name - = text "Qualified name in binding position:" <+> ppr rdr_name - -opDeclErr :: RdrName -> SDoc -opDeclErr n - = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n)) - 2 (text "Use TypeOperators to declare operators in type and declarations") - -checkTupSize :: Int -> RnM () -checkTupSize tup_size - | tup_size <= mAX_TUPLE_SIZE - = return () - | otherwise - = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), - nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), - nest 2 (text "Workaround: use nested tuples or define a data type")]) - -{- -************************************************************************ -* * -\subsection{Contexts for renaming errors} -* * -************************************************************************ --} - --- AZ:TODO: Change these all to be Name instead of RdrName. --- Merge TcType.UserTypeContext in to it. -data HsDocContext - = TypeSigCtx SDoc - | PatCtx - | SpecInstSigCtx - | DefaultDeclCtx - | ForeignDeclCtx (Located RdrName) - | DerivDeclCtx - | RuleCtx FastString - | TyDataCtx (Located RdrName) - | TySynCtx (Located RdrName) - | TyFamilyCtx (Located RdrName) - | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance - | ConDeclCtx [Located Name] - | ClassDeclCtx (Located RdrName) - | ExprWithTySigCtx - | TypBrCtx - | HsTypeCtx - | GHCiCtx - | SpliceTypeCtx (LHsType RdrName) - | ClassInstanceCtx - | VectDeclCtx (Located RdrName) - | GenericCtx SDoc -- Maybe we want to use this more! - -withHsDocContext :: HsDocContext -> SDoc -> SDoc -withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt - -inHsDocContext :: HsDocContext -> SDoc -inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt - -pprHsDocContext :: HsDocContext -> SDoc -pprHsDocContext (GenericCtx doc) = doc -pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc -pprHsDocContext PatCtx = text "a pattern type-signature" -pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" -pprHsDocContext DefaultDeclCtx = text "a `default' declaration" -pprHsDocContext DerivDeclCtx = text "a deriving declaration" -pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name -pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) -pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) -pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) -pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) -pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) -pprHsDocContext ExprWithTySigCtx = text "an expression type signature" -pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" -pprHsDocContext HsTypeCtx = text "a type argument" -pprHsDocContext GHCiCtx = text "GHCi input" -pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) -pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances" - -pprHsDocContext (ForeignDeclCtx name) - = text "the foreign declaration for" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx [name]) - = text "the definition of data constructor" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx names) - = text "the definition of data constructors" <+> interpp'SP names -pprHsDocContext (VectDeclCtx tycon) - = text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon) diff --git a/rename/RnExpr.hs b/rename/RnExpr.hs deleted file mode 100644 --- a/rename/RnExpr.hs +++ /dev/null @@ -1,2067 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnExpr]{Renaming of expressions} - -Basically dependency analysis. - -Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In -general, all of these functions return a renamed thing, and a set of -free variables. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiWayIf #-} - -module RnExpr ( - rnLExpr, rnExpr, rnStmts - ) where - -#include "HsVersions.h" - -import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, - rnMatchGroup, rnGRHS, makeMiniFixityEnv) -import HsSyn -import TcRnMonad -import Module ( getModule ) -import RnEnv -import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName ) -import RnTypes -import RnPat -import DynFlags -import PrelNames - -import BasicTypes -import Name -import NameSet -import RdrName -import UniqSet -import Data.List -import Util -import ListSetOps ( removeDups ) -import ErrUtils -import Outputable -import SrcLoc -import FastString -import Control.Monad -import TysWiredIn ( nilDataConName ) -import qualified GHC.LanguageExtensions as LangExt - -import Data.Ord -import Data.Array - -{- -************************************************************************ -* * -\subsubsection{Expressions} -* * -************************************************************************ --} - -rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars) -rnExprs ls = rnExprs' ls emptyUniqSet - where - rnExprs' [] acc = return ([], acc) - rnExprs' (expr:exprs) acc = - do { (expr', fvExpr) <- rnLExpr expr - -- Now we do a "seq" on the free vars because typically it's small - -- or empty, especially in very long lists of constants - ; let acc' = acc `plusFV` fvExpr - ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc' - ; return (expr':exprs', fvExprs) } - --- Variables. We look up the variable and return the resulting name. - -rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) -rnLExpr = wrapLocFstM rnExpr - -rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) - -finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars) --- Separated from rnExpr because it's also used --- when renaming infix expressions -finishHsVar (L l name) - = do { this_mod <- getModule - ; when (nameIsLocalOrFrom this_mod name) $ - checkThLocalName name - ; return (HsVar (L l name), unitFV name) } - -rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars) -rnUnboundVar v - = do { if isUnqual v - then -- Treat this as a "hole" - -- Do not fail right now; instead, return HsUnboundVar - -- and let the type checker report the error - do { let occ = rdrNameOcc v - ; uv <- if startsWithUnderscore occ - then return (TrueExprHole occ) - else OutOfScope occ <$> getGlobalRdrEnv - ; return (HsUnboundVar uv, emptyFVs) } - - else -- Fail immediately (qualified name) - do { n <- reportUnboundName v - ; return (HsVar (noLoc n), emptyFVs) } } - -rnExpr (HsVar (L l v)) - = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields - ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v - ; case mb_name of { - Nothing -> rnUnboundVar v ; - Just (Left name) - | name == nilDataConName -- Treat [] as an ExplicitList, so that - -- OverloadedLists works correctly - -> rnExpr (ExplicitList placeHolderType Nothing []) - - | otherwise - -> finishHsVar (L l name) ; - Just (Right [f@(FieldOcc (L _ fn) s)]) -> - return (HsRecFld (ambiguousFieldOcc (FieldOcc (L l fn) s)) - , unitFV (selectorFieldOcc f)) ; - Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous (L l v) - PlaceHolder) - , mkFVs (map selectorFieldOcc fs)); - Just (Right []) -> panic "runExpr/HsVar" } } - -rnExpr (HsIPVar v) - = return (HsIPVar v, emptyFVs) - -rnExpr (HsOverLabel _ v) - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if rebindable_on - then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel")) - ; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) } - else return (HsOverLabel Nothing v, emptyFVs) } - -rnExpr (HsLit lit@(HsString src s)) - = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings - ; if opt_OverloadedStrings then - rnExpr (HsOverLit (mkHsIsString src s placeHolderType)) - else do { - ; rnLit lit - ; return (HsLit lit, emptyFVs) } } - -rnExpr (HsLit lit) - = do { rnLit lit - ; return (HsLit lit, emptyFVs) } - -rnExpr (HsOverLit lit) - = do { (lit', fvs) <- rnOverLit lit - ; return (HsOverLit lit', fvs) } - -rnExpr (HsApp fun arg) - = do { (fun',fvFun) <- rnLExpr fun - ; (arg',fvArg) <- rnLExpr arg - ; return (HsApp fun' arg', fvFun `plusFV` fvArg) } - -rnExpr (HsAppType fun arg) - = do { (fun',fvFun) <- rnLExpr fun - ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg - ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) } - -rnExpr (OpApp e1 op _ e2) - = do { (e1', fv_e1) <- rnLExpr e1 - ; (e2', fv_e2) <- rnLExpr e2 - ; (op', fv_op) <- rnLExpr op - - -- Deal with fixity - -- When renaming code synthesised from "deriving" declarations - -- we used to avoid fixity stuff, but we can't easily tell any - -- more, so I've removed the test. Adding HsPars in TcGenDeriv - -- should prevent bad things happening. - ; fixity <- case op' of - L _ (HsVar (L _ n)) -> lookupFixityRn n - L _ (HsRecFld f) -> lookupFieldFixityRn f - _ -> return (Fixity NoSourceText minPrecedence InfixL) - -- c.f. lookupFixity for unbound - - ; final_e <- mkOpAppRn e1' op' fixity e2' - ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } - -rnExpr (NegApp e _) - = do { (e', fv_e) <- rnLExpr e - ; (neg_name, fv_neg) <- lookupSyntaxName negateName - ; final_e <- mkNegAppRn e' neg_name - ; return (final_e, fv_e `plusFV` fv_neg) } - ------------------------------------------- --- Template Haskell extensions --- Don't ifdef-GHCI them because we want to fail gracefully --- (not with an rnExpr crash) in a stage-1 compiler. -rnExpr e@(HsBracket br_body) = rnBracket e br_body - -rnExpr (HsSpliceE splice) = rnSpliceExpr splice - ---------------------------------------------- --- Sections --- See Note [Parsing sections] in Parser.y -rnExpr (HsPar (L loc (section@(SectionL {})))) - = do { (section', fvs) <- rnSection section - ; return (HsPar (L loc section'), fvs) } - -rnExpr (HsPar (L loc (section@(SectionR {})))) - = do { (section', fvs) <- rnSection section - ; return (HsPar (L loc section'), fvs) } - -rnExpr (HsPar e) - = do { (e', fvs_e) <- rnLExpr e - ; return (HsPar e', fvs_e) } - -rnExpr expr@(SectionL {}) - = do { addErr (sectionErr expr); rnSection expr } -rnExpr expr@(SectionR {}) - = do { addErr (sectionErr expr); rnSection expr } - ---------------------------------------------- -rnExpr (HsCoreAnn src ann expr) - = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsCoreAnn src ann expr', fvs_expr) } - -rnExpr (HsSCC src lbl expr) - = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsSCC src lbl expr', fvs_expr) } -rnExpr (HsTickPragma src info srcInfo expr) - = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsTickPragma src info srcInfo expr', fvs_expr) } - -rnExpr (HsLam matches) - = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches - ; return (HsLam matches', fvMatch) } - -rnExpr (HsLamCase matches) - = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsLamCase matches', fvs_ms) } - -rnExpr (HsCase expr matches) - = do { (new_expr, e_fvs) <- rnLExpr expr - ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } - -rnExpr (HsLet (L l binds) expr) - = rnLocalBindsAndThen binds $ \binds' _ -> do - { (expr',fvExpr) <- rnLExpr expr - ; return (HsLet (L l binds') expr', fvExpr) } - -rnExpr (HsDo do_or_lc (L l stmts) _) - = do { ((stmts', _), fvs) <- - rnStmtsWithPostProcessing do_or_lc rnLExpr - postProcessStmtsForApplicativeDo stmts - (\ _ -> return ((), emptyFVs)) - ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) } - -rnExpr (ExplicitList _ _ exps) - = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists - ; (exps', fvs) <- rnExprs exps - ; if opt_OverloadedLists - then do { - ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; return (ExplicitList placeHolderType (Just from_list_n_name) exps' - , fvs `plusFV` fvs') } - else - return (ExplicitList placeHolderType Nothing exps', fvs) } - -rnExpr (ExplicitPArr _ exps) - = do { (exps', fvs) <- rnExprs exps - ; return (ExplicitPArr placeHolderType exps', fvs) } - -rnExpr (ExplicitTuple tup_args boxity) - = do { checkTupleSection tup_args - ; checkTupSize (length tup_args) - ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args - ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) } - where - rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e - ; return (L l (Present e'), fvs) } - rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType) - , emptyFVs) - -rnExpr (ExplicitSum alt arity expr _) - = do { (expr', fvs) <- rnLExpr expr - ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) } - -rnExpr (RecordCon { rcon_con_name = con_id - , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) - = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id - ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds - ; (flds', fvss) <- mapAndUnzipM rn_field flds - ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd } - ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds' - , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder } - , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } - where - mk_hs_var l n = HsVar (L l n) - rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } - -rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) - = do { (expr', fvExpr) <- rnLExpr expr - ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds - ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds' - , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder - , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder } - , fvExpr `plusFV` fvRbinds) } - -rnExpr (ExprWithTySig expr pty) - = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty - ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ - rnLExpr expr - ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } - -rnExpr (HsIf _ p b1 b2) - = do { (p', fvP) <- rnLExpr p - ; (b1', fvB1) <- rnLExpr b1 - ; (b2', fvB2) <- rnLExpr b2 - ; (mb_ite, fvITE) <- lookupIfThenElse - ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } - -rnExpr (HsMultiIf _ty alts) - = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts - -- ; return (HsMultiIf ty alts', fvs) } - ; return (HsMultiIf placeHolderType alts', fvs) } - -rnExpr (ArithSeq _ _ seq) - = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists - ; (new_seq, fvs) <- rnArithSeq seq - ; if opt_OverloadedLists - then do { - ; (from_list_name, fvs') <- lookupSyntaxName fromListName - ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') } - else - return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } - -rnExpr (PArrSeq _ seq) - = do { (new_seq, fvs) <- rnArithSeq seq - ; return (PArrSeq noPostTcExpr new_seq, fvs) } - -{- -These three are pattern syntax appearing in expressions. -Since all the symbols are reservedops we can simply reject them. -We return a (bogus) EWildPat in each case. --} - -rnExpr EWildPat = return (hsHoleExpr, emptyFVs) -- "_" is just a hole -rnExpr e@(EAsPat {}) - = do { opt_TypeApplications <- xoptM LangExt.TypeApplications - ; let msg | opt_TypeApplications - = "Type application syntax requires a space before '@'" - | otherwise - = "Did you mean to enable TypeApplications?" - ; patSynErr e (text msg) - } -rnExpr e@(EViewPat {}) = patSynErr e empty -rnExpr e@(ELazyPat {}) = patSynErr e empty - -{- -************************************************************************ -* * - Static values -* * -************************************************************************ - -For the static form we check that the free variables are all top-level -value bindings. This is done by checking that the name is external or -wired-in. See the Notes about the NameSorts in Name.hs. --} - -rnExpr e@(HsStatic _ expr) = do - (expr',fvExpr) <- rnLExpr expr - stage <- getStage - case stage of - Splice _ -> addErr $ sep - [ text "static forms cannot be used in splices:" - , nest 2 $ ppr e - ] - _ -> return () - mod <- getModule - let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr - return (HsStatic fvExpr' expr', fvExpr) - -{- -************************************************************************ -* * - Arrow notation -* * -************************************************************************ --} - -rnExpr (HsProc pat body) - = newArrowScope $ - rnPat ProcExpr pat $ \ pat' -> do - { (body',fvBody) <- rnCmdTop body - ; return (HsProc pat' body', fvBody) } - --- Ideally, these would be done in parsing, but to keep parsing simple, we do it here. -rnExpr e@(HsArrApp {}) = arrowFail e -rnExpr e@(HsArrForm {}) = arrowFail e - -rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) - -- HsWrap - -hsHoleExpr :: HsExpr id -hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_")) - -arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) -arrowFail e - = do { addErr (vcat [ text "Arrow command found where an expression was expected:" - , nest 2 (ppr e) ]) - -- Return a place-holder hole, so that we can carry on - -- to report other errors - ; return (hsHoleExpr, emptyFVs) } - ----------------------- --- See Note [Parsing sections] in Parser.y -rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) -rnSection section@(SectionR op expr) - = do { (op', fvs_op) <- rnLExpr op - ; (expr', fvs_expr) <- rnLExpr expr - ; checkSectionPrec InfixR section op' expr' - ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) } - -rnSection section@(SectionL expr op) - = do { (expr', fvs_expr) <- rnLExpr expr - ; (op', fvs_op) <- rnLExpr op - ; checkSectionPrec InfixL section op' expr' - ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) } - -rnSection other = pprPanic "rnSection" (ppr other) - -{- -************************************************************************ -* * - Arrow commands -* * -************************************************************************ --} - -rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars) -rnCmdArgs [] = return ([], emptyFVs) -rnCmdArgs (arg:args) - = do { (arg',fvArg) <- rnCmdTop arg - ; (args',fvArgs) <- rnCmdArgs args - ; return (arg':args', fvArg `plusFV` fvArgs) } - -rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars) -rnCmdTop = wrapLocFstM rnCmdTop' - where - rnCmdTop' (HsCmdTop cmd _ _ _) - = do { (cmd', fvCmd) <- rnLCmd cmd - ; let cmd_names = [arrAName, composeAName, firstAName] ++ - nameSetElemsStable (methodNamesCmd (unLoc cmd')) - -- Generate the rebindable syntax for the monad - ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names - - ; return (HsCmdTop cmd' placeHolderType placeHolderType - (cmd_names `zip` cmd_names'), - fvCmd `plusFV` cmd_fvs) } - -rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars) -rnLCmd = wrapLocFstM rnCmd - -rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars) - -rnCmd (HsCmdArrApp arrow arg _ ho rtl) - = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) - ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, - fvArrow `plusFV` fvArg) } - where - select_arrow_scope tc = case ho of - HsHigherOrderApp -> tc - HsFirstOrderApp -> escapeArrowScope tc - -- See Note [Escaping the arrow scope] in TcRnTypes - -- Before renaming 'arrow', use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside 'arrow'. In the higher-order case (-<<), they are. - --- infix form -rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2]) - = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) - ; let L _ (HsVar (L _ op_name)) = op' - ; (arg1',fv_arg1) <- rnCmdTop arg1 - ; (arg2',fv_arg2) <- rnCmdTop arg2 - -- Deal with fixity - ; fixity <- lookupFixityRn op_name - ; final_e <- mkOpFormRn arg1' op' fixity arg2' - ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } - -rnCmd (HsCmdArrForm op f fixity cmds) - = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) - ; (cmds',fvCmds) <- rnCmdArgs cmds - ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) } - -rnCmd (HsCmdApp fun arg) - = do { (fun',fvFun) <- rnLCmd fun - ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) } - -rnCmd (HsCmdLam matches) - = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches - ; return (HsCmdLam matches', fvMatch) } - -rnCmd (HsCmdPar e) - = do { (e', fvs_e) <- rnLCmd e - ; return (HsCmdPar e', fvs_e) } - -rnCmd (HsCmdCase expr matches) - = do { (new_expr, e_fvs) <- rnLExpr expr - ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches - ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } - -rnCmd (HsCmdIf _ p b1 b2) - = do { (p', fvP) <- rnLExpr p - ; (b1', fvB1) <- rnLCmd b1 - ; (b2', fvB2) <- rnLCmd b2 - ; (mb_ite, fvITE) <- lookupIfThenElse - ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } - -rnCmd (HsCmdLet (L l binds) cmd) - = rnLocalBindsAndThen binds $ \ binds' _ -> do - { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet (L l binds') cmd', fvExpr) } - -rnCmd (HsCmdDo (L l stmts) _) - = do { ((stmts', _), fvs) <- - rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) } - -rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd) - ---------------------------------------------------- -type CmdNeeds = FreeVars -- Only inhabitants are - -- appAName, choiceAName, loopAName - --- find what methods the Cmd needs (loop, choice, apply) -methodNamesLCmd :: LHsCmd Name -> CmdNeeds -methodNamesLCmd = methodNamesCmd . unLoc - -methodNamesCmd :: HsCmd Name -> CmdNeeds - -methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl) - = emptyFVs -methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl) - = unitFV appAName -methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd - -methodNamesCmd (HsCmdPar c) = methodNamesLCmd c - -methodNamesCmd (HsCmdIf _ _ c1 c2) - = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName - -methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c -methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts -methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c -methodNamesCmd (HsCmdLam match) = methodNamesMatch match - -methodNamesCmd (HsCmdCase _ matches) - = methodNamesMatch matches `addOneFV` choiceAName - ---methodNamesCmd _ = emptyFVs - -- Other forms can't occur in commands, but it's not convenient - -- to error here so we just do what's convenient. - -- The type checker will complain later - ---------------------------------------------------- -methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars -methodNamesMatch (MG { mg_alts = L _ ms }) - = plusFVs (map do_one ms) - where - do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss - -------------------------------------------------- --- gaw 2004 -methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars -methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss) - -------------------------------------------------- - -methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds -methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs - ---------------------------------------------------- -methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars -methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) - ---------------------------------------------------- -methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars -methodNamesLStmt = methodNamesStmt . unLoc - -methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars -methodNamesStmt (LastStmt cmd _ _) = methodNamesLCmd cmd -methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd -methodNamesStmt (BindStmt _ cmd _ _ _) = methodNamesLCmd cmd -methodNamesStmt (RecStmt { recS_stmts = stmts }) = - methodNamesStmts stmts `addOneFV` loopAName -methodNamesStmt (LetStmt {}) = emptyFVs -methodNamesStmt (ParStmt {}) = emptyFVs -methodNamesStmt (TransStmt {}) = emptyFVs -methodNamesStmt ApplicativeStmt{} = emptyFVs - -- ParStmt and TransStmt can't occur in commands, but it's not - -- convenient to error here so we just do what's convenient - -{- -************************************************************************ -* * - Arithmetic sequences -* * -************************************************************************ --} - -rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars) -rnArithSeq (From expr) - = do { (expr', fvExpr) <- rnLExpr expr - ; return (From expr', fvExpr) } - -rnArithSeq (FromThen expr1 expr2) - = do { (expr1', fvExpr1) <- rnLExpr expr1 - ; (expr2', fvExpr2) <- rnLExpr expr2 - ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) } - -rnArithSeq (FromTo expr1 expr2) - = do { (expr1', fvExpr1) <- rnLExpr expr1 - ; (expr2', fvExpr2) <- rnLExpr expr2 - ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) } - -rnArithSeq (FromThenTo expr1 expr2 expr3) - = do { (expr1', fvExpr1) <- rnLExpr expr1 - ; (expr2', fvExpr2) <- rnLExpr expr2 - ; (expr3', fvExpr3) <- rnLExpr expr3 - ; return (FromThenTo expr1' expr2' expr3', - plusFVs [fvExpr1, fvExpr2, fvExpr3]) } - -{- -************************************************************************ -* * -\subsubsection{@Stmt@s: in @do@ expressions} -* * -************************************************************************ --} - -{- -Note [Deterministic ApplicativeDo and RecursiveDo desugaring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Both ApplicativeDo and RecursiveDo need to create tuples not -present in the source text. - -For ApplicativeDo we create: - - (a,b,c) <- (\c b a -> (a,b,c)) <$> - -For RecursiveDo we create: - - mfix (\ ~(a,b,c) -> do ...; return (a',b',c')) - -The order of the components in those tuples needs to be stable -across recompilations, otherwise they can get optimized differently -and we end up with incompatible binaries. -To get a stable order we use nameSetElemsStable. -See Note [Deterministic UniqFM] to learn more about nondeterminism. --} - --- | Rename some Stmts -rnStmts :: Outputable (body RdrName) - => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -- ^ How to rename the body of each statement (e.g. rnLExpr) - -> [LStmt RdrName (Located (body RdrName))] - -- ^ Statements - -> ([Name] -> RnM (thing, FreeVars)) - -- ^ if these statements scope over something, this renames it - -- and returns the result. - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) -rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts - --- | like 'rnStmts' but applies a post-processing step to the renamed Stmts -rnStmtsWithPostProcessing - :: Outputable (body RdrName) - => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -- ^ How to rename the body of each statement (e.g. rnLExpr) - -> (HsStmtContext Name - -> [(LStmt Name (Located (body Name)), FreeVars)] - -> RnM ([LStmt Name (Located (body Name))], FreeVars)) - -- ^ postprocess the statements - -> [LStmt RdrName (Located (body RdrName))] - -- ^ Statements - -> ([Name] -> RnM (thing, FreeVars)) - -- ^ if these statements scope over something, this renames it - -- and returns the result. - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) -rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside - = do { ((stmts', thing), fvs) <- - rnStmtsWithFreeVars ctxt rnBody stmts thing_inside - ; (pp_stmts, fvs') <- ppStmts ctxt stmts' - ; return ((pp_stmts, thing), fvs `plusFV` fvs') - } - --- | maybe rearrange statements according to the ApplicativeDo transformation -postProcessStmtsForApplicativeDo - :: HsStmtContext Name - -> [(ExprLStmt Name, FreeVars)] - -> RnM ([ExprLStmt Name], FreeVars) -postProcessStmtsForApplicativeDo ctxt stmts - = do { - -- rearrange the statements using ApplicativeStmt if - -- -XApplicativeDo is on. Also strip out the FreeVars attached - -- to each Stmt body. - ado_is_on <- xoptM LangExt.ApplicativeDo - ; let is_do_expr | DoExpr <- ctxt = True - | otherwise = False - ; if ado_is_on && is_do_expr - then rearrangeForApplicativeDo ctxt stmts - else noPostProcessStmts ctxt stmts } - --- | strip the FreeVars annotations from statements -noPostProcessStmts - :: HsStmtContext Name - -> [(LStmt Name (Located (body Name)), FreeVars)] - -> RnM ([LStmt Name (Located (body Name))], FreeVars) -noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) - - -rnStmtsWithFreeVars :: Outputable (body RdrName) - => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> [LStmt RdrName (Located (body RdrName))] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing) - , FreeVars) --- Each Stmt body is annotated with its FreeVars, so that --- we can rearrange statements for ApplicativeDo. --- --- Variables bound by the Stmts, and mentioned in thing_inside, --- do not appear in the result FreeVars - -rnStmtsWithFreeVars ctxt _ [] thing_inside - = do { checkEmptyStmts ctxt - ; (thing, fvs) <- thing_inside [] - ; return (([], thing), fvs) } - -rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside -- Deal with mdo - = -- Behave like do { rec { ...all but last... }; last } - do { ((stmts1, (stmts2, thing)), fvs) - <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> - do { last_stmt' <- checkLastStmt MDoExpr last_stmt - ; rnStmt MDoExpr rnBody last_stmt' thing_inside } - ; return (((stmts1 ++ stmts2), thing), fvs) } - where - Just (all_but_last, last_stmt) = snocView stmts - -rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside - | null lstmts - = setSrcSpan loc $ - do { lstmt' <- checkLastStmt ctxt lstmt - ; rnStmt ctxt rnBody lstmt' thing_inside } - - | otherwise - = do { ((stmts1, (stmts2, thing)), fvs) - <- setSrcSpan loc $ - do { checkStmt ctxt lstmt - ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> - rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 -> - thing_inside (bndrs1 ++ bndrs2) } - ; return (((stmts1 ++ stmts2), thing), fvs) } - ----------------------- - -{- -Note [Failing pattern matches in Stmts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Many things desugar to HsStmts including monadic things like `do` and `mdo` -statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an -exhaustive list). How we deal with pattern match failure is context-dependent. - - * In the case of list comprehensions and pattern guards we don't need any 'fail' - function; the desugarer ignores the fail function field of 'BindStmt' entirely. - * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo - expressions) we want pattern match failure to be desugared to the appropriate - 'fail' function (either that of Monad or MonadFail, depending on whether - -XMonadFailDesugaring is enabled.) - -At one point we failed to make this distinction, leading to #11216. --} - -rnStmt :: Outputable (body RdrName) - => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -- ^ How to rename the body of the statement - -> LStmt RdrName (Located (body RdrName)) - -- ^ The statement - -> ([Name] -> RnM (thing, FreeVars)) - -- ^ Rename the stuff that this statement scopes over - -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing) - , FreeVars) --- Variables bound by the Stmt, and mentioned in thing_inside, --- do not appear in the result FreeVars - -rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside - = do { (body', fv_expr) <- rnBody body - ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName - ; (thing, fvs3) <- thing_inside [] - ; return (([(L loc (LastStmt body' noret ret_op), fv_expr)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs3) } - -rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside - = do { (body', fv_expr) <- rnBody body - ; (then_op, fvs1) <- lookupStmtName ctxt thenMName - ; (guard_op, fvs2) <- if isListCompExpr ctxt - then lookupStmtName ctxt guardMName - else return (noSyntaxExpr, emptyFVs) - -- Only list/parr/monad comprehensions use 'guard' - -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] - -- Here "gd" is a guard - ; (thing, fvs3) <- thing_inside [] - ; return (([(L loc (BodyStmt body' - then_op guard_op placeHolderType), fv_expr)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } - -rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside - = do { (body', fv_expr) <- rnBody body - -- The binders do not scope over the expression - ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName - - ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags - ; let getFailFunction - -- If the pattern is irrefutible (e.g.: wildcard, tuple, - -- ~pat, etc.) we should not need to fail. - | isIrrefutableHsPat pat - = return (noSyntaxExpr, emptyFVs) - -- For non-monadic contexts (e.g. guard patterns, list - -- comprehensions, etc.) we should not need to fail. - -- See Note [Failing pattern matches in Stmts] - | not (isMonadFailStmtContext ctxt) - = return (noSyntaxExpr, emptyFVs) - | xMonadFailEnabled = lookupSyntaxName failMName - | otherwise = lookupSyntaxName failMName_preMFP - ; (fail_op, fvs2) <- getFailFunction - - ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do - { (thing, fvs3) <- thing_inside (collectPatBinders pat') - ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder) - , fv_expr )] - , thing), - fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} - -- fv_expr shouldn't really be filtered by the rnPatsAndThen - -- but it does not matter because the names are unique - -rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside - = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do - { (thing, fvs) <- thing_inside (collectLocalBinders binds') - ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) } } - -rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside - = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName - ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName - ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName - ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op - , recS_mfix_fn = mfix_op - , recS_bind_fn = bind_op } - - -- Step1: Bring all the binders of the mdo into scope - -- (Remember that this also removes the binders from the - -- finally-returned free-vars.) - -- And rename each individual stmt, making a - -- singleton segment. At this stage the FwdRefs field - -- isn't finished: it's empty for all except a BindStmt - -- for which it's the fwd refs within the bind itself - -- (This set may not be empty, because we're in a recursive - -- context.) - ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do - { let bndrs = nameSetElemsStable $ - foldr (unionNameSet . (\(ds,_,_,_) -> ds)) - emptyNameSet - segs - -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] - ; (thing, fvs_later) <- thing_inside bndrs - ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later - -- We aren't going to try to group RecStmts with - -- ApplicativeDo, so attaching empty FVs is fine. - ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing) - , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } - -rnStmt ctxt _ (L loc (ParStmt segs _ _ _)) thing_inside - = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName - ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName - ; (return_op, fvs3) <- lookupStmtName ctxt returnMName - ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside - ; return ( ([(L loc (ParStmt segs' mzip_op bind_op placeHolderType), fvs4)], thing) - , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } - -rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form - , trS_using = using })) thing_inside - = do { -- Rename the 'using' expression in the context before the transform is begun - (using', fvs1) <- rnLExpr using - - -- Rename the stmts and the 'by' expression - -- Keep track of the variables mentioned in the 'by' expression - ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> - do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by - ; (thing, fvs_thing) <- thing_inside bndrs - ; let fvs = fvs_by `plusFV` fvs_thing - used_bndrs = filter (`elemNameSet` fvs) bndrs - -- The paper (Fig 5) has a bug here; we must treat any free variable - -- of the "thing inside", **or of the by-expression**, as used - ; return ((by', used_bndrs, thing), fvs) } - - -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions - ; (return_op, fvs3) <- lookupStmtName ctxt returnMName - ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName - ; (fmap_op, fvs5) <- case form of - ThenForm -> return (noExpr, emptyFVs) - _ -> lookupStmtNamePoly ctxt fmapName - - ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 - `plusFV` fvs4 `plusFV` fvs5 - bndr_map = used_bndrs `zip` used_bndrs - -- See Note [TransStmt binder map] in HsExpr - - ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map) - ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map - , trS_by = by', trS_using = using', trS_form = form - , trS_ret = return_op, trS_bind = bind_op - , trS_bind_arg_ty = PlaceHolder - , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) } - -rnStmt _ _ (L _ ApplicativeStmt{}) _ = - panic "rnStmt: ApplicativeStmt" - -rnParallelStmts :: forall thing. HsStmtContext Name - -> SyntaxExpr Name - -> [ParStmtBlock RdrName RdrName] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([ParStmtBlock Name Name], thing), FreeVars) --- Note [Renaming parallel Stmts] -rnParallelStmts ctxt return_op segs thing_inside - = do { orig_lcl_env <- getLocalRdrEnv - ; rn_segs orig_lcl_env [] segs } - where - rn_segs :: LocalRdrEnv - -> [Name] -> [ParStmtBlock RdrName RdrName] - -> RnM (([ParStmtBlock Name Name], thing), FreeVars) - rn_segs _ bndrs_so_far [] - = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far - ; mapM_ dupErr dups - ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') - ; return (([], thing), fvs) } - - rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) - = do { ((stmts', (used_bndrs, segs', thing)), fvs) - <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> - setLocalRdrEnv env $ do - { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs - ; let used_bndrs = filter (`elemNameSet` fvs) bndrs - ; return ((used_bndrs, segs', thing), fvs) } - - ; let seg' = ParStmtBlock stmts' used_bndrs return_op - ; return ((seg':segs', thing), fvs) } - - cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 - dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" - <+> quotes (ppr (head vs))) - -lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr Name, FreeVars) --- Like lookupSyntaxName, but respects contexts -lookupStmtName ctxt n - | rebindableContext ctxt - = lookupSyntaxName n - | otherwise - = return (mkRnSyntaxExpr n, emptyFVs) - -lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) -lookupStmtNamePoly ctxt name - | rebindableContext ctxt - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if rebindable_on - then do { fm <- lookupOccRn (nameRdrName name) - ; return (HsVar (noLoc fm), unitFV fm) } - else not_rebindable } - | otherwise - = not_rebindable - where - not_rebindable = return (HsVar (noLoc name), emptyFVs) - --- | Is this a context where we respect RebindableSyntax? --- but ListComp/PArrComp are never rebindable --- Neither is ArrowExpr, which has its own desugarer in DsArrows -rebindableContext :: HsStmtContext Name -> Bool -rebindableContext ctxt = case ctxt of - ListComp -> False - PArrComp -> False - ArrowExpr -> False - PatGuard {} -> False - - DoExpr -> True - MDoExpr -> True - MonadComp -> True - GhciStmtCtxt -> True -- I suppose? - - ParStmtCtxt c -> rebindableContext c -- Look inside to - TransStmtCtxt c -> rebindableContext c -- the parent context - -{- -Note [Renaming parallel Stmts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Renaming parallel statements is painful. Given, say - [ a+c | a <- as, bs <- bss - | c <- bs, a <- ds ] -Note that - (a) In order to report "Defined but not used" about 'bs', we must - rename each group of Stmts with a thing_inside whose FreeVars - include at least {a,c} - - (b) We want to report that 'a' is illegally bound in both branches - - (c) The 'bs' in the second group must obviously not be captured by - the binding in the first group - -To satisfy (a) we nest the segements. -To satisfy (b) we check for duplicates just before thing_inside. -To satisfy (c) we reset the LocalRdrEnv each time. - -************************************************************************ -* * -\subsubsection{mdo expressions} -* * -************************************************************************ --} - -type FwdRefs = NameSet -type Segment stmts = (Defs, - Uses, -- May include defs - FwdRefs, -- A subset of uses that are - -- (a) used before they are bound in this segment, or - -- (b) used here, and bound in subsequent segments - stmts) -- Either Stmt or [Stmt] - - --- wrapper that does both the left- and right-hand sides -rnRecStmtsAndThen :: Outputable (body RdrName) => - (Located (body RdrName) - -> RnM (Located (body Name), FreeVars)) - -> [LStmt RdrName (Located (body RdrName))] - -- assumes that the FreeVars returned includes - -- the FreeVars of the Segments - -> ([Segment (LStmt Name (Located (body Name)))] - -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnRecStmtsAndThen rnBody s cont - = do { -- (A) Make the mini fixity env for all of the stmts - fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) - - -- (B) Do the LHSes - ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s - - -- ...bring them and their fixities into scope - ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) - -- Fake uses of variables introduced implicitly (warning suppression, see #4404) - implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv) - ; bindLocalNamesFV bound_names $ - addLocalFixities fix_env bound_names $ do - - -- (C) do the right-hand-sides and thing-inside - { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv - ; (res, fvs) <- cont segs - ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses) - ; return (res, fvs) }} - --- get all the fixity decls in any Let stmt -collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName] -collectRecStmtsFixities l = - foldr (\ s -> \acc -> case s of - (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) -> - foldr (\ sig -> \ acc -> case sig of - (L loc (FixSig s)) -> (L loc s) : acc - _ -> acc) acc sigs - _ -> acc) [] l - --- left-hand sides - -rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv - -> LStmt RdrName body - -- rename LHS, and return its FVs - -- Warning: we will only need the FreeVars below in the case of a BindStmt, - -- so we don't bother to compute it accurately in the other cases - -> RnM [(LStmtLR Name RdrName body, FreeVars)] - -rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) - = return [(L loc (BodyStmt body a b c), emptyFVs)] - -rn_rec_stmt_lhs _ (L loc (LastStmt body noret a)) - = return [(L loc (LastStmt body noret a), emptyFVs)] - -rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t)) - = do - -- should the ctxt be MDo instead? - (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat - return [(L loc (BindStmt pat' body a b t), - fv_pat)] - -rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _)))) - = failWith (badIpBinds (text "an mdo expression") binds) - -rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds)))) - = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds - return [(L loc (LetStmt (L l (HsValBinds binds'))), - -- Warning: this is bogus; see function invariant - emptyFVs - )] - --- XXX Do we need to do something with the return and mfix names? -rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec - = rn_rec_stmts_lhs fix_env stmts - -rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt" (ppr stmt) - -rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt" (ppr stmt) - -rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet - = pprPanic "rn_rec_stmt" (ppr stmt) - -rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds))) - = panic "rn_rec_stmt LetStmt EmptyLocalBinds" - -rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv - -> [LStmt RdrName body] - -> RnM [(LStmtLR Name RdrName body, FreeVars)] -rn_rec_stmts_lhs fix_env stmts - = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts - ; let boundNames = collectLStmtsBinders (map fst ls) - -- First do error checking: we need to check for dups here because we - -- don't bind all of the variables from the Stmt at once - -- with bindLocatedLocals. - ; checkDupNames boundNames - ; return ls } - - --- right-hand-sides - -rn_rec_stmt :: (Outputable (body RdrName)) => - (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> [Name] - -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars) - -> RnM [Segment (LStmt Name (Located (body Name)))] - -- Rename a Stmt that is inside a RecStmt (or mdo) - -- Assumes all binders are already in scope - -- Turns each stmt into a singleton Stmt -rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _) - = do { (body', fv_expr) <- rnBody body - ; (ret_op, fvs1) <- lookupSyntaxName returnMName - ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, - L loc (LastStmt body' noret ret_op))] } - -rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _) - = do { (body', fvs) <- rnBody body - ; (then_op, fvs1) <- lookupSyntaxName thenMName - ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] } - -rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat) - = do { (body', fv_expr) <- rnBody body - ; (bind_op, fvs1) <- lookupSyntaxName bindMName - - ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags - ; let failFunction | xMonadFailEnabled = failMName - | otherwise = failMName_preMFP - ; (fail_op, fvs2) <- lookupSyntaxName failFunction - - ; let bndrs = mkNameSet (collectPatBinders pat') - fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 - ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] } - -rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _) - = failWith (badIpBinds (text "an mdo expression") binds) - -rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _) - = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' - -- fixities and unused are handled above in rnRecStmtsAndThen - ; let fvs = allUses du_binds - ; return [(duDefs du_binds, fvs, emptyNameSet, - L loc (LetStmt (L l (HsValBinds binds'))))] } - --- no RecStmt case because they get flattened above when doing the LHSes -rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _) - = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) - -rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) - -rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) - -rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _) - = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" - -rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) - = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) - -rn_rec_stmts :: Outputable (body RdrName) => - (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> [Name] - -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] - -> RnM [Segment (LStmt Name (Located (body Name)))] -rn_rec_stmts rnBody bndrs stmts - = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts - ; return (concat segs_s) } - ---------------------------------------------- -segmentRecStmts :: SrcSpan -> HsStmtContext Name - -> Stmt Name body - -> [Segment (LStmt Name body)] -> FreeVars - -> ([LStmt Name body], FreeVars) - -segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later - | null segs - = ([], fvs_later) - - | MDoExpr <- ctxt - = segsToStmts empty_rec_stmt grouped_segs fvs_later - -- Step 4: Turn the segments into Stmts - -- Use RecStmt when and only when there are fwd refs - -- Also gather up the uses from the end towards the - -- start, so we can tell the RecStmt which things are - -- used 'after' the RecStmt - - | otherwise - = ([ L loc $ - empty_rec_stmt { recS_stmts = ss - , recS_later_ids = nameSetElemsStable - (defs `intersectNameSet` fvs_later) - , recS_rec_ids = nameSetElemsStable - (defs `intersectNameSet` uses) }] - -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] - , uses `plusFV` fvs_later) - - where - (defs_s, uses_s, _, ss) = unzip4 segs - defs = plusFVs defs_s - uses = plusFVs uses_s - - -- Step 2: Fill in the fwd refs. - -- The segments are all singletons, but their fwd-ref - -- field mentions all the things used by the segment - -- that are bound after their use - segs_w_fwd_refs = addFwdRefs segs - - -- Step 3: Group together the segments to make bigger segments - -- Invariant: in the result, no segment uses a variable - -- bound in a later segment - grouped_segs = glomSegments ctxt segs_w_fwd_refs - ----------------------------- -addFwdRefs :: [Segment a] -> [Segment a] --- So far the segments only have forward refs *within* the Stmt --- (which happens for bind: x <- ...x...) --- This function adds the cross-seg fwd ref info - -addFwdRefs segs - = fst (foldr mk_seg ([], emptyNameSet) segs) - where - mk_seg (defs, uses, fwds, stmts) (segs, later_defs) - = (new_seg : segs, all_defs) - where - new_seg = (defs, uses, new_fwds, stmts) - all_defs = later_defs `unionNameSet` defs - new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs) - -- Add the downstream fwd refs here - -{- -Note [Segmenting mdo] -~~~~~~~~~~~~~~~~~~~~~ -NB. June 7 2012: We only glom segments that appear in an explicit mdo; -and leave those found in "do rec"'s intact. See -http://ghc.haskell.org/trac/ghc/ticket/4148 for the discussion -leading to this design choice. Hence the test in segmentRecStmts. - -Note [Glomming segments] -~~~~~~~~~~~~~~~~~~~~~~~~ -Glomming the singleton segments of an mdo into minimal recursive groups. - -At first I thought this was just strongly connected components, but -there's an important constraint: the order of the stmts must not change. - -Consider - mdo { x <- ...y... - p <- z - y <- ...x... - q <- x - z <- y - r <- x } - -Here, the first stmt mention 'y', which is bound in the third. -But that means that the innocent second stmt (p <- z) gets caught -up in the recursion. And that in turn means that the binding for -'z' has to be included... and so on. - -Start at the tail { r <- x } -Now add the next one { z <- y ; r <- x } -Now add one more { q <- x ; z <- y ; r <- x } -Now one more... but this time we have to group a bunch into rec - { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x } -Now one more, which we can add on without a rec - { p <- z ; - rec { y <- ...x... ; q <- x ; z <- y } ; - r <- x } -Finally we add the last one; since it mentions y we have to -glom it together with the first two groups - { rec { x <- ...y...; p <- z ; y <- ...x... ; - q <- x ; z <- y } ; - r <- x } --} - -glomSegments :: HsStmtContext Name - -> [Segment (LStmt Name body)] - -> [Segment [LStmt Name body]] -- Each segment has a non-empty list of Stmts --- See Note [Glomming segments] - -glomSegments _ [] = [] -glomSegments ctxt ((defs,uses,fwds,stmt) : segs) - -- Actually stmts will always be a singleton - = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others - where - segs' = glomSegments ctxt segs - (extras, others) = grab uses segs' - (ds, us, fs, ss) = unzip4 extras - - seg_defs = plusFVs ds `plusFV` defs - seg_uses = plusFVs us `plusFV` uses - seg_fwds = plusFVs fs `plusFV` fwds - seg_stmts = stmt : concat ss - - grab :: NameSet -- The client - -> [Segment a] - -> ([Segment a], -- Needed by the 'client' - [Segment a]) -- Not needed by the client - -- The result is simply a split of the input - grab uses dus - = (reverse yeses, reverse noes) - where - (noes, yeses) = span not_needed (reverse dus) - not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) - ----------------------------------------------------- -segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in - -> [Segment [LStmt Name body]] -- Each Segment has a non-empty list of Stmts - -> FreeVars -- Free vars used 'later' - -> ([LStmt Name body], FreeVars) - -segsToStmts _ [] fvs_later = ([], fvs_later) -segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later - = ASSERT( not (null ss) ) - (new_stmt : later_stmts, later_uses `plusFV` uses) - where - (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later - new_stmt | non_rec = head ss - | otherwise = L (getLoc (head ss)) rec_stmt - rec_stmt = empty_rec_stmt { recS_stmts = ss - , recS_later_ids = nameSetElemsStable used_later - , recS_rec_ids = nameSetElemsStable fwds } - -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] - non_rec = isSingleton ss && isEmptyNameSet fwds - used_later = defs `intersectNameSet` later_uses - -- The ones needed after the RecStmt - -{- -************************************************************************ -* * -ApplicativeDo -* * -************************************************************************ - -Note [ApplicativeDo] - -= Example = - -For a sequence of statements - - do - x <- A - y <- B x - z <- C - return (f x y z) - -We want to transform this to - - (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C - -It would be easy to notice that "y <- B x" and "z <- C" are -independent and do something like this: - - do - x <- A - (y,z) <- (,) <$> B x <*> C - return (f x y z) - -But this isn't enough! A and C were also independent, and this -transformation loses the ability to do A and C in parallel. - -The algorithm works by first splitting the sequence of statements into -independent "segments", and a separate "tail" (the final statement). In -our example above, the segements would be - - [ x <- A - , y <- B x ] - - [ z <- C ] - -and the tail is: - - return (f x y z) - -Then we take these segments and make an Applicative expression from them: - - (\(x,y) z -> return (f x y z)) - <$> do { x <- A; y <- B x; return (x,y) } - <*> C - -Finally, we recursively apply the transformation to each segment, to -discover any nested parallelism. - -= Syntax & spec = - - expr ::= ... | do {stmt_1; ..; stmt_n} expr | ... - - stmt ::= pat <- expr - | (arg_1 | ... | arg_n) -- applicative composition, n>=1 - | ... -- other kinds of statement (e.g. let) - - arg ::= pat <- expr - | {stmt_1; ..; stmt_n} {var_1..var_n} - -(note that in the actual implementation,the expr in a do statement is -represented by a LastStmt as the final stmt, this is just a -representational issue and may change later.) - -== Transformation to introduce applicative stmts == - -ado {} tail = tail -ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr' -ado {one} tail = one : tail -ado stmts tail - | n == 1 = ado before (ado after tail) - where (before,after) = split(stmts_1) - | n > 1 = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail - where - {stmts_1 .. stmts_n} = segments(stmts) - -segments(stmts) = - -- divide stmts into segments with no interdependencies - -mkArg({pat <- expr}) = (pat <- expr) -mkArg({stmt_1; ...; stmt_n}) = - {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)} - -split({stmt_1; ..; stmt_n) = - ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n}) - -- 1 <= i <= n - -- i is a good place to insert a bind - -== Desugaring for do == - -dsDo {} expr = expr - -dsDo {pat <- rhs; stmts} expr = - rhs >>= \pat -> dsDo stmts expr - -dsDo {(arg_1 | ... | arg_n)} (return expr) = - (\argpat (arg_1) .. argpat(arg_n) -> expr) - <$> argexpr(arg_1) - <*> ... - <*> argexpr(arg_n) - -dsDo {(arg_1 | ... | arg_n); stmts} expr = - join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr) - <$> argexpr(arg_1) - <*> ... - <*> argexpr(arg_n) - --} - --- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and --- 'pureName' due to @RebindableSyntax@. -data MonadNames = MonadNames { return_name, pure_name :: Name } - --- | rearrange a list of statements using ApplicativeDoStmt. See --- Note [ApplicativeDo]. -rearrangeForApplicativeDo - :: HsStmtContext Name - -> [(ExprLStmt Name, FreeVars)] - -> RnM ([ExprLStmt Name], FreeVars) - -rearrangeForApplicativeDo _ [] = return ([], emptyNameSet) -rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet) -rearrangeForApplicativeDo ctxt stmts0 = do - optimal_ado <- goptM Opt_OptimalApplicativeDo - let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts - | otherwise = mkStmtTreeHeuristic stmts - return_name <- lookupSyntaxName' returnMName - pure_name <- lookupSyntaxName' pureAName - let monad_names = MonadNames { return_name = return_name - , pure_name = pure_name } - stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs - where - (stmts,(last,last_fvs)) = findLast stmts0 - findLast [] = error "findLast" - findLast [last] = ([],last) - findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs - --- | A tree of statements using a mixture of applicative and bind constructs. -data StmtTree a - = StmtTreeOne a - | StmtTreeBind (StmtTree a) (StmtTree a) - | StmtTreeApplicative [StmtTree a] - -flattenStmtTree :: StmtTree a -> [a] -flattenStmtTree t = go t [] - where - go (StmtTreeOne a) as = a : as - go (StmtTreeBind l r) as = go l (go r as) - go (StmtTreeApplicative ts) as = foldr go as ts - -type ExprStmtTree = StmtTree (ExprLStmt Name, FreeVars) -type Cost = Int - --- | Turn a sequence of statements into an ExprStmtTree using a --- heuristic algorithm. /O(n^2)/ -mkStmtTreeHeuristic :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree -mkStmtTreeHeuristic [one] = StmtTreeOne one -mkStmtTreeHeuristic stmts = - case segments stmts of - [one] -> split one - segs -> StmtTreeApplicative (map split segs) - where - split [one] = StmtTreeOne one - split stmts = - StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after) - where (before, after) = splitSegment stmts - --- | Turn a sequence of statements into an ExprStmtTree optimally, --- using dynamic programming. /O(n^3)/ -mkStmtTreeOptimal :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree -mkStmtTreeOptimal stmts = - ASSERT(not (null stmts)) -- the empty case is handled by the caller; - -- we don't support empty StmtTrees. - fst (arr ! (0,n)) - where - n = length stmts - 1 - stmt_arr = listArray (0,n) stmts - - -- lazy cache of optimal trees for subsequences of the input - arr :: Array (Int,Int) (ExprStmtTree, Cost) - arr = array ((0,0),(n,n)) - [ ((lo,hi), tree lo hi) - | lo <- [0..n] - , hi <- [lo..n] ] - - -- compute the optimal tree for the sequence [lo..hi] - tree lo hi - | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) - | otherwise = - case segments [ stmt_arr ! i | i <- [lo..hi] ] of - [] -> panic "mkStmtTree" - [_one] -> split lo hi - segs -> (StmtTreeApplicative trees, maximum costs) - where - bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs - (trees,costs) = unzip (map (uncurry split) (tail bounds)) - - -- find the best place to split the segment [lo..hi] - split :: Int -> Int -> (ExprStmtTree, Cost) - split lo hi - | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) - | otherwise = (StmtTreeBind before after, c1+c2) - where - -- As per the paper, for a sequence s1...sn, we want to find - -- the split with the minimum cost, where the cost is the - -- sum of the cost of the left and right subsequences. - -- - -- As an optimisation (also in the paper) if the cost of - -- s1..s(n-1) is different from the cost of s2..sn, we know - -- that the optimal solution is the lower of the two. Only - -- in the case that these two have the same cost do we need - -- to do the exhaustive search. - -- - ((before,c1),(after,c2)) - | hi - lo == 1 - = ((StmtTreeOne (stmt_arr ! lo), 1), - (StmtTreeOne (stmt_arr ! hi), 1)) - | left_cost < right_cost - = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1)) - | left_cost > right_cost - = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost)) - | otherwise = minimumBy (comparing cost) alternatives - where - (left, left_cost) = arr ! (lo,hi-1) - (right, right_cost) = arr ! (lo+1,hi) - cost ((_,c1),(_,c2)) = c1 + c2 - alternatives = [ (arr ! (lo,k), arr ! (k+1,hi)) - | k <- [lo .. hi-1] ] - - --- | Turn the ExprStmtTree back into a sequence of statements, using --- ApplicativeStmt where necessary. -stmtTreeToStmts - :: MonadNames - -> HsStmtContext Name - -> ExprStmtTree - -> [ExprLStmt Name] -- ^ the "tail" - -> FreeVars -- ^ free variables of the tail - -> RnM ( [ExprLStmt Name] -- ( output statements, - , FreeVars ) -- , things we needed - --- If we have a single bind, and we can do it without a join, transform --- to an ApplicativeStmt. This corresponds to the rule --- dsBlock [pat <- rhs] (return expr) = expr <$> rhs --- In the spec, but we do it here rather than in the desugarer, --- because we need the typechecker to typecheck the <$> form rather than --- the bind form, which would give rise to a Monad constraint. -stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt pat rhs _ _ _),_)) - tail _tail_fvs - | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail - -- See Note [ApplicativeDo and strict patterns] - = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail' - -stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = - return (s : tail, emptyNameSet) - -stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do - (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs - let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after)) - (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs - return (stmts2, fvs1 `plusFV` fvs2) - -stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do - pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees - let (stmts', fvss) = unzip pairs - let (need_join, tail') = needJoin monad_names tail - (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' - return (stmts, unionNameSets (fvs:fvss)) - where - stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt pat exp _ _ _), _)) = - return (ApplicativeArgOne pat exp, emptyFVs) - stmtTreeArg ctxt tail_fvs tree = do - let stmts = flattenStmtTree tree - pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) - `intersectNameSet` tail_fvs - pvars = nameSetElemsStable pvarset - -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] - pat = mkBigLHsVarPatTup pvars - tup = mkBigLHsVarTup pvars - (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset - (mb_ret, fvs1) <- - if | L _ ApplicativeStmt{} <- last stmts' -> - return (unLoc tup, emptyNameSet) - | otherwise -> do - (ret,fvs) <- lookupStmtNamePoly ctxt returnMName - return (HsApp (noLoc ret) tup, fvs) - return ( ApplicativeArgMany stmts' mb_ret pat - , fvs1 `plusFV` fvs2) - - --- | Divide a sequence of statements into segments, where no segment --- depends on any variables defined by a statement in another segment. -segments - :: [(ExprLStmt Name, FreeVars)] - -> [[(ExprLStmt Name, FreeVars)]] -segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) - where - allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) - - -- We would rather not have a segment that just has LetStmts in - -- it, so combine those with an adjacent segment where possible. - merge [] = [] - merge (seg : segs) - = case rest of - [] -> [(seg,all_lets)] - ((s,s_lets):ss) | all_lets || s_lets - -> (seg ++ s, all_lets && s_lets) : ss - _otherwise -> (seg,all_lets) : rest - where - rest = merge segs - all_lets = all (isLetStmt . fst) seg - - -- walk splits the statement sequence into segments, traversing - -- the sequence from the back to the front, and keeping track of - -- the set of free variables of the current segment. Whenever - -- this set of free variables is empty, we have a complete segment. - walk :: [(ExprLStmt Name, FreeVars)] -> [[(ExprLStmt Name, FreeVars)]] - walk [] = [] - walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest - where (seg,rest) = chunter fvs' stmts - (_, fvs') = stmtRefs stmt fvs - - chunter _ [] = ([], []) - chunter vars ((stmt,fvs) : rest) - | not (isEmptyNameSet vars) - || isStrictPatternBind stmt - -- See Note [ApplicativeDo and strict patterns] - = ((stmt,fvs) : chunk, rest') - where (chunk,rest') = chunter vars' rest - (pvars, evars) = stmtRefs stmt fvs - vars' = (vars `minusNameSet` pvars) `unionNameSet` evars - chunter _ rest = ([], rest) - - stmtRefs stmt fvs - | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars) - | otherwise = (pvars, fvs') - where fvs' = fvs `intersectNameSet` allvars - pvars = mkNameSet (collectStmtBinders (unLoc stmt)) - - isStrictPatternBind :: ExprLStmt Name -> Bool - isStrictPatternBind (L _ (BindStmt pat _ _ _ _)) = isStrictPattern pat - isStrictPatternBind _ = False - -{- -Note [ApplicativeDo and strict patterns] - -A strict pattern match is really a dependency. For example, - -do - (x,y) <- A - z <- B - return C - -The pattern (_,_) must be matched strictly before we do B. If we -allowed this to be transformed into - - (\(x,y) -> \z -> C) <$> A <*> B - -then it could be lazier than the standard desuraging using >>=. See #13875 -for more examples. - -Thus, whenever we have a strict pattern match, we treat it as a -dependency between that statement and the following one. The -dependency prevents those two statements from being performed "in -parallel" in an ApplicativeStmt, but doesn't otherwise affect what we -can do with the rest of the statements in the same "do" expression. --} - -isStrictPattern :: LPat id -> Bool -isStrictPattern (L _ pat) = - case pat of - WildPat{} -> False - VarPat{} -> False - LazyPat{} -> False - AsPat _ p -> isStrictPattern p - ParPat p -> isStrictPattern p - ViewPat _ p _ -> isStrictPattern p - SigPatIn p _ -> isStrictPattern p - SigPatOut p _ -> isStrictPattern p - BangPat{} -> True - TuplePat{} -> True - SumPat{} -> True - PArrPat{} -> True - ConPatIn{} -> True - ConPatOut{} -> True - LitPat{} -> True - NPat{} -> True - NPlusKPat{} -> True - SplicePat{} -> True - _otherwise -> panic "isStrictPattern" - -isLetStmt :: LStmt a b -> Bool -isLetStmt (L _ LetStmt{}) = True -isLetStmt _ = False - --- | Find a "good" place to insert a bind in an indivisible segment. --- This is the only place where we use heuristics. The current --- heuristic is to peel off the first group of independent statements --- and put the bind after those. -splitSegment - :: [(ExprLStmt Name, FreeVars)] - -> ( [(ExprLStmt Name, FreeVars)] - , [(ExprLStmt Name, FreeVars)] ) -splitSegment [one,two] = ([one],[two]) - -- there is no choice when there are only two statements; this just saves - -- some work in a common case. -splitSegment stmts - | Just (lets,binds,rest) <- slurpIndependentStmts stmts - = if not (null lets) - then (lets, binds++rest) - else (lets++binds, rest) - | otherwise - = case stmts of - (x:xs) -> ([x],xs) - _other -> (stmts,[]) - -slurpIndependentStmts - :: [(LStmt Name (Located (body Name)), FreeVars)] - -> Maybe ( [(LStmt Name (Located (body Name)), FreeVars)] -- LetStmts - , [(LStmt Name (Located (body Name)), FreeVars)] -- BindStmts - , [(LStmt Name (Located (body Name)), FreeVars)] ) -slurpIndependentStmts stmts = go [] [] emptyNameSet stmts - where - -- If we encounter a BindStmt that doesn't depend on a previous BindStmt - -- in this group, then add it to the group. We have to be careful about - -- strict patterns though; splitSegments expects that if we return Just - -- then we have actually done some splitting. Otherwise it will go into - -- an infinite loop (#14163). - go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest) - | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat) - = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep) - bndrs' rest - where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) - -- If we encounter a LetStmt that doesn't depend on a BindStmt in this - -- group, then move it to the beginning, so that it doesn't interfere with - -- grouping more BindStmts. - -- TODO: perhaps we shouldn't do this if there are any strict bindings, - -- because we might be moving evaluation earlier. - go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest) - | isEmptyNameSet (bndrs `intersectNameSet` fvs) - = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest - go _ [] _ _ = Nothing - go _ [_] _ _ = Nothing - go lets indep _ stmts = Just (reverse lets, reverse indep, stmts) - --- | Build an ApplicativeStmt, and strip the "return" from the tail --- if necessary. --- --- For example, if we start with --- do x <- E1; y <- E2; return (f x y) --- then we get --- do (E1[x] | E2[y]); f x y --- --- the LastStmt in this case has the return removed, but we set the --- flag on the LastStmt to indicate this, so that we can print out the --- original statement correctly in error messages. It is easier to do --- it this way rather than try to ignore the return later in both the --- typechecker and the desugarer (I tried it that way first!). -mkApplicativeStmt - :: HsStmtContext Name - -> [ApplicativeArg Name Name] -- ^ The args - -> Bool -- ^ True <=> need a join - -> [ExprLStmt Name] -- ^ The body statements - -> RnM ([ExprLStmt Name], FreeVars) -mkApplicativeStmt ctxt args need_join body_stmts - = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName - ; (ap_op, fvs2) <- lookupStmtName ctxt apAName - ; (mb_join, fvs3) <- - if need_join then - do { (join_op, fvs) <- lookupStmtName ctxt joinMName - ; return (Just join_op, fvs) } - else - return (Nothing, emptyNameSet) - ; let applicative_stmt = noLoc $ ApplicativeStmt - (zip (fmap_op : repeat ap_op) args) - mb_join - placeHolderType - ; return ( applicative_stmt : body_stmts - , fvs1 `plusFV` fvs2 `plusFV` fvs3) } - --- | Given the statements following an ApplicativeStmt, determine whether --- we need a @join@ or not, and remove the @return@ if necessary. -needJoin :: MonadNames - -> [ExprLStmt Name] - -> (Bool, [ExprLStmt Name]) -needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg -needJoin monad_names [L loc (LastStmt e _ t)] - | Just arg <- isReturnApp monad_names e = - (False, [L loc (LastStmt arg True t)]) -needJoin _monad_names stmts = (True, stmts) - --- | @Just e@, if the expression is @return e@ or @return $ e@, --- otherwise @Nothing@ -isReturnApp :: MonadNames - -> LHsExpr Name - -> Maybe (LHsExpr Name) -isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr -isReturnApp monad_names (L _ e) = case e of - OpApp l op _ r | is_return l, is_dollar op -> Just r - HsApp f arg | is_return f -> Just arg - _otherwise -> Nothing - where - is_var f (L _ (HsPar e)) = is_var f e - is_var f (L _ (HsAppType e _)) = is_var f e - is_var f (L _ (HsVar (L _ r))) = f r - -- TODO: I don't know how to get this right for rebindable syntax - is_var _ _ = False - - is_return = is_var (\n -> n == return_name monad_names - || n == pure_name monad_names) - is_dollar = is_var (`hasKey` dollarIdKey) - -{- -************************************************************************ -* * -\subsubsection{Errors} -* * -************************************************************************ --} - -checkEmptyStmts :: HsStmtContext Name -> RnM () --- We've seen an empty sequence of Stmts... is that ok? -checkEmptyStmts ctxt - = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) - -okEmpty :: HsStmtContext a -> Bool -okEmpty (PatGuard {}) = True -okEmpty _ = False - -emptyErr :: HsStmtContext Name -> SDoc -emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension" -emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'" -emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt - ----------------------- -checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name - -> LStmt RdrName (Located (body RdrName)) - -> RnM (LStmt RdrName (Located (body RdrName))) -checkLastStmt ctxt lstmt@(L loc stmt) - = case ctxt of - ListComp -> check_comp - MonadComp -> check_comp - PArrComp -> check_comp - ArrowExpr -> check_do - DoExpr -> check_do - MDoExpr -> check_do - _ -> check_other - where - check_do -- Expect BodyStmt, and change it to LastStmt - = case stmt of - BodyStmt e _ _ _ -> return (L loc (mkLastStmt e)) - LastStmt {} -> return lstmt -- "Deriving" clauses may generate a - -- LastStmt directly (unlike the parser) - _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } - last_error = (text "The last statement in" <+> pprAStmtContext ctxt - <+> text "must be an expression") - - check_comp -- Expect LastStmt; this should be enforced by the parser! - = case stmt of - LastStmt {} -> return lstmt - _ -> pprPanic "checkLastStmt" (ppr lstmt) - - check_other -- Behave just as if this wasn't the last stmt - = do { checkStmt ctxt lstmt; return lstmt } - --- Checking when a particular Stmt is ok -checkStmt :: HsStmtContext Name - -> LStmt RdrName (Located (body RdrName)) - -> RnM () -checkStmt ctxt (L _ stmt) - = do { dflags <- getDynFlags - ; case okStmt dflags ctxt stmt of - IsValid -> return () - NotValid extra -> addErr (msg $$ extra) } - where - msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement") - , text "in" <+> pprAStmtContext ctxt ] - -pprStmtCat :: Stmt a body -> SDoc -pprStmtCat (TransStmt {}) = text "transform" -pprStmtCat (LastStmt {}) = text "return expression" -pprStmtCat (BodyStmt {}) = text "body" -pprStmtCat (BindStmt {}) = text "binding" -pprStmtCat (LetStmt {}) = text "let" -pprStmtCat (RecStmt {}) = text "rec" -pprStmtCat (ParStmt {}) = text "parallel" -pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt" - ------------- -emptyInvalid :: Validity -- Payload is the empty document -emptyInvalid = NotValid Outputable.empty - -okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt - :: DynFlags -> HsStmtContext Name - -> Stmt RdrName (Located (body RdrName)) -> Validity --- Return Nothing if OK, (Just extra) if not ok --- The "extra" is an SDoc that is appended to an generic error message - -okStmt dflags ctxt stmt - = case ctxt of - PatGuard {} -> okPatGuardStmt stmt - ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt - DoExpr -> okDoStmt dflags ctxt stmt - MDoExpr -> okDoStmt dflags ctxt stmt - ArrowExpr -> okDoStmt dflags ctxt stmt - GhciStmtCtxt -> okDoStmt dflags ctxt stmt - ListComp -> okCompStmt dflags ctxt stmt - MonadComp -> okCompStmt dflags ctxt stmt - PArrComp -> okPArrStmt dflags ctxt stmt - TransStmtCtxt ctxt -> okStmt dflags ctxt stmt - -------------- -okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity -okPatGuardStmt stmt - = case stmt of - BodyStmt {} -> IsValid - BindStmt {} -> IsValid - LetStmt {} -> IsValid - _ -> emptyInvalid - -------------- -okParStmt dflags ctxt stmt - = case stmt of - LetStmt (L _ (HsIPBinds {})) -> emptyInvalid - _ -> okStmt dflags ctxt stmt - ----------------- -okDoStmt dflags ctxt stmt - = case stmt of - RecStmt {} - | LangExt.RecursiveDo `xopt` dflags -> IsValid - | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec' - | otherwise -> NotValid (text "Use RecursiveDo") - BindStmt {} -> IsValid - LetStmt {} -> IsValid - BodyStmt {} -> IsValid - _ -> emptyInvalid - ----------------- -okCompStmt dflags _ stmt - = case stmt of - BindStmt {} -> IsValid - LetStmt {} -> IsValid - BodyStmt {} -> IsValid - ParStmt {} - | LangExt.ParallelListComp `xopt` dflags -> IsValid - | otherwise -> NotValid (text "Use ParallelListComp") - TransStmt {} - | LangExt.TransformListComp `xopt` dflags -> IsValid - | otherwise -> NotValid (text "Use TransformListComp") - RecStmt {} -> emptyInvalid - LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) - ApplicativeStmt {} -> emptyInvalid - ----------------- -okPArrStmt dflags _ stmt - = case stmt of - BindStmt {} -> IsValid - LetStmt {} -> IsValid - BodyStmt {} -> IsValid - ParStmt {} - | LangExt.ParallelListComp `xopt` dflags -> IsValid - | otherwise -> NotValid (text "Use ParallelListComp") - TransStmt {} -> emptyInvalid - RecStmt {} -> emptyInvalid - LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) - ApplicativeStmt {} -> emptyInvalid - ---------- -checkTupleSection :: [LHsTupArg RdrName] -> RnM () -checkTupleSection args - = do { tuple_section <- xoptM LangExt.TupleSections - ; checkErr (all tupArgPresent args || tuple_section) msg } - where - msg = text "Illegal tuple section: use TupleSections" - ---------- -sectionErr :: HsExpr RdrName -> SDoc -sectionErr expr - = hang (text "A section must be enclosed in parentheses") - 2 (text "thus:" <+> (parens (ppr expr))) - -patSynErr :: HsExpr RdrName -> SDoc -> RnM (HsExpr Name, FreeVars) -patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:", - nest 4 (ppr e)] $$ - explanation) - ; return (EWildPat, emptyFVs) } - -badIpBinds :: Outputable a => SDoc -> a -> SDoc -badIpBinds what binds - = hang (text "Implicit-parameter bindings illegal in" <+> what) - 2 (ppr binds) diff --git a/rename/RnExpr.hs-boot b/rename/RnExpr.hs-boot deleted file mode 100644 --- a/rename/RnExpr.hs-boot +++ /dev/null @@ -1,18 +0,0 @@ -module RnExpr where -import HsSyn -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) -import TcRnTypes -import SrcLoc ( Located ) -import Outputable ( Outputable ) - -rnLExpr :: LHsExpr RdrName - -> RnM (LHsExpr Name, FreeVars) - -rnStmts :: --forall thing body. - Outputable (body RdrName) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> [LStmt RdrName (Located (body RdrName))] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) diff --git a/rename/RnHsDoc.hs b/rename/RnHsDoc.hs deleted file mode 100644 --- a/rename/RnHsDoc.hs +++ /dev/null @@ -1,23 +0,0 @@ - -module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where - -import TcRnTypes -import HsSyn -import SrcLoc - - -rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString) -rnMbLHsDoc mb_doc = case mb_doc of - Just doc -> do - doc' <- rnLHsDoc doc - return (Just doc') - Nothing -> return Nothing - -rnLHsDoc :: LHsDocString -> RnM LHsDocString -rnLHsDoc (L pos doc) = do - doc' <- rnHsDoc doc - return (L pos doc') - -rnHsDoc :: HsDocString -> RnM HsDocString -rnHsDoc (HsDocString s) = return (HsDocString s) - diff --git a/rename/RnNames.hs b/rename/RnNames.hs deleted file mode 100644 --- a/rename/RnNames.hs +++ /dev/null @@ -1,1627 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnNames]{Extracting imported and top-level names in scope} --} - -{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-} - -module RnNames ( - rnImports, getLocalNonValBinders, newRecordSelector, - extendGlobalRdrEnvRn, - gresFromAvails, - calculateAvails, - reportUnusedNames, - checkConName, - mkChildEnv, - findChildren, - dodgyMsg - ) where - -#include "HsVersions.h" - -import DynFlags -import HsSyn -import TcEnv -import RnEnv -import LoadIface ( loadSrcInterface ) -import TcRnMonad -import PrelNames -import Module -import Name -import NameEnv -import NameSet -import Avail -import FieldLabel -import HscTypes -import RdrName -import RdrHsSyn ( setRdrNameSpace ) -import Outputable -import Maybes -import SrcLoc -import BasicTypes ( TopLevelFlag(..), StringLiteral(..) ) -import Util -import FastString -import FastStringEnv -import Id -import Type -import PatSyn -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Either ( partitionEithers, isRight, rights ) --- import qualified Data.Foldable as Foldable -import Data.Map ( Map ) -import qualified Data.Map as Map -import Data.Ord ( comparing ) -import Data.List ( partition, (\\), find, sortBy ) -import qualified Data.Set as S --- import qualified Data.Set as Set -import System.FilePath (()) - -import System.IO - -{- -************************************************************************ -* * -\subsection{rnImports} -* * -************************************************************************ - -Note [Tracking Trust Transitively] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we import a package as well as checking that the direct imports are safe -according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check] -we must also check that these rules hold transitively for all dependent modules -and packages. Doing this without caching any trust information would be very -slow as we would need to touch all packages and interface files a module depends -on. To avoid this we make use of the property that if a modules Safe Haskell -mode changes, this triggers a recompilation from that module in the dependcy -graph. So we can just worry mostly about direct imports. - -There is one trust property that can change for a package though without -recompliation being triggered: package trust. So we must check that all -packages a module tranitively depends on to be trusted are still trusted when -we are compiling this module (as due to recompilation avoidance some modules -below may not be considered trusted any more without recompilation being -triggered). - -We handle this by augmenting the existing transitive list of packages a module M -depends on with a bool for each package that says if it must be trusted when the -module M is being checked for trust. This list of trust required packages for a -single import is gathered in the rnImportDecl function and stored in an -ImportAvails data structure. The union of these trust required packages for all -imports is done by the rnImports function using the combine function which calls -the plusImportAvails function that is a union operation for the ImportAvails -type. This gives us in an ImportAvails structure all packages required to be -trusted for the module we are currently compiling. Checking that these packages -are still trusted (and that direct imports are trusted) is done in -HscMain.checkSafeImports. - -See the note below, [Trust Own Package] for a corner case in this method and -how its handled. - - -Note [Trust Own Package] -~~~~~~~~~~~~~~~~~~~~~~~~ -There is a corner case of package trust checking that the usual transitive check -doesn't cover. (For how the usual check operates see the Note [Tracking Trust -Transitively] below). The case is when you import a -XSafe module M and M -imports a -XTrustworthy module N. If N resides in a different package than M, -then the usual check works as M will record a package dependency on N's package -and mark it as required to be trusted. If N resides in the same package as M -though, then importing M should require its own package be trusted due to N -(since M is -XSafe so doesn't create this requirement by itself). The usual -check fails as a module doesn't record a package dependency of its own package. -So instead we now have a bool field in a modules interface file that simply -states if the module requires its own package to be trusted. This field avoids -us having to load all interface files that the module depends on to see if one -is trustworthy. - - -Note [Trust Transitive Property] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -So there is an interesting design question in regards to transitive trust -checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch -of modules and packages, some packages it requires to be trusted as its using --XTrustworthy modules from them. Now if I have a module A that doesn't use safe -haskell at all and simply imports B, should A inherit all the the trust -requirements from B? Should A now also require that a package p is trusted since -B required it? - -We currently say no but saying yes also makes sense. The difference is, if a -module M that doesn't use Safe Haskell imports a module N that does, should all -the trusted package requirements be dropped since M didn't declare that it cares -about Safe Haskell (so -XSafe is more strongly associated with the module doing -the importing) or should it be done still since the author of the module N that -uses Safe Haskell said they cared (so -XSafe is more strongly associated with -the module that was compiled that used it). - -Going with yes is a simpler semantics we think and harder for the user to stuff -up but it does mean that Safe Haskell will affect users who don't care about -Safe Haskell as they might grab a package from Cabal which uses safe haskell (say -network) and that packages imports -XTrustworthy modules from another package -(say bytestring), so requires that package is trusted. The user may now get -compilation errors in code that doesn't do anything with Safe Haskell simply -because they are using the network package. They will have to call 'ghc-pkg -trust network' to get everything working. Due to this invasive nature of going -with yes we have gone with no for now. --} - --- | Process Import Decls. See 'rnImportDecl' for a description of what --- the return types represent. --- Note: Do the non SOURCE ones first, so that we get a helpful warning --- for SOURCE ones that are unnecessary -rnImports :: [LImportDecl RdrName] - -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) -rnImports imports = do - tcg_env <- getGblEnv - -- NB: want an identity module here, because it's OK for a signature - -- module to import from its implementor - let this_mod = tcg_mod tcg_env - let (source, ordinary) = partition is_source_import imports - is_source_import d = ideclSource (unLoc d) - stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary - stuff2 <- mapAndReportM (rnImportDecl this_mod) source - -- Safe Haskell: See Note [Tracking Trust Transitively] - let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2) - return (decls, rdr_env, imp_avails, hpc_usage) - - where - combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] - -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) - combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False) - - plus (decl, gbl_env1, imp_avails1,hpc_usage1) - (decls, gbl_env2, imp_avails2,hpc_usage2) - = ( decl:decls, - gbl_env1 `plusGlobalRdrEnv` gbl_env2, - imp_avails1 `plusImportAvails` imp_avails2, - hpc_usage1 || hpc_usage2 ) - --- | Given a located import declaration @decl@ from @this_mod@, --- calculate the following pieces of information: --- --- 1. An updated 'LImportDecl', where all unresolved 'RdrName' in --- the entity lists have been resolved into 'Name's, --- --- 2. A 'GlobalRdrEnv' representing the new identifiers that were --- brought into scope (taking into account module qualification --- and hiding), --- --- 3. 'ImportAvails' summarizing the identifiers that were imported --- by this declaration, and --- --- 4. A boolean 'AnyHpcUsage' which is true if the imported module --- used HPC. -rnImportDecl :: Module -> LImportDecl RdrName - -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage) -rnImportDecl this_mod - (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg - , ideclSource = want_boot, ideclSafe = mod_safe - , ideclQualified = qual_only, ideclImplicit = implicit - , ideclAs = as_mod, ideclHiding = imp_details })) - = setSrcSpan loc $ do - - when (isJust mb_pkg) $ do - pkg_imports <- xoptM LangExt.PackageImports - when (not pkg_imports) $ addErr packageImportErr - - -- If there's an error in loadInterface, (e.g. interface - -- file not found) we get lots of spurious errors from 'filterImports' - let imp_mod_name = unLoc loc_imp_mod_name - doc = ppr imp_mod_name <+> text "is directly imported" - - -- Check for self-import, which confuses the typechecker (Trac #9032) - -- ghc --make rejects self-import cycles already, but batch-mode may not - -- at least not until TcIface.tcHiBootIface, which is too late to avoid - -- typechecker crashes. (Indirect self imports are not caught until - -- TcIface, see #10337 tracking how to make this error better.) - -- - -- Originally, we also allowed 'import {-# SOURCE #-} M', but this - -- caused bug #10182: in one-shot mode, we should never load an hs-boot - -- file for the module we are compiling into the EPS. In principle, - -- it should be possible to support this mode of use, but we would have to - -- extend Provenance to support a local definition in a qualified location. - -- For now, we don't support it, but see #10336 - when (imp_mod_name == moduleName this_mod && - (case mb_pkg of -- If we have import "" M, then we should - -- check that "" is "this" (which is magic) - -- or the name of this_mod's package. Yurgh! - -- c.f. GHC.findModule, and Trac #9997 - Nothing -> True - Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" || - fsToUnitId pkg_fs == moduleUnitId this_mod)) - (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name)) - - -- Check for a missing import list (Opt_WarnMissingImportList also - -- checks for T(..) items but that is done in checkDodgyImport below) - case imp_details of - Just (False, _) -> return () -- Explicit import list - _ | implicit -> return () -- Do not bleat for implicit imports - | qual_only -> return () - | otherwise -> whenWOptM Opt_WarnMissingImportList $ - addWarn (Reason Opt_WarnMissingImportList) - (missingImportListWarn imp_mod_name) - - iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg) - - -- Compiler sanity check: if the import didn't say - -- {-# SOURCE #-} we should not get a hi-boot file - WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do - - -- Issue a user warning for a redundant {- SOURCE -} import - -- NB that we arrange to read all the ordinary imports before - -- any of the {- SOURCE -} imports. - -- - -- in --make and GHCi, the compilation manager checks for this, - -- and indeed we shouldn't do it here because the existence of - -- the non-boot module depends on the compilation order, which - -- is not deterministic. The hs-boot test can show this up. - dflags <- getDynFlags - warnIf NoReason - (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) - (warnRedundantSourceImport imp_mod_name) - when (mod_safe && not (safeImportsOn dflags)) $ - addErr (text "safe import can't be used as Safe Haskell isn't on!" - $+$ ptext (sLit $ "please enable Safe Haskell through either " - ++ "Safe, Trustworthy or Unsafe")) - - let - qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name - imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, - is_dloc = loc, is_as = qual_mod_name } - - -- filter the imports according to the import declaration - (new_imp_details, gres) <- filterImports iface imp_spec imp_details - - -- for certain error messages, we’d like to know what could be imported - -- here, if everything were imported - potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing - - let gbl_env = mkGlobalRdrEnv gres - - is_hiding | Just (True,_) <- imp_details = True - | otherwise = False - - -- should the import be safe? - mod_safe' = mod_safe - || (not implicit && safeDirectImpsReq dflags) - || (implicit && safeImplicitImpsReq dflags) - - let imv = ImportedModsVal - { imv_name = qual_mod_name - , imv_span = loc - , imv_is_safe = mod_safe' - , imv_is_hiding = is_hiding - , imv_all_exports = potential_gres - , imv_qualified = qual_only - } - imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv) - - -- Complain if we import a deprecated module - whenWOptM Opt_WarnWarningsDeprecations ( - case (mi_warns iface) of - WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations) - (moduleWarn imp_mod_name txt) - _ -> return () - ) - - let new_imp_decl = L loc (decl { ideclSafe = mod_safe' - , ideclHiding = new_imp_details }) - - return (new_imp_decl, gbl_env, imports, mi_hpc iface) - --- | Calculate the 'ImportAvails' induced by an import of a particular --- interface, but without 'imp_mods'. -calculateAvails :: DynFlags - -> ModIface - -> IsSafeImport - -> IsBootInterface - -> ImportedBy - -> ImportAvails -calculateAvails dflags iface mod_safe' want_boot imported_by = - let imp_mod = mi_module iface - imp_sem_mod= mi_semantic_module iface - orph_iface = mi_orphan iface - has_finsts = mi_finsts iface - deps = mi_deps iface - trust = getSafeMode $ mi_trust iface - trust_pkg = mi_trust_pkg iface - - -- If the module exports anything defined in this module, just - -- ignore it. Reason: otherwise it looks as if there are two - -- local definition sites for the thing, and an error gets - -- reported. Easiest thing is just to filter them out up - -- front. This situation only arises if a module imports - -- itself, or another module that imported it. (Necessarily, - -- this invoves a loop.) - -- - -- We do this *after* filterImports, so that if you say - -- module A where - -- import B( AType ) - -- type AType = ... - -- - -- module B( AType ) where - -- import {-# SOURCE #-} A( AType ) - -- - -- then you won't get a 'B does not export AType' message. - - - -- Compute new transitive dependencies - -- - -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module - -- itself, but we DO need to include this module in 'imp_orphs' and - -- 'imp_finsts' if it defines an orphan or instance family; thus the - -- orph_iface/has_iface tests. - - orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) ) - imp_sem_mod : dep_orphs deps - | otherwise = dep_orphs deps - - finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) ) - imp_sem_mod : dep_finsts deps - | otherwise = dep_finsts deps - - pkg = moduleUnitId (mi_module iface) - ipkg = toInstalledUnitId pkg - - -- Does this import mean we now require our own pkg - -- to be trusted? See Note [Trust Own Package] - ptrust = trust == Sf_Trustworthy || trust_pkg - - (dependent_mods, dependent_pkgs, pkg_trust_req) - | pkg == thisPackage dflags = - -- Imported module is from the home package - -- Take its dependent modules and add imp_mod itself - -- Take its dependent packages unchanged - -- - -- NB: (dep_mods deps) might include a hi-boot file - -- for the module being compiled, CM. Do *not* filter - -- this out (as we used to), because when we've - -- finished dealing with the direct imports we want to - -- know if any of them depended on CM.hi-boot, in - -- which case we should do the hi-boot consistency - -- check. See LoadIface.loadHiBootInterface - ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust) - - | otherwise = - -- Imported module is from another package - -- Dump the dependent modules - -- Add the package imp_mod comes from to the dependent packages - ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps)) - , ppr ipkg <+> ppr (dep_pkgs deps) ) - ([], (ipkg, False) : dep_pkgs deps, False) - - in ImportAvails { - imp_mods = unitModuleEnv (mi_module iface) [imported_by], - imp_orphs = orphans, - imp_finsts = finsts, - imp_dep_mods = mkModDeps dependent_mods, - imp_dep_pkgs = S.fromList . map fst $ dependent_pkgs, - -- Add in the imported modules trusted package - -- requirements. ONLY do this though if we import the - -- module as a safe import. - -- See Note [Tracking Trust Transitively] - -- and Note [Trust Transitive Property] - imp_trust_pkgs = if mod_safe' - then S.fromList . map fst $ filter snd dependent_pkgs - else S.empty, - -- Do we require our own pkg to be trusted? - -- See Note [Trust Own Package] - imp_trust_own_pkg = pkg_trust_req - } - - -warnRedundantSourceImport :: ModuleName -> SDoc -warnRedundantSourceImport mod_name - = text "Unnecessary {-# SOURCE #-} in the import of module" - <+> quotes (ppr mod_name) - -{- -************************************************************************ -* * -\subsection{importsFromLocalDecls} -* * -************************************************************************ - -From the top-level declarations of this module produce - * the lexical environment - * the ImportAvails -created by its bindings. - -Note [Top-level Names in Template Haskell decl quotes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also: Note [Interactively-bound Ids in GHCi] in HscTypes - Note [Looking up Exact RdrNames] in RnEnv - -Consider a Template Haskell declaration quotation like this: - module M where - f x = h [d| f = 3 |] -When renaming the declarations inside [d| ...|], we treat the -top level binders specially in two ways - -1. We give them an Internal Name, not (as usual) an External one. - This is done by RnEnv.newTopSrcBinder. - -2. We make them *shadow* the outer bindings. - See Note [GlobalRdrEnv shadowing] - -3. We find out whether we are inside a [d| ... |] by testing the TH - stage. This is a slight hack, because the stage field was really - meant for the type checker, and here we are not interested in the - fields of Brack, hence the error thunks in thRnBrack. --} - -extendGlobalRdrEnvRn :: [AvailInfo] - -> MiniFixityEnv - -> RnM (TcGblEnv, TcLclEnv) --- Updates both the GlobalRdrEnv and the FixityEnv --- We return a new TcLclEnv only because we might have to --- delete some bindings from it; --- see Note [Top-level Names in Template Haskell decl quotes] - -extendGlobalRdrEnvRn avails new_fixities - = do { (gbl_env, lcl_env) <- getEnvs - ; stage <- getStage - ; isGHCi <- getIsGHCi - ; let rdr_env = tcg_rdr_env gbl_env - fix_env = tcg_fix_env gbl_env - th_bndrs = tcl_th_bndrs lcl_env - th_lvl = thLevel stage - - -- Delete new_occs from global and local envs - -- If we are in a TemplateHaskell decl bracket, - -- we are going to shadow them - -- See Note [GlobalRdrEnv shadowing] - inBracket = isBrackStage stage - - lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs } - -- See Note [GlobalRdrEnv shadowing] - - lcl_env2 | inBracket = lcl_env_TH - | otherwise = lcl_env - - -- Deal with shadowing: see Note [GlobalRdrEnv shadowing] - want_shadowing = isGHCi || inBracket - rdr_env1 | want_shadowing = shadowNames rdr_env new_names - | otherwise = rdr_env - - lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs - [ (n, (TopLevel, th_lvl)) - | n <- new_names ] } - - ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres - - ; let fix_env' = foldl extend_fix_env fix_env new_gres - gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' } - - ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2) - ; return (gbl_env', lcl_env3) } - where - new_names = concatMap availNames avails - new_occs = map nameOccName new_names - - -- If there is a fixity decl for the gre, add it to the fixity env - extend_fix_env fix_env gre - | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ) - = extendNameEnv fix_env name (FixItem occ fi) - | otherwise - = fix_env - where - name = gre_name gre - occ = greOccName gre - - new_gres :: [GlobalRdrElt] -- New LocalDef GREs, derived from avails - new_gres = concatMap localGREsFromAvail avails - - add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv - -- Extend the GlobalRdrEnv with a LocalDef GRE - -- If there is already a LocalDef GRE with the same OccName, - -- report an error and discard the new GRE - -- This establishes INVARIANT 1 of GlobalRdrEnvs - add_gre env gre - | not (null dups) -- Same OccName defined twice - = do { addDupDeclErr (gre : dups); return env } - - | otherwise - = return (extendGlobalRdrEnv env gre) - where - name = gre_name gre - occ = nameOccName name - dups = filter isLocalGRE (lookupGlobalRdrEnv env occ) - - -{- ********************************************************************* -* * - getLocalDeclBindersd@ returns the names for an HsDecl - It's used for source code. - - *** See Note [The Naming story] in HsDecls **** -* * -********************************************************************* -} - -getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName - -> RnM ((TcGblEnv, TcLclEnv), NameSet) --- Get all the top-level binders bound the group *except* --- for value bindings, which are treated separately --- Specifically we return AvailInfo for --- * type decls (incl constructors and record selectors) --- * class decls (including class ops) --- * associated types --- * foreign imports --- * value signatures (in hs-boot files only) - -getLocalNonValBinders fixity_env - (HsGroup { hs_valds = binds, - hs_tyclds = tycl_decls, - hs_fords = foreign_decls }) - = do { -- Process all type/class decls *except* family instances - ; let inst_decls = tycl_decls >>= group_instds - ; overload_ok <- xoptM LangExt.DuplicateRecordFields - ; (tc_avails, tc_fldss) - <- fmap unzip $ mapM (new_tc overload_ok) - (tyClGroupTyClDecls tycl_decls) - ; traceRn "getLocalNonValBinders 1" (ppr tc_avails) - ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env - ; setEnvs envs $ do { - -- Bring these things into scope first - -- See Note [Looking up family names in family instances] - - -- Process all family instances - -- to bring new data constructors into scope - ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok) - inst_decls - - -- Finish off with value binders: - -- foreign decls and pattern synonyms for an ordinary module - -- type sigs in case of a hs-boot file only - ; is_boot <- tcIsHsBootOrSig - ; let val_bndrs | is_boot = hs_boot_sig_bndrs - | otherwise = for_hs_bndrs - ; val_avails <- mapM new_simple val_bndrs - - ; let avails = concat nti_availss ++ val_avails - new_bndrs = availsToNameSetWithSelectors avails `unionNameSet` - availsToNameSetWithSelectors tc_avails - flds = concat nti_fldss ++ concat tc_fldss - ; traceRn "getLocalNonValBinders 2" (ppr avails) - ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env - - -- Extend tcg_field_env with new fields (this used to be the - -- work of extendRecordFieldEnv) - ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds - envs = (tcg_env { tcg_field_env = field_env }, tcl_env) - - ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) - ; return (envs, new_bndrs) } } - where - ValBindsIn _val_binds val_sigs = binds - - for_hs_bndrs :: [Located RdrName] - for_hs_bndrs = hsForeignDeclsBinders foreign_decls - - -- In a hs-boot file, the value binders come from the - -- *signatures*, and there should be no foreign binders - hs_boot_sig_bndrs = [ L decl_loc (unLoc n) - | L decl_loc (TypeSig ns _) <- val_sigs, n <- ns] - - -- the SrcSpan attached to the input should be the span of the - -- declaration, not just the name - new_simple :: Located RdrName -> RnM AvailInfo - new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name - ; return (avail nm) } - - new_tc :: Bool -> LTyClDecl RdrName - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_tc overload_ok tc_decl -- NOT for type/data instances - = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl - ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs - ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds - ; let fld_env = case unLoc tc_decl of - DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' - _ -> [] - ; return (AvailTC main_name names flds', fld_env) } - - - -- Calculate the mapping from constructor names to fields, which - -- will go in tcg_field_env. It's convenient to do this here where - -- we are working with a single datatype definition. - mk_fld_env :: HsDataDefn RdrName -> [Name] -> [FieldLabel] -> [(Name, [FieldLabel])] - mk_fld_env d names flds = concatMap find_con_flds (dd_cons d) - where - find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr - , con_details = RecCon cdflds })) - = [( find_con_name rdr - , concatMap find_con_decl_flds (unLoc cdflds) )] - find_con_flds (L _ (ConDeclGADT - { con_names = rdrs - , con_type = (HsIB { hsib_body = res_ty})})) - = map (\ (L _ rdr) -> ( find_con_name rdr - , concatMap find_con_decl_flds cdflds)) - rdrs - where - (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty - cdflds = case tau of - L _ (HsFunTy - (L _ (HsAppsTy - [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds - L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds - _ -> [] - find_con_flds _ = [] - - find_con_name rdr - = expectJust "getLocalNonValBinders/find_con_name" $ - find (\ n -> nameOccName n == rdrNameOcc rdr) names - find_con_decl_flds (L _ x) - = map find_con_decl_fld (cd_fld_names x) - find_con_decl_fld (L _ (FieldOcc (L _ rdr) _)) - = expectJust "getLocalNonValBinders/find_con_decl_fld" $ - find (\ fl -> flLabel fl == lbl) flds - where lbl = occNameFS (rdrNameOcc rdr) - - new_assoc :: Bool -> LInstDecl RdrName - -> RnM ([AvailInfo], [(Name, [FieldLabel])]) - new_assoc _ (L _ (TyFamInstD {})) = return ([], []) - -- type instances don't bind new names - - new_assoc overload_ok (L _ (DataFamInstD d)) - = do { (avail, flds) <- new_di overload_ok Nothing d - ; return ([avail], flds) } - new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty - , cid_datafam_insts = adts }))) - | Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty - = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr - ; (avails, fldss) - <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts - ; return (avails, concat fldss) } - | otherwise - = return ([], []) -- Do not crash on ill-formed instances - -- Eg instance !Show Int Trac #3811c - - new_di :: Bool -> Maybe Name -> DataFamInstDecl RdrName - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_di overload_ok mb_cls ti_decl - = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl) - ; let (bndrs, flds) = hsDataFamInstBinders ti_decl - ; sub_names <- mapM newTopSrcBinder bndrs - ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds - ; let avail = AvailTC (unLoc main_name) sub_names flds' - -- main_name is not bound here! - fld_env = mk_fld_env (dfid_defn ti_decl) sub_names flds' - ; return (avail, fld_env) } - - new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl RdrName - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d - -newRecordSelector :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel -newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" -newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _)) - = do { selName <- newTopSrcBinder $ L loc $ field - ; return $ qualFieldLbl { flSelector = selName } } - where - fieldOccName = occNameFS $ rdrNameOcc fld - qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok - field | isExact fld = fld - -- use an Exact RdrName as is to preserve the bindings - -- of an already renamer-resolved field and its use - -- sites. This is needed to correctly support record - -- selectors in Template Haskell. See Note [Binders in - -- Template Haskell] in Convert.hs and Note [Looking up - -- Exact RdrNames] in RnEnv.hs. - | otherwise = mkRdrUnqual (flSelector qualFieldLbl) - -{- -Note [Looking up family names in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - module M where - type family T a :: * - type instance M.T Int = Bool - -We might think that we can simply use 'lookupOccRn' when processing the type -instance to look up 'M.T'. Alas, we can't! The type family declaration is in -the *same* HsGroup as the type instance declaration. Hence, as we are -currently collecting the binders declared in that HsGroup, these binders will -not have been added to the global environment yet. - -Solution is simple: process the type family declarations first, extend -the environment, and then process the type instances. - - -************************************************************************ -* * -\subsection{Filtering imports} -* * -************************************************************************ - -@filterImports@ takes the @ExportEnv@ telling what the imported module makes -available, and filters it through the import spec (if any). - -Note [Dealing with imports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For import M( ies ), we take the mi_exports of M, and make - imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name) -One entry for each Name that M exports; the AvailInfo is the -AvailInfo exported from M that exports that Name. - -The situation is made more complicated by associated types. E.g. - module M where - class C a where { data T a } - instance C Int where { data T Int = T1 | T2 } - instance C Bool where { data T Int = T3 } -Then M's export_avails are (recall the AvailTC invariant from Avails.hs) - C(C,T), T(T,T1,T2,T3) -Notice that T appears *twice*, once as a child and once as a parent. From -this list we construt a raw list including - T -> (T, T( T1, T2, T3 ), Nothing) - T -> (C, C( C, T ), Nothing) -and we combine these (in function 'combine' in 'imp_occ_env' in -'filterImports') to get - T -> (T, T(T,T1,T2,T3), Just C) - -So the overall imp_occ_env is - C -> (C, C(C,T), Nothing) - T -> (T, T(T,T1,T2,T3), Just C) - T1 -> (T1, T(T,T1,T2,T3), Nothing) -- similarly T2,T3 - -If we say - import M( T(T1,T2) ) -then we get *two* Avails: C(T), T(T1,T2) - -Note that the imp_occ_env will have entries for data constructors too, -although we never look up data constructors. --} - -filterImports - :: ModIface - -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (Bool, Located [LIE RdrName]) -- Import spec; True => hiding - -> RnM (Maybe (Bool, Located [LIE Name]), -- Import spec w/ Names - [GlobalRdrElt]) -- Same again, but in GRE form -filterImports iface decl_spec Nothing - = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface)) - where - imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - - -filterImports iface decl_spec (Just (want_hiding, L l import_items)) - = do -- check for errors, convert RdrNames to Names - items1 <- mapM lookup_lie import_items - - let items2 :: [(LIE Name, AvailInfo)] - items2 = concat items1 - -- NB the AvailInfo may have duplicates, and several items - -- for the same parent; e.g N(x) and N(y) - - names = availsToNameSet (map snd items2) - keep n = not (n `elemNameSet` names) - pruned_avails = filterAvails keep all_avails - hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - - gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails - | otherwise = concatMap (gresFromIE decl_spec) items2 - - return (Just (want_hiding, L l (map fst items2)), gres) - where - all_avails = mi_exports iface - - -- See Note [Dealing with imports] - imp_occ_env :: OccEnv (Name, -- the name - AvailInfo, -- the export item providing the name - Maybe Name) -- the parent of associated types - imp_occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing)) - | a <- all_avails, n <- availNames a] - where - -- See Note [Dealing with imports] - -- 'combine' is only called for associated data types which appear - -- twice in the all_avails. In the example, we combine - -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) - -- NB: the AvailTC can have fields as well as data constructors (Trac #12127) - combine (name1, a1@(AvailTC p1 _ _), mp1) - (name2, a2@(AvailTC p2 _ _), mp2) - = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2 - , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 ) - if p1 == name1 then (name1, a1, Just p2) - else (name1, a2, Just p1) - combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) - - lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name) - lookup_name rdr | isQual rdr = failLookupWith (QualImportError rdr) - | Just succ <- mb_success = return succ - | otherwise = failLookupWith BadImport - where - mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) - - lookup_lie :: LIE RdrName -> TcRn [(LIE Name, AvailInfo)] - lookup_lie (L loc ieRdr) - = do (stuff, warns) <- setSrcSpan loc $ - liftM (fromMaybe ([],[])) $ - run_lookup (lookup_ie ieRdr) - mapM_ emit_warning warns - return [ (L loc ie, avail) | (ie,avail) <- stuff ] - where - -- Warn when importing T(..) if T was exported abstractly - emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ - addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n) - emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ - addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr) - emit_warning BadImportW = whenWOptM Opt_WarnDodgyImports $ - addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg BadImport) - - run_lookup :: IELookupM a -> TcRn (Maybe a) - run_lookup m = case m of - Failed err -> addErr (lookup_err_msg err) >> return Nothing - Succeeded a -> return (Just a) - - lookup_err_msg err = case err of - BadImport -> badImportItemErr iface decl_spec ieRdr all_avails - IllegalImport -> illegalImportItemErr - QualImportError rdr -> qualImportItemErr rdr - - -- For each import item, we convert its RdrNames to Names, - -- and at the same time construct an AvailInfo corresponding - -- to what is actually imported by this item. - -- Returns Nothing on error. - -- We return a list here, because in the case of an import - -- item like C, if we are hiding, then C refers to *both* a - -- type/class and a data constructor. Moreover, when we import - -- data constructors of an associated family, we need separate - -- AvailInfos for the data constructors and the family (as they have - -- different parents). See Note [Dealing with imports] - lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning]) - lookup_ie ie = handle_bad_import $ do - case ie of - IEVar (L l n) -> do - (name, avail, _) <- lookup_name $ ieWrappedName n - return ([(IEVar (L l (replaceWrappedName n name)), - trimAvail avail name)], []) - - IEThingAll (L l tc) -> do - (name, avail, mb_parent) <- lookup_name $ ieWrappedName tc - let warns = case avail of - Avail {} -- e.g. f(..) - -> [DodgyImport $ ieWrappedName tc] - - AvailTC _ subs fs - | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym - -> [DodgyImport $ ieWrappedName tc] - - | not (is_qual decl_spec) -- e.g. import M( T(..) ) - -> [MissingImportList] - - | otherwise - -> [] - - renamed_ie = IEThingAll (L l (replaceWrappedName tc name)) - sub_avails = case avail of - Avail {} -> [] - AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)] - case mb_parent of - Nothing -> return ([(renamed_ie, avail)], warns) - -- non-associated ty/cls - Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns) - -- associated type - - IEThingAbs (L l tc') - | want_hiding -- hiding ( C ) - -- Here the 'C' can be a data constructor - -- *or* a type/class, or even both - -> let tc = ieWrappedName tc' - tc_name = lookup_name tc - dc_name = lookup_name (setRdrNameSpace tc srcDataName) - in - case catIELookupM [ tc_name, dc_name ] of - [] -> failLookupWith BadImport - names -> return ([mkIEThingAbs tc' l name | name <- names], []) - | otherwise - -> do nameAvail <- lookup_name (ieWrappedName tc') - return ([mkIEThingAbs tc' l nameAvail] - , []) - - IEThingWith (L l rdr_tc) wc rdr_ns' rdr_fs -> - ASSERT2(null rdr_fs, ppr rdr_fs) do - (name, AvailTC _ ns subflds, mb_parent) - <- lookup_name (ieWrappedName rdr_tc) - - -- Look up the children in the sub-names of the parent - let subnames = case ns of -- The tc is first in ns, - [] -> [] -- if it is there at all - -- See the AvailTC Invariant in Avail.hs - (n1:ns1) | n1 == name -> ns1 - | otherwise -> ns - rdr_ns = map ieLWrappedName rdr_ns' - case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of - Nothing -> failLookupWith BadImport - Just (childnames, childflds) -> - case mb_parent of - -- non-associated ty/cls - Nothing - -> return ([(IEThingWith (L l name') wc childnames' - childflds, - AvailTC name (name:map unLoc childnames) (map unLoc childflds))], - []) - where name' = replaceWrappedName rdr_tc name - childnames' = map to_ie_post_rn childnames - -- childnames' = postrn_ies childnames - -- associated ty - Just parent - -> return ([(IEThingWith (L l name') wc childnames' - childflds, - AvailTC name (map unLoc childnames) (map unLoc childflds)), - (IEThingWith (L l name') wc childnames' - childflds, - AvailTC parent [name] [])], - []) - where name' = replaceWrappedName rdr_tc name - childnames' = map to_ie_post_rn childnames - - _other -> failLookupWith IllegalImport - -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed - -- all errors. - - where - mkIEThingAbs tc l (n, av, Nothing ) - = (IEThingAbs (L l (replaceWrappedName tc n)), trimAvail av n) - mkIEThingAbs tc l (n, _, Just parent) - = (IEThingAbs (L l (replaceWrappedName tc n)), AvailTC parent [n] []) - - handle_bad_import m = catchIELookup m $ \err -> case err of - BadImport | want_hiding -> return ([], [BadImportW]) - _ -> failLookupWith err - -type IELookupM = MaybeErr IELookupError - -data IELookupWarning - = BadImportW - | MissingImportList - | DodgyImport RdrName - -- NB. use the RdrName for reporting a "dodgy" import - -data IELookupError - = QualImportError RdrName - | BadImport - | IllegalImport - -failLookupWith :: IELookupError -> IELookupM a -failLookupWith err = Failed err - -catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a -catchIELookup m h = case m of - Succeeded r -> return r - Failed err -> h err - -catIELookupM :: [IELookupM a] -> [a] -catIELookupM ms = [ a | Succeeded a <- ms ] - -{- -************************************************************************ -* * -\subsection{Import/Export Utils} -* * -************************************************************************ --} - --- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's. -gresFromIE :: ImpDeclSpec -> (LIE Name, AvailInfo) -> [GlobalRdrElt] -gresFromIE decl_spec (L loc ie, avail) - = gresFromAvail prov_fn avail - where - is_explicit = case ie of - IEThingAll (L _ name) -> \n -> n == ieWrappedName name - _ -> \_ -> True - prov_fn name - = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec }) - where - item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc } - - -{- -Note [Children for duplicate record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the module - - {-# LANGUAGE DuplicateRecordFields #-} - module M (F(foo, MkFInt, MkFBool)) where - data family F a - data instance F Int = MkFInt { foo :: Int } - data instance F Bool = MkFBool { foo :: Bool } - -The `foo` in the export list refers to *both* selectors! For this -reason, lookupChildren builds an environment that maps the FastString -to a list of items, rather than a single item. --} - -mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] -mkChildEnv gres = foldr add emptyNameEnv gres - where - add gre env = case gre_par gre of - FldParent p _ -> extendNameEnv_Acc (:) singleton env p gre - ParentIs p -> extendNameEnv_Acc (:) singleton env p gre - NoParent -> env - -findChildren :: NameEnv [a] -> Name -> [a] -findChildren env n = lookupNameEnv env n `orElse` [] - -lookupChildren :: [Either Name FieldLabel] -> [Located RdrName] - -> Maybe ([Located Name], [Located FieldLabel]) --- (lookupChildren all_kids rdr_items) maps each rdr_item to its --- corresponding Name all_kids, if the former exists --- The matching is done by FastString, not OccName, so that --- Cls( meth, AssocTy ) --- will correctly find AssocTy among the all_kids of Cls, even though --- the RdrName for AssocTy may have a (bogus) DataName namespace --- (Really the rdr_items should be FastStrings in the first place.) -lookupChildren all_kids rdr_items - = do xs <- mapM doOne rdr_items - return (fmap concat (partitionEithers xs)) - where - doOne (L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc) r of - Just [Left n] -> Just (Left (L l n)) - Just rs | all isRight rs -> Just (Right (map (L l) (rights rs))) - _ -> Nothing - - -- See Note [Children for duplicate record fields] - kid_env = extendFsEnvList_C (++) emptyFsEnv - [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids] - - - -------------------------------- - -{- -********************************************************* -* * -\subsection{Unused names} -* * -********************************************************* --} - -reportUnusedNames :: Maybe (Located [LIE RdrName]) -- Export list - -> TcGblEnv -> RnM () -reportUnusedNames _export_decls gbl_env - = do { traceRn "RUN" (ppr (tcg_dus gbl_env)) - ; warnUnusedImportDecls gbl_env - ; warnUnusedTopBinds unused_locals - ; warnMissingSignatures gbl_env } - where - used_names :: NameSet - used_names = findUses (tcg_dus gbl_env) emptyNameSet - -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used - -- Hence findUses - - -- Collect the defined names from the in-scope environment - defined_names :: [GlobalRdrElt] - defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) - - -- Note that defined_and_used, defined_but_not_used - -- are both [GRE]; that's why we need defined_and_used - -- rather than just used_names - _defined_and_used, defined_but_not_used :: [GlobalRdrElt] - (_defined_and_used, defined_but_not_used) - = partition (gre_is_used used_names) defined_names - - kids_env = mkChildEnv defined_names - -- This is done in mkExports too; duplicated work - - gre_is_used :: NameSet -> GlobalRdrElt -> Bool - gre_is_used used_names (GRE {gre_name = name}) - = name `elemNameSet` used_names - || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name) - -- A use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - - -- Filter out the ones that are - -- (a) defined in this module, and - -- (b) not defined by a 'deriving' clause - -- The latter have an Internal Name, so we can filter them out easily - unused_locals :: [GlobalRdrElt] - unused_locals = filter is_unused_local defined_but_not_used - is_unused_local :: GlobalRdrElt -> Bool - is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre) - -{- -********************************************************* -* * -\subsection{Unused imports} -* * -********************************************************* - -This code finds which import declarations are unused. The -specification and implementation notes are here: - http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/UnusedImports --} - -type ImportDeclUsage - = ( LImportDecl Name -- The import declaration - , [AvailInfo] -- What *is* used (normalised) - , [Name] ) -- What is imported but *not* used - -warnUnusedImportDecls :: TcGblEnv -> RnM () -warnUnusedImportDecls gbl_env - = do { uses <- readMutVar (tcg_used_gres gbl_env) - ; let user_imports = filterOut (ideclImplicit . unLoc) (tcg_rn_imports gbl_env) - -- This whole function deals only with *user* imports - -- both for warning about unnecessary ones, and for - -- deciding the minimal ones - rdr_env = tcg_rdr_env gbl_env - fld_env = mkFieldEnv rdr_env - - ; let usage :: [ImportDeclUsage] - usage = findImportUsage user_imports uses - - ; traceRn "warnUnusedImportDecls" $ - (vcat [ text "Uses:" <+> ppr uses - , text "Import usage" <+> ppr usage]) - ; whenWOptM Opt_WarnUnusedImports $ - mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage - - ; whenGOptM Opt_D_dump_minimal_imports $ - printMinimalImports usage } - --- | Warn the user about top level binders that lack type signatures. --- Called /after/ type inference, so that we can report the --- inferred type of the function -warnMissingSignatures :: TcGblEnv -> RnM () -warnMissingSignatures gbl_env - = do { let exports = availsToNameSet (tcg_exports gbl_env) - sig_ns = tcg_sigs gbl_env - -- We use sig_ns to exclude top-level bindings that are generated by GHC - binds = collectHsBindsBinders $ tcg_binds gbl_env - pat_syns = tcg_patsyns gbl_env - - -- Warn about missing signatures - -- Do this only when we we have a type to offer - ; warn_missing_sigs <- woptM Opt_WarnMissingSignatures - ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures - ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures - - ; let add_sig_warns - | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures - | warn_missing_sigs = add_warns Opt_WarnMissingSignatures - | warn_pat_syns = add_warns Opt_WarnMissingPatternSynonymSignatures - | otherwise = return () - - add_warns flag - = when warn_pat_syns - (mapM_ add_pat_syn_warn pat_syns) >> - when (warn_missing_sigs || warn_only_exported) - (mapM_ add_bind_warn binds) - where - add_pat_syn_warn p - = add_warn name $ - hang (text "Pattern synonym with no type signature:") - 2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty) - where - name = patSynName p - pp_ty = pprPatSynType p - - add_bind_warn id - = do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv? - ; let name = idName id - (_, ty) = tidyOpenType env (idType id) - ty_msg = pprSigmaType ty - ; add_warn name $ - hang (text "Top-level binding with no type signature:") - 2 (pprPrefixName name <+> dcolon <+> ty_msg) } - - add_warn name msg - = when (name `elemNameSet` sig_ns && export_check name) - (addWarnAt (Reason flag) (getSrcSpan name) msg) - - export_check name - = not warn_only_exported || name `elemNameSet` exports - - ; add_sig_warns } - -{- -Note [The ImportMap] -~~~~~~~~~~~~~~~~~~~~ -The ImportMap is a short-lived intermediate data struture records, for -each import declaration, what stuff brought into scope by that -declaration is actually used in the module. - -The SrcLoc is the location of the END of a particular 'import' -declaration. Why *END*? Because we don't want to get confused -by the implicit Prelude import. Consider (Trac #7476) the module - import Foo( foo ) - main = print foo -There is an implicit 'import Prelude(print)', and it gets a SrcSpan -of line 1:1 (just the point, not a span). If we use the *START* of -the SrcSpan to identify the import decl, we'll confuse the implicit -import Prelude with the explicit 'import Foo'. So we use the END. -It's just a cheap hack; we could equally well use the Span too. - -The AvailInfos are the things imported from that decl (just a list, -not normalised). --} - -type ImportMap = Map SrcLoc [AvailInfo] -- See [The ImportMap] - -findImportUsage :: [LImportDecl Name] - -> [GlobalRdrElt] - -> [ImportDeclUsage] - -findImportUsage imports used_gres - = map unused_decl imports - where - import_usage :: ImportMap - import_usage - = foldr extendImportMap Map.empty used_gres - - unused_decl decl@(L loc (ImportDecl { ideclHiding = imps })) - = (decl, nubAvails used_avails, nameSetElemsStable unused_imps) - where - used_avails = Map.lookup (srcSpanEnd loc) import_usage `orElse` [] - -- srcSpanEnd: see Note [The ImportMap] - used_names = availsToNameSetWithSelectors used_avails - used_parents = mkNameSet [n | AvailTC n _ _ <- used_avails] - - unused_imps -- Not trivial; see eg Trac #7454 - = case imps of - Just (False, L _ imp_ies) -> - foldr (add_unused . unLoc) emptyNameSet imp_ies - _other -> emptyNameSet -- No explicit import list => no unused-name list - - add_unused :: IE Name -> NameSet -> NameSet - add_unused (IEVar (L _ n)) acc - = add_unused_name (ieWrappedName n) acc - add_unused (IEThingAbs (L _ n)) acc - = add_unused_name (ieWrappedName n) acc - add_unused (IEThingAll (L _ n)) acc - = add_unused_all (ieWrappedName n) acc - add_unused (IEThingWith (L _ p) wc ns fs) acc = - add_wc_all (add_unused_with (ieWrappedName p) xs acc) - where xs = map (ieWrappedName . unLoc) ns - ++ map (flSelector . unLoc) fs - add_wc_all = case wc of - NoIEWildcard -> id - IEWildcard _ -> add_unused_all (ieWrappedName p) - add_unused _ acc = acc - - add_unused_name n acc - | n `elemNameSet` used_names = acc - | otherwise = acc `extendNameSet` n - add_unused_all n acc - | n `elemNameSet` used_names = acc - | n `elemNameSet` used_parents = acc - | otherwise = acc `extendNameSet` n - add_unused_with p ns acc - | all (`elemNameSet` acc1) ns = add_unused_name p acc1 - | otherwise = acc1 - where - acc1 = foldr add_unused_name acc ns - -- If you use 'signum' from Num, then the user may well have - -- imported Num(signum). We don't want to complain that - -- Num is not itself mentioned. Hence the two cases in add_unused_with. - -extendImportMap :: GlobalRdrElt -> ImportMap -> ImportMap --- For each of a list of used GREs, find all the import decls that brought --- it into scope; choose one of them (bestImport), and record --- the RdrName in that import decl's entry in the ImportMap -extendImportMap gre imp_map - = add_imp gre (bestImport (gre_imp gre)) imp_map - where - add_imp :: GlobalRdrElt -> ImportSpec -> ImportMap -> ImportMap - add_imp gre (ImpSpec { is_decl = imp_decl_spec }) imp_map - = Map.insertWith add decl_loc [avail] imp_map - where - add _ avails = avail : avails -- add is really just a specialised (++) - decl_loc = srcSpanEnd (is_dloc imp_decl_spec) - -- For srcSpanEnd see Note [The ImportMap] - avail = availFromGRE gre - -warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name) - -> ImportDeclUsage -> RnM () -warnUnusedImport flag fld_env (L loc decl, used, unused) - | Just (False,L _ []) <- ideclHiding decl - = return () -- Do not warn for 'import M()' - - | Just (True, L _ hides) <- ideclHiding decl - , not (null hides) - , pRELUDE_NAME == unLoc (ideclName decl) - = return () -- Note [Do not warn about Prelude hiding] - | null used = addWarnAt (Reason flag) loc msg1 -- Nothing used; drop entire decl - | null unused = return () -- Everything imported is used; nop - | otherwise = addWarnAt (Reason flag) loc msg2 -- Some imports are unused - where - msg1 = vcat [pp_herald <+> quotes pp_mod <+> pp_not_used, - nest 2 (text "except perhaps to import instances from" - <+> quotes pp_mod), - text "To import instances alone, use:" - <+> text "import" <+> pp_mod <> parens Outputable.empty ] - msg2 = sep [pp_herald <+> quotes sort_unused, - text "from module" <+> quotes pp_mod <+> pp_not_used] - pp_herald = text "The" <+> pp_qual <+> text "import of" - pp_qual - | ideclQualified decl = text "qualified" - | otherwise = Outputable.empty - pp_mod = ppr (unLoc (ideclName decl)) - pp_not_used = text "is redundant" - - ppr_possible_field n = case lookupNameEnv fld_env n of - Just (fld, p) -> ppr p <> parens (ppr fld) - Nothing -> ppr n - - -- Print unused names in a deterministic (lexicographic) order - sort_unused = pprWithCommas ppr_possible_field $ - sortBy (comparing nameOccName) unused - -{- -Note [Do not warn about Prelude hiding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not warn about - import Prelude hiding( x, y ) -because even if nothing else from Prelude is used, it may be essential to hide -x,y to avoid name-shadowing warnings. Example (Trac #9061) - import Prelude hiding( log ) - f x = log where log = () - - - -Note [Printing minimal imports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To print the minimal imports we walk over the user-supplied import -decls, and simply trim their import lists. NB that - - * We do *not* change the 'qualified' or 'as' parts! - - * We do not disard a decl altogether; we might need instances - from it. Instead we just trim to an empty import list --} - -printMinimalImports :: [ImportDeclUsage] -> RnM () --- See Note [Printing minimal imports] -printMinimalImports imports_w_usage - = do { imports' <- mapM mk_minimal imports_w_usage - ; this_mod <- getModule - ; dflags <- getDynFlags - ; liftIO $ - do { h <- openFile (mkFilename dflags this_mod) WriteMode - ; printForUser dflags h neverQualify (vcat (map ppr imports')) } - -- The neverQualify is important. We are printing Names - -- but they are in the context of an 'import' decl, and - -- we never qualify things inside there - -- E.g. import Blag( f, b ) - -- not import Blag( Blag.f, Blag.g )! - } - where - mkFilename dflags this_mod - | Just d <- dumpDir dflags = d basefn - | otherwise = basefn - where - basefn = moduleNameString (moduleName this_mod) ++ ".imports" - - mk_minimal (L l decl, used, unused) - | null unused - , Just (False, _) <- ideclHiding decl - = return (L l decl) - | otherwise - = do { let ImportDecl { ideclName = L _ mod_name - , ideclSource = is_boot - , ideclPkgQual = mb_pkg } = decl - ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg) - ; let lies = map (L l) (concatMap (to_ie iface) used) - ; return (L l (decl { ideclHiding = Just (False, L l lies) })) } - where - doc = text "Compute minimal imports for" <+> ppr decl - - to_ie :: ModIface -> AvailInfo -> [IE Name] - -- The main trick here is that if we're importing all the constructors - -- we want to say "T(..)", but if we're importing only a subset we want - -- to say "T(A,B,C)". So we have to find out what the module exports. - to_ie _ (Avail n) - = [IEVar (to_ie_post_rn $ noLoc n)] - to_ie _ (AvailTC n [m] []) - | n==m = [IEThingAbs (to_ie_post_rn $ noLoc n)] - to_ie iface (AvailTC n ns fs) - = case [(xs,gs) | AvailTC x xs gs <- mi_exports iface - , x == n - , x `elem` xs -- Note [Partial export] - ] of - [xs] | all_used xs -> [IEThingAll (to_ie_post_rn $ noLoc n)] - | otherwise -> - [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard - (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) - (map noLoc fs)] - -- Note [Overloaded field import] - _other | all_non_overloaded fs - -> map (IEVar . to_ie_post_rn_var . noLoc) $ ns - ++ map flSelector fs - | otherwise -> - [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard - (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) - (map noLoc fs)] - where - - fld_lbls = map flLabel fs - - all_used (avail_occs, avail_flds) - = all (`elem` ns) avail_occs - && all (`elem` fld_lbls) (map flLabel avail_flds) - - all_non_overloaded = all (not . flIsOverloaded) - -to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name -to_ie_post_rn_var (L l n) - | isDataOcc $ occName n = L l (IEPattern (L l n)) - | otherwise = L l (IEName (L l n)) - - -to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name -to_ie_post_rn (L l n) - | isTcOcc occ && isSymOcc occ = L l (IEType (L l n)) - | otherwise = L l (IEName (L l n)) - where occ = occName n - -{- -Note [Partial export] -~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - module A( op ) where - class C a where - op :: a -> a - - module B where - import A - f = ..op... - -Then the minimal import for module B is - import A( op ) -not - import A( C( op ) ) -which we would usually generate if C was exported from B. Hence -the (x `elem` xs) test when deciding what to generate. - - -Note [Overloaded field import] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -On the other hand, if we have - - {-# LANGUAGE DuplicateRecordFields #-} - module A where - data T = MkT { foo :: Int } - - module B where - import A - f = ...foo... - -then the minimal import for module B must be - import A ( T(foo) ) -because when DuplicateRecordFields is enabled, field selectors are -not in scope without their enclosing datatype. - - -************************************************************************ -* * -\subsection{Errors} -* * -************************************************************************ --} - -qualImportItemErr :: RdrName -> SDoc -qualImportItemErr rdr - = hang (text "Illegal qualified name in import item:") - 2 (ppr rdr) - -badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE RdrName -> SDoc -badImportItemErrStd iface decl_spec ie - = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import, - text "does not export", quotes (ppr ie)] - where - source_import | mi_boot iface = text "(hi-boot interface)" - | otherwise = Outputable.empty - -badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE RdrName -> SDoc -badImportItemErrDataCon dataType_occ iface decl_spec ie - = vcat [ text "In module" - <+> quotes (ppr (is_mod decl_spec)) - <+> source_import <> colon - , nest 2 $ quotes datacon - <+> text "is a data constructor of" - <+> quotes dataType - , text "To import it use" - , nest 2 $ text "import" - <+> ppr (is_mod decl_spec) - <> parens_sp (dataType <> parens_sp datacon) - , text "or" - , nest 2 $ text "import" - <+> ppr (is_mod decl_spec) - <> parens_sp (dataType <> text "(..)") - ] - where - datacon_occ = rdrNameOcc $ ieName ie - datacon = parenSymOcc datacon_occ (ppr datacon_occ) - dataType = parenSymOcc dataType_occ (ppr dataType_occ) - source_import | mi_boot iface = text "(hi-boot interface)" - | otherwise = Outputable.empty - parens_sp d = parens (space <> d <> space) -- T( f,g ) - -badImportItemErr :: ModIface -> ImpDeclSpec -> IE RdrName -> [AvailInfo] -> SDoc -badImportItemErr iface decl_spec ie avails - = case find checkIfDataCon avails of - Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie - Nothing -> badImportItemErrStd iface decl_spec ie - where - checkIfDataCon (AvailTC _ ns _) = - case find (\n -> importedFS == nameOccNameFS n) ns of - Just n -> isDataConName n - Nothing -> False - checkIfDataCon _ = False - availOccName = nameOccName . availName - nameOccNameFS = occNameFS . nameOccName - importedFS = occNameFS . rdrNameOcc $ ieName ie - -illegalImportItemErr :: SDoc -illegalImportItemErr = text "Illegal import item" - -dodgyImportWarn :: RdrName -> SDoc -dodgyImportWarn item = dodgyMsg (text "import") item - -dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc -dodgyMsg kind tc - = sep [ text "The" <+> kind <+> ptext (sLit "item") - <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc)))) - <+> text "suggests that", - quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", - text "but it has none" ] - - -addDupDeclErr :: [GlobalRdrElt] -> TcRn () -addDupDeclErr [] = panic "addDupDeclErr: empty list" -addDupDeclErr gres@(gre : _) - = addErrAt (getSrcSpan (last sorted_names)) $ - -- Report the error at the later location - vcat [text "Multiple declarations of" <+> - quotes (ppr (nameOccName name)), - -- NB. print the OccName, not the Name, because the - -- latter might not be in scope in the RdrEnv and so will - -- be printed qualified. - text "Declared at:" <+> - vcat (map (ppr . nameSrcLoc) sorted_names)] - where - name = gre_name gre - sorted_names = sortWith nameSrcLoc (map gre_name gres) - - - -missingImportListWarn :: ModuleName -> SDoc -missingImportListWarn mod - = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list") - -missingImportListItem :: IE RdrName -> SDoc -missingImportListItem ie - = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list") - -moduleWarn :: ModuleName -> WarningTxt -> SDoc -moduleWarn mod (WarningTxt _ txt) - = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"), - nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] -moduleWarn mod (DeprecatedTxt _ txt) - = sep [ text "Module" <+> quotes (ppr mod) - <+> text "is deprecated:", - nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] - -packageImportErr :: SDoc -packageImportErr - = text "Package-qualified imports are not enabled; use PackageImports" - --- This data decl will parse OK --- data T = a Int --- treating "a" as the constructor. --- It is really hard to make the parser spot this malformation. --- So the renamer has to check that the constructor is legal --- --- We can get an operator as the constructor, even in the prefix form: --- data T = :% Int Int --- from interface files, which always print in prefix form - -checkConName :: RdrName -> TcRn () -checkConName name = checkErr (isRdrDataCon name) (badDataCon name) - -badDataCon :: RdrName -> SDoc -badDataCon name - = hsep [text "Illegal data constructor name", quotes (ppr name)] diff --git a/rename/RnPat.hs b/rename/RnPat.hs deleted file mode 100644 --- a/rename/RnPat.hs +++ /dev/null @@ -1,861 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnPat]{Renaming of patterns} - -Basically dependency analysis. - -Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In -general, all of these functions return a renamed thing, and a set of -free variables. --} - -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} - -module RnPat (-- main entry points - rnPat, rnPats, rnBindPat, rnPatAndThen, - - NameMaker, applyNameMaker, -- a utility for making names: - localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names, - -- sometimes we want to make top (qualified) names. - isTopRecNameMaker, - - rnHsRecFields, HsRecFieldContext(..), - rnHsRecUpdFields, - - -- CpsRn monad - CpsRn, liftCps, - - -- Literals - rnLit, rnOverLit, - - -- Pattern Error messages that are also used elsewhere - checkTupSize, patSigErr - ) where - --- ENH: thin imports to only what is necessary for patterns - -import {-# SOURCE #-} RnExpr ( rnLExpr ) -import {-# SOURCE #-} RnSplice ( rnSplicePat ) - -#include "HsVersions.h" - -import HsSyn -import TcRnMonad -import TcHsSyn ( hsOverLitName ) -import RnEnv -import RnTypes -import PrelNames -import TyCon ( tyConName ) -import ConLike -import Type ( TyThing(..) ) -import Name -import NameSet -import RdrName -import BasicTypes -import Util -import ListSetOps ( removeDups ) -import Outputable -import SrcLoc -import Literal ( inCharRange ) -import TysWiredIn ( nilDataCon ) -import DataCon -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad ( when, liftM, ap, unless ) -import Data.Ratio - -{- -********************************************************* -* * - The CpsRn Monad -* * -********************************************************* - -Note [CpsRn monad] -~~~~~~~~~~~~~~~~~~ -The CpsRn monad uses continuation-passing style to support this -style of programming: - - do { ... - ; ns <- bindNames rs - ; ...blah... } - - where rs::[RdrName], ns::[Name] - -The idea is that '...blah...' - a) sees the bindings of ns - b) returns the free variables it mentions - so that bindNames can report unused ones - -In particular, - mapM rnPatAndThen [p1, p2, p3] -has a *left-to-right* scoping: it makes the binders in -p1 scope over p2,p3. --} - -newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars)) - -> RnM (r, FreeVars) } - -- See Note [CpsRn monad] - -instance Functor CpsRn where - fmap = liftM - -instance Applicative CpsRn where - pure x = CpsRn (\k -> k x) - (<*>) = ap - -instance Monad CpsRn where - (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k)) - -runCps :: CpsRn a -> RnM (a, FreeVars) -runCps (CpsRn m) = m (\r -> return (r, emptyFVs)) - -liftCps :: RnM a -> CpsRn a -liftCps rn_thing = CpsRn (\k -> rn_thing >>= k) - -liftCpsFV :: RnM (a, FreeVars) -> CpsRn a -liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing - ; (r,fvs2) <- k v - ; return (r, fvs1 `plusFV` fvs2) }) - -wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b) --- Set the location, and also wrap it around the value returned -wrapSrcSpanCps fn (L loc a) - = CpsRn (\k -> setSrcSpan loc $ - unCpsRn (fn a) $ \v -> - k (L loc v)) - -lookupConCps :: Located RdrName -> CpsRn (Located Name) -lookupConCps con_rdr - = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr - ; (r, fvs) <- k con_name - ; return (r, addOneFV fvs (unLoc con_name)) }) - -- We add the constructor name to the free vars - -- See Note [Patterns are uses] - -{- -Note [Patterns are uses] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - module Foo( f, g ) where - data T = T1 | T2 - - f T1 = True - f T2 = False - - g _ = T1 - -Arguably we should report T2 as unused, even though it appears in a -pattern, because it never occurs in a constructed position. See -Trac #7336. -However, implementing this in the face of pattern synonyms would be -less straightforward, since given two pattern synonyms - - pattern P1 <- P2 - pattern P2 <- () - -we need to observe the dependency between P1 and P2 so that type -checking can be done in the correct order (just like for value -bindings). Dependencies between bindings is analyzed in the renamer, -where we don't know yet whether P2 is a constructor or a pattern -synonym. So for now, we do report conid occurrences in patterns as -uses. - -********************************************************* -* * - Name makers -* * -********************************************************* - -Externally abstract type of name makers, -which is how you go from a RdrName to a Name --} - -data NameMaker - = LamMk -- Lambdas - Bool -- True <=> report unused bindings - -- (even if True, the warning only comes out - -- if -Wunused-matches is on) - - | LetMk -- Let bindings, incl top level - -- Do *not* check for unused bindings - TopLevelFlag - MiniFixityEnv - -topRecNameMaker :: MiniFixityEnv -> NameMaker -topRecNameMaker fix_env = LetMk TopLevel fix_env - -isTopRecNameMaker :: NameMaker -> Bool -isTopRecNameMaker (LetMk TopLevel _) = True -isTopRecNameMaker _ = False - -localRecNameMaker :: MiniFixityEnv -> NameMaker -localRecNameMaker fix_env = LetMk NotTopLevel fix_env - -matchNameMaker :: HsMatchContext a -> NameMaker -matchNameMaker ctxt = LamMk report_unused - where - -- Do not report unused names in interactive contexts - -- i.e. when you type 'x <- e' at the GHCi prompt - report_unused = case ctxt of - StmtCtxt GhciStmtCtxt -> False - -- also, don't warn in pattern quotes, as there - -- is no RHS where the variables can be used! - ThPatQuote -> False - _ -> True - -rnHsSigCps :: LHsSigWcType RdrName -> CpsRn (LHsSigWcType Name) -rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig) - -newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) -newPatLName name_maker rdr_name@(L loc _) - = do { name <- newPatName name_maker rdr_name - ; return (L loc name) } - -newPatName :: NameMaker -> Located RdrName -> CpsRn Name -newPatName (LamMk report_unused) rdr_name - = CpsRn (\ thing_inside -> - do { name <- newLocalBndrRn rdr_name - ; (res, fvs) <- bindLocalNames [name] (thing_inside name) - ; when report_unused $ warnUnusedMatches [name] fvs - ; return (res, name `delFV` fvs) }) - -newPatName (LetMk is_top fix_env) rdr_name - = CpsRn (\ thing_inside -> - do { name <- case is_top of - NotTopLevel -> newLocalBndrRn rdr_name - TopLevel -> newTopSrcBinder rdr_name - ; bindLocalNames [name] $ -- Do *not* use bindLocalNameFV here - -- See Note [View pattern usage] - addLocalFixities fix_env [name] $ - thing_inside name }) - - -- Note: the bindLocalNames is somewhat suspicious - -- because it binds a top-level name as a local name. - -- however, this binding seems to work, and it only exists for - -- the duration of the patterns and the continuation; - -- then the top-level name is added to the global env - -- before going on to the RHSes (see RnSource.hs). - -{- -Note [View pattern usage] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let (r, (r -> x)) = x in ... -Here the pattern binds 'r', and then uses it *only* in the view pattern. -We want to "see" this use, and in let-bindings we collect all uses and -report unused variables at the binding level. So we must use bindLocalNames -here, *not* bindLocalNameFV. Trac #3943. - - -Note [Don't report shadowing for pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is one special context where a pattern doesn't introduce any new binders - -pattern synonym declarations. Therefore we don't check to see if pattern -variables shadow existing identifiers as they are never bound to anything -and have no scope. - -Without this check, there would be quite a cryptic warning that the `x` -in the RHS of the pattern synonym declaration shadowed the top level `x`. - -``` -x :: () -x = () - -pattern P x = Just x -``` - -See #12615 for some more examples. - -********************************************************* -* * - External entry points -* * -********************************************************* - -There are various entry points to renaming patterns, depending on - (1) whether the names created should be top-level names or local names - (2) whether the scope of the names is entirely given in a continuation - (e.g., in a case or lambda, but not in a let or at the top-level, - because of the way mutually recursive bindings are handled) - (3) whether the a type signature in the pattern can bind - lexically-scoped type variables (for unpacking existential - type vars in data constructors) - (4) whether we do duplicate and unused variable checking - (5) whether there are fixity declarations associated with the names - bound by the patterns that need to be brought into scope with them. - - Rather than burdening the clients of this module with all of these choices, - we export the three points in this design space that we actually need: --} - --- ----------- Entry point 1: rnPats ------------------- --- Binds local names; the scope of the bindings is entirely in the thing_inside --- * allows type sigs to bind type vars --- * local namemaker --- * unused and duplicate checking --- * no fixities -rnPats :: HsMatchContext Name -- for error messages - -> [LPat RdrName] - -> ([LPat Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnPats ctxt pats thing_inside - = do { envs_before <- getRdrEnvs - - -- (1) rename the patterns, bringing into scope all of the term variables - -- (2) then do the thing inside. - ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do - { -- Check for duplicated and shadowed names - -- Must do this *after* renaming the patterns - -- See Note [Collect binders only after renaming] in HsUtils - -- Because we don't bind the vars all at once, we can't - -- check incrementally for duplicates; - -- Nor can we check incrementally for shadowing, else we'll - -- complain *twice* about duplicates e.g. f (x,x) = ... - -- - -- See note [Don't report shadowing for pattern synonyms] - ; unless (isPatSynCtxt ctxt) - (addErrCtxt doc_pat $ - checkDupAndShadowedNames envs_before $ - collectPatsBinders pats') - ; thing_inside pats' } } - where - doc_pat = text "In" <+> pprMatchContext ctxt - -rnPat :: HsMatchContext Name -- for error messages - -> LPat RdrName - -> (LPat Name -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -- Variables bound by pattern do not - -- appear in the result FreeVars -rnPat ctxt pat thing_inside - = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') - -applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name) -applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) - ; return n } - --- ----------- Entry point 2: rnBindPat ------------------- --- Binds local names; in a recursive scope that involves other bound vars --- e.g let { (x, Just y) = e1; ... } in ... --- * does NOT allows type sig to bind type vars --- * local namemaker --- * no unused and duplicate checking --- * fixities might be coming in -rnBindPat :: NameMaker - -> LPat RdrName - -> RnM (LPat Name, FreeVars) - -- Returned FreeVars are the free variables of the pattern, - -- of course excluding variables bound by this pattern - -rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat) - -{- -********************************************************* -* * - The main event -* * -********************************************************* --} - --- ----------- Entry point 3: rnLPatAndThen ------------------- --- General version: parametrized by how you make new names - -rnLPatsAndThen :: NameMaker -> [LPat RdrName] -> CpsRn [LPat Name] -rnLPatsAndThen mk = mapM (rnLPatAndThen mk) - -- Despite the map, the monad ensures that each pattern binds - -- variables that may be mentioned in subsequent patterns in the list - --------------------- --- The workhorse -rnLPatAndThen :: NameMaker -> LPat RdrName -> CpsRn (LPat Name) -rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat - -rnPatAndThen :: NameMaker -> Pat RdrName -> CpsRn (Pat Name) -rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType) -rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') } -rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') } -rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') } -rnPatAndThen mk (VarPat (L l rdr)) = do { loc <- liftCps getSrcSpanM - ; name <- newPatName mk (L loc rdr) - ; return (VarPat (L l name)) } - -- we need to bind pattern variables for view pattern expressions - -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) - -rnPatAndThen mk (SigPatIn pat sig) - -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is - -- important to rename its type signature _before_ renaming the rest of the - -- pattern, so that type variables are first bound by the _outermost_ pattern - -- type signature they occur in. This keeps the type checker happy when - -- pattern type signatures happen to be nested (#7827) - -- - -- f ((Just (x :: a) :: Maybe a) - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here - -- ~~~~~~~~~~~~~~~^ the same `a' then used here - = do { sig' <- rnHsSigCps sig - ; pat' <- rnLPatAndThen mk pat - ; return (SigPatIn pat' sig') } - -rnPatAndThen mk (LitPat lit) - | HsString src s <- lit - = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings) - ; if ovlStr - then rnPatAndThen mk - (mkNPat (noLoc (mkHsIsString src s placeHolderType)) - Nothing) - else normal_lit } - | otherwise = normal_lit - where - normal_lit = do { liftCps (rnLit lit); return (LitPat lit) } - -rnPatAndThen _ (NPat (L l lit) mb_neg _eq _) - = do { lit' <- liftCpsFV $ rnOverLit lit - ; mb_neg' <- liftCpsFV $ case mb_neg of - Nothing -> return (Nothing, emptyFVs) - Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName - ; return (Just neg, fvs) } - ; eq' <- liftCpsFV $ lookupSyntaxName eqName - ; return (NPat (L l lit') mb_neg' eq' placeHolderType) } - -rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _) - = do { new_name <- newPatName mk rdr - ; lit' <- liftCpsFV $ rnOverLit lit - ; minus <- liftCpsFV $ lookupSyntaxName minusName - ; ge <- liftCpsFV $ lookupSyntaxName geName - ; return (NPlusKPat (L (nameSrcSpan new_name) new_name) - (L l lit') lit' ge minus placeHolderType) } - -- The Report says that n+k patterns must be in Integral - -rnPatAndThen mk (AsPat rdr pat) - = do { new_name <- newPatLName mk rdr - ; pat' <- rnLPatAndThen mk pat - ; return (AsPat new_name pat') } - -rnPatAndThen mk p@(ViewPat expr pat _ty) - = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns - ; checkErr vp_flag (badViewPat p) } - -- Because of the way we're arranging the recursive calls, - -- this will be in the right context - ; expr' <- liftCpsFV $ rnLExpr expr - ; pat' <- rnLPatAndThen mk pat - -- Note: at this point the PreTcType in ty can only be a placeHolder - -- ; return (ViewPat expr' pat' ty) } - ; return (ViewPat expr' pat' placeHolderType) } - -rnPatAndThen mk (ConPatIn con stuff) - -- rnConPatAndThen takes care of reconstructing the pattern - -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. - = case unLoc con == nameRdrName (dataConName nilDataCon) of - True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists - ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing) - else rnConPatAndThen mk con stuff} - False -> rnConPatAndThen mk con stuff - -rnPatAndThen mk (ListPat pats _ _) - = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists - ; pats' <- rnLPatsAndThen mk pats - ; case opt_OverloadedLists of - True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName - ; return (ListPat pats' placeHolderType - (Just (placeHolderType, to_list_name)))} - False -> return (ListPat pats' placeHolderType Nothing) } - -rnPatAndThen mk (PArrPat pats _) - = do { pats' <- rnLPatsAndThen mk pats - ; return (PArrPat pats' placeHolderType) } - -rnPatAndThen mk (TuplePat pats boxed _) - = do { liftCps $ checkTupSize (length pats) - ; pats' <- rnLPatsAndThen mk pats - ; return (TuplePat pats' boxed []) } - -rnPatAndThen mk (SumPat pat alt arity _) - = do { pat <- rnLPatAndThen mk pat - ; return (SumPat pat alt arity PlaceHolder) - } - --- If a splice has been run already, just rename the result. -rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat))) - = SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat - -rnPatAndThen mk (SplicePat splice) - = do { eith <- liftCpsFV $ rnSplicePat splice - ; case eith of -- See Note [rnSplicePat] in RnSplice - Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed - Right already_renamed -> return already_renamed } - -rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat) - - --------------------- -rnConPatAndThen :: NameMaker - -> Located RdrName -- the constructor - -> HsConPatDetails RdrName - -> CpsRn (Pat Name) - -rnConPatAndThen mk con (PrefixCon pats) - = do { con' <- lookupConCps con - ; pats' <- rnLPatsAndThen mk pats - ; return (ConPatIn con' (PrefixCon pats')) } - -rnConPatAndThen mk con (InfixCon pat1 pat2) - = do { con' <- lookupConCps con - ; pat1' <- rnLPatAndThen mk pat1 - ; pat2' <- rnLPatAndThen mk pat2 - ; fixity <- liftCps $ lookupFixityRn (unLoc con') - ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' } - -rnConPatAndThen mk con (RecCon rpats) - = do { con' <- lookupConCps con - ; rpats' <- rnHsRecPatsAndThen mk con' rpats - ; return (ConPatIn con' (RecCon rpats')) } - --------------------- -rnHsRecPatsAndThen :: NameMaker - -> Located Name -- Constructor - -> HsRecFields RdrName (LPat RdrName) - -> CpsRn (HsRecFields Name (LPat Name)) -rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) - = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat - hs_rec_fields - ; flds' <- mapM rn_field (flds `zip` [1..]) - ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } - where - mkVarPat l n = VarPat (L l n) - rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') - (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldArg = arg' })) } - - -- Suppress unused-match reporting for fields introduced by ".." - nested_mk Nothing mk _ = mk - nested_mk (Just _) mk@(LetMk {}) _ = mk - nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n)) - -{- -************************************************************************ -* * - Record fields -* * -************************************************************************ --} - -data HsRecFieldContext - = HsRecFieldCon Name - | HsRecFieldPat Name - | HsRecFieldUpd - -rnHsRecFields - :: forall arg. - HsRecFieldContext - -> (SrcSpan -> RdrName -> arg) - -- When punning, use this to build a new field - -> HsRecFields RdrName (Located arg) - -> RnM ([LHsRecField Name (Located arg)], FreeVars) - --- This surprisingly complicated pass --- a) looks up the field name (possibly using disambiguation) --- b) fills in puns and dot-dot stuff --- When we we've finished, we've renamed the LHS, but not the RHS, --- of each x=e binding --- --- This is used for record construction and pattern-matching, but not updates. - -rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) - = do { pun_ok <- xoptM LangExt.RecordPuns - ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields - ; parent <- check_disambiguation disambig_ok mb_con - ; flds1 <- mapM (rn_fld pun_ok parent) flds - ; mapM_ (addErr . dupFieldErr ctxt) dup_flds - ; dotdot_flds <- rn_dotdot dotdot mb_con flds1 - ; let all_flds | null dotdot_flds = flds1 - | otherwise = flds1 ++ dotdot_flds - ; return (all_flds, mkFVs (getFieldIds all_flds)) } - where - mb_con = case ctxt of - HsRecFieldCon con | not (isUnboundName con) -> Just con - HsRecFieldPat con | not (isUnboundName con) -> Just con - _ {- update or isUnboundName con -} -> Nothing - -- The unbound name test is because if the constructor - -- isn't in scope the constructor lookup will add an error - -- add an error, but still return an unbound name. - -- We don't want that to screw up the dot-dot fill-in stuff. - - doc = case mb_con of - Nothing -> text "constructor field name" - Just con -> text "field of constructor" <+> quotes (ppr con) - - rn_fld :: Bool -> Maybe Name -> LHsRecField RdrName (Located arg) - -> RnM (LHsRecField Name (Located arg)) - rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl - = L loc (FieldOcc (L ll lbl) _) - , hsRecFieldArg = arg - , hsRecPun = pun })) - = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl - ; arg' <- if pun - then do { checkErr pun_ok (badPun (L loc lbl)) - -- Discard any module qualifier (#11662) - ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (mk_arg loc arg_rdr)) } - else return arg - ; return (L l (HsRecField { hsRecFieldLbl - = L loc (FieldOcc (L ll lbl) sel) - , hsRecFieldArg = arg' - , hsRecPun = pun })) } - - rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat - -> Maybe Name -- The constructor (Nothing for an - -- out of scope constructor) - -> [LHsRecField Name (Located arg)] -- Explicit fields - -> RnM [LHsRecField Name (Located arg)] -- Filled in .. fields - rn_dotdot Nothing _mb_con _flds -- No ".." at all - = return [] - rn_dotdot (Just {}) Nothing _flds -- Constructor out of scope - = return [] - rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match - = ASSERT( n == length flds ) - do { loc <- getSrcSpanM -- Rather approximate - ; dd_flag <- xoptM LangExt.RecordWildCards - ; checkErr dd_flag (needFlagDotDot ctxt) - ; (rdr_env, lcl_env) <- getRdrEnvs - ; con_fields <- lookupConstructorFields con - ; when (null con_fields) (addErr (badDotDotCon con)) - ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds) - - -- For constructor uses (but not patterns) - -- the arg should be in scope locally; - -- i.e. not top level or imported - -- Eg. data R = R { x,y :: Int } - -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} - arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env - - (dot_dot_fields, dot_dot_gres) - = unzip [ (fl, gre) - | fl <- con_fields - , let lbl = mkVarOccFS (flLabel fl) - , not (lbl `elemOccSet` present_flds) - , Just gre <- [lookupGRE_FieldLabel rdr_env fl] - -- Check selector is in scope - , case ctxt of - HsRecFieldCon {} -> arg_in_scope lbl - _other -> True ] - - ; addUsedGREs dot_dot_gres - ; return [ L loc (HsRecField - { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel) - , hsRecFieldArg = L loc (mk_arg loc arg_rdr) - , hsRecPun = False }) - | fl <- dot_dot_fields - , let sel = flSelector fl - , let arg_rdr = mkVarUnqual (flLabel fl) ] } - - check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name) - -- When disambiguation is on, return name of parent tycon. - check_disambiguation disambig_ok mb_con - | disambig_ok, Just con <- mb_con - = do { env <- getGlobalRdrEnv; return (find_tycon env con) } - | otherwise = return Nothing - - find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Maybe Name {- TyCon -} - -- Return the parent *type constructor* of the data constructor - -- (that is, the parent of the data constructor), - -- or 'Nothing' if it is a pattern synonym or not in scope. - -- That's the parent to use for looking up record fields. - find_tycon env con_name - | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con_name - = Just (tyConName (dataConTyCon dc)) - -- Special case for [], which is built-in syntax - -- and not in the GlobalRdrEnv (Trac #8448) - - | Just gre <- lookupGRE_Name env con_name - = case gre_par gre of - ParentIs p -> Just p - _ -> Nothing -- Can happen if the con_name - -- is for a pattern synonym - - | otherwise = Nothing - -- Data constructor not lexically in scope at all - -- See Note [Disambiguation and Template Haskell] - - dup_flds :: [[RdrName]] - -- Each list represents a RdrName that occurred more than once - -- (the list contains all occurrences) - -- Each list in dup_fields is non-empty - (_, dup_flds) = removeDups compare (getFieldLbls flds) - - -{- Note [Disambiguation and Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #12130) - module Foo where - import M - b = $(funny) - - module M(funny) where - data T = MkT { x :: Int } - funny :: Q Exp - funny = [| MkT { x = 3 } |] - -When we splice, neither T nor MkT are lexically in scope, so find_tycon will -fail. But there is no need for disambiguation anyway, so we just return Nothing --} - -rnHsRecUpdFields - :: [LHsRecUpdField RdrName] - -> RnM ([LHsRecUpdField Name], FreeVars) -rnHsRecUpdFields flds - = do { pun_ok <- xoptM LangExt.RecordPuns - ; overload_ok <- xoptM LangExt.DuplicateRecordFields - ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds - ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds - - -- Check for an empty record update e {} - -- NB: don't complain about e { .. }, because rn_dotdot has done that already - ; when (null flds) $ addErr emptyUpdateErr - - ; return (flds1, plusFVs fvss) } - where - doc = text "constructor field name" - - rn_fld :: Bool -> Bool -> LHsRecUpdField RdrName -> RnM (LHsRecUpdField Name, FreeVars) - rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f - , hsRecFieldArg = arg - , hsRecPun = pun })) - = do { let lbl = rdrNameAmbiguousFieldOcc f - ; sel <- setSrcSpan loc $ - -- Defer renaming of overloaded fields to the typechecker - -- See Note [Disambiguating record fields] in TcExpr - if overload_ok - then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl - ; case mb of - Nothing -> do { addErr (unknownSubordinateErr doc lbl) - ; return (Right []) } - Just r -> return r } - else fmap Left $ lookupGlobalOccRn lbl - ; arg' <- if pun - then do { checkErr pun_ok (badPun (L loc lbl)) - -- Discard any module qualifier (#11662) - ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (HsVar (L loc arg_rdr))) } - else return arg - ; (arg'', fvs) <- rnLExpr arg' - - ; let fvs' = case sel of - Left sel_name -> fvs `addOneFV` sel_name - Right [FieldOcc _ sel_name] -> fvs `addOneFV` sel_name - Right _ -> fvs - lbl' = case sel of - Left sel_name -> - L loc (Unambiguous (L loc lbl) sel_name) - Right [FieldOcc lbl sel_name] -> - L loc (Unambiguous lbl sel_name) - Right _ -> L loc (Ambiguous (L loc lbl) PlaceHolder) - - ; return (L l (HsRecField { hsRecFieldLbl = lbl' - , hsRecFieldArg = arg'' - , hsRecPun = pun }), fvs') } - - dup_flds :: [[RdrName]] - -- Each list represents a RdrName that occurred more than once - -- (the list contains all occurrences) - -- Each list in dup_fields is non-empty - (_, dup_flds) = removeDups compare (getFieldUpdLbls flds) - - - -getFieldIds :: [LHsRecField Name arg] -> [Name] -getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds - -getFieldLbls :: [LHsRecField id arg] -> [RdrName] -getFieldLbls flds - = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds - -getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName] -getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds - -needFlagDotDot :: HsRecFieldContext -> SDoc -needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt, - text "Use RecordWildCards to permit this"] - -badDotDotCon :: Name -> SDoc -badDotDotCon con - = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) - , nest 2 (text "The constructor has no labelled fields") ] - -emptyUpdateErr :: SDoc -emptyUpdateErr = text "Empty record update" - -badPun :: Located RdrName -> SDoc -badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld), - text "Use NamedFieldPuns to permit this"] - -dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc -dupFieldErr ctxt dups - = hsep [text "duplicate field name", - quotes (ppr (head dups)), - text "in record", pprRFC ctxt] - -pprRFC :: HsRecFieldContext -> SDoc -pprRFC (HsRecFieldCon {}) = text "construction" -pprRFC (HsRecFieldPat {}) = text "pattern" -pprRFC (HsRecFieldUpd {}) = text "update" - -{- -************************************************************************ -* * -\subsubsection{Literals} -* * -************************************************************************ - -When literals occur we have to make sure -that the types and classes they involve -are made available. --} - -rnLit :: HsLit -> RnM () -rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c) -rnLit _ = return () - --- Turn a Fractional-looking literal which happens to be an integer into an --- Integer-looking literal. -generalizeOverLitVal :: OverLitVal -> OverLitVal -generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_value=val})) - | denominator val == 1 = HsIntegral (SourceText src) (numerator val) -generalizeOverLitVal lit = lit - -rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars) -rnOverLit origLit - = do { opt_NumDecimals <- xoptM LangExt.NumDecimals - ; let { lit@(OverLit {ol_val=val}) - | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)} - | otherwise = origLit - } - ; let std_name = hsOverLitName val - ; (SyntaxExpr { syn_expr = from_thing_name }, fvs) - <- lookupSyntaxName std_name - ; let rebindable = case from_thing_name of - HsVar (L _ v) -> v /= std_name - _ -> panic "rnOverLit" - ; return (lit { ol_witness = from_thing_name - , ol_rebindable = rebindable - , ol_type = placeHolderType }, fvs) } - -{- -************************************************************************ -* * -\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 RdrName -> SDoc -badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat, - text "Use ViewPatterns to enable view patterns"] diff --git a/rename/RnSource.hs b/rename/RnSource.hs deleted file mode 100644 --- a/rename/RnSource.hs +++ /dev/null @@ -1,2285 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnSource]{Main pass of renamer} --} - -{-# LANGUAGE CPP, ScopedTypeVariables #-} - -module RnSource ( - rnSrcDecls, addTcgDUs, findSplice - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} RnExpr( rnLExpr ) -import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls ) - -import HsSyn -import FieldLabel -import RdrName -import RnTypes -import RnBinds -import RnEnv -import RnNames -import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) -import TcAnnotations ( annCtxt ) -import TcRnMonad - -import ForeignCall ( CCallTarget(..) ) -import Module -import HscTypes ( Warnings(..), plusWarns ) -import Class ( FunDep ) -import PrelNames ( applicativeClassName, pureAName, thenAName - , monadClassName, returnMName, thenMName - , monadFailClassName, failMName, failMName_preMFP - , semigroupClassName, sappendName - , monoidClassName, mappendName - ) -import Name -import NameSet -import NameEnv -import Avail -import Outputable -import Bag -import BasicTypes ( DerivStrategy, RuleName, pprRuleName ) -import FastString -import SrcLoc -import DynFlags -import Util ( debugIsOn, lengthExceeds, partitionWith ) -import HscTypes ( HscEnv, hsc_dflags ) -import ListSetOps ( findDupsEq, removeDups, equivClasses ) -import Digraph ( SCC, flattenSCC, flattenSCCs - , stronglyConnCompFromEdgedVerticesUniq ) -import UniqSet -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Control.Arrow ( first ) -import Data.List ( sortBy, mapAccumL ) -import Data.Maybe ( isJust ) -import qualified Data.Set as Set ( difference, fromList, toList, null ) - -{- | @rnSourceDecl@ "renames" declarations. -It simultaneously performs dependency analysis and precedence parsing. -It also does the following error checks: - -* Checks that tyvars are used properly. This includes checking - for undefined tyvars, and tyvars in contexts that are ambiguous. - (Some of this checking has now been moved to module @TcMonoType@, - since we don't have functional dependency information at this point.) - -* Checks that all variable occurrences are defined. - -* Checks the @(..)@ etc constraints in the export list. - -Brings the binders of the group into scope in the appropriate places; -does NOT assume that anything is in scope already --} -rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) --- Rename a top-level HsGroup; used for normal source files *and* hs-boot files -rnSrcDecls group@(HsGroup { hs_valds = val_decls, - hs_splcds = splice_decls, - hs_tyclds = tycl_decls, - hs_derivds = deriv_decls, - hs_fixds = fix_decls, - hs_warnds = warn_decls, - hs_annds = ann_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls, - hs_docs = docs }) - = do { - -- (A) Process the fixity declarations, creating a mapping from - -- FastStrings to FixItems. - -- Also checks for duplicates. - local_fix_env <- makeMiniFixityEnv fix_decls ; - - -- (B) Bring top level binders (and their fixities) into scope, - -- *except* for the value bindings, which get done in step (D) - -- with collectHsIdBinders. However *do* include - -- - -- * Class ops, data constructors, and record fields, - -- because they do not have value declarations. - -- Aso step (C) depends on datacons and record fields - -- - -- * For hs-boot files, include the value signatures - -- Again, they have no value declarations - -- - (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; - - - setEnvs tc_envs $ do { - - failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations - - -- (D1) Bring pattern synonyms into scope. - -- Need to do this before (D2) because rnTopBindsLHS - -- looks up those pattern synonyms (Trac #9889) - - extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do { - - -- (D2) Rename the left-hand sides of the value bindings. - -- This depends on everything from (B) being in scope, - -- and on (C) for resolving record wild cards. - -- It uses the fixity env from (A) to bind fixities for view patterns. - new_lhs <- rnTopBindsLHS local_fix_env val_decls ; - - -- Bind the LHSes (and their fixities) in the global rdr environment - let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders - -- They are already in scope - traceRn "rnSrcDecls" (ppr id_bndrs) ; - tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; - traceRn "D2" (ppr (tcg_rdr_env (fst tc_envs))); - setEnvs tc_envs $ do { - - -- Now everything is in scope, as the remaining renaming assumes. - - -- (E) Rename type and class decls - -- (note that value LHSes need to be in scope for default methods) - -- - -- You might think that we could build proper def/use information - -- for type and class declarations, but they can be involved - -- in mutual recursion across modules, and we only do the SCC - -- analysis for them in the type checker. - -- So we content ourselves with gathering uses only; that - -- means we'll only report a declaration as unused if it isn't - -- mentioned at all. Ah well. - traceRn "Start rnTyClDecls" (ppr tycl_decls) ; - (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; - - -- (F) Rename Value declarations right-hand sides - traceRn "Start rnmono" empty ; - let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; - is_boot <- tcIsHsBootOrSig ; - (rn_val_decls, bind_dus) <- if is_boot - -- For an hs-boot, use tc_bndrs (which collects how we're renamed - -- signatures), since val_bndr_set is empty (there are no x = ... - -- bindings in an hs-boot.) - then rnTopBindsBoot tc_bndrs new_lhs - else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ; - traceRn "finish rnmono" (ppr rn_val_decls) ; - - -- (G) Rename Fixity and deprecations - - -- Rename fixity declarations and error if we try to - -- fix something from another module (duplicates were checked in (A)) - let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ; - rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ; - - -- Rename deprec decls; - -- check for duplicates and ensure that deprecated things are defined locally - -- at the moment, we don't keep these around past renaming - rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ; - - -- (H) Rename Everything else - - (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $ - rnList rnHsRuleDecls rule_decls ; - -- Inside RULES, scoped type variables are on - (rn_vect_decls, src_fvs3) <- rnList rnHsVectDecl vect_decls ; - (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ; - (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ; - (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ; - (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ; - (rn_splice_decls, src_fvs8) <- rnList rnSpliceDecl splice_decls ; - -- Haddock docs; no free vars - rn_docs <- mapM (wrapLocM rnDocDecl) docs ; - - last_tcg_env <- getGblEnv ; - -- (I) Compute the results and return - let {rn_group = HsGroup { hs_valds = rn_val_decls, - hs_splcds = rn_splice_decls, - hs_tyclds = rn_tycl_decls, - hs_derivds = rn_deriv_decls, - hs_fixds = rn_fix_decls, - hs_warnds = [], -- warns are returned in the tcg_env - -- (see below) not in the HsGroup - hs_fords = rn_foreign_decls, - hs_annds = rn_ann_decls, - hs_defds = rn_default_decls, - hs_ruleds = rn_rule_decls, - hs_vects = rn_vect_decls, - hs_docs = rn_docs } ; - - tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; - other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, src_fvs5, - src_fvs6, src_fvs7, src_fvs8] ; - -- It is tiresome to gather the binders from type and class decls - - src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ; - -- Instance decls may have occurrences of things bound in bind_dus - -- so we must put other_fvs last - - final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) - in -- we return the deprecs in the env, not in the HsGroup above - tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; - } ; - traceRn "last" (ppr (tcg_rdr_env final_tcg_env)) ; - traceRn "finish rnSrc" (ppr rn_group) ; - traceRn "finish Dus" (ppr src_dus ) ; - return (final_tcg_env, rn_group) - }}}} - -addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv --- This function could be defined lower down in the module hierarchy, --- but there doesn't seem anywhere very logical to put it. -addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } - -rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars) -rnList f xs = mapFvRn (wrapLocFstM f) xs - -{- -********************************************************* -* * - HsDoc stuff -* * -********************************************************* --} - -rnDocDecl :: DocDecl -> RnM DocDecl -rnDocDecl (DocCommentNext doc) = do - rn_doc <- rnHsDoc doc - return (DocCommentNext rn_doc) -rnDocDecl (DocCommentPrev doc) = do - rn_doc <- rnHsDoc doc - return (DocCommentPrev rn_doc) -rnDocDecl (DocCommentNamed str doc) = do - rn_doc <- rnHsDoc doc - return (DocCommentNamed str rn_doc) -rnDocDecl (DocGroup lev doc) = do - rn_doc <- rnHsDoc doc - return (DocGroup lev rn_doc) - -{- -********************************************************* -* * - Source-code fixity declarations -* * -********************************************************* --} - -rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name] --- Rename the fixity decls, so we can put --- the renamed decls in the renamed syntax tree --- Errors if the thing being fixed is not defined locally. --- --- The returned FixitySigs are not actually used for anything, --- except perhaps the GHCi API -rnSrcFixityDecls bndr_set fix_decls - = do fix_decls <- mapM rn_decl fix_decls - return (concat fix_decls) - where - sig_ctxt = TopSigCtxt bndr_set - - rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name] - -- GHC extension: look up both the tycon and data con - -- for con-like things; hence returning a list - -- If neither are in scope, report an error; otherwise - -- return a fixity sig for each (slightly odd) - rn_decl (L loc (FixitySig fnames fixity)) - = do names <- mapM lookup_one fnames - return [ L loc (FixitySig name fixity) - | name <- names ] - - lookup_one :: Located RdrName -> RnM [Located Name] - lookup_one (L name_loc rdr_name) - = setSrcSpan name_loc $ - -- this lookup will fail if the definition isn't local - do names <- lookupLocalTcNames sig_ctxt what rdr_name - return [ L name_loc name | (_, name) <- names ] - what = text "fixity signature" - -{- -********************************************************* -* * - Source-code deprecations declarations -* * -********************************************************* - -Check that the deprecated names are defined, are defined locally, and -that there are no duplicate deprecations. - -It's only imported deprecations, dealt with in RnIfaces, that we -gather them together. --} - --- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings -rnSrcWarnDecls _ [] - = return NoWarnings - -rnSrcWarnDecls bndr_set decls' - = do { -- check for duplicates - ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups - in addErrAt loc (dupWarnDecl lrdr' rdr)) - warn_rdr_dups - ; pairs_s <- mapM (addLocM rn_deprec) decls - ; return (WarnSome ((concat pairs_s))) } - where - decls = concatMap (\(L _ d) -> wd_warnings d) decls' - - sig_ctxt = TopSigCtxt bndr_set - - rn_deprec (Warning rdr_names txt) - -- ensures that the names are defined locally - = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) - rdr_names - ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } - - what = text "deprecation" - - warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns) - decls - -findDupRdrNames :: [Located RdrName] -> [[Located RdrName]] -findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) - --- look for duplicates among the OccNames; --- we check that the names are defined above --- invt: the lists returned by findDupsEq always have at least two elements - -dupWarnDecl :: Located RdrName -> RdrName -> SDoc --- Located RdrName -> DeprecDecl RdrName -> SDoc -dupWarnDecl (L loc _) rdr_name - = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr loc] - -{- -********************************************************* -* * -\subsection{Annotation declarations} -* * -********************************************************* --} - -rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars) -rnAnnDecl ann@(HsAnnotation s provenance expr) - = addErrCtxt (annCtxt ann) $ - do { (provenance', provenance_fvs) <- rnAnnProvenance provenance - ; (expr', expr_fvs) <- setStage (Splice Untyped) $ - rnLExpr expr - ; return (HsAnnotation s provenance' expr', - provenance_fvs `plusFV` expr_fvs) } - -rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars) -rnAnnProvenance provenance = do - provenance' <- traverse lookupTopBndrRn provenance - return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) - -{- -********************************************************* -* * -\subsection{Default declarations} -* * -********************************************************* --} - -rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars) -rnDefaultDecl (DefaultDecl tys) - = do { (tys', fvs) <- rnLHsTypes doc_str tys - ; return (DefaultDecl tys', fvs) } - where - doc_str = DefaultDeclCtx - -{- -********************************************************* -* * -\subsection{Foreign declarations} -* * -********************************************************* --} - -rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) -rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) - = do { topEnv :: HscEnv <- getTopEnv - ; name' <- lookupLocatedTopBndrRn name - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty - - -- Mark any PackageTarget style imports as coming from the current package - ; let unitId = thisPackage $ hsc_dflags topEnv - spec' = patchForeignImport unitId spec - - ; return (ForeignImport { fd_name = name', fd_sig_ty = ty' - , fd_co = noForeignImportCoercionYet - , fd_fi = spec' }, fvs) } - -rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) - = do { name' <- lookupLocatedOccRn name - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty - ; return (ForeignExport { fd_name = name', fd_sig_ty = ty' - , fd_co = noForeignExportCoercionYet - , fd_fe = spec } - , fvs `addOneFV` unLoc name') } - -- NB: a foreign export is an *occurrence site* for name, so - -- we add it to the free-variable list. It might, for example, - -- be imported from another module - --- | For Windows DLLs we need to know what packages imported symbols are from --- to generate correct calls. Imported symbols are tagged with the current --- package, so if they get inlined across a package boundry we'll still --- know where they're from. --- -patchForeignImport :: UnitId -> ForeignImport -> ForeignImport -patchForeignImport unitId (CImport cconv safety fs spec src) - = CImport cconv safety fs (patchCImportSpec unitId spec) src - -patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec -patchCImportSpec unitId spec - = case spec of - CFunction callTarget -> CFunction $ patchCCallTarget unitId callTarget - _ -> spec - -patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget -patchCCallTarget unitId callTarget = - case callTarget of - StaticTarget src label Nothing isFun - -> StaticTarget src label (Just unitId) isFun - _ -> callTarget - -{- -********************************************************* -* * -\subsection{Instance declarations} -* * -********************************************************* --} - -rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) -rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) - = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi - ; return (TyFamInstD { tfid_inst = tfi' }, fvs) } - -rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) - = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi - ; return (DataFamInstD { dfid_inst = dfi' }, fvs) } - -rnSrcInstDecl (ClsInstD { cid_inst = cid }) - = do { (cid', fvs) <- rnClsInstDecl cid - ; return (ClsInstD { cid_inst = cid' }, fvs) } - --- | Warn about non-canonical typeclass instance declarations --- --- A "non-canonical" instance definition can occur for instances of a --- class which redundantly defines an operation its superclass --- provides as well (c.f. `return`/`pure`). In such cases, a canonical --- instance is one where the subclass inherits its method --- implementation from its superclass instance (usually the subclass --- has a default method implementation to that effect). Consequently, --- a non-canonical instance occurs when this is not the case. --- --- See also descriptions of 'checkCanonicalMonadInstances' and --- 'checkCanonicalMonoidInstances' -checkCanonicalInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM () -checkCanonicalInstances cls poly_ty mbinds = do - whenWOptM Opt_WarnNonCanonicalMonadInstances - checkCanonicalMonadInstances - - whenWOptM Opt_WarnNonCanonicalMonadFailInstances - checkCanonicalMonadFailInstances - - whenWOptM Opt_WarnNonCanonicalMonoidInstances - checkCanonicalMonoidInstances - - where - -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance - -- declarations. Specifically, the following conditions are verified: - -- - -- In 'Monad' instances declarations: - -- - -- * If 'return' is overridden it must be canonical (i.e. @return = pure@) - -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@) - -- - -- In 'Applicative' instance declarations: - -- - -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). - -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). - -- - checkCanonicalMonadInstances - | cls == applicativeClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } - | name == pureAName, isAliasMG mg == Just returnMName - -> addWarnNonCanonicalMethod1 - Opt_WarnNonCanonicalMonadInstances "pure" "return" - - | name == thenAName, isAliasMG mg == Just thenMName - -> addWarnNonCanonicalMethod1 - Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" - - _ -> return () - - | cls == monadClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } - | name == returnMName, isAliasMG mg /= Just pureAName - -> addWarnNonCanonicalMethod2 - Opt_WarnNonCanonicalMonadInstances "return" "pure" - - | name == thenMName, isAliasMG mg /= Just thenAName - -> addWarnNonCanonicalMethod2 - Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" - - _ -> return () - - | otherwise = return () - - -- | Warn about unsound/non-canonical 'Monad'/'MonadFail' instance - -- declarations. Specifically, the following conditions are verified: - -- - -- In 'Monad' instances declarations: - -- - -- * If 'fail' is overridden it must be canonical - -- (i.e. @fail = Control.Monad.Fail.fail@) - -- - -- In 'MonadFail' instance declarations: - -- - -- * Warn if 'fail' is defined backwards - -- (i.e. @fail = Control.Monad.fail@). - -- - checkCanonicalMonadFailInstances - | cls == monadFailClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } - | name == failMName, isAliasMG mg == Just failMName_preMFP - -> addWarnNonCanonicalMethod1 - Opt_WarnNonCanonicalMonadFailInstances "fail" - "Control.Monad.fail" - - _ -> return () - - | cls == monadClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } - | name == failMName_preMFP, isAliasMG mg /= Just failMName - -> addWarnNonCanonicalMethod2 - Opt_WarnNonCanonicalMonadFailInstances "fail" - "Control.Monad.Fail.fail" - _ -> return () - - | otherwise = return () - - -- | Check whether Monoid(mappend) is defined in terms of - -- Semigroup((<>)) (and not the other way round). Specifically, - -- the following conditions are verified: - -- - -- In 'Monoid' instances declarations: - -- - -- * If 'mappend' is overridden it must be canonical - -- (i.e. @mappend = (<>)@) - -- - -- In 'Semigroup' instance declarations: - -- - -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). - -- - checkCanonicalMonoidInstances - | cls == semigroupClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } - | name == sappendName, isAliasMG mg == Just mappendName - -> addWarnNonCanonicalMethod1 - Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" - - _ -> return () - - | cls == monoidClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } - | name == mappendName, isAliasMG mg /= Just sappendName - -> addWarnNonCanonicalMethod2NoDefault - Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)" - - _ -> return () - - | otherwise = return () - - -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" - -- binding, and return @Just rhsName@ if this is the case - isAliasMG :: MatchGroup Name (LHsExpr Name) -> Maybe Name - isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]} - | GRHSs [L _ (GRHS [] body)] lbinds <- grhss - , L _ EmptyLocalBinds <- lbinds - , L _ (HsVar (L _ rhsName)) <- body = Just rhsName - isAliasMG _ = Nothing - - -- got "lhs = rhs" but expected something different - addWarnNonCanonicalMethod1 flag lhs rhs = do - addWarn (Reason flag) $ vcat - [ text "Noncanonical" <+> - quotes (text (lhs ++ " = " ++ rhs)) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Move definition from" <+> - quotes (text rhs) <+> - text "to" <+> quotes (text lhs) - ] - - -- expected "lhs = rhs" but got something else - addWarnNonCanonicalMethod2 flag lhs rhs = do - addWarn (Reason flag) $ vcat - [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Either remove definition for" <+> - quotes (text lhs) <+> text "or define as" <+> - quotes (text (lhs ++ " = " ++ rhs)) - ] - - -- like above, but method has no default impl - addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do - addWarn (Reason flag) $ vcat - [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Define as" <+> - quotes (text (lhs ++ " = " ++ rhs)) - ] - - -- stolen from TcInstDcls - instDeclCtxt1 :: LHsSigType Name -> SDoc - instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - - inst_decl_ctxt :: SDoc -> SDoc - inst_decl_ctxt doc = hang (text "in the instance declaration for") - 2 (quotes doc <> text ".") - - -rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars) -rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds - , cid_sigs = uprags, cid_tyfam_insts = ats - , cid_overlap_mode = oflag - , cid_datafam_insts = adts }) - = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty - ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' - ; let cls = case hsTyGetAppHead_maybe head_ty' of - Nothing -> mkUnboundName (mkTcOccFS (fsLit "")) - Just (L _ cls, _) -> cls - -- rnLHsInstType has added an error message - -- if hsTyGetAppHead_maybe fails - - -- Rename the bindings - -- The typechecker (not the renamer) checks that all - -- the bindings are for the right class - -- (Slightly strangely) when scoped type variables are on, the - -- forall-d tyvars scope over the method bindings too - ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags - - ; checkCanonicalInstances cls inst_ty' mbinds' - - -- Rename the associated types, and type signatures - -- Both need to have the instance type variables in scope - ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names) - ; ((ats', adts'), more_fvs) - <- extendTyVarEnvFVRn ktv_names $ - do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats - ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts - ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } - - ; let all_fvs = meth_fvs `plusFV` more_fvs - `plusFV` inst_fvs - ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds' - , cid_sigs = uprags', cid_tyfam_insts = ats' - , cid_overlap_mode = oflag - , cid_datafam_insts = adts' }, - all_fvs) } - -- We return the renamed associated data type declarations so - -- that they can be entered into the list of type declarations - -- for the binding group, but we also keep a copy in the instance. - -- The latter is needed for well-formedness checks in the type - -- checker (eg, to ensure that all ATs of the instance actually - -- receive a declaration). - -- NB: Even the copies in the instance declaration carry copies of - -- the instance context after renaming. This is a bit - -- strange, but should not matter (and it would be more work - -- to remove the context). - -rnFamInstDecl :: HsDocContext - -> Maybe (Name, [Name]) -- Nothing => not associated - -- Just (cls,tvs) => associated, - -- and gives class and tyvars of the - -- parent instance delc - -> Located RdrName - -> HsTyPats RdrName - -> rhs - -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) - -> RnM (Located Name, HsTyPats Name, rhs', FreeVars) -rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload - = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon - ; let loc = case pats of - [] -> pprPanic "rnFamInstDecl" (ppr tycon) - (L loc _ : []) -> loc - (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps)) - - ; pat_kity_vars_with_dups <- extractHsTysRdrTyVarsDups pats - -- Use the "...Dups" form because it's needed - -- below to report unsed binder on the LHS - ; var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) $ - freeKiTyVarsAllVars $ - rmDupsInRdrTyVars pat_kity_vars_with_dups - - -- All the free vars of the family patterns - -- with a sensible binding location - ; ((pats', payload'), fvs) - <- bindLocalNamesFV var_names $ - do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats - ; (payload', rhs_fvs) <- rnPayload doc payload - - -- Report unused binders on the LHS - -- See Note [Unused type variables in family instances] - ; let groups :: [[Located RdrName]] - groups = equivClasses cmpLocated $ - freeKiTyVarsAllVars pat_kity_vars_with_dups - ; tv_nms_dups <- mapM (lookupOccRn . unLoc) $ - [ tv | (tv:_:_) <- groups ] - -- Add to the used variables - -- a) any variables that appear *more than once* on the LHS - -- e.g. F a Int a = Bool - -- b) for associated instances, the variables - -- of the instance decl. See - -- Note [Unused type variables in family instances] - ; let tv_nms_used = extendNameSetList rhs_fvs $ - inst_tvs ++ tv_nms_dups - inst_tvs = case mb_cls of - Nothing -> [] - Just (_, inst_tvs) -> inst_tvs - ; warnUnusedTypePatterns var_names tv_nms_used - - -- See Note [Renaming associated types] - ; let bad_tvs = case mb_cls of - Nothing -> [] - Just (_,cls_tkvs) -> filter is_bad cls_tkvs - var_name_set = mkNameSet var_names - - is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs - && not (cls_tkv `elemNameSet` var_name_set) - ; unless (null bad_tvs) (badAssocRhs bad_tvs) - - ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) } - - ; let anon_wcs = concatMap collectAnonWildCards pats' - all_ibs = anon_wcs ++ var_names - -- all_ibs: include anonymous wildcards in the implicit - -- binders In a type pattern they behave just like any - -- other type variable except for being anoymous. See - -- Note [Wildcards in family instances] - all_fvs = fvs `addOneFV` unLoc tycon' - - ; return (tycon', - HsIB { hsib_body = pats' - , hsib_vars = all_ibs - , hsib_closed = True }, - payload', - all_fvs) } - -- type instance => use, hence addOneFV - -rnTyFamInstDecl :: Maybe (Name, [Name]) - -> TyFamInstDecl RdrName - -> RnM (TyFamInstDecl Name, FreeVars) -rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn }) - = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn - ; return (TyFamInstDecl { tfid_eqn = L loc eqn' - , tfid_fvs = fvs }, fvs) } - -rnTyFamInstEqn :: Maybe (Name, [Name]) - -> TyFamInstEqn RdrName - -> RnM (TyFamInstEqn Name, FreeVars) -rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon - , tfe_pats = pats - , tfe_fixity = fixity - , tfe_rhs = rhs }) - = do { (tycon', pats', rhs', fvs) <- - rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn - ; return (TyFamEqn { tfe_tycon = tycon' - , tfe_pats = pats' - , tfe_fixity = fixity - , tfe_rhs = rhs' }, fvs) } - -rnTyFamDefltEqn :: Name - -> TyFamDefltEqn RdrName - -> RnM (TyFamDefltEqn Name, FreeVars) -rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon - , tfe_pats = tyvars - , tfe_fixity = fixity - , tfe_rhs = rhs }) - = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ -> - do { tycon' <- lookupFamInstName (Just cls) tycon - ; (rhs', fvs) <- rnLHsType ctx rhs - ; return (TyFamEqn { tfe_tycon = tycon' - , tfe_pats = tyvars' - , tfe_fixity = fixity - , tfe_rhs = rhs' }, fvs) } - where - ctx = TyFamilyCtx tycon - -rnDataFamInstDecl :: Maybe (Name, [Name]) - -> DataFamInstDecl RdrName - -> RnM (DataFamInstDecl Name, FreeVars) -rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon - , dfid_pats = pats - , dfid_fixity = fixity - , dfid_defn = defn }) - = do { (tycon', pats', (defn', _), fvs) <- - rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn - ; return (DataFamInstDecl { dfid_tycon = tycon' - , dfid_pats = pats' - , dfid_fixity = fixity - , dfid_defn = defn' - , dfid_fvs = fvs }, fvs) } - --- Renaming of the associated types in instances. - --- Rename associated type family decl in class -rnATDecls :: Name -- Class - -> [LFamilyDecl RdrName] - -> RnM ([LFamilyDecl Name], FreeVars) -rnATDecls cls at_decls - = rnList (rnFamDecl (Just cls)) at_decls - -rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames - decl RdrName -> -- an instance. rnTyFamInstDecl - RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl - -> Name -- Class - -> [Name] - -> [Located (decl RdrName)] - -> RnM ([Located (decl Name)], FreeVars) --- Used for data and type family defaults in a class decl --- and the family instance declarations in an instance --- --- NB: We allow duplicate associated-type decls; --- See Note [Associated type instances] in TcInstDcls -rnATInstDecls rnFun cls tv_ns at_insts - = rnList (rnFun (Just (cls, tv_ns))) at_insts - -- See Note [Renaming associated types] - -{- Note [Wildcards in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Wild cards can be used in type/data family instance declarations to indicate -that the name of a type variable doesn't matter. Each wild card will be -replaced with a new unique type variable. For instance: - - type family F a b :: * - type instance F Int _ = Int - -is the same as - - type family F a b :: * - type instance F Int b = Int - -This is implemented as follows: during renaming anonymous wild cards -'_' are given freshly generated names. These names are collected after -renaming (rnFamInstDecl) and used to make new type variables during -type checking (tc_fam_ty_pats). One should not confuse these wild -cards with the ones from partial type signatures. The latter generate -fresh meta-variables whereas the former generate fresh skolems. - -Note [Unused type variables in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the flag -fwarn-unused-type-patterns is on, the compiler reports -warnings about unused type variables in type-family instances. A -tpye variable is considered used (i.e. cannot be turned into a wildcard) -when - - * it occurs on the RHS of the family instance - e.g. type instance F a b = a -- a is used on the RHS - - * it occurs multiple times in the patterns on the LHS - e.g. type instance F a a = Int -- a appears more than once on LHS - - * it is one of the instance-decl variables, for associated types - e.g. instance C (a,b) where - type T (a,b) = a - Here the type pattern in the type instance must be the same as that - for the class instance, so - type T (a,_) = a - would be rejected. So we should not complain about an unused variable b - -As usual, the warnings are not reported for for type variables with names -beginning with an underscore. - -Extra-constraints wild cards are not supported in type/data family -instance declarations. - -Relevant tickets: #3699, #10586, #10982 and #11451. - -Note [Renaming associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Check that the RHS of the decl mentions only type variables -bound on the LHS. For example, this is not ok - class C a b where - type F a x :: * - instance C (p,q) r where - type F (p,q) x = (x, r) -- BAD: mentions 'r' -c.f. Trac #5515 - -The same thing applies to kind variables, of course (Trac #7938, #9574): - class Funct f where - type Codomain f :: * - instance Funct ('KProxy :: KProxy o) where - type Codomain 'KProxy = NatTr (Proxy :: o -> *) -Here 'o' is mentioned on the RHS of the Codomain function, but -not on the LHS. - -All this applies only for *instance* declarations. In *class* -declarations there is no RHS to worry about, and the class variables -can all be in scope (Trac #5862): - class Category (x :: k -> k -> *) where - type Ob x :: k -> Constraint - id :: Ob x a => x a a - (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c -Here 'k' is in scope in the kind signature, just like 'x'. --} - - -{- -********************************************************* -* * -\subsection{Stand-alone deriving declarations} -* * -********************************************************* --} - -rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) -rnSrcDerivDecl (DerivDecl ty deriv_strat overlap) - = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving - ; deriv_strats_ok <- xoptM LangExt.DerivingStrategies - ; unless standalone_deriv_ok (addErr standaloneDerivErr) - ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $ - illegalDerivStrategyErr $ fmap unLoc deriv_strat - ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty - ; return (DerivDecl ty' deriv_strat overlap, fvs) } - -standaloneDerivErr :: SDoc -standaloneDerivErr - = hang (text "Illegal standalone deriving declaration") - 2 (text "Use StandaloneDeriving to enable this extension") - -{- -********************************************************* -* * -\subsection{Rules} -* * -********************************************************* --} - -rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars) -rnHsRuleDecls (HsRules src rules) - = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules - ; return (HsRules src rn_rules,fvs) } - -rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) -rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) - = do { let rdr_names_w_loc = map get_var vars - ; checkDupRdrNames rdr_names_w_loc - ; checkShadowedRdrNames rdr_names_w_loc - ; names <- newLocalBndrsRn rdr_names_w_loc - ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' -> - do { (lhs', fv_lhs') <- rnLExpr lhs - ; (rhs', fv_rhs') <- rnLExpr rhs - ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs' - ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', - fv_lhs' `plusFV` fv_rhs') } } - where - get_var (L _ (RuleBndrSig v _)) = v - get_var (L _ (RuleBndr v)) = v - -bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name] - -> ([LRuleBndr Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindHsRuleVars rule_name vars names thing_inside - = go vars names $ \ vars' -> - bindLocalNamesFV names (thing_inside vars') - where - doc = RuleCtx rule_name - - go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside - = go vars ns $ \ vars' -> - thing_inside (L l (RuleBndr (L loc n)) : vars') - - go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside - = rnHsSigWcTypeScoped doc bsig $ \ bsig' -> - go vars ns $ \ vars' -> - thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars') - - go [] [] thing_inside = thing_inside [] - go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) - -{- -Note [Rule LHS validity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Check the shape of a transformation rule LHS. Currently we only allow -LHSs of the form @(f e1 .. en)@, where @f@ is not one of the -@forall@'d variables. - -We used restrict the form of the 'ei' to prevent you writing rules -with LHSs with a complicated desugaring (and hence unlikely to match); -(e.g. a case expression is not allowed: too elaborate.) - -But there are legitimate non-trivial args ei, like sections and -lambdas. So it seems simmpler not to check at all, and that is why -check_e is commented out. --} - -checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM () -checkValidRule rule_name ids lhs' fv_lhs' - = do { -- Check for the form of the LHS - case (validRuleLhs ids lhs') of - Nothing -> return () - Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) - - -- Check that LHS vars are all bound - ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] - ; mapM_ (addErr . badRuleVar rule_name) bad_vars } - -validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) --- Nothing => OK --- Just e => Not ok, and e is the offending sub-expression -validRuleLhs foralls lhs - = checkl lhs - where - checkl (L _ e) = check e - - check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 - check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2 - check (HsAppType e _) = checkl e - check (HsVar (L _ v)) | v `notElem` foralls = Nothing - check other = Just other -- Failure - - -- Check an argument - checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking] - -{- Commented out; see Note [Rule LHS validity checking] above - check_e (HsVar v) = Nothing - check_e (HsPar e) = checkl_e e - check_e (HsLit e) = Nothing - check_e (HsOverLit e) = Nothing - - check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 - check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 - check_e (NegApp e _) = checkl_e e - check_e (ExplicitList _ es) = checkl_es es - check_e other = Just other -- Fails - - checkl_es es = foldr (mplus . checkl_e) Nothing es --} - -badRuleVar :: FastString -> Name -> SDoc -badRuleVar name var - = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, - text "Forall'd variable" <+> quotes (ppr var) <+> - text "does not appear on left hand side"] - -badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc -badRuleLhsErr name lhs bad_e - = sep [text "Rule" <+> pprRuleName name <> colon, - nest 4 (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 -> text "Not in scope:" <+> ppr uv - _ -> text "Illegal expression:" <+> ppr bad_e - -{- -********************************************************* -* * -\subsection{Vectorisation declarations} -* * -********************************************************* --} - -rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars) --- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly --- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser. -rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _))) - = do { var' <- lookupLocatedOccRn var - ; (rhs', fv_rhs) <- rnLExpr rhs - ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var') - } -rnHsVectDecl (HsVect _ _var _rhs) - = failWith $ vcat - [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma" - , text "must be an identifier" - ] -rnHsVectDecl (HsNoVect s var) - = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names - ; return (HsNoVect s var', unitFV (unLoc var')) - } -rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing) - = do { tycon' <- lookupLocatedOccRn tycon - ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon')) - } -rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon)) - = do { tycon' <- lookupLocatedOccRn tycon - ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon - ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon') - , mkFVs [unLoc tycon', unLoc rhs_tycon']) - } -rnHsVectDecl (HsVectTypeOut _ _ _) - = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'" -rnHsVectDecl (HsVectClassIn s cls) - = do { cls' <- lookupLocatedOccRn cls - ; return (HsVectClassIn s cls', unitFV (unLoc cls')) - } -rnHsVectDecl (HsVectClassOut _) - = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" -rnHsVectDecl (HsVectInstIn instTy) - = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy - ; return (HsVectInstIn instTy', fvs) - } -rnHsVectDecl (HsVectInstOut _) - = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'" - -{- ************************************************************** - * * - Renaming type, class, instance and role declarations -* * -***************************************************************** - -@rnTyDecl@ uses the `global name function' to create a new type -declaration in which local names have been replaced by their original -names, reporting any unknown names. - -Renaming type variables is a pain. Because they now contain uniques, -it is necessary to pass in an association list which maps a parsed -tyvar to its @Name@ representation. -In some cases (type signatures of values), -it is even necessary to go over the type first -in order to get the set of tyvars used by it, make an assoc list, -and then go over it again to rename the tyvars! -However, we can also do some scoping checks at the same time. - -Note [Dependency analysis of type, class, and instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A TyClGroup represents a strongly connected components of -type/class/instance decls, together with the role annotations for the -type/class declarations. The renamer uses strongly connected -comoponent analysis to build these groups. We do this for a number of -reasons: - -* Improve kind error messages. Consider - - data T f a = MkT f a - data S f a = MkS f (T f a) - - This has a kind error, but the error message is better if you - check T first, (fixing its kind) and *then* S. If you do kind - inference together, you might get an error reported in S, which - is jolly confusing. See Trac #4875 - - -* Increase kind polymorphism. See TcTyClsDecls - Note [Grouping of type and class declarations] - -Why do the instance declarations participate? At least two reasons - -* Consider (Trac #11348) - - type family F a - type instance F Int = Bool - - data R = MkR (F Int) - - type Foo = 'MkR 'True - - For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't - know that unless we've looked at the type instance declaration for F - before kind-checking Foo. - -* Another example is this (Trac #3990). - - data family Complex a - data instance Complex Double = CD {-# UNPACK #-} !Double - {-# UNPACK #-} !Double - - data T = T {-# UNPACK #-} !(Complex Double) - - Here, to generate the right kind of unpacked implementation for T, - we must have access to the 'data instance' declaration. - -* Things become more complicated when we introduce transitive - dependencies through imported definitions, like in this scenario: - - A.hs - type family Closed (t :: Type) :: Type where - Closed t = Open t - - type family Open (t :: Type) :: Type - - B.hs - data Q where - Q :: Closed Bool -> Q - - type instance Open Int = Bool - - type S = 'Q 'True - - Somehow, we must ensure that the instance Open Int = Bool is checked before - the type synonym S. While we know that S depends upon 'Q depends upon Closed, - we have no idea that Closed depends upon Open! - - To accomodate for these situations, we ensure that an instance is checked - before every @TyClDecl@ on which it does not depend. That's to say, instances - are checked as early as possible in @tcTyAndClassDecls@. - ------------------------------------- -So much for WHY. What about HOW? It's pretty easy: - -(1) Rename the type/class, instance, and role declarations - individually - -(2) Do strongly-connected component analysis of the type/class decls, - We'll make a TyClGroup for each SCC - - In this step we treat a reference to a (promoted) data constructor - K as a dependency on its parent type. Thus - data T = K1 | K2 - data S = MkS (Proxy 'K1) - Here S depends on 'K1 and hence on its parent T. - - In this step we ignore instances; see - Note [No dependencies on data instances] - -(3) Attach roles to the appropriate SCC - -(4) Attach instances to the appropriate SCC. - We add an instance decl to SCC when: - all its free types/classes are bound in this SCC or earlier ones - -(5) We make an initial TyClGroup, with empty group_tyclds, for any - (orphan) instances that affect only imported types/classes - -Steps (3) and (4) are done by the (mapAccumL mk_group) call. - -Note [No dependencies on data instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - data family D a - data instance D Int = D1 - data S = MkS (Proxy 'D1) - -Here the declaration of S depends on the /data instance/ declaration -for 'D Int'. That makes things a lot more complicated, especially -if the data instance is an associated type of an enclosing class instance. -(And the class instance might have several associated type instances -with different dependency structure!) - -Ugh. For now we simply don't allow promotion of data constructors for -data instances. See Note [AFamDataCon: not promoting data family -constructors] in TcEnv --} - - -rnTyClDecls :: [TyClGroup RdrName] - -> RnM ([TyClGroup Name], FreeVars) --- Rename the declarations and do dependency analysis on them -rnTyClDecls tycl_ds - = do { -- Rename the type/class, instance, and role declaraations - tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) - (tyClGroupTyClDecls tycl_ds) - ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) - - ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) - ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) - - ; tycls_w_fvs <- addBootDeps tycls_w_fvs - -- TBD must add_boot_deps to instds_w_fvs? - - -- Do SCC analysis on the type/class decls - ; rdr_env <- getGlobalRdrEnv - ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs - role_annot_env = mkRoleAnnotEnv role_annots - - inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs - (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map - - first_group - | null init_inst_ds = [] - | otherwise = [TyClGroup { group_tyclds = [] - , group_roles = [] - , group_instds = init_inst_ds }] - - ((final_inst_ds, orphan_roles), groups) - = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs - - - all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs) - (foldr (plusFV . snd) emptyFVs instds_w_fvs) - - all_groups = first_group ++ groups - - ; ASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map - $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds ) - mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles) - - ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) - ; return (all_groups, all_fvs) } - where - mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv) - -> SCC (LTyClDecl Name) - -> ( (InstDeclFreeVarsMap, RoleAnnotEnv) - , TyClGroup Name ) - mk_group (inst_map, role_env) scc - = ((inst_map', role_env'), group) - where - tycl_ds = flattenSCC scc - bndrs = map (tcdName . unLoc) tycl_ds - (inst_ds, inst_map') = getInsts bndrs inst_map - (roles, role_env') = getRoleAnnots bndrs role_env - group = TyClGroup { group_tyclds = tycl_ds - , group_roles = roles - , group_instds = inst_ds } - - -depAnalTyClDecls :: GlobalRdrEnv - -> [(LTyClDecl Name, FreeVars)] - -> [SCC (LTyClDecl Name)] --- See Note [Dependency analysis of type, class, and instance decls] -depAnalTyClDecls rdr_env ds_w_fvs - = stronglyConnCompFromEdgedVerticesUniq edges - where - edges = [ (d, tcdName (unLoc d), map (getParent rdr_env) (nonDetEltsUniqSet fvs)) - | (d, fvs) <- ds_w_fvs ] - -- It's OK to use nonDetEltsUFM here as - -- stronglyConnCompFromEdgedVertices is still deterministic - -- even if the edges are in nondeterministic order as explained - -- in Note [Deterministic SCC] in Digraph. - -toParents :: GlobalRdrEnv -> NameSet -> NameSet -toParents rdr_env ns - = nonDetFoldUniqSet add emptyNameSet ns - -- It's OK to use nonDetFoldUFM because we immediately forget the - -- ordering by creating a set - where - add n s = extendNameSet s (getParent rdr_env n) - -getParent :: GlobalRdrEnv -> Name -> Name -getParent rdr_env n - = case lookupGRE_Name rdr_env n of - Just gre -> case gre_par gre of - ParentIs { par_is = p } -> p - FldParent { par_is = p } -> p - _ -> n - Nothing -> n - - -{- Note [Extra dependencies from .hs-boot files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This is a long story, so buckle in. - -**Dependencies via hs-boot files are not obvious.** Consider the following case: - -A.hs-boot - module A where - data A1 - -B.hs - module B where - import {-# SOURCE #-} A - type B1 = A1 - -A.hs - module A where - import B - data A2 = MkA2 B1 - data A1 = MkA1 A2 - -Here A2 is really recursive (via B1), but we won't see that easily when -doing dependency analysis when compiling A.hs. When we look at A2, -we see that its free variables are simply B1, but without (recursively) digging -into the definition of B1 will we see that it actually refers to A1 via an -hs-boot file. - -**Recursive declarations, even those broken by an hs-boot file, need to -be type-checked together.** Whenever we refer to a declaration via -an hs-boot file, we must be careful not to force the TyThing too early: -ala Note [Tying the knot] if we force the TyThing before we have -defined it ourselves in the local type environment, GHC will error. - -Conservatively, then, it would make sense that we to typecheck A1 -and A2 from the previous example together, because the two types are -truly mutually recursive through B1. - -If we are being clever, we might observe that while kind-checking -A2, we don't actually need to force the TyThing for A1: B1 -independently records its kind, so there is no need to go "deeper". -But then we are in an uncomfortable situation where we have -constructed a TyThing for A2 before we have checked A1, and we -have to be absolutely certain we don't force it too deeply until -we get around to kind checking A1, which could be for a very long -time. - -Indeed, with datatype promotion, we may very well need to look -at the type of MkA2 before we have kind-checked A1: consider, - - data T = MkT (Proxy 'MkA2) - -To promote MkA2, we need to lift its type to the kind level. -We never tested this, but it seems likely A1 would get poked -at this point. - -**Here's what we do instead.** So it is expedient for us to -make sure A1 and A2 are kind checked together in a loop. -To ensure that our dependency analysis can catch this, -we add a dependency: - - - from every local declaration - - to everything that comes from this module's .hs-boot file - (this is gotten from sb_tcs in the SelfBootInfo). - -In this case, we'll add an edges - - - from A1 to A2 (but that edge is there already) - - from A2 to A1 (which is new) - -Well, not quite *every* declaration. Imagine module A -above had another datatype declaration: - - data A3 = A3 Int - -Even though A3 has a dependency (on Int), all its dependencies are from things -that live on other packages. Since we don't have mutual dependencies across -packages, it is safe not to add the dependencies on the .hs-boot stuff to A2. - -Hence function nameIsHomePackageImport. - -Note that this is fairly conservative: it essentially implies that -EVERY type declaration in this modules hs-boot file will be kind-checked -together in one giant loop (and furthermore makes every other type -in the module depend on this loop). This is perhaps less than ideal, because -the larger a recursive group, the less polymorphism available (we -cannot infer a type to be polymorphically instantiated while we -are inferring its kind), but no one has hollered about this (yet!) --} - -addBootDeps :: [(LTyClDecl Name, FreeVars)] -> RnM [(LTyClDecl Name, FreeVars)] --- See Note [Extra dependencies from .hs-boot files] -addBootDeps ds_w_fvs - = do { tcg_env <- getGblEnv - ; let this_mod = tcg_mod tcg_env - boot_info = tcg_self_boot tcg_env - - add_boot_deps :: [(LTyClDecl Name, FreeVars)] -> [(LTyClDecl Name, FreeVars)] - add_boot_deps ds_w_fvs - = case boot_info of - SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs) - -> map (add_one tcs) ds_w_fvs - _ -> ds_w_fvs - - add_one :: NameSet -> (LTyClDecl Name, FreeVars) -> (LTyClDecl Name, FreeVars) - add_one tcs pr@(decl,fvs) - | has_local_imports fvs = (decl, fvs `plusFV` tcs) - | otherwise = pr - - has_local_imports fvs - = nameSetAny (nameIsHomePackageImport this_mod) fvs - ; return (add_boot_deps ds_w_fvs) } - - - -{- ****************************************************** -* * - Role annotations -* * -****************************************************** -} - --- | Renames role annotations, returning them as the values in a NameEnv --- and checks for duplicate role annotations. --- It is quite convenient to do both of these in the same place. --- See also Note [Role annotations in the renamer] -rnRoleAnnots :: NameSet - -> [LRoleAnnotDecl RdrName] - -> RnM [LRoleAnnotDecl Name] -rnRoleAnnots tc_names role_annots - = do { -- Check for duplicates *before* renaming, to avoid - -- lumping together all the unboundNames - let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots - role_annots_cmp (L _ annot1) (L _ annot2) - = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2 - ; mapM_ dupRoleAnnotErr dup_annots - ; mapM (wrapLocM rn_role_annot1) no_dups } - where - rn_role_annot1 (RoleAnnotDecl tycon roles) - = do { -- the name is an *occurrence*, but look it up only in the - -- decls defined in this group (see #10263) - tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) - (text "role annotation") - tycon - ; return $ RoleAnnotDecl tycon' roles } - -dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM () -dupRoleAnnotErr [] = panic "dupRoleAnnotErr" -dupRoleAnnotErr list - = addErrAt loc $ - hang (text "Duplicate role annotations for" <+> - quotes (ppr $ roleAnnotDeclName first_decl) <> colon) - 2 (vcat $ map pp_role_annot sorted_list) - where - sorted_list = sortBy cmp_annot list - (L loc first_decl : _) = sorted_list - - pp_role_annot (L loc decl) = hang (ppr decl) - 4 (text "-- written at" <+> ppr loc) - - cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2 - -orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM () -orphanRoleAnnotErr (L loc decl) - = addErrAt loc $ - hang (text "Role annotation for a type previously declared:") - 2 (ppr decl) $$ - parens (text "The role annotation must be given where" <+> - quotes (ppr $ roleAnnotDeclName decl) <+> - text "is declared.") - - -{- Note [Role annotations in the renamer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must ensure that a type's role annotation is put in the same group as the -proper type declaration. This is because role annotations are needed during -type-checking when creating the type's TyCon. So, rnRoleAnnots builds a -NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that -type, if any. Then, this map can be used to add the role annotations to the -groups after dependency analysis. - -This process checks for duplicate role annotations, where we must be careful -to do the check *before* renaming to avoid calling all unbound names duplicates -of one another. - -The renaming process, as usual, might identify and report errors for unbound -names. We exclude the annotations for unbound names in the annotation -environment to avoid spurious errors for orphaned annotations. - -We then (in rnTyClDecls) do a check for orphan role annotations (role -annotations without an accompanying type decl). The check works by folding -over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting -out the relevant role declarations for each group, as well as diminishing the -annotation environment. After the fold is complete, anything left over in the -name environment must be an orphan, and errors are generated. - -An earlier version of this algorithm short-cut the orphan check by renaming -only with names declared in this module. But, this check is insufficient in -the case of staged module compilation (Template Haskell, GHCi). -See #8485. With the new lookup process (which includes types declared in other -modules), we get better error messages, too. --} - - -{- ****************************************************** -* * - Dependency info for instances -* * -****************************************************** -} - ----------------------------------------------------------- --- | 'InstDeclFreeVarsMap is an association of an --- @InstDecl@ with @FreeVars@. The @FreeVars@ are --- the tycon names that are both --- a) free in the instance declaration --- b) bound by this group of type/class/instance decls -type InstDeclFreeVarsMap = [(LInstDecl Name, FreeVars)] - --- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the --- @FreeVars@ which are *not* the binders of a @TyClDecl@. -mkInstDeclFreeVarsMap :: GlobalRdrEnv - -> NameSet - -> [(LInstDecl Name, FreeVars)] - -> InstDeclFreeVarsMap -mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs - = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs) - | (inst_decl, fvs) <- inst_ds_fvs ] - --- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the --- @InstDeclFreeVarsMap@ with these entries removed. --- We call (getInsts tcs instd_map) when we've completed the declarations --- for 'tcs'. The call returns (inst_decls, instd_map'), where --- inst_decls are the instance declarations all of --- whose free vars are now defined --- instd_map' is the inst-decl map with 'tcs' removed from --- the free-var set -getInsts :: [Name] -> InstDeclFreeVarsMap -> ([LInstDecl Name], InstDeclFreeVarsMap) -getInsts bndrs inst_decl_map - = partitionWith pick_me inst_decl_map - where - pick_me :: (LInstDecl Name, FreeVars) - -> Either (LInstDecl Name) (LInstDecl Name, FreeVars) - pick_me (decl, fvs) - | isEmptyNameSet depleted_fvs = Left decl - | otherwise = Right (decl, depleted_fvs) - where - depleted_fvs = delFVs bndrs fvs - -{- ****************************************************** -* * - Renaming a type or class declaration -* * -****************************************************** -} - -rnTyClDecl :: TyClDecl RdrName - -> RnM (TyClDecl Name, FreeVars) - --- All flavours of type family declarations ("type family", "newtype family", --- and "data family"), both top level and (for an associated type) --- in a class decl -rnTyClDecl (FamDecl { tcdFam = decl }) - = do { (decl', fvs) <- rnFamDecl Nothing decl - ; return (FamDecl decl', fvs) } - -rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, - tcdFixity = fixity, tcdRhs = rhs }) - = do { tycon' <- lookupLocatedTopBndrRn tycon - ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs - ; let doc = TySynCtx tycon - ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) - ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ - \ tyvars' _ -> - do { (rhs', fvs) <- rnTySyn doc rhs - ; return ((tyvars', rhs'), fvs) } - ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' - , tcdFixity = fixity - , tcdRhs = rhs', tcdFVs = fvs }, fvs) } - --- "data", "newtype" declarations --- both top level and (for an associated type) in an instance decl -rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, - tcdFixity = fixity, tcdDataDefn = defn }) - = do { tycon' <- lookupLocatedTopBndrRn tycon - ; kvs <- extractDataDefnKindVars defn - ; let doc = TyDataCtx tycon - ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) - ; ((tyvars', defn', no_kvs), fvs) - <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' dep_vars -> - do { ((defn', kind_sig_fvs), fvs) <- rnDataDefn doc defn - ; let sig_tvs = filterNameSet isTyVarName kind_sig_fvs - unbound_sig_tvs = sig_tvs `minusNameSet` dep_vars - ; return ((tyvars', defn', isEmptyNameSet unbound_sig_tvs), fvs) } - -- See Note [Complete user-supplied kind signatures] in HsDecls - ; typeintype <- xoptM LangExt.TypeInType - ; let cusk = hsTvbAllKinded tyvars' && - (not typeintype || no_kvs) - ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars' - , tcdFixity = fixity - , tcdDataDefn = defn', tcdDataCusk = cusk - , tcdFVs = fvs }, fvs) } - -rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, - tcdTyVars = tyvars, tcdFixity = fixity, - tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, - tcdDocs = docs}) - = do { lcls' <- lookupLocatedTopBndrRn lcls - ; let cls' = unLoc lcls' - kvs = [] -- No scoped kind vars except those in - -- kind signatures on the tyvars - - -- Tyvars scope over superclass context and method signatures - ; ((tyvars', context', fds', ats'), stuff_fvs) - <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do - -- Checks for distinct tyvars - { (context', cxt_fvs) <- rnContext cls_doc context - ; fds' <- rnFds fds - -- The fundeps have no free variables - ; (ats', fv_ats) <- rnATDecls cls' ats - ; let fvs = cxt_fvs `plusFV` - fv_ats - ; return ((tyvars', context', fds', ats'), fvs) } - - ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs - - -- No need to check for duplicate associated type decls - -- since that is done by RnNames.extendGlobalRdrEnvRn - - -- Check the signatures - -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs - , op <- ops] - ; checkDupRdrNames sig_rdr_names_w_locs - -- Typechecker is responsible for checking that we only - -- give default-method bindings for things in this class. - -- The renamer *could* check this for class decls, but can't - -- for instance decls. - - -- The newLocals call is tiresome: given a generic class decl - -- class C a where - -- op :: a -> a - -- op {| x+y |} (Inl a) = ... - -- op {| x+y |} (Inr b) = ... - -- op {| a*b |} (a*b) = ... - -- we want to name both "x" tyvars with the same unique, so that they are - -- easy to group together in the typechecker. - ; (mbinds', sigs', meth_fvs) - <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs - -- No need to check for duplicate method signatures - -- since that is done by RnNames.extendGlobalRdrEnvRn - -- and the methods are already in scope - - -- Haddock docs - ; docs' <- mapM (wrapLocM rnDocDecl) docs - - ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs - ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', - tcdTyVars = tyvars', tcdFixity = fixity, - tcdFDs = fds', tcdSigs = sigs', - tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', - tcdDocs = docs', tcdFVs = all_fvs }, - all_fvs ) } - where - cls_doc = ClassDeclCtx lcls - --- "type" and "type instance" declarations -rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnTySyn doc rhs = rnLHsType doc rhs - -rnDataDefn :: HsDocContext -> HsDataDefn RdrName - -> RnM ((HsDataDefn Name, NameSet), FreeVars) - -- the NameSet includes all Names free in the kind signature - -- See Note [Complete user-supplied kind signatures] -rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = context, dd_cons = condecls - , dd_kindSig = m_sig, dd_derivs = derivs }) - = do { checkTc (h98_style || null (unLoc context)) - (badGadtStupidTheta doc) - - ; (m_sig', sig_fvs) <- case m_sig of - Just sig -> first Just <$> rnLHsKind doc sig - Nothing -> return (Nothing, emptyFVs) - ; (context', fvs1) <- rnContext doc context - ; (derivs', fvs3) <- rn_derivs derivs - - -- For the constructor declarations, drop the LocalRdrEnv - -- in the GADT case, where the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } - ; let { zap_lcl_env | h98_style = \ thing -> thing - | otherwise = setLocalRdrEnv emptyLocalRdrEnv } - ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls - -- No need to check for duplicate constructor decls - -- since that is done by RnNames.extendGlobalRdrEnvRn - - ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` - con_fvs `plusFV` sig_fvs - ; return (( HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = context', dd_kindSig = m_sig' - , dd_cons = condecls' - , dd_derivs = derivs' } - , sig_fvs ) - , all_fvs ) - } - where - h98_style = case condecls of -- Note [Stupid theta] - L _ (ConDeclGADT {}) : _ -> False - _ -> True - - rn_derivs (L loc ds) - = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies - ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) - multipleDerivClausesErr - ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds - ; return (L loc ds', fvs) } - -rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause RdrName - -> RnM (LHsDerivingClause Name, FreeVars) -rnLHsDerivingClause deriv_strats_ok doc - (L loc (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = L loc' dct })) - = do { failIfTc (isJust dcs && not deriv_strats_ok) $ - illegalDerivStrategyErr $ fmap unLoc dcs - ; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct - ; return ( L loc (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = L loc' dct' }) - , fvs ) } - -badGadtStupidTheta :: HsDocContext -> SDoc -badGadtStupidTheta _ - = vcat [text "No context is allowed on a GADT-style data declaration", - text "(You can put a context on each constructor, though.)"] - -illegalDerivStrategyErr :: Maybe DerivStrategy -> SDoc -illegalDerivStrategyErr ds - = vcat [ text "Illegal deriving strategy" <> colon <+> maybe empty ppr ds - , text "Use DerivingStrategies to enable this extension" ] - -multipleDerivClausesErr :: SDoc -multipleDerivClausesErr - = vcat [ text "Illegal use of multiple, consecutive deriving clauses" - , text "Use DerivingStrategies to allow this" ] - -rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested - -- inside an *class decl* for cls - -- used for associated types - -> FamilyDecl RdrName - -> RnM (FamilyDecl Name, FreeVars) -rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars - , fdFixity = fixity - , fdInfo = info, fdResultSig = res_sig - , fdInjectivityAnn = injectivity }) - = do { tycon' <- lookupLocatedTopBndrRn tycon - ; kvs <- extractRdrKindSigVars res_sig - ; ((tyvars', res_sig', injectivity'), fv1) <- - bindHsQTyVars doc Nothing mb_cls kvs tyvars $ - \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) _ -> - do { let rn_sig = rnFamResultSig doc rn_kvs - ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig - ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') - injectivity - ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } - ; (info', fv2) <- rn_info info - ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars' - , fdFixity = fixity - , fdInfo = info', fdResultSig = res_sig' - , fdInjectivityAnn = injectivity' } - , fv1 `plusFV` fv2) } - where - doc = TyFamilyCtx tycon - - ---------------------- - rn_info (ClosedTypeFamily (Just eqns)) - = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns - -- no class context, - ; return (ClosedTypeFamily (Just eqns'), fvs) } - rn_info (ClosedTypeFamily Nothing) - = return (ClosedTypeFamily Nothing, emptyFVs) - rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) - rn_info DataFamily = return (DataFamily, emptyFVs) - -rnFamResultSig :: HsDocContext - -> [Name] -- kind variables already in scope - -> FamilyResultSig RdrName - -> RnM (FamilyResultSig Name, FreeVars) -rnFamResultSig _ _ NoSig - = return (NoSig, emptyFVs) -rnFamResultSig doc _ (KindSig kind) - = do { (rndKind, ftvs) <- rnLHsKind doc kind - ; return (KindSig rndKind, ftvs) } -rnFamResultSig doc kv_names (TyVarSig tvbndr) - = do { -- `TyVarSig` tells us that user named the result of a type family by - -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to - -- be sure that the supplied result name is not identical to an - -- already in-scope type variable from an enclosing class. - -- - -- Example of disallowed declaration: - -- class C a b where - -- type F b = a | a -> b - rdr_env <- getLocalRdrEnv - ; let resName = hsLTyVarName tvbndr - ; when (resName `elemLocalRdrEnv` rdr_env) $ - addErrAt (getLoc tvbndr) $ - (hsep [ text "Type variable", quotes (ppr resName) <> comma - , text "naming a type family result," - ] $$ - text "shadows an already bound type variable") - - ; bindLHsTyVarBndr doc Nothing -- this might be a lie, but it's used for - -- scoping checks that are irrelevant here - (mkNameSet kv_names) emptyNameSet - -- use of emptyNameSet here avoids - -- redundant duplicate errors - tvbndr $ \ _ _ tvbndr' -> - return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) } - --- Note [Renaming injectivity annotation] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- During renaming of injectivity annotation we have to make several checks to --- make sure that it is well-formed. At the moment injectivity annotation --- consists of a single injectivity condition, so the terms "injectivity --- annotation" and "injectivity condition" might be used interchangeably. See --- Note [Injectivity annotation] for a detailed discussion of currently allowed --- injectivity annotations. --- --- Checking LHS is simple because the only type variable allowed on the LHS of --- injectivity condition is the variable naming the result in type family head. --- Example of disallowed annotation: --- --- type family Foo a b = r | b -> a --- --- Verifying RHS of injectivity consists of checking that: --- --- 1. only variables defined in type family head appear on the RHS (kind --- variables are also allowed). Example of disallowed annotation: --- --- type family Foo a = r | r -> b --- --- 2. for associated types the result variable does not shadow any of type --- class variables. Example of disallowed annotation: --- --- class Foo a b where --- type F a = b | b -> a --- --- Breaking any of these assumptions results in an error. - --- | Rename injectivity annotation. Note that injectivity annotation is just the --- part after the "|". Everything that appears before it is renamed in --- rnFamDecl. -rnInjectivityAnn :: LHsQTyVars Name -- ^ Type variables declared in - -- type family head - -> LFamilyResultSig Name -- ^ Result signature - -> LInjectivityAnn RdrName -- ^ Injectivity annotation - -> RnM (LInjectivityAnn Name) -rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv)) - (L srcSpan (InjectivityAnn injFrom injTo)) - = do - { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) - <- askNoErrs $ - bindLocalNames [hsLTyVarName resTv] $ - -- The return type variable scopes over the injectivity annotation - -- e.g. type family F a = (r::*) | r -> a - do { injFrom' <- rnLTyVar injFrom - ; injTo' <- mapM rnLTyVar injTo - ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } - - ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs - resName = hsLTyVarName resTv - -- See Note [Renaming injectivity annotation] - lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) - rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames - - -- if renaming of type variables ended with errors (eg. there were - -- not-in-scope variables) don't check the validity of injectivity - -- annotation. This gives better error messages. - ; when (noRnErrors && not lhsValid) $ - addErrAt (getLoc injFrom) - ( vcat [ text $ "Incorrect type variable on the LHS of " - ++ "injectivity condition" - , nest 5 - ( vcat [ text "Expected :" <+> ppr resName - , text "Actual :" <+> ppr injFrom ])]) - - ; when (noRnErrors && not (Set.null rhsValid)) $ - do { let errorVars = Set.toList rhsValid - ; addErrAt srcSpan $ ( hsep - [ text "Unknown type variable" <> plural errorVars - , text "on the RHS of injectivity condition:" - , interpp'SP errorVars ] ) } - - ; return injDecl' } - --- We can only hit this case when the user writes injectivity annotation without --- naming the result: --- --- type family F a | result -> a --- type family F a :: * | result -> a --- --- So we rename injectivity annotation like we normally would except that --- this time we expect "result" to be reported not in scope by rnLTyVar. -rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = - setSrcSpan srcSpan $ do - (injDecl', _) <- askNoErrs $ do - injFrom' <- rnLTyVar injFrom - injTo' <- mapM rnLTyVar injTo - return $ L srcSpan (InjectivityAnn injFrom' injTo') - return $ injDecl' - -{- -Note [Stupid theta] -~~~~~~~~~~~~~~~~~~~ -Trac #3850 complains about a regression wrt 6.10 for - data Show a => T a -There is no reason not to allow the stupid theta if there are no data -constructors. It's still stupid, but does no harm, and I don't want -to cause programs to break unnecessarily (notably HList). So if there -are no data constructors we allow h98_style = True --} - - -{- ***************************************************** -* * - Support code for type/data declarations -* * -***************************************************** -} - ---------------- -badAssocRhs :: [Name] -> RnM () -badAssocRhs ns - = addErr (hang (text "The RHS of an associated type declaration mentions" - <+> pprWithCommas (quotes . ppr) ns) - 2 (text "All such variables must be bound on the LHS")) - ------------------ -rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) -rnConDecls = mapFvRn (wrapLocFstM rnConDecl) - -rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) -rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs - , con_cxt = mcxt, con_details = details - , con_doc = mb_doc }) - = do { _ <- addLocM checkConName name - ; new_name <- lookupLocatedTopBndrRn name - ; let doc = ConDeclCtx [new_name] - ; mb_doc' <- rnMbLHsDoc mb_doc - ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details) - - ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing kvs qtvs' $ - \new_tyvars _ -> do - { (new_context, fvs1) <- case mcxt of - Nothing -> return (Nothing,emptyFVs) - Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt - ; return (Just lctx',fvs) } - ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details - ; let (new_details',fvs3) = (new_details,emptyFVs) - ; traceRn "rnConDecl" (ppr name <+> vcat - [ text "free_kvs:" <+> ppr kvs - , text "qtvs:" <+> ppr qtvs - , text "qtvs':" <+> ppr qtvs' ]) - ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 - new_tyvars' = case qtvs of - Nothing -> Nothing - Just _ -> Just new_tyvars - ; return (decl { con_name = new_name, con_qvars = new_tyvars' - , con_cxt = new_context, con_details = new_details' - , con_doc = mb_doc' }, - all_fvs) }} - where - cxt = maybe [] unLoc mcxt - get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) - - get_con_qtvs :: [LHsType RdrName] - -> RnM ([Located RdrName], LHsQTyVars RdrName) - get_con_qtvs arg_tys - | Just tvs <- qtvs -- data T = forall a. MkT (a -> a) - = do { free_vars <- get_rdr_tvs arg_tys - ; return (freeKiTyVarsKindVars free_vars, tvs) } - | otherwise -- data T = MkT (a -> a) - = return ([], mkHsQTvs []) - -rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty - , con_doc = mb_doc }) - = do { mapM_ (addLocM checkConName) names - ; new_names <- mapM lookupLocatedTopBndrRn names - ; let doc = ConDeclCtx new_names - ; mb_doc' <- rnMbLHsDoc mb_doc - - ; (ty', fvs) <- rnHsSigType doc ty - ; traceRn "rnConDecl" (ppr names <+> vcat - [ text "fvs:" <+> ppr fvs ]) - ; return (decl { con_names = new_names, con_type = ty' - , con_doc = mb_doc' }, - fvs) } - -rnConDeclDetails - :: Name - -> HsDocContext - -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName]) - -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars) -rnConDeclDetails _ doc (PrefixCon tys) - = do { (new_tys, fvs) <- rnLHsTypes doc tys - ; return (PrefixCon new_tys, fvs) } - -rnConDeclDetails _ doc (InfixCon ty1 ty2) - = do { (new_ty1, fvs1) <- rnLHsType doc ty1 - ; (new_ty2, fvs2) <- rnLHsType doc ty2 - ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } - -rnConDeclDetails con doc (RecCon (L l fields)) - = do { fls <- lookupConstructorFields con - ; (new_fields, fvs) <- rnConDeclFields doc fls fields - -- No need to check for duplicate fields - -- since that is done by RnNames.extendGlobalRdrEnvRn - ; return (RecCon (L l new_fields), fvs) } - -------------------------------------------------- - --- | Brings pattern synonym names and also pattern synonym selectors --- from record pattern synonyms into scope. -extendPatSynEnv :: HsValBinds RdrName -> MiniFixityEnv - -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a -extendPatSynEnv val_decls local_fix_env thing = do { - names_with_fls <- new_ps val_decls - ; let pat_syn_bndrs = concat [ name: map flSelector fields - | (name, fields) <- names_with_fls ] - ; let avails = map avail pat_syn_bndrs - ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env - - ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls - final_gbl_env = gbl_env { tcg_field_env = field_env' } - ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } - where - new_ps :: HsValBinds RdrName -> TcM [(Name, [FieldLabel])] - new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds - new_ps _ = panic "new_ps" - - new_ps' :: LHsBindLR RdrName RdrName - -> [(Name, [FieldLabel])] - -> TcM [(Name, [FieldLabel])] - new_ps' bind names - | L bind_loc (PatSynBind (PSB { psb_id = L _ n - , psb_args = RecordPatSyn as })) <- bind - = do - bnd_name <- newTopSrcBinder (L bind_loc n) - let rnames = map recordPatSynSelectorId as - mkFieldOcc :: Located RdrName -> LFieldOcc RdrName - mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder) - field_occs = map mkFieldOcc rnames - flds <- mapM (newRecordSelector False [bnd_name]) field_occs - return ((bnd_name, flds): names) - | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind - = do - bnd_name <- newTopSrcBinder (L bind_loc n) - return ((bnd_name, []): names) - | otherwise - = return names - -{- -********************************************************* -* * -\subsection{Support code to rename types} -* * -********************************************************* --} - -rnFds :: [Located (FunDep (Located RdrName))] - -> RnM [Located (FunDep (Located Name))] -rnFds fds - = mapM (wrapLocM rn_fds) fds - where - rn_fds (tys1, tys2) - = do { tys1' <- rnHsTyVars tys1 - ; tys2' <- rnHsTyVars tys2 - ; return (tys1', tys2') } - -rnHsTyVars :: [Located RdrName] -> RnM [Located Name] -rnHsTyVars tvs = mapM rnHsTyVar tvs - -rnHsTyVar :: Located RdrName -> RnM (Located Name) -rnHsTyVar (L l tyvar) = do - tyvar' <- lookupOccRn tyvar - return (L l tyvar') - -{- -********************************************************* -* * - findSplice -* * -********************************************************* - -This code marches down the declarations, looking for the first -Template Haskell splice. As it does so it - a) groups the declarations into a HsGroup - b) runs any top-level quasi-quotes --} - -findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) -findSplice ds = addl emptyRdrGroup ds - -addl :: HsGroup RdrName -> [LHsDecl RdrName] - -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) --- This stuff reverses the declarations (again) but it doesn't matter -addl gp [] = return (gp, Nothing) -addl gp (L l d : ds) = add gp l d ds - - -add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName] - -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) - --- #10047: Declaration QuasiQuoters are expanded immediately, without --- causing a group split -add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds - = do { (ds', _) <- rnTopSpliceDecls qq - ; addl gp (ds' ++ ds) - } - -add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds - = do { -- We've found a top-level splice. If it is an *implicit* one - -- (i.e. a naked top level expression) - case flag of - ExplicitSplice -> return () - ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell - ; unless th_on $ setSrcSpan loc $ - failWith badImplicitSplice } - - ; return (gp, Just (splice, ds)) } - where - badImplicitSplice = text "Parse error: module header, import declaration" - $$ text "or top-level declaration expected." - --- Class declarations: pull out the fixity signatures to the top -add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds - | isClassDecl d - = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in - addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds - | otherwise - = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds - --- Signatures: fixity sigs go a different place than all others -add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds - = addl (gp {hs_fixds = L l f : ts}) ds -add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds - = addl (gp {hs_valds = add_sig (L l d) ts}) ds - --- Value declarations: use add_bind -add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds - = addl (gp { hs_valds = add_bind (L l d) ts }) ds - --- Role annotations: added to the TyClGroup -add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds - = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds - --- NB instance declarations go into TyClGroups. We throw them into the first --- group, just as we do for the TyClD case. The renamer will go on to group --- and order them later. -add gp@(HsGroup {hs_tyclds = ts}) l (InstD d) ds - = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds - --- The rest are routine -add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds - = addl (gp { hs_derivds = L l d : ts }) ds -add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds - = addl (gp { hs_defds = L l d : ts }) ds -add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds - = addl (gp { hs_fords = L l d : ts }) ds -add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds - = addl (gp { hs_warnds = L l d : ts }) ds -add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds - = addl (gp { hs_annds = L l d : ts }) ds -add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds - = addl (gp { hs_ruleds = L l d : ts }) ds -add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds - = addl (gp { hs_vects = L l d : ts }) ds -add gp l (DocD d) ds - = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds - -add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a] -add_tycld d [] = [TyClGroup { group_tyclds = [d] - , group_roles = [] - , group_instds = [] - } - ] -add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) - = ds { group_tyclds = d : tyclds } : dss - -add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a] -add_instd d [] = [TyClGroup { group_tyclds = [] - , group_roles = [] - , group_instds = [d] - } - ] -add_instd d (ds@(TyClGroup { group_instds = instds }):dss) - = ds { group_instds = d : instds } : dss - -add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a] -add_role_annot d [] = [TyClGroup { group_tyclds = [] - , group_roles = [d] - , group_instds = [] - } - ] -add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) - = tycls { group_roles = d : roles } : rest - -add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs -add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" - -add_sig :: LSig a -> HsValBinds a -> HsValBinds a -add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) -add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" diff --git a/rename/RnSplice.hs b/rename/RnSplice.hs deleted file mode 100644 --- a/rename/RnSplice.hs +++ /dev/null @@ -1,866 +0,0 @@ -{-# LANGUAGE CPP #-} - -module RnSplice ( - rnTopSpliceDecls, - rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, - rnBracket, - checkThLocalName - , traceSplice, SpliceInfo(..) - ) where - -#include "HsVersions.h" - -import Name -import NameSet -import HsSyn -import RdrName -import TcRnMonad -import Kind - -import RnEnv -import RnSource ( rnSrcDecls, findSplice ) -import RnPat ( rnPat ) -import BasicTypes ( TopLevelFlag, isTopLevel, SourceText(..) ) -import Outputable -import Module -import SrcLoc -import RnTypes ( rnLHsType ) - -import Control.Monad ( unless, when ) - -import {-# SOURCE #-} RnExpr ( rnLExpr ) - -import TcEnv ( checkWellStaged ) -import THNames ( liftName ) - -import DynFlags -import FastString -import ErrUtils ( dumpIfSet_dyn_printer ) -import TcEnv ( tcMetaTy ) -import Hooks -import Var ( Id ) -import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName - , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) - -import {-# SOURCE #-} TcExpr ( tcPolyExpr ) -import {-# SOURCE #-} TcSplice - ( runMetaD - , runMetaE - , runMetaP - , runMetaT - , runRemoteModFinalizers - , tcTopSpliceExpr - ) - -import GHCi.RemoteTypes ( ForeignRef ) -import qualified Language.Haskell.TH as TH (Q) - -import qualified GHC.LanguageExtensions as LangExt - -{- -************************************************************************ -* * - Template Haskell brackets -* * -************************************************************************ --} - -rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) -rnBracket e br_body - = addErrCtxt (quotationCtxtDoc br_body) $ - do { -- Check that -XTemplateHaskellQuotes is enabled and available - thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes - ; unless thQuotesEnabled $ - failWith ( vcat - [ text "Syntax error on" <+> ppr e - , text ("Perhaps you intended to use TemplateHaskell" - ++ " or TemplateHaskellQuotes") ] ) - - -- Check for nested brackets - ; cur_stage <- getStage - ; case cur_stage of - { Splice Typed -> checkTc (isTypedBracket br_body) - illegalUntypedBracket - ; Splice Untyped -> checkTc (not (isTypedBracket br_body)) - illegalTypedBracket - ; RunSplice _ -> - -- See Note [RunSplice ThLevel] in "TcRnTypes". - pprPanic "rnBracket: Renaming bracket when running a splice" - (ppr e) - ; Comp -> return () - ; Brack {} -> failWithTc illegalBracket - } - - -- Brackets are desugared to code that mentions the TH package - ; recordThUse - - ; case isTypedBracket br_body of - True -> do { traceRn "Renaming typed TH bracket" empty - ; (body', fvs_e) <- - setStage (Brack cur_stage RnPendingTyped) $ - rn_bracket cur_stage br_body - ; return (HsBracket body', fvs_e) } - - False -> do { traceRn "Renaming untyped TH bracket" empty - ; ps_var <- newMutVar [] - ; (body', fvs_e) <- - setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ - rn_bracket cur_stage br_body - ; pendings <- readMutVar ps_var - ; return (HsRnBracketOut body' pendings, fvs_e) } - } - -rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars) -rn_bracket outer_stage br@(VarBr flg rdr_name) - = do { name <- lookupOccRn rdr_name - ; this_mod <- getModule - - ; when (flg && nameIsLocalOrFrom this_mod name) $ - -- Type variables can be quoted in TH. See #5721. - do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name - ; case mb_bind_lvl of - { Nothing -> return () -- Can happen for data constructors, - -- but nothing needs to be done for them - - ; Just (top_lvl, bind_lvl) -- See Note [Quoting names] - | isTopLevel top_lvl - -> when (isExternalName name) (keepAlive name) - | otherwise - -> do { traceRn "rn_bracket VarBr" - (ppr name <+> ppr bind_lvl - <+> ppr outer_stage) - ; checkTc (thLevel outer_stage + 1 == bind_lvl) - (quotedNameStageErr br) } - } - } - ; return (VarBr flg name, unitFV name) } - -rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e - ; return (ExpBr e', fvs) } - -rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) - -rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t - ; return (TypBr t', fvs) } - -rn_bracket _ (DecBrL decls) - = do { group <- groupDecls decls - ; gbl_env <- getGblEnv - ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } - -- The emptyDUs is so that we just collect uses for this - -- group alone in the call to rnSrcDecls below - ; (tcg_env, group') <- setGblEnv new_gbl_env $ - rnSrcDecls group - - -- Discard the tcg_env; it contains only extra info about fixity - ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$ - ppr (duUses (tcg_dus tcg_env))) - ; return (DecBrG group', duUses (tcg_dus tcg_env)) } - where - groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName) - groupDecls decls - = do { (group, mb_splice) <- findSplice decls - ; case mb_splice of - { Nothing -> return group - ; Just (splice, rest) -> - do { group' <- groupDecls rest - ; let group'' = appendGroups group group' - ; return group'' { hs_splcds = noLoc splice : hs_splcds group' } - } - }} - -rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG" - -rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e - ; return (TExpBr e', fvs) } - -quotationCtxtDoc :: HsBracket RdrName -> SDoc -quotationCtxtDoc br_body - = hang (text "In the Template Haskell quotation") - 2 (ppr br_body) - -illegalBracket :: SDoc -illegalBracket = - text "Template Haskell brackets cannot be nested" <+> - text "(without intervening splices)" - -illegalTypedBracket :: SDoc -illegalTypedBracket = - text "Typed brackets may only appear in typed splices." - -illegalUntypedBracket :: SDoc -illegalUntypedBracket = - text "Untyped brackets may only appear in untyped splices." - -quotedNameStageErr :: HsBracket RdrName -> SDoc -quotedNameStageErr br - = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br - , text "must be used at the same stage at which it is bound" ] - - -{- -********************************************************* -* * - Splices -* * -********************************************************* - -Note [Free variables of typed splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider renaming this: - f = ... - h = ...$(thing "f")... - -where the splice is a *typed* splice. The splice can expand into -literally anything, so when we do dependency analysis we must assume -that it might mention 'f'. So we simply treat all locally-defined -names as mentioned by any splice. This is terribly brutal, but I -don't see what else to do. For example, it'll mean that every -locally-defined thing will appear to be used, so no unused-binding -warnings. But if we miss the dependency, then we might typecheck 'h' -before 'f', and that will crash the type checker because 'f' isn't in -scope. - -Currently, I'm not treating a splice as also mentioning every import, -which is a bit inconsistent -- but there are a lot of them. We might -thereby get some bogus unused-import warnings, but we won't crash the -type checker. Not very satisfactory really. - -Note [Renamer errors] -~~~~~~~~~~~~~~~~~~~~~ -It's important to wrap renamer calls in checkNoErrs, because the -renamer does not fail for out of scope variables etc. Instead it -returns a bogus term/type, so that it can report more than one error. -We don't want the type checker to see these bogus unbound variables. --} - -rnSpliceGen :: (HsSplice Name -> RnM (a, FreeVars)) -- Outside brackets, run splice - -> (HsSplice Name -> (PendingRnSplice, a)) -- Inside brackets, make it pending - -> HsSplice RdrName - -> RnM (a, FreeVars) -rnSpliceGen run_splice pend_splice splice - = addErrCtxt (spliceCtxt splice) $ do - { stage <- getStage - ; case stage of - Brack pop_stage RnPendingTyped - -> do { checkTc is_typed_splice illegalUntypedSplice - ; (splice', fvs) <- setStage pop_stage $ - rnSplice splice - ; let (_pending_splice, result) = pend_splice splice' - ; return (result, fvs) } - - Brack pop_stage (RnPendingUntyped ps_var) - -> do { checkTc (not is_typed_splice) illegalTypedSplice - ; (splice', fvs) <- setStage pop_stage $ - rnSplice splice - ; let (pending_splice, result) = pend_splice splice' - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (pending_splice : ps) - ; return (result, fvs) } - - _ -> do { (splice', fvs1) <- checkNoErrs $ - setStage (Splice splice_type) $ - rnSplice splice - -- checkNoErrs: don't attempt to run the splice if - -- renaming it failed; otherwise we get a cascade of - -- errors from e.g. unbound variables - ; (result, fvs2) <- run_splice splice' - ; return (result, fvs1 `plusFV` fvs2) } } - where - is_typed_splice = isTypedSplice splice - splice_type = if is_typed_splice - then Typed - else Untyped - ------------------- - --- | Returns the result of running a splice and the modFinalizers collected --- during the execution. --- --- See Note [Delaying modFinalizers in untyped splices]. -runRnSplice :: UntypedSpliceFlavour - -> (LHsExpr Id -> TcRn res) - -> (res -> SDoc) -- How to pretty-print res - -- Usually just ppr, but not for [Decl] - -> HsSplice Name -- Always untyped - -> TcRn (res, [ForeignRef (TH.Q ())]) -runRnSplice flavour run_meta ppr_res splice - = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) - - ; let the_expr = case splice' of - HsUntypedSplice _ _ e -> e - HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str - HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) - HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) - - -- Typecheck the expression - ; meta_exp_ty <- tcMetaTy meta_ty_name - ; zonked_q_expr <- tcTopSpliceExpr Untyped $ - tcPolyExpr the_expr meta_exp_ty - - -- Run the expression - ; mod_finalizers_ref <- newTcRef [] - ; result <- setStage (RunSplice mod_finalizers_ref) $ - run_meta zonked_q_expr - ; mod_finalizers <- readTcRef mod_finalizers_ref - ; traceSplice (SpliceInfo { spliceDescription = what - , spliceIsDecl = is_decl - , spliceSource = Just the_expr - , spliceGenerated = ppr_res result }) - - ; return (result, mod_finalizers) } - - where - meta_ty_name = case flavour of - UntypedExpSplice -> expQTyConName - UntypedPatSplice -> patQTyConName - UntypedTypeSplice -> typeQTyConName - UntypedDeclSplice -> decsQTyConName - what = case flavour of - UntypedExpSplice -> "expression" - UntypedPatSplice -> "pattern" - UntypedTypeSplice -> "type" - UntypedDeclSplice -> "declarations" - is_decl = case flavour of - UntypedDeclSplice -> True - _ -> False - ------------------- -makePending :: UntypedSpliceFlavour - -> HsSplice Name - -> PendingRnSplice -makePending flavour (HsUntypedSplice _ n e) - = PendingRnSplice flavour n e -makePending flavour (HsQuasiQuote n quoter q_span quote) - = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote) -makePending _ splice@(HsTypedSplice {}) - = pprPanic "makePending" (ppr splice) -makePending _ splice@(HsSpliced {}) - = pprPanic "makePending" (ppr splice) - ------------------- -mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr Name --- Return the expression (quoter "...quote...") --- which is what we must run in a quasi-quote -mkQuasiQuoteExpr flavour quoter q_span quote - = L q_span $ HsApp (L q_span $ - HsApp (L q_span (HsVar (L q_span quote_selector))) - quoterExpr) - quoteExpr - where - quoterExpr = L q_span $! HsVar $! (L q_span quoter) - quoteExpr = L q_span $! HsLit $! HsString NoSourceText quote - quote_selector = case flavour of - UntypedExpSplice -> quoteExpName - UntypedPatSplice -> quotePatName - UntypedTypeSplice -> quoteTypeName - UntypedDeclSplice -> quoteDecName - ---------------------- -rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) --- Not exported...used for all -rnSplice (HsTypedSplice hasParen splice_name expr) - = do { checkTH expr "Template Haskell typed splice" - ; loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L loc splice_name) - ; (expr', fvs) <- rnLExpr expr - ; return (HsTypedSplice hasParen n' expr', fvs) } - -rnSplice (HsUntypedSplice hasParen splice_name expr) - = do { checkTH expr "Template Haskell untyped splice" - ; loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L loc splice_name) - ; (expr', fvs) <- rnLExpr expr - ; return (HsUntypedSplice hasParen n' expr', fvs) } - -rnSplice (HsQuasiQuote splice_name quoter q_loc quote) - = do { checkTH quoter "Template Haskell quasi-quote" - ; loc <- getSrcSpanM - ; splice_name' <- newLocalBndrRn (L loc splice_name) - - -- Rename the quoter; akin to the HsVar case of rnExpr - ; quoter' <- lookupOccRn quoter - ; this_mod <- getModule - ; when (nameIsLocalOrFrom this_mod quoter') $ - checkThLocalName quoter' - - ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') } - -rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) - ---------------------- -rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) -rnSpliceExpr splice - = rnSpliceGen run_expr_splice pend_expr_splice splice - where - pend_expr_splice :: HsSplice Name -> (PendingRnSplice, HsExpr Name) - pend_expr_splice rn_splice - = (makePending UntypedExpSplice rn_splice, HsSpliceE rn_splice) - - run_expr_splice :: HsSplice Name -> RnM (HsExpr Name, FreeVars) - run_expr_splice rn_splice - | isTypedSplice rn_splice -- Run it later, in the type checker - = do { -- Ugh! See Note [Splices] above - traceRn "rnSpliceExpr: typed expression splice" empty - ; lcl_rdr <- getLocalRdrEnv - ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr - , isLocalGRE gre] - lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) - - ; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) } - - | otherwise -- Run it here, see Note [Running splices in the Renamer] - = do { traceRn "rnSpliceExpr: untyped expression splice" empty - ; (rn_expr, mod_finalizers) <- - runRnSplice UntypedExpSplice runMetaE ppr rn_splice - ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) - -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsPar $ HsSpliceE - . HsSpliced (ThModFinalizers mod_finalizers) - . HsSplicedExpr <$> - lexpr3 - , fvs) - } - -{- Note [Running splices in the Renamer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Splices used to be run in the typechecker, which led to (Trac #4364). Since the -renamer must decide which expressions depend on which others, and it cannot -reliably do this for arbitrary splices, we used to conservatively say that -splices depend on all other expressions in scope. Unfortunately, this led to -the problem of cyclic type declarations seen in (Trac #4364). Instead, by -running splices in the renamer, we side-step the problem of determining -dependencies: by the time the dependency analysis happens, any splices have -already been run, and expression dependencies can be determined as usual. - -However, see (Trac #9813), for an example where we would like to run splices -*after* performing dependency analysis (that is, after renaming). It would be -desirable to typecheck "non-splicy" expressions (those expressions that do not -contain splices directly or via dependence on an expression that does) before -"splicy" expressions, such that types/expressions within the same declaration -group would be available to `reify` calls, for example consider the following: - -> module M where -> data D = C -> f = 1 -> g = $(mapM reify ['f, 'D, ''C] ...) - -Compilation of this example fails since D/C/f are not in the type environment -and thus cannot be reified as they have not been typechecked by the time the -splice is renamed and thus run. - -These requirements are at odds: we do not want to run splices in the renamer as -we wish to first determine dependencies and typecheck certain expressions, -making them available to reify, but cannot accurately determine dependencies -without running splices in the renamer! - -Indeed, the conclusion of (Trac #9813) was that it is not worth the complexity -to try and - a) implement and maintain the code for renaming/typechecking non-splicy - expressions before splicy expressions, - b) explain to TH users which expressions are/not available to reify at any - given point. - --} - -{- Note [Delaying modFinalizers in untyped splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When splices run in the renamer, 'reify' does not have access to the local -type environment (Trac #11832, [1]). - -For instance, in - -> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |]) - -'reify' cannot find @x@, because the local type environment is not yet -populated. To address this, we allow 'reify' execution to be deferred with -'addModFinalizer'. - -> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print) - [| return () |] - ) - -The finalizer is run with the local type environment when type checking is -complete. - -Since the local type environment is not available in the renamer, we annotate -the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where -@e@ is the result of splicing and @finalizers@ are the finalizers that have been -collected during evaluation of the splice [3]. In our example, - -> HsLet -> (x = e) -> (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print] -> (HsSplicedExpr $ return ()) -> ) - -When the typechecker finds the annotation, it inserts the finalizers in the -global environment and exposes the current local environment to them [4, 5, 6]. - -> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print] - -References: - -[1] https://ghc.haskell.org/trac/ghc/wiki/TemplateHaskell/Reify -[2] 'rnSpliceExpr' -[3] 'TcSplice.qAddModFinalizer' -[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...)) -[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...)) -[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...)) - --} - ----------------------- -rnSpliceType :: HsSplice RdrName -> PostTc Name Kind - -> RnM (HsType Name, FreeVars) -rnSpliceType splice k - = rnSpliceGen run_type_splice pend_type_splice splice - where - pend_type_splice rn_splice - = (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k) - - run_type_splice rn_splice - = do { traceRn "rnSpliceType: untyped type splice" empty - ; (hs_ty2, mod_finalizers) <- - runRnSplice UntypedTypeSplice runMetaT ppr rn_splice - ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2 - ; checkNoErrs $ rnLHsType doc hs_ty2 } - -- checkNoErrs: see Note [Renamer errors] - -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsParTy $ flip HsSpliceTy k - . HsSpliced (ThModFinalizers mod_finalizers) - . HsSplicedTy <$> - hs_ty3 - , fvs - ) } - -- Wrap the result of the splice in parens so that we don't - -- lose the outermost location set by runQuasiQuote (#7918) - -{- Note [Partial Type Splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Partial Type Signatures are partially supported in TH type splices: only -anonymous wild cards are allowed. - - -- ToDo: SLPJ says: I don't understand all this - -Normally, named wild cards are collected before renaming a (partial) type -signature. However, TH type splices are run during renaming, i.e. after the -initial traversal, leading to out of scope errors for named wild cards. We -can't just extend the initial traversal to collect the named wild cards in TH -type splices, as we'd need to expand them, which is supposed to happen only -once, during renaming. - -Similarly, the extra-constraints wild card is handled right before renaming -too, and is therefore also not supported in a TH type splice. Another reason -to forbid extra-constraints wild cards in TH type splices is that a single -signature can contain many TH type splices, whereas it mustn't contain more -than one extra-constraints wild card. Enforcing would this be hard the way -things are currently organised. - -Anonymous wild cards pose no problem, because they start out without names and -are given names during renaming. These names are collected right after -renaming. The names generated for anonymous wild cards in TH type splices will -thus be collected as well. - -For more details about renaming wild cards, see RnTypes.rnHsSigWcType - -Note that partial type signatures are fully supported in TH declaration -splices, e.g.: - - [d| foo :: _ => _ - foo x y = x == y |] - -This is because in this case, the partial type signature can be treated as a -whole signature, instead of as an arbitrary type. - --} - - ----------------------- --- | Rename a splice pattern. See Note [rnSplicePat] -rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name) - , FreeVars) -rnSplicePat splice - = rnSpliceGen run_pat_splice pend_pat_splice splice - where - pend_pat_splice rn_splice - = (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice)) - - run_pat_splice rn_splice - = do { traceRn "rnSplicePat: untyped pattern splice" empty - ; (pat, mod_finalizers) <- - runRnSplice UntypedPatSplice runMetaP ppr rn_splice - -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( Left $ ParPat $ SplicePat - . HsSpliced (ThModFinalizers mod_finalizers) - . HsSplicedPat <$> - pat - , emptyFVs - ) } - -- Wrap the result of the quasi-quoter in parens so that we don't - -- lose the outermost location set by runQuasiQuote (#7918) - ----------------------- -rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) -rnSpliceDecl (SpliceDecl (L loc splice) flg) - = rnSpliceGen run_decl_splice pend_decl_splice splice - where - pend_decl_splice rn_splice - = (makePending UntypedDeclSplice rn_splice, SpliceDecl (L loc rn_splice) flg) - - run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) - -rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars) --- Declaration splice at the very top level of the module -rnTopSpliceDecls splice - = do { (rn_splice, fvs) <- checkNoErrs $ - setStage (Splice Untyped) $ - rnSplice splice - -- As always, be sure to checkNoErrs above lest we end up with - -- holes making it to typechecking, hence #12584. - ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty - ; (decls, mod_finalizers) <- - runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice - ; add_mod_finalizers_now mod_finalizers - ; return (decls,fvs) } - where - ppr_decls :: [LHsDecl RdrName] -> SDoc - ppr_decls ds = vcat (map ppr ds) - - -- Adds finalizers to the global environment instead of delaying them - -- to the type checker. - -- - -- Declaration splices do not have an interesting local environment so - -- there is no point in delaying them. - -- - -- See Note [Delaying modFinalizers in untyped splices]. - add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn () - add_mod_finalizers_now [] = return () - add_mod_finalizers_now mod_finalizers = do - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - updTcRef th_modfinalizers_var $ \fins -> - runRemoteModFinalizers (ThModFinalizers mod_finalizers) : fins - - -{- -Note [rnSplicePat] -~~~~~~~~~~~~~~~~~~ -Renaming a pattern splice is a bit tricky, because we need the variables -bound in the pattern to be in scope in the RHS of the pattern. This scope -management is effectively done by using continuation-passing style in -RnPat, through the CpsRn monad. We don't wish to be in that monad here -(it would create import cycles and generally conflict with renaming other -splices), so we really want to return a (Pat RdrName) -- the result of -running the splice -- which can then be further renamed in RnPat, in -the CpsRn monad. - -The problem is that if we're renaming a splice within a bracket, we -*don't* want to run the splice now. We really do just want to rename -it to an HsSplice Name. Of course, then we can't know what variables -are bound within the splice. So we accept any unbound variables and -rename them again when the bracket is spliced in. If a variable is brought -into scope by a pattern splice all is fine. If it is not then an error is -reported. - -In any case, when we're done in rnSplicePat, we'll either have a -Pat RdrName (the result of running a top-level splice) or a Pat Name -(the renamed nested splice). Thus, the awkward return type of -rnSplicePat. --} - -spliceCtxt :: HsSplice RdrName -> SDoc -spliceCtxt splice - = hang (text "In the" <+> what) 2 (ppr splice) - where - what = case splice of - HsUntypedSplice {} -> text "untyped splice:" - HsTypedSplice {} -> text "typed splice:" - HsQuasiQuote {} -> text "quasi-quotation:" - HsSpliced {} -> text "spliced expression:" - --- | The splice data to be logged -data SpliceInfo - = SpliceInfo - { spliceDescription :: String - , spliceSource :: Maybe (LHsExpr Name) -- Nothing <=> top-level decls - -- added by addTopDecls - , spliceIsDecl :: Bool -- True <=> put the generate code in a file - -- when -dth-dec-file is on - , spliceGenerated :: SDoc - } - -- Note that 'spliceSource' is *renamed* but not *typechecked* - -- Reason (a) less typechecking crap - -- (b) data constructors after type checking have been - -- changed to their *wrappers*, and that makes them - -- print always fully qualified - --- | outputs splice information for 2 flags which have different output formats: --- `-ddump-splices` and `-dth-dec-file` -traceSplice :: SpliceInfo -> TcM () -traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src - , spliceGenerated = gen, spliceIsDecl = is_decl }) - = do { loc <- case mb_src of - Nothing -> getSrcSpanM - Just (L loc _) -> return loc - ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) - - ; when is_decl $ -- Raw material for -dth-dec-file - do { dflags <- getDynFlags - ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file - (spliceCodeDoc loc) } } - where - -- `-ddump-splices` - spliceDebugDoc :: SrcSpan -> SDoc - spliceDebugDoc loc - = let code = case mb_src of - Nothing -> ending - Just e -> nest 2 (ppr e) : ending - ending = [ text "======>", nest 2 gen ] - in hang (ppr loc <> colon <+> text "Splicing" <+> text sd) - 2 (sep code) - - -- `-dth-dec-file` - spliceCodeDoc :: SrcSpan -> SDoc - spliceCodeDoc loc - = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd - , gen ] - -illegalTypedSplice :: SDoc -illegalTypedSplice = text "Typed splices may not appear in untyped brackets" - -illegalUntypedSplice :: SDoc -illegalUntypedSplice = text "Untyped splices may not appear in typed brackets" - -checkThLocalName :: Name -> RnM () -checkThLocalName name - | isUnboundName name -- Do not report two errors for - = return () -- $(not_in_scope args) - - | otherwise - = do { traceRn "checkThLocalName" (ppr name) - ; mb_local_use <- getStageAndBindLevel name - ; case mb_local_use of { - Nothing -> return () ; -- Not a locally-bound thing - Just (top_lvl, bind_lvl, use_stage) -> - do { let use_lvl = thLevel use_stage - ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl - ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl - <+> ppr use_stage - <+> ppr use_lvl) - ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } } - --------------------------------------- -checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel - -> Name -> TcM () --- We are inside brackets, and (use_lvl > bind_lvl) --- Now we must check whether there's a cross-stage lift to do --- Examples \x -> [| x |] --- [| map |] --- --- This code is similar to checkCrossStageLifting in TcExpr, but --- this is only run on *untyped* brackets. - -checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name - | Brack _ (RnPendingUntyped ps_var) <- use_stage -- Only for untyped brackets - , use_lvl > bind_lvl -- Cross-stage condition - = check_cross_stage_lifting top_lvl name ps_var - | otherwise - = return () - -check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM () -check_cross_stage_lifting top_lvl name ps_var - | isTopLevel top_lvl - -- Top-level identifiers in this module, - -- (which have External Names) - -- are just like the imported case: - -- no need for the 'lifting' treatment - -- E.g. this is fine: - -- f x = x - -- g y = [| f 3 |] - = when (isExternalName name) (keepAlive name) - -- See Note [Keeping things alive for Template Haskell] - - | otherwise - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [| h x |] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the SplicePointName, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same SplicePointName, but that doesn't - -- matter, although it's a mite untidy. - do { traceRn "checkCrossStageLifting" (ppr name) - - -- Construct the (lift x) expression - ; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name) - pend_splice = PendingRnSplice UntypedExpSplice name lift_expr - - -- Update the pending splices - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (pend_splice : ps) } - -{- -Note [Keeping things alive for Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = x+1 - g y = [| f 3 |] - -Here 'f' is referred to from inside the bracket, which turns into data -and mentions only f's *name*, not 'f' itself. So we need some other -way to keep 'f' alive, lest it get dropped as dead code. That's what -keepAlive does. It puts it in the keep-alive set, which subsequently -ensures that 'f' stays as a top level binding. - -This must be done by the renamer, not the type checker (as of old), -because the type checker doesn't typecheck the body of untyped -brackets (Trac #8540). - -A thing can have a bind_lvl of outerLevel, but have an internal name: - foo = [d| op = 3 - bop = op + 1 |] -Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is -bound inside a bracket. That is because we don't even even record -binding levels for top-level things; the binding levels are in the -LocalRdrEnv. - -So the occurrence of 'op' in the rhs of 'bop' looks a bit like a -cross-stage thing, but it isn't really. And in fact we never need -to do anything here for top-level bound things, so all is fine, if -a bit hacky. - -For these chaps (which have Internal Names) we don't want to put -them in the keep-alive set. - -Note [Quoting names] -~~~~~~~~~~~~~~~~~~~~ -A quoted name 'n is a bit like a quoted expression [| n |], except that we -have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing -the use-level to account for the brackets, the cases are: - - bind > use Error - bind = use+1 OK - bind < use - Imported things OK - Top-level things OK - Non-top-level Error - -where 'use' is the binding level of the 'n quote. (So inside the implied -bracket the level would be use+1.) - -Examples: - - f 'map -- OK; also for top-level defns of this module - - \x. f 'x -- Not ok (bind = 1, use = 1) - -- (whereas \x. f [| x |] might have been ok, by - -- cross-stage lifting - - \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1) - - [| \x. $(f 'x) |] -- OK (bind = 2, use = 1) --} diff --git a/rename/RnSplice.hs-boot b/rename/RnSplice.hs-boot deleted file mode 100644 --- a/rename/RnSplice.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -module RnSplice where - -import HsSyn -import TcRnMonad -import RdrName -import Name -import NameSet -import Kind - - -rnSpliceType :: HsSplice RdrName -> PostTc Name Kind - -> RnM (HsType Name, FreeVars) -rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name) - , FreeVars ) -rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) - -rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars) diff --git a/rename/RnTypes.hs b/rename/RnTypes.hs deleted file mode 100644 --- a/rename/RnTypes.hs +++ /dev/null @@ -1,1746 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnSource]{Main pass of renamer} --} - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} - -module RnTypes ( - -- Type related stuff - rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsKind, rnLHsKind, - rnHsSigType, rnHsWcType, - rnHsSigWcType, rnHsSigWcTypeScoped, - rnLHsInstType, - newTyVarNameRn, collectAnonWildCards, - rnConDeclFields, - rnLTyVar, - - -- Precence related stuff - mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, - checkPrecMatch, checkSectionPrec, - - -- Binding related stuff - bindLHsTyVarBndr, - bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames, - extractFilteredRdrTyVars, - extractHsTyRdrTyVars, extractHsTysRdrTyVars, - extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars, - extractRdrKindSigVars, extractDataDefnKindVars, - freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars - ) where - -import {-# SOURCE #-} RnSplice( rnSpliceType ) - -import DynFlags -import HsSyn -import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) -import RnEnv -import TcRnMonad -import RdrName -import PrelNames -import TysPrim ( funTyConName ) -import TysWiredIn ( starKindTyConName, unicodeStarKindTyConName ) -import Name -import SrcLoc -import NameSet -import FieldLabel - -import Util -import BasicTypes ( compareFixity, funTyFixity, negateFixity, - Fixity(..), FixityDirection(..), LexicalFixity(..) ) -import Outputable -import FastString -import Maybes -import qualified GHC.LanguageExtensions as LangExt - -import Data.List ( nubBy, partition ) -import Control.Monad ( unless, when ) - -#include "HsVersions.h" - -{- -These type renamers are in a separate module, rather than in (say) RnSource, -to break several loop. - -********************************************************* -* * - HsSigWcType (i.e with wildcards) -* * -********************************************************* --} - -rnHsSigWcType :: HsDocContext -> LHsSigWcType RdrName - -> RnM (LHsSigWcType Name, FreeVars) -rnHsSigWcType doc sig_ty - = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' -> - return (sig_ty', emptyFVs) - -rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType RdrName - -> (LHsSigWcType Name -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) --- Used for --- - Signatures on binders in a RULE --- - Pattern type signatures --- Wildcards are allowed --- type signatures on binders only allowed with ScopedTypeVariables -rnHsSigWcTypeScoped ctx sig_ty thing_inside - = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables - ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty) - ; rn_hs_sig_wc_type False ctx sig_ty thing_inside - } - -- False: for pattern type sigs and rules we /do/ want - -- to bring those type variables into scope - -- e.g \ (x :: forall a. a-> b) -> e - -- Here we do bring 'b' into scope - -rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs - -> HsDocContext - -> LHsSigWcType RdrName - -> (LHsSigWcType Name -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) --- rn_hs_sig_wc_type is used for source-language type signatures -rn_hs_sig_wc_type no_implicit_if_forall ctxt - (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) - thing_inside - = do { free_vars <- extractFilteredRdrTyVars hs_ty - ; (tv_rdrs, nwc_rdrs) <- partition_nwcs free_vars - ; rnImplicitBndrs no_implicit_if_forall tv_rdrs hs_ty $ \ vars -> - do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty - ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_ty' } - ib_ty' = mk_implicit_bndrs vars hs_ty' fvs1 - ; (res, fvs2) <- thing_inside sig_ty' - ; return (res, fvs1 `plusFV` fvs2) } } - -rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars) -rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) - = do { free_vars <- extractFilteredRdrTyVars hs_ty - ; (_, nwc_rdrs) <- partition_nwcs free_vars - ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty - ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = hs_ty' } - ; return (sig_ty', fvs) } - -rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType RdrName - -> RnM ([Name], LHsType Name, FreeVars) -rnWcBody ctxt nwc_rdrs hs_ty - = do { nwcs <- mapM newLocalBndrRn nwc_rdrs - ; let env = RTKE { rtke_level = TypeLevel - , rtke_what = RnTypeBody - , rtke_nwcs = mkNameSet nwcs - , rtke_ctxt = ctxt } - ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $ - rn_lty env hs_ty - ; let awcs = collectAnonWildCards hs_ty' - ; return (nwcs ++ awcs, hs_ty', fvs) } - where - rn_lty env (L loc hs_ty) - = setSrcSpan loc $ - do { (hs_ty', fvs) <- rn_ty env hs_ty - ; return (L loc hs_ty', fvs) } - - rn_ty :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars) - -- A lot of faff just to allow the extra-constraints wildcard to appear - rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body }) - = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) - Nothing [] tvs $ \ _ tvs' _ _ -> - do { (hs_body', fvs) <- rn_lty env hs_body - ; return (HsForAllTy { hst_bndrs = tvs', hst_body = hs_body' }, fvs) } - - rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty }) - | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt - , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last - = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 - ; wc' <- setSrcSpan lx $ - do { checkExtraConstraintWildCard env wc - ; rnAnonWildCard wc } - ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')] - ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty - ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } - , fvs1 `plusFV` fvs2) } - - | otherwise - = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt - ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty - ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } - , fvs1 `plusFV` fvs2) } - - rn_ty env hs_ty = rnHsTyKi env hs_ty - - rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) - - -checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName - -> RnM () --- Rename the extra-constraint spot in a type signature --- (blah, _) => type --- Check that extra-constraints are allowed at all, and --- if so that it's an anonymous wildcard -checkExtraConstraintWildCard env wc - = checkWildCard env mb_bad - where - mb_bad | not (extraConstraintWildCardsAllowed env) - = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc) - <+> text "not allowed") - | otherwise - = Nothing - -extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool -extraConstraintWildCardsAllowed env - = case rtke_ctxt env of - TypeSigCtx {} -> True - ExprWithTySigCtx {} -> True - _ -> False - --- | Finds free type and kind variables in a type, --- without duplicates, and --- without variables that are already in scope in LocalRdrEnv --- NB: this includes named wildcards, which look like perfectly --- ordinary type variables at this point -extractFilteredRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars -extractFilteredRdrTyVars hs_ty - = do { rdr_env <- getLocalRdrEnv - ; filterInScope rdr_env <$> extractHsTyRdrTyVars hs_ty } - --- | When the NamedWildCards extension is enabled, partition_nwcs --- removes type variables that start with an underscore from the --- FreeKiTyVars in the argument and returns them in a separate list. --- When the extension is disabled, the function returns the argument --- and empty list. See Note [Renaming named wild cards] -partition_nwcs :: FreeKiTyVars -> RnM (FreeKiTyVars, [Located RdrName]) -partition_nwcs free_vars@(FKTV { fktv_tys = tys }) - = do { wildcards_enabled <- fmap (xopt LangExt.NamedWildCards) getDynFlags - ; let (nwcs, no_nwcs) | wildcards_enabled = partition is_wildcard tys - | otherwise = ([], tys) - free_vars' = free_vars { fktv_tys = no_nwcs } - ; return (free_vars', nwcs) } - where - is_wildcard :: Located RdrName -> Bool - is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr)) - -{- Note [Renaming named wild cards] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Identifiers starting with an underscore are always parsed as type variables. -It is only here in the renamer that we give the special treatment. -See Note [The wildcard story for types] in HsTypes. - -It's easy! When we collect the implicitly bound type variables, ready -to bring them into scope, and NamedWildCards is on, we partition the -variables into the ones that start with an underscore (the named -wildcards) and the rest. Then we just add them to the hswc_wcs field -of the HsWildCardBndrs structure, and we are done. - - -********************************************************* -* * - HsSigtype (i.e. no wildcards) -* * -****************************************************** -} - -rnHsSigType :: HsDocContext -> LHsSigType RdrName - -> RnM (LHsSigType Name, FreeVars) --- Used for source-language type signatures --- that cannot have wildcards -rnHsSigType ctx (HsIB { hsib_body = hs_ty }) - = do { vars <- extractFilteredRdrTyVars hs_ty - ; rnImplicitBndrs True vars hs_ty $ \ vars -> - do { (body', fvs) <- rnLHsType ctx hs_ty - ; return ( mk_implicit_bndrs vars body' fvs, fvs ) } } - -rnImplicitBndrs :: Bool -- True <=> no implicit quantification - -- if type is headed by a forall - -- E.g. f :: forall a. a->b - -- Do not quantify over 'b' too. - -> FreeKiTyVars - -> LHsType RdrName - -> ([Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside - = do { let real_tv_rdrs -- Implicit quantification only if - -- there is no explicit forall - | no_implicit_if_forall - , L _ (HsForAllTy {}) <- hs_ty = [] - | otherwise = freeKiTyVarsTypeVars free_vars - real_rdrs = freeKiTyVarsKindVars free_vars ++ real_tv_rdrs - ; traceRn "rnSigType" (ppr hs_ty $$ ppr free_vars $$ - ppr real_rdrs) - - ; traceRn "" (text "rnSigType2" <+> ppr hs_ty $$ ppr free_vars $$ - ppr real_rdrs) - ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_rdrs - ; bindLocalNamesFV vars $ - thing_inside vars } - -rnLHsInstType :: SDoc -> LHsSigType RdrName -> RnM (LHsSigType Name, FreeVars) --- Rename the type in an instance or standalone deriving decl --- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma" -rnLHsInstType doc_str inst_ty - | Just cls <- getLHsInstDeclClass_maybe inst_ty - , isTcOcc (rdrNameOcc (unLoc cls)) - -- The guards check that the instance type looks like - -- blah => C ty1 .. tyn - = do { let full_doc = doc_str <+> text "for" <+> quotes (ppr cls) - ; rnHsSigType (GenericCtx full_doc) inst_ty } - - | otherwise -- The instance is malformed, but we'd still like - -- to make progress rather than failing outright, so - -- we report more errors. So we rename it anyway. - = do { addErrAt (getLoc (hsSigType inst_ty)) $ - text "Malformed instance:" <+> ppr inst_ty - ; rnHsSigType (GenericCtx doc_str) inst_ty } - -mk_implicit_bndrs :: [Name] -- implicitly bound - -> a -- payload - -> FreeVars -- FreeVars of payload - -> HsImplicitBndrs Name a -mk_implicit_bndrs vars body fvs - = HsIB { hsib_vars = vars - , hsib_body = body - , hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) } - - -{- ****************************************************** -* * - LHsType and HsType -* * -****************************************************** -} - -{- -rnHsType is here because we call it from loadInstDecl, and I didn't -want a gratuitous knot. - -Note [Context quantification] ------------------------------ -Variables in type signatures are implicitly quantified -when (1) they are in a type signature not beginning -with "forall" or (2) in any qualified type T => R. -We are phasing out (2) since it leads to inconsistencies -(Trac #4426): - -data A = A (a -> a) is an error -data A = A (Eq a => a -> a) binds "a" -data A = A (Eq a => a -> b) binds "a" and "b" -data A = A (() => a -> b) binds "a" and "b" -f :: forall a. a -> b is an error -f :: forall a. () => a -> b is an error -f :: forall a. a -> (() => b) binds "a" and "b" - -This situation is now considered to be an error. See rnHsTyKi for case -HsForAllTy Qualified. - -Note [Dealing with *] -~~~~~~~~~~~~~~~~~~~~~ -As a legacy from the days when types and kinds were different, we use -the type * to mean what we now call GHC.Types.Type. The problem is that -* should associate just like an identifier, *not* a symbol. -Running example: the user has written - - T (Int, Bool) b + c * d - -At this point, we have a bunch of stretches of types - - [[T, (Int, Bool), b], [c], [d]] - -these are the [[LHsType Name]] and a bunch of operators - - [GHC.TypeLits.+, GHC.Types.*] - -Note that the * is GHC.Types.*. So, we want to rearrange to have - - [[T, (Int, Bool), b], [c, *, d]] - -and - - [GHC.TypeLits.+] - -as our lists. We can then do normal fixity resolution on these. The fixities -must come along for the ride just so that the list stays in sync with the -operators. - -Note [QualTy in kinds] -~~~~~~~~~~~~~~~~~~~~~~ -I was wondering whether QualTy could occur only at TypeLevel. But no, -we can have a qualified type in a kind too. Here is an example: - - type family F a where - F Bool = Nat - F Nat = Type - - type family G a where - G Type = Type -> Type - G () = Nat - - data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where - MkX :: X 'True '() - -See that k1 becomes Bool and k2 becomes (), so the equality is -satisfied. If I write MkX :: X 'True 'False, compilation fails with a -suitable message: - - MkX :: X 'True '() - • Couldn't match kind ‘G Bool’ with ‘Nat’ - Expected kind: G Bool - Actual kind: F Bool - -However: in a kind, the constraints in the QualTy must all be -equalities; or at least, any kinds with a class constraint are -uninhabited. --} - -data RnTyKiEnv - = RTKE { rtke_ctxt :: HsDocContext - , rtke_level :: TypeOrKind -- Am I renaming a type or a kind? - , rtke_what :: RnTyKiWhat -- And within that what am I renaming? - , rtke_nwcs :: NameSet -- These are the in-scope named wildcards - } - -data RnTyKiWhat = RnTypeBody - | RnTopConstraint -- Top-level context of HsSigWcTypes - | RnConstraint -- All other constraints - -instance Outputable RnTyKiEnv where - ppr (RTKE { rtke_level = lev, rtke_what = what - , rtke_nwcs = wcs, rtke_ctxt = ctxt }) - = text "RTKE" - <+> braces (sep [ ppr lev, ppr what, ppr wcs - , pprHsDocContext ctxt ]) - -instance Outputable RnTyKiWhat where - ppr RnTypeBody = text "RnTypeBody" - ppr RnTopConstraint = text "RnTopConstraint" - ppr RnConstraint = text "RnConstraint" - -mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv -mkTyKiEnv cxt level what - = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet - , rtke_what = what, rtke_ctxt = cxt } - -isRnKindLevel :: RnTyKiEnv -> Bool -isRnKindLevel (RTKE { rtke_level = KindLevel }) = True -isRnKindLevel _ = False - --------------- -rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty - -rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> RnM ([LHsType Name], FreeVars) -rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys - -rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty - -rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) -rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind - -rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars) -rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind - --------------- -rnTyKiContext :: RnTyKiEnv -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) -rnTyKiContext env (L loc cxt) - = do { traceRn "rncontext" (ppr cxt) - ; let env' = env { rtke_what = RnConstraint } - ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt - ; return (L loc cxt', fvs) } - -rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) -rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta - --------------- -rnLHsTyKi :: RnTyKiEnv -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnLHsTyKi env (L loc ty) - = setSrcSpan loc $ - do { (ty', fvs) <- rnHsTyKi env ty - ; return (L loc ty', fvs) } - -rnHsTyKi :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars) - -rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) - = do { checkTypeInType env ty - ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty) - Nothing [] tyvars $ \ _ tyvars' _ _ -> - do { (tau', fvs) <- rnLHsTyKi env tau - ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' } - , fvs) } } - -rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) - = do { checkTypeInType env ty -- See Note [QualTy in kinds] - ; (ctxt', fvs1) <- rnTyKiContext env lctxt - ; (tau', fvs2) <- rnLHsTyKi env tau - ; return (HsQualTy { hst_ctxt = ctxt', hst_body = tau' } - , fvs1 `plusFV` fvs2) } - -rnHsTyKi env (HsTyVar ip (L loc rdr_name)) - = do { name <- rnTyVar env rdr_name - ; return (HsTyVar ip (L loc name), unitFV name) } - -rnHsTyKi env ty@(HsOpTy ty1 l_op ty2) - = setSrcSpan (getLoc l_op) $ - do { (l_op', fvs1) <- rnHsTyOp env ty l_op - ; fix <- lookupTyFixityRn l_op' - ; (ty1', fvs2) <- rnLHsTyKi env ty1 - ; (ty2', fvs3) <- rnLHsTyKi env ty2 - ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) - (unLoc l_op') fix ty1' ty2' - ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } - -rnHsTyKi env (HsParTy ty) - = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsParTy ty', fvs) } - -rnHsTyKi env (HsBangTy b ty) - = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsBangTy b ty', fvs) } - -rnHsTyKi env ty@(HsRecTy flds) - = do { let ctxt = rtke_ctxt env - ; fls <- get_fields ctxt - ; (flds', fvs) <- rnConDeclFields ctxt fls flds - ; return (HsRecTy flds', fvs) } - where - get_fields (ConDeclCtx names) - = concatMapM (lookupConstructorFields . unLoc) names - get_fields _ - = do { addErr (hang (text "Record syntax is illegal here:") - 2 (ppr ty)) - ; return [] } - -rnHsTyKi env (HsFunTy ty1 ty2) - = do { (ty1', fvs1) <- rnLHsTyKi env ty1 - -- Might find a for-all as the arg of a function type - ; (ty2', fvs2) <- rnLHsTyKi env ty2 - -- Or as the result. This happens when reading Prelude.hi - -- when we find return :: forall m. Monad m -> forall a. a -> m a - - -- Check for fixity rearrangements - ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' - ; return (res_ty, fvs1 `plusFV` fvs2) } - -rnHsTyKi env listTy@(HsListTy ty) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env listTy)) - ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsListTy ty', fvs) } - -rnHsTyKi env t@(HsKindSig ty k) - = do { checkTypeInType env t - ; kind_sigs_ok <- xoptM LangExt.KindSignatures - ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) - ; (ty', fvs1) <- rnLHsTyKi env ty - ; (k', fvs2) <- rnLHsTyKi (env { rtke_level = KindLevel }) k - ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } - -rnHsTyKi env t@(HsPArrTy ty) - = do { notInKinds env t - ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsPArrTy ty', fvs) } - --- Unboxed tuples are allowed to have poly-typed arguments. These --- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsTyKi env tupleTy@(HsTupleTy tup_con tys) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env tupleTy)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsTupleTy tup_con tys', fvs) } - -rnHsTyKi env sumTy@(HsSumTy tys) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env sumTy)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsSumTy tys', fvs) } - --- Ensure that a type-level integer is nonnegative (#8306, #8412) -rnHsTyKi env tyLit@(HsTyLit t) - = do { data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env tyLit)) - ; when (negLit t) (addErr negLitErr) - ; checkTypeInType env tyLit - ; return (HsTyLit t, emptyFVs) } - where - negLit (HsStrTy _ _) = False - negLit (HsNumTy _ i) = i < 0 - negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit - -rnHsTyKi env overall_ty@(HsAppsTy tys) - = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions - let (non_syms, syms) = splitHsAppsTy tys - - -- Step 2: rename the pieces - ; (syms1, fvs1) <- mapFvRn (rnHsTyOp env overall_ty) syms - ; (non_syms1, fvs2) <- (mapFvRn . mapFvRn) (rnLHsTyKi env) non_syms - - -- Step 3: deal with *. See Note [Dealing with *] - ; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1 - - -- Step 4: collapse the non-symbol regions with HsAppTy - ; non_syms3 <- mapM deal_with_non_syms non_syms2 - - -- Step 5: assemble the pieces, using mkHsOpTyRn - ; L _ res_ty <- build_res_ty non_syms3 syms2 - - -- all done. Phew. - ; return (res_ty, fvs1 `plusFV` fvs2) } - where - -- See Note [Dealing with *] - deal_with_star :: [[LHsType Name]] -> [Located Name] - -> [[LHsType Name]] -> [Located Name] - -> ([[LHsType Name]], [Located Name]) - deal_with_star acc1 acc2 - (non_syms1 : non_syms2 : non_syms) (L loc star : ops) - | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey - = deal_with_star acc1 acc2 - ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star)) - : non_syms2) : non_syms) - ops - deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops) - = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops - deal_with_star acc1 acc2 [non_syms] [] - = (reverse (non_syms : acc1), reverse acc2) - deal_with_star _ _ _ _ - = pprPanic "deal_with_star" (ppr overall_ty) - - -- collapse [LHsType Name] to LHsType Name by making applications - -- monadic only for failure - deal_with_non_syms :: [LHsType Name] -> RnM (LHsType Name) - deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms - deal_with_non_syms [] = failWith (emptyNonSymsErr overall_ty) - - -- assemble a right-biased OpTy for use in mkHsOpTyRn - build_res_ty :: [LHsType Name] -> [Located Name] -> RnM (LHsType Name) - build_res_ty (arg1 : args) (op1 : ops) - = do { rhs <- build_res_ty args ops - ; fix <- lookupTyFixityRn op1 - ; res <- - mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs - ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs) - ; return (L loc res) - } - build_res_ty [arg] [] = return arg - build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty) - -rnHsTyKi env (HsAppTy ty1 ty2) - = do { (ty1', fvs1) <- rnLHsTyKi env ty1 - ; (ty2', fvs2) <- rnLHsTyKi env ty2 - ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) } - -rnHsTyKi env t@(HsIParamTy n ty) - = do { notInKinds env t - ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsIParamTy n ty', fvs) } - -rnHsTyKi env t@(HsEqTy ty1 ty2) - = do { checkTypeInType env t - ; (ty1', fvs1) <- rnLHsTyKi env ty1 - ; (ty2', fvs2) <- rnLHsTyKi env ty2 - ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } - -rnHsTyKi _ (HsSpliceTy sp k) - = rnSpliceType sp k - -rnHsTyKi env (HsDocTy ty haddock_doc) - = do { (ty', fvs) <- rnLHsTyKi env ty - ; haddock_doc' <- rnLHsDoc haddock_doc - ; return (HsDocTy ty' haddock_doc', fvs) } - -rnHsTyKi _ (HsCoreTy ty) - = return (HsCoreTy ty, emptyFVs) - -- The emptyFVs probably isn't quite right - -- but I don't think it matters - -rnHsTyKi env ty@(HsExplicitListTy ip k tys) - = do { checkTypeInType env ty - ; data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env ty)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsExplicitListTy ip k tys', fvs) } - -rnHsTyKi env ty@(HsExplicitTupleTy kis tys) - = do { checkTypeInType env ty - ; data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env ty)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsExplicitTupleTy kis tys', fvs) } - -rnHsTyKi env (HsWildCardTy wc) - = do { checkAnonWildCard env wc - ; wc' <- rnAnonWildCard wc - ; return (HsWildCardTy wc', emptyFVs) } - -- emptyFVs: this occurrence does not refer to a - -- user-written binding site, so don't treat - -- it as a free variable - --------------- -rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name -rnTyVar env rdr_name - = do { name <- if isRnKindLevel env - then lookupKindOccRn rdr_name - else lookupTypeOccRn rdr_name - ; checkNamedWildCard env name - ; return name } - -rnLTyVar :: Located RdrName -> RnM (Located Name) --- Called externally; does not deal with wildards -rnLTyVar (L loc rdr_name) - = do { tyvar <- lookupTypeOccRn rdr_name - ; return (L loc tyvar) } - --------------- -rnHsTyOp :: Outputable a - => RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars) -rnHsTyOp env overall_ty (L loc op) - = do { ops_ok <- xoptM LangExt.TypeOperators - ; op' <- rnTyVar env op - ; unless (ops_ok - || op' == starKindTyConName - || op' == unicodeStarKindTyConName - || op' `hasKey` eqTyConKey) $ - addErr (opTyErr op overall_ty) - ; let l_op' = L loc op' - ; return (l_op', unitFV op') } - --------------- -notAllowed :: SDoc -> SDoc -notAllowed doc - = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed") - -checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM () -checkWildCard env (Just doc) - = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))] -checkWildCard _ Nothing - = return () - -checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName -> RnM () --- Report an error if an anonymoous wildcard is illegal here -checkAnonWildCard env wc - = checkWildCard env mb_bad - where - mb_bad :: Maybe SDoc - mb_bad | not (wildCardsAllowed env) - = Just (notAllowed (ppr wc)) - | otherwise - = case rtke_what env of - RnTypeBody -> Nothing - RnConstraint -> Just constraint_msg - RnTopConstraint -> Just constraint_msg - - constraint_msg = hang (notAllowed (ppr wc) <+> text "in a constraint") - 2 hint_msg - hint_msg = vcat [ text "except as the last top-level constraint of a type signature" - , nest 2 (text "e.g f :: (Eq a, _) => blah") ] - -checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () --- Report an error if a named wildcard is illegal here -checkNamedWildCard env name - = checkWildCard env mb_bad - where - mb_bad | not (name `elemNameSet` rtke_nwcs env) - = Nothing -- Not a wildcard - | not (wildCardsAllowed env) - = Just (notAllowed (ppr name)) - | otherwise - = case rtke_what env of - RnTypeBody -> Nothing -- Allowed - RnTopConstraint -> Nothing -- Allowed - RnConstraint -> Just constraint_msg - constraint_msg = notAllowed (ppr name) <+> text "in a constraint" - -wildCardsAllowed :: RnTyKiEnv -> Bool --- ^ In what contexts are wildcards permitted -wildCardsAllowed env - = case rtke_ctxt env of - TypeSigCtx {} -> True - TypBrCtx {} -> True -- Template Haskell quoted type - SpliceTypeCtx {} -> True -- Result of a Template Haskell splice - ExprWithTySigCtx {} -> True - PatCtx {} -> True - RuleCtx {} -> True - FamPatCtx {} -> True -- Not named wildcards though - GHCiCtx {} -> True - HsTypeCtx {} -> True - _ -> False - -rnAnonWildCard :: HsWildCardInfo RdrName -> RnM (HsWildCardInfo Name) -rnAnonWildCard (AnonWildCard _) - = do { loc <- getSrcSpanM - ; uniq <- newUnique - ; let name = mkInternalName uniq (mkTyVarOcc "_") loc - ; return (AnonWildCard (L loc name)) } - ---------------- --- | Ensures either that we're in a type or that -XTypeInType is set -checkTypeInType :: Outputable ty - => RnTyKiEnv - -> ty -- ^ type - -> RnM () -checkTypeInType env ty - | isRnKindLevel env - = do { type_in_type <- xoptM LangExt.TypeInType - ; unless type_in_type $ - addErr (text "Illegal kind:" <+> ppr ty $$ - text "Did you mean to enable TypeInType?") } -checkTypeInType _ _ = return () - -notInKinds :: Outputable ty - => RnTyKiEnv - -> ty - -> RnM () -notInKinds env ty - | isRnKindLevel env - = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty) -notInKinds _ _ = return () - -{- ***************************************************** -* * - Binding type variables -* * -***************************************************** -} - -bindSigTyVarsFV :: [Name] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) --- Used just before renaming the defn of a function --- with a separate type signature, to bring its tyvars into scope --- With no -XScopedTypeVariables, this is a no-op -bindSigTyVarsFV tvs thing_inside - = do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables - ; if not scoped_tyvars then - thing_inside - else - bindLocalNamesFV tvs thing_inside } - --- | Simply bring a bunch of RdrNames into scope. No checking for --- validity, at all. The binding location is taken from the location --- on each name. -bindLRdrNames :: [Located RdrName] - -> ([Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindLRdrNames rdrs thing_inside - = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs - ; bindLocalNamesFV var_names $ - thing_inside var_names } - ---------------- -bindHsQTyVars :: forall a b. - HsDocContext - -> Maybe SDoc -- if we are to check for unused tvs, - -- a phrase like "in the type ..." - -> Maybe a -- Just _ => an associated type decl - -> [Located RdrName] -- Kind variables from scope, in l-to-r - -- order, but not from ... - -> (LHsQTyVars RdrName) -- ... these user-written tyvars - -> (LHsQTyVars Name -> NameSet -> RnM (b, FreeVars)) - -- also returns all names used in kind signatures, for the - -- TypeInType clause of Note [Complete user-supplied kind - -- signatures] in HsDecls - -> RnM (b, FreeVars) --- (a) Bring kind variables into scope --- both (i) passed in (kv_bndrs) --- and (ii) mentioned in the kinds of tv_bndrs --- (b) Bring type variables into scope -bindHsQTyVars doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside - = do { bindLHsTyVarBndrs doc mb_in_doc - mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $ - \ rn_kvs rn_bndrs dep_var_set all_dep_vars -> - thing_inside (HsQTvs { hsq_implicit = rn_kvs - , hsq_explicit = rn_bndrs - , hsq_dependent = dep_var_set }) all_dep_vars } - -bindLHsTyVarBndrs :: forall a b. - HsDocContext - -> Maybe SDoc -- if we are to check for unused tvs, - -- a phrase like "in the type ..." - -> Maybe a -- Just _ => an associated type decl - -> [Located RdrName] -- Unbound kind variables from scope, - -- in l-to-r order, but not from ... - -> [LHsTyVarBndr RdrName] -- ... these user-written tyvars - -> ( [Name] -- all kv names - -> [LHsTyVarBndr Name] - -> NameSet -- which names, from the preceding list, - -- are used dependently within that list - -- See Note [Dependent LHsQTyVars] in TcHsType - -> NameSet -- all names used in kind signatures - -> RnM (b, FreeVars)) - -> RnM (b, FreeVars) -bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside - = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) - ; go [] [] emptyNameSet emptyNameSet emptyNameSet tv_bndrs } - where - tv_names_w_loc = map hsLTyVarLocName tv_bndrs - - go :: [Name] -- kind-vars found (in reverse order) - -> [LHsTyVarBndr Name] -- already renamed (in reverse order) - -> NameSet -- kind vars already in scope (for dup checking) - -> NameSet -- type vars already in scope (for dup checking) - -> NameSet -- (all) variables used dependently - -> [LHsTyVarBndr RdrName] -- still to be renamed, scoped - -> RnM (b, FreeVars) - go rn_kvs rn_tvs kv_names tv_names dep_vars (tv_bndr : tv_bndrs) - = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $ - \ kv_nms used_dependently tv_bndr' -> - do { (b, fvs) <- go (reverse kv_nms ++ rn_kvs) - (tv_bndr' : rn_tvs) - (kv_names `extendNameSetList` kv_nms) - (tv_names `extendNameSet` hsLTyVarName tv_bndr') - (dep_vars `unionNameSet` used_dependently) - tv_bndrs - ; warn_unused tv_bndr' fvs - ; return (b, fvs) } - - go rn_kvs rn_tvs _kv_names tv_names dep_vars [] - = -- still need to deal with the kv_bndrs passed in originally - bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms others -> - do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs) - all_rn_tvs = reverse rn_tvs - ; env <- getLocalRdrEnv - ; let all_dep_vars = dep_vars `unionNameSet` others - exp_dep_vars -- variables in all_rn_tvs that are in dep_vars - = mkNameSet [ name - | v <- all_rn_tvs - , let name = hsLTyVarName v - , name `elemNameSet` all_dep_vars ] - ; traceRn "bindHsTyVars" (ppr env $$ - ppr all_rn_kvs $$ - ppr all_rn_tvs $$ - ppr exp_dep_vars) - ; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars all_dep_vars } - - warn_unused tv_bndr fvs = case mb_in_doc of - Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs - Nothing -> return () - -bindLHsTyVarBndr :: HsDocContext - -> Maybe a -- associated class - -> NameSet -- kind vars already in scope - -> NameSet -- type vars already in scope - -> LHsTyVarBndr RdrName - -> ([Name] -> NameSet -> LHsTyVarBndr Name -> RnM (b, FreeVars)) - -- passed the newly-bound implicitly-declared kind vars, - -- any other names used in a kind - -- and the renamed LHsTyVarBndr - -> RnM (b, FreeVars) -bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside - = case hs_tv_bndr of - L loc (UserTyVar lrdr@(L lv rdr)) -> - do { check_dup loc rdr [] - ; nm <- newTyVarNameRn mb_assoc lrdr - ; bindLocalNamesFV [nm] $ - thing_inside [] emptyNameSet (L loc (UserTyVar (L lv nm))) } - L loc (KindedTyVar lrdr@(L lv rdr) kind) -> - do { free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind - ; check_dup lv rdr (map unLoc free_kvs) - - -- check for -XKindSignatures - ; sig_ok <- xoptM LangExt.KindSignatures - ; unless sig_ok (badKindSigErr doc kind) - - -- deal with kind vars in the user-written kind - ; bindImplicitKvs doc mb_assoc free_kvs tv_names $ - \ new_kv_nms other_kv_nms -> - do { (kind', fvs1) <- rnLHsKind doc kind - ; tv_nm <- newTyVarNameRn mb_assoc lrdr - ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $ - thing_inside new_kv_nms other_kv_nms - (L loc (KindedTyVar (L lv tv_nm) kind')) - ; return (b, fvs1 `plusFV` fvs2) }} - where - -- make sure that the RdrName isn't in the sets of - -- names. We can't just check that it's not in scope at all - -- because we might be inside an associated class. - check_dup :: SrcSpan -> RdrName -> [RdrName] -> RnM () - check_dup loc rdr kindFreeVars - = do { -- Disallow use of a type variable name in its - -- kind signature (#11592). - when (rdr `elem` kindFreeVars) $ - addErrAt loc (vcat [ ki_ty_self_err rdr - , pprHsDocContext doc ]) - - ; m_name <- lookupLocalOccRn_maybe rdr - ; whenIsJust m_name $ \name -> - do { when (name `elemNameSet` kv_names) $ - addErrAt loc (vcat [ ki_ty_err_msg name - , pprHsDocContext doc ]) - ; when (name `elemNameSet` tv_names) $ - dupNamesErr getLoc [L loc name, L (nameSrcSpan name) name] }} - - ki_ty_err_msg n = text "Variable" <+> quotes (ppr n) <+> - text "used as a kind variable before being bound" $$ - text "as a type variable. Perhaps reorder your variables?" - - ki_ty_self_err n = text "Variable" <+> quotes (ppr n) <+> - text "is used in the kind signature of its" $$ - text "declaration as a type variable." - - -bindImplicitKvs :: HsDocContext - -> Maybe a - -> [Located RdrName] -- ^ kind var *occurrences*, from which - -- intent to bind is inferred - -> NameSet -- ^ *type* variables, for type/kind - -- misuse check for -XNoTypeInType - -> ([Name] -> NameSet -> RnM (b, FreeVars)) - -- ^ passed new kv_names, and any other names used in a kind - -> RnM (b, FreeVars) -bindImplicitKvs _ _ [] _ thing_inside - = thing_inside [] emptyNameSet -bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside - = do { rdr_env <- getLocalRdrEnv - ; let part_kvs lrdr@(L loc kv_rdr) - = case lookupLocalRdrEnv rdr_env kv_rdr of - Just kv_name -> Left (L loc kv_name) - _ -> Right lrdr - (bound_kvs, new_kvs) = partitionWith part_kvs free_kvs - - -- check whether we're mixing types & kinds illegally - ; type_in_type <- xoptM LangExt.TypeInType - ; unless type_in_type $ - mapM_ (check_tv_used_in_kind tv_names) bound_kvs - - ; poly_kinds <- xoptM LangExt.PolyKinds - ; unless poly_kinds $ - addErr (badKindBndrs doc new_kvs) - - -- bind the vars and move on - ; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs - ; bindLocalNamesFV kv_nms $ - thing_inside kv_nms (mkNameSet (map unLoc bound_kvs)) } - where - -- check to see if the variables free in a kind are bound as type - -- variables. Assume -XNoTypeInType. - check_tv_used_in_kind :: NameSet -- ^ *type* variables - -> Located Name -- ^ renamed var used in kind - -> RnM () - check_tv_used_in_kind tv_names (L loc kv_name) - = when (kv_name `elemNameSet` tv_names) $ - addErrAt loc (vcat [ text "Type variable" <+> quotes (ppr kv_name) <+> - text "used in a kind." $$ - text "Did you mean to use TypeInType?" - , pprHsDocContext doc ]) - - -newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name -newTyVarNameRn mb_assoc (L loc rdr) - = do { rdr_env <- getLocalRdrEnv - ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of - (Just _, Just n) -> return n - -- Use the same Name as the parent class decl - - _ -> newLocalBndrRn (L loc rdr) } - ---------------------- -collectAnonWildCards :: LHsType Name -> [Name] --- | Extract all wild cards from a type. -collectAnonWildCards lty = go lty - where - go (L _ ty) = case ty of - HsWildCardTy (AnonWildCard (L _ wc)) -> [wc] - HsAppsTy tys -> gos (mapMaybe (prefix_types_only . unLoc) tys) - HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2 - HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2 - HsListTy ty -> go ty - HsPArrTy ty -> go ty - HsTupleTy _ tys -> gos tys - HsSumTy tys -> gos tys - HsOpTy ty1 _ ty2 -> go ty1 `mappend` go ty2 - HsParTy ty -> go ty - HsIParamTy _ ty -> go ty - HsEqTy ty1 ty2 -> go ty1 `mappend` go ty2 - HsKindSig ty kind -> go ty `mappend` go kind - HsDocTy ty _ -> go ty - HsBangTy _ ty -> go ty - HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds - HsExplicitListTy _ _ tys -> gos tys - HsExplicitTupleTy _ tys -> gos tys - HsForAllTy { hst_bndrs = bndrs - , hst_body = ty } -> collectAnonWildCardsBndrs bndrs - `mappend` go ty - HsQualTy { hst_ctxt = L _ ctxt - , hst_body = ty } -> gos ctxt `mappend` go ty - HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _ -> go $ L noSrcSpan ty - HsSpliceTy{} -> mempty - HsCoreTy{} -> mempty - HsTyLit{} -> mempty - HsTyVar{} -> mempty - - gos = mconcat . map go - - prefix_types_only (HsAppPrefix ty) = Just ty - prefix_types_only (HsAppInfix _) = Nothing - -collectAnonWildCardsBndrs :: [LHsTyVarBndr Name] -> [Name] -collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs - where - go (UserTyVar _) = [] - go (KindedTyVar _ ki) = collectAnonWildCards ki - -{- -********************************************************* -* * - ConDeclField -* * -********************************************************* - -When renaming a ConDeclField, we have to find the FieldLabel -associated with each field. But we already have all the FieldLabels -available (since they were brought into scope by -RnNames.getLocalNonValBinders), so we just take the list as an -argument, build a map and look them up. --} - -rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField RdrName] - -> RnM ([LConDeclField Name], FreeVars) --- Also called from RnSource --- No wildcards can appear in record fields -rnConDeclFields ctxt fls fields - = mapFvRn (rnField fl_env env) fields - where - env = mkTyKiEnv ctxt TypeLevel RnTypeBody - fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] - -rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField RdrName - -> RnM (LConDeclField Name, FreeVars) -rnField fl_env env (L l (ConDeclField names ty haddock_doc)) - = do { let new_names = map (fmap lookupField) names - ; (new_ty, fvs) <- rnLHsTyKi env ty - ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) } - where - lookupField :: FieldOcc RdrName -> FieldOcc Name - lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl) - where - lbl = occNameFS $ rdrNameOcc rdr - fl = expectJust "rnField" $ lookupFsEnv fl_env lbl - -{- -************************************************************************ -* * - Fixities and precedence parsing -* * -************************************************************************ - -@mkOpAppRn@ deals with operator fixities. The argument expressions -are assumed to be already correctly arranged. It needs the fixities -recorded in the OpApp nodes, because fixity info applies to the things -the programmer actually wrote, so you can't find it out from the Name. - -Furthermore, the second argument is guaranteed not to be another -operator application. Why? Because the parser parses all -operator applications left-associatively, EXCEPT negation, which -we need to handle specially. -Infix types are read in a *right-associative* way, so that - a `op` b `op` c -is always read in as - a `op` (b `op` c) - -mkHsOpTyRn rearranges where necessary. The two arguments -have already been renamed and rearranged. It's made rather tiresome -by the presence of ->, which is a separate syntactic construct. --} - ---------------- --- Building (ty1 `op1` (ty21 `op2` ty22)) -mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name -> LHsType Name - -> RnM (HsType Name) - -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22)) - = do { fix2 <- lookupTyFixityRn op2 - ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (\t1 t2 -> HsOpTy t1 op2 t2) - (unLoc op2) fix2 ty21 ty22 loc2 } - -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22)) - = mk_hs_op_ty mk1 pp_op1 fix1 ty1 - HsFunTy funTyConName funTyFixity ty21 ty22 loc2 - -mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment - = return (mk1 ty1 ty2) - ---------------- -mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name - -> (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan - -> RnM (HsType Name) -mk_hs_op_ty mk1 op1 fix1 ty1 - mk2 op2 fix2 ty21 ty22 loc2 - | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2) - ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } - | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) - | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) - new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 - ; return (mk2 (noLoc new_ty) ty22) } - where - (nofix_error, associate_right) = compareFixity fix1 fix2 - - ---------------------------- -mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged - -> LHsExpr Name -> Fixity -- Operator and fixity - -> LHsExpr Name -- Right operand (not an OpApp, but might - -- be a NegApp) - -> RnM (HsExpr Name) - --- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 - | nofix_error - = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (OpApp e1 op2 fix2 e2) - - | associate_right = do - new_e <- mkOpAppRn e12 op2 fix2 e2 - return (OpApp e11 op1 fix1 (L loc' new_e)) - where - loc'= combineLocs e12 e2 - (nofix_error, associate_right) = compareFixity fix1 fix2 - ---------------------------- --- (- neg_arg) `op` e2 -mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 - | nofix_error - = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) - return (OpApp e1 op2 fix2 e2) - - | associate_right - = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 - return (NegApp (L loc' new_e) neg_name) - where - loc' = combineLocs neg_arg e2 - (nofix_error, associate_right) = compareFixity negateFixity fix2 - ---------------------------- --- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right - | not associate_right -- We *want* right association - = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) - return (OpApp e1 op1 fix1 e2) - where - (_, associate_right) = compareFixity fix1 negateFixity - ---------------------------- --- Default case -mkOpAppRn e1 op fix e2 -- Default case, no rearrangment - = ASSERT2( right_op_ok fix (unLoc e2), - ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 - ) - return (OpApp e1 op fix e2) - ----------------------------- - --- | Name of an operator in an operator application or section -data OpName = NormalOp Name -- ^ A normal identifier - | NegateOp -- ^ Prefix negation - | UnboundOp UnboundVar -- ^ An unbound indentifier - | RecFldOp (AmbiguousFieldOcc Name) - -- ^ A (possibly ambiguous) record field occurrence - -instance Outputable OpName where - ppr (NormalOp n) = ppr n - ppr NegateOp = ppr negateName - ppr (UnboundOp uv) = ppr uv - ppr (RecFldOp fld) = ppr fld - -get_op :: LHsExpr Name -> OpName --- An unbound name could be either HsVar or HsUnboundVar --- See RnExpr.rnUnboundVar -get_op (L _ (HsVar (L _ n))) = NormalOp n -get_op (L _ (HsUnboundVar uv)) = UnboundOp uv -get_op (L _ (HsRecFld fld)) = RecFldOp fld -get_op other = pprPanic "get_op" (ppr other) - --- Parser left-associates everything, but --- derived instances may have correctly-associated things to --- in the right operand. So we just check that the right operand is OK -right_op_ok :: Fixity -> HsExpr Name -> Bool -right_op_ok fix1 (OpApp _ _ fix2 _) - = not error_please && associate_right - where - (error_please, associate_right) = compareFixity fix1 fix2 -right_op_ok _ _ - = True - --- Parser initially makes negation bind more tightly than any other operator --- And "deriving" code should respect this (use HsPar if not) -mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id) -mkNegAppRn neg_arg neg_name - = ASSERT( not_op_app (unLoc neg_arg) ) - return (NegApp neg_arg neg_name) - -not_op_app :: HsExpr id -> Bool -not_op_app (OpApp _ _ _ _) = False -not_op_app _ = True - ---------------------------- -mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged - -> LHsExpr Name -> Fixity -- Operator and fixity - -> LHsCmdTop Name -- Right operand (not an infix) - -> RnM (HsCmd Name) - --- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1) - [a11,a12])) _ _ _)) - op2 fix2 a2 - | nofix_error - = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (HsCmdArrForm op2 f (Just fix2) [a1, a2]) - - | associate_right - = do new_c <- mkOpFormRn a12 op2 fix2 a2 - return (HsCmdArrForm op1 f (Just fix1) - [a11, L loc (HsCmdTop (L loc new_c) - placeHolderType placeHolderType [])]) - -- TODO: locs are wrong - where - (nofix_error, associate_right) = compareFixity fix1 fix2 - --- Default case -mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2]) - - --------------------------------------- -mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name - -> RnM (Pat Name) - -mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 - = do { fix1 <- lookupFixityRn (unLoc op1) - ; let (nofix_error, associate_right) = compareFixity fix1 fix2 - - ; if nofix_error then do - { precParseErr (NormalOp (unLoc op1),fix1) - (NormalOp (unLoc op2),fix2) - ; return (ConPatIn op2 (InfixCon p1 p2)) } - - else if associate_right then do - { new_p <- mkConOpPatRn op2 fix2 p12 p2 - ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? - else return (ConPatIn op2 (InfixCon p1 p2)) } - -mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment - = ASSERT( not_op_pat (unLoc p2) ) - return (ConPatIn op (InfixCon p1 p2)) - -not_op_pat :: Pat Name -> Bool -not_op_pat (ConPatIn _ (InfixCon _ _)) = False -not_op_pat _ = True - --------------------------------------- -checkPrecMatch :: Name -> MatchGroup Name body -> RnM () - -- Check precedence of a function binding written infix - -- eg a `op` b `C` c = ... - -- See comments with rnExpr (OpApp ...) about "deriving" - -checkPrecMatch op (MG { mg_alts = L _ ms }) - = mapM_ check ms - where - check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _)) - = setSrcSpan (combineSrcSpans l1 l2) $ - do checkPrec op p1 False - checkPrec op p2 True - - check _ = return () - -- This can happen. Consider - -- a `op` True = ... - -- op = ... - -- The infix flag comes from the first binding of the group - -- but the second eqn has no args (an error, but not discovered - -- until the type checker). So we don't want to crash on the - -- second eqn. - -checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () -checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do - op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op - op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1) - let - inf_ok = op1_prec > op_prec || - (op1_prec == op_prec && - (op1_dir == InfixR && op_dir == InfixR && right || - op1_dir == InfixL && op_dir == InfixL && not right)) - - info = (NormalOp op, op_fix) - info1 = (NormalOp (unLoc op1), op1_fix) - (infol, infor) = if right then (info, info1) else (info1, info) - unless inf_ok (precParseErr infol infor) - -checkPrec _ _ _ - = return () - --- Check precedence of (arg op) or (op arg) respectively --- If arg is itself an operator application, then either --- (a) its precedence must be higher than that of op --- (b) its precedency & associativity must be the same as that of op -checkSectionPrec :: FixityDirection -> HsExpr RdrName - -> LHsExpr Name -> LHsExpr Name -> RnM () -checkSectionPrec direction section op arg - = case unLoc arg of - OpApp _ op' fix _ -> go_for_it (get_op op') fix - NegApp _ _ -> go_for_it NegateOp negateFixity - _ -> return () - where - op_name = get_op op - go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do - op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name - unless (op_prec < arg_prec - || (op_prec == arg_prec && direction == assoc)) - (sectionPrecErr (get_op op, op_fix) - (arg_op, arg_fix) section) - --- | Look up the fixity for an operator name. Be careful to use --- 'lookupFieldFixityRn' for (possibly ambiguous) record fields --- (see Trac #13132). -lookupFixityOp :: OpName -> RnM Fixity -lookupFixityOp (NormalOp n) = lookupFixityRn n -lookupFixityOp NegateOp = lookupFixityRn negateName -lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (unboundVarOcc u)) -lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f - - --- Precedence-related error messages - -precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM () -precParseErr op1@(n1,_) op2@(n2,_) - | is_unbound n1 || is_unbound n2 - = return () -- Avoid error cascade - | otherwise - = addErr $ hang (text "Precedence parsing error") - 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"), - ppr_opfix op2, - text "in the same infix expression"]) - -sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr RdrName -> RnM () -sectionPrecErr op@(n1,_) arg_op@(n2,_) section - | is_unbound n1 || is_unbound n2 - = return () -- Avoid error cascade - | otherwise - = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"), - nest 4 (sep [text "must have lower precedence than that of the operand,", - nest 2 (text "namely" <+> ppr_opfix arg_op)]), - nest 4 (text "in the section:" <+> quotes (ppr section))] - -is_unbound :: OpName -> Bool -is_unbound (NormalOp n) = isUnboundName n -is_unbound UnboundOp{} = True -is_unbound _ = False - -ppr_opfix :: (OpName, Fixity) -> SDoc -ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) - where - pp_op | NegateOp <- op = text "prefix `-'" - | otherwise = quotes (ppr op) - - -{- ***************************************************** -* * - Errors -* * -***************************************************** -} - -unexpectedTypeSigErr :: LHsSigWcType RdrName -> SDoc -unexpectedTypeSigErr ty - = hang (text "Illegal type signature:" <+> quotes (ppr ty)) - 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") - -badKindBndrs :: HsDocContext -> [Located RdrName] -> SDoc -badKindBndrs doc kvs - = withHsDocContext doc $ - hang (text "Unexpected kind variable" <> plural kvs - <+> pprQuotedList kvs) - 2 (text "Perhaps you intended to use PolyKinds") - -badKindSigErr :: HsDocContext -> LHsType RdrName -> TcM () -badKindSigErr doc (L loc ty) - = setSrcSpan loc $ addErr $ - withHsDocContext doc $ - hang (text "Illegal kind signature:" <+> quotes (ppr ty)) - 2 (text "Perhaps you intended to use KindSignatures") - -dataKindsErr :: RnTyKiEnv -> HsType RdrName -> SDoc -dataKindsErr env thing - = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) - 2 (text "Perhaps you intended to use DataKinds") - where - pp_what | isRnKindLevel env = text "kind" - | otherwise = text "type" - -inTypeDoc :: HsType RdrName -> SDoc -inTypeDoc ty = text "In the type" <+> quotes (ppr ty) - -warnUnusedForAll :: SDoc -> LHsTyVarBndr Name -> FreeVars -> TcM () -warnUnusedForAll in_doc (L loc tv) used_names - = whenWOptM Opt_WarnUnusedForalls $ - unless (hsTyVarName tv `elemNameSet` used_names) $ - addWarnAt (Reason Opt_WarnUnusedForalls) loc $ - vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) - , in_doc ] - -opTyErr :: Outputable a => RdrName -> a -> SDoc -opTyErr op overall_ty - = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty)) - 2 extra - where - extra | op == dot_tv_RDR - = perhapsForallMsg - | otherwise - = text "Use TypeOperators to allow operators in types" - -emptyNonSymsErr :: HsType RdrName -> SDoc -emptyNonSymsErr overall_ty - = text "Operator applied to too few arguments:" <+> ppr overall_ty - -{- -************************************************************************ -* * - Finding the free type variables of a (HsType RdrName) -* * -************************************************************************ - - -Note [Kind and type-variable binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a type signature we may implicitly bind type variable and, more -recently, kind variables. For example: - * f :: a -> a - f = ... - Here we need to find the free type variables of (a -> a), - so that we know what to quantify - - * class C (a :: k) where ... - This binds 'k' in ..., as well as 'a' - - * f (x :: a -> [a]) = .... - Here we bind 'a' in .... - - * f (x :: T a -> T (b :: k)) = ... - Here we bind both 'a' and the kind variable 'k' - - * type instance F (T (a :: Maybe k)) = ...a...k... - Here we want to constrain the kind of 'a', and bind 'k'. - -In general we want to walk over a type, and find - * Its free type variables - * The free kind variables of any kind signatures in the type - -Hence we returns a pair (kind-vars, type vars) -See also Note [HsBSig binder lists] in HsTypes --} - -data FreeKiTyVars = FKTV { fktv_kis :: [Located RdrName] - , fktv_tys :: [Located RdrName] } - -instance Outputable FreeKiTyVars where - ppr (FKTV kis tys) = ppr (kis, tys) - -emptyFKTV :: FreeKiTyVars -emptyFKTV = FKTV [] [] - -freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName] -freeKiTyVarsAllVars (FKTV tys kvs) = tys ++ kvs - -freeKiTyVarsKindVars :: FreeKiTyVars -> [Located RdrName] -freeKiTyVarsKindVars = fktv_kis - -freeKiTyVarsTypeVars :: FreeKiTyVars -> [Located RdrName] -freeKiTyVarsTypeVars = fktv_tys - -filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars -filterInScope rdr_env (FKTV kis tys) - = FKTV (filterOut in_scope kis) - (filterOut in_scope tys) - where - in_scope = inScope rdr_env . unLoc - -inScope :: LocalRdrEnv -> RdrName -> Bool -inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env - -extractHsTyRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars --- extractHsTyRdrNames finds the free (kind, type) variables of a HsType --- or the free (sort, kind) variables of a HsKind --- It's used when making the for-alls explicit. --- Does not return any wildcards --- When the same name occurs multiple times in the types, only the first --- occurrence is returned. --- See Note [Kind and type-variable binders] -extractHsTyRdrTyVars ty - = do { FKTV kis tys <- extract_lty TypeLevel ty emptyFKTV - ; return (FKTV (nubL kis) - (nubL tys)) } - - --- | Extracts free type and kind variables from types in a list. --- When the same name occurs multiple times in the types, only the first --- occurrence is returned and the rest is filtered out. --- See Note [Kind and type-variable binders] -extractHsTysRdrTyVars :: [LHsType RdrName] -> RnM FreeKiTyVars -extractHsTysRdrTyVars tys - = rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys - --- | Extracts free type and kind variables from types in a list. --- When the same name occurs multiple times in the types, all occurrences --- are returned. -extractHsTysRdrTyVarsDups :: [LHsType RdrName] -> RnM FreeKiTyVars -extractHsTysRdrTyVarsDups tys - = extract_ltys TypeLevel tys emptyFKTV - --- | Removes multiple occurrences of the same name from FreeKiTyVars. -rmDupsInRdrTyVars :: FreeKiTyVars -> FreeKiTyVars -rmDupsInRdrTyVars (FKTV kis tys) - = FKTV (nubL kis) (nubL tys) - -extractRdrKindSigVars :: LFamilyResultSig RdrName -> RnM [Located RdrName] -extractRdrKindSigVars (L _ resultSig) - | KindSig k <- resultSig = kindRdrNameFromSig k - | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k - | otherwise = return [] - where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k - -extractDataDefnKindVars :: HsDataDefn RdrName -> RnM [Located RdrName] --- Get the scoped kind variables mentioned free in the constructor decls --- Eg: data T a = T1 (S (a :: k) | forall (b::k). T2 (S b) --- Here k should scope over the whole definition --- --- However, do NOT collect free kind vars from the deriving clauses: --- Eg: (Trac #14331) class C p q --- data D = D deriving ( C (a :: k) ) --- Here k should /not/ scope over the whole definition. We intend --- this to elaborate to: --- class C @k1 @k2 (p::k1) (q::k2) --- data D = D --- instance forall k (a::k). C @k @* a D where ... --- -extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig - , dd_cons = cons }) - = (nubL . freeKiTyVarsKindVars) <$> - (extract_lctxt TypeLevel ctxt =<< - extract_mb extract_lkind ksig =<< - foldrM (extract_con . unLoc) emptyFKTV cons) - where - extract_con (ConDeclGADT { }) acc = return acc - extract_con (ConDeclH98 { con_qvars = qvs - , con_cxt = ctxt, con_details = details }) acc - = extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<< - extract_mlctxt ctxt =<< - extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV - -extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> RnM FreeKiTyVars -extract_mlctxt Nothing acc = return acc -extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc - -extract_lctxt :: TypeOrKind - -> LHsContext RdrName -> FreeKiTyVars -> RnM FreeKiTyVars -extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt) - -extract_ltys :: TypeOrKind - -> [LHsType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars -extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys - -extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars) - -> Maybe a -> FreeKiTyVars -> RnM FreeKiTyVars -extract_mb _ Nothing acc = return acc -extract_mb f (Just x) acc = f x acc - -extract_lkind :: LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars -extract_lkind = extract_lty KindLevel - -extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars -extract_lty t_or_k (L _ ty) acc - = case ty of - HsTyVar _ ltv -> extract_tv t_or_k ltv acc - HsBangTy _ ty -> extract_lty t_or_k ty acc - HsRecTy flds -> foldrM (extract_lty t_or_k - . cd_fld_type . unLoc) acc - flds - HsAppsTy tys -> extract_apps t_or_k tys acc - HsAppTy ty1 ty2 -> extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsListTy ty -> extract_lty t_or_k ty acc - HsPArrTy ty -> extract_lty t_or_k ty acc - HsTupleTy _ tys -> extract_ltys t_or_k tys acc - HsSumTy tys -> extract_ltys t_or_k tys acc - HsFunTy ty1 ty2 -> extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsIParamTy _ ty -> extract_lty t_or_k ty acc - HsEqTy ty1 ty2 -> extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsOpTy ty1 tv ty2 -> extract_tv t_or_k tv =<< - extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsParTy ty -> extract_lty t_or_k ty acc - HsCoreTy {} -> return acc -- The type is closed - HsSpliceTy {} -> return acc -- Type splices mention no tvs - HsDocTy ty _ -> extract_lty t_or_k ty acc - HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc - HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc - HsTyLit _ -> return acc - HsKindSig ty ki -> extract_lty t_or_k ty =<< - extract_lkind ki acc - HsForAllTy { hst_bndrs = tvs, hst_body = ty } - -> extract_hs_tv_bndrs tvs acc =<< - extract_lty t_or_k ty emptyFKTV - HsQualTy { hst_ctxt = ctxt, hst_body = ty } - -> extract_lctxt t_or_k ctxt =<< - extract_lty t_or_k ty acc - -- We deal with these separately in rnLHsTypeWithWildCards - HsWildCardTy {} -> return acc - -extract_apps :: TypeOrKind - -> [LHsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars -extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys - -extract_app :: TypeOrKind -> LHsAppType RdrName -> FreeKiTyVars - -> RnM FreeKiTyVars -extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc -extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc - -extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars - -> FreeKiTyVars -> RnM FreeKiTyVars --- In (forall (a :: Maybe e). a -> b) we have --- 'a' is bound by the forall --- 'b' is a free type variable --- 'e' is a free kind variable -extract_hs_tv_bndrs tvs - (FKTV acc_kvs acc_tvs) - -- Note accumulator comes first - (FKTV body_kvs body_tvs) - | null tvs - = return $ - FKTV (body_kvs ++ acc_kvs) (body_tvs ++ acc_tvs) - | otherwise - = do { FKTV bndr_kvs _ - <- foldrM extract_lkind emptyFKTV [k | L _ (KindedTyVar _ k) <- tvs] - - ; let locals = map hsLTyVarName tvs - ; return $ - FKTV (filterOut ((`elem` locals) . unLoc) (bndr_kvs ++ body_kvs) - ++ acc_kvs) - (filterOut ((`elem` locals) . unLoc) body_tvs ++ acc_tvs) } - -extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars -> RnM FreeKiTyVars -extract_tv t_or_k ltv@(L _ tv) acc - | isRdrTyVar tv = case acc of - FKTV kvs tvs - | isTypeLevel t_or_k - -> do { when (ltv `elemRdr` kvs) $ - mixedVarsErr ltv - ; return (FKTV kvs (ltv : tvs)) } - | otherwise - -> do { when (ltv `elemRdr` tvs) $ - mixedVarsErr ltv - ; return (FKTV (ltv : kvs) tvs) } - | otherwise = return acc - where - elemRdr x = any (eqLocated x) - -mixedVarsErr :: Located RdrName -> RnM () -mixedVarsErr (L loc tv) - = do { typeintype <- xoptM LangExt.TypeInType - ; unless typeintype $ - addErrAt loc $ text "Variable" <+> quotes (ppr tv) <+> - text "used as both a kind and a type" $$ - text "Did you intend to use TypeInType?" } - --- just used in this module; seemed convenient here -nubL :: Eq a => [Located a] -> [Located a] -nubL = nubBy eqLocated diff --git a/simplCore/CSE.hs b/simplCore/CSE.hs deleted file mode 100644 --- a/simplCore/CSE.hs +++ /dev/null @@ -1,601 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section{Common subexpression} --} - -{-# LANGUAGE CPP #-} - -module CSE (cseProgram, cseOneExpr) where - -#include "HsVersions.h" - -import CoreSubst -import Var ( Var ) -import VarEnv ( elemInScopeSet ) -import Id ( Id, idType, idInlineActivation, isDeadBinder - , zapIdOccInfo, zapIdUsageInfo, idInlinePragma - , isJoinId ) -import CoreUtils ( mkAltExpr, eqExpr - , exprIsLiteralString - , stripTicksE, stripTicksT, mkTicks ) -import Type ( tyConAppArgs ) -import CoreSyn -import Outputable -import BasicTypes ( TopLevelFlag(..), isTopLevel - , isAlwaysActive, isAnyInlinePragma ) -import TrieMap -import Util ( filterOut ) -import Data.List ( mapAccumL ) - -{- - Simple common sub-expression - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we see - x1 = C a b - x2 = C x1 b -we build up a reverse mapping: C a b -> x1 - C x1 b -> x2 -and apply that to the rest of the program. - -When we then see - y1 = C a b - y2 = C y1 b -we replace the C a b with x1. But then we *dont* want to -add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 -so that a subsequent binding - y2 = C y1 b -will get transformed to C x1 b, and then to x2. - -So we carry an extra var->var substitution which we apply *before* looking up in the -reverse mapping. - - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -We have to be careful about shadowing. -For example, consider - f = \x -> let y = x+x in - h = \x -> x+x - in ... - -Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no -shadowing, but it doesn't any more (it proved too hard), so we clone as we go. -We can simply add clones to the substitution already described. - - -Note [CSE for bindings] -~~~~~~~~~~~~~~~~~~~~~~~ -Let-bindings have two cases, implemented by addBinding. - -* SUBSTITUTE: applies when the RHS is a variable - - let x = y in ...(h x).... - - Here we want to extend the /substitution/ with x -> y, so that the - (h x) in the body might CSE with an enclosing (let v = h y in ...). - NB: the substitution maps InIds, so we extend the substitution with - a binding for the original InId 'x' - - How can we have a variable on the RHS? Doesn't the simplifier inline them? - - - First, the original RHS might have been (g z) which has CSE'd - with an enclosing (let y = g z in ...). This is super-important. - See Trac #5996: - x1 = C a b - x2 = C x1 b - y1 = C a b - y2 = C y1 b - Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to - the substitution so that we can CSE the binding for y2. - - - Second, we use addBinding for case expression scrutinees too; - see Note [CSE for case expressions] - -* EXTEND THE REVERSE MAPPING: applies in all other cases - - let x = h y in ...(h y)... - - Here we want to extend the /reverse mapping (cs_map)/ so that - we CSE the (h y) call to x. - - Note that we use EXTEND even for a trivial expression, provided it - is not a variable or literal. In particular this /includes/ type - applications. This can be important (Trac #13156); e.g. - case f @ Int of { r1 -> - case f @ Int of { r2 -> ... - Here we want to common-up the two uses of (f @ Int) so we can - remove one of the case expressions. - - See also Note [Corner case for case expressions] for another - reason not to use SUBSTITUTE for all trivial expressions. - -Notice that - - The SUBSTITUTE situation extends the substitution (cs_subst) - - The EXTEND situation extends the reverse mapping (cs_map) - -Notice also that in the SUBSTITUTE case we leave behind a binding - x = y -even though we /also/ carry a substitution x -> y. Can we just drop -the binding instead? Well, not at top level! See SimplUtils -Note [Top level and postInlineUnconditionally]; and in any case CSE -applies only to the /bindings/ of the program, and we leave it to the -simplifier to propate effects to the RULES. Finally, it doesn't seem -worth the effort to discard the nested bindings because the simplifier -will do it next. - -Note [CSE for case expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - case scrut_expr of x { ...alts... } -This is very like a strict let-binding - let !x = scrut_expr in ... -So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a -result all the stuff under Note [CSE for bindings] applies directly. - -For example: - -* Trivial scrutinee - f = \x -> case x of wild { - (a:as) -> case a of wild1 { - (p,q) -> ...(wild1:as)... - - Here, (wild1:as) is morally the same as (a:as) and hence equal to - wild. But that's not quite obvious. In the rest of the compiler we - want to keep it as (wild1:as), but for CSE purpose that's a bad - idea. - - By using addBinding we add the binding (wild1 -> a) to the substitution, - which does exactly the right thing. - - (Notice this is exactly backwards to what the simplifier does, which - is to try to replaces uses of 'a' with uses of 'wild1'.) - - This is the main reason that addBinding is called with a trivial rhs. - -* Non-trivial scrutinee - case (f x) of y { pat -> ...let y = f x in ... } - - By using addBinding we'll add (f x :-> y) to the cs_map, and - thereby CSE the inner (f x) to y. - -Note [CSE for INLINE and NOINLINE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are some subtle interactions of CSE with functions that the user -has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.) -Consider - - yes :: Int {-# NOINLINE yes #-} - yes = undefined - - no :: Int {-# NOINLINE no #-} - no = undefined - - foo :: Int -> Int -> Int {-# NOINLINE foo #-} - foo m n = n - - {-# RULES "foo/no" foo no = id #-} - - bar :: Int -> Int - bar = foo yes - -We do not expect the rule to fire. But if we do CSE, then we risk -getting yes=no, and the rule does fire. Actually, it won't because -NOINLINE means that 'yes' will never be inlined, not even if we have -yes=no. So that's fine (now; perhaps in the olden days, yes=no would -have substituted even if 'yes' was NOINLINE). - -But we do need to take care. Consider - - {-# NOINLINE bar #-} - bar = -- Same rhs as foo - - foo = - -If CSE produces - foo = bar -then foo will never be inlined to (when it should be, if -is small). The conclusion here is this: - - We should not add - :-> bar - to the CSEnv if 'bar' has any constraints on when it can inline; - that is, if its 'activation' not always active. Otherwise we - might replace by 'bar', and then later be unable to see that it - really was . - -Note that we do not (currently) do CSE on the unfolding stored inside -an Id, even if is a 'stable' unfolding. That means that when an -unfolding happens, it is always faithful to what the stable unfolding -originally was. - -Note [CSE for stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - {-# Unf = Stable (\pq. build blah) #-} - foo = x - -Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial. -(Turns out that this actually happens for the enumFromTo method of -the Integer instance of Enum in GHC.Enum.) Suppose moreover that foo's -stable unfolding originates from an INLINE or INLINEABLE pragma on foo. -Then we obviously do NOT want to extend the substitution with (foo->x), -because we promised to inline foo as what the user wrote. See similar -SimplUtils Note [Stable unfoldings and postInlineUnconditionally]. - -Nor do we want to change the reverse mapping. Suppose we have - - {-# Unf = Stable (\pq. build blah) #-} - foo = - bar = - -There could conceivably be merit in rewriting the RHS of bar: - bar = foo -but now bar's inlining behaviour will change, and importing -modules might see that. So it seems dodgy and we don't do it. - -Stable unfoldings are also created during worker/wrapper when we decide -that a function's definition is so small that it should always inline. -In this case we still want to do CSE (#13340). Hence the use of -isAnyInlinePragma rather than isStableUnfolding. - -Note [Corner case for case expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is another reason that we do not use SUBSTITUTE for -all trivial expressions. Consider - case x |> co of (y::Array# Int) { ... } - -We do not want to extend the substitution with (y -> x |> co); since y -is of unlifted type, this would destroy the let/app invariant if (x |> -co) was not ok-for-speculation. - -But surely (x |> co) is ok-for-speculation, becasue it's a trivial -expression, and x's type is also unlifted, presumably. Well, maybe -not if you are using unsafe casts. I actually found a case where we -had - (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int) - -Note [CSE for join points?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must not be naive about join points in CSE: - join j = e in - if b then jump j else 1 + e -The expression (1 + jump j) is not good (see Note [Invariants on join points] in -CoreSyn). This seems to come up quite seldom, but it happens (first seen -compiling ppHtml in Haddock.Backends.Xhtml). - -We could try and be careful by tracking which join points are still valid at -each subexpression, but since join points aren't allocated or shared, there's -less to gain by trying to CSE them. - -Note [CSE for recursive bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f = \x ... f.... - g = \y ... g ... -where the "..." are identical. Could we CSE them? In full generality -with mutual recursion it's quite hard; but for self-recursive bindings -(which are very common) it's rather easy: - -* Maintain a separate cs_rec_map, that maps - (\f. (\x. ...f...) ) -> f - Note the \f in the domain of the mapping! - -* When we come across the binding for 'g', look up (\g. (\y. ...g...)) - Bingo we get a hit. So we can replace the 'g' binding with - g = f - -We can't use cs_map for this, because the key isn't an expression of -the program; it's a kind of synthetic key for recursive bindings. - - -************************************************************************ -* * -\section{Common subexpression} -* * -************************************************************************ --} - -cseProgram :: CoreProgram -> CoreProgram -cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds) - -cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind) -cseBind toplevel env (NonRec b e) - = (env2, NonRec b2 e2) - where - (env1, b1) = addBinder env b - (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1 - -cseBind _ env (Rec [(in_id, rhs)]) - | noCSE in_id - = (env1, Rec [(out_id, rhs')]) - - -- See Note [CSE for recursive bindings] - | Just previous <- lookupCSRecEnv env out_id rhs'' - , let previous' = mkTicks ticks previous - = (extendCSSubst env1 in_id previous', NonRec out_id previous') - - | otherwise - = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')]) - - where - (env1, [out_id]) = addRecBinders env [in_id] - rhs' = cseExpr env1 rhs - rhs'' = stripTicksE tickishFloatable rhs' - ticks = stripTicksT tickishFloatable rhs' - id_expr' = varToCoreExpr out_id - zapped_id = zapIdUsageInfo out_id - -cseBind toplevel env (Rec pairs) - = (env2, Rec pairs') - where - (env1, bndrs1) = addRecBinders env (map fst pairs) - (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1) - - do_one env (pr, b1) = cse_bind toplevel env pr b1 - -cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr)) -cse_bind toplevel env (in_id, in_rhs) out_id - | isTopLevel toplevel, exprIsLiteralString in_rhs - -- See Note [Take care with literal strings] - = (env', (out_id, in_rhs)) - - | otherwise - = (env', (out_id', out_rhs)) - where - out_rhs = tryForCSE env in_rhs - (env', out_id') = addBinding env in_id out_id out_rhs - -addBinding :: CSEnv -- Includes InId->OutId cloning - -> InVar -- Could be a let-bound type - -> OutId -> OutExpr -- Processed binding - -> (CSEnv, OutId) -- Final env, final bndr --- Extend the CSE env with a mapping [rhs -> out-id] --- unless we can instead just substitute [in-id -> rhs] --- --- It's possible for the binder to be a type variable (see --- Note [Type-let] in CoreSyn), in which case we can just substitute. -addBinding env in_id out_id rhs' - | not (isId in_id) = (extendCSSubst env in_id rhs', out_id) - | noCSE in_id = (env, out_id) - | use_subst = (extendCSSubst env in_id rhs', out_id) - | otherwise = (extendCSEnv env rhs' id_expr', zapped_id) - where - id_expr' = varToCoreExpr out_id - zapped_id = zapIdUsageInfo out_id - -- Putting the Id into the cs_map makes it possible that - -- it'll become shared more than it is now, which would - -- invalidate (the usage part of) its demand info. - -- This caused Trac #100218. - -- Easiest thing is to zap the usage info; subsequently - -- performing late demand-analysis will restore it. Don't zap - -- the strictness info; it's not necessary to do so, and losing - -- it is bad for performance if you don't do late demand - -- analysis - - -- Should we use SUBSTITUTE or EXTEND? - -- See Note [CSE for bindings] - use_subst = case rhs' of - Var {} -> True - _ -> False - -noCSE :: InId -> Bool -noCSE id = not (isAlwaysActive (idInlineActivation id)) - -- See Note [CSE for INLINE and NOINLINE] - || isAnyInlinePragma (idInlinePragma id) - -- See Note [CSE for stable unfoldings] - || isJoinId id - -- See Note [CSE for join points?] - - -{- Note [Take care with literal strings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example: - - x = "foo"# - y = "foo"# - ...x...y...x...y.... - -We would normally turn this into: - - x = "foo"# - y = x - ...x...x...x...x.... - -But this breaks an invariant of Core, namely that the RHS of a top-level binding -of type Addr# must be a string literal, not another variable. See Note -[CoreSyn top-level string literals] in CoreSyn. - -For this reason, we special case top-level bindings to literal strings and leave -the original RHS unmodified. This produces: - - x = "foo"# - y = "foo"# - ...x...x...x...x.... - -Now 'y' will be discarded as dead code, and we are done. - -The net effect is that for the y-binding we want to - - Use SUBSTITUTE, by extending the substitution with y :-> x - - but leave the original binding for y undisturbed - -This is done by cse_bind. I got it wrong the first time (Trac #13367). --} - -tryForCSE :: CSEnv -> InExpr -> OutExpr -tryForCSE env expr - | Just e <- lookupCSEnv env expr'' = mkTicks ticks e - | otherwise = expr' - -- The varToCoreExpr is needed if we have - -- case e of xco { ...case e of yco { ... } ... } - -- Then CSE will substitute yco -> xco; - -- but these are /coercion/ variables - where - expr' = cseExpr env expr - expr'' = stripTicksE tickishFloatable expr' - ticks = stripTicksT tickishFloatable expr' - -- We don't want to lose the source notes when a common sub - -- expression gets eliminated. Hence we push all (!) of them on - -- top of the replaced sub-expression. This is probably not too - -- useful in practice, but upholds our semantics. - -cseOneExpr :: InExpr -> OutExpr -cseOneExpr = cseExpr emptyCSEnv - -cseExpr :: CSEnv -> InExpr -> OutExpr -cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) -cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) -cseExpr _ (Lit lit) = Lit lit -cseExpr env (Var v) = lookupSubst env v -cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) -cseExpr env (Tick t e) = Tick t (cseExpr env e) -cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co) -cseExpr env (Lam b e) = let (env', b') = addBinder env b - in Lam b' (cseExpr env' e) -cseExpr env (Let bind e) = let (env', bind') = cseBind NotTopLevel env bind - in Let bind' (cseExpr env' e) -cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts - -cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr -cseCase env scrut bndr ty alts - = Case scrut1 bndr3 ty' $ - combineAlts alt_env (map cse_alt alts) - where - ty' = substTy (csEnvSubst env) ty - scrut1 = tryForCSE env scrut - - bndr1 = zapIdOccInfo bndr - -- Zapping the OccInfo is needed because the extendCSEnv - -- in cse_alt may mean that a dead case binder - -- becomes alive, and Lint rejects that - (env1, bndr2) = addBinder env bndr1 - (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1 - -- addBinding: see Note [CSE for case expressions] - - con_target :: OutExpr - con_target = lookupSubst alt_env bndr - - arg_tys :: [OutType] - arg_tys = tyConAppArgs (idType bndr3) - - cse_alt (DataAlt con, args, rhs) - | not (null args) - -- Don't try CSE if there are no args; it just increases the number - -- of live vars. E.g. - -- case x of { True -> ....True.... } - -- Don't replace True by x! - -- Hence the 'null args', which also deal with literals and DEFAULT - = (DataAlt con, args', tryForCSE new_env rhs) - where - (env', args') = addBinders alt_env args - new_env = extendCSEnv env' con_expr con_target - con_expr = mkAltExpr (DataAlt con) args' arg_tys - - cse_alt (con, args, rhs) - = (con, args', tryForCSE env' rhs) - where - (env', args') = addBinders alt_env args - -combineAlts :: CSEnv -> [InAlt] -> [InAlt] --- See Note [Combine case alternatives] -combineAlts env ((_,bndrs1,rhs1) : rest_alts) - | all isDeadBinder bndrs1 - = (DEFAULT, [], rhs1) : filtered_alts - where - in_scope = substInScope (csEnvSubst env) - filtered_alts = filterOut identical rest_alts - identical (_con, bndrs, rhs) = all ok bndrs && eqExpr in_scope rhs1 rhs - ok bndr = isDeadBinder bndr || not (bndr `elemInScopeSet` in_scope) - -combineAlts _ alts = alts -- Default case - -{- Note [Combine case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -combineAlts is just a more heavyweight version of the use of -combineIdentialAlts in SimplUtils.prepareAlts. The basic idea is -to transform - - DEFAULT -> e1 - K x -> e1 - W y z -> e2 -===> - DEFAULT -> e1 - W y z -> e2 - -In the simplifier we use cheapEqExpr, because it is called a lot. -But here in CSE we use the full eqExpr. After all, two alterantives usually -differ near the root, so it probably isn't expensive to compare the full -alternative. It seems like the the same kind of thing that CSE is supposed -to be doing, which is why I put it here. - -I acutally saw some examples in the wild, where some inlining made e1 too -big for cheapEqExpr to catch it. - - -************************************************************************ -* * -\section{The CSE envt} -* * -************************************************************************ --} - -data CSEnv - = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs - -- The substitution variables to - -- /trivial/ OutExprs, not arbitrary expressions - - , cs_map :: CoreMap OutExpr -- The reverse mapping - -- Maps a OutExpr to a /trivial/ OutExpr - -- The key of cs_map is stripped of all Ticks - - , cs_rec_map :: CoreMap OutExpr - -- See Note [CSE for recursive bindings] - } - -emptyCSEnv :: CSEnv -emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap - , cs_subst = emptySubst } - -lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr -lookupCSEnv (CS { cs_map = csmap }) expr - = lookupCoreMap csmap expr - -extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv -extendCSEnv cse expr triv_expr - = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr } - where - sexpr = stripTicksE tickishFloatable expr - -extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv --- See Note [CSE for recursive bindings] -extendCSRecEnv cse bndr expr triv_expr - = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr } - -lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr --- See Note [CSE for recursive bindings] -lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr - = lookupCoreMap csmap (Lam bndr expr) - -csEnvSubst :: CSEnv -> Subst -csEnvSubst = cs_subst - -lookupSubst :: CSEnv -> Id -> OutExpr -lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x - -extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv -extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs } - -addBinder :: CSEnv -> Var -> (CSEnv, Var) -addBinder cse v = (cse { cs_subst = sub' }, v') - where - (sub', v') = substBndr (cs_subst cse) v - -addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) -addBinders cse vs = (cse { cs_subst = sub' }, vs') - where - (sub', vs') = substBndrs (cs_subst cse) vs - -addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) -addRecBinders cse vs = (cse { cs_subst = sub' }, vs') - where - (sub', vs') = substRecBndrs (cs_subst cse) vs diff --git a/simplCore/CallArity.hs b/simplCore/CallArity.hs deleted file mode 100644 --- a/simplCore/CallArity.hs +++ /dev/null @@ -1,739 +0,0 @@ --- --- Copyright (c) 2014 Joachim Breitner --- - -module CallArity - ( callArityAnalProgram - , callArityRHS -- for testing - ) where - -import VarSet -import VarEnv -import DynFlags ( DynFlags ) - -import BasicTypes -import CoreSyn -import Id -import CoreArity ( typeArity ) -import CoreUtils ( exprIsCheap, exprIsTrivial ) ---import Outputable -import UnVarGraph -import Demand - -import Control.Arrow ( first, second ) - - -{- -%************************************************************************ -%* * - Call Arity Analyis -%* * -%************************************************************************ - -Note [Call Arity: The goal] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The goal of this analysis is to find out if we can eta-expand a local function, -based on how it is being called. The motivating example is this code, -which comes up when we implement foldl using foldr, and do list fusion: - - let go = \x -> let d = case ... of - False -> go (x+1) - True -> id - in \z -> d (x + z) - in go 1 0 - -If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of -partial function applications, which would be bad. - -The function `go` has a type of arity two, but only one lambda is manifest. -Furthermore, an analysis that only looks at the RHS of go cannot be sufficient -to eta-expand go: If `go` is ever called with one argument (and the result used -multiple times), we would be doing the work in `...` multiple times. - -So `callArityAnalProgram` looks at the whole let expression to figure out if -all calls are nice, i.e. have a high enough arity. It then stores the result in -the `calledArity` field of the `IdInfo` of `go`, which the next simplifier -phase will eta-expand. - -The specification of the `calledArity` field is: - - No work will be lost if you eta-expand me to the arity in `calledArity`. - -What we want to know for a variable ------------------------------------ - -For every let-bound variable we'd like to know: - 1. A lower bound on the arity of all calls to the variable, and - 2. whether the variable is being called at most once or possible multiple - times. - -It is always ok to lower the arity, or pretend that there are multiple calls. -In particular, "Minimum arity 0 and possible called multiple times" is always -correct. - - -What we want to know from an expression ---------------------------------------- - -In order to obtain that information for variables, we analyize expression and -obtain bits of information: - - I. The arity analysis: - For every variable, whether it is absent, or called, - and if called, which what arity. - - II. The Co-Called analysis: - For every two variables, whether there is a possibility that both are being - called. - We obtain as a special case: For every variables, whether there is a - possibility that it is being called twice. - -For efficiency reasons, we gather this information only for a set of -*interesting variables*, to avoid spending time on, e.g., variables from pattern matches. - -The two analysis are not completely independent, as a higher arity can improve -the information about what variables are being called once or multiple times. - -Note [Analysis I: The arity analyis] ------------------------------------- - -The arity analysis is quite straight forward: The information about an -expression is an - VarEnv Arity -where absent variables are bound to Nothing and otherwise to a lower bound to -their arity. - -When we analyize an expression, we analyize it with a given context arity. -Lambdas decrease and applications increase the incoming arity. Analysizing a -variable will put that arity in the environment. In lets or cases all the -results from the various subexpressions are lubed, which takes the point-wise -minimum (considering Nothing an infinity). - - -Note [Analysis II: The Co-Called analysis] ------------------------------------------- - -The second part is more sophisticated. For reasons explained below, it is not -sufficient to simply know how often an expression evaluates a variable. Instead -we need to know which variables are possibly called together. - -The data structure here is an undirected graph of variables, which is provided -by the abstract - UnVarGraph - -It is safe to return a larger graph, i.e. one with more edges. The worst case -(i.e. the least useful and always correct result) is the complete graph on all -free variables, which means that anything can be called together with anything -(including itself). - -Notation for the following: -C(e) is the co-called result for e. -G₁∪G₂ is the union of two graphs -fv is the set of free variables (conveniently the domain of the arity analysis result) -S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ } -S² is the complete graph on the set of variables S, S² = S×S -C'(e) is a variant for bound expression: - If e is called at most once, or it is and stays a thunk (after the analysis), - it is simply C(e). Otherwise, the expression can be called multiple times - and we return (fv e)² - -The interesting cases of the analysis: - * Var v: - No other variables are being called. - Return {} (the empty graph) - * Lambda v e, under arity 0: - This means that e can be evaluated many times and we cannot get - any useful co-call information. - Return (fv e)² - * Case alternatives alt₁,alt₂,...: - Only one can be execuded, so - Return (alt₁ ∪ alt₂ ∪...) - * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂: - We get the results from both sides, with the argument evaluated at most once. - Additionally, anything called by e₁ can possibly be called with anything - from e₂. - Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂) - * App e₁ x: - As this is already in A-normal form, CorePrep will not separately lambda - bind (and hence share) x. So we conservatively assume multiple calls to x here - Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)} - * Let v = rhs in body: - In addition to the results from the subexpressions, add all co-calls from - everything that the body calls together with v to everthing that is called - by v. - Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)} - * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body - Tricky. - We assume that it is really mutually recursive, i.e. that every variable - calls one of the others, and that this is strongly connected (otherwise we - return an over-approximation, so that's ok), see note [Recursion and fixpointing]. - - Let V = {v₁,...vₙ}. - Assume that the vs have been analysed with an incoming demand and - cardinality consistent with the final result (this is the fixed-pointing). - Again we can use the results from all subexpressions. - In addition, for every variable vᵢ, we need to find out what it is called - with (call this set Sᵢ). There are two cases: - * If vᵢ is a function, we need to go through all right-hand-sides and bodies, - and collect every variable that is called together with any variable from V: - Sᵢ = {v' | j ∈ {1,...,n}, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } - * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to - exclude it from this set: - Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } - Finally, combine all this: - Return: C(body) ∪ - C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ - (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ) - -Using the result: Eta-Expansion -------------------------------- - -We use the result of these two analyses to decide whether we can eta-expand the -rhs of a let-bound variable. - -If the variable is already a function (exprIsCheap), and all calls to the -variables have a higher arity than the current manifest arity (i.e. the number -of lambdas), expand. - -If the variable is a thunk we must be careful: Eta-Expansion will prevent -sharing of work, so this is only safe if there is at most one call to the -function. Therefore, we check whether {v,v} ∈ G. - - Example: - - let n = case .. of .. -- A thunk! - in n 0 + n 1 - - vs. - - let n = case .. of .. - in case .. of T -> n 0 - F -> n 1 - - We are only allowed to eta-expand `n` if it is going to be called at most - once in the body of the outer let. So we need to know, for each variable - individually, that it is going to be called at most once. - - -Why the co-call graph? ----------------------- - -Why is it not sufficient to simply remember which variables are called once and -which are called multiple times? It would be in the previous example, but consider - - let n = case .. of .. - in case .. of - True -> let go = \y -> case .. of - True -> go (y + n 1) - False > n - in go 1 - False -> n - -vs. - - let n = case .. of .. - in case .. of - True -> let go = \y -> case .. of - True -> go (y+1) - False > n - in go 1 - False -> n - -In both cases, the body and the rhs of the inner let call n at most once. -But only in the second case that holds for the whole expression! The -crucial difference is that in the first case, the rhs of `go` can call -*both* `go` and `n`, and hence can call `n` multiple times as it recurses, -while in the second case find out that `go` and `n` are not called together. - - -Why co-call information for functions? --------------------------------------- - -Although for eta-expansion we need the information only for thunks, we still -need to know whether functions are being called once or multiple times, and -together with what other functions. - - Example: - - let n = case .. of .. - f x = n (x+1) - in f 1 + f 2 - - vs. - - let n = case .. of .. - f x = n (x+1) - in case .. of T -> f 0 - F -> f 1 - - Here, the body of f calls n exactly once, but f itself is being called - multiple times, so eta-expansion is not allowed. - - -Note [Analysis type signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The work-hourse of the analysis is the function `callArityAnal`, with the -following type: - - type CallArityRes = (UnVarGraph, VarEnv Arity) - callArityAnal :: - Arity -> -- The arity this expression is called with - VarSet -> -- The set of interesting variables - CoreExpr -> -- The expression to analyse - (CallArityRes, CoreExpr) - -and the following specification: - - ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr - - <=> - - Assume the expression `expr` is being passed `arity` arguments. Then it holds that - * The domain of `callArityEnv` is a subset of `interestingIds`. - * Any variable from `interestingIds` that is not mentioned in the `callArityEnv` - is absent, i.e. not called at all. - * Every call from `expr` to a variable bound to n in `callArityEnv` has at - least n value arguments. - * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`, - then in no execution of `expr` both are being called. - Furthermore, expr' is expr with the callArity field of the `IdInfo` updated. - - -Note [Which variables are interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The analysis would quickly become prohibitive expensive if we would analyse all -variables; for most variables we simply do not care about how often they are -called, i.e. variables bound in a pattern match. So interesting are variables that are - * top-level or let bound - * and possibly functions (typeArity > 0) - -Note [Taking boring variables into account] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -If we decide that the variable bound in `let x = e1 in e2` is not interesting, -the analysis of `e2` will not report anything about `x`. To ensure that -`callArityBind` does still do the right thing we have to take that into account -everytime we would be lookup up `x` in the analysis result of `e2`. - * Instead of calling lookupCallArityRes, we return (0, True), indicating - that this variable might be called many times with no arguments. - * Instead of checking `calledWith x`, we assume that everything can be called - with it. - * In the recursive case, when calclulating the `cross_calls`, if there is - any boring variable in the recursive group, we ignore all co-call-results - and directly go to a very conservative assumption. - -The last point has the nice side effect that the relatively expensive -integration of co-call results in a recursive groups is often skipped. This -helped to avoid the compile time blowup in some real-world code with large -recursive groups (#10293). - -Note [Recursion and fixpointing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For a mutually recursive let, we begin by - 1. analysing the body, using the same incoming arity as for the whole expression. - 2. Then we iterate, memoizing for each of the bound variables the last - analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes. - 3. We combine the analysis result from the body and the memoized results for - the arguments (if already present). - 4. For each variable, we find out the incoming arity and whether it is called - once, based on the the current analysis result. If this differs from the - memoized results, we re-analyse the rhs and update the memoized table. - 5. If nothing had to be reanalyzed, we are done. - Otherwise, repeat from step 3. - - -Note [Thunks in recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We never eta-expand a thunk in a recursive group, on the grounds that if it is -part of a recursive group, then it will be called multipe times. - -This is not necessarily true, e.g. it would be safe to eta-expand t2 (but not -t1) in the following code: - - let go x = t1 - t1 = if ... then t2 else ... - t2 = if ... then go 1 else ... - in go 0 - -Detecting this would require finding out what variables are only ever called -from thunks. While this is certainly possible, we yet have to see this to be -relevant in the wild. - - -Note [Analysing top-level binds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We can eta-expand top-level-binds if they are not exported, as we see all calls -to them. The plan is as follows: Treat the top-level binds as nested lets around -a body representing “all external calls”, which returns a pessimistic -CallArityRes (the co-call graph is the complete graph, all arityies 0). - -Note [Trimming arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In the Call Arity papers, we are working on an untyped lambda calculus with no -other id annotations, where eta-expansion is always possible. But this is not -the case for Core! - 1. We need to ensure the invariant - callArity e <= typeArity (exprType e) - for the same reasons that exprArity needs this invariant (see Note - [exprArity invariant] in CoreArity). - - If we are not doing that, a too-high arity annotation will be stored with - the id, confusing the simplifier later on. - - 2. Eta-expanding a right hand side might invalidate existing annotations. In - particular, if an id has a strictness annotation of <...><...>b, then - passing two arguments to it will definitely bottom out, so the simplifier - will throw away additional parameters. This conflicts with Call Arity! So - we ensure that we never eta-expand such a value beyond the number of - arguments mentioned in the strictness signature. - See #10176 for a real-world-example. - -Note [What is a thunk] -~~~~~~~~~~~~~~~~~~~~~~ - -Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a -thunk, not eta-expanded, to avoid losing any sharing. This is also how the -published papers on Call Arity describe it. - -In practice, there are thunks that do a just little work, such as -pattern-matching on a variable, and the benefits of eta-expansion likely -oughtweigh the cost of doing that repeatedly. Therefore, this implementation of -Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk. --} - --- Main entry point - -callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram -callArityAnalProgram _dflags binds = binds' - where - (_, binds') = callArityTopLvl [] emptyVarSet binds - --- See Note [Analysing top-level-binds] -callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind]) -callArityTopLvl exported _ [] - = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported]) - , [] ) -callArityTopLvl exported int1 (b:bs) - = (ae2, b':bs') - where - int2 = bindersOf b - exported' = filter isExportedId int2 ++ exported - int' = int1 `addInterestingBinds` b - (ae1, bs') = callArityTopLvl exported' int' bs - (ae2, b') = callArityBind (boringBinds b) ae1 int1 b - - -callArityRHS :: CoreExpr -> CoreExpr -callArityRHS = snd . callArityAnal 0 emptyVarSet - --- The main analysis function. See Note [Analysis type signature] -callArityAnal :: - Arity -> -- The arity this expression is called with - VarSet -> -- The set of interesting variables - CoreExpr -> -- The expression to analyse - (CallArityRes, CoreExpr) - -- How this expression uses its interesting variables - -- and the expression with IdInfo updated - --- The trivial base cases -callArityAnal _ _ e@(Lit _) - = (emptyArityRes, e) -callArityAnal _ _ e@(Type _) - = (emptyArityRes, e) -callArityAnal _ _ e@(Coercion _) - = (emptyArityRes, e) --- The transparent cases -callArityAnal arity int (Tick t e) - = second (Tick t) $ callArityAnal arity int e -callArityAnal arity int (Cast e co) - = second (\e -> Cast e co) $ callArityAnal arity int e - --- The interesting case: Variables, Lambdas, Lets, Applications, Cases -callArityAnal arity int e@(Var v) - | v `elemVarSet` int - = (unitArityRes v arity, e) - | otherwise - = (emptyArityRes, e) - --- Non-value lambdas are ignored -callArityAnal arity int (Lam v e) | not (isId v) - = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e - --- We have a lambda that may be called multiple times, so its free variables --- can all be co-called. -callArityAnal 0 int (Lam v e) - = (ae', Lam v e') - where - (ae, e') = callArityAnal 0 (int `delVarSet` v) e - ae' = calledMultipleTimes ae --- We have a lambda that we are calling. decrease arity. -callArityAnal arity int (Lam v e) - = (ae, Lam v e') - where - (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e - --- Application. Increase arity for the called expression, nothing to know about --- the second -callArityAnal arity int (App e (Type t)) - = second (\e -> App e (Type t)) $ callArityAnal arity int e -callArityAnal arity int (App e1 e2) - = (final_ae, App e1' e2') - where - (ae1, e1') = callArityAnal (arity + 1) int e1 - (ae2, e2') = callArityAnal 0 int e2 - -- If the argument is trivial (e.g. a variable), then it will _not_ be - -- let-bound in the Core to STG transformation (CorePrep actually), - -- so no sharing will happen here, and we have to assume many calls. - ae2' | exprIsTrivial e2 = calledMultipleTimes ae2 - | otherwise = ae2 - final_ae = ae1 `both` ae2' - --- Case expression. -callArityAnal arity int (Case scrut bndr ty alts) - = -- pprTrace "callArityAnal:Case" - -- (vcat [ppr scrut, ppr final_ae]) - (final_ae, Case scrut' bndr ty alts') - where - (alt_aes, alts') = unzip $ map go alts - go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e - in (ae, (dc, bndrs, e')) - alt_ae = lubRess alt_aes - (scrut_ae, scrut') = callArityAnal 0 int scrut - final_ae = scrut_ae `both` alt_ae - --- For lets, use callArityBind -callArityAnal arity int (Let bind e) - = -- pprTrace "callArityAnal:Let" - -- (vcat [ppr v, ppr arity, ppr n, ppr final_ae ]) - (final_ae, Let bind' e') - where - int_body = int `addInterestingBinds` bind - (ae_body, e') = callArityAnal arity int_body e - (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind - --- Which bindings should we look at? --- See Note [Which variables are interesting] -isInteresting :: Var -> Bool -isInteresting v = not $ null (typeArity (idType v)) - -interestingBinds :: CoreBind -> [Var] -interestingBinds = filter isInteresting . bindersOf - -boringBinds :: CoreBind -> VarSet -boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf - -addInterestingBinds :: VarSet -> CoreBind -> VarSet -addInterestingBinds int bind - = int `delVarSetList` bindersOf bind -- Possible shadowing - `extendVarSetList` interestingBinds bind - --- Used for both local and top-level binds --- Second argument is the demand from the body -callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind) --- Non-recursive let -callArityBind boring_vars ae_body int (NonRec v rhs) - | otherwise - = -- pprTrace "callArityBind:NonRec" - -- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity]) - (final_ae, NonRec v' rhs') - where - is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk] - -- If v is boring, we will not find it in ae_body, but always assume (0, False) - boring = v `elemVarSet` boring_vars - - (arity, called_once) - | boring = (0, False) -- See Note [Taking boring variables into account] - | otherwise = lookupCallArityRes ae_body v - safe_arity | called_once = arity - | is_thunk = 0 -- A thunk! Do not eta-expand - | otherwise = arity - - -- See Note [Trimming arity] - trimmed_arity = trimArity v safe_arity - - (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs - - - ae_rhs'| called_once = ae_rhs - | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once - | otherwise = calledMultipleTimes ae_rhs - - called_by_v = domRes ae_rhs' - called_with_v - | boring = domRes ae_body - | otherwise = calledWith ae_body v `delUnVarSet` v - final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body - - v' = v `setIdCallArity` trimmed_arity - - --- Recursive let. See Note [Recursion and fixpointing] -callArityBind boring_vars ae_body int b@(Rec binds) - = -- (if length binds > 300 then - -- pprTrace "callArityBind:Rec" - -- (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $ - (final_ae, Rec binds') - where - -- See Note [Taking boring variables into account] - any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds] - - int_body = int `addInterestingBinds` b - (ae_rhs, binds') = fix initial_binds - final_ae = bindersOf b `resDelList` ae_rhs - - initial_binds = [(i,Nothing,e) | (i,e) <- binds] - - fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)]) - fix ann_binds - | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $ - any_change - = fix ann_binds' - | otherwise - = (ae, map (\(i, _, e) -> (i, e)) ann_binds') - where - aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ] - ae = callArityRecEnv any_boring aes_old ae_body - - rerun (i, mbLastRun, rhs) - | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae) - -- No call to this yet, so do nothing - = (False, (i, Nothing, rhs)) - - | Just (old_called_once, old_arity, _) <- mbLastRun - , called_once == old_called_once - , new_arity == old_arity - -- No change, no need to re-analyze - = (False, (i, mbLastRun, rhs)) - - | otherwise - -- We previously analyzed this with a different arity (or not at all) - = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk] - - safe_arity | is_thunk = 0 -- See Note [Thunks in recursive groups] - | otherwise = new_arity - - -- See Note [Trimming arity] - trimmed_arity = trimArity i safe_arity - - (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs - - ae_rhs' | called_once = ae_rhs - | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once - | otherwise = calledMultipleTimes ae_rhs - - in (True, (i `setIdCallArity` trimmed_arity, Just (called_once, new_arity, ae_rhs'), rhs')) - where - -- See Note [Taking boring variables into account] - (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False) - | otherwise = lookupCallArityRes ae i - - (changes, ann_binds') = unzip $ map rerun ann_binds - any_change = or changes - --- Combining the results from body and rhs, (mutually) recursive case --- See Note [Analysis II: The Co-Called analysis] -callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes -callArityRecEnv any_boring ae_rhss ae_body - = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $ - ae_new - where - vars = map fst ae_rhss - - ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body - - cross_calls - -- See Note [Taking boring variables into account] - | any_boring = completeGraph (domRes ae_combined) - -- Also, calculating cross_calls is expensive. Simply be conservative - -- if the mutually recursive group becomes too large. - | length ae_rhss > 25 = completeGraph (domRes ae_combined) - | otherwise = unionUnVarGraphs $ map cross_call ae_rhss - cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v - where - is_thunk = idCallArity v == 0 - -- What rhs are relevant as happening before (or after) calling v? - -- If v is a thunk, everything from all the _other_ variables - -- If v is not a thunk, everything can happen. - ae_before_v | is_thunk = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body - | otherwise = ae_combined - -- What do we want to know from these? - -- Which calls can happen next to any recursive call. - called_with_v - = unionUnVarSets $ map (calledWith ae_before_v) vars - called_by_v = domRes ae_rhs - - ae_new = first (cross_calls `unionUnVarGraph`) ae_combined - --- See Note [Trimming arity] -trimArity :: Id -> Arity -> Arity -trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] - where - max_arity_by_type = length (typeArity (idType v)) - max_arity_by_strsig - | isBotRes result_info = length demands - | otherwise = a - - (demands, result_info) = splitStrictSig (idStrictness v) - ---------------------------------------- --- Functions related to CallArityRes -- ---------------------------------------- - --- Result type for the two analyses. --- See Note [Analysis I: The arity analyis] --- and Note [Analysis II: The Co-Called analysis] -type CallArityRes = (UnVarGraph, VarEnv Arity) - -emptyArityRes :: CallArityRes -emptyArityRes = (emptyUnVarGraph, emptyVarEnv) - -unitArityRes :: Var -> Arity -> CallArityRes -unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity) - -resDelList :: [Var] -> CallArityRes -> CallArityRes -resDelList vs ae = foldr resDel ae vs - -resDel :: Var -> CallArityRes -> CallArityRes -resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v) - -domRes :: CallArityRes -> UnVarSet -domRes (_, ae) = varEnvDom ae - --- In the result, find out the minimum arity and whether the variable is called --- at most once. -lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool) -lookupCallArityRes (g, ae) v - = case lookupVarEnv ae v of - Just a -> (a, not (v `elemUnVarSet` (neighbors g v))) - Nothing -> (0, False) - -calledWith :: CallArityRes -> Var -> UnVarSet -calledWith (g, _) v = neighbors g v - -addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes -addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`) - --- Replaces the co-call graph by a complete graph (i.e. no information) -calledMultipleTimes :: CallArityRes -> CallArityRes -calledMultipleTimes res = first (const (completeGraph (domRes res))) res - --- Used for application and cases -both :: CallArityRes -> CallArityRes -> CallArityRes -both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2 - --- Used when combining results from alternative cases; take the minimum -lubRes :: CallArityRes -> CallArityRes -> CallArityRes -lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2) - -lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity -lubArityEnv = plusVarEnv_C min - -lubRess :: [CallArityRes] -> CallArityRes -lubRess = foldl lubRes emptyArityRes diff --git a/simplCore/CoreMonad.hs b/simplCore/CoreMonad.hs deleted file mode 100644 --- a/simplCore/CoreMonad.hs +++ /dev/null @@ -1,814 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[CoreMonad]{The core pipeline monad} --} - -{-# LANGUAGE CPP #-} - -module CoreMonad ( - -- * Configuration of the core-to-core passes - CoreToDo(..), runWhen, runMaybe, - SimplifierMode(..), - FloatOutSwitches(..), - pprPassDetails, - - -- * Plugins - PluginPass, bindsOnlyPass, - - -- * Counting - SimplCount, doSimplTick, doFreeSimplTick, simplCountN, - pprSimplCount, plusSimplCount, zeroSimplCount, - isZeroSimplCount, hasDetailedCounts, Tick(..), - - -- * The monad - CoreM, runCoreM, - - -- ** Reading from the monad - getHscEnv, getRuleBase, getModule, - getDynFlags, getOrigNameCache, getPackageFamInstEnv, - getVisibleOrphanMods, - getPrintUnqualified, getSrcSpanM, - - -- ** Writing to the monad - addSimplCount, - - -- ** Lifting into the monad - liftIO, liftIOWithCount, - liftIO1, liftIO2, liftIO3, liftIO4, - - -- ** Global initialization - reinitializeGlobals, - - -- ** Dealing with annotations - getAnnotations, getFirstAnnotations, - - -- ** Screen output - putMsg, putMsgS, errorMsg, errorMsgS, warnMsg, - fatalErrorMsg, fatalErrorMsgS, - debugTraceMsg, debugTraceMsgS, - dumpIfSet_dyn, - - -- * Getting 'Name's - thNameToGhcName - ) where - -import Name( Name ) -import TcRnMonad ( initTcForLookup ) -import CoreSyn -import HscTypes -import Module -import DynFlags -import BasicTypes ( CompilerPhase(..) ) -import Annotations - -import IOEnv hiding ( liftIO, failM, failWithM ) -import qualified IOEnv ( liftIO ) -import TcEnv ( lookupGlobal ) -import Var -import Outputable -import FastString -import qualified ErrUtils as Err -import ErrUtils( Severity(..) ) -import Maybes -import UniqSupply -import UniqFM ( UniqFM, mapUFM, filterUFM ) -import MonadUtils -import NameCache -import SrcLoc -import ListSetOps ( runs ) -import Data.List -import Data.Ord -import Data.Dynamic -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Map.Strict as MapStrict -import Data.Word -import Control.Monad -import Control.Applicative ( Alternative(..) ) - -import Prelude hiding ( read ) - -import {-# SOURCE #-} TcSplice ( lookupThName_maybe ) -import qualified Language.Haskell.TH as TH - -{- -************************************************************************ -* * - The CoreToDo type and related types - Abstraction of core-to-core passes to run. -* * -************************************************************************ --} - -data CoreToDo -- These are diff core-to-core passes, - -- which may be invoked in any order, - -- as many times as you like. - - = CoreDoSimplify -- The core-to-core simplifier. - Int -- Max iterations - SimplifierMode - | CoreDoPluginPass String PluginPass - | CoreDoFloatInwards - | CoreDoFloatOutwards FloatOutSwitches - | CoreLiberateCase - | CoreDoPrintCore - | CoreDoStaticArgs - | CoreDoCallArity - | CoreDoStrictness - | CoreDoWorkerWrapper - | CoreDoSpecialising - | CoreDoSpecConstr - | CoreCSE - | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules - -- matching this string - | CoreDoVectorisation - | CoreDoNothing -- Useful when building up - | CoreDoPasses [CoreToDo] -- lists of these things - - | CoreDesugar -- Right after desugaring, no simple optimisation yet! - | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces - -- Core output, and hence useful to pass to endPass - - | CoreTidy - | CorePrep - | CoreOccurAnal - -instance Outputable CoreToDo where - ppr (CoreDoSimplify _ _) = text "Simplifier" - ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s - ppr CoreDoFloatInwards = text "Float inwards" - ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) - ppr CoreLiberateCase = text "Liberate case" - ppr CoreDoStaticArgs = text "Static argument" - ppr CoreDoCallArity = text "Called arity analysis" - ppr CoreDoStrictness = text "Demand analysis" - ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" - ppr CoreDoSpecialising = text "Specialise" - ppr CoreDoSpecConstr = text "SpecConstr" - ppr CoreCSE = text "Common sub-expression" - ppr CoreDoVectorisation = text "Vectorisation" - ppr CoreDesugar = text "Desugar (before optimization)" - ppr CoreDesugarOpt = text "Desugar (after optimization)" - ppr CoreTidy = text "Tidy Core" - ppr CorePrep = text "CorePrep" - ppr CoreOccurAnal = text "Occurrence analysis" - ppr CoreDoPrintCore = text "Print core" - ppr (CoreDoRuleCheck {}) = text "Rule check" - ppr CoreDoNothing = text "CoreDoNothing" - ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes - -pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n - , ppr md ] -pprPassDetails _ = Outputable.empty - -data SimplifierMode -- See comments in SimplMonad - = SimplMode - { sm_names :: [String] -- Name(s) of the phase - , sm_phase :: CompilerPhase - , sm_rules :: Bool -- Whether RULES are enabled - , sm_inline :: Bool -- Whether inlining is enabled - , sm_case_case :: Bool -- Whether case-of-case is enabled - , sm_eta_expand :: Bool -- Whether eta-expansion is enabled - } - -instance Outputable SimplifierMode where - ppr (SimplMode { sm_phase = p, sm_names = ss - , sm_rules = r, sm_inline = i - , sm_eta_expand = eta, sm_case_case = cc }) - = text "SimplMode" <+> braces ( - sep [ text "Phase =" <+> ppr p <+> - brackets (text (concat $ intersperse "," ss)) <> comma - , pp_flag i (sLit "inline") <> comma - , pp_flag r (sLit "rules") <> comma - , pp_flag eta (sLit "eta-expand") <> comma - , pp_flag cc (sLit "case-of-case") ]) - where - pp_flag f s = ppUnless f (text "no") <+> ptext s - -data FloatOutSwitches = FloatOutSwitches { - floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if - -- doing so will abstract over n or fewer - -- value variables - -- Nothing <=> float all lambdas to top level, - -- regardless of how many free variables - -- Just 0 is the vanilla case: float a lambda - -- iff it has no free vars - - floatOutConstants :: Bool, -- ^ True <=> float constants to top level, - -- even if they do not escape a lambda - floatOutOverSatApps :: Bool, - -- ^ True <=> float out over-saturated applications - -- based on arity information. - -- See Note [Floating over-saturated applications] - -- in SetLevels - floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. - } -instance Outputable FloatOutSwitches where - ppr = pprFloatOutSwitches - -pprFloatOutSwitches :: FloatOutSwitches -> SDoc -pprFloatOutSwitches sw - = text "FOS" <+> (braces $ - sep $ punctuate comma $ - [ text "Lam =" <+> ppr (floatOutLambdas sw) - , text "Consts =" <+> ppr (floatOutConstants sw) - , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) - --- The core-to-core pass ordering is derived from the DynFlags: -runWhen :: Bool -> CoreToDo -> CoreToDo -runWhen True do_this = do_this -runWhen False _ = CoreDoNothing - -runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo -runMaybe (Just x) f = f x -runMaybe Nothing _ = CoreDoNothing - -{- - -************************************************************************ -* * - Types for Plugins -* * -************************************************************************ --} - --- | A description of the plugin pass itself -type PluginPass = ModGuts -> CoreM ModGuts - -bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts -bindsOnlyPass pass guts - = do { binds' <- pass (mg_binds guts) - ; return (guts { mg_binds = binds' }) } - -{- -************************************************************************ -* * - Counting and logging -* * -************************************************************************ --} - -getVerboseSimplStats :: (Bool -> SDoc) -> SDoc -getVerboseSimplStats = sdocWithPprDebug -- For now, anyway - -zeroSimplCount :: DynFlags -> SimplCount -isZeroSimplCount :: SimplCount -> Bool -hasDetailedCounts :: SimplCount -> Bool -pprSimplCount :: SimplCount -> SDoc -doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount -doFreeSimplTick :: Tick -> SimplCount -> SimplCount -plusSimplCount :: SimplCount -> SimplCount -> SimplCount - -data SimplCount - = VerySimplCount !Int -- Used when don't want detailed stats - - | SimplCount { - ticks :: !Int, -- Total ticks - details :: !TickCounts, -- How many of each type - - n_log :: !Int, -- N - log1 :: [Tick], -- Last N events; <= opt_HistorySize, - -- most recent first - log2 :: [Tick] -- Last opt_HistorySize events before that - -- Having log1, log2 lets us accumulate the - -- recent history reasonably efficiently - } - -type TickCounts = Map Tick Int - -simplCountN :: SimplCount -> Int -simplCountN (VerySimplCount n) = n -simplCountN (SimplCount { ticks = n }) = n - -zeroSimplCount dflags - -- This is where we decide whether to do - -- the VerySimpl version or the full-stats version - | dopt Opt_D_dump_simpl_stats dflags - = SimplCount {ticks = 0, details = Map.empty, - n_log = 0, log1 = [], log2 = []} - | otherwise - = VerySimplCount 0 - -isZeroSimplCount (VerySimplCount n) = n==0 -isZeroSimplCount (SimplCount { ticks = n }) = n==0 - -hasDetailedCounts (VerySimplCount {}) = False -hasDetailedCounts (SimplCount {}) = True - -doFreeSimplTick tick sc@SimplCount { details = dts } - = sc { details = dts `addTick` tick } -doFreeSimplTick _ sc = sc - -doSimplTick dflags tick - sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) - | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } - | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } - where - sc1 = sc { ticks = tks+1, details = dts `addTick` tick } - -doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) - - -addTick :: TickCounts -> Tick -> TickCounts -addTick fm tick = MapStrict.insertWith (+) tick 1 fm - -plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) - sc2@(SimplCount { ticks = tks2, details = dts2 }) - = log_base { ticks = tks1 + tks2 - , details = MapStrict.unionWith (+) dts1 dts2 } - where - -- A hackish way of getting recent log info - log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 - | null (log2 sc2) = sc2 { log2 = log1 sc1 } - | otherwise = sc2 - -plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) -plusSimplCount _ _ = panic "plusSimplCount" - -- We use one or the other consistently - -pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n -pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) - = vcat [text "Total ticks: " <+> int tks, - blankLine, - pprTickCounts dts, - getVerboseSimplStats $ \dbg -> if dbg - then - vcat [blankLine, - text "Log (most recent first)", - nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] - else Outputable.empty - ] - -pprTickCounts :: Map Tick Int -> SDoc -pprTickCounts counts - = vcat (map pprTickGroup groups) - where - groups :: [[(Tick,Int)]] -- Each group shares a comon tag - -- toList returns common tags adjacent - groups = runs same_tag (Map.toList counts) - same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 - -pprTickGroup :: [(Tick, Int)] -> SDoc -pprTickGroup group@((tick1,_):_) - = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) - 2 (vcat [ int n <+> pprTickCts tick - -- flip as we want largest first - | (tick,n) <- sortBy (flip (comparing snd)) group]) -pprTickGroup [] = panic "pprTickGroup" - -data Tick - = PreInlineUnconditionally Id - | PostInlineUnconditionally Id - - | UnfoldingDone Id - | RuleFired FastString -- Rule name - - | LetFloatFromLet - | EtaExpansion Id -- LHS binder - | EtaReduction Id -- Binder on outer lambda - | BetaReduction Id -- Lambda binder - - - | CaseOfCase Id -- Bndr on *inner* case - | KnownBranch Id -- Case binder - | CaseMerge Id -- Binder on outer case - | AltMerge Id -- Case binder - | CaseElim Id -- Case binder - | CaseIdentity Id -- Case binder - | FillInCaseDefault Id -- Case binder - - | BottomFound - | SimplifierDone -- Ticked at each iteration of the simplifier - -instance Outputable Tick where - ppr tick = text (tickString tick) <+> pprTickCts tick - -instance Eq Tick where - a == b = case a `cmpTick` b of - EQ -> True - _ -> False - -instance Ord Tick where - compare = cmpTick - -tickToTag :: Tick -> Int -tickToTag (PreInlineUnconditionally _) = 0 -tickToTag (PostInlineUnconditionally _) = 1 -tickToTag (UnfoldingDone _) = 2 -tickToTag (RuleFired _) = 3 -tickToTag LetFloatFromLet = 4 -tickToTag (EtaExpansion _) = 5 -tickToTag (EtaReduction _) = 6 -tickToTag (BetaReduction _) = 7 -tickToTag (CaseOfCase _) = 8 -tickToTag (KnownBranch _) = 9 -tickToTag (CaseMerge _) = 10 -tickToTag (CaseElim _) = 11 -tickToTag (CaseIdentity _) = 12 -tickToTag (FillInCaseDefault _) = 13 -tickToTag BottomFound = 14 -tickToTag SimplifierDone = 16 -tickToTag (AltMerge _) = 17 - -tickString :: Tick -> String -tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" -tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" -tickString (UnfoldingDone _) = "UnfoldingDone" -tickString (RuleFired _) = "RuleFired" -tickString LetFloatFromLet = "LetFloatFromLet" -tickString (EtaExpansion _) = "EtaExpansion" -tickString (EtaReduction _) = "EtaReduction" -tickString (BetaReduction _) = "BetaReduction" -tickString (CaseOfCase _) = "CaseOfCase" -tickString (KnownBranch _) = "KnownBranch" -tickString (CaseMerge _) = "CaseMerge" -tickString (AltMerge _) = "AltMerge" -tickString (CaseElim _) = "CaseElim" -tickString (CaseIdentity _) = "CaseIdentity" -tickString (FillInCaseDefault _) = "FillInCaseDefault" -tickString BottomFound = "BottomFound" -tickString SimplifierDone = "SimplifierDone" - -pprTickCts :: Tick -> SDoc -pprTickCts (PreInlineUnconditionally v) = ppr v -pprTickCts (PostInlineUnconditionally v)= ppr v -pprTickCts (UnfoldingDone v) = ppr v -pprTickCts (RuleFired v) = ppr v -pprTickCts LetFloatFromLet = Outputable.empty -pprTickCts (EtaExpansion v) = ppr v -pprTickCts (EtaReduction v) = ppr v -pprTickCts (BetaReduction v) = ppr v -pprTickCts (CaseOfCase v) = ppr v -pprTickCts (KnownBranch v) = ppr v -pprTickCts (CaseMerge v) = ppr v -pprTickCts (AltMerge v) = ppr v -pprTickCts (CaseElim v) = ppr v -pprTickCts (CaseIdentity v) = ppr v -pprTickCts (FillInCaseDefault v) = ppr v -pprTickCts _ = Outputable.empty - -cmpTick :: Tick -> Tick -> Ordering -cmpTick a b = case (tickToTag a `compare` tickToTag b) of - GT -> GT - EQ -> cmpEqTick a b - LT -> LT - -cmpEqTick :: Tick -> Tick -> Ordering -cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b -cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b -cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b -cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b -cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b -cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b -cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b -cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b -cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b -cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b -cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b -cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b -cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b -cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b -cmpEqTick _ _ = EQ - -{- -************************************************************************ -* * - Monad and carried data structure definitions -* * -************************************************************************ --} - -newtype CoreState = CoreState { - cs_uniq_supply :: UniqSupply -} - -data CoreReader = CoreReader { - cr_hsc_env :: HscEnv, - cr_rule_base :: RuleBase, - cr_module :: Module, - cr_print_unqual :: PrintUnqualified, - cr_loc :: SrcSpan, -- Use this for log/error messages so they - -- are at least tagged with the right source file - cr_visible_orphan_mods :: !ModuleSet -} - --- Note: CoreWriter used to be defined with data, rather than newtype. If it --- is defined that way again, the cw_simpl_count field, at least, must be --- strict to avoid a space leak (Trac #7702). -newtype CoreWriter = CoreWriter { - cw_simpl_count :: SimplCount -} - -emptyWriter :: DynFlags -> CoreWriter -emptyWriter dflags = CoreWriter { - cw_simpl_count = zeroSimplCount dflags - } - -plusWriter :: CoreWriter -> CoreWriter -> CoreWriter -plusWriter w1 w2 = CoreWriter { - cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2) - } - -type CoreIOEnv = IOEnv CoreReader - --- | The monad used by Core-to-Core passes to access common state, register simplification --- statistics and so on -newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) } - -instance Functor CoreM where - fmap = liftM - -instance Monad CoreM where - mx >>= f = CoreM $ \s -> do - (x, s', w1) <- unCoreM mx s - (y, s'', w2) <- unCoreM (f x) s' - let w = w1 `plusWriter` w2 - return $ seq w (y, s'', w) - -- forcing w before building the tuple avoids a space leak - -- (Trac #7702) - -instance Applicative CoreM where - pure x = CoreM $ \s -> nop s x - (<*>) = ap - m *> k = m >>= \_ -> k - -instance Alternative CoreM where - empty = CoreM (const Control.Applicative.empty) - m <|> n = CoreM (\rs -> unCoreM m rs <|> unCoreM n rs) - -instance MonadPlus CoreM - -instance MonadUnique CoreM where - getUniqueSupplyM = do - us <- getS cs_uniq_supply - let (us1, us2) = splitUniqSupply us - modifyS (\s -> s { cs_uniq_supply = us2 }) - return us1 - - getUniqueM = do - us <- getS cs_uniq_supply - let (u,us') = takeUniqFromSupply us - modifyS (\s -> s { cs_uniq_supply = us' }) - return u - -runCoreM :: HscEnv - -> RuleBase - -> UniqSupply - -> Module - -> ModuleSet - -> PrintUnqualified - -> SrcSpan - -> CoreM a - -> IO (a, SimplCount) -runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m - = liftM extract $ runIOEnv reader $ unCoreM m state - where - reader = CoreReader { - cr_hsc_env = hsc_env, - cr_rule_base = rule_base, - cr_module = mod, - cr_visible_orphan_mods = orph_imps, - cr_print_unqual = print_unqual, - cr_loc = loc - } - state = CoreState { - cs_uniq_supply = us - } - - extract :: (a, CoreState, CoreWriter) -> (a, SimplCount) - extract (value, _, writer) = (value, cw_simpl_count writer) - -{- -************************************************************************ -* * - Core combinators, not exported -* * -************************************************************************ --} - -nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter) -nop s x = do - r <- getEnv - return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r) - -read :: (CoreReader -> a) -> CoreM a -read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r))) - -getS :: (CoreState -> a) -> CoreM a -getS f = CoreM (\s -> nop s (f s)) - -modifyS :: (CoreState -> CoreState) -> CoreM () -modifyS f = CoreM (\s -> nop (f s) ()) - -write :: CoreWriter -> CoreM () -write w = CoreM (\s -> return ((), s, w)) - --- \subsection{Lifting IO into the monad} - --- | Lift an 'IOEnv' operation into 'CoreM' -liftIOEnv :: CoreIOEnv a -> CoreM a -liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x)) - -instance MonadIO CoreM where - liftIO = liftIOEnv . IOEnv.liftIO - --- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount' -liftIOWithCount :: IO (SimplCount, a) -> CoreM a -liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x) - -{- -************************************************************************ -* * - Reader, writer and state accessors -* * -************************************************************************ --} - -getHscEnv :: CoreM HscEnv -getHscEnv = read cr_hsc_env - -getRuleBase :: CoreM RuleBase -getRuleBase = read cr_rule_base - -getVisibleOrphanMods :: CoreM ModuleSet -getVisibleOrphanMods = read cr_visible_orphan_mods - -getPrintUnqualified :: CoreM PrintUnqualified -getPrintUnqualified = read cr_print_unqual - -getSrcSpanM :: CoreM SrcSpan -getSrcSpanM = read cr_loc - -addSimplCount :: SimplCount -> CoreM () -addSimplCount count = write (CoreWriter { cw_simpl_count = count }) - --- Convenience accessors for useful fields of HscEnv - -instance HasDynFlags CoreM where - getDynFlags = fmap hsc_dflags getHscEnv - -instance HasModule CoreM where - getModule = read cr_module - --- | The original name cache is the current mapping from 'Module' and --- 'OccName' to a compiler-wide unique 'Name' -getOrigNameCache :: CoreM OrigNameCache -getOrigNameCache = do - nameCacheRef <- fmap hsc_NC getHscEnv - liftIO $ fmap nsNames $ readIORef nameCacheRef - -getPackageFamInstEnv :: CoreM PackageFamInstEnv -getPackageFamInstEnv = do - hsc_env <- getHscEnv - eps <- liftIO $ hscEPS hsc_env - return $ eps_fam_inst_env eps - -{-# DEPRECATED reinitializeGlobals "It is not necessary to call reinitializeGlobals. Since GHC 8.2, this function is a no-op and will be removed in GHC 8.4" #-} -reinitializeGlobals :: CoreM () -reinitializeGlobals = return () - -{- -************************************************************************ -* * - Dealing with annotations -* * -************************************************************************ --} - --- | Get all annotations of a given type. This happens lazily, that is --- no deserialization will take place until the [a] is actually demanded and --- the [a] can also be empty (the UniqFM is not filtered). --- --- This should be done once at the start of a Core-to-Core pass that uses --- annotations. --- --- See Note [Annotations] -getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a]) -getAnnotations deserialize guts = do - hsc_env <- getHscEnv - ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) - return (deserializeAnns deserialize ann_env) - --- | Get at most one annotation of a given type per Unique. -getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a) -getFirstAnnotations deserialize guts - = liftM (mapUFM head . filterUFM (not . null)) - $ getAnnotations deserialize guts - -{- -Note [Annotations] -~~~~~~~~~~~~~~~~~~ -A Core-to-Core pass that wants to make use of annotations calls -getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with -annotations of a specific type. This produces all annotations from interface -files read so far. However, annotations from interface files read during the -pass will not be visible until getAnnotations is called again. This is similar -to how rules work and probably isn't too bad. - -The current implementation could be optimised a bit: when looking up -annotations for a thing from the HomePackageTable, we could search directly in -the module where the thing is defined rather than building one UniqFM which -contains all annotations we know of. This would work because annotations can -only be given to things defined in the same module. However, since we would -only want to deserialise every annotation once, we would have to build a cache -for every module in the HTP. In the end, it's probably not worth it as long as -we aren't using annotations heavily. - -************************************************************************ -* * - Direct screen output -* * -************************************************************************ --} - -msg :: Severity -> SDoc -> CoreM () -msg sev doc - = do { dflags <- getDynFlags - ; loc <- getSrcSpanM - ; unqual <- getPrintUnqualified - ; let sty = case sev of - SevError -> err_sty - SevWarning -> err_sty - SevDump -> dump_sty - _ -> user_sty - err_sty = mkErrStyle dflags unqual - user_sty = mkUserStyle dflags unqual AllTheWay - dump_sty = mkDumpStyle dflags unqual - ; liftIO $ putLogMsg dflags NoReason sev loc sty doc } - --- | Output a String message to the screen -putMsgS :: String -> CoreM () -putMsgS = putMsg . text - --- | Output a message to the screen -putMsg :: SDoc -> CoreM () -putMsg = msg SevInfo - --- | Output an error to the screen. Does not cause the compiler to die. -errorMsgS :: String -> CoreM () -errorMsgS = errorMsg . text - --- | Output an error to the screen. Does not cause the compiler to die. -errorMsg :: SDoc -> CoreM () -errorMsg = msg SevError - -warnMsg :: SDoc -> CoreM () -warnMsg = msg SevWarning - --- | Output a fatal error to the screen. Does not cause the compiler to die. -fatalErrorMsgS :: String -> CoreM () -fatalErrorMsgS = fatalErrorMsg . text - --- | Output a fatal error to the screen. Does not cause the compiler to die. -fatalErrorMsg :: SDoc -> CoreM () -fatalErrorMsg = msg SevFatal - --- | Output a string debugging message at verbosity level of @-v@ or higher -debugTraceMsgS :: String -> CoreM () -debugTraceMsgS = debugTraceMsg . text - --- | Outputs a debugging message at verbosity level of @-v@ or higher -debugTraceMsg :: SDoc -> CoreM () -debugTraceMsg = msg SevDump - --- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher -dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM () -dumpIfSet_dyn flag str doc - = do { dflags <- getDynFlags - ; unqual <- getPrintUnqualified - ; when (dopt flag dflags) $ liftIO $ - Err.dumpSDoc dflags unqual flag str doc } - -{- -************************************************************************ -* * - Finding TyThings -* * -************************************************************************ --} - -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 $ initTcForLookup hsc_env (lookupThName_maybe th_name) diff --git a/simplCore/FloatIn.hs b/simplCore/FloatIn.hs deleted file mode 100644 --- a/simplCore/FloatIn.hs +++ /dev/null @@ -1,659 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -************************************************************************ -* * -\section[FloatIn]{Floating Inwards pass} -* * -************************************************************************ - -The main purpose of @floatInwards@ is floating into branches of a -case, so that we don't allocate things, save them on the stack, and -then discover that they aren't needed in the chosen branch. --} - -{-# LANGUAGE CPP #-} - -module FloatIn ( floatInwards ) where - -#include "HsVersions.h" - -import CoreSyn -import MkCore -import HscTypes ( ModGuts(..) ) -import CoreUtils ( exprIsDupable, exprIsExpandable, - exprOkForSideEffects, mkTicks ) -import CoreFVs -import CoreMonad ( CoreM ) -import Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) -import Var -import Type ( isUnliftedType ) -import VarSet -import Util -import DynFlags -import Outputable -import Data.List ( mapAccumL ) -import BasicTypes ( RecFlag(..), isRec ) - -{- -Top-level interface function, @floatInwards@. Note that we do not -actually float any bindings downwards from the top-level. --} - -floatInwards :: ModGuts -> CoreM ModGuts -floatInwards pgm@(ModGuts { mg_binds = binds }) - = do { dflags <- getDynFlags - ; return (pgm { mg_binds = map (fi_top_bind dflags) binds }) } - where - fi_top_bind dflags (NonRec binder rhs) - = NonRec binder (fiExpr dflags [] (freeVars rhs)) - fi_top_bind dflags (Rec pairs) - = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ] - - -{- -************************************************************************ -* * -\subsection{Mail from Andr\'e [edited]} -* * -************************************************************************ - -{\em Will wrote: What??? I thought the idea was to float as far -inwards as possible, no matter what. This is dropping all bindings -every time it sees a lambda of any kind. Help! } - -You are assuming we DO DO full laziness AFTER floating inwards! We -have to [not float inside lambdas] if we don't. - -If we indeed do full laziness after the floating inwards (we could -check the compilation flags for that) then I agree we could be more -aggressive and do float inwards past lambdas. - -Actually we are not doing a proper full laziness (see below), which -was another reason for not floating inwards past a lambda. - -This can easily be fixed. The problem is that we float lets outwards, -but there are a few expressions which are not let bound, like case -scrutinees and case alternatives. After floating inwards the -simplifier could decide to inline the let and the laziness would be -lost, e.g. - -\begin{verbatim} -let a = expensive ==> \b -> case expensive of ... -in \ b -> case a of ... -\end{verbatim} -The fix is -\begin{enumerate} -\item -to let bind the algebraic case scrutinees (done, I think) and -the case alternatives (except the ones with an -unboxed type)(not done, I think). This is best done in the -SetLevels.hs module, which tags things with their level numbers. -\item -do the full laziness pass (floating lets outwards). -\item -simplify. The simplifier inlines the (trivial) lets that were - created but were not floated outwards. -\end{enumerate} - -With the fix I think Will's suggestion that we can gain even more from -strictness by floating inwards past lambdas makes sense. - -We still gain even without going past lambdas, as things may be -strict in the (new) context of a branch (where it was floated to) or -of a let rhs, e.g. -\begin{verbatim} -let a = something case x of -in case x of alt1 -> case something of a -> a + a - alt1 -> a + a ==> alt2 -> b - alt2 -> b - -let a = something let b = case something of a -> a + a -in let b = a + a ==> in (b,b) -in (b,b) -\end{verbatim} -Also, even if a is not found to be strict in the new context and is -still left as a let, if the branch is not taken (or b is not entered) -the closure for a is not built. - -************************************************************************ -* * -\subsection{Main floating-inwards code} -* * -************************************************************************ --} - -type FreeVarSet = DIdSet -type BoundVarSet = DIdSet - -data FloatInBind = FB BoundVarSet FreeVarSet FloatBind - -- The FreeVarSet is the free variables of the binding. In the case - -- of recursive bindings, the set doesn't include the bound - -- variables. - -type FloatInBinds = [FloatInBind] - -- In reverse dependency order (innermost binder first) - -fiExpr :: DynFlags - -> FloatInBinds -- Binds we're trying to drop - -- as far "inwards" as possible - -> CoreExprWithFVs -- Input expr - -> CoreExpr -- Result - -fiExpr _ to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit -fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty -fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) -fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) -fiExpr dflags to_drop (_, AnnCast expr (co_ann, co)) - = wrapFloats (drop_here ++ co_drop) $ - Cast (fiExpr dflags e_drop expr) co - where - [drop_here, e_drop, co_drop] - = sepBindsByDropPoint dflags False - [freeVarsOf expr, freeVarsOfAnn co_ann] - (freeVarsOfType expr `unionDVarSet` freeVarsOfTypeAnn co_ann) - to_drop - -{- -Applications: we do float inside applications, mainly because we -need to get at all the arguments. The next simplifier run will -pull out any silly ones. --} - -fiExpr dflags to_drop ann_expr@(_,AnnApp {}) - = mkTicks ticks $ wrapFloats drop_here $ wrapFloats extra_drop $ - mkApps (fiExpr dflags fun_drop ann_fun) - (zipWith (fiExpr dflags) arg_drops ann_args) - where - (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr - (extra_fvs0, fun_fvs) - | (_, AnnVar _) <- ann_fun = (freeVarsOf ann_fun, emptyDVarSet) - -- Don't float the binding for f into f x y z; see Note [Join points] - -- for why we *can't* do it when f is a join point. (If f isn't a - -- join point, floating it in isn't especially harmful but it's - -- useless since the simplifier will immediately float it back out.) - | otherwise = (emptyDVarSet, freeVarsOf ann_fun) - (extra_fvs, arg_fvs) = mapAccumL mk_arg_fvs extra_fvs0 ann_args - - mk_arg_fvs :: FreeVarSet -> CoreExprWithFVs -> (FreeVarSet, FreeVarSet) - mk_arg_fvs extra_fvs ann_arg - | noFloatIntoRhs False NonRecursive ann_arg - = (extra_fvs `unionDVarSet` freeVarsOf ann_arg, emptyDVarSet) - | otherwise - = (extra_fvs, freeVarsOf ann_arg) - - drop_here : extra_drop : fun_drop : arg_drops - = sepBindsByDropPoint dflags False - (extra_fvs : fun_fvs : arg_fvs) - (freeVarsOfType ann_fun `unionDVarSet` - mapUnionDVarSet freeVarsOfType ann_args) - to_drop - -{- -Note [Do not destroy the let/app invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Watch out for - f (x +# y) -We don't want to float bindings into here - f (case ... of { x -> x +# y }) -because that might destroy the let/app invariant, which requires -unlifted function arguments to be ok-for-speculation. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -Generally, we don't need to worry about join points - there are places we're -not allowed to float them, but since they can't have occurrences in those -places, we're not tempted. - -We do need to be careful about jumps, however: - - joinrec j x y z = ... in - jump j a b c - -Previous versions often floated the definition of a recursive function into its -only non-recursive occurrence. But for a join point, this is a disaster: - - (joinrec j x y z = ... in - jump j) a b c -- wrong! - -Every jump must be exact, so the jump to j must have three arguments. Hence -we're careful not to float into the target of a jump (though we can float into -the arguments just fine). - -Note [Floating in past a lambda group] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* We must be careful about floating inside a value lambda. - That risks losing laziness. - The float-out pass might rescue us, but then again it might not. - -* We must be careful about type lambdas too. At one time we did, and - there is no risk of duplicating work thereby, but we do need to be - careful. In particular, here is a bad case (it happened in the - cichelli benchmark: - let v = ... - in let f = /\t -> \a -> ... - ==> - let f = /\t -> let v = ... in \a -> ... - This is bad as now f is an updatable closure (update PAP) - and has arity 0. - -* Hack alert! We only float in through one-shot lambdas, - not (as you might guess) through lone big lambdas. - Reason: we float *out* past big lambdas (see the test in the Lam - case of FloatOut.floatExpr) and we don't want to float straight - back in again. - - It *is* important to float into one-shot lambdas, however; - see the remarks with noFloatIntoRhs. - -So we treat lambda in groups, using the following rule: - - Float in if (a) there is at least one Id, - and (b) there are no non-one-shot Ids - - Otherwise drop all the bindings outside the group. - -This is what the 'go' function in the AnnLam case is doing. - -(Join points are handled similarly: a join point is considered one-shot iff -it's non-recursive, so we float only into non-recursive join points.) - -Urk! if all are tyvars, and we don't float in, we may miss an - opportunity to float inside a nested case branch --} - -fiExpr dflags to_drop lam@(_, AnnLam _ _) - | okToFloatInside bndrs -- Float in - -- NB: Must line up with noFloatIntoRhs (AnnLam...); see Trac #7088 - = mkLams bndrs (fiExpr dflags to_drop body) - - | otherwise -- Dump it all here - = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body)) - - where - (bndrs, body) = collectAnnBndrs lam - -{- -We don't float lets inwards past an SCC. - ToDo: keep info on current cc, and when passing - one, if it is not the same, annotate all lets in binds with current - cc, change current cc to the new one and float binds into expr. --} - -fiExpr dflags to_drop (_, AnnTick tickish expr) - | tickish `tickishScopesLike` SoftScope - = Tick tickish (fiExpr dflags to_drop expr) - - | otherwise -- Wimp out for now - we could push values in - = wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr)) - -{- -For @Lets@, the possible ``drop points'' for the \tr{to_drop} -bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding, -or~(b2), in each of the RHSs of the pairs of a @Rec@. - -Note that we do {\em weird things} with this let's binding. Consider: -\begin{verbatim} -let - w = ... -in { - let v = ... w ... - in ... v .. w ... -} -\end{verbatim} -Look at the inner \tr{let}. As \tr{w} is used in both the bind and -body of the inner let, we could panic and leave \tr{w}'s binding where -it is. But \tr{v} is floatable further into the body of the inner let, and -{\em then} \tr{w} will also be only in the body of that inner let. - -So: rather than drop \tr{w}'s binding here, we add it onto the list of -things to drop in the outer let's body, and let nature take its -course. - -Note [extra_fvs (1): avoid floating into RHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider let x=\y....t... in body. We do not necessarily want to float -a binding for t into the RHS, because it'll immediately be floated out -again. (It won't go inside the lambda else we risk losing work.) -In letrec, we need to be more careful still. We don't want to transform - let x# = y# +# 1# - in - letrec f = \z. ...x#...f... - in ... -into - letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... -because now we can't float the let out again, because a letrec -can't have unboxed bindings. - -So we make "extra_fvs" which is the rhs_fvs of such bindings, and -arrange to dump bindings that bind extra_fvs before the entire let. - -Note [extra_fvs (2): free variables of rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let x{rule mentioning y} = rhs in body -Here y is not free in rhs or body; but we still want to dump bindings -that bind y outside the let. So we augment extra_fvs with the -idRuleAndUnfoldingVars of x. No need for type variables, hence not using -idFreeVars. --} - -fiExpr dflags to_drop (_,AnnLet bind body) - = fiExpr dflags (after ++ new_float : before) body - -- to_drop is in reverse dependency order - where - (before, new_float, after) = fiBind dflags to_drop bind body_fvs body_ty_fvs - body_fvs = freeVarsOf body - body_ty_fvs = freeVarsOfType body - -{- -For @Case@, the possible ``drop points'' for the \tr{to_drop} -bindings are: (a)~inside the scrutinee, (b)~inside one of the -alternatives/default [default FVs always {\em first}!]. - -Floating case expressions inward was added to fix Trac #5658: strict bindings -not floated in. In particular, this change allows array indexing operations, -which have a single DEFAULT alternative without any binders, to be floated -inward. SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed -scalars also need to be floated inward, but unpacks have a single non-DEFAULT -alternative that binds the elements of the tuple. We now therefore also support -floating in cases with a single alternative that may bind values. --} - -fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) - | isUnliftedType (idType case_bndr) - , exprOkForSideEffects (deAnnotate scrut) - -- See PrimOp, Note [PrimOp can_fail and has_side_effects] - = wrapFloats shared_binds $ - fiExpr dflags (case_float : rhs_binds) rhs - where - case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs - (FloatCase scrut' case_bndr con alt_bndrs) - scrut' = fiExpr dflags scrut_binds scrut - [shared_binds, scrut_binds, rhs_binds] - = sepBindsByDropPoint dflags False - [scrut_fvs, rhs_fvs] - (freeVarsOfType scrut `unionDVarSet` rhs_ty_fvs) - to_drop - rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs) - rhs_ty_fvs = freeVarsOfType rhs `delDVarSetList` (case_bndr : alt_bndrs) - scrut_fvs = freeVarsOf scrut - -fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts) - = wrapFloats drop_here1 $ - wrapFloats drop_here2 $ - Case (fiExpr dflags scrut_drops scrut) case_bndr ty - (zipWith fi_alt alts_drops_s alts) - where - -- Float into the scrut and alts-considered-together just like App - [drop_here1, scrut_drops, alts_drops] - = sepBindsByDropPoint dflags False - [scrut_fvs, all_alts_fvs] - (freeVarsOfType scrut `unionDVarSet` all_alts_ty_fvs) - to_drop - - -- Float into the alts with the is_case flag set - (drop_here2 : alts_drops_s) - = sepBindsByDropPoint dflags True alts_fvs all_alts_ty_fvs - alts_drops - - scrut_fvs = freeVarsOf scrut - alts_fvs = map alt_fvs alts - all_alts_fvs = unionDVarSets alts_fvs - alts_ty_fvs = map alt_ty_fvs alts - all_alts_ty_fvs = unionDVarSets alts_ty_fvs - alt_fvs (_con, args, rhs) - = foldl delDVarSet (freeVarsOf rhs) (case_bndr:args) - alt_ty_fvs (_con, args, rhs) - = foldl delDVarSet (freeVarsOfType rhs) (case_bndr:args) - -- Delete case_bndr and args from free vars of rhs - -- to get free vars of alt - - fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs) - ------------------- -fiBind :: DynFlags - -> FloatInBinds -- Binds we're trying to drop - -- as far "inwards" as possible - -> CoreBindWithFVs -- Input binding - -> DVarSet -- Free in scope of binding - -> DVarSet -- Free in type of body of binding - -> ( FloatInBinds -- Land these before - , FloatInBind -- The binding itself - , FloatInBinds) -- Land these after - -fiBind dflags to_drop (AnnNonRec id rhs) body_fvs body_ty_fvs - = ( extra_binds ++ shared_binds -- Land these before - -- See Note [extra_fvs (1,2)] - , FB (unitDVarSet id) rhs_fvs' -- The new binding itself - (FloatLet (NonRec id rhs')) - , body_binds ) -- Land these after - - where - body_fvs2 = body_fvs `delDVarSet` id - rhs_fvs = freeVarsOf rhs - - rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2): free variables of rules] - extra_fvs | noFloatIntoRhs (isJoinId id) NonRecursive rhs - = rule_fvs `unionDVarSet` freeVarsOf rhs - | otherwise - = rule_fvs - -- See Note [extra_fvs (1): avoid floating into RHS] - -- No point in floating in only to float straight out again - -- We *can't* float into ok-for-speculation unlifted RHSs - -- But do float into join points - - [shared_binds, extra_binds, rhs_binds, body_binds] - = sepBindsByDropPoint dflags False - [extra_fvs, rhs_fvs, body_fvs2] - (freeVarsOfType rhs `unionDVarSet` body_ty_fvs) - to_drop - - -- Push rhs_binds into the right hand side of the binding - rhs' = fiRhs dflags rhs_binds id rhs - rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs - -- Don't forget the rule_fvs; the binding mentions them! - -fiBind dflags to_drop (AnnRec bindings) body_fvs body_ty_fvs - = ( extra_binds ++ shared_binds - , FB (mkDVarSet ids) rhs_fvs' - (FloatLet (Rec (fi_bind rhss_binds bindings))) - , body_binds ) - where - (ids, rhss) = unzip bindings - rhss_fvs = map freeVarsOf rhss - - -- See Note [extra_fvs (1,2)] - rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids - extra_fvs = rule_fvs `unionDVarSet` - unionDVarSets [ freeVarsOf rhs | (bndr, rhs) <- bindings - , noFloatIntoRhs (isJoinId bndr) Recursive rhs ] - - (shared_binds:extra_binds:body_binds:rhss_binds) - = sepBindsByDropPoint dflags False - (extra_fvs:body_fvs:rhss_fvs) - (body_ty_fvs `unionDVarSet` mapUnionDVarSet freeVarsOfType rhss) - to_drop - - rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet` - unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet` - rule_fvs -- Don't forget the rule variables! - - -- Push rhs_binds into the right hand side of the binding - fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss - -> [(Id, CoreExprWithFVs)] - -> [(Id, CoreExpr)] - - fi_bind to_drops pairs - = [ (binder, fiRhs dflags to_drop binder rhs) - | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] - ------------------- -fiRhs :: DynFlags -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr -fiRhs dflags to_drop bndr rhs - | Just join_arity <- isJoinId_maybe bndr - , let (bndrs, body) = collectNAnnBndrs join_arity rhs - = mkLams bndrs (fiExpr dflags to_drop body) - | otherwise - = fiExpr dflags to_drop rhs - ------------------- -okToFloatInside :: [Var] -> Bool -okToFloatInside bndrs = all ok bndrs - where - ok b = not (isId b) || isOneShotBndr b - -- Push the floats inside there are no non-one-shot value binders - -noFloatIntoRhs :: Bool -> RecFlag -> CoreExprWithFVs -> Bool --- ^ True if it's a bad idea to float bindings into this RHS --- Preconditio: rhs :: rhs_ty -noFloatIntoRhs is_join is_rec rhs@(_, rhs') - | is_join - = isRec is_rec -- Joins are one-shot iff non-recursive - | otherwise - = isUnliftedType rhs_ty - -- See Note [Do not destroy the let/app invariant] - || noFloatIntoExpr rhs' - where - rhs_ty = exprTypeFV rhs - -noFloatIntoExpr :: CoreExprWithFVs' -> Bool -noFloatIntoExpr (AnnLam bndr e) - = not (okToFloatInside (bndr:bndrs)) - -- NB: Must line up with fiExpr (AnnLam...); see Trac #7088 - where - (bndrs, _) = collectAnnBndrs e - -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top. - -- This makes a big difference for things like - -- f x# = let x = I# x# - -- in let j = \() -> ...x... - -- in if then normal-path else j () - -- If x is used only in the error case join point, j, we must float the - -- boxing constructor into it, else we box it every time which is very bad - -- news indeed. - -noFloatIntoExpr rhs = exprIsExpandable (deAnnotate' rhs) - -- We'd just float right back out again... - -- Should match the test in SimplEnv.doFloatFromRhs - -{- -************************************************************************ -* * -\subsection{@sepBindsByDropPoint@} -* * -************************************************************************ - -This is the crucial function. The idea is: We have a wad of bindings -that we'd like to distribute inside a collection of {\em drop points}; -insides the alternatives of a \tr{case} would be one example of some -drop points; the RHS and body of a non-recursive \tr{let} binding -would be another (2-element) collection. - -So: We're given a list of sets-of-free-variables, one per drop point, -and a list of floating-inwards bindings. If a binding can go into -only one drop point (without suddenly making something out-of-scope), -in it goes. If a binding is used inside {\em multiple} drop points, -then it has to go in a you-must-drop-it-above-all-these-drop-points -point. - -But, with coercions appearing in types, there is a complication: we -might be floating in a "strict let" -- that is, a case. Case expressions -mention their return type. We absolutely can't float a coercion binding -inward to the point that the type of the expression it's about to wrap -mentions the coercion. So we include the union of the sets of free variables -of the types of all the drop points involved. If any of the floaters -bind a coercion variable mentioned in any of the types, that binder must -be dropped right away. - -We have to maintain the order on these drop-point-related lists. --} - -sepBindsByDropPoint - :: DynFlags - -> Bool -- True <=> is case expression - -> [FreeVarSet] -- One set of FVs per drop point - -> FreeVarSet -- Vars free in all the types of the drop points - -> FloatInBinds -- Candidate floaters - -> [FloatInBinds] -- FIRST one is bindings which must not be floated - -- inside any drop point; the rest correspond - -- one-to-one with the input list of FV sets - --- Every input floater is returned somewhere in the result; --- none are dropped, not even ones which don't seem to be --- free in *any* of the drop-point fvs. Why? Because, for example, --- a binding (let x = E in B) might have a specialised version of --- x (say x') stored inside x, but x' isn't free in E or B. - -type DropBox = (FreeVarSet, FloatInBinds) - -sepBindsByDropPoint _ _is_case drop_pts _ty_fvs [] - = [] : [[] | _ <- drop_pts] -- cut to the chase scene; it happens - -sepBindsByDropPoint dflags is_case drop_pts ty_fvs floaters - = go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts)) - where - go :: FloatInBinds -> [DropBox] -> [FloatInBinds] - -- The *first* one in the argument list is the drop_here set - -- The FloatInBinds in the lists are in the reverse of - -- the normal FloatInBinds order; that is, they are the right way round! - - go [] drop_boxes = map (reverse . snd) drop_boxes - - go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes) - = go binds new_boxes - where - -- "here" means the group of bindings dropped at the top of the fork - - (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs - | (fvs, _) <- drop_boxes] - used_in_ty = ty_fvs `intersectsDVarSet` bndrs - - drop_here = used_here || not can_push || used_in_ty - - -- For case expressions we duplicate the binding if it is - -- reasonably small, and if it is not used in all the RHSs - -- This is good for situations like - -- let x = I# y in - -- case e of - -- C -> error x - -- D -> error x - -- E -> ...not mentioning x... - - n_alts = length used_in_flags - n_used_alts = count id used_in_flags -- returns number of Trues in list. - - can_push = n_used_alts == 1 -- Used in just one branch - || (is_case && -- We are looking at case alternatives - n_used_alts > 1 && -- It's used in more than one - n_used_alts < n_alts && -- ...but not all - floatIsDupable dflags bind) -- and we can duplicate the binding - - new_boxes | drop_here = (insert here_box : fork_boxes) - | otherwise = (here_box : new_fork_boxes) - - new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags - - insert :: DropBox -> DropBox - insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops) - - insert_maybe box True = insert box - insert_maybe box False = box - - go _ _ = panic "sepBindsByDropPoint/go" - - -floatedBindsFVs :: FloatInBinds -> FreeVarSet -floatedBindsFVs binds = mapUnionDVarSet fbFVs binds - -fbFVs :: FloatInBind -> DVarSet -fbFVs (FB _ fvs _) = fvs - -wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr --- Remember FloatInBinds is in *reverse* dependency order -wrapFloats [] e = e -wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) - -floatIsDupable :: DynFlags -> FloatBind -> Bool -floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut -floatIsDupable dflags (FloatLet (Rec prs)) = all (exprIsDupable dflags . snd) prs -floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r diff --git a/simplCore/FloatOut.hs b/simplCore/FloatOut.hs deleted file mode 100644 --- a/simplCore/FloatOut.hs +++ /dev/null @@ -1,755 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[FloatOut]{Float bindings outwards (towards the top level)} - -``Long-distance'' floating of bindings towards the top level. --} - -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module FloatOut ( floatOutwards ) where - -import CoreSyn -import CoreUtils -import MkCore -import CoreArity ( etaExpand ) -import CoreMonad ( FloatOutSwitches(..) ) - -import DynFlags -import ErrUtils ( dumpIfSet_dyn ) -import Id ( Id, idArity, idType, isBottomingId, - isJoinId, isJoinId_maybe ) -import Var ( Var ) -import SetLevels -import UniqSupply ( UniqSupply ) -import Bag -import Util -import Maybes -import Outputable -import Type -import qualified Data.IntMap as M - -import Data.List ( partition ) - -#include "HsVersions.h" - -{- - ----------------- - Overall game plan - ----------------- - -The Big Main Idea is: - - To float out sub-expressions that can thereby get outside - a non-one-shot value lambda, and hence may be shared. - - -To achieve this we may need to do two thing: - - a) Let-bind the sub-expression: - - f (g x) ==> let lvl = f (g x) in lvl - - Now we can float the binding for 'lvl'. - - b) More than that, we may need to abstract wrt a type variable - - \x -> ... /\a -> let v = ...a... in .... - - Here the binding for v mentions 'a' but not 'x'. So we - abstract wrt 'a', to give this binding for 'v': - - vp = /\a -> ...a... - v = vp a - - Now the binding for vp can float out unimpeded. - I can't remember why this case seemed important enough to - deal with, but I certainly found cases where important floats - didn't happen if we did not abstract wrt tyvars. - -With this in mind we can also achieve another goal: lambda lifting. -We can make an arbitrary (function) binding float to top level by -abstracting wrt *all* local variables, not just type variables, leaving -a binding that can be floated right to top level. Whether or not this -happens is controlled by a flag. - - -Random comments -~~~~~~~~~~~~~~~ - -At the moment we never float a binding out to between two adjacent -lambdas. For example: - -@ - \x y -> let t = x+x in ... -===> - \x -> let t = x+x in \y -> ... -@ -Reason: this is less efficient in the case where the original lambda -is never partially applied. - -But there's a case I've seen where this might not be true. Consider: -@ -elEm2 x ys - = elem' x ys - where - elem' _ [] = False - elem' x (y:ys) = x==y || elem' x ys -@ -It turns out that this generates a subexpression of the form -@ - \deq x ys -> let eq = eqFromEqDict deq in ... -@ -vwhich might usefully be separated to -@ - \deq -> let eq = eqFromEqDict deq in \xy -> ... -@ -Well, maybe. We don't do this at the moment. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -Every occurrence of a join point must be a tail call (see Note [Invariants on -join points] in CoreSyn), so we must be careful with how far we float them. The -mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling] -in SetLevels. For us, the significance is that a binder might be marked to be -dropped at the nearest boundary between tail calls and non-tail calls. For -example: - - (< join j = ... in - let x = < ... > in - case < ... > of - A -> ... - B -> ... - >) < ... > < ... > - -Here the join ceilings are marked with angle brackets. Either side of an -application is a join ceiling, as is the scrutinee position of a case -expression or the RHS of a let binding (but not a join point). - -Why do we *want* do float join points at all? After all, they're never -allocated, so there's no sharing to be gained by floating them. However, the -other benefit of floating is making RHSes small, and this can have a significant -impact. In particular, stream fusion has been known to produce nested loops like -this: - - joinrec j1 x1 = - joinrec j2 x2 = - joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... - in jump j3 x2 - in jump j2 x1 - in jump j1 x - -(Assume x1 and x2 do *not* occur free in j3.) - -Here j1 and j2 are wholly superfluous---each of them merely forwards its -argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make -everything one big mutual recursion: - - joinrec j1 x1 = jump j2 x1 - j2 x2 = jump j3 x2 - j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... - in jump j1 x - -Now the simplifier will happily inline the trivial j1 and j2, leaving only j3. -Without floating, we're stuck with three loops instead of one. - -************************************************************************ -* * -\subsection[floatOutwards]{@floatOutwards@: let-floating interface function} -* * -************************************************************************ --} - -floatOutwards :: FloatOutSwitches - -> DynFlags - -> UniqSupply - -> CoreProgram -> IO CoreProgram - -floatOutwards float_sws dflags us pgm - = do { - let { annotated_w_levels = setLevels float_sws pgm us ; - (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) - } ; - - dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:" - (vcat (map ppr annotated_w_levels)); - - let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; - - dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" - (hcat [ int tlets, text " Lets floated to top level; ", - int ntlets, text " Lets floated elsewhere; from ", - int lams, text " Lambda groups"]); - - return (bagToList (unionManyBags binds_s')) - } - -floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind) -floatTopBind bind - = case (floatBind bind) of { (fs, floats, bind') -> - let float_bag = flattenTopFloats floats - in case bind' of - -- bind' can't have unlifted values or join points, so can only be one - -- value bind, rec or non-rec (see comment on floatBind) - [Rec prs] -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs))) - [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e) - _ -> pprPanic "floatTopBind" (ppr bind') } - -{- -************************************************************************ -* * -\subsection[FloatOut-Bind]{Floating in a binding (the business end)} -* * -************************************************************************ --} - -floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind]) - -- Returns a list with either - -- * A single non-recursive binding (value or join point), or - -- * The following, in order: - -- * Zero or more non-rec unlifted bindings - -- * One or both of: - -- * A recursive group of join binds - -- * A recursive group of value binds - -- See Note [Floating out of Rec rhss] for why things get arranged this way. -floatBind (NonRec (TB var _) rhs) - = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') -> - - -- A tiresome hack: - -- see Note [Bottoming floats: eta expansion] in SetLevels - let rhs'' | isBottomingId var = etaExpand (idArity var) rhs' - | otherwise = rhs' - - in (fs, rhs_floats, [NonRec var rhs'']) } - -floatBind (Rec pairs) - = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> - let (new_ul_pairss, new_other_pairss) = unzip new_pairs - (new_join_pairs, new_l_pairs) = partition (isJoinId . fst) - (concat new_other_pairss) - -- Can't put the join points and the values in the same rec group - new_rec_binds | null new_join_pairs = [ Rec new_l_pairs ] - | null new_l_pairs = [ Rec new_join_pairs ] - | otherwise = [ Rec new_l_pairs - , Rec new_join_pairs ] - new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ] - in - (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) } - where - do_pair :: (LevelledBndr, LevelledExpr) - -> (FloatStats, FloatBinds, - ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings - [(Id,CoreExpr)])) -- Join points and lifted value bindings - do_pair (TB name spec, rhs) - | isTopLvl dest_lvl -- See Note [floatBind for top level] - = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> - (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats) - [(name, rhs')]))} - | otherwise -- Note [Floating out of Rec rhss] - = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> - case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) -> - case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) -> - let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in - (fs, rhs_floats', (ul_pairs, pairs')) }}} - where - dest_lvl = floatSpecLevel spec - -splitRecFloats :: Bag FloatBind - -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings - [(Id,CoreExpr)], -- Join points and lifted value bindings - Bag FloatBind) -- A tail of further bindings --- The "tail" begins with a case --- See Note [Floating out of Rec rhss] -splitRecFloats fs - = go [] [] (bagToList fs) - where - go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b) - , not (isJoinId b) - = go ((b,r):ul_prs) prs fs - | otherwise - = go ul_prs ((b,r):prs) fs - go ul_prs prs (FloatLet (Rec prs') : fs) = go ul_prs (prs' ++ prs) fs - go ul_prs prs fs = (reverse ul_prs, prs, - listToBag fs) - -- Order only matters for - -- non-rec - -installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr --- Note [Floating out of Rec rhss] -installUnderLambdas floats e - | isEmptyBag floats = e - | otherwise = go e - where - go (Lam b e) = Lam b (go e) - go e = install floats e - ---------------- -floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) -floatList _ [] = (zeroStats, emptyFloats, []) -floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> - case floatList f as of { (fs_as, binds_as, bs) -> - (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} - -{- -Note [Floating out of Rec rhss] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider Rec { f<1,0> = \xy. body } -From the body we may get some floats. The ones with level <1,0> must -stay here, since they may mention f. Ideally we'd like to make them -part of the Rec block pairs -- but we can't if there are any -FloatCases involved. - -Nor is it a good idea to dump them in the rhs, but outside the lambda - f = case x of I# y -> \xy. body -because now f's arity might get worse, which is Not Good. (And if -there's an SCC around the RHS it might not get better again. -See Trac #5342.) - -So, gruesomely, we split the floats into - * the outer FloatLets, which can join the Rec, and - * an inner batch starting in a FloatCase, which are then - pushed *inside* the lambdas. -This loses full-laziness the rare situation where there is a -FloatCase and a Rec interacting. - -If there are unlifted FloatLets (that *aren't* join points) among the floats, -we can't add them to the recursive group without angering Core Lint, but since -they must be ok-for-speculation, they can't actually be making any recursive -calls, so we can safely pull them out and keep them non-recursive. - -(Why is something getting floated to <1,0> that doesn't make a recursive call? -The case that came up in testing was that f *and* the unlifted binding were -getting floated *to the same place*: - - \x<2,0> -> - ... <3,0> - letrec { f> = - ... let x'> = x +# 1# in ... - } in ... - -Everything gets labeled "float to <2,0>" because it all depends on x, but this -makes f and x' look mutually recursive when they're not. - -The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the -wip/join-points branch. - -TODO: This can probably be solved somehow in SetLevels. The difference between -"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very -important.) - -Note [floatBind for top level] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus - letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... } -The binding for bar will be in the "tops" part of the floating binds, -and thus not partioned by floatBody. - -We could perhaps get rid of the 'tops' component of the floating binds, -but this case works just as well. - - -************************************************************************ - -\subsection[FloatOut-Expr]{Floating in expressions} -* * -************************************************************************ --} - -floatBody :: Level - -> LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) - -floatBody lvl arg -- Used rec rhss, and case-alternative rhss - = case (floatExpr arg) of { (fsa, floats, arg') -> - case (partitionByLevel lvl floats) of { (floats', heres) -> - -- Dump bindings are bound here - (fsa, floats', install heres arg') }} - ------------------ - -{- Note [Floating past breakpoints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We used to disallow floating out of breakpoint ticks (see #10052). However, I -think this is too restrictive. - -Consider the case of an expression scoped over by a breakpoint tick, - - tick<...> (let x = ... in f x) - -In this case it is completely legal to float out x, despite the fact that -breakpoint ticks are scoped, - - let x = ... in (tick<...> f x) - -The reason here is that we know that the breakpoint will still be hit when the -expression is entered since the tick still scopes over the RHS. - --} - -floatExpr :: LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) -floatExpr (Var v) = (zeroStats, emptyFloats, Var v) -floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty) -floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co) -floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit) - -floatExpr (App e a) - = case (atJoinCeiling $ floatExpr e) of { (fse, floats_e, e') -> - case (atJoinCeiling $ floatExpr a) of { (fsa, floats_a, a') -> - (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }} - -floatExpr lam@(Lam (TB _ lam_spec) _) - = let (bndrs_w_lvls, body) = collectBinders lam - bndrs = [b | TB b _ <- bndrs_w_lvls] - bndr_lvl = asJoinCeilLvl (floatSpecLevel lam_spec) - -- All the binders have the same level - -- See SetLevels.lvlLamBndrs - -- Use asJoinCeilLvl to make this the join ceiling - in - case (floatBody bndr_lvl body) of { (fs, floats, body') -> - (add_to_stats fs floats, floats, mkLams bndrs body') } - -floatExpr (Tick tickish expr) - | tickish `tickishScopesLike` SoftScope -- not scoped, can just float - = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> - (fs, floating_defns, Tick tickish expr') } - - | not (tickishCounts tickish) || tickishCanSplit tickish - = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> - let -- Annotate bindings floated outwards past an scc expression - -- with the cc. We mark that cc as "duplicated", though. - annotated_defns = wrapTick (mkNoCount tickish) floating_defns - in - (fs, annotated_defns, Tick tickish expr') } - - -- Note [Floating past breakpoints] - | Breakpoint{} <- tickish - = case (floatExpr expr) of { (fs, floating_defns, expr') -> - (fs, floating_defns, Tick tickish expr') } - - | otherwise - = pprPanic "floatExpr tick" (ppr tickish) - -floatExpr (Cast expr co) - = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> - (fs, floating_defns, Cast expr' co) } - -floatExpr (Let bind body) - = case bind_spec of - FloatMe dest_lvl - -> case (floatBind bind) of { (fsb, bind_floats, binds') -> - case (floatExpr body) of { (fse, body_floats, body') -> - let new_bind_floats = foldr plusFloats emptyFloats - (map (unitLetFloat dest_lvl) binds') in - ( add_stats fsb fse - , bind_floats `plusFloats` new_bind_floats - `plusFloats` body_floats - , body') }} - - StayPut bind_lvl -- See Note [Avoiding unnecessary floating] - -> case (floatBind bind) of { (fsb, bind_floats, binds') -> - case (floatBody bind_lvl body) of { (fse, body_floats, body') -> - ( add_stats fsb fse - , bind_floats `plusFloats` body_floats - , foldr Let body' binds' ) }} - where - bind_spec = case bind of - NonRec (TB _ s) _ -> s - Rec ((TB _ s, _) : _) -> s - Rec [] -> panic "floatExpr:rec" - -floatExpr (Case scrut (TB case_bndr case_spec) ty alts) - = case case_spec of - FloatMe dest_lvl -- Case expression moves - | [(con@(DataAlt {}), bndrs, rhs)] <- alts - -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> - case floatExpr rhs of { (fsb, fdb, rhs') -> - let - float = unitCaseFloat dest_lvl scrut' - case_bndr con [b | TB b _ <- bndrs] - in - (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }} - | otherwise - -> pprPanic "Floating multi-case" (ppr alts) - - StayPut bind_lvl -- Case expression stays put - -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> - case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') -> - (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') - }} - where - float_alt bind_lvl (con, bs, rhs) - = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } - -floatRhs :: CoreBndr - -> LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) -floatRhs bndr rhs - | Just join_arity <- isJoinId_maybe bndr - , Just (bndrs, body) <- try_collect join_arity rhs [] - = case bndrs of - [] -> floatExpr rhs - (TB _ lam_spec):_ -> - let lvl = floatSpecLevel lam_spec in - case floatBody lvl body of { (fs, floats, body') -> - (fs, floats, mkLams [b | TB b _ <- bndrs] body') } - | otherwise - = atJoinCeiling $ floatExpr rhs - where - try_collect 0 expr acc = Just (reverse acc, expr) - try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc) - try_collect _ _ _ = Nothing - -{- -Note [Avoiding unnecessary floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we want to avoid floating a let unnecessarily, because -it might worsen strictness: - let - x = ...(let y = e in y+y).... -Here y is demanded. If we float it outside the lazy 'x=..' then -we'd have to zap its demand info, and it may never be restored. - -So at a 'let' we leave the binding right where the are unless -the binding will escape a value lambda, e.g. - -(\x -> let y = fac 100 in y) - -That's what the partitionByMajorLevel does in the floatExpr (Let ...) -case. - -Notice, though, that we must take care to drop any bindings -from the body of the let that depend on the staying-put bindings. - -We used instead to do the partitionByMajorLevel on the RHS of an '=', -in floatRhs. But that was quite tiresome. We needed to test for -values or trival rhss, because (in particular) we don't want to insert -new bindings between the "=" and the "\". E.g. - f = \x -> let in -We do not want - f = let in \x -> -(a) The simplifier will immediately float it further out, so we may - as well do so right now; in general, keeping rhss as manifest - values is good -(b) If a float-in pass follows immediately, it might add yet more - bindings just after the '='. And some of them might (correctly) - be strict even though the 'let f' is lazy, because f, being a value, - gets its demand-info zapped by the simplifier. -And even all that turned out to be very fragile, and broke -altogether when profiling got in the way. - -So now we do the partition right at the (Let..) itself. - -************************************************************************ -* * -\subsection{Utility bits for floating stats} -* * -************************************************************************ - -I didn't implement this with unboxed numbers. I don't want to be too -strict in this stuff, as it is rarely turned on. (WDP 95/09) --} - -data FloatStats - = FlS Int -- Number of top-floats * lambda groups they've been past - Int -- Number of non-top-floats * lambda groups they've been past - Int -- Number of lambda (groups) seen - -get_stats :: FloatStats -> (Int, Int, Int) -get_stats (FlS a b c) = (a, b, c) - -zeroStats :: FloatStats -zeroStats = FlS 0 0 0 - -sum_stats :: [FloatStats] -> FloatStats -sum_stats xs = foldr add_stats zeroStats xs - -add_stats :: FloatStats -> FloatStats -> FloatStats -add_stats (FlS a1 b1 c1) (FlS a2 b2 c2) - = FlS (a1 + a2) (b1 + b2) (c1 + c2) - -add_to_stats :: FloatStats -> FloatBinds -> FloatStats -add_to_stats (FlS a b c) (FB tops ceils others) - = FlS (a + lengthBag tops) - (b + lengthBag ceils + lengthBag (flattenMajor others)) - (c + 1) - -{- -************************************************************************ -* * -\subsection{Utility bits for floating} -* * -************************************************************************ - -Note [Representation of FloatBinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The FloatBinds types is somewhat important. We can get very large numbers -of floating bindings, often all destined for the top level. A typical example -is x = [4,2,5,2,5, .... ] -Then we get lots of small expressions like (fromInteger 4), which all get -lifted to top level. - -The trouble is that - (a) we partition these floating bindings *at every binding site* - (b) SetLevels introduces a new bindings site for every float -So we had better not look at each binding at each binding site! - -That is why MajorEnv is represented as a finite map. - -We keep the bindings destined for the *top* level separate, because -we float them out even if they don't escape a *value* lambda; see -partitionByMajorLevel. --} - -type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted -type MajorEnv = M.IntMap MinorEnv -- Keyed by major level -type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level - -data FloatBinds = FB !(Bag FloatLet) -- Destined for top level - !(Bag FloatBind) -- Destined for join ceiling - !MajorEnv -- Other levels - -- See Note [Representation of FloatBinds] - -instance Outputable FloatBinds where - ppr (FB fbs ceils defs) - = text "FB" <+> (braces $ vcat - [ text "tops =" <+> ppr fbs - , text "ceils =" <+> ppr ceils - , text "non-tops =" <+> ppr defs ]) - -flattenTopFloats :: FloatBinds -> Bag CoreBind -flattenTopFloats (FB tops ceils defs) - = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs ) - ASSERT2( isEmptyBag ceils, ppr ceils ) - tops - -addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] -addTopFloatPairs float_bag prs - = foldrBag add prs float_bag - where - add (NonRec b r) prs = (b,r):prs - add (Rec prs1) prs2 = prs1 ++ prs2 - -flattenMajor :: MajorEnv -> Bag FloatBind -flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag - -flattenMinor :: MinorEnv -> Bag FloatBind -flattenMinor = M.foldr unionBags emptyBag - -emptyFloats :: FloatBinds -emptyFloats = FB emptyBag emptyBag M.empty - -unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds -unitCaseFloat (Level major minor t) e b con bs - | t == JoinCeilLvl - = FB emptyBag floats M.empty - | otherwise - = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats)) - where - floats = unitBag (FloatCase e b con bs) - -unitLetFloat :: Level -> FloatLet -> FloatBinds -unitLetFloat lvl@(Level major minor t) b - | isTopLvl lvl = FB (unitBag b) emptyBag M.empty - | t == JoinCeilLvl = FB emptyBag floats M.empty - | otherwise = FB emptyBag emptyBag (M.singleton major - (M.singleton minor floats)) - where - floats = unitBag (FloatLet b) - -plusFloats :: FloatBinds -> FloatBinds -> FloatBinds -plusFloats (FB t1 c1 l1) (FB t2 c2 l2) - = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2) - -plusMajor :: MajorEnv -> MajorEnv -> MajorEnv -plusMajor = M.unionWith plusMinor - -plusMinor :: MinorEnv -> MinorEnv -> MinorEnv -plusMinor = M.unionWith unionBags - -install :: Bag FloatBind -> CoreExpr -> CoreExpr -install defn_groups expr - = foldrBag wrapFloat expr defn_groups - -partitionByLevel - :: Level -- Partitioning level - -> FloatBinds -- Defns to be divided into 2 piles... - -> (FloatBinds, -- Defns with level strictly < partition level, - Bag FloatBind) -- The rest - -{- --- ---- partitionByMajorLevel ---- --- Float it if we escape a value lambda, --- *or* if we get to the top level --- *or* if it's a case-float and its minor level is < current --- --- If we can get to the top level, say "yes" anyway. This means that --- x = f e --- transforms to --- lvl = e --- x = f lvl --- which is as it should be - -partitionByMajorLevel (Level major _) (FB tops defns) - = (FB tops outer, heres `unionBags` flattenMajor inner) - where - (outer, mb_heres, inner) = M.splitLookup major defns - heres = case mb_heres of - Nothing -> emptyBag - Just h -> flattenMinor h --} - -partitionByLevel (Level major minor typ) (FB tops ceils defns) - = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min), - here_min `unionBags` here_ceil - `unionBags` flattenMinor inner_min - `unionBags` flattenMajor inner_maj) - - where - (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns - (outer_min, mb_here_min, inner_min) = case mb_here_maj of - Nothing -> (M.empty, Nothing, M.empty) - Just min_defns -> M.splitLookup minor min_defns - here_min = mb_here_min `orElse` emptyBag - (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag) - | otherwise = (emptyBag, ceils) - --- Like partitionByLevel, but instead split out the bindings that are marked --- to float to the nearest join ceiling (see Note [Join points]) -partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind) -partitionAtJoinCeiling (FB tops ceils defs) - = (FB tops emptyBag defs, ceils) - --- Perform some action at a join ceiling, i.e., don't let join points float out --- (see Note [Join points]) -atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr) - -> (FloatStats, FloatBinds, CoreExpr) -atJoinCeiling (fs, floats, expr') - = (fs, floats', install ceils expr') - where - (floats', ceils) = partitionAtJoinCeiling floats - -wrapTick :: Tickish Id -> FloatBinds -> FloatBinds -wrapTick t (FB tops ceils defns) - = FB (mapBag wrap_bind tops) (wrap_defns ceils) - (M.map (M.map wrap_defns) defns) - where - wrap_defns = mapBag wrap_one - - wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs) - wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs) - - wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) - wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs - - maybe_tick e | exprIsHNF e = tickHNFArgs t e - | otherwise = mkTick t e - -- we don't need to wrap a tick around an HNF when we float it - -- outside a tick: that is an invariant of the tick semantics - -- Conversely, inlining of HNFs inside an SCC is allowed, and - -- indeed the HNF we're floating here might well be inlined back - -- again, and we don't want to end up with duplicate ticks. diff --git a/simplCore/LiberateCase.hs b/simplCore/LiberateCase.hs deleted file mode 100644 --- a/simplCore/LiberateCase.hs +++ /dev/null @@ -1,422 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1994-1998 - -\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} --} - -{-# LANGUAGE CPP #-} -module LiberateCase ( liberateCase ) where - -#include "HsVersions.h" - -import DynFlags -import CoreSyn -import CoreUnfold ( couldBeSmallEnoughToInline ) -import Id -import VarEnv -import Util ( notNull ) - -{- -The liberate-case transformation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This module walks over @Core@, and looks for @case@ on free variables. -The criterion is: - if there is case on a free on the route to the recursive call, - then the recursive call is replaced with an unfolding. - -Example - - f = \ t -> case v of - V a b -> a : f t - -=> the inner f is replaced. - - f = \ t -> case v of - V a b -> a : (letrec - f = \ t -> case v of - V a b -> a : f t - in f) t -(note the NEED for shadowing) - -=> Simplify - - f = \ t -> case v of - V a b -> a : (letrec - f = \ t -> a : f t - in f t) - -Better code, because 'a' is free inside the inner letrec, rather -than needing projection from v. - -Note that this deals with *free variables*. SpecConstr deals with -*arguments* that are of known form. E.g. - - last [] = error - last (x:[]) = x - last (x:xs) = last xs - - -Note [Scrutinee with cast] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - f = \ t -> case (v `cast` co) of - V a b -> a : f t - -Exactly the same optimisation (unrolling one call to f) will work here, -despite the cast. See mk_alt_env in the Case branch of libCase. - - -Note [Only functions!] -~~~~~~~~~~~~~~~~~~~~~~ -Consider the following code - - f = g (case v of V a b -> a : t f) - -where g is expensive. If we aren't careful, liberate case will turn this into - - f = g (case v of - V a b -> a : t (letrec f = g (case v of V a b -> a : f t) - in f) - ) - -Yikes! We evaluate g twice. This leads to a O(2^n) explosion -if g calls back to the same code recursively. - -Solution: make sure that we only do the liberate-case thing on *functions* - -To think about (Apr 94) -~~~~~~~~~~~~~~ -Main worry: duplicating code excessively. At the moment we duplicate -the entire binding group once at each recursive call. But there may -be a group of recursive calls which share a common set of evaluated -free variables, in which case the duplication is a plain waste. - -Another thing we could consider adding is some unfold-threshold thing, -so that we'll only duplicate if the size of the group rhss isn't too -big. - -Data types -~~~~~~~~~~ -The ``level'' of a binder tells how many -recursive defns lexically enclose the binding -A recursive defn "encloses" its RHS, not its -scope. For example: -\begin{verbatim} - letrec f = let g = ... in ... - in - let h = ... - in ... -\end{verbatim} -Here, the level of @f@ is zero, the level of @g@ is one, -and the level of @h@ is zero (NB not one). - - -************************************************************************ -* * - Top-level code -* * -************************************************************************ --} - -liberateCase :: DynFlags -> CoreProgram -> CoreProgram -liberateCase dflags binds = do_prog (initEnv dflags) binds - where - do_prog _ [] = [] - do_prog env (bind:binds) = bind' : do_prog env' binds - where - (env', bind') = libCaseBind env bind - -{- -************************************************************************ -* * - Main payload -* * -************************************************************************ - -Bindings -~~~~~~~~ --} - -libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind) - -libCaseBind env (NonRec binder rhs) - = (addBinders env [binder], NonRec binder (libCase env rhs)) - -libCaseBind env (Rec pairs) - = (env_body, Rec pairs') - where - binders = map fst pairs - - env_body = addBinders env binders - - pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs] - - -- We extend the rec-env by binding each Id to its rhs, first - -- processing the rhs with an *un-extended* environment, so - -- that the same process doesn't occur for ever! - env_rhs = addRecBinds env [ (localiseId binder, libCase env_body rhs) - | (binder, rhs) <- pairs - , rhs_small_enough binder rhs ] - -- localiseID : see Note [Need to localiseId in libCaseBind] - - - rhs_small_enough id rhs -- Note [Small enough] - = idArity id > 0 -- Note [Only functions!] - && maybe True (\size -> couldBeSmallEnoughToInline (lc_dflags env) size rhs) - (bombOutSize env) - -{- -Note [Need to localiseId in libCaseBind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The call to localiseId is needed for two subtle reasons -(a) Reset the export flags on the binders so - that we don't get name clashes on exported things if the - local binding floats out to top level. This is most unlikely - to happen, since the whole point concerns free variables. - But resetting the export flag is right regardless. - -(b) Make the name an Internal one. External Names should never be - nested; if it were floated to the top level, we'd get a name - clash at code generation time. - -Note [Small enough] -~~~~~~~~~~~~~~~~~~~ -Consider - \fv. letrec - f = \x. BIG...(case fv of { (a,b) -> ...g.. })... - g = \y. SMALL...f... -Then we *can* do liberate-case on g (small RHS) but not for f (too big). -But we can choose on a item-by-item basis, and that's what the -rhs_small_enough call in the comprehension for env_rhs does. - -Expressions -~~~~~~~~~~~ --} - -libCase :: LibCaseEnv - -> CoreExpr - -> CoreExpr - -libCase env (Var v) = libCaseApp env v [] -libCase _ (Lit lit) = Lit lit -libCase _ (Type ty) = Type ty -libCase _ (Coercion co) = Coercion co -libCase env e@(App {}) | let (fun, args) = collectArgs e - , Var v <- fun - = libCaseApp env v args -libCase env (App fun arg) = App (libCase env fun) (libCase env arg) -libCase env (Tick tickish body) = Tick tickish (libCase env body) -libCase env (Cast e co) = Cast (libCase env e) co - -libCase env (Lam binder body) - = Lam binder (libCase (addBinders env [binder]) body) - -libCase env (Let bind body) - = Let bind' (libCase env_body body) - where - (env_body, bind') = libCaseBind env bind - -libCase env (Case scrut bndr ty alts) - = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) - where - env_alts = addBinders (mk_alt_env scrut) [bndr] - mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var - mk_alt_env (Cast scrut _) = mk_alt_env scrut -- Note [Scrutinee with cast] - mk_alt_env _ = env - -libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr) - -> (AltCon, [CoreBndr], CoreExpr) -libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) - -{- -Ids -~~~ - -To unfold, we can't just wrap the id itself in its binding if it's a join point: - - jump j a b c => (joinrec j x y z = ... in jump j) a b c -- wrong!!! - -Every jump must provide all arguments, so we have to be careful to wrap the -whole jump instead: - - jump j a b c => joinrec j x y z = ... in jump j a b c -- right - --} - -libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr -libCaseApp env v args - | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing - , notNull free_scruts -- with free vars scrutinised in RHS - = Let the_bind expr' - - | otherwise - = expr' - - where - rec_id_level = lookupLevel env v - free_scruts = freeScruts env rec_id_level - expr' = mkApps (Var v) (map (libCase env) args) - -freeScruts :: LibCaseEnv - -> LibCaseLevel -- Level of the recursive Id - -> [Id] -- Ids that are scrutinised between the binding - -- of the recursive Id and here -freeScruts env rec_bind_lvl - = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env - , scrut_bind_lvl <= rec_bind_lvl - , scrut_at_lvl > rec_bind_lvl] - -- Note [When to specialise] - -- Note [Avoiding fruitless liberate-case] - -{- -Note [When to specialise] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f = \x. letrec g = \y. case x of - True -> ... (f a) ... - False -> ... (g b) ... - -We get the following levels - f 0 - x 1 - g 1 - y 2 - -Then 'x' is being scrutinised at a deeper level than its binding, so -it's added to lc_sruts: [(x,1)] - -We do *not* want to specialise the call to 'f', because 'x' is not free -in 'f'. So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0). - -We *do* want to specialise the call to 'g', because 'x' is free in g. -Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1). - -Note [Avoiding fruitless liberate-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider also: - f = \x. case top_lvl_thing of - I# _ -> let g = \y. ... g ... - in ... - -Here, top_lvl_thing is scrutinised at a level (1) deeper than its -binding site (0). Nevertheless, we do NOT want to specialise the call -to 'g' because all the structure in its free variables is already -visible at the definition site for g. Hence, when considering specialising -an occurrence of 'g', we want to check that there's a scruted-var v st - - a) v's binding site is *outside* g - b) v's scrutinisation site is *inside* g - - -************************************************************************ -* * - Utility functions -* * -************************************************************************ --} - -addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv -addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders - = env { lc_lvl_env = lvl_env' } - where - lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl) - -addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv -addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env, - lc_rec_env = rec_env}) pairs - = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' } - where - lvl' = lvl + 1 - lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs] - rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs] - -addScrutedVar :: LibCaseEnv - -> Id -- This Id is being scrutinised by a case expression - -> LibCaseEnv - -addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env, - lc_scruts = scruts }) scrut_var - | bind_lvl < lvl - = env { lc_scruts = scruts' } - -- Add to scruts iff the scrut_var is being scrutinised at - -- a deeper level than its defn - - | otherwise = env - where - scruts' = (scrut_var, bind_lvl, lvl) : scruts - bind_lvl = case lookupVarEnv lvl_env scrut_var of - Just lvl -> lvl - Nothing -> topLevel - -lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind -lookupRecId env id = lookupVarEnv (lc_rec_env env) id - -lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel -lookupLevel env id - = case lookupVarEnv (lc_lvl_env env) id of - Just lvl -> lvl - Nothing -> topLevel - -{- -************************************************************************ -* * - The environment -* * -************************************************************************ --} - -type LibCaseLevel = Int - -topLevel :: LibCaseLevel -topLevel = 0 - -data LibCaseEnv - = LibCaseEnv { - lc_dflags :: DynFlags, - - lc_lvl :: LibCaseLevel, -- Current level - -- The level is incremented when (and only when) going - -- inside the RHS of a (sufficiently small) recursive - -- function. - - lc_lvl_env :: IdEnv LibCaseLevel, - -- Binds all non-top-level in-scope Ids (top-level and - -- imported things have a level of zero) - - lc_rec_env :: IdEnv CoreBind, - -- Binds *only* recursively defined ids, to their own - -- binding group, and *only* in their own RHSs - - lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)] - -- Each of these Ids was scrutinised by an enclosing - -- case expression, at a level deeper than its binding - -- level. - -- - -- The first LibCaseLevel is the *binding level* of - -- the scrutinised Id, - -- The second is the level *at which it was scrutinised*. - -- (see Note [Avoiding fruitless liberate-case]) - -- The former is a bit redundant, since you could always - -- look it up in lc_lvl_env, but it's just cached here - -- - -- The order is insignificant; it's a bag really - -- - -- There's one element per scrutinisation; - -- in principle the same Id may appear multiple times, - -- although that'd be unusual: - -- case x of { (a,b) -> ....(case x of ...) .. } - } - -initEnv :: DynFlags -> LibCaseEnv -initEnv dflags - = LibCaseEnv { lc_dflags = dflags, - lc_lvl = 0, - lc_lvl_env = emptyVarEnv, - lc_rec_env = emptyVarEnv, - lc_scruts = [] } - --- Bomb-out size for deciding if --- potential liberatees are too big. --- (passed in from cmd-line args) -bombOutSize :: LibCaseEnv -> Maybe Int -bombOutSize = liberateCaseThreshold . lc_dflags diff --git a/simplCore/OccurAnal.hs b/simplCore/OccurAnal.hs deleted file mode 100644 --- a/simplCore/OccurAnal.hs +++ /dev/null @@ -1,2772 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -************************************************************************ -* * -\section[OccurAnal]{Occurrence analysis pass} -* * -************************************************************************ - -The occurrence analyser re-typechecks a core expression, returning a new -core expression with (hopefully) improved usage information. --} - -{-# LANGUAGE CPP, BangPatterns, MultiWayIf #-} - -module OccurAnal ( - occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap - ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreFVs -import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, - stripTicksTopE, mkTicks ) -import Id -import IdInfo -import Name( localiseName ) -import BasicTypes -import Module( Module ) -import Coercion -import Type - -import VarSet -import VarEnv -import Var -import Demand ( argOneShots, argsOneShots ) -import Digraph ( SCC(..), Node - , stronglyConnCompFromEdgedVerticesUniq - , stronglyConnCompFromEdgedVerticesUniqR ) -import Unique -import UniqFM -import UniqSet -import Util -import Outputable -import Data.List -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap -* * -************************************************************************ - -Here's the externally-callable interface: --} - -occurAnalysePgm :: Module -- Used only in debug output - -> (Activation -> Bool) - -> [CoreRule] -> [CoreVect] -> VarSet - -> CoreProgram -> CoreProgram -occurAnalysePgm this_mod active_rule imp_rules vects vectVars binds - | isEmptyDetails final_usage - = occ_anald_binds - - | otherwise -- See Note [Glomming] - = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon) - 2 (ppr final_usage ) ) - occ_anald_glommed_binds - where - init_env = initOccEnv active_rule - (final_usage, occ_anald_binds) = go init_env binds - (_, occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel - imp_rule_edges - (flattenBinds occ_anald_binds) - initial_uds - -- It's crucial to re-analyse the glommed-together bindings - -- so that we establish the right loop breakers. Otherwise - -- we can easily create an infinite loop (Trac #9583 is an example) - - initial_uds = addManyOccsSet emptyDetails - (rulesFreeVars imp_rules `unionVarSet` - vectsFreeVars vects `unionVarSet` - vectVars) - -- The RULES and VECTORISE declarations keep things alive! (For VECTORISE declarations, - -- we only get them *until* the vectoriser runs. Afterwards, these dependencies are - -- reflected in 'vectors' — see Note [Vectorisation declarations and occurrences].) - - -- Note [Preventing loops due to imported functions rules] - imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv - [ mapVarEnv (const maps_to) $ - getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule) - | imp_rule <- imp_rules - , not (isBuiltinRule imp_rule) -- See Note [Plugin rules] - , let maps_to = exprFreeIds (ru_rhs imp_rule) - `delVarSetList` ru_bndrs imp_rule - , arg <- ru_args imp_rule ] - - go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) - go _ [] - = (initial_uds, []) - go env (bind:binds) - = (final_usage, bind' ++ binds') - where - (bs_usage, binds') = go env binds - (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind - bs_usage - -occurAnalyseExpr :: CoreExpr -> CoreExpr - -- Do occurrence analysis, and discard occurrence info returned -occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap - -occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr -occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap - -occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr -occurAnalyseExpr' enable_binder_swap expr - = snd (occAnal env expr) - where - env = (initOccEnv all_active_rules) {occ_binder_swap = enable_binder_swap} - -- To be conservative, we say that all inlines and rules are active - all_active_rules = \_ -> True - -{- Note [Plugin rules] -~~~~~~~~~~~~~~~~~~~~~~ -Conal Elliott (Trac #11651) built a GHC plugin that added some -BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to -do some domain-specific transformations that could not be expressed -with an ordinary pattern-matching CoreRule. But then we can't extract -the dependencies (in imp_rule_edges) from ru_rhs etc, because a -BuiltinRule doesn't have any of that stuff. - -So we simply assume that BuiltinRules have no dependencies, and filter -them out from the imp_rule_edges comprehension. --} - -{- -************************************************************************ -* * - Bindings -* * -************************************************************************ - -Note [Recursive bindings: the grand plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come across a binding group - Rec { x1 = r1; ...; xn = rn } -we treat it like this (occAnalRecBind): - -1. Occurrence-analyse each right hand side, and build a - "Details" for each binding to capture the results. - - Wrap the details in a Node (details, node-id, dep-node-ids), - where node-id is just the unique of the binder, and - dep-node-ids lists all binders on which this binding depends. - We'll call these the "scope edges". - See Note [Forming the Rec groups]. - - All this is done by makeNode. - -2. Do SCC-analysis on these Nodes. Each SCC will become a new Rec or - NonRec. The key property is that every free variable of a binding - is accounted for by the scope edges, so that when we are done - everything is still in scope. - -3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we - identify suitable loop-breakers to ensure that inlining terminates. - This is done by occAnalRec. - -4. To do so we form a new set of Nodes, with the same details, but - different edges, the "loop-breaker nodes". The loop-breaker nodes - have both more and fewer depedencies than the scope edges - (see Note [Choosing loop breakers]) - - More edges: if f calls g, and g has an active rule that mentions h - then we add an edge from f -> h - - Fewer edges: we only include dependencies on active rules, on rule - RHSs (not LHSs) and if there is an INLINE pragma only - on the stable unfolding (and vice versa). The scope - edges must be much more inclusive. - -5. The "weak fvs" of a node are, by definition: - the scope fvs - the loop-breaker fvs - See Note [Weak loop breakers], and the nd_weak field of Details - -6. Having formed the loop-breaker nodes - -Note [Dead code] -~~~~~~~~~~~~~~~~ -Dropping dead code for a cyclic Strongly Connected Component is done -in a very simple way: - - the entire SCC is dropped if none of its binders are mentioned - in the body; otherwise the whole thing is kept. - -The key observation is that dead code elimination happens after -dependency analysis: so 'occAnalBind' processes SCCs instead of the -original term's binding groups. - -Thus 'occAnalBind' does indeed drop 'f' in an example like - - letrec f = ...g... - g = ...(...g...)... - in - ...g... - -when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in -'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes -'AcyclicSCC f', where 'body_usage' won't contain 'f'. - ------------------------------------------------------------- -Note [Forming Rec groups] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We put bindings {f = ef; g = eg } in a Rec group if "f uses g" -and "g uses f", no matter how indirectly. We do a SCC analysis -with an edge f -> g if "f uses g". - -More precisely, "f uses g" iff g should be in scope wherever f is. -That is, g is free in: - a) the rhs 'ef' - b) or the RHS of a rule for f (Note [Rules are extra RHSs]) - c) or the LHS or a rule for f (Note [Rule dependency info]) - -These conditions apply regardless of the activation of the RULE (eg it might be -inactive in this phase but become active later). Once a Rec is broken up -it can never be put back together, so we must be conservative. - -The principle is that, regardless of rule firings, every variable is -always in scope. - - * Note [Rules are extra RHSs] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" - keeps the specialised "children" alive. If the parent dies - (because it isn't referenced any more), then the children will die - too (unless they are already referenced directly). - - To that end, we build a Rec group for each cyclic strongly - connected component, - *treating f's rules as extra RHSs for 'f'*. - More concretely, the SCC analysis runs on a graph with an edge - from f -> g iff g is mentioned in - (a) f's rhs - (b) f's RULES - These are rec_edges. - - Under (b) we include variables free in *either* LHS *or* RHS of - the rule. The former might seems silly, but see Note [Rule - dependency info]. So in Example [eftInt], eftInt and eftIntFB - will be put in the same Rec, even though their 'main' RHSs are - both non-recursive. - - * Note [Rule dependency info] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The VarSet in a RuleInfo is used for dependency analysis in the - occurrence analyser. We must track free vars in *both* lhs and rhs. - Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. - Why both? Consider - x = y - RULE f x = v+4 - Then if we substitute y for x, we'd better do so in the - rule's LHS too, so we'd better ensure the RULE appears to mention 'x' - as well as 'v' - - * Note [Rules are visible in their own rec group] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We want the rules for 'f' to be visible in f's right-hand side. - And we'd like them to be visible in other functions in f's Rec - group. E.g. in Note [Specialisation rules] we want f' rule - to be visible in both f's RHS, and fs's RHS. - - This means that we must simplify the RULEs first, before looking - at any of the definitions. This is done by Simplify.simplRecBind, - when it calls addLetIdInfo. - ------------------------------------------------------------- -Note [Choosing loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Loop breaking is surprisingly subtle. First read the section 4 of -"Secrets of the GHC inliner". This describes our basic plan. -We avoid infinite inlinings by choosing loop breakers, and -ensuring that a loop breaker cuts each loop. - -See also Note [Inlining and hs-boot files] in ToIface, which deals -with a closely related source of infinite loops. - -Fundamentally, we do SCC analysis on a graph. For each recursive -group we choose a loop breaker, delete all edges to that node, -re-analyse the SCC, and iterate. - -But what is the graph? NOT the same graph as was used for Note -[Forming Rec groups]! In particular, a RULE is like an equation for -'f' that is *always* inlined if it is applicable. We do *not* disable -rules for loop-breakers. It's up to whoever makes the rules to make -sure that the rules themselves always terminate. See Note [Rules for -recursive functions] in Simplify.hs - -Hence, if - f's RHS (or its INLINE template if it has one) mentions g, and - g has a RULE that mentions h, and - h has a RULE that mentions f - -then we *must* choose f to be a loop breaker. Example: see Note -[Specialisation rules]. - -In general, take the free variables of f's RHS, and augment it with -all the variables reachable by RULES from those starting points. That -is the whole reason for computing rule_fv_env in occAnalBind. (Of -course we only consider free vars that are also binders in this Rec -group.) See also Note [Finding rule RHS free vars] - -Note that when we compute this rule_fv_env, we only consider variables -free in the *RHS* of the rule, in contrast to the way we build the -Rec group in the first place (Note [Rule dependency info]) - -Note that if 'g' has RHS that mentions 'w', we should add w to -g's loop-breaker edges. More concretely there is an edge from f -> g -iff - (a) g is mentioned in f's RHS `xor` f's INLINE rhs - (see Note [Inline rules]) - (b) or h is mentioned in f's RHS, and - g appears in the RHS of an active RULE of h - or a transitive sequence of active rules starting with h - -Why "active rules"? See Note [Finding rule RHS free vars] - -Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is -chosen as a loop breaker, because their RHSs don't mention each other. -And indeed both can be inlined safely. - -Note again that the edges of the graph we use for computing loop breakers -are not the same as the edges we use for computing the Rec blocks. -That's why we compute - -- rec_edges for the Rec block analysis -- loop_breaker_nodes for the loop breaker analysis - - * Note [Finding rule RHS free vars] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Consider this real example from Data Parallel Haskell - tagZero :: Array Int -> Array Tag - {-# INLINE [1] tagZeroes #-} - tagZero xs = pmap (\x -> fromBool (x==0)) xs - - {-# RULES "tagZero" [~1] forall xs n. - pmap fromBool = tagZero xs #-} - So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. - However, tagZero can only be inlined in phase 1 and later, while - the RULE is only active *before* phase 1. So there's no problem. - - To make this work, we look for the RHS free vars only for - *active* rules. That's the reason for the occ_rule_act field - of the OccEnv. - - * Note [Weak loop breakers] - ~~~~~~~~~~~~~~~~~~~~~~~~~ - There is a last nasty wrinkle. Suppose we have - - Rec { f = f_rhs - RULE f [] = g - - h = h_rhs - g = h - ...more... - } - - Remember that we simplify the RULES before any RHS (see Note - [Rules are visible in their own rec group] above). - - So we must *not* postInlineUnconditionally 'g', even though - its RHS turns out to be trivial. (I'm assuming that 'g' is - not choosen as a loop breaker.) Why not? Because then we - drop the binding for 'g', which leaves it out of scope in the - RULE! - - Here's a somewhat different example of the same thing - Rec { g = h - ; h = ...f... - ; f = f_rhs - RULE f [] = g } - Here the RULE is "below" g, but we *still* can't postInlineUnconditionally - g, because the RULE for f is active throughout. So the RHS of h - might rewrite to h = ...g... - So g must remain in scope in the output program! - - We "solve" this by: - - Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True) - iff g is a "missing free variable" of the Rec group - - A "missing free variable" x is one that is mentioned in an RHS or - INLINE or RULE of a binding in the Rec group, but where the - dependency on x may not show up in the loop_breaker_nodes (see - note [Choosing loop breakers} above). - - A normal "strong" loop breaker has IAmLoopBreaker False. So - - Inline postInlineUnconditionally - strong IAmLoopBreaker False no no - weak IAmLoopBreaker True yes no - other yes yes - - The **sole** reason for this kind of loop breaker is so that - postInlineUnconditionally does not fire. Ugh. (Typically it'll - inline via the usual callSiteInline stuff, so it'll be dead in the - next pass, so the main Ugh is the tiresome complication.) - -Note [Rules for imported functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - f = /\a. B.g a - RULE B.g Int = 1 + f Int -Note that - * The RULE is for an imported function. - * f is non-recursive -Now we -can get - f Int --> B.g Int Inlining f - --> 1 + f Int Firing RULE -and so the simplifier goes into an infinite loop. This -would not happen if the RULE was for a local function, -because we keep track of dependencies through rules. But -that is pretty much impossible to do for imported Ids. Suppose -f's definition had been - f = /\a. C.h a -where (by some long and devious process), C.h eventually inlines to -B.g. We could only spot such loops by exhaustively following -unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) -f. - -Note that RULES for imported functions are important in practice; they -occur a lot in the libraries. - -We regard this potential infinite loop as a *programmer* error. -It's up the programmer not to write silly rules like - RULE f x = f x -and the example above is just a more complicated version. - -Note [Preventing loops due to imported functions rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - import GHC.Base (foldr) - - {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} - filter p xs = build (\c n -> foldr (filterFB c p) n xs) - filterFB c p = ... - - f = filter p xs - -Note that filter is not a loop-breaker, so what happens is: - f = filter p xs - = {inline} build (\c n -> foldr (filterFB c p) n xs) - = {inline} foldr (filterFB (:) p) [] xs - = {RULE} filter p xs - -We are in an infinite loop. - -A more elaborate example (that I actually saw in practice when I went to -mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: - {-# LANGUAGE RankNTypes #-} - module GHCList where - - import Prelude hiding (filter) - import GHC.Base (build) - - {-# INLINABLE filter #-} - filter :: (a -> Bool) -> [a] -> [a] - filter p [] = [] - filter p (x:xs) = if p x then x : filter p xs else filter p xs - - {-# NOINLINE [0] filterFB #-} - filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b - filterFB c p x r | p x = x `c` r - | otherwise = r - - {-# RULES - "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr - (filterFB c p) n xs) - "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p - #-} - -Then (because RULES are applied inside INLINABLE unfoldings, but inlinings -are not), the unfolding given to "filter" in the interface file will be: - filter p [] = [] - filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) - else build (\c n -> foldr (filterFB c p) n xs - -Note that because this unfolding does not mention "filter", filter is not -marked as a strong loop breaker. Therefore at a use site in another module: - filter p xs - = {inline} - case xs of [] -> [] - (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) - else build (\c n -> foldr (filterFB c p) n xs) - - build (\c n -> foldr (filterFB c p) n xs) - = {inline} foldr (filterFB (:) p) [] xs - = {RULE} filter p xs - -And we are in an infinite loop again, except that this time the loop is producing an -infinitely large *term* (an unrolling of filter) and so the simplifier finally -dies with "ticks exhausted" - -Because of this problem, we make a small change in the occurrence analyser -designed to mark functions like "filter" as strong loop breakers on the basis that: - 1. The RHS of filter mentions the local function "filterFB" - 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS - -So for each RULE for an *imported* function we are going to add -dependency edges between the *local* FVS of the rule LHS and the -*local* FVS of the rule RHS. We don't do anything special for RULES on -local functions because the standard occurrence analysis stuff is -pretty good at getting loop-breakerness correct there. - -It is important to note that even with this extra hack we aren't always going to get -things right. For example, it might be that the rule LHS mentions an imported Id, -and another module has a RULE that can rewrite that imported Id to one of our local -Ids. - -Note [Specialising imported functions] (referred to from Specialise) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -BUT for *automatically-generated* rules, the programmer can't be -responsible for the "programmer error" in Note [Rules for imported -functions]. In paricular, consider specialising a recursive function -defined in another module. If we specialise a recursive function B.g, -we get - g_spec = .....(B.g Int)..... - RULE B.g Int = g_spec -Here, g_spec doesn't look recursive, but when the rule fires, it -becomes so. And if B.g was mutually recursive, the loop might -not be as obvious as it is here. - -To avoid this, - * When specialising a function that is a loop breaker, - give a NOINLINE pragma to the specialised function - -Note [Glomming] -~~~~~~~~~~~~~~~ -RULES for imported Ids can make something at the top refer to something at the bottom: - f = \x -> B.g (q x) - h = \y -> 3 - - RULE: B.g (q x) = h x - -Applying this rule makes f refer to h, although f doesn't appear to -depend on h. (And, as in Note [Rules for imported functions], the -dependency might be more indirect. For example, f might mention C.t -rather than B.g, where C.t eventually inlines to B.g.) - -NOTICE that this cannot happen for rules whose head is a -locally-defined function, because we accurately track dependencies -through RULES. It only happens for rules whose head is an imported -function (B.g in the example above). - -Solution: - - When simplifying, bring all top level identifiers into - scope at the start, ignoring the Rec/NonRec structure, so - that when 'h' pops up in f's rhs, we find it in the in-scope set - (as the simplifier generally expects). This happens in simplTopBinds. - - - In the occurrence analyser, if there are any out-of-scope - occurrences that pop out of the top, which will happen after - firing the rule: f = \x -> h x - h = \y -> 3 - then just glom all the bindings into a single Rec, so that - the *next* iteration of the occurrence analyser will sort - them all out. This part happens in occurAnalysePgm. - ------------------------------------------------------------- -Note [Inline rules] -~~~~~~~~~~~~~~~~~~~ -None of the above stuff about RULES applies to Inline Rules, -stored in a CoreUnfolding. The unfolding, if any, is simplified -at the same time as the regular RHS of the function (ie *not* like -Note [Rules are visible in their own rec group]), so it should be -treated *exactly* like an extra RHS. - -Or, rather, when computing loop-breaker edges, - * If f has an INLINE pragma, and it is active, we treat the - INLINE rhs as f's rhs - * If it's inactive, we treat f as having no rhs - * If it has no INLINE pragma, we look at f's actual rhs - - -There is a danger that we'll be sub-optimal if we see this - f = ...f... - [INLINE f = ..no f...] -where f is recursive, but the INLINE is not. This can just about -happen with a sufficiently odd set of rules; eg - - foo :: Int -> Int - {-# INLINE [1] foo #-} - foo x = x+1 - - bar :: Int -> Int - {-# INLINE [1] bar #-} - bar x = foo x + 1 - - {-# RULES "foo" [~1] forall x. foo x = bar x #-} - -Here the RULE makes bar recursive; but it's INLINE pragma remains -non-recursive. It's tempting to then say that 'bar' should not be -a loop breaker, but an attempt to do so goes wrong in two ways: - a) We may get - $df = ...$cfoo... - $cfoo = ...$df.... - [INLINE $cfoo = ...no-$df...] - But we want $cfoo to depend on $df explicitly so that we - put the bindings in the right order to inline $df in $cfoo - and perhaps break the loop altogether. (Maybe this - b) - - -Example [eftInt] -~~~~~~~~~~~~~~~ -Example (from GHC.Enum): - - eftInt :: Int# -> Int# -> [Int] - eftInt x y = ...(non-recursive)... - - {-# INLINE [0] eftIntFB #-} - eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r - eftIntFB c n x y = ...(non-recursive)... - - {-# RULES - "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) - "eftIntList" [1] eftIntFB (:) [] = eftInt - #-} - -Note [Specialisation rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this group, which is typical of what SpecConstr builds: - - fs a = ....f (C a).... - f x = ....f (C a).... - {-# RULE f (C a) = fs a #-} - -So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). - -But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: - - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify - - fs is inlined (say it's small) - - now there's another opportunity to apply the RULE - -This showed up when compiling Control.Concurrent.Chan.getChanContents. - ------------------------------------------------------------- -Note [Finding join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's the occurrence analyser's job to find bindings that we can turn into join -points, but it doesn't perform that transformation right away. Rather, it marks -the eligible bindings as part of their occurrence data, leaving it to the -simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'. -The simplifier then eta-expands the RHS if needed and then updates the -occurrence sites. Dividing the work this way means that the occurrence analyser -still only takes one pass, yet one can always tell the difference between a -function call and a jump by looking at the occurrence (because the same pass -changes the 'IdDetails' and propagates the binders to their occurrence sites). - -To track potential join points, we use the 'occ_tail' field of OccInfo. A value -of `AlwaysTailCalled n` indicates that every occurrence of the variable is a -tail call with `n` arguments (counting both value and type arguments). Otherwise -'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the -rest of 'OccInfo' until it goes on the binder. - -Note [Rules and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Things get fiddly with rules. Suppose we have: - - let j :: Int -> Int - j y = 2 * y - k :: Int -> Int -> Int - {-# RULES "SPEC k 0" k 0 = j #-} - k x y = x + 2 * y - in ... - -Now suppose that both j and k appear only as saturated tail calls in the body. -Thus we would like to make them both join points. The rule complicates matters, -though, as its RHS has an unapplied occurrence of j. *However*, if we were to -eta-expand the rule, all would be well: - - {-# RULES "SPEC k 0" forall a. k 0 a = j a #-} - -So conceivably we could notice that a potential join point would have an -"undersaturated" rule and account for it. This would mean we could make -something that's been specialised a join point, for instance. But local bindings -are rarely specialised, and being overly cautious about rules only -costs us anything when, for some `j`: - - * Before specialisation, `j` has non-tail calls, so it can't be a join point. - * During specialisation, `j` gets specialised and thus acquires rules. - * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say), - and so now `j` *could* become a join point. - -This appears to be very rare in practice. TODO Perhaps we should gather -statistics to be sure. - -Note [Excess polymorphism and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In principle, if a function would be a join point except that it fails -the polymorphism rule (see Note [The polymorphism rule of join points] in -CoreSyn), it can still be made a join point with some effort. This is because -all tail calls must return the same type (they return to the same context!), and -thus if the return type depends on an argument, that argument must always be the -same. - -For instance, consider: - - let f :: forall a. a -> Char -> [a] - f @a x c = ... f @a x 'a' ... - in ... f @Int 1 'b' ... f @Int 2 'c' ... - -(where the calls are tail calls). `f` fails the polymorphism rule because its -return type is [a], where [a] is bound. But since the type argument is always -'Int', we can rewrite it as: - - let f' :: Int -> Char -> [Int] - f' x c = ... f' x 'a' ... - in ... f' 1 'b' ... f 2 'c' ... - -and now we can make f' a join point: - - join f' :: Int -> Char -> [Int] - f' x c = ... jump f' x 'a' ... - in ... jump f' 1 'b' ... jump f' 2 'c' ... - -It's not clear that this comes up often, however. TODO: Measure how often and -add this analysis if necessary. - ------------------------------------------------------------- -Note [Adjusting for lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's a bit of a dance we need to do after analysing a lambda expression or -a right-hand side. In particular, we need to - - a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot - lambda, or a non-recursive join point; and - b) call 'markAllNonTailCalled' *unless* the binding is for a join point. - -Some examples, with how the free occurrences in e (assumed not to be a value -lambda) get marked: - - inside lam non-tail-called - ------------------------------------------------------------ - let x = e No Yes - let f = \x -> e Yes Yes - let f = \x{OneShot} -> e No Yes - \x -> e Yes Yes - join j x = e No No - joinrec j x = e Yes No - -There are a few other caveats; most importantly, if we're marking a binding as -'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so -that the effect cascades properly. Consequently, at the time the RHS is -analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must -return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once -join-point-hood has been decided. - -Thus the overall sequence taking place in 'occAnalNonRecBind' and -'occAnalRecBind' is as follows: - - 1. Call 'occAnalLamOrRhs' to find usage information for the RHS. - 2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make - the binding a join point. - 3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when - recursive.) - -(In the recursive case, this logic is spread between 'makeNode' and -'occAnalRec'.) --} - ------------------------------------------------------------------- --- occAnalBind ------------------------------------------------------------------- - -occAnalBind :: OccEnv -- The incoming OccEnv - -> TopLevelFlag - -> ImpRuleEdges - -> CoreBind - -> UsageDetails -- Usage details of scope - -> (UsageDetails, -- Of the whole let(rec) - [CoreBind]) - -occAnalBind env lvl top_env (NonRec binder rhs) body_usage - = occAnalNonRecBind env lvl top_env binder rhs body_usage -occAnalBind env lvl top_env (Rec pairs) body_usage - = occAnalRecBind env lvl top_env pairs body_usage - ------------------ -occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr - -> UsageDetails -> (UsageDetails, [CoreBind]) -occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage - | isTyVar binder -- A type let; we don't gather usage info - = (body_usage, [NonRec binder rhs]) - - | not (binder `usedIn` body_usage) -- It's not mentioned - = (body_usage, []) - - | otherwise -- It's mentioned in the body - = (body_usage' +++ rhs_usage', [NonRec tagged_binder rhs']) - where - (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder - mb_join_arity = willBeJoinId_maybe tagged_binder - - (bndrs, body) = collectBinders rhs - - (rhs_usage1, bndrs', body') = occAnalNonRecRhs env tagged_binder bndrs body - rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body' - -- For a /non-recursive/ join point we can mark all - -- its join-lambda as one-shot; and it's a good idea to do so - - -- Unfoldings - -- See Note [Unfoldings and join points] - rhs_usage2 = case occAnalUnfolding env NonRecursive binder of - Just unf_usage -> rhs_usage1 +++ unf_usage - Nothing -> rhs_usage1 - - -- Rules - -- See Note [Rules are extra RHSs] and Note [Rule dependency info] - rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder - rhs_usage3 = rhs_usage2 +++ combineUsageDetailsList - (map (\(_, l, r) -> l +++ r) rules_w_uds) - rhs_usage4 = maybe rhs_usage3 (addManyOccsSet rhs_usage3) $ - lookupVarEnv imp_rule_edges binder - -- See Note [Preventing loops due to imported functions rules] - - -- Final adjustment - rhs_usage' = adjustRhsUsage mb_join_arity NonRecursive bndrs' rhs_usage4 - ------------------ -occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)] - -> UsageDetails -> (UsageDetails, [CoreBind]) -occAnalRecBind env lvl imp_rule_edges pairs body_usage - = foldr (occAnalRec lvl) (body_usage, []) sccs - -- For a recursive group, we - -- * occ-analyse all the RHSs - -- * compute strongly-connected components - -- * feed those components to occAnalRec - -- See Note [Recursive bindings: the grand plan] - where - sccs :: [SCC Details] - sccs = {-# SCC "occAnalBind.scc" #-} - stronglyConnCompFromEdgedVerticesUniq nodes - - nodes :: [LetrecNode] - nodes = {-# SCC "occAnalBind.assoc" #-} - map (makeNode env imp_rule_edges bndr_set) pairs - - bndr_set = mkVarSet (map fst pairs) - -{- -Note [Unfoldings and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We assume that anything in an unfolding occurs multiple times, since unfoldings -are often copied (that's the whole point!). But we still need to track tail -calls for the purpose of finding join points. --} - ------------------------------ -occAnalRec :: TopLevelFlag - -> SCC Details - -> (UsageDetails, [CoreBind]) - -> (UsageDetails, [CoreBind]) - - -- The NonRec case is just like a Let (NonRec ...) above -occAnalRec lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs - , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs })) - (body_uds, binds) - | not (bndr `usedIn` body_uds) - = (body_uds, binds) -- See Note [Dead code] - - | otherwise -- It's mentioned in the body - = (body_uds' +++ rhs_uds', - NonRec tagged_bndr rhs : binds) - where - (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr - rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive - rhs_bndrs rhs_uds - - -- The Rec case is the interesting one - -- See Note [Recursive bindings: the grand plan] - -- See Note [Loop breaking] -occAnalRec lvl (CyclicSCC details_s) (body_uds, binds) - | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds - = (body_uds, binds) -- See Note [Dead code] - - | otherwise -- At this point we always build a single Rec - = -- pprTrace "occAnalRec" (vcat - -- [ text "weak_fvs" <+> ppr weak_fvs - -- , text "tagged details" <+> ppr tagged_details_s - -- , text "lb nodes" <+> ppr loop_breaker_nodes]) - (final_uds, Rec pairs : binds) - - where - bndrs = map nd_bndr details_s - bndr_set = mkVarSet bndrs - - ------------------------------ - -- See Note [Choosing loop breakers] for loop_breaker_nodes - final_uds :: UsageDetails - loop_breaker_nodes :: [LetrecNode] - (final_uds, loop_breaker_nodes) - = mkLoopBreakerNodes lvl bndr_set body_uds details_s - - ------------------------------ - weak_fvs :: VarSet - weak_fvs = mapUnionVarSet nd_weak details_s - - --------------------------- - -- Now reconstruct the cycle - pairs :: [(Id,CoreExpr)] - pairs | isEmptyVarSet weak_fvs = reOrderNodes 0 bndr_set weak_fvs loop_breaker_nodes [] - | otherwise = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_nodes [] - -- If weak_fvs is empty, the loop_breaker_nodes will include - -- all the edges in the original scope edges [remember, - -- weak_fvs is the difference between scope edges and - -- lb-edges], so a fresh SCC computation would yield a - -- single CyclicSCC result; and reOrderNodes deals with - -- exactly that case - - ------------------------------------------------------------------- --- Loop breaking ------------------------------------------------------------------- - -type Binding = (Id,CoreExpr) - -loopBreakNodes :: Int - -> VarSet -- All binders - -> VarSet -- Binders whose dependencies may be "missing" - -- See Note [Weak loop breakers] - -> [LetrecNode] - -> [Binding] -- Append these to the end - -> [Binding] -{- -loopBreakNodes is applied to the list of nodes for a cyclic strongly -connected component (there's guaranteed to be a cycle). It returns -the same nodes, but - a) in a better order, - b) with some of the Ids having a IAmALoopBreaker pragma - -The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means -that the simplifier can guarantee not to loop provided it never records an inlining -for these no-inline guys. - -Furthermore, the order of the binds is such that if we neglect dependencies -on the no-inline Ids then the binds are topologically sorted. This means -that the simplifier will generally do a good job if it works from top bottom, -recording inlinings for any Ids which aren't marked as "no-inline" as it goes. --} - --- Return the bindings sorted into a plausible order, and marked with loop breakers. -loopBreakNodes depth bndr_set weak_fvs nodes binds - = go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds - where - go [] binds = binds - go (scc:sccs) binds = loop_break_scc scc (go sccs binds) - - loop_break_scc scc binds - = case scc of - AcyclicSCC node -> mk_non_loop_breaker weak_fvs node : binds - CyclicSCC nodes -> reOrderNodes depth bndr_set weak_fvs nodes binds - ----------------------------------- -reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding] - -- Choose a loop breaker, mark it no-inline, - -- and call loopBreakNodes on the rest -reOrderNodes _ _ _ [] _ = panic "reOrderNodes" -reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds -reOrderNodes depth bndr_set weak_fvs (node : nodes) binds - = -- pprTrace "reOrderNodes" (text "unchosen" <+> ppr unchosen $$ - -- text "chosen" <+> ppr chosen_nodes) $ - loopBreakNodes new_depth bndr_set weak_fvs unchosen $ - (map mk_loop_breaker chosen_nodes ++ binds) - where - (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb - (nd_score (fstOf3 node)) - [node] [] nodes - - approximate_lb = depth >= 2 - new_depth | approximate_lb = 0 - | otherwise = depth+1 - -- After two iterations (d=0, d=1) give up - -- and approximate, returning to d=0 - -mk_loop_breaker :: LetrecNode -> Binding -mk_loop_breaker (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _) - = (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs) - where - tail_info = tailCallInfo (idOccInfo bndr) - -mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding --- See Note [Weak loop breakers] -mk_non_loop_breaker weak_fvs (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _) - | bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs) - | otherwise = (bndr, rhs) - where - occ' = weakLoopBreaker { occ_tail = tail_info } - tail_info = tailCallInfo (idOccInfo bndr) - ----------------------------------- -chooseLoopBreaker :: Bool -- True <=> Too many iterations, - -- so approximate - -> NodeScore -- Best score so far - -> [LetrecNode] -- Nodes with this score - -> [LetrecNode] -- Nodes with higher scores - -> [LetrecNode] -- Unprocessed nodes - -> ([LetrecNode], [LetrecNode]) - -- This loop looks for the bind with the lowest score - -- to pick as the loop breaker. The rest accumulate in -chooseLoopBreaker _ _ loop_nodes acc [] - = (loop_nodes, acc) -- Done - - -- If approximate_loop_breaker is True, we pick *all* - -- nodes with lowest score, else just one - -- See Note [Complexity of loop breaking] -chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes) - | approx_lb - , rank sc == rank loop_sc - = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes - - | sc `betterLB` loop_sc -- Better score so pick this new one - = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes - - | otherwise -- Worse score so don't pick it - = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes - where - sc = nd_score (fstOf3 node) - -{- -Note [Complexity of loop breaking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The loop-breaking algorithm knocks out one binder at a time, and -performs a new SCC analysis on the remaining binders. That can -behave very badly in tightly-coupled groups of bindings; in the -worst case it can be (N**2)*log N, because it does a full SCC -on N, then N-1, then N-2 and so on. - -To avoid this, we switch plans after 2 (or whatever) attempts: - Plan A: pick one binder with the lowest score, make it - a loop breaker, and try again - Plan B: pick *all* binders with the lowest score, make them - all loop breakers, and try again -Since there are only a small finite number of scores, this will -terminate in a constant number of iterations, rather than O(N) -iterations. - -You might thing that it's very unlikely, but RULES make it much -more likely. Here's a real example from Trac #1969: - Rec { $dm = \d.\x. op d - {-# RULES forall d. $dm Int d = $s$dm1 - forall d. $dm Bool d = $s$dm2 #-} - - dInt = MkD .... opInt ... - dInt = MkD .... opBool ... - opInt = $dm dInt - opBool = $dm dBool - - $s$dm1 = \x. op dInt - $s$dm2 = \x. op dBool } -The RULES stuff means that we can't choose $dm as a loop breaker -(Note [Choosing loop breakers]), so we must choose at least (say) -opInt *and* opBool, and so on. The number of loop breakders is -linear in the number of instance declarations. - -Note [Loop breakers and INLINE/INLINABLE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Avoid choosing a function with an INLINE pramga as the loop breaker! -If such a function is mutually-recursive with a non-INLINE thing, -then the latter should be the loop-breaker. - -It's vital to distinguish between INLINE and INLINABLE (the -Bool returned by hasStableCoreUnfolding_maybe). If we start with - Rec { {-# INLINABLE f #-} - f x = ...f... } -and then worker/wrapper it through strictness analysis, we'll get - Rec { {-# INLINABLE $wf #-} - $wf p q = let x = (p,q) in ...f... - - {-# INLINE f #-} - f x = case x of (p,q) -> $wf p q } - -Now it is vital that we choose $wf as the loop breaker, so we can -inline 'f' in '$wf'. - -Note [DFuns should not be loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's particularly bad to make a DFun into a loop breaker. See -Note [How instance declarations are translated] in TcInstDcls - -We give DFuns a higher score than ordinary CONLIKE things because -if there's a choice we want the DFun to be the non-loop breaker. Eg - -rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) - - $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) - {-# DFUN #-} - $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) - } - -Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it -if we can't unravel the DFun first. - -Note [Constructor applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's really really important to inline dictionaries. Real -example (the Enum Ordering instance from GHC.Base): - - rec f = \ x -> case d of (p,q,r) -> p x - g = \ x -> case d of (p,q,r) -> q x - d = (v, f, g) - -Here, f and g occur just once; but we can't inline them into d. -On the other hand we *could* simplify those case expressions if -we didn't stupidly choose d as the loop breaker. -But we won't because constructor args are marked "Many". -Inlining dictionaries is really essential to unravelling -the loops in static numeric dictionaries, see GHC.Float. - -Note [Closure conversion] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. -The immediate motivation came from the result of a closure-conversion transformation -which generated code like this: - - data Clo a b = forall c. Clo (c -> a -> b) c - - ($:) :: Clo a b -> a -> b - Clo f env $: x = f env x - - rec { plus = Clo plus1 () - - ; plus1 _ n = Clo plus2 n - - ; plus2 Zero n = n - ; plus2 (Succ m) n = Succ (plus $: m $: n) } - -If we inline 'plus' and 'plus1', everything unravels nicely. But if -we choose 'plus1' as the loop breaker (which is entirely possible -otherwise), the loop does not unravel nicely. - - -@occAnalUnfolding@ deals with the question of bindings where the Id is marked -by an INLINE pragma. For these we record that anything which occurs -in its RHS occurs many times. This pessimistically assumes that this -inlined binder also occurs many times in its scope, but if it doesn't -we'll catch it next time round. At worst this costs an extra simplifier pass. -ToDo: try using the occurrence info for the inline'd binder. - -[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. -[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. - - -************************************************************************ -* * - Making nodes -* * -************************************************************************ --} - -type ImpRuleEdges = IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs - -noImpRuleEdges :: ImpRuleEdges -noImpRuleEdges = emptyVarEnv - -type LetrecNode = Node Unique Details -- Node comes from Digraph - -- The Unique key is gotten from the Id -data Details - = ND { nd_bndr :: Id -- Binder - , nd_rhs :: CoreExpr -- RHS, already occ-analysed - , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS - -- INVARIANT: (nd_rhs_bndrs nd, _) == - -- collectBinders (nd_rhs nd) - - , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and stable unfoldings - -- ignoring phase (ie assuming all are active) - -- See Note [Forming Rec groups] - - , nd_inl :: IdSet -- Free variables of - -- the stable unfolding (if present and active) - -- or the RHS (if not) - -- but excluding any RULES - -- This is the IdSet that may be used if the Id is inlined - - , nd_weak :: IdSet -- Binders of this Rec that are mentioned in nd_uds - -- but are *not* in nd_inl. These are the ones whose - -- dependencies might not be respected by loop_breaker_nodes - -- See Note [Weak loop breakers] - - , nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES - - , nd_score :: NodeScore - } - -instance Outputable Details where - ppr nd = text "ND" <> braces - (sep [ text "bndr =" <+> ppr (nd_bndr nd) - , text "uds =" <+> ppr (nd_uds nd) - , text "inl =" <+> ppr (nd_inl nd) - , text "weak =" <+> ppr (nd_weak nd) - , text "rule =" <+> ppr (nd_active_rule_fvs nd) - ]) - --- The NodeScore is compared lexicographically; --- e.g. lower rank wins regardless of size -type NodeScore = ( Int -- Rank: lower => more likely to be picked as loop breaker - , Int -- Size of rhs: higher => more likely to be picked as LB - -- Maxes out at maxExprSize; we just use it to prioritise - -- small functions - , Bool ) -- Was it a loop breaker before? - -- True => more likely to be picked - -- Note [Loop breakers, node scoring, and stability] - -rank :: NodeScore -> Int -rank (r, _, _) = r - -makeNode :: OccEnv -> ImpRuleEdges -> VarSet - -> (Var, CoreExpr) -> LetrecNode --- See Note [Recursive bindings: the grand plan] -makeNode env imp_rule_edges bndr_set (bndr, rhs) - = (details, varUnique bndr, nonDetKeysUniqSet node_fvs) - -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR - -- is still deterministic with edges in nondeterministic order as - -- explained in Note [Deterministic SCC] in Digraph. - where - details = ND { nd_bndr = bndr - , nd_rhs = rhs' - , nd_rhs_bndrs = bndrs' - , nd_uds = rhs_usage3 - , nd_inl = inl_fvs - , nd_weak = node_fvs `minusVarSet` inl_fvs - , nd_active_rule_fvs = active_rule_fvs - , nd_score = pprPanic "makeNodeDetails" (ppr bndr) } - - -- Constructing the edges for the main Rec computation - -- See Note [Forming Rec groups] - (bndrs, body) = collectBinders rhs - (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body - rhs' = mkLams bndrs' body' - rhs_usage2 = rhs_usage1 +++ all_rule_uds - -- Note [Rules are extra RHSs] - -- Note [Rule dependency info] - rhs_usage3 = case mb_unf_uds of - Just unf_uds -> rhs_usage2 +++ unf_uds - Nothing -> rhs_usage2 - node_fvs = udFreeVars bndr_set rhs_usage3 - - -- Finding the free variables of the rules - is_active = occ_rule_act env :: Activation -> Bool - - rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] - rules_w_uds = occAnalRules env (Just (length bndrs)) Recursive bndr - - rules_w_rhs_fvs :: [(Activation, VarSet)] -- Find the RHS fvs - rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) - (lookupVarEnv imp_rule_edges bndr) - -- See Note [Preventing loops due to imported functions rules] - [ (ru_act rule, udFreeVars bndr_set rhs_uds) - | (rule, _, rhs_uds) <- rules_w_uds ] - all_rule_uds = combineUsageDetailsList $ - concatMap (\(_, l, r) -> [l, r]) rules_w_uds - active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs - , is_active a] - - -- Finding the usage details of the INLINE pragma (if any) - mb_unf_uds = occAnalUnfolding env Recursive bndr - - -- Find the "nd_inl" free vars; for the loop-breaker phase - inl_fvs = case mb_unf_uds of - Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS - Just unf_uds -> udFreeVars bndr_set unf_uds - -- We could check for an *active* INLINE (returning - -- emptyVarSet for an inactive one), but is_active - -- isn't the right thing (it tells about - -- RULE activation), so we'd need more plumbing - -mkLoopBreakerNodes :: TopLevelFlag - -> VarSet - -> UsageDetails -- for BODY of let - -> [Details] - -> (UsageDetails, -- adjusted - [LetrecNode]) --- Does four things --- a) tag each binder with its occurrence info --- b) add a NodeScore to each node --- c) make a Node with the right dependency edges for --- the loop-breaker SCC analysis --- d) adjust each RHS's usage details according to --- the binder's (new) shotness and join-point-hood -mkLoopBreakerNodes lvl bndr_set body_uds details_s - = (final_uds, zipWith mk_lb_node details_s bndrs') - where - (final_uds, bndrs') = tagRecBinders lvl body_uds - [ (nd_bndr nd, nd_uds nd, nd_rhs_bndrs nd) - | nd <- details_s ] - mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr' - = (nd', varUnique bndr, nonDetKeysUniqSet lb_deps) - -- It's OK to use nonDetKeysUniqSet here as - -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges - -- in nondeterministic order as explained in - -- Note [Deterministic SCC] in Digraph. - where - nd' = nd { nd_bndr = bndr', nd_score = score } - score = nodeScore bndr bndr' rhs lb_deps - lb_deps = extendFvs_ rule_fv_env inl_fvs - - rule_fv_env :: IdEnv IdSet - -- Maps a variable f to the variables from this group - -- mentioned in RHS of active rules for f - -- Domain is *subset* of bound vars (others have no rule fvs) - rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs) - init_rule_fvs -- See Note [Finding rule RHS free vars] - = [ (b, trimmed_rule_fvs) - | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s - , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set - , not (isEmptyVarSet trimmed_rule_fvs) ] - - ------------------------------------------- -nodeScore :: Id -- Binder has old occ-info (just for loop-breaker-ness) - -> Id -- Binder with new occ-info - -> CoreExpr -- RHS - -> VarSet -- Loop-breaker dependencies - -> NodeScore -nodeScore old_bndr new_bndr bind_rhs lb_deps - | not (isId old_bndr) -- A type or cercion variable is never a loop breaker - = (100, 0, False) - - | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers - = (0, 0, True) -- See Note [Self-recursion and loop breakers] - - | exprIsTrivial rhs - = mk_score 10 -- Practically certain to be inlined - -- Used to have also: && not (isExportedId bndr) - -- But I found this sometimes cost an extra iteration when we have - -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } - -- where df is the exported dictionary. Then df makes a really - -- bad choice for loop breaker - - | DFunUnfolding { df_args = args } <- id_unfolding - -- Never choose a DFun as a loop breaker - -- Note [DFuns should not be loop breakers] - = (9, length args, is_lb) - - -- Data structures are more important than INLINE pragmas - -- so that dictionary/method recursion unravels - - | CoreUnfolding { uf_guidance = UnfWhen {} } <- id_unfolding - = mk_score 6 - - | is_con_app rhs -- Data types help with cases: - = mk_score 5 -- Note [Constructor applications] - - | isStableUnfolding id_unfolding - , can_unfold - = mk_score 3 - - | isOneOcc (idOccInfo new_bndr) - = mk_score 2 -- Likely to be inlined - - | can_unfold -- The Id has some kind of unfolding - = mk_score 1 - - | otherwise - = (0, 0, is_lb) - - where - mk_score :: Int -> NodeScore - mk_score rank = (rank, rhs_size, is_lb) - - is_lb = isStrongLoopBreaker (idOccInfo old_bndr) - rhs = case id_unfolding of - CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } - | isStableSource src - -> unf_rhs - _ -> bind_rhs - -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding - rhs_size = case id_unfolding of - CoreUnfolding { uf_guidance = guidance } - | UnfIfGoodArgs { ug_size = size } <- guidance - -> size - _ -> cheapExprSize rhs - - can_unfold = canUnfold id_unfolding - id_unfolding = realIdUnfolding old_bndr - -- realIdUnfolding: Ignore loop-breaker-ness here because - -- that is what we are setting! - - -- Checking for a constructor application - -- Cheap and cheerful; the simplifier moves casts out of the way - -- The lambda case is important to spot x = /\a. C (f a) - -- which comes up when C is a dictionary constructor and - -- f is a default method. - -- Example: the instance for Show (ST s a) in GHC.ST - -- - -- However we *also* treat (\x. C p q) as a con-app-like thing, - -- Note [Closure conversion] - is_con_app (Var v) = isConLikeId v - is_con_app (App f _) = is_con_app f - is_con_app (Lam _ e) = is_con_app e - is_con_app (Tick _ e) = is_con_app e - is_con_app _ = False - -maxExprSize :: Int -maxExprSize = 20 -- Rather arbitrary - -cheapExprSize :: CoreExpr -> Int --- Maxes out at maxExprSize -cheapExprSize e - = go 0 e - where - go n e | n >= maxExprSize = n - | otherwise = go1 n e - - go1 n (Var {}) = n+1 - go1 n (Lit {}) = n+1 - go1 n (Type {}) = n - go1 n (Coercion {}) = n - go1 n (Tick _ e) = go1 n e - go1 n (Cast e _) = go1 n e - go1 n (App f a) = go (go1 n f) a - go1 n (Lam b e) - | isTyVar b = go1 n e - | otherwise = go (n+1) e - go1 n (Let b e) = gos (go1 n e) (rhssOfBind b) - go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as) - - gos n [] = n - gos n (e:es) | n >= maxExprSize = n - | otherwise = gos (go1 n e) es - -betterLB :: NodeScore -> NodeScore -> Bool --- If n1 `betterLB` n2 then choose n1 as the loop breaker -betterLB (rank1, size1, lb1) (rank2, size2, _) - | rank1 < rank2 = True - | rank1 > rank2 = False - | size1 < size2 = False -- Make the bigger n2 into the loop breaker - | size1 > size2 = True - | lb1 = True -- Tie-break: if n1 was a loop breaker before, choose it - | otherwise = False -- See Note [Loop breakers, node scoring, and stability] - -{- Note [Self-recursion and loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - rec { f = ...f...g... - ; g = .....f... } -then 'f' has to be a loop breaker anyway, so we may as well choose it -right away, so that g can inline freely. - -This is really just a cheap hack. Consider - rec { f = ...g... - ; g = ..f..h... - ; h = ...f....} -Here f or g are better loop breakers than h; but we might accidentally -choose h. Finding the minimal set of loop breakers is hard. - -Note [Loop breakers, node scoring, and stability] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To choose a loop breaker, we give a NodeScore to each node in the SCC, -and pick the one with the best score (according to 'betterLB'). - -We need to be jolly careful (Trac #12425, #12234) about the stability -of this choice. Suppose we have - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...f.. - False -> ..f... - -In each iteration of the simplifier the occurrence analyser OccAnal -chooses a loop breaker. Suppose in iteration 1 it choose g as the loop -breaker. That means it is free to inline f. - -Suppose that GHC decides to inline f in the branches of the case, but -(for some reason; eg it is not saturated) in the rhs of g. So we get - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...g...g..... - False -> ..g..g.... - -Now suppose that, for some reason, in the next iteration the occurrence -analyser chooses f as the loop breaker, so it can freely inline g. And -again for some reason the simplifier inlines g at its calls in the case -branches, but not in the RHS of f. Then we get - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...(...f...f...)...(...f..f..)..... - False -> ..(...f...f...)...(..f..f...).... - -You can see where this is going! Each iteration of the simplifier -doubles the number of calls to f or g. No wonder GHC is slow! - -(In the particular example in comment:3 of #12425, f and g are the two -mutually recursive fmap instances for CondT and Result. They are both -marked INLINE which, oddly, is why they don't inline in each other's -RHS, because the call there is not saturated.) - -The root cause is that we flip-flop on our choice of loop breaker. I -always thought it didn't matter, and indeed for any single iteration -to terminate, it doesn't matter. But when we iterate, it matters a -lot!! - -So The Plan is this: - If there is a tie, choose the node that - was a loop breaker last time round - -Hence the is_lb field of NodeScore - -************************************************************************ -* * - Right hand sides -* * -************************************************************************ --} - -occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalRhs env Recursive _ bndrs body - = occAnalRecRhs env bndrs body -occAnalRhs env NonRecursive id bndrs body - = occAnalNonRecRhs env id bndrs body - -occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr -- Rhs lambdas, body - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalRecRhs env bndrs body = occAnalLamOrRhs (rhsCtxt env) bndrs body - -occAnalNonRecRhs :: OccEnv - -> Id -> [CoreBndr] -> CoreExpr -- Binder; rhs lams, body - -- Binder is already tagged with occurrence info - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalNonRecRhs env bndr bndrs body - = occAnalLamOrRhs rhs_env bndrs body - where - -- See Note [Cascading inlines] - env1 | certainly_inline = env - | otherwise = rhsCtxt env - - -- See Note [Sources of one-shot information] - rhs_env = env1 { occ_one_shots = argOneShots dmd } - - certainly_inline -- See Note [Cascading inlines] - = case idOccInfo bndr of - OneOcc { occ_in_lam = in_lam, occ_one_br = one_br } - -> not in_lam && one_br && active && not_stable - _ -> False - - dmd = idDemandInfo bndr - active = isAlwaysActive (idInlineActivation bndr) - not_stable = not (isStableUnfolding (idUnfolding bndr)) - -occAnalUnfolding :: OccEnv - -> RecFlag - -> Id - -> Maybe UsageDetails - -- Just the analysis, not a new unfolding. The unfolding - -- got analysed when it was created and we don't need to - -- update it. -occAnalUnfolding env rec_flag id - = case realIdUnfolding id of -- ignore previous loop-breaker flag - CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | not (isStableSource src) - -> Nothing - | otherwise - -> Just $ markAllMany usage - where - (bndrs, body) = collectBinders rhs - (usage, _, _) = occAnalRhs env rec_flag id bndrs body - - DFunUnfolding { df_bndrs = bndrs, df_args = args } - -> Just $ zapDetails (delDetailsList usage bndrs) - where - usage = foldr (+++) emptyDetails (map (fst . occAnal env) args) - - _ -> Nothing - -occAnalRules :: OccEnv - -> Maybe JoinArity -- If the binder is (or MAY become) a join - -- point, what its join arity is (or WOULD - -- become). See Note [Rules and join points]. - -> RecFlag - -> Id - -> [(CoreRule, -- Each (non-built-in) rule - UsageDetails, -- Usage details for LHS - UsageDetails)] -- Usage details for RHS -occAnalRules env mb_expected_join_arity rec_flag id - = [ (rule, lhs_uds, rhs_uds) | rule@Rule {} <- idCoreRules id - , let (lhs_uds, rhs_uds) = occ_anal_rule rule ] - where - occ_anal_rule (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) - = (lhs_uds, final_rhs_uds) - where - lhs_uds = addManyOccsSet emptyDetails $ - (exprsFreeVars args `delVarSetList` bndrs) - (rhs_bndrs, rhs_body) = collectBinders rhs - (rhs_uds, _, _) = occAnalRhs env rec_flag id rhs_bndrs rhs_body - -- Note [Rules are extra RHSs] - -- Note [Rule dependency info] - final_rhs_uds = adjust_tail_info args $ markAllMany $ - (rhs_uds `delDetailsList` bndrs) - occ_anal_rule _ - = (emptyDetails, emptyDetails) - - adjust_tail_info args uds -- see Note [Rules and join points] - = case mb_expected_join_arity of - Just ar | args `lengthIs` ar -> uds - _ -> markAllNonTailCalled uds -{- -Note [Cascading inlines] -~~~~~~~~~~~~~~~~~~~~~~~~ -By default we use an rhsCtxt for the RHS of a binding. This tells the -occ anal n that it's looking at an RHS, which has an effect in -occAnalApp. In particular, for constructor applications, it makes -the arguments appear to have NoOccInfo, so that we don't inline into -them. Thus x = f y - k = Just x -we do not want to inline x. - -But there's a problem. Consider - x1 = a0 : [] - x2 = a1 : x1 - x3 = a2 : x2 - g = f x3 -First time round, it looks as if x1 and x2 occur as an arg of a -let-bound constructor ==> give them a many-occurrence. -But then x3 is inlined (unconditionally as it happens) and -next time round, x2 will be, and the next time round x1 will be -Result: multiple simplifier iterations. Sigh. - -So, when analysing the RHS of x3 we notice that x3 will itself -definitely inline the next time round, and so we analyse x3's rhs in -an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff. - -Annoyingly, we have to approximate SimplUtils.preInlineUnconditionally. -If we say "yes" when preInlineUnconditionally says "no" the simplifier iterates -indefinitely: - x = f y - k = Just x -inline ==> - k = Just (f y) -float ==> - x1 = f y - k = Just x1 - -This is worse than the slow cascade, so we only want to say "certainly_inline" -if it really is certain. Look at the note with preInlineUnconditionally -for the various clauses. - - -************************************************************************ -* * - Expressions -* * -************************************************************************ --} - -occAnal :: OccEnv - -> CoreExpr - -> (UsageDetails, -- Gives info only about the "interesting" Ids - CoreExpr) - -occAnal _ expr@(Type _) = (emptyDetails, expr) -occAnal _ expr@(Lit _) = (emptyDetails, expr) -occAnal env expr@(Var _) = occAnalApp env (expr, [], []) - -- At one stage, I gathered the idRuleVars for the variable here too, - -- which in a way is the right thing to do. - -- But that went wrong right after specialisation, when - -- the *occurrences* of the overloaded function didn't have any - -- rules in them, so the *specialised* versions looked as if they - -- weren't used at all. - -occAnal _ (Coercion co) - = (addManyOccsSet emptyDetails (coVarsOfCo co), Coercion co) - -- See Note [Gather occurrences of coercion variables] - -{- -Note [Gather occurrences of coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to gather info about what coercion variables appear, so that -we can sort them into the right place when doing dependency analysis. --} - -occAnal env (Tick tickish body) - | tickish `tickishScopesLike` SoftScope - = (markAllNonTailCalled usage, Tick tickish body') - - | Breakpoint _ ids <- tickish - = (usage_lam +++ foldr addManyOccs emptyDetails ids, Tick tickish body') - -- never substitute for any of the Ids in a Breakpoint - - | otherwise - = (usage_lam, Tick tickish body') - where - !(usage,body') = occAnal env body - -- for a non-soft tick scope, we can inline lambdas only - usage_lam = markAllNonTailCalled (markAllInsideLam usage) - -- TODO There may be ways to make ticks and join points play - -- nicer together, but right now there are problems: - -- let j x = ... in tick (j 1) - -- Making j a join point may cause the simplifier to drop t - -- (if the tick is put into the continuation). So we don't - -- count j 1 as a tail call. - -occAnal env (Cast expr co) - = case occAnal env expr of { (usage, expr') -> - let usage1 = zapDetailsIf (isRhsEnv env) usage - usage2 = addManyOccsSet usage1 (coVarsOfCo co) - -- See Note [Gather occurrences of coercion variables] - in (markAllNonTailCalled usage2, Cast expr' co) - -- If we see let x = y `cast` co - -- then mark y as 'Many' so that we don't - -- immediately inline y again. - } - -occAnal env app@(App _ _) - = occAnalApp env (collectArgsTicks tickishFloatable app) - --- Ignore type variables altogether --- (a) occurrences inside type lambdas only not marked as InsideLam --- (b) type variables not in environment - -occAnal env (Lam x body) - | isTyVar x - = case occAnal env body of { (body_usage, body') -> - (markAllNonTailCalled body_usage, Lam x body') - } - --- For value lambdas we do a special hack. Consider --- (\x. \y. ...x...) --- If we did nothing, x is used inside the \y, so would be marked --- as dangerous to dup. But in the common case where the abstraction --- is applied to two arguments this is over-pessimistic. --- So instead, we just mark each binder with its occurrence --- info in the *body* of the multiple lambda. --- Then, the simplifier is careful when partially applying lambdas. - -occAnal env expr@(Lam _ _) - = case occAnalLamOrRhs env binders body of { (usage, tagged_binders, body') -> - let - expr' = mkLams tagged_binders body' - usage1 = markAllNonTailCalled usage - one_shot_gp = all isOneShotBndr tagged_binders - final_usage | one_shot_gp = usage1 - | otherwise = markAllInsideLam usage1 - in - (final_usage, expr') } - where - (binders, body) = collectBinders expr - -occAnal env (Case scrut bndr ty alts) - = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> - case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> - let - alts_usage = foldr combineAltsUsageDetails emptyDetails alts_usage_s - (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr - total_usage = markAllNonTailCalled scrut_usage +++ alts_usage1 - -- Alts can have tail calls, but the scrutinee can't - in - total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} - where - -- Note [Case binder usage] - -- ~~~~~~~~~~~~~~~~~~~~~~~~ - -- The case binder gets a usage of either "many" or "dead", never "one". - -- Reason: we like to inline single occurrences, to eliminate a binding, - -- but inlining a case binder *doesn't* eliminate a binding. - -- We *don't* want to transform - -- case x of w { (p,q) -> f w } - -- into - -- case x of w { (p,q) -> f (p,q) } - tag_case_bndr usage bndr - = (usage', setIdOccInfo bndr final_occ_info) - where - occ_info = lookupDetails usage bndr - usage' = usage `delDetails` bndr - final_occ_info = case occ_info of IAmDead -> IAmDead - _ -> noOccInfo - - alt_env = mkAltEnv env scrut bndr - occ_anal_alt = occAnalAlt alt_env - - occ_anal_scrut (Var v) (alt1 : other_alts) - | not (null other_alts) || not (isDefaultAlt alt1) - = (mkOneOcc env v True 0, Var v) - -- The 'True' says that the variable occurs in an interesting - -- context; the case has at least one non-default alternative - occ_anal_scrut (Tick t e) alts - | t `tickishScopesLike` SoftScope - -- No reason to not look through all ticks here, but only - -- for soft-scoped ticks we can do so without having to - -- update returned occurance info (see occAnal) - = second (Tick t) $ occ_anal_scrut e alts - - occ_anal_scrut scrut _alts - = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt - -occAnal env (Let bind body) - = case occAnal env body of { (body_usage, body') -> - case occAnalBind env NotTopLevel - noImpRuleEdges bind - body_usage of { (final_usage, new_binds) -> - (final_usage, mkLets new_binds body') }} - -occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr]) -occAnalArgs _ [] _ - = (emptyDetails, []) - -occAnalArgs env (arg:args) one_shots - | isTypeArg arg - = case occAnalArgs env args one_shots of { (uds, args') -> - (uds, arg:args') } - - | otherwise - = case argCtxt env one_shots of { (arg_env, one_shots') -> - case occAnal arg_env arg of { (uds1, arg') -> - case occAnalArgs env args one_shots' of { (uds2, args') -> - (uds1 +++ uds2, arg':args') }}} - -{- -Applications are dealt with specially because we want -the "build hack" to work. - -Note [Arguments of let-bound constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = let y = expensive x in - let z = (True,y) in - (case z of {(p,q)->q}, case z of {(p,q)->q}) -We feel free to duplicate the WHNF (True,y), but that means -that y may be duplicated thereby. - -If we aren't careful we duplicate the (expensive x) call! -Constructors are rather like lambdas in this way. --} - -occAnalApp :: OccEnv - -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id]) - -> (UsageDetails, Expr CoreBndr) -occAnalApp env (Var fun, args, ticks) - | null ticks = (uds, mkApps (Var fun) args') - | otherwise = (uds, mkTicks ticks $ mkApps (Var fun) args') - where - uds = fun_uds +++ final_args_uds - - !(args_uds, args') = occAnalArgs env args one_shots - !final_args_uds - | isRhsEnv env && is_exp = markAllNonTailCalled $ - markAllInsideLam args_uds - | otherwise = markAllNonTailCalled args_uds - -- We mark the free vars of the argument of a constructor or PAP - -- as "inside-lambda", if it is the RHS of a let(rec). - -- This means that nothing gets inlined into a constructor or PAP - -- argument position, which is what we want. Typically those - -- constructor arguments are just variables, or trivial expressions. - -- We use inside-lam because it's like eta-expanding the PAP. - -- - -- This is the *whole point* of the isRhsEnv predicate - -- See Note [Arguments of let-bound constructors] - - n_val_args = valArgCount args - n_args = length args - fun_uds = mkOneOcc env fun (n_val_args > 0) n_args - is_exp = isExpandableApp fun n_val_args - -- See Note [CONLIKE pragma] in BasicTypes - -- The definition of is_exp should match that in Simplify.prepareRhs - - one_shots = argsOneShots (idStrictness fun) guaranteed_val_args - guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo - (occ_one_shots env)) - -- See Note [Sources of one-shot information], bullet point A'] - -occAnalApp env (fun, args, ticks) - = (markAllNonTailCalled (fun_uds +++ args_uds), - mkTicks ticks $ mkApps fun' args') - where - !(fun_uds, fun') = occAnal (addAppCtxt env args) fun - -- The addAppCtxt is a bit cunning. One iteration of the simplifier - -- often leaves behind beta redexs like - -- (\x y -> e) a1 a2 - -- Here we would like to mark x,y as one-shot, and treat the whole - -- thing much like a let. We do this by pushing some True items - -- onto the context stack. - !(args_uds, args') = occAnalArgs env args [] - -zapDetailsIf :: Bool -- If this is true - -> UsageDetails -- Then do zapDetails on this - -> UsageDetails -zapDetailsIf True uds = zapDetails uds -zapDetailsIf False uds = uds - -{- -Note [Sources of one-shot information] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The occurrence analyser obtains one-shot-lambda information from two sources: - -A: Saturated applications: eg f e1 .. en - - In general, given a call (f e1 .. en) we can propagate one-shot info from - f's strictness signature into e1 .. en, but /only/ if n is enough to - saturate the strictness signature. A strictness signature like - - f :: C1(C1(L))LS - - means that *if f is applied to three arguments* then it will guarantee to - call its first argument at most once, and to call the result of that at - most once. But if f has fewer than three arguments, all bets are off; e.g. - - map (f (\x y. expensive) e2) xs - - Here the \x y abstraction may be called many times (once for each element of - xs) so we should not mark x and y as one-shot. But if it was - - map (f (\x y. expensive) 3 2) xs - - then the first argument of f will be called at most once. - - The one-shot info, derived from f's strictness signature, is - computed by 'argsOneShots', called in occAnalApp. - -A': Non-obviously saturated applications: eg build (f (\x y -> expensive)) - where f is as above. - - In this case, f is only manifestly applied to one argument, so it does not - look saturated. So by the previous point, we should not use its strictness - signature to learn about the one-shotness of \x y. But in this case we can: - build is fully applied, so we may use its strictness signature; and from - that we learn that build calls its argument with two arguments *at most once*. - - So there is really only one call to f, and it will have three arguments. In - that sense, f is saturated, and we may proceed as described above. - - Hence the computation of 'guaranteed_val_args' in occAnalApp, using - '(occ_one_shots env)'. See also Trac #13227, comment:9 - -B: Let-bindings: eg let f = \c. let ... in \n -> blah - in (build f, build f) - - Propagate one-shot info from the demanand-info on 'f' to the - lambdas in its RHS (which may not be syntactically at the top) - - This information must have come from a previous run of the demanand - analyser. - -Previously, the demand analyser would *also* set the one-shot information, but -that code was buggy (see #11770), so doing it only in on place, namely here, is -saner. - -Note [OneShots] -~~~~~~~~~~~~~~~ -When analysing an expression, the occ_one_shots argument contains information -about how the function is being used. The length of the list indicates -how many arguments will eventually be passed to the analysed expression, -and the OneShotInfo indicates whether this application is once or multiple times. - -Example: - - Context of f occ_one_shots when analysing f - - f 1 2 [OneShot, OneShot] - map (f 1) [OneShot, NoOneShotInfo] - build f [OneShot, OneShot] - f 1 2 `seq` f 2 1 [NoOneShotInfo, OneShot] - -Note [Binders in case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - case x of y { (a,b) -> f y } -We treat 'a', 'b' as dead, because they don't physically occur in the -case alternative. (Indeed, a variable is dead iff it doesn't occur in -its scope in the output of OccAnal.) It really helps to know when -binders are unused. See esp the call to isDeadBinder in -Simplify.mkDupableAlt - -In this example, though, the Simplifier will bring 'a' and 'b' back to -life, beause it binds 'y' to (a,b) (imagine got inlined and -scrutinised y). --} - -occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr - -> (UsageDetails, [CoreBndr], CoreExpr) -occAnalLamOrRhs env [] body - = case occAnal env body of (body_usage, body') -> (body_usage, [], body') - -- RHS of thunk or nullary join point -occAnalLamOrRhs env (bndr:bndrs) body - | isTyVar bndr - = -- Important: Keep the environment so that we don't inline into an RHS like - -- \(@ x) -> C @x (f @x) - -- (see the beginning of Note [Cascading inlines]). - case occAnalLamOrRhs env bndrs body of - (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body') -occAnalLamOrRhs env binders body - = case occAnal env_body body of { (body_usage, body') -> - let - (final_usage, tagged_binders) = tagLamBinders body_usage binders' - -- Use binders' to put one-shot info on the lambdas - in - (final_usage, tagged_binders, body') } - where - (env_body, binders') = oneShotGroup env binders - -occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr)) - -> CoreAlt - -> (UsageDetails, Alt IdWithOccInfo) -occAnalAlt (env, scrut_bind) (con, bndrs, rhs) - = case occAnal env rhs of { (rhs_usage1, rhs1) -> - let - (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs - -- See Note [Binders in case alternatives] - (alt_usg', rhs2) = - wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1 - in - (alt_usg', (con, tagged_bndrs, rhs2)) } - -wrapAltRHS :: OccEnv - -> Maybe (Id, CoreExpr) -- proxy mapping generated by mkAltEnv - -> UsageDetails -- usage for entire alt (p -> rhs) - -> [Var] -- alt binders - -> CoreExpr -- alt RHS - -> (UsageDetails, CoreExpr) -wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs - | occ_binder_swap env - , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this - -- handles condition (a) in Note [Binder swap] - , not captured -- See condition (b) in Note [Binder swap] - = ( alt_usg' +++ let_rhs_usg - , Let (NonRec tagged_scrut_var let_rhs') alt_rhs ) - where - captured = any (`usedIn` let_rhs_usg) bndrs - -- The rhs of the let may include coercion variables - -- if the scrutinee was a cast, so we must gather their - -- usage. See Note [Gather occurrences of coercion variables] - (let_rhs_usg, let_rhs') = occAnal env let_rhs - (alt_usg', [tagged_scrut_var]) = tagLamBinders alt_usg [scrut_var] - -wrapAltRHS _ _ alt_usg _ alt_rhs - = (alt_usg, alt_rhs) - -{- -************************************************************************ -* * - OccEnv -* * -************************************************************************ --} - -data OccEnv - = OccEnv { occ_encl :: !OccEncl -- Enclosing context information - , occ_one_shots :: !OneShots -- See Note [OneShots] - , occ_gbl_scrut :: GlobalScruts - , occ_rule_act :: Activation -> Bool -- Which rules are active - -- See Note [Finding rule RHS free vars] - , occ_binder_swap :: !Bool -- enable the binder_swap - -- See CorePrep Note [Dead code in CorePrep] - } - -type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees] - ------------------------------ --- OccEncl is used to control whether to inline into constructor arguments --- For example: --- x = (p,q) -- Don't inline p or q --- y = /\a -> (p a, q a) -- Still don't inline p or q --- z = f (p,q) -- Do inline p,q; it may make a rule fire --- So OccEncl tells enought about the context to know what to do when --- we encounter a constructor application or PAP. - -data OccEncl - = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda - -- Don't inline into constructor args here - | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. - -- Do inline into constructor args here - -instance Outputable OccEncl where - ppr OccRhs = text "occRhs" - ppr OccVanilla = text "occVanilla" - --- See note [OneShots] -type OneShots = [OneShotInfo] - -initOccEnv :: (Activation -> Bool) -> OccEnv -initOccEnv active_rule - = OccEnv { occ_encl = OccVanilla - , occ_one_shots = [] - , occ_gbl_scrut = emptyVarSet - , occ_rule_act = active_rule - , occ_binder_swap = True } - -vanillaCtxt :: OccEnv -> OccEnv -vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] } - -rhsCtxt :: OccEnv -> OccEnv -rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] } - -argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots]) -argCtxt env [] - = (env { occ_encl = OccVanilla, occ_one_shots = [] }, []) -argCtxt env (one_shots:one_shots_s) - = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s) - -isRhsEnv :: OccEnv -> Bool -isRhsEnv (OccEnv { occ_encl = OccRhs }) = True -isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False - -oneShotGroup :: OccEnv -> [CoreBndr] - -> ( OccEnv - , [CoreBndr] ) - -- The result binders have one-shot-ness set that they might not have had originally. - -- This happens in (build (\c n -> e)). Here the occurrence analyser - -- linearity context knows that c,n are one-shot, and it records that fact in - -- the binder. This is useful to guide subsequent float-in/float-out tranformations - -oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs - = go ctxt bndrs [] - where - go ctxt [] rev_bndrs - = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla } - , reverse rev_bndrs ) - - go [] bndrs rev_bndrs - = ( env { occ_one_shots = [], occ_encl = OccVanilla } - , reverse rev_bndrs ++ bndrs ) - - go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs - | isId bndr = go ctxt' bndrs (bndr': rev_bndrs) - | otherwise = go ctxt bndrs (bndr : rev_bndrs) - where - bndr' = updOneShotInfo bndr one_shot - -- Use updOneShotInfo, not setOneShotInfo, as pre-existing - -- one-shot info might be better than what we can infer, e.g. - -- due to explicit use of the magic 'oneShot' function. - -- See Note [The oneShot function] - - -markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var] --- Mark the lambdas of a non-recursive join point as one-shot. --- This is good to prevent gratuitous float-out etc -markJoinOneShots mb_join_arity bndrs - = case mb_join_arity of - Nothing -> bndrs - Just n -> go n bndrs - where - go 0 bndrs = bndrs - go _ [] = WARN( True, ppr mb_join_arity <+> ppr bndrs ) [] - go n (b:bs) = b' : go (n-1) bs - where - b' | isId b = setOneShotLambda b - | otherwise = b - -addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv -addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args - = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt } - -transClosureFV :: UniqFM VarSet -> UniqFM VarSet --- If (f,g), (g,h) are in the input, then (f,h) is in the output --- as well as (f,g), (g,h) -transClosureFV env - | no_change = env - | otherwise = transClosureFV (listToUFM new_fv_list) - where - (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env) - -- It's OK to use nonDetUFMToList here because we'll forget the - -- ordering by creating a new set with listToUFM - bump no_change (b,fvs) - | no_change_here = (no_change, (b,fvs)) - | otherwise = (False, (b,new_fvs)) - where - (new_fvs, no_change_here) = extendFvs env fvs - -------------- -extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet -extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag - -extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool) --- (extendFVs env s) returns --- (s `union` env(s), env(s) `subset` s) -extendFvs env s - | isNullUFM env - = (s, True) - | otherwise - = (s `unionVarSet` extras, extras `subVarSet` s) - where - extras :: VarSet -- env(s) - extras = nonDetFoldUFM unionVarSet emptyVarSet $ - -- It's OK to use nonDetFoldUFM here because unionVarSet commutes - intersectUFM_C (\x _ -> x) env (getUniqSet s) - -{- -************************************************************************ -* * - Binder swap -* * -************************************************************************ - -Note [Binder swap] -~~~~~~~~~~~~~~~~~~ -We do these two transformations right here: - - (1) case x of b { pi -> ri } - ==> - case x of b { pi -> let x=b in ri } - - (2) case (x |> co) of b { pi -> ri } - ==> - case (x |> co) of b { pi -> let x = b |> sym co in ri } - - Why (2)? See Note [Case of cast] - -In both cases, in a particular alternative (pi -> ri), we only -add the binding if - (a) x occurs free in (pi -> ri) - (ie it occurs in ri, but is not bound in pi) - (b) the pi does not bind b (or the free vars of co) -We need (a) and (b) for the inserted binding to be correct. - -For the alternatives where we inject the binding, we can transfer -all x's OccInfo to b. And that is the point. - -Notice that - * The deliberate shadowing of 'x'. - * That (a) rapidly becomes false, so no bindings are injected. - -The reason for doing these transformations here is because it allows -us to adjust the OccInfo for 'x' and 'b' as we go. - - * Suppose the only occurrences of 'x' are the scrutinee and in the - ri; then this transformation makes it occur just once, and hence - get inlined right away. - - * If we do this in the Simplifier, we don't know whether 'x' is used - in ri, so we are forced to pessimistically zap b's OccInfo even - though it is typically dead (ie neither it nor x appear in the - ri). There's nothing actually wrong with zapping it, except that - it's kind of nice to know which variables are dead. My nose - tells me to keep this information as robustly as possible. - -The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding -{x=b}; it's Nothing if the binder-swap doesn't happen. - -There is a danger though. Consider - let v = x +# y - in case (f v) of w -> ...v...v... -And suppose that (f v) expands to just v. Then we'd like to -use 'w' instead of 'v' in the alternative. But it may be too -late; we may have substituted the (cheap) x+#y for v in the -same simplifier pass that reduced (f v) to v. - -I think this is just too bad. CSE will recover some of it. - -Note [Case of cast] -~~~~~~~~~~~~~~~~~~~ -Consider case (x `cast` co) of b { I# -> - ... (case (x `cast` co) of {...}) ... -We'd like to eliminate the inner case. That is the motivation for -equation (2) in Note [Binder swap]. When we get to the inner case, we -inline x, cancel the casts, and away we go. - -Note [Binder swap on GlobalId scrutinees] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the scrutinee is a GlobalId we must take care in two ways - - i) In order to *know* whether 'x' occurs free in the RHS, we need its - occurrence info. BUT, we don't gather occurrence info for - GlobalIds. That's the reason for the (small) occ_gbl_scrut env in - OccEnv is for: it says "gather occurrence info for these". - - ii) We must call localiseId on 'x' first, in case it's a GlobalId, or - has an External Name. See, for example, SimplEnv Note [Global Ids in - the substitution]. - -Note [Zap case binders in proxy bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -From the original - case x of cb(dead) { p -> ...x... } -we will get - case x of cb(live) { p -> let x = cb in ...x... } - -Core Lint never expects to find an *occurrence* of an Id marked -as Dead, so we must zap the OccInfo on cb before making the -binding x = cb. See Trac #5028. - -Historical note [no-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We *used* to suppress the binder-swap in case expressions when --fno-case-of-case is on. Old remarks: - "This happens in the first simplifier pass, - and enhances full laziness. Here's the bad case: - f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) - If we eliminate the inner case, we trap it inside the I# v -> arm, - which might prevent some full laziness happening. I've seen this - in action in spectral/cichelli/Prog.hs: - [(m,n) | m <- [1..max], n <- [1..max]] - Hence the check for NoCaseOfCase." -However, now the full-laziness pass itself reverses the binder-swap, so this -check is no longer necessary. - -Historical note [Suppressing the case binder-swap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This old note describes a problem that is also fixed by doing the -binder-swap in OccAnal: - - There is another situation when it might make sense to suppress the - case-expression binde-swap. If we have - - case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } - ...other cases .... } - - We'll perform the binder-swap for the outer case, giving - - case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } - ...other cases .... } - - But there is no point in doing it for the inner case, because w1 can't - be inlined anyway. Furthermore, doing the case-swapping involves - zapping w2's occurrence info (see paragraphs that follow), and that - forces us to bind w2 when doing case merging. So we get - - case x of w1 { A -> let w2 = w1 in e1 - B -> let w2 = w1 in e2 - ...other cases .... } - - This is plain silly in the common case where w2 is dead. - - Even so, I can't see a good way to implement this idea. I tried - not doing the binder-swap if the scrutinee was already evaluated - but that failed big-time: - - data T = MkT !Int - - case v of w { MkT x -> - case x of x1 { I# y1 -> - case x of x2 { I# y2 -> ... - - Notice that because MkT is strict, x is marked "evaluated". But to - eliminate the last case, we must either make sure that x (as well as - x1) has unfolding MkT y1. The straightforward thing to do is to do - the binder-swap. So this whole note is a no-op. - -It's fixed by doing the binder-swap in OccAnal because we can do the -binder-swap unconditionally and still get occurrence analysis -information right. --} - -mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr)) --- Does two things: a) makes the occ_one_shots = OccVanilla --- b) extends the GlobalScruts if possible --- c) returns a proxy mapping, binding the scrutinee --- to the case binder, if possible -mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr - = case stripTicksTopE (const True) scrut of - Var v -> add_scrut v case_bndr' - Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co)) - -- See Note [Case of cast] - _ -> (env { occ_encl = OccVanilla }, Nothing) - - where - add_scrut v rhs = ( env { occ_encl = OccVanilla, occ_gbl_scrut = pe `extendVarSet` v } - , Just (localise v, rhs) ) - - case_bndr' = Var (zapIdOccInfo case_bndr) -- See Note [Zap case binders in proxy bindings] - localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) (idType scrut_var) - -- Localise the scrut_var before shadowing it; we're making a - -- new binding for it, and it might have an External Name, or - -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] - -- Also we don't want any INLINE or NOINLINE pragmas! - -{- -************************************************************************ -* * -\subsection[OccurAnal-types]{OccEnv} -* * -************************************************************************ - -Note [UsageDetails and zapping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -On many occasions, we must modify all gathered occurrence data at once. For -instance, all occurrences underneath a (non-one-shot) lambda set the -'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but -that takes O(n) time and we will do this often---in particular, there are many -places where tail calls are not allowed, and each of these causes all variables -to get marked with 'NoTailCallInfo'. - -Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along -with the 'OccInfoEnv'. Each of these extra environments is a "zapped set" -recording which variables have been zapped in some way. Zapping all occurrence -info then simply means setting the corresponding zapped set to the whole -'OccInfoEnv', a fast O(1) operation. --} - -type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage - -- INVARIANT: never IAmDead - -- (Deadness is signalled by not being in the map at all) - -type ZappedSet = OccInfoEnv -- Values are ignored - -data UsageDetails - = UD { ud_env :: !OccInfoEnv - , ud_z_many :: ZappedSet -- apply 'markMany' to these - , ud_z_in_lam :: ZappedSet -- apply 'markInsideLam' to these - , ud_z_no_tail :: ZappedSet } -- apply 'markNonTailCalled' to these - -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv - -instance Outputable UsageDetails where - ppr ud = ppr (ud_env (flattenUsageDetails ud)) - -------------------- --- UsageDetails API - -(+++), combineAltsUsageDetails - :: UsageDetails -> UsageDetails -> UsageDetails -(+++) = combineUsageDetailsWith addOccInfo -combineAltsUsageDetails = combineUsageDetailsWith orOccInfo - -combineUsageDetailsList :: [UsageDetails] -> UsageDetails -combineUsageDetailsList = foldl (+++) emptyDetails - -mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails -mkOneOcc env id int_cxt arity - | isLocalId id - = singleton $ OneOcc { occ_in_lam = False - , occ_one_br = True - , occ_int_cxt = int_cxt - , occ_tail = AlwaysTailCalled arity } - | id `elemVarSet` occ_gbl_scrut env - = singleton noOccInfo - - | otherwise - = emptyDetails - where - singleton info = emptyDetails { ud_env = unitVarEnv id info } - -addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails -addOneOcc ud id info - = ud { ud_env = extendVarEnv_C plus_zapped (ud_env ud) id info } - `alterZappedSets` (`delVarEnv` id) - where - plus_zapped old new = doZapping ud id old `addOccInfo` new - -addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails -addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set - -- It's OK to use nonDetFoldUFM here because addManyOccs commutes - --- Add several occurrences, assumed not to be tail calls -addManyOccs :: Var -> UsageDetails -> UsageDetails -addManyOccs v u | isId v = addOneOcc u v noOccInfo - | otherwise = u - -- Give a non-committal binder info (i.e noOccInfo) because - -- a) Many copies of the specialised thing can appear - -- b) We don't want to substitute a BIG expression inside a RULE - -- even if that's the only occurrence of the thing - -- (Same goes for INLINE.) - -delDetails :: UsageDetails -> Id -> UsageDetails -delDetails ud bndr - = ud `alterUsageDetails` (`delVarEnv` bndr) - -delDetailsList :: UsageDetails -> [Id] -> UsageDetails -delDetailsList ud bndrs - = ud `alterUsageDetails` (`delVarEnvList` bndrs) - -emptyDetails :: UsageDetails -emptyDetails = UD { ud_env = emptyVarEnv - , ud_z_many = emptyVarEnv - , ud_z_in_lam = emptyVarEnv - , ud_z_no_tail = emptyVarEnv } - -isEmptyDetails :: UsageDetails -> Bool -isEmptyDetails = isEmptyVarEnv . ud_env - -markAllMany, markAllInsideLam, markAllNonTailCalled, zapDetails - :: UsageDetails -> UsageDetails -markAllMany ud = ud { ud_z_many = ud_env ud } -markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud } -markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud } - -zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo - -lookupDetails :: UsageDetails -> Id -> OccInfo -lookupDetails ud id - = case lookupVarEnv (ud_env ud) id of - Just occ -> doZapping ud id occ - Nothing -> IAmDead - -usedIn :: Id -> UsageDetails -> Bool -v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud - -udFreeVars :: VarSet -> UsageDetails -> VarSet --- Find the subset of bndrs that are mentioned in uds -udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud) - -------------------- --- Auxiliary functions for UsageDetails implementation - -combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo) - -> UsageDetails -> UsageDetails -> UsageDetails -combineUsageDetailsWith plus_occ_info ud1 ud2 - | isEmptyDetails ud1 = ud2 - | isEmptyDetails ud2 = ud1 - | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2) - , ud_z_many = plusVarEnv (ud_z_many ud1) (ud_z_many ud2) - , ud_z_in_lam = plusVarEnv (ud_z_in_lam ud1) (ud_z_in_lam ud2) - , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) } - -doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo -doZapping ud var occ - = doZappingByUnique ud (varUnique var) occ - -doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo -doZappingByUnique ud uniq - = (if | in_subset ud_z_many -> markMany - | in_subset ud_z_in_lam -> markInsideLam - | otherwise -> id) . - (if | in_subset ud_z_no_tail -> markNonTailCalled - | otherwise -> id) - where - in_subset field = uniq `elemVarEnvByKey` field ud - -alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails -alterZappedSets ud f - = ud { ud_z_many = f (ud_z_many ud) - , ud_z_in_lam = f (ud_z_in_lam ud) - , ud_z_no_tail = f (ud_z_no_tail ud) } - -alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails -alterUsageDetails ud f - = ud { ud_env = f (ud_env ud) } - `alterZappedSets` f - -flattenUsageDetails :: UsageDetails -> UsageDetails -flattenUsageDetails ud - = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) } - `alterZappedSets` const emptyVarEnv - -------------------- --- See Note [Adjusting right-hand sides] -adjustRhsUsage :: Maybe JoinArity -> RecFlag - -> [CoreBndr] -- Outer lambdas, AFTER occ anal - -> UsageDetails -> UsageDetails -adjustRhsUsage mb_join_arity rec_flag bndrs usage - = maybe_mark_lam (maybe_drop_tails usage) - where - maybe_mark_lam ud | one_shot = ud - | otherwise = markAllInsideLam ud - maybe_drop_tails ud | exact_join = ud - | otherwise = markAllNonTailCalled ud - - one_shot = case mb_join_arity of - Just join_arity - | isRec rec_flag -> False - | otherwise -> all isOneShotBndr (drop join_arity bndrs) - Nothing -> all isOneShotBndr bndrs - - exact_join = case mb_join_arity of - Just join_arity -> join_arity == length bndrs - _ -> False - -type IdWithOccInfo = Id - -tagLamBinders :: UsageDetails -- Of scope - -> [Id] -- Binders - -> (UsageDetails, -- Details with binders removed - [IdWithOccInfo]) -- Tagged binders --- Used for lambda and case binders --- It copes with the fact that lambda bindings can have a --- stable unfolding, used for join points -tagLamBinders usage binders = usage' `seq` (usage', bndrs') - where - (usage', bndrs') = mapAccumR tag_lam usage binders - tag_lam usage bndr = (usage2, bndr') - where - occ = lookupDetails usage bndr - bndr' = setBinderOcc (markNonTailCalled occ) bndr - -- Don't try to make an argument into a join point - usage1 = usage `delDetails` bndr - usage2 | isId bndr = addManyOccsSet usage1 (idUnfoldingVars bndr) - -- This is effectively the RHS of a - -- non-join-point binding, so it's okay to use - -- addManyOccsSet, which assumes no tail calls - | otherwise = usage1 - -tagNonRecBinder :: TopLevelFlag -- At top level? - -> UsageDetails -- Of scope - -> CoreBndr -- Binder - -> (UsageDetails, -- Details with binder removed - IdWithOccInfo) -- Tagged binder - -tagNonRecBinder lvl usage binder - = let - occ = lookupDetails usage binder - will_be_join = decideJoinPointHood lvl usage [binder] - occ' | will_be_join = occ -- must already be marked AlwaysTailCalled - | otherwise = markNonTailCalled occ - binder' = setBinderOcc occ' binder - usage' = usage `delDetails` binder - in - usage' `seq` (usage', binder') - -tagRecBinders :: TopLevelFlag -- At top level? - -> UsageDetails -- Of body of let ONLY - -> [(CoreBndr, -- Binder - UsageDetails, -- RHS usage details - [CoreBndr])] -- Lambdas in new RHS - -> (UsageDetails, -- Adjusted details for whole scope, - -- with binders removed - [IdWithOccInfo]) -- Tagged binders --- Substantially more complicated than non-recursive case. Need to adjust RHS --- details *before* tagging binders (because the tags depend on the RHSes). -tagRecBinders lvl body_uds triples - = let - (bndrs, rhs_udss, _) = unzip3 triples - - -- 1. Determine join-point-hood of whole group, as determined by - -- the *unadjusted* usage details - unadj_uds = body_uds +++ combineUsageDetailsList rhs_udss - will_be_joins = decideJoinPointHood lvl unadj_uds bndrs - - -- 2. Adjust usage details of each RHS, taking into account the - -- join-point-hood decision - rhs_udss' = map adjust triples - adjust (bndr, rhs_uds, rhs_bndrs) - = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds - where - -- Can't use willBeJoinId_maybe here because we haven't tagged the - -- binder yet (the tag depends on these adjustments!) - mb_join_arity - | will_be_joins - , let occ = lookupDetails unadj_uds bndr - , AlwaysTailCalled arity <- tailCallInfo occ - = Just arity - | otherwise - = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if we're - -- making join points! - Nothing - - -- 3. Compute final usage details from adjusted RHS details - adj_uds = body_uds +++ combineUsageDetailsList rhs_udss' - - -- 4. Tag each binder with its adjusted details modulo the - -- join-point-hood decision - occs = map (lookupDetails adj_uds) bndrs - occs' | will_be_joins = occs - | otherwise = map markNonTailCalled occs - bndrs' = zipWith setBinderOcc occs' bndrs - - -- 5. Drop the binders from the adjusted details and return - usage' = adj_uds `delDetailsList` bndrs - in - (usage', bndrs') - -setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr -setBinderOcc occ_info bndr - | isTyVar bndr = bndr - | isExportedId bndr = if isManyOccs (idOccInfo bndr) - then bndr - else setIdOccInfo bndr noOccInfo - -- Don't use local usage info for visible-elsewhere things - -- BUT *do* erase any IAmALoopBreaker annotation, because we're - -- about to re-generate it and it shouldn't be "sticky" - - | otherwise = setIdOccInfo bndr occ_info - --- | Decide whether some bindings should be made into join points or not. --- Returns `False` if they can't be join points. Note that it's an --- all-or-nothing decision, as if multiple binders are given, they're assumed to --- be mutually recursive. --- --- See Note [Invariants for join points] in CoreSyn. -decideJoinPointHood :: TopLevelFlag -> UsageDetails - -> [CoreBndr] - -> Bool -decideJoinPointHood TopLevel _ _ - = False -decideJoinPointHood NotTopLevel usage bndrs - | isJoinId (head bndrs) - = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+> - ppr bndrs) - all_ok - | otherwise - = all_ok - where - -- See Note [Invariants on join points]; invariants cited by number below. - -- Invariant 2 is always satisfiable by the simplifier by eta expansion. - all_ok = -- Invariant 3: Either all are join points or none are - all ok bndrs - - ok bndr - | -- Invariant 1: Only tail calls, all same join arity - AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr) - , -- Invariant 1 as applied to LHSes of rules - all (ok_rule arity) (idCoreRules bndr) - -- Invariant 4: Satisfies polymorphism rule - , isValidJoinPointType arity (idType bndr) - = True - | otherwise - = False - - ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans - ok_rule join_arity (Rule { ru_args = args }) - = length args == join_arity - -- Invariant 1 as applied to LHSes of rules - -willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity -willBeJoinId_maybe bndr - | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) - = Just arity - | otherwise - = isJoinId_maybe bndr - -{- -************************************************************************ -* * -\subsection{Operations over OccInfo} -* * -************************************************************************ --} - -markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo - -markMany IAmDead = IAmDead -markMany occ = ManyOccs { occ_tail = occ_tail occ } - -markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = True } -markInsideLam occ = occ - -markNonTailCalled IAmDead = IAmDead -markNonTailCalled occ = occ { occ_tail = NoTailCallInfo } - -addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo - -addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) - ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` - tailCallInfo a2 } - -- Both branches are at least One - -- (Argument is never IAmDead) - --- (orOccInfo orig new) is used --- when combining occurrence info from branches of a case - -orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1 - , occ_tail = tail1 }) - (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2 - , occ_tail = tail2 }) - = OneOcc { occ_in_lam = in_lam1 || in_lam2 - , occ_one_br = False -- False, because it occurs in both branches - , occ_int_cxt = int_cxt1 && int_cxt2 - , occ_tail = tail1 `andTailCallInfo` tail2 } -orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) - ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` - tailCallInfo a2 } - -andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo -andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2) - | arity1 == arity2 = info -andTailCallInfo _ _ = NoTailCallInfo diff --git a/simplCore/SAT.hs b/simplCore/SAT.hs deleted file mode 100644 --- a/simplCore/SAT.hs +++ /dev/null @@ -1,431 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -************************************************************************ - - Static Argument Transformation pass - -************************************************************************ - -May be seen as removing invariants from loops: -Arguments of recursive functions that do not change in recursive -calls are removed from the recursion, which is done locally -and only passes the arguments which effectively change. - -Example: -map = /\ ab -> \f -> \xs -> case xs of - [] -> [] - (a:b) -> f a : map f b - -as map is recursively called with the same argument f (unmodified) -we transform it to - -map = /\ ab -> \f -> \xs -> let map' ys = case ys of - [] -> [] - (a:b) -> f a : map' b - in map' xs - -Notice that for a compiler that uses lambda lifting this is -useless as map' will be transformed back to what map was. - -We could possibly do the same for big lambdas, but we don't as -they will eventually be removed in later stages of the compiler, -therefore there is no penalty in keeping them. - -We only apply the SAT when the number of static args is > 2. This -produces few bad cases. See - should_transform -in saTransform. - -Here are the headline nofib results: - Size Allocs Runtime -Min +0.0% -13.7% -21.4% -Max +0.1% +0.0% +5.4% -Geometric Mean +0.0% -0.2% -6.9% - -The previous patch, to fix polymorphic floatout demand signatures, is -essential to make this work well! --} - -{-# LANGUAGE CPP #-} -module SAT ( doStaticArgs ) where - -import Var -import CoreSyn -import CoreUtils -import Type -import Coercion -import Id -import Name -import VarEnv -import UniqSupply -import Util -import UniqFM -import VarSet -import Unique -import UniqSet -import Outputable - -import Data.List -import FastString - -#include "HsVersions.h" - -doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram -doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds - where - sat_bind_threaded_us us bind = - let (us1, us2) = splitUniqSupply us - in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet)) - --- We don't bother to SAT recursive groups since it can lead --- to massive code expansion: see Andre Santos' thesis for details. --- This means we only apply the actual SAT to Rec groups of one element, --- but we want to recurse into the others anyway to discover other binds -satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo) -satBind (NonRec binder expr) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (NonRec binder expr', finalizeApp expr_app sat_info_expr) -satBind (Rec [(binder, rhs)]) interesting_ids = do - let interesting_ids' = interesting_ids `addOneToUniqSet` binder - (rhs_binders, rhs_body) = collectBinders rhs - (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids' - let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders) - sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body - - shadowing = binder `elementOfUniqSet` interesting_ids - sat_info_rhs'' = if shadowing - then sat_info_rhs' `delFromUFM` binder -- For safety - else sat_info_rhs' - - bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder) - rhs_binders rhs_body' - return (bind', sat_info_rhs'') -satBind (Rec pairs) interesting_ids = do - let (binders, rhss) = unzip pairs - rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss - let (rhss', sat_info_rhss') = unzip rhss_SATed - return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss') - -data App = VarApp Id | TypeApp Type | CoApp Coercion -data Staticness a = Static a | NotStatic - -type IdAppInfo = (Id, SATInfo) - -type SATInfo = [Staticness App] -type IdSATInfo = IdEnv SATInfo -emptyIdSATInfo :: IdSATInfo -emptyIdSATInfo = emptyUFM - -{- -pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info)) - where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info) --} - -pprSATInfo :: SATInfo -> SDoc -pprSATInfo staticness = hcat $ map pprStaticness staticness - -pprStaticness :: Staticness App -> SDoc -pprStaticness (Static (VarApp _)) = text "SV" -pprStaticness (Static (TypeApp _)) = text "ST" -pprStaticness (Static (CoApp _)) = text "SC" -pprStaticness NotStatic = text "NS" - - -mergeSATInfo :: SATInfo -> SATInfo -> SATInfo -mergeSATInfo l r = zipWith mergeSA l r - where - mergeSA NotStatic _ = NotStatic - mergeSA _ NotStatic = NotStatic - mergeSA (Static (VarApp v)) (Static (VarApp v')) - | v == v' = Static (VarApp v) - | otherwise = NotStatic - mergeSA (Static (TypeApp t)) (Static (TypeApp t')) - | t `eqType` t' = Static (TypeApp t) - | otherwise = NotStatic - mergeSA (Static (CoApp c)) (Static (CoApp c')) - | c `eqCoercion` c' = Static (CoApp c) - | otherwise = NotStatic - mergeSA _ _ = pprPanic "mergeSATInfo" $ - text "Left:" - <> pprSATInfo l <> text ", " - <> text "Right:" - <> pprSATInfo r - -mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo -mergeIdSATInfo = plusUFM_C mergeSATInfo - -mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo -mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo - -bindersToSATInfo :: [Id] -> SATInfo -bindersToSATInfo vs = map (Static . binderToApp) vs - where binderToApp v | isId v = VarApp v - | isTyVar v = TypeApp $ mkTyVarTy v - | otherwise = CoApp $ mkCoVarCo v - -finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo -finalizeApp Nothing id_sat_info = id_sat_info -finalizeApp (Just (v, sat_info')) id_sat_info = - let sat_info'' = case lookupUFM id_sat_info v of - Nothing -> sat_info' - Just sat_info -> mergeSATInfo sat_info sat_info' - in extendVarEnv id_sat_info v sat_info'' - -satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo) -satTopLevelExpr expr interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (expr', finalizeApp expr_app sat_info_expr) - -satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) -satExpr var@(Var v) interesting_ids = do - let app_info = if v `elementOfUniqSet` interesting_ids - then Just (v, []) - else Nothing - return (var, emptyIdSATInfo, app_info) - -satExpr lit@(Lit _) _ = do - return (lit, emptyIdSATInfo, Nothing) - -satExpr (Lam binders body) interesting_ids = do - (body', sat_info, this_app) <- satExpr body interesting_ids - return (Lam binders body', finalizeApp this_app sat_info, Nothing) - -satExpr (App fn arg) interesting_ids = do - (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids - let satRemainder = boring fn' sat_info_fn - case fn_app of - Nothing -> satRemainder Nothing - Just (fn_id, fn_app_info) -> - -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface) - let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness]) - in case arg of - Type t -> satRemainderWithStaticness $ Static (TypeApp t) - Coercion c -> satRemainderWithStaticness $ Static (CoApp c) - Var v -> satRemainderWithStaticness $ Static (VarApp v) - _ -> satRemainderWithStaticness $ NotStatic - where - boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) - boring fn' sat_info_fn app_info = - do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids - let sat_info_arg' = finalizeApp arg_app sat_info_arg - sat_info = mergeIdSATInfo sat_info_fn sat_info_arg' - return (App fn' arg', sat_info, app_info) - -satExpr (Case expr bndr ty alts) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - let sat_info_expr' = finalizeApp expr_app sat_info_expr - - zipped_alts' <- mapM satAlt alts - let (alts', sat_infos_alts) = unzip zipped_alts' - return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing) - where - satAlt (con, bndrs, expr) = do - (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids - return ((con, bndrs, expr'), sat_info_expr) - -satExpr (Let bind body) interesting_ids = do - (body', sat_info_body, body_app) <- satExpr body interesting_ids - (bind', sat_info_bind) <- satBind bind interesting_ids - return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app) - -satExpr (Tick tickish expr) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (Tick tickish expr', sat_info_expr, expr_app) - -satExpr ty@(Type _) _ = do - return (ty, emptyIdSATInfo, Nothing) - -satExpr co@(Coercion _) _ = do - return (co, emptyIdSATInfo, Nothing) - -satExpr (Cast expr coercion) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (Cast expr' coercion, sat_info_expr, expr_app) - -{- -************************************************************************ - - Static Argument Transformation Monad - -************************************************************************ --} - -type SatM result = UniqSM result - -runSAT :: UniqSupply -> SatM a -> a -runSAT = initUs_ - -newUnique :: SatM Unique -newUnique = getUniqueM - -{- -************************************************************************ - - Static Argument Transformation Monad - -************************************************************************ - -To do the transformation, the game plan is to: - -1. Create a small nonrecursive RHS that takes the - original arguments to the function but discards - the ones that are static and makes a call to the - SATed version with the remainder. We intend that - this will be inlined later, removing the overhead - -2. Bind this nonrecursive RHS over the original body - WITH THE SAME UNIQUE as the original body so that - any recursive calls to the original now go via - the small wrapper - -3. Rebind the original function to a new one which contains - our SATed function and just makes a call to it: - we call the thing making this call the local body - -Example: transform this - - map :: forall a b. (a->b) -> [a] -> [b] - map = /\ab. \(f:a->b) (as:[a]) -> body[map] -to - map :: forall a b. (a->b) -> [a] -> [b] - map = /\ab. \(f:a->b) (as:[a]) -> - letrec map' :: [a] -> [b] - -- The "worker function - map' = \(as:[a]) -> - let map :: forall a' b'. (a -> b) -> [a] -> [b] - -- The "shadow function - map = /\a'b'. \(f':(a->b) (as:[a]). - map' as - in body[map] - in map' as - -Note [Shadow binding] -~~~~~~~~~~~~~~~~~~~~~ -The calls to the inner map inside body[map] should get inlined -by the local re-binding of 'map'. We call this the "shadow binding". - -But we can't use the original binder 'map' unchanged, because -it might be exported, in which case the shadow binding won't be -discarded as dead code after it is inlined. - -So we use a hack: we make a new SysLocal binder with the *same* unique -as binder. (Another alternative would be to reset the export flag.) - -Note [Binder type capture] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice that in the inner map (the "shadow function"), the static arguments -are discarded -- it's as if they were underscores. Instead, mentions -of these arguments (notably in the types of dynamic arguments) are bound -by the *outer* lambdas of the main function. So we must make up fresh -names for the static arguments so that they do not capture variables -mentioned in the types of dynamic args. - -In the map example, the shadow function must clone the static type -argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a' -is bound by the outer forall. We clone f' too for consistency, but -that doesn't matter either way because static Id arguments aren't -mentioned in the shadow binding at all. - -If we don't we get something like this: - -[Exported] -[Arity 3] -GHC.Base.until = - \ (@ a_aiK) - (p_a6T :: a_aiK -> GHC.Types.Bool) - (f_a6V :: a_aiK -> a_aiK) - (x_a6X :: a_aiK) -> - letrec { - sat_worker_s1aU :: a_aiK -> a_aiK - [] - sat_worker_s1aU = - \ (x_a6X :: a_aiK) -> - let { - sat_shadow_r17 :: forall a_a3O. - (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O - [] - sat_shadow_r17 = - \ (@ a_aiK) - (p_a6T :: a_aiK -> GHC.Types.Bool) - (f_a6V :: a_aiK -> a_aiK) - (x_a6X :: a_aiK) -> - sat_worker_s1aU x_a6X } in - case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] { - GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X); - GHC.Types.True -> x_a6X - }; } in - sat_worker_s1aU x_a6X - -Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK -type argument. This is bad because it means the application sat_worker_s1aU x_a6X -is not well typed. --} - -saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind -saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body - | Just arg_staticness <- maybe_arg_staticness - , should_transform arg_staticness - = saTransform binder arg_staticness rhs_binders rhs_body - | otherwise - = return (Rec [(binder, mkLams rhs_binders rhs_body)]) - where - should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT - where - n_static_args = count isStaticValue staticness - -saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind -saTransform binder arg_staticness rhs_binders rhs_body - = do { shadow_lam_bndrs <- mapM clone binders_w_staticness - ; uniq <- newUnique - ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) } - where - -- Running example: foldr - -- foldr \alpha \beta c n xs = e, for some e - -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic] - -- rhs_binders = [\alpha, \beta, c, n, xs] - -- rhs_body = e - - binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic) - -- Any extra args are assumed NotStatic - - non_static_args :: [Var] - -- non_static_args = [xs] - -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs] - non_static_args = [v | (v, NotStatic) <- binders_w_staticness] - - clone (bndr, NotStatic) = return bndr - clone (bndr, _ ) = do { uniq <- newUnique - ; return (setVarUnique bndr uniq) } - - -- new_rhs = \alpha beta c n xs -> - -- let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs -> - -- sat_worker xs - -- in e - -- in sat_worker xs - mk_new_rhs uniq shadow_lam_bndrs - = mkLams rhs_binders $ - Let (Rec [(rec_body_bndr, rec_body)]) - local_body - where - local_body = mkVarApps (Var rec_body_bndr) non_static_args - - rec_body = mkLams non_static_args $ - Let (NonRec shadow_bndr shadow_rhs) rhs_body - - -- See Note [Binder type capture] - shadow_rhs = mkLams shadow_lam_bndrs local_body - -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs - - rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body) - -- rec_body_bndr = sat_worker - - -- See Note [Shadow binding]; make a SysLocal - shadow_bndr = mkSysLocal (occNameFS (getOccName binder)) - (idUnique binder) - (exprType shadow_rhs) - -isStaticValue :: Staticness App -> Bool -isStaticValue (Static (VarApp _)) = True -isStaticValue _ = False diff --git a/simplCore/SetLevels.hs b/simplCore/SetLevels.hs deleted file mode 100644 --- a/simplCore/SetLevels.hs +++ /dev/null @@ -1,1645 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{SetLevels} - - *************************** - Overview - *************************** - -1. We attach binding levels to Core bindings, in preparation for floating - outwards (@FloatOut@). - -2. We also let-ify many expressions (notably case scrutinees), so they - will have a fighting chance of being floated sensible. - -3. Note [Need for cloning during float-out] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We clone the binders of any floatable let-binding, so that when it is - floated out it will be unique. Example - (let x=2 in x) + (let x=3 in x) - we must clone before floating so we get - let x1=2 in - let x2=3 in - x1+x2 - - NOTE: this can't be done using the uniqAway idea, because the variable - must be unique in the whole program, not just its current scope, - because two variables in different scopes may float out to the - same top level place - - NOTE: Very tiresomely, we must apply this substitution to - the rules stored inside a variable too. - - We do *not* clone top-level bindings, because some of them must not change, - but we *do* clone bindings that are heading for the top level - -4. Note [Binder-swap during float-out] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - In the expression - case x of wild { p -> ...wild... } - we substitute x for wild in the RHS of the case alternatives: - case x of wild { p -> ...x... } - This means that a sub-expression involving x is not "trapped" inside the RHS. - And it's not inconvenient because we already have a substitution. - - Note that this is EXACTLY BACKWARDS from the what the simplifier does. - The simplifier tries to get rid of occurrences of x, in favour of wild, - in the hope that there will only be one remaining occurrence of x, namely - the scrutinee of the case, and we can inline it. --} - -{-# LANGUAGE CPP, MultiWayIf #-} -module SetLevels ( - setLevels, - - Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl, - LevelledBind, LevelledExpr, LevelledBndr, - FloatSpec(..), floatSpecLevel, - - incMinorLvl, ltMajLvl, ltLvl, isTopLvl - ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreMonad ( FloatOutSwitches(..) ) -import CoreUtils ( exprType, exprIsHNF - , exprOkForSpeculation - , exprIsTopLevelBindable - , isExprLevPoly - , collectMakeStaticArgs - ) -import CoreArity ( exprBotStrictness_maybe ) -import CoreFVs -- all of it -import CoreSubst -import MkCore ( sortQuantVars ) - -import Id -import IdInfo -import Var -import VarSet -import VarEnv -import Literal ( litIsTrivial ) -import Demand ( StrictSig, isStrictDmd, splitStrictSig, increaseStrictSigArity ) -import Name ( getOccName, mkSystemVarName ) -import OccName ( occNameString ) -import Type ( isUnliftedType, Type, mkLamTypes, splitTyConApp_maybe ) -import BasicTypes ( Arity, RecFlag(..), isRec ) -import DataCon ( dataConOrigResTy ) -import TysWiredIn -import UniqSupply -import Util -import Outputable -import FastString -import UniqDFM -import FV -import Data.Maybe -import Control.Monad ( zipWithM ) - -{- -************************************************************************ -* * -\subsection{Level numbers} -* * -************************************************************************ --} - -type LevelledExpr = TaggedExpr FloatSpec -type LevelledBind = TaggedBind FloatSpec -type LevelledBndr = TaggedBndr FloatSpec - -data Level = Level Int -- Level number of enclosing lambdas - Int -- Number of big-lambda and/or case expressions and/or - -- context boundaries between - -- here and the nearest enclosing lambda - LevelType -- Binder or join ceiling? -data LevelType = BndrLvl | JoinCeilLvl deriving (Eq) - -data FloatSpec - = FloatMe Level -- Float to just inside the binding - -- tagged with this level - | StayPut Level -- Stay where it is; binding is - -- tagged with tihs level - -floatSpecLevel :: FloatSpec -> Level -floatSpecLevel (FloatMe l) = l -floatSpecLevel (StayPut l) = l - -{- -The {\em level number} on a (type-)lambda-bound variable is the -nesting depth of the (type-)lambda which binds it. The outermost lambda -has level 1, so (Level 0 0) means that the variable is bound outside any lambda. - -On an expression, it's the maximum level number of its free -(type-)variables. On a let(rec)-bound variable, it's the level of its -RHS. On a case-bound variable, it's the number of enclosing lambdas. - -Top-level variables: level~0. Those bound on the RHS of a top-level -definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown -as ``subscripts'')... -\begin{verbatim} -a_0 = let b_? = ... in - x_1 = ... b ... in ... -\end{verbatim} - -The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@). -That's meant to be the level number of the enclosing binder in the -final (floated) program. If the level number of a sub-expression is -less than that of the context, then it might be worth let-binding the -sub-expression so that it will indeed float. - -If you can float to level @Level 0 0@ worth doing so because then your -allocation becomes static instead of dynamic. We always start with -context @Level 0 0@. - - -Note [FloatOut inside INLINE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose: -to say "don't float anything out of here". That's exactly what we -want for the body of an INLINE, where we don't want to float anything -out at all. See notes with lvlMFE below. - -But, check this out: - --- At one time I tried the effect of not float anything out of an InlineMe, --- but it sometimes works badly. For example, consider PrelArr.done. It --- has the form __inline (\d. e) --- where e doesn't mention d. If we float this to --- __inline (let x = e in \d. x) --- things are bad. The inliner doesn't even inline it because it doesn't look --- like a head-normal form. So it seems a lesser evil to let things float. --- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe --- which discourages floating out. - -So the conclusion is: don't do any floating at all inside an InlineMe. -(In the above example, don't float the {x=e} out of the \d.) - -One particular case is that of workers: we don't want to float the -call to the worker outside the wrapper, otherwise the worker might get -inlined into the floated expression, and an importing module won't see -the worker at all. - -Note [Join ceiling] -~~~~~~~~~~~~~~~~~~~ -Join points can't float very far; too far, and they can't remain join points -So, suppose we have: - - f x = (joinrec j y = ... x ... in jump j x) + 1 - -One may be tempted to float j out to the top of f's RHS, but then the jump -would not be a tail call. Thus we keep track of a level called the *join -ceiling* past which join points are not allowed to float. - -The troublesome thing is that, unlike most levels to which something might -float, there is not necessarily an identifier to which the join ceiling is -attached. Fortunately, if something is to be floated to a join ceiling, it must -be dropped at the *nearest* join ceiling. Thus each level is marked as to -whether it is a join ceiling, so that FloatOut can tell which binders are being -floated to the nearest join ceiling and which to a particular binder (or set of -binders). --} - -instance Outputable FloatSpec where - ppr (FloatMe l) = char 'F' <> ppr l - ppr (StayPut l) = ppr l - -tOP_LEVEL :: Level -tOP_LEVEL = Level 0 0 BndrLvl - -incMajorLvl :: Level -> Level -incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl - -incMinorLvl :: Level -> Level -incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl - -asJoinCeilLvl :: Level -> Level -asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl - -maxLvl :: Level -> Level -> Level -maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _) - | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 - | otherwise = l2 - -ltLvl :: Level -> Level -> Bool -ltLvl (Level maj1 min1 _) (Level maj2 min2 _) - = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) - -ltMajLvl :: Level -> Level -> Bool - -- Tells if one level belongs to a difft *lambda* level to another -ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2 - -isTopLvl :: Level -> Bool -isTopLvl (Level 0 0 _) = True -isTopLvl _ = False - -isJoinCeilLvl :: Level -> Bool -isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl - -instance Outputable Level where - ppr (Level maj min typ) - = hcat [ char '<', int maj, char ',', int min, char '>' - , ppWhen (typ == JoinCeilLvl) (char 'C') ] - -instance Eq Level where - (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2 - -{- -************************************************************************ -* * -\subsection{Main level-setting code} -* * -************************************************************************ --} - -setLevels :: FloatOutSwitches - -> CoreProgram - -> UniqSupply - -> [LevelledBind] - -setLevels float_lams binds us - = initLvl us (do_them init_env binds) - where - init_env = initialEnv float_lams - - do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind] - do_them _ [] = return [] - do_them env (b:bs) - = do { (lvld_bind, env') <- lvlTopBind env b - ; lvld_binds <- do_them env' bs - ; return (lvld_bind : lvld_binds) } - -lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) -lvlTopBind env (NonRec bndr rhs) - = do { rhs' <- lvl_top env NonRecursive bndr rhs - ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr] - ; return (NonRec bndr' rhs', env') } - -lvlTopBind env (Rec pairs) - = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL - (map fst pairs) - ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs - ; return (Rec (bndrs' `zip` rhss'), env') } - -lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr -lvl_top env is_rec bndr rhs - = lvlRhs env is_rec - (isBottomingId bndr) - Nothing -- Not a join point - (freeVars rhs) - -{- -************************************************************************ -* * -\subsection{Setting expression levels} -* * -************************************************************************ - -Note [Floating over-saturated applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see (f x y), and (f x) is a redex (ie f's arity is 1), -we call (f x) an "over-saturated application" - -Should we float out an over-sat app, if can escape a value lambda? -It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2). -But we don't want to do it for class selectors, because the work saved -is minimal, and the extra local thunks allocated cost money. - -Arguably we could float even class-op applications if they were going to -top level -- but then they must be applied to a constant dictionary and -will almost certainly be optimised away anyway. --} - -lvlExpr :: LevelEnv -- Context - -> CoreExprWithFVs -- Input expression - -> LvlM LevelledExpr -- Result expression - -{- -The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing -binder. Here's an example - - v = \x -> ...\y -> let r = case (..x..) of - ..x.. - in .. - -When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's -the level of @r@, even though it's inside a level-2 @\y@. It's -important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we -don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE ---- because it isn't a *maximal* free expression. - -If there were another lambda in @r@'s rhs, it would get level-2 as well. --} - -lvlExpr env (_, AnnType ty) = return (Type (CoreSubst.substTy (le_subst env) ty)) -lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co)) -lvlExpr env (_, AnnVar v) = return (lookupVar env v) -lvlExpr _ (_, AnnLit lit) = return (Lit lit) - -lvlExpr env (_, AnnCast expr (_, co)) = do - expr' <- lvlNonTailExpr env expr - return (Cast expr' (substCo (le_subst env) co)) - -lvlExpr env (_, AnnTick tickish expr) = do - expr' <- lvlNonTailExpr env expr - let tickish' = substTickish (le_subst env) tickish - return (Tick tickish' expr') - -lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr) - --- We don't split adjacent lambdas. That is, given --- \x y -> (x+1,y) --- we don't float to give --- \x -> let v = x+1 in \y -> (v,y) --- Why not? Because partial applications are fairly rare, and splitting --- lambdas makes them more expensive. - -lvlExpr env expr@(_, AnnLam {}) - = do { new_body <- lvlNonTailMFE new_env True body - ; return (mkLams new_bndrs new_body) } - where - (bndrs, body) = collectAnnBndrs expr - (env1, bndrs1) = substBndrsSL NonRecursive env bndrs - (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1 - -- At one time we called a special verion of collectBinders, - -- which ignored coercions, because we don't want to split - -- a lambda like this (\x -> coerce t (\s -> ...)) - -- This used to happen quite a bit in state-transformer programs, - -- but not nearly so much now non-recursive newtypes are transparent. - -- [See SetLevels rev 1.50 for a version with this approach.] - -lvlExpr env (_, AnnLet bind body) - = do { (bind', new_env) <- lvlBind env bind - ; body' <- lvlExpr new_env body - -- No point in going via lvlMFE here. If the binding is alive - -- (mentioned in body), and the whole let-expression doesn't - -- float, then neither will the body - ; return (Let bind' body') } - -lvlExpr env (_, AnnCase scrut case_bndr ty alts) - = do { scrut' <- lvlNonTailMFE env True scrut - ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts } - -lvlNonTailExpr :: LevelEnv -- Context - -> CoreExprWithFVs -- Input expression - -> LvlM LevelledExpr -- Result expression -lvlNonTailExpr env expr - = lvlExpr (placeJoinCeiling env) expr - -------------------------------------------- -lvlApp :: LevelEnv - -> CoreExprWithFVs - -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application - -> LvlM LevelledExpr -- Result expression -lvlApp env orig_expr ((_,AnnVar fn), args) - | floatOverSat env -- See Note [Floating over-saturated applications] - , arity > 0 - , arity < n_val_args - , Nothing <- isClassOpId_maybe fn - = do { rargs' <- mapM (lvlNonTailMFE env False) rargs - ; lapp' <- lvlNonTailMFE env False lapp - ; return (foldl App lapp' rargs') } - - | otherwise - = do { args' <- zipWithM (lvlMFE env) stricts args - -- Take account of argument strictness; see - -- Note [Floating to the top] - ; return (foldl App (lookupVar env fn) args') } - where - n_val_args = count (isValArg . deAnnotate) args - arity = idArity fn - - stricts :: [Bool] -- True for strict argument - stricts = case splitStrictSig (idStrictness fn) of - (arg_ds, _) | not (arg_ds `lengthExceeds` n_val_args) - -> map isStrictDmd arg_ds ++ repeat False - | otherwise - -> repeat False - - -- Separate out the PAP that we are floating from the extra - -- arguments, by traversing the spine until we have collected - -- (n_val_args - arity) value arguments. - (lapp, rargs) = left (n_val_args - arity) orig_expr [] - - left 0 e rargs = (e, rargs) - left n (_, AnnApp f a) rargs - | isValArg (deAnnotate a) = left (n-1) f (a:rargs) - | otherwise = left n f (a:rargs) - left _ _ _ = panic "SetLevels.lvlExpr.left" - -lvlApp env _ (fun, args) - = -- No PAPs that we can float: just carry on with the - -- arguments and the function. - do { args' <- mapM (lvlNonTailMFE env False) args - ; fun' <- lvlNonTailExpr env fun - ; return (foldl App fun' args') } - -------------------------------------------- -lvlCase :: LevelEnv -- Level of in-scope names/tyvars - -> DVarSet -- Free vars of input scrutinee - -> LevelledExpr -- Processed scrutinee - -> Id -> Type -- Case binder and result type - -> [CoreAltWithFVs] -- Input alternatives - -> LvlM LevelledExpr -- Result expression -lvlCase env scrut_fvs scrut' case_bndr ty alts - | [(con@(DataAlt {}), bs, body)] <- alts - , exprOkForSpeculation (deTagExpr scrut') - -- See Note [Check the output scrutinee for okForSpec] - , not (isTopLvl dest_lvl) -- Can't have top-level cases - , not (floatTopLvlOnly env) -- Can float anywhere - = -- See Note [Floating cases] - -- Always float the case if possible - -- Unlike lets we don't insist that it escapes a value lambda - do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) - ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut' - ; body' <- lvlMFE rhs_env True body - ; let alt' = (con, map (stayPut dest_lvl) bs', body') - ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) } - - | otherwise -- Stays put - = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr] - alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut' - ; alts' <- mapM (lvl_alt alts_env) alts - ; return (Case scrut' case_bndr' ty' alts') } - where - ty' = substTy (le_subst env) ty - - incd_lvl = incMinorLvl (le_ctxt_lvl env) - dest_lvl = maxFvLevel (const True) env scrut_fvs - -- Don't abstract over type variables, hence const True - - lvl_alt alts_env (con, bs, rhs) - = do { rhs' <- lvlMFE new_env True rhs - ; return (con, bs', rhs') } - where - (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs - -{- -Note [Floating cases] -~~~~~~~~~~~~~~~~~~~~~ -Consider this: - data T a = MkT !a - f :: T Int -> blah - f x vs = case x of { MkT y -> - let f vs = ...(case y of I# w -> e)...f.. - in f vs -Here we can float the (case y ...) out, because y is sure -to be evaluated, to give - f x vs = case x of { MkT y -> - caes y of I# w -> - let f vs = ...(e)...f.. - in f vs - -That saves unboxing it every time round the loop. It's important in -some DPH stuff where we really want to avoid that repeated unboxing in -the inner loop. - -Things to note - * We can't float a case to top level - * It's worth doing this float even if we don't float - the case outside a value lambda. Example - case x of { - MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...) - If we floated the cases out we could eliminate one of them. - * We only do this with a single-alternative case - -Note [Check the output scrutinee for okForSpec] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - case x of y { - A -> ....(case y of alts).... - } -Because of the binder-swap, the inner case will get substituted to -(case x of ..). So when testing whether the scrutinee is -okForSpeculation we must be careful to test the *result* scrutinee ('x' -in this case), not the *input* one 'y'. The latter *is* ok for -speculation here, but the former is not -- and indeed we can't float -the inner case out, at least not unless x is also evaluated at its -binding site. - -That's why we apply exprOkForSpeculation to scrut' and not to scrut. --} - -lvlNonTailMFE :: LevelEnv -- Level of in-scope names/tyvars - -> Bool -- True <=> strict context [body of case - -- or let] - -> CoreExprWithFVs -- input expression - -> LvlM LevelledExpr -- Result expression -lvlNonTailMFE env strict_ctxt ann_expr - = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr - -lvlMFE :: LevelEnv -- Level of in-scope names/tyvars - -> Bool -- True <=> strict context [body of case or let] - -> CoreExprWithFVs -- input expression - -> LvlM LevelledExpr -- Result expression --- lvlMFE is just like lvlExpr, except that it might let-bind --- the expression, so that it can itself be floated. - -lvlMFE env _ (_, AnnType ty) - = return (Type (CoreSubst.substTy (le_subst env) ty)) - --- No point in floating out an expression wrapped in a coercion or note --- If we do we'll transform lvl = e |> co --- to lvl' = e; lvl = lvl' |> co --- and then inline lvl. Better just to float out the payload. -lvlMFE env strict_ctxt (_, AnnTick t e) - = do { e' <- lvlMFE env strict_ctxt e - ; let t' = substTickish (le_subst env) t - ; return (Tick t' e') } - -lvlMFE env strict_ctxt (_, AnnCast e (_, co)) - = do { e' <- lvlMFE env strict_ctxt e - ; return (Cast e' (substCo (le_subst env) co)) } - -lvlMFE env strict_ctxt e@(_, AnnCase {}) - | strict_ctxt -- Don't share cases in a strict context - = lvlExpr env e -- See Note [Case MFEs] - -lvlMFE env strict_ctxt ann_expr - | floatTopLvlOnly env && not (isTopLvl dest_lvl) - -- Only floating to the top level is allowed. - || anyDVarSet isJoinId fvs -- If there is a free join, don't float - -- See Note [Free join points] - || isExprLevPoly expr - -- We can't let-bind levity polymorphic expressions - -- See Note [Levity polymorphism invariants] in CoreSyn - || notWorthFloating expr abs_vars - || not float_me - = -- Don't float it out - lvlExpr env ann_expr - - | float_is_new_lam || exprIsTopLevelBindable expr expr_ty - -- No wrapping needed if the type is lifted, or is a literal string - -- or if we are wrapping it in one or more value lambdas - = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive - (isJust mb_bot_str) - join_arity_maybe - ann_expr - -- Treat the expr just like a right-hand side - ; var <- newLvlVar expr1 join_arity_maybe is_mk_static - ; let var2 = annotateBotStr var float_n_lams mb_bot_str - ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1) - (mkVarApps (Var var2) abs_vars)) } - - -- OK, so the float has an unlifted type (not top-level bindable) - -- and no new value lambdas (float_is_new_lam is False) - -- Try for the boxing strategy - -- See Note [Floating MFEs of unlifted type] - | escapes_value_lam - , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions - -- See Note [Test cheapness with exprOkForSpeculation] - , Just (tc, _) <- splitTyConApp_maybe expr_ty - , Just dc <- boxingDataCon_maybe tc - , let dc_res_ty = dataConOrigResTy dc -- No free type variables - [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty] - = do { expr1 <- lvlExpr rhs_env ann_expr - ; let l1r = incMinorLvlFrom rhs_env - float_rhs = mkLams abs_vars_w_lvls $ - Case expr1 (stayPut l1r ubx_bndr) dc_res_ty - [(DEFAULT, [], mkConApp dc [Var ubx_bndr])] - - ; var <- newLvlVar float_rhs Nothing is_mk_static - ; let l1u = incMinorLvlFrom env - use_expr = Case (mkVarApps (Var var) abs_vars) - (stayPut l1u bx_bndr) expr_ty - [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)] - ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) - use_expr) } - - | otherwise -- e.g. do not float unboxed tuples - = lvlExpr env ann_expr - - where - expr = deAnnotate ann_expr - expr_ty = exprType expr - fvs = freeVarsOf ann_expr - is_bot = isBottomThunk mb_bot_str - is_function = isFunction ann_expr - mb_bot_str = exprBotStrictness_maybe expr - -- See Note [Bottoming floats] - -- esp Bottoming floats (2) - expr_ok_for_spec = exprOkForSpeculation expr - dest_lvl = destLevel env fvs is_function is_bot False - abs_vars = abstractVars dest_lvl env fvs - - -- float_is_new_lam: the floated thing will be a new value lambda - -- replacing, say (g (x+4)) by (lvl x). No work is saved, nor is - -- allocation saved. The benefit is to get it to the top level - -- and hence out of the body of this function altogether, making - -- it smaller and more inlinable - float_is_new_lam = float_n_lams > 0 - float_n_lams = count isId abs_vars - - (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars - - join_arity_maybe = Nothing - - is_mk_static = isJust (collectMakeStaticArgs expr) - -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable - - -- A decision to float entails let-binding this thing, and we only do - -- that if we'll escape a value lambda, or will go to the top level. - float_me = saves_work || saves_alloc || is_mk_static - - -- We can save work if we can move a redex outside a value lambda - -- But if float_is_new_lam is True, then the redex is wrapped in a - -- a new lambda, so no work is saved - saves_work = escapes_value_lam && not float_is_new_lam - - escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env) - -- See Note [Escaping a value lambda] - - -- See Note [Floating to the top] - saves_alloc = isTopLvl dest_lvl - && floatConsts env - && (not strict_ctxt || is_bot || exprIsHNF expr) - -isBottomThunk :: Maybe (Arity, s) -> Bool --- See Note [Bottoming floats] (2) -isBottomThunk (Just (0, _)) = True -- Zero arity -isBottomThunk _ = False - -{- Note [Floating to the top] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are keen to float something to the top level, even if it does not -escape a value lambda (and hence save work), for two reasons: - - * Doing so makes the function smaller, by floating out - bottoming expressions, or integer or string literals. That in - turn makes it easier to inline, with less duplication. - - * (Minor) Doing so may turn a dynamic allocation (done by machine - instructions) into a static one. Minor because we are assuming - we are not escaping a value lambda. - -But do not so if: - - the context is a strict, and - - the expression is not a HNF, and - - the expression is not bottoming - -Exammples: - -* Bottoming - f x = case x of - 0 -> error - _ -> x+1 - Here we want to float (error ) to top level, abstracting - over 'x', so as to make f's RHS smaller. - -* HNF - f = case y of - True -> p:q - False -> blah - We may as well float the (p:q) so it becomes a static data structure. - -* Case scrutinee - f = case g True of .... - Don't float (g True) to top level; then we have the admin of a - top-level thunk to worry about, with zero gain. - -* Case alternative - h = case y of - True -> g True - False -> False - Don't float (g True) to the top level - -* Arguments - t = f (g True) - If f is lazy, we /do/ float (g True) because then we can allocate - the thunk statically rather than dynamically. But if f is strict - we don't (see the use of idStrictness in lvlApp). It's not clear - if this test is worth the bother: it's only about CAFs! - -It's controlled by a flag (floatConsts), because doing this too -early loses opportunities for RULES which (needless to say) are -important in some nofib programs (gcd is an example). [SPJ note: -I think this is obselete; the flag seems always on.] - -Note [Floating join point bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Mostly we only float a join point if it can /stay/ a join point. But -there is one exception: if it can go to the top level (Trac #13286). -Consider - f x = joinrec j y n = <...j y' n'...> - in jump j x 0 - -Here we may just as well produce - j y n = <....j y' n'...> - f x = j x 0 - -and now there is a chance that 'f' will be inlined at its call sites. -It shouldn't make a lot of difference, but thes tests - perf/should_run/MethSharing - simplCore/should_compile/spec-inline -and one nofib program, all improve if you do float to top, because -of the resulting inlining of f. So ok, let's do it. - -Note [Free join points] -~~~~~~~~~~~~~~~~~~~~~~~ -We never float a MFE that has a free join-point variable. You mght think -this can never occur. After all, consider - join j x = ... - in ....(jump j x).... -How might we ever want to float that (jump j x)? - * If it would escape a value lambda, thus - join j x = ... in (\y. ...(jump j x)... ) - then 'j' isn't a valid join point in the first place. - -But consider - join j x = .... in - joinrec j2 y = ...(jump j x)...(a+b).... - -Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec. -But it is emphatically /not/ good to float the (jump j x) out: - (a) 'j' will stop being a join point - (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no - work would be saved by floating it out of the \y. - -Even if we floated 'j' to top level, (b) would still hold. - -Bottom line: never float a MFE that has a free JoinId. - -Note [Floating MFEs of unlifted type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - case f x of (r::Int#) -> blah -we'd like to float (f x). But it's not trivial because it has type -Int#, and we don't want to evaluate it too early. But we can instead -float a boxed version - y = case f x of r -> I# r -and replace the original (f x) with - case (case y of I# r -> r) of r -> blah - -Being able to float unboxed expressions is sometimes important; see -Trac #12603. I'm not sure how /often/ it is important, but it's -not hard to achieve. - -We only do it for a fixed collection of types for which we have a -convenient boxing constructor (see boxingDataCon_maybe). In -particular we /don't/ do it for unboxed tuples; it's better to float -the components of the tuple individually. - -I did experiment with a form of boxing that works for any type, namely -wrapping in a function. In our example - - let y = case f x of r -> \v. f x - in case y void of r -> blah - -It works fine, but it's 50% slower (based on some crude benchmarking). -I suppose we could do it for types not covered by boxingDataCon_maybe, -but it's more code and I'll wait to see if anyone wants it. - -Note [Test cheapness with exprOkForSpeculation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't want to float very cheap expressions by boxing and unboxing. -But we use exprOkForSpeculation for the test, not exprIsCheap. -Why? Because it's important /not/ to transform - f (a /# 3) -to - f (case bx of I# a -> a /# 3) -and float bx = I# (a /# 3), because the application of f no -longer obeys the let/app invariant. But (a /# 3) is ok-for-spec -due to a special hack that says division operators can't fail -when the denominator is definitely non-zero. And yet that -same expression says False to exprIsCheap. Simplest way to -guarantee the let/app invariant is to use the same function! - -If an expression is okay for speculation, we could also float it out -*without* boxing and unboxing, since evaluating it early is okay. -However, it turned out to usually be better not to float such expressions, -since they tend to be extremely cheap things like (x +# 1#). Even the -cost of spilling the let-bound variable to the stack across a call may -exceed the cost of recomputing such an expression. (And we can't float -unlifted bindings to top-level.) - -We could try to do something smarter here, and float out expensive yet -okay-for-speculation things, such as division by non-zero constants. -But I suspect it's a narrow target. - -Note [Bottoming floats] -~~~~~~~~~~~~~~~~~~~~~~~ -If we see - f = \x. g (error "urk") -we'd like to float the call to error, to get - lvl = error "urk" - f = \x. g lvl - -But, as ever, we need to be careful: - -(1) We want to float a bottoming - expression even if it has free variables: - f = \x. g (let v = h x in error ("urk" ++ v)) - Then we'd like to abstract over 'x' can float the whole arg of g: - lvl = \x. let v = h x in error ("urk" ++ v) - f = \x. g (lvl x) - To achieve this we pass is_bot to destLevel - -(2) We do not do this for lambdas that return - bottom. Instead we treat the /body/ of such a function specially, - via point (1). For example: - f = \x. ....(\y z. if x then error y else error z).... - ===> - lvl = \x z y. if b then error y else error z - f = \x. ...(\y z. lvl x z y)... - (There is no guarantee that we'll choose the perfect argument order.) - -(3) If we have a /binding/ that returns bottom, we want to float it to top - level, even if it has free vars (point (1)), and even it has lambdas. - Example: - ... let { v = \y. error (show x ++ show y) } in ... - We want to abstract over x and float the whole thing to top: - lvl = \xy. errror (show x ++ show y) - ...let {v = lvl x} in ... - - Then of course we don't want to separately float the body (error ...) - as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot - argument. - -See Maessen's paper 1999 "Bottom extraction: factoring error handling out -of functional programs" (unpublished I think). - -When we do this, we set the strictness and arity of the new bottoming -Id, *immediately*, for three reasons: - - * To prevent the abstracted thing being immediately inlined back in again - via preInlineUnconditionally. The latter has a test for bottoming Ids - to stop inlining them, so we'd better make sure it *is* a bottoming Id! - - * So that it's properly exposed as such in the interface file, even if - this is all happening after strictness analysis. - - * In case we do CSE with the same expression that *is* marked bottom - lvl = error "urk" - x{str=bot) = error "urk" - Here we don't want to replace 'x' with 'lvl', else we may get Lint - errors, e.g. via a case with empty alternatives: (case x of {}) - Lint complains unless the scrutinee of such a case is clearly bottom. - - This was reported in Trac #11290. But since the whole bottoming-float - thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure - that it'll nail all such cases. - -Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tiresomely, though, the simplifier has an invariant that the manifest -arity of the RHS should be the same as the arity; but we can't call -etaExpand during SetLevels because it works over a decorated form of -CoreExpr. So we do the eta expansion later, in FloatOut. - -Note [Case MFEs] -~~~~~~~~~~~~~~~~ -We don't float a case expression as an MFE from a strict context. Why not? -Because in doing so we share a tiny bit of computation (the switch) but -in exchange we build a thunk, which is bad. This case reduces allocation -by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem. -Doesn't change any other allocation at all. - -We will make a separate decision for the scrutinees and alternatives. --} - -annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id --- See Note [Bottoming floats] for why we want to add --- bottoming information right now --- --- n_extra are the number of extra value arguments added during floating -annotateBotStr id n_extra mb_str - = case mb_str of - Nothing -> id - Just (arity, sig) -> id `setIdArity` (arity + n_extra) - `setIdStrictness` (increaseStrictSigArity n_extra sig) - -notWorthFloating :: CoreExpr -> [Var] -> Bool --- Returns True if the expression would be replaced by --- something bigger than it is now. For example: --- abs_vars = tvars only: return True if e is trivial, --- but False for anything bigger --- abs_vars = [x] (an Id): return True for trivial, or an application (f x) --- but False for (f x x) --- --- One big goal is that floating should be idempotent. Eg if --- we replace e with (lvl79 x y) and then run FloatOut again, don't want --- to replace (lvl79 x y) with (lvl83 x y)! - -notWorthFloating e abs_vars - = go e (count isId abs_vars) - where - go (Var {}) n = n >= 0 - go (Lit lit) n = ASSERT( n==0 ) - litIsTrivial lit -- Note [Floating literals] - go (Tick t e) n = not (tickishIsCode t) && go e n - go (Cast e _) n = go e n - go (App e arg) n - | Type {} <- arg = go e n - | Coercion {} <- arg = go e n - | n==0 = False - | is_triv arg = go e (n-1) - | otherwise = False - go _ _ = False - - is_triv (Lit {}) = True -- Treat all literals as trivial - is_triv (Var {}) = True -- (ie not worth floating) - is_triv (Cast e _) = is_triv e - is_triv (App e (Type {})) = is_triv e - is_triv (App e (Coercion {})) = is_triv e - is_triv (Tick t e) = not (tickishIsCode t) && is_triv e - is_triv _ = False - -{- -Note [Floating literals] -~~~~~~~~~~~~~~~~~~~~~~~~ -It's important to float Integer literals, so that they get shared, -rather than being allocated every time round the loop. -Hence the litIsTrivial. - -Ditto literal strings (MachStr), which we'd like to float to top -level, which is now possible. - - -Note [Escaping a value lambda] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to float even cheap expressions out of value lambdas, -because that saves allocation. Consider - f = \x. .. (\y.e) ... -Then we'd like to avoid allocating the (\y.e) every time we call f, -(assuming e does not mention x). An example where this really makes a -difference is simplrun009. - -Another reason it's good is because it makes SpecContr fire on functions. -Consider - f = \x. ....(f (\y.e)).... -After floating we get - lvl = \y.e - f = \x. ....(f lvl)... -and that is much easier for SpecConstr to generate a robust -specialisation for. - -However, if we are wrapping the thing in extra value lambdas (in -abs_vars), then nothing is saved. E.g. - f = \xyz. ...(e1[y],e2).... -If we float - lvl = \y. (e1[y],e2) - f = \xyz. ...(lvl y)... -we have saved nothing: one pair will still be allocated for each -call of 'f'. Hence the (not float_is_lam) in float_me. - - -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ - -The binding stuff works for top level too. --} - -lvlBind :: LevelEnv - -> CoreBindWithFVs - -> LvlM (LevelledBind, LevelEnv) - -lvlBind env (AnnNonRec bndr rhs) - | isTyVar bndr -- Don't do anything for TyVar binders - -- (simplifier gets rid of them pronto) - || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv) - -- so we will ignore this case for now - || not (profitableFloat env dest_lvl) - || (isTopLvl dest_lvl && isUnliftedType (idType bndr)) - -- We can't float an unlifted binding to top level, so we don't - -- float it at all. It's a bit brutal, but unlifted bindings - -- aren't expensive either - - = -- No float - do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs - ; let bind_lvl = incMinorLvl (le_ctxt_lvl env) - (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr] - ; return (NonRec bndr' rhs', env') } - - -- Otherwise we are going to float - | null abs_vars - = do { -- No type abstraction; clone existing binder - rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive - is_bot mb_join_arity rhs - ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr] - ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str - ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } - - | otherwise - = do { -- Yes, type abstraction; create a new binder, extend substitution, etc - rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive - is_bot mb_join_arity rhs - ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr] - ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str - ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } - - where - rhs_fvs = freeVarsOf rhs - bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr - abs_vars = abstractVars dest_lvl env bind_fvs - dest_lvl = destLevel env bind_fvs (isFunction rhs) is_bot is_join - - mb_bot_str = exprBotStrictness_maybe (deAnnotate rhs) - is_bot = isJust mb_bot_str - -- NB: not isBottomThunk! See Note [Bottoming floats] point (3) - - n_extra = count isId abs_vars - mb_join_arity = isJoinId_maybe bndr - is_join = isJust mb_join_arity - -lvlBind env (AnnRec pairs) - | floatTopLvlOnly env && not (isTopLvl dest_lvl) - -- Only floating to the top level is allowed. - || not (profitableFloat env dest_lvl) - = do { let bind_lvl = incMinorLvl (le_ctxt_lvl env) - (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs - lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r - ; rhss' <- mapM lvl_rhs pairs - ; return (Rec (bndrs' `zip` rhss'), env') } - - | null abs_vars - = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs - ; new_rhss <- mapM (do_rhs new_env) pairs - ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) - , new_env) } - --- ToDo: when enabling the floatLambda stuff, --- I think we want to stop doing this - | [(bndr,rhs)] <- pairs - , count isId abs_vars > 1 - = do -- Special case for self recursion where there are - -- several variables carried around: build a local loop: - -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars - -- This just makes the closures a bit smaller. If we don't do - -- this, allocation rises significantly on some programs - -- - -- We could elaborate it for the case where there are several - -- mutually functions, but it's quite a bit more complicated - -- - -- This all seems a bit ad hoc -- sigh - let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars - rhs_lvl = le_ctxt_lvl rhs_env - - (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr] - let - (lam_bndrs, rhs_body) = collectAnnBndrs rhs - (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs - (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1 - new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body - (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr] - return (Rec [(TB poly_bndr (FloatMe dest_lvl) - , mkLams abs_vars_w_lvls $ - mkLams lam_bndrs2 $ - Let (Rec [( TB new_bndr (StayPut rhs_lvl) - , mkLams lam_bndrs2 new_rhs_body)]) - (mkVarApps (Var new_bndr) lam_bndrs1))] - , poly_env) - - | otherwise -- Non-null abs_vars - = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs - ; new_rhss <- mapM (do_rhs new_env) pairs - ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) - , new_env) } - - where - (bndrs,rhss) = unzip pairs - is_join = isJoinId (head bndrs) - -- bndrs is always non-empty and if one is a join they all are - -- Both are checked by Lint - is_fun = all isFunction rhss - is_bot = False -- It's odd to have an unconditionally divergent - -- function in a Rec, and we don't much care what - -- happens to it. False is simple! - - do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive - is_bot (get_join bndr) - rhs - - get_join bndr | need_zap = Nothing - | otherwise = isJoinId_maybe bndr - need_zap = dest_lvl `ltLvl` joinCeilingLevel env - - -- Finding the free vars of the binding group is annoying - bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs]) - `unionDVarSet` - (fvDVarSet $ unionsFV [ idFVs bndr - | (bndr, (_,_)) <- pairs])) - `delDVarSetList` - bndrs - - dest_lvl = destLevel env bind_fvs is_fun is_bot is_join - abs_vars = abstractVars dest_lvl env bind_fvs - -profitableFloat :: LevelEnv -> Level -> Bool -profitableFloat env dest_lvl - = (dest_lvl `ltMajLvl` le_ctxt_lvl env) -- Escapes a value lambda - || isTopLvl dest_lvl -- Going all the way to top level - - ----------------------------------------------------- --- Three help functions for the type-abstraction case - -lvlRhs :: LevelEnv - -> RecFlag - -> Bool -- Is this a bottoming function - -> Maybe JoinArity - -> CoreExprWithFVs - -> LvlM LevelledExpr -lvlRhs env rec_flag is_bot mb_join_arity expr - = lvlFloatRhs [] (le_ctxt_lvl env) env - rec_flag is_bot mb_join_arity expr - -lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag - -> Bool -- Binding is for a bottoming function - -> Maybe JoinArity - -> CoreExprWithFVs - -> LvlM (Expr LevelledBndr) --- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline -lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs - = do { body' <- if not is_bot -- See Note [Floating from a RHS] - && any isId bndrs - then lvlMFE body_env True body - else lvlExpr body_env body - ; return (mkLams bndrs' body') } - where - (bndrs, body) | Just join_arity <- mb_join_arity - = collectNAnnBndrs join_arity rhs - | otherwise - = collectAnnBndrs rhs - (env1, bndrs1) = substBndrsSL NonRecursive env bndrs - all_bndrs = abs_vars ++ bndrs1 - (body_env, bndrs') | Just _ <- mb_join_arity - = lvlJoinBndrs env1 dest_lvl rec all_bndrs - | otherwise - = case lvlLamBndrs env1 dest_lvl all_bndrs of - (env2, bndrs') -> (placeJoinCeiling env2, bndrs') - -- The important thing here is that we call lvlLamBndrs on - -- all these binders at once (abs_vars and bndrs), so they - -- all get the same major level. Otherwise we create stupid - -- let-bindings inside, joyfully thinking they can float; but - -- in the end they don't because we never float bindings in - -- between lambdas - -{- Note [Floating from a RHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When float the RHS of a let-binding, we don't always want to apply -lvlMFE to the body of a lambda, as we usually do, because the entire -binding body is already going to the right place (dest_lvl). - -A particular example is the top level. Consider - concat = /\ a -> foldr ..a.. (++) [] -We don't want to float the body of the lambda to get - lvl = /\ a -> foldr ..a.. (++) [] - concat = /\ a -> lvl a -That would be stupid. - -Previously this was avoided in a much nastier way, by testing strict_ctxt -in float_me in lvlMFE. But that wasn't even right because it would fail -to float out the error sub-expression in - f = \x. case x of - True -> error ("blah" ++ show x) - False -> ... - -But we must be careful: - -* If we had - f = \x -> factorial 20 - we /would/ want to float that (factorial 20) out! Functions are treated - differently: see the use of isFunction in the calls to destLevel. If - there are only type lambdas, then destLevel will say "go to top, and - abstract over the free tyvars" and we don't want that here. - -* But if we had - f = \x -> error (...x....) - we would NOT want to float the bottoming expression out to give - lvl = \x -> error (...x...) - f = \x -> lvl x - -Conclusion: use lvlMFE if there are - * any value lambdas in the original function, and - * this is not a bottoming function (the is_bot argument) -Use lvlExpr otherwise. A little subtle, and I got it wrong at least twice -(e.g. Trac #13369). --} - -{- -************************************************************************ -* * -\subsection{Deciding floatability} -* * -************************************************************************ --} - -substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr]) -substAndLvlBndrs is_rec env lvl bndrs - = lvlBndrs subst_env lvl subst_bndrs - where - (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs - -substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar]) --- So named only to avoid the name clash with CoreSubst.substBndrs -substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs - = ( env { le_subst = subst' - , le_env = foldl add_id id_env (bndrs `zip` bndrs') } - , bndrs') - where - (subst', bndrs') = case is_rec of - NonRecursive -> substBndrs subst bndrs - Recursive -> substRecBndrs subst bndrs - -lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr]) --- Compute the levels for the binders of a lambda group -lvlLamBndrs env lvl bndrs - = lvlBndrs env new_lvl bndrs - where - new_lvl | any is_major bndrs = incMajorLvl lvl - | otherwise = incMinorLvl lvl - - is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr) - -- The "probably" part says "don't float things out of a - -- probable one-shot lambda" - -- See Note [Computing one-shot info] in Demand.hs - -lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar] - -> (LevelEnv, [LevelledBndr]) -lvlJoinBndrs env lvl rec bndrs - = lvlBndrs env new_lvl bndrs - where - new_lvl | isRec rec = incMajorLvl lvl - | otherwise = incMinorLvl lvl - -- Non-recursive join points are one-shot; recursive ones are not - -lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr]) --- The binders returned are exactly the same as the ones passed, --- apart from applying the substitution, but they are now paired --- with a (StayPut level) --- --- The returned envt has le_ctxt_lvl updated to the new_lvl --- --- All the new binders get the same level, because --- any floating binding is either going to float past --- all or none. We never separate binders. -lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs - = ( env { le_ctxt_lvl = new_lvl - , le_join_ceil = new_lvl - , le_lvl_env = addLvls new_lvl lvl_env bndrs } - , map (stayPut new_lvl) bndrs) - -stayPut :: Level -> OutVar -> LevelledBndr -stayPut new_lvl bndr = TB bndr (StayPut new_lvl) - - -- Destination level is the max Id level of the expression - -- (We'll abstract the type variables, if any.) -destLevel :: LevelEnv -> DVarSet - -> Bool -- True <=> is function - -> Bool -- True <=> is bottom - -> Bool -- True <=> is a join point - -> Level --- INVARIANT: if is_join=True then result >= join_ceiling -destLevel env fvs is_function is_bot is_join - | isTopLvl max_fv_id_level -- Float even joins if they get to top level - -- See Note [Floating join point bindings] - = tOP_LEVEL - - | is_join -- Never float a join point past the join ceiling - -- See Note [Join points] in FloatOut - = if max_fv_id_level `ltLvl` join_ceiling - then join_ceiling - else max_fv_id_level - - | is_bot -- Send bottoming bindings to the top - = tOP_LEVEL -- regardless; see Note [Bottoming floats] - -- Esp Bottoming floats (1) - - | Just n_args <- floatLams env - , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case - , is_function - , countFreeIds fvs <= n_args - = tOP_LEVEL -- Send functions to top level; see - -- the comments with isFunction - - | otherwise = max_fv_id_level - where - max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the tyvars - -- will be abstracted - join_ceiling = joinCeilingLevel env - -isFunction :: CoreExprWithFVs -> Bool --- The idea here is that we want to float *functions* to --- the top level. This saves no work, but --- (a) it can make the host function body a lot smaller, --- and hence inlinable. --- (b) it can also save allocation when the function is recursive: --- h = \x -> letrec f = \y -> ...f...y...x... --- in f x --- becomes --- f = \x y -> ...(f x)...y...x... --- h = \x -> f x x --- No allocation for f now. --- We may only want to do this if there are sufficiently few free --- variables. We certainly only want to do it for values, and not for --- constructors. So the simple thing is just to look for lambdas -isFunction (_, AnnLam b e) | isId b = True - | otherwise = isFunction e --- isFunction (_, AnnTick _ e) = isFunction e -- dubious -isFunction _ = False - -countFreeIds :: DVarSet -> Int -countFreeIds = nonDetFoldUDFM add 0 - -- It's OK to use nonDetFoldUDFM here because we're just counting things. - where - add :: Var -> Int -> Int - add v n | isId v = n+1 - | otherwise = n - -{- -************************************************************************ -* * -\subsection{Free-To-Level Monad} -* * -************************************************************************ --} - -data LevelEnv - = LE { le_switches :: FloatOutSwitches - , le_ctxt_lvl :: Level -- The current level - , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids - , le_join_ceil:: Level -- Highest level to which joins float - -- Invariant: always >= le_ctxt_lvl - - -- See Note [le_subst and le_env] - , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids - -- The Id -> CoreExpr in the Subst is ignored - -- (since we want to substitute a LevelledExpr for - -- an Id via le_env) but we do use the Co/TyVar substs - , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids - } - -{- Note [le_subst and le_env] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We clone let- and case-bound variables so that they are still distinct -when floated out; hence the le_subst/le_env. (see point 3 of the -module overview comment). We also use these envs when making a -variable polymorphic because we want to float it out past a big -lambda. - -The le_subst and le_env always implement the same mapping, - in_x :-> out_x a b -where out_x is an OutVar, and a,b are its arguments (when -we perform abstraction at the same time as floating). - - le_subst maps to CoreExpr - le_env maps to LevelledExpr - -Since the range is always a variable or application, there is never -any difference between the two, but sadly the types differ. The -le_subst is used when substituting in a variable's IdInfo; the le_env -when we find a Var. - -In addition the le_env records a [OutVar] of variables free in the -OutExpr/LevelledExpr, just so we don't have to call freeVars -repeatedly. This list is always non-empty, and the first element is -out_x - -The domain of the both envs is *pre-cloned* Ids, though - -The domain of the le_lvl_env is the *post-cloned* Ids --} - -initialEnv :: FloatOutSwitches -> LevelEnv -initialEnv float_lams - = LE { le_switches = float_lams - , le_ctxt_lvl = tOP_LEVEL - , le_join_ceil = panic "initialEnv" - , le_lvl_env = emptyVarEnv - , le_subst = emptySubst - , le_env = emptyVarEnv } - -addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level -addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl - -addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level -addLvls dest_lvl env vs = foldl (addLvl dest_lvl) env vs - -floatLams :: LevelEnv -> Maybe Int -floatLams le = floatOutLambdas (le_switches le) - -floatConsts :: LevelEnv -> Bool -floatConsts le = floatOutConstants (le_switches le) - -floatOverSat :: LevelEnv -> Bool -floatOverSat le = floatOutOverSatApps (le_switches le) - -floatTopLvlOnly :: LevelEnv -> Bool -floatTopLvlOnly le = floatToTopLevelOnly (le_switches le) - -incMinorLvlFrom :: LevelEnv -> Level -incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env) - --- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can --- See Note [Binder-swap during float-out] -extendCaseBndrEnv :: LevelEnv - -> Id -- Pre-cloned case binder - -> Expr LevelledBndr -- Post-cloned scrutinee - -> LevelEnv -extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env }) - case_bndr (Var scrut_var) - = le { le_subst = extendSubstWithVar subst case_bndr scrut_var - , le_env = add_id id_env (case_bndr, scrut_var) } -extendCaseBndrEnv env _ _ = env - --- See Note [Join ceiling] -placeJoinCeiling :: LevelEnv -> LevelEnv -placeJoinCeiling le@(LE { le_ctxt_lvl = lvl }) - = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' } - where - lvl' = asJoinCeilLvl (incMinorLvl lvl) - -maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level -maxFvLevel max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set - = foldDVarSet max_in tOP_LEVEL var_set - where - max_in in_var lvl - = foldr max_out lvl (case lookupVarEnv id_env in_var of - Just (abs_vars, _) -> abs_vars - Nothing -> [in_var]) - - max_out out_var lvl - | max_me out_var = case lookupVarEnv lvl_env out_var of - Just lvl' -> maxLvl lvl' lvl - Nothing -> lvl - | otherwise = lvl -- Ignore some vars depending on max_me - -lookupVar :: LevelEnv -> Id -> LevelledExpr -lookupVar le v = case lookupVarEnv (le_env le) v of - Just (_, expr) -> expr - _ -> Var v - --- Level to which join points are allowed to float (boundary of current tail --- context). See Note [Join ceiling] -joinCeilingLevel :: LevelEnv -> Level -joinCeilingLevel = le_join_ceil - -abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar] - -- Find the variables in fvs, free vars of the target expression, - -- whose level is greater than the destination level - -- These are the ones we are going to abstract out - -- - -- Note that to get reproducible builds, the variables need to be - -- abstracted in deterministic order, not dependent on the values of - -- Uniques. This is achieved by using DVarSets, deterministic free - -- variable computation and deterministic sort. - -- See Note [Unique Determinism] in Unique for explanation of why - -- Uniques are not deterministic. -abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs - = -- NB: sortQuantVars might not put duplicates next to each other - map zap $ sortQuantVars $ uniq - [out_var | out_fv <- dVarSetElems (substDVarSet subst in_fvs) - , out_var <- dVarSetElems (close out_fv) - , abstract_me out_var ] - -- NB: it's important to call abstract_me only on the OutIds the - -- come from substDVarSet (not on fv, which is an InId) - where - uniq :: [Var] -> [Var] - -- Remove duplicates, preserving order - uniq = dVarSetElems . mkDVarSet - - abstract_me v = case lookupVarEnv lvl_env v of - Just lvl -> dest_lvl `ltLvl` lvl - Nothing -> False - - -- We are going to lambda-abstract, so nuke any IdInfo, - -- and add the tyvars of the Id (if necessary) - zap v | isId v = WARN( isStableUnfolding (idUnfolding v) || - not (isEmptyRuleInfo (idSpecialisation v)), - text "absVarsOf: discarding info on" <+> ppr v ) - setIdInfo v vanillaIdInfo - | otherwise = v - - close :: Var -> DVarSet -- Close over variables free in the type - -- Result includes the input variable itself - close v = foldDVarSet (unionDVarSet . close) - (unitDVarSet v) - (fvDVarSet $ varTypeTyCoFVs v) - -type LvlM result = UniqSM result - -initLvl :: UniqSupply -> UniqSM a -> a -initLvl = initUs_ - -newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] - -> LvlM (LevelEnv, [OutId]) --- The envt is extended to bind the new bndrs to dest_lvl, but --- the le_ctxt_lvl is unaffected -newPolyBndrs dest_lvl - env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) - abs_vars bndrs - = ASSERT( all (not . isCoVar) bndrs ) -- What would we add to the CoSubst in this case. No easy answer. - do { uniqs <- getUniquesM - ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs - bndr_prs = bndrs `zip` new_bndrs - env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs - , le_subst = foldl add_subst subst bndr_prs - , le_env = foldl add_id id_env bndr_prs } - ; return (env', new_bndrs) } - where - add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) - add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) - - mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in Id.hs - transfer_join_info bndr $ - mkSysLocalOrCoVar (mkFastString str) uniq poly_ty - where - str = "poly_" ++ occNameString (getOccName bndr) - poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr)) - - -- If we are floating a join point to top level, it stops being - -- a join point. Otherwise it continues to be a join point, - -- but we may need to adjust its arity - dest_is_top = isTopLvl dest_lvl - transfer_join_info bndr new_bndr - | Just join_arity <- isJoinId_maybe bndr - , not dest_is_top - = new_bndr `asJoinId` join_arity + length abs_vars - | otherwise - = new_bndr - -newLvlVar :: LevelledExpr -- The RHS of the new binding - -> Maybe JoinArity -- Its join arity, if it is a join point - -> Bool -- True <=> the RHS looks like (makeStatic ...) - -> LvlM Id -newLvlVar lvld_rhs join_arity_maybe is_mk_static - = do { uniq <- getUniqueM - ; return (add_join_info (mk_id uniq rhs_ty)) - } - where - add_join_info var = var `asJoinId_maybe` join_arity_maybe - de_tagged_rhs = deTagExpr lvld_rhs - rhs_ty = exprType de_tagged_rhs - - mk_id uniq rhs_ty - -- See Note [Grand plan for static forms] in StaticPtrTable. - | is_mk_static - = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) - rhs_ty - | otherwise - = mkLocalIdOrCoVar (mkSystemVarName uniq (mkFastString "lvl")) rhs_ty - -cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) -cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) - new_lvl vs - = do { us <- getUniqueSupplyM - ; let (subst', vs') = cloneBndrs subst us vs - env' = env { le_ctxt_lvl = new_lvl - , le_join_ceil = new_lvl - , le_lvl_env = addLvls new_lvl lvl_env vs' - , le_subst = subst' - , le_env = foldl add_id id_env (vs `zip` vs') } - - ; return (env', vs') } - -cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar] - -> LvlM (LevelEnv, [OutVar]) --- See Note [Need for cloning during float-out] --- Works for Ids bound by let(rec) --- The dest_lvl is attributed to the binders in the new env, --- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env -cloneLetVars is_rec - env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) - dest_lvl vs - = do { us <- getUniqueSupplyM - ; let vs1 = map zap vs - -- See Note [Zapping the demand info] - (subst', vs2) = case is_rec of - NonRecursive -> cloneBndrs subst us vs1 - Recursive -> cloneRecIdBndrs subst us vs1 - prs = vs `zip` vs2 - env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2 - , le_subst = subst' - , le_env = foldl add_id id_env prs } - - ; return (env', vs2) } - where - zap :: Var -> Var - zap v | isId v = zap_join (zapIdDemandInfo v) - | otherwise = v - - zap_join | isTopLvl dest_lvl = zapJoinId - | otherwise = \v -> v - -add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr) -add_id id_env (v, v1) - | isTyVar v = delVarEnv id_env v - | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1) - -{- -Note [Zapping the demand info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -VERY IMPORTANT: we must zap the demand info if the thing is going to -float out, because it may be less demanded than at its original -binding site. Eg - f :: Int -> Int - f x = let v = 3*4 in v+x -Here v is strict; but if we float v to top level, it isn't any more. - -Similarly, if we're floating a join point, it won't be one anymore, so we zap -join point information as well. --} diff --git a/simplCore/SimplCore.hs b/simplCore/SimplCore.hs deleted file mode 100644 --- a/simplCore/SimplCore.hs +++ /dev/null @@ -1,1061 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[SimplCore]{Driver for simplifying @Core@ programs} --} - -{-# LANGUAGE CPP #-} - -module SimplCore ( core2core, simplifyExpr ) where - -#include "HsVersions.h" - -import DynFlags -import CoreSyn -import HscTypes -import CSE ( cseProgram ) -import Rules ( mkRuleBase, unionRuleBase, - extendRuleBaseList, ruleCheckProgram, addRuleInfo, ) -import PprCore ( pprCoreBindings, pprCoreExpr ) -import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) -import IdInfo -import CoreStats ( coreBindsSize, coreBindsStats, exprSize ) -import CoreUtils ( mkTicks, stripTicksTop ) -import CoreLint ( endPass, lintPassResult, dumpPassResult, - lintAnnots ) -import Simplify ( simplTopBinds, simplExpr, simplRules ) -import SimplUtils ( simplEnvForGHCi, activeRule ) -import SimplEnv -import SimplMonad -import CoreMonad -import qualified ErrUtils as Err -import FloatIn ( floatInwards ) -import FloatOut ( floatOutwards ) -import FamInstEnv -import Id -import ErrUtils ( withTiming ) -import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma ) -import VarSet -import VarEnv -import LiberateCase ( liberateCase ) -import SAT ( doStaticArgs ) -import Specialise ( specProgram) -import SpecConstr ( specConstrProgram) -import DmdAnal ( dmdAnalProgram ) -import CallArity ( callArityAnalProgram ) -import WorkWrap ( wwTopBinds ) -import Vectorise ( vectorise ) -import SrcLoc -import Util -import Module - -import Maybes -import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) -import UniqFM -import Outputable -import Control.Monad -import qualified GHC.LanguageExtensions as LangExt - -#ifdef GHCI -import DynamicLoading ( loadPlugins ) -import Plugins ( installCoreToDos ) -#else -import DynamicLoading ( pluginError ) -#endif - -{- -************************************************************************ -* * -\subsection{The driver for the simplifier} -* * -************************************************************************ --} - -core2core :: HscEnv -> ModGuts -> IO ModGuts -core2core hsc_env guts@(ModGuts { mg_module = mod - , mg_loc = loc - , mg_deps = deps - , mg_rdr_env = rdr_env }) - = do { us <- mkSplitUniqSupply 's' - -- make sure all plugins are loaded - - ; let builtin_passes = getCoreToDo dflags - orph_mods = mkModuleSet (mod : dep_orphs deps) - ; - ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod - orph_mods print_unqual loc $ - do { all_passes <- addPluginPasses builtin_passes - ; runCorePasses all_passes guts } - - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats - "Grand total simplifier statistics" - (pprSimplCount stats) - - ; return guts2 } - where - dflags = hsc_dflags hsc_env - home_pkg_rules = hptRules hsc_env (dep_mods deps) - hpt_rule_base = mkRuleBase home_pkg_rules - print_unqual = mkPrintUnqualified dflags rdr_env - -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. - -- This is very convienent for the users of the monad (e.g. plugins do not have to - -- consume the ModGuts to find the module) but somewhat ugly because mg_module may - -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which - -- would mean our cached value would go out of date. - -{- -************************************************************************ -* * - Generating the main optimisation pipeline -* * -************************************************************************ --} - -getCoreToDo :: DynFlags -> [CoreToDo] -getCoreToDo dflags - = flatten_todos core_todo - where - opt_level = optLevel dflags - phases = simplPhases dflags - max_iter = maxSimplIterations dflags - rule_check = ruleCheck dflags - call_arity = gopt Opt_CallArity dflags - strictness = gopt Opt_Strictness dflags - full_laziness = gopt Opt_FullLaziness dflags - do_specialise = gopt Opt_Specialise dflags - do_float_in = gopt Opt_FloatIn dflags - cse = gopt Opt_CSE dflags - spec_constr = gopt Opt_SpecConstr dflags - liberate_case = gopt Opt_LiberateCase dflags - late_dmd_anal = gopt Opt_LateDmdAnal dflags - static_args = gopt Opt_StaticArgumentTransformation dflags - rules_on = gopt Opt_EnableRewriteRules dflags - eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags - ww_on = gopt Opt_WorkerWrapper dflags - vectorise_on = gopt Opt_Vectorise dflags - static_ptrs = xopt LangExt.StaticPointers dflags - - maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) - - maybe_strictness_before phase - = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness - - base_mode = SimplMode { sm_phase = panic "base_mode" - , sm_names = [] - , sm_rules = rules_on - , sm_eta_expand = eta_expand_on - , sm_inline = True - , sm_case_case = True } - - simpl_phase phase names iter - = CoreDoPasses - $ [ maybe_strictness_before phase - , CoreDoSimplify iter - (base_mode { sm_phase = Phase phase - , sm_names = names }) - - , maybe_rule_check (Phase phase) ] - - -- Vectorisation can introduce a fair few common sub expressions involving - -- DPH primitives. For example, see the Reverse test from dph-examples. - -- We need to eliminate these common sub expressions before their definitions - -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings, - -- so we also run simpl_gently to inline them. - ++ (if vectorise_on && phase == 3 - then [CoreCSE, simpl_gently] - else []) - - vectorisation - = runWhen vectorise_on $ - CoreDoPasses [ simpl_gently, CoreDoVectorisation ] - - -- By default, we have 2 phases before phase 0. - - -- Want to run with inline phase 2 after the specialiser to give - -- maximum chance for fusion to work before we inline build/augment - -- in phase 1. This made a difference in 'ansi' where an - -- overloaded function wasn't inlined till too late. - - -- Need phase 1 so that build/augment get - -- inlined. I found that spectral/hartel/genfft lost some useful - -- strictness in the function sumcode' if augment is not inlined - -- before strictness analysis runs - simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter - | phase <- [phases, phases-1 .. 1] ] - - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently = CoreDoSimplify max_iter - (base_mode { sm_phase = InitialPhase - , sm_names = ["Gentle"] - , sm_rules = rules_on -- Note [RULEs enabled in SimplGently] - , sm_inline = not vectorise_on - -- See Note [Inline in InitialPhase] - , sm_case_case = False }) - -- Don't do case-of-case transformations. - -- This makes full laziness work better - - strictness_pass = if ww_on - then [CoreDoStrictness,CoreDoWorkerWrapper] - else [CoreDoStrictness] - - - -- New demand analyser - demand_analyser = (CoreDoPasses ( - strictness_pass ++ - [simpl_phase 0 ["post-worker-wrapper"] max_iter] - )) - - -- Static forms are moved to the top level with the FloatOut pass. - -- See Note [Grand plan for static forms] in StaticPtrTable. - static_ptrs_float_outwards = - runWhen static_ptrs $ CoreDoPasses - [ simpl_gently -- Float Out can't handle type lets (sometimes created - -- by simpleOptPgm via mkParallelBindings) - , CoreDoFloatOutwards FloatOutSwitches - { floatOutLambdas = Just 0 - , floatOutConstants = True - , floatOutOverSatApps = False - , floatToTopLevelOnly = True - } - ] - - core_todo = - if opt_level == 0 then - [ vectorisation, - static_ptrs_float_outwards, - CoreDoSimplify max_iter - (base_mode { sm_phase = Phase 0 - , sm_names = ["Non-opt simplification"] }) - ] - - else {- opt_level >= 1 -} [ - - -- We want to do the static argument transform before full laziness as it - -- may expose extra opportunities to float things outwards. However, to fix - -- up the output of the transformation we need at do at least one simplify - -- after this before anything else - runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), - - -- We run vectorisation here for now, but we might also try to run - -- it later - vectorisation, - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently, - - -- Specialisation is best done before full laziness - -- so that overloaded functions have all their dictionary lambdas manifest - runWhen do_specialise CoreDoSpecialising, - - if full_laziness then - CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = Just 0, - floatOutConstants = True, - floatOutOverSatApps = False, - floatToTopLevelOnly = False } - -- Was: gentleFloatOutSwitches - -- - -- I have no idea why, but not floating constants to - -- top level is very bad in some cases. - -- - -- Notably: p_ident in spectral/rewrite - -- Changing from "gentle" to "constantsOnly" - -- improved rewrite's allocation by 19%, and - -- made 0.0% difference to any other nofib - -- benchmark - -- - -- Not doing floatOutOverSatApps yet, we'll do - -- that later on when we've had a chance to get more - -- accurate arity information. In fact it makes no - -- difference at all to performance if we do it here, - -- but maybe we save some unnecessary to-and-fro in - -- the simplifier. - else - -- Even with full laziness turned off, we still need to float static - -- forms to the top level. See Note [Grand plan for static forms] in - -- StaticPtrTable. - static_ptrs_float_outwards, - - simpl_phases, - - -- Phase 0: allow all Ids to be inlined now - -- This gets foldr inlined before strictness analysis - - -- At least 3 iterations because otherwise we land up with - -- huge dead expressions because of an infelicity in the - -- simpifier. - -- let k = BIG in foldr k z xs - -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs - -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs - -- Don't stop now! - simpl_phase 0 ["main"] (max max_iter 3), - - runWhen do_float_in CoreDoFloatInwards, - -- Run float-inwards immediately before the strictness analyser - -- Doing so pushes bindings nearer their use site and hence makes - -- them more likely to be strict. These bindings might only show - -- up after the inlining from simplification. Example in fulsom, - -- Csg.calc, where an arg of timesDouble thereby becomes strict. - - runWhen call_arity $ CoreDoPasses - [ CoreDoCallArity - , simpl_phase 0 ["post-call-arity"] max_iter - ], - - runWhen strictness demand_analyser, - - runWhen full_laziness $ - CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = floatLamArgs dflags, - floatOutConstants = True, - floatOutOverSatApps = True, - floatToTopLevelOnly = False }, - -- nofib/spectral/hartel/wang doubles in speed if you - -- do full laziness late in the day. It only happens - -- after fusion and other stuff, so the early pass doesn't - -- catch it. For the record, the redex is - -- f_el22 (f_el21 r_midblock) - - - runWhen cse CoreCSE, - -- We want CSE to follow the final full-laziness pass, because it may - -- succeed in commoning up things floated out by full laziness. - -- CSE used to rely on the no-shadowing invariant, but it doesn't any more - - runWhen do_float_in CoreDoFloatInwards, - - maybe_rule_check (Phase 0), - - -- Case-liberation for -O2. This should be after - -- strictness analysis and the simplification which follows it. - runWhen liberate_case (CoreDoPasses [ - CoreLiberateCase, - simpl_phase 0 ["post-liberate-case"] max_iter - ]), -- Run the simplifier after LiberateCase to vastly - -- reduce the possibility of shadowing - -- Reason: see Note [Shadowing] in SpecConstr.hs - - runWhen spec_constr CoreDoSpecConstr, - - maybe_rule_check (Phase 0), - - -- Final clean-up simplification: - simpl_phase 0 ["final"] max_iter, - - runWhen late_dmd_anal $ CoreDoPasses ( - strictness_pass ++ - [simpl_phase 0 ["post-late-ww"] max_iter] - ), - - -- Final run of the demand_analyser, ensures that one-shot thunks are - -- really really one-shot thunks. Only needed if the demand analyser - -- has run at all. See Note [Final Demand Analyser run] in DmdAnal - -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution - -- can become /exponentially/ more expensive. See Trac #11731, #12996. - runWhen (strictness || late_dmd_anal) CoreDoStrictness, - - maybe_rule_check (Phase 0) - ] - - -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity. - flatten_todos [] = [] - flatten_todos (CoreDoNothing : rest) = flatten_todos rest - flatten_todos (CoreDoPasses passes : rest) = - flatten_todos passes ++ flatten_todos rest - flatten_todos (todo : rest) = todo : flatten_todos rest - --- Loading plugins - -addPluginPasses :: [CoreToDo] -> CoreM [CoreToDo] -#ifndef GHCI -addPluginPasses builtin_passes - = do { dflags <- getDynFlags - ; let pluginMods = pluginModNames dflags - ; unless (null pluginMods) (pluginError pluginMods) - ; return builtin_passes } -#else -addPluginPasses builtin_passes - = do { hsc_env <- getHscEnv - ; named_plugins <- liftIO (loadPlugins hsc_env) - ; foldM query_plug builtin_passes named_plugins } - where - query_plug todos (_, plug, options) = installCoreToDos plug options todos -#endif - -{- Note [Inline in InitialPhase] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is -confusing for users because when they say INLINE they expect the function to inline -right away. - -So now we do inlining immediately, even in the InitialPhase, assuming that the -Id's Activation allows it. - -This is a surprisingly big deal. Compiler performance improved a lot -when I made this change: - - perf/compiler/T5837.run T5837 [stat too good] (normal) - perf/compiler/parsing001.run parsing001 [stat too good] (normal) - perf/compiler/T12234.run T12234 [stat too good] (optasm) - perf/compiler/T9020.run T9020 [stat too good] (optasm) - perf/compiler/T3064.run T3064 [stat too good] (normal) - perf/compiler/T9961.run T9961 [stat too good] (normal) - perf/compiler/T13056.run T13056 [stat too good] (optasm) - perf/compiler/T9872d.run T9872d [stat too good] (normal) - perf/compiler/T783.run T783 [stat too good] (normal) - perf/compiler/T12227.run T12227 [stat too good] (normal) - perf/should_run/lazy-bs-alloc.run lazy-bs-alloc [stat too good] (normal) - perf/compiler/T1969.run T1969 [stat too good] (normal) - perf/compiler/T9872a.run T9872a [stat too good] (normal) - perf/compiler/T9872c.run T9872c [stat too good] (normal) - perf/compiler/T9872b.run T9872b [stat too good] (normal) - perf/compiler/T9872d.run T9872d [stat too good] (normal) - -Note [RULEs enabled in SimplGently] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -RULES are enabled when doing "gentle" simplification. Two reasons: - - * We really want the class-op cancellation to happen: - op (df d1 d2) --> $cop3 d1 d2 - because this breaks the mutual recursion between 'op' and 'df' - - * I wanted the RULE - lift String ===> ... - to work in Template Haskell when simplifying - splices, so we get simpler code for literal strings - -But watch out: list fusion can prevent floating. So use phase control -to switch off those rules until after floating. - -************************************************************************ -* * - The CoreToDo interpreter -* * -************************************************************************ --} - -runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts -runCorePasses passes guts - = foldM do_pass guts passes - where - do_pass guts CoreDoNothing = return guts - do_pass guts (CoreDoPasses ps) = runCorePasses ps guts - do_pass guts pass - = withTiming getDynFlags - (ppr pass <+> brackets (ppr mod)) - (const ()) $ do - { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts - ; endPass pass (mg_binds guts') (mg_rules guts') - ; return guts' } - - mod = mg_module guts - -doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts -doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} - simplifyPgm pass - -doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} - doPass cseProgram - -doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} - doPassD liberateCase - -doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} - floatInwards - -doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} - doPassDUM (floatOutwards f) - -doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} - doPassU doStaticArgs - -doCorePass CoreDoCallArity = {-# SCC "CallArity" #-} - doPassD callArityAnalProgram - -doCorePass CoreDoStrictness = {-# SCC "NewStranal" #-} - doPassDFM dmdAnalProgram - -doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} - doPassDFU wwTopBinds - -doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} - specProgram - -doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} - specConstrProgram - -doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} - vectorise - -doCorePass CoreDoPrintCore = observe printCore -doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat -doCorePass CoreDoNothing = return -doCorePass (CoreDoPasses passes) = runCorePasses passes - -#ifdef GHCI -doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass -#endif - -doCorePass pass = pprPanic "doCorePass" (ppr pass) - -{- -************************************************************************ -* * -\subsection{Core pass combinators} -* * -************************************************************************ --} - -printCore :: DynFlags -> CoreProgram -> IO () -printCore dflags binds - = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds) - -ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts -ruleCheckPass current_phase pat guts = - withTiming getDynFlags - (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) - (const ()) $ do - { rb <- getRuleBase - ; dflags <- getDynFlags - ; vis_orphs <- getVisibleOrphanMods - ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) - (ruleCheckProgram current_phase pat - (RuleEnv rb vis_orphs) (mg_binds guts)) - ; return guts } - -doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDUM do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - us <- getUniqueSupplyM - liftIO $ do_pass dflags us binds - -doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags)) - -doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags) - -doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us) - -doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassU do_pass = doPassDU (const do_pass) - -doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFM do_pass guts = do - dflags <- getDynFlags - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPassM (liftIO . do_pass dflags fam_envs) guts - -doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFU do_pass guts = do - dflags <- getDynFlags - us <- getUniqueSupplyM - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPass (do_pass dflags fam_envs us) guts - --- Most passes return no stats and don't change rules: these combinators --- let us lift them to the full blown ModGuts+CoreM world -doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts -doPassM bind_f guts = do - binds' <- bind_f (mg_binds guts) - return (guts { mg_binds = binds' }) - -doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } - --- Observer passes just peek; don't modify the bindings at all -observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts -observe do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - _ <- liftIO $ do_pass dflags binds - return binds - -{- -************************************************************************ -* * - Gentle simplification -* * -************************************************************************ --} - -simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do - -> CoreExpr - -> IO CoreExpr --- simplifyExpr is called by the driver to simplify an --- expression typed in at the interactive prompt --- --- Also used by Template Haskell -simplifyExpr dflags expr - = withTiming (pure dflags) (text "Simplify [expr]") (const ()) $ - do { - ; us <- mkSplitUniqSupply 's' - - ; let sz = exprSize expr - - ; (expr', counts) <- initSmpl dflags emptyRuleEnv - emptyFamInstEnvs us sz - (simplExprGently (simplEnvForGHCi dflags) expr) - - ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags) - "Simplifier statistics" (pprSimplCount counts) - - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" - (pprCoreExpr expr') - - ; return expr' - } - -simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr --- Simplifies an expression --- does occurrence analysis, then simplification --- and repeats (twice currently) because one pass --- alone leaves tons of crud. --- Used (a) for user expressions typed in at the interactive prompt --- (b) the LHS and RHS of a RULE --- (c) Template Haskell splices --- --- The name 'Gently' suggests that the SimplifierMode is SimplGently, --- and in fact that is so.... but the 'Gently' in simplExprGently doesn't --- enforce that; it just simplifies the expression twice - --- It's important that simplExprGently does eta reduction; see --- Note [Simplifying the left-hand side of a RULE] above. The --- simplifier does indeed do eta reduction (it's in Simplify.completeLam) --- but only if -O is on. - -simplExprGently env expr = do - expr1 <- simplExpr env (occurAnalyseExpr expr) - simplExpr env (occurAnalyseExpr expr1) - -{- -************************************************************************ -* * -\subsection{The driver for the simplifier} -* * -************************************************************************ --} - -simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts -simplifyPgm pass guts - = do { hsc_env <- getHscEnv - ; us <- getUniqueSupplyM - ; rb <- getRuleBase - ; liftIOWithCount $ - simplifyPgmIO pass hsc_env us rb guts } - -simplifyPgmIO :: CoreToDo - -> HscEnv - -> UniqSupply - -> RuleBase - -> ModGuts - -> IO (SimplCount, ModGuts) -- New bindings - -simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) - hsc_env us hpt_rule_base - guts@(ModGuts { mg_module = this_mod - , mg_rdr_env = rdr_env - , mg_deps = deps - , mg_binds = binds, mg_rules = rules - , mg_fam_inst_env = fam_inst_env }) - = do { (termination_msg, it_count, counts_out, guts') - <- do_iteration us 1 [] binds rules - - ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags && - dopt Opt_D_dump_simpl_stats dflags) - "Simplifier statistics for following pass" - (vcat [text termination_msg <+> text "after" <+> ppr it_count - <+> text "iterations", - blankLine, - pprSimplCount counts_out]) - - ; return (counts_out, guts') - } - where - dflags = hsc_dflags hsc_env - print_unqual = mkPrintUnqualified dflags rdr_env - simpl_env = mkSimplEnv mode - active_rule = activeRule simpl_env - - do_iteration :: UniqSupply - -> Int -- Counts iterations - -> [SimplCount] -- Counts from earlier iterations, reversed - -> CoreProgram -- Bindings in - -> [CoreRule] -- and orphan rules - -> IO (String, Int, SimplCount, ModGuts) - - do_iteration us iteration_no counts_so_far binds rules - -- iteration_no is the number of the iteration we are - -- about to begin, with '1' for the first - | iteration_no > max_iterations -- Stop if we've run out of iterations - = WARN( debugIsOn && (max_iterations > 2) - , hang (text "Simplifier bailing out after" <+> int max_iterations - <+> text "iterations" - <+> (brackets $ hsep $ punctuate comma $ - map (int . simplCountN) (reverse counts_so_far))) - 2 (text "Size =" <+> ppr (coreBindsStats binds))) - - -- Subtract 1 from iteration_no to get the - -- number of iterations we actually completed - return ( "Simplifier baled out", iteration_no - 1 - , totalise counts_so_far - , guts { mg_binds = binds, mg_rules = rules } ) - - -- Try and force thunks off the binds; significantly reduces - -- space usage, especially with -O. JRS, 000620. - | let sz = coreBindsSize binds - , () <- sz `seq` () -- Force it - = do { - -- Occurrence analysis - let { -- Note [Vectorisation declarations and occurrences] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure - -- that the right-hand sides of vectorisation declarations are taken into - -- account during occurrence analysis. After the 'InitialPhase', we need to ensure - -- that the binders representing variable vectorisation declarations are kept alive. - -- (In contrast to automatically vectorised variables, their unvectorised versions - -- don't depend on them.) - vectVars = mkVarSet $ - catMaybes [ fmap snd $ lookupDVarEnv (vectInfoVar (mg_vect_info guts)) bndr - | Vect bndr _ <- mg_vect_decls guts] - ++ - catMaybes [ fmap snd $ lookupDVarEnv (vectInfoVar (mg_vect_info guts)) bndr - | bndr <- bindersOfBinds binds] - -- FIXME: This second comprehensions is only needed as long as we - -- have vectorised bindings where we get "Could NOT call - -- vectorised from original version". - ; (maybeVects, maybeVectVars) - = case sm_phase mode of - InitialPhase -> (mg_vect_decls guts, vectVars) - _ -> ([], vectVars) - ; tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm this_mod active_rule rules - maybeVects maybeVectVars binds - } ; - Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" - (pprCoreBindings tagged_binds); - - -- Get any new rules, and extend the rule base - -- See Note [Overall plumbing for rules] in Rules.hs - -- We need to do this regularly, because simplification can - -- poke on IdInfo thunks, which in turn brings in new rules - -- behind the scenes. Otherwise there's a danger we'll simply - -- miss the rules for Ids hidden inside imported inlinings - eps <- hscEPS hsc_env ; - let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) - ; rule_base2 = extendRuleBaseList rule_base1 rules - ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) - ; vis_orphs = this_mod : dep_orphs deps } ; - - -- Simplify the program - ((binds1, rules1), counts1) <- - initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $ - do { env1 <- {-# SCC "SimplTopBinds" #-} - simplTopBinds simpl_env tagged_binds - - -- Apply the substitution to rules defined in this module - -- for imported Ids. Eg RULE map my_f = blah - -- If we have a substitution my_f :-> other_f, we'd better - -- apply it to the rule to, or it'll never match - ; rules1 <- simplRules env1 Nothing rules - - ; return (getFloatBinds env1, rules1) } ; - - -- Stop if nothing happened; don't dump output - if isZeroSimplCount counts1 then - return ( "Simplifier reached fixed point", iteration_no - , totalise (counts1 : counts_so_far) -- Include "free" ticks - , guts { mg_binds = binds1, mg_rules = rules1 } ) - else do { - -- Short out indirections - -- We do this *after* at least one run of the simplifier - -- because indirection-shorting uses the export flag on *occurrences* - -- and that isn't guaranteed to be ok until after the first run propagates - -- stuff from the binding site to its occurrences - -- - -- ToDo: alas, this means that indirection-shorting does not happen at all - -- if the simplifier does nothing (not common, I know, but unsavoury) - let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; - - -- Dump the result of this iteration - dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ; - lintPassResult hsc_env pass binds2 ; - - -- Loop - do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 - } } - | otherwise = panic "do_iteration" - where - (us1, us2) = splitUniqSupply us - - -- Remember the counts_so_far are reversed - totalise :: [SimplCount] -> SimplCount - totalise = foldr (\c acc -> acc `plusSimplCount` c) - (zeroSimplCount dflags) - -simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" - -------------------- -dump_end_iteration :: DynFlags -> PrintUnqualified -> Int - -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration dflags print_unqual iteration_no counts binds rules - = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules - where - mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations - | otherwise = Nothing - -- Show details if Opt_D_dump_simpl_iterations is on - - hdr = text "Simplifier iteration=" <> int iteration_no - pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr - , pprSimplCount counts - , text "---- End of simplifier counts for" <+> hdr ] - -{- -************************************************************************ -* * - Shorting out indirections -* * -************************************************************************ - -If we have this: - - x_local = - ...bindings... - x_exported = x_local - -where x_exported is exported, and x_local is not, then we replace it with this: - - x_exported = - x_local = x_exported - ...bindings... - -Without this we never get rid of the x_exported = x_local thing. This -save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and -makes strictness information propagate better. This used to happen in -the final phase, but it's tidier to do it here. - -Note [Transferring IdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to propagage any useful IdInfo on x_local to x_exported. - -STRICTNESS: if we have done strictness analysis, we want the strictness info on -x_local to transfer to x_exported. Hence the copyIdInfo call. - -RULES: we want to *add* any RULES for x_local to x_exported. - - -Note [Messing up the exported Id's RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must be careful about discarding (obviously) or even merging the -RULES on the exported Id. The example that went bad on me at one stage -was this one: - - iterate :: (a -> a) -> a -> [a] - [Exported] - iterate = iterateList - - iterateFB c f x = x `c` iterateFB c f (f x) - iterateList f x = x : iterateList f (f x) - [Not exported] - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterateList - #-} - -This got shorted out to: - - iterateList :: (a -> a) -> a -> [a] - iterateList = iterate - - iterateFB c f x = x `c` iterateFB c f (f x) - iterate f x = x : iterate f (f x) - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterate - #-} - -And now we get an infinite loop in the rule system - iterate f x -> build (\cn -> iterateFB c f x) - -> iterateFB (:) f x - -> iterate f x - -Old "solution": - use rule switching-off pragmas to get rid - of iterateList in the first place - -But in principle the user *might* want rules that only apply to the Id -he says. And inline pragmas are similar - {-# NOINLINE f #-} - f = local - local = -Then we do not want to get rid of the NOINLINE. - -Hence hasShortableIdinfo. - - -Note [Rules and indirection-zapping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Problem: what if x_exported has a RULE that mentions something in ...bindings...? -Then the things mentioned can be out of scope! Solution - a) Make sure that in this pass the usage-info from x_exported is - available for ...bindings... - b) If there are any such RULES, rec-ify the entire top-level. - It'll get sorted out next time round - -Other remarks -~~~~~~~~~~~~~ -If more than one exported thing is equal to a local thing (i.e., the -local thing really is shared), then we do one only: -\begin{verbatim} - x_local = .... - x_exported1 = x_local - x_exported2 = x_local -==> - x_exported1 = .... - - x_exported2 = x_exported1 -\end{verbatim} - -We rely on prior eta reduction to simplify things like -\begin{verbatim} - x_exported = /\ tyvars -> x_local tyvars -==> - x_exported = x_local -\end{verbatim} -Hence,there's a possibility of leaving unchanged something like this: -\begin{verbatim} - x_local = .... - x_exported1 = x_local Int -\end{verbatim} -By the time we've thrown away the types in STG land this -could be eliminated. But I don't think it's very common -and it's dangerous to do this fiddling in STG land -because we might elminate a binding that's mentioned in the -unfolding for something. - -Note [Indirection zapping and ticks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Unfortunately this is another place where we need a special case for -ticks. The following happens quite regularly: - - x_local = - x_exported = tick x_local - -Which we want to become: - - x_exported = tick - -As it makes no sense to keep the tick and the expression on separate -bindings. Note however that that this might increase the ticks scoping -over the execution of x_local, so we can only do this for floatable -ticks. More often than not, other references will be unfoldings of -x_exported, and therefore carry the tick anyway. --} - -type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks - -shortOutIndirections :: CoreProgram -> CoreProgram -shortOutIndirections binds - | isEmptyVarEnv ind_env = binds - | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping] - | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff - where - ind_env = makeIndEnv binds - -- These exported Ids are the subjects of the indirection-elimination - exp_ids = map fst $ nonDetEltsUFM ind_env - -- It's OK to use nonDetEltsUFM here because we forget the ordering - -- by immediately converting to a set or check if all the elements - -- satisfy a predicate. - exp_id_set = mkVarSet exp_ids - no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids - binds' = concatMap zap binds - - zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] - zap (Rec pairs) = [Rec (concatMap zapPair pairs)] - - zapPair (bndr, rhs) - | bndr `elemVarSet` exp_id_set = [] - | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr - = [(transferIdInfo exp_id bndr, - mkTicks ticks rhs), - (bndr, Var exp_id)] - | otherwise = [(bndr,rhs)] - -makeIndEnv :: [CoreBind] -> IndEnv -makeIndEnv binds - = foldr add_bind emptyVarEnv binds - where - add_bind :: CoreBind -> IndEnv -> IndEnv - add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env - add_bind (Rec pairs) env = foldr add_pair env pairs - - add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv - add_pair (exported_id, exported) env - | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported - , shortMeOut env exported_id local_id - = extendVarEnv env local_id (exported_id, ticks) - add_pair _ env = env - ------------------ -shortMeOut :: IndEnv -> Id -> Id -> Bool -shortMeOut ind_env exported_id local_id --- The if-then-else stuff is just so I can get a pprTrace to see --- how often I don't get shorting out because of IdInfo stuff - = if isExportedId exported_id && -- Only if this is exported - - isLocalId local_id && -- Only if this one is defined in this - -- module, so that we *can* change its - -- binding to be the exported thing! - - not (isExportedId local_id) && -- Only if this one is not itself exported, - -- since the transformation will nuke it - - not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for - then - if hasShortableIdInfo exported_id - then True -- See Note [Messing up the exported Id's IdInfo] - else WARN( True, text "Not shorting out:" <+> ppr exported_id ) - False - else - False - ------------------ -hasShortableIdInfo :: Id -> Bool --- True if there is no user-attached IdInfo on exported_id, --- so we can safely discard it --- See Note [Messing up the exported Id's IdInfo] -hasShortableIdInfo id - = isEmptyRuleInfo (ruleInfo info) - && isDefaultInlinePragma (inlinePragInfo info) - && not (isStableUnfolding (unfoldingInfo info)) - where - info = idInfo id - ------------------ -transferIdInfo :: Id -> Id -> Id --- See Note [Transferring IdInfo] --- If we have --- lcl_id = e; exp_id = lcl_id --- and lcl_id has useful IdInfo, we don't want to discard it by going --- gbl_id = e; lcl_id = gbl_id --- Instead, transfer IdInfo from lcl_id to exp_id --- Overwriting, rather than merging, seems to work ok. -transferIdInfo exported_id local_id - = modifyIdInfo transfer exported_id - where - local_info = idInfo local_id - transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info - `setUnfoldingInfo` unfoldingInfo local_info - `setInlinePragInfo` inlinePragInfo local_info - `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info - new_info = setRuleInfoHead (idName exported_id) - (ruleInfo local_info) - -- Remember to set the function-name field of the - -- rules as we transfer them from one function to another diff --git a/simplCore/SimplEnv.hs b/simplCore/SimplEnv.hs deleted file mode 100644 --- a/simplCore/SimplEnv.hs +++ /dev/null @@ -1,838 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[SimplMonad]{The simplifier Monad} --} - -{-# LANGUAGE CPP #-} - -module SimplEnv ( - -- * The simplifier mode - setMode, getMode, updMode, - - -- * Environments - SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract - mkSimplEnv, extendIdSubst, - SimplEnv.extendTvSubst, SimplEnv.extendCvSubst, - zapSubstEnv, setSubstEnv, - getInScope, setInScopeAndZapFloats, - setInScopeSet, modifyInScope, addNewInScopeIds, - getSimplRules, - - -- * Substitution results - SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope, - isJoinIdInEnv_maybe, - - -- * Simplifying 'Id' binders - simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, - simplBinder, simplBinders, - substTy, substTyVar, getTCvSubst, - substCo, substCoVar, - - -- * Floats - Floats, emptyFloats, isEmptyFloats, - addNonRec, addFloats, extendFloats, - wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats, - doFloatFromRhs, getFloatBinds, - - JoinFloats, emptyJoinFloats, isEmptyJoinFloats, - wrapJoinFloats, zapJoinFloats, restoreJoinFloats, getJoinFloatBinds, - ) where - -#include "HsVersions.h" - -import SimplMonad -import CoreMonad ( SimplifierMode(..) ) -import CoreSyn -import CoreUtils -import Var -import VarEnv -import VarSet -import OrdList -import Id -import MkCore ( mkWildValBinder ) -import TysWiredIn -import qualified Type -import Type hiding ( substTy, substTyVar, substTyVarBndr ) -import qualified Coercion -import Coercion hiding ( substCo, substCoVar, substCoVarBndr ) -import BasicTypes -import MonadUtils -import Outputable -import Util -import UniqFM ( pprUniqFM ) - -import Data.List - -{- -************************************************************************ -* * -\subsubsection{The @SimplEnv@ type} -* * -************************************************************************ --} - -data SimplEnv - = SimplEnv { - ----------- Static part of the environment ----------- - -- Static in the sense of lexically scoped, - -- wrt the original expression - - seMode :: SimplifierMode, - - -- The current substitution - seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType - seCvSubst :: CvSubstEnv, -- InCoVar |--> OutCoercion - seIdSubst :: SimplIdSubst, -- InId |--> OutExpr - - ----------- Dynamic part of the environment ----------- - -- Dynamic in the sense of describing the setup where - -- the expression finally ends up - - -- The current set of in-scope variables - -- They are all OutVars, and all bound in this module - seInScope :: InScopeSet, -- OutVars only - -- Includes all variables bound by seFloats - seFloats :: Floats, - -- See Note [Simplifier floats] - seJoinFloats :: JoinFloats - -- Handled separately; they don't go very far - } - -type StaticEnv = SimplEnv -- Just the static part is relevant - -pprSimplEnv :: SimplEnv -> SDoc --- Used for debugging; selective -pprSimplEnv env - = vcat [text "TvSubst:" <+> ppr (seTvSubst env), - text "CvSubst:" <+> ppr (seCvSubst env), - text "IdSubst:" <+> id_subst_doc, - text "InScope:" <+> in_scope_vars_doc - ] - where - id_subst_doc = pprUniqFM ppr_id_subst (seIdSubst env) - ppr_id_subst (m_ar, sr) = arity_part <+> ppr sr - where arity_part = case m_ar of Just ar -> brackets $ - text "join" <+> int ar - Nothing -> empty - - in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env)) - (vcat . map ppr_one) - ppr_one v | isId v = ppr v <+> ppr (idUnfolding v) - | otherwise = ppr v - -type SimplIdSubst = IdEnv (Maybe JoinArity, SimplSR) -- IdId |--> OutExpr - -- See Note [Extending the Subst] in CoreSubst - -- See Note [Join arity in SimplIdSubst] - --- | A substitution result. -data SimplSR - = DoneEx OutExpr -- Completed term - | DoneId OutId -- Completed term variable - | ContEx TvSubstEnv -- A suspended substitution - CvSubstEnv - SimplIdSubst - InExpr - -instance Outputable SimplSR where - ppr (DoneEx e) = text "DoneEx" <+> ppr e - ppr (DoneId v) = text "DoneId" <+> ppr v - ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, - ppr (filter_env tv), ppr (filter_env id) -}] - -- where - -- fvs = exprFreeVars e - -- filter_env env = filterVarEnv_Directly keep env - -- keep uniq _ = uniq `elemUFM_Directly` fvs - -{- -Note [SimplEnv invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -seInScope: - The in-scope part of Subst includes *all* in-scope TyVars and Ids - The elements of the set may have better IdInfo than the - occurrences of in-scope Ids, and (more important) they will - have a correctly-substituted type. So we use a lookup in this - set to replace occurrences - - The Ids in the InScopeSet are replete with their Rules, - and as we gather info about the unfolding of an Id, we replace - it in the in-scope set. - - The in-scope set is actually a mapping OutVar -> OutVar, and - in case expressions we sometimes bind - -seIdSubst: - The substitution is *apply-once* only, because InIds and OutIds - can overlap. - For example, we generally omit mappings - a77 -> a77 - from the substitution, when we decide not to clone a77, but it's quite - legitimate to put the mapping in the substitution anyway. - - Furthermore, consider - let x = case k of I# x77 -> ... in - let y = case k of I# x77 -> ... in ... - and suppose the body is strict in both x and y. Then the simplifier - will pull the first (case k) to the top; so the second (case k) will - cancel out, mapping x77 to, well, x77! But one is an in-Id and the - other is an out-Id. - - Of course, the substitution *must* applied! Things in its domain - simply aren't necessarily bound in the result. - -* substId adds a binding (DoneId new_id) to the substitution if - the Id's unique has changed - - Note, though that the substitution isn't necessarily extended - if the type of the Id changes. Why not? Because of the next point: - -* We *always, always* finish by looking up in the in-scope set - any variable that doesn't get a DoneEx or DoneVar hit in the substitution. - Reason: so that we never finish up with a "old" Id in the result. - An old Id might point to an old unfolding and so on... which gives a space - leak. - - [The DoneEx and DoneVar hits map to "new" stuff.] - -* It follows that substExpr must not do a no-op if the substitution is empty. - substType is free to do so, however. - -* When we come to a let-binding (say) we generate new IdInfo, including an - unfolding, attach it to the binder, and add this newly adorned binder to - the in-scope set. So all subsequent occurrences of the binder will get - mapped to the full-adorned binder, which is also the one put in the - binding site. - -* The in-scope "set" usually maps x->x; we use it simply for its domain. - But sometimes we have two in-scope Ids that are synomyms, and should - map to the same target: x->x, y->x. Notably: - case y of x { ... } - That's why the "set" is actually a VarEnv Var - -Note [Join arity in SimplIdSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We have to remember which incoming variables are join points (the occurrences -may not be marked correctly yet; we're in change of propagating the change if -OccurAnal makes something a join point). Normally the in-scope set is where we -keep the latest information, but the in-scope set tracks only OutVars; if a -binding is unconditionally inlined, it never makes it into the in-scope set, -and we need to know at the occurrence site that the variable is a join point so -that we know to drop the context. Thus we remember which join points we're -substituting. Clumsily, finding whether an InVar is a join variable may require -looking in both the substitution *and* the in-scope set (see -'isJoinIdInEnv_maybe'). --} - -mkSimplEnv :: SimplifierMode -> SimplEnv -mkSimplEnv mode - = SimplEnv { seMode = mode - , seInScope = init_in_scope - , seFloats = emptyFloats - , seJoinFloats = emptyJoinFloats - , seTvSubst = emptyVarEnv - , seCvSubst = emptyVarEnv - , seIdSubst = emptyVarEnv } - -- The top level "enclosing CC" is "SUBSUMED". - -init_in_scope :: InScopeSet -init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy)) - -- See Note [WildCard binders] - -{- -Note [WildCard binders] -~~~~~~~~~~~~~~~~~~~~~~~ -The program to be simplified may have wild binders - case e of wild { p -> ... } -We want to *rename* them away, so that there are no -occurrences of 'wild-id' (with wildCardKey). The easy -way to do that is to start of with a representative -Id in the in-scope set - -There can be be *occurrences* of wild-id. For example, -MkCore.mkCoreApp transforms - e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } -This is ok provided 'wild' isn't free in 'e', and that's the delicate -thing. Generally, you want to run the simplifier to get rid of the -wild-ids before doing much else. - -It's a very dark corner of GHC. Maybe it should be cleaned up. --} - -getMode :: SimplEnv -> SimplifierMode -getMode env = seMode env - -setMode :: SimplifierMode -> SimplEnv -> SimplEnv -setMode mode env = env { seMode = mode } - -updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv -updMode upd env = env { seMode = upd (seMode env) } - ---------------------- -extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv -extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res - = ASSERT2( isId var && not (isCoVar var), ppr var ) - env { seIdSubst = extendVarEnv subst var (isJoinId_maybe var, res) } - -extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv -extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res - = ASSERT( isTyVar var ) - env {seTvSubst = extendVarEnv tsubst var res} - -extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv -extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co - = ASSERT( isCoVar var ) - env {seCvSubst = extendVarEnv csubst var co} - ---------------------- -getInScope :: SimplEnv -> InScopeSet -getInScope env = seInScope env - -setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv -setInScopeSet env in_scope = env {seInScope = in_scope} - -setInScopeAndZapFloats :: SimplEnv -> SimplEnv -> SimplEnv --- Set the in-scope set, and *zap* the floats -setInScopeAndZapFloats env env_with_scope - = env { seInScope = seInScope env_with_scope, - seFloats = emptyFloats, - seJoinFloats = emptyJoinFloats } - -setFloats :: SimplEnv -> SimplEnv -> SimplEnv --- Set the in-scope set *and* the floats -setFloats env env_with_floats - = env { seInScope = seInScope env_with_floats, - seFloats = seFloats env_with_floats, - seJoinFloats = seJoinFloats env_with_floats } - -restoreJoinFloats :: SimplEnv -> SimplEnv -> SimplEnv --- Put back floats previously zapped --- Unlike 'setFloats', does *not* update the in-scope set, since the right-hand --- env is assumed to be *older* -restoreJoinFloats env old_env - = env { seJoinFloats = seJoinFloats old_env } - -addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv - -- The new Ids are guaranteed to be freshly allocated -addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs - = env { seInScope = in_scope `extendInScopeSetList` vs, - seIdSubst = id_subst `delVarEnvList` vs } - -- Why delete? Consider - -- let x = a*b in (x, \x -> x+3) - -- We add [x |-> a*b] to the substitution, but we must - -- _delete_ it from the substitution when going inside - -- the (\x -> ...)! - -modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv --- The variable should already be in scope, but --- replace the existing version with this new one --- which has more information -modifyInScope env@(SimplEnv {seInScope = in_scope}) v - = env {seInScope = extendInScopeSet in_scope v} - ---------------------- -zapSubstEnv :: SimplEnv -> SimplEnv -zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} - -setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv -setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } - -mkContEx :: SimplEnv -> InExpr -> SimplSR -mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e - -{- -************************************************************************ -* * -\subsection{Floats} -* * -************************************************************************ - -Note [Simplifier floats] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The Floats is a bunch of bindings, classified by a FloatFlag. - -* All of them satisfy the let/app invariant - -Examples - - NonRec x (y:ys) FltLifted - Rec [(x,rhs)] FltLifted - - NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? - NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n - - NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge - -Can't happen: - NonRec x# (a /# b) -- Might fail; does not satisfy let/app - NonRec x# (f y) -- Might diverge; does not satisfy let/app --} - -data Floats = Floats (OrdList OutBind) FloatFlag - -- See Note [Simplifier floats] - -type JoinFloats = OrdList OutBind - -data FloatFlag - = FltLifted -- All bindings are lifted and lazy *or* - -- consist of a single primitive string literal - -- Hence ok to float to top level, or recursive - - | FltOkSpec -- All bindings are FltLifted *or* - -- strict (perhaps because unlifted, - -- perhaps because of a strict binder), - -- *and* ok-for-speculation - -- Hence ok to float out of the RHS - -- of a lazy non-recursive let binding - -- (but not to top level, or into a rec group) - - | FltCareful -- At least one binding is strict (or unlifted) - -- and not guaranteed cheap - -- Do not float these bindings out of a lazy let - -instance Outputable Floats where - ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds) - -instance Outputable FloatFlag where - ppr FltLifted = text "FltLifted" - ppr FltOkSpec = text "FltOkSpec" - ppr FltCareful = text "FltCareful" - -andFF :: FloatFlag -> FloatFlag -> FloatFlag -andFF FltCareful _ = FltCareful -andFF FltOkSpec FltCareful = FltCareful -andFF FltOkSpec _ = FltOkSpec -andFF FltLifted flt = flt - -doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool --- If you change this function look also at FloatIn.noFloatFromRhs -doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) - = not (isNilOL fs) && want_to_float && can_float - where - want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs - -- See Note [Float when cheap or expandable] - can_float = case ff of - FltLifted -> True - FltOkSpec -> isNotTopLevel lvl && isNonRec rec - FltCareful -> isNotTopLevel lvl && isNonRec rec && str - -{- -Note [Float when cheap or expandable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to float a let from a let if the residual RHS is - a) cheap, such as (\x. blah) - b) expandable, such as (f b) if f is CONLIKE -But there are - - cheap things that are not expandable (eg \x. expensive) - - expandable things that are not cheap (eg (f b) where b is CONLIKE) -so we must take the 'or' of the two. --} - -emptyFloats :: Floats -emptyFloats = Floats nilOL FltLifted - -emptyJoinFloats :: JoinFloats -emptyJoinFloats = nilOL - -unitFloat :: OutBind -> Floats --- This key function constructs a singleton float with the right form -unitFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind)) - Floats (unitOL bind) (flag bind) - where - flag (Rec {}) = FltLifted - flag (NonRec bndr rhs) - | not (isStrictId bndr) = FltLifted - | exprIsLiteralString rhs = FltLifted - -- String literals can be floated freely. - -- See Note [CoreSyn top-level string ltierals] in CoreSyn. - | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) - | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr ) - FltCareful - -- Unlifted binders can only be let-bound if exprOkForSpeculation holds - -unitJoinFloat :: OutBind -> JoinFloats -unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind)) - unitOL bind - -addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv --- Add a non-recursive binding and extend the in-scope set --- The latter is important; the binder may already be in the --- in-scope set (although it might also have been created with newId) --- but it may now have more IdInfo -addNonRec env id rhs - = id `seq` -- This seq forces the Id, and hence its IdInfo, - -- and hence any inner substitutions - env { seFloats = floats', - seJoinFloats = jfloats', - seInScope = extendInScopeSet (seInScope env) id } - where - bind = NonRec id rhs - - floats' | isJoinId id = seFloats env - | otherwise = seFloats env `addFlts` unitFloat bind - jfloats' | isJoinId id = seJoinFloats env `addJoinFlts` unitJoinFloat bind - | otherwise = seJoinFloats env - -extendFloats :: SimplEnv -> OutBind -> SimplEnv --- Add these bindings to the floats, and extend the in-scope env too -extendFloats env bind - = ASSERT(all (not . isJoinId) (bindersOf bind)) - env { seFloats = floats', - seJoinFloats = jfloats', - seInScope = extendInScopeSetList (seInScope env) bndrs } - where - bndrs = bindersOf bind - - floats' | isJoinBind bind = seFloats env - | otherwise = seFloats env `addFlts` unitFloat bind - jfloats' | isJoinBind bind = seJoinFloats env `addJoinFlts` - unitJoinFloat bind - | otherwise = seJoinFloats env - -addFloats :: SimplEnv -> SimplEnv -> SimplEnv --- Add the floats for env2 to env1; --- *plus* the in-scope set for env2, which is bigger --- than that for env1 -addFloats env1 env2 - = env1 {seFloats = seFloats env1 `addFlts` seFloats env2, - seJoinFloats = seJoinFloats env1 `addJoinFlts` seJoinFloats env2, - seInScope = seInScope env2 } - -addFlts :: Floats -> Floats -> Floats -addFlts (Floats bs1 l1) (Floats bs2 l2) - = Floats (bs1 `appOL` bs2) (l1 `andFF` l2) - -addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats -addJoinFlts = appOL - -zapFloats :: SimplEnv -> SimplEnv -zapFloats env = env { seFloats = emptyFloats - , seJoinFloats = emptyJoinFloats } - -zapJoinFloats :: SimplEnv -> SimplEnv -zapJoinFloats env = env { seJoinFloats = emptyJoinFloats } - -addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv --- Flattens the floats from env2 into a single Rec group, --- prepends the floats from env1, and puts the result back in env2 --- This is all very specific to the way recursive bindings are --- handled; see Simplify.simplRecBind -addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff - ,seJoinFloats = jbs }) - = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) - env2 {seFloats = seFloats env1 `addFlts` floats' - ,seJoinFloats = seJoinFloats env1 `addJoinFlts` jfloats'} - where - floats' | isNilOL bs = emptyFloats - | otherwise = unitFloat (Rec (flattenBinds (fromOL bs))) - jfloats' | isNilOL jbs = emptyJoinFloats - | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) - -wrapFloats :: SimplEnv -> OutExpr -> OutExpr --- Wrap the floats around the expression; they should all --- satisfy the let/app invariant, so mkLets should do the job just fine -wrapFloats env@(SimplEnv {seFloats = Floats bs _}) body - = foldrOL Let (wrapJoinFloats env body) bs - -- Note: Always safe to put the joins on the inside since the values - -- can't refer to them - -wrapJoinFloats :: SimplEnv -> OutExpr -> OutExpr -wrapJoinFloats (SimplEnv {seJoinFloats = jbs}) body - = foldrOL Let body jbs - -getFloatBinds :: SimplEnv -> [CoreBind] -getFloatBinds env@(SimplEnv {seFloats = Floats bs _}) - = fromOL bs ++ getJoinFloatBinds env - -getJoinFloatBinds :: SimplEnv -> [CoreBind] -getJoinFloatBinds (SimplEnv {seJoinFloats = jbs}) - = fromOL jbs - -isEmptyFloats :: SimplEnv -> Bool -isEmptyFloats env@(SimplEnv {seFloats = Floats bs _}) - = isNilOL bs && isEmptyJoinFloats env - -isEmptyJoinFloats :: SimplEnv -> Bool -isEmptyJoinFloats (SimplEnv {seJoinFloats = jbs}) - = isNilOL jbs - -mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv -mapFloats env@SimplEnv { seFloats = Floats fs ff, seJoinFloats = jfs } fun - = env { seFloats = Floats (mapOL app fs) ff - , seJoinFloats = mapOL app jfs } - where - app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' - app (Rec bs) = Rec (map fun bs) - -{- -************************************************************************ -* * - Substitution of Vars -* * -************************************************************************ - -Note [Global Ids in the substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We look up even a global (eg imported) Id in the substitution. Consider - case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } -The binder-swap in the occurrence analyser will add a binding -for a LocalId version of g (with the same unique though): - case X.g_34 of b { (a,b) -> let g_34 = b in - ... case X.g_34 of { (p,q) -> ...} ... } -So we want to look up the inner X.g_34 in the substitution, where we'll -find that it has been substituted by b. (Or conceivably cloned.) --} - -substId :: SimplEnv -> InId -> SimplSR --- Returns DoneEx only on a non-Var expression -substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v - = case snd <$> lookupVarEnv ids v of -- Note [Global Ids in the substitution] - Nothing -> DoneId (refineFromInScope in_scope v) - Just (DoneId v) -> DoneId (refineFromInScope in_scope v) - Just (DoneEx (Var v)) -> DoneId (refineFromInScope in_scope v) - Just res -> res -- DoneEx non-var, or ContEx - - -- Get the most up-to-date thing from the in-scope set - -- Even though it isn't in the substitution, it may be in - -- the in-scope set with better IdInfo - -isJoinIdInEnv_maybe :: SimplEnv -> InId -> Maybe JoinArity -isJoinIdInEnv_maybe (SimplEnv { seInScope = inScope, seIdSubst = ids }) v - | not (isLocalId v) = Nothing - | Just (m_ar, _) <- lookupVarEnv ids v = m_ar - | Just v' <- lookupInScope inScope v = isJoinId_maybe v' - | otherwise = WARN( True , ppr v ) - isJoinId_maybe v - -refineFromInScope :: InScopeSet -> Var -> Var -refineFromInScope in_scope v - | isLocalId v = case lookupInScope in_scope v of - Just v' -> v' - Nothing -> WARN( True, ppr v ) v -- This is an error! - | otherwise = v - -lookupRecBndr :: SimplEnv -> InId -> OutId --- Look up an Id which has been put into the envt by simplRecBndrs, --- but where we have not yet done its RHS -lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v - = case lookupVarEnv ids v of - Just (_, DoneId v) -> v - Just _ -> pprPanic "lookupRecBndr" (ppr v) - Nothing -> refineFromInScope in_scope v - -{- -************************************************************************ -* * -\section{Substituting an Id binder} -* * -************************************************************************ - - -These functions are in the monad only so that they can be made strict via seq. --} - -simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) -simplBinders env bndrs = mapAccumLM simplBinder env bndrs - -------------- -simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- Used for lambda and case-bound variables --- Clone Id if necessary, substitute type --- Return with IdInfo already substituted, but (fragile) occurrence info zapped --- The substitution is extended only if the variable is cloned, because --- we *don't* need to use it to track occurrence info. -simplBinder env bndr - | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr - ; seqTyVar tv `seq` return (env', tv) } - | otherwise = do { let (env', id) = substIdBndr Nothing env bndr - ; seqId id `seq` return (env', id) } - ---------------- -simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- A non-recursive let binder -simplNonRecBndr env id - = do { let (env1, id1) = substIdBndr Nothing env id - ; seqId id1 `seq` return (env1, id1) } - ---------------- -simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr - -> SimplM (SimplEnv, OutBndr) --- A non-recursive let binder for a join point; context being pushed inward may --- change the type -simplNonRecJoinBndr env res_ty id - = do { let (env1, id1) = substIdBndr (Just res_ty) env id - ; seqId id1 `seq` return (env1, id1) } - ---------------- -simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv --- Recursive let binders -simplRecBndrs env@(SimplEnv {}) ids - = ASSERT(all (not . isJoinId) ids) - do { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids - ; seqIds ids1 `seq` return env1 } - ---------------- -simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv --- Recursive let binders for join points; context being pushed inward may --- change types -simplRecJoinBndrs env@(SimplEnv {}) res_ty ids - = ASSERT(all isJoinId ids) - do { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids - ; seqIds ids1 `seq` return env1 } - ---------------- -substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr) --- Might be a coercion variable -substIdBndr new_res_ty env bndr - | isCoVar bndr = substCoVarBndr env bndr - | otherwise = substNonCoVarIdBndr new_res_ty env bndr - ---------------- -substNonCoVarIdBndr - :: Maybe OutType -- New result type, if a join binder - -> SimplEnv - -> InBndr -- Env and binder to transform - -> (SimplEnv, OutBndr) --- Clone Id if necessary, substitute its type --- Return an Id with its --- * Type substituted --- * UnfoldingInfo, Rules, WorkerInfo zapped --- * Fragile OccInfo (only) zapped: Note [Robust OccInfo] --- * Robust info, retained especially arity and demand info, --- so that they are available to occurrences that occur in an --- earlier binding of a letrec --- --- For the robust info, see Note [Arity robustness] --- --- Augment the substitution if the unique changed --- Extend the in-scope set with the new Id --- --- Similar to CoreSubst.substIdBndr, except that --- the type of id_subst differs --- all fragile info is zapped -substNonCoVarIdBndr new_res_ty - env@(SimplEnv { seInScope = in_scope - , seIdSubst = id_subst }) - old_id - = ASSERT2( not (isCoVar old_id), ppr old_id ) - (env { seInScope = in_scope `extendInScopeSet` new_id, - seIdSubst = new_subst }, new_id) - where - id1 = uniqAway in_scope old_id - id2 = substIdType env id1 - id3 | Just res_ty <- new_res_ty - = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2) - | otherwise - = id2 - new_id = zapFragileIdInfo id3 -- Zaps rules, worker-info, unfolding - -- and fragile OccInfo - - -- Extend the substitution if the unique has changed, - -- or there's some useful occurrence information - -- See the notes with substTyVarBndr for the delSubstEnv - new_subst | new_id /= old_id - = extendVarEnv id_subst old_id - (isJoinId_maybe new_id, DoneId new_id) - | otherwise - = delVarEnv id_subst old_id - ------------------------------------- -seqTyVar :: TyVar -> () -seqTyVar b = b `seq` () - -seqId :: Id -> () -seqId id = seqType (idType id) `seq` - idInfo id `seq` - () - -seqIds :: [Id] -> () -seqIds [] = () -seqIds (id:ids) = seqId id `seq` seqIds ids - -{- -Note [Arity robustness] -~~~~~~~~~~~~~~~~~~~~~~~ -We *do* transfer the arity from from the in_id of a let binding to the -out_id. This is important, so that the arity of an Id is visible in -its own RHS. For example: - f = \x. ....g (\y. f y).... -We can eta-reduce the arg to g, because f is a value. But that -needs to be visible. - -This interacts with the 'state hack' too: - f :: Bool -> IO Int - f = \x. case x of - True -> f y - False -> \s -> ... -Can we eta-expand f? Only if we see that f has arity 1, and then we -take advantage of the 'state hack' on the result of -(f y) :: State# -> (State#, Int) to expand the arity one more. - -There is a disadvantage though. Making the arity visible in the RHS -allows us to eta-reduce - f = \x -> f x -to - f = f -which technically is not sound. This is very much a corner case, so -I'm not worried about it. Another idea is to ensure that f's arity -never decreases; its arity started as 1, and we should never eta-reduce -below that. - - -Note [Robust OccInfo] -~~~~~~~~~~~~~~~~~~~~~ -It's important that we *do* retain the loop-breaker OccInfo, because -that's what stops the Id getting inlined infinitely, in the body of -the letrec. --} - - -{- -************************************************************************ -* * - Impedance matching to type substitution -* * -************************************************************************ --} - -getTCvSubst :: SimplEnv -> TCvSubst -getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env - , seCvSubst = cv_env }) - = mkTCvSubst in_scope (tv_env, cv_env) - -substTy :: SimplEnv -> Type -> Type -substTy env ty = Type.substTy (getTCvSubst env) ty - -substTyVar :: SimplEnv -> TyVar -> Type -substTyVar env tv = Type.substTyVar (getTCvSubst env) tv - -substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) -substTyVarBndr env tv - = case Type.substTyVarBndr (getTCvSubst env) tv of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') - -substCoVar :: SimplEnv -> CoVar -> Coercion -substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv - -substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) -substCoVarBndr env cv - = case Coercion.substCoVarBndr (getTCvSubst env) cv of - (TCvSubst in_scope' tv_env' cv_env', cv') - -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') - -substCo :: SimplEnv -> Coercion -> Coercion -substCo env co = Coercion.substCo (getTCvSubst env) co - ------------------- -substIdType :: SimplEnv -> Id -> Id -substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id - | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) - || noFreeVarsOfType old_ty - = id - | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty) - -- The tyCoVarsOfType is cheaper than it looks - -- because we cache the free tyvars of the type - -- in a Note in the id's type itself - where - old_ty = idType id diff --git a/simplCore/SimplMonad.hs b/simplCore/SimplMonad.hs deleted file mode 100644 --- a/simplCore/SimplMonad.hs +++ /dev/null @@ -1,218 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[SimplMonad]{The simplifier Monad} --} - -module SimplMonad ( - -- The monad - SimplM, - initSmpl, traceSmpl, - getSimplRules, getFamEnvs, - - -- Unique supply - MonadUnique(..), newId, - - -- Counting - SimplCount, tick, freeTick, checkedTick, - getSimplCount, zeroSimplCount, pprSimplCount, - plusSimplCount, isZeroSimplCount - ) where - -import Id ( Id, mkSysLocalOrCoVar ) -import Type ( Type ) -import FamInstEnv ( FamInstEnv ) -import CoreSyn ( RuleEnv(..) ) -import UniqSupply -import DynFlags -import CoreMonad -import Outputable -import FastString -import MonadUtils -import ErrUtils -import BasicTypes ( IntWithInf, treatZeroAsInf, mkIntWithInf ) -import Control.Monad ( when, liftM, ap ) - -{- -************************************************************************ -* * -\subsection{Monad plumbing} -* * -************************************************************************ - -For the simplifier monad, we want to {\em thread} a unique supply and a counter. -(Command-line switches move around through the explicitly-passed SimplEnv.) --} - -newtype SimplM result - = SM { unSM :: SimplTopEnv -- Envt that does not change much - -> UniqSupply -- We thread the unique supply because - -- constantly splitting it is rather expensive - -> SimplCount - -> IO (result, UniqSupply, SimplCount)} - -- we only need IO here for dump output - -data SimplTopEnv - = STE { st_flags :: DynFlags - , st_max_ticks :: IntWithInf -- Max #ticks in this simplifier run - , st_rules :: RuleEnv - , st_fams :: (FamInstEnv, FamInstEnv) } - -initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) - -> UniqSupply -- No init count; set to 0 - -> Int -- Size of the bindings, used to limit - -- the number of ticks we allow - -> SimplM a - -> IO (a, SimplCount) - -initSmpl dflags rules fam_envs us size m - = do (result, _, count) <- unSM m env us (zeroSimplCount dflags) - return (result, count) - where - env = STE { st_flags = dflags, st_rules = rules - , st_max_ticks = computeMaxTicks dflags size - , st_fams = fam_envs } - -computeMaxTicks :: DynFlags -> Int -> IntWithInf --- Compute the max simplifier ticks as --- (base-size + pgm-size) * magic-multiplier * tick-factor/100 --- where --- magic-multiplier is a constant that gives reasonable results --- base-size is a constant to deal with size-zero programs -computeMaxTicks dflags size - = treatZeroAsInf $ - fromInteger ((toInteger (size + base_size) - * toInteger (tick_factor * magic_multiplier)) - `div` 100) - where - tick_factor = simplTickFactor dflags - base_size = 100 - magic_multiplier = 40 - -- MAGIC NUMBER, multiplies the simplTickFactor - -- We can afford to be generous; this is really - -- just checking for loops, and shouldn't usually fire - -- A figure of 20 was too small: see Trac #5539. - -{-# INLINE thenSmpl #-} -{-# INLINE thenSmpl_ #-} -{-# INLINE returnSmpl #-} - - -instance Functor SimplM where - fmap = liftM - -instance Applicative SimplM where - pure = returnSmpl - (<*>) = ap - (*>) = thenSmpl_ - -instance Monad SimplM where - (>>) = (*>) - (>>=) = thenSmpl - -returnSmpl :: a -> SimplM a -returnSmpl e = SM (\_st_env us sc -> return (e, us, sc)) - -thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b -thenSmpl_ :: SimplM a -> SimplM b -> SimplM b - -thenSmpl m k - = SM $ \st_env us0 sc0 -> do - (m_result, us1, sc1) <- unSM m st_env us0 sc0 - unSM (k m_result) st_env us1 sc1 - -thenSmpl_ m k - = SM $ \st_env us0 sc0 -> do - (_, us1, sc1) <- unSM m st_env us0 sc0 - unSM k st_env us1 sc1 - --- TODO: this specializing is not allowed --- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-} --- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-} --- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-} - -traceSmpl :: String -> SDoc -> SimplM () -traceSmpl herald doc - = do { dflags <- getDynFlags - ; when (dopt Opt_D_dump_simpl_trace dflags) $ liftIO $ - printOutputForUser dflags alwaysQualify $ - hang (text herald) 2 doc } - -{- -************************************************************************ -* * -\subsection{The unique supply} -* * -************************************************************************ --} - -instance MonadUnique SimplM where - getUniqueSupplyM - = SM (\_st_env us sc -> case splitUniqSupply us of - (us1, us2) -> return (us1, us2, sc)) - - getUniqueM - = SM (\_st_env us sc -> case takeUniqFromSupply us of - (u, us') -> return (u, us', sc)) - - getUniquesM - = SM (\_st_env us sc -> case splitUniqSupply us of - (us1, us2) -> return (uniqsFromSupply us1, us2, sc)) - -instance HasDynFlags SimplM where - getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc)) - -instance MonadIO SimplM where - liftIO m = SM $ \_ us sc -> do - x <- m - return (x, us, sc) - -getSimplRules :: SimplM RuleEnv -getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc)) - -getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) -getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc)) - -newId :: FastString -> Type -> SimplM Id -newId fs ty = do uniq <- getUniqueM - return (mkSysLocalOrCoVar fs uniq ty) - -{- -************************************************************************ -* * -\subsection{Counting up what we've done} -* * -************************************************************************ --} - -getSimplCount :: SimplM SimplCount -getSimplCount = SM (\_st_env us sc -> return (sc, us, sc)) - -tick :: Tick -> SimplM () -tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), us, sc')) - -checkedTick :: Tick -> SimplM () --- Try to take a tick, but fail if too many -checkedTick t - = SM (\st_env us sc -> if st_max_ticks st_env <= mkIntWithInf (simplCountN sc) - then pprPanic "Simplifier ticks exhausted" (msg sc) - else let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), us, sc')) - where - msg sc = vcat [ text "When trying" <+> ppr t - , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)" - , text "If you need to do this, let GHC HQ know, and what factor you needed" - , pp_details sc - , pprSimplCount sc ] - pp_details sc - | hasDetailedCounts sc = empty - | otherwise = text "To see detailed counts use -ddump-simpl-stats" - - -freeTick :: Tick -> SimplM () --- Record a tick, but don't add to the total tick count, which is --- used to decide when nothing further has happened -freeTick t - = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc - in sc' `seq` return ((), us, sc')) diff --git a/simplCore/SimplUtils.hs b/simplCore/SimplUtils.hs deleted file mode 100644 --- a/simplCore/SimplUtils.hs +++ /dev/null @@ -1,2048 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[SimplUtils]{The simplifier utilities} --} - -{-# LANGUAGE CPP #-} - -module SimplUtils ( - -- Rebuilding - mkLam, mkCase, prepareAlts, tryEtaExpandRhs, - - -- Inlining, - preInlineUnconditionally, postInlineUnconditionally, - activeUnfolding, activeRule, - getUnfoldingInRuleMatch, - simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, - - -- The continuation type - SimplCont(..), DupFlag(..), - isSimplified, - contIsDupable, contResultType, contHoleType, - contIsTrivial, contArgs, - countArgs, - mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, - interestingCallContext, - - -- ArgInfo - ArgInfo(..), ArgSpec(..), mkArgInfo, - addValArgTo, addCastTo, addTyArgTo, - argInfoExpr, argInfoAppArgs, pushSimplifiedArgs, - - abstractFloats - ) where - -#include "HsVersions.h" - -import SimplEnv -import CoreMonad ( SimplifierMode(..), Tick(..) ) -import DynFlags -import CoreSyn -import qualified CoreSubst -import PprCore -import CoreFVs -import CoreUtils -import CoreArity -import CoreUnfold -import Name -import Id -import IdInfo -import Var -import Demand -import SimplMonad -import Type hiding( substTy ) -import Coercion hiding( substCo ) -import DataCon ( dataConWorkId ) -import VarEnv -import VarSet -import BasicTypes -import Util -import MonadUtils -import Outputable -import Pair -import PrelRules -import Literal - -import Control.Monad ( when ) -import Data.List ( sortBy ) - -{- -************************************************************************ -* * - The SimplCont and DupFlag types -* * -************************************************************************ - -A SimplCont allows the simplifier to traverse the expression in a -zipper-like fashion. The SimplCont represents the rest of the expression, -"above" the point of interest. - -You can also think of a SimplCont as an "evaluation context", using -that term in the way it is used for operational semantics. This is the -way I usually think of it, For example you'll often see a syntax for -evaluation context looking like - C ::= [] | C e | case C of alts | C `cast` co -That's the kind of thing we are doing here, and I use that syntax in -the comments. - - -Key points: - * A SimplCont describes a *strict* context (just like - evaluation contexts do). E.g. Just [] is not a SimplCont - - * A SimplCont describes a context that *does not* bind - any variables. E.g. \x. [] is not a SimplCont --} - -data SimplCont - = Stop -- An empty context, or - OutType -- Type of the - CallCtxt -- Tells if there is something interesting about - -- the context, and hence the inliner - -- should be a bit keener (see interestingCallContext) - -- Specifically: - -- This is an argument of a function that has RULES - -- Inlining the call might allow the rule to fire - -- Never ValAppCxt (use ApplyToVal instead) - -- or CaseCtxt (use Select instead) - - | CastIt -- `cast` co - OutCoercion -- The coercion simplified - -- Invariant: never an identity coercion - SimplCont - - | ApplyToVal { -- arg - sc_dup :: DupFlag, -- See Note [DupFlag invariants] - sc_arg :: InExpr, -- The argument, - sc_env :: StaticEnv, -- and its static env - sc_cont :: SimplCont } - - | ApplyToTy { -- ty - sc_arg_ty :: OutType, -- Argument type - sc_hole_ty :: OutType, -- Type of the function, presumably (forall a. blah) - -- See Note [The hole type in ApplyToTy] - sc_cont :: SimplCont } - - | Select { -- case of alts - sc_dup :: DupFlag, -- See Note [DupFlag invariants] - sc_bndr :: InId, -- case binder - sc_alts :: [InAlt], -- Alternatives - sc_env :: StaticEnv, -- and their static environment - sc_cont :: SimplCont } - - -- The two strict forms have no DupFlag, because we never duplicate them - | StrictBind -- (\x* \xs. e) - InId [InBndr] -- let x* = in e - InExpr StaticEnv -- is a special case - SimplCont - - | StrictArg -- f e1 ..en - ArgInfo -- Specifies f, e1..en, Whether f has rules, etc - -- plus strictness flags for *further* args - CallCtxt -- Whether *this* argument position is interesting - SimplCont - - | TickIt - (Tickish Id) -- Tick tickish - SimplCont - -data DupFlag = NoDup -- Unsimplified, might be big - | Simplified -- Simplified - | OkToDup -- Simplified and small - -isSimplified :: DupFlag -> Bool -isSimplified NoDup = False -isSimplified _ = True -- Invariant: the subst-env is empty - -perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type -perhapsSubstTy dup env ty - | isSimplified dup = ty - | otherwise = substTy env ty - -{- -Note [DupFlag invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~ -In both (ApplyToVal dup _ env k) - and (Select dup _ _ env k) -the following invariants hold - - (a) if dup = OkToDup, then continuation k is also ok-to-dup - (b) if dup = OkToDup or Simplified, the subst-env is empty - (and and hence no need to re-simplify) --} - -instance Outputable DupFlag where - ppr OkToDup = text "ok" - ppr NoDup = text "nodup" - ppr Simplified = text "simpl" - -instance Outputable SimplCont where - ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty - ppr (CastIt co cont ) = (text "CastIt" <+> pprOptCo co) $$ ppr cont - ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont - ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) - = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont - ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont }) - = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg) - $$ ppr cont - ppr (StrictBind b _ _ _ cont) = (text "StrictBind" <+> ppr b) $$ ppr cont - ppr (StrictArg ai _ cont) = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont - ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) - = (text "Select" <+> ppr dup <+> ppr bndr) $$ - ifPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont - - -{- Note [The hole type in ApplyToTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The sc_hole_ty field of ApplyToTy records the type of the "hole" in the -continuation. It is absolutely necessary to compute contHoleType, but it is -not used for anything else (and hence may not be evaluated). - -Why is it necessary for contHoleType? Consider the continuation - ApplyToType Int (Stop Int) -corresponding to - ( @Int) :: Int -What is the type of ? It could be (forall a. Int) or (forall a. a), -and there is no way to know which, so we must record it. - -In a chain of applications (f @t1 @t2 @t3) we'll lazily compute exprType -for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably -doesn't matter because we'll never compute them all. - -************************************************************************ -* * - ArgInfo and ArgSpec -* * -************************************************************************ --} - -data ArgInfo - = ArgInfo { - ai_fun :: OutId, -- The function - ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) - - ai_type :: OutType, -- Type of (f a1 ... an) - - ai_rules :: FunRules, -- Rules for this function - - ai_encl :: Bool, -- Flag saying whether this function - -- or an enclosing one has rules (recursively) - -- True => be keener to inline in all args - - ai_strs :: [Bool], -- Strictness of remaining arguments - -- Usually infinite, but if it is finite it guarantees - -- that the function diverges after being given - -- that number of args - ai_discs :: [Int] -- Discounts for remaining arguments; non-zero => be keener to inline - -- Always infinite - } - -data ArgSpec - = ValArg OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal - | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy - , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) - | CastBy OutCoercion -- Cast by this; c.f. CastIt - -instance Outputable ArgSpec where - ppr (ValArg e) = text "ValArg" <+> ppr e - ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty - ppr (CastBy c) = text "CastBy" <+> ppr c - -addValArgTo :: ArgInfo -> OutExpr -> ArgInfo -addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai - , ai_type = applyTypeToArg (ai_type ai) arg - , ai_rules = decRules (ai_rules ai) } - -addTyArgTo :: ArgInfo -> OutType -> ArgInfo -addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai - , ai_type = piResultTy poly_fun_ty arg_ty - , ai_rules = decRules (ai_rules ai) } - where - poly_fun_ty = ai_type ai - arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty } - -addCastTo :: ArgInfo -> OutCoercion -> ArgInfo -addCastTo ai co = ai { ai_args = CastBy co : ai_args ai - , ai_type = pSnd (coercionKind co) } - -argInfoAppArgs :: [ArgSpec] -> [OutExpr] -argInfoAppArgs [] = [] -argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast -argInfoAppArgs (ValArg e : as) = e : argInfoAppArgs as -argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as - -pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont -pushSimplifiedArgs _env [] k = k -pushSimplifiedArgs env (arg : args) k - = case arg of - TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } - -> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest } - ValArg e -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest } - CastBy c -> CastIt c rest - where - rest = pushSimplifiedArgs env args k - -- The env has an empty SubstEnv - -argInfoExpr :: OutId -> [ArgSpec] -> OutExpr --- NB: the [ArgSpec] is reversed so that the first arg --- in the list is the last one in the application -argInfoExpr fun rev_args - = go rev_args - where - go [] = Var fun - go (ValArg a : as) = go as `App` a - go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty - go (CastBy co : as) = mkCast (go as) co - - -type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function - -- Nothing => No rules - -- Just (n, rules) => some rules, requiring at least n more type/value args - -decRules :: FunRules -> FunRules -decRules (Just (n, rules)) = Just (n-1, rules) -decRules Nothing = Nothing - -mkFunRules :: [CoreRule] -> FunRules -mkFunRules [] = Nothing -mkFunRules rs = Just (n_required, rs) - where - n_required = maximum (map ruleArity rs) - -{- -************************************************************************ -* * - Functions on SimplCont -* * -************************************************************************ --} - -mkBoringStop :: OutType -> SimplCont -mkBoringStop ty = Stop ty BoringCtxt - -mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in CoreUnfold -mkRhsStop ty = Stop ty RhsCtxt - -mkLazyArgStop :: OutType -> CallCtxt -> SimplCont -mkLazyArgStop ty cci = Stop ty cci - -------------------- -contIsRhsOrArg :: SimplCont -> Bool -contIsRhsOrArg (Stop {}) = True -contIsRhsOrArg (StrictBind {}) = True -contIsRhsOrArg (StrictArg {}) = True -contIsRhsOrArg _ = False - -contIsRhs :: SimplCont -> Bool -contIsRhs (Stop _ RhsCtxt) = True -contIsRhs _ = False - -------------------- -contIsDupable :: SimplCont -> Bool -contIsDupable (Stop {}) = True -contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k -contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants] -contIsDupable (Select { sc_dup = OkToDup }) = True -- ...ditto... -contIsDupable (CastIt _ k) = contIsDupable k -contIsDupable _ = False - -------------------- -contIsTrivial :: SimplCont -> Bool -contIsTrivial (Stop {}) = True -contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k -contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k -contIsTrivial (CastIt _ k) = contIsTrivial k -contIsTrivial _ = False - -------------------- -contResultType :: SimplCont -> OutType -contResultType (Stop ty _) = ty -contResultType (CastIt _ k) = contResultType k -contResultType (StrictBind _ _ _ _ k) = contResultType k -contResultType (StrictArg _ _ k) = contResultType k -contResultType (Select { sc_cont = k }) = contResultType k -contResultType (ApplyToTy { sc_cont = k }) = contResultType k -contResultType (ApplyToVal { sc_cont = k }) = contResultType k -contResultType (TickIt _ k) = contResultType k - -contHoleType :: SimplCont -> OutType -contHoleType (Stop ty _) = ty -contHoleType (TickIt _ k) = contHoleType k -contHoleType (CastIt co _) = pFst (coercionKind co) -contHoleType (StrictBind b _ _ se _) = substTy se (idType b) -contHoleType (StrictArg ai _ _) = funArgTy (ai_type ai) -contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] -contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k }) - = mkFunTy (perhapsSubstTy dup se (exprType e)) - (contHoleType k) -contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) - = perhapsSubstTy d se (idType b) - -------------------- -countArgs :: SimplCont -> Int --- Count all arguments, including types, coercions, and other values -countArgs (ApplyToTy { sc_cont = cont }) = 1 + countArgs cont -countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont -countArgs _ = 0 - -contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) --- Summarises value args, discards type args and coercions --- The returned continuation of the call is only used to --- answer questions like "are you interesting?" -contArgs cont - | lone cont = (True, [], cont) - | otherwise = go [] cont - where - lone (ApplyToTy {}) = False -- See Note [Lone variables] in CoreUnfold - lone (ApplyToVal {}) = False - lone (CastIt {}) = False - lone _ = True - - go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) - = go (is_interesting arg se : args) k - go args (ApplyToTy { sc_cont = k }) = go args k - go args (CastIt _ k) = go args k - go args k = (False, reverse args, k) - - is_interesting arg se = interestingArg se arg - -- Do *not* use short-cutting substitution here - -- because we want to get as much IdInfo as possible - - -------------------- -mkArgInfo :: Id - -> [CoreRule] -- Rules for function - -> Int -- Number of value args - -> SimplCont -- Context of the call - -> ArgInfo - -mkArgInfo fun rules n_val_args call_cont - | n_val_args < idArity fun -- Note [Unsaturated functions] - = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty - , ai_rules = fun_rules, ai_encl = False - , ai_strs = vanilla_stricts - , ai_discs = vanilla_discounts } - | otherwise - = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty - , ai_rules = fun_rules - , ai_encl = interestingArgContext rules call_cont - , ai_strs = add_type_str fun_ty arg_stricts - , ai_discs = arg_discounts } - where - fun_ty = idType fun - - fun_rules = mkFunRules rules - - vanilla_discounts, arg_discounts :: [Int] - vanilla_discounts = repeat 0 - arg_discounts = case idUnfolding fun of - CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} - -> discounts ++ vanilla_discounts - _ -> vanilla_discounts - - vanilla_stricts, arg_stricts :: [Bool] - vanilla_stricts = repeat False - - arg_stricts - = case splitStrictSig (idStrictness fun) of - (demands, result_info) - | not (demands `lengthExceeds` n_val_args) - -> -- Enough args, use the strictness given. - -- For bottoming functions we used to pretend that the arg - -- is lazy, so that we don't treat the arg as an - -- interesting context. This avoids substituting - -- top-level bindings for (say) strings into - -- calls to error. But now we are more careful about - -- inlining lone variables, so its ok (see SimplUtils.analyseCont) - if isBotRes result_info then - map isStrictDmd demands -- Finite => result is bottom - else - map isStrictDmd demands ++ vanilla_stricts - | otherwise - -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun) - <+> ppr n_val_args <+> ppr demands ) - vanilla_stricts -- Not enough args, or no strictness - - add_type_str :: Type -> [Bool] -> [Bool] - -- If the function arg types are strict, record that in the 'strictness bits' - -- No need to instantiate because unboxed types (which dominate the strict - -- types) can't instantiate type variables. - -- add_type_str is done repeatedly (for each call); might be better - -- once-for-all in the function - -- But beware primops/datacons with no strictness - - add_type_str - = go - where - go _ [] = [] - go fun_ty strs -- Look through foralls - | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty -- Includes coercions - = go fun_ty' strs - go fun_ty (str:strs) -- Add strict-type info - | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty - = (str || Just False == isLiftedType_maybe arg_ty) : go fun_ty' strs - -- If the type is levity-polymorphic, we can't know whether it's - -- strict. isLiftedType_maybe will return Just False only when - -- we're sure the type is unlifted. - go _ strs - = strs - -{- Note [Unsaturated functions] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (test eyeball/inline4) - x = a:as - y = f x -where f has arity 2. Then we do not want to inline 'x', because -it'll just be floated out again. Even if f has lots of discounts -on its first argument -- it must be saturated for these to kick in --} - - -{- -************************************************************************ -* * - Interesting arguments -* * -************************************************************************ - -Note [Interesting call context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to avoid inlining an expression where there can't possibly be -any gain, such as in an argument position. Hence, if the continuation -is interesting (eg. a case scrutinee, application etc.) then we -inline, otherwise we don't. - -Previously some_benefit used to return True only if the variable was -applied to some value arguments. This didn't work: - - let x = _coerce_ (T Int) Int (I# 3) in - case _coerce_ Int (T Int) x of - I# y -> .... - -we want to inline x, but can't see that it's a constructor in a case -scrutinee position, and some_benefit is False. - -Another example: - -dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) - -.... case dMonadST _@_ x0 of (a,b,c) -> .... - -we'd really like to inline dMonadST here, but we *don't* want to -inline if the case expression is just - - case x of y { DEFAULT -> ... } - -since we can just eliminate this case instead (x is in WHNF). Similar -applies when x is bound to a lambda expression. Hence -contIsInteresting looks for case expressions with just a single -default case. --} - -interestingCallContext :: SimplCont -> CallCtxt --- See Note [Interesting call context] -interestingCallContext cont - = interesting cont - where - interesting (Select {}) = CaseCtxt - interesting (ApplyToVal {}) = ValAppCtxt - -- Can happen if we have (f Int |> co) y - -- If f has an INLINE prag we need to give it some - -- motivation to inline. See Note [Cast then apply] - -- in CoreUnfold - - interesting (StrictArg _ BoringCtxt _) = RhsCtxt - interesting (StrictArg _ cci _) = cci - interesting (StrictBind {}) = BoringCtxt - interesting (Stop _ cci) = cci - interesting (TickIt _ k) = interesting k - interesting (ApplyToTy { sc_cont = k }) = interesting k - interesting (CastIt _ k) = interesting k - -- If this call is the arg of a strict function, the context - -- is a bit interesting. If we inline here, we may get useful - -- evaluation information to avoid repeated evals: e.g. - -- x + (y * z) - -- Here the contIsInteresting makes the '*' keener to inline, - -- which in turn exposes a constructor which makes the '+' inline. - -- Assuming that +,* aren't small enough to inline regardless. - -- - -- It's also very important to inline in a strict context for things - -- like - -- foldr k z (f x) - -- Here, the context of (f x) is strict, and if f's unfolding is - -- a build it's *great* to inline it here. So we must ensure that - -- the context for (f x) is not totally uninteresting. - -interestingArgContext :: [CoreRule] -> SimplCont -> Bool --- If the argument has form (f x y), where x,y are boring, --- and f is marked INLINE, then we don't want to inline f. --- But if the context of the argument is --- g (f x y) --- where g has rules, then we *do* want to inline f, in case it --- exposes a rule that might fire. Similarly, if the context is --- h (g (f x x)) --- where h has rules, then we do want to inline f; hence the --- call_cont argument to interestingArgContext --- --- The ai-rules flag makes this happen; if it's --- set, the inliner gets just enough keener to inline f --- regardless of how boring f's arguments are, if it's marked INLINE --- --- The alternative would be to *always* inline an INLINE function, --- regardless of how boring its context is; but that seems overkill --- For example, it'd mean that wrapper functions were always inlined --- --- The call_cont passed to interestingArgContext is the context of --- the call itself, e.g. g in the example above -interestingArgContext rules call_cont - = notNull rules || enclosing_fn_has_rules - where - enclosing_fn_has_rules = go call_cont - - go (Select {}) = False - go (ApplyToVal {}) = False -- Shouldn't really happen - go (ApplyToTy {}) = False -- Ditto - go (StrictArg _ cci _) = interesting cci - go (StrictBind {}) = False -- ?? - go (CastIt _ c) = go c - go (Stop _ cci) = interesting cci - go (TickIt _ c) = go c - - interesting RuleArgCtxt = True - interesting _ = False - - -{- Note [Interesting arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An argument is interesting if it deserves a discount for unfoldings -with a discount in that argument position. The idea is to avoid -unfolding a function that is applied only to variables that have no -unfolding (i.e. they are probably lambda bound): f x y z There is -little point in inlining f here. - -Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But -we must look through lets, eg (let x = e in C a b), because the let will -float, exposing the value, if we inline. That makes it different to -exprIsHNF. - -Before 2009 we said it was interesting if the argument had *any* structure -at all; i.e. (hasSomeUnfolding v). But does too much inlining; see Trac #3016. - -But we don't regard (f x y) as interesting, unless f is unsaturated. -If it's saturated and f hasn't inlined, then it's probably not going -to now! - -Note [Conlike is interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f d = ...((*) d x y)... - ... f (df d')... -where df is con-like. Then we'd really like to inline 'f' so that the -rule for (*) (df d) can fire. To do this - a) we give a discount for being an argument of a class-op (eg (*) d) - b) we say that a con-like argument (eg (df d)) is interesting --} - -interestingArg :: SimplEnv -> CoreExpr -> ArgSummary --- See Note [Interesting arguments] -interestingArg env e = go env 0 e - where - -- n is # value args to which the expression is applied - go env n (Var v) - | SimplEnv { seIdSubst = ids, seInScope = in_scope } <- env - = case snd <$> lookupVarEnv ids v of - Nothing -> go_var n (refineFromInScope in_scope v) - Just (DoneId v') -> go_var n (refineFromInScope in_scope v') - Just (DoneEx e) -> go (zapSubstEnv env) n e - Just (ContEx tvs cvs ids e) -> go (setSubstEnv env tvs cvs ids) n e - - go _ _ (Lit {}) = ValueArg - go _ _ (Type _) = TrivArg - go _ _ (Coercion _) = TrivArg - go env n (App fn (Type _)) = go env n fn - go env n (App fn _) = go env (n+1) fn - go env n (Tick _ a) = go env n a - go env n (Cast e _) = go env n e - go env n (Lam v e) - | isTyVar v = go env n e - | n>0 = NonTrivArg -- (\x.b) e is NonTriv - | otherwise = ValueArg - go _ _ (Case {}) = NonTrivArg - go env n (Let b e) = case go env' n e of - ValueArg -> ValueArg - _ -> NonTrivArg - where - env' = env `addNewInScopeIds` bindersOf b - - go_var n v - | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that - -- data constructors here - | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding - | n > 0 = NonTrivArg -- Saturated or unknown call - | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding - -- See Note [Conlike is interesting] - | otherwise = TrivArg -- n==0, no useful unfolding - where - conlike_unfolding = isConLikeUnfolding (idUnfolding v) - -{- -************************************************************************ -* * - SimplifierMode -* * -************************************************************************ - -The SimplifierMode controls several switches; see its definition in -CoreMonad - sm_rules :: Bool -- Whether RULES are enabled - sm_inline :: Bool -- Whether inlining is enabled - sm_case_case :: Bool -- Whether case-of-case is enabled - sm_eta_expand :: Bool -- Whether eta-expansion is enabled --} - -simplEnvForGHCi :: DynFlags -> SimplEnv -simplEnvForGHCi dflags - = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] - , sm_phase = InitialPhase - , sm_rules = rules_on - , sm_inline = False - , sm_eta_expand = eta_expand_on - , sm_case_case = True } - where - rules_on = gopt Opt_EnableRewriteRules dflags - eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags - -- Do not do any inlining, in case we expose some unboxed - -- tuple stuff that confuses the bytecode interpreter - -updModeForStableUnfoldings :: Activation -> SimplifierMode -> SimplifierMode --- See Note [Simplifying inside stable unfoldings] -updModeForStableUnfoldings inline_rule_act current_mode - = current_mode { sm_phase = phaseFromActivation inline_rule_act - , sm_inline = True - , sm_eta_expand = False } - -- sm_eta_expand: see Note [No eta expansion in stable unfoldings] - -- For sm_rules, just inherit; sm_rules might be "off" - -- because of -fno-enable-rewrite-rules - where - phaseFromActivation (ActiveAfter _ n) = Phase n - phaseFromActivation _ = InitialPhase - -updModeForRules :: SimplifierMode -> SimplifierMode --- See Note [Simplifying rules] -updModeForRules current_mode - = current_mode { sm_phase = InitialPhase - , sm_inline = False - , sm_rules = False - , sm_eta_expand = False } - -{- Note [Simplifying rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When simplifying a rule LHS, refrain from /any/ inlining or applying -of other RULES. - -Doing anything to the LHS is plain confusing, because it means that what the -rule matches is not what the user wrote. c.f. Trac #10595, and #10528. -Moreover, inlining (or applying rules) on rule LHSs risks introducing -Ticks into the LHS, which makes matching trickier. Trac #10665, #10745. - -Doing this to either side confounds tools like HERMIT, which seek to reason -about and apply the RULES as originally written. See Trac #10829. - -Note [No eta expansion in stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a stable unfolding - - f :: Ord a => a -> IO () - -- Unfolding template - -- = /\a \(d:Ord a) (x:a). bla - -we do not want to eta-expand to - - f :: Ord a => a -> IO () - -- Unfolding template - -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co - -because not specialisation of the overloading doesn't work properly -(see Note [Specialisation shape] in Specialise), Trac #9509. - -So we disable eta-expansion in stable unfoldings. - -Note [Inlining in gentle mode] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Something is inlined if - (i) the sm_inline flag is on, AND - (ii) the thing has an INLINE pragma, AND - (iii) the thing is inlinable in the earliest phase. - -Example of why (iii) is important: - {-# INLINE [~1] g #-} - g = ... - - {-# INLINE f #-} - f x = g (g x) - -If we were to inline g into f's inlining, then an importing module would -never be able to do - f e --> g (g e) ---> RULE fires -because the stable unfolding for f has had g inlined into it. - -On the other hand, it is bad not to do ANY inlining into an -stable unfolding, because then recursive knots in instance declarations -don't get unravelled. - -However, *sometimes* SimplGently must do no call-site inlining at all -(hence sm_inline = False). Before full laziness we must be careful -not to inline wrappers, because doing so inhibits floating - e.g. ...(case f x of ...)... - ==> ...(case (case x of I# x# -> fw x#) of ...)... - ==> ...(case x of I# x# -> case fw x# of ...)... -and now the redex (f x) isn't floatable any more. - -The no-inlining thing is also important for Template Haskell. You might be -compiling in one-shot mode with -O2; but when TH compiles a splice before -running it, we don't want to use -O2. Indeed, we don't want to inline -anything, because the byte-code interpreter might get confused about -unboxed tuples and suchlike. - -Note [Simplifying inside stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must take care with simplification inside stable unfoldings (which come from -INLINE pragmas). - -First, consider the following example - let f = \pq -> BIG - in - let g = \y -> f y y - {-# INLINE g #-} - in ...g...g...g...g...g... -Now, if that's the ONLY occurrence of f, it might be inlined inside g, -and thence copied multiple times when g is inlined. HENCE we treat -any occurrence in a stable unfolding as a multiple occurrence, not a single -one; see OccurAnal.addRuleUsage. - -Second, we do want *do* to some modest rules/inlining stuff in stable -unfoldings, partly to eliminate senseless crap, and partly to break -the recursive knots generated by instance declarations. - -However, suppose we have - {-# INLINE f #-} - f = -meaning "inline f in phases p where activation (p) holds". -Then what inlinings/rules can we apply to the copy of captured in -f's stable unfolding? Our model is that literally is substituted for -f when it is inlined. So our conservative plan (implemented by -updModeForStableUnfoldings) is this: - - ------------------------------------------------------------- - When simplifying the RHS of an stable unfolding, set the phase - to the phase in which the stable unfolding first becomes active - ------------------------------------------------------------- - -That ensures that - - a) Rules/inlinings that *cease* being active before p will - not apply to the stable unfolding, consistent with it being - inlined in its *original* form in phase p. - - b) Rules/inlinings that only become active *after* p will - not apply to the stable unfolding, again to be consistent with - inlining the *original* rhs in phase p. - -For example, - {-# INLINE f #-} - f x = ...g... - - {-# NOINLINE [1] g #-} - g y = ... - - {-# RULE h g = ... #-} -Here we must not inline g into f's RHS, even when we get to phase 0, -because when f is later inlined into some other module we want the -rule for h to fire. - -Similarly, consider - {-# INLINE f #-} - f x = ...g... - - g y = ... -and suppose that there are auto-generated specialisations and a strictness -wrapper for g. The specialisations get activation AlwaysActive, and the -strictness wrapper get activation (ActiveAfter 0). So the strictness -wrepper fails the test and won't be inlined into f's stable unfolding. That -means f can inline, expose the specialised call to g, so the specialisation -rules can fire. - -A note about wrappers -~~~~~~~~~~~~~~~~~~~~~ -It's also important not to inline a worker back into a wrapper. -A wrapper looks like - wraper = inline_me (\x -> ...worker... ) -Normally, the inline_me prevents the worker getting inlined into -the wrapper (initially, the worker's only call site!). But, -if the wrapper is sure to be called, the strictness analyser will -mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf -continuation. --} - -activeUnfolding :: SimplEnv -> Id -> Bool -activeUnfolding env id - | isCompulsoryUnfolding (realIdUnfolding id) - = True -- Even sm_inline can't override compulsory unfoldings - | otherwise - = isActive (sm_phase mode) (idInlineActivation id) - && sm_inline mode - -- `or` isStableUnfolding (realIdUnfolding id) - -- Inline things when - -- (a) they are active - -- (b) sm_inline says so, except that for stable unfoldings - -- (ie pragmas) we inline anyway - where - mode = getMode env - -getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv --- When matching in RULE, we want to "look through" an unfolding --- (to see a constructor) if *rules* are on, even if *inlinings* --- are not. A notable example is DFuns, which really we want to --- match in rules like (op dfun) in gentle mode. Another example --- is 'otherwise' which we want exprIsConApp_maybe to be able to --- see very early on -getUnfoldingInRuleMatch env - = (in_scope, id_unf) - where - in_scope = seInScope env - mode = getMode env - id_unf id | unf_is_active id = idUnfolding id - | otherwise = NoUnfolding - unf_is_active id - | not (sm_rules mode) = -- active_unfolding_minimal id - isStableUnfolding (realIdUnfolding id) - -- Do we even need to test this? I think this InScopeEnv - -- is only consulted if activeRule returns True, which - -- never happens if sm_rules is False - | otherwise = isActive (sm_phase mode) (idInlineActivation id) - ----------------------- -activeRule :: SimplEnv -> Activation -> Bool --- Nothing => No rules at all -activeRule env - | not (sm_rules mode) = \_ -> False -- Rewriting is off - | otherwise = isActive (sm_phase mode) - where - mode = getMode env - -{- -************************************************************************ -* * - preInlineUnconditionally -* * -************************************************************************ - -preInlineUnconditionally -~~~~~~~~~~~~~~~~~~~~~~~~ -@preInlineUnconditionally@ examines a bndr to see if it is used just -once in a completely safe way, so that it is safe to discard the -binding inline its RHS at the (unique) usage site, REGARDLESS of how -big the RHS might be. If this is the case we don't simplify the RHS -first, but just inline it un-simplified. - -This is much better than first simplifying a perhaps-huge RHS and then -inlining and re-simplifying it. Indeed, it can be at least quadratically -better. Consider - - x1 = e1 - x2 = e2[x1] - x3 = e3[x2] - ...etc... - xN = eN[xN-1] - -We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. -This can happen with cascades of functions too: - - f1 = \x1.e1 - f2 = \xs.e2[f1] - f3 = \xs.e3[f3] - ...etc... - -THE MAIN INVARIANT is this: - - ---- preInlineUnconditionally invariant ----- - IF preInlineUnconditionally chooses to inline x = - THEN doing the inlining should not change the occurrence - info for the free vars of - ---------------------------------------------- - -For example, it's tempting to look at trivial binding like - x = y -and inline it unconditionally. But suppose x is used many times, -but this is the unique occurrence of y. Then inlining x would change -y's occurrence info, which breaks the invariant. It matters: y -might have a BIG rhs, which will now be dup'd at every occurrenc of x. - - -Even RHSs labelled InlineMe aren't caught here, because there might be -no benefit from inlining at the call site. - -[Sept 01] Don't unconditionally inline a top-level thing, because that -can simply make a static thing into something built dynamically. E.g. - x = (a,b) - main = \s -> h x - -[Remember that we treat \s as a one-shot lambda.] No point in -inlining x unless there is something interesting about the call site. - -But watch out: if you aren't careful, some useful foldr/build fusion -can be lost (most notably in spectral/hartel/parstof) because the -foldr didn't see the build. Doing the dynamic allocation isn't a big -deal, in fact, but losing the fusion can be. But the right thing here -seems to be to do a callSiteInline based on the fact that there is -something interesting about the call site (it's strict). Hmm. That -seems a bit fragile. - -Conclusion: inline top level things gaily until Phase 0 (the last -phase), at which point don't. - -Note [pre/postInlineUnconditionally in gentle mode] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even in gentle mode we want to do preInlineUnconditionally. The -reason is that too little clean-up happens if you don't inline -use-once things. Also a bit of inlining is *good* for full laziness; -it can expose constant sub-expressions. Example in -spectral/mandel/Mandel.hs, where the mandelset function gets a useful -let-float if you inline windowToViewport - -However, as usual for Gentle mode, do not inline things that are -inactive in the intial stages. See Note [Gentle mode]. - -Note [Stable unfoldings and preInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! -Example - - {-# INLINE f #-} - f :: Eq a => a -> a - f x = ... - - fInt :: Int -> Int - fInt = f Int dEqInt - - ...fInt...fInt...fInt... - -Here f occurs just once, in the RHS of fInt. But if we inline it there -it might make fInt look big, and we'll lose the opportunity to inline f -at each of fInt's call sites. The INLINE pragma will only inline when -the application is saturated for exactly this reason; and we don't -want PreInlineUnconditionally to second-guess it. A live example is -Trac #3736. - c.f. Note [Stable unfoldings and postInlineUnconditionally] - -Note [Top-level bottoming Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't inline top-level Ids that are bottoming, even if they are used just -once, because FloatOut has gone to some trouble to extract them out. -Inlining them won't make the program run faster! - -Note [Do not inline CoVars unconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Coercion variables appear inside coercions, and the RHS of a let-binding -is a term (not a coercion) so we can't necessarily inline the latter in -the former. --} - -preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool --- Precondition: rhs satisfies the let/app invariant --- See Note [CoreSyn let/app invariant] in CoreSyn --- Reason: we don't want to inline single uses, or discard dead bindings, --- for unlifted, side-effect-ful bindings -preInlineUnconditionally dflags env top_lvl bndr rhs - | not active = False - | isStableUnfolding (idUnfolding bndr) = False -- Note [Stable unfoldings and preInlineUnconditionally] - | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids] - | not (gopt Opt_SimplPreInlining dflags) = False - | isCoVar bndr = False -- Note [Do not inline CoVars unconditionally] - | otherwise = case idOccInfo bndr of - IAmDead -> True -- Happens in ((\x.1) v) - occ@OneOcc { occ_one_br = True } - -> try_once (occ_in_lam occ) - (occ_int_cxt occ) - _ -> False - where - mode = getMode env - active = isActive (sm_phase mode) act - -- See Note [pre/postInlineUnconditionally in gentle mode] - act = idInlineActivation bndr - try_once in_lam int_cxt -- There's one textual occurrence - | not in_lam = isNotTopLevel top_lvl || early_phase - | otherwise = int_cxt && canInlineInLam rhs - --- Be very careful before inlining inside a lambda, because (a) we must not --- invalidate occurrence information, and (b) we want to avoid pushing a --- single allocation (here) into multiple allocations (inside lambda). --- Inlining a *function* with a single *saturated* call would be ok, mind you. --- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) --- where --- is_cheap = exprIsCheap rhs --- ok = is_cheap && int_cxt - - -- int_cxt The context isn't totally boring - -- E.g. let f = \ab.BIG in \y. map f xs - -- Don't want to substitute for f, because then we allocate - -- its closure every time the \y is called - -- But: let f = \ab.BIG in \y. map (f y) xs - -- Now we do want to substitute for f, even though it's not - -- saturated, because we're going to allocate a closure for - -- (f y) every time round the loop anyhow. - - -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, - -- so substituting rhs inside a lambda doesn't change the occ info. - -- Sadly, not quite the same as exprIsHNF. - canInlineInLam (Lit _) = True - canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e - canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e - canInlineInLam _ = False - -- not ticks. Counting ticks cannot be duplicated, and non-counting - -- ticks around a Lam will disappear anyway. - - early_phase = case sm_phase mode of - Phase 0 -> False - _ -> True --- If we don't have this early_phase test, consider --- x = length [1,2,3] --- The full laziness pass carefully floats all the cons cells to --- top level, and preInlineUnconditionally floats them all back in. --- Result is (a) static allocation replaced by dynamic allocation --- (b) many simplifier iterations because this tickles --- a related problem; only one inlining per pass --- --- On the other hand, I have seen cases where top-level fusion is --- lost if we don't inline top level thing (e.g. string constants) --- Hence the test for phase zero (which is the phase for all the final --- simplifications). Until phase zero we take no special notice of --- top level things, but then we become more leery about inlining --- them. - -{- -************************************************************************ -* * - postInlineUnconditionally -* * -************************************************************************ - -postInlineUnconditionally -~~~~~~~~~~~~~~~~~~~~~~~~~ -@postInlineUnconditionally@ decides whether to unconditionally inline -a thing based on the form of its RHS; in particular if it has a -trivial RHS. If so, we can inline and discard the binding altogether. - -NB: a loop breaker has must_keep_binding = True and non-loop-breakers -only have *forward* references. Hence, it's safe to discard the binding - -NOTE: This isn't our last opportunity to inline. We're at the binding -site right now, and we'll get another opportunity when we get to the -occurrence(s) - -Note that we do this unconditional inlining only for trival RHSs. -Don't inline even WHNFs inside lambdas; doing so may simply increase -allocation when the function is called. This isn't the last chance; see -NOTE above. - -NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why? -Because we don't even want to inline them into the RHS of constructor -arguments. See NOTE above - -NB: At one time even NOINLINE was ignored here: if the rhs is trivial -it's best to inline it anyway. We often get a=E; b=a from desugaring, -with both a and b marked NOINLINE. But that seems incompatible with -our new view that inlining is like a RULE, so I'm sticking to the 'active' -story for now. --} - -postInlineUnconditionally - :: DynFlags -> SimplEnv -> TopLevelFlag - -> OutId -- The binder (an InId would be fine too) - -- (*not* a CoVar) - -> OccInfo -- From the InId - -> OutExpr - -> Unfolding - -> Bool --- Precondition: rhs satisfies the let/app invariant --- See Note [CoreSyn let/app invariant] in CoreSyn --- Reason: we don't want to inline single uses, or discard dead bindings, --- for unlifted, side-effect-ful bindings -postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding - | not active = False - | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline - -- because it might be referred to "earlier" - | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] - | isTopLevel top_lvl = False -- Note [Top level and postInlineUnconditionally] - | exprIsTrivial rhs = True - | otherwise - = case occ_info of - -- The point of examining occ_info here is that for *non-values* - -- that occur outside a lambda, the call-site inliner won't have - -- a chance (because it doesn't know that the thing - -- only occurs once). The pre-inliner won't have gotten - -- it either, if the thing occurs in more than one branch - -- So the main target is things like - -- let x = f y in - -- case v of - -- True -> case x of ... - -- False -> case x of ... - -- This is very important in practice; e.g. wheel-seive1 doubles - -- in allocation if you miss this out - OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt } - -- OneOcc => no code-duplication issue - -> smallEnoughToInline dflags unfolding -- Small enough to dup - -- ToDo: consider discount on smallEnoughToInline if int_cxt is true - -- - -- NB: Do NOT inline arbitrarily big things, even if one_br is True - -- Reason: doing so risks exponential behaviour. We simplify a big - -- expression, inline it, and simplify it again. But if the - -- very same thing happens in the big expression, we get - -- exponential cost! - -- PRINCIPLE: when we've already simplified an expression once, - -- make sure that we only inline it if it's reasonably small. - - && (not in_lam || - -- Outside a lambda, we want to be reasonably aggressive - -- about inlining into multiple branches of case - -- e.g. let x = - -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } - -- Inlining can be a big win if C3 is the hot-spot, even if - -- the uses in C1, C2 are not 'interesting' - -- An example that gets worse if you add int_cxt here is 'clausify' - - (isCheapUnfolding unfolding && int_cxt)) - -- isCheap => acceptable work duplication; in_lam may be true - -- int_cxt to prevent us inlining inside a lambda without some - -- good reason. See the notes on int_cxt in preInlineUnconditionally - - IAmDead -> True -- This happens; for example, the case_bndr during case of - -- known constructor: case (a,b) of x { (p,q) -> ... } - -- Here x isn't mentioned in the RHS, so we don't want to - -- create the (dead) let-binding let x = (a,b) in ... - - _ -> False - --- Here's an example that we don't handle well: --- let f = if b then Left (\x.BIG) else Right (\y.BIG) --- in \y. ....case f of {...} .... --- Here f is used just once, and duplicating the case work is fine (exprIsCheap). --- But --- - We can't preInlineUnconditionally because that woud invalidate --- the occ info for b. --- - We can't postInlineUnconditionally because the RHS is big, and --- that risks exponential behaviour --- - We can't call-site inline, because the rhs is big --- Alas! - - where - active = isActive (sm_phase (getMode env)) (idInlineActivation bndr) - -- See Note [pre/postInlineUnconditionally in gentle mode] - -{- -Note [Top level and postInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't do postInlineUnconditionally for top-level things (even for -ones that are trivial): - - * Doing so will inline top-level error expressions that have been - carefully floated out by FloatOut. More generally, it might - replace static allocation with dynamic. - - * Even for trivial expressions there's a problem. Consider - {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-} - blah xs = reverse xs - ruggle = sort - In one simplifier pass we might fire the rule, getting - blah xs = ruggle xs - but in *that* simplifier pass we must not do postInlineUnconditionally - on 'ruggle' because then we'll have an unbound occurrence of 'ruggle' - - If the rhs is trivial it'll be inlined by callSiteInline, and then - the binding will be dead and discarded by the next use of OccurAnal - - * There is less point, because the main goal is to get rid of local - bindings used in multiple case branches. - - * The inliner should inline trivial things at call sites anyway. - - * The Id might be exported. We could check for that separately, - but since we aren't going to postInlineUnconditionally /any/ - top-level bindings, we don't need to test. - -Note [Stable unfoldings and postInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do not do postInlineUnconditionally if the Id has an stable unfolding, -otherwise we lose the unfolding. Example - - -- f has stable unfolding with rhs (e |> co) - -- where 'e' is big - f = e |> co - -Then there's a danger we'll optimise to - - f' = e - f = f' |> co - -and now postInlineUnconditionally, losing the stable unfolding on f. Now f' -won't inline because 'e' is too big. - - c.f. Note [Stable unfoldings and preInlineUnconditionally] - - -************************************************************************ -* * - Rebuilding a lambda -* * -************************************************************************ --} - -mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr --- mkLam tries three things --- a) eta reduction, if that gives a trivial expression --- b) eta expansion [only if there are some value lambdas] - -mkLam _env [] body _cont - = return body -mkLam env bndrs body cont - = do { dflags <- getDynFlags - ; mkLam' dflags bndrs body } - where - mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr - mkLam' dflags bndrs (Cast body co) - | not (any bad bndrs) - -- Note [Casts and lambdas] - = do { lam <- mkLam' dflags bndrs body - ; return (mkCast lam (mkPiCos Representational bndrs co)) } - where - co_vars = tyCoVarsOfCo co - bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars - - mkLam' dflags bndrs body@(Lam {}) - = mkLam' dflags (bndrs ++ bndrs1) body1 - where - (bndrs1, body1) = collectBinders body - - mkLam' dflags bndrs (Tick t expr) - | tickishFloatable t - = mkTick t <$> mkLam' dflags bndrs expr - - mkLam' dflags bndrs body - | gopt Opt_DoEtaReduction dflags - , Just etad_lam <- tryEtaReduce bndrs body - = do { tick (EtaReduction (head bndrs)) - ; return etad_lam } - - | not (contIsRhs cont) -- See Note [Eta-expanding lambdas] - , sm_eta_expand (getMode env) - , any isRuntimeVar bndrs - , let body_arity = exprEtaExpandArity dflags body - , body_arity > 0 - = do { tick (EtaExpansion (head bndrs)) - ; let res = mkLams bndrs (etaExpand body_arity body) - ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body) - , text "after" <+> ppr res]) - ; return res } - - | otherwise - = return (mkLams bndrs body) - -{- -Note [Eta expanding lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we *do* want to eta-expand lambdas. Consider - f (\x -> case x of (a,b) -> \s -> blah) -where 's' is a state token, and hence can be eta expanded. This -showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather -important function! - -The eta-expansion will never happen unless we do it now. (Well, it's -possible that CorePrep will do it, but CorePrep only has a half-baked -eta-expander that can't deal with casts. So it's much better to do it -here.) - -However, when the lambda is let-bound, as the RHS of a let, we have a -better eta-expander (in the form of tryEtaExpandRhs), so we don't -bother to try expansion in mkLam in that case; hence the contIsRhs -guard. - -NB: We check the SimplEnv (sm_eta_expand), not DynFlags. - See Note [No eta expansion in stable unfoldings] - -Note [Casts and lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (\x. (\y. e) `cast` g1) `cast` g2 -There is a danger here that the two lambdas look separated, and the -full laziness pass might float an expression to between the two. - -So this equation in mkLam' floats the g1 out, thus: - (\x. e `cast` g1) --> (\x.e) `cast` (tx -> g1) -where x:tx. - -In general, this floats casts outside lambdas, where (I hope) they -might meet and cancel with some other cast: - \x. e `cast` co ===> (\x. e) `cast` (tx -> co) - /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co) - /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) - (if not (g `in` co)) - -Notice that it works regardless of 'e'. Originally it worked only -if 'e' was itself a lambda, but in some cases that resulted in -fruitless iteration in the simplifier. A good example was when -compiling Text.ParserCombinators.ReadPrec, where we had a definition -like (\x. Get `cast` g) -where Get is a constructor with nonzero arity. Then mkLam eta-expanded -the Get, and the next iteration eta-reduced it, and then eta-expanded -it again. - -Note also the side condition for the case of coercion binders. -It does not make sense to transform - /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) -because the latter is not well-kinded. - -************************************************************************ -* * - Eta expansion -* * -************************************************************************ --} - -tryEtaExpandRhs :: SimplEnv -> RecFlag -> OutId -> OutExpr - -> SimplM (Arity, OutExpr) --- See Note [Eta-expanding at let bindings] -tryEtaExpandRhs env is_rec bndr rhs - = do { dflags <- getDynFlags - ; (new_arity, new_rhs) <- try_expand dflags - - ; WARN( new_arity < old_id_arity, - (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity - <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) ) - -- Note [Arity decrease] in Simplify - return (new_arity, new_rhs) } - where - try_expand dflags - | exprIsTrivial rhs - = return (exprArity rhs, rhs) - - | sm_eta_expand (getMode env) -- Provided eta-expansion is on - , let new_arity1 = findRhsArity dflags bndr rhs old_arity - new_arity2 = idCallArity bndr - new_arity = max new_arity1 new_arity2 - , new_arity > old_arity -- And the current manifest arity isn't enough - = if is_rec == Recursive && isJoinId bndr - then WARN(True, text "Can't eta-expand recursive join point:" <+> - ppr bndr) - return (old_arity, rhs) - else do { tick (EtaExpansion bndr) - ; return (new_arity, etaExpand new_arity rhs) } - | otherwise - = return (old_arity, rhs) - - old_arity = exprArity rhs -- See Note [Do not expand eta-expand PAPs] - old_id_arity = idArity bndr - -{- -Note [Eta-expanding at let bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We now eta expand at let-bindings, which is where the payoff comes. -The most significant thing is that we can do a simple arity analysis -(in CoreArity.findRhsArity), which we can't do for free-floating lambdas - -One useful consequence of not eta-expanding lambdas is this example: - genMap :: C a => ... - {-# INLINE genMap #-} - genMap f xs = ... - - myMap :: D a => ... - {-# INLINE myMap #-} - myMap = genMap - -Notice that 'genMap' should only inline if applied to two arguments. -In the stable unfolding for myMap we'll have the unfolding - (\d -> genMap Int (..d..)) -We do not want to eta-expand to - (\d f xs -> genMap Int (..d..) f xs) -because then 'genMap' will inline, and it really shouldn't: at least -as far as the programmer is concerned, it's not applied to two -arguments! - -Note [Do not eta-expand PAPs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to have old_arity = manifestArity rhs, which meant that we -would eta-expand even PAPs. But this gives no particular advantage, -and can lead to a massive blow-up in code size, exhibited by Trac #9020. -Suppose we have a PAP - foo :: IO () - foo = returnIO () -Then we can eta-expand do - foo = (\eta. (returnIO () |> sym g) eta) |> g -where - g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #) - -But there is really no point in doing this, and it generates masses of -coercions and whatnot that eventually disappear again. For T9020, GHC -allocated 6.6G beore, and 0.8G afterwards; and residency dropped from -1.8G to 45M. - -But note that this won't eta-expand, say - f = \g -> map g -Does it matter not eta-expanding such functions? I'm not sure. Perhaps -strictness analysis will have less to bite on? - - -************************************************************************ -* * -\subsection{Floating lets out of big lambdas} -* * -************************************************************************ - -Note [Floating and type abstraction] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - x = /\a. C e1 e2 -We'd like to float this to - y1 = /\a. e1 - y2 = /\a. e2 - x = /\a. C (y1 a) (y2 a) -for the usual reasons: we want to inline x rather vigorously. - -You may think that this kind of thing is rare. But in some programs it is -common. For example, if you do closure conversion you might get: - - data a :-> b = forall e. (e -> a -> b) :$ e - - f_cc :: forall a. a :-> a - f_cc = /\a. (\e. id a) :$ () - -Now we really want to inline that f_cc thing so that the -construction of the closure goes away. - -So I have elaborated simplLazyBind to understand right-hand sides that look -like - /\ a1..an. body - -and treat them specially. The real work is done in SimplUtils.abstractFloats, -but there is quite a bit of plumbing in simplLazyBind as well. - -The same transformation is good when there are lets in the body: - - /\abc -> let(rec) x = e in b - ==> - let(rec) x' = /\abc -> let x = x' a b c in e - in - /\abc -> let x = x' a b c in b - -This is good because it can turn things like: - - let f = /\a -> letrec g = ... g ... in g -into - letrec g' = /\a -> ... g' a ... - in - let f = /\ a -> g' a - -which is better. In effect, it means that big lambdas don't impede -let-floating. - -This optimisation is CRUCIAL in eliminating the junk introduced by -desugaring mutually recursive definitions. Don't eliminate it lightly! - -[May 1999] If we do this transformation *regardless* then we can -end up with some pretty silly stuff. For example, - - let - st = /\ s -> let { x1=r1 ; x2=r2 } in ... - in .. -becomes - let y1 = /\s -> r1 - y2 = /\s -> r2 - st = /\s -> ...[y1 s/x1, y2 s/x2] - in .. - -Unless the "..." is a WHNF there is really no point in doing this. -Indeed it can make things worse. Suppose x1 is used strictly, -and is of the form - - x1* = case f y of { (a,b) -> e } - -If we abstract this wrt the tyvar we then can't do the case inline -as we would normally do. - -That's why the whole transformation is part of the same process that -floats let-bindings and constructor arguments out of RHSs. In particular, -it is guarded by the doFloatFromRhs call in simplLazyBind. - -Note [Which type variables to abstract over] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Abstract only over the type variables free in the rhs wrt which the -new binding is abstracted. Note that - - * The naive approach of abstracting wrt the - tyvars free in the Id's /type/ fails. Consider: - /\ a b -> let t :: (a,b) = (e1, e2) - x :: a = fst t - in ... - Here, b isn't free in x's type, but we must nevertheless - abstract wrt b as well, because t's type mentions b. - Since t is floated too, we'd end up with the bogus: - poly_t = /\ a b -> (e1, e2) - poly_x = /\ a -> fst (poly_t a *b*) - - * We must do closeOverKinds. Example (Trac #10934): - f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... - Here we want to float 't', but we must remember to abstract over - 'k' as well, even though it is not explicitly mentioned in the RHS, - otherwise we get - t = /\ (f:k->*) (a:k). AccFailure @ (f a) - which is obviously bogus. --} - -abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr) -abstractFloats main_tvs body_env body - = ASSERT( notNull body_floats ) - do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats - ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) } - where - main_tv_set = mkVarSet main_tvs - body_floats = getFloatBinds body_env - empty_subst = CoreSubst.mkEmptySubst (seInScope body_env) - - abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind) - abstract subst (NonRec id rhs) - = do { (poly_id, poly_app) <- mk_poly tvs_here id - ; let poly_rhs = mkLams tvs_here rhs' - subst' = CoreSubst.extendIdSubst subst id poly_app - ; return (subst', (NonRec poly_id poly_rhs)) } - where - rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs - - -- tvs_here: see Note [Which type variables to abstract over] - tvs_here = toposortTyVars $ - filter (`elemVarSet` main_tv_set) $ - closeOverKindsList $ - exprSomeFreeVarsList isTyVar rhs' - - abstract subst (Rec prs) - = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids - ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps) - poly_rhss = [mkLams tvs_here (CoreSubst.substExpr (text "abstract_floats3") subst' rhs) - | rhs <- rhss] - ; return (subst', Rec (poly_ids `zip` poly_rhss)) } - where - (ids,rhss) = unzip prs - -- For a recursive group, it's a bit of a pain to work out the minimal - -- set of tyvars over which to abstract: - -- /\ a b c. let x = ...a... in - -- letrec { p = ...x...q... - -- q = .....p...b... } in - -- ... - -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted - -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'. - -- Since it's a pain, we just use the whole set, which is always safe - -- - -- If you ever want to be more selective, remember this bizarre case too: - -- x::a = x - -- Here, we must abstract 'x' over 'a'. - tvs_here = toposortTyVars main_tvs - - mk_poly tvs_here var - = do { uniq <- getUniqueM - ; let poly_name = setNameUnique (idName var) uniq -- Keep same name - poly_ty = mkInvForAllTys tvs_here (idType var) -- But new type of course - poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs - mkLocalIdOrCoVar poly_name poly_ty - ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } - -- In the olden days, it was crucial to copy the occInfo of the original var, - -- because we were looking at occurrence-analysed but as yet unsimplified code! - -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking - -- at already simplified code, so it doesn't matter - -- - -- It's even right to retain single-occurrence or dead-var info: - -- Suppose we started with /\a -> let x = E in B - -- where x occurs once in B. Then we transform to: - -- let x' = /\a -> E in /\a -> let x* = x' a in B - -- where x* has an INLINE prag on it. Now, once x* is inlined, - -- the occurrences of x' will be just the occurrences originally - -- pinned on x. - -{- -Note [Abstract over coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the -type variable a. Rather than sort this mess out, we simply bale out and abstract -wrt all the type variables if any of them are coercion variables. - - -Historical note: if you use let-bindings instead of a substitution, beware of this: - - -- Suppose we start with: - -- - -- x = /\ a -> let g = G in E - -- - -- Then we'll float to get - -- - -- x = let poly_g = /\ a -> G - -- in /\ a -> let g = poly_g a in E - -- - -- But now the occurrence analyser will see just one occurrence - -- of poly_g, not inside a lambda, so the simplifier will - -- PreInlineUnconditionally poly_g back into g! Badk to square 1! - -- (I used to think that the "don't inline lone occurrences" stuff - -- would stop this happening, but since it's the *only* occurrence, - -- PreInlineUnconditionally kicks in first!) - -- - -- Solution: put an INLINE note on g's RHS, so that poly_g seems - -- to appear many times. (NB: mkInlineMe eliminates - -- such notes on trivial RHSs, so do it manually.) - -************************************************************************ -* * - prepareAlts -* * -************************************************************************ - -prepareAlts tries these things: - -1. Eliminate alternatives that cannot match, including the - DEFAULT alternative. - -2. If the DEFAULT alternative can match only one possible constructor, - then make that constructor explicit. - e.g. - case e of x { DEFAULT -> rhs } - ===> - case e of x { (a,b) -> rhs } - where the type is a single constructor type. This gives better code - when rhs also scrutinises x or e. - -3. Returns a list of the constructors that cannot holds in the - DEFAULT alternative (if there is one) - -Here "cannot match" includes knowledge from GADTs - -It's a good idea to do this stuff before simplifying the alternatives, to -avoid simplifying alternatives we know can't happen, and to come up with -the list of constructors that are handled, to put into the IdInfo of the -case binder, for use when simplifying the alternatives. - -Eliminating the default alternative in (1) isn't so obvious, but it can -happen: - -data Colour = Red | Green | Blue - -f x = case x of - Red -> .. - Green -> .. - DEFAULT -> h x - -h y = case y of - Blue -> .. - DEFAULT -> [ case y of ... ] - -If we inline h into f, the default case of the inlined h can't happen. -If we don't notice this, we may end up filtering out *all* the cases -of the inner case y, which give us nowhere to go! --} - -prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) --- The returned alternatives can be empty, none are possible -prepareAlts scrut case_bndr' alts - | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr') - -- Case binder is needed just for its type. Note that as an - -- OutId, it has maximum information; this is important. - -- Test simpl013 is an example - = do { us <- getUniquesM - ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts - (yes2, alts2) = refineDefaultAlt us tc tys idcs1 alts1 - (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 - -- "idcs" stands for "impossible default data constructors" - -- i.e. the constructors that can't match the default case - ; when yes2 $ tick (FillInCaseDefault case_bndr') - ; when yes3 $ tick (AltMerge case_bndr') - ; return (idcs3, alts3) } - - | otherwise -- Not a data type, so nothing interesting happens - = return ([], alts) - where - imposs_cons = case scrut of - Var v -> otherCons (idUnfolding v) - _ -> [] - - -{- -************************************************************************ -* * - mkCase -* * -************************************************************************ - -mkCase tries these things - -1. Merge Nested Cases - - case e of b { ==> case e of b { - p1 -> rhs1 p1 -> rhs1 - ... ... - pm -> rhsm pm -> rhsm - _ -> case b of b' { pn -> let b'=b in rhsn - pn -> rhsn ... - ... po -> let b'=b in rhso - po -> rhso _ -> let b'=b in rhsd - _ -> rhsd - } - - which merges two cases in one case when -- the default alternative of - the outer case scrutises the same variable as the outer case. This - transformation is called Case Merging. It avoids that the same - variable is scrutinised multiple times. - -2. Eliminate Identity Case - - case e of ===> e - True -> True; - False -> False - - and similar friends. - -3. Scrutinee Constant Folding - - case x op# k# of _ { ===> case x of _ { - a1# -> e1 (a1# inv_op# k#) -> e1 - a2# -> e2 (a2# inv_op# k#) -> e2 - ... ... - DEFAULT -> ed DEFAULT -> ed - - where (x op# k#) inv_op# k# == x - - And similarly for commuted arguments and for some unary operations. - - The purpose of this transformation is not only to avoid an arithmetic - operation at runtime but to allow other transformations to apply in cascade. - - Example with the "Merge Nested Cases" optimization (from #12877): - - main = case t of t0 - 0## -> ... - DEFAULT -> case t0 `minusWord#` 1## of t1 - 0## -> ... - DEFAUT -> case t1 `minusWord#` 1## of t2 - 0## -> ... - DEFAULT -> case t2 `minusWord#` 1## of _ - 0## -> ... - DEFAULT -> ... - - becomes: - - main = case t of _ - 0## -> ... - 1## -> ... - 2## -> ... - 3## -> ... - DEFAULT -> ... - --} - -mkCase, mkCase1, mkCase2, mkCase3 - :: DynFlags - -> OutExpr -> OutId - -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order - -> SimplM OutExpr - --------------------------------------------------- --- 1. Merge Nested Cases --------------------------------------------------- - -mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) - | gopt Opt_CaseMerge dflags - , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) - <- stripTicksTop tickishFloatable deflt_rhs - , inner_scrut_var == outer_bndr - = do { tick (CaseMerge outer_bndr) - - ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args ) - (con, args, wrap_rhs rhs) - -- Simplifier's no-shadowing invariant should ensure - -- that outer_bndr is not shadowed by the inner patterns - wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs - -- The let is OK even for unboxed binders, - - wrapped_alts | isDeadBinder inner_bndr = inner_alts - | otherwise = map wrap_alt inner_alts - - merged_alts = mergeAlts outer_alts wrapped_alts - -- NB: mergeAlts gives priority to the left - -- case x of - -- A -> e1 - -- DEFAULT -> case x of - -- A -> e2 - -- B -> e3 - -- When we merge, we must ensure that e1 takes - -- precedence over e2 as the value for A! - - ; fmap (mkTicks ticks) $ - mkCase1 dflags scrut outer_bndr alts_ty merged_alts - } - -- Warning: don't call mkCase recursively! - -- Firstly, there's no point, because inner alts have already had - -- mkCase applied to them, so they won't have a case in their default - -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr - -- in munge_rhs may put a case into the DEFAULT branch! - -mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts - --------------------------------------------------- --- 2. Eliminate Identity Case --------------------------------------------------- - -mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case - | all identity_alt alts - = do { tick (CaseIdentity case_bndr) - ; return (mkTicks ticks $ re_cast scrut rhs1) } - where - ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts) - identity_alt (con, args, rhs) = check_eq rhs con args - - check_eq (Cast rhs co) con args -- See Note [RHS casts] - = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args - check_eq (Tick t e) alt args - = tickishFloatable t && check_eq e alt args - - check_eq (Lit lit) (LitAlt lit') _ = lit == lit' - check_eq (Var v) _ _ | v == case_bndr = True - check_eq (Var v) (DataAlt con) args - | null arg_tys, null args = v == dataConWorkId con - -- Optimisation only - check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ - mkConApp2 con arg_tys args - check_eq _ _ _ = False - - arg_tys = tyConAppArgs (idType case_bndr) - - -- Note [RHS casts] - -- ~~~~~~~~~~~~~~~~ - -- We've seen this: - -- case e of x { _ -> x `cast` c } - -- And we definitely want to eliminate this case, to give - -- e `cast` c - -- So we throw away the cast from the RHS, and reconstruct - -- it at the other end. All the RHS casts must be the same - -- if (all identity_alt alts) holds. - -- - -- Don't worry about nested casts, because the simplifier combines them - - re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co - re_cast scrut _ = scrut - -mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts - --------------------------------------------------- --- 2. Scrutinee Constant Folding --------------------------------------------------- - -mkCase2 dflags scrut bndr alts_ty alts - | gopt Opt_CaseFolding dflags - , Just (scrut',f) <- caseRules dflags scrut - = mkCase3 dflags scrut' bndr alts_ty (new_alts f) - | otherwise - = mkCase3 dflags scrut bndr alts_ty alts - where - -- We need to keep the correct association between the scrutinee and its - -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with - -- "let bndr = ... in": - -- - -- case v + 10 of y =====> case v of y - -- 20 -> e1 10 -> let y = 20 in e1 - -- DEFAULT -> e2 DEFAULT -> let y = v + 10 in e2 - -- - -- Other transformations give: =====> case v of y' - -- 10 -> let y = 20 in e1 - -- DEFAULT -> let y = y' + 10 in e2 - -- - wrap_rhs l rhs - | isDeadBinder bndr = rhs - | otherwise = Let (NonRec bndr l) rhs - - -- We need to re-sort the alternatives to preserve the #case_invariants# - new_alts f = sortBy cmpAlt (map (mapAlt f) alts) - - mapAlt f alt@(c,bs,e) = case c of - DEFAULT -> (c, bs, wrap_rhs scrut e) - LitAlt l - | isLitValue l -> (LitAlt (mapLitValue dflags f l), - bs, wrap_rhs (Lit l) e) - _ -> pprPanic "Unexpected alternative (mkCase2)" (ppr alt) - --------------------------------------------------- --- Catch-all --------------------------------------------------- -mkCase3 _dflags scrut bndr alts_ty alts - = return (Case scrut bndr alts_ty alts) - -{- -Note [Dead binders] -~~~~~~~~~~~~~~~~~~~~ -Note that dead-ness is maintained by the simplifier, so that it is -accurate after simplification as well as before. - - -Note [Cascading case merge] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Case merging should cascade in one sweep, because it -happens bottom-up - - case e of a { - DEFAULT -> case a of b - DEFAULT -> case b of c { - DEFAULT -> e - A -> ea - B -> eb - C -> ec -==> - case e of a { - DEFAULT -> case a of b - DEFAULT -> let c = b in e - A -> let c = b in ea - B -> eb - C -> ec -==> - case e of a { - DEFAULT -> let b = a in let c = b in e - A -> let b = a in let c = b in ea - B -> let b = a in eb - C -> ec - - -However here's a tricky case that we still don't catch, and I don't -see how to catch it in one pass: - - case x of c1 { I# a1 -> - case a1 of c2 -> - 0 -> ... - DEFAULT -> case x of c3 { I# a2 -> - case a2 of ... - -After occurrence analysis (and its binder-swap) we get this - - case x of c1 { I# a1 -> - let x = c1 in -- Binder-swap addition - case a1 of c2 -> - 0 -> ... - DEFAULT -> case x of c3 { I# a2 -> - case a2 of ... - -When we simplify the inner case x, we'll see that -x=c1=I# a1. So we'll bind a2 to a1, and get - - case x of c1 { I# a1 -> - case a1 of c2 -> - 0 -> ... - DEFAULT -> case a1 of ... - -This is corect, but we can't do a case merge in this sweep -because c2 /= a1. Reason: the binding c1=I# a1 went inwards -without getting changed to c1=I# c2. - -I don't think this is worth fixing, even if I knew how. It'll -all come out in the next pass anyway. --} diff --git a/simplCore/Simplify.hs b/simplCore/Simplify.hs deleted file mode 100644 --- a/simplCore/Simplify.hs +++ /dev/null @@ -1,3451 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[Simplify]{The main module of the simplifier} --} - -{-# LANGUAGE CPP #-} - -module Simplify ( simplTopBinds, simplExpr, simplRules ) where - -#include "HsVersions.h" - -import DynFlags -import SimplMonad -import Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) -import SimplEnv -import SimplUtils -import OccurAnal ( occurAnalyseExpr ) -import FamInstEnv ( FamInstEnv ) -import Literal ( litIsLifted ) --, mkMachInt ) -- temporalily commented out. See #8326 -import Id -import MkId ( seqId ) -import MkCore ( mkImpossibleExpr, castBottomExpr ) -import IdInfo -import Name ( Name, mkSystemVarName, isExternalName, getOccFS ) -import Coercion hiding ( substCo, substCoVar ) -import OptCoercion ( optCoercion ) -import FamInstEnv ( topNormaliseType_maybe ) -import DataCon ( DataCon, dataConWorkId, dataConRepStrictness, dataConRepArgTys ) ---import TyCon ( isEnumerationTyCon ) -- temporalily commented out. See #8326 -import CoreMonad ( Tick(..), SimplifierMode(..) ) -import CoreSyn -import Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd ) -import PprCore ( pprCoreExpr ) -import CoreUnfold -import CoreUtils -import CoreArity -import CoreOpt ( pushCoTyArg, pushCoValArg - , joinPointBinding_maybe, joinPointBindings_maybe ) ---import PrimOp ( tagToEnumKey ) -- temporalily commented out. See #8326 -import Rules ( mkRuleInfo, lookupRule, getRules ) ---import TysPrim ( intPrimTy ) -- temporalily commented out. See #8326 -import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, - RecFlag(..) ) -import MonadUtils ( foldlM, mapAccumLM, liftIO ) -import Maybes ( isJust, fromJust, orElse ) ---import Unique ( hasKey ) -- temporalily commented out. See #8326 -import Control.Monad -import Outputable -import FastString -import Pair -import Util -import ErrUtils -import Module ( moduleName, pprModuleName ) - -{- -The guts of the simplifier is in this module, but the driver loop for -the simplifier is in SimplCore.hs. - - ------------------------------------------ - *** IMPORTANT NOTE *** ------------------------------------------ -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. - - ------------------------------------------ - *** IMPORTANT NOTE *** ------------------------------------------ -Many parts of the simplifier return a bunch of "floats" as well as an -expression. This is wrapped as a datatype SimplUtils.FloatsWith. - -All "floats" are let-binds, not case-binds, but some non-rec lets may -be unlifted (with RHS ok-for-speculation). - - - ------------------------------------------ - ORGANISATION OF FUNCTIONS ------------------------------------------ -simplTopBinds - - simplify all top-level binders - - for NonRec, call simplRecOrTopPair - - for Rec, call simplRecBind - - - ------------------------------ -simplExpr (applied lambda) ==> simplNonRecBind -simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind -simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind - - ------------------------------ -simplRecBind [binders already simplfied] - - use simplRecOrTopPair on each pair in turn - -simplRecOrTopPair [binder already simplified] - Used for: recursive bindings (top level and nested) - top-level non-recursive bindings - Returns: - - check for PreInlineUnconditionally - - simplLazyBind - -simplNonRecBind - Used for: non-top-level non-recursive bindings - beta reductions (which amount to the same thing) - Because it can deal with strict arts, it takes a - "thing-inside" and returns an expression - - - check for PreInlineUnconditionally - - simplify binder, including its IdInfo - - if strict binding - simplStrictArg - mkAtomicArgs - completeNonRecX - else - simplLazyBind - addFloats - -simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder] - Used for: binding case-binder and constr args in a known-constructor case - - check for PreInLineUnconditionally - - simplify binder - - completeNonRecX - - ------------------------------ -simplLazyBind: [binder already simplified, RHS not] - Used for: recursive bindings (top level and nested) - top-level non-recursive bindings - non-top-level, but *lazy* non-recursive bindings - [must not be strict or unboxed] - Returns floats + an augmented environment, not an expression - - substituteIdInfo and add result to in-scope - [so that rules are available in rec rhs] - - simplify rhs - - mkAtomicArgs - - float if exposes constructor or PAP - - completeBind - - -completeNonRecX: [binder and rhs both simplified] - - if the the thing needs case binding (unlifted and not ok-for-spec) - build a Case - else - completeBind - addFloats - -completeBind: [given a simplified RHS] - [used for both rec and non-rec bindings, top level and not] - - try PostInlineUnconditionally - - add unfolding [this is the only place we add an unfolding] - - add arity - - - -Right hand sides and arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In many ways we want to treat - (a) the right hand side of a let(rec), and - (b) a function argument -in the same way. But not always! In particular, we would -like to leave these arguments exactly as they are, so they -will match a RULE more easily. - - f (g x, h x) - g (+ x) - -It's harder to make the rule match if we ANF-ise the constructor, -or eta-expand the PAP: - - f (let { a = g x; b = h x } in (a,b)) - g (\y. + x y) - -On the other hand if we see the let-defns - - p = (g x, h x) - q = + x - -then we *do* want to ANF-ise and eta-expand, so that p and q -can be safely inlined. - -Even floating lets out is a bit dubious. For let RHS's we float lets -out if that exposes a value, so that the value can be inlined more vigorously. -For example - - r = let x = e in (x,x) - -Here, if we float the let out we'll expose a nice constructor. We did experiments -that showed this to be a generally good thing. But it was a bad thing to float -lets out unconditionally, because that meant they got allocated more often. - -For function arguments, there's less reason to expose a constructor (it won't -get inlined). Just possibly it might make a rule match, but I'm pretty skeptical. -So for the moment we don't float lets out of function arguments either. - - -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. - - -Case-of-case and join points -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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. - -Clearly we need to be very careful here to remain consistent---neither part is -optional! - -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ --} - -simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv - -simplTopBinds env0 binds0 - = do { -- Put all the top-level binders into scope at the start - -- so that if a transformation rule has unexpectedly brought - -- anything into scope, then we don't get a complaint about that. - -- It's rather as if the top-level binders were imported. - -- See note [Glomming] in OccurAnal. - ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0) - ; env2 <- simpl_binds env1 binds0 - ; freeTick SimplifierDone - ; return 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 SimplEnv - simpl_binds env [] = return env - simpl_binds env (bind:binds) = do { env' <- simpl_bind env bind - ; simpl_binds env' binds } - - 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) - ; simplRecOrTopPair env' TopLevel - NonRecursive Nothing - b b' r } - -{- -************************************************************************ -* * -\subsection{Lazy bindings} -* * -************************************************************************ - -simplRecBind is used for - * recursive bindings only --} - -simplRecBind :: SimplEnv -> TopLevelFlag -> Maybe SimplCont - -> [(InId, InExpr)] - -> SimplM SimplEnv -simplRecBind env0 top_lvl mb_cont pairs0 - = do { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0 - ; env1 <- go (zapFloats env_with_info) triples - ; return (env0 `addRecFloats` env1) } - -- addFloats adds the floats from env1, - -- _and_ updates env0 with the in-scope set from 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) - ; return (env', (bndr, bndr', rhs)) } - - go env [] = return env - - go env ((old_bndr, new_bndr, rhs) : pairs) - = do { env' <- simplRecOrTopPair env top_lvl Recursive mb_cont - old_bndr new_bndr rhs - ; go env' pairs } - -{- -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 -> Maybe SimplCont - -> InId -> OutBndr -> InExpr -- Binder and rhs - -> SimplM SimplEnv -- Returns an env that includes the binding - -simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs - = do { dflags <- getDynFlags - ; trace_bind dflags $ - if preInlineUnconditionally dflags env top_lvl old_bndr rhs - -- Check for unconditional inline - then do tick (PreInlineUnconditionally old_bndr) - return (extendIdSubst env old_bndr (mkContEx env rhs)) - else simplBind env top_lvl is_rec mb_cont old_bndr new_bndr rhs env } - where - trace_bind dflags thing_inside - | not (dopt Opt_D_verbose_core2core dflags) - = thing_inside - | otherwise - = pprTrace "SimplBind" (ppr old_bndr) thing_inside - -- trace_bind emits a trace for each top-level binding, which - -- helps to locate the tracing for inlining and rule firing - -{- -simplBind is used for - * [simplRecOrTopPair] recursive bindings (whether top level or not) - * [simplRecOrTopPair] top-level non-recursive bindings - * [simplNonRecE] non-top-level *lazy* non-recursive bindings - -Nota bene: - 1. It assumes that the binder is *already* simplified, - and is in scope, and its IdInfo too, except unfolding - - 2. It assumes that the binder type is lifted. - - 3. It does not check for pre-inline-unconditionally; - that should have been done already. --} - -simplBind :: SimplEnv - -> TopLevelFlag -> RecFlag -> Maybe SimplCont - -> InId -> OutId -- Binder, both pre-and post simpl - -- The OutId has IdInfo, except arity, unfolding - -- Ids only, no TyVars - -> InExpr -> SimplEnv -- The RHS and its environment - -> SimplM SimplEnv -simplBind env top_lvl is_rec mb_cont bndr bndr1 rhs rhs_se - | ASSERT( isId bndr1 ) - isJoinId bndr1 - = ASSERT(isNotTopLevel top_lvl && isJust mb_cont) - simplJoinBind env is_rec (fromJust mb_cont) bndr bndr1 rhs rhs_se - | otherwise - = simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se - -simplLazyBind :: SimplEnv - -> TopLevelFlag -> RecFlag - -> InId -> OutId -- Binder, both pre-and post simpl - -- The OutId has IdInfo, except arity, unfolding - -- Ids only, no TyVars - -> InExpr -> SimplEnv -- The RHS and its environment - -> SimplM SimplEnv --- 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 `setInScopeAndZapFloats` env - (tvs, body) = case collectTyAndValBinders rhs of - (tvs, [], body) - | surely_not_lam body -> (tvs, body) - _ -> ([], rhs) - - surely_not_lam (Lam {}) = False - surely_not_lam (Tick t e) - | not (tickishFloatable t) = surely_not_lam e - -- eta-reduction could float - surely_not_lam _ = True - -- Do not do the "abstract tyyvar" thing if there's - -- a lambda inside, because it defeats eta-reduction - -- f = /\a. \x. g a x - -- should eta-reduce. - - - ; (body_env, tvs') <- simplBinders rhs_env tvs - -- See Note [Floating and type abstraction] in SimplUtils - - -- Simplify the RHS - ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) - ; (body_env0, body0) <- simplExprF body_env body rhs_cont - ; let body1 = wrapJoinFloats body_env0 body0 - body_env1 = body_env0 `restoreJoinFloats` body_env - - -- ANF-ise a constructor or PAP rhs - ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1 - - ; (env', rhs') - <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2) - then -- No floating, revert to body1 - do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1) rhs_cont - ; return (env, rhs') } - - else if null tvs then -- Simple floating - do { tick LetFloatFromLet - ; return (addFloats env body_env2, body2) } - - else -- Do type-abstraction first - do { tick LetFloatFromLet - ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2 - ; rhs' <- mkLam env tvs' body3 rhs_cont - ; env' <- foldlM (addPolyBind top_lvl) env poly_binds - ; return (env', rhs') } - - ; completeBind env' top_lvl is_rec Nothing bndr bndr1 rhs' } - -simplJoinBind :: SimplEnv - -> RecFlag - -> SimplCont - -> InId -> OutId -- Binder, both pre-and post simpl - -- The OutId has IdInfo, except arity, - -- unfolding - -> InExpr -> SimplEnv -- The RHS and its environment - -> SimplM SimplEnv -simplJoinBind env is_rec cont bndr bndr1 rhs rhs_se - = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ - -- ppr rhs $$ ppr (seIdSubst rhs_se)) $ - do { let rhs_env = rhs_se `setInScopeAndZapFloats` env - - -- Simplify the RHS - ; rhs' <- simplJoinRhs rhs_env bndr rhs cont - ; completeBind env NotTopLevel is_rec (Just cont) bndr bndr1 rhs' } - -{- -A specialised variant of simplNonRec used when the RHS is already simplified, -notably in knownCon. It uses case-binding where necessary. --} - -simplNonRecX :: SimplEnv - -> InId -- Old binder - -> OutExpr -- Simplified RHS - -> SimplM SimplEnv --- Precondition: rhs satisfies the let/app invariant -simplNonRecX env bndr new_rhs - | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } - = return env -- Here c is dead, and we avoid creating - -- the binding c = (a,b) - - | Coercion co <- new_rhs - = return (extendCvSubst env bndr co) - - | otherwise - = do { (env', bndr') <- simplBinder env bndr - ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } - -- simplNonRecX is only used for NotTopLevel things - -completeNonRecX :: TopLevelFlag -> SimplEnv - -> Bool - -> InId -- Old binder - -> OutId -- New binder - -> OutExpr -- Simplified RHS - -> SimplM SimplEnv --- Precondition: rhs satisfies the let/app invariant --- See Note [CoreSyn let/app invariant] in CoreSyn - -completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs - = ASSERT(not (isJoinId new_bndr)) - do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs - ; (env2, rhs2) <- - if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 - then do { tick LetFloatFromLet - ; return (addFloats env env1, rhs1) } -- Add the floats to the main env - else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS - ; completeBind env2 NotTopLevel NonRecursive Nothing - old_bndr new_bndr rhs2 } - -{- No, no, no! Do not try preInlineUnconditionally in completeNonRecX - Doing so risks exponential behaviour, because new_rhs has been simplified once already - In the cases described by the folowing commment, postInlineUnconditionally will - catch many of the relevant cases. - -- This happens; for example, the case_bndr during case of - -- known constructor: case (a,b) of x { (p,q) -> ... } - -- Here x isn't mentioned in the RHS, so we don't want to - -- create the (dead) let-binding let x = (a,b) in ... - -- - -- Similarly, single occurrences can be inlined vigourously - -- e.g. case (f x, g y) of (a,b) -> .... - -- If a,b occur once we can avoid constructing the let binding for them. - - Furthermore in the case-binding case preInlineUnconditionally risks extra thunks - -- Consider case I# (quotInt# x y) of - -- I# v -> let w = J# v in ... - -- If we gaily inline (quotInt# x y) for v, we end up building an - -- extra thunk: - -- let w = J# (quotInt# x y) in ... - -- because quotInt# can fail. - - | preInlineUnconditionally env NotTopLevel bndr new_rhs - = thing_inside (extendIdSubst env bndr (DoneEx new_rhs)) --} - ----------------------------------- -{- 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 [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 :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) --- Adds new floats to the env iff that allows us to return a good RHS --- See Note [prepareRhs] -prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions] - | Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type - , not (isUnliftedType ty1) -- see Note [Float coercions (unlifted)] - = do { (env', rhs') <- makeTrivialWithInfo top_lvl env (getOccFS id) sanitised_info rhs - ; return (env', Cast rhs' co) } - where - sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info - `setDemandInfo` demandInfo info - info = idInfo id - -prepareRhs top_lvl env0 id rhs0 - = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0 - ; return (env1, rhs1) } - where - go n_val_args env (Cast rhs co) - = do { (is_exp, env', rhs') <- go n_val_args env rhs - ; return (is_exp, env', Cast rhs' co) } - go n_val_args env (App fun (Type ty)) - = do { (is_exp, env', rhs') <- go n_val_args env fun - ; return (is_exp, env', App rhs' (Type ty)) } - go n_val_args env (App fun arg) - = do { (is_exp, env', fun') <- go (n_val_args+1) env fun - ; case is_exp of - True -> do { (env'', arg') <- makeTrivial top_lvl env' (getOccFS id) arg - ; return (True, env'', App fun' arg') } - False -> return (False, env, App fun arg) } - go n_val_args env (Var fun) - = return (is_exp, env, Var fun) - where - is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP - -- See Note [CONLIKE pragma] in BasicTypes - -- The definition of is_exp should match that in - -- OccurAnal.occAnalApp - - go n_val_args env (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, env', rhs') <- go n_val_args env rhs - ; return (is_exp, env', 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, env', rhs') <- go n_val_args (zapFloats env) rhs - ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) - floats' = seFloats $ env `addFloats` mapFloats env' tickIt - ; return (is_exp, env' { seFloats = floats' }, Tick t rhs') } - - go _ env other - = return (False, env, other) - -{- -Note [Float coercions] -~~~~~~~~~~~~~~~~~~~~~~ -When we find the binding - x = e `cast` co -we'd like to transform it to - x' = e - x = x `cast` co -- A trivial binding -There's a chance that e will be a constructor application or function, or something -like that, so moving the coercion to the usage site may well cancel the coercions -and lead to further optimisation. Example: - - data family T a :: * - data instance T Int = T Int - - foo :: Int -> Int -> Int - foo m n = ... - where - x = T m - go 0 = 0 - go n = case x of { T m -> go (n-m) } - -- This case should optimise - -Note [Preserve strictness when floating coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the Note [Float coercions] transformation, keep the strictness info. -Eg - f = e `cast` co -- f has strictness SSL -When we transform to - f' = e -- f' also has strictness SSL - f = f' `cast` co -- f still has strictness SSL - -Its not wrong to drop it on the floor, but better to keep it. - -Note [Float coercions (unlifted)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -BUT don't do [Float coercions] if 'e' has an unlifted type. -This *can* happen: - - foo :: Int = (error (# Int,Int #) "urk") - `cast` CoUnsafe (# Int,Int #) Int - -If do the makeTrivial thing to the error call, we'll get - foo = case error (# Int,Int #) "urk" of v -> v `cast` ... -But 'v' isn't in scope! - -These strange casts can happen as a result of case-of-case - bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of - (# p,q #) -> p+q --} - -makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec) -makeTrivialArg env (ValArg e) = do - { (env', e') <- makeTrivial NotTopLevel env (fsLit "arg") e - ; return (env', ValArg e') } -makeTrivialArg env arg = return (env, arg) -- CastBy, TyArg - -makeTrivial :: TopLevelFlag -> SimplEnv - -> FastString -- ^ a "friendly name" to build the new binder from - -> OutExpr -> SimplM (SimplEnv, OutExpr) --- Binds the expression to a variable, if it's not trivial, returning the variable -makeTrivial top_lvl env context expr = - makeTrivialWithInfo top_lvl env context vanillaIdInfo expr - -makeTrivialWithInfo :: TopLevelFlag -> SimplEnv - -> FastString - -- ^ a "friendly name" to build the new binder from - -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr) --- Propagate strictness and demand info to the new binder --- Note [Preserve strictness when floating coercions] --- Returned SimplEnv has same substitution as incoming one -makeTrivialWithInfo top_lvl env context info expr - | exprIsTrivial expr -- Already trivial - || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise - -- See Note [Cannot trivialise] - = return (env, expr) - | otherwise -- See Note [Take care] below - = do { uniq <- getUniqueM - ; let name = mkSystemVarName uniq context - var = mkLocalIdOrCoVarWithInfo name expr_ty info - ; env' <- completeNonRecX top_lvl env False var var expr - ; expr' <- simplVar env' var - ; return (env', expr') } - -- The simplVar is needed because we're constructing a new binding - -- a = rhs - -- And if rhs is of form (rhs1 |> co), then we might get - -- a1 = rhs1 - -- a = a1 |> co - -- and now a's RHS is trivial and can be substituted out, and that - -- is what completeNonRecX will do - -- To put it another way, it's as if we'd simplified - -- let var = e in var - where - expr_ty = exprType expr - -bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool --- True iff we can have a binding of this expression at this level --- Precondition: the type is the type of the expression -bindingOk top_lvl expr expr_ty - | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty - | otherwise = True - -{- -Note [Cannot trivialise] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider tih - f :: Int -> Addr# - - foo :: Bar - foo = Bar (f 3) - -Then we can't ANF-ise foo, even though we'd like to, because -we can't make a top-level binding for the Addr# (f 3). And if -so we don't want to turn it into - foo = let x = f 3 in Bar x -because we'll just end up inlining x back, and that makes the -simplifier loop. Better not to ANF-ise it at all. - -Literal strings are an exception. - - foo = Ptr "blob"# - -We want to turn this into: - - foo1 = "blob"# - foo = Ptr foo1 - -See Note [CoreSyn top-level string literals] in CoreSyn. - -************************************************************************ -* * -\subsection{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 - -> RecFlag -- Recursive binding? - -> Maybe SimplCont -- Required only for join point - -> InId -- Old binder - -> OutId -> OutExpr -- New binder and RHS - -> SimplM 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 --- --- Precondition: rhs obeys the let/app invariant -completeBind env top_lvl is_rec mb_cont old_bndr new_bndr new_rhs - | isCoVar old_bndr - = case new_rhs of - Coercion co -> return (extendCvSubst env old_bndr co) - _ -> return (addNonRec env new_bndr new_rhs) - - | otherwise - = ASSERT( isId new_bndr ) - do { let old_info = idInfo old_bndr - old_unf = unfoldingInfo old_info - occ_info = occInfo old_info - - -- Do eta-expansion on the RHS of the binding - -- See Note [Eta-expanding at let bindings] in SimplUtils - ; (new_arity, final_rhs) <- if isJoinId new_bndr - then return (manifestArity new_rhs, new_rhs) - -- Note [Don't eta-expand join points] - else tryEtaExpandRhs env is_rec - new_bndr new_rhs - - -- Simplify the unfolding - ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr - final_rhs old_unf - - ; dflags <- getDynFlags - ; if postInlineUnconditionally dflags env top_lvl new_bndr occ_info - final_rhs new_unfolding - - -- Inline and discard the binding - then do { tick (PostInlineUnconditionally old_bndr) - ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) } - -- Use the substitution to make quite, quite sure that the - -- substitution will happen, since we are going to discard the binding - else - do { let info1 = idInfo new_bndr `setArityInfo` new_arity - - -- Unfolding info: Note [Setting the new unfolding] - info2 = info1 `setUnfoldingInfo` new_unfolding - - -- 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_unfolding - || (case strictnessInfo info2 of - StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty) - = zapDemandInfo info2 `orElse` info2 - | otherwise - = info2 - - -- 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) - info4 = zapCallArityInfo info3 - - final_id = new_bndr `setIdInfo` info4 - - ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $ - return (addNonRec env final_id final_rhs) } } - -- The addNonRec adds it to the in-scope set too - ------------------------------- -addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv --- Add a new binding to the environment, complete with its unfolding --- but *do not* do postInlineUnconditionally, because we have already --- processed some of the scope of the binding --- We still want the unfolding though. Consider --- let --- x = /\a. let y = ... in Just y --- in body --- Then we float the y-binding out (via abstractFloats and addPolyBind) --- but 'x' may well then be inlined in 'body' in which case we'd like the --- opportunity to inline 'y' too. --- --- INVARIANT: the arity is correct on the incoming binders - -addPolyBind top_lvl env (NonRec poly_id rhs) - = do { unfolding <- simplLetUnfolding env top_lvl Nothing poly_id rhs - noUnfolding - -- Assumes that poly_id did not have an INLINE prag - -- which is perhaps wrong. ToDo: think about this - ; let final_id = setIdInfo poly_id $ - idInfo poly_id `setUnfoldingInfo` unfolding - - ; return (addNonRec env final_id rhs) } - -addPolyBind _ env bind@(Rec _) - = return (extendFloats env bind) - -- Hack: letrecs are more awkward, so we extend "by steam" - -- without adding unfoldings etc. At worst this leads to - -- more simplifier iterations - -{- 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 [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 [Don't eta-expand join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Similarly to CPR (see Note [Don't CPR join points] in WorkWrap), a join point -stands well to gain from its outer binding's eta-expansion, and eta-expanding a -join point is fraught with issues like how to deal with a cast: - - let join $j1 :: IO () - $j1 = ... - $j2 :: Int -> IO () - $j2 n = if n > 0 then $j1 - else ... - - => - - let join $j1 :: IO () - $j1 = (\eta -> ...) - `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) - ~ IO () - $j2 :: Int -> IO () - $j2 n = (\eta -> if n > 0 then $j1 - else ...) - `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) - ~ IO () - -The cast here can't be pushed inside the lambda (since it's not casting to a -function type), so the lambda has to stay, but it can't because it contains a -reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather -than try and detect this situation (and whatever other situations crop up!), we -don't bother; again, any surrounding eta-expansion will improve these join -points anyway, since an outer cast can *always* be pushed inside. By the time -CorePrep comes around, the code is very likely to look more like this: - - let join $j1 :: State# RealWorld -> (# State# RealWorld, ()) - $j1 = (...) eta - $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) - $j2 = if n > 0 then $j1 - else (...) eta - -************************************************************************ -* * -\subsection[Simplify-simplExpr]{The main function: simplExpr} -* * -************************************************************************ - -The reason for this OutExprStuff stuff is that we want to float *after* -simplifying a RHS, not before. If we do so naively we get quadratic -behaviour as things float out. - -To see why it's important to do it after, consider this (real) example: - - let t = f x - in fst t -==> - let t = let a = e1 - b = e2 - in (a,b) - in fst t -==> - let a = e1 - b = e2 - t = (a,b) - in - a -- Can't inline a this round, cos it appears twice -==> - e1 - -Each of the ==> steps is a round of simplification. We'd save a -whole round if we float first. This can cascade. Consider - - let f = g d - in \x -> ...f... -==> - let f = let d1 = ..d.. in \y -> e - in \x -> ...f... -==> - let d1 = ..d.. - in \x -> ...(\y ->e)... - -Only in this second round can the \y be applied, and it -might do the same again. --} - -simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr -simplExpr env (Type ty) - = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] - ; return (Type ty') } - -simplExpr env expr - = simplExprC env expr (mkBoringStop expr_out_ty) - where - expr_out_ty :: OutType - expr_out_ty = substTy env (exprType expr) - -- NB: Since 'expr' is term-valued, not (Type ty), this call - -- to exprType will succeed. exprType fails on (Type ty). - -simplExprC :: SimplEnv - -> InExpr -- A term-valued expression, never (Type ty) - -> SimplCont - -> SimplM OutExpr - -- Simplify an expression, given a continuation -simplExprC env expr cont - = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $ - do { (env', expr') <- simplExprF (zapFloats env) expr cont - ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ - -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ - -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $ - return (wrapFloats env' expr') } - --------------------------------------------------- -simplExprF :: SimplEnv - -> InExpr -- A term-valued expression, never (Type ty) - -> SimplCont - -> SimplM (SimplEnv, OutExpr) - -simplExprF env e cont - = -- pprTrace "simplExprF" (vcat --- [ ppr e --- , text "cont =" <+> ppr cont --- , text "inscope =" <+> ppr (seInScope env) --- , text "tvsubst =" <+> ppr (seTvSubst env) --- , text "idsubst =" <+> ppr (seIdSubst env) --- , text "cvsubst =" <+> ppr (seCvSubst env) --- {- , ppr (seFloats env) -} --- ]) $ - simplExprF1 env e cont - -simplExprF1 :: SimplEnv -> InExpr -> SimplCont - -> SimplM (SimplEnv, OutExpr) - -simplExprF1 _ (Type ty) _ - = pprPanic "simplExprF: type" (ppr ty) - -- simplExprF does only with term-valued expressions - -- The (Type ty) case is handled separately by simplExpr - -- and by the other callers of simplExprF - -simplExprF1 env (Var v) cont = simplIdF env v cont -simplExprF1 env (Lit lit) cont = rebuild env (Lit lit) cont -simplExprF1 env (Tick t expr) cont = simplTick env t expr cont -simplExprF1 env (Cast body co) cont = simplCast env body co cont -simplExprF1 env (Coercion co) cont = simplCoercionF env co cont - -simplExprF1 env (App fun arg) cont - = case arg of - Type ty -> do { -- The argument type will (almost) certainly be used - -- in the output program, so just force it now. - -- See Note [Avoiding space leaks in OutType] - arg' <- simplType env ty - - -- But use substTy, not simplType, to avoid forcing - -- the hole type; it will likely not be needed. - -- See Note [The hole type in ApplyToTy] - ; let hole' = substTy env (exprType fun) - - ; simplExprF env fun $ - ApplyToTy { sc_arg_ty = arg' - , sc_hole_ty = hole' - , sc_cont = cont } } - _ -> simplExprF env fun $ - ApplyToVal { sc_arg = arg, sc_env = env - , sc_dup = NoDup, sc_cont = cont } - -simplExprF1 env expr@(Lam {}) cont - = simplLam env zapped_bndrs body cont - -- The main issue here is under-saturated lambdas - -- (\x1. \x2. e) arg1 - -- Here x1 might have "occurs-once" occ-info, because occ-info - -- is computed assuming that a group of lambdas is applied - -- all at once. If there are too few args, we must zap the - -- occ-info, UNLESS the remaining binders are one-shot - where - (bndrs, body) = collectBinders expr - zapped_bndrs | need_to_zap = map zap bndrs - | otherwise = bndrs - - need_to_zap = any zappable_bndr (drop n_args bndrs) - n_args = countArgs cont - -- NB: countArgs counts all the args (incl type args) - -- and likewise drop counts all binders (incl type lambdas) - - zappable_bndr b = isId b && not (isOneShotBndr b) - zap b | isTyVar b = b - | otherwise = zapLamIdInfo b - -simplExprF1 env (Case scrut bndr _ alts) cont - = 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 - = 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) - = ASSERT( isTyVar bndr ) - do { ty' <- simplType env ty - ; simplExprF (extendTvSubst env bndr ty') body cont } - - | otherwise - = simplNonRecE env bndr (rhs, env) ([], body) cont - -{- Note [Avoiding space leaks in OutType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the simplifier is run for multiple iterations, we need to ensure -that any thunks in the output of one simplifier iteration are forced -by the evaluation of the next simplifier iteration. Otherwise we may -retain multiple copies of the Core program and leak a terrible amount -of memory (as in #13426). - -The simplifier is naturally strict in the entire "Expr part" of the -input Core program, because any expression may contain binders, which -we must find in order to extend the SimplEnv accordingly. But types -do not contain binders and so it is tempting to write things like - - simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! - -This is Bad because the result includes a thunk (substTy env ty) which -retains a reference to the whole simplifier environment; and the next -simplifier iteration will not force this thunk either, because the -line above is not strict in ty. - -So instead our strategy is for the simplifier to fully evaluate -OutTypes when it emits them into the output Core program, for example - - simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good - ; return (Type ty') } - -where the only difference from above is that simplType calls seqType -on the result of substTy. - -However, SimplCont can also contain OutTypes and it's not necessarily -a good idea to force types on the way in to SimplCont, because they -may end up not being used and forcing them could be a lot of wasted -work. T5631 is a good example of this. - -- For ApplyToTy's sc_arg_ty, we force the type on the way in because - the type will almost certainly appear as a type argument in the - output program. - -- For the hole types in Stop and ApplyToTy, we force the type when we - emit it into the output program, after obtaining it from - contResultType. (The hole type in ApplyToTy is only directly used - to form the result type in a new Stop continuation.) --} - ---------------------------------- --- Simplify a join point, adding the context. --- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: --- \x1 .. xn -> e => \x1 .. xn -> E[e] --- Note that we need the arity of the join point, since e may be a lambda --- (though this is unlikely). See Note [Case-of-case and join points]. -simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont - -> SimplM OutExpr -simplJoinRhs env bndr expr cont - | Just arity <- isJoinId_maybe bndr - = do { let (join_bndrs, join_body) = collectNBinders arity expr - ; (env', join_bndrs') <- simplLamBndrs env join_bndrs - ; join_body' <- simplExprC env' join_body cont - ; return $ mkLams join_bndrs' join_body' } - - | otherwise - = pprPanic "simplJoinRhs" (ppr bndr) - ---------------------------------- -simplType :: SimplEnv -> InType -> SimplM OutType - -- Kept monadic just so we can do the seqType - -- See Note [Avoiding space leaks in OutType] -simplType env ty - = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ - seqType new_ty `seq` return new_ty - where - new_ty = substTy env ty - ---------------------------------- -simplCoercionF :: SimplEnv -> InCoercion -> SimplCont - -> SimplM (SimplEnv, OutExpr) -simplCoercionF env co cont - = do { co' <- simplCoercion env co - ; rebuild env (Coercion co') cont } - -simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion -simplCoercion env co - = let opt_co = optCoercion (getTCvSubst env) co - in seqCo opt_co `seq` return opt_co - ------------------------------------ --- | Push a TickIt context outwards past applications and cases, as --- long as this is a non-scoping tick, to let case and application --- optimisations apply. - -simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont - -> SimplM (SimplEnv, 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 case expensive of p -> e --- becomes --- case expensive of p -> scc 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 { (env', expr') <- simplExprF env expr cont - ; return (env', mkTick tickish expr') - } - - -- Push tick inside if the context looks like this will allow us to - -- do a case-of-case - see Note [case-of-scc-of-case] - | Select {} <- cont, Just expr' <- push_tick_inside - = simplExprF env expr' cont - - -- We don't want to move the tick, but we might still want to allow - -- floats to pass through with appropriate wrapping (or not, see - -- wrap_floats below) - --- | not (tickishCounts tickish) || tickishCanSplit tickish - -- = wrap_floats - - | otherwise - = no_floating_past_tick - - where - - -- Try to push tick inside a case, see Note [case-of-scc-of-case]. - push_tick_inside = - case expr0 of - Case scrut bndr ty alts - -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) - _other -> Nothing - where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) - movable t = not (tickishCounts t) || - t `tickishScopesLike` NoScope || - tickishCanSplit t - tickScrut e = foldr mkTick e ticks - -- Alternatives get annotated with all ticks that scope in some way, - -- but we don't want to count entries. - tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope) - ts_scope = map mkNoCount $ - filter (not . (`tickishScopesLike` NoScope)) ticks - - no_floating_past_tick = - do { let (inc,outc) = splitCont cont - ; (env', expr') <- simplExprF (zapFloats env) expr inc - ; let tickish' = simplTickish env tickish - ; (env'', expr'') <- rebuild (zapFloats env') - (wrapFloats env' expr') - (TickIt tickish' outc) - ; return (addFloats env env'', expr'') - } - --- Alternative version that wraps outgoing floats with the tick. This --- results in ticks being duplicated, as we don't make any attempt to --- eliminate the tick if we re-inline the binding (because the tick --- semantics allows unrestricted inlining of HNFs), so I'm not doing --- this any more. FloatOut will catch any real opportunities for --- floating. --- --- wrap_floats = --- do { let (inc,outc) = splitCont cont --- ; (env', expr') <- simplExprF (zapFloats env) expr inc --- ; let tickish' = simplTickish env tickish --- ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0), --- mkTick (mkNoCount tickish') rhs) --- -- when wrapping a float with mkTick, we better zap the Id's --- -- strictness info and arity, because it might be wrong now. --- ; let env'' = addFloats env (mapFloats env' wrap_float) --- ; rebuild env'' expr' (TickIt tickish' outc) --- } - - - simplTickish env tickish - | Breakpoint n ids <- tickish - = Breakpoint n (map (getDoneId . substId env) ids) - | otherwise = tickish - - -- Push type application and coercion inside a tick - splitCont :: SimplCont -> (SimplCont, SimplCont) - splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) - where (inc,outc) = splitCont tail - splitCont (CastIt co c) = (CastIt co inc, outc) - where (inc,outc) = splitCont c - splitCont other = (mkBoringStop (contHoleType other), other) - - getDoneId (DoneId id) = id - getDoneId (DoneEx e) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst - getDoneId other = pprPanic "getDoneId" (ppr other) - --- Note [case-of-scc-of-case] --- It's pretty important to be able to transform case-of-case when --- there's an SCC in the way. For example, the following comes up --- in nofib/real/compress/Encode.hs: --- --- case scctick --- 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 --- (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 (SimplEnv, OutExpr) --- At this point the substitution in the SimplEnv should be irrelevant --- only the in-scope set and floats should matter -rebuild env expr cont - = case cont of - Stop {} -> return (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 `setFloats` env) expr bndr alts cont - - StrictArg info _ cont -> rebuildCall env (info `addValArgTo` expr) cont - StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr - -- expr satisfies let/app since it started life - -- in a call to simplNonRecE - ; simplLam env' bs body cont } - - 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] - | isSimplified dup_flag - -> rebuild env (App expr arg) cont - - | otherwise - -> do { arg' <- simplExpr (se `setInScopeAndZapFloats` env) arg - ; rebuild env (App expr arg') cont } - - -{- -************************************************************************ -* * -\subsection{Lambdas} -* * -************************************************************************ --} - -simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont - -> SimplM (SimplEnv, OutExpr) -simplCast env body co0 cont0 - = do { co1 <- simplCoercion env co0 - ; cont1 <- addCoerce co1 cont0 - ; simplExprF env body cont1 } - where - addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont - addCoerce co1 (CastIt co2 cont) - = addCoerce (mkTransCo co1 co2) cont - - addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) - | Just (arg_ty', co') <- pushCoTyArg co arg_ty - = do { tail' <- addCoerce co' tail - ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) } - - addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup, sc_cont = tail }) - | Just (co1, co2) <- pushCoValArg co - , Pair _ new_ty <- coercionKind co1 - , not (isTypeLevPoly new_ty) -- without this check, we get a lev-poly arg - -- See Note [Levity polymorphism invariants] in CoreSyn - -- test: typecheck/should_run/EtaExpandLevPoly - = do { tail' <- addCoerce co2 tail - ; if isReflCo co1 - then return (cont { sc_cont = tail' }) - -- Avoid simplifying if possible; - -- See Note [Avoiding exponential behaviour] - else do - { (dup', arg_se', arg') <- simplArg env dup arg_se arg - -- When we build the ApplyTo we can't mix the OutCoercion - -- 'co' with the InExpr 'arg', so we simplify - -- to make it all consistent. It's a bit messy. - -- But it isn't a common case. - -- Example of use: Trac #995 - ; return (ApplyToVal { sc_arg = mkCast arg' co1 - , sc_env = arg_se' - , sc_dup = dup' - , sc_cont = tail' }) } } - - addCoerce co cont - | isReflexiveCo co = return cont - | otherwise = return (CastIt co cont) - -- It's worth checking isReflexiveCo. - -- For example, in the initial form of a worker - -- we may find (coerce T (coerce S (\x.e))) y - -- and we'd like it to simplify to e[y/x] in one round - -- of simplification - -simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr - -> SimplM (DupFlag, StaticEnv, OutExpr) -simplArg env dup_flag arg_env arg - | isSimplified dup_flag - = return (dup_flag, arg_env, arg) - | otherwise - = do { arg' <- simplExpr (arg_env `setInScopeAndZapFloats` env) arg - ; return (Simplified, zapSubstEnv arg_env, arg') } - -{- -************************************************************************ -* * -\subsection{Lambdas} -* * -************************************************************************ - -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. --} - -simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont - -> SimplM (SimplEnv, OutExpr) - -simplLam env [] body cont = simplExprF env body cont - - -- Beta reduction - -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) - ; env' <- simplNonRecX env zapped_bndr arg - ; simplLam env' bndrs body cont } - - | 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, isStableUnfolding (realIdUnfolding bndr) - = setIdUnfolding bndr NoUnfolding - | 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 } - -simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) -simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs - -------------- -simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- Used for lambda binders. These sometimes have unfoldings added by --- the worker/wrapper pass that must be preserved, because they can't --- be reconstructed from context. For example: --- f x = case x of (a,b) -> fw a b x --- fw a b x{=(a,b)} = ... --- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise. -simplLamBndr env bndr - | isId bndr && isFragileUnfolding old_unf -- Special case - = do { (env1, bndr1) <- simplBinder env bndr - ; unf' <- simplUnfolding env1 NotTopLevel Nothing bndr old_unf - ; let bndr2 = bndr1 `setIdUnfolding` unf' - ; return (modifyInScope env1 bndr2, bndr2) } - - | otherwise - = simplBinder env bndr -- Normal case - where - old_unf = idUnfolding bndr - ------------------- -simplNonRecE :: SimplEnv - -> InId -- The binder, always an Id - -- Can be a join point - -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) - -> ([InBndr], InExpr) -- Body of the let/lambda - -- \xs.e - -> SimplCont - -> SimplM (SimplEnv, OutExpr) - --- simplNonRecE is used for --- * non-top-level non-recursive lets in expressions --- * beta reduction --- --- It deals with strict bindings, via the StrictBind continuation, --- which may abort the whole process --- --- Precondition: rhs satisfies the let/app invariant --- Note [CoreSyn let/app invariant] in CoreSyn --- --- The "body" of the binding comes as a pair of ([InId],InExpr) --- representing a lambda; so we recurse back to simplLam --- Why? Because of the binder-occ-info-zapping done before --- the call to simplLam in simplExprF (Lam ...) - -simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont - = ASSERT( isId bndr ) - do dflags <- getDynFlags - case () of - _ | preInlineUnconditionally dflags env NotTopLevel bndr rhs - -> do { tick (PreInlineUnconditionally bndr) - ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ - simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } - - | isStrictId bndr -- Includes coercions - -> simplExprF (rhs_se `setFloats` env) rhs - (StrictBind bndr bndrs body env cont) - - | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs - -> do { let cont_dup_res_ty = resultTypeOfDupableCont (getMode env) - [bndr'] cont - ; (env1, bndr1) <- simplNonRecJoinBndr env - cont_dup_res_ty bndr' - ; (env2, bndr2) <- addBndrRules env1 bndr' bndr1 - ; (env3, cont_dup, cont_nodup) - <- prepareLetCont (zapJoinFloats env2) [bndr'] cont - ; MASSERT2(cont_dup_res_ty `eqType` contResultType cont_dup, - ppr cont_dup_res_ty $$ blankLine $$ - ppr cont $$ blankLine $$ - ppr cont_dup $$ blankLine $$ - ppr cont_nodup) - ; env4 <- simplJoinBind env3 NonRecursive cont_dup bndr' bndr2 - rhs' rhs_se - ; (env5, expr) <- simplLam env4 bndrs body cont_dup - ; rebuild (env5 `restoreJoinFloats` env2) - (wrapJoinFloats env5 expr) cont_nodup } - - | otherwise - -> ASSERT( not (isTyVar bndr) ) - do { (env1, bndr1) <- simplNonRecBndr env bndr - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 - ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se - ; simplLam env3 bndrs body cont } - ------------------- -simplRecE :: SimplEnv - -> [(InId, InExpr)] - -> InExpr - -> SimplCont - -> SimplM (SimplEnv, OutExpr) - --- simplRecE is used for --- * non-top-level recursive lets in expressions -simplRecE env pairs body cont - | Just pairs' <- joinPointBindings_maybe pairs - = do { let bndrs' = map fst pairs' - cont_dup_res_ty = resultTypeOfDupableCont (getMode env) - bndrs' cont - ; env1 <- simplRecJoinBndrs env cont_dup_res_ty bndrs' - -- NB: bndrs' don't have unfoldings or rules - -- We add them as we go down - ; (env2, cont_dup, cont_nodup) <- prepareLetCont (zapJoinFloats env1) - bndrs' cont - ; MASSERT2(cont_dup_res_ty `eqType` contResultType cont_dup, - ppr cont_dup_res_ty $$ blankLine $$ - ppr cont $$ blankLine $$ - ppr cont_dup $$ blankLine $$ - ppr cont_nodup) - ; env3 <- simplRecBind env2 NotTopLevel (Just cont_dup) pairs' - ; (env4, expr) <- simplExprF env3 body cont_dup - ; rebuild (env4 `restoreJoinFloats` env1) - (wrapJoinFloats env4 expr) cont_nodup } - | otherwise - = 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 - ; env2 <- simplRecBind env1 NotTopLevel Nothing pairs - ; simplExprF env2 body cont } - - -{- -************************************************************************ -* * - Variables -* * -************************************************************************ --} - -simplVar :: SimplEnv -> InVar -> SimplM OutExpr --- Look up an InVar in the environment -simplVar env var - | isTyVar var = return (Type (substTyVar env var)) - | isCoVar var = return (Coercion (substCoVar env var)) - | otherwise - = case substId env var of - DoneId var1 -> return (Var var1) - DoneEx e -> return e - ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e - -simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplIdF env var cont - = case substId env var of - DoneEx e -> simplExprF (zapSubstEnv env) e trimmed_cont - ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont - -- Don't trim; haven't already simplified - -- the join, so the cont was never copied - DoneId var1 -> completeCall env var1 trimmed_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!! - where - trimmed_cont | Just arity <- isJoinIdInEnv_maybe env var - = trim_cont arity cont - | otherwise - = cont - - -- Drop outer context from join point invocation - -- Note [Case-of-case and join points] - trim_cont 0 cont@(Stop {}) - = cont - trim_cont 0 cont - = mkBoringStop (contResultType cont) - trim_cont n cont@(ApplyToVal { sc_cont = k }) - = cont { sc_cont = trim_cont (n-1) k } - trim_cont n cont@(ApplyToTy { sc_cont = k }) - = cont { sc_cont = trim_cont (n-1) k } -- join arity counts types! - trim_cont _ cont - = pprPanic "completeCall" $ ppr var $$ ppr cont - ---------------------------------------------------------- --- Dealing with a call site - -completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplEnv, OutExpr) -completeCall env var cont - = do { ------------- Try inlining ---------------- - dflags <- getDynFlags - ; let (lone_variable, arg_infos, call_cont) = contArgs cont - n_val_args = length arg_infos - interesting_cont = interestingCallContext call_cont - unfolding = activeUnfolding env var - maybe_inline = callSiteInline dflags var unfolding - lone_variable arg_infos interesting_cont - ; case maybe_inline of - Just expr -- There is an inlining! - -> do { checkedTick (UnfoldingDone var) - ; dump_inline dflags expr cont - ; simplExprF (zapSubstEnv env) expr cont } - - ; Nothing -> do { rule_base <- getSimplRules - ; let info = mkArgInfo var (getRules rule_base var) - n_val_args call_cont - ; rebuildCall env info cont } - } - where - dump_inline dflags unfolding cont - | not (dopt Opt_D_dump_inlinings dflags) = return () - | not (dopt Opt_D_verbose_core2core dflags) - = when (isExternalName (idName var)) $ - liftIO $ printOutputForUser dflags alwaysQualify $ - sep [text "Inlining done:", nest 4 (ppr var)] - | otherwise - = liftIO $ printOutputForUser dflags alwaysQualify $ - sep [text "Inlining done: " <> ppr var, - nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), - text "Cont: " <+> ppr cont])] - -rebuildCall :: SimplEnv - -> ArgInfo - -> SimplCont - -> SimplM (SimplEnv, OutExpr) --- We decided not to inline, so --- - simplify the arguments --- - try rewrite rules --- - and rebuild - ----------- Bottoming applications -------------- -rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont - -- When we run out of strictness args, it means - -- that the call is definitely bottom; see SimplUtils.mkArgInfo - -- Then we want to discard the entire strict continuation. E.g. - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - -- Then, especially in the first of these cases, we'd like to discard - -- the continuation, leaving just the bottoming expression. But the - -- type might not be right, so we may have to add a coerce. - | not (contIsTrivial cont) -- Only do this if there is a non-trivial - -- continuation to discard, else we do it - -- again and again! - = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] - return (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 - -- so try rewrite rules; see Note [RULEs apply to simplified arguments] - -- See also Note [Rules for recursive functions] - do { mb_match <- tryRules env rules fun (reverse rev_args) cont - ; case mb_match of - Just (env', rhs, cont') -> simplExprF env' rhs cont' - Nothing -> rebuildCall env info' cont } - where - no_more_args = case cont of - ApplyToTy {} -> False - ApplyToVal {} -> False - _ -> True - - ----------- Simplify applications and casts -------------- -rebuildCall env info (CastIt co cont) - = rebuildCall env (addCastTo info co) cont - -rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) - = rebuildCall env (addTyArgTo info arg_ty) cont - -rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty - , ai_strs = str:strs, ai_discs = disc:discs }) - (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup_flag, sc_cont = cont }) - | isSimplified dup_flag -- See Note [Avoid redundant simplification] - = rebuildCall env (addValArgTo info' arg) cont - - | str -- Strict argument - = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ - simplExprF (arg_se `setFloats` env) arg - (StrictArg info' cci_strict cont) - -- Note [Shadowing] - - | otherwise -- Lazy argument - -- DO NOT float anything outside, hence simplExprC - -- There is no benefit (unlike in a let-binding), and we'd - -- have to be very careful about bogus strictness through - -- floating a demanded let. - = do { arg' <- simplExprC (arg_se `setInScopeAndZapFloats` env) arg - (mkLazyArgStop arg_ty cci_lazy) - ; rebuildCall env (addValArgTo info' arg') cont } - where - info' = info { ai_strs = strs, ai_discs = discs } - arg_ty = funArgTy fun_ty - - -- Use this for lazy arguments - cci_lazy | encl_rules = RuleArgCtxt - | disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = BoringCtxt -- Nothing interesting - - -- ..and this for strict arguments - cci_strict | encl_rules = RuleArgCtxt - | disc > 0 = DiscArgCtxt - | otherwise = RhsCtxt - -- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we - -- want to be a bit more eager to inline g, because it may - -- expose an eval (on x perhaps) that can be eliminated or - -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1 - -- It's worth an 18% improvement in allocation for this - -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier' - ----------- No further useful info, revert to generic rebuild ------------ -rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont - = rebuild env (argInfoExpr fun rev_args) cont - -{- Note [Trying rewrite rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet -simplified. We want to simplify enough arguments to allow the rules -to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone -is sufficient. Example: class ops - (+) dNumInt e2 e3 -If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the -latter's strictness when simplifying e2, e3. Moreover, suppose we have - RULE f Int = \x. x True - -Then given (f Int e1) we rewrite to - (\x. x True) e1 -without simpifying 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 { dflags <- getDynFlags - ; 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 = mkMachInt 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)) } --} - | otherwise - = do { dflags <- getDynFlags - ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env) - fn (argInfoAppArgs args) rules of { - Nothing -> - do { nodump dflags -- This ensures that an empty file is written - ; return Nothing } ; -- No rule matches - Just (rule, rule_rhs) -> - 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 dflags 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 - where - zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] - - printRuleModule rule = - parens - (maybe (text "BUILTIN") (pprModuleName . moduleName) (ruleModule rule)) - - dump dflags rule rule_rhs - | dopt Opt_D_dump_rule_rewrites dflags - = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat - [ text "Rule:" <+> ftext (ruleName rule) - , text "Module:" <+> printRuleModule rule - , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) - , text "After: " <+> pprCoreExpr rule_rhs - , text "Cont: " <+> ppr call_cont ] - - | dopt Opt_D_dump_rule_firings dflags - = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ - ftext (ruleName rule) - <+> printRuleModule rule - - | otherwise - = return () - - nodump dflags - | dopt Opt_D_dump_rule_rewrites dflags - = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_rewrites "" empty - - | dopt Opt_D_dump_rule_firings dflags - = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_firings "" empty - - | otherwise - = return () - - log_rule dflags flag hdr details - = liftIO . dumpSDoc dflags alwaysQualify flag "" $ - sep [text hdr, nest 4 details] - -trySeqRules :: SimplEnv - -> OutExpr -> InExpr -- Scrutinee and RHS - -> SimplCont - -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) --- See Note [User-defined RULES for seq] -trySeqRules in_env scrut rhs cont - = do { rule_base <- getSimplRules - ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont } - where - no_cast_scrut = drop_casts scrut - scrut_ty = exprType no_cast_scrut - seq_id_ty = idType seqId - rhs_ty = substTy in_env (exprType rhs) - out_args = [ TyArg { as_arg_ty = scrut_ty - , as_hole_ty = seq_id_ty } - , TyArg { as_arg_ty = rhs_ty - , as_hole_ty = piResultTy seq_id_ty scrut_ty } - , ValArg no_cast_scrut] - rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs - , sc_env = in_env, sc_cont = cont } - -- Lazily evaluated, so we don't do most of this - - drop_casts (Cast e _) = drop_casts e - drop_casts e = e - -{- Note [User-defined RULES for seq] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given - case (scrut |> co) of _ -> rhs -look for rules that match the expression - seq @t1 @t2 scrut -where scrut :: t1 - rhs :: t2 - -If you find a match, rewrite it, and apply to 'rhs'. - -Notice that we can simply drop casts on the fly here, which -makes it more likely that a rule will match. - -See Note [User-defined RULES for seq] in MkId. - -Note [Occurrence-analyse after rule firing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After firing a rule, we occurrence-analyse the instantiated RHS before -simplifying it. Usually this doesn't make much difference, but it can -be huge. Here's an example (simplCore/should_compile/T7785) - - map f (map f (map f xs) - -= -- Use build/fold form of map, twice - map f (build (\cn. foldr (mapFB c f) n - (build (\cn. foldr (mapFB c f) n xs)))) - -= -- Apply fold/build rule - map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) - -= -- Beta-reduce - -- Alas we have no occurrence-analysed, so we don't know - -- that c is used exactly once - map f (build (\cn. let c1 = mapFB c f in - foldr (mapFB c1 f) n xs)) - -= -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) - -- We can do this because (mapFB c n) is a PAP and hence expandable - map f (build (\cn. let c1 = mapFB c n in - foldr (mapFB c (f.f)) n x)) - -This is not too bad. But now do the same with the outer map, and -we get another use of mapFB, and t can interact with /both/ remaining -mapFB calls in the above expression. This is stupid because actually -that 'c1' binding is dead. The outer map introduces another c2. If -there is a deep stack of maps we get lots of dead bindings, and lots -of redundant work as we repeatedly simplify the result of firing rules. - -The easy thing to do is simply to occurrence analyse the result of -the rule firing. Note that this occ-anals not only the RHS of the -rule, but also the function arguments, which by now are OutExprs. -E.g. - RULE f (g x) = x+1 - -Call f (g BIG) --> (\x. x+1) BIG - -The rule binders are lambda-bound and applied to the OutExpr arguments -(here BIG) which lack all internal occurrence info. - -Is this inefficient? Not really: we are about to walk over the result -of the rule firing to simplify it, so occurrence analysis is at most -a constant factor. - -Possible improvement: occ-anal the rules when putting them in the -database; and in the simplifier just occ-anal the OutExpr arguments. -But that's more complicated and the rule RHS is usually tiny; so I'm -just doing the simple thing. - -Historical note: previously we did occ-anal the rules in Rule.hs, -but failed to occ-anal the OutExpr arguments, which led to the -nasty performance problem described above. - - -Note [Optimising tagToEnum#] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an enumeration data type: - - data Foo = A | B | C - -Then we want to transform - - case tagToEnum# x of ==> case x of - A -> e1 DEFAULT -> e1 - B -> e2 1# -> e2 - C -> e3 2# -> e3 - -thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT -alternative we retain it (remember it comes first). If not the case must -be exhaustive, and we reflect that in the transformed version by adding -a DEFAULT. Otherwise Lint complains that the new case is not exhaustive. -See #8317. - -Note [Rules for recursive functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that we shouldn't apply rules for a loop breaker: -doing so might give rise to an infinite loop, because a RULE is -rather like an extra equation for the function: - RULE: f (g x) y = x+y - Eqn: f a y = a-y - -But it's too drastic to disable rules for loop breakers. -Even the foldr/build rule would be disabled, because foldr -is recursive, and hence a loop breaker: - foldr k z (build g) = g k z -So it's up to the programmer: rules can cause divergence - - -************************************************************************ -* * - Rebuilding a case expression -* * -************************************************************************ - -Note [Case elimination] -~~~~~~~~~~~~~~~~~~~~~~~ -The case-elimination transformation discards redundant case expressions. -Start with a simple situation: - - case x# of ===> let y# = x# in e - y# -> e - -(when x#, y# are of primitive type, of course). We can't (in general) -do this for algebraic cases, because we might turn bottom into -non-bottom! - -The code in SimplUtils.prepareAlts has the effect of generalise this -idea to look for a case where we're scrutinising a variable, and we -know that only the default case can match. For example: - - case x of - 0# -> ... - DEFAULT -> ...(case x of - 0# -> ... - DEFAULT -> ...) ... - -Here the inner case is first trimmed to have only one alternative, the -DEFAULT, after which it's an instance of the previous case. This -really only shows up in eliminating error-checking code. - -Note that SimplUtils.mkCase combines identical RHSs. So - - case e of ===> case e of DEFAULT -> r - True -> r - False -> r - -Now again the case may be elminated by the CaseElim transformation. -This includes things like (==# a# b#)::Bool so that we simplify - case ==# a# b# of { True -> x; False -> x } -to just - x -This particular example shows up in default methods for -comparison operations (e.g. in (>=) for Int.Int32) - -Note [Case to let transformation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a case over a lifted type has a single alternative, and is being -used as a strict 'let' (all isDeadBinder bndrs), we may want to do -this transformation: - - case e of r ===> let r = e in ...r... - _ -> ...r... - -We treat the unlifted and lifted cases separately: - -* Unlifted case: 'e' satisfies exprOkForSpeculation - (ok-for-spec is needed to satisfy the let/app invariant). - This turns case a +# b of r -> ...r... - into let r = a +# b in ...r... - and thence .....(a +# b).... - - However, if we have - case indexArray# a i of r -> ...r... - we might like to do the same, and inline the (indexArray# a i). - But indexArray# is not okForSpeculation, so we don't build a let - in rebuildCase (lest it get floated *out*), so the inlining doesn't - happen either. Annoying. - -* Lifted case: we need to be sure that the expression is already - evaluated (exprIsHNF). If it's not already evaluated - - we risk losing exceptions, divergence or - user-specified thunk-forcing - - even if 'e' is guaranteed to converge, we don't want to - create a thunk (call by need) instead of evaluating it - right away (call by value) - - However, we can turn the case into a /strict/ let if the 'r' is - used strictly in the body. Then we won't lose divergence; and - we won't build a thunk because the let is strict. - See also Note [Eliminating redundant seqs] - - NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in MkCore. - We want to turn - case (absentError "foo") of r -> ...MkT r... - into - let r = absentError "foo" in ...MkT r... - - -Note [Eliminating redundant seqs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have this: - case x of r { _ -> ..r.. } -where 'r' is used strictly in (..r..), the case is effectively a 'seq' -on 'x', but since 'r' is used strictly anyway, we can safely transform to - (...x...) - -Note that this can change the error behaviour. For example, we might -transform - case x of { _ -> error "bad" } - --> error "bad" -which is might be puzzling if 'x' currently lambda-bound, but later gets -let-bound to (error "good"). - -Nevertheless, the paper "A semantics for imprecise exceptions" allows -this transformation. If you want to fix the evaluation order, use -'pseq'. See Trac #8900 for an example where the loss of this -transformation bit us in practice. - -See also Note [Empty case alternatives] in CoreSyn. - -Just for reference, the original code (added Jan 13) 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 came up when fixing Trac #7542. See also Note [Eta reduction of -an eval'd function] in CoreUtils.) - - -Further notes about case elimination -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: test :: Integer -> IO () - test = print - -Turns out that this compiles to: - Print.test - = \ eta :: Integer - eta1 :: Void# -> - case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> - case hPutStr stdout - (PrelNum.jtos eta ($w[] @ Char)) - eta1 - of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} - -Notice the strange '<' which has no effect at all. This is a funny one. -It started like this: - -f x y = if x < 0 then jtos x - else if y==0 then "" else jtos x - -At a particular call site we have (f v 1). So we inline to get - - if v < 0 then jtos x - else if 1==0 then "" else jtos x - -Now simplify the 1==0 conditional: - - if v<0 then jtos v else jtos v - -Now common-up the two branches of the case: - - case (v<0) of DEFAULT -> jtos v - -Why don't we drop the case? Because it's strict in v. It's technically -wrong to drop even unnecessary evaluations, and in practice they -may be a result of 'seq' so we *definitely* don't want to drop those. -I don't really know how to improve this situation. --} - ---------------------------------------------------------- --- Eliminate the case if possible - -rebuildCase, reallyRebuildCase - :: SimplEnv - -> OutExpr -- Scrutinee - -> InId -- Case binder - -> [InAlt] -- Alternatives (inceasing order) - -> SimplCont - -> SimplM (SimplEnv, OutExpr) - --------------------------------------------------- --- 1. Eliminate the case if there's a known constructor --------------------------------------------------- - -rebuildCase env scrut case_bndr alts cont - | Lit lit <- scrut -- No need for same treatment as constructors - -- because literals are inlined more vigorously - , not (litIsLifted lit) - = do { tick (KnownBranch case_bndr) - ; case findAlt (LitAlt lit) alts of - Nothing -> missingAlt env case_bndr alts cont - Just (_, bs, rhs) -> simple_rhs bs rhs } - - | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut - -- Works when the scrutinee is a variable with a known unfolding - -- as well as when it's an explicit constructor application - = do { tick (KnownBranch case_bndr) - ; case findAlt (DataAlt con) alts of - Nothing -> missingAlt env case_bndr alts cont - Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs - Just (_, bs, rhs) -> knownCon env scrut con ty_args other_args - case_bndr bs rhs cont - } - where - simple_rhs bs rhs = ASSERT( null bs ) - do { env' <- simplNonRecX env case_bndr scrut - -- scrut is a constructor application, - -- hence satisfies let/app invariant - ; simplExprF env' rhs cont } - - --------------------------------------------------- --- 2. Eliminate the case if scrutinee is evaluated --------------------------------------------------- - -rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont - -- See if we can get rid of the case altogether - -- See Note [Case elimination] - -- mkCase made sure that if all the alternatives are equal, - -- then there is now only one (DEFAULT) rhs - - -- 2a. Dropping the case altogether, if - -- a) it binds nothing (so it's really just a 'seq') - -- b) evaluating the scrutinee has no side effects - | is_plain_seq - , exprOkForSideEffects scrut - -- The entire case is dead, so we can drop it - -- if the scrutinee converges without having imperative - -- side effects or raising a Haskell exception - -- See Note [PrimOp can_fail and has_side_effects] in PrimOp - = simplExprF env rhs cont - - -- 2b. Turn the case into a let, if - -- a) it binds only the case-binder - -- b) unlifted case: the scrutinee is ok-for-speculation - -- lifted case: the scrutinee is in HNF (or will later be demanded) - -- See Note [Case to let transformation] - | all_dead_bndrs - , if isUnliftedType (idType case_bndr) - then exprOkForSpeculation scrut - else exprIsHNF scrut || scrut_is_demanded_var scrut - = do { tick (CaseElim case_bndr) - ; env' <- simplNonRecX env case_bndr scrut - ; simplExprF env' rhs cont } - - -- 2c. Try the seq rules if - -- a) it binds only the case binder - -- b) a rule for seq applies - -- See Note [User-defined RULES for seq] in MkId - | is_plain_seq - = do { mb_rule <- trySeqRules env scrut rhs cont - ; case mb_rule of - Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' - Nothing -> reallyRebuildCase env scrut case_bndr alts cont } - where - all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] - is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect - - scrut_is_demanded_var :: CoreExpr -> Bool - -- See Note [Eliminating redundant seqs] - scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s - scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr) - scrut_is_demanded_var _ = False - - -rebuildCase env scrut case_bndr alts cont - = reallyRebuildCase env scrut case_bndr alts cont - --------------------------------------------------- --- 3. Catch-all case --------------------------------------------------- - -reallyRebuildCase env scrut case_bndr alts cont - = do { -- Prepare the continuation; - -- The new subst_env is in place - (env', dup_cont, nodup_cont) <- prepareCaseCont (zapJoinFloats env) - alts cont - - -- Simplify the alternatives - ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont - - ; dflags <- getDynFlags - ; let alts_ty' = contResultType dup_cont - -- See Note [Avoiding space leaks in OutType] - ; case_expr <- seqType alts_ty' `seq` - mkCase dflags scrut' case_bndr' alts_ty' alts' - - -- Notice that rebuild gets the in-scope set from env', not alt_env - -- (which in any case is only build in simplAlts) - -- The case binder *not* scope over the whole returned case-expression - ; rebuild (env' `restoreJoinFloats` env) - (wrapJoinFloats env' case_expr) nodup_cont } - -{- -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 analyer; see -OccurAnal Note [Binder swap]. - -Note [knownCon occ info] -~~~~~~~~~~~~~~~~~~~~~~~~ -If the case binder is not dead, then neither are the pattern bound -variables: - case of x { (a,b) -> - case x of { (p,q) -> p } } -Here (a,b) both look dead, but come alive after the inner case is eliminated. -The point is that we bring into the envt a binding - let x = (a,b) -after the outer case, and that makes (a,b) alive. At least we do unless -the case binder is guaranteed dead. - -Note [Case alternative occ info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are simply reconstructing a case (the common case), we always -zap the occurrence info on the binders in the alternatives. Even -if the case binder is dead, the scrutinee is usually a variable, and *that* -can bring the case-alternative binders back to life. -See Note [Add unfolding for scrutinee] - -Note [Improving seq] -~~~~~~~~~~~~~~~~~~~ -Consider - type family F :: * -> * - type instance F Int = Int - -We'd like to transform - case e of (x :: F Int) { DEFAULT -> rhs } -===> - case e `cast` co of (x'::Int) - I# x# -> let x = x' `cast` sym co - in rhs - -so that 'rhs' can take advantage of the form of x'. Notice that Note -[Case of cast] (in OccurAnal) may then apply to the result. - -We'd also like to eliminate empty types (Trac #13468). So if - - data Void - type instance F Bool = Void - -then we'd like to transform - case (x :: F Bool) of { _ -> error "urk" } -===> - case (x |> co) of (x' :: Void) of {} - -Nota Bene: we used to have a built-in rule for 'seq' that dropped -casts, so that - case (x |> co) of { _ -> blah } -dropped the cast; in order to imporove the chances of trySeqRules -firing. But that works in the /opposite/ direction to Note [Improving -seq] so there's a danger of flip/flopping. Better to make trySeqRules -insensitive to the cast, which is now is. - -The need for [Improving seq] showed up in Roman's experiments. Example: - foo :: F Int -> Int -> Int - foo t n = t `seq` bar n - where - bar 0 = 0 - bar n = bar (n - case t of TI i -> i) -Here we'd like to avoid repeated evaluating t inside the loop, by -taking advantage of the `seq`. - -At one point I did transformation in LiberateCase, but it's more -robust here. (Otherwise, there's a danger that we'll simply drop the -'seq' altogether, before LiberateCase gets to see it.) --} - -simplAlts :: SimplEnv - -> OutExpr - -> InId -- Case binder - -> [InAlt] -- Non-empty - -> SimplCont - -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation --- Like simplExpr, this just returns the simplified alternatives; --- it does not return an environment --- The returned alternatives can be empty, none are possible - -simplAlts env scrut case_bndr alts cont' - = do { let env0 = zapFloats env - - ; (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') $ - return (scrut', case_bndr', alts') } - - ------------------------------------- -improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv - -> OutExpr -> InId -> OutId -> [InAlt] - -> SimplM (SimplEnv, OutExpr, OutId) --- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] - | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId (fsLit "nt") ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) - env2 = extendIdSubst env case_bndr rhs - ; return (env2, scrut `Cast` co, case_bndr2) } - -improveSeq _ env scrut _ case_bndr1 _ - = return (env, scrut, case_bndr1) - - ------------------------------------- -simplAlt :: SimplEnv - -> Maybe OutExpr -- The scrutinee - -> [AltCon] -- These constructors can't be present when - -- matching the DEFAULT alternative - -> OutId -- The case binder - -> SimplCont - -> InAlt - -> SimplM OutAlt - -simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) - = ASSERT( null bndrs ) - do { let env' = addBinderUnfolding env case_bndr' - (mkOtherCon imposs_deflt_cons) - -- Record the constructors that the case-binder *can't* be. - ; rhs' <- simplExprC env' rhs cont' - ; return (DEFAULT, [], rhs') } - -simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs) - = ASSERT( null bndrs ) - do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) - ; rhs' <- simplExprC env' rhs cont' - ; return (LitAlt lit, [], rhs') } - -simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs) - = do { -- Deal with the pattern-bound variables - -- Mark the ones that are in ! positions in the - -- data constructor as certainly-evaluated. - -- NB: simplLamBinders preserves this eval info - ; let vs_with_evals = add_evals (dataConRepStrictness con) - ; (env', vs') <- simplLamBndrs env vs_with_evals - - -- Bind the case-binder to (con args) - ; let inst_tys' = tyConAppArgs (idType case_bndr') - con_app :: OutExpr - con_app = mkConApp2 con inst_tys' vs' - - ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app - ; rhs' <- simplExprC env'' rhs cont' - ; return (DataAlt con, vs', rhs') } - where - -- add_evals records the evaluated-ness of the bound variables of - -- a case pattern. This is *important*. Consider - -- data T = T !Int !Int - -- - -- case x of { T a b -> T (a+1) b } - -- - -- We really must record that b is already evaluated so that we don't - -- go and re-evaluate it when constructing the result. - -- See Note [Data-con worker strictness] in MkId.hs - add_evals the_strs - = go vs the_strs - where - go [] [] = [] - go (v:vs') strs | isTyVar v = v : go vs' strs - go (v:vs') (str:strs) = zap str v : go vs' strs - go _ _ = pprPanic "cat_evals" - (ppr con $$ - ppr vs $$ - ppr_with_length 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)) - -- NB: If this panic triggers, note that - -- NoStrictnessMark doesn't print! - - zap 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 { dflags <- getDynFlags - ; let con_app_unf = mkSimpleUnfolding dflags con_app - env1 = addBinderUnfolding env case_bndr con_app_unf - - -- See Note [Add unfolding for scrutinee] - env2 = case scrut of - Just (Var v) -> addBinderUnfolding env1 v con_app_unf - Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ - mkSimpleUnfolding dflags (Cast con_app (mkSymCo co)) - _ -> env1 - - ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) - ; return env2 } - -addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv -addBinderUnfolding env bndr unf - | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf - = WARN( not (eqType (idType bndr) (exprType tmpl)), - ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) ) - modifyInScope env (bndr `setIdUnfolding` unf) - - | otherwise - = modifyInScope env (bndr `setIdUnfolding` unf) - -zapBndrOccInfo :: Bool -> Id -> Id --- Consider case e of b { (a,b) -> ... } --- Then if we bind b to (a,b) in "...", and b is not dead, --- then we must zap the deadness info on a,b -zapBndrOccInfo keep_occ_info pat_id - | keep_occ_info = pat_id - | otherwise = zapIdOccInfo pat_id - -{- Note [Case binder evaluated-ness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pin on a (OtherCon []) unfolding to the case-binder of a Case, -even though it'll be over-ridden in every case alternative with a more -informative unfolding. Why? Because suppose a later, less clever, pass -simply replaces all occurrences of the case binder with the binder itself; -then Lint may complain about the let/app invariant. Example - case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in .... - ; K -> blah } - -The let/app invariant requires that y is evaluated in the call to -reallyUnsafePtrEq#, which it is. But we still want that to be true if we -propagate binders to occurrences. - -This showed up in Trac #13027. - -Note [Add unfolding for scrutinee] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general it's unlikely that a variable scrutinee will appear -in the case alternatives case x of { ...x unlikely to appear... } -because the binder-swap in OccAnal has got rid of all such occcurrences -See Note [Binder swap] in OccAnal. - -BUT it is still VERY IMPORTANT to add a suitable unfolding for a -variable scrutinee, in simplAlt. Here's why - case x of y - (a,b) -> case b of c - I# v -> ...(f y)... -There is no occurrence of 'b' in the (...(f y)...). But y gets -the unfolding (a,b), and *that* mentions b. If f has a RULE - RULE f (p, I# q) = ... -we want that rule to match, so we must extend the in-scope env with a -suitable unfolding for 'y'. It's *essential* for rule matching; but -it's also good for case-elimintation -- suppose that 'f' was inlined -and did multi-level case analysis, then we'd solve it in one -simplifier sweep instead of two. - -Exactly the same issue arises in SpecConstr; -see Note [Add scrutinee to ValueEnv too] in SpecConstr - -HOWEVER, given - case x of y { Just a -> r1; Nothing -> r2 } -we do not want to add the unfolding x -> y to 'x', which might seem cool, -since 'y' itself has different unfoldings in r1 and r2. Reason: if we -did that, we'd have to zap y's deadness info and that is a very useful -piece of information. - -So instead we add the unfolding x -> Just a, and x -> Nothing in the -respective RHSs. - - -************************************************************************ -* * -\subsection{Known constructor} -* * -************************************************************************ - -We are a bit careful with occurrence info. Here's an example - - (\x* -> case x of (a*, b) -> f a) (h v, e) - -where the * means "occurs once". This effectively becomes - case (h v, e) of (a*, b) -> f a) -and then - let a* = h v; b = e in f a -and then - f (h v) - -All this should happen in one sweep. --} - -knownCon :: SimplEnv - -> OutExpr -- The scrutinee - -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) - -> InId -> [InBndr] -> InExpr -- The alternative - -> SimplCont - -> SimplM (SimplEnv, OutExpr) - -knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont - = do { env' <- bind_args env bs dc_args - ; env'' <- bind_case_bndr env' - ; simplExprF env'' rhs cont } - where - zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId - - -- Ugh! - bind_args env' [] _ = return 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] - ; env'' <- simplNonRecX env' b' arg -- arg satisfies let/app invariant - ; bind_args env'' bs' args } - - 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 env - | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut)) - | otherwise = do { dc_args <- mapM (simplVar env) bs - -- dc_ty_args are aready OutTypes, - -- but bs are InBndrs - ; let con_app = Var (dataConWorkId dc) - `mkTyApps` dc_ty_args - `mkApps` dc_args - ; simplNonRecX env bndr con_app } - -------------------- -missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, 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 (env, mkImpossibleExpr cont_ty) - -{- -************************************************************************ -* * -\subsection{Duplicating continuations} -* * -************************************************************************ --} - -prepareCaseCont :: SimplEnv - -> [InAlt] -> SimplCont - -> SimplM (SimplEnv, - SimplCont, -- Dupable part - SimplCont) -- Non-dupable part --- We are considering --- K[case _ of { p1 -> r1; ...; pn -> rn }] --- where K is some enclosing continuation for the case --- Goal: split K into two pieces Kdup,Knodup so that --- a) Kdup can be duplicated --- b) Knodup[Kdup[e]] = K[e] --- The idea is that we'll transform thus: --- Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] } --- --- We may also return some extra value bindings in SimplEnv (that scope over --- the entire continuation) as well as some join points (thus must *not* float --- past the continuation!). --- Hence, the full story is this: --- K[case _ of { p1 -> r1; ...; pn -> rn }] ==> --- F_v[Knodup[F_j[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }) ]]] --- Here F_v represents some values that got floated out and F_j represents some --- join points that got floated out. --- --- When case-of-case is off, just make the entire continuation non-dupable - -prepareCaseCont env alts cont - | not (sm_case_case (getMode env)) - = return (env, mkBoringStop (contHoleType cont), cont) - | not (altsWouldDup alts) - = return (env, cont, mkBoringStop (contResultType cont)) - | otherwise - = mkDupableCont env cont - -prepareLetCont :: SimplEnv - -> [InBndr] -> SimplCont - -> SimplM (SimplEnv, - SimplCont, -- Dupable part - SimplCont) -- Non-dupable part - --- Similar to prepareCaseCont, only for --- K[let { j1 = r1; ...; jn -> rn } in _] --- If the js are join points, this will turn into --- Knodup[join { j1 = Kdup[r1]; ...; jn = Kdup[rn] } in Kdup[_]]. --- --- When case-of-case is off and it's a join binding, just make the entire --- continuation non-dupable. This is necessary because otherwise --- case (join j = ... in case e of { A -> jump j 1; ... }) of { B -> ... } --- becomes --- join j = case ... of { B -> ... } in --- case (case e of { A -> jump j 1; ... }) of { B -> ... }, --- and the reference to j is invalid. - -prepareLetCont env bndrs cont - | not (isJoinId (head bndrs)) - = return (env, cont, mkBoringStop (contResultType cont)) - | not (sm_case_case (getMode env)) - = return (env, mkBoringStop (contHoleType cont), cont) - | otherwise - = mkDupableCont env cont - --- Predict the result type of the dupable cont returned by prepareLetCont (= the --- hole type of the non-dupable part). Ugly, but sadly necessary so that we can --- know what the new type of a recursive join point will be before we start --- simplifying it. -resultTypeOfDupableCont :: SimplifierMode - -> [InBndr] - -> SimplCont - -> OutType -- INVARIANT: Result type of dupable cont - -- returned by prepareLetCont --- IMPORTANT: This must be kept in sync with mkDupableCont! -resultTypeOfDupableCont mode bndrs cont - | not (any isJoinId bndrs) = contResultType cont - | not (sm_case_case mode) = contHoleType cont - | otherwise = go cont - where - go cont | contIsDupable cont = contResultType cont - go (Stop {}) = panic "typeOfDupableCont" -- Handled by previous eqn - go (CastIt _ cont) = go cont - go cont@(TickIt {}) = contHoleType cont - go cont@(StrictBind {}) = contHoleType cont - go (StrictArg _ _ cont) = go cont - go cont@(ApplyToTy {}) = go (sc_cont cont) - go cont@(ApplyToVal {}) = go (sc_cont cont) - go (Select { sc_alts = alts, sc_cont = cont }) - | not (sm_case_case mode) = contHoleType cont - | not (altsWouldDup alts) = contResultType cont - | otherwise = go cont - -altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative -altsWouldDup [] = False -- See Note [Bottom alternatives] -altsWouldDup [_] = False -altsWouldDup (alt:alts) - | is_bot_alt alt = altsWouldDup alts - | otherwise = not (all is_bot_alt alts) - where - is_bot_alt (_,_,rhs) = exprIsBottom rhs - -{- -Note [Bottom alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have - case (case x of { A -> error .. ; B -> e; C -> error ..) - of alts -then we can just duplicate those alts because the A and C cases -will disappear immediately. This is more direct than creating -join points and inlining them away. See Trac #4930. --} - -mkDupableCont :: SimplEnv -> SimplCont - -> SimplM (SimplEnv, SimplCont, SimplCont) - -mkDupableCont env cont - | contIsDupable cont - = return (env, cont, mkBoringStop (contResultType cont)) - -mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn - -mkDupableCont env (CastIt ty cont) - = do { (env', dup, nodup) <- mkDupableCont env cont - ; return (env', CastIt ty dup, nodup) } - --- Duplicating ticks for now, not sure if this is good or not -mkDupableCont env cont@(TickIt{}) - = return (env, mkBoringStop (contHoleType cont), cont) - -mkDupableCont env cont@(StrictBind {}) - = return (env, mkBoringStop (contHoleType cont), cont) - -- See Note [Duplicating StrictBind] - -mkDupableCont env (StrictArg info cci cont) - -- See Note [Duplicating StrictArg] - = do { (env', dup, nodup) <- mkDupableCont env cont - ; (env'', args') <- mapAccumLM makeTrivialArg env' (ai_args info) - ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) } - -mkDupableCont env cont@(ApplyToTy { sc_cont = tail }) - = do { (env', dup_cont, nodup_cont) <- mkDupableCont env tail - ; return (env', cont { sc_cont = dup_cont }, nodup_cont ) } - -mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se, sc_cont = cont }) - = -- e.g. [...hole...] (...arg...) - -- ==> - -- let a = ...arg... - -- in [...hole...] a - do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont - ; (_, se', arg') <- simplArg env' dup se arg - ; (env'', arg'') <- makeTrivial NotTopLevel env' (fsLit "karg") arg' - ; let app_cont = ApplyToVal { sc_arg = arg'', sc_env = se' - , sc_dup = OkToDup, sc_cont = dup_cont } - ; return (env'', app_cont, nodup_cont) } - -mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts - , sc_env = se, sc_cont = cont }) - = -- e.g. (case [...hole...] of { pi -> ei }) - -- ===> - -- let ji = \xij -> ei - -- in case [...hole...] of { pi -> ji xij } - do { tick (CaseOfCase case_bndr) - ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont - -- NB: We call prepareCaseCont here. If there is only one - -- alternative, then dup_cont may be big, but that's ok - -- because we push it into the single alternative, and then - -- use mkDupableAlt to turn that simplified alternative into - -- a join point if it's too big to duplicate. - -- And this is important: see Note [Fusing case continuations] - - ; let alt_env = se `setInScopeAndZapFloats` env' - - ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr - ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts - -- Safe to say that there are no handled-cons for the DEFAULT case - -- NB: simplBinder does not zap deadness occ-info, so - -- a dead case_bndr' will still advertise its deadness - -- This is really important because in - -- case e of b { (# p,q #) -> ... } - -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), - -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. - -- In the new alts we build, we have the new case binder, so it must retain - -- its deadness. - -- NB: we don't use alt_env further; it has the substEnv for - -- the alternatives, and we don't want that - - ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts' - ; return (env'', -- Note [Duplicated env] - Select { sc_dup = OkToDup - , sc_bndr = case_bndr', sc_alts = alts'' - , sc_env = zapSubstEnv env'' - , sc_cont = mkBoringStop (contHoleType nodup_cont) }, - nodup_cont) } - - -mkDupableAlts :: SimplEnv -> OutId -> [InAlt] - -> SimplM (SimplEnv, [InAlt]) --- Absorbs the continuation into the new alternatives - -mkDupableAlts env case_bndr' the_alts - = go env the_alts - where - go env0 [] = return (env0, []) - go env0 (alt:alts) - = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt - ; (env2, alts') <- go env1 alts - ; return (env2, alt' : alts' ) } - -mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr) - -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr)) -mkDupableAlt env case_bndr (con, bndrs', rhs') = do - dflags <- getDynFlags - if exprIsDupable dflags rhs' -- Note [Small alternative rhs] - then return (env, (con, bndrs', rhs')) - else - do { let rhs_ty' = exprType rhs' - scrut_ty = idType case_bndr - case_bndr_w_unf - = case con of - DEFAULT -> case_bndr - DataAlt dc -> setIdUnfolding case_bndr unf - where - -- See Note [Case binders and join points] - unf = mkInlineUnfolding rhs - rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' - - LitAlt {} -> WARN( True, text "mkDupableAlt" - <+> ppr case_bndr <+> ppr con ) - case_bndr - -- The case binder is alive but trivial, so why has - -- it not been substituted away? - - final_bndrs' - | isDeadBinder case_bndr = filter abstract_over bndrs' - | otherwise = bndrs' ++ [case_bndr_w_unf] - - abstract_over bndr - | isTyVar bndr = True -- Abstract over all type variables just in case - | otherwise = not (isDeadBinder bndr) - -- The deadness info on the new Ids is preserved by simplBinders - final_args -- Note [Join point abstraction] - = varsToCoreExprs final_bndrs' - - ; join_bndr <- newId (fsLit "$j") (mkLamTypes final_bndrs' rhs_ty') - -- Note [Funky mkLamTypes] - - ; let -- 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' - arity = length (filter (not . isTyVar) final_bndrs') - join_arity = length final_bndrs' - final_join_bndr = (join_bndr `setIdArity` arity) - `asJoinId` join_arity - join_call = mkApps (Var final_join_bndr) final_args - final_join_bind = NonRec final_join_bndr join_rhs - - ; env' <- addPolyBind NotTopLevel env final_join_bind - ; return (env', (con, bndrs', join_call)) } - -- See Note [Duplicated env] - -{- -Note [Fusing case continuations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important to fuse two successive case continuations when the -first has one alternative. That's why we call prepareCaseCont here. -Consider this, which arises from thunk splitting (see Note [Thunk -splitting] in WorkWrap): - - let - x* = case (case v of {pn -> rn}) of - I# a -> I# a - in body - -The simplifier will find - (Var v) with continuation - Select (pn -> rn) ( - Select [I# a -> I# a] ( - StrictBind body Stop - -So we'll call mkDupableCont on - Select [I# a -> I# a] (StrictBind body Stop) -There is just one alternative in the first Select, so we want to -simplify the rhs (I# a) with continuation (StricgtBind body Stop) -Supposing that body is big, we end up with - let $j a = - in case v of { pn -> case rn of - I# a -> $j a } -This is just what we want because the rn produces a box that -the case rn cancels with. - -See Trac #4957 a fuller example. - -Note [Case binders and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - case (case .. ) of c { - I# c# -> ....c.... - -If we make a join point with c but not c# we get - $j = \c -> ....c.... - -But if later inlining scrutinises the c, thus - - $j = \c -> ... case c of { I# y -> ... } ... - -we won't see that 'c' has already been scrutinised. This actually -happens in the 'tabulate' function in wave4main, and makes a significant -difference to allocation. - -An alternative plan is this: - - $j = \c# -> let c = I# c# in ...c.... - -but that is bad if 'c' is *not* later scrutinised. - -So instead we do both: we pass 'c' and 'c#' , and record in c's inlining -(a stable unfolding) that it's really I# c#, thus - - $j = \c# -> \c[=I# c#] -> ...c.... - -Absence analysis may later discard 'c'. - -NB: take great care when doing strictness analysis; - see Note [Lambda-bound unfoldings] in DmdAnal. - -Also note that we can still end up passing stuff that isn't used. Before -strictness analysis we have - let $j x y c{=(x,y)} = (h c, ...) - in ... -After strictness analysis we see that h is strict, we end up with - let $j x y c{=(x,y)} = ($wh x y, ...) -and c is unused. - -Note [Duplicated env] -~~~~~~~~~~~~~~~~~~~~~ -Some of the alternatives are simplified, but have not been turned into a join point -So they *must* have an zapped subst-env. So we can't use completeNonRecX to -bind the join point, because it might to do PostInlineUnconditionally, and -we'd lose that when zapping the subst-env. We could have a per-alt subst-env, -but zapping it (as we do in mkDupableCont, the Select case) is safe, and -at worst delays the join-point inlining. - -Note [Small alternative rhs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is worth checking for a small RHS because otherwise we -get extra let bindings that may cause an extra iteration of the simplifier to -inline back in place. Quite often the rhs is just a variable or constructor. -The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra -iterations because the version with the let bindings looked big, and so wasn't -inlined, but after the join points had been inlined it looked smaller, and so -was inlined. - -NB: we have to check the size of rhs', not rhs. -Duplicating a small InAlt might invalidate occurrence information -However, if it *is* dupable, we return the *un* simplified alternative, -because otherwise we'd need to pair it up with an empty subst-env.... -but we only have one env shared between all the alts. -(Remember we must zap the subst-env before re-simplifying something). -Rather than do this we simply agree to re-simplify the original (small) thing later. - -Note [Funky mkLamTypes] -~~~~~~~~~~~~~~~~~~~~~~ -Notice the funky mkLamTypes. If the constructor has existentials -it's possible that the join point will be abstracted over -type variables as well as term variables. - Example: Suppose we have - data T = forall t. C [t] - Then faced with - case (case e of ...) of - C t xs::[t] -> rhs - We get the join point - let j :: forall t. [t] -> ... - j = /\t \xs::[t] -> rhs - in - case (case e of ...) of - C t xs::[t] -> j t xs - -Note [Join point abstraction] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -NB: This note is now historical. 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 - - -Note [Duplicating StrictArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The original plan had (where E is a big argument) -e.g. f E [..hole..] - ==> let $j = \a -> f E a - in $j [..hole..] - -But this is terrible! Here's an example: - && E (case x of { T -> F; F -> T }) -Now, && is strict so we end up simplifying the case with - -an ArgOf continuation. If we let-bind it, we get - let $j = \v -> && E v - in simplExpr (case x of { T -> F; F -> T }) - (ArgOf (\r -> $j r) -And after simplifying more we get - let $j = \v -> && E v - in case x of { T -> $j F; F -> $j T } -Which is a Very Bad Thing - -What we do now is this - f E [..hole..] - ==> let a = E - in f a [..hole..] -Now if the thing in the hole is a case expression (which is when -we'll call mkDupableCont), we'll push the function call into the -branches, which is what we want. Now RULES for f may fire, and -call-pattern specialisation. Here's an example from Trac #3116 - go (n+1) (case l of - 1 -> bs' - _ -> Chunk p fpc (o+1) (l-1) bs') -If we can push the call for 'go' inside the case, we get -call-pattern specialisation for 'go', which is *crucial* for -this program. - -Here is the (&&) example: - && E (case x of { T -> F; F -> T }) - ==> let a = E in - case x of { T -> && a F; F -> && a T } -Much better! - -Notice that - * Arguments to f *after* the strict one are handled by - the ApplyToVal case of mkDupableCont. Eg - f [..hole..] E - - * We can only do the let-binding of E because the function - part of a StrictArg continuation is an explicit syntax - tree. In earlier versions we represented it as a function - (CoreExpr -> CoreEpxr) which we couldn't take apart. - -Do *not* duplicate StrictBind and StritArg continuations. We gain -nothing by propagating them into the expressions, and we do lose a -lot. - -The desire not to duplicate is the entire reason that -mkDupableCont returns a pair of continuations. - -Note [Duplicating StrictBind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unlike StrictArg, there doesn't seem anything to gain from -duplicating a StrictBind continuation, so we don't. - - -************************************************************************ -* * - Unfoldings -* * -************************************************************************ --} - -simplLetUnfolding :: SimplEnv-> TopLevelFlag - -> Maybe SimplCont - -> InId - -> OutExpr - -> Unfolding -> SimplM Unfolding -simplLetUnfolding env top_lvl cont_mb id new_rhs unf - | isStableUnfolding unf - = simplUnfolding env top_lvl cont_mb id unf - | otherwise - = is_bottoming `seq` -- See Note [Force bottoming field] - do { dflags <- getDynFlags - ; return (mkUnfolding dflags InlineRhs is_top_lvl is_bottoming new_rhs) } - -- We make an unfolding *even for loop-breakers*. - -- Reason: (a) It might be useful to know that they are WHNF - -- (b) In TidyPgm we currently assume that, if we want to - -- expose the unfolding then indeed we *have* an unfolding - -- to expose. (We could instead use the RHS, but currently - -- we don't.) The simple thing is always to have one. - where - is_top_lvl = isTopLevel top_lvl - is_bottoming = isBottomingId id - -simplUnfolding :: SimplEnv -> TopLevelFlag - -> Maybe SimplCont -- Just k => a join point with continuation k - -> InId - -> Unfolding -> SimplM Unfolding --- Note [Setting the new unfolding] -simplUnfolding env top_lvl mb_cont id 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 rule_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 -> simplJoinRhs rule_env id expr cont - Nothing -> simplExpr rule_env expr - ; case guide of - UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok } -- Happens for INLINE things - -> let guide' = UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok - , ug_boring_ok = inlineBoringOk expr' } - -- Refresh the boring-ok flag, in case expr' - -- has got small. This happens, notably in the inlinings - -- for dfuns for single-method classes; see - -- Note [Single-method classes] in TcInstDcls. - -- A test case is Trac #4138 - in return (mkCoreUnfolding src is_top_lvl expr' guide') - -- See Note [Top-level flag on inline rules] in CoreUnfold - - _other -- Happens for INLINABLE things - -> is_bottoming `seq` -- See Note [Force bottoming field] - do { dflags <- getDynFlags - ; return (mkUnfolding dflags src is_top_lvl is_bottoming 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 - is_top_lvl = isTopLevel top_lvl - is_bottoming = isBottomingId id - act = idInlineActivation id - rule_env = updMode (updModeForStableUnfoldings act) env - -- See Note [Simplifying inside stable unfoldings] in SimplUtils - -{- -Note [Force bottoming field] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to force bottoming, or the new unfolding holds -on to the old unfolding (which is part of the id). - -Note [Setting the new unfolding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* If there's an INLINE pragma, we simplify the RHS gently. Maybe we - should do nothing at all, but simplifying gently might get rid of - more crap. - -* If not, we make an unfolding from the new RHS. But *only* for - non-loop-breakers. Making loop breakers not have an unfolding at all - means that we can avoid tests in exprIsConApp, for example. This is - important: if exprIsConApp says 'yes' for a recursive thing, then we - can get into an infinite loop - -If there's an stable unfolding on a loop breaker (which happens for -INLINABLE), we hang on to the inlining. It's pretty dodgy, but the -user did say 'INLINE'. May need to revisit this choice. - -************************************************************************ -* * - Rules -* * -************************************************************************ - -Note [Rules in a letrec] -~~~~~~~~~~~~~~~~~~~~~~~~ -After creating fresh binders for the binders of a letrec, we -substitute the RULES and add them back onto the binders; this is done -*before* processing any of the RHSs. This is important. Manuel found -cases where he really, really wanted a RULE for a recursive function -to apply in that function's own right-hand side. - -See Note [Forming Rec groups] in OccurAnal --} - -addBndrRules :: SimplEnv -> InBndr -> OutBndr -> SimplM (SimplEnv, OutBndr) --- Rules are added back into the bin -addBndrRules env in_id out_id - | null old_rules - = return (env, out_id) - | otherwise - = do { new_rules <- simplRules env (Just (idName out_id)) old_rules - ; 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 Name -> [CoreRule] -> SimplM [CoreRule] -simplRules env mb_new_nm rules - = mapM simpl_rule rules - where - simpl_rule rule@(BuiltinRule {}) - = return rule - - simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args - , ru_fn = fn_name, ru_rhs = rhs }) - = do { (env', bndrs') <- simplBinders env bndrs - ; let rhs_ty = substTy env' (exprType rhs) - rule_cont = mkBoringStop rhs_ty - rule_env = updMode updModeForRules env' - ; args' <- mapM (simplExpr rule_env) args - ; rhs' <- simplExprC rule_env rhs rule_cont - ; return (rule { ru_bndrs = bndrs' - , ru_fn = mb_new_nm `orElse` fn_name - , ru_args = args' - , ru_rhs = rhs' }) } diff --git a/simplStg/RepType.hs b/simplStg/RepType.hs deleted file mode 100644 --- a/simplStg/RepType.hs +++ /dev/null @@ -1,365 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -module RepType - ( - -- * Code generator views onto Types - UnaryType, NvUnaryType, isNvUnaryType, - unwrapType, - - -- * Predicates on types - isVoidTy, - - -- * Type representation for the code generator - typePrimRep, typePrimRep1, - runtimeRepPrimRep, typePrimRepArgs, - PrimRep(..), primRepToType, - countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1, - - -- * Unboxed sum representation type - ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..), - slotPrimRep, primRepSlot - ) where - -#include "HsVersions.h" - -import BasicTypes (Arity, RepArity) -import DataCon -import Outputable -import PrelNames -import Coercion -import TyCon -import TyCoRep -import Type -import Util -import TysPrim -import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind ) - -import Data.List (foldl', sort) -import qualified Data.IntSet as IS - -{- ********************************************************************** -* * - Representation types -* * -********************************************************************** -} - -type NvUnaryType = Type -type UnaryType = Type - -- Both are always a value type; i.e. its kind is TYPE rr - -- for some rr; moreover the rr is never a variable. - -- - -- NvUnaryType : never an unboxed tuple or sum, or void - -- - -- UnaryType : never an unboxed tuple or sum; - -- can be Void# or (# #) - -isNvUnaryType :: Type -> Bool -isNvUnaryType ty - | [_] <- typePrimRep ty - = True - | otherwise - = False - --- INVARIANT: the result list is never empty. -typePrimRepArgs :: Type -> [PrimRep] -typePrimRepArgs ty - | [] <- reps - = [VoidRep] - | otherwise - = reps - where - reps = typePrimRep ty - --- | Gets rid of the stuff that prevents us from understanding the --- runtime representation of a type. Including: --- 1. Casts --- 2. Newtypes --- 3. Foralls --- 4. Synonyms --- But not type/data families, because we don't have the envs to hand. -unwrapType :: Type -> Type -unwrapType ty - | Just (_, unwrapped) - <- topNormaliseTypeX stepper mappend inner_ty - = unwrapped - | otherwise - = inner_ty - where - inner_ty = go ty - - go t | Just t' <- coreView t = go t' - go (ForAllTy _ t) = go t - go (CastTy t _) = go t - go t = t - - -- cf. Coercion.unwrapNewTypeStepper - stepper rec_nts tc tys - | Just (ty', _) <- instNewTyCon_maybe tc tys - = case checkRecTc rec_nts tc of - Just rec_nts' -> NS_Step rec_nts' (go ty') () - Nothing -> NS_Abort -- infinite newtypes - | otherwise - = NS_Done - -countFunRepArgs :: Arity -> Type -> RepArity -countFunRepArgs 0 _ - = 0 -countFunRepArgs n ty - | FunTy arg res <- unwrapType ty - = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res - | otherwise - = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) - -countConRepArgs :: DataCon -> RepArity -countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc) - where - go :: Arity -> Type -> RepArity - go 0 _ - = 0 - go n ty - | FunTy arg res <- unwrapType ty - = length (typePrimRep arg) + go (n - 1) res - | otherwise - = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) - --- | True if the type has zero width. -isVoidTy :: Type -> Bool -isVoidTy = null . typePrimRep - - -{- ********************************************************************** -* * - Unboxed sums - See Note [Translating unboxed sums to unboxed tuples] in UnariseStg.hs -* * -********************************************************************** -} - -type SortedSlotTys = [SlotTy] - --- | Given the arguments of a sum type constructor application, --- return the unboxed sum rep type. --- --- E.g. --- --- (# Int# | Maybe Int | (# Int#, Float# #) #) --- --- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`, --- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot] --- --- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head --- of the list we have the slot for the tag. -ubxSumRepType :: [[PrimRep]] -> [SlotTy] -ubxSumRepType constrs0 - -- These first two cases never classify an actual unboxed sum, which always - -- has at least two disjuncts. But it could happen if a user writes, e.g., - -- forall (a :: TYPE (SumRep [IntRep])). ... - -- which could never be instantiated. We still don't want to panic. - | length constrs0 < 2 - = [WordSlot] - - | otherwise - = let - combine_alts :: [SortedSlotTys] -- slots of constructors - -> SortedSlotTys -- final slots - combine_alts constrs = foldl' merge [] constrs - - merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys - merge existing_slots [] - = existing_slots - merge [] needed_slots - = needed_slots - merge (es : ess) (s : ss) - | Just s' <- s `fitsIn` es - = -- found a slot, use it - s' : merge ess ss - | s < es - = -- we need a new slot and this is the right place for it - s : merge (es : ess) ss - | otherwise - = -- keep searching for a slot - es : merge ess (s : ss) - - -- Nesting unboxed tuples and sums is OK, so we need to flatten first. - rep :: [PrimRep] -> SortedSlotTys - rep ty = sort (map primRepSlot ty) - - sumRep = WordSlot : combine_alts (map rep constrs0) - -- WordSlot: for the tag of the sum - in - sumRep - -layoutUbxSum :: SortedSlotTys -- Layout of sum. Does not include tag. - -- We assume that they are in increasing order - -> [SlotTy] -- Slot types of things we want to map to locations in the - -- sum layout - -> [Int] -- Where to map 'things' in the sum layout -layoutUbxSum sum_slots0 arg_slots0 = - go arg_slots0 IS.empty - where - go :: [SlotTy] -> IS.IntSet -> [Int] - go [] _ - = [] - go (arg : args) used - = let slot_idx = findSlot arg 0 sum_slots0 used - in slot_idx : go args (IS.insert slot_idx used) - - findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int - findSlot arg slot_idx (slot : slots) useds - | not (IS.member slot_idx useds) - , Just slot == arg `fitsIn` slot - = slot_idx - | otherwise - = findSlot arg (slot_idx + 1) slots useds - findSlot _ _ [] _ - = pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0) - --------------------------------------------------------------------------------- - --- We have 3 kinds of slots: --- --- - Pointer slot: Only shared between actual pointers to Haskell heap (i.e. --- boxed objects) --- --- - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep. --- --- - Float slots: Shared between floating point types. --- --- - Void slots: Shared between void types. Not used in sums. -data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot - deriving (Eq, Ord) - -- Constructor order is important! If slot A could fit into slot B - -- then slot A must occur first. E.g. FloatSlot before DoubleSlot - -- - -- We are assuming that WordSlot is smaller than or equal to Word64Slot - -- (would not be true on a 128-bit machine) - -instance Outputable SlotTy where - ppr PtrSlot = text "PtrSlot" - ppr Word64Slot = text "Word64Slot" - ppr WordSlot = text "WordSlot" - ppr DoubleSlot = text "DoubleSlot" - ppr FloatSlot = text "FloatSlot" - -typeSlotTy :: UnaryType -> Maybe SlotTy -typeSlotTy ty - | isVoidTy ty - = Nothing - | otherwise - = Just (primRepSlot (typePrimRep1 ty)) - -primRepSlot :: PrimRep -> SlotTy -primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") -primRepSlot LiftedRep = PtrSlot -primRepSlot UnliftedRep = PtrSlot -primRepSlot IntRep = WordSlot -primRepSlot WordRep = WordSlot -primRepSlot Int64Rep = Word64Slot -primRepSlot Word64Rep = Word64Slot -primRepSlot AddrRep = WordSlot -primRepSlot FloatRep = FloatSlot -primRepSlot DoubleRep = DoubleSlot -primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep") - -slotPrimRep :: SlotTy -> PrimRep -slotPrimRep PtrSlot = LiftedRep -- choice between lifted & unlifted seems arbitrary -slotPrimRep Word64Slot = Word64Rep -slotPrimRep WordSlot = WordRep -slotPrimRep DoubleSlot = DoubleRep -slotPrimRep FloatSlot = FloatRep - --- | Returns the bigger type if one fits into the other. (commutative) -fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy -fitsIn ty1 ty2 - | isWordSlot ty1 && isWordSlot ty2 - = Just (max ty1 ty2) - | isFloatSlot ty1 && isFloatSlot ty2 - = Just (max ty1 ty2) - | isPtrSlot ty1 && isPtrSlot ty2 - = Just PtrSlot - | otherwise - = Nothing - where - isPtrSlot PtrSlot = True - isPtrSlot _ = False - - isWordSlot Word64Slot = True - isWordSlot WordSlot = True - isWordSlot _ = False - - isFloatSlot DoubleSlot = True - isFloatSlot FloatSlot = True - isFloatSlot _ = False - - -{- ********************************************************************** -* * - PrimRep -* * -********************************************************************** -} - --- | Discovers the primitive representation of a 'Type'. Returns --- a list of 'PrimRep': it's a list because of the possibility of --- no runtime representation (void) or multiple (unboxed tuple/sum) -typePrimRep :: HasDebugCallStack => Type -> [PrimRep] -typePrimRep ty = kindPrimRep (text "typePrimRep" <+> - parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) - (typeKind ty) - --- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; --- an empty list of PrimReps becomes a VoidRep -typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep -typePrimRep1 ty = case typePrimRep ty of - [] -> VoidRep - [rep] -> rep - _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) - --- | Find the runtime representation of a 'TyCon'. Defined here to --- avoid module loops. Returns a list of the register shapes necessary. -tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep] -tyConPrimRep tc - = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) - res_kind - where - res_kind = tyConResKind tc - --- | Like 'tyConPrimRep', but assumed that there is precisely zero or --- one 'PrimRep' output -tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep -tyConPrimRep1 tc = case tyConPrimRep tc of - [] -> VoidRep - [rep] -> rep - _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) - --- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's --- of values of types of this kind. -kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] -kindPrimRep doc ki - | Just ki' <- coreView ki - = kindPrimRep doc ki' -kindPrimRep doc (TyConApp typ [runtime_rep]) - = ASSERT( typ `hasKey` tYPETyConKey ) - runtimeRepPrimRep doc runtime_rep -kindPrimRep doc ki - = pprPanic "kindPrimRep" (ppr ki $$ doc) - - -- TODO (RAE): Remove: - -- WARN( True, text "kindPrimRep defaulting to LiftedRep on" <+> ppr ki $$ doc ) - -- [LiftedRep] -- this can happen legitimately for, e.g., Any - --- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that --- it encodes. -runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep] -runtimeRepPrimRep doc rr_ty - | Just rr_ty' <- coreView rr_ty - = runtimeRepPrimRep doc rr_ty' - | TyConApp rr_dc args <- rr_ty - , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc - = fun args - | otherwise - = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) - --- | Convert a PrimRep back to a Type. Used only in the unariser to give types --- to fresh Ids. Really, only the type's representation matters. -primRepToType :: PrimRep -> Type -primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep diff --git a/simplStg/SimplStg.hs b/simplStg/SimplStg.hs deleted file mode 100644 --- a/simplStg/SimplStg.hs +++ /dev/null @@ -1,117 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[SimplStg]{Driver for simplifying @STG@ programs} --} - -{-# LANGUAGE CPP #-} - -module SimplStg ( stg2stg ) where - -#include "HsVersions.h" - -import StgSyn - -import CostCentre ( CollectedCCs ) -import SCCfinal ( stgMassageForProfiling ) -import StgLint ( lintStgTopBindings ) -import StgStats ( showStgStats ) -import UnariseStg ( unarise ) -import StgCse ( stgCse ) - -import DynFlags -import Module ( Module ) -import ErrUtils -import SrcLoc -import UniqSupply ( mkSplitUniqSupply, splitUniqSupply ) -import Outputable -import Control.Monad - -stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do - -> Module -- module name (profiling only) - -> [StgTopBinding] -- input... - -> IO ( [StgTopBinding] -- output program... - , CollectedCCs) -- cost centre information (declared and used) - -stg2stg dflags module_name binds - = do { showPass dflags "Stg2Stg" - ; us <- mkSplitUniqSupply 'g' - - ; when (dopt Opt_D_verbose_stg2stg dflags) - (putLogMsg dflags NoReason SevDump noSrcSpan - (defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:")) - - ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds - - -- Do the main business! - ; let (us0, us1) = splitUniqSupply us' - ; (processed_binds, _, cost_centres) - <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags) - - ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:" - (pprStgTopBindings processed_binds) - - ; let un_binds = unarise us1 processed_binds - - ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" - (pprStgTopBindings un_binds) - - ; return (un_binds, cost_centres) - } - - where - stg_linter = if gopt Opt_DoStgLinting dflags - then lintStgTopBindings - else ( \ _whodunnit binds -> binds ) - - ------------------------------------------- - do_stg_pass (binds, us, ccs) to_do - = case to_do of - D_stg_stats -> - trace (showStgStats binds) - end_pass us "StgStats" ccs binds - - StgDoMassageForProfiling -> - {-# SCC "ProfMassage" #-} - let - (us1, us2) = splitUniqSupply us - (collected_CCs, binds3) - = stgMassageForProfiling dflags module_name us1 binds - in - end_pass us2 "ProfMassage" collected_CCs binds3 - - StgCSE -> - {-# SCC "StgCse" #-} - let - binds' = stgCse binds - in - end_pass us "StgCse" ccs binds' - - end_pass us2 what ccs binds2 - = do -- report verbosely, if required - dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what - (vcat (map ppr binds2)) - let linted_binds = stg_linter what binds2 - return (linted_binds, us2, ccs) - -- return: processed binds - -- UniqueSupply for the next guy to use - -- cost-centres to be declared/registered (specialised) - -- add to description of what's happened (reverse order) - --- ----------------------------------------------------------------------------- --- StgToDo: abstraction of stg-to-stg passes to run. - --- | Optional Stg-to-Stg passes. -data StgToDo - = StgCSE - | StgDoMassageForProfiling -- should be (next to) last - | D_stg_stats - --- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc. -getStgToDo :: DynFlags -> [StgToDo] -getStgToDo dflags - = [ StgCSE | gopt Opt_StgCSE dflags] ++ - [ StgDoMassageForProfiling | WayProf `elem` ways dflags] ++ - [ D_stg_stats | stg_stats ] - where - stg_stats = gopt Opt_StgStats dflags diff --git a/simplStg/StgCse.hs b/simplStg/StgCse.hs deleted file mode 100644 --- a/simplStg/StgCse.hs +++ /dev/null @@ -1,430 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -{-| -Note [CSE for Stg] -~~~~~~~~~~~~~~~~~~ -This module implements a simple common subexpression elimination pass for STG. -This is useful because there are expressions that we want to common up (because -they are operational equivalent), but that we cannot common up in Core, because -their types differ. -This was original reported as #9291. - -There are two types of common code occurrences that we aim for, see -note [Case 1: CSEing allocated closures] and -note [Case 2: CSEing case binders] below. - - -Note [Case 1: CSEing allocated closures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The fist kind of CSE opportunity we aim for is generated by this Haskell code: - - bar :: a -> (Either Int a, Either Bool a) - bar x = (Right x, Right x) - -which produces this Core: - - bar :: forall a. a -> (Either Int a, Either Bool a) - bar @a x = (Right @Int @a x, Right @Bool @a x) - -where the two components of the tuple are differnt terms, and cannot be -commoned up (easily). On the STG level we have - - bar [x] = let c1 = Right [x] - c2 = Right [x] - in (c1,c2) - -and now it is obvious that we can write - - bar [x] = let c1 = Right [x] - in (c1,c1) - -instead. - - -Note [Case 2: CSEing case binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The second kind of CSE opportunity we aim for is more interesting, and -came up in #9291 and #5344: The Haskell code - - foo :: Either Int a -> Either Bool a - foo (Right x) = Right x - foo _ = Left False - -produces this Core - - foo :: forall a. Either Int a -> Either Bool a - foo @a e = case e of b { Left n -> … - , Right x -> Right @Bool @a x } - -where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have -different types. But in STG we have - - foo [e] = case e of b { Left [n] -> … - , Right [x] -> Right [x] } - -and nothing stops us from transforming that to - - foo [e] = case e of b { Left [n] -> … - , Right [x] -> b} - --} -module StgCse (stgCse) where - -import DataCon -import Id -import StgSyn -import Outputable -import VarEnv -import CoreSyn (AltCon(..)) -import Data.List (mapAccumL) -import Data.Maybe (fromMaybe) -import TrieMap -import NameEnv -import Control.Monad( (>=>) ) - --------------- --- The Trie -- --------------- - --- A lookup trie for data constructor applications, i.e. --- keys of type `(DataCon, [StgArg])`, following the patterns in TrieMap. - -data StgArgMap a = SAM - { sam_var :: DVarEnv a - , sam_lit :: LiteralMap a - } - -instance TrieMap StgArgMap where - type Key StgArgMap = StgArg - emptyTM = SAM { sam_var = emptyTM - , sam_lit = emptyTM } - lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var - lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit - alterTM (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f } - alterTM (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f } - foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m) - mapTM f (SAM {sam_var = varm, sam_lit = litm}) = - SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm } - -newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) } - -instance TrieMap ConAppMap where - type Key ConAppMap = (DataCon, [StgArg]) - emptyTM = CAM emptyTM - lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args - alterTM (dataCon, args) f m = - m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f } - foldTM k = un_cam >.> foldTM (foldTM k) - mapTM f = un_cam >.> mapTM (mapTM f) >.> CAM - ------------------ --- The CSE Env -- ------------------ - --- | The CSE environment. See note [CseEnv Example] -data CseEnv = CseEnv - { ce_conAppMap :: ConAppMap OutId - -- ^ The main component of the environment is the trie that maps - -- data constructor applications (with their `OutId` arguments) - -- to an in-scope name that can be used instead. - -- This name is always either a let-bound variable or a case binder. - , ce_subst :: IdEnv OutId - -- ^ This substitution is applied to the code as we traverse it. - -- Entries have one of two reasons: - -- - -- * The input might have shadowing (see Note [Shadowing]), so we have - -- to rename some binders as we traverse the tree. - -- * If we remove `let x = Con z` because `let y = Con z` is in scope, - -- we note this here as x ↦ y. - , ce_bndrMap :: IdEnv OutId - -- If we come across a case expression case x as b of … with a trivial - -- binder, we add b ↦ x to this. - -- This map is *only* used when looking something up in the ce_conAppMap. - -- See Note [Trivial case scrutinee] - , ce_in_scope :: InScopeSet - -- ^ The third component is an in-scope set, to rename away any - -- shadowing binders - } - -{-| -Note [CseEnv Example] -~~~~~~~~~~~~~~~~~~~~~ -The following tables shows how the CseEnvironment changes as code is traversed, -as well as the changes to that code. - - InExpr OutExpr - conAppMap subst in_scope - ─────────────────────────────────────────────────────────── - -- empty {} {} - case … as a of {Con x y -> case … as a of {Con x y -> - -- Con x y ↦ a {} {a,x,y} - let b = Con x y (removed) - -- Con x y ↦ a b↦a {a,x,y,b} - let c = Bar a let c = Bar a - -- Con x y ↦ a, Bar a ↦ c b↦a {a,x,y,b,c} - let c = some expression let c' = some expression - -- Con x y ↦ a, Bar a ↦ c b↦a, c↦c', {a,x,y,b,c,c'} - let d = Bar b (removed) - -- Con x y ↦ a, Bar a ↦ c b↦a, c↦c', d↦c {a,x,y,b,c,c',d} - (a, b, c d) (a, a, c' c) --} - -initEnv :: InScopeSet -> CseEnv -initEnv in_scope = CseEnv - { ce_conAppMap = emptyTM - , ce_subst = emptyVarEnv - , ce_bndrMap = emptyVarEnv - , ce_in_scope = in_scope - } - -envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId -envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env) - where args' = map go args -- See Note [Trivial case scrutinee] - go (StgVarArg v ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v) - go (StgLitArg lit) = StgLitArg lit - -addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv --- do not bother with nullary data constructors, they are static anyways -addDataCon _ _ [] env = env -addDataCon bndr dataCon args env = env { ce_conAppMap = new_env } - where - new_env = insertTM (dataCon, args) bndr (ce_conAppMap env) - -forgetCse :: CseEnv -> CseEnv -forgetCse env = env { ce_conAppMap = emptyTM } - -- See note [Free variables of an StgClosure] - -addSubst :: OutId -> OutId -> CseEnv -> CseEnv -addSubst from to env - = env { ce_subst = extendVarEnv (ce_subst env) from to } - -addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv -addTrivCaseBndr from to env - = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to } - -substArgs :: CseEnv -> [InStgArg] -> [OutStgArg] -substArgs env = map (substArg env) - -substArg :: CseEnv -> InStgArg -> OutStgArg -substArg env (StgVarArg from) = StgVarArg (substVar env from) -substArg _ (StgLitArg lit) = StgLitArg lit - -substVars :: CseEnv -> [InId] -> [OutId] -substVars env = map (substVar env) - -substVar :: CseEnv -> InId -> OutId -substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id - --- Functions to enter binders - --- This is much simpler than the requivalent code in CoreSubst: --- * We do not substitute type variables, and --- * There is nothing relevant in IdInfo at this stage --- that needs substitutions. --- Therefore, no special treatment for a recursive group is required. - -substBndr :: CseEnv -> InId -> (CseEnv, OutId) -substBndr env old_id - = (new_env, new_id) - where - new_id = uniqAway (ce_in_scope env) old_id - no_change = new_id == old_id - env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id } - new_env | no_change = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id } - | otherwise = env' - -substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar]) -substBndrs env bndrs = mapAccumL substBndr env bndrs - -substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)]) -substPairs env bndrs = mapAccumL go env bndrs - where go env (id, x) = let (env', id') = substBndr env id - in (env', (id', x)) - --- Main entry point - -stgCse :: [InStgTopBinding] -> [OutStgTopBinding] -stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds - --- Top level bindings. --- --- We do not CSE these, as top-level closures are allocated statically anyways. --- Also, they might be exported. --- But we still have to collect the set of in-scope variables, otherwise --- uniqAway might shadow a top-level closure. - -stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding) -stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t) -stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs)) - = (in_scope' - , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs))) - where in_scope' = in_scope `extendInScopeSet` bndr - -stgCseTopLvl in_scope (StgTopLifted (StgRec eqs)) - = ( in_scope' - , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ])) - where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ] - -stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs -stgCseTopLvlRhs in_scope (StgRhsClosure ccs info occs upd args body) - = let body' = stgCseExpr (initEnv in_scope) body - in StgRhsClosure ccs info occs upd args body' -stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args) - = StgRhsCon ccs dataCon args - ------------------------------- --- The actual AST traversal -- ------------------------------- - --- Trivial cases -stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr -stgCseExpr env (StgApp fun args) - = StgApp fun' args' - where fun' = substVar env fun - args' = substArgs env args -stgCseExpr _ (StgLit lit) - = StgLit lit -stgCseExpr env (StgOpApp op args tys) - = StgOpApp op args' tys - where args' = substArgs env args -stgCseExpr _ (StgLam _ _) - = pprPanic "stgCseExp" (text "StgLam") -stgCseExpr env (StgTick tick body) - = let body' = stgCseExpr env body - in StgTick tick body' -stgCseExpr env (StgCase scrut bndr ty alts) - = StgCase scrut' bndr' ty alts' - where - scrut' = stgCseExpr env scrut - (env1, bndr') = substBndr env bndr - env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1 - -- See Note [Trivial case scrutinee] - | otherwise = env1 - alts' = map (stgCseAlt env2 bndr') alts - - --- A constructor application. --- To be removed by a variable use when found in the CSE environment -stgCseExpr env (StgConApp dataCon args tys) - | Just bndr' <- envLookup dataCon args' env - = StgApp bndr' [] - | otherwise - = StgConApp dataCon args' tys - where args' = substArgs env args - --- Let bindings --- The binding might be removed due to CSE (we do not want trivial bindings on --- the STG level), so use the smart constructor `mkStgLet` to remove the binding --- if empty. -stgCseExpr env (StgLet binds body) - = let (binds', env') = stgCseBind env binds - body' = stgCseExpr env' body - in mkStgLet StgLet binds' body' -stgCseExpr env (StgLetNoEscape binds body) - = let (binds', env') = stgCseBind env binds - body' = stgCseExpr env' body - in mkStgLet StgLetNoEscape binds' body' - --- Case alternatives --- Extend the CSE environment -stgCseAlt :: CseEnv -> OutId -> InStgAlt -> OutStgAlt -stgCseAlt env case_bndr (DataAlt dataCon, args, rhs) - = let (env1, args') = substBndrs env args - env2 = addDataCon case_bndr dataCon (map StgVarArg args') env1 - -- see note [Case 2: CSEing case binders] - rhs' = stgCseExpr env2 rhs - in (DataAlt dataCon, args', rhs') -stgCseAlt env _ (altCon, args, rhs) - = let (env1, args') = substBndrs env args - rhs' = stgCseExpr env1 rhs - in (altCon, args', rhs') - --- Bindings -stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv) -stgCseBind env (StgNonRec b e) - = let (env1, b') = substBndr env b - in case stgCseRhs env1 b' e of - (Nothing, env2) -> (Nothing, env2) - (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2) -stgCseBind env (StgRec pairs) - = let (env1, pairs1) = substPairs env pairs - in case stgCsePairs env1 pairs1 of - ([], env2) -> (Nothing, env2) - (pairs2, env2) -> (Just (StgRec pairs2), env2) - -stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv) -stgCsePairs env [] = ([], env) -stgCsePairs env0 ((b,e):pairs) - = let (pairMB, env1) = stgCseRhs env0 b e - (pairs', env2) = stgCsePairs env1 pairs - in (pairMB `mbCons` pairs', env2) - where - mbCons = maybe id (:) - --- The RHS of a binding. --- If it is an constructor application, either short-cut it or extend the environment -stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv) -stgCseRhs env bndr (StgRhsCon ccs dataCon args) - | Just other_bndr <- envLookup dataCon args' env - = let env' = addSubst bndr other_bndr env - in (Nothing, env') - | otherwise - = let env' = addDataCon bndr dataCon args' env - -- see note [Case 1: CSEing allocated closures] - pair = (bndr, StgRhsCon ccs dataCon args') - in (Just pair, env') - where args' = substArgs env args -stgCseRhs env bndr (StgRhsClosure ccs info occs upd args body) - = let (env1, args') = substBndrs env args - env2 = forgetCse env1 -- See note [Free variables of an StgClosure] - body' = stgCseExpr env2 body - in (Just (substVar env bndr, StgRhsClosure ccs info occs' upd args' body'), env) - where occs' = substVars env occs - --- Utilities - --- | This function short-cuts let-bindings that are now obsolete -mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b -mkStgLet _ Nothing body = body -mkStgLet stgLet (Just binds) body = stgLet binds body - - -{- -Note [Trivial case scrutinee] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We wnat to be able to handle nested reconstruction of constructors as in - - nested :: Either Int (Either Int a) -> Either Bool (Either Bool a) - nested (Right (Right v)) = Right (Right v) - nested _ = Left True - -So if we come across - - case x of r1 - Right a -> case a of r2 - Right b -> let v = Right b - in Right v - -we first replace v with r2. Next we want to replace Right r2 with r1. But the -ce_conAppMap contains Right a! - -Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use -this subsitution before looking Right r2 up in ce_conAppMap, and everything -works out. - -Note [Free variables of an StgClosure] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -StgClosures (function and thunks) have an explicit list of free variables: - -foo [x] = - let not_a_free_var = Left [x] - let a_free_var = Right [x] - let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var - in closure - -If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`, -then the list of free variables would be wrong, so for now, we do not CSE -across such a closure, simply because I (Joachim) was not sure about possible -knock-on effects. If deemed safe and worth the slight code complication of -re-calculating this list during or after this pass, this can surely be done. --} diff --git a/simplStg/StgStats.hs b/simplStg/StgStats.hs deleted file mode 100644 --- a/simplStg/StgStats.hs +++ /dev/null @@ -1,175 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[StgStats]{Gathers statistical information about programs} - - -The program gather statistics about -\begin{enumerate} -\item number of boxed cases -\item number of unboxed cases -\item number of let-no-escapes -\item number of non-updatable lets -\item number of updatable lets -\item number of applications -\item number of primitive applications -\item number of closures (does not include lets bound to constructors) -\item number of free variables in closures -%\item number of top-level functions -%\item number of top-level CAFs -\item number of constructors -\end{enumerate} --} - -{-# LANGUAGE CPP #-} - -module StgStats ( showStgStats ) where - -#include "HsVersions.h" - -import StgSyn - -import Id (Id) -import Panic - -import Data.Map (Map) -import qualified Data.Map as Map - -data CounterType - = Literals - | Applications - | ConstructorApps - | PrimitiveApps - | LetNoEscapes - | StgCases - | FreeVariables - | ConstructorBinds Bool{-True<=>top-level-} - | ReEntrantBinds Bool{-ditto-} - | SingleEntryBinds Bool{-ditto-} - | UpdatableBinds Bool{-ditto-} - deriving (Eq, Ord) - -type Count = Int -type StatEnv = Map CounterType Count - -emptySE :: StatEnv -emptySE = Map.empty - -combineSE :: StatEnv -> StatEnv -> StatEnv -combineSE = Map.unionWith (+) - -combineSEs :: [StatEnv] -> StatEnv -combineSEs = foldr combineSE emptySE - -countOne :: CounterType -> StatEnv -countOne c = Map.singleton c 1 - -countN :: CounterType -> Int -> StatEnv -countN = Map.singleton - -{- -************************************************************************ -* * -\subsection{Top-level list of bindings (a ``program'')} -* * -************************************************************************ --} - -showStgStats :: [StgTopBinding] -> String - -showStgStats prog - = "STG Statistics:\n\n" - ++ concat (map showc (Map.toList (gatherStgStats prog))) - where - showc (x,n) = (showString (s x) . shows n) "\n" - - s Literals = "Literals " - s Applications = "Applications " - s ConstructorApps = "ConstructorApps " - s PrimitiveApps = "PrimitiveApps " - s LetNoEscapes = "LetNoEscapes " - s StgCases = "StgCases " - s FreeVariables = "FreeVariables " - s (ConstructorBinds True) = "ConstructorBinds_Top " - s (ReEntrantBinds True) = "ReEntrantBinds_Top " - s (SingleEntryBinds True) = "SingleEntryBinds_Top " - s (UpdatableBinds True) = "UpdatableBinds_Top " - s (ConstructorBinds _) = "ConstructorBinds_Nested " - s (ReEntrantBinds _) = "ReEntrantBindsBinds_Nested " - s (SingleEntryBinds _) = "SingleEntryBinds_Nested " - s (UpdatableBinds _) = "UpdatableBinds_Nested " - -gatherStgStats :: [StgTopBinding] -> StatEnv -gatherStgStats binds = combineSEs (map statTopBinding binds) - -{- -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ --} - -statTopBinding :: StgTopBinding -> StatEnv -statTopBinding (StgTopStringLit _ _) = countOne Literals -statTopBinding (StgTopLifted bind) = statBinding True bind - -statBinding :: Bool -- True <=> top-level; False <=> nested - -> StgBinding - -> StatEnv - -statBinding top (StgNonRec b rhs) - = statRhs top (b, rhs) - -statBinding top (StgRec pairs) - = combineSEs (map (statRhs top) pairs) - -statRhs :: Bool -> (Id, StgRhs) -> StatEnv - -statRhs top (_, StgRhsCon _ _ _) - = countOne (ConstructorBinds top) - -statRhs top (_, StgRhsClosure _ _ fv u _ body) - = statExpr body `combineSE` - countN FreeVariables (length fv) `combineSE` - countOne ( - case u of - ReEntrant -> ReEntrantBinds top - Updatable -> UpdatableBinds top - SingleEntry -> SingleEntryBinds top - ) - -{- -************************************************************************ -* * -\subsection{Expressions} -* * -************************************************************************ --} - -statExpr :: StgExpr -> StatEnv - -statExpr (StgApp _ _) = countOne Applications -statExpr (StgLit _) = countOne Literals -statExpr (StgConApp _ _ _)= countOne ConstructorApps -statExpr (StgOpApp _ _ _) = countOne PrimitiveApps -statExpr (StgTick _ e) = statExpr e - -statExpr (StgLetNoEscape binds body) - = statBinding False{-not top-level-} binds `combineSE` - statExpr body `combineSE` - countOne LetNoEscapes - -statExpr (StgLet binds body) - = statBinding False{-not top-level-} binds `combineSE` - statExpr body - -statExpr (StgCase expr _ _ alts) - = statExpr expr `combineSE` - stat_alts alts `combineSE` - countOne StgCases - where - stat_alts alts - = combineSEs (map statExpr [ e | (_,_,e) <- alts ]) - -statExpr (StgLam {}) = panic "statExpr StgLam" diff --git a/simplStg/UnariseStg.hs b/simplStg/UnariseStg.hs deleted file mode 100644 --- a/simplStg/UnariseStg.hs +++ /dev/null @@ -1,761 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-2012 - -Note [Unarisation] -~~~~~~~~~~~~~~~~~~ -The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum -binders. So for example: - - f (x :: (# Int, Bool #)) = f x + f (# 1, True #) - - ==> - - f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True - -It is important that we do this at the STG level and NOT at the Core level -because it would be very hard to make this pass Core-type-preserving. In this -example the type of 'f' changes, for example. - -STG fed to the code generators *must* be unarised because the code generators do -not support unboxed tuple and unboxed sum binders natively. - -In more detail: (see next note for unboxed sums) - -Suppose that a variable x : (# t1, t2 #). - - * At the binding site for x, make up fresh vars x1:t1, x2:t2 - - * Extend the UnariseEnv x :-> MultiVal [x1,x2] - - * Replace the binding with a curried binding for x1,x2 - - Lambda: \x.e ==> \x1 x2. e - Case alt: MkT a b x c d -> e ==> MkT a b x1 x2 c d -> e - - * Replace argument occurrences with a sequence of args via a lookup in - UnariseEnv - - f a b x c d ==> f a b x1 x2 c d - - * Replace tail-call occurrences with an unboxed tuple via a lookup in - UnariseEnv - - x ==> (# x1, x2 #) - - So, for example - - f x = x ==> f x1 x2 = (# x1, x2 #) - - * We /always/ eliminate a case expression when - - - It scrutinises an unboxed tuple or unboxed sum - - - The scrutinee is a variable (or when it is an explicit tuple, but the - simplifier eliminates those) - - The case alternative (there can be only one) can be one of these two - things: - - - An unboxed tuple pattern. e.g. - - case v of x { (# x1, x2, x3 #) -> ... } - - Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the - environment with - - x :-> MultiVal [t1,t2,t3] - x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3 - - - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3 - -By the end of this pass, we only have unboxed tuples in return positions. -Unboxed sums are completely eliminated, see next note. - -Note [Translating unboxed sums to unboxed tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unarise also eliminates unboxed sum binders, and translates unboxed sums in -return positions to unboxed tuples. We want to overlap fields of a sum when -translating it to a tuple to have efficient memory layout. When translating a -sum pattern to a tuple pattern, we need to translate it so that binders of sum -alternatives will be mapped to right arguments after the term translation. So -translation of sum DataCon applications to tuple DataCon applications and -translation of sum patterns to tuple patterns need to be in sync. - -These translations work like this. Suppose we have - - (# x1 | | ... #) :: (# t1 | t2 | ... #) - -remember that t1, t2 ... can be sums and tuples too. So we first generate -layouts of those. Then we "merge" layouts of each alternative, which gives us a -sum layout with best overlapping possible. - -Layout of a flat type 'ty1' is just [ty1]. -Layout of a tuple is just concatenation of layouts of its fields. - -For layout of a sum type, - - - We first get layouts of all alternatives. - - We sort these layouts based on their "slot types". - - We merge all the alternatives. - -For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #) - - - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ] - - Sorted: [ [Ptr, Word], [Word, Word], [Word] ] - - Merge all alternatives together: [ Ptr, Word, Word ] - -We add a slot for the tag to the first position. So our tuple type is - - (# Tag#, Any, Word#, Word# #) - (we use Any for pointer slots) - -Now, any term of this sum type needs to generate a tuple of this type instead. -The translation works by simply putting arguments to first slots that they fit -in. Suppose we had - - (# (# 42#, 'c' #) | | #) - -42# fits in Word#, 'c' fits in Any, so we generate this application: - - (# 1#, 'c', 42#, rubbish #) - -Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#, -3# fits in Word #, so we get: - - (# 2#, rubbish, 2#, 3# #). - -Note [Types in StgConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have this unboxed sum term: - - (# 123 | #) - -What will be the unboxed tuple representation? We can't tell without knowing the -type of this term. For example, these are all valid tuples for this: - - (# 1#, 123 #) -- when type is (# Int | String #) - (# 1#, 123, rubbish #) -- when type is (# Int | Float# #) - (# 1#, 123, rubbish, rubbish #) - -- when type is (# Int | (# Int, Int, Int #) #) - -So we pass type arguments of the DataCon's TyCon in StgConApp to decide what -layout to use. Note that unlifted values can't be let-bound, so we don't need -types in StgRhsCon. - -Note [UnariseEnv can map to literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To avoid redundant case expressions when unarising unboxed sums, UnariseEnv -needs to map variables to literals too. Suppose we have this Core: - - f (# x | #) - - ==> (CorePrep) - - case (# x | #) of y { - _ -> f y - } - - ==> (MultiVal) - - case (# 1#, x #) of [x1, x2] { - _ -> f x1 x2 - } - -To eliminate this case expression we need to map x1 to 1# in UnariseEnv: - - x1 :-> UnaryVal 1#, x2 :-> UnaryVal x - -so that `f x1 x2` becomes `f 1# x`. - -Note [Unarisation and arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because of unarisation, the arity that will be recorded in the generated info -table for an Id may be larger than the idArity. Instead we record what we call -the RepArity, which is the Arity taking into account any expanded arguments, and -corresponds to the number of (possibly-void) *registers* arguments will arrive -in. - -Note [Post-unarisation invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -STG programs after unarisation have these invariants: - - * No unboxed sums at all. - - * No unboxed tuple binders. Tuples only appear in return position. - - * DataCon applications (StgRhsCon and StgConApp) don't have void arguments. - This means that it's safe to wrap `StgArg`s of DataCon applications with - `StgCmmEnv.NonVoid`, for example. - - * Alt binders (binders in patterns) are always non-void. --} - -{-# LANGUAGE CPP, TupleSections #-} - -module UnariseStg (unarise) where - -#include "HsVersions.h" - -import BasicTypes -import CoreSyn -import DataCon -import FastString (FastString, mkFastString) -import Id -import Literal (Literal (..)) -import MkCore (aBSENT_ERROR_ID) -import MkId (voidPrimId, voidArgId) -import MonadUtils (mapAccumLM) -import Outputable -import RepType -import StgSyn -import Type -import TysPrim (intPrimTy) -import TysWiredIn -import UniqSupply -import Util -import VarEnv - -import Data.Bifunctor (second) -import Data.Maybe (mapMaybe) -import qualified Data.IntMap as IM - --------------------------------------------------------------------------------- - --- | A mapping from binders to the Ids they were expanded/renamed to. --- --- x :-> MultiVal [a,b,c] in rho --- --- iff x's typePrimRep is not a singleton, or equivalently --- x's type is an unboxed tuple, sum or void. --- --- x :-> UnaryVal x' --- --- iff x's RepType is UnaryRep or equivalently --- x's type is not unboxed tuple, sum or void. --- --- So --- x :-> MultiVal [a] in rho --- means x is represented by singleton tuple. --- --- x :-> MultiVal [] in rho --- means x is void. --- --- INVARIANT: OutStgArgs in the range only have NvUnaryTypes --- (i.e. no unboxed tuples, sums or voids) --- -type UnariseEnv = VarEnv UnariseVal - -data UnariseVal - = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). - | UnaryVal OutStgArg -- See NOTE [Renaming during unarisation]. - -instance Outputable UnariseVal where - ppr (MultiVal args) = text "MultiVal" <+> ppr args - ppr (UnaryVal arg) = text "UnaryVal" <+> ppr arg - --- | Extend the environment, checking the UnariseEnv invariant. -extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv -extendRho rho x (MultiVal args) - = ASSERT(all (isNvUnaryType . stgArgType) args) - extendVarEnv rho x (MultiVal args) -extendRho rho x (UnaryVal val) - = ASSERT(isNvUnaryType (stgArgType val)) - extendVarEnv rho x (UnaryVal val) - --------------------------------------------------------------------------------- - -unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding] -unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds) - -unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding -unariseTopBinding rho (StgTopLifted bind) - = StgTopLifted <$> unariseBinding rho bind -unariseTopBinding _ bind@StgTopStringLit{} = return bind - -unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding -unariseBinding rho (StgNonRec x rhs) - = StgNonRec x <$> unariseRhs rho rhs -unariseBinding rho (StgRec xrhss) - = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss - -unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs -unariseRhs rho (StgRhsClosure ccs b_info fvs update_flag args expr) - = do (rho', args1) <- unariseFunArgBinders rho args - expr' <- unariseExpr rho' expr - let fvs' = unariseFreeVars rho fvs - return (StgRhsClosure ccs b_info fvs' update_flag args1 expr') - -unariseRhs rho (StgRhsCon ccs con args) - = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con)) - return (StgRhsCon ccs con (unariseConArgs rho args)) - --------------------------------------------------------------------------------- - -unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr - -unariseExpr rho e@(StgApp f []) - = case lookupVarEnv rho f of - Just (MultiVal args) -- Including empty tuples - -> return (mkTuple args) - Just (UnaryVal (StgVarArg f')) - -> return (StgApp f' []) - Just (UnaryVal (StgLitArg f')) - -> return (StgLit f') - Nothing - -> return e - -unariseExpr rho e@(StgApp f args) - = return (StgApp f' (unariseFunArgs rho args)) - where - f' = case lookupVarEnv rho f of - Just (UnaryVal (StgVarArg f')) -> f' - Nothing -> f - err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err) - -- Can't happen because 'args' is non-empty, and - -- a tuple or sum cannot be applied to anything - -unariseExpr _ (StgLit l) - = return (StgLit l) - -unariseExpr rho (StgConApp dc args ty_args) - | Just args' <- unariseMulti_maybe rho dc args ty_args - = return (mkTuple args') - - | otherwise - , let args' = unariseConArgs rho args - = return (StgConApp dc args' (map stgArgType args')) - -unariseExpr rho (StgOpApp op args ty) - = return (StgOpApp op (unariseFunArgs rho args) ty) - -unariseExpr _ e@StgLam{} - = pprPanic "unariseExpr: found lambda" (ppr e) - -unariseExpr rho (StgCase scrut bndr alt_ty alts) - -- a tuple/sum binders in the scrutinee can always be eliminated - | StgApp v [] <- scrut - , Just (MultiVal xs) <- lookupVarEnv rho v - = elimCase rho xs bndr alt_ty alts - - -- Handle strict lets for tuples and sums: - -- case (# a,b #) of r -> rhs - -- and analogously for sums - | StgConApp dc args ty_args <- scrut - , Just args' <- unariseMulti_maybe rho dc args ty_args - = elimCase rho args' bndr alt_ty alts - - -- general case - | otherwise - = do scrut' <- unariseExpr rho scrut - alts' <- unariseAlts rho alt_ty bndr alts - return (StgCase scrut' bndr alt_ty alts') - -- bndr will be dead after unarise - -unariseExpr rho (StgLet bind e) - = StgLet <$> unariseBinding rho bind <*> unariseExpr rho e - -unariseExpr rho (StgLetNoEscape bind e) - = StgLetNoEscape <$> unariseBinding rho bind <*> unariseExpr rho e - -unariseExpr rho (StgTick tick e) - = StgTick tick <$> unariseExpr rho e - --- Doesn't return void args. -unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg] -unariseMulti_maybe rho dc args ty_args - | isUnboxedTupleCon dc - = Just (unariseConArgs rho args) - - | isUnboxedSumCon dc - , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args) - = Just (mkUbxSum dc ty_args args1) - - | otherwise - = Nothing - --------------------------------------------------------------------------------- - -elimCase :: UnariseEnv - -> [OutStgArg] -- non-void args - -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr - -elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)] - = do let rho1 = extendRho rho bndr (MultiVal args) - rho2 - | isUnboxedTupleBndr bndr - = mapTupleIdBinders bndrs args rho1 - | otherwise - = ASSERT(isUnboxedSumBndr bndr) - if null bndrs then rho1 - else mapSumIdBinders bndrs args rho1 - - unariseExpr rho2 rhs - -elimCase rho args bndr (MultiValAlt _) alts - | isUnboxedSumBndr bndr - = do let (tag_arg : real_args) = args - tag_bndr <- mkId (mkFastString "tag") tagTy - -- this won't be used but we need a binder anyway - let rho1 = extendRho rho bndr (MultiVal args) - scrut' = case tag_arg of - StgVarArg v -> StgApp v [] - StgLitArg l -> StgLit l - - alts' <- unariseSumAlts rho1 real_args alts - return (StgCase scrut' tag_bndr tagAltTy alts') - -elimCase _ args bndr alt_ty alts - = pprPanic "elimCase - unhandled case" - (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts) - --------------------------------------------------------------------------------- - -unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt] -unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)] - | isUnboxedTupleBndr bndr - = do (rho', ys) <- unariseConArgBinder rho bndr - e' <- unariseExpr rho' e - return [(DataAlt (tupleDataCon Unboxed n), ys, e')] - -unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)] - | isUnboxedTupleBndr bndr - = do (rho', ys1) <- unariseConArgBinders rho ys - MASSERT(n == length ys1) - let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1)) - e' <- unariseExpr rho'' e - return [(DataAlt (tupleDataCon Unboxed n), ys1, e')] - -unariseAlts _ (MultiValAlt _) bndr alts - | isUnboxedTupleBndr bndr - = pprPanic "unariseExpr: strange multi val alts" (ppr alts) - --- In this case we don't need to scrutinize the tag bit -unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)] - | isUnboxedSumBndr bndr - = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr - rhs' <- unariseExpr rho_sum_bndrs rhs - return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')] - -unariseAlts rho (MultiValAlt _) bndr alts - | isUnboxedSumBndr bndr - = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr - alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts - let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts' - return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)), - scrt_bndrs, - inner_case) ] - -unariseAlts rho _ _ alts - = mapM (\alt -> unariseAlt rho alt) alts - -unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt -unariseAlt rho (con, xs, e) - = do (rho', xs') <- unariseConArgBinders rho xs - (con, xs',) <$> unariseExpr rho' e - --------------------------------------------------------------------------------- - --- | Make alternatives that match on the tag of a sum --- (i.e. generate LitAlts for the tag) -unariseSumAlts :: UnariseEnv - -> [StgArg] -- sum components _excluding_ the tag bit. - -> [StgAlt] -- original alternative with sum LHS - -> UniqSM [StgAlt] -unariseSumAlts env args alts - = do alts' <- mapM (unariseSumAlt env args) alts - return (mkDefaultLitAlt alts') - -unariseSumAlt :: UnariseEnv - -> [StgArg] -- sum components _excluding_ the tag bit. - -> StgAlt -- original alternative with sum LHS - -> UniqSM StgAlt -unariseSumAlt rho _ (DEFAULT, _, e) - = ( DEFAULT, [], ) <$> unariseExpr rho e - -unariseSumAlt rho args (DataAlt sumCon, bs, e) - = do let rho' = mapSumIdBinders bs args rho - e' <- unariseExpr rho' e - return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e' ) - -unariseSumAlt _ scrt alt - = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt) - --------------------------------------------------------------------------------- - -mapTupleIdBinders - :: [InId] -- Un-processed binders of a tuple alternative. - -- Can have void binders. - -> [OutStgArg] -- Arguments that form the tuple (after unarisation). - -- Can't have void args. - -> UnariseEnv - -> UnariseEnv -mapTupleIdBinders ids args0 rho0 - = ASSERT(not (any (isVoidTy . stgArgType) args0)) - let - ids_unarised :: [(Id, [PrimRep])] - ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids - - map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv - map_ids rho [] _ = rho - map_ids rho ((x, x_reps) : xs) args = - let - x_arity = length x_reps - (x_args, args') = - ASSERT(args `lengthAtLeast` x_arity) - splitAt x_arity args - - rho' - | x_arity == 1 - = ASSERT(x_args `lengthIs` 1) - extendRho rho x (UnaryVal (head x_args)) - | otherwise - = extendRho rho x (MultiVal x_args) - in - map_ids rho' xs args' - in - map_ids rho0 ids_unarised args0 - -mapSumIdBinders - :: [InId] -- Binder of a sum alternative (remember that sum patterns - -- only have one binder, so this list should be a singleton) - -> [OutStgArg] -- Arguments that form the sum (NOT including the tag). - -- Can't have void args. - -> UnariseEnv - -> UnariseEnv - -mapSumIdBinders [id] args rho0 - = ASSERT(not (any (isVoidTy . stgArgType) args)) - let - arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args - id_slots = map primRepSlot $ typePrimRep (idType id) - layout1 = layoutUbxSum arg_slots id_slots - in - if isMultiValBndr id - then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ]) - else ASSERT(layout1 `lengthIs` 1) - extendRho rho0 id (UnaryVal (args !! head layout1)) - -mapSumIdBinders ids sum_args _ - = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args) - --- | Build a unboxed sum term from arguments of an alternative. --- --- Example, for (# x | #) :: (# (# #) | Int #) we call --- --- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ] --- --- which returns --- --- [ 1#, rubbish ] --- -mkUbxSum - :: DataCon -- Sum data con - -> [Type] -- Type arguments of the sum data con - -> [OutStgArg] -- Actual arguments of the alternative. - -> [OutStgArg] -- Final tuple arguments -mkUbxSum dc ty_args args0 - = let - (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args) - -- drop tag slot - - tag = dataConTag dc - - layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0) - tag_arg = StgLitArg (MachInt (fromIntegral tag)) - arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0) - - mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg] - mkTupArgs _ [] _ - = [] - mkTupArgs arg_idx (slot : slots_left) arg_map - | Just stg_arg <- IM.lookup arg_idx arg_map - = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map - | otherwise - = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map - - slotRubbishArg :: SlotTy -> StgArg - slotRubbishArg PtrSlot = StgVarArg aBSENT_ERROR_ID - slotRubbishArg WordSlot = StgLitArg (MachWord 0) - slotRubbishArg Word64Slot = StgLitArg (MachWord64 0) - slotRubbishArg FloatSlot = StgLitArg (MachFloat 0) - slotRubbishArg DoubleSlot = StgLitArg (MachDouble 0) - in - tag_arg : mkTupArgs 0 sum_slots arg_idxs - --------------------------------------------------------------------------------- - -{- -For arguments (StgArg) and binders (Id) we have two kind of unarisation: - - - When unarising function arg binders and arguments, we don't want to remove - void binders and arguments. For example, - - f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ... - f x y z = - - Here after unarise we should still get a function with arity 3. Similarly - in the call site we shouldn't remove void arguments: - - f (# (# #), (# #) #) voidId rw - - When unarising , we extend the environment with these binders: - - x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal [] - - Because their rep types are `MultiRep []` (aka. void). This means that when - we see `x` in a function argument position, we actually replace it with a - void argument. When we see it in a DataCon argument position, we just get - rid of it, because DataCon applications in STG are always saturated. - - - When unarising case alternative binders we remove void binders, but we - still update the environment the same way, because those binders may be - used in the RHS. Example: - - case x of y { - (# x1, x2, x3 #) -> - } - - We know that y can't be void, because we don't scrutinize voids, so x will - be unarised to some number of arguments, and those arguments will have at - least one non-void thing. So in the rho we will have something like: - - x :-> MultiVal [xu1, xu2] - - Now, after we eliminate void binders in the pattern, we get exactly the same - number of binders, and extend rho again with these: - - x1 :-> UnaryVal xu1 - x2 :-> MultiVal [] -- x2 is void - x3 :-> UnaryVal xu2 - - Now when we see x2 in a function argument position or in return position, we - generate void#. In constructor argument position, we just remove it. - -So in short, when we have a void id, - - - We keep it if it's a lambda argument binder or - in argument position of an application. - - - We remove it if it's a DataCon field binder or - in argument position of a DataCon application. --} - --------------------------------------------------------------------------------- - --- | MultiVal a function argument. Never returns an empty list. -unariseFunArg :: UnariseEnv -> StgArg -> [StgArg] -unariseFunArg rho (StgVarArg x) = - case lookupVarEnv rho x of - Just (MultiVal []) -> [voidArg] -- NB: do not remove void args - Just (MultiVal as) -> as - Just (UnaryVal arg) -> [arg] - Nothing -> [StgVarArg x] -unariseFunArg _ arg = [arg] - -unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg] -unariseFunArgs = concatMap . unariseFunArg - -unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id]) -unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs - -unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) --- Result list of binders is never empty -unariseFunArgBinder rho x = - case typePrimRep (idType x) of - [] -> return (extendRho rho x (MultiVal []), [voidArgId]) - -- NB: do not remove void binders - [_] -> return (rho, [x]) - reps -> do - xs <- mkIds (mkFastString "us") (map primRepToType reps) - return (extendRho rho x (MultiVal (map StgVarArg xs)), xs) - --------------------------------------------------------------------------------- - --- | MultiVal a DataCon argument. Returns an empty list when argument is void. -unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg] -unariseConArg rho (StgVarArg x) = - case lookupVarEnv rho x of - Just (UnaryVal arg) -> [arg] - Just (MultiVal as) -> as -- 'as' can be empty - Nothing - | isVoidTy (idType x) -> [] -- e.g. C realWorld# - -- Here realWorld# is not in the envt, but - -- is a void, and so should be eliminated - | otherwise -> [StgVarArg x] -unariseConArg _ arg = [arg] -- We have no void literals - -unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg] -unariseConArgs = concatMap . unariseConArg - -unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id]) -unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs - -unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) -unariseConArgBinder rho x = - case typePrimRep (idType x) of - [_] -> return (rho, [x]) - reps -> do - xs <- mkIds (mkFastString "us") (map primRepToType reps) - return (extendRho rho x (MultiVal (map StgVarArg xs)), xs) - -unariseFreeVars :: UnariseEnv -> [InId] -> [OutId] -unariseFreeVars rho fvs - = [ v | fv <- fvs, StgVarArg v <- unariseFreeVar rho fv ] - -- Notice that we filter out any StgLitArgs - -- e.g. case e of (x :: (# Int | Bool #)) - -- (# v | #) -> ... let {g = \y. ..x...} in ... - -- (# | w #) -> ... - -- Here 'x' is free in g's closure, and the env will have - -- x :-> [1, v] - -- we want to capture 'v', but not 1, in the free vars - -unariseFreeVar :: UnariseEnv -> Id -> [StgArg] -unariseFreeVar rho x = - case lookupVarEnv rho x of - Just (MultiVal args) -> args - Just (UnaryVal arg) -> [arg] - Nothing -> [StgVarArg x] - --------------------------------------------------------------------------------- - -mkIds :: FastString -> [UnaryType] -> UniqSM [Id] -mkIds fs tys = mapM (mkId fs) tys - -mkId :: FastString -> UnaryType -> UniqSM Id -mkId = mkSysLocalOrCoVarM - -isMultiValBndr :: Id -> Bool -isMultiValBndr id - | [_] <- typePrimRep (idType id) - = False - | otherwise - = True - -isUnboxedSumBndr :: Id -> Bool -isUnboxedSumBndr = isUnboxedSumType . idType - -isUnboxedTupleBndr :: Id -> Bool -isUnboxedTupleBndr = isUnboxedTupleType . idType - -mkTuple :: [StgArg] -> StgExpr -mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args) - -tagAltTy :: AltType -tagAltTy = PrimAlt IntRep - -tagTy :: Type -tagTy = intPrimTy - -voidArg :: StgArg -voidArg = StgVarArg voidPrimId - -mkDefaultLitAlt :: [StgAlt] -> [StgAlt] --- We have an exhauseive list of literal alternatives --- 1# -> e1 --- 2# -> e2 --- Since they are exhaustive, we can replace one with DEFAULT, to avoid --- generating a final test. Remember, the DEFAULT comes first if it exists. -mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts") -mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts -mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts -mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts) diff --git a/specialise/Rules.hs b/specialise/Rules.hs deleted file mode 100644 --- a/specialise/Rules.hs +++ /dev/null @@ -1,1256 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[CoreRules]{Transformation rules} --} - -{-# LANGUAGE CPP #-} - --- | Functions for collecting together and applying rewrite rules to a module. --- The 'CoreRule' datatype itself is declared elsewhere. -module Rules ( - -- ** Constructing - emptyRuleBase, mkRuleBase, extendRuleBaseList, - unionRuleBase, pprRuleBase, - - -- ** Checking rule applications - ruleCheckProgram, - - -- ** Manipulating 'RuleInfo' rules - mkRuleInfo, extendRuleInfo, addRuleInfo, - addIdSpecialisations, - - -- * Misc. CoreRule helpers - rulesOfBinds, getRules, pprRulesForUser, - - lookupRule, mkRule, roughTopNames - ) where - -#include "HsVersions.h" - -import CoreSyn -- All of it -import Module ( Module, ModuleSet, elemModuleSet ) -import CoreSubst -import CoreOpt ( exprIsLambda_maybe ) -import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars - , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) -import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, - stripTicksTopT, stripTicksTopE, - isJoinBind ) -import PprCore ( pprRules ) -import Type ( Type, substTy, mkTCvSubst ) -import TcType ( tcSplitTyConApp_maybe ) -import TysWiredIn ( anyTypeOfKind ) -import Coercion -import CoreTidy ( tidyRules ) -import Id -import IdInfo ( RuleInfo( RuleInfo ) ) -import Var -import VarEnv -import VarSet -import Name ( Name, NamedThing(..), nameIsLocalOrFrom ) -import NameSet -import NameEnv -import UniqFM -import Unify ( ruleMatchTyKiX ) -import BasicTypes ( Activation, CompilerPhase, isActive, pprRuleName ) -import DynFlags ( DynFlags ) -import Outputable -import FastString -import Maybes -import Bag -import Util -import Data.List -import Data.Ord -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 - DsBinds - -* TidyPgm 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 CoreMonad. - 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 CoreMonad, and - (d) from its mutable variable - [Of coures 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 'CoreSyn.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 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 "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 :: DynFlags -> [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 PprCore because it calls tidyRules -pprRulesForUser dflags rules - = withPprStyle (defaultUserStyle dflags) $ - pprRules $ - sortBy (comparing ruleName) $ - tidyRules emptyTidyEnv rules - -{- -************************************************************************ -* * - RuleInfo: the rules in an IdInfo -* * -************************************************************************ --} - --- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable --- for putting into an 'IdInfo' -mkRuleInfo :: [CoreRule] -> RuleInfo -mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) - -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 [] - = id -addIdSpecialisations id rules - = 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 iself (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 PrelRules.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 CoreSyn, 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 (:) 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 :: DynFlags -> InScopeEnv - -> (Activation -> Bool) -- When rule is active - -> Id -> [CoreExpr] - -> [CoreRule] -> Maybe (CoreRule, CoreExpr) - --- See Note [Extra args in rule matching] --- See comments on matchRule -lookupRule dflags in_scope is_active fn args rules - = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ - case go [] rules of - [] -> Nothing - (m:ms) -> Just (findBest (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 dflags in_scope 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 :: (Id, [CoreExpr]) - -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) --- All these pairs matched the expression --- Return the pair the the most specific rule --- The (fn,args) is just for overlap reporting - -findBest _ (rule,ans) [] = (rule,ans) -findBest target (rule1,ans1) ((rule2,ans2):prs) - | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs - | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs - | debugIsOn = let pp_rule rule = sdocWithPprDebug $ \dbg -> if dbg - then ppr rule - else doubleQuotes (ftext (ruleName rule)) - in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" - (vcat [ sdocWithPprDebug $ \dbg -> if dbg - then text "Expression to match:" <+> ppr fn - <+> sep (map ppr args) - else empty - , text "Rule 1:" <+> pp_rule rule1 - , text "Rule 2:" <+> pp_rule rule2]) $ - findBest target (rule1,ans1) prs - | otherwise = findBest target (rule1,ans1) prs - where - (fn,args) = target - -isMoreSpecific :: 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 (Trac #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 (Rule { ru_bndrs = bndrs1, ru_args = args1 }) - (Rule { ru_bndrs = bndrs2, ru_args = args2, ru_name = rule_name2 }) - = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1) - where - id_unfolding_fun _ = NoUnfolding -- Don't expand in templates - in_scope = mkInScopeSet (mkVarSet bndrs1) - -- Actually we should probably include the free vars - -- of rule1's args, but I can't be bothered - -noBlackList :: Activation -> Bool -noBlackList _ = False -- Nothing is black listed - -{- -Note [Extra args in rule matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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. It's up to the caller to keep track -of any left-over args. E.g. if you call - lookupRule ... f [e1, e2, e3] -and it returns Just (r, rhs), where r has ruleArity 2 -then 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 --} - ------------------------------------- -matchRule :: DynFlags -> 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 dflags 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 dflags rule_env fn args of - Nothing -> Nothing - Just expr -> Just expr - -matchRule _ in_scope 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 - = case matchN in_scope rule_name tpl_vars tpl_args args of - Nothing -> Nothing - Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $ - rule_fn `mkApps` tpl_vals) - where - rule_fn = mkLams tpl_vars rhs - ---------------------------------------- -matchN :: InScopeEnv - -> RuleName -> [Var] -> [CoreExpr] - -> [CoreExpr] -- ^ Target; can have more elements than the template - -> Maybe (BindWrapper, -- Floated bindings; see Note [Matching lets] - [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 two few actual arguments from the target to match the template - -matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es - = do { subst <- go init_menv emptyRuleSubst tmpl_es target_es - ; let (_, matched_es) = mapAccumL lookup_tmpl subst tmpl_vars - ; return (rs_binds subst, matched_es) } - where - init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars) - -- See Note [Template binders] - - init_menv = RV { rv_tmpls = mkVarSet tmpl_vars, rv_lcl = init_rn_env - , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) - , rv_unf = id_unf } - - go _ subst [] _ = Just subst - go _ _ _ [] = Nothing -- Fail if too few actual args - go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e - ; go menv subst1 ts es } - - lookup_tmpl :: RuleSubst -> Var -> (RuleSubst, CoreExpr) - lookup_tmpl rs@(RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var - | isId tmpl_var - = case lookupVarEnv id_subst tmpl_var of - Just e -> (rs, e) - Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var - , let co_expr = Coercion refl_co - -> (rs { rs_id_subst = extendVarEnv id_subst tmpl_var co_expr }, co_expr) - | otherwise - -> unbound tmpl_var - | otherwise - = case lookupVarEnv tv_subst tmpl_var of - Just ty -> (rs, Type ty) - Nothing -> (rs { rs_tv_subst = extendVarEnv tv_subst tmpl_var fake_ty }, Type fake_ty) - -- See Note [Unbound RULE binders] - where - fake_ty = anyTypeOfKind kind - cv_subst = to_co_env id_subst - kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst)) - (tyVarKind tmpl_var) - - to_co_env env = nonDetFoldUFM_Directly to_co emptyVarEnv env - -- It's OK to use nonDetFoldUFM_Directly because we forget the - -- order immediately by creating a new env - to_co uniq expr env - | Just co <- exprToCoercion_maybe expr - = extendVarEnv_Directly env uniq co - - | otherwise - = env - - unbound var = pprPanic "Template variable unbound in rewrite rule" $ - vcat [ text "Variable:" <+> ppr 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 (Trac #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 simpilfy the LHS (Simplify.simplRule) we - optCoercion will turn that 'c' into Refl: - RULE forall (c :: Int~Int). f (x |> ) = 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 for c. - - This actually happened (in a RULE for a local function) - in Trac #13410, and also in test T10602. - - -Note [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: - * Adding forall'd template binders to the in-scope set - -This works even if the template binder are already in scope -(in the target) because - - * The RuleSubst rs_tv_subst, rs_id_subst maps LHS template vars to - the target world. It is not applied recursively. - - * Having the template vars in the in-scope set ensures that in - example 2 above, the (\x.x) is cloned to (\x'. x'). - -In the past we used rnBndrL to clone the template variables if -they were already in scope. But (a) that's not necessary and (b) -it complicate the fancy footwork for Note [Unbound template type variables] - - -************************************************************************ -* * - The main matcher -* * -********************************************************************* -} - --- * 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 RuleMatchEnv - = RV { rv_tmpls :: VarSet -- Template variables - , rv_lcl :: RnEnv2 -- Renamings for *local bindings* - -- (lambda/case) - , rv_fltR :: Subst -- Renamings for floated let-bindings - -- domain disjoint from envR of rv_lcl - -- See Note [Matching lets] - , rv_unf :: IdUnfoldingFun - } - -rvInScopeEnv :: RuleMatchEnv -> InScopeEnv -rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) - -data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the - , rs_id_subst :: IdSubstEnv -- template variables - , rs_binds :: BindWrapper -- Floated bindings - , rs_bndrs :: VarSet -- 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 = emptyVarSet } - --- At one stage I tried to match even if there are more --- template args than real args. - --- 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 - - -match :: RuleMatchEnv - -> RuleSubst - -> CoreExpr -- Template - -> CoreExpr -- Target - -> Maybe RuleSubst - --- We look through certain ticks. See note [Tick annotations in RULE matching] -match renv subst e1 (Tick t e2) - | tickishFloatable t - = match renv subst' e1 e2 - where subst' = subst { rs_binds = rs_binds subst . mkTick t } -match _ _ e@Tick{} _ - = pprPanic "Tick in rule" (ppr e) - --- See the notes with Unify.match, which matches types --- Everything is very similar for terms - --- Interesting examples: --- Consider matching --- \x->f against \f->f --- When we meet the lambdas we must remember to rename f to f' in the --- second expression. The RnEnv2 does that. --- --- Consider matching --- forall a. \b->b against \a->3 --- We must rename the \a. Otherwise when we meet the lambdas we --- might substitute [a/b] in the template, and then erroneously --- succeed in matching what looks like the template variable 'a' against 3. - --- The Var case follows closely what happens in Unify.match -match renv subst (Var v1) e2 = match_var renv subst v1 e2 - -match renv subst e1 (Var v2) -- 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' - 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 - -match renv subst e1 (Let bind e2) - | -- 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' }) - (subst { rs_binds = rs_binds subst . Let bind' - , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) - e1 e2 - where - flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) - (flt_subst', bind') = substBind flt_subst bind - new_bndrs = bindersOf bind' - -{- 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 _ subst (Lit lit1) (Lit lit2) - | lit1 == lit2 - = Just subst - -match renv subst (App f1 a1) (App f2 a2) - = do { subst' <- match renv subst f1 f2 - ; match renv subst' a1 a2 } - -match renv subst (Lam x1 e1) e2 - | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2 - = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 - , rv_fltR = delBndr (rv_fltR renv) x2 } - subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } - in match renv' subst' e1 e2 - -match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) - = do { subst1 <- match_ty renv subst ty1 ty2 - ; subst2 <- match renv subst1 e1 e2 - ; let renv' = rnMatchBndr2 renv subst x1 x2 - ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted - } - -match renv subst (Type ty1) (Type ty2) - = match_ty renv subst ty1 ty2 -match renv subst (Coercion co1) (Coercion co2) - = match_co renv subst co1 co2 - -match renv subst (Cast e1 co1) (Cast e2 co2) - = do { subst1 <- match_co renv subst co1 co2 - ; match renv subst1 e1 e2 } - --- Everything else fails -match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ - Nothing - -------------- -match_co :: RuleMatchEnv - -> RuleSubst - -> Coercion - -> Coercion - -> Maybe RuleSubst -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 } -match_co renv subst co1 co2 - | Just (tc1, cos1) <- splitTyConAppCo_maybe co1 - = case splitTyConAppCo_maybe co2 of - Just (tc2, cos2) - | tc1 == tc2 - -> match_cos renv subst cos1 cos2 - _ -> Nothing -match_co renv subst co1 co2 - | Just (arg1, res1) <- splitFunCo_maybe co1 - = case splitFunCo_maybe co2 of - Just (arg2, res2) - -> match_cos renv subst [arg1, res1] [arg2, res2] - _ -> Nothing -match_co _ _ _co1 _co2 - -- Currently just deals with CoVarCo, TyConAppCo and Refl -#ifdef DEBUG - = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing -#else - = Nothing -#endif - -match_cos :: RuleMatchEnv - -> RuleSubst - -> [Coercion] - -> [Coercion] - -> Maybe RuleSubst -match_cos renv subst (co1:cos1) (co2:cos2) = - do { subst' <- match_co renv subst co1 co2 - ; match_cos renv subst' cos1 cos2 } -match_cos _ subst [] [] = Just subst -match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing - -------------- -rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv -rnMatchBndr2 renv subst x1 x2 - = renv { rv_lcl = rnBndr2 rn_env x1 x2 - , rv_fltR = delBndr (rv_fltR renv) x2 } - where - rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst) - -- Typically this is a no-op, but it may matter if - -- there are some floated let-bindings - ------------------------------------------- -match_alts :: RuleMatchEnv - -> RuleSubst - -> [CoreAlt] -- Template - -> [CoreAlt] -- Target - -> Maybe RuleSubst -match_alts _ subst [] [] - = return subst -match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) - | c1 == c2 - = do { subst1 <- match renv' subst r1 r2 - ; match_alts renv subst1 alts1 alts2 } - where - renv' = foldl mb renv (vs1 `zip` vs2) - mb renv (v1,v2) = rnMatchBndr2 renv subst 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 | v1' == rnOccR rn_env v2 - -> Just subst - - | Var v2' <- lookupIdSubst (text "match_var") flt_env v2 - , v1' == v2' - -> Just subst - - _ -> 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 -- Occurs check 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 - = -- Note [Matching variable types] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- However, we must match the *types*; e.g. - -- forall (c::Char->Int) (x::Char). - -- f (c x) = "RULE FIRED" - -- We must only match on args that have the right type - -- 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 - 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' | isEmptyVarSet let_bndrs = e2 - | otherwise = substExpr (text "match_tmpl_var") 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 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 [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 Notes 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. - -cf Note [Notes in call patterns] in SpecConstr - -Note [Matching lets] -~~~~~~~~~~~~~~~~~~~~ -Matching a let-expression. Consider - RULE forall x. f (g x) = -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. ) 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? - f (let v = x+1 in v) v - --> NOT! - let v = x+1 in f (x+1) v - - (b) 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 "RuleFloatLet". - -Our cunning plan is this: - * 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. - - * The RnEnv2 in the MatchEnv binds only the local binders - in the term (lambdas, case) - - * When we encounter a let in the term to be matched, we - check that does not mention any locally bound (lambda, case) - variables. If so we fail - - * We use CoreSubst.substBind to freshen the binding, using an - in-scope set that is the original in-scope variables plus the - rs_bndrs (currently floated let-bindings). So in (a) above - we'll freshen the 'v' binding; in (b) above we'll freshen - the *second* 'v' binding. - - * We apply that freshening substitution, in a lexically-scoped - way to the term, although lazily; this is the rv_fltR field. - - -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 :: CompilerPhase -- ^ Rule activation test - -> String -- ^ Rule pattern - -> RuleEnv -- ^ Database of rules - -> CoreProgram -- ^ Bindings to check in - -> SDoc -- ^ Resulting check message -ruleCheckProgram phase rule_pat rule_base 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_rule_base = rule_base } - 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_rule_base :: RuleEnv -} - -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 | (_,_,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 (getRules (rc_rule_base 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 = sdocWithDynFlags $ \dflags -> - rule_herald rule <> colon <+> rule_info dflags 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 dflags rule - | Just _ <- matchRule dflags (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 - 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 } diff --git a/specialise/SpecConstr.hs b/specialise/SpecConstr.hs deleted file mode 100644 --- a/specialise/SpecConstr.hs +++ /dev/null @@ -1,2269 +0,0 @@ -{- -ToDo [Oct 2013] -~~~~~~~~~~~~~~~ -1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim) -2. Nuke NoSpecConstr - - -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[SpecConstr]{Specialise over constructors} --} - -{-# LANGUAGE CPP #-} - -module SpecConstr( - specConstrProgram, - SpecConstrAnnotation(..) - ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreSubst -import CoreUtils -import CoreUnfold ( couldBeSmallEnoughToInline ) -import CoreFVs ( exprsFreeVarsList ) -import CoreMonad -import Literal ( litIsLifted ) -import HscTypes ( ModGuts(..) ) -import WwLib ( isWorkerSmallEnough, mkWorkerArgs ) -import DataCon -import Coercion hiding( substCo ) -import Rules -import Type hiding ( substTy ) -import TyCon ( tyConName ) -import Id -import PprCore ( pprParendExpr ) -import MkCore ( mkImpossibleExpr ) -import Var -import VarEnv -import VarSet -import Name -import BasicTypes -import DynFlags ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) - , gopt, hasPprDebug ) -import Maybes ( orElse, catMaybes, isJust, isNothing ) -import Demand -import GHC.Serialized ( deserializeWithData ) -import Util -import Pair -import UniqSupply -import Outputable -import FastString -import UniqFM -import MonadUtils -import Control.Monad ( zipWithM ) -import Data.List -import PrelNames ( specTyConName ) -import Module -import TyCon ( TyCon ) -import GHC.Exts( SpecConstrAnnotation(..) ) -import Data.Ord( comparing ) - -{- ------------------------------------------------------ - Game plan ------------------------------------------------------ - -Consider - drop n [] = [] - drop 0 xs = [] - drop n (x:xs) = drop (n-1) xs - -After the first time round, we could pass n unboxed. This happens in -numerical code too. Here's what it looks like in Core: - - drop n xs = case xs of - [] -> [] - (y:ys) -> case n of - I# n# -> case n# of - 0 -> [] - _ -> drop (I# (n# -# 1#)) xs - -Notice that the recursive call has an explicit constructor as argument. -Noticing this, we can make a specialised version of drop - - RULE: drop (I# n#) xs ==> drop' n# xs - - drop' n# xs = let n = I# n# in ...orig RHS... - -Now the simplifier will apply the specialisation in the rhs of drop', giving - - drop' n# xs = case xs of - [] -> [] - (y:ys) -> case n# of - 0 -> [] - _ -> drop' (n# -# 1#) xs - -Much better! - -We'd also like to catch cases where a parameter is carried along unchanged, -but evaluated each time round the loop: - - f i n = if i>0 || i>n then i else f (i*2) n - -Here f isn't strict in n, but we'd like to avoid evaluating it each iteration. -In Core, by the time we've w/wd (f is strict in i) we get - - f i# n = case i# ># 0 of - False -> I# i# - True -> case n of { I# n# -> - case i# ># n# of - False -> I# i# - True -> f (i# *# 2#) n - -At the call to f, we see that the argument, n is known to be (I# n#), -and n is evaluated elsewhere in the body of f, so we can play the same -trick as above. - - -Note [Reboxing] -~~~~~~~~~~~~~~~ -We must be careful not to allocate the same constructor twice. Consider - f p = (...(case p of (a,b) -> e)...p..., - ...let t = (r,s) in ...t...(f t)...) -At the recursive call to f, we can see that t is a pair. But we do NOT want -to make a specialised copy: - f' a b = let p = (a,b) in (..., ...) -because now t is allocated by the caller, then r and s are passed to the -recursive call, which allocates the (r,s) pair again. - -This happens if - (a) the argument p is used in other than a case-scrutinisation way. - (b) the argument to the call is not a 'fresh' tuple; you have to - look into its unfolding to see that it's a tuple - -Hence the "OR" part of Note [Good arguments] below. - -ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves -allocation, but does perhaps save evals. In the RULE we'd have -something like - - f (I# x#) = f' (I# x#) x# - -If at the call site the (I# x) was an unfolding, then we'd have to -rely on CSE to eliminate the duplicate allocation.... This alternative -doesn't look attractive enough to pursue. - -ALTERNATIVE 3: ignore the reboxing problem. The trouble is that -the conservative reboxing story prevents many useful functions from being -specialised. Example: - foo :: Maybe Int -> Int -> Int - foo (Just m) 0 = 0 - foo x@(Just m) n = foo x (n-m) -Here the use of 'x' will clearly not require boxing in the specialised function. - -The strictness analyser has the same problem, in fact. Example: - f p@(a,b) = ... -If we pass just 'a' and 'b' to the worker, it might need to rebox the -pair to create (a,b). A more sophisticated analysis might figure out -precisely the cases in which this could happen, but the strictness -analyser does no such analysis; it just passes 'a' and 'b', and hopes -for the best. - -So my current choice is to make SpecConstr similarly aggressive, and -ignore the bad potential of reboxing. - - -Note [Good arguments] -~~~~~~~~~~~~~~~~~~~~~ -So we look for - -* A self-recursive function. Ignore mutual recursion for now, - because it's less common, and the code is simpler for self-recursion. - -* EITHER - - a) At a recursive call, one or more parameters is an explicit - constructor application - AND - That same parameter is scrutinised by a case somewhere in - the RHS of the function - - OR - - b) At a recursive call, one or more parameters has an unfolding - that is an explicit constructor application - AND - That same parameter is scrutinised by a case somewhere in - the RHS of the function - AND - Those are the only uses of the parameter (see Note [Reboxing]) - - -What to abstract over -~~~~~~~~~~~~~~~~~~~~~ -There's a bit of a complication with type arguments. If the call -site looks like - - f p = ...f ((:) [a] x xs)... - -then our specialised function look like - - f_spec x xs = let p = (:) [a] x xs in ....as before.... - -This only makes sense if either - a) the type variable 'a' is in scope at the top of f, or - b) the type variable 'a' is an argument to f (and hence fs) - -Actually, (a) may hold for value arguments too, in which case -we may not want to pass them. Suppose 'x' is in scope at f's -defn, but xs is not. Then we'd like - - f_spec xs = let p = (:) [a] x xs in ....as before.... - -Similarly (b) may hold too. If x is already an argument at the -call, no need to pass it again. - -Finally, if 'a' is not in scope at the call site, we could abstract -it as we do the term variables: - - f_spec a x xs = let p = (:) [a] x xs in ...as before... - -So the grand plan is: - - * abstract the call site to a constructor-only pattern - e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3) - - * Find the free variables of the abstracted pattern - - * Pass these variables, less any that are in scope at - the fn defn. But see Note [Shadowing] below. - - -NOTICE that we only abstract over variables that are not in scope, -so we're in no danger of shadowing variables used in "higher up" -in f_spec's RHS. - - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -In this pass we gather up usage information that may mention variables -that are bound between the usage site and the definition site; or (more -seriously) may be bound to something different at the definition site. -For example: - - f x = letrec g y v = let x = ... - in ...(g (a,b) x)... - -Since 'x' is in scope at the call site, we may make a rewrite rule that -looks like - RULE forall a,b. g (a,b) x = ... -But this rule will never match, because it's really a different 'x' at -the call site -- and that difference will be manifest by the time the -simplifier gets to it. [A worry: the simplifier doesn't *guarantee* -no-shadowing, so perhaps it may not be distinct?] - -Anyway, the rule isn't actually wrong, it's just not useful. One possibility -is to run deShadowBinds before running SpecConstr, but instead we run the -simplifier. That gives the simplest possible program for SpecConstr to -chew on; and it virtually guarantees no shadowing. - -Note [Specialising for constant parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This one is about specialising on a *constant* (but not necessarily -constructor) argument - - foo :: Int -> (Int -> Int) -> Int - foo 0 f = 0 - foo m f = foo (f m) (+1) - -It produces - - lvl_rmV :: GHC.Base.Int -> GHC.Base.Int - lvl_rmV = - \ (ds_dlk :: GHC.Base.Int) -> - case ds_dlk of wild_alH { GHC.Base.I# x_alG -> - GHC.Base.I# (GHC.Prim.+# x_alG 1) - - T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> - GHC.Prim.Int# - T.$wfoo = - \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) -> - case ww_sme of ds_Xlw { - __DEFAULT -> - case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz -> - T.$wfoo ww1_Xmz lvl_rmV - }; - 0 -> 0 - } - -The recursive call has lvl_rmV as its argument, so we could create a specialised copy -with that argument baked in; that is, not passed at all. Now it can perhaps be inlined. - -When is this worth it? Call the constant 'lvl' -- If 'lvl' has an unfolding that is a constructor, see if the corresponding - parameter is scrutinised anywhere in the body. - -- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding - parameter is applied (...to enough arguments...?) - - Also do this is if the function has RULES? - -Also - -Note [Specialising for lambda parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - foo :: Int -> (Int -> Int) -> Int - foo 0 f = 0 - foo m f = foo (f m) (\n -> n-m) - -This is subtly different from the previous one in that we get an -explicit lambda as the argument: - - T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> - GHC.Prim.Int# - T.$wfoo = - \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) -> - case ww_sm8 of ds_Xlr { - __DEFAULT -> - case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq -> - T.$wfoo - ww1_Xmq - (\ (n_ad3 :: GHC.Base.Int) -> - case n_ad3 of wild_alB { GHC.Base.I# x_alA -> - GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr) - }) - }; - 0 -> 0 - } - -I wonder if SpecConstr couldn't be extended to handle this? After all, -lambda is a sort of constructor for functions and perhaps it already -has most of the necessary machinery? - -Furthermore, there's an immediate win, because you don't need to allocate the lambda -at the call site; and if perchance it's called in the recursive call, then you -may avoid allocating it altogether. Just like for constructors. - -Looks cool, but probably rare...but it might be easy to implement. - - -Note [SpecConstr for casts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T a :: * - data instance T Int = T Int - - foo n = ... - where - go (T 0) = 0 - go (T n) = go (T (n-1)) - -The recursive call ends up looking like - go (T (I# ...) `cast` g) -So we want to spot the constructor application inside the cast. -That's why we have the Cast case in argToPat - -Note [Local recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a *local* recursive group, we can see all the calls to the -function, so we seed the specialisation loop from the calls in the -body, not from the calls in the RHS. Consider: - - bar m n = foo n (n,n) (n,n) (n,n) (n,n) - where - foo n p q r s - | n == 0 = m - | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s } - | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s } - | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s } - | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) } - -If we start with the RHSs of 'foo', we get lots and lots of specialisations, -most of which are not needed. But if we start with the (single) call -in the rhs of 'bar' we get exactly one fully-specialised copy, and all -the recursive calls go to this fully-specialised copy. Indeed, the original -function is later collected as dead code. This is very important in -specialising the loops arising from stream fusion, for example in NDP where -we were getting literally hundreds of (mostly unused) specialisations of -a local function. - -In a case like the above we end up never calling the original un-specialised -function. (Although we still leave its code around just in case.) - -However, if we find any boring calls in the body, including *unsaturated* -ones, such as - letrec foo x y = ....foo... - in map foo xs -then we will end up calling the un-specialised function, so then we *should* -use the calls in the un-specialised RHS as seeds. We call these -"boring call patterns", and callsToPats reports if it finds any of these. - -Note [Seeding top-level recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This seeding is done in the binding for seed_calls in specRec. - -1. If all the bindings in a top-level recursive group are local (not - exported), then all the calls are in the rest of the top-level - bindings. This means we can specialise with those call patterns - ONLY, and NOT with the RHSs of the recursive group (exactly like - Note [Local recursive groups]) - -2. But if any of the bindings are exported, the function may be called - with any old arguments, so (for lack of anything better) we specialise - based on - (a) the call patterns in the RHS - (b) the call patterns in the rest of the top-level bindings - NB: before Apr 15 we used (a) only, but Dimitrios had an example - where (b) was crucial, so I added that. - Adding (b) also improved nofib allocation results: - multiplier: 4% better - minimax: 2.8% better - -Actually in case (2), instead of using the calls from the RHS, it -would be better to specialise in the importing module. We'd need to -add an INLINABLE pragma to the function, and then it can be -specialised in the importing scope, just as is done for type classes -in Specialise.specImports. This remains to be done (#10346). - -Note [Top-level recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To get the call usage information from "the rest of the top level -bindings" (c.f. Note [Seeding top-level recursive groups]), we work -backwards through the top-level bindings so we see the usage before we -get to the binding of the function. Before we can collect the usage -though, we go through all the bindings and add them to the -environment. This is necessary because usage is only tracked for -functions in the environment. These two passes are called - 'go' and 'goEnv' -in specConstrProgram. (Looks a bit revolting to me.) - -Note [Do not specialise diverging functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Specialising a function that just diverges is a waste of code. -Furthermore, it broke GHC (simpl014) thus: - {-# STR Sb #-} - f = \x. case x of (a,b) -> f x -If we specialise f we get - f = \x. case x of (a,b) -> fspec a b -But fspec doesn't have decent strictness info. As it happened, -(f x) :: IO t, so the state hack applied and we eta expanded fspec, -and hence f. But now f's strictness is less than its arity, which -breaks an invariant. - - -Note [Forcing specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With stream fusion and in other similar cases, we want to fully -specialise some (but not necessarily all!) loops regardless of their -size and the number of specialisations. - -We allow a library to do this, in one of two ways (one which is -deprecated): - - 1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body. - - 2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts, - and then add *that* type as a parameter to the loop body - -The reason #2 is deprecated is because it requires GHCi, which isn't -available for things like a cross compiler using stage1. - -Here's a (simplified) example from the `vector` package. You may bring -the special 'force specialization' type into scope by saying: - - import GHC.Types (SPEC(..)) - -or by defining your own type (again, deprecated): - - data SPEC = SPEC | SPEC2 - {-# ANN type SPEC ForceSpecConstr #-} - -(Note this is the exact same definition of GHC.Types.SPEC, just -without the annotation.) - -After that, you say: - - foldl :: (a -> b -> a) -> a -> Stream b -> a - {-# INLINE foldl #-} - foldl f z (Stream step s _) = foldl_loop SPEC z s - where - foldl_loop !sPEC z s = case step s of - Yield x s' -> foldl_loop sPEC (f z x) s' - Skip -> foldl_loop sPEC z s' - Done -> z - -SpecConstr will spot the SPEC parameter and always fully specialise -foldl_loop. Note that - - * We have to prevent the SPEC argument from being removed by - w/w which is why (a) SPEC is a sum type, and (b) we have to seq on - the SPEC argument. - - * And lastly, the SPEC argument is ultimately eliminated by - SpecConstr itself so there is no runtime overhead. - -This is all quite ugly; we ought to come up with a better design. - -ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set -sc_force to True when calling specLoop. This flag does four things: - - * Ignore specConstrThreshold, to specialise functions of arbitrary size - (see scTopBind) - * Ignore specConstrCount, to make arbitrary numbers of specialisations - (see specialise) - * Specialise even for arguments that are not scrutinised in the loop - (see argToPat; Trac #4488) - * Only specialise on recursive types a finite number of times - (see is_too_recursive; Trac #5550; Note [Limit recursive specialisation]) - -The flag holds only for specialising a single binding group, and NOT -for nested bindings. (So really it should be passed around explicitly -and not stored in ScEnv.) Trac #14379 turned out to be caused by - f SPEC x = let g1 x = ... - in ... -We force-specialise f (becuase of the SPEC), but that generates a specialised -copy of g1 (as well as the original). Alas g1 has a nested binding g2; and -in each copy of g1 we get an unspecialised and specialised copy of g2; and so -on. Result, exponential. So the force-spec flag now only applies to one -level of bindings at a time. - -Mechanism for this one-level-only thing: - - - Switch it on at the call to specRec, in scExpr and scTopBinds - - Switch it off when doing the RHSs; - this can be done very conveneniently in decreaseSpecCount - -What alternatives did I consider? - -* Annotating the loop itself doesn't work because (a) it is local and - (b) it will be w/w'ed and having w/w propagating annotations somehow - doesn't seem like a good idea. The types of the loop arguments - really seem to be the most persistent thing. - -* Annotating the types that make up the loop state doesn't work, - either, because (a) it would prevent us from using types like Either - or tuples here, (b) we don't want to restrict the set of types that - can be used in Stream states and (c) some types are fixed by the - user (e.g., the accumulator here) but we still want to specialise as - much as possible. - -Alternatives to ForceSpecConstr -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instead of giving the loop an extra argument of type SPEC, we -also considered *wrapping* arguments in SPEC, thus - data SPEC a = SPEC a | SPEC2 - - loop = \arg -> case arg of - SPEC state -> - case state of (x,y) -> ... loop (SPEC (x',y')) ... - S2 -> error ... -The idea is that a SPEC argument says "specialise this argument -regardless of whether the function case-analyses it". But this -doesn't work well: - * SPEC must still be a sum type, else the strictness analyser - eliminates it - * But that means that 'loop' won't be strict in its real payload -This loss of strictness in turn screws up specialisation, because -we may end up with calls like - loop (SPEC (case z of (p,q) -> (q,p))) -Without the SPEC, if 'loop' were strict, the case would move out -and we'd see loop applied to a pair. But if 'loop' isn't strict -this doesn't look like a specialisable call. - -Note [Limit recursive specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible for ForceSpecConstr to cause an infinite loop of specialisation. -Because there is no limit on the number of specialisations, a recursive call with -a recursive constructor as an argument (for example, list cons) will generate -a specialisation for that constructor. If the resulting specialisation also -contains a recursive call with the constructor, this could proceed indefinitely. - -For example, if ForceSpecConstr is on: - loop :: [Int] -> [Int] -> [Int] - loop z [] = z - loop z (x:xs) = loop (x:z) xs -this example will create a specialisation for the pattern - loop (a:b) c = loop' a b c - - loop' a b [] = (a:b) - loop' a b (x:xs) = loop (x:(a:b)) xs -and a new pattern is found: - loop (a:(b:c)) d = loop'' a b c d -which can continue indefinitely. - -Roman's suggestion to fix this was to stop after a couple of times on recursive types, -but still specialising on non-recursive types as much as possible. - -To implement this, we count the number of times we have gone round the -"specialise recursively" loop ('go' in 'specRec'). Once have gone round -more than N times (controlled by -fspec-constr-recursive=N) we check - - - If sc_force is off, and sc_count is (Just max) then we don't - need to do anything: trim_pats will limit the number of specs - - - Otherwise check if any function has now got more than (sc_count env) - specialisations. If sc_count is "no limit" then we arbitrarily - choose 10 as the limit (ugh). - -See Trac #5550. Also Trac #13623, where this test had become over-agressive, -and we lost a wonderful specialisation that we really wanted! - -Note [NoSpecConstr] -~~~~~~~~~~~~~~~~~~~ -The ignoreDataCon stuff allows you to say - {-# ANN type T NoSpecConstr #-} -to mean "don't specialise on arguments of this type". It was added -before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised -regardless of size; and then we needed a way to turn that *off*. Now -that we have ForceSpecConstr, this NoSpecConstr is probably redundant. -(Used only for PArray.) - ------------------------------------------------------ - Stuff not yet handled ------------------------------------------------------ - -Here are notes arising from Roman's work that I don't want to lose. - -Example 1 -~~~~~~~~~ - data T a = T !a - - foo :: Int -> T Int -> Int - foo 0 t = 0 - foo x t | even x = case t of { T n -> foo (x-n) t } - | otherwise = foo (x-1) t - -SpecConstr does no specialisation, because the second recursive call -looks like a boxed use of the argument. A pity. - - $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# - $wfoo_sFw = - \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) -> - case ww_sFo of ds_Xw6 [Just L] { - __DEFAULT -> - case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] { - __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq; - 0 -> - case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] -> - case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] -> - $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy - } } }; - 0 -> 0 - -Example 2 -~~~~~~~~~ - data a :*: b = !a :*: !b - data T a = T !a - - foo :: (Int :*: T Int) -> Int - foo (0 :*: t) = 0 - foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) } - | otherwise = foo ((x-1) :*: t) - -Very similar to the previous one, except that the parameters are now in -a strict tuple. Before SpecConstr, we have - - $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# - $wfoo_sG3 = - \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T - GHC.Base.Int) -> - case ww_sFU of ds_Xws [Just L] { - __DEFAULT -> - case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] { - __DEFAULT -> - case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] -> - $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1 - }; - 0 -> - case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] -> - case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] -> - $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2 - } } }; - 0 -> 0 } - -We get two specialisations: -"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#} - Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB) - = Foo.$s$wfoo1 a_sFB sc_sGC ; -"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#} - Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp)) - = Foo.$s$wfoo y_aFp sc_sGC ; - -But perhaps the first one isn't good. After all, we know that tpl_B2 is -a T (I# x) really, because T is strict and Int has one constructor. (We can't -unbox the strict fields, because T is polymorphic!) - -************************************************************************ -* * -\subsection{Top level wrapper stuff} -* * -************************************************************************ --} - -specConstrProgram :: ModGuts -> CoreM ModGuts -specConstrProgram guts - = do - dflags <- getDynFlags - us <- getUniqueSupplyM - annos <- getFirstAnnotations deserializeWithData guts - this_mod <- getModule - let binds' = reverse $ fst $ initUs us $ do - -- Note [Top-level recursive groups] - (env, binds) <- goEnv (initScEnv dflags this_mod annos) - (mg_binds guts) - -- binds is identical to (mg_binds guts), except that the - -- binders on the LHS have been replaced by extendBndr - -- (SPJ this seems like overkill; I don't think the binders - -- will change at all; and we don't substitute in the RHSs anyway!!) - go env nullUsage (reverse binds) - - return (guts { mg_binds = binds' }) - where - -- See Note [Top-level recursive groups] - goEnv env [] = return (env, []) - goEnv env (bind:binds) = do (env', bind') <- scTopBindEnv env bind - (env'', binds') <- goEnv env' binds - return (env'', bind' : binds') - - -- Arg list of bindings is in reverse order - go _ _ [] = return [] - go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind - binds' <- go env usg' binds - return (bind' : binds') - -{- -************************************************************************ -* * -\subsection{Environment: goes downwards} -* * -************************************************************************ - -Note [Work-free values only in environment] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The sc_vals field keeps track of in-scope value bindings, so -that if we come across (case x of Just y ->...) we can reduce the -case from knowing that x is bound to a pair. - -But only *work-free* values are ok here. For example if the envt had - x -> Just (expensive v) -then we do NOT want to expand to - let y = expensive v in ... -because the x-binding still exists and we've now duplicated (expensive v). - -This seldom happens because let-bound constructor applications are -ANF-ised, but it can happen as a result of on-the-fly transformations in -SpecConstr itself. Here is Trac #7865: - - let { - a'_shr = - case xs_af8 of _ { - [] -> acc_af6; - : ds_dgt [Dmd=] ds_dgu [Dmd=] -> - (expensive x_af7, x_af7 - } } in - let { - ds_sht = - case a'_shr of _ { (p'_afd, q'_afe) -> - TSpecConstr_DoubleInline.recursive - (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd) - } } in - -When processed knowing that xs_af8 was bound to a cons, we simplify to - a'_shr = (expensive x_af7, x_af7) -and we do NOT want to inline that at the occurrence of a'_shr in ds_sht. -(There are other occurrences of a'_shr.) No no no. - -It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned -into a work-free value again, thus - a1 = expensive x_af7 - a'_shr = (a1, x_af7) -but that's more work, so until its shown to be important I'm going to -leave it for now. - -Note [Making SpecConstr keener] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this, in (perf/should_run/T9339) - last (filter odd [1..1000]) - -After optimisation, including SpecConstr, we get: - f :: Int# -> Int -> Int - f x y = case case remInt# x 2# of - __DEFAULT -> case x of - __DEFAULT -> f (+# wild_Xp 1#) (I# x) - 1000000# -> ... - 0# -> case x of - __DEFAULT -> f (+# wild_Xp 1#) y - 1000000# -> y - -Not good! We build an (I# x) box every time around the loop. -SpecConstr (as described in the paper) does not specialise f, despite -the call (f ... (I# x)) because 'y' is not scrutinied in the body. -But it is much better to specialise f for the case where the argument -is of form (I# x); then we build the box only when returning y, which -is on the cold path. - -Another example: - - f x = ...(g x).... - -Here 'x' is not scrutinised in f's body; but if we did specialise 'f' -then the call (g x) might allow 'g' to be specialised in turn. - -So sc_keen controls whether or not we take account of whether argument is -scrutinised in the body. True <=> ignore that, and speicalise whenever -the function is applied to a data constructor. --} - -data ScEnv = SCE { sc_dflags :: DynFlags, - sc_module :: !Module, - sc_size :: Maybe Int, -- Size threshold - -- Nothing => no limit - - sc_count :: Maybe Int, -- Max # of specialisations for any one fn - -- Nothing => no limit - -- See Note [Avoiding exponential blowup] - - sc_recursive :: Int, -- Max # of specialisations over recursive type. - -- Stops ForceSpecConstr from diverging. - - sc_keen :: Bool, -- Specialise on arguments that are known - -- constructors, even if they are not - -- scrutinised in the body. See - -- Note [Making SpecConstr keener] - - sc_force :: Bool, -- Force specialisation? - -- See Note [Forcing specialisation] - - sc_subst :: Subst, -- Current substitution - -- Maps InIds to OutExprs - - sc_how_bound :: HowBoundEnv, - -- Binds interesting non-top-level variables - -- Domain is OutVars (*after* applying the substitution) - - sc_vals :: ValueEnv, - -- Domain is OutIds (*after* applying the substitution) - -- Used even for top-level bindings (but not imported ones) - -- The range of the ValueEnv is *work-free* values - -- such as (\x. blah), or (Just v) - -- but NOT (Just (expensive v)) - -- See Note [Work-free values only in environment] - - sc_annotations :: UniqFM SpecConstrAnnotation - } - ---------------------- -type HowBoundEnv = VarEnv HowBound -- Domain is OutVars - ---------------------- -type ValueEnv = IdEnv Value -- Domain is OutIds -data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors - -- The AltCon is never DEFAULT - | LambdaVal -- Inlinable lambdas or PAPs - -instance Outputable Value where - ppr (ConVal con args) = ppr con <+> interpp'SP args - ppr LambdaVal = text "" - ---------------------- -initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv -initScEnv dflags this_mod anns - = SCE { sc_dflags = dflags, - sc_module = this_mod, - sc_size = specConstrThreshold dflags, - sc_count = specConstrCount dflags, - sc_recursive = specConstrRecursive dflags, - sc_keen = gopt Opt_SpecConstrKeen dflags, - sc_force = False, - sc_subst = emptySubst, - sc_how_bound = emptyVarEnv, - sc_vals = emptyVarEnv, - sc_annotations = anns } - -data HowBound = RecFun -- These are the recursive functions for which - -- we seek interesting call patterns - - | RecArg -- These are those functions' arguments, or their sub-components; - -- we gather occurrence information for these - -instance Outputable HowBound where - ppr RecFun = text "RecFun" - ppr RecArg = text "RecArg" - -scForce :: ScEnv -> Bool -> ScEnv -scForce env b = env { sc_force = b } - -lookupHowBound :: ScEnv -> Id -> Maybe HowBound -lookupHowBound env id = lookupVarEnv (sc_how_bound env) id - -scSubstId :: ScEnv -> Id -> CoreExpr -scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v - -scSubstTy :: ScEnv -> Type -> Type -scSubstTy env ty = substTy (sc_subst env) ty - -scSubstCo :: ScEnv -> Coercion -> Coercion -scSubstCo env co = substCo (sc_subst env) co - -zapScSubst :: ScEnv -> ScEnv -zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } - -extendScInScope :: ScEnv -> [Var] -> ScEnv - -- Bring the quantified variables into scope -extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars } - - -- Extend the substitution -extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv -extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr } - -extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv -extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs } - -extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv -extendHowBound env bndrs how_bound - = env { sc_how_bound = extendVarEnvList (sc_how_bound env) - [(bndr,how_bound) | bndr <- bndrs] } - -extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var]) -extendBndrsWith how_bound env bndrs - = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs') - where - (subst', bndrs') = substBndrs (sc_subst env) bndrs - hb_env' = sc_how_bound env `extendVarEnvList` - [(bndr,how_bound) | bndr <- bndrs'] - -extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var) -extendBndrWith how_bound env bndr - = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr') - where - (subst', bndr') = substBndr (sc_subst env) bndr - hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound - -extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var]) -extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs') - where - (subst', bndrs') = substRecBndrs (sc_subst env) bndrs - -extendBndr :: ScEnv -> Var -> (ScEnv, Var) -extendBndr env bndr = (env { sc_subst = subst' }, bndr') - where - (subst', bndr') = substBndr (sc_subst env) bndr - -extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv -extendValEnv env _ Nothing = env -extendValEnv env id (Just cv) - | valueIsWorkFree cv -- Don't duplicate work!! Trac #7865 - = env { sc_vals = extendVarEnv (sc_vals env) id cv } -extendValEnv env _ _ = env - -extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) --- When we encounter --- case scrut of b --- C x y -> ... --- we want to bind b, to (C x y) --- NB1: Extends only the sc_vals part of the envt --- NB2: Kill the dead-ness info on the pattern binders x,y, since --- they are potentially made alive by the [b -> C x y] binding -extendCaseBndrs env scrut case_bndr con alt_bndrs - = (env2, alt_bndrs') - where - live_case_bndr = not (isDeadBinder case_bndr) - env1 | Var v <- stripTicksTopE (const True) scrut - = extendValEnv env v cval - | otherwise = env -- See Note [Add scrutinee to ValueEnv too] - env2 | live_case_bndr = extendValEnv env1 case_bndr cval - | otherwise = env1 - - alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr } - = map zap alt_bndrs - | otherwise - = alt_bndrs - - cval = case con of - DEFAULT -> Nothing - LitAlt {} -> Just (ConVal con []) - DataAlt {} -> Just (ConVal con vanilla_args) - where - vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ - varsToCoreExprs alt_bndrs - - zap v | isTyVar v = v -- See NB2 above - | otherwise = zapIdOccInfo v - - -decreaseSpecCount :: ScEnv -> Int -> ScEnv --- See Note [Avoiding exponential blowup] -decreaseSpecCount env n_specs - = env { sc_force = False -- See Note [Forcing specialisation] - , sc_count = case sc_count env of - Nothing -> Nothing - Just n -> Just (n `div` (n_specs + 1)) } - -- The "+1" takes account of the original function; - -- See Note [Avoiding exponential blowup] - ---------------------------------------------------- --- See Note [Forcing specialisation] -ignoreType :: ScEnv -> Type -> Bool -ignoreDataCon :: ScEnv -> DataCon -> Bool -forceSpecBndr :: ScEnv -> Var -> Bool - -ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) - -ignoreType env ty - = case tyConAppTyCon_maybe ty of - Just tycon -> ignoreTyCon env tycon - _ -> False - -ignoreTyCon :: ScEnv -> TyCon -> Bool -ignoreTyCon env tycon - = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr - -forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var - -forceSpecFunTy :: ScEnv -> Type -> Bool -forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys - -forceSpecArgTy :: ScEnv -> Type -> Bool -forceSpecArgTy env ty - | Just ty' <- coreView ty = forceSpecArgTy env ty' - -forceSpecArgTy env ty - | Just (tycon, tys) <- splitTyConApp_maybe ty - , tycon /= funTyCon - = tyConName tycon == specTyConName - || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr - || any (forceSpecArgTy env) tys - -forceSpecArgTy _ _ = False - -{- -Note [Add scrutinee to ValueEnv too] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - case x of y - (a,b) -> case b of c - I# v -> ...(f y)... -By the time we get to the call (f y), the ValueEnv -will have a binding for y, and for c - y -> (a,b) - c -> I# v -BUT that's not enough! Looking at the call (f y) we -see that y is pair (a,b), but we also need to know what 'b' is. -So in extendCaseBndrs we must *also* add the binding - b -> I# v -else we lose a useful specialisation for f. This is necessary even -though the simplifier has systematically replaced uses of 'x' with 'y' -and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came -from outside the case. See Trac #4908 for the live example. - -Note [Avoiding exponential blowup] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The sc_count field of the ScEnv says how many times we are prepared to -duplicate a single function. But we must take care with recursive -specialisations. Consider - - let $j1 = let $j2 = let $j3 = ... - in - ...$j3... - in - ...$j2... - in - ...$j1... - -If we specialise $j1 then in each specialisation (as well as the original) -we can specialise $j2, and similarly $j3. Even if we make just *one* -specialisation of each, because we also have the original we'll get 2^n -copies of $j3, which is not good. - -So when recursively specialising we divide the sc_count by the number of -copies we are making at this level, including the original. - - -************************************************************************ -* * -\subsection{Usage information: flows upwards} -* * -************************************************************************ --} - -data ScUsage - = SCU { - scu_calls :: CallEnv, -- Calls - -- The functions are a subset of the - -- RecFuns in the ScEnv - - scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences - } -- The domain is OutIds - -type CallEnv = IdEnv [Call] -data Call = Call Id [CoreArg] ValueEnv - -- The arguments of the call, together with the - -- env giving the constructor bindings at the call site - -- We keep the function mainly for debug output - -instance Outputable ScUsage where - ppr (SCU { scu_calls = calls, scu_occs = occs }) - = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls - , text "occs =" <+> ppr occs ]) - -instance Outputable Call where - ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args) - -nullUsage :: ScUsage -nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv } - -combineCalls :: CallEnv -> CallEnv -> CallEnv -combineCalls = plusVarEnv_C (++) - where --- plus cs ds | length res > 1 --- = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs --- , text "ds:" <+> ppr ds]) --- res --- | otherwise = res --- where --- res = cs ++ ds - -combineUsage :: ScUsage -> ScUsage -> ScUsage -combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2), - scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) } - -combineUsages :: [ScUsage] -> ScUsage -combineUsages [] = nullUsage -combineUsages us = foldr1 combineUsage us - -lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc]) -lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs - = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, - [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs]) - -data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument - | UnkOcc -- Used in some unknown way - - | ScrutOcc -- See Note [ScrutOcc] - (DataConEnv [ArgOcc]) -- How the sub-components are used - -type DataConEnv a = UniqFM a -- Keyed by DataCon - -{- Note [ScrutOcc] -~~~~~~~~~~~~~~~~~~~ -An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, -is *only* taken apart or applied. - - Functions, literal: ScrutOcc emptyUFM - Data constructors: ScrutOcc subs, - -where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components, -The domain of the UniqFM is the Unique of the data constructor - -The [ArgOcc] is the occurrences of the *pattern-bound* components -of the data structure. E.g. - data T a = forall b. MkT a b (b->a) -A pattern binds b, x::a, y::b, z::b->a, but not 'a'! - --} - -instance Outputable ArgOcc where - ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs - ppr UnkOcc = text "unk-occ" - ppr NoOcc = text "no-occ" - -evalScrutOcc :: ArgOcc -evalScrutOcc = ScrutOcc emptyUFM - --- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so --- that if the thing is scrutinised anywhere then we get to see that --- in the overall result, even if it's also used in a boxed way --- This might be too aggressive; see Note [Reboxing] Alternative 3 -combineOcc :: ArgOcc -> ArgOcc -> ArgOcc -combineOcc NoOcc occ = occ -combineOcc occ NoOcc = occ -combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys) -combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys -combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs -combineOcc UnkOcc UnkOcc = UnkOcc - -combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] -combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys - -setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage --- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee --- is a variable, and an interesting variable -setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ -setScrutOcc env usg (Tick _ e) occ = setScrutOcc env usg e occ -setScrutOcc env usg (Var v) occ - | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ } - | otherwise = usg -setScrutOcc _env usg _other _occ -- Catch-all - = usg - -{- -************************************************************************ -* * -\subsection{The main recursive function} -* * -************************************************************************ - -The main recursive function gathers up usage information, and -creates specialised versions of functions. --} - -scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr) - -- The unique supply is needed when we invent - -- a new name for the specialised function and its args - -scExpr env e = scExpr' env e - -scExpr' env (Var v) = case scSubstId env v of - Var v' -> return (mkVarUsage env v' [], Var v') - e' -> scExpr (zapScSubst env) e' - -scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t)) -scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) -scExpr' _ e@(Lit {}) = return (nullUsage, e) -scExpr' env (Tick t e) = do (usg, e') <- scExpr env e - return (usg, Tick t e') -scExpr' env (Cast e co) = do (usg, e') <- scExpr env e - return (usg, mkCast e' (scSubstCo env co)) - -- Important to use mkCast here - -- See Note [SpecConstr call patterns] -scExpr' env e@(App _ _) = scApp env (collectArgs e) -scExpr' env (Lam b e) = do let (env', b') = extendBndr env b - (usg, e') <- scExpr env' e - return (usg, Lam b' e') - -scExpr' env (Case scrut b ty alts) - = do { (scrut_usg, scrut') <- scExpr env scrut - ; case isValue (sc_vals env) scrut' of - Just (ConVal con args) -> sc_con_app con args scrut' - _other -> sc_vanilla scrut_usg scrut' - } - where - sc_con_app con args scrut' -- Known constructor; simplify - = do { let (_, bs, rhs) = findAlt con alts - `orElse` (DEFAULT, [], mkImpossibleExpr ty) - alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) - ; scExpr alt_env' rhs } - - sc_vanilla scrut_usg scrut' -- Normal case - = do { let (alt_env,b') = extendBndrWith RecArg env b - -- Record RecArg for the components - - ; (alt_usgs, alt_occs, alts') - <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts - - ; let scrut_occ = foldr combineOcc NoOcc alt_occs - scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ - -- The combined usage of the scrutinee is given - -- by scrut_occ, which is passed to scScrut, which - -- in turn treats a bare-variable scrutinee specially - - ; return (foldr combineUsage scrut_usg' alt_usgs, - Case scrut' b' (scSubstTy env ty) alts') } - - sc_alt env scrut' b' (con,bs,rhs) - = do { let (env1, bs1) = extendBndrsWith RecArg env bs - (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 - ; (usg, rhs') <- scExpr env2 rhs - ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) - scrut_occ = case con of - DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) - _ -> ScrutOcc emptyUFM - ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } - -scExpr' env (Let (NonRec bndr rhs) body) - | isTyVar bndr -- Type-lets may be created by doBeta - = scExpr' (extendScSubst env bndr rhs) body - - | otherwise - = do { let (body_env, bndr') = extendBndr env bndr - ; rhs_info <- scRecRhs env (bndr',rhs) - - ; let body_env2 = extendHowBound body_env [bndr'] RecFun - -- Note [Local let bindings] - rhs' = ri_new_rhs rhs_info - body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') - - ; (body_usg, body') <- scExpr body_env3 body - - -- NB: For non-recursive bindings we inherit sc_force flag from - -- the parent function (see Note [Forcing specialisation]) - ; (spec_usg, specs) <- specNonRec env body_usg rhs_info - - ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } - `combineUsage` spec_usg, -- Note [spec_usg includes rhs_usg] - mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body') - } - - --- A *local* recursive group: see Note [Local recursive groups] -scExpr' env (Let (Rec prs) body) - = do { let (bndrs,rhss) = unzip prs - (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun - force_spec = any (forceSpecBndr env) bndrs' - -- Note [Forcing specialisation] - - ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss) - ; (body_usg, body') <- scExpr rhs_env2 body - - -- NB: start specLoop from body_usg - ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec) - body_usg rhs_infos - -- Do not unconditionally generate specialisations from rhs_usgs - -- Instead use them only if we find an unspecialised call - -- See Note [Local recursive groups] - - ; let all_usg = spec_usg `combineUsage` body_usg -- Note [spec_usg includes rhs_usg] - bind' = Rec (concat (zipWith ruleInfoBinds rhs_infos specs)) - - ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, - Let bind' body') } - -{- -Note [Local let bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~ -It is not uncommon to find this - - let $j = \x. in ...$j True...$j True... - -Here $j is an arbitrary let-bound function, but it often comes up for -join points. We might like to specialise $j for its call patterns. -Notice the difference from a letrec, where we look for call patterns -in the *RHS* of the function. Here we look for call patterns in the -*body* of the let. - -At one point I predicated this on the RHS mentioning the outer -recursive function, but that's not essential and might even be -harmful. I'm not sure. --} - -scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr) - -scApp env (Var fn, args) -- Function is a variable - = ASSERT( not (null args) ) - do { args_w_usgs <- mapM (scExpr env) args - ; let (arg_usgs, args') = unzip args_w_usgs - arg_usg = combineUsages arg_usgs - ; case scSubstId env fn of - fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') - -- Do beta-reduction and try again - - Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args', - mkApps (Var fn') args') - - other_fn' -> return (arg_usg, mkApps other_fn' args') } - -- NB: doing this ignores any usage info from the substituted - -- function, but I don't think that matters. If it does - -- we can fix it. - where - doBeta :: OutExpr -> [OutExpr] -> OutExpr - -- ToDo: adjust for System IF - doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args) - doBeta fn args = mkApps fn args - --- The function is almost always a variable, but not always. --- In particular, if this pass follows float-in, --- which it may, we can get --- (let f = ...f... in f) arg1 arg2 -scApp env (other_fn, args) - = do { (fn_usg, fn') <- scExpr env other_fn - ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args - ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') } - ----------------------- -mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage -mkVarUsage env fn args - = case lookupHowBound env fn of - Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)] - , scu_occs = emptyVarEnv } - Just RecArg -> SCU { scu_calls = emptyVarEnv - , scu_occs = unitVarEnv fn arg_occ } - Nothing -> nullUsage - where - -- I rather think we could use UnkOcc all the time - arg_occ | null args = UnkOcc - | otherwise = evalScrutOcc - ----------------------- -scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) -scTopBindEnv env (Rec prs) - = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs RecFun - - prs' = zip bndrs' rhss - ; return (rhs_env2, Rec prs') } - where - (bndrs,rhss) = unzip prs - -scTopBindEnv env (NonRec bndr rhs) - = do { let (env1, bndr') = extendBndr env bndr - env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs) - ; return (env2, NonRec bndr' rhs) } - ----------------------- -scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) - -{- -scTopBind _ usage _ - | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False - = error "false" --} - -scTopBind env body_usage (Rec prs) - | Just threshold <- sc_size env - , not force_spec - , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss) - -- No specialisation - = -- pprTrace "scTopBind: nospec" (ppr bndrs) $ - do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss - ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) } - - | otherwise -- Do specialisation - = do { rhs_infos <- mapM (scRecRhs env) prs - - ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec) - body_usage rhs_infos - - ; return (body_usage `combineUsage` spec_usage, - Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) } - where - (bndrs,rhss) = unzip prs - force_spec = any (forceSpecBndr env) bndrs - -- Note [Forcing specialisation] - -scTopBind env usage (NonRec bndr rhs) -- Oddly, we don't seem to specialise top-level non-rec functions - = do { (rhs_usg', rhs') <- scExpr env rhs - ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') } - ----------------------- -scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo -scRecRhs env (bndr,rhs) - = do { let (arg_bndrs,body) = collectBinders rhs - (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs - ; (body_usg, body') <- scExpr body_env body - ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' - ; return (RI { ri_rhs_usg = rhs_usg - , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body' - , ri_lam_bndrs = arg_bndrs, ri_lam_body = body - , ri_arg_occs = arg_occs }) } - -- The arg_occs says how the visible, - -- lambda-bound binders of the RHS are used - -- (including the TyVar binders) - -- Two pats are the same if they match both ways - ----------------------- -ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)] -ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs }) - (SI { si_specs = specs }) - = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] ++ - -- First the specialised bindings - - [(fn `addIdSpecialisations` rules, new_rhs)] - -- And now the original binding - where - rules = [r | OS { os_rule = r } <- specs] - -{- -************************************************************************ -* * - The specialiser itself -* * -************************************************************************ --} - -data RhsInfo - = RI { ri_fn :: OutId -- The binder - , ri_new_rhs :: OutExpr -- The specialised RHS (in current envt) - , ri_rhs_usg :: ScUsage -- Usage info from specialising RHS - - , ri_lam_bndrs :: [InVar] -- The *original* RHS (\xs.body) - , ri_lam_body :: InExpr -- Note [Specialise original body] - , ri_arg_occs :: [ArgOcc] -- Info on how the xs occur in body - } - -data SpecInfo -- Info about specialisations for a particular Id - = SI { si_specs :: [OneSpec] -- The specialisations we have generated - - , si_n_specs :: Int -- Length of si_specs; used for numbering them - - , si_mb_unspec :: Maybe ScUsage -- Just cs => we have not yet used calls in the - } -- from calls in the *original* RHS as - -- seeds for new specialisations; - -- if you decide to do so, here is the - -- RHS usage (which has not yet been - -- unleashed) - -- Nothing => we have - -- See Note [Local recursive groups] - -- See Note [spec_usg includes rhs_usg] - - -- One specialisation: Rule plus definition -data OneSpec = - OS { os_pat :: CallPat -- Call pattern that generated this specialisation - , os_rule :: CoreRule -- Rule connecting original id with the specialisation - , os_id :: OutId -- Spec id - , os_rhs :: OutExpr } -- Spec rhs - -noSpecInfo :: SpecInfo -noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing } - ----------------------- -specNonRec :: ScEnv - -> ScUsage -- Body usage - -> RhsInfo -- Structure info usage info for un-specialised RHS - -> UniqSM (ScUsage, SpecInfo) -- Usage from RHSs (specialised and not) - -- plus details of specialisations - -specNonRec env body_usg rhs_info - = specialise env (scu_calls body_usg) rhs_info - (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) }) - ----------------------- -specRec :: TopLevelFlag -> ScEnv - -> ScUsage -- Body usage - -> [RhsInfo] -- Structure info and usage info for un-specialised RHSs - -> UniqSM (ScUsage, [SpecInfo]) -- Usage from all RHSs (specialised and not) - -- plus details of specialisations - -specRec top_lvl env body_usg rhs_infos - = go 1 seed_calls nullUsage init_spec_infos - where - (seed_calls, init_spec_infos) -- Note [Seeding top-level recursive groups] - | isTopLevel top_lvl - , any (isExportedId . ri_fn) rhs_infos -- Seed from body and RHSs - = (all_calls, [noSpecInfo | _ <- rhs_infos]) - | otherwise -- Seed from body only - = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) } - | ri <- rhs_infos]) - - calls_in_body = scu_calls body_usg - calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos - all_calls = calls_in_rhss `combineCalls` calls_in_body - - -- Loop, specialising, until you get no new specialisations - go :: Int -- Which iteration of the "until no new specialisations" - -- loop we are on; first iteration is 1 - -> CallEnv -- Seed calls - -- Two accumulating parameters: - -> ScUsage -- Usage from earlier specialisations - -> [SpecInfo] -- Details of specialisations so far - -> UniqSM (ScUsage, [SpecInfo]) - go n_iter seed_calls usg_so_far spec_infos - | isEmptyVarEnv seed_calls - = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos) - -- , ppr seed_calls - -- , ppr body_usg ]) $ - return (usg_so_far, spec_infos) - - -- Limit recursive specialisation - -- See Note [Limit recursive specialisation] - | n_iter > sc_recursive env -- Too many iterations of the 'go' loop - , sc_force env || isNothing (sc_count env) - -- If both of these are false, the sc_count - -- threshold will prevent non-termination - , any ((> the_limit) . si_n_specs) spec_infos - = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $ - return (usg_so_far, spec_infos) - - | otherwise - = do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos - ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg - extra_usg = combineUsages extra_usg_s - all_usg = usg_so_far `combineUsage` extra_usg - ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos } - - -- See Note [Limit recursive specialisation] - the_limit = case sc_count env of - Nothing -> 10 -- Ugh! - Just max -> max - - ----------------------- -specialise - :: ScEnv - -> CallEnv -- Info on newly-discovered calls to this function - -> RhsInfo - -> SpecInfo -- Original RHS plus patterns dealt with - -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage - --- See Note [spec_usg includes rhs_usg] - --- Note: this only generates *specialised* bindings --- The original binding is added by ruleInfoBinds --- --- Note: the rhs here is the optimised version of the original rhs --- So when we make a specialised copy of the RHS, we're starting --- from an RHS whose nested functions have been optimised already. - -specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs - , ri_lam_body = body, ri_arg_occs = arg_occs }) - spec_info@(SI { si_specs = specs, si_n_specs = spec_count - , si_mb_unspec = mb_unspec }) - | isBottomingId fn -- Note [Do not specialise diverging functions] - -- and do not generate specialisation seeds from its RHS - = -- pprTrace "specialise bot" (ppr fn) $ - return (nullUsage, spec_info) - - | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation] - || null arg_bndrs -- Only specialise functions - = -- pprTrace "specialise inactive" (ppr fn) $ - case mb_unspec of -- Behave as if there was a single, boring call - Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }) - -- See Note [spec_usg includes rhs_usg] - Nothing -> return (nullUsage, spec_info) - - | Just all_calls <- lookupVarEnv bind_calls fn - = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $ - do { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls - - ; let n_pats = length new_pats --- ; if (not (null new_pats) || isJust mb_unspec) then --- pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns" --- , text "mb_unspec" <+> ppr (isJust mb_unspec) --- , text "arg_occs" <+> ppr arg_occs --- , text "good pats" <+> ppr new_pats]) $ --- return () --- else return () - - ; let spec_env = decreaseSpecCount env n_pats - ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body) - (new_pats `zip` [spec_count..]) - -- See Note [Specialise original body] - - ; let spec_usg = combineUsages spec_usgs - - -- If there were any boring calls among the seeds (= all_calls), then those - -- calls will call the un-specialised function. So we should use the seeds - -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning - -- then in new_usg. - (new_usg, mb_unspec') - = case mb_unspec of - Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing) - _ -> (spec_usg, mb_unspec) - --- ; pprTrace "specialise return }" --- (vcat [ ppr fn --- , text "boring_call:" <+> ppr boring_call --- , text "new calls:" <+> ppr (scu_calls new_usg)]) $ --- return () - - ; return (new_usg, SI { si_specs = new_specs ++ specs - , si_n_specs = spec_count + n_pats - , si_mb_unspec = mb_unspec' }) } - - | otherwise -- No new seeds, so return nullUsage - = return (nullUsage, spec_info) - - - - ---------------------- -spec_one :: ScEnv - -> OutId -- Function - -> [InVar] -- Lambda-binders of RHS; should match patterns - -> InExpr -- Body of the original function - -> (CallPat, Int) - -> UniqSM (ScUsage, OneSpec) -- Rule and binding - --- spec_one creates a specialised copy of the function, together --- with a rule for using it. I'm very proud of how short this --- function is, considering what it does :-). - -{- - Example - - In-scope: a, x::a - f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))... - [c::*, v::(b,c) are presumably bound by the (...) part] - ==> - f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] -> - (...entire body of f...) [b -> (b,c), - y -> ((:) (a,(b,c)) (x,v) hw)] - - RULE: forall b::* c::*, -- Note, *not* forall a, x - v::(b,c), - hw::[(a,(b,c))] . - - f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw --} - -spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) - = do { spec_uniq <- getUniqueM - ; let spec_env = extendScSubstList (extendScInScope env qvars) - (arg_bndrs `zip` pats) - fn_name = idName fn - fn_loc = nameSrcSpan fn_name - fn_occ = nameOccName fn_name - spec_occ = mkSpecOcc fn_occ - -- We use fn_occ rather than fn in the rule_name string - -- as we don't want the uniq to end up in the rule, and - -- hence in the ABI, as that can cause spurious ABI - -- changes (#4012). - rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) - spec_name = mkInternalName spec_uniq spec_occ fn_loc --- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn --- <+> ppr pats <+> text "-->" <+> ppr spec_name) $ --- return () - - -- Specialise the body - ; (spec_usg, spec_body) <- scExpr spec_env body - --- ; pprTrace "done spec_one}" (ppr fn) $ --- return () - - -- And build the results - ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) - qvars body_ty - -- Usual w/w hack to avoid generating - -- a spec_rhs of unlifted type and no args - - spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args - -- Annotate the variables with the strictness information from - -- the function (see Note [Strictness information in worker binders]) - - spec_join_arity | isJoinId fn = Just (length spec_lam_args) - | otherwise = Nothing - spec_id = mkLocalIdOrCoVar spec_name - (mkLamTypes spec_lam_args body_ty) - -- See Note [Transfer strictness] - `setIdStrictness` spec_str - `setIdArity` count isId spec_lam_args - `asJoinId_maybe` spec_join_arity - spec_str = calcSpecStrictness fn spec_lam_args pats - - - -- Conditionally use result of new worker-wrapper transform - spec_rhs = mkLams spec_lam_args_str spec_body - body_ty = exprType spec_body - rule_rhs = mkVarApps (Var spec_id) spec_call_args - inline_act = idInlineActivation fn - this_mod = sc_module spec_env - rule = mkRule this_mod True {- Auto -} True {- Local -} - rule_name inline_act fn_name qvars pats rule_rhs - -- See Note [Transfer activation] - ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule - , os_id = spec_id - , os_rhs = spec_rhs }) } - - --- See Note [Strictness information in worker binders] -handOutStrictnessInformation :: [Demand] -> [Var] -> [Var] -handOutStrictnessInformation = go - where - go _ [] = [] - go [] vs = vs - go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs - go dmds (v:vs) = v : go dmds vs - -calcSpecStrictness :: Id -- The original function - -> [Var] -> [CoreExpr] -- Call pattern - -> StrictSig -- Strictness of specialised thing --- See Note [Transfer strictness] -calcSpecStrictness fn qvars pats - = mkClosedStrictSig spec_dmds topRes - where - spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] - StrictSig (DmdType _ dmds _) = idStrictness fn - - dmd_env = go emptyVarEnv dmds pats - - go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv - go env ds (Type {} : pats) = go env ds pats - go env ds (Coercion {} : pats) = go env ds pats - go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats - go env _ _ = env - - go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv - go_one env d (Var v) = extendVarEnv_C bothDmd env v d - go_one env d e - | Just ds <- splitProdDmd_maybe d -- NB: d does not have to be strict - , (Var _, args) <- collectArgs e = go env ds args - go_one env _ _ = env - -{- -Note [spec_usg includes rhs_usg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In calls to 'specialise', the returned ScUsage must include the rhs_usg in -the passed-in SpecInfo, unless there are no calls at all to the function. - -The caller can, indeed must, assume this. He should not combine in rhs_usg -himself, or he'll get rhs_usg twice -- and that can lead to an exponential -blowup of duplicates in the CallEnv. This is what gave rise to the massive -performace loss in Trac #8852. - -Note [Specialise original body] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RhsInfo for a binding keeps the *original* body of the binding. We -must specialise that, *not* the result of applying specExpr to the RHS -(which is also kept in RhsInfo). Otherwise we end up specialising a -specialised RHS, and that can lead directly to exponential behaviour. - -Note [Transfer activation] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - This note is for SpecConstr, but exactly the same thing - happens in the overloading specialiser; see - Note [Auto-specialisation and RULES] in Specialise. - -In which phase should the specialise-constructor rules be active? -Originally I made them always-active, but Manuel found that this -defeated some clever user-written rules. Then I made them active only -in Phase 0; after all, currently, the specConstr transformation is -only run after the simplifier has reached Phase 0, but that meant -that specialisations didn't fire inside wrappers; see test -simplCore/should_compile/spec-inline. - -So now I just use the inline-activation of the parent Id, as the -activation for the specialiation RULE, just like the main specialiser; - -This in turn means there is no point in specialising NOINLINE things, -so we test for that. - -Note [Transfer strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must transfer strictness information from the original function to -the specialised one. Suppose, for example - - f has strictness SS - and a RULE f (a:as) b = f_spec a as b - -Now we want f_spec to have strictness LLS, otherwise we'll use call-by-need -when calling f_spec instead of call-by-value. And that can result in -unbounded worsening in space (cf the classic foldl vs foldl') - -See Trac #3437 for a good example. - -The function calcSpecStrictness performs the calculation. - -Note [Strictness information in worker binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -After having calculated the strictness annotation for the worker (see Note -[Transfer strictness] above), we also want to have this information attached to -the worker’s arguments, for the benefit of later passes. The function -handOutStrictnessInformation decomposes the strictness annotation calculated by -calcSpecStrictness and attaches them to the variables. - -************************************************************************ -* * -\subsection{Argument analysis} -* * -************************************************************************ - -This code deals with analysing call-site arguments to see whether -they are constructor applications. - -Note [Free type variables of the qvar types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a call (f @a x True), that we want to specialise, what variables should -we quantify over. Clearly over 'a' and 'x', but what about any type variables -free in x's type? In fact we don't need to worry about them because (f @a) -can only be a well-typed application if its type is compatible with x, so any -variables free in x's type must be free in (f @a), and hence either be gathered -via 'a' itself, or be in scope at f's defn. Hence we just take - (exprsFreeVars pats). - -BUT phantom type synonyms can mess this reasoning up, - eg x::T b with type T b = Int -So we apply expandTypeSynonyms to the bound Ids. -See Trac # 5458. Yuk. - -Note [SpecConstr call patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "call patterns" that we collect is going to become the LHS of a RULE. -It's important that it doesn't have - e |> Refl -or - e |> g1 |> g2 -because both of these will be optimised by Simplify.simplRule. In the -former case such optimisation benign, because the rule will match more -terms; but in the latter we may lose a binding of 'g1' or 'g2', and -end up with a rule LHS that doesn't bind the template variables -(Trac #10602). - -The simplifier eliminates such things, but SpecConstr itself constructs -new terms by substituting. So the 'mkCast' in the Cast case of scExpr -is very important! - -Note [Choosing patterns] -~~~~~~~~~~~~~~~~~~~~~~~~ -If we get lots of patterns we may not want to make a specialisation -for each of them (code bloat), so we choose as follows, implemented -by trim_pats. - -* The flag -fspec-constr-count-N sets the sc_count field - of the ScEnv to (Just n). This limits the total number - of specialisations for a given function to N. - -* -fno-spec-constr-count sets the sc_count field to Nothing, - which switches of the limit. - -* The ghastly ForceSpecConstr trick also switches of the limit - for a particular function - -* Otherwise we sort the patterns to choose the most general - ones first; more general => more widely applicable. --} - -type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments - -- See Note [SpecConstr call patterns] - -callsToNewPats :: ScEnv -> Id - -> SpecInfo - -> [ArgOcc] -> [Call] - -> UniqSM (Bool, [CallPat]) - -- Result has no duplicate patterns, - -- nor ones mentioned in done_pats - -- Bool indicates that there was at least one boring pattern -callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls - = do { mb_pats <- mapM (callToPats env bndr_occs) calls - - ; let have_boring_call = any isNothing mb_pats - - good_pats :: [CallPat] - good_pats = catMaybes mb_pats - - -- Remove patterns we have already done - new_pats = filterOut is_done good_pats - is_done p = any (samePat p . os_pat) done_specs - - -- Remove duplicates - non_dups = nubBy samePat new_pats - - -- Remove ones that have too many worker variables - small_pats = filterOut too_big non_dups - too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars) - -- We are about to construct w/w pair in 'spec_one'. - -- Omit specialisation leading to high arity workers. - -- See Note [Limit w/w arity] in WwLib - - -- Discard specialisations if there are too many of them - trimmed_pats = trim_pats env fn spec_info small_pats - --- ; pprTrace "callsToPats" (vcat [ text "calls:" <+> ppr calls --- , text "good_pats:" <+> ppr good_pats ]) $ --- return () - - ; return (have_boring_call, trimmed_pats) } - - -trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat] --- See Note [Choosing patterns] -trim_pats env fn (SI { si_n_specs = done_spec_count }) pats - | sc_force env - || isNothing mb_scc - || n_remaining >= n_pats - = pats -- No need to trim - - | otherwise - = emit_trace $ -- Need to trim, so keep the best ones - take n_remaining sorted_pats - - where - n_pats = length pats - spec_count' = n_pats + done_spec_count - n_remaining = max_specs - done_spec_count - mb_scc = sc_count env - Just max_specs = mb_scc - - sorted_pats = map fst $ - sortBy (comparing snd) $ - [(pat, pat_cons pat) | pat <- pats] - -- Sort in order of increasing number of constructors - -- (i.e. decreasing generality) and pick the initial - -- segment of this list - - pat_cons :: CallPat -> Int - -- How many data consturorst of literals are in - -- the patten. More data-cons => less general - pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps - where - q_set = mkVarSet qs - n_cons (Var v) | v `elemVarSet` q_set = 0 - | otherwise = 1 - n_cons (Cast e _) = n_cons e - n_cons (App e1 e2) = n_cons e1 + n_cons e2 - n_cons (Lit {}) = 1 - n_cons _ = 0 - - emit_trace result - | debugIsOn || hasPprDebug (sc_dflags env) - -- Suppress this scary message for ordinary users! Trac #5125 - = pprTrace "SpecConstr" msg result - | otherwise - = result - msg = vcat [ sep [ text "Function" <+> quotes (ppr fn) - , nest 2 (text "has" <+> - speakNOf spec_count' (text "call pattern") <> comma <+> - text "but the limit is" <+> int max_specs) ] - , text "Use -fspec-constr-count=n to set the bound" - , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ] - - -callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) - -- The [Var] is the variables to quantify over in the rule - -- Type variables come first, since they may scope - -- over the following term variables - -- The [CoreExpr] are the argument patterns for the rule -callToPats env bndr_occs (Call _ args con_env) - | length args < length bndr_occs -- Check saturated - = return Nothing - | otherwise - = do { let in_scope = substInScope (sc_subst env) - ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs - ; let pat_fvs = exprsFreeVarsList pats - -- To get determinism we need the list of free variables in - -- deterministic order. Otherwise we end up creating - -- lambdas with different argument orders. See - -- determinism/simplCore/should_compile/spec-inline-determ.hs - -- for an example. For explanation of determinism - -- considerations See Note [Unique Determinism] in Unique. - in_scope_vars = getInScopeVars in_scope - qvars = filterOut (`elemVarSet` in_scope_vars) pat_fvs - -- Quantify over variables that are not in scope - -- at the call site - -- See Note [Free type variables of the qvar types] - -- See Note [Shadowing] at the top - - (ktvs, ids) = partition isTyVar qvars - qvars' = toposortTyVars ktvs ++ map sanitise ids - -- Order into kind variables, type variables, term variables - -- The kind of a type variable may mention a kind variable - -- and the type of a term variable may mention a type variable - - sanitise id = id `setIdType` expandTypeSynonyms (idType id) - -- See Note [Free type variables of the qvar types] - - ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $ - if interesting - then return (Just (qvars', pats)) - else return Nothing } - - -- argToPat takes an actual argument, and returns an abstracted - -- version, consisting of just the "constructor skeleton" of the - -- argument, with non-constructor sub-expression replaced by new - -- placeholder variables. For example: - -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) - -argToPat :: ScEnv - -> InScopeSet -- What's in scope at the fn defn site - -> ValueEnv -- ValueEnv at the call site - -> CoreArg -- A call arg (or component thereof) - -> ArgOcc - -> UniqSM (Bool, CoreArg) - --- Returns (interesting, pat), --- where pat is the pattern derived from the argument --- interesting=True if the pattern is non-trivial (not a variable or type) --- E.g. x:xs --> (True, x:xs) --- f xs --> (False, w) where w is a fresh wildcard --- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard --- \x. x+y --> (True, \x. x+y) --- lvl7 --> (True, lvl7) if lvl7 is bound --- somewhere further out - -argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ - = return (False, arg) - -argToPat env in_scope val_env (Tick _ arg) arg_occ - = argToPat env in_scope val_env arg arg_occ - -- Note [Notes in call patterns] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Ignore Notes. In particular, we want to ignore any InlineMe notes - -- Perhaps we should not ignore profiling notes, but I'm going to - -- ride roughshod over them all for now. - --- See Note [Notes in RULE matching] in Rules - -argToPat env in_scope val_env (Let _ arg) arg_occ - = argToPat env in_scope val_env arg arg_occ - -- See Note [Matching lets] in Rule.hs - -- Look through let expressions - -- e.g. f (let v = rhs in (v,w)) - -- Here we can specialise for f (v,w) - -- because the rule-matcher will look through the let. - -{- Disabled; see Note [Matching cases] in Rule.hs -argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ - | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs - = argToPat env in_scope val_env rhs arg_occ --} - -argToPat env in_scope val_env (Cast arg co) arg_occ - | not (ignoreType env ty2) - = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ - ; if not interesting then - wildCardPat ty2 - else do - { -- Make a wild-card pattern for the coercion - uniq <- getUniqueM - ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) - ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } - where - Pair ty1 ty2 = coercionKind co - - - -{- Disabling lambda specialisation for now - It's fragile, and the spec_loop can be infinite -argToPat in_scope val_env arg arg_occ - | is_value_lam arg - = return (True, arg) - where - is_value_lam (Lam v e) -- Spot a value lambda, even if - | isId v = True -- it is inside a type lambda - | otherwise = is_value_lam e - is_value_lam other = False --} - - -- Check for a constructor application - -- NB: this *precedes* the Var case, so that we catch nullary constrs -argToPat env in_scope val_env arg arg_occ - | Just (ConVal (DataAlt dc) args) <- isValue val_env arg - , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] - , Just arg_occs <- mb_scrut dc - = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args - ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs - ; return (True, - mkConApp dc (ty_args ++ args')) } - where - mb_scrut dc = case arg_occ of - ScrutOcc bs | Just occs <- lookupUFM bs dc - -> Just (occs) -- See Note [Reboxing] - _other | sc_force env || sc_keen env - -> Just (repeat UnkOcc) - | otherwise - -> Nothing - - -- Check if the argument is a variable that - -- (a) is used in an interesting way in the function body - -- (b) we know what its value is - -- In that case it counts as "interesting" -argToPat env in_scope val_env (Var v) arg_occ - | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) - is_value, -- (b) - -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing] - -- So sc_keen focused just on f (I# x), where we have freshly-allocated - -- box that we can eliminate in the caller - not (ignoreType env (varType v)) - = return (True, Var v) - where - is_value - | isLocalId v = v `elemInScopeSet` in_scope - && isJust (lookupVarEnv val_env v) - -- Local variables have values in val_env - | otherwise = isValueUnfolding (idUnfolding v) - -- Imports have unfoldings - --- I'm really not sure what this comment means --- And by not wild-carding we tend to get forall'd --- variables that are in scope, which in turn can --- expose the weakness in let-matching --- See Note [Matching lets] in Rules - - -- Check for a variable bound inside the function. - -- Don't make a wild-card, because we may usefully share - -- e.g. f a = let x = ... in f (x,x) - -- NB: this case follows the lambda and con-app cases!! --- argToPat _in_scope _val_env (Var v) _arg_occ --- = return (False, Var v) - -- SLPJ : disabling this to avoid proliferation of versions - -- also works badly when thinking about seeding the loop - -- from the body of the let - -- f x y = letrec g z = ... in g (x,y) - -- We don't want to specialise for that *particular* x,y - - -- The default case: make a wild-card - -- We use this for coercions too -argToPat _env _in_scope _val_env arg _arg_occ - = wildCardPat (exprType arg) - -wildCardPat :: Type -> UniqSM (Bool, CoreArg) -wildCardPat ty - = do { uniq <- getUniqueM - ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty - ; return (False, varToCoreExpr id) } - -argsToPats :: ScEnv -> InScopeSet -> ValueEnv - -> [CoreArg] -> [ArgOcc] -- Should be same length - -> UniqSM (Bool, [CoreArg]) -argsToPats env in_scope val_env args occs - = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs - ; let (interesting_s, args') = unzip stuff - ; return (or interesting_s, args') } - -isValue :: ValueEnv -> CoreExpr -> Maybe Value -isValue _env (Lit lit) - | litIsLifted lit = Nothing - | otherwise = Just (ConVal (LitAlt lit) []) - -isValue env (Var v) - | Just cval <- lookupVarEnv env v - = Just cval -- You might think we could look in the idUnfolding here - -- but that doesn't take account of which branch of a - -- case we are in, which is the whole point - - | not (isLocalId v) && isCheapUnfolding unf - = isValue env (unfoldingTemplate unf) - where - unf = idUnfolding v - -- However we do want to consult the unfolding - -- as well, for let-bound constructors! - -isValue env (Lam b e) - | isTyVar b = case isValue env e of - Just _ -> Just LambdaVal - Nothing -> Nothing - | otherwise = Just LambdaVal - -isValue env (Tick t e) - | not (tickishIsCode t) - = isValue env e - -isValue _env expr -- Maybe it's a constructor application - | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr - = case isDataConWorkId_maybe fun of - - Just con | args `lengthAtLeast` dataConRepArity con - -- Check saturated; might be > because the - -- arity excludes type args - -> Just (ConVal (DataAlt con) args) - - _other | valArgCount args < idArity fun - -- Under-applied function - -> Just LambdaVal -- Partial application - - _other -> Nothing - -isValue _env _expr = Nothing - -valueIsWorkFree :: Value -> Bool -valueIsWorkFree LambdaVal = True -valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args - -samePat :: CallPat -> CallPat -> Bool -samePat (vs1, as1) (vs2, as2) - = all2 same as1 as2 - where - same (Var v1) (Var v2) - | v1 `elem` vs1 = v2 `elem` vs2 - | v2 `elem` vs2 = False - | otherwise = v1 == v2 - - same (Lit l1) (Lit l2) = l1==l2 - same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 - - same (Type {}) (Type {}) = True -- Note [Ignore type differences] - same (Coercion {}) (Coercion {}) = True - same (Tick _ e1) e2 = same e1 e2 -- Ignore casts and notes - same (Cast e1 _) e2 = same e1 e2 - same e1 (Tick _ e2) = same e1 e2 - same e1 (Cast e2 _) = same e1 e2 - - same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) - False -- Let, lambda, case should not occur - bad (Case {}) = True - bad (Let {}) = True - bad (Lam {}) = True - bad _other = False - -{- -Note [Ignore type differences] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to generate specialisations where the call patterns -differ only in their type arguments! Not only is it utterly useless, -but it also means that (with polymorphic recursion) we can generate -an infinite number of specialisations. Example is Data.Sequence.adjustTree, -I think. --} diff --git a/specialise/Specialise.hs b/specialise/Specialise.hs deleted file mode 100644 --- a/specialise/Specialise.hs +++ /dev/null @@ -1,2456 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[Specialise]{Stamping out overloading, and (optionally) polymorphism} --} - -{-# LANGUAGE CPP #-} -module Specialise ( specProgram, specUnfolding ) where - -#include "HsVersions.h" - -import Id -import TcType hiding( substTy ) -import Type hiding( substTy, extendTvSubstList ) -import Module( Module, HasModule(..) ) -import Coercion( Coercion ) -import CoreMonad -import qualified CoreSubst -import CoreUnfold -import Var ( isLocalVar ) -import VarSet -import VarEnv -import CoreSyn -import Rules -import CoreOpt ( collectBindersPushingCo ) -import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkCast ) -import CoreFVs -import FV ( InterestingVarFun ) -import CoreArity ( etaExpandToJoinPointRule ) -import UniqSupply -import Name -import MkId ( voidArgId, voidPrimId ) -import Maybes ( catMaybes, isJust ) -import MonadUtils ( foldlM ) -import BasicTypes -import HscTypes -import Bag -import DynFlags -import Util -import Outputable -import FastString -import State -import UniqDFM - -import Control.Monad -#if __GLASGOW_HASKELL__ > 710 -import qualified Control.Monad.Fail as MonadFail -#endif - -{- -************************************************************************ -* * -\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} -* * -************************************************************************ - -These notes describe how we implement specialisation to eliminate -overloading. - -The specialisation pass works on Core -syntax, complete with all the explicit dictionary application, -abstraction and construction as added by the type checker. The -existing type checker remains largely as it is. - -One important thought: the {\em types} passed to an overloaded -function, and the {\em dictionaries} passed are mutually redundant. -If the same function is applied to the same type(s) then it is sure to -be applied to the same dictionary(s)---or rather to the same {\em -values}. (The arguments might look different but they will evaluate -to the same value.) - -Second important thought: we know that we can make progress by -treating dictionary arguments as static and worth specialising on. So -we can do without binding-time analysis, and instead specialise on -dictionary arguments and no others. - -The basic idea -~~~~~~~~~~~~~~ -Suppose we have - - let f = - in - -and suppose f is overloaded. - -STEP 1: CALL-INSTANCE COLLECTION - -We traverse , accumulating all applications of f to types and -dictionaries. - -(Might there be partial applications, to just some of its types and -dictionaries? In principle yes, but in practice the type checker only -builds applications of f to all its types and dictionaries, so partial -applications could only arise as a result of transformation, and even -then I think it's unlikely. In any case, we simply don't accumulate such -partial applications.) - - -STEP 2: EQUIVALENCES - -So now we have a collection of calls to f: - f t1 t2 d1 d2 - f t3 t4 d3 d4 - ... -Notice that f may take several type arguments. To avoid ambiguity, we -say that f is called at type t1/t2 and t3/t4. - -We take equivalence classes using equality of the *types* (ignoring -the dictionary args, which as mentioned previously are redundant). - -STEP 3: SPECIALISATION - -For each equivalence class, choose a representative (f t1 t2 d1 d2), -and create a local instance of f, defined thus: - - f@t1/t2 = t1 t2 d1 d2 - -f_rhs presumably has some big lambdas and dictionary lambdas, so lots -of simplification will now result. However we don't actually *do* that -simplification. Rather, we leave it for the simplifier to do. If we -*did* do it, though, we'd get more call instances from the specialised -RHS. We can work out what they are by instantiating the call-instance -set from f's RHS with the types t1, t2. - -Add this new id to f's IdInfo, to record that f has a specialised version. - -Before doing any of this, check that f's IdInfo doesn't already -tell us about an existing instance of f at the required type/s. -(This might happen if specialisation was applied more than once, or -it might arise from user SPECIALIZE pragmas.) - -Recursion -~~~~~~~~~ -Wait a minute! What if f is recursive? Then we can't just plug in -its right-hand side, can we? - -But it's ok. The type checker *always* creates non-recursive definitions -for overloaded recursive functions. For example: - - f x = f (x+x) -- Yes I know its silly - -becomes - - f a (d::Num a) = let p = +.sel a d - in - letrec fl (y::a) = fl (p y y) - in - fl - -We still have recusion for non-overloaded functions which we -specialise, but the recursive call should get specialised to the -same recursive version. - - -Polymorphism 1 -~~~~~~~~~~~~~~ - -All this is crystal clear when the function is applied to *constant -types*; that is, types which have no type variables inside. But what if -it is applied to non-constant types? Suppose we find a call of f at type -t1/t2. There are two possibilities: - -(a) The free type variables of t1, t2 are in scope at the definition point -of f. In this case there's no problem, we proceed just as before. A common -example is as follows. Here's the Haskell: - - g y = let f x = x+x - in f y + f y - -After typechecking we have - - g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x - in +.sel a d (f a d y) (f a d y) - -Notice that the call to f is at type type "a"; a non-constant type. -Both calls to f are at the same type, so we can specialise to give: - - g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x - in +.sel a d (f@a y) (f@a y) - - -(b) The other case is when the type variables in the instance types -are *not* in scope at the definition point of f. The example we are -working with above is a good case. There are two instances of (+.sel a d), -but "a" is not in scope at the definition of +.sel. Can we do anything? -Yes, we can "common them up", a sort of limited common sub-expression deal. -This would give: - - g a (d::Num a) (y::a) = let +.sel@a = +.sel a d - f@a (x::a) = +.sel@a x x - in +.sel@a (f@a y) (f@a y) - -This can save work, and can't be spotted by the type checker, because -the two instances of +.sel weren't originally at the same type. - -Further notes on (b) - -* There are quite a few variations here. For example, the defn of - +.sel could be floated ouside the \y, to attempt to gain laziness. - It certainly mustn't be floated outside the \d because the d has to - be in scope too. - -* We don't want to inline f_rhs in this case, because -that will duplicate code. Just commoning up the call is the point. - -* Nothing gets added to +.sel's IdInfo. - -* Don't bother unless the equivalence class has more than one item! - -Not clear whether this is all worth it. It is of course OK to -simply discard call-instances when passing a big lambda. - -Polymorphism 2 -- Overloading -~~~~~~~~~~~~~~ -Consider a function whose most general type is - - f :: forall a b. Ord a => [a] -> b -> b - -There is really no point in making a version of g at Int/Int and another -at Int/Bool, because it's only instantiating the type variable "a" which -buys us any efficiency. Since g is completely polymorphic in b there -ain't much point in making separate versions of g for the different -b types. - -That suggests that we should identify which of g's type variables -are constrained (like "a") and which are unconstrained (like "b"). -Then when taking equivalence classes in STEP 2, we ignore the type args -corresponding to unconstrained type variable. In STEP 3 we make -polymorphic versions. Thus: - - f@t1/ = /\b -> t1 b d1 d2 - -We do this. - - -Dictionary floating -~~~~~~~~~~~~~~~~~~~ -Consider this - - f a (d::Num a) = let g = ... - in - ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... - -Here, g is only called at one type, but the dictionary isn't in scope at the -definition point for g. Usually the type checker would build a -definition for d1 which enclosed g, but the transformation system -might have moved d1's defn inward. Solution: float dictionary bindings -outwards along with call instances. - -Consider - - f x = let g p q = p==q - h r s = (r+s, g r s) - in - h x x - - -Before specialisation, leaving out type abstractions we have - - f df x = let g :: Eq a => a -> a -> Bool - g dg p q = == dg p q - h :: Num a => a -> a -> (a, Bool) - h dh r s = let deq = eqFromNum dh - in (+ dh r s, g deq r s) - in - h df x x - -After specialising h we get a specialised version of h, like this: - - h' r s = let deq = eqFromNum df - in (+ df r s, g deq r s) - -But we can't naively make an instance for g from this, because deq is not in scope -at the defn of g. Instead, we have to float out the (new) defn of deq -to widen its scope. Notice that this floating can't be done in advance -- it only -shows up when specialisation is done. - -User SPECIALIZE pragmas -~~~~~~~~~~~~~~~~~~~~~~~ -Specialisation pragmas can be digested by the type checker, and implemented -by adding extra definitions along with that of f, in the same way as before - - f@t1/t2 = t1 t2 d1 d2 - -Indeed the pragmas *have* to be dealt with by the type checker, because -only it knows how to build the dictionaries d1 and d2! For example - - g :: Ord a => [a] -> [a] - {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} - -Here, the specialised version of g is an application of g's rhs to the -Ord dictionary for (Tree Int), which only the type checker can conjure -up. There might not even *be* one, if (Tree Int) is not an instance of -Ord! (All the other specialision has suitable dictionaries to hand -from actual calls.) - -Problem. The type checker doesn't have to hand a convenient , because -it is buried in a complex (as-yet-un-desugared) binding group. -Maybe we should say - - f@t1/t2 = f* t1 t2 d1 d2 - -where f* is the Id f with an IdInfo which says "inline me regardless!". -Indeed all the specialisation could be done in this way. -That in turn means that the simplifier has to be prepared to inline absolutely -any in-scope let-bound thing. - - -Again, the pragma should permit polymorphism in unconstrained variables: - - h :: Ord a => [a] -> b -> b - {-# SPECIALIZE h :: [Int] -> b -> b #-} - -We *insist* that all overloaded type variables are specialised to ground types, -(and hence there can be no context inside a SPECIALIZE pragma). -We *permit* unconstrained type variables to be specialised to - - a ground type - - or left as a polymorphic type variable -but nothing in between. So - - {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} - -is *illegal*. (It can be handled, but it adds complication, and gains the -programmer nothing.) - - -SPECIALISING INSTANCE DECLARATIONS -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - instance Foo a => Foo [a] where - ... - {-# SPECIALIZE instance Foo [Int] #-} - -The original instance decl creates a dictionary-function -definition: - - dfun.Foo.List :: forall a. Foo a -> Foo [a] - -The SPECIALIZE pragma just makes a specialised copy, just as for -ordinary function definitions: - - dfun.Foo.List@Int :: Foo [Int] - dfun.Foo.List@Int = dfun.Foo.List Int dFooInt - -The information about what instance of the dfun exist gets added to -the dfun's IdInfo in the same way as a user-defined function too. - - -Automatic instance decl specialisation? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Can instance decls be specialised automatically? It's tricky. -We could collect call-instance information for each dfun, but -then when we specialised their bodies we'd get new call-instances -for ordinary functions; and when we specialised their bodies, we might get -new call-instances of the dfuns, and so on. This all arises because of -the unrestricted mutual recursion between instance decls and value decls. - -Still, there's no actual problem; it just means that we may not do all -the specialisation we could theoretically do. - -Furthermore, instance decls are usually exported and used non-locally, -so we'll want to compile enough to get those specialisations done. - -Lastly, there's no such thing as a local instance decl, so we can -survive solely by spitting out *usage* information, and then reading that -back in as a pragma when next compiling the file. So for now, -we only specialise instance decls in response to pragmas. - - -SPITTING OUT USAGE INFORMATION -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To spit out usage information we need to traverse the code collecting -call-instance information for all imported (non-prelude?) functions -and data types. Then we equivalence-class it and spit it out. - -This is done at the top-level when all the call instances which escape -must be for imported functions and data types. - -*** Not currently done *** - - -Partial specialisation by pragmas -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What about partial specialisation: - - k :: (Ord a, Eq b) => [a] -> b -> b -> [a] - {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} - -or even - - {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} - -Seems quite reasonable. Similar things could be done with instance decls: - - instance (Foo a, Foo b) => Foo (a,b) where - ... - {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} - {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} - -Ho hum. Things are complex enough without this. I pass. - - -Requirements for the simplifier -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The simplifier has to be able to take advantage of the specialisation. - -* When the simplifier finds an application of a polymorphic f, it looks in -f's IdInfo in case there is a suitable instance to call instead. This converts - - f t1 t2 d1 d2 ===> f_t1_t2 - -Note that the dictionaries get eaten up too! - -* Dictionary selection operations on constant dictionaries must be - short-circuited: - - +.sel Int d ===> +Int - -The obvious way to do this is in the same way as other specialised -calls: +.sel has inside it some IdInfo which tells that if it's applied -to the type Int then it should eat a dictionary and transform to +Int. - -In short, dictionary selectors need IdInfo inside them for constant -methods. - -* Exactly the same applies if a superclass dictionary is being - extracted: - - Eq.sel Int d ===> dEqInt - -* Something similar applies to dictionary construction too. Suppose -dfun.Eq.List is the function taking a dictionary for (Eq a) to -one for (Eq [a]). Then we want - - dfun.Eq.List Int d ===> dEq.List_Int - -Where does the Eq [Int] dictionary come from? It is built in -response to a SPECIALIZE pragma on the Eq [a] instance decl. - -In short, dfun Ids need IdInfo with a specialisation for each -constant instance of their instance declaration. - -All this uses a single mechanism: the SpecEnv inside an Id - - -What does the specialisation IdInfo look like? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The SpecEnv of an Id maps a list of types (the template) to an expression - - [Type] |-> Expr - -For example, if f has this RuleInfo: - - [Int, a] -> \d:Ord Int. f' a - -it means that we can replace the call - - f Int t ===> (\d. f' t) - -This chucks one dictionary away and proceeds with the -specialised version of f, namely f'. - - -What can't be done this way? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is no way, post-typechecker, to get a dictionary for (say) -Eq a from a dictionary for Eq [a]. So if we find - - ==.sel [t] d - -we can't transform to - - eqList (==.sel t d') - -where - eqList :: (a->a->Bool) -> [a] -> [a] -> Bool - -Of course, we currently have no way to automatically derive -eqList, nor to connect it to the Eq [a] instance decl, but you -can imagine that it might somehow be possible. Taking advantage -of this is permanently ruled out. - -Still, this is no great hardship, because we intend to eliminate -overloading altogether anyway! - -A note about non-tyvar dictionaries -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some Ids have types like - - forall a,b,c. Eq a -> Ord [a] -> tau - -This seems curious at first, because we usually only have dictionary -args whose types are of the form (C a) where a is a type variable. -But this doesn't hold for the functions arising from instance decls, -which sometimes get arguments with types of form (C (T a)) for some -type constructor T. - -Should we specialise wrt this compound-type dictionary? We used to say -"no", saying: - "This is a heuristic judgement, as indeed is the fact that we - specialise wrt only dictionaries. We choose *not* to specialise - wrt compound dictionaries because at the moment the only place - they show up is in instance decls, where they are simply plugged - into a returned dictionary. So nothing is gained by specialising - wrt them." - -But it is simpler and more uniform to specialise wrt these dicts too; -and in future GHC is likely to support full fledged type signatures -like - f :: Eq [(a,b)] => ... - - -************************************************************************ -* * -\subsubsection{The new specialiser} -* * -************************************************************************ - -Our basic game plan is this. For let(rec) bound function - f :: (C a, D c) => (a,b,c,d) -> Bool - -* Find any specialised calls of f, (f ts ds), where - ts are the type arguments t1 .. t4, and - ds are the dictionary arguments d1 .. d2. - -* Add a new definition for f1 (say): - - f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 - - Note that we abstract over the unconstrained type arguments. - -* Add the mapping - - [t1,b,t3,d] |-> \d1 d2 -> f1 b d - - to the specialisations of f. This will be used by the - simplifier to replace calls - (f t1 t2 t3 t4) da db - by - (\d1 d1 -> f1 t2 t4) da db - - All the stuff about how many dictionaries to discard, and what types - to apply the specialised function to, are handled by the fact that the - SpecEnv contains a template for the result of the specialisation. - -We don't build *partial* specialisations for f. For example: - - f :: Eq a => a -> a -> Bool - {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-} - -Here, little is gained by making a specialised copy of f. -There's a distinct danger that the specialised version would -first build a dictionary for (Eq b, Eq c), and then select the (==) -method from it! Even if it didn't, not a great deal is saved. - -We do, however, generate polymorphic, but not overloaded, specialisations: - - f :: Eq a => [a] -> b -> b -> b - ... SPECIALISE f :: [Int] -> b -> b -> b ... - -Hence, the invariant is this: - - *** no specialised version is overloaded *** - - -************************************************************************ -* * -\subsubsection{The exported function} -* * -************************************************************************ --} - --- | Specialise calls to type-class overloaded functions occuring in a program. -specProgram :: ModGuts -> CoreM ModGuts -specProgram guts@(ModGuts { mg_module = this_mod - , mg_rules = local_rules - , mg_binds = binds }) - = do { dflags <- getDynFlags - - -- Specialise the bindings of this module - ; (binds', uds) <- runSpecM dflags this_mod (go binds) - - -- Specialise imported functions - ; hpt_rules <- getRuleBase - ; let rule_base = extendRuleBaseList hpt_rules local_rules - ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet - [] rule_base uds - - ; let final_binds - | null spec_binds = binds' - | otherwise = Rec (flattenBinds spec_binds) : binds' - -- Note [Glom the bindings if imported functions are specialised] - - ; return (guts { mg_binds = final_binds - , mg_rules = new_rules ++ local_rules }) } - where - -- We need to start with a Subst that knows all the things - -- that are in scope, so that the substitution engine doesn't - -- accidentally re-use a unique that's already in use - -- Easiest thing is to do it all at once, as if all the top-level - -- decls were mutually recursive - top_env = SE { se_subst = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $ - bindersOfBinds binds - , se_interesting = emptyVarSet } - - go [] = return ([], emptyUDs) - go (bind:binds) = do (binds', uds) <- go binds - (bind', uds') <- specBind top_env bind uds - return (bind' ++ binds', uds') - -{- -Note [Wrap bindings returned by specImports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'specImports' returns a set of specialized bindings. However, these are lacking -necessary floated dictionary bindings, which are returned by -UsageDetails(ud_binds). These dictionaries need to be brought into scope with -'wrapDictBinds' before the bindings returned by 'specImports' can be used. See, -for instance, the 'specImports' call in 'specProgram'. - - -Note [Disabling cross-module specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since GHC 7.10 we have performed specialisation of INLINABLE bindings living -in modules outside of the current module. This can sometimes uncover user code -which explodes in size when aggressively optimized. The --fno-cross-module-specialise option was introduced to allow users to being -bitten by such instances to revert to the pre-7.10 behavior. - -See Trac #10491 --} - --- | Specialise a set of calls to imported bindings -specImports :: DynFlags - -> Module - -> SpecEnv -- Passed in so that all top-level Ids are in scope - -> VarSet -- Don't specialise these ones - -- See Note [Avoiding recursive specialisation] - -> [Id] -- Stack of imported functions being specialised - -> RuleBase -- Rules from this module and the home package - -- (but not external packages, which can change) - -> UsageDetails -- Calls for imported things, and floating bindings - -> CoreM ( [CoreRule] -- New rules - , [CoreBind] ) -- Specialised bindings - -- See Note [Wrapping bindings returned by specImports] -specImports dflags this_mod top_env done callers rule_base - (MkUD { ud_binds = dict_binds, ud_calls = calls }) - -- See Note [Disabling cross-module specialisation] - | not $ gopt Opt_CrossModuleSpecialise dflags - = return ([], []) - - | otherwise - = do { let import_calls = dVarEnvElts calls - ; (rules, spec_binds) <- go rule_base import_calls - - -- Don't forget to wrap the specialized bindings with - -- bindings for the needed dictionaries. - -- See Note [Wrap bindings returned by specImports] - ; let spec_binds' = wrapDictBinds dict_binds spec_binds - - ; return (rules, spec_binds') } - where - go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind]) - go _ [] = return ([], []) - go rb (cis@(CIS fn _) : other_calls) - = do { let ok_calls = filterCalls cis dict_binds - -- Drop calls that (directly or indirectly) refer to fn - -- See Note [Avoiding loops] --- ; debugTraceMsg (text "specImport" <+> vcat [ ppr fn --- , text "calls" <+> ppr cis --- , text "ud_binds =" <+> ppr dict_binds --- , text "dump set =" <+> ppr dump_set --- , text "filtered calls =" <+> ppr ok_calls ]) - ; (rules1, spec_binds1) <- specImport dflags this_mod top_env - done callers rb fn ok_calls - - ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls - ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } - -specImport :: DynFlags - -> Module - -> SpecEnv -- Passed in so that all top-level Ids are in scope - -> VarSet -- Don't specialise these - -- See Note [Avoiding recursive specialisation] - -> [Id] -- Stack of imported functions being specialised - -> RuleBase -- Rules from this module - -> Id -> [CallInfo] -- Imported function and calls for it - -> CoreM ( [CoreRule] -- New rules - , [CoreBind] ) -- Specialised bindings -specImport dflags this_mod top_env done callers rb fn calls_for_fn - | fn `elemVarSet` done - = return ([], []) -- No warning. This actually happens all the time - -- when specialising a recursive function, because - -- the RHS of the specialised function contains a recursive - -- call to the original function - - | null calls_for_fn -- We filtered out all the calls in deleteCallsMentioning - = return ([], []) - - | wantSpecImport dflags unfolding - , Just rhs <- maybeUnfoldingTemplate unfolding - = do { -- Get rules from the external package state - -- We keep doing this in case we "page-fault in" - -- more rules as we go along - ; hsc_env <- getHscEnv - ; eps <- liftIO $ hscEPS hsc_env - ; vis_orphs <- getVisibleOrphanMods - ; let full_rb = unionRuleBase rb (eps_rule_base eps) - rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn - - ; (rules1, spec_pairs, uds) - <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $ - runSpecM dflags this_mod $ - specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs - ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] - -- After the rules kick in we may get recursion, but - -- we rely on a global GlomBinds to sort that out later - -- See Note [Glom the bindings if imported functions are specialised] - - -- Now specialise any cascaded calls - ; (rules2, spec_binds2) <- -- pprTrace "specImport 2" (ppr fn $$ ppr rules1 $$ ppr spec_binds1) $ - specImports dflags this_mod top_env - (extendVarSet done fn) - (fn:callers) - (extendRuleBaseList rb rules1) - uds - - ; let final_binds = spec_binds2 ++ spec_binds1 - - ; return (rules2 ++ rules1, final_binds) } - - | warnMissingSpecs dflags callers - = do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn)) - 2 (vcat [ text "when specialising" <+> quotes (ppr caller) - | caller <- callers]) - , ifPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) - , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) - ; return ([], []) } - - | otherwise - = return ([], []) - where - unfolding = realIdUnfolding fn -- We want to see the unfolding even for loop breakers - -warnMissingSpecs :: DynFlags -> [Id] -> Bool --- See Note [Warning about missed specialisations] -warnMissingSpecs dflags callers - | wopt Opt_WarnAllMissedSpecs dflags = True - | not (wopt Opt_WarnMissedSpecs dflags) = False - | null callers = False - | otherwise = all has_inline_prag callers - where - has_inline_prag id = isAnyInlinePragma (idInlinePragma id) - -wantSpecImport :: DynFlags -> Unfolding -> Bool --- See Note [Specialise imported INLINABLE things] -wantSpecImport dflags unf - = case unf of - NoUnfolding -> False - BootUnfolding -> False - OtherCon {} -> False - DFunUnfolding {} -> True - CoreUnfolding { uf_src = src, uf_guidance = _guidance } - | gopt Opt_SpecialiseAggressively dflags -> True - | isStableSource src -> True - -- Specialise even INLINE things; it hasn't inlined yet, - -- so perhaps it never will. Moreover it may have calls - -- inside it that we want to specialise - | otherwise -> False -- Stable, not INLINE, hence INLINABLE - -{- Note [Warning about missed specialisations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose - * In module Lib, you carefully mark a function 'foo' INLINABLE - * Import Lib(foo) into another module M - * Call 'foo' at some specialised type in M -Then you jolly well expect it to be specialised in M. But what if -'foo' calls another function 'Lib.bar'. Then you'd like 'bar' to be -specialised too. But if 'bar' is not marked INLINABLE it may well -not be specialised. The warning Opt_WarnMissedSpecs warns about this. - -It's more noisy to warning about a missed specialisation opportunity -for /every/ overloaded imported function, but sometimes useful. That -is what Opt_WarnAllMissedSpecs does. - -ToDo: warn about missed opportunities for local functions. - -Note [Specialise imported INLINABLE things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What imported functions do we specialise? The basic set is - * DFuns and things with INLINABLE pragmas. -but with -fspecialise-aggressively we add - * Anything with an unfolding template - -Trac #8874 has a good example of why we want to auto-specialise DFuns. - -We have the -fspecialise-aggressively flag (usually off), because we -risk lots of orphan modules from over-vigorous specialisation. -However it's not a big deal: anything non-recursive with an -unfolding-template will probably have been inlined already. - -Note [Glom the bindings if imported functions are specialised] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an imported, *recursive*, INLINABLE function - f :: Eq a => a -> a - f = /\a \d x. ...(f a d)... -In the module being compiled we have - g x = f (x::Int) -Now we'll make a specialised function - f_spec :: Int -> Int - f_spec = \x -> ...(f Int dInt)... - {-# RULE f Int _ = f_spec #-} - g = \x. f Int dInt x -Note that f_spec doesn't look recursive -After rewriting with the RULE, we get - f_spec = \x -> ...(f_spec)... -BUT since f_spec was non-recursive before it'll *stay* non-recursive. -The occurrence analyser never turns a NonRec into a Rec. So we must -make sure that f_spec is recursive. Easiest thing is to make all -the specialisations for imported bindings recursive. - - -Note [Avoiding recursive specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we specialise 'f' we may find new overloaded calls to 'g', 'h' in -'f's RHS. So we want to specialise g,h. But we don't want to -specialise f any more! It's possible that f's RHS might have a -recursive yet-more-specialised call, so we'd diverge in that case. -And if the call is to the same type, one specialisation is enough. -Avoiding this recursive specialisation loop is the reason for the -'done' VarSet passed to specImports and specImport. - -************************************************************************ -* * -\subsubsection{@specExpr@: the main function} -* * -************************************************************************ --} - -data SpecEnv - = SE { se_subst :: CoreSubst.Subst - -- We carry a substitution down: - -- a) we must clone any binding that might float outwards, - -- to avoid name clashes - -- b) we carry a type substitution to use when analysing - -- the RHS of specialised bindings (no type-let!) - - - , se_interesting :: VarSet - -- Dict Ids that we know something about - -- and hence may be worth specialising against - -- See Note [Interesting dictionary arguments] - } - -specVar :: SpecEnv -> Id -> CoreExpr -specVar env v = CoreSubst.lookupIdSubst (text "specVar") (se_subst env) v - -specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) - ----------------- First the easy cases -------------------- -specExpr env (Type ty) = return (Type (substTy env ty), emptyUDs) -specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs) -specExpr env (Var v) = return (specVar env v, emptyUDs) -specExpr _ (Lit lit) = return (Lit lit, emptyUDs) -specExpr env (Cast e co) - = do { (e', uds) <- specExpr env e - ; return ((mkCast e' (substCo env co)), uds) } -specExpr env (Tick tickish body) - = do { (body', uds) <- specExpr env body - ; return (Tick (specTickish env tickish) body', uds) } - ----------------- Applications might generate a call instance -------------------- -specExpr env expr@(App {}) - = go expr [] - where - go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg - (fun', uds_app) <- go fun (arg':args) - return (App fun' arg', uds_arg `plusUDs` uds_app) - - go (Var f) args = case specVar env f of - Var f' -> return (Var f', mkCallUDs env f' args) - e' -> return (e', emptyUDs) -- I don't expect this! - go other _ = specExpr env other - ----------------- Lambda/case require dumping of usage details -------------------- -specExpr env e@(Lam _ _) = do - (body', uds) <- specExpr env' body - let (free_uds, dumped_dbs) = dumpUDs bndrs' uds - return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds) - where - (bndrs, body) = collectBinders e - (env', bndrs') = substBndrs env bndrs - -- More efficient to collect a group of binders together all at once - -- and we don't want to split a lambda group with dumped bindings - -specExpr env (Case scrut case_bndr ty alts) - = do { (scrut', scrut_uds) <- specExpr env scrut - ; (scrut'', case_bndr', alts', alts_uds) - <- specCase env scrut' case_bndr alts - ; return (Case scrut'' case_bndr' (substTy env ty) alts' - , scrut_uds `plusUDs` alts_uds) } - ----------------- Finally, let is the interesting case -------------------- -specExpr env (Let bind body) - = do { -- Clone binders - (rhs_env, body_env, bind') <- cloneBindSM env bind - - -- Deal with the body - ; (body', body_uds) <- specExpr body_env body - - -- Deal with the bindings - ; (binds', uds) <- specBind rhs_env bind' body_uds - - -- All done - ; return (foldr Let body' binds', uds) } - -specTickish :: SpecEnv -> Tickish Id -> Tickish Id -specTickish env (Breakpoint ix ids) - = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]] - -- drop vars from the list if they have a non-variable substitution. - -- should never happen, but it's harmless to drop them anyway. -specTickish _ other_tickish = other_tickish - -specCase :: SpecEnv - -> CoreExpr -- Scrutinee, already done - -> Id -> [CoreAlt] - -> SpecM ( CoreExpr -- New scrutinee - , Id - , [CoreAlt] - , UsageDetails) -specCase env scrut' case_bndr [(con, args, rhs)] - | isDictId case_bndr -- See Note [Floating dictionaries out of cases] - , interestingDict env scrut' - , not (isDeadBinder case_bndr && null sc_args') - = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') - - ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') - [(con, args', Var sc_arg')] - | sc_arg' <- sc_args' ] - - -- Extend the substitution for RHS to map the *original* binders - -- to their floated verions. - mb_sc_flts :: [Maybe DictId] - mb_sc_flts = map (lookupVarEnv clone_env) args' - clone_env = zipVarEnv sc_args' sc_args_flt - subst_prs = (case_bndr, Var case_bndr_flt) - : [ (arg, Var sc_flt) - | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] - env_rhs' = env_rhs { se_subst = CoreSubst.extendIdSubstList (se_subst env_rhs) subst_prs - , se_interesting = se_interesting env_rhs `extendVarSetList` - (case_bndr_flt : sc_args_flt) } - - ; (rhs', rhs_uds) <- specExpr env_rhs' rhs - ; let scrut_bind = mkDB (NonRec case_bndr_flt scrut') - case_bndr_set = unitVarSet case_bndr_flt - sc_binds = [(NonRec sc_arg_flt sc_rhs, case_bndr_set) - | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ] - flt_binds = scrut_bind : sc_binds - (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds - all_uds = flt_binds `addDictBinds` free_uds - alt' = (con, args', wrapDictBindsE dumped_dbs rhs') - ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } - where - (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) - sc_args' = filter is_flt_sc_arg args' - - clone_me bndr = do { uniq <- getUniqueM - ; return (mkUserLocalOrCoVar occ uniq ty loc) } - where - name = idName bndr - ty = idType bndr - occ = nameOccName name - loc = getSrcSpan name - - arg_set = mkVarSet args' - is_flt_sc_arg var = isId var - && not (isDeadBinder var) - && isDictTy var_ty - && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set) - where - var_ty = idType var - - -specCase env scrut case_bndr alts - = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts - ; return (scrut, case_bndr', alts', uds_alts) } - where - (env_alt, case_bndr') = substBndr env case_bndr - spec_alt (con, args, rhs) = do - (rhs', uds) <- specExpr env_rhs rhs - let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds - return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds) - where - (env_rhs, args') = substBndrs env_alt args - -{- -Note [Floating dictionaries out of cases] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - g = \d. case d of { MkD sc ... -> ...(f sc)... } -Naively we can't float d2's binding out of the case expression, -because 'sc' is bound by the case, and that in turn means we can't -specialise f, which seems a pity. - -So we invert the case, by floating out a binding -for 'sc_flt' thus: - sc_flt = case d of { MkD sc ... -> sc } -Now we can float the call instance for 'f'. Indeed this is just -what'll happen if 'sc' was originally bound with a let binding, -but case is more efficient, and necessary with equalities. So it's -good to work with both. - -You might think that this won't make any difference, because the -call instance will only get nuked by the \d. BUT if 'g' itself is -specialised, then transitively we should be able to specialise f. - -In general, given - case e of cb { MkD sc ... -> ...(f sc)... } -we transform to - let cb_flt = e - sc_flt = case cb_flt of { MkD sc ... -> sc } - in - case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... } - -The "_flt" things are the floated binds; we use the current substitution -to substitute sc -> sc_flt in the RHS - -************************************************************************ -* * - Dealing with a binding -* * -************************************************************************ --} - -specBind :: SpecEnv -- Use this for RHSs - -> CoreBind -- Binders are already cloned by cloneBindSM, - -- but RHSs are un-processed - -> UsageDetails -- Info on how the scope of the binding - -> SpecM ([CoreBind], -- New bindings - UsageDetails) -- And info to pass upstream - --- Returned UsageDetails: --- No calls for binders of this bind -specBind rhs_env (NonRec fn rhs) body_uds - = do { (rhs', rhs_uds) <- specExpr rhs_env rhs - ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs - - ; let pairs = spec_defns ++ [(fn', rhs')] - -- fn' mentions the spec_defns in its rules, - -- so put the latter first - - combined_uds = body_uds1 `plusUDs` rhs_uds - - (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds - - final_binds :: [DictBind] - -- See Note [From non-recursive to recursive] - final_binds - | not (isEmptyBag dump_dbs) - , not (null spec_defns) - = [recWithDumpedDicts pairs dump_dbs] - | otherwise - = [mkDB $ NonRec b r | (b,r) <- pairs] - ++ bagToList dump_dbs - - ; if float_all then - -- Rather than discard the calls mentioning the bound variables - -- we float this (dictionary) binding along with the others - return ([], free_uds `snocDictBinds` final_binds) - else - -- No call in final_uds mentions bound variables, - -- so we can just leave the binding here - return (map fst final_binds, free_uds) } - - -specBind rhs_env (Rec pairs) body_uds - -- Note [Specialising a recursive group] - = do { let (bndrs,rhss) = unzip pairs - ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss - ; let scope_uds = body_uds `plusUDs` rhs_uds - -- Includes binds and calls arising from rhss - - ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs - - ; (bndrs3, spec_defns3, uds3) - <- if null spec_defns1 -- Common case: no specialisation - then return (bndrs1, [], uds1) - else do { -- Specialisation occurred; do it again - (bndrs2, spec_defns2, uds2) - <- specDefns rhs_env uds1 (bndrs1 `zip` rhss) - ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) } - - ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3 - final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss') - dumped_dbs - - ; if float_all then - return ([], final_uds `snocDictBind` final_bind) - else - return ([fst final_bind], final_uds) } - - ---------------------------- -specDefns :: SpecEnv - -> UsageDetails -- Info on how it is used in its scope - -> [(OutId,InExpr)] -- The things being bound and their un-processed RHS - -> SpecM ([OutId], -- Original Ids with RULES added - [(OutId,OutExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions - --- Specialise a list of bindings (the contents of a Rec), but flowing usages --- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } --- Then if the input CallDetails has a specialised call for 'g', whose specialisation --- in turn generates a specialised call for 'f', we catch that in this one sweep. --- But not vice versa (it's a fixpoint problem). - -specDefns _env uds [] - = return ([], [], uds) -specDefns env uds ((bndr,rhs):pairs) - = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs - ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs - ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) } - ---------------------------- -specDefn :: SpecEnv - -> UsageDetails -- Info on how it is used in its scope - -> OutId -> InExpr -- The thing being bound and its un-processed RHS - -> SpecM (Id, -- Original Id with added RULES - [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions - -specDefn env body_uds fn rhs - = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds - rules_for_me = idCoreRules fn - ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me - calls_for_me fn rhs - ; return ( fn `addIdSpecialisations` rules - , spec_defns - , body_uds_without_me `plusUDs` spec_uds) } - -- It's important that the `plusUDs` is this way - -- round, because body_uds_without_me may bind - -- dictionaries that are used in calls_for_me passed - -- to specDefn. So the dictionary bindings in - -- spec_uds may mention dictionaries bound in - -- body_uds_without_me - ---------------------------- -specCalls :: Maybe Module -- Just this_mod => specialising imported fn - -- Nothing => specialising local fn - -> SpecEnv - -> [CoreRule] -- Existing RULES for the fn - -> [CallInfo] - -> OutId -> InExpr - -> SpecM SpecInfo -- New rules, specialised bindings, and usage details - --- This function checks existing rules, and does not create --- duplicate ones. So the caller does not need to do this filtering. --- See 'already_covered' - -type SpecInfo = ( [CoreRule] -- Specialisation rules - , [(Id,CoreExpr)] -- Specialised definition - , UsageDetails ) -- Usage details from specialised RHSs - -specCalls mb_mod env existing_rules calls_for_me fn rhs - -- The first case is the interesting one - | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas - && rhs_bndrs1 `lengthAtLeast` n_dicts -- and enough dict args - && notNull calls_for_me -- And there are some calls to specialise - && not (isNeverActive (idInlineActivation fn)) - -- Don't specialise NOINLINE things - -- See Note [Auto-specialisation and RULES] - --- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small --- See Note [Inline specialisation] for why we do not --- switch off specialisation for inline functions - - = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $ - foldlM spec_call ([], [], emptyUDs) calls_for_me - - | otherwise -- No calls or RHS doesn't fit our preconceptions - = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, - text "Missed specialisation opportunity for" - <+> ppr fn $$ _trace_doc ) - -- Note [Specialisation shape] - -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ - return ([], [], emptyUDs) - where - _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars - , ppr rhs_bndrs, ppr n_dicts - , ppr (idInlineActivation fn) ] - - fn_type = idType fn - fn_arity = idArity fn - fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here - (tyvars, theta, _) = tcSplitSigmaTy fn_type - n_tyvars = length tyvars - n_dicts = length theta - inl_prag = idInlinePragma fn - inl_act = inlinePragmaActivation inl_prag - is_local = isLocalId fn - - -- Figure out whether the function has an INLINE pragma - -- See Note [Inline specialisations] - - (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs - -- See Note [Account for casts in binding] - (rhs_tyvars, rhs_bndrs1) = span isTyVar rhs_bndrs - (rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1 - body = mkLams rhs_bndrs2 rhs_body - -- Glue back on the non-dict lambdas - - in_scope = CoreSubst.substInScope (se_subst env) - - already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool - already_covered dflags new_rules args -- Note [Specialisations already covered] - = isJust (lookupRule dflags (in_scope, realIdUnfolding) - (const True) fn args - (new_rules ++ existing_rules)) - -- NB: we look both in the new_rules (generated by this invocation - -- of specCalls), and in existing_rules (passed in to specCalls) - - mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr] - mk_ty_args [] poly_tvs - = ASSERT( null poly_tvs ) [] - mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs) - = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs - mk_ty_args (Just ty : call_ts) poly_tvs - = Type ty : mk_ty_args call_ts poly_tvs - mk_ty_args (Nothing : _) [] = panic "mk_ty_args" - - ---------------------------------------------------------- - -- Specialise to one particular call pattern - spec_call :: SpecInfo -- Accumulating parameter - -> CallInfo -- Call instance - -> SpecM SpecInfo - spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) - (CI { ci_key = CallKey call_ts, ci_args = call_ds }) - = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts ) - - -- Suppose f's defn is f = /\ a b c -> \ d1 d2 -> rhs - -- Suppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2] - - -- Construct the new binding - -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs) - -- PLUS the rule - -- RULE "SPEC f" forall b d1' d2'. f b d1' d2' = f1 b - -- In the rule, d1' and d2' are just wildcards, not used in the RHS - -- PLUS the usage-details - -- { d1' = dx1; d2' = dx2 } - -- where d1', d2' are cloned versions of d1,d2, with the type substitution - -- applied. These auxiliary bindings just avoid duplication of dx1, dx2 - -- - -- Note that the substitution is applied to the whole thing. - -- This is convenient, but just slightly fragile. Notably: - -- * There had better be no name clashes in a/b/c - do { let - -- poly_tyvars = [b] in the example above - -- spec_tyvars = [a,c] - -- ty_args = [t1,b,t3] - spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts] - env1 = extendTvSubstList env spec_tv_binds - (rhs_env, poly_tyvars) = substBndrs env1 - [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] - - -- Clone rhs_dicts, including instantiating their types - ; inst_dict_ids <- mapM (newDictBndr rhs_env) rhs_dict_ids - ; let (rhs_env2, dx_binds, spec_dict_args) - = bindAuxiliaryDicts rhs_env rhs_dict_ids call_ds inst_dict_ids - ty_args = mk_ty_args call_ts poly_tyvars - ev_args = map varToCoreExpr inst_dict_ids -- ev_args, ev_bndrs: - ev_bndrs = exprsFreeIdsList ev_args -- See Note [Evidence foralls] - rule_args = ty_args ++ ev_args - rule_bndrs = poly_tyvars ++ ev_bndrs - - ; dflags <- getDynFlags - ; if already_covered dflags rules_acc rule_args - then return spec_acc - else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids - -- , text "rhs_env2" <+> ppr (se_subst rhs_env2) - -- , ppr dx_binds ]) $ - do - { -- Figure out the type of the specialised function - let body_ty = applyTypeToArgs rhs fn_type rule_args - (lam_args, app_args) -- Add a dummy argument if body_ty is unlifted - | isUnliftedType body_ty -- C.f. WwLib.mkWorkerArgs - , not (isJoinId fn) - = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId]) - | otherwise = (poly_tyvars, poly_tyvars) - spec_id_ty = mkLamTypes lam_args body_ty - join_arity_change = length app_args - length rule_args - spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn - = Just (orig_join_arity + join_arity_change) - | otherwise - = Nothing - - ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity - ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body) - ; this_mod <- getModule - ; let - -- The rule to put in the function's specialisation is: - -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b - herald = case mb_mod of - Nothing -- Specialising local fn - -> text "SPEC" - Just this_mod -- Specialising imoprted fn - -> text "SPEC/" <> ppr this_mod - - rule_name = mkFastString $ showSDoc dflags $ - herald <+> ftext (occNameFS (getOccName fn)) - <+> hsep (map ppr_call_key_ty call_ts) - -- This name ends up in interface files, so use occNameString. - -- Otherwise uniques end up there, making builds - -- less deterministic (See #4012 comment:61 ff) - - rule_wout_eta = mkRule - this_mod - True {- Auto generated -} - is_local - rule_name - inl_act -- Note [Auto-specialisation and RULES] - (idName fn) - rule_bndrs - rule_args - (mkVarApps (Var spec_f) app_args) - - spec_rule - = case isJoinId_maybe fn of - Just join_arity -> etaExpandToJoinPointRule join_arity - rule_wout_eta - Nothing -> rule_wout_eta - - -- Add the { d1' = dx1; d2' = dx2 } usage stuff - spec_uds = foldr consDictBind rhs_uds dx_binds - - -------------------------------------- - -- Add a suitable unfolding if the spec_inl_prag says so - -- See Note [Inline specialisations] - (spec_inl_prag, spec_unf) - | not is_local && isStrongLoopBreaker (idOccInfo fn) - = (neverInlinePragma, noUnfolding) - -- See Note [Specialising imported functions] in OccurAnal - - | InlinePragma { inl_inline = Inlinable } <- inl_prag - = (inl_prag { inl_inline = EmptyInlineSpec }, noUnfolding) - - | otherwise - = (inl_prag, specUnfolding poly_tyvars spec_app - arity_decrease fn_unf) - - arity_decrease = length spec_dict_args - spec_app e = (e `mkApps` ty_args) `mkApps` spec_dict_args - - -------------------------------------- - -- Adding arity information just propagates it a bit faster - -- See Note [Arity decrease] in Simplify - -- Copy InlinePragma information from the parent Id. - -- So if f has INLINE[1] so does spec_f - spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts) - `setInlinePragma` spec_inl_prag - `setIdUnfolding` spec_unf - `asJoinId_maybe` spec_join_arity - - ; return ( spec_rule : rules_acc - , (spec_f_w_arity, spec_rhs) : pairs_acc - , spec_uds `plusUDs` uds_acc - ) } } - -{- Note [Account for casts in binding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: Eq a => a -> IO () - {-# INLINABLE f - StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g - #-} - f = ... - -In f's stable unfolding we have done some modest simplification which -has pushed the cast to the outside. (I wonder if this is the Right -Thing, but it's what happens now; see SimplUtils Note [Casts and -lambdas].) Now that stable unfolding must be specialised, so we want -to push the cast back inside. It would be terrible if the cast -defeated specialisation! Hence the use of collectBindersPushingCo. - -Note [Evidence foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose (Trac #12212) that we are specialising - f :: forall a b. (Num a, F a ~ F b) => blah -with a=b=Int. Then the RULE will be something like - RULE forall (d:Num Int) (g :: F Int ~ F Int). - f Int Int d g = f_spec -But both varToCoreExpr (when constructing the LHS args), and the -simplifier (when simplifying the LHS args), will transform to - RULE forall (d:Num Int) (g :: F Int ~ F Int). - f Int Int d = f_spec -by replacing g with Refl. So now 'g' is unbound, which results in a later -crash. So we use Refl right off the bat, and do not forall-quantify 'g': - * varToCoreExpr generates a Refl - * exprsFreeIdsList returns the Ids bound by the args, - which won't include g - -You might wonder if this will match as often, but the simplifier replaces -complicated Refl coercions with Refl pretty aggressively. - -Note [Orphans and auto-generated rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we specialise an INLINABLE function, or when we have --fspecialise-aggressively, we auto-generate RULES that are orphans. -We don't want to warn about these, or we'd generate a lot of warnings. -Thus, we only warn about user-specified orphan rules. - -Indeed, we don't even treat the module as an orphan module if it has -auto-generated *rule* orphans. Orphan modules are read every time we -compile, so they are pretty obtrusive and slow down every compilation, -even non-optimised ones. (Reason: for type class instances it's a -type correctness issue.) But specialisation rules are strictly for -*optimisation* only so it's fine not to read the interface. - -What this means is that a SPEC rules from auto-specialisation in -module M will be used in other modules only if M.hi has been read for -some other reason, which is actually pretty likely. --} - -bindAuxiliaryDicts - :: SpecEnv - -> [DictId] -> [CoreExpr] -- Original dict bndrs, and the witnessing expressions - -> [DictId] -- A cloned dict-id for each dict arg - -> (SpecEnv, -- Substitute for all orig_dicts - [DictBind], -- Auxiliary dict bindings - [CoreExpr]) -- Witnessing expressions (all trivial) --- Bind any dictionary arguments to fresh names, to preserve sharing -bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting }) - orig_dict_ids call_ds inst_dict_ids - = (env', dx_binds, spec_dict_args) - where - (dx_binds, spec_dict_args) = go call_ds inst_dict_ids - env' = env { se_subst = subst `CoreSubst.extendSubstList` - (orig_dict_ids `zip` spec_dict_args) - `CoreSubst.extendInScopeList` dx_ids - , se_interesting = interesting `unionVarSet` interesting_dicts } - - dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds] - interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds - , interestingDict env dx ] - -- See Note [Make the new dictionaries interesting] - - go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr]) - go [] _ = ([], []) - go (dx:dxs) (dx_id:dx_ids) - | exprIsTrivial dx = (dx_binds, dx : args) - | otherwise = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args) - where - (dx_binds, args) = go dxs dx_ids - -- In the first case extend the substitution but not bindings; - -- in the latter extend the bindings but not the substitution. - -- For the former, note that we bind the *original* dict in the substitution, - -- overriding any d->dx_id binding put there by substBndrs - go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids) - -{- -Note [Make the new dictionaries interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Important! We're going to substitute dx_id1 for d -and we want it to look "interesting", else we won't gather *any* -consequential calls. E.g. - f d = ...g d.... -If we specialise f for a call (f (dfun dNumInt)), we'll get -a consequent call (g d') with an auxiliary definition - d' = df dNumInt -We want that consequent call to look interesting - - -Note [From non-recursive to recursive] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even in the non-recursive case, if any dict-binds depend on 'fn' we might -have built a recursive knot - - f a d x = - MkUD { ud_binds = NonRec d7 (MkD ..f..) - , ud_calls = ...(f T d7)... } - -The we generate - - Rec { fs x = [T/a, d7/d] - f a d x = - RULE f T _ = fs - d7 = ...f... } - -Here the recursion is only through the RULE. - -However we definitely should /not/ make the Rec in this wildly common -case: - d = ... - MkUD { ud_binds = NonRec d7 (...d...) - , ud_calls = ...(f T d7)... } - -Here we want simply to add d to the floats, giving - MkUD { ud_binds = NonRec d (...) - NonRec d7 (...d...) - , ud_calls = ...(f T d7)... } - -In general, we need only make this Rec if - - there are some specialisations (spec_binds non-empty) - - there are some dict_binds that depend on f (dump_dbs non-empty) - -Note [Avoiding loops] -~~~~~~~~~~~~~~~~~~~~~ -When specialising /dictionary functions/ we must be very careful to -avoid building loops. Here is an example that bit us badly: Trac #3591 - - class Eq a => C a - instance Eq [a] => C [a] - -This translates to - dfun :: Eq [a] -> C [a] - dfun a d = MkD a d (meth d) - - d4 :: Eq [T] = - d2 :: C [T] = dfun T d4 - d1 :: Eq [T] = $p1 d2 - d3 :: C [T] = dfun T d1 - -None of these definitions is recursive. What happened was that we -generated a specialisation: - - RULE forall d. dfun T d = dT :: C [T] - dT = (MkD a d (meth d)) [T/a, d1/d] - = MkD T d1 (meth d1) - -But now we use the RULE on the RHS of d2, to get - - d2 = dT = MkD d1 (meth d1) - d1 = $p1 d2 - -and now d1 is bottom! The problem is that when specialising 'dfun' we -should first dump "below" the binding all floated dictionary bindings -that mention 'dfun' itself. So d2 and d3 (and hence d1) must be -placed below 'dfun', and thus unavailable to it when specialising -'dfun'. That in turn means that the call (dfun T d1) must be -discarded. On the other hand, the call (dfun T d4) is fine, assuming -d4 doesn't mention dfun. - -Solution: - Discard all calls that mention dictionaries that depend - (directly or indirectly) on the dfun we are specialising. - This is done by 'filterCalls' - --------------- -Here's another example, this time for an imported dfun, so the call -to filterCalls is in specImports (Trac #13429). Suppose we have - class Monoid v => C v a where ... - -We start with a call - f @ [Integer] @ Integer $fC[]Integer - -Specialising call to 'f' gives dict bindings - $dMonoid_1 :: Monoid [Integer] - $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer - - $dC_1 :: C [Integer] (Node [Integer] Integer) - $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 - -...plus a recursive call to - f @ [Integer] @ (Node [Integer] Integer) $dC_1 - -Specialising that call gives - $dMonoid_2 :: Monoid [Integer] - $dMonoid_2 = M.$p1C @ [Integer] $dC_1 - - $dC_2 :: C [Integer] (Node [Integer] Integer) - $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2 - -Now we have two calls to the imported function - M.$fCvNode :: Monoid v => C v a - M.$fCvNode @v @a m = C m some_fun - -But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2) -for specialisation, else we get: - - $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 - $dMonoid_2 = M.$p1C @ [Integer] $dC_1 - $s$fCvNode = C $dMonoid_2 ... - RULE M.$fCvNode [Integer] _ _ = $s$fCvNode - -Now use the rule to rewrite the call in the RHS of $dC_1 -and we get a loop! - --------------- -Here's yet another example - - class C a where { foo,bar :: [a] -> [a] } - - instance C Int where - foo x = r_bar x - bar xs = reverse xs - - r_bar :: C a => [a] -> [a] - r_bar xs = bar (xs ++ xs) - -That translates to: - - r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) - - Rec { $fCInt :: C Int = MkC foo_help reverse - foo_help (xs::[Int]) = r_bar Int $fCInt xs } - -The call (r_bar $fCInt) mentions $fCInt, - which mentions foo_help, - which mentions r_bar -But we DO want to specialise r_bar at Int: - - Rec { $fCInt :: C Int = MkC foo_help reverse - foo_help (xs::[Int]) = r_bar Int $fCInt xs - - r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) - RULE r_bar Int _ = r_bar_Int - - r_bar_Int xs = bar Int $fCInt (xs ++ xs) - } - -Note that, because of its RULE, r_bar joins the recursive -group. (In this case it'll unravel a short moment later.) - - -Note [Specialising a recursive group] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let rec { f x = ...g x'... - ; g y = ...f y'.... } - in f 'a' -Here we specialise 'f' at Char; but that is very likely to lead to -a specialisation of 'g' at Char. We must do the latter, else the -whole point of specialisation is lost. - -But we do not want to keep iterating to a fixpoint, because in the -presence of polymorphic recursion we might generate an infinite number -of specialisations. - -So we use the following heuristic: - * Arrange the rec block in dependency order, so far as possible - (the occurrence analyser already does this) - - * Specialise it much like a sequence of lets - - * Then go through the block a second time, feeding call-info from - the RHSs back in the bottom, as it were - -In effect, the ordering maxmimises the effectiveness of each sweep, -and we do just two sweeps. This should catch almost every case of -monomorphic recursion -- the exception could be a very knotted-up -recursion with multiple cycles tied up together. - -This plan is implemented in the Rec case of specBindItself. - -Note [Specialisations already covered] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We obviously don't want to generate two specialisations for the same -argument pattern. There are two wrinkles - -1. We do the already-covered test in specDefn, not when we generate -the CallInfo in mkCallUDs. We used to test in the latter place, but -we now iterate the specialiser somewhat, and the Id at the call site -might therefore not have all the RULES that we can see in specDefn - -2. What about two specialisations where the second is an *instance* -of the first? If the more specific one shows up first, we'll generate -specialisations for both. If the *less* specific one shows up first, -we *don't* currently generate a specialisation for the more specific -one. (See the call to lookupRule in already_covered.) Reasons: - (a) lookupRule doesn't say which matches are exact (bad reason) - (b) if the earlier specialisation is user-provided, it's - far from clear that we should auto-specialise further - -Note [Auto-specialisation and RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - g :: Num a => a -> a - g = ... - - f :: (Int -> Int) -> Int - f w = ... - {-# RULE f g = 0 #-} - -Suppose that auto-specialisation makes a specialised version of -g::Int->Int That version won't appear in the LHS of the RULE for f. -So if the specialisation rule fires too early, the rule for f may -never fire. - -It might be possible to add new rules, to "complete" the rewrite system. -Thus when adding - RULE forall d. g Int d = g_spec -also add - RULE f g_spec = 0 - -But that's a bit complicated. For now we ask the programmer's help, -by *copying the INLINE activation pragma* to the auto-specialised -rule. So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule -will also not be active until phase 2. And that's what programmers -should jolly well do anyway, even aside from specialisation, to ensure -that g doesn't inline too early. - -This in turn means that the RULE would never fire for a NOINLINE -thing so not much point in generating a specialisation at all. - -Note [Specialisation shape] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only specialise a function if it has visible top-level lambdas -corresponding to its overloading. E.g. if - f :: forall a. Eq a => .... -then its body must look like - f = /\a. \d. ... - -Reason: when specialising the body for a call (f ty dexp), we want to -substitute dexp for d, and pick up specialised calls in the body of f. - -This doesn't always work. One example I came across was this: - newtype Gen a = MkGen{ unGen :: Int -> a } - - choose :: Eq a => a -> Gen a - choose n = MkGen (\r -> n) - - oneof = choose (1::Int) - -It's a silly exapmle, but we get - choose = /\a. g `cast` co -where choose doesn't have any dict arguments. Thus far I have not -tried to fix this (wait till there's a real example). - -Mind you, then 'choose' will be inlined (since RHS is trivial) so -it doesn't matter. This comes up with single-method classes - - class C a where { op :: a -> a } - instance C a => C [a] where .... -==> - $fCList :: C a => C [a] - $fCList = $copList |> (...coercion>...) - ....(uses of $fCList at particular types)... - -So we suppress the WARN if the rhs is trivial. - -Note [Inline specialisations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is what we do with the InlinePragma of the original function - * Activation/RuleMatchInfo: both transferred to the - specialised function - * InlineSpec: - (a) An INLINE pragma is transferred - (b) An INLINABLE pragma is *not* transferred - -Why (a): transfer INLINE pragmas? The point of INLINE was precisely to -specialise the function at its call site, and arguably that's not so -important for the specialised copies. BUT *pragma-directed* -specialisation now takes place in the typechecker/desugarer, with -manually specified INLINEs. The specialisation here is automatic. -It'd be very odd if a function marked INLINE was specialised (because -of some local use), and then forever after (including importing -modules) the specialised version wasn't INLINEd. After all, the -programmer said INLINE! - -You might wonder why we specialise INLINE functions at all. After -all they should be inlined, right? Two reasons: - - * Even INLINE functions are sometimes not inlined, when they aren't - applied to interesting arguments. But perhaps the type arguments - alone are enough to specialise (even though the args are too boring - to trigger inlining), and it's certainly better to call the - specialised version. - - * The RHS of an INLINE function might call another overloaded function, - and we'd like to generate a specialised version of that function too. - This actually happens a lot. Consider - replicateM_ :: (Monad m) => Int -> m a -> m () - {-# INLINABLE replicateM_ #-} - replicateM_ d x ma = ... - The strictness analyser may transform to - replicateM_ :: (Monad m) => Int -> m a -> m () - {-# INLINE replicateM_ #-} - replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma - - $wreplicateM_ :: (Monad m) => Int# -> m a -> m () - {-# INLINABLE $wreplicateM_ #-} - $wreplicateM_ = ... - Now an importing module has a specialised call to replicateM_, say - (replicateM_ dMonadIO). We certainly want to specialise $wreplicateM_! - This particular example had a huge effect on the call to replicateM_ - in nofib/shootout/n-body. - -Why (b): discard INLINABLE pragmas? See Trac #4874 for persuasive examples. -Suppose we have - {-# INLINABLE f #-} - f :: Ord a => [a] -> Int - f xs = letrec f' = ...f'... in f' -Then, when f is specialised and optimised we might get - wgo :: [Int] -> Int# - wgo = ...wgo... - f_spec :: [Int] -> Int - f_spec xs = case wgo xs of { r -> I# r } -and we clearly want to inline f_spec at call sites. But if we still -have the big, un-optimised of f (albeit specialised) captured in an -INLINABLE pragma for f_spec, we won't get that optimisation. - -So we simply drop INLINABLE pragmas when specialising. It's not really -a complete solution; ignoring specialisation for now, INLINABLE functions -don't get properly strictness analysed, for example. But it works well -for examples involving specialisation, which is the dominant use of -INLINABLE. See Trac #4874. - - -************************************************************************ -* * -\subsubsection{UsageDetails and suchlike} -* * -************************************************************************ --} - -data UsageDetails - = MkUD { - ud_binds :: !(Bag DictBind), - -- See Note [Floated dictionary bindings] - -- The order is important; - -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 - -- (Remember, Bags preserve order in GHC.) - - ud_calls :: !CallDetails - - -- INVARIANT: suppose bs = bindersOf ud_binds - -- Then 'calls' may *mention* 'bs', - -- but there should be no calls *for* bs - } - --- | A 'DictBind' is a binding along with a cached set containing its free --- variables (both type variables and dictionaries) -type DictBind = (CoreBind, VarSet) - -{- Note [Floated dictionary bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We float out dictionary bindings for the reasons described under -"Dictionary floating" above. But not /just/ dictionary bindings. -Consider - - f :: Eq a => blah - f a d = rhs - - $c== :: T -> T -> Bool - $c== x y = ... - - $df :: Eq T - $df = Eq $c== ... - - gurgle = ...(f @T $df)... - -We gather the call info for (f @T $df), and we don't want to drop it -when we come across the binding for $df. So we add $df to the floats -and continue. But then we have to add $c== to the floats, and so on. -These all float above the binding for 'f', and and now we can -successfullly specialise 'f'. - -So the DictBinds in (ud_binds :: Bag DictBind) may contain -non-dictionary bindings too. --} - -instance Outputable UsageDetails where - ppr (MkUD { ud_binds = dbs, ud_calls = calls }) - = text "MkUD" <+> braces (sep (punctuate comma - [text "binds" <+> equals <+> ppr dbs, - text "calls" <+> equals <+> ppr calls])) - -emptyUDs :: UsageDetails -emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv } - ------------------------------------------------------------- -type CallDetails = DIdEnv CallInfoSet - -- The order of specialized binds and rules depends on how we linearize - -- CallDetails, so to get determinism we must use a deterministic set here. - -- See Note [Deterministic UniqFM] in UniqDFM - -data CallInfoSet = CIS Id (Bag CallInfo) - -- The list of types and dictionaries is guaranteed to - -- match the type of f - -- The Bag may contain duplicate calls (i.e. f @T and another f @T) - -- These dups are eliminated by already_covered in specCalls - -data CallInfo - = CI { ci_key :: CallKey -- Type arguments - , ci_args :: [DictExpr] -- Dictionary arguments - , ci_fvs :: VarSet -- Free vars of the ci_key and ci_args - -- call (including tyvars) - -- [*not* include the main id itself, of course] - } - -newtype CallKey = CallKey [Maybe Type] - -- Nothing => unconstrained type argument - -type DictExpr = CoreExpr - -ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet -ciSetFilter p (CIS id a) = CIS id (filterBag p a) - -instance Outputable CallInfoSet where - ppr (CIS fn map) = hang (text "CIS" <+> ppr fn) - 2 (ppr map) - -pprCallInfo :: Id -> CallInfo -> SDoc -pprCallInfo fn (CI { ci_key = key }) - = ppr fn <+> ppr key - -ppr_call_key_ty :: Maybe Type -> SDoc -ppr_call_key_ty Nothing = char '_' -ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty - -instance Outputable CallKey where - ppr (CallKey ts) = brackets (fsep (map ppr_call_key_ty ts)) - -instance Outputable CallInfo where - ppr (CI { ci_key = key, ci_args = args, ci_fvs = fvs }) - = text "CI" <> braces (hsep [ ppr key, ppr args, ppr fvs ]) - -unionCalls :: CallDetails -> CallDetails -> CallDetails -unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2 - -unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet -unionCallInfoSet (CIS f calls1) (CIS _ calls2) = - CIS f (calls1 `unionBags` calls2) - -callDetailsFVs :: CallDetails -> VarSet -callDetailsFVs calls = - nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls - -- It's OK to use nonDetFoldUDFM here because we forget the ordering - -- immediately by converting to a nondeterministic set. - -callInfoFVs :: CallInfoSet -> VarSet -callInfoFVs (CIS _ call_info) = - foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info - ------------------------------------------------------------- -singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails -singleCall id tys dicts - = MkUD {ud_binds = emptyBag, - ud_calls = unitDVarEnv id $ CIS id $ - unitBag (CI { ci_key = CallKey tys - , ci_args = dicts - , ci_fvs = call_fvs }) } - where - call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs - tys_fvs = tyCoVarsOfTypes (catMaybes tys) - -- The type args (tys) are guaranteed to be part of the dictionary - -- types, because they are just the constrained types, - -- and the dictionary is therefore sure to be bound - -- inside the binding for any type variables free in the type; - -- hence it's safe to neglect tyvars free in tys when making - -- the free-var set for this call - -- BUT I don't trust this reasoning; play safe and include tys_fvs - -- - -- We don't include the 'id' itself. - -mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails -mkCallUDs env f args - = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ]) - res - where - res = mkCallUDs' env f args - -mkCallUDs' env f args - | not (want_calls_for f) -- Imported from elsewhere - || null theta -- Not overloaded - = emptyUDs - - | not (all type_determines_value theta) - || not (spec_tys `lengthIs` n_tyvars) - || not ( dicts `lengthIs` n_dicts) - || not (any (interestingDict env) dicts) -- Note [Interesting dictionary arguments] - -- See also Note [Specialisations already covered] - = -- pprTrace "mkCallUDs: discarding" _trace_doc - emptyUDs -- Not overloaded, or no specialisation wanted - - | otherwise - = -- pprTrace "mkCallUDs: keeping" _trace_doc - singleCall f spec_tys dicts - where - _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts - , ppr (map (interestingDict env) dicts)] - (tyvars, theta, _) = tcSplitSigmaTy (idType f) - constrained_tyvars = tyCoVarsOfTypes theta - n_tyvars = length tyvars - n_dicts = length theta - - spec_tys = [mk_spec_ty tv ty | (tv, ty) <- tyvars `type_zip` args] - dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)] - - -- ignores Coercion arguments - type_zip :: [TyVar] -> [CoreExpr] -> [(TyVar, Type)] - type_zip tvs (Coercion _ : args) = type_zip tvs args - type_zip (tv:tvs) (Type ty : args) = (tv, ty) : type_zip tvs args - type_zip _ _ = [] - - mk_spec_ty tyvar ty - | tyvar `elemVarSet` constrained_tyvars = Just ty - | otherwise = Nothing - - want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f)) - -- For imported things, we gather call instances if - -- there is an unfolding that we could in principle specialise - -- We might still decide not to use it (consulting dflags) - -- in specImports - -- Use 'realIdUnfolding' to ignore the loop-breaker flag! - - type_determines_value pred -- See Note [Type determines value] - = case classifyPredType pred of - ClassPred cls _ -> not (isIPClass cls) -- Superclasses can't be IPs - EqPred {} -> True - IrredPred {} -> True -- Things like (D []) where D is a - -- Constraint-ranged family; Trac #7785 - -{- -Note [Type determines value] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Only specialise if all overloading is on non-IP *class* params, -because these are the ones whose *type* determines their *value*. In -parrticular, with implicit params, the type args *don't* say what the -value of the implicit param is! See Trac #7101 - -However, consider - type family D (v::*->*) :: Constraint - type instance D [] = () - f :: D v => v Char -> Int -If we see a call (f "foo"), we'll pass a "dictionary" - () |> (g :: () ~ D []) -and it's good to specialise f at this dictionary. - -So the question is: can an implicit parameter "hide inside" a -type-family constraint like (D a). Well, no. We don't allow - type instance D Maybe = ?x:Int -Hence the IrredPred case in type_determines_value. -See Trac #7785. - -Note [Interesting dictionary arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - \a.\d:Eq a. let f = ... in ...(f d)... -There really is not much point in specialising f wrt the dictionary d, -because the code for the specialised f is not improved at all, because -d is lambda-bound. We simply get junk specialisations. - -What is "interesting"? Just that it has *some* structure. But what about -variables? - - * A variable might be imported, in which case its unfolding - will tell us whether it has useful structure - - * Local variables are cloned on the way down (to avoid clashes when - we float dictionaries), and cloning drops the unfolding - (cloneIdBndr). Moreover, we make up some new bindings, and it's a - nuisance to give them unfoldings. So we keep track of the - "interesting" dictionaries as a VarSet in SpecEnv. - We have to take care to put any new interesting dictionary - bindings in the set. - -We accidentally lost accurate tracking of local variables for a long -time, because cloned variables don't have unfoldings. But makes a -massive difference in a few cases, eg Trac #5113. For nofib as a -whole it's only a small win: 2.2% improvement in allocation for ansi, -1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. --} - -interestingDict :: SpecEnv -> CoreExpr -> Bool --- A dictionary argument is interesting if it has *some* structure --- NB: "dictionary" arguments include constraints of all sorts, --- including equality constraints; hence the Coercion case -interestingDict env (Var v) = hasSomeUnfolding (idUnfolding v) - || isDataConWorkId v - || v `elemVarSet` se_interesting env -interestingDict _ (Type _) = False -interestingDict _ (Coercion _) = False -interestingDict env (App fn (Type _)) = interestingDict env fn -interestingDict env (App fn (Coercion _)) = interestingDict env fn -interestingDict env (Tick _ a) = interestingDict env a -interestingDict env (Cast e _) = interestingDict env e -interestingDict _ _ = True - -plusUDs :: UsageDetails -> UsageDetails -> UsageDetails -plusUDs (MkUD {ud_binds = db1, ud_calls = calls1}) - (MkUD {ud_binds = db2, ud_calls = calls2}) - = MkUD { ud_binds = db1 `unionBags` db2 - , ud_calls = calls1 `unionCalls` calls2 } - ------------------------------ -_dictBindBndrs :: Bag DictBind -> [Id] -_dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs - --- | Construct a 'DictBind' from a 'CoreBind' -mkDB :: CoreBind -> DictBind -mkDB bind = (bind, bind_fvs bind) - --- | Identify the free variables of a 'CoreBind' -bind_fvs :: CoreBind -> VarSet -bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) -bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs - where - bndrs = map fst prs - rhs_fvs = unionVarSets (map pair_fvs prs) - -pair_fvs :: (Id, CoreExpr) -> VarSet -pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs - `unionVarSet` idFreeVars bndr - -- idFreeVars: don't forget variables mentioned in - -- the rules of the bndr. C.f. OccAnal.addRuleUsage - -- Also tyvars mentioned in its type; they may not appear - -- in the RHS - -- type T a = Int - -- x :: T a = 3 - where - interesting :: InterestingVarFun - interesting v = isLocalVar v || (isId v && isDFunId v) - -- Very important: include DFunIds /even/ if it is imported - -- Reason: See Note [Avoiding loops], the second exmaple - -- involving an imported dfun. We must know whether - -- a dictionary binding depends on an imported dfun, - -- in case we try to specialise that imported dfun - -- Trac #13429 illustrates - --- | Flatten a set of "dumped" 'DictBind's, and some other binding --- pairs, into a single recursive binding. -recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind -recWithDumpedDicts pairs dbs - = (Rec bindings, fvs) - where - (bindings, fvs) = foldrBag add - ([], emptyVarSet) - (dbs `snocBag` mkDB (Rec pairs)) - add (NonRec b r, fvs') (pairs, fvs) = - ((b,r) : pairs, fvs `unionVarSet` fvs') - add (Rec prs1, fvs') (pairs, fvs) = - (prs1 ++ pairs, fvs `unionVarSet` fvs') - -snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails --- Add ud_binds to the tail end of the bindings in uds -snocDictBinds uds dbs - = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs } - -consDictBind :: DictBind -> UsageDetails -> UsageDetails -consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds } - -addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails -addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds } - -snocDictBind :: UsageDetails -> DictBind -> UsageDetails -snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind } - -wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind] -wrapDictBinds dbs binds - = foldrBag add binds dbs - where - add (bind,_) binds = bind : binds - -wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr -wrapDictBindsE dbs expr - = foldrBag add expr dbs - where - add (bind,_) expr = Let bind expr - ----------------------- -dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind) --- Used at a lambda or case binder; just dump anything mentioning the binder -dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) - | null bndrs = (uds, emptyBag) -- Common in case alternatives - | otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ - (free_uds, dump_dbs) - where - free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } - bndr_set = mkVarSet bndrs - (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set - free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor - deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be - -- no calls for any of the dicts in dump_dbs - -dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool) --- Used at a let(rec) binding. --- We return a boolean indicating whether the binding itself is mentioned --- is mentioned, directly or indirectly, by any of the ud_calls; in that --- case we want to float the binding itself; --- See Note [Floated dictionary bindings] -dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) - = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ - (free_uds, dump_dbs, float_all) - where - free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } - bndr_set = mkVarSet bndrs - (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set - free_calls = deleteCallsFor bndrs orig_calls - float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls - -callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) -callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) - = -- pprTrace ("callsForMe") - -- (vcat [ppr fn, - -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), - -- text "Orig calls =" <+> ppr orig_calls, - -- text "Dep set =" <+> ppr dep_set, - -- text "Calls for me =" <+> ppr calls_for_me]) $ - (uds_without_me, calls_for_me) - where - uds_without_me = MkUD { ud_binds = orig_dbs - , ud_calls = delDVarEnv orig_calls fn } - calls_for_me = case lookupDVarEnv orig_calls fn of - Nothing -> [] - Just cis -> filterCalls cis orig_dbs - -- filterCalls: drop calls that (directly or indirectly) - -- refer to fn. See Note [Avoiding loops] - ----------------------- -filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo] --- See Note [Avoiding loops] -filterCalls (CIS fn call_bag) dbs - = filter ok_call (bagToList call_bag) - where - dump_set = foldlBag go (unitVarSet fn) dbs - -- This dump-set could also be computed by splitDictBinds - -- (_,_,dump_set) = splitDictBinds dbs {fn} - -- But this variant is shorter - - go so_far (db,fvs) | fvs `intersectsVarSet` so_far - = extendVarSetList so_far (bindersOf db) - | otherwise = so_far - - ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set) - ----------------------- -splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) --- splitDictBinds dbs bndrs returns --- (free_dbs, dump_dbs, dump_set) --- where --- * dump_dbs depends, transitively on bndrs --- * free_dbs does not depend on bndrs --- * dump_set = bndrs `union` bndrs(dump_dbs) -splitDictBinds dbs bndr_set - = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs - -- Important that it's foldl not foldr; - -- we're accumulating the set of dumped ids in dump_set - where - split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs) - | dump_idset `intersectsVarSet` fvs -- Dump it - = (free_dbs, dump_dbs `snocBag` db, - extendVarSetList dump_idset (bindersOf bind)) - - | otherwise -- Don't dump it - = (free_dbs `snocBag` db, dump_dbs, dump_idset) - - ----------------------- -deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails --- Remove calls *mentioning* bs in any way -deleteCallsMentioning bs calls - = mapDVarEnv (ciSetFilter keep_call) calls - where - keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs) - -deleteCallsFor :: [Id] -> CallDetails -> CallDetails --- Remove calls *for* bs -deleteCallsFor bs calls = delDVarEnvList calls bs - -{- -************************************************************************ -* * -\subsubsection{Boring helper functions} -* * -************************************************************************ --} - -newtype SpecM a = SpecM (State SpecState a) - -data SpecState = SpecState { - spec_uniq_supply :: UniqSupply, - spec_module :: Module, - spec_dflags :: DynFlags - } - -instance Functor SpecM where - fmap = liftM - -instance Applicative SpecM where - pure x = SpecM $ return x - (<*>) = ap - -instance Monad SpecM where - SpecM x >>= f = SpecM $ do y <- x - case f y of - SpecM z -> - z - fail str = SpecM $ fail str - -#if __GLASGOW_HASKELL__ > 710 -instance MonadFail.MonadFail SpecM where - fail str = SpecM $ fail str -#endif - -instance MonadUnique SpecM where - getUniqueSupplyM - = SpecM $ do st <- get - let (us1, us2) = splitUniqSupply $ spec_uniq_supply st - put $ st { spec_uniq_supply = us2 } - return us1 - - getUniqueM - = SpecM $ do st <- get - let (u,us') = takeUniqFromSupply $ spec_uniq_supply st - put $ st { spec_uniq_supply = us' } - return u - -instance HasDynFlags SpecM where - getDynFlags = SpecM $ liftM spec_dflags get - -instance HasModule SpecM where - getModule = SpecM $ liftM spec_module get - -runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a -runSpecM dflags this_mod (SpecM spec) - = do us <- getUniqueSupplyM - let initialState = SpecState { - spec_uniq_supply = us, - spec_module = this_mod, - spec_dflags = dflags - } - return $ evalState spec initialState - -mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) -mapAndCombineSM _ [] = return ([], emptyUDs) -mapAndCombineSM f (x:xs) = do (y, uds1) <- f x - (ys, uds2) <- mapAndCombineSM f xs - return (y:ys, uds1 `plusUDs` uds2) - -extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv -extendTvSubstList env tv_binds - = env { se_subst = CoreSubst.extendTvSubstList (se_subst env) tv_binds } - -substTy :: SpecEnv -> Type -> Type -substTy env ty = CoreSubst.substTy (se_subst env) ty - -substCo :: SpecEnv -> Coercion -> Coercion -substCo env co = CoreSubst.substCo (se_subst env) co - -substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr) -substBndr env bs = case CoreSubst.substBndr (se_subst env) bs of - (subst', bs') -> (env { se_subst = subst' }, bs') - -substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr]) -substBndrs env bs = case CoreSubst.substBndrs (se_subst env) bs of - (subst', bs') -> (env { se_subst = subst' }, bs') - -cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind) --- Clone the binders of the bind; return new bind with the cloned binders --- Return the substitution to use for RHSs, and the one to use for the body -cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs) - = do { us <- getUniqueSupplyM - ; let (subst', bndr') = CoreSubst.cloneIdBndr subst us bndr - interesting' | interestingDict env rhs - = interesting `extendVarSet` bndr' - | otherwise = interesting - ; return (env, env { se_subst = subst', se_interesting = interesting' } - , NonRec bndr' rhs) } - -cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs) - = do { us <- getUniqueSupplyM - ; let (subst', bndrs') = CoreSubst.cloneRecIdBndrs subst us (map fst pairs) - env' = env { se_subst = subst' - , se_interesting = interesting `extendVarSetList` - [ v | (v,r) <- pairs, interestingDict env r ] } - ; return (env', env', Rec (bndrs' `zip` map snd pairs)) } - -newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr --- Make up completely fresh binders for the dictionaries --- Their bindings are going to float outwards -newDictBndr env b = do { uniq <- getUniqueM - ; let n = idName b - ty' = substTy env (idType b) - ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) } - -newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id - -- Give the new Id a similar occurrence name to the old one -newSpecIdSM old_id new_ty join_arity_maybe - = do { uniq <- getUniqueM - ; let name = idName old_id - new_occ = mkSpecOcc (nameOccName name) - new_id = mkUserLocalOrCoVar new_occ uniq new_ty (getSrcSpan name) - `asJoinId_maybe` join_arity_maybe - ; return new_id } - -{- - Old (but interesting) stuff about unboxed bindings - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -What should we do when a value is specialised to a *strict* unboxed value? - - map_*_* f (x:xs) = let h = f x - t = map f xs - in h:t - -Could convert let to case: - - map_*_Int# f (x:xs) = case f x of h# -> - let t = map f xs - in h#:t - -This may be undesirable since it forces evaluation here, but the value -may not be used in all branches of the body. In the general case this -transformation is impossible since the mutual recursion in a letrec -cannot be expressed as a case. - -There is also a problem with top-level unboxed values, since our -implementation cannot handle unboxed values at the top level. - -Solution: Lift the binding of the unboxed value and extract it when it -is used: - - map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h# - t = map f xs - in case h of - _Lift h# -> h#:t - -Now give it to the simplifier and the _Lifting will be optimised away. - -The benefit is that we have given the specialised "unboxed" values a -very simple lifted semantics and then leave it up to the simplifier to -optimise it --- knowing that the overheads will be removed in nearly -all cases. - -In particular, the value will only be evaluated in the branches of the -program which use it, rather than being forced at the point where the -value is bound. For example: - - filtermap_*_* p f (x:xs) - = let h = f x - t = ... - in case p x of - True -> h:t - False -> t - ==> - filtermap_*_Int# p f (x:xs) - = let h = case (f x) of h# -> _Lift h# - t = ... - in case p x of - True -> case h of _Lift h# - -> h#:t - False -> t - -The binding for h can still be inlined in the one branch and the -_Lifting eliminated. - - -Question: When won't the _Lifting be eliminated? - -Answer: When they at the top-level (where it is necessary) or when -inlining would duplicate work (or possibly code depending on -options). However, the _Lifting will still be eliminated if the -strictness analyser deems the lifted binding strict. --} diff --git a/stgSyn/CoreToStg.hs b/stgSyn/CoreToStg.hs deleted file mode 100644 --- a/stgSyn/CoreToStg.hs +++ /dev/null @@ -1,1025 +0,0 @@ -{-# LANGUAGE CPP #-} - --- --- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 --- - --------------------------------------------------------------- --- Converting Core to STG Syntax --------------------------------------------------------------- - --- And, as we have the info in hand, we may convert some lets to --- let-no-escapes. - -module CoreToStg ( coreToStg, coreExprToStg ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreUtils ( exprType, findDefault, isJoinBind ) -import CoreArity ( manifestArity ) -import StgSyn - -import Type -import RepType -import TyCon -import MkId ( coercionTokenId ) -import Id -import IdInfo -import DataCon -import CostCentre ( noCCS ) -import VarEnv -import Module -import Name ( isExternalName, nameOccName ) -import OccName ( occNameFS ) -import BasicTypes ( Arity ) -import TysWiredIn ( unboxedUnitDataCon ) -import Literal -import Outputable -import MonadUtils -import FastString -import Util -import DynFlags -import ForeignCall -import Demand ( isUsedOnce ) -import PrimOp ( PrimCall(..) ) -import UniqFM - -import Data.Maybe (isJust, fromMaybe) -import Control.Monad (liftM, ap) - --- Note [Live vs free] --- ~~~~~~~~~~~~~~~~~~~ --- --- The two are not the same. Liveness is an operational property rather --- than a semantic one. A variable is live at a particular execution --- point if it can be referred to directly again. In particular, a dead --- variable's stack slot (if it has one): --- --- - should be stubbed to avoid space leaks, and --- - may be reused for something else. --- --- There ought to be a better way to say this. Here are some examples: --- --- let v = [q] \[x] -> e --- in --- ...v... (but no q's) --- --- Just after the `in', v is live, but q is dead. If the whole of that --- let expression was enclosed in a case expression, thus: --- --- case (let v = [q] \[x] -> e in ...v...) of --- alts[...q...] --- --- (ie `alts' mention `q'), then `q' is live even after the `in'; because --- we'll return later to the `alts' and need it. --- --- Let-no-escapes make this a bit more interesting: --- --- let-no-escape v = [q] \ [x] -> e --- in --- ...v... --- --- Here, `q' is still live at the `in', because `v' is represented not by --- a closure but by the current stack state. In other words, if `v' is --- live then so is `q'. Furthermore, if `e' mentions an enclosing --- let-no-escaped variable, then its free variables are also live if `v' is. - --- Note [What are these SRTs all about?] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Consider the Core program, --- --- fibs = go 1 1 --- where go a b = let c = a + c --- in c : go b c --- add x = map (\y -> x*y) fibs --- --- In this case we have a CAF, 'fibs', which is quite large after evaluation and --- has only one possible user, 'add'. Consequently, we want to ensure that when --- all references to 'add' die we can garbage collect any bit of 'fibs' that we --- have evaluated. --- --- However, how do we know whether there are any references to 'fibs' still --- around? Afterall, the only reference to it is buried in the code generated --- for 'add'. The answer is that we record the CAFs referred to by a definition --- in its info table, namely a part of it known as the Static Reference Table --- (SRT). --- --- Since SRTs are so common, we use a special compact encoding for them in: we --- produce one table containing a list of CAFs in a module and then include a --- bitmap in each info table describing which entries of this table the closure --- references. --- --- See also: Commentary/Rts/Storage/GC/CAFs on the GHC Wiki. - --- Note [Collecting live CAF info] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- In this pass we also collect information on which CAFs are live. --- --- A top-level Id has CafInfo, which is --- --- - MayHaveCafRefs, if it may refer indirectly to --- one or more CAFs, or --- - NoCafRefs if it definitely doesn't --- --- The CafInfo has already been calculated during the CoreTidy pass. --- --- During CoreToStg, we then pin onto each binding and case expression, a --- list of Ids which represents the "live" CAFs at that point. The meaning --- of "live" here is the same as for live variables, see above (which is --- why it's convenient to collect CAF information here rather than elsewhere). --- --- The later SRT pass takes these lists of Ids and uses them to construct --- the actual nested SRTs, and replaces the lists of Ids with (offset,length) --- pairs. - --- Note [What is a non-escaping let] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- NB: Nowadays this is recognized by the occurrence analyser by turning a --- "non-escaping let" into a join point. The following is then an operational --- account of join points. --- --- Consider: --- --- let x = fvs \ args -> e --- in --- if ... then x else --- if ... then x else ... --- --- `x' is used twice (so we probably can't unfold it), but when it is --- entered, the stack is deeper than it was when the definition of `x' --- happened. Specifically, if instead of allocating a closure for `x', --- we saved all `x's fvs on the stack, and remembered the stack depth at --- that moment, then whenever we enter `x' we can simply set the stack --- pointer(s) to these remembered (compile-time-fixed) values, and jump --- to the code for `x'. --- --- All of this is provided x is: --- 1. non-updatable; --- 2. guaranteed to be entered before the stack retreats -- ie x is not --- buried in a heap-allocated closure, or passed as an argument to --- something; --- 3. all the enters have exactly the right number of arguments, --- no more no less; --- 4. all the enters are tail calls; that is, they return to the --- caller enclosing the definition of `x'. --- --- Under these circumstances we say that `x' is non-escaping. --- --- An example of when (4) does not hold: --- --- let x = ... --- in case x of ...alts... --- --- Here, `x' is certainly entered only when the stack is deeper than when --- `x' is defined, but here it must return to ...alts... So we can't just --- adjust the stack down to `x''s recalled points, because that would lost --- alts' context. --- --- Things can get a little more complicated. Consider: --- --- let y = ... --- in let x = fvs \ args -> ...y... --- in ...x... --- --- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a --- non-escaping way in ...y..., then `y' is non-escaping. --- --- `x' can even be recursive! Eg: --- --- letrec x = [y] \ [v] -> if v then x True else ... --- in --- ...(x b)... - --- -------------------------------------------------------------- --- Setting variable info: top-level, binds, RHSs --- -------------------------------------------------------------- - -coreToStg :: DynFlags -> Module -> CoreProgram -> [StgTopBinding] -coreToStg dflags this_mod pgm - = pgm' - where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm - -coreExprToStg :: CoreExpr -> StgExpr -coreExprToStg expr - = new_expr where (new_expr,_) = initCts emptyVarEnv (coreToStgExpr expr) - - -coreTopBindsToStg - :: DynFlags - -> Module - -> IdEnv HowBound -- environment for the bindings - -> CoreProgram - -> (IdEnv HowBound, FreeVarsInfo, [StgTopBinding]) - -coreTopBindsToStg _ _ env [] = (env, emptyFVInfo, []) -coreTopBindsToStg dflags this_mod env (b:bs) - = (env2, fvs2, b':bs') - where - -- Notice the mutually-recursive "knot" here: - -- env accumulates down the list of binds, - -- fvs accumulates upwards - (env1, fvs2, b' ) = coreTopBindToStg dflags this_mod env fvs1 b - (env2, fvs1, bs') = coreTopBindsToStg dflags this_mod env1 bs - -coreTopBindToStg - :: DynFlags - -> Module - -> IdEnv HowBound - -> FreeVarsInfo -- Info about the body - -> CoreBind - -> (IdEnv HowBound, FreeVarsInfo, StgTopBinding) - -coreTopBindToStg _ _ env body_fvs (NonRec id (Lit (MachStr str))) - -- top-level string literal - = let - env' = extendVarEnv env id how_bound - how_bound = LetBound TopLet 0 - in (env', body_fvs, StgTopStringLit id str) - -coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs) - = let - env' = extendVarEnv env id how_bound - how_bound = LetBound TopLet $! manifestArity rhs - - (stg_rhs, fvs') = - initCts env $ do - (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs) - return (stg_rhs, fvs') - - bind = StgTopLifted $ StgNonRec id stg_rhs - in - ASSERT2(consistentCafInfo id bind, ppr id ) - -- NB: previously the assertion printed 'rhs' and 'bind' - -- as well as 'id', but that led to a black hole - -- where printing the assertion error tripped the - -- assertion again! - (env', fvs' `unionFVInfo` body_fvs, bind) - -coreTopBindToStg dflags this_mod env body_fvs (Rec pairs) - = ASSERT( not (null pairs) ) - let - binders = map fst pairs - - extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) - | (b, rhs) <- pairs ] - env' = extendVarEnvList env extra_env' - - (stg_rhss, fvs') - = initCts env' $ do - (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags this_mod body_fvs) pairs - let fvs' = unionFVInfos fvss' - return (stg_rhss, fvs') - - bind = StgTopLifted $ StgRec (zip binders stg_rhss) - in - ASSERT2(consistentCafInfo (head binders) bind, ppr binders) - (env', fvs' `unionFVInfo` body_fvs, bind) - - --- Assertion helper: this checks that the CafInfo on the Id matches --- what CoreToStg has figured out about the binding's SRT. The --- CafInfo will be exact in all cases except when CorePrep has --- floated out a binding, in which case it will be approximate. -consistentCafInfo :: Id -> GenStgTopBinding Var Id -> Bool -consistentCafInfo id bind - = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy ) - safe - where - safe = id_marked_caffy || not binding_is_caffy - exact = id_marked_caffy == binding_is_caffy - id_marked_caffy = mayHaveCafRefs (idCafInfo id) - binding_is_caffy = topStgBindHasCafRefs bind - is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat" - -coreToTopStgRhs - :: DynFlags - -> Module - -> FreeVarsInfo -- Free var info for the scope of the binding - -> (Id,CoreExpr) - -> CtsM (StgRhs, FreeVarsInfo) - -coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs) - = do { (new_rhs, rhs_fvs) <- coreToStgExpr rhs - - ; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs bndr bndr_info new_rhs - stg_arity = stgRhsArity stg_rhs - ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, - rhs_fvs) } - where - bndr_info = lookupFVInfo scope_fv_info bndr - - -- It's vital that the arity on a top-level Id matches - -- the arity of the generated STG binding, else an importing - -- module will use the wrong calling convention - -- (Trac #2844 was an example where this happened) - -- NB1: we can't move the assertion further out without - -- blocking the "knot" tied in coreTopBindsToStg - -- NB2: the arity check is only needed for Ids with External - -- Names, because they are externally visible. The CorePrep - -- pass introduces "sat" things with Local Names and does - -- not bother to set their Arity info, so don't fail for those - arity_ok stg_arity - | isExternalName (idName bndr) = id_arity == stg_arity - | otherwise = True - id_arity = idArity bndr - mk_arity_msg stg_arity - = vcat [ppr bndr, - text "Id arity:" <+> ppr id_arity, - text "STG arity:" <+> ppr stg_arity] - -mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo - -> Id -> StgBinderInfo -> StgExpr - -> StgRhs - -mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable - -- Dynamic StgConApps are updatable - where con_updateable con args = isDllConApp dflags this_mod con args - --- --------------------------------------------------------------------------- --- Expressions --- --------------------------------------------------------------------------- - -coreToStgExpr - :: CoreExpr - -> CtsM (StgExpr, -- Decorated STG expr - FreeVarsInfo) -- Its free vars (NB free, not live) - --- The second and third components can be derived in a simple bottom up pass, not --- dependent on any decisions about which variables will be let-no-escaped or --- not. The first component, that is, the decorated expression, may then depend --- on these components, but it in turn is not scrutinised as the basis for any --- decisions. Hence no black holes. - --- No LitInteger's should be left by the time this is called. CorePrep --- should have converted them all to a real core representation. -coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger" -coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo) -coreToStgExpr (Var v) = coreToStgApp Nothing v [] [] -coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] [] - -coreToStgExpr expr@(App _ _) - = coreToStgApp Nothing f args ticks - where - (f, args, ticks) = myCollectArgs expr - -coreToStgExpr expr@(Lam _ _) - = let - (args, body) = myCollectBinders expr - args' = filterStgBinders args - in - extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do - (body, body_fvs) <- coreToStgExpr body - let - fvs = args' `minusFVBinders` body_fvs - result_expr | null args' = body - | otherwise = StgLam args' body - - return (result_expr, fvs) - -coreToStgExpr (Tick tick expr) - = do case tick of - HpcTick{} -> return () - ProfNote{} -> return () - SourceNote{} -> return () - Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen" - (expr2, fvs) <- coreToStgExpr expr - return (StgTick tick expr2, fvs) - -coreToStgExpr (Cast expr _) - = coreToStgExpr expr - --- Cases require a little more real work. - -coreToStgExpr (Case scrut _ _ []) - = coreToStgExpr scrut - -- See Note [Empty case alternatives] in CoreSyn If the case - -- alternatives are empty, the scrutinee must diverge or raise an - -- exception, so we can just dive into it. - -- - -- Of course this may seg-fault if the scrutinee *does* return. A - -- belt-and-braces approach would be to move this case into the - -- code generator, and put a return point anyway that calls a - -- runtime system error function. - - -coreToStgExpr (Case scrut bndr _ alts) = do - (alts2, alts_fvs) - <- extendVarEnvCts [(bndr, LambdaBound)] $ do - (alts2, fvs_s) <- mapAndUnzipM vars_alt alts - return ( alts2, - unionFVInfos fvs_s ) - let - -- Determine whether the default binder is dead or not - -- This helps the code generator to avoid generating an assignment - -- for the case binder (is extremely rare cases) ToDo: remove. - bndr' | bndr `elementOfFVInfo` alts_fvs = bndr - | otherwise = bndr `setIdOccInfo` IAmDead - - -- Don't consider the default binder as being 'live in alts', - -- since this is from the point of view of the case expr, where - -- the default binder is not free. - alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs - - -- We tell the scrutinee that everything - -- live in the alts is live in it, too. - (scrut2, scrut_fvs) <- coreToStgExpr scrut - - return ( - StgCase scrut2 bndr' (mkStgAltType bndr alts) alts2, - scrut_fvs `unionFVInfo` alts_fvs_wo_bndr - ) - where - vars_alt (con, binders, rhs) - | DataAlt c <- con, c == unboxedUnitDataCon - = -- This case is a bit smelly. - -- See Note [Nullary unboxed tuple] in Type.hs - -- where a nullary tuple is mapped to (State# World#) - ASSERT( null binders ) - do { (rhs2, rhs_fvs) <- coreToStgExpr rhs - ; return ((DEFAULT, [], rhs2), rhs_fvs) } - | otherwise - = let -- Remove type variables - binders' = filterStgBinders binders - in - extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do - (rhs2, rhs_fvs) <- coreToStgExpr rhs - return ( (con, binders', rhs2), - binders' `minusFVBinders` rhs_fvs ) - -coreToStgExpr (Let bind body) = do - coreToStgLet bind body - -coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) - -mkStgAltType :: Id -> [CoreAlt] -> AltType -mkStgAltType bndr alts - | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty - = MultiValAlt (length prim_reps) -- always use MultiValAlt for unboxed tuples - - | otherwise - = case prim_reps of - [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of - Just tc - | isAbstractTyCon tc -> look_for_better_tycon - | isAlgTyCon tc -> AlgAlt tc - | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) - PolyAlt - Nothing -> PolyAlt - [unlifted] -> PrimAlt unlifted - not_unary -> MultiValAlt (length not_unary) - where - bndr_ty = idType bndr - prim_reps = typePrimRep bndr_ty - - _is_poly_alt_tycon tc - = isFunTyCon tc - || isPrimTyCon tc -- "Any" is lifted but primitive - || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict - -- function application where argument has a - -- type-family type - - -- Sometimes, the TyCon is a AbstractTyCon which may not have any - -- constructors inside it. Then we may get a better TyCon by - -- grabbing the one from a constructor alternative - -- if one exists. - look_for_better_tycon - | ((DataAlt con, _, _) : _) <- data_alts = - AlgAlt (dataConTyCon con) - | otherwise = - ASSERT(null data_alts) - PolyAlt - where - (data_alts, _deflt) = findDefault alts - --- --------------------------------------------------------------------------- --- Applications --- --------------------------------------------------------------------------- - -coreToStgApp - :: Maybe UpdateFlag -- Just upd <=> this application is - -- the rhs of a thunk binding - -- x = [...] \upd [] -> the_app - -- with specified update flag - -> Id -- Function - -> [CoreArg] -- Arguments - -> [Tickish Id] -- Debug ticks - -> CtsM (StgExpr, FreeVarsInfo) - - -coreToStgApp _ f args ticks = do - (args', args_fvs, ticks') <- coreToStgArgs args - how_bound <- lookupVarCts f - - let - n_val_args = valArgCount args - not_letrec_bound = not (isLetBound how_bound) - fun_fvs = singletonFVInfo f how_bound fun_occ - -- e.g. (f :: a -> int) (x :: a) - -- Here the free variables are "f", "x" AND the type variable "a" - -- coreToStgArgs will deal with the arguments recursively - - -- Mostly, the arity info of a function is in the fn's IdInfo - -- But new bindings introduced by CoreSat may not have no - -- arity info; it would do us no good anyway. For example: - -- let f = \ab -> e in f - -- No point in having correct arity info for f! - -- Hence the hasArity stuff below. - -- NB: f_arity is only consulted for LetBound things - f_arity = stgArity f how_bound - saturated = f_arity <= n_val_args - - fun_occ - | not_letrec_bound = noBinderInfo -- Uninteresting variable - | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call - | otherwise = stgUnsatOcc -- Unsaturated function or thunk - - res_ty = exprType (mkApps (Var f) args) - app = case idDetails f of - DataConWorkId dc - | saturated -> StgConApp dc args' - (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) - - -- Some primitive operator that might be implemented as a library call. - PrimOpId op -> ASSERT( saturated ) - StgOpApp (StgPrimOp op) args' res_ty - - -- A call to some primitive Cmm function. - FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True) - PrimCallConv _)) - -> ASSERT( saturated ) - StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty - - -- A regular foreign call. - FCallId call -> ASSERT( saturated ) - StgOpApp (StgFCallOp call (idUnique f)) args' res_ty - - TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') - _other -> StgApp f args' - fvs = fun_fvs `unionFVInfo` args_fvs - - tapp = foldr StgTick app (ticks ++ ticks') - - -- Forcing these fixes a leak in the code generator, noticed while - -- profiling for trac #4367 - app `seq` fvs `seq` return ( - tapp, - fvs - ) - - - --- --------------------------------------------------------------------------- --- Argument lists --- This is the guy that turns applications into A-normal form --- --------------------------------------------------------------------------- - -coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], FreeVarsInfo, [Tickish Id]) -coreToStgArgs [] - = return ([], emptyFVInfo, []) - -coreToStgArgs (Type _ : args) = do -- Type argument - (args', fvs, ts) <- coreToStgArgs args - return (args', fvs, ts) - -coreToStgArgs (Coercion _ : args) -- Coercion argument; replace with place holder - = do { (args', fvs, ts) <- coreToStgArgs args - ; return (StgVarArg coercionTokenId : args', fvs, ts) } - -coreToStgArgs (Tick t e : args) - = ASSERT( not (tickishIsCode t) ) - do { (args', fvs, ts) <- coreToStgArgs (e : args) - ; return (args', fvs, t:ts) } - -coreToStgArgs (arg : args) = do -- Non-type argument - (stg_args, args_fvs, ticks) <- coreToStgArgs args - (arg', arg_fvs) <- coreToStgExpr arg - let - fvs = args_fvs `unionFVInfo` arg_fvs - - (aticks, arg'') = stripStgTicksTop tickishFloatable arg' - stg_arg = case arg'' of - StgApp v [] -> StgVarArg v - StgConApp con [] _ -> StgVarArg (dataConWorkId con) - StgLit lit -> StgLitArg lit - _ -> pprPanic "coreToStgArgs" (ppr arg) - - -- WARNING: what if we have an argument like (v `cast` co) - -- where 'co' changes the representation type? - -- (This really only happens if co is unsafe.) - -- Then all the getArgAmode stuff in CgBindery will set the - -- cg_rep of the CgIdInfo based on the type of v, rather - -- than the type of 'co'. - -- This matters particularly when the function is a primop - -- or foreign call. - -- Wanted: a better solution than this hacky warning - let - arg_ty = exprType arg - stg_arg_ty = stgArgType stg_arg - bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty)) - || (typePrimRep arg_ty /= typePrimRep stg_arg_ty) - -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted), - -- and pass it to a function expecting an HValue (arg_ty). This is ok because - -- we can treat an unlifted value as lifted. But the other way round - -- we complain. - -- We also want to check if a pointer is cast to a non-ptr etc - - WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg ) - return (stg_arg : stg_args, fvs, ticks ++ aticks) - - --- --------------------------------------------------------------------------- --- The magic for lets: --- --------------------------------------------------------------------------- - -coreToStgLet - :: CoreBind -- bindings - -> CoreExpr -- body - -> CtsM (StgExpr, -- new let - FreeVarsInfo) -- variables free in the whole let - -coreToStgLet bind body = do - (bind2, bind_fvs, - body2, body_fvs) - <- mfix $ \ ~(_, _, _, rec_body_fvs) -> do - - ( bind2, bind_fvs, env_ext) - <- vars_bind rec_body_fvs bind - - -- Do the body - extendVarEnvCts env_ext $ do - (body2, body_fvs) <- coreToStgExpr body - - return (bind2, bind_fvs, - body2, body_fvs) - - - -- Compute the new let-expression - let - new_let | isJoinBind bind = StgLetNoEscape bind2 body2 - | otherwise = StgLet bind2 body2 - - free_in_whole_let - = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs) - - return ( - new_let, - free_in_whole_let - ) - where - binders = bindersOf bind - - mk_binding binder rhs - = (binder, LetBound NestedLet (manifestArity rhs)) - - vars_bind :: FreeVarsInfo -- Free var info for body of binding - -> CoreBind - -> CtsM (StgBinding, - FreeVarsInfo, - [(Id, HowBound)]) -- extension to environment - - - vars_bind body_fvs (NonRec binder rhs) = do - (rhs2, bind_fvs) <- coreToStgRhs body_fvs (binder,rhs) - let - env_ext_item = mk_binding binder rhs - - return (StgNonRec binder rhs2, - bind_fvs, [env_ext_item]) - - - vars_bind body_fvs (Rec pairs) - = mfix $ \ ~(_, rec_rhs_fvs, _) -> - let - rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs - binders = map fst pairs - env_ext = [ mk_binding b rhs - | (b,rhs) <- pairs ] - in - extendVarEnvCts env_ext $ do - (rhss2, fvss) - <- mapAndUnzipM (coreToStgRhs rec_scope_fvs) pairs - let - bind_fvs = unionFVInfos fvss - - return (StgRec (binders `zip` rhss2), - bind_fvs, env_ext) - -coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding - -> (Id,CoreExpr) - -> CtsM (StgRhs, FreeVarsInfo) - -coreToStgRhs scope_fv_info (bndr, rhs) = do - (new_rhs, rhs_fvs) <- coreToStgExpr rhs - return (mkStgRhs rhs_fvs bndr bndr_info new_rhs, rhs_fvs) - where - bndr_info = lookupFVInfo scope_fv_info bndr - -mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs -mkStgRhs = mkStgRhs' con_updateable - where con_updateable _ _ = False - -mkStgRhs' :: (DataCon -> [StgArg] -> Bool) - -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs -mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs - | StgLam bndrs body <- rhs - = StgRhsClosure noCCS binder_info - (getFVs rhs_fvs) - ReEntrant - bndrs body - | isJoinId bndr -- must be nullary join point - = ASSERT(idJoinArity bndr == 0) - StgRhsClosure noCCS binder_info - (getFVs rhs_fvs) - ReEntrant -- ignored for LNE - [] rhs - | StgConApp con args _ <- unticked_rhs - , not (con_updateable con args) - = -- CorePrep does this right, but just to make sure - ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con) - , ppr bndr $$ ppr con $$ ppr args) - StgRhsCon noCCS con args - | otherwise - = StgRhsClosure noCCS binder_info - (getFVs rhs_fvs) - upd_flag [] rhs - where - - (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs - - upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable - - {- - SDM: disabled. Eval/Apply can't handle functions with arity zero very - well; and making these into simple non-updatable thunks breaks other - assumptions (namely that they will be entered only once). - - upd_flag | isPAP env rhs = ReEntrant - | otherwise = Updatable - --- Detect thunks which will reduce immediately to PAPs, and make them --- non-updatable. This has several advantages: --- --- - the non-updatable thunk behaves exactly like the PAP, --- --- - the thunk is more efficient to enter, because it is --- specialised to the task. --- --- - we save one update frame, one stg_update_PAP, one update --- and lots of PAP_enters. --- --- - in the case where the thunk is top-level, we save building --- a black hole and furthermore the thunk isn't considered to --- be a CAF any more, so it doesn't appear in any SRTs. --- --- We do it here, because the arity information is accurate, and we need --- to do it before the SRT pass to save the SRT entries associated with --- any top-level PAPs. - -isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args - where - arity = stgArity f (lookupBinding env f) -isPAP env _ = False - --} - -{- ToDo: - upd = if isOnceDem dem - then (if isNotTop toplev - then SingleEntry -- HA! Paydirt for "dem" - else - (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $ - Updatable) - else Updatable - -- For now we forbid SingleEntry CAFs; they tickle the - -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, - -- and I don't understand why. There's only one SE_CAF (well, - -- only one that tickled a great gaping bug in an earlier attempt - -- at ClosureInfo.getEntryConvention) in the whole of nofib, - -- specifically Main.lvl6 in spectral/cryptarithm2. - -- So no great loss. KSW 2000-07. --} - --- --------------------------------------------------------------------------- --- A monad for the core-to-STG pass --- --------------------------------------------------------------------------- - --- There's a lot of stuff to pass around, so we use this CtsM --- ("core-to-STG monad") monad to help. All the stuff here is only passed --- *down*. - -newtype CtsM a = CtsM - { unCtsM :: IdEnv HowBound - -> a - } - -data HowBound - = ImportBound -- Used only as a response to lookupBinding; never - -- exists in the range of the (IdEnv HowBound) - - | LetBound -- A let(rec) in this module - LetInfo -- Whether top level or nested - Arity -- Its arity (local Ids don't have arity info at this point) - - | LambdaBound -- Used for both lambda and case - deriving (Eq) - -data LetInfo - = TopLet -- top level things - | NestedLet - deriving (Eq) - -isLetBound :: HowBound -> Bool -isLetBound (LetBound _ _) = True -isLetBound _ = False - -topLevelBound :: HowBound -> Bool -topLevelBound ImportBound = True -topLevelBound (LetBound TopLet _) = True -topLevelBound _ = False - --- For a let(rec)-bound variable, x, we record LiveInfo, the set of --- variables that are live if x is live. This LiveInfo comprises --- (a) dynamic live variables (ones with a non-top-level binding) --- (b) static live variabes (CAFs or things that refer to CAFs) --- --- For "normal" variables (a) is just x alone. If x is a let-no-escaped --- variable then x is represented by a code pointer and a stack pointer --- (well, one for each stack). So all of the variables needed in the --- execution of x are live if x is, and are therefore recorded in the --- LetBound constructor; x itself *is* included. --- --- The set of dynamic live variables is guaranteed ot have no further --- let-no-escaped variables in it. - --- The std monad functions: - -initCts :: IdEnv HowBound -> CtsM a -> a -initCts env m = unCtsM m env - - - -{-# INLINE thenCts #-} -{-# INLINE returnCts #-} - -returnCts :: a -> CtsM a -returnCts e = CtsM $ \_ -> e - -thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b -thenCts m k = CtsM $ \env - -> unCtsM (k (unCtsM m env)) env - -instance Functor CtsM where - fmap = liftM - -instance Applicative CtsM where - pure = returnCts - (<*>) = ap - -instance Monad CtsM where - (>>=) = thenCts - -instance MonadFix CtsM where - mfix expr = CtsM $ \env -> - let result = unCtsM (expr result) env - in result - --- Functions specific to this monad: - -extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a -extendVarEnvCts ids_w_howbound expr - = CtsM $ \env - -> unCtsM expr (extendVarEnvList env ids_w_howbound) - -lookupVarCts :: Id -> CtsM HowBound -lookupVarCts v = CtsM $ \env -> lookupBinding env v - -lookupBinding :: IdEnv HowBound -> Id -> HowBound -lookupBinding env v = case lookupVarEnv env v of - Just xx -> xx - Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound - - --- --------------------------------------------------------------------------- --- Free variable information --- --------------------------------------------------------------------------- - -type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo) - -- The Var is so we can gather up the free variables - -- as a set. - -- - -- The HowBound info just saves repeated lookups; - -- we look up just once when we encounter the occurrence. - -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids - -- Imported Ids without CAF refs are simply - -- not put in the FreeVarsInfo for an expression. - -- See singletonFVInfo and freeVarsToLiveVars - -- - -- StgBinderInfo records how it occurs; notably, we - -- are interested in whether it only occurs in saturated - -- applications, because then we don't need to build a - -- curried version. - -- If f is mapped to noBinderInfo, that means - -- that f *is* mentioned (else it wouldn't be in the - -- IdEnv at all), but perhaps in an unsaturated applications. - -- - -- All case/lambda-bound things are also mapped to - -- noBinderInfo, since we aren't interested in their - -- occurrence info. - -- - -- For ILX we track free var info for type variables too; - -- hence VarEnv not IdEnv - -emptyFVInfo :: FreeVarsInfo -emptyFVInfo = emptyVarEnv - -singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo --- Don't record non-CAF imports at all, to keep free-var sets small -singletonFVInfo id ImportBound info - | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info) - | otherwise = emptyVarEnv -singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info) - -unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo -unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 - -unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo -unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs - -minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo -minusFVBinders vs fv = foldr minusFVBinder fv vs - -minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo -minusFVBinder v fv = fv `delVarEnv` v - -- When removing a binder, remember to add its type variables - -- c.f. CoreFVs.delBinderFV - -elementOfFVInfo :: Id -> FreeVarsInfo -> Bool -elementOfFVInfo id fvs = isJust (lookupVarEnv fvs id) - -lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo --- Find how the given Id is used. --- Externally visible things may be used any old how -lookupFVInfo fvs id - | isExternalName (idName id) = noBinderInfo - | otherwise = case lookupVarEnv fvs id of - Nothing -> noBinderInfo - Just (_,_,info) -> info - --- Non-top-level things only, both type variables and ids -getFVs :: FreeVarsInfo -> [Var] -getFVs fvs = [id | (id, how_bound, _) <- nonDetEltsUFM fvs, - -- It's OK to use nonDetEltsUFM here because we're not aiming for - -- bit-for-bit determinism. - -- See Note [Unique Determinism and code generation] - not (topLevelBound how_bound) ] - -plusFVInfo :: (Var, HowBound, StgBinderInfo) - -> (Var, HowBound, StgBinderInfo) - -> (Var, HowBound, StgBinderInfo) -plusFVInfo (id1,hb1,info1) (id2,hb2,info2) - = ASSERT(id1 == id2 && hb1 == hb2) - (id1, hb1, combineStgBinderInfo info1 info2) - --- Misc. - -filterStgBinders :: [Var] -> [Var] -filterStgBinders bndrs = filter isId bndrs - -myCollectBinders :: Expr Var -> ([Var], Expr Var) -myCollectBinders expr - = go [] expr - where - go bs (Lam b e) = go (b:bs) e - go bs (Cast e _) = go bs e - go bs e = (reverse bs, e) - -myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id]) - -- We assume that we only have variables - -- in the function position by now -myCollectArgs expr - = go expr [] [] - where - go (Var v) as ts = (v, as, ts) - go (App f a) as ts = go f (a:as) ts - go (Tick t e) as ts = ASSERT( all isTypeArg as ) - go e as (t:ts) -- ticks can appear in type apps - go (Cast e _) as ts = go e as ts - go (Lam b e) as ts - | isTyVar b = go e as ts -- Note [Collect args] - go _ _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr) - --- Note [Collect args] --- ~~~~~~~~~~~~~~~~~~~ --- --- This big-lambda case occurred following a rather obscure eta expansion. --- It all seems a bit yukky to me. - -stgArity :: Id -> HowBound -> Arity -stgArity _ (LetBound _ arity) = arity -stgArity f ImportBound = idArity f -stgArity _ LambdaBound = 0 diff --git a/stgSyn/StgLint.hs b/stgSyn/StgLint.hs deleted file mode 100644 --- a/stgSyn/StgLint.hs +++ /dev/null @@ -1,537 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[StgLint]{A ``lint'' pass to check for Stg correctness} --} - -{-# LANGUAGE CPP #-} - -module StgLint ( lintStgTopBindings ) where - -import StgSyn - -import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) -import Id ( Id, idType, isLocalId ) -import VarSet -import DataCon -import CoreSyn ( AltCon(..) ) -import PrimOp ( primOpType ) -import Literal ( literalType ) -import Maybes -import Name ( getSrcLoc ) -import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) -import Type -import RepType -import TyCon -import Util -import SrcLoc -import Outputable -import Control.Monad - -#include "HsVersions.h" - -{- -Checks for - (a) *some* type errors - (b) locally-defined variables used but not defined - - -Note: unless -dverbose-stg is on, display of lint errors will result -in "panic: bOGUS_LVs". - -WARNING: -~~~~~~~~ - -This module has suffered bit-rot; it is likely to yield lint errors -for Stg code that is currently perfectly acceptable for code -generation. Solution: don't use it! (KSW 2000-05). - - -************************************************************************ -* * -\subsection{``lint'' for various constructs} -* * -************************************************************************ - -@lintStgTopBindings@ is the top-level interface function. --} - -lintStgTopBindings :: String -> [StgTopBinding] -> [StgTopBinding] - -lintStgTopBindings whodunnit binds - = {-# SCC "StgLint" #-} - case (initL (lint_binds binds)) of - Nothing -> binds - Just msg -> pprPanic "" (vcat [ - text "*** Stg Lint ErrMsgs: in" <+> - text whodunnit <+> text "***", - msg, - text "*** Offending Program ***", - pprStgTopBindings binds, - text "*** End of Offense ***"]) - where - lint_binds :: [StgTopBinding] -> LintM () - - lint_binds [] = return () - lint_binds (bind:binds) = do - binders <- lint_bind bind - addInScopeVars binders $ - lint_binds binds - - lint_bind (StgTopLifted bind) = lintStgBinds bind - lint_bind (StgTopStringLit v _) = return [v] - -lintStgArg :: StgArg -> LintM (Maybe Type) -lintStgArg (StgLitArg lit) = return (Just (literalType lit)) -lintStgArg (StgVarArg v) = lintStgVar v - -lintStgVar :: Id -> LintM (Maybe Kind) -lintStgVar v = do checkInScope v - return (Just (idType v)) - -lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders -lintStgBinds (StgNonRec binder rhs) = do - lint_binds_help (binder,rhs) - return [binder] - -lintStgBinds (StgRec pairs) - = addInScopeVars binders $ do - mapM_ lint_binds_help pairs - return binders - where - binders = [b | (b,_) <- pairs] - -lint_binds_help :: (Id, StgRhs) -> LintM () -lint_binds_help (binder, rhs) - = addLoc (RhsOf binder) $ do - -- Check the rhs - _maybe_rhs_ty <- lintStgRhs rhs - - -- Check binder doesn't have unlifted type - checkL (not (isUnliftedType binder_ty)) - (mkUnliftedTyMsg binder rhs) - - -- Check match to RHS type - -- Actually we *can't* check the RHS type, because - -- unsafeCoerce means it really might not match at all - -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce... - -- case maybe_rhs_ty of - -- Nothing -> return () - -- Just rhs_ty -> checkTys binder_ty - -- rhs_ty - --- (mkRhsMsg binder rhs_ty) - - return () - where - binder_ty = idType binder - -lintStgRhs :: StgRhs -> LintM (Maybe Type) -- Just ty => type is exact - -lintStgRhs (StgRhsClosure _ _ _ _ [] expr) - = lintStgExpr expr - -lintStgRhs (StgRhsClosure _ _ _ _ binders expr) - = addLoc (LambdaBodyOf binders) $ - addInScopeVars binders $ runMaybeT $ do - body_ty <- MaybeT $ lintStgExpr expr - return (mkFunTys (map idType binders) body_ty) - -lintStgRhs rhs@(StgRhsCon _ con args) = do - -- TODO: Check arg_tys - when (isUnboxedTupleCon con || isUnboxedSumCon con) $ - addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ - ppr rhs) - runMaybeT $ do - arg_tys <- mapM (MaybeT . lintStgArg) args - MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys) - where - con_ty = dataConRepType con - -lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Just ty => type is exact - -lintStgExpr (StgLit l) = return (Just (literalType l)) - -lintStgExpr e@(StgApp fun args) = runMaybeT $ do - fun_ty <- MaybeT $ lintStgVar fun - arg_tys <- mapM (MaybeT . lintStgArg) args - MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e) - -lintStgExpr e@(StgConApp con args _arg_tys) = runMaybeT $ do - -- TODO: Check arg_tys - arg_tys <- mapM (MaybeT . lintStgArg) args - MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e) - where - con_ty = dataConRepType con - -lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do - arg_tys <- mapM (MaybeT . lintStgArg) args - MaybeT $ checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e) - where - op_ty = primOpType op - -lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do - -- We don't have enough type information to check - -- the application for StgFCallOp and StgPrimCallOp; ToDo - _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args - return res_ty - -lintStgExpr (StgLam bndrs _) = do - addErrL (text "Unexpected StgLam" <+> ppr bndrs) - return Nothing - -lintStgExpr (StgLet binds body) = do - binders <- lintStgBinds binds - addLoc (BodyOfLetRec binders) $ - addInScopeVars binders $ - lintStgExpr body - -lintStgExpr (StgLetNoEscape binds body) = do - binders <- lintStgBinds binds - addLoc (BodyOfLetRec binders) $ - addInScopeVars binders $ - lintStgExpr body - -lintStgExpr (StgTick _ expr) = lintStgExpr expr - -lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do - _ <- MaybeT $ lintStgExpr scrut - - in_scope <- MaybeT $ liftM Just $ - case alts_type of - AlgAlt tc -> check_bndr (tyConPrimRep tc) >> return True - PrimAlt rep -> check_bndr [rep] >> return True - MultiValAlt _ -> return False -- Binder is always dead in this case - PolyAlt -> return True - - MaybeT $ addInScopeVars [bndr | in_scope] $ - lintStgAlts alts scrut_ty - where - scrut_ty = idType bndr - scrut_reps = typePrimRep scrut_ty - check_bndr reps = checkL (scrut_reps == reps) bad_bndr - where - bad_bndr = mkDefltMsg bndr reps - -lintStgAlts :: [StgAlt] - -> Type -- Type of scrutinee - -> LintM (Maybe Type) -- Just ty => type is accurage - -lintStgAlts alts scrut_ty = do - maybe_result_tys <- mapM (lintAlt scrut_ty) alts - - -- Check the result types - case catMaybes (maybe_result_tys) of - [] -> return Nothing - - (first_ty:_tys) -> do -- mapM_ check tys - return (Just first_ty) - where - -- check ty = checkTys first_ty ty (mkCaseAltMsg alts) - -- We can't check that the alternatives have the - -- same type, because they don't, with unsafeCoerce# - -lintAlt :: Type -> (AltCon, [Id], StgExpr) -> LintM (Maybe Type) -lintAlt _ (DEFAULT, _, rhs) - = lintStgExpr rhs - -lintAlt scrut_ty (LitAlt lit, _, rhs) = do - checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty) - lintStgExpr rhs - -lintAlt scrut_ty (DataAlt con, args, rhs) = do - case splitTyConApp_maybe scrut_ty of - Just (tycon, tys_applied) | isAlgTyCon tycon && - not (isNewTyCon tycon) -> do - let - cons = tyConDataCons tycon - arg_tys = dataConInstArgTys con tys_applied - -- This does not work for existential constructors - - checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) - checkL (length args == dataConRepArity con) (mkAlgAltMsg3 con args) - when (isVanillaDataCon con) $ - mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args) - return () - _ -> - addErrL (mkAltMsg1 scrut_ty) - - addInScopeVars args $ - lintStgExpr rhs - where - check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg) - - -- elem: yes, the elem-list here can sometimes be long-ish, - -- but as it's use-once, probably not worth doing anything different - -- We give it its own copy, so it isn't overloaded. - elem _ [] = False - elem x (y:ys) = x==y || elem x ys - -{- -************************************************************************ -* * -\subsection[lint-monad]{The Lint monad} -* * -************************************************************************ --} - -newtype LintM a = LintM - { unLintM :: [LintLocInfo] -- Locations - -> IdSet -- Local vars in scope - -> Bag MsgDoc -- Error messages so far - -> (a, Bag MsgDoc) -- Result and error messages (if any) - } - -data LintLocInfo - = RhsOf Id -- The variable bound - | LambdaBodyOf [Id] -- The lambda-binder - | BodyOfLetRec [Id] -- One of the binders - -dumpLoc :: LintLocInfo -> (SrcSpan, SDoc) -dumpLoc (RhsOf v) = - (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' ) -dumpLoc (LambdaBodyOf bs) = - (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' ) - -dumpLoc (BodyOfLetRec bs) = - (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' ) - - -pp_binders :: [Id] -> SDoc -pp_binders bs - = sep (punctuate comma (map pp_binder bs)) - where - pp_binder b - = hsep [ppr b, dcolon, ppr (idType b)] - -initL :: LintM a -> Maybe MsgDoc -initL (LintM m) - = case (m [] emptyVarSet emptyBag) of { (_, errs) -> - if isEmptyBag errs then - Nothing - else - Just (vcat (punctuate blankLine (bagToList errs))) - } - -instance Functor LintM where - fmap = liftM - -instance Applicative LintM where - pure a = LintM $ \_loc _scope errs -> (a, errs) - (<*>) = ap - (*>) = thenL_ - -instance Monad LintM where - (>>=) = thenL - (>>) = (*>) - -thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k = LintM $ \loc scope errs - -> case unLintM m loc scope errs of - (r, errs') -> unLintM (k r) loc scope errs' - -thenL_ :: LintM a -> LintM b -> LintM b -thenL_ m k = LintM $ \loc scope errs - -> case unLintM m loc scope errs of - (_, errs') -> unLintM k loc scope errs' - -checkL :: Bool -> MsgDoc -> LintM () -checkL True _ = return () -checkL False msg = addErrL msg - -addErrL :: MsgDoc -> LintM () -addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc) - -addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc -addErr errs_so_far msg locs - = errs_so_far `snocBag` mk_msg locs - where - mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage SevWarning l (hdr $$ msg) - mk_msg [] = msg - -addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m = LintM $ \loc scope errs - -> unLintM m (extra_loc:loc) scope errs - -addInScopeVars :: [Id] -> LintM a -> LintM a -addInScopeVars ids m = LintM $ \loc scope errs - -> let - new_set = mkVarSet ids - in unLintM m loc (scope `unionVarSet` new_set) errs - -{- -Checking function applications: we only check that the type has the -right *number* of arrows, we don't actually compare the types. This -is because we can't expect the types to be equal - the type -applications and type lambdas that we use to calculate accurate types -have long since disappeared. --} - -checkFunApp :: Type -- The function type - -> [Type] -- The arg type(s) - -> MsgDoc -- Error message - -> LintM (Maybe Type) -- Just ty => result type is accurate - -checkFunApp fun_ty arg_tys msg - = do { case mb_msg of - Just msg -> addErrL msg - Nothing -> return () - ; return mb_ty } - where - (mb_ty, mb_msg) = cfa True fun_ty arg_tys - - cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? - , Maybe MsgDoc) -- Errors? - - cfa accurate fun_ty [] -- Args have run out; that's fine - = (if accurate then Just fun_ty else Nothing, Nothing) - - cfa accurate fun_ty arg_tys@(arg_ty':arg_tys') - | Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty - = if accurate && not (arg_ty `stgEqType` arg_ty') - then (Nothing, Just msg) -- Arg type mismatch - else cfa accurate res_ty arg_tys' - - | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty - = cfa False fun_ty' arg_tys - - | Just (tc,tc_args) <- splitTyConApp_maybe fun_ty - , isNewTyCon tc - = if length tc_args < tyConArity tc - then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg ) - (Nothing, Nothing) -- This is odd, but I've seen it - else cfa False (newTyConInstRhs tc tc_args) arg_tys - - | Just tc <- tyConAppTyCon_maybe fun_ty - , not (isTypeFamilyTyCon tc) -- Definite error - = (Nothing, Just msg) -- Too many args - - | otherwise - = (Nothing, Nothing) - -stgEqType :: Type -> Type -> Bool --- Compare types, but crudely because we have discarded --- both casts and type applications, so types might look --- different but be the same. So reply "True" if in doubt. --- "False" means that the types are definitely different. --- --- Fundamentally this is a losing battle because of unsafeCoerce - -stgEqType orig_ty1 orig_ty2 - = gos orig_ty1 orig_ty2 - where - gos :: Type -> Type -> Bool - gos ty1 ty2 - -- These have no prim rep - | isRuntimeRepKindedTy ty1 && isRuntimeRepKindedTy ty2 - = True - - -- We have a unary type - | [_] <- reps1, [_] <- reps2 - = go ty1 ty2 - - -- In the case of a tuple just compare prim reps - | otherwise - = reps1 == reps2 - where - reps1 = typePrimRep ty1 - reps2 = typePrimRep ty2 - - go :: UnaryType -> UnaryType -> Bool - go ty1 ty2 - | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1 - , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2 - , let res = if tc1 == tc2 - then equalLength tc_args1 tc_args2 - && and (zipWith gos tc_args1 tc_args2) - else -- TyCons don't match; but don't bleat if either is a - -- family TyCon because a coercion might have made it - -- equal to something else - (isFamilyTyCon tc1 || isFamilyTyCon tc2) - = if res then True - else - pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2]) - False - - | otherwise = True -- Conservatively say "fine". - -- Type variables in particular - -checkInScope :: Id -> LintM () -checkInScope id = LintM $ \loc scope errs - -> if isLocalId id && not (id `elemVarSet` scope) then - ((), addErr errs (hsep [ppr id, text "is out of scope"]) loc) - else - ((), errs) - -checkTys :: Type -> Type -> MsgDoc -> LintM () -checkTys ty1 ty2 msg = LintM $ \loc _scope errs - -> if (ty1 `stgEqType` ty2) - then ((), errs) - else ((), addErr errs msg loc) - -_mkCaseAltMsg :: [StgAlt] -> MsgDoc -_mkCaseAltMsg _alts - = ($$) (text "In some case alternatives, type of alternatives not all same:") - (Outputable.empty) -- LATER: ppr alts - -mkDefltMsg :: Id -> [PrimRep] -> MsgDoc -mkDefltMsg bndr reps - = ($$) (text "Binder of a case expression doesn't match representation of scrutinee:") - (ppr bndr $$ ppr (idType bndr) $$ ppr reps) - -mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc -mkFunAppMsg fun_ty arg_tys expr - = vcat [text "In a function application, function type doesn't match arg types:", - hang (text "Function type:") 4 (ppr fun_ty), - hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys)), - hang (text "Expression:") 4 (ppr expr)] - -mkRhsConMsg :: Type -> [Type] -> MsgDoc -mkRhsConMsg fun_ty arg_tys - = vcat [text "In a RHS constructor application, con type doesn't match arg types:", - hang (text "Constructor type:") 4 (ppr fun_ty), - hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys))] - -mkAltMsg1 :: Type -> MsgDoc -mkAltMsg1 ty - = ($$) (text "In a case expression, type of scrutinee does not match patterns") - (ppr ty) - -mkAlgAltMsg2 :: Type -> DataCon -> MsgDoc -mkAlgAltMsg2 ty con - = vcat [ - text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", - ppr ty, - ppr con - ] - -mkAlgAltMsg3 :: DataCon -> [Id] -> MsgDoc -mkAlgAltMsg3 con alts - = vcat [ - text "In some algebraic case alternative, number of arguments doesn't match constructor:", - ppr con, - ppr alts - ] - -mkAlgAltMsg4 :: Type -> Id -> MsgDoc -mkAlgAltMsg4 ty arg - = vcat [ - text "In some algebraic case alternative, type of argument doesn't match data constructor:", - ppr ty, - ppr arg - ] - -_mkRhsMsg :: Id -> Type -> MsgDoc -_mkRhsMsg binder ty - = vcat [hsep [text "The type of this binder doesn't match the type of its RHS:", - ppr binder], - hsep [text "Binder's type:", ppr (idType binder)], - hsep [text "Rhs type:", ppr ty] - ] - -mkUnliftedTyMsg :: Id -> StgRhs -> SDoc -mkUnliftedTyMsg binder rhs - = (text "Let(rec) binder" <+> quotes (ppr binder) <+> - text "has unlifted type" <+> quotes (ppr (idType binder))) - $$ - (text "RHS:" <+> ppr rhs) diff --git a/stgSyn/StgSyn.hs b/stgSyn/StgSyn.hs deleted file mode 100644 --- a/stgSyn/StgSyn.hs +++ /dev/null @@ -1,820 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation} - -This data type represents programs just before code generation (conversion to -@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style -being one that happens to be ideally suited to spineless tagless code -generation. --} - -{-# LANGUAGE CPP #-} - -module StgSyn ( - GenStgArg(..), - - GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), - GenStgAlt, AltType(..), - - UpdateFlag(..), isUpdatable, - - StgBinderInfo, - noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly, - combineStgBinderInfo, - - -- a set of synonyms for the most common (only :-) parameterisation - StgArg, - StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt, - - -- a set of synonyms to distinguish in- and out variants - InStgArg, InStgTopBinding, InStgBinding, InStgExpr, InStgRhs, InStgAlt, - OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt, - - -- StgOp - StgOp(..), - - -- utils - topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, - isDllConApp, - stgArgType, - stripStgTicksTop, - - pprStgBinding, pprStgTopBindings - ) where - -#include "HsVersions.h" - -import CoreSyn ( AltCon, Tickish ) -import CostCentre ( CostCentreStack ) -import Data.ByteString ( ByteString ) -import Data.List ( intersperse ) -import DataCon -import DynFlags -import FastString -import ForeignCall ( ForeignCall ) -import Id -import IdInfo ( mayHaveCafRefs ) -import Literal ( Literal, literalType ) -import Module ( Module ) -import Outputable -import Packages ( isDllName ) -import Platform -import PprCore ( {- instances -} ) -import PrimOp ( PrimOp, PrimCall ) -import TyCon ( PrimRep(..), TyCon ) -import Type ( Type ) -import RepType ( typePrimRep1 ) -import Unique ( Unique ) -import Util - -{- -************************************************************************ -* * -\subsection{@GenStgBinding@} -* * -************************************************************************ - -As usual, expressions are interesting; other things are boring. Here -are the boring things [except note the @GenStgRhs@], parameterised -with respect to binder and occurrence information (just as in -@CoreSyn@): --} - --- | A top-level binding. -data GenStgTopBinding bndr occ --- See Note [CoreSyn top-level string literals] - = StgTopLifted (GenStgBinding bndr occ) - | StgTopStringLit bndr ByteString - -data GenStgBinding bndr occ - = StgNonRec bndr (GenStgRhs bndr occ) - | StgRec [(bndr, GenStgRhs bndr occ)] - -{- -************************************************************************ -* * -\subsection{@GenStgArg@} -* * -************************************************************************ --} - -data GenStgArg occ - = StgVarArg occ - | StgLitArg Literal - --- | Does this constructor application refer to --- anything in a different *Windows* DLL? --- If so, we can't allocate it statically -isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool -isDllConApp dflags this_mod con args - | platformOS (targetPlatform dflags) == OSMinGW32 - = isDllName dflags this_mod (dataConName con) || any is_dll_arg args - | otherwise = False - where - -- NB: typePrimRep1 is legit because any free variables won't have - -- unlifted type (there are no unlifted things at top level) - is_dll_arg :: StgArg -> Bool - is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v)) - && isDllName dflags this_mod (idName v) - is_dll_arg _ = False - --- True of machine addresses; these are the things that don't --- work across DLLs. The key point here is that VoidRep comes --- out False, so that a top level nullary GADT constructor is --- False for isDllConApp --- data T a where --- T1 :: T Int --- gives --- T1 :: forall a. (a~Int) -> T a --- and hence the top-level binding --- $WT1 :: T Int --- $WT1 = T1 Int (Coercion (Refl Int)) --- The coercion argument here gets VoidRep -isAddrRep :: PrimRep -> Bool -isAddrRep AddrRep = True -isAddrRep LiftedRep = True -isAddrRep UnliftedRep = True -isAddrRep _ = False - --- | Type of an @StgArg@ --- --- Very half baked because we have lost the type arguments. -stgArgType :: StgArg -> Type -stgArgType (StgVarArg v) = idType v -stgArgType (StgLitArg lit) = literalType lit - - --- | Strip ticks of a given type from an STG expression -stripStgTicksTop :: (Tickish Id -> Bool) -> StgExpr -> ([Tickish Id], StgExpr) -stripStgTicksTop p = go [] - where go ts (StgTick t e) | p t = go (t:ts) e - go ts other = (reverse ts, other) - - -{- -************************************************************************ -* * -\subsection{STG expressions} -* * -************************************************************************ - -The @GenStgExpr@ data type is parameterised on binder and occurrence -info, as before. - -************************************************************************ -* * -\subsubsection{@GenStgExpr@ application} -* * -************************************************************************ - -An application is of a function to a list of atoms [not expressions]. -Operationally, we want to push the arguments on the stack and call the -function. (If the arguments were expressions, we would have to build -their closures first.) - -There is no constructor for a lone variable; it would appear as -@StgApp var []@. --} - -data GenStgExpr bndr occ - = StgApp - occ -- function - [GenStgArg occ] -- arguments; may be empty - -{- -************************************************************************ -* * -\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications} -* * -************************************************************************ - -There are specialised forms of application, for constructors, -primitives, and literals. --} - - | StgLit Literal - - -- StgConApp is vital for returning unboxed tuples or sums - -- which can't be let-bound first - | StgConApp DataCon - [GenStgArg occ] -- Saturated - [Type] -- See Note [Types in StgConApp] in UnariseStg - - | StgOpApp StgOp -- Primitive op or foreign call - [GenStgArg occ] -- Saturated. - Type -- Result type - -- We need to know this so that we can - -- assign result registers - -{- -************************************************************************ -* * -\subsubsection{@StgLam@} -* * -************************************************************************ - -StgLam is used *only* during CoreToStg's work. Before CoreToStg has -finished it encodes (\x -> e) as (let f = \x -> e in f) --} - - | StgLam - [bndr] - StgExpr -- Body of lambda - -{- -************************************************************************ -* * -\subsubsection{@GenStgExpr@: case-expressions} -* * -************************************************************************ - -This has the same boxed/unboxed business as Core case expressions. --} - - | StgCase - (GenStgExpr bndr occ) - -- the thing to examine - - bndr -- binds the result of evaluating the scrutinee - - AltType - - [GenStgAlt bndr occ] - -- The DEFAULT case is always *first* - -- if it is there at all - -{- -************************************************************************ -* * -\subsubsection{@GenStgExpr@: @let(rec)@-expressions} -* * -************************************************************************ - -The various forms of let(rec)-expression encode most of the -interesting things we want to do. -\begin{enumerate} -\item -\begin{verbatim} -let-closure x = [free-vars] [args] expr -in e -\end{verbatim} -is equivalent to -\begin{verbatim} -let x = (\free-vars -> \args -> expr) free-vars -\end{verbatim} -\tr{args} may be empty (and is for most closures). It isn't under -circumstances like this: -\begin{verbatim} -let x = (\y -> y+z) -\end{verbatim} -This gets mangled to -\begin{verbatim} -let-closure x = [z] [y] (y+z) -\end{verbatim} -The idea is that we compile code for @(y+z)@ in an environment in which -@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an -offset from the stack pointer. - -(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.) - -\item -\begin{verbatim} -let-constructor x = Constructor [args] -in e -\end{verbatim} - -(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.) - -\item -Letrec-expressions are essentially the same deal as -let-closure/let-constructor, so we use a common structure and -distinguish between them with an @is_recursive@ boolean flag. - -\item -\begin{verbatim} -let-unboxed u = an arbitrary arithmetic expression in unboxed values -in e -\end{verbatim} -All the stuff on the RHS must be fully evaluated. -No function calls either! - -(We've backed away from this toward case-expressions with -suitably-magical alts ...) - -\item -~[Advanced stuff here! Not to start with, but makes pattern matching -generate more efficient code.] - -\begin{verbatim} -let-escapes-not fail = expr -in e' -\end{verbatim} -Here the idea is that @e'@ guarantees not to put @fail@ in a data structure, -or pass it to another function. All @e'@ will ever do is tail-call @fail@. -Rather than build a closure for @fail@, all we need do is to record the stack -level at the moment of the @let-escapes-not@; then entering @fail@ is just -a matter of adjusting the stack pointer back down to that point and entering -the code for it. - -Another example: -\begin{verbatim} -f x y = let z = huge-expression in - if y==1 then z else - if y==2 then z else - 1 -\end{verbatim} - -(A let-escapes-not is an @StgLetNoEscape@.) - -\item -We may eventually want: -\begin{verbatim} -let-literal x = Literal -in e -\end{verbatim} -\end{enumerate} - -And so the code for let(rec)-things: --} - - | StgLet - (GenStgBinding bndr occ) -- right hand sides (see below) - (GenStgExpr bndr occ) -- body - - | StgLetNoEscape - (GenStgBinding bndr occ) -- right hand sides (see below) - (GenStgExpr bndr occ) -- body - -{- -%************************************************************************ -%* * -\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations} -%* * -%************************************************************************ - -Finally for @hpc@ expressions we introduce a new STG construct. --} - - | StgTick - (Tickish bndr) - (GenStgExpr bndr occ) -- sub expression - --- END of GenStgExpr - -{- -************************************************************************ -* * -\subsection{STG right-hand sides} -* * -************************************************************************ - -Here's the rest of the interesting stuff for @StgLet@s; the first -flavour is for closures: --} - -data GenStgRhs bndr occ - = StgRhsClosure - CostCentreStack -- CCS to be attached (default is CurrentCCS) - StgBinderInfo -- Info about how this binder is used (see below) - [occ] -- non-global free vars; a list, rather than - -- a set, because order is important - !UpdateFlag -- ReEntrant | Updatable | SingleEntry - [bndr] -- arguments; if empty, then not a function; - -- as above, order is important. - (GenStgExpr bndr occ) -- body - -{- -An example may be in order. Consider: -\begin{verbatim} -let t = \x -> \y -> ... x ... y ... p ... q in e -\end{verbatim} -Pulling out the free vars and stylising somewhat, we get the equivalent: -\begin{verbatim} -let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q -\end{verbatim} -Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are -offsets from @Node@ into the closure, and the code ptr for the closure -will be exactly that in parentheses above. - -The second flavour of right-hand-side is for constructors (simple but important): --} - - | StgRhsCon - CostCentreStack -- CCS to be attached (default is CurrentCCS). - -- Top-level (static) ones will end up with - -- DontCareCCS, because we don't count static - -- data in heap profiles, and we don't set CCCS - -- from static closure. - DataCon -- Constructor. Never an unboxed tuple or sum, as those - -- are not allocated. - [GenStgArg occ] -- Args - -stgRhsArity :: StgRhs -> Int -stgRhsArity (StgRhsClosure _ _ _ _ bndrs _) - = ASSERT( all isId bndrs ) length bndrs - -- The arity never includes type parameters, but they should have gone by now -stgRhsArity (StgRhsCon _ _ _) = 0 - --- Note [CAF consistency] --- ~~~~~~~~~~~~~~~~~~~~~~ --- --- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in --- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with --- reality. --- --- Specifically, if the RHS mentions any Id that itself is marked --- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the --- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble --- is that `TidyPgm` computed the CAF info on the `Id` but some transformations --- have taken place since then. - -topStgBindHasCafRefs :: GenStgTopBinding bndr Id -> Bool -topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs)) - = topRhsHasCafRefs rhs -topStgBindHasCafRefs (StgTopLifted (StgRec binds)) - = any topRhsHasCafRefs (map snd binds) -topStgBindHasCafRefs StgTopStringLit{} - = False - -topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool -topRhsHasCafRefs (StgRhsClosure _ _ _ upd _ body) - = -- See Note [CAF consistency] - isUpdatable upd || exprHasCafRefs body -topRhsHasCafRefs (StgRhsCon _ _ args) - = any stgArgHasCafRefs args - -exprHasCafRefs :: GenStgExpr bndr Id -> Bool -exprHasCafRefs (StgApp f args) - = stgIdHasCafRefs f || any stgArgHasCafRefs args -exprHasCafRefs StgLit{} - = False -exprHasCafRefs (StgConApp _ args _) - = any stgArgHasCafRefs args -exprHasCafRefs (StgOpApp _ args _) - = any stgArgHasCafRefs args -exprHasCafRefs (StgLam _ body) - = exprHasCafRefs body -exprHasCafRefs (StgCase scrt _ _ alts) - = exprHasCafRefs scrt || any altHasCafRefs alts -exprHasCafRefs (StgLet bind body) - = bindHasCafRefs bind || exprHasCafRefs body -exprHasCafRefs (StgLetNoEscape bind body) - = bindHasCafRefs bind || exprHasCafRefs body -exprHasCafRefs (StgTick _ expr) - = exprHasCafRefs expr - -bindHasCafRefs :: GenStgBinding bndr Id -> Bool -bindHasCafRefs (StgNonRec _ rhs) - = rhsHasCafRefs rhs -bindHasCafRefs (StgRec binds) - = any rhsHasCafRefs (map snd binds) - -rhsHasCafRefs :: GenStgRhs bndr Id -> Bool -rhsHasCafRefs (StgRhsClosure _ _ _ _ _ body) - = exprHasCafRefs body -rhsHasCafRefs (StgRhsCon _ _ args) - = any stgArgHasCafRefs args - -altHasCafRefs :: GenStgAlt bndr Id -> Bool -altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs - -stgArgHasCafRefs :: GenStgArg Id -> Bool -stgArgHasCafRefs (StgVarArg id) - = stgIdHasCafRefs id -stgArgHasCafRefs _ - = False - -stgIdHasCafRefs :: Id -> Bool -stgIdHasCafRefs id = - -- We are looking for occurrences of an Id that is bound at top level, and may - -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether - -- imported or defined in this module) are GlobalIds, so the test is easy. - isGlobalId id && mayHaveCafRefs (idCafInfo id) - --- Here's the @StgBinderInfo@ type, and its combining op: - -data StgBinderInfo - = NoStgBinderInfo - | SatCallsOnly -- All occurrences are *saturated* *function* calls - -- This means we don't need to build an info table and - -- slow entry code for the thing - -- Thunks never get this value - -noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo -noBinderInfo = NoStgBinderInfo -stgUnsatOcc = NoStgBinderInfo -stgSatOcc = SatCallsOnly - -satCallsOnly :: StgBinderInfo -> Bool -satCallsOnly SatCallsOnly = True -satCallsOnly NoStgBinderInfo = False - -combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo -combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly -combineStgBinderInfo _ _ = NoStgBinderInfo - --------------- -pp_binder_info :: StgBinderInfo -> SDoc -pp_binder_info NoStgBinderInfo = empty -pp_binder_info SatCallsOnly = text "sat-only" - -{- -************************************************************************ -* * -\subsection[Stg-case-alternatives]{STG case alternatives} -* * -************************************************************************ - -Very like in @CoreSyntax@ (except no type-world stuff). - -The type constructor is guaranteed not to be abstract; that is, we can -see its representation. This is important because the code generator -uses it to determine return conventions etc. But it's not trivial -where there's a module loop involved, because some versions of a type -constructor might not have all the constructors visible. So -mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the -constructors or literals (which are guaranteed to have the Real McCoy) -rather than from the scrutinee type. --} - -type GenStgAlt bndr occ - = (AltCon, -- alts: data constructor, - [bndr], -- constructor's parameters, - GenStgExpr bndr occ) -- ...right-hand side. - -data AltType - = PolyAlt -- Polymorphic (a lifted type variable) - | MultiValAlt Int -- Multi value of this arity (unboxed tuple or sum) - -- the arity could indeed be 1 for unary unboxed tuple - | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts - | PrimAlt PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts - -{- -************************************************************************ -* * -\subsection[Stg]{The Plain STG parameterisation} -* * -************************************************************************ - -This happens to be the only one we use at the moment. --} - -type StgTopBinding = GenStgTopBinding Id Id -type StgBinding = GenStgBinding Id Id -type StgArg = GenStgArg Id -type StgExpr = GenStgExpr Id Id -type StgRhs = GenStgRhs Id Id -type StgAlt = GenStgAlt Id Id - -{- Many passes apply a substitution, and it's very handy to have type - synonyms to remind us whether or not the substitution has been applied. - See CoreSyn for precedence in Core land --} - -type InStgTopBinding = StgTopBinding -type InStgBinding = StgBinding -type InStgArg = StgArg -type InStgExpr = StgExpr -type InStgRhs = StgRhs -type InStgAlt = StgAlt -type OutStgTopBinding = StgTopBinding -type OutStgBinding = StgBinding -type OutStgArg = StgArg -type OutStgExpr = StgExpr -type OutStgRhs = StgRhs -type OutStgAlt = StgAlt - -{- - -************************************************************************ -* * -\subsubsection[UpdateFlag-datatype]{@UpdateFlag@} -* * -************************************************************************ - -This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. - -A @ReEntrant@ closure may be entered multiple times, but should not be -updated or blackholed. An @Updatable@ closure should be updated after -evaluation (and may be blackholed during evaluation). A @SingleEntry@ -closure will only be entered once, and so need not be updated but may -safely be blackholed. --} - -data UpdateFlag = ReEntrant | Updatable | SingleEntry - -instance Outputable UpdateFlag where - ppr u = char $ case u of - ReEntrant -> 'r' - Updatable -> 'u' - SingleEntry -> 's' - -isUpdatable :: UpdateFlag -> Bool -isUpdatable ReEntrant = False -isUpdatable SingleEntry = False -isUpdatable Updatable = True - -{- -************************************************************************ -* * -\subsubsection{StgOp} -* * -************************************************************************ - -An StgOp allows us to group together PrimOps and ForeignCalls. -It's quite useful to move these around together, notably -in StgOpApp and COpStmt. --} - -data StgOp - = StgPrimOp PrimOp - - | StgPrimCallOp PrimCall - - | StgFCallOp ForeignCall Unique - -- The Unique is occasionally needed by the C pretty-printer - -- (which lacks a unique supply), notably when generating a - -- typedef for foreign-export-dynamic - -{- -************************************************************************ -* * -\subsection[Stg-pretty-printing]{Pretty-printing} -* * -************************************************************************ - -Robin Popplestone asked for semi-colon separators on STG binds; here's -hoping he likes terminators instead... Ditto for case alternatives. --} - -pprGenStgTopBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee) - => GenStgTopBinding bndr bdee -> SDoc - -pprGenStgTopBinding (StgTopStringLit bndr str) - = hang (hsep [pprBndr LetBind bndr, equals]) - 4 (pprHsBytes str <> semi) -pprGenStgTopBinding (StgTopLifted bind) - = pprGenStgBinding bind - -pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee) - => GenStgBinding bndr bdee -> SDoc - -pprGenStgBinding (StgNonRec bndr rhs) - = hang (hsep [pprBndr LetBind bndr, equals]) - 4 (ppr rhs <> semi) - -pprGenStgBinding (StgRec pairs) - = vcat $ ifPprDebug (text "{- StgRec (begin) -}") : - map (ppr_bind) pairs ++ [ifPprDebug (text "{- StgRec (end) -}")] - where - ppr_bind (bndr, expr) - = hang (hsep [pprBndr LetBind bndr, equals]) - 4 (ppr expr <> semi) - -pprStgBinding :: StgBinding -> SDoc -pprStgBinding bind = pprGenStgBinding bind - -pprStgTopBindings :: [StgTopBinding] -> SDoc -pprStgTopBindings binds - = vcat $ intersperse blankLine (map pprGenStgTopBinding binds) - -instance (Outputable bdee) => Outputable (GenStgArg bdee) where - ppr = pprStgArg - -instance (OutputableBndr bndr, Outputable bdee, Ord bdee) - => Outputable (GenStgTopBinding bndr bdee) where - ppr = pprGenStgTopBinding - -instance (OutputableBndr bndr, Outputable bdee, Ord bdee) - => Outputable (GenStgBinding bndr bdee) where - ppr = pprGenStgBinding - -instance (OutputableBndr bndr, Outputable bdee, Ord bdee) - => Outputable (GenStgExpr bndr bdee) where - ppr = pprStgExpr - -instance (OutputableBndr bndr, Outputable bdee, Ord bdee) - => Outputable (GenStgRhs bndr bdee) where - ppr rhs = pprStgRhs rhs - -pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc -pprStgArg (StgVarArg var) = ppr var -pprStgArg (StgLitArg con) = ppr con - -pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee) - => GenStgExpr bndr bdee -> SDoc --- special case -pprStgExpr (StgLit lit) = ppr lit - --- general case -pprStgExpr (StgApp func args) - = hang (ppr func) 4 (sep (map (ppr) args)) - -pprStgExpr (StgConApp con args _) - = hsep [ ppr con, brackets (interppSP args) ] - -pprStgExpr (StgOpApp op args _) - = hsep [ pprStgOp op, brackets (interppSP args)] - -pprStgExpr (StgLam bndrs body) - = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs) - <+> text "->", - pprStgExpr body ] - where ppr_list = brackets . fsep . punctuate comma - --- special case: let v = --- in --- let ... --- in --- ... --- --- Very special! Suspicious! (SLPJ) - -{- -pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) - expr@(StgLet _ _)) - = ($$) - (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "), - ppr cc, - pp_binder_info bi, - text " [", ifPprDebug (interppSP free_vars), ptext (sLit "] \\"), - ppr upd_flag, text " [", - interppSP args, char ']']) - 8 (sep [hsep [ppr rhs, text "} in"]])) - (ppr expr) --} - --- special case: let ... in let ... - -pprStgExpr (StgLet bind expr@(StgLet _ _)) - = ($$) - (sep [hang (text "let {") - 2 (hsep [pprGenStgBinding bind, text "} in"])]) - (ppr expr) - --- general case -pprStgExpr (StgLet bind expr) - = sep [hang (text "let {") 2 (pprGenStgBinding bind), - hang (text "} in ") 2 (ppr expr)] - -pprStgExpr (StgLetNoEscape bind expr) - = sep [hang (text "let-no-escape {") - 2 (pprGenStgBinding bind), - hang (text "} in ") - 2 (ppr expr)] - -pprStgExpr (StgTick tickish expr) - = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressTicks dflags - then pprStgExpr expr - else sep [ ppr tickish, pprStgExpr expr ] - - -pprStgExpr (StgCase expr bndr alt_type alts) - = sep [sep [text "case", - nest 4 (hsep [pprStgExpr expr, - ifPprDebug (dcolon <+> ppr alt_type)]), - text "of", pprBndr CaseBind bndr, char '{'], - nest 2 (vcat (map pprStgAlt alts)), - char '}'] - -pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ) - => GenStgAlt bndr occ -> SDoc -pprStgAlt (con, params, expr) - = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"]) - 4 (ppr expr <> semi) - -pprStgOp :: StgOp -> SDoc -pprStgOp (StgPrimOp op) = ppr op -pprStgOp (StgPrimCallOp op)= ppr op -pprStgOp (StgFCallOp op _) = ppr op - -instance Outputable AltType where - ppr PolyAlt = text "Polymorphic" - ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n - ppr (AlgAlt tc) = text "Alg" <+> ppr tc - ppr (PrimAlt tc) = text "Prim" <+> ppr tc - -pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee) - => GenStgRhs bndr bdee -> SDoc - --- special case -pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [])) - = hsep [ ppr cc, - pp_binder_info bi, - brackets (ifPprDebug (ppr free_var)), - text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ] - --- general case -pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body) - = sdocWithDynFlags $ \dflags -> - hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty, - pp_binder_info bi, - ifPprDebug (brackets (interppSP free_vars)), - char '\\' <> ppr upd_flag, brackets (interppSP args)]) - 4 (ppr body) - -pprStgRhs (StgRhsCon cc con args) - = hcat [ ppr cc, - space, ppr con, text "! ", brackets (interppSP args)] diff --git a/stranal/DmdAnal.hs b/stranal/DmdAnal.hs deleted file mode 100644 --- a/stranal/DmdAnal.hs +++ /dev/null @@ -1,1482 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - - - ----------------- - A demand analysis - ----------------- --} - -{-# LANGUAGE CPP #-} - -module DmdAnal ( dmdAnalProgram ) where - -#include "HsVersions.h" - -import DynFlags -import WwLib ( findTypeShape, deepSplitProductType_maybe ) -import Demand -- All of it -import CoreSyn -import CoreSeq ( seqBinds ) -import Outputable -import VarEnv -import BasicTypes -import Data.List -import DataCon -import Id -import CoreUtils ( exprIsHNF, exprType, exprIsTrivial ) -import TyCon -import Type -import Coercion ( Coercion, coVarsOfCo ) -import FamInstEnv -import Util -import Maybes ( isJust ) -import TysWiredIn -import TysPrim ( realWorldStatePrimTy ) -import ErrUtils ( dumpIfSet_dyn ) -import Name ( getName, stableNameCmp ) -import Data.Function ( on ) -import UniqSet - -{- -************************************************************************ -* * -\subsection{Top level stuff} -* * -************************************************************************ --} - -dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram -dmdAnalProgram dflags fam_envs binds - = do { - let { binds_plus_dmds = do_prog binds } ; - dumpIfSet_dyn dflags Opt_D_dump_str_signatures - "Strictness signatures" $ - dumpStrSig binds_plus_dmds ; - -- See Note [Stamp out space leaks in demand analysis] - seqBinds binds_plus_dmds `seq` return binds_plus_dmds - } - where - do_prog :: CoreProgram -> CoreProgram - do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds - --- Analyse a (group of) top-level binding(s) -dmdAnalTopBind :: AnalEnv - -> CoreBind - -> (AnalEnv, CoreBind) -dmdAnalTopBind sigs (NonRec id rhs) - = (extendAnalEnv TopLevel sigs id2 (idStrictness id2), NonRec id2 rhs2) - where - ( _, _, rhs1) = dmdAnalRhsLetDown TopLevel Nothing sigs id rhs - ( _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin sigs) id rhs1 - -- Do two passes to improve CPR information - -- See Note [CPR for thunks] - -- See Note [Optimistic CPR in the "virgin" case] - -- See Note [Initial CPR for strict binders] - -dmdAnalTopBind sigs (Rec pairs) - = (sigs', Rec pairs') - where - (sigs', _, pairs') = dmdFix TopLevel sigs pairs - -- We get two iterations automatically - -- c.f. the NonRec case above - -{- Note [Stamp out space leaks in demand analysis] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The demand analysis pass outputs a new copy of the Core program in -which binders have been annotated with demand and strictness -information. It's tiresome to ensure that this information is fully -evaluated everywhere that we produce it, so we just run a single -seqBinds over the output before returning it, to ensure that there are -no references holding on to the input Core program. - -This is particularly important when we are doing late demand analysis, -since we don't do a seqBinds at any point thereafter. Hence code -generation would hold on to an extra copy of the Core program, via -unforced thunks in demand or strictness information; and it is the -most memory-intensive part of the compilation process, so this added -seqBinds makes a big difference in peak memory usage. --} - - -{- -************************************************************************ -* * -\subsection{The analyser itself} -* * -************************************************************************ - -Note [Ensure demand is strict] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important not to analyse e with a lazy demand because -a) When we encounter case s of (a,b) -> - we demand s with U(d1d2)... but if the overall demand is lazy - that is wrong, and we'd need to reduce the demand on s, - which is inconvenient -b) More important, consider - f (let x = R in x+x), where f is lazy - We still want to mark x as demanded, because it will be when we - enter the let. If we analyse f's arg with a Lazy demand, we'll - just mark x as Lazy -c) The application rule wouldn't be right either - Evaluating (f x) in a L demand does *not* cause - evaluation of f in a C(L) demand! --} - --- If e is complicated enough to become a thunk, its contents will be evaluated --- at most once, so oneify it. -dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand -dmdTransformThunkDmd e - | exprIsTrivial e = id - | otherwise = oneifyDmd - --- Do not process absent demands --- Otherwise act like in a normal demand analysis --- See ↦* relation in the Cardinality Analysis paper -dmdAnalStar :: AnalEnv - -> Demand -- This one takes a *Demand* - -> CoreExpr -> (BothDmdArg, CoreExpr) -dmdAnalStar env dmd e - | (defer_and_use, cd) <- toCleanDmd dmd (exprType e) - , (dmd_ty, e') <- dmdAnal env cd e - = (postProcessDmdType defer_and_use dmd_ty, e') - --- Main Demand Analsysis machinery -dmdAnal, dmdAnal' :: AnalEnv - -> CleanDemand -- The main one takes a *CleanDemand* - -> CoreExpr -> (DmdType, CoreExpr) - --- The CleanDemand is always strict and not absent --- See Note [Ensure demand is strict] - -dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ - dmdAnal' env d e - -dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit) -dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact -dmdAnal' _ _ (Coercion co) - = (unitDmdType (coercionDmdEnv co), Coercion co) - -dmdAnal' env dmd (Var var) - = (dmdTransform env var dmd, Var var) - -dmdAnal' env dmd (Cast e co) - = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co) - where - (dmd_ty, e') = dmdAnal env dmd e - -{- ----- I don't get this, so commenting out ------- - to_co = pSnd (coercionKind co) - dmd' - | Just tc <- tyConAppTyCon_maybe to_co - , isRecursiveTyCon tc = cleanEvalDmd - | otherwise = dmd - -- This coerce usually arises from a recursive - -- newtype, and we don't want to look inside them - -- for exactly the same reason that we don't look - -- inside recursive products -- we might not reach - -- a fixpoint. So revert to a vanilla Eval demand --} - -dmdAnal' env dmd (Tick t e) - = (dmd_ty, Tick t e') - where - (dmd_ty, e') = dmdAnal env dmd e - -dmdAnal' env dmd (App fun (Type ty)) - = (fun_ty, App fun' (Type ty)) - where - (fun_ty, fun') = dmdAnal env dmd fun - --- Lots of the other code is there to make this --- beautiful, compositional, application rule :-) -dmdAnal' env dmd (App fun arg) - = -- This case handles value arguments (type args handled above) - -- Crucially, coercions /are/ handled here, because they are - -- value arguments (Trac #10288) - let - call_dmd = mkCallDmd dmd - (fun_ty, fun') = dmdAnal env call_dmd fun - (arg_dmd, res_ty) = splitDmdTy fun_ty - (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg - in --- pprTrace "dmdAnal:app" (vcat --- [ text "dmd =" <+> ppr dmd --- , text "expr =" <+> ppr (App fun arg) --- , text "fun dmd_ty =" <+> ppr fun_ty --- , text "arg dmd =" <+> ppr arg_dmd --- , text "arg dmd_ty =" <+> ppr arg_ty --- , text "res dmd_ty =" <+> ppr res_ty --- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ]) - (res_ty `bothDmdType` arg_ty, App fun' arg') - --- this is an anonymous lambda, since @dmdAnalRhsLetDown@ uses @collectBinders@ -dmdAnal' env dmd (Lam var body) - | isTyVar var - = let - (body_ty, body') = dmdAnal env dmd body - in - (body_ty, Lam var body') - - | otherwise - = let (body_dmd, defer_and_use) = peelCallDmd dmd - -- body_dmd: a demand to analyze the body - - env' = extendSigsWithLam env var - (body_ty, body') = dmdAnal env' body_dmd body - (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty var - in - (postProcessUnsat defer_and_use lam_ty, Lam var' body') - -dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) - -- Only one alternative with a product constructor - | let tycon = dataConTyCon dc - , isJust (isDataProductTyCon_maybe tycon) - , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon - = let - env_w_tc = env { ae_rec_tc = rec_tc' } - env_alt = extendEnvForProdAlt env_w_tc scrut case_bndr dc bndrs - (rhs_ty, rhs') = dmdAnal env_alt dmd rhs - (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs - (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr - id_dmds = addCaseBndrDmd case_bndr_dmd dmds - alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2 - | otherwise = alt_ty2 - - -- Compute demand on the scrutinee - -- See Note [Demand on scrutinee of a product case] - scrut_dmd = mkProdDmd (addDataConStrictness dc id_dmds) - (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut - res_ty = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty - case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - bndrs' = setBndrsDemandInfo bndrs id_dmds - in --- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut --- , text "dmd" <+> ppr dmd --- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') --- , text "scrut_dmd" <+> ppr scrut_dmd --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_ty" <+> ppr alt_ty2 --- , text "res_ty" <+> ppr res_ty ]) $ - (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')]) - -dmdAnal' env dmd (Case scrut case_bndr ty alts) - = let -- Case expression with multiple alternatives - (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts - (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut - (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr - -- NB: Base case is botDmdType, for empty case alternatives - -- This is a unit for lubDmdType, and the right result - -- when there really are no alternatives - res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty - in --- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_tys" <+> ppr alt_tys --- , text "alt_ty" <+> ppr alt_ty --- , text "res_ty" <+> ppr res_ty ]) $ - (res_ty, Case scrut' case_bndr' ty alts') - --- Let bindings can be processed in two ways: --- Down (RHS before body) or Up (body before RHS). --- The following case handle the up variant. --- --- It is very simple. For let x = rhs in body --- * Demand-analyse 'body' in the current environment --- * Find the demand, 'rhs_dmd' placed on 'x' by 'body' --- * Demand-analyse 'rhs' in 'rhs_dmd' --- --- This is used for a non-recursive local let without manifest lambdas. --- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnal' env dmd (Let (NonRec id rhs) body) - | useLetUp id rhs - , Nothing <- unpackTrivial rhs - -- dmdAnalRhsLetDown treats trivial right hand sides specially - -- so if we have a trival right hand side, fall through to that. - = (final_ty, Let (NonRec id' rhs') body') - where - (body_ty, body') = dmdAnal env dmd body - (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id - id' = setIdDemandInfo id id_dmd - - (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs - final_ty = body_ty' `bothDmdType` rhs_ty - -dmdAnal' env dmd (Let (NonRec id rhs) body) - = (body_ty2, Let (NonRec id2 rhs') body') - where - (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env id rhs - env1 = extendAnalEnv NotTopLevel env id1 (idStrictness id1) - (body_ty, body') = dmdAnal env1 dmd body - (body_ty1, id2) = annotateBndr env body_ty id1 - body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleasheable free variables] - - -- If the actual demand is better than the vanilla call - -- demand, you might think that we might do better to re-analyse - -- the RHS with the stronger demand. - -- But (a) That seldom happens, because it means that *every* path in - -- the body of the let has to use that stronger demand - -- (b) It often happens temporarily in when fixpointing, because - -- the recursive function at first seems to place a massive demand. - -- But we don't want to go to extra work when the function will - -- probably iterate to something less demanding. - -- In practice, all the times the actual demand on id2 is more than - -- the vanilla call demand seem to be due to (b). So we don't - -- bother to re-analyse the RHS. - -dmdAnal' env dmd (Let (Rec pairs) body) - = let - (env', lazy_fv, pairs') = dmdFix NotTopLevel env pairs - (body_ty, body') = dmdAnal env' dmd body - body_ty1 = deleteFVs body_ty (map fst pairs) - body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleasheable free variables] - in - body_ty2 `seq` - (body_ty2, Let (Rec pairs') body') - -io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool --- See Note [IO hack in the demand analyser] -io_hack_reqd scrut con bndrs - | (bndr:_) <- bndrs - , con == tupleDataCon Unboxed 2 - , idType bndr `eqType` realWorldStatePrimTy - , (fun, _) <- collectArgs scrut - = case fun of - Var f -> not (isPrimOpId f) - _ -> True - | otherwise - = False - -dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var) -dmdAnalAlt env dmd case_bndr (con,bndrs,rhs) - | null bndrs -- Literals, DEFAULT, and nullary constructors - , (rhs_ty, rhs') <- dmdAnal env dmd rhs - = (rhs_ty, (con, [], rhs')) - - | otherwise -- Non-nullary data constructors - , (rhs_ty, rhs') <- dmdAnal env dmd rhs - , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs - , let case_bndr_dmd = findIdDemand alt_ty case_bndr - id_dmds = addCaseBndrDmd case_bndr_dmd dmds - = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) - - -{- Note [IO hack in the demand analyser] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's a hack here for I/O operations. Consider - - case foo x s of { (# s', r #) -> y } - -Is this strict in 'y'? Often not! If foo x s performs some observable action -(including raising an exception with raiseIO#, modifying a mutable variable, or -even ending the program normally), then we must not force 'y' (which may fail -to terminate) until we have performed foo x s. - -Hackish solution: spot the IO-like situation and add a virtual branch, -as if we had - case foo x s of - (# s, r #) -> y - other -> return () -So the 'y' isn't necessarily going to be evaluated - -A more complete example (Trac #148, #1592) where this shows up is: - do { let len = ; - ; when (...) (exitWith ExitSuccess) - ; print len } - -However, consider - f x s = case getMaskingState# s of - (# s, r #) -> - case x of I# x2 -> ... - -Here it is terribly sad to make 'f' lazy in 's'. After all, -getMaskingState# is not going to diverge or throw an exception! This -situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle -(on an MVar not an Int), and made a material difference. - -So if the scrutinee is a primop call, we *don't* apply the -state hack: - - If is a simple, terminating one like getMaskingState, - applying the hack is over-conservative. - - If the primop is raise# then it returns bottom, so - the case alternatives are already discarded. - - If the primop can raise a non-IO exception, like - divide by zero or seg-fault (eg writing an array - out of bounds) then we don't mind evaluating 'x' first. - -Note [Demand on the scrutinee of a product case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When figuring out the demand on the scrutinee of a product case, -we use the demands of the case alternative, i.e. id_dmds. -But note that these include the demand on the case binder; -see Note [Demand on case-alternative binders] in Demand.hs. -This is crucial. Example: - f x = case x of y { (a,b) -> k y a } -If we just take scrut_demand = U(L,A), then we won't pass x to the -worker, so the worker will rebuild - x = (a, absent-error) -and that'll crash. - -Note [Aggregated demand for cardinality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use different strategies for strictness and usage/cardinality to -"unleash" demands captured on free variables by bindings. Let us -consider the example: - -f1 y = let {-# NOINLINE h #-} - h = y - in (h, h) - -We are interested in obtaining cardinality demand U1 on |y|, as it is -used only in a thunk, and, therefore, is not going to be updated any -more. Therefore, the demand on |y|, captured and unleashed by usage of -|h| is U1. However, if we unleash this demand every time |h| is used, -and then sum up the effects, the ultimate demand on |y| will be U1 + -U1 = U. In order to avoid it, we *first* collect the aggregate demand -on |h| in the body of let-expression, and only then apply the demand -transformer: - -transf[x](U) = {y |-> U1} - -so the resulting demand on |y| is U1. - -The situation is, however, different for strictness, where this -aggregating approach exhibits worse results because of the nature of -|both| operation for strictness. Consider the example: - -f y c = - let h x = y |seq| x - in case of - True -> h True - False -> y - -It is clear that |f| is strict in |y|, however, the suggested analysis -will infer from the body of |let| that |h| is used lazily (as it is -used in one branch only), therefore lazy demand will be put on its -free variable |y|. Conversely, if the demand on |h| is unleashed right -on the spot, we will get the desired result, namely, that |f| is -strict in |y|. - - -************************************************************************ -* * - Demand transformer -* * -************************************************************************ --} - -dmdTransform :: AnalEnv -- The strictness environment - -> Id -- The function - -> CleanDemand -- The demand on the function - -> DmdType -- The demand type of the function in this context - -- Returned DmdEnv includes the demand on - -- this function plus demand on its free variables - -dmdTransform env var dmd - | isDataConWorkId var -- Data constructor - = dmdTransformDataConSig (idArity var) (idStrictness var) dmd - - | gopt Opt_DmdTxDictSel (ae_dflags env), - Just _ <- isClassOpId_maybe var -- Dictionary component selector - = dmdTransformDictSelSig (idStrictness var) dmd - - | isGlobalId var -- Imported function - = let res = dmdTransformSig (idStrictness var) dmd in --- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) - res - - | Just (sig, top_lvl) <- lookupSigEnv env var -- Local letrec bound thing - , let fn_ty = dmdTransformSig sig dmd - = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ - if isTopLevel top_lvl - then fn_ty -- Don't record top level things - else addVarDmd fn_ty var (mkOnceUsedDmd dmd) - - | otherwise -- Local non-letrec-bound thing - = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) - -{- -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ --} - --- Recursive bindings -dmdFix :: TopLevelFlag - -> AnalEnv -- Does not include bindings for this binding - -> [(Id,CoreExpr)] - -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info - -dmdFix top_lvl env orig_pairs - = loop 1 initial_pairs - where - bndrs = map fst orig_pairs - - -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ] - - | otherwise = orig_pairs - - -- If fixed-point iteration does not yield a result we use this instead - -- See Note [Safe abortion in the fixed-point iteration] - abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)]) - abort = (env, lazy_fv', zapped_pairs) - where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs) - -- Note [Lazy and unleasheable free variables] - non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs' - lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs - zapped_pairs = zapIdStrictness pairs' - - -- The fixed-point varies the idStrictness field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) - loop n pairs - | found_fixpoint = (final_anal_env, lazy_fv, pairs') - | n == 10 = abort - | otherwise = loop (n+1) pairs' - where - found_fixpoint = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs - first_round = n == 1 - (lazy_fv, pairs') = step first_round pairs - final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) - step first_round pairs = (lazy_fv, pairs') - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv) - - ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs - -- mapAccumL: Use the new signature to do the next pair - -- The occurrence analyser has arranged them in a good order - -- so this can significantly reduce the number of iterations needed - - my_downRhs (env, lazy_fv) (id,rhs) - = ((env', lazy_fv'), (id', rhs')) - where - (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env id rhs - lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 - env' = extendAnalEnv top_lvl env id (idStrictness id') - - - zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ] - -{- -Note [Safe abortion in the fixed-point iteration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Fixed-point iteration may fail to terminate. But we cannot simply give up and -return the environment and code unchanged! We still need to do one additional -round, for two reasons: - - * To get information on used free variables (both lazy and strict!) - (see Note [Lazy and unleasheable free variables]) - * To ensure that all expressions have been traversed at least once, and any left-over - strictness annotations have been updated. - -This final iteration does not add the variables to the strictness signature -environment, which effectively assigns them 'nopSig' (see "getStrictness") - --} - --- Trivial RHS --- See Note [Demand analysis for trivial right-hand sides] -dmdAnalTrivialRhs :: - AnalEnv -> Id -> CoreExpr -> Var -> - (DmdEnv, Id, CoreExpr) -dmdAnalTrivialRhs env id rhs fn - = (fn_fv, set_idStrictness env id fn_str, rhs) - where - fn_str = getStrictness env fn - fn_fv | isLocalId fn = unitVarEnv fn topDmd - | otherwise = emptyDmdEnv - -- Note [Remember to demand the function itself] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- fn_fv: don't forget to produce a demand for fn itself - -- Lacking this caused Trac #9128 - -- The demand is very conservative (topDmd), but that doesn't - -- matter; trivial bindings are usually inlined, so it only - -- kicks in for top-level bindings and NOINLINE bindings - --- Let bindings can be processed in two ways: --- Down (RHS before body) or Up (body before RHS). --- dmdAnalRhsLetDown implements the Down variant: --- * assuming a demand of --- * looking at the definition --- * determining a strictness signature --- --- It is used for toplevel definition, recursive definitions and local --- non-recursive definitions that have manifest lambdas. --- Local non-recursive definitions without a lambda are handled with LetUp. --- --- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalRhsLetDown :: TopLevelFlag - -> Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive - -> AnalEnv -> Id -> CoreExpr - -> (DmdEnv, Id, CoreExpr) --- Process the RHS of the binding, add the strictness signature --- to the Id, and augment the environment with the signature as well. -dmdAnalRhsLetDown top_lvl rec_flag env id rhs - | Just fn <- unpackTrivial rhs -- See Note [Demand analysis for trivial right-hand sides] - = dmdAnalTrivialRhs env id rhs fn - - | otherwise - = (lazy_fv, id', mkLams bndrs' body') - where - (bndrs, body) = collectBinders rhs - env_body = foldl extendSigsWithLam env bndrs - (body_ty, body') = dmdAnal env_body body_dmd body - body_ty' = removeDmdTyArgs body_ty -- zap possible deep CPR info - (DmdType rhs_fv rhs_dmds rhs_res, bndrs') - = annotateLamBndrs env (isDFunId id) body_ty' bndrs - sig_ty = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res') - id' = set_idStrictness env id sig_ty - -- See Note [NOINLINE and strictness] - - -- See Note [Product demands for function body] - body_dmd = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of - Nothing -> cleanEvalDmd - Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc) - - -- See Note [Aggregated demand for cardinality] - rhs_fv1 = case rec_flag of - Just bs -> reuseEnv (delVarEnvList rhs_fv bs) - Nothing -> rhs_fv - - -- See Note [Lazy and unleashable free variables] - (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1 - - rhs_res' = trimCPRInfo trim_all trim_sums rhs_res - trim_all = is_thunk && not_strict - trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types] - - -- See Note [CPR for thunks] - is_thunk = not (exprIsHNF rhs) && not (isJoinId id) - not_strict - = isTopLevel top_lvl -- Top level and recursive things don't - || isJust rec_flag -- get their demandInfo set at all - || not (isStrictDmd (idDemandInfo id) || ae_virgin env) - -- See Note [Optimistic CPR in the "virgin" case] - -unpackTrivial :: CoreExpr -> Maybe Id --- Returns (Just v) if the arg is really equal to v, modulo --- casts, type applications etc --- See Note [Demand analysis for trivial right-hand sides] -unpackTrivial (Var v) = Just v -unpackTrivial (Cast e _) = unpackTrivial e -unpackTrivial (Lam v e) | isTyVar v = unpackTrivial e -unpackTrivial (App e a) | isTypeArg a = unpackTrivial e -unpackTrivial _ = Nothing - --- | If given the RHS of a let-binding, this 'useLetUp' determines --- whether we should process the binding up (body before rhs) or --- down (rhs before body). --- --- We use LetDown if there is a chance to get a useful strictness signature. --- This is the case when there are manifest value lambdas or the binding is a --- join point (hence always acts like a function, not a value). -useLetUp :: Var -> CoreExpr -> Bool -useLetUp f _ | isJoinId f = False -useLetUp f (Lam v e) | isTyVar v = useLetUp f e -useLetUp _ (Lam _ _) = False -useLetUp _ _ = True - - -{- -Note [Demand analysis for trivial right-hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - foo = plusInt |> co -where plusInt is an arity-2 function with known strictness. Clearly -we want plusInt's strictness to propagate to foo! But because it has -no manifest lambdas, it won't do so automatically, and indeed 'co' might -have type (Int->Int->Int) ~ T, so we *can't* eta-expand. So we have a -special case for right-hand sides that are "trivial", namely variables, -casts, type applications, and the like. - -Note that this can mean that 'foo' has an arity that is smaller than that -indicated by its demand info. e.g. if co :: (Int->Int->Int) ~ T, then -foo's arity will be zero (see Note [exprArity invariant] in CoreArity), -but its demand signature will be that of plusInt. A small example is the -test case of Trac #8963. - - -Note [Product demands for function body] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This example comes from shootout/binary_trees: - - Main.check' = \ b z ds. case z of z' { I# ip -> - case ds_d13s of - Main.Nil -> z' - Main.Node s14k s14l s14m -> - Main.check' (not b) - (Main.check' b - (case b { - False -> I# (-# s14h s14k); - True -> I# (+# s14h s14k) - }) - s14l) - s14m } } } - -Here we *really* want to unbox z, even though it appears to be used boxed in -the Nil case. Partly the Nil case is not a hot path. But more specifically, -the whole function gets the CPR property if we do. - -So for the demand on the body of a RHS we use a product demand if it's -a product type. - -************************************************************************ -* * -\subsection{Strictness signatures and types} -* * -************************************************************************ --} - -unitDmdType :: DmdEnv -> DmdType -unitDmdType dmd_env = DmdType dmd_env [] topRes - -coercionDmdEnv :: Coercion -> DmdEnv -coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co) - -- The VarSet from coVarsOfCo is really a VarEnv Var - -addVarDmd :: DmdType -> Var -> Demand -> DmdType -addVarDmd (DmdType fv ds res) var dmd - = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res - -addLazyFVs :: DmdType -> DmdEnv -> DmdType -addLazyFVs dmd_ty lazy_fvs - = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs - -- Using bothDmdType (rather than just both'ing the envs) - -- is vital. Consider - -- let f = \x -> (x,y) - -- in error (f 3) - -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L - -- demand with the bottom coming up from 'error' - -- - -- I got a loop in the fixpointer without this, due to an interaction - -- with the lazy_fv filtering in dmdAnalRhsLetDown. Roughly, it was - -- letrec f n x - -- = letrec g y = x `fatbar` - -- letrec h z = z + ...g... - -- in h (f (n-1) x) - -- in ... - -- In the initial iteration for f, f=Bot - -- Suppose h is found to be strict in z, but the occurrence of g in its RHS - -- is lazy. Now consider the fixpoint iteration for g, esp the demands it - -- places on its free variables. Suppose it places none. Then the - -- x `fatbar` ...call to h... - -- will give a x->V demand for x. That turns into a L demand for x, - -- which floats out of the defn for h. Without the modifyEnv, that - -- L demand doesn't get both'd with the Bot coming up from the inner - -- call to f. So we just get an L demand for x for g. - -{- -Note [Do not strictify the argument dictionaries of a dfun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker can tie recursive knots involving dfuns, so we do the -conservative thing and refrain from strictifying a dfun's argument -dictionaries. --} - -setBndrsDemandInfo :: [Var] -> [Demand] -> [Var] -setBndrsDemandInfo (b:bs) (d:ds) - | isTyVar b = b : setBndrsDemandInfo bs (d:ds) - | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds -setBndrsDemandInfo [] ds = ASSERT( null ds ) [] -setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) - -annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var) --- The returned env has the var deleted --- The returned var is annotated with demand info --- according to the result demand of the provided demand type --- No effect on the argument demands -annotateBndr env dmd_ty var - | isId var = (dmd_ty', setIdDemandInfo var dmd) - | otherwise = (dmd_ty, var) - where - (dmd_ty', dmd) = findBndrDmd env False dmd_ty var - -annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var]) -annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs - where - annotate dmd_ty bndr - | isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty bndr - | otherwise = (dmd_ty, bndr) - -annotateLamIdBndr :: AnalEnv - -> DFunFlag -- is this lambda at the top of the RHS of a dfun? - -> DmdType -- Demand type of body - -> Id -- Lambda binder - -> (DmdType, -- Demand type of lambda - Id) -- and binder annotated with demand - -annotateLamIdBndr env arg_of_dfun dmd_ty id --- For lambdas we add the demand to the argument demands --- Only called for Ids - = ASSERT( isId id ) - -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $ - (final_ty, setIdDemandInfo id dmd) - where - -- Watch out! See note [Lambda-bound unfoldings] - final_ty = case maybeUnfoldingTemplate (idUnfolding id) of - Nothing -> main_ty - Just unf -> main_ty `bothDmdType` unf_ty - where - (unf_ty, _) = dmdAnalStar env dmd unf - - main_ty = addDemand dmd dmd_ty' - (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id - -deleteFVs :: DmdType -> [Var] -> DmdType -deleteFVs (DmdType fvs dmds res) bndrs - = DmdType (delVarEnvList fvs bndrs) dmds res - -{- -Note [CPR for sum types] -~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we do not do CPR for let-bindings that - * non-top level - * bind a sum type -Reason: I found that in some benchmarks we were losing let-no-escapes, -which messed it all up. Example - let j = \x. .... - in case y of - True -> j False - False -> j True -If we w/w this we get - let j' = \x. .... - in case y of - True -> case j' False of { (# a #) -> Just a } - False -> case j' True of { (# a #) -> Just a } -Notice that j' is not a let-no-escape any more. - -However this means in turn that the *enclosing* function -may be CPR'd (via the returned Justs). But in the case of -sums, there may be Nothing alternatives; and that messes -up the sum-type CPR. - -Conclusion: only do this for products. It's still not -guaranteed OK for products, but sums definitely lose sometimes. - -Note [CPR for thunks] -~~~~~~~~~~~~~~~~~~~~~ -If the rhs is a thunk, we usually forget the CPR info, because -it is presumably shared (else it would have been inlined, and -so we'd lose sharing if w/w'd it into a function). E.g. - - let r = case expensive of - (a,b) -> (b,a) - in ... - -If we marked r as having the CPR property, then we'd w/w into - - let $wr = \() -> case expensive of - (a,b) -> (# b, a #) - r = case $wr () of - (# b,a #) -> (b,a) - in ... - -But now r is a thunk, which won't be inlined, so we are no further ahead. -But consider - - f x = let r = case expensive of (a,b) -> (b,a) - in if foo r then r else (x,x) - -Does f have the CPR property? Well, no. - -However, if the strictness analyser has figured out (in a previous -iteration) that it's strict, then we DON'T need to forget the CPR info. -Instead we can retain the CPR info and do the thunk-splitting transform -(see WorkWrap.splitThunk). - -This made a big difference to PrelBase.modInt, which had something like - modInt = \ x -> let r = ... -> I# v in - ...body strict in r... -r's RHS isn't a value yet; but modInt returns r in various branches, so -if r doesn't have the CPR property then neither does modInt -Another case I found in practice (in Complex.magnitude), looks like this: - let k = if ... then I# a else I# b - in ... body strict in k .... -(For this example, it doesn't matter whether k is returned as part of -the overall result; but it does matter that k's RHS has the CPR property.) -Left to itself, the simplifier will make a join point thus: - let $j k = ...body strict in k... - if ... then $j (I# a) else $j (I# b) -With thunk-splitting, we get instead - let $j x = let k = I#x in ...body strict in k... - in if ... then $j a else $j b -This is much better; there's a good chance the I# won't get allocated. - -The difficulty with this is that we need the strictness type to -look at the body... but we now need the body to calculate the demand -on the variable, so we can decide whether its strictness type should -have a CPR in it or not. Simple solution: - a) use strictness info from the previous iteration - b) make sure we do at least 2 iterations, by doing a second - round for top-level non-recs. Top level recs will get at - least 2 iterations except for totally-bottom functions - which aren't very interesting anyway. - -NB: strictly_demanded is never true of a top-level Id, or of a recursive Id. - -Note [Optimistic CPR in the "virgin" case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Demand and strictness info are initialized by top elements. However, -this prevents from inferring a CPR property in the first pass of the -analyser, so we keep an explicit flag ae_virgin in the AnalEnv -datatype. - -We can't start with 'not-demanded' (i.e., top) because then consider - f x = let - t = ... I# x - in - if ... then t else I# y else f x' - -In the first iteration we'd have no demand info for x, so assume -not-demanded; then we'd get TopRes for f's CPR info. Next iteration -we'd see that t was demanded, and so give it the CPR property, but by -now f has TopRes, so it will stay TopRes. Instead, by checking the -ae_virgin flag at the first time round, we say 'yes t is demanded' the -first time. - -However, this does mean that for non-recursive bindings we must -iterate twice to be sure of not getting over-optimistic CPR info, -in the case where t turns out to be not-demanded. This is handled -by dmdAnalTopBind. - - -Note [NOINLINE and strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The strictness analyser used to have a HACK which ensured that NOINLNE -things were not strictness-analysed. The reason was unsafePerformIO. -Left to itself, the strictness analyser would discover this strictness -for unsafePerformIO: - unsafePerformIO: C(U(AV)) -But then consider this sub-expression - unsafePerformIO (\s -> let r = f x in - case writeIORef v r s of (# s1, _ #) -> - (# s1, r #) -The strictness analyser will now find that r is sure to be eval'd, -and may then hoist it out. This makes tests/lib/should_run/memo002 -deadlock. - -Solving this by making all NOINLINE things have no strictness info is overkill. -In particular, it's overkill for runST, which is perfectly respectable. -Consider - f x = runST (return x) -This should be strict in x. - -So the new plan is to define unsafePerformIO using the 'lazy' combinator: - - unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) - -Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is -magically NON-STRICT, and is inlined after strictness analysis. So -unsafePerformIO will look non-strict, and that's what we want. - -Now we don't need the hack in the strictness analyser. HOWEVER, this -decision does mean that even a NOINLINE function is not entirely -opaque: some aspect of its implementation leaks out, notably its -strictness. For example, if you have a function implemented by an -error stub, but which has RULES, you may want it not to be eliminated -in favour of error! - -Note [Lazy and unleasheable free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We put the strict and once-used FVs in the DmdType of the Id, so -that at its call sites we unleash demands on its strict fvs. -An example is 'roll' in imaginary/wheel-sieve2 -Something like this: - roll x = letrec - go y = if ... then roll (x-1) else x+1 - in - go ms -We want to see that roll is strict in x, which is because -go is called. So we put the DmdEnv for x in go's DmdType. - -Another example: - - f :: Int -> Int -> Int - f x y = let t = x+1 - h z = if z==0 then t else - if z==1 then x+1 else - x + h (z-1) - in h y - -Calling h does indeed evaluate x, but we can only see -that if we unleash a demand on x at the call site for t. - -Incidentally, here's a place where lambda-lifting h would -lose the cigar --- we couldn't see the joint strictness in t/x - - ON THE OTHER HAND - -We don't want to put *all* the fv's from the RHS into the -DmdType. Because - - * it makes the strictness signatures larger, and hence slows down fixpointing - -and - - * it is useless information at the call site anyways: - For lazy, used-many times fv's we will never get any better result than - that, no matter how good the actual demand on the function at the call site - is (unless it is always absent, but then the whole binder is useless). - -Therefore we exclude lazy multiple-used fv's from the environment in the -DmdType. - -But now the signature lies! (Missing variables are assumed to be absent.) To -make up for this, the code that analyses the binding keeps the demand on those -variable separate (usually called "lazy_fv") and adds it to the demand of the -whole binding later. - -What if we decide _not_ to store a strictness signature for a binding at all, as -we do when aborting a fixed-point iteration? The we risk losing the information -that the strict variables are being used. In that case, we take all free variables -mentioned in the (unsound) strictness signature, conservatively approximate the -demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix". - - -Note [Lambda-bound unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow a lambda-bound variable to carry an unfolding, a facility that is used -exclusively for join points; see Note [Case binders and join points]. If so, -we must be careful to demand-analyse the RHS of the unfolding! Example - \x. \y{=Just x}. -Then if uses 'y', then transitively it uses 'x', and we must not -forget that fact, otherwise we might make 'x' absent when it isn't. - - -************************************************************************ -* * -\subsection{Strictness signatures} -* * -************************************************************************ --} - -type DFunFlag = Bool -- indicates if the lambda being considered is in the - -- sequence of lambdas at the top of the RHS of a dfun -notArgOfDfun :: DFunFlag -notArgOfDfun = False - -data AnalEnv - = AE { ae_dflags :: DynFlags - , ae_sigs :: SigEnv - , ae_virgin :: Bool -- True on first iteration only - -- See Note [Initialising strictness] - , ae_rec_tc :: RecTcChecker - , ae_fam_envs :: FamInstEnvs - } - - -- We use the se_env to tell us whether to - -- record info about a variable in the DmdEnv - -- We do so if it's a LocalId, but not top-level - -- - -- The DmdEnv gives the demand on the free vars of the function - -- when it is given enough args to satisfy the strictness signature - -type SigEnv = VarEnv (StrictSig, TopLevelFlag) - -instance Outputable AnalEnv where - ppr (AE { ae_sigs = env, ae_virgin = virgin }) - = text "AE" <+> braces (vcat - [ text "ae_virgin =" <+> ppr virgin - , text "ae_sigs =" <+> ppr env ]) - -emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv -emptyAnalEnv dflags fam_envs - = AE { ae_dflags = dflags - , ae_sigs = emptySigEnv - , ae_virgin = True - , ae_rec_tc = initRecTc - , ae_fam_envs = fam_envs - } - -emptySigEnv :: SigEnv -emptySigEnv = emptyVarEnv - --- | Extend an environment with the strictness IDs attached to the id -extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -extendAnalEnvs top_lvl env vars - = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } - -extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv -extendSigEnvs top_lvl sigs vars - = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars] - -extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv -extendAnalEnv top_lvl env var sig - = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } - -extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv -extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) - -lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) -lookupSigEnv env id = lookupVarEnv (ae_sigs env) id - -getStrictness :: AnalEnv -> Id -> StrictSig -getStrictness env fn - | isGlobalId fn = idStrictness fn - | Just (sig, _) <- lookupSigEnv env fn = sig - | otherwise = nopSig - -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - -extendSigsWithLam :: AnalEnv -> Id -> AnalEnv --- Extend the AnalEnv when we meet a lambda binder -extendSigsWithLam env id - | isId id - , isStrictDmd (idDemandInfo id) || ae_virgin env - -- See Note [Optimistic CPR in the "virgin" case] - -- See Note [Initial CPR for strict binders] - , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id - = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc)) - - | otherwise - = env - -extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv --- See Note [CPR in a product case alternative] -extendEnvForProdAlt env scrut case_bndr dc bndrs - = foldl do_con_arg env1 ids_w_strs - where - env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig - - ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc - case_bndr_sig = cprProdSig (dataConRepArity dc) - fam_envs = ae_fam_envs env - - do_con_arg env (id, str) - | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str - , ae_virgin env || (is_var_scrut && is_strict) -- See Note [CPR in a product case alternative] - , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id - = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc)) - | otherwise - = env - - is_var_scrut = is_var scrut - is_var (Cast e _) = is_var e - is_var (Var v) = isLocalId v - is_var _ = False - -addDataConStrictness :: DataCon -> [Demand] -> [Demand] --- See Note [Add demands for strict constructors] -addDataConStrictness con ds - = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds ) - zipWith add ds strs - where - strs = dataConRepStrictness con - add dmd str | isMarkedStrict str - , not (isAbsDmd dmd) = dmd `bothDmd` seqDmd - | otherwise = dmd - -findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) --- Return the demands on the Ids in the [Var] -findBndrsDmds env dmd_ty bndrs - = go dmd_ty bndrs - where - go dmd_ty [] = (dmd_ty, []) - go dmd_ty (b:bs) - | isId b = let (dmd_ty1, dmds) = go dmd_ty bs - (dmd_ty2, dmd) = findBndrDmd env False dmd_ty1 b - in (dmd_ty2, dmd : dmds) - | otherwise = go dmd_ty bs - -findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) --- See Note [Trimming a demand to a type] in Demand.hs -findBndrDmd env arg_of_dfun dmd_ty id - = (dmd_ty', dmd') - where - dmd' = killUsageDemand (ae_dflags env) $ - strictify $ - trimToType starting_dmd (findTypeShape fam_envs id_ty) - - (dmd_ty', starting_dmd) = peelFV dmd_ty id - - id_ty = idType id - - strictify dmd - | gopt Opt_DictsStrict (ae_dflags env) - -- We never want to strictify a recursive let. At the moment - -- annotateBndr is only call for non-recursive lets; if that - -- changes, we need a RecFlag parameter and another guard here. - , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun] - = strictifyDictDmd id_ty dmd - | otherwise - = dmd - - fam_envs = ae_fam_envs env - -set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id -set_idStrictness env id sig - = setIdStrictness id (killUsageSig (ae_dflags env) sig) - -dumpStrSig :: CoreProgram -> SDoc -dumpStrSig binds = vcat (map printId ids) - where - ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds) - getIds (NonRec i _) = [ i ] - getIds (Rec bs) = map fst bs - printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id) - | otherwise = empty - -{- Note [CPR in a product case alternative] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a case alternative for a product type, we want to give some of the -binders the CPR property. Specifically - - * The case binder; inside the alternative, the case binder always has - the CPR property, meaning that a case on it will successfully cancel. - Example: - f True x = case x of y { I# x' -> if x' ==# 3 - then y - else I# 8 } - f False x = I# 3 - - By giving 'y' the CPR property, we ensure that 'f' does too, so we get - f b x = case fw b x of { r -> I# r } - fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } - fw False x = 3 - - Of course there is the usual risk of re-boxing: we have 'x' available - boxed and unboxed, but we return the unboxed version for the wrapper to - box. If the wrapper doesn't cancel with its caller, we'll end up - re-boxing something that we did have available in boxed form. - - * Any strict binders with product type, can use - Note [Initial CPR for strict binders]. But we can go a little - further. Consider - - data T = MkT !Int Int - - f2 (MkT x y) | y>0 = f2 (MkT x (y-1)) - | otherwise = x - - For $wf2 we are going to unbox the MkT *and*, since it is strict, the - first argument of the MkT; see Note [Add demands for strict constructors]. - But then we don't want box it up again when returning it! We want - 'f2' to have the CPR property, so we give 'x' the CPR property. - - * It's a bit delicate because if this case is scrutinising something other - than an argument the original function, we really don't have the unboxed - version available. E.g - g v = case foo v of - MkT x y | y>0 -> ... - | otherwise -> x - Here we don't have the unboxed 'x' available. Hence the - is_var_scrut test when making use of the strictness annotation. - Slightly ad-hoc, because even if the scrutinee *is* a variable it - might not be a onre of the arguments to the original function, or a - sub-component thereof. But it's simple, and nothing terrible - happens if we get it wrong. e.g. Trac #10694. - -Note [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! - -We achieve the effect using addDataConStrictness. It is called at a -case expression, such as the pattern match on (X a) in the example -above. After computing how 'a' is used in the alternatives, we add an -extra 'seqDmd' to it. The case alternative isn't itself strict in the -sub-components, but simply evaluating the scrutinee to HNF does force -those sub-components. - -If the argument is not used at all in the alternative (i.e. it is -Absent), then *don't* add a 'seqDmd'. If we do, it makes it look used -and hence it'll be passed to the worker when it doesn't need to be. -Hence the isAbsDmd test in addDataConStrictness. - -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! - - -Note [Initial CPR for strict binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CPR is initialized for a lambda binder in an optimistic manner, i.e, -if the binder is used strictly and at least some of its components as -a product are used, which is checked by the value of the absence -demand. - -If the binder is marked demanded with a strict demand, then give it a -CPR signature. Here's a concrete example ('f1' in test T10482a), -assuming h is strict: - - f1 :: Int -> Int - f1 x = case h x of - A -> x - B -> f1 (x-1) - C -> x+1 - -If we notice that 'x' is used strictly, we can give it the CPR -property; and hence f1 gets the CPR property too. It's sound (doesn't -change strictness) to give it the CPR property because by the time 'x' -is returned (case A above), it'll have been evaluated (by the wrapper -of 'h' in the example). - -Moreover, if f itself is strict in x, then we'll pass x unboxed to -f1, and so the boxed version *won't* be available; in that case it's -very helpful to give 'x' the CPR property. - -Note that - - * We only want to do this for something that definitely - has product type, else we may get over-optimistic CPR results - (e.g. from \x -> x!). - - * See Note [CPR examples] - -Note [CPR examples] -~~~~~~~~~~~~~~~~~~~~ -Here are some examples (stranal/should_compile/T10482a) of the -usefulness of Note [CPR in a product case alternative]. The main -point: all of these functions can have the CPR property. - - ------- f1 ----------- - -- x is used strictly by h, so it'll be available - -- unboxed before it is returned in the True branch - - f1 :: Int -> Int - f1 x = case h x x of - True -> x - False -> f1 (x-1) - - - ------- f2 ----------- - -- x is a strict field of MkT2, so we'll pass it unboxed - -- to $wf2, so it's available unboxed. This depends on - -- the case expression analysing (a subcomponent of) one - -- of the original arguments to the function, so it's - -- a bit more delicate. - - data T2 = MkT2 !Int Int - - f2 :: T2 -> Int - f2 (MkT2 x y) | y>0 = f2 (MkT2 x (y-1)) - | otherwise = x - - - ------- f3 ----------- - -- h is strict in x, so x will be unboxed before it - -- is rerturned in the otherwise case. - - data T3 = MkT3 Int Int - - f1 :: T3 -> Int - f1 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) - | otherwise = x - - - ------- f4 ----------- - -- Just like f2, but MkT4 can't unbox its strict - -- argument automatically, as f2 can - - data family Foo a - newtype instance Foo Int = Foo Int - - data T4 a = MkT4 !(Foo a) Int - - f4 :: T4 Int -> Int - f4 (MkT4 x@(Foo v) y) | y>0 = f4 (MkT4 x (y-1)) - | otherwise = v - - -Note [Initialising strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See section 9.2 (Finding fixpoints) of the paper. - -Our basic plan is to initialise the strictness of each Id in a -recursive group to "bottom", and find a fixpoint from there. However, -this group B might be inside an *enclosing* recursive group A, in -which case we'll do the entire fixpoint shebang on for each iteration -of A. This can be illustrated by the following example: - -Example: - - f [] = [] - f (x:xs) = let g [] = f xs - g (y:ys) = y+1 : g ys - in g (h x) - -At each iteration of the fixpoint for f, the analyser has to find a -fixpoint for the enclosed function g. In the meantime, the demand -values for g at each iteration for f are *greater* than those we -encountered in the previous iteration for f. Therefore, we can begin -the fixpoint for g not with the bottom value but rather with the -result of the previous analysis. I.e., when beginning the fixpoint -process for g, we can start from the demand signature computed for g -previously and attached to the binding occurrence of g. - -To speed things up, we initialise each iteration of A (the enclosing -one) from the result of the last one, which is neatly recorded in each -binder. That way we make use of earlier iterations of the fixpoint -algorithm. (Cunning plan.) - -But on the *first* iteration we want to *ignore* the current strictness -of the Id, and start from "bottom". Nowadays the Id can have a current -strictness, because interface files record strictness for nested bindings. -To know when we are in the first iteration, we look at the ae_virgin -field of the AnalEnv. - - -Note [Final Demand Analyser run] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some of the information that the demand analyser determines is not always -preserved by the simplifier. For example, the simplifier will happily rewrite - \y [Demand=1*U] let x = y in x + x -to - \y [Demand=1*U] y + y -which is quite a lie. - -The once-used information is (currently) only used by the code -generator, though. So: - - * We zap the used-once info in the worker-wrapper; - see Note [Zapping Used Once info in WorkWrap] in WorkWrap. If it's - not reliable, it's better not to have it at all. - - * Just before TidyCore, we add a pass of the demand analyser, - but WITHOUT subsequent worker/wrapper and simplifier, - right before TidyCore. See SimplCore.getCoreToDo. - - This way, correct information finds its way into the module interface - (strictness signatures!) and the code generator (single-entry thunks!) - -Note that, in contrast, the single-call information (C1(..)) /can/ be -relied upon, as the simplifier tends to be very careful about not -duplicating actual function calls. - -Also see #11731. --} diff --git a/stranal/WorkWrap.hs b/stranal/WorkWrap.hs deleted file mode 100644 --- a/stranal/WorkWrap.hs +++ /dev/null @@ -1,661 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} --} - -{-# LANGUAGE CPP #-} -module WorkWrap ( wwTopBinds ) where - -import CoreSyn -import CoreUnfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding ) -import CoreUtils ( exprType, exprIsHNF ) -import CoreFVs ( exprFreeVars ) -import Var -import Id -import IdInfo -import Type -import UniqSupply -import BasicTypes -import DynFlags -import Demand -import WwLib -import Util -import Outputable -import FamInstEnv -import MonadUtils - -#include "HsVersions.h" - -{- -We take Core bindings whose binders have: - -\begin{enumerate} - -\item Strictness attached (by the front-end of the strictness -analyser), and / or - -\item Constructed Product Result information attached by the CPR -analysis pass. - -\end{enumerate} - -and we return some ``plain'' bindings which have been -worker/wrapper-ified, meaning: - -\begin{enumerate} - -\item Functions have been split into workers and wrappers where -appropriate. If a function has both strictness and CPR properties -then only one worker/wrapper doing both transformations is produced; - -\item Binders' @IdInfos@ have been updated to reflect the existence of -these workers/wrappers (this is where we get STRICTNESS and CPR pragma -info for exported values). -\end{enumerate} --} - -wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram - -wwTopBinds dflags fam_envs us top_binds - = initUs_ us $ do - top_binds' <- mapM (wwBind dflags fam_envs) top_binds - return (concat top_binds') - -{- -************************************************************************ -* * -\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@} -* * -************************************************************************ - -@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in -turn. Non-recursive case first, then recursive... --} - -wwBind :: DynFlags - -> FamInstEnvs - -> CoreBind - -> UniqSM [CoreBind] -- returns a WwBinding intermediate form; - -- the caller will convert to Expr/Binding, - -- as appropriate. - -wwBind dflags fam_envs (NonRec binder rhs) = do - new_rhs <- wwExpr dflags fam_envs rhs - new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs - return [NonRec b e | (b,e) <- new_pairs] - -- Generated bindings must be non-recursive - -- because the original binding was. - -wwBind dflags fam_envs (Rec pairs) - = return . Rec <$> concatMapM do_one pairs - where - do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs - tryWW dflags fam_envs Recursive binder new_rhs - -{- -@wwExpr@ basically just walks the tree, looking for appropriate -annotations that can be used. Remember it is @wwBind@ that does the -matching by looking for strict arguments of the correct type. -@wwExpr@ is a version that just returns the ``Plain'' Tree. --} - -wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr - -wwExpr _ _ e@(Type {}) = return e -wwExpr _ _ e@(Coercion {}) = return e -wwExpr _ _ e@(Lit {}) = return e -wwExpr _ _ e@(Var {}) = return e - -wwExpr dflags fam_envs (Lam binder expr) - = Lam new_binder <$> wwExpr dflags fam_envs expr - where new_binder | isId binder = zapIdUsedOnceInfo binder - | otherwise = binder - -- See Note [Zapping Used Once info in WorkWrap] - -wwExpr dflags fam_envs (App f a) - = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a - -wwExpr dflags fam_envs (Tick note expr) - = Tick note <$> wwExpr dflags fam_envs expr - -wwExpr dflags fam_envs (Cast expr co) = do - new_expr <- wwExpr dflags fam_envs expr - return (Cast new_expr co) - -wwExpr dflags fam_envs (Let bind expr) - = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr - -wwExpr dflags fam_envs (Case expr binder ty alts) = do - new_expr <- wwExpr dflags fam_envs expr - new_alts <- mapM ww_alt alts - let new_binder = zapIdUsedOnceInfo binder - -- See Note [Zapping Used Once info in WorkWrap] - return (Case new_expr new_binder ty new_alts) - where - ww_alt (con, binders, rhs) = do - new_rhs <- wwExpr dflags fam_envs rhs - let new_binders = [ if isId b then zapIdUsedOnceInfo b else b - | b <- binders ] - -- See Note [Zapping Used Once info in WorkWrap] - return (con, new_binders, new_rhs) - -{- -************************************************************************ -* * -\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair} -* * -************************************************************************ - -@tryWW@ just accumulates arguments, converts strictness info from the -front-end into the proper form, then calls @mkWwBodies@ to do -the business. - -The only reason this is monadised is for the unique supply. - -Note [Don't w/w INLINE things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very important to refrain from w/w-ing an INLINE function (ie one -with a stable unfolding) because the wrapper will then overwrite the -old stable unfolding with the wrapper code. - -Furthermore, if the programmer has marked something as INLINE, -we may lose by w/w'ing it. - -If the strictness analyser is run twice, this test also prevents -wrappers (which are INLINEd) from being re-done. (You can end up with -several liked-named Ids bouncing around at the same time---absolute -mischief.) - -Notice that we refrain from w/w'ing an INLINE function even if it is -in a recursive group. It might not be the loop breaker. (We could -test for loop-breaker-hood, but I'm not sure that ever matters.) - -Note [Worker-wrapper for INLINABLE functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - {-# INLINABLE f #-} - f :: Ord a => [a] -> Int -> a - f x y = ....f.... - -where f is strict in y, we might get a more efficient loop by w/w'ing -f. But that would make a new unfolding which would overwrite the old -one! So the function would no longer be ININABLE, and in particular -will not be specialised at call sites in other modules. - -This comes in practice (Trac #6056). - -Solution: do the w/w for strictness analysis, but transfer the Stable -unfolding to the *worker*. So we will get something like this: - - {-# INLINE[0] f #-} - f :: Ord a => [a] -> Int -> a - f d x y = case y of I# y' -> fw d x y' - - {-# INLINABLE[0] fw #-} - fw :: Ord a => [a] -> Int# -> a - fw d x y' = let y = I# y' in ...f... - -How do we "transfer the unfolding"? Easy: by using the old one, wrapped -in work_fn! See CoreUnfold.mkWorkerUnfolding. - -Note [Worker-wrapper for NOINLINE functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to disable worker/wrapper for NOINLINE things, but it turns out -this can cause unnecessary reboxing of values. Consider - - {-# NOINLINE f #-} - f :: Int -> a - f x = error (show x) - - g :: Bool -> Bool -> Int -> Int - g True True p = f p - g False True p = p + 1 - g b False p = g b True p - -the strictness analysis will discover f and g are strict, but because f -has no wrapper, the worker for g will rebox p. So we get - - $wg x y p# = - let p = I# p# in -- Yikes! Reboxing! - case x of - False -> - case y of - False -> $wg False True p# - True -> +# p# 1# - True -> - case y of - False -> $wg True True p# - True -> case f p of { } - - g x y p = case p of (I# p#) -> $wg x y p# - -Now, in this case the reboxing will float into the True branch, an so -the allocation will only happen on the error path. But it won't float -inwards if there are multiple branches that call (f p), so the reboxing -will happen on every call of g. Disaster. - -Solution: do worker/wrapper even on NOINLINE things; but move the -NOINLINE pragma to the worker. - -(See Trac #13143 for a real-world example.) - -Note [Activation for workers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Follows on from Note [Worker-wrapper for INLINABLE functions] - -It is *vital* that if the worker gets an INLINABLE pragma (from the -original function), then the worker has the same phase activation as -the wrapper (or later). That is necessary to allow the wrapper to -inline into the worker's unfolding: see SimplUtils -Note [Simplifying inside stable unfoldings]. - -If the original is NOINLINE, it's important that the work inherit the -original activation. Consider - - {-# NOINLINE expensive #-} - expensive x = x + 1 - - f y = let z = expensive y in ... - -If expensive's worker inherits the wrapper's activation, we'll get - - {-# NOINLINE[0] $wexpensive #-} - $wexpensive x = x + 1 - {-# INLINE[0] expensive #-} - expensive x = $wexpensive x - - f y = let z = expensive y in ... - -and $wexpensive will be immediately inlined into expensive, followed by -expensive into f. This effectively removes the original NOINLINE! - -Otherwise, nothing is lost by giving the worker the same activation as the -wrapper, because the worker won't have any chance of inlining until the -wrapper does; there's no point in giving it an earlier activation. - -Note [Don't w/w inline small non-loop-breaker things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, we refrain from w/w-ing *small* functions, which are not -loop breakers, because they'll inline anyway. But we must take care: -it may look small now, but get to be big later after other inlining -has happened. So we take the precaution of adding an INLINE pragma to -any such functions. - -I made this change when I observed a big function at the end of -compilation with a useful strictness signature but no w-w. (It was -small during demand analysis, we refrained from w/w, and then got big -when something was inlined in its rhs.) When I measured it on nofib, -it didn't make much difference; just a few percent improved allocation -on one benchmark (bspt/Euclid.space). But nothing got worse. - -There is an infelicity though. We may get something like - f = g val -==> - g x = case gw x of r -> I# r - - f {- InlineStable, Template = g val -} - f = case gw x of r -> I# r - -The code for f duplicates that for g, without any real benefit. It -won't really be executed, because calls to f will go via the inlining. - -Note [Don't CPR join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There's no point in doing CPR on a join point. If the whole function is getting -CPR'd, then the case expression around the worker function will get pushed into -the join point by the simplifier, which will have the same effect that CPR would -have - the result will be returned in an unboxed tuple. - - f z = let join j x y = (x+1, y+1) - in case z of A -> j 1 2 - B -> j 2 3 - - => - - f z = case $wf z of (# a, b #) -> (a, b) - $wf z = case (let join j x y = (x+1, y+1) - in case z of A -> j 1 2 - B -> j 2 3) of (a, b) -> (# a, b #) - - => - - f z = case $wf z of (# a, b #) -> (a, b) - $wf z = let join j x y = (# x+1, y+1 #) - in case z of A -> j 1 2 - B -> j 2 3 - -Doing CPR on a join point would be tricky anyway, as the worker could not be -a join point because it would not be tail-called. However, doing the *argument* -part of W/W still works for join points, since the wrapper body will make a tail -call: - - f z = let join j x y = x + y - in ... - - => - - f z = let join $wj x# y# = x# +# y# - j x y = case x of I# x# -> - case y of I# y# -> - $wj x# y# - in ... - -Note [Wrapper activation] -~~~~~~~~~~~~~~~~~~~~~~~~~ -When should the wrapper inlining be active? It must not be active -earlier than the current Activation of the Id (eg it might have a -NOINLINE pragma). But in fact strictness analysis happens fairly -late in the pipeline, and we want to prioritise specialisations over -strictness. Eg if we have - module Foo where - f :: Num a => a -> Int -> a - f n 0 = n -- Strict in the Int, hence wrapper - f n x = f (n+n) (x-1) - - g :: Int -> Int - g x = f x x -- Provokes a specialisation for f - - module Bar where - import Foo - - h :: Int -> Int - h x = f 3 x - -Then we want the specialisation for 'f' to kick in before the wrapper does. - -Now in fact the 'gentle' simplification pass encourages this, by -having rules on, but inlinings off. But that's kind of lucky. It seems -more robust to give the wrapper an Activation of (ActiveAfter 0), -so that it becomes active in an importing module at the same time that -it appears in the first place in the defining module. - -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. --} - -tryWW :: DynFlags - -> FamInstEnvs - -> RecFlag - -> Id -- The fn binder - -> CoreExpr -- The bound rhs; its innards - -- are already ww'd - -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs; - -- if one, then no worker (only - -- the orig "wrapper" lives on); - -- if two, then a worker and a - -- wrapper. -tryWW dflags fam_envs is_rec fn_id rhs - -- See Note [Worker-wrapper for NOINLINE functions] - - | Just stable_unf <- certainlyWillInline dflags fn_info - = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ] - -- See Note [Don't w/w INLINE things] - -- See Note [Don't w/w inline small non-loop-breaker things] - - | is_fun - = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs - - | is_thunk -- See Note [Thunk splitting] - = splitThunk dflags fam_envs is_rec new_fn_id rhs - - | otherwise - = return [ (new_fn_id, rhs) ] - - where - fn_info = idInfo fn_id - (wrap_dmds, res_info) = splitStrictSig (strictnessInfo fn_info) - - new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id) - -- See Note [Zapping DmdEnv after Demand Analyzer] and - -- See Note [Zapping Used Once info in WorkWrap] - - is_fun = notNull wrap_dmds || isJoinId fn_id - is_thunk = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id) - && not (isUnliftedType (idType fn_id)) - -{- -Note [Zapping DmdEnv after Demand Analyzer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the worker-wrapper pass we zap the DmdEnv. Why? - (a) it is never used again - (b) it wastes space - (c) it becomes incorrect as things are cloned, because - we don't push the substitution into it - -Why here? - * Because we don’t want to do it in the Demand Analyzer, as we never know - there when we are doing the last pass. - * We want them to be still there at the end of DmdAnal, so that - -ddump-str-anal contains them. - * We don’t want a second pass just for that. - * WorkWrap looks at all bindings anyway. - -We also need to do it in TidyCore.tidyLetBndr to clean up after the -final, worker/wrapper-less run of the demand analyser (see -Note [Final Demand Analyser run] in DmdAnal). - -Note [Zapping Used Once info in WorkWrap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the worker-wrapper pass we zap the used once info in demands and in -strictness signatures. - -Why? - * The simplifier may happen to transform code in a way that invalidates the - data (see #11731 for an example). - * It is not used in later passes, up to code generation. - -So as the data is useless and possibly wrong, we want to remove it. The most -convenient place to do that is the worker wrapper phase, as it runs after every -run of the demand analyser besides the very last one (which is the one where we -want to _keep_ the info for the code generator). - -We do not do it in the demand analyser for the same reasons outlined in -Note [Zapping DmdEnv after Demand Analyzer] above. --} - - ---------------------- -splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr - -> UniqSM [(Id, CoreExpr)] -splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs - = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do - -- The arity should match the signature - stuff <- mkWwBodies dflags fam_envs rhs_fvs mb_join_arity fun_ty - wrap_dmds use_res_info - case stuff of - Just (work_demands, join_arity, wrap_fn, work_fn) -> do - work_uniq <- getUniqueM - let work_rhs = work_fn rhs - work_inline = inl_inline inl_prag - work_act = case work_inline of - -- See Note [Activation for workers] - NoInline -> inl_act inl_prag - _ -> wrap_act - work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_inline = work_inline - , inl_sat = Nothing - , inl_act = work_act - , inl_rule = FunLike } - -- idl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions] - -- idl_act: see Note [Activation for workers] - -- inl_rule: it does not make sense for workers to be constructorlike. - work_join_arity | isJoinId fn_id = Just join_arity - | otherwise = Nothing - -- worker is join point iff wrapper is join point - -- (see Note [Don't CPR join points]) - work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) - `setIdOccInfo` occInfo fn_info - -- Copy over occurrence info from parent - -- Notably whether it's a loop breaker - -- Doesn't matter much, since we will simplify next, but - -- seems right-er to do so - - `setInlinePragma` work_prag - - `setIdUnfolding` mkWorkerUnfolding dflags work_fn (unfoldingInfo fn_info) - -- See Note [Worker-wrapper for INLINABLE functions] - - `setIdStrictness` mkClosedStrictSig work_demands work_res_info - -- Even though we may not be at top level, - -- it's ok to give it an empty DmdEnv - - `setIdDemandInfo` worker_demand - - `setIdArity` work_arity - -- Set the arity so that the Core Lint check that the - -- arity is consistent with the demand type goes - -- through - `asJoinId_maybe` work_join_arity - - work_arity = length work_demands - - -- See Note [Demand on the Worker] - single_call = saturatedByOneShots arity (demandInfo fn_info) - worker_demand | single_call = mkWorkerDemand work_arity - | otherwise = topDmd - - - wrap_act = ActiveAfter NoSourceText 0 - wrap_rhs = wrap_fn work_id - wrap_prag = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_inline = Inline - , inl_sat = Nothing - , inl_act = wrap_act - , inl_rule = rule_match_info } - -- See Note [Wrapper activation] - -- The RuleMatchInfo is (and must be) unaffected - - wrap_id = fn_id `setIdUnfolding` mkWwInlineRule wrap_rhs arity - `setInlinePragma` wrap_prag - `setIdOccInfo` noOccInfo - -- Zap any loop-breaker-ness, to avoid bleating from Lint - -- about a loop breaker with an INLINE rule - - - - return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)] - -- Worker first, because wrapper mentions it - - Nothing -> return [(fn_id, rhs)] - where - mb_join_arity = isJoinId_maybe fn_id - rhs_fvs = exprFreeVars rhs - fun_ty = idType fn_id - inl_prag = inlinePragInfo fn_info - rule_match_info = inlinePragmaRuleMatchInfo inl_prag - arity = arityInfo fn_info - -- The arity is set by the simplifier using exprEtaExpandArity - -- So it may be more than the number of top-level-visible lambdas - - use_res_info | isJoinId fn_id = topRes -- Note [Don't CPR join points] - | otherwise = res_info - work_res_info | isJoinId fn_id = res_info -- Worker remains CPR-able - | otherwise - = case returnsCPR_maybe res_info of - Just _ -> topRes -- Cpr stuff done by wrapper; kill it here - Nothing -> res_info -- Preserve exception/divergence - - -{- -Note [Demand on the worker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -If the original function is called once, according to its demand info, then -so is the worker. This is important so that the occurrence analyser can -attach OneShot annotations to the worker’s lambda binders. - - -Example: - - -- Original function - f [Demand=] :: (a,a) -> a - f = \p -> ... - - -- Wrapper - f [Demand=] :: a -> a -> a - f = \p -> case p of (a,b) -> $wf a b - - -- Worker - $wf [Demand=] :: Int -> Int - $wf = \a b -> ... - -We need to check whether the original function is called once, with -sufficiently many arguments. This is done using saturatedByOneShots, which -takes the arity of the original function (resp. the wrapper) and the demand on -the original function. - -The demand on the worker is then calculated using mkWorkerDemand, and always of -the form [Demand=] - - -Note [Do not split void functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this rather common form of binding: - $j = \x:Void# -> ...no use of x... - -Since x is not used it'll be marked as absent. But there is no point -in w/w-ing because we'll simply add (\y:Void#), see WwLib.mkWorerArgs. - -If x has a more interesting type (eg Int, or Int#), there *is* a point -in w/w so that we don't pass the argument at all. - -Note [Thunk splitting] -~~~~~~~~~~~~~~~~~~~~~~ -Suppose x is used strictly (never mind whether it has the CPR -property). - - let - x* = x-rhs - in body - -splitThunk transforms like this: - - let - x* = case x-rhs of { I# a -> I# a } - in body - -Now simplifier will transform to - - case x-rhs of - I# a -> let x* = I# a - in body - -which is what we want. Now suppose x-rhs is itself a case: - - x-rhs = case e of { T -> I# a; F -> I# b } - -The join point will abstract over a, rather than over (which is -what would have happened before) which is fine. - -Notice that x certainly has the CPR property now! - -In fact, splitThunk uses the function argument w/w splitting -function, so that if x's demand is deeper (say U(U(L,L),L)) -then the splitting will go deeper too. --} - --- See Note [Thunk splitting] --- splitThunk converts the *non-recursive* binding --- x = e --- into --- x = let x = e --- in case x of --- I# y -> let x = I# y in x } --- See comments above. Is it not beautifully short? --- Moreover, it works just as well when there are --- several binders, and if the binders are lifted --- E.g. x = e --- --> x = let x = e in --- case x of (a,b) -> let x = (a,b) in x - -splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] -splitThunk dflags fam_envs is_rec fn_id rhs - = ASSERT(not (isJoinId fn_id)) - do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs [fn_id] - ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] - ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive - return res - else return [(fn_id, rhs)] } diff --git a/stranal/WwLib.hs b/stranal/WwLib.hs deleted file mode 100644 --- a/stranal/WwLib.hs +++ /dev/null @@ -1,961 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser} --} - -{-# LANGUAGE CPP #-} - -module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs - , deepSplitProductType_maybe, findTypeShape - , isWorkerSmallEnough - ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreUtils ( exprType, mkCast ) -import Id -import IdInfo ( JoinArity, vanillaIdInfo ) -import DataCon -import Demand -import MkCore ( mkAbsentErrorApp, mkCoreUbxTup - , mkCoreApp, mkCoreLet ) -import MkId ( voidArgId, voidPrimId ) -import TysWiredIn ( tupleDataCon ) -import TysPrim ( voidPrimTy ) -import Literal ( absentLiteralOf ) -import VarEnv ( mkInScopeSet ) -import VarSet ( VarSet ) -import Type -import RepType ( isVoidTy ) -import Coercion -import FamInstEnv -import BasicTypes ( Boxity(..) ) -import TyCon -import UniqSupply -import Unique -import Maybes -import Util -import Outputable -import DynFlags -import FastString -import ListSetOps - -{- -************************************************************************ -* * -\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@} -* * -************************************************************************ - -Here's an example. The original function is: - -\begin{verbatim} -g :: forall a . Int -> [a] -> a - -g = \/\ a -> \ x ys -> - case x of - 0 -> head ys - _ -> head (tail ys) -\end{verbatim} - -From this, we want to produce: -\begin{verbatim} --- wrapper (an unfolding) -g :: forall a . Int -> [a] -> a - -g = \/\ a -> \ x ys -> - case x of - I# x# -> $wg a x# ys - -- call the worker; don't forget the type args! - --- worker -$wg :: forall a . Int# -> [a] -> a - -$wg = \/\ a -> \ x# ys -> - let - x = I# x# - in - case x of -- note: body of g moved intact - 0 -> head ys - _ -> head (tail ys) -\end{verbatim} - -Something we have to be careful about: Here's an example: - -\begin{verbatim} --- "f" strictness: U(P)U(P) -f (I# a) (I# b) = a +# b - -g = f -- "g" strictness same as "f" -\end{verbatim} - -\tr{f} will get a worker all nice and friendly-like; that's good. -{\em But we don't want a worker for \tr{g}}, even though it has the -same strictness as \tr{f}. Doing so could break laziness, at best. - -Consequently, we insist that the number of strictness-info items is -exactly the same as the number of lambda-bound arguments. (This is -probably slightly paranoid, but OK in practice.) If it isn't the -same, we ``revise'' the strictness info, so that we won't propagate -the unusable strictness-info into the interfaces. - - -************************************************************************ -* * -\subsection{The worker wrapper core} -* * -************************************************************************ - -@mkWwBodies@ is called when doing the worker\/wrapper split inside a module. --} - -type WwResult - = ([Demand], -- Demands for worker (value) args - JoinArity, -- Number of worker (type OR value) args - Id -> CoreExpr, -- Wrapper body, lacking only the worker Id - CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs - -mkWwBodies :: DynFlags - -> FamInstEnvs - -> VarSet -- Free vars of RHS - -- See Note [Freshen WW arguments] - -> Maybe JoinArity -- Just ar <=> is join point with join arity ar - -> Type -- Type of original function - -> [Demand] -- Strictness of original function - -> DmdResult -- Info about function result - -> UniqSM (Maybe WwResult) - --- wrap_fn_args E = \x y -> E --- work_fn_args E = E x y - --- wrap_fn_str E = case x of { (a,b) -> --- case a of { (a1,a2) -> --- E a1 a2 b y }} --- work_fn_str E = \a2 a2 b y -> --- let a = (a1,a2) in --- let x = (a,b) in --- E - -mkWwBodies dflags fam_envs rhs_fvs mb_join_arity fun_ty demands res_info - = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs) - -- See Note [Freshen WW arguments] - - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs empty_subst fun_ty demands - ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags fam_envs wrap_args - - -- Do CPR w/w. See Note [Always do CPR w/w] - ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) - <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty res_info - - ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty - worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] - wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var - worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args - - ; if isWorkerSmallEnough dflags work_args - && not (too_many_args_for_join_point wrap_args) - && (useful1 && not only_one_void_argument || useful2) - then return (Just (worker_args_dmds, length work_call_args, - wrapper_body, worker_body)) - else return Nothing - } - -- We use an INLINE unconditionally, even if the wrapper turns out to be - -- something trivial like - -- fw = ... - -- f = __inline__ (coerce T fw) - -- The point is to propagate the coerce to f's call sites, so even though - -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent - -- fw from being inlined into f's RHS - where - -- Note [Do not split void functions] - only_one_void_argument - | [d] <- demands - , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty - , isAbsDmd d && isVoidTy arg_ty1 - = True - | otherwise - = False - - -- Note [Join points returning functions] - too_many_args_for_join_point wrap_args - | Just join_arity <- mb_join_arity - , wrap_args `lengthExceeds` join_arity - = WARN(True, text "Unable to worker/wrapper join point with arity " <+> - int join_arity <+> text "but" <+> - int (length wrap_args) <+> text "args") - True - | otherwise - = False - --- See Note [Limit w/w arity] -isWorkerSmallEnough :: DynFlags -> [Var] -> Bool -isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags - -- We count only Free variables (isId) to skip Type, Kind - -- variables which have no runtime representation. - -{- -Note [Always do CPR w/w] -~~~~~~~~~~~~~~~~~~~~~~~~ -At one time we refrained from doing CPR w/w for thunks, on the grounds that -we might duplicate work. But that is already handled by the demand analyser, -which doesn't give the CPR proprety if w/w might waste work: see -Note [CPR for thunks] in DmdAnal. - -And if something *has* been given the CPR property and we don't w/w, it's -a disaster, because then the enclosing function might say it has the CPR -property, but now doesn't and there a cascade of disaster. A good example -is Trac #5920. - -Note [Limit w/w arity] -~~~~~~~~~~~~~~~~~~~~~~~~ -Guard against high worker arity as it generates a lot of stack traffic. -A simplified example is Trac #11565#comment:6 - -Current strategy is very simple: don't perform w/w transformation at all -if the result produces a wrapper with arity higher than -fmax-worker-args=. - -It is a bit all or nothing, consider - - f (x,y) (a,b,c,d,e ... , z) = rhs - -Currently we will remove all w/w ness entirely. But actually we could -w/w on the (x,y) pair... it's the huge product that is the problem. - -Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd -solve f. But we can get a lot of args from deeply-nested products: - - g (a, (b, (c, (d, ...)))) = rhs - -This is harder to spot on an arg-by-arg basis. Previously mkWwStr was -given some "fuel" saying how many arguments it could add; when we ran -out of fuel it would stop w/wing. -Still not very clever because it had a left-right bias. - -************************************************************************ -* * -\subsection{Making wrapper args} -* * -************************************************************************ - -During worker-wrapper stuff we may end up with an unlifted thing -which we want to let-bind without losing laziness. So we -add a void argument. E.g. - - f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z -==> - fw = /\ a -> \void -> E - f = /\ a -> \x y z -> fw realworld - -We use the state-token type which generates no code. --} - -mkWorkerArgs :: DynFlags -> [Var] - -> Type -- Type of body - -> ([Var], -- Lambda bound args - [Var]) -- Args at call site -mkWorkerArgs dflags args res_ty - | any isId args || not needsAValueLambda - = (args, args) - | otherwise - = (args ++ [voidArgId], args ++ [voidPrimId]) - where - needsAValueLambda = - isUnliftedType res_ty - || not (gopt Opt_FunToThunk dflags) - -- see Note [Protecting the last value argument] - -{- -Note [Protecting the last value argument] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the user writes (\_ -> E), they might be intentionally disallowing -the sharing of E. Since absence analysis and worker-wrapper are keen -to remove such unused arguments, we add in a void argument to prevent -the function from becoming a thunk. - -The user can avoid adding the void argument with the -ffun-to-thunk -flag. However, this can create sharing, which may be bad in two ways. 1) It can -create a space leak. 2) It can prevent inlining *under a lambda*. If w/w -removes the last argument from a function f, then f now looks like a thunk, and -so f can't be inlined *under a lambda*. - -Note [Join points and beta-redexes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Originally, the worker would invoke the original function by calling it with -arguments, thus producing a beta-redex for the simplifier to munch away: - - \x y z -> e => (\x y z -> e) wx wy wz - -Now that we have special rules about join points, however, this is Not Good if -the original function is itself a join point, as then it may contain invocations -of other join points: - - join j1 x = ... - join j2 y = if y == 0 then 0 else j1 y - - => - - join j1 x = ... - join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy - join j2 y = case y of I# y# -> jump $wj2 y# - -There can't be an intervening lambda between a join point's declaration and its -occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix: - - ... - let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y - ... - -Hence we simply do the beta-reduction here. (This would be harder if we had to -worry about hygiene, but luckily wy is freshly generated.) - -Note [Join points returning functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -It is crucial that the arity of a join point depends on its *callers,* not its -own syntax. What this means is that a join point can have "extra lambdas": - -f :: Int -> Int -> (Int, Int) -> Int -f x y = join j (z, w) = \(u, v) -> ... - in jump j (x, y) - -Typically this happens with functions that are seen as computing functions, -rather than being curried. (The real-life example was GraphOps.addConflicts.) - -When we create the wrapper, it *must* be in "eta-contracted" form so that the -jump has the right number of arguments: - -f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... - j (z, w) = jump $wj z w - -(See Note [Join points and beta-redexes] for where the lets come from.) If j -were a function, we would instead say - -f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... - j (z, w) (u, v) = $wj z w u v - -Notice that the worker ends up with the same lambdas; it's only the wrapper we -have to be concerned about. - -FIXME Currently the functionality to produce "eta-contracted" wrappers is -unimplemented; we simply give up. - -************************************************************************ -* * -\subsection{Coercion stuff} -* * -************************************************************************ - -We really want to "look through" coerces. -Reason: I've seen this situation: - - let f = coerce T (\s -> E) - in \x -> case x of - p -> coerce T' f - q -> \s -> E2 - r -> coerce T' f - -If only we w/w'd f, we'd get - let f = coerce T (\s -> fw s) - fw = \s -> E - in ... - -Now we'll inline f to get - - let fw = \s -> E - in \x -> case x of - p -> fw - q -> \s -> E2 - r -> fw - -Now we'll see that fw has arity 1, and will arity expand -the \x to get what we want. --} - --- mkWWargs just does eta expansion --- is driven off the function type and arity. --- It chomps bites off foralls, arrows, newtypes --- and keeps repeating that until it's satisfied the supplied arity - -mkWWargs :: TCvSubst -- Freshening substitution to apply to the type - -- See Note [Freshen WW arguments] - -> Type -- The type of the function - -> [Demand] -- Demands and one-shot info for value arguments - -> UniqSM ([Var], -- Wrapper args - CoreExpr -> CoreExpr, -- Wrapper fn - CoreExpr -> CoreExpr, -- Worker fn - Type) -- Type of wrapper body - -mkWWargs subst fun_ty demands - | null demands - = return ([], id, id, substTy subst fun_ty) - - | (dmd:demands') <- demands - , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty - = do { uniq <- getUniqueM - ; let arg_ty' = substTy subst arg_ty - id = mk_wrap_arg uniq arg_ty' dmd - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst fun_ty' demands' - ; return (id : wrap_args, - Lam id . wrap_fn_args, - apply_or_bind_then work_fn_args (varToCoreExpr id), - res_ty) } - - | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty - = do { uniq <- getUniqueM - ; let (subst', tv') = cloneTyVarBndr subst tv uniq - -- See Note [Freshen WW arguments] - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst' fun_ty' demands - ; return (tv' : wrap_args, - Lam tv' . wrap_fn_args, - apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')), - res_ty) } - - | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty - -- The newtype case is for when the function has - -- a newtype after the arrow (rare) - -- - -- It's also important when we have a function returning (say) a pair - -- wrapped in a newtype, at least if CPR analysis can look - -- through such newtypes, which it probably can since they are - -- simply coerces. - - = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst rep_ty demands - ; let co' = substCo subst co - ; return (wrap_args, - \e -> Cast (wrap_fn_args e) (mkSymCo co'), - \e -> work_fn_args (Cast e co'), - res_ty) } - - | otherwise - = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand - return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow - where - -- See Note [Join points and beta-redexes] - apply_or_bind_then k arg (Lam bndr body) - = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh! - apply_or_bind_then k arg fun - = k $ mkCoreApp (text "mkWWargs") fun arg -applyToVars :: [Var] -> CoreExpr -> CoreExpr -applyToVars vars fn = mkVarApps fn vars - -mk_wrap_arg :: Unique -> Type -> Demand -> Id -mk_wrap_arg uniq ty dmd - = mkSysLocalOrCoVar (fsLit "w") uniq ty - `setIdDemandInfo` dmd - -{- Note [Freshen WW arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Wen we do a worker/wrapper split, we must not in-scope names as the arguments -of the worker, else we'll get name capture. E.g. - - -- y1 is in scope from further out - f x = ..y1.. - -If we accidentally choose y1 as a worker argument disaster results: - - fww y1 y2 = let x = (y1,y2) in ...y1... - -To avoid this: - - * We use a fresh unique for both type-variable and term-variable binders - Originally we lacked this freshness for type variables, and that led - to the very obscure Trac #12562. (A type variable in the worker shadowed - an outer term-variable binding.) - - * Because of this cloning we have to substitute in the type/kind of the - new binders. That's why we carry the TCvSubst through mkWWargs. - - So we need a decent in-scope set, just in case that type/kind - itself has foralls. We get this from the free vars of the RHS of the - function since those are the only variables that might be captured. - It's a lazy thunk, which will only be poked if the type/kind has a forall. - - Another tricky case was when f :: forall a. a -> forall a. a->a - (i.e. with shadowing), and then the worker used the same 'a' twice. - -************************************************************************ -* * -\subsection{Strictness stuff} -* * -************************************************************************ --} - -mkWWstr :: DynFlags - -> FamInstEnvs - -> [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 _ _ [] - = return (False, [], nop_fn, nop_fn) - -mkWWstr dflags fam_envs (arg : args) = do - (useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags fam_envs arg - (useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags fam_envs args - return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2) - -{- -Note [Unpacking arguments with product and polymorphic demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The argument is unpacked in a case if it has a product type and has a -strict *and* used demand put on it. I.e., arguments, with demands such -as the following ones: - - - - -will be unpacked, but - - or - -will not, because the pieces aren't used. This is quite important otherwise -we end up unpacking massive tuples passed to the bottoming function. Example: - - f :: ((Int,Int) -> String) -> (Int,Int) -> a - f g pr = error (g pr) - - main = print (f fst (1, error "no")) - -Does 'main' print "error 1" or "error no"? We don't really want 'f' -to unbox its second argument. This actually happened in GHC's onwn -source code, in Packages.applyPackageFlag, which ended up un-boxing -the enormous DynFlags tuple, and being strict in the -as-yet-un-filled-in pkgState files. --} - ----------------------- --- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn) --- * wrap_fn assumes wrap_arg is in scope, --- brings into scope work_args (via cases) --- * work_fn assumes work_args are in scope, a --- brings into scope wrap_arg (via lets) -mkWWstr_one :: DynFlags -> FamInstEnvs -> Var - -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -mkWWstr_one dflags fam_envs arg - | isTyVar arg - = return (False, [arg], nop_fn, nop_fn) - - -- See Note [Worker-wrapper for bottoming functions] - | isAbsDmd dmd - , Just work_fn <- mk_absent_let dflags arg - -- Absent case. We can't always handle absence for arbitrary - -- unlifted types, so we need to choose just the cases we can - --- (that's what mk_absent_let does) - = return (True, [], nop_fn, work_fn) - - -- See Note [Worthy functions for Worker-Wrapper split] - | isSeqDmd dmd -- `seq` demand; evaluate in wrapper in the hope - -- of dropping seqs in the worker - = let arg_w_unf = arg `setIdUnfolding` evaldUnfolding - -- Tell the worker arg that it's sure to be evaluated - -- so that internal seqs can be dropped - in return (True, [arg_w_unf], mk_seq_case arg, nop_fn) - -- Pass the arg, anyway, even if it is in theory discarded - -- Consider - -- f x y = x `seq` y - -- x gets a (Eval (Poly Abs)) demand, but if we fail to pass it to the worker - -- we ABSOLUTELY MUST record that x is evaluated in the wrapper. - -- Something like: - -- f x y = x `seq` fw y - -- fw y = let x{Evald} = error "oops" in (x `seq` y) - -- If we don't pin on the "Evald" flag, the seq doesn't disappear, and - -- we end up evaluating the absent thunk. - -- But the Evald flag is pretty weird, and I worry that it might disappear - -- during simplification, so for now I've just nuked this whole case - - | isStrictDmd dmd - , Just cs <- splitProdDmd_maybe dmd - -- See Note [Unpacking arguments with product and polymorphic demands] - , Just (data_con, inst_tys, inst_con_arg_tys, co) - <- deepSplitProductType_maybe fam_envs (idType arg) - , cs `equalLength` inst_con_arg_tys - -- See Note [mkWWstr and unsafeCoerce] - = do { (uniq1:uniqs) <- getUniquesM - ; let unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs - unbox_fn = mkUnpackCase (Var arg) co uniq1 - data_con unpk_args - rebox_fn = Let (NonRec arg con_app) - con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co - ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs unpk_args - ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) } - -- Don't pass the arg, rebox instead - - | otherwise -- Other cases - = return (False, [arg], nop_fn, nop_fn) - - where - dmd = idDemandInfo arg - mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd - ----------------------- -nop_fn :: CoreExpr -> CoreExpr -nop_fn body = body - -{- -Note [mkWWstr and unsafeCoerce] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -By using unsafeCoerce, it is possible to make the number of demands fail to -match the number of constructor arguments; this happened in Trac #8037. -If so, the worker/wrapper split doesn't work right and we get a Core Lint -bug. The fix here is simply to decline to do w/w if that happens. - -Note [Record evaluated-ness in worker/wrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - data T = MkT !Int Int - - f :: T -> T - f x = e - -and f's is strict, and has the CPR property. The we are going to generate -this w/w split - - f x = case x of - MkT x1 x2 -> case $wf x1 x2 of - (# r1, r2 #) -> MkT r1 r2 - - $wfw x1 x2 = let x = MkT x1 x2 in - case e of - MkT r1 r2 -> (# r1, r2 #) - -Note that - -* In the worker $wf, inside 'e' we can be sure that x1 will be - evaluated (it came from unpacking the argument MkT. But that's no - immediately apparent in $wf - -* In the wrapper 'f', which we'll inline at call sites, we can be sure - that 'r1' has been evaluated (because it came from unpacking the result - MkT. But that is not immediately apparent from the wrapper code. - -Missing these facts isn't unsound, but it loses possible future -opportunities for optimisation. - -Solution: use setCaseBndrEvald when creating - (A) The arg binders x1,x2 in mkWstr_one - See Trac #13077, test T13077 - (B) The result binders r1,r2 in mkWWcpr_help - See Trace #13077, test T13077a - And Trac #13027 comment:20, item (4) -to record that the relevant binder is evaluated. - - -************************************************************************ -* * - Type scrutiny that is specific to demand analysis -* * -************************************************************************ - -Note [Do not unpack class dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - f :: Ord a => [a] -> Int -> a - {-# INLINABLE f #-} -and we worker/wrapper f, we'll get a worker with an INLINABLE pragma -(see Note [Worker-wrapper for INLINABLE functions] in WorkWrap), which -can still be specialised by the type-class specialiser, something like - fw :: Ord a => [a] -> Int# -> a - -BUT if f is strict in the Ord dictionary, we might unpack it, to get - fw :: (a->a->Bool) -> [a] -> Int# -> a -and the type-class specialiser can't specialise that. An example is -Trac #6056. - -Moreover, dictionaries can have a lot of fields, so unpacking them can -increase closure sizes. - -Conclusion: don't unpack dictionaries. --} - -deepSplitProductType_maybe - :: FamInstEnvs -> Type - -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion) --- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co) --- then dc @ tys (args::arg_tys) :: rep_ty --- co :: ty ~ rep_ty --- Why do we return the strictness of the data-con arguments? --- Answer: see Note [Record evaluated-ness in worker/wrapper] -deepSplitProductType_maybe fam_envs ty - | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkRepReflCo ty, ty) - , Just (tc, tc_args) <- splitTyConApp_maybe ty1 - , Just con <- isDataProductTyCon_maybe tc - , not (isClassTyCon tc) -- See Note [Do not unpack class dictionaries] - , let arg_tys = dataConInstArgTys con tc_args - strict_marks = dataConRepStrictness con - = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co) -deepSplitProductType_maybe _ _ = Nothing - -deepSplitCprType_maybe - :: FamInstEnvs -> ConTag -> Type - -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion) --- If deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co) --- then dc @ tys (args::arg_tys) :: rep_ty --- co :: ty ~ rep_ty --- Why do we return the strictness of the data-con arguments? --- Answer: see Note [Record evaluated-ness in worker/wrapper] -deepSplitCprType_maybe fam_envs con_tag ty - | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkRepReflCo ty, ty) - , Just (tc, tc_args) <- splitTyConApp_maybe ty1 - , isDataTyCon tc - , let cons = tyConDataCons tc - , cons `lengthAtLeast` con_tag -- This might not be true if we import the - -- type constructor via a .hs-bool file (#8743) - , let con = cons `getNth` (con_tag - fIRST_TAG) - arg_tys = dataConInstArgTys con tc_args - strict_marks = dataConRepStrictness con - = Just (con, tc_args, zipEqual "dsct" arg_tys strict_marks, co) -deepSplitCprType_maybe _ _ _ = Nothing - -findTypeShape :: FamInstEnvs -> Type -> TypeShape --- Uncover the arrow and product shape of a type --- The data type TypeShape is defined in Demand --- See Note [Trimming a demand to a type] in Demand -findTypeShape fam_envs ty - | Just (tc, tc_args) <- splitTyConApp_maybe ty - , Just con <- isDataProductTyCon_maybe tc - = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args) - - | Just (_, res) <- splitFunTy_maybe ty - = TsFun (findTypeShape fam_envs res) - - | Just (_, ty') <- splitForAllTy_maybe ty - = findTypeShape fam_envs ty' - - | Just (_, ty') <- topNormaliseType_maybe fam_envs ty - = findTypeShape fam_envs ty' - - | otherwise - = TsUnk - -{- -************************************************************************ -* * -\subsection{CPR stuff} -* * -************************************************************************ - - -@mkWWcpr@ takes the worker/wrapper pair produced from the strictness -info and adds in the CPR transformation. The worker returns an -unboxed tuple containing non-CPR components. The wrapper takes this -tuple and re-produces the correct structured output. - -The non-CPR results appear ordered in the unboxed tuple as if by a -left-to-right traversal of the result structure. --} - -mkWWcpr :: Bool - -> FamInstEnvs - -> Type -- function body type - -> DmdResult -- CPR analysis results - -> UniqSM (Bool, -- Is w/w'ing useful? - CoreExpr -> CoreExpr, -- New wrapper - CoreExpr -> CoreExpr, -- New worker - Type) -- Type of worker's body - -mkWWcpr opt_CprAnal fam_envs body_ty res - -- CPR explicitly turned off (or in -O0) - | not opt_CprAnal = return (False, id, id, body_ty) - -- CPR is turned on by default for -O and O2 - | otherwise - = case returnsCPR_maybe res of - Nothing -> return (False, id, id, body_ty) -- No CPR info - Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty - -> mkWWcpr_help stuff - | otherwise - -- See Note [non-algebraic or open body type warning] - -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty ) - return (False, id, id, body_ty) - -mkWWcpr_help :: (DataCon, [Type], [(Type,StrictnessMark)], Coercion) - -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) - -mkWWcpr_help (data_con, inst_tys, arg_tys, co) - | [arg1@(arg_ty1, _)] <- arg_tys - , isUnliftedType arg_ty1 - -- Special case when there is a single result of unlifted type - -- - -- Wrapper: case (..call worker..) of x -> C x - -- Worker: case ( ..body.. ) of C x -> x - = do { (work_uniq : arg_uniq : _) <- getUniquesM - ; let arg = mk_ww_local arg_uniq arg1 - con_app = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co - - ; return ( True - , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)] - , \ body -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg) - -- varToCoreExpr important here: arg can be a coercion - -- Lacking this caused Trac #10658 - , arg_ty1 ) } - - | otherwise -- The general case - -- Wrapper: case (..call worker..) of (# a, b #) -> C a b - -- Worker: case ( ...body... ) of C a b -> (# a, b #) - = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM - ; let wrap_wild = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict) - args = zipWith mk_ww_local uniqs arg_tys - ubx_tup_ty = exprType ubx_tup_app - ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args) - con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co - - ; return (True - , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)] - , \ body -> mkUnpackCase body co work_uniq data_con args ubx_tup_app - , ubx_tup_ty ) } - -mkUnpackCase :: CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr --- (mkUnpackCase e co uniq Con args body) --- returns --- case e |> co of bndr { Con args -> body } - -mkUnpackCase (Tick tickish e) co uniq con args body -- See Note [Profiling and unpacking] - = Tick tickish (mkUnpackCase e co uniq con args body) -mkUnpackCase scrut co uniq boxing_con unpk_args body - = Case casted_scrut bndr (exprType body) - [(DataAlt boxing_con, unpk_args, body)] - where - casted_scrut = scrut `mkCast` co - bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict) - -{- -Note [non-algebraic or open body type warning] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a few cases where the W/W transformation is told that something -returns a constructor, but the type at hand doesn't really match this. One -real-world example involves unsafeCoerce: - foo = IO a - foo = unsafeCoerce c_exit - foreign import ccall "c_exit" c_exit :: IO () -Here CPR will tell you that `foo` returns a () constructor for sure, but trying -to create a worker/wrapper for type `a` obviously fails. -(This was a real example until ee8e792 in libraries/base.) - -It does not seem feasible to avoid all such cases already in the analyser (and -after all, the analysis is not really wrong), so we simply do nothing here in -mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch -other cases where something went avoidably wrong. - - -Note [Profiling and unpacking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the original function looked like - f = \ x -> {-# SCC "foo" #-} E - -then we want the CPR'd worker to look like - \ x -> {-# SCC "foo" #-} (case E of I# x -> x) -and definitely not - \ x -> case ({-# SCC "foo" #-} E) of I# x -> x) - -This transform doesn't move work or allocation -from one cost centre to another. - -Later [SDM]: presumably this is because we want the simplifier to -eliminate the case, and the scc would get in the way? I'm ok with -including the case itself in the cost centre, since it is morally -part of the function (post transformation) anyway. - - -************************************************************************ -* * -\subsection{Utilities} -* * -************************************************************************ - -Note [Absent errors] -~~~~~~~~~~~~~~~~~~~~ -We make a new binding for Ids that are marked absent, thus - let x = absentError "x :: Int" -The idea is that this binding will never be used; but if it -buggily is used we'll get a runtime error message. - -Coping with absence for *unlifted* types is important; see, for -example, Trac #4306. For these we find a suitable literal, -using Literal.absentLiteralOf. We don't have literals for -every primitive type, so the function is partial. - -Note: I did try the experiment of using an error thunk for unlifted -things too, relying on the simplifier to drop it as dead code. -But this is fragile - - - It fails when profiling is on, which disables various optimisations - - - It fails when reboxing happens. E.g. - data T = MkT Int Int# - f p@(MkT a _) = ...g p.... - where g is /lazy/ in 'p', but only uses the first component. Then - 'f' is /strict/ in 'p', and only uses the first component. So we only - pass that component to the worker for 'f', which reconstructs 'p' to - pass it to 'g'. Alas we can't say - ...f (MkT a (absentError Int# "blah"))... - bacause `MkT` is strict in its Int# argument, so we get an absentError - exception when we shouldn't. Very annoying! - -So absentError is only used for lifted types. --} - -mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr) -mk_absent_let dflags arg - | not (isUnliftedType arg_ty) - = Just (Let (NonRec lifted_arg abs_rhs)) - | Just tc <- tyConAppTyCon_maybe arg_ty - , Just lit <- absentLiteralOf tc - = Just (Let (NonRec arg (Lit lit))) - | arg_ty `eqType` voidPrimTy - = Just (Let (NonRec arg (Var voidPrimId))) - | otherwise - = WARN( True, text "No absent value for" <+> ppr arg_ty ) - Nothing - where - lifted_arg = arg `setIdStrictness` exnSig - -- Note in strictness signature that this is bottoming - -- (for the sake of the "empty case scrutinee not known to - -- diverge for sure lint" warning) - arg_ty = idType arg - abs_rhs = mkAbsentErrorApp arg_ty msg - msg = showSDoc (gopt_set dflags Opt_SuppressUniques) - (ppr arg <+> ppr (idType arg)) - -- We need to suppress uniques here because otherwise they'd - -- end up in the generated code as strings. This is bad for - -- determinism, because with different uniques the strings - -- will have different lengths and hence different costs for - -- the inliner leading to different inlining. - -- See also Note [Unique Determinism] in Unique - -mk_seq_case :: Id -> CoreExpr -> CoreExpr -mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)] - -sanitiseCaseBndr :: Id -> Id --- The argument we are scrutinising has the right type to be --- a case binder, so it's convenient to re-use it for that purpose. --- But we *must* throw away all its IdInfo. In particular, the argument --- will have demand info on it, and that demand info may be incorrect for --- the case binder. e.g. case ww_arg of ww_arg { I# x -> ... } --- Quite likely ww_arg isn't used in '...'. The case may get discarded --- if the case binder says "I'm demanded". This happened in a situation --- like (x+y) `seq` .... -sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo - -mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id --- The StrictnessMark comes form the data constructor and says --- whether this field is strict --- See Note [Record evaluated-ness in worker/wrapper] -mk_ww_local uniq (ty,str) - = setCaseBndrEvald str $ - mkSysLocalOrCoVar (fsLit "ww") uniq ty diff --git a/typecheck/FamInst.hs b/typecheck/FamInst.hs deleted file mode 100644 --- a/typecheck/FamInst.hs +++ /dev/null @@ -1,918 +0,0 @@ --- The @FamInst@ type: family instance heads - -{-# LANGUAGE CPP, GADTs #-} - -module FamInst ( - FamInstEnvs, tcGetFamInstEnvs, - checkFamInstConsistency, tcExtendLocalFamInstEnv, - tcLookupDataFamInst, tcLookupDataFamInst_maybe, - tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe, - checkRecFamInstConsistency, - newFamInst, - - -- * Injectivity - makeInjectivityErrors, injTyVarsOfType, injTyVarsOfTypes - ) where - -import HscTypes -import FamInstEnv -import InstEnv( roughMatchTcs ) -import Coercion -import TcEvidence -import LoadIface -import TcRnMonad -import SrcLoc -import TyCon -import TcType -import CoAxiom -import DynFlags -import Module -import Outputable -import Util -import RdrName -import DataCon ( dataConName ) -import Maybes -import Type -import TyCoRep -import TcMType -import Name -import Pair -import Panic -import VarSet -import Bag( Bag, unionBags, unitBag ) -import Control.Monad -import Unique -import NameEnv -import Data.Set (Set) -import qualified Data.Set as Set -import Data.List - -#include "HsVersions.h" - -{- - -Note [The type family instance consistency story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To preserve type safety we must ensure that for any given module, all -the type family instances used either in that module or in any module -it directly or indirectly imports are consistent. For example, consider - - module F where - type family F a - - module A where - import F( F ) - type instance F Int = Bool - f :: F Int -> Bool - f x = x - - module B where - import F( F ) - type instance F Int = Char - g :: Char -> F Int - g x = x - - module Bad where - import A( f ) - import B( g ) - bad :: Char -> Int - bad c = f (g c) - -Even though module Bad never mentions the type family F at all, by -combining the functions f and g that were type checked in contradictory -type family instance environments, the function bad is able to coerce -from one type to another. So when we type check Bad we must verify that -the type family instances defined in module A are consistent with those -defined in module B. - -How do we ensure that we maintain the necessary consistency? - -* Call a module which defines at least one type family instance a -"family instance module". This flag `mi_finsts` is recorded in the -interface file. - -* For every module we calculate the set of all of its direct and -indirect dependencies that are family instance modules. This list -`dep_finsts` is also recorded in the interface file so we can compute -this list for a module from the lists for its direct dependencies. - -* When type checking a module M we check consistency of all the type -family instances that are either provided by its `dep_finsts` or -defined in the module M itself. This is a pairwise check, i.e., for -every pair of instances we must check that they are consistent. - -- For family instances coming from `dep_finsts`, this is checked in -checkFamInstConsistency, called from tcRnImports, and in -checkRecFamInstConsistency, called from tcTyClGroup. See Note -[Checking family instance consistency] for details on this check (and -in particular how we avoid having to do all these checks for every -module we compile). - -- That leaves checking the family instances defined in M itself -against instances defined in either M or its `dep_finsts`. This is -checked in `tcExtendLocalFamInstEnv'. - -There are two subtle points in this scheme which have not been -addressed yet. - -* We have checked consistency of the family instances *defined* by M -or its imports, but this is not by definition the same thing as the -family instances *used* by M or its imports. Specifically, we need to -ensure when we use a type family instance while compiling M that this -instance was really defined from either M or one of its imports, -rather than being an instance that we happened to know about from -reading an interface file in the course of compiling an unrelated -module. Otherwise, we'll end up with no record of the fact that M -depends on this family instance and type safety will be compromised. -See #13102. - -* It can also happen that M uses a function defined in another module -which is not transitively imported by M. Examples include the -desugaring of various overloaded constructs, and references inserted -by Template Haskell splices. If that function's definition makes use -of type family instances which are not checked against those visible -from M, type safety can again be compromised. See #13251. - -* When a module C imports a boot module B.hs-boot, we check that C's -type family instances are compatible with those visible from -B.hs-boot. However, C will eventually be linked against a different -module B.hs, which might define additional type family instances which -are inconsistent with C's. This can also lead to loss of type safety. -See #9562. - --} - -{- -************************************************************************ -* * - Making a FamInst -* * -************************************************************************ --} - --- All type variables in a FamInst must be fresh. This function --- creates the fresh variables and applies the necessary substitution --- It is defined here to avoid a dependency from FamInstEnv on the monad --- code. - -newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst --- Freshen the type variables of the FamInst branches --- Called from the vectoriser monad too, hence the rather general type -newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc }) - = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax ) - ASSERT2( tyCoVarsOfType rhs `subVarSet` tcv_set, text "rhs" <+> pp_ax ) - ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind ) - do { (subst, tvs') <- freshenTyVarBndrs tvs - ; (subst, cvs') <- freshenCoVarBndrsX subst cvs - ; return (FamInst { fi_fam = tyConName fam_tc - , fi_flavor = flavor - , fi_tcs = roughMatchTcs lhs - , fi_tvs = tvs' - , fi_cvs = cvs' - , fi_tys = substTys subst lhs - , fi_rhs = substTy subst rhs - , fi_axiom = axiom }) } - where - lhs_kind = typeKind (mkTyConApp fam_tc lhs) - rhs_kind = typeKind rhs - tcv_set = mkVarSet (tvs ++ cvs) - pp_ax = pprCoAxiom axiom - CoAxBranch { cab_tvs = tvs - , cab_cvs = cvs - , cab_lhs = lhs - , cab_rhs = rhs } = coAxiomSingleBranch axiom - - -{- -************************************************************************ -* * - Optimised overlap checking for family instances -* * -************************************************************************ - -Note [Checking family instance consistency] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For any two family instance modules that we import directly or indirectly, we -check whether the instances in the two modules are consistent, *unless* we can -be certain that the instances of the two modules have already been checked for -consistency during the compilation of modules that we import. - -Why do we need to check? Consider - module X1 where module X2 where - data T1 data T2 - type instance F T1 b = Int type instance F a T2 = Char - f1 :: F T1 a -> Int f2 :: Char -> F a T2 - f1 x = x f2 x = x - -Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char. -Notice that neither instance is an orphan. - -How do we know which pairs of modules have already been checked? For each -module M we directly import, we look up the family instance modules that M -imports (directly or indirectly), say F1, ..., FN. For any two modules -among M, F1, ..., FN, we know that the family instances defined in those -two modules are consistent--because we checked that when we compiled M. - -For every other pair of family instance modules we import (directly or -indirectly), we check that they are consistent now. (So that we can be -certain that the modules in our `HscTypes.dep_finsts' are consistent.) - -There is some fancy footwork regarding hs-boot module loops, see -Note [Don't check hs-boot type family instances too early] --} - --- The optimisation of overlap tests is based on determining pairs of modules --- whose family instances need to be checked for consistency. --- -data ModulePair = ModulePair Module Module - -- Invariant: first Module < second Module - -- use the smart constructor - --- | Smart constructor that establishes the invariant -modulePair :: Module -> Module -> ModulePair -modulePair a b - | a < b = ModulePair a b - | otherwise = ModulePair b a - -instance Eq ModulePair where - (ModulePair a1 b1) == (ModulePair a2 b2) = a1 == a2 && b1 == b2 - -instance Ord ModulePair where - (ModulePair a1 b1) `compare` (ModulePair a2 b2) = - nonDetCmpModule a1 a2 `thenCmp` - nonDetCmpModule b1 b2 - -- See Note [ModulePairSet determinism and performance] - -instance Outputable ModulePair where - ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2) - --- Fast, nondeterministic comparison on Module. Don't use when the ordering --- can change the ABI. See Note [ModulePairSet determinism and performance] -nonDetCmpModule :: Module -> Module -> Ordering -nonDetCmpModule a b = - nonDetCmpUnique (getUnique $ moduleUnitId a) (getUnique $ moduleUnitId b) - `thenCmp` - nonDetCmpUnique (getUnique $ moduleName a) (getUnique $ moduleName b) - -type ModulePairSet = Set ModulePair -{- -Note [ModulePairSet determinism and performance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The size of ModulePairSet is quadratic in the number of modules. -The Ord instance for Module uses string comparison which is linear in the -length of ModuleNames and UnitIds. This adds up to a significant cost, see -#12191. - -To get reasonable performance ModulePairSet uses nondeterministic ordering -on Module based on Uniques. It doesn't affect the ABI, because it only -determines the order the modules are checked for family instance consistency. -See Note [Unique Determinism] in Unique --} - -listToSet :: [ModulePair] -> ModulePairSet -listToSet l = Set.fromList l - --- | Check family instance consistency, given: --- --- 1. The list of all modules transitively imported by us --- which define a family instance (these are the ones --- we have to check for consistency), and --- --- 2. The list of modules which we directly imported --- (these specify the sets of family instance defining --- modules which are already known to be consistent). --- --- See Note [Checking family instance consistency] for more --- details, and Note [The type family instance consistency story] --- for the big picture. --- --- This function doesn't check ALL instances for consistency, --- only ones that aren't involved in recursive knot-tying --- loops; see Note [Don't check hs-boot type family instances too early]. --- It returns a modified 'TcGblEnv' that has saved the --- instances that need to be checked later; use 'checkRecFamInstConsistency' --- to check those. -checkFamInstConsistency :: [Module] -> [Module] -> TcM TcGblEnv -checkFamInstConsistency famInstMods directlyImpMods - = do { dflags <- getDynFlags - ; (eps, hpt) <- getEpsAndHpt - ; let { -- Fetch the iface of a given module. Must succeed as - -- all directly imported modules must already have been loaded. - modIface mod = - case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of - Nothing -> panicDoc "FamInst.checkFamInstConsistency" - (ppr mod $$ pprHPT hpt) - Just iface -> iface - - -- Which modules were checked for consistency when we compiled - -- `mod`? Itself and its dep_finsts. - ; modConsistent mod = mod : (dep_finsts . mi_deps . modIface $ mod) - - ; hmiModule = mi_module . hm_iface - ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv - . md_fam_insts . hm_details - ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) - | hmi <- eltsHpt hpt] - ; groups = map modConsistent directlyImpMods - ; okPairs = listToSet $ concatMap allPairs groups - -- instances of okPairs are consistent - ; criticalPairs = listToSet $ allPairs famInstMods - -- all pairs that we need to consider - ; toCheckPairs = - Set.elems $ criticalPairs `Set.difference` okPairs - -- the difference gives us the pairs we need to check now - -- See Note [ModulePairSet determinism and performance] - } - - ; pending_checks <- mapM (check hpt_fam_insts) toCheckPairs - ; tcg_env <- getGblEnv - ; return tcg_env { tcg_pending_fam_checks - = foldl' (plusNameEnv_C (++)) emptyNameEnv pending_checks } - } - where - allPairs [] = [] - allPairs (m:ms) = map (modulePair m) ms ++ allPairs ms - - check hpt_fam_insts (ModulePair m1 m2) - = do { env1' <- getFamInsts hpt_fam_insts m1 - ; env2' <- getFamInsts hpt_fam_insts m2 - -- We're checking each element of env1 against env2. - -- The cost of that is dominated by the size of env1, because - -- for each instance in env1 we look it up in the type family - -- environment env2, and lookup is cheap. - -- The code below ensures that env1 is the smaller environment. - ; let sizeE1 = famInstEnvSize env1' - sizeE2 = famInstEnvSize env2' - (env1, env2) = if sizeE1 < sizeE2 then (env1', env2') - else (env2', env1') - -- Note [Don't check hs-boot type family instances too early] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Family instance consistency checking involves checking that - -- the family instances of our imported modules are consistent with - -- one another; this might lead you to think that this process - -- has nothing to do with the module we are about to typecheck. - -- Not so! Consider the following case: - -- - -- -- A.hs-boot - -- type family F a - -- - -- -- B.hs - -- import {-# SOURCE #-} A - -- type instance F Int = Bool - -- - -- -- A.hs - -- import B - -- type family F a - -- - -- When typechecking A, we are NOT allowed to poke the TyThing - -- for for F until we have typechecked the family. Thus, we - -- can't do consistency checking for the instance in B - -- (checkFamInstConsistency is called during renaming). - -- Failing to defer the consistency check lead to #11062. - -- - -- Additionally, we should also defer consistency checking when - -- type from the hs-boot file of the current module occurs on - -- the left hand side, as we will poke its TyThing when checking - -- for overlap. - -- - -- -- F.hs - -- type family F a - -- - -- -- A.hs-boot - -- import F - -- data T - -- - -- -- B.hs - -- import {-# SOURCE #-} A - -- import F - -- type instance F T = Int - -- - -- -- A.hs - -- import B - -- data T = MkT - -- - -- However, this is not yet done; see #13981. - -- - -- Note that it is NOT necessary to defer for occurrences in the - -- RHS (e.g., type instance F Int = T, in the above example), - -- since that never participates in consistency checking - -- in any nontrivial way. - -- - -- Why don't we defer ALL of the checks to later? Well, many - -- instances aren't involved in the recursive loop at all. So - -- we might as well check them immediately; and there isn't - -- a good time to check them later in any case: every time - -- we finish kind-checking a type declaration and add it to - -- a context, we *then* consistency check all of the instances - -- which mentioned that type. We DO want to check instances - -- as quickly as possible, so that we aren't typechecking - -- values with inconsistent axioms in scope. - -- - -- See also Note [Tying the knot] and Note [Type-checking inside the knot] - -- for why we are doing this at all. - ; this_mod <- getModule - -- NB: == this_mod only holds if there's an hs-boot file; - -- otherwise we cannot possible see instances for families - -- defined by the module we are compiling in imports. - ; let shouldCheckNow = ((/= this_mod) . nameModule . fi_fam) - (check_now, check_later) = - partition shouldCheckNow (famInstEnvElts env1) - ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) check_now - ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now - ; let check_later_map = - extendNameEnvList_C (++) emptyNameEnv - [(fi_fam finst, [finst]) | finst <- check_later] - ; return (mapNameEnv (\xs -> [(xs, env2)]) check_later_map) - } - --- | Given a 'TyCon' that has been incorporated into the type --- environment (the knot is tied), if it is a type family, check --- that all deferred instances for it are consistent. --- See Note [Don't check hs-boot type family instances too early] -checkRecFamInstConsistency :: TyCon -> TcM () -checkRecFamInstConsistency tc = do - tcg_env <- getGblEnv - let checkConsistency tc - | isFamilyTyCon tc - , Just pairs <- lookupNameEnv (tcg_pending_fam_checks tcg_env) - (tyConName tc) - = forM_ pairs $ \(check_now, env2) -> do - mapM_ (checkForConflicts (emptyFamInstEnv, env2)) check_now - mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now - | otherwise - = return () - checkConsistency tc - - -getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv -getFamInsts hpt_fam_insts mod - | Just env <- lookupModuleEnv hpt_fam_insts mod = return env - | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod) - ; eps <- getEps - ; return (expectJust "checkFamInstConsistency" $ - lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } - where - doc = ppr mod <+> text "is a family-instance module" - -{- -************************************************************************ -* * - Lookup -* * -************************************************************************ - --} - --- | If @co :: T ts ~ rep_ty@ then: --- --- > instNewTyCon_maybe T ts = Just (rep_ty, co) --- --- Checks for a newtype, and for being saturated --- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion -tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion) -tcInstNewTyCon_maybe = instNewTyCon_maybe - --- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if --- there is no data family to unwrap. --- Returns a Representational coercion -tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType] - -> (TyCon, [TcType], Coercion) -tcLookupDataFamInst fam_inst_envs tc tc_args - | Just (rep_tc, rep_args, co) - <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args - = (rep_tc, rep_args, co) - | otherwise - = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args)) - -tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType] - -> Maybe (TyCon, [TcType], Coercion) --- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a) --- and returns a coercion between the two: co :: F [a] ~R FList a. -tcLookupDataFamInst_maybe fam_inst_envs tc tc_args - | isDataFamilyTyCon tc - , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args - , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax - , fi_cvs = cvs }) - , fim_tys = rep_args - , fim_cos = rep_cos } <- match - , let rep_tc = dataFamInstRepTyCon rep_fam - co = mkUnbranchedAxInstCo Representational ax rep_args - (mkCoVarCos cvs) - = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in FamInstEnv - Just (rep_tc, rep_args, co) - - | otherwise - = Nothing - --- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes, --- potentially looking through newtype /instances/. --- --- It is only used by the type inference engine (specifically, when --- solving representational equality), and hence it is careful to unwrap --- only if the relevant data constructor is in scope. That's why --- it get a GlobalRdrEnv argument. --- --- It is careful not to unwrap data/newtype instances if it can't --- continue unwrapping. Such care is necessary for proper error --- messages. --- --- It does not look through type families. --- It does not normalise arguments to a tycon. --- --- If the result is Just (rep_ty, (co, gres), rep_ty), then --- co : ty ~R rep_ty --- gres are the GREs for the data constructors that --- had to be in scope -tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs - -> GlobalRdrEnv - -> Type - -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type) -tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty --- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe - = topNormaliseTypeX stepper plus ty - where - plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion) - -> (Bag GlobalRdrElt, TcCoercion) - plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2 - , co1 `mkTransCo` co2 ) - - stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion) - stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance - - -- For newtype instances we take a double step or nothing, so that - -- we don't return the representation type of the newtype instance, - -- which would lead to terrible error messages - unwrap_newtype_instance rec_nts tc tys - | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys - = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $ - unwrap_newtype rec_nts tc' tys' - | otherwise = NS_Done - - unwrap_newtype rec_nts tc tys - | Just con <- newTyConDataCon_maybe tc - , Just gre <- lookupGRE_Name rdr_env (dataConName con) - -- This is where we check that the - -- data constructor is in scope - = mapStepResult (\co -> (unitBag gre, co)) $ - unwrapNewTypeStepper rec_nts tc tys - - | otherwise - = NS_Done - -{- -************************************************************************ -* * - Extending the family instance environment -* * -************************************************************************ --} - --- Add new locally-defined family instances, checking consistency with --- previous locally-defined family instances as well as all instances --- available from imported modules. This requires loading all of our --- imports that define family instances (if we haven't loaded them already). -tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a - --- If we weren't actually given any instances to add, then we don't want --- to go to the bother of loading family instance module dependencies. -tcExtendLocalFamInstEnv [] thing_inside = thing_inside - --- Otherwise proceed... -tcExtendLocalFamInstEnv fam_insts thing_inside - = do { env <- getGblEnv - ; let this_mod = tcg_mod env - imports = tcg_imports env - - -- Optimization: If we're only defining type family instances - -- for type families *defined in the home package*, then we - -- only have to load interface files that belong to the home - -- package. The reason is that there's no recursion between - -- packages, so modules in other packages can't possibly define - -- instances for our type families. - -- - -- (Within the home package, we could import a module M that - -- imports us via an hs-boot file, and thereby defines an - -- instance of a type family defined in this module. So we can't - -- apply the same logic to avoid reading any interface files at - -- all, when we define an instances for type family defined in - -- the current module.) - home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts - want_module mod - | mod == this_mod = False - | home_fams_only = moduleUnitId mod == moduleUnitId this_mod - | otherwise = True - ; loadModuleInterfaces (text "Loading family-instance modules") - (filter want_module (imp_finsts imports)) - ; (inst_env', fam_insts') <- foldlM addLocalFamInst - (tcg_fam_inst_env env, tcg_fam_insts env) - fam_insts - ; let env' = env { tcg_fam_insts = fam_insts' - , tcg_fam_inst_env = inst_env' } - ; setGblEnv env' thing_inside - } - --- Check that the proposed new instance is OK, --- and then add it to the home inst env --- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] --- in FamInstEnv.hs -addLocalFamInst :: (FamInstEnv,[FamInst]) - -> FamInst - -> TcM (FamInstEnv, [FamInst]) -addLocalFamInst (home_fie, my_fis) fam_inst - -- home_fie includes home package and this module - -- my_fies is just the ones from this module - = do { traceTc "addLocalFamInst" (ppr fam_inst) - - -- Unlike the case of class instances, don't override existing - -- instances in GHCi; it's unsound. See #7102. - - ; mod <- getModule - ; traceTc "alfi" (ppr mod) - - -- Fetch imported instances, so that we report - -- overlaps correctly. - -- Really we ought to only check consistency with - -- those instances which are transitively imported - -- by the current module, rather than every instance - -- we've ever seen. Fixing this is part of #13102. - ; eps <- getEps - ; let inst_envs = (eps_fam_inst_env eps, home_fie) - home_fie' = extendFamInstEnv home_fie fam_inst - - -- Check for conflicting instance decls and injectivity violations - ; no_conflict <- checkForConflicts inst_envs fam_inst - ; injectivity_ok <- checkForInjectivityConflicts inst_envs fam_inst - - ; if no_conflict && injectivity_ok then - return (home_fie', fam_inst : my_fis) - else - return (home_fie, my_fis) } - -{- -************************************************************************ -* * - Checking an instance against conflicts with an instance env -* * -************************************************************************ - -Check whether a single family instance conflicts with those in two instance -environments (one for the EPS and one for the HPT). --} - -checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool -checkForConflicts inst_envs fam_inst - = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst - no_conflicts = null conflicts - ; traceTc "checkForConflicts" $ - vcat [ ppr (map fim_instance conflicts) - , ppr fam_inst - -- , ppr inst_envs - ] - ; unless no_conflicts $ conflictInstErr fam_inst conflicts - ; return no_conflicts } - --- | Check whether a new open type family equation can be added without --- violating injectivity annotation supplied by the user. Returns True when --- this is possible and False if adding this equation would violate injectivity --- annotation. -checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM Bool -checkForInjectivityConflicts instEnvs famInst - | isTypeFamilyTyCon tycon - -- type family is injective in at least one argument - , Injective inj <- familyTyConInjectivityInfo tycon = do - { let axiom = coAxiomSingleBranch fi_ax - conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst - -- see Note [Verifying injectivity annotation] in FamInstEnv - errs = makeInjectivityErrors fi_ax axiom inj conflicts - ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs - ; return (null errs) - } - - -- if there was no injectivity annotation or tycon does not represent a - -- type family we report no conflicts - | otherwise = return True - where tycon = famInstTyCon famInst - fi_ax = fi_axiom famInst - --- | Build a list of injectivity errors together with their source locations. -makeInjectivityErrors - :: CoAxiom br -- ^ Type family for which we generate errors - -> CoAxBranch -- ^ Currently checked equation (represented by axiom) - -> [Bool] -- ^ Injectivity annotation - -> [CoAxBranch] -- ^ List of injectivity conflicts - -> [(SDoc, SrcSpan)] -makeInjectivityErrors fi_ax axiom inj conflicts - = ASSERT2( any id inj, text "No injective type variables" ) - let lhs = coAxBranchLHS axiom - rhs = coAxBranchRHS axiom - - are_conflicts = not $ null conflicts - unused_inj_tvs = unusedInjTvsInRHS (coAxiomTyCon fi_ax) inj lhs rhs - inj_tvs_unused = not $ and (isEmptyVarSet <$> unused_inj_tvs) - tf_headed = isTFHeaded rhs - bare_variables = bareTvInRHSViolated lhs rhs - wrong_bare_rhs = not $ null bare_variables - - err_builder herald eqns - = ( hang herald - 2 (vcat (map (pprCoAxBranch fi_ax) eqns)) - , coAxBranchSpan (head eqns) ) - errorIf p f = if p then [f err_builder axiom] else [] - in errorIf are_conflicts (conflictInjInstErr conflicts ) - ++ errorIf inj_tvs_unused (unusedInjectiveVarsErr unused_inj_tvs) - ++ errorIf tf_headed tfHeadedErr - ++ errorIf wrong_bare_rhs (bareVariableInRHSErr bare_variables) - - --- | Return a list of type variables that the function is injective in and that --- do not appear on injective positions in the RHS of a family instance --- declaration. The returned Pair includes invisible vars followed by visible ones -unusedInjTvsInRHS :: TyCon -> [Bool] -> [Type] -> Type -> Pair TyVarSet --- INVARIANT: [Bool] list contains at least one True value --- See Note [Verifying injectivity annotation]. This function implements fourth --- check described there. --- In theory, instead of implementing this whole check in this way, we could --- attempt to unify equation with itself. We would reject exactly the same --- equations but this method gives us more precise error messages by returning --- precise names of variables that are not mentioned in the RHS. -unusedInjTvsInRHS tycon injList lhs rhs = - (`minusVarSet` injRhsVars) <$> injLHSVars - where - -- set of type and kind variables in which type family is injective - (invis_pairs, vis_pairs) - = partitionInvisibles tycon snd (zipEqual "unusedInjTvsInRHS" injList lhs) - invis_lhs = uncurry filterByList $ unzip invis_pairs - vis_lhs = uncurry filterByList $ unzip vis_pairs - - invis_vars = tyCoVarsOfTypes invis_lhs - Pair invis_vars' vis_vars = splitVisVarsOfTypes vis_lhs - injLHSVars - = Pair (invis_vars `minusVarSet` vis_vars `unionVarSet` invis_vars') - vis_vars - - -- set of type variables appearing in the RHS on an injective position. - -- For all returned variables we assume their associated kind variables - -- also appear in the RHS. - injRhsVars = injTyVarsOfType rhs - -injTyVarsOfType :: TcTauType -> TcTyVarSet --- Collect all type variables that are either arguments to a type --- constructor or to /injective/ type families. --- Determining the overall type determines thes variables --- --- E.g. Suppose F is injective in its second arg, but not its first --- then injVarOfType (Either a (F [b] (a,c))) = {a,c} --- Determining the overall type determines a,c but not b. -injTyVarsOfType (TyVarTy v) - = unitVarSet v `unionVarSet` injTyVarsOfType (tyVarKind v) -injTyVarsOfType (TyConApp tc tys) - | isTypeFamilyTyCon tc - = case familyTyConInjectivityInfo tc of - NotInjective -> emptyVarSet - Injective inj -> injTyVarsOfTypes (filterByList inj tys) - | otherwise - = injTyVarsOfTypes tys -injTyVarsOfType (LitTy {}) - = emptyVarSet -injTyVarsOfType (FunTy arg res) - = injTyVarsOfType arg `unionVarSet` injTyVarsOfType res -injTyVarsOfType (AppTy fun arg) - = injTyVarsOfType fun `unionVarSet` injTyVarsOfType arg --- No forall types in the RHS of a type family -injTyVarsOfType (CastTy ty _) = injTyVarsOfType ty -injTyVarsOfType (CoercionTy {}) = emptyVarSet -injTyVarsOfType (ForAllTy {}) = - panic "unusedInjTvsInRHS.injTyVarsOfType" - -injTyVarsOfTypes :: [Type] -> VarSet -injTyVarsOfTypes tys = mapUnionVarSet injTyVarsOfType tys - --- | Is type headed by a type family application? -isTFHeaded :: Type -> Bool --- See Note [Verifying injectivity annotation]. This function implements third --- check described there. -isTFHeaded ty | Just ty' <- coreView ty - = isTFHeaded ty' -isTFHeaded ty | (TyConApp tc args) <- ty - , isTypeFamilyTyCon tc - = tyConArity tc == length args -isTFHeaded _ = False - - --- | If a RHS is a bare type variable return a set of LHS patterns that are not --- bare type variables. -bareTvInRHSViolated :: [Type] -> Type -> [Type] --- See Note [Verifying injectivity annotation]. This function implements second --- check described there. -bareTvInRHSViolated pats rhs | isTyVarTy rhs - = filter (not . isTyVarTy) pats -bareTvInRHSViolated _ _ = [] - - -conflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () -conflictInstErr fam_inst conflictingMatch - | (FamInstMatch { fim_instance = confInst }) : _ <- conflictingMatch - = let (err, span) = makeFamInstsErr - (text "Conflicting family instance declarations:") - [fam_inst, confInst] - in setSrcSpan span $ addErr err - | otherwise - = panic "conflictInstErr" - --- | Type of functions that use error message and a list of axioms to build full --- error message (with a source location) for injective type families. -type InjErrorBuilder = SDoc -> [CoAxBranch] -> (SDoc, SrcSpan) - --- | Build injecivity error herald common to all injectivity errors. -injectivityErrorHerald :: Bool -> SDoc -injectivityErrorHerald isSingular = - text "Type family equation" <> s isSingular <+> text "violate" <> - s (not isSingular) <+> text "injectivity annotation" <> - if isSingular then dot else colon - -- Above is an ugly hack. We want this: "sentence. herald:" (note the dot and - -- colon). But if herald is empty we want "sentence:" (note the colon). We - -- can't test herald for emptiness so we rely on the fact that herald is empty - -- only when isSingular is False. If herald is non empty it must end with a - -- colon. - where - s False = text "s" - s True = empty - --- | Build error message for a pair of equations violating an injectivity --- annotation. -conflictInjInstErr :: [CoAxBranch] -> InjErrorBuilder -> CoAxBranch - -> (SDoc, SrcSpan) -conflictInjInstErr conflictingEqns errorBuilder tyfamEqn - | confEqn : _ <- conflictingEqns - = errorBuilder (injectivityErrorHerald False) [confEqn, tyfamEqn] - | otherwise - = panic "conflictInjInstErr" - --- | Build error message for equation with injective type variables unused in --- the RHS. -unusedInjectiveVarsErr :: Pair TyVarSet -> InjErrorBuilder -> CoAxBranch - -> (SDoc, SrcSpan) -unusedInjectiveVarsErr (Pair invis_vars vis_vars) errorBuilder tyfamEqn - = errorBuilder (injectivityErrorHerald True $$ msg) - [tyfamEqn] - where - tvs = invis_vars `unionVarSet` vis_vars - has_types = not $ isEmptyVarSet vis_vars - has_kinds = not $ isEmptyVarSet invis_vars - - doc = sep [ what <+> text "variable" <> - pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . toposortTyVars) - , text "cannot be inferred from the right-hand side." ] - what = case (has_types, has_kinds) of - (True, True) -> text "Type and kind" - (True, False) -> text "Type" - (False, True) -> text "Kind" - (False, False) -> pprPanic "mkUnusedInjectiveVarsErr" $ ppr tvs - print_kinds_info = ppWhen has_kinds ppSuggestExplicitKinds - msg = doc $$ print_kinds_info $$ - text "In the type family equation:" - --- | Build error message for equation that has a type family call at the top --- level of RHS -tfHeadedErr :: InjErrorBuilder -> CoAxBranch - -> (SDoc, SrcSpan) -tfHeadedErr errorBuilder famInst - = errorBuilder (injectivityErrorHerald True $$ - text "RHS of injective type family equation cannot" <+> - text "be a type family:") [famInst] - --- | Build error message for equation that has a bare type variable in the RHS --- but LHS pattern is not a bare type variable. -bareVariableInRHSErr :: [Type] -> InjErrorBuilder -> CoAxBranch - -> (SDoc, SrcSpan) -bareVariableInRHSErr tys errorBuilder famInst - = errorBuilder (injectivityErrorHerald True $$ - text "RHS of injective type family equation is a bare" <+> - text "type variable" $$ - text "but these LHS type and kind patterns are not bare" <+> - text "variables:" <+> pprQuotedList tys) [famInst] - - -makeFamInstsErr :: SDoc -> [FamInst] -> (SDoc, SrcSpan) -makeFamInstsErr herald insts - = ASSERT( not (null insts) ) - ( hang herald - 2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) 0 - | fi <- sorted ]) - , srcSpan ) - where - getSpan = getSrcLoc . famInstAxiom - sorted = sortWith getSpan insts - fi1 = head sorted - srcSpan = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) - -- The sortWith just arranges that instances are dislayed in order - -- of source location, which reduced wobbling in error messages, - -- and is better for users - -tcGetFamInstEnvs :: TcM FamInstEnvs --- Gets both the external-package inst-env --- and the home-pkg inst env (includes module being compiled) -tcGetFamInstEnvs - = do { eps <- getEps; env <- getGblEnv - ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } diff --git a/typecheck/FunDeps.hs b/typecheck/FunDeps.hs deleted file mode 100644 --- a/typecheck/FunDeps.hs +++ /dev/null @@ -1,666 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 2000 - - -FunDeps - functional dependencies - -It's better to read it as: "if we know these, then we're going to know these" --} - -{-# LANGUAGE CPP #-} - -module FunDeps ( - FunDepEqn(..), pprEquation, - improveFromInstEnv, improveFromAnother, - checkInstCoverage, checkFunDeps, - pprFundeps - ) where - -#include "HsVersions.h" - -import Name -import Var -import Class -import Type -import TcType( transSuperClasses ) -import CoAxiom( TypeEqn ) -import Unify -import FamInst( injTyVarsOfTypes ) -import InstEnv -import VarSet -import VarEnv -import Outputable -import ErrUtils( Validity(..), allValid ) -import SrcLoc -import Util - -import Pair ( Pair(..) ) -import Data.List ( nubBy ) -import Data.Maybe -import Data.Foldable ( fold ) - -{- -************************************************************************ -* * -\subsection{Generate equations from functional dependencies} -* * -************************************************************************ - - -Each functional dependency with one variable in the RHS is responsible -for generating a single equality. For instance: - class C a b | a -> b -The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha -will generate the following FunDepEqn - FDEqn { fd_qtvs = [] - , fd_eqs = [Pair Bool alpha] - , fd_pred1 = C Int Bool - , fd_pred2 = C Int alpha - , fd_loc = ... } -However notice that a functional dependency may have more than one variable -in the RHS which will create more than one pair of types in fd_eqs. Example: - class C a b c | a -> b c - [Wanted] C Int alpha alpha - [Wanted] C Int Bool beta -Will generate: - FDEqn { fd_qtvs = [] - , fd_eqs = [Pair Bool alpha, Pair alpha beta] - , fd_pred1 = C Int Bool - , fd_pred2 = C Int alpha - , fd_loc = ... } - -INVARIANT: Corresponding types aren't already equal -That is, there exists at least one non-identity equality in FDEqs. - -Assume: - class C a b c | a -> b c - instance C Int x x -And: [Wanted] C Int Bool alpha -We will /match/ the LHS of fundep equations, producing a matching substitution -and create equations for the RHS sides. In our last example we'd have generated: - ({x}, [fd1,fd2]) -where - fd1 = FDEq 1 Bool x - fd2 = FDEq 2 alpha x -To ``execute'' the equation, make fresh type variable for each tyvar in the set, -instantiate the two types with these fresh variables, and then unify or generate -a new constraint. In the above example we would generate a new unification -variable 'beta' for x and produce the following constraints: - [Wanted] (Bool ~ beta) - [Wanted] (alpha ~ beta) - -Notice the subtle difference between the above class declaration and: - class C a b c | a -> b, a -> c -where we would generate: - ({x},[fd1]),({x},[fd2]) -This means that the template variable would be instantiated to different -unification variables when producing the FD constraints. - -Finally, the position parameters will help us rewrite the wanted constraint ``on the spot'' --} - -data FunDepEqn loc - = FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars - -- to fresh unification vars, - -- Non-empty only for FunDepEqns arising from instance decls - - , fd_eqs :: [TypeEqn] -- Make these pairs of types equal - , fd_pred1 :: PredType -- The FunDepEqn arose from - , fd_pred2 :: PredType -- combining these two constraints - , fd_loc :: loc } - -{- -Given a bunch of predicates that must hold, such as - - C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5 - -improve figures out what extra equations must hold. -For example, if we have - - class C a b | a->b where ... - -then improve will return - - [(t1,t2), (t4,t5)] - -NOTA BENE: - - * improve does not iterate. It's possible that when we make - t1=t2, for example, that will in turn trigger a new equation. - This would happen if we also had - C t1 t7, C t2 t8 - If t1=t2, we also get t7=t8. - - improve does *not* do this extra step. It relies on the caller - doing so. - - * The equations unify types that are not already equal. So there - is no effect iff the result of improve is empty --} - -instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type --- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys) -instFD (ls,rs) tvs tys - = (map lookup ls, map lookup rs) - where - env = zipVarEnv tvs tys - lookup tv = lookupVarEnv_NF env tv - -zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true - -> [Type] -> [Type] - -> [TypeEqn] --- Create a list of (Type,Type) pairs from two lists of types, --- making sure that the types are not already equal -zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2) - | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2 - | otherwise = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2 -zipAndComputeFDEqs _ _ _ = [] - --- Improve a class constraint from another class constraint --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -improveFromAnother :: loc - -> PredType -- Template item (usually given, or inert) - -> PredType -- Workitem [that can be improved] - -> [FunDepEqn loc] --- Post: FDEqs always oriented from the other to the workitem --- Equations have empty quantified variables -improveFromAnother loc pred1 pred2 - | Just (cls1, tys1) <- getClassPredTys_maybe pred1 - , Just (cls2, tys2) <- getClassPredTys_maybe pred2 - , cls1 == cls2 - = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc } - | let (cls_tvs, cls_fds) = classTvsFds cls1 - , fd <- cls_fds - , let (ltys1, rs1) = instFD fd cls_tvs tys1 - (ltys2, rs2) = instFD fd cls_tvs tys2 - , eqTypes ltys1 ltys2 -- The LHSs match - , let eqs = zipAndComputeFDEqs eqType rs1 rs2 - , not (null eqs) ] - -improveFromAnother _ _ _ = [] - - --- Improve a class constraint from instance declarations --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -instance Outputable (FunDepEqn a) where - ppr = pprEquation - -pprEquation :: FunDepEqn a -> SDoc -pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) - = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs), - nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2 - | Pair t1 t2 <- pairs])] - -improveFromInstEnv :: InstEnvs - -> (PredType -> SrcSpan -> loc) - -> PredType - -> [FunDepEqn loc] -- Needs to be a FunDepEqn because - -- of quantified variables --- Post: Equations oriented from the template (matching instance) to the workitem! -improveFromInstEnv inst_env mk_loc pred - | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred ) - getClassPredTys_maybe pred - , let (cls_tvs, cls_fds) = classTvsFds cls - instances = classInstances inst_env cls - rough_tcs = roughMatchTcs tys - = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs - , fd_pred1 = p_inst, fd_pred2 = pred - , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) } - | fd <- cls_fds -- Iterate through the fundeps first, - -- because there often are none! - , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs - -- Trim the rough_tcs based on the head of the fundep. - -- Remember that instanceCantMatch treats both arguments - -- symmetrically, so it's ok to trim the rough_tcs, - -- rather than trimming each inst_tcs in turn - , ispec <- instances - , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec - tys trimmed_tcs -- NB: orientation - , let p_inst = mkClassPred cls (is_tys ispec) - ] -improveFromInstEnv _ _ _ = [] - - -improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class - -> ClsInst -- An instance template - -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate - -> [([TyCoVar], [TypeEqn])] -- Empty or singleton - -improveClsFD clas_tvs fd - (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) - tys_actual rough_tcs_actual - --- Compare instance {a,b} C sx sp sy sq --- with wanted [W] C tx tp ty tq --- for fundep (x,y -> p,q) from class (C x p y q) --- If (sx,sy) unifies with (tx,ty), take the subst S - --- 'qtvs' are the quantified type variables, the ones which an be instantiated --- to make the types match. For example, given --- class C a b | a->b where ... --- instance C (Maybe x) (Tree x) where .. --- --- and a wanted constraint of form (C (Maybe t1) t2), --- then we will call checkClsFD with --- --- is_qtvs = {x}, is_tys = [Maybe x, Tree x] --- tys_actual = [Maybe t1, t2] --- --- We can instantiate x to t1, and then we want to force --- (Tree x) [t1/x] ~ t2 - - | instanceCantMatch rough_tcs_inst rough_tcs_actual - = [] -- Filter out ones that can't possibly match, - - | otherwise - = ASSERT2( length tys_inst == length tys_actual && - length tys_inst == length clas_tvs - , ppr tys_inst <+> ppr tys_actual ) - - case tcMatchTyKis ltys1 ltys2 of - Nothing -> [] - Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2) - -- Don't include any equations that already hold. - -- Reason: then we know if any actual improvement has happened, - -- in which case we need to iterate the solver - -- In making this check we must taking account of the fact that any - -- qtvs that aren't already instantiated can be instantiated to anything - -- at all - -- NB: We can't do this 'is-useful-equation' check element-wise - -- because of: - -- class C a b c | a -> b c - -- instance C Int x x - -- [Wanted] C Int alpha Int - -- We would get that x -> alpha (isJust) and x -> Int (isJust) - -- so we would produce no FDs, which is clearly wrong. - -> [] - - | null fdeqs - -> [] - - | otherwise - -> [(meta_tvs, fdeqs)] - -- We could avoid this substTy stuff by producing the eqn - -- (qtvs, ls1++rs1, ls2++rs2) - -- which will re-do the ls1/ls2 unification when the equation is - -- executed. What we're doing instead is recording the partial - -- work of the ls1/ls2 unification leaving a smaller unification problem - where - rtys1' = map (substTyUnchecked subst) rtys1 - - fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2 - -- Don't discard anything! - -- We could discard equal types but it's an overkill to call - -- eqType again, since we know for sure that /at least one/ - -- equation in there is useful) - - meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv)) - | tv <- qtvs, tv `notElemTCvSubst` subst ] - -- meta_tvs are the quantified type variables - -- that have not been substituted out - -- - -- Eg. class C a b | a -> b - -- instance C Int [y] - -- Given constraint C Int z - -- we generate the equation - -- ({y}, [y], z) - -- - -- But note (a) we get them from the dfun_id, so they are *in order* - -- because the kind variables may be mentioned in the - -- type variabes' kinds - -- (b) we must apply 'subst' to the kinds, in case we have - -- matched out a kind variable, but not a type variable - -- whose kind mentions that kind variable! - -- Trac #6015, #6068 - where - (ltys1, rtys1) = instFD fd clas_tvs tys_inst - (ltys2, rtys2) = instFD fd clas_tvs tys_actual - -{- -%************************************************************************ -%* * - The Coverage condition for instance declarations -* * -************************************************************************ - -Note [Coverage condition] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Example - class C a b | a -> b - instance theta => C t1 t2 - -For the coverage condition, we check - (normal) fv(t2) `subset` fv(t1) - (liberal) fv(t2) `subset` oclose(fv(t1), theta) - -The liberal version ensures the self-consistency of the instance, but -it does not guarantee termination. Example: - - class Mul a b c | a b -> c where - (.*.) :: a -> b -> c - - instance Mul Int Int Int where (.*.) = (*) - instance Mul Int Float Float where x .*. y = fromIntegral x * y - instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v - -In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]). -But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) ) - -But it is a mistake to accept the instance because then this defn: - f = \ b x y -> if b then x .*. [y] else y -makes instance inference go into a loop, because it requires the constraint - Mul a [b] b --} - -checkInstCoverage :: Bool -- Be liberal - -> Class -> [PredType] -> [Type] - -> Validity --- "be_liberal" flag says whether to use "liberal" coverage of --- See Note [Coverage Condition] below --- --- Return values --- Nothing => no problems --- Just msg => coverage problem described by msg - -checkInstCoverage be_liberal clas theta inst_taus - = allValid (map fundep_ok fds) - where - (tyvars, fds) = classTvsFds clas - fundep_ok fd - | and (isEmptyVarSet <$> undetermined_tvs) = IsValid - | otherwise = NotValid msg - where - (ls,rs) = instFD fd tyvars inst_taus - ls_tvs = tyCoVarsOfTypes ls - rs_tvs = splitVisVarsOfTypes rs - - undetermined_tvs | be_liberal = liberal_undet_tvs - | otherwise = conserv_undet_tvs - - closed_ls_tvs = oclose theta ls_tvs - liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs - conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs - - undet_set = fold undetermined_tvs - - msg = vcat [ -- text "ls_tvs" <+> ppr ls_tvs - -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs) - -- , text "theta" <+> ppr theta - -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs)) - -- , text "rs_tvs" <+> ppr rs_tvs - sep [ text "The" - <+> ppWhen be_liberal (text "liberal") - <+> text "coverage condition fails in class" - <+> quotes (ppr clas) - , nest 2 $ text "for functional dependency:" - <+> quotes (pprFunDep fd) ] - , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls - , nest 2 $ - (if isSingleton ls - then text "does not" - else text "do not jointly") - <+> text "determine rhs type"<>plural rs - <+> pprQuotedList rs ] - , text "Un-determined variable" <> pluralVarSet undet_set <> colon - <+> pprVarSet undet_set (pprWithCommas ppr) - , ppWhen (isEmptyVarSet $ pSnd undetermined_tvs) $ - ppSuggestExplicitKinds - , ppWhen (not be_liberal && - and (isEmptyVarSet <$> liberal_undet_tvs)) $ - text "Using UndecidableInstances might help" ] - -{- Note [Closing over kinds in coverage] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a fundep (a::k) -> b -Then if 'a' is instantiated to (x y), where x:k2->*, y:k2, -then fixing x really fixes k2 as well, and so k2 should be added to -the lhs tyvars in the fundep check. - -Example (Trac #8391), using liberal coverage - data Foo a = ... -- Foo :: forall k. k -> * - class Bar a b | a -> b - instance Bar a (Foo a) - - In the instance decl, (a:k) does fix (Foo k a), but only if we notice - that (a:k) fixes k. Trac #10109 is another example. - -Here is a more subtle example, from HList-0.4.0.0 (Trac #10564) - - class HasFieldM (l :: k) r (v :: Maybe *) - | l r -> v where ... - class HasFieldM1 (b :: Maybe [*]) (l :: k) r v - | b l r -> v where ... - class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) - | e1 l -> r - - data Label :: k -> * - type family LabelsOf (a :: [*]) :: * - - instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b, - HasFieldM1 b l (r xs) v) - => HasFieldM l (r xs) v where - -Is the instance OK? Does {l,r,xs} determine v? Well: - - * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b, - plus the fundep "| el l -> r" in class HMameberM, - we get {l,k,xs} -> b - - * Note the 'k'!! We must call closeOverKinds on the seed set - ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b - fundep won't fire. This was the reason for #10564. - - * So starting from seeds {l,r,xs,k} we do oclose to get - first {l,r,xs,k,b}, via the HMemberM constraint, and then - {l,r,xs,k,b,v}, via the HasFieldM1 constraint. - - * And that fixes v. - -However, we must closeOverKinds whenever augmenting the seed set -in oclose! Consider Trac #10109: - - data Succ a -- Succ :: forall k. k -> * - class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab - instance (Add a b ab) => Add (Succ {k1} (a :: k1)) - b - (Succ {k3} (ab :: k3}) - -We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}. -Now use the fundep to extend to {a,k1,b,k2,ab}. But we need to -closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all -the variables free in (Succ {k3} ab). - -Bottom line: - * closeOverKinds on initial seeds (done automatically - by tyCoVarsOfTypes in checkInstCoverage) - * and closeOverKinds whenever extending those seeds (in oclose) - -Note [The liberal coverage condition] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(oclose preds tvs) closes the set of type variables tvs, -wrt functional dependencies in preds. The result is a superset -of the argument set. For example, if we have - class C a b | a->b where ... -then - oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} -because if we know x and y then that fixes z. - -We also use equality predicates in the predicates; if we have an -assumption `t1 ~ t2`, then we use the fact that if we know `t1` we -also know `t2` and the other way. - eg oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} - -oclose is used (only) when checking the coverage condition for -an instance declaration - -Note [Equality superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class (a ~ [b]) => C a b - -Remember from Note [The equality types story] in TysPrim, that - * (a ~~ b) is a superclass of (a ~ b) - * (a ~# b) is a superclass of (a ~~ b) - -So when oclose expands superclasses we'll get a (a ~# [b]) superclass. -But that's an EqPred not a ClassPred, and we jolly well do want to -account for the mutual functional dependencies implied by (t1 ~# t2). -Hence the EqPred handling in oclose. See Trac #10778. - -Note [Care with type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #12803) - class C x y | x -> y - type family F a b - type family G c d = r | r -> d - -Now consider - oclose (C (F a b) (G c d)) {a,b} - -Knowing {a,b} fixes (F a b) regardless of the injectivity of F. -But knowing (G c d) fixes only {d}, because G is only injective -in its second parameter. - -Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds. --} - -oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet --- See Note [The liberal coverage condition] -oclose preds fixed_tvs - | null tv_fds = fixed_tvs -- Fast escape hatch for common case. - | otherwise = fixVarSet extend fixed_tvs - where - extend fixed_tvs = foldl add fixed_tvs tv_fds - where - add fixed_tvs (ls,rs) - | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs - | otherwise = fixed_tvs - -- closeOverKinds: see Note [Closing over kinds in coverage] - - tv_fds :: [(TyCoVarSet,TyCoVarSet)] - tv_fds = [ (tyCoVarsOfTypes ls, injTyVarsOfTypes rs) - -- See Note [Care with type functions] - | pred <- preds - , pred' <- pred : transSuperClasses pred - -- Look for fundeps in superclasses too - , (ls, rs) <- determined pred' ] - - determined :: PredType -> [([Type],[Type])] - determined pred - = case classifyPredType pred of - EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])] - -- See Note [Equality superclasses] - ClassPred cls tys -> [ instFD fd cls_tvs tys - | let (cls_tvs, cls_fds) = classTvsFds cls - , fd <- cls_fds ] - _ -> [] - - -{- ********************************************************************* -* * - Check that a new instance decl is OK wrt fundeps -* * -************************************************************************ - -Here is the bad case: - class C a b | a->b where ... - instance C Int Bool where ... - instance C Int Char where ... - -The point is that a->b, so Int in the first parameter must uniquely -determine the second. In general, given the same class decl, and given - - instance C s1 s2 where ... - instance C t1 t2 where ... - -Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). - -Matters are a little more complicated if there are free variables in -the s2/t2. - - class D a b c | a -> b - instance D a b => D [(a,a)] [b] Int - instance D a b => D [a] [b] Bool - -The instance decls don't overlap, because the third parameter keeps -them separate. But we want to make sure that given any constraint - D s1 s2 s3 -if s1 matches - -Note [Bogus consistency check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In checkFunDeps we check that a new ClsInst is consistent with all the -ClsInsts in the environment. - -The bogus aspect is discussed in Trac #10675. Currenty it if the two -types are *contradicatory*, using (isNothing . tcUnifyTys). But all -the papers say we should check if the two types are *equal* thus - not (substTys subst rtys1 `eqTypes` substTys subst rtys2) -For now I'm leaving the bogus form because that's the way it has -been for years. --} - -checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst] --- The Consistency Check. --- Check whether adding DFunId would break functional-dependency constraints --- Used only for instance decls defined in the module being compiled --- Returns a list of the ClsInst in InstEnvs that are inconsistent --- with the proposed new ClsInst -checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls - , is_tys = tys1, is_tcs = rough_tcs1 }) - | null fds - = [] - | otherwise - = nubBy eq_inst $ - [ ispec | ispec <- cls_insts - , fd <- fds - , is_inconsistent fd ispec ] - where - cls_insts = classInstances inst_envs cls - (cls_tvs, fds) = classTvsFds cls - qtv_set1 = mkVarSet qtvs1 - - is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 }) - | instanceCantMatch trimmed_tcs rough_tcs2 - = False - | otherwise - = case tcUnifyTyKis bind_fn ltys1 ltys2 of - Nothing -> False - Just subst - -> isNothing $ -- Bogus legacy test (Trac #10675) - -- See Note [Bogus consistency check] - tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2) - - where - trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs1 - (ltys1, rtys1) = instFD fd cls_tvs tys1 - (ltys2, rtys2) = instFD fd cls_tvs tys2 - qtv_set2 = mkVarSet qtvs2 - bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe - | tv `elemVarSet` qtv_set2 = BindMe - | otherwise = Skolem - - eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2 - -- An single instance may appear twice in the un-nubbed conflict list - -- because it may conflict with more than one fundep. E.g. - -- class C a b c | a -> b, a -> c - -- instance C Int Bool Bool - -- instance C Int Char Char - -- The second instance conflicts with the first by *both* fundeps - -trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] --- Computing rough_tcs for a particular fundep --- class C a b c | a -> b where ... --- For each instance .... => C ta tb tc --- we want to match only on the type ta; so our --- rough-match thing must similarly be filtered. --- Hence, we Nothing-ise the tb and tc types right here --- --- Result list is same length as input list, just with more Nothings -trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs - = zipWith select clas_tvs mb_tcs - where - select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc - | otherwise = Nothing diff --git a/typecheck/Inst.hs b/typecheck/Inst.hs deleted file mode 100644 --- a/typecheck/Inst.hs +++ /dev/null @@ -1,856 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The @Inst@ type: dictionaries or method instances --} - -{-# LANGUAGE CPP, MultiWayIf, TupleSections #-} - -module Inst ( - deeplySkolemise, - topInstantiate, topInstantiateInferred, deeplyInstantiate, - instCall, instDFunType, instStupidTheta, instTyVarsWith, - newWanted, newWanteds, - - tcInstBinders, tcInstBindersX, tcInstBinderX, - - newOverloadedLit, mkOverLit, - - newClsInst, - tcGetInsts, tcGetInstEnvs, getOverlapFlag, - tcExtendLocalInstEnv, - instCallConstraints, newMethodFromName, - tcSyntaxName, - - -- Simple functions over evidence variables - tyCoVarsOfWC, - tyCoVarsOfCt, tyCoVarsOfCts, - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) -import {-# SOURCE #-} TcUnify( unifyType, unifyKind, noThing ) - -import BasicTypes ( SourceText(..) ) -import FastString -import HsSyn -import TcHsSyn -import TcRnMonad -import TcEnv -import TcEvidence -import InstEnv -import TysWiredIn ( heqDataCon, coercibleDataCon ) -import CoreSyn ( isOrphan ) -import FunDeps -import TcMType -import Type -import TyCoRep ( TyBinder(..) ) -import TcType -import HscTypes -import Class( Class ) -import MkId( mkDictFunId ) -import Id -import Name -import Var ( EvVar, mkTyVar, tyVarName, TyVarBndr(..) ) -import DataCon -import TyCon -import VarEnv -import PrelNames -import SrcLoc -import DynFlags -import Util -import Outputable -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad( unless ) - -{- -************************************************************************ -* * - Creating and emittind constraints -* * -************************************************************************ --} - -newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) --- Used when Name is the wired-in name for a wired-in class method, --- so the caller knows its type for sure, which should be of form --- forall a. C a => --- newMethodFromName is supposed to instantiate just the outer --- type variable and constraint - -newMethodFromName origin name inst_ty - = do { id <- tcLookupId name - -- Use tcLookupId not tcLookupGlobalId; the method is almost - -- always a class op, but with -XRebindableSyntax GHC is - -- meant to find whatever thing is in scope, and that may - -- be an ordinary function. - - ; let ty = piResultTy (idType id) inst_ty - (theta, _caller_knows_this) = tcSplitPhiTy ty - ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) - instCall origin [inst_ty] theta - - ; return (mkHsWrap wrap (HsVar (noLoc id))) } - -{- -************************************************************************ -* * - Deep instantiation and skolemisation -* * -************************************************************************ - -Note [Deep skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~~~ -deeplySkolemise decomposes and skolemises a type, returning a type -with all its arrows visible (ie not buried under foralls) - -Examples: - - deeplySkolemise (Int -> forall a. Ord a => blah) - = ( wp, [a], [d:Ord a], Int -> blah ) - where wp = \x:Int. /\a. \(d:Ord a). x - - deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah) - = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah ) - where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). x - -In general, - if deeplySkolemise ty = (wrap, tvs, evs, rho) - and e :: rho - then wrap e :: ty - and 'wrap' binds tvs, evs - -ToDo: this eta-abstraction plays fast and loose with termination, - because it can introduce extra lambdas. Maybe add a `seq` to - fix this --} - -deeplySkolemise :: TcSigmaType - -> TcM ( HsWrapper - , [(Name,TyVar)] -- All skolemised variables - , [EvVar] -- All "given"s - , TcRhoType ) - -deeplySkolemise ty - = go init_subst ty - where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) - - go subst ty - | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty - = do { let arg_tys' = substTys subst arg_tys - ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' - ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs - ; ev_vars1 <- newEvVars (substTheta subst' theta) - ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' - ; let tv_prs1 = map tyVarName tvs `zip` tvs1 - ; return ( mkWpLams ids1 - <.> mkWpTyLams tvs1 - <.> mkWpLams ev_vars1 - <.> wrap - <.> mkWpEvVarApps ids1 - , tv_prs1 ++ tvs_prs2 - , ev_vars1 ++ ev_vars2 - , mkFunTys arg_tys' rho ) } - - | otherwise - = return (idHsWrapper, [], [], substTy subst ty) - -- substTy is a quick no-op on an empty substitution - --- | Instantiate all outer type variables --- and any context. Never looks through arrows. -topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- if topInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho (that is, wrap :: ty "->" rho) -topInstantiate = top_instantiate True - --- | Instantiate all outer 'Inferred' binders --- and any context. Never looks through arrows or specified type variables. --- Used for visible type application. -topInstantiateInferred :: CtOrigin -> TcSigmaType - -> TcM (HsWrapper, TcSigmaType) --- if topInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho -topInstantiateInferred = top_instantiate False - -top_instantiate :: Bool -- True <=> instantiate *all* variables - -- False <=> instantiate only the inferred ones - -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) -top_instantiate inst_all orig ty - | not (null binders && null theta) - = do { let (inst_bndrs, leave_bndrs) = span should_inst binders - (inst_theta, leave_theta) - | null leave_bndrs = (theta, []) - | otherwise = ([], theta) - in_scope = mkInScopeSet (tyCoVarsOfType ty) - empty_subst = mkEmptyTCvSubst in_scope - inst_tvs = binderVars inst_bndrs - ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs - ; let inst_theta' = substTheta subst inst_theta - sigma' = substTy subst (mkForAllTys leave_bndrs $ - mkFunTys leave_theta rho) - - ; wrap1 <- instCall orig (mkTyVarTys inst_tvs') inst_theta' - ; traceTc "Instantiating" - (vcat [ text "all tyvars?" <+> ppr inst_all - , text "origin" <+> pprCtOrigin orig - , text "type" <+> ppr ty - , text "theta" <+> ppr theta - , text "leave_bndrs" <+> ppr leave_bndrs - , text "with" <+> ppr inst_tvs' - , text "theta:" <+> ppr inst_theta' ]) - - ; (wrap2, rho2) <- - if null leave_bndrs - - -- account for types like forall a. Num a => forall b. Ord b => ... - then top_instantiate inst_all orig sigma' - - -- but don't loop if there were any un-inst'able tyvars - else return (idHsWrapper, sigma') - - ; return (wrap2 <.> wrap1, rho2) } - - | otherwise = return (idHsWrapper, ty) - where - (binders, phi) = tcSplitForAllTyVarBndrs ty - (theta, rho) = tcSplitPhiTy phi - - should_inst bndr - | inst_all = True - | otherwise = binderArgFlag bndr == Inferred - -deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- Int -> forall a. a -> a ==> (\x:Int. [] x alpha) :: Int -> alpha --- In general if --- if deeplyInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho --- That is, wrap :: ty ~> rho --- --- If you don't need the HsWrapper returned from this function, consider --- using tcSplitNestedSigmaTys in TcType, which is a pure alternative that --- only computes the returned TcRhoType. - -deeplyInstantiate orig ty = - deeply_instantiate orig - (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))) - ty - -deeply_instantiate :: CtOrigin - -> TCvSubst - -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- Internal function to deeply instantiate that builds on an existing subst. --- It extends the input substitution and applies the final subtitution to --- the types on return. See #12549. - -deeply_instantiate orig subst ty - | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty - = do { (subst', tvs') <- newMetaTyVarsX subst tvs - ; ids1 <- newSysLocalIds (fsLit "di") (substTys subst' arg_tys) - ; let theta' = substTheta subst' theta - ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' - ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig - , text "type" <+> ppr ty - , text "with" <+> ppr tvs' - , text "args:" <+> ppr ids1 - , text "theta:" <+> ppr theta' - , text "subst:" <+> ppr subst']) - ; (wrap2, rho2) <- deeply_instantiate orig subst' rho - ; return (mkWpLams ids1 - <.> wrap2 - <.> wrap1 - <.> mkWpEvVarApps ids1, - mkFunTys arg_tys rho2) } - - | otherwise - = do { let ty' = substTy subst ty - ; traceTc "deeply_instantiate final subst" - (vcat [ text "origin:" <+> pprCtOrigin orig - , text "type:" <+> ppr ty - , text "new type:" <+> ppr ty' - , text "subst:" <+> ppr subst ]) - ; return (idHsWrapper, ty') } - - -instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst --- Use this when you want to instantiate (forall a b c. ty) with --- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might --- not yet match (perhaps because there are unsolved constraints; Trac #14154) --- If they don't match, emit a kind-equality to promise that they will --- eventually do so, and thus make a kind-homongeneous substitution. -instTyVarsWith orig tvs tys - = go empty_subst tvs tys - where - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) - - go subst [] [] - = return subst - go subst (tv:tvs) (ty:tys) - | tv_kind `tcEqType` ty_kind - = go (extendTCvSubst subst tv ty) tvs tys - | otherwise - = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind - ; go (extendTCvSubst subst tv (ty `mkCastTy` co)) tvs tys } - where - tv_kind = substTy subst (tyVarKind tv) - ty_kind = typeKind ty - - go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys) - -{- -************************************************************************ -* * - Instantiating a call -* * -************************************************************************ - -Note [Handling boxed equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The solver deals entirely in terms of unboxed (primitive) equality. -There should never be a boxed Wanted equality. Ever. But, what if -we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality -is boxed, so naive treatment here would emit a boxed Wanted equality. - -So we simply check for this case and make the right boxing of evidence. - --} - ----------------- -instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper --- Instantiate the constraints of a call --- (instCall o tys theta) --- (a) Makes fresh dictionaries as necessary for the constraints (theta) --- (b) Throws these dictionaries into the LIE --- (c) Returns an HsWrapper ([.] tys dicts) - -instCall orig tys theta - = do { dict_app <- instCallConstraints orig theta - ; return (dict_app <.> mkWpTyApps tys) } - ----------------- -instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper --- Instantiates the TcTheta, puts all constraints thereby generated --- into the LIE, and returns a HsWrapper to enclose the call site. - -instCallConstraints orig preds - | null preds - = return idHsWrapper - | otherwise - = do { evs <- mapM go preds - ; traceTc "instCallConstraints" (ppr evs) - ; return (mkWpEvApps evs) } - where - go pred - | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1 - = do { co <- unifyType noThing ty1 ty2 - ; return (EvCoercion co) } - - -- Try short-cut #2 - | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred - , tc `hasKey` heqTyConKey - = do { co <- unifyType noThing ty1 ty2 - ; return (EvDFunApp (dataConWrapId heqDataCon) args [EvCoercion co]) } - - | otherwise - = emitWanted orig pred - -instDFunType :: DFunId -> [DFunInstType] - -> TcM ( [TcType] -- instantiated argument types - , TcThetaType ) -- instantiated constraint --- See Note [DFunInstType: instantiating types] in InstEnv -instDFunType dfun_id dfun_inst_tys - = do { (subst, inst_tys) <- go emptyTCvSubst dfun_tvs dfun_inst_tys - ; return (inst_tys, substTheta subst dfun_theta) } - where - (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy (idType dfun_id) - - go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType]) - go subst [] [] = return (subst, []) - go subst (tv:tvs) (Just ty : mb_tys) - = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty) - tvs - mb_tys - ; return (subst', ty : tys) } - go subst (tv:tvs) (Nothing : mb_tys) - = do { (subst', tv') <- newMetaTyVarX subst tv - ; (subst'', tys) <- go subst' tvs mb_tys - ; return (subst'', mkTyVarTy tv' : tys) } - go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys) - ----------------- -instStupidTheta :: CtOrigin -> TcThetaType -> TcM () --- Similar to instCall, but only emit the constraints in the LIE --- Used exclusively for the 'stupid theta' of a data constructor -instStupidTheta orig theta - = do { _co <- instCallConstraints orig theta -- Discard the coercion - ; return () } - -{- -************************************************************************ -* * - Instantiating Kinds -* * -************************************************************************ - --} - ---------------------------- --- | This is used to instantiate binders when type-checking *types* only. --- See also Note [Bidirectional type checking] -tcInstBinders :: [TyBinder] -> TcM (TCvSubst, [TcType]) -tcInstBinders = tcInstBindersX emptyTCvSubst Nothing - --- | This is used to instantiate binders when type-checking *types* only. --- The @VarEnv Kind@ gives some known instantiations. --- See also Note [Bidirectional type checking] -tcInstBindersX :: TCvSubst -> Maybe (VarEnv Kind) - -> [TyBinder] -> TcM (TCvSubst, [TcType]) -tcInstBindersX subst mb_kind_info bndrs - = do { (subst, args) <- mapAccumLM (tcInstBinderX mb_kind_info) subst bndrs - ; traceTc "instantiating tybinders:" - (vcat $ zipWith (\bndr arg -> ppr bndr <+> text ":=" <+> ppr arg) - bndrs args) - ; return (subst, args) } - --- | Used only in *types* -tcInstBinderX :: Maybe (VarEnv Kind) - -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) -tcInstBinderX mb_kind_info subst (Named (TvBndr tv _)) - = case lookup_tv tv of - Just ki -> return (extendTvSubstAndInScope subst tv ki, ki) - Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv - ; return (subst', mkTyVarTy tv') } - where - lookup_tv tv = do { env <- mb_kind_info -- `Maybe` monad - ; lookupVarEnv env tv } - - -tcInstBinderX _ subst (Anon ty) - -- This is the *only* constraint currently handled in types. - | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty - = do { let origin = TypeEqOrigin { uo_actual = k1 - , uo_expected = k2 - , uo_thing = Nothing } - ; co <- case role of - Nominal -> unifyKind noThing k1 k2 - Representational -> emitWantedEq origin KindLevel role k1 k2 - Phantom -> pprPanic "tcInstBinderX Phantom" (ppr ty) - ; arg' <- mk co k1 k2 - ; return (subst, arg') } - - | isPredTy substed_ty - = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty - ; addErrTcM (env, text "Illegal constraint in a type:" <+> ppr tidy_ty) - - -- just invent a new variable so that we can continue - ; u <- newUnique - ; let name = mkSysTvName u (fsLit "dict") - ; return (subst, mkTyVarTy $ mkTyVar name substed_ty) } - - - | otherwise - = do { tv_ty <- newFlexiTyVarTy substed_ty - ; return (subst, tv_ty) } - - where - substed_ty = substTy subst ty - - -- handle boxed equality constraints, because it's so easy - get_pred_tys_maybe ty - | Just (r, k1, k2) <- getEqPredTys_maybe ty - = Just (\co _ _ -> return $ mkCoercionTy co, r, k1, k2) - | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty - = if | tc `hasKey` heqTyConKey - -> Just (mkHEqBoxTy, Nominal, k1, k2) - | otherwise - -> Nothing - | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty - = if | tc `hasKey` eqTyConKey - -> Just (mkEqBoxTy, Nominal, k1, k2) - | tc `hasKey` coercibleTyConKey - -> Just (mkCoercibleBoxTy, Representational, k1, k2) - | otherwise - -> Nothing - | otherwise - = Nothing - -------------------------------- --- | This takes @a ~# b@ and returns @a ~~ b@. -mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type --- monadic just for convenience with mkEqBoxTy -mkHEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] - where k1 = typeKind ty1 - k2 = typeKind ty2 - --- | This takes @a ~# b@ and returns @a ~ b@. -mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type -mkEqBoxTy co ty1 ty2 - = do { eq_tc <- tcLookupTyCon eqTyConName - ; let [datacon] = tyConDataCons eq_tc - ; hetero <- mkHEqBoxTy co ty1 ty2 - ; return $ mkTyConApp (promoteDataCon datacon) [k, ty1, ty2, hetero] } - where k = typeKind ty1 - --- | This takes @a ~R# b@ and returns @Coercible a b@. -mkCoercibleBoxTy :: TcCoercion -> Type -> Type -> TcM Type --- monadic just for convenience with mkEqBoxTy -mkCoercibleBoxTy co ty1 ty2 - = do { return $ - mkTyConApp (promoteDataCon coercibleDataCon) - [k, ty1, ty2, mkCoercionTy co] } - where k = typeKind ty1 - -{- -************************************************************************ -* * - Literals -* * -************************************************************************ - --} - -{- -In newOverloadedLit we convert directly to an Int or Integer if we -know that's what we want. This may save some time, by not -temporarily generating overloaded literals, but it won't catch all -cases (the rest are caught in lookupInst). - --} - -newOverloadedLit :: HsOverLit Name - -> ExpRhoType - -> TcM (HsOverLit TcId) -newOverloadedLit - lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty - | not rebindable - -- all built-in overloaded lits are tau-types, so we can just - -- tauify the ExpType - = do { res_ty <- expTypeToType res_ty - ; dflags <- getDynFlags - ; case shortCutLit dflags val res_ty of - -- Do not generate a LitInst for rebindable syntax. - -- Reason: If we do, tcSimplify will call lookupInst, which - -- will call tcSyntaxName, which does unification, - -- which tcSimplify doesn't like - Just expr -> return (lit { ol_witness = expr, ol_type = res_ty - , ol_rebindable = False }) - Nothing -> newNonTrivialOverloadedLit orig lit - (mkCheckExpType res_ty) } - - | otherwise - = newNonTrivialOverloadedLit orig lit res_ty - where - orig = LiteralOrigin lit - --- Does not handle things that 'shortCutLit' can handle. See also --- newOverloadedLit in TcUnify -newNonTrivialOverloadedLit :: CtOrigin - -> HsOverLit Name - -> ExpRhoType - -> TcM (HsOverLit TcId) -newNonTrivialOverloadedLit orig - lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name) - , ol_rebindable = rebindable }) res_ty - = do { hs_lit <- mkOverLit val - ; let lit_ty = hsLitType hs_lit - ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) - [synKnownType lit_ty] res_ty $ - \_ -> return () - ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] - ; res_ty <- readExpType res_ty - ; return (lit { ol_witness = witness - , ol_type = res_ty - , ol_rebindable = rebindable }) } -newNonTrivialOverloadedLit _ lit _ - = pprPanic "newNonTrivialOverloadedLit" (ppr lit) - ------------- -mkOverLit :: OverLitVal -> TcM HsLit -mkOverLit (HsIntegral src i) - = do { integer_ty <- tcMetaTy integerTyConName - ; return (HsInteger src i integer_ty) } - -mkOverLit (HsFractional r) - = do { rat_ty <- tcMetaTy rationalTyConName - ; return (HsRat r rat_ty) } - -mkOverLit (HsIsString src s) = return (HsString src s) - -{- -************************************************************************ -* * - Re-mappable syntax - - Used only for arrow syntax -- find a way to nuke this -* * -************************************************************************ - -Suppose we are doing the -XRebindableSyntax thing, and we encounter -a do-expression. We have to find (>>) in the current environment, which is -done by the rename. Then we have to check that it has the same type as -Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had -this: - - (>>) :: HB m n mn => m a -> n b -> mn b - -So the idea is to generate a local binding for (>>), thus: - - let then72 :: forall a b. m a -> m b -> m b - then72 = ...something involving the user's (>>)... - in - ...the do-expression... - -Now the do-expression can proceed using then72, which has exactly -the expected type. - -In fact tcSyntaxName just generates the RHS for then72, because we only -want an actual binding in the do-expression case. For literals, we can -just use the expression inline. --} - -tcSyntaxName :: CtOrigin - -> TcType -- Type to instantiate it at - -> (Name, HsExpr Name) -- (Standard name, user name) - -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression) --- USED ONLY FOR CmdTop (sigh) *** --- See Note [CmdSyntaxTable] in HsExpr - -tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm)) - | std_nm == user_nm - = do rhs <- newMethodFromName orig std_nm ty - return (std_nm, rhs) - -tcSyntaxName orig ty (std_nm, user_nm_expr) = do - std_id <- tcLookupId std_nm - let - -- C.f. newMethodAtLoc - ([tv], _, tau) = tcSplitSigmaTy (idType std_id) - sigma1 = substTyWith [tv] [ty] tau - -- Actually, the "tau-type" might be a sigma-type in the - -- case of locally-polymorphic methods. - - addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do - - -- Check that the user-supplied thing has the - -- same type as the standard one. - -- Tiresome jiggling because tcCheckSigma takes a located expression - span <- getSrcSpanM - expr <- tcPolyExpr (L span user_nm_expr) sigma1 - return (std_nm, unLoc expr) - -syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv - -> TcRn (TidyEnv, SDoc) -syntaxNameCtxt name orig ty tidy_env - = do { inst_loc <- getCtLocM orig (Just TypeLevel) - ; let msg = vcat [ text "When checking that" <+> quotes (ppr name) - <+> text "(needed by a syntactic construct)" - , nest 2 (text "has the required type:" - <+> ppr (tidyType tidy_env ty)) - , nest 2 (pprCtLoc inst_loc) ] - ; return (tidy_env, msg) } - -{- -************************************************************************ -* * - Instances -* * -************************************************************************ --} - -getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag --- Construct the OverlapFlag from the global module flags, --- but if the overlap_mode argument is (Just m), --- set the OverlapMode to 'm' -getOverlapFlag overlap_mode - = do { dflags <- getDynFlags - ; let overlap_ok = xopt LangExt.OverlappingInstances dflags - incoherent_ok = xopt LangExt.IncoherentInstances dflags - use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags - , overlapMode = x } - default_oflag | incoherent_ok = use (Incoherent NoSourceText) - | overlap_ok = use (Overlaps NoSourceText) - | otherwise = use (NoOverlap NoSourceText) - - final_oflag = setOverlapModeMaybe default_oflag overlap_mode - ; return final_oflag } - -tcGetInsts :: TcM [ClsInst] --- Gets the local class instances. -tcGetInsts = fmap tcg_insts getGblEnv - -newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType - -> Class -> [Type] -> TcM ClsInst -newClsInst overlap_mode dfun_name tvs theta clas tys - = do { (subst, tvs') <- freshenTyVarBndrs tvs - -- Be sure to freshen those type variables, - -- so they are sure not to appear in any lookup - ; let tys' = substTys subst tys - - dfun = mkDictFunId dfun_name tvs theta clas tys - -- The dfun uses the original 'tvs' because - -- (a) they don't need to be fresh - -- (b) they may be mentioned in the ib_binds field of - -- an InstInfo, and in TcEnv.pprInstInfoDetails it's - -- helpful to use the same names - - ; oflag <- getOverlapFlag overlap_mode - ; let inst = mkLocalInstance dfun oflag tvs' clas tys' - ; warnIf (Reason Opt_WarnOrphans) - (isOrphan (is_orphan inst)) - (instOrphWarn inst) - ; return inst } - -instOrphWarn :: ClsInst -> SDoc -instOrphWarn inst - = hang (text "Orphan instance:") 2 (pprInstanceHdr inst) - $$ text "To avoid this" - $$ nest 4 (vcat possibilities) - where - possibilities = - text "move the instance declaration to the module of the class or of the type, or" : - text "wrap the type with a newtype and declare the instance on the new type." : - [] - -tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a - -- Add new locally-defined instances -tcExtendLocalInstEnv dfuns thing_inside - = do { traceDFuns dfuns - ; env <- getGblEnv - ; (inst_env', cls_insts') <- foldlM addLocalInst - (tcg_inst_env env, tcg_insts env) - dfuns - ; let env' = env { tcg_insts = cls_insts' - , tcg_inst_env = inst_env' } - ; setGblEnv env' thing_inside } - -addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) --- Check that the proposed new instance is OK, --- and then add it to the home inst env --- If overwrite_inst, then we can overwrite a direct match -addLocalInst (home_ie, my_insts) ispec - = do { - -- Load imported instances, so that we report - -- duplicates correctly - - -- 'matches' are existing instance declarations that are less - -- specific than the new one - -- 'dups' are those 'matches' that are equal to the new one - ; isGHCi <- getIsGHCi - ; eps <- getEps - ; tcg_env <- getGblEnv - - -- In GHCi, we *override* any identical instances - -- that are also defined in the interactive context - -- See Note [Override identical instances in GHCi] - ; let home_ie' - | isGHCi = deleteFromInstEnv home_ie ispec - | otherwise = home_ie - - global_ie = eps_inst_env eps - inst_envs = InstEnvs { ie_global = global_ie - , ie_local = home_ie' - , ie_visible = tcVisibleOrphanMods tcg_env } - - -- Check for inconsistent functional dependencies - ; let inconsistent_ispecs = checkFunDeps inst_envs ispec - ; unless (null inconsistent_ispecs) $ - funDepErr ispec inconsistent_ispecs - - -- Check for duplicate instance decls. - ; let (_tvs, cls, tys) = instanceHead ispec - (matches, _, _) = lookupInstEnv False inst_envs cls tys - dups = filter (identicalClsInstHead ispec) (map fst matches) - ; unless (null dups) $ - dupInstErr ispec (head dups) - - ; return (extendInstEnv home_ie' ispec, ispec : my_insts) } - -{- -Note [Signature files and type class instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instances in signature files do not have an effect when compiling: -when you compile a signature against an implementation, you will -see the instances WHETHER OR NOT the instance is declared in -the file (this is because the signatures go in the EPS and we -can't filter them out easily.) This is also why we cannot -place the instance in the hi file: it would show up as a duplicate, -and we don't have instance reexports anyway. - -However, you might find them useful when typechecking against -a signature: the instance is a way of indicating to GHC that -some instance exists, in case downstream code uses it. - -Implementing this is a little tricky. Consider the following -situation (sigof03): - - module A where - instance C T where ... - - module ASig where - instance C T - -When compiling ASig, A.hi is loaded, which brings its instances -into the EPS. When we process the instance declaration in ASig, -we should ignore it for the purpose of doing a duplicate check, -since it's not actually a duplicate. But don't skip the check -entirely, we still want this to fail (tcfail221): - - module ASig where - instance C T - instance C T - -Note that in some situations, the interface containing the type -class instances may not have been loaded yet at all. The usual -situation when A imports another module which provides the -instances (sigof02m): - - module A(module B) where - import B - -See also Note [Signature lazy interface loading]. We can't -rely on this, however, since sometimes we'll have spurious -type class instances in the EPS, see #9422 (sigof02dm) - -************************************************************************ -* * - Errors and tracing -* * -************************************************************************ --} - -traceDFuns :: [ClsInst] -> TcRn () -traceDFuns ispecs - = traceTc "Adding instances:" (vcat (map pp ispecs)) - where - pp ispec = hang (ppr (instanceDFunId ispec) <+> colon) - 2 (ppr ispec) - -- Print the dfun name itself too - -funDepErr :: ClsInst -> [ClsInst] -> TcRn () -funDepErr ispec ispecs - = addClsInstsErr (text "Functional dependencies conflict between instance declarations:") - (ispec : ispecs) - -dupInstErr :: ClsInst -> ClsInst -> TcRn () -dupInstErr ispec dup_ispec - = addClsInstsErr (text "Duplicate instance declarations:") - [ispec, dup_ispec] - -addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () -addClsInstsErr herald ispecs - = setSrcSpan (getSrcSpan (head sorted)) $ - addErr (hang herald 2 (pprInstances sorted)) - where - sorted = sortWith getSrcLoc ispecs - -- The sortWith just arranges that instances are dislayed in order - -- of source location, which reduced wobbling in error messages, - -- and is better for users diff --git a/typecheck/TcAnnotations.hs b/typecheck/TcAnnotations.hs deleted file mode 100644 --- a/typecheck/TcAnnotations.hs +++ /dev/null @@ -1,74 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[TcAnnotations]{Typechecking annotations} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -module TcAnnotations ( tcAnnotations, annCtxt ) where - -import {-# SOURCE #-} TcSplice ( runAnnotation ) -import Module -import DynFlags -import Control.Monad ( when ) - -import HsSyn -import Annotations -import Name -import TcRnMonad -import SrcLoc -import Outputable - --- Some platforms don't support the external interpreter, and --- compilation on those platforms shouldn't fail just due to --- annotations -#ifndef GHCI -tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] -tcAnnotations anns = do - dflags <- getDynFlags - case gopt Opt_ExternalInterpreter dflags of - True -> tcAnnotations' anns - False -> warnAnns anns -warnAnns :: [LAnnDecl Name] -> TcM [Annotation] ---- No GHCI; emit a warning (not an error) and ignore. cf Trac #4268 -warnAnns [] = return [] -warnAnns anns@(L loc _ : _) - = do { setSrcSpan loc $ addWarnTc NoReason $ - (text "Ignoring ANN annotation" <> plural anns <> comma - <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") - ; return [] } -#else -tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] -tcAnnotations = tcAnnotations' -#endif - -tcAnnotations' :: [LAnnDecl Name] -> TcM [Annotation] -tcAnnotations' anns = mapM tcAnnotation anns - -tcAnnotation :: LAnnDecl Name -> TcM Annotation -tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do - -- Work out what the full target of this annotation was - mod <- getModule - let target = annProvenanceToTarget mod provenance - - -- Run that annotation and construct the full Annotation data structure - setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do - -- See #10826 -- Annotations allow one to bypass Safe Haskell. - dflags <- getDynFlags - when (safeLanguageOn dflags) $ failWithTc safeHsErr - runAnnotation target expr - where - safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." - , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ] - -annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name -annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name -annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name -annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod - -annCtxt :: (OutputableBndrId id) => AnnDecl id -> SDoc -annCtxt ann - = hang (text "In the annotation:") 2 (ppr ann) diff --git a/typecheck/TcArrows.hs b/typecheck/TcArrows.hs deleted file mode 100644 --- a/typecheck/TcArrows.hs +++ /dev/null @@ -1,427 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -Typecheck arrow notation --} - -{-# LANGUAGE RankNTypes, TupleSections #-} - -module TcArrows ( tcProc ) where - -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) - -import HsSyn -import TcMatches -import TcHsSyn( hsLPatType ) -import TcType -import TcMType -import TcBinds -import TcPat -import TcUnify -import TcRnMonad -import TcEnv -import TcEvidence -import Id( mkLocalId ) -import Inst -import Name -import TysWiredIn -import VarSet -import TysPrim -import BasicTypes( Arity ) -import SrcLoc -import Outputable -import Util - -import Control.Monad - -{- -Note [Arrow overview] -~~~~~~~~~~~~~~~~~~~~~ -Here's a summary of arrows and how they typecheck. First, here's -a cut-down syntax: - - expr ::= .... - | proc pat cmd - - cmd ::= cmd exp -- Arrow application - | \pat -> cmd -- Arrow abstraction - | (| exp cmd1 ... cmdn |) -- Arrow form, n>=0 - | ... -- If, case in the usual way - - cmd_type ::= carg_type --> type - - carg_type ::= () - | (type, carg_type) - -Note that - * The 'exp' in an arrow form can mention only - "arrow-local" variables - - * An "arrow-local" variable is bound by an enclosing - cmd binding form (eg arrow abstraction) - - * A cmd_type is here written with a funny arrow "-->", - The bit on the left is a carg_type (command argument type) - which itself is a nested tuple, finishing with () - - * The arrow-tail operator (e1 -< e2) means - (| e1 <<< arr snd |) e2 - - -************************************************************************ -* * - Proc -* * -************************************************************************ --} - -tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr - -> ExpRhoType -- Expected type of whole proc expression - -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion) - -tcProc pat cmd exp_ty - = newArrowScope $ - do { exp_ty <- expTypeToType exp_ty -- no higher-rank stuff with arrows - ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty - ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 - ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $ - tcCmdTop cmd_env cmd (unitTy, res_ty) - ; let res_co = mkTcTransCo co - (mkTcAppCo co1 (mkTcNomReflCo res_ty)) - ; return (pat', cmd', res_co) } - -{- -************************************************************************ -* * - Commands -* * -************************************************************************ --} - --- See Note [Arrow overview] -type CmdType = (CmdArgType, TcTauType) -- cmd_type -type CmdArgType = TcTauType -- carg_type, a nested tuple - -data CmdEnv - = CmdEnv { - cmd_arr :: TcType -- arrow type constructor, of kind *->*->* - } - -mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType -mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] - ---------------------------------------- -tcCmdTop :: CmdEnv - -> LHsCmdTop Name - -> CmdType - -> TcM (LHsCmdTop TcId) - -tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty) - = setSrcSpan loc $ - do { cmd' <- tcCmd env cmd cmd_ty - ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names - ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } ----------------------------------------- -tcCmd :: CmdEnv -> LHsCmd Name -> CmdType -> TcM (LHsCmd TcId) - -- The main recursive function -tcCmd env (L loc cmd) res_ty - = setSrcSpan loc $ do - { cmd' <- tc_cmd env cmd res_ty - ; return (L loc cmd') } - -tc_cmd :: CmdEnv -> HsCmd Name -> CmdType -> TcM (HsCmd TcId) -tc_cmd env (HsCmdPar cmd) res_ty - = do { cmd' <- tcCmd env cmd res_ty - ; return (HsCmdPar cmd') } - -tc_cmd env (HsCmdLet (L l binds) (L body_loc body)) res_ty - = do { (binds', body') <- tcLocalBinds binds $ - setSrcSpan body_loc $ - tc_cmd env body res_ty - ; return (HsCmdLet (L l binds') (L body_loc body')) } - -tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty) - = addErrCtxt (cmdCtxt in_cmd) $ do - (scrut', scrut_ty) <- tcInferRho scrut - matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty) - return (HsCmdCase scrut' matches') - where - match_ctxt = MC { mc_what = CaseAlt, - mc_body = mc_body } - mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' - ; tcCmd env body (stk, res_ty') } - -tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty -- Ordinary 'if' - = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) - ; b1' <- tcCmd env b1 res_ty - ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf Nothing pred' b1' b2') - } - -tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if - = do { pred_ty <- newOpenFlexiTyVarTy - -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r - -- because we're going to apply it to the environment, not - -- the return value. - ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] - ; let r_ty = mkTyVarTy r_tv - ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) - (text "Predicate type of `ifThenElse' depends on result type") - ; (pred', fun') - <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty]) - (mkCheckExpType r_ty) $ \ _ -> - tcMonoExpr pred (mkCheckExpType pred_ty) - - ; b1' <- tcCmd env b1 res_ty - ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf (Just fun') pred' b1' b2') - } - -------------------------------------------- --- Arrow application --- (f -< a) or (f -<< a) --- --- D |- fun :: a t1 t2 --- D,G |- arg :: t1 --- ------------------------ --- D;G |-a fun -< arg :: stk --> t2 --- --- D,G |- fun :: a t1 t2 --- D,G |- arg :: t1 --- ------------------------ --- D;G |-a fun -<< arg :: stk --> t2 --- --- (plus -<< requires ArrowApply) - -tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newOpenFlexiTyVarTy - ; let fun_ty = mkCmdArrTy env arg_ty res_ty - ; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty)) - - ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - - ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } - where - -- Before type-checking f, use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside f. In the higher-order case (-<<), they are. - -- See Note [Escaping the arrow scope] in TcRnTypes - select_arrow_scope tc = case ho_app of - HsHigherOrderApp -> tc - HsFirstOrderApp -> escapeArrowScope tc - -------------------------------------------- --- Command application --- --- D,G |- exp : t --- D;G |-a cmd : (t,stk) --> res --- ----------------------------- --- D;G |-a cmd exp : stk --> res - -tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newOpenFlexiTyVarTy - ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) - ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - ; return (HsCmdApp fun' arg') } - -------------------------------------------- --- Lambda --- --- D;G,x:t |-a cmd : stk --> res --- ------------------------------ --- D;G |-a (\x.cmd) : (t,stk) --> res - -tc_cmd env - (HsCmdLam (MG { mg_alts = L l [L mtch_loc - (match@(Match _ pats _maybe_rhs_sig grhss))], - mg_origin = origin })) - (cmd_stk, res_ty) - = addErrCtxt (pprMatchInCtxt match) $ - do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk - - -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $ - tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) - - ; let match' = L mtch_loc (Match LambdaExpr pats' Nothing grhss') - arg_tys = map hsLPatType pats' - cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys - , mg_res_ty = res_ty, mg_origin = origin }) - ; return (mkHsCmdWrap (mkWpCastN co) cmd') } - where - n_pats = length pats - match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? - pg_ctxt = PatGuard match_ctxt - - tc_grhss (GRHSs grhss (L l binds)) stk_ty res_ty - = do { (binds', grhss') <- tcLocalBinds binds $ - mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss - ; return (GRHSs grhss' (L l binds')) } - - tc_grhs stk_ty res_ty (GRHS 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 guards' rhs') } - -------------------------------------------- --- Do notation - -tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty) - = do { co <- unifyType noThing unitTy cmd_stk -- Expecting empty argument stack - ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty - ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo (L l stmts') res_ty)) } - - ------------------------------------------------------------------ --- Arrow ``forms'' (| e c1 .. cn |) --- --- D; G |-a1 c1 : stk1 --> r1 --- ... --- D; G |-an cn : stkn --> rn --- D |- e :: forall e. a1 (e, stk1) t1 --- ... --- -> an (e, stkn) tn --- -> a (e, stk) t --- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) --- ---------------------------------------------- --- D; G |-a (| e c1 ... cn |) : stk --> t - -tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args - -- We use alphaTyVar for 'w' - ; let e_ty = mkInvForAllTy alphaTyVar $ - mkFunTys cmd_tys $ - mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty - ; expr' <- tcPolyExpr expr e_ty - ; return (HsCmdArrForm expr' f fixity cmd_args') } - - where - tc_cmd_arg :: LHsCmdTop Name -> TcM (LHsCmdTop TcId, TcType) - tc_cmd_arg cmd - = do { arr_ty <- newFlexiTyVarTy arrowTyConKind - ; stk_ty <- newFlexiTyVarTy liftedTypeKind - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; let env' = env { cmd_arr = arr_ty } - ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) - ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } - ------------------------------------------------------------------ --- Base case for illegal commands --- This is where expressions that aren't commands get rejected - -tc_cmd _ cmd _ - = failWithTc (vcat [text "The expression", nest 2 (ppr cmd), - text "was found where an arrow command was expected"]) - - -matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType) -matchExpectedCmdArgs 0 ty - = return (mkTcNomReflCo ty, [], ty) -matchExpectedCmdArgs n ty - = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty - ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 - ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } - -{- -************************************************************************ -* * - Stmts -* * -************************************************************************ --} - --------------------------------- --- Mdo-notation --- The distinctive features here are --- (a) RecStmts, and --- (b) no rebindable syntax - -tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker -tcArrDoStmt env _ (LastStmt rhs noret _) res_ty thing_inside - = do { rhs' <- tcCmd env rhs (unitTy, res_ty) - ; thing <- thing_inside (panic "tcArrDoStmt") - ; return (LastStmt rhs' noret noSyntaxExpr, thing) } - -tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside - = do { (rhs', elt_ty) <- tc_arr_rhs env rhs - ; thing <- thing_inside res_ty - ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } - -tcArrDoStmt env ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside - = do { (rhs', pat_ty) <- tc_arr_rhs env rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - thing_inside res_ty - ; return (mkTcBindStmt pat' rhs', thing) } - -tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names - , recS_rec_ids = rec_names }) res_ty thing_inside - = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names - ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys - ; tcExtendIdEnv tup_ids $ do - { (stmts', tup_rets) - <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> - -- ToDo: res_ty not really right - zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys) - - ; thing <- thing_inside res_ty - -- NB: The rec_ids for the recursive things - -- already scope over this part. This binding may shadow - -- some of them with polymorphic things with the same Name - -- (see note [RecStmt] in HsExpr) - - ; let rec_ids = takeList rec_names tup_ids - ; later_ids <- tcLookupLocalIds later_names - - ; let rec_rets = takeList rec_names tup_rets - ; let ret_table = zip tup_ids tup_rets - ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] - - ; return (emptyRecStmtId { recS_stmts = stmts' - , recS_later_ids = later_ids - , recS_later_rets = later_rets - , recS_rec_ids = rec_ids - , recS_rec_rets = rec_rets - , recS_ret_ty = res_ty }, thing) - }} - -tcArrDoStmt _ _ stmt _ _ - = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) - -tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType) -tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCmd env rhs (unitTy, ty) - ; return (rhs', ty) } - -{- -************************************************************************ -* * - Helpers -* * -************************************************************************ --} - -mkPairTy :: Type -> Type -> Type -mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] - -arrowTyConKind :: Kind -- *->*->* -arrowTyConKind = mkFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind - -{- -************************************************************************ -* * - Errors -* * -************************************************************************ --} - -cmdCtxt :: HsCmd Name -> SDoc -cmdCtxt cmd = text "In the command:" <+> ppr cmd diff --git a/typecheck/TcBackpack.hs b/typecheck/TcBackpack.hs deleted file mode 100644 --- a/typecheck/TcBackpack.hs +++ /dev/null @@ -1,903 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -module TcBackpack ( - findExtraSigImports', - findExtraSigImports, - implicitRequirements', - implicitRequirements, - checkUnitId, - tcRnCheckUnitId, - tcRnMergeSignatures, - mergeSignatures, - tcRnInstantiateSignature, - instantiateSignature, -) where - -import BasicTypes (defaultFixity) -import Packages -import TcRnExports -import DynFlags -import HsSyn -import RdrName -import TcRnMonad -import TcTyDecls -import InstEnv -import FamInstEnv -import Inst -import TcIface -import TcMType -import TcType -import TcSimplify -import LoadIface -import RnNames -import ErrUtils -import Id -import Module -import Name -import NameEnv -import NameSet -import Avail -import SrcLoc -import HscTypes -import Outputable -import Type -import FastString -import RnEnv -import Maybes -import TcEnv -import Var -import IfaceSyn -import PrelNames -import qualified Data.Map as Map - -import Finder -import UniqDSet -import NameShape -import TcErrors -import TcUnify -import RnModIface -import Util - -import Control.Monad -import Data.List (find, foldl') - -import {-# SOURCE #-} TcRnDriver - -#include "HsVersions.h" - -fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc -fixityMisMatch real_thing real_fixity sig_fixity = - vcat [ppr real_thing <+> text "has conflicting fixities in the module", - text "and its hsig file", - text "Main module:" <+> ppr_fix real_fixity, - text "Hsig file:" <+> ppr_fix sig_fixity] - where - ppr_fix f = - ppr f <+> - (if f == defaultFixity - then parens (text "default") - else empty) - -checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn () -checkHsigDeclM sig_iface sig_thing real_thing = do - let name = getName real_thing - -- TODO: Distinguish between signature merging and signature - -- implementation cases. - checkBootDeclM False sig_thing real_thing - real_fixity <- lookupFixityRn name - let sig_fixity = case mi_fix_fn sig_iface (occName name) of - Nothing -> defaultFixity - Just f -> f - when (real_fixity /= sig_fixity) $ - addErrAt (nameSrcSpan name) - (fixityMisMatch real_thing real_fixity sig_fixity) - --- | Given a 'ModDetails' of an instantiated signature (note that the --- 'ModDetails' must be knot-tied consistently with the actual implementation) --- and a 'GlobalRdrEnv' constructed from the implementor of this interface, --- verify that the actual implementation actually matches the original --- interface. --- --- Note that it is already assumed that the implementation *exports* --- a sufficient set of entities, since otherwise the renaming and then --- typechecking of the signature 'ModIface' would have failed. -checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn () -checkHsigIface tcg_env gr sig_iface - ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, - md_types = sig_type_env, md_exports = sig_exports } = do - traceTc "checkHsigIface" $ vcat - [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] - mapM_ check_export (map availName sig_exports) - unless (null sig_fam_insts) $ - panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++ - "instances in hsig files yet...") - -- Delete instances so we don't look them up when - -- checking instance satisfiability - -- TODO: this should not be necessary - tcg_env <- getGblEnv - setGblEnv tcg_env { tcg_inst_env = emptyInstEnv, - tcg_fam_inst_env = emptyFamInstEnv, - tcg_insts = [], - tcg_fam_insts = [] } $ do - mapM_ check_inst sig_insts - failIfErrsM - where - -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig - -- in package p that defines T; and we implement with himpl:H. Then the - -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just - -- have to look up the right name. - sig_type_occ_env = mkOccEnv - . map (\t -> (nameOccName (getName t), t)) - $ nameEnvElts sig_type_env - dfun_names = map getName sig_insts - check_export name - -- Skip instances, we'll check them later - -- TODO: Actually this should never happen, because DFuns are - -- never exported... - | name `elem` dfun_names = return () - -- See if we can find the type directly in the hsig ModDetails - -- TODO: need to special case wired in names - | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do - -- NB: We use tcLookupImported_maybe because we want to EXCLUDE - -- tcg_env (TODO: but maybe this isn't relevant anymore). - r <- tcLookupImported_maybe name - case r of - Failed err -> addErr err - Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing - - -- The hsig did NOT define this function; that means it must - -- be a reexport. In this case, make sure the 'Name' of the - -- reexport matches the 'Name exported here. - | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) = - when (name /= name') $ do - -- See Note [Error reporting bad reexport] - -- TODO: Actually this error swizzle doesn't work - let p (L _ ie) = name `elem` ieNames ie - loc = case tcg_rn_exports tcg_env of - Just es | Just e <- find p es - -- TODO: maybe we can be a little more - -- precise here and use the Located - -- info for the *specific* name we matched. - -> getLoc e - _ -> nameSrcSpan name - dflags <- getDynFlags - addErrAt loc - (badReexportedBootThing dflags False name name') - -- This should actually never happen, but whatever... - | otherwise = - addErrAt (nameSrcSpan name) - (missingBootThing False name "exported by") - --- Note [Error reporting bad reexport] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- NB: You want to be a bit careful about what location you report on reexports. --- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the --- correct source location. However, if it was *reexported*, obviously the name --- is not going to have the right location. In this case, we need to grovel in --- tcg_rn_exports to figure out where the reexport came from. - - - --- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't --- assume that the implementing file actually implemented the instances (they --- may be reexported from elsewhere). Where should we look for the instances? --- We do the same as we would otherwise: consult the EPS. This isn't perfect --- (we might conclude the module exports an instance when it doesn't, see --- #9422), but we will never refuse to compile something. -check_inst :: ClsInst -> TcM () -check_inst sig_inst = do - -- TODO: This could be very well generalized to support instance - -- declarations in boot files. - tcg_env <- getGblEnv - -- NB: Have to tug on the interface, not necessarily - -- tugged... but it didn't work? - mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst)) - -- Based off of 'simplifyDeriv' - let ty = idType (instanceDFunId sig_inst) - skol_info = InstSkol - -- Based off of tcSplitDFunTy - (tvs, theta, pred) = - case tcSplitForAllTys ty of { (tvs, rho) -> - case splitFunTys rho of { (theta, pred) -> - (tvs, theta, pred) }} - origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst - (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize - (cts, tclvl) <- pushTcLevelM $ do - wanted <- newWanted origin - (Just TypeLevel) - (substTy skol_subst pred) - givens <- forM theta $ \given -> do - loc <- getCtLocM origin (Just TypeLevel) - let given_pred = substTy skol_subst given - new_ev <- newEvVar given_pred - return CtGiven { ctev_pred = given_pred - -- Doesn't matter, make something up - , ctev_evar = new_ev - , ctev_loc = loc - } - return $ wanted : givens - unsolved <- simplifyWantedsTcM cts - - (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved - reportAllUnsolved (mkImplicWC implic) - --- | Return this list of requirement interfaces that need to be merged --- to form @mod_name@, or @[]@ if this is not a requirement. -requirementMerges :: DynFlags -> ModuleName -> [IndefModule] -requirementMerges dflags mod_name = - fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags))) - --- | For a module @modname@ of type 'HscSource', determine the list --- of extra "imports" of other requirements which should be considered part of --- the import of the requirement, because it transitively depends on those --- requirements by imports of modules from other packages. The situation --- is something like this: --- --- unit p where --- signature A --- signature B --- import A --- --- unit q where --- dependency p[A=,B=] --- signature A --- signature B --- --- Although q's B does not directly import A, we still have to make sure we --- process A first, because the merging process will cause B to indirectly --- import A. This function finds the TRANSITIVE closure of all such imports --- we need to make. -findExtraSigImports' :: HscEnv - -> HscSource - -> ModuleName - -> IO (UniqDSet ModuleName) -findExtraSigImports' hsc_env HsigFile modname = - fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) -> - (initIfaceLoad hsc_env - . withException - $ moduleFreeHolesPrecise (text "findExtraSigImports") - (mkModule (IndefiniteUnitId iuid) mod_name))) - where - reqs = requirementMerges (hsc_dflags hsc_env) modname - -findExtraSigImports' _ _ _ = return emptyUniqDSet - --- | 'findExtraSigImports', but in a convenient form for "GhcMake" and --- "TcRnDriver". -findExtraSigImports :: HscEnv -> HscSource -> ModuleName - -> IO [(Maybe FastString, Located ModuleName)] -findExtraSigImports hsc_env hsc_src modname = do - extra_requirements <- findExtraSigImports' hsc_env hsc_src modname - return [ (Nothing, noLoc mod_name) - | mod_name <- uniqDSetToList extra_requirements ] - --- A version of 'implicitRequirements'' which is more friendly --- for "GhcMake" and "TcRnDriver". -implicitRequirements :: HscEnv - -> [(Maybe FastString, Located ModuleName)] - -> IO [(Maybe FastString, Located ModuleName)] -implicitRequirements hsc_env normal_imports - = do mns <- implicitRequirements' hsc_env normal_imports - return [ (Nothing, noLoc mn) | mn <- mns ] - --- Given a list of 'import M' statements in a module, figure out --- any extra implicit requirement imports they may have. For --- example, if they 'import M' and M resolves to p[A=], then --- they actually also import the local requirement B. -implicitRequirements' :: HscEnv - -> [(Maybe FastString, Located ModuleName)] - -> IO [ModuleName] -implicitRequirements' hsc_env normal_imports - = fmap concat $ - forM normal_imports $ \(mb_pkg, L _ imp) -> do - found <- findImportedModule hsc_env imp mb_pkg - case found of - Found _ mod | thisPackage dflags /= moduleUnitId mod -> - return (uniqDSetToList (moduleFreeHoles mod)) - _ -> return [] - where dflags = hsc_dflags hsc_env - --- | Given a 'UnitId', make sure it is well typed. This is because --- unit IDs come from Cabal, which does not know if things are well-typed or --- not; a component may have been filled with implementations for the holes --- that don't actually fulfill the requirements. --- --- INVARIANT: the UnitId is NOT a InstalledUnitId -checkUnitId :: UnitId -> TcM () -checkUnitId uid = do - case splitUnitIdInsts uid of - (_, Just indef) -> - let insts = indefUnitIdInsts indef in - forM_ insts $ \(mod_name, mod) -> - -- NB: direct hole instantiations are well-typed by construction - -- (because we FORCE things to be merged in), so don't check them - when (not (isHoleModule mod)) $ do - checkUnitId (moduleUnitId mod) - _ <- mod `checkImplements` IndefModule indef mod_name - return () - _ -> return () -- if it's hashed, must be well-typed - --- | Top-level driver for signature instantiation (run when compiling --- an @hsig@ file.) -tcRnCheckUnitId :: - HscEnv -> UnitId -> - IO (Messages, Maybe ()) -tcRnCheckUnitId hsc_env uid = - withTiming (pure dflags) - (text "Check unit id" <+> ppr uid) - (const ()) $ - initTc hsc_env - HsigFile -- bogus - False - mAIN -- bogus - (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus - $ checkUnitId uid - where - dflags = hsc_dflags hsc_env - loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) - --- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear... - --- | Top-level driver for signature merging (run after typechecking --- an @hsig@ file). -tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface - -> IO (Messages, Maybe TcGblEnv) -tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = - withTiming (pure dflags) - (text "Signature merging" <+> brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env HsigFile False this_mod real_loc $ - mergeSignatures hpm orig_tcg_env iface - where - dflags = hsc_dflags hsc_env - this_mod = mi_module iface - real_loc = tcg_top_loc orig_tcg_env - -thinModIface :: [AvailInfo] -> ModIface -> ModIface -thinModIface avails iface = - iface { - mi_exports = avails, - -- mi_fixities = ..., - -- mi_warns = ..., - -- mi_anns = ..., - -- TODO: The use of nameOccName here is a bit dodgy, because - -- perhaps there might be two IfaceTopBndr that are the same - -- OccName but different Name. Requires better understanding - -- of invariants here. - mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls - -- mi_insts = ..., - -- mi_fam_insts = ..., - } - where - decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs - filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface) - - exported_occs = mkOccSet [ occName n - | a <- avails - , n <- availNames a ] - exported_decls = filter_decls exported_occs - - non_exported_occs = mkOccSet [ occName n - | (_, d) <- exported_decls - , n <- ifaceDeclNeverExportedRefs d ] - non_exported_decls = filter_decls non_exported_occs - - dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True - dfun_pred _ = False - dfun_decls = filter (dfun_pred . snd) (mi_decls iface) - --- | The list of 'Name's of *non-exported* 'IfaceDecl's which this --- 'IfaceDecl' may refer to. A non-exported 'IfaceDecl' should be kept --- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps) --- refers to it; we can't decide to keep it by looking at the exports --- of a module after thinning. Keep this synchronized with --- 'rnIfaceDecl'. -ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name] -ifaceDeclNeverExportedRefs d@IfaceFamily{} = - case ifFamFlav d of - IfaceClosedSynFamilyTyCon (Just (n, _)) - -> [n] - _ -> [] -ifaceDeclNeverExportedRefs _ = [] - - --- Note [Blank hsigs for all requirements] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- One invariant that a client of GHC must uphold is that there --- must be an hsig file for every requirement (according to --- @-this-unit-id@); this ensures that for every interface --- file (hi), there is a source file (hsig), which helps grease --- the wheels of recompilation avoidance which assumes that --- source files always exist. - -{- -inheritedSigPvpWarning :: WarningTxt -inheritedSigPvpWarning = - WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))] - where - msg = "Inherited requirements from non-signature libraries (libraries " ++ - "with modules) should not be used, as this mode of use is not " ++ - "compatible with PVP-style version bounds. Instead, copy the " ++ - "declaration to the local hsig file or move the signature to a " ++ - "library of its own and add that library as a dependency." --} - --- Note [Handling never-exported TyThings under Backpack] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will --- never be mentioned in the export list of a module (mi_avails). --- Unlike implicit TyThings (Note [Implicit TyThings]), non-exported --- TyThings DO have a standalone IfaceDecl declaration in their --- interface file. --- --- Originally, Backpack was designed under the assumption that anything --- you could declare in a module could also be exported; thus, merging --- the export lists of two signatures is just merging the declarations --- of two signatures writ small. Of course, in GHC Haskell, there are a --- few important things which are not explicitly exported but still can --- be used: in particular, dictionary functions for instances, Typeable --- TyCon bindings, and coercion axioms for type families also count. --- --- When handling these non-exported things, there two primary things --- we need to watch out for: --- --- * Signature matching/merging is done by comparing each --- of the exported entities of a signature and a module. These exported --- entities may refer to non-exported TyThings which must be tested for --- consistency. For example, an instance (ClsInst) will refer to a --- non-exported DFunId. In this case, 'checkBootDeclM' directly compares the --- embedded 'DFunId' in 'is_dfun'. --- --- For this to work at all, we must ensure that pointers in 'is_dfun' refer --- to DISTINCT 'DFunId's, even though the 'Name's (may) be the same. --- Unfortunately, this is the OPPOSITE of how we treat most other references --- to 'Name's, so this case needs to be handled specially. --- --- The details are in the documentation for 'typecheckIfacesForMerging'. --- and the Note [Resolving never-exported Names in TcIface]. --- --- * When we rename modules and signatures, we use the export lists to --- decide how the declarations should be renamed. However, this --- means we don't get any guidance for how to rename non-exported --- entities. Fortunately, we only need to rename these entities --- *consistently*, so that 'typecheckIfacesForMerging' can wire them --- up as needed. --- --- The details are in Note [rnIfaceNeverExported] in 'RnModIface'. --- --- The root cause for all of these complications is the fact that these --- logically "implicit" entities are defined indirectly in an interface --- file. #13151 gives a proposal to make these *truly* implicit. - -merge_msg :: ModuleName -> [IndefModule] -> SDoc -merge_msg mod_name [] = - text "while checking the local signature" <+> ppr mod_name <+> - text "for consistency" -merge_msg mod_name reqs = - hang (text "while merging the signatures from" <> colon) - 2 (vcat [ bullet <+> ppr req | req <- reqs ] $$ - bullet <+> text "...and the local signature for" <+> ppr mod_name) - --- | Given a local 'ModIface', merge all inherited requirements --- from 'requirementMerges' into this signature, producing --- a final 'TcGblEnv' that matches the local signature and --- all required signatures. -mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv -mergeSignatures - (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }), - hpm_src_files = src_files }) - orig_tcg_env lcl_iface0 = setSrcSpan loc $ do - -- The lcl_iface0 is the ModIface for the local hsig - -- file, which is guaranteed to exist, see - -- Note [Blank hsigs for all requirements] - hsc_env <- getTopEnv - dflags <- getDynFlags - tcg_env <- getGblEnv - let outer_mod = tcg_mod tcg_env - inner_mod = tcg_semantic_mod tcg_env - mod_name = moduleName (tcg_mod tcg_env) - - -- STEP 1: Figure out all of the external signature interfaces - -- we are going to merge in. - let reqs = requirementMerges dflags mod_name - - addErrCtxt (merge_msg mod_name reqs) $ do - - -- STEP 2: Read in the RAW forms of all of these interfaces - ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) -> - let m = mkModule (IndefiniteUnitId iuid) mod_name - im = fst (splitModuleInsts m) - in fmap fst - . withException - $ findAndReadIface (text "mergeSignatures") im m False - - -- STEP 3: Get the unrenamed exports of all these interfaces, - -- thin it according to the export list, and do shaping on them. - let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as - -- This function gets run on every inherited interface, and - -- it's responsible for: - -- - -- 1. Merging the exports of the interface into @nsubst@, - -- 2. Adding these exports to the "OK to import" set (@oks@) - -- if they came from a package with no exposed modules - -- (this means we won't report a PVP error in this case), and - -- 3. Thinning the interface according to an explicit export - -- list. - -- - gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do - let insts = indefUnitIdInsts iuid - as1 <- tcRnModExports insts ireq_iface - let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid)) - pkg = getInstalledPackageDetails dflags inst_uid - -- Setup the import spec correctly, so that when we apply - -- IEModuleContents we pick up EVERYTHING - ispec = ImpSpec - ImpDeclSpec{ - is_mod = mod_name, - is_as = mod_name, - is_qual = False, - is_dloc = loc - } ImpAll - rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1) - (thinned_iface, as2) <- case mb_exports of - Just (L loc _) - | null (exposedModules pkg) -> setSrcSpan loc $ do - -- Suppress missing errors; we'll pick em up - -- when we test exports on the final thing - (msgs, mb_r) <- tryTc $ - setGblEnv tcg_env { - tcg_rdr_env = rdr_env - } $ exports_from_avail mb_exports rdr_env - (tcg_imports tcg_env) (tcg_semantic_mod tcg_env) - case mb_r of - Just (_, as2) -> return (thinModIface as2 ireq_iface, as2) - Nothing -> addMessages msgs >> failM - _ -> return (ireq_iface, as1) - let oks' | null (exposedModules pkg) - = extendOccSetList oks (exportOccs as2) - | otherwise - = oks - mb_r <- extend_ns nsubst as2 - case mb_r of - Left err -> failWithTc err - Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces) - nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) - ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0)) - -- Process each interface, getting the thinned interfaces as well as - -- the final, full set of exports @nsubst@ and the exports which are - -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.) - (nsubst, ok_to_use, rev_thinned_ifaces) - <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0) - let thinned_ifaces = reverse rev_thinned_ifaces - exports = nameShapeExports nsubst - rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports) - _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports) - warns = NoWarnings - {- - -- TODO: Warnings are transitive, but this is not what we want here: - -- if a module reexports an entity from a signature, that should be OK. - -- Not supported in current warning framework - warns | null warn_occs = NoWarnings - | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs - -} - setGblEnv tcg_env { - -- The top-level GlobalRdrEnv is quite interesting. It consists - -- of two components: - -- 1. First, we reuse the GlobalRdrEnv of the local signature. - -- This is very useful, because it means that if we have - -- to print a message involving some entity that the local - -- signature imported, we'll qualify it accordingly. - -- 2. Second, we need to add all of the declarations we are - -- going to merge in (as they need to be in scope for the - -- final test of the export list.) - tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env, - -- Inherit imports from the local signature, so that module - -- rexports are picked up correctly - tcg_imports = tcg_imports orig_tcg_env, - tcg_exports = exports, - tcg_dus = usesOnly (availsToNameSetWithSelectors exports), - tcg_warns = warns - } $ do - tcg_env <- getGblEnv - - -- Make sure we didn't refer to anything that doesn't actually exist - -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return () - (mb_lies, _) <- exports_from_avail mb_exports rdr_env - (tcg_imports tcg_env) (tcg_semantic_mod tcg_env) - - -- If you tried to explicitly export an identifier that has a warning - -- attached to it, that's probably a mistake. Warn about it. - case mb_lies of - Nothing -> return () - Just lies -> - forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) -> - setSrcSpan loc $ - unless (nameOccName n `elemOccSet` ok_to_use) $ - addWarn NoReason $ vcat [ - text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.", - parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.") - ] - - failIfErrsM - - -- STEP 4: Rename the interfaces - ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) -> - tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface - lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0 - let ifaces = lcl_iface : ext_ifaces - - -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env - let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) - | (occ, f) <- concatMap mi_fixities ifaces - , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ] - - -- STEP 5: Typecheck the interfaces - let type_env_var = tcg_type_env_var tcg_env - - -- typecheckIfacesForMerging does two things: - -- 1. It merges the all of the ifaces together, and typechecks the - -- result to type_env. - -- 2. It typechecks each iface individually, but with their 'Name's - -- resolving to the merged type_env from (1). - -- See typecheckIfacesForMerging for more details. - (type_env, detailss) <- initIfaceTcRn $ - typecheckIfacesForMerging inner_mod ifaces type_env_var - let infos = zip ifaces detailss - - -- Test for cycles - checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) [] - - -- NB on type_env: it contains NO dfuns. DFuns are recorded inside - -- detailss, and given a Name that doesn't correspond to anything real. See - -- also Note [Signature merging DFuns] - - -- Add the merged type_env to TcGblEnv, so that it gets serialized - -- out when we finally write out the interface. - -- - -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly, - -- rather than use tcExtendGlobalEnv (the normal method to add newly - -- defined types to TcGblEnv?) tcExtendGlobalEnv adds these - -- TyThings to 'tcg_type_env_var', which is consulted when - -- we read in interfaces to tie the knot. But *these TyThings themselves - -- come from interface*, so that would result in deadlock. Don't - -- update it! - setGblEnv tcg_env { - tcg_tcs = typeEnvTyCons type_env, - tcg_patsyns = typeEnvPatSyns type_env, - tcg_type_env = type_env, - tcg_fix_env = fix_env - } $ do - tcg_env <- getGblEnv - - -- STEP 6: Check for compatibility/merge things - tcg_env <- (\x -> foldM x tcg_env infos) - $ \tcg_env (iface, details) -> do - - let check_export name - | Just sig_thing <- lookupTypeEnv (md_types details) name - = case lookupTypeEnv type_env (getName sig_thing) of - Just thing -> checkHsigDeclM iface sig_thing thing - Nothing -> panic "mergeSignatures: check_export" - -- Oops! We're looking for this export but it's - -- not actually in the type environment of the signature's - -- ModDetails. - -- - -- NB: This case happens because the we're iterating - -- over the union of all exports, so some interfaces - -- won't have everything. Note that md_exports is nonsense - -- (it's the same as exports); maybe we should fix this - -- eventually. - | otherwise - = return () - mapM_ check_export (map availName exports) - - -- Note [Signature merging instances] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Merge instances into the global environment. The algorithm here is - -- dumb and simple: if an instance has exactly the same DFun type - -- (tested by 'memberInstEnv') as an existing instance, we drop it; - -- otherwise, we add it even, even if this would cause overlap. - -- - -- Why don't we deduplicate instances with identical heads? There's no - -- good choice if they have premises: - -- - -- instance K1 a => K (T a) - -- instance K2 a => K (T a) - -- - -- Why not eagerly error in this case? The overlapping head does not - -- necessarily mean that the instances are unimplementable: in fact, - -- they may be implemented without overlap (if, for example, the - -- implementing module has 'instance K (T a)'; both are implemented in - -- this case.) The implements test just checks that the wanteds are - -- derivable assuming the givens. - -- - -- Still, overlapping instances with hypotheses like above are going - -- to be a bad deal, because instance resolution when we're typechecking - -- against the merged signature is going to have a bad time when - -- there are overlapping heads like this: we never backtrack, so it - -- may be difficult to see that a wanted is derivable. For now, - -- we hope that we get lucky / the overlapping instances never - -- get used, but it is not a very good situation to be in. - -- - let merge_inst (insts, inst_env) inst - | memberInstEnv inst_env inst -- test DFun Type equality - = (insts, inst_env) - | otherwise - -- NB: is_dfun_name inst is still nonsense here, - -- see Note [Signature merging DFuns] - = (inst:insts, extendInstEnv inst_env inst) - (insts, inst_env) = foldl' merge_inst - (tcg_insts tcg_env, tcg_inst_env tcg_env) - (md_insts details) - -- This is a HACK to prevent calculateAvails from including imp_mod - -- in the listing. We don't want it because a module is NOT - -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 - iface' = iface { mi_orphan = False, mi_finsts = False } - avails = plusImportAvails (tcg_imports tcg_env) $ - calculateAvails dflags iface' False False ImportedBySystem - return tcg_env { - tcg_inst_env = inst_env, - tcg_insts = insts, - tcg_imports = avails, - tcg_merged = - if outer_mod == mi_module iface - -- Don't add ourselves! - then tcg_merged tcg_env - else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env - } - - -- Note [Signature merging DFuns] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Once we know all of instances which will be defined by this merged - -- signature, we go through each of the DFuns and rename them with a fresh, - -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing - -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'. - -- - -- We can't do this fixup earlier, because we need a way to identify each - -- source DFun (from each of the signatures we are merging in) so that - -- when we have a ClsInst, we can pull up the correct DFun to check if - -- the types match. - -- - -- See also Note [rnIfaceNeverExported] in RnModIface - dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do - n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst)) - let dfun = setVarName (is_dfun inst) n - return (dfun, inst { is_dfun_name = n, is_dfun = dfun }) - tcg_env <- return tcg_env { - tcg_insts = map snd dfun_insts, - tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) - } - - addDependentFiles src_files - - return tcg_env - --- | Top-level driver for signature instantiation (run when compiling --- an @hsig@ file.) -tcRnInstantiateSignature :: - HscEnv -> Module -> RealSrcSpan -> - IO (Messages, Maybe TcGblEnv) -tcRnInstantiateSignature hsc_env this_mod real_loc = - withTiming (pure dflags) - (text "Signature instantiation"<+>brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature - where - dflags = hsc_dflags hsc_env - -exportOccs :: [AvailInfo] -> [OccName] -exportOccs = concatMap (map occName . availNames) - -impl_msg :: Module -> IndefModule -> SDoc -impl_msg impl_mod (IndefModule req_uid req_mod_name) = - text "while checking that" <+> ppr impl_mod <+> - text "implements signature" <+> ppr req_mod_name <+> - text "in" <+> ppr req_uid - --- | Check if module implements a signature. (The signature is --- always un-hashed, which is why its components are specified --- explicitly.) -checkImplements :: Module -> IndefModule -> TcRn TcGblEnv -checkImplements impl_mod req_mod@(IndefModule uid mod_name) = - addErrCtxt (impl_msg impl_mod req_mod) $ do - let insts = indefUnitIdInsts uid - - -- STEP 1: Load the implementing interface, and make a RdrEnv - -- for its exports. Also, add its 'ImportAvails' to 'tcg_imports', - -- so that we treat all orphan instances it provides as visible - -- when we verify that all instances are checked (see #12945), and so that - -- when we eventually write out the interface we record appropriate - -- dependency information. - impl_iface <- initIfaceTcRn $ - loadSysInterface (text "checkImplements 1") impl_mod - let impl_gr = mkGlobalRdrEnv - (gresFromAvails Nothing (mi_exports impl_iface)) - nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) - - -- Load all the orphans, so the subsequent 'checkHsigIface' sees - -- all the instances it needs to - loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") - (dep_orphs (mi_deps impl_iface)) - - dflags <- getDynFlags - let avails = calculateAvails dflags - impl_iface False{- safe -} False{- boot -} ImportedBySystem - fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) - | (occ, f) <- mi_fixities impl_iface - , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ] - updGblEnv (\tcg_env -> tcg_env { - -- Setting tcg_rdr_env to treat all exported entities from - -- the implementing module as in scope improves error messages, - -- as it reduces the amount of qualification we need. Unfortunately, - -- we still end up qualifying references to external modules - -- (see bkpfail07 for an example); we'd need to record more - -- information in ModIface to solve this. - tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr, - tcg_imports = tcg_imports tcg_env `plusImportAvails` avails, - -- This is here so that when we call 'lookupFixityRn' for something - -- directly implemented by the module, we grab the right thing - tcg_fix_env = fix_env - }) $ do - - -- STEP 2: Load the *unrenamed, uninstantiated* interface for - -- the ORIGINAL signature. We are going to eventually rename it, - -- but we must proceed slowly, because it is NOT known if the - -- instantiation is correct. - let sig_mod = mkModule (IndefiniteUnitId uid) mod_name - isig_mod = fst (splitModuleInsts sig_mod) - mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False - isig_iface <- case mb_isig_iface of - Succeeded (iface, _) -> return iface - Failed err -> failWithTc $ - hang (text "Could not find hi interface for signature" <+> - quotes (ppr isig_mod) <> colon) 4 err - - -- STEP 3: Check that the implementing interface exports everything - -- we need. (Notice we IGNORE the Modules in the AvailInfos.) - forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> - case lookupGlobalRdrEnv impl_gr occ of - [] -> addErr $ quotes (ppr occ) - <+> text "is exported by the hsig file, but not" - <+> text "exported by the implementing module" - <+> quotes (ppr impl_mod) - _ -> return () - failIfErrsM - - -- STEP 4: Now that the export is complete, rename the interface... - sig_iface <- tcRnModIface insts (Just nsubst) isig_iface - - -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst - -- lets us determine how top-level identifiers should be handled.) - sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface - - -- STEP 6: Check that it's sufficient - tcg_env <- getGblEnv - checkHsigIface tcg_env impl_gr sig_iface sig_details - - -- STEP 7: Return the updated 'TcGblEnv' with the signature exports, - -- so we write them out. - return tcg_env { - tcg_exports = mi_exports sig_iface - } - --- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite --- library to use the actual implementations of the relevant entities, --- checking that the implementation matches the signature. -instantiateSignature :: TcRn TcGblEnv -instantiateSignature = do - tcg_env <- getGblEnv - dflags <- getDynFlags - let outer_mod = tcg_mod tcg_env - inner_mod = tcg_semantic_mod tcg_env - -- TODO: setup the local RdrEnv so the error messages look a little better. - -- But this information isn't stored anywhere. Should we RETYPECHECK - -- the local one just to get the information? Hmm... - MASSERT( moduleUnitId outer_mod == thisPackage dflags ) - inner_mod `checkImplements` - IndefModule - (newIndefUnitId (thisComponentId dflags) - (thisUnitIdInsts dflags)) - (moduleName outer_mod) diff --git a/typecheck/TcBinds.hs b/typecheck/TcBinds.hs deleted file mode 100644 --- a/typecheck/TcBinds.hs +++ /dev/null @@ -1,1738 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcBinds]{TcBinds} --} - -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} - -module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, - tcHsBootSigs, tcPolyCheck, - tcVectDecls, addTypecheckedBinds, - chooseInferredQuantifiers, - badBootDeclErr ) where - -import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl - , tcPatSynBuilderBind ) -import CoreSyn (Tickish (..)) -import CostCentre (mkUserCC) -import DynFlags -import FastString -import HsSyn -import HscTypes( isHsBootOrSig ) -import TcSigs -import TcRnMonad -import TcEnv -import TcUnify -import TcSimplify -import TcEvidence -import TcHsType -import TcPat -import TcMType -import FamInstEnv( normaliseType ) -import FamInst( tcGetFamInstEnvs ) -import TyCon -import TcType -import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder, splitTyConApp_maybe) -import TysPrim -import TysWiredIn( mkBoxedTupleTy ) -import Id -import Var -import VarSet -import VarEnv( TidyEnv ) -import Module -import Name -import NameSet -import NameEnv -import SrcLoc -import Bag -import ListSetOps -import ErrUtils -import Digraph -import Maybes -import Util -import BasicTypes -import Outputable -import PrelNames( ipClassName ) -import TcValidity (checkValidType) -import Unique (getUnique) -import UniqFM -import UniqSet -import qualified GHC.LanguageExtensions as LangExt -import ConLike - -import Control.Monad - -#include "HsVersions.h" - -{- ********************************************************************* -* * - A useful helper function -* * -********************************************************************* -} - -addTypecheckedBinds :: TcGblEnv -> [LHsBinds Id] -> TcGblEnv -addTypecheckedBinds tcg_env binds - | isHsBootOrSig (tcg_src tcg_env) = tcg_env - -- Do not add the code for record-selector bindings - -- when compiling hs-boot files - | otherwise = tcg_env { tcg_binds = foldr unionBags - (tcg_binds tcg_env) - binds } - -{- -************************************************************************ -* * -\subsection{Type-checking bindings} -* * -************************************************************************ - -@tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because -it needs to know something about the {\em usage} of the things bound, -so that it can create specialisations of them. So @tcBindsAndThen@ -takes a function which, given an extended environment, E, typechecks -the scope of the bindings returning a typechecked thing and (most -important) an LIE. It is this LIE which is then used as the basis for -specialising the things bound. - -@tcBindsAndThen@ also takes a "combiner" which glues together the -bindings and the "thing" to make a new "thing". - -The real work is done by @tcBindWithSigsAndThen@. - -Recursive and non-recursive binds are handled in essentially the same -way: because of uniques there are no scoping issues left. The only -difference is that non-recursive bindings can bind primitive values. - -Even for non-recursive binding groups we add typings for each binder -to the LVE for the following reason. When each individual binding is -checked the type of its LHS is unified with that of its RHS; and -type-checking the LHS of course requires that the binder is in scope. - -At the top-level the LIE is sure to contain nothing but constant -dictionaries, which we resolve at the module level. - -Note [Polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The game plan for polymorphic recursion in the code above is - - * Bind any variable for which we have a type signature - to an Id with a polymorphic type. Then when type-checking - the RHSs we'll make a full polymorphic call. - -This fine, but if you aren't a bit careful you end up with a horrendous -amount of partial application and (worse) a huge space leak. For example: - - f :: Eq a => [a] -> [a] - f xs = ...f... - -If we don't take care, after typechecking we get - - f = /\a -> \d::Eq a -> let f' = f a d - in - \ys:[a] -> ...f'... - -Notice the the stupid construction of (f a d), which is of course -identical to the function we're executing. In this case, the -polymorphic recursion isn't being used (but that's a very common case). -This can lead to a massive space leak, from the following top-level defn -(post-typechecking) - - ff :: [Int] -> [Int] - ff = f Int dEqInt - -Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but -f' is another thunk which evaluates to the same thing... and you end -up with a chain of identical values all hung onto by the CAF ff. - - ff = f Int dEqInt - - = let f' = f Int dEqInt in \ys. ...f'... - - = let f' = let f' = f Int dEqInt in \ys. ...f'... - in \ys. ...f'... - -Etc. - -NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), -which would make the space leak go away in this case - -Solution: when typechecking the RHSs we always have in hand the -*monomorphic* Ids for each binding. So we just need to make sure that -if (Method f a d) shows up in the constraints emerging from (...f...) -we just use the monomorphic Id. We achieve this by adding monomorphic Ids -to the "givens" when simplifying constraints. That's what the "lies_avail" -is doing. - -Then we get - - f = /\a -> \d::Eq a -> letrec - fm = \ys:[a] -> ...fm... - in - fm --} - -tcTopBinds :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM (TcGblEnv, TcLclEnv) --- The TcGblEnv contains the new tcg_binds and tcg_spects --- The TcLclEnv has an extended type envt for the new bindings -tcTopBinds binds sigs - = do { -- Pattern synonym bindings populate the global environment - (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $ - do { gbl <- getGblEnv - ; lcl <- getLclEnv - ; return (gbl, lcl) } - ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids - - ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs - ; traceTc "complete_matches" (ppr binds $$ ppr sigs) - ; traceTc "complete_matches" (ppr complete_matches) - - ; let { tcg_env' = tcg_env { tcg_imp_specs - = specs ++ tcg_imp_specs tcg_env - , tcg_complete_matches - = complete_matches - ++ tcg_complete_matches tcg_env } - `addTypecheckedBinds` map snd binds' } - - ; return (tcg_env', tcl_env) } - -- The top level bindings are flattened into a giant - -- implicitly-mutually-recursive LHsBinds - - --- Note [Typechecking Complete Matches] --- Much like when a user bundled a pattern synonym, the result types of --- all the constructors in the match pragma must be consistent. --- --- If we allowed pragmas with inconsistent types then it would be --- impossible to ever match every constructor in the list and so --- the pragma would be useless. - - - - - --- This is only used in `tcCompleteSig`. We fold over all the conlikes, --- this accumulator keeps track of the first `ConLike` with a concrete --- return type. After fixing the return type, all other constructors with --- a fixed return type must agree with this. --- --- The fields of `Fixed` cache the first conlike and its return type so --- that that we can compare all the other conlikes to it. The conlike is --- stored for error messages. --- --- `Nothing` in the case that the type is fixed by a type signature -data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon - -tcCompleteSigs :: [LSig Name] -> TcM [CompleteMatch] -tcCompleteSigs sigs = - let - doOne :: Sig Name -> TcM (Maybe CompleteMatch) - doOne c@(CompleteMatchSig _ lns mtc) - = fmap Just $ do - addErrCtxt (text "In" <+> ppr c) $ - case mtc of - Nothing -> infer_complete_match - Just tc -> check_complete_match tc - where - - checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns) - - infer_complete_match = do - (res, cls) <- checkCLTypes AcceptAny - case res of - AcceptAny -> failWithTc ambiguousError - Fixed _ tc -> return $ mkMatch cls tc - - check_complete_match tc_name = do - ty_con <- tcLookupLocatedTyCon tc_name - (_, cls) <- checkCLTypes (Fixed Nothing ty_con) - return $ mkMatch cls ty_con - - mkMatch :: [ConLike] -> TyCon -> CompleteMatch - mkMatch cls ty_con = CompleteMatch { - completeMatchConLikes = map conLikeName cls, - completeMatchTyCon = tyConName ty_con - } - doOne _ = return Nothing - - ambiguousError :: SDoc - ambiguousError = - text "A type signature must be provided for a set of polymorphic" - <+> text "pattern synonyms." - - - -- See note [Typechecking Complete Matches] - checkCLType :: (CompleteSigType, [ConLike]) -> Located Name - -> TcM (CompleteSigType, [ConLike]) - checkCLType (cst, cs) n = do - cl <- addLocM tcLookupConLike n - let (_,_,_,_,_,_, res_ty) = conLikeFullSig cl - res_ty_con = fst <$> splitTyConApp_maybe res_ty - case (cst, res_ty_con) of - (AcceptAny, Nothing) -> return (AcceptAny, cl:cs) - (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs) - (Fixed mfcl tc, Nothing) -> return (Fixed mfcl tc, cl:cs) - (Fixed mfcl tc, Just tc') -> - if tc == tc' - then return (Fixed mfcl tc, cl:cs) - else case mfcl of - Nothing -> - addErrCtxt (text "In" <+> ppr cl) $ - failWithTc typeSigErrMsg - Just cl -> failWithTc (errMsg cl) - where - typeSigErrMsg :: SDoc - typeSigErrMsg = - text "Couldn't match expected type" - <+> quotes (ppr tc) - <+> text "with" - <+> quotes (ppr tc') - - errMsg :: ConLike -> SDoc - errMsg fcl = - text "Cannot form a group of complete patterns from patterns" - <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl) - <+> text "as they match different type constructors" - <+> parens (quotes (ppr tc) - <+> text "resp." - <+> quotes (ppr tc')) - in mapMaybeM (addLocM doOne) sigs - -tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv -tcRecSelBinds (ValBindsOut binds sigs) - = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ - do { (rec_sel_binds, tcg_env) <- discardWarnings $ - tcValBinds TopLevel binds sigs getGblEnv - ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds - ; return tcg_env' } -tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds" - -tcHsBootSigs :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM [Id] --- A hs-boot file has only one BindGroup, and it only has type --- signatures in it. The renamer checked all this -tcHsBootSigs binds sigs - = do { checkTc (null binds) badBootDeclErr - ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } - where - tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames - where - f (L _ name) - = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty - ; return (mkVanillaGlobal name sigma_ty) } - -- Notice that we make GlobalIds, not LocalIds - tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) - -badBootDeclErr :: MsgDoc -badBootDeclErr = text "Illegal declarations in an hs-boot file" - ------------------------- -tcLocalBinds :: HsLocalBinds Name -> TcM thing - -> TcM (HsLocalBinds TcId, thing) - -tcLocalBinds EmptyLocalBinds thing_inside - = do { thing <- thing_inside - ; return (EmptyLocalBinds, thing) } - -tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside - = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside - ; return (HsValBinds (ValBindsOut binds' sigs), thing) } -tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds" - -tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside - = do { ipClass <- tcLookupClass ipClassName - ; (given_ips, ip_binds') <- - mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds - - -- If the binding binds ?x = E, we must now - -- discharge any ?x constraints in expr_lie - -- See Note [Implicit parameter untouchables] - ; (ev_binds, result) <- checkConstraints (IPSkol ips) - [] given_ips thing_inside - - ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) } - where - ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds] - - -- I wonder if we should do these one at at time - -- Consider ?x = 4 - -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr) - = do { ty <- newOpenFlexiTyVarTy - ; let p = mkStrLitTy $ hsIPNameFS ip - ; ip_id <- newDict ipClass [ p, ty ] - ; expr' <- tcMonoExpr expr (mkCheckExpType ty) - ; let d = toDict ipClass p ty `fmap` expr' - ; return (ip_id, (IPBind (Right ip_id) d)) } - tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind" - - -- Coerces a `t` into a dictionry for `IP "x" t`. - -- co : t -> IP "x" t - toDict ipClass x ty = HsWrap $ 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 Name)] -> [LSig Name] - -> TcM thing - -> TcM ([(RecFlag, LHsBinds TcId)], thing) - -tcValBinds top_lvl binds sigs thing_inside - = do { let patsyns = getPatSynBinds binds - - -- Typecheck the signature - ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $ - tcTySigs sigs - - ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds) - - -- Extend the envt right away with all the Ids - -- declared with complete type signatures - -- Do not extend the TcIdBinderStack; instead - -- we extend it on a per-rhs basis in tcExtendForRhs - ; tcExtendSigIds top_lvl poly_ids $ do - { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do - { thing <- thing_inside - -- See Note [Pattern synonym builders don't yield dependencies] - -- in RnBinds - ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns - ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ] - ; return (extra_binds, thing) } - ; return (binds' ++ extra_binds', thing) }} - ------------------------- -tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv - -> [(RecFlag, LHsBinds Name)] -> TcM thing - -> TcM ([(RecFlag, LHsBinds TcId)], thing) --- Typecheck a whole lot of value bindings, --- one strongly-connected component at a time --- Here a "strongly connected component" has the strightforward --- meaning of a group of bindings that mention each other, --- ignoring type signatures (that part comes later) - -tcBindGroups _ _ _ [] thing_inside - = do { thing <- thing_inside - ; return ([], thing) } - -tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside - = do { -- See Note [Closed binder groups] - type_env <- getLclTypeEnv - ; let closed = isClosedBndrGroup type_env (snd group) - ; (group', (groups', thing)) - <- tc_group top_lvl sig_fn prag_fn group closed $ - tcBindGroups top_lvl sig_fn prag_fn groups thing_inside - ; return (group' ++ groups', thing) } - --- Note [Closed binder groups] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- A mutually recursive group is "closed" if all of the free variables of --- the bindings are closed. For example --- --- > h = \x -> let f = ...g... --- > g = ....f...x... --- > in ... --- --- Here @g@ is not closed because it mentions @x@; and hence neither is @f@ --- closed. --- --- So we need to compute closed-ness on each strongly connected components, --- before we sub-divide it based on what type signatures it has. --- - ------------------------- -tc_group :: forall thing. - TopLevelFlag -> TcSigFun -> TcPragEnv - -> (RecFlag, LHsBinds Name) -> IsGroupClosed -> TcM thing - -> TcM ([(RecFlag, LHsBinds TcId)], thing) - --- Typecheck one strongly-connected component of the original program. --- We get a list of groups back, because there may --- be specialisations etc as well - -tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside - -- A single non-recursive binding - -- We want to keep non-recursive things non-recursive - -- so that we desugar unlifted bindings correctly - = do { let bind = case bagToList binds of - [bind] -> bind - [] -> panic "tc_group: empty list of binds" - _ -> panic "tc_group: NonRecursive binds is not a singleton bag" - ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed - thing_inside - ; return ( [(NonRecursive, bind')], thing) } - -tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside - = -- To maximise polymorphism, we do a new - -- strongly-connected-component analysis, this time omitting - -- any references to variables with type signatures. - -- (This used to be optional, but isn't now.) - -- See Note [Polymorphic recursion] in HsBinds. - do { traceTc "tc_group rec" (pprLHsBinds binds) - ; when hasPatSyn $ recursivePatSynErr binds - ; (binds1, thing) <- go sccs - ; return ([(Recursive, binds1)], thing) } - -- Rec them all together - where - hasPatSyn = anyBag (isPatSyn . unLoc) binds - isPatSyn PatSynBind{} = True - isPatSyn _ = False - - sccs :: [SCC (LHsBind Name)] - sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds) - - go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing) - go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc - ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn - closed ids1 $ - go sccs - ; return (binds1 `unionBags` binds2, thing) } - go [] = do { thing <- thing_inside; return (emptyBag, thing) } - - tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] - tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds - - tc_sub_group rec_tc binds = - tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds - -recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a -recursivePatSynErr binds - = failWithTc $ - hang (text "Recursive pattern synonym definition with following bindings:") - 2 (vcat $ map pprLBind . bagToList $ binds) - where - pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> - pprLoc loc - -tc_single :: forall thing. - TopLevelFlag -> TcSigFun -> TcPragEnv - -> LHsBind Name -> IsGroupClosed -> TcM thing - -> TcM (LHsBinds TcId, thing) -tc_single _top_lvl sig_fn _prag_fn - (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) - _ thing_inside - = do { (aux_binds, tcg_env) <- tc_pat_syn_decl - ; thing <- setGblEnv tcg_env thing_inside - ; return (aux_binds, thing) - } - where - tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv) - tc_pat_syn_decl = case sig_fn name of - Nothing -> tcInferPatSynDecl psb - Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi - Just _ -> panic "tc_single" - -tc_single top_lvl sig_fn prag_fn lbind closed thing_inside - = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn - NonRecursive NonRecursive - closed - [lbind] - ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside - ; return (binds1, thing) } - ------------------------- -type BKey = Int -- Just number off the bindings - -mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)] --- See Note [Polymorphic recursion] in HsBinds. -mkEdges sig_fn binds - = [ (bind, key, [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)), - Just key <- [lookupNameEnv key_map n], no_sig n ]) - | (bind, key) <- keyd_binds - ] - -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices - -- is still deterministic even if the edges are in nondeterministic order - -- as explained in Note [Deterministic SCC] in Digraph. - where - no_sig :: Name -> Bool - no_sig n = not (hasCompleteSig sig_fn n) - - keyd_binds = bagToList binds `zip` [0::BKey ..] - - key_map :: NameEnv BKey -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds - , bndr <- collectHsBindBinders bind ] - ------------------------- -tcPolyBinds :: TcSigFun -> TcPragEnv - -> RecFlag -- Whether the group is really recursive - -> RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> IsGroupClosed -- Whether the group is closed - -> [LHsBind Name] -- None are PatSynBind - -> TcM (LHsBinds TcId, [TcId]) - --- Typechecks a single bunch of values bindings all together, --- and generalises them. The bunch may be only part of a recursive --- group, because we use type signatures to maximise polymorphism --- --- Returns a list because the input may be a single non-recursive binding, --- in which case the dependency order of the resulting bindings is --- important. --- --- Knows nothing about the scope of the bindings --- None of the bindings are pattern synonyms - -tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list - = setSrcSpan loc $ - recoverM (recoveryCode binder_names sig_fn) $ do - -- Set up main recover; take advantage of any type sigs - - { traceTc "------------------------------------------------" Outputable.empty - ; traceTc "Bindings for {" (ppr binder_names) - ; dflags <- getDynFlags - ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn - ; traceTc "Generalisation plan" (ppr plan) - ; result@(_, poly_ids) <- case plan of - NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list - InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list - CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind - - ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group - , vcat [ppr id <+> ppr (idType id) | id <- poly_ids] - ]) - - ; return result } - where - binder_names = collectHsBindListBinders bind_list - loc = foldr1 combineSrcSpans (map getLoc bind_list) - -- The mbinds have been dependency analysed and - -- may no longer be adjacent; so find the narrowest - -- span that includes them all - --------------- --- If typechecking the binds fails, then return with each --- signature-less binder given type (forall a.a), to minimise --- subsequent error messages -recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id]) -recoveryCode binder_names sig_fn - = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) - ; let poly_ids = map mk_dummy binder_names - ; return (emptyBag, poly_ids) } - where - mk_dummy name - | Just sig <- sig_fn name - , Just poly_id <- completeSigPolyId_maybe sig - = poly_id - | otherwise - = mkLocalId name forall_a_a - -forall_a_a :: TcType -forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy - -{- ********************************************************************* -* * - tcPolyNoGen -* * -********************************************************************* -} - -tcPolyNoGen -- No generalisation whatsoever - :: RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> TcPragEnv -> TcSigFun - -> [LHsBind Name] - -> TcM (LHsBinds TcId, [TcId]) - -tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list - = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn - (LetGblBndr prag_fn) - bind_list - ; mono_ids' <- mapM tc_mono_info mono_infos - ; return (binds', mono_ids') } - where - tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id }) - = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name) - ; return mono_id } - -- NB: tcPrags generates error messages for - -- specialisation pragmas for non-overloaded sigs - -- Indeed that is why we call it here! - -- So we can safely ignore _specs - - -{- ********************************************************************* -* * - tcPolyCheck -* * -********************************************************************* -} - -tcPolyCheck :: TcPragEnv - -> TcIdSigInfo -- Must be a complete signature - -> LHsBind Name -- Must be a FunBind - -> TcM (LHsBinds TcId, [TcId]) --- There is just one binding, --- it is a Funbind --- it has a complete type signature, -tcPolyCheck prag_fn - (CompleteSig { sig_bndr = poly_id - , sig_ctxt = ctxt - , sig_loc = sig_loc }) - (L loc (FunBind { fun_id = L nm_loc name - , fun_matches = matches })) - = setSrcSpan sig_loc $ - do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) - ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id - -- See Note [Instantiate sig with fresh variables] - - ; mono_name <- newNameAt (nameOccName name) nm_loc - ; ev_vars <- newEvVars theta - ; let mono_id = mkLocalId mono_name tau - skol_info = SigSkol ctxt (idType poly_id) tv_prs - skol_tvs = map snd tv_prs - - ; (ev_binds, (co_fn, matches')) - <- checkConstraints skol_info skol_tvs ev_vars $ - tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $ - tcExtendTyVarEnv2 tv_prs $ - setSrcSpan loc $ - tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau) - - ; let prag_sigs = lookupPragEnv prag_fn name - ; spec_prags <- tcSpecPrags poly_id prag_sigs - ; poly_id <- addInlinePrags poly_id prag_sigs - - ; mod <- getModule - ; let bind' = FunBind { fun_id = L nm_loc mono_id - , fun_matches = matches' - , fun_co_fn = co_fn - , bind_fvs = placeHolderNamesTc - , fun_tick = funBindTicks nm_loc mono_id mod prag_sigs } - - abs_bind = L loc $ AbsBindsSig - { abs_sig_export = poly_id - , abs_tvs = skol_tvs - , abs_ev_vars = ev_vars - , abs_sig_prags = SpecPrags spec_prags - , abs_sig_ev_bind = ev_binds - , abs_sig_bind = L loc bind' } - - ; return (unitBag abs_bind, [poly_id]) } - -tcPolyCheck _prag_fn sig bind - = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) - -funBindTicks :: SrcSpan -> TcId -> Module -> [LSig Name] -> [Tickish TcId] -funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ] - -- this can only be a singleton list, as duplicate pragmas are rejected - -- by the renamer - , let cc_str - | Just cc_str <- mb_cc_str - = sl_fs $ unLoc cc_str - | otherwise - = getOccFS (Var.varName fun_id) - cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str - cc = mkUserCC cc_name mod loc (getUnique fun_id) - = [ProfNote cc True True] - | otherwise - = [] - -{- Note [Instantiate sig with fresh variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's vital to instantiate a type signature with fresh variables. -For example: - type T = forall a. [a] -> [a] - f :: T; - f = g where { g :: T; g = } - - We must not use the same 'a' from the defn of T at both places!! -(Instantiation is only necessary because of type synonyms. Otherwise, -it's all cool; each signature has distinct type variables from the renamer.) --} - - -{- ********************************************************************* -* * - tcPolyInfer -* * -********************************************************************* -} - -tcPolyInfer - :: RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> TcPragEnv -> TcSigFun - -> Bool -- True <=> apply the monomorphism restriction - -> [LHsBind Name] - -> TcM (LHsBinds TcId, [TcId]) -tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list - = do { (tclvl, wanted, (binds', mono_infos)) - <- pushLevelAndCaptureConstraints $ - tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list - - ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info)) - | info <- mono_infos ] - sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ] - infer_mode = if mono then ApplyMR else NoRestrictions - - ; mapM_ (checkOverloadedSig mono) sigs - - ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) - ; (qtvs, givens, ev_binds, insoluble) - <- 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 - - ; loc <- getSrcSpanM - ; let poly_ids = map abe_poly exports - abs_bind = L loc $ - AbsBinds { abs_tvs = qtvs - , abs_ev_vars = givens, abs_ev_binds = [ev_binds] - , abs_exports = exports, abs_binds = binds' } - - ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids)) - ; return (unitBag abs_bind, poly_ids) } - -- poly_ids are guaranteed zonked by mkExport - --------------- -mkExport :: TcPragEnv - -> Bool -- True <=> there was an insoluble type error - -- when typechecking the bindings - -> [TyVar] -> TcThetaType -- Both already zonked - -> MonoBindInfo - -> TcM (ABExport Id) --- Only called for generalisation plan InferGen, not by CheckGen or NoGen --- --- mkExport generates exports with --- zonked type variables, --- zonked poly_ids --- The former is just because no further unifications will change --- the quantified type variables, so we can fix their final form --- right now. --- The latter is needed because the poly_ids are used to extend the --- type environment; see the invariant on TcEnv.tcExtendIdEnv - --- Pre-condition: the qtvs and theta are already zonked - -mkExport prag_fn insoluble qtvs theta - mono_info@(MBI { mbi_poly_name = poly_name - , mbi_sig = mb_sig - , mbi_mono_id = mono_id }) - = do { mono_ty <- zonkTcType (idType mono_id) - ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty - - -- NB: poly_id has a zonked type - ; poly_id <- addInlinePrags poly_id prag_sigs - ; spec_prags <- tcSpecPrags poly_id prag_sigs - -- tcPrags requires a zonked poly_id - - -- See Note [Impedance matching] - -- NB: we have already done checkValidType, including an ambiguity check, - -- on the type; either when we checked the sig or in mkInferredPolyId - ; let poly_ty = idType poly_id - sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty - -- This type is just going into tcSubType, - -- so Inferred vs. Specified doesn't matter - - ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility - then return idHsWrapper -- Fast path; also avoids complaint when we infer - -- an ambiguouse type and have AllowAmbiguousType - -- e..g infer x :: forall a. F a -> Int - else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $ - tcSubType_NC sig_ctxt sel_poly_ty poly_ty - - ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures - ; when warn_missing_sigs $ - localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig - - ; return (ABE { abe_wrap = wrap - -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = SpecPrags spec_prags}) } - where - prag_sigs = lookupPragEnv prag_fn poly_name - sig_ctxt = InfSigCtxt poly_name - -mkInferredPolyId :: Bool -- True <=> there was an insoluble error when - -- checking the binding group for this Id - -> [TyVar] -> TcThetaType - -> Name -> Maybe TcIdSigInst -> TcType - -> TcM TcId -mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty - | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst - , CompleteSig { sig_bndr = poly_id } <- sig - = return poly_id - - | otherwise -- Either no type sig or partial type sig - = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous - -- we don't carry on to the impedance matching, and generate - -- a duplicate ambiguity error. There is a similar - -- checkNoErrs for complete type signatures too. - do { fam_envs <- tcGetFamInstEnvs - ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty - -- Unification may not have normalised the type, - -- (see Note [Lazy flattening] in TcFlatten) so do it - -- here to make it as uncomplicated as possible. - -- Example: f :: [F Int] -> Bool - -- should be rewritten to f :: [Char] -> Bool, if possible - -- - -- We can discard the coercion _co, because we'll reconstruct - -- it in the call to tcSubType below - - ; (binders, theta') <- chooseInferredQuantifiers inferred_theta - (tyCoVarsOfType mono_ty') qtvs mb_sig_inst - - ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty') - - ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' - , ppr inferred_poly_ty]) - ; unless insoluble $ - addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ - checkValidType (InfSigCtxt poly_name) inferred_poly_ty - -- See Note [Validity of inferred types] - -- If we found an insoluble error in the function definition, don't - -- do this check; otherwise (Trac #14000) we may report an ambiguity - -- error for a rather bogus type. - - ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) } - - -chooseInferredQuantifiers :: TcThetaType -- inferred - -> TcTyVarSet -- tvs free in tau type - -> [TcTyVar] -- inferred quantified tvs - -> Maybe TcIdSigInst - -> TcM ([TyVarBinder], TcThetaType) -chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing - = -- No type signature (partial or complete) for this binder, - do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) - -- Include kind variables! Trac #7916 - my_theta = pickCapturedPreds free_tvs inferred_theta - binders = [ mkTyVarBinder Inferred tv - | tv <- qtvs - , tv `elemVarSet` free_tvs ] - ; return (binders, my_theta) } - -chooseInferredQuantifiers inferred_theta tau_tvs qtvs - (Just (TISI { sig_inst_sig = sig -- Always PartialSig - , sig_inst_wcx = wcx - , sig_inst_theta = annotated_theta - , sig_inst_skols = annotated_tvs })) - | Nothing <- wcx - = do { annotated_theta <- zonkTcTypes annotated_theta - ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta - `unionVarSet` tau_tvs) - ; traceTc "ciq" (vcat [ ppr sig, ppr annotated_theta, ppr free_tvs]) - ; psig_qtvs <- mk_psig_qtvs annotated_tvs - ; return (mk_final_qtvs psig_qtvs free_tvs, annotated_theta) } - - | Just wc_var <- wcx - = do { annotated_theta <- zonkTcTypes annotated_theta - ; let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs) - -- growThetaVars just like the no-type-sig case - -- Omitting this caused #12844 - seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there - `unionVarSet` tau_tvs -- by the user - - ; psig_qtvs <- mk_psig_qtvs annotated_tvs - ; let my_qtvs = mk_final_qtvs psig_qtvs free_tvs - keep_me = psig_qtvs `unionVarSet` free_tvs - my_theta = pickCapturedPreds keep_me inferred_theta - - -- Fill in the extra-constraints wildcard hole with inferred_theta, - -- so that the Hole constraint we have already emitted (in tcHsPartialSigType) - -- can report what filled it in. - -- NB: my_theta already includes all the annotated constraints - inferred_diff = [ pred - | pred <- my_theta - , all (not . (`eqType` pred)) annotated_theta ] - ; ctuple <- mk_ctuple inferred_diff - ; writeMetaTyVar wc_var ctuple - - ; traceTc "completeTheta" $ - vcat [ ppr sig - , ppr annotated_theta, ppr inferred_theta - , ppr inferred_diff ] - ; return (my_qtvs, my_theta) } - - | otherwise -- A complete type signature is dealt with in mkInferredPolyId - = pprPanic "chooseInferredQuantifiers" (ppr sig) - - where - mk_final_qtvs psig_qtvs free_tvs - = [ mkTyVarBinder vis tv - | tv <- qtvs -- Pulling from qtvs maintains original order - , tv `elemVarSet` keep_me - , let vis | tv `elemVarSet` psig_qtvs = Specified - | otherwise = Inferred ] - where - keep_me = free_tvs `unionVarSet` psig_qtvs - - mk_ctuple preds = return (mkBoxedTupleTy preds) - -- Hack alert! See TcHsType: - -- Note [Extra-constraint holes in partial type signatures] - - mk_psig_qtvs :: [(Name,TcTyVar)] -> TcM TcTyVarSet - mk_psig_qtvs annotated_tvs - = do { psig_qtvs <- mapM (zonkTcTyVarToTyVar . snd) annotated_tvs - ; return (mkVarSet psig_qtvs) } - -mk_impedance_match_msg :: MonoBindInfo - -> TcType -> TcType - -> TidyEnv -> TcM (TidyEnv, SDoc) --- This is a rare but rather awkward error messages -mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig }) - inf_ty sig_ty tidy_env - = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty - ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty - ; let msg = vcat [ text "When checking that the inferred type" - , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty - , text "is as general as its" <+> what <+> text "signature" - , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ] - ; return (tidy_env2, msg) } - where - what = case mb_sig of - Nothing -> text "inferred" - Just sig | isPartialSig sig -> text "(partial)" - | otherwise -> empty - - -mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) -mk_inf_msg poly_name poly_ty tidy_env - = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty - ; let msg = vcat [ text "When checking the inferred type" - , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] - ; return (tidy_env1, msg) } - - --- | Warn the user about polymorphic local binders that lack type signatures. -localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM () -localSigWarn flag id mb_sig - | Just _ <- mb_sig = return () - | not (isSigmaTy (idType id)) = return () - | otherwise = warnMissingSignatures flag msg id - where - msg = text "Polymorphic local binding with no type signature:" - -warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM () -warnMissingSignatures flag msg id - = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) - ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) } - where - mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] - -checkOverloadedSig :: Bool -> TcIdSigInst -> TcM () --- Example: --- f :: Eq a => a -> a --- K f = e --- The MR applies, but the signature is overloaded, and it's --- best to complain about this directly --- c.f Trac #11339 -checkOverloadedSig monomorphism_restriction_applies sig - | not (null (sig_inst_theta sig)) - , monomorphism_restriction_applies - , let orig_sig = sig_inst_sig sig - = setSrcSpan (sig_loc orig_sig) $ - failWith $ - hang (text "Overloaded signature conflicts with monomorphism restriction") - 2 (ppr orig_sig) - | otherwise - = return () - -{- Note [Partial type signatures and generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If /any/ of the signatures in the gropu is a partial type signature - f :: _ -> Int -then we *always* use the InferGen plan, and hence tcPolyInfer. -We do this even for a local binding with -XMonoLocalBinds, when -we normally use NoGen. - -Reasons: - * The TcSigInfo for 'f' has a unification variable for the '_', - whose TcLevel is one level deeper than the current level. - (See pushTcLevelM in tcTySig.) But NoGen doesn't increase - the TcLevel like InferGen, so we lose the level invariant. - - * The signature might be f :: forall a. _ -> a - so it really is polymorphic. It's not clear what it would - mean to use NoGen on this, and indeed the ASSERT in tcLhs, - in the (Just sig) case, checks that if there is a signature - then we are using LetLclBndr, and hence a nested AbsBinds with - increased TcLevel - -It might be possible to fix these difficulties somehow, but there -doesn't seem much point. Indeed, adding a partial type signature is a -way to get per-binding inferred generalisation. - -We apply the MR if /all/ of the partial signatures lack a context. -In particular (Trac #11016): - f2 :: (?loc :: Int) => _ - f2 = ?loc -It's stupid to apply the MR here. This test includes an extra-constraints -wildcard; that is, we don't apply the MR if you write - f3 :: _ => blah - -Note [Validity of inferred types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to check inferred type for validity, in case it uses language -extensions that are not turned on. The principle is that if the user -simply adds the inferred type to the program source, it'll compile fine. -See #8883. - -Examples that might fail: - - the type might be ambiguous - - - an inferred theta that requires type equalities e.g. (F a ~ G b) - or multi-parameter type classes - - an inferred type that includes unboxed tuples - - -Note [Impedance matching] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f 0 x = x - f n x = g [] (not x) - - g [] y = f 10 y - g _ y = f 9 y - -After typechecking we'll get - f_mono_ty :: a -> Bool -> Bool - g_mono_ty :: [b] -> Bool -> Bool -with constraints - (Eq a, Num a) - -Note that f is polymorphic in 'a' and g in 'b'; and these are not linked. -The types we really want for f and g are - f :: forall a. (Eq a, Num a) => a -> Bool -> Bool - g :: forall b. [b] -> Bool -> Bool - -We can get these by "impedance matching": - tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool) - tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) - - f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f - g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g - -Suppose the shared quantified tyvars are qtvs and constraints theta. -Then we want to check that - forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype -and the proof is the impedance matcher. - -Notice that the impedance matcher may do defaulting. See Trac #7173. - -It also cleverly does an ambiguity check; for example, rejecting - f :: F a -> F a -where F is a non-injective type function. --} - -{- ********************************************************************* -* * - Vectorisation -* * -********************************************************************* -} - -tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId]) -tcVectDecls decls - = do { decls' <- mapM (wrapLocM tcVect) decls - ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl] - dups = findDupsEq (==) ids - ; mapM_ reportVectDups dups - ; traceTcConstraints "End of tcVectDecls" - ; return decls' - } - where - reportVectDups (first:_second:_more) - = addErrAt (getSrcSpan first) $ - text "Duplicate vectorisation declarations for" <+> ppr first - reportVectDups _ = return () - --------------- -tcVect :: VectDecl Name -> TcM (VectDecl TcId) --- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised --- type of the original definition as this requires internals of the vectoriser not available --- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single --- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType' --- from the vectoriser here. -tcVect (HsVect s name rhs) - = addErrCtxt (vectCtxt name) $ - do { var <- wrapLocM tcLookupId name - ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs - ; rhs_id <- tcLookupId rhs_var_name - ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id))) - } - -tcVect (HsNoVect s name) - = addErrCtxt (vectCtxt name) $ - do { var <- wrapLocM tcLookupId name - ; return $ HsNoVect s var - } -tcVect (HsVectTypeIn _ isScalar lname rhs_name) - = addErrCtxt (vectCtxt lname) $ - do { tycon <- tcLookupLocatedTyCon lname - ; checkTc ( not isScalar -- either we have a non-SCALAR declaration - || isJust rhs_name -- or we explicitly provide a vectorised type - || tyConArity tycon == 0 -- otherwise the type constructor must be nullary - ) - scalarTyConMustBeNullary - - ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name - ; return $ HsVectTypeOut isScalar tycon rhs_tycon - } -tcVect (HsVectTypeOut _ _ _) - = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'" -tcVect (HsVectClassIn _ lname) - = addErrCtxt (vectCtxt lname) $ - do { cls <- tcLookupLocatedClass lname - ; return $ HsVectClassOut cls - } -tcVect (HsVectClassOut _) - = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'" -tcVect (HsVectInstIn linstTy) - = addErrCtxt (vectCtxt linstTy) $ - do { (cls, tys) <- tcHsVectInst linstTy - ; inst <- tcLookupInstance cls tys - ; return $ HsVectInstOut inst - } -tcVect (HsVectInstOut _) - = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'" - -vectCtxt :: Outputable thing => thing -> SDoc -vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing - -scalarTyConMustBeNullary :: MsgDoc -scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary" - -{- -Note [SPECIALISE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~ -There is no point in a SPECIALISE pragma for a non-overloaded function: - reverse :: [a] -> [a] - {-# SPECIALISE reverse :: [Int] -> [Int] #-} - -But SPECIALISE INLINE *can* make sense for GADTS: - data Arr e where - ArrInt :: !Int -> ByteArray# -> Arr Int - ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) - - (!:) :: Arr e -> Int -> e - {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} - {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} - (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) - (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) - -When (!:) is specialised it becomes non-recursive, and can usefully -be inlined. Scary! So we only warn for SPECIALISE *without* INLINE -for a non-overloaded function. - -************************************************************************ -* * - tcMonoBinds -* * -************************************************************************ - -@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. -The signatures have been dealt with already. --} - -data MonoBindInfo = MBI { mbi_poly_name :: Name - , mbi_sig :: Maybe TcIdSigInst - , mbi_mono_id :: TcId } - -tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes - -- i.e. the binders are mentioned in their RHSs, and - -- we are not rescued by a type signature - -> TcSigFun -> LetBndrSpec - -> [LHsBind Name] - -> TcM (LHsBinds TcId, [MonoBindInfo]) -tcMonoBinds is_rec sig_fn no_gen - [ L b_loc (FunBind { fun_id = L nm_loc name, - fun_matches = matches, bind_fvs = fvs })] - -- Single function binding, - | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS - , Nothing <- sig_fn name -- ...with no type signature - = -- Note [Single function non-recursive binding special-case] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- In this very special case we infer the type of the - -- right hand side first (it may have a higher-rank type) - -- and *then* make the monomorphic Id for the LHS - -- e.g. f = \(x::forall a. a->a) -> - -- We want to infer a higher-rank type for f - setSrcSpan b_loc $ - do { ((co_fn, matches'), rhs_ty) - <- tcInferInst $ \ exp_ty -> - -- tcInferInst: see TcUnify, - -- Note [Deep instantiation of InferResult] - tcExtendIdBndrs [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 - - ; mono_id <- newLetBndr no_gen name rhs_ty - ; return (unitBag $ L b_loc $ - FunBind { fun_id = L nm_loc mono_id, - fun_matches = matches', bind_fvs = fvs, - fun_co_fn = co_fn, fun_tick = [] }, - [MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id }]) } - -tcMonoBinds _ sig_fn no_gen binds - = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds - - -- Bring the monomorphic Ids, into scope for the RHSs - ; let mono_infos = getMonoBindInfo tc_binds - rhs_id_env = [ (name, mono_id) - | MBI { mbi_poly_name = name - , mbi_sig = mb_sig - , mbi_mono_id = mono_id } <- mono_infos - , case mb_sig of - Just sig -> isPartialSig sig - Nothing -> True ] - -- A monomorphic binding for each term variable that lacks - -- a complete type sig. (Ones with a sig are already in scope.) - - ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) - | (n,id) <- rhs_id_env] - ; binds' <- tcExtendRecIds rhs_id_env $ - mapM (wrapLocM tcRhs) tc_binds - - ; return (listToBag binds', mono_infos) } - - ------------------------- --- tcLhs typechecks the LHS of the bindings, to construct the environment in which --- we typecheck the RHSs. Basically what we are doing is this: for each binder: --- if there's a signature for it, use the instantiated signature type --- otherwise invent a type variable --- You see that quite directly in the FunBind case. --- --- But there's a complication for pattern bindings: --- data T = MkT (forall a. a->a) --- MkT f = e --- Here we can guess a type variable for the entire LHS (which will be refined to T) --- but we want to get (f::forall a. a->a) as the RHS environment. --- The simplest way to do this is to typecheck the pattern, and then look up the --- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing --- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't - -data TcMonoBind -- Half completed; LHS done, RHS not done - = TcFunBind MonoBindInfo SrcSpan (MatchGroup Name (LHsExpr Name)) - | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType - -tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind --- Only called with plan InferGen (LetBndrSpec = LetLclBndr) --- or NoGen (LetBndrSpec = LetGblBndr) --- CheckGen is used only for functions with a complete type signature, --- and tcPolyCheck doesn't use tcMonoBinds at all - -tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches }) - | Just (TcIdSig sig) <- sig_fn name - = -- There is a type signature. - -- It must be partial; if complete we'd be in tcPolyCheck! - -- e.g. f :: _ -> _ - -- f x = ...g... - -- Just g = ...f... - -- Hence always typechecked with InferGen - do { mono_info <- tcLhsSigId no_gen (name, sig) - ; return (TcFunBind mono_info nm_loc matches) } - - | otherwise -- No type signature - = do { mono_ty <- newOpenFlexiTyVarTy - ; mono_id <- newLetBndr no_gen name mono_ty - ; let mono_info = MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id } - ; return (TcFunBind mono_info nm_loc matches) } - -tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) - = -- See Note [Typechecking pattern bindings] - do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names - - ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $ - [ (mbi_poly_name mbi, mbi_mono_id mbi) - | mbi <- sig_mbis ] - - -- See Note [Existentials in pattern bindings] - ; ((pat', nosig_mbis), pat_ty) - <- addErrCtxt (patMonoBindsCtxt pat grhss) $ - tcInferNoInst $ \ exp_ty -> - tcLetPat inst_sig_fun no_gen pat exp_ty $ - mapM lookup_info nosig_names - - ; let mbis = sig_mbis ++ nosig_mbis - - ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id) - | mbi <- mbis, let id = mbi_mono_id mbi ] - $$ ppr no_gen) - - ; return (TcPatBind mbis pat' grhss pat_ty) } - where - bndr_names = collectPatBinders pat - (nosig_names, sig_names) = partitionWith find_sig bndr_names - - find_sig :: Name -> Either Name (Name, TcIdSigInfo) - find_sig name = case sig_fn name of - Just (TcIdSig sig) -> Right (name, sig) - _ -> Left name - - -- After typechecking the pattern, look up the binder - -- names that lack a signature, which the pattern has brought - -- into scope. - lookup_info :: Name -> TcM MonoBindInfo - lookup_info name - = do { mono_id <- tcLookupId name - ; return (MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id }) } - -tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) - -- AbsBind, VarBind impossible - -------------------- -tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo -tcLhsSigId no_gen (name, sig) - = do { inst_sig <- tcInstSig sig - ; mono_id <- newSigLetBndr no_gen name inst_sig - ; return (MBI { mbi_poly_name = name - , mbi_sig = Just inst_sig - , mbi_mono_id = mono_id }) } - ------------- -newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId -newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig }) - | CompleteSig { sig_bndr = poly_id } <- id_sig - = addInlinePrags poly_id (lookupPragEnv prags name) -newSigLetBndr no_gen name (TISI { sig_inst_tau = tau }) - = newLetBndr no_gen name tau - -------------------- -tcRhs :: TcMonoBind -> TcM (HsBind TcId) -tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) - loc matches) - = tcExtendIdBinderStackForRhs [info] $ - tcExtendTyVarEnvForRhs mb_sig $ - do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id)) - matches (mkCheckExpType $ idType mono_id) - ; return ( FunBind { fun_id = L loc mono_id - , fun_matches = matches' - , fun_co_fn = co_fn - , bind_fvs = placeHolderNamesTc - , fun_tick = [] } ) } - -tcRhs (TcPatBind infos pat' grhss pat_ty) - = -- When we are doing pattern bindings we *don't* bring any scoped - -- type variables into scope unlike function bindings - -- Wny not? They are not completely rigid. - -- That's why we have the special case for a single FunBind in tcMonoBinds - tcExtendIdBinderStackForRhs infos $ - do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) - ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ - tcGRHSsPat grhss pat_ty - ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' - , pat_rhs_ty = pat_ty - , bind_fvs = placeHolderNamesTc - , pat_ticks = ([],[]) } )} - -tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a -tcExtendTyVarEnvForRhs Nothing thing_inside - = thing_inside -tcExtendTyVarEnvForRhs (Just sig) thing_inside - = tcExtendTyVarEnvFromSig sig thing_inside - -tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a -tcExtendTyVarEnvFromSig sig_inst thing_inside - | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst - = tcExtendTyVarEnv2 wcs $ - tcExtendTyVarEnv2 skol_prs $ - thing_inside - -tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a --- Extend the TcIdBinderStack for the RHS of the binding, with --- the monomorphic Id. That way, if we have, say --- f = \x -> blah --- and something goes wrong in 'blah', we get a "relevant binding" --- looking like f :: alpha -> beta --- This applies if 'f' has a type signature too: --- f :: forall a. [a] -> [a] --- f x = True --- We can't unify True with [a], and a relevant binding is f :: [a] -> [a] --- If we had the *polymorphic* version of f in the TcIdBinderStack, it --- would not be reported as relevant, because its type is closed -tcExtendIdBinderStackForRhs infos thing_inside - = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel - | MBI { mbi_mono_id = mono_id } <- infos ] - thing_inside - -- NotTopLevel: it's a monomorphic binding - ---------------------- -getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] -getMonoBindInfo tc_binds - = foldr (get_info . unLoc) [] tc_binds - where - get_info (TcFunBind info _ _) rest = info : rest - get_info (TcPatBind infos _ _ _) rest = infos ++ rest - - -{- Note [Typechecking pattern bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at: - - typecheck/should_compile/ExPat - - Trac #12427, typecheck/should_compile/T12427{a,b} - - data T where - MkT :: Integral a => a -> Int -> T - -and suppose t :: T. Which of these pattern bindings are ok? - - E1. let { MkT p _ = t } in - - E2. let { MkT _ q = t } in - - E3. let { MkT (toInteger -> r) _ = t } in - -* (E1) is clearly wrong because the existential 'a' escapes. - What type could 'p' possibly have? - -* (E2) is fine, despite the existential pattern, because - q::Int, and nothing escapes. - -* Even (E3) is fine. The existential pattern binds a dictionary - for (Integral a) which the view pattern can use to convert the - a-valued field to an Integer, so r :: Integer. - -An easy way to see all three is to imagine the desugaring. -For (E2) it would look like - let q = case t of MkT _ q' -> q' - in - - -We typecheck pattern bindings as follows. First tcLhs does this: - - 1. Take each type signature q :: ty, partial or complete, and - instantiate it (with tcLhsSigId) to get a MonoBindInfo. This - gives us a fresh "mono_id" qm :: instantiate(ty), where qm has - a fresh name. - - Any fresh unification variables in instantiate(ty) born here, not - deep under implications as would happen if we allocated them when - we encountered q during tcPat. - - 2. Build a little environment mapping "q" -> "qm" for those Ids - with signatures (inst_sig_fun) - - 3. Invoke tcLetPat to typecheck the pattern. - - - We pass in the current TcLevel. This is captured by - TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in - PatEnv. - - - When tcPat finds an existential constructor, it binds fresh - type variables and dictionaries as usual, increments the TcLevel, - and emits an implication constraint. - - - When we come to a binder (TcPat.tcPatBndr), it looks it up - in the little environment (the pc_sig_fn field of PatCtxt). - - Success => There was a type signature, so just use it, - checking compatibility with the expected type. - - Failure => No type sigature. - Infer case: (happens only outside any constructor pattern) - use a unification variable - at the outer level pc_lvl - - Check case: use promoteTcType to promote the type - to the outer level pc_lvl. This is the - place where we emit a constraint that'll blow - up if existential capture takes place - - Result: the type of the binder is always at pc_lvl. This is - crucial. - - 4. Throughout, when we are making up an Id for the pattern-bound variables - (newLetBndr), we have two cases: - - - If we are generalising (generalisation plan is InferGen or - CheckGen), then the let_bndr_spec will be LetLclBndr. In that case - we want to bind a cloned, local version of the variable, with the - type given by the pattern context, *not* by the signature (even if - there is one; see Trac #7268). The mkExport part of the - generalisation step will do the checking and impedance matching - against the signature. - - - If for some some reason we are not generalising (plan = NoGen), the - LetBndrSpec will be LetGblBndr. In that case we must bind the - global version of the Id, and do so with precisely the type given - in the signature. (Then we unify with the type from the pattern - context type.) - - -And that's it! The implication constraints check for the skolem -escape. It's quite simple and neat, and more expressive than before -e.g. GHC 8.0 rejects (E2) and (E3). - -Example for (E1), starting at level 1. We generate - p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta) -The (a~beta) can't float (because of the 'a'), nor be solved (because -beta is untouchable.) - -Example for (E2), we generate - q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta) -The beta is untoucable, but floats out of the constraint and can -be solved absolutely fine. - -************************************************************************ -* * - Generalisation -* * -********************************************************************* -} - -data GeneralisationPlan - = NoGen -- No generalisation, no AbsBinds - - | InferGen -- Implicit generalisation; there is an AbsBinds - Bool -- True <=> apply the MR; generalise only unconstrained type vars - - | CheckGen (LHsBind Name) TcIdSigInfo - -- One FunBind with a signature - -- Explicit generalisation; there is an AbsBindsSig - --- A consequence of the no-AbsBinds choice (NoGen) is that there is --- no "polymorphic Id" and "monmomorphic Id"; there is just the one - -instance Outputable GeneralisationPlan where - ppr NoGen = text "NoGen" - ppr (InferGen b) = text "InferGen" <+> ppr b - ppr (CheckGen _ s) = text "CheckGen" <+> ppr s - -decideGeneralisationPlan - :: DynFlags -> [LHsBind Name] -> IsGroupClosed -> TcSigFun - -> GeneralisationPlan -decideGeneralisationPlan dflags lbinds closed sig_fn - | has_partial_sigs = InferGen (and partial_sig_mrs) - | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig - | do_not_generalise closed = NoGen - | otherwise = InferGen mono_restriction - where - binds = map unLoc lbinds - - partial_sig_mrs :: [Bool] - -- One for each parital signature (so empty => no partial sigs) - -- The Bool is True if the signature has no constraint context - -- so we should apply the MR - -- See Note [Partial type signatures and generalisation] - partial_sig_mrs - = [ null theta - | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) - <- mapMaybe sig_fn (collectHsBindListBinders lbinds) - , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] - - has_partial_sigs = not (null partial_sig_mrs) - - mono_restriction = xopt LangExt.MonomorphismRestriction dflags - && any restricted binds - - do_not_generalise (IsGroupClosed _ True) = False - -- The 'True' means that all of the group's - -- free vars have ClosedTypeId=True; so we can ignore - -- -XMonoLocalBinds, and generalise anyway - do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags - - -- With OutsideIn, all nested bindings are monomorphic - -- except a single function binding with a signature - one_funbind_with_sig - | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds - , Just (TcIdSig sig) <- sig_fn (unLoc v) - = Just (lbind, sig) - | otherwise - = Nothing - - -- The Haskell 98 monomorphism restriction - restricted (PatBind {}) = True - restricted (VarBind { var_id = v }) = no_sig v - restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m - && no_sig (unLoc v) - restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind" - restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds" - restricted (AbsBindsSig {}) = panic "isRestrictedGroup/unrestricted AbsBindsSig" - - restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True - restricted_match _ = False - -- No args => like a pattern binding - -- Some args => a function binding - - no_sig n = not (hasCompleteSig sig_fn n) - -isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind Name) -> IsGroupClosed -isClosedBndrGroup type_env binds - = IsGroupClosed fv_env type_closed - where - type_closed = allUFM (nameSetAll is_closed_type_id) fv_env - - fv_env :: NameEnv NameSet - fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds - - bindFvs :: HsBindLR Name idR -> [(Name, NameSet)] - bindFvs (FunBind { fun_id = L _ f, bind_fvs = fvs }) - = let open_fvs = filterNameSet (not . is_closed) fvs - in [(f, open_fvs)] - bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs }) - = let open_fvs = filterNameSet (not . is_closed) fvs - in [(b, open_fvs) | b <- collectPatBinders pat] - bindFvs _ - = [] - - is_closed :: Name -> ClosedTypeId - is_closed name - | Just thing <- lookupNameEnv type_env name - = case thing of - AGlobal {} -> True - ATcId { tct_info = ClosedLet } -> True - _ -> False - - | otherwise - = True -- The free-var set for a top level binding mentions - - - is_closed_type_id :: Name -> Bool - -- We're already removed Global and ClosedLet Ids - is_closed_type_id name - | Just thing <- lookupNameEnv type_env name - = case thing of - ATcId { tct_info = NonClosedLet _ cl } -> cl - ATcId { tct_info = NotLetBound } -> False - ATyVar {} -> False - -- In-scope type variables are not closed! - _ -> pprPanic "is_closed_id" (ppr name) - - | otherwise - = True -- The free-var set for a top level binding mentions - -- imported things too, so that we can report unused imports - -- These won't be in the local type env. - -- Ditto class method etc from the current module - - -{- ********************************************************************* -* * - Error contexts and messages -* * -********************************************************************* -} - --- This one is called on LHS, when pat and grhss are both Name --- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (OutputableBndrId id, Outputable body) - => LPat id -> GRHSs Name body -> SDoc -patMonoBindsCtxt pat grhss - = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/typecheck/TcCanonical.hs b/typecheck/TcCanonical.hs deleted file mode 100644 --- a/typecheck/TcCanonical.hs +++ /dev/null @@ -1,1949 +0,0 @@ -{-# LANGUAGE CPP #-} - -module TcCanonical( - canonicalize, - unifyDerived, - makeSuperClasses, maybeSym, - StopOrContinue(..), stopWith, continueWith - ) where - -#include "HsVersions.h" - -import TcRnTypes -import TcUnify( swapOverTyVars, metaTyVarUpdateOK ) -import TcType -import Type -import TcFlatten -import TcSMonad -import TcEvidence -import Class -import TyCon -import TyCoRep -- cleverly decomposes types, good for completeness checking -import Coercion -import FamInstEnv ( FamInstEnvs ) -import FamInst ( tcTopNormaliseNewTypeTF_maybe ) -import Var -import VarEnv( mkInScopeSet ) -import VarSet( extendVarSetList ) -import Outputable -import DynFlags( DynFlags ) -import NameSet -import RdrName - -import Pair -import Util -import Bag -import MonadUtils -import Control.Monad -import Data.Maybe ( isJust ) -import Data.List ( zip4, foldl' ) -import BasicTypes - -import Data.Bifunctor ( bimap ) - -{- -************************************************************************ -* * -* The Canonicaliser * -* * -************************************************************************ - -Note [Canonicalization] -~~~~~~~~~~~~~~~~~~~~~~~ - -Canonicalization converts a simple constraint to a canonical form. It is -unary (i.e. treats individual constraints one at a time). - -Constraints originating from user-written code come into being as -CNonCanonicals (except for CHoleCans, arising from holes). We know nothing -about these constraints. So, first: - - Classify CNonCanoncal constraints, depending on whether they - are equalities, class predicates, or other. - -Then proceed depending on the shape of the constraint. Generally speaking, -each constraint gets flattened and then decomposed into one of several forms -(see type Ct in TcRnTypes). - -When an already-canonicalized constraint gets kicked out of the inert set, -it must be recanonicalized. But we know a bit about its shape from the -last time through, so we can skip the classification step. - --} - --- Top-level canonicalization --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -canonicalize :: Ct -> TcS (StopOrContinue Ct) -canonicalize ct@(CNonCanonical { cc_ev = ev }) - = do { traceTcS "canonicalize (non-canonical)" (ppr ct) - ; {-# SCC "canEvVar" #-} - canEvNC ev } - -canonicalize (CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis, cc_pend_sc = pend_sc }) - = {-# SCC "canClass" #-} - canClass ev cls xis pend_sc - -canonicalize (CTyEqCan { cc_ev = ev - , cc_tyvar = tv - , cc_rhs = xi - , cc_eq_rel = eq_rel }) - = {-# SCC "canEqLeafTyVarEq" #-} - canEqNC ev eq_rel (mkTyVarTy tv) xi - -- NB: Don't use canEqTyVar because that expects flattened types, - -- and tv and xi may not be flat w.r.t. an updated inert set - -canonicalize (CFunEqCan { cc_ev = ev - , cc_fun = fn - , cc_tyargs = xis1 - , cc_fsk = fsk }) - = {-# SCC "canEqLeafFunEq" #-} - canCFunEqCan ev fn xis1 fsk - -canonicalize (CIrredEvCan { cc_ev = ev }) - = canIrred ev -canonicalize (CHoleCan { cc_ev = ev, cc_hole = hole }) - = canHole ev hole - -canEvNC :: CtEvidence -> TcS (StopOrContinue Ct) --- Called only for non-canonical EvVars -canEvNC ev - = case classifyPredType (ctEvPred ev) of - ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys) - canClassNC ev cls tys - EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2) - canEqNC ev eq_rel ty1 ty2 - IrredPred {} -> do traceTcS "canEvNC:irred" (ppr (ctEvPred ev)) - canIrred ev -{- -************************************************************************ -* * -* Class Canonicalization -* * -************************************************************************ --} - -canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct) --- "NC" means "non-canonical"; that is, we have got here --- from a NonCanonical constrataint, not from a CDictCan --- Precondition: EvVar is class evidence -canClassNC ev cls tys - | isGiven ev -- See Note [Eagerly expand given superclasses] - = do { sc_cts <- mkStrictSuperClasses ev cls tys - ; emitWork sc_cts - ; canClass ev cls tys False } - | otherwise - = canClass ev cls tys (has_scs cls) - where - has_scs cls = not (null (classSCTheta cls)) - -canClass :: CtEvidence - -> Class -> [Type] - -> Bool -- True <=> un-explored superclasses - -> TcS (StopOrContinue Ct) --- Precondition: EvVar is class evidence - -canClass ev cls tys pend_sc - = -- all classes do *nominal* matching - ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys ) - do { (xis, cos) <- flattenManyNom ev tys - ; let co = mkTcTyConAppCo Nominal (classTyCon cls) cos - xi = mkClassPred cls xis - mk_ct new_ev = CDictCan { cc_ev = new_ev - , cc_tyargs = xis - , cc_class = cls - , cc_pend_sc = pend_sc } - ; mb <- rewriteEvidence ev xi co - ; traceTcS "canClass" (vcat [ ppr ev - , ppr xi, ppr mb ]) - ; return (fmap mk_ct mb) } - -{- Note [The superclass story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to add superclass constraints for two reasons: - -* For givens [G], they give us a route to to proof. E.g. - f :: Ord a => a -> Bool - f x = x == x - We get a Wanted (Eq a), which can only be solved from the superclass - of the Given (Ord a). - -* For wanteds [W], and deriveds [WD], [D], they may give useful - functional dependencies. E.g. - class C a b | a -> b where ... - class C a b => D a b where ... - Now a [W] constraint (D Int beta) has (C Int beta) as a superclass - and that might tell us about beta, via C's fundeps. We can get this - by generating a [D] (C Int beta) constraint. It's derived because - we don't actually have to cough up any evidence for it; it's only there - to generate fundep equalities. - -See Note [Why adding superclasses can help]. - -For these reasons we want to generate superclass constraints for both -Givens and Wanteds. But: - -* (Minor) they are often not needed, so generating them aggressively - is a waste of time. - -* (Major) if we want recursive superclasses, there would be an infinite - number of them. Here is a real-life example (Trac #10318); - - class (Frac (Frac a) ~ Frac a, - Fractional (Frac a), - IntegralDomain (Frac a)) - => IntegralDomain a where - type Frac a :: * - - Notice that IntegralDomain has an associated type Frac, and one - of IntegralDomain's superclasses is another IntegralDomain constraint. - -So here's the plan: - -1. Eagerly generate superclasses for given (but not wanted) - constraints; see Note [Eagerly expand given superclasses]. - This is done in canClassNC, when we take a non-canonical constraint - and cannonicalise it. - - However stop if you encounter the same class twice. That is, - expand eagerly, but have a conservative termination condition: see - Note [Expanding superclasses] in TcType. - -2. Solve the wanteds as usual, but do no further expansion of - superclasses for canonical CDictCans in solveSimpleGivens or - solveSimpleWanteds; Note [Danger of adding superclasses during solving] - - However, /do/ continue to eagerly expand superlasses for /given/ - non-canonical constraints (canClassNC does this). As Trac #12175 - showed, a type-family application can expand to a class constraint, - and we want to see its superclasses for just the same reason as - Note [Eagerly expand given superclasses]. - -3. If we have any remaining unsolved wanteds - (see Note [When superclasses help] in TcRnTypes) - try harder: take both the Givens and Wanteds, and expand - superclasses again. This may succeed in generating (a finite - number of) extra Givens, and extra Deriveds. Both may help the - proof. This is done in TcSimplify.expandSuperClasses. - -4. Go round to (2) again. This loop (2,3,4) is implemented - in TcSimplify.simpl_loop. - -The cc_pend_sc flag in a CDictCan records whether the superclasses of -this constraint have been expanded. Specifically, in Step 3 we only -expand superclasses for constraints with cc_pend_sc set to true (i.e. -isPendingScDict holds). - -Why do we do this? Two reasons: - -* To avoid repeated work, by repeatedly expanding the superclasses of - same constraint, - -* To terminate the above loop, at least in the -XNoRecursiveSuperClasses - case. If there are recursive superclasses we could, in principle, - expand forever, always encountering new constraints. - -When we take a CNonCanonical or CIrredCan, but end up classifying it -as a CDictCan, we set the cc_pend_sc flag to False. - -Note [Eagerly expand given superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In step (1) of Note [The superclass story], why do we eagerly expand -Given superclasses by one layer? Mainly because of some very obscure -cases like this: - - instance Bad a => Eq (T a) - - f :: (Ord (T a)) => blah - f x = ....needs Eq (T a), Ord (T a).... - -Here if we can't satisfy (Eq (T a)) from the givens we'll use the -instance declaration; but then we are stuck with (Bad a). Sigh. -This is really a case of non-confluent proofs, but to stop our users -complaining we expand one layer in advance. - -Note [Instance and Given overlap] in TcInteract. - -We also want to do this if we have - - f :: F (T a) => blah - -where - type instance F (T a) = Ord (T a) - -So we may need to do a little work on the givens to expose the -class that has the superclasses. That's why the superclass -expansion for Givens happens in canClassNC. - -Note [Why adding superclasses can help] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Examples of how adding superclasses can help: - - --- Example 1 - class C a b | a -> b - Suppose we want to solve - [G] C a b - [W] C a beta - Then adding [D] beta~b will let us solve it. - - -- Example 2 (similar but using a type-equality superclass) - class (F a ~ b) => C a b - And try to sllve: - [G] C a b - [W] C a beta - Follow the superclass rules to add - [G] F a ~ b - [D] F a ~ beta - Now we we get [D] beta ~ b, and can solve that. - - -- Example (tcfail138) - class L a b | a -> b - class (G a, L a b) => C a b - - instance C a b' => G (Maybe a) - instance C a b => C (Maybe a) a - instance L (Maybe a) a - - When solving the superclasses of the (C (Maybe a) a) instance, we get - [G] C a b, and hance by superclasses, [G] G a, [G] L a b - [W] G (Maybe a) - Use the instance decl to get - [W] C a beta - Generate its derived superclass - [D] L a beta. Now using fundeps, combine with [G] L a b to get - [D] beta ~ b - which is what we want. - -Note [Danger of adding superclasses during solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here's a serious, but now out-dated example, from Trac #4497: - - class Num (RealOf t) => Normed t - type family RealOf x - -Assume the generated wanted constraint is: - [W] RealOf e ~ e - [W] Normed e - -If we were to be adding the superclasses during simplification we'd get: - [W] RealOf e ~ e - [W] Normed e - [D] RealOf e ~ fuv - [D] Num fuv -==> - e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv - -While looks exactly like our original constraint. If we add the -superclass of (Normed fuv) again we'd loop. By adding superclasses -definitely only once, during canonicalisation, this situation can't -happen. - -Mind you, now that Wanteds cannot rewrite Derived, I think this particular -situation can't happen. - -} - -makeSuperClasses :: [Ct] -> TcS [Ct] --- Returns strict superclasses, transitively, see Note [The superclasses story] --- See Note [The superclass story] --- The loop-breaking here follows Note [Expanding superclasses] in TcType --- Specifically, for an incoming (C t) constraint, we return all of (C t)'s --- superclasses, up to /and including/ the first repetition of C --- --- Example: class D a => C a --- class C [a] => D a --- makeSuperClasses (C x) will return (D x, C [x]) --- --- NB: the incoming constraints have had their cc_pend_sc flag already --- flipped to False, by isPendingScDict, so we are /obliged/ to at --- least produce the immediate superclasses -makeSuperClasses cts = concatMapM go cts - where - go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) - = mkStrictSuperClasses ev cls tys - go ct = pprPanic "makeSuperClasses" (ppr ct) - -mkStrictSuperClasses :: CtEvidence -> Class -> [Type] -> TcS [Ct] --- Return constraints for the strict superclasses of (c tys) -mkStrictSuperClasses ev cls tys - = mk_strict_superclasses (unitNameSet (className cls)) ev cls tys - -mk_superclasses :: NameSet -> CtEvidence -> TcS [Ct] --- Return this constraint, plus its superclasses, if any -mk_superclasses rec_clss ev - | ClassPred cls tys <- classifyPredType (ctEvPred ev) - = mk_superclasses_of rec_clss ev cls tys - - | otherwise -- Superclass is not a class predicate - = return [mkNonCanonical ev] - -mk_superclasses_of :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct] --- Always return this class constraint, --- and expand its superclasses -mk_superclasses_of rec_clss ev cls tys - | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys) - ; return [this_ct] } -- cc_pend_sc of this_ct = True - | otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys - , ppr (isCTupleClass cls) - , ppr rec_clss - ]) - ; sc_cts <- mk_strict_superclasses rec_clss' ev cls tys - ; return (this_ct : sc_cts) } - -- cc_pend_sc of this_ct = False - where - cls_nm = className cls - loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss - -- Tuples never contribute to recursion, and can be nested - rec_clss' = rec_clss `extendNameSet` cls_nm - this_ct = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys - , cc_pend_sc = loop_found } - -- NB: If there is a loop, we cut off, so we have not - -- added the superclasses, hence cc_pend_sc = True - -mk_strict_superclasses :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct] --- Always return the immediate superclasses of (cls tys); --- and expand their superclasses, provided none of them are in rec_clss --- nor are repeated -mk_strict_superclasses rec_clss ev cls tys - | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev - = do { sc_evs <- newGivenEvVars (mk_given_loc loc) - (mkEvScSelectors (EvId evar) cls tys) - ; concatMapM (mk_superclasses rec_clss) sc_evs } - - | all noFreeVarsOfType tys - = return [] -- Wanteds with no variables yield no deriveds. - -- See Note [Improvement from Ground Wanteds] - - | otherwise -- Wanted/Derived case, just add Derived superclasses - -- that can lead to improvement. - = do { let loc = ctEvLoc ev - ; sc_evs <- mapM (newDerivedNC loc) (immSuperClasses cls tys) - ; concatMapM (mk_superclasses rec_clss) sc_evs } - where - size = sizeTypes tys - mk_given_loc loc - | isCTupleClass cls - = loc -- For tuple predicates, just take them apart, without - -- adding their (large) size into the chain. When we - -- get down to a base predicate, we'll include its size. - -- Trac #10335 - - | GivenOrigin skol_info <- ctLocOrigin loc - -- See Note [Solving superclass constraints] in TcInstDcls - -- for explantation of this transformation for givens - = case skol_info of - InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) } - InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) } - _ -> loc - - | otherwise -- Probably doesn't happen, since this function - = loc -- is only used for Givens, but does no harm - - -{- -************************************************************************ -* * -* Irreducibles canonicalization -* * -************************************************************************ --} - -canIrred :: CtEvidence -> TcS (StopOrContinue Ct) --- Precondition: ty not a tuple and no other evidence form -canIrred old_ev - = do { let old_ty = ctEvPred old_ev - ; traceTcS "can_pred" (text "IrredPred = " <+> ppr old_ty) - ; (xi,co) <- flatten FM_FlattenAll old_ev old_ty -- co :: xi ~ old_ty - ; rewriteEvidence old_ev xi co `andWhenContinue` \ new_ev -> - do { -- Re-classify, in case flattening has improved its shape - ; case classifyPredType (ctEvPred new_ev) of - ClassPred cls tys -> canClassNC new_ev cls tys - EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2 - _ -> continueWith $ - CIrredEvCan { cc_ev = new_ev } } } - -canHole :: CtEvidence -> Hole -> TcS (StopOrContinue Ct) -canHole ev hole - = do { let ty = ctEvPred ev - ; (xi,co) <- flatten FM_SubstOnly ev ty -- co :: xi ~ ty - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - do { emitInsoluble (CHoleCan { cc_ev = new_ev - , cc_hole = hole }) - ; stopWith new_ev "Emit insoluble hole" } } - -{- -************************************************************************ -* * -* Equalities -* * -************************************************************************ - -Note [Canonicalising equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In order to canonicalise an equality, we look at the structure of the -two types at hand, looking for similarities. A difficulty is that the -types may look dissimilar before flattening but similar after flattening. -However, we don't just want to jump in and flatten right away, because -this might be wasted effort. So, after looking for similarities and failing, -we flatten and then try again. Of course, we don't want to loop, so we -track whether or not we've already flattened. - -It is conceivable to do a better job at tracking whether or not a type -is flattened, but this is left as future work. (Mar '15) - - -Note [FunTy and decomposing tycon applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When can_eq_nc' attempts to decompose a tycon application we haven't yet zonked. -This means that we may very well have a FunTy containing a type of some unknown -kind. For instance, we may have, - - FunTy (a :: k) Int - -Where k is a unification variable. tcRepSplitTyConApp_maybe panics in the event -that it sees such a type as it cannot determine the RuntimeReps which the (->) -is applied to. Consequently, it is vital that we instead use -tcRepSplitTyConApp_maybe', which simply returns Nothing in such a case. - -When this happens can_eq_nc' will fail to decompose, zonk, and try again. -Zonking should fill the variable k, meaning that decomposition will succeed the -second time around. --} - -canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) -canEqNC ev eq_rel ty1 ty2 - = do { result <- zonk_eq_types ty1 ty2 - ; case result of - Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2 - Right ty -> canEqReflexive ev eq_rel ty } - -can_eq_nc - :: Bool -- True => both types are flat - -> CtEvidence - -> EqRel - -> Type -> Type -- LHS, after and before type-synonym expansion, resp - -> Type -> Type -- RHS, after and before type-synonym expansion, resp - -> TcS (StopOrContinue Ct) -can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - = do { traceTcS "can_eq_nc" $ - vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ] - ; rdr_env <- getGlobalRdrEnvTcS - ; fam_insts <- getFamInstEnvs - ; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 } - -can_eq_nc' - :: Bool -- True => both input types are flattened - -> GlobalRdrEnv -- needed to see which newtypes are in scope - -> FamInstEnvs -- needed to unwrap data instances - -> CtEvidence - -> EqRel - -> Type -> Type -- LHS, after and before type-synonym expansion, resp - -> Type -> Type -- RHS, after and before type-synonym expansion, resp - -> TcS (StopOrContinue Ct) - --- Expand synonyms first; see Note [Type synonyms and canonicalization] -can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | Just ty1' <- tcView ty1 = can_eq_nc flat ev eq_rel ty1' ps_ty1 ty2 ps_ty2 - | Just ty2' <- tcView ty2 = can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2' ps_ty2 - --- need to check for reflexivity in the ReprEq case. --- See Note [Eager reflexivity check] --- Check only when flat because the zonk_eq_types check in canEqNC takes --- care of the non-flat case. -can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _ - | ty1 `tcEqType` ty2 - = canEqReflexive ev ReprEq ty1 - --- When working with ReprEq, unwrap newtypes. -can_eq_nc' _flat rdr_env envs ev ReprEq ty1 _ ty2 ps_ty2 - | Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1 - = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2 -can_eq_nc' _flat rdr_env envs ev ReprEq ty1 ps_ty1 ty2 _ - | Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 - = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1 - --- Then, get rid of casts -can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 - = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 -can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ - = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 - ----------------------- --- Otherwise try to decompose ----------------------- - --- Literals -can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ - | l1 == l2 - = do { setEqIfWanted ev (mkReflCo (eqRelRole eq_rel) ty1) - ; stopWith ev "Equal LitTy" } - --- Try to decompose type constructor applications --- Including FunTy (s -> t) -can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _ - --- See Note [FunTy and decomposing type constructor applications]. - | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe' ty1 - , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe' ty2 - , not (isTypeFamilyTyCon tc1) - , not (isTypeFamilyTyCon tc2) - = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - -can_eq_nc' _flat _rdr_env _envs ev eq_rel - s1@(ForAllTy {}) _ s2@(ForAllTy {}) _ - = can_eq_nc_forall ev eq_rel s1 s2 - --- See Note [Canonicalising type applications] about why we require flat types -can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _ - | Just (t2, s2) <- tcSplitAppTy_maybe ty2 - = can_eq_app ev eq_rel t1 s1 t2 s2 -can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _ - | Just (t1, s1) <- tcSplitAppTy_maybe ty1 - = can_eq_app ev eq_rel t1 s1 t2 s2 - --- No similarity in type structure detected. Flatten and try again. -can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 - = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1 - ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2 - ; rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 - `andWhenContinue` \ new_ev -> - can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } - --- Type variable on LHS or RHS are last. --- NB: pattern match on True: we want only flat types sent to canEqTyVar. --- See also Note [No top-level newtypes on RHS of representational equalities] -can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2 - = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2 -can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2 - = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1 - --- We've flattened and the types don't match. Give up. -can_eq_nc' True _rdr_env _envs ev _eq_rel _ ps_ty1 _ ps_ty2 - = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) - ; canEqHardFailure ev ps_ty1 ps_ty2 } - ---------------------------------- -can_eq_nc_forall :: CtEvidence -> EqRel - -> Type -> Type -- LHS and RHS - -> TcS (StopOrContinue Ct) --- (forall as. phi1) ~ (forall bs. phi2) --- Check for length match of as, bs --- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs] --- But remember also to unify the kinds of as and bs --- (this is the 'go' loop), and actually substitute phi2[as |> cos / bs] --- Remember also that we might have forall z (a:z). blah --- so we must proceed one binder at a time (Trac #13879) - -can_eq_nc_forall ev eq_rel s1 s2 - | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev - = do { let free_tvs1 = tyCoVarsOfType s1 - free_tvs2 = tyCoVarsOfType s2 - (bndrs1, phi1) = tcSplitForAllTyVarBndrs s1 - (bndrs2, phi2) = tcSplitForAllTyVarBndrs s2 - ; if not (equalLength bndrs1 bndrs2) - then do { traceTcS "Forall failure" $ - vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 - , ppr (map binderArgFlag bndrs1) - , ppr (map binderArgFlag bndrs2) ] - ; canEqHardFailure ev s1 s2 } - else - do { traceTcS "Creating implication for polytype equality" $ ppr ev - ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs1 - ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $ - binderVars bndrs1 - - ; let skol_info = UnifyForAllSkol phi1 - phi1' = substTy subst1 phi1 - - -- Unify the kinds, extend the substitution - go (skol_tv:skol_tvs) subst (bndr2:bndrs2) - = do { let tv2 = binderVar bndr2 - ; kind_co <- unifyWanted loc Nominal - (tyVarKind skol_tv) - (substTy subst (tyVarKind tv2)) - ; let subst' = extendTvSubst subst tv2 - (mkCastTy (mkTyVarTy skol_tv) kind_co) - ; co <- go skol_tvs subst' bndrs2 - ; return (mkForAllCo skol_tv kind_co co) } - - -- Done: unify phi1 ~ phi2 - go [] subst bndrs2 - = ASSERT( null bndrs2 ) - unifyWanted loc (eqRelRole eq_rel) - phi1' (substTy subst phi2) - - go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] - - empty_subst2 = mkEmptyTCvSubst $ mkInScopeSet $ - free_tvs2 `extendVarSetList` skol_tvs - - ; (implic, _ev_binds, all_co) <- buildImplication skol_info skol_tvs [] $ - go skol_tvs empty_subst2 bndrs2 - -- We have nowhere to put these bindings - -- but TcSimplify.setImplicationStatus - -- checks that we don't actually use them - -- when skol_info = UnifyForAllSkol - - ; updWorkListTcS (extendWorkListImplic implic) - ; setWantedEq orig_dest all_co - ; stopWith ev "Deferred polytype equality" } } - - | otherwise - = do { traceTcS "Omitting decomposition of given polytype equality" $ - pprEq s1 s2 -- See Note [Do not decompose given polytype equalities] - ; stopWith ev "Discard given polytype equality" } - ---------------------------------- --- | Compare types for equality, while zonking as necessary. Gives up --- as soon as it finds that two types are not equal. --- This is quite handy when some unification has made two --- types in an inert wanted to be equal. We can discover the equality without --- flattening, which is sometimes very expensive (in the case of type functions). --- In particular, this function makes a ~20% improvement in test case --- perf/compiler/T5030. --- --- Returns either the (partially zonked) types in the case of --- inequality, or the one type in the case of equality. canEqReflexive is --- a good next step in the 'Right' case. Returning 'Left' is always safe. --- --- NB: This does *not* look through type synonyms. In fact, it treats type --- synonyms as rigid constructors. In the future, it might be convenient --- to look at only those arguments of type synonyms that actually appear --- in the synonym RHS. But we're not there yet. -zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType) -zonk_eq_types = go - where - go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2 - go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2 - go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1 - - -- We handle FunTys explicitly here despite the fact that they could also be - -- treated as an application. Why? Well, for one it's cheaper to just look - -- at two types (the argument and result types) than four (the argument, - -- result, and their RuntimeReps). Also, we haven't completely zonked yet, - -- so we may run into an unzonked type variable while trying to compute the - -- RuntimeReps of the argument and result types. This can be observed in - -- testcase tc269. - go ty1 ty2 - | Just (arg1, res1) <- split1 - , Just (arg2, res2) <- split2 - = do { res_a <- go arg1 arg2 - ; res_b <- go res1 res2 - ; return $ combine_rev mkFunTy res_b res_a - } - | isJust split1 || isJust split2 - = bale_out ty1 ty2 - where - split1 = tcSplitFunTy_maybe ty1 - split2 = tcSplitFunTy_maybe ty2 - - go ty1 ty2 - | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe ty2 - = if tc1 == tc2 && tys1 `equalLength` tys2 - -- Crucial to check for equal-length args, because - -- we cannot assume that the two args to 'go' have - -- the same kind. E.g go (Proxy * (Maybe Int)) - -- (Proxy (*->*) Maybe) - -- We'll call (go (Maybe Int) Maybe) - -- See Trac #13083 - then tycon tc1 tys1 tys2 - else bale_out ty1 ty2 - - go ty1 ty2 - | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 - , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 - = do { res_a <- go ty1a ty2a - ; res_b <- go ty1b ty2b - ; return $ combine_rev mkAppTy res_b res_a } - - go ty1@(LitTy lit1) (LitTy lit2) - | lit1 == lit2 - = return (Right ty1) - - go ty1 ty2 = bale_out ty1 ty2 - -- We don't handle more complex forms here - - bale_out ty1 ty2 = return $ Left (Pair ty1 ty2) - - tyvar :: SwapFlag -> TcTyVar -> TcType - -> TcS (Either (Pair TcType) TcType) - -- Try to do as little as possible, as anything we do here is redundant - -- with flattening. In particular, no need to zonk kinds. That's why - -- we don't use the already-defined zonking functions - tyvar swapped tv ty - = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } - -> do { cts <- readTcRef ref - ; case cts of - Flexi -> give_up - Indirect ty' -> unSwap swapped go ty' ty } - _ -> give_up - where - give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty - - tyvar_tyvar tv1 tv2 - | tv1 == tv2 = return (Right (mkTyVarTy tv1)) - | otherwise = do { (ty1', progress1) <- quick_zonk tv1 - ; (ty2', progress2) <- quick_zonk tv2 - ; if progress1 || progress2 - then go ty1' ty2' - else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) } - - quick_zonk tv = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } - -> do { cts <- readTcRef ref - ; case cts of - Flexi -> return (TyVarTy tv, False) - Indirect ty' -> return (ty', True) } - _ -> return (TyVarTy tv, False) - - -- This happens for type families, too. But recall that failure - -- here just means to try harder, so it's OK if the type function - -- isn't injective. - tycon :: TyCon -> [TcType] -> [TcType] - -> TcS (Either (Pair TcType) TcType) - tycon tc tys1 tys2 - = do { results <- zipWithM go tys1 tys2 - ; return $ case combine_results results of - Left tys -> Left (mkTyConApp tc <$> tys) - Right tys -> Right (mkTyConApp tc tys) } - - combine_results :: [Either (Pair TcType) TcType] - -> Either (Pair [TcType]) [TcType] - combine_results = bimap (fmap reverse) reverse . - foldl' (combine_rev (:)) (Right []) - - -- combine (in reverse) a new result onto an already-combined result - combine_rev :: (a -> b -> c) - -> Either (Pair b) b - -> Either (Pair a) a - -> Either (Pair c) c - combine_rev f (Left list) (Left elt) = Left (f <$> elt <*> list) - combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list) - combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys) - combine_rev f (Right tys) (Right ty) = Right (f ty tys) - -{- -Note [Newtypes can blow the stack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype X = MkX (Int -> X) - newtype Y = MkY (Int -> Y) - -and now wish to prove - - [W] X ~R Y - -This Wanted will loop, expanding out the newtypes ever deeper looking -for a solid match or a solid discrepancy. Indeed, there is something -appropriate to this looping, because X and Y *do* have the same representation, -in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized -coercion will ever witness it. This loop won't actually cause GHC to hang, -though, because we check our depth when unwrapping newtypes. - -Note [Eager reflexivity check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype X = MkX (Int -> X) - -and - - [W] X ~R X - -Naively, we would start unwrapping X and end up in a loop. Instead, -we do this eager reflexivity check. This is necessary only for representational -equality because the flattener technology deals with the similar case -(recursive type families) for nominal equality. - -Note that this check does not catch all cases, but it will catch the cases -we're most worried about, types like X above that are actually inhabited. - -Here's another place where this reflexivity check is key: -Consider trying to prove (f a) ~R (f a). The AppTys in there can't -be decomposed, because representational equality isn't congruent with respect -to AppTy. So, when canonicalising the equality above, we get stuck and -would normally produce a CIrredEvCan. However, we really do want to -be able to solve (f a) ~R (f a). So, in the representational case only, -we do a reflexivity check. - -(This would be sound in the nominal case, but unnecessary, and I [Richard -E.] am worried that it would slow down the common case.) --} - ------------------------- --- | We're able to unwrap a newtype. Update the bits accordingly. -can_eq_newtype_nc :: CtEvidence -- ^ :: ty1 ~ ty2 - -> SwapFlag - -> TcType -- ^ ty1 - -> ((Bag GlobalRdrElt, TcCoercion), TcType) -- ^ :: ty1 ~ ty1' - -> TcType -- ^ ty2 - -> TcType -- ^ ty2, with type synonyms - -> TcS (StopOrContinue Ct) -can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2 - = do { traceTcS "can_eq_newtype_nc" $ - vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ] - - -- check for blowing our stack: - -- See Note [Newtypes can blow the stack] - ; checkReductionDepth (ctEvLoc ev) ty1 - ; addUsedGREs (bagToList gres) - -- we have actually used the newtype constructor here, so - -- make sure we don't warn about importing it! - - ; rewriteEqEvidence ev swapped ty1' ps_ty2 - (mkTcSymCo co) (mkTcReflCo Representational ps_ty2) - `andWhenContinue` \ new_ev -> - can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 } - ---------- --- ^ Decompose a type application. --- All input types must be flat. See Note [Canonicalising type applications] -can_eq_app :: CtEvidence -- :: s1 t1 ~r s2 t2 - -> EqRel -- r - -> Xi -> Xi -- s1 t1 - -> Xi -> Xi -- s2 t2 - -> TcS (StopOrContinue Ct) - --- AppTys only decompose for nominal equality, so this case just leads --- to an irreducible constraint; see typecheck/should_compile/T10494 --- See Note [Decomposing equality], note {4} -can_eq_app ev ReprEq _ _ _ _ - = do { traceTcS "failing to decompose representational AppTy equality" (ppr ev) - ; continueWith (CIrredEvCan { cc_ev = ev }) } - -- no need to call canEqFailure, because that flattens, and the - -- types involved here are already flat - -can_eq_app ev NomEq s1 t1 s2 t2 - | CtDerived { ctev_loc = loc } <- ev - = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2] - ; stopWith ev "Decomposed [D] AppTy" } - | CtWanted { ctev_dest = dest, ctev_loc = loc } <- ev - = do { co_s <- unifyWanted loc Nominal s1 s2 - ; co_t <- unifyWanted loc Nominal t1 t2 - ; let co = mkAppCo co_s co_t - ; setWantedEq dest co - ; stopWith ev "Decomposed [W] AppTy" } - | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev - = do { let co = mkTcCoVarCo evar - co_s = mkTcLRCo CLeft co - co_t = mkTcLRCo CRight co - ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 - , EvCoercion co_s ) - ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 - , EvCoercion co_t ) - ; emitWorkNC [evar_t] - ; canEqNC evar_s NomEq s1 s2 } - | otherwise -- Can't happen - = error "can_eq_app" - ------------------------ --- | Break apart an equality over a casted type --- looking like (ty1 |> co1) ~ ty2 (modulo a swap-flag) -canEqCast :: Bool -- are both types flat? - -> CtEvidence - -> EqRel - -> SwapFlag - -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 - -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty - -> TcS (StopOrContinue Ct) -canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2 - = do { traceTcS "Decomposing cast" (vcat [ ppr ev - , ppr ty1 <+> text "|>" <+> ppr co1 - , ppr ps_ty2 ]) - ; rewriteEqEvidence ev swapped ty1 ps_ty2 - (mkTcReflCo role ty1 - `mkTcCoherenceRightCo` co1) - (mkTcReflCo role ps_ty2) - `andWhenContinue` \ new_ev -> - can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 } - where - role = eqRelRole eq_rel - ------------------------- -canTyConApp :: CtEvidence -> EqRel - -> TyCon -> [TcType] - -> TyCon -> [TcType] - -> TcS (StopOrContinue Ct) --- See Note [Decomposing TyConApps] -canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - | tc1 == tc2 - , length tys1 == length tys2 - = do { inerts <- getTcSInerts - ; if can_decompose inerts - then do { traceTcS "canTyConApp" - (ppr ev $$ ppr eq_rel $$ ppr tc1 $$ ppr tys1 $$ ppr tys2) - ; canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 - ; stopWith ev "Decomposed TyConApp" } - else canEqFailure ev eq_rel ty1 ty2 } - - -- See Note [Skolem abstract data] (at tyConSkolem) - | tyConSkolem tc1 || tyConSkolem tc2 - = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) - ; continueWith (CIrredEvCan { cc_ev = ev }) } - - -- Fail straight away for better error messages - -- See Note [Use canEqFailure in canDecomposableTyConApp] - | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational && - isGenerativeTyCon tc2 Representational) - = canEqFailure ev eq_rel ty1 ty2 - | otherwise - = canEqHardFailure ev ty1 ty2 - where - ty1 = mkTyConApp tc1 tys1 - ty2 = mkTyConApp tc2 tys2 - - loc = ctEvLoc ev - pred = ctEvPred ev - - -- See Note [Decomposing equality] - can_decompose inerts - = isInjectiveTyCon tc1 (eqRelRole eq_rel) - || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts)) - -{- -Note [Use canEqFailure in canDecomposableTyConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must use canEqFailure, not canEqHardFailure here, because there is -the possibility of success if working with a representational equality. -Here is one case: - - type family TF a where TF Char = Bool - data family DF a - newtype instance DF Bool = MkDF Int - -Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet -know `a`. This is *not* a hard failure, because we might soon learn -that `a` is, in fact, Char, and then the equality succeeds. - -Here is another case: - - [G] Age ~R Int - -where Age's constructor is not in scope. We don't want to report -an "inaccessible code" error in the context of this Given! - -For example, see typecheck/should_compile/T10493, repeated here: - - import Data.Ord (Down) -- no constructor - - foo :: Coercible (Down Int) Int => Down Int -> Int - foo = coerce - -That should compile, but only because we use canEqFailure and not -canEqHardFailure. - -Note [Decomposing equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a constraint (of any flavour and role) that looks like -T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer, -of course, is "it depends". This Note spells it all out. - -In this Note, "decomposition" refers to taking the constraint - [fl] (T tys1 ~X T tys2) -(for some flavour fl and some role X) and replacing it with - [fls'] (tys1 ~Xs' tys2) -where that notation indicates a list of new constraints, where the -new constraints may have different flavours and different roles. - -The key property to consider is injectivity. When decomposing a Given the -decomposition is sound if and only if T is injective in all of its type -arguments. When decomposing a Wanted, the decomposition is sound (assuming the -correct roles in the produced equality constraints), but it may be a guess -- -that is, an unforced decision by the constraint solver. Decomposing Wanteds -over injective TyCons does not entail guessing. But sometimes we want to -decompose a Wanted even when the TyCon involved is not injective! (See below.) - -So, in broad strokes, we want this rule: - -(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective -at role X. - -Pursuing the details requires exploring three axes: -* Flavour: Given vs. Derived vs. Wanted -* Role: Nominal vs. Representational -* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable - -(So a type variable isn't a TyCon, but it's convenient to put the AppTy case -in the same table.) - -Right away, we can say that Derived behaves just as Wanted for the purposes -of decomposition. The difference between Derived and Wanted is the handling of -evidence. Since decomposition in these cases isn't a matter of soundness but of -guessing, we want the same behavior regardless of evidence. - -Here is a table (discussion following) detailing where decomposition of - (T s1 ... sn) ~r (T t1 .. tn) -is allowed. The first four lines (Data types ... type family) refer -to TyConApps with various TyCons T; the last line is for AppTy, where -there is presumably a type variable at the head, so it's actually - (s s1 ... sn) ~r (t t1 .. tn) - -NOMINAL GIVEN WANTED - -Datatype YES YES -Newtype YES YES -Data family YES YES -Type family YES, in injective args{1} YES, in injective args{1} -Type variable YES YES - -REPRESENTATIONAL GIVEN WANTED - -Datatype YES YES -Newtype NO{2} MAYBE{2} -Data family NO{3} MAYBE{3} -Type family NO NO -Type variable NO{4} NO{4} - -{1}: Type families can be injective in some, but not all, of their arguments, -so we want to do partial decomposition. This is quite different than the way -other decomposition is done, where the decomposed equalities replace the original -one. We thus proceed much like we do with superclasses: emitting new Givens -when "decomposing" a partially-injective type family Given and new Deriveds -when "decomposing" a partially-injective type family Wanted. (As of the time of -writing, 13 June 2015, the implementation of injective type families has not -been merged, but it should be soon. Please delete this parenthetical if the -implementation is indeed merged.) - -{2}: See Note [Decomposing newtypes at representational role] - -{3}: Because of the possibility of newtype instances, we must treat -data families like newtypes. See also Note [Decomposing newtypes at -representational role]. See #10534 and test case -typecheck/should_fail/T10534. - -{4}: Because type variables can stand in for newtypes, we conservatively do not -decompose AppTys over representational equality. - -In the implementation of can_eq_nc and friends, we don't directly pattern -match using lines like in the tables above, as those tables don't cover -all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity, -boiling the tables above down to rule (*). The exceptions to rule (*) are for -injective type families, which are handled separately from other decompositions, -and the MAYBE entries above. - -Note [Decomposing newtypes at representational role] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note discusses the 'newtype' line in the REPRESENTATIONAL table -in Note [Decomposing equality]. (At nominal role, newtypes are fully -decomposable.) - -Here is a representative example of why representational equality over -newtypes is tricky: - - newtype Nt a = Mk Bool -- NB: a is not used in the RHS, - type role Nt representational -- but the user gives it an R role anyway - -If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to -[W] alpha ~R beta, because it's possible that alpha and beta aren't -representationally equal. Here's another example. - - newtype Nt a = MkNt (Id a) - type family Id a where Id a = a - - [W] Nt Int ~R Nt Age - -Because of its use of a type family, Nt's parameter will get inferred to have -a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, which -is unsatisfiable. Unwrapping, though, leads to a solution. - -Conclusion: - * Unwrap newtypes before attempting to decompose them. - This is done in can_eq_nc'. - -It all comes from the fact that newtypes aren't necessarily injective -w.r.t. representational equality. - -Furthermore, as explained in Note [NthCo and newtypes] in TyCoRep, we can't use -NthCo on representational coercions over newtypes. NthCo comes into play -only when decomposing givens. - -Conclusion: - * Do not decompose [G] N s ~R N t - -Is it sensible to decompose *Wanted* constraints over newtypes? Yes! -It's the only way we could ever prove (IO Int ~R IO Age), recalling -that IO is a newtype. - -However we must be careful. Consider - - type role Nt representational - - [G] Nt a ~R Nt b (1) - [W] NT alpha ~R Nt b (2) - [W] alpha ~ a (3) - -If we focus on (3) first, we'll substitute in (2), and now it's -identical to the given (1), so we succeed. But if we focus on (2) -first, and decompose it, we'll get (alpha ~R b), which is not soluble. -This is exactly like the question of overlapping Givens for class -constraints: see Note [Instance and Given overlap] in TcInteract. - -Conclusion: - * Decompose [W] N s ~R N t iff there no given constraint that could - later solve it. --} - -canDecomposableTyConAppOK :: CtEvidence -> EqRel - -> TyCon -> [TcType] -> [TcType] - -> TcS () --- Precondition: tys1 and tys2 are the same length, hence "OK" -canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 - = case ev of - CtDerived {} - -> unifyDeriveds loc tc_roles tys1 tys2 - - CtWanted { ctev_dest = dest } - -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2 - ; setWantedEq dest (mkTyConAppCo role tc cos) } - - CtGiven { ctev_evar = evar } - -> do { let ev_co = mkCoVarCo evar - ; given_evs <- newGivenEvVars loc $ - [ ( mkPrimEqPredRole r ty1 ty2 - , EvCoercion (mkNthCo i ev_co) ) - | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] - , r /= Phantom - , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] - ; emitWorkNC given_evs } - where - loc = ctEvLoc ev - role = eqRelRole eq_rel - tc_roles = tyConRolesX role tc - - -- the following makes a better distinction between "kind" and "type" - -- in error messages - bndrs = tyConBinders tc - kind_loc = toKindLoc loc - is_kinds = map isNamedTyConBinder bndrs - new_locs | Just KindLevel <- ctLocTypeOrKind_maybe loc - = repeat loc - | otherwise - = map (\is_kind -> if is_kind then kind_loc else loc) is_kinds - - --- | Call when canonicalizing an equality fails, but if the equality is --- representational, there is some hope for the future. --- Examples in Note [Use canEqFailure in canDecomposableTyConApp] -canEqFailure :: CtEvidence -> EqRel - -> TcType -> TcType -> TcS (StopOrContinue Ct) -canEqFailure ev NomEq ty1 ty2 - = canEqHardFailure ev ty1 ty2 -canEqFailure ev ReprEq ty1 ty2 - = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1 - ; (xi2, co2) <- flatten FM_FlattenAll ev ty2 - -- We must flatten the types before putting them in the - -- inert set, so that we are sure to kick them out when - -- new equalities become available - ; traceTcS "canEqFailure with ReprEq" $ - vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ] - ; rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 - `andWhenContinue` \ new_ev -> - continueWith (CIrredEvCan { cc_ev = new_ev }) } - --- | Call when canonicalizing an equality fails with utterly no hope. -canEqHardFailure :: CtEvidence - -> TcType -> TcType -> TcS (StopOrContinue Ct) --- See Note [Make sure that insolubles are fully rewritten] -canEqHardFailure ev ty1 ty2 - = do { (s1, co1) <- flatten FM_SubstOnly ev ty1 - ; (s2, co2) <- flatten FM_SubstOnly ev ty2 - ; rewriteEqEvidence ev NotSwapped s1 s2 co1 co2 - `andWhenContinue` \ new_ev -> - do { emitInsoluble (mkNonCanonical new_ev) - ; stopWith new_ev "Definitely not equal" }} - -{- -Note [Decomposing TyConApps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see (T s1 t1 ~ T s2 t2), then we can just decompose to - (s1 ~ s2, t1 ~ t2) -and push those back into the work list. But if - s1 = K k1 s2 = K k2 -then we will just decomopose s1~s2, and it might be better to -do so on the spot. An important special case is where s1=s2, -and we get just Refl. - -So canDecomposableTyCon is a fast-path decomposition that uses -unifyWanted etc to short-cut that work. - -Note [Canonicalising type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (s1 t1) ~ ty2, how should we proceed? -The simple things is to see if ty2 is of form (s2 t2), and -decompose. By this time s1 and s2 can't be saturated type -function applications, because those have been dealt with -by an earlier equation in can_eq_nc, so it is always sound to -decompose. - -However, over-eager decomposition gives bad error messages -for things like - a b ~ Maybe c - e f ~ p -> q -Suppose (in the first example) we already know a~Array. Then if we -decompose the application eagerly, yielding - a ~ Maybe - b ~ c -we get an error "Can't match Array ~ Maybe", -but we'd prefer to get "Can't match Array b ~ Maybe c". - -So instead can_eq_wanted_app flattens the LHS and RHS, in the hope of -replacing (a b) by (Array b), before using try_decompose_app to -decompose it. - -Note [Make sure that insolubles are fully rewritten] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When an equality fails, we still want to rewrite the equality -all the way down, so that it accurately reflects - (a) the mutable reference substitution in force at start of solving - (b) any ty-binds in force at this point in solving -See Note [Kick out insolubles] in TcSMonad. -And if we don't do this there is a bad danger that -TcSimplify.applyTyVarDefaulting will find a variable -that has in fact been substituted. - -Note [Do not decompose Given polytype equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? -No -- what would the evidence look like? So instead we simply discard -this given evidence. - - -Note [Combining insoluble constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As this point we have an insoluble constraint, like Int~Bool. - - * If it is Wanted, delete it from the cache, so that subsequent - Int~Bool constraints give rise to separate error messages - - * But if it is Derived, DO NOT delete from cache. A class constraint - may get kicked out of the inert set, and then have its functional - dependency Derived constraints generated a second time. In that - case we don't want to get two (or more) error messages by - generating two (or more) insoluble fundep constraints from the same - class constraint. - -Note [No top-level newtypes on RHS of representational equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we're in this situation: - - work item: [W] c1 : a ~R b - inert: [G] c2 : b ~R Id a - -where - newtype Id a = Id a - -We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened -and the Id newtype is unwrapped. This is assured by requiring only flat -types in canEqTyVar *and* having the newtype-unwrapping check above -the tyvar check in can_eq_nc. - -Note [Occurs check error] -~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an occurs check error, are we necessarily hosed? Say our -tyvar is tv1 and the type it appears in is xi2. Because xi2 is function -free, then if we're computing w.r.t. nominal equality, then, yes, we're -hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t. -representational equality, this is a little subtler. Once again, (a ~R [a]) -is a bad thing, but (a ~R N a) for a newtype N might be just fine. This -means also that (a ~ b a) might be fine, because `b` might become a newtype. - -So, we must check: does tv1 appear in xi2 under any type constructor that -is generative w.r.t. representational equality? That's what isTyVarUnderDatatype -does. (The other name I considered, isTyVarUnderTyConGenerativeWrtReprEq was -a bit verbose. And the shorter name gets the point across.) - -See also #10715, which induced this addition. - -Note [No derived kind equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we're working with a heterogeneous derived equality - - [D] (t1 :: k1) ~ (t2 :: k2) - -we want to homogenise to establish the kind invariant on CTyEqCans. -But we can't emit [D] k1 ~ k2 because we wouldn't then be able to -use the evidence in the homogenised types. So we emit a wanted -constraint, because we do really need the evidence here. - -Thus: no derived kind equalities. - --} - -canCFunEqCan :: CtEvidence - -> TyCon -> [TcType] -- LHS - -> TcTyVar -- RHS - -> TcS (StopOrContinue Ct) --- ^ Canonicalise a CFunEqCan. We know that --- the arg types are already flat, --- and the RHS is a fsk, which we must *not* substitute. --- So just substitute in the LHS -canCFunEqCan ev fn tys fsk - = do { (tys', cos) <- flattenManyNom ev tys - -- cos :: tys' ~ tys - ; let lhs_co = mkTcTyConAppCo Nominal fn cos - -- :: F tys' ~ F tys - new_lhs = mkTyConApp fn tys' - fsk_ty = mkTyVarTy fsk - ; rewriteEqEvidence ev NotSwapped new_lhs fsk_ty - lhs_co (mkTcNomReflCo fsk_ty) - `andWhenContinue` \ ev' -> - do { extendFlatCache fn tys' (ctEvCoercion ev', fsk_ty, ctEvFlavour ev') - ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn - , cc_tyargs = tys', cc_fsk = fsk }) } } - ---------------------- -canEqTyVar :: CtEvidence -- ev :: lhs ~ rhs - -> EqRel -> SwapFlag - -> TcTyVar -> TcType -- lhs: already flat, not a cast - -> TcType -> TcType -- rhs: already flat, not a cast - -> TcS (StopOrContinue Ct) -canEqTyVar ev eq_rel swapped tv1 ps_ty1 (TyVarTy tv2) _ - | tv1 == tv2 - = canEqReflexive ev eq_rel ps_ty1 - - | swapOverTyVars tv1 tv2 - = do { traceTcS "canEqTyVar" (ppr tv1 $$ ppr tv2 $$ ppr swapped) - -- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten - -- let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True } - -- Flatten the RHS less vigorously, to avoid gratuitous flattening - -- True <=> xi2 should not itself be a type-function application - ; dflags <- getDynFlags - ; canEqTyVar2 dflags ev eq_rel (flipSwap swapped) tv2 ps_ty1 } - -canEqTyVar ev eq_rel swapped tv1 _ _ ps_ty2 - = do { dflags <- getDynFlags - ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_ty2 } - -canEqTyVar2 :: DynFlags - -> CtEvidence -- lhs ~ rhs (or, if swapped, orhs ~ olhs) - -> EqRel - -> SwapFlag - -> TcTyVar -- lhs, flat - -> TcType -- rhs, flat - -> TcS (StopOrContinue Ct) --- LHS is an inert type variable, --- and RHS is fully rewritten, but with type synonyms --- preserved as much as possible - -canEqTyVar2 dflags ev eq_rel swapped tv1 xi2 - | Just xi2' <- metaTyVarUpdateOK dflags tv1 xi2 -- No occurs check - -- Must do the occurs check even on tyvar/tyvar - -- equalities, in case have x ~ (y :: ..x...) - -- Trac #12593 - = rewriteEqEvidence ev swapped xi1 xi2' co1 co2 - `andWhenContinue` \ new_ev -> - homogeniseRhsKind new_ev eq_rel xi1 xi2' $ \new_new_ev xi2'' -> - CTyEqCan { cc_ev = new_new_ev, cc_tyvar = tv1 - , cc_rhs = xi2'', cc_eq_rel = eq_rel } - - | otherwise -- For some reason (occurs check, or forall) we can't unify - -- We must not use it for further rewriting! - = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr xi2) - ; rewriteEqEvidence ev swapped xi1 xi2 co1 co2 - `andWhenContinue` \ new_ev -> - if isInsolubleOccursCheck eq_rel tv1 xi2 - then do { emitInsoluble (mkNonCanonical new_ev) - -- If we have a ~ [a], it is not canonical, and in particular - -- we don't want to rewrite existing inerts with it, otherwise - -- we'd risk divergence in the constraint solver - ; stopWith new_ev "Occurs check" } - - -- A representational equality with an occurs-check problem isn't - -- insoluble! For example: - -- a ~R b a - -- We might learn that b is the newtype Id. - -- But, the occurs-check certainly prevents the equality from being - -- canonical, and we might loop if we were to use it in rewriting. - else do { traceTcS "Possibly-soluble occurs check" - (ppr xi1 $$ ppr xi2) - ; continueWith (CIrredEvCan { cc_ev = new_ev }) } } - where - role = eqRelRole eq_rel - xi1 = mkTyVarTy tv1 - co1 = mkTcReflCo role xi1 - co2 = mkTcReflCo role xi2 - --- | Solve a reflexive equality constraint -canEqReflexive :: CtEvidence -- ty ~ ty - -> EqRel - -> TcType -- ty - -> TcS (StopOrContinue Ct) -- always Stop -canEqReflexive ev eq_rel ty - = do { setEvBindIfWanted ev (EvCoercion $ - mkTcReflCo (eqRelRole eq_rel) ty) - ; stopWith ev "Solved by reflexivity" } - --- See Note [Equalities with incompatible kinds] -homogeniseRhsKind :: CtEvidence -- ^ the evidence to homogenise - -> EqRel - -> TcType -- ^ original LHS - -> Xi -- ^ original RHS - -> (CtEvidence -> Xi -> Ct) - -- ^ how to build the homogenised constraint; - -- the 'Xi' is the new RHS - -> TcS (StopOrContinue Ct) -homogeniseRhsKind ev eq_rel lhs rhs build_ct - | k1 `tcEqType` k2 - = continueWith (build_ct ev rhs) - - | CtGiven { ctev_evar = evar } <- ev - -- tm :: (lhs :: k1) ~ (rhs :: k2) - = do { kind_ev_id <- newBoundEvVarId kind_pty - (EvCoercion $ - mkTcKindCo $ mkTcCoVarCo evar) - -- kind_ev_id :: (k1 :: *) ~# (k2 :: *) - ; let kind_ev = CtGiven { ctev_pred = kind_pty - , ctev_evar = kind_ev_id - , ctev_loc = kind_loc } - homo_co = mkSymCo $ mkCoVarCo kind_ev_id - rhs' = mkCastTy rhs homo_co - ; traceTcS "Hetero equality gives rise to given kind equality" - (ppr kind_ev_id <+> dcolon <+> ppr kind_pty) - ; emitWorkNC [kind_ev] - ; type_ev <- newGivenEvVar loc - ( mkTcEqPredLikeEv ev lhs rhs' - , EvCoercion $ - mkTcCoherenceRightCo (mkTcCoVarCo evar) homo_co ) - -- type_ev :: (lhs :: k1) ~ ((rhs |> sym kind_ev_id) :: k1) - ; continueWith (build_ct type_ev rhs') } - - | otherwise -- Wanted and Derived. See Note [No derived kind equalities] - -- evar :: (lhs :: k1) ~ (rhs :: k2) - = do { kind_co <- emitNewWantedEq kind_loc Nominal k1 k2 - -- kind_ev :: (k1 :: *) ~ (k2 :: *) - ; traceTcS "Hetero equality gives rise to wanted kind equality" $ - ppr (kind_co) - ; let homo_co = mkSymCo kind_co - -- homo_co :: k2 ~ k1 - rhs' = mkCastTy rhs homo_co - ; case ev of - CtGiven {} -> panic "homogeniseRhsKind" - CtDerived {} -> continueWith (build_ct (ev { ctev_pred = homo_pred }) - rhs') - where homo_pred = mkTcEqPredLikeEv ev lhs rhs' - CtWanted { ctev_dest = dest } -> do - { (type_ev, hole_co) <- newWantedEq loc role lhs rhs' - -- type_ev :: (lhs :: k1) ~ (rhs |> sym kind_co :: k1) - ; setWantedEq dest - (hole_co `mkTransCo` - (mkReflCo role rhs - `mkCoherenceLeftCo` homo_co)) - - -- dest := hole ; |> homo_co :: (lhs :: k1) ~ (rhs :: k2) - ; continueWith (build_ct type_ev rhs') }} - - where - k1 = typeKind lhs - k2 = typeKind rhs - - kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind k1 k2 - kind_loc = mkKindLoc lhs rhs loc - - loc = ctev_loc ev - role = eqRelRole eq_rel - -{- -Note [Canonical orientation for tyvar/tyvar equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have a ~ b where both 'a' and 'b' are TcTyVars, which way -round should be oriented in the CTyEqCan? The rules, implemented by -canEqTyVarTyVar, are these - - * If either is a flatten-meta-variables, it goes on the left. - - * Put a meta-tyvar on the left if possible - alpha[3] ~ r - - * If both are meta-tyvars, put the more touchable one (deepest level - number) on the left, so there is the best chance of unifying it - alpha[3] ~ beta[2] - - * If both are meta-tyvars and both at the same level, put a SigTv - on the right if possible - alpha[2] ~ beta[2](sig-tv) - That way, when we unify alpha := beta, we don't lose the SigTv flag. - - * Put a meta-tv with a System Name on the left if possible so it - gets eliminated (improves error messages) - - * If one is a flatten-skolem, put it on the left so that it is - substituted out Note [Elminate flat-skols] - fsk ~ a - -Note [Avoid unnecessary swaps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we swap without actually improving matters, we can get an infnite loop. -Consider - work item: a ~ b - inert item: b ~ c -We canonicalise the work-time to (a ~ c). If we then swap it before -aeding to the inert set, we'll add (c ~ a), and therefore kick out the -inert guy, so we get - new work item: b ~ c - inert item: c ~ a -And now the cycle just repeats - -Note [Eliminate flat-skols] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have [G] Num (F [a]) -then we flatten to - [G] Num fsk - [G] F [a] ~ fsk -where fsk is a flatten-skolem (FlatSkol). Suppose we have - type instance F [a] = a -then we'll reduce the second constraint to - [G] a ~ fsk -and then replace all uses of 'a' with fsk. That's bad because -in error messages intead of saying 'a' we'll say (F [a]). In all -places, including those where the programmer wrote 'a' in the first -place. Very confusing! See Trac #7862. - -Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate -the fsk. - -Note [Equalities with incompatible kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -canEqLeaf is about to make a CTyEqCan or CFunEqCan; but both have the -invariant that LHS and RHS satisfy the kind invariants for CTyEqCan, -CFunEqCan. What if we try to unify two things with incompatible -kinds? - -eg a ~ b where a::*, b::*->* -or a ~ b where a::*, b::k, k is a kind variable - -The CTyEqCan compatKind invariant is important. If we make a CTyEqCan -for a~b, then we might well *substitute* 'b' for 'a', and that might make -a well-kinded type ill-kinded; and that is bad (eg typeKind can crash, see -Trac #7696). - -So instead for these ill-kinded equalities we homogenise the RHS of the -equality, emitting new constraints as necessary. - -Note [Type synonyms and canonicalization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat type synonym applications as xi types, that is, they do not -count as type function applications. However, we do need to be a bit -careful with type synonyms: like type functions they may not be -generative or injective. However, unlike type functions, they are -parametric, so there is no problem in expanding them whenever we see -them, since we do not need to know anything about their arguments in -order to expand them; this is what justifies not having to treat them -as specially as type function applications. The thing that causes -some subtleties is that we prefer to leave type synonym applications -*unexpanded* whenever possible, in order to generate better error -messages. - -If we encounter an equality constraint with type synonym applications -on both sides, or a type synonym application on one side and some sort -of type application on the other, we simply must expand out the type -synonyms in order to continue decomposing the equality constraint into -primitive equality constraints. For example, suppose we have - - type F a = [Int] - -and we encounter the equality - - F a ~ [b] - -In order to continue we must expand F a into [Int], giving us the -equality - - [Int] ~ [b] - -which we can then decompose into the more primitive equality -constraint - - Int ~ b. - -However, if we encounter an equality constraint with a type synonym -application on one side and a variable on the other side, we should -NOT (necessarily) expand the type synonym, since for the purpose of -good error messages we want to leave type synonyms unexpanded as much -as possible. Hence the ps_ty1, ps_ty2 argument passed to canEqTyVar. - --} - -{- -************************************************************************ -* * - Evidence transformation -* * -************************************************************************ --} - -data StopOrContinue a - = ContinueWith a -- The constraint was not solved, although it may have - -- been rewritten - - | Stop CtEvidence -- The (rewritten) constraint was solved - SDoc -- Tells how it was solved - -- Any new sub-goals have been put on the work list - -instance Functor StopOrContinue where - fmap f (ContinueWith x) = ContinueWith (f x) - fmap _ (Stop ev s) = Stop ev s - -instance Outputable a => Outputable (StopOrContinue a) where - ppr (Stop ev s) = text "Stop" <> parens s <+> ppr ev - ppr (ContinueWith w) = text "ContinueWith" <+> ppr w - -continueWith :: a -> TcS (StopOrContinue a) -continueWith = return . ContinueWith - -stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) -stopWith ev s = return (Stop ev (text s)) - -andWhenContinue :: TcS (StopOrContinue a) - -> (a -> TcS (StopOrContinue b)) - -> TcS (StopOrContinue b) -andWhenContinue tcs1 tcs2 - = do { r <- tcs1 - ; case r of - Stop ev s -> return (Stop ev s) - ContinueWith ct -> tcs2 ct } -infixr 0 `andWhenContinue` -- allow chaining with ($) - -rewriteEvidence :: CtEvidence -- old evidence - -> TcPredType -- new predicate - -> TcCoercion -- Of type :: new predicate ~ - -> TcS (StopOrContinue CtEvidence) --- Returns Just new_ev iff either (i) 'co' is reflexivity --- or (ii) 'co' is not reflexivity, and 'new_pred' not cached --- In either case, there is nothing new to do with new_ev -{- - rewriteEvidence old_ev new_pred co -Main purpose: create new evidence for new_pred; - unless new_pred is cached already -* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev -* If old_ev was wanted, create a binding for old_ev, in terms of new_ev -* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev -* Returns Nothing if new_ev is already cached - - Old evidence New predicate is Return new evidence - flavour of same flavor - ------------------------------------------------------------------- - Wanted Already solved or in inert Nothing - or Derived Not Just new_evidence - - Given Already in inert Nothing - Not Just new_evidence - -Note [Rewriting with Refl] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the coercion is just reflexivity then you may re-use the same -variable. But be careful! Although the coercion is Refl, new_pred -may reflect the result of unification alpha := ty, so new_pred might -not _look_ the same as old_pred, and it's vital to proceed from now on -using new_pred. - -qThe flattener preserves type synonyms, so they should appear in new_pred -as well as in old_pred; that is important for good error messages. - -} - - -rewriteEvidence old_ev@(CtDerived {}) new_pred _co - = -- If derived, don't even look at the coercion. - -- This is very important, DO NOT re-order the equations for - -- rewriteEvidence to put the isTcReflCo test first! - -- Why? Because for *Derived* constraints, c, the coercion, which - -- was produced by flattening, may contain suspended calls to - -- (ctEvTerm c), which fails for Derived constraints. - -- (Getting this wrong caused Trac #7384.) - continueWith (old_ev { ctev_pred = new_pred }) - -rewriteEvidence old_ev new_pred co - | isTcReflCo co -- See Note [Rewriting with Refl] - = continueWith (old_ev { ctev_pred = new_pred }) - -rewriteEvidence ev@(CtGiven { ctev_evar = old_evar , ctev_loc = loc }) new_pred co - = do { new_ev <- newGivenEvVar loc (new_pred, new_tm) - ; continueWith new_ev } - where - -- mkEvCast optimises ReflCo - new_tm = mkEvCast (EvId old_evar) (tcDowngradeRole Representational - (ctEvRole ev) - (mkTcSymCo co)) - -rewriteEvidence ev@(CtWanted { ctev_dest = dest - , ctev_loc = loc }) new_pred co - = do { mb_new_ev <- newWanted loc new_pred - ; MASSERT( tcCoercionRole co == ctEvRole ev ) - ; setWantedEvTerm dest - (mkEvCast (getEvTerm mb_new_ev) - (tcDowngradeRole Representational (ctEvRole ev) co)) - ; case mb_new_ev of - Fresh new_ev -> continueWith new_ev - Cached _ -> stopWith ev "Cached wanted" } - - -rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) - -- or orhs ~ olhs (swapped) - -> SwapFlag - -> TcType -> TcType -- New predicate nlhs ~ nrhs - -- Should be zonked, because we use typeKind on nlhs/nrhs - -> TcCoercion -- lhs_co, of type :: nlhs ~ olhs - -> TcCoercion -- rhs_co, of type :: nrhs ~ orhs - -> TcS (StopOrContinue CtEvidence) -- Of type nlhs ~ nrhs --- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co) --- we generate --- If not swapped --- g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co --- If 'swapped' --- g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co --- --- For (Wanted w) we do the dual thing. --- New w1 : nlhs ~ nrhs --- If not swapped --- w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co --- If swapped --- w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co --- --- It's all a form of rewwriteEvidence, specialised for equalities -rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co - | CtDerived {} <- old_ev -- Don't force the evidence for a Derived - = continueWith (old_ev { ctev_pred = new_pred }) - - | NotSwapped <- swapped - , isTcReflCo lhs_co -- See Note [Rewriting with Refl] - , isTcReflCo rhs_co - = continueWith (old_ev { ctev_pred = new_pred }) - - | CtGiven { ctev_evar = old_evar } <- old_ev - = do { let new_tm = EvCoercion (lhs_co - `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar) - `mkTcTransCo` mkTcSymCo rhs_co) - ; new_ev <- newGivenEvVar loc' (new_pred, new_tm) - ; continueWith new_ev } - - | CtWanted { ctev_dest = dest } <- old_ev - = do { (new_ev, hole_co) <- newWantedEq loc' (ctEvRole old_ev) nlhs nrhs - ; let co = maybeSym swapped $ - mkSymCo lhs_co - `mkTransCo` hole_co - `mkTransCo` rhs_co - ; setWantedEq dest co - ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) - ; continueWith new_ev } - - | otherwise - = panic "rewriteEvidence" - where - new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs - - -- equality is like a type class. Bumping the depth is necessary because - -- of recursive newtypes, where "reducing" a newtype can actually make - -- it bigger. See Note [Newtypes can blow the stack]. - loc = ctEvLoc old_ev - loc' = bumpCtLocDepth loc - -{- Note [unifyWanted and unifyDerived] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When decomposing equalities we often create new wanted constraints for -(s ~ t). But what if s=t? Then it'd be faster to return Refl right away. -Similar remarks apply for Derived. - -Rather than making an equality test (which traverses the structure of the -type, perhaps fruitlessly, unifyWanted traverses the common structure, and -bales out when it finds a difference by creating a new Wanted constraint. -But where it succeeds in finding common structure, it just builds a coercion -to reflect it. --} - -unifyWanted :: CtLoc -> Role - -> TcType -> TcType -> TcS Coercion --- Return coercion witnessing the equality of the two types, --- emitting new work equalities where necessary to achieve that --- Very good short-cut when the two types are equal, or nearly so --- See Note [unifyWanted and unifyDerived] --- The returned coercion's role matches the input parameter -unifyWanted loc Phantom ty1 ty2 - = do { kind_co <- unifyWanted loc Nominal (typeKind ty1) (typeKind ty2) - ; return (mkPhantomCo kind_co ty1 ty2) } - -unifyWanted loc role orig_ty1 orig_ty2 - = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - - go (FunTy s1 t1) (FunTy s2 t2) - = do { co_s <- unifyWanted loc role s1 s2 - ; co_t <- unifyWanted loc role t1 t2 - ; return (mkFunCo role co_s co_t) } - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, tys1 `equalLength` tys2 - , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality - = do { cos <- zipWith3M (unifyWanted loc) - (tyConRolesX role tc1) tys1 tys2 - ; return (mkTyConAppCo role tc1 cos) } - - go ty1@(TyVarTy tv) ty2 - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty1' -> go ty1' ty2 - Nothing -> bale_out ty1 ty2} - go ty1 ty2@(TyVarTy tv) - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty2' -> go ty1 ty2' - Nothing -> bale_out ty1 ty2 } - - go ty1@(CoercionTy {}) (CoercionTy {}) - = return (mkReflCo role ty1) -- we just don't care about coercions! - - go ty1 ty2 = bale_out ty1 ty2 - - bale_out ty1 ty2 - | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1) - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2 - -unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS () --- See Note [unifyWanted and unifyDerived] -unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2 - -unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS () --- See Note [unifyWanted and unifyDerived] -unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2 - -unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS () --- Create new Derived and put it in the work list --- Should do nothing if the two types are equal --- See Note [unifyWanted and unifyDerived] -unify_derived _ Phantom _ _ = return () -unify_derived loc role orig_ty1 orig_ty2 - = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - - go (FunTy s1 t1) (FunTy s2 t2) - = do { unify_derived loc role s1 s2 - ; unify_derived loc role t1 t2 } - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, tys1 `equalLength` tys2 - , isInjectiveTyCon tc1 role - = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2 - go ty1@(TyVarTy tv) ty2 - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty1' -> go ty1' ty2 - Nothing -> bale_out ty1 ty2 } - go ty1 ty2@(TyVarTy tv) - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty2' -> go ty1 ty2' - Nothing -> bale_out ty1 ty2 } - go ty1 ty2 = bale_out ty1 ty2 - - bale_out ty1 ty2 - | ty1 `tcEqType` ty2 = return () - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2 - -maybeSym :: SwapFlag -> TcCoercion -> TcCoercion -maybeSym IsSwapped co = mkTcSymCo co -maybeSym NotSwapped co = co diff --git a/typecheck/TcClassDcl.hs b/typecheck/TcClassDcl.hs deleted file mode 100644 --- a/typecheck/TcClassDcl.hs +++ /dev/null @@ -1,524 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Typechecking class declarations --} - -{-# LANGUAGE CPP #-} - -module TcClassDcl ( tcClassSigs, tcClassDecl2, - findMethodBind, instantiateMethod, - tcClassMinimalDef, - HsSigFun, mkHsSigFun, - tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr, - tcATDefault - ) where - -#include "HsVersions.h" - -import HsSyn -import TcEnv -import TcSigs -import TcEvidence ( idHsWrapper ) -import TcBinds -import TcUnify -import TcHsType -import TcMType -import Type ( getClassPredTys_maybe, piResultTys ) -import TcType -import TcRnMonad -import DriverPhases (HscSource(..)) -import BuildTyCl( TcMethInfo ) -import Class -import Coercion ( pprCoAxiom ) -import DynFlags -import FamInst -import FamInstEnv -import Id -import Name -import NameEnv -import NameSet -import Var -import VarEnv -import Outputable -import SrcLoc -import TyCon -import Maybes -import BasicTypes -import Bag -import FastString -import BooleanFormula -import Util - -import Control.Monad -import Data.List ( mapAccumL, partition ) - -{- -Dictionary handling -~~~~~~~~~~~~~~~~~~~ -Every class implicitly declares a new data type, corresponding to dictionaries -of that class. So, for example: - - class (D a) => C a where - op1 :: a -> a - op2 :: forall b. Ord b => a -> b -> b - -would implicitly declare - - data CDict a = CDict (D a) - (a -> a) - (forall b. Ord b => a -> b -> b) - -(We could use a record decl, but that means changing more of the existing apparatus. -One step at at time!) - -For classes with just one superclass+method, we use a newtype decl instead: - - class C a where - op :: forallb. a -> b -> b - -generates - - newtype CDict a = CDict (forall b. a -> b -> b) - -Now DictTy in Type is just a form of type synomym: - DictTy c t = TyConTy CDict `AppTy` t - -Death to "ExpandingDicts". - - -************************************************************************ -* * - Type-checking the class op signatures -* * -************************************************************************ --} - -illegalHsigDefaultMethod :: Name -> SDoc -illegalHsigDefaultMethod n = - text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file" - -tcClassSigs :: Name -- Name of the class - -> [LSig Name] - -> LHsBinds Name - -> TcM [TcMethInfo] -- Exactly one for each method -tcClassSigs clas sigs def_methods - = do { traceTc "tcClassSigs 1" (ppr clas) - - ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs - ; let gen_dm_env :: NameEnv (SrcSpan, Type) - gen_dm_env = mkNameEnv gen_dm_prs - - ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs - - ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] - ; sequence_ [ failWithTc (badMethodErr clas n) - | n <- dm_bind_names, not (n `elemNameSet` op_names) ] - -- Value binding for non class-method (ie no TypeSig) - - ; tcg_env <- getGblEnv - ; if tcg_src tcg_env == HsigFile - then - -- Error if we have value bindings - -- (Generic signatures without value bindings indicate - -- that a default of this form is expected to be - -- provided.) - when (not (null def_methods)) $ - failWithTc (illegalHsigDefaultMethod clas) - else - -- Error for each generic signature without value binding - sequence_ [ failWithTc (badGenericMethod clas n) - | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] - - ; traceTc "tcClassSigs 2" (ppr clas) - ; return op_info } - where - vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig False nm ty) <- sigs] - gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig True nm ty) <- sigs] - dm_bind_names :: [Name] -- These ones have a value binding in the class decl - dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] - - tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType Name) - -> TcM [TcMethInfo] - tc_sig gen_dm_env (op_names, op_hs_ty) - = do { traceTc "ClsSig 1" (ppr op_names) - ; op_ty <- tcClassSigType op_names op_hs_ty -- Class tyvars already in scope - ; traceTc "ClsSig 2" (ppr op_names) - ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] } - where - f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty) - | nm `elem` dm_bind_names = Just VanillaDM - | otherwise = Nothing - - tc_gen_sig (op_names, gen_hs_ty) - = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty - ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] } - -{- -************************************************************************ -* * - Class Declarations -* * -************************************************************************ --} - -tcClassDecl2 :: LTyClDecl Name -- The class declaration - -> TcM (LHsBinds Id) - -tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, - tcdMeths = default_binds})) - = recoverM (return emptyLHsBinds) $ - setSrcSpan (getLoc class_name) $ - do { clas <- tcLookupLocatedClass class_name - - -- We make a separate binding for each default method. - -- At one time I used a single AbsBinds for all of them, thus - -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } - -- But that desugars into - -- ds = \d -> (..., ..., ...) - -- dm1 = \d -> case ds d of (a,b,c) -> a - -- And since ds is big, it doesn't get inlined, so we don't get good - -- default methods. Better to make separate AbsBinds for each - ; let (tyvars, _, _, op_items) = classBigSig clas - prag_fn = mkPragEnv sigs default_binds - sig_fn = mkHsSigFun sigs - clas_tyvars = snd (tcSuperSkolTyVars tyvars) - pred = mkClassPred clas (mkTyVarTys clas_tyvars) - ; this_dict <- newEvVar pred - - ; let tc_item = tcDefMeth clas clas_tyvars this_dict - default_binds sig_fn prag_fn - ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ - mapM tc_item op_items - - ; return (unionManyBags dm_binds) } - -tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) - -tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name - -> HsSigFun -> TcPragEnv -> ClassOpItem - -> TcM (LHsBinds TcId) --- Generate code for default methods --- This is incompatible with Hugs, which expects a polymorphic --- default method for every class op, regardless of whether or not --- the programmer supplied an explicit default decl for the class. --- (If necessary we can fix that, but we don't have a convenient Id to hand.) - -tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) - = do { -- No default method - mapM_ (addLocM (badDmPrag sel_id)) - (lookupPragEnv prag_fn (idName sel_id)) - ; return emptyBag } - -tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn - (sel_id, Just (dm_name, dm_spec)) - | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn - = do { -- First look up the default method; it should be there! - -- It can be the orinary default method - -- or the generic-default method. E.g of the latter - -- class C a where - -- op :: a -> a -> Bool - -- default op :: Eq a => a -> a -> Bool - -- op x y = x==y - -- The default method we generate is - -- $gm :: (C a, Eq a) => a -> a -> Bool - -- $gm x y = x==y - - global_dm_id <- tcLookupId dm_name - ; global_dm_id <- addInlinePrags global_dm_id prags - ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc - -- Base the local_dm_name on the selector name, because - -- type errors from tcInstanceMethodBody come from here - - ; spec_prags <- discardConstraints $ - tcSpecPrags global_dm_id prags - ; warnTc NoReason - (not (null spec_prags)) - (text "Ignoring SPECIALISE pragmas on default method" - <+> quotes (ppr sel_name)) - - ; let hs_ty = hs_sig_fn sel_name - `orElse` pprPanic "tc_dm" (ppr sel_name) - -- We need the HsType so that we can bring the right - -- type variables into scope - -- - -- Eg. class C a where - -- op :: forall b. Eq b => a -> [b] -> a - -- gen_op :: a -> a - -- generic gen_op :: D a => a -> a - -- The "local_dm_ty" is precisely the type in the above - -- type signatures, ie with no "forall a. C a =>" prefix - - local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) - - lm_bind = dm_bind { fun_id = L bind_loc local_dm_name } - -- Substitute the local_meth_name for the binder - -- NB: the binding is always a FunBind - - warn_redundant = case dm_spec of - GenericDM {} -> True - VanillaDM -> False - -- For GenericDM, warn if the user specifies a signature - -- with redundant constraints; but not for VanillaDM, where - -- the default method may well be 'error' or something - - ctxt = FunSigCtxt sel_name warn_redundant - - ; let local_dm_id = mkLocalId local_dm_name local_dm_ty - local_dm_sig = CompleteSig { sig_bndr = local_dm_id - , sig_ctxt = ctxt - , sig_loc = getLoc (hsSigType hs_ty) } - - ; (ev_binds, (tc_bind, _)) - <- checkConstraints (ClsSkol clas) tyvars [this_dict] $ - tcPolyCheck no_prag_fn local_dm_sig - (L bind_loc lm_bind) - - ; let export = ABE { abe_poly = global_dm_id - , abe_mono = local_dm_id - , abe_wrap = idHsWrapper - , abe_prags = IsDefaultMethod } - full_bind = AbsBinds { abs_tvs = tyvars - , abs_ev_vars = [this_dict] - , abs_exports = [export] - , abs_ev_binds = [ev_binds] - , abs_binds = tc_bind } - - ; return (unitBag (L bind_loc full_bind)) } - - | otherwise = pprPanic "tcDefMeth" (ppr sel_id) - where - sel_name = idName sel_id - no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; - -- they are all for meth_id - ---------------- -tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef -tcClassMinimalDef _clas sigs op_info - = case findMinimalDef sigs of - Nothing -> return defMindef - Just mindef -> do - -- Warn if the given mindef does not imply the default one - -- That is, the given mindef should at least ensure that the - -- class ops without default methods are required, since we - -- have no way to fill them in otherwise - tcg_env <- getGblEnv - -- However, only do this test when it's not an hsig file, - -- since you can't write a default implementation. - when (tcg_src tcg_env /= HsigFile) $ - whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ - (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf)) - return mindef - where - -- By default require all methods without a default implementation - defMindef :: ClassMinimalDef - defMindef = mkAnd [ noLoc (mkVar name) - | (name, _, Nothing) <- op_info ] - -instantiateMethod :: Class -> Id -> [TcType] -> TcType --- Take a class operation, say --- op :: forall ab. C a => forall c. Ix c => (b,c) -> a --- Instantiate it at [ty1,ty2] --- Return the "local method type": --- forall c. Ix x => (ty2,c) -> ty1 -instantiateMethod clas sel_id inst_tys - = ASSERT( ok_first_pred ) local_meth_ty - where - rho_ty = piResultTys (idType sel_id) inst_tys - (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty - `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) - - ok_first_pred = case getClassPredTys_maybe first_pred of - Just (clas1, _tys) -> clas == clas1 - Nothing -> False - -- The first predicate should be of form (C a b) - -- where C is the class in question - - ---------------------------- -type HsSigFun = Name -> Maybe (LHsSigType Name) - -mkHsSigFun :: [LSig Name] -> HsSigFun -mkHsSigFun sigs = lookupNameEnv env - where - env = mkHsSigEnv get_classop_sig sigs - - get_classop_sig :: LSig Name -> Maybe ([Located Name], LHsSigType Name) - get_classop_sig (L _ (ClassOpSig _ ns hs_ty)) = Just (ns, hs_ty) - get_classop_sig _ = Nothing - ---------------------------- -findMethodBind :: Name -- Selector - -> LHsBinds Name -- A group of bindings - -> TcPragEnv - -> Maybe (LHsBind Name, SrcSpan, [LSig Name]) - -- Returns the binding, the binding - -- site of the method binder, and any inline or - -- specialisation pragmas -findMethodBind sel_name binds prag_fn - = foldlBag mplus Nothing (mapBag f binds) - where - prags = lookupPragEnv prag_fn sel_name - - f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) - | op_name == sel_name - = Just (bind, bndr_loc, prags) - f _other = Nothing - ---------------------------- -findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef -findMinimalDef = firstJusts . map toMinimalDef - where - toMinimalDef :: LSig Name -> Maybe ClassMinimalDef - toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf) - toMinimalDef _ = Nothing - -{- -Note [Polymorphic methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class Foo a where - op :: forall b. Ord b => a -> b -> b -> b - instance Foo c => Foo [c] where - op = e - -When typechecking the binding 'op = e', we'll have a meth_id for op -whose type is - op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b - -So tcPolyBinds must be capable of dealing with nested polytypes; -and so it is. See TcBinds.tcMonoBinds (with type-sig case). - -Note [Silly default-method bind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we pass the default method binding to the type checker, it must -look like op2 = e -not $dmop2 = e -otherwise the "$dm" stuff comes out error messages. But we want the -"$dm" to come out in the interface file. So we typecheck the former, -and wrap it in a let, thus - $dmop2 = let op2 = e in op2 -This makes the error messages right. - - -************************************************************************ -* * - Error messages -* * -************************************************************************ --} - -tcMkDeclCtxt :: TyClDecl Name -> SDoc -tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl, - text "declaration for", quotes (ppr (tcdName decl))] - -tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a -tcAddDeclCtxt decl thing_inside - = addErrCtxt (tcMkDeclCtxt decl) thing_inside - -badMethodErr :: Outputable a => a -> Name -> SDoc -badMethodErr clas op - = hsep [text "Class", quotes (ppr clas), - text "does not have a method", quotes (ppr op)] - -badGenericMethod :: Outputable a => a -> Name -> SDoc -badGenericMethod clas op - = hsep [text "Class", quotes (ppr clas), - text "has a generic-default signature without a binding", quotes (ppr op)] - -{- -badGenericInstanceType :: LHsBinds Name -> SDoc -badGenericInstanceType binds - = vcat [text "Illegal type pattern in the generic bindings", - nest 2 (ppr binds)] - -missingGenericInstances :: [Name] -> SDoc -missingGenericInstances missing - = text "Missing type patterns for" <+> pprQuotedList missing - -dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc -dupGenericInsts tc_inst_infos - = vcat [text "More than one type pattern for a single generic type constructor:", - nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), - text "All the type patterns for a generic type constructor must be identical" - ] - where - ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) --} -badDmPrag :: Id -> Sig Name -> TcM () -badDmPrag sel_id prag - = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method") - <+> quotes (ppr sel_id) - <+> text "lacks an accompanying binding") - -warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc -warningMinimalDefIncomplete mindef - = vcat [ text "The MINIMAL pragma does not require:" - , nest 2 (pprBooleanFormulaNice mindef) - , text "but there is no default implementation." ] - -tcATDefault :: Bool -- If a warning should be emitted when a default instance - -- definition is not provided by the user - -> SrcSpan - -> TCvSubst - -> NameSet - -> ClassATItem - -> TcM [FamInst] --- ^ Construct default instances for any associated types that --- aren't given a user definition --- Returns [] or singleton -tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs) - -- User supplied instances ==> everything is OK - | tyConName fam_tc `elemNameSet` defined_ats - = return [] - - -- No user instance, have defaults ==> instantiate them - -- Example: class C a where { type F a b :: *; type F a b = () } - -- instance C [x] - -- Then we want to generate the decl: type F [x] b = () - | Just (rhs_ty, _loc) <- defs - = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst - (tyConTyVars fam_tc) - rhs' = substTyUnchecked subst' rhs_ty - tcv' = tyCoVarsOfTypesList pat_tys' - (tv', cv') = partition isTyVar tcv' - tvs' = toposortTyVars tv' - cvs' = toposortTyVars cv' - ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' cvs' - fam_tc pat_tys' rhs' - -- NB: no validity check. We check validity of default instances - -- in the class definition. Because type instance arguments cannot - -- be type family applications and cannot be polytypes, the - -- validity check is redundant. - - ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty - , pprCoAxiom axiom ]) - ; fam_inst <- newFamInst SynFamilyInst axiom - ; return [fam_inst] } - - -- No defaults ==> generate a warning - | otherwise -- defs = Nothing - = do { when emit_warn $ warnMissingAT (tyConName fam_tc) - ; return [] } - where - subst_tv subst tc_tv - | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv - = (subst, ty) - | otherwise - = (extendTvSubst subst tc_tv ty', ty') - where - ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) - -warnMissingAT :: Name -> TcM () -warnMissingAT name - = do { warn <- woptM Opt_WarnMissingMethods - ; traceTc "warn" (ppr name <+> ppr warn) - ; hsc_src <- fmap tcg_src getGblEnv - -- Warn only if -Wmissing-methods AND not a signature - ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile) - (text "No explicit" <+> text "associated type" - <+> text "or default declaration for " - <+> quotes (ppr name)) } diff --git a/typecheck/TcDefaults.hs b/typecheck/TcDefaults.hs deleted file mode 100644 --- a/typecheck/TcDefaults.hs +++ /dev/null @@ -1,104 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[TcDefaults]{Typechecking \tr{default} declarations} --} - -module TcDefaults ( tcDefaults ) where - -import HsSyn -import Name -import Class -import TcRnMonad -import TcEnv -import TcHsType -import TcHsSyn -import TcSimplify -import TcValidity -import TcType -import PrelNames -import SrcLoc -import Outputable -import FastString -import qualified GHC.LanguageExtensions as LangExt - -tcDefaults :: [LDefaultDecl Name] - -> TcM (Maybe [Type]) -- Defaulting types to heave - -- into Tc monad for later use - -- in Disambig. - -tcDefaults [] - = getDeclaredDefaultTys -- No default declaration, so get the - -- default types from the envt; - -- i.e. use the current ones - -- (the caller will put them back there) - -- It's important not to return defaultDefaultTys here (which - -- we used to do) because in a TH program, tcDefaults [] is called - -- repeatedly, once for each group of declarations between top-level - -- splices. We don't want to carefully set the default types in - -- one group, only for the next group to ignore them and install - -- defaultDefaultTys - -tcDefaults [L _ (DefaultDecl [])] - = return (Just []) -- Default declaration specifying no types - -tcDefaults [L locn (DefaultDecl mono_tys)] - = setSrcSpan locn $ - addErrCtxt defaultDeclCtxt $ - do { ovl_str <- xoptM LangExt.OverloadedStrings - ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules - ; num_class <- tcLookupClass numClassName - ; deflt_str <- if ovl_str - then mapM tcLookupClass [isStringClassName] - else return [] - ; deflt_interactive <- if ext_deflt - then mapM tcLookupClass interactiveClassNames - else return [] - ; let deflt_clss = num_class : deflt_str ++ deflt_interactive - - ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys - - ; return (Just tau_tys) } - -tcDefaults decls@(L locn (DefaultDecl _) : _) - = setSrcSpan locn $ - failWithTc (dupDefaultDeclErr decls) - - -tc_default_ty :: [Class] -> LHsType Name -> TcM Type -tc_default_ty deflt_clss hs_ty - = do { (ty, _kind) <- solveEqualities $ - tcLHsType hs_ty - ; ty <- zonkTcTypeToType emptyZonkEnv ty -- establish Type invariants - ; checkValidType DefaultDeclCtxt ty - - -- Check that the type is an instance of at least one of the deflt_clss - ; oks <- mapM (check_instance ty) deflt_clss - ; checkTc (or oks) (badDefaultTy ty deflt_clss) - ; return ty } - -check_instance :: Type -> Class -> TcM Bool - -- Check that ty is an instance of cls - -- We only care about whether it worked or not; return a boolean -check_instance ty cls - = do { (_, success) <- discardErrs $ - askNoErrs $ - simplifyDefault [mkClassPred cls [ty]] - ; return success } - -defaultDeclCtxt :: SDoc -defaultDeclCtxt = text "When checking the types in a default declaration" - -dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc -dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things) - = hang (text "Multiple default declarations") - 2 (vcat (map pp dup_things)) - where - pp (L locn (DefaultDecl _)) = text "here was another default declaration" <+> ppr locn -dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" - -badDefaultTy :: Type -> [Class] -> SDoc -badDefaultTy ty deflt_clss - = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) - 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/typecheck/TcDeriv.hs b/typecheck/TcDeriv.hs deleted file mode 100644 --- a/typecheck/TcDeriv.hs +++ /dev/null @@ -1,1843 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Handles @deriving@ clauses on @data@ declarations. --} - -{-# LANGUAGE CPP #-} - -module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where - -#include "HsVersions.h" - -import HsSyn -import DynFlags - -import TcRnMonad -import FamInst -import TcDerivInfer -import TcDerivUtils -import TcValidity( allDistinctTyVars ) -import TcClassDcl( tcATDefault, tcMkDeclCtxt ) -import TcEnv -import TcGenDeriv -- Deriv stuff -import InstEnv -import Inst -import FamInstEnv -import TcHsType -import TcMType - -import RnNames( extendGlobalRdrEnvRn ) -import RnBinds -import RnEnv -import RnSource ( addTcgDUs ) -import Avail - -import Unify( tcUnifyTy ) -import BasicTypes ( DerivStrategy(..) ) -import Class -import Type -import ErrUtils -import DataCon -import Maybes -import RdrName -import Name -import NameSet -import TyCon -import TcType -import Var -import VarEnv -import VarSet -import PrelNames -import SrcLoc -import Util -import Outputable -import FastString -import Bag -import Pair -import FV (fvVarList, unionFV, mkFVs) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.List - -{- -************************************************************************ -* * - Overview -* * -************************************************************************ - -Overall plan -~~~~~~~~~~~~ -1. Convert the decls (i.e. data/newtype deriving clauses, - plus standalone deriving) to [EarlyDerivSpec] - -2. Infer the missing contexts for the InferTheta's - -3. Add the derived bindings, generating InstInfos --} - -data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin]) - | GivenTheta (DerivSpec ThetaType) - -- InferTheta ds => the context for the instance should be inferred - -- In this case ds_theta is the list of all the sets of - -- constraints needed, such as (Eq [a], Eq a), together with a - -- suitable CtLoc to get good error messages. - -- The inference process is to reduce this to a - -- simpler form (e.g. Eq a) - -- - -- GivenTheta ds => the exact context for the instance is supplied - -- by the programmer; it is ds_theta - -- See Note [Inferring the instance context] in TcDerivInfer - -earlyDSLoc :: EarlyDerivSpec -> SrcSpan -earlyDSLoc (InferTheta spec) = ds_loc spec -earlyDSLoc (GivenTheta spec) = ds_loc spec - -splitEarlyDerivSpec :: [EarlyDerivSpec] - -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType]) -splitEarlyDerivSpec [] = ([],[]) -splitEarlyDerivSpec (InferTheta spec : specs) = - case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs) -splitEarlyDerivSpec (GivenTheta spec : specs) = - case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs) - -instance Outputable EarlyDerivSpec where - ppr (InferTheta spec) = ppr spec <+> text "(Infer)" - ppr (GivenTheta spec) = ppr spec <+> text "(Given)" - -{- -Note [Data decl contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data (RealFloat a) => Complex a = !a :+ !a deriving( Read ) - -We will need an instance decl like: - - instance (Read a, RealFloat a) => Read (Complex a) where - ... - -The RealFloat in the context is because the read method for Complex is bound -to construct a Complex, and doing that requires that the argument type is -in RealFloat. - -But this ain't true for Show, Eq, Ord, etc, since they don't construct -a Complex; they only take them apart. - -Our approach: identify the offending classes, and add the data type -context to the instance decl. The "offending classes" are - - Read, Enum? - -FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that -pattern matching against a constructor from a data type with a context -gives rise to the constraints for that context -- or at least the thinned -version. So now all classes are "offending". - -Note [Newtype deriving] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - class C a b - instance C [a] Char - newtype T = T Char deriving( C [a] ) - -Notice the free 'a' in the deriving. We have to fill this out to - newtype T = T Char deriving( forall a. C [a] ) - -And then translate it to: - instance C [a] Char => C [a] T where ... - - -Note [Newtype deriving superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(See also Trac #1220 for an interesting exchange on newtype -deriving and superclasses.) - -The 'tys' here come from the partial application in the deriving -clause. The last arg is the new instance type. - -We must pass the superclasses; the newtype might be an instance -of them in a different way than the representation type -E.g. newtype Foo a = Foo a deriving( Show, Num, Eq ) -Then the Show instance is not done via Coercible; it shows - Foo 3 as "Foo 3" -The Num instance is derived via Coercible, but the Show superclass -dictionary must the Show instance for Foo, *not* the Show dictionary -gotten from the Num dictionary. So we must build a whole new dictionary -not just use the Num one. The instance we want is something like: - instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where - (+) = ((+)@a) - ...etc... -There may be a coercion needed which we get from the tycon for the newtype -when the dict is constructed in TcInstDcls.tcInstDecl2 - - -Note [Unused constructors and deriving clauses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Trac #3221. Consider - data T = T1 | T2 deriving( Show ) -Are T1 and T2 unused? Well, no: the deriving clause expands to mention -both of them. So we gather defs/uses from deriving just like anything else. - --} - --- | Stuff needed to process a datatype's `deriving` clauses -data DerivInfo = DerivInfo { di_rep_tc :: TyCon - -- ^ The data tycon for normal datatypes, - -- or the *representation* tycon for data families - , di_clauses :: [LHsDerivingClause Name] - , di_ctxt :: SDoc -- ^ error context - } - --- | Extract `deriving` clauses of proper data type (skips data families) -mkDerivInfos :: [LTyClDecl Name] -> TcM [DerivInfo] -mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls - where - - mk_deriv decl@(DataDecl { tcdLName = L _ data_name - , tcdDataDefn = - HsDataDefn { dd_derivs = L _ clauses } }) - = do { tycon <- tcLookupTyCon data_name - ; return [DerivInfo { di_rep_tc = tycon, di_clauses = clauses - , di_ctxt = tcMkDeclCtxt decl }] } - mk_deriv _ = return [] - -{- - -************************************************************************ -* * -\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}} -* * -************************************************************************ --} - -tcDeriving :: [DerivInfo] -- All `deriving` clauses - -> [LDerivDecl Name] -- All stand-alone deriving declarations - -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name) -tcDeriving deriv_infos deriv_decls - = recoverM (do { g <- getGblEnv - ; return (g, emptyBag, emptyValBindsOut)}) $ - do { -- Fish the "deriving"-related information out of the TcEnv - -- And make the necessary "equations". - is_boot <- tcIsHsBootOrSig - ; traceTc "tcDeriving" (ppr is_boot) - - ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls - ; traceTc "tcDeriving 1" (ppr early_specs) - - ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs - ; insts1 <- mapM genInst given_specs - ; insts2 <- mapM genInst infer_specs - - ; dflags <- getDynFlags - - ; let (_, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2) - ; loc <- getSrcSpanM - ; let (binds, famInsts) = genAuxBinds dflags loc - (unionManyBags deriv_stuff) - - ; let mk_inst_infos1 = map fstOf3 insts1 - ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs - - -- We must put all the derived type family instances (from both - -- infer_specs and given_specs) in the local instance environment - -- before proceeding, or else simplifyInstanceContexts might - -- get stuck if it has to reason about any of those family instances. - -- See Note [Staging of tcDeriving] - ; tcExtendLocalFamInstEnv (bagToList famInsts) $ - -- NB: only call tcExtendLocalFamInstEnv once, as it performs - -- validity checking for all of the family instances you give it. - -- If the family instances have errors, calling it twice will result - -- in duplicate error messages! - - do { - -- the stand-alone derived instances (@inst_infos1@) are used when - -- inferring the contexts for "deriving" clauses' instances - -- (@infer_specs@) - ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $ - simplifyInstanceContexts infer_specs - - ; let mk_inst_infos2 = map fstOf3 insts2 - ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs - ; let inst_infos = inst_infos1 ++ inst_infos2 - - ; (inst_info, rn_binds, rn_dus) <- - renameDeriv is_boot inst_infos binds - - ; unless (isEmptyBag inst_info) $ - liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds famInsts)) - - ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) - getGblEnv - ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ catMaybes maybe_fvs) - ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } } - where - ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name - -> Bag FamInst -- ^ Rep type family instances - -> SDoc - ddump_deriving inst_infos extra_binds repFamInsts - = hang (text "Derived class instances:") - 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) - $$ ppr extra_binds) - $$ hangP "Derived type family instances:" - (vcat (map pprRepTy (bagToList repFamInsts))) - - hangP s x = text "" $$ hang (ptext (sLit s)) 2 x - - -- Apply the suspended computations given by genInst calls. - -- See Note [Staging of tcDeriving] - apply_inst_infos :: [ThetaType -> TcM (InstInfo RdrName)] - -> [DerivSpec ThetaType] -> TcM [InstInfo RdrName] - apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds)) - --- Prints the representable type family instance -pprRepTy :: FamInst -> SDoc -pprRepTy fi@(FamInst { fi_tys = lhs }) - = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> - equals <+> ppr rhs - where rhs = famInstRHS fi - -renameDeriv :: Bool - -> [InstInfo RdrName] - -> Bag (LHsBind RdrName, LSig RdrName) - -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses) -renameDeriv is_boot inst_infos bagBinds - | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings - -- The inst-info bindings will all be empty, but it's easier to - -- just use rn_inst_info to change the type appropriately - = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos - ; return ( listToBag rn_inst_infos - , emptyValBindsOut, usesOnly (plusFVs fvs)) } - - | otherwise - = discardWarnings $ - -- Discard warnings about unused bindings etc - setXOptM LangExt.EmptyCase $ - -- Derived decls (for empty types) can have - -- case x of {} - setXOptM LangExt.ScopedTypeVariables $ - setXOptM LangExt.KindSignatures $ - -- Derived decls (for newtype-deriving) can use ScopedTypeVariables & - -- KindSignatures - unsetXOptM LangExt.RebindableSyntax $ - -- See Note [Avoid RebindableSyntax when deriving] - do { - -- Bring the extra deriving stuff into scope - -- before renaming the instances themselves - ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) - ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds - ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs) - ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds - ; let bndrs = collectHsValBinders rn_aux_lhs - ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ; - ; setEnvs envs $ - do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs - ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos - ; return (listToBag rn_inst_infos, rn_aux, - dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } - - where - rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars) - rn_inst_info - inst_info@(InstInfo { iSpec = inst - , iBinds = InstBindings - { ib_binds = binds - , ib_tyvars = tyvars - , ib_pragmas = sigs - , ib_extensions = exts -- Only for type-checking - , ib_derived = sa } }) - = ASSERT( null sigs ) - bindLocalNamesFV tyvars $ - do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds [] - ; let binds' = InstBindings { ib_binds = rn_binds - , ib_tyvars = tyvars - , ib_pragmas = [] - , ib_extensions = exts - , ib_derived = sa } - ; return (inst_info { iBinds = binds' }, fvs) } - -{- -Note [Newtype deriving and unused constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (see Trac #1954): - - module Bug(P) where - newtype P a = MkP (IO a) deriving Monad - -If you compile with -Wunused-binds you do not expect the warning -"Defined but not used: data constructor MkP". Yet the newtype deriving -code does not explicitly mention MkP, but it should behave as if you -had written - instance Monad P where - return x = MkP (return x) - ...etc... - -So we want to signal a user of the data constructor 'MkP'. -This is the reason behind the (Maybe Name) part of the return type -of genInst. - -Note [Staging of tcDeriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here's a tricky corner case for deriving (adapted from Trac #2721): - - class C a where - type T a - foo :: a -> T a - - instance C Int where - type T Int = Int - foo = id - - newtype N = N Int deriving C - -This will produce an instance something like this: - - instance C N where - type T N = T Int - foo = coerce (foo :: Int -> T Int) :: N -> T N - -We must be careful in order to typecheck this code. When determining the -context for the instance (in simplifyInstanceContexts), we need to determine -that T N and T Int have the same representation, but to do that, the T N -instance must be in the local family instance environment. Otherwise, GHC -would be unable to conclude that T Int is representationally equivalent to -T Int, and simplifyInstanceContexts would get stuck. - -Previously, tcDeriving would defer adding any derived type family instances to -the instance environment until the very end, which meant that -simplifyInstanceContexts would get called without all the type family instances -it needed in the environment in order to properly simplify instance like -the C N instance above. - -To avoid this scenario, we carefully structure the order of events in -tcDeriving. We first call genInst on the standalone derived instance specs and -the instance specs obtained from deriving clauses. Note that the return type of -genInst is a triple: - - TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name) - -The type family instances are in the BagDerivStuff. The first field of the -triple is a suspended computation which, given an instance context, produces -the rest of the instance. The fact that it is suspended is important, because -right now, we don't have ThetaTypes for the instances that use deriving clauses -(only the standalone-derived ones). - -Now we can can collect the type family instances and extend the local instance -environment. At this point, it is safe to run simplifyInstanceContexts on the -deriving-clause instance specs, which gives us the ThetaTypes for the -deriving-clause instances. Now we can feed all the ThetaTypes to the -suspended computations and obtain our InstInfos, at which point -tcDeriving is done. - -An alternative design would be to split up genInst so that the -family instances are generated separately from the InstInfos. But this would -require carving up a lot of the GHC deriving internals to accommodate the -change. On the other hand, we can keep all of the InstInfo and type family -instance logic together in genInst simply by converting genInst to -continuation-returning style, so we opt for that route. - -Note [Why we don't pass rep_tc into deriveTyData] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into -the rep_tc by means of a lookup. And yet we have the rep_tc right here! -Why look it up again? Answer: it's just easier this way. -We drop some number of arguments from the end of the datatype definition -in deriveTyData. The arguments are dropped from the fam_tc. -This action may drop a *different* number of arguments -passed to the rep_tc, depending on how many free variables, etc., the -dropped patterns have. - -Also, this technique carries over the kind substitution from deriveTyData -nicely. - -Note [Avoid RebindableSyntax when deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RebindableSyntax extension interacts awkwardly with the derivation of -any stock class whose methods require the use of string literals. The Show -class is a simple example (see Trac #12688): - - {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} - newtype Text = Text String - fromString :: String -> Text - fromString = Text - - data Foo = Foo deriving Show - -This will generate code to the effect of: - - instance Show Foo where - showsPrec _ Foo = showString "Foo" - -But because RebindableSyntax and OverloadedStrings are enabled, the "Foo" -string literal is now of type Text, not String, which showString doesn't -accept! This causes the generated Show instance to fail to typecheck. - -To avoid this kind of scenario, we simply turn off RebindableSyntax entirely -in derived code. - -************************************************************************ -* * - From HsSyn to DerivSpec -* * -************************************************************************ - -@makeDerivSpecs@ fishes around to find the info about needed derived instances. --} - -makeDerivSpecs :: Bool - -> [DerivInfo] - -> [LDerivDecl Name] - -> TcM [EarlyDerivSpec] -makeDerivSpecs is_boot deriv_infos deriv_decls - = do { eqns1 <- concatMapM (recoverM (return []) . deriveDerivInfo) deriv_infos - ; eqns2 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls - ; let eqns = eqns1 ++ eqns2 - - ; if is_boot then -- No 'deriving' at all in hs-boot files - do { unless (null eqns) (add_deriv_err (head eqns)) - ; return [] } - else return eqns } - where - add_deriv_err eqn - = setSrcSpan (earlyDSLoc eqn) $ - addErr (hang (text "Deriving not permitted in hs-boot file") - 2 (text "Use an instance declaration instead")) - ------------------------------------------------------------------- --- | Process a `deriving` clause -deriveDerivInfo :: DerivInfo -> TcM [EarlyDerivSpec] -deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses - , di_ctxt = err_ctxt }) - = addErrCtxt err_ctxt $ - concatMapM (deriveForClause . unLoc) clauses - where - tvs = tyConTyVars rep_tc - (tc, tys) = case tyConFamInstSig_maybe rep_tc of - -- data family: - Just (fam_tc, pats, _) -> (fam_tc, pats) - -- NB: deriveTyData wants the *user-specified* - -- name. See Note [Why we don't pass rep_tc into deriveTyData] - - _ -> (rep_tc, mkTyVarTys tvs) -- datatype - - deriveForClause :: HsDerivingClause Name -> TcM [EarlyDerivSpec] - deriveForClause (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = L _ preds }) - = concatMapM (deriveTyData tvs tc tys (fmap unLoc dcs)) preds - ------------------------------------------------------------------- -deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec] --- Standalone deriving declarations --- e.g. deriving instance Show a => Show (T a) --- Rather like tcLocalInstDecl -deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode)) - = setSrcSpan loc $ - addErrCtxt (standaloneCtxt deriv_ty) $ - do { traceTc "Standalone deriving decl for" (ppr deriv_ty) - ; let deriv_strat = fmap unLoc deriv_strat' - ; traceTc "Deriving strategy (standalone deriving)" $ - vcat [ppr deriv_strat, ppr deriv_ty] - ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty - ; traceTc "Standalone deriving;" $ vcat - [ text "tvs:" <+> ppr tvs - , text "theta:" <+> ppr theta - , text "cls:" <+> ppr cls - , text "tys:" <+> ppr inst_tys ] - -- C.f. TcInstDcls.tcLocalInstDecl1 - ; checkTc (not (null inst_tys)) derivingNullaryErr - - ; let cls_tys = take (length inst_tys - 1) inst_tys - inst_ty = last inst_tys - ; traceTc "Standalone deriving:" $ vcat - [ text "class:" <+> ppr cls - , text "class types:" <+> ppr cls_tys - , text "type:" <+> ppr inst_ty ] - - ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys - inst_ty deriv_strat msg) - - ; case tcSplitTyConApp_maybe inst_ty of - Just (tc, tc_args) - | className cls == typeableClassName - -> do warnUselessTypeable - return [] - - | isUnboxedTupleTyCon tc - -> bale_out $ unboxedTyConErr "tuple" - - | isUnboxedSumTyCon tc - -> bale_out $ unboxedTyConErr "sum" - - | isAlgTyCon tc || isDataFamilyTyCon tc -- All other classes - -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode) - tvs cls cls_tys tc tc_args - (Just theta) deriv_strat - ; return [spec] } - - _ -> -- Complain about functions, primitive types, etc, - bale_out $ - text "The last argument of the instance must be a data or newtype application" - } - -warnUselessTypeable :: TcM () -warnUselessTypeable - = do { warn <- woptM Opt_WarnDerivingTypeable - ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable) - $ text "Deriving" <+> quotes (ppr typeableClassName) <+> - text "has no effect: all types now auto-derive Typeable" } - ------------------------------------------------------------------- -deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance - -- Can be a data instance, hence [Type] args - -> Maybe DerivStrategy -- The optional deriving strategy - -> LHsSigType Name -- The deriving predicate - -> TcM [EarlyDerivSpec] --- The deriving clause of a data or newtype declaration --- I.e. not standalone deriving -deriveTyData tvs tc tc_args deriv_strat deriv_pred - = setSrcSpan (getLoc (hsSigType deriv_pred)) $ -- Use loc of the 'deriving' item - do { (deriv_tvs, cls, cls_tys, cls_arg_kinds) - <- tcExtendTyVarEnv tvs $ - tcHsDeriv deriv_pred - -- Deriving preds may (now) mention - -- the type variables for the type constructor, hence tcExtendTyVarenv - -- The "deriv_pred" is a LHsType to take account of the fact that for - -- newtype deriving we allow deriving (forall a. C [a]). - - -- Typeable is special, because Typeable :: forall k. k -> Constraint - -- so the argument kind 'k' is not decomposable by splitKindFunTys - -- as is the case for all other derivable type classes - ; when (length cls_arg_kinds /= 1) $ - failWithTc (nonUnaryErr deriv_pred) - ; let [cls_arg_kind] = cls_arg_kinds - ; if className cls == typeableClassName - then do warnUselessTypeable - return [] - else - - do { -- Given data T a b c = ... deriving( C d ), - -- we want to drop type variables from T so that (C d (T a)) is well-kinded - let (arg_kinds, _) = splitFunTys cls_arg_kind - n_args_to_drop = length arg_kinds - n_args_to_keep = tyConArity tc - n_args_to_drop - (tc_args_to_keep, args_to_drop) - = splitAt n_args_to_keep tc_args - inst_ty_kind = typeKind (mkTyConApp tc tc_args_to_keep) - - -- Match up the kinds, and apply the resulting kind substitution - -- to the types. See Note [Unify kinds in deriving] - -- We are assuming the tycon tyvars and the class tyvars are distinct - mb_match = tcUnifyTy inst_ty_kind cls_arg_kind - enough_args = n_args_to_keep >= 0 - - -- Check that the result really is well-kinded - ; checkTc (enough_args && isJust mb_match) - (derivingKindErr tc cls cls_tys cls_arg_kind enough_args) - - ; let Just kind_subst = mb_match - ki_subst_range = getTCvSubstRangeFVs kind_subst - all_tkvs = toposortTyVars $ - fvVarList $ unionFV - (tyCoFVsOfTypes tc_args_to_keep) - (FV.mkFVs deriv_tvs) - -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst - && not (v `elemVarSet` ki_subst_range)) - all_tkvs - (subst, _) = mapAccumL substTyVarBndr - kind_subst unmapped_tkvs - final_tc_args = substTys subst tc_args_to_keep - final_cls_tys = substTys subst cls_tys - tkvs = tyCoVarsOfTypesWellScoped $ - final_cls_tys ++ final_tc_args - - ; traceTc "Deriving strategy (deriving clause)" $ - vcat [ppr deriv_strat, ppr deriv_pred] - - ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args - , ppr deriv_pred - , pprTyVars (tyCoVarsOfTypesList tc_args) - , ppr n_args_to_keep, ppr n_args_to_drop - , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match - , ppr final_tc_args, ppr final_cls_tys ]) - - ; traceTc "derivTyData2" (vcat [ ppr tkvs ]) - - ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop) -- (a, b, c) - (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args)) - -- Check that - -- (a) The args to drop are all type variables; eg reject: - -- data instance T a Int = .... deriving( Monad ) - -- (b) The args to drop are all *distinct* type variables; eg reject: - -- class C (a :: * -> * -> *) where ... - -- data instance T a a = ... deriving( C ) - -- (c) The type class args, or remaining tycon args, - -- do not mention any of the dropped type variables - -- newtype T a s = ... deriving( ST s ) - -- newtype instance K a a = ... deriving( Monad ) - -- - -- It is vital that the implementation of allDistinctTyVars - -- expand any type synonyms. - -- See Note [Eta-reducing type synonyms] - - ; spec <- mkEqnHelp Nothing tkvs - cls final_cls_tys tc final_tc_args - Nothing deriv_strat - ; traceTc "derivTyData" (ppr spec) - ; return [spec] } } - - -{- -Note [Unify kinds in deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #8534) - data T a b = MkT a deriving( Functor ) - -- where Functor :: (*->*) -> Constraint - -So T :: forall k. * -> k -> *. We want to get - instance Functor (T * (a:*)) where ... -Notice the '*' argument to T. - -Moreover, as well as instantiating T's kind arguments, we may need to instantiate -C's kind args. Consider (Trac #8865): - newtype T a b = MkT (Either a b) deriving( Category ) -where - Category :: forall k. (k -> k -> *) -> Constraint -We need to generate the instance - instance Category * (Either a) where ... -Notice the '*' argument to Category. - -So we need to - * drop arguments from (T a b) to match the number of - arrows in the (last argument of the) class; - * and then *unify* kind of the remaining type against the - expected kind, to figure out how to instantiate C's and T's - kind arguments. - -In the two examples, - * we unify kind-of( T k (a:k) ) ~ kind-of( Functor ) - i.e. (k -> *) ~ (* -> *) to find k:=*. - yielding k:=* - - * we unify kind-of( Either ) ~ kind-of( Category ) - i.e. (* -> * -> *) ~ (k -> k -> k) - yielding k:=* - -Now we get a kind substitution. We then need to: - - 1. Remove the substituted-out kind variables from the quantified kind vars - - 2. Apply the substitution to the kinds of quantified *type* vars - (and extend the substitution to reflect this change) - - 3. Apply that extended substitution to the non-dropped args (types and - kinds) of the type and class - -Forgetting step (2) caused Trac #8893: - data V a = V [a] deriving Functor - data P (x::k->*) (a:k) = P (x a) deriving Functor - data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor - -When deriving Functor for P, we unify k to *, but we then want -an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*)) -and similarly for C. Notice the modified kind of x, both at binding -and occurrence sites. - -This can lead to some surprising results when *visible* kind binder is -unified (in contrast to the above examples, in which only non-visible kind -binders were considered). Consider this example from Trac #11732: - - data T k (a :: k) = MkT deriving Functor - -Since unification yields k:=*, this results in a generated instance of: - - instance Functor (T *) where ... - -which looks odd at first glance, since one might expect the instance head -to be of the form Functor (T k). Indeed, one could envision an alternative -generated instance of: - - instance (k ~ *) => Functor (T k) where - -But this does not typecheck as the result of a -XTypeInType design decision: -kind equalities are not allowed to be bound in types, only terms. But in -essence, the two instance declarations are entirely equivalent, since even -though (T k) matches any kind k, the only possibly value for k is *, since -anything else is ill-typed. As a result, we can just as comfortably use (T *). - -Another way of thinking about is: deriving clauses often infer constraints. -For example: - - data S a = S a deriving Eq - -infers an (Eq a) constraint in the derived instance. By analogy, when we -are deriving Functor, we might infer an equality constraint (e.g., k ~ *). -The only distinction is that GHC instantiates equality constraints directly -during the deriving process. - -Another quirk of this design choice manifests when typeclasses have visible -kind parameters. Consider this code (also from Trac #11732): - - class Cat k (cat :: k -> k -> *) where - catId :: cat a a - catComp :: cat b c -> cat a b -> cat a c - - instance Cat * (->) where - catId = id - catComp = (.) - - newtype Fun a b = Fun (a -> b) deriving (Cat k) - -Even though we requested an derived instance of the form (Cat k Fun), the -kind unification will actually generate (Cat * Fun) (i.e., the same thing as if -the user wrote deriving (Cat *)). - -Note [Unification of two kind variables in deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As a special case of the Note above, it is possible to derive an instance of -a poly-kinded typeclass for a poly-kinded datatype. For example: - - class Category (cat :: k -> k -> *) where - newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category - -This case is suprisingly tricky. To see why, let's write out what instance GHC -will attempt to derive (using -fprint-explicit-kinds syntax): - - instance Category k1 (T k2 c) where ... - -GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst) -that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to -the type variable binder for c, since its kind is (k2 -> k2 -> *). - -We used to accomplish this by doing the following: - - unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs - (subst, _) = mapAccumL substTyVarBndr kind_subst unmapped_tkvs - -Where all_tkvs contains all kind variables in the class and instance types (in -this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping, -this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped -to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new]. -This is bad, because applying that substitution yields the following instance: - - instance Category k_new (T k1 c) where ... - -In other words, keeping k1 in unmapped_tvks taints the substitution, resulting -in an ill-kinded instance (this caused Trac #11837). - -To prevent this, we need to filter out any variable from all_tkvs which either - -1. Appears in the domain of kind_subst. notElemTCvSubst checks this. -2. Appears in the range of kind_subst. To do this, we compute the free - variable set of the range of kind_subst with getTCvSubstRangeFVs, and check - if a kind variable appears in that set. - -Note [Eta-reducing type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One can instantiate a type in a data family instance with a type synonym that -mentions other type variables: - - type Const a b = a - data family Fam (f :: * -> *) (a :: *) - newtype instance Fam f (Const a f) = Fam (f a) deriving Functor - -With -XTypeInType, it is also possible to define kind synonyms, and they can -mention other types in a datatype declaration. For example, - - type Const a b = a - newtype T f (a :: Const * f) = T (f a) deriving Functor - -When deriving, we need to perform eta-reduction analysis to ensure that none of -the eta-reduced type variables are mentioned elsewhere in the declaration. But -we need to be careful, because if we don't expand through the Const type -synonym, we will mistakenly believe that f is an eta-reduced type variable and -fail to derive Functor, even though the code above is correct (see Trac #11416, -where this was first noticed). For this reason, we expand the type synonyms in -the eta-reduced types before doing any analysis. --} - -mkEqnHelp :: Maybe OverlapMode - -> [TyVar] - -> Class -> [Type] - -> TyCon -> [Type] - -> DerivContext -- Just => context supplied (standalone deriving) - -- Nothing => context inferred (deriving on data decl) - -> Maybe DerivStrategy - -> TcRn EarlyDerivSpec --- Make the EarlyDerivSpec for an instance --- forall tvs. theta => cls (tys ++ [ty]) --- where the 'theta' is optional (that's the Maybe part) --- Assumes that this declaration is well-kinded - -mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat - = do { -- Find the instance of a data family - -- Note [Looking up family instances for deriving] - fam_envs <- tcGetFamInstEnvs - ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args - -- If it's still a data family, the lookup failed; i.e no instance exists - ; when (isDataFamilyTyCon rep_tc) - (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args))) - - ; dflags <- getDynFlags - ; if isDataTyCon rep_tc then - mkDataTypeEqn dflags overlap_mode tvs cls cls_tys - tycon tc_args rep_tc rep_tc_args mtheta deriv_strat - else - mkNewTypeEqn dflags overlap_mode tvs cls cls_tys - tycon tc_args rep_tc rep_tc_args mtheta deriv_strat } - where - bale_out msg = failWithTc (derivingThingErr False cls cls_tys - (mkTyConApp tycon tc_args) deriv_strat msg) - -{- -Note [Looking up family instances for deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcLookupFamInstExact is an auxiliary lookup wrapper which requires -that looked-up family instances exist. If called with a vanilla -tycon, the old type application is simply returned. - -If we have - data instance F () = ... deriving Eq - data instance F () = ... deriving Eq -then tcLookupFamInstExact will be confused by the two matches; -but that can't happen because tcInstDecls1 doesn't call tcDeriving -if there are any overlaps. - -There are two other things that might go wrong with the lookup. -First, we might see a standalone deriving clause - deriving Eq (F ()) -when there is no data instance F () in scope. - -Note that it's OK to have - data instance F [a] = ... - deriving Eq (F [(a,b)]) -where the match is not exact; the same holds for ordinary data types -with standalone deriving declarations. - -Note [Deriving, type families, and partial applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When there are no type families, it's quite easy: - - newtype S a = MkS [a] - -- :CoS :: S ~ [] -- Eta-reduced - - instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) - instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S - -When type familes are involved it's trickier: - - data family T a b - newtype instance T Int a = MkT [a] deriving( Eq, Monad ) - -- :RT is the representation type for (T Int a) - -- :Co:RT :: :RT ~ [] -- Eta-reduced! - -- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced! - - instance Eq [a] => Eq (T Int a) -- easy by coercion - -- d1 :: Eq [a] - -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a)) - - instance Monad [] => Monad (T Int) -- only if we can eta reduce??? - -- d1 :: Monad [] - -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) - -Note the need for the eta-reduced rule axioms. After all, we can -write it out - instance Monad [] => Monad (T Int) -- only if we can eta reduce??? - return x = MkT [x] - ... etc ... - -See Note [Eta reduction for data families] in FamInstEnv - -%************************************************************************ -%* * - Deriving data types -* * -************************************************************************ --} - -mkDataTypeEqn :: DynFlags - -> Maybe OverlapMode - -> [TyVar] -- Universally quantified type variables in the instance - -> Class -- Class for which we need to derive an instance - -> [Type] -- Other parameters to the class except the last - -> TyCon -- Type constructor for which the instance is requested - -- (last parameter to the type class) - -> [Type] -- Parameters to the type constructor - -> TyCon -- rep of the above (for type families) - -> [Type] -- rep of the above - -> DerivContext -- Context of the instance, for standalone deriving - -> Maybe DerivStrategy -- 'Just' if user requests a particular - -- deriving strategy. - -- Otherwise, 'Nothing'. - -> TcRn EarlyDerivSpec -- Return 'Nothing' if error - -mkDataTypeEqn dflags overlap_mode tvs cls cls_tys - tycon tc_args rep_tc rep_tc_args mtheta deriv_strat - = case deriv_strat of - Just StockStrategy -> mk_eqn_stock dflags mtheta cls cls_tys rep_tc - go_for_it bale_out - Just AnyclassStrategy -> mk_eqn_anyclass dflags go_for_it bale_out - -- GeneralizedNewtypeDeriving makes no sense for non-newtypes - Just NewtypeStrategy -> bale_out gndNonNewtypeErr - -- Lacking a user-requested deriving strategy, we will try to pick - -- between the stock or anyclass strategies - Nothing -> mk_eqn_no_mechanism dflags tycon mtheta cls cls_tys rep_tc - go_for_it bale_out - where - go_for_it = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args - rep_tc rep_tc_args mtheta (isJust deriv_strat) - bale_out msg = failWithTc (derivingThingErr False cls cls_tys - (mkTyConApp tycon tc_args) deriv_strat msg) - -mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> [Type] - -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext - -> Bool -- True if an explicit deriving strategy keyword was - -- provided - -> DerivSpecMechanism -- How GHC should proceed attempting to - -- derive this instance, determined in - -- mkDataTypeEqn/mkNewTypeEqn - -> TcM EarlyDerivSpec -mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args - mtheta strat_used mechanism - = do doDerivInstErrorChecks1 cls cls_tys tycon tc_args rep_tc mtheta - strat_used mechanism - loc <- getSrcSpanM - dfun_name <- newDFunName' cls tycon - case mtheta of - Nothing -> -- Infer context - do { (inferred_constraints, tvs', inst_tys') - <- inferConstraints tvs cls cls_tys inst_ty - rep_tc rep_tc_args mechanism - ; return $ InferTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs' - , ds_cls = cls, ds_tys = inst_tys' - , ds_tc = rep_tc - , ds_theta = inferred_constraints - , ds_overlap = overlap_mode - , ds_mechanism = mechanism } } - - Just theta -> do -- Specified context - return $ GivenTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs - , ds_cls = cls, ds_tys = inst_tys - , ds_tc = rep_tc - , ds_theta = theta - , ds_overlap = overlap_mode - , ds_mechanism = mechanism } - where - inst_ty = mkTyConApp tycon tc_args - inst_tys = cls_tys ++ [inst_ty] - -mk_eqn_stock :: DynFlags -> DerivContext -> Class -> [Type] -> TyCon - -> (DerivSpecMechanism -> TcRn EarlyDerivSpec) - -> (SDoc -> TcRn EarlyDerivSpec) - -> TcRn EarlyDerivSpec -mk_eqn_stock dflags mtheta cls cls_tys rep_tc go_for_it bale_out - = case checkSideConditions dflags mtheta cls cls_tys rep_tc of - CanDerive -> mk_eqn_stock' cls go_for_it - DerivableClassError msg -> bale_out msg - _ -> bale_out (nonStdErr cls) - -mk_eqn_stock' :: Class -> (DerivSpecMechanism -> TcRn EarlyDerivSpec) - -> TcRn EarlyDerivSpec -mk_eqn_stock' cls go_for_it - = go_for_it $ case hasStockDeriving cls of - Just gen_fn -> DerivSpecStock gen_fn - Nothing -> - pprPanic "mk_eqn_stock': Not a stock class!" (ppr cls) - -mk_eqn_anyclass :: DynFlags - -> (DerivSpecMechanism -> TcRn EarlyDerivSpec) - -> (SDoc -> TcRn EarlyDerivSpec) - -> TcRn EarlyDerivSpec -mk_eqn_anyclass dflags go_for_it bale_out - = case canDeriveAnyClass dflags of - IsValid -> go_for_it DerivSpecAnyClass - NotValid msg -> bale_out msg - -mk_eqn_no_mechanism :: DynFlags -> TyCon -> DerivContext - -> Class -> [Type] -> TyCon - -> (DerivSpecMechanism -> TcRn EarlyDerivSpec) - -> (SDoc -> TcRn EarlyDerivSpec) - -> TcRn EarlyDerivSpec -mk_eqn_no_mechanism dflags tc mtheta cls cls_tys rep_tc go_for_it bale_out - = case checkSideConditions dflags mtheta cls cls_tys rep_tc of - -- NB: pass the *representation* tycon to checkSideConditions - NonDerivableClass msg -> bale_out (dac_error msg) - DerivableClassError msg -> bale_out msg - CanDerive -> mk_eqn_stock' cls go_for_it - DerivableViaInstance -> go_for_it DerivSpecAnyClass - where - -- See Note [Deriving instances for classes themselves] - dac_error msg - | isClassTyCon rep_tc - = quotes (ppr tc) <+> text "is a type class," - <+> text "and can only have a derived instance" - $+$ text "if DeriveAnyClass is enabled" - | otherwise - = nonStdErr cls $$ msg - -{- -************************************************************************ -* * - Deriving newtypes -* * -************************************************************************ --} - -mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [TyVar] -> Class - -> [Type] -> TyCon -> [Type] -> TyCon -> [Type] - -> DerivContext -> Maybe DerivStrategy - -> TcRn EarlyDerivSpec -mkNewTypeEqn dflags overlap_mode tvs - cls cls_tys tycon tc_args rep_tycon rep_tc_args - mtheta deriv_strat --- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... - = ASSERT( length cls_tys + 1 == classArity cls ) - case deriv_strat of - Just StockStrategy -> mk_eqn_stock dflags mtheta cls cls_tys rep_tycon - go_for_it_other bale_out - Just AnyclassStrategy -> mk_eqn_anyclass dflags go_for_it_other bale_out - Just NewtypeStrategy -> - -- Since the user explicitly asked for GeneralizedNewtypeDeriving, we - -- don't need to perform all of the checks we normally would, such as - -- if the class being derived is known to produce ill-roled coercions - -- (e.g., Traversable), since we can just derive the instance and let - -- it error if need be. - -- See Note [Determining whether newtype-deriving is appropriate] - if coercion_looks_sensible && newtype_deriving - then go_for_it_gnd - else bale_out (cant_derive_err $$ - if newtype_deriving then empty else suggest_gnd) - Nothing - | might_derive_via_coercible - && ((newtype_deriving && not deriveAnyClass) - || std_class_via_coercible cls) - -> go_for_it_gnd - | otherwise - -> case checkSideConditions dflags mtheta cls cls_tys rep_tycon of - DerivableClassError msg - -- There's a particular corner case where - -- - -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are both - -- enabled at the same time - -- 2. We're deriving a particular stock derivable class - -- (such as Functor) - -- - -- and the previous cases won't catch it. This fixes the bug - -- reported in Trac #10598. - | might_derive_via_coercible && newtype_deriving - -> go_for_it_gnd - -- Otherwise, throw an error for a stock class - | might_derive_via_coercible && not newtype_deriving - -> bale_out (msg $$ suggest_gnd) - | otherwise - -> bale_out msg - - -- Must use newtype deriving or DeriveAnyClass - NonDerivableClass _msg - -- Too hard, even with newtype deriving - | newtype_deriving -> bale_out cant_derive_err - -- Try newtype deriving! - -- Here we suggest GeneralizedNewtypeDeriving even in cases where - -- it may not be applicable. See Trac #9600. - | otherwise -> bale_out (non_std $$ suggest_gnd) - - -- DerivableViaInstance - DerivableViaInstance -> do - -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are - -- enabled, we take the diplomatic approach of defaulting to - -- DeriveAnyClass, but emitting a warning about the choice. - -- See Note [Deriving strategies] - when (newtype_deriving && deriveAnyClass) $ - addWarnTc NoReason $ sep - [ text "Both DeriveAnyClass and" - <+> text "GeneralizedNewtypeDeriving are enabled" - , text "Defaulting to the DeriveAnyClass strategy" - <+> text "for instantiating" <+> ppr cls ] - go_for_it_other DerivSpecAnyClass - -- CanDerive - CanDerive -> mk_eqn_stock' cls go_for_it_other - where - newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags - deriveAnyClass = xopt LangExt.DeriveAnyClass dflags - go_for_it_gnd = do - traceTc "newtype deriving:" $ - ppr tycon <+> ppr rep_tys <+> ppr all_thetas - let mechanism = DerivSpecNewtype rep_inst_ty - doDerivInstErrorChecks1 cls cls_tys tycon tc_args rep_tycon mtheta - strat_used mechanism - dfun_name <- newDFunName' cls tycon - loc <- getSrcSpanM - case mtheta of - Just theta -> return $ GivenTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs - , ds_cls = cls, ds_tys = inst_tys - , ds_tc = rep_tycon - , ds_theta = theta - , ds_overlap = overlap_mode - , ds_mechanism = mechanism } - Nothing -> return $ InferTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs - , ds_cls = cls, ds_tys = inst_tys - , ds_tc = rep_tycon - , ds_theta = all_thetas - , ds_overlap = overlap_mode - , ds_mechanism = mechanism } - go_for_it_other = mk_data_eqn overlap_mode tvs cls cls_tys tycon - tc_args rep_tycon rep_tc_args mtheta strat_used - bale_out = bale_out' newtype_deriving - bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty - deriv_strat - - strat_used = isJust deriv_strat - non_std = nonStdErr cls - suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension" - - -- Here is the plan for newtype derivings. We see - -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...) - -- where t is a type, - -- ak+1...an is a suffix of a1..an, and are all tyvars - -- ak+1...an do not occur free in t, nor in the s1..sm - -- (C s1 ... sm) is a *partial applications* of class C - -- with the last parameter missing - -- (T a1 .. ak) matches the kind of C's last argument - -- (and hence so does t) - -- The latter kind-check has been done by deriveTyData already, - -- and tc_args are already trimmed - -- - -- We generate the instance - -- instance forall ({a1..ak} u fvs(s1..sm)). - -- C s1 .. sm t => C s1 .. sm (T a1...ak) - -- where T a1...ap is the partial application of - -- the LHS of the correct kind and p >= k - -- - -- NB: the variables below are: - -- tc_tvs = [a1, ..., an] - -- tyvars_to_keep = [a1, ..., ak] - -- rep_ty = t ak .. an - -- deriv_tvs = fvs(s1..sm) \ tc_tvs - -- tys = [s1, ..., sm] - -- rep_fn' = t - -- - -- Running example: newtype T s a = MkT (ST s a) deriving( Monad ) - -- We generate the instance - -- instance Monad (ST s) => Monad (T s) where - - nt_eta_arity = newTyConEtadArity rep_tycon - -- For newtype T a b = MkT (S a a b), the TyCon machinery already - -- eta-reduces the representation type, so we know that - -- T a ~ S a a - -- That's convenient here, because we may have to apply - -- it to fewer than its original complement of arguments - - -- Note [Newtype representation] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Need newTyConRhs (*not* a recursive representation finder) - -- to get the representation type. For example - -- newtype B = MkB Int - -- newtype A = MkA B deriving( Num ) - -- We want the Num instance of B, *not* the Num instance of Int, - -- when making the Num instance of A! - rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args - rep_tys = cls_tys ++ [rep_inst_ty] - rep_pred = mkClassPred cls rep_tys - rep_pred_o = mkPredOrigin DerivOrigin TypeLevel rep_pred - -- rep_pred is the representation dictionary, from where - -- we are gong to get all the methods for the newtype - -- dictionary - - -- Next we figure out what superclass dictionaries to use - -- See Note [Newtype deriving superclasses] above - sc_preds :: [PredOrigin] - cls_tyvars = classTyVars cls - inst_ty = mkTyConApp tycon tc_args - inst_tys = cls_tys ++ [inst_ty] - sc_preds = map (mkPredOrigin DerivOrigin TypeLevel) $ - substTheta (zipTvSubst cls_tyvars inst_tys) $ - classSCTheta cls - - -- Next we collect constraints for the class methods - -- If there are no methods, we don't need any constraints - -- Otherwise we need (C rep_ty), for the representation methods, - -- and constraints to coerce each individual method - meth_preds :: [PredOrigin] - meths = classMethods cls - meth_preds | null meths = [] -- No methods => no constraints - -- (Trac #12814) - | otherwise = rep_pred_o : coercible_constraints - coercible_constraints - = [ mkPredOrigin (DerivOriginCoerce meth t1 t2) TypeLevel - (mkReprPrimEqPred t1 t2) - | meth <- meths - , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs - inst_tys rep_inst_ty meth ] - - all_thetas :: [ThetaOrigin] - all_thetas = [mkThetaOriginFromPreds $ meth_preds ++ sc_preds] - - ------------------------------------------------------------------- - -- Figuring out whether we can only do this newtype-deriving thing - - -- See Note [Determining whether newtype-deriving is appropriate] - might_derive_via_coercible - = not (non_coercible_class cls) - && coercion_looks_sensible --- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] - coercion_looks_sensible - = eta_ok - -- Check (a) from Note [GND and associated type families] - && ats_ok - -- Check (b) from Note [GND and associated type families] - && isNothing at_without_last_cls_tv - - -- Check that eta reduction is OK - eta_ok = nt_eta_arity <= length rep_tc_args - -- The newtype can be eta-reduced to match the number - -- of type argument actually supplied - -- newtype T a b = MkT (S [a] b) deriving( Monad ) - -- Here the 'b' must be the same in the rep type (S [a] b) - -- And the [a] must not mention 'b'. That's all handled - -- by nt_eta_rity. - - (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs - ats_ok = null adf_tcs - -- We cannot newtype-derive data family instances - - at_without_last_cls_tv - = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs - at_tcs = classATs cls - last_cls_tv = ASSERT( notNull cls_tyvars ) - last cls_tyvars - - cant_derive_err - = vcat [ ppUnless eta_ok eta_msg - , ppUnless ats_ok ats_msg - , maybe empty at_tv_msg - at_without_last_cls_tv] - eta_msg = text "cannot eta-reduce the representation type enough" - ats_msg = text "the class has associated data types" - at_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)) - -{- -Note [Recursive newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Newtype deriving works fine, even if the newtype is recursive. -e.g. newtype S1 = S1 [T1 ()] - newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad ) -Remember, too, that type families are currently (conservatively) given -a recursive flag, so this also allows newtype deriving to work -for type famillies. - -We used to exclude recursive types, because we had a rather simple -minded way of generating the instance decl: - newtype A = MkA [A] - instance Eq [A] => Eq A -- Makes typechecker loop! -But now we require a simple context, so it's ok. - -Note [Determining whether newtype-deriving is appropriate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we see - newtype NT = MkNT Foo - deriving C -we have to decide how to perform the deriving. Do we do newtype deriving, -or do we do normal deriving? In general, we prefer to do newtype deriving -wherever possible. So, we try newtype deriving unless there's a glaring -reason not to. - -"Glaring reasons not to" include trying to derive a class for which a -coercion-based instance doesn't make sense. These classes are listed in -the definition of non_coercible_class. They include Show (since it must -show the name of the datatype) and Traversable (since a coercion-based -Traversable instance is ill-roled). - -However, non_coercible_class is ignored if the user explicitly requests -to derive an instance with GeneralizedNewtypeDeriving using the newtype -deriving strategy. In such a scenario, GHC will unquestioningly try to -derive the instance via coercions (even if the final generated code is -ill-roled!). See Note [Deriving strategies]. - -Note that newtype deriving might fail, even after we commit to it. This -is because the derived instance uses `coerce`, which must satisfy its -`Coercible` constraint. This is different than other deriving scenarios, -where we're sure that the resulting instance will type-check. - -Note [GND and associated type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for -classes with associated type families. A general recipe is: - - class C x y z where - type T y z x - op :: x -> [y] -> z - - newtype N a = MkN deriving( C ) - - =====> - - instance C x y => C x y (N a) where - type T y (N a) x = T y x - op = coerce (op :: x -> [y] -> ) - -However, we must watch out for three things: - -(a) The class must not contain any data families. If it did, we'd have to - generate a fresh data constructor name for the derived data family - instance, and it's not clear how to do this. - -(b) Each associated type family's type variables must mention the last type - variable of the class. As an example, you wouldn't be able to use GND to - derive an instance of this class: - - class C a b where - type T a - - But you would be able to derive an instance of this class: - - class C a b where - type T b - - The difference is that in the latter T mentions the last parameter of C - (i.e., it mentions b), but the former T does not. If you tried, e.g., - - newtype Foo x = Foo x deriving (C a) - - with the former definition of C, you'd end up with something like this: - - instance C a (Foo x) where - type T a = T ??? - - This T family instance doesn't mention the newtype (or its representation - type) at all, so we disallow such constructions with GND. - -(c) UndecidableInstances might need to be enabled. Here's a case where it is - most definitely necessary: - - class C a where - type T a - newtype Loop = Loop MkLoop deriving C - - =====> - - instance C Loop where - type T Loop = T Loop - - Obviously, T Loop would send the typechecker into a loop. Unfortunately, - you might even need UndecidableInstances even in cases where the - typechecker would be guaranteed to terminate. For example: - - instance C Int where - type C Int = Int - newtype MyInt = MyInt Int deriving C - - =====> - - instance C MyInt where - type T MyInt = T Int - - GHC's termination checker isn't sophisticated enough to conclude that the - definition of T MyInt terminates, so UndecidableInstances is required. - -************************************************************************ -* * -\subsection[TcDeriv-normal-binds]{Bindings for the various classes} -* * -************************************************************************ - -After all the trouble to figure out the required context for the -derived instance declarations, all that's left is to chug along to -produce them. They will then be shoved into @tcInstDecls2@, which -will do all its usual business. - -There are lots of possibilities for code to generate. Here are -various general remarks. - -PRINCIPLES: -\begin{itemize} -\item -We want derived instances of @Eq@ and @Ord@ (both v common) to be -``you-couldn't-do-better-by-hand'' efficient. - -\item -Deriving @Show@---also pretty common--- should also be reasonable good code. - -\item -Deriving for the other classes isn't that common or that big a deal. -\end{itemize} - -PRAGMATICS: - -\begin{itemize} -\item -Deriving @Ord@ is done mostly with the 1.3 @compare@ method. - -\item -Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too. - -\item -We {\em normally} generate code only for the non-defaulted methods; -there are some exceptions for @Eq@ and (especially) @Ord@... - -\item -Sometimes we use a @_con2tag_@ function, which returns a data -constructor's numeric (@Int#@) tag. These are generated by -@gen_tag_n_con_binds@, and the heuristic for deciding if one of -these is around is given by @hasCon2TagFun@. - -The examples under the different sections below will make this -clearer. - -\item -Much less often (really just for deriving @Ix@), we use a -@_tag2con_@ function. See the examples. - -\item -We use the renamer!!! Reason: we're supposed to be -producing @LHsBinds Name@ for the methods, but that means -producing correctly-uniquified code on the fly. This is entirely -possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. -So, instead, we produce @MonoBinds RdrName@ then heave 'em through -the renamer. What a great hack! -\end{itemize} --} - --- Generate the InstInfo for the required instance paired with the --- *representation* tycon for that instance, --- plus any auxiliary bindings required --- --- Representation tycons differ from the tycon in the instance signature in --- case of instances for indexed families. --- -genInst :: DerivSpec theta - -> TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name) --- We must use continuation-returning style here to get the order in which we --- typecheck family instances and derived instances right. --- See Note [Staging of tcDeriving] -genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon - , ds_mechanism = mechanism, ds_tys = tys - , ds_cls = clas, ds_loc = loc }) - = do (meth_binds, deriv_stuff) <- genDerivStuff mechanism loc clas - rep_tycon tys tvs - let mk_inst_info theta = do - inst_spec <- newDerivClsInst theta spec - doDerivInstErrorChecks2 clas inst_spec mechanism - traceTc "newder" (ppr inst_spec) - return $ InstInfo - { iSpec = inst_spec - , iBinds = InstBindings - { ib_binds = meth_binds - , ib_tyvars = map Var.varName tvs - , ib_pragmas = [] - , ib_extensions = extensions - , ib_derived = True } } - return (mk_inst_info, deriv_stuff, unusedConName) - where - unusedConName :: Maybe Name - unusedConName - | isDerivSpecNewtype mechanism - -- See Note [Newtype deriving and unused constructors] - = Just $ getName $ head $ tyConDataCons rep_tycon - | otherwise - = Nothing - - extensions :: [LangExt.Extension] - extensions - | isDerivSpecNewtype mechanism - -- Both these flags are needed for higher-rank uses of coerce - -- See Note [Newtype-deriving instances] in TcGenDeriv - = [LangExt.ImpredicativeTypes, LangExt.RankNTypes] - | otherwise - = [] - -doDerivInstErrorChecks1 :: Class -> [Type] -> TyCon -> [Type] -> TyCon - -> DerivContext -> Bool -> DerivSpecMechanism - -> TcM () -doDerivInstErrorChecks1 cls cls_tys tc tc_args rep_tc mtheta - strat_used mechanism = do - -- For standalone deriving (mtheta /= Nothing), - -- check that all the data constructors are in scope... - rdr_env <- getGlobalRdrEnv - let data_con_names = map dataConName (tyConDataCons rep_tc) - hidden_data_cons = not (isWiredInName (tyConName rep_tc)) && - (isAbstractTyCon rep_tc || - any not_in_scope data_con_names) - not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc) - - addUsedDataCons rdr_env rep_tc - -- ...however, we don't perform this check if we're using DeriveAnyClass, - -- since it doesn't generate any code that requires use of a data - -- constructor. - unless (anyclass_strategy || isNothing mtheta || not hidden_data_cons) $ - bale_out $ derivingHiddenErr tc - where - anyclass_strategy = isDerivSpecAnyClass mechanism - - bale_out msg = failWithTc (derivingThingErrMechanism cls cls_tys - (mkTyConApp tc tc_args) strat_used mechanism msg) - -doDerivInstErrorChecks2 :: Class -> ClsInst -> DerivSpecMechanism -> TcM () -doDerivInstErrorChecks2 clas clas_inst mechanism - = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst) - ; dflags <- getDynFlags - -- Check for Generic instances that are derived with an exotic - -- deriving strategy like DAC - -- See Note [Deriving strategies] - ; when (exotic_mechanism && className clas `elem` genericClassNames) $ - do { failIfTc (safeLanguageOn dflags) gen_inst_err - ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } } - where - exotic_mechanism = case mechanism of - DerivSpecStock{} -> False - _ -> True - - gen_inst_err = hang (text ("Generic instances can only be derived in " - ++ "Safe Haskell using the stock strategy.") $+$ - text "In the following instance:") - 2 (pprInstanceHdr clas_inst) - -genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class - -> TyCon -> [Type] -> [TyVar] - -> TcM (LHsBinds RdrName, BagDerivStuff) -genDerivStuff mechanism loc clas tycon inst_tys tyvars - = case mechanism of - -- See Note [Bindings for Generalised Newtype Deriving] - DerivSpecNewtype rhs_ty -> gen_Newtype_binds loc clas tyvars - inst_tys rhs_ty - - -- Try a stock deriver - DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys - - -- If there isn't a stock deriver, our last resort is -XDeriveAnyClass - -- (since -XGeneralizedNewtypeDeriving fell through). - 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 False 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] - ) - -{- -Note [Bindings for Generalised Newtype Deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class Eq a => C a where - f :: a -> a - newtype N a = MkN [a] deriving( C ) - instance Eq (N a) where ... - -The 'deriving C' clause generates, in effect - instance (C [a], Eq a) => C (N a) where - f = coerce (f :: [a] -> [a]) - -This generates a cast for each method, but allows the superclasse to -be worked out in the usual way. In this case the superclass (Eq (N -a)) will be solved by the explicit Eq (N a) instance. We do *not* -create the superclasses by casting the superclass dictionaries for the -representation type. - -See the paper "Safe zero-cost coercions for Haskell". - -Note [DeriveAnyClass and default family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When a class has a associated type family with a default instance, e.g.: - - class C a where - type T a - type T a = Char - -then there are a couple of scenarios in which a user would expect T a to -default to Char. One is when an instance declaration for C is given without -an implementation for T: - - instance C Int - -Another scenario in which this can occur is when the -XDeriveAnyClass extension -is used: - - data Example = Example deriving (C, Generic) - -In the latter case, we must take care to check if C has any associated type -families with default instances, because -XDeriveAnyClass will never provide -an implementation for them. We "fill in" the default instances using the -tcATDefault function from TcClsDcl (which is also used in TcInstDcls to handle -the empty instance declaration case). - -Note [Deriving strategies] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC has a notion of deriving strategies, which allow the user to explicitly -request which approach to use when deriving an instance (enabled with the --XDerivingStrategies language extension). For more information, refer to the -original Trac ticket (#10598) or the associated wiki page: -https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies - -A deriving strategy can be specified in a deriving clause: - - newtype Foo = MkFoo Bar - deriving newtype C - -Or in a standalone deriving declaration: - - deriving anyclass instance C Foo - --XDerivingStrategies also allows the use of multiple deriving clauses per data -declaration so that a user can derive some instance with one deriving strategy -and other instances with another deriving strategy. For example: - - newtype Baz = Baz Quux - deriving (Eq, Ord) - deriving stock (Read, Show) - deriving newtype (Num, Floating) - deriving anyclass C - -Currently, the deriving strategies are: - -* stock: Have GHC implement a "standard" instance for a data type, if possible - (e.g., Eq, Ord, Generic, Data, Functor, etc.) - -* anyclass: Use -XDeriveAnyClass - -* newtype: Use -XGeneralizedNewtypeDeriving - -If an explicit deriving strategy is not given, GHC has an algorithm it uses to -determine which strategy it will actually use. The algorithm is quite long, -so it lives in the Haskell wiki at -https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies -("The deriving strategy resolution algorithm" section). - -Internally, GHC uses the DerivStrategy datatype to denote a user-requested -deriving strategy, and it uses the DerivSpecMechanism datatype to denote what -GHC will use to derive the instance after taking the above steps. In other -words, GHC will always settle on a DerivSpecMechnism, even if the user did not -ask for a particular DerivStrategy (using the algorithm linked to above). - -Note [Deriving instances for classes themselves] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Much of the code in TcDeriv assumes that deriving only works on data types. -But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly -reasonable to do something like this: - - {-# LANGUAGE DeriveAnyClass #-} - class C1 (a :: Constraint) where - class C2 where - deriving instance C1 C2 - -- This is equivalent to `instance C1 C2` - -If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock -deriving), we throw a special error message indicating that DeriveAnyClass is -the only way to go. We don't bother throwing this error if an explicit 'stock' -or 'newtype' keyword is used, since both options have their own perfectly -sensible error messages in the case of the above code (as C1 isn't a stock -derivable class, and C2 isn't a newtype). - -************************************************************************ -* * -\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} -* * -************************************************************************ --} - -nonUnaryErr :: LHsSigType Name -> SDoc -nonUnaryErr ct = quotes (ppr ct) - <+> text "is not a unary constraint, as expected by a deriving clause" - -nonStdErr :: Class -> SDoc -nonStdErr cls = - quotes (ppr cls) - <+> text "is not a stock derivable class (Eq, Show, etc.)" - -gndNonNewtypeErr :: SDoc -gndNonNewtypeErr = - text "GeneralizedNewtypeDeriving cannot be used on non-newtypes" - -derivingNullaryErr :: MsgDoc -derivingNullaryErr = text "Cannot derive instances for nullary classes" - -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc -derivingKindErr tc cls cls_tys cls_kind enough_args - = sep [ hang (text "Cannot derive well-kinded instance of form" - <+> quotes (pprClassPred cls cls_tys - <+> parens (ppr tc <+> text "..."))) - 2 gen1_suggestion - , nest 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind)) - ] - where - gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args - = text "(Perhaps you intended to use PolyKinds)" - | otherwise = Outputable.empty - -derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc -derivingEtaErr cls cls_tys inst_ty - = sep [text "Cannot eta-reduce to an instance of form", - nest 2 (text "instance (...) =>" - <+> pprClassPred cls (cls_tys ++ [inst_ty]))] - -derivingThingErr :: Bool -> Class -> [Type] -> Type -> Maybe DerivStrategy - -> MsgDoc -> MsgDoc -derivingThingErr newtype_deriving clas tys ty deriv_strat why - = derivingThingErr' newtype_deriving clas tys ty (isJust deriv_strat) - (maybe empty ppr deriv_strat) why - -derivingThingErrMechanism :: Class -> [Type] -> Type - -> Bool -- True if an explicit deriving strategy - -- keyword was provided - -> DerivSpecMechanism - -> MsgDoc -> MsgDoc -derivingThingErrMechanism clas tys ty strat_used mechanism why - = derivingThingErr' (isDerivSpecNewtype mechanism) clas tys ty strat_used - (ppr mechanism) why - -derivingThingErr' :: Bool -> Class -> [Type] -> Type -> Bool -> MsgDoc - -> MsgDoc -> MsgDoc -derivingThingErr' newtype_deriving clas tys ty strat_used strat_msg why - = sep [(hang (text "Can't make a derived instance of") - 2 (quotes (ppr pred) <+> via_mechanism) - $$ nest 2 extra) <> colon, - nest 2 why] - where - extra | not strat_used, newtype_deriving - = text "(even with cunning GeneralizedNewtypeDeriving)" - | otherwise = empty - pred = mkClassPred clas (tys ++ [ty]) - via_mechanism | strat_used - = text "with the" <+> strat_msg <+> text "strategy" - | otherwise - = empty - -derivingHiddenErr :: TyCon -> SDoc -derivingHiddenErr tc - = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) - 2 (text "so you cannot derive an instance for it") - -standaloneCtxt :: LHsSigType Name -> SDoc -standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") - 2 (quotes (ppr ty)) - -unboxedTyConErr :: String -> MsgDoc -unboxedTyConErr thing = - text "The last argument of the instance cannot be an unboxed" <+> text thing diff --git a/typecheck/TcDerivInfer.hs b/typecheck/TcDerivInfer.hs deleted file mode 100644 --- a/typecheck/TcDerivInfer.hs +++ /dev/null @@ -1,878 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Functions for inferring (and simplifying) the context for derived instances. --} - -{-# LANGUAGE CPP #-} - -module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where - -#include "HsVersions.h" - -import Bag -import BasicTypes -import Class -import DataCon --- import DynFlags -import ErrUtils -import Inst -import Outputable -import PrelNames -import TcDerivUtils -import TcEnv --- import TcErrors (reportAllUnsolved) -import TcGenFunctor -import TcGenGenerics -import TcMType -import TcRnMonad -import TcType -import TyCon -import Type -import TcSimplify -import TcValidity (validDerivPred) -import TcUnify (buildImplicationFor) -import Unify (tcUnifyTy) -import Util -import Var -import VarEnv -import VarSet - -import Control.Monad -import Data.List -import Data.Maybe - ----------------------- - -inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType - -> TyCon -> [TcType] -> DerivSpecMechanism - -> TcM ([ThetaOrigin], [TyVar], [TcType]) --- inferConstraints figures out the constraints needed for the --- instance declaration generated by a 'deriving' clause on a --- data type declaration. It also returns the new in-scope type --- variables and instance types, in case they were changed due to --- the presence of functor-like constraints. --- See Note [Inferring the instance context] - --- e.g. inferConstraints --- C Int (T [a]) -- Class and inst_tys --- :RTList a -- Rep tycon and its arg tys --- where T [a] ~R :RTList a --- --- Generate a sufficiently large set of constraints that typechecking the --- generated method definitions should succeed. This set will be simplified --- before being used in the instance declaration -inferConstraints tvs main_cls cls_tys inst_ty - rep_tc rep_tc_args - mechanism - | is_generic && not is_anyclass -- Generic constraints are easy - = return ([], tvs, inst_tys) - - | is_generic1 && not is_anyclass -- Generic1 needs Functor - = ASSERT( length rep_tc_tvs > 0 ) -- See Note [Getting base classes] - ASSERT( length cls_tys == 1 ) -- Generic1 has a single kind variable - do { functorClass <- tcLookupClass functorClassName - ; con_arg_constraints (get_gen1_constraints functorClass) } - - | otherwise -- The others are a bit more complicated - = -- 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 { (arg_constraints, tvs', inst_tys') <- infer_constraints - ; traceTc "inferConstraints" $ vcat - [ ppr main_cls <+> ppr inst_tys' - , ppr arg_constraints - ] - ; return (stupid_constraints ++ extra_constraints - ++ sc_constraints ++ arg_constraints - , tvs', inst_tys') } - where - is_anyclass = isDerivSpecAnyClass mechanism - infer_constraints - | is_anyclass = inferConstraintsDAC main_cls tvs inst_tys - | otherwise = con_arg_constraints get_std_constrained_tys - - tc_binders = tyConBinders rep_tc - choose_level bndr - | isNamedTyConBinder bndr = KindLevel - | otherwise = TypeLevel - t_or_ks = map choose_level tc_binders ++ repeat TypeLevel - -- want to report *kind* errors when possible - - -- Constraints arising from the arguments of each constructor - con_arg_constraints :: (CtOrigin -> TypeOrKind - -> Type - -> [([PredOrigin], Maybe TCvSubst)]) - -> TcM ([ThetaOrigin], [TyVar], [TcType]) - con_arg_constraints get_arg_constraints - = let (predss, mbSubsts) = unzip - [ preds_and_mbSubst - | data_con <- tyConDataCons rep_tc - , (arg_n, arg_t_or_k, arg_ty) - <- zip3 [1..] t_or_ks $ - dataConInstOrigArgTys data_con all_rep_tc_args - -- No constraints for unlifted types - -- See Note [Deriving and unboxed types] - , not (isUnliftedType arg_ty) - , let orig = DerivOriginDC data_con arg_n - , preds_and_mbSubst <- get_arg_constraints orig arg_t_or_k arg_ty - ] - preds = concat predss - -- If the constraints require a subtype to be of kind (* -> *) - -- (which is the case for functor-like constraints), then we - -- explicitly unify the subtype's kinds with (* -> *). - -- See Note [Inferring the instance context] - subst = foldl' composeTCvSubst - emptyTCvSubst (catMaybes mbSubsts) - unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst - && not (v `isInScope` subst)) tvs - (subst', _) = mapAccumL substTyVarBndr subst unmapped_tvs - preds' = map (substPredOrigin subst') preds - inst_tys' = substTys subst' inst_tys - tvs' = tyCoVarsOfTypesWellScoped inst_tys' - in return ([mkThetaOriginFromPreds preds'], tvs', inst_tys') - - is_generic = main_cls `hasKey` genClassKey - is_generic1 = main_cls `hasKey` gen1ClassKey - -- is_functor_like: see Note [Inferring the instance context] - is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind - || is_generic1 - - get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type - -> [([PredOrigin], Maybe TCvSubst)] - get_gen1_constraints functor_cls orig t_or_k ty - = mk_functor_like_constraints orig t_or_k functor_cls $ - get_gen1_constrained_tys last_tv ty - - get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type - -> [([PredOrigin], Maybe TCvSubst)] - get_std_constrained_tys orig t_or_k ty - | is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $ - deepSubtypesContaining last_tv ty - | otherwise = [( [mk_cls_pred orig t_or_k main_cls ty] - , Nothing )] - - mk_functor_like_constraints :: CtOrigin -> TypeOrKind - -> Class -> [Type] - -> [([PredOrigin], Maybe TCvSubst)] - -- 'cls' is usually main_cls (Functor or Traversable etc), but if - -- main_cls = Generic1, then 'cls' can be Functor; see get_gen1_constraints - -- - -- For each type, generate two constraints, [cls ty, kind(ty) ~ (*->*)], - -- and a kind substitution that results from unifying kind(ty) with * -> *. - -- If the unification is successful, it will ensure that the resulting - -- instance is well kinded. If not, the second constraint will result - -- in an error message which points out the kind mismatch. - -- See Note [Inferring the instance context] - mk_functor_like_constraints orig t_or_k cls - = map $ \ty -> let ki = typeKind ty in - ( [ mk_cls_pred orig t_or_k cls ty - , mkPredOrigin orig KindLevel - (mkPrimEqPred ki typeToTypeKind) ] - , tcUnifyTy ki typeToTypeKind - ) - - rep_tc_tvs = tyConTyVars rep_tc - last_tv = last rep_tc_tvs - -- When we first gather up the constraints to solve, most of them contain - -- rep_tc_tvs, i.e., the type variables from the derived datatype's type - -- constructor. We don't want these type variables to appear in the final - -- instance declaration, so we must substitute each type variable with its - -- counterpart in the derived instance. rep_tc_args lists each of these - -- counterpart types in the same order as the type variables. - all_rep_tc_args = rep_tc_args ++ map mkTyVarTy - (drop (length rep_tc_args) rep_tc_tvs) - - -- Constraints arising from superclasses - -- See Note [Superclasses of derived instance] - cls_tvs = classTyVars main_cls - inst_tys = cls_tys ++ [inst_ty] - sc_constraints = ASSERT2( equalLength cls_tvs inst_tys, ppr main_cls <+> ppr rep_tc) - [ mkThetaOrigin DerivOrigin TypeLevel [] [] $ - substTheta cls_subst (classSCTheta main_cls) ] - cls_subst = ASSERT( equalLength cls_tvs inst_tys ) - zipTvSubst cls_tvs inst_tys - - -- Stupid constraints - stupid_constraints = [ mkThetaOrigin DerivOrigin TypeLevel [] [] $ - substTheta tc_subst (tyConStupidTheta rep_tc) ] - tc_subst = -- See the comment with all_rep_tc_args for an explanation of - -- this assertion - ASSERT( equalLength rep_tc_tvs all_rep_tc_args ) - zipTvSubst rep_tc_tvs all_rep_tc_args - - -- Extra Data constraints - -- The Data class (only) requires that for - -- instance (...) => Data (T t1 t2) - -- IF t1:*, t2:* - -- THEN (Data t1, Data t2) are among the (...) constraints - -- Reason: when the IF holds, we generate a method - -- dataCast2 f = gcast2 f - -- and we need the Data constraints to typecheck the method - extra_constraints = [mkThetaOriginFromPreds constrs] - where - constrs - | main_cls `hasKey` dataClassKey - , all (isLiftedTypeKind . typeKind) rep_tc_args - = [ mk_cls_pred DerivOrigin t_or_k main_cls ty - | (t_or_k, ty) <- zip t_or_ks rep_tc_args] - | otherwise - = [] - - mk_cls_pred orig t_or_k cls ty -- Don't forget to apply to cls_tys' too - = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty])) - cls_tys' | is_generic1 = [] -- In the awkward Generic1 case, cls_tys' - -- should be empty, since we are applying the - -- class Functor. - | otherwise = cls_tys - -typeToTypeKind :: Kind -typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind - --- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@, --- which gathers its constraints based on the type signatures of the class's --- methods instead of the types of the data constructor's field. --- --- See Note [Gathering and simplifying constraints for DeriveAnyClass] --- for an explanation of how these constraints are used to determine the --- derived instance context. -inferConstraintsDAC :: Class -> [TyVar] -> [TcType] - -> TcM ([ThetaOrigin], [TyVar], [TcType]) -inferConstraintsDAC cls tvs inst_tys - = do { let gen_dms = [ (sel_id, dm_ty) - | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] - - ; theta_origins <- pushTcLevelM_ (mapM do_one_meth gen_dms) - -- Yuk: the pushTcLevel is to match the one wrapping the call - -- to mk_wanteds in simplifyDeriv. If we omit this, the - -- unification variables will wrongly be untouchable. - - ; return (theta_origins, tvs, inst_tys) } - where - cls_tvs = classTyVars cls - empty_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tvs)) - - do_one_meth :: (Id, Type) -> TcM ThetaOrigin - -- (Id,Type) are the selector Id and the generic default method type - -- NB: the latter is /not/ quantified over the class variables - -- See Note [Gathering and simplifying constraints for DeriveAnyClass] - do_one_meth (sel_id, gen_dm_ty) - = do { let (sel_tvs, _cls_pred, meth_ty) = tcSplitMethodTy (varType sel_id) - meth_ty' = substTyWith sel_tvs inst_tys meth_ty - (meth_tvs, meth_theta, meth_tau) = tcSplitNestedSigmaTys meth_ty' - - gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty - (dm_tvs, dm_theta, dm_tau) = tcSplitNestedSigmaTys gen_dm_ty' - - ; (subst, _meta_tvs) <- pushTcLevelM_ $ - newMetaTyVarsX empty_subst dm_tvs - -- Yuk: the pushTcLevel is to match the one in mk_wanteds - -- simplifyDeriv. If we don't, the unification variables - -- will bogusly be untouchable. - ; let dm_theta' = substTheta subst dm_theta - tau_eq = mkPrimEqPred meth_tau (substTy subst dm_tau) - ; return (mkThetaOrigin DerivOrigin TypeLevel - meth_tvs meth_theta (tau_eq:dm_theta')) } - -{- Note [Inferring the instance context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are two sorts of 'deriving': - - * InferTheta: the deriving clause for a data type - data T a = T1 a deriving( Eq ) - Here we must infer an instance context, - and generate instance declaration - instance Eq a => Eq (T a) where ... - - * CheckTheta: standalone deriving - deriving instance Eq a => Eq (T a) - Here we only need to fill in the bindings; - the instance context is user-supplied - -For a deriving clause (InferTheta) we must figure out the -instance context (inferConstraints). Suppose we are inferring -the instance context for - C t1 .. tn (T s1 .. sm) -There are two cases - - * (T s1 .. sm) :: * (the normal case) - Then we behave like Eq and guess (C t1 .. tn t) - for each data constructor arg of type t. More - details below. - - * (T s1 .. sm) :: * -> * (the functor-like case) - Then we behave like Functor. - -In both cases we produce a bunch of un-simplified constraints -and them simplify them in simplifyInstanceContexts; see -Note [Simplifying the instance context]. - -In the functor-like case, we may need to unify some kind variables with * in -order for the generated instance to be well-kinded. An example from -Trac #10524: - - newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) - = Compose (f (g a)) deriving Functor - -Earlier in the deriving pipeline, GHC unifies the kind of Compose f g -(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this -alone isn't enough, since k2 wasn't unified with *: - - instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) => - Functor (Compose f g) where ... - -The two Functor constraints are ill-kinded. To ensure this doesn't happen, we: - - 1. Collect all of a datatype's subtypes which require functor-like - constraints. - 2. For each subtype, create a substitution by unifying the subtype's kind - with (* -> *). - 3. Compose all the substitutions into one, then apply that substitution to - all of the in-scope type variables and the instance types. - -Note [Getting base classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Functor and Typeable are defined in package 'base', and that is not available -when compiling 'ghc-prim'. So we must be careful that 'deriving' for stuff in -ghc-prim does not use Functor or Typeable implicitly via these lookups. - -Note [Deriving and unboxed types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have some special hacks to support things like - data T = MkT Int# deriving ( Show ) - -Specifically, we use TcGenDeriv.box to box the Int# into an Int -(which we know how to show), and append a '#'. Parenthesis are not required -for unboxed values (`MkT -3#` is a valid expression). - -Note [Superclasses of derived instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, a derived instance decl needs the superclasses of the derived -class too. So if we have - data T a = ...deriving( Ord ) -then the initial context for Ord (T a) should include Eq (T a). Often this is -redundant; we'll also generate an Ord constraint for each constructor argument, -and that will probably generate enough constraints to make the Eq (T a) constraint -be satisfied too. But not always; consider: - - data S a = S - instance Eq (S a) - instance Ord (S a) - - data T a = MkT (S a) deriving( Ord ) - instance Num a => Eq (T a) - -The derived instance for (Ord (T a)) must have a (Num a) constraint! -Similarly consider: - data T a = MkT deriving( Data ) -Here there *is* no argument field, but we must nevertheless generate -a context for the Data instances: - instance Typeable a => Data (T a) where ... - - -************************************************************************ -* * - Finding the fixed point of deriving equations -* * -************************************************************************ - -Note [Simplifying the instance context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T a b = C1 (Foo a) (Bar b) - | C2 Int (T b a) - | C3 (T a a) - deriving (Eq) - -We want to come up with an instance declaration of the form - - instance (Ping a, Pong b, ...) => Eq (T a b) where - x == y = ... - -It is pretty easy, albeit tedious, to fill in the code "...". The -trick is to figure out what the context for the instance decl is, -namely Ping, Pong and friends. - -Let's call the context reqd for the T instance of class C at types -(a,b, ...) C (T a b). Thus: - - Eq (T a b) = (Ping a, Pong b, ...) - -Now we can get a (recursive) equation from the data decl. This part -is done by inferConstraints. - - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - -Foo and Bar may have explicit instances for Eq, in which case we can -just substitute for them. Alternatively, either or both may have -their Eq instances given by deriving clauses, in which case they -form part of the system of equations. - -Now all we need do is simplify and solve the equations, iterating to -find the least fixpoint. This is done by simplifyInstanceConstraints. -Notice that the order of the arguments can -switch around, as here in the recursive calls to T. - -Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b. - -We start with: - - Eq (T a b) = {} -- The empty set - -Next iteration: - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - After simplification: - = Eq a u Ping b u {} u {} u {} - = Eq a u Ping b - -Next iteration: - - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - After simplification: - = Eq a u Ping b - u (Eq b u Ping a) - u (Eq a u Ping a) - - = Eq a u Ping b u Eq b u Ping a - -The next iteration gives the same result, so this is the fixpoint. We -need to make a canonical form of the RHS to ensure convergence. We do -this by simplifying the RHS to a form in which - - - the classes constrain only tyvars - - the list is sorted by tyvar (major key) and then class (minor key) - - no duplicates, of course - -Note [Deterministic simplifyInstanceContexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting -with nonDetCmpType puts the returned lists in a nondeterministic order. -If we were to return them, we'd get class constraints in -nondeterministic order. - -Consider: - - data ADT a b = Z a b deriving Eq - -The generated code could be either: - - instance (Eq a, Eq b) => Eq (Z a b) where - -Or: - - instance (Eq b, Eq a) => Eq (Z a b) where - -To prevent the order from being nondeterministic we only -canonicalize when comparing and return them in the same order as -simplifyDeriv returned them. -See also Note [nonDetCmpType nondeterminism] --} - - -simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]] - -> TcM [DerivSpec ThetaType] --- Used only for deriving clauses (InferTheta) --- not for standalone deriving --- See Note [Simplifying the instance context] - -simplifyInstanceContexts [] = return [] - -simplifyInstanceContexts infer_specs - = do { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs) - ; iterate_deriv 1 initial_solutions } - where - ------------------------------------------------------------------ - -- The initial solutions for the equations claim that each - -- instance has an empty context; this solution is certainly - -- in canonical form. - initial_solutions :: [ThetaType] - initial_solutions = [ [] | _ <- infer_specs ] - - ------------------------------------------------------------------ - -- iterate_deriv calculates the next batch of solutions, - -- compares it with the current one; finishes if they are the - -- same, otherwise recurses with the new solutions. - -- It fails if any iteration fails - iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType] - iterate_deriv n current_solns - | n > 20 -- Looks as if we are in an infinite loop - -- This can happen if we have -XUndecidableInstances - -- (See TcSimplify.tcSimplifyDeriv.) - = pprPanic "solveDerivEqns: probable loop" - (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns) - | otherwise - = do { -- Extend the inst info from the explicit instance decls - -- with the current set of solutions, and simplify each RHS - inst_specs <- zipWithM newDerivClsInst current_solns infer_specs - ; new_solns <- checkNoErrs $ - extendLocalInstEnv inst_specs $ - mapM gen_soln infer_specs - - ; if (current_solns `eqSolution` new_solns) then - return [ spec { ds_theta = soln } - | (spec, soln) <- zip infer_specs current_solns ] - else - iterate_deriv (n+1) new_solns } - - eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b) - -- Canonicalise for comparison - -- See Note [Deterministic simplifyInstanceContexts] - canSolution = map (sortBy nonDetCmpType) - ------------------------------------------------------------------ - gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType - gen_soln (DS { ds_loc = loc, ds_tvs = tyvars - , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) - = setSrcSpan loc $ - addErrCtxt (derivInstCtxt the_pred) $ - do { theta <- simplifyDeriv the_pred tyvars deriv_rhs - -- checkValidInstance tyvars theta clas inst_tys - -- Not necessary; see Note [Exotic derived instance contexts] - - ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta) - -- Claim: the result instance declaration is guaranteed valid - -- Hence no need to call: - -- checkValidInstance tyvars theta clas inst_tys - ; return theta } - where - the_pred = mkClassPred clas inst_tys - -derivInstCtxt :: PredType -> MsgDoc -derivInstCtxt pred - = text "When deriving the instance for" <+> parens (ppr pred) - -{- -*********************************************************************************** -* * -* Simplify derived constraints -* * -*********************************************************************************** --} - --- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much --- as possible. Fail if not possible. -simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are - -- deriving. Only used for SkolemInfo. - -> [TyVar] -- ^ The tyvars bound by @inst_ty@. - -> [ThetaOrigin] -- ^ Given and wanted constraints - -> TcM ThetaType -- ^ Needed constraints (after simplification), - -- i.e. @['PredType']@. -simplifyDeriv pred tvs thetas - = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize - -- The constraint solving machinery - -- expects *TcTyVars* not TyVars. - -- We use *non-overlappable* (vanilla) skolems - -- See Note [Overlap and deriving] - - ; let skol_set = mkVarSet tvs_skols - skol_info = DerivSkol pred - doc = text "deriving" <+> parens (ppr pred) - - mk_given_ev :: PredType -> TcM EvVar - mk_given_ev given = - let given_pred = substTy skol_subst given - in newEvVar given_pred - - mk_wanted_ct :: PredOrigin -> TcM CtEvidence - mk_wanted_ct (PredOrigin wanted o t_or_k) - = newWanted o (Just t_or_k) (substTyUnchecked skol_subst wanted) - - -- 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_tvs = local_skols - , to_givens = givens - , to_wanted_origins = wanteds }) - | null local_skols, null givens - = do { wanted_cts <- mapM mk_wanted_ct wanteds - ; return (mkSimpleWC wanted_cts) } - | otherwise - = do { given_evs <- mapM mk_given_ev givens - ; (wanted_cts, tclvl) <- pushTcLevelM $ - mapM mk_wanted_ct wanteds - ; (implic, _) <- buildImplicationFor tclvl skol_info local_skols - given_evs (mkSimpleWC wanted_cts) - ; pure (mkImplicWC implic) } - - -- See [STEP DAC BUILD] - -- Generate the implication constraints constraints to solve with the - -- skolemized variables - ; (wanteds, tclvl) <- pushTcLevelM $ mapM mk_wanteds thetas - - ; traceTc "simplifyDeriv inputs" $ - vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ] - - -- See [STEP DAC SOLVE] - -- Simplify the constraints - ; solved_implics <- runTcSDeriveds $ solveWantedsAndDrop - $ unionsWC wanteds - -- It's not yet zonked! Obviously zonk it before peering at it - ; solved_implics <- zonkWC solved_implics - - -- See [STEP DAC HOIST] - -- Split the resulting constraints into bad and good constraints, - -- building an @unsolved :: WantedConstraints@ representing all - -- the constraints we can't just shunt to the predicates. - -- See Note [Exotic derived instance contexts] - ; let residual_simple = approximateWC True solved_implics - (bad, good) = partitionBagWith get_good residual_simple - - get_good :: Ct -> Either Ct PredType - get_good ct | validDerivPred skol_set p - , isWantedCt ct - = Right p - -- TODO: This is wrong - -- NB re 'isWantedCt': residual_wanted may contain - -- unsolved CtDerived and we stick them into the - -- bad set so that reportUnsolved may decide what - -- to do with them - | otherwise - = Left ct - where p = ctPred ct - - ; traceTc "simplifyDeriv outputs" $ - vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ] - - -- Return the good unsolved constraints (unskolemizing on the way out.) - ; let min_theta = mkMinimalBySCs (bagToList good) - -- An important property of mkMinimalBySCs (used above) is that in - -- addition to removing constraints that are made redundant by - -- superclass relationships, it also removes _duplicate_ - -- constraints. - -- See Note [Gathering and simplifying constraints for - -- DeriveAnyClass] - subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs - -- The reverse substitution (sigh) - - -- See [STEP DAC RESIDUAL] - ; min_theta_vars <- mapM newEvVar min_theta - ; (leftover_implic, _) <- buildImplicationFor tclvl skol_info tvs_skols - min_theta_vars solved_implics - -- This call to simplifyTop is purely for error reporting - -- See Note [Error reporting for deriving clauses] - -- See also Note [Exotic derived instance contexts], which are caught - -- in this line of code. - ; simplifyTopImplic leftover_implic - - ; return (substTheta subst_skol min_theta) } - -{- -Note [Overlap and deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider some overlapping instances: - data Show a => Show [a] where .. - data Show [Char] where ... - -Now a data type with deriving: - data T a = MkT [a] deriving( Show ) - -We want to get the derived instance - instance Show [a] => Show (T a) where... -and NOT - instance Show a => Show (T a) where... -so that the (Show (T Char)) instance does the Right Thing - -It's very like the situation when we're inferring the type -of a function - f x = show [x] -and we want to infer - f :: Show [a] => a -> String - -BOTTOM LINE: use vanilla, non-overlappable skolems when inferring - the context for the derived instance. - Hence tcInstSkolTyVars not tcInstSuperSkolTyVars - -Note [Gathering and simplifying constraints for DeriveAnyClass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -DeriveAnyClass works quite differently from stock and newtype deriving in -the way it gathers and simplifies constraints to be used in a derived -instance's context. Stock and newtype deriving gather constraints by looking -at the data constructors of the data type for which we are deriving an -instance. But DeriveAnyClass doesn't need to know about a data type's -definition at all! - -To see why, consider this example of DeriveAnyClass: - - class Foo a where - bar :: forall b. Ix b => a -> b -> String - default bar :: (Show a, Ix c) => a -> c -> String - bar x y = show x ++ show (range (y,y)) - - baz :: Eq a => a -> a -> Bool - default baz :: (Ord a, Show a) => a -> a -> Bool - baz x y = compare x y == EQ - -Because 'bar' and 'baz' have default signatures, this generates a top-level -definition for these generic default methods - - $gdm_bar :: forall a. Foo a - => forall c. (Show a, Ix c) - => a -> c -> String - $gdm_bar x y = show x ++ show (range (y,y)) - -(and similarly for baz). Now consider a 'deriving' clause - data Maybe s = ... deriving Foo - -This derives an instance of the form: - instance (CX) => Foo (Maybe s) where - bar = $gdm_bar - baz = $gdm_baz - -Now it is GHC's job to fill in a suitable instance context (CX). If -GHC were typechecking the binding - bar = $gdm bar -it would - * skolemise the expected type of bar - * instantiate the type of $dm_bar with meta-type variables - * build an implication constraint - -[STEP DAC BUILD] -So that's what we do. We build the constraint (call it C1) - - forall b. Ix b => (Show (Maybe s), Ix cc, - Maybe s -> b -> String - ~ Maybe s -> cc -> String) - -The 'cc' is a unification variable that comes from instantiating -$dm_bar's type. The equality constraint comes from marrying up -the instantiated type of $dm_bar with the specified type of bar. -Notice that the type variables from the instance, 's' in this case, -are global to this constraint. - -Similarly for 'baz', givng the constraint C2 - - forall. Eq (Maybe s) => (Ord a, Show a, - Maybe s -> Maybe s -> Bool - ~ Maybe s -> Maybe s -> Bool) - -In this case baz has no local quantification, so the implication -constraint has no local skolems and there are no unificaiton -variables. - -[STEP DAC SOLVE] -We can combine these two implication constraints into a single -constraint (C1, C2), and simplify, unifying cc:=b, to get: - - forall b. Ix b => Show a - /\ - forall. Eq (Maybe s) => (Ord a, Show a) - -[STEP DAC HOIST] -Let's call that (C1', C2'). Now we need to hoist the unsolved -constraints out of the implications to become our candidate for -(CX). That is done by approximateWC, which will return: - - (Show a, Ord a, Show a) - -Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving - - (Show a, Ord a) - -And that's what GHC uses for CX. - -[STEP DAC RESIDUAL] -In this case we have solved all the leftover constraints, but what if -we don't? Simple! We just form the final residual constraint - - forall s. CX => (C1',C2') - -and simplify that. In simple cases it'll succeed easily, because CX -literally contains the constraints in C1', C2', but if there is anything -more complicated it will be reported in a civilised way. - -Note [Error reporting for deriving clauses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A suprisingly tricky aspect of deriving to get right is reporting sensible -error messages. In particular, if simplifyDeriv reaches a constraint that it -cannot solve, which might include: - -1. Insoluble constraints -2. "Exotic" constraints (See Note [Exotic derived instance contexts]) - -Then we report an error immediately in simplifyDeriv. - -Another possible choice is to punt and let another part of the typechecker -(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead -to worse error messages, so we do it directly in simplifyDeriv. - -simplifyDeriv checks for errors in a clever way. If the deriving machinery -infers the context (Foo a)--that is, if this instance is to be generated: - - instance Foo a => ... - -Then we form an implication of the form: - - forall a. Foo a => - -And pass it to the simplifier. If the context (Foo a) is enough to discharge -all the constraints in , then everything is -hunky-dory. But if contains, say, an insoluble -constraint, then (Foo a) won't be able to solve it, causing GHC to error. - -Note [Exotic derived instance contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a 'derived' instance declaration, we *infer* the context. It's a -bit unclear what rules we should apply for this; the Haskell report is -silent. Obviously, constraints like (Eq a) are fine, but what about - data T f a = MkT (f a) deriving( Eq ) -where we'd get an Eq (f a) constraint. That's probably fine too. - -One could go further: consider - data T a b c = MkT (Foo a b c) deriving( Eq ) - instance (C Int a, Eq b, Eq c) => Eq (Foo a b c) - -Notice that this instance (just) satisfies the Paterson termination -conditions. Then we *could* derive an instance decl like this: - - instance (C Int a, Eq b, Eq c) => Eq (T a b c) -even though there is no instance for (C Int a), because there just -*might* be an instance for, say, (C Int Bool) at a site where we -need the equality instance for T's. - -However, this seems pretty exotic, and it's quite tricky to allow -this, and yet give sensible error messages in the (much more common) -case where we really want that instance decl for C. - -So for now we simply require that the derived instance context -should have only type-variable constraints. - -Here is another example: - data Fix f = In (f (Fix f)) deriving( Eq ) -Here, if we are prepared to allow -XUndecidableInstances we -could derive the instance - instance Eq (f (Fix f)) => Eq (Fix f) -but this is so delicate that I don't think it should happen inside -'deriving'. If you want this, write it yourself! - -NB: if you want to lift this condition, make sure you still meet the -termination conditions! If not, the deriving mechanism generates -larger and larger constraints. Example: - data Succ a = S a - data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show - -Note the lack of a Show instance for Succ. First we'll generate - instance (Show (Succ a), Show a) => Show (Seq a) -and then - instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) -and so on. Instead we want to complain of no instance for (Show (Succ a)). - -The bottom line -~~~~~~~~~~~~~~~ -Allow constraints which consist only of type variables, with no repeats. --} diff --git a/typecheck/TcDerivUtils.hs b/typecheck/TcDerivUtils.hs deleted file mode 100644 --- a/typecheck/TcDerivUtils.hs +++ /dev/null @@ -1,669 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Error-checking and other utilities for @deriving@ clauses or declarations. --} - -{-# LANGUAGE ImplicitParams #-} - -module TcDerivUtils ( - DerivSpec(..), pprDerivSpec, - DerivSpecMechanism(..), isDerivSpecStock, - isDerivSpecNewtype, isDerivSpecAnyClass, - DerivContext, DerivStatus(..), - PredOrigin(..), ThetaOrigin(..), mkPredOrigin, - mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin, - checkSideConditions, hasStockDeriving, - canDeriveAnyClass, - std_class_via_coercible, non_coercible_class, - newDerivClsInst, extendLocalInstEnv - ) where - -import Bag -import BasicTypes -import Class -import DataCon -import DynFlags -import ErrUtils -import HscTypes (lookupFixity, mi_fix) -import HsSyn -import Inst -import InstEnv -import LoadIface (loadInterfaceForName) -import Module (getModule) -import Name -import Outputable -import PrelNames -import RdrName -import SrcLoc -import TcGenDeriv -import TcGenFunctor -import TcGenGenerics -import TcRnMonad -import TcType -import THNames (liftClassKey) -import TyCon -import Type -import Util -import VarSet - -import qualified GHC.LanguageExtensions as LangExt -import ListSetOps (assocMaybe) - -data DerivSpec theta = DS { ds_loc :: SrcSpan - , ds_name :: Name -- DFun name - , ds_tvs :: [TyVar] - , ds_theta :: theta - , ds_cls :: Class - , ds_tys :: [Type] - , ds_tc :: TyCon - , ds_overlap :: Maybe OverlapMode - , ds_mechanism :: DerivSpecMechanism } - -- This spec implies a dfun declaration of the form - -- df :: forall tvs. theta => C tys - -- The Name is the name for the DFun we'll build - -- The tyvars bind all the variables in the theta - -- For type families, the tycon in - -- in ds_tys is the *family* tycon - -- in ds_tc is the *representation* type - -- For non-family tycons, both are the same - - -- the theta is either the given and final theta, in standalone deriving, - -- or the not-yet-simplified list of constraints together with their origin - - -- ds_mechanism specifies the means by which GHC derives the instance. - -- See Note [Deriving strategies] in TcDeriv - -{- -Example: - - newtype instance T [a] = MkT (Tree a) deriving( C s ) -==> - axiom T [a] = :RTList a - axiom :RTList a = Tree a - - DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]] - , ds_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) } --} - -pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc -pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c, - ds_tys = tys, ds_theta = rhs, ds_mechanism = mech }) - = hang (text "DerivSpec") - 2 (vcat [ text "ds_loc =" <+> ppr l - , text "ds_name =" <+> ppr n - , text "ds_tvs =" <+> ppr tvs - , text "ds_cls =" <+> ppr c - , text "ds_tys =" <+> ppr tys - , text "ds_theta =" <+> ppr rhs - , text "ds_mechanism =" <+> ppr mech ]) - -instance Outputable theta => Outputable (DerivSpec theta) where - ppr = pprDerivSpec - --- What action to take in order to derive a class instance. --- See Note [Deriving strategies] in TcDeriv --- NB: DerivSpecMechanism is purely local to this module -data DerivSpecMechanism - = DerivSpecStock -- "Standard" classes - (SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds RdrName, BagDerivStuff)) - - | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving - Type -- ^ The newtype rep type - - | DerivSpecAnyClass -- -XDeriveAnyClass - -isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass - :: DerivSpecMechanism -> Bool -isDerivSpecStock (DerivSpecStock{}) = True -isDerivSpecStock _ = False - -isDerivSpecNewtype (DerivSpecNewtype{}) = True -isDerivSpecNewtype _ = False - -isDerivSpecAnyClass (DerivSpecAnyClass{}) = True -isDerivSpecAnyClass _ = False - --- A DerivSpecMechanism can be losslessly converted to a DerivStrategy. -mechanismToStrategy :: DerivSpecMechanism -> DerivStrategy -mechanismToStrategy (DerivSpecStock{}) = StockStrategy -mechanismToStrategy (DerivSpecNewtype{}) = NewtypeStrategy -mechanismToStrategy (DerivSpecAnyClass{}) = AnyclassStrategy - -instance Outputable DerivSpecMechanism where - ppr = ppr . mechanismToStrategy - -type DerivContext = Maybe ThetaType - -- Nothing <=> Vanilla deriving; infer the context of the instance decl - -- Just theta <=> Standalone deriving: context supplied by programmer - -data DerivStatus = CanDerive -- Stock class, can derive - | DerivableClassError SDoc -- Stock class, but can't do it - | DerivableViaInstance -- See Note [Deriving any class] - | NonDerivableClass SDoc -- Non-stock class - --- A stock class is one either defined in the Haskell report or for which GHC --- otherwise knows how to generate code for (possibly requiring the use of a --- language extension), such as Eq, Ord, Ix, Data, Generic, etc. - --- | A 'PredType' annotated with the origin of the constraint 'CtOrigin', --- and whether or the constraint deals in types or kinds. -data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind - --- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') alongside --- any corresponding given constraints ('to_givens') and locally quantified --- type variables ('to_tvs'). --- --- In most cases, 'to_givens' will be empty, as most deriving mechanisms (e.g., --- stock and newtype deriving) do not require given constraints. The exception --- is @DeriveAnyClass@, which can involve given constraints. For example, --- if you tried to derive an instance for the following class using --- @DeriveAnyClass@: --- --- @ --- class Foo a where --- bar :: a -> b -> String --- default bar :: (Show a, Ix b) => a -> b -> String --- bar = show --- --- baz :: Eq a => a -> a -> Bool --- default baz :: Ord a => a -> a -> Bool --- baz x y = compare x y == EQ --- @ --- --- Then it would generate two 'ThetaOrigin's, one for each method: --- --- @ --- [ ThetaOrigin { to_tvs = [b] --- , to_givens = [] --- , to_wanted_origins = [Show a, Ix b] } --- , ThetaOrigin { to_tvs = [] --- , to_givens = [Eq a] --- , to_wanted_origins = [Ord a] } --- ] --- @ -data ThetaOrigin - = ThetaOrigin { to_tvs :: [TyVar] - , to_givens :: ThetaType - , to_wanted_origins :: [PredOrigin] } - -instance Outputable PredOrigin where - ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging - -instance Outputable ThetaOrigin where - ppr (ThetaOrigin { to_tvs = tvs - , to_givens = givens - , to_wanted_origins = wanted_origins }) - = hang (text "ThetaOrigin") - 2 (vcat [ text "to_tvs =" <+> ppr tvs - , text "to_givens =" <+> ppr givens - , text "to_wanted_origins =" <+> ppr wanted_origins ]) - -mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin -mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k - -mkThetaOrigin :: CtOrigin -> TypeOrKind -> [TyVar] -> ThetaType -> ThetaType - -> ThetaOrigin -mkThetaOrigin origin t_or_k tvs givens - = ThetaOrigin tvs givens . map (mkPredOrigin origin t_or_k) - --- A common case where the ThetaOrigin only contains wanted constraints, with --- no givens or locally scoped type variables. -mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin -mkThetaOriginFromPreds = ThetaOrigin [] [] - -substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin -substPredOrigin subst (PredOrigin pred origin t_or_k) - = PredOrigin (substTy subst pred) origin t_or_k - -{- -************************************************************************ -* * - Class deriving diagnostics -* * -************************************************************************ - -Only certain blessed classes can be used in a deriving clause (without the -assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes -are listed below in the definition of hasStockDeriving. The sideConditions -function determines the criteria that needs to be met in order for a particular -class to be able to be derived successfully. - -A class might be able to be used in a deriving clause if -XDeriveAnyClass -is willing to support it. The canDeriveAnyClass function checks if this is the -case. --} - -hasStockDeriving :: Class - -> Maybe (SrcSpan - -> TyCon - -> [Type] - -> TcM (LHsBinds RdrName, BagDerivStuff)) -hasStockDeriving clas - = assocMaybe gen_list (getUnique clas) - where - gen_list :: [(Unique, SrcSpan - -> TyCon - -> [Type] - -> TcM (LHsBinds RdrName, BagDerivStuff))] - 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, with_fix_env gen_Show_binds) - , (readClassKey, with_fix_env gen_Read_binds) - , (dataClassKey, simpleM gen_Data_binds) - , (functorClassKey, simple gen_Functor_binds) - , (foldableClassKey, simple gen_Foldable_binds) - , (traversableClassKey, simple gen_Traversable_binds) - , (liftClassKey, simple gen_Lift_binds) - , (genClassKey, generic (gen_Generic_binds Gen0)) - , (gen1ClassKey, generic (gen_Generic_binds Gen1)) ] - - simple gen_fn loc tc _ - = return (gen_fn loc tc) - - simpleM gen_fn loc tc _ - = gen_fn loc tc - - with_fix_env gen_fn loc tc _ - = do { fix_env <- getDataConFixityFun tc - ; return (gen_fn fix_env loc tc) } - - generic gen_fn _ tc inst_tys - = do { (binds, faminst) <- gen_fn tc inst_tys - ; return (binds, unitBag (DerivFamInst faminst)) } - -getDataConFixityFun :: TyCon -> TcM (Name -> Fixity) --- If the TyCon is locally defined, we want the local fixity env; --- but if it is imported (which happens for standalone deriving) --- we need to get the fixity env from the interface file --- c.f. RnEnv.lookupFixity, and Trac #9830 -getDataConFixityFun tc - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod name - then do { fix_env <- getFixityEnv - ; return (lookupFixity fix_env) } - else do { iface <- loadInterfaceForName doc name - -- Should already be loaded! - ; return (mi_fix iface . nameOccName) } } - where - name = tyConName tc - doc = text "Data con fixities for" <+> ppr name - ------------------------------------------------------------------- --- Check side conditions that dis-allow derivability for particular classes --- This is *apart* from the newtype-deriving mechanism --- --- Here we get the representation tycon in case of family instances as it has --- the data constructors - but we need to be careful to fall back to the --- family tycon (with indexes) in error messages. - -checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] - -> TyCon -- tycon - -> DerivStatus -checkSideConditions dflags mtheta cls cls_tys rep_tc - | Just cond <- sideConditions mtheta cls - = case (cond dflags rep_tc) of - NotValid err -> DerivableClassError err -- Class-specific error - IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys) - -> CanDerive - -- 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. - | otherwise -> DerivableClassError (classArgsErr cls cls_tys) - -- e.g. deriving( Eq s ) - - | NotValid err <- canDeriveAnyClass dflags - = NonDerivableClass err -- DeriveAnyClass does not work - - | otherwise - = DerivableViaInstance -- DeriveAnyClass should work - -classArgsErr :: Class -> [Type] -> SDoc -classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class" - --- Side conditions (whether the datatype must have at least one constructor, --- required language extensions, etc.) for using GHC's stock deriving --- mechanism on certain classes (as opposed to classes that require --- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a --- class for which stock deriving isn't possible. -sideConditions :: DerivContext -> Class -> Maybe Condition -sideConditions mtheta cls - | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration) - | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) - | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) - | cls_key == dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond` - cond_std `andCond` - cond_args cls) - | cls_key == functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond` - cond_vanilla `andCond` - cond_functorOK True False) - | cls_key == foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond` - cond_vanilla `andCond` - cond_functorOK False True) - -- Functor/Fold/Trav works ok - -- for rank-n types - | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond` - cond_vanilla `andCond` - cond_functorOK False False) - | cls_key == genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` - cond_vanilla `andCond` - cond_RepresentableOk) - | cls_key == gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` - cond_vanilla `andCond` - cond_Representable1Ok) - | cls_key == liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond` - cond_vanilla `andCond` - cond_args cls) - | otherwise = Nothing - where - cls_key = getUnique cls - cond_std = cond_stdOK mtheta False -- Vanilla data constructors, at least one, - -- and monotype arguments - cond_vanilla = cond_stdOK mtheta 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 -> Validity - -- TyCon is the *representation* tycon if the data type is an indexed one - -- Nothing => OK - -orCond :: Condition -> Condition -> Condition -orCond c1 c2 dflags tc - = case (c1 dflags tc, c2 dflags tc) of - (IsValid, _) -> IsValid -- c1 succeeds - (_, IsValid) -> IsValid -- c21 succeeds - (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y) - -- Both fail - -andCond :: Condition -> Condition -> Condition -andCond c1 c2 dflags tc = c1 dflags tc `andValid` c2 dflags tc - -cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not; - -- if standalone, we just say "yes, go for it" - -> Bool -- True <=> permissive: allow higher rank - -- args and no data constructors - -> Condition -cond_stdOK (Just _) _ _ _ - = IsValid -- Don't check these conservative conditions for - -- standalone deriving; just generate the code - -- and let the typechecker handle the result -cond_stdOK Nothing permissive _ rep_tc - | null data_cons - , not permissive = NotValid (no_cons_why rep_tc $$ suggestion) - | not (null con_whys) = NotValid (vcat con_whys $$ suggestion) - | otherwise = IsValid - where - suggestion = text "Possible fix: use a standalone deriving declaration instead" - data_cons = tyConDataCons rep_tc - con_whys = getInvalids (map check_con data_cons) - - check_con :: DataCon -> Validity - check_con con - | not (null eq_spec) - = bad "is a GADT" - | not (null ex_tvs) - = bad "has existential type variables in its type" - | not (null theta) - = bad "has constraints in its type" - | not (permissive || all isTauTy (dataConOrigArgTys con)) - = bad "has a higher-rank type" - | otherwise - = IsValid - where - (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con - bad msg = NotValid (badCon con (text msg)) - -no_cons_why :: TyCon -> SDoc -no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> - text "must have at least one data constructor" - -cond_RepresentableOk :: Condition -cond_RepresentableOk _ tc = canDoGenerics tc - -cond_Representable1Ok :: Condition -cond_Representable1Ok _ tc = canDoGenerics1 tc - -cond_enumOrProduct :: Class -> Condition -cond_enumOrProduct cls = cond_isEnumeration `orCond` - (cond_isProduct `andCond` cond_args cls) - -cond_args :: Class -> Condition --- For some classes (eg Eq, Ord) we allow unlifted arg types --- by generating specialised code. For others (eg Data) we don't. -cond_args cls _ tc - = case bad_args of - [] -> IsValid - (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls)) - 2 (text "for type" <+> quotes (ppr ty))) - where - bad_args = [ arg_ty | con <- tyConDataCons tc - , arg_ty <- dataConOrigArgTys con - , isUnliftedType arg_ty - , not (ok_ty arg_ty) ] - - cls_key = classKey cls - ok_ty arg_ty - | cls_key == eqClassKey = check_in arg_ty ordOpTbl - | cls_key == ordClassKey = check_in arg_ty ordOpTbl - | cls_key == showClassKey = check_in arg_ty boxConTbl - | cls_key == liftClassKey = check_in arg_ty litConTbl - | otherwise = False -- Read, Ix etc - - check_in :: Type -> [(Type,a)] -> Bool - check_in arg_ty tbl = any (eqType arg_ty . fst) tbl - - -cond_isEnumeration :: Condition -cond_isEnumeration _ rep_tc - | isEnumerationTyCon rep_tc = IsValid - | otherwise = NotValid why - where - why = sep [ quotes (pprSourceTyCon rep_tc) <+> - text "must be an enumeration type" - , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ] - -- See Note [Enumeration types] in TyCon - -cond_isProduct :: Condition -cond_isProduct _ rep_tc - | isProductTyCon rep_tc = IsValid - | otherwise = NotValid why - where - why = quotes (pprSourceTyCon rep_tc) <+> - text "must have precisely one constructor" - -cond_functorOK :: Bool -> Bool -> Condition --- OK for Functor/Foldable/Traversable class --- Currently: (a) at least one argument --- (b) don't use argument contravariantly --- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) --- (d) optionally: don't use function types --- (e) no "stupid context" on data type -cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc - | null tc_tvs - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters") - - | not (null bad_stupid_theta) - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) - - | otherwise - = allValid (map check_con data_cons) - where - tc_tvs = tyConTyVars rep_tc - Just (_, last_tv) = snocView tc_tvs - bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) - is_bad pred = last_tv `elemVarSet` tyCoVarsOfType pred - - data_cons = tyConDataCons rep_tc - check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) - - check_universal :: DataCon -> Validity - check_universal con - | allowExQuantifiedLastTyVar - = IsValid -- See Note [DeriveFoldable with ExistentialQuantification] - -- in TcGenFunctor - | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) - , tv `elem` dataConUnivTyVars con - , not (tv `elemVarSet` tyCoVarsOfTypes (dataConTheta con)) - = IsValid -- See Note [Check that the type variable is truly universal] - | otherwise - = NotValid (badCon con existential) - - ft_check :: DataCon -> FFoldType Validity - ft_check con = FT { ft_triv = IsValid, ft_var = IsValid - , ft_co_var = NotValid (badCon con covariant) - , ft_fun = \x y -> if allowFunctions then x `andValid` y - else NotValid (badCon con functions) - , ft_tup = \_ xs -> allValid xs - , ft_ty_app = \_ x -> x - , ft_bad_app = NotValid (badCon con wrong_arg) - , ft_forall = \_ x -> x } - - existential = text "must be truly polymorphic in the last argument of the data type" - covariant = text "must not use the type variable in a function argument" - functions = text "must not contain function types" - wrong_arg = text "must use the type variable only as the last argument of a data type" - -checkFlag :: LangExt.Extension -> Condition -checkFlag flag dflags _ - | xopt flag dflags = IsValid - | otherwise = NotValid why - where - why = text "You need " <> text flag_str - <+> text "to derive an instance for this class" - flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of - [s] -> s - other -> pprPanic "checkFlag" (ppr other) - -std_class_via_coercible :: Class -> Bool --- These standard classes can be derived for a newtype --- using the coercible trick *even if no -XGeneralizedNewtypeDeriving --- because giving so gives the same results as generating the boilerplate -std_class_via_coercible clas - = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] - -- Not Read/Show because they respect the type - -- Not Enum, because newtypes are never in Enum - - -non_coercible_class :: Class -> Bool --- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift --- by Coercible, even with -XGeneralizedNewtypeDeriving --- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived --- instance behave differently if there's a non-lawful Applicative out there. --- Besides, with roles, Coercible-deriving Traversable is ill-roled. -non_coercible_class cls - = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey - , genClassKey, gen1ClassKey, typeableClassKey - , traversableClassKey, liftClassKey ]) - -badCon :: DataCon -> SDoc -> SDoc -badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg - ------------------------------------------------------------------- - -newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst -newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode - , ds_tvs = tvs, ds_cls = clas, ds_tys = tys }) - = newClsInst overlap_mode dfun_name tvs theta clas tys - -extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a --- Add new locally-defined instances; don't bother to check --- for functional dependency errors -- that'll happen in TcInstDcls -extendLocalInstEnv dfuns thing_inside - = do { env <- getGblEnv - ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns - env' = env { tcg_inst_env = inst_env' } - ; setGblEnv env' thing_inside } - -{- -Note [Deriving any class] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Classic uses of a deriving clause, or a standalone-deriving declaration, are -for: - * a stock class like Eq or Show, for which GHC knows how to generate - the instance code - * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving - -The DeriveAnyClass extension adds a third way to derive instances, based on -empty instance declarations. - -The canonical use case is in combination with GHC.Generics and default method -signatures. These allow us to have instance declarations being empty, but still -useful, e.g. - - data T a = ...blah..blah... deriving( Generic ) - instance C a => C (T a) -- No 'where' clause - -where C is some "random" user-defined class. - -This boilerplate code can be replaced by the more compact - - data T a = ...blah..blah... deriving( Generic, C ) - -if DeriveAnyClass is enabled. - -This is not restricted to Generics; any class can be derived, simply giving -rise to an empty instance. - -Unfortunately, it is not clear how to determine the context (when using a -deriving clause; in standalone deriving, the user provides the context). -GHC uses the same heuristic for figuring out the class context that it uses for -Eq in the case of *-kinded classes, and for Functor in the case of -* -> *-kinded classes. That may not be optimal or even wrong. But in such -cases, standalone deriving can still be used. - -Note [Check that the type variable is truly universal] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For Functor and Traversable instances, we must check that the *last argument* -of the type constructor is used truly universally quantified. Example - - data T a b where - T1 :: a -> b -> T a b -- Fine! Vanilla H-98 - T2 :: b -> c -> T a b -- Fine! Existential c, but we can still map over 'b' - T3 :: b -> T Int b -- Fine! Constraint 'a', but 'b' is still polymorphic - T4 :: Ord b => b -> T a b -- No! 'b' is constrained - T5 :: b -> T b b -- No! 'b' is constrained - T6 :: T a (b,b) -- No! 'b' is constrained - -Notice that only the first of these constructors is vanilla H-98. We only -need to take care about the last argument (b in this case). See Trac #8678. -Eg. for T1-T3 we can write - - fmap f (T1 a b) = T1 a (f b) - fmap f (T2 b c) = T2 (f b) c - fmap f (T3 x) = T3 (f x) - -We need not perform these checks for Foldable instances, however, since -functions in Foldable can only consume existentially quantified type variables, -rather than produce them (as is the case in Functor and Traversable functions.) -As a result, T can have a derived Foldable instance: - - foldr f z (T1 a b) = f b z - foldr f z (T2 b c) = f b z - foldr f z (T3 x) = f x z - foldr f z (T4 x) = f x z - foldr f z (T5 x) = f x z - foldr _ z T6 = z - -See Note [DeriveFoldable with ExistentialQuantification] in TcGenFunctor. --} diff --git a/typecheck/TcEnv.hs b/typecheck/TcEnv.hs deleted file mode 100644 --- a/typecheck/TcEnv.hs +++ /dev/null @@ -1,1023 +0,0 @@ --- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP, FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an - -- orphan -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder - -module TcEnv( - TyThing(..), TcTyThing(..), TcId, - - -- Instance environment, and InstInfo type - InstInfo(..), iDFunId, pprInstInfoDetails, - simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, - InstBindings(..), - - -- Global environment - tcExtendGlobalEnv, tcExtendTyConEnv, - tcExtendGlobalEnvImplicit, setGlobalTypeEnv, - tcExtendGlobalValEnv, - tcLookupLocatedGlobal, tcLookupGlobal, - tcLookupTyCon, tcLookupClass, - tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, - tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, tcLookupAxiom, - lookupGlobal, - - -- Local environment - tcExtendKindEnv, tcExtendKindEnvList, - tcExtendTyVarEnv, tcExtendTyVarEnv2, - tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds, - tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, - tcExtendIdBndrs, tcExtendLocalTypeEnv, - isTypeClosedLetBndr, - - tcLookup, tcLookupLocated, tcLookupLocalIds, - tcLookupId, tcLookupTyVar, - tcLookupLcl_maybe, - getInLocalScope, - wrongThingErr, pprBinders, - - tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, - getTypeSigNames, - tcExtendRecEnv, -- For knot-tying - - -- Instances - tcLookupInstance, tcGetInstEnvs, - - -- Rules - tcExtendRules, - - -- Defaults - tcGetDefaultTys, - - -- Global type variables - tcGetGlobalTyCoVars, - - -- Template Haskell stuff - checkWellStaged, tcMetaTy, thLevel, - topIdLvl, isBrackStage, - - -- New Ids - newDFunName, newDFunName', newFamInstTyConName, - newFamInstAxiomName, - mkStableIdFromString, mkStableIdFromName, - mkWrapperName - ) where - -#include "HsVersions.h" - -import HsSyn -import IfaceEnv -import TcRnMonad -import TcMType -import TcType -import LoadIface -import PrelNames -import TysWiredIn -import Id -import Var -import VarSet -import RdrName -import InstEnv -import DataCon ( DataCon ) -import PatSyn ( PatSyn ) -import ConLike -import TyCon -import CoAxiom -import Class -import Name -import NameSet -import NameEnv -import VarEnv -import HscTypes -import DynFlags -import SrcLoc -import BasicTypes hiding( SuccessFlag(..) ) -import Module -import Outputable -import Encoding -import FastString -import ListSetOps -import Util -import Maybes( MaybeErr(..), orElse ) -import qualified GHC.LanguageExtensions as LangExt - -import Data.IORef -import Data.List - - -{- ********************************************************************* -* * - An IO interface to looking up globals -* * -********************************************************************* -} - -lookupGlobal :: HscEnv -> Name -> IO TyThing --- An IO version, used outside the typechecker --- It's more complicated than it looks, because it may --- need to suck in an interface file -lookupGlobal hsc_env name - = initTcForLookup hsc_env (tcLookupGlobal name) - -- This initTcForLookup stuff is massive overkill - -- but that's how it is right now, and at least - -- this function localises it - -{- -************************************************************************ -* * -* tcLookupGlobal * -* * -************************************************************************ - -Using the Located versions (eg. tcLookupLocatedGlobal) is preferred, -unless you know that the SrcSpan in the monad is already set to the -span of the Name. --} - - -tcLookupLocatedGlobal :: Located Name -> TcM TyThing --- c.f. IfaceEnvEnv.tcIfaceGlobal -tcLookupLocatedGlobal name - = addLocM tcLookupGlobal name - -tcLookupGlobal :: Name -> TcM TyThing --- The Name is almost always an ExternalName, but not always --- In GHCi, we may make command-line bindings (ghci> let x = True) --- that bind a GlobalId, but with an InternalName -tcLookupGlobal name - = do { -- Try local envt - env <- getGblEnv - ; case lookupNameEnv (tcg_type_env env) name of { - Just thing -> return thing ; - Nothing -> - - -- Should it have been in the local envt? - -- (NB: use semantic mod here, since names never use - -- identity module, see Note [Identity versus semantic module].) - if nameIsLocalOrFrom (tcg_semantic_mod env) name - then notFound name -- Internal names can happen in GHCi - else - - -- Try home package table and external package table - do { mb_thing <- tcLookupImported_maybe name - ; case mb_thing of - Succeeded thing -> return thing - Failed msg -> failWithTc msg - }}} - -tcLookupDataCon :: Name -> TcM DataCon -tcLookupDataCon name = do - thing <- tcLookupGlobal name - case thing of - AConLike (RealDataCon con) -> return con - _ -> wrongThingErr "data constructor" (AGlobal thing) name - -tcLookupPatSyn :: Name -> TcM PatSyn -tcLookupPatSyn name = do - thing <- tcLookupGlobal name - case thing of - AConLike (PatSynCon ps) -> return ps - _ -> wrongThingErr "pattern synonym" (AGlobal thing) name - -tcLookupConLike :: Name -> TcM ConLike -tcLookupConLike name = do - thing <- tcLookupGlobal name - case thing of - AConLike cl -> return cl - _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name - -tcLookupClass :: Name -> TcM Class -tcLookupClass name = do - thing <- tcLookupGlobal name - case thing of - ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls - _ -> wrongThingErr "class" (AGlobal thing) name - -tcLookupTyCon :: Name -> TcM TyCon -tcLookupTyCon name = do - thing <- tcLookupGlobal name - case thing of - ATyCon tc -> return tc - _ -> wrongThingErr "type constructor" (AGlobal thing) name - -tcLookupAxiom :: Name -> TcM (CoAxiom Branched) -tcLookupAxiom name = do - thing <- tcLookupGlobal name - case thing of - ACoAxiom ax -> return ax - _ -> wrongThingErr "axiom" (AGlobal thing) name - -tcLookupLocatedGlobalId :: Located Name -> TcM Id -tcLookupLocatedGlobalId = addLocM tcLookupId - -tcLookupLocatedClass :: Located Name -> TcM Class -tcLookupLocatedClass = addLocM tcLookupClass - -tcLookupLocatedTyCon :: Located Name -> TcM TyCon -tcLookupLocatedTyCon = addLocM tcLookupTyCon - --- Find the instance that exactly matches a type class application. The class arguments must be precisely --- the same as in the instance declaration (modulo renaming & casts). --- -tcLookupInstance :: Class -> [Type] -> TcM ClsInst -tcLookupInstance cls tys - = do { instEnv <- tcGetInstEnvs - ; case lookupUniqueInstEnv instEnv cls tys of - Left err -> failWithTc $ text "Couldn't match instance:" <+> err - Right (inst, tys) - | uniqueTyVars tys -> return inst - | otherwise -> failWithTc errNotExact - } - where - errNotExact = text "Not an exact match (i.e., some variables get instantiated)" - - uniqueTyVars tys = all isTyVarTy tys - && hasNoDups (map (getTyVar "tcLookupInstance") tys) - -tcGetInstEnvs :: TcM InstEnvs --- Gets both the external-package inst-env --- and the home-pkg inst env (includes module being compiled) -tcGetInstEnvs = do { eps <- getEps - ; env <- getGblEnv - ; return (InstEnvs { ie_global = eps_inst_env eps - , ie_local = tcg_inst_env env - , ie_visible = tcVisibleOrphanMods env }) } - -instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where - lookupThing = tcLookupGlobal - -{- -************************************************************************ -* * - Extending the global environment -* * -************************************************************************ --} - -setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv --- Use this to update the global type env --- It updates both * the normal tcg_type_env field --- * the tcg_type_env_var field seen by interface files -setGlobalTypeEnv tcg_env new_type_env - = do { -- Sync the type-envt variable seen by interface files - writeMutVar (tcg_type_env_var tcg_env) new_type_env - ; return (tcg_env { tcg_type_env = new_type_env }) } - - -tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r - -- Just extend the global environment with some TyThings - -- Do not extend tcg_tcs etc -tcExtendGlobalEnvImplicit things thing_inside - = do { tcg_env <- getGblEnv - ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things - ; tcg_env' <- setGlobalTypeEnv tcg_env ge' - ; setGblEnv tcg_env' thing_inside } - -tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, all defined in the - -- module being compiled, extend the global environment -tcExtendGlobalEnv things thing_inside - = do { env <- getGblEnv - ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env, - tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env } - ; setGblEnv env' $ - tcExtendGlobalEnvImplicit things thing_inside - } - -tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, all defined in the - -- module being compiled, extend the global environment -tcExtendTyConEnv tycons thing_inside - = do { env <- getGblEnv - ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env } - ; setGblEnv env' $ - tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside - } - -tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a - -- Same deal as tcExtendGlobalEnv, but for Ids -tcExtendGlobalValEnv ids thing_inside - = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside - -tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r --- Extend the global environments for the type/class knot tying game --- Just like tcExtendGlobalEnv, except the argument is a list of pairs -tcExtendRecEnv gbl_stuff thing_inside - = do { tcg_env <- getGblEnv - ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff - ; tcg_env' <- setGlobalTypeEnv tcg_env ge' - ; setGblEnv tcg_env' thing_inside } - -{- -************************************************************************ -* * -\subsection{The local environment} -* * -************************************************************************ --} - -tcLookupLocated :: Located Name -> TcM TcTyThing -tcLookupLocated = addLocM tcLookup - -tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) -tcLookupLcl_maybe name - = do { local_env <- getLclTypeEnv - ; return (lookupNameEnv local_env name) } - -tcLookup :: Name -> TcM TcTyThing -tcLookup name = do - local_env <- getLclTypeEnv - case lookupNameEnv local_env name of - Just thing -> return thing - Nothing -> AGlobal <$> tcLookupGlobal name - -tcLookupTyVar :: Name -> TcM TcTyVar -tcLookupTyVar name - = do { thing <- tcLookup name - ; case thing of - ATyVar _ tv -> return tv - _ -> pprPanic "tcLookupTyVar" (ppr name) } - -tcLookupId :: Name -> TcM Id --- Used when we aren't interested in the binding level, nor refinement. --- The "no refinement" part means that we return the un-refined Id regardless --- --- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId) -tcLookupId name = do - thing <- tcLookup name - case thing of - ATcId { tct_id = id} -> return id - AGlobal (AnId id) -> return id - _ -> pprPanic "tcLookupId" (ppr name) - -tcLookupLocalIds :: [Name] -> TcM [TcId] --- We expect the variables to all be bound, and all at --- the same level as the lookup. Only used in one place... -tcLookupLocalIds ns - = do { env <- getLclEnv - ; return (map (lookup (tcl_env env)) ns) } - where - lookup lenv name - = case lookupNameEnv lenv name of - Just (ATcId { tct_id = id }) -> id - _ -> pprPanic "tcLookupLocalIds" (ppr name) - -getInLocalScope :: TcM (Name -> Bool) -getInLocalScope = do { lcl_env <- getLclTypeEnv - ; return (`elemNameEnv` lcl_env) } - -tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r --- Used only during kind checking, for TcThings that are --- ATcTyCon or APromotionErr --- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr -tcExtendKindEnvList things thing_inside - = do { traceTc "txExtendKindEnvList" (ppr things) - ; updLclEnv upd_env thing_inside } - where - upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things } - -tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r --- A variant of tcExtendKindEvnList -tcExtendKindEnv extra_env thing_inside - = do { traceTc "txExtendKindEnv" (ppr extra_env) - ; updLclEnv upd_env thing_inside } - where - upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env } - ------------------------ --- Scoped type and kind variables -tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r -tcExtendTyVarEnv tvs thing_inside - = tcExtendTyVarEnv2 [(tyVarName tv, tv) | tv <- tvs] thing_inside - -tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r -tcExtendTyVarEnv2 binds thing_inside - -- this should be used only for explicitly mentioned scoped variables. - -- thus, no coercion variables - = do { tc_extend_local_env NotTopLevel - [(name, ATyVar name tv) | (name, tv) <- binds] $ - do { env <- getLclEnv - ; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) } - ; setLclEnv env' thing_inside }} - where - add_tidy_tvs env = foldl add env binds - - -- We initialise the "tidy-env", used for tidying types before printing, - -- by building a reverse map from the in-scope type variables to the - -- OccName that the programmer originally used for them - add :: TidyEnv -> (Name, TcTyVar) -> TidyEnv - add (env,subst) (name, tyvar) - = ASSERT( isTyVar tyvar ) - case tidyOccName env (nameOccName name) of - (env', occ') -> (env', extendVarEnv subst tyvar tyvar') - where - tyvar' = setTyVarName tyvar name' - name' = tidyNameOcc name occ' - -isTypeClosedLetBndr :: Id -> Bool --- See Note [Bindings with closed types] in TcRnTypes -isTypeClosedLetBndr = noFreeVarsOfType . idType - -tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a --- Used for binding the recurive uses of Ids in a binding --- both top-level value bindings and and nested let/where-bindings --- Does not extend the TcIdBinderStack -tcExtendRecIds pairs thing_inside - = tc_extend_local_env NotTopLevel - [ (name, ATcId { tct_id = let_id - , tct_info = NonClosedLet emptyNameSet False }) - | (name, let_id) <- pairs ] $ - thing_inside - -tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a --- Used for binding the Ids that have a complete user type signature --- Does not extend the TcIdBinderStack -tcExtendSigIds top_lvl sig_ids thing_inside - = tc_extend_local_env top_lvl - [ (idName id, ATcId { tct_id = id - , tct_info = info }) - | id <- sig_ids - , let closed = isTypeClosedLetBndr id - info = NonClosedLet emptyNameSet closed ] - thing_inside - - -tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed - -> [TcId] -> TcM a -> TcM a --- Used for both top-level value bindings and and nested let/where-bindings --- Adds to the TcIdBinderStack too -tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) - ids thing_inside - = tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] $ - tc_extend_local_env top_lvl - [ (idName id, ATcId { tct_id = id - , tct_info = mk_tct_info id }) - | id <- ids ] - thing_inside - where - mk_tct_info id - | type_closed && isEmptyNameSet rhs_fvs = ClosedLet - | otherwise = NonClosedLet rhs_fvs type_closed - where - name = idName id - rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet - type_closed = isTypeClosedLetBndr id && - (fv_type_closed || hasCompleteSig sig_fn name) - -tcExtendIdEnv :: [TcId] -> TcM a -> TcM a --- For lambda-bound and case-bound Ids --- Extends the the TcIdBinderStack as well -tcExtendIdEnv ids thing_inside - = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside - -tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a --- Exactly like tcExtendIdEnv2, but for a single (name,id) pair -tcExtendIdEnv1 name id thing_inside - = tcExtendIdEnv2 [(name,id)] thing_inside - -tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a -tcExtendIdEnv2 names_w_ids thing_inside - = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel - | (_,mono_id) <- names_w_ids ] $ - tc_extend_local_env NotTopLevel - [ (name, ATcId { tct_id = id - , tct_info = NotLetBound }) - | (name,id) <- names_w_ids] - thing_inside - -tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a -tc_extend_local_env top_lvl extra_env thing_inside --- Precondition: the argument list extra_env has TcTyThings --- that ATcId or ATyVar, but nothing else --- --- Invariant: the ATcIds are fully zonked. Reasons: --- (a) The kinds of the forall'd type variables are defaulted --- (see Kind.defaultKind, done in zonkQuantifiedTyVar) --- (b) There are no via-Indirect occurrences of the bound variables --- in the types, because instantiation does not look through such things --- (c) The call to tyCoVarsOfTypes is ok without looking through refs - --- The second argument of type TyVarSet is a set of type variables --- that are bound together with extra_env and should not be regarded --- as free in the types of extra_env. - = do { traceTc "env2" (ppr extra_env) - ; env0 <- getLclEnv - ; env1 <- tcExtendLocalTypeEnv env0 extra_env - ; stage <- getStage - ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1 - ; setLclEnv env2 thing_inside } - where - extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv - -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously - -- Reason for extending LocalRdrEnv: after running a TH splice we need - -- to do renaming. - extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env - , tcl_th_bndrs = th_bndrs }) - = env { tcl_rdr = extendLocalRdrEnvList rdr_env - [ n | (n, _) <- pairs, isInternalName n ] - -- The LocalRdrEnv contains only non-top-level names - -- (GlobalRdrEnv handles the top level) - , tcl_th_bndrs = extendNameEnvList th_bndrs -- We only track Ids in tcl_th_bndrs - [(n, thlvl) | (n, ATcId {}) <- pairs] } - -tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcM TcLclEnv -tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things - | isEmptyVarSet extra_tvs - = return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things }) - | otherwise - = do { global_tvs <- readMutVar (tcl_tyvars lcl_env) - ; new_g_var <- newMutVar (global_tvs `unionVarSet` extra_tvs) - ; return (lcl_env { tcl_tyvars = new_g_var - , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) } - where - extra_tvs = foldr get_tvs emptyVarSet tc_ty_things - - get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs - = case closed of - ClosedLet -> - ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) tvs - _ -> - tvs `unionVarSet` id_tvs - where id_tvs = tyCoVarsOfType (idType id) - - get_tvs (_, ATyVar _ tv) tvs -- See Note [Global TyVars] - = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv - - get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc) - - get_tvs (_, AGlobal {}) tvs = tvs - get_tvs (_, APromotionErr {}) tvs = tvs - - -- Note [Global TyVars] - -- It's important to add the in-scope tyvars to the global tyvar set - -- as well. Consider - -- f (_::r) = let g y = y::r in ... - -- Here, g mustn't be generalised. This is also important during - -- class and instance decls, when we mustn't generalise the class tyvars - -- when typechecking the methods. - -- - -- Nor must we generalise g over any kind variables free in r's kind - -------------------------------------------------------------- --- Extending the TcIdBinderStack, used only for error messages - -tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a -tcExtendIdBndrs bndrs thing_inside - = do { traceTc "tcExtendIdBndrs" (ppr bndrs) - ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) - thing_inside } - - -{- ********************************************************************* -* * - Adding placeholders -* * -********************************************************************* -} - -tcAddDataFamConPlaceholders :: [LInstDecl Name] -> TcM a -> TcM a --- See Note [AFamDataCon: not promoting data family constructors] -tcAddDataFamConPlaceholders inst_decls thing_inside - = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE) - | lid <- inst_decls, con <- get_cons lid ] - thing_inside - -- Note [AFamDataCon: not promoting data family constructors] - where - -- get_cons extracts the *constructor* bindings of the declaration - get_cons :: LInstDecl Name -> [Name] - get_cons (L _ (TyFamInstD {})) = [] - get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid - get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) - = concatMap (get_fi_cons . unLoc) fids - - get_fi_cons :: DataFamInstDecl Name -> [Name] - get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } }) - = map unLoc $ concatMap (getConNames . unLoc) cons - - -tcAddPatSynPlaceholders :: [PatSynBind Name Name] -> TcM a -> TcM a --- See Note [Don't promote pattern synonyms] -tcAddPatSynPlaceholders pat_syns thing_inside - = tcExtendKindEnvList [ (name, APromotionErr PatSynPE) - | PSB{ psb_id = L _ name } <- pat_syns ] - thing_inside - -getTypeSigNames :: [LSig Name] -> NameSet --- Get the names that have a user type sig -getTypeSigNames sigs - = foldr get_type_sig emptyNameSet sigs - where - get_type_sig :: LSig Name -> NameSet -> NameSet - get_type_sig sig ns = - case sig of - L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names) - L _ (PatSynSig names _) -> extendNameSetList ns (map unLoc names) - _ -> ns - - -{- Note [AFamDataCon: not promoting data family constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T a - data instance T Int = MkT - data Proxy (a :: k) - data S = MkS (Proxy 'MkT) - -Is it ok to use the promoted data family instance constructor 'MkT' in -the data declaration for S (where both declarations live in the same module)? -No, we don't allow this. It *might* make sense, but at least it would mean that -we'd have to interleave typechecking instances and data types, whereas at -present we do data types *then* instances. - -So to check for this we put in the TcLclEnv a binding for all the family -constructors, bound to AFamDataCon, so that if we trip over 'MkT' when -type checking 'S' we'll produce a decent error message. - -Trac #12088 describes this limitation. Of course, when MkT and S live in -different modules then all is well. - -Note [Don't promote pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We never promote pattern synonyms. - -Consider this (Trac #11265): - pattern A = True - instance Eq A -We want a civilised error message from the occurrence of 'A' -in the instance, yet 'A' really has not yet been type checked. - -Similarly (Trac #9161) - {-# LANGUAGE PatternSynonyms, DataKinds #-} - pattern A = () - b :: A - b = undefined -Here, the type signature for b mentions A. But A is a pattern -synonym, which is typechecked as part of a group of bindings (for very -good reasons; a view pattern in the RHS may mention a value binding). -It is entirely reasonable to reject this, but to do so we need A to be -in the kind environment when kind-checking the signature for B. - -Hence tcAddPatSynPlaceholers adds a binding - A -> APromotionErr PatSynPE -to the environment. Then TcHsType.tcTyVar will find A in the kind -environment, and will give a 'wrongThingErr' as a result. But the -lookup of A won't fail. - - -************************************************************************ -* * -\subsection{Rules} -* * -************************************************************************ --} - -tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a - -- Just pop the new rules into the EPS and envt resp - -- All the rules come from an interface file, not source - -- Nevertheless, some may be for this module, if we read - -- its interface instead of its source code -tcExtendRules lcl_rules thing_inside - = do { env <- getGblEnv - ; let - env' = env { tcg_rules = lcl_rules ++ tcg_rules env } - ; setGblEnv env' thing_inside } - -{- -************************************************************************ -* * - Meta level -* * -************************************************************************ --} - -checkWellStaged :: SDoc -- What the stage check is for - -> ThLevel -- Binding level (increases inside brackets) - -> ThLevel -- Use stage - -> TcM () -- Fail if badly staged, adding an error -checkWellStaged pp_thing bind_lvl use_lvl - | use_lvl >= bind_lvl -- OK! Used later than bound - = return () -- E.g. \x -> [| $(f x) |] - - | bind_lvl == outerLevel -- GHC restriction on top level splices - = stageRestrictionError pp_thing - - | otherwise -- Badly staged - = failWithTc $ -- E.g. \x -> $(f x) - text "Stage error:" <+> pp_thing <+> - hsep [text "is bound at stage" <+> ppr bind_lvl, - text "but used at stage" <+> ppr use_lvl] - -stageRestrictionError :: SDoc -> TcM a -stageRestrictionError pp_thing - = failWithTc $ - sep [ text "GHC stage restriction:" - , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation," - , text "and must be imported, not defined locally"])] - -topIdLvl :: Id -> ThLevel --- Globals may either be imported, or may be from an earlier "chunk" --- (separated by declaration splices) of this module. The former --- *can* be used inside a top-level splice, but the latter cannot. --- Hence we give the former impLevel, but the latter topLevel --- E.g. this is bad: --- x = [| foo |] --- $( f x ) --- By the time we are prcessing the $(f x), the binding for "x" --- will be in the global env, not the local one. -topIdLvl id | isLocalId id = outerLevel - | otherwise = impLevel - -tcMetaTy :: Name -> TcM Type --- Given the name of a Template Haskell data type, --- return the type --- E.g. given the name "Expr" return the type "Expr" -tcMetaTy tc_name = do - t <- tcLookupTyCon tc_name - return (mkTyConApp t []) - -isBrackStage :: ThStage -> Bool -isBrackStage (Brack {}) = True -isBrackStage _other = False - -{- -************************************************************************ -* * - getDefaultTys -* * -************************************************************************ --} - -tcGetDefaultTys :: TcM ([Type], -- Default types - (Bool, -- True <=> Use overloaded strings - Bool)) -- True <=> Use extended defaulting rules -tcGetDefaultTys - = do { dflags <- getDynFlags - ; let ovl_strings = xopt LangExt.OverloadedStrings dflags - extended_defaults = xopt LangExt.ExtendedDefaultRules dflags - -- See also Trac #1974 - flags = (ovl_strings, extended_defaults) - - ; mb_defaults <- getDeclaredDefaultTys - ; case mb_defaults of { - Just tys -> return (tys, flags) ; - -- User-supplied defaults - Nothing -> do - - -- No use-supplied default - -- Use [Integer, Double], plus modifications - { integer_ty <- tcMetaTy integerTyConName - ; list_ty <- tcMetaTy listTyConName - ; checkWiredInTyCon doubleTyCon - ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty] - -- Note [Extended defaults] - ++ [integer_ty, doubleTy] - ++ opt_deflt ovl_strings [stringTy] - ; return (deflt_tys, flags) } } } - where - opt_deflt True xs = xs - opt_deflt False _ = [] - -{- -Note [Extended defaults] -~~~~~~~~~~~~~~~~~~~~~ -In interative mode (or with -XExtendedDefaultRules) we add () as the first type we -try when defaulting. This has very little real impact, except in the following case. -Consider: - Text.Printf.printf "hello" -This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't -want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to -default the 'a' to (), rather than to Integer (which is what would otherwise happen; -and then GHCi doesn't attempt to print the (). So in interactive mode, we add -() to the list of defaulting types. See Trac #1200. - -Additonally, the list type [] is added as a default specialization for -Traversable and Foldable. As such the default default list now has types of -varying kinds, e.g. ([] :: * -> *) and (Integer :: *). - -************************************************************************ -* * -\subsection{The InstInfo type} -* * -************************************************************************ - -The InstInfo type summarises the information in an instance declaration - - instance c => k (t tvs) where b - -It is used just for *local* instance decls (not ones from interface files). -But local instance decls includes - - derived ones - - generic ones -as well as explicit user written ones. --} - -data InstInfo a - = InstInfo - { iSpec :: ClsInst -- Includes the dfun id - , iBinds :: InstBindings a - } - -iDFunId :: InstInfo a -> DFunId -iDFunId info = instanceDFunId (iSpec info) - -data InstBindings a - = InstBindings - { ib_tyvars :: [Name] -- Names of the tyvars from the instance head - -- that are lexically in scope in the bindings - -- Must correspond 1-1 with the forall'd tyvars - -- of the dfun Id. When typechecking, we are - -- going to extend the typechecker's envt with - -- ib_tyvars -> dfun_forall_tyvars - - , ib_binds :: LHsBinds a -- Bindings for the instance methods - - , ib_pragmas :: [LSig a] -- User pragmas recorded for generating - -- specialised instances - - , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should - -- be enabled when type-checking - -- this instance; needed for - -- GeneralizedNewtypeDeriving - - , ib_derived :: Bool - -- True <=> This code was generated by GHC from a deriving clause - -- or standalone deriving declaration - -- Used only to improve error messages - } - -instance (OutputableBndrId a) => Outputable (InstInfo a) where - ppr = pprInstInfoDetails - -pprInstInfoDetails :: (OutputableBndrId a) => InstInfo a -> SDoc -pprInstInfoDetails info - = hang (pprInstanceHdr (iSpec info) <+> text "where") - 2 (details (iBinds info)) - where - details (InstBindings { ib_binds = b }) = pprLHsBinds b - -simpleInstInfoClsTy :: InstInfo a -> (Class, Type) -simpleInstInfoClsTy info = case instanceHead (iSpec info) of - (_, cls, [ty]) -> (cls, ty) - _ -> panic "simpleInstInfoClsTy" - -simpleInstInfoTy :: InstInfo a -> Type -simpleInstInfoTy info = snd (simpleInstInfoClsTy info) - -simpleInstInfoTyCon :: InstInfo a -> TyCon - -- Gets the type constructor for a simple instance declaration, - -- i.e. one of the form instance (...) => C (T a b c) where ... -simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) - --- | Make a name for the dict fun for an instance decl. It's an *external* --- name, like other top-level names, and hence must be made with --- newGlobalBinder. -newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name -newDFunName clas tys loc - = do { is_boot <- tcIsHsBootOrSig - ; mod <- getModule - ; let info_string = occNameString (getOccName clas) ++ - concatMap (occNameString.getDFunTyKey) tys - ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) - ; newGlobalBinder mod dfun_occ loc } - --- | Special case of 'newDFunName' to generate dict fun name for a single TyCon. -newDFunName' :: Class -> TyCon -> TcM Name -newDFunName' clas tycon -- Just a simple wrapper - = do { loc <- getSrcSpanM -- The location of the instance decl, - -- not of the tycon - ; newDFunName clas [mkTyConApp tycon []] loc } - -- The type passed to newDFunName is only used to generate - -- a suitable string; hence the empty type arg list - -{- -Make a name for the representation tycon of a family instance. It's an -*external* name, like other top-level names, and hence must be made with -newGlobalBinder. --} - -newFamInstTyConName :: Located Name -> [Type] -> TcM Name -newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] - -newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name -newFamInstAxiomName (L loc name) branches - = mk_fam_inst_name mkInstTyCoOcc loc name branches - -mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name -mk_fam_inst_name adaptOcc loc tc_name tyss - = do { mod <- getModule - ; let info_string = occNameString (getOccName tc_name) ++ - intercalate "|" ty_strings - ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) - ; newGlobalBinder mod (adaptOcc occ) loc } - where - ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss - -{- -Stable names used for foreign exports and annotations. -For stable names, the name must be unique (see #1533). If the -same thing has several stable Ids based on it, the -top-level bindings generated must not have the same name. -Hence we create an External name (doesn't change), and we -append a Unique to the string right here. --} - -mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId -mkStableIdFromString str sig_ty loc occ_wrapper = do - uniq <- newUnique - mod <- getModule - name <- mkWrapperName "stable" str - let occ = mkVarOccFS name :: OccName - gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name - id = mkExportedVanillaId gnm sig_ty :: Id - return id - -mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId -mkStableIdFromName nm = mkStableIdFromString (getOccString nm) - -mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m) - => String -> String -> m FastString -mkWrapperName what nameBase - = do dflags <- getDynFlags - thisMod <- getModule - let -- Note [Generating fresh names for ccall wrapper] - wrapperRef = nextWrapperNum dflags - pkg = unitIdString (moduleUnitId thisMod) - mod = moduleNameString (moduleName thisMod) - wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env -> - let num = lookupWithDefaultModuleEnv mod_env 0 thisMod - mod_env' = extendModuleEnv mod_env thisMod (num+1) - in (mod_env', num) - let components = [what, show wrapperNum, pkg, mod, nameBase] - return $ mkFastString $ zEncodeString $ intercalate ":" components - -{- -Note [Generating fresh names for FFI wrappers] - -We used to use a unique, rather than nextWrapperNum, to distinguish -between FFI wrapper functions. However, the wrapper names that we -generate are external names. This means that if a call to them ends up -in an unfolding, then we can't alpha-rename them, and thus if the -unique randomly changes from one compile to another then we get a -spurious ABI change (#4012). - -The wrapper counter has to be per-module, not global, so that the number we end -up using is not dependent on the modules compiled before the current one. --} - -{- -************************************************************************ -* * -\subsection{Errors} -* * -************************************************************************ --} - -pprBinders :: [Name] -> SDoc --- Used in error messages --- Use quotes for a single one; they look a bit "busy" for several -pprBinders [bndr] = quotes (ppr bndr) -pprBinders bndrs = pprWithCommas ppr bndrs - -notFound :: Name -> TcM TyThing -notFound name - = do { lcl_env <- getLclEnv - ; let stage = tcl_th_ctxt lcl_env - ; case stage of -- See Note [Out of scope might be a staging error] - Splice {} - | isUnboundName name -> failM -- If the name really isn't in scope - -- don't report it again (Trac #11941) - | otherwise -> stageRestrictionError (quotes (ppr name)) - _ -> failWithTc $ - vcat[text "GHC internal error:" <+> quotes (ppr name) <+> - text "is not in scope during type checking, but it passed the renamer", - text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)] - -- Take care: printing the whole gbl env can - -- cause an infinite loop, in the case where we - -- are in the middle of a recursive TyCon/Class group; - -- so let's just not print it! Getting a loop here is - -- very unhelpful, because it hides one compiler bug with another - } - -wrongThingErr :: String -> TcTyThing -> Name -> TcM a --- It's important that this only calls pprTcTyThingCategory, which in --- turn does not look at the details of the TcTyThing. --- See Note [Placeholder PatSyn kinds] in TcBinds -wrongThingErr expected thing name - = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - text "used as a" <+> text expected) - -{- Note [Out of scope might be a staging error] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - x = 3 - data T = MkT $(foo x) - -where 'foo' is imported from somewhere. - -This is really a staging error, because we can't run code involving 'x'. -But in fact the type checker processes types first, so 'x' won't even be -in the type envt when we look for it in $(foo x). So inside splices we -report something missing from the type env as a staging error. -See Trac #5752 and #5795. --} diff --git a/typecheck/TcEnv.hs-boot b/typecheck/TcEnv.hs-boot deleted file mode 100644 --- a/typecheck/TcEnv.hs-boot +++ /dev/null @@ -1,6 +0,0 @@ -{- ->module TcEnv where ->import TcRnTypes -> ->tcExtendIdEnv :: [TcId] -> TcM a -> TcM a --} diff --git a/typecheck/TcErrors.hs b/typecheck/TcErrors.hs deleted file mode 100644 --- a/typecheck/TcErrors.hs +++ /dev/null @@ -1,2843 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} - -module TcErrors( - reportUnsolved, reportAllUnsolved, warnAllUnsolved, - warnDefaulting, - - solverDepthErrorTcS - ) where - -#include "HsVersions.h" - -import TcRnTypes -import TcRnMonad -import TcMType -import TcUnify( occCheckForErrors, OccCheckResult(..) ) -import TcType -import RnEnv( unknownNameSuggestions ) -import Type -import TyCoRep -import Kind -import Unify ( tcMatchTys ) -import Module -import FamInst -import FamInstEnv ( flattenTys ) -import Inst -import InstEnv -import TyCon -import Class -import DataCon -import TcEvidence -import HsExpr ( UnboundVar(..) ) -import HsBinds ( PatSynBind(..) ) -import Name -import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv - , mkRdrUnqual, isLocalGRE, greSrcSpan ) -import PrelNames ( typeableClassName, hasKey, liftedRepDataConKey ) -import Id -import Var -import VarSet -import VarEnv -import NameSet -import Bag -import ErrUtils ( ErrMsg, errDoc, pprLocErrMsg ) -import BasicTypes -import ConLike ( ConLike(..) ) -import Util -import FastString -import Outputable -import SrcLoc -import DynFlags -import ListSetOps ( equivClasses ) -import Maybes -import qualified GHC.LanguageExtensions as LangExt -import FV ( fvVarList, unionFV ) - -import Control.Monad ( when ) -import Data.List ( partition, mapAccumL, nub, sortBy, unfoldr ) -import qualified Data.Set as Set - -#if __GLASGOW_HASKELL__ > 710 -import Data.Semigroup ( Semigroup ) -import qualified Data.Semigroup as Semigroup -#endif - - -{- -************************************************************************ -* * -\section{Errors and contexts} -* * -************************************************************************ - -ToDo: for these error messages, should we note the location as coming -from the insts, or just whatever seems to be around in the monad just -now? - -Note [Deferring coercion errors to runtime] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -While developing, sometimes it is desirable to allow compilation to succeed even -if there are type errors in the code. Consider the following case: - - module Main where - - a :: Int - a = 'a' - - main = print "b" - -Even though `a` is ill-typed, it is not used in the end, so if all that we're -interested in is `main` it is handy to be able to ignore the problems in `a`. - -Since we treat type equalities as evidence, this is relatively simple. Whenever -we run into a type mismatch in TcUnify, we normally just emit an error. But it -is always safe to defer the mismatch to the main constraint solver. If we do -that, `a` will get transformed into - - co :: Int ~ Char - co = ... - - a :: Int - a = 'a' `cast` co - -The constraint solver would realize that `co` is an insoluble constraint, and -emit an error with `reportUnsolved`. But we can also replace the right-hand side -of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program -to compile, and it will run fine unless we evaluate `a`. This is what -`deferErrorsToRuntime` does. - -It does this by keeping track of which errors correspond to which coercion -in TcErrors. TcErrors.reportTidyWanteds does not print the errors -and does not fail if -fdefer-type-errors is on, so that we can continue -compilation. The errors are turned into warnings in `reportUnsolved`. --} - --- | Report unsolved goals as errors or warnings. We may also turn some into --- deferred run-time errors if `-fdefer-type-errors` is on. -reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) -reportUnsolved wanted - = do { binds_var <- newTcEvBinds - ; defer_errors <- goptM Opt_DeferTypeErrors - ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283 - ; let type_errors | not defer_errors = TypeError - | warn_errors = TypeWarn - | 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 binds_var False type_errors expr_holes - type_holes out_of_scope_holes wanted - - ; ev_binds <- getTcEvBindsMap binds_var - ; return (evBindMapBinds ev_binds)} - --- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on --- However, do not make any evidence bindings, because we don't --- have any convenient place to put them. --- See Note [Deferring coercion errors to runtime] --- Used by solveEqualities for kind equalities --- (see Note [Fail fast on kind errors] in TcSimplify] --- and for simplifyDefault. -reportAllUnsolved :: WantedConstraints -> TcM () -reportAllUnsolved wanted - = do { ev_binds <- newTcEvBinds - ; report_unsolved ev_binds False TypeError - HoleError HoleError HoleError wanted } - --- | Report all unsolved goals as warnings (but without deferring any errors to --- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in --- TcSimplify -warnAllUnsolved :: WantedConstraints -> TcM () -warnAllUnsolved wanted - = do { ev_binds <- newTcEvBinds - ; report_unsolved ev_binds True TypeWarn - HoleWarn HoleWarn HoleWarn wanted } - --- | Report unsolved goals as errors or warnings. -report_unsolved :: EvBindsVar -- cec_binds - -> Bool -- Errors as warnings - -> TypeErrorChoice -- Deferred type errors - -> HoleChoice -- Expression holes - -> HoleChoice -- Type holes - -> HoleChoice -- Out of scope holes - -> WantedConstraints -> TcM () -report_unsolved mb_binds_var err_as_warn type_errors expr_holes - type_holes out_of_scope_holes wanted - | isEmptyWC wanted - = return () - | otherwise - = do { traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) - - ; wanted <- zonkWC wanted -- Zonk to reveal all information - ; env0 <- tcInitTidyEnv - -- If we are deferring we are going to need /all/ evidence around, - -- including the evidence produced by unflattening (zonkWC) - ; let tidy_env = tidyFreeTyCoVars env0 free_tvs - free_tvs = tyCoVarsOfWCList wanted - - ; traceTc "reportUnsolved (after zonking):" $ - vcat [ text "Free tyvars:" <+> pprTyVars free_tvs - , text "Wanted:" <+> ppr wanted ] - - ; warn_redundant <- woptM Opt_WarnRedundantConstraints - ; let err_ctxt = CEC { cec_encl = [] - , cec_tidy = tidy_env - , cec_defer_type_errors = type_errors - , cec_errors_as_warns = err_as_warn - , cec_expr_holes = expr_holes - , cec_type_holes = type_holes - , cec_out_of_scope_holes = out_of_scope_holes - , cec_suppress = False -- See Note [Suppressing error messages] - , cec_warn_redundant = warn_redundant - , cec_binds = mb_binds_var } - - ; tc_lvl <- getTcLevel - ; reportWanteds err_ctxt tc_lvl wanted } - --------------------------------------------- --- 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] - } - -instance Outputable Report where -- Debugging only - ppr (Report { report_important = imp, report_relevant_bindings = rel }) - = vcat [ text "important:" <+> vcat imp - , text "relevant:" <+> vcat rel ] - -{- 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 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. --} - -#if __GLASGOW_HASKELL__ > 710 -instance Semigroup Report where - Report a1 b1 <> Report a2 b2 = Report (a1 ++ a2) (b1 ++ b2) -#endif - -instance Monoid Report where - mempty = Report [] [] - mappend (Report a1 b1) (Report a2 b2) = Report (a1 ++ a2) (b1 ++ b2) - --- | Put a doc into the important msgs block. -important :: SDoc -> Report -important doc = mempty { report_important = [doc] } - --- | Put a doc into the relevant bindings block. -relevant_bindings :: SDoc -> Report -relevant_bindings doc = mempty { report_relevant_bindings = [doc] } - -data TypeErrorChoice -- What to do for type errors found by the type checker - = TypeError -- A type error aborts compilation with an error message - | TypeWarn -- A type error is deferred to runtime, plus a compile-time warning - | 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 = text "TypeWarn" - 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_errors_as_warns :: Bool -- Turn all errors into warnings - -- (except for Holes, which are - -- controlled by cec_type_holes and - -- cec_expr_holes) - , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime - - -- cec_expr_holes is a union of: - -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' - -- cec_out_of_scope_holes - a set of variables which are - -- out of scope: 'x', 'y', 'bar' - , cec_expr_holes :: HoleChoice -- Holes in expressions - , cec_type_holes :: HoleChoice -- Holes in types - , cec_out_of_scope_holes :: HoleChoice -- Out of scope holes - - , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints - - , cec_suppress :: Bool -- True <=> More important errors have occurred, - -- so create bindings if need be, but - -- don't issue any more errors/warnings - -- See Note [Suppressing error messages] - } - -instance Outputable ReportErrCtxt where - ppr (CEC { cec_binds = bvar - , cec_errors_as_warns = ew - , cec_defer_type_errors = dte - , cec_expr_holes = eh - , cec_type_holes = th - , cec_out_of_scope_holes = osh - , cec_warn_redundant = wr - , cec_suppress = sup }) - = text "CEC" <+> braces (vcat - [ text "cec_binds" <+> equals <+> ppr bvar - , text "cec_errors_as_warns" <+> equals <+> ppr ew - , text "cec_defer_type_errors" <+> equals <+> ppr dte - , text "cec_expr_holes" <+> equals <+> ppr eh - , text "cec_type_holes" <+> equals <+> ppr th - , text "cec_out_of_scope_holes" <+> equals <+> ppr osh - , text "cec_warn_redundant" <+> equals <+> ppr wr - , text "cec_suppress" <+> equals <+> ppr sup ]) - -{- -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. --} - -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_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" (ppr implic') - ; reportWanteds ctxt' tc_lvl wanted - ; when (cec_warn_redundant ctxt) $ - warnRedundantConstraints ctxt' tcl_env info' dead_givens } - where - insoluble = isInsolubleStatus status - (env1, tvs') = mapAccumL tidyTyCoVarBndr (cec_tidy ctxt) tvs - info' = tidySkolemInfo env1 info - implic' = implic { ic_skols = tvs' - , ic_given = map (tidyEvVar env1) given - , ic_info = info' } - ctxt' = ctxt { cec_tidy = env1 - , cec_encl = implic' : cec_encl ctxt - - , cec_suppress = insoluble || cec_suppress ctxt - -- Suppress inessential errors if there - -- are are insolubles anywhere in the - -- tree rooted here, or we've come across - -- a suppress-worthy constraint higher up (Trac #11541) - - , cec_binds = evb } - - dead_givens = case status of - IC_Solved { ics_dead = dead } -> dead - _ -> [] - -warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM () --- See Note [Tracking redundant constraints] in TcSimplify -warnRedundantConstraints ctxt env info ev_vars - | null redundant_evs - = return () - - | SigSkol {} <- info - = setLclEnv env $ -- We want to add "In the type signature for f" - -- to the error context, which is a bit tiresome - addErrCtxt (text "In" <+> ppr info) $ - do { env <- getLclEnv - ; msg <- mkErrorReport ctxt env (important doc) - ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } - - | otherwise -- But for InstSkol there already *is* a surrounding - -- "In the instance declaration for Eq [a]" context - -- and we don't want to say it twice. Seems a bit ad-hoc - = do { msg <- mkErrorReport ctxt env (important doc) - ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } - where - doc = text "Redundant constraint" <> plural redundant_evs <> colon - <+> pprEvVarTheta redundant_evs - - redundant_evs = case info of -- See Note [Redundant constraints in instance decls] - InstSkol -> filterOut improving ev_vars - _ -> ev_vars - - improving ev_var = any isImprovementPred $ - transSuperClasses (idType ev_var) - -{- Note [Redundant constraints in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For instance declarations, we don't report unused givens if -they can give rise to improvement. Example (Trac #10100): - class Add a b ab | a b -> ab, a ab -> b - instance Add Zero b b - instance Add a b ab => Add (Succ a) b (Succ ab) -The context (Add a b ab) for the instance is clearly unused in terms -of evidence, since the dictionary has no feilds. 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_insol = insols, wc_impl = implics }) - = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples - , text "Insols =" <+> ppr insols - , text "Suppress =" <+> ppr (cec_suppress ctxt)]) - ; let tidy_cts = bagToList (mapBag (tidyCt env) (insols `unionBags` simples)) - - -- First deal with things that are utterly wrong - -- Like Int ~ Bool (incl nullary TyCons) - -- or Int ~ t a (AppTy on one side) - -- These /ones/ are not suppressed by the incoming context - ; let ctxt_for_insols = ctxt { cec_suppress = False } - ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts - - -- Now all the other constraints. We suppress errors here if - -- any of the first batch failed, or if the enclosing context - -- says to suppress - ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } - ; (_, leftovers) <- tryReporters ctxt2 report2 cts1 - ; MASSERT2( null leftovers, ppr leftovers ) - - -- All the Derived ones have been filtered out of simples - -- by the constraint solver. This is ok; we don't want - -- to report unsolved Derived goals as errors - -- See Note [Do not report derived but soluble errors] - - ; mapBagM_ (reportImplic ctxt2) implics } - -- NB ctxt1: don't suppress inner insolubles if there's only a - -- wanted insoluble here; but do suppress inner insolubles - -- if there's a *given* insoluble here (= inaccessible code) - where - env = cec_tidy ctxt - - -- report1: ones that should *not* be suppresed by - -- an insoluble somewhere else in the tree - -- It's crucial that anything that is considered insoluble - -- (see TcRnTypes.trulyInsoluble) 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) - , ("skolem eq2", skolem_eq, True, mkSkolReporter) - , ("non-tv eq", non_tv_eq, True, mkSkolReporter) - , ("Out of scope", is_out_of_scope, True, mkHoleReporter) - , ("Holes", is_hole, False, mkHoleReporter) - - -- The only remaining equalities are alpha ~ ty, - -- where alpha is untouchable; and representational equalities - , ("Other eqs", is_equality, False, mkGroupReporter mkEqErr) ] - - -- report2: we suppress these if there are insolubles elsewhere in the tree - report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) - , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) - , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] - - -- rigid_nom_eq, rigid_nom_tv_eq, - is_hole, is_dict, - is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool - - is_given_eq ct pred - | EqPred {} <- pred = arisesFromGivens ct - | otherwise = False - -- I think all given residuals are equalities - - -- Things like (Int ~N Bool) - utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 - utterly_wrong _ _ = False - - -- Things like (a ~N Int) - very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2 - very_wrong _ _ = False - - -- Things like (a ~N b) or (a ~N F Bool) - skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1 - skolem_eq _ _ = False - - -- Things like (F a ~N Int) - non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) - non_tv_eq _ _ = False - - is_out_of_scope ct _ = isOutOfScopeCt ct - is_hole ct _ = isHoleCt ct - - is_user_type_error ct _ = isUserTypeErrorCt ct - - is_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 = case find_gadt_match (cec_encl ctxt) of - Just imp -> ("insoluble1a", is_given_eq, True, mkGivenErrorReporter imp) - Nothing -> ("insoluble1b", is_given_eq, False, ignoreErrorReporter) - -- False means don't suppress subsequent errors - -- Reason: we don't report all given errors - -- (see mkGivenErrorReporter), and we should only suppress - -- subsequent errors if we actually report this one! - -- Trac #13446 is an example - - find_gadt_match [] = Nothing - find_gadt_match (implic : implics) - | PatSkol {} <- ic_info implic - , not (ic_no_eqs implic) - = Just implic - | otherwise - = find_gadt_match implics - ---------------- -isSkolemTy :: TcLevel -> Type -> Bool --- The type is a skolem tyvar -isSkolemTy tc_lvl ty - | Just tv <- getTyVar_maybe ty - = isSkolemTyVar tv - || (isSigTyVar tv && isTouchableMetaTyVar tc_lvl tv) - -- The last case is for touchable SigTvs - -- we postpone untouchables to a latter test (too obscure) - - | otherwise - = False - -isTyFun_maybe :: Type -> Maybe TyCon -isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of - Just (tc,_) | isTypeFamilyTyCon tc -> Just tc - _ -> Nothing - --------------------------------------------- --- Reporters --------------------------------------------- - -type Reporter - = ReportErrCtxt -> [Ct] -> TcM () -type ReporterSpec - = ( String -- Name - , Ct -> PredTree -> Bool -- Pick these ones - , Bool -- True <=> suppress subsequent reporters - , Reporter) -- The reporter itself - -mkSkolReporter :: Reporter --- Suppress duplicates with either the same LHS, or same location -mkSkolReporter ctxt cts - = mapM_ (reportGroup mkEqErr ctxt) (group cts) - where - group [] = [] - group (ct:cts) = (ct : yeses) : group noes - where - (yeses, noes) = partition (group_with ct) cts - - group_with ct1 ct2 - | EQ <- cmp_loc ct1 ct2 = True - | eq_lhs_type ct1 ct2 = True - | otherwise = False - -mkHoleReporter :: Reporter --- Reports errors one at a time -mkHoleReporter ctxt - = mapM_ $ \ct -> do { err <- mkHoleError ctxt ct - ; maybeReportHoleError ctxt ct err - ; maybeAddDeferredHoleBinding ctxt err ct } - -mkUserTypeErrorReporter :: Reporter -mkUserTypeErrorReporter ctxt - = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct - ; maybeReportError ctxt err - ; addDeferredBinding ctxt err ct } - -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg -mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct - $ important - $ pprUserTypeErrorTy - $ case getUserTypeErrorMsg ct of - Just msg -> msg - Nothing -> pprPanic "mkUserTypeError" (ppr ct) - - -mkGivenErrorReporter :: Implication -> Reporter --- See Note [Given errors] -mkGivenErrorReporter implic ctxt cts - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; dflags <- getDynFlags - ; let ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) - -- For given constraints we overwrite the env (and hence src-loc) - -- with one from the implication. See Note [Inaccessible code] - - inaccessible_msg = hang (text "Inaccessible code in") - 2 (ppr (ic_info implic)) - report = important inaccessible_msg `mappend` - relevant_bindings binds_msg - - ; err <- mkEqErr_help dflags ctxt report ct' - Nothing ty1 ty2 - - ; traceTc "mkGivenErrorRporter" (ppr ct) - ; maybeReportError ctxt 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 -ignoreErrorReporter ctxt cts - = do { traceTc "mkGivenErrorRporter 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 on. 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 to we don't report -either. - -The bottom line is this: find_gadt_match looks for an encosing -pattern match which binds some equality constraints. If we -find one, we report the insoluble Given. --} - -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) - -- Make error message for a group - -> Reporter -- Deal with lots of constraints --- Group together errors from same location, --- and report only the first (to avoid a cascade) -mkGroupReporter mk_err ctxt cts - = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts) - -eq_lhs_type :: Ct -> Ct -> Bool -eq_lhs_type ct1 ct2 - = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of - (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> - (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2) - _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2) - -cmp_loc :: Ct -> Ct -> Ordering -cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2) - -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt - -> [Ct] -> TcM () -reportGroup mk_err ctxt cts = - case partition isMonadFailInstanceMissing cts of - -- Only warn about missing MonadFail constraint when - -- there are no other missing constraints! - (monadFailCts, []) -> - do { err <- mk_err ctxt monadFailCts - ; reportWarning (Reason Opt_WarnMissingMonadFailInstances) err } - - (_, cts') -> do { err <- mk_err ctxt cts' - ; maybeReportError ctxt err - -- But see Note [Always warn with -fdefer-type-errors] - ; traceTc "reportGroup" (ppr cts') - ; mapM_ (addDeferredBinding ctxt err) cts' } - -- Add deferred bindings for all - -- Redundant if we are going to abort compilation, - -- but that's hard to know for sure, and if we don't - -- abort, we need bindings for all (e.g. Trac #12156) - where - isMonadFailInstanceMissing ct = - case ctLocOrigin (ctLoc ct) of - FailablePattern _pat -> True - _otherwise -> False - -maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM () -maybeReportHoleError ctxt ct err - -- When -XPartialTypeSignatures is on, warnings (instead of errors) are - -- generated for holes in partial type signatures. - -- Unless -fwarn_partial_type_signatures is not on, - -- in which case the messages are discarded. - | isTypeHoleCt ct - = -- For partial type signatures, generate warnings only, and do that - -- only if -fwarn_partial_type_signatures is on - case cec_type_holes ctxt of - HoleError -> reportError err - HoleWarn -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err - HoleDefer -> return () - - -- Always report an error for out-of-scope variables - -- Unless -fdefer-out-of-scope-variables is on, - -- in which case the messages are discarded. - -- See Trac #12170, #12406 - | isOutOfScopeCt ct - = -- If deferring, report a warning only if -Wout-of-scope-variables is on - case cec_out_of_scope_holes ctxt of - HoleError -> reportError err - HoleWarn -> - reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err - HoleDefer -> return () - - -- Otherwise this is a typed hole in an expression, - -- but not for an out-of-scope variable - | otherwise - = -- If deferring, report a warning only if -Wtyped-holes is on - case cec_expr_holes ctxt of - HoleError -> reportError err - HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err - HoleDefer -> return () - -maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM () --- Report the error and/or make a deferred binding for it -maybeReportError ctxt err - | cec_suppress ctxt -- Some worse error has occurred; - = return () -- so suppress this error/warning - - | cec_errors_as_warns ctxt - = reportWarning NoReason err - - | otherwise - = case cec_defer_type_errors ctxt of - TypeDefer -> return () - TypeWarn -> reportWarning (Reason Opt_WarnDeferredTypeErrors) err - TypeError -> reportError err - -addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () --- See Note [Deferring coercion errors to runtime] -addDeferredBinding ctxt err ct - | CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct - -- Only add deferred bindings for Wanted constraints - = do { dflags <- getDynFlags - ; let err_msg = pprLocErrMsg err - err_fs = mkFastString $ showSDoc dflags $ - err_msg $$ text "(deferred type error)" - err_tm = EvDelayedError pred err_fs - ev_binds_var = cec_binds ctxt - - ; case dest of - EvVarDest evar - -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm - HoleDest hole - -> do { -- See Note [Deferred errors for coercion holes] - evar <- newEvVar pred - ; addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm - ; fillCoercionHole hole (mkTcCoVarCo evar) }} - - | otherwise -- Do not set any evidence for Given/Derived - = return () - -maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () -maybeAddDeferredHoleBinding ctxt err ct - | isExprHoleCt ct - = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions - | otherwise -- not for holes in partial type signatures - = return () - -tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) --- Use the first reporter in the list whose predicate says True -tryReporters ctxt reporters cts - = do { traceTc "tryReporters {" (ppr cts) - ; (ctxt', cts') <- go ctxt reporters cts - ; traceTc "tryReporters }" (ppr cts') - ; return (ctxt', cts') } - where - go ctxt [] cts - = return (ctxt, cts) - - go ctxt (r : rs) cts - = do { (ctxt', cts') <- tryReporter ctxt r cts - ; go ctxt' rs 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) - ; reporter ctxt yeses - ; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt } - ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) - ; return (ctxt', nos) } - where - (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts - - -pprArising :: CtOrigin -> SDoc --- Used for the main, top-level error message --- We've done special processing for TypeEq, KindEq, Given -pprArising (TypeEqOrigin {}) = empty -pprArising (KindEqOrigin {}) = empty -pprArising (GivenOrigin {}) = empty -pprArising orig = pprCtOrigin orig - --- Add the "arising from..." part to a message about bunch of dicts -addArising :: CtOrigin -> SDoc -> SDoc -addArising orig msg = hang msg 2 (pprArising orig) - -pprWithArising :: [Ct] -> (CtLoc, SDoc) --- Print something like --- (Eq a) arising from a use of x at y --- (Show a) arising from a use of p at q --- Also return a location for the error message --- Works for Wanted/Derived only -pprWithArising [] - = panic "pprWithArising" -pprWithArising (ct:cts) - | null cts - = (loc, addArising (ctLocOrigin loc) - (pprTheta [ctPred ct])) - | otherwise - = (loc, vcat (map ppr_one (ct:cts))) - where - loc = ctLoc ct - ppr_one ct' = hang (parens (pprType (ctPred ct'))) - 2 (pprCtLoc (ctLoc ct')) - -mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg -mkErrorMsgFromCt ctxt ct report - = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report - -mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg -mkErrorReport ctxt tcl_env (Report important relevant_bindings) - = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env)) - (errDoc important [context] relevant_bindings) - } - -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 in wc_insols). We do not want to report -these as errors: - -* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have - an unsolved [D] Eq a, and we do not want to report that; it's just noise. - -* Functional dependencies. For givens, consider - class C a b | a -> b - data T a where - MkT :: C a d => [d] -> T a - f :: C a b => T a -> F Int - f (MkT xs) = length xs - Then we get a [D] b~d. But there *is* a legitimate call to - f, namely f (MkT [True]) :: T Bool, in which b=d. So we should - not reject the program. - - For wanteds, something similar - data T a where - MkT :: C Int b => a -> b -> T a - g :: C Int c => c -> () - f :: T a -> () - f (MkT x y) = g x - Here we get [G] C Int b, [W] C Int a, hence [D] a~b. - But again f (MkT True True) is a legitimate call. - -(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose -derived superclasses between iterations of the solver.) - -For functional dependencies, here is a real example, -stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs - - class C a b | a -> b - g :: C a b => a -> b -> () - f :: C a b => a -> b -> () - f xa xb = - let loop = g xa - in loop xb - -We will first try to infer a type for loop, and we will succeed: - C a b' => b' -> () -Subsequently, we will type check (loop xb) and all is good. But, -recall that we have to solve a final implication constraint: - C a b => (C a b' => .... cts from body of loop .... )) -And now we have a problem as we will generate an equality b ~ b' and fail to -solve it. - - -************************************************************************ -* * - Irreducible predicate errors -* * -************************************************************************ --} - -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkIrredErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) - ; mkErrorMsgFromCt ctxt ct1 $ - important msg `mappend` relevant_bindings binds_msg } - where - (ct1:_) = cts - ----------------- -mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg -mkHoleError _ctxt ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) }) - -- Out-of-scope variables, like 'a', where 'a' isn't bound; suggest possible - -- in-scope variables in the message, and note inaccessible exact matches - = do { dflags <- getDynFlags - ; imp_info <- getImports - ; let suggs_msg = unknownNameSuggestions dflags rdr_env0 - (tcl_rdr lcl_env) imp_info rdr - ; rdr_env <- getGlobalRdrEnv - ; splice_locs <- getTopLevelSpliceLocs - ; let match_msgs = mk_match_msgs rdr_env splice_locs - ; mkErrDocAt (RealSrcSpan err_loc) $ - errDoc [out_of_scope_msg] [] (match_msgs ++ [suggs_msg]) } - - where - rdr = mkRdrUnqual occ - ct_loc = ctLoc ct - lcl_env = ctLocEnv ct_loc - err_loc = tcl_loc lcl_env - hole_ty = ctEvPred (ctEvidence ct) - boring_type = isTyVarTy hole_ty - - out_of_scope_msg -- Print v :: ty only if the type has structure - | boring_type = hang herald 2 (ppr occ) - | otherwise = hang herald 2 (pp_with_type occ hole_ty) - - herald | isDataOcc occ = text "Data constructor not in scope:" - | otherwise = text "Variable not in scope:" - - -- Indicate if the out-of-scope variable exactly (and unambiguously) matches - -- a top-level binding in a later inter-splice group; see Note [OutOfScope - -- exact matches] - mk_match_msgs rdr_env splice_locs - = let gres = filter isLocalGRE (lookupGlobalRdrEnv rdr_env occ) - in case gres of - [gre] - | RealSrcSpan bind_loc <- greSrcSpan gre - -- Find splice between the unbound variable and the match; use - -- lookupLE, not lookupLT, since match could be in the splice - , Just th_loc <- Set.lookupLE bind_loc splice_locs - , err_loc < th_loc - -> [mk_bind_scope_msg bind_loc th_loc] - _ -> [] - - mk_bind_scope_msg bind_loc th_loc - | is_th_bind - = hang (quotes (ppr occ) <+> parens (text "splice on" <+> th_rng)) - 2 (text "is not in scope before line" <+> int th_start_ln) - | otherwise - = hang (quotes (ppr occ) <+> bind_rng <+> text "is not in scope") - 2 (text "before the splice on" <+> th_rng) - where - bind_rng = parens (text "line" <+> int bind_ln) - th_rng - | th_start_ln == th_end_ln = single - | otherwise = multi - single = text "line" <+> int th_start_ln - multi = text "lines" <+> int th_start_ln <> text "-" <> int th_end_ln - bind_ln = srcSpanStartLine bind_loc - th_start_ln = srcSpanStartLine th_loc - th_end_ln = srcSpanEndLine th_loc - is_th_bind = th_loc `containsSpan` bind_loc - -mkHoleError ctxt ct@(CHoleCan { cc_hole = hole }) - -- Explicit holes, like "_" or "_f" - = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct - -- The 'False' means "don't filter the bindings"; see Trac #8191 - - ; show_hole_constraints <- goptM Opt_ShowHoleConstraints - ; let constraints_msg - | isExprHoleCt ct, show_hole_constraints - = givenConstraintsMsg ctxt - | otherwise = empty - - ; mkErrorMsgFromCt ctxt ct $ - important hole_msg `mappend` - relevant_bindings (binds_msg $$ constraints_msg) } - - where - occ = holeOcc hole - hole_ty = ctEvPred (ctEvidence ct) - tyvars = tyCoVarsOfTypeList hole_ty - - hole_msg = case hole of - ExprHole {} -> vcat [ hang (text "Found hole:") - 2 (pp_with_type occ hole_ty) - , tyvars_msg, expr_hole_hint ] - TypeHole {} -> vcat [ hang (text "Found type wildcard" <+> - quotes (ppr occ)) - 2 (text "standing for" <+> - quotes (pprType hole_ty)) - , tyvars_msg, type_hole_hint ] - - tyvars_msg = ppUnless (null tyvars) $ - text "Where:" <+> vcat (map loc_msg tyvars) - - 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" - _ -> extraTyVarInfo ctxt tv - | otherwise - = sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitCoercions dflags - then quotes (ppr tv) <+> text "is a coercion variable" - else empty - -mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct) - - --- See Note [Constraints include ...] -givenConstraintsMsg :: ReportErrCtxt -> SDoc -givenConstraintsMsg ctxt = - let constraints :: [(Type, RealSrcSpan)] - constraints = - do { Implic{ ic_given = given, ic_env = env } <- cec_encl ctxt - ; constraint <- given - ; return (varType constraint, tcl_loc env) } - - pprConstraint (constraint, loc) = - ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) - - in ppUnless (null constraints) $ - hang (text "Constraints include") - 2 (vcat $ map pprConstraint constraints) - -pp_with_type :: OccName -> Type -> SDoc -pp_with_type occ ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType ty) - ----------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkIPErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - preds = map ctPred cts - givens = getUserGivens ctxt - msg | null givens - = addArising orig $ - sep [ text "Unbound implicit parameter" <> plural cts - , nest 2 (pprTheta preds) ] - | otherwise - = couldNotDeduce givens (preds, orig) - - ; mkErrorMsgFromCt ctxt ct1 $ - important msg `mappend` relevant_bindings binds_msg } - where - (ct1:_) = cts - -{- -Note [Constraints include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'givenConstraintsMsg' returns the "Constraints include ..." message enabled by --fshow-hole-constraints. For example, the following hole: - - foo :: (Eq a, Show a) => a -> String - foo x = _ - -would generate the message: - - Constraints include - Eq a (from foo.hs:1:1-36) - Show a (from foo.hs:1:1-36) - -Constraints are displayed in order from innermost (closest to the hole) to -outermost. There's currently no filtering or elimination of duplicates. - - -Note [OutOfScope exact matches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When constructing an out-of-scope error message, we not only generate a list of -possible in-scope alternatives but also search for an exact, unambiguous match -in a later inter-splice group. If we find such a match, we report its presence -(and indirectly, its scope) in the message. For example, if a module A contains -the following declarations, - - foo :: Int - foo = x - - $(return []) -- Empty top-level splice - - x :: Int - x = 23 - -we will issue an error similar to - - A.hs:6:7: error: - • Variable not in scope: x :: Int - • ‘x’ (line 11) is not in scope before the splice on line 8 - -By providing information about the match, we hope to clarify why declaring a -variable after a top-level splice but using it before the splice generates an -out-of-scope error (a situation which is often confusing to Haskell newcomers). - -Note that if we find multiple exact matches to the out-of-scope variable -(hereafter referred to as x), we report nothing. Such matches can only be -duplicate record fields, as the presence of any other duplicate top-level -declarations would have already halted compilation. But if these record fields -are declared in a later inter-splice group, then so too are their corresponding -types. Thus, these types must not occur in the inter-splice group containing x -(any unknown types would have already been reported), and so the matches to the -record fields are most likely coincidental. - -One oddity of the exact match portion of the error message is that we specify -where the match to x is NOT in scope. Why not simply state where the match IS -in scope? It most cases, this would be just as easy and perhaps a little -clearer for the user. But now consider the following example: - - {-# LANGUAGE TemplateHaskell #-} - - module A where - - import Language.Haskell.TH - import Language.Haskell.TH.Syntax - - foo = x - - $(do ------------------------------------------------- - ds <- [d| ok1 = x - |] - addTopDecls ds - return []) - - bar = $(do - ds <- [d| x = 23 - ok2 = x - |] - addTopDecls ds - litE $ stringL "hello") - - $(return []) ----------------------------------------- - - ok3 = x - -Here, x is out-of-scope in the declaration of foo, and so we report - - A.hs:8:7: error: - • Variable not in scope: x - • ‘x’ (line 16) is not in scope before the splice on lines 10-14 - -If we instead reported where x IS in scope, we would have to state that it is in -scope after the second top-level splice as well as among all the top-level -declarations added by both calls to addTopDecls. But doing so would not only -add complexity to the code but also overwhelm the user with unneeded -information. - -The logic which determines where x is not in scope is straightforward: it simply -finds the last top-level splice which occurs after x but before (or at) the -match to x (assuming such a splice exists). In most cases, the check that the -splice occurs after x acts only as a sanity check. For example, when the match -to x is a non-TH top-level declaration and a splice S occurs before the match, -then x must precede S; otherwise, it would be in scope. But when dealing with -addTopDecls, this check serves a practical purpose. Consider the following -declarations: - - $(do - ds <- [d| ok = x - x = 23 - |] - addTopDecls ds - return []) - - foo = x - -In this case, x is not in scope in the declaration for foo. Since x occurs -AFTER the splice containing the match, the logic does not find any splices after -x but before or at its match, and so we report nothing about x's scope. If we -had not checked whether x occurs before the splice, we would have instead -reported that x is not in scope before the splice. While correct, such an error -message is more likely to confuse than to enlighten. --} - -{- -************************************************************************ -* * - Equality errors -* * -************************************************************************ - -Note [Inaccessible code] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a where - T1 :: T a - T2 :: T Bool - - f :: (a ~ Int) => T a -> Int - f T1 = 3 - f T2 = 4 -- Unreachable code - -Here the second equation is unreachable. The original constraint -(a~Int) from the signature gets rewritten by the pattern-match to -(Bool~Int), so the danger is that we report the error as coming from -the *signature* (Trac #7293). So, for Given errors we replace the -env (and hence src-loc) on its CtLoc with that from the immediately -enclosing implication. - -Note [Error messages for untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #9109) - data G a where { GBool :: G Bool } - foo x = case x of GBool -> True - -Here we can't solve (t ~ Bool), where t is the untouchable result -meta-var 't', because of the (a ~ Bool) from the pattern match. -So we infer the type - f :: forall a t. G a -> t -making the meta-var 't' into a skolem. So when we come to report -the unsolved (t ~ Bool), t won't look like an untouchable meta-var -any more. So we don't assert that it is. --} - -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg --- Don't have multiple equality errors from the same location --- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct -mkEqErr _ [] = panic "mkEqErr" - -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg -mkEqErr1 ctxt ct -- Wanted or derived; - -- givens handled in mkGivenErrorReporter - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; rdr_env <- getGlobalRdrEnv - ; fam_envs <- tcGetFamInstEnvs - ; exp_syns <- goptM Opt_PrintExpandedSynonyms - ; let (keep_going, is_oriented, wanted_msg) - = mk_wanted_extra (ctLoc ct) exp_syns - coercible_msg = case ctEqRel ct of - NomEq -> empty - ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - ; dflags <- getDynFlags - ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) - ; let report = mconcat [important wanted_msg, important coercible_msg, - relevant_bindings binds_msg] - ; if keep_going - then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2 - else mkErrorMsgFromCt ctxt ct report } - where - (ty1, ty2) = getEqPredTys (ctPred ct) - - -- If the types in the error message are the same as the types - -- we are unifying, don't add the extra expected/actual message - mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc) - mk_wanted_extra loc expandSyns - = case ctLocOrigin loc of - orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig - t_or_k expandSyns - where - t_or_k = ctLocTypeOrKind_maybe loc - - KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k - -> (True, Nothing, msg1 $$ msg2) - where - sub_what = case sub_t_or_k of Just KindLevel -> text "kinds" - _ -> text "types" - msg1 = sdocWithDynFlags $ \dflags -> - case mb_cty2 of - Just cty2 - | gopt Opt_PrintExplicitCoercions dflags - || not (cty1 `pickyEqType` cty2) - -> hang (text "When matching" <+> sub_what) - 2 (vcat [ ppr cty1 <+> dcolon <+> - ppr (typeKind cty1) - , ppr cty2 <+> dcolon <+> - ppr (typeKind cty2) ]) - _ -> text "When matching the kind of" <+> quotes (ppr cty1) - msg2 = case sub_o of - TypeEqOrigin {} - | Just cty2 <- mb_cty2 -> - thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k - expandSyns) - _ -> empty - _ -> (True, Nothing, empty) - --- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint --- is left over. -mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs - -> TcType -> TcType -> SDoc -mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = msg - | Just (tc, tys) <- splitTyConApp_maybe ty2 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = msg - | Just (s1, _) <- tcSplitAppTy_maybe ty1 - , Just (s2, _) <- tcSplitAppTy_maybe ty2 - , s1 `eqType` s2 - , has_unknown_roles s1 - = hang (text "NB: We cannot know what roles the parameters to" <+> - quotes (ppr s1) <+> text "have;") - 2 (text "we must assume that the role is nominal") - | otherwise - = empty - where - coercible_msg_for_tycon tc - | isAbstractTyCon tc - = Just $ hsep [ text "NB: The type constructor" - , quotes (pprSourceTyCon tc) - , text "is abstract" ] - | isNewTyCon tc - , [data_con] <- tyConDataCons tc - , let dc_name = dataConName data_con - , isNothing (lookupGRE_Name rdr_env dc_name) - = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name)) - 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) - , text "is not in scope" ]) - | otherwise = Nothing - - has_unknown_roles ty - | Just (tc, tys) <- tcSplitTyConApp_maybe ty - = length tys >= tyConArity tc -- oversaturated tycon - | Just (s, _) <- tcSplitAppTy_maybe ty - = has_unknown_roles s - | isTyVarTy ty - = True - | otherwise - = False - -{- --- | Make a listing of role signatures for all the parameterised tycons --- used in the provided types - - --- SLPJ Jun 15: I could not convince myself that these hints were really --- useful. Maybe they are, but I think we need more work to make them --- actually helpful. -mkRoleSigs :: Type -> Type -> SDoc -mkRoleSigs ty1 ty2 - = ppUnless (null role_sigs) $ - hang (text "Relevant role signatures:") - 2 (vcat role_sigs) - where - tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2 - role_sigs = mapMaybe ppr_role_sig tcs - - ppr_role_sig tc - | null roles -- if there are no parameters, don't bother printing - = Nothing - | isBuiltInSyntax (tyConName tc) -- don't print roles for (->), etc. - = Nothing - | otherwise - = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles - where - roles = tyConRoles tc --} - -mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report - -> Ct - -> Maybe SwapFlag -- Nothing <=> not sure - -> TcType -> TcType -> TcM ErrMsg -mkEqErr_help dflags ctxt report ct oriented ty1 ty2 - | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt report ct swapped tv2 ty1 - | otherwise = reportEqErr ctxt report ct oriented ty1 ty2 - where - swapped = fmap flipSwap oriented - -reportEqErr :: ReportErrCtxt -> Report - -> Ct - -> Maybe SwapFlag -- Nothing <=> not sure - -> TcType -> TcType -> TcM ErrMsg -reportEqErr ctxt report ct oriented ty1 ty2 - = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo]) - where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2 - eqInfo = important $ mkEqInfoMsg ct ty1 ty2 - -mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg --- tv1 and ty2 are already tidied -mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 - | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would - -- be oriented the other way round; - -- see TcCanonical.canEqTyVarTyVar - || isSigTyVar tv1 && not (isTyVarTy ty2) - || ctEqRel ct == ReprEq && not insoluble_occurs_check - -- the cases below don't really apply to ReprEq (except occurs check) - = mkErrorMsgFromCt ctxt ct $ mconcat - [ important $ misMatchOrCND ctxt ct oriented ty1 ty2 - , important $ extraTyVarEqInfo ctxt tv1 ty2 - , report - ] - - | OC_Occurs <- occ_check_expand - -- We report an "occurs check" even for a ~ F t a, where F is a type - -- function; it's not insouble (because in principle F could reduce) - -- but we have certainly been unable to solve it - -- See Note [Occurs check error] in TcCanonical - = do { let main_msg = addArising (ctOrigin ct) $ - hang (text "Occurs check: cannot construct the infinite" <+> what <> colon) - 2 (sep [ppr ty1, char '~', ppr ty2]) - - extra2 = important $ mkEqInfoMsg ct ty1 ty2 - - interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ - filter isTyVar $ - fvVarList $ - tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - extra3 = relevant_bindings $ - ppWhen (not (null interesting_tyvars)) $ - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyVarOcc (cec_tidy ctxt)) - interesting_tyvars) - - tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - ; mkErrorMsgFromCt ctxt ct $ - mconcat [important main_msg, extra2, extra3, report] } - - | OC_Bad <- occ_check_expand - = do { let msg = vcat [ text "Cannot instantiate unification variable" - <+> quotes (ppr tv1) - , hang (text "with a" <+> what <+> text "involving foralls:") 2 (ppr ty2) - , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ] - -- Unlike the other reports, this discards the old 'report_important' - -- instead of augmenting it. This is because the details are not likely - -- to be helpful since this is just an unimplemented feature. - ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } } - - -- 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 SigTv, else it'd have been unified, given - -- that there's no occurs-check or forall problem - | (implic:_) <- cec_encl ctxt - , Implic { ic_skols = skols } <- implic - , tv1 `elem` skols - = mkErrorMsgFromCt ctxt ct $ mconcat - [ important $ misMatchMsg ct oriented ty1 ty2 - , important $ extraTyVarEqInfo ctxt tv1 ty2 - , report - ] - - -- Check for skolem escape - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic - , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols - , not (null esc_skols) - = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 - esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols - <+> pprQuotedList esc_skols - , text "would escape" <+> - if isSingleton esc_skols then text "its scope" - else text "their scope" ] - tv_extra = important $ - vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then text "This (rigid, skolem)" <+> - what <+> text "variable is" - else text "These (rigid, skolem)" <+> - what <+> text "variables are") - <+> text "bound by" - , nest 2 $ ppr skol_info - , nest 2 $ text "at" <+> ppr (tcl_loc env) ] ] - ; 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 SigTv, else it'd have been unified - -- See Note [Error messages for untouchables] - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_env = env, ic_given = given - , ic_tclvl = lvl, ic_info = skol_info } <- implic - = ASSERT2( not (isTouchableMetaTyVar lvl tv1) - , ppr tv1 ) -- See Note [Error messages for untouchables] - do { let msg = important $ misMatchMsg ct oriented ty1 ty2 - tclvl_extra = important $ - nest 2 $ - sep [ quotes (ppr tv1) <+> text "is untouchable" - , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given - , nest 2 $ text "bound by" <+> ppr skol_info - , nest 2 $ text "at" <+> ppr (tcl_loc env) ] - tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2 - add_sig = important $ suggestAddSig ctxt ty1 ty2 - ; mkErrorMsgFromCt ctxt ct $ mconcat - [msg, tclvl_extra, tv_extra, add_sig, report] } - - | otherwise - = reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2 - -- This *can* happen (Trac #6123, and test T2627b) - -- Consider an ambiguous top-level constraint (a ~ F a) - -- Not an occurs check, because F is a type function. - where - ty1 = mkTyVarTy tv1 - occ_check_expand = occCheckForErrors dflags tv1 ty2 - insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2 - - what = case ctLocTypeOrKind_maybe (ctLoc ct) of - Just KindLevel -> text "kind" - _ -> text "type" - -mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc --- Report (a) ambiguity if either side is a type function application --- e.g. F a0 ~ Int --- (b) warning about injectivity if both sides are the same --- type function application F a ~ F b --- See Note [Non-injective type functions] --- (c) warning about -fprint-explicit-kinds if that might be helpful -mkEqInfoMsg ct ty1 ty2 - = tyfun_msg $$ ambig_msg $$ invis_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 - - -- better to check the exp/act types in the CtOrigin than the actual - -- mismatched types for suggestion about -fprint-explicit-kinds - (act_ty, exp_ty) = case ctOrigin ct of - TypeEqOrigin { uo_actual = act - , uo_expected = exp } -> (act, exp) - _ -> (ty1, ty2) - - invis_msg | Just vis <- tcEqTypeVis act_ty exp_ty - , not vis - = ppSuggestExplicitKinds - | otherwise - = empty - - tyfun_msg | Just tc1 <- mb_fun1 - , Just tc2 <- mb_fun2 - , tc1 == tc2 - = text "NB:" <+> quotes (ppr tc1) - <+> text "is a type function, and may not be injective" - | otherwise = empty - -isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool --- See Note [Reporting occurs-check errors] -isUserSkolem ctxt tv - = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt) - where - is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info }) - = tv `elem` sks && is_user_skol_info skol_info - - is_user_skol_info (InferSkol {}) = False - is_user_skol_info _ = True - -misMatchOrCND :: ReportErrCtxt -> Ct - -> Maybe SwapFlag -> TcType -> TcType -> SDoc --- If oriented then ty1 is actual, ty2 is expected -misMatchOrCND ctxt ct oriented ty1 ty2 - | null givens || - (isRigidTy ty1 && isRigidTy ty2) || - isGivenCt ct - -- If the equality is unconditionally insoluble - -- or there is no context, don't report the context - = misMatchMsg ct oriented ty1 ty2 - | otherwise - = couldNotDeduce givens ([eq_pred], orig) - where - ev = ctEvidence ct - eq_pred = ctEvPred ev - orig = ctEvOrigin ev - givens = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)] - -- Keep only UserGivens that have some equalities - -couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc -couldNotDeduce givens (wanteds, orig) - = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) - , vcat (pp_givens givens)] - -pp_givens :: [UserGiven] -> [SDoc] -pp_givens givens - = case givens of - [] -> [] - (g:gs) -> ppr_given (text "from the context:") g - : map (ppr_given (text "or from:")) gs - where - ppr_given herald (Implic { ic_given = gs, ic_info = skol_info - , ic_env = env }) - = hang (herald <+> pprEvVarTheta gs) - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> ppr (tcl_loc env) ]) - -extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc --- Add on extra info about skolem constants --- NB: The types themselves are already tidied -extraTyVarEqInfo ctxt tv1 ty2 - = extraTyVarInfo ctxt tv1 $$ ty_extra ty2 - where - ty_extra ty = case tcGetTyVar_maybe ty of - Just tv -> extraTyVarInfo ctxt tv - Nothing -> empty - -extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc -extraTyVarInfo ctxt tv - = ASSERT2( isTyVar tv, ppr tv ) - case tcTyVarDetails tv of - SkolemTv {} -> pprSkol implics tv - FlatSkol {} -> pp_tv <+> text "is a flattening type variable" - RuntimeUnk {} -> pp_tv <+> text "is an interactive-debugger skolem" - MetaTv {} -> empty - where - implics = cec_encl ctxt - pp_tv = quotes (ppr tv) - -suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc --- See Note [Suggest adding a type signature] -suggestAddSig ctxt ty1 ty2 - | null inferred_bndrs - = empty - | [bndr] <- inferred_bndrs - = text "Possible fix: add a type signature for" <+> quotes (ppr bndr) - | otherwise - = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) - where - inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2) - get_inf ty | Just tv <- tcGetTyVar_maybe ty - , isSkolemTyVar tv - , InferSkol prs <- ic_info (getSkolemInfo (cec_encl ctxt) tv) - = map fst prs - | otherwise - = [] - --------------------- -misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc --- Types are already tidy --- If oriented then ty1 is actual, ty2 is expected -misMatchMsg ct oriented ty1 ty2 - | Just NotSwapped <- oriented - = misMatchMsg ct (Just IsSwapped) ty2 ty1 - - -- These next two cases are when we're about to report, e.g., that - -- 'LiftedRep doesn't match 'VoidRep. Much better just to say - -- lifted vs. unlifted - | Just (tc1, []) <- splitTyConApp_maybe ty1 - , tc1 `hasKey` liftedRepDataConKey - = lifted_vs_unlifted - - | Just (tc2, []) <- splitTyConApp_maybe ty2 - , tc2 `hasKey` liftedRepDataConKey - = lifted_vs_unlifted - - | otherwise -- So now we have Nothing or (Just IsSwapped) - -- For some reason we treat Nothing like IsSwapped - = addArising orig $ - sep [ text herald1 <+> quotes (ppr ty1) - , nest padding $ - text herald2 <+> quotes (ppr ty2) - , sameOccExtra ty2 ty1 ] - where - herald1 = conc [ "Couldn't match" - , if is_repr then "representation of" else "" - , if is_oriented then "expected" else "" - , what ] - herald2 = conc [ "with" - , if is_repr then "that of" else "" - , if is_oriented then ("actual " ++ what) else "" ] - padding = length herald1 - length herald2 - - is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } - is_oriented = isJust oriented - - orig = ctOrigin ct - what = case ctLocTypeOrKind_maybe (ctLoc ct) of - Just KindLevel -> "kind" - _ -> "type" - - conc :: [String] -> String - conc = foldr1 add_space - - add_space :: String -> String -> String - add_space s1 s2 | null s1 = s2 - | null s2 = s1 - | otherwise = s1 ++ (' ' : s2) - - lifted_vs_unlifted - = addArising orig $ - text "Couldn't match a lifted type with an unlifted type" - -mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool - -> (Bool, Maybe SwapFlag, SDoc) --- NotSwapped means (actual, expected), IsSwapped is the reverse --- First return val is whether or not to print a herald above this msg -mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act - , uo_expected = exp - , uo_thing = maybe_thing }) - m_level printExpanded - | KindLevel <- level, occurs_check_error = (True, Nothing, empty) - | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2) - | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3) - | isLiftedTypeKind exp && not (isConstraintKind exp) - = (False, Nothing, msg4) - | Just msg <- num_args_msg = (False, Nothing, msg $$ msg1) - | KindLevel <- level, Just th <- maybe_thing = (False, Nothing, msg5 th) - | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty) - | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty) - | otherwise = (True, Nothing, msg1) - where - level = m_level `orElse` TypeLevel - - occurs_check_error - | Just act_tv <- tcGetTyVar_maybe act - , act_tv `elemVarSet` tyCoVarsOfType exp - = True - | Just exp_tv <- tcGetTyVar_maybe exp - , exp_tv `elemVarSet` tyCoVarsOfType act - = True - | otherwise - = False - - sort = case level of - TypeLevel -> text "type" - KindLevel -> text "kind" - - msg1 = case level of - KindLevel - | Just th <- maybe_thing - -> msg5 th - - _ | not (act `pickyEqType` exp) - -> vcat [ text "Expected" <+> sort <> colon <+> ppr exp - , text " Actual" <+> sort <> colon <+> ppr act - , if printExpanded then expandedTys else empty ] - - | otherwise - -> empty - - thing_msg = case maybe_thing of - Just thing -> \_ -> quotes (ppr thing) <+> text "is" - Nothing -> \vowel -> text "got a" <> - if vowel then char 'n' else empty - msg2 = sep [ text "Expecting a lifted type, but" - , thing_msg True, text "unlifted" ] - msg3 = sep [ text "Expecting an unlifted type, but" - , thing_msg False, text "lifted" ] - msg4 = maybe_num_args_msg $$ - sep [ text "Expected a type, but" - , maybe (text "found something with kind") - (\thing -> quotes (ppr thing) <+> text "has kind") - maybe_thing - , quotes (ppr act) ] - - msg5 th = hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes (ppr th) <+> text "has kind" <+> - quotes (ppr act)) - where - kind_desc | isConstraintKind exp = text "a constraint" - | otherwise = text "kind" <+> quotes (ppr exp) - - num_args_msg = case level of - TypeLevel -> Nothing - KindLevel - -> let n_act = count_args act - n_exp = count_args exp in - case n_act - n_exp of - n | n /= 0 - , Just thing <- maybe_thing - , case errorThingNumArgs_maybe thing of - Nothing -> n > 0 - Just num_act_args -> num_act_args >= -n - -- don't report to strip off args that aren't there - -> Just $ text "Expecting" <+> speakN (abs n) <+> - more_or_fewer <+> quotes (ppr thing) - where - more_or_fewer - | n < 0 = text "fewer arguments to" - | n == 1 = text "more argument to" - | otherwise = text "more arguments to" -- n > 1 - _ -> Nothing - - maybe_num_args_msg = case num_args_msg of - Nothing -> empty - Just m -> m - - count_args ty = count isVisibleBinder $ fst $ splitPiTys ty - - expandedTys = - ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat - [ text "Type synonyms expanded:" - , text "Expected type:" <+> ppr expTy1 - , text " Actual type:" <+> ppr expTy2 - ] - - (expTy1, expTy2) = expandSynonymsToMatch exp act - -mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg" - -{- -Note [Expanding type synonyms to make types similar] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In type error messages, if -fprint-expanded-types is used, we want to expand -type synonyms to make expected and found types as similar as possible, but we -shouldn't expand types too much to make type messages even more verbose and -harder to understand. The whole point here is to make the difference in expected -and found types clearer. - -`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms -only as much as necessary. Given two types t1 and t2: - - * If they're already same, it just returns the types. - - * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are - type constructors), it expands C1 and C2 if they're different type synonyms. - Then it recursively does the same thing on expanded types. If C1 and C2 are - same, then it applies the same procedure to arguments of C1 and arguments of - C2 to make them as similar as possible. - - Most important thing here is to keep number of synonym expansions at - minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, - Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and - `T (T3, T3, Bool)`. - - * Otherwise types don't have same shapes and so the difference is clearly - visible. It doesn't do any expansions and show these types. - -Note that we only expand top-layer type synonyms. Only when top-layer -constructors are the same we start expanding inner type synonyms. - -Suppose top-layer type synonyms of t1 and t2 can expand N and M times, -respectively. If their type-synonym-expanded forms will meet at some point (i.e. -will have same shapes according to `sameShapes` function), it's possible to find -where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) -comparisons. We first collect all the top-layer expansions of t1 and t2 in two -lists, then drop the prefix of the longer list so that they have same lengths. -Then we search through both lists in parallel, and return the first pair of -types that have same shapes. Inner types of these two types with same shapes -are then expanded using the same algorithm. - -In case they don't meet, we return the last pair of types in the lists, which -has top-layer type synonyms completely expanded. (in this case the inner types -are not expanded at all, as the current form already shows the type error) --} - --- | Expand type synonyms in given types only enough to make them as similar as --- possible. Returned types are the same in terms of used type synonyms. --- --- To expand all synonyms, see 'Type.expandTypeSynonyms'. --- --- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for --- some examples of how this should work. -expandSynonymsToMatch :: Type -> Type -> (Type, Type) -expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) - where - (ty1_ret, ty2_ret) = go ty1 ty2 - - -- | Returns (type synonym expanded version of first type, - -- type synonym expanded version of second type) - go :: Type -> Type -> (Type, Type) - go t1 t2 - | t1 `pickyEqType` t2 = - -- Types are same, nothing to do - (t1, t2) - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 = - -- Type constructors are same. They may be synonyms, but we don't - -- expand further. - let (tys1', tys2') = - unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2) - in (TyConApp tc1 tys1', TyConApp tc2 tys2') - - go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - - go (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in (mkFunTy t1_1' t1_2', mkFunTy t2_1' t2_2') - - go (ForAllTy b1 t1) (ForAllTy b2 t2) = - -- NOTE: We may have a bug here, but we just can't reproduce it easily. - -- See D1016 comments for details and our attempts at producing a test - -- case. Short version: We probably need RnEnv2 to really get this right. - let (t1', t2') = go t1 t2 - in (ForAllTy b1 t1', ForAllTy b2 t2') - - go (CastTy ty1 _) ty2 = go ty1 ty2 - go ty1 (CastTy ty2 _) = go ty1 ty2 - - go t1 t2 = - -- See Note [Expanding type synonyms to make types similar] for how this - -- works - let - t1_exp_tys = t1 : tyExpansions t1 - t2_exp_tys = t2 : tyExpansions t2 - t1_exps = length t1_exp_tys - t2_exps = length t2_exp_tys - dif = abs (t1_exps - t2_exps) - in - followExpansions $ - zipEqual "expandSynonymsToMatch.go" - (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) - (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) - - -- | Expand the top layer type synonyms repeatedly, collect expansions in a - -- list. The list does not include the original type. - -- - -- Example, if you have: - -- - -- type T10 = T9 - -- type T9 = T8 - -- ... - -- type T0 = Int - -- - -- `tyExpansions T10` returns [T9, T8, T7, ... Int] - -- - -- This only expands the top layer, so if you have: - -- - -- type M a = Maybe a - -- - -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) - tyExpansions :: Type -> [Type] - tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) - - -- | Drop the type pairs until types in a pair look alike (i.e. the outer - -- constructors are the same). - followExpansions :: [(Type, Type)] -> (Type, Type) - followExpansions [] = pprPanic "followExpansions" empty - followExpansions [(t1, t2)] - | sameShapes t1 t2 = go t1 t2 -- expand subtrees - | otherwise = (t1, t2) -- the difference is already visible - followExpansions ((t1, t2) : tss) - -- Traverse subtrees when the outer shapes are the same - | sameShapes t1 t2 = go t1 t2 - -- Otherwise follow the expansions until they look alike - | otherwise = followExpansions tss - - sameShapes :: Type -> Type -> Bool - sameShapes AppTy{} AppTy{} = True - sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 - sameShapes (FunTy {}) (FunTy {}) = True - sameShapes (ForAllTy {}) (ForAllTy {}) = True - sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 - sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 - sameShapes _ _ = False - -sameOccExtra :: TcType -> TcType -> SDoc --- See Note [Disambiguating (X ~ X) errors] -sameOccExtra ty1 ty2 - | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 - , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 - , let n1 = tyConName tc1 - n2 = tyConName tc2 - same_occ = nameOccName n1 == nameOccName n2 - same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2) - , n1 /= n2 -- Different Names - , same_occ -- but same OccName - = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) - | otherwise - = empty - where - ppr_from same_pkg nm - | isGoodSrcSpan loc - = hang (quotes (ppr nm) <+> text "is defined at") - 2 (ppr loc) - | otherwise -- Imported things have an UnhelpfulSrcSpan - = hang (quotes (ppr nm)) - 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) - , ppUnless (same_pkg || pkg == mainUnitId) $ - nest 4 $ text "in package" <+> quotes (ppr pkg) ]) - where - pkg = moduleUnitId mod - mod = nameModule nm - loc = nameSrcSpan nm - -{- -Note [Suggest adding a type signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The OutsideIn algorithm rejects GADT programs that don't have a principal -type, and indeed some that do. Example: - data T a where - MkT :: Int -> T Int - - f (MkT n) = n - -Does this have type f :: T a -> a, or f :: T a -> Int? -The error that shows up tends to be an attempt to unify an -untouchable type variable. So suggestAddSig sees if the offending -type variable is bound by an *inferred* signature, and suggests -adding a declared signature instead. - -This initially came up in Trac #8968, concerning pattern synonyms. - -Note [Disambiguating (X ~ X) errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Trac #8278 - -Note [Reporting occurs-check errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied -type signature, then the best thing is to report that we can't unify -a with [a], because a is a skolem variable. That avoids the confusing -"occur-check" error message. - -But nowadays when inferring the type of a function with no type signature, -even if there are errors inside, we still generalise its signature and -carry on. For example - f x = x:x -Here we will infer something like - f :: forall a. a -> [a] -with a deferred error of (a ~ [a]). So in the deferred unsolved constraint -'a' is now a skolem, but not one bound by the programmer in the context! -Here we really should report an occurs check. - -So isUserSkolem distinguishes the two. - -Note [Non-injective type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very confusing to get a message like - Couldn't match expected type `Depend s' - against inferred type `Depend s1' -so mkTyFunInfoMsg adds: - NB: `Depend' is type function, and hence may not be injective - -Warn of loopy local equalities that were dropped. - - -************************************************************************ -* * - Type-class errors -* * -************************************************************************ --} - -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkDictErr ctxt cts - = ASSERT( not (null cts) ) - do { inst_envs <- tcGetInstEnvs - ; let (ct1:_) = cts -- ct1 just for its location - min_cts = elim_superclasses cts - lookups = map (lookup_cls_inst inst_envs) min_cts - (no_inst_cts, overlap_cts) = partition is_no_inst lookups - - -- Report definite no-instance errors, - -- or (iff there are none) overlap errors - -- But we report only one of them (hence 'head') because they all - -- have the same source-location origin, to try avoid a cascade - -- of error from one location - ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; mkErrorMsgFromCt ctxt ct1 (important err) } - where - no_givens = null (getUserGivens ctxt) - - is_no_inst (ct, (matches, unifiers, _)) - = no_givens - && null matches - && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) - - lookup_cls_inst inst_envs ct - -- Note [Flattening in error message generation] - = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys)) - where - (clas, tys) = getClassPredTys (ctPred ct) - - - -- When simplifying [W] Ord (Set a), we need - -- [W] Eq a, [W] Ord a - -- but we really only want to report the latter - elim_superclasses cts - = filter (\ct -> any (eqType (ctPred ct)) min_preds) cts - where - min_preds = mkMinimalBySCs (map ctPred cts) - -mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) - -> TcM (ReportErrCtxt, SDoc) --- Report an overlap error if this class constraint results --- from an overlap (returning Left clas), otherwise return (Right pred) -mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped)) - | null matches -- No matches but perhaps several unifiers - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; candidate_insts <- get_candidate_instances - ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) } - - | null unsafe_overlapped -- Some matches => overlap errors - = return (ctxt, overlap_msg) - - | otherwise - = return (ctxt, safe_haskell_msg) - where - orig = ctOrigin ct - pred = ctPred ct - (clas, tys) = getClassPredTys pred - ispecs = [ispec | (ispec, _) <- matches] - unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] - useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) - -- useful_givens are the enclosing implications with non-empty givens, - -- modulo the horrid discardProvCtxtGivens - - get_candidate_instances :: TcM [ClsInst] - -- See Note [Report candidate instances] - get_candidate_instances - | [ty] <- tys -- Only try for single-parameter classes - = do { instEnvs <- tcGetInstEnvs - ; return (filter (is_candidate_inst ty) - (classInstances instEnvs clas)) } - | otherwise = return [] - - is_candidate_inst ty inst -- See Note [Report candidate instances] - | [other_ty] <- is_tys inst - , Just (tc1, _) <- tcSplitTyConApp_maybe ty - , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty - = let n1 = tyConName tc1 - n2 = tyConName tc2 - different_names = n1 /= n2 - same_occ_names = nameOccName n1 == nameOccName n2 - in different_names && same_occ_names - | otherwise = False - - cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc - cannot_resolve_msg ct candidate_insts binds_msg - = vcat [ no_inst_msg - , nest 2 extra_note - , vcat (pp_givens useful_givens) - , mb_patsyn_prov `orElse` empty - , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens)) - (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ]) - - , ppWhen (isNothing mb_patsyn_prov) $ - -- Don't suggest fixes for the provided context of a pattern - -- synonym; the right fix is to bind more in the pattern - show_fixes (ctxtFixes has_ambig_tvs pred implics - ++ drv_fixes) - , ppWhen (not (null candidate_insts)) - (hang (text "There are instances for similar types:") - 2 (vcat (map ppr candidate_insts))) ] - -- See Note [Report candidate instances] - where - orig = ctOrigin ct - -- See Note [Highlighting ambiguous type variables] - lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs) - && not (null unifiers) && null useful_givens - - (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct - ambig_tvs = uncurry (++) (getAmbigTkvs ct) - - no_inst_msg - | lead_with_ambig - = ambig_msg <+> pprArising orig - $$ text "prevents the constraint" <+> quotes (pprParendType pred) - <+> text "from being solved." - - | null useful_givens - = addArising orig $ text "No instance for" - <+> pprParendType pred - - | otherwise - = addArising orig $ text "Could not deduce" - <+> pprParendType pred - - potential_msg - = ppWhen (not (null unifiers) && want_potential orig) $ - sdocWithDynFlags $ \dflags -> - getPprStyle $ \sty -> - pprPotentials dflags sty potential_hdr unifiers - - potential_hdr - = vcat [ ppWhen lead_with_ambig $ - text "Probable fix: use a type annotation to specify what" - <+> pprQuotedList ambig_tvs <+> text "should be." - , text "These potential instance" <> plural unifiers - <+> text "exist:"] - - mb_patsyn_prov :: Maybe SDoc - mb_patsyn_prov - | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = 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 (typeKind ty))) - | otherwise - = empty - - drv_fixes = case orig of - DerivOrigin -> [drv_fix] - DerivOriginDC {} -> [drv_fix] - DerivOriginCoerce {} -> [drv_fix] - _ -> [] - - drv_fix = hang (text "use a standalone 'deriving instance' declaration,") - 2 (text "so you can specify the instance context yourself") - - -- Normal overlap error - overlap_msg - = ASSERT( not (null matches) ) - vcat [ addArising orig (text "Overlapping instances for" - <+> pprType (mkClassPred clas tys)) - - , ppUnless (null matching_givens) $ - sep [text "Matching givens (or their superclasses):" - , nest 2 (vcat matching_givens)] - - , sdocWithDynFlags $ \dflags -> - getPprStyle $ \sty -> - pprPotentials dflags sty (text "Matching instances:") $ - ispecs ++ unifiers - - , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ - -- Intuitively, some given matched the wanted in their - -- flattened or rewritten (from given equalities) form - -- but the matcher can't figure that out because the - -- constraints are non-flat and non-rewritten so we - -- simply report back the whole given - -- context. Accelerate Smart.hs showed this problem. - sep [ text "There exists a (perhaps superclass) match:" - , nest 2 (vcat (pp_givens useful_givens))] - - , ppWhen (isSingleton matches) $ - parens (vcat [ text "The choice depends on the instantiation of" <+> - quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys)) - , ppWhen (null (matching_givens)) $ - vcat [ text "To pick the first instance above, use IncoherentInstances" - , text "when compiling the other instance declarations"] - ])] - - matching_givens = mapMaybe matchable useful_givens - - matchable (Implic { ic_given = evvars, ic_info = skol_info, ic_env = env }) - = 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 env) ]) - where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) - ev_var_matches ty = case getClassPredTys_maybe ty of - Just (clas', tys') - | clas' == clas - , Just _ <- tcMatchTys tys tys' - -> True - | otherwise - -> any ev_var_matches (immSuperClasses clas' tys') - Nothing -> False - - -- Overlap error because of Safe Haskell (first - -- match should be the most specific match) - safe_haskell_msg - = ASSERT( length matches == 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 Trac #9611. - -Note [Highlighting ambiguous type variables] -~------------------------------------------- -When we encounter ambiguous type variables (i.e. type variables -that remain metavariables after type inference), we need a few more -conditions before we can reason that *ambiguity* prevents constraints -from being solved: - - We can't have any givens, as encountering a typeclass error - with given constraints just means we couldn't deduce - a solution satisfying those constraints and as such couldn't - bind the type variable to a known type. - - If we don't have any unifiers, we don't even have potential - instances from which an ambiguity could arise. - - Lastly, I don't want to mess with error reporting for - unknown runtime types so we just fall back to the old message there. -Once these conditions are satisfied, we can safely say that ambiguity prevents -the constraint from being solved. - -Note [discardProvCtxtGivens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In most situations we call all enclosing implications "useful". There is one -exception, and that is when the constraint that causes the error is from the -"provided" context of a pattern synonym declaration: - - pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a - -- required => provided => type - pattern Pat x <- (Just x, 4) - -When checking the pattern RHS we must check that it does actually bind all -the claimed "provided" constraints; in this case, does the pattern (Just x, 4) -bind the (Show a) constraint. Answer: no! - -But the implication we generate for this will look like - forall a. (Num a, Eq a) => [W] Show a -because when checking the pattern we must make the required -constraints available, since they are needed to match the pattern (in -this case the literal '4' needs (Num a, Eq a)). - -BUT we don't want to suggest adding (Show a) to the "required" constraints -of the pattern synonym, thus: - pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a -It would then typecheck but it's silly. We want the /pattern/ to bind -the alleged "provided" constraints, Show a. - -So we suppress that Implication in discardProvCtxtGivens. It's -painfully ad-hoc but the truth is that adding it to the "required" -constraints would work. Suprressing it solves two problems. First, -we never tell the user that we could not deduce a "provided" -constraint from the "required" context. Second, we never give a -possible fix that suggests to add a "provided" constraint to the -"required" context. - -For example, without this distinction the above code gives a bad error -message (showing both problems): - - error: Could not deduce (Show a) ... from the context: (Eq a) - ... Possible fix: add (Show a) to the context of - the signature for pattern synonym `Pat' ... - --} - -show_fixes :: [SDoc] -> SDoc -show_fixes [] = empty -show_fixes (f:fs) = sep [ text "Possible fix:" - , nest 2 (vcat (f : map (text "or" <+>) fs))] - -pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc --- See Note [Displaying potential instances] -pprPotentials dflags sty herald insts - | null insts - = empty - - | null show_these - = hang herald - 2 (vcat [ not_in_scope_msg empty - , flag_hint ]) - - | otherwise - = hang herald - 2 (vcat [ pprInstances show_these - , ppWhen (n_in_scope_hidden > 0) $ - text "...plus" - <+> speakNOf n_in_scope_hidden (text "other") - , not_in_scope_msg (text "...plus") - , flag_hint ]) - where - n_show = 3 :: Int - show_potentials = gopt Opt_PrintPotentialInstances dflags - - (in_scope, not_in_scope) = partition inst_in_scope insts - sorted = sortBy fuzzyClsInstCmp in_scope - show_these | show_potentials = sorted - | otherwise = take n_show sorted - n_in_scope_hidden = length sorted - length show_these - - -- "in scope" means that all the type constructors - -- are lexically in scope; these instances are likely - -- to be more useful - inst_in_scope :: ClsInst -> Bool - inst_in_scope cls_inst = nameSetAll name_in_scope $ - orphNamesOfTypes (is_tys cls_inst) - - name_in_scope name - | isBuiltInSyntax name - = True -- E.g. (->) - | Just mod <- nameModule_maybe name - = qual_in_scope (qualName sty mod (nameOccName name)) - | otherwise - = True - - qual_in_scope :: QualifyName -> Bool - qual_in_scope NameUnqual = True - qual_in_scope (NameQual {}) = True - qual_in_scope _ = False - - not_in_scope_msg herald - | null not_in_scope - = empty - | otherwise - = hang (herald <+> speakNOf (length not_in_scope) (text "instance") - <+> text "involving out-of-scope types") - 2 (ppWhen show_potentials (pprInstances not_in_scope)) - - flag_hint = ppUnless (show_potentials || length show_these == length insts) $ - text "(use -fprint-potential-instances to see them all)" - -{- Note [Displaying potential instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When showing a list of instances for - - overlapping instances (show ones that match) - - no such instance (show ones that could match) -we want to give it a bit of structure. Here's the plan - -* Say that an instance is "in scope" if all of the - type constructors it mentions are lexically in scope. - These are the ones most likely to be useful to the programmer. - -* Show at most n_show in-scope instances, - and summarise the rest ("plus 3 others") - -* Summarise the not-in-scope instances ("plus 4 not in scope") - -* Add the flag -fshow-potential-instances which replaces the - summary with the full list --} - -{- -Note [Flattening in error message generation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (C (Maybe (F x))), where F is a type function, and we have -instances - C (Maybe Int) and C (Maybe a) -Since (F x) might turn into Int, this is an overlap situation, and -indeed (because of flattening) the main solver will have refrained -from solving. But by the time we get to error message generation, we've -un-flattened the constraint. So we must *re*-flatten it before looking -up in the instance environment, lest we only report one matching -instance when in fact there are two. - -Re-flattening is pretty easy, because we don't need to keep track of -evidence. We don't re-use the code in TcCanonical because that's in -the TcS monad, and we are in TcM here. - -Note [Suggest -fprint-explicit-kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It can be terribly confusing to get an error message like (Trac #9171) - Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ - with actual type ‘GetParam Base (GetParam Base Int)’ -The reason may be that the kinds don't match up. Typically you'll get -more useful information, but not when it's as a result of ambiguity. -This test suggests -fprint-explicit-kinds when all the ambiguous type -variables are kind variables. --} - -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 -- All ambiguous kind variabes; suggest -fprint-explicit-kinds - -- See Note [Suggest -fprint-explicit-kinds] - = vcat [ pp_ambig (text "kind") ambig_kvs - , ppSuggestExplicitKinds ] - - pp_ambig what tkvs - | prepend_msg -- "Ambiguous type variable 't0'" - = text "Ambiguous" <+> what <+> text "variable" - <> plural tkvs <+> pprQuotedList tkvs - - | otherwise -- "The type variable 't0' is ambiguous" - = text "The" <+> what <+> text "variable" <> plural tkvs - <+> pprQuotedList tkvs <+> is_or_are tkvs <+> text "ambiguous" - - is_or_are [_] = text "is" - is_or_are _ = text "are" - -pprSkol :: [Implication] -> TcTyVar -> SDoc -pprSkol implics tv - = case skol_info of - UnkSkol -> quotes (ppr tv) <+> text "is an unknown type variable" - _ -> ppr_rigid (pprSkolInfo skol_info) - where - Implic { ic_info = skol_info } = getSkolemInfo implics tv - ppr_rigid pp_info - = hang (quotes (ppr tv) <+> text "is a rigid type variable bound by") - 2 (sep [ pp_info - , text "at" <+> ppr (getSrcSpan tv) ]) - -getAmbigTkvs :: Ct -> ([Var],[Var]) -getAmbigTkvs ct - = partition (`elemVarSet` dep_tkv_set) ambig_tkvs - where - tkvs = tyCoVarsOfCtList ct - ambig_tkvs = filter isAmbiguousTyVar tkvs - dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) - -getSkolemInfo :: [Implication] -> TcTyVar -> Implication --- Get the skolem info for a type variable --- from the implication constraint that binds it -getSkolemInfo [] tv - = pprPanic "No skolem info:" (ppr tv) - -getSkolemInfo (implic:implics) tv - | tv `elem` ic_skols implic = implic - | otherwise = getSkolemInfo implics tv - ------------------------ --- relevantBindings looks at the value environment and finds values whose --- types mention any of the offending type variables. It has to be --- careful to zonk the Id's type first, so it has to be in the monad. --- We must be careful to pass it a zonked type variable, too. --- --- We always remove closed top-level bindings, though, --- since they are never relevant (cf Trac #8233) - -relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering - -- See Trac #8191 - -> ReportErrCtxt -> Ct - -> TcM (ReportErrCtxt, SDoc, Ct) --- Also returns the zonked and tidied CtOrigin of the constraint -relevantBindings want_filtering ctxt ct - = do { dflags <- getDynFlags - ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) - ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs - - -- For *kind* errors, report the relevant bindings of the - -- enclosing *type* equality, because that's more useful for the programmer - extra_tvs = case tidy_orig of - KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $ - t1 : maybeToList m_t2 - _ -> emptyVarSet - ; traceTc "relevantBindings" $ - vcat [ ppr ct - , pprCtOrigin (ctLocOrigin loc) - , ppr ct_tvs - , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) - | TcIdBndr id _ <- tcl_bndrs lcl_env ] - , pprWithCommas id - [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] - - ; (tidy_env', docs, discards) - <- go dflags env1 ct_tvs (maxRelevantBinds dflags) - emptyVarSet [] False - (remove_shadowing $ tcl_bndrs lcl_env) - -- tcl_bndrs has the innermost bindings first, - -- which are probably the most relevant ones - - ; let doc = ppUnless (null docs) $ - hang (text "Relevant bindings include") - 2 (vcat docs $$ ppWhen discards discardMsg) - - -- Put a zonked, tidied CtOrigin into the Ct - loc' = setCtLocOrigin loc tidy_orig - ct' = setCtLoc ct loc' - ctxt' = ctxt { cec_tidy = tidy_env' } - - ; return (ctxt', doc, ct') } - where - ev = ctEvidence ct - loc = ctEvLoc ev - lcl_env = ctLocEnv loc - - run_out :: Maybe Int -> Bool - run_out Nothing = False - run_out (Just n) = n <= 0 - - dec_max :: Maybe Int -> Maybe Int - dec_max = fmap (\n -> n - 1) - - ---- fixes #12177 - ---- builds up a list of bindings whose OccName has not been seen before - remove_shadowing :: [TcIdBinder] -> [TcIdBinder] - remove_shadowing bindings = reverse $ fst $ foldl - (\(bindingAcc, seenNames) binding -> - if (occName binding) `elemOccSet` seenNames -- if we've seen it - then (bindingAcc, seenNames) -- skip it - else (binding:bindingAcc, extendOccSet seenNames (occName binding))) - ([], emptyOccSet) bindings - - go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc] - -> Bool -- True <=> some filtered out due to lack of fuel - -> [TcIdBinder] - -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out - -- because of lack of fuel - go _ tidy_env _ _ _ docs discards [] - = return (tidy_env, reverse docs, discards) - go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs) - = case tc_bndr of - TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl - TcIdBndr_ExpType name et top_lvl -> - do { mb_ty <- readExpType_maybe et - -- et really should be filled in by now. But there's a chance - -- it hasn't, if, say, we're reporting a kind error en route to - -- checking a term. See test indexed-types/should_fail/T8129 - -- Or we are reporting errors from the ambiguity check on - -- a local type signature - ; case mb_ty of - Just ty -> go2 name ty top_lvl - Nothing -> discard_it -- No info; discard - } - where - discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs - discards tc_bndrs - go2 id_name id_type top_lvl - = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type - ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) - ; let id_tvs = tyCoVarsOfType tidy_ty - doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (text "bound at" - <+> ppr (getSrcLoc id_name)))] - new_seen = tvs_seen `unionVarSet` id_tvs - - ; if (want_filtering && not (hasPprDebug dflags) - && id_tvs `disjointVarSet` ct_tvs) - -- We want to filter out this binding anyway - -- so discard it silently - then discard_it - - else if isTopLevel top_lvl && not (isNothing n_left) - -- It's a top-level binding and we have not specified - -- -fno-max-relevant-bindings, so discard it silently - then discard_it - - else if run_out n_left && id_tvs `subVarSet` tvs_seen - -- We've run out of n_left fuel and this binding only - -- mentions already-seen type variables, so discard it - then go dflags tidy_env ct_tvs n_left tvs_seen docs - True -- Record that we have now discarded something - tc_bndrs - - -- Keep this binding, decrement fuel - else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen - (doc:docs) discards tc_bndrs } - -discardMsg :: SDoc -discardMsg = text "(Some bindings suppressed;" <+> - text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" - ------------------------ -warnDefaulting :: [Ct] -> Type -> TcM () -warnDefaulting wanteds default_ty - = do { warn_default <- woptM Opt_WarnTypeDefaults - ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 $ - tyCoVarsOfCtsList (listToBag wanteds) - tidy_wanteds = map (tidyCt tidy_env) wanteds - (loc, ppr_wanteds) = pprWithArising tidy_wanteds - warn_msg = - hang (hsep [ text "Defaulting the following" - , text "constraint" <> plural tidy_wanteds - , text "to type" - , quotes (ppr default_ty) ]) - 2 - ppr_wanteds - ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg } - -{- -Note [Runtime skolems] -~~~~~~~~~~~~~~~~~~~~~~ -We want to give a reasonably helpful error message for ambiguity -arising from *runtime* skolems in the debugger. These -are created by in RtClosureInspect.zonkRTTIType. - -************************************************************************ -* * - Error from the canonicaliser - These ones are called *during* constraint simplification -* * -************************************************************************ --} - -solverDepthErrorTcS :: CtLoc -> TcType -> TcM a -solverDepthErrorTcS loc ty - = setCtLocM loc $ - do { ty <- zonkTcType ty - ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) - tidy_ty = tidyType tidy_env ty - msg - = vcat [ text "Reduction stack overflow; size =" <+> ppr depth - , hang (text "When simplifying the following type:") - 2 (ppr tidy_ty) - , note ] - ; failWithTcM (tidy_env, msg) } - where - depth = ctLocDepth loc - note = vcat - [ text "Use -freduction-depth=0 to disable this check" - , text "(any upper bound you could choose might fail unpredictably with" - , text " minor updates to GHC, so disabling the check is recommended if" - , text " you're sure that type checking should terminate)" ] diff --git a/typecheck/TcEvidence.hs b/typecheck/TcEvidence.hs deleted file mode 100644 --- a/typecheck/TcEvidence.hs +++ /dev/null @@ -1,948 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -module TcEvidence ( - - -- HsWrapper - HsWrapper(..), - (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, - mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders, - mkWpFun, mkWpFuns, idHsWrapper, isIdHsWrapper, pprHsWrapper, - - -- Evidence bindings - TcEvBinds(..), EvBindsVar(..), - EvBindMap(..), emptyEvBindMap, extendEvBinds, - lookupEvBind, evBindMapBinds, foldEvBindMap, isEmptyEvBindMap, - EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, - sccEvBinds, evBindVar, - EvTerm(..), mkEvCast, evVarsOfTerm, mkEvScSelectors, - EvLit(..), evTermCoercion, - EvCallStack(..), - EvTypeable(..), - - -- TcCoercion - TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, - Role(..), LeftOrRight(..), pickLR, - mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo, - mkTcTyConAppCo, mkTcAppCo, mkTcFunCo, - mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos, - mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo, - tcDowngradeRole, - mkTcAxiomRuleCo, mkTcCoherenceLeftCo, mkTcCoherenceRightCo, mkTcPhantomCo, - mkTcKindCo, - tcCoercionKind, coVarsOfTcCo, - mkTcCoVarCo, - isTcReflCo, - tcCoercionRole, - unwrapIP, wrapIP - ) where -#include "HsVersions.h" - -import Var -import CoAxiom -import Coercion -import PprCore () -- Instance OutputableBndr TyVar -import TcType -import Type -import TyCon -import Class( Class ) -import PrelNames -import DynFlags ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) ) -import VarEnv -import VarSet -import Name -import Pair - -import Util -import Bag -import Digraph -import qualified Data.Data as Data -import Outputable -import FastString -import SrcLoc -import Data.IORef( IORef ) -import UniqSet - -{- -Note [TcCoercions] -~~~~~~~~~~~~~~~~~~ -| TcCoercions are a hack used by the typechecker. Normally, -Coercions have free variables of type (a ~# b): we call these -CoVars. However, the type checker passes around equality evidence -(boxed up) at type (a ~ b). - -An TcCoercion is simply a Coercion whose free variables have may be either -boxed or unboxed. After we are done with typechecking the desugarer finds the -boxed free variables, unboxes them, and creates a resulting real Coercion with -kosher free variables. - --} - -type TcCoercion = Coercion -type TcCoercionN = CoercionN -- A Nominal coercion ~N -type TcCoercionR = CoercionR -- A Representational coercion ~R -type TcCoercionP = CoercionP -- a phantom coercion - -mkTcReflCo :: Role -> TcType -> TcCoercion -mkTcSymCo :: TcCoercion -> TcCoercion -mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion -mkTcNomReflCo :: TcType -> TcCoercionN -mkTcRepReflCo :: TcType -> TcCoercionR -mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion -mkTcAppCo :: TcCoercion -> TcCoercionN -> TcCoercion -mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion -mkTcAxInstCo :: Role -> CoAxiom br -> BranchIndex - -> [TcType] -> [TcCoercion] -> TcCoercion -mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] - -> [TcCoercion] -> TcCoercionR -mkTcForAllCo :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion -mkTcForAllCos :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion -mkTcNthCo :: Int -> TcCoercion -> TcCoercion -mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion -mkTcSubCo :: TcCoercionN -> TcCoercionR -maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion -tcDowngradeRole :: Role -> Role -> TcCoercion -> TcCoercion -mkTcAxiomRuleCo :: CoAxiomRule -> [TcCoercion] -> TcCoercionR -mkTcCoherenceLeftCo :: TcCoercion -> TcCoercionN -> TcCoercion -mkTcCoherenceRightCo :: TcCoercion -> TcCoercionN -> TcCoercion -mkTcPhantomCo :: TcCoercionN -> TcType -> TcType -> TcCoercionP -mkTcKindCo :: TcCoercion -> TcCoercionN -mkTcCoVarCo :: CoVar -> TcCoercion - -tcCoercionKind :: TcCoercion -> Pair TcType -tcCoercionRole :: TcCoercion -> Role -coVarsOfTcCo :: TcCoercion -> TcTyCoVarSet -isTcReflCo :: TcCoercion -> Bool - -mkTcReflCo = mkReflCo -mkTcSymCo = mkSymCo -mkTcTransCo = mkTransCo -mkTcNomReflCo = mkNomReflCo -mkTcRepReflCo = mkRepReflCo -mkTcTyConAppCo = mkTyConAppCo -mkTcAppCo = mkAppCo -mkTcFunCo = mkFunCo -mkTcAxInstCo = mkAxInstCo -mkTcUnbranchedAxInstCo = mkUnbranchedAxInstCo Representational -mkTcForAllCo = mkForAllCo -mkTcForAllCos = mkForAllCos -mkTcNthCo = mkNthCo -mkTcLRCo = mkLRCo -mkTcSubCo = mkSubCo -maybeTcSubCo = maybeSubCo -tcDowngradeRole = downgradeRole -mkTcAxiomRuleCo = mkAxiomRuleCo -mkTcCoherenceLeftCo = mkCoherenceLeftCo -mkTcCoherenceRightCo = mkCoherenceRightCo -mkTcPhantomCo = mkPhantomCo -mkTcKindCo = mkKindCo -mkTcCoVarCo = mkCoVarCo - -tcCoercionKind = coercionKind -tcCoercionRole = coercionRole -coVarsOfTcCo = coVarsOfCo -isTcReflCo = isReflCo - - -{- -%************************************************************************ -%* * - HsWrapper -* * -************************************************************************ --} - -data HsWrapper - = WpHole -- The identity coercion - - | WpCompose HsWrapper HsWrapper - -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] - -- - -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) - -- But ([] a) `WpCompose` ([] b) = ([] b a) - - | WpFun HsWrapper HsWrapper TcType SDoc - -- (WpFun wrap1 wrap2 t1)[e] = \(x:t1). wrap2[ e wrap1[x] ] - -- So note that if wrap1 :: exp_arg <= act_arg - -- wrap2 :: act_res <= exp_res - -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res) - -- This isn't the same as for mkFunCo, but it has to be this way - -- because we can't use 'sym' to flip around these HsWrappers - -- The TcType is the "from" type of the first wrapper - -- The SDoc explains the circumstances under which we have created this - -- WpFun, in case we run afoul of levity polymorphism restrictions in - -- the desugarer. See Note [Levity polymorphism checking] in DsMonad - - | WpCast TcCoercionR -- A cast: [] `cast` co - -- Guaranteed not the identity coercion - -- At role Representational - - -- Evidence abstraction and application - -- (both dictionaries and coercions) - | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable - | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint - -- Kind and Type abstraction and application - | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) - | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) - - - | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, - -- so that the identity coercion is always exactly WpHole - --- Cannot derive Data instance because SDoc is not Data (it stores a function). --- So we do it manually: -instance Data.Data HsWrapper where - gfoldl _ z WpHole = z WpHole - gfoldl k z (WpCompose a1 a2) = z WpCompose `k` a1 `k` a2 - gfoldl k z (WpFun a1 a2 a3 _) = z wpFunEmpty `k` a1 `k` a2 `k` a3 - gfoldl k z (WpCast a1) = z WpCast `k` a1 - gfoldl k z (WpEvLam a1) = z WpEvLam `k` a1 - gfoldl k z (WpEvApp a1) = z WpEvApp `k` a1 - gfoldl k z (WpTyLam a1) = z WpTyLam `k` a1 - gfoldl k z (WpTyApp a1) = z WpTyApp `k` a1 - gfoldl k z (WpLet a1) = z WpLet `k` a1 - - gunfold k z c = case Data.constrIndex c of - 1 -> z WpHole - 2 -> k (k (z WpCompose)) - 3 -> k (k (k (z wpFunEmpty))) - 4 -> k (z WpCast) - 5 -> k (z WpEvLam) - 6 -> k (z WpEvApp) - 7 -> k (z WpTyLam) - 8 -> k (z WpTyApp) - _ -> k (z WpLet) - - toConstr WpHole = wpHole_constr - toConstr (WpCompose _ _) = wpCompose_constr - toConstr (WpFun _ _ _ _) = wpFun_constr - toConstr (WpCast _) = wpCast_constr - toConstr (WpEvLam _) = wpEvLam_constr - toConstr (WpEvApp _) = wpEvApp_constr - toConstr (WpTyLam _) = wpTyLam_constr - toConstr (WpTyApp _) = wpTyApp_constr - toConstr (WpLet _) = wpLet_constr - - dataTypeOf _ = hsWrapper_dataType - -hsWrapper_dataType :: Data.DataType -hsWrapper_dataType - = Data.mkDataType "HsWrapper" - [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr - , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr - , wpLet_constr] - -wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr, - wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr :: Data.Constr -wpHole_constr = mkHsWrapperConstr "WpHole" -wpCompose_constr = mkHsWrapperConstr "WpCompose" -wpFun_constr = mkHsWrapperConstr "WpFun" -wpCast_constr = mkHsWrapperConstr "WpCast" -wpEvLam_constr = mkHsWrapperConstr "WpEvLam" -wpEvApp_constr = mkHsWrapperConstr "WpEvApp" -wpTyLam_constr = mkHsWrapperConstr "WpTyLam" -wpTyApp_constr = mkHsWrapperConstr "WpTyApp" -wpLet_constr = mkHsWrapperConstr "WpLet" - -mkHsWrapperConstr :: String -> Data.Constr -mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix - -wpFunEmpty :: HsWrapper -> HsWrapper -> TcType -> HsWrapper -wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty - -(<.>) :: HsWrapper -> HsWrapper -> HsWrapper -WpHole <.> c = c -c <.> WpHole = c -c1 <.> c2 = c1 `WpCompose` c2 - -mkWpFun :: HsWrapper -> HsWrapper - -> TcType -- the "from" type of the first wrapper - -> TcType -- either type of the second wrapper (used only when the - -- second wrapper is the identity) - -> SDoc -- what caused you to want a WpFun? Something like "When converting ..." - -> HsWrapper -mkWpFun WpHole WpHole _ _ _ = WpHole -mkWpFun WpHole (WpCast co2) t1 _ _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) -mkWpFun (WpCast co1) WpHole _ t2 _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) -mkWpFun (WpCast co1) (WpCast co2) _ _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) -mkWpFun co1 co2 t1 _ d = WpFun co1 co2 t1 d - --- | @mkWpFuns [(ty1, wrap1), (ty2, wrap2)] ty_res wrap_res@, --- where @wrap1 :: ty1 "->" ty1'@ and @wrap2 :: ty2 "->" ty2'@, --- @wrap3 :: ty3 "->" ty3'@ and @ty_res@ is /either/ @ty3@ or @ty3'@, --- gives a wrapper @(ty1' -> ty2' -> ty3) "->" (ty1 -> ty2 -> ty3')@. --- Notice that the result wrapper goes the other way round to all --- the others. This is a result of sub-typing contravariance. --- The SDoc is a description of what you were doing when you called mkWpFuns. -mkWpFuns :: [(TcType, HsWrapper)] -> TcType -> HsWrapper -> SDoc -> HsWrapper -mkWpFuns args res_ty res_wrap doc = snd $ go args res_ty res_wrap - where - go [] res_ty res_wrap = (res_ty, res_wrap) - go ((arg_ty, arg_wrap) : args) res_ty res_wrap - = let (tail_ty, tail_wrap) = go args res_ty res_wrap in - (arg_ty `mkFunTy` tail_ty, mkWpFun arg_wrap tail_wrap arg_ty tail_ty doc) - -mkWpCastR :: TcCoercionR -> HsWrapper -mkWpCastR co - | isTcReflCo co = WpHole - | otherwise = ASSERT2(tcCoercionRole co == Representational, ppr co) - WpCast co - -mkWpCastN :: TcCoercionN -> HsWrapper -mkWpCastN co - | isTcReflCo co = WpHole - | otherwise = ASSERT2(tcCoercionRole co == Nominal, ppr co) - WpCast (mkTcSubCo co) - -- The mkTcSubCo converts Nominal to Representational - -mkWpTyApps :: [Type] -> HsWrapper -mkWpTyApps tys = mk_co_app_fn WpTyApp tys - -mkWpEvApps :: [EvTerm] -> HsWrapper -mkWpEvApps args = mk_co_app_fn WpEvApp args - -mkWpEvVarApps :: [EvVar] -> HsWrapper -mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map EvId vs) - -mkWpTyLams :: [TyVar] -> HsWrapper -mkWpTyLams ids = mk_co_lam_fn WpTyLam ids - -mkWpLams :: [Var] -> HsWrapper -mkWpLams ids = mk_co_lam_fn WpEvLam ids - -mkWpLet :: TcEvBinds -> HsWrapper --- This no-op is a quite a common case -mkWpLet (EvBinds b) | isEmptyBag b = WpHole -mkWpLet ev_binds = WpLet ev_binds - -mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper -mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as - -mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper --- For applications, the *first* argument must --- come *last* in the composition sequence -mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as - -idHsWrapper :: HsWrapper -idHsWrapper = WpHole - -isIdHsWrapper :: HsWrapper -> Bool -isIdHsWrapper WpHole = True -isIdHsWrapper _ = False - -collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper) --- Collect the outer lambda binders of a HsWrapper, --- stopping as soon as you get to a non-lambda binder -collectHsWrapBinders wrap = go wrap [] - where - -- go w ws = collectHsWrapBinders (w <.> w1 <.> ... <.> wn) - go :: HsWrapper -> [HsWrapper] -> ([Var], HsWrapper) - go (WpEvLam v) wraps = add_lam v (gos wraps) - go (WpTyLam v) wraps = add_lam v (gos wraps) - go (WpCompose w1 w2) wraps = go w1 (w2:wraps) - go wrap wraps = ([], foldl (<.>) wrap wraps) - - gos [] = ([], WpHole) - gos (w:ws) = go w ws - - add_lam v (vs,w) = (v:vs, w) - -{- -************************************************************************ -* * - Evidence bindings -* * -************************************************************************ --} - -data TcEvBinds - = TcEvBinds -- Mutable evidence bindings - EvBindsVar -- Mutable because they are updated "later" - -- when an implication constraint is solved - - | EvBinds -- Immutable after zonking - (Bag EvBind) - -data EvBindsVar - = EvBindsVar { - ebv_uniq :: Unique, - -- The Unique is for debug printing only - - ebv_binds :: IORef EvBindMap, - -- The main payload: the value-level evidence bindings - -- (dictionaries etc) - -- Some Given, some Wanted - - ebv_tcvs :: IORef CoVarSet - -- The free coercion vars of the (rhss of) the coercion bindings - -- All of these are Wanted - -- - -- Coercions don't actually have bindings - -- because we plug them in-place (via a mutable - -- variable); but we keep their free variables - -- so that we can report unused given constraints - -- See Note [Tracking redundant constraints] in TcSimplify - } - -instance Data.Data TcEvBinds where - -- Placeholder; we can't travers into TcEvBinds - toConstr _ = abstractConstr "TcEvBinds" - gunfold _ _ = error "gunfold" - dataTypeOf _ = Data.mkNoRepType "TcEvBinds" - ------------------ -newtype EvBindMap - = EvBindMap { - ev_bind_varenv :: DVarEnv EvBind - } -- Map from evidence variables to evidence terms - -- We use @DVarEnv@ here to get deterministic ordering when we - -- turn it into a Bag. - -- If we don't do that, when we generate let bindings for - -- dictionaries in dsTcEvBinds they will be generated in random - -- order. - -- - -- For example: - -- - -- let $dEq = GHC.Classes.$fEqInt in - -- let $$dNum = GHC.Num.$fNumInt in ... - -- - -- vs - -- - -- let $dNum = GHC.Num.$fNumInt in - -- let $dEq = GHC.Classes.$fEqInt in ... - -- - -- See Note [Deterministic UniqFM] in UniqDFM for explanation why - -- @UniqFM@ can lead to nondeterministic order. - -emptyEvBindMap :: EvBindMap -emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyDVarEnv } - -extendEvBinds :: EvBindMap -> EvBind -> EvBindMap -extendEvBinds bs ev_bind - = EvBindMap { ev_bind_varenv = extendDVarEnv (ev_bind_varenv bs) - (eb_lhs ev_bind) - ev_bind } - -isEmptyEvBindMap :: EvBindMap -> Bool -isEmptyEvBindMap (EvBindMap m) = isEmptyDVarEnv m - -lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind -lookupEvBind bs = lookupDVarEnv (ev_bind_varenv bs) - -evBindMapBinds :: EvBindMap -> Bag EvBind -evBindMapBinds = foldEvBindMap consBag emptyBag - -foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a -foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs) - -instance Outputable EvBindMap where - ppr (EvBindMap m) = ppr m - ------------------ --- All evidence is bound by EvBinds; no side effects -data EvBind - = EvBind { eb_lhs :: EvVar - , eb_rhs :: EvTerm - , eb_is_given :: Bool -- True <=> given - -- See Note [Tracking redundant constraints] in TcSimplify - } - -evBindVar :: EvBind -> EvVar -evBindVar = eb_lhs - -mkWantedEvBind :: EvVar -> EvTerm -> EvBind -mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm } - - -mkGivenEvBind :: EvVar -> EvTerm -> EvBind -mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm } - -data EvTerm - = EvId EvId -- Any sort of evidence Id, including coercions - - | EvCoercion TcCoercion -- coercion bindings - -- See Note [Coercion evidence terms] - - | EvCast EvTerm TcCoercionR -- d |> co - - | EvDFunApp DFunId -- Dictionary instance application - [Type] [EvTerm] - - | EvDelayedError Type FastString -- Used with Opt_DeferTypeErrors - -- See Note [Deferring coercion errors to runtime] - -- in TcSimplify - - | EvSuperClass EvTerm Int -- n'th superclass. Used for both equalities and - -- dictionaries, even though the former have no - -- selector Id. We count up from _0_ - - | EvLit EvLit -- Dictionary for KnownNat and KnownSymbol classes. - -- Note [KnownNat & KnownSymbol and EvLit] - - | EvCallStack EvCallStack -- Dictionary for CallStack implicit parameters - - | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty) - - | EvSelector Id [Type] [EvTerm] -- Selector id plus the types at which it - -- should be instantiated, used for HasField - -- dictionaries; see Note [HasField instances] - -- in TcInterface - - deriving Data.Data - - --- | Instructions on how to make a 'Typeable' dictionary. --- See Note [Typeable evidence terms] -data EvTypeable - = EvTypeableTyCon TyCon [EvTerm] - -- ^ Dictionary for @Typeable T@ where @T@ is a type constructor with all of - -- its kind variables saturated. The @[EvTerm]@ is @Typeable@ evidence for - -- the applied kinds.. - - | EvTypeableTyApp EvTerm EvTerm - -- ^ Dictionary for @Typeable (s t)@, - -- given a dictionaries for @s@ and @t@. - - | EvTypeableTrFun EvTerm EvTerm - -- ^ Dictionary for @Typeable (s -> t)@, - -- given a dictionaries for @s@ and @t@. - - | EvTypeableTyLit EvTerm - -- ^ Dictionary for a type literal, - -- e.g. @Typeable "foo"@ or @Typeable 3@ - -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@ - -- (see Trac #10348) - deriving Data.Data - -data EvLit - = EvNum Integer - | EvStr FastString - deriving Data.Data - --- | Evidence for @CallStack@ implicit parameters. -data EvCallStack - -- See Note [Overview of implicit CallStacks] - = EvCsEmpty - | EvCsPushCall Name RealSrcSpan EvTerm - -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at - -- @loc@, in a calling context @stk@. - deriving Data.Data - -{- -Note [Typeable evidence terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The EvTypeable data type looks isomorphic to Type, but the EvTerms -inside can be EvIds. Eg - f :: forall a. Typeable a => a -> TypeRep - f x = typeRep (undefined :: Proxy [a]) -Here for the (Typeable [a]) dictionary passed to typeRep we make -evidence - dl :: Typeable [a] = EvTypeable [a] - (EvTypeableTyApp (EvTypeableTyCon []) (EvId d)) -where - d :: Typable a -is the lambda-bound dictionary passed into f. - -Note [Coercion evidence terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "coercion evidence term" takes one of these forms - co_tm ::= EvId v where v :: t1 ~# t2 - | EvCoercion co - | EvCast co_tm co - -We do quite often need to get a TcCoercion from an EvTerm; see -'evTermCoercion'. - -INVARIANT: The evidence for any constraint with type (t1 ~# t2) is -a coercion evidence term. Consider for example - [G] d :: F Int a -If we have - ax7 a :: F Int a ~ (a ~ Bool) -then we do NOT generate the constraint - [G] (d |> ax7 a) :: a ~ Bool -because that does not satisfy the invariant (d is not a coercion variable). -Instead we make a binding - g1 :: a~Bool = g |> ax7 a -and the constraint - [G] g1 :: a~Bool -See Trac [7238] and Note [Bind new Givens immediately] in TcRnTypes - -Note [EvBinds/EvTerm] -~~~~~~~~~~~~~~~~~~~~~ -How evidence is created and updated. Bindings for dictionaries, -and coercions and implicit parameters are carried around in TcEvBinds -which during constraint generation and simplification is always of the -form (TcEvBinds ref). After constraint simplification is finished it -will be transformed to t an (EvBinds ev_bag). - -Evidence for coercions *SHOULD* be filled in using the TcEvBinds -However, all EvVars that correspond to *wanted* coercion terms in -an EvBind must be mutable variables so that they can be readily -inlined (by zonking) after constraint simplification is finished. - -Conclusion: a new wanted coercion variable should be made mutable. -[Notice though that evidence variables that bind coercion terms - from super classes will be "given" and hence rigid] - - -Note [KnownNat & KnownSymbol and EvLit] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A part of the type-level literals implementation are the classes -"KnownNat" and "KnownSymbol", which provide a "smart" constructor for -defining singleton values. Here is the key stuff from GHC.TypeLits - - class KnownNat (n :: Nat) where - natSing :: SNat n - - newtype SNat (n :: Nat) = SNat Integer - -Conceptually, this class has infinitely many instances: - - instance KnownNat 0 where natSing = SNat 0 - instance KnownNat 1 where natSing = SNat 1 - instance KnownNat 2 where natSing = SNat 2 - ... - -In practice, we solve `KnownNat` predicates in the type-checker -(see typecheck/TcInteract.hs) because we can't have infinitely many instances. -The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`. - -We make the following assumptions about dictionaries in GHC: - 1. The "dictionary" for classes with a single method---like `KnownNat`---is - a newtype for the type of the method, so using a evidence amounts - to a coercion, and - 2. Newtypes use the same representation as their definition types. - -So, the evidence for `KnownNat` is just a value of the representation type, -wrapped in two newtype constructors: one to make it into a `SNat` value, -and another to make it into a `KnownNat` dictionary. - -Also note that `natSing` and `SNat` are never actually exposed from the -library---they are just an implementation detail. Instead, users see -a more convenient function, defined in terms of `natSing`: - - natVal :: KnownNat n => proxy n -> Integer - -The reason we don't use this directly in the class is that it is simpler -and more efficient to pass around an integer rather than an entier function, -especially when the `KnowNat` evidence is packaged up in an existential. - -The story for kind `Symbol` is analogous: - * class KnownSymbol - * newtype SSymbol - * Evidence: EvLit (EvStr n) - - -Note [Overview of implicit CallStacks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(See https://ghc.haskell.org/trac/ghc/wiki/ExplicitCallStack/ImplicitLocations) - -The goal of CallStack evidence terms is to reify locations -in the program source as runtime values, without any support -from the RTS. We accomplish this by assigning a special meaning -to constraints of type GHC.Stack.Types.HasCallStack, an alias - - type HasCallStack = (?callStack :: CallStack) - -Implicit parameters of type GHC.Stack.Types.CallStack (the name is not -important) are solved in three steps: - -1. Occurrences of CallStack IPs are solved directly from the given IP, - just like a regular IP. For example, the occurrence of `?stk` in - - error :: (?stk :: CallStack) => String -> a - error s = raise (ErrorCall (s ++ prettyCallStack ?stk)) - - will be solved for the `?stk` in `error`s context as before. - -2. In a function call, instead of simply passing the given IP, we first - append the current call-site to it. For example, consider a - call to the callstack-aware `error` above. - - undefined :: (?stk :: CallStack) => a - undefined = error "undefined!" - - Here we want to take the given `?stk` and append the current - call-site, before passing it to `error`. In essence, we want to - rewrite `error "undefined!"` to - - let ?stk = pushCallStack ?stk - in error "undefined!" - - We achieve this effect by emitting a NEW wanted - - [W] d :: IP "stk" CallStack - - from which we build the evidence term - - EvCsPushCall "error" (EvId d) - - that we use to solve the call to `error`. The new wanted `d` will - then be solved per rule (1), ie as a regular IP. - - (see TcInteract.interactDict) - -3. We default any insoluble CallStacks to the empty CallStack. Suppose - `undefined` did not request a CallStack, ie - - undefinedNoStk :: a - undefinedNoStk = error "undefined!" - - Under the usual IP rules, the new wanted from rule (2) would be - insoluble as there's no given IP from which to solve it, so we - would get an "unbound implicit parameter" error. - - We don't ever want to emit an insoluble CallStack IP, so we add a - defaulting pass to default any remaining wanted CallStacks to the - empty CallStack with the evidence term - - EvCsEmpty - - (see TcSimplify.simpl_top and TcSimplify.defaultCallStacks) - -This provides a lightweight mechanism for building up call-stacks -explicitly, but is notably limited by the fact that the stack will -stop at the first function whose type does not include a CallStack IP. -For example, using the above definition of `undefined`: - - head :: [a] -> a - head [] = undefined - head (x:_) = x - - g = head [] - -the resulting CallStack will include the call to `undefined` in `head` -and the call to `error` in `undefined`, but *not* the call to `head` -in `g`, because `head` did not explicitly request a CallStack. - - -Important Details: -- GHC should NEVER report an insoluble CallStack constraint. - -- GHC should NEVER infer a CallStack constraint unless one was requested - with a partial type signature (See TcType.pickQuantifiablePreds). - -- A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)], - where the String is the name of the binder that is used at the - SrcLoc. SrcLoc is also defined in GHC.Stack.Types and contains the - package/module/file name, as well as the full source-span. Both - CallStack and SrcLoc are kept abstract so only GHC can construct new - values. - -- We will automatically solve any wanted CallStack regardless of the - name of the IP, i.e. - - f = show (?stk :: CallStack) - g = show (?loc :: CallStack) - - are both valid. However, we will only push new SrcLocs onto existing - CallStacks when the IP names match, e.g. in - - head :: (?loc :: CallStack) => [a] -> a - head [] = error (show (?stk :: CallStack)) - - the printed CallStack will NOT include head's call-site. This reflects the - standard scoping rules of implicit-parameters. - -- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. - The desugarer will need to unwrap the IP newtype before pushing a new - call-site onto a given stack (See DsBinds.dsEvCallStack) - -- When we emit a new wanted CallStack from rule (2) we set its origin to - `IPOccOrigin ip_name` instead of the original `OccurrenceOf func` - (see TcInteract.interactDict). - - This is a bit shady, but is how we ensure that the new wanted is - solved like a regular IP. - --} - -mkEvCast :: EvTerm -> TcCoercion -> EvTerm -mkEvCast ev lco - | ASSERT2(tcCoercionRole lco == Representational, (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco])) - isTcReflCo lco = ev - | otherwise = EvCast ev lco - -mkEvScSelectors :: EvTerm -> Class -> [TcType] -> [(TcPredType, EvTerm)] -mkEvScSelectors ev cls tys - = zipWith mk_pr (immSuperClasses cls tys) [0..] - where - mk_pr pred i = (pred, EvSuperClass ev i) - -emptyTcEvBinds :: TcEvBinds -emptyTcEvBinds = EvBinds emptyBag - -isEmptyTcEvBinds :: TcEvBinds -> Bool -isEmptyTcEvBinds (EvBinds b) = isEmptyBag b -isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" - - -evTermCoercion :: EvTerm -> TcCoercion --- Applied only to EvTerms of type (s~t) --- See Note [Coercion evidence terms] -evTermCoercion (EvId v) = mkCoVarCo v -evTermCoercion (EvCoercion co) = co -evTermCoercion (EvCast tm co) = mkCoCast (evTermCoercion tm) co -evTermCoercion tm = pprPanic "evTermCoercion" (ppr tm) - -evVarsOfTerm :: EvTerm -> VarSet -evVarsOfTerm (EvId v) = unitVarSet v -evVarsOfTerm (EvCoercion co) = coVarsOfCo co -evVarsOfTerm (EvDFunApp _ _ evs) = mapUnionVarSet evVarsOfTerm evs -evVarsOfTerm (EvSuperClass v _) = evVarsOfTerm v -evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfCo co -evVarsOfTerm (EvDelayedError _ _) = emptyVarSet -evVarsOfTerm (EvLit _) = emptyVarSet -evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs -evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev -evVarsOfTerm (EvSelector _ _ evs) = mapUnionVarSet evVarsOfTerm evs - -evVarsOfTerms :: [EvTerm] -> VarSet -evVarsOfTerms = mapUnionVarSet evVarsOfTerm - --- | Do SCC analysis on a bag of 'EvBind's. -sccEvBinds :: Bag EvBind -> [SCC EvBind] -sccEvBinds bs = stronglyConnCompFromEdgedVerticesUniq edges - where - edges :: [(EvBind, EvVar, [EvVar])] - edges = foldrBag ((:) . mk_node) [] bs - - mk_node :: EvBind -> (EvBind, EvVar, [EvVar]) - mk_node b@(EvBind { eb_lhs = var, eb_rhs = term }) - = (b, var, nonDetEltsUniqSet (evVarsOfTerm term `unionVarSet` - coVarsOfType (varType var))) - -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices - -- is still deterministic even if the edges are in nondeterministic order - -- as explained in Note [Deterministic SCC] in Digraph. - -evVarsOfCallStack :: EvCallStack -> VarSet -evVarsOfCallStack cs = case cs of - EvCsEmpty -> emptyVarSet - EvCsPushCall _ _ tm -> evVarsOfTerm tm - -evVarsOfTypeable :: EvTypeable -> VarSet -evVarsOfTypeable ev = - case ev of - EvTypeableTyCon _ e -> mapUnionVarSet evVarsOfTerm e - EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] - EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2] - EvTypeableTyLit e -> evVarsOfTerm e - -{- -************************************************************************ -* * - Pretty printing -* * -************************************************************************ --} - -instance Outputable HsWrapper where - ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>")) - -pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc --- With -fprint-typechecker-elaboration, print the wrapper --- otherwise just print what's inside --- The pp_thing_inside function takes Bool to say whether --- it's in a position that needs parens for a non-atomic thing -pprHsWrapper wrap pp_thing_inside - = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintTypecheckerElaboration dflags - then help pp_thing_inside wrap False - else pp_thing_inside False - where - help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc - -- True <=> appears in function application position - -- False <=> appears as body of let or lambda - help it WpHole = it - help it (WpCompose f1 f2) = help (help it f2) f1 - help it (WpFun f1 f2 t1 _) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> - help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False - help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" - <+> pprParendCo co)] - help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] - help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty] - help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pp_bndr id, it False] - help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pp_bndr tv, it False] - help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] - - pp_bndr v = pprBndr LambdaBind v <> dot - -add_parens, no_parens :: SDoc -> Bool -> SDoc -add_parens d True = parens d -add_parens d False = d -no_parens d _ = d - -instance Outputable TcEvBinds where - ppr (TcEvBinds v) = ppr v - ppr (EvBinds bs) = text "EvBinds" <> braces (vcat (map ppr (bagToList bs))) - -instance Outputable EvBindsVar where - ppr (EvBindsVar { ebv_uniq = u }) - = text "EvBindsVar" <> angleBrackets (ppr u) - -instance Uniquable EvBindsVar where - getUnique (EvBindsVar { ebv_uniq = u }) = u - -instance Outputable EvBind where - ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given }) - = sep [ pp_gw <+> ppr v - , nest 2 $ equals <+> ppr e ] - where - pp_gw = brackets (if is_given then char 'G' else char 'W') - -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing - -instance Outputable EvTerm where - ppr (EvId v) = ppr v - ppr (EvCast v co) = ppr v <+> (text "`cast`") <+> pprParendCo co - ppr (EvCoercion co) = text "CO" <+> ppr co - ppr (EvSuperClass d n) = text "sc" <> parens (ppr (d,n)) - ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] - ppr (EvLit l) = ppr l - ppr (EvCallStack cs) = ppr cs - ppr (EvDelayedError ty msg) = text "error" - <+> sep [ char '@' <> ppr ty, ppr msg ] - ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty - ppr (EvSelector sel tys ts) = ppr sel <+> sep [ char '@' <> ppr tys, ppr ts] - -instance Outputable EvLit where - ppr (EvNum n) = integer n - ppr (EvStr s) = text (show s) - -instance Outputable EvCallStack where - ppr EvCsEmpty - = text "[]" - ppr (EvCsPushCall name loc tm) - = ppr (name,loc) <+> text ":" <+> ppr tm - -instance Outputable EvTypeable where - ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts - ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) - ppr (EvTypeableTrFun t1 t2) = parens (ppr t1 <+> arrow <+> ppr t2) - ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 - - ----------------------------------------------------------------------- --- Helper functions for dealing with IP newtype-dictionaries ----------------------------------------------------------------------- - --- | Create a 'Coercion' that unwraps an implicit-parameter or --- overloaded-label dictionary to expose the underlying value. We --- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`, --- and return a 'Coercion' `co :: IP sym ty ~ ty` or --- `co :: IsLabel sym ty ~ Proxy# sym -> ty`. See also --- Note [Type-checking overloaded labels] in TcExpr. -unwrapIP :: Type -> CoercionR -unwrapIP ty = - case unwrapNewTyCon_maybe tc of - Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys [] - Nothing -> pprPanic "unwrapIP" $ - text "The dictionary for" <+> quotes (ppr tc) - <+> text "is not a newtype!" - where - (tc, tys) = splitTyConApp ty - --- | Create a 'Coercion' that wraps a value in an implicit-parameter --- dictionary. See 'unwrapIP'. -wrapIP :: Type -> CoercionR -wrapIP ty = mkSymCo (unwrapIP ty) diff --git a/typecheck/TcExpr.hs b/typecheck/TcExpr.hs deleted file mode 100644 --- a/typecheck/TcExpr.hs +++ /dev/null @@ -1,2767 +0,0 @@ -{- -% -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcExpr]{Typecheck an expression} --} - -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} - -module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC, - tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC, - tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, - tcCheckId, - addExprErrCtxt, - getFixedTyVars ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) -import THNames( liftStringName, liftName ) - -import HsSyn -import TcHsSyn -import TcRnMonad -import TcUnify -import BasicTypes -import Inst -import TcBinds ( chooseInferredQuantifiers, tcLocalBinds ) -import TcSigs ( tcUserTypeSig, tcInstSig ) -import TcSimplify ( simplifyInfer, InferMode(..) ) -import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst ) -import FamInstEnv ( FamInstEnvs ) -import RnEnv ( addUsedGRE, addNameClashErrRn - , unknownSubordinateErr ) -import TcEnv -import TcArrows -import TcMatches -import TcHsType -import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr ) -import TcPat -import TcMType -import TcType -import DsMonad -import Id -import IdInfo -import ConLike -import DataCon -import PatSyn -import Name -import NameEnv -import NameSet -import RdrName -import TyCon -import Type -import TcEvidence -import VarSet -import TysWiredIn -import TysPrim( intPrimTy ) -import PrimOp( tagToEnumKey ) -import PrelNames -import DynFlags -import SrcLoc -import Util -import VarEnv ( emptyTidyEnv, mkInScopeSet ) -import ListSetOps -import Maybes -import Outputable -import FastString -import Control.Monad -import Class(classTyCon) -import UniqSet ( nonDetEltsUniqSet ) -import qualified GHC.LanguageExtensions as LangExt - -import Data.Function -import Data.List -import Data.Either -import qualified Data.Set as Set - -{- -************************************************************************ -* * -\subsection{Main wrappers} -* * -************************************************************************ --} - -tcPolyExpr, tcPolyExprNC - :: LHsExpr Name -- Expression to type check - -> TcSigmaType -- Expected type (could be a polytype) - -> TcM (LHsExpr TcId) -- Generalised expr with expected type - --- tcPolyExpr is a convenient place (frequent but not too frequent) --- place to add context information. --- The NC version does not do so, usually because the caller wants --- to do so himself. - -tcPolyExpr expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty) -tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty) - --- these versions take an ExpType -tc_poly_expr, tc_poly_expr_nc :: LHsExpr Name -> ExpSigmaType -> TcM (LHsExpr TcId) -tc_poly_expr expr res_ty - = addExprErrCtxt expr $ - do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty } - -tc_poly_expr_nc (L loc expr) res_ty - = do { traceTc "tcPolyExprNC" (ppr res_ty) - ; (wrap, expr') - <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> - setSrcSpan loc $ - -- NB: setSrcSpan *after* skolemising, so we get better - -- skolem locations - tcExpr expr res_ty - ; return $ L loc (mkHsWrap wrap expr') } - ---------------- -tcMonoExpr, tcMonoExprNC - :: LHsExpr Name -- Expression to type check - -> ExpRhoType -- Expected type - -- Definitely no foralls at the top - -> TcM (LHsExpr TcId) - -tcMonoExpr expr res_ty - = addErrCtxt (exprCtxt expr) $ - tcMonoExprNC expr res_ty - -tcMonoExprNC (L loc expr) res_ty - = setSrcSpan loc $ - do { expr' <- tcExpr expr res_ty - ; return (L loc expr') } - ---------------- -tcInferSigma, tcInferSigmaNC :: LHsExpr Name -> TcM ( LHsExpr TcId - , TcSigmaType ) --- Infer a *sigma*-type. -tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr) - -tcInferSigmaNC (L loc expr) - = setSrcSpan loc $ - do { (expr', sigma) <- tcInferNoInst (tcExpr expr) - ; return (L loc expr', sigma) } - -tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) --- Infer a *rho*-type. The return type is always (shallowly) instantiated. -tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr) - -tcInferRhoNC expr - = do { (expr', sigma) <- tcInferSigmaNC expr - ; (wrap, rho) <- topInstantiate (lexprCtOrigin expr) sigma - ; return (mkLHsWrap wrap expr', rho) } - - -{- -************************************************************************ -* * - tcExpr: the main expression typechecker -* * -************************************************************************ - -NB: The res_ty is always deeply skolemised. --} - -tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId) -tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty -tcExpr (HsUnboundVar uv) res_ty = tcUnboundId uv res_ty - -tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty -tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty - -tcExpr e@(HsLit lit) res_ty = do { let lit_ty = hsLitType lit - ; tcWrapResult e (HsLit lit) lit_ty res_ty } - -tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar expr') } - -tcExpr (HsSCC src lbl expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsSCC src lbl expr') } - -tcExpr (HsTickPragma src info srcInfo expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsTickPragma src info srcInfo expr') } - -tcExpr (HsCoreAnn src lbl expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsCoreAnn src lbl expr') } - -tcExpr (HsOverLit lit) res_ty - = do { lit' <- newOverloadedLit lit res_ty - ; return (HsOverLit lit') } - -tcExpr (NegApp expr neg_expr) res_ty - = do { (expr', neg_expr') - <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ - \[arg_ty] -> - tcMonoExpr expr (mkCheckExpType arg_ty) - ; return (NegApp expr' neg_expr') } - -tcExpr e@(HsIPVar x) res_ty - = do { {- Implicit parameters must have a *tau-type* not a - type scheme. We enforce this by creating a fresh - type variable as its type. (Because res_ty may not - be a tau-type.) -} - ip_ty <- newOpenFlexiTyVarTy - ; let ip_name = mkStrLitTy (hsIPNameFS x) - ; ipClass <- tcLookupClass ipClassName - ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) - ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var))) - ip_ty res_ty } - where - -- Coerces a dictionary for `IP "x" t` into `t`. - fromDict ipClass x ty = HsWrap $ mkWpCastR $ - unwrapIP $ mkClassPred ipClass [x,ty] - origin = IPOccOrigin x - -tcExpr e@(HsOverLabel mb_fromLabel l) res_ty - = do { -- See Note [Type-checking overloaded labels] - loc <- getSrcSpanM - ; case mb_fromLabel of - Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty - Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName - ; alpha <- newFlexiTyVarTy liftedTypeKind - ; let pred = mkClassPred isLabelClass [lbl, alpha] - ; loc <- getSrcSpanM - ; var <- emitWantedEvVar origin pred - ; tcWrapResult e (fromDict pred (HsVar (L loc var))) - alpha res_ty } } - where - -- Coerces a dictionary for `IsLabel "x" t` into `t`, - -- or `HasField "x" r a into `r -> a`. - fromDict pred = HsWrap $ mkWpCastR $ unwrapIP pred - origin = OverLabelOrigin l - lbl = mkStrLitTy l - - applyFromLabel loc fromLabel = - L loc (HsVar (L loc fromLabel)) `HsAppType` - mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l))) - -tcExpr (HsLam match) res_ty - = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty - ; return (mkHsWrap wrap (HsLam match')) } - where - match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } - herald = sep [ text "The lambda expression" <+> - quotes (pprSetDepth (PartWay 1) $ - pprMatches match), - -- The pprSetDepth makes the abstraction print briefly - text "has"] - -tcExpr e@(HsLamCase matches) res_ty - = do { (matches', wrap) - <- tcMatchLambda msg match_ctxt matches res_ty - -- The laziness annotation is because we don't want to fail here - -- if there are multiple arguments - ; return (mkHsWrap wrap $ HsLamCase matches') } - where - msg = sep [ text "The function" <+> quotes (ppr e) - , text "requires"] - match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } - -tcExpr e@(ExprWithTySig expr sig_ty) res_ty - = do { let loc = getLoc (hsSigWcType sig_ty) - ; sig_info <- checkNoErrs $ -- Avoid error cascade - tcUserTypeSig loc sig_ty Nothing - ; (expr', poly_ty) <- tcExprSig expr sig_info - ; let expr'' = ExprWithTySigOut expr' sig_ty - ; tcWrapResult e expr'' poly_ty res_ty } - -{- -Note [Type-checking overloaded labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that we have - - module GHC.OverloadedLabels where - class IsLabel (x :: Symbol) a where - fromLabel :: a - -We translate `#foo` to `fromLabel @"foo"`, where we use - - * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not - * `GHC.OverloadedLabels.fromLabel`. - -In the `RebindableSyntax` case, the renamer will have filled in the -first field of `HsOverLabel` with the `fromLabel` function to use, and -we simply apply it to the appropriate visible type argument. - -In the `OverloadedLabels` case, when we see an overloaded label like -`#foo`, we generate a fresh variable `alpha` for the type and emit an -`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a -single method, it is represented by a newtype, so we can coerce -`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters). - --} - - -{- -************************************************************************ -* * - Infix operators and sections -* * -************************************************************************ - -Note [Left sections] -~~~~~~~~~~~~~~~~~~~~ -Left sections, like (4 *), are equivalent to - \ x -> (*) 4 x, -or, if PostfixOperators is enabled, just - (*) 4 -With PostfixOperators we don't actually require the function to take -two arguments at all. For example, (x `not`) means (not x); you get -postfix operators! Not Haskell 98, but it's less work and kind of -useful. - -Note [Typing rule for ($)] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -People write - runST $ blah -so much, where - runST :: (forall s. ST s a) -> a -that I have finally given in and written a special type-checking -rule just for saturated applications of ($). - * Infer the type of the first argument - * Decompose it; should be of form (arg2_ty -> res_ty), - where arg2_ty might be a polytype - * Use arg2_ty to typecheck arg2 - -Note [Typing rule for seq] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to allow - x `seq` (# p,q #) -which suggests this type for seq: - seq :: forall (a:*) (b:Open). a -> b -> b, -with (b:Open) meaning that be can be instantiated with an unboxed -tuple. The trouble is that this might accept a partially-applied -'seq', and I'm just not certain that would work. I'm only sure it's -only going to work when it's fully applied, so it turns into - case x of _ -> (# p,q #) - -So it seems more uniform to treat 'seq' as if it was a language -construct. - -See also Note [seqId magic] in MkId --} - -tcExpr expr@(OpApp arg1 op fix arg2) res_ty - | (L loc (HsVar (L lv op_name))) <- op - , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] - = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind - ; let arg2_exp_ty = res_ty - ; arg1' <- tcArg op arg1 arg1_ty 1 - ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $ - tc_poly_expr_nc arg2 arg2_exp_ty - ; arg2_ty <- readExpType arg2_exp_ty - ; op_id <- tcLookupId op_name - ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) - (HsVar (L lv op_id))) - ; return $ OpApp arg1' op' fix arg2' } - - | (L loc (HsVar (L lv op_name))) <- op - , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] - = do { traceTc "Application rule" (ppr op) - ; (arg1', arg1_ty) <- tcInferSigma arg1 - - ; let doc = text "The first argument of ($) takes" - orig1 = lexprCtOrigin arg1 - ; (wrap_arg1, [arg2_sigma], op_res_ty) <- - matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty - - -- We have (arg1 $ arg2) - -- So: arg1_ty = arg2_ty -> op_res_ty - -- where arg2_sigma maybe polymorphic; that's the point - - ; arg2' <- tcArg op arg2 arg2_sigma 2 - - -- Make sure that the argument type has kind '*' - -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b - -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 - -- (which gives a seg fault) - -- - -- The *result* type can have any kind (Trac #8739), - -- so we don't need to check anything for that - ; _ <- unifyKind (Just arg2_sigma) (typeKind arg2_sigma) liftedTypeKind - -- ignore the evidence. arg2_sigma must have type * or #, - -- because we know arg2_sigma -> or_res_ty is well-kinded - -- (because otherwise matchActualFunTys would fail) - -- There's no possibility here of, say, a kind family reducing to *. - - ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty - -- op_res -> res - - ; op_id <- tcLookupId op_name - ; res_ty <- readExpType res_ty - ; let op' = L loc (HsWrap (mkWpTyApps [ getRuntimeRep res_ty - , arg2_sigma - , res_ty]) - (HsVar (L lv op_id))) - -- arg1' :: arg1_ty - -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) - -- wrap_res :: op_res_ty "->" res_ty - -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty - - -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty) - wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty doc - <.> wrap_arg1 - doc = text "When looking at the argument to ($)" - - ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') } - - | (L loc (HsRecFld (Ambiguous lbl _))) <- op - , Just sig_ty <- obviousSig (unLoc arg1) - -- See Note [Disambiguating record fields] - = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty - ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; let op' = L loc (HsRecFld (Unambiguous lbl sel_name)) - ; tcExpr (OpApp arg1 op' fix arg2) res_ty - } - - | otherwise - = do { traceTc "Non Application rule" (ppr op) - ; (wrap, op', [Left arg1', Left arg2']) - <- tcApp (Just $ mk_op_msg op) - op [Left arg1, Left arg2] res_ty - ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') } - --- Right sections, equivalent to \ x -> x `op` expr, or --- \ x -> op x expr - -tcExpr expr@(SectionR op arg2) res_ty - = do { (op', op_ty) <- tcInferFun op - ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) - <- matchActualFunTys (mk_op_msg op) fn_orig (Just op) 2 op_ty - ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) - (mkFunTy arg1_ty op_res_ty) res_ty - ; arg2' <- tcArg op arg2 arg2_ty 2 - ; return ( mkHsWrap wrap_res $ - SectionR (mkLHsWrap wrap_fun op') arg2' ) } - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See Trac #13285 - -tcExpr expr@(SectionL arg1 op) res_ty - = do { (op', op_ty) <- tcInferFun op - ; dflags <- getDynFlags -- Note [Left sections] - ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1 - | otherwise = 2 - - ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) - <- matchActualFunTys (mk_op_msg op) fn_orig (Just op) - n_reqd_args op_ty - ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) - (mkFunTys arg_tys op_res_ty) res_ty - ; arg1' <- tcArg op arg1 arg1_ty 1 - ; return ( mkHsWrap wrap_res $ - SectionL arg1' (mkLHsWrap wrap_fn op') ) } - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See Trac #13285 - -tcExpr expr@(ExplicitTuple tup_args boxity) res_ty - | all tupArgPresent tup_args - = do { let arity = length tup_args - tup_tc = tupleTyCon boxity arity - ; res_ty <- expTypeToType res_ty - ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty - -- Unboxed tuples have RuntimeRep vars, which we - -- don't care about here - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys - Boxed -> arg_tys - ; tup_args1 <- tcTupArgs tup_args arg_tys' - ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } - - | otherwise - = -- The tup_args are a mixture of Present and Missing (for tuple sections) - do { let arity = length tup_args - - ; arg_tys <- case boxity of - { Boxed -> newFlexiTyVarTys arity liftedTypeKind - ; Unboxed -> replicateM arity newOpenFlexiTyVarTy } - ; let actual_res_ty - = mkFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args] - (mkTupleTy boxity arg_tys) - - ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple") - (Just expr) - actual_res_ty res_ty - - -- Handle tuple sections where - ; tup_args1 <- tcTupArgs tup_args arg_tys - - ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) } - -tcExpr (ExplicitSum alt arity expr _) res_ty - = do { let sum_tc = sumTyCon arity - ; res_ty <- expTypeToType res_ty - ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty - ; -- Drop levity vars, we don't care about them here - let arg_tys' = drop arity arg_tys - ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1)) - ; return $ mkHsWrapCo coi (ExplicitSum alt arity expr' arg_tys') } - -tcExpr (ExplicitList _ witness exprs) res_ty - = case witness of - Nothing -> do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ - mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' } - - Just fln -> do { ((exprs', elt_ty), fln') - <- tcSyntaxOp ListOrigin fln - [synKnownType intTy, SynList] res_ty $ - \ [elt_ty] -> - do { exprs' <- - mapM (tc_elt elt_ty) exprs - ; return (exprs', elt_ty) } - - ; return $ ExplicitList elt_ty (Just fln') exprs' } - where tc_elt elt_ty expr = tcPolyExpr expr elt_ty - -tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty - = do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedPArrTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ - mkHsWrapCo coi $ ExplicitPArr elt_ty exprs' } - where - tc_elt elt_ty expr = tcPolyExpr expr elt_ty - -{- -************************************************************************ -* * - Let, case, if, do -* * -************************************************************************ --} - -tcExpr (HsLet (L l binds) expr) res_ty - = do { (binds', expr') <- tcLocalBinds binds $ - tcMonoExpr expr res_ty - ; return (HsLet (L l binds') expr') } - -tcExpr (HsCase scrut matches) res_ty - = do { -- We used to typecheck the case alternatives first. - -- The case patterns tend to give good type info to use - -- when typechecking the scrutinee. For example - -- case (map f) of - -- (x:xs) -> ... - -- will report that map is applied to too few arguments - -- - -- But now, in the GADT world, we need to typecheck the scrutinee - -- first, to get type info that may be refined in the case alternatives - (scrut', scrut_ty) <- tcInferRho scrut - - ; traceTc "HsCase" (ppr scrut_ty) - ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty - ; return (HsCase scrut' matches') } - where - match_ctxt = MC { mc_what = CaseAlt, - mc_body = tcBody } - -tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' - = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) - ; res_ty <- tauifyExpType res_ty - -- Just like Note [Case branches must never infer a non-tau type] - -- in TcMatches (See #10619) - - ; b1' <- tcMonoExpr b1 res_ty - ; b2' <- tcMonoExpr b2 res_ty - ; return (HsIf Nothing pred' b1' b2') } - -tcExpr (HsIf (Just fun) pred b1 b2) res_ty - = do { ((pred', b1', b2'), fun') - <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ - \ [pred_ty, b1_ty, b2_ty] -> - do { pred' <- tcPolyExpr pred pred_ty - ; b1' <- tcPolyExpr b1 b1_ty - ; b2' <- tcPolyExpr b2 b2_ty - ; return (pred', b1', b2') } - ; return (HsIf (Just fun') pred' b1' b2') } - -tcExpr (HsMultiIf _ alts) res_ty - = do { res_ty <- if isSingleton alts - then return res_ty - else tauifyExpType res_ty - -- Just like TcMatches - -- Note [Case branches must never infer a non-tau type] - - ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts - ; res_ty <- readExpType res_ty - ; return (HsMultiIf res_ty alts') } - where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } - -tcExpr (HsDo do_or_lc stmts _) res_ty - = do { expr' <- tcDoStmts do_or_lc stmts res_ty - ; return expr' } - -tcExpr (HsProc pat cmd) res_ty - = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCo coi (HsProc pat' cmd') } - --- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. --- See Note [Grand plan for static forms] in StaticPtrTable for an overview. -tcExpr (HsStatic fvs expr) res_ty - = do { res_ty <- expTypeToType res_ty - ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty - ; (expr', lie) <- captureConstraints $ - addErrCtxt (hang (text "In the body of a static form:") - 2 (ppr expr) - ) $ - tcPolyExprNC expr expr_ty - -- Check that the free variables of the static form are closed. - -- It's OK to use nonDetEltsUniqSet here as the only side effects of - -- checkClosedInStaticForm are error messages. - ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs - - -- Require the type of the argument to be Typeable. - -- The evidence is not used, but asking the constraint ensures that - -- the current implementation is as restrictive as future versions - -- of the StaticPointers extension. - ; typeableClass <- tcLookupClass typeableClassName - ; _ <- emitWantedEvVar StaticOrigin $ - mkTyConApp (classTyCon typeableClass) - [liftedTypeKind, expr_ty] - -- Insert the constraints of the static form in a global list for later - -- validation. - ; emitStaticConstraints lie - - -- Wrap the static form with the 'fromStaticPtr' call. - ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty - ; let wrap = mkWpTyApps [expr_ty] - ; loc <- getSrcSpanM - ; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr) - (L loc (HsStatic fvs expr')) - } - -{- -************************************************************************ -* * - Record construction and update -* * -************************************************************************ --} - -tcExpr expr@(RecordCon { rcon_con_name = L loc con_name - , rcon_flds = rbinds }) res_ty - = do { con_like <- tcLookupConLike con_name - - -- Check for missing fields - ; checkMissingFields con_like rbinds - - ; (con_expr, con_sigma) <- tcInferId con_name - ; (con_wrap, con_tau) <- - topInstantiate (OccurrenceOf con_name) con_sigma - -- a shallow instantiation should really be enough for - -- a data constructor. - ; let arity = conLikeArity con_like - Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau - ; case conLikeWrapId_maybe con_like of - Nothing -> nonBidirectionalErr (conLikeName con_like) - Just con_id -> do { - res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon") - (Just expr) actual_res_ty res_ty - ; rbinds' <- tcRecordBinds con_like arg_tys rbinds - ; return $ - mkHsWrap res_wrap $ - RecordCon { rcon_con_name = L loc con_id - , rcon_con_expr = mkHsWrap con_wrap con_expr - , rcon_con_like = con_like - , rcon_flds = rbinds' } } } - -{- -Note [Type of a record update] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The main complication with RecordUpd is that we need to explicitly -handle the *non-updated* fields. Consider: - - data T a b c = MkT1 { fa :: a, fb :: (b,c) } - | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } - | MkT3 { fd :: a } - - upd :: T a b c -> (b',c) -> T a b' c - upd t x = t { fb = x} - -The result type should be (T a b' c) -not (T a b c), because 'b' *is not* mentioned in a non-updated field -not (T a b' c'), because 'c' *is* mentioned in a non-updated field -NB that it's not good enough to look at just one constructor; we must -look at them all; cf Trac #3219 - -After all, upd should be equivalent to: - upd t x = case t of - MkT1 p q -> MkT1 p x - MkT2 a b -> MkT2 p b - MkT3 d -> error ... - -So we need to give a completely fresh type to the result record, -and then constrain it by the fields that are *not* updated ("p" above). -We call these the "fixed" type variables, and compute them in getFixedTyVars. - -Note that because MkT3 doesn't contain all the fields being updated, -its RHS is simply an error, so it doesn't impose any type constraints. -Hence the use of 'relevant_cont'. - -Note [Implicit type sharing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We also take into account any "implicit" non-update fields. For example - data T a b where { MkT { f::a } :: T a a; ... } -So the "real" type of MkT is: forall ab. (a~b) => a -> T a b - -Then consider - upd t x = t { f=x } -We infer the type - upd :: T a b -> a -> T a b - upd (t::T a b) (x::a) - = case t of { MkT (co:a~b) (_:a) -> MkT co x } -We can't give it the more general type - upd :: T a b -> c -> T c b - -Note [Criteria for update] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to allow update for existentials etc, provided the updated -field isn't part of the existential. For example, this should be ok. - data T a where { MkT { f1::a, f2::b->b } :: T a } - f :: T a -> b -> T b - f t b = t { f1=b } - -The criterion we use is this: - - The types of the updated fields - mention only the universally-quantified type variables - of the data constructor - -NB: this is not (quite) the same as being a "naughty" record selector -(See Note [Naughty record selectors]) in TcTyClsDecls), at least -in the case of GADTs. Consider - data T a where { MkT :: { f :: a } :: T [a] } -Then f is not "naughty" because it has a well-typed record selector. -But we don't allow updates for 'f'. (One could consider trying to -allow this, but it makes my head hurt. Badly. And no one has asked -for it.) - -In principle one could go further, and allow - g :: T a -> T a - g t = t { f2 = \x -> x } -because the expression is polymorphic...but that seems a bridge too far. - -Note [Data family example] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - data instance T (a,b) = MkT { x::a, y::b } - ---> - data :TP a b = MkT { a::a, y::b } - coTP a b :: T (a,b) ~ :TP a b - -Suppose r :: T (t1,t2), e :: t3 -Then r { x=e } :: T (t3,t1) - ---> - case r |> co1 of - MkT x y -> MkT e y |> co2 - where co1 :: T (t1,t2) ~ :TP t1 t2 - co2 :: :TP t3 t2 ~ T (t3,t2) -The wrapping with co2 is done by the constructor wrapper for MkT - -Outgoing invariants -~~~~~~~~~~~~~~~~~~~ -In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): - - * cons are the data constructors to be updated - - * in_inst_tys, out_inst_tys have same length, and instantiate the - *representation* tycon of the data cons. In Note [Data - family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] - -Note [Mixed Record Field Updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following pattern synonym. - - data MyRec = MyRec { foo :: Int, qux :: String } - - pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} - -This allows updates such as the following - - updater :: MyRec -> MyRec - updater a = a {f1 = 1 } - -It would also make sense to allow the following update (which we reject). - - updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two" - -This leads to confusing behaviour when the selectors in fact refer the same -field. - - updater a = a {f1 = 1, foo = 2} ==? ??? - -For this reason, we reject a mixture of pattern synonym and normal record -selectors in the same update block. Although of course we still allow the -following. - - updater a = (a {f1 = 1}) {foo = 2} - - > updater (MyRec 0 "str") - MyRec 2 "str" - --} - -tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty - = ASSERT( notNull rbnds ) - do { -- STEP -2: typecheck the record_expr, the record to be updated - (record_expr', record_rho) <- tcInferRho record_expr - - -- STEP -1 See Note [Disambiguating record fields] - -- After this we know that rbinds is unambiguous - ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty - ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds - upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds - sel_ids = map selectorAmbiguousFieldOcc upd_flds - -- STEP 0 - -- Check that the field names are really field names - -- and they are all field names for proper records or - -- all field names for pattern synonyms. - ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) - | fld <- rbinds, - -- Excludes class ops - let L loc sel_id = hsRecUpdFieldId (unLoc fld), - not (isRecordSelector sel_id), - let fld_name = idName sel_id ] - ; unless (null bad_guys) (sequence bad_guys >> failM) - -- See note [Mixed Record Selectors] - ; let (data_sels, pat_syn_sels) = - partition isDataConRecordSelector sel_ids - ; MASSERT( all isPatSynRecordSelector pat_syn_sels ) - ; checkTc ( null data_sels || null pat_syn_sels ) - ( mixedSelectors data_sels pat_syn_sels ) - - -- STEP 1 - -- Figure out the tycon and data cons from the first field name - ; let -- It's OK to use the non-tc splitters here (for a selector) - sel_id : _ = sel_ids - - mtycon :: Maybe TyCon - mtycon = case idDetails sel_id of - RecSelId (RecSelData tycon) _ -> Just tycon - _ -> Nothing - - con_likes :: [ConLike] - con_likes = case idDetails sel_id of - RecSelId (RecSelData tc) _ - -> map RealDataCon (tyConDataCons tc) - RecSelId (RecSelPatSyn ps) _ - -> [PatSynCon ps] - _ -> panic "tcRecordUpd" - -- NB: for a data type family, the tycon is the instance tycon - - relevant_cons = conLikesWithFields con_likes upd_fld_occs - -- A constructor is only relevant to this process if - -- it contains *all* the fields that are being updated - -- Other ones will cause a runtime error if they occur - - -- Step 2 - -- Check that at least one constructor has all the named fields - -- i.e. has an empty set of bad fields returned by badFields - ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes) - - -- Take apart a representative constructor - ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) - = conLikeFullSig con1 - con1_flds = map flLabel $ conLikeFieldLabels con1 - con1_tv_tys = mkTyVarTys con1_tvs - con1_res_ty = case mtycon of - Just tc -> mkFamilyTyConApp tc con1_tv_tys - Nothing -> conLikeResTy con1 con1_tv_tys - - -- Check that we're not dealing with a unidirectional pattern - -- synonym - ; unless (isJust $ conLikeWrapId_maybe con1) - (nonBidirectionalErr (conLikeName con1)) - - -- STEP 3 Note [Criteria for update] - -- Check that each updated field is polymorphic; that is, its type - -- mentions only the universally-quantified variables of the data con - ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys - bad_upd_flds = filter bad_fld flds1_w_tys - con1_tv_set = mkVarSet con1_tvs - bad_fld (fld, ty) = fld `elem` upd_fld_occs && - not (tyCoVarsOfType ty `subVarSet` con1_tv_set) - ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) - - -- STEP 4 Note [Type of a record update] - -- Figure out types for the scrutinee and result - -- Both are of form (T a b c), with fresh type variables, but with - -- common variables where the scrutinee and result must have the same type - -- These are variables that appear in *any* arg of *any* of the - -- relevant constructors *except* in the updated fields - -- - ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons - is_fixed_tv tv = tv `elemVarSet` fixed_tvs - - mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType) - -- Deals with instantiation of kind variables - -- c.f. TcMType.newMetaTyVars - mk_inst_ty subst (tv, result_inst_ty) - | is_fixed_tv tv -- Same as result type - = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) - | otherwise -- Fresh type, of correct kind - = do { (subst', new_tv) <- newMetaTyVarX subst tv - ; return (subst', mkTyVarTy new_tv) } - - ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs - ; let result_inst_tys = mkTyVarTys con1_tvs' - init_subst = mkEmptyTCvSubst (getTCvInScope result_subst) - - ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst - (con1_tvs `zip` result_inst_tys) - - ; let rec_res_ty = TcType.substTy result_subst con1_res_ty - scrut_ty = TcType.substTy scrut_subst con1_res_ty - con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys - - ; wrap_res <- tcSubTypeHR (exprCtOrigin expr) - (Just expr) rec_res_ty res_ty - ; co_scrut <- unifyType (Just record_expr) record_rho scrut_ty - -- NB: normal unification is OK here (as opposed to subsumption), - -- because for this to work out, both record_rho and scrut_ty have - -- to be normal datatypes -- no contravariant stuff can go on - - -- STEP 5 - -- Typecheck the bindings - ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds - - -- STEP 6: Deal with the stupid theta - ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1) - ; instStupidTheta RecordUpdOrigin theta' - - -- Step 7: make a cast for the scrutinee, in the - -- case that it's from a data family - ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty - fam_co | Just tycon <- mtycon - , Just co_con <- tyConFamilyCoercion_maybe tycon - = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys []) - | otherwise - = idHsWrapper - - -- Step 8: Check that the req constraints are satisfied - -- For normal data constructors req_theta is empty but we must do - -- this check for pattern synonyms. - ; let req_theta' = substThetaUnchecked scrut_subst req_theta - ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta' - - -- Phew! - ; return $ - mkHsWrap wrap_res $ - RecordUpd { rupd_expr = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') - , rupd_flds = rbinds' - , rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys - , rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } } - -tcExpr (HsRecFld f) res_ty - = tcCheckRecSelId f res_ty - -{- -************************************************************************ -* * - Arithmetic sequences e.g. [a,b..] - and their parallel-array counterparts e.g. [: a,b.. :] - -* * -************************************************************************ --} - -tcExpr (ArithSeq _ witness seq) res_ty - = tcArithSeq witness seq res_ty - -tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty - = do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedPArrTy res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar - ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) - (idName enumFromToP) elt_ty - ; return $ - mkHsWrapCo coi $ PArrSeq enum_from_to (FromTo expr1' expr2') } - -tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty - = do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedPArrTy res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; expr3' <- tcPolyExpr expr3 elt_ty - ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar - ; eft <- newMethodFromName (PArrSeqOrigin seq) - (idName enumFromThenToP) elt_ty -- !!!FIXME: chak - ; return $ - mkHsWrapCo coi $ - PArrSeq eft (FromThenTo expr1' expr2' expr3') } - -tcExpr (PArrSeq _ _) _ - = panic "TcExpr.tcExpr: Infinite parallel array!" - -- the parser shouldn't have generated it and the renamer shouldn't have - -- let it through - -{- -************************************************************************ -* * - Template Haskell -* * -************************************************************************ --} - --- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'. --- Here we get rid of it and add the finalizers to the global environment. --- --- See Note [Delaying modFinalizers in untyped splices] in RnSplice. -tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr))) - res_ty - = do addModFinalizersWithLclEnv mod_finalizers - tcExpr expr res_ty -tcExpr (HsSpliceE splice) res_ty - = tcSpliceExpr splice res_ty -tcExpr (HsBracket brack) res_ty - = tcTypedBracket brack res_ty -tcExpr (HsRnBracketOut brack ps) res_ty - = tcUntypedBracket brack ps res_ty - -{- -************************************************************************ -* * - Catch-all -* * -************************************************************************ --} - -tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) - -- Include ArrForm, ArrApp, which shouldn't appear at all - -- Also HsTcBracketOut, HsQuasiQuoteE - -{- -************************************************************************ -* * - Arithmetic sequences [a..b] etc -* * -************************************************************************ --} - -tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> ExpRhoType - -> TcM (HsExpr TcId) - -tcArithSeq witness seq@(From expr) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr' <- tcPolyExpr expr elt_ty - ; enum_from <- newMethodFromName (ArithSeqOrigin seq) - enumFromName elt_ty - ; return $ mkHsWrap wrap $ - ArithSeq enum_from wit' (From expr') } - -tcArithSeq witness seq@(FromThen expr1 expr2) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenName elt_ty - ; return $ mkHsWrap wrap $ - ArithSeq enum_from_then wit' (FromThen expr1' expr2') } - -tcArithSeq witness seq@(FromTo expr1 expr2) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) - enumFromToName elt_ty - ; return $ mkHsWrap wrap $ - ArithSeq enum_from_to wit' (FromTo expr1' expr2') } - -tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; expr3' <- tcPolyExpr expr3 elt_ty - ; eft <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenToName elt_ty - ; return $ mkHsWrap wrap $ - ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } - ------------------ -arithSeqEltType :: Maybe (SyntaxExpr Name) -> ExpRhoType - -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr Id)) -arithSeqEltType Nothing res_ty - = do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; return (mkWpCastN coi, elt_ty, Nothing) } -arithSeqEltType (Just fl) res_ty - = do { (elt_ty, fl') - <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ - \ [elt_ty] -> return elt_ty - ; return (idHsWrapper, elt_ty, Just fl') } - -{- -************************************************************************ -* * - Applications -* * -************************************************************************ --} - -type LHsExprArgIn = Either (LHsExpr Name) (LHsWcType Name) -type LHsExprArgOut = Either (LHsExpr TcId) (LHsWcType Name) - -- Left e => argument expression - -- Right ty => visible type application - -tcApp1 :: HsExpr Name -- either HsApp or HsAppType - -> ExpRhoType -> TcM (HsExpr TcId) -tcApp1 e res_ty - = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty - ; return (mkHsWrap wrap $ unLoc $ foldl mk_hs_app fun args) } - where - mk_hs_app f (Left a) = mkHsApp f a - mk_hs_app f (Right a) = mkHsAppTypeOut f a - -tcApp :: Maybe SDoc -- like "The function `f' is applied to" - -- or leave out to get exactly that message - -> LHsExpr Name -> [LHsExprArgIn] -- Function and args - -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut]) - -- (wrap, fun, args). For an ordinary function application, - -- these should be assembled as (wrap (fun args)). - -- But OpApp is slightly different, so that's why the caller - -- must assemble - -tcApp m_herald orig_fun orig_args res_ty - = go orig_fun orig_args - where - go :: LHsExpr Name -> [LHsExprArgIn] - -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut]) - go (L _ (HsPar e)) args = go e args - go (L _ (HsApp e1 e2)) args = go e1 (Left e2:args) - go (L _ (HsAppType e t)) args = go e (Right t:args) - - go (L loc (HsVar (L _ fun))) args - | fun `hasKey` tagToEnumKey - , count isLeft args == 1 - = do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty - ; return (wrap, expr, args) } - - | fun `hasKey` seqIdKey - , count isLeft args == 2 - = do { (wrap, expr, args) <- tcSeq loc fun args res_ty - ; return (wrap, expr, args) } - - go (L loc (HsRecFld (Ambiguous lbl _))) args@(Left (L _ arg) : _) - | Just sig_ty <- obviousSig arg - = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty - ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; go (L loc (HsRecFld (Unambiguous lbl sel_name))) args } - - go fun args - = do { -- Type-check the function - ; (fun1, fun_sigma) <- tcInferFun fun - ; let orig = lexprCtOrigin fun - - ; (wrap_fun, args1, actual_res_ty) - <- tcArgs fun fun_sigma orig args - (m_herald `orElse` mk_app_msg fun) - - -- this is just like tcWrapResult, but the types don't line - -- up to call that function - ; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $ - tcSubTypeDS_NC_O orig GenSigCtxt - (Just $ foldl mk_hs_app fun args) - actual_res_ty res_ty - - ; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) } - - mk_hs_app f (Left a) = mkHsApp f a - mk_hs_app f (Right a) = mkHsAppType f a - -mk_app_msg :: LHsExpr Name -> SDoc -mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun) - , text "is applied to"] - -mk_op_msg :: LHsExpr Name -> SDoc -mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" - ----------------- -tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType) --- Infer type of a function -tcInferFun (L loc (HsVar (L _ name))) - = do { (fun, ty) <- setSrcSpan loc (tcInferId name) - -- Don't wrap a context around a plain Id - ; return (L loc fun, ty) } - -tcInferFun (L loc (HsRecFld f)) - = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f) - -- Don't wrap a context around a plain Id - ; return (L loc fun, ty) } - -tcInferFun fun - = tcInferSigma fun - -- NB: tcInferSigma; see TcUnify - -- Note [Deep instantiation of InferResult] - - ----------------- --- | Type-check the arguments to a function, possibly including visible type --- applications -tcArgs :: LHsExpr Name -- ^ The function itself (for err msgs only) - -> TcSigmaType -- ^ the (uninstantiated) type of the function - -> CtOrigin -- ^ the origin for the function's type - -> [LHsExprArgIn] -- ^ the args - -> SDoc -- ^ the herald for matchActualFunTys - -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType) - -- ^ (a wrapper for the function, the tc'd args, result type) -tcArgs fun orig_fun_ty fun_orig orig_args herald - = go [] 1 orig_fun_ty orig_args - where - orig_arity = length orig_args - - go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty) - - go acc_args n fun_ty (Right hs_ty_arg:args) - = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty - -- wrap1 :: fun_ty "->" upsilon_ty - ; case tcSplitForAllTy_maybe upsilon_ty of - Just (tvb, inner_ty) -> - do { let tv = binderVar tvb - vis = binderArgFlag tvb - kind = tyVarKind tv - ; MASSERT2( vis == Specified - , (vcat [ ppr fun_ty, ppr upsilon_ty, ppr tvb - , ppr inner_ty, pprTyVar tv - , ppr vis ]) ) - ; ty_arg <- tcHsTypeApp hs_ty_arg kind - - ; inner_ty <- zonkTcType inner_ty - -- See Note [Visible type application zonk] - - ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg]) - insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty - -- NB: tv and ty_arg have the same kind, so this - -- substitution is kind-respecting - ; traceTc "VTA" (vcat [ppr tv, ppr kind - , ppr ty_arg - , ppr (typeKind ty_arg) - , ppr insted_ty ]) - ; (inner_wrap, args', res_ty) - <- go acc_args (n+1) insted_ty args - -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty - ; let inst_wrap = mkWpTyApps [ty_arg] - ; return ( inner_wrap <.> inst_wrap <.> wrap1 - , Right hs_ty_arg : args' - , res_ty ) } - _ -> ty_app_err upsilon_ty hs_ty_arg } - - go acc_args n fun_ty (Left arg : args) - = do { (wrap, [arg_ty], res_ty) - <- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty - acc_args orig_arity - -- wrap :: fun_ty "->" arg_ty -> res_ty - ; arg' <- tcArg fun arg arg_ty n - ; (inner_wrap, args', inner_res_ty) - <- go (arg_ty : acc_args) (n+1) res_ty args - -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty - ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap - , Left arg' : args' - , inner_res_ty ) } - where - doc = text "When checking the" <+> speakNth n <+> - text "argument to" <+> quotes (ppr fun) - - ty_app_err ty arg - = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty - ; failWith $ - text "Cannot apply expression of type" <+> quotes (ppr ty) $$ - text "to a visible type argument" <+> quotes (ppr arg) } - -{- Note [Visible type application zonk] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg). - -* tcHsTypeApp only guarantees that - - ty_arg is zonked - - kind(zonk(tv)) = kind(ty_arg) - (checkExpectedKind zonks as it goes). - -So we must zonk inner_ty as well, to guarantee consistency between zonk(tv) -and inner_ty. Otherwise we can build an ill-kinded type. An example was -Trac #14158, where we had: - id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a -and we had the visible type application - id @(->) - -* We instantiated k := kappa, yielding - forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a -* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *). -* That instantiated (->) as ((->) q1 q1), and unified kappa := q1, - Here q1 :: RuntimeRep -* Now we substitute - cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> * - but we must first zonk the inner_ty to get - forall (a :: TYPE q1). cat a a - so that the result of substitution is well-kinded - Failing to do so led to Trac #14158. --} - ----------------- -tcArg :: LHsExpr Name -- The function (for error messages) - -> LHsExpr Name -- Actual arguments - -> TcRhoType -- expected arg type - -> Int -- # of argument - -> TcM (LHsExpr TcId) -- Resulting argument -tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $ - tcPolyExprNC arg ty - ----------------- -tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId] -tcTupArgs args tys - = ASSERT( equalLength args tys ) mapM go (args `zip` tys) - where - go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty)) - go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty - ; return (L l (Present expr')) } - ---------------------------- --- See TcType.SyntaxOpType also for commentary -tcSyntaxOp :: CtOrigin - -> SyntaxExpr Name - -> [SyntaxOpType] -- ^ shape of syntax operator arguments - -> ExpRhoType -- ^ overall result type - -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExpr TcId) --- ^ Typecheck a syntax operator --- The operator is always a variable at this stage (i.e. renamer output) -tcSyntaxOp orig expr arg_tys res_ty - = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) - --- | Slightly more general version of 'tcSyntaxOp' that allows the caller --- to specify the shape of the result of the syntax operator -tcSyntaxOpGen :: CtOrigin - -> SyntaxExpr Name - -> [SyntaxOpType] - -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExpr TcId) -tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) }) - arg_tys res_ty thing_inside - = do { (expr, sigma) <- tcInferId op - ; (result, expr_wrap, arg_wraps, res_wrap) - <- tcSynArgA orig sigma arg_tys res_ty $ - thing_inside - ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) } - -tcSyntaxOpGen _ other _ _ _ = pprPanic "tcSyntaxOp" (ppr other) - -{- -Note [tcSynArg] -~~~~~~~~~~~~~~~ -Because of the rich structure of SyntaxOpType, we must do the -contra-/covariant thing when working down arrows, to get the -instantiation vs. skolemisation decisions correct (and, more -obviously, the orientation of the HsWrappers). We thus have -two tcSynArgs. --} - --- works on "expected" types, skolemising where necessary --- See Note [tcSynArg] -tcSynArgE :: CtOrigin - -> TcSigmaType - -> SyntaxOpType -- ^ shape it is expected to have - -> ([TcSigmaType] -> TcM a) -- ^ check the arguments - -> TcM (a, HsWrapper) - -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) -tcSynArgE orig sigma_ty syn_ty thing_inside - = do { (skol_wrap, (result, ty_wrapper)) - <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty -> - go rho_ty syn_ty - ; return (result, skol_wrap <.> ty_wrapper) } - where - go rho_ty SynAny - = do { result <- thing_inside [rho_ty] - ; return (result, idHsWrapper) } - - go rho_ty SynRho -- same as SynAny, because we skolemise eagerly - = do { result <- thing_inside [rho_ty] - ; return (result, idHsWrapper) } - - go rho_ty SynList - = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty - ; result <- thing_inside [elt_ty] - ; return (result, mkWpCastN list_co) } - - go rho_ty (SynFun arg_shape res_shape) - = do { ( ( ( (result, arg_ty, res_ty) - , res_wrapper ) -- :: res_ty_out "->" res_ty - , arg_wrapper1, [], arg_wrapper2 ) -- :: arg_ty "->" arg_ty_out - , match_wrapper ) -- :: (arg_ty -> res_ty) "->" rho_ty - <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $ - \ [arg_ty] res_ty -> - do { arg_tc_ty <- expTypeToType arg_ty - ; res_tc_ty <- expTypeToType res_ty - - -- another nested arrow is too much for now, - -- but I bet we'll never need this - ; MASSERT2( case arg_shape of - SynFun {} -> False; - _ -> True - , text "Too many nested arrows in SyntaxOpType" $$ - pprCtOrigin orig ) - - ; tcSynArgA orig arg_tc_ty [] arg_shape $ - \ arg_results -> - tcSynArgE orig res_tc_ty res_shape $ - \ res_results -> - do { result <- thing_inside (arg_results ++ res_results) - ; return (result, arg_tc_ty, res_tc_ty) }} - - ; return ( result - , match_wrapper <.> - mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper - arg_ty res_ty doc ) } - where - herald = text "This rebindable syntax expects a function with" - doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig - - go rho_ty (SynType the_ty) - = do { wrap <- tcSubTypeET orig GenSigCtxt the_ty rho_ty - ; result <- thing_inside [] - ; return (result, wrap) } - --- works on "actual" types, instantiating where necessary --- See Note [tcSynArg] -tcSynArgA :: CtOrigin - -> TcSigmaType - -> [SyntaxOpType] -- ^ argument shapes - -> SyntaxOpType -- ^ result shape - -> ([TcSigmaType] -> TcM a) -- ^ check the arguments - -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) - -- ^ returns a wrapper to be applied to the original function, - -- wrappers to be applied to arguments - -- and a wrapper to be applied to the overall expression -tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside - = do { (match_wrapper, arg_tys, res_ty) - <- matchActualFunTys herald orig noThing (length arg_shapes) sigma_ty - -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) - ; ((result, res_wrapper), arg_wrappers) - <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results -> - tc_syn_arg res_ty res_shape $ \ res_results -> - thing_inside (arg_results ++ res_results) - ; return (result, match_wrapper, arg_wrappers, res_wrapper) } - where - herald = text "This rebindable syntax expects a function with" - - tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType] - -> ([TcSigmaType] -> TcM a) - -> TcM (a, [HsWrapper]) - -- the wrappers are for arguments - tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside - = do { ((result, arg_wraps), arg_wrap) - <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results -> - tc_syn_args_e arg_tys arg_shapes $ \ args_results -> - thing_inside (arg1_results ++ args_results) - ; return (result, arg_wrap : arg_wraps) } - tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] - - tc_syn_arg :: TcSigmaType -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, HsWrapper) - -- the wrapper applies to the overall result - tc_syn_arg res_ty SynAny thing_inside - = do { result <- thing_inside [res_ty] - ; return (result, idHsWrapper) } - tc_syn_arg res_ty SynRho thing_inside - = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty - ; result <- thing_inside [rho_ty] - ; return (result, inst_wrap) } - tc_syn_arg res_ty SynList thing_inside - = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty - ; (list_co, elt_ty) <- matchExpectedListTy rho_ty - -- list_co :: [elt_ty] ~N rho_ty - ; result <- thing_inside [elt_ty] - ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) } - tc_syn_arg _ (SynFun {}) _ - = pprPanic "tcSynArgA hits a SynFun" (ppr orig) - tc_syn_arg res_ty (SynType the_ty) thing_inside - = do { wrap <- tcSubTypeO orig GenSigCtxt res_ty the_ty - ; result <- thing_inside [] - ; return (result, wrap) } - -{- -Note [Push result type in] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unify with expected result before type-checking the args so that the -info from res_ty percolates to args. This is when we might detect a -too-few args situation. (One can think of cases when the opposite -order would give a better error message.) -experimenting with putting this first. - -Here's an example where it actually makes a real difference - - class C t a b | t a -> b - instance C Char a Bool - - data P t a = forall b. (C t a b) => MkP b - data Q t = MkQ (forall a. P t a) - - f1, f2 :: Q Char; - f1 = MkQ (MkP True) - f2 = MkQ (MkP True :: forall a. P Char a) - -With the change, f1 will type-check, because the 'Char' info from -the signature is propagated into MkQ's argument. With the check -in the other order, the extra signature in f2 is reqd. - -************************************************************************ -* * - Expressions with a type signature - expr :: type -* * -********************************************************************* -} - -tcExprSig :: LHsExpr Name -> TcIdSigInfo -> TcM (LHsExpr TcId, TcType) -tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id - ; given <- newEvVars theta - ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs - skol_tvs = map snd tv_prs - ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $ - tcExtendTyVarEnv2 tv_prs $ - tcPolyExprNC expr tau - - ; let poly_wrap = mkWpTyLams skol_tvs - <.> mkWpLams given - <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', idType poly_id) } - -tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { (tclvl, wanted, (expr', sig_inst)) - <- pushLevelAndCaptureConstraints $ - do { sig_inst <- tcInstSig sig - ; expr' <- tcExtendTyVarEnv2 (sig_inst_skols sig_inst) $ - tcExtendTyVarEnv2 (sig_inst_wcs sig_inst) $ - tcPolyExprNC expr (sig_inst_tau sig_inst) - ; return (expr', sig_inst) } - -- See Note [Partial expression signatures] - ; let tau = sig_inst_tau sig_inst - infer_mode | null (sig_inst_theta sig_inst) - , isNothing (sig_inst_wcx sig_inst) - = ApplyMR - | otherwise - = NoRestrictions - ; (qtvs, givens, ev_binds, _) - <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted - ; tau <- zonkTcType tau - ; let inferred_theta = map evVarPred givens - tau_tvs = tyCoVarsOfType tau - ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta - tau_tvs qtvs (Just sig_inst) - ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau - my_sigma = mkForAllTys binders (mkPhiTy my_theta tau) - ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. - then return idHsWrapper -- Fast path; also avoids complaint when we infer - -- an ambiguouse type and have AllowAmbiguousType - -- e..g infer x :: forall a. F a -> Int - else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma - - ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) - ; let poly_wrap = wrap - <.> mkWpTyLams qtvs - <.> mkWpLams givens - <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', my_sigma) } - - -{- Note [Partial expression signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Partial type signatures on expressions are easy to get wrong. But -here is a guiding principile - e :: ty -should behave like - let x :: ty - x = e - in x - -So for partial signatures we apply the MR if no context is given. So - e :: IO _ apply the MR - e :: _ => IO _ do not apply the MR -just like in TcBinds.decideGeneralisationPlan - -This makes a difference (Trac #11670): - peek :: Ptr a -> IO CLong - peek ptr = peekElemOff undefined 0 :: _ -from (peekElemOff undefined 0) we get - type: IO w - constraints: Storable w - -We must NOT try to generalise over 'w' because the signature specifies -no constraints so we'll complain about not being able to solve -Storable w. Instead, don't generalise; then _ gets instantiated to -CLong, as it should. --} - -{- ********************************************************************* -* * - tcInferId -* * -********************************************************************* -} - -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId) -tcCheckId name res_ty - = do { (expr, actual_res_ty) <- tcInferId name - ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) - ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOf name) expr actual_res_ty res_ty } - -tcCheckRecSelId :: AmbiguousFieldOcc Name -> ExpRhoType -> TcM (HsExpr TcId) -tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty - = do { (expr, actual_res_ty) <- tcInferRecSelId f - ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOfRecSel lbl) expr actual_res_ty res_ty } -tcCheckRecSelId (Ambiguous lbl _) res_ty - = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of - Nothing -> ambiguousSelector lbl - Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg - ; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty } - ------------------------- -tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType) -tcInferRecSelId (Unambiguous (L _ lbl) sel) - = do { (expr', ty) <- tc_infer_id lbl sel - ; return (expr', ty) } -tcInferRecSelId (Ambiguous lbl _) - = ambiguousSelector lbl - ------------------------- -tcInferId :: Name -> TcM (HsExpr TcId, TcSigmaType) --- Look up an occurrence of an Id --- Do not instantiate its type -tcInferId id_name - | id_name `hasKey` tagToEnumKey - = failWithTc (text "tagToEnum# must appear applied to one argument") - -- tcApp catches the case (tagToEnum# arg) - - | id_name `hasKey` assertIdKey - = do { dflags <- getDynFlags - ; if gopt Opt_IgnoreAsserts dflags - then tc_infer_id (nameRdrName id_name) id_name - else tc_infer_assert id_name } - - | otherwise - = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name - ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) - ; return (expr, ty) } - -tc_infer_assert :: Name -> TcM (HsExpr TcId, TcSigmaType) --- Deal with an occurrence of 'assert' --- See Note [Adding the implicit parameter to 'assert'] -tc_infer_assert assert_name - = do { assert_error_id <- tcLookupId assertErrorName - ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) - (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho) - } - -tc_infer_id :: RdrName -> Name -> TcM (HsExpr TcId, TcSigmaType) -tc_infer_id lbl id_name - = do { thing <- tcLookup id_name - ; case thing of - ATcId { tct_id = id } - -> do { check_naughty id -- Note [Local record selectors] - ; checkThLocalId id - ; return_id id } - - AGlobal (AnId id) - -> do { check_naughty id - ; return_id id } - -- A global cannot possibly be ill-staged - -- nor does it need the 'lifting' treatment - -- hence no checkTh stuff here - - AGlobal (AConLike cl) -> case cl of - RealDataCon con -> return_data_con con - PatSynCon ps -> tcPatSynBuilderOcc ps - - _ -> failWithTc $ - ppr thing <+> text "used where a value identifier was expected" } - where - return_id id = return (HsVar (noLoc id), idType id) - - return_data_con con - -- For data constructors, must perform the stupid-theta check - | null stupid_theta - = return (HsConLikeOut (RealDataCon con), con_ty) - - | otherwise - -- See Note [Instantiating stupid theta] - = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty - ; (subst, tvs') <- newMetaTyVars tvs - ; let tys' = mkTyVarTys tvs' - theta' = substTheta subst theta - rho' = substTy subst rho - ; wrap <- instCall (OccurrenceOf id_name) tys' theta' - ; addDataConStupidTheta con tys' - ; return (mkHsWrap wrap (HsConLikeOut (RealDataCon con)), rho') } - - where - con_ty = dataConUserType con - stupid_theta = dataConStupidTheta con - - check_naughty id - | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) - | otherwise = return () - - -tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr TcId) --- Typecheck an occurrence of an unbound Id --- --- Some of these started life as a true expression hole "_". --- Others might simply be variables that accidentally have no binding site --- --- We turn all of them into HsVar, since HsUnboundVar can't contain an --- Id; and indeed the evidence for the CHoleCan does bind it, so it's --- not unbound any more! -tcUnboundId unbound res_ty - = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (Trac #12531) - ; let occ = unboundVarOcc unbound - ; name <- newSysName occ - ; let ev = mkLocalId name ty - ; loc <- getCtLocM HoleOrigin Nothing - ; let can = CHoleCan { cc_ev = CtWanted { ctev_pred = ty - , ctev_dest = EvVarDest ev - , ctev_nosh = WDeriv - , ctev_loc = loc} - , cc_hole = ExprHole unbound } - ; emitInsoluble can - ; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noLoc ev)) ty res_ty } - - -{- -Note [Adding the implicit parameter to 'assert'] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker transforms (assert e1 e2) to (assertError e1 e2). -This isn't really the Right Thing because there's no way to "undo" -if you want to see the original source code in the typechecker -output. We'll have fix this in due course, when we care more about -being able to reconstruct the exact original program. - -Note [tagToEnum#] -~~~~~~~~~~~~~~~~~ -Nasty check to ensure that tagToEnum# is applied to a type that is an -enumeration TyCon. Unification may refine the type later, but this -check won't see that, alas. It's crude, because it relies on our -knowing *now* that the type is ok, which in turn relies on the -eager-unification part of the type checker pushing enough information -here. In theory the Right Thing to do is to have a new form of -constraint but I definitely cannot face that! And it works ok as-is. - -Here's are two cases that should fail - f :: forall a. a - f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable - - g :: Int - g = tagToEnum# 0 -- Int is not an enumeration - -When data type families are involved it's a bit more complicated. - data family F a - data instance F [Int] = A | B | C -Then we want to generate something like - tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] -Usually that coercion is hidden inside the wrappers for -constructors of F [Int] but here we have to do it explicitly. - -It's all grotesquely complicated. - -Note [Instantiating stupid theta] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, when we infer the type of an Id, we don't instantiate, -because we wish to allow for visible type application later on. -But if a datacon has a stupid theta, we're a bit stuck. We need -to emit the stupid theta constraints with instantiated types. It's -difficult to defer this to the lazy instantiation, because a stupid -theta has no spot to put it in a type. So we just instantiate eagerly -in this case. Thus, users cannot use visible type application with -a data constructor sporting a stupid theta. I won't feel so bad for -the users that complain. - --} - -tcSeq :: SrcSpan -> Name -> [LHsExprArgIn] - -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut]) --- (seq e1 e2) :: res_ty --- We need a special typing rule because res_ty can be unboxed --- See Note [Typing rule for seq] -tcSeq loc fun_name args res_ty - = do { fun <- tcLookupId fun_name - ; (arg1_ty, args1) <- case args of - (Right hs_ty_arg1 : args1) - -> do { ty_arg1 <- tcHsTypeApp hs_ty_arg1 liftedTypeKind - ; return (ty_arg1, args1) } - - _ -> do { arg_ty1 <- newFlexiTyVarTy liftedTypeKind - ; return (arg_ty1, args) } - - ; (arg1, arg2, arg2_exp_ty) <- case args1 of - [Right hs_ty_arg2, Left term_arg1, Left term_arg2] - -> do { arg2_kind <- newOpenTypeKind - ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 arg2_kind - -- see Note [Typing rule for seq] - ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg2 res_ty - ; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) } - [Left term_arg1, Left term_arg2] - -> return (term_arg1, term_arg2, res_ty) - _ -> too_many_args "seq" args - - ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty) - ; arg2' <- tcMonoExpr arg2 arg2_exp_ty - ; res_ty <- readExpType res_ty -- by now, it's surely filled in - ; let fun' = L loc (HsWrap ty_args (HsVar (L loc fun))) - ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty - ; return (idHsWrapper, fun', [Left arg1', Left arg2']) } - -tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType - -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut]) --- tagToEnum# :: forall a. Int# -> a --- See Note [tagToEnum#] Urgh! -tcTagToEnum loc fun_name args res_ty - = do { fun <- tcLookupId fun_name - - ; arg <- case args of - [Right hs_ty_arg, Left term_arg] - -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind - ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty - -- other than influencing res_ty, we just - -- don't care about a type arg passed in. - -- So drop the evidence. - ; return term_arg } - [Left term_arg] -> do { _ <- expTypeToType res_ty - ; return term_arg } - _ -> too_many_args "tagToEnum#" args - - ; res_ty <- readExpType res_ty - ; ty' <- zonkTcType res_ty - - -- Check that the type is algebraic - ; let mb_tc_app = tcSplitTyConApp_maybe ty' - Just (tc, tc_args) = mb_tc_app - ; checkTc (isJust mb_tc_app) - (mk_error ty' doc1) - - -- Look through any type family - ; fam_envs <- tcGetFamInstEnvs - ; let (rep_tc, rep_args, coi) - = tcLookupDataFamInst fam_envs tc tc_args - -- coi :: tc tc_args ~R rep_tc rep_args - - ; checkTc (isEnumerationTyCon rep_tc) - (mk_error ty' doc2) - - ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy) - ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun))) - rep_ty = mkTyConApp rep_tc rep_args - - ; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) } - -- coi is a Representational coercion - where - doc1 = vcat [ text "Specify the type by giving a type signature" - , text "e.g. (tagToEnum# x) :: Bool" ] - doc2 = text "Result type must be an enumeration type" - - mk_error :: TcType -> SDoc -> SDoc - mk_error ty what - = hang (text "Bad call to tagToEnum#" - <+> text "at type" <+> ppr ty) - 2 what - -too_many_args :: String -> [LHsExprArgIn] -> TcM a -too_many_args fun args - = failWith $ - hang (text "Too many type arguments to" <+> text fun <> colon) - 2 (sep (map pp args)) - where - pp (Left e) = ppr e - pp (Right (HsWC { hswc_body = L _ t })) = pprParendHsType t - - -{- -************************************************************************ -* * - Template Haskell checks -* * -************************************************************************ --} - -checkThLocalId :: Id -> TcM () -checkThLocalId id - = do { mb_local_use <- getStageAndBindLevel (idName id) - ; case mb_local_use of - Just (top_lvl, bind_lvl, use_stage) - | thLevel use_stage > bind_lvl - , isNotTopLevel top_lvl - -> checkCrossStageLifting id use_stage - _ -> return () -- Not a locally-bound thing, or - -- no cross-stage link - } - --------------------------------------- -checkCrossStageLifting :: Id -> ThStage -> TcM () --- If we are inside typed brackets, and (use_lvl > bind_lvl) --- we must check whether there's a cross-stage lift to do --- Examples \x -> [|| x ||] --- [|| map ||] --- There is no error-checking to do, because the renamer did that --- --- This is similar to checkCrossStageLifting in RnSplice, but --- this code is applied to *typed* brackets. - -checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var)) - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [|| h x ||] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the splice proxy, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same splice proxy, but that doesn't - -- matter, although it's a mite untidy. - do { let id_ty = idType id - ; checkTc (isTauTy id_ty) (polySpliceErr id) - -- If x is polymorphic, its occurrence sites might - -- have different instantiations, so we can't use plain - -- 'x' as the splice proxy name. I don't know how to - -- solve this, and it's probably unimportant, so I'm - -- just going to flag an error for now - - ; lift <- if isStringTy id_ty then - do { sid <- tcLookupId THNames.liftStringName - -- See Note [Lifting strings] - ; return (HsVar (noLoc sid)) } - else - setConstraintVar lie_var $ - -- Put the 'lift' constraint into the right LIE - newMethodFromName (OccurrenceOf (idName id)) - THNames.liftName id_ty - - -- Update the pending splices - ; ps <- readMutVar ps_var - ; let pending_splice = PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id)) - ; writeMutVar ps_var (pending_splice : ps) - - ; return () } - -checkCrossStageLifting _ _ = return () - -polySpliceErr :: Id -> SDoc -polySpliceErr id - = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) - -{- -Note [Lifting strings] -~~~~~~~~~~~~~~~~~~~~~~ -If we see $(... [| s |] ...) where s::String, we don't want to -generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. -So this conditional short-circuits the lifting mechanism to generate -(liftString "xy") in that case. I didn't want to use overlapping instances -for the Lift class in TH.Syntax, because that can lead to overlapping-instance -errors in a polymorphic situation. - -If this check fails (which isn't impossible) we get another chance; see -Note [Converting strings] in Convert.hs - -Local record selectors -~~~~~~~~~~~~~~~~~~~~~~ -Record selectors for TyCons in this module are ordinary local bindings, -which show up as ATcIds rather than AGlobals. So we need to check for -naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. - - -************************************************************************ -* * -\subsection{Record bindings} -* * -************************************************************************ --} - -getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet --- These tyvars must not change across the updates -getFixedTyVars upd_fld_occs univ_tvs cons - = mkVarSet [tv1 | con <- cons - , let (u_tvs, _, eqspec, prov_theta - , req_theta, arg_tys, _) - = conLikeFullSig con - theta = eqSpecPreds eqspec - ++ prov_theta - ++ req_theta - flds = conLikeFieldLabels con - fixed_tvs = exactTyCoVarsOfTypes fixed_tys - -- fixed_tys: See Note [Type of a record update] - `unionVarSet` tyCoVarsOfTypes theta - -- Universally-quantified tyvars that - -- appear in any of the *implicit* - -- arguments to the constructor are fixed - -- See Note [Implicit type sharing] - - fixed_tys = [ty | (fl, ty) <- zip flds arg_tys - , not (flLabel fl `elem` upd_fld_occs)] - , (tv1,tv) <- univ_tvs `zip` u_tvs - , tv `elemVarSet` fixed_tvs ] - -{- -Note [Disambiguating record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the -XDuplicateRecordFields extension is used, and the renamer -encounters a record selector or update that it cannot immediately -disambiguate (because it involves fields that belong to multiple -datatypes), it will defer resolution of the ambiguity to the -typechecker. In this case, the `Ambiguous` constructor of -`AmbiguousFieldOcc` is used. - -Consider the following definitions: - - data S = MkS { foo :: Int } - data T = MkT { foo :: Int, bar :: Int } - data U = MkU { bar :: Int, baz :: Int } - -When the renamer sees `foo` as a selector or an update, it will not -know which parent datatype is in use. - -For selectors, there are two possible ways to disambiguate: - -1. Check if the pushed-in type is a function whose domain is a - datatype, for example: - - f s = (foo :: S -> Int) s - - g :: T -> Int - g = foo - - This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`. - -2. Check if the selector is applied to an argument that has a type - signature, for example: - - h = foo (s :: S) - - This is checked by `tcApp`. - - -Updates are slightly more complex. The `disambiguateRecordBinds` -function tries to determine the parent datatype in three ways: - -1. Check for types that have all the fields being updated. For example: - - f x = x { foo = 3, bar = 2 } - - Here `f` must be updating `T` because neither `S` nor `U` have - both fields. This may also discover that no possible type exists. - For example the following will be rejected: - - f' x = x { foo = 3, baz = 3 } - -2. Use the type being pushed in, if it is already a TyConApp. The - following are valid updates to `T`: - - g :: T -> T - g x = x { foo = 3 } - - g' x = x { foo = 3 } :: T - -3. Use the type signature of the record expression, if it exists and - is a TyConApp. Thus this is valid update to `T`: - - h x = (x :: T) { foo = 3 } - - -Note that we do not look up the types of variables being updated, and -no constraint-solving is performed, so for example the following will -be rejected as ambiguous: - - let bad (s :: S) = foo s - - let r :: T - r = blah - in r { foo = 3 } - - \r. (r { foo = 3 }, r :: T ) - -We could add further tests, of a more heuristic nature. For example, -rather than looking for an explicit signature, we could try to infer -the type of the argument to a selector or the record expression being -updated, in case we are lucky enough to get a TyConApp straight -away. However, it might be hard for programmers to predict whether a -particular update is sufficiently obvious for the signature to be -omitted. Moreover, this might change the behaviour of typechecker in -non-obvious ways. - -See also Note [HsRecField and HsRecUpdField] in HsPat. --} - --- Given a RdrName that refers to multiple record fields, and the type --- of its argument, try to determine the name of the selector that is --- meant. -disambiguateSelector :: Located RdrName -> Type -> TcM Name -disambiguateSelector lr@(L _ rdr) parent_type - = do { fam_inst_envs <- tcGetFamInstEnvs - ; case tyConOf fam_inst_envs parent_type of - Nothing -> ambiguousSelector lr - Just p -> - do { xs <- lookupParents rdr - ; let parent = RecSelData p - ; case lookup parent xs of - Just gre -> do { addUsedGRE True gre - ; return (gre_name gre) } - Nothing -> failWithTc (fieldNotInType parent rdr) } } - --- This field name really is ambiguous, so add a suitable "ambiguous --- occurrence" error, then give up. -ambiguousSelector :: Located RdrName -> TcM a -ambiguousSelector (L _ rdr) - = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env - ; setErrCtxt [] $ addNameClashErrRn rdr gres - ; failM } - --- Disambiguate the fields in a record update. --- See Note [Disambiguating record fields] -disambiguateRecordBinds :: LHsExpr Name -> TcRhoType - -> [LHsRecUpdField Name] -> ExpRhoType - -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -disambiguateRecordBinds record_expr record_rho rbnds res_ty - -- Are all the fields unambiguous? - = case mapM isUnambiguous rbnds of - -- If so, just skip to looking up the Ids - -- Always the case if DuplicateRecordFields is off - Just rbnds' -> mapM lookupSelector rbnds' - Nothing -> -- If not, try to identify a single parent - do { fam_inst_envs <- tcGetFamInstEnvs - -- Look up the possible parents for each field - ; rbnds_with_parents <- getUpdFieldsParents - ; let possible_parents = map (map fst . snd) rbnds_with_parents - -- Identify a single parent - ; p <- identifyParent fam_inst_envs possible_parents - -- Pick the right selector with that parent for each field - ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents } - where - -- Extract the selector name of a field update if it is unambiguous - isUnambiguous :: LHsRecUpdField Name -> Maybe (LHsRecUpdField Name, Name) - isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of - Unambiguous _ sel_name -> Just (x, sel_name) - Ambiguous{} -> Nothing - - -- Look up the possible parents and selector GREs for each field - getUpdFieldsParents :: TcM [(LHsRecUpdField Name - , [(RecSelParent, GlobalRdrElt)])] - getUpdFieldsParents - = fmap (zip rbnds) $ mapM - (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc) - rbnds - - -- Given a the lists of possible parents for each field, - -- identify a single parent - identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent - identifyParent fam_inst_envs possible_parents - = case foldr1 intersect possible_parents of - -- No parents for all fields: record update is ill-typed - [] -> failWithTc (noPossibleParents rbnds) - - -- Exactly one datatype with all the fields: use that - [p] -> return p - - -- Multiple possible parents: try harder to disambiguate - -- Can we get a parent TyCon from the pushed-in type? - _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p) - - -- Does the expression being updated have a type signature? - -- If so, try to extract a parent TyCon from it - | Just {} <- obviousSig (unLoc record_expr) - , Just tc <- tyConOf fam_inst_envs record_rho - -> return (RecSelData tc) - - -- Nothing else we can try... - _ -> failWithTc badOverloadedUpdate - - -- Make a field unambiguous by choosing the given parent. - -- Emits an error if the field cannot have that parent, - -- e.g. if the user writes - -- r { x = e } :: T - -- where T does not have field x. - pickParent :: RecSelParent - -> (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)]) - -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)) - pickParent p (upd, xs) - = case lookup p xs of - -- Phew! The parent is valid for this field. - -- Previously ambiguous fields must be marked as - -- used now that we know which one is meant, but - -- unambiguous ones shouldn't be recorded again - -- (giving duplicate deprecation warnings). - Just gre -> do { unless (null (tail xs)) $ do - let L loc _ = hsRecFieldLbl (unLoc upd) - setSrcSpan loc $ addUsedGRE True gre - ; lookupSelector (upd, gre_name gre) } - -- The field doesn't belong to this parent, so report - -- an error but keep going through all the fields - Nothing -> do { addErrTc (fieldNotInType p - (unLoc (hsRecUpdFieldRdr (unLoc upd)))) - ; lookupSelector (upd, gre_name (snd (head xs))) } - - -- Given a (field update, selector name) pair, look up the - -- selector to give a field update with an unambiguous Id - lookupSelector :: (LHsRecUpdField Name, Name) - -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)) - lookupSelector (L l upd, n) - = do { i <- tcLookupId n - ; let L loc af = hsRecFieldLbl upd - lbl = rdrNameAmbiguousFieldOcc af - ; return $ L l upd { hsRecFieldLbl - = L loc (Unambiguous (L loc lbl) i) } } - - --- Extract the outermost TyCon of a type, if there is one; for --- data families this is the representation tycon (because that's --- where the fields live). -tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon -tyConOf fam_inst_envs ty0 - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) - Nothing -> Nothing - where - (_, _, ty) = tcSplitSigmaTy ty0 - --- Variant of tyConOf that works for ExpTypes -tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon -tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 - --- For an ambiguous record field, find all the candidate record --- selectors (as GlobalRdrElts) and their parents. -lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)] -lookupParents rdr - = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env - ; mapM lookupParent gres } - where - lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) - lookupParent gre = do { id <- tcLookupId (gre_name gre) - ; if isRecordSelector id - then return (recordSelectorTyCon id, gre) - else failWithTc (notSelector (gre_name gre)) } - --- A type signature on the argument of an ambiguous record selector or --- the record expression in an update must be "obvious", i.e. the --- outermost constructor ignoring parentheses. -obviousSig :: HsExpr Name -> Maybe (LHsSigWcType Name) -obviousSig (ExprWithTySig _ ty) = Just ty -obviousSig (HsPar p) = obviousSig (unLoc p) -obviousSig _ = Nothing - - -{- -Game plan for record bindings -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -1. Find the TyCon for the bindings, from the first field label. - -2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. - -For each binding field = value - -3. Instantiate the field type (from the field label) using the type - envt from step 2. - -4 Type check the value using tcArg, passing the field type as - the expected argument type. - -This extends OK when the field types are universally quantified. --} - -tcRecordBinds - :: ConLike - -> [TcType] -- Expected type for each field - -> HsRecordBinds Name - -> TcM (HsRecordBinds TcId) - -tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) - = do { mb_binds <- mapM do_bind rbinds - ; return (HsRecFields (catMaybes mb_binds) dd) } - where - fields = map flLabel $ conLikeFieldLabels con_like - flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys - - do_bind :: LHsRecField Name (LHsExpr Name) - -> TcM (Maybe (LHsRecField TcId (LHsExpr TcId))) - do_bind (L l fld@(HsRecField { hsRecFieldLbl = f - , hsRecFieldArg = rhs })) - - = do { mb <- tcRecordField con_like flds_w_tys f rhs - ; case mb of - Nothing -> return Nothing - Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' - , hsRecFieldArg = rhs' }))) } - -tcRecordUpd - :: ConLike - -> [TcType] -- Expected type for each field - -> [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] - -> TcM [LHsRecUpdField TcId] - -tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds - where - flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ conLikeFieldLabels con_like) arg_tys - - do_bind :: LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name) -> TcM (Maybe (LHsRecUpdField TcId)) - do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af - , hsRecFieldArg = rhs })) - = do { let lbl = rdrNameAmbiguousFieldOcc af - sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (L loc lbl) (idName sel_id)) - ; mb <- tcRecordField con_like flds_w_tys f rhs - ; case mb of - Nothing -> return Nothing - Just (f', rhs') -> - return (Just - (L l (fld { hsRecFieldLbl - = L loc (Unambiguous (L loc lbl) - (selectorFieldOcc (unLoc f'))) - , hsRecFieldArg = rhs' }))) } - -tcRecordField :: ConLike -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name - -> TcM (Maybe (LFieldOcc Id, LHsExpr Id)) -tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs - | Just field_ty <- assocMaybe flds_w_tys field_lbl - = addErrCtxt (fieldCtxt field_lbl) $ - do { rhs' <- tcPolyExprNC rhs field_ty - ; let field_id = mkUserLocal (nameOccName sel_name) - (nameUnique sel_name) - field_ty loc - -- Yuk: the field_id has the *unique* of the selector Id - -- (so we can find it easily) - -- but is a LocalId with the appropriate type of the RHS - -- (so the desugarer knows the type of local binder to make) - ; return (Just (L loc (FieldOcc lbl field_id), rhs')) } - | otherwise - = do { addErrTc (badFieldCon con_like field_lbl) - ; return Nothing } - where - field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) - - -checkMissingFields :: ConLike -> HsRecordBinds Name -> TcM () -checkMissingFields con_like rbinds - | null field_labels -- Not declared as a record; - -- But C{} is still valid if no strict fields - = if any isBanged field_strs then - -- Illegal if any arg is strict - addErrTc (missingStrictFields con_like []) - else - return () - - | otherwise = do -- A record - unless (null missing_s_fields) - (addErrTc (missingStrictFields con_like missing_s_fields)) - - warn <- woptM Opt_WarnMissingFields - unless (not (warn && notNull missing_ns_fields)) - (warnTc (Reason Opt_WarnMissingFields) True - (missingFields con_like missing_ns_fields)) - - where - missing_s_fields - = [ flLabel fl | (fl, str) <- field_info, - isBanged str, - not (fl `elemField` field_names_used) - ] - missing_ns_fields - = [ flLabel fl | (fl, str) <- field_info, - not (isBanged str), - not (fl `elemField` field_names_used) - ] - - field_names_used = hsRecFields rbinds - field_labels = conLikeFieldLabels con_like - - field_info = zipEqual "missingFields" - field_labels - field_strs - - field_strs = conLikeImplBangs con_like - - fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds - -{- -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -Boring and alphabetical: --} - -addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a -addExprErrCtxt expr = addErrCtxt (exprCtxt expr) - -exprCtxt :: LHsExpr Name -> SDoc -exprCtxt expr - = hang (text "In the expression:") 2 (ppr expr) - -fieldCtxt :: FieldLabelString -> SDoc -fieldCtxt field_name - = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") - -addFunResCtxt :: Bool -- There is at least one argument - -> HsExpr Name -> TcType -> ExpRhoType - -> TcM a -> TcM a --- When we have a mis-match in the return type of a function --- try to give a helpful message about too many/few arguments --- --- Used for naked variables too; but with has_args = False -addFunResCtxt has_args fun fun_res_ty env_ty - = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) - -- NB: use a landmark error context, so that an empty context - -- doesn't suppress some more useful context - where - mk_msg - = do { mb_env_ty <- readExpType_maybe env_ty - -- by the time the message is rendered, the ExpType - -- will be filled in (except if we're debugging) - ; fun_res' <- zonkTcType fun_res_ty - ; env' <- case mb_env_ty of - Just env_ty -> zonkTcType env_ty - Nothing -> - do { dumping <- doptM Opt_D_dump_tc_trace - ; MASSERT( dumping ) - ; newFlexiTyVarTy liftedTypeKind } - ; let (_, _, fun_tau) = tcSplitSigmaTy fun_res' - (_, _, env_tau) = tcSplitSigmaTy env' - (args_fun, res_fun) = tcSplitFunTys fun_tau - (args_env, res_env) = tcSplitFunTys env_tau - n_fun = length args_fun - n_env = length args_env - info | n_fun == n_env = Outputable.empty - | n_fun > n_env - , not_fun res_env - = text "Probable cause:" <+> quotes (ppr fun) - <+> text "is applied to too few arguments" - - | has_args - , not_fun res_fun - = text "Possible cause:" <+> quotes (ppr fun) - <+> text "is applied to too many arguments" - - | otherwise - = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args! - ; return info } - where - not_fun ty -- ty is definitely not an arrow type, - -- and cannot conceivably become one - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isAlgTyCon tc - Nothing -> False - -badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc -badFieldTypes prs - = hang (text "Record update for insufficiently polymorphic field" - <> plural prs <> colon) - 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) - -badFieldsUpd - :: [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -- Field names that don't belong to a single datacon - -> [ConLike] -- Data cons of the type which the first field name belongs to - -> SDoc -badFieldsUpd rbinds data_cons - = hang (text "No constructor has all these fields:") - 2 (pprQuotedList conflictingFields) - -- See Note [Finding the conflicting fields] - where - -- A (preferably small) set of fields such that no constructor contains - -- all of them. See Note [Finding the conflicting fields] - conflictingFields = case nonMembers of - -- nonMember belongs to a different type. - (nonMember, _) : _ -> [aMember, nonMember] - [] -> let - -- All of rbinds belong to one type. In this case, repeatedly add - -- a field to the set until no constructor contains the set. - - -- Each field, together with a list indicating which constructors - -- have all the fields so far. - growingSets :: [(FieldLabelString, [Bool])] - growingSets = scanl1 combine membership - combine (_, setMem) (field, fldMem) - = (field, zipWith (&&) setMem fldMem) - in - -- Fields that don't change the membership status of the set - -- are redundant and can be dropped. - map (fst . head) $ groupBy ((==) `on` snd) growingSets - - aMember = ASSERT( not (null members) ) fst (head members) - (members, nonMembers) = partition (or . snd) membership - - -- For each field, which constructors contain the field? - membership :: [(FieldLabelString, [Bool])] - membership = sortMembership $ - map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $ - map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds - - fieldLabelSets :: [Set.Set FieldLabelString] - fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons - - -- Sort in order of increasing number of True, so that a smaller - -- conflicting set can be found. - sortMembership = - map snd . - sortBy (compare `on` fst) . - map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) - - countTrue = count id - -{- -Note [Finding the conflicting fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - data A = A {a0, a1 :: Int} - | B {b0, b1 :: Int} -and we see a record update - x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } -Then we'd like to find the smallest subset of fields that no -constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. -We don't really want to report that no constructor has all of -{a0,a1,b0,b1}, because when there are hundreds of fields it's -hard to see what was really wrong. - -We may need more than two fields, though; eg - data T = A { x,y :: Int, v::Int } - | B { y,z :: Int, v::Int } - | C { z,x :: Int, v::Int } -with update - r { x=e1, y=e2, z=e3 }, we - -Finding the smallest subset is hard, so the code here makes -a decent stab, no more. See Trac #7989. --} - -naughtyRecordSel :: RdrName -> SDoc -naughtyRecordSel sel_id - = text "Cannot use record selector" <+> quotes (ppr sel_id) <+> - text "as a function due to escaped type variables" $$ - text "Probable fix: use pattern-matching syntax instead" - -notSelector :: Name -> SDoc -notSelector field - = hsep [quotes (ppr field), text "is not a record selector"] - -mixedSelectors :: [Id] -> [Id] -> SDoc -mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = ptext - (sLit "Cannot use a mixture of pattern synonym and record selectors") $$ - text "Record selectors defined by" - <+> quotes (ppr (tyConName rep_dc)) - <> text ":" - <+> pprWithCommas ppr data_sels $$ - text "Pattern synonym selectors defined by" - <+> quotes (ppr (patSynName rep_ps)) - <> text ":" - <+> pprWithCommas ppr pat_syn_sels - where - RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id - RecSelData rep_dc = recordSelectorTyCon dc_rep_id -mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists" - - -missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc -missingStrictFields con fields - = header <> rest - where - rest | null fields = Outputable.empty -- Happens for non-record constructors - -- with strict fields - | otherwise = colon <+> pprWithCommas ppr fields - - header = text "Constructor" <+> quotes (ppr con) <+> - text "does not have the required strict field(s)" - -missingFields :: ConLike -> [FieldLabelString] -> SDoc -missingFields con fields - = text "Fields of" <+> quotes (ppr con) <+> ptext (sLit "not initialised:") - <+> pprWithCommas ppr fields - --- callCtxt fun args = text "In the call" <+> parens (ppr (foldl mkHsApp fun args)) - -noPossibleParents :: [LHsRecUpdField Name] -> SDoc -noPossibleParents rbinds - = hang (text "No type has all these fields:") - 2 (pprQuotedList fields) - where - fields = map (hsRecFieldLbl . unLoc) rbinds - -badOverloadedUpdate :: SDoc -badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" - -fieldNotInType :: RecSelParent -> RdrName -> SDoc -fieldNotInType p rdr - = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr - -{- -************************************************************************ -* * -\subsection{Static Pointers} -* * -************************************************************************ --} - --- | A data type to describe why a variable is not closed. -data NotClosedReason = NotLetBoundReason - | NotTypeClosed VarSet - | NotClosed Name NotClosedReason - --- | Checks if the given name is closed and emits an error if not. --- --- See Note [Not-closed error messages]. -checkClosedInStaticForm :: Name -> TcM () -checkClosedInStaticForm name = do - type_env <- getLclTypeEnv - case checkClosed type_env name of - Nothing -> return () - Just reason -> addErrTc $ explain name reason - where - -- See Note [Checking closedness]. - checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason - checkClosed type_env n = checkLoop type_env (unitNameSet n) n - - checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason - checkLoop type_env visited n = do - -- The @visited@ set is an accumulating parameter that contains the set of - -- visited nodes, so we avoid repeating cycles in the traversal. - case lookupNameEnv type_env n of - Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of - ClosedLet -> Nothing - NotLetBound -> Just NotLetBoundReason - NonClosedLet fvs type_closed -> listToMaybe $ - -- Look for a non-closed variable in fvs - [ NotClosed n' reason - | n' <- nameSetElemsStable fvs - , not (elemNameSet n' visited) - , Just reason <- [checkLoop type_env (extendNameSet visited n') n'] - ] ++ - if type_closed then - [] - else - -- We consider non-let-bound variables easier to figure out than - -- non-closed types, so we report non-closed types to the user - -- only if we cannot spot the former. - [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ] - -- The binding is closed. - _ -> Nothing - - -- Converts a reason into a human-readable sentence. - -- - -- @explain name reason@ starts with - -- - -- " is used in a static form but it is not closed because it" - -- - -- and then follows a list of causes. For each id in the path, the text - -- - -- "uses which" - -- - -- is appended, yielding something like - -- - -- "uses which uses which uses which" - -- - -- until the end of the path is reached, which is reported as either - -- - -- "is not let-bound" - -- - -- when the final node is not let-bound, or - -- - -- "has a non-closed type because it contains the type variables: - -- v1, v2, v3" - -- - -- when the final node has a non-closed type. - -- - explain :: Name -> NotClosedReason -> SDoc - explain name reason = - quotes (ppr name) <+> text "is used in a static form but it is not closed" - <+> text "because it" - $$ - sep (causes reason) - - causes :: NotClosedReason -> [SDoc] - causes NotLetBoundReason = [text "is not let-bound."] - causes (NotTypeClosed vs) = - [ text "has a non-closed type because it contains the" - , text "type variables:" <+> - pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) - ] - causes (NotClosed n reason) = - let msg = text "uses" <+> quotes (ppr n) <+> text "which" - in case reason of - NotClosed _ _ -> msg : causes reason - _ -> let (xs0, xs1) = splitAt 1 $ causes reason - in fmap (msg <+>) xs0 ++ xs1 - --- Note [Not-closed error messages] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- When variables in a static form are not closed, we go through the trouble --- of explaining why they aren't. --- --- Thus, the following program --- --- > {-# LANGUAGE StaticPointers #-} --- > module M where --- > --- > f x = static g --- > where --- > g = h --- > h = x --- --- produces the error --- --- 'g' is used in a static form but it is not closed because it --- uses 'h' which uses 'x' which is not let-bound. --- --- And a program like --- --- > {-# LANGUAGE StaticPointers #-} --- > module M where --- > --- > import Data.Typeable --- > import GHC.StaticPtr --- > --- > f :: Typeable a => a -> StaticPtr TypeRep --- > f x = const (static (g undefined)) (h x) --- > where --- > g = h --- > h = typeOf --- --- produces the error --- --- 'g' is used in a static form but it is not closed because it --- uses 'h' which has a non-closed type because it contains the --- type variables: 'a' --- - --- Note [Checking closedness] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- @checkClosed@ checks if a binding is closed and returns a reason if it is --- not. --- --- The bindings define a graph where the nodes are ids, and there is an edge --- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free --- variables. --- --- When @n@ is not closed, it has to exist in the graph some node reachable --- from @n@ that it is not a let-bound variable or that it has a non-closed --- type. Thus, the "reason" is a path from @n@ to this offending node. --- --- When @n@ is not closed, we traverse the graph reachable from @n@ to build --- the reason. --- diff --git a/typecheck/TcExpr.hs-boot b/typecheck/TcExpr.hs-boot deleted file mode 100644 --- a/typecheck/TcExpr.hs-boot +++ /dev/null @@ -1,40 +0,0 @@ -module TcExpr where -import HsSyn ( HsExpr, LHsExpr, SyntaxExpr ) -import Name ( Name ) -import TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) -import TcRnTypes( TcM, TcId, CtOrigin ) - -tcPolyExpr :: - LHsExpr Name - -> TcSigmaType - -> TcM (LHsExpr TcId) - -tcMonoExpr, tcMonoExprNC :: - LHsExpr Name - -> ExpRhoType - -> TcM (LHsExpr TcId) - -tcInferSigma, tcInferSigmaNC :: - LHsExpr Name - -> TcM (LHsExpr TcId, TcSigmaType) - -tcInferRho :: - LHsExpr Name - -> TcM (LHsExpr TcId, TcRhoType) - -tcSyntaxOp :: CtOrigin - -> SyntaxExpr Name - -> [SyntaxOpType] -- ^ shape of syntax operator arguments - -> ExpType -- ^ overall result type - -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExpr TcId) - -tcSyntaxOpGen :: CtOrigin - -> SyntaxExpr Name - -> [SyntaxOpType] - -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExpr TcId) - - -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId) diff --git a/typecheck/TcFlatten.hs b/typecheck/TcFlatten.hs deleted file mode 100644 --- a/typecheck/TcFlatten.hs +++ /dev/null @@ -1,1647 +0,0 @@ -{-# LANGUAGE CPP, ViewPatterns #-} - -module TcFlatten( - FlattenMode(..), - flatten, flattenManyNom, - - unflatten, - ) where - -#include "HsVersions.h" - -import TcRnTypes -import TcType -import Type -import TcUnify( occCheckExpand ) -import TcEvidence -import TyCon -import TyCoRep -- performs delicate algorithm on types -import Coercion -import Var -import VarEnv -import Outputable -import TcSMonad as TcS -import BasicTypes( SwapFlag(..) ) - -import Util -import Bag -import Pair -import Control.Monad -import MonadUtils ( zipWithAndUnzipM ) -import GHC.Exts ( inline ) - -import Control.Arrow ( first ) - -{- -Note [The flattening story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* A CFunEqCan is either of form - [G] : F xis ~ fsk -- fsk is a FlatSkol - [W] x : F xis ~ fmv -- fmv is a unification variable, - -- but untouchable, - -- with MetaInfo = FlatMetaTv - where - x is the witness variable - fsk/fmv is a flatten skolem - xis are function-free - CFunEqCans are always [Wanted], or [Given], never [Derived] - - fmv untouchable just means that in a CTyVarEq, say, - fmv ~ Int - we do NOT unify fmv. - -* KEY INSIGHTS: - - - A given flatten-skolem, fsk, is known a-priori to be equal to - F xis (the LHS), with evidence - - - A unification flatten-skolem, fmv, stands for the as-yet-unknown - type to which (F xis) will eventually reduce - -* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2 - then xis1 /= xis2 - i.e. at most one CFunEqCan with a particular LHS - -* Each canonical [G], [W], or [WD] CFunEqCan x : F xis ~ fsk/fmv - has its own distinct evidence variable x and flatten-skolem fsk/fmv. - Why? We make a fresh fsk/fmv when the constraint is born; - and we never rewrite the RHS of a CFunEqCan. - - In contrast a [D] CFunEqCan shares its fmv with its partner [W], - but does not "own" it. If we reduce a [D] F Int ~ fmv, where - say type instance F Int = ty, then we don't discharge fmv := ty. - Rather we simply generate [D] fmv ~ ty - -* Function applications can occur in the RHS of a CTyEqCan. No reason - not allow this, and it reduces the amount of flattening that must occur. - -* Flattening a type (F xis): - - If we are flattening in a Wanted/Derived constraint - then create new [W] x : F xis ~ fmv - else create new [G] x : F xis ~ fsk - with fresh evidence variable x and flatten-skolem fsk/fmv - - - Add it to the work list - - - Replace (F xis) with fsk/fmv in the type you are flattening - - - You can also add the CFunEqCan to the "flat cache", which - simply keeps track of all the function applications you - have flattened. - - - If (F xis) is in the cache already, just - use its fsk/fmv and evidence x, and emit nothing. - - - No need to substitute in the flat-cache. It's not the end - of the world if we start with, say (F alpha ~ fmv1) and - (F Int ~ fmv2) and then find alpha := Int. Athat will - simply give rise to fmv1 := fmv2 via [Interacting rule] below - -* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv - - Flatten xis (to substitute any tyvars; there are already no functions) - cos :: xis ~ flat_xis - - New wanted x2 :: F flat_xis ~ fsk/fmv - - Add new wanted to flat cache - - Discharge x = F cos ; x2 - -* Unification flatten-skolems, fmv, ONLY get unified when either - a) The CFunEqCan takes a step, using an axiom - b) During un-flattening - They are never unified in any other form of equality. - For example [W] ffmv ~ Int is stuck; it does not unify with fmv. - -* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan. - That would destroy the invariant about the shape of a CFunEqCan, - and it would risk wanted/wanted interactions. The only way we - learn information about fsk is when the CFunEqCan takes a step. - - However we *do* substitute in the LHS of a CFunEqCan (else it - would never get to fire!) - -* [Interacting rule] - (inert) [W] x1 : F tys ~ fmv1 - (work item) [W] x2 : F tys ~ fmv2 - Just solve one from the other: - x2 := x1 - fmv2 := fmv1 - This just unites the two fsks into one. - Always solve given from wanted if poss. - -* For top-level reductions, see Note [Top-level reductions for type functions] - in TcInteract - - -Why given-fsks, alone, doesn't work -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Could we get away with only flatten meta-tyvars, with no flatten-skolems? No. - - [W] w : alpha ~ [F alpha Int] - ----> flatten - w = ...w'... - [W] w' : alpha ~ [fsk] - [G] : F alpha Int ~ fsk - ---> unify (no occurs check) - alpha := [fsk] - -But since fsk = F alpha Int, this is really an occurs check error. If -that is all we know about alpha, we will succeed in constraint -solving, producing a program with an infinite type. - -Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk) -using axiom, zonking would not see it, so (x::alpha) sitting in the -tree will get zonked to an infinite type. (Zonking always only does -refl stuff.) - -Why flatten-meta-vars, alone doesn't work -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at Simple13, with unification-fmvs only - - [G] g : a ~ [F a] - ----> Flatten given - g' = g;[x] - [G] g' : a ~ [fmv] - [W] x : F a ~ fmv - ---> subst a in x - g' = g;[x] - x = F g' ; x2 - [W] x2 : F [fmv] ~ fmv - -And now we have an evidence cycle between g' and x! - -If we used a given instead (ie current story) - - [G] g : a ~ [F a] - ----> Flatten given - g' = g;[x] - [G] g' : a ~ [fsk] - [G] : F a ~ fsk - ----> Substitute for a - [G] g' : a ~ [fsk] - [G] F (sym g'); : F [fsk] ~ fsk - - -Why is it right to treat fmv's differently to ordinary unification vars? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - f :: forall a. a -> a -> Bool - g :: F Int -> F Int -> Bool - -Consider - f (x:Int) (y:Bool) -This gives alpha~Int, alpha~Bool. There is an inconsistency, -but really only one error. SherLoc may tell you which location -is most likely, based on other occurrences of alpha. - -Consider - g (x:Int) (y:Bool) -Here we get (F Int ~ Int, F Int ~ Bool), which flattens to - (fmv ~ Int, fmv ~ Bool) -But there are really TWO separate errors. - - ** We must not complain about Int~Bool. ** - -Moreover these two errors could arise in entirely unrelated parts of -the code. (In the alpha case, there must be *some* connection (eg -v:alpha in common envt).) - -Note [Unflattening can force the solver to iterate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at Trac #10340: - type family Any :: * -- No instances - get :: MonadState s m => m s - instance MonadState s (State s) where ... - - foo :: State Any Any - foo = get - -For 'foo' we instantiate 'get' at types mm ss - [WD] MonadState ss mm, [WD] mm ss ~ State Any Any -Flatten, and decompose - [WD] MonadState ss mm, [WD] Any ~ fmv - [WD] mm ~ State fmv, [WD] fmv ~ ss -Unify mm := State fmv: - [WD] MonadState ss (State fmv) - [WD] Any ~ fmv, [WD] fmv ~ ss -Now we are stuck; the instance does not match!! So unflatten: - fmv := Any - ss := Any (*) - [WD] MonadState Any (State Any) - -The unification (*) represents progress, so we must do a second -round of solving; this time it succeeds. This is done by the 'go' -loop in solveSimpleWanteds. - -This story does not feel right but it's the best I can do; and the -iteration only happens in pretty obscure circumstances. - - -************************************************************************ -* * -* Examples - Here is a long series of examples I had to work through -* * -************************************************************************ - -Simple20 -~~~~~~~~ -axiom F [a] = [F a] - - [G] F [a] ~ a ---> - [G] fsk ~ a - [G] [F a] ~ fsk (nc) ---> - [G] F a ~ fsk2 - [G] fsk ~ [fsk2] - [G] fsk ~ a ---> - [G] F a ~ fsk2 - [G] a ~ [fsk2] - [G] fsk ~ a - ----------------------------------------- -indexed-types/should_compile/T44984 - - [W] H (F Bool) ~ H alpha - [W] alpha ~ F Bool ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 - - fmv1 ~ fmv2 - fmv0 ~ alpha - -flatten -~~~~~~~ - fmv0 := F Bool - fmv1 := H (F Bool) - fmv2 := H alpha - alpha := F Bool -plus - fmv1 ~ fmv2 - -But these two are equal under the above assumptions. -Solve by Refl. - - ---- under plan B, namely solve fmv1:=fmv2 eagerly --- - [W] H (F Bool) ~ H alpha - [W] alpha ~ F Bool ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 - - fmv1 ~ fmv2 - fmv0 ~ alpha ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 fmv2 := fmv1 - - fmv0 ~ alpha - -flatten - fmv0 := F Bool - fmv1 := H fmv0 = H (F Bool) - retain H alpha ~ fmv2 - because fmv2 has been filled - alpha := F Bool - - ----------------------------- -indexed-types/should_failt/T4179 - -after solving - [W] fmv_1 ~ fmv_2 - [W] A3 (FCon x) ~ fmv_1 (CFunEqCan) - [W] A3 (x (aoa -> fmv_2)) ~ fmv_2 (CFunEqCan) - ----------------------------------------- -indexed-types/should_fail/T7729a - -a) [W] BasePrimMonad (Rand m) ~ m1 -b) [W] tt m1 ~ BasePrimMonad (Rand m) - ----> process (b) first - BasePrimMonad (Ramd m) ~ fmv_atH - fmv_atH ~ tt m1 - ----> now process (a) - m1 ~ s_atH ~ tt m1 -- An obscure occurs check - - ----------------------------------------- -typecheck/TcTypeNatSimple - -Original constraint - [W] x + y ~ x + alpha (non-canonical) -==> - [W] x + y ~ fmv1 (CFunEqCan) - [W] x + alpha ~ fmv2 (CFuneqCan) - [W] fmv1 ~ fmv2 (CTyEqCan) - -(sigh) - ----------------------------------------- -indexed-types/should_fail/GADTwrong1 - - [G] Const a ~ () -==> flatten - [G] fsk ~ () - work item: Const a ~ fsk -==> fire top rule - [G] fsk ~ () - work item fsk ~ () - -Surely the work item should rewrite to () ~ ()? Well, maybe not; -it'a very special case. More generally, our givens look like -F a ~ Int, where (F a) is not reducible. - - ----------------------------------------- -indexed_types/should_fail/T8227: - -Why using a different can-rewrite rule in CFunEqCan heads -does not work. - -Assuming NOT rewriting wanteds with wanteds - - Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk - [W] fmv_aBk ~ fsk_aBh - - [G] Scalar fsk_aBg ~ fsk_aBh - [G] V a ~ f_aBg - - Worklist includes [W] Scalar fmv_aBi ~ fmv_aBk - fmv_aBi, fmv_aBk are flatten unification variables - - Work item: [W] V fsk_aBh ~ fmv_aBi - -Note that the inert wanteds are cyclic, because we do not rewrite -wanteds with wanteds. - - -Then we go into a loop when normalise the work-item, because we -use rewriteOrSame on the argument of V. - -Conclusion: Don't make canRewrite context specific; instead use -[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable. - - ----------------------------------------- - -Here is a somewhat similar case: - - type family G a :: * - - blah :: (G a ~ Bool, Eq (G a)) => a -> a - blah = error "urk" - - foo x = blah x - -For foo we get - [W] Eq (G a), G a ~ Bool -Flattening - [W] G a ~ fmv, Eq fmv, fmv ~ Bool -We can't simplify away the Eq Bool unless we substitute for fmv. -Maybe that doesn't matter: we would still be left with unsolved -G a ~ Bool. - --------------------------- -Trac #9318 has a very simple program leading to - - [W] F Int ~ Int - [W] F Int ~ Bool - -We don't want to get "Error Int~Bool". But if fmv's can rewrite -wanteds, we will - - [W] fmv ~ Int - [W] fmv ~ Bool ----> - [W] Int ~ Bool - - -************************************************************************ -* * -* FlattenEnv & FlatM -* The flattening environment & monad -* * -************************************************************************ - --} - -type FlatWorkListRef = TcRef [Ct] -- See Note [The flattening work list] - -data FlattenEnv - = FE { fe_mode :: FlattenMode - , fe_loc :: CtLoc -- See Note [Flattener CtLoc] - , fe_flavour :: CtFlavour - , fe_eq_rel :: EqRel -- See Note [Flattener EqRels] - , fe_work :: FlatWorkListRef } -- See Note [The flattening work list] - -data FlattenMode -- Postcondition for all three: inert wrt the type substitution - = FM_FlattenAll -- Postcondition: function-free - | FM_SubstOnly -- See Note [Flattening under a forall] - --- | FM_Avoid TcTyVar Bool -- See Note [Lazy flattening] --- -- Postcondition: --- -- * tyvar is only mentioned in result under a rigid path --- -- e.g. [a] is ok, but F a won't happen --- -- * If flat_top is True, top level is not a function application --- -- (but under type constructors is ok e.g. [F a]) - -instance Outputable FlattenMode where - ppr FM_FlattenAll = text "FM_FlattenAll" - ppr FM_SubstOnly = text "FM_SubstOnly" - -eqFlattenMode :: FlattenMode -> FlattenMode -> Bool -eqFlattenMode FM_FlattenAll FM_FlattenAll = True -eqFlattenMode FM_SubstOnly FM_SubstOnly = True --- FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2 -eqFlattenMode _ _ = False - -mkFlattenEnv :: FlattenMode -> CtEvidence -> FlatWorkListRef -> FlattenEnv -mkFlattenEnv fm ctev ref = FE { fe_mode = fm - , fe_loc = ctEvLoc ctev - , fe_flavour = ctEvFlavour ctev - , fe_eq_rel = ctEvEqRel ctev - , fe_work = ref } - --- | The 'FlatM' monad is a wrapper around 'TcS' with the following --- extra capabilities: (1) it offers access to a 'FlattenEnv'; --- and (2) it maintains the flattening worklist. --- See Note [The flattening work list]. -newtype FlatM a - = FlatM { runFlatM :: FlattenEnv -> TcS a } - -instance Monad FlatM where - m >>= k = FlatM $ \env -> - do { a <- runFlatM m env - ; runFlatM (k a) env } - -instance Functor FlatM where - fmap = liftM - -instance Applicative FlatM where - pure x = FlatM $ const (pure x) - (<*>) = ap - -liftTcS :: TcS a -> FlatM a -liftTcS thing_inside - = FlatM $ const thing_inside - -emitFlatWork :: Ct -> FlatM () --- See Note [The flattening work list] -emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :) - -runFlatten :: FlattenMode -> CtEvidence -> FlatM a -> TcS a --- Run thing_inside (which does flattening), and put all --- the work it generates onto the main work list --- See Note [The flattening work list] --- NB: The returned evidence is always the same as the original, but with --- perhaps a new CtLoc -runFlatten mode ev thing_inside - = do { flat_ref <- newTcRef [] - ; let fmode = mkFlattenEnv mode ev flat_ref - ; res <- runFlatM thing_inside fmode - ; new_flats <- readTcRef flat_ref - ; updWorkListTcS (add_flats new_flats) - ; return res } - where - add_flats new_flats wl - = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) } - - add_funeqs [] wl = wl - add_funeqs (f:fs) wl = add_funeqs fs (f:wl) - -- add_funeqs fs ws = reverse fs ++ ws - -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4] - -- = [f3,f2,f1,w1,w2,w3,w4] - -traceFlat :: String -> SDoc -> FlatM () -traceFlat herald doc = liftTcS $ traceTcS herald doc - -getFlatEnvField :: (FlattenEnv -> a) -> FlatM a -getFlatEnvField accessor - = FlatM $ \env -> return (accessor env) - -getEqRel :: FlatM EqRel -getEqRel = getFlatEnvField fe_eq_rel - -getRole :: FlatM Role -getRole = eqRelRole <$> getEqRel - -getFlavour :: FlatM CtFlavour -getFlavour = getFlatEnvField fe_flavour - -getFlavourRole :: FlatM CtFlavourRole -getFlavourRole - = do { flavour <- getFlavour - ; eq_rel <- getEqRel - ; return (flavour, eq_rel) } - -getMode :: FlatM FlattenMode -getMode = getFlatEnvField fe_mode - -getLoc :: FlatM CtLoc -getLoc = getFlatEnvField fe_loc - -checkStackDepth :: Type -> FlatM () -checkStackDepth ty - = do { loc <- getLoc - ; liftTcS $ checkReductionDepth loc ty } - --- | Change the 'EqRel' in a 'FlatM'. -setEqRel :: EqRel -> FlatM a -> FlatM a -setEqRel new_eq_rel thing_inside - = FlatM $ \env -> - if new_eq_rel == fe_eq_rel env - then runFlatM thing_inside env - else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel }) - --- | Change the 'FlattenMode' in a 'FlattenEnv'. -setMode :: FlattenMode -> FlatM a -> FlatM a -setMode new_mode thing_inside - = FlatM $ \env -> - if new_mode `eqFlattenMode` fe_mode env - then runFlatM thing_inside env - else runFlatM thing_inside (env { fe_mode = new_mode }) - --- | Use when flattening kinds/kind coercions. See --- Note [No derived kind equalities] in TcCanonical -flattenKinds :: FlatM a -> FlatM a -flattenKinds thing_inside - = FlatM $ \env -> - let kind_flav = case fe_flavour env of - Given -> Given - _ -> Wanted WDeriv - in - runFlatM thing_inside (env { fe_eq_rel = NomEq, fe_flavour = kind_flav }) - -bumpDepth :: FlatM a -> FlatM a -bumpDepth (FlatM thing_inside) - = FlatM $ \env -> do { let env' = env { fe_loc = bumpCtLocDepth (fe_loc env) } - ; thing_inside env' } - -{- -Note [The flattening work list] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The "flattening work list", held in the fe_work field of FlattenEnv, -is a list of CFunEqCans generated during flattening. The key idea -is this. Consider flattening (Eq (F (G Int) (H Bool)): - * The flattener recursively calls itself on sub-terms before building - the main term, so it will encounter the terms in order - G Int - H Bool - F (G Int) (H Bool) - flattening to sub-goals - w1: G Int ~ fuv0 - w2: H Bool ~ fuv1 - w3: F fuv0 fuv1 ~ fuv2 - - * Processing w3 first is BAD, because we can't reduce i t,so it'll - get put into the inert set, and later kicked out when w1, w2 are - solved. In Trac #9872 this led to inert sets containing hundreds - of suspended calls. - - * So we want to process w1, w2 first. - - * So you might think that we should just use a FIFO deque for the work-list, - so that putting adding goals in order w1,w2,w3 would mean we processed - w1 first. - - * BUT suppose we have 'type instance G Int = H Char'. Then processing - w1 leads to a new goal - w4: H Char ~ fuv0 - We do NOT want to put that on the far end of a deque! Instead we want - to put it at the *front* of the work-list so that we continue to work - on it. - -So the work-list structure is this: - - * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on - top (extendWorkListFunEq), and take new work from the top - (selectWorkItem). - - * When flattening, emitFlatWork pushes new flattening goals (like - w1,w2,w3) onto the flattening work list, fe_work, another - push-down stack. - - * When we finish flattening, we *reverse* the fe_work stack - onto the wl_funeqs stack (which brings w1 to the top). - -The function runFlatten initialises the fe_work stack, and reverses -it onto wl_fun_eqs at the end. - -Note [Flattener EqRels] -~~~~~~~~~~~~~~~~~~~~~~~ -When flattening, we need to know which equality relation -- nominal -or representation -- we should be respecting. The only difference is -that we rewrite variables by representational equalities when fe_eq_rel -is ReprEq, and that we unwrap newtypes when flattening w.r.t. -representational equality. - -Note [Flattener CtLoc] -~~~~~~~~~~~~~~~~~~~~~~ -The flattener does eager type-family reduction. -Type families might loop, and we -don't want GHC to do so. A natural solution is to have a bounded depth -to these processes. A central difficulty is that such a solution isn't -quite compositional. For example, say it takes F Int 10 steps to get to Bool. -How many steps does it take to get from F Int -> F Int to Bool -> Bool? -10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to -know and hard to track. So, we punt, essentially. We store a CtLoc in -the FlattenEnv and just update the environment when recurring. In the -TyConApp case, where there may be multiple type families to flatten, -we just copy the current CtLoc into each branch. If any branch hits the -stack limit, then the whole thing fails. - -A consequence of this is that setting the stack limits appropriately -will be essentially impossible. So, the official recommendation if a -stack limit is hit is to disable the check entirely. Otherwise, there -will be baffling, unpredictable errors. - -Note [Lazy flattening] -~~~~~~~~~~~~~~~~~~~~~~ -The idea of FM_Avoid mode is to flatten less aggressively. If we have - a ~ [F Int] -there seems to be no great merit in lifting out (F Int). But if it was - a ~ [G a Int] -then we *do* want to lift it out, in case (G a Int) reduces to Bool, say, -which gets rid of the occurs-check problem. (For the flat_top Bool, see -comments above and at call sites.) - -HOWEVER, the lazy flattening actually seems to make type inference go -*slower*, not faster. perf/compiler/T3064 is a case in point; it gets -*dramatically* worse with FM_Avoid. I think it may be because -floating the types out means we normalise them, and that often makes -them smaller and perhaps allows more re-use of previously solved -goals. But to be honest I'm not absolutely certain, so I am leaving -FM_Avoid in the code base. What I'm removing is the unique place -where it is *used*, namely in TcCanonical.canEqTyVar. - -See also Note [Conservative unification check] in TcUnify, which gives -other examples where lazy flattening caused problems. - -Bottom line: FM_Avoid is unused for now (Nov 14). -Note: T5321Fun got faster when I disabled FM_Avoid - T5837 did too, but it's pathalogical anyway - -Note [Phantoms in the flattener] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - -data Proxy p = Proxy - -and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty` -is really irrelevant -- it will be ignored when solving for representational -equality later on. So, we omit flattening `ty` entirely. This may -violate the expectation of "xi"s for a bit, but the canonicaliser will -soon throw out the phantoms when decomposing a TyConApp. (Or, the -canonicaliser will emit an insoluble, in which case the unflattened version -yields a better error message anyway.) - --} - -{- ********************************************************************* -* * -* Externally callable flattening functions * -* * -* They are all wrapped in runFlatten, so their * -* flattening work gets put into the work list * -* * -********************************************************************* -} - -flatten :: FlattenMode -> CtEvidence -> TcType - -> TcS (Xi, TcCoercion) -flatten mode ev ty - = do { traceTcS "flatten {" (ppr mode <+> ppr ty) - ; (ty', co) <- runFlatten mode ev (flatten_one ty) - ; traceTcS "flatten }" (ppr ty') - ; return (ty', co) } - -flattenManyNom :: CtEvidence -> [TcType] -> TcS ([Xi], [TcCoercion]) --- Externally-callable, hence runFlatten --- Flatten a bunch of types all at once; in fact they are --- always the arguments of a saturated type-family, so --- ctEvFlavour ev = Nominal --- and we want to flatten all at nominal role -flattenManyNom ev tys - = do { traceTcS "flatten_many {" (vcat (map ppr tys)) - ; (tys', cos) <- runFlatten FM_FlattenAll ev (flatten_many_nom tys) - ; traceTcS "flatten }" (vcat (map ppr tys')) - ; return (tys', cos) } - - -{- ********************************************************************* -* * -* The main flattening functions -* * -********************************************************************* -} - -{- Note [Flattening] -~~~~~~~~~~~~~~~~~~~~ - flatten ty ==> (xi, co) - where - xi has no type functions, unless they appear under ForAlls - has no skolems that are mapped in the inert set - has no filled-in metavariables - co :: xi ~ ty - -Note that it is flatten's job to flatten *every type function it sees*. -flatten is only called on *arguments* to type functions, by canEqGiven. - -Flattening also: - * zonks, removing any metavariables, and - * applies the substitution embodied in the inert set - -Because flattening zonks and the returned coercion ("co" above) is also -zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead, -we can rely on these facts: - (F1) typeKind(xi) succeeds and returns a fully zonked kind - (F2) co :: xi ~ zonk(ty) -Note that the left-hand type of co is *always* precisely xi. The right-hand -type may or may not be ty, however: if ty has unzonked filled-in metavariables, -then the right-hand type of co will be the zonked version of ty. -It is for this reason that we -occasionally have to explicitly zonk, when (co :: xi ~ ty) is important -even before we zonk the whole program. For example, see the FTRNotFollowed -case in flattenTyVar. - -Why have these invariants on flattening? Really, they're both to ensure -invariant (F1), which is a Good Thing because we sometimes use typeKind -during canonicalisation, and we want this kind to be zonked (e.g., see -TcCanonical.homogeniseRhsKind). Invariant (F2) is needed solely to support -(F1). It is relied on in one place: - - - The FTRNotFollowed case in flattenTyVar. Here, we have a tyvar - that cannot be reduced any further (that is, no equality over the tyvar - is in the inert set such that the inert equality can rewrite the constraint - at hand, and it is not a filled-in metavariable). - But its kind might still not be flat, - if it mentions a type family or a variable that can be rewritten. Flattened - types have flattened kinds (see below), so we must flatten the kind. Here is - an example: - - let kappa be a filled-in metavariable such that kappa := k. - [G] co :: k ~ Type - - We are flattening - a :: kappa - where a is a skolem. - - We end up in the FTRNotFollowed case, but we need to flatten the kind kappa. - Flattening kappa yields (Type, kind_co), where kind_co :: Type ~ k. Note that the - right-hand type of kind_co is *not* kappa, because (F1) tells us it's zonk(kappa), - which is k. Now, we return (a |> sym kind_co). If we are to uphold (F1), then - the right-hand type of (sym kind_co) had better be fully zonked. In other words, - the left-hand type of kind_co needs to be zonked... which is precisely what (F2) - guarantees. - -In order to support (F2), we require that ctEvCoercion, when called on a -zonked CtEvidence, always returns a zonked coercion. See Note [Given in -ctEvCoercion]. This requirement comes into play in flatten_tyvar2. (I suppose -we could move the logic from ctEvCoercion to flatten_tyvar2, but it's much -easier to do in ctEvCoercion.) - -Flattening a type also means flattening its kind. In the case of a type -variable whose kind mentions a type family, this might mean that the result -of flattening has a cast in it. - -Recall that in comments we use alpha[flat = ty] to represent a -flattening skolem variable alpha which has been generated to stand in -for ty. - ------ Example of flattening a constraint: ------ - flatten (List (F (G Int))) ==> (xi, cc) - where - xi = List alpha - cc = { G Int ~ beta[flat = G Int], - F beta ~ alpha[flat = F beta] } -Here - * alpha and beta are 'flattening skolem variables'. - * All the constraints in cc are 'given', and all their coercion terms - are the identity. - -NB: Flattening Skolems only occur in canonical constraints, which -are never zonked, so we don't need to worry about zonking doing -accidental unflattening. - -Note that we prefer to leave type synonyms unexpanded when possible, -so when the flattener encounters one, it first asks whether its -transitive expansion contains any type function applications. If so, -it expands the synonym and proceeds; if not, it simply returns the -unexpanded synonym. - -Note [flatten_many performance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In programs with lots of type-level evaluation, flatten_many becomes -part of a tight loop. For example, see test perf/compiler/T9872a, which -calls flatten_many a whopping 7,106,808 times. It is thus important -that flatten_many be efficient. - -Performance testing showed that the current implementation is indeed -efficient. It's critically important that zipWithAndUnzipM be -specialized to TcS, and it's also quite helpful to actually `inline` -it. On test T9872a, here are the allocation stats (Dec 16, 2014): - - * Unspecialized, uninlined: 8,472,613,440 bytes allocated in the heap - * Specialized, uninlined: 6,639,253,488 bytes allocated in the heap - * Specialized, inlined: 6,281,539,792 bytes allocated in the heap - -To improve performance even further, flatten_many_nom is split off -from flatten_many, as nominal equality is the common case. This would -be natural to write using mapAndUnzipM, but even inlined, that function -is not as performant as a hand-written loop. - - * mapAndUnzipM, inlined: 7,463,047,432 bytes allocated in the heap - * hand-written recursion: 5,848,602,848 bytes allocated in the heap - -If you make any change here, pay close attention to the T9872{a,b,c} tests -and T5321Fun. - -If we need to make this yet more performant, a possible way forward is to -duplicate the flattener code for the nominal case, and make that case -faster. This doesn't seem quite worth it, yet. --} - -flatten_many :: [Role] -> [Type] -> FlatM ([Xi], [Coercion]) --- Coercions :: Xi ~ Type, at roles given --- Returns True iff (no flattening happened) --- NB: The EvVar inside the 'fe_ev :: CtEvidence' is unused, --- we merely want (a) Given/Solved/Derived/Wanted info --- (b) the GivenLoc/WantedLoc for when we create new evidence -flatten_many roles tys --- See Note [flatten_many performance] - = inline zipWithAndUnzipM go roles tys - where - go Nominal ty = setEqRel NomEq $ flatten_one ty - go Representational ty = setEqRel ReprEq $ flatten_one ty - go Phantom ty = -- See Note [Phantoms in the flattener] - do { ty <- liftTcS $ zonkTcType ty - ; return ( ty, mkReflCo Phantom ty ) } - --- | Like 'flatten_many', but assumes that every role is nominal. -flatten_many_nom :: [Type] -> FlatM ([Xi], [Coercion]) -flatten_many_nom [] = return ([], []) --- See Note [flatten_many performance] -flatten_many_nom (ty:tys) - = do { (xi, co) <- flatten_one ty - ; (xis, cos) <- flatten_many_nom tys - ; return (xi:xis, co:cos) } ------------------- -flatten_one :: TcType -> FlatM (Xi, Coercion) --- Flatten a type to get rid of type function applications, returning --- the new type-function-free type, and a collection of new equality --- constraints. See Note [Flattening] for more detail. --- --- Postcondition: Coercion :: Xi ~ TcType --- The role on the result coercion matches the EqRel in the FlattenEnv - -flatten_one xi@(LitTy {}) - = do { role <- getRole - ; return (xi, mkReflCo role xi) } - -flatten_one (TyVarTy tv) - = flattenTyVar tv - -flatten_one (AppTy ty1 ty2) - = do { (xi1,co1) <- flatten_one ty1 - ; eq_rel <- getEqRel - ; case (eq_rel, nextRole xi1) of - (NomEq, _) -> flatten_rhs xi1 co1 NomEq - (ReprEq, Nominal) -> flatten_rhs xi1 co1 NomEq - (ReprEq, Representational) -> flatten_rhs xi1 co1 ReprEq - (ReprEq, Phantom) -> -- See Note [Phantoms in the flattener] - do { ty2 <- liftTcS $ zonkTcType ty2 - ; return ( mkAppTy xi1 ty2 - , mkAppCo co1 (mkNomReflCo ty2)) } } - where - flatten_rhs xi1 co1 eq_rel2 - = do { (xi2,co2) <- setEqRel eq_rel2 $ flatten_one ty2 - ; role1 <- getRole - ; let role2 = eqRelRole eq_rel2 - ; traceFlat "flatten/appty" - (ppr ty1 $$ ppr ty2 $$ ppr xi1 $$ - ppr xi2 $$ ppr role1 $$ ppr role2) - - ; return ( mkAppTy xi1 xi2 - , mkTransAppCo role1 co1 xi1 ty1 - role2 co2 xi2 ty2 - role1 ) } -- output should match fmode - -flatten_one (TyConApp tc tys) - -- Expand type synonyms that mention type families - -- on the RHS; see Note [Flattening synonyms] - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' - = do { mode <- getMode - ; case mode of - FM_FlattenAll | not (isFamFreeTyCon tc) - -> flatten_one expanded_ty - _ -> flatten_ty_con_app tc tys } - - -- Otherwise, it's a type function application, and we have to - -- flatten it away as well, and generate a new given equality constraint - -- between the application and a newly generated flattening skolem variable. - | isTypeFamilyTyCon tc - = flatten_fam_app tc tys - - -- For * a normal data type application - -- * data family application - -- we just recursively flatten the arguments. - | otherwise --- FM_Avoid stuff commented out; see Note [Lazy flattening] --- , let fmode' = case fmode of -- Switch off the flat_top bit in FM_Avoid --- FE { fe_mode = FM_Avoid tv _ } --- -> fmode { fe_mode = FM_Avoid tv False } --- _ -> fmode - = flatten_ty_con_app tc tys - -flatten_one (FunTy ty1 ty2) - = do { (xi1,co1) <- flatten_one ty1 - ; (xi2,co2) <- flatten_one ty2 - ; role <- getRole - ; return (mkFunTy xi1 xi2, mkFunCo role co1 co2) } - -flatten_one ty@(ForAllTy {}) --- TODO (RAE): This is inadequate, as it doesn't flatten the kind of --- the bound tyvar. Doing so will require carrying around a substitution --- and the usual substTyVarBndr-like silliness. Argh. - --- We allow for-alls when, but only when, no type function --- applications inside the forall involve the bound type variables. - = do { let (bndrs, rho) = splitForAllTyVarBndrs ty - tvs = binderVars bndrs - ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho - -- Substitute only under a forall - -- See Note [Flattening under a forall] - ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) } - -flatten_one (CastTy ty g) - = do { (xi, co) <- flatten_one ty - ; (g', _) <- flatten_co g - - ; return (mkCastTy xi g', castCoercionKind co g' g) } - -flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co - --- | "Flatten" a coercion. Really, just flatten the types that it coerces --- between and then use transitivity. See Note [Flattening coercions] -flatten_co :: Coercion -> FlatM (Coercion, Coercion) -flatten_co co - = do { co <- liftTcS $ zonkCo co -- see Note [Zonking when flattening a coercion] - ; let (Pair ty1 ty2, role) = coercionKindRole co - ; (co1, co2) <- flattenKinds $ - do { (_, co1) <- flatten_one ty1 - ; (_, co2) <- flatten_one ty2 - ; return (co1, co2) } - ; let co' = downgradeRole role Nominal co1 `mkTransCo` - co `mkTransCo` - mkSymCo (downgradeRole role Nominal co2) - -- kco :: (ty1' ~r ty2') ~N (ty1 ~r ty2) - kco = mkTyConAppCo Nominal (equalityTyCon role) - [ mkKindCo co1, mkKindCo co2, co1, co2 ] - ; traceFlat "flatten_co" (vcat [ ppr co, ppr co1, ppr co2, ppr co' ]) - ; env_role <- getRole - ; return (co', mkProofIrrelCo env_role kco co' co) } - -flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) -flatten_ty_con_app tc tys - = do { eq_rel <- getEqRel - ; let role = eqRelRole eq_rel - ; (xis, cos) <- case eq_rel of - NomEq -> flatten_many_nom tys - ReprEq -> flatten_many (tyConRolesRepresentational tc) tys - ; return (mkTyConApp tc xis, mkTyConAppCo role tc cos) } - -{- -Note [Flattening coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because a flattened type has a flattened kind, we also must "flatten" -coercions as we walk through a type. Otherwise, the "from" type of -the coercion might not match the (now flattened) kind of the type -that it's casting. flatten_co does the work, taking a coercion of -type (ty1 ~ ty2) and flattening it to have type (fty1 ~ fty2), -where flatten(ty1) = fty1 and flatten(ty2) = fty2. - -In other words: - - If r1 is a role - co :: s ~r1 t - flatten_co co = (fco, kco) - r2 is the role in the FlatM - - then - fco :: fs ~r1 ft - fs, ft are flattened types - kco :: fco ~r2 co - -The second return value of flatten_co is always a ProofIrrelCo. As -such, it doesn't contain any information the caller doesn't have and -might not be necessary in whatever comes next. - -Note that a flattened coercion might have unzonked metavariables or -type functions in it -- but its *kind* will not. Instead of just flattening -the kinds and using mkTransCo, we could actually flatten the coercion -structurally. But doing so seems harder than simply flattening the types. - -Note [Zonking when flattening a coercion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The first step in flatten_co (see Note [Flattening coercions]) is to -zonk the input. This is necessary because we want to ensure the following -invariants (c.f. the invariants (F1) and (F2) in Note [Flattening]) - If - (co', kco) <- flatten_co co - Then - (FC1) coercionKind(co') succeeds and produces a fully zonked pair of kinds - (FC2) kco :: co' ~ zonk(co) -We must zonk to ensure (1). This is because fco is built by using mkTransCo -to build up on the input co. But if the only action that happens during -flattening ty1 and ty2 is to zonk metavariables, the coercions returned -(co1 and co2) will be reflexive. The mkTransCo calls will drop the reflexive -coercions and co' will be the same as co -- with unzonked kinds. - -These invariants are necessary to uphold (F1) and (F2) in the CastTy and -CoercionTy cases. - -We zonk right at the beginning to avoid duplicating work when flattening the -ty1 and ty2. - -Note [Flattening synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Not expanding synonyms aggressively improves error messages, and -keeps types smaller. But we need to take care. - -Suppose - type T a = a -> a -and we want to flatten the type (T (F a)). Then we can safely flatten -the (F a) to a skolem, and return (T fsk). We don't need to expand the -synonym. This works because TcTyConAppCo can deal with synonyms -(unlike TyConAppCo), see Note [TcCoercions] in TcEvidence. - -But (Trac #8979) for - type T a = (F a, a) where F is a type function -we must expand the synonym in (say) T Int, to expose the type function -to the flattener. - - -Note [Flattening under a forall] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Under a forall, we - (a) MUST apply the inert substitution - (b) MUST NOT flatten type family applications -Hence FMSubstOnly. - -For (a) consider c ~ a, a ~ T (forall b. (b, [c])) -If we don't apply the c~a substitution to the second constraint -we won't see the occurs-check error. - -For (b) consider (a ~ forall b. F a b), we don't want to flatten -to (a ~ forall b.fsk, F a b ~ fsk) -because now the 'b' has escaped its scope. We'd have to flatten to - (a ~ forall b. fsk b, forall b. F a b ~ fsk b) -and we have not begun to think about how to make that work! - -************************************************************************ -* * - Flattening a type-family application -* * -************************************************************************ --} - -flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) - -- flatten_fam_app can be over-saturated - -- flatten_exact_fam_app is exactly saturated - -- flatten_exact_fam_app_fully lifts out the application to top level - -- Postcondition: Coercion :: Xi ~ F tys -flatten_fam_app tc tys -- Can be over-saturated - = ASSERT2( tyConArity tc <= length tys - , 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) <- flatten_exact_fam_app tc tys1 - -- co1 :: xi1 ~ F tys1 - - -- all Nominal roles b/c the tycon is oversaturated - ; (xis_rest, cos_rest) <- flatten_many (repeat Nominal) tys_rest - -- cos_res :: xis_rest ~ tys_rest - - ; return ( mkAppTys xi1 xis_rest -- NB mkAppTys: rhs_xi might not be a type variable - -- cf Trac #5655 - , mkAppCos co1 cos_rest - -- (rhs_xi :: F xis) ; (F cos :: F xis ~ F tys) - ) } - -flatten_exact_fam_app, flatten_exact_fam_app_fully :: - TyCon -> [TcType] -> FlatM (Xi, Coercion) - -flatten_exact_fam_app tc tys - = do { mode <- getMode - ; role <- getRole - ; case mode of - -- These roles are always going to be Nominal for now, - -- but not if #8177 is implemented - FM_SubstOnly -> do { let roles = tyConRolesX role tc - ; (xis, cos) <- flatten_many roles tys - ; return ( mkTyConApp tc xis - , mkTyConAppCo role tc cos ) } - - FM_FlattenAll -> flatten_exact_fam_app_fully tc tys } - --- FM_Avoid tv flat_top -> --- do { (xis, cos) <- flatten_many fmode roles tys --- ; if flat_top || tv `elemVarSet` tyCoVarsOfTypes xis --- then flatten_exact_fam_app_fully fmode tc tys --- else return ( mkTyConApp tc xis --- , mkTcTyConAppCo (feRole fmode) tc cos ) } - -flatten_exact_fam_app_fully tc tys - -- See Note [Reduce type family applications eagerly] - = try_to_reduce tc tys False id $ - do { -- First, flatten the arguments - ; (xis, cos) <- setEqRel NomEq $ - flatten_many_nom tys - ; eq_rel <- getEqRel - ; cur_flav <- getFlavour - ; let role = eqRelRole eq_rel - ret_co = mkTyConAppCo role tc cos - -- ret_co :: F xis ~ F tys - - -- Now, look in the cache - ; mb_ct <- liftTcS $ lookupFlatCache tc xis - ; case mb_ct of - Just (co, rhs_ty, flav) -- co :: F xis ~ fsk - -- flav is [G] or [WD] - -- See Note [Type family equations] in TcSMonad - | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav - -> -- Usable hit in the flat-cache - do { traceFlat "flatten/flat-cache hit" $ (ppr tc <+> ppr xis $$ ppr rhs_ty) - ; (fsk_xi, fsk_co) <- flatten_one rhs_ty - -- The fsk may already have been unified, so flatten it - -- fsk_co :: fsk_xi ~ fsk - ; return ( fsk_xi - , fsk_co `mkTransCo` - maybeSubCo eq_rel (mkSymCo co) `mkTransCo` - ret_co ) } - -- :: fsk_xi ~ F xis - - -- Try to reduce the family application right now - -- See Note [Reduce type family applications eagerly] - _ -> try_to_reduce tc xis True (`mkTransCo` ret_co) $ - do { loc <- getLoc - ; (ev, co, fsk) <- liftTcS $ newFlattenSkolem cur_flav loc tc xis - - -- The new constraint (F xis ~ fsk) is not necessarily inert - -- (e.g. the LHS may be a redex) so we must put it in the work list - ; let ct = CFunEqCan { cc_ev = ev - , cc_fun = tc - , cc_tyargs = xis - , cc_fsk = fsk } - ; emitFlatWork ct - - ; traceFlat "flatten/flat-cache miss" $ - (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev) - - -- NB: fsk's kind is already flattend because - -- the xis are flattened - ; return (mkTyVarTy fsk, maybeSubCo eq_rel (mkSymCo co) - `mkTransCo` ret_co ) } - } - - where - try_to_reduce :: TyCon -- F, family tycon - -> [Type] -- args, not necessarily flattened - -> Bool -- add to the flat cache? - -> ( Coercion -- :: xi ~ F args - -> Coercion ) -- what to return from outer function - -> FlatM (Xi, Coercion) -- continuation upon failure - -> FlatM (Xi, Coercion) - try_to_reduce tc tys cache update_co k - = do { checkStackDepth (mkTyConApp tc tys) - ; mb_match <- liftTcS $ matchFam tc tys - ; case mb_match of - Just (norm_co, norm_ty) - -> do { traceFlat "Eager T.F. reduction success" $ - vcat [ ppr tc, ppr tys, ppr norm_ty - , ppr norm_co <+> dcolon - <+> ppr (coercionKind norm_co) - , ppr cache] - ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty - ; eq_rel <- getEqRel - ; let co = maybeSubCo eq_rel norm_co - `mkTransCo` mkSymCo final_co - ; flavour <- getFlavour - -- NB: only extend cache with nominal equalities - ; when (cache && eq_rel == NomEq) $ - liftTcS $ - extendFlatCache tc tys ( co, xi, flavour ) - ; return ( xi, update_co $ mkSymCo co ) } - Nothing -> k } - -{- Note [Reduce type family applications eagerly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we come across a type-family application like (Append (Cons x Nil) t), -then, rather than flattening to a skolem etc, we may as well just reduce -it on the spot to (Cons x t). This saves a lot of intermediate steps. -Examples that are helped are tests T9872, and T5321Fun. - -Performance testing indicates that it's best to try this *twice*, once -before flattening arguments and once after flattening arguments. -Adding the extra reduction attempt before flattening arguments cut -the allocation amounts for the T9872{a,b,c} tests by half. - -An example of where the early reduction appears helpful: - - type family Last x where - Last '[x] = x - Last (h ': t) = Last t - - workitem: (x ~ Last '[1,2,3,4,5,6]) - -Flattening the argument never gets us anywhere, but trying to flatten -it at every step is quadratic in the length of the list. Reducing more -eagerly makes simplifying the right-hand type linear in its length. - -Testing also indicated that the early reduction should *not* use the -flat-cache, but that the later reduction *should*. (Although the -effect was not large.) Hence the Bool argument to try_to_reduce. To -me (SLPJ) this seems odd; I get that eager reduction usually succeeds; -and if don't use the cache for eager reduction, we will miss most of -the opportunities for using it at all. More exploration would be good -here. - -At the end, once we've got a flat rhs, we extend the flatten-cache to record -the result. Doing so can save lots of work when the same redex shows up more -than once. Note that we record the link from the redex all the way to its -*final* value, not just the single step reduction. Interestingly, using the -flat-cache for the first reduction resulted in an increase in allocations -of about 3% for the four T9872x tests. However, using the flat-cache in -the later reduction is a similar gain. I (Richard E) don't currently (Dec '14) -have any knowledge as to *why* these facts are true. - -************************************************************************ -* * - Flattening a type variable -* * -********************************************************************* -} - --- | The result of flattening a tyvar "one step". -data FlattenTvResult - = FTRNotFollowed - -- ^ The inert set doesn't make the tyvar equal to anything else - - | FTRFollowed TcType Coercion - -- ^ The tyvar flattens to a not-necessarily flat other type. - -- co :: new type ~r old type, where the role is determined by - -- the FlattenEnv - -flattenTyVar :: TyVar -> FlatM (Xi, Coercion) -flattenTyVar tv - = do { mb_yes <- flatten_tyvar1 tv - ; case mb_yes of - FTRFollowed ty1 co1 -- Recur - -> do { (ty2, co2) <- flatten_one ty1 - -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2) - ; return (ty2, co2 `mkTransCo` co1) } - - FTRNotFollowed -- Done - -> do { let orig_kind = tyVarKind tv - ; (_new_kind, kind_co) <- setMode FM_SubstOnly $ - flattenKinds $ - flatten_one orig_kind - ; let Pair _ zonked_kind = coercionKind kind_co - -- NB: kind_co :: _new_kind ~ zonked_kind - -- But zonked_kind is not necessarily the same as orig_kind - -- because that may have filled-in metavars. - -- Moreover the returned Xi type must be well-kinded - -- (e.g. in canEqTyVarTyVar we use getCastedTyVar_maybe) - -- If you remove it, then e.g. dependent/should_fail/T11407 panics - -- See also Note [Flattening] - -- An alternative would to use (zonkTcType orig_kind), - -- but some simple measurements suggest that's a little slower - ; let tv' = setTyVarKind tv zonked_kind - tv_ty' = mkTyVarTy tv' - ty' = tv_ty' `mkCastTy` mkSymCo kind_co - - ; role <- getRole - ; return (ty', mkReflCo role tv_ty' - `mkCoherenceLeftCo` mkSymCo kind_co) } } - -flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult --- "Flattening" a type variable means to apply the substitution to it --- Specifically, look up the tyvar in --- * the internal MetaTyVar box --- * the inerts --- See also the documentation for FlattenTvResult - -flatten_tyvar1 tv - | not (isTcTyVar tv) -- Happens when flatten under a (forall a. ty) - = return FTRNotFollowed - -- So ty contains references to the non-TcTyVar a - - | otherwise - = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv - ; role <- getRole - ; case mb_ty of - Just ty -> do { traceFlat "Following filled tyvar" (ppr tv <+> equals <+> ppr ty) - ; return (FTRFollowed ty (mkReflCo role ty)) } ; - Nothing -> do { traceFlat "Unfilled tyvar" (ppr tv) - ; fr <- getFlavourRole - ; flatten_tyvar2 tv fr } } - -flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult --- The tyvar is not a filled-in meta-tyvar --- Try in the inert equalities --- See Definition [Applying a generalised substitution] in TcSMonad --- See Note [Stability of flattening] in TcSMonad - -flatten_tyvar2 tv fr@(_, eq_rel) - = do { ieqs <- liftTcS $ getInertEqs - ; mode <- getMode - ; case lookupDVarEnv ieqs tv of - Just (ct:_) -- If the first doesn't work, - -- the subsequent ones won't either - | CTyEqCan { cc_ev = ctev, cc_tyvar = tv, cc_rhs = rhs_ty } <- ct - , let ct_fr = ctEvFlavourRole ctev - , ct_fr `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR - -> do { traceFlat "Following inert tyvar" (ppr mode <+> ppr tv <+> equals <+> ppr rhs_ty $$ ppr ctev) - ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev) - rewrite_co = case (ctEvEqRel ctev, eq_rel) of - (ReprEq, _rel) -> ASSERT( _rel == ReprEq ) - -- if this ASSERT fails, then - -- eqCanRewriteFR answered incorrectly - rewrite_co1 - (NomEq, NomEq) -> rewrite_co1 - (NomEq, ReprEq) -> mkSubCo rewrite_co1 - - ; return (FTRFollowed rhs_ty rewrite_co) } - -- NB: ct is Derived then fmode must be also, hence - -- we are not going to touch the returned coercion - -- so ctEvCoercion is fine. - - _other -> return FTRNotFollowed } - -{- -Note [An alternative story for the inert substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(This entire note is just background, left here in case we ever want - to return the the previous state of affairs) - -We used (GHC 7.8) to have this story for the inert substitution inert_eqs - - * 'a' is not in fvs(ty) - * They are *inert* in the weaker sense that there is no infinite chain of - (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc - -This means that flattening must be recursive, but it does allow - [G] a ~ [b] - [G] b ~ Maybe c - -This avoids "saturating" the Givens, which can save a modest amount of work. -It is easy to implement, in TcInteract.kick_out, by only kicking out an inert -only if (a) the work item can rewrite the inert AND - (b) the inert cannot rewrite the work item - -This is significantly harder to think about. It can save a LOT of work -in occurs-check cases, but we don't care about them much. Trac #5837 -is an example; all the constraints here are Givens - - [G] a ~ TF (a,Int) - --> - work TF (a,Int) ~ fsk - inert fsk ~ a - - ---> - work fsk ~ (TF a, TF Int) - inert fsk ~ a - - ---> - work a ~ (TF a, TF Int) - inert fsk ~ a - - ---> (attempting to flatten (TF a) so that it does not mention a - work TF a ~ fsk2 - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (substitute for a) - work TF (fsk2, TF Int) ~ fsk2 - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (top-level reduction, re-orient) - work fsk2 ~ (TF fsk2, TF Int) - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (attempt to flatten (TF fsk2) to get rid of fsk2 - work TF fsk2 ~ fsk3 - work fsk2 ~ (fsk3, TF Int) - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> - work TF fsk2 ~ fsk3 - inert fsk2 ~ (fsk3, TF Int) - inert a ~ ((fsk3, TF Int), TF Int) - inert fsk ~ ((fsk3, TF Int), TF Int) - -Because the incoming given rewrites all the inert givens, we get more and -more duplication in the inert set. But this really only happens in pathalogical -casee, so we don't care. - - -************************************************************************ -* * - Unflattening -* * -************************************************************************ - -An unflattening example: - [W] F a ~ alpha -flattens to - [W] F a ~ fmv (CFunEqCan) - [W] fmv ~ alpha (CTyEqCan) -We must solve both! --} - -unflatten :: Cts -> Cts -> TcS Cts -unflatten tv_eqs funeqs - = do { tclvl <- getTcLevel - - ; traceTcS "Unflattening" $ braces $ - vcat [ text "Funeqs =" <+> pprCts funeqs - , text "Tv eqs =" <+> pprCts tv_eqs ] - - -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check - -- Occurs check: consider [W] alpha ~ [F alpha] - -- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv] - -- ==> (unify) [W] F [fmv] ~ fmv - -- See Note [Unflatten using funeqs first] - ; funeqs <- foldrBagM unflatten_funeq emptyCts funeqs - ; traceTcS "Unflattening 1" $ braces (pprCts funeqs) - - -- Step 2: unify the tv_eqs, if possible - ; tv_eqs <- foldrBagM (unflatten_eq tclvl) emptyCts tv_eqs - ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs) - - -- Step 3: fill any remaining fmvs with fresh unification variables - ; funeqs <- mapBagM finalise_funeq funeqs - ; traceTcS "Unflattening 3" $ braces (pprCts funeqs) - - -- Step 4: remove any tv_eqs that look like ty ~ ty - ; tv_eqs <- foldrBagM finalise_eq emptyCts tv_eqs - - ; let all_flat = tv_eqs `andCts` funeqs - ; traceTcS "Unflattening done" $ braces (pprCts all_flat) - - -- Step 5: zonk the result - -- Motivation: makes them nice and ready for the next step - -- (see TcInteract.solveSimpleWanteds) - ; zonkSimples all_flat } - where - ---------------- - unflatten_funeq :: Ct -> Cts -> TcS Cts - unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis - , cc_fsk = fmv, cc_ev = ev }) rest - = do { -- fmv should be an un-filled flatten meta-tv; - -- we now fix its final value by filling it, being careful - -- to observe the occurs check. Zonking will eliminate it - -- altogether in due course - rhs' <- zonkTcType (mkTyConApp tc xis) - ; case occCheckExpand fmv rhs' of - Just rhs'' -- Normal case: fill the tyvar - -> do { setReflEvidence ev NomEq rhs'' - ; unflattenFmv fmv rhs'' - ; return rest } - - Nothing -> -- Occurs check - return (ct `consCts` rest) } - - unflatten_funeq other_ct _ - = pprPanic "unflatten_funeq" (ppr other_ct) - - ---------------- - finalise_funeq :: Ct -> TcS Ct - finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev }) - = do { demoteUnfilledFmv fmv - ; return (mkNonCanonical ev) } - finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct) - - ---------------- - unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts - unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv - , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest - | isFmvTyVar tv -- Previously these fmvs were untouchable, - -- but now they are touchable - -- NB: unlike unflattenFmv, filling a fmv here /does/ - -- bump the unification count; it is "improvement" - -- Note [Unflattening can force the solver to iterate] - = ASSERT2( tyVarKind tv `eqType` typeKind rhs, ppr ct ) - -- CTyEqCan invariant should ensure this is true - do { is_filled <- isFilledMetaTyVar tv - ; elim <- case is_filled of - False -> do { traceTcS "unflatten_eq 2" (ppr ct) - ; tryFill ev eq_rel tv rhs } - True -> do { traceTcS "unflatten_eq 2" (ppr ct) - ; try_fill_rhs ev eq_rel tclvl tv rhs } - ; if elim then return rest - else return (ct `consCts` rest) } - - | otherwise - = return (ct `consCts` rest) - - unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct) - - ---------------- - try_fill_rhs ev eq_rel tclvl lhs_tv rhs - -- Constraint is lhs_tv ~ rhs_tv, - -- and lhs_tv is filled, so try RHS - | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs - -- co :: kind(rhs_tv) ~ kind(lhs_tv) - , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv - && not (isSigTyVar rhs_tv)) - -- LHS is a filled fmv, and so is a type - -- family application, which a SigTv should - -- not unify with - = do { is_filled <- isFilledMetaTyVar rhs_tv - ; if is_filled then return False - else tryFill ev eq_rel rhs_tv - (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) } - - | otherwise - = return False - - ---------------- - finalise_eq :: Ct -> Cts -> TcS Cts - finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv - , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest - | isFmvTyVar tv - = do { ty1 <- zonkTcTyVar tv - ; rhs' <- zonkTcType rhs - ; if ty1 `tcEqType` rhs' - then do { setReflEvidence ev eq_rel rhs' - ; return rest } - else return (mkNonCanonical ev `consCts` rest) } - - | otherwise - = return (mkNonCanonical ev `consCts` rest) - - finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct) - -tryFill :: CtEvidence -> EqRel -> TcTyVar -> TcType -> TcS Bool --- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv --- If tv does not appear in 'rhs', it set tv := rhs, --- binds the evidence (which should be a CtWanted) to Refl --- and return True. Otherwise returns False -tryFill ev eq_rel tv rhs - = ASSERT2( not (isGiven ev), ppr ev ) - do { rhs' <- zonkTcType rhs - ; case tcGetTyVar_maybe rhs' of { - Just tv' | tv == tv' -> do { setReflEvidence ev eq_rel rhs - ; return True } ; - _other -> - do { case occCheckExpand tv rhs' of - Just rhs'' -- Normal case: fill the tyvar - -> do { setReflEvidence ev eq_rel rhs'' - ; unifyTyVar tv rhs'' - ; return True } - - Nothing -> -- Occurs check - return False } } } - -setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS () -setReflEvidence ev eq_rel rhs - = setEvBindIfWanted ev (EvCoercion refl_co) - where - refl_co = mkTcReflCo (eqRelRole eq_rel) rhs - -{- -Note [Unflatten using funeqs first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - [W] G a ~ Int - [W] F (G a) ~ G a - -do not want to end up with - [W] F Int ~ Int -because that might actually hold! Better to end up with the two above -unsolved constraints. The flat form will be - - G a ~ fmv1 (CFunEqCan) - F fmv1 ~ fmv2 (CFunEqCan) - fmv1 ~ Int (CTyEqCan) - fmv1 ~ fmv2 (CTyEqCan) - -Flatten using the fun-eqs first. --} diff --git a/typecheck/TcForeign.hs b/typecheck/TcForeign.hs deleted file mode 100644 --- a/typecheck/TcForeign.hs +++ /dev/null @@ -1,562 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1998 - -\section[TcForeign]{Typechecking \tr{foreign} declarations} - -A foreign declaration is used to either give an externally -implemented function a Haskell type (and calling interface) or -give a Haskell function an external calling interface. Either way, -the range of argument and result types these functions can accommodate -is restricted to what the outside world understands (read C), and this -module checks to see if a foreign declaration has got a legal type. --} - -{-# LANGUAGE CPP #-} - -module TcForeign - ( tcForeignImports - , tcForeignExports - - -- Low-level exports for hooks - , isForeignImport, isForeignExport - , tcFImport, tcFExport - , tcForeignImports' - , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes - , normaliseFfiType - , nonIOok, mustBeIO - , checkSafe, noCheckSafe - , tcForeignExports' - , tcCheckFEType - ) where - -#include "HsVersions.h" - -import HsSyn - -import TcRnMonad -import TcHsType -import TcExpr -import TcEnv - -import FamInst -import FamInstEnv -import Coercion -import Type -import ForeignCall -import ErrUtils -import Id -import Name -import RdrName -import DataCon -import TyCon -import TcType -import PrelNames -import DynFlags -import Outputable -import Platform -import SrcLoc -import Bag -import Hooks -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Maybe - --- Defines a binding -isForeignImport :: LForeignDecl name -> Bool -isForeignImport (L _ (ForeignImport {})) = True -isForeignImport _ = False - --- Exports a binding -isForeignExport :: LForeignDecl name -> Bool -isForeignExport (L _ (ForeignExport {})) = True -isForeignExport _ = False - -{- -Note [Don't recur in normaliseFfiType'] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -normaliseFfiType' is the workhorse for normalising a type used in a foreign -declaration. If we have - -newtype Age = MkAge Int - -we want to see that Age -> IO () is the same as Int -> IO (). But, we don't -need to recur on any type parameters, because no paramaterized types (with -interesting parameters) are marshalable! The full list of marshalable types -is in the body of boxedMarshalableTyCon in TcType. The only members of that -list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled -the same way regardless of type parameter. So, no need to recur into -parameters. - -Similarly, we don't need to look in AppTy's, because nothing headed by -an AppTy will be marshalable. - -Note [FFI type roles] -~~~~~~~~~~~~~~~~~~~~~ -The 'go' helper function within normaliseFfiType' always produces -representational coercions. But, in the "children_only" case, we need to -use these coercions in a TyConAppCo. Accordingly, the roles on the coercions -must be twiddled to match the expectation of the enclosing TyCon. However, -we cannot easily go from an R coercion to an N one, so we forbid N roles -on FFI type constructors. Currently, only two such type constructors exist: -IO and FunPtr. Thus, this is not an onerous burden. - -If we ever want to lift this restriction, we would need to make 'go' take -the target role as a parameter. This wouldn't be hard, but it's a complication -not yet necessary and so is not yet implemented. --} - --- normaliseFfiType takes the type from an FFI declaration, and --- evaluates any type synonyms, type functions, and newtypes. However, --- we are only allowed to look through newtypes if the constructor is --- in scope. We return a bag of all the newtype constructors thus found. --- Always returns a Representational coercion -normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt) -normaliseFfiType ty - = do fam_envs <- tcGetFamInstEnvs - normaliseFfiType' fam_envs ty - -normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) -normaliseFfiType' env ty0 = go initRecTc ty0 - where - go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) - go rec_nts ty - | Just ty' <- tcView ty -- Expand synonyms - = go rec_nts ty' - - | Just (tc, tys) <- splitTyConApp_maybe ty - = go_tc_app rec_nts tc tys - - | (bndrs, inner_ty) <- splitForAllTyVarBndrs ty - , not (null bndrs) - = do (coi, nty1, gres1) <- go rec_nts inner_ty - return ( mkHomoForAllCos (binderVars bndrs) coi - , mkForAllTys bndrs nty1, gres1 ) - - | otherwise -- see Note [Don't recur in normaliseFfiType'] - = return (mkRepReflCo ty, ty, emptyBag) - - go_tc_app :: RecTcChecker -> TyCon -> [Type] - -> TcM (Coercion, Type, Bag GlobalRdrElt) - go_tc_app rec_nts tc tys - -- We don't want to look through the IO newtype, even if it is - -- in scope, so we have a special case for it: - | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey] - -- These *must not* have nominal roles on their parameters! - -- See Note [FFI type roles] - = children_only - - | isNewTyCon tc -- Expand newtypes - , Just rec_nts' <- checkRecTc rec_nts tc - -- See Note [Expanding newtypes] in TyCon.hs - -- We can't just use isRecursiveTyCon; sometimes recursion is ok: - -- newtype T = T (Ptr T) - -- Here, we don't reject the type for being recursive. - -- If this is a recursive newtype then it will normally - -- be rejected later as not being a valid FFI type. - = do { rdr_env <- getGlobalRdrEnv - ; case checkNewtypeFFI rdr_env tc of - Nothing -> nothing - Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs - ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } } - - | isFamilyTyCon tc -- Expand open tycons - , (co, ty) <- normaliseTcApp env Representational tc tys - , not (isReflexiveCo co) - = do (co', ty', gres) <- go rec_nts ty - return (mkTransCo co co', ty', gres) - - | otherwise - = nothing -- see Note [Don't recur in normaliseFfiType'] - where - tc_key = getUnique tc - children_only - = do xs <- mapM (go rec_nts) tys - let (cos, tys', gres) = unzip3 xs - -- the (repeat Representational) is because 'go' always - -- returns R coercions - cos' = zipWith3 downgradeRole (tyConRoles tc) - (repeat Representational) cos - return ( mkTyConAppCo Representational tc cos' - , mkTyConApp tc tys', unionManyBags gres) - nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys [] - nt_rhs = newTyConInstRhs tc tys - - ty = mkTyConApp tc tys - nothing = return (mkRepReflCo ty, ty, emptyBag) - -checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt -checkNewtypeFFI rdr_env tc - | Just con <- tyConSingleDataCon_maybe tc - , Just gre <- lookupGRE_Name rdr_env (dataConName con) - = Just gre -- See Note [Newtype constructor usage in foreign declarations] - | otherwise - = Nothing - -{- -Note [Newtype constructor usage in foreign declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC automatically "unwraps" newtype constructors in foreign import/export -declarations. In effect that means that a newtype data constructor is -used even though it is not mentioned expclitly in the source, so we don't -want to report it as "defined but not used" or "imported but not used". -eg newtype D = MkD Int - foreign import foo :: D -> IO () -Here 'MkD' us used. See Trac #7408. - -GHC also expands type functions during this process, so it's not enough -just to look at the free variables of the declaration. -eg type instance F Bool = D - foreign import bar :: F Bool -> IO () -Here again 'MkD' is used. - -So we really have wait until the type checker to decide what is used. -That's why tcForeignImports and tecForeignExports return a (Bag GRE) -for the newtype constructors they see. Then TcRnDriver can add them -to the module's usages. - - -************************************************************************ -* * -\subsection{Imports} -* * -************************************************************************ --} - -tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt) -tcForeignImports decls - = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls) - -tcForeignImports' :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt) --- For the (Bag GlobalRdrElt) result, --- see Note [Newtype constructor usage in foreign declarations] -tcForeignImports' decls - = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $ - filter isForeignImport decls - ; return (ids, decls, unionManyBags gres) } - -tcFImport :: LForeignDecl Name -> TcM (Id, LForeignDecl Id, Bag GlobalRdrElt) -tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty - , fd_fi = imp_decl })) - = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ - do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty - ; let - -- Drop the foralls before inspecting the - -- structure of the foreign type. - (bndrs, res_ty) = tcSplitPiTys norm_sig_ty - arg_tys = mapMaybe binderRelevantType_maybe bndrs - id = mkLocalId nm sig_ty - -- Use a LocalId to obey the invariant that locally-defined - -- things are LocalIds. However, it does not need zonking, - -- (so TcHsSyn.zonkForeignExports ignores it). - - ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl - -- Can't use sig_ty here because sig_ty :: Type and - -- we need HsType Id hence the undefined - ; let fi_decl = ForeignImport { fd_name = L nloc id - , fd_sig_ty = undefined - , fd_co = mkSymCo norm_co - , fd_fi = imp_decl' } - ; return (id, L dloc fi_decl, gres) } -tcFImport d = pprPanic "tcFImport" (ppr d) - --- ------------ Checking types for foreign import ---------------------- - -tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport - -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src) - -- Foreign import label - = do checkCg checkCOrAsmOrLlvmOrInterp - -- NB check res_ty not sig_ty! - -- In case sig_ty is (forall a. ForeignPtr a) - check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) - cconv' <- checkCConv cconv - return (CImport (L lc cconv') safety mh l src) - -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do - -- Foreign wrapper (former f.e.d.) - -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid - -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. - -- The use of the latter form is DEPRECATED, though. - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - case arg_tys of - [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys - checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty - checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty - where - (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected")) - return (CImport (L lc cconv') safety mh CWrapper src) - -tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh - (CFunction target) src) - | isDynamicTarget target = do -- Foreign import dynamic - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - case arg_tys of -- The first arg must be Ptr or FunPtr - [] -> - addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected")) - (arg1_ty:arg_tys) -> do - dflags <- getDynFlags - let curried_res_ty = mkFunTys arg_tys res_ty - check (isFFIDynTy curried_res_ty arg1_ty) - (illegalForeignTyErr argument) - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src - | cconv == PrimCallConv = do - dflags <- getDynFlags - checkTc (xopt LangExt.GHCForeignImportPrim dflags) - (text "Use GHCForeignImportPrim to allow `foreign import prim'.") - checkCg checkCOrAsmOrLlvmOrInterp - checkCTarget target - checkTc (playSafe safety) - (text "The safe/unsafe annotation should not be used with `foreign import prim'.") - checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys - -- prim import result is more liberal, allows (#,,#) - checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty - return idecl - | otherwise = do -- Normal foreign import - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - checkCTarget target - dflags <- getDynFlags - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - checkMissingAmpersand dflags arg_tys res_ty - case target of - StaticTarget _ _ _ False - | not (null arg_tys) -> - addErrTc (text "`value' imports cannot have function types") - _ -> return () - return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src - - --- This makes a convenient place to check --- that the C identifier is valid for C -checkCTarget :: CCallTarget -> TcM () -checkCTarget (StaticTarget _ str _ _) = do - checkCg checkCOrAsmOrLlvmOrInterp - checkTc (isCLabelString str) (badCName str) - -checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" - - -checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () -checkMissingAmpersand dflags arg_tys res_ty - | null arg_tys && isFunPtrTy res_ty && - wopt Opt_WarnDodgyForeignImports dflags - = addWarn (Reason Opt_WarnDodgyForeignImports) - (text "possible missing & in foreign import of FunPtr") - | otherwise - = return () - -{- -************************************************************************ -* * -\subsection{Exports} -* * -************************************************************************ --} - -tcForeignExports :: [LForeignDecl Name] - -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt) -tcForeignExports decls = - getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls) - -tcForeignExports' :: [LForeignDecl Name] - -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt) --- For the (Bag GlobalRdrElt) result, --- see Note [Newtype constructor usage in foreign declarations] -tcForeignExports' decls - = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) - where - combine (binds, fs, gres1) (L loc fe) = do - (b, f, gres2) <- setSrcSpan loc (tcFExport fe) - return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) - -tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id, Bag GlobalRdrElt) -tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec }) - = addErrCtxt (foreignDeclCtxt fo) $ do - - sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - rhs <- tcPolyExpr (nlHsVar nm) sig_ty - - (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty - - spec' <- tcCheckFEType norm_sig_ty spec - - -- we're exporting a function, but at a type possibly more - -- constrained than its declared/inferred type. Hence the need - -- to create a local binding which will call the exported function - -- at a particular type (and, maybe, overloading). - - - -- We need to give a name to the new top-level binding that - -- is *stable* (i.e. the compiler won't change it later), - -- because this name will be referred to by the C code stub. - id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return ( mkVarBind id rhs - , ForeignExport { fd_name = L loc id - , fd_sig_ty = undefined - , fd_co = norm_co, fd_fe = spec' } - , gres) -tcFExport d = pprPanic "tcFExport" (ppr d) - --- ------------ Checking argument types for foreign export ---------------------- - -tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport -tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do - checkCg checkCOrAsmOrLlvm - checkTc (isCLabelString str) (badCName str) - cconv' <- checkCConv cconv - checkForeignArgs isFFIExternalTy arg_tys - checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty - return (CExport (L l (CExportStatic esrc str cconv')) src) - where - -- Drop the foralls before inspecting n - -- the structure of the foreign type. - (bndrs, res_ty) = tcSplitPiTys sig_ty - arg_tys = mapMaybe binderRelevantType_maybe bndrs - -{- -************************************************************************ -* * -\subsection{Miscellaneous} -* * -************************************************************************ --} - ------------- Checking argument types for foreign import ---------------------- -checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM () -checkForeignArgs pred tys = mapM_ go tys - where - go ty = check (pred ty) (illegalForeignTyErr argument) - ------------- Checking result types for foreign calls ---------------------- --- | Check that the type has the form --- (IO t) or (t) , and that t satisfies the given predicate. --- When calling this function, any newtype wrappers (should) have been --- already dealt with by normaliseFfiType. --- --- We also check that the Safe Haskell condition of FFI imports having --- results in the IO monad holds. --- -checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM () -checkForeignRes non_io_result_ok check_safe pred_res_ty ty - | Just (_, res_ty) <- tcSplitIOType_maybe ty - = -- Got an IO result type, that's always fine! - check (pred_res_ty res_ty) (illegalForeignTyErr result) - - -- Case for non-IO result type with FFI Import - | not non_io_result_ok - = addErrTc $ illegalForeignTyErr result (text "IO result type expected") - - | otherwise - = do { dflags <- getDynFlags - ; case pred_res_ty ty of - -- Handle normal typecheck fail, we want to handle this first and - -- only report safe haskell errors if the normal type check is OK. - NotValid msg -> addErrTc $ illegalForeignTyErr result msg - - -- handle safe infer fail - _ | check_safe && safeInferOn dflags - -> recordUnsafeInfer emptyBag - - -- handle safe language typecheck fail - _ | check_safe && safeLanguageOn dflags - -> addErrTc (illegalForeignTyErr result safeHsErr) - - -- success! non-IO return is fine - _ -> return () } - where - safeHsErr = - text "Safe Haskell is on, all FFI imports must be in the IO monad" - -nonIOok, mustBeIO :: Bool -nonIOok = True -mustBeIO = False - -checkSafe, noCheckSafe :: Bool -checkSafe = True -noCheckSafe = False - --- Checking a supported backend is in use - -checkCOrAsmOrLlvm :: HscTarget -> Validity -checkCOrAsmOrLlvm HscC = IsValid -checkCOrAsmOrLlvm HscAsm = IsValid -checkCOrAsmOrLlvm HscLlvm = IsValid -checkCOrAsmOrLlvm _ - = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") - -checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity -checkCOrAsmOrLlvmOrInterp HscC = IsValid -checkCOrAsmOrLlvmOrInterp HscAsm = IsValid -checkCOrAsmOrLlvmOrInterp HscLlvm = IsValid -checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid -checkCOrAsmOrLlvmOrInterp _ - = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") - -checkCg :: (HscTarget -> Validity) -> TcM () -checkCg check = do - dflags <- getDynFlags - let target = hscTarget dflags - case target of - HscNothing -> return () - _ -> - case check target of - IsValid -> return () - NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) - --- Calling conventions - -checkCConv :: CCallConv -> TcM CCallConv -checkCConv CCallConv = return CCallConv -checkCConv CApiConv = return CApiConv -checkCConv StdCallConv = do dflags <- getDynFlags - let platform = targetPlatform dflags - if platformArch platform == ArchX86 - then return StdCallConv - else do -- This is a warning, not an error. see #3336 - when (wopt Opt_WarnUnsupportedCallingConventions dflags) $ - addWarnTc (Reason Opt_WarnUnsupportedCallingConventions) - (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") - return CCallConv -checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") - return PrimCallConv -checkCConv JavaScriptCallConv = do dflags <- getDynFlags - if platformArch (targetPlatform dflags) == ArchJavaScript - then return JavaScriptCallConv - else do addErrTc (text "The `javascript' calling convention is unsupported on this platform") - return JavaScriptCallConv - --- Warnings - -check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () -check IsValid _ = return () -check (NotValid doc) err_fn = addErrTc (err_fn doc) - -illegalForeignTyErr :: SDoc -> SDoc -> SDoc -illegalForeignTyErr arg_or_res extra - = hang msg 2 extra - where - msg = hsep [ text "Unacceptable", arg_or_res - , text "type in foreign declaration:"] - --- Used for 'arg_or_res' argument to illegalForeignTyErr -argument, result :: SDoc -argument = text "argument" -result = text "result" - -badCName :: CLabelString -> MsgDoc -badCName target - = sep [quotes (ppr target) <+> text "is not a valid C identifier"] - -foreignDeclCtxt :: ForeignDecl Name -> SDoc -foreignDeclCtxt fo - = hang (text "When checking declaration:") - 2 (ppr fo) diff --git a/typecheck/TcGenDeriv.hs b/typecheck/TcGenDeriv.hs deleted file mode 100644 --- a/typecheck/TcGenDeriv.hs +++ /dev/null @@ -1,2155 +0,0 @@ -{- - % -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcGenDeriv: Generating derived instance declarations - -This module is nominally ``subordinate'' to @TcDeriv@, which is the -``official'' interface to deriving-related things. - -This is where we do all the grimy bindings' generation. --} - -{-# LANGUAGE CPP, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} - -module TcGenDeriv ( - BagDerivStuff, DerivStuff(..), - - gen_Eq_binds, - gen_Ord_binds, - gen_Enum_binds, - gen_Bounded_binds, - gen_Ix_binds, - gen_Show_binds, - gen_Read_binds, - gen_Data_binds, - gen_Lift_binds, - gen_Newtype_binds, - mkCoerceClassMethEqn, - genAuxBinds, - ordOpTbl, boxConTbl, litConTbl, - mkRdrFunBind, error_Expr - ) where - -#include "HsVersions.h" - -import TcRnMonad -import HsSyn -import RdrName -import BasicTypes -import DataCon -import Name -import Fingerprint -import Encoding - -import DynFlags -import PrelInfo -import FamInst -import FamInstEnv -import PrelNames -import THNames -import Module ( moduleName, moduleNameString - , moduleUnitId, unitIdString ) -import MkId ( coerceId ) -import PrimOp -import SrcLoc -import TyCon -import TcEnv -import TcType -import TcValidity ( checkValidTyFamEqn ) -import TysPrim -import TysWiredIn -import Type -import Class -import VarSet -import VarEnv -import Util -import Var -import Outputable -import Lexeme -import FastString -import Pair -import Bag - -import Data.List ( partition, intersperse ) - -type BagDerivStuff = Bag DerivStuff - -data AuxBindSpec - = DerivCon2Tag TyCon -- The con2Tag for given TyCon - | DerivTag2Con TyCon -- ...ditto tag2Con - | DerivMaxTag TyCon -- ...and maxTag - deriving( Eq ) - -- All these generate ZERO-BASED tag operations - -- I.e first constructor has tag 0 - -data DerivStuff -- Please add this auxiliary stuff - = DerivAuxBind AuxBindSpec - - -- Generics and DeriveAnyClass - | DerivFamInst FamInst -- New type family instances - - -- New top-level auxiliary bindings - | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB - - -{- -************************************************************************ -* * - Eq instances -* * -************************************************************************ - -Here are the heuristics for the code we generate for @Eq@. Let's -assume we have a data type with some (possibly zero) nullary data -constructors and some ordinary, non-nullary ones (the rest, also -possibly zero of them). Here's an example, with both \tr{N}ullary and -\tr{O}rdinary data cons. - - data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... - -* For the ordinary constructors (if any), we emit clauses to do The - Usual Thing, e.g.,: - - (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2 - (==) (O2 a1) (O2 a2) = a1 == a2 - (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 - - Note: if we're comparing unlifted things, e.g., if 'a1' and - 'a2' are Float#s, then we have to generate - case (a1 `eqFloat#` a2) of r -> r - for that particular test. - -* If there are a lot of (more than en) nullary constructors, we emit a - catch-all clause of the form: - - (==) a b = case (con2tag_Foo a) of { a# -> - case (con2tag_Foo b) of { b# -> - case (a# ==# b#) of { - r -> r }}} - - If con2tag gets inlined this leads to join point stuff, so - it's better to use regular pattern matching if there aren't too - many nullary constructors. "Ten" is arbitrary, of course - -* If there aren't any nullary constructors, we emit a simpler - catch-all: - - (==) a b = False - -* For the @(/=)@ method, we normally just use the default method. - If the type is an enumeration type, we could/may/should? generate - special code that calls @con2tag_Foo@, much like for @(==)@ shown - above. - -We thought about doing this: If we're also deriving 'Ord' for this -tycon, we generate: - instance ... Eq (Foo ...) where - (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False} - (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True } -However, that requires that (Ord ) was put in the context -for the instance decl, which it probably wasn't, so the decls -produced don't get through the typechecker. --} - -gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) -gen_Eq_binds loc tycon = do - dflags <- getDynFlags - return (method_binds dflags, aux_binds) - where - all_cons = tyConDataCons tycon - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons - - -- If there are ten or more (arbitrary number) nullary constructors, - -- use the con2tag stuff. For small types it's better to use - -- ordinary pattern matching. - (tag_match_cons, pat_match_cons) - | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons) - | otherwise = ([], all_cons) - - no_tag_match_cons = null tag_match_cons - - fall_through_eqn dflags - | no_tag_match_cons -- All constructors have arguments - = case pat_match_cons of - [] -> [] -- No constructors; no fall-though case - [_] -> [] -- One constructor; no fall-though case - _ -> -- Two or more constructors; add fall-through of - -- (==) _ _ = False - [([nlWildPat, nlWildPat], false_Expr)] - - | otherwise -- One or more tag_match cons; add fall-through of - -- extract tags compare for equality - = [([a_Pat, b_Pat], - untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] - - aux_binds | no_tag_match_cons = emptyBag - | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon - - method_binds dflags = listToBag - [ eq_bind dflags - , ne_bind - ] - eq_bind dflags = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons - ++ fall_through_eqn dflags) - ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] ( - nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) - - ------------------------------------------------------------------ - pats_etc data_con - = let - con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed - con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed - - data_con_RDR = getRdrName data_con - con_arity = length tys_needed - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - tys_needed = dataConOrigArgTys data_con - in - ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) - where - nested_eq_expr [] [] [] = true_Expr - nested_eq_expr tys as bs - = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) - where - nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b)) - -{- -************************************************************************ -* * - Ord instances -* * -************************************************************************ - -Note [Generating Ord instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose constructors are K1..Kn, and some are nullary. -The general form we generate is: - -* Do case on first argument - case a of - K1 ... -> rhs_1 - K2 ... -> rhs_2 - ... - Kn ... -> rhs_n - _ -> nullary_rhs - -* To make rhs_i - If i = 1, 2, n-1, n, generate a single case. - rhs_2 case b of - K1 {} -> LT - K2 ... -> ...eq_rhs(K2)... - _ -> GT - - Otherwise do a tag compare against the bigger range - (because this is the one most likely to succeed) - rhs_3 case tag b of tb -> - if 3 <# tg then GT - else case b of - K3 ... -> ...eq_rhs(K3).... - _ -> LT - -* To make eq_rhs(K), which knows that - a = K a1 .. av - b = K b1 .. bv - we just want to compare (a1,b1) then (a2,b2) etc. - Take care on the last field to tail-call into comparing av,bv - -* To make nullary_rhs generate this - case con2tag a of a# -> - case con2tag b of -> - a# `compare` b# - -Several special cases: - -* Two or fewer nullary constructors: don't generate nullary_rhs - -* Be careful about unlifted comparisons. When comparing unboxed - values we can't call the overloaded functions. - See function unliftedOrdOp - -Note [Game plan for deriving Ord] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's a bad idea to define only 'compare', and build the other binary -comparisons on top of it; see Trac #2130, #4019. Reason: we don't -want to laboriously make a three-way comparison, only to extract a -binary result, something like this: - (>) (I# x) (I# y) = case <# x y of - True -> False - False -> case ==# x y of - True -> False - False -> True - -This being said, we can get away with generating full code only for -'compare' and '<' thus saving us generation of other three operators. -Other operators can be cheaply expressed through '<': -a <= b = not $ b < a -a > b = b < a -a >= b = not $ a < b - -So for sufficiently small types (few constructors, or all nullary) -we generate all methods; for large ones we just use 'compare'. - --} - -data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT - ------------- -ordMethRdr :: OrdOp -> RdrName -ordMethRdr op - = case op of - OrdCompare -> compare_RDR - OrdLT -> lt_RDR - OrdLE -> le_RDR - OrdGE -> ge_RDR - OrdGT -> gt_RDR - ------------- -ltResult :: OrdOp -> LHsExpr RdrName --- Knowing a LHsExpr RdrName --- Knowing a=b, what is the result for a `op` b? -eqResult OrdCompare = eqTag_Expr -eqResult OrdLT = false_Expr -eqResult OrdLE = true_Expr -eqResult OrdGE = true_Expr -eqResult OrdGT = false_Expr - ------------- -gtResult :: OrdOp -> LHsExpr RdrName --- Knowing a>b, what is the result for a `op` b? -gtResult OrdCompare = gtTag_Expr -gtResult OrdLT = false_Expr -gtResult OrdLE = false_Expr -gtResult OrdGE = true_Expr -gtResult OrdGT = true_Expr - ------------- -gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) -gen_Ord_binds loc tycon = do - dflags <- getDynFlags - return $ if null tycon_data_cons -- No data-cons => invoke bale-out case - then ( unitBag $ mk_FunBind loc compare_RDR [] - , emptyBag) - else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags - , aux_binds) - where - aux_binds | single_con_type = emptyBag - | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon - - -- Note [Game plan for deriving Ord] - other_ops dflags - | (last_tag - first_tag) <= 2 -- 1-3 constructors - || null non_nullary_cons -- Or it's an enumeration - = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE] - | otherwise - = emptyBag - - negate_expr = nlHsApp (nlHsVar not_RDR) - lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $ - negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr) - gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $ - nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr - gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $ - negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) - - get_tag con = dataConTag con - fIRST_TAG - -- We want *zero-based* tags, because that's what - -- con2Tag returns (generated by untag_Expr)! - - tycon_data_cons = tyConDataCons tycon - single_con_type = isSingleton tycon_data_cons - (first_con : _) = tycon_data_cons - (last_con : _) = reverse tycon_data_cons - first_tag = get_tag first_con - last_tag = get_tag last_con - - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons - - - mkOrdOp :: DynFlags -> OrdOp -> LHsBind RdrName - -- Returns a binding op a b = ... compares a and b according to op .... - mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] - (mkOrdOpRhs dflags op) - - mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr RdrName - mkOrdOpRhs dflags op -- RHS for comparing 'a' and 'b' according to op - | length nullary_cons <= 2 -- Two nullary or fewer, so use cases - = nlHsCase (nlHsVar a_RDR) $ - map (mkOrdOpAlt dflags op) tycon_data_cons - -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... - -- C2 x -> case b of C2 x -> ....comopare x.... } - - | null non_nullary_cons -- All nullary, so go straight to comparing tags - = mkTagCmp dflags op - - | otherwise -- Mixed nullary and non-nullary - = nlHsCase (nlHsVar a_RDR) $ - (map (mkOrdOpAlt dflags op) non_nullary_cons - ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)]) - - - mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon - -> LMatch RdrName (LHsExpr RdrName) - -- Make the alternative (Ki a1 a2 .. av -> - mkOrdOpAlt dflags op data_con - = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) - (mkInnerRhs dflags op data_con) - where - as_needed = take (dataConSourceArity data_con) as_RDRs - data_con_RDR = getRdrName data_con - - mkInnerRhs dflags op data_con - | single_con_type - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] - - | tag == first_tag - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - | tag == last_tag - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - - | tag == first_tag + 1 - = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con) - (gtResult op) - , mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - | tag == last_tag - 1 - = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con) - (ltResult op) - , mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - - | tag > last_tag `div` 2 -- lower range is larger - = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) - (gtResult op) $ -- Definitely GT - nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - - | otherwise -- upper range is larger - = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) - (ltResult op) $ -- Definitely LT - nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - where - tag = get_tag data_con - tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag))) - - mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName) - -- First argument 'a' known to be built with K - -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) - mkInnerEqAlt op data_con - = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $ - mkCompareFields tycon op (dataConOrigArgTys data_con) - where - data_con_RDR = getRdrName data_con - bs_needed = take (dataConSourceArity data_con) bs_RDRs - - mkTagCmp :: DynFlags -> OrdOp -> LHsExpr RdrName - -- Both constructors known to be nullary - -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# - mkTagCmp dflags op = - untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ - unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR - -mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName --- Generates nested comparisons for (a1,a2...) against (b1,b2,...) --- where the ai,bi have the given types -mkCompareFields tycon op tys - = go tys as_RDRs bs_RDRs - where - go [] _ _ = eqResult op - go [ty] (a:_) (b:_) - | isUnliftedType ty = unliftedOrdOp tycon ty op a b - | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b) - go (ty:tys) (a:as) (b:bs) = mk_compare ty a b - (ltResult op) - (go tys as bs) - (gtResult op) - go _ _ _ = panic "mkCompareFields" - - -- (mk_compare ty a b) generates - -- (case (compare a b) of { LT -> ; EQ -> ; GT -> }) - -- but with suitable special cases for - mk_compare ty a b lt eq gt - | isUnliftedType ty - = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt - | otherwise - = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr)) - [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt, - mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq, - mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt] - where - a_expr = nlHsVar a - b_expr = nlHsVar b - (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty - -unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName -unliftedOrdOp tycon ty op a b - = case op of - OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr - ltTag_Expr eqTag_Expr gtTag_Expr - OrdLT -> wrap lt_op - OrdLE -> wrap le_op - OrdGE -> wrap ge_op - OrdGT -> wrap gt_op - where - (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty - wrap prim_op = genPrimOpApp a_expr prim_op b_expr - a_expr = nlHsVar a - b_expr = nlHsVar b - -unliftedCompare :: RdrName -> RdrName - -> LHsExpr RdrName -> LHsExpr RdrName -- What to cmpare - -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results - -> LHsExpr RdrName --- Return (if a < b then lt else if a == b then eq else gt) -unliftedCompare lt_op eq_op a_expr b_expr lt eq gt - = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $ - -- Test (<) first, not (==), because the latter - -- is true less often, so putting it first would - -- mean more tests (dynamically) - nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt - where - ascribeBool e = nlExprWithTySig e boolTy - -nlConWildPat :: DataCon -> LPat RdrName --- The pattern (K {}) -nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con)) - (RecCon (HsRecFields { rec_flds = [] - , rec_dotdot = Nothing }))) - -{- -************************************************************************ -* * - Enum instances -* * -************************************************************************ - -@Enum@ can only be derived for enumeration types. For a type -\begin{verbatim} -data Foo ... = N1 | N2 | ... | Nn -\end{verbatim} - -we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a -@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@). - -\begin{verbatim} -instance ... Enum (Foo ...) where - succ x = toEnum (1 + fromEnum x) - pred x = toEnum (fromEnum x - 1) - - toEnum i = tag2con_Foo i - - enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] - - -- or, really... - enumFrom a - = case con2tag_Foo a of - a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo) - - enumFromThen a b - = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo] - - -- or, really... - enumFromThen a b - = case con2tag_Foo a of { a# -> - case con2tag_Foo b of { b# -> - map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo) - }} -\end{verbatim} - -For @enumFromTo@ and @enumFromThenTo@, we use the default methods. --} - -gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) -gen_Enum_binds loc tycon = do - dflags <- getDynFlags - return (method_binds dflags, aux_binds) - where - method_binds dflags = listToBag - [ succ_enum dflags - , pred_enum dflags - , to_enum dflags - , enum_from dflags - , enum_from_then dflags - , from_enum dflags - ] - aux_binds = listToBag $ map DerivAuxBind - [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon] - - occ_nm = getOccString tycon - - succ_enum dflags - = mk_easy_FunBind loc succ_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon), - nlHsVarApps intDataCon_RDR [ah_RDR]]) - (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") - (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) - (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], - nlHsIntLit 1])) - - pred_enum dflags - = mk_easy_FunBind loc pred_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, - nlHsVarApps intDataCon_RDR [ah_RDR]]) - (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") - (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) - (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], - nlHsLit (HsInt NoSourceText (-1))])) - - to_enum dflags - = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ - nlHsIf (nlHsApps and_RDR - [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], - nlHsApps le_RDR [ nlHsVar a_RDR - , nlHsVar (maxtag_RDR dflags tycon)]]) - (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR]) - (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon)) - - enum_from dflags - = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsApps map_RDR - [nlHsVar (tag2con_RDR dflags tycon), - nlHsPar (enum_from_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVar (maxtag_RDR dflags tycon)))] - - enum_from_then dflags - = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ - nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ - nlHsPar (enum_from_then_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVarApps intDataCon_RDR [bh_RDR]) - (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], - nlHsVarApps intDataCon_RDR [bh_RDR]]) - (nlHsIntLit 0) - (nlHsVar (maxtag_RDR dflags tycon)) - )) - - from_enum dflags - = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - (nlHsVarApps intDataCon_RDR [ah_RDR]) - -{- -************************************************************************ -* * - Bounded instances -* * -************************************************************************ --} - -gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) -gen_Bounded_binds loc tycon - | isEnumerationTyCon tycon - = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) - | otherwise - = ASSERT(isSingleton data_cons) - (listToBag [ min_bound_1con, max_bound_1con ], emptyBag) - where - data_cons = tyConDataCons tycon - - ----- enum-flavored: --------------------------- - min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) - max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) - - data_con_1 = head data_cons - data_con_N = last data_cons - data_con_1_RDR = getRdrName data_con_1 - data_con_N_RDR = getRdrName data_con_N - - ----- single-constructor-flavored: ------------- - arity = dataConSourceArity data_con_1 - - min_bound_1con = mkHsVarBind loc minBound_RDR $ - nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) - max_bound_1con = mkHsVarBind loc maxBound_RDR $ - nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) - -{- -************************************************************************ -* * - Ix instances -* * -************************************************************************ - -Deriving @Ix@ is only possible for enumeration types and -single-constructor types. We deal with them in turn. - -For an enumeration type, e.g., -\begin{verbatim} - data Foo ... = N1 | N2 | ... | Nn -\end{verbatim} -things go not too differently from @Enum@: -\begin{verbatim} -instance ... Ix (Foo ...) where - range (a, b) - = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b] - - -- or, really... - range (a, b) - = case (con2tag_Foo a) of { a# -> - case (con2tag_Foo b) of { b# -> - map tag2con_Foo (enumFromTo (I# a#) (I# b#)) - }} - - -- Generate code for unsafeIndex, because using index leads - -- to lots of redundant range tests - unsafeIndex c@(a, b) d - = case (con2tag_Foo d -# con2tag_Foo a) of - r# -> I# r# - - inRange (a, b) c - = let - p_tag = con2tag_Foo c - in - p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b - - -- or, really... - inRange (a, b) c - = case (con2tag_Foo a) of { a_tag -> - case (con2tag_Foo b) of { b_tag -> - case (con2tag_Foo c) of { c_tag -> - if (c_tag >=# a_tag) then - c_tag <=# b_tag - else - False - }}} -\end{verbatim} -(modulo suitable case-ification to handle the unlifted tags) - -For a single-constructor type (NB: this includes all tuples), e.g., -\begin{verbatim} - data Foo ... = MkFoo a b Int Double c c -\end{verbatim} -we follow the scheme given in Figure~19 of the Haskell~1.2 report -(p.~147). --} - -gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) - -gen_Ix_binds loc tycon = do - dflags <- getDynFlags - return $ if isEnumerationTyCon tycon - then (enum_ixes dflags, listToBag $ map DerivAuxBind - [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]) - else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon))) - where - -------------------------------------------------------------- - enum_ixes dflags = listToBag - [ enum_range dflags - , enum_index dflags - , enum_inRange dflags - ] - - enum_range dflags - = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ - nlHsPar (enum_from_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVarApps intDataCon_RDR [bh_RDR])) - - enum_index dflags - = mk_easy_FunBind loc unsafeIndex_RDR - [noLoc (AsPat (noLoc c_RDR) - (nlTuplePat [a_Pat, nlWildPat] Boxed)), - d_Pat] ( - untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( - untag_Expr dflags tycon [(d_RDR, dh_RDR)] ( - let - rhs = nlHsVarApps intDataCon_RDR [c_RDR] - in - nlHsCase - (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR)) - [mkHsCaseAlt (nlVarPat c_RDR) rhs] - )) - ) - - -- This produces something like `(ch >= ah) && (ch <= bh)` - enum_inRange dflags - = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( - untag_Expr dflags tycon [(b_RDR, bh_RDR)] ( - untag_Expr dflags tycon [(c_RDR, ch_RDR)] ( - -- This used to use `if`, which interacts badly with RebindableSyntax. - -- See #11396. - nlHsApps and_RDR - [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR) - , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR) - ] - ))) - - -------------------------------------------------------------- - single_con_ixes - = listToBag [single_con_range, single_con_index, single_con_inRange] - - data_con - = case tyConSingleDataCon_maybe tycon of -- just checking... - Nothing -> panic "get_Ix_binds" - Just dc -> dc - - con_arity = dataConSourceArity data_con - data_con_RDR = getRdrName data_con - - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - cs_needed = take con_arity cs_RDRs - - con_pat xs = nlConVarPat data_con_RDR xs - con_expr = nlHsVarApps data_con_RDR cs_needed - - -------------------------------------------------------------- - single_con_range - = mk_easy_FunBind loc range_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ - noLoc (mkHsComp ListComp stmts con_expr) - where - stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed - - mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c) - (nlHsApp (nlHsVar range_RDR) - (mkLHsVarTuple [a,b])) - - ---------------- - single_con_index - = mk_easy_FunBind loc unsafeIndex_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] - -- We need to reverse the order we consider the components in - -- so that - -- range (l,u) !! index (l,u) i == i -- when i is in range - -- (from http://haskell.org/onlinereport/ix.html) holds. - (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) - where - -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) - mk_index [] = nlHsIntLit 0 - mk_index [(l,u,i)] = mk_one l u i - mk_index ((l,u,i) : rest) - = genOpApp ( - mk_one l u i - ) plus_RDR ( - genOpApp ( - (nlHsApp (nlHsVar unsafeRangeSize_RDR) - (mkLHsVarTuple [l,u])) - ) times_RDR (mk_index rest) - ) - mk_one l u i - = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] - - ------------------ - single_con_inRange - = mk_easy_FunBind loc inRange_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] $ - if con_arity == 0 - -- If the product type has no fields, inRange is trivially true - -- (see Trac #12853). - then true_Expr - else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range - as_needed bs_needed cs_needed) - where - in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] - -{- -************************************************************************ -* * - Read instances -* * -************************************************************************ - -Example - - infix 4 %% - data T = Int %% Int - | T1 { f1 :: Int } - | T2 T - -instance Read T where - readPrec = - parens - ( prec 4 ( - do x <- ReadP.step Read.readPrec - expectP (Symbol "%%") - y <- ReadP.step Read.readPrec - return (x %% y)) - +++ - prec (appPrec+1) ( - -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok - -- Record construction binds even more tightly than application - do expectP (Ident "T1") - expectP (Punc '{') - expectP (Ident "f1") - expectP (Punc '=') - x <- ReadP.reset Read.readPrec - expectP (Punc '}') - return (T1 { f1 = x })) - +++ - prec appPrec ( - do expectP (Ident "T2") - x <- ReadP.step Read.readPrec - return (T2 x)) - ) - - readListPrec = readListPrecDefault - readList = readListDefault - - -Note [Use expectP] -~~~~~~~~~~~~~~~~~~ -Note that we use - expectP (Ident "T1") -rather than - Ident "T1" <- lexP -The latter desugares to inline code for matching the Ident and the -string, and this can be very voluminous. The former is much more -compact. Cf Trac #7258, although that also concerned non-linearity in -the occurrence analyser, a separate issue. - -Note [Read for empty data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should we get for this? (Trac #7931) - data Emp deriving( Read ) -- No data constructors - -Here we want - read "[]" :: [Emp] to succeed, returning [] -So we do NOT want - instance Read Emp where - readPrec = error "urk" -Rather we want - instance Read Emp where - readPred = pfail -- Same as choose [] - -Because 'pfail' allows the parser to backtrack, but 'error' doesn't. -These instances are also useful for Read (Either Int Emp), where -we want to be able to parse (Left 3) just fine. --} - -gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) - -gen_Read_binds get_fixity loc tycon - = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) - where - ----------------------------------------------------------------------- - default_readlist - = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) - - default_readlistprec - = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) - ----------------------------------------------------------------------- - - data_cons = tyConDataCons tycon - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons - - read_prec = mkHsVarBind loc readPrec_RDR - (nlHsApp (nlHsVar parens_RDR) read_cons) - - read_cons | null data_cons = nlHsVar pfail_RDR -- See Note [Read for empty data types] - | otherwise = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) - read_non_nullary_cons = map read_non_nullary_con non_nullary_cons - - read_nullary_cons - = case nullary_cons of - [] -> [] - [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] - _ -> [nlHsApp (nlHsVar choose_RDR) - (nlList (map mk_pair nullary_cons))] - -- NB For operators the parens around (:=:) are matched by the - -- enclosing "parens" call, so here we must match the naked - -- data_con_str con - - match_con con | isSym con_str = [symbol_pat con_str] - | otherwise = ident_h_pat con_str - where - con_str = data_con_str con - -- For nullary constructors we must match Ident s for normal constrs - -- and Symbol s for operators - - mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), - result_expr con []] - - read_non_nullary_con data_con - | is_infix = mk_parser infix_prec infix_stmts body - | is_record = mk_parser record_prec record_stmts body --- Using these two lines instead allows the derived --- read for infix and record bindings to read the prefix form --- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) --- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) - | otherwise = prefix_parser - where - body = result_expr data_con as_needed - con_str = data_con_str data_con - - prefix_parser = mk_parser prefix_prec prefix_stmts body - - read_prefix_con - | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] - | otherwise = ident_h_pat con_str - - read_infix_con - | isSym con_str = [symbol_pat con_str] - | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] - - prefix_stmts -- T a b c - = read_prefix_con ++ read_args - - infix_stmts -- a %% b, or a `T` b - = [read_a1] - ++ read_infix_con - ++ [read_a2] - - record_stmts -- T { f1 = a, f2 = b } - = read_prefix_con - ++ [read_punc "{"] - ++ concat (intersperse [read_punc ","] field_stmts) - ++ [read_punc "}"] - - field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed - - con_arity = dataConSourceArity data_con - labels = map flLabel $ dataConFieldLabels data_con - dc_nm = getName data_con - is_infix = dataConIsInfix data_con - is_record = length labels > 0 - as_needed = take con_arity as_RDRs - read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con) - (read_a1:read_a2:_) = read_args - - prefix_prec = appPrecedence - infix_prec = getPrecedence get_fixity dc_nm - record_prec = appPrecedence + 1 -- Record construction binds even more tightly - -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) - - ------------------------------------------------------------------------ - -- Helpers - ------------------------------------------------------------------------ - mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 - mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) - , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])] - con_app con as = nlHsVarApps (getRdrName con) as -- con as - result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) - - -- For constructors and field labels ending in '#', we hackily - -- let the lexer generate two tokens, and look for both in sequence - -- Thus [Ident "I"; Symbol "#"]. See Trac #5041 - ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] - | otherwise = [ ident_pat s ] - - bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p - -- See Note [Use expectP] - ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo") - symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>") - read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<") - - data_con_str con = occNameString (getOccName con) - - read_arg a ty = ASSERT( not (isUnliftedType ty) ) - noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) - - read_field lbl a = read_lbl lbl ++ - [read_punc "=", - noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))] - - -- When reading field labels we might encounter - -- a = 3 - -- _a = 3 - -- or (#) = 4 - -- Note the parens! - read_lbl lbl | isSym lbl_str - = [read_punc "(", symbol_pat lbl_str, read_punc ")"] - | otherwise - = ident_h_pat lbl_str - where - lbl_str = unpackFS lbl - -{- -************************************************************************ -* * - Show instances -* * -************************************************************************ - -Example - - infixr 5 :^: - - data Tree a = Leaf a | Tree a :^: Tree a - - instance (Show a) => Show (Tree a) where - - showsPrec d (Leaf m) = showParen (d > app_prec) showStr - where - showStr = showString "Leaf " . showsPrec (app_prec+1) m - - showsPrec d (u :^: v) = showParen (d > up_prec) showStr - where - showStr = showsPrec (up_prec+1) u . - showString " :^: " . - showsPrec (up_prec+1) v - -- Note: right-associativity of :^: ignored - - up_prec = 5 -- Precedence of :^: - app_prec = 10 -- Application has precedence one more than - -- the most tightly-binding operator --} - -gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) - -gen_Show_binds get_fixity loc tycon - = (listToBag [shows_prec, show_list], emptyBag) - where - ----------------------------------------------------------------------- - show_list = mkHsVarBind loc showList_RDR - (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) - ----------------------------------------------------------------------- - data_cons = tyConDataCons tycon - shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons) - comma_space = nlHsVar showCommaSpace_RDR - - pats_etc data_con - | nullary_con = -- skip the showParen junk... - ASSERT(null bs_needed) - ([nlWildPat, con_pat], mk_showString_app op_con_str) - | otherwise = - ([a_Pat, con_pat], - showParen_Expr (genOpApp a_Expr ge_RDR - (nlHsLit (HsInt NoSourceText con_prec_plus_one))) - (nlHsPar (nested_compose_Expr show_thingies))) - where - data_con_RDR = getRdrName data_con - con_arity = dataConSourceArity data_con - bs_needed = take con_arity bs_RDRs - arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed - con_pat = nlConVarPat data_con_RDR bs_needed - nullary_con = con_arity == 0 - labels = map flLabel $ dataConFieldLabels data_con - lab_fields = length labels - record_syntax = lab_fields > 0 - - dc_nm = getName data_con - dc_occ_nm = getOccName data_con - con_str = occNameString dc_occ_nm - op_con_str = wrapOpParens con_str - backquote_str = wrapOpBackquotes con_str - - show_thingies - | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2] - | record_syntax = mk_showString_app (op_con_str ++ " {") : - show_record_args ++ [mk_showString_app "}"] - | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args - - show_label l = mk_showString_app (nm ++ " = ") - -- Note the spaces around the "=" sign. If we - -- don't have them then we get Foo { x=-1 } and - -- the "=-" parses as a single lexeme. Only the - -- space after the '=' is necessary, but it - -- seems tidier to have them both sides. - where - nm = wrapOpParens (unpackFS l) - - show_args = zipWith show_arg bs_needed arg_tys - (show_arg1:show_arg2:_) = show_args - show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args - - -- Assumption for record syntax: no of fields == no of - -- labelled fields (and in same order) - show_record_args = concat $ - intersperse [comma_space] $ - [ [show_label lbl, arg] - | (lbl,arg) <- zipEqual "gen_Show_binds" - labels show_args ] - - show_arg :: RdrName -> Type -> LHsExpr RdrName - show_arg b arg_ty - | isUnliftedType arg_ty - -- See Note [Deriving and unboxed types] in TcDeriv - = nlHsApps compose_RDR [mk_shows_app boxed_arg, - mk_showString_app postfixMod] - | otherwise - = mk_showsPrec_app arg_prec arg - where - arg = nlHsVar b - boxed_arg = box "Show" tycon arg arg_ty - postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty - - -- Fixity stuff - is_infix = dataConIsInfix data_con - con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm - arg_prec | record_syntax = 0 -- Record fields don't need parens - | otherwise = con_prec_plus_one - -wrapOpParens :: String -> String -wrapOpParens s | isSym s = '(' : s ++ ")" - | otherwise = s - -wrapOpBackquotes :: String -> String -wrapOpBackquotes s | isSym s = s - | otherwise = '`' : s ++ "`" - -isSym :: String -> Bool -isSym "" = False -isSym (c : _) = startsVarSym c || startsConSym c - --- | showString :: String -> ShowS -mk_showString_app :: String -> LHsExpr RdrName -mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) - --- | showsPrec :: Show a => Int -> a -> ShowS -mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName -mk_showsPrec_app p x - = nlHsApps showsPrec_RDR [nlHsLit (HsInt NoSourceText p), x] - --- | shows :: Show a => a -> ShowS -mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName -mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x - -getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer -getPrec is_infix get_fixity nm - | not is_infix = appPrecedence - | otherwise = getPrecedence get_fixity nm - -appPrecedence :: Integer -appPrecedence = fromIntegral maxPrecedence + 1 - -- One more than the precedence of the most - -- tightly-binding operator - -getPrecedence :: (Name -> Fixity) -> Name -> Integer -getPrecedence get_fixity nm - = case get_fixity nm of - Fixity _ x _assoc -> fromIntegral x - -- NB: the Report says that associativity is not taken - -- into account for either Read or Show; hence we - -- ignore associativity here - -{- -************************************************************************ -* * - Data instances -* * -************************************************************************ - -From the data type - - data T a b = T1 a b | T2 - -we generate - - $cT1 = mkDataCon $dT "T1" Prefix - $cT2 = mkDataCon $dT "T2" Prefix - $dT = mkDataType "Module.T" [] [$con_T1, $con_T2] - -- the [] is for field labels. - - instance (Data a, Data b) => Data (T a b) where - gfoldl k z (T1 a b) = z T `k` a `k` b - gfoldl k z T2 = z T2 - -- ToDo: add gmapT,Q,M, gfoldr - - gunfold k z c = case conIndex c of - I# 1# -> k (k (z T1)) - I# 2# -> z T2 - - toConstr (T1 _ _) = $cT1 - toConstr T2 = $cT2 - - dataTypeOf _ = $dT - - dataCast1 = gcast1 -- If T :: * -> * - dataCast2 = gcast2 -- if T :: * -> * -> * --} - -gen_Data_binds :: SrcSpan - -> TyCon -- For data families, this is the - -- *representation* TyCon - -> TcM (LHsBinds RdrName, -- The method bindings - BagDerivStuff) -- Auxiliary bindings -gen_Data_binds loc rep_tc - = do { dflags <- getDynFlags - - -- Make unique names for the data type and constructor - -- auxiliary bindings. Start with the name of the TyCon/DataCon - -- but that might not be unique: see Trac #12245. - ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc)) - ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName) - (tyConDataCons rep_tc) - ; let dt_rdr = mkRdrUnqual dt_occ - dc_rdrs = map mkRdrUnqual dc_occs - - -- OK, now do the work - ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) } - -gen_data :: DynFlags -> RdrName -> [RdrName] - -> SrcSpan -> TyCon - -> (LHsBinds RdrName, -- The method bindings - BagDerivStuff) -- Auxiliary bindings -gen_data dflags data_type_name constr_names loc rep_tc - = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] - `unionBags` gcast_binds, - -- Auxiliary definitions: the data type and constructors - listToBag ( genDataTyCon - : zipWith genDataDataCon data_cons constr_names ) ) - where - data_cons = tyConDataCons rep_tc - n_cons = length data_cons - one_constr = n_cons == 1 - genDataTyCon :: DerivStuff - genDataTyCon -- $dT - = DerivHsBind (mkHsVarBind loc data_type_name rhs, - L loc (TypeSig [L loc data_type_name] sig_ty)) - - sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) - rhs = nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc))) - `nlHsApp` nlList (map nlHsVar constr_names) - - genDataDataCon :: DataCon -> RdrName -> DerivStuff - genDataDataCon dc constr_name -- $cT1 etc - = DerivHsBind (mkHsVarBind loc constr_name rhs, - L loc (TypeSig [L loc constr_name] sig_ty)) - where - sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR) - rhs = nlHsApps mkConstr_RDR constr_args - - constr_args - = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag - nlHsVar (data_type_name) -- DataType - , nlHsLit (mkHsString (occNameString dc_occ)) -- String name - , nlList labels -- Field labels - , nlHsVar fixity ] -- Fixity - - labels = map (nlHsLit . mkHsString . unpackFS . flLabel) - (dataConFieldLabels dc) - dc_occ = getOccName dc - is_infix = isDataSymOcc dc_occ - fixity | is_infix = infix_RDR - | otherwise = prefix_RDR - - ------------ gfoldl - gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons) - - gfoldl_eqn con - = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed], - foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed) - where - con_name :: RdrName - con_name = getRdrName con - as_needed = take (dataConSourceArity con) as_RDRs - mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) - - ------------ gunfold - gunfold_bind = mk_HRFunBind 2 loc - gunfold_RDR - [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], - gunfold_rhs)] - - gunfold_rhs - | one_constr = mk_unfold_rhs (head data_cons) -- No need for case - | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) - (map gunfold_alt data_cons) - - gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) - mk_unfold_rhs dc = foldr nlHsApp - (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc)) - (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) - - mk_unfold_pat dc -- Last one is a wild-pat, to avoid - -- redundant test, and annoying warning - | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor - | otherwise = nlConPat intDataCon_RDR - [nlLitPat (HsIntPrim NoSourceText (toInteger tag))] - where - tag = dataConTag dc - - ------------ toConstr - toCon_bind = mk_FunBind loc toConstr_RDR (zipWith to_con_eqn data_cons constr_names) - to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) - - ------------ dataTypeOf - dataTypeOf_bind = mk_easy_FunBind - loc - dataTypeOf_RDR - [nlWildPat] - (nlHsVar data_type_name) - - ------------ gcast1/2 - -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> * - -- or dataCast2 x = gcast2 s -- if T :: * -> * -> * - -- (or nothing if T has neither of these two types) - - -- But care is needed for data families: - -- If we have data family D a - -- data instance D (a,b,c) = A | B deriving( Data ) - -- and we want instance ... => Data (D [(a,b,c)]) where ... - -- then we need dataCast1 x = gcast1 x - -- because D :: * -> * - -- even though rep_tc has kind * -> * -> * -> * - -- Hence looking for the kind of fam_tc not rep_tc - -- See Trac #4896 - tycon_kind = case tyConFamInst_maybe rep_tc of - Just (fam_tc, _) -> tyConKind fam_tc - Nothing -> tyConKind rep_tc - gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR - | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR - | otherwise = emptyBag - mk_gcast dataCast_RDR gcast_RDR - = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR] - (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) - - -kind1, kind2 :: Kind -kind1 = liftedTypeKind `mkFunTy` liftedTypeKind -kind2 = liftedTypeKind `mkFunTy` kind1 - -gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, - mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, - dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, - constr_RDR, dataType_RDR, - eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR , - eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , - eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , - eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , - eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , - eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName -gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") -gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") -toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") -dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") -dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") -dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") -gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") -gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") -mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") -constr_RDR = tcQual_RDR gENERICS (fsLit "Constr") -mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") -dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") -conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") -prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") -infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") - -eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#") -ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#") -leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#") -gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#") -geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#") - -eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#") -ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" ) -leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#") -gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" ) -geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#") - -eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") -ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") -leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") -gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#") -geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#") - -eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") -ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") -leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") -gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#") -geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#") - -eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#") -ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#") -leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#") -gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#") -geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#") - -eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##") -ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" ) -leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##") -gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) -geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") - -{- -************************************************************************ -* * - Lift instances -* * -************************************************************************ - -Example: - - data Foo a = Foo a | a :^: a deriving Lift - - ==> - - instance (Lift a) => Lift (Foo a) where - lift (Foo a) - = appE - (conE - (mkNameG_d "package-name" "ModuleName" "Foo")) - (lift a) - lift (u :^: v) - = infixApp - (lift u) - (conE - (mkNameG_d "package-name" "ModuleName" ":^:")) - (lift v) - -Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what -'Foo would be when using the -XTemplateHaskell extension. To make sure that --XDeriveLift can be used on stage-1 compilers, however, we explicitly invoke -makeG_d. --} - -gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) -gen_Lift_binds loc tycon - | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR) - [mkMatch (mkPrefixFunRhs (L loc lift_RDR)) - [nlWildPat] errorMsg_Expr - (noLoc emptyLocalBinds)]) - , emptyBag) - | otherwise = (unitBag lift_bind, emptyBag) - where - errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit - (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str) - - lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons) - data_cons = tyConDataCons tycon - tycon_str = occNameString . nameOccName . tyConName $ tycon - - pats_etc data_con - = ([con_pat], lift_Expr) - where - con_pat = nlConVarPat data_con_RDR as_needed - data_con_RDR = getRdrName data_con - con_arity = dataConSourceArity data_con - as_needed = take con_arity as_RDRs - lifted_as = zipWithEqual "mk_lift_app" mk_lift_app - tys_needed as_needed - tycon_name = tyConName tycon - is_infix = dataConIsInfix data_con - tys_needed = dataConOrigArgTys data_con - - mk_lift_app ty a - | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR) - (nlHsVar a) - | otherwise = nlHsApp (nlHsVar litE_RDR) - (primLitOp (mkBoxExp (nlHsVar a))) - where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty - - pkg_name = unitIdString . moduleUnitId - . nameModule $ tycon_name - mod_name = moduleNameString . moduleName . nameModule $ tycon_name - con_name = occNameString . nameOccName . dataConName $ data_con - - conE_Expr = nlHsApp (nlHsVar conE_RDR) - (nlHsApps mkNameG_dRDR - (map (nlHsLit . mkHsString) - [pkg_name, mod_name, con_name])) - - lift_Expr - | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2] - | otherwise = foldl mk_appE_app conE_Expr lifted_as - (a1:a2:_) = lifted_as - -mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -mk_appE_app a b = nlHsApps appE_RDR [a, b] - -{- -************************************************************************ -* * - Newtype-deriving instances -* * -************************************************************************ - -Note [Newtype-deriving instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We take every method in the original instance and `coerce` it to fit -into the derived instance. We need a type annotation on the argument -to `coerce` to make it obvious what instantiation of the method we're -coercing from. So from, say, - class C a b where - op :: a -> [b] -> Int - - newtype T x = MkT - - instance C a => C a (T x) where - op = coerce @ (a -> [] -> Int) - @ (a -> [T x] -> Int) - op - -Notice that we give the 'coerce' two explicitly-visible type arguments -to say how it should be instantiated. Recall - - coerce :: Coeercible a b => a -> b - -By giving it explicit type arguments we deal with the case where -'op' has a higher rank type, and so we must instantiate 'coerce' with -a polytype. E.g. - class C a where op :: forall b. a -> b -> b - newtype T x = MkT - instance C => C (T x) where - op = coerce @ (forall b. -> b -> b) - @ (forall b. T x -> b -> b) - op - -The type checker checks this code, and it currently requires --XImpredicativeTypes to permit that polymorphic type instantiation, -so we have to switch that flag on locally in TcDeriv.genInst. - -See #8503 for more discussion. - -Note [Newtype-deriving trickiness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #12768): - class C a where { op :: D a => a -> a } - - instance C a => C [a] where { op = opList } - - opList :: (C a, D [a]) => [a] -> [a] - opList = ... - -Now suppose we try GND on this: - newtype N a = MkN [a] deriving( C ) - -The GND is expecting to get an implementation of op for N by -coercing opList, thus: - - instance C a => C (N a) where { op = opN } - - opN :: (C a, D (N a)) => N a -> N a - opN = coerce @(D [a] => [a] -> [a]) - @(D (N a) => [N a] -> [N a] - opList - -But there is no reason to suppose that (D [a]) and (D (N a)) -are inter-coercible; these instances might completely different. -So GHC rightly rejects this code. --} - -gen_Newtype_binds :: SrcSpan - -> Class -- the class being derived - -> [TyVar] -- the tvs in the instance head (this includes - -- the tvs from both the class types and the - -- newtype itself) - -> [Type] -- instance head parameters (incl. newtype) - -> Type -- the representation type - -> TcM (LHsBinds RdrName, BagDerivStuff) --- See Note [Newtype-deriving instances] -gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty - = do let ats = classATs cls - atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats ) - mapM mk_atf_inst ats - return ( listToBag $ map mk_bind (classMethods cls) - , listToBag $ map DerivFamInst atf_insts ) - where - coerce_RDR = getRdrName coerceId - - mk_bind :: Id -> LHsBind RdrName - mk_bind meth_id - = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch - (mkPrefixFunRhs (L loc meth_RDR)) - [] rhs_expr] - where - Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id - - meth_RDR = getRdrName meth_id - - rhs_expr = nlHsVar coerce_RDR `nlHsAppType` from_ty - `nlHsAppType` to_ty - `nlHsApp` nlHsVar meth_RDR - - mk_atf_inst :: TyCon -> TcM FamInst - mk_atf_inst fam_tc = do - rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) - rep_lhs_tys - let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' rep_cvs' - fam_tc rep_lhs_tys rep_rhs_ty - -- Check (c) from Note [GND and associated type families] in TcDeriv - checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs' - rep_cvs' rep_lhs_tys rep_rhs_ty loc - 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 $ changeLast inst_tys rhs_ty - rhs_subst = mkTvSubst in_scope rhs_env - fam_tvs = tyConTyVars fam_tc - rep_lhs_tys = substTyVars lhs_subst fam_tvs - rep_rhs_tys = substTyVars rhs_subst fam_tvs - rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys - rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys - (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs - rep_tvs' = toposortTyVars rep_tvs - rep_cvs' = toposortTyVars rep_cvs - -nlHsAppType :: LHsExpr RdrName -> Type -> LHsExpr RdrName -nlHsAppType e s = noLoc (e `HsAppType` hs_ty) - where - hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s) - -nlExprWithTySig :: LHsExpr RdrName -> Type -> LHsExpr RdrName -nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty) - where - hs_ty = mkLHsSigWcType (typeToLHsType s) - -mkCoerceClassMethEqn :: Class -- the class being derived - -> [TyVar] -- the tvs in the instance head (this includes - -- the tvs from both the class types and the - -- newtype itself) - -> [Type] -- instance head parameters (incl. newtype) - -> Type -- the representation type - -> Id -- the method to look at - -> Pair Type --- See Note [Newtype-deriving instances] --- See also Note [Newtype-deriving trickiness] --- The pair is the (from_type, to_type), where to_type is --- the type of the method we are tyrying to get -mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id - = Pair (substTy rhs_subst user_meth_ty) - (substTy lhs_subst user_meth_ty) - where - cls_tvs = classTyVars cls - in_scope = mkInScopeSet $ mkVarSet inst_tvs - lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys) - rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty)) - (_class_tvs, _class_constraint, user_meth_ty) - = tcSplitMethodTy (varType id) - -{- -************************************************************************ -* * -\subsection{Generating extra binds (@con2tag@ and @tag2con@)} -* * -************************************************************************ - -\begin{verbatim} -data Foo ... = ... - -con2tag_Foo :: Foo ... -> Int# -tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# -maxtag_Foo :: Int -- ditto (NB: not unlifted) -\end{verbatim} - -The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) -fiddling around. --} - -genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec - -> (LHsBind RdrName, LSig RdrName) -genAuxBindSpec dflags loc (DerivCon2Tag tycon) - = (mk_FunBind loc rdr_name eqns, - L loc (TypeSig [L loc rdr_name] sig_ty)) - where - rdr_name = con2tag_RDR dflags tycon - - sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $ - mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ - mkParentType tycon `mkFunTy` intPrimTy - - lots_of_constructors = tyConFamilySize tycon > 8 - -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS - -- but we don't do vectored returns any more. - - eqns | lots_of_constructors = [get_tag_eqn] - | otherwise = map mk_eqn (tyConDataCons tycon) - - get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr) - - mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName) - mk_eqn con = ([nlWildConPat con], - nlHsLit (HsIntPrim NoSourceText - (toInteger ((dataConTag con) - fIRST_TAG)))) - -genAuxBindSpec dflags loc (DerivTag2Con tycon) - = (mk_FunBind loc rdr_name - [([nlConVarPat intDataCon_RDR [a_RDR]], - nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig [L loc rdr_name] sig_ty)) - where - sig_ty = mkLHsSigWcType $ L loc $ - HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ - intTy `mkFunTy` mkParentType tycon - - rdr_name = tag2con_RDR dflags tycon - -genAuxBindSpec dflags loc (DerivMaxTag tycon) - = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] sig_ty)) - where - rdr_name = maxtag_RDR dflags tycon - sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy)) - rhs = nlHsApp (nlHsVar intDataCon_RDR) - (nlHsLit (HsIntPrim NoSourceText max_tag)) - max_tag = case (tyConDataCons tycon) of - data_cons -> toInteger ((length data_cons) - fIRST_TAG) - -type SeparateBagsDerivStuff = - -- AuxBinds and SYB bindings - ( Bag (LHsBind RdrName, LSig RdrName) - -- Extra family instances (used by Generic and DeriveAnyClass) - , Bag (FamInst) ) - -genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff -genAuxBinds dflags loc b = genAuxBinds' b2 where - (b1,b2) = partitionBagWith splitDerivAuxBind b - splitDerivAuxBind (DerivAuxBind x) = Left x - splitDerivAuxBind x = Right x - - rm_dups = foldrBag dup_check emptyBag - dup_check a b = if anyBag (== a) b then b else consBag a b - - genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff - genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1) - , emptyBag ) - f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff - f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before - f (DerivHsBind b) = add1 b - f (DerivFamInst t) = add2 t - - add1 x (a,b) = (x `consBag` a,b) - add2 x (a,b) = (a,x `consBag` b) - -mkParentType :: TyCon -> Type --- Turn the representation tycon of a family into --- a use of its family constructor -mkParentType tc - = case tyConFamInst_maybe tc of - Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc)) - Just (fam_tc,tys) -> mkTyConApp fam_tc tys - -{- -************************************************************************ -* * -\subsection{Utility bits for generating bindings} -* * -************************************************************************ --} - -mk_FunBind :: SrcSpan -> RdrName - -> [([LPat RdrName], LHsExpr RdrName)] - -> LHsBind RdrName -mk_FunBind = mk_HRFunBind 0 -- by using mk_FunBind and not mk_HRFunBind, - -- the caller says that the Void case needs no - -- patterns - --- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before --- the "=" in the empty-data-decl case. This is necessary if the function --- has a higher-rank type, like foldl. (See deriving/should_compile/T4302) -mk_HRFunBind :: Arity -> SrcSpan -> RdrName - -> [([LPat RdrName], LHsExpr RdrName)] - -> LHsBind RdrName -mk_HRFunBind arity loc fun pats_and_exprs - = mkHRRdrFunBind arity (L loc fun) matches - where - matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e - (noLoc emptyLocalBinds) - | (p,e) <-pats_and_exprs] - -mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName -mkRdrFunBind = mkHRRdrFunBind 0 - -mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName -mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') - where - -- Catch-all eqn looks like - -- fmap = error "Void fmap" - -- It's needed if there no data cons at all, - -- which can happen with -XEmptyDataDecls - -- See Trac #4302 - matches' = if null matches - then [mkMatch (mkPrefixFunRhs fun) - (replicate arity nlWildPat) - (error_Expr str) (noLoc emptyLocalBinds)] - else matches - str = "Void " ++ occNameString (rdrNameOcc fun_rdr) - -box :: String -- The class involved - -> TyCon -- The tycon involved - -> LHsExpr RdrName -- The argument - -> Type -- The argument type - -> LHsExpr RdrName -- Boxed version of the arg --- See Note [Deriving and unboxed types] in TcDeriv -box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg - where - box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty - ---------------------- -primOrdOps :: String -- The class involved - -> TyCon -- The tycon involved - -> Type -- The type - -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt) --- See Note [Deriving and unboxed types] in TcDeriv -primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty - -primLitOps :: String -- The class involved - -> TyCon -- The tycon involved - -> Type -- The type - -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value - , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value - ) -primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty - , \v -> nlHsVar boxRDR `nlHsApp` v - ) - where - boxRDR - | ty `eqType` addrPrimTy = unpackCString_RDR - | otherwise = assoc_ty_id str tycon boxConTbl ty - -ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] -ordOpTbl - = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR )) - ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR )) - ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR )) - ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) - ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) - ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] - -boxConTbl :: [(Type, RdrName)] -boxConTbl - = [(charPrimTy , getRdrName charDataCon ) - ,(intPrimTy , getRdrName intDataCon ) - ,(wordPrimTy , getRdrName wordDataCon ) - ,(floatPrimTy , getRdrName floatDataCon ) - ,(doublePrimTy, getRdrName doubleDataCon) - ] - --- | A table of postfix modifiers for unboxed values. -postfixModTbl :: [(Type, String)] -postfixModTbl - = [(charPrimTy , "#" ) - ,(intPrimTy , "#" ) - ,(wordPrimTy , "##") - ,(floatPrimTy , "#" ) - ,(doublePrimTy, "##") - ] - -litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)] -litConTbl - = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR)) - ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR) - . nlHsApp (nlHsVar toInteger_RDR)) - ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR) - . nlHsApp (nlHsVar toInteger_RDR)) - ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR) - . nlHsApp (nlHsApp - (nlHsVar map_RDR) - (compose_RDR `nlHsApps` - [ nlHsVar fromIntegral_RDR - , nlHsVar fromEnum_RDR - ]))) - ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR) - . nlHsApp (nlHsVar toRational_RDR)) - ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR) - . nlHsApp (nlHsVar toRational_RDR)) - ] - --- | Lookup `Type` in an association list. -assoc_ty_id :: String -- The class involved - -> TyCon -- The tycon involved - -> [(Type,a)] -- The table - -> Type -- The type - -> a -- The result of the lookup -assoc_ty_id cls_str _ tbl ty - | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+> - text "for primitive type" <+> ppr ty) - | otherwise = head res - where - res = [id | (ty',id) <- tbl, ty `eqType` ty'] - ------------------------------------------------------------------------ - -and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -and_Expr a b = genOpApp a and_RDR b - ------------------------------------------------------------------------ - -eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -eq_Expr tycon ty a b - | not (isUnliftedType ty) = genOpApp a eq_RDR b - | otherwise = genPrimOpApp a prim_eq b - where - (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty - -untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)] - -> LHsExpr RdrName -> LHsExpr RdrName -untag_Expr _ _ [] expr = expr -untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr - = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon) - [untag_this])) {-of-} - [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)] - -enum_from_to_Expr - :: LHsExpr RdrName -> LHsExpr RdrName - -> LHsExpr RdrName -enum_from_then_to_Expr - :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName - -> LHsExpr RdrName - -enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2 -enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2 - -showParen_Expr - :: LHsExpr RdrName -> LHsExpr RdrName - -> LHsExpr RdrName - -showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 - -nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName - -nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty -nested_compose_Expr [e] = parenify e -nested_compose_Expr (e:es) - = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) - --- impossible_Expr is used in case RHSs that should never happen. --- We generate these to keep the desugarer from complaining that they *might* happen! -error_Expr :: String -> LHsExpr RdrName -error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) - --- illegal_Expr is used when signalling error conditions in the RHS of a derived --- method. It is currently only used by Enum.{succ,pred} -illegal_Expr :: String -> String -> String -> LHsExpr RdrName -illegal_Expr meth tp msg = - nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) - --- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you --- to include the value of a_RDR in the error string. -illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName -illegal_toEnum_tag tp maxtag = - nlHsApp (nlHsVar error_RDR) - (nlHsApp (nlHsApp (nlHsVar append_RDR) - (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag (")))) - (nlHsApp (nlHsApp (nlHsApp - (nlHsVar showsPrec_RDR) - (nlHsIntLit 0)) - (nlHsVar a_RDR)) - (nlHsApp (nlHsApp - (nlHsVar append_RDR) - (nlHsLit (mkHsString ") is outside of enumeration's range (0,"))) - (nlHsApp (nlHsApp (nlHsApp - (nlHsVar showsPrec_RDR) - (nlHsIntLit 0)) - (nlHsVar maxtag)) - (nlHsLit (mkHsString ")")))))) - -parenify :: LHsExpr RdrName -> LHsExpr RdrName -parenify e@(L _ (HsVar _)) = e -parenify e = mkHsPar e - --- genOpApp wraps brackets round the operator application, so that the --- renamer won't subsequently try to re-associate it. -genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName -genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) - -genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName -genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2)) - -a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR - :: RdrName -a_RDR = mkVarUnqual (fsLit "a") -b_RDR = mkVarUnqual (fsLit "b") -c_RDR = mkVarUnqual (fsLit "c") -d_RDR = mkVarUnqual (fsLit "d") -f_RDR = mkVarUnqual (fsLit "f") -k_RDR = mkVarUnqual (fsLit "k") -z_RDR = mkVarUnqual (fsLit "z") -ah_RDR = mkVarUnqual (fsLit "a#") -bh_RDR = mkVarUnqual (fsLit "b#") -ch_RDR = mkVarUnqual (fsLit "c#") -dh_RDR = mkVarUnqual (fsLit "d#") - -as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] -as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] -cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] - -a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, - true_Expr :: LHsExpr RdrName -a_Expr = nlHsVar a_RDR -b_Expr = nlHsVar b_RDR -c_Expr = nlHsVar c_RDR -ltTag_Expr = nlHsVar ltTag_RDR -eqTag_Expr = nlHsVar eqTag_RDR -gtTag_Expr = nlHsVar gtTag_RDR -false_Expr = nlHsVar false_RDR -true_Expr = nlHsVar true_RDR - -a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName -a_Pat = nlVarPat a_RDR -b_Pat = nlVarPat b_RDR -c_Pat = nlVarPat c_RDR -d_Pat = nlVarPat d_RDR -k_Pat = nlVarPat k_RDR -z_Pat = nlVarPat z_RDR - -minusInt_RDR, tagToEnum_RDR :: RdrName -minusInt_RDR = getRdrName (primOpId IntSubOp ) -tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) - -con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName --- Generates Orig s RdrName, for the binding positions -con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc -tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc -maxtag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc - -mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName -mk_tc_deriv_name dflags tycon occ_fun = - mkAuxBinderName dflags (tyConName tycon) occ_fun - -mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName --- ^ Make a top-level binder name for an auxiliary binding for a parent name --- See Note [Auxiliary binders] -mkAuxBinderName dflags parent occ_fun - = mkRdrUnqual (occ_fun stable_parent_occ) - where - stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string - stable_string - | hasPprDebug dflags = parent_stable - | otherwise = parent_stable_hash - parent_stable = nameStableString parent - parent_stable_hash = - let Fingerprint high low = fingerprintString parent_stable - in toBase62 high ++ toBase62Padded low - -- See Note [Base 62 encoding 128-bit integers] in Encoding - parent_occ = nameOccName parent - - -{- -Note [Auxiliary binders] -~~~~~~~~~~~~~~~~~~~~~~~~ -We often want to make a top-level auxiliary binding. E.g. for comparison we haev - - instance Ord T where - compare a b = $con2tag a `compare` $con2tag b - - $con2tag :: T -> Int - $con2tag = ...code.... - -Of course these top-level bindings should all have distinct name, and we are -generating RdrNames here. We can't just use the TyCon or DataCon to distinguish -because with standalone deriving two imported TyCons might both be called T! -(See Trac #7947.) - -So we use package name, module name and the name of the parent -(T in this example) as part of the OccName we generate for the new binding. -To make the symbol names short we take a base62 hash of the full name. - -In the past we used the *unique* from the parent, but that's not stable across -recompilations as uniques are nondeterministic. --} diff --git a/typecheck/TcGenFunctor.hs b/typecheck/TcGenFunctor.hs deleted file mode 100644 --- a/typecheck/TcGenFunctor.hs +++ /dev/null @@ -1,1023 +0,0 @@ -{- -(c) The University of Glasgow 2011 - - -The deriving code for the Functor, Foldable, and Traversable classes -(equivalent to the code in TcGenDeriv, for other classes) --} - -{-# LANGUAGE ScopedTypeVariables #-} - -module TcGenFunctor ( - FFoldType(..), functorLikeTraverse, - deepSubtypesContaining, foldDataConArgs, - - gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds - ) where - -import Bag -import DataCon -import FastString -import HsSyn -import Panic -import PrelNames -import RdrName -import SrcLoc -import State -import TcGenDeriv -import TcType -import TyCon -import TyCoRep -import Type -import Util -import Var -import VarSet - -import Data.Maybe (catMaybes, isJust) - -{- -************************************************************************ -* * - Functor instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html - -* * -************************************************************************ - -For the data type: - - data T a = T1 Int a | T2 (T a) - -We generate the instance: - - instance Functor T where - fmap f (T1 b1 a) = T1 b1 (f a) - fmap f (T2 ta) = T2 (fmap f ta) - -Notice that we don't simply apply 'fmap' to the constructor arguments. -Rather - - Do nothing to an argument whose type doesn't mention 'a' - - Apply 'f' to an argument of type 'a' - - Apply 'fmap f' to other arguments -That's why we have to recurse deeply into the constructor argument types, -rather than just one level, as we typically do. - -What about types with more than one type parameter? In general, we only -derive Functor for the last position: - - data S a b = S1 [b] | S2 (a, T a b) - instance Functor (S a) where - fmap f (S1 bs) = S1 (fmap f bs) - fmap f (S2 (p,q)) = S2 (a, fmap f q) - -However, we have special cases for - - tuples - - functions - -More formally, we write the derivation of fmap code over type variable -'a for type 'b as ($fmap 'a 'b). In this general notation the derived -instance for T is: - - instance Functor T where - fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2) - fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1) - - $(fmap 'a 'b) = \x -> x -- when b does not contain a - $(fmap 'a 'a) = f - $(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2) - $(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2 - $(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b)) - -For functions, the type parameter 'a can occur in a contravariant position, -which means we need to derive a function like: - - cofmap :: (a -> b) -> (f b -> f a) - -This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case: - - $(cofmap 'a 'b) = \x -> x -- when b does not contain a - $(cofmap 'a 'a) = error "type variable in contravariant position" - $(cofmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2) - $(cofmap 'a '[b]) = map $(cofmap 'a 'b) - $(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2 - $(cofmap 'a '(b -> c)) = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b)) - -Note that the code produced by $(fmap _ _) is always a higher order function, -with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern -matching on the type, this means create a lambda function (see the (,) case above). -The resulting code for fmap can look a bit weird, for example: - - data X a = X (a,Int) - -- generated instance - instance Functor X where - fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x - -The optimizer should be able to simplify this code by simple inlining. - -An older version of the deriving code tried to avoid these applied -lambda functions by producing a meta level function. But the function to -be mapped, `f`, is a function on the code level, not on the meta level, -so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion. -It is better to produce too many lambdas than to eta expand, see ticket #7436. --} - -gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) -gen_Functor_binds loc tycon - = (listToBag [fmap_bind, replace_bind], emptyBag) - where - data_cons = tyConDataCons tycon - fmap_name = L loc fmap_RDR - fmap_bind = mkRdrFunBind fmap_name fmap_eqns - fmap_match_ctxt = mkPrefixFunRhs fmap_name - - fmap_eqn con = flip evalState bs_RDRs $ - match_for_con fmap_match_ctxt [f_Pat] con =<< parts - where - parts = sequence $ foldDataConArgs ft_fmap con - - fmap_eqns - | null data_cons = [mkSimpleMatch fmap_match_ctxt - [nlWildPat, nlWildPat] - (error_Expr "Void fmap")] - | otherwise = map fmap_eqn data_cons - - ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName)) - ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x - -- fmap f = \x -> x - , ft_var = return f_Expr - -- fmap f = f - , ft_fun = \g h -> do - gg <- g - hh <- h - mkSimpleLam2 $ \x b -> return $ - nlHsApp hh (nlHsApp x (nlHsApp gg b)) - -- fmap f = \x b -> h (x (g b)) - , ft_tup = \t gs -> do - gg <- sequence gs - mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg - -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..) - , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g - -- fmap f = fmap g - , ft_forall = \_ g -> g - , ft_bad_app = panic "in other argument" - , ft_co_var = panic "contravariant" } - - -- See Note [deriving <$] - replace_name = L loc replace_RDR - replace_bind = mkRdrFunBind replace_name replace_eqns - replace_match_ctxt = mkPrefixFunRhs replace_name - - replace_eqn con = flip evalState bs_RDRs $ - match_for_con replace_match_ctxt [z_Pat] con =<< parts - where - parts = traverse (fmap replace) $ foldDataConArgs ft_replace con - - replace_eqns - | null data_cons = [mkSimpleMatch replace_match_ctxt - [nlWildPat, nlWildPat] - (error_Expr "Void <$")] - | otherwise = map replace_eqn data_cons - - ft_replace :: FFoldType (State [RdrName] Replacer) - ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x - -- (p <$) = \x -> x - , ft_var = fmap Immediate $ mkSimpleLam $ \_ -> return z_Expr - -- (p <$) = const p - , ft_fun = \g h -> do - gg <- replace <$> g - hh <- replace <$> h - fmap Nested $ mkSimpleLam2 $ \x b -> return $ - nlHsApp hh (nlHsApp x (nlHsApp gg b)) - -- (<$) p = \x b -> h (x (g b)) - , ft_tup = \t gs -> do - gg <- traverse (fmap replace) gs - fmap Nested . mkSimpleLam $ - mkSimpleTupleCase (match_for_con CaseAlt) t gg - -- (p <$) = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..) - , ft_ty_app = \_ gm -> do - g <- gm - case g of - Nested g' -> pure . Nested $ - nlHsApp fmap_Expr $ g' - Immediate _ -> pure . Nested $ - nlHsApp replace_Expr z_Expr - -- (p <$) = fmap (p <$) - , ft_forall = \_ g -> g - , ft_bad_app = panic "in other argument" - , ft_co_var = panic "contravariant" } - - -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... - match_for_con :: HsMatchContext RdrName - -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName] - -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) - match_for_con ctxt = mkSimpleConMatch ctxt $ - \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 .. - --- See Note [deriving <$] -data Replacer = Immediate {replace :: LHsExpr RdrName} - | Nested {replace :: LHsExpr RdrName} - -{- Note [deriving <$] - ~~~~~~~~~~~~~~~~~~ - -We derive the definition of <$. Allowing this to take the default definition -can lead to memory leaks: mapping over a structure with a constant function can -fill the result structure with trivial thunks that retain the values from the -original structure. The simplifier seems to handle this all right for simple -types, but not for recursive ones. Consider - -data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor - --- fmap _ Tip = Tip --- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r) - -Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that -simplifies no further. Why is that? `fmap` is defined recursively, so GHC -cannot inline it. The static argument transformation would turn the definition -into a non-recursive one - --- fmap f = go where --- go Tip = Tip --- go (Bin l v r) = Bin (go l) (f v) (go r) - -which GHC could inline, producing an efficient definion of `<$`. But there are -several problems. First, GHC does not perform the static argument transformation -by default, even with -O2. Second, even when it does perform the static argument -transformation, it does so only when there are at least two static arguments, -which is not the case for fmap. Finally, when the type in question is -non-regular, such as - -data Nesty a = Z a | S (Nesty a) (Nest (a, a)) - -the function argument is no longer (entirely) static, so the static argument -transformation will do nothing for us. - -Applying the default definition of `<$` will produce a tree full of thunks that -look like ((\_ -> x) x0), which represents unnecessary thunk allocation and -also retention of the previous value, potentially leaking memory. Instead, we -derive <$ separately. Two aspects are different from fmap: the case of the -sought type variable (ft_var) and the case of a type application (ft_ty_app). -The interesting one is ft_ty_app. We have to distinguish two cases: the -"immediate" case where the type argument *is* the sought type variable, and -the "nested" case where the type argument *contains* the sought type variable. - -The immediate case: - -Suppose we have - -data Imm a = Imm (F ... a) - -Then we want to define - -x <$ Imm q = Imm (x <$ q) - -The nested case: - -Suppose we have - -data Nes a = Nes (F ... (G a)) - -Then we want to define - -x <$ Nes q = Nes (fmap (x <$) q) - -We use the Replacer type to tag whether the expression derived for applying -<$ to the last type variable was the ft_var case (immediate) or one of the -others (letting ft_forall pass through as usual). - -We could, but do not, give tuples special treatment to improve efficiency -in some cases. Suppose we have - -data Nest a = Z a | S (Nest (a,a)) - -The optimal definition would be - -x <$ Z _ = Z x -x <$ S t = S ((x, x) <$ t) - -which produces a result with maximal internal sharing. The reason we do not -attempt to treat this case specially is that we have no way to give -user-provided tuple-like types similar treatment. If the user changed the -definition to - -data Pair a = Pair a a -data Nest a = Z a | S (Nest (Pair a)) - -they would experience a surprising degradation in performance. -} - - -{- -Utility functions related to Functor deriving. - -Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse. -This function works like a fold: it makes a value of type 'a' in a bottom up way. --} - --- Generic traversal for Functor deriving --- See Note [FFoldType and functorLikeTraverse] -data FFoldType a -- Describes how to fold over a Type in a functor like way - = FT { ft_triv :: a - -- ^ Does not contain variable - , ft_var :: a - -- ^ The variable itself - , ft_co_var :: a - -- ^ The variable itself, contravariantly - , ft_fun :: a -> a -> a - -- ^ Function type - , ft_tup :: TyCon -> [a] -> a - -- ^ Tuple type - , ft_ty_app :: Type -> a -> a - -- ^ Type app, variable only in last argument - , ft_bad_app :: a - -- ^ Type app, variable other than in last argument - , ft_forall :: TcTyVar -> a -> a - -- ^ Forall type - } - -functorLikeTraverse :: forall a. - TyVar -- ^ Variable to look for - -> FFoldType a -- ^ How to fold - -> Type -- ^ Type to process - -> a -functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar - , ft_co_var = caseCoVar, ft_fun = caseFun - , ft_tup = caseTuple, ft_ty_app = caseTyApp - , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) - ty - = fst (go False ty) - where - go :: Bool -- Covariant or contravariant context - -> Type - -> (a, Bool) -- (result of type a, does type contain var) - - go co ty | Just ty' <- tcView ty = go co ty' - go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) - go co (FunTy x y) | isPredTy x = go co y - | xc || yc = (caseFun xr yr,True) - where (xr,xc) = go (not co) x - (yr,yc) = go co y - go co (AppTy x y) | xc = (caseWrongArg, True) - | yc = (caseTyApp x yr, True) - where (_, xc) = go co x - (yr,yc) = go co y - go co ty@(TyConApp con args) - | not (or xcs) = (caseTrivial, False) -- Variable does not occur - -- At this point we know that xrs, xcs is not empty, - -- and at least one xr is True - | isTupleTyCon con = (caseTuple con xrs, True) - | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty - | Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty - = (caseTyApp fun_ty (last xrs), True) - | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function) - where - -- When folding over an unboxed tuple, we must explicitly drop the - -- runtime rep arguments, or else GHC will generate twice as many - -- variables in a unboxed tuple pattern match and expression as it - -- actually needs. See Trac #12399 - (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args)) - go co (ForAllTy (TvBndr v vis) x) - | isVisibleArgFlag vis = panic "unexpected visible binder" - | v /= var && xc = (caseForAll v xr,True) - where (xr,xc) = go co x - - go _ _ = (caseTrivial,False) - --- Return all syntactic subterms of ty that contain var somewhere --- These are the things that should appear in instance constraints -deepSubtypesContaining :: TyVar -> Type -> [TcType] -deepSubtypesContaining tv - = functorLikeTraverse tv - (FT { ft_triv = [] - , ft_var = [] - , ft_fun = (++) - , ft_tup = \_ xs -> concat xs - , ft_ty_app = (:) - , ft_bad_app = panic "in other argument" - , ft_co_var = panic "contravariant" - , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs }) - - -foldDataConArgs :: FFoldType a -> DataCon -> [a] --- Fold over the arguments of the datacon -foldDataConArgs ft con - = map foldArg (dataConOrigArgTys con) - where - foldArg - = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of - Just tv -> functorLikeTraverse tv ft - Nothing -> const (ft_triv ft) - -- If we are deriving Foldable for a GADT, there is a chance that the last - -- type variable in the data type isn't actually a type variable at all. - -- (for example, this can happen if the last type variable is refined to - -- be a concrete type such as Int). If the last type variable is refined - -- to be a specific type, then getTyVar_maybe will return Nothing. - -- See Note [DeriveFoldable with ExistentialQuantification] - -- - -- The kind checks have ensured the last type parameter is of kind *. - --- Make a HsLam using a fresh variable from a State monad -mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)) - -> State [RdrName] (LHsExpr RdrName) --- (mkSimpleLam fn) returns (\x. fn(x)) -mkSimpleLam lam = do - (n:names) <- get - put names - body <- lam (nlHsVar n) - return (mkHsLam [nlVarPat n] body) - -mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName - -> State [RdrName] (LHsExpr RdrName)) - -> State [RdrName] (LHsExpr RdrName) -mkSimpleLam2 lam = do - (n1:n2:names) <- get - put names - body <- lam (nlHsVar n1) (nlHsVar n2) - return (mkHsLam [nlVarPat n1,nlVarPat n2] body) - --- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --- --- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in --- which the LHS pattern-matches on @extra_pats@, followed by a match on the --- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ --- and its arguments, applying an expression (from @insides@) to each of the --- respective arguments of @con@. -mkSimpleConMatch :: Monad m => HsMatchContext RdrName - -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName)) - -> [LPat RdrName] - -> DataCon - -> [LHsExpr RdrName] - -> m (LMatch RdrName (LHsExpr RdrName)) -mkSimpleConMatch ctxt fold extra_pats con insides = do - let con_name = getRdrName con - let vars_needed = takeList insides as_RDRs - let bare_pat = nlConVarPat con_name vars_needed - let pat = if null vars_needed - then bare_pat - else nlParPat bare_pat - rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed)) - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) - --- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" --- --- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to --- 'mkSimpleConMatch', with two key differences: --- --- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a --- @[LHsExpr RdrName]@. This is because it filters out the expressions --- corresponding to arguments whose types do not mention the last type --- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the --- 'Nothing' elements of @insides@). --- --- 2. @fold@ takes an expression as its first argument instead of a --- constructor name. This is because it uses a specialized --- constructor function expression that only takes as many parameters as --- there are argument types that mention the last type variable. --- --- See Note [Generated code for DeriveFoldable and DeriveTraversable] -mkSimpleConMatch2 :: Monad m - => HsMatchContext RdrName - -> (LHsExpr RdrName -> [LHsExpr RdrName] - -> m (LHsExpr RdrName)) - -> [LPat RdrName] - -> DataCon - -> [Maybe (LHsExpr RdrName)] - -> m (LMatch RdrName (LHsExpr RdrName)) -mkSimpleConMatch2 ctxt fold extra_pats con insides = do - let con_name = getRdrName con - vars_needed = takeList insides as_RDRs - pat = nlConVarPat con_name vars_needed - -- Make sure to zip BEFORE invoking catMaybes. We want the variable - -- indicies in each expression to match up with the argument indices - -- in con_expr (defined below). - exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i) - insides (map nlHsVar vars_needed) - -- An element of argTysTyVarInfo is True if the constructor argument - -- with the same index has a type which mentions the last type - -- variable. - argTysTyVarInfo = map isJust insides - (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs - - con_expr - | null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar - | otherwise = - let bs = filterByList argTysTyVarInfo bs_RDRs - vars = filterByLists argTysTyVarInfo - (map nlHsVar bs_RDRs) - (map nlHsVar as_RDRs) - in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) - - rhs <- fold con_expr exps - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) - --- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" -mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a] - -> m (LMatch RdrName (LHsExpr RdrName))) - -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName) -mkSimpleTupleCase match_for_con tc insides x - = do { let data_con = tyConSingleDataCon tc - ; match <- match_for_con [] data_con insides - ; return $ nlHsCase x [match] } - -{- -************************************************************************ -* * - Foldable instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html - -* * -************************************************************************ - -Deriving Foldable instances works the same way as Functor instances, -only Foldable instances are not possible for function types at all. -Given (data T a = T a a (T a) deriving Foldable), we get: - - instance Foldable T where - foldr f z (T x1 x2 x3) = - $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) ) - --XDeriveFoldable is different from -XDeriveFunctor in that it filters out -arguments to the constructor that would produce useless code in a Foldable -instance. For example, the following datatype: - - data Foo a = Foo Int a Int deriving Foldable - -would have the following generated Foldable instance: - - instance Foldable Foo where - foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2 - -since neither of the two Int arguments are folded over. - -The cases are: - - $(foldr 'a 'a) = f - $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z ) - $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2 - -Note that the arguments to the real foldr function are the wrong way around, -since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). - -One can envision a case for types that don't contain the last type variable: - - $(foldr 'a 'b) = \x z -> z -- when b does not contain a - -But this case will never materialize, since the aforementioned filtering -removes all such types from consideration. -See Note [Generated code for DeriveFoldable and DeriveTraversable]. - -Foldable instances differ from Functor and Traversable instances in that -Foldable instances can be derived for data types in which the last type -variable is existentially quantified. In particular, if the last type variable -is refined to a more specific type in a GADT: - - data GADT a where - G :: a ~ Int => a -> G Int - -then the deriving machinery does not attempt to check that the type a contains -Int, since it is not syntactically equal to a type variable. That is, the -derived Foldable instance for GADT is: - - instance Foldable GADT where - foldr _ z (GADT _) = z - -See Note [DeriveFoldable with ExistentialQuantification]. - --} - -gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) -gen_Foldable_binds loc tycon - = (listToBag [foldr_bind, foldMap_bind], emptyBag) - where - data_cons = tyConDataCons tycon - - foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns - eqns = map foldr_eqn data_cons - foldr_eqn con - = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_foldr con - - foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons) - foldMap_eqn con - = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_foldMap con - - -- Yields 'Just' an expression if we're folding over a type that mentions - -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. - -- See Note [FFoldType and functorLikeTraverse] - ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName))) - ft_foldr - = FT { ft_triv = return Nothing - -- foldr f = \x z -> z - , ft_var = return $ Just f_Expr - -- foldr f = f - , ft_tup = \t g -> do - gg <- sequence g - lam <- mkSimpleLam2 $ \x z -> - mkSimpleTupleCase (match_foldr z) t gg x - return (Just lam) - -- foldr f = (\x z -> case x of ...) - , ft_ty_app = \_ g -> do - gg <- g - mapM (\gg' -> mkSimpleLam2 $ \x z -> return $ - nlHsApps foldable_foldr_RDR [gg',z,x]) gg - -- foldr f = (\x z -> foldr g z x) - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant" - , ft_fun = panic "function" - , ft_bad_app = panic "in other argument" } - - match_foldr :: LHsExpr RdrName - -> [LPat RdrName] - -> DataCon - -> [Maybe (LHsExpr RdrName)] - -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) - match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs) - where - -- g1 v1 (g2 v2 (.. z)) - mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName - mkFoldr = foldr nlHsApp z - - -- See Note [FFoldType and functorLikeTraverse] - ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName))) - ft_foldMap - = FT { ft_triv = return Nothing - -- foldMap f = \x -> mempty - , ft_var = return (Just f_Expr) - -- foldMap f = f - , ft_tup = \t g -> do - gg <- sequence g - lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg - return (Just lam) - -- foldMap f = \x -> case x of (..,) - , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g - -- foldMap f = foldMap g - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant" - , ft_fun = panic "function" - , ft_bad_app = panic "in other argument" } - - match_foldMap :: [LPat RdrName] - -> DataCon - -> [Maybe (LHsExpr RdrName)] - -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) - match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs) - where - -- mappend v1 (mappend v2 ..) - mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName - mkFoldMap [] = mempty_Expr - mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs - -{- -************************************************************************ -* * - Traversable instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html -* * -************************************************************************ - -Again, Traversable is much like Functor and Foldable. - -The cases are: - - $(traverse 'a 'a) = f - $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> - liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2) - $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2 - -Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types -do not mention the last type parameter. Therefore, the following datatype: - - data Foo a = Foo Int a Int - -would have the following derived Traversable instance: - - instance Traversable Foo where - traverse f (Foo x1 x2 x3) = - fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 ) - -since the two Int arguments do not produce any effects in a traversal. - -One can envision a case for types that do not mention the last type parameter: - - $(traverse 'a 'b) = pure -- when b does not contain a - -But this case will never materialize, since the aforementioned filtering -removes all such types from consideration. -See Note [Generated code for DeriveFoldable and DeriveTraversable]. --} - -gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) -gen_Traversable_binds loc tycon - = (unitBag traverse_bind, emptyBag) - where - data_cons = tyConDataCons tycon - - traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns - eqns = map traverse_eqn data_cons - traverse_eqn con - = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_trav con - - -- Yields 'Just' an expression if we're folding over a type that mentions - -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. - -- See Note [FFoldType and functorLikeTraverse] - ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName))) - ft_trav - = FT { ft_triv = return Nothing - -- traverse f = pure x - , ft_var = return (Just f_Expr) - -- traverse f = f x - , ft_tup = \t gs -> do - gg <- sequence gs - lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg - return (Just lam) - -- traverse f = \x -> case x of (a1,a2,..) -> - -- liftA2 (,,) (g1 a1) (g2 a2) <*> .. - , ft_ty_app = \_ g -> fmap (nlHsApp traverse_Expr) <$> g - -- traverse f = traverse g - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant" - , ft_fun = panic "function" - , ft_bad_app = panic "in other argument" } - - -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) - -- (g2 a2) <*> ... - match_for_con :: [LPat RdrName] - -> DataCon - -> [Maybe (LHsExpr RdrName)] - -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) - match_for_con = mkSimpleConMatch2 CaseAlt $ - \con xs -> return (mkApCon con xs) - where - -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. - mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName - mkApCon con [] = nlHsApps pure_RDR [con] - mkApCon con [x] = nlHsApps fmap_RDR [con,x] - mkApCon con (x1:x2:xs) = - foldl appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs - where appAp x y = nlHsApps ap_RDR [x,y] - ------------------------------------------------------------------------ - -f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr, - traverse_Expr :: LHsExpr RdrName -f_Expr = nlHsVar f_RDR -z_Expr = nlHsVar z_RDR -fmap_Expr = nlHsVar fmap_RDR -replace_Expr = nlHsVar replace_RDR -mempty_Expr = nlHsVar mempty_RDR -foldMap_Expr = nlHsVar foldMap_RDR -traverse_Expr = nlHsVar traverse_RDR - -f_RDR, z_RDR :: RdrName -f_RDR = mkVarUnqual (fsLit "f") -z_RDR = mkVarUnqual (fsLit "z") - -as_RDRs, bs_RDRs :: [RdrName] -as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] - -f_Pat, z_Pat :: LPat RdrName -f_Pat = nlVarPat f_RDR -z_Pat = nlVarPat z_RDR - -{- -Note [DeriveFoldable with ExistentialQuantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Functor and Traversable instances can only be derived for data types whose -last type parameter is truly universally polymorphic. For example: - - data T a b where - T1 :: b -> T a b -- YES, b is unconstrained - T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b) - T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int) - T4 :: Int -> T a Int -- NO, this is just like T3 - T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even - -- though a is existential - T6 :: Int -> T Int b -- YES, b is unconstrained - -For Foldable instances, however, we can completely lift the constraint that -the last type parameter be truly universally polymorphic. This means that T -(as defined above) can have a derived Foldable instance: - - instance Foldable (T a) where - foldr f z (T1 b) = f b z - foldr f z (T2 b) = f b z - foldr f z (T3 b) = f b z - foldr f z (T4 b) = z - foldr f z (T5 a b) = f b z - foldr f z (T6 a) = z - - foldMap f (T1 b) = f b - foldMap f (T2 b) = f b - foldMap f (T3 b) = f b - foldMap f (T4 b) = mempty - foldMap f (T5 a b) = f b - foldMap f (T6 a) = mempty - -In a Foldable instance, it is safe to fold over an occurrence of the last type -parameter that is not truly universally polymorphic. However, there is a bit -of subtlety in determining what is actually an occurrence of a type parameter. -T3 and T4, as defined above, provide one example: - - data T a b where - ... - T3 :: b ~ Int => b -> T a b - T4 :: Int -> T a Int - ... - - instance Foldable (T a) where - ... - foldr f z (T3 b) = f b z - foldr f z (T4 b) = z - ... - foldMap f (T3 b) = f b - foldMap f (T4 b) = mempty - ... - -Notice that the argument of T3 is folded over, whereas the argument of T4 is -not. This is because we only fold over constructor arguments that -syntactically mention the universally quantified type parameter of that -particular data constructor. See foldDataConArgs for how this is implemented. - -As another example, consider the following data type. The argument of each -constructor has the same type as the last type parameter: - - data E a where - E1 :: (a ~ Int) => a -> E a - E2 :: Int -> E Int - E3 :: (a ~ Int) => a -> E Int - E4 :: (a ~ Int) => Int -> E a - -Only E1's argument is an occurrence of a universally quantified type variable -that is syntactically equivalent to the last type parameter, so only E1's -argument will be be folded over in a derived Foldable instance. - -See Trac #10447 for the original discussion on this feature. Also see -https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor -for a more in-depth explanation. - -Note [FFoldType and functorLikeTraverse] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deriving Functor, Foldable, and Traversable all require generating expressions -which perform an operation on each argument of a data constructor depending -on the argument's type. In particular, a generated operation can be different -depending on whether the type mentions the last type variable of the datatype -(e.g., if you have data T a = MkT a Int, then a generated foldr expression would -fold over the first argument of MkT, but not the second). - -This pattern is abstracted with the FFoldType datatype, which provides hooks -for the user to specify how a constructor argument should be folded when it -has a type with a particular "shape". The shapes are as follows (assume that -a is the last type variable in a given datatype): - -* ft_triv: The type does not mention the last type variable at all. - Examples: Int, b - -* ft_var: The type is syntactically equal to the last type variable. - Moreover, the type appears in a covariant position (see - the Deriving Functor instances section of the user's guide - for an in-depth explanation of covariance vs. contravariance). - Example: a (covariantly) - -* ft_co_var: The type is syntactically equal to the last type variable. - Moreover, the type appears in a contravariant position. - Example: a (contravariantly) - -* ft_fun: A function type which mentions the last type variable in - the argument position, result position or both. - Examples: a -> Int, Int -> a, Maybe a -> [a] - -* ft_tup: A tuple type which mentions the last type variable in at least - one of its fields. The TyCon argument of ft_tup represents the - particular tuple's type constructor. - Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #) - -* ft_ty_app: A type is being applied to the last type parameter, where the - applied type does not mention the last type parameter (if it - did, it would fall under ft_bad_app). The Type argument to - ft_ty_app represents the applied type. - - Note that functions, tuples, and foralls are distinct cases - and take precedence of ft_ty_app. (For example, (Int -> a) would - fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a). - Examples: Maybe a, Either b a - -* ft_bad_app: A type application uses the last type parameter in a position - other than the last argument. This case is singled out because - Functor, Foldable, and Traversable instances cannot be derived - for datatypes containing arguments with such types. - Examples: Either a Int, Const a b - -* ft_forall: A forall'd type mentions the last type parameter on its right- - hand side (and is not quantified on the left-hand side). This - case is present mostly for plumbing purposes. - Example: forall b. Either b a - -If FFoldType describes a strategy for folding subcomponents of a Type, then -functorLikeTraverse is the function that applies that strategy to the entirety -of a Type, returning the final folded-up result. - -foldDataConArgs applies functorLikeTraverse to every argument type of a -constructor, returning a list of the fold results. This makes foldDataConArgs -a natural way to generate the subexpressions in a generated fmap, foldr, -foldMap, or traverse definition (the subexpressions must then be combined in -a method-specific fashion to form the final generated expression). - -Deriving Generic1 also does validity checking by looking for the last type -variable in certain positions of a constructor's argument types, so it also -uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics. - -Note [Generated code for DeriveFoldable and DeriveTraversable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on -that of -XDeriveFunctor. However, there an important difference between deriving -the former two typeclasses and the latter one, which is best illustrated by the -following scenario: - - data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable) - -The generated code for the Functor instance is straightforward: - - instance Functor WithInt where - fmap f (WithInt a i) = WithInt (f a) i - -But if we use too similar of a strategy for deriving the Foldable and -Traversable instances, we end up with this code: - - instance Foldable WithInt where - foldMap f (WithInt a i) = f a <> mempty - - instance Traversable WithInt where - traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i - -This is unsatisfying for two reasons: - -1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure - expects an argument whose type is of kind *. This effectively prevents - Traversable from being derived for any datatype with an unlifted argument - type (Trac #11174). - -2. The generated code contains superfluous expressions. By the Monoid laws, - we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can - reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)). - -We can fix both of these issues by incorporating a slight twist to the usual -algorithm that we use for -XDeriveFunctor. The differences can be summarized -as follows: - -1. In the generated expression, we only fold over arguments whose types - mention the last type parameter. Any other argument types will simply - produce useless 'mempty's or 'pure's, so they can be safely ignored. - -2. In the case of -XDeriveTraversable, instead of applying ConName, - we apply (\b_i ... b_k -> ConName a_1 ... a_n), where - - * ConName has n arguments - * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond - to the arguments whose types mention the last type parameter. As a - consequence, taking the difference of {a_1, ..., a_n} and - {b_i, ..., b_k} yields the all the argument values of ConName whose types - do not mention the last type parameter. Note that [i, ..., k] is a - strictly increasing—but not necessarily consecutive—integer sequence. - - For example, the datatype - - data Foo a = Foo Int a Int a - - would generate the following Traversable instance: - - instance Traversable Foo where - traverse f (Foo a1 a2 a3 a4) = - fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4 - -Technically, this approach would also work for -XDeriveFunctor as well, but we -decide not to do so because: - -1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a)) - instead of (WithInt (f a) i). - -2. There would be certain datatypes for which the above strategy would - generate Functor code that would fail to typecheck. For example: - - data Bar f a = Bar (forall f. Functor f => f a) deriving Functor - - With the conventional algorithm, it would generate something like: - - fmap f (Bar a) = Bar (fmap f a) - - which typechecks. But with the strategy mentioned above, it would generate: - - fmap f (Bar a) = (\b -> Bar b) (fmap f a) - - which does not typecheck, since GHC cannot unify the rank-2 type variables - in the types of b and (fmap f a). --} diff --git a/typecheck/TcGenGenerics.hs b/typecheck/TcGenGenerics.hs deleted file mode 100644 --- a/typecheck/TcGenGenerics.hs +++ /dev/null @@ -1,1010 +0,0 @@ -{- -(c) The University of Glasgow 2011 - - -The deriving code for the Generic class -(equivalent to the code in TcGenDeriv, for other classes) --} - -{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} - -module TcGenGenerics (canDoGenerics, canDoGenerics1, - GenericKind(..), - gen_Generic_binds, get_gen1_constrained_tys) where - -import HsSyn -import Type -import TcType -import TcGenDeriv -import TcGenFunctor -import DataCon -import TyCon -import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) -import FamInst -import Module ( moduleName, moduleNameFS - , moduleUnitId, unitIdFS, getModule ) -import IfaceEnv ( newGlobalBinder ) -import Name hiding ( varName ) -import RdrName -import BasicTypes -import TysPrim -import TysWiredIn -import PrelNames -import TcEnv -import TcRnMonad -import HscTypes -import ErrUtils( Validity(..), andValid ) -import SrcLoc -import Bag -import VarEnv -import VarSet (elemVarSet) -import Outputable -import FastString -import Util - -import Control.Monad (mplus) -import Data.List (zip4, partition) -import Data.Maybe (isJust) - -#include "HsVersions.h" - -{- -************************************************************************ -* * -\subsection{Bindings for the new generic deriving mechanism} -* * -************************************************************************ - -For the generic representation we need to generate: -\begin{itemize} -\item A Generic instance -\item A Rep type instance -\item Many auxiliary datatypes and instances for them (for the meta-information) -\end{itemize} --} - -gen_Generic_binds :: GenericKind -> TyCon -> [Type] - -> TcM (LHsBinds RdrName, FamInst) -gen_Generic_binds gk tc inst_tys = do - repTyInsts <- tc_mkRepFamInsts gk tc inst_tys - return (mkBindsRep gk tc, repTyInsts) - -{- -************************************************************************ -* * -\subsection{Generating representation types} -* * -************************************************************************ --} - -get_gen1_constrained_tys :: TyVar -> Type -> [Type] --- called by TcDeriv.inferConstraints; generates a list of types, each of which --- must be a Functor in order for the Generic1 instance to work. -get_gen1_constrained_tys argVar - = argTyFold argVar $ ArgTyAlg { ata_rec0 = const [] - , ata_par1 = [], ata_rec1 = const [] - , ata_comp = (:) } - -{- - -Note [Requirements for deriving Generic and Rep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In the following, T, Tfun, and Targ are "meta-variables" ranging over type -expressions. - -(Generic T) and (Rep T) are derivable for some type expression T if the -following constraints are satisfied. - - (a) D is a type constructor *value*. In other words, D is either a type - constructor or it is equivalent to the head of a data family instance (up to - alpha-renaming). - - (b) D cannot have a "stupid context". - - (c) The right-hand side of D cannot include existential types, universally - quantified types, or "exotic" unlifted types. An exotic unlifted type - is one which is not listed in the definition of allowedUnliftedTy - (i.e., one for which we have no representation type). - See Note [Generics and unlifted types] - - (d) T :: *. - -(Generic1 T) and (Rep1 T) are derivable for some type expression T if the -following constraints are satisfied. - - (a),(b),(c) As above. - - (d) T must expect arguments, and its last parameter must have kind *. - - We use `a' to denote the parameter of D that corresponds to the last - parameter of T. - - (e) For any type-level application (Tfun Targ) in the right-hand side of D - where the head of Tfun is not a tuple constructor: - - (b1) `a' must not occur in Tfun. - - (b2) If `a' occurs in Targ, then Tfun :: * -> *. - --} - -canDoGenerics :: TyCon -> Validity --- canDoGenerics determines if Generic/Rep can be derived. --- --- Check (a) from Note [Requirements for deriving Generic and Rep] is taken --- care of because canDoGenerics is applied to rep tycons. --- --- It returns IsValid if deriving is possible. It returns (NotValid reason) --- if not. -canDoGenerics tc - = mergeErrors ( - -- Check (b) from Note [Requirements for deriving Generic and Rep]. - (if (not (null (tyConStupidTheta tc))) - then (NotValid (tc_name <+> text "must not have a datatype context")) - else IsValid) - -- See comment below - : (map bad_con (tyConDataCons tc))) - where - -- The tc can be a representation tycon. When we want to display it to the - -- user (in an error message) we should print its parent - tc_name = ppr $ case tyConFamInst_maybe tc of - Just (ptc, _) -> ptc - _ -> tc - - -- Check (c) from Note [Requirements for deriving Generic and Rep]. - -- - -- If any of the constructors has an exotic unlifted type as argument, - -- then we can't build the embedding-projection pair, because - -- it relies on instantiating *polymorphic* sum and product types - -- at the argument types of the constructors - bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc)) - then (NotValid (ppr dc <+> text - "must not have exotic unlifted or polymorphic arguments")) - else (if (not (isVanillaDataCon dc)) - then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) - else IsValid) - - -- Nor can we do the job if it's an existential data constructor, - -- Nor if the args are polymorphic types (I don't think) - bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty)) - || not (isTauTy ty) - --- Returns True the Type argument is an unlifted type which has a --- corresponding generic representation type. For example, --- (allowedUnliftedTy Int#) would return True since there is the UInt --- representation type. -allowedUnliftedTy :: Type -> Bool -allowedUnliftedTy = isJust . unboxedRepRDRs - -mergeErrors :: [Validity] -> Validity -mergeErrors [] = IsValid -mergeErrors (NotValid s:t) = case mergeErrors t of - IsValid -> NotValid s - NotValid s' -> NotValid (s <> text ", and" $$ s') -mergeErrors (IsValid : t) = mergeErrors t - --- A datatype used only inside of canDoGenerics1. It's the result of analysing --- a type term. -data Check_for_CanDoGenerics1 = CCDG1 - { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in - -- this type? - , _ccdg1_errors :: Validity -- errors generated by this type - } - -{- - -Note [degenerate use of FFoldType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We use foldDataConArgs here only for its ability to treat tuples -specially. foldDataConArgs also tracks covariance (though it assumes all -higher-order type parameters are covariant) and has hooks for special handling -of functions and polytypes, but we do *not* use those. - -The key issue is that Generic1 deriving currently offers no sophisticated -support for functions. For example, we cannot handle - - data F a = F ((a -> Int) -> Int) - -even though a is occurring covariantly. - -In fact, our rule is harsh: a is simply not allowed to occur within the first -argument of (->). We treat (->) the same as any other non-tuple tycon. - -Unfortunately, this means we have to track "the parameter occurs in this type" -explicitly, even though foldDataConArgs is also doing this internally. - --} - --- canDoGenerics1 determines if a Generic1/Rep1 can be derived. --- --- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep] --- are taken care of by the call to canDoGenerics. --- --- It returns IsValid if deriving is possible. It returns (NotValid reason) --- if not. -canDoGenerics1 :: TyCon -> Validity -canDoGenerics1 rep_tc = - canDoGenerics rep_tc `andValid` additionalChecks - where - additionalChecks - -- check (d) from Note [Requirements for deriving Generic and Rep] - | null (tyConTyVars rep_tc) = NotValid $ - text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters" - - | otherwise = mergeErrors $ concatMap check_con data_cons - - data_cons = tyConDataCons rep_tc - check_con con = case check_vanilla con of - j@(NotValid {}) -> [j] - IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con - - bad :: DataCon -> SDoc -> SDoc - bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg - - check_vanilla :: DataCon -> Validity - check_vanilla con | isVanillaDataCon con = IsValid - | otherwise = NotValid (bad con existential) - - bmzero = CCDG1 False IsValid - bmbad con s = CCDG1 True $ NotValid $ bad con s - bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) - - -- check (e) from Note [Requirements for deriving Generic and Rep] - -- See also Note [degenerate use of FFoldType] - ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1 - ft_check con = FT - { ft_triv = bmzero - - , ft_var = caseVar, ft_co_var = caseVar - - -- (component_0,component_1,...,component_n) - , ft_tup = \_ components -> if any _ccdg1_hasParam (init components) - then bmbad con wrong_arg - else foldr bmplus bmzero components - - -- (dom -> rng), where the head of ty is not a tuple tycon - , ft_fun = \dom rng -> -- cf #8516 - if _ccdg1_hasParam dom - then bmbad con wrong_arg - else bmplus dom rng - - -- (ty arg), where head of ty is neither (->) nor a tuple constructor and - -- the parameter of interest does not occur in ty - , ft_ty_app = \_ arg -> arg - - , ft_bad_app = bmbad con wrong_arg - , ft_forall = \_ body -> body -- polytypes are handled elsewhere - } - where - caseVar = CCDG1 True IsValid - - - existential = text "must not have existential arguments" - wrong_arg = text "applies a type to an argument involving the last parameter" - $$ text "but the applied type is not of kind * -> *" - -{- -************************************************************************ -* * -\subsection{Generating the RHS of a generic default method} -* * -************************************************************************ --} - -type US = Int -- Local unique supply, just a plain Int -type Alt = (LPat RdrName, LHsExpr RdrName) - --- GenericKind serves to mark if a datatype derives Generic (Gen0) or --- Generic1 (Gen1). -data GenericKind = Gen0 | Gen1 - --- as above, but with a payload of the TyCon's name for "the" parameter -data GenericKind_ = Gen0_ | Gen1_ TyVar - --- as above, but using a single datacon's name for "the" parameter -data GenericKind_DC = Gen0_DC | Gen1_DC TyVar - -forgetArgVar :: GenericKind_DC -> GenericKind -forgetArgVar Gen0_DC = Gen0 -forgetArgVar Gen1_DC{} = Gen1 - --- When working only within a single datacon, "the" parameter's name should --- match that datacon's name for it. -gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC -gk2gkDC Gen0_ _ = Gen0_DC -gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d - - --- Bindings for the Generic instance -mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName -mkBindsRep gk tycon = - unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn]) - `unionBags` - unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn]) - where - -- The topmost M1 (the datatype metadata) has the exact same type - -- across all cases of a from/to definition, and can be factored out - -- to save some allocations during typechecking. - -- See Note [Generics compilation speed tricks] - from_eqn = mkHsCaseAlt x_Pat $ mkM1_E - $ nlHsPar $ nlHsCase x_Expr from_matches - to_eqn = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches - - from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] - to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] - loc = srcLocSpan (getSrcLoc tycon) - datacons = tyConDataCons tycon - - (from01_RDR, to01_RDR) = case gk of - Gen0 -> (from_RDR, to_RDR) - Gen1 -> (from1_RDR, to1_RDR) - - -- Recurse over the sum first - from_alts, to_alts :: [Alt] - (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons - where gk_ = case gk of - Gen0 -> Gen0_ - Gen1 -> ASSERT(length tyvars >= 1) - Gen1_ (last tyvars) - where tyvars = tyConTyVars tycon - --------------------------------------------------------------------------------- --- The type synonym instance and synonym --- type instance Rep (D a b) = Rep_D a b --- type Rep_D a b = ...representation type for D ... --------------------------------------------------------------------------------- - -tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 - -> TyCon -- The type to generate representation for - -> [Type] -- The type(s) to which Generic(1) is applied - -- in the generated instance - -> TcM FamInst -- Generated representation0 coercion -tc_mkRepFamInsts gk tycon inst_tys = - -- Consider the example input tycon `D`, where data D a b = D_ a - -- Also consider `R:DInt`, where { data family D x y :: * -> * - -- ; data instance D Int a b = D_ a } - do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family) - fam_tc <- case gk of - Gen0 -> tcLookupTyCon repTyConName - Gen1 -> tcLookupTyCon rep1TyConName - - ; fam_envs <- tcGetFamInstEnvs - - ; let -- If the derived instance is - -- instance Generic (Foo x) - -- then: - -- `arg_ki` = *, `inst_ty` = Foo x :: * - -- - -- If the derived instance is - -- instance Generic1 (Bar x :: k -> *) - -- then: - -- `arg_k` = k, `inst_ty` = Bar x :: k -> * - (arg_ki, inst_ty) = case (gk, inst_tys) of - (Gen0, [inst_t]) -> (liftedTypeKind, inst_t) - (Gen1, [arg_k, inst_t]) -> (arg_k, inst_t) - _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys) - - ; let mbFamInst = tyConFamInst_maybe tycon - -- If we're examining a data family instance, we grab the parent - -- TyCon (ptc) and use it to determine the type arguments - -- (inst_args) for the data family *instance*'s type variables. - ptc = maybe tycon fst mbFamInst - (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd - $ tcSplitTyConApp inst_ty - - ; let -- `tyvars` = [a,b] - (tyvars, gk_) = case gk of - Gen0 -> (all_tyvars, Gen0_) - Gen1 -> ASSERT(not $ null all_tyvars) - (init all_tyvars, Gen1_ $ last all_tyvars) - where all_tyvars = tyConTyVars tycon - - -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; repTy <- tc_mkRepTy gk_ tycon arg_ki - - -- `rep_name` is a name we generate for the synonym - ; mod <- getModule - ; loc <- getSrcSpanM - ; let tc_occ = nameOccName (tyConName tycon) - rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ - ; rep_name <- newGlobalBinder mod rep_occ loc - - -- We make sure to substitute the tyvars with their user-supplied - -- type arguments before generating the Rep/Rep1 instance, since some - -- of the tyvars might have been instantiated when deriving. - -- See Note [Generating a correctly typed Rep instance]. - ; let env = zipTyEnv tyvars inst_args - in_scope = mkInScopeSet (tyCoVarsOfTypes inst_tys) - subst = mkTvSubst in_scope env - repTy' = substTy subst repTy - tcv' = tyCoVarsOfTypeList inst_ty - (tv', cv') = partition isTyVar tcv' - tvs' = toposortTyVars tv' - cvs' = toposortTyVars cv' - axiom = mkSingleCoAxiom Nominal rep_name tvs' cvs' - fam_tc inst_tys repTy' - - ; newFamInst SynFamilyInst axiom } - --------------------------------------------------------------------------------- --- Type representation --------------------------------------------------------------------------------- - --- | See documentation of 'argTyFold'; that function uses the fields of this --- type to interpret the structure of a type when that type is considered as an --- argument to a constructor that is being represented with 'Rep1'. -data ArgTyAlg a = ArgTyAlg - { ata_rec0 :: (Type -> a) - , ata_par1 :: a, ata_rec1 :: (Type -> a) - , ata_comp :: (Type -> a -> a) - } - --- | @argTyFold@ implements a generalised and safer variant of the @arg@ --- function from Figure 3 in . @arg@ --- is conceptually equivalent to: --- --- > arg t = case t of --- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t --- > App f [t'] | --- > representable1 f && --- > t' == argVar -> Rec1 f --- > App f [t'] | --- > representable1 f && --- > t' has tyvars -> f :.: (arg t') --- > _ -> Rec0 t --- --- where @argVar@ is the last type variable in the data type declaration we are --- finding the representation for. --- --- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to --- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and --- @:.:@. --- --- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for --- some data types. The problematic case is when @t@ is an application of a --- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the --- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in --- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some --- representable1 checks have been relaxed, and others were moved to --- @canDoGenerics1@. -argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a -argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, - ata_par1 = mkPar1, ata_rec1 = mkRec1, - ata_comp = mkComp}) = - -- mkRec0 is the default; use it if there is no interesting structure - -- (e.g. occurrences of parameters or recursive occurrences) - \t -> maybe (mkRec0 t) id $ go t where - go :: Type -> -- type to fold through - Maybe a -- the result (e.g. representation type), unless it's trivial - go t = isParam `mplus` isApp where - - isParam = do -- handles parameters - t' <- getTyVar_maybe t - Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter - else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0 - - isApp = do -- handles applications - (phi, beta) <- tcSplitAppTy_maybe t - - let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta - - -- Does it have no interesting structure to represent? - if not interesting then Nothing - else -- Is the argument the parameter? Special case for mkRec1. - if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi - else mkComp phi `fmap` go beta -- It must be a composition. - - -tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 - GenericKind_ - -- The type to generate representation for - -> TyCon - -- The kind of the representation type's argument - -- See Note [Handling kinds in a Rep instance] - -> Kind - -- Generated representation0 type - -> TcM Type -tc_mkRepTy gk_ tycon k = - do - d1 <- tcLookupTyCon d1TyConName - c1 <- tcLookupTyCon c1TyConName - s1 <- tcLookupTyCon s1TyConName - rec0 <- tcLookupTyCon rec0TyConName - rec1 <- tcLookupTyCon rec1TyConName - par1 <- tcLookupTyCon par1TyConName - u1 <- tcLookupTyCon u1TyConName - v1 <- tcLookupTyCon v1TyConName - plus <- tcLookupTyCon sumTyConName - times <- tcLookupTyCon prodTyConName - comp <- tcLookupTyCon compTyConName - uAddr <- tcLookupTyCon uAddrTyConName - uChar <- tcLookupTyCon uCharTyConName - uDouble <- tcLookupTyCon uDoubleTyConName - uFloat <- tcLookupTyCon uFloatTyConName - uInt <- tcLookupTyCon uIntTyConName - uWord <- tcLookupTyCon uWordTyConName - - let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon - - md <- tcLookupPromDataCon metaDataDataConName - mc <- tcLookupPromDataCon metaConsDataConName - ms <- tcLookupPromDataCon metaSelDataConName - pPrefix <- tcLookupPromDataCon prefixIDataConName - pInfix <- tcLookupPromDataCon infixIDataConName - pLA <- tcLookupPromDataCon leftAssociativeDataConName - pRA <- tcLookupPromDataCon rightAssociativeDataConName - pNA <- tcLookupPromDataCon notAssociativeDataConName - pSUpk <- tcLookupPromDataCon sourceUnpackDataConName - pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName - pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName - pSLzy <- tcLookupPromDataCon sourceLazyDataConName - pSStr <- tcLookupPromDataCon sourceStrictDataConName - pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName - pDLzy <- tcLookupPromDataCon decidedLazyDataConName - pDStr <- tcLookupPromDataCon decidedStrictDataConName - pDUpk <- tcLookupPromDataCon decidedUnpackDataConName - - fix_env <- getFixityEnv - - let mkSum' a b = mkTyConApp plus [k,a,b] - mkProd a b = mkTyConApp times [k,a,b] - mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a - mkRec1 a = mkTyConApp rec1 [k,a] - mkPar1 = mkTyConTy par1 - mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ] - mkC a = mkTyConApp c1 [ k - , metaConsTy a - , prod (dataConInstOrigArgTys a - . mkTyVarTys . tyConTyVars $ tycon) - (dataConSrcBangs a) - (dataConImplBangs a) - (dataConFieldLabels a)] - mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a] - - -- Sums and products are done in the same way for both Rep and Rep1 - sumP [] = mkTyConApp v1 [k] - sumP l = foldBal mkSum' . map mkC $ l - -- The Bool is True if this constructor has labelled fields - prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type - prod [] _ _ _ = mkTyConApp u1 [k] - prod l sb ib fl = foldBal mkProd - [ ASSERT(null fl || length fl > j) - arg t sb' ib' (if null fl - then Nothing - else Just (fl !! j)) - | (t,sb',ib',j) <- zip4 l sb ib [0..] ] - - arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type - arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of - -- Here we previously used Par0 if t was a type variable, but we - -- realized that we can't always guarantee that we are wrapping-up - -- all type variables in Par0. So we decided to stop using Par0 - -- altogether, and use Rec0 all the time. - Gen0_ -> mkRec0 t - Gen1_ argVar -> argPar argVar t - where - -- Builds argument representation for Rep1 (more complicated due to - -- the presence of composition). - argPar argVar = argTyFold argVar $ ArgTyAlg - {ata_rec0 = mkRec0, ata_par1 = mkPar1, - ata_rec1 = mkRec1, ata_comp = mkComp comp k} - - tyConName_user = case tyConFamInst_maybe tycon of - Just (ptycon, _) -> tyConName ptycon - Nothing -> tyConName tycon - - dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user - mdName = mkStrLitTy . moduleNameFS . moduleName - . nameModule . tyConName $ tycon - pkgName = mkStrLitTy . unitIdFS . moduleUnitId - . nameModule . tyConName $ tycon - isNT = mkTyConTy $ if isNewTyCon tycon - then promotedTrueDataCon - else promotedFalseDataCon - - ctName = mkStrLitTy . occNameFS . nameOccName . dataConName - ctFix c - | dataConIsInfix c - = case lookupFixity fix_env (dataConName c) of - Fixity _ n InfixL -> buildFix n pLA - Fixity _ n InfixR -> buildFix n pRA - Fixity _ n InfixN -> buildFix n pNA - | otherwise = mkTyConTy pPrefix - buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc - , mkNumLitTy (fromIntegral n)] - - isRec c = mkTyConTy $ if length (dataConFieldLabels c) > 0 - then promotedTrueDataCon - else promotedFalseDataCon - - selName = mkStrLitTy . flLabel - - mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind] - mbSel (Just s) = mkTyConApp promotedJustDataCon - [typeSymbolKind, selName s] - - metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT] - metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c] - metaSelTy mlbl su ss ib = - mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness] - where - pSUpkness = mkTyConTy $ case su of - SrcUnpack -> pSUpk - SrcNoUnpack -> pSNUpk - NoSrcUnpack -> pNSUpkness - - pSStrness = mkTyConTy $ case ss of - SrcLazy -> pSLzy - SrcStrict -> pSStr - NoSrcStrict -> pNSStrness - - pDStrness = mkTyConTy $ case ib of - HsLazy -> pDLzy - HsStrict -> pDStr - HsUnpack{} -> pDUpk - - return (mkD tycon) - -mkComp :: TyCon -> Kind -> Type -> Type -> Type -mkComp comp k f g - | k1_first = mkTyConApp comp [k,liftedTypeKind,f,g] - | otherwise = mkTyConApp comp [liftedTypeKind,k,f,g] - where - -- Which of these is the case? - -- newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... - -- or newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... - -- We want to instantiate with k1=k, and k2=* - -- Reason for k2=*: see Note [Handling kinds in a Rep instance] - -- But we need to know which way round! - k1_first = k_first == p_kind_var - [k_first,_,_,_,p] = tyConTyVars comp - Just p_kind_var = getTyVar_maybe (tyVarKind p) - --- Given the TyCons for each URec-related type synonym, check to see if the --- given type is an unlifted type that generics understands. If so, return --- its representation type. Otherwise, return Rec0. --- See Note [Generics and unlifted types] -mkBoxTy :: TyCon -- UAddr - -> TyCon -- UChar - -> TyCon -- UDouble - -> TyCon -- UFloat - -> TyCon -- UInt - -> TyCon -- UWord - -> TyCon -- Rec0 - -> Kind -- What to instantiate Rec0's kind variable with - -> Type - -> Type -mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty - | ty `eqType` addrPrimTy = mkTyConApp uAddr [k] - | ty `eqType` charPrimTy = mkTyConApp uChar [k] - | ty `eqType` doublePrimTy = mkTyConApp uDouble [k] - | ty `eqType` floatPrimTy = mkTyConApp uFloat [k] - | ty `eqType` intPrimTy = mkTyConApp uInt [k] - | ty `eqType` wordPrimTy = mkTyConApp uWord [k] - | otherwise = mkTyConApp rec0 [k,ty] - --------------------------------------------------------------------------------- --- Dealing with sums --------------------------------------------------------------------------------- - -mkSum :: GenericKind_ -- Generic or Generic1? - -> US -- Base for generating unique names - -> TyCon -- The type constructor - -> [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 _ _ tycon [] = ([from_alt], [to_alt]) - where - from_alt = (nlWildPat, makeError errMsgFrom) - to_alt = (nlWildPat, makeError errMsgTo) - -- These M1s are meta-information for the datatype - makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s)) - tyConStr = occNameString (nameOccName (tyConName tycon)) - errMsgFrom = "No generic representation for empty datatype " ++ tyConStr - errMsgTo = "No values for empty datatype " ++ tyConStr - --- Datatype with at least one constructor -mkSum gk_ us _ datacons = - -- switch the payload of gk_ to be datacon-centric instead of tycon-centric - unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d - | (d,i) <- zip datacons [1..] ] - --- Build the sum for a particular constructor -mk1Sum :: GenericKind_DC -- Generic or Generic1? - -> US -- Base for generating unique names - -> Int -- The index of this constructor - -> Int -- Total number of constructors - -> DataCon -- The data constructor - -> (Alt, -- Alternative for the T->Trep "from" function - Alt) -- Alternative for the Trep->T "to" function -mk1Sum gk_ us i n datacon = (from_alt, to_alt) - where - gk = forgetArgVar gk_ - - -- Existentials already excluded - argTys = dataConOrigArgTys datacon - n_args = dataConSourceArity datacon - - datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys - datacon_vars = map fst datacon_varTys - us' = us + n_args - - datacon_rdr = getRdrName datacon - - from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) - from_alt_rhs = genLR_E i n (mkProd_E gk_ us' datacon_varTys) - - to_alt = ( genLR_P i n (mkProd_P gk us' datacon_varTys) - , to_alt_rhs - ) -- These M1s are meta-information for the datatype - to_alt_rhs = case gk_ of - Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars - Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys - where - argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where - converter = argTyFold argVar $ ArgTyAlg - {ata_rec0 = nlHsVar . unboxRepRDR, - ata_par1 = nlHsVar unPar1_RDR, - ata_rec1 = const $ nlHsVar unRec1_RDR, - ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv) - `nlHsCompose` nlHsVar unComp1_RDR} - - --- Generates the L1/R1 sum pattern -genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName -genLR_P i n p - | n == 0 = error "impossible" - | n == 1 = p - | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] - | otherwise = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] - where m = div n 2 - --- Generates the L1/R1 sum expression -genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName -genLR_E i n e - | n == 0 = error "impossible" - | n == 1 = e - | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` - nlHsPar (genLR_E i (div n 2) e) - | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` - nlHsPar (genLR_E (i-m) (n-m) e) - where m = div n 2 - --------------------------------------------------------------------------------- --- Dealing with products --------------------------------------------------------------------------------- - --- Build a product expression -mkProd_E :: GenericKind_DC -- Generic or Generic1? - -> US -- Base for unique names - -> [(RdrName, Type)] -- List of variables matched on the lhs and their types - -> LHsExpr RdrName -- Resulting product expression -mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR) -mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars) - -- These M1s are meta-information for the constructor - where - appVars = map (wrapArg_E gk_) varTys - prod a b = prodDataCon_RDR `nlHsApps` [a,b] - -wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName -wrapArg_E Gen0_DC (var, ty) = mkM1_E $ - boxRepRDR ty `nlHsVarApps` [var] - -- This M1 is meta-information for the selector -wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ - converter ty `nlHsApp` nlHsVar var - -- This M1 is meta-information for the selector - where converter = argTyFold argVar $ ArgTyAlg - {ata_rec0 = nlHsVar . boxRepRDR, - ata_par1 = nlHsVar par1DataCon_RDR, - ata_rec1 = const $ nlHsVar rec1DataCon_RDR, - ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` - (nlHsVar fmap_RDR `nlHsApp` cnv)} - -boxRepRDR :: Type -> RdrName -boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs - -unboxRepRDR :: Type -> RdrName -unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs - --- Retrieve the RDRs associated with each URec data family instance --- constructor. See Note [Generics and unlifted types] -unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName) -unboxedRepRDRs ty - | ty `eqType` addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR) - | ty `eqType` charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR) - | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR) - | ty `eqType` floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR) - | ty `eqType` intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR) - | ty `eqType` wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR) - | otherwise = Nothing - --- Build a product pattern -mkProd_P :: GenericKind -- Gen0 or Gen1 - -> US -- Base for unique names - -> [(RdrName, Type)] -- List of variables to match, - -- along with their types - -> LPat RdrName -- Resulting product pattern -mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) -mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars) - -- These M1s are meta-information for the constructor - where - appVars = unzipWith (wrapArg_P gk) varTys - prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b] - -wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName -wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v]) - -- This M1 is meta-information for the selector -wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v] - -mkGenericLocal :: US -> RdrName -mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) - -x_RDR :: RdrName -x_RDR = mkVarUnqual (fsLit "x") - -x_Expr :: LHsExpr RdrName -x_Expr = nlHsVar x_RDR - -x_Pat :: LPat RdrName -x_Pat = nlVarPat x_RDR - -mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName -mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e - -mkM1_P :: LPat RdrName -> LPat RdrName -mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p] - -nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -nlHsCompose x y = compose_RDR `nlHsApps` [x, y] - --- | Variant of foldr1 for producing balanced lists -foldBal :: (a -> a -> a) -> [a] -> a -foldBal op = foldBal' op (error "foldBal: empty list") - -foldBal' :: (a -> a -> a) -> a -> [a] -> a -foldBal' _ x [] = x -foldBal' _ _ [y] = y -foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l - in foldBal' op x a `op` foldBal' op x b - -{- -Note [Generics and unlifted types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, all constants are marked with K1/Rec0. The exception to this rule is -when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In -that case, we must use a data family instance of URec (from GHC.Generics) to -mark it. As a result, before we can generate K1 or unK1, we must first check -to see if the type is actually one of the unlifted types for which URec has a -data family instance; if so, we generate that instead. - -See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more -details on why URec is implemented the way it is. - -Note [Generating a correctly typed Rep instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving -Generic(1). That is, it derives the ellipsis in the following: - - instance Generic Foo where - type Rep Foo = ... - -However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which -a Generic(1) instance is being derived, not the fully instantiated type. As a -result, tc_mkRepTy builds the most generalized Rep(1) instance possible using -the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This -can cause problems when the instance has instantiated type variables -(see Trac #11732). As an example: - - data T a = MkT a - deriving instance Generic (T Int) - ==> - instance Generic (T Int) where - type Rep (T Int) = (... (Rec0 a)) -- wrong! - --XStandaloneDeriving is one way for the type variables to become instantiated. -Another way is when Generic1 is being derived for a datatype with a visible -kind binder, e.g., - - data P k (a :: k) = MkP k deriving Generic1 - ==> - instance Generic1 (P *) where - type Rep1 (P *) = (... (Rec0 k)) -- wrong! - -See Note [Unify kinds in deriving] in TcDeriv. - -In any such scenario, we must prevent a discrepancy between the LHS and RHS of -a Rep(1) instance. To do so, we create a type variable substitution that maps -the tyConTyVars of the TyCon to their counterparts in the fully instantiated -type. (For example, using T above as example, you'd map a :-> Int.) We then -apply the substitution to the RHS before generating the instance. - -Note [Handling kinds in a Rep instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because Generic1 is poly-kinded, the representation types were generalized to -be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply -the kind of the instance being derived to all the representation type -constructors. For instance, if you have - - data Empty (a :: k) = Empty deriving Generic1 - -Then the generated code is now approximately (with -fprint-explicit-kinds -syntax): - - instance Generic1 k (Empty k) where - type Rep1 k (Empty k) = U1 k - -Most representation types have only one kind variable, making them easy to deal -with. The only non-trivial case is (:.:), which is only used in Generic1 -instances: - - newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) = - Comp1 { unComp1 :: f (g p) } - -Here, we do something a bit counter-intuitive: we make k1 be the kind of the -instance being derived, and we always make k2 be *. Why *? It's because -the code that GHC generates using (:.:) is always of the form x :.: Rec1 y -for some types x and y. In other words, the second type to which (:.:) is -applied always has kind k -> *, for some kind k, so k2 cannot possibly be -anything other than * in a generated Generic1 instance. - -Note [Generics compilation speed tricks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deriving Generic(1) is known to have a large constant factor during -compilation, which contributes to noticeable compilation slowdowns when -deriving Generic(1) for large datatypes (see Trac #5642). - -To ease the pain, there is a trick one can play when generating definitions for -to(1) and from(1). If you have a datatype like: - - data Letter = A | B | C | D - -then a naïve Generic instance for Letter would be: - - instance Generic Letter where - type Rep Letter = D1 ('MetaData ...) ... - - to (M1 (L1 (L1 (M1 U1)))) = A - to (M1 (L1 (R1 (M1 U1)))) = B - to (M1 (R1 (L1 (M1 U1)))) = C - to (M1 (R1 (R1 (M1 U1)))) = D - - from A = M1 (L1 (L1 (M1 U1))) - from B = M1 (L1 (R1 (M1 U1))) - from C = M1 (R1 (L1 (M1 U1))) - from D = M1 (R1 (R1 (M1 U1))) - -Notice that in every LHS pattern-match of the 'to' definition, and in every RHS -expression in the 'from' definition, the topmost constructor is M1. This -corresponds to the datatype-specific metadata (the D1 in the Rep Letter -instance). But this is wasteful from a typechecking perspective, since this -definition requires GHC to typecheck an application of M1 in every single case, -leading to an O(n) increase in the number of coercions the typechecker has to -solve, which in turn increases allocations and degrades compilation speed. - -Luckily, since the topmost M1 has the exact same type across every case, we can -factor it out reduce the typechecker's burden: - - instance Generic Letter where - type Rep Letter = D1 ('MetaData ...) ... - - to (M1 x) = case x of - L1 (L1 (M1 U1)) -> A - L1 (R1 (M1 U1)) -> B - R1 (L1 (M1 U1)) -> C - R1 (R1 (M1 U1)) -> D - - from x = M1 (case x of - A -> L1 (L1 (M1 U1)) - B -> L1 (R1 (M1 U1)) - C -> R1 (L1 (M1 U1)) - D -> R1 (R1 (M1 U1))) - -A simple change, but one that pays off, since it goes turns an O(n) amount of -coercions to an O(1) amount. --} diff --git a/typecheck/TcHsSyn.hs b/typecheck/TcHsSyn.hs deleted file mode 100644 --- a/typecheck/TcHsSyn.hs +++ /dev/null @@ -1,1700 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - - -TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker - -This module is an extension of @HsSyn@ syntax, for use in the type -checker. --} - -{-# LANGUAGE CPP, TupleSections #-} - -module TcHsSyn ( - -- * Extracting types from HsSyn - hsLitType, hsLPatType, hsPatType, - - -- * Other HsSyn functions - mkHsDictLet, mkHsApp, - mkHsAppTy, mkHsCaseAlt, - nlHsIntLit, - shortCutLit, hsOverLitName, - conLikeResTy, - - -- * re-exported from TcMonad - TcId, TcIdSet, - - -- * Zonking - -- | For a description of "zonking", see Note [What is zonking?] - -- in TcMType - zonkTopDecls, zonkTopExpr, zonkTopLExpr, - zonkTopBndrs, zonkTyBndrsX, - zonkTyVarBindersX, zonkTyVarBinderX, - emptyZonkEnv, mkEmptyZonkEnv, - zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc, - zonkCoToCo, zonkSigType, - zonkEvBinds, - ) where - -#include "HsVersions.h" - -import HsSyn -import Id -import IdInfo -import TcRnMonad -import PrelNames -import TcType -import TcMType -import TcEvidence -import TysPrim -import TyCon ( isUnboxedTupleTyCon ) -import TysWiredIn -import Type -import Coercion -import ConLike -import DataCon -import HscTypes -import Name -import NameEnv -import Var -import VarEnv -import DynFlags -import Literal -import BasicTypes -import Maybes -import SrcLoc -import Bag -import Outputable -import Util -import UniqFM - -import Control.Monad -import Data.List ( partition ) -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - Extracting the type from HsSyn -* * -************************************************************************ - --} - -hsLPatType :: OutPat Id -> Type -hsLPatType (L _ pat) = hsPatType pat - -hsPatType :: Pat Id -> Type -hsPatType (ParPat pat) = hsLPatType pat -hsPatType (WildPat ty) = ty -hsPatType (VarPat (L _ var)) = idType var -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 Nothing) = mkListTy ty -hsPatType (ListPat _ _ (Just (ty,_))) = ty -hsPatType (PArrPat _ ty) = mkPArrTy ty -hsPatType (TuplePat _ bx tys) = mkTupleTy bx tys -hsPatType (SumPat _ _ _ tys) = mkSumTy tys -hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) - = conLikeResTy con tys -hsPatType (SigPatOut _ ty) = ty -hsPatType (NPat _ _ _ ty) = ty -hsPatType (NPlusKPat _ _ _ _ _ ty) = ty -hsPatType (CoPat _ _ ty) = ty -hsPatType p = pprPanic "hsPatType" (ppr p) - -hsLitType :: HsLit -> 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 - --- Overloaded literals. Here mainly because it uses isIntTy etc - -shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId) -shortCutLit dflags (HsIntegral src i) ty - | isIntTy ty && inIntRange dflags i = Just (HsLit (HsInt src i)) - | isWordTy ty && inWordRange dflags i - = Just (mkLit wordDataCon (HsWordPrim src i)) - | isIntegerTy ty = Just (HsLit (HsInteger src i ty)) - | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty - -- The 'otherwise' case is important - -- Consider (3 :: Float). Syntactically it looks like an IntLit, - -- so we'll call shortCutIntLit, but of course it's a float - -- This can make a big difference for programs with a lot of - -- literals, compiled without -O - -shortCutLit _ (HsFractional f) ty - | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f)) - | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f)) - | otherwise = Nothing - -shortCutLit _ (HsIsString src s) ty - | isStringTy ty = Just (HsLit (HsString src s)) - | otherwise = Nothing - -mkLit :: DataCon -> HsLit -> HsExpr Id -mkLit con lit = HsApp (nlHsDataCon con) (nlHsLit lit) - ------------------------------- -hsOverLitName :: OverLitVal -> Name --- Get the canonical 'fromX' name for a particular OverLitVal -hsOverLitName (HsIntegral {}) = fromIntegerName -hsOverLitName (HsFractional {}) = fromRationalName -hsOverLitName (HsIsString {}) = fromStringName - -{- -************************************************************************ -* * -\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} -* * -************************************************************************ - -The rest of the zonking is done *after* typechecking. -The main zonking pass runs over the bindings - - a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc - b) convert unbound TcTyVar to Void - c) convert each TcId to an Id by zonking its type - -The type variables are converted by binding mutable tyvars to immutable ones -and then zonking as normal. - -The Ids are converted by binding them in the normal Tc envt; that -way we maintain sharing; eg an Id is zonked at its binding site and they -all occurrences of that Id point to the common zonked copy - -It's all pretty boring stuff, because HsSyn is such a large type, and -the environment manipulation is tiresome. --} - --- Confused by zonking? See Note [What is zonking?] in TcMType. -type UnboundTyVarZonker = TcTyVar -> TcM Type - -- How to zonk an unbound type variable - -- The TcTyVar is - -- (a) a MetaTv - -- (b) Flexi and - -- (c) its kind is already zonked - -- Note [Zonking the LHS of a RULE] - --- | A ZonkEnv carries around several bits. --- The UnboundTyVarZonker just zaps unbouned meta-tyvars to Any (as --- defined in zonkTypeZapping), except on the LHS of rules. See --- Note [Zonking the LHS of a RULE]. --- --- The (TyCoVarEnv TyVar) and is just an optimisation: when binding a --- tyvar or covar, we zonk the kind right away and add a mapping to --- the env. This prevents re-zonking the kind at every occurrence. But --- this is *just* an optimisation. --- --- The final (IdEnv Var) optimises zonking for Ids. It is --- knot-tied. We must be careful never to put coercion variables --- (which are Ids, after all) in the knot-tied env, because coercions --- can appear in types, and we sometimes inspect a zonked type in this --- module. --- --- Confused by zonking? See Note [What is zonking?] in TcMType. -data ZonkEnv - = ZonkEnv - UnboundTyVarZonker - (TyCoVarEnv TyVar) - (IdEnv Var) -- What variables are in scope - -- Maps an Id or EvVar to its zonked version; both have the same Name - -- Note that all evidence (coercion variables as well as dictionaries) - -- are kept in the ZonkEnv - -- Only *type* abstraction is done by side effect - -- Is only consulted lazily; hence knot-tying - -instance Outputable ZonkEnv where - ppr (ZonkEnv _ _ty_env var_env) = pprUFM var_env (vcat . map ppr) - - --- The EvBinds have to already be zonked, but that's usually the case. -emptyZonkEnv :: ZonkEnv -emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping - -mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv -mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv - --- | Extend the knot-tied environment. -extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv -extendIdZonkEnvRec (ZonkEnv zonk_ty ty_env id_env) ids - -- NB: Don't look at the var to decide which env't to put it in. That - -- would end up knot-tying all the env'ts. - = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids]) - -- Given coercion variables will actually end up here. That's OK though: - -- coercion variables are never looked up in the knot-tied env't, so zonking - -- them simply doesn't get optimised. No one gets hurt. An improvement (?) - -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the - -- recursive groups. But perhaps the time it takes to do the analysis is - -- more than the savings. - -extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv -extendZonkEnv (ZonkEnv zonk_ty tyco_env id_env) vars - = ZonkEnv zonk_ty (extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars]) - (extendVarEnvList id_env [(id,id) | id <- ids]) - where (tycovars, ids) = partition isTyCoVar vars - -extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv -extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id - = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id) - -extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv -extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) tv - = ZonkEnv zonk_ty (extendVarEnv ty_env tv tv) id_env - -setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv -setZonkType (ZonkEnv _ ty_env id_env) zonk_ty - = ZonkEnv zonk_ty ty_env id_env - -zonkEnvIds :: ZonkEnv -> TypeEnv -zonkEnvIds (ZonkEnv _ _ id_env) = - mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env] - -- It's OK to use nonDetEltsUFM here because we forget the ordering - -- immediately by creating a TypeEnv - -zonkIdOcc :: ZonkEnv -> TcId -> Id --- Ids defined in this module should be in the envt; --- ignore others. (Actually, data constructors are also --- not LocalVars, even when locally defined, but that is fine.) --- (Also foreign-imported things aren't currently in the ZonkEnv; --- that's ok because they don't need zonking.) --- --- Actually, Template Haskell works in 'chunks' of declarations, and --- an earlier chunk won't be in the 'env' that the zonking phase --- carries around. Instead it'll be in the tcg_gbl_env, already fully --- zonked. There's no point in looking it up there (except for error --- checking), and it's not conveniently to hand; hence the simple --- 'orElse' case in the LocalVar branch. --- --- Even without template splices, in module Main, the checking of --- 'main' is done as a separate chunk. -zonkIdOcc (ZonkEnv _zonk_ty _ty_env id_env) id - | isLocalVar id = lookupVarEnv id_env id `orElse` - id - | otherwise = id - -zonkIdOccs :: ZonkEnv -> [TcId] -> [Id] -zonkIdOccs env ids = map (zonkIdOcc env) ids - --- zonkIdBndr is used *after* typechecking to get the Id's type --- to its final form. The TyVarEnv give -zonkIdBndr :: ZonkEnv -> TcId -> TcM Id -zonkIdBndr env v - = do ty' <- zonkTcTypeToType env (idType v) - ensureNotLevPoly ty' - (text "In the type of binder" <+> quotes (ppr v)) - - return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty')) - -zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] -zonkIdBndrs env ids = mapM (zonkIdBndr env) ids - -zonkTopBndrs :: [TcId] -> TcM [Id] -zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids - -zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id) -zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel - -zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) -zonkEvBndrsX = mapAccumLM zonkEvBndrX - -zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) --- Works for dictionaries and coercions -zonkEvBndrX env var - = do { var' <- zonkEvBndr env var - ; return (extendZonkEnv env [var'], var') } - -zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar --- Works for dictionaries and coercions --- Does not extend the ZonkEnv -zonkEvBndr env var - = do { let var_ty = varType var - ; ty <- - {-# SCC "zonkEvBndr_zonkTcTypeToType" #-} - zonkTcTypeToType env var_ty - ; return (setVarType var ty) } - -zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm -zonkEvVarOcc env v - | isCoVar v - = EvCoercion <$> zonkCoVarOcc env v - | otherwise - = return (EvId $ zonkIdOcc env v) - -zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar]) -zonkTyBndrsX = mapAccumLM zonkTyBndrX - -zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar) --- This guarantees to return a TyVar (not a TcTyVar) --- then we add it to the envt, so all occurrences are replaced -zonkTyBndrX env tv - = ASSERT( isImmutableTyVar tv ) - do { ki <- zonkTcTypeToType env (tyVarKind tv) - -- Internal names tidy up better, for iface files. - ; let tv' = mkTyVar (tyVarName tv) ki - ; return (extendTyZonkEnv1 env tv', tv') } - -zonkTyVarBindersX :: ZonkEnv -> [TyVarBndr TcTyVar vis] - -> TcM (ZonkEnv, [TyVarBndr TyVar vis]) -zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX - -zonkTyVarBinderX :: ZonkEnv -> TyVarBndr TcTyVar vis - -> TcM (ZonkEnv, TyVarBndr TyVar vis) --- Takes a TcTyVar and guarantees to return a TyVar -zonkTyVarBinderX env (TvBndr tv vis) - = do { (env', tv') <- zonkTyBndrX env tv - ; return (env', TvBndr tv' vis) } - -zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id) -zonkTopExpr e = zonkExpr emptyZonkEnv e - -zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) -zonkTopLExpr e = zonkLExpr emptyZonkEnv e - -zonkTopDecls :: Bag EvBind - -> LHsBinds TcId - -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] - -> TcM (TypeEnv, - Bag EvBind, - LHsBinds Id, - [LForeignDecl Id], - [LTcSpecPrag], - [LRuleDecl Id], - [LVectDecl Id]) -zonkTopDecls ev_binds binds rules vects imp_specs fords - = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds - ; (env2, binds') <- zonkRecMonoBinds env1 binds - -- Top level is implicitly recursive - ; rules' <- zonkRules env2 rules - ; vects' <- zonkVects env2 vects - ; specs' <- zonkLTcSpecPrags env2 imp_specs - ; fords' <- zonkForeignExports env2 fords - ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') } - ---------------------------------------------- -zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) -zonkLocalBinds env EmptyLocalBinds - = return (env, EmptyLocalBinds) - -zonkLocalBinds _ (HsValBinds (ValBindsIn {})) - = panic "zonkLocalBinds" -- Not in typechecker output - -zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs)) - = do { (env1, new_binds) <- go env binds - ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) } - where - go env [] - = return (env, []) - go env ((r,b):bs) - = do { (env1, b') <- zonkRecMonoBinds env b - ; (env2, bs') <- go env1 bs - ; return (env2, (r,b'):bs') } - -zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do - new_binds <- mapM (wrapLocM zonk_ip_bind) binds - let - env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds] - (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds - return (env2, HsIPBinds (IPBinds new_binds new_dict_binds)) - where - zonk_ip_bind (IPBind n e) - = do n' <- mapIPNameTc (zonkIdBndr env) n - e' <- zonkLExpr env e - return (IPBind n' e') - ---------------------------------------------- -zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) -zonkRecMonoBinds env binds - = fixM (\ ~(_, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds) - ; binds' <- zonkMonoBinds env1 binds - ; return (env1, binds') }) - ---------------------------------------------- -zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id) -zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds - -zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id) -zonk_lbind env = wrapLocM (zonk_bind env) - -zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id) -zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) - = do { (_env, new_pat) <- zonkPat env pat -- Env already extended - ; new_grhss <- zonkGRHSs env zonkLExpr grhss - ; new_ty <- zonkTcTypeToType env ty - ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } - -zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl }) - = do { new_var <- zonkIdBndr env var - ; new_expr <- zonkLExpr env expr - ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) } - -zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms - , fun_co_fn = co_fn }) - = do { new_var <- zonkIdBndr env var - ; (env1, new_co_fn) <- zonkCoFn env co_fn - ; new_ms <- zonkMatchGroup env1 zonkLExpr ms - ; return (bind { fun_id = L loc new_var, fun_matches = new_ms - , fun_co_fn = new_co_fn }) } - -zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs - , abs_ev_binds = ev_binds - , abs_exports = exports - , abs_binds = val_binds }) - = ASSERT( all isImmutableTyVar tyvars ) - do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds - ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> - do { let env3 = extendIdZonkEnvRec env2 - (collectHsBindsBinders new_val_binds) - ; new_val_binds <- zonkMonoBinds env3 val_binds - ; new_exports <- mapM (zonkExport env3) exports - ; return (new_val_binds, new_exports) } - ; return (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 }) } - where - zonkExport env (ABE{ abe_wrap = wrap - , abe_poly = poly_id - , abe_mono = mono_id, abe_prags = prags }) - = do new_poly_id <- zonkIdBndr env poly_id - (_, new_wrap) <- zonkCoFn env wrap - new_prags <- zonkSpecPrags env prags - return (ABE{ abe_wrap = new_wrap - , abe_poly = new_poly_id - , abe_mono = zonkIdOcc env mono_id - , abe_prags = new_prags }) - -zonk_bind env outer_bind@(AbsBindsSig { abs_tvs = tyvars - , abs_ev_vars = evs - , abs_sig_export = poly - , abs_sig_prags = prags - , abs_sig_ev_bind = ev_bind - , abs_sig_bind = lbind }) - | L bind_loc bind@(FunBind { fun_id = L loc local - , fun_matches = ms - , fun_co_fn = co_fn }) <- lbind - = ASSERT( all isImmutableTyVar tyvars ) - do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_ev_bind) <- zonkTcEvBinds env1 ev_bind - -- Inline zonk_bind (FunBind ...) because we wish to skip - -- the check for representation-polymorphic binders. The - -- local binder in the FunBind in an AbsBindsSig is never actually - -- bound in Core -- indeed, that's the whole point of AbsBindsSig. - -- just calling zonk_bind causes #11405. - ; new_local <- updateVarTypeM (zonkTcTypeToType env2) local - ; (env3, new_co_fn) <- zonkCoFn env2 co_fn - ; new_ms <- zonkMatchGroup env3 zonkLExpr ms - -- If there is a representation polymorphism problem, it will - -- be caught here: - ; new_poly_id <- zonkIdBndr env2 poly - ; new_prags <- zonkSpecPrags env2 prags - ; let new_val_bind = L bind_loc (bind { fun_id = L loc new_local - , fun_matches = new_ms - , fun_co_fn = new_co_fn }) - ; return (AbsBindsSig { abs_tvs = new_tyvars - , abs_ev_vars = new_evs - , abs_sig_export = new_poly_id - , abs_sig_prags = new_prags - , abs_sig_ev_bind = new_ev_bind - , abs_sig_bind = new_val_bind }) } - - | otherwise - = pprPanic "zonk_bind" (ppr outer_bind) - -zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id - , psb_args = details - , psb_def = lpat - , psb_dir = dir })) - = do { id' <- zonkIdBndr env id - ; details' <- zonkPatSynDetails env details - ; (env1, lpat') <- zonkPat env lpat - ; (_env2, dir') <- zonkPatSynDir env1 dir - ; return $ PatSynBind $ - bind { psb_id = L loc id' - , psb_args = details' - , psb_def = lpat' - , psb_dir = dir' } } - -zonkPatSynDetails :: ZonkEnv - -> HsPatSynDetails (Located TcId) - -> TcM (HsPatSynDetails (Located Id)) -zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env) - -zonkPatSynDir :: ZonkEnv -> HsPatSynDir TcId -> TcM (ZonkEnv, HsPatSynDir Id) -zonkPatSynDir env Unidirectional = return (env, Unidirectional) -zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) -zonkPatSynDir env (ExplicitBidirectional mg) = do - mg' <- zonkMatchGroup env zonkLExpr mg - return (env, ExplicitBidirectional mg') - -zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags -zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod -zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps - ; return (SpecPrags ps') } - -zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] -zonkLTcSpecPrags env ps - = mapM zonk_prag ps - where - zonk_prag (L loc (SpecPrag id co_fn inl)) - = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } - -{- -************************************************************************ -* * -\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} -* * -************************************************************************ --} - -zonkMatchGroup :: ZonkEnv - -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) - -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id))) -zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys - , mg_res_ty = res_ty, mg_origin = origin }) - = do { ms' <- mapM (zonkMatch env zBody) ms - ; arg_tys' <- zonkTcTypeToTypes env arg_tys - ; res_ty' <- zonkTcTypeToType env res_ty - ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys' - , mg_res_ty = res_ty', mg_origin = origin }) } - -zonkMatch :: ZonkEnv - -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) - -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id))) -zonkMatch env zBody (L loc (Match mf pats _ grhss)) - = do { (env1, new_pats) <- zonkPats env pats - ; new_grhss <- zonkGRHSs env1 zBody grhss - ; return (L loc (Match mf new_pats Nothing new_grhss)) } - -------------------------------------------------------------------------- -zonkGRHSs :: ZonkEnv - -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) - -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id))) - -zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do - (new_env, new_binds) <- zonkLocalBinds env binds - let - zonk_grhs (GRHS guarded rhs) - = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded - new_rhs <- zBody env2 rhs - return (GRHS new_guarded new_rhs) - new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs new_grhss (L l new_binds)) - -{- -************************************************************************ -* * -\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} -* * -************************************************************************ --} - -zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id] -zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id) -zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id) - -zonkLExprs env exprs = mapM (zonkLExpr env) exprs -zonkLExpr env expr = wrapLocM (zonkExpr env) expr - -zonkExpr env (HsVar (L l id)) - = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) - return (HsVar (L l (zonkIdOcc env id))) - -zonkExpr _ e@(HsConLikeOut {}) = return e - -zonkExpr _ (HsIPVar id) - = return (HsIPVar id) - -zonkExpr _ e@HsOverLabel{} = return e - -zonkExpr env (HsLit (HsRat f ty)) - = do new_ty <- zonkTcTypeToType env ty - return (HsLit (HsRat f new_ty)) - -zonkExpr _ (HsLit lit) - = return (HsLit lit) - -zonkExpr env (HsOverLit lit) - = do { lit' <- zonkOverLit env lit - ; return (HsOverLit lit') } - -zonkExpr env (HsLam matches) - = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLam new_matches) - -zonkExpr env (HsLamCase matches) - = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLamCase new_matches) - -zonkExpr env (HsApp e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (HsApp new_e1 new_e2) - -zonkExpr env (HsAppTypeOut e t) - = do new_e <- zonkLExpr env e - return (HsAppTypeOut new_e t) - -- NB: the type is an HsType; can't zonk that! - -zonkExpr _ e@(HsRnBracketOut _ _) - = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) - -zonkExpr env (HsTcBracketOut body bs) - = do bs' <- mapM zonk_b bs - return (HsTcBracketOut body bs') - where - zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e - return (PendingTcSplice n e') - -zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen - return (HsSpliceE s) - -zonkExpr env (OpApp e1 op fixity e2) - = do new_e1 <- zonkLExpr env e1 - new_op <- zonkLExpr env op - new_e2 <- zonkLExpr env e2 - return (OpApp new_e1 new_op fixity new_e2) - -zonkExpr env (NegApp expr op) - = do (env', new_op) <- zonkSyntaxExpr env op - new_expr <- zonkLExpr env' expr - return (NegApp new_expr new_op) - -zonkExpr env (HsPar e) - = do new_e <- zonkLExpr env e - return (HsPar new_e) - -zonkExpr env (SectionL expr op) - = do new_expr <- zonkLExpr env expr - new_op <- zonkLExpr env op - return (SectionL new_expr new_op) - -zonkExpr env (SectionR op expr) - = do new_op <- zonkLExpr env op - new_expr <- zonkLExpr env expr - return (SectionR new_op new_expr) - -zonkExpr env (ExplicitTuple tup_args boxed) - = do { new_tup_args <- mapM zonk_tup_arg tup_args - ; return (ExplicitTuple new_tup_args boxed) } - where - zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e - ; return (L l (Present e')) } - zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t - ; return (L l (Missing t')) } - -zonkExpr env (ExplicitSum alt arity expr args) - = do new_args <- mapM (zonkTcTypeToType env) args - new_expr <- zonkLExpr env expr - return (ExplicitSum alt arity new_expr new_args) - -zonkExpr env (HsCase expr ms) - = do new_expr <- zonkLExpr env expr - new_ms <- zonkMatchGroup env zonkLExpr ms - return (HsCase new_expr new_ms) - -zonkExpr env (HsIf Nothing e1 e2 e3) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_e3 <- zonkLExpr env e3 - return (HsIf Nothing new_e1 new_e2 new_e3) - -zonkExpr env (HsIf (Just fun) e1 e2 e3) - = do (env1, new_fun) <- zonkSyntaxExpr env fun - new_e1 <- zonkLExpr env1 e1 - new_e2 <- zonkLExpr env1 e2 - new_e3 <- zonkLExpr env1 e3 - return (HsIf (Just new_fun) new_e1 new_e2 new_e3) - -zonkExpr env (HsMultiIf ty alts) - = do { alts' <- mapM (wrapLocM zonk_alt) alts - ; ty' <- zonkTcTypeToType env ty - ; return $ HsMultiIf ty' alts' } - where zonk_alt (GRHS guard expr) - = do { (env', guard') <- zonkStmts env zonkLExpr guard - ; expr' <- zonkLExpr env' expr - ; return $ GRHS guard' expr' } - -zonkExpr env (HsLet (L l binds) expr) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_expr <- zonkLExpr new_env expr - return (HsLet (L l new_binds) new_expr) - -zonkExpr env (HsDo do_or_lc (L l stmts) ty) - = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts - new_ty <- zonkTcTypeToType env ty - return (HsDo do_or_lc (L l new_stmts) new_ty) - -zonkExpr env (ExplicitList ty wit exprs) - = do (env1, new_wit) <- zonkWit env wit - new_ty <- zonkTcTypeToType env1 ty - new_exprs <- zonkLExprs env1 exprs - return (ExplicitList new_ty new_wit new_exprs) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln - -zonkExpr env (ExplicitPArr ty exprs) - = do new_ty <- zonkTcTypeToType env ty - new_exprs <- zonkLExprs env exprs - return (ExplicitPArr new_ty new_exprs) - -zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds }) - = do { new_con_expr <- zonkExpr env con_expr - ; new_rbinds <- zonkRecFields env rbinds - ; return (expr { rcon_con_expr = new_con_expr - , rcon_flds = new_rbinds }) } - -zonkExpr env (RecordUpd { rupd_expr = expr, rupd_flds = rbinds - , rupd_cons = cons, rupd_in_tys = in_tys - , rupd_out_tys = out_tys, rupd_wrap = req_wrap }) - = do { new_expr <- zonkLExpr env expr - ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys - ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys - ; new_rbinds <- zonkRecUpdFields env rbinds - ; (_, new_recwrap) <- zonkCoFn env req_wrap - ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds - , rupd_cons = cons, rupd_in_tys = new_in_tys - , rupd_out_tys = new_out_tys, rupd_wrap = new_recwrap }) } - -zonkExpr env (ExprWithTySigOut e ty) - = do { e' <- zonkLExpr env e - ; return (ExprWithTySigOut e' ty) } - -zonkExpr env (ArithSeq expr wit info) - = do (env1, new_wit) <- zonkWit env wit - new_expr <- zonkExpr env expr - new_info <- zonkArithSeq env1 info - return (ArithSeq new_expr new_wit new_info) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln - -zonkExpr env (PArrSeq expr info) - = do new_expr <- zonkExpr env expr - new_info <- zonkArithSeq env info - return (PArrSeq new_expr new_info) - -zonkExpr env (HsSCC src lbl expr) - = do new_expr <- zonkLExpr env expr - return (HsSCC src lbl new_expr) - -zonkExpr env (HsTickPragma src info srcInfo expr) - = do new_expr <- zonkLExpr env expr - return (HsTickPragma src info srcInfo new_expr) - --- hdaume: core annotations -zonkExpr env (HsCoreAnn src lbl expr) - = do new_expr <- zonkLExpr env expr - return (HsCoreAnn src lbl new_expr) - --- arrow notation extensions -zonkExpr env (HsProc pat body) - = do { (env1, new_pat) <- zonkPat env pat - ; new_body <- zonkCmdTop env1 body - ; return (HsProc new_pat new_body) } - --- StaticPointers extension -zonkExpr env (HsStatic fvs expr) - = HsStatic fvs <$> zonkLExpr env expr - -zonkExpr env (HsWrap co_fn expr) - = do (env1, new_co_fn) <- zonkCoFn env co_fn - new_expr <- zonkExpr env1 expr - return (HsWrap new_co_fn new_expr) - -zonkExpr _ e@(HsUnboundVar {}) = return e - -zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) - -------------------------------------------------------------------------- -{- -Note [Skolems in zonkSyntaxExpr] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider rebindable syntax with something like - - (>>=) :: (forall x. blah) -> (forall y. blah') -> blah'' - -The x and y become skolems that are in scope when type-checking the -arguments to the bind. This means that we must extend the ZonkEnv with -these skolems when zonking the arguments to the bind. But the skolems -are different between the two arguments, and so we should theoretically -carry around different environments to use for the different arguments. - -However, this becomes a logistical nightmare, especially in dealing with -the more exotic Stmt forms. So, we simplify by making the critical -assumption that the uniques of the skolems are different. (This assumption -is justified by the use of newUnique in TcMType.instSkolTyCoVarX.) -Now, we can safely just extend one environment. --} - --- See Note [Skolems in zonkSyntaxExpr] -zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr TcId - -> TcM (ZonkEnv, SyntaxExpr Id) -zonkSyntaxExpr env (SyntaxExpr { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - = do { (env0, res_wrap') <- zonkCoFn env res_wrap - ; expr' <- zonkExpr env0 expr - ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps - ; return (env1, SyntaxExpr { syn_expr = expr' - , syn_arg_wraps = arg_wraps' - , syn_res_wrap = res_wrap' }) } - -------------------------------------------------------------------------- - -zonkLCmd :: ZonkEnv -> LHsCmd TcId -> TcM (LHsCmd Id) -zonkCmd :: ZonkEnv -> HsCmd TcId -> TcM (HsCmd Id) - -zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd - -zonkCmd env (HsCmdWrap w cmd) - = do { (env1, w') <- zonkCoFn env w - ; cmd' <- zonkCmd env1 cmd - ; return (HsCmdWrap w' cmd') } -zonkCmd env (HsCmdArrApp e1 e2 ty ho rl) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_ty <- zonkTcTypeToType env ty - return (HsCmdArrApp new_e1 new_e2 new_ty ho rl) - -zonkCmd env (HsCmdArrForm op f fixity args) - = do new_op <- zonkLExpr env op - new_args <- mapM (zonkCmdTop env) args - return (HsCmdArrForm new_op f fixity new_args) - -zonkCmd env (HsCmdApp c e) - = do new_c <- zonkLCmd env c - new_e <- zonkLExpr env e - return (HsCmdApp new_c new_e) - -zonkCmd env (HsCmdLam matches) - = do new_matches <- zonkMatchGroup env zonkLCmd matches - return (HsCmdLam new_matches) - -zonkCmd env (HsCmdPar c) - = do new_c <- zonkLCmd env c - return (HsCmdPar new_c) - -zonkCmd env (HsCmdCase expr ms) - = do new_expr <- zonkLExpr env expr - new_ms <- zonkMatchGroup env zonkLCmd ms - return (HsCmdCase new_expr new_ms) - -zonkCmd env (HsCmdIf eCond ePred cThen cElse) - = do { (env1, new_eCond) <- zonkWit env eCond - ; new_ePred <- zonkLExpr env1 ePred - ; new_cThen <- zonkLCmd env1 cThen - ; new_cElse <- zonkLCmd env1 cElse - ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) } - where - zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w - -zonkCmd env (HsCmdLet (L l binds) cmd) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet (L l new_binds) new_cmd) - -zonkCmd env (HsCmdDo (L l stmts) ty) - = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts - new_ty <- zonkTcTypeToType env ty - return (HsCmdDo (L l new_stmts) new_ty) - - - - - -zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id) -zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd - -zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id) -zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) - = do new_cmd <- zonkLCmd env cmd - new_stack_tys <- zonkTcTypeToType env stack_tys - new_ty <- zonkTcTypeToType env ty - new_ids <- mapSndM (zonkExpr env) ids - - MASSERT( isLiftedTypeKind (typeKind new_stack_tys) ) - -- desugarer assumes that this is not levity polymorphic... - -- but indeed it should always be lifted due to the typing - -- rules for arrows - - return (HsCmdTop new_cmd new_stack_tys new_ty new_ids) - -------------------------------------------------------------------------- -zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) -zonkCoFn env WpHole = return (env, WpHole) -zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; t1' <- zonkTcTypeToType env2 t1 - ; return (env2, WpFun c1' c2' t1' d) } -zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co - ; return (env, WpCast co') } -zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev - ; return (env', WpEvLam ev') } -zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg - ; return (env, WpEvApp arg') } -zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) - do { (env', tv') <- zonkTyBndrX env tv - ; return (env', WpTyLam tv') } -zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty - ; return (env, WpTyApp ty') } -zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs - ; return (env1, WpLet bs') } - -------------------------------------------------------------------------- -zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) -zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) - = do { ty' <- zonkTcTypeToType env ty - ; e' <- zonkExpr env e - ; return (lit { ol_witness = e', ol_type = ty' }) } - -------------------------------------------------------------------------- -zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) - -zonkArithSeq env (From e) - = do new_e <- zonkLExpr env e - return (From new_e) - -zonkArithSeq env (FromThen e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (FromThen new_e1 new_e2) - -zonkArithSeq env (FromTo e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (FromTo new_e1 new_e2) - -zonkArithSeq env (FromThenTo e1 e2 e3) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_e3 <- zonkLExpr env e3 - return (FromThenTo new_e1 new_e2 new_e3) - - -------------------------------------------------------------------------- -zonkStmts :: ZonkEnv - -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) - -> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))]) -zonkStmts env _ [] = return (env, []) -zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s - ; (env2, ss') <- zonkStmts env1 zBody ss - ; return (env2, s' : ss') } - -zonkStmt :: ZonkEnv - -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) - -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id))) -zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty) - = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op - ; new_bind_ty <- zonkTcTypeToType env1 bind_ty - ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs - ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs] - env2 = extendIdZonkEnvRec env1 new_binders - ; new_mzip <- zonkExpr env2 mzip_op - ; return (env2, ParStmt new_stmts_w_bndrs new_mzip new_bind_op new_bind_ty) } - where - zonk_branch env1 (ParStmtBlock stmts bndrs return_op) - = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts - ; (env3, new_return) <- zonkSyntaxExpr env2 return_op - ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) } - -zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs - , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id - , recS_bind_fn = bind_id, recS_bind_ty = bind_ty - , recS_later_rets = later_rets, recS_rec_rets = rec_rets - , recS_ret_ty = ret_ty }) - = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id - ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id - ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id - ; new_bind_ty <- zonkTcTypeToType env3 bind_ty - ; new_rvs <- zonkIdBndrs env3 rvs - ; new_lvs <- zonkIdBndrs env3 lvs - ; new_ret_ty <- zonkTcTypeToType env3 ret_ty - ; let env4 = extendIdZonkEnvRec env3 new_rvs - ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts - -- Zonk the ret-expressions in an envt that - -- has the polymorphic bindings in the envt - ; new_later_rets <- mapM (zonkExpr env5) later_rets - ; new_rec_rets <- mapM (zonkExpr env5) rec_rets - ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed - RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs - , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id - , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_bind_ty = new_bind_ty - , recS_later_rets = new_later_rets - , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) } - -zonkStmt env zBody (BodyStmt body then_op guard_op ty) - = do (env1, new_then_op) <- zonkSyntaxExpr env then_op - (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op - new_body <- zBody env2 body - new_ty <- zonkTcTypeToType env2 ty - return (env2, BodyStmt new_body new_then_op new_guard_op new_ty) - -zonkStmt env zBody (LastStmt body noret ret_op) - = do (env1, new_ret) <- zonkSyntaxExpr env ret_op - new_body <- zBody env1 body - return (env, LastStmt new_body noret new_ret) - -zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap - , trS_by = by, trS_form = form, trS_using = using - , trS_ret = return_op, trS_bind = bind_op - , trS_bind_arg_ty = bind_arg_ty - , trS_fmap = liftM_op }) - = do { - ; (env1, bind_op') <- zonkSyntaxExpr env bind_op - ; bind_arg_ty' <- zonkTcTypeToType env1 bind_arg_ty - ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts - ; by' <- fmapMaybeM (zonkLExpr env2) by - ; using' <- zonkLExpr env2 using - - ; (env3, return_op') <- zonkSyntaxExpr env2 return_op - ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap - ; liftM_op' <- zonkExpr env3 liftM_op - ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap') - ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' - , trS_by = by', trS_form = form, trS_using = using' - , trS_ret = return_op', trS_bind = bind_op' - , trS_bind_arg_ty = bind_arg_ty' - , trS_fmap = liftM_op' }) } - where - zonkBinderMapEntry env (oldBinder, newBinder) = do - let oldBinder' = zonkIdOcc env oldBinder - newBinder' <- zonkIdBndr env newBinder - return (oldBinder', newBinder') - -zonkStmt env _ (LetStmt (L l binds)) - = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt (L l new_binds)) - -zonkStmt env zBody (BindStmt pat body bind_op fail_op bind_ty) - = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op - ; new_bind_ty <- zonkTcTypeToType env1 bind_ty - ; new_body <- zBody env1 body - ; (env2, new_pat) <- zonkPat env1 pat - ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op - ; return (env2, BindStmt new_pat new_body new_bind new_fail new_bind_ty) } - --- Scopes: join > ops (in reverse order) > pats (in forward order) --- > rest of stmts -zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty) - = do { (env1, new_mb_join) <- zonk_join env mb_join - ; (env2, new_args) <- zonk_args env1 args - ; new_body_ty <- zonkTcTypeToType env2 body_ty - ; return (env2, ApplicativeStmt new_args new_mb_join new_body_ty) } - where - zonk_join env Nothing = return (env, Nothing) - zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j - - get_pat (_, ApplicativeArgOne pat _) = pat - get_pat (_, ApplicativeArgMany _ _ pat) = pat - - replace_pat pat (op, ApplicativeArgOne _ a) - = (op, ApplicativeArgOne pat a) - replace_pat pat (op, ApplicativeArgMany a b _) - = (op, ApplicativeArgMany a b pat) - - zonk_args env args - = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args) - ; (env2, new_pats) <- zonkPats env1 (map get_pat args) - ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) } - - -- these need to go backward, because if any operators are higher-rank, - -- later operators may introduce skolems that are in scope for earlier - -- arguments - zonk_args_rev env ((op, arg) : args) - = do { (env1, new_op) <- zonkSyntaxExpr env op - ; new_arg <- zonk_arg env1 arg - ; (env2, new_args) <- zonk_args_rev env1 args - ; return (env2, (new_op, new_arg) : new_args) } - zonk_args_rev env [] = return (env, []) - - zonk_arg env (ApplicativeArgOne pat expr) - = do { new_expr <- zonkLExpr env expr - ; return (ApplicativeArgOne pat new_expr) } - zonk_arg env (ApplicativeArgMany stmts ret pat) - = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts - ; new_ret <- zonkExpr env1 ret - ; return (ApplicativeArgMany new_stmts new_ret pat) } - -------------------------------------------------------------------------- -zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) -zonkRecFields env (HsRecFields flds dd) - = do { flds' <- mapM zonk_rbind flds - ; 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 })) } - -zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField TcId] -> TcM [LHsRecUpdField TcId] -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) - -{- -************************************************************************ -* * -\subsection[BackSubst-Pats]{Patterns} -* * -************************************************************************ --} - -zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id) --- Extend the environment as we go, because it's possible for one --- pattern to bind something that is used in another (inside or --- to the right) -zonkPat env pat = wrapLocSndM (zonk_pat env) pat - -zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id) -zonk_pat env (ParPat p) - = do { (env', p') <- zonkPat env p - ; return (env', ParPat p') } - -zonk_pat env (WildPat ty) - = do { ty' <- zonkTcTypeToType env ty - ; ensureNotLevPoly ty' - (text "In a wildcard pattern") - ; return (env, WildPat ty') } - -zonk_pat env (VarPat (L l v)) - = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv1 env v', VarPat (L l v')) } - -zonk_pat env (LazyPat pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', LazyPat pat') } - -zonk_pat env (BangPat pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', BangPat pat') } - -zonk_pat env (AsPat (L loc v) pat) - = do { v' <- zonkIdBndr env v - ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat - ; return (env', AsPat (L loc v') pat') } - -zonk_pat env (ViewPat expr pat ty) - = do { expr' <- zonkLExpr env expr - ; (env', pat') <- zonkPat env pat - ; ty' <- zonkTcTypeToType env ty - ; return (env', ViewPat expr' pat' ty') } - -zonk_pat env (ListPat pats ty Nothing) - = do { ty' <- zonkTcTypeToType env ty - ; (env', pats') <- zonkPats env pats - ; return (env', ListPat pats' ty' Nothing) } - -zonk_pat env (ListPat pats ty (Just (ty2,wit))) - = do { (env', wit') <- zonkSyntaxExpr env wit - ; ty2' <- zonkTcTypeToType env' ty2 - ; ty' <- zonkTcTypeToType env' ty - ; (env'', pats') <- zonkPats env' pats - ; return (env'', ListPat pats' ty' (Just (ty2',wit'))) } - -zonk_pat env (PArrPat pats ty) - = do { ty' <- zonkTcTypeToType env ty - ; (env', pats') <- zonkPats env pats - ; return (env', PArrPat pats' ty') } - -zonk_pat env (TuplePat pats boxed tys) - = do { tys' <- mapM (zonkTcTypeToType env) tys - ; (env', pats') <- zonkPats env pats - ; return (env', TuplePat pats' boxed tys') } - -zonk_pat env (SumPat pat alt arity tys) - = do { tys' <- mapM (zonkTcTypeToType env) tys - ; (env', pat') <- zonkPat env pat - ; return (env', SumPat pat' alt arity tys') } - -zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars - , pat_dicts = evs, pat_binds = binds - , pat_args = args, pat_wrap = wrapper - , pat_con = L _ con }) - = ASSERT( all isImmutableTyVar tyvars ) - do { new_tys <- mapM (zonkTcTypeToType env) tys - - -- an unboxed tuple pattern (but only an unboxed tuple pattern) - -- might have levity-polymorphic arguments. Check for this badness. - ; case con of - RealDataCon dc - | isUnboxedTupleTyCon (dataConTyCon dc) - -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys) - _ -> return () - - ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars - -- Must zonk the existential variables, because their - -- /kind/ need potential zonking. - -- cf typecheck/should_compile/tc221.hs - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_binds) <- zonkTcEvBinds env1 binds - ; (env3, new_wrapper) <- zonkCoFn env2 wrapper - ; (env', new_args) <- zonkConStuff env3 args - ; return (env', p { pat_arg_tys = new_tys, - pat_tvs = new_tyvars, - pat_dicts = new_evs, - pat_binds = new_binds, - pat_args = new_args, - pat_wrap = new_wrapper}) } - where - doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p - -zonk_pat env (LitPat lit) = return (env, LitPat lit) - -zonk_pat env (SigPatOut pat ty) - = do { ty' <- zonkTcTypeToType env ty - ; (env', pat') <- zonkPat env pat - ; return (env', SigPatOut pat' ty') } - -zonk_pat env (NPat (L l lit) mb_neg eq_expr ty) - = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr - ; (env2, mb_neg') <- case mb_neg of - Nothing -> return (env1, Nothing) - Just n -> second Just <$> zonkSyntaxExpr env1 n - - ; lit' <- zonkOverLit env2 lit - ; ty' <- zonkTcTypeToType env2 ty - ; return (env2, NPat (L l lit') mb_neg' eq_expr' ty') } - -zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty) - = do { (env1, e1') <- zonkSyntaxExpr env e1 - ; (env2, e2') <- zonkSyntaxExpr env1 e2 - ; n' <- zonkIdBndr env2 n - ; lit1' <- zonkOverLit env2 lit1 - ; lit2' <- zonkOverLit env2 lit2 - ; ty' <- zonkTcTypeToType env2 ty - ; return (extendIdZonkEnv1 env2 n', - NPlusKPat (L loc n') (L l lit1') lit2' e1' e2' ty') } - -zonk_pat env (CoPat co_fn pat ty) - = do { (env', co_fn') <- zonkCoFn env co_fn - ; (env'', pat') <- zonkPat env' (noLoc pat) - ; ty' <- zonkTcTypeToType env'' ty - ; return (env'', CoPat co_fn' (unLoc pat') ty') } - -zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) - ---------------------------- -zonkConStuff :: ZonkEnv - -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId)) - -> TcM (ZonkEnv, - HsConDetails (OutPat Id) (HsRecFields id (OutPat Id))) -zonkConStuff env (PrefixCon pats) - = do { (env', pats') <- zonkPats env pats - ; return (env', PrefixCon pats') } - -zonkConStuff env (InfixCon p1 p2) - = do { (env1, p1') <- zonkPat env p1 - ; (env', p2') <- zonkPat env1 p2 - ; return (env', InfixCon p1' p2') } - -zonkConStuff env (RecCon (HsRecFields rpats dd)) - = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats) - ; let rpats' = zipWith (\(L l rp) p' -> L l (rp { hsRecFieldArg = p' })) - rpats pats' - ; return (env', RecCon (HsRecFields rpats' dd)) } - -- Field selectors have declared types; hence no zonking - ---------------------------- -zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id]) -zonkPats env [] = return (env, []) -zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat - ; (env', pats') <- zonkPats env1 pats - ; return (env', pat':pats') } - -{- -************************************************************************ -* * -\subsection[BackSubst-Foreign]{Foreign exports} -* * -************************************************************************ --} - -zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id] -zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls - -zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id) -zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec }) - = return (ForeignExport { fd_name = fmap (zonkIdOcc env) i - , fd_sig_ty = undefined, fd_co = co - , fd_fe = spec }) -zonkForeignExport _ for_imp - = return for_imp -- Foreign imports don't need zonking - -zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id] -zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs - -zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) -zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) - = do { (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env vars - - ; let env_lhs = setZonkType env_inside zonkTvSkolemising - -- See Note [Zonking the LHS of a RULE] - - ; new_lhs <- zonkLExpr env_lhs lhs - ; new_rhs <- zonkLExpr env_inside rhs - - ; return (HsRule name act new_bndrs new_lhs fv_lhs new_rhs fv_rhs) } - where - zonk_bndr env (L l (RuleBndr (L loc v))) - = do { (env', v') <- zonk_it env v - ; return (env', L l (RuleBndr (L loc v'))) } - zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig" - - zonk_it env v - | isId v = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnvRec env [v'], v') } - | otherwise = ASSERT( isImmutableTyVar v) - zonkTyBndrX env v - -- DV: used to be return (env,v) but that is plain - -- wrong because we may need to go inside the kind - -- of v and zonk there! - -zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] -zonkVects env = mapM (wrapLocM (zonkVect env)) - -zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id) -zonkVect env (HsVect s v e) - = do { v' <- wrapLocM (zonkIdBndr env) v - ; e' <- zonkLExpr env e - ; return $ HsVect s v' e' - } -zonkVect env (HsNoVect s v) - = do { v' <- wrapLocM (zonkIdBndr env) v - ; return $ HsNoVect s v' - } -zonkVect _env (HsVectTypeOut s t rt) - = return $ HsVectTypeOut s t rt -zonkVect _ (HsVectTypeIn _ _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn" -zonkVect _env (HsVectClassOut c) - = return $ HsVectClassOut c -zonkVect _ (HsVectClassIn _ _) = panic "TcHsSyn.zonkVect: HsVectClassIn" -zonkVect _env (HsVectInstOut i) - = return $ HsVectInstOut i -zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn" - -{- -************************************************************************ -* * - Constraints and evidence -* * -************************************************************************ --} - -zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm -zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) - zonkEvVarOcc env v -zonkEvTerm env (EvCoercion co) = do { co' <- zonkCoToCo env co - ; return (EvCoercion co') } -zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm - ; co' <- zonkCoToCo env co - ; return (mkEvCast tm' co') } -zonkEvTerm _ (EvLit l) = return (EvLit l) - -zonkEvTerm env (EvTypeable ty ev) = - do { ev' <- zonkEvTypeable env ev - ; ty' <- zonkTcTypeToType env ty - ; return (EvTypeable ty' ev') } -zonkEvTerm env (EvCallStack cs) - = case cs of - EvCsEmpty -> return (EvCallStack cs) - EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm - ; return (EvCallStack (EvCsPushCall n l tm')) } - -zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d - ; return (EvSuperClass d' n) } -zonkEvTerm env (EvDFunApp df tys tms) - = do { tys' <- zonkTcTypeToTypes env tys - ; tms' <- mapM (zonkEvTerm env) tms - ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } -zonkEvTerm env (EvDelayedError ty msg) - = do { ty' <- zonkTcTypeToType env ty - ; return (EvDelayedError ty' msg) } -zonkEvTerm env (EvSelector sel_id tys tms) - = do { sel_id' <- zonkIdBndr env sel_id - ; tys' <- zonkTcTypeToTypes env tys - ; tms' <- mapM (zonkEvTerm env) tms - ; return (EvSelector sel_id' tys' tms') } - -zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable -zonkEvTypeable env (EvTypeableTyCon tycon e) - = do { e' <- mapM (zonkEvTerm env) e - ; return $ EvTypeableTyCon tycon e' } -zonkEvTypeable env (EvTypeableTyApp t1 t2) - = do { t1' <- zonkEvTerm env t1 - ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTyApp t1' t2') } -zonkEvTypeable env (EvTypeableTrFun t1 t2) - = do { t1' <- zonkEvTerm env t1 - ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTrFun t1' t2') } -zonkEvTypeable env (EvTypeableTyLit t1) - = do { t1' <- zonkEvTerm env t1 - ; return (EvTypeableTyLit t1') } - -zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds]) -zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs - ; return (env, [EvBinds (unionManyBags bs')]) } - -zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) -zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs - ; return (env', EvBinds bs') } - -zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind) -zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var -zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs - -zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind) -zonkEvBindsVar env (EvBindsVar { ebv_binds = ref }) - = do { bs <- readMutVar ref - ; zonkEvBinds env (evBindMapBinds bs) } - -zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) -zonkEvBinds env binds - = {-# SCC "zonkEvBinds" #-} - fixM (\ ~( _, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds) - ; binds' <- mapBagM (zonkEvBind env1) binds - ; return (env1, binds') }) - where - collect_ev_bndrs :: Bag EvBind -> [EvVar] - collect_ev_bndrs = foldrBag add [] - add (EvBind { eb_lhs = var }) vars = var : vars - -zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind -zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term }) - = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var - - -- Optimise the common case of Refl coercions - -- See Note [Optimise coercion zonking] - -- This has a very big effect on some programs (eg Trac #5030) - - ; term' <- case getEqPredTys_maybe (idType var') of - Just (r, ty1, ty2) | ty1 `eqType` ty2 - -> return (EvCoercion (mkTcReflCo r ty1)) - _other -> zonkEvTerm env term - - ; return (bind { eb_lhs = var', eb_rhs = term' }) } - -{- -************************************************************************ -* * - Zonking types -* * -************************************************************************ - -Note [Zonking mutable unbound type or kind variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In zonkTypeZapping, we zonk mutable but unbound type or kind variables to an -arbitrary type. We know if they are unbound even though we don't carry an -environment, because at the binding site for a variable we bind the mutable -var to a fresh immutable one. So the mutable store plays the role of an -environment. If we come across a mutable variable that isn't so bound, it -must be completely free. We zonk the expected kind to make sure we don't get -some unbound meta variable as the kind. - -Note that since we have kind polymorphism, zonk_unbound_tyvar will handle both -type and kind variables. Consider the following datatype: - - data Phantom a = Phantom Int - -The type of Phantom is (forall (k : *). forall (a : k). Int). Both `a` and -`k` are unbound variables. We want to zonk this to -(forall (k : Any *). forall (a : Any (Any *)). Int). - -Note [Optimise coercion zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When optimising evidence binds we may come across situations where -a coercion looks like - cv = ReflCo ty -or cv1 = cv2 -where the type 'ty' is big. In such cases it is a waste of time to zonk both - * The variable on the LHS - * The coercion on the RHS -Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just -use Refl on the right, ignoring the actual coercion on the RHS. - -This can have a very big effect, because the constraint solver sometimes does go -to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf Trac #5030) - --} - -zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType -zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv - | isTcTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> lookup_in_env - RuntimeUnk {} -> lookup_in_env - FlatSkol ty -> zonkTcTypeToType env ty - MetaTv { mtv_ref = ref } - -> do { cts <- readMutVar ref - ; case cts of - Flexi -> do { kind <- {-# SCC "zonkKind1" #-} - zonkTcTypeToType env (tyVarKind tv) - ; zonk_unbound_tyvar (setTyVarKind tv kind) } - Indirect ty -> do { zty <- zonkTcTypeToType env ty - -- Small optimisation: shortern-out indirect steps - -- so that the old type may be more easily collected. - ; writeMutVar ref (Indirect zty) - ; return zty } } - | otherwise - = lookup_in_env - where - lookup_in_env -- Look up in the env just as we do for Ids - = case lookupVarEnv tv_env tv of - Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToType env) tv - Just tv' -> return (mkTyVarTy tv') - -zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion -zonkCoVarOcc env@(ZonkEnv _ tyco_env _) cv - | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env - = return $ mkCoVarCo cv' - | otherwise - = mkCoVarCo <$> updateVarTypeM (zonkTcTypeToType env) cv - -zonkCoHole :: ZonkEnv -> CoercionHole - -> Role -> Type -> Type -- these are all redundant with - -- the details in the hole, - -- unzonked - -> TcM Coercion -zonkCoHole env h r t1 t2 - = do { contents <- unpackCoercionHole_maybe h - ; case contents of - Just co -> do { co <- zonkCoToCo env co - ; checkCoercionHole co h r t1 t2 } - - -- This next case should happen only in the presence of - -- (undeferred) type errors. Originally, I put in a panic - -- here, but that caused too many uses of `failIfErrsM`. - Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr h) - ; when debugIsOn $ - whenNoErrs $ - MASSERT2( False - , text "Type-correct unfilled coercion hole" - <+> ppr h ) - ; t1 <- zonkTcTypeToType env t1 - ; t2 <- zonkTcTypeToType env t2 - ; return $ mkHoleCo h r t1 t2 } } - -zonk_tycomapper :: TyCoMapper ZonkEnv TcM -zonk_tycomapper = TyCoMapper - { tcm_smart = True -- Establish type invariants - -- See Note [Type-checking inside the knot] in TcHsType - , tcm_tyvar = zonkTyVarOcc - , tcm_covar = zonkCoVarOcc - , tcm_hole = zonkCoHole - , tcm_tybinder = \env tv _vis -> zonkTyBndrX env tv } - --- Confused by zonking? See Note [What is zonking?] in TcMType. -zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type -zonkTcTypeToType = mapType zonk_tycomapper - -zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type] -zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys - -zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion -zonkCoToCo = mapCoercion zonk_tycomapper - -zonkSigType :: TcType -> TcM Type --- Zonk the type obtained from a user type signature --- We want to turn any quantified (forall'd) variables into TyVars --- but we may find some free TcTyVars, and we want to leave them --- completely alone. They may even have unification variables inside --- e.g. f (x::a) = ...(e :: a -> a).... --- The type sig for 'e' mentions a free 'a' which will be a --- unification SigTv variable. -zonkSigType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_tv) - where - zonk_unbound_tv :: UnboundTyVarZonker - zonk_unbound_tv tv = return (mkTyVarTy tv) - -zonkTvSkolemising :: UnboundTyVarZonker --- This variant is used for the LHS of rules --- See Note [Zonking the LHS of a RULE]. -zonkTvSkolemising tv - = do { let tv' = mkTyVar (tyVarName tv) (tyVarKind tv) - -- NB: the kind of tv is already zonked - ty = mkTyVarTy tv' - -- Make a proper TyVar (remember we - -- are now done with type checking) - ; writeMetaTyVar tv ty - ; return ty } - -zonkTypeZapping :: UnboundTyVarZonker --- This variant is used for everything except the LHS of rules --- It zaps unbound type variables to Any, except for RuntimeRep --- vars which it zonks to LiftedRep --- Works on both types and kinds -zonkTypeZapping tv - = do { let ty | isRuntimeRepVar tv = liftedRepTy - | otherwise = anyTypeOfKind (tyVarKind tv) - ; writeMetaTyVar tv ty - ; return ty } - ---------------------------------------- -{- Note [Zonking the LHS of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also DsBinds Note [Free tyvars on rule LHS] - -We need to gather the type variables mentioned on the LHS so we can -quantify over them. Example: - data T a = C - - foo :: T a -> Int - foo C = 1 - - {-# RULES "myrule" foo C = 1 #-} - -After type checking the LHS becomes (foo alpha (C alpha)) and we do -not want to zap the unbound meta-tyvar 'alpha' to Any, because that -limits the applicability of the rule. Instead, we want to quantify -over it! - -We do this in two stages. - -* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We - do this by using zonkTvSkolemising as the UnboundTyVarZonker in the - ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a - UnboundTyVarZonker.) - -* In DsBinds, we quantify over it. See DsBinds - Note [Free tyvars on rule LHS] - -Quantifying here is awkward because (a) the data type is big and (b) -finding the free type vars of an expression is necessarily monadic -operation. (consider /\a -> f @ b, where b is side-effected to a) --} diff --git a/typecheck/TcHsType.hs b/typecheck/TcHsType.hs deleted file mode 100644 --- a/typecheck/TcHsType.hs +++ /dev/null @@ -1,2211 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcMonoType]{Typechecking user-specified @MonoTypes@} --} - -{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} - -module TcHsType ( - -- Type signatures - kcHsSigType, tcClassSigType, - tcHsSigType, tcHsSigWcType, - tcHsPartialSigType, - funsSigCtxt, addSigCtxt, pprSigCtxt, - - tcHsClsInstType, - tcHsDeriv, tcHsVectInst, - tcHsTypeApp, - UserTypeCtxt(..), - tcImplicitTKBndrs, tcImplicitTKBndrsType, tcExplicitTKBndrs, - - -- Type checking type and class decls - kcLookupTcTyCon, kcTyClTyVars, tcTyClTyVars, - tcDataKindSig, - - -- Kind-checking types - -- No kind generalisation, no checkValidType - tcWildCardBinders, - kcHsTyVarBndrs, - tcHsLiftedType, tcHsOpenType, - tcHsLiftedTypeNC, tcHsOpenTypeNC, - tcLHsType, tcCheckLHsType, - tcHsContext, tcLHsPredType, tcInferApps, tcInferArgs, - solveEqualities, -- useful re-export - - kindGeneralize, - - -- Sort-checking kinds - tcLHsKindSig, - - -- Pattern type signatures - tcHsPatSigType, tcPatSig, funAppCtxt - ) where - -#include "HsVersions.h" - -import HsSyn -import TcRnMonad -import TcEvidence -import TcEnv -import TcMType -import TcValidity -import TcUnify -import TcIface -import TcSimplify ( solveEqualities ) -import TcType -import TcHsSyn( zonkSigType ) -import Inst ( tcInstBindersX, tcInstBinderX ) -import Type -import Kind -import RdrName( lookupLocalRdrOcc ) -import Var -import VarSet -import TyCon -import ConLike -import DataCon -import Class -import Name -import NameEnv -import NameSet -import VarEnv -import TysWiredIn -import BasicTypes -import SrcLoc -import Constants ( mAX_CTUPLE_SIZE ) -import ErrUtils( MsgDoc ) -import Unique -import Util -import UniqSupply -import Outputable -import FastString -import PrelNames hiding ( wildCardName ) -import qualified GHC.LanguageExtensions as LangExt - -import Maybes -import Data.List ( partition, zipWith4 ) -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. -This is because some type-checking is done in a mutually-recursive knot, and -if we look too closely at the tycons, we'll loop. This is why we always must -use mkNakedTyConApp and mkNakedAppTys, etc., which never look at a tycon. -The mkNamed... functions don't uphold Type invariants, but zonkTcTypeToType -will repair this for us. Note that zonkTcType *is* safe within a knot, and -can be done repeatedly with no ill effect: it just squeezes out metavariables. - -Generally, after type-checking, you will want to do validity checking, say -with TcValidity.checkValidType. - -Validity checking -~~~~~~~~~~~~~~~~~ -Some of the validity check could in principle be done by the kind checker, -but not all: - -- During desugaring, we normalise by expanding type synonyms. Only - after this step can we check things like type-synonym saturation - e.g. type T k = k Int - type S a = a - Then (T S) is ok, because T is saturated; (T S) expands to (S Int); - and then S is saturated. This is a GHC extension. - -- Similarly, also a GHC extension, we look through synonyms before complaining - about the form of a class or instance declaration - -- Ambiguity checks involve functional dependencies, and it's easier to wait - until knots have been resolved before poking into them - -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). - -Knot tying -~~~~~~~~~~ -During step (1) we might fault in a TyCon defined in another module, and it might -(via a loop) refer back to a TyCon defined in this module. So when we tie a big -knot around type declarations with ARecThing, so that the fault-in code can get -the TyCon being defined. - -%************************************************************************ -%* * - Check types AND do validity checking -* * -************************************************************************ --} - -funsSigCtxt :: [Located Name] -> UserTypeCtxt --- Returns FunSigCtxt, with no redundant-context-reporting, --- form a list of located names -funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False -funsSigCtxt [] = panic "funSigCtxt" - -addSigCtxt :: UserTypeCtxt -> LHsType Name -> TcM a -> TcM a -addSigCtxt ctxt hs_ty thing_inside - = setSrcSpan (getLoc hs_ty) $ - addErrCtxt (pprSigCtxt ctxt hs_ty) $ - thing_inside - -pprSigCtxt :: UserTypeCtxt -> LHsType Name -> SDoc --- (pprSigCtxt ctxt ) --- prints In the type signature for 'f': --- f :: --- The 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 Name -> TcM Type --- This one is used when we have a LHsSigWcType, but in --- a place where wildards aren't allowed. The renamer has --- already checked this, so we can simply ignore it. -tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) - -kcHsSigType :: [Located Name] -> LHsSigType Name -> TcM () -kcHsSigType names (HsIB { hsib_body = hs_ty - , hsib_vars = sig_vars }) - = addSigCtxt (funsSigCtxt names) hs_ty $ - discardResult $ - tcImplicitTKBndrsType sig_vars $ - tc_lhs_type typeLevelMode hs_ty liftedTypeKind - -tcClassSigType :: [Located Name] -> LHsSigType Name -> TcM Type --- Does not do validity checking; this must be done outside --- the recursive class declaration "knot" -tcClassSigType names sig_ty - = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ - tc_hs_sig_type_and_gen sig_ty liftedTypeKind - -tcHsSigType :: UserTypeCtxt -> LHsSigType Name -> TcM Type --- Does validity checking -tcHsSigType ctxt sig_ty - = addSigCtxt ctxt (hsSigType sig_ty) $ - do { kind <- case expectedKindInCtxt ctxt of - AnythingKind -> newMetaKindVar - TheKind k -> return k - OpenKind -> newOpenTypeKind - -- The kind is checked by checkValidType, and isn't necessarily - -- of kind * in a Template Haskell quote eg [t| Maybe |] - - -- Generalise here: see Note [Kind generalisation] - ; do_kind_gen <- decideKindGeneralisationPlan sig_ty - ; ty <- if do_kind_gen - then tc_hs_sig_type_and_gen sig_ty kind - else tc_hs_sig_type sig_ty kind >>= zonkTcType - - ; checkValidType ctxt ty - ; return ty } - -tc_hs_sig_type_and_gen :: LHsSigType Name -> Kind -> TcM Type --- Kind-checks/desugars an 'LHsSigType', --- solve equalities, --- and then kind-generalizes. --- This will never emit constraints, as it uses solveEqualities interally. --- No validity checking, but it does zonk en route to generalization -tc_hs_sig_type_and_gen hs_ty kind - = do { ty <- solveEqualities $ - tc_hs_sig_type hs_ty kind - -- NB the call to solveEqualities, which unifies all those - -- kind variables floating about, immediately prior to - -- kind generalisation - ; kindGeneralizeType ty } - -tc_hs_sig_type :: LHsSigType Name -> Kind -> TcM Type --- Kind-check/desugar a 'LHsSigType', but does not solve --- the equalities that arise from doing so; instead it may --- emit kind-equality constraints into the monad --- No zonking or validity checking -tc_hs_sig_type (HsIB { hsib_vars = sig_vars - , hsib_body = hs_ty }) kind - = do { (tkvs, ty) <- tcImplicitTKBndrsType sig_vars $ - tc_lhs_type typeLevelMode hs_ty kind - ; return (mkSpecForAllTys tkvs ty) } - ------------------ -tcHsDeriv :: LHsSigType Name -> 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]) -tcHsDeriv hs_ty - = do { cls_kind <- newMetaKindVar - -- always safe to kind-generalize, because there - -- can be no covars in an outer scope - ; ty <- checkNoErrs $ - -- avoid redundant error report with "illegal deriving", below - tc_hs_sig_type_and_gen hs_ty cls_kind - ; cls_kind <- zonkTcType cls_kind - ; let (tvs, pred) = splitForAllTys ty - ; let (args, _) = splitFunTys cls_kind - ; case getClassPredTys_maybe pred of - Just (cls, tys) -> return (tvs, cls, tys, args) - Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } - -tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt - -> LHsSigType Name - -> TcM ([TyVar], ThetaType, Class, [Type]) --- Like tcHsSigType, but for a class instance declaration -tcHsClsInstType user_ctxt hs_inst_ty - = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $ - do { inst_ty <- tc_hs_sig_type_and_gen hs_inst_ty constraintKind - ; checkValidInstance user_ctxt hs_inst_ty inst_ty } - --- Used for 'VECTORISE [SCALAR] instance' declarations -tcHsVectInst :: LHsSigType Name -> TcM (Class, [Type]) -tcHsVectInst ty - | Just (L _ cls_name, tys) <- hsTyGetAppHead_maybe (hsSigType ty) - -- Ignoring the binders looks pretty dodgy to me - = do { (cls, cls_kind) <- tcClass cls_name - ; (applied_class, _res_kind) - <- tcInferApps typeLevelMode cls_name (mkClassPred cls []) cls_kind tys - ; case tcSplitTyConApp_maybe applied_class of - Just (_tc, args) -> ASSERT( _tc == classTyCon cls ) - return (cls, args) - _ -> failWithTc (text "Too many arguments passed to" <+> ppr cls_name) } - | otherwise - = failWithTc $ text "Malformed instance type" - ----------------------------------------------- --- | Type-check a visible type application -tcHsTypeApp :: LHsWcType Name -> Kind -> TcM Type -tcHsTypeApp wc_ty kind - | HsWC { hswc_wcs = sig_wcs, hswc_body = hs_ty } <- wc_ty - = do { ty <- tcWildCardBindersX newWildTyVar sig_wcs $ \ _ -> - tcCheckLHsType hs_ty kind - ; ty <- zonkTcType ty - ; checkValidType TypeAppCtxt ty - ; return ty } - -- NB: we don't call emitWildcardHoleConstraints here, because - -- we want any holes in visible type applications to be used - -- without fuss. No errors, warnings, extensions, etc. - -{- -************************************************************************ -* * - The main kind checker: no validity checks here -* * -************************************************************************ - - First a couple of simple wrappers for kcHsType --} - ---------------------------- -tcHsOpenType, tcHsLiftedType, - tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType Name -> TcM TcType --- Used for type signatures --- Do not do validity checking -tcHsOpenType ty = addTypeCtxt ty $ tcHsOpenTypeNC ty -tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty - -tcHsOpenTypeNC ty = do { ek <- newOpenTypeKind - ; tc_lhs_type typeLevelMode ty ek } -tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind - --- Like tcHsType, but takes an expected kind -tcCheckLHsType :: LHsType Name -> Kind -> TcM Type -tcCheckLHsType hs_ty exp_kind - = addTypeCtxt hs_ty $ - tc_lhs_type typeLevelMode hs_ty exp_kind - -tcLHsType :: LHsType Name -> TcM (TcType, TcKind) --- Called from outside: set the context -tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty) - ---------------------------- --- | Should we generalise the kind of this type signature? --- We *should* generalise if the type is closed --- or if NoMonoLocalBinds is set. Otherwise, nope. --- See Note [Kind generalisation plan] -decideKindGeneralisationPlan :: LHsSigType Name -> TcM Bool -decideKindGeneralisationPlan sig_ty@(HsIB { hsib_closed = closed }) - = do { mono_locals <- xoptM LangExt.MonoLocalBinds - ; let should_gen = not mono_locals || closed - ; traceTc "decideKindGeneralisationPlan" - (ppr sig_ty $$ text "should gen?" <+> ppr should_gen) - ; return should_gen } - -{- Note [Kind generalisation plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When should we do kind-generalisation for user-written type signature? -Answer: we use the same rule as for value bindings: - - * We always kind-generalise if the type signature is closed - * Additionally, we attempt to generalise if we have NoMonoLocalBinds - -Trac #13337 shows the problem if we kind-generalise an open type (i.e. -one that mentions in-scope tpe variable - foo :: forall k (a :: k) proxy. (Typeable k, Typeable a) - => proxy a -> String - foo _ = case eqT :: Maybe (k :~: Type) of - Nothing -> ... - Just Refl -> case eqT :: Maybe (a :~: Int) of ... - -In the expression type sig on the last line, we have (a :: k) -but (Int :: Type). Since (:~:) is kind-homogeneous, this requires -k ~ *, which is true in the Refl branch of the outer case. - -That equality will be solved if we allow it to float out to the -implication constraint for the Refl match, bnot not if we aggressively -attempt to solve all equalities the moment they occur; that is, when -checking (Maybe (a :~: Int)). (NB: solveEqualities fails unless it -solves all the kind equalities, which is the right thing at top level.) - -So here the right thing is simply not to do kind generalisation! - -************************************************************************ -* * - 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. - --} - --- | 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. -newtype TcTyMode - = TcTyMode { mode_level :: TypeOrKind -- True <=> type, False <=> kind - } - -typeLevelMode :: TcTyMode -typeLevelMode = TcTyMode { mode_level = TypeLevel } - -kindLevelMode :: TcTyMode -kindLevelMode = TcTyMode { mode_level = KindLevel } - --- switch to kind level -kindLevel :: TcTyMode -> TcTyMode -kindLevel mode = mode { mode_level = KindLevel } - -instance Outputable TcTyMode where - ppr = ppr . mode_level - -{- -Note [Bidirectional type checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In expressions, whenever we see a polymorphic identifier, say `id`, we are -free to instantiate it with metavariables, knowing that we can always -re-generalize with type-lambdas when necessary. For example: - - rank2 :: (forall a. a -> a) -> () - x = rank2 id - -When checking the body of `x`, we can instantiate `id` with a metavariable. -Then, when we're checking the application of `rank2`, we notice that we really -need a polymorphic `id`, and then re-generalize over the unconstrained -metavariable. - -In types, however, we're not so lucky, because *we cannot re-generalize*! -There is no lambda. So, we must be careful only to instantiate at the last -possible moment, when we're sure we're never going to want the lost polymorphism -again. This is done in calls to tcInstBinders and tcInstBindersX. - -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 Name -> TcM (TcType, TcKind) -tc_infer_lhs_type mode (L span ty) - = setSrcSpan span $ - do { (ty', kind) <- tc_infer_hs_type mode ty - ; return (ty', kind) } - --- | Infer the kind of a type and desugar. This is the "up" type-checker, --- as described in Note [Bidirectional type checking] -tc_infer_hs_type :: TcTyMode -> HsType Name -> TcM (TcType, TcKind) -tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode tv -tc_infer_hs_type mode (HsAppTy ty1 ty2) - = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] - ; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty - ; fun_kind' <- zonkTcType fun_kind - ; tcInferApps mode fun_ty fun_ty' fun_kind' arg_tys } -tc_infer_hs_type mode (HsParTy t) = tc_infer_lhs_type mode t -tc_infer_hs_type mode (HsOpTy lhs (L _ op) rhs) - | not (op `hasKey` funTyConKey) - = do { (op', op_kind) <- tcTyVar mode op - ; op_kind' <- zonkTcType op_kind - ; tcInferApps mode op op' op_kind' [lhs, rhs] } -tc_infer_hs_type mode (HsKindSig ty sig) - = do { sig' <- tc_lhs_kind (kindLevel mode) sig - ; ty' <- tc_lhs_type mode ty sig' - ; return (ty', sig') } --- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType' to communicate --- the splice location to the typechecker. Here we skip over it in order to have --- the same kind inferred for a given expression whether it was produced from --- splices or not. --- --- See Note [Delaying modFinalizers in untyped splices]. -tc_infer_hs_type mode (HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _) - = tc_infer_hs_type mode ty -tc_infer_hs_type mode (HsDocTy ty _) = tc_infer_lhs_type mode ty -tc_infer_hs_type _ (HsCoreTy ty) = return (ty, typeKind ty) -tc_infer_hs_type mode other_ty - = do { kv <- newMetaKindVar - ; ty' <- tc_hs_type mode other_ty kv - ; return (ty', kv) } - ------------------------------------------- -tc_lhs_type :: TcTyMode -> LHsType Name -> TcKind -> TcM TcType -tc_lhs_type mode (L span ty) exp_kind - = setSrcSpan span $ - do { ty' <- tc_hs_type mode ty exp_kind - ; return ty' } - ------------------------------------------- -tc_fun_type :: TcTyMode -> LHsType Name -> LHsType Name -> TcKind -> TcM TcType -tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of - TypeLevel -> - do { arg_k <- newOpenTypeKind - ; res_k <- newOpenTypeKind - ; ty1' <- tc_lhs_type mode ty1 arg_k - ; ty2' <- tc_lhs_type mode ty2 res_k - ; checkExpectedKind (mkFunTy ty1' ty2') liftedTypeKind exp_kind } - KindLevel -> -- no representation polymorphism in kinds. yet. - do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind - ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind - ; checkExpectedKind (mkFunTy ty1' ty2') liftedTypeKind exp_kind } - ------------------------------------------- --- See also Note [Bidirectional type checking] -tc_hs_type :: TcTyMode -> HsType Name -> TcKind -> TcM TcType -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 {}) _ - -- 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) - = failWithTc (text "Unexpected strictness annotation:" <+> ppr ty) -tc_hs_type _ ty@(HsRecTy _) _ - -- Record types (which only show up temporarily in constructor - -- signatures) should have been removed by now - = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) - --- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'. --- Here we get rid of it and add the finalizers to the global environment --- while capturing the local environment. --- --- See Note [Delaying modFinalizers in untyped splices]. -tc_hs_type mode (HsSpliceTy (HsSpliced mod_finalizers (HsSplicedTy ty)) - _ - ) - exp_kind - = do addModFinalizersWithLclEnv mod_finalizers - tc_hs_type mode ty exp_kind - --- This should never happen; type splices are expanded by the renamer -tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind - = failWithTc (text "Unexpected type splice:" <+> ppr ty) - ----------- Functions and applications -tc_hs_type mode (HsFunTy ty1 ty2) exp_kind - = tc_fun_type mode ty1 ty2 exp_kind - -tc_hs_type mode (HsOpTy ty1 (L _ op) ty2) exp_kind - | op `hasKey` funTyConKey - = tc_fun_type mode ty1 ty2 exp_kind - ---------- Foralls -tc_hs_type mode (HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind - = fmap fst $ - tcExplicitTKBndrs hs_tvs $ \ tvs' -> - -- Do not kind-generalise here! See Note [Kind generalisation] - -- Why exp_kind? See Note [Body kind of HsForAllTy] - do { ty' <- tc_lhs_type mode ty exp_kind - ; let bound_vars = allBoundVariables ty' - bndrs = mkTyVarBinders Specified tvs' - ; return (mkForAllTys bndrs ty', bound_vars) } - -tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind - | null (unLoc ctxt) - = tc_lhs_type mode ty exp_kind - - | otherwise - = do { ctxt' <- tc_hs_context mode ctxt - - -- See Note [Body kind of a HsQualTy] - ; ty' <- if isConstraintKind exp_kind - then tc_lhs_type mode ty constraintKind - else do { ek <- newOpenTypeKind - -- The body kind (result of the function) - -- can be * or #, hence newOpenTypeKind - ; ty <- tc_lhs_type mode ty ek - ; checkExpectedKind ty liftedTypeKind exp_kind } - - ; return (mkPhiTy ctxt' ty') } - ---------- Lists, arrays, and tuples -tc_hs_type mode (HsListTy elt_ty) exp_kind - = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind - ; checkWiredInTyCon listTyCon - ; checkExpectedKind (mkListTy tau_ty) liftedTypeKind exp_kind } - -tc_hs_type mode (HsPArrTy elt_ty) exp_kind - = do { MASSERT( isTypeLevel (mode_level mode) ) - ; tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind - ; checkWiredInTyCon parrTyCon - ; checkExpectedKind (mkPArrTy tau_ty) liftedTypeKind exp_kind } - --- See Note [Distinguishing tuple kinds] in HsTypes --- See Note [Inferring tuple kinds] -tc_hs_type mode (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 mode tup_sort hs_tys exp_kind - | otherwise - = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) - ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys - ; kinds <- mapM zonkTcType kinds - -- Infer each arg type separately, because errors can be - -- confusing if we give them a shared kind. Eg Trac #7410 - -- (Either Int, Int), we do not want to get an error saying - -- "the second argument of a tuple should have kind *->*" - - ; let (arg_kind, tup_sort) - = case [ (k,s) | k <- kinds - , Just s <- [tupKindSort_maybe k] ] of - ((k,s) : _) -> (k,s) - [] -> (liftedTypeKind, BoxedTuple) - -- In the [] case, it's not clear what the kind is, so guess * - - ; tys' <- sequence [ setSrcSpan loc $ - checkExpectedKind ty kind arg_kind - | ((L loc _),ty,kind) <- zip3 hs_tys tys kinds ] - - ; finish_tuple tup_sort tys' (map (const arg_kind) tys') exp_kind } - - -tc_hs_type mode (HsTupleTy hs_tup_sort tys) exp_kind - = tc_tuple mode tup_sort tys exp_kind - where - tup_sort = case hs_tup_sort of -- Fourth case dealt with above - HsUnboxedTuple -> UnboxedTuple - HsBoxedTuple -> BoxedTuple - HsConstraintTuple -> ConstraintTuple - _ -> panic "tc_hs_type HsTupleTy" - -tc_hs_type mode (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 getRuntimeRepFromKind arg_kinds - arg_tys = arg_reps ++ tau_tys - ; checkExpectedKind (mkTyConApp (sumTyCon arity) arg_tys) - (unboxedSumKind arg_reps) - exp_kind - } - ---------- Promoted lists and tuples -tc_hs_type mode (HsExplicitListTy _ _k tys) exp_kind - = do { tks <- mapM (tc_infer_lhs_type mode) tys - ; (taus', kind) <- unifyKinds tks - ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') - ; checkExpectedKind 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 (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 - ; checkExpectedKind (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } - where - arity = length tys - ---------- Constraint types -tc_hs_type mode (HsIParamTy (L _ n) ty) exp_kind - = do { MASSERT( isTypeLevel (mode_level mode) ) - ; ty' <- tc_lhs_type mode ty liftedTypeKind - ; let n' = mkStrLitTy $ hsIPNameFS n - ; ipClass <- tcLookupClass ipClassName - ; checkExpectedKind (mkClassPred ipClass [n',ty']) - constraintKind exp_kind } - -tc_hs_type mode (HsEqTy ty1 ty2) exp_kind - = do { (ty1', kind1) <- tc_infer_lhs_type mode ty1 - ; (ty2', kind2) <- tc_infer_lhs_type mode ty2 - ; ty2'' <- checkExpectedKind ty2' kind2 kind1 - ; eq_tc <- tcLookupTyCon eqTyConName - ; let ty' = mkNakedTyConApp eq_tc [kind1, ty1', ty2''] - ; checkExpectedKind ty' constraintKind exp_kind } - ---------- Literals -tc_hs_type _ (HsTyLit (HsNumTy _ n)) exp_kind - = do { checkWiredInTyCon typeNatKindCon - ; checkExpectedKind (mkNumLitTy n) typeNatKind exp_kind } - -tc_hs_type _ (HsTyLit (HsStrTy _ s)) exp_kind - = do { checkWiredInTyCon typeSymbolKindCon - ; checkExpectedKind (mkStrLitTy s) typeSymbolKind exp_kind } - ---------- Potentially kind-polymorphic types: call the "up" checker --- See Note [Future-proofing the type checker] -tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(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@(HsCoreTy {}) ek = tc_infer_hs_type_ek mode ty ek - -tc_hs_type _ (HsWildCardTy wc) exp_kind - = do { wc_tv <- tcWildCardOcc wc exp_kind - ; return (mkTyVarTy wc_tv) } - --- disposed of by renamer -tc_hs_type _ ty@(HsAppsTy {}) _ - = pprPanic "tc_hs_tyep HsAppsTy" (ppr ty) - -tcWildCardOcc :: HsWildCardInfo Name -> Kind -> TcM TcTyVar -tcWildCardOcc wc_info exp_kind - = do { wc_tv <- tcLookupTyVar (wildCardName wc_info) - -- The wildcard's kind should be an un-filled-in meta tyvar - ; let Just wc_kind_var = tcGetTyVar_maybe (tyVarKind wc_tv) - ; writeMetaTyVar wc_kind_var exp_kind - ; return wc_tv } - ---------------------------- --- | Call 'tc_infer_hs_type' and check its result against an expected kind. -tc_infer_hs_type_ek :: TcTyMode -> HsType Name -> TcKind -> TcM TcType -tc_infer_hs_type_ek mode ty ek - = do { (ty', k) <- tc_infer_hs_type mode ty - ; checkExpectedKind ty' k ek } - ---------------------------- -tupKindSort_maybe :: TcKind -> Maybe TupleSort -tupKindSort_maybe k - | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' - | Just k' <- tcView k = tupKindSort_maybe k' - | isConstraintKind k = Just ConstraintTuple - | isLiftedTypeKind k = Just BoxedTuple - | otherwise = Nothing - -tc_tuple :: TcTyMode -> TupleSort -> [LHsType Name] -> TcKind -> TcM TcType -tc_tuple mode tup_sort tys exp_kind - = do { arg_kinds <- case tup_sort of - BoxedTuple -> return (nOfThem arity liftedTypeKind) - UnboxedTuple -> mapM (\_ -> newOpenTypeKind) tys - ConstraintTuple -> return (nOfThem arity constraintKind) - ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds - ; finish_tuple tup_sort tau_tys arg_kinds exp_kind } - where - arity = length tys - -finish_tuple :: TupleSort - -> [TcType] -- ^ argument types - -> [TcKind] -- ^ of these kinds - -> TcKind -- ^ expected kind of the whole tuple - -> TcM TcType -finish_tuple tup_sort tau_tys tau_kinds exp_kind - = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind) - ; let arg_tys = case tup_sort of - -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon - UnboxedTuple -> tau_reps ++ tau_tys - BoxedTuple -> tau_tys - ConstraintTuple -> tau_tys - ; tycon <- case tup_sort of - ConstraintTuple - | arity > mAX_CTUPLE_SIZE - -> failWith (bigConstraintTuple arity) - | otherwise -> tcLookupTyCon (cTupleTyConName arity) - BoxedTuple -> do { let tc = tupleTyCon Boxed arity - ; checkWiredInTyCon tc - ; return tc } - UnboxedTuple -> return (tupleTyCon Unboxed arity) - ; checkExpectedKind (mkTyConApp tycon arg_tys) res_kind exp_kind } - where - arity = length tau_tys - tau_reps = map getRuntimeRepFromKind tau_kinds - res_kind = case tup_sort of - UnboxedTuple -> unboxedTupleKind tau_reps - BoxedTuple -> liftedTypeKind - ConstraintTuple -> constraintKind - -bigConstraintTuple :: Arity -> MsgDoc -bigConstraintTuple arity - = hang (text "Constraint tuple arity too large:" <+> int arity - <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) - 2 (text "Instead, use a nested tuple") - ---------------------------- --- | Apply a type of a given kind to a list of arguments. This instantiates --- invisible parameters as necessary. However, it does *not* necessarily --- apply all the arguments, if the kind runs out of binders. --- Never calls 'matchExpectedFunKind'; when the kind runs out of binders, --- this stops processing. --- 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. --- This version will instantiate all invisible arguments left over after --- the visible ones. Used only when typechecking type/data family patterns --- (where we need to instantiate all remaining invisible parameters; for --- example, consider @type family F :: k where F = Int; F = Maybe@. We --- need to instantiate the @k@.) -tcInferArgs :: Outputable fun - => fun -- ^ the function - -> [TyConBinder] -- ^ function kind's binders - -> Maybe (VarEnv Kind) -- ^ possibly, kind info (see above) - -> [LHsType Name] -- ^ args - -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType Name], Int) - -- ^ (instantiating subst, un-insted leftover binders, - -- typechecked args, untypechecked args, n) -tcInferArgs fun tc_binders mb_kind_info args - = do { let binders = tyConBindersTyBinders tc_binders -- UGH! - ; (subst, leftover_binders, args', leftovers, n) - <- tc_infer_args typeLevelMode fun binders mb_kind_info args 1 - -- now, we need to instantiate any remaining invisible arguments - ; let (invis_bndrs, other_binders) = break isVisibleBinder leftover_binders - ; (subst', invis_args) - <- tcInstBindersX subst mb_kind_info invis_bndrs - ; return ( subst' - , other_binders - , args' `chkAppend` invis_args - , leftovers, n ) } - --- | See comments for 'tcInferArgs'. But this version does not instantiate --- any remaining invisible arguments. -tc_infer_args :: Outputable fun - => TcTyMode - -> fun -- ^ the function - -> [TyBinder] -- ^ function kind's binders (zonked) - -> Maybe (VarEnv Kind) -- ^ possibly, kind info (see above) - -> [LHsType Name] -- ^ args - -> Int -- ^ number to start arg counter at - -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType Name], Int) -tc_infer_args mode orig_ty binders mb_kind_info orig_args n0 - = go emptyTCvSubst binders orig_args n0 [] - where - go subst binders [] n acc - = return ( subst, binders, reverse acc, [], n ) - -- when we call this when checking type family patterns, we really - -- do want to instantiate all invisible arguments. During other - -- typechecking, we don't. - - go subst (binder:binders) all_args@(arg:args) n acc - | isInvisibleBinder binder - = do { traceTc "tc_infer_args (invis)" (ppr binder) - ; (subst', arg') <- tcInstBinderX mb_kind_info subst binder - ; go subst' binders all_args n (arg' : acc) } - - | otherwise - = do { traceTc "tc_infer_args (vis)" (ppr binder $$ ppr arg) - ; arg' <- addErrCtxt (funAppCtxt orig_ty arg n) $ - tc_lhs_type mode arg (substTyUnchecked subst $ - tyBinderType binder) - ; let subst' = extendTvSubstBinder subst binder arg' - ; go subst' binders args (n+1) (arg' : acc) } - - go subst [] all_args n acc - = return (subst, [], reverse acc, all_args, n) - --- | Applies a type to a list of arguments. --- Always consumes all the arguments, using 'matchExpectedFunKind' as --- necessary. If you wish to apply a type to a list of HsTypes, this is --- your function. --- Used for type-checking types only. -tcInferApps :: Outputable fun - => TcTyMode - -> fun -- ^ Function (for printing only) - -> TcType -- ^ Function (could be knot-tied) - -> TcKind -- ^ Function kind (zonked) - -> [LHsType Name] -- ^ Args - -> TcM (TcType, TcKind) -- ^ (f args, result kind) -tcInferApps mode orig_ty ty ki args = go ty ki args 1 - where - go fun fun_kind [] _ = return (fun, fun_kind) - go fun fun_kind args n - | let (binders, res_kind) = splitPiTys fun_kind - , not (null binders) - = do { (subst, leftover_binders, args', leftover_args, n') - <- tc_infer_args mode orig_ty binders Nothing args n - ; let fun_kind' = substTyUnchecked subst $ - mkPiTys leftover_binders res_kind - ; go (mkNakedAppTys fun args') fun_kind' leftover_args n' } - - go fun fun_kind all_args@(arg:args) n - = do { (co, arg_k, res_k) <- matchExpectedFunKind (length all_args) - fun fun_kind - ; arg' <- addErrCtxt (funAppCtxt orig_ty arg n) $ - tc_lhs_type mode arg arg_k - ; go (mkNakedAppTy (fun `mkNakedCastTy` co) arg') - res_k args (n+1) } - --------------------------- -checkExpectedKind :: TcType -- the type whose kind we're checking - -> TcKind -- the known kind of that type, k - -> TcKind -- the expected kind, exp_kind - -> TcM TcType -- a possibly-inst'ed, casted type :: exp_kind --- Instantiate a kind (if necessary) and then call unifyType --- (checkExpectedKind ty act_kind exp_kind) --- checks that the actual kind act_kind is compatible --- with the expected kind exp_kind -checkExpectedKind ty act_kind exp_kind - = do { (ty', act_kind') <- instantiate ty act_kind exp_kind - ; let origin = TypeEqOrigin { uo_actual = act_kind' - , uo_expected = exp_kind - , uo_thing = Just $ mkTypeErrorThing ty' - } - ; co_k <- uType origin KindLevel act_kind' exp_kind - ; traceTc "checkExpectedKind" (vcat [ ppr act_kind - , ppr exp_kind - , ppr co_k ]) - ; let result_ty = ty' `mkNakedCastTy` co_k - ; return result_ty } - 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. - instantiate :: TcType -- the type - -> TcKind -- of this kind - -> TcKind -- but expected to be of this one - -> TcM ( TcType -- the inst'ed type - , TcKind ) -- its new kind - instantiate ty act_ki exp_ki - = let (exp_bndrs, _) = splitPiTysInvisible exp_ki in - instantiateTyN (length exp_bndrs) ty act_ki - --- | Instantiate a type to have at most @n@ invisible arguments. -instantiateTyN :: Int -- ^ @n@ - -> TcType -- ^ the type - -> TcKind -- ^ its kind - -> TcM (TcType, TcKind) -- ^ The inst'ed type with kind -instantiateTyN n ty ki - = let (bndrs, inner_ki) = splitPiTysInvisible ki - num_to_inst = length bndrs - n - -- NB: splitAt is forgiving with invalid numbers - (inst_bndrs, leftover_bndrs) = splitAt num_to_inst bndrs - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ki)) - in - if num_to_inst <= 0 then return (ty, ki) else - do { (subst, inst_args) <- tcInstBindersX empty_subst Nothing inst_bndrs - ; let rebuilt_ki = mkPiTys leftover_bndrs inner_ki - ki' = substTy subst rebuilt_ki - ; traceTc "instantiateTyN" (vcat [ ppr ty <+> dcolon <+> ppr ki - , ppr subst - , ppr rebuilt_ki - , ppr ki' ]) - ; return (mkNakedAppTys ty inst_args, ki') } - ---------------------------- -tcHsContext :: LHsContext Name -> TcM [PredType] -tcHsContext = tc_hs_context typeLevelMode - -tcLHsPredType :: LHsType Name -> TcM PredType -tcLHsPredType = tc_lhs_pred typeLevelMode - -tc_hs_context :: TcTyMode -> LHsContext Name -> TcM [PredType] -tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) - -tc_lhs_pred :: TcTyMode -> LHsType Name -> TcM PredType -tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind - ---------------------------- -tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind) --- See Note [Type checking recursive type and class declarations] --- in TcTyClsDecls -tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon - = do { traceTc "lk1" (ppr name) - ; thing <- tcLookup name - ; case thing of - ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) - - ATcTyCon tc_tc -> do { -- See Note [GADT kind self-reference] - unless - (isTypeLevel (mode_level mode)) - (promotionErr name TyConPE) - ; check_tc tc_tc - ; tc <- get_loopy_tc name tc_tc - ; handle_tyfams tc tc_tc } - -- mkNakedTyConApp: see Note [Type-checking inside the knot] - -- NB: we really should check if we're at the kind level - -- and if the tycon is promotable if -XNoTypeInType is set. - -- But this is a terribly large amount of work! Not worth it. - - AGlobal (ATyCon tc) - -> do { check_tc tc - ; handle_tyfams tc tc } - - AGlobal (AConLike (RealDataCon dc)) - -> do { data_kinds <- xoptM LangExt.DataKinds - ; unless (data_kinds || specialPromotedDc dc) $ - promotionErr name NoDataKindsDC - ; type_in_type <- xoptM LangExt.TypeInType - ; unless ( type_in_type || - ( isTypeLevel (mode_level mode) && - isLegacyPromotableDataCon dc ) || - ( isKindLevel (mode_level mode) && - specialPromotedDc dc ) ) $ - promotionErr name NoTypeInTypeDC - ; let tc = promoteDataCon dc - ; return (mkNakedTyConApp tc [], tyConKind tc) } - - APromotionErr err -> promotionErr name err - - _ -> wrongThingErr "type" thing name } - where - check_tc :: TyCon -> TcM () - check_tc tc = do { type_in_type <- xoptM LangExt.TypeInType - ; data_kinds <- xoptM LangExt.DataKinds - ; unless (isTypeLevel (mode_level mode) || - data_kinds || - isKindTyCon tc) $ - promotionErr name NoDataKindsTC - ; unless (isTypeLevel (mode_level mode) || - type_in_type || - isLegacyPromotableTyCon tc) $ - promotionErr name NoTypeInTypeTC } - - -- if we are type-checking a type family tycon, we must instantiate - -- any invisible arguments right away. Otherwise, we get #11246 - handle_tyfams :: TyCon -- the tycon to instantiate (might be loopy) - -> TyCon -- a non-loopy version of the tycon - -> TcM (TcType, TcKind) - handle_tyfams tc tc_tc - | mightBeUnsaturatedTyCon tc_tc - = do { traceTc "tcTyVar2a" (ppr tc_tc $$ ppr tc_kind) - ; return (ty, tc_kind) } - - | otherwise - = do { (tc_ty, kind) <- instantiateTyN 0 ty tc_kind - -- tc and tc_ty must not be traced here, because that would - -- force the evaluation of a potentially knot-tied variable (tc), - -- and the typechecker would hang, as per #11708 - ; traceTc "tcTyVar2b" (vcat [ ppr tc_tc <+> dcolon <+> ppr tc_kind - , ppr kind ]) - ; return (tc_ty, kind) } - where - ty = mkNakedTyConApp tc [] - tc_kind = tyConKind tc_tc - - get_loopy_tc :: Name -> TyCon -> TcM TyCon - -- Return the knot-tied global TyCon if there is one - -- Otherwise the local TcTyCon; we must be doing kind checking - -- but we still want to return a TyCon of some sort to use in - -- error messages - get_loopy_tc name tc_tc - = do { env <- getGblEnv - ; case lookupNameEnv (tcg_type_env env) name of - Just (ATyCon tc) -> return tc - _ -> do { traceTc "lk1 (loopy)" (ppr name) - ; return tc_tc } } - -tcClass :: Name -> TcM (Class, TcKind) -tcClass cls -- Must be a class - = do { thing <- tcLookup cls - ; case thing of - ATcTyCon tc -> return (aThingErr "tcClass" cls, tyConKind tc) - AGlobal (ATyCon tc) - | Just cls <- tyConClass_maybe tc - -> return (cls, tyConKind tc) - _ -> wrongThingErr "class" thing cls } - - -aThingErr :: String -> Name -> b --- The type checker for types is sometimes called simply to --- do *kind* checking; and in that case it ignores the type --- returned. Which is a good thing since it may not be available yet! -aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x) - -{- -Note [Type-checking inside the knot] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are checking the argument types of a data constructor. We -must zonk the types before making the DataCon, because once built we -can't change it. So we must traverse the type. - -BUT the parent TyCon is knot-tied, so we can't look at it yet. - -So we must be careful not to use "smart constructors" for types that -look at the TyCon or Class involved. - - * Hence the use of mkNakedXXX functions. These do *not* enforce - the invariants (for example that we use (FunTy s t) rather - than (TyConApp (->) [s,t])). - - * The zonking functions establish invariants (even zonkTcType, a change from - previous behaviour). So we must never inspect the result of a - zonk that might mention a knot-tied TyCon. This is generally OK - because we zonk *kinds* while kind-checking types. And the TyCons - in kinds shouldn't be knot-tied, because they come from a previous - mutually recursive group. - - * TcHsSyn.zonkTcTypeToType also can safely check/establish - invariants. - -This is horribly delicate. I hate it. A good example of how -delicate it is can be seen in Trac #7903. - -Note [GADT kind self-reference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A promoted type cannot be used in the body of that type's declaration. -Trac #11554 shows this example, which made GHC loop: - - import Data.Kind - data P (x :: k) = Q - data A :: Type where - B :: forall (a :: A). P a -> A - -In order to check the constructor B, we need to have the promoted type A, but in -order to get that promoted type, B must first be checked. To prevent looping, a -TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode. -Any ATcTyCon is a TyCon being defined in the current recursive group (see data -type decl for TcTyThing), and all such TyCons are illegal in kinds. - -Trac #11962 proposes checking the head of a data declaration separately from -its constructors. This would allow the example above to pass. - -Note [Body kind of a HsForAllTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The body of a forall is usually a type, but in principle -there's no reason to prohibit *unlifted* types. -In fact, GHC can itself construct a function with an -unboxed tuple inside a for-all (via CPR analyis; see -typecheck/should_compile/tc170). - -Moreover in instance heads we get forall-types with -kind Constraint. - -It's tempting to check that the body kind is either * or #. But this is -wrong. For example: - - class C a b - newtype N = Mk Foo deriving (C a) - -We're doing newtype-deriving for C. But notice how `a` isn't in scope in -the predicate `C a`. So we quantify, yielding `forall a. C a` even though -`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but -convenient. Bottom line: don't check for * or # here. - -Note [Body kind of a HsQualTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If ctxt is non-empty, the HsQualTy really is a /function/, so the -kind of the result really is '*', and in that case the kind of the -body-type can be lifted or unlifted. - -However, consider - instance Eq a => Eq [a] where ... -or - f :: (Eq a => Eq [a]) => blah -Here both body-kind of the HsQualTy is Constraint rather than *. -Rather crudely we tell the difference by looking at exp_kind. It's -very convenient to typecheck instance types like any other HsSigType. - -Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's -better to reject in checkValidType. If we say that the body kind -should be '*' we risk getting TWO error messages, one saying that Eq -[a] doens't have kind '*', and one saying that we need a Constraint to -the left of the outer (=>). - -How do we figure out the right body kind? Well, it's a bit of a -kludge: I just look at the expected kind. If it's Constraint, we -must be in this instance situation context. It's a kludge because it -wouldn't work if any unification was involved to compute that result -kind -- but it isn't. (The true way might be to use the 'mode' -parameter, but that seemed like a sledgehammer to crack a nut.) - -Note [Inferring tuple kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, -we try to figure out whether it's a tuple of kind * or Constraint. - Step 1: look at the expected kind - Step 2: infer argument kinds - -If after Step 2 it's not clear from the arguments that it's -Constraint, then it must be *. Once having decided that we re-check -the Check the arguments again to give good error messages -in eg. `(Maybe, Maybe)` - -Note that we will still fail to infer the correct kind in this case: - - type T a = ((a,a), D a) - type family D :: Constraint -> Constraint - -While kind checking T, we do not yet know the kind of D, so we will default the -kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. - -Note [Desugaring types] -~~~~~~~~~~~~~~~~~~~~~~~ -The type desugarer is phase 2 of dealing with HsTypes. Specifically: - - * It transforms from HsType to Type - - * It zonks any kinds. The returned type should have no mutable kind - or type variables (hence returning Type not TcType): - - any unconstrained kind variables are defaulted to (Any *) just - as in TcHsSyn. - - there are no mutable type variables because we are - kind-checking a type - Reason: the returned type may be put in a TyCon or DataCon where - it will never subsequently be zonked. - -You might worry about nested scopes: - ..a:kappa in scope.. - let f :: forall b. T '[a,b] -> Int -In this case, f's type could have a mutable kind variable kappa in it; -and we might then default it to (Any *) when dealing with f's type -signature. But we don't expect this to happen because we can't get a -lexically scoped type variable with a mutable kind variable in it. A -delicate point, this. If it becomes an issue we might need to -distinguish top-level from nested uses. - -Moreover - * it cannot fail, - * it does no unifications - * it does no validity checking, except for structural matters, such as - (a) spurious ! annotations. - (b) a class used as a type - -Note [Kind of a type splice] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these terms, each with TH type splice inside: - [| e1 :: Maybe $(..blah..) |] - [| e2 :: $(..blah..) |] -When kind-checking the type signature, we'll kind-check the splice -$(..blah..); we want to give it a kind that can fit in any context, -as if $(..blah..) :: forall k. k. - -In the e1 example, the context of the splice fixes kappa to *. But -in the e2 example, we'll desugar the type, zonking the kind unification -variables as we go. When we encounter the unconstrained kappa, we -want to default it to '*', not to (Any *). - - -Help functions for type applications -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --} - -addTypeCtxt :: LHsType Name -> TcM a -> TcM a - -- Wrap a context around only if we want to show that contexts. - -- Omit invisble ones and ones user's won't grok -addTypeCtxt (L _ ty) thing - = addErrCtxt doc thing - where - doc = text "In the type" <+> quotes (ppr ty) - -{- -************************************************************************ -* * - Type-variable binders -%* * -%************************************************************************ - -Note [Scope-check inferred kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data SameKind :: k -> k -> * - foo :: forall a (b :: Proxy a) (c :: Proxy d). SameKind b c - -d has no binding site. So it gets bound implicitly, at the top. The -problem is that d's kind mentions `a`. So it's all ill-scoped. - -The way we check for this is to gather all variables *bound* in a -type variable's scope. The type variable's kind should not mention -any of these variables. That is, d's kind can't mention a, b, or c. -We can't just check to make sure that d's kind is in scope, because -we might be about to kindGeneralize. - -A little messy, but it works. - -Note [Dependent LHsQTyVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We track (in the renamer) which explicitly bound variables in a -LHsQTyVars are manifestly dependent; only precisely these variables -may be used within the LHsQTyVars. We must do this so that kcHsTyVarBndrs -can produce the right TyConBinders, and tell Anon vs. Named. Earlier, -I thought it would work simply to do a free-variable check during -kcHsTyVarBndrs, but this is bogus, because there may be unsolved -equalities about. And we don't want to eagerly solve the equalities, -because we may get further information after kcHsTyVarBndrs is called. -(Recall that kcHsTyVarBndrs is usually called from getInitialKind. -The only other case is in kcConDecl.) This is what implements the rule -that all variables intended to be dependent must be manifestly so. - -Sidenote: It's quite possible that later, we'll consider (t -> s) -as a degenerate case of some (pi (x :: t) -> s) and then this will -all get more permissive. - --} - -tcWildCardBinders :: [Name] - -> ([(Name, TcTyVar)] -> TcM a) - -> TcM a -tcWildCardBinders = tcWildCardBindersX new_tv - where - new_tv name = do { kind <- newMetaKindVar - ; newSkolemTyVar name kind } - -tcWildCardBindersX :: (Name -> TcM TcTyVar) - -> [Name] - -> ([(Name, TcTyVar)] -> TcM a) - -> TcM a -tcWildCardBindersX new_wc wc_names thing_inside - = do { wcs <- mapM new_wc wc_names - ; let wc_prs = wc_names `zip` wcs - ; tcExtendTyVarEnv2 wc_prs $ - thing_inside wc_prs } - --- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete, --- user-supplied kind signature (CUSK), generalise the result. --- Used in 'getInitialKind' (for tycon kinds and other kinds) --- and in kind-checking (but not for tycon kinds, which are checked with --- tcTyClDecls). See also Note [Complete user-supplied kind signatures] in --- HsDecls. --- --- This function does not do telescope checking. -kcHsTyVarBndrs :: Name -- ^ of the thing being checked - -> Bool -- ^ True <=> the TyCon being kind-checked can be unsaturated - -> Bool -- ^ True <=> the decl being checked has a CUSK - -> Bool -- ^ True <=> the decl is an open type/data family - -> Bool -- ^ True <=> all the hsq_implicit are *kind* vars - -- (will give these kind * if -XNoTypeInType) - -> LHsQTyVars Name - -> TcM (Kind, r) -- ^ The result kind, possibly with other info - -> TcM (TcTyCon, r) -- ^ A suitably-kinded TcTyCon -kcHsTyVarBndrs name unsat cusk open_fam all_kind_vars - (HsQTvs { hsq_implicit = kv_ns, hsq_explicit = hs_tvs - , hsq_dependent = dep_names }) thing_inside - | cusk - = do { kv_kinds <- mk_kv_kinds - ; lvl <- getTcLevel - ; let scoped_kvs = zipWith (mk_skolem_tv lvl) kv_ns kv_kinds - ; tcExtendTyVarEnv2 (kv_ns `zip` scoped_kvs) $ - do { (tc_binders, res_kind, stuff) <- solveEqualities $ - bind_telescope hs_tvs thing_inside - - -- Now, because we're in a CUSK, quantify over the mentioned - -- kind vars, in dependency order. - ; tc_binders <- mapM zonkTcTyVarBinder tc_binders - ; res_kind <- zonkTcType res_kind - ; let tc_tvs = binderVars tc_binders - qkvs = tyCoVarsOfTypeWellScoped (mkTyConKind tc_binders res_kind) - -- the visibility of tvs doesn't matter here; we just - -- want the free variables not to include the tvs - - -- If there are any meta-tvs left, the user has - -- lied about having a CUSK. Error. - ; let (meta_tvs, good_tvs) = partition isMetaTyVar qkvs - ; when (not (null meta_tvs)) $ - report_non_cusk_tvs (qkvs ++ tc_tvs) - - -- If any of the scoped_kvs aren't actually mentioned in a binder's - -- kind (or the return kind), then we're in the CUSK case from - -- Note [Free-floating kind vars] - ; let all_tc_tvs = good_tvs ++ tc_tvs - all_mentioned_tvs = mapUnionVarSet (tyCoVarsOfType . tyVarKind) - all_tc_tvs - `unionVarSet` tyCoVarsOfType res_kind - unmentioned_kvs = filterOut (`elemVarSet` all_mentioned_tvs) - scoped_kvs - ; reportFloatingKvs name all_tc_tvs unmentioned_kvs - - ; let final_binders = map (mkNamedTyConBinder Specified) good_tvs - ++ tc_binders - tycon = mkTcTyCon name final_binders res_kind - unsat (scoped_kvs ++ tc_tvs) - -- the tvs contain the binders already - -- in scope from an enclosing class, but - -- re-adding tvs to the env't doesn't cause - -- harm - ; return (tycon, stuff) }} - - | otherwise - = do { kv_kinds <- mk_kv_kinds - ; scoped_kvs <- zipWithM newSigTyVar kv_ns kv_kinds - -- the names must line up in splitTelescopeTvs - ; (binders, res_kind, stuff) - <- tcExtendTyVarEnv2 (kv_ns `zip` scoped_kvs) $ - bind_telescope hs_tvs thing_inside - ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they - -- must remain lined up with the binders - tycon = mkTcTyCon name binders res_kind unsat - (scoped_kvs ++ binderVars binders) - ; return (tycon, stuff) } - where - -- if -XNoTypeInType and we know all the implicits are kind vars, - -- just give the kind *. This prevents test - -- dependent/should_fail/KindLevelsB from compiling, as it should - mk_kv_kinds :: TcM [Kind] - mk_kv_kinds = do { typeintype <- xoptM LangExt.TypeInType - ; if not typeintype && all_kind_vars - then return (map (const liftedTypeKind) kv_ns) - else mapM (const newMetaKindVar) kv_ns } - - -- there may be dependency between the explicit "ty" vars. So, we have - -- to handle them one at a time. - bind_telescope :: [LHsTyVarBndr Name] - -> TcM (Kind, r) - -> TcM ([TyConBinder], TcKind, r) - bind_telescope [] thing - = do { (res_kind, stuff) <- thing - ; return ([], res_kind, stuff) } - bind_telescope (L _ hs_tv : hs_tvs) thing - = do { tv_pair@(tv, _) <- kc_hs_tv hs_tv - -- NB: Bring all tvs into scope, even non-dependent ones, - -- as they're needed in type synonyms, data constructors, etc. - ; (binders, res_kind, stuff) <- bind_unless_scoped tv_pair $ - bind_telescope hs_tvs $ - thing - -- See Note [Dependent LHsQTyVars] - ; let new_binder | hsTyVarName hs_tv `elemNameSet` dep_names - = mkNamedTyConBinder Required tv - | otherwise - = mkAnonTyConBinder tv - ; return ( new_binder : binders - , res_kind, stuff ) } - - -- | Bind the tyvar in the env't unless the bool is True - bind_unless_scoped :: (TcTyVar, Bool) -> TcM a -> TcM a - bind_unless_scoped (_, True) thing_inside = thing_inside - bind_unless_scoped (tv, False) thing_inside - = tcExtendTyVarEnv [tv] thing_inside - - kc_hs_tv :: HsTyVarBndr Name -> TcM (TcTyVar, Bool) - kc_hs_tv (UserTyVar (L _ name)) - = do { tv_pair@(tv, scoped) <- tcHsTyVarName Nothing name - - -- Open type/data families default their variables to kind *. - ; when (open_fam && not scoped) $ -- (don't default class tyvars) - discardResult $ unifyKind (Just (mkTyVarTy tv)) liftedTypeKind - (tyVarKind tv) - - ; return tv_pair } - - kc_hs_tv (KindedTyVar (L _ name) lhs_kind) - = do { kind <- tcLHsKindSig lhs_kind - ; tcHsTyVarName (Just kind) name } - - report_non_cusk_tvs all_tvs - = do { all_tvs <- mapM zonkTyCoVarKind all_tvs - ; let (_, tidy_tvs) = tidyOpenTyCoVars emptyTidyEnv all_tvs - (meta_tvs, other_tvs) = partition isMetaTyVar tidy_tvs - - ; addErr $ - vcat [ text "You have written a *complete user-suppled kind signature*," - , hang (text "but the following variable" <> plural meta_tvs <+> - isOrAre meta_tvs <+> text "undetermined:") - 2 (vcat (map pp_tv meta_tvs)) - , text "Perhaps add a kind signature." - , hang (text "Inferred kinds of user-written variables:") - 2 (vcat (map pp_tv other_tvs)) ] } - where - pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - - -tcImplicitTKBndrs :: [Name] - -> TcM (a, TyVarSet) -- vars are bound somewhere in the scope - -- see Note [Scope-check inferred kinds] - -> TcM ([TcTyVar], a) -tcImplicitTKBndrs = tcImplicitTKBndrsX (tcHsTyVarName Nothing) - --- | Convenient specialization -tcImplicitTKBndrsType :: [Name] - -> TcM Type - -> TcM ([TcTyVar], Type) -tcImplicitTKBndrsType var_ns thing_inside - = tcImplicitTKBndrs var_ns $ - do { res_ty <- thing_inside - ; return (res_ty, allBoundVariables res_ty) } - --- this more general variant is needed in tcHsPatSigType. --- See Note [Pattern signature binders] -tcImplicitTKBndrsX :: (Name -> TcM (TcTyVar, Bool)) -- new_tv function - -> [Name] - -> TcM (a, TyVarSet) - -> TcM ([TcTyVar], a) --- Returned TcTyVars have the supplied Names, --- but may be in different order to the original [Name] --- (because of sorting to respect dependency) --- Returned TcTyVars have zonked kinds -tcImplicitTKBndrsX new_tv var_ns thing_inside - = do { tkvs_pairs <- mapM new_tv var_ns - ; let must_scope_tkvs = [ tkv | (tkv, False) <- tkvs_pairs ] - tkvs = map fst tkvs_pairs - ; (result, bound_tvs) <- tcExtendTyVarEnv must_scope_tkvs $ - thing_inside - - -- Check that the implicitly-bound kind variable - -- really can go at the beginning. - -- e.g. forall (a :: k) (b :: *). ...(forces k :: b)... - ; tkvs <- mapM zonkTyCoVarKind tkvs - -- NB: /not/ zonkTcTyVarToTyVar. tcImplicitTKBndrsX - -- guarantees to return TcTyVars with the same Names - -- as the var_ns. See [Pattern signature binders] - - ; let extra = text "NB: Implicitly-bound variables always come" <+> - text "before other ones." - ; checkValidInferredKinds tkvs bound_tvs extra - - ; let final_tvs = toposortTyVars tkvs - ; traceTc "tcImplicitTKBndrs" (ppr var_ns $$ ppr final_tvs) - - ; return (final_tvs, result) } - -tcExplicitTKBndrs :: [LHsTyVarBndr Name] - -> ([TyVar] -> TcM (a, TyVarSet)) - -- ^ Thing inside returns the set of variables bound - -- in the scope. See Note [Scope-check inferred kinds] - -> TcM (a, TyVarSet) -- ^ returns augmented bound vars --- No cloning: returned TyVars have the same Name as the incoming LHsTyVarBndrs -tcExplicitTKBndrs orig_hs_tvs thing_inside - = tcExplicitTKBndrsX newSkolemTyVar orig_hs_tvs thing_inside - -tcExplicitTKBndrsX :: (Name -> Kind -> TcM TyVar) - -> [LHsTyVarBndr Name] - -> ([TyVar] -> TcM (a, TyVarSet)) - -- ^ Thing inside returns the set of variables bound - -- in the scope. See Note [Scope-check inferred kinds] - -> TcM (a, TyVarSet) -- ^ returns augmented bound vars -tcExplicitTKBndrsX new_tv orig_hs_tvs thing_inside - = go orig_hs_tvs $ \ tvs -> - do { (result, bound_tvs) <- thing_inside tvs - - -- Issue an error if the ordering is bogus. - -- See Note [Bad telescopes] in TcValidity. - ; tvs <- checkZonkValidTelescope (interppSP orig_hs_tvs) tvs empty - ; checkValidInferredKinds tvs bound_tvs empty - - ; traceTc "tcExplicitTKBndrs" $ - vcat [ text "Hs vars:" <+> ppr orig_hs_tvs - , text "tvs:" <+> sep (map pprTyVar tvs) ] - - ; return (result, bound_tvs `unionVarSet` mkVarSet tvs) - } - where - go [] thing = thing [] - go (L _ hs_tv : hs_tvs) thing - = do { tv <- tcHsTyVarBndr new_tv hs_tv - ; tcExtendTyVarEnv [tv] $ - go hs_tvs $ \ tvs -> - thing (tv : tvs) } - -tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr Name -> TcM TcTyVar --- Return a SkolemTv TcTyVar, initialised with a kind variable. --- Typically the Kind inside the HsTyVarBndr will be a tyvar --- with a mutable kind in it. --- NB: These variables must not be in scope. This function --- is not appropriate for use with associated types, for example. --- --- Returned TcTyVar has the same name; no cloning --- --- See also Note [Associated type tyvar names] in Class --- -tcHsTyVarBndr new_tv (UserTyVar (L _ name)) - = do { kind <- newMetaKindVar - ; new_tv name kind } - -tcHsTyVarBndr new_tv (KindedTyVar (L _ name) kind) - = do { kind <- tcLHsKindSig kind - ; new_tv name kind } - -newWildTyVar :: Name -> TcM TcTyVar --- ^ New unification variable for a wildcard -newWildTyVar _name - = do { kind <- newMetaKindVar - ; uniq <- newUnique - ; details <- newMetaDetails TauTv - ; let name = mkSysTvName uniq (fsLit "w") - ; return (mkTcTyVar name kind details) } - --- | Produce a tyvar of the given name (with the kind provided, or --- otherwise a meta-var kind). If --- the name is already in scope, return the scoped variable, checking --- to make sure the known kind matches any kind provided. The --- second return value says whether the variable is in scope (True) --- or not (False). (Use this for associated types, for example.) -tcHsTyVarName :: Maybe Kind -> Name -> TcM (TcTyVar, Bool) -tcHsTyVarName m_kind name - = do { mb_tv <- tcLookupLcl_maybe name - ; case mb_tv of - Just (ATyVar _ tv) - -> do { whenIsJust m_kind $ \ kind -> - discardResult $ - unifyKind (Just (mkTyVarTy tv)) kind (tyVarKind tv) - ; return (tv, True) } - _ -> do { kind <- case m_kind of - Just kind -> return kind - Nothing -> newMetaKindVar - ; tv <- newSkolemTyVar name kind - ; return (tv, False) }} - --- makes a new skolem tv -newSkolemTyVar :: Name -> Kind -> TcM TcTyVar -newSkolemTyVar name kind = do { lvl <- getTcLevel - ; return (mk_skolem_tv lvl name kind) } - -mk_skolem_tv :: TcLevel -> Name -> Kind -> TcTyVar -mk_skolem_tv lvl n k = mkTcTyVar n k (SkolemTv lvl False) - ------------------- -kindGeneralizeType :: Type -> TcM Type --- Result is zonked -kindGeneralizeType ty - = do { kvs <- kindGeneralize ty - ; ty <- zonkSigType (mkInvForAllTys kvs ty) - ; return ty } - -kindGeneralize :: TcType -> TcM [KindVar] --- Quantify the free kind variables of a kind or type --- In the latter case the type is closed, so it has no free --- type variables. So in both cases, all the free vars are kind vars -kindGeneralize kind_or_type - = do { kvs <- zonkTcTypeAndFV kind_or_type - ; let dvs = DV { dv_kvs = kvs, dv_tvs = emptyDVarSet } - ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked - ; quantifyZonkedTyVars gbl_tvs dvs } - -{- -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'. - -Note [Free-floating kind vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T = MkT (forall (a :: k). Proxy a) - -- from test ghci/scripts/T7873 - -This is not an existential datatype, but a higher-rank one. Note that -the forall to the right of MkT. Also consider - - data S a = MkS (Proxy (a :: k)) - -According to the rules around implicitly-bound kind variables, those -k's scope over the whole declarations. The renamer grabs it and adds it -to the hsq_implicits field of the HsQTyVars of the tycon. So it must -be in scope during type-checking, but we want to reject T while accepting -S. - -Why reject T? Because the kind variable isn't fixed by anything. For -a variable like k to be implicit, it needs to be mentioned in the kind -of a tycon tyvar. But it isn't. - -Why accept S? Because kind inference tells us that a has kind k, so it's -all OK. - -Our approach depends on whether or not the datatype has a CUSK. - -Non-CUSK: In the first pass (kcTyClTyVars) we just bring -k into scope. In the second pass (tcTyClTyVars), -we check to make sure that k has been unified with some other variable -(or generalized over, making k into a skolem). If it hasn't been, then -it must be a free-floating kind var. Error. - -CUSK: When we determine the tycon's final, never-to-be-changed kind -in kcHsTyVarBndrs, we check to make sure all implicitly-bound kind -vars are indeed mentioned in a kind somewhere. If not, error. - --} - --------------------- --- getInitialKind has made a suitably-shaped kind for the type or class --- Look it up in the local environment. This is used only for tycons --- that we're currently type-checking, so we're sure to find a TcTyCon. -kcLookupTcTyCon :: Name -> TcM TcTyCon -kcLookupTcTyCon nm - = do { tc_ty_thing <- tcLookup nm - ; return $ case tc_ty_thing of - ATcTyCon tc -> tc - _ -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) } - ------------------------ --- | Bring tycon tyvars into scope. This is used during the "kind-checking" --- pass in TcTyClsDecls. (Never in getInitialKind, never in the --- "type-checking"/desugaring pass.) --- Never emits constraints, though the thing_inside might. -kcTyClTyVars :: Name -> TcM a -> TcM a -kcTyClTyVars tycon_name thing_inside - = do { tycon <- kcLookupTcTyCon tycon_name - ; tcExtendTyVarEnv (tcTyConScopedTyVars tycon) $ thing_inside } - -tcTyClTyVars :: Name - -> ([TyConBinder] -> Kind -> TcM a) -> TcM a --- ^ Used for the type variables of a type or class decl --- on the second full pass (type-checking/desugaring) in TcTyClDecls. --- This is *not* used in the initial-kind run, nor in the "kind-checking" pass. --- Accordingly, everything passed to the continuation is fully zonked. --- --- (tcTyClTyVars T [a,b] thing_inside) --- where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> * --- calls thing_inside with arguments --- [k1,k2,a,b] [k1:*, k2:*, Anon (k1 -> *), Anon k1] (k2 -> *) --- having also extended the type environment with bindings --- for k1,k2,a,b --- --- Never emits constraints. --- --- The LHsTyVarBndrs is always user-written, and the full, generalised --- kind of the tycon is available in the local env. -tcTyClTyVars tycon_name thing_inside - = do { tycon <- kcLookupTcTyCon tycon_name - - ; let scoped_tvs = tcTyConScopedTyVars tycon - -- these are all zonked: - binders = tyConBinders tycon - res_kind = tyConResKind tycon - - -- See Note [Free-floating kind vars] - ; zonked_scoped_tvs <- mapM zonkTcTyVarToTyVar scoped_tvs - ; let still_sig_tvs = filter isSigTyVar zonked_scoped_tvs - ; checkNoErrs $ reportFloatingKvs tycon_name - zonked_scoped_tvs still_sig_tvs - - -- Add the *unzonked* tyvars to the env't, because those - -- are the ones mentioned in the source. - ; tcExtendTyVarEnv scoped_tvs $ - thing_inside binders res_kind } - ------------------------------------ -tcDataKindSig :: Kind -> TcM ([TyConBinder], Kind) --- GADT decls can have a (perhaps partial) kind signature --- e.g. data T :: * -> * -> * where ... --- This function makes up suitable (kinded) type variables for --- the argument kinds, and checks that the result kind is indeed *. --- We use it also to make up argument type variables for for data instances. --- Never emits constraints. --- Returns the new TyVars, the extracted TyBinders, and the new, reduced --- result kind (which should always be Type or a synonym thereof) -tcDataKindSig kind - = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind) - ; span <- getSrcSpanM - ; us <- newUniqueSupply - ; rdr_env <- getLocalRdrEnv - ; let uniqs = uniqsFromSupply us - occs = [ occ | str <- allNameStrings - , let occ = mkOccName tvName str - , isNothing (lookupLocalRdrOcc rdr_env occ) ] - -- Note [Avoid name clashes for associated data types] - - -- NB: Use the tv from a binder if there is one. Otherwise, - -- we end up inventing a new Unique for it, and any other tv - -- that mentions the first ends up with the wrong kind. - extra_bndrs = zipWith4 mkTyBinderTyConBinder - tv_bndrs (repeat span) uniqs occs - - ; return (extra_bndrs, res_kind) } - where - (tv_bndrs, res_kind) = splitPiTys kind - -badKindSig :: Kind -> SDoc -badKindSig kind - = hang (text "Kind signature on data type declaration has non-* return kind") - 2 (ppr kind) - -{- -Note [Avoid name clashes for associated data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider class C a b where - data D b :: * -> * -When typechecking the decl for D, we'll invent an extra type variable -for D, to fill out its kind. Ideally we don't want this type variable -to be 'a', because when pretty printing we'll get - class C a b where - data D b a0 -(NB: the tidying happens in the conversion to IfaceSyn, which happens -as part of pretty-printing a TyThing.) - -That's why we look in the LocalRdrEnv to see what's in scope. This is -important only to get nice-looking output when doing ":info C" in GHCi. -It isn't essential for correctness. - - -************************************************************************ -* * - Partial signatures -* * -************************************************************************ - --} - -tcHsPartialSigType - :: UserTypeCtxt - -> LHsSigWcType Name -- The type signature - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , Maybe TcTyVar -- Extra-constraints wildcard - , [TcTyVar] -- Implicitly and explicitly bound type variables - , TcThetaType -- Theta part - , TcType ) -- Tau part -tcHsPartialSigType ctxt sig_ty - | HsWC { hswc_wcs = sig_wcs, hswc_body = ib_ty } <- sig_ty - , HsIB { hsib_vars = implicit_hs_tvs, hsib_body = hs_ty } <- ib_ty - , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty - = addSigCtxt ctxt hs_ty $ - do { (implicit_tvs, (wcs, wcx, explicit_tvs, theta, tau)) - <- tcWildCardBindersX newWildTyVar sig_wcs $ \ wcs -> - tcImplicitTKBndrsX new_implicit_tv implicit_hs_tvs $ - tcExplicitTKBndrsX newSigTyVar explicit_hs_tvs $ \ explicit_tvs -> - do { -- Instantiate the type-class context; but if there - -- is an extra-constraints wildcard, just discard it here - (theta, wcx) <- tcPartialContext hs_ctxt - - ; tau <- tcHsOpenType hs_tau - - ; let bound_tvs = unionVarSets [ allBoundVariables tau - , mkVarSet explicit_tvs - , mkVarSet (map snd wcs) ] - - ; return ( (wcs, wcx, explicit_tvs, theta, tau) - , bound_tvs) } - - -- Spit out the wildcards (including the extra-constraints one) - -- as "hole" constraints, so that they'll be reported if necessary - -- See Note [Extra-constraint holes in partial type signatures] - ; emitWildCardHoleConstraints wcs - - ; explicit_tvs <- mapM zonkTyCoVarKind explicit_tvs - ; let all_tvs = implicit_tvs ++ explicit_tvs - -- The implicit_tvs alraedy have zonked kinds - - ; theta <- mapM zonkTcType theta - ; tau <- zonkTcType tau - ; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau) - - ; traceTc "tcHsPartialSigType" (ppr all_tvs) - ; return (wcs, wcx, all_tvs, theta, tau) } - where - new_implicit_tv name = do { kind <- newMetaKindVar - ; tv <- newSigTyVar name kind - ; return (tv, False) } - -tcPartialContext :: HsContext Name -> TcM (TcThetaType, Maybe TcTyVar) -tcPartialContext hs_theta - | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta - , L _ (HsWildCardTy wc) <- ignoreParens hs_ctxt_last - = do { wc_tv <- tcWildCardOcc wc constraintKind - ; theta <- mapM tcLHsPredType hs_theta1 - ; return (theta, Just wc_tv) } - | otherwise - = do { theta <- mapM tcLHsPredType hs_theta - ; return (theta, Nothing) } - -{- Note [Extra-constraint holes in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: (_) => a -> a - f x = ... - -* The renamer makes a wildcard name for the "_", and puts it in - the hswc_wcs field. - -* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in - tcWildCardBindersX. - -* TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar - with the inferred constraints, e.g. (Eq a, Show a) - -* TcErrors.mkHoleError finally reports the error. - -An annoying difficulty happens if there are more than 62 inferred -constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple. -Where do we find the TyCon? For good reasons we only have constraint -tuples up to 62 (see Note [How tuples work] in TysWiredIn). So how -can we make a 70-tuple? This was the root cause of Trac #14217. - -It's incredibly tiresome, becuase we only need this type to fill -in the hole, to commuincate to the error reporting machinery. Nothing -more. So I use a HACK: - -* I make an /ordinary/ tuple of the constraints, in - TcBinds.chooseInferredQuantifiers. This is ill-kinded because - ordinary tuples can't contain contraints, but it works fine. And for - ordinary tuples we don't have the same limit as for constraint - tuples (which need selectors and an assocated class). - -* Because it is ill-kided, it trips an assert in writeMetaTyVar, - so now I disable the assertion if we are writing a type of - kind Constraint. (That seldom/never normally happens so we aren't - losing much.) - -Result works fine, but it may eventually bite us. - - -************************************************************************ -* * - Pattern signatures (i.e signatures that occur in patterns) -* * -********************************************************************* -} - -tcHsPatSigType :: UserTypeCtxt - -> LHsSigWcType Name -- The type signature - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , [(Name, TcTyVar)] -- The new bit of type environment, binding - -- the scoped type variables - , TcType) -- The type --- Used for type-checking type signatures in --- (a) patterns e.g f (x::Int) = e --- (b) RULE forall bndrs e.g. forall (x::Int). f x = x --- --- This may emit constraints - -tcHsPatSigType ctxt sig_ty - | HsWC { hswc_wcs = sig_wcs, hswc_body = ib_ty } <- sig_ty - , HsIB { hsib_vars = sig_vars, hsib_body = hs_ty } <- ib_ty - = addSigCtxt ctxt hs_ty $ - do { (implicit_tvs, (wcs, sig_ty)) - <- tcWildCardBindersX newWildTyVar sig_wcs $ \ wcs -> - tcImplicitTKBndrsX new_implicit_tv sig_vars $ - do { sig_ty <- tcHsOpenType hs_ty - ; return ((wcs, sig_ty), allBoundVariables sig_ty) } - - ; emitWildCardHoleConstraints wcs - - ; sig_ty <- zonkTcType sig_ty - ; checkValidType ctxt sig_ty - - ; tv_pairs <- mapM mk_tv_pair implicit_tvs - - ; traceTc "tcHsPatSigType" (ppr sig_vars) - ; return (wcs, tv_pairs, sig_ty) } - where - new_implicit_tv name = do { kind <- newMetaKindVar - ; tv <- new_tv name kind - ; return (tv, False) } - -- "False" means that these tyvars aren't yet in scope - new_tv = case ctxt of - RuleSigCtxt {} -> newSkolemTyVar - _ -> newSigTyVar - -- See Note [Pattern signature binders] - -- See Note [Unifying SigTvs] - - mk_tv_pair tv = do { tv' <- zonkTcTyVarToTyVar tv - ; return (tyVarName tv, tv') } - -- The Name is one of sig_vars, the lexically scoped name - -- But if it's a SigTyVar, it might have been unified - -- with an existing in-scope skolem, so we must zonk - -- here. See Note [Pattern signature binders] - -tcPatSig :: Bool -- True <=> pattern binding - -> LHsSigWcType Name - -> ExpSigmaType - -> TcM (TcType, -- The type to use for "inside" the signature - [(Name,TcTyVar)], -- The new bit of type environment, binding - -- the scoped type variables - [(Name,TcTyVar)], -- The wildcards - HsWrapper) -- Coercion due to unification with actual ty - -- Of shape: res_ty ~ sig_ty -tcPatSig in_pat_bind sig res_ty - = do { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig - -- sig_tvs are the type variables free in 'sig', - -- and not already in scope. These are the ones - -- that should be brought into scope - - ; if null sig_tvs then do { - -- Just do the subsumption check and return - wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty - ; return (sig_ty, [], sig_wcs, wrap) - } else do - -- Type signature binds at least one scoped type variable - - -- A pattern binding cannot bind scoped type variables - -- It is more convenient to make the test here - -- than in the renamer - { when in_pat_bind (addErr (patBindSigErr sig_tvs)) - - -- Check that all newly-in-scope tyvars are in fact - -- constrained by the pattern. This catches tiresome - -- cases like - -- type T a = Int - -- f :: Int -> Int - -- f (x :: T a) = ... - -- Here 'a' doesn't get a binding. Sigh - ; let bad_tvs = [ tv | (_,tv) <- sig_tvs - , not (tv `elemVarSet` exactTyCoVarsOfType sig_ty) ] - ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs) - - -- Now do a subsumption check of the pattern signature against res_ty - ; wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty - - -- Phew! - ; return (sig_ty, sig_tvs, sig_wcs, wrap) - } } - where - mk_msg sig_ty tidy_env - = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty - ; res_ty <- readExpType res_ty -- should be filled in by now - ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty - ; let msg = vcat [ hang (text "When checking that the pattern signature:") - 4 (ppr sig_ty) - , nest 2 (hang (text "fits the type of its context:") - 2 (ppr res_ty)) ] - ; return (tidy_env, msg) } - -patBindSigErr :: [(Name,TcTyVar)] -> SDoc -patBindSigErr sig_tvs - = hang (text "You cannot bind scoped type variable" <> plural sig_tvs - <+> pprQuotedList (map fst sig_tvs)) - 2 (text "in a pattern binding signature") - -{- Note [Pattern signature binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = forall a. T a (a->Int) - f (T x (f :: b->Int)) = blah - -Here - * The pattern (T p1 p2) creates a *skolem* type variable 'a_sk', - It must be a skolem so that that it retains its identity, and - TcErrors.getSkolemInfo can thereby find the binding site for the skolem. - - * The type signature pattern (f :: b->Int) makes a fresh meta-tyvar b_sig - (a SigTv), and binds "b" :-> b_sig in the envt - - * Then unification makes b_sig := a_sk - That's why we must make b_sig a MetaTv (albeit a SigTv), - not a SkolemTv, so that it can unify to a_sk. - - * Finally, in 'blah' we must have the envt "b" :-> a_sk. The pair - ("b" :-> a_sk) is returned by tcHsPatSigType, constructed by - mk_tv_pair in that funcion. - -Another example (Trac #13881): - fl :: forall (l :: [a]). Sing l -> Sing l - fl (SNil :: Sing (l :: [y])) = SNil -When we reach the pattern signature, 'l' is in scope from the -outer 'forall': - "a" :-> a_sk :: * - "l" :-> l_sk :: [a_sk] -We make up a fresh meta-SigTv, 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" :-> a_sk). - -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. - -Note [Unifying SigTvs] -~~~~~~~~~~~~~~~~~~~~~~ -ALAS we have no decent way of avoiding two SigTvs getting unified. -Consider - f (x::(a,b)) (y::c)) = [fst x, y] -Here we'd really like to complain that 'a' and 'c' are unified. But -for the reasons above we can't make a,b,c into skolems, so they -are just SigTvs that can unify. And indeed, this would be ok, - f x (y::c) = case x of - (x1 :: a1, True) -> [x,y] - (x1 :: a2, False) -> [x,y,y] -Here the type of x's first component is called 'a1' in one branch and -'a2' in the other. We could try insisting on the same OccName, but -they definitely won't have the sane lexical Name. - -I think we could solve this by recording in a SigTv a list of all the -in-scope variables that it should not unify with, but it's fiddly. - - -************************************************************************ -* * - Checking kinds -* * -************************************************************************ - --} - -unifyKinds :: [(TcType, TcKind)] -> TcM ([TcType], TcKind) -unifyKinds act_kinds - = do { kind <- newMetaKindVar - ; let check (ty, act_kind) = checkExpectedKind ty act_kind kind - ; tys' <- mapM check 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 :: LHsKind Name -> TcM Kind -tcLHsKindSig hs_kind - = do { kind <- tc_lhs_kind kindLevelMode hs_kind - ; zonkTcType kind } - -- This zonk is very important in the case of higher rank kinds - -- E.g. Trac #13879 f :: forall (p :: forall z (y::z). ). - -- - -- When instanting p's kind at occurrences of p in - -- it's crucial that the kind we instantiate is fully zonked, - -- else we may fail to substitute properly - -tc_lhs_kind :: TcTyMode -> LHsKind Name -> TcM Kind -tc_lhs_kind mode k - = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $ - tc_lhs_type (kindLevel mode) k liftedTypeKind - -promotionErr :: Name -> PromotionErr -> TcM a -promotionErr name err - = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") - 2 (parens reason)) - where - reason = case err of - 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" - NoTypeInTypeTC -> text "Perhaps you intended to use TypeInType" - NoTypeInTypeDC -> text "Perhaps you intended to use TypeInType" - PatSynPE -> text "Pattern synonyms cannot be promoted" - _ -> text "it is defined and used in the same recursive group" - -{- -************************************************************************ -* * - Scoped type variables -* * -************************************************************************ --} - -badPatSigTvs :: TcType -> [TyVar] -> SDoc -badPatSigTvs sig_ty bad_tvs - = vcat [ fsep [text "The type variable" <> plural bad_tvs, - quotes (pprWithCommas ppr bad_tvs), - text "should be bound by the pattern signature" <+> quotes (ppr sig_ty), - text "but are actually discarded by a type synonym" ] - , text "To fix this, expand the type synonym" - , text "[Note: I hope to lift this restriction in due course]" ] - -{- -************************************************************************ -* * - Error messages and such -* * -************************************************************************ --} - --- | Make an appropriate message for an error in a function argument. --- Used for both expressions and types. -funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc -funAppCtxt fun arg arg_no - = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"), - quotes (ppr fun) <> text ", namely"]) - 2 (quotes (ppr arg)) - --- See Note [Free-floating kind vars] -reportFloatingKvs :: Name -- of the tycon - -> [TcTyVar] -- all tyvars, not necessarily zonked - -> [TcTyVar] -- floating tyvars - -> TcM () -reportFloatingKvs tycon_name all_tvs bad_tvs - = unless (null bad_tvs) $ -- don't bother zonking if there's no error - do { all_tvs <- mapM zonkTcTyVarToTyVar all_tvs - ; bad_tvs <- mapM zonkTcTyVarToTyVar bad_tvs - ; let (tidy_env, tidy_all_tvs) = tidyOpenTyCoVars emptyTidyEnv all_tvs - tidy_bad_tvs = map (tidyTyVarOcc tidy_env) bad_tvs - ; typeintype <- xoptM LangExt.TypeInType - ; mapM_ (report typeintype tidy_all_tvs) tidy_bad_tvs } - where - report typeintype tidy_all_tvs tidy_bad_tv - = addErr $ - vcat [ text "Kind variable" <+> quotes (ppr tidy_bad_tv) <+> - text "is implicitly bound in datatype" - , quotes (ppr tycon_name) <> comma <+> - text "but does not appear as the kind of any" - , text "of its type variables. Perhaps you meant" - , text "to bind it" <+> ppWhen (not typeintype) - (text "(with TypeInType)") <+> - text "explicitly somewhere?" - , ppWhen (not (null tidy_all_tvs)) $ - hang (text "Type variables with inferred kinds:") - 2 (ppr_tv_bndrs tidy_all_tvs) ] - - ppr_tv_bndrs tvs = sep (map pp_tv tvs) - pp_tv tv = parens (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) diff --git a/typecheck/TcInstDcls.hs b/typecheck/TcInstDcls.hs deleted file mode 100644 --- a/typecheck/TcInstDcls.hs +++ /dev/null @@ -1,1839 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcInstDecls: Typechecking instance declarations --} - -{-# LANGUAGE CPP #-} - -module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where - -#include "HsVersions.h" - -import HsSyn -import TcBinds -import TcTyClsDecls -import TcClassDcl( tcClassDecl2, tcATDefault, - HsSigFun, mkHsSigFun, - findMethodBind, instantiateMethod ) -import TcSigs -import TcRnMonad -import TcValidity -import TcHsSyn ( zonkTyBndrsX, emptyZonkEnv - , zonkTcTypeToTypes, zonkTcTypeToType ) -import TcMType -import TcType -import BuildTyCl -import Inst -import InstEnv -import FamInst -import FamInstEnv -import TcDeriv -import TcEnv -import TcHsType -import TcUnify -import CoreSyn ( Expr(..), mkApps, mkVarApps, mkLams ) -import MkCore ( nO_METHOD_BINDING_ERROR_ID ) -import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding ) -import Type -import TcEvidence -import TyCon -import CoAxiom -import DataCon -import ConLike -import Class -import Var -import VarEnv -import VarSet -import PrelNames ( typeableClassName, genericClassNames - , knownNatClassName, knownSymbolClassName ) -import Bag -import BasicTypes -import DynFlags -import ErrUtils -import FastString -import Id -import MkId -import Name -import NameSet -import Outputable -import SrcLoc -import Util -import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Maybes - - -{- -Typechecking instance declarations is done in two passes. The first -pass, made by @tcInstDecls1@, collects information to be used in the -second pass. - -This pre-processed info includes the as-yet-unprocessed bindings -inside the instance declaration. These are type-checked in the second -pass, when the class-instance envs and GVE contain all the info from -all the instance and value decls. Indeed that's the reason we need -two passes over the instance decls. - - -Note [How instance declarations are translated] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is how we translate instance declarations into Core - -Running example: - class C a where - op1, op2 :: Ix b => a -> b -> b - op2 = - - instance C a => C [a] - {-# INLINE [2] op1 #-} - op1 = -===> - -- Method selectors - op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b - op1 = ... - op2 = ... - - -- Default methods get the 'self' dictionary as argument - -- so they can call other methods at the same type - -- Default methods get the same type as their method selector - $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b - $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). - -- NB: type variables 'a' and 'b' are *both* in scope in - -- Note [Tricky type variable scoping] - - -- A top-level definition for each instance method - -- Here op1_i, op2_i are the "instance method Ids" - -- The INLINE pragma comes from the user pragma - {-# INLINE [2] op1_i #-} -- From the instance decl bindings - op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b - op1_i = /\a. \(d:C a). - let this :: C [a] - this = df_i a d - -- Note [Subtle interaction of recursion and overlap] - - local_op1 :: forall b. Ix b => [a] -> b -> b - local_op1 = - -- Source code; run the type checker on this - -- NB: Type variable 'a' (but not 'b') is in scope in - -- Note [Tricky type variable scoping] - - in local_op1 a d - - op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) - - -- The dictionary function itself - {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions - df_i :: forall a. C a -> C [a] - df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) - -- But see Note [Default methods in instances] - -- We can't apply the type checker to the default-method call - - -- Use a RULE to short-circuit applications of the class ops - {-# RULE "op1@C[a]" forall a, d:C a. - op1 [a] (df_i d) = op1_i a d #-} - -Note [Instances and loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Note that df_i may be mutually recursive with both op1_i and op2_i. - It's crucial that df_i is not chosen as the loop breaker, even - though op1_i has a (user-specified) INLINE pragma. - -* Instead the idea is to inline df_i into op1_i, which may then select - methods from the MkC record, and thereby break the recursion with - df_i, leaving a *self*-recursive op1_i. (If op1_i doesn't call op at - the same type, it won't mention df_i, so there won't be recursion in - the first place.) - -* If op1_i is marked INLINE by the user there's a danger that we won't - inline df_i in it, and that in turn means that (since it'll be a - loop-breaker because df_i isn't), op1_i will ironically never be - inlined. But this is OK: the recursion breaking happens by way of - a RULE (the magic ClassOp rule above), and RULES work inside InlineRule - unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils - -Note [ClassOp/DFun selection] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One thing we see a lot is stuff like - op2 (df d1 d2) -where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* -'op2' and 'df' to get - case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of - MkD _ op2 _ _ _ -> op2 -And that will reduce to ($cop2 d1 d2) which is what we wanted. - -But it's tricky to make this work in practice, because it requires us to -inline both 'op2' and 'df'. But neither is keen to inline without having -seen the other's result; and it's very easy to get code bloat (from the -big intermediate) if you inline a bit too much. - -Instead we use a cunning trick. - * We arrange that 'df' and 'op2' NEVER inline. - - * We arrange that 'df' is ALWAYS defined in the sylised form - df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... - - * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..]) - that lists its methods. - - * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return - a suitable constructor application -- inlining df "on the fly" as it - were. - - * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that - extracts the right piece iff its argument satisfies - exprIsConApp_maybe. This is done in MkId mkDictSelId - - * We make 'df' CONLIKE, so that shared uses still match; eg - let d = df d1 d2 - in ...(op2 d)...(op1 d)... - -Note [Single-method classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the class has just one method (or, more accurately, just one element -of {superclasses + methods}), then we use a different strategy. - - class C a where op :: a -> a - instance C a => C [a] where op = - -We translate the class decl into a newtype, which just gives a -top-level axiom. The "constructor" MkC expands to a cast, as does the -class-op selector. - - axiom Co:C a :: C a ~ (a->a) - - op :: forall a. C a -> (a -> a) - op a d = d |> (Co:C a) - - MkC :: forall a. (a->a) -> C a - MkC = /\a.\op. op |> (sym Co:C a) - -The clever RULE stuff doesn't work now, because ($df a d) isn't -a constructor application, so exprIsConApp_maybe won't return -Just . - -Instead, we simply rely on the fact that casts are cheap: - - $df :: forall a. C a => C [a] - {-# INLINE df #-} -- NB: INLINE this - $df = /\a. \d. MkC [a] ($cop_list a d) - = $cop_list |> forall a. C a -> (sym (Co:C [a])) - - $cop_list :: forall a. C a => [a] -> [a] - $cop_list = - -So if we see - (op ($df a d)) -we'll inline 'op' and '$df', since both are simply casts, and -good things happen. - -Why do we use this different strategy? Because otherwise we -end up with non-inlined dictionaries that look like - $df = $cop |> blah -which adds an extra indirection to every use, which seems stupid. See -Trac #4138 for an example (although the regression reported there -wasn't due to the indirection). - -There is an awkward wrinkle though: we want to be very -careful when we have - instance C a => C [a] where - {-# INLINE op #-} - op = ... -then we'll get an INLINE pragma on $cop_list but it's important that -$cop_list only inlines when it's applied to *two* arguments (the -dictionary and the list argument). So we must not eta-expand $df -above. We ensure that this doesn't happen by putting an INLINE -pragma on the dfun itself; after all, it ends up being just a cast. - -There is one more dark corner to the INLINE story, even more deeply -buried. Consider this (Trac #3772): - - class DeepSeq a => C a where - gen :: Int -> a - - instance C a => C [a] where - gen n = ... - - class DeepSeq a where - deepSeq :: a -> b -> b - - instance DeepSeq a => DeepSeq [a] where - {-# INLINE deepSeq #-} - deepSeq xs b = foldr deepSeq b xs - -That gives rise to these defns: - - $cdeepSeq :: DeepSeq a -> [a] -> b -> b - -- User INLINE( 3 args )! - $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ... - - $fDeepSeq[] :: DeepSeq a -> DeepSeq [a] - -- DFun (with auto INLINE pragma) - $fDeepSeq[] a d = $cdeepSeq a d |> blah - - $cp1 a d :: C a => DeepSep [a] - -- We don't want to eta-expand this, lest - -- $cdeepSeq gets inlined in it! - $cp1 a d = $fDeepSep[] a (scsel a d) - - $fC[] :: C a => C [a] - -- Ordinary DFun - $fC[] a d = MkC ($cp1 a d) ($cgen a d) - -Here $cp1 is the code that generates the superclass for C [a]. The -issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[] -and then $cdeepSeq will inline there, which is definitely wrong. Like -on the dfun, we solve this by adding an INLINE pragma to $cp1. - -Note [Subtle interaction of recursion and overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - class C a where { op1,op2 :: a -> a } - instance C a => C [a] where - op1 x = op2 x ++ op2 x - op2 x = ... - instance C [Int] where - ... - -When type-checking the C [a] instance, we need a C [a] dictionary (for -the call of op2). If we look up in the instance environment, we find -an overlap. And in *general* the right thing is to complain (see Note -[Overlapping instances] in InstEnv). But in *this* case it's wrong to -complain, because we just want to delegate to the op2 of this same -instance. - -Why is this justified? Because we generate a (C [a]) constraint in -a context in which 'a' cannot be instantiated to anything that matches -other overlapping instances, or else we would not be executing this -version of op1 in the first place. - -It might even be a bit disguised: - - nullFail :: C [a] => [a] -> [a] - nullFail x = op2 x ++ op2 x - - instance C a => C [a] where - op1 x = nullFail x - -Precisely this is used in package 'regex-base', module Context.hs. -See the overlapping instances for RegexContext, and the fact that they -call 'nullFail' just like the example above. The DoCon package also -does the same thing; it shows up in module Fraction.hs. - -Conclusion: when typechecking the methods in a C [a] instance, we want to -treat the 'a' as an *existential* type variable, in the sense described -by Note [Binding when looking up instances]. That is why isOverlappableTyVar -responds True to an InstSkol, which is the kind of skolem we use in -tcInstDecl2. - - -Note [Tricky type variable scoping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In our example - class C a where - op1, op2 :: Ix b => a -> b -> b - op2 = - - instance C a => C [a] - {-# INLINE [2] op1 #-} - op1 = - -note that 'a' and 'b' are *both* in scope in , but only 'a' is -in scope in . In particular, we must make sure that 'b' is in -scope when typechecking . This is achieved by subFunTys, -which brings appropriate tyvars into scope. This happens for both - and for , but that doesn't matter: the *renamer* will have -complained if 'b' is mentioned in . - - - -************************************************************************ -* * -\subsection{Extracting instance decls} -* * -************************************************************************ - -Gather up the instance declarations from their various sources --} - -tcInstDecls1 -- Deal with both source-code and imported instance decls - :: [LInstDecl Name] -- Source code instance decls - -> TcM (TcGblEnv, -- The full inst env - [InstInfo Name], -- Source-code instance decls to process; - -- contains all dfuns for this module - [DerivInfo]) -- From data family instances - -tcInstDecls1 inst_decls - = do { -- Do class and family instance declarations - ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls - - ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff - fam_insts = concat fam_insts_s - local_infos = concat local_infos_s - - ; gbl_env <- addClsInsts local_infos $ - addFamInsts fam_insts $ - getGblEnv - - ; return ( gbl_env - , local_infos - , concat datafam_deriv_infos ) } - --- | Use DerivInfo for data family instances (produced by tcInstDecls1), --- datatype declarations (TyClDecl), and standalone deriving declarations --- (DerivDecl) to check and process all derived class instances. -tcInstDeclsDeriv - :: [DerivInfo] - -> [LTyClDecl Name] - -> [LDerivDecl Name] - -> TcM (TcGblEnv, [InstInfo Name], HsValBinds Name) -tcInstDeclsDeriv datafam_deriv_infos tyclds derivds - = do th_stage <- getStage -- See Note [Deriving inside TH brackets] - if isBrackStage th_stage - then do { gbl_env <- getGblEnv - ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) } - else do { data_deriv_infos <- mkDerivInfos tyclds - ; let deriv_infos = datafam_deriv_infos ++ data_deriv_infos - ; (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds - ; return (tcg_env, bagToList info_bag, valbinds) } - -addClsInsts :: [InstInfo Name] -> TcM a -> TcM a -addClsInsts infos thing_inside - = tcExtendLocalInstEnv (map iSpec infos) thing_inside - -addFamInsts :: [FamInst] -> TcM a -> TcM a --- Extend (a) the family instance envt --- (b) the type envt with stuff from data type decls -addFamInsts fam_insts thing_inside - = tcExtendLocalFamInstEnv fam_insts $ - tcExtendGlobalEnv axioms $ - tcExtendTyConEnv data_rep_tycons $ - do { traceTc "addFamInsts" (pprFamInsts fam_insts) - ; tcg_env <- tcAddImplicits data_rep_tycons - -- Does not add its axiom; that comes from - -- adding the 'axioms' above - ; setGblEnv tcg_env thing_inside } - where - axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts - data_rep_tycons = famInstsRepTyCons fam_insts - -- The representation tycons for 'data instances' declarations - -{- -Note [Deriving inside TH brackets] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a declaration bracket - [d| data T = A | B deriving( Show ) |] - -there is really no point in generating the derived code for deriving( -Show) and then type-checking it. This will happen at the call site -anyway, and the type check should never fail! Moreover (Trac #6005) -the scoping of the generated code inside the bracket does not seem to -work out. - -The easy solution is simply not to generate the derived instances at -all. (A less brutal solution would be to generate them with no -bindings.) This will become moot when we shift to the new TH plan, so -the brutal solution will do. --} - -tcLocalInstDecl :: LInstDecl Name - -> TcM ([InstInfo Name], [FamInst], [DerivInfo]) - -- A source-file instance declaration - -- Type-check all the stuff before the "where" - -- - -- We check for respectable instance type, and context -tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) - = do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl) - ; return ([], [fam_inst], []) } - -tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) - = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl Nothing (L loc decl) - ; return ([], [fam_inst], maybeToList m_deriv_info) } - -tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) - = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl) - ; return (insts, fam_insts, deriv_infos) } - -tcClsInstDecl :: LClsInstDecl Name - -> TcM ([InstInfo Name], [FamInst], [DerivInfo]) --- The returned DerivInfos are for any associated data families -tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds - , cid_sigs = uprags, cid_tyfam_insts = ats - , cid_overlap_mode = overlap_mode - , cid_datafam_insts = adts })) - = setSrcSpan loc $ - addErrCtxt (instDeclCtxt1 poly_ty) $ - do { (tyvars, theta, clas, inst_tys) <- tcHsClsInstType InstDeclCtxt poly_ty - ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) - mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env - mb_info = Just (clas, tyvars, mini_env) - - -- Next, process any associated types. - ; traceTc "tcLocalInstDecl" (ppr poly_ty) - ; tyfam_insts0 <- tcExtendTyVarEnv tyvars $ - mapAndRecoverM (tcTyFamInstDecl mb_info) ats - ; datafam_stuff <- tcExtendTyVarEnv tyvars $ - mapAndRecoverM (tcDataFamInstDecl mb_info) adts - ; let (datafam_insts, m_deriv_infos) = unzip datafam_stuff - deriv_infos = catMaybes m_deriv_infos - - -- Check for missing associated types and build them - -- from their defaults (if available) - ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) - `unionNameSet` - mkNameSet (map (unLoc . dfid_tycon . unLoc) adts) - ; tyfam_insts1 <- mapM (tcATDefault True loc mini_subst defined_ats) - (classATItems clas) - - -- Finally, construct the Core representation of the instance. - -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType poly_ty)) - -- Dfun location is that of instance *header* - - ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta - clas inst_tys - - ; let inst_info = InstInfo { iSpec = ispec - , iBinds = InstBindings - { ib_binds = binds - , ib_tyvars = map Var.varName tyvars -- Scope over bindings - , ib_pragmas = uprags - , ib_extensions = [] - , ib_derived = False } } - - ; doClsInstErrorChecks inst_info - - ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts - , deriv_infos ) } - - -doClsInstErrorChecks :: InstInfo Name -> TcM () -doClsInstErrorChecks inst_info - = do { traceTc "doClsInstErrorChecks" (ppr ispec) - ; dflags <- getDynFlags - ; is_boot <- tcIsHsBootOrSig - - -- In hs-boot files there should be no bindings - ; failIfTc (is_boot && not no_binds) badBootDeclErr - - -- If not in an hs-boot file, abstract classes cannot have - -- instances declared - ; failIfTc (not is_boot && isAbstractClass clas) abstractClassInstErr - - -- Handwritten instances of any rejected - -- class is always forbidden - -- #12837 - ; failIfTc (clas_nm `elem` rejectedClassNames) clas_err - - -- Check for hand-written Generic instances (disallowed in Safe Haskell) - ; when (clas_nm `elem` genericClassNames) $ - do { failIfTc (safeLanguageOn dflags) gen_inst_err - ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } - } - where - ispec = iSpec inst_info - binds = iBinds inst_info - no_binds = isEmptyLHsBinds (ib_binds binds) && null (ib_pragmas binds) - clas_nm = is_cls_nm ispec - clas = is_cls ispec - - gen_inst_err = hang (text ("Generic instances can only be " - ++ "derived in Safe Haskell.") $+$ - text "Replace the following instance:") - 2 (pprInstanceHdr ispec) - - abstractClassInstErr = - text "Cannot define instance for abstract class" <+> quotes (ppr clas_nm) - - -- Report an error or a warning for certain class instances. - -- If we are working on an .hs-boot file, we just report a warning, - -- and ignore the instance. We do this, to give users a chance to fix - -- their code. - rejectedClassNames = [ typeableClassName - , knownNatClassName - , knownSymbolClassName ] - clas_err = text "Class" <+> quotes (ppr clas_nm) - <+> text "does not support user-specified instances" - -{- -************************************************************************ -* * - Type checking family instances -* * -************************************************************************ - -Family instances are somewhat of a hybrid. They are processed together with -class instance heads, but can contain data constructors and hence they share a -lot of kinding and type checking code with ordinary algebraic data types (and -GADTs). --} - -tcFamInstDeclCombined :: Maybe ClsInstInfo - -> Located Name -> TcM TyCon -tcFamInstDeclCombined mb_clsinfo fam_tc_lname - = do { -- Type family instances require -XTypeFamilies - -- and can't (currently) be in an hs-boot file - ; traceTc "tcFamInstDecl" (ppr fam_tc_lname) - ; type_families <- xoptM LangExt.TypeFamilies - ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc type_families $ badFamInstDecl fam_tc_lname - ; checkTc (not is_boot) $ badBootFamInstDeclErr - - -- Look up the family TyCon and check for validity including - -- check that toplevel type instances are not for associated types. - ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname - ; when (isNothing mb_clsinfo && -- Not in a class decl - isTyConAssoc fam_tc) -- but an associated type - (addErr $ assocInClassErr fam_tc_lname) - - ; return fam_tc } - -tcTyFamInstDecl :: Maybe ClsInstInfo - -> LTyFamInstDecl Name -> TcM FamInst - -- "type instance" -tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) - = setSrcSpan loc $ - tcAddTyFamInstCtxt decl $ - do { let fam_lname = tfe_tycon (unLoc eqn) - ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname - - -- (0) Check it's an open type family - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) - ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc) - - -- (1) do the work of verifying the synonym group - ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) mb_clsinfo eqn - - -- (2) check for validity - ; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch - - -- (3) construct coercion axiom - ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch] - ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch - ; newFamInst SynFamilyInst axiom } - -tcDataFamInstDecl :: Maybe ClsInstInfo - -> LDataFamInstDecl Name -> TcM (FamInst, Maybe DerivInfo) - -- "newtype instance" and "data instance" -tcDataFamInstDecl mb_clsinfo - (L loc decl@(DataFamInstDecl - { dfid_pats = pats - , dfid_tycon = fam_tc_name - , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = ctxt, dd_cons = cons - , dd_derivs = derivs } })) - = setSrcSpan loc $ - tcAddDataFamInstCtxt decl $ - do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name - - -- Check that the family declaration is for the right kind - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) - ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - - -- Kind check type patterns - ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo pats - (kcDataDefn (unLoc fam_tc_name) pats defn) $ - \tvs pats res_kind -> - do { stupid_theta <- solveEqualities $ tcHsContext ctxt - - -- Zonk the patterns etc into the Type world - ; (ze, tvs') <- zonkTyBndrsX emptyZonkEnv tvs - ; pats' <- zonkTcTypeToTypes ze pats - ; res_kind' <- zonkTcTypeToType ze res_kind - ; stupid_theta' <- zonkTcTypeToTypes ze stupid_theta - - ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta' cons - - -- Construct representation tycon - ; rep_tc_name <- newFamInstTyConName fam_tc_name pats' - ; axiom_name <- newFamInstAxiomName fam_tc_name [pats'] - - ; let (eta_pats, etad_tvs) = eta_reduce pats' - eta_tvs = filterOut (`elem` etad_tvs) tvs' - full_tvs = eta_tvs ++ etad_tvs - -- Put the eta-removed tyvars at the end - -- Remember, tvs' is in arbitrary order (except kind vars are - -- first, so there is no reason to suppose that the etad_tvs - -- (obtained from the pats) are at the end (Trac #11148) - orig_res_ty = mkTyConApp fam_tc pats' - - ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> - do { let ty_binders = mkTyConBindersPreferAnon full_tvs liftedTypeKind - ; data_cons <- tcConDecls rec_rep_tc - (ty_binders, orig_res_ty) cons - ; tc_rhs <- case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) - -- freshen tyvars - ; let axiom = mkSingleCoAxiom Representational - axiom_name eta_tvs [] fam_tc eta_pats - (mkTyConApp rep_tc (mkTyVarTys eta_tvs)) - parent = DataFamInstTyCon axiom fam_tc pats' - - - -- NB: Use the full_tvs from the pats. See bullet toward - -- the end of Note [Data type families] in TyCon - rep_tc = mkAlgTyCon rep_tc_name - ty_binders liftedTypeKind - (map (const Nominal) full_tvs) - (fmap unLoc cType) stupid_theta - tc_rhs parent - gadt_syntax - -- We always assume that indexed types are recursive. Why? - -- (1) Due to their open nature, we can never be sure that a - -- further instance might not introduce a new recursive - -- dependency. (2) They are always valid loop breakers as - -- they involve a coercion. - ; return (rep_tc, axiom) } - - -- Remember to check validity; no recursion to worry about here - -- Check that left-hand sides are ok (mono-types, no type families, - -- consistent instantiations, etc) - ; checkValidFamPats mb_clsinfo fam_tc tvs' [] pats' - - -- Result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (isLiftedTypeKind res_kind') $ - tooFewParmsErr (tyConArity fam_tc) - - ; checkValidTyCon rep_tc - - ; let m_deriv_info = case derivs of - L _ [] -> Nothing - L _ preds -> - Just $ DerivInfo { di_rep_tc = rep_tc - , di_clauses = preds - , di_ctxt = tcMkDataFamInstCtxt decl } - - ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom - ; return (fam_inst, m_deriv_info) } } - where - eta_reduce :: [Type] -> ([Type], [TyVar]) - -- See Note [Eta reduction for data families] in FamInstEnv - -- Splits the incoming patterns into two: the [TyVar] - -- are the patterns that can be eta-reduced away. - -- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c]) - -- - -- NB: quadratic algorithm, but types are small here - eta_reduce pats - = go (reverse pats) [] - go (pat:pats) etad_tvs - | Just tv <- getTyVar_maybe pat - , not (tv `elemVarSet` tyCoVarsOfTypes pats) - = go pats (tv : etad_tvs) - go pats etad_tvs = (reverse pats, etad_tvs) - - -{- ********************************************************************* -* * - Type-checking instance declarations, pass 2 -* * -********************************************************************* -} - -tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name] - -> TcM (LHsBinds Id) --- (a) From each class declaration, --- generate any default-method bindings --- (b) From each instance decl --- generate the dfun binding - -tcInstDecls2 tycl_decls inst_decls - = do { -- (a) Default methods from class decls - let class_decls = filter (isClassDecl . unLoc) tycl_decls - ; dm_binds_s <- mapM tcClassDecl2 class_decls - ; let dm_binds = unionManyBags dm_binds_s - - -- (b) instance declarations - ; let dm_ids = collectHsBindsBinders dm_binds - -- Add the default method Ids (again) - -- (they were arready added in TcTyDecls.tcAddImplicits) - -- See Note [Default methods in the type environment] - ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ - mapM tcInstDecl2 inst_decls - - -- Done - ; return (dm_binds `unionBags` unionManyBags inst_binds_s) } - -{- Note [Default methods in the type environment] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The default method Ids are already in the type environment (see Note -[Default method Ids and Template Haskell] in TcTyDcls), BUT they -don't have their InlinePragmas yet. Usually that would not matter, -because the simplifier propagates information from binding site to -use. But, unusually, when compiling instance decls we *copy* the -INLINE pragma from the default method to the method for that -particular operation (see Note [INLINE and default methods] below). - -So right here in tcInstDecls2 we must re-extend the type envt with -the default method Ids replete with their INLINE pragmas. Urk. --} - -tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) - -- Returns a binding for the dfun -tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) - = recoverM (return emptyLHsBinds) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ - do { -- Instantiate the instance decl with skolem constants - ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id - ; dfun_ev_vars <- newEvVars dfun_theta - -- We instantiate the dfun_id with superSkolems. - -- See Note [Subtle interaction of recursion and overlap] - -- and Note [Binding when looking up instances] - - ; let (clas, inst_tys) = tcSplitDFunHead inst_head - (class_tyvars, sc_theta, _, op_items) = classBigSig clas - sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta - - ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta']) - - -- Deal with 'SPECIALISE instance' pragmas - -- See Note [SPECIALISE instance pragmas] - ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds - - -- Typecheck superclasses and methods - -- See Note [Typechecking plan for instance declarations] - ; dfun_ev_binds_var <- newTcEvBinds - ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var - ; ((sc_meth_ids, sc_meth_binds, sc_meth_implics), tclvl) - <- pushTcLevelM $ - do { (sc_ids, sc_binds, sc_implics) - <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars - inst_tys dfun_ev_binds - sc_theta' - - -- Typecheck the methods - ; (meth_ids, meth_binds, meth_implics) - <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars - inst_tys dfun_ev_binds spec_inst_info - op_items ibinds - - ; return ( sc_ids ++ meth_ids - , sc_binds `unionBags` meth_binds - , sc_implics `unionBags` meth_implics ) } - - ; env <- getLclEnv - ; emitImplication $ Implic { ic_tclvl = tclvl - , ic_skols = inst_tyvars - , ic_no_eqs = False - , ic_given = dfun_ev_vars - , ic_wanted = mkImplicWC sc_meth_implics - , ic_status = IC_Unsolved - , ic_binds = dfun_ev_binds_var - , ic_needed = emptyVarSet - , ic_env = env - , ic_info = InstSkol } - - -- Create the result bindings - ; self_dict <- newDict clas inst_tys - ; let class_tc = classTyCon clas - [dict_constr] = tyConDataCons class_tc - dict_bind = mkVarBind self_dict (L loc con_app_args) - - -- We don't produce a binding for the dict_constr; instead we - -- rely on the simplifier to unfold this saturated application - -- We do this rather than generate an HsCon directly, because - -- it means that the special cases (e.g. dictionary with only one - -- member) are dealt with by the common MkId.mkDataConWrapId - -- code rather than needing to be repeated here. - -- con_app_tys = MkD ty1 ty2 - -- con_app_scs = MkD ty1 ty2 sc1 sc2 - -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 - con_app_tys = mkHsWrap (mkWpTyApps inst_tys) - (HsConLikeOut (RealDataCon dict_constr)) - -- NB: We *can* have covars in inst_tys, in the case of - -- promoted GADT constructors. - - con_app_args = foldl app_to_meth con_app_tys sc_meth_ids - - app_to_meth :: HsExpr Id -> Id -> HsExpr Id - app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id) - - inst_tv_tys = mkTyVarTys inst_tyvars - arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys - - is_newtype = isNewTyCon class_tc - dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids - dfun_spec_prags - | is_newtype = SpecPrags [] - | otherwise = SpecPrags spec_inst_prags - -- Newtype dfuns just inline unconditionally, - -- so don't attempt to specialise them - - export = ABE { abe_wrap = idHsWrapper - , abe_poly = dfun_id_w_prags - , abe_mono = self_dict - , abe_prags = dfun_spec_prags } - -- NB: see Note [SPECIALISE instance pragmas] - main_bind = AbsBinds { abs_tvs = inst_tyvars - , abs_ev_vars = dfun_ev_vars - , abs_exports = [export] - , abs_ev_binds = [] - , abs_binds = unitBag dict_bind } - - ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds) - } - where - dfun_id = instanceDFunId ispec - loc = getSrcSpan dfun_id - -addDFunPrags :: DFunId -> [Id] -> DFunId --- DFuns need a special Unfolding and InlinePrag --- See Note [ClassOp/DFun selection] --- and Note [Single-method classes] --- It's easiest to create those unfoldings right here, where --- have all the pieces in hand, even though we are messing with --- Core at this point, which the typechecker doesn't usually do --- However we take care to build the unfolding using the TyVars from --- the DFunId rather than from the skolem pieces that the typechecker --- is messing with. -addDFunPrags dfun_id sc_meth_ids - | is_newtype - = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app - `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } - | otherwise - = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args - `setInlinePragma` dfunInlinePragma - where - con_app = mkLams dfun_bndrs $ - mkApps (Var (dataConWrapId dict_con)) dict_args - -- mkApps is OK because of the checkForLevPoly call in checkValidClass - -- See Note [Levity polymorphism checking] in DsMonad - dict_args = map Type inst_tys ++ - [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] - - (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id) - ev_ids = mkTemplateLocalsNum 1 dfun_theta - dfun_bndrs = dfun_tvs ++ ev_ids - clas_tc = classTyCon clas - [dict_con] = tyConDataCons clas_tc - is_newtype = isNewTyCon clas_tc - -wrapId :: HsWrapper -> id -> HsExpr id -wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id)) - -{- Note [Typechecking plan for instance declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For instance declarations we generate the following bindings and implication -constraints. Example: - - instance Ord a => Ord [a] where compare = - -generates this: - - Bindings: - -- Method bindings - $ccompare :: forall a. Ord a => a -> a -> Ordering - $ccompare = /\a \(d:Ord a). let in ... - - -- Superclass bindings - $cp1Ord :: forall a. Ord a => Eq [a] - $cp1Ord = /\a \(d:Ord a). let - in dfEqList (dw :: Eq a) - - Constraints: - forall a. Ord a => - -- Method constraint - (forall. (empty) => ) - -- Superclass constraint - /\ (forall. (empty) => dw :: Eq a) - -Notice that - - * Per-meth/sc implication. There is one inner implication per - superclass or method, with no skolem variables or givens. The only - reason for this one is to gather the evidence bindings privately - for this superclass or method. This implication is generated - by checkInstConstraints. - - * Overall instance implication. There is an overall enclosing - implication for the whole instance declaratation, with the expected - skolems and givens. We need this to get the correct "redundant - constraint" warnings, gathering all the uses from all the methods - and superclasses. See TcSimplify Note [Tracking redundant - constraints] - - * The given constraints in the outer implication may generate - evidence, notably by superclass selection. Since the method and - superclass bindings are top-level, we want that evidence copied - into *every* method or superclass definition. (Some of it will - be usused in some, but dead-code elimination will drop it.) - - We achieve this by putting the the evidence variable for the overall - instance implication into the AbsBinds for each method/superclass. - Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses. - (And that in turn is why the abs_ev_binds field of AbBinds is a - [TcEvBinds] rather than simply TcEvBinds. - - This is a bit of a hack, but works very nicely in practice. - - * Note that if a method has a locally-polymorphic binding, there will - be yet another implication for that, generated by tcPolyCheck - in tcMethodBody. E.g. - class C a where - foo :: forall b. Ord b => blah - - -************************************************************************ -* * - Type-checking superclasses -* * -************************************************************************ --} - -tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] - -> TcEvBinds - -> TcThetaType - -> TcM ([EvVar], LHsBinds Id, Bag Implication) --- Make a new top-level function binding for each superclass, --- something like --- $Ordp1 :: forall a. Ord a => Eq [a] --- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d) --- --- See Note [Recursive superclasses] for why this is so hard! --- In effect, we build a special-purpose solver for the first step --- of solving each superclass constraint -tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta - = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..]) - ; return (ids, listToBag binds, listToBag implics) } - where - loc = getSrcSpan dfun_id - size = sizeTypes inst_tys - tc_super (sc_pred, n) - = do { (sc_implic, ev_binds_var, sc_ev_tm) - <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred - - ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) - ; sc_ev_id <- newEvVar sc_pred - ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm - ; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred) - sc_top_id = mkLocalId sc_top_name sc_top_ty - export = ABE { abe_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_tvs = tyvars - , abs_ev_vars = dfun_evs - , abs_exports = [export] - , abs_ev_binds = [dfun_ev_binds, local_ev_binds] - , abs_binds = emptyBag } - ; return (sc_top_id, L loc bind, sc_implic) } - -------------------- -checkInstConstraints :: TcM result - -> TcM (Implication, EvBindsVar, result) --- See Note [Typechecking plan for instance declarations] -checkInstConstraints thing_inside - = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $ - thing_inside - - ; ev_binds_var <- newTcEvBinds - ; env <- getLclEnv - ; let implic = Implic { ic_tclvl = tclvl - , ic_skols = [] - , ic_no_eqs = False - , ic_given = [] - , ic_wanted = wanted - , ic_status = IC_Unsolved - , ic_binds = ev_binds_var - , ic_needed = emptyVarSet - , ic_env = env - , ic_info = InstSkol } - - ; return (implic, ev_binds_var, result) } - -{- -Note [Recursive superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Trac #3731, #4809, #5751, #5913, #6117, #6161, which all -describe somewhat more complicated situations, but ones -encountered in practice. - -See also tests tcrun020, tcrun021, tcrun033, and Trac #11427. - ------ THE PROBLEM -------- -The problem is that it is all too easy to create a class whose -superclass is bottom when it should not be. - -Consider the following (extreme) situation: - class C a => D a where ... - instance D [a] => D [a] where ... (dfunD) - instance C [a] => C [a] where ... (dfunC) -Although this looks wrong (assume D [a] to prove D [a]), it is only a -more extreme case of what happens with recursive dictionaries, and it -can, just about, make sense because the methods do some work before -recursing. - -To implement the dfunD we must generate code for the superclass C [a], -which we had better not get by superclass selection from the supplied -argument: - dfunD :: forall a. D [a] -> D [a] - dfunD = \d::D [a] -> MkD (scsel d) .. - -Otherwise if we later encounter a situation where -we have a [Wanted] dw::D [a] we might solve it thus: - dw := dfunD dw -Which is all fine except that now ** the superclass C is bottom **! - -The instance we want is: - dfunD :: forall a. D [a] -> D [a] - dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ... - ------ THE SOLUTION -------- -The basic solution is simple: be very careful about using superclass -selection to generate a superclass witness in a dictionary function -definition. More precisely: - - Superclass Invariant: in every class dictionary, - every superclass dictionary field - is non-bottom - -To achieve the Superclass Invariant, in a dfun definition we can -generate a guaranteed-non-bottom superclass witness from: - (sc1) one of the dictionary arguments itself (all non-bottom) - (sc2) an immediate superclass of a smaller dictionary - (sc3) a call of a dfun (always returns a dictionary constructor) - -The tricky case is (sc2). We proceed by induction on the size of -the (type of) the dictionary, defined by TcValidity.sizeTypes. -Let's suppose we are building a dictionary of size 3, and -suppose the Superclass Invariant holds of smaller dictionaries. -Then if we have a smaller dictionary, its immediate superclasses -will be non-bottom by induction. - -What does "we have a smaller dictionary" mean? It might be -one of the arguments of the instance, or one of its superclasses. -Here is an example, taken from CmmExpr: - class Ord r => UserOfRegs r a where ... -(i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where -(i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where - -For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a), -since it is smaller than the thing we are building (UserOfRegs r (Maybe a). - -But for (i2) that isn't the case, so we must add an explicit, and -perhaps surprising, (Ord r) argument to the instance declaration. - -Here's another example from Trac #6161: - - class Super a => Duper a where ... - class Duper (Fam a) => Foo a where ... -(i3) instance Foo a => Duper (Fam a) where ... -(i4) instance Foo Float where ... - -It would be horribly wrong to define - dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3) - dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ... - - dfFooFloat :: Foo Float -- from (i4) - dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ... - -Now the Super superclass of Duper is definitely bottom! - -This won't happen because when processing (i3) we can use the -superclasses of (Foo a), which is smaller, namely Duper (Fam a). But -that is *not* smaller than the target so we can't take *its* -superclasses. As a result the program is rightly rejected, unless you -add (Super (Fam a)) to the context of (i3). - -Note [Solving superclass constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How do we ensure that every superclass witness is generated by -one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses]. -Answer: - - * Superclass "wanted" constraints have CtOrigin of (ScOrigin size) - where 'size' is the size of the instance declaration. e.g. - class C a => D a where... - instance blah => D [a] where ... - The wanted superclass constraint for C [a] has origin - ScOrigin size, where size = size( D [a] ). - - * (sc1) When we rewrite such a wanted constraint, it retains its - origin. But if we apply an instance declaration, we can set the - origin to (ScOrigin infinity), thus lifting any restrictions by - making prohibitedSuperClassSolve return False. - - * (sc2) ScOrigin wanted constraints can't be solved from a - superclass selection, except at a smaller type. This test is - implemented by TcInteract.prohibitedSuperClassSolve - - * The "given" constraints of an instance decl have CtOrigin - GivenOrigin InstSkol. - - * When we make a superclass selection from InstSkol we use - a SkolemInfo of (InstSC size), where 'size' is the size of - the constraint whose superclass we are taking. An similarly - when taking the superclass of an InstSC. This is implemented - in TcCanonical.newSCWorkFromFlavored - -Note [Silent superclass arguments] (historical interest only) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB1: this note describes our *old* solution to the - recursive-superclass problem. I'm keeping the Note - for now, just as institutional memory. - However, the code for silent superclass arguments - was removed in late Dec 2014 - -NB2: the silent-superclass solution introduced new problems - of its own, in the form of instance overlap. Tests - SilentParametersOverlapping, T5051, and T7862 are examples - -NB3: the silent-superclass solution also generated tons of - extra dictionaries. For example, in monad-transformer - code, when constructing a Monad dictionary you had to pass - an Applicative dictionary; and to construct that you neede - a Functor dictionary. Yet these extra dictionaries were - often never used. Test T3064 compiled *far* faster after - silent superclasses were eliminated. - -Our solution to this problem "silent superclass arguments". We pass -to each dfun some ``silent superclass arguments’’, which are the -immediate superclasses of the dictionary we are trying to -construct. In our example: - dfun :: forall a. C [a] -> D [a] -> D [a] - dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... -Notice the extra (dc :: C [a]) argument compared to the previous version. - -This gives us: - - ----------------------------------------------------------- - DFun Superclass Invariant - ~~~~~~~~~~~~~~~~~~~~~~~~ - In the body of a DFun, every superclass argument to the - returned dictionary is - either * one of the arguments of the DFun, - or * constant, bound at top level - ----------------------------------------------------------- - -This net effect is that it is safe to treat a dfun application as -wrapping a dictionary constructor around its arguments (in particular, -a dfun never picks superclasses from the arguments under the -dictionary constructor). No superclass is hidden inside a dfun -application. - -The extra arguments required to satisfy the DFun Superclass Invariant -always come first, and are called the "silent" arguments. You can -find out how many silent arguments there are using Id.dfunNSilent; -and then you can just drop that number of arguments to see the ones -that were in the original instance declaration. - -DFun types are built (only) by MkId.mkDictFunId, so that is where we -decide what silent arguments are to be added. --} - -{- -************************************************************************ -* * - Type-checking an instance method -* * -************************************************************************ - -tcMethod -- Make the method bindings, as a [(NonRec, HsBinds)], one per method -- Remembering to use fresh Name (the instance method Name) as the binder -- Bring the instance method Ids into scope, for the benefit of tcInstSig -- Use sig_fn mapping instance method Name -> instance tyvars -- Ditto prag_fn -- Use tcValBinds to do the checking --} - -tcMethods :: DFunId -> Class - -> [TcTyVar] -> [EvVar] - -> [TcType] - -> TcEvBinds - -> ([Located TcSpecPrag], TcPragEnv) - -> [ClassOpItem] - -> InstBindings Name - -> TcM ([Id], LHsBinds Id, Bag Implication) - -- The returned inst_meth_ids all have types starting - -- forall tvs. theta => ... -tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds (spec_inst_prags, prag_fn) op_items - (InstBindings { ib_binds = binds - , ib_tyvars = lexical_tvs - , ib_pragmas = sigs - , ib_extensions = exts - , ib_derived = is_derived }) - = tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $ - -- The lexical_tvs scope over the 'where' part - do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) - ; checkMinimalDefinition - ; (ids, binds, mb_implics) <- set_exts exts $ - mapAndUnzip3M tc_item op_items - ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) } - where - set_exts :: [LangExt.Extension] -> TcM a -> TcM a - set_exts es thing = foldr setXOptM thing es - - hs_sig_fn = mkHsSigFun sigs - inst_loc = getSrcSpan dfun_id - - ---------------------- - tc_item :: ClassOpItem -> TcM (Id, LHsBind Id, Maybe Implication) - tc_item (sel_id, dm_info) - | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn - = tcMethodBody clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived hs_sig_fn - spec_inst_prags prags - sel_id user_bind bndr_loc - | otherwise - = do { traceTc "tc_def" (ppr sel_id) - ; tc_default sel_id dm_info } - - ---------------------- - tc_default :: Id -> DefMethInfo -> TcM (TcId, LHsBind Id, Maybe Implication) - - tc_default sel_id (Just (dm_name, _)) - = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name - ; tcMethodBody clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived hs_sig_fn - spec_inst_prags inline_prags - sel_id meth_bind inst_loc } - - tc_default sel_id Nothing -- No default method at all - = do { traceTc "tc_def: warn" (ppr sel_id) - ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id - ; dflags <- getDynFlags - ; let meth_bind = mkVarBind meth_id $ - mkLHsWrap lam_wrapper (error_rhs dflags) - ; return (meth_id, meth_bind, Nothing) } - where - error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) - error_fun = L inst_loc $ - wrapId (mkWpTyApps - [ getRuntimeRep meth_tau, meth_tau]) - nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L inst_loc (HsLit (HsStringPrim NoSourceText - (unsafeMkByteString (error_string dflags)))) - meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys) - error_string dflags = showSDoc dflags - (hcat [ppr inst_loc, vbar, ppr sel_id ]) - lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars - - ---------------------- - -- Check if one of the minimal complete definitions is satisfied - checkMinimalDefinition - = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ - warnUnsatisfiedMinimalDefinition - - methodExists meth = isJust (findMethodBind meth binds prag_fn) - ------------------------- -tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType] - -> TcEvBinds -> Bool - -> HsSigFun - -> [LTcSpecPrag] -> [LSig Name] - -> Id -> LHsBind Name -> SrcSpan - -> TcM (TcId, LHsBind Id, Maybe Implication) -tcMethodBody clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived - sig_fn spec_inst_prags prags - sel_id (L bind_loc meth_bind) bndr_loc - = add_meth_ctxt $ - do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc) - ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $ - mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id - - ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) } - -- Substitute the local_meth_name for the binder - -- NB: the binding is always a FunBind - - -- taking instance signature into account might change the type of - -- the local_meth_id - ; (meth_implic, ev_binds_var, tc_bind) - <- checkInstConstraints $ - tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind) - - ; global_meth_id <- addInlinePrags global_meth_id prags - ; spec_prags <- tcSpecPrags global_meth_id prags - - ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags - export = ABE { abe_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_tvs = tyvars - , abs_ev_vars = dfun_ev_vars - , abs_exports = [export] - , abs_ev_binds = [dfun_ev_binds, local_ev_binds] - , abs_binds = tc_bind } - - ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) } - where - -- For instance decls that come from deriving clauses - -- we want to print out the full source code if there's an error - -- because otherwise the user won't see the code at all - add_meth_ctxt thing - | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing - | otherwise = thing - -tcMethodBodyHelp :: HsSigFun -> Id -> TcId - -> LHsBind Name -> TcM (LHsBinds TcId) -tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind - | Just hs_sig_ty <- hs_sig_fn sel_name - -- There is a signature in the instance - -- See Note [Instance method signatures] - = do { let ctxt = FunSigCtxt sel_name True - ; (sig_ty, hs_wrap) - <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $ - do { inst_sigs <- xoptM LangExt.InstanceSigs - ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty) - ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty - ; let local_meth_ty = idType local_meth_id - ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $ - tcSubType_NC ctxt sig_ty local_meth_ty - ; return (sig_ty, hs_wrap) } - - ; inner_meth_name <- newName (nameOccName sel_name) - ; let inner_meth_id = mkLocalId inner_meth_name sig_ty - inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id - , sig_ctxt = ctxt - , sig_loc = getLoc (hsSigType hs_sig_ty) } - - - ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind - - ; let export = ABE { abe_poly = local_meth_id - , abe_mono = inner_id - , abe_wrap = hs_wrap - , abe_prags = noSpecPrags } - - ; return (unitBag $ L (getLoc meth_bind) $ - AbsBinds { abs_tvs = [], abs_ev_vars = [] - , abs_exports = [export] - , abs_binds = tc_bind, abs_ev_binds = [] }) } - - | otherwise -- No instance signature - = do { let ctxt = FunSigCtxt sel_name False - -- False <=> don't report redundant constraints - -- The signature is not under the users control! - tc_sig = completeSigFromId ctxt local_meth_id - -- Absent a type sig, there are no new scoped type variables here - -- Only the ones from the instance decl itself, which are already - -- in scope. Example: - -- class C a where { op :: forall b. Eq b => ... } - -- instance C [c] where { op = } - -- In , 'c' is scope but 'b' is not! - - ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind - ; return tc_bind } - - where - sel_name = idName sel_id - no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; - -- they are all for meth_id - - ------------------------- -mkMethIds :: Class -> [TcTyVar] -> [EvVar] - -> [TcType] -> Id -> TcM (TcId, TcId) - -- returns (poly_id, local_id), but ignoring any instance signature - -- See Note [Instance method signatures] -mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ) - ; local_meth_name <- newName sel_occ - -- Base the local_meth_name on the selector name, because - -- type errors from tcMethodBody come from here - ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty - local_meth_id = mkLocalId local_meth_name local_meth_ty - - ; return (poly_meth_id, local_meth_id) } - where - sel_name = idName sel_id - sel_occ = nameOccName sel_name - local_meth_ty = instantiateMethod clas sel_id inst_tys - poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty - theta = map idType dfun_ev_vars - -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) -methSigCtxt sel_name sig_ty meth_ty env0 - = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty - ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty - ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name)) - 2 (vcat [ text "is more general than its signature in the class" - , text "Instance sig:" <+> ppr sig_ty - , text " Class sig:" <+> ppr meth_ty ]) - ; return (env2, msg) } - -misplacedInstSig :: Name -> LHsSigType Name -> SDoc -misplacedInstSig name hs_ty - = vcat [ hang (text "Illegal type signature in instance declaration:") - 2 (hang (pprPrefixName name) - 2 (dcolon <+> ppr hs_ty)) - , text "(Use InstanceSigs to allow this)" ] - -{- Note [Instance method signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XInstanceSigs we allow the user to supply a signature for the -method in an instance declaration. Here is an artificial example: - - data T a = MkT a - instance Ord a => Ord (T a) where - (>) :: forall b. b -> b -> Bool - (>) = error "You can't compare Ts" - -The instance signature can be *more* polymorphic than the instantiated -class method (in this case: Age -> Age -> Bool), but it cannot be less -polymorphic. Moreover, if a signature is given, the implementation -code should match the signature, and type variables bound in the -singature should scope over the method body. - -We achieve this by building a TcSigInfo for the method, whether or not -there is an instance method signature, and using that to typecheck -the declaration (in tcMethodBody). That means, conveniently, -that the type variables bound in the signature will scope over the body. - -What about the check that the instance method signature is more -polymorphic than the instantiated class method type? We just do a -tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like -this (for the example above - - AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a] - , abs_exports - = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool - , gr_lcl :: T a -> T a -> Bool } - , abs_binds - = AbsBind { abs_tvs = [], abs_ev_vars = [] - , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool - , gr_inner :: forall b. b -> b -> Bool } - , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = [] - , ..etc.. } - } } - -Wow! Three nested AbsBinds! - * The outer one abstracts over the tyvars and dicts for the instance - * The middle one is only present if there is an instance signature, - and does the impedance matching for that signature - * The inner one is for the method binding itself against either the - signature from the class, or the the instance signature. --} - ----------------------- -mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags - -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id - -- There are two sources: - -- * spec_prags_for_me: {-# SPECIALISE op :: #-} - -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: #-} - -- These ones have the dfun inside, but [perhaps surprisingly] - -- the correct wrapper. - -- See Note [Handling SPECIALISE pragmas] in TcBinds -mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me - = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) - where - spec_prags_from_inst - | isInlinePragma (idInlinePragma meth_id) - = [] -- Do not inherit SPECIALISE from the instance if the - -- method is marked INLINE, because then it'll be inlined - -- and the specialisation would do nothing. (Indeed it'll provoke - -- a warning from the desugarer - | otherwise - = [ L inst_loc (SpecPrag meth_id wrap inl) - | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] - - -mkDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name, [LSig Name]) --- The is a default method (vanailla or generic) defined in the class --- So make a binding op = $dmop @t1 @t2 --- where $dmop is the name of the default method in the class, --- and t1,t2 are the instance types. --- See Note [Default methods in instances] for why we use --- visible type application here -mkDefMethBind clas inst_tys sel_id dm_name - = do { dflags <- getDynFlags - ; dm_id <- tcLookupId dm_name - ; let inline_prag = idInlinePragma dm_id - inline_prags | isAnyInlinePragma inline_prag - = [noLoc (InlineSig fn inline_prag)] - | otherwise - = [] - -- Copy the inline pragma (if any) from the default method - -- to this version. Note [INLINE and default methods] - - fn = noLoc (idName sel_id) - visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys - , tyConBinderArgFlag tcb /= Inferred ] - rhs = foldl mk_vta (nlHsVar dm_name) visible_inst_tys - bind = noLoc $ mkTopFunBind Generated fn $ - [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] - - ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" - (vcat [ppr clas <+> ppr inst_tys, - nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) - - ; return (bind, inline_prags) } - where - mk_vta :: LHsExpr Name -> Type -> LHsExpr Name - mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs $ noLoc $ HsCoreTy ty)) - -- NB: use visible type application - -- See Note [Default methods in instances] - ----------------------- -derivBindCtxt :: Id -> Class -> [Type ] -> SDoc -derivBindCtxt sel_id clas tys - = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id) - , nest 2 (text "in a derived instance for" - <+> quotes (pprClassPred clas tys) <> colon) - , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ] - -warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () -warnUnsatisfiedMinimalDefinition mindef - = do { warn <- woptM Opt_WarnMissingMethods - ; warnTc (Reason Opt_WarnMissingMethods) warn message - } - where - message = vcat [text "No explicit implementation for" - ,nest 2 $ pprBooleanFormulaNice mindef - ] - -{- -Note [Export helper functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We arrange to export the "helper functions" of an instance declaration, -so that they are not subject to preInlineUnconditionally, even if their -RHS is trivial. Reason: they are mentioned in the DFunUnfolding of -the dict fun as Ids, not as CoreExprs, so we can't substitute a -non-variable for them. - -We could change this by making DFunUnfoldings have CoreExprs, but it -seems a bit simpler this way. - -Note [Default methods in instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - - class Baz v x where - foo :: x -> x - foo y = - - instance Baz Int Int - -From the class decl we get - - $dmfoo :: forall v x. Baz v x => x -> x - $dmfoo y = - -Notice that the type is ambiguous. So we use Visible Type Application -to disambiguate: - - $dBazIntInt = MkBaz fooIntInt - fooIntInt = $dmfoo @Int @Int - -Lacking VTA we'd get ambiguity errors involving the default method. This applies -equally to vanilla default methods (Trac #1061) and generic default methods -(Trac #12220). - -Historical note: before we had VTA we had to generate -post-type-checked code, which took a lot more code, and didn't work for -generic default methods. - -Note [INLINE and default methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Default methods need special case. They are supposed to behave rather like -macros. For exmample - - class Foo a where - op1, op2 :: Bool -> a -> a - - {-# INLINE op1 #-} - op1 b x = op2 (not b) x - - instance Foo Int where - -- op1 via default method - op2 b x = - -The instance declaration should behave - - just as if 'op1' had been defined with the - code, and INLINE pragma, from its original - definition. - -That is, just as if you'd written - - instance Foo Int where - op2 b x = - - {-# INLINE op1 #-} - op1 b x = op2 (not b) x - -So for the above example we generate: - - {-# INLINE $dmop1 #-} - -- $dmop1 has an InlineCompulsory unfolding - $dmop1 d b x = op2 d (not b) x - - $fFooInt = MkD $cop1 $cop2 - - {-# INLINE $cop1 #-} - $cop1 = $dmop1 $fFooInt - - $cop2 = - -Note carefully: - -* We *copy* any INLINE pragma from the default method $dmop1 to the - instance $cop1. Otherwise we'll just inline the former in the - latter and stop, which isn't what the user expected - -* Regardless of its pragma, we give the default method an - unfolding with an InlineCompulsory source. That means - that it'll be inlined at every use site, notably in - each instance declaration, such as $cop1. This inlining - must happen even though - a) $dmop1 is not saturated in $cop1 - b) $cop1 itself has an INLINE pragma - - It's vital that $dmop1 *is* inlined in this way, to allow the mutual - recursion between $fooInt and $cop1 to be broken - -* To communicate the need for an InlineCompulsory to the desugarer - (which makes the Unfoldings), we use the IsDefaultMethod constructor - in TcSpecPrags. - - -************************************************************************ -* * - Specialise instance pragmas -* * -************************************************************************ - -Note [SPECIALISE instance pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - instance (Ix a, Ix b) => Ix (a,b) where - {-# SPECIALISE instance Ix (Int,Int) #-} - range (x,y) = ... - -We make a specialised version of the dictionary function, AND -specialised versions of each *method*. Thus we should generate -something like this: - - $dfIxPair :: (Ix a, Ix b) => Ix (a,b) - {-# DFUN [$crangePair, ...] #-} - {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-} - $dfIxPair da db = Ix ($crangePair da db) (...other methods...) - - $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] - {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} - $crange da db = - -The SPECIALISE pragmas are acted upon by the desugarer, which generate - - dii :: Ix Int - dii = ... - - $s$dfIxPair :: Ix ((Int,Int),(Int,Int)) - {-# DFUN [$crangePair di di, ...] #-} - $s$dfIxPair = Ix ($crangePair di di) (...) - - {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-} - - $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)] - $c$crangePair = ...specialised RHS of $crangePair... - - {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-} - -Note that - - * The specialised dictionary $s$dfIxPair is very much needed, in case we - call a function that takes a dictionary, but in a context where the - specialised dictionary can be used. See Trac #7797. - - * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because - it still has a DFunUnfolding. See Note [ClassOp/DFun selection] - - * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways: - --> {ClassOp rule for range} $crangePair Int Int d1 d2 - --> {SPEC rule for $crangePair} $s$crangePair - or thus: - --> {SPEC rule for $dfIxPair} range $s$dfIxPair - --> {ClassOpRule for range} $s$crangePair - It doesn't matter which way. - - * We want to specialise the RHS of both $dfIxPair and $crangePair, - but the SAME HsWrapper will do for both! We can call tcSpecPrag - just once, and pass the result (in spec_inst_info) to tcMethods. --} - -tcSpecInstPrags :: DFunId -> InstBindings Name - -> TcM ([Located TcSpecPrag], TcPragEnv) -tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) - = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ - filter isSpecInstLSig uprags - -- The filter removes the pragmas for methods - ; return (spec_inst_prags, mkPragEnv uprags binds) } - ------------------------------- -tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag -tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) - = addErrCtxt (spec_ctxt prag) $ - do { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty - ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys - ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty - ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } - where - spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag) - -tcSpecInst _ _ = panic "tcSpecInst" - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -instDeclCtxt1 :: LHsSigType Name -> SDoc -instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - -instDeclCtxt2 :: Type -> SDoc -instDeclCtxt2 dfun_ty - = inst_decl_ctxt (ppr (mkClassPred cls tys)) - where - (_,_,cls,tys) = tcSplitDFunTy dfun_ty - -inst_decl_ctxt :: SDoc -> SDoc -inst_decl_ctxt doc = hang (text "In the instance declaration for") - 2 (quotes doc) - -badBootFamInstDeclErr :: SDoc -badBootFamInstDeclErr - = text "Illegal family instance in hs-boot file" - -notFamily :: TyCon -> SDoc -notFamily tycon - = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) - , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] - -tooFewParmsErr :: Arity -> SDoc -tooFewParmsErr arity - = text "Family instance has too few parameters; expected" <+> - ppr arity - -assocInClassErr :: Located Name -> SDoc -assocInClassErr name - = text "Associated type" <+> quotes (ppr name) <+> - text "must be inside a class instance" - -badFamInstDecl :: Located Name -> SDoc -badFamInstDecl tc_name - = vcat [ text "Illegal family instance for" <+> - quotes (ppr tc_name) - , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] - -notOpenFamily :: TyCon -> SDoc -notOpenFamily tc - = text "Illegal instance for closed family" <+> quotes (ppr tc) diff --git a/typecheck/TcInstDcls.hs-boot b/typecheck/TcInstDcls.hs-boot deleted file mode 100644 --- a/typecheck/TcInstDcls.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module TcInstDcls ( tcInstDecls1 ) where - -import HsSyn -import TcRnTypes -import TcEnv( InstInfo ) -import TcDeriv -import Name - --- We need this because of the mutual recursion --- between TcTyClsDecls and TcInstDcls -tcInstDecls1 :: [LInstDecl Name] -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo]) diff --git a/typecheck/TcInteract.hs b/typecheck/TcInteract.hs deleted file mode 100644 --- a/typecheck/TcInteract.hs +++ /dev/null @@ -1,2698 +0,0 @@ -{-# LANGUAGE CPP #-} - -module TcInteract ( - solveSimpleGivens, -- Solves [Ct] - solveSimpleWanteds, -- Solves Cts - - solveCallStack, -- for use in TcSimplify - ) where - -#include "HsVersions.h" - -import BasicTypes ( SwapFlag(..), isSwapped, - infinity, IntWithInf, intGtLimit ) -import HsTypes ( HsIPName(..) ) -import TcCanonical -import TcFlatten -import TcUnify( canSolveByUnification ) -import VarSet -import Type -import Kind( isConstraintKind ) -import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId ) -import CoAxiom( sfInteractTop, sfInteractInert ) - -import TcMType (newMetaTyVars) - -import Var -import TcType -import Name -import RdrName ( lookupGRE_FieldLabel ) -import PrelNames ( knownNatClassName, knownSymbolClassName, - typeableClassName, coercibleTyConKey, - hasFieldClassName, - heqTyConKey, ipClassKey ) -import TysWiredIn ( typeNatKind, typeSymbolKind, heqDataCon, - coercibleDataCon, constraintKindTyCon ) -import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) -import Id( idType, isNaughtyRecordSelector ) -import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches ) -import Class -import TyCon -import DataCon( dataConWrapId ) -import FieldLabel -import FunDeps -import FamInst -import FamInstEnv -import Unify ( tcUnifyTyWithTFs ) - -import TcEvidence -import Outputable - -import TcRnTypes -import TcSMonad -import Bag -import MonadUtils ( concatMapM ) - -import Data.List( partition, foldl', deleteFirstsBy ) -import SrcLoc -import VarEnv - -import Control.Monad -import Maybes( isJust ) -import Pair (Pair(..)) -import Unique( hasKey ) -import DynFlags -import Util -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe - -{- -********************************************************************** -* * -* Main Interaction Solver * -* * -********************************************************************** - -Note [Basic Simplifier Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -1. Pick an element from the WorkList if there exists one with depth - less than our context-stack depth. - -2. Run it down the 'stage' pipeline. Stages are: - - canonicalization - - inert reactions - - spontaneous reactions - - top-level intreactions - Each stage returns a StopOrContinue and may have sideffected - the inerts or worklist. - - The threading of the stages is as follows: - - If (Stop) is returned by a stage then we start again from Step 1. - - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to - the next stage in the pipeline. -4. If the element has survived (i.e. ContinueWith x) the last stage - then we add him in the inerts and jump back to Step 1. - -If in Step 1 no such element exists, we have exceeded our context-stack -depth and will simply fail. - -Note [Unflatten after solving the simple wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We unflatten after solving the wc_simples of an implication, and before attempting -to float. This means that - - * The fsk/fmv flatten-skolems only survive during solveSimples. We don't - need to worry about them across successive passes over the constraint tree. - (E.g. we don't need the old ic_fsk field of an implication. - - * When floating an equality outwards, we don't need to worry about floating its - associated flattening constraints. - - * Another tricky case becomes easy: Trac #4935 - type instance F True a b = a - type instance F False a b = b - - [w] F c a b ~ gamma - (c ~ True) => a ~ gamma - (c ~ False) => b ~ gamma - - Obviously this is soluble with gamma := F c a b, and unflattening - will do exactly that after solving the simple constraints and before - attempting the implications. Before, when we were not unflattening, - we had to push Wanted funeqs in as new givens. Yuk! - - Another example that becomes easy: indexed_types/should_fail/T7786 - [W] BuriedUnder sub k Empty ~ fsk - [W] Intersect fsk inv ~ s - [w] xxx[1] ~ s - [W] forall[2] . (xxx[1] ~ Empty) - => Intersect (BuriedUnder sub k Empty) inv ~ Empty - -Note [Running plugins on unflattened wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is an annoying mismatch between solveSimpleGivens and -solveSimpleWanteds, because the latter needs to fiddle with the inert -set, unflatten and zonk the wanteds. It passes the zonked wanteds -to runTcPluginsWanteds, which produces a replacement set of wanteds, -some additional insolubles and a flag indicating whether to go round -the loop again. If so, prepareInertsForImplications is used to remove -the previous wanteds (which will still be in the inert set). Note -that prepareInertsForImplications will discard the insolubles, so we -must keep track of them separately. --} - -solveSimpleGivens :: [Ct] -> TcS () -solveSimpleGivens givens - | null givens -- Shortcut for common case - = return () - | otherwise - = do { traceTcS "solveSimpleGivens {" (ppr givens) - ; go givens - ; traceTcS "End solveSimpleGivens }" empty } - where - go givens = do { solveSimples (listToBag givens) - ; new_givens <- runTcPluginsGiven - ; when (notNull new_givens) $ - go new_givens } - -solveSimpleWanteds :: Cts -> TcS WantedConstraints --- NB: 'simples' may contain /derived/ equalities, floated --- out from a nested implication. So don't discard deriveds! -solveSimpleWanteds simples - = do { traceTcS "solveSimpleWanteds {" (ppr simples) - ; dflags <- getDynFlags - ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples }) - ; traceTcS "solveSimpleWanteds end }" $ - vcat [ text "iterations =" <+> ppr n - , text "residual =" <+> ppr wc ] - ; return wc } - where - go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints) - go n limit wc - | n `intGtLimit` limit - = failTcS (hang (text "solveSimpleWanteds: too many iterations" - <+> parens (text "limit =" <+> ppr limit)) - 2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" - , text "Simples =" <+> ppr simples - , text "WC =" <+> ppr wc ])) - - | isEmptyBag (wc_simple wc) - = return (n,wc) - - | otherwise - = do { -- Solve - (unif_count, wc1) <- solve_simple_wanteds wc - - -- Run plugins - ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 - -- See Note [Running plugins on unflattened wanteds] - - ; if unif_count == 0 && not rerun_plugin - then return (n, wc2) -- Done - else do { traceTcS "solveSimple going round again:" $ - ppr unif_count $$ ppr rerun_plugin - ; go (n+1) limit wc2 } } -- Loop - - -solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints) --- Try solving these constraints --- Affects the unification state (of course) but not the inert set -solve_simple_wanteds (WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 }) - = nestTcS $ - do { solveSimples simples1 - ; (implics2, tv_eqs, fun_eqs, insols2, others) <- getUnsolvedInerts - ; (unif_count, unflattened_eqs) <- reportUnifications $ - unflatten tv_eqs fun_eqs - -- See Note [Unflatten after solving the simple wanteds] - ; return ( unif_count - , WC { wc_simple = others `andCts` unflattened_eqs - , wc_insol = insols1 `andCts` insols2 - , wc_impl = implics1 `unionBags` implics2 }) } - -{- Note [The solveSimpleWanteds loop] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Solving a bunch of simple constraints is done in a loop, -(the 'go' loop of 'solveSimpleWanteds'): - 1. Try to solve them; unflattening may lead to improvement that - was not exploitable during solving - 2. Try the plugin - 3. If step 1 did improvement during unflattening; or if the plugin - wants to run again, go back to step 1 - -Non-obviously, improvement can also take place during -the unflattening that takes place in step (1). See TcFlatten, -See Note [Unflattening can force the solver to iterate] --} - --- The main solver loop implements Note [Basic Simplifier Plan] ---------------------------------------------------------------- -solveSimples :: Cts -> TcS () --- Returns the final InertSet in TcS --- Has no effect on work-list or residual-implications --- The constraints are initially examined in left-to-right order - -solveSimples cts - = {-# SCC "solveSimples" #-} - do { updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts) - ; solve_loop } - where - solve_loop - = {-# SCC "solve_loop" #-} - do { sel <- selectNextWorkItem - ; case sel of - Nothing -> return () - Just ct -> do { runSolverPipeline thePipeline ct - ; solve_loop } } - --- | Extract the (inert) givens and invoke the plugins on them. --- Remove solved givens from the inert set and emit insolubles, but --- return new work produced so that 'solveSimpleGivens' can feed it back --- into the main solver. -runTcPluginsGiven :: TcS [Ct] -runTcPluginsGiven - = do { plugins <- getTcPlugins - ; if null plugins then return [] else - do { givens <- getInertGivens - ; if null givens then return [] else - do { p <- runTcPlugins plugins (givens,[],[]) - ; let (solved_givens, _, _) = pluginSolvedCts p - ; updInertCans (removeInertCts solved_givens) - ; mapM_ emitInsoluble (pluginBadCts p) - ; return (pluginNewCts p) } } } - --- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on --- them and produce an updated bag of wanteds (possibly with some new --- work) and a bag of insolubles. The boolean indicates whether --- 'solveSimpleWanteds' should feed the updated wanteds back into the --- main solver. -runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints) -runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 }) - | isEmptyBag simples1 - = return (False, wc) - | otherwise - = do { plugins <- getTcPlugins - ; if null plugins then return (False, wc) else - - do { given <- getInertGivens - ; simples1 <- zonkSimples simples1 -- Plugin requires zonked inputs - ; let (wanted, derived) = partition isWantedCt (bagToList simples1) - ; p <- runTcPlugins plugins (given, derived, wanted) - ; let (_, _, solved_wanted) = pluginSolvedCts p - (_, unsolved_derived, unsolved_wanted) = pluginInputCts p - new_wanted = pluginNewCts p - --- SLPJ: I'm deeply suspicious of this --- ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds) - - ; mapM_ setEv solved_wanted - ; return ( notNull (pluginNewCts p) - , WC { wc_simple = listToBag new_wanted `andCts` listToBag unsolved_wanted - `andCts` listToBag unsolved_derived - , wc_insol = listToBag (pluginBadCts p) `andCts` insols1 - , wc_impl = implics1 } ) } } - where - setEv :: (EvTerm,Ct) -> TcS () - setEv (ev,ct) = case ctEvidence ct of - CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev - _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" - --- | A triple of (given, derived, wanted) constraints to pass to plugins -type SplitCts = ([Ct], [Ct], [Ct]) - --- | A solved triple of constraints, with evidence for wanteds -type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)]) - --- | Represents collections of constraints generated by typechecker --- plugins -data TcPluginProgress = TcPluginProgress - { pluginInputCts :: SplitCts - -- ^ Original inputs to the plugins with solved/bad constraints - -- removed, but otherwise unmodified - , pluginSolvedCts :: SolvedCts - -- ^ Constraints solved by plugins - , pluginBadCts :: [Ct] - -- ^ Constraints reported as insoluble by plugins - , pluginNewCts :: [Ct] - -- ^ New constraints emitted by plugins - } - -getTcPlugins :: TcS [TcPluginSolver] -getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) } - --- | Starting from a triple of (given, derived, wanted) constraints, --- invoke each of the typechecker plugins in turn and return --- --- * the remaining unmodified constraints, --- * constraints that have been solved, --- * constraints that are insoluble, and --- * new work. --- --- Note that new work generated by one plugin will not be seen by --- other plugins on this pass (but the main constraint solver will be --- re-invoked and they will see it later). There is no check that new --- work differs from the original constraints supplied to the plugin: --- the plugin itself should perform this check if necessary. -runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress -runTcPlugins plugins all_cts - = foldM do_plugin initialProgress plugins - where - do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress - do_plugin p solver = do - result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p)) - return $ progress p result - - progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress - progress p (TcPluginContradiction bad_cts) = - p { pluginInputCts = discard bad_cts (pluginInputCts p) - , pluginBadCts = bad_cts ++ pluginBadCts p - } - progress p (TcPluginOk solved_cts new_cts) = - p { pluginInputCts = discard (map snd solved_cts) (pluginInputCts p) - , pluginSolvedCts = add solved_cts (pluginSolvedCts p) - , pluginNewCts = new_cts ++ pluginNewCts p - } - - initialProgress = TcPluginProgress all_cts ([], [], []) [] [] - - discard :: [Ct] -> SplitCts -> SplitCts - discard cts (xs, ys, zs) = - (xs `without` cts, ys `without` cts, zs `without` cts) - - without :: [Ct] -> [Ct] -> [Ct] - without = deleteFirstsBy eqCt - - eqCt :: Ct -> Ct -> Bool - eqCt c c' = ctFlavour c == ctFlavour c' - && ctPred c `tcEqType` ctPred c' - - add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts - add xs scs = foldl' addOne scs xs - - addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts - addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of - CtGiven {} -> (ct:givens, deriveds, wanteds) - CtDerived{} -> (givens, ct:deriveds, wanteds) - CtWanted {} -> (givens, deriveds, (ev,ct):wanteds) - - -type WorkItem = Ct -type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct) - -runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline - -> WorkItem -- The work item - -> TcS () --- Run this item down the pipeline, leaving behind new work and inerts -runSolverPipeline pipeline workItem - = do { wl <- getWorkList - ; inerts <- getTcSInerts - ; traceTcS "----------------------------- " empty - ; traceTcS "Start solver pipeline {" $ - vcat [ text "work item =" <+> ppr workItem - , text "inerts =" <+> ppr inerts - , text "rest of worklist =" <+> ppr wl ] - - ; bumpStepCountTcS -- One step for each constraint processed - ; final_res <- run_pipeline pipeline (ContinueWith workItem) - - ; case final_res of - Stop ev s -> do { traceFireTcS ev s - ; traceTcS "End solver pipeline (discharged) }" empty - ; return () } - ContinueWith ct -> do { addInertCan ct - ; traceFireTcS (ctEvidence ct) (text "Kept as inert") - ; traceTcS "End solver pipeline (kept as inert) }" $ - (text "final_item =" <+> ppr ct) } - } - where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct - -> TcS (StopOrContinue Ct) - run_pipeline [] res = return res - run_pipeline _ (Stop ev s) = return (Stop ev s) - run_pipeline ((stg_name,stg):stgs) (ContinueWith ct) - = do { traceTcS ("runStage " ++ stg_name ++ " {") - (text "workitem = " <+> ppr ct) - ; res <- stg ct - ; traceTcS ("end stage " ++ stg_name ++ " }") empty - ; run_pipeline stgs res } - -{- -Example 1: - Inert: {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given) - Reagent: a ~ [b] (given) - -React with (c~d) ==> IR (ContinueWith (a~[b])) True [] -React with (F a ~ t) ==> IR (ContinueWith (a~[b])) False [F [b] ~ t] -React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True [] - -Example 2: - Inert: {c ~w d, F a ~g t, b ~w Int, a ~w ty} - Reagent: a ~w [b] - -React with (c ~w d) ==> IR (ContinueWith (a~[b])) True [] -React with (F a ~g t) ==> IR (ContinueWith (a~[b])) True [] (can't rewrite given with wanted!) -etc. - -Example 3: - Inert: {a ~ Int, F Int ~ b} (given) - Reagent: F a ~ b (wanted) - -React with (a ~ Int) ==> IR (ContinueWith (F Int ~ b)) True [] -React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canonicalize and get nothing --} - -thePipeline :: [(String,SimplifierStage)] -thePipeline = [ ("canonicalization", TcCanonical.canonicalize) - , ("interact with inerts", interactWithInertsStage) - , ("top-level reactions", topReactionsStage) ] - -{- -********************************************************************************* -* * - The interact-with-inert Stage -* * -********************************************************************************* - -Note [The Solver Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We always add Givens first. So you might think that the solver has -the invariant - - If the work-item is Given, - then the inert item must Given - -But this isn't quite true. Suppose we have, - c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int -After processing the first two, we get - c1: [G] beta ~ [alpha], c2 : [W] blah -Now, c3 does not interact with the the given c1, so when we spontaneously -solve c3, we must re-react it with the inert set. So we can attempt a -reaction between inert c2 [W] and work-item c3 [G]. - -It *is* true that [Solver Invariant] - If the work-item is Given, - AND there is a reaction - then the inert item must Given -or, equivalently, - If the work-item is Given, - and the inert item is Wanted/Derived - then there is no reaction --} - --- Interaction result of WorkItem <~> Ct - -type StopNowFlag = Bool -- True <=> stop after this interaction - -interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct) --- Precondition: if the workitem is a CTyEqCan then it will not be able to --- react with anything at this stage. - -interactWithInertsStage wi - = do { inerts <- getTcSInerts - ; let ics = inert_cans inerts - ; case wi of - CTyEqCan {} -> interactTyVarEq ics wi - CFunEqCan {} -> interactFunEq ics wi - CIrredEvCan {} -> interactIrred ics wi - CDictCan {} -> interactDict ics wi - _ -> pprPanic "interactWithInerts" (ppr wi) } - -- CHoleCan are put straight into inert_frozen, so never get here - -- CNonCanonical have been canonicalised - -data InteractResult - = IRKeep -- Keep the existing inert constraint in the inert set - | IRReplace -- Replace the existing inert constraint with the work item - | IRDelete -- Delete the existing inert constraint from the inert set - -instance Outputable InteractResult where - ppr IRKeep = text "keep" - ppr IRReplace = text "replace" - ppr IRDelete = text "delete" - -solveOneFromTheOther :: CtEvidence -- Inert - -> CtEvidence -- WorkItem - -> TcS (InteractResult, StopNowFlag) --- Preconditions: --- 1) inert and work item represent evidence for the /same/ predicate --- 2) ip/class/irred constraints only; not used for equalities -solveOneFromTheOther ev_i ev_w - | isDerived ev_w -- Work item is Derived; just discard it - = return (IRKeep, True) - - | isDerived ev_i -- The inert item is Derived, we can just throw it away, - = return (IRDelete, False) -- The ev_w is inert wrt earlier inert-set items, - -- so it's safe to continue on from this point - - | CtWanted { ctev_loc = loc_w } <- ev_w - , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w - = return (IRDelete, False) - - | CtWanted { ctev_dest = dest } <- ev_w - -- Inert is Given or Wanted - = do { setWantedEvTerm dest (ctEvTerm ev_i) - ; return (IRKeep, True) } - - | CtWanted { ctev_loc = loc_i } <- ev_i -- Work item is Given - , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i - = return (IRKeep, False) -- Just discard the un-usable Given - -- This never actually happens because - -- Givens get processed first - - | CtWanted { ctev_dest = dest } <- ev_i - = do { setWantedEvTerm dest (ctEvTerm ev_w) - ; return (IRReplace, True) } - - -- So they are both Given - -- See Note [Replacement vs keeping] - | lvl_i == lvl_w - = do { binds <- getTcEvBindsMap - ; return (same_level_strategy binds, True) } - - | otherwise -- Both are Given, levels differ - = return (different_level_strategy, True) - where - pred = ctEvPred ev_i - loc_i = ctEvLoc ev_i - loc_w = ctEvLoc ev_w - lvl_i = ctLocLevel loc_i - lvl_w = ctLocLevel loc_w - - different_level_strategy - | isIPPred pred, lvl_w > lvl_i = IRReplace - | lvl_w < lvl_i = IRReplace - | otherwise = IRKeep - - same_level_strategy binds -- Both Given - | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i - = case ctLocOrigin loc_w of - GivenOrigin (InstSC s_w) | s_w < s_i -> IRReplace - | otherwise -> IRKeep - _ -> IRReplace - - | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w - = IRKeep - - | has_binding binds ev_w - , not (has_binding binds ev_i) - = IRReplace - - | otherwise = IRKeep - - has_binding binds ev = isJust (lookupEvBind binds (ctEvId ev)) - -{- -Note [Replacement vs keeping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have two Given constraints both of type (C tys), say, which should -we keep? More subtle than you might think! - - * Constraints come from different levels (different_level_strategy) - - - For implicit parameters we want to keep the innermost (deepest) - one, so that it overrides the outer one. - See Note [Shadowing of Implicit Parameters] - - - For everything else, we want to keep the outermost one. Reason: that - makes it more likely that the inner one will turn out to be unused, - and can be reported as redundant. See Note [Tracking redundant constraints] - in TcSimplify. - - It transpires that using the outermost one is reponsible for an - 8% performance improvement in nofib cryptarithm2, compared to - just rolling the dice. I didn't investigate why. - - * Constraints coming from the same level (i.e. same implication) - - - Always get rid of InstSC ones if possible, since they are less - useful for solving. If both are InstSC, choose the one with - the smallest TypeSize - See Note [Solving superclass constraints] in TcInstDcls - - - Keep the one that has a non-trivial evidence binding. - Example: f :: (Eq a, Ord a) => blah - then we may find [G] d3 :: Eq a - [G] d2 :: Eq a - with bindings d3 = sc_sel (d1::Ord a) - We want to discard d2 in favour of the superclass selection from - the Ord dictionary. - Why? See Note [Tracking redundant constraints] in TcSimplify again. - - * Finally, when there is still a choice, use IRKeep rather than - IRReplace, to avoid unnecessary munging of the inert set. - -Doing the depth-check for implicit parameters, rather than making the work item -always override, is important. Consider - - data T a where { T1 :: (?x::Int) => T Int; T2 :: T a } - - f :: (?x::a) => T a -> Int - f T1 = ?x - f T2 = 3 - -We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add -two new givens in the work-list: [G] (?x::Int) - [G] (a ~ Int) -Now consider these steps - - process a~Int, kicking out (?x::a) - - process (?x::Int), the inner given, adding to inert set - - process (?x::a), the outer given, overriding the inner given -Wrong! The depth-check ensures that the inner implicit parameter wins. -(Actually I think that the order in which the work-list is processed means -that this chain of events won't happen, but that's very fragile.) - -********************************************************************************* -* * - interactIrred -* * -********************************************************************************* --} - --- Two pieces of irreducible evidence: if their types are *exactly identical* --- we can rewrite them. We can never improve using this: --- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not --- mean that (ty1 ~ ty2) -interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) - -interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w }) - | let pred = ctEvPred ev_w - (matching_irreds, others) - = partitionBag (\ct -> ctPred ct `tcEqTypeNoKindCheck` pred) - (inert_irreds inerts) - , (ct_i : rest) <- bagToList matching_irreds - , let ctev_i = ctEvidence ct_i - = ASSERT( null rest ) - do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w - ; case inert_effect of - IRKeep -> return () - IRDelete -> updInertIrreds (\_ -> others) - IRReplace -> updInertIrreds (\_ -> others `snocCts` workItem) - -- These const upd's assume that solveOneFromTheOther - -- has no side effects on InertCans - ; if stop_now then - return (Stop ev_w (text "Irred equal" <+> parens (ppr inert_effect))) - ; else - continueWith workItem } - - | otherwise - = continueWith workItem - -interactIrred _ wi = pprPanic "interactIrred" (ppr wi) - -{- -********************************************************************************* -* * - interactDict -* * -********************************************************************************* - -Note [Shortcut solving] -~~~~~~~~~~~~~~~~~~~~~~~ -When we interact a [W] constraint with a [G] constraint that solves it, there is -a possibility that we could produce better code if instead we solved from a -top-level instance declaration (See #12791, #5835). For example: - - class M a b where m :: a -> b - - type C a b = (Num a, M a b) - - f :: C Int b => b -> Int -> Int - f _ x = x + 1 - -The body of `f` requires a [W] `Num Int` instance. We could solve this -constraint from the givens because we have `C Int b` and that provides us a -solution for `Num Int`. This would let us produce core like the following -(with -O2): - - f :: forall b. C Int b => b -> Int -> Int - f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) -> - + @ Int - (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%)) - eta1 - A.f1 - -This is bad! We could do /much/ better if we solved [W] `Num Int` directly -from the instance that we have in scope: - - f :: forall b. C Int b => b -> Int -> Int - f = \ (@ b) _ _ (x :: Int) -> - case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) } - -** NB: It is important to emphasize that all this is purely an optimization: -** exactly the same programs should typecheck with or without this -** procedure. - -Solving fully -~~~~~~~~~~~~~ -There is a reason why the solver does not simply try to solve such -constraints with top-level instances. If the solver finds a relevant -instance declaration in scope, that instance may require a context -that can't be solved for. A good example of this is: - - f :: Ord [a] => ... - f x = ..Need Eq [a]... - -If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would -be left with the obligation to solve the constraint Eq a, which we cannot. So we -must be conservative in our attempt to use an instance declaration to solve the -[W] constraint we're interested in. - -Our rule is that we try to solve all of the instance's subgoals -recursively all at once. Precisely: We only attempt to solve -constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci -are themselves class constraints of the form `C1', ... Cm' => C' t1' -... tn'` and we only succeed if the entire tree of constraints is -solvable from instances. - -An example that succeeds: - - class Eq a => C a b | b -> a where - m :: b -> a - - f :: C [Int] b => b -> Bool - f x = m x == [] - -We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This -produces the following core: - - f :: forall b. C [Int] b => b -> Bool - f = \ (@ b) ($dC :: C [Int] b) (x :: b) -> - GHC.Classes.$fEq[]_$s$c== - (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int) - -An example that fails: - - class Eq a => C a b | b -> a where - m :: b -> a - - f :: C [a] b => b -> Bool - f x = m x == [] - -Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces: - - f :: forall a b. C [a] b => b -> Bool - f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) -> - == - @ [a] - (A.$p1C @ [a] @ b $dC) - (m @ [a] @ b $dC eta) - (GHC.Types.[] @ a) - -Type families -~~~~~~~~~~~~~ -Suppose we have (Trac #13943) - class Take (n :: Nat) where ... - instance {-# OVERLAPPING #-} Take 0 where .. - instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where .. - -And we have [W] Take 3. That only matches one instance so we get -[W] Take (3-1). Really we should now flatten to reduce the (3-1) to 2, and -so on -- but that is reproducing yet more of the solver. Sigh. For now, -we just give up (remember all this is just an optimisation). - -But we must not just naively try to lookup (Take (3-1)) in the -InstEnv, or it'll (wrongly appear not to match (Take 0) and get a -unique match on the (Take n) instance. That leads immediately to an -infinite loop. Hence the check that 'preds' have no type families -(isTyFamFree). - -Incoherence -~~~~~~~~~~~ -This optimization relies on coherence of dictionaries to be correct. When we -cannot assume coherence because of IncoherentInstances then this optimization -can change the behavior of the user's code. - -The following four modules produce a program whose output would change depending -on whether we apply this optimization when IncoherentInstances is in effect: - -######### - {-# LANGUAGE MultiParamTypeClasses #-} - module A where - - class A a where - int :: a -> Int - - class A a => C a b where - m :: b -> a -> a - -######### - {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} - module B where - - import A - - instance A a where - int _ = 1 - - instance C a [b] where - m _ = id - -######### - {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} - {-# LANGUAGE IncoherentInstances #-} - module C where - - import A - - instance A Int where - int _ = 2 - - instance C Int [Int] where - m _ = id - - intC :: C Int a => a -> Int -> Int - intC _ x = int x - -######### - module Main where - - import A - import B - import C - - main :: IO () - main = print (intC [] (0::Int)) - -The output of `main` if we avoid the optimization under the effect of -IncoherentInstances is `1`. If we were to do the optimization, the output of -`main` would be `2`. --} - -interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) - | isWanted ev_w - , Just ip_name <- isCallStackPred (ctPred workItem) - , OccurrenceOf func <- ctLocOrigin (ctEvLoc ev_w) - -- 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] - = do { let loc = ctEvLoc ev_w - - -- 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] - - ; mb_new <- newWantedEvVar new_loc (ctEvPred ev_w) - ; emitWorkNC (freshGoals [mb_new]) - - -- Then we solve the wanted by pushing the call-site onto the - -- newly emitted CallStack. - ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (getEvTerm mb_new) - ; solveCallStack ev_w ev_cs - ; stopWith ev_w "Wanted CallStack IP" } - | Just ctev_i <- lookupInertDict inerts cls tys - = -- There is a matching dictionary in the inert set - do - { -- First to try to solve it /completely/ from top level instances - -- See Note [Shortcut solving] - dflags <- getDynFlags - ; try_inst_res <- shortCutSolver dflags ev_w ctev_i - ; case try_inst_res of - Just evs -> do - { flip mapM_ evs $ \(ev_t, ct_ev, cls, typ) -> do - { setWantedEvBind (ctEvId ct_ev) ev_t - ; addSolvedDict ct_ev cls typ } - ; stopWith ev_w "interactDict/solved from instance" } - -- We were unable to solve the [W] constraint from in-scope instances so - -- we solve it from the solution in the inerts we just retrieved. - Nothing -> do - { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w - ; case inert_effect of - IRKeep -> return () - IRDelete -> updInertDicts $ \ ds -> delDict ds cls tys - IRReplace -> updInertDicts $ \ ds -> addDict ds cls tys workItem - ; if stop_now then - return $ Stop ev_w (text "Dict equal" <+> parens (ppr inert_effect)) - else - continueWith workItem } } - | cls `hasKey` ipClassKey - , isGiven ev_w - = interactGivenIP inerts workItem - - | otherwise - = do { addFunDepWork inerts ev_w cls - ; continueWith workItem } - -interactDict _ wi = pprPanic "interactDict" (ppr wi) - --- See Note [Shortcut solving] -shortCutSolver :: DynFlags - -> CtEvidence -- Work item - -> CtEvidence -- Inert we want to try to replace - -> TcS (Maybe [(EvTerm, CtEvidence, Class, [TcPredType])]) - -- Everything we need to bind a solution for the work item - -- and add the solved Dict to the cache in the main solver. -shortCutSolver dflags ev_w ctev_i - | isWanted ev_w - && isGiven ctev_i - -- We are about to solve a [W] constraint from a [G] constraint. We take - -- a moment to see if we can get a better solution using an instance. - -- Note that we only do this for the sake of performance. Exactly the same - -- programs should typecheck regardless of whether we take this step or - -- not. See Note [Shortcut solving] - - && not (xopt LangExt.IncoherentInstances dflags) - -- If IncoherentInstances is on then we cannot rely on coherence of proofs - -- in order to justify this optimization: The proof provided by the - -- [G] constraint's superclass may be different from the top-level proof. - - && gopt Opt_SolveConstantDicts dflags - -- Enabled by the -fsolve-constant-dicts flag - = runMaybeT $ try_solve_from_instance loc_w emptyDictMap ev_w - - | otherwise = return Nothing - where - -- This `CtLoc` is used only to check the well-staged condition of any - -- candidate DFun. Our subgoals all have the same stage as our root - -- [W] constraint so it is safe to use this while solving them. - loc_w = ctEvLoc ev_w - - -- 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 :: DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew - new_wanted_cached cache pty - | ClassPred cls tys <- classifyPredType pty - = lift $ case findDict cache cls tys of - Just ctev -> return $ Cached (ctEvTerm ctev) - Nothing -> Fresh <$> newWantedNC loc_w pty - | otherwise = mzero - - -- MaybeT manages early failure if we find a subgoal that cannot be solved - -- from instances. - -- Why do we need a local cache here? - -- 1. We can't use the global cache because it contains givens that - -- we specifically don't want to use to solve. - -- 2. We need to be able to handle recursive super classes. The - -- cache ensures that we remember what we have already tried to - -- solve to avoid looping. - try_solve_from_instance - :: CtLoc -> DictMap CtEvidence -> CtEvidence - -> MaybeT TcS [(EvTerm, CtEvidence, Class, [TcPredType])] - try_solve_from_instance loc cache ev - | let pred = ctEvPred ev - , ClassPred cls tys <- classifyPredType pred - -- It is important that we add our goal to the cache before we solve! - -- Otherwise we may end up in a loop while solving recursive dictionaries. - = do { let cache' = addDict cache cls tys ev - loc' = bumpCtLocDepth loc - ; inst_res <- lift $ match_class_inst dflags cls tys loc_w - ; case inst_res of - GenInst { lir_new_theta = preds - , lir_mk_ev = mk_ev - , lir_safe_over = safeOverlap } - | safeOverlap - , all isTyFamFree preds -- See "Type families" in - -- Note [Shortcut solving] - -> do { lift $ traceTcS "shortCutSolver: found instance" (ppr preds) - ; lift $ checkReductionDepth loc' pred - ; evc_vs <- mapM (new_wanted_cached cache') preds - -- Emit work for subgoals but use our local cache - -- so we can solve recursive dictionaries. - ; subgoalBinds <- mapM (try_solve_from_instance loc' cache') - (freshGoals evc_vs) - ; return $ (mk_ev (map getEvTerm evc_vs), ev, cls, preds) - : concat subgoalBinds } - - | otherwise -> mzero - _ -> mzero } - | otherwise = mzero - -addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS () --- Add derived constraints from type-class functional dependencies. -addFunDepWork inerts work_ev cls - | isImprovable work_ev - = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls) - -- No need to check flavour; fundeps work between - -- any pair of constraints, regardless of flavour - -- Importantly we don't throw workitem back in the - -- worklist because this can cause loops (see #5236) - | otherwise - = return () - where - work_pred = ctEvPred work_ev - work_loc = ctEvLoc work_ev - - add_fds inert_ct - | isImprovable inert_ev - = emitFunDepDeriveds $ - improveFromAnother derived_loc inert_pred work_pred - -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok - -- NB: We do create FDs for given to report insoluble equations that arise - -- from pairs of Givens, and also because of floating when we approximate - -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs - | otherwise - = return () - where - inert_ev = ctEvidence inert_ct - inert_pred = ctEvPred inert_ev - inert_loc = ctEvLoc inert_ev - derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` - ctl_depth inert_loc - , ctl_origin = FunDepOrigin1 work_pred work_loc - inert_pred inert_loc } - -{- -********************************************************************** -* * - Implicit parameters -* * -********************************************************************** --} - -interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- Work item is Given (?x:ty) --- See Note [Shadowing of Implicit Parameters] -interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = tys@(ip_str:_) }) - = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem } - ; stopWith ev "Given IP" } - where - dicts = inert_dicts inerts - ip_dicts = findDictsByClass dicts cls - other_ip_dicts = filterBag (not . is_this_ip) ip_dicts - filtered_dicts = addDictsByClass dicts cls other_ip_dicts - - -- Pick out any Given constraints for the same implicit parameter - is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ }) - = isGiven ev && ip_str `tcEqType` ip_str' - is_this_ip _ = False - -interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi) - - -{- Note [Shadowing of Implicit Parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example: - -f :: (?x :: Char) => Char -f = let ?x = 'a' in ?x - -The "let ?x = ..." generates an implication constraint of the form: - -?x :: Char => ?x :: Char - -Furthermore, the signature for `f` also generates an implication -constraint, so we end up with the following nested implication: - -?x :: Char => (?x :: Char => ?x :: Char) - -Note that the wanted (?x :: Char) constraint may be solved in -two incompatible ways: either by using the parameter from the -signature, or by using the local definition. Our intention is -that the local definition should "shadow" the parameter of the -signature, and we implement this as follows: when we add a new -*given* implicit parameter to the inert set, it replaces any existing -givens for the same implicit parameter. - -Similarly, consider - f :: (?x::a) => Bool -> a - - g v = let ?x::Int = 3 - in (f v, let ?x::Bool = True in f v) - -This should probably be well typed, with - g :: Bool -> (Int, Bool) - -So the inner binding for ?x::Bool *overrides* the outer one. - -All this works for the normal cases but it has an odd side effect in -some pathological programs like this: --- This is accepted, the second parameter shadows -f1 :: (?x :: Int, ?x :: Char) => Char -f1 = ?x - --- This is rejected, the second parameter shadows -f2 :: (?x :: Int, ?x :: Char) => Int -f2 = ?x - -Both of these are actually wrong: when we try to use either one, -we'll get two incompatible wnated constraints (?x :: Int, ?x :: Char), -which would lead to an error. - -I can think of two ways to fix this: - - 1. Simply disallow multiple constraints for the same implicit - parameter---this is never useful, and it can be detected completely - syntactically. - - 2. Move the shadowing machinery to the location where we nest - implications, and add some code here that will produce an - error if we get multiple givens for the same implicit parameter. - - -********************************************************************** -* * - interactFunEq -* * -********************************************************************** --} - -interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- Try interacting the work item with the inert set -interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc - , cc_tyargs = args, cc_fsk = fsk }) - | Just inert_ct@(CFunEqCan { cc_ev = ev_i - , cc_fsk = fsk_i }) - <- findFunEq (inert_funeqs inerts) tc args - , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev - = do { traceTcS "reactFunEq (rewrite inert item):" $ - vcat [ text "work_item =" <+> ppr work_item - , text "inertItem=" <+> ppr ev_i - , text "(swap_flag, upgrade)" <+> ppr pr ] - ; if isSwapped swap_flag - then do { -- Rewrite inert using work-item - let work_item' | upgrade_flag = upgradeWanted work_item - | otherwise = work_item - ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item' - -- Do the updInertFunEqs before the reactFunEq, so that - -- we don't kick out the inertItem as well as consuming it! - ; reactFunEq ev fsk ev_i fsk_i - ; stopWith ev "Work item rewrites inert" } - else do { -- Rewrite work-item using inert - ; when upgrade_flag $ - updInertFunEqs $ \ feqs -> insertFunEq feqs tc args - (upgradeWanted inert_ct) - ; reactFunEq ev_i fsk_i ev fsk - ; stopWith ev "Inert rewrites work item" } } - - | otherwise -- Try improvement - = do { improveLocalFunEqs ev inerts tc args fsk - ; continueWith work_item } - -interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item) - -upgradeWanted :: Ct -> Ct --- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2 --- so upgrade the [W] to [WD] before putting it in the inert set -upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) } - where - upgrade_ev ev = ASSERT2( isWanted ev, ppr ct ) - ev { ctev_nosh = WDeriv } - -improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar - -> TcS () --- Generate derived improvement equalities, by comparing --- the current work item with inert CFunEqs --- E.g. x + y ~ z, x + y' ~ z => [D] y ~ y' --- --- See Note [FunDep and implicit parameter reactions] -improveLocalFunEqs work_ev inerts fam_tc args fsk - | isGiven work_ev -- See Note [No FunEq improvement for Givens] - || not (isImprovable work_ev) - = return () - - | not (null improvement_eqns) - = do { traceTcS "interactFunEq improvements: " $ - vcat [ text "Eqns:" <+> ppr improvement_eqns - , text "Candidates:" <+> ppr funeqs_for_tc - , text "Inert eqs:" <+> ppr ieqs ] - ; emitFunDepDeriveds improvement_eqns } - - | otherwise - = return () - - where - ieqs = inert_eqs inerts - funeqs = inert_funeqs inerts - funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc - rhs = lookupFlattenTyVar ieqs fsk - work_loc = ctEvLoc work_ev - work_pred = ctEvPred work_ev - fam_inj_info = familyTyConInjectivityInfo fam_tc - - -------------------- - improvement_eqns :: [FunDepEqn CtLoc] - improvement_eqns - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = -- Try built-in families, notably for arithmethic - concatMap (do_one_built_in ops) funeqs_for_tc - - | Injective injective_args <- fam_inj_info - = -- Try improvement from type families with injectivity annotations - concatMap (do_one_injective injective_args) funeqs_for_tc - - | otherwise - = [] - - -------------------- - do_one_built_in ops (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev }) - = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs - (lookupFlattenTyVar ieqs ifsk)) - - do_one_built_in _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) - - -------------------- - -- See Note [Type inference for type families with injectivity] - do_one_injective inj_args (CFunEqCan { cc_tyargs = inert_args - , cc_fsk = ifsk, cc_ev = inert_ev }) - | isImprovable inert_ev - , rhs `tcEqType` lookupFlattenTyVar ieqs ifsk - = mk_fd_eqns inert_ev $ - [ Pair arg iarg - | (arg, iarg, True) <- zip3 args inert_args inj_args ] - | otherwise - = [] - - do_one_injective _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) - - -------------------- - mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc] - mk_fd_eqns inert_ev eqns - | null eqns = [] - | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns - , fd_pred1 = work_pred - , fd_pred2 = ctEvPred inert_ev - , fd_loc = loc } ] - where - inert_loc = ctEvLoc inert_ev - loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` - ctl_depth work_loc } - -------------- -reactFunEq :: CtEvidence -> TcTyVar -- From this :: F args1 ~ fsk1 - -> CtEvidence -> TcTyVar -- Solve this :: F args2 ~ fsk2 - -> TcS () -reactFunEq from_this fsk1 solve_this fsk2 - | CtGiven { ctev_evar = evar, ctev_loc = loc } <- solve_this - = do { let fsk_eq_co = mkTcSymCo (mkTcCoVarCo evar) `mkTcTransCo` - ctEvCoercion from_this - -- :: fsk2 ~ fsk1 - fsk_eq_pred = mkTcEqPredLikeEv solve_this - (mkTyVarTy fsk2) (mkTyVarTy fsk1) - - ; new_ev <- newGivenEvVar loc (fsk_eq_pred, EvCoercion fsk_eq_co) - ; emitWorkNC [new_ev] } - - | CtDerived { ctev_loc = loc } <- solve_this - = do { traceTcS "reactFunEq (Derived)" (ppr from_this $$ ppr fsk1 $$ - ppr solve_this $$ ppr fsk2) - ; emitNewDerivedEq loc Nominal (mkTyVarTy fsk1) (mkTyVarTy fsk2) } - -- FunEqs are always at Nominal role - - | otherwise -- Wanted - = do { traceTcS "reactFunEq" (ppr from_this $$ ppr fsk1 $$ - ppr solve_this $$ ppr fsk2) - ; dischargeFmv solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1) - ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$ - ppr solve_this $$ ppr fsk2) } - -{- Note [Type inference for type families with injectivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a type family with an injectivity annotation: - type family F a b = r | r -> b - -Then if we have two CFunEqCan constraints for F with the same RHS - F s1 t1 ~ rhs - F s2 t2 ~ rhs -then we can use the injectivity to get a new Derived constraint on -the injective argument - [D] t1 ~ t2 - -That in turn can help GHC solve constraints that would otherwise require -guessing. For example, consider the ambiguity check for - f :: F Int b -> Int -We get the constraint - [W] F Int b ~ F Int beta -where beta is a unification variable. Injectivity lets us pick beta ~ b. - -Injectivity information is also used at the call sites. For example: - g = f True -gives rise to - [W] F Int b ~ Bool -from which we can derive b. This requires looking at the defining equations of -a type family, ie. finding equation with a matching RHS (Bool in this example) -and infering values of type variables (b in this example) from the LHS patterns -of the matching equation. For closed type families we have to perform -additional apartness check for the selected equation to check that the selected -is guaranteed to fire for given LHS arguments. - -These new constraints are simply *Derived* constraints; they have no evidence. -We could go further and offer evidence from decomposing injective type-function -applications, but that would require new evidence forms, and an extension to -FC, so we don't do that right now (Dec 14). - -See also Note [Injective type families] in TyCon - - -Note [Cache-caused loops] -~~~~~~~~~~~~~~~~~~~~~~~~~ -It is very dangerous to cache a rewritten wanted family equation as 'solved' in our -solved cache (which is the default behaviour or xCtEvidence), because the interaction -may not be contributing towards a solution. Here is an example: - -Initial inert set: - [W] g1 : F a ~ beta1 -Work item: - [W] g2 : F a ~ beta2 -The work item will react with the inert yielding the _same_ inert set plus: - i) Will set g2 := g1 `cast` g3 - ii) Will add to our solved cache that [S] g2 : F a ~ beta2 - iii) Will emit [W] g3 : beta1 ~ beta2 -Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 -and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it -will set - g1 := g ; sym g3 -and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but -remember that we have this in our solved cache, and it is ... g2! In short we -created the evidence loop: - - g2 := g1 ; g3 - g3 := refl - g1 := g2 ; sym g3 - -To avoid this situation we do not cache as solved any workitems (or inert) -which did not really made a 'step' towards proving some goal. Solved's are -just an optimization so we don't lose anything in terms of completeness of -solving. - - -Note [Efficient Orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are interacting two FunEqCans with the same LHS: - (inert) ci :: (F ty ~ xi_i) - (work) cw :: (F ty ~ xi_w) -We prefer to keep the inert (else we pass the work item on down -the pipeline, which is a bit silly). If we keep the inert, we -will (a) discharge 'cw' - (b) produce a new equality work-item (xi_w ~ xi_i) -Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w): - new_work :: xi_w ~ xi_i - cw := ci ; sym new_work -Why? Consider the simplest case when xi1 is a type variable. If -we generate xi1~xi2, porcessing that constraint will kick out 'ci'. -If we generate xi2~xi1, there is less chance of that happening. -Of course it can and should still happen if xi1=a, xi1=Int, say. -But we want to avoid it happening needlessly. - -Similarly, if we *can't* keep the inert item (because inert is Wanted, -and work is Given, say), we prefer to orient the new equality (xi_i ~ -xi_w). - -Note [Carefully solve the right CFunEqCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ---- OLD COMMENT, NOW NOT NEEDED - ---- because we now allow multiple - ---- wanted FunEqs with the same head -Consider the constraints - c1 :: F Int ~ a -- Arising from an application line 5 - c2 :: F Int ~ Bool -- Arising from an application line 10 -Suppose that 'a' is a unification variable, arising only from -flattening. So there is no error on line 5; it's just a flattening -variable. But there is (or might be) an error on line 10. - -Two ways to combine them, leaving either (Plan A) - c1 :: F Int ~ a -- Arising from an application line 5 - c3 :: a ~ Bool -- Arising from an application line 10 -or (Plan B) - c2 :: F Int ~ Bool -- Arising from an application line 10 - c4 :: a ~ Bool -- Arising from an application line 5 - -Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error -on the *totally innocent* line 5. An example is test SimpleFail16 -where the expected/actual message comes out backwards if we use -the wrong plan. - -The second is the right thing to do. Hence the isMetaTyVarTy -test when solving pairwise CFunEqCan. - - -********************************************************************** -* * - interactTyVarEq -* * -********************************************************************** --} - -inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtEvidence - -> Maybe ( CtEvidence -- The evidence for the inert - , SwapFlag -- Whether we need mkSymCo - , Bool) -- True <=> keep a [D] version - -- of the [WD] constraint -inertsCanDischarge inerts tv rhs ev - | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i } - <- findTyEqs inerts tv - , ev_i `eqCanDischarge` ev - , rhs_i `tcEqType` rhs ] - = -- Inert: a ~ ty - -- Work item: a ~ ty - Just (ev_i, NotSwapped, keep_deriv ev_i) - - | Just tv_rhs <- getTyVar_maybe rhs - , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i } - <- findTyEqs inerts tv_rhs - , ev_i `eqCanDischarge` ev - , rhs_i `tcEqType` mkTyVarTy tv ] - = -- Inert: a ~ b - -- Work item: b ~ a - Just (ev_i, IsSwapped, keep_deriv ev_i) - - | otherwise - = Nothing - - where - keep_deriv ev_i - | Wanted WOnly <- ctEvFlavour ev_i -- inert is [W] - , Wanted WDeriv <- ctEvFlavour ev -- work item is [WD] - = True -- Keep a derived verison of the work item - | otherwise - = False -- Work item is fully discharged - -interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- CTyEqCans are always consumed, so always returns Stop -interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv - , cc_rhs = rhs - , cc_ev = ev - , cc_eq_rel = eq_rel }) - | Just (ev_i, swapped, keep_deriv) - <- inertsCanDischarge inerts tv rhs ev - = do { setEvBindIfWanted ev $ - EvCoercion (maybeSym swapped $ - tcDowngradeRole (eqRelRole eq_rel) - (ctEvRole ev_i) - (ctEvCoercion ev_i)) - - ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev - , ctev_loc = ctEvLoc ev } - ; when keep_deriv $ - emitWork [workItem { cc_ev = deriv_ev }] - -- As a Derived it might not be fully rewritten, - -- so we emit it as new work - - ; stopWith ev "Solved from inert" } - - | ReprEq <- eq_rel -- We never solve representational - = unsolved_inert -- equalities by unification - - | isGiven ev -- See Note [Touchables and givens] - = unsolved_inert - - | otherwise - = do { tclvl <- getTcLevel - ; if canSolveByUnification tclvl tv rhs - then do { solveByUnification ev tv rhs - ; n_kicked <- kickOutAfterUnification tv - ; return (Stop ev (text "Solved by unification" <+> ppr_kicked n_kicked)) } - - else unsolved_inert } - - where - unsolved_inert - = do { traceTcS "Can't solve tyvar equality" - (vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv) - , ppWhen (isMetaTyVar tv) $ - nest 4 (text "TcLevel of" <+> ppr tv - <+> text "is" <+> ppr (metaTyVarTcLevel tv)) - , text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs) ]) - ; addInertEq workItem - ; stopWith ev "Kept as inert" } - -interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi) - -solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () --- Solve with the identity coercion --- Precondition: kind(xi) equals kind(tv) --- Precondition: CtEvidence is Wanted or Derived --- Precondition: CtEvidence is nominal --- Returns: workItem where --- workItem = the new Given constraint --- --- NB: No need for an occurs check here, because solveByUnification always --- arises from a CTyEqCan, a *canonical* constraint. Its invariants --- say that in (a ~ xi), the type variable a does not appear in xi. --- See TcRnTypes.Ct invariants. --- --- Post: tv is unified (by side effect) with xi; --- we often write tv := xi -solveByUnification wd tv xi - = do { let tv_ty = mkTyVarTy tv - ; traceTcS "Sneaky unification:" $ - vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi, - text "Coercion:" <+> pprEq tv_ty xi, - text "Left Kind is:" <+> ppr (typeKind tv_ty), - text "Right Kind is:" <+> ppr (typeKind xi) ] - - ; unifyTyVar tv xi - ; setEvBindIfWanted wd (EvCoercion (mkTcNomReflCo xi)) } - -ppr_kicked :: Int -> SDoc -ppr_kicked 0 = empty -ppr_kicked n = parens (int n <+> text "kicked out") - -{- Note [Avoid double unifications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The spontaneous solver has to return a given which mentions the unified unification -variable *on the left* of the equality. Here is what happens if not: - Original wanted: (a ~ alpha), (alpha ~ Int) -We spontaneously solve the first wanted, without changing the order! - given : a ~ alpha [having unified alpha := a] -Now the second wanted comes along, but he cannot rewrite the given, so we simply continue. -At the end we spontaneously solve that guy, *reunifying* [alpha := Int] - -We avoid this problem by orienting the resulting given so that the unification -variable is on the left. [Note that alternatively we could attempt to -enforce this at canonicalization] - -See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding -double unifications is the main reason we disallow touchable -unification variables as RHS of type family equations: F xis ~ alpha. - - -************************************************************************ -* * -* Functional dependencies, instantiation of equations -* * -************************************************************************ - -When we spot an equality arising from a functional dependency, -we now use that equality (a "wanted") to rewrite the work-item -constraint right away. This avoids two dangers - - Danger 1: If we send the original constraint on down the pipeline - it may react with an instance declaration, and in delicate - situations (when a Given overlaps with an instance) that - may produce new insoluble goals: see Trac #4952 - - Danger 2: If we don't rewrite the constraint, it may re-react - with the same thing later, and produce the same equality - again --> termination worries. - -To achieve this required some refactoring of FunDeps.hs (nicer -now!). - -Note [FunDep and implicit parameter reactions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, our story of interacting two dictionaries (or a dictionary -and top-level instances) for functional dependencies, and implicit -parameters, is that we simply produce new Derived equalities. So for example - - class D a b | a -> b where ... - Inert: - d1 :g D Int Bool - WorkItem: - d2 :w D Int alpha - - We generate the extra work item - cv :d alpha ~ Bool - where 'cv' is currently unused. However, this new item can perhaps be - spontaneously solved to become given and react with d2, - discharging it in favour of a new constraint d2' thus: - d2' :w D Int Bool - d2 := d2' |> D Int cv - Now d2' can be discharged from d1 - -We could be more aggressive and try to *immediately* solve the dictionary -using those extra equalities, but that requires those equalities to carry -evidence and derived do not carry evidence. - -If that were the case with the same inert set and work item we might dischard -d2 directly: - - cv :w alpha ~ Bool - d2 := d1 |> D Int cv - -But in general it's a bit painful to figure out the necessary coercion, -so we just take the first approach. Here is a better example. Consider: - class C a b c | a -> b -And: - [Given] d1 : C T Int Char - [Wanted] d2 : C T beta Int -In this case, it's *not even possible* to solve the wanted immediately. -So we should simply output the functional dependency and add this guy -[but NOT its superclasses] back in the worklist. Even worse: - [Given] d1 : C T Int beta - [Wanted] d2: C T beta Int -Then it is solvable, but its very hard to detect this on the spot. - -It's exactly the same with implicit parameters, except that the -"aggressive" approach would be much easier to implement. - -Note [Weird fundeps] -~~~~~~~~~~~~~~~~~~~~ -Consider class Het a b | a -> b where - het :: m (f c) -> a -> m b - - class GHet (a :: * -> *) (b :: * -> *) | a -> b - instance GHet (K a) (K [a]) - instance Het a b => GHet (K a) (K b) - -The two instances don't actually conflict on their fundeps, -although it's pretty strange. So they are both accepted. Now -try [W] GHet (K Int) (K Bool) -This triggers fundeps from both instance decls; - [D] K Bool ~ K [a] - [D] K Bool ~ K beta -And there's a risk of complaining about Bool ~ [a]. But in fact -the Wanted matches the second instance, so we never get as far -as the fundeps. - -Trac #7875 is a case in point. --} - -emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS () --- See Note [FunDep and implicit parameter reactions] -emitFunDepDeriveds fd_eqns - = mapM_ do_one_FDEqn fd_eqns - where - do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc }) - | null tvs -- Common shortcut - = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs) - ; mapM_ (unifyDerived loc Nominal) eqs } - | otherwise - = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr eqs) - ; subst <- instFlexi tvs -- Takes account of kind substitution - ; mapM_ (do_one_eq loc subst) eqs } - - do_one_eq loc subst (Pair ty1 ty2) - = unifyDerived loc Nominal $ - Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2) - -{- -********************************************************************** -* * - The top-reaction Stage -* * -********************************************************************** --} - -topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) -topReactionsStage wi - = do { tir <- doTopReact wi - ; case tir of - ContinueWith wi -> continueWith wi - Stop ev s -> return (Stop ev (text "Top react:" <+> s)) } - -doTopReact :: WorkItem -> TcS (StopOrContinue Ct) --- The work item does not react with the inert set, so try interaction with top-level --- instances. Note: --- --- (a) The place to add superclasses in not here in doTopReact stage. --- Instead superclasses are added in the worklist as part of the --- canonicalization process. See Note [Adding superclasses]. - -doTopReact work_item - = do { traceTcS "doTopReact" (ppr work_item) - ; case work_item of - CDictCan {} -> do { inerts <- getTcSInerts - ; doTopReactDict inerts work_item } - CFunEqCan {} -> doTopReactFunEq work_item - _ -> -- Any other work item does not react with any top-level equations - continueWith work_item } - - --------------------- -doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct) -doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc - , cc_tyargs = args, cc_fsk = fsk }) - - | fsk `elemVarSet` tyCoVarsOfTypes args - = no_reduction -- See Note [FunEq occurs-check principle] - - | otherwise -- Note [Reduction for Derived CFunEqCans] - = do { match_res <- matchFam fam_tc args - -- Look up in top-level instances, or built-in axiom - -- See Note [MATCHING-SYNONYMS] - ; case match_res of - Nothing -> no_reduction - Just match_info -> reduce_top_fun_eq old_ev fsk match_info } - where - no_reduction - = do { improveTopFunEqs old_ev fam_tc args fsk - ; continueWith work_item } - -doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w) - -reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType) - -> TcS (StopOrContinue Ct) --- We have found an applicable top-level axiom: use it to reduce --- Precondition: fsk is not free in rhs_ty --- old_ev is not Derived -reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty) - | isDerived old_ev - = do { emitNewDerivedEq loc Nominal (mkTyVarTy fsk) rhs_ty - ; stopWith old_ev "Fun/Top (derived)" } - - | Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty - , isTypeFamilyTyCon tc - , tc_args `lengthIs` tyConArity tc -- Short-cut - = -- RHS is another type-family application - -- Try shortcut; see Note [Top-level reductions for type functions] - shortCutReduction old_ev fsk ax_co tc tc_args - - | isGiven old_ev -- Not shortcut - = do { let final_co = mkTcSymCo (ctEvCoercion old_ev) `mkTcTransCo` ax_co - -- final_co :: fsk ~ rhs_ty - ; new_ev <- newGivenEvVar deeper_loc (mkPrimEqPred (mkTyVarTy fsk) rhs_ty, - EvCoercion final_co) - ; emitWorkNC [new_ev] -- Non-cannonical; that will mean we flatten rhs_ty - ; stopWith old_ev "Fun/Top (given)" } - - | otherwise -- So old_ev is Wanted (cannot be Derived) - = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty) - , ppr old_ev $$ ppr rhs_ty ) - -- Guaranteed by Note [FunEq occurs-check principle] - do { dischargeFmv old_ev fsk ax_co rhs_ty - ; traceTcS "doTopReactFunEq" $ - vcat [ text "old_ev:" <+> ppr old_ev - , nest 2 (text ":=") <+> ppr ax_co ] - ; stopWith old_ev "Fun/Top (wanted)" } - - where - loc = ctEvLoc old_ev - deeper_loc = bumpCtLocDepth loc - -improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS () --- See Note [FunDep and implicit parameter reactions] -improveTopFunEqs ev fam_tc args fsk - | isGiven ev -- See Note [No FunEq improvement for Givens] - || not (isImprovable ev) - = return () - - | otherwise - = do { ieqs <- getInertEqs - ; fam_envs <- getFamInstEnvs - ; eqns <- improve_top_fun_eqs fam_envs fam_tc args - (lookupFlattenTyVar ieqs fsk) - ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr fsk - , ppr eqns ]) - ; mapM_ (unifyDerived loc Nominal) eqns } - where - loc = ctEvLoc ev - -improve_top_fun_eqs :: FamInstEnvs - -> TyCon -> [TcType] -> TcType - -> TcS [TypeEqn] -improve_top_fun_eqs fam_envs fam_tc args rhs_ty - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = return (sfInteractTop ops args rhs_ty) - - -- see Note [Type inference for type families with injectivity] - | isOpenTypeFamilyTyCon fam_tc - , Injective injective_args <- familyTyConInjectivityInfo fam_tc - = -- it is possible to have several compatible equations in an open type - -- family but we only want to derive equalities from one such equation. - concatMapM (injImproveEqns injective_args) (take 1 $ - buildImprovementData (lookupFamInstEnvByTyCon fam_envs fam_tc) - fi_tvs fi_tys fi_rhs (const Nothing)) - - | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc - , Injective injective_args <- familyTyConInjectivityInfo fam_tc - = concatMapM (injImproveEqns injective_args) $ - buildImprovementData (fromBranches (co_ax_branches ax)) - cab_tvs cab_lhs cab_rhs Just - - | otherwise - = return [] - - where - buildImprovementData - :: [a] -- axioms for a TF (FamInst or CoAxBranch) - -> (a -> [TyVar]) -- get bound tyvars of an axiom - -> (a -> [Type]) -- get LHS of an axiom - -> (a -> Type) -- get RHS of an axiom - -> (a -> Maybe CoAxBranch) -- Just => apartness check required - -> [( [Type], TCvSubst, [TyVar], Maybe CoAxBranch )] - -- Result: - -- ( [arguments of a matching axiom] - -- , RHS-unifying substitution - -- , axiom variables without substitution - -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] ) - buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap = - [ (ax_args, subst, unsubstTvs, wrap axiom) - | axiom <- axioms - , let ax_args = axiomLHS axiom - ax_rhs = axiomRHS axiom - ax_tvs = axiomTVs axiom - , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty] - , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst) - unsubstTvs = filter (notInSubst <&&> isTyVar) ax_tvs ] - -- The order of unsubstTvs is important; it must be - -- in telescope order e.g. (k:*) (a:k) - - injImproveEqns :: [Bool] - -> ([Type], TCvSubst, [TyCoVar], Maybe CoAxBranch) - -> TcS [TypeEqn] - injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr) - = do { subst <- instFlexiX subst unsubstTvs - -- If the current substitution bind [k -> *], and - -- one of the un-substituted tyvars is (a::k), we'd better - -- be sure to apply the current substitution to a's kind. - -- Hence instFlexiX. Trac #13135 was an example. - - ; return [ Pair (substTyUnchecked subst ax_arg) arg - -- NB: the ax_arg part is on the left - -- see Note [Improvement orientation] - | case cabr of - Just cabr' -> apartnessCheck (substTys subst ax_args) cabr' - _ -> True - , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] } - - -shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion - -> TyCon -> [TcType] -> TcS (StopOrContinue Ct) --- See Note [Top-level reductions for type functions] -shortCutReduction old_ev fsk ax_co fam_tc tc_args - = ASSERT( ctEvEqRel old_ev == NomEq) - do { (xis, cos) <- flattenManyNom old_ev tc_args - -- ax_co :: F args ~ G tc_args - -- cos :: xis ~ tc_args - -- old_ev :: F args ~ fsk - -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk - - ; new_ev <- case ctEvFlavour old_ev of - Given -> newGivenEvVar deeper_loc - ( mkPrimEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk) - , EvCoercion (mkTcTyConAppCo Nominal fam_tc cos - `mkTcTransCo` mkTcSymCo ax_co - `mkTcTransCo` ctEvCoercion old_ev) ) - - Wanted {} -> - do { (new_ev, new_co) <- newWantedEq deeper_loc Nominal - (mkTyConApp fam_tc xis) (mkTyVarTy fsk) - ; setWantedEq (ctev_dest old_ev) $ - ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal - fam_tc cos) - `mkTcTransCo` new_co - ; return new_ev } - - Derived -> pprPanic "shortCutReduction" (ppr old_ev) - - ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc - , cc_tyargs = xis, cc_fsk = fsk } - ; updWorkListTcS (extendWorkListFunEq new_ct) - ; stopWith old_ev "Fun/Top (shortcut)" } - where - deeper_loc = bumpCtLocDepth (ctEvLoc old_ev) - -dischargeFmv :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS () --- (dischargeFmv x fmv co ty) --- [W] ev :: F tys ~ fmv --- co :: F tys ~ xi --- Precondition: fmv is not filled, and fmv `notElem` xi --- ev is Wanted --- --- Then set fmv := xi, --- set ev := co --- kick out any inert things that are now rewritable --- --- Does not evaluate 'co' if 'ev' is Derived -dischargeFmv ev@(CtWanted { ctev_dest = dest }) fmv co xi - = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi ) - do { setWantedEvTerm dest (EvCoercion co) - ; unflattenFmv fmv xi - ; n_kicked <- kickOutAfterUnification fmv - ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ ppr_kicked n_kicked) } -dischargeFmv ev _ _ _ = pprPanic "dischargeFmv" (ppr ev) - -{- Note [Top-level reductions for type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c.f. Note [The flattening story] in TcFlatten - -Suppose we have a CFunEqCan F tys ~ fmv/fsk, and a matching axiom. -Here is what we do, in four cases: - -* Wanteds: general firing rule - (work item) [W] x : F tys ~ fmv - instantiate axiom: ax_co : F tys ~ rhs - - Then: - Discharge fmv := rhs - Discharge x := ax_co ; sym x2 - This is *the* way that fmv's get unified; even though they are - "untouchable". - - NB: Given Note [FunEq occurs-check principle], fmv does not appear - in tys, and hence does not appear in the instantiated RHS. So - the unification can't make an infinite type. - -* Wanteds: short cut firing rule - Applies when the RHS of the axiom is another type-function application - (work item) [W] x : F tys ~ fmv - instantiate axiom: ax_co : F tys ~ G rhs_tys - - It would be a waste to create yet another fmv for (G rhs_tys). - Instead (shortCutReduction): - - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis) - - Add G rhs_xis ~ fmv to flat cache (note: the same old fmv) - - New canonical wanted [W] x2 : G rhs_xis ~ fmv (CFunEqCan) - - Discharge x := ax_co ; G cos ; x2 - -* Givens: general firing rule - (work item) [G] g : F tys ~ fsk - instantiate axiom: ax_co : F tys ~ rhs - - Now add non-canonical given (since rhs is not flat) - [G] (sym g ; ax_co) : fsk ~ rhs (Non-canonical) - -* Givens: short cut firing rule - Applies when the RHS of the axiom is another type-function application - (work item) [G] g : F tys ~ fsk - instantiate axiom: ax_co : F tys ~ G rhs_tys - - It would be a waste to create yet another fsk for (G rhs_tys). - Instead (shortCutReduction): - - Flatten rhs_tys: flat_cos : tys ~ flat_tys - - Add new Canonical given - [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk (CFunEqCan) - -Note [FunEq occurs-check principle] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I have spent a lot of time finding a good way to deal with -CFunEqCan constraints like - F (fuv, a) ~ fuv -where flatten-skolem occurs on the LHS. Now in principle we -might may progress by doing a reduction, but in practice its -hard to find examples where it is useful, and easy to find examples -where we fall into an infinite reduction loop. A rule that works -very well is this: - - *** FunEq occurs-check principle *** - - Do not reduce a CFunEqCan - F tys ~ fsk - if fsk appears free in tys - Instead we treat it as stuck. - -Examples: - -* Trac #5837 has [G] a ~ TF (a,Int), with an instance - type instance TF (a,b) = (TF a, TF b) - This readily loops when solving givens. But with the FunEq occurs - check principle, it rapidly gets stuck which is fine. - -* Trac #12444 is a good example, explained in comment:2. We have - type instance F (Succ x) = Succ (F x) - [W] alpha ~ Succ (F alpha) - If we allow the reduction to happen, we get an infinite loop - -Note [Cached solved FunEqs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When trying to solve, say (FunExpensive big-type ~ ty), it's important -to see if we have reduced (FunExpensive big-type) before, lest we -simply repeat it. Hence the lookup in inert_solved_funeqs. Moreover -we must use `funEqCanDischarge` because both uses might (say) be Wanteds, -and we *still* want to save the re-computation. - -Note [MATCHING-SYNONYMS] -~~~~~~~~~~~~~~~~~~~~~~~~ -When trying to match a dictionary (D tau) to a top-level instance, or a -type family equation (F taus_1 ~ tau_2) to a top-level family instance, -we do *not* need to expand type synonyms because the matcher will do that for us. - -Note [Improvement orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A very delicate point is the orientation of derived equalities -arising from injectivity improvement (Trac #12522). Suppse we have - type family F x = t | t -> x - type instance F (a, Int) = (Int, G a) -where G is injective; and wanted constraints - - [W] TF (alpha, beta) ~ fuv - [W] fuv ~ (Int, ) - -The injectivity will give rise to derived constraints - - [D] gamma1 ~ alpha - [D] Int ~ beta - -The fresh unification variable gamma1 comes from the fact that we -can only do "partial improvement" here; see Section 5.2 of -"Injective type families for Haskell" (HS'15). - -Now, it's very important to orient the equations this way round, -so that the fresh unification variable will be eliminated in -favour of alpha. If we instead had - [D] alpha ~ gamma1 -then we would unify alpha := gamma1; and kick out the wanted -constraint. But when we grough it back in, it'd look like - [W] TF (gamma1, beta) ~ fuv -and exactly the same thing would happen again! Infnite loop. - -This all sesms fragile, and it might seem more robust to avoid -introducing gamma1 in the first place, in the case where the -actual argument (alpha, beta) partly matches the improvement -template. But that's a bit tricky, esp when we remember that the -kinds much match too; so it's easier to let the normal machinery -handle it. Instead we are careful to orient the new derived -equality with the template on the left. Delicate, but it works. - -Note [No FunEq improvement for Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't do improvements (injectivity etc) for Givens. Why? - -* It generates Derived constraints on skolems, which don't do us - much good, except perhaps identify inaccessible branches. - (They'd be perfectly valid though.) - -* For type-nat stuff the derived constraints include type families; - e.g. (a < b), (b < c) ==> a < c If we generate a Derived for this, - we'll generate a Derived/Wanted CFunEqCan; and, since the same - InertCans (after solving Givens) are used for each iteration, that - massively confused the unflattening step (TcFlatten.unflatten). - - In fact it led to some infinite loops: - indexed-types/should_compile/T10806 - indexed-types/should_compile/T10507 - polykinds/T10742 - -Note [Reduction for Derived CFunEqCans] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You may wonder if it's important to use top-level instances to -simplify [D] CFunEqCan's. But it is. Here's an example (T10226). - - type instance F Int = Int - type instance FInv Int = Int - -Suppose we have to solve - [WD] FInv (F alpha) ~ alpha - [WD] F alpha ~ Int - - --> flatten - [WD] F alpha ~ fuv0 - [WD] FInv fuv0 ~ fuv1 -- (A) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int -- (B) - - --> Rewwrite (A) with (B), splitting it - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] FInv Int ~ fuv1 -- (C) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int - - --> Reduce (C) with top-level instance - **** This is the key step *** - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] fuv1 ~ Int -- (D) - [WD] fuv1 ~ alpha -- (E) - [WD] fuv0 ~ Int - - --> Rewrite (D) with (E) - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] alpha ~ Int -- (F) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int - - --> unify (F) alpha := Int, and that solves it - -Another example is indexed-types/should_compile/T10634 --} - -{- ******************************************************************* -* * - Top-level reaction for class constraints (CDictCan) -* * -**********************************************************************-} - -doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct) --- Try to use type-class instance declarations to simplify the constraint -doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls - , cc_tyargs = xis }) - | isGiven fl -- Never use instances for Given constraints - = do { try_fundep_improvement - ; continueWith work_item } - - | Just ev <- lookupSolvedDict inerts cls xis -- Cached - = do { setEvBindIfWanted fl (ctEvTerm ev) - ; stopWith fl "Dict/Top (cached)" } - - | otherwise -- Wanted or Derived, but not cached - = do { dflags <- getDynFlags - ; lkup_inst_res <- matchClassInst dflags inerts cls xis dict_loc - ; case lkup_inst_res of - GenInst { lir_new_theta = theta - , lir_mk_ev = mk_ev - , lir_safe_over = s } -> - do { traceTcS "doTopReact/found instance for" $ ppr fl - ; checkReductionDepth deeper_loc dict_pred - ; unless s $ insertSafeOverlapFailureTcS work_item - ; if isDerived fl then finish_derived theta - else finish_wanted theta mk_ev } - NoInstance -> - do { when (isImprovable fl) $ - try_fundep_improvement - ; continueWith work_item } } - where - dict_pred = mkClassPred cls xis - dict_loc = ctEvLoc fl - dict_origin = ctLocOrigin dict_loc - deeper_loc = zap_origin (bumpCtLocDepth dict_loc) - - zap_origin loc -- After applying an instance we can set ScOrigin to - -- infinity, so that prohibitedSuperClassSolve never fires - | ScOrigin {} <- dict_origin - = setCtLocOrigin loc (ScOrigin infinity) - | otherwise - = loc - - finish_wanted :: [TcPredType] - -> ([EvTerm] -> EvTerm) -> TcS (StopOrContinue Ct) - -- Precondition: evidence term matches the predicate workItem - finish_wanted theta mk_ev - = do { addSolvedDict fl cls xis - ; evc_vars <- mapM (newWanted deeper_loc) theta - ; setWantedEvBind (ctEvId fl) (mk_ev (map getEvTerm evc_vars)) - ; emitWorkNC (freshGoals evc_vars) - ; stopWith fl "Dict/Top (solved wanted)" } - - finish_derived theta -- Use type-class instances for Deriveds, in the hope - = -- of generating some improvements - -- C.f. Example 3 of Note [The improvement story] - -- It's easy because no evidence is involved - do { emitNewDeriveds deeper_loc theta - ; traceTcS "finish_derived" (ppr (ctl_depth deeper_loc)) - ; stopWith fl "Dict/Top (solved derived)" } - - -- 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) - - -{- ******************************************************************* -* * - Class lookup -* * -**********************************************************************-} - --- | Indicates if Instance met the Safe Haskell overlapping instances safety --- check. --- --- See Note [Safe Haskell Overlapping Instances] in TcSimplify --- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -type SafeOverlapping = Bool - -data LookupInstResult - = NoInstance - | GenInst { lir_new_theta :: [TcPredType] - , lir_mk_ev :: [EvTerm] -> EvTerm - , lir_safe_over :: SafeOverlapping } - -instance Outputable LookupInstResult where - ppr NoInstance = text "NoInstance" - ppr (GenInst { lir_new_theta = ev - , lir_safe_over = s }) - = text "GenInst" <+> vcat [ppr ev, ss] - where ss = text $ if s then "[safe]" else "[unsafe]" - - -matchClassInst :: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult -matchClassInst dflags inerts clas tys loc --- First check whether there is an in-scope Given that could --- match this constraint. In that case, do not use top-level --- instances. See Note [Instance and Given overlap] - | not (xopt LangExt.IncoherentInstances dflags) - , not (naturallyCoherentClass clas) - , let matchable_givens = matchableGivens loc pred inerts - , not (isEmptyBag matchable_givens) - = do { traceTcS "Delaying instance application" $ - vcat [ text "Work item=" <+> pprClassPred clas tys - , text "Potential matching givens:" <+> ppr matchable_givens ] - ; return NoInstance } - where - pred = mkClassPred clas tys - -matchClassInst dflags _ clas tys loc - = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr (mkClassPred clas tys) <+> char '{' - ; res <- match_class_inst dflags clas tys loc - ; traceTcS "} matchClassInst result" $ ppr res - ; return res } - -match_class_inst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult -match_class_inst dflags clas tys loc - | cls_name == knownNatClassName = matchKnownNat clas tys - | cls_name == knownSymbolClassName = matchKnownSymbol clas tys - | isCTupleClass clas = matchCTuple clas tys - | cls_name == typeableClassName = matchTypeable clas tys - | clas `hasKey` heqTyConKey = matchLiftedEquality tys - | clas `hasKey` coercibleTyConKey = matchLiftedCoercible tys - | cls_name == hasFieldClassName = matchHasField dflags clas tys loc - | otherwise = matchInstEnv dflags clas tys loc - where - cls_name = className clas - -{- Note [Instance and Given overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Example, from the OutsideIn(X) paper: - instance P x => Q [x] - instance (x ~ y) => R y [x] - - wob :: forall a b. (Q [b], R b a) => a -> Int - - g :: forall a. Q [a] => [a] -> Int - g x = wob x - -From 'g' we get the impliation constraint: - forall a. Q [a] => (Q [beta], R beta [a]) -If we react (Q [beta]) with its top-level axiom, we end up with a -(P beta), which we have no way of discharging. On the other hand, -if we react R beta [a] with the top-level we get (beta ~ a), which -is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is -now solvable by the given Q [a]. - -The partial solution is that: - In matchClassInst (and thus in topReact), we return a matching - instance only when there is no Given in the inerts which is - unifiable to this particular dictionary. - - We treat any meta-tyvar as "unifiable" for this purpose, - *including* untouchable ones. But not skolems like 'a' in - the implication constraint above. - -The end effect is that, much as we do for overlapping instances, we -delay choosing a class instance if there is a possibility of another -instance OR a given to match our constraint later on. This fixes -Trac #4981 and #5002. - -Other notes: - -* The check is done *first*, so that it also covers classes - with built-in instance solving, such as - - constraint tuples - - natural numbers - - Typeable - -* The given-overlap problem is arguably not easy to appear in practice - due to our aggressive prioritization of equality solving over other - constraints, but it is possible. I've added a test case in - typecheck/should-compile/GivenOverlapping.hs - -* Another "live" example is Trac #10195; another is #10177. - -* We ignore the overlap problem if -XIncoherentInstances is in force: - see Trac #6002 for a worked-out example where this makes a - difference. - -* Moreover notice that our goals here are different than the goals of - the top-level overlapping checks. There we are interested in - validating the following principle: - - If we inline a function f at a site where the same global - instance environment is available as the instance environment at - the definition site of f then we should get the same behaviour. - - But for the Given Overlap check our goal is just related to completeness of - constraint solving. - -* The solution is only a partial one. Consider the above example with - g :: forall a. Q [a] => [a] -> Int - g x = let v = wob x - in v - and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most - general type for 'v'. When generalising v's type we'll simplify its - Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we - will use the instance declaration after all. Trac #11948 was a case - in point. - -All of this is disgustingly delicate, so to discourage people from writing -simplifiable class givens, we warn about signatures that contain them;# -see TcValidity Note [Simplifiable given constraints]. --} - - -{- ******************************************************************* -* * - Class lookup in the instance environment -* * -**********************************************************************-} - -matchInstEnv :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult -matchInstEnv dflags clas tys loc - = do { instEnvs <- getInstEnvs - ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy] - (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys - safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps) - ; case (matches, unify, safeHaskFail) of - - -- Nothing matches - ([], _, _) - -> do { traceTcS "matchClass not matching" $ - vcat [ text "dict" <+> ppr pred ] - ; return NoInstance } - - -- A single match (& no safe haskell failure) - ([(ispec, inst_tys)], [], False) - -> do { let dfun_id = instanceDFunId ispec - ; traceTcS "matchClass success" $ - vcat [text "dict" <+> ppr pred, - text "witness" <+> ppr dfun_id - <+> ppr (idType dfun_id) ] - -- Record that this dfun is needed - ; match_one (null unsafeOverlaps) dfun_id inst_tys } - - -- More than one matches (or Safe Haskell fail!). Defer any - -- reactions of a multitude until we learn more about the reagent - (matches, _, _) - -> do { traceTcS "matchClass multiple matches, deferring choice" $ - vcat [text "dict" <+> ppr pred, - text "matches" <+> ppr matches] - ; return NoInstance } } - where - pred = mkClassPred clas tys - - match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcS LookupInstResult - -- See Note [DFunInstType: instantiating types] in InstEnv - match_one so dfun_id mb_inst_tys - = do { checkWellStagedDFun pred dfun_id loc - ; (tys, theta) <- instDFunType dfun_id mb_inst_tys - ; return $ GenInst { lir_new_theta = theta - , lir_mk_ev = EvDFunApp dfun_id tys - , lir_safe_over = so } } - - -{- ******************************************************************** -* * - Class lookup for CTuples -* * -***********************************************************************-} - -matchCTuple :: Class -> [Type] -> TcS LookupInstResult -matchCTuple clas tys -- (isCTupleClass clas) holds - = return (GenInst { lir_new_theta = tys - , lir_mk_ev = tuple_ev - , lir_safe_over = True }) - -- The dfun *is* the data constructor! - where - data_con = tyConSingleDataCon (classTyCon clas) - tuple_ev = EvDFunApp (dataConWrapId data_con) tys - -{- ******************************************************************** -* * - Class lookup for Literals -* * -***********************************************************************-} - -matchKnownNat :: Class -> [Type] -> TcS LookupInstResult -matchKnownNat clas [ty] -- clas = KnownNat - | Just n <- isNumLitTy ty = makeLitDict clas ty (EvNum n) -matchKnownNat _ _ = return NoInstance - -matchKnownSymbol :: Class -> [Type] -> TcS LookupInstResult -matchKnownSymbol clas [ty] -- clas = KnownSymbol - | Just n <- isStrLitTy ty = makeLitDict clas ty (EvStr n) -matchKnownSymbol _ _ = return NoInstance - - -makeLitDict :: Class -> Type -> EvLit -> TcS LookupInstResult --- makeLitDict adds a coercion that will convert the literal into a dictionary --- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit] --- in TcEvidence. The coercion happens in 2 steps: --- --- Integer -> SNat n -- representation of literal to singleton --- SNat n -> KnownNat n -- singleton to dictionary --- --- The process is mirrored for Symbols: --- String -> SSymbol n --- SSymbol n -> KnownSymbol n -} -makeLitDict clas ty evLit - | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] - -- co_dict :: KnownNat n ~ SNat n - , [ meth ] <- classMethods clas - , Just tcRep <- tyConAppTyCon_maybe -- SNat - $ funResultTy -- SNat n - $ dropForAlls -- KnownNat n => SNat n - $ idType meth -- forall n. KnownNat n => SNat n - , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] - -- SNat n ~ Integer - , let ev_tm = mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep)) - = return $ GenInst { lir_new_theta = [] - , lir_mk_ev = \_ -> ev_tm - , lir_safe_over = True } - - | otherwise - = panicTcS (text "Unexpected evidence for" <+> ppr (className clas) - $$ vcat (map (ppr . idType) (classMethods clas))) - - -{- ******************************************************************** -* * - Class lookup for Typeable -* * -***********************************************************************-} - --- | Assumes that we've checked that this is the 'Typeable' class, --- and it was applied to the correct argument. -matchTypeable :: Class -> [Type] -> TcS LookupInstResult -matchTypeable clas [k,t] -- clas = Typeable - -- For the first two cases, See Note [No Typeable for polytypes or qualified types] - | isForAllTy k = return NoInstance -- Polytype - | isJust (tcSplitPredFunTy_maybe t) = return NoInstance -- Qualified type - - -- Now cases that do work - | k `eqType` typeNatKind = doTyLit knownNatClassName t - | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t - | isConstraintKind t = doTyConApp clas t constraintKindTyCon [] - | Just (arg,ret) <- splitFunTy_maybe t = doFunTy clas t arg ret - | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] - , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks - | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt - -matchTypeable _ _ = return NoInstance - --- | Representation for a type @ty@ of the form @arg -> ret@. -doFunTy :: Class -> Type -> Type -> Type -> TcS LookupInstResult -doFunTy clas ty arg_ty ret_ty - = do { let preds = map (mk_typeable_pred clas) [arg_ty, ret_ty] - build_ev [arg_ev, ret_ev] = - EvTypeable ty $ EvTypeableTrFun arg_ev ret_ev - build_ev _ = panic "TcInteract.doFunTy" - ; return $ GenInst preds build_ev True - } - --- | Representation for type constructor applied to some kinds. --- 'onlyNamedBndrsApplied' has ensured that this application results in a type --- of monomorphic kind (e.g. all kind variables have been instantiated). -doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcS LookupInstResult -doTyConApp clas ty tc kind_args - = return $ GenInst (map (mk_typeable_pred clas) kind_args) - (\kinds -> EvTypeable ty $ EvTypeableTyCon tc kinds) - True - --- | Representation for TyCon applications of a concrete kind. We just use the --- kind itself, but first we must make sure that we've instantiated all kind- --- polymorphism, but no more. -onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool -onlyNamedBndrsApplied tc ks - = all isNamedTyConBinder used_bndrs && - not (any isNamedTyConBinder leftover_bndrs) - where - bndrs = tyConBinders tc - (used_bndrs, leftover_bndrs) = splitAtList ks bndrs - -doTyApp :: Class -> Type -> Type -> KindOrType -> TcS LookupInstResult --- Representation for an application of a type to a type-or-kind. --- This may happen when the type expression starts with a type variable. --- Example (ignoring kind parameter): --- Typeable (f Int Char) --> --- (Typeable (f Int), Typeable Char) --> --- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) --- Typeable f -doTyApp clas ty f tk - | isForAllTy (typeKind f) - = return NoInstance -- We can't solve until we know the ctr. - | otherwise - = return $ GenInst (map (mk_typeable_pred clas) [f, tk]) - (\[t1,t2] -> EvTypeable ty $ EvTypeableTyApp t1 t2) - True - --- Emit a `Typeable` constraint for the given type. -mk_typeable_pred :: Class -> Type -> PredType -mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ] - - -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal - -- we generate a sub-goal for the appropriate class. See #10348 for what - -- happens when we fail to do this. -doTyLit :: Name -> Type -> TcS LookupInstResult -doTyLit kc t = do { kc_clas <- tcLookupClass kc - ; let kc_pred = mkClassPred kc_clas [ t ] - mk_ev [ev] = EvTypeable t $ EvTypeableTyLit ev - mk_ev _ = panic "doTyLit" - ; return (GenInst [kc_pred] mk_ev True) } - -{- Note [Typeable (T a b c)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For type applications we always decompose using binary application, -via doTyApp, until we get to a *kind* instantiation. Example - Proxy :: forall k. k -> * - -To solve Typeable (Proxy (* -> *) Maybe) we - - First decompose with doTyApp, - to get (Typeable (Proxy (* -> *))) and Typeable Maybe - - Then solve (Typeable (Proxy (* -> *))) with doTyConApp - -If we attempt to short-cut by solving it all at once, via -doTyConApp - -(this note is sadly truncated FIXME) - - -Note [No Typeable for polytypes or qualified types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not support impredicative typeable, such as - Typeable (forall a. a->a) - Typeable (Eq a => a -> a) - Typeable (() => Int) - Typeable (((),()) => Int) - -See Trac #9858. For forall's the case is clear: we simply don't have -a TypeRep for them. For qualified but not polymorphic types, like -(Eq a => a -> a), things are murkier. But: - - * We don't need a TypeRep for these things. TypeReps are for - monotypes only. - - * Perhaps we could treat `=>` as another type constructor for `Typeable` - purposes, and thus support things like `Eq Int => Int`, however, - at the current state of affairs this would be an odd exception as - no other class works with impredicative types. - For now we leave it off, until we have a better story for impredicativity. --} - -solveCallStack :: CtEvidence -> EvCallStack -> TcS () -solveCallStack ev ev_cs = do - -- We're given ev_cs :: CallStack, but the evidence term should be a - -- dictionary, so we have to coerce ev_cs to a dictionary for - -- `IP ip CallStack`. See Note [Overview of implicit CallStacks] - let ev_tm = mkEvCast (EvCallStack ev_cs) (wrapIP (ctEvPred ev)) - setWantedEvBind (ctEvId ev) ev_tm - -{- ******************************************************************** -* * - Class lookup for lifted equality -* * -***********************************************************************-} - --- See also Note [The equality types story] in TysPrim -matchLiftedEquality :: [Type] -> TcS LookupInstResult -matchLiftedEquality args - = return (GenInst { lir_new_theta = [ mkTyConApp eqPrimTyCon args ] - , lir_mk_ev = EvDFunApp (dataConWrapId heqDataCon) args - , lir_safe_over = True }) - --- See also Note [The equality types story] in TysPrim -matchLiftedCoercible :: [Type] -> TcS LookupInstResult -matchLiftedCoercible args@[k, t1, t2] - = return (GenInst { lir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ] - , lir_mk_ev = EvDFunApp (dataConWrapId coercibleDataCon) - args - , lir_safe_over = True }) - where - args' = [k, k, t1, t2] -matchLiftedCoercible args = pprPanic "matchLiftedCoercible" (ppr args) - - -{- ******************************************************************** -* * - Class lookup for overloaded record fields -* * -***********************************************************************-} - -{- -Note [HasField instances] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - data T y = MkT { foo :: [y] } - -and `foo` is in scope. Then GHC will automatically solve a constraint like - - HasField "foo" (T Int) b - -by emitting a new wanted - - T alpha -> [alpha] ~# T Int -> b - -and building a HasField dictionary out of the selector function `foo`, -appropriately cast. - -The HasField class is defined (in GHC.Records) thus: - - class HasField (x :: k) r a | x r -> a where - getField :: r -> a - -Since this is a one-method class, it is represented as a newtype. -Hence we can solve `HasField "foo" (T Int) b` by taking an expression -of type `T Int -> b` and casting it using the newtype coercion. -Note that - - foo :: forall y . T y -> [y] - -so the expression we construct is - - foo @alpha |> co - -where - - co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b - -is built from - - co1 :: (T alpha -> [alpha]) ~# (T Int -> b) - -which is the new wanted, and - - co2 :: (T Int -> b) ~# HasField "foo" (T Int) b - -which can be derived from the newtype coercion. - -If `foo` is not in scope, or has a higher-rank or existentially -quantified type, then the constraint is not solved automatically, but -may be solved by a user-supplied HasField instance. Similarly, if we -encounter a HasField constraint where the field is not a literal -string, or does not belong to the type, then we fall back on the -normal constraint solver behaviour. --} - --- See Note [HasField instances] -matchHasField :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult -matchHasField dflags clas tys loc - = do { fam_inst_envs <- getFamInstEnvs - ; rdr_env <- getGlobalRdrEnvTcS - ; case tys of - -- We are matching HasField {k} x r a... - [_k_ty, x_ty, r_ty, a_ty] - -- x should be a literal string - | Just x <- isStrLitTy x_ty - -- r should be an applied type constructor - , Just (tc, args) <- tcSplitTyConApp_maybe r_ty - -- use representation tycon (if data family); it has the fields - , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args) - -- x should be a field of r - , Just fl <- lookupTyConFieldLabel x r_tc - -- the field selector should be in scope - , Just gre <- lookupGRE_FieldLabel rdr_env fl - - -> do { sel_id <- tcLookupId (flSelector fl) - ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id - - -- The first new wanted constraint equates the actual - -- type of the selector with the type (r -> a) within - -- the HasField x r a dictionary. The preds will - -- typically be empty, but if the datatype has a - -- "stupid theta" then we have to include it here. - ; let theta = mkPrimEqPred sel_ty (mkFunTy r_ty a_ty) : preds - - -- Use the equality proof to cast the selector Id to - -- type (r -> a), then use the newtype coercion to cast - -- it to a HasField dictionary. - mk_ev (ev1:evs) = EvSelector sel_id tvs evs `EvCast` co - where - co = mkTcSubCo (evTermCoercion ev1) - `mkTcTransCo` mkTcSymCo co2 - mk_ev [] = panic "matchHasField.mk_ev" - - Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas) - tys - - tvs = mkTyVarTys (map snd tv_prs) - - -- The selector must not be "naughty" (i.e. the field - -- cannot have an existentially quantified type), and - -- it must not be higher-rank. - ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty - then do { addUsedGRE True gre - ; return GenInst { lir_new_theta = theta - , lir_mk_ev = mk_ev - , lir_safe_over = True - } } - else matchInstEnv dflags clas tys loc } - - _ -> matchInstEnv dflags clas tys loc } diff --git a/typecheck/TcMType.hs b/typecheck/TcMType.hs deleted file mode 100644 --- a/typecheck/TcMType.hs +++ /dev/null @@ -1,1706 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Monadic type operations - -This module contains monadic operations over types that contain -mutable type variables --} - -{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} - -module TcMType ( - TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, - - -------------------------------- - -- Creating new mutable type variables - newFlexiTyVar, - newFlexiTyVarTy, -- Kind -> TcM TcType - newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] - newOpenFlexiTyVarTy, newOpenTypeKind, - newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel, - cloneMetaTyVar, - newFmvTyVar, newFskTyVar, - - readMetaTyVar, writeMetaTyVar, - newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar, - - -------------------------------- - -- Expected types - ExpType(..), ExpSigmaType, ExpRhoType, - mkCheckExpType, - newInferExpType, newInferExpTypeInst, newInferExpTypeNoInst, - readExpType, readExpType_maybe, - expTypeToType, checkingExpType_maybe, checkingExpType, - tauifyExpType, inferResultToType, - - -------------------------------- - -- Creating fresh type variables for pm checking - genInstSkolTyVarsX, - - -------------------------------- - -- Creating new evidence variables - newEvVar, newEvVars, newDict, - newWanted, newWanteds, cloneWanted, cloneWC, - emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, - newTcEvBinds, addTcEvBind, - - newCoercionHole, fillCoercionHole, isFilledCoercionHole, - unpackCoercionHole, unpackCoercionHole_maybe, - checkCoercionHole, - - -------------------------------- - -- Instantiation - newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, - newMetaSigTyVars, newMetaSigTyVarX, - newSigTyVar, newWildCardX, - tcInstType, - tcInstSkolTyVars,tcInstSkolTyVarsX, - tcInstSuperSkolTyVarsX, - tcSkolDFunType, tcSuperSkolTyVars, - - instSkolTyCoVars, freshenTyVarBndrs, freshenCoVarBndrsX, - - -------------------------------- - -- Zonking and tidying - zonkTidyTcType, zonkTidyOrigin, - mkTypeErrorThing, mkTypeErrorThingArgs, - tidyEvVar, tidyCt, tidySkolemInfo, - skolemiseRuntimeUnk, - zonkTcTyVar, zonkTcTyVars, zonkTcTyVarToTyVar, - zonkTyCoVarsAndFV, zonkTcTypeAndFV, - zonkTyCoVarsAndFVList, - zonkTcTypeAndSplitDepVars, zonkTcTypesAndSplitDepVars, - zonkQuantifiedTyVar, defaultTyVar, - quantifyTyVars, quantifyZonkedTyVars, - zonkTcTyCoVarBndr, zonkTcTyVarBinder, - zonkTcType, zonkTcTypes, zonkCo, - zonkTyCoVarKind, zonkTcTypeMapper, - - zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCt, zonkSkolemInfo, - - tcGetGlobalTyCoVars, - - ------------------------------ - -- Levity polymorphism - ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr - ) where - -#include "HsVersions.h" - --- friends: -import TyCoRep -import TcType -import Type -import Kind -import Coercion -import Class -import Var - --- others: -import TcRnMonad -- TcType, amongst others -import TcEvidence -import Id -import Name -import VarSet -import TysWiredIn -import TysPrim -import VarEnv -import NameEnv -import PrelNames -import Util -import Outputable -import FastString -import SrcLoc -import Bag -import Pair -import UniqSet -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Maybes -import Data.List ( mapAccumL ) -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - Kind variables -* * -************************************************************************ --} - -mkKindName :: Unique -> Name -mkKindName unique = mkSystemName unique kind_var_occ - -kind_var_occ :: OccName -- Just one for all MetaKindVars - -- They may be jiggled by tidying -kind_var_occ = mkOccName tvName "k" - -newMetaKindVar :: TcM TcKind -newMetaKindVar = do { uniq <- newUnique - ; details <- newMetaDetails TauTv - ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details - ; return (mkTyVarTy kv) } - -newMetaKindVars :: Int -> TcM [TcKind] -newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ()) - -{- -************************************************************************ -* * - Evidence variables; range over constraints we can abstract over -* * -************************************************************************ --} - -newEvVars :: TcThetaType -> TcM [EvVar] -newEvVars theta = mapM newEvVar theta - --------------- - -newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar --- Creates new *rigid* variables for predicates -newEvVar ty = do { name <- newSysName (predTypeOccName ty) - ; return (mkLocalIdOrCoVar name ty) } - -newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence --- Deals with both equality and non-equality predicates -newWanted orig t_or_k pty - = do loc <- getCtLocM orig t_or_k - d <- if isEqPred pty then HoleDest <$> newCoercionHole - else EvVarDest <$> newEvVar pty - return $ CtWanted { ctev_dest = d - , ctev_pred = pty - , ctev_nosh = WDeriv - , ctev_loc = loc } - -newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] -newWanteds orig = mapM (newWanted orig Nothing) - -cloneWanted :: Ct -> TcM CtEvidence -cloneWanted ct - = newWanted (ctEvOrigin ev) Nothing (ctEvPred ev) - where - ev = ctEvidence ct - -cloneWC :: WantedConstraints -> TcM WantedConstraints -cloneWC wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { simples' <- mapBagM clone_one simples - ; implics' <- mapBagM clone_implic implics - ; return (wc { wc_simple = simples', wc_impl = implics' }) } - where - clone_one ct = do { ev <- cloneWanted ct; return (mkNonCanonical ev) } - - clone_implic implic@(Implic { ic_wanted = inner_wanted }) - = do { inner_wanted' <- cloneWC inner_wanted - ; return (implic { ic_wanted = inner_wanted' }) } - --- | Emits a new Wanted. Deals with both equalities and non-equalities. -emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm -emitWanted origin pty - = do { ev <- newWanted origin Nothing pty - ; emitSimple $ mkNonCanonical ev - ; return $ ctEvTerm ev } - --- | Emits a new equality constraint -emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion -emitWantedEq origin t_or_k role ty1 ty2 - = do { hole <- newCoercionHole - ; loc <- getCtLocM origin (Just t_or_k) - ; emitSimple $ mkNonCanonical $ - CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole - , ctev_nosh = WDeriv, ctev_loc = loc } - ; return (mkHoleCo hole role ty1 ty2) } - where - pty = mkPrimEqPredRole role ty1 ty2 - --- | Creates a new EvVar and immediately emits it as a Wanted. --- No equality predicates here. -emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar -emitWantedEvVar origin ty - = do { new_cv <- newEvVar ty - ; loc <- getCtLocM origin Nothing - ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv - , ctev_pred = ty - , ctev_nosh = WDeriv - , ctev_loc = loc } - ; emitSimple $ mkNonCanonical ctev - ; return new_cv } - -emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar] -emitWantedEvVars orig = mapM (emitWantedEvVar orig) - -newDict :: Class -> [TcType] -> TcM DictId -newDict cls tys - = do { name <- newSysName (mkDictOcc (getOccName cls)) - ; return (mkLocalId name (mkClassPred cls tys)) } - -predTypeOccName :: PredType -> OccName -predTypeOccName ty = case classifyPredType ty of - ClassPred cls _ -> mkDictOcc (getOccName cls) - EqPred _ _ _ -> mkVarOccFS (fsLit "cobox") - IrredPred _ -> mkVarOccFS (fsLit "irred") - -{- -************************************************************************ -* * - Coercion holes -* * -************************************************************************ --} - -newCoercionHole :: TcM CoercionHole -newCoercionHole - = do { u <- newUnique - ; traceTc "New coercion hole:" (ppr u) - ; ref <- newMutVar Nothing - ; return $ CoercionHole u ref } - --- | Put a value in a coercion hole -fillCoercionHole :: CoercionHole -> Coercion -> TcM () -fillCoercionHole (CoercionHole u ref) co - = do { -#ifdef DEBUG - ; cts <- readTcRef ref - ; whenIsJust cts $ \old_co -> - pprPanic "Filling a filled coercion hole" (ppr u $$ ppr co $$ ppr old_co) -#endif - ; traceTc "Filling coercion hole" (ppr u <+> text ":=" <+> ppr co) - ; writeTcRef ref (Just co) } - --- | Is a coercion hole filled in? -isFilledCoercionHole :: CoercionHole -> TcM Bool -isFilledCoercionHole (CoercionHole _ ref) = isJust <$> readTcRef ref - --- | Retrieve the contents of a coercion hole. Panics if the hole --- is unfilled -unpackCoercionHole :: CoercionHole -> TcM Coercion -unpackCoercionHole hole - = do { contents <- unpackCoercionHole_maybe hole - ; case contents of - Just co -> return co - Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } - --- | Retrieve the contents of a coercion hole, if it is filled -unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion) -unpackCoercionHole_maybe (CoercionHole _ ref) = readTcRef ref - --- | Check that a coercion is appropriate for filling a hole. (The hole --- itself is needed only for printing. NB: This must be /lazy/ in the coercion, --- as it's used in TcHsSyn in the presence of knots. --- Always returns the checked coercion, but this return value is necessary --- so that the input coercion is forced only when the output is forced. -checkCoercionHole :: Coercion -> CoercionHole -> Role -> Type -> Type -> TcM Coercion -checkCoercionHole co h r t1 t2 --- co is already zonked, but t1 and t2 might not be - | debugIsOn - = do { t1 <- zonkTcType t1 - ; t2 <- zonkTcType t2 - ; let (Pair _t1 _t2, _role) = coercionKindRole co - ; return $ - ASSERT2( t1 `eqType` _t1 && t2 `eqType` _t2 && r == _role - , (text "Bad coercion hole" <+> - ppr h <> colon <+> vcat [ ppr _t1, ppr _t2, ppr _role - , ppr co, ppr t1, ppr t2 - , ppr r ]) ) - co } - | otherwise - = return co - -{- -************************************************************************ -* - Expected types -* -************************************************************************ - -Note [ExpType] -~~~~~~~~~~~~~~ - -An ExpType is used as the "expected type" when type-checking an expression. -An ExpType can hold a "hole" that can be filled in by the type-checker. -This allows us to have one tcExpr that works in both checking mode and -synthesis mode (that is, bidirectional type-checking). Previously, this -was achieved by using ordinary unification variables, but we don't need -or want that generality. (For example, #11397 was caused by doing the -wrong thing with unification variables.) Instead, we observe that these -holes should - -1. never be nested -2. never appear as the type of a variable -3. be used linearly (never be duplicated) - -By defining ExpType, separately from Type, we can achieve goals 1 and 2 -statically. - -See also [wiki:Typechecking] - -Note [TcLevel of ExpType] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data G a where - MkG :: G Bool - - foo MkG = True - -This is a classic untouchable-variable / ambiguous GADT return type -scenario. But, with ExpTypes, we'll be inferring the type of the RHS. -And, because there is only one branch of the case, we won't trigger -Note [Case branches must never infer a non-tau type] of TcMatches. -We thus must track a TcLevel in an Inferring ExpType. If we try to -fill the ExpType and find that the TcLevels don't work out, we -fill the ExpType with a tau-tv at the low TcLevel, hopefully to -be worked out later by some means. This is triggered in -test gadt/gadt-escape1. - --} - --- actual data definition is in TcType - --- | Make an 'ExpType' suitable for inferring a type of kind * or #. -newInferExpTypeNoInst :: TcM ExpSigmaType -newInferExpTypeNoInst = newInferExpType False - -newInferExpTypeInst :: TcM ExpRhoType -newInferExpTypeInst = newInferExpType True - -newInferExpType :: Bool -> TcM ExpType -newInferExpType inst - = do { u <- newUnique - ; tclvl <- getTcLevel - ; traceTc "newOpenInferExpType" (ppr u <+> ppr inst <+> ppr tclvl) - ; ref <- newMutVar Nothing - ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl - , ir_ref = ref, ir_inst = inst })) } - --- | Extract a type out of an ExpType, if one exists. But one should always --- exist. Unless you're quite sure you know what you're doing. -readExpType_maybe :: ExpType -> TcM (Maybe TcType) -readExpType_maybe (Check ty) = return (Just ty) -readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref - --- | Extract a type out of an ExpType. Otherwise, panics. -readExpType :: ExpType -> TcM TcType -readExpType exp_ty - = do { mb_ty <- readExpType_maybe exp_ty - ; case mb_ty of - Just ty -> return ty - Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) } - --- | Returns the expected type when in checking mode. -checkingExpType_maybe :: ExpType -> Maybe TcType -checkingExpType_maybe (Check ty) = Just ty -checkingExpType_maybe _ = Nothing - --- | Returns the expected type when in checking mode. Panics if in inference --- mode. -checkingExpType :: String -> ExpType -> TcType -checkingExpType _ (Check ty) = ty -checkingExpType err et = pprPanic "checkingExpType" (text err $$ ppr et) - -tauifyExpType :: ExpType -> TcM ExpType --- ^ Turn a (Infer hole) type into a (Check alpha), --- where alpha is a fresh unification variable -tauifyExpType (Check ty) = return (Check ty) -- No-op for (Check ty) -tauifyExpType (Infer inf_res) = do { ty <- inferResultToType inf_res - ; return (Check ty) } - --- | Extracts the expected type if there is one, or generates a new --- TauTv if there isn't. -expTypeToType :: ExpType -> TcM TcType -expTypeToType (Check ty) = return ty -expTypeToType (Infer inf_res) = inferResultToType inf_res - -inferResultToType :: InferResult -> TcM Type -inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl - , ir_ref = ref }) - = do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy - ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr) - -- See Note [TcLevel of ExpType] - ; writeMutVar ref (Just tau) - ; traceTc "Forcing ExpType to be monomorphic:" - (ppr u <+> text ":=" <+> ppr tau) - ; return tau } - - -{- ********************************************************************* -* * - SkolemTvs (immutable) -* * -********************************************************************* -} - -tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) - -- ^ How to instantiate the type variables - -> Id -- ^ Type to instantiate - -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result - -- (type vars, preds (incl equalities), rho) -tcInstType inst_tyvars id - = case tcSplitForAllTys (idType id) of - ([], rho) -> let -- There may be overloading despite no type variables; - -- (?x :: Int) => Int -> Int - (theta, tau) = tcSplitPhiTy rho - in - return ([], theta, tau) - - (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars - ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho) - tv_prs = map tyVarName tyvars `zip` tyvars' - ; return (tv_prs, theta, tau) } - -tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) --- Instantiate a type signature with skolem constants. --- We could give them fresh names, but no need to do so -tcSkolDFunType dfun - = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun - ; return (map snd tv_prs, theta, tau) } - -tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar]) --- Make skolem constants, but do *not* give them new names, as above --- Moreover, make them "super skolems"; see comments with superSkolemTv --- see Note [Kind substitution when instantiating] --- Precondition: tyvars should be ordered by scoping -tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst - -tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar) -tcSuperSkolTyVar subst tv - = (extendTvSubstWithClone subst tv new_tv, new_tv) - where - kind = substTyUnchecked subst (tyVarKind tv) - new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv - --- | Given a list of @['TyVar']@, skolemize the type variables, --- returning a substitution mapping the original tyvars to the --- skolems, and the list of newly bound skolems. See also --- tcInstSkolTyVars' for a precondition. The resulting --- skolems are non-overlappable; see Note [Overlap and deriving] --- for an example where this matters. -tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst - -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsX = tcInstSkolTyVars' False - -tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst - -tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst - -tcInstSkolTyVars' :: Bool -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- Precondition: tyvars should be ordered (kind vars first) --- see Note [Kind substitution when instantiating] --- Get the location from the monad; this is a complete freshening operation -tcInstSkolTyVars' overlappable subst tvs - = do { loc <- getSrcSpanM - ; lvl <- getTcLevel - ; instSkolTyCoVarsX (mkTcSkolTyVar lvl loc overlappable) subst tvs } - -mkTcSkolTyVar :: TcLevel -> SrcSpan -> Bool -> TcTyVarMaker -mkTcSkolTyVar lvl loc overlappable - = \ uniq old_name kind -> mkTcTyVar (mkInternalName uniq (getOccName old_name) loc) - kind details - where - details = SkolemTv (pushTcLevel lvl) overlappable - -- NB: skolems bump the level - ------------------- -freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyVar]) --- ^ Give fresh uniques to a bunch of TyVars, but they stay --- as TyVars, rather than becoming TcTyVars --- Used in FamInst.newFamInst, and Inst.newClsInst -freshenTyVarBndrs = instSkolTyCoVars mk_tv - where - mk_tv uniq old_name kind = mkTyVar (setNameUnique old_name uniq) kind - -freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcRnIf gbl lcl (TCvSubst, [CoVar]) --- ^ Give fresh uniques to a bunch of CoVars --- Used in FamInst.newFamInst -freshenCoVarBndrsX subst = instSkolTyCoVarsX mk_cv subst - where - mk_cv uniq old_name kind = mkCoVar (setNameUnique old_name uniq) kind - ------------------- -type TcTyVarMaker = Unique -> Name -> Kind -> TyCoVar -instSkolTyCoVars :: TcTyVarMaker -> [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar]) -instSkolTyCoVars mk_tcv = instSkolTyCoVarsX mk_tcv emptyTCvSubst - -instSkolTyCoVarsX :: TcTyVarMaker - -> TCvSubst -> [TyCoVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar]) -instSkolTyCoVarsX mk_tcv = mapAccumLM (instSkolTyCoVarX mk_tcv) - -instSkolTyCoVarX :: TcTyVarMaker - -> TCvSubst -> TyCoVar -> TcRnIf gbl lcl (TCvSubst, TyCoVar) -instSkolTyCoVarX mk_tcv subst tycovar - = do { uniq <- newUnique -- using a new unique is critical. See - -- Note [Skolems in zonkSyntaxExpr] in TcHsSyn - ; let new_tcv = mk_tcv uniq old_name kind - subst1 | isTyVar new_tcv - = extendTvSubstWithClone subst tycovar new_tcv - | otherwise - = extendCvSubstWithClone subst tycovar new_tcv - ; return (subst1, new_tcv) } - where - old_name = tyVarName tycovar - kind = substTyUnchecked subst (tyVarKind tycovar) - -newFskTyVar :: TcType -> TcM TcTyVar -newFskTyVar fam_ty - = do { uniq <- newUnique - ; let name = mkSysTvName uniq (fsLit "fsk") - ; return (mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty)) } -{- -Note [Kind substitution when instantiating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we instantiate a bunch of kind and type variables, first we -expect them to be topologically sorted. -Then we have to instantiate the kind variables, build a substitution -from old variables to the new variables, then instantiate the type -variables substituting the original kind. - -Exemple: If we want to instantiate - [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)] -we want - [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)] -instead of the buggous - [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)] - - -************************************************************************ -* * - MetaTvs (meta type variables; mutable) -* * -************************************************************************ --} - -mkMetaTyVarName :: Unique -> FastString -> Name --- Makes a /System/ Name, which is eagerly eliminated by --- the unifier; see TcUnify.nicer_to_update_tv1, and --- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2) -mkMetaTyVarName uniq str = mkSysTvName uniq str - -newSigTyVar :: Name -> Kind -> TcM TcTyVar -newSigTyVar name kind - = do { details <- newMetaDetails SigTv - ; return (mkTcTyVar name kind details) } - -newFmvTyVar :: TcType -> TcM TcTyVar --- Very like newMetaTyVar, except sets mtv_tclvl to one less --- so that the fmv is untouchable. -newFmvTyVar fam_ty - = do { uniq <- newUnique - ; ref <- newMutVar Flexi - ; cur_lvl <- getTcLevel - ; let details = MetaTv { mtv_info = FlatMetaTv - , mtv_ref = ref - , mtv_tclvl = fmvTcLevel cur_lvl } - name = mkMetaTyVarName uniq (fsLit "s") - ; return (mkTcTyVar name (typeKind fam_ty) details) } - -newMetaDetails :: MetaInfo -> TcM TcTyVarDetails -newMetaDetails info - = do { ref <- newMutVar Flexi - ; tclvl <- getTcLevel - ; return (MetaTv { mtv_info = info - , mtv_ref = ref - , mtv_tclvl = tclvl }) } - -cloneMetaTyVar :: TcTyVar -> TcM TcTyVar -cloneMetaTyVar tv - = ASSERT( isTcTyVar tv ) - do { uniq <- newUnique - ; ref <- newMutVar Flexi - ; let name' = setNameUnique (tyVarName tv) uniq - details' = case tcTyVarDetails tv of - details@(MetaTv {}) -> details { mtv_ref = ref } - _ -> pprPanic "cloneMetaTyVar" (ppr tv) - ; return (mkTcTyVar name' (tyVarKind tv) details') } - --- Works for both type and kind variables -readMetaTyVar :: TyVar -> TcM MetaDetails -readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) - readMutVar (metaTyVarRef tyvar) - -isFilledMetaTyVar :: TyVar -> TcM Bool --- True of a filled-in (Indirect) meta type variable -isFilledMetaTyVar tv - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv - = do { details <- readMutVar ref - ; return (isIndirect details) } - | otherwise = return False - -isUnfilledMetaTyVar :: TyVar -> TcM Bool --- True of a un-filled-in (Flexi) meta type variable -isUnfilledMetaTyVar tv - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv - = do { details <- readMutVar ref - ; return (isFlexi details) } - | otherwise = return False - --------------------- --- Works with both type and kind variables -writeMetaTyVar :: TcTyVar -> TcType -> TcM () --- Write into a currently-empty MetaTyVar - -writeMetaTyVar tyvar ty - | not debugIsOn - = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty - --- Everything from here on only happens if DEBUG is on - | not (isTcTyVar tyvar) - = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar ) - return () - - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar - = writeMetaTyVarRef tyvar ref ty - - | otherwise - = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar ) - return () - --------------------- -writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () --- Here the tyvar is for error checking only; --- the ref cell must be for the same tyvar -writeMetaTyVarRef tyvar ref ty - | not debugIsOn - = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) - <+> text ":=" <+> ppr ty) - ; writeTcRef ref (Indirect ty) } - - -- Everything from here on only happens if DEBUG is on - | otherwise - = do { meta_details <- readMutVar ref; - -- Zonk kinds to allow the error check to work - ; zonked_tv_kind <- zonkTcType tv_kind - ; zonked_ty_kind <- zonkTcType ty_kind - ; let kind_check_ok = isPredTy tv_kind -- Don't check kinds for updates - -- to coercion variables. Why not?? - || isConstraintKind zonked_tv_kind - || tcEqKind zonked_ty_kind zonked_tv_kind - -- Hack alert! isConstraintKind: see TcHsType - -- Note [Extra-constraint holes in partial type signatures] - - kind_msg = hang (text "Ill-kinded update to meta tyvar") - 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) - <+> text ":=" - <+> ppr ty <+> text "::" <+> (ppr ty_kind $$ ppr zonked_ty_kind) ) - - ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) - - -- Check for double updates - ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details ) - - -- Check for level OK - -- See Note [Level check when unifying] - ; MASSERT2( level_check_ok, level_check_msg ) - - -- Check Kinds ok - ; MASSERT2( kind_check_ok, kind_msg ) - - -- Do the write - ; writeMutVar ref (Indirect ty) } - where - tv_kind = tyVarKind tyvar - ty_kind = typeKind ty - - tv_lvl = tcTyVarLevel tyvar - ty_lvl = tcTypeLevel ty - - level_check_ok = isFmvTyVar tyvar - || not (ty_lvl `strictlyDeeperThan` tv_lvl) - level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty - - double_upd_msg details = hang (text "Double update of meta tyvar") - 2 (ppr tyvar $$ ppr details) - - -{- Note [Level check when unifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When unifying - alpha:lvl := ty -we expect that the TcLevel of 'ty' will be <= lvl. -However, during unflatting we do - fuv:l := ty:(l+1) -which is usually wrong; hence the check isFmmvTyVar in level_check_ok. -See Note [TcLevel assignment] in TcType. --} - -{- -% Generating fresh variables for pattern match check --} - --- UNINSTANTIATED VERSION OF tcInstSkolTyCoVars -genInstSkolTyVarsX :: SrcSpan -> TCvSubst -> [TyVar] - -> TcRnIf gbl lcl (TCvSubst, [TcTyVar]) --- Precondition: tyvars should be scoping-ordered --- see Note [Kind substitution when instantiating] --- Get the location from the monad; this is a complete freshening operation -genInstSkolTyVarsX loc subst tvs - = instSkolTyCoVarsX (mkTcSkolTyVar topTcLevel loc False) subst tvs - -{- -************************************************************************ -* * - MetaTvs: TauTvs -* * -************************************************************************ - -Note [Never need to instantiate coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With coercion variables sloshing around in types, it might seem that we -sometimes need to instantiate coercion variables. This would be problematic, -because coercion variables inhabit unboxed equality (~#), and the constraint -solver thinks in terms only of boxed equality (~). The solution is that -we never need to instantiate coercion variables in the first place. - -The tyvars that we need to instantiate come from the types of functions, -data constructors, and patterns. These will never be quantified over -coercion variables, except for the special case of the promoted Eq#. But, -that can't ever appear in user code, so we're safe! --} - -newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar --- Make a new meta tyvar out of thin air -newAnonMetaTyVar meta_info kind - = do { uniq <- newUnique - ; let name = mkMetaTyVarName uniq s - s = case meta_info of - TauTv -> fsLit "t" - FlatMetaTv -> fsLit "fmv" - SigTv -> fsLit "a" - ; details <- newMetaDetails meta_info - ; return (mkTcTyVar name kind details) } - -newFlexiTyVar :: Kind -> TcM TcTyVar -newFlexiTyVar kind = newAnonMetaTyVar TauTv kind - -newFlexiTyVarTy :: Kind -> TcM TcType -newFlexiTyVarTy kind = do - tc_tyvar <- newFlexiTyVar kind - return (mkTyVarTy tc_tyvar) - -newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] -newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) - -newOpenTypeKind :: TcM TcKind -newOpenTypeKind - = do { rr <- newFlexiTyVarTy runtimeRepTy - ; return (tYPE rr) } - --- | Create a tyvar that can be a lifted or unlifted type. --- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh -newOpenFlexiTyVarTy :: TcM TcType -newOpenFlexiTyVarTy - = do { kind <- newOpenTypeKind - ; newFlexiTyVarTy kind } - -newMetaSigTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -newMetaSigTyVars = mapAccumLM newMetaSigTyVarX emptyTCvSubst - -newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- Instantiate with META type variables --- Note that this works for a sequence of kind, type, and coercion variables --- variables. Eg [ (k:*), (a:k->k) ] --- Gives [ (k7:*), (a8:k7->k7) ] -newMetaTyVars = mapAccumLM newMetaTyVarX emptyTCvSubst - -- emptyTCvSubst has an empty in-scope set, but that's fine here - -- Since the tyvars are freshly made, they cannot possibly be - -- captured by any existing for-alls. - -newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) --- Make a new unification variable tyvar whose Name and Kind come from --- an existing TyVar. We substitute kind variables in the kind. -newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar - -newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- Just like newMetaTyVars, but start with an existing substitution. -newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst - -newMetaSigTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) --- Just like newMetaTyVarX, but make a SigTv -newMetaSigTyVarX subst tyvar = new_meta_tv_x SigTv subst tyvar - -newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -newWildCardX subst tv - = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv)) - ; return (extendTvSubstWithClone subst tv new_tv, new_tv) } - -new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -new_meta_tv_x info subst tv - = do { uniq <- newUnique - ; details <- newMetaDetails info - ; let name = mkSystemName uniq (getOccName tv) - -- See Note [Name of an instantiated type variable] - kind = substTyUnchecked subst (tyVarKind tv) - -- NOTE: Trac #12549 is fixed so we could use - -- substTy here, but the tc_infer_args problem - -- is not yet fixed so leaving as unchecked for now. - -- OLD NOTE: - -- Unchecked because we call newMetaTyVarX from - -- tcInstBinderX, which is called from tc_infer_args - -- which does not yet take enough trouble to ensure - -- the in-scope set is right; e.g. Trac #12785 trips - -- if we use substTy here - new_tv = mkTcTyVar name kind details - subst1 = extendTvSubstWithClone subst tv new_tv - ; return (subst1, new_tv) } - -newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType -newMetaTyVarTyAtLevel tc_lvl kind - = do { uniq <- newUnique - ; ref <- newMutVar Flexi - ; let name = mkMetaTyVarName uniq (fsLit "p") - details = MetaTv { mtv_info = TauTv - , mtv_ref = ref - , mtv_tclvl = tc_lvl } - ; return (mkTyVarTy (mkTcTyVar name kind details)) } - -{- Note [Name of an instantiated type variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we give a unification variable a System Name, which -influences the way it is tidied; see TypeRep.tidyTyVarBndr. - -************************************************************************ -* * - Quantification -* * -************************************************************************ - -Note [quantifyTyVars] -~~~~~~~~~~~~~~~~~~~~~ -quantifyTyVars is given the free vars of a type that we -are about to wrap in a forall. - -It takes these free type/kind variables (partitioned into dependent and -non-dependent variables) and - 1. Zonks them and remove globals and covars - 2. Extends kvs1 with free kind vars in the kinds of tvs (removing globals) - 3. Calls zonkQuantifiedTyVar on each - -Step (2) is often unimportant, because the kind variable is often -also free in the type. Eg - Typeable k (a::k) -has free vars {k,a}. But the type (see Trac #7916) - (f::k->*) (a::k) -has free vars {f,a}, but we must add 'k' as well! Hence step (3). - -* This function distinguishes between dependent and non-dependent - variables only to keep correct defaulting behavior with -XNoPolyKinds. - With -XPolyKinds, it treats both classes of variables identically. - -* quantifyTyVars never quantifies over - - a coercion variable - - a runtime-rep variable - -Note [quantifyTyVars determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The results of quantifyTyVars are wrapped in a forall and can end up in the -interface file. One such example is inferred type signatures. They also affect -the results of optimizations, for example worker-wrapper. This means that to -get deterministic builds quantifyTyVars needs to be deterministic. - -To achieve this CandidatesQTvs is backed by deterministic sets which allows them -to be later converted to a list in a deterministic order. - -For more information about deterministic sets see -Note [Deterministic UniqFM] in UniqDFM. --} - -quantifyTyVars, quantifyZonkedTyVars - :: TcTyCoVarSet -- global tvs - -> CandidatesQTvs -- See Note [Dependent type variables] in TcType - -> TcM [TcTyVar] --- See Note [quantifyTyVars] --- Can be given a mixture of TcTyVars and TyVars, in the case of --- associated type declarations. Also accepts covars, but *never* returns any. - --- The zonked variant assumes everything is already zonked. - -quantifyTyVars gbl_tvs (DV { dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) - = do { dep_tkvs <- zonkTyCoVarsAndFVDSet dep_tkvs - ; nondep_tkvs <- zonkTyCoVarsAndFVDSet nondep_tkvs - ; gbl_tvs <- zonkTyCoVarsAndFV gbl_tvs - ; quantifyZonkedTyVars gbl_tvs (DV { dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) } - -quantifyZonkedTyVars gbl_tvs dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) - = do { traceTc "quantifyZonkedTyVars" (vcat [ppr dvs, ppr gbl_tvs]) - ; let all_cvs = filterVarSet isCoVar $ dVarSetToVarSet dep_tkvs - dep_kvs = dVarSetElemsWellScoped $ - dep_tkvs `dVarSetMinusVarSet` gbl_tvs - `dVarSetMinusVarSet` closeOverKinds all_cvs - -- dVarSetElemsWellScoped: put the kind variables into - -- well-scoped order. - -- E.g. [k, (a::k)] not the other way roud - -- closeOverKinds all_cvs: do not quantify over coercion - -- variables, or any any tvs that a covar depends on - - nondep_tvs = dVarSetElems $ - (nondep_tkvs `minusDVarSet` dep_tkvs) - `dVarSetMinusVarSet` gbl_tvs - -- See Note [Dependent type variables] in TcType - -- The `minus` dep_tkvs removes any kind-level vars - -- e.g. T k (a::k) Since k appear in a kind it'll - -- be in dv_kvs, and is dependent. So remove it from - -- dv_tvs which will also contain k - -- No worry about dependent covars here; - -- they are all in dep_tkvs - -- No worry about scoping, because these are all - -- type variables - -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV - - -- In the non-PolyKinds case, default the kind variables - -- to *, and zonk the tyvars as usual. Notice that this - -- may make quantifyTyVars return a shorter list - -- than it was passed, but that's ok - ; poly_kinds <- xoptM LangExt.PolyKinds - ; dep_kvs' <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs - ; nondep_tvs' <- mapMaybeM (zonk_quant False) nondep_tvs - -- Because of the order, any kind variables - -- mentioned in the kinds of the nondep_tvs' - -- now refer to the dep_kvs' - - ; traceTc "quantifyZonkedTyVars" - (vcat [ text "globals:" <+> ppr gbl_tvs - , text "nondep:" <+> pprTyVars nondep_tvs - , text "dep:" <+> pprTyVars dep_kvs - , text "dep_kvs'" <+> pprTyVars dep_kvs' - , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ]) - - ; return (dep_kvs' ++ nondep_tvs') } - where - zonk_quant default_kind tkv - | isTcTyVar tkv = zonkQuantifiedTyVar default_kind tkv - | otherwise = return $ Just tkv - -- For associated types, we have the class variables - -- in scope, and they are TyVars not TcTyVars - -zonkQuantifiedTyVar :: Bool -- True <=> this is a kind var and -XNoPolyKinds - -- False <=> not a kind var or -XPolyKinds - -> TcTyVar - -> TcM (Maybe TcTyVar) --- The quantified type variables often include meta type variables --- we want to freeze them into ordinary type variables, and --- default their kind (e.g. from TYPE v to TYPE Lifted) --- The meta tyvar is updated to point to the new skolem TyVar. Now any --- bound occurrences of the original type variable will get zonked to --- the immutable version. --- --- We leave skolem TyVars alone; they are immutable. --- --- This function is called on both kind and type variables, --- but kind variables *only* if PolyKinds is on. --- --- This returns a tyvar if it should be quantified over; --- otherwise, it returns Nothing. The latter case happens for --- * Kind variables, with -XNoPolyKinds: don't quantify over these --- * RuntimeRep variables: we never quantify over these - -zonkQuantifiedTyVar default_kind tv - = case tcTyVarDetails tv of - SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv) - ; return $ Just (setTyVarKind tv kind) } - -- It might be a skolem type variable, - -- for example from a user type signature - - MetaTv {} - -> do { mb_tv <- defaultTyVar default_kind tv - ; case mb_tv of - True -> return Nothing - False -> do { tv' <- skolemiseUnboundMetaTyVar tv - ; return (Just tv') } } - - _other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- FlatSkol, RuntimeUnk - -defaultTyVar :: Bool -- True <=> please default this kind variable to * - -> TcTyVar -- Always an unbound meta tyvar - -> TcM Bool -- True <=> defaulted away altogether - -defaultTyVar default_kind tv - | isRuntimeRepVar tv && not_sig_tv -- We never quantify over a RuntimeRep var - = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) - ; writeMetaTyVar tv liftedRepTy - ; return True } - - | default_kind && not_sig_tv -- -XNoPolyKinds and this is a kind var - = do { default_kind_var tv -- so default it to * if possible - ; return True } - - | otherwise - = return False - - where - -- Do not default SigTvs. Doing so would violate the invariants - -- on SigTvs; see Note [Signature skolems] in TcType. - -- Trac #13343 is an example - not_sig_tv = not (isSigTyVar tv) - - default_kind_var :: TyVar -> TcM () - -- defaultKindVar is used exclusively with -XNoPolyKinds - -- See Note [Defaulting with -XNoPolyKinds] - -- It takes an (unconstrained) meta tyvar and defaults it. - -- Works only on vars of type *; for other kinds, it issues an error. - default_kind_var kv - | isStarKind (tyVarKind kv) - = do { traceTc "Defaulting a kind var to *" (ppr kv) - ; writeMetaTyVar kv liftedTypeKind } - | otherwise - = addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') - , text "of kind:" <+> ppr (tyVarKind kv') - , text "Perhaps enable PolyKinds or add a kind signature" ]) - where - (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv - -skolemiseRuntimeUnk :: TcTyVar -> TcM TyVar -skolemiseRuntimeUnk tv - = skolemise_tv tv RuntimeUnk - -skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar -skolemiseUnboundMetaTyVar tv - = skolemise_tv tv (SkolemTv (metaTyVarTcLevel tv) False) - -skolemise_tv :: TcTyVar -> TcTyVarDetails -> 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 TyVar, not a regular TyVar --- See Note [Zonking to Skolem] -skolemise_tv tv details - = ASSERT2( isMetaTyVar tv, ppr tv ) - do { when debugIsOn (check_empty tv) - ; span <- getSrcSpanM -- Get the location from "here" - -- ie where we are generalising - ; kind <- zonkTcType (tyVarKind tv) - ; let uniq = getUnique tv - -- NB: Use same Unique as original tyvar. This is - -- important for TcHsType.splitTelescopeTvs to work properly - - tv_name = getOccName tv - final_name = mkInternalName uniq tv_name span - final_tv = mkTcTyVar final_name kind details - - ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) - ; writeMetaTyVar tv (mkTyVarTy final_tv) - ; return final_tv } - - where - check_empty tv -- [Sept 04] Check for non-empty. - = when debugIsOn $ -- See note [Silly Type Synonym] - do { cts <- readMetaTyVar tv - ; case cts of - Flexi -> return () - Indirect ty -> WARN( True, ppr tv $$ ppr ty ) - return () } - -{- Note [Defaulting with -XNoPolyKinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data Compose f g a = Mk (f (g a)) - -We infer - - Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> * - Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1). - f (g a) -> Compose k1 k2 f g a - -Now, in another module, we have -XNoPolyKinds -XDataKinds in effect. -What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds, -we just defaulted all kind variables to *. But that's no good here, -because the kind variables in 'Mk aren't of kind *, so defaulting to * -is ill-kinded. - -After some debate on #11334, we decided to issue an error in this case. -The code is in defaultKindVar. - -Note [What is a meta variable?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "meta type-variable", also know as a "unification variable" is a placeholder -introduced by the typechecker for an as-yet-unknown monotype. - -For example, when we see a call `reverse (f xs)`, we know that we calling - reverse :: forall a. [a] -> [a] -So we know that the argument `f xs` must be a "list of something". But what is -the "something"? We don't know until we explore the `f xs` a bit more. So we set -out what we do know at the call of `reverse` by instantiate its type with a fresh -meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the -result, is `[alpha]`. The unification variable `alpha` stands for the -as-yet-unknown type of the elements of the list. - -As type inference progresses we may learn more about `alpha`. For example, suppose -`f` has the type - f :: forall b. b -> [Maybe b] -Then we instantiate `f`'s type with another fresh unification variable, say -`beta`; and equate `f`'s result type with reverse's argument type, thus -`[alpha] ~ [Maybe beta]`. - -Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've -refined our knowledge about `alpha`. And so on. - -If you found this Note useful, you may also want to have a look at -Section 5 of "Practical type inference for higher rank types" (Peyton Jones, -Vytiniotis, Weirich and Shields. J. Functional Programming. 2011). - -Note [What is zonking?] -~~~~~~~~~~~~~~~~~~~~~~~ -GHC relies heavily on mutability in the typechecker for efficient operation. -For this reason, throughout much of the type checking process meta type -variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable -variables (known as TcRefs). - -Zonking is the process of ripping out these mutable variables and replacing them -with a real Type. This involves traversing the entire type expression, but the -interesting part of replacing the mutable variables occurs in zonkTyVarOcc. - -There are two ways to zonk a Type: - - * zonkTcTypeToType, which is intended to be used at the end of type-checking - for the final zonk. It has to deal with unfilled metavars, either by filling - it with a value like Any or failing (determined by the UnboundTyVarZonker - used). - - * zonkTcType, which will happily ignore unfilled metavars. This is the - appropriate function to use while in the middle of type-checking. - -Note [Zonking to Skolem] -~~~~~~~~~~~~~~~~~~~~~~~~ -We used to zonk quantified type variables to regular TyVars. However, this -leads to problems. Consider this program from the regression test suite: - - eval :: Int -> String -> String -> String - eval 0 root actual = evalRHS 0 root actual - - evalRHS :: Int -> a - evalRHS 0 root actual = eval 0 root actual - -It leads to the deferral of an equality (wrapped in an implication constraint) - - forall a. () => ((String -> String -> String) ~ a) - -which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck). -In the meantime `a' is zonked and quantified to form `evalRHS's signature. -This has the *side effect* of also zonking the `a' in the deferred equality -(which at this point is being handed around wrapped in an implication -constraint). - -Finally, the equality (with the zonked `a') will be handed back to the -simplifier by TcRnDriver.tcRnSrcDecls calling TcSimplify.tcSimplifyTop. -If we zonk `a' with a regular type variable, we will have this regular type -variable now floating around in the simplifier, which in many places assumes to -only see proper TcTyVars. - -We can avoid this problem by zonking with a skolem. The skolem is rigid -(which we require for a quantified variable), but is still a TcTyVar that the -simplifier knows how to deal with. - -Note [Silly Type Synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - type C u a = u -- Note 'a' unused - - foo :: (forall a. C u a -> C u a) -> u - foo x = ... - - bar :: Num u => u - bar = foo (\t -> t + t) - -* From the (\t -> t+t) we get type {Num d} => d -> d - where d is fresh. - -* Now unify with type of foo's arg, and we get: - {Num (C d a)} => C d a -> C d a - where a is fresh. - -* Now abstract over the 'a', but float out the Num (C d a) constraint - because it does not 'really' mention a. (see exactTyVarsOfType) - The arg to foo becomes - \/\a -> \t -> t+t - -* So we get a dict binding for Num (C d a), which is zonked to give - a = () - [Note Sept 04: now that we are zonking quantified type variables - on construction, the 'a' will be frozen as a regular tyvar on - quantification, so the floated dict will still have type (C d a). - Which renders this whole note moot; happily!] - -* Then the \/\a abstraction has a zonked 'a' in it. - -All very silly. I think its harmless to ignore the problem. We'll end up with -a \/\a in the final result but all the occurrences of a will be zonked to () - -************************************************************************ -* * - Zonking types -* * -************************************************************************ - --} - --- | @tcGetGlobalTyCoVars@ returns a fully-zonked set of *scoped* tyvars free in --- the environment. To improve subsequent calls to the same function it writes --- the zonked set back into the environment. Note that this returns all --- variables free in anything (term-level or type-level) in scope. We thus --- don't have to worry about clashes with things that are not in scope, because --- if they are reachable, then they'll be returned here. -tcGetGlobalTyCoVars :: TcM TcTyVarSet -tcGetGlobalTyCoVars - = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv - ; gbl_tvs <- readMutVar gtv_var - ; gbl_tvs' <- zonkTyCoVarsAndFV gbl_tvs - ; writeMutVar gtv_var gbl_tvs' - ; return gbl_tvs' } - --- | Zonk a type without using the smart constructors; the result type --- is available for inspection within the type-checking knot. -zonkTcTypeInKnot :: TcType -> TcM TcType -zonkTcTypeInKnot = mapType (zonkTcTypeMapper { tcm_smart = False }) () - -zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet --- Zonk a type and take its free variables --- With kind polymorphism it can be essential to zonk *first* --- so that we find the right set of free variables. Eg --- forall k1. forall (a:k2). a --- where k2:=k1 is in the substitution. We don't want --- k2 to look free in this type! --- NB: This might be called from within the knot, so don't use --- smart constructors. See Note [Zonking within the knot] in TcHsType -zonkTcTypeAndFV ty - = tyCoVarsOfTypeDSet <$> zonkTcTypeInKnot ty - --- | Zonk a type and call 'candidateQTyVarsOfType' on it. --- Works within the knot. -zonkTcTypeAndSplitDepVars :: TcType -> TcM CandidatesQTvs -zonkTcTypeAndSplitDepVars ty - = candidateQTyVarsOfType <$> zonkTcTypeInKnot ty - -zonkTcTypesAndSplitDepVars :: [TcType] -> TcM CandidatesQTvs -zonkTcTypesAndSplitDepVars tys - = candidateQTyVarsOfTypes <$> mapM zonkTcTypeInKnot tys - -zonkTyCoVar :: TyCoVar -> TcM TcType --- Works on TyVars and TcTyVars -zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv - | isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv - | otherwise = ASSERT2( isCoVar tv, ppr tv ) - mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv - -- Hackily, when typechecking type and class decls - -- we have TyVars in scopeadded (only) in - -- TcHsType.tcTyClTyVars, but it seems - -- painful to make them into TcTyVars there - -zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet -zonkTyCoVarsAndFV tycovars = - tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars) - -- It's OK to use nonDetEltsUniqSet here because we immediately forget about - -- the ordering by turning it into a nondeterministic set and the order - -- of zonking doesn't matter for determinism. - --- Takes a list of TyCoVars, zonks them and returns a --- deterministically ordered list of their free variables. -zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar] -zonkTyCoVarsAndFVList tycovars = - tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars - --- Takes a deterministic set of TyCoVars, zonks them and returns a --- deterministic set of their free variables. --- See Note [quantifyTyVars determinism]. -zonkTyCoVarsAndFVDSet :: DTyCoVarSet -> TcM DTyCoVarSet -zonkTyCoVarsAndFVDSet tycovars = - tyCoVarsOfTypesDSet <$> mapM zonkTyCoVar (dVarSetElems tycovars) - -zonkTcTyVars :: [TcTyVar] -> TcM [TcType] -zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars - ------------------ Types -zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar -zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) - ; return (setTyVarKind tv kind') } - -zonkTcTypes :: [TcType] -> TcM [TcType] -zonkTcTypes tys = mapM zonkTcType tys - -{- -************************************************************************ -* * - Zonking constraints -* * -************************************************************************ --} - -zonkImplication :: Implication -> TcM Implication -zonkImplication implic@(Implic { ic_skols = skols - , ic_given = given - , ic_wanted = wanted - , ic_info = info }) - = do { skols' <- mapM zonkTcTyCoVarBndr skols -- Need to zonk their kinds! - -- as Trac #7230 showed - ; given' <- mapM zonkEvVar given - ; info' <- zonkSkolemInfo info - ; wanted' <- zonkWCRec wanted - ; return (implic { ic_skols = skols' - , ic_given = given' - , ic_wanted = wanted' - , ic_info = info' }) } - -zonkEvVar :: EvVar -> TcM EvVar -zonkEvVar var = do { ty' <- zonkTcType (varType var) - ; return (setVarType var ty') } - - -zonkWC :: WantedConstraints -> TcM WantedConstraints -zonkWC wc = zonkWCRec wc - -zonkWCRec :: WantedConstraints -> TcM WantedConstraints -zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol }) - = do { simple' <- zonkSimples simple - ; implic' <- mapBagM zonkImplication implic - ; insol' <- zonkSimples insol - ; return (WC { wc_simple = simple', wc_impl = implic', wc_insol = insol' }) } - -zonkSimples :: Cts -> TcM Cts -zonkSimples cts = do { cts' <- mapBagM zonkCt' cts - ; traceTc "zonkSimples done:" (ppr cts') - ; return cts' } - -zonkCt' :: Ct -> TcM Ct -zonkCt' ct = zonkCt ct - -{- Note [zonkCt behaviour] -zonkCt tries to maintain the canonical form of a Ct. For example, - - a CDictCan should stay a CDictCan; - - a CTyEqCan should stay a CTyEqCan (if the LHS stays as a variable.). - - a CHoleCan should stay a CHoleCan - -Why?, for example: -- For CDictCan, the @TcSimplify.expandSuperClasses@ step, which runs after the - simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use, - constraints are zonked before being passed to the plugin. This means if we - don't preserve a canonical form, @expandSuperClasses@ fails to expand - superclasses. This is what happened in Trac #11525. - -- For CHoleCan, once we forget that it's a hole, we can never recover that info. - -NB: we do not expect to see any CFunEqCans, because zonkCt is only -called on unflattened constraints. -NB: Constraints are always re-flattened etc by the canonicaliser in -@TcCanonical@ even if they come in as CDictCan. Only canonical constraints that -are actually in the inert set carry all the guarantees. So it is okay if zonkCt -creates e.g. a CDictCan where the cc_tyars are /not/ function free. --} -zonkCt :: Ct -> TcM Ct -zonkCt ct@(CHoleCan { cc_ev = ev }) - = do { ev' <- zonkCtEvidence ev - ; return $ ct { cc_ev = ev' } } -zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args }) - = do { ev' <- zonkCtEvidence ev - ; args' <- mapM zonkTcType args - ; return $ ct { cc_ev = ev', cc_tyargs = args' } } -zonkCt ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs }) - = do { ev' <- zonkCtEvidence ev - ; tv_ty' <- zonkTcTyVar tv - ; case getTyVar_maybe tv_ty' of - Just tv' -> do { rhs' <- zonkTcType rhs - ; return ct { cc_ev = ev' - , cc_tyvar = tv' - , cc_rhs = rhs' } } - Nothing -> return (mkNonCanonical ev') } -zonkCt ct - = ASSERT( not (isCFunEqCan ct) ) - -- We do not expect to see any CFunEqCans, because zonkCt is only called on - -- unflattened constraints. - do { fl' <- zonkCtEvidence (cc_ev ct) - ; return (mkNonCanonical fl') } - -zonkCtEvidence :: CtEvidence -> TcM CtEvidence -zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) - = do { pred' <- zonkTcType pred - ; return (ctev { ctev_pred = pred'}) } -zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest }) - = do { pred' <- zonkTcType pred - ; let dest' = case dest of - EvVarDest ev -> EvVarDest $ setVarType ev pred' - -- necessary in simplifyInfer - HoleDest h -> HoleDest h - ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) } -zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) - = do { pred' <- zonkTcType pred - ; return (ctev { ctev_pred = pred' }) } - -zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo -zonkSkolemInfo (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty - ; return (SigSkol cx ty' tv_prs) } -zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys - ; return (InferSkol ntys') } - where - do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } -zonkSkolemInfo skol_info = return skol_info - -{- -%************************************************************************ -%* * -\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} -* * -* For internal use only! * -* * -************************************************************************ - --} - --- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> TcM TcId -zonkId id - = do { ty' <- zonkTcType (idType id) - ; return (Id.setIdType id ty') } - --- | A suitable TyCoMapper for zonking a type inside the knot, and --- before all metavars are filled in. -zonkTcTypeMapper :: TyCoMapper () TcM -zonkTcTypeMapper = TyCoMapper - { tcm_smart = True - , tcm_tyvar = const zonkTcTyVar - , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv) - , tcm_hole = hole - , tcm_tybinder = \_env tv _vis -> ((), ) <$> zonkTcTyCoVarBndr tv } - where - hole :: () -> CoercionHole -> Role -> Type -> Type - -> TcM Coercion - hole _ h r t1 t2 - = do { contents <- unpackCoercionHole_maybe h - ; case contents of - Just co -> do { co <- zonkCo co - ; checkCoercionHole co h r t1 t2 } - Nothing -> do { t1 <- zonkTcType t1 - ; t2 <- zonkTcType t2 - ; return $ mkHoleCo h r t1 t2 } } - - --- For unbound, mutable tyvars, zonkType uses the function given to it --- For tyvars bound at a for-all, zonkType zonks them to an immutable --- type variable and zonks the kind too -zonkTcType :: TcType -> TcM TcType -zonkTcType = mapType zonkTcTypeMapper () - --- | "Zonk" a coercion -- really, just zonk any types in the coercion -zonkCo :: Coercion -> TcM Coercion -zonkCo = mapCoercion zonkTcTypeMapper () - -zonkTcTyCoVarBndr :: TcTyCoVar -> TcM TcTyCoVar --- A tyvar binder is never a unification variable (MetaTv), --- rather it is always a skolems. BUT it may have a kind --- that has not yet been zonked, and may include kind --- unification variables. -zonkTcTyCoVarBndr tyvar - -- can't use isCoVar, because it looks at a TyCon. Argh. - = ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), pprTyVar tyvar ) - updateTyVarKindM zonkTcType tyvar - -zonkTcTyVarBinder :: TyVarBndr TcTyVar vis -> TcM (TyVarBndr TcTyVar vis) -zonkTcTyVarBinder (TvBndr tv vis) - = do { tv' <- zonkTcTyCoVarBndr tv - ; return (TvBndr tv' vis) } - -zonkTcTyVar :: TcTyVar -> TcM TcType --- Simply look through all Flexis -zonkTcTyVar tv - | isTcTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> zonk_kind_and_return - RuntimeUnk {} -> zonk_kind_and_return - FlatSkol ty -> zonkTcType ty - MetaTv { mtv_ref = ref } - -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_kind_and_return - Indirect ty -> zonkTcType ty } - - | otherwise -- coercion variable - = zonk_kind_and_return - where - zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv - ; return (mkTyVarTy z_tv) } - --- Variant that assumes that any result of zonking is still a TyVar. --- Should be used only on skolems and SigTvs -zonkTcTyVarToTyVar :: TcTyVar -> TcM TcTyVar -zonkTcTyVarToTyVar tv - = do { ty <- zonkTcTyVar tv - ; return (tcGetTyVar "zonkTcTyVarToVar" ty) } - -{- -%************************************************************************ -%* * - Tidying -* * -************************************************************************ --} - -zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) -zonkTidyTcType env ty = do { ty' <- zonkTcType ty - ; return (tidyOpenType env ty') } - --- | Make an 'ErrorThing' storing a type. -mkTypeErrorThing :: TcType -> ErrorThing -mkTypeErrorThing ty = ErrorThing ty (Just $ length $ snd $ repSplitAppTys ty) - zonkTidyTcType - -- NB: Use *rep*splitAppTys, else we get #11313 - --- | Make an 'ErrorThing' storing a type, with some extra args known about -mkTypeErrorThingArgs :: TcType -> Int -> ErrorThing -mkTypeErrorThingArgs ty num_args - = ErrorThing ty (Just $ (length $ snd $ repSplitAppTys ty) + num_args) - zonkTidyTcType - -zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) -zonkTidyOrigin env (GivenOrigin skol_info) - = do { skol_info1 <- zonkSkolemInfo skol_info - ; let skol_info2 = tidySkolemInfo env skol_info1 - ; return (env, GivenOrigin skol_info2) } -zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act - , uo_expected = exp - , uo_thing = m_thing }) - = do { (env1, act') <- zonkTidyTcType env act - ; (env2, exp') <- zonkTidyTcType env1 exp - ; (env3, m_thing') <- zonkTidyErrorThing env2 m_thing - ; return ( env3, orig { uo_actual = act' - , uo_expected = exp' - , uo_thing = m_thing' }) } -zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k) - = do { (env1, ty1') <- zonkTidyTcType env ty1 - ; (env2, m_ty2') <- case m_ty2 of - Just ty2 -> second Just <$> zonkTidyTcType env1 ty2 - Nothing -> return (env1, Nothing) - ; (env3, orig') <- zonkTidyOrigin env2 orig - ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) } -zonkTidyOrigin env (FunDepOrigin1 p1 l1 p2 l2) - = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, p2') <- zonkTidyTcType env1 p2 - ; return (env2, FunDepOrigin1 p1' l1 p2' l2) } -zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) - = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, p2') <- zonkTidyTcType env1 p2 - ; (env3, o1') <- zonkTidyOrigin env2 o1 - ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } -zonkTidyOrigin env orig = return (env, orig) - -zonkTidyErrorThing :: TidyEnv -> Maybe ErrorThing - -> TcM (TidyEnv, Maybe ErrorThing) -zonkTidyErrorThing env (Just (ErrorThing thing n_args zonker)) - = do { (env', thing') <- zonker env thing - ; return (env', Just $ ErrorThing thing' n_args zonker) } -zonkTidyErrorThing env Nothing - = return (env, Nothing) - ----------------- -tidyCt :: TidyEnv -> Ct -> Ct --- Used only in error reporting --- Also converts it to non-canonical -tidyCt env ct - = case ct of - CHoleCan { cc_ev = ev } - -> ct { cc_ev = tidy_ev env ev } - _ -> mkNonCanonical (tidy_ev env (ctEvidence ct)) - where - tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence - -- NB: we do not tidy the ctev_evar field because we don't - -- show it in error messages - tidy_ev env ctev@(CtGiven { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - tidy_ev env ctev@(CtWanted { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - tidy_ev env ctev@(CtDerived { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - ----------------- -tidyEvVar :: TidyEnv -> EvVar -> EvVar -tidyEvVar env var = setVarType var (tidyType env (varType var)) - ----------------- -tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo -tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty) -tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs -tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) -tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) -tidySkolemInfo _ info = info - -tidySigSkol :: TidyEnv -> UserTypeCtxt - -> TcType -> [(Name,TcTyVar)] -> SkolemInfo --- We need to take special care when tidying SigSkol --- See Note [SigSkol SkolemInfo] in TcRnTypes -tidySigSkol env cx ty tv_prs - = SigSkol cx (tidy_ty env ty) tv_prs' - where - tv_prs' = mapSnd (tidyTyVarOcc env) tv_prs - inst_env = mkNameEnv tv_prs' - - tidy_ty env (ForAllTy (TvBndr tv vis) ty) - = ForAllTy (TvBndr tv' vis) (tidy_ty env' ty) - where - (env', tv') = tidy_tv_bndr env tv - - tidy_ty env (FunTy arg res) - = FunTy (tidyType env arg) (tidy_ty env res) - - tidy_ty env ty = tidyType env ty - - tidy_tv_bndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) - tidy_tv_bndr env@(occ_env, subst) tv - | Just tv' <- lookupNameEnv inst_env (tyVarName tv) - = ((occ_env, extendVarEnv subst tv tv'), tv') - - | otherwise - = tidyTyCoVarBndr env tv - -------------------------------------------------------------------------- -{- -%************************************************************************ -%* * - Levity polymorphism checks -* * -************************************************************************ - -See Note [Levity polymorphism checking] in DsMonad - --} - --- | According to the rules around representation polymorphism --- (see https://ghc.haskell.org/trac/ghc/wiki/NoSubKinds), no binder --- can have a representation-polymorphic type. This check ensures --- that we respect this rule. It is a bit regrettable that this error --- occurs in zonking, after which we should have reported all errors. --- But it's hard to see where else to do it, because this can be discovered --- only after all solving is done. And, perhaps most importantly, this --- isn't really a compositional property of a type system, so it's --- not a terrible surprise that the check has to go in an awkward spot. -ensureNotLevPoly :: Type -- its zonked type - -> SDoc -- where this happened - -> TcM () -ensureNotLevPoly ty doc - = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type - -- forall a. a. See, for example, test ghci/scripts/T9140 - checkForLevPoly doc ty - - -- See Note [Levity polymorphism checking] in DsMonad -checkForLevPoly :: SDoc -> Type -> TcM () -checkForLevPoly = checkForLevPolyX addErr - -checkForLevPolyX :: Monad m - => (SDoc -> m ()) -- how to report an error - -> SDoc -> Type -> m () -checkForLevPolyX add_err extra ty - | isTypeLevPoly ty - = add_err (formatLevPolyErr ty $$ extra) - | otherwise - = return () - -formatLevPolyErr :: Type -- levity-polymorphic type - -> SDoc -formatLevPolyErr ty - = hang (text "A levity-polymorphic type is not allowed here:") - 2 (vcat [ text "Type:" <+> ppr tidy_ty - , text "Kind:" <+> ppr tidy_ki ]) - where - (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty - tidy_ki = tidyType tidy_env (typeKind ty) diff --git a/typecheck/TcMatches.hs b/typecheck/TcMatches.hs deleted file mode 100644 --- a/typecheck/TcMatches.hs +++ /dev/null @@ -1,1135 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcMatches: Typecheck some @Matches@ --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} - -module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, - TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, - tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, - tcDoStmt, tcGuardStmt - ) where - -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma - , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) - -import BasicTypes (LexicalFixity(..)) -import HsSyn -import TcRnMonad -import TcEnv -import TcPat -import TcMType -import TcType -import TcBinds -import TcUnify -import Name -import TysWiredIn -import Id -import TyCon -import TysPrim -import TcEvidence -import Outputable -import Util -import SrcLoc -import DynFlags -import PrelNames (monadFailClassName) -import qualified GHC.LanguageExtensions as LangExt - --- Create chunkified tuple tybes for monad comprehensions -import MkCore - -import Control.Monad -import Control.Arrow ( second ) - -#include "HsVersions.h" - -{- -************************************************************************ -* * -\subsection{tcMatchesFun, tcMatchesCase} -* * -************************************************************************ - -@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a -@FunMonoBind@. The second argument is the name of the function, which -is used in error messages. It checks that all the equations have the -same number of arguments before using @tcMatches@ to do the work. - -Note [Polymorphic expected type for tcMatchesFun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcMatchesFun may be given a *sigma* (polymorphic) type -so it must be prepared to use tcSkolemise to skolemise it. -See Note [sig_tau may be polymorphic] in TcPat. --} - -tcMatchesFun :: Located Name - -> MatchGroup Name (LHsExpr Name) - -> ExpRhoType -- Expected type of function - -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) - -- Returns type of body -tcMatchesFun fn@(L _ fun_name) matches exp_ty - = do { -- Check that they all have the same no of arguments - -- Location is in the monad, set the caller so that - -- any inter-equation error messages get some vaguely - -- sensible location. Note: we have to do this odd - -- ann-grabbing, because we don't always have annotations in - -- hand when we call tcMatchesFun... - traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) - ; checkArgs fun_name matches - - ; (wrap_gen, (wrap_fun, group)) - <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho -> - -- Note [Polymorphic expected type for tcMatchesFun] - do { (matches', wrap_fun) - <- matchExpectedFunTys herald arity exp_rho $ - \ pat_tys rhs_ty -> - tcMatches match_ctxt pat_tys rhs_ty matches - ; return (wrap_fun, matches') } - ; return (wrap_gen <.> wrap_fun, group) } - where - arity = matchGroupArity matches - herald = text "The equation(s) for" - <+> quotes (ppr fun_name) <+> text "have" - match_ctxt = MC { mc_what = FunRhs fn Prefix strictness, mc_body = tcBody } - strictness - | [L _ match] <- unLoc $ mg_alts matches - , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match - = SrcStrict - | otherwise - = NoSrcStrict - -{- -@tcMatchesCase@ doesn't do the argument-count check because the -parser guarantees that each equation has exactly one argument. --} - -tcMatchesCase :: (Outputable (body Name)) => - TcMatchCtxt body -- Case context - -> TcSigmaType -- Type of scrutinee - -> MatchGroup Name (Located (body Name)) -- The case alternatives - -> ExpRhoType -- Type of whole case expressions - -> TcM (MatchGroup TcId (Located (body TcId))) - -- Translated alternatives - -- wrapper goes from MatchGroup's ty to expected ty - -tcMatchesCase ctxt scrut_ty matches res_ty - = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches - -tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify - -> TcMatchCtxt HsExpr - -> MatchGroup Name (LHsExpr Name) - -> ExpRhoType -- deeply skolemised - -> TcM (MatchGroup TcId (LHsExpr TcId), HsWrapper) -tcMatchLambda herald match_ctxt match res_ty - = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty -> - tcMatches match_ctxt pat_tys rhs_ty match - where - n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case - | otherwise = matchGroupArity match - --- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. - -tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType - -> TcM (GRHSs TcId (LHsExpr TcId)) --- Used for pattern bindings -tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty) - where - match_ctxt = MC { mc_what = PatBindRhs, - mc_body = tcBody } - -{- -************************************************************************ -* * -\subsection{tcMatch} -* * -************************************************************************ - -Note [Case branches must never infer a non-tau type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - case ... of - ... -> \(x :: forall a. a -> a) -> x - ... -> \y -> y - -Should that type-check? The problem is that, if we check the second branch -first, then we'll get a type (b -> b) for the branches, which won't unify -with the polytype in the first branch. If we check the first branch first, -then everything is OK. This order-dependency is terrible. So we want only -proper tau-types in branches (unless a sigma-type is pushed down). -This is what expTypeToType ensures: it replaces an Infer with a fresh -tau-type. - -An even trickier case looks like - - f x True = x undefined - f x False = x () - -Here, we see that the arguments must also be non-Infer. Thus, we must -use expTypeToType on the output of matchExpectedFunTys, not the input. - -But we make a special case for a one-branch case. This is so that - - f = \(x :: forall a. a -> a) -> x - -still gets assigned a polytype. --} - --- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the --- expected type into TauTvs. --- See Note [Case branches must never infer a non-tau type] -tauifyMultipleMatches :: [LMatch id body] - -> [ExpType] -> TcM [ExpType] -tauifyMultipleMatches group exp_tys - | isSingletonMatchGroup group = return exp_tys - | otherwise = mapM tauifyExpType exp_tys - -- NB: In the empty-match case, this ensures we fill in the ExpType - --- | Type-check a MatchGroup. -tcMatches :: (Outputable (body Name)) => TcMatchCtxt body - -> [ExpSigmaType] -- Expected pattern types - -> ExpRhoType -- Expected result-type of the Match. - -> MatchGroup Name (Located (body Name)) - -> TcM (MatchGroup TcId (Located (body TcId))) - -data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module - = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is - mc_body :: Located (body Name) -- Type checker for a body of - -- an alternative - -> ExpRhoType - -> TcM (Located (body TcId)) } - -tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches - , mg_origin = origin }) - = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys) - -- See Note [Case branches must never infer a non-tau type] - - ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches - ; pat_tys <- mapM readExpType pat_tys - ; rhs_ty <- readExpType rhs_ty - ; return (MG { mg_alts = L l matches' - , mg_arg_tys = pat_tys - , mg_res_ty = rhs_ty - , mg_origin = origin }) } - -------------- -tcMatch :: (Outputable (body Name)) => TcMatchCtxt body - -> [ExpSigmaType] -- Expected pattern types - -> ExpRhoType -- Expected result-type of the Match. - -> LMatch Name (Located (body Name)) - -> TcM (LMatch TcId (Located (body TcId))) - -tcMatch ctxt pat_tys rhs_ty match - = wrapLocM (tc_match ctxt pat_tys rhs_ty) match - where - tc_match ctxt pat_tys rhs_ty match@(Match _ pats maybe_rhs_sig grhss) - = add_match_ctxt match $ - do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ - tc_grhss ctxt maybe_rhs_sig grhss rhs_ty - ; return (Match (mc_what ctxt) pats' Nothing grhss') } - - tc_grhss ctxt Nothing grhss rhs_ty - = tcGRHSs ctxt grhss rhs_ty -- No result signature - - -- Result type sigs are no longer supported - tc_grhss _ (Just {}) _ _ - = panic "tc_ghrss" -- Rejected by renamer - - -- For (\x -> e), tcExpr has already said "In the expression \x->e" - -- so we don't want to add "In the lambda abstraction \x->e" - add_match_ctxt match thing_inside - = case mc_what ctxt of - LambdaExpr -> thing_inside - _ -> addErrCtxt (pprMatchInCtxt match) thing_inside - -------------- -tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> ExpRhoType - -> TcM (GRHSs TcId (Located (body TcId))) - --- Notice that we pass in the full res_ty, so that we get --- good inference from simple things like --- f = \(x::forall a.a->a) -> --- We used to force it to be a monotype when there was more than one guard --- but we don't need to do that any more - -tcGRHSs ctxt (GRHSs grhss (L l binds)) res_ty - = do { (binds', grhss') - <- tcLocalBinds binds $ - mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss - - ; return (GRHSs grhss' (L l binds')) } - -------------- -tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS Name (Located (body Name)) - -> TcM (GRHS TcId (Located (body TcId))) - -tcGRHS ctxt res_ty (GRHS guards rhs) - = do { (guards', rhs') - <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ - mc_body ctxt rhs - ; return (GRHS guards' rhs') } - where - stmt_ctxt = PatGuard (mc_what ctxt) - -{- -************************************************************************ -* * -\subsection{@tcDoStmts@ typechecks a {\em list} of do statements} -* * -************************************************************************ --} - -tcDoStmts :: HsStmtContext Name - -> Located [LStmt Name (LHsExpr Name)] - -> ExpRhoType - -> TcM (HsExpr TcId) -- Returns a HsDo -tcDoStmts ListComp (L l stmts) res_ty - = do { res_ty <- expTypeToType res_ty - ; (co, elt_ty) <- matchExpectedListTy res_ty - ; let list_ty = mkListTy elt_ty - ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts - (mkCheckExpType elt_ty) - ; return $ mkHsWrapCo co (HsDo ListComp (L l stmts') list_ty) } - -tcDoStmts PArrComp (L l stmts) res_ty - = do { res_ty <- expTypeToType res_ty - ; (co, elt_ty) <- matchExpectedPArrTy res_ty - ; let parr_ty = mkPArrTy elt_ty - ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts - (mkCheckExpType elt_ty) - ; return $ mkHsWrapCo co (HsDo PArrComp (L l stmts') parr_ty) } - -tcDoStmts DoExpr (L l stmts) res_ty - = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo DoExpr (L l stmts') res_ty) } - -tcDoStmts MDoExpr (L l stmts) res_ty - = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo MDoExpr (L l stmts') res_ty) } - -tcDoStmts MonadComp (L l stmts) res_ty - = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo MonadComp (L l stmts') res_ty) } - -tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) - -tcBody :: LHsExpr Name -> ExpRhoType -> TcM (LHsExpr TcId) -tcBody body res_ty - = do { traceTc "tcBody" (ppr res_ty) - ; tcMonoExpr body res_ty - } - -{- -************************************************************************ -* * -\subsection{tcStmts} -* * -************************************************************************ --} - -type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType -type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType - -type TcStmtChecker body rho_type - = forall thing. HsStmtContext Name - -> Stmt Name (Located (body Name)) - -> rho_type -- Result type for comprehension - -> (rho_type -> TcM thing) -- Checker for what follows the stmt - -> TcM (Stmt TcId (Located (body TcId)), thing) - -tcStmts :: (Outputable (body Name)) => HsStmtContext Name - -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt Name (Located (body Name))] - -> rho_type - -> TcM [LStmt TcId (Located (body TcId))] -tcStmts ctxt stmt_chk stmts res_ty - = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ - const (return ()) - ; return stmts' } - -tcStmtsAndThen :: (Outputable (body Name)) => HsStmtContext Name - -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt Name (Located (body Name))] - -> rho_type - -> (rho_type -> TcM thing) - -> TcM ([LStmt TcId (Located (body TcId))], thing) - --- Note the higher-rank type. stmt_chk is applied at different --- types in the equations for tcStmts - -tcStmtsAndThen _ _ [] res_ty thing_inside - = do { thing <- thing_inside res_ty - ; return ([], thing) } - --- LetStmts are handled uniformly, regardless of context -tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt (L l binds)) : stmts) - res_ty thing_inside - = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ - tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside - ; return (L loc (LetStmt (L l binds')) : stmts', thing) } - --- Don't set the error context for an ApplicativeStmt. It ought to be --- possible to do this with a popErrCtxt in the tcStmt case for --- ApplicativeStmt, but it did someting strange and broke a test (ado002). -tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside - | ApplicativeStmt{} <- stmt - = do { (stmt', (stmts', thing)) <- - stmt_chk ctxt stmt res_ty $ \ res_ty' -> - tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ - thing_inside - ; return (L loc stmt' : stmts', thing) } - - -- For the vanilla case, handle the location-setting part - | otherwise - = do { (stmt', (stmts', thing)) <- - setSrcSpan loc $ - addErrCtxt (pprStmtInCtxt ctxt stmt) $ - stmt_chk ctxt stmt res_ty $ \ res_ty' -> - popErrCtxt $ - tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ - thing_inside - ; return (L loc stmt' : stmts', thing) } - ---------------------------------------------------- --- Pattern guards ---------------------------------------------------- - -tcGuardStmt :: TcExprStmtChecker -tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside - = do { guard' <- tcMonoExpr guard (mkCheckExpType boolTy) - ; thing <- thing_inside res_ty - ; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) } - -tcGuardStmt ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside - = do { (rhs', rhs_ty) <- tcInferSigmaNC rhs - -- Stmt has a context already - ; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) - pat (mkCheckExpType rhs_ty) $ - thing_inside res_ty - ; return (mkTcBindStmt pat' rhs', thing) } - -tcGuardStmt _ stmt _ _ - = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- List comprehensions and PArrays --- (no rebindable syntax) ---------------------------------------------------- - --- Dealt with separately, rather than by tcMcStmt, because --- a) PArr isn't (yet) an instance of Monad, so the generality seems overkill --- b) We have special desugaring rules for list comprehensions, --- which avoid creating intermediate lists. They in turn --- assume that the bind/return operations are the regular --- polymorphic ones, and in particular don't have any --- coercion matching stuff in them. It's hard to avoid the --- potential for non-trivial coercions in tcMcStmt - -tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) - -> TcExprStmtChecker - -tcLcStmt _ _ (LastStmt body noret _) elt_ty thing_inside - = do { body' <- tcMonoExprNC body elt_ty - ; thing <- thing_inside (panic "tcLcStmt: thing_inside") - ; return (LastStmt body' noret noSyntaxExpr, thing) } - --- A generator, pat <- rhs -tcLcStmt m_tc ctxt (BindStmt pat rhs _ _ _) elt_ty thing_inside - = do { pat_ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty]) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - thing_inside elt_ty - ; return (mkTcBindStmt pat' rhs', thing) } - --- A boolean guard -tcLcStmt _ _ (BodyStmt rhs _ _ _) elt_ty thing_inside - = do { rhs' <- tcMonoExpr rhs (mkCheckExpType boolTy) - ; thing <- thing_inside elt_ty - ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } - --- ParStmt: See notes with tcMcStmt -tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside - = do { (pairs', thing) <- loop bndr_stmts_s - ; return (ParStmt pairs' noExpr noSyntaxExpr unitTy, thing) } - where - -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing) - loop [] = do { thing <- thing_inside elt_ty - ; return ([], thing) } -- matching in the branches - - loop (ParStmtBlock stmts names _ : pairs) - = do { (stmts', (ids, pairs', thing)) - <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> - do { ids <- tcLookupLocalIds names - ; (pairs', thing) <- loop pairs - ; return (ids, pairs', thing) } - ; return ( ParStmtBlock stmts' ids noSyntaxExpr : pairs', thing ) } - -tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts - , trS_bndrs = bindersMap - , trS_by = by, trS_using = using }) elt_ty thing_inside - = do { let (bndr_names, n_bndr_names) = unzip bindersMap - unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) - -- The inner 'stmts' lack a LastStmt, so the element type - -- passed in to tcStmtsAndThen is never looked at - ; (stmts', (bndr_ids, by')) - <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do - { by' <- traverse tcInferSigma by - ; bndr_ids <- tcLookupLocalIds bndr_names - ; return (bndr_ids, by') } - - ; let m_app ty = mkTyConApp m_tc [ty] - - --------------- Typecheck the 'using' function ------------- - -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm) - -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm) - - -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm - ; let n_app = case form of - ThenForm -> (\ty -> ty) - _ -> m_app - - by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present - by_arrow = case by' of - Nothing -> \ty -> ty - Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty - - tup_ty = mkBigCoreVarTupTy bndr_ids - poly_arg_ty = m_app alphaTy - poly_res_ty = m_app (n_app alphaTy) - using_poly_ty = mkInvForAllTy alphaTyVar $ - by_arrow $ - poly_arg_ty `mkFunTy` poly_res_ty - - ; using' <- tcPolyExpr using using_poly_ty - ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' - - -- 'stmts' returns a result of type (m1_ty tuple_ty), - -- typically something like [(Int,Bool,Int)] - -- We don't know what tuple_ty is yet, so we use a variable - ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id)) - - -- Ensure that every old binder of type `b` is linked up with its - -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in HsExpr - n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids - bindersMap' = bndr_ids `zip` n_bndr_ids - - -- Type check the thing in the environment with - -- these new binders and return the result - ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty) - - ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' - , trS_by = fmap fst by', trS_using = final_using - , trS_ret = noSyntaxExpr - , trS_bind = noSyntaxExpr - , trS_fmap = noExpr - , trS_bind_arg_ty = unitTy - , trS_form = form }, thing) } - -tcLcStmt _ _ stmt _ _ - = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- Monad comprehensions --- (supports rebindable syntax) ---------------------------------------------------- - -tcMcStmt :: TcExprStmtChecker - -tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside - = do { (body', return_op') - <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $ - \ [a_ty] -> - tcMonoExprNC body (mkCheckExpType a_ty) - ; thing <- thing_inside (panic "tcMcStmt: thing_inside") - ; return (LastStmt body' noret return_op', thing) } - --- Generators for monad comprehensions ( pat <- rhs ) --- --- [ body | q <- gen ] -> gen :: m a --- q :: a --- - -tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside - -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - = do { ((rhs', pat', thing, new_res_ty), bind_op') - <- tcSyntaxOp MCompOrigin bind_op - [SynRho, SynFun SynAny SynRho] res_ty $ - \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat - (mkCheckExpType pat_ty) $ - thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat', thing, new_res_ty) } - - -- If (but only if) the pattern can fail, typecheck the 'fail' operator - ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty - - ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) } - --- Boolean expressions. --- --- [ body | stmts, expr ] -> expr :: m Bool --- -tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside - = do { -- Deal with rebindable syntax: - -- guard_op :: test_ty -> rhs_ty - -- then_op :: rhs_ty -> new_res_ty -> res_ty - -- Where test_ty is, for example, Bool - ; ((thing, rhs', rhs_ty, guard_op'), then_op') - <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $ - \ [rhs_ty, new_res_ty] -> - do { (rhs', guard_op') - <- tcSyntaxOp MCompOrigin guard_op [SynAny] - (mkCheckExpType rhs_ty) $ - \ [test_ty] -> - tcMonoExpr rhs (mkCheckExpType test_ty) - ; thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (thing, rhs', rhs_ty, guard_op') } - ; return (BodyStmt rhs' then_op' guard_op' rhs_ty, thing) } - --- Grouping statements --- --- [ body | stmts, then group by e using f ] --- -> e :: t --- f :: forall a. (a -> t) -> m a -> m (m a) --- [ body | stmts, then group using f ] --- -> f :: forall a. m a -> m (m a) - --- We type [ body | (stmts, group by e using f), ... ] --- f [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body.... --- --- We type the functions as follows: --- f :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm) --- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm) --- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm) --- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm) --- -tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap - , trS_by = by, trS_using = using, trS_form = form - , trS_ret = return_op, trS_bind = bind_op - , trS_fmap = fmap_op }) res_ty thing_inside - = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind - ; m1_ty <- newFlexiTyVarTy star_star_kind - ; m2_ty <- newFlexiTyVarTy star_star_kind - ; tup_ty <- newFlexiTyVarTy liftedTypeKind - ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) - - -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm - ; n_app <- case form of - ThenForm -> return (\ty -> ty) - _ -> do { n_ty <- newFlexiTyVarTy star_star_kind - ; return (n_ty `mkAppTy`) } - ; let by_arrow :: Type -> Type - -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present) - -- or res ('by' absent) - by_arrow = case by of - Nothing -> \res -> res - Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res - - poly_arg_ty = m1_ty `mkAppTy` alphaTy - using_arg_ty = m1_ty `mkAppTy` tup_ty - poly_res_ty = m2_ty `mkAppTy` n_app alphaTy - using_res_ty = m2_ty `mkAppTy` n_app tup_ty - using_poly_ty = mkInvForAllTy alphaTyVar $ - by_arrow $ - poly_arg_ty `mkFunTy` poly_res_ty - - -- 'stmts' returns a result of type (m1_ty tuple_ty), - -- typically something like [(Int,Bool,Int)] - -- We don't know what tuple_ty is yet, so we use a variable - ; let (bndr_names, n_bndr_names) = unzip bindersMap - ; (stmts', (bndr_ids, by', return_op')) <- - tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts - (mkCheckExpType using_arg_ty) $ \res_ty' -> do - { by' <- case by of - Nothing -> return Nothing - Just e -> do { e' <- tcMonoExpr e - (mkCheckExpType by_e_ty) - ; return (Just e') } - - -- Find the Ids (and hence types) of all old binders - ; bndr_ids <- tcLookupLocalIds bndr_names - - -- 'return' is only used for the binders, so we know its type. - -- return :: (a,b,c,..) -> m (a,b,c,..) - ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op - [synKnownType (mkBigCoreVarTupTy bndr_ids)] - res_ty' $ \ _ -> return () - - ; return (bndr_ids, by', return_op') } - - --------------- Typecheck the 'bind' function ------------- - -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty - ; new_res_ty <- newFlexiTyVarTy liftedTypeKind - ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op - [ synKnownType using_res_ty - , synKnownType (n_app tup_ty `mkFunTy` new_res_ty) ] - res_ty $ \ _ -> return () - - --------------- Typecheck the 'fmap' function ------------- - ; fmap_op' <- case form of - ThenForm -> return noExpr - _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ - mkInvForAllTy alphaTyVar $ - mkInvForAllTy betaTyVar $ - (alphaTy `mkFunTy` betaTy) - `mkFunTy` (n_app alphaTy) - `mkFunTy` (n_app betaTy) - - --------------- Typecheck the 'using' function ------------- - -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) - - ; using' <- tcPolyExpr using using_poly_ty - ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' - - --------------- Bulding the bindersMap ---------------- - ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id)) - - -- Ensure that every old binder of type `b` is linked up with its - -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in HsExpr - n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids - bindersMap' = bndr_ids `zip` n_bndr_ids - - -- Type check the thing in the environment with - -- these new binders and return the result - ; thing <- tcExtendIdEnv n_bndr_ids $ - thing_inside (mkCheckExpType new_res_ty) - - ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' - , trS_by = by', trS_using = final_using - , trS_ret = return_op', trS_bind = bind_op' - , trS_bind_arg_ty = n_app tup_ty - , trS_fmap = fmap_op', trS_form = form }, thing) } - --- A parallel set of comprehensions --- [ (g x, h x) | ... ; let g v = ... --- | ... ; let h v = ... ] --- --- It's possible that g,h are overloaded, so we need to feed the LIE from the --- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods). --- Similarly if we had an existential pattern match: --- --- data T = forall a. Show a => C a --- --- [ (show x, show y) | ... ; C x <- ... --- | ... ; C y <- ... ] --- --- Then we need the LIE from (show x, show y) to be simplified against --- the bindings for x and y. --- --- It's difficult to do this in parallel, so we rely on the renamer to --- ensure that g,h and x,y don't duplicate, and simply grow the environment. --- So the binders of the first parallel group will be in scope in the second --- group. But that's fine; there's no shadowing to worry about. --- --- Note: The `mzip` function will get typechecked via: --- --- ParStmt [st1::t1, st2::t2, st3::t3] --- --- mzip :: m st1 --- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call --- -> m (st1, (st2, st3)) --- -tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside - = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind - ; m_ty <- newFlexiTyVarTy star_star_kind - - ; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $ - (m_ty `mkAppTy` alphaTy) - `mkFunTy` - (m_ty `mkAppTy` betaTy) - `mkFunTy` - (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) - ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty - - -- type dummies since we don't know all binder types yet - ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) - [ names | ParStmtBlock _ names _ <- bndr_stmts_s ] - - -- Typecheck bind: - ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ] - tuple_ty = mk_tuple_ty tup_tys - - ; (((blocks', thing), inner_res_ty), bind_op') - <- tcSyntaxOp MCompOrigin bind_op - [ synKnownType (m_ty `mkAppTy` tuple_ty) - , SynFun (synKnownType tuple_ty) SynRho ] res_ty $ - \ [inner_res_ty] -> - do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) - tup_tys bndr_stmts_s - ; return (stuff, inner_res_ty) } - - ; return (ParStmt blocks' mzip_op' bind_op' inner_res_ty, thing) } - - where - mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys - - -- loop :: Type -- m_ty - -- -> ExpRhoType -- inner_res_ty - -- -> [TcType] -- tup_tys - -- -> [ParStmtBlock Name] - -- -> TcM ([([LStmt TcId], [TcId])], thing) - loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty - ; return ([], thing) } - -- matching in the branches - - loop m_ty inner_res_ty (tup_ty_in : tup_tys_in) - (ParStmtBlock stmts names return_op : pairs) - = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in - ; (stmts', (ids, return_op', pairs', thing)) - <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $ - \m_tup_ty' -> - do { ids <- tcLookupLocalIds names - ; let tup_ty = mkBigCoreVarTupTy ids - ; (_, return_op') <- - tcSyntaxOp MCompOrigin return_op - [synKnownType tup_ty] m_tup_ty' $ - \ _ -> return () - ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs - ; return (ids, return_op', pairs', thing) } - ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) } - loop _ _ _ _ = panic "tcMcStmt.loop" - -tcMcStmt _ stmt _ _ - = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- Do-notation --- (supports rebindable syntax) ---------------------------------------------------- - -tcDoStmt :: TcExprStmtChecker - -tcDoStmt _ (LastStmt body noret _) res_ty thing_inside - = do { body' <- tcMonoExprNC body res_ty - ; thing <- thing_inside (panic "tcDoStmt: thing_inside") - ; return (LastStmt body' noret noSyntaxExpr, thing) } - -tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside - = do { -- Deal with rebindable syntax: - -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - -- This level of generality is needed for using do-notation - -- in full generality; see Trac #1537 - - ((rhs', pat', new_res_ty, thing), bind_op') - <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $ - \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat - (mkCheckExpType pat_ty) $ - thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat', new_res_ty, thing) } - - -- If (but only if) the pattern can fail, typecheck the 'fail' operator - ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty - - ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) } - -tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside - = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $ - thing_inside . mkCheckExpType - ; ((pairs', body_ty, thing), mb_join') <- case mb_join of - Nothing -> (, Nothing) <$> tc_app_stmts res_ty - Just join_op -> - second Just <$> - (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ - \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty)) - - ; return (ApplicativeStmt pairs' mb_join' body_ty, thing) } - -tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside - = do { -- Deal with rebindable syntax; - -- (>>) :: rhs_ty -> new_res_ty -> res_ty - ; ((rhs', rhs_ty, thing), then_op') - <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ - \ [rhs_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', rhs_ty, thing) } - ; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) } - -tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names - , recS_rec_ids = rec_names, recS_ret_fn = ret_op - , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) - res_ty thing_inside - = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names - ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys - tup_ty = mkBigCoreTupTy tup_elt_tys - - ; tcExtendIdEnv tup_ids $ do - { ((stmts', (ret_op', tup_rets)), stmts_ty) - <- tcInferInst $ \ exp_ty -> - tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty -> - do { tup_rets <- zipWithM tcCheckId tup_names - (map mkCheckExpType tup_elt_tys) - -- Unify the types of the "final" Ids (which may - -- be polymorphic) with those of "knot-tied" Ids - ; (_, ret_op') - <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty] - inner_res_ty $ \_ -> return () - ; return (ret_op', tup_rets) } - - ; ((_, mfix_op'), mfix_res_ty) - <- tcInferInst $ \ exp_ty -> - tcSyntaxOp DoOrigin mfix_op - [synKnownType (mkFunTy tup_ty stmts_ty)] exp_ty $ - \ _ -> return () - - ; ((thing, new_res_ty), bind_op') - <- tcSyntaxOp DoOrigin bind_op - [ synKnownType mfix_res_ty - , synKnownType tup_ty `SynFun` SynRho ] - res_ty $ - \ [new_res_ty] -> - do { thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (thing, new_res_ty) } - - ; let rec_ids = takeList rec_names tup_ids - ; later_ids <- tcLookupLocalIds later_names - ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids), - ppr later_ids <+> ppr (map idType later_ids)] - ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' - , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' - , recS_bind_ty = new_res_ty - , recS_later_rets = [], recS_rec_rets = tup_rets - , recS_ret_ty = stmts_ty }, thing) - }} - -tcDoStmt _ stmt _ _ - = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) - - - ---------------------------------------------------- --- MonadFail Proposal warnings ---------------------------------------------------- - --- The idea behind issuing MonadFail warnings is that we add them whenever a --- failable pattern is encountered. However, instead of throwing a type error --- when the constraint cannot be satisfied, we only issue a warning in --- TcErrors.hs. - -tcMonadFailOp :: CtOrigin - -> LPat TcId - -> SyntaxExpr Name -- The fail op - -> TcType -- Type of the whole do-expression - -> TcRn (SyntaxExpr TcId) -- Typechecked fail op --- Get a 'fail' operator expression, to use if the pattern --- match fails. If the pattern is irrefutatable, just return --- noSyntaxExpr; it won't be used -tcMonadFailOp orig pat fail_op res_ty - | isIrrefutableHsPat pat - = return noSyntaxExpr - - | otherwise - = do { -- Issue MonadFail warnings - rebindableSyntax <- xoptM LangExt.RebindableSyntax - ; desugarFlag <- xoptM LangExt.MonadFailDesugaring - ; missingWarning <- woptM Opt_WarnMissingMonadFailInstances - ; if | rebindableSyntax && (desugarFlag || missingWarning) - -> warnRebindableClash pat - | not desugarFlag && missingWarning - -> emitMonadFailConstraint pat res_ty - | otherwise - -> return () - - -- Get the fail op itself - ; snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] - (mkCheckExpType res_ty) $ \_ -> return ()) } - -emitMonadFailConstraint :: LPat TcId -> TcType -> TcRn () -emitMonadFailConstraint pat res_ty - = do { -- We expect res_ty to be of form (monad_ty arg_ty) - (_co, (monad_ty, _arg_ty)) <- matchExpectedAppTy res_ty - - -- Emit (MonadFail m), but ignore the evidence; it's - -- just there to generate a warning - ; monadFailClass <- tcLookupClass monadFailClassName - ; _ <- emitWanted (FailablePattern pat) - (mkClassPred monadFailClass [monad_ty]) - ; return () } - -warnRebindableClash :: LPat TcId -> TcRn () -warnRebindableClash pattern = addWarnAt - (Reason Opt_WarnMissingMonadFailInstances) - (getLoc pattern) - (text "The failable pattern" <+> quotes (ppr pattern) - $$ - nest 2 (text "is used together with -XRebindableSyntax." - <+> text "If this is intentional," - $$ - text "compile with -Wno-missing-monadfail-instances.")) - -{- -Note [Treat rebindable syntax first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking - do { bar; ... } :: IO () -we want to typecheck 'bar' in the knowledge that it should be an IO thing, -pushing info from the context into the RHS. To do this, we check the -rebindable syntax first, and push that information into (tcMonoExprNC rhs). -Otherwise the error shows up when cheking the rebindable syntax, and -the expected/inferred stuff is back to front (see Trac #3613). - -Note [typechecking ApplicativeStmt] - -join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en) - -fresh type variables: - pat_ty_1..pat_ty_n - exp_ty_1..exp_ty_n - t_1..t_(n-1) - -body :: body_ty -(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty -pat_i :: pat_ty_i -e_i :: exp_ty_i -<$> :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1 -<*>_i :: t_(i-1) -> exp_ty_i -> t_i -join :: tn -> res_ty --} - -tcApplicativeStmts - :: HsStmtContext Name - -> [(SyntaxExpr Name, ApplicativeArg Name Name)] - -> ExpRhoType -- rhs_ty - -> (TcRhoType -> TcM t) -- thing_inside - -> TcM ([(SyntaxExpr TcId, ApplicativeArg TcId TcId)], Type, t) - -tcApplicativeStmts ctxt pairs rhs_ty thing_inside - = do { body_ty <- newFlexiTyVarTy liftedTypeKind - ; let arity = length pairs - ; ts <- replicateM (arity-1) $ newInferExpTypeInst - ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind - ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind - ; let fun_ty = mkFunTys pat_tys body_ty - - -- NB. do the <$>,<*> operators first, we don't want type errors here - -- i.e. goOps before goArgs - -- See Note [Treat rebindable syntax first] - ; let (ops, args) = unzip pairs - ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys) - - -- Typecheck each ApplicativeArg separately - -- See Note [ApplicativeDo and constraints] - ; args' <- mapM goArg (zip3 args pat_tys exp_tys) - - -- Bring into scope all the things bound by the args, - -- and typecheck the thing_inside - -- See Note [ApplicativeDo and constraints] - ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $ - thing_inside body_ty - - ; return (zip ops' args', body_ty, res) } - where - goOps _ [] = return [] - goOps t_left ((op,t_i,exp_ty) : ops) - = do { (_, op') - <- tcSyntaxOp DoOrigin op - [synKnownType t_left, synKnownType exp_ty] t_i $ - \ _ -> return () - ; t_i <- readExpType t_i - ; ops' <- goOps t_i ops - ; return (op' : ops') } - - goArg :: (ApplicativeArg Name Name, Type, Type) - -> TcM (ApplicativeArg TcId TcId) - - goArg (ApplicativeArgOne pat rhs, pat_ty, exp_ty) - = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ - addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $ - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty) - ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - return () - ; return (ApplicativeArgOne pat' rhs') } - - goArg (ApplicativeArgMany stmts ret pat, pat_ty, exp_ty) - = do { (stmts', (ret',pat')) <- - tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ - \res_ty -> do - { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty - ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - return () - ; return (ret', pat') - } - ; return (ApplicativeArgMany stmts' ret' pat') } - - get_arg_bndrs :: ApplicativeArg TcId TcId -> [Id] - get_arg_bndrs (ApplicativeArgOne pat _) = collectPatBinders pat - get_arg_bndrs (ApplicativeArgMany _ _ pat) = collectPatBinders pat - - -{- Note [ApplicativeDo and constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An applicative-do is supposed to take place in parallel, so -constraints bound in one arm can't possibly be available in another -(Trac #13242). Our current rule is this (more details and discussion -on the ticket). Consider - - ...stmts... - ApplicativeStmts [arg1, arg2, ... argN] - ...more stmts... - -where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts. -Now, we say that: - -* Constraints required by the argi can be solved from - constraint bound by ...stmts... - -* Constraints and existentials bound by the argi are not available - to solve constraints required either by argj (where i /= j), - or by ...more stmts.... - -* Within the stmts of each 'argi' individually, however, constraints bound - by earlier stmts can be used to solve later ones. - -To achieve this, we just typecheck each 'argi' separately, bring all -the variables they bind into scope, and typecheck the thing_inside. - -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same -number of args are used in each equation. --} - -checkArgs :: Name -> MatchGroup Name body -> TcM () -checkArgs _ (MG { mg_alts = L _ [] }) - = return () -checkArgs fun (MG { mg_alts = L _ (match1:matches) }) - | null bad_matches - = return () - | otherwise - = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> - text "have different numbers of arguments" - , nest 2 (ppr (getLoc match1)) - , nest 2 (ppr (getLoc (head bad_matches)))]) - where - n_args1 = args_in_match match1 - bad_matches = [m | m <- matches, args_in_match m /= n_args1] - - args_in_match :: LMatch Name body -> Int - args_in_match (L _ (Match _ pats _ _)) = length pats diff --git a/typecheck/TcMatches.hs-boot b/typecheck/TcMatches.hs-boot deleted file mode 100644 --- a/typecheck/TcMatches.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -module TcMatches where -import HsSyn ( GRHSs, MatchGroup, LHsExpr ) -import TcEvidence( HsWrapper ) -import Name ( Name ) -import TcType ( ExpRhoType, TcRhoType ) -import TcRnTypes( TcM, TcId ) -import SrcLoc ( Located ) - -tcGRHSsPat :: GRHSs Name (LHsExpr Name) - -> TcRhoType - -> TcM (GRHSs TcId (LHsExpr TcId)) - -tcMatchesFun :: Located Name - -> MatchGroup Name (LHsExpr Name) - -> ExpRhoType - -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) diff --git a/typecheck/TcPat.hs b/typecheck/TcPat.hs deleted file mode 100644 --- a/typecheck/TcPat.hs +++ /dev/null @@ -1,1180 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcPat: Typechecking patterns --} - -{-# LANGUAGE CPP, RankNTypes, TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} - -module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..) - , tcPat, tcPat_O, tcPats - , addDataConStupidTheta, badFieldCon, polyPatSig ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma ) - -import HsSyn -import TcHsSyn -import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags ) -import TcRnMonad -import Inst -import Id -import Var -import Name -import RdrName -import TcEnv -import TcMType -import TcValidity( arityErr ) -import Type ( pprTyVars ) -import TcType -import TcUnify -import TcHsType -import TysWiredIn -import TcEvidence -import TyCon -import DataCon -import PatSyn -import ConLike -import PrelNames -import BasicTypes hiding (SuccessFlag(..)) -import DynFlags -import SrcLoc -import VarSet -import Util -import Outputable -import qualified GHC.LanguageExtensions as LangExt -import Control.Arrow ( second ) -import ListSetOps ( getNth ) - -{- -************************************************************************ -* * - External interface -* * -************************************************************************ --} - -tcLetPat :: (Name -> Maybe TcId) - -> LetBndrSpec - -> LPat Name -> ExpSigmaType - -> TcM a - -> TcM (LPat TcId, a) -tcLetPat sig_fn no_gen pat pat_ty thing_inside - = do { bind_lvl <- getTcLevel - ; let ctxt = LetPat { pc_lvl = bind_lvl - , pc_sig_fn = sig_fn - , pc_new = no_gen } - penv = PE { pe_lazy = True - , pe_ctxt = ctxt - , pe_orig = PatOrigin } - - ; tc_lpat pat pat_ty penv thing_inside } - ------------------ -tcPats :: HsMatchContext Name - -> [LPat Name] -- Patterns, - -> [ExpSigmaType] -- and their types - -> TcM a -- and the checker for the body - -> TcM ([LPat TcId], a) - --- This is the externally-callable wrapper function --- Typecheck the patterns, extend the environment to bind the variables, --- do the thing inside, use any existentially-bound dictionaries to --- discharge parts of the returning LIE, and deal with pattern type --- signatures - --- 1. Initialise the PatState --- 2. Check the patterns --- 3. Check the body --- 4. Check that no existentials escape - -tcPats ctxt pats pat_tys thing_inside - = tc_lpats penv pats pat_tys thing_inside - where - penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } - -tcPat :: HsMatchContext Name - -> LPat Name -> ExpSigmaType - -> TcM a -- Checker for body - -> TcM (LPat TcId, a) -tcPat ctxt = tcPat_O ctxt PatOrigin - --- | A variant of 'tcPat' that takes a custom origin -tcPat_O :: HsMatchContext Name - -> CtOrigin -- ^ origin to use if the type needs inst'ing - -> LPat Name -> ExpSigmaType - -> TcM a -- Checker for body - -> TcM (LPat TcId, a) -tcPat_O ctxt orig pat pat_ty thing_inside - = tc_lpat pat pat_ty penv thing_inside - where - penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig } - - -{- -************************************************************************ -* * - PatEnv, PatCtxt, LetBndrSpec -* * -************************************************************************ --} - -data PatEnv - = PE { pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed - , pe_ctxt :: PatCtxt -- Context in which the whole pattern appears - , pe_orig :: CtOrigin -- origin to use if the pat_ty needs inst'ing - } - -data PatCtxt - = LamPat -- Used for lambdas, case etc - (HsMatchContext Name) - - | LetPat -- Used only for let(rec) pattern bindings - -- See Note [Typing patterns in pattern bindings] - { pc_lvl :: TcLevel - -- Level of the binding group - - , pc_sig_fn :: Name -> Maybe TcId - -- Tells the expected type - -- for binders with a signature - - , pc_new :: LetBndrSpec - -- How to make a new binder - } -- for binders without signatures - -data LetBndrSpec - = LetLclBndr -- We are going to generalise, and wrap in an AbsBinds - -- so clone a fresh binder for the local monomorphic Id - - | LetGblBndr TcPragEnv -- Generalisation plan is NoGen, so there isn't going - -- to be an AbsBinds; So we must bind the global version - -- of the binder right away. - -- And here is the inline-pragma information - -instance Outputable LetBndrSpec where - ppr LetLclBndr = text "LetLclBndr" - ppr (LetGblBndr {}) = text "LetGblBndr" - -makeLazy :: PatEnv -> PatEnv -makeLazy penv = penv { pe_lazy = True } - -inPatBind :: PatEnv -> Bool -inPatBind (PE { pe_ctxt = LetPat {} }) = True -inPatBind (PE { pe_ctxt = LamPat {} }) = False - -{- ********************************************************************* -* * - Binders -* * -********************************************************************* -} - -tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId) --- (coi, xp) = tcPatBndr penv x pat_ty --- Then coi : pat_ty ~ typeof(xp) --- -tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl - , pc_sig_fn = sig_fn - , pc_new = no_gen } }) - bndr_name exp_pat_ty - -- For the LetPat cases, see - -- Note [Typechecking pattern bindings] in TcBinds - - | Just bndr_id <- sig_fn bndr_name -- There is a signature - = do { wrap <- tcSubTypePat penv exp_pat_ty (idType bndr_id) - -- See Note [Subsumption check at pattern variables] - ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty) - ; return (wrap, bndr_id) } - - | otherwise -- No signature - = do { (co, bndr_ty) <- case exp_pat_ty of - Check pat_ty -> promoteTcType bind_lvl pat_ty - Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res ) - -- If we were under a constructor that bumped - -- the level, we'd be in checking mode - do { bndr_ty <- inferResultToType infer_res - ; return (mkTcNomReflCo bndr_ty, bndr_ty) } - ; bndr_id <- newLetBndr no_gen bndr_name bndr_ty - ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl - , ppr exp_pat_ty, ppr bndr_ty, ppr co - , ppr bndr_id ]) - ; return (mkWpCastN co, bndr_id) } - -tcPatBndr _ bndr_name pat_ty - = do { pat_ty <- expTypeToType pat_ty - ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty) - ; return (idHsWrapper, mkLocalId bndr_name pat_ty) } - -- Whether or not there is a sig is irrelevant, - -- as this is local - -newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId --- Make up a suitable Id for the pattern-binder. --- See Note [Typechecking pattern bindings], item (4) in TcBinds --- --- In the polymorphic case when we are going to generalise --- (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version" --- of the Id; the original name will be bound to the polymorphic version --- by the AbsBinds --- In the monomorphic case when we are not going to generalise --- (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds, --- and we use the original name directly -newLetBndr LetLclBndr name ty - = do { mono_name <- cloneLocalName name - ; return (mkLocalId mono_name ty) } -newLetBndr (LetGblBndr prags) name ty - = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name) - -tcSubTypePat :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper --- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt --- Used when typechecking patterns -tcSubTypePat penv t1 t2 = tcSubTypeET (pe_orig penv) GenSigCtxt t1 t2 - -{- Note [Subsumption check at pattern variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come across a variable with a type signature, we need to do a -subsumption, not equality, check against the context type. e.g. - - data T = MkT (forall a. a->a) - f :: forall b. [b]->[b] - MkT f = blah - -Since 'blah' returns a value of type T, its payload is a polymorphic -function of type (forall a. a->a). And that's enough to bind the -less-polymorphic function 'f', but we need some impedance matching -to witness the instantiation. - - -************************************************************************ -* * - The main worker functions -* * -************************************************************************ - -Note [Nesting] -~~~~~~~~~~~~~~ -tcPat takes a "thing inside" over which the pattern scopes. This is partly -so that tcPat can extend the environment for the thing_inside, but also -so that constraints arising in the thing_inside can be discharged by the -pattern. - -This does not work so well for the ErrCtxt carried by the monad: we don't -want the error-context for the pattern to scope over the RHS. -Hence the getErrCtxt/setErrCtxt stuff in tcMultiple --} - --------------------- -type Checker inp out = forall r. - inp - -> PatEnv - -> TcM r - -> TcM (out, r) - -tcMultiple :: Checker inp out -> Checker [inp] [out] -tcMultiple tc_pat args penv thing_inside - = do { err_ctxt <- getErrCtxt - ; let loop _ [] - = do { res <- thing_inside - ; return ([], res) } - - loop penv (arg:args) - = do { (p', (ps', res)) - <- tc_pat arg penv $ - setErrCtxt err_ctxt $ - loop penv args - -- setErrCtxt: restore context before doing the next pattern - -- See note [Nesting] above - - ; return (p':ps', res) } - - ; loop penv args } - --------------------- -tc_lpat :: LPat Name - -> ExpSigmaType - -> PatEnv - -> TcM a - -> TcM (LPat TcId, a) -tc_lpat (L span pat) pat_ty penv thing_inside - = setSrcSpan span $ - do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) - thing_inside - ; return (L span pat', res) } - -tc_lpats :: PatEnv - -> [LPat Name] -> [ExpSigmaType] - -> TcM a - -> TcM ([LPat TcId], a) -tc_lpats penv pats tys thing_inside - = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys ) - tcMultiple (\(p,t) -> tc_lpat p t) - (zipEqual "tc_lpats" pats tys) - penv thing_inside - --------------------- -tc_pat :: PatEnv - -> Pat Name - -> ExpSigmaType -- Fully refined result type - -> TcM a -- Thing inside - -> TcM (Pat TcId, -- Translated pattern - a) -- Result of thing inside - -tc_pat penv (VarPat (L l name)) pat_ty thing_inside - = do { (wrap, id) <- tcPatBndr penv name pat_ty - ; res <- tcExtendIdEnv1 name id thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat (L l id)) pat_ty, res) } - -tc_pat penv (ParPat pat) pat_ty thing_inside - = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (ParPat pat', res) } - -tc_pat penv (BangPat pat) pat_ty thing_inside - = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (BangPat pat', res) } - -tc_pat penv (LazyPat pat) pat_ty thing_inside - = do { (pat', (res, pat_ct)) - <- tc_lpat pat pat_ty (makeLazy penv) $ - captureConstraints thing_inside - -- Ignore refined penv', revert to penv - - ; emitConstraints pat_ct - -- captureConstraints/extendConstraints: - -- see Note [Hopping the LIE in lazy patterns] - - -- Check that the expected pattern type is itself lifted - ; pat_ty <- readExpType pat_ty - ; _ <- unifyType noThing (typeKind pat_ty) liftedTypeKind - - ; return (LazyPat pat', res) } - -tc_pat _ (WildPat _) pat_ty thing_inside - = do { res <- thing_inside - ; pat_ty <- expTypeToType pat_ty - ; return (WildPat pat_ty, res) } - -tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside - = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) - ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ - tc_lpat pat (mkCheckExpType $ idType bndr_id) - penv thing_inside - -- NB: if we do inference on: - -- \ (y@(x::forall a. a->a)) = e - -- we'll fail. The as-pattern infers a monotype for 'y', which then - -- fails to unify with the polymorphic type for 'x'. This could - -- perhaps be fixed, but only with a bit more work. - -- - -- If you fix it, don't forget the bindInstsOfPatIds! - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } - -tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside - = do { - -- Expr must have type `forall a1...aN. OPT' -> B` - -- where overall_pat_ty is an instance of OPT'. - ; (expr',expr'_inferred) <- tcInferSigma expr - - -- expression must be a function - ; let expr_orig = lexprCtOrigin expr - herald = text "A view pattern expression expects" - ; (expr_wrap1, [inf_arg_ty], inf_res_ty) - <- matchActualFunTys herald expr_orig (Just expr) 1 expr'_inferred - -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty) - - -- check that overall pattern is more polymorphic than arg type - ; expr_wrap2 <- tcSubTypePat penv overall_pat_ty inf_arg_ty - -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty - - -- pattern must have inf_res_ty - ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside - - ; overall_pat_ty <- readExpType overall_pat_ty - ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper - overall_pat_ty inf_res_ty doc - -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->" - -- (overall_pat_ty -> inf_res_ty) - expr_wrap = expr_wrap2' <.> expr_wrap1 - doc = text "When checking the view pattern function:" <+> (ppr expr) - ; return (ViewPat (mkLHsWrap expr_wrap expr') pat' overall_pat_ty, res) } - --- Type signatures in patterns --- See Note [Pattern coercions] below -tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside - = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) - sig_ty pat_ty - ; (pat', res) <- tcExtendTyVarEnv2 wcs $ - tcExtendTyVarEnv2 tv_binds $ - tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) } - ------------------------- --- Lists, tuples, arrays -tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside - = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty - ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) - pats penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res) - } - -tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside - = do { tau_pat_ty <- expTypeToType pat_ty - ; ((pats', res, elt_ty), e') - <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] - SynList $ - \ [elt_ty] -> - do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) - pats penv thing_inside - ; return (pats', res, elt_ty) } - ; return (ListPat pats' elt_ty (Just (tau_pat_ty,e')), res) - } - -tc_pat penv (PArrPat pats _) pat_ty thing_inside - = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy penv pat_ty - ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) - pats penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res) - } - -tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside - = do { let arity = length pats - tc = tupleTyCon boxity arity - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv pat_ty - -- Unboxed tuples have RuntimeRep vars, which we discard: - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys - Boxed -> arg_tys - ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys) - thing_inside - - ; dflags <- getDynFlags - - -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) - -- so that we can experiment with lazy tuple-matching. - -- This is a pretty odd place to make the switch, but - -- it was easy to do. - ; let - unmangled_result = TuplePat pats' boxity con_arg_tys - -- pat_ty /= pat_ty iff coi /= IdCo - possibly_mangled_result - | gopt Opt_IrrefutableTuples dflags && - isBoxed boxity = LazyPat (noLoc unmangled_result) - | otherwise = unmangled_result - - ; pat_ty <- readExpType pat_ty - ; ASSERT( length con_arg_tys == length pats ) -- Syntactically enforced - return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) - } - -tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside - = do { let tc = sumTyCon arity - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv pat_ty - ; -- Drop levity vars, we don't care about them here - let con_arg_tys = drop arity arg_tys - ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) - penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (SumPat pat' alt arity con_arg_tys) pat_ty, res) - } - ------------------------- --- Data constructors -tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside - = tcConPat penv con pat_ty arg_pats thing_inside - ------------------------- --- Literal patterns -tc_pat penv (LitPat simple_lit) pat_ty thing_inside - = do { let lit_ty = hsLitType simple_lit - ; wrap <- tcSubTypePat penv pat_ty lit_ty - ; res <- thing_inside - ; pat_ty <- readExpType pat_ty - ; return ( mkHsWrapPat wrap (LitPat simple_lit) pat_ty - , res) } - ------------------------- --- Overloaded patterns: n, and n+k - --- In the case of a negative literal (the more complicated case), --- we get --- --- case v of (-5) -> blah --- --- becoming --- --- if v == (negate (fromInteger 5)) then blah else ... --- --- There are two bits of rebindable syntax: --- (==) :: pat_ty -> neg_lit_ty -> Bool --- negate :: lit_ty -> neg_lit_ty --- where lit_ty is the type of the overloaded literal 5. --- --- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside - = do { let orig = LiteralOrigin over_lit - ; ((lit', mb_neg'), eq') - <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] - (mkCheckExpType boolTy) $ - \ [neg_lit_ty] -> - let new_over_lit lit_ty = newOverloadedLit over_lit - (mkCheckExpType lit_ty) - in case mb_neg of - Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty - Just neg -> -- Negative literal - -- The 'negate' is re-mappable syntax - second Just <$> - (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $ - \ [lit_ty] -> new_over_lit lit_ty) - - ; res <- thing_inside - ; pat_ty <- readExpType pat_ty - ; return (NPat (L l lit') mb_neg' eq' pat_ty, res) } - -{- -Note [NPlusK patterns] -~~~~~~~~~~~~~~~~~~~~~~ -From - - case v of x + 5 -> blah - -we get - - if v >= 5 then (\x -> blah) (v - 5) else ... - -There are two bits of rebindable syntax: - (>=) :: pat_ty -> lit1_ty -> Bool - (-) :: pat_ty -> lit2_ty -> var_ty - -lit1_ty and lit2_ty could conceivably be different. -var_ty is the type inferred for x, the variable in the pattern. - -If the pushed-down pattern type isn't a tau-type, the two pat_ty's above -could conceivably be different specializations. But this is very much -like the situation in Note [Case branches must be taus] in TcMatches. -So we tauify the pat_ty before proceeding. - -Note that we need to type-check the literal twice, because it is used -twice, and may be used at different types. The second HsOverLit stored in the -AST is used for the subtraction operation. --} - --- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_inside - = do { pat_ty <- expTypeToType pat_ty - ; let orig = LiteralOrigin lit - ; (lit1', ge') - <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho] - (mkCheckExpType boolTy) $ - \ [lit1_ty] -> - newOverloadedLit lit (mkCheckExpType lit1_ty) - ; ((lit2', minus_wrap, bndr_id), minus') - <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $ - \ [lit2_ty, var_ty] -> - do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) - ; (wrap, bndr_id) <- setSrcSpan nm_loc $ - tcPatBndr penv name (mkCheckExpType var_ty) - -- co :: var_ty ~ idType bndr_id - - -- minus_wrap is applicable to minus' - ; return (lit2', wrap, bndr_id) } - - -- The Report says that n+k patterns must be in Integral - -- but it's silly to insist on this in the RebindableSyntax case - ; unlessM (xoptM LangExt.RebindableSyntax) $ - do { icls <- tcLookupClass integralClassName - ; instStupidTheta orig [mkClassPred icls [pat_ty]] } - - ; res <- tcExtendIdEnv1 name bndr_id thing_inside - - ; let minus'' = minus' { syn_res_wrap = - minus_wrap <.> syn_res_wrap minus' } - pat' = NPlusKPat (L nm_loc bndr_id) (L loc lit1') lit2' - ge' minus'' pat_ty - ; return (pat', res) } - --- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'. --- Here we get rid of it and add the finalizers to the global environment. --- --- See Note [Delaying modFinalizers in untyped splices] in RnSplice. -tc_pat penv (SplicePat (HsSpliced mod_finalizers (HsSplicedPat pat))) - pat_ty thing_inside - = do addModFinalizersWithLclEnv mod_finalizers - tc_pat penv pat pat_ty thing_inside - -tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut - - -{- -Note [Hopping the LIE in lazy patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a lazy pattern, we must *not* discharge constraints from the RHS -from dictionaries bound in the pattern. E.g. - f ~(C x) = 3 -We can't discharge the Num constraint from dictionaries bound by -the pattern C! - -So we have to make the constraints from thing_inside "hop around" -the pattern. Hence the captureConstraints and emitConstraints. - -The same thing ensures that equality constraints in a lazy match -are not made available in the RHS of the match. For example - data T a where { T1 :: Int -> T Int; ... } - f :: T a -> Int -> a - f ~(T1 i) y = y -It's obviously not sound to refine a to Int in the right -hand side, because the argument might not match T1 at all! - -Finally, a lazy pattern should not bind any existential type variables -because they won't be in scope when we do the desugaring - - -************************************************************************ -* * - Most of the work for constructors is here - (the rest is in the ConPatIn case of tc_pat) -* * -************************************************************************ - -[Pattern matching indexed data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following declarations: - - data family Map k :: * -> * - data instance Map (a, b) v = MapPair (Map a (Pair b v)) - -and a case expression - - case x :: Map (Int, c) w of MapPair m -> ... - -As explained by [Wrappers for data instance tycons] in MkIds.hs, the -worker/wrapper types for MapPair are - - $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v - $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v - -So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is -:R123Map, which means the straight use of boxySplitTyConApp would give a type -error. Hence, the smart wrapper function boxySplitTyConAppWithFamily calls -boxySplitTyConApp with the family tycon Map instead, which gives us the family -type list {(Int, c), w}. To get the correct split for :R123Map, we need to -unify the family type list {(Int, c), w} with the instance types {(a, b), v} -(provided by tyConFamInst_maybe together with the family tycon). This -unification yields the substitution [a -> Int, b -> c, v -> w], which gives us -the split arguments for the representation tycon :R123Map as {Int, c, w} - -In other words, boxySplitTyConAppWithFamily implicitly takes the coercion - - Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} - -moving between representation and family type into account. To produce type -correct Core, this coercion needs to be used to case the type of the scrutinee -from the family to the representation type. This is achieved by -unwrapFamInstScrutinee using a CoPat around the result pattern. - -Now it might appear seem as if we could have used the previous GADT type -refinement infrastructure of refineAlt and friends instead of the explicit -unification and CoPat generation. However, that would be wrong. Why? The -whole point of GADT refinement is that the refinement is local to the case -alternative. In contrast, the substitution generated by the unification of -the family type list and instance types needs to be propagated to the outside. -Imagine that in the above example, the type of the scrutinee would have been -(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the -substitution [x -> (a, b), v -> w]. In contrast to GADT matching, the -instantiation of x with (a, b) must be global; ie, it must be valid in *all* -alternatives of the case expression, whereas in the GADT case it might vary -between alternatives. - -RIP GADT refinement: refinements have been replaced by the use of explicit -equality constraints that are used in conjunction with implication constraints -to express the local scope of GADT refinements. --} - --- Running example: --- MkT :: forall a b c. (a~[b]) => b -> c -> T a --- with scrutinee of type (T ty) - -tcConPat :: PatEnv -> Located Name - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails Name -> TcM a - -> TcM (Pat TcId, a) -tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside - = do { con_like <- tcLookupConLike con_name - ; case con_like of - RealDataCon data_con -> tcDataConPat penv con_lname data_con - pat_ty arg_pats thing_inside - PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn - pat_ty arg_pats thing_inside - } - -tcDataConPat :: PatEnv -> Located Name -> DataCon - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails Name -> TcM a - -> TcM (Pat TcId, a) -tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside - = do { let tycon = dataConTyCon data_con - -- For data families this is the representation tycon - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) - = dataConFullSig data_con - header = L con_span (RealDataCon data_con) - - -- Instantiate the constructor type variables [a->ty] - -- This may involve doing a family-instance coercion, - -- and building a wrapper - ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty - ; pat_ty <- readExpType pat_ty - - -- Add the stupid theta - ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys - - ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys - ; checkExistentials ex_tvs all_arg_tys penv - - ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys - -- NB: Do not use zipTvSubst! See Trac #14154 - -- We want to create a well-kinded substitution, so - -- that the instantiated type is well-kinded - - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs - -- Get location from monad, not from ex_tvs - - ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys - -- pat_ty' is type of the actual constructor application - -- pat_ty' /= pat_ty iff coi /= IdCo - - arg_tys' = substTys tenv arg_tys - - ; traceTc "tcConPat" (vcat [ ppr con_name - , pprTyVars univ_tvs - , pprTyVars ex_tvs - , ppr eq_spec - , ppr theta - , pprTyVars ex_tvs' - , ppr ctxt_res_tys - , ppr arg_tys' - , ppr arg_pats ]) - ; if null ex_tvs && null eq_spec && null theta - then do { -- The common case; no class bindings etc - -- (see Note [Arrows and patterns]) - (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys' - arg_pats penv thing_inside - ; let res_pat = ConPatOut { pat_con = header, - pat_tvs = [], pat_dicts = [], - pat_binds = emptyTcEvBinds, - pat_args = arg_pats', - pat_arg_tys = ctxt_res_tys, - pat_wrap = idHsWrapper } - - ; return (mkHsWrapPat wrap res_pat pat_ty, res) } - - else do -- The general case, with existential, - -- and local equality constraints - { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) - -- order is *important* as we generate the list of - -- dictionary binders from theta' - no_equalities = not (any isNomEqPred theta') - skol_info = PatSkol (RealDataCon data_con) mc - mc = case pe_ctxt penv of - LamPat mc -> mc - LetPat {} -> PatBindRhs - - ; gadts_on <- xoptM LangExt.GADTs - ; families_on <- xoptM LangExt.TypeFamilies - ; checkTc (no_equalities || gadts_on || families_on) - (text "A pattern match on a GADT requires the" <+> - text "GADTs or TypeFamilies language extension") - -- Trac #2905 decided that a *pattern-match* of a GADT - -- should require the GADT language flag. - -- Re TypeFamilies see also #7156 - - ; given <- newEvVars theta' - ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' given $ - tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside - - ; let res_pat = ConPatOut { pat_con = header, - pat_tvs = ex_tvs', - pat_dicts = given, - pat_binds = ev_binds, - pat_args = arg_pats', - pat_arg_tys = ctxt_res_tys, - pat_wrap = idHsWrapper } - ; return (mkHsWrapPat wrap res_pat pat_ty, res) - } } - -tcPatSynPat :: PatEnv -> Located Name -> PatSyn - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails Name -> TcM a - -> TcM (Pat TcId, a) -tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside - = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn - - ; (subst, univ_tvs') <- newMetaTyVars univ_tvs - - ; let all_arg_tys = ty : prov_theta ++ arg_tys - ; checkExistentials ex_tvs all_arg_tys penv - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs - ; let ty' = substTy tenv ty - arg_tys' = substTys tenv arg_tys - prov_theta' = substTheta tenv prov_theta - req_theta' = substTheta tenv req_theta - - ; wrap <- tcSubTypePat penv pat_ty ty' - ; traceTc "tcPatSynPat" (ppr pat_syn $$ - ppr pat_ty $$ - ppr ty' $$ - ppr ex_tvs' $$ - ppr prov_theta' $$ - ppr req_theta' $$ - ppr arg_tys') - - ; prov_dicts' <- newEvVars prov_theta' - - ; let skol_info = case pe_ctxt penv of - LamPat mc -> PatSkol (PatSynCon pat_syn) mc - LetPat {} -> UnkSkol -- Doesn't matter - - ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta' - ; traceTc "instCall" (ppr req_wrap) - - ; traceTc "checkConstraints {" Outputable.empty - ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' prov_dicts' $ - tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside - - ; traceTc "checkConstraints }" (ppr ev_binds) - ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn, - pat_tvs = ex_tvs', - pat_dicts = prov_dicts', - pat_binds = ev_binds, - pat_args = arg_pats', - pat_arg_tys = mkTyVarTys univ_tvs', - pat_wrap = req_wrap } - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap res_pat pat_ty, res) } - ----------------------------- --- | Convenient wrapper for calling a matchExpectedXXX function -matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a)) - -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a) --- See Note [Matching polytyped patterns] --- Returns a wrapper : pat_ty ~R inner_ty -matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty - = do { pat_ty <- expTypeToType pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - ; (co, res) <- inner_match pat_rho - ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap) - ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) } - ----------------------------- -matchExpectedConTy :: PatEnv - -> TyCon -- The TyCon that this data - -- constructor actually returns - -- In the case of a data family this is - -- the /representation/ TyCon - -> ExpSigmaType -- The type of the pattern; in the case - -- of a data family this would mention - -- the /family/ TyCon - -> TcM (HsWrapper, [TcSigmaType]) --- See Note [Matching constructor patterns] --- Returns a wrapper : pat_ty "->" T ty1 ... tyn -matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty - | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc - -- Comments refer to Note [Matching constructor patterns] - -- co_tc :: forall a. T [a] ~ T7 a - = do { pat_ty <- expTypeToType exp_pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - - ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc) - -- tys = [ty1,ty2] - - ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, - ppr (tyConTyVars data_tc), - ppr fam_tc, ppr fam_args, - ppr exp_pat_ty, - ppr pat_ty, - ppr pat_rho, ppr wrap]) - ; co1 <- unifyType noThing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho - -- co1 : T (ty1,ty2) ~N pat_rho - -- could use tcSubType here... but it's the wrong way round - -- for actual vs. expected in error messages. - - ; let tys' = mkTyVarTys tvs' - co2 = mkTcUnbranchedAxInstCo co_tc tys' [] - -- co2 : T (ty1,ty2) ~R T7 ty1 ty2 - - full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2 - -- full_co :: pat_rho ~R T7 ty1 ty2 - - ; return ( mkWpCastR full_co <.> wrap, tys') } - - | otherwise - = do { pat_ty <- expTypeToType exp_pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho - ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) } - -{- -Note [Matching constructor patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose (coi, tys) = matchExpectedConType data_tc pat_ty - - * In the simple case, pat_ty = tc tys - - * If pat_ty is a polytype, we want to instantiate it - This is like part of a subsumption check. Eg - f :: (forall a. [a]) -> blah - f [] = blah - - * In a type family case, suppose we have - data family T a - data instance T (p,q) = A p | B q - Then we'll have internally generated - data T7 p q = A p | B q - axiom coT7 p q :: T (p,q) ~ T7 p q - - So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that - coi = coi2 . coi1 : T7 t ~ pat_ty - coi1 : T (ty1,ty2) ~ pat_ty - coi2 : T7 ty1 ty2 ~ T (ty1,ty2) - - For families we do all this matching here, not in the unifier, - because we never want a whisper of the data_tycon to appear in - error messages; it's a purely internal thing --} - -tcConArgs :: ConLike -> [TcSigmaType] - -> Checker (HsConPatDetails Name) (HsConPatDetails Id) - -tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside - = do { checkTc (con_arity == no_of_args) -- Check correct arity - (arityErr "constructor" con_like con_arity no_of_args) - ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys - ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys - penv thing_inside - ; return (PrefixCon arg_pats', res) } - where - con_arity = conLikeArity con_like - no_of_args = length arg_pats - -tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside - = do { checkTc (con_arity == 2) -- Check correct arity - (arityErr "constructor" con_like con_arity 2) - ; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check - ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)] - penv thing_inside - ; return (InfixCon p1' p2', res) } - where - con_arity = conLikeArity con_like - -tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside - = do { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside - ; return (RecCon (HsRecFields rpats' dd), res) } - where - tc_field :: Checker (LHsRecField Name (LPat Name)) - (LHsRecField TcId (LPat TcId)) - tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv - thing_inside - = do { sel' <- tcLookupId sel - ; pat_ty <- setSrcSpan loc $ find_field_ty (occNameFS $ rdrNameOcc rdr) - ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel')) pat' - pun), res) } - - find_field_ty :: FieldLabelString -> TcM TcType - find_field_ty lbl - = case [ty | (fl, ty) <- field_tys, flLabel fl == lbl] of - - -- No matching field; chances are this field label comes from some - -- other record type (or maybe none). If this happens, just fail, - -- otherwise we get crashes later (Trac #8570), and similar: - -- f (R { foo = (a,b) }) = a+b - -- If foo isn't one of R's fields, we don't want to crash when - -- typechecking the "a+b". - [] -> failWith (badFieldCon con_like lbl) - - -- The normal case, when the field comes from the right constructor - (pat_ty : extras) -> do - traceTc "find_field" (ppr pat_ty <+> ppr extras) - ASSERT( null extras ) (return pat_ty) - - field_tys :: [(FieldLabel, TcType)] - field_tys = zip (conLikeFieldLabels con_like) arg_tys - -- Don't use zipEqual! If the constructor isn't really a record, then - -- dataConFieldLabels will be empty (and each field in the pattern - -- will generate an error below). - -tcConArg :: Checker (LPat Name, TcSigmaType) (LPat Id) -tcConArg (arg_pat, arg_ty) penv thing_inside - = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside - -addDataConStupidTheta :: DataCon -> [TcType] -> TcM () --- Instantiate the "stupid theta" of the data con, and throw --- the constraints into the constraint set -addDataConStupidTheta data_con inst_tys - | null stupid_theta = return () - | otherwise = instStupidTheta origin inst_theta - where - origin = OccurrenceOf (dataConName data_con) - -- The origin should always report "occurrence of C" - -- even when C occurs in a pattern - stupid_theta = dataConStupidTheta data_con - univ_tvs = dataConUnivTyVars data_con - tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys) - -- NB: inst_tys can be longer than the univ tyvars - -- because the constructor might have existentials - inst_theta = substTheta tenv stupid_theta - -{- -Note [Arrows and patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -(Oct 07) Arrow notation has the odd property that it involves -"holes in the scope". For example: - expr :: Arrow a => a () Int - expr = proc (y,z) -> do - x <- term -< y - expr' -< x - -Here the 'proc (y,z)' binding scopes over the arrow tails but not the -arrow body (e.g 'term'). As things stand (bogusly) all the -constraints from the proc body are gathered together, so constraints -from 'term' will be seen by the tcPat for (y,z). But we must *not* -bind constraints from 'term' here, because the desugarer will not make -these bindings scope over 'term'. - -The Right Thing is not to confuse these constraints together. But for -now the Easy Thing is to ensure that we do not have existential or -GADT constraints in a 'proc', and to short-cut the constraint -simplification for such vanilla patterns so that it binds no -constraints. Hence the 'fast path' in tcConPat; but it's also a good -plan for ordinary vanilla patterns to bypass the constraint -simplification step. - -************************************************************************ -* * - Note [Pattern coercions] -* * -************************************************************************ - -In principle, these program would be reasonable: - - f :: (forall a. a->a) -> Int - f (x :: Int->Int) = x 3 - - g :: (forall a. [a]) -> Bool - g [] = True - -In both cases, the function type signature restricts what arguments can be passed -in a call (to polymorphic ones). The pattern type signature then instantiates this -type. For example, in the first case, (forall a. a->a) <= Int -> Int, and we -generate the translated term - f = \x' :: (forall a. a->a). let x = x' Int in x 3 - -From a type-system point of view, this is perfectly fine, but it's *very* seldom useful. -And it requires a significant amount of code to implement, because we need to decorate -the translated pattern with coercion functions (generated from the subsumption check -by tcSub). - -So for now I'm just insisting on type *equality* in patterns. No subsumption. - -Old notes about desugaring, at a time when pattern coercions were handled: - -A SigPat is a type coercion and must be handled one at at time. We can't -combine them unless the type of the pattern inside is identical, and we don't -bother to check for that. For example: - - data T = T1 Int | T2 Bool - f :: (forall a. a -> a) -> T -> t - f (g::Int->Int) (T1 i) = T1 (g i) - f (g::Bool->Bool) (T2 b) = T2 (g b) - -We desugar this as follows: - - f = \ g::(forall a. a->a) t::T -> - let gi = g Int - in case t of { T1 i -> T1 (gi i) - other -> - let gb = g Bool - in case t of { T2 b -> T2 (gb b) - other -> fail }} - -Note that we do not treat the first column of patterns as a -column of variables, because the coerced variables (gi, gb) -would be of different types. So we get rather grotty code. -But I don't think this is a common case, and if it was we could -doubtless improve it. - -Meanwhile, the strategy is: - * treat each SigPat coercion (always non-identity coercions) - as a separate block - * deal with the stuff inside, and then wrap a binding round - the result to bind the new variable (gi, gb, etc) - - -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -Note [Existential check] -~~~~~~~~~~~~~~~~~~~~~~~~ -Lazy patterns can't bind existentials. They arise in two ways: - * Let bindings let { C a b = e } in b - * Twiddle patterns f ~(C a b) = e -The pe_lazy field of PatEnv says whether we are inside a lazy -pattern (perhaps deeply) - -See also Note [Typechecking pattern bindings] in TcBinds --} - -maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b --- Not all patterns are worth pushing a context -maybeWrapPatCtxt pat tcm thing_inside - | not (worth_wrapping pat) = tcm thing_inside - | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside - -- Remember to pop before doing thing_inside - where - worth_wrapping (VarPat {}) = False - worth_wrapping (ParPat {}) = False - worth_wrapping (AsPat {}) = False - worth_wrapping _ = True - msg = hang (text "In the pattern:") 2 (ppr pat) - ------------------------------------------------ -checkExistentials :: [TyVar] -- existentials - -> [Type] -- argument types - -> PatEnv -> TcM () - -- See Note [Existential check]] - -- See Note [Arrows and patterns] -checkExistentials ex_tvs tys _ - | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return () -checkExistentials _ _ (PE { pe_ctxt = LetPat {}}) = return () -checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existentialProcPat -checkExistentials _ _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat -checkExistentials _ _ _ = return () - -existentialLazyPat :: SDoc -existentialLazyPat - = hang (text "An existential or GADT data constructor cannot be used") - 2 (text "inside a lazy (~) pattern") - -existentialProcPat :: SDoc -existentialProcPat - = text "Proc patterns cannot use existential or GADT data constructors" - -badFieldCon :: ConLike -> FieldLabelString -> SDoc -badFieldCon con field - = hsep [text "Constructor" <+> quotes (ppr con), - text "does not have field", quotes (ppr field)] - -polyPatSig :: TcType -> SDoc -polyPatSig sig_ty - = hang (text "Illegal polymorphic type signature in pattern:") - 2 (ppr sig_ty) diff --git a/typecheck/TcPatSyn.hs b/typecheck/TcPatSyn.hs deleted file mode 100644 --- a/typecheck/TcPatSyn.hs +++ /dev/null @@ -1,849 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcPatSyn]{Typechecking pattern synonym declarations} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl - , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr - ) where - -import HsSyn -import TcPat -import Type( mkTyVarBinders, mkEmptyTCvSubst - , tidyTyVarBinders, tidyTypes, tidyType ) -import TcRnMonad -import TcSigs( emptyPragEnv, completeSigFromId ) -import TcEnv -import TcMType -import TcHsSyn( zonkTyVarBindersX, zonkTcTypeToTypes - , zonkTcTypeToType, emptyZonkEnv ) -import TysPrim -import TysWiredIn ( runtimeRepTy ) -import Name -import SrcLoc -import PatSyn -import NameSet -import Panic -import Outputable -import FastString -import Var -import VarEnv( emptyTidyEnv, mkInScopeSet ) -import Id -import IdInfo( RecSelParent(..), setLevityInfoWithType ) -import TcBinds -import BasicTypes -import TcSimplify -import TcUnify -import TcType -import TcEvidence -import BuildTyCl -import VarSet -import MkId -import TcTyDecls -import ConLike -import FieldLabel -import Bag -import Util -import ErrUtils -import Control.Monad ( zipWithM ) -import Data.List( partition ) - -#include "HsVersions.h" - -{- -************************************************************************ -* * - Type checking a pattern synonym -* * -************************************************************************ --} - -tcInferPatSynDecl :: PatSynBind Name Name - -> TcM (LHsBinds Id, TcGblEnv) -tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, - psb_def = lpat, psb_dir = dir } - = addPatSynCtxt lname $ - do { traceTc "tcInferPatSynDecl {" $ ppr name - ; tcCheckPatSynPat lpat - - ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details - ; (tclvl, wanted, ((lpat', args), pat_ty)) - <- pushLevelAndCaptureConstraints $ - tcInferNoInst $ \ exp_ty -> - tcPat PatSyn lpat exp_ty $ - mapM tcLookupId arg_names - - ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args - - ; (qtvs, req_dicts, ev_binds, _) <- simplifyInfer tclvl NoRestrictions [] - named_taus wanted - - ; let (ex_tvs, prov_dicts) = tcCollectEx lpat' - ex_tv_set = mkVarSet ex_tvs - univ_tvs = filterOut (`elemVarSet` ex_tv_set) qtvs - prov_theta = map evVarPred prov_dicts - req_theta = map evVarPred req_dicts - - ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) - ; tc_patsyn_finish lname dir is_infix lpat' - (mkTyVarBinders Inferred univ_tvs - , req_theta, ev_binds, req_dicts) - (mkTyVarBinders Inferred ex_tvs - , mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts) - (map nlHsVar args, map idType args) - pat_ty rec_fields } - - -tcCheckPatSynDecl :: PatSynBind Name Name - -> TcPatSynInfo - -> TcM (LHsBinds Id, TcGblEnv) -tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details - , psb_def = lpat, psb_dir = dir } - TPSI{ patsig_implicit_bndrs = implicit_tvs - , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta - , patsig_ex_bndrs = explicit_ex_tvs, patsig_req = req_theta - , patsig_body_ty = sig_body_ty } - = addPatSynCtxt lname $ - do { let decl_arity = length arg_names - (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details - - ; traceTc "tcCheckPatSynDecl" $ - vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta - , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ] - - ; tcCheckPatSynPat lpat - - ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of - Right stuff -> return stuff - Left missing -> wrongNumberOfParmsErr name decl_arity missing - - -- Complain about: pattern P :: () => forall x. x -> P x - -- The existential 'x' should not appear in the result type - -- Can't check this until we know P's arity - ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs - ; checkTc (null bad_tvs) $ - hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma - , text "namely" <+> quotes (ppr pat_ty) ]) - 2 (text "mentions existential type variable" <> plural bad_tvs - <+> pprQuotedList bad_tvs) - - -- See Note [The pattern-synonym signature splitting rule] - ; let univ_fvs = closeOverKinds $ - (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs) - (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs - univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs - ex_bndrs = extra_ex ++ mkTyVarBinders Specified explicit_ex_tvs - univ_tvs = binderVars univ_bndrs - ex_tvs = binderVars ex_bndrs - - -- Right! Let's check the pattern against the signature - -- See Note [Checking against a pattern signature] - ; req_dicts <- newEvVars req_theta - ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <- - ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys ) - pushLevelAndCaptureConstraints $ - tcExtendTyVarEnv univ_tvs $ - tcPat PatSyn lpat (mkCheckExpType pat_ty) $ - do { let in_scope = mkInScopeSet (mkVarSet univ_tvs) - empty_subst = mkEmptyTCvSubst in_scope - ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs - -- newMetaTyVarX: see the "Existential type variables" - -- part of Note [Checking against a pattern signature] - ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs]) - ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs']) - ; let prov_theta' = substTheta subst prov_theta - -- Add univ_tvs to the in_scope set to - -- satisfy the substitution invariant. There's no need to - -- add 'ex_tvs' as they are already in the domain of the - -- substitution. - -- See also Note [The substitution invariant] in TyCoRep. - ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta' - ; args' <- zipWithM (tc_arg subst) arg_names arg_tys - ; return (ex_tvs', prov_dicts, args') } - - ; let skol_info = SigSkol (PatSynCtxt name) pat_ty [] - -- The type here is a bit bogus, but we do not print - -- the type for PatSynCtxt, so it doesn't matter - -- See TcRnTypes Note [Skolem info for pattern synonyms] - ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted - - -- Solve the constraints now, because we are about to make a PatSyn, - -- which should not contain unification variables and the like (Trac #10997) - ; simplifyTopImplic implics - - -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct - -- Otherwise we may get a type error when typechecking the builder, - -- when that should be impossible - - ; traceTc "tcCheckPatSynDecl }" $ ppr name - ; tc_patsyn_finish lname dir is_infix lpat' - (univ_bndrs, req_theta, ev_binds, req_dicts) - (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts) - (args', arg_tys) - pat_ty rec_fields } - where - tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr TcId) - tc_arg subst arg_name arg_ty - = do { -- Look up the variable actually bound by lpat - -- and check that it has the expected type - arg_id <- tcLookupId arg_name - ; coi <- unifyType (Just arg_id) - (idType arg_id) - (substTyUnchecked subst arg_ty) - ; return (mkLHsWrapCo coi $ nlHsVar arg_id) } - -{- Note [Checking against a pattern signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When checking the actual supplied pattern against the pattern synonym -signature, we need to be quite careful. - ------ Provided constraints -Example - - data T a where - MkT :: Ord a => a -> T a - - pattern P :: () => Eq a => a -> [T a] - pattern P x = [MkT x] - -We must check that the (Eq a) that P claims to bind (and to -make available to matches against P), is derivable from the -actual pattern. For example: - f (P (x::a)) = ...here (Eq a) should be available... -And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs. - ------ Existential type variables -Unusually, we instantiate the existential tyvars of the pattern with -*meta* type variables. For example - - data S where - MkS :: Eq a => [a] -> S - - pattern P :: () => Eq x => x -> S - pattern P x <- MkS x - -The pattern synonym conceals from its client the fact that MkS has a -list inside it. The client just thinks it's a type 'x'. So we must -unify x := [a] during type checking, and then use the instantiating type -[a] (called ex_tys) when building the matcher. In this case we'll get - - $mP :: S -> (forall x. Ex x => x -> r) -> r -> r - $mP x k = case x of - MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a] - dl = $dfunEqList d - in k [a] dl ys - -All this applies when type-checking the /matching/ side of -a pattern synonym. What about the /building/ side? - -* For Unidirectional, there is no builder - -* For ExplicitBidirectional, the builder is completely separate - code, typechecked in tcPatSynBuilderBind - -* For ImplicitBidirectional, the builder is still typechecked in - tcPatSynBuilderBind, by converting the pattern to an expression and - typechecking it. - - At one point, for ImplicitBidirectional I used SigTvs (instead of - TauTvs) in tcCheckPatSynDecl. But (a) strengthening the check here - is redundant since tcPatSynBuilderBind does the job, (b) it was - still incomplete (SigTvs can unify with each other), and (c) it - didn't even work (Trac #13441 was accepted with - ExplicitBidirectional, but rejected if expressed in - ImplicitBidirectional form. Conclusion: trying to be too clever is - a bad idea. --} - -collectPatSynArgInfo :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool) -collectPatSynArgInfo details = - case details of - PrefixPatSyn names -> (map unLoc names, [], False) - InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True) - RecordPatSyn names -> - let (vars, sels) = unzip (map splitRecordPatSyn names) - in (vars, sels, False) - - where - splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name) - splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar - , recordPatSynSelectorId = L _ selId }) - = (patVar, selId) - -addPatSynCtxt :: Located Name -> TcM a -> TcM a -addPatSynCtxt (L loc name) thing_inside - = setSrcSpan loc $ - addErrCtxt (text "In the declaration for pattern synonym" - <+> quotes (ppr name)) $ - thing_inside - -wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a -wrongNumberOfParmsErr name decl_arity missing - = failWithTc $ - hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has") - <+> speakNOf decl_arity (text "argument")) - 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") - -------------------------- --- Shared by both tcInferPatSyn and tcCheckPatSyn -tc_patsyn_finish :: Located Name -- ^ PatSyn Name - -> HsPatSynDir Name -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) - -> Bool -- ^ Whether infix - -> LPat Id -- ^ Pattern of the PatSyn - -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar]) - -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm]) - -> ([LHsExpr TcId], [TcType]) -- ^ Pattern arguments and types - -> TcType -- ^ Pattern type - -> [Name] -- ^ Selector names - -- ^ Whether fields, empty if not record PatSyn - -> TcM (LHsBinds Id, TcGblEnv) -tc_patsyn_finish lname dir is_infix lpat' - (univ_tvs, req_theta, req_ev_binds, req_dicts) - (ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) - pat_ty field_labels - = do { -- Zonk everything. We are about to build a final PatSyn - -- so there had better be no unification variables in there - - (ze, univ_tvs') <- zonkTyVarBindersX emptyZonkEnv univ_tvs - ; req_theta' <- zonkTcTypeToTypes ze req_theta - ; (ze, ex_tvs') <- zonkTyVarBindersX ze ex_tvs - ; prov_theta' <- zonkTcTypeToTypes ze prov_theta - ; pat_ty' <- zonkTcTypeToType ze pat_ty - ; arg_tys' <- zonkTcTypeToTypes ze arg_tys - - ; let (env1, univ_tvs) = tidyTyVarBinders emptyTidyEnv univ_tvs' - (env2, ex_tvs) = tidyTyVarBinders env1 ex_tvs' - req_theta = tidyTypes env2 req_theta' - prov_theta = tidyTypes env2 prov_theta' - arg_tys = tidyTypes env2 arg_tys' - pat_ty = tidyType env2 pat_ty' - - ; traceTc "tc_patsyn_finish {" $ - ppr (unLoc lname) $$ ppr (unLoc lpat') $$ - ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ - ppr (ex_tvs, prov_theta, prov_dicts) $$ - ppr args $$ - ppr arg_tys $$ - ppr pat_ty - - -- Make the 'matcher' - ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' - (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) - (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) - pat_ty - - -- Make the 'builder' - ; builder_id <- mkPatSynBuilderId dir lname - univ_tvs req_theta - ex_tvs prov_theta - arg_tys pat_ty - - -- TODO: Make this have the proper information - ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name) - , flIsOverloaded = False - , flSelector = name } - field_labels' = map mkFieldLabel field_labels - - - -- Make the PatSyn itself - ; let patSyn = mkPatSyn (unLoc lname) is_infix - (univ_tvs, req_theta) - (ex_tvs, prov_theta) - arg_tys - pat_ty - matcher_id builder_id - field_labels' - - -- Selectors - ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) - tything = AConLike (PatSynCon patSyn) - ; tcg_env <- tcExtendGlobalEnv [tything] $ - tcRecSelBinds rn_rec_sel_binds - - ; traceTc "tc_patsyn_finish }" empty - ; return (matcher_bind, tcg_env) } - -{- -************************************************************************ -* * - Constructing the "matcher" Id and its binding -* * -************************************************************************ --} - -tcPatSynMatcher :: Located Name - -> LPat Id - -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) - -> ([TcTyVar], [TcType], ThetaType, [EvTerm]) - -> ([LHsExpr TcId], [TcType]) - -> TcType - -> TcM ((Id, Bool), LHsBinds Id) --- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynMatcher (L loc name) lpat - (univ_tvs, req_theta, req_ev_binds, req_dicts) - (ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) pat_ty - = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc - ; tv_name <- newNameAt (mkTyVarOcc "r") loc - ; let rr_tv = mkTcTyVar rr_name runtimeRepTy vanillaSkolemTv - rr = mkTyVarTy rr_tv - res_tv = mkTcTyVar tv_name (tYPE rr) vanillaSkolemTv - res_ty = mkTyVarTy res_tv - is_unlifted = null args && null prov_dicts - (cont_args, cont_arg_tys) - | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy]) - | otherwise = (args, arg_tys) - cont_ty = mkInfSigmaTy ex_tvs prov_theta $ - mkFunTys cont_arg_tys res_ty - - fail_ty = mkFunTy voidPrimTy res_ty - - ; matcher_name <- newImplicitBinder name mkMatcherOcc - ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty - ; cont <- newSysLocalId (fsLit "cont") cont_ty - ; fail <- newSysLocalId (fsLit "fail") fail_ty - - ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty - matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau - matcher_id = mkExportedVanillaId matcher_name matcher_sigma - -- See Note [Exported LocalIds] in Id - - inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys - cont' = foldl nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args - - fail' = nlHsApps fail [nlHsVar voidPrimId] - - args = map nlVarPat [scrutinee, cont, fail] - lwpat = noLoc $ WildPat pat_ty - cases = if isIrrefutableHsPat lpat - then [mkHsCaseAlt lpat cont'] - else [mkHsCaseAlt lpat cont', - mkHsCaseAlt lwpat fail'] - body = mkLHsWrap (mkWpLet req_ev_binds) $ - L (getLoc lpat) $ - HsCase (nlHsVar scrutinee) $ - MG{ mg_alts = L (getLoc lpat) cases - , mg_arg_tys = [pat_ty] - , mg_res_ty = res_ty - , mg_origin = Generated - } - body' = noLoc $ - HsLam $ - MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr - args body] - , mg_arg_tys = [pat_ty, cont_ty, fail_ty] - , mg_res_ty = res_ty - , mg_origin = Generated - } - match = mkMatch (mkPrefixFunRhs (L loc name)) [] - (mkHsLams (rr_tv:res_tv:univ_tvs) - req_dicts body') - (noLoc EmptyLocalBinds) - mg = MG{ mg_alts = L (getLoc match) [match] - , mg_arg_tys = [] - , mg_res_ty = res_ty - , mg_origin = Generated - } - - ; let bind = FunBind{ fun_id = L loc matcher_id - , fun_matches = mg - , fun_co_fn = idHsWrapper - , bind_fvs = emptyNameSet - , fun_tick = [] } - matcher_bind = unitBag (noLoc bind) - - ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) - ; traceTc "tcPatSynMatcher" (ppr matcher_bind) - - ; return ((matcher_id, is_unlifted), matcher_bind) } - -mkPatSynRecSelBinds :: PatSyn - -> [FieldLabel] -- ^ Visible field labels - -> HsValBinds Name -mkPatSynRecSelBinds ps fields - = ValBindsOut selector_binds sigs - where - (sigs, selector_binds) = unzip (map mkRecSel fields) - mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl - -isUnidirectional :: HsPatSynDir a -> Bool -isUnidirectional Unidirectional = True -isUnidirectional ImplicitBidirectional = False -isUnidirectional ExplicitBidirectional{} = False - -{- -************************************************************************ -* * - Constructing the "builder" Id -* * -************************************************************************ --} - -mkPatSynBuilderId :: HsPatSynDir a -> Located Name - -> [TyVarBinder] -> ThetaType - -> [TyVarBinder] -> ThetaType - -> [Type] -> Type - -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (L _ name) - univ_bndrs req_theta ex_bndrs prov_theta - arg_tys pat_ty - | isUnidirectional dir - = return Nothing - | otherwise - = do { builder_name <- newImplicitBinder name mkBuilderOcc - ; let theta = req_theta ++ prov_theta - need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta - builder_sigma = add_void need_dummy_arg $ - mkForAllTys univ_bndrs $ - mkForAllTys ex_bndrs $ - mkFunTys theta $ - mkFunTys arg_tys $ - pat_ty - builder_id = mkExportedVanillaId builder_name builder_sigma - -- See Note [Exported LocalIds] in Id - - builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id - - ; return (Just (builder_id', need_dummy_arg)) } - where - -tcPatSynBuilderBind :: PatSynBind Name Name - -> TcM (LHsBinds Id) --- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat - , psb_dir = dir, psb_args = details }) - | isUnidirectional dir - = return emptyBag - - | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLoc lpat) $ failWithTc $ - vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" - <+> quotes (ppr name) <> colon) - 2 why - , text "RHS pattern:" <+> ppr lpat ] - - | Right match_group <- mb_match_group -- Bidirectional - = do { patsyn <- tcLookupPatSyn name - ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn - -- Bidirectional, so patSynBuilder returns Just - - match_group' | need_dummy_arg = add_dummy_arg match_group - | otherwise = match_group - - bind = FunBind { fun_id = L loc (idName builder_id) - , fun_matches = match_group' - , fun_co_fn = idHsWrapper - , bind_fvs = placeHolderNamesTc - , fun_tick = [] } - - sig = completeSigFromId (PatSynCtxt name) builder_id - - ; traceTc "tcPatSynBuilderBind {" $ - ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id) - ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) - ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds - ; return builder_binds } - - | otherwise = panic "tcPatSynBuilderBind" -- Both cases dealt with - where - mb_match_group - = case dir of - ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat) - Unidirectional -> panic "tcPatSynBuilderBind" - - mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name) - mk_mg body = mkMatchGroup Generated [builder_match] - where - builder_args = [L loc (VarPat (L loc n)) | L loc n <- args] - builder_match = mkMatch (mkPrefixFunRhs (L loc name)) - builder_args body - (noLoc EmptyLocalBinds) - - args = case details of - PrefixPatSyn args -> args - InfixPatSyn arg1 arg2 -> [arg1, arg2] - RecordPatSyn args -> map recordPatSynPatVar args - - add_dummy_arg :: MatchGroup Name (LHsExpr Name) - -> MatchGroup Name (LHsExpr Name) - add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] }) - = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } - add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ - pprMatches other_mg - -tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr TcId, TcSigmaType) --- monadic only for failure -tcPatSynBuilderOcc ps - | Just (builder_id, add_void_arg) <- builder - , let builder_expr = HsConLikeOut (PatSynCon ps) - builder_ty = idType builder_id - = return $ - if add_void_arg - then ( builder_expr -- still just return builder_expr; the void# arg is added - -- by dsConLike in the desugarer - , tcFunResultTy builder_ty ) - else (builder_expr, builder_ty) - - | otherwise -- Unidirectional - = nonBidirectionalErr name - where - name = patSynName ps - builder = patSynBuilder ps - -add_void :: Bool -> Type -> Type -add_void need_dummy_arg ty - | need_dummy_arg = mkFunTy voidPrimTy ty - | otherwise = ty - -tcPatToExpr :: [Located Name] -> LPat Name -> Either MsgDoc (LHsExpr Name) --- Given a /pattern/, return an /expression/ that builds a value --- that matches the pattern. E.g. if the pattern is (Just [x]), --- the expression is (Just [x]). They look the same, but the --- input uses constructors from HsPat and the output uses constructors --- from HsExpr. --- --- Returns (Left r) if the pattern is not invertible, for reason r. --- See Note [Builder for a bidirectional pattern synonym] -tcPatToExpr args pat = go pat - where - lhsVars = mkNameSet (map unLoc args) - - -- Make a prefix con for prefix and infix patterns for simplicity - mkPrefixConExpr :: Located Name -> [LPat Name] -> Either MsgDoc (HsExpr Name) - mkPrefixConExpr lcon@(L loc _) pats - = do { exprs <- mapM go pats - ; return (foldl (\x y -> HsApp (L loc x) y) - (HsVar lcon) exprs) } - - mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name) - -> Either MsgDoc (HsExpr Name) - mkRecordConExpr con fields - = do { exprFields <- mapM go fields - ; return (RecordCon con PlaceHolder noPostTcExpr exprFields) } - - go :: LPat Name -> Either MsgDoc (LHsExpr Name) - go (L loc p) = L loc <$> go1 p - - go1 :: Pat Name -> Either MsgDoc (HsExpr Name) - go1 (ConPatIn con info) - = case info of - PrefixCon ps -> mkPrefixConExpr con ps - InfixCon l r -> mkPrefixConExpr con [l,r] - RecCon fields -> mkRecordConExpr con fields - - go1 (SigPatIn pat _) = go1 (unLoc pat) - -- See Note [Type signatures and the builder expression] - - go1 (VarPat (L l var)) - | var `elemNameSet` lhsVars - = return $ HsVar (L l var) - | otherwise - = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") - go1 (ParPat pat) = fmap HsPar $ go pat - go1 (LazyPat pat) = go1 (unLoc pat) - go1 (BangPat pat) = go1 (unLoc pat) - go1 (PArrPat pats ptt) = do { exprs <- mapM go pats - ; return $ ExplicitPArr ptt exprs } - go1 (ListPat pats ptt reb) = do { exprs <- mapM go pats - ; return $ ExplicitList ptt (fmap snd reb) exprs } - go1 (TuplePat pats box _) = do { exprs <- mapM go pats - ; return $ ExplicitTuple - (map (noLoc . Present) exprs) box } - go1 (SumPat pat alt arity _) = do { expr <- go1 (unLoc pat) - ; return $ ExplicitSum alt arity (noLoc expr) PlaceHolder - } - go1 (LitPat lit) = return $ HsLit lit - go1 (NPat (L _ n) mb_neg _ _) - | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)] - | otherwise = return $ HsOverLit n - go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" - go1 (SigPatOut{}) = panic "SigPatOut in output of renamer" - go1 (CoPat{}) = panic "CoPat in output of renamer" - go1 p = Left (text "pattern" <+> quotes (ppr p) <+> text "is not invertible") - -{- 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 synoymy. For example - pattern F x y = (Just x, [y]) -The 'builder' for F looks like - $builderF x y = (Just x, [y]) - -We can't always do this: - * Some patterns aren't invertible; e.g. view patterns - pattern F x = (reverse -> x:_) - - * The RHS pattern might bind more variables than the pattern - synonym, so again we can't invert it - pattern F x = (x,y) - - * Ditto wildcards - pattern F x = (x,_) - - -Note [Redundant constraints for builder] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The builder can have redundant constraints, which are awkard to eliminate. -Consider - pattern P = Just 34 -To match against this pattern we need (Eq a, Num a). But to build -(Just 34) we need only (Num a). Fortunately instTcSigFromId sets -sig_warn_redundant to False. - -************************************************************************ -* * - Helper functions -* * -************************************************************************ - -Note [As-patterns in pattern synonym definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The rationale for rejecting as-patterns in pattern synonym definitions -is that an as-pattern would introduce nonindependent pattern synonym -arguments, e.g. given a pattern synonym like: - - pattern K x y = x@(Just y) - -one could write a nonsensical function like - - f (K Nothing x) = ... - -or - g (K (Just True) False) = ... - -Note [Type signatures and the builder expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - pattern L x = Left x :: Either [a] [b] - -In tc{Infer/Check}PatSynDecl we will check that the pattern has the -specified type. We check the pattern *as a pattern*, so the type -signature is a pattern signature, and so brings 'a' and 'b' into -scope. But we don't have a way to bind 'a, b' in the LHS, as we do -'x', say. Nevertheless, the sigature may be useful to constrain -the type. - -When making the binding for the *builder*, though, we don't want - $buildL x = Left x :: Either [a] [b] -because that wil either mean (forall a b. Either [a] [b]), or we'll -get a complaint that 'a' and 'b' are out of scope. (Actually the -latter; Trac #9867.) No, the job of the signature is done, so when -converting the pattern to an expression (for the builder RHS) we -simply discard the signature. - -Note [Record PatSyn Desugaring] -------------------------------- -It is important that prov_theta comes before req_theta as this ordering is used -when desugaring record pattern synonym updates. - -Any change to this ordering should make sure to change deSugar/DsExpr.hs if you -want to avoid difficult to decipher core lint errors! - -} - -tcCheckPatSynPat :: LPat Name -> TcM () -tcCheckPatSynPat = go - where - go :: LPat Name -> TcM () - go = addLocM go1 - - go1 :: Pat Name -> TcM () - go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info) - go1 VarPat{} = return () - go1 WildPat{} = return () - go1 p@(AsPat _ _) = asPatInPatSynErr p - go1 (LazyPat pat) = go pat - go1 (ParPat pat) = go pat - go1 (BangPat pat) = go pat - go1 (PArrPat pats _) = mapM_ go pats - go1 (ListPat pats _ _) = mapM_ go pats - go1 (TuplePat pats _ _) = mapM_ go pats - go1 (SumPat pat _ _ _) = go pat - go1 LitPat{} = return () - go1 NPat{} = return () - go1 (SigPatIn pat _) = go pat - go1 (ViewPat _ pat _) = go pat - go1 p@SplicePat{} = thInPatSynErr p - go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p - go1 ConPatOut{} = panic "ConPatOut in output of renamer" - go1 SigPatOut{} = panic "SigPatOut in output of renamer" - go1 CoPat{} = panic "CoPat in output of renamer" - -asPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a -asPatInPatSynErr pat - = failWithTc $ - hang (text "Pattern synonym definition cannot contain as-patterns (@):") - 2 (ppr pat) - -thInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a -thInPatSynErr pat - = failWithTc $ - hang (text "Pattern synonym definition cannot contain Template Haskell:") - 2 (ppr pat) - -nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a -nPlusKPatInPatSynErr pat - = failWithTc $ - hang (text "Pattern synonym definition cannot contain n+k-pattern:") - 2 (ppr pat) - -nonBidirectionalErr :: Outputable name => name -> TcM a -nonBidirectionalErr name = failWithTc $ - text "non-bidirectional pattern synonym" - <+> quotes (ppr name) <+> text "used in an expression" - --- Walk the whole pattern and for all ConPatOuts, collect the --- existentially-bound type variables and evidence binding variables. --- --- These are used in computing the type of a pattern synonym and also --- in generating matcher functions, since success continuations need --- to be passed these pattern-bound evidences. -tcCollectEx - :: LPat Id - -> ( [TyVar] -- Existentially-bound type variables - -- in correctly-scoped order; e.g. [ k:*, x:k ] - , [EvVar] ) -- and evidence variables - -tcCollectEx pat = go pat - where - go :: LPat Id -> ([TyVar], [EvVar]) - go = go1 . unLoc - - go1 :: Pat Id -> ([TyVar], [EvVar]) - go1 (LazyPat p) = go p - go1 (AsPat _ p) = go p - go1 (ParPat p) = go p - go1 (BangPat p) = go p - go1 (ListPat ps _ _) = mergeMany . map go $ ps - go1 (TuplePat ps _ _) = mergeMany . map go $ ps - go1 (SumPat p _ _ _) = go p - go1 (PArrPat ps _) = mergeMany . map go $ ps - go1 (ViewPat _ p _) = go p - go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $ - goConDetails $ pat_args con - go1 (SigPatOut p _) = go p - go1 (CoPat _ p _) = go1 p - go1 (NPlusKPat n k _ geq subtract _) - = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract - go1 _ = empty - - goConDetails :: HsConPatDetails Id -> ([TyVar], [EvVar]) - goConDetails (PrefixCon ps) = mergeMany . map go $ ps - goConDetails (InfixCon p1 p2) = go p1 `merge` go p2 - goConDetails (RecCon HsRecFields{ rec_flds = flds }) - = mergeMany . map goRecFd $ flds - - goRecFd :: LHsRecField Id (LPat Id) -> ([TyVar], [EvVar]) - goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p - - merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) - mergeMany = foldr merge empty - empty = ([], []) diff --git a/typecheck/TcPatSyn.hs-boot b/typecheck/TcPatSyn.hs-boot deleted file mode 100644 --- a/typecheck/TcPatSyn.hs-boot +++ /dev/null @@ -1,19 +0,0 @@ -module TcPatSyn where - -import Name ( Name ) -import Id ( Id ) -import HsSyn ( PatSynBind, LHsBinds ) -import TcRnTypes ( TcM, TcPatSynInfo ) -import TcRnMonad ( TcGblEnv) -import Outputable ( Outputable ) - -tcInferPatSynDecl :: PatSynBind Name Name - -> TcM (LHsBinds Id, TcGblEnv) - -tcCheckPatSynDecl :: PatSynBind Name Name - -> TcPatSynInfo - -> TcM (LHsBinds Id, TcGblEnv) - -tcPatSynBuilderBind :: PatSynBind Name Name -> TcM (LHsBinds Id) - -nonBidirectionalErr :: Outputable name => name -> TcM a diff --git a/typecheck/TcPluginM.hs b/typecheck/TcPluginM.hs deleted file mode 100644 --- a/typecheck/TcPluginM.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE CPP #-} --- | This module provides an interface for typechecker plugins to --- access select functions of the 'TcM', principally those to do with --- reading parts of the state. -module TcPluginM ( -#ifdef GHCI - -- * Basic TcPluginM functionality - TcPluginM, - tcPluginIO, - tcPluginTrace, - unsafeTcPluginTcM, - - -- * Finding Modules and Names - FindResult(..), - findImportedModule, - lookupOrig, - - -- * Looking up Names in the typechecking environment - tcLookupGlobal, - tcLookupTyCon, - tcLookupDataCon, - tcLookupClass, - tcLookup, - tcLookupId, - - -- * Getting the TcM state - getTopEnv, - getEnvs, - getInstEnvs, - getFamInstEnvs, - matchFam, - - -- * Type variables - newUnique, - newFlexiTyVar, - isTouchableTcPluginM, - - -- * Zonking - zonkTcType, - zonkCt, - - -- * Creating constraints - newWanted, - newDerived, - newGiven, - newCoercionHole, - - -- * Manipulating evidence bindings - newEvVar, - setEvBind, - getEvBindsTcPluginM -#endif - ) where - -#ifdef GHCI -import qualified TcRnMonad as TcM -import qualified TcSMonad as TcS -import qualified TcEnv as TcM -import qualified TcMType as TcM -import qualified FamInst as TcM -import qualified IfaceEnv -import qualified Finder - -import FamInstEnv ( FamInstEnv ) -import TcRnMonad ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM - , unsafeTcPluginTcM, getEvBindsTcPluginM - , liftIO, traceTc ) -import TcMType ( TcTyVar, TcType ) -import TcEnv ( TcTyThing ) -import TcEvidence ( TcCoercion, CoercionHole - , EvTerm, EvBind, mkGivenEvBind ) -import TcRnTypes ( CtEvidence(..) ) -import Var ( EvVar ) - -import Module -import Name -import TyCon -import DataCon -import Class -import HscTypes -import Outputable -import Type -import Id -import InstEnv -import FastString -import Unique - - --- | Perform some IO, typically to interact with an external tool. -tcPluginIO :: IO a -> TcPluginM a -tcPluginIO a = unsafeTcPluginTcM (liftIO a) - --- | Output useful for debugging the compiler. -tcPluginTrace :: String -> SDoc -> TcPluginM () -tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) - - -findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult -findImportedModule mod_name mb_pkg = do - hsc_env <- getTopEnv - tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg - -lookupOrig :: Module -> OccName -> TcPluginM Name -lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod - - -tcLookupGlobal :: Name -> TcPluginM TyThing -tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal - -tcLookupTyCon :: Name -> TcPluginM TyCon -tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon - -tcLookupDataCon :: Name -> TcPluginM DataCon -tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon - -tcLookupClass :: Name -> TcPluginM Class -tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass - -tcLookup :: Name -> TcPluginM TcTyThing -tcLookup = unsafeTcPluginTcM . TcM.tcLookup - -tcLookupId :: Name -> TcPluginM Id -tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId - - -getTopEnv :: TcPluginM HscEnv -getTopEnv = unsafeTcPluginTcM TcM.getTopEnv - -getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) -getEnvs = unsafeTcPluginTcM TcM.getEnvs - -getInstEnvs :: TcPluginM InstEnvs -getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs - -getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv) -getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs - -matchFam :: TyCon -> [Type] - -> TcPluginM (Maybe (TcCoercion, TcType)) -matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args - -newUnique :: TcPluginM Unique -newUnique = unsafeTcPluginTcM TcM.newUnique - -newFlexiTyVar :: Kind -> TcPluginM TcTyVar -newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar - -isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool -isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM - --- Confused by zonking? See Note [What is zonking?] in TcMType. -zonkTcType :: TcType -> TcPluginM TcType -zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType - -zonkCt :: Ct -> TcPluginM Ct -zonkCt = unsafeTcPluginTcM . TcM.zonkCt - - --- | Create a new wanted constraint. -newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence -newWanted loc pty - = unsafeTcPluginTcM (TcM.newWanted (TcM.ctLocOrigin loc) Nothing pty) - --- | Create a new derived constraint. -newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence -newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc } - --- | Create a new given constraint, with the supplied evidence. This --- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it --- will panic. -newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence -newGiven loc pty evtm = do - new_ev <- newEvVar pty - setEvBind $ mkGivenEvBind new_ev evtm - return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc } - --- | Create a fresh evidence variable. -newEvVar :: PredType -> TcPluginM EvVar -newEvVar = unsafeTcPluginTcM . TcM.newEvVar - --- | Create a fresh coercion hole. -newCoercionHole :: TcPluginM CoercionHole -newCoercionHole = unsafeTcPluginTcM $ TcM.newCoercionHole - --- | Bind an evidence variable. This must not be invoked from --- 'tcPluginInit' or 'tcPluginStop', or it will panic. -setEvBind :: EvBind -> TcPluginM () -setEvBind ev_bind = do - tc_evbinds <- getEvBindsTcPluginM - unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind -#endif diff --git a/typecheck/TcRnDriver.hs b/typecheck/TcRnDriver.hs deleted file mode 100644 --- a/typecheck/TcRnDriver.hs +++ /dev/null @@ -1,2638 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcMovectle]{Typechecking a whole module} - -https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module TcRnDriver ( - tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, - tcRnImportDecls, - tcRnLookupRdrName, - getModuleInterface, - tcRnDeclsi, - isGHCiMonad, - runTcInteractive, -- Used by GHC API clients (Trac #8878) - tcRnLookupName, - tcRnGetInfo, - tcRnModule, tcRnModuleTcRnM, - tcTopSrcDecls, - rnTopSrcDecls, - checkBootDecl, checkHiBootIface', - findExtraSigImports, - implicitRequirements, - checkUnitId, - mergeSignatures, - tcRnMergeSignatures, - instantiateSignature, - tcRnInstantiateSignature, - loadUnqualIfaces, - -- More private... - badReexportedBootThing, - checkBootDeclM, - missingBootThing, - ) where - -import {-# SOURCE #-} TcSplice ( finishTH ) -import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) -import IfaceEnv( externaliseName ) -import TcHsType -import TcMatches -import Inst( deeplyInstantiate ) -import TcUnify( checkConstraints ) -import RnTypes -import RnExpr -import MkId -import TidyPgm ( globaliseAndTidyId ) -import TysWiredIn ( unitTy, mkListTy ) -#ifdef GHCI -import DynamicLoading ( loadPlugins ) -import Plugins ( tcPlugin ) -#endif - -import DynFlags -import HsSyn -import IfaceSyn ( ShowSub(..), showToHeader ) -import IfaceType( ShowForAllFlag(..) ) -import PrelNames -import RdrName -import TcHsSyn -import TcExpr -import TcRnMonad -import TcRnExports -import TcEvidence -import qualified BooleanFormula as BF -import PprTyThing( pprTyThingInContext ) -import MkIface( tyThingToIfaceDecl ) -import Coercion( pprCoAxiom ) -import CoreFVs( orphNamesOfFamInst ) -import FamInst -import InstEnv -import FamInstEnv -import TcAnnotations -import TcBinds -import HeaderInfo ( mkPrelImports ) -import TcDefaults -import TcEnv -import TcRules -import TcForeign -import TcInstDcls -import TcIface -import TcMType -import TcType -import TcSimplify -import TcTyClsDecls -import TcTypeable ( mkTypeableBinds ) -import TcBackpack -import LoadIface -import RnNames -import RnEnv -import RnSource -import ErrUtils -import Id -import VarEnv -import Module -import UniqFM -import Name -import NameEnv -import NameSet -import Avail -import TyCon -import SrcLoc -import HscTypes -import ListSetOps -import Outputable -import ConLike -import DataCon -import Type -import Class -import BasicTypes hiding( SuccessFlag(..) ) -import CoAxiom -import Annotations -import Data.List ( sortBy, sort ) -import Data.Ord -import FastString -import Maybes -import Util -import Bag -import Inst (tcGetInsts) -import qualified GHC.LanguageExtensions as LangExt -import Data.Data ( Data ) -import HsDumpAst -import qualified Data.Set as S - -import Control.Monad - -#include "HsVersions.h" - -{- -************************************************************************ -* * - Typecheck and rename a module -* * -************************************************************************ --} - --- | Top level entry point for typechecker and renamer -tcRnModule :: HscEnv - -> HscSource - -> Bool -- True <=> save renamed syntax - -> HsParsedModule - -> IO (Messages, Maybe TcGblEnv) - -tcRnModule hsc_env hsc_src save_rn_syntax - parsedModule@HsParsedModule {hpm_module=L loc this_module} - | RealSrcSpan real_loc <- loc - = withTiming (pure dflags) - (text "Renamer/typechecker"<+>brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ - withTcPlugins hsc_env $ - - tcRnModuleTcRnM hsc_env hsc_src parsedModule pair - - | otherwise - = return ((emptyBag, unitBag err_msg), Nothing) - - where - dflags = hsc_dflags hsc_env - err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $ - text "Module does not have a RealSrcSpan:" <+> ppr this_mod - - this_pkg = thisPackage (hsc_dflags hsc_env) - - pair :: (Module, SrcSpan) - pair@(this_mod,_) - | Just (L mod_loc mod) <- hsmodName this_module - = (mkModule this_pkg mod, mod_loc) - - | otherwise -- 'module M where' is omitted - = (mAIN, srcLocSpan (srcSpanStart loc)) - - - - -tcRnModuleTcRnM :: HscEnv - -> HscSource - -> HsParsedModule - -> (Module, SrcSpan) - -> TcRn TcGblEnv --- Factored out separately from tcRnModule so that a Core plugin can --- call the type checker directly -tcRnModuleTcRnM hsc_env hsc_src - (HsParsedModule { - hpm_module = - (L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec - maybe_doc_hdr)), - hpm_src_files = src_files - }) - (this_mod, prel_imp_loc) - = setSrcSpan loc $ - do { let { explicit_mod_hdr = isJust maybe_mod } ; - - -- Load the hi-boot interface for this module, if any - -- We do this now so that the boot_names can be passed - -- to tcTyAndClassDecls, because the boot_names are - -- automatically considered to be loop breakers - tcg_env <- getGblEnv ; - boot_info <- tcHiBootIface hsc_src this_mod ; - setGblEnv (tcg_env { tcg_self_boot = boot_info }) $ do { - - -- Deal with imports; first add implicit prelude - implicit_prelude <- xoptM LangExt.ImplicitPrelude; - let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc - implicit_prelude import_decls } ; - - whenWOptM Opt_WarnImplicitPrelude $ - when (notNull prel_imports) $ - addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) ; - - -- TODO This is a little skeevy; maybe handle a bit more directly - let { simplifyImport (L _ idecl) = (fmap sl_fs (ideclPkgQual idecl), ideclName idecl) } ; - raw_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src (moduleName this_mod) ; - raw_req_imports <- liftIO $ - implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls)) ; - let { mkImport (Nothing, L _ mod_name) = noLoc $ (simpleImportDecl mod_name) { - ideclHiding = Just (False, noLoc []) - } ; - mkImport _ = panic "mkImport" } ; - - let { all_imports = prel_imports ++ import_decls - ++ map mkImport (raw_sig_imports ++ raw_req_imports) } ; - - -- OK now finally rename the imports - tcg_env <- {-# SCC "tcRnImports" #-} - tcRnImports hsc_env all_imports ; - - -- If the whole module is warned about or deprecated - -- (via mod_deprec) record that in tcg_warns. If we do thereby add - -- a WarnAll, it will override any subseqent depracations added to tcg_warns - let { tcg_env1 = case mod_deprec of - Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt } - Nothing -> tcg_env - } ; - - setGblEnv tcg_env1 $ do { - - -- Rename and type check the declarations - traceRn "rn1a" empty ; - tcg_env <- if isHsBootOrSig hsc_src then - tcRnHsBootDecls hsc_src local_decls - else - {-# SCC "tcRnSrcDecls" #-} - tcRnSrcDecls explicit_mod_hdr local_decls ; - setGblEnv tcg_env $ do { - - -- Process the export list - traceRn "rn4a: before exports" empty; - tcg_env <- tcRnExports explicit_mod_hdr export_ies tcg_env ; - traceRn "rn4b: after exports" empty ; - - -- Check that main is exported (must be after tcRnExports) - checkMainExported tcg_env ; - - -- Compare the hi-boot iface (if any) with the real thing - -- Must be done after processing the exports - tcg_env <- checkHiBootIface tcg_env boot_info ; - - -- The new type env is already available to stuff slurped from - -- interface files, via TcEnv.setGlobalTypeEnv - -- It's important that this includes the stuff in checkHiBootIface, - -- because the latter might add new bindings for boot_dfuns, - -- which may be mentioned in imported unfoldings - - -- Don't need to rename the Haddock documentation, - -- it's not parsed by GHC anymore. - tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; - - -- Report unused names - -- Do this /after/ type inference, so that when reporting - -- a function with no type signature we can give the - -- inferred type - reportUnusedNames export_ies tcg_env ; - - -- add extra source files to tcg_dependent_files - addDependentFiles src_files ; - - -- Dump output and return - tcDump tcg_env ; - return tcg_env - }}}} - -implicitPreludeWarn :: SDoc -implicitPreludeWarn - = text "Module `Prelude' implicitly imported" - -{- -************************************************************************ -* * - Import declarations -* * -************************************************************************ --} - -tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv -tcRnImports hsc_env import_decls - = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; - - ; this_mod <- getModule - ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) - ; dep_mods = imp_dep_mods imports - - -- We want instance declarations from all home-package - -- modules below this one, including boot modules, except - -- ourselves. The 'except ourselves' is so that we don't - -- get the instances from this module's hs-boot file. This - -- filtering also ensures that we don't see instances from - -- modules batch (@--make@) compiled before this one, but - -- which are not below this one. - ; want_instances :: ModuleName -> Bool - ; want_instances mod = mod `elemUFM` dep_mods - && mod /= moduleName this_mod - ; (home_insts, home_fam_insts) = hptInstances hsc_env - want_instances - } ; - - -- Record boot-file info in the EPS, so that it's - -- visible to loadHiBootInterface in tcRnSrcDecls, - -- and any other incrementally-performed imports - ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; - - -- Update the gbl env - ; updGblEnv ( \ gbl -> - gbl { - tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = rn_imports, - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) - home_fam_insts, - tcg_hpc = hpc_info - }) $ do { - - ; traceRn "rn1" (ppr (imp_dep_mods imports)) - -- Fail if there are any errors so far - -- The error printing (if needed) takes advantage - -- of the tcg_env we have now set --- ; traceIf (text "rdr_env: " <+> ppr rdr_env) - ; failIfErrsM - - -- Load any orphan-module (including orphan family - -- instance-module) interfaces, so that their rules and - -- instance decls will be found. But filter out a - -- self hs-boot: these instances will be checked when - -- we define them locally. - -- (We don't need to load non-orphan family instance - -- modules until we either try to use the instances they - -- define, or define our own family instances, at which - -- point we need to check them for consistency.) - ; loadModuleInterfaces (text "Loading orphan modules") - (filter (/= this_mod) (imp_orphs imports)) - - -- Check type-family consistency between imports. - -- See Note [The type family instance consistency story] - ; traceRn "rn1: checking family instance consistency" empty - ; let { dir_imp_mods = moduleEnvKeys - . imp_mods - $ imports } - ; tcg_env <- checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; - - ; return tcg_env } } - -{- -************************************************************************ -* * - Type-checking the top level of a module -* * -************************************************************************ --} - -tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all - -> [LHsDecl RdrName] -- Declarations - -> TcM TcGblEnv -tcRnSrcDecls explicit_mod_hdr decls - = do { -- Do all the declarations - ; ((tcg_env, tcl_env), lie) <- captureTopConstraints $ - do { (tcg_env, tcl_env) <- tc_rn_src_decls decls - - -- Check for the 'main' declaration - -- Must do this inside the captureTopConstraints - ; tcg_env <- setEnvs (tcg_env, tcl_env) $ - checkMain explicit_mod_hdr - ; return (tcg_env, tcl_env) } - - ; setEnvs (tcg_env, tcl_env) $ do { - - -- Simplify constraints - -- - -- We do this after checkMain, so that we use the type info - -- that checkMain adds - -- - -- We do it with both global and local env in scope: - -- * the global env exposes the instances to simplifyTop - -- * the local env exposes the local Ids to simplifyTop, - -- so that we get better error messages (monomorphism restriction) - ; new_ev_binds <- {-# SCC "simplifyTop" #-} - simplifyTop lie - - -- Emit Typeable bindings - ; tcg_env <- mkTypeableBinds - - -- Finalizers must run after constraints are simplified, or some types - -- might not be complete when using reify (see #12777). - ; (tcg_env, tcl_env) <- setGblEnv tcg_env run_th_modfinalizers - ; setEnvs (tcg_env, tcl_env) $ do { - - ; finishTH - - ; traceTc "Tc9" empty - - ; failIfErrsM -- Don't zonk if there have been errors - -- It's a waste of time; and we may get debug warnings - -- about strangely-typed TyCons! - ; traceTc "Tc10" empty - - -- Zonk the final code. This must be done last. - -- Even simplifyTop may do some unification. - -- This pass also warns about missing type signatures - ; let { TcGblEnv { tcg_type_env = type_env, - tcg_binds = binds, - tcg_ev_binds = cur_ev_binds, - tcg_imp_specs = imp_specs, - tcg_rules = rules, - tcg_vects = vects, - tcg_fords = fords } = tcg_env - ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; - - ; (bind_env, ev_binds', binds', fords', imp_specs', rules', vects') - <- {-# SCC "zonkTopDecls" #-} - zonkTopDecls all_ev_binds binds rules vects - imp_specs fords ; - ; traceTc "Tc11" empty - - ; let { final_type_env = plusTypeEnv type_env bind_env - ; tcg_env' = tcg_env { tcg_binds = binds', - tcg_ev_binds = ev_binds', - tcg_imp_specs = imp_specs', - tcg_rules = rules', - tcg_vects = vects', - tcg_fords = fords' } } ; - - ; setGlobalTypeEnv tcg_env' final_type_env - - } - } } - --- | Runs TH finalizers and renames and typechecks the top-level declarations --- that they could introduce. -run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv) -run_th_modfinalizers = do - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - th_modfinalizers <- readTcRef th_modfinalizers_var - if null th_modfinalizers - then getEnvs - else do - writeTcRef th_modfinalizers_var [] - (envs, lie) <- captureTopConstraints $ do - sequence_ th_modfinalizers - -- Finalizers can add top-level declarations with addTopDecls. - tc_rn_src_decls [] - setEnvs envs $ do - -- Subsequent rounds of finalizers run after any new constraints are - -- simplified, or some types might not be complete when using reify - -- (see #12777). - new_ev_binds <- {-# SCC "simplifyTop2" #-} - simplifyTop lie - updGblEnv (\tcg_env -> - tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env `unionBags` new_ev_binds } - ) - -- addTopDecls can add declarations which add new finalizers. - run_th_modfinalizers - -tc_rn_src_decls :: [LHsDecl RdrName] - -> TcM (TcGblEnv, TcLclEnv) --- Loops around dealing with each top level inter-splice group --- in turn, until it's dealt with the entire module -tc_rn_src_decls ds - = {-# SCC "tc_rn_src_decls" #-} - do { (first_group, group_tail) <- findSplice ds - -- If ds is [] we get ([], Nothing) - - -- Deal with decls up to, but not including, the first splice - ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group - -- rnTopSrcDecls fails if there are any errors - - -- Get TH-generated top-level declarations and make sure they don't - -- contain any splices since we don't handle that at the moment - -- - -- The plumbing here is a bit odd: see Trac #10853 - ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv - ; th_ds <- readTcRef th_topdecls_var - ; writeTcRef th_topdecls_var [] - - ; (tcg_env, rn_decls) <- - if null th_ds - then return (tcg_env, rn_decls) - else do { (th_group, th_group_tail) <- findSplice th_ds - ; case th_group_tail of - { Nothing -> return () ; - ; Just (SpliceDecl (L loc _) _, _) - -> setSrcSpan loc $ - addErr (text "Declaration splices are not permitted inside top-level declarations added with addTopDecls") - } ; - - -- Rename TH-generated top-level declarations - ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $ - rnTopSrcDecls th_group - - -- Dump generated top-level declarations - ; let msg = "top-level declarations added with addTopDecls" - ; traceSplice $ SpliceInfo { spliceDescription = msg - , spliceIsDecl = True - , spliceSource = Nothing - , spliceGenerated = ppr th_rn_decls } - - ; return (tcg_env, appendGroups rn_decls th_rn_decls) - } - - -- Type check all declarations - ; (tcg_env, tcl_env) <- setGblEnv tcg_env $ - tcTopSrcDecls rn_decls - - -- If there is no splice, we're nearly done - ; setEnvs (tcg_env, tcl_env) $ - case group_tail of - { Nothing -> return (tcg_env, tcl_env) - - -- If there's a splice, we must carry on - ; Just (SpliceDecl (L loc splice) _, rest_ds) -> - do { recordTopLevelSpliceLoc loc - - -- Rename the splice expression, and get its supporting decls - ; (spliced_decls, splice_fvs) <- checkNoErrs (rnTopSpliceDecls - splice) - - -- Glue them on the front of the remaining decls and loop - ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - tc_rn_src_decls (spliced_decls ++ rest_ds) - } - } - } - -{- -************************************************************************ -* * - Compiling hs-boot source files, and - comparing the hi-boot interface with the real thing -* * -************************************************************************ --} - -tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv -tcRnHsBootDecls hsc_src decls - = do { (first_group, group_tail) <- findSplice decls - - -- Rename the declarations - ; (tcg_env, HsGroup { hs_tyclds = tycl_decls - , hs_derivds = deriv_decls - , hs_fords = for_decls - , hs_defds = def_decls - , hs_ruleds = rule_decls - , hs_vects = vect_decls - , hs_annds = _ - , hs_valds = ValBindsOut val_binds val_sigs }) - <- rnTopSrcDecls first_group - -- The empty list is for extra dependencies coming from .hs-boot files - -- See Note [Extra dependencies from .hs-boot files] in RnSource - ; (gbl_env, lie) <- captureTopConstraints $ setGblEnv tcg_env $ do { - - - -- Check for illegal declarations - ; case group_tail of - Just (SpliceDecl d _, _) -> badBootDecl hsc_src "splice" d - Nothing -> return () - ; mapM_ (badBootDecl hsc_src "foreign") for_decls - ; mapM_ (badBootDecl hsc_src "default") def_decls - ; mapM_ (badBootDecl hsc_src "rule") rule_decls - ; mapM_ (badBootDecl hsc_src "vect") vect_decls - - -- Typecheck type/class/instance decls - ; traceTc "Tc2 (boot)" empty - ; (tcg_env, inst_infos, _deriv_binds) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds - ; setGblEnv tcg_env $ do { - - -- Emit Typeable bindings - ; tcg_env <- mkTypeableBinds - ; setGblEnv tcg_env $ do { - - -- Typecheck value declarations - ; traceTc "Tc5" empty - ; val_ids <- tcHsBootSigs val_binds val_sigs - - -- Wrap up - -- No simplification or zonking to do - ; traceTc "Tc7a" empty - ; gbl_env <- getGblEnv - - -- Make the final type-env - -- Include the dfun_ids so that their type sigs - -- are written into the interface file. - ; let { type_env0 = tcg_type_env gbl_env - ; type_env1 = extendTypeEnvWithIds type_env0 val_ids - ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos - } - - ; setGlobalTypeEnv gbl_env type_env2 - }}} - ; traceTc "boot" (ppr lie); return gbl_env } - -badBootDecl :: HscSource -> String -> Located decl -> TcM () -badBootDecl hsc_src what (L loc _) - = addErrAt loc (char 'A' <+> text what - <+> text "declaration is not (currently) allowed in a" - <+> (case hsc_src of - HsBootFile -> text "hs-boot" - HsigFile -> text "hsig" - _ -> panic "badBootDecl: should be an hsig or hs-boot file") - <+> text "file") - -{- -Once we've typechecked the body of the module, we want to compare what -we've found (gathered in a TypeEnv) with the hi-boot details (if any). --} - -checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv --- Compare the hi-boot file for this module (if there is one) --- with the type environment we've just come up with --- In the common case where there is no hi-boot file, the list --- of boot_names is empty. - -checkHiBootIface tcg_env boot_info - | NoSelfBoot <- boot_info -- Common case - = return tcg_env - - | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file! - = return tcg_env - - | SelfBoot { sb_mds = boot_details } <- boot_info - , TcGblEnv { tcg_binds = binds - , tcg_insts = local_insts - , tcg_type_env = local_type_env - , tcg_exports = local_exports } <- tcg_env - = do { -- This code is tricky, see Note [DFun knot-tying] - ; let boot_dfuns = filter isDFunId (typeEnvIds (md_types boot_details)) - type_env' = extendTypeEnvWithIds local_type_env boot_dfuns - -- Why the seq? Without, we will put a TypeEnv thunk in - -- tcg_type_env_var. That thunk will eventually get - -- forced if we are typechecking interfaces, but that - -- is no good if we are trying to typecheck the very - -- DFun we were going to put in. - -- TODO: Maybe setGlobalTypeEnv should be strict. - ; tcg_env <- type_env' `seq` setGlobalTypeEnv tcg_env type_env' - ; dfun_prs <- checkHiBootIface' local_insts type_env' - local_exports boot_details - ; let dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - - ; return tcg_env { tcg_binds = binds `unionBags` dfun_binds } } - - | otherwise = panic "checkHiBootIface: unreachable code" - --- Note [DFun knot-tying] --- ~~~~~~~~~~~~~~~~~~~~~~ --- The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes --- from typechecking the hi-boot file that we are presently --- implementing. Suppose we are typechecking the module A: --- when we typecheck the hi-boot file, whenever we see an --- identifier A.T, we knot-tie this identifier to the --- *local* type environment (via if_rec_types.) The contract --- then is that we don't *look* at 'SelfBootInfo' until --- we've finished typechecking the module and updated the --- type environment with the new tycons and ids. --- --- This most works well, but there is one problem: DFuns! --- In general, it's not possible to know a priori what an --- hs-boot file named a DFun (see Note [DFun impedance matching]), --- so we look at the ClsInsts from the boot file to figure out --- what DFuns to add to the type environment. But we're not --- allowed to poke the DFuns of the ClsInsts in the SelfBootInfo --- until we've added the DFuns to the type environment. A --- Gordian knot! --- --- We cut the knot by a little trick: we first *unconditionally* --- add all of the boot-declared DFuns to the type environment --- (so that knot tying works, see Trac #4003), without the --- actual bindings for them. Then, we compute the impedance --- matching bindings, and add them to the environment. --- --- There is one subtlety to doing this: we have to get the --- DFuns from md_types, not md_insts, even though involves --- filtering a bunch of TyThings we don't care about. The --- reason is only the TypeEnv in md_types has the actual --- Id we want to add to the environment; the DFun fields --- in md_insts are typechecking thunks that will attempt to --- go through if_rec_types to lookup the real Id... but --- that's what we're trying to setup right now. - -checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] - -> ModDetails -> TcM [(Id, Id)] --- Variant which doesn't require a full TcGblEnv; you could get the --- local components from another ModDetails. --- --- Note [DFun impedance matching] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- We return a list of "impedance-matching" bindings for the dfuns --- defined in the hs-boot file, such as --- $fxEqT = $fEqT --- We need these because the module and hi-boot file might differ in --- the name it chose for the dfun: the name of a dfun is not --- uniquely determined by its type; there might be multiple dfuns --- which, individually, would map to the same name (in which case --- we have to disambiguate them.) There's no way for the hi file --- to know exactly what disambiguation to use... without looking --- at the hi-boot file itself. --- --- In fact, the names will always differ because we always pick names --- prefixed with "$fx" for boot dfuns, and "$f" for real dfuns --- (so that this impedance matching is always possible). - -checkHiBootIface' - local_insts local_type_env local_exports - (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, - md_types = boot_type_env, md_exports = boot_exports }) - = do { traceTc "checkHiBootIface" $ vcat - [ ppr boot_type_env, ppr boot_insts, ppr boot_exports] - - -- Check the exports of the boot module, one by one - ; mapM_ check_export boot_exports - - -- Check for no family instances - ; unless (null boot_fam_insts) $ - panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ - "instances in boot files yet...") - -- FIXME: Why? The actual comparison is not hard, but what would - -- be the equivalent to the dfun bindings returned for class - -- instances? We can't easily equate tycons... - - -- Check instance declarations - -- and generate an impedance-matching binding - ; mb_dfun_prs <- mapM check_inst boot_insts - - ; failIfErrsM - - ; return (catMaybes mb_dfun_prs) } - - where - check_export boot_avail -- boot_avail is exported by the boot iface - | name `elem` dfun_names = return () - | isWiredInName name = return () -- No checking for wired-in names. In particular, - -- 'error' is handled by a rather gross hack - -- (see comments in GHC.Err.hs-boot) - - -- Check that the actual module exports the same thing - | not (null missing_names) - = addErrAt (nameSrcSpan (head missing_names)) - (missingBootThing True (head missing_names) "exported by") - - -- If the boot module does not *define* the thing, we are done - -- (it simply re-exports it, and names match, so nothing further to do) - | isNothing mb_boot_thing = return () - - -- Check that the actual module also defines the thing, and - -- then compare the definitions - | Just real_thing <- lookupTypeEnv local_type_env name, - Just boot_thing <- mb_boot_thing - = checkBootDeclM True boot_thing real_thing - - | otherwise - = addErrTc (missingBootThing True name "defined in") - where - name = availName boot_avail - mb_boot_thing = lookupTypeEnv boot_type_env name - missing_names = case lookupNameEnv local_export_env name of - Nothing -> [name] - Just avail -> availNames boot_avail `minusList` availNames avail - - dfun_names = map getName boot_insts - - local_export_env :: NameEnv AvailInfo - local_export_env = availsToNameEnv local_exports - - check_inst :: ClsInst -> TcM (Maybe (Id, Id)) - -- Returns a pair of the boot dfun in terms of the equivalent - -- real dfun. Delicate (like checkBootDecl) because it depends - -- on the types lining up precisely even to the ordering of - -- the type variables in the foralls. - check_inst boot_inst - = case [dfun | inst <- local_insts, - let dfun = instanceDFunId inst, - idType dfun `eqType` boot_dfun_ty ] of - [] -> do { traceTc "check_inst" $ vcat - [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) - , text "boot_inst" <+> ppr boot_inst - , text "boot_dfun_ty" <+> ppr boot_dfun_ty - ] - ; addErrTc (instMisMatch True boot_inst) - ; return Nothing } - (dfun:_) -> return (Just (local_boot_dfun, dfun)) - where - local_boot_dfun = Id.mkExportedVanillaId boot_dfun_name (idType dfun) - -- Name from the /boot-file/ ClsInst, but type from the dfun - -- defined in /this module/. That ensures that the TyCon etc - -- inside the type are the ones defined in this module, not - -- the ones gotten from the hi-boot file, which may have - -- a lot less info (Trac #T8743, comment:10). - where - boot_dfun = instanceDFunId boot_inst - boot_dfun_ty = idType boot_dfun - boot_dfun_name = idName boot_dfun - --- In general, to perform these checks we have to --- compare the TyThing from the .hi-boot file to the TyThing --- in the current source file. We must be careful to allow alpha-renaming --- where appropriate, and also the boot declaration is allowed to omit --- constructors and class methods. --- --- See rnfail055 for a good test of this stuff. - --- | Compares two things for equivalence between boot-file and normal code, --- reporting an error if they don't match up. -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -checkBootDeclM is_boot boot_thing real_thing - = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err -> - addErrAt span - (bootMisMatch is_boot err real_thing boot_thing) - where - -- Here we use the span of the boot thing or, if it doesn't have a sensible - -- span, that of the real thing, - span - | let span = nameSrcSpan (getName boot_thing) - , isGoodSrcSpan span - = span - | otherwise - = nameSrcSpan (getName real_thing) - --- | Compares the two things for equivalence between boot-file and normal --- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ --- failure. If the difference will be apparent to the user, @Just empty@ is --- perfectly suitable. -checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc - -checkBootDecl _ (AnId id1) (AnId id2) - = ASSERT(id1 == id2) - check (idType id1 `eqType` idType id2) - (text "The two types are different") - -checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2) - = checkBootTyCon is_boot tc1 tc2 - -checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) - = pprPanic "checkBootDecl" (ppr dc1) - -checkBootDecl _ _ _ = Just empty -- probably shouldn't happen - --- | Combines two potential error messages -andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc -Nothing `andThenCheck` msg = msg -msg `andThenCheck` Nothing = msg -Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2) -infixr 0 `andThenCheck` - --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, return the provided check -checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc -checkUnless True _ = Nothing -checkUnless False k = k - --- | Run the check provided for every pair of elements in the lists. --- The provided SDoc should name the element type, in the plural. -checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc - -> Maybe SDoc -checkListBy check_fun as bs whats = go [] as bs - where - herald = text "The" <+> whats <+> text "do not match" - - go [] [] [] = Nothing - go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs)) - go docs (x:xs) (y:ys) = case check_fun x y of - Just doc -> go (doc:docs) xs ys - Nothing -> go docs xs ys - go _ _ _ = Just (hang (herald <> colon) - 2 (text "There are different numbers of" <+> whats)) - --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, fail with the given SDoc. -check :: Bool -> SDoc -> Maybe SDoc -check True _ = Nothing -check False doc = Just doc - --- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends. -checkSuccess :: Maybe SDoc -checkSuccess = Nothing - ----------------- -checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc -checkBootTyCon is_boot tc1 tc2 - | not (eqType (tyConKind tc1) (tyConKind tc2)) - = Just $ text "The types have different kinds" -- First off, check the kind - - | Just c1 <- tyConClass_maybe tc1 - , Just c2 <- tyConClass_maybe tc2 - , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1) - = classExtraBigSig c1 - (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) - = classExtraBigSig c2 - , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 - = let - eqSig (id1, def_meth1) (id2, def_meth2) - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "are different") `andThenCheck` - check (eqTypeX env op_ty1 op_ty2) - (text "The types of" <+> pname1 <+> - text "are different") `andThenCheck` - if is_boot - then check (eqMaybeBy eqDM def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are different") - else check (subDM op_ty1 def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are not compatible") - where - name1 = idName id1 - name2 = idName id2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - (_, rho_ty1) = splitForAllTys (idType id1) - op_ty1 = funResultTy rho_ty1 - (_, rho_ty2) = splitForAllTys (idType id2) - op_ty2 = funResultTy rho_ty2 - - eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) - = checkBootTyCon is_boot tc1 tc2 `andThenCheck` - check (eqATDef def_ats1 def_ats2) - (text "The associated type defaults differ") - - eqDM (_, VanillaDM) (_, VanillaDM) = True - eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2 - eqDM _ _ = False - - -- NB: first argument is from hsig, second is from real impl. - -- Order of pattern matching matters. - subDM _ Nothing _ = True - subDM _ _ Nothing = False - -- If the hsig wrote: - -- - -- f :: a -> a - -- default f :: a -> a - -- - -- this should be validly implementable using an old-fashioned - -- vanilla default method. - subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM)) - = eqTypeX env t1 t2 - -- This case can occur when merging signatures - subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True - subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - - -- Ignore the location of the defaults - eqATDef Nothing Nothing = True - eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 - eqATDef _ _ = False - - eqFD (as1,bs1) (as2,bs2) = - eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) - in - checkRoles roles1 roles2 `andThenCheck` - -- Checks kind of class - check (eqListBy eqFD clas_fds1 clas_fds2) - (text "The functional dependencies do not match") `andThenCheck` - checkUnless (isAbstractTyCon tc1) $ - check (eqListBy (eqTypeX env) sc_theta1 sc_theta2) - (text "The class constraints do not match") `andThenCheck` - checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` - checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck` - check (classMinimalDef c1 `BF.implies` classMinimalDef c2) - (text "The MINIMAL pragmas are not compatible") - - | Just syn_rhs1 <- synTyConRhs_maybe tc1 - , Just syn_rhs2 <- synTyConRhs_maybe tc2 - , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) - = ASSERT(tc1 == tc2) - checkRoles roles1 roles2 `andThenCheck` - check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say - - -- This allows abstract 'data T a' to be implemented using 'type T = ...' - -- and abstract 'class K a' to be implement using 'type K = ...' - -- See Note [Synonyms implement abstract data] - | not is_boot -- don't support for hs-boot yet - , isAbstractTyCon tc1 - , Just (tvs, ty) <- synTyConDefn_maybe tc2 - , Just (tc2', args) <- tcSplitTyConApp_maybe ty - = checkSynAbsData tvs ty tc2' args - -- TODO: When it's a synonym implementing a class, we really - -- should check if the fundeps are satisfied, but - -- there is not an obvious way to do this for a constraint synonym. - -- So for now, let it all through (it won't cause segfaults, anyway). - -- Tracked at #12704. - - | Just fam_flav1 <- famTyConFlav_maybe tc1 - , Just fam_flav2 <- famTyConFlav_maybe tc2 - = ASSERT(tc1 == tc2) - let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True - eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True - -- This case only happens for hsig merging: - eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True - eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True - eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True - eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) - = eqClosedFamilyAx ax1 ax2 - eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2 - eqFamFlav _ _ = False - injInfo1 = familyTyConInjectivityInfo tc1 - injInfo2 = familyTyConInjectivityInfo tc2 - in - -- check equality of roles, family flavours and injectivity annotations - -- (NB: Type family roles are always nominal. But the check is - -- harmless enough.) - checkRoles roles1 roles2 `andThenCheck` - check (eqFamFlav fam_flav1 fam_flav2) - (ifPprDebug $ - text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+> - text "do not match") `andThenCheck` - check (injInfo1 == injInfo2) (text "Injectivities do not match") - - | isAlgTyCon tc1 && isAlgTyCon tc2 - , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) - = ASSERT(tc1 == tc2) - checkRoles roles1 roles2 `andThenCheck` - check (eqListBy (eqTypeX env) - (tyConStupidTheta tc1) (tyConStupidTheta tc2)) - (text "The datatype contexts do not match") `andThenCheck` - eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) - - | otherwise = Just empty -- two very different types -- should be obvious - where - roles1 = tyConRoles tc1 -- the abstract one - roles2 = tyConRoles tc2 - roles_msg = text "The roles do not match." $$ - (text "Roles on abstract types default to" <+> - quotes (text "representational") <+> text "in boot files.") - - roles_subtype_msg = text "The roles are not compatible:" $$ - text "Main module:" <+> ppr roles2 $$ - text "Hsig file:" <+> ppr roles1 - - checkRoles r1 r2 - | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping] - = check (r1 == r2) roles_msg - | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg - - -- Note [Role subtyping] - -- ~~~~~~~~~~~~~~~~~~~~~ - -- In the current formulation of roles, role subtyping is only OK if the - -- "abstract" TyCon was not representationally injective. Among the most - -- notable examples of non representationally injective TyCons are abstract - -- data, which can be implemented via newtypes (which are not - -- representationally injective). The key example is - -- in this example from #13140: - -- - -- -- In an hsig file - -- data T a -- abstract! - -- type role T nominal - -- - -- -- Elsewhere - -- foo :: Coercible (T a) (T b) => a -> b - -- foo x = x - -- - -- We must NOT allow foo to typecheck, because if we instantiate - -- T with a concrete data type with a phantom role would cause - -- Coercible (T a) (T b) to be provable. Fortunately, if T is not - -- representationally injective, we cannot make the inference that a ~N b if - -- T a ~R T b. - -- - -- Unconditional role subtyping would be possible if we setup - -- an extra set of roles saying when we can project out coercions - -- (we call these proj-roles); then it would NOT be valid to instantiate T - -- with a data type at phantom since the proj-role subtyping check - -- would fail. See #13140 for more details. - -- - -- One consequence of this is we get no role subtyping for non-abstract - -- data types in signatures. Suppose you have: - -- - -- signature A where - -- type role T nominal - -- data T a = MkT - -- - -- If you write this, we'll treat T as injective, and make inferences - -- like T a ~R T b ==> a ~N b (mkNthCo). But if we can - -- subsequently replace T with one at phantom role, we would then be able to - -- infer things like T Int ~R T Bool which is bad news. - -- - -- We could allow role subtyping here if we didn't treat *any* data types - -- defined in signatures as injective. But this would be a bit surprising, - -- replacing a data type in a module with one in a signature could cause - -- your code to stop typechecking (whereas if you made the type abstract, - -- it is more understandable that the type checker knows less). - -- - -- It would have been best if this was purely a question of defaults - -- (i.e., a user could explicitly ask for one behavior or another) but - -- the current role system isn't expressive enough to do this. - -- Having explict proj-roles would solve this problem. - - rolesSubtypeOf [] [] = True - -- NB: this relation is the OPPOSITE of the subroling relation - rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys - rolesSubtypeOf _ _ = False - - -- Note [Synonyms implement abstract data] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- An abstract data type or class can be implemented using a type synonym, - -- but ONLY if the type synonym is nullary and has no type family - -- applications. This arises from two properties of skolem abstract data: - -- - -- For any T (with some number of paramaters), - -- - -- 1. T is a valid type (it is "curryable"), and - -- - -- 2. T is valid in an instance head (no type families). - -- - -- See also 'HowAbstract' and Note [Skolem abstract data]. - - -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@, - -- check that this synonym is an acceptable implementation of @tc1@. - -- See Note [Synonyms implement abstract data] - checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc - checkSynAbsData tvs ty tc2' args = - check (null (tcTyFamInsts ty)) - (text "Illegal type family application in implementation of abstract data.") - `andThenCheck` - check (null tvs) - (text "Illegal parameterized type synonym in implementation of abstract data." $$ - text "(Try eta reducing your type synonym so that it is nullary.)") - `andThenCheck` - -- Don't report roles errors unless the type synonym is nullary - checkUnless (not (null tvs)) $ - ASSERT( null roles2 ) - -- If we have something like: - -- - -- signature H where - -- data T a - -- module H where - -- data K a b = ... - -- type T = K Int - -- - -- we need to drop the first role of K when comparing! - checkRoles roles1 (drop (length args) (tyConRoles tc2')) -{- - -- Hypothetically, if we were allow to non-nullary type synonyms, here - -- is how you would check the roles - if length tvs == length roles1 - then checkRoles roles1 roles2 - else case tcSplitTyConApp_maybe ty of - Just (tc2', args) -> - checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2) - Nothing -> Just roles_msg --} - - eqAlgRhs _ AbstractTyCon _rhs2 - = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon - eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = - checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") - eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} = - eqCon (data_con tc1) (data_con tc2) - eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+> - text "definition with a" <+> quotes (text "newtype") <+> - text "definition") - - eqCon c1 c2 - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "differ") `andThenCheck` - check (dataConIsInfix c1 == dataConIsInfix c2) - (text "The fixities of" <+> pname1 <+> - text "differ") `andThenCheck` - check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) - (text "The strictness annotations for" <+> pname1 <+> - text "differ") `andThenCheck` - check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) - (text "The record label lists for" <+> pname1 <+> - text "differ") `andThenCheck` - check (eqType (dataConUserType c1) (dataConUserType c2)) - (text "The types for" <+> pname1 <+> text "differ") - where - name1 = dataConName c1 - name2 = dataConName c2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - - eqClosedFamilyAx Nothing Nothing = True - eqClosedFamilyAx Nothing (Just _) = False - eqClosedFamilyAx (Just _) Nothing = False - eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 })) - (Just (CoAxiom { co_ax_branches = branches2 })) - = numBranches branches1 == numBranches branches2 - && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2) - where - branch_list1 = fromBranches branches1 - branch_list2 = fromBranches branches2 - - eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 - , cab_lhs = lhs1, cab_rhs = rhs1 }) - (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 - , cab_lhs = lhs2, cab_rhs = rhs2 }) - | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 - , Just env <- eqVarBndrs env1 cvs1 cvs2 - = eqListBy (eqTypeX env) lhs1 lhs2 && - eqTypeX env rhs1 rhs2 - - | otherwise = False - -emptyRnEnv2 :: RnEnv2 -emptyRnEnv2 = mkRnEnv2 emptyInScopeSet - ----------------- -missingBootThing :: Bool -> Name -> String -> SDoc -missingBootThing is_boot name what - = quotes (ppr name) <+> text "is exported by the" - <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file, but not" - <+> text what <+> text "the module" - -badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc -badReexportedBootThing dflags is_boot name name' - = withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ vcat - [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file (re)exports" <+> quotes (ppr name) - , text "but the implementing module exports a different identifier" <+> quotes (ppr name') - ] - -bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc -bootMisMatch is_boot extra_info real_thing boot_thing - = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc - where - to_doc - = pprTyThingInContext $ showToHeader { ss_forall = - if is_boot - then ShowForAllMust - else ShowForAllWhen } - - real_doc = to_doc real_thing - boot_doc = to_doc boot_thing - - pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc - pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc - = vcat - [ ppr real_thing <+> - text "has conflicting definitions in the module", - text "and its" <+> - (if is_boot - then text "hs-boot file" - else text "hsig file"), - text "Main module:" <+> real_doc, - (if is_boot - then text "Boot file: " - else text "Hsig file: ") - <+> boot_doc, - extra_info - ] - -instMisMatch :: Bool -> ClsInst -> SDoc -instMisMatch is_boot inst - = hang (ppr inst) - 2 (text "is defined in the" <+> - (if is_boot then text "hs-boot" else text "hsig") - <+> text "file, but not in the module itself") - -{- -************************************************************************ -* * - Type-checking the top level of a module (continued) -* * -************************************************************************ --} - -rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) --- Fails if there are any errors -rnTopSrcDecls group - = do { -- Rename the source decls - traceRn "rn12" empty ; - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; - traceRn "rn13" empty ; - - -- save the renamed syntax, if we want it - let { tcg_env' - | Just grp <- tcg_rn_decls tcg_env - = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } - | otherwise - = tcg_env }; - - -- Dump trace of renaming part - rnDump rn_decls ; - return (tcg_env', rn_decls) - } - -tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, - hs_derivds = deriv_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_annds = annotation_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls, - hs_valds = hs_val_binds@(ValBindsOut val_binds val_sigs) }) - = do { -- Type-check the type and class decls, and all imported decls - -- The latter come in via tycl_decls - traceTc "Tc2 (src)" empty ; - - -- Source-language instances, including derivings, - -- and import the supporting declarations - traceTc "Tc3" empty ; - (tcg_env, inst_infos, ValBindsOut deriv_binds deriv_sigs) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; - - setGblEnv tcg_env $ do { - - -- Generate Applicative/Monad proposal (AMP) warnings - traceTc "Tc3b" empty ; - - -- Generate Semigroup/Monoid warnings - traceTc "Tc3c" empty ; - tcSemigroupWarnings ; - - -- Foreign import declarations next. - traceTc "Tc4" empty ; - (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; - tcExtendGlobalValEnv fi_ids $ do { - - -- Default declarations - traceTc "Tc4a" empty ; - default_tys <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { - - -- Value declarations next. - -- It is important that we check the top-level value bindings - -- before the GHC-generated derived bindings, since the latter - -- may be defined in terms of the former. (For instance, - -- the bindings produced in a Data instance.) - traceTc "Tc5" empty ; - tc_envs <- tcTopBinds val_binds val_sigs; - setEnvs tc_envs $ do { - - -- Now GHC-generated derived bindings, generics, and selectors - -- Do not generate warnings from compiler-generated code; - -- hence the use of discardWarnings - tc_envs@(tcg_env, tcl_env) - <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ; - setEnvs tc_envs $ do { -- Environment doesn't change now - - -- Second pass over class and instance declarations, - -- now using the kind-checked decls - traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; - - -- Foreign exports - traceTc "Tc7" empty ; - (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ; - - -- Annotations - annotations <- tcAnnotations annotation_decls ; - - -- Rules - rules <- tcRules rule_decls ; - - -- Vectorisation declarations - vects <- tcVectDecls vect_decls ; - - -- Wrap up - traceTc "Tc7a" empty ; - let { all_binds = inst_binds `unionBags` - foe_binds - - ; fo_gres = fi_gres `unionBags` foe_gres - ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre) - emptyFVs fo_gres - - ; sig_names = mkNameSet (collectHsValBinders hs_val_binds) - `minusNameSet` getTypeSigNames val_sigs - - -- Extend the GblEnv with the (as yet un-zonked) - -- bindings, rules, foreign decls - ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds - , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names - , tcg_rules = tcg_rules tcg_env - ++ flattenRuleDecls rules - , tcg_vects = tcg_vects tcg_env ++ vects - , tcg_anns = tcg_anns tcg_env ++ annotations - , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations - , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls - , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; - -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] - - -- See Note [Newtype constructor usage in foreign declarations] - addUsedGREs (bagToList fo_gres) ; - - return (tcg_env', tcl_env) - }}}}}} - -tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" - - -tcSemigroupWarnings :: TcM () -tcSemigroupWarnings = do - traceTc "tcSemigroupWarnings" empty - let warnFlag = Opt_WarnSemigroup - tcPreludeClashWarn warnFlag sappendName - tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName - - --- | Warn on local definitions of names that would clash with future Prelude --- elements. --- --- A name clashes if the following criteria are met: --- 1. It would is imported (unqualified) from Prelude --- 2. It is locally defined in the current module --- 3. It has the same literal name as the reference function --- 4. It is not identical to the reference function -tcPreludeClashWarn :: WarningFlag - -> Name - -> TcM () -tcPreludeClashWarn warnFlag name = do - { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcPreludeClashWarn/wouldBeImported" empty - -- Is the name imported (unqualified) from Prelude? (Point 4 above) - ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv - -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude - -- will not appear in rnImports automatically if it is set.) - - -- Continue only the name is imported from Prelude - ; when (importedViaPrelude name rnImports) $ do - -- Handle 2.-4. - { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv - - ; let clashes :: GlobalRdrElt -> Bool - clashes x = isLocalDef && nameClashes && isNotInProperModule - where - isLocalDef = gre_lcl x == True - -- Names are identical ... - nameClashes = nameOccName (gre_name x) == nameOccName name - -- ... but not the actual definitions, because we don't want to - -- warn about a bad definition of e.g. <> in Data.Semigroup, which - -- is the (only) proper place where this should be defined - isNotInProperModule = gre_name x /= name - - -- List of all offending definitions - clashingElts :: [GlobalRdrElt] - clashingElts = filter clashes rdrElts - - ; traceTc "tcPreludeClashWarn/prelude_functions" - (hang (ppr name) 4 (sep [ppr clashingElts])) - - ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep - [ text "Local definition of" - , (quotes . ppr . nameOccName . gre_name) x - , text "clashes with a future Prelude name." ] - $$ - text "This will become an error in a future release." ) - ; mapM_ warn_msg clashingElts - }}} - - where - - -- Is the given name imported via Prelude? - -- - -- Possible scenarios: - -- a) Prelude is imported implicitly, issue warnings. - -- b) Prelude is imported explicitly, but without mentioning the name in - -- question. Issue no warnings. - -- c) Prelude is imported hiding the name in question. Issue no warnings. - -- d) Qualified import of Prelude, no warnings. - importedViaPrelude :: Name - -> [ImportDecl Name] - -> Bool - importedViaPrelude name = any importViaPrelude - where - isPrelude :: ImportDecl Name -> Bool - isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME - - -- Implicit (Prelude) import? - isImplicit :: ImportDecl Name -> Bool - isImplicit = ideclImplicit - - -- Unqualified import? - isUnqualified :: ImportDecl Name -> Bool - isUnqualified = not . ideclQualified - - -- List of explicitly imported (or hidden) Names from a single import. - -- Nothing -> No explicit imports - -- Just (False, ) -> Explicit import list of - -- Just (True , ) -> Explicit hiding of - importListOf :: ImportDecl Name -> Maybe (Bool, [Name]) - importListOf = fmap toImportList . ideclHiding - where - toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc)) - - isExplicit :: ImportDecl Name -> Bool - isExplicit x = case importListOf x of - Nothing -> False - Just (False, explicit) - -> nameOccName name `elem` map nameOccName explicit - Just (True, hidden) - -> nameOccName name `notElem` map nameOccName hidden - - -- Check whether the given name would be imported (unqualified) from - -- an import declaration. - importViaPrelude :: ImportDecl Name -> Bool - importViaPrelude x = isPrelude x - && isUnqualified x - && (isImplicit x || isExplicit x) - - --- Notation: is* is for classes the type is an instance of, should* for those --- that it should also be an instance of based on the corresponding --- is*. -tcMissingParentClassWarn :: WarningFlag - -> Name -- ^ Instances of this ... - -> Name -- ^ should also be instances of this - -> TcM () -tcMissingParentClassWarn warnFlag isName shouldName - = do { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcMissingParentClassWarn" empty - ; isClass' <- tcLookupClass_maybe isName - ; shouldClass' <- tcLookupClass_maybe shouldName - ; case (isClass', shouldClass') of - (Just isClass, Just shouldClass) -> do - { localInstances <- tcGetInsts - ; let isInstance m = is_cls m == isClass - isInsts = filter isInstance localInstances - ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts) - ; forM_ isInsts (checkShouldInst isClass shouldClass) - } - (is',should') -> - traceTc "tcMissingParentClassWarn/notIsShould" - (hang (ppr isName <> text "/" <> ppr shouldName) 2 ( - (hsep [ quotes (text "Is"), text "lookup for" - , ppr isName - , text "resulted in", ppr is' ]) - $$ - (hsep [ quotes (text "Should"), text "lookup for" - , ppr shouldName - , text "resulted in", ppr should' ]))) - }} - where - -- Check whether the desired superclass exists in a given environment. - checkShouldInst :: Class -- ^ Class of existing instance - -> Class -- ^ Class there should be an instance of - -> ClsInst -- ^ Existing instance - -> TcM () - checkShouldInst isClass shouldClass isInst - = do { instEnv <- tcGetInstEnvs - ; let (instanceMatches, shouldInsts, _) - = lookupInstEnv False instEnv shouldClass (is_tys isInst) - - ; traceTc "tcMissingParentClassWarn/checkShouldInst" - (hang (ppr isInst) 4 - (sep [ppr instanceMatches, ppr shouldInsts])) - - -- ": Warning: is an instance of but not - -- " e.g. "Foo is an instance of Monad but not Applicative" - ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst - warnMsg (Just name:_) = - addWarnAt (Reason warnFlag) instLoc $ - hsep [ (quotes . ppr . nameOccName) name - , text "is an instance of" - , (ppr . nameOccName . className) isClass - , text "but not" - , (ppr . nameOccName . className) shouldClass ] - <> text "." - $$ - hsep [ text "This will become an error in" - , text "a future release." ] - warnMsg _ = pure () - ; when (null shouldInsts && null instanceMatches) $ - warnMsg (is_tcs isInst) - } - - tcLookupClass_maybe :: Name -> TcM (Maybe Class) - tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case - Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls - _else -> pure Nothing - - ---------------------------- -tcTyClsInstDecls :: [TyClGroup Name] - -> [LDerivDecl Name] - -> [(RecFlag, LHsBinds Name)] - -> TcM (TcGblEnv, -- The full inst env - [InstInfo Name], -- Source-code instance decls to process; - -- contains all dfuns for this module - HsValBinds Name) -- Supporting bindings for derived instances - -tcTyClsInstDecls tycl_decls deriv_decls binds - = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ - tcAddPatSynPlaceholders (getPatSynBinds binds) $ - do { (tcg_env, inst_info, datafam_deriv_info) - <- tcTyAndClassDecls tycl_decls ; - ; setGblEnv tcg_env $ do { - -- With the @TyClDecl@s and @InstDecl@s checked we're ready to - -- process the deriving clauses, including data family deriving - -- clauses discovered in @tcTyAndClassDecls@. - -- - -- Careful to quit now in case there were instance errors, so that - -- the deriving errors don't pile up as well. - ; failIfErrsM - ; let tyclds = tycl_decls >>= group_tyclds - ; (tcg_env', inst_info', val_binds) - <- tcInstDeclsDeriv datafam_deriv_info tyclds deriv_decls - ; setGblEnv tcg_env' $ do { - failIfErrsM - ; pure (tcg_env', inst_info' ++ inst_info, val_binds) - }}} - -{- ********************************************************************* -* * - Checking for 'main' -* * -************************************************************************ --} - -checkMain :: Bool -- False => no 'module M(..) where' header at all - -> TcM TcGblEnv --- If we are in module Main, check that 'main' is defined. -checkMain explicit_mod_hdr - = do { dflags <- getDynFlags - ; tcg_env <- getGblEnv - ; check_main dflags tcg_env explicit_mod_hdr } - -check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv -check_main dflags tcg_env explicit_mod_hdr - | mod /= main_mod - = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >> - return tcg_env - - | otherwise - = do { mb_main <- lookupGlobalOccRn_maybe main_fn - -- Check that 'main' is in scope - -- It might be imported from another module! - ; case mb_main of { - Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn) - ; complain_no_main - ; return tcg_env } ; - Just main_name -> do - - { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) - ; let loc = srcLocSpan (getSrcLoc main_name) - ; ioTyCon <- tcLookupTyCon ioTyConName - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; let io_ty = mkTyConApp ioTyCon [res_ty] - skol_info = SigSkol (FunSigCtxt main_name False) io_ty [] - ; (ev_binds, main_expr) - <- checkConstraints skol_info [] [] $ - addErrCtxt mainCtxt $ - tcMonoExpr (L loc (HsVar (L loc main_name))) - (mkCheckExpType io_ty) - - -- See Note [Root-main Id] - -- Construct the binding - -- :Main.main :: IO res_ty = runMainIO res_ty main - ; run_main_id <- tcLookupId runMainIOName - ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN - (mkVarOccFS (fsLit "main")) - (getSrcSpan main_name) - ; root_main_id = Id.mkExportedVanillaId root_main_name - (mkTyConApp ioTyCon [res_ty]) - ; co = mkWpTyApps [res_ty] - ; rhs = mkHsDictLet ev_binds $ - nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr - ; main_bind = mkVarBind root_main_id rhs } - - ; return (tcg_env { tcg_main = Just main_name, - tcg_binds = tcg_binds tcg_env - `snocBag` main_bind, - tcg_dus = tcg_dus tcg_env - `plusDU` usesOnly (unitFV main_name) - -- Record the use of 'main', so that we don't - -- complain about it being defined but not used - }) - }}} - where - mod = tcg_mod tcg_env - main_mod = mainModIs dflags - main_fn = getMainFun dflags - interactive = ghcLink dflags == LinkInMemory - - complain_no_main = checkTc (interactive && not explicit_mod_hdr) noMainMsg - -- In interactive mode, without an explicit module header, don't - -- worry about the absence of 'main'. - -- In other modes, fail altogether, so that we don't go on - -- and complain a second time when processing the export list. - - mainCtxt = text "When checking the type of the" <+> pp_main_fn - noMainMsg = text "The" <+> pp_main_fn - <+> text "is not defined in module" <+> quotes (ppr main_mod) - pp_main_fn = ppMainFn main_fn - --- | Get the unqualified name of the function to use as the \"main\" for the main module. --- Either returns the default name or the one configured on the command line with -main-is -getMainFun :: DynFlags -> RdrName -getMainFun dflags = case mainFunIs dflags of - Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) - Nothing -> main_RDR_Unqual - --- If we are in module Main, check that 'main' is exported. -checkMainExported :: TcGblEnv -> TcM () -checkMainExported tcg_env - = case tcg_main tcg_env of - Nothing -> return () -- not the main module - Just main_name -> - do { dflags <- getDynFlags - ; let main_mod = mainModIs dflags - ; checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $ - text "The" <+> ppMainFn (nameRdrName main_name) <+> - text "is not exported by module" <+> quotes (ppr main_mod) } - -ppMainFn :: RdrName -> SDoc -ppMainFn main_fn - | rdrNameOcc main_fn == mainOcc - = text "IO action" <+> quotes (ppr main_fn) - | otherwise - = text "main IO action" <+> quotes (ppr main_fn) - -mainOcc :: OccName -mainOcc = mkVarOccFS (fsLit "main") - -{- -Note [Root-main Id] -~~~~~~~~~~~~~~~~~~~ -The function that the RTS invokes is always :Main.main, which we call -root_main_id. (Because GHC allows the user to have a module not -called Main as the main module, we can't rely on the main function -being called "Main.main". That's why root_main_id has a fixed module -":Main".) - -This is unusual: it's a LocalId whose Name has a Module from another -module. Tiresomely, we must filter it out again in MkIface, les we -get two defns for 'main' in the interface file! - - -********************************************************* -* * - GHCi stuff -* * -********************************************************* --} - -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a) --- Initialise the tcg_inst_env with instances from all home modules. --- This mimics the more selective call to hptInstances in tcRnImports -runTcInteractive hsc_env thing_inside - = initTcInteractive hsc_env $ withTcPlugins hsc_env $ - do { traceTc "setInteractiveContext" $ - vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) - , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) - , text "ic_rn_gbl_env (LocalDef)" <+> - vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt) - , let local_gres = filter isLocalGRE gres - , not (null local_gres) ]) ] - ; let getOrphans m = fmap (\iface -> mi_module iface - : dep_orphs (mi_deps iface)) - (loadSrcInterface (text "runTcInteractive") m - False Nothing) - ; orphs <- fmap concat . forM (ic_imports icxt) $ \i -> - case i of - IIModule n -> getOrphans n - IIDecl i -> getOrphans (unLoc (ideclName i)) - ; let imports = emptyImportAvails { - imp_orphs = orphs - } - ; (gbl_env, lcl_env) <- getEnvs - ; let gbl_env' = gbl_env { - tcg_rdr_env = ic_rn_gbl_env icxt - , tcg_type_env = type_env - , tcg_inst_env = extendInstEnvList - (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) - home_insts - , tcg_fam_inst_env = extendFamInstEnvList - (extendFamInstEnvList (tcg_fam_inst_env gbl_env) - ic_finsts) - home_fam_insts - , tcg_field_env = mkNameEnv con_fields - -- setting tcg_field_env is necessary - -- to make RecordWildCards work (test: ghci049) - , tcg_fix_env = ic_fix_env icxt - , tcg_default = ic_default icxt - -- must calculate imp_orphs of the ImportAvails - -- so that instance visibility is done correctly - , tcg_imports = imports - } - - ; lcl_env' <- tcExtendLocalTypeEnv lcl_env lcl_ids - ; setEnvs (gbl_env', lcl_env') thing_inside } - where - (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) - - icxt = hsc_IC hsc_env - (ic_insts, ic_finsts) = ic_instances icxt - (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt) - - is_closed :: TyThing -> Either (Name, TcTyThing) TyThing - -- Put Ids with free type variables (always RuntimeUnks) - -- in the *local* type environment - -- See Note [Initialising the type environment for GHCi] - is_closed thing - | AnId id <- thing - , not (isTypeClosedLetBndr id) - = Left (idName id, ATcId { tct_id = id - , tct_info = NotLetBound }) - | otherwise - = Right thing - - type_env1 = mkTypeEnvWithImplicits top_ty_things - type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts) - -- Putting the dfuns in the type_env - -- is just to keep Core Lint happy - - con_fields = [ (dataConName c, dataConFieldLabels c) - | ATyCon t <- top_ty_things - , c <- tyConDataCons t ] - - -{- Note [Initialising the type environment for GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most of the the Ids in ic_things, defined by the user in 'let' stmts, -have closed types. E.g. - ghci> let foo x y = x && not y - -However the GHCi debugger creates top-level bindings for Ids whose -types have free RuntimeUnk skolem variables, standing for unknown -types. If we don't register these free TyVars as global TyVars then -the typechecker will try to quantify over them and fall over in -zonkQuantifiedTyVar. so we must add any free TyVars to the -typechecker's global TyVar set. That is most conveniently by using -tcExtendLocalTypeEnv, which automatically extends the global TyVar -set. - -We do this by splitting out the Ids with open types, using 'is_closed' -to do the partition. The top-level things go in the global TypeEnv; -the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the -local TypeEnv. - -Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope -things are already in the interactive context's GlobalRdrEnv. -Extending the local RdrEnv isn't terrible, but it means there is an -entry for the same Name in both global and local RdrEnvs, and that -lead to duplicate "perhaps you meant..." suggestions (e.g. T5564). - -We don't bother with the tcl_th_bndrs environment either. --} - --- | The returned [Id] is the list of new Ids bound by this statement. It can --- be used to extend the InteractiveContext via extendInteractiveContext. --- --- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound --- values, coerced to (). -tcRnStmt :: HscEnv -> GhciLStmt RdrName - -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv)) -tcRnStmt hsc_env rdr_stmt - = runTcInteractive hsc_env $ do { - - -- The real work is done here - ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; - zonked_expr <- zonkTopLExpr tc_expr ; - zonked_ids <- zonkTopBndrs bound_ids ; - - failIfErrsM ; -- we can't do the next step if there are levity polymorphism errors - -- test case: ghci/scripts/T13202{,a} - - -- None of the Ids should be of unboxed type, because we - -- cast them all to HValues in the end! - mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ; - - traceTc "tcs 1" empty ; - this_mod <- getModule ; - global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ; - -- Note [Interactively-bound Ids in GHCi] in HscTypes - -{- --------------------------------------------- - At one stage I removed any shadowed bindings from the type_env; - they are inaccessible but might, I suppose, cause a space leak if we leave them there. - However, with Template Haskell they aren't necessarily inaccessible. Consider this - GHCi session - Prelude> let f n = n * 2 :: Int - Prelude> fName <- runQ [| f |] - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) - 14 - Prelude> let f n = n * 3 :: Int - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) - In the last line we use 'fName', which resolves to the *first* 'f' - in scope. If we delete it from the type env, GHCi crashes because - it doesn't expect that. - - Hence this code is commented out - --------------------------------------------------- -} - - traceOptTcRn Opt_D_dump_tc - (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, - text "Typechecked expr" <+> ppr zonked_expr]) ; - - return (global_ids, zonked_expr, fix_env) - } - where - bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:", - nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) - -{- --------------------------------------------------------------------------- - Typechecking Stmts in GHCi - -Here is the grand plan, implemented in tcUserStmt - - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] - [NB: result not printed] bindings: [it] - - expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] - result showable) bindings: [it] - - expr (of non-IO type, - result not showable) ==> error --} - --- | A plan is an attempt to lift some code into the IO monad. -type PlanResult = ([Id], LHsExpr Id) -type Plan = TcM PlanResult - --- | Try the plans in order. If one fails (by raising an exn), try the next. --- If one succeeds, take it. -runPlans :: [Plan] -> TcM PlanResult -runPlans [] = panic "runPlans" -runPlans [p] = p -runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p - --- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the --- GHCi 'environment'. --- --- By 'lift' and 'environment we mean that the code is changed to --- execute properly in an IO monad. See Note [Interactively-bound Ids --- in GHCi] in HscTypes for more details. We do this lifting by trying --- different ways ('plans') of lifting the code into the IO monad and --- type checking each plan until one succeeds. -tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv) - --- An expression typed at the prompt is treated very specially -tcUserStmt (L loc (BodyStmt expr _ _ _)) - = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) - -- Don't try to typecheck if the renamer fails! - ; ghciStep <- getGhciStepIO - ; uniq <- newUnique - ; interPrintName <- getInteractivePrintName - ; let fresh_it = itName uniq loc - matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr - (noLoc emptyLocalBinds)] - -- [it = expr] - the_bind = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs } - -- Care here! In GHCi the expression might have - -- free variables, and they in turn may have free type variables - -- (if we are at a breakpoint, say). We must put those free vars - - -- [let it = expr] - let_stmt = L loc $ LetStmt $ noLoc $ HsValBinds $ - ValBindsOut [(NonRecursive,unitBag the_bind)] [] - - -- [it <- e] - bind_stmt = L loc $ BindStmt (L loc (VarPat (L loc fresh_it))) - (nlHsApp ghciStep rn_expr) - (mkRnSyntaxExpr bindIOName) - noSyntaxExpr - PlaceHolder - - -- [; print it] - print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr placeHolderType - - -- The plans are: - -- A. [it <- e; print it] but not if it::() - -- B. [it <- e] - -- C. [let it = e; print it] - -- - -- Ensure that type errors don't get deferred when type checking the - -- naked expression. Deferring type errors here is unhelpful because the - -- expression gets evaluated right away anyway. It also would potentially - -- emit two redundant type-error warnings, one from each plan. - ; plan <- unsetGOptM Opt_DeferTypeErrors $ - unsetGOptM Opt_DeferTypedHoles $ runPlans [ - -- Plan A - do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] - ; it_ty <- zonkTcType (idType it_id) - ; when (isUnitTy $ it_ty) failM - ; return stuff }, - - -- Plan B; a naked bind statment - tcGhciStmts [bind_stmt], - - -- Plan C; check that the let-binding is typeable all by itself. - -- If not, fail; if so, try to print it. - -- The two-step process avoids getting two errors: one from - -- the expression itself, and one from the 'print it' part - -- This two-step story is very clunky, alas - do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) - --- checkNoErrs defeats the error recovery of let-bindings - ; tcGhciStmts [let_stmt, print_it] } ] - - ; fix_env <- getFixityEnv - ; return (plan, fix_env) } - -tcUserStmt rdr_stmt@(L loc _) - = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ - rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do - fix_env <- getFixityEnv - return (fix_env, emptyFVs) - -- Don't try to typecheck if the renamer fails! - ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) - ; rnDump rn_stmt ; - - ; ghciStep <- getGhciStepIO - ; let gi_stmt - | (L loc (BindStmt pat expr op1 op2 ty)) <- rn_stmt - = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2 ty - | otherwise = rn_stmt - - ; opt_pr_flag <- goptM Opt_PrintBindResult - ; let print_result_plan - | opt_pr_flag -- The flag says "print result" - , [v] <- collectLStmtBinders gi_stmt -- One binder - = [mk_print_result_plan gi_stmt v] - | otherwise = [] - - -- The plans are: - -- [stmt; print v] if one binder and not v::() - -- [stmt] otherwise - ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) - ; return (plan, fix_env) } - where - mk_print_result_plan stmt v - = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] - ; v_ty <- zonkTcType (idType v_id) - ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM - ; return stuff } - where - print_v = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (mkRnSyntaxExpr thenIOName) noSyntaxExpr - placeHolderType - --- | Typecheck the statements given and then return the results of the --- statement in the form 'IO [()]'. -tcGhciStmts :: [GhciLStmt Name] -> TcM PlanResult -tcGhciStmts stmts - = do { ioTyCon <- tcLookupTyCon ioTyConName ; - ret_id <- tcLookupId returnIOName ; -- return @ IO - let { - ret_ty = mkListTy unitTy ; - io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts - (mkCheckExpType io_ret_ty) ; - names = collectLStmtsBinders stmts ; - } ; - - -- OK, we're ready to typecheck the stmts - traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; - ((tc_stmts, ids), lie) <- captureTopConstraints $ - tc_io_stmts $ \ _ -> - mapM tcLookupId names ; - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; - const_binds <- checkNoErrs (simplifyInteractive lie) ; - -- checkNoErrs ensures that the plan fails if context redn fails - - traceTc "TcRnDriver.tcGhciStmts: done" empty ; - let { -- mk_return builds the expression - -- returnIO @ [()] [coerce () x, .., coerce () z] - -- - -- Despite the inconvenience of building the type applications etc, - -- this *has* to be done in type-annotated post-typecheck form - -- because we are going to return a list of *polymorphic* values - -- coerced to type (). If we built a *source* stmt - -- return [coerce x, ..., coerce z] - -- then the type checker would instantiate x..z, and we wouldn't - -- get their *polymorphic* values. (And we'd get ambiguity errs - -- if they were overloaded, since they aren't applied to anything.) - ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ; - mk_item id = let ty_args = [idType id, unitTy] in - nlHsApp (nlHsTyApp unsafeCoerceId - (map getRuntimeRep ty_args ++ ty_args)) - (nlHsVar id) ; - stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] - } ; - return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmtCtxt (noLoc stmts) io_ret_ty)) - } - --- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) -getGhciStepIO :: TcM (LHsExpr Name) -getGhciStepIO = do - ghciTy <- getGHCiMonad - a_tv <- newName (mkTyVarOccFS (fsLit "a")) - let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) - ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) - - step_ty = noLoc $ HsForAllTy { hst_bndrs = [noLoc $ UserTyVar (noLoc a_tv)] - , hst_body = nlHsFunTy ghciM ioM } - - stepTy :: LHsSigWcType Name - stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) - - return (noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy) - -isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) -isGHCiMonad hsc_env ty - = runTcInteractive hsc_env $ do - rdrEnv <- getGlobalRdrEnv - let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) - case occIO of - Just [n] -> do - let name = gre_name n - ghciClass <- tcLookupClass ghciIoClassName - userTyCon <- tcLookupTyCon name - let userTy = mkTyConApp userTyCon [] - _ <- tcLookupInstance ghciClass [userTy] - return name - - Just _ -> failWithTc $ text "Ambiguous type!" - Nothing -> failWithTc $ text ("Can't find type:" ++ ty) - --- | How should we infer a type? See Note [TcRnExprMode] -data TcRnExprMode = TM_Inst -- ^ Instantiate the type fully (:type) - | TM_NoInst -- ^ Do not instantiate the type (:type +v) - | TM_Default -- ^ Default the type eagerly (:type +d) - --- | tcRnExpr just finds the type of an expression -tcRnExpr :: HscEnv - -> TcRnExprMode - -> LHsExpr RdrName - -> IO (Messages, Maybe Type) -tcRnExpr hsc_env mode rdr_expr - = runTcInteractive hsc_env $ - do { - - (rn_expr, _fvs) <- rnLExpr rdr_expr ; - failIfErrsM ; - - -- Now typecheck the expression, and generalise its type - -- it might have a rank-2 type (e.g. :t runST) - uniq <- newUnique ; - let { fresh_it = itName uniq (getLoc rdr_expr) - ; orig = lexprCtOrigin rn_expr } ; - (tclvl, lie, res_ty) - <- pushLevelAndCaptureConstraints $ - do { (_tc_expr, expr_ty) <- tcInferSigma rn_expr - ; if inst - then snd <$> deeplyInstantiate orig expr_ty - else return expr_ty } ; - - -- Generalise - ((qtvs, dicts, _, _), lie_top) <- captureTopConstraints $ - {-# SCC "simplifyInfer" #-} - simplifyInfer tclvl - infer_mode - [] {- No sig vars -} - [(fresh_it, res_ty)] - lie ; - - -- Ignore the dictionary bindings - _ <- perhaps_disable_default_warnings $ - simplifyInteractive lie_top ; - - let { all_expr_ty = mkInvForAllTys qtvs (mkLamTypes dicts res_ty) } ; - ty <- zonkTcType all_expr_ty ; - - -- We normalise type families, so that the type of an expression is the - -- same as of a bound expression (TcBinds.mkInferredPolyId). See Trac - -- #10321 for further discussion. - fam_envs <- tcGetFamInstEnvs ; - -- normaliseType returns a coercion which we discard, so the Role is - -- irrelevant - return (snd (normaliseType fam_envs Nominal ty)) - } - where - -- See Note [TcRnExprMode] - (inst, infer_mode, perhaps_disable_default_warnings) = case mode of - TM_Inst -> (True, NoRestrictions, id) - TM_NoInst -> (False, NoRestrictions, id) - TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) - --------------------------- -tcRnImportDecls :: HscEnv - -> [LImportDecl RdrName] - -> IO (Messages, Maybe GlobalRdrEnv) --- Find the new chunk of GlobalRdrEnv created by this list of import --- decls. In contract tcRnImports *extends* the TcGblEnv. -tcRnImportDecls hsc_env import_decls - = runTcInteractive hsc_env $ - do { gbl_env <- updGblEnv zap_rdr_env $ - tcRnImports hsc_env import_decls - ; return (tcg_rdr_env gbl_env) } - where - zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } - --- tcRnType just finds the kind of a type -tcRnType :: HscEnv - -> Bool -- Normalise the returned type - -> LHsType RdrName - -> IO (Messages, Maybe (Type, Kind)) -tcRnType hsc_env normalise rdr_type - = runTcInteractive hsc_env $ - setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] - do { (HsWC { hswc_wcs = wcs, hswc_body = rn_type }, _fvs) - <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type) - -- The type can have wild cards, but no implicit - -- generalisation; e.g. :kind (T _) - ; failIfErrsM - - -- Now kind-check the type - -- It can have any rank or kind - -- First bring into scope any wildcards - ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type]) - ; (ty, kind) <- solveEqualities $ - tcWildCardBinders wcs $ \ _ -> - tcLHsType rn_type - - -- Do kind generalisation; see Note [Kind-generalise in tcRnType] - ; kvs <- kindGeneralize kind - ; ty <- zonkTcTypeToType emptyZonkEnv ty - - ; ty' <- if normalise - then do { fam_envs <- tcGetFamInstEnvs - ; let (_, ty') - = normaliseType fam_envs Nominal ty - ; return ty' } - else return ty ; - - ; return (ty', mkInvForAllTys kvs (typeKind ty')) } - -{- Note [TcRnExprMode] -~~~~~~~~~~~~~~~~~~~~~~ -How should we infer a type when a user asks for the type of an expression e -at the GHCi prompt? We offer 3 different possibilities, described below. Each -considers this example, with -fprint-explicit-foralls enabled: - - foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String - :type{,-spec,-def} foo @Int - -:type / TM_Inst - - In this mode, we report the type that would be inferred if a variable - were assigned to expression e, without applying the monomorphism restriction. - This means we deeply instantiate the type and then regeneralize, as discussed - in #11376. - - > :type foo @Int - forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String - - Note that the variables and constraints are reordered here, because this - is possible during regeneralization. Also note that the variables are - reported as Inferred instead of Specified. - -:type +v / TM_NoInst - - This mode is for the benefit of users using TypeApplications. It does no - instantiation whatsoever, sometimes meaning that class constraints are not - solved. - - > :type +v foo @Int - forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String - - Note that Show Int is still reported, because the solver never got a chance - to see it. - -:type +d / TM_Default - - This mode is for the benefit of users who wish to see instantiations of - generalized types, and in particular to instantiate Foldable and Traversable. - In this mode, any type variable that can be defaulted is defaulted. Because - GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are - defaulted. - - > :type +d foo @Int - Int -> [Integer] -> String - - Note that this mode can sometimes lead to a type error, if a type variable is - used with a defaultable class but cannot actually be defaulted: - - bar :: (Num a, Monoid a) => a -> a - > :type +d bar - ** error ** - - The error arises because GHC tries to default a but cannot find a concrete - type in the defaulting list that is both Num and Monoid. (If this list is - modified to include an element that is both Num and Monoid, the defaulting - would succeed, of course.) - -Note [Kind-generalise in tcRnType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We switch on PolyKinds when kind-checking a user type, so that we will -kind-generalise the type, even when PolyKinds is not otherwise on. -This gives the right default behaviour at the GHCi prompt, where if -you say ":k T", and T has a polymorphic kind, you'd like to see that -polymorphism. Of course. If T isn't kind-polymorphic you won't get -anything unexpected, but the apparent *loss* of polymorphism, for -types that you know are polymorphic, is quite surprising. See Trac -#7688 for a discussion. - -Note that the goal is to generalise the *kind of the type*, not -the type itself! Example: - ghci> data T m a = MkT (m a) -- T :: forall . (k -> *) -> k -> * - ghci> :k T -We instantiate T to get (T kappa). We do not want to kind-generalise -that to forall k. T k! Rather we want to take its kind - T kappa :: (kappa -> *) -> kappa -> * -and now kind-generalise that kind, to forall k. (k->*) -> k -> * -(It was Trac #10122 that made me realise how wrong the previous -approach was.) -} - - -{- -************************************************************************ -* * - tcRnDeclsi -* * -************************************************************************ - -tcRnDeclsi exists to allow class, data, and other declarations in GHCi. --} - -tcRnDeclsi :: HscEnv - -> [LHsDecl RdrName] - -> IO (Messages, Maybe TcGblEnv) -tcRnDeclsi hsc_env local_decls - = runTcInteractive hsc_env $ - tcRnSrcDecls False local_decls - -externaliseAndTidyId :: Module -> Id -> TcM Id -externaliseAndTidyId this_mod id - = do { name' <- externaliseName this_mod (idName id) - ; return (globaliseAndTidyId (setIdName id name')) } - - -{- -************************************************************************ -* * - More GHCi stuff, to do with browsing and getting info -* * -************************************************************************ --} - --- | ASSUMES that the module is either in the 'HomePackageTable' or is --- a package module with an interface on disk. If neither of these is --- true, then the result will be an error indicating the interface --- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface) -getModuleInterface hsc_env mod - = runTcInteractive hsc_env $ - loadModuleInterface (text "getModuleInterface") mod - -tcRnLookupRdrName :: HscEnv -> Located RdrName - -> IO (Messages, Maybe [Name]) --- ^ Find all the Names that this RdrName could mean, in GHCi -tcRnLookupRdrName hsc_env (L loc rdr_name) - = runTcInteractive hsc_env $ - setSrcSpan loc $ - do { -- If the identifier is a constructor (begins with an - -- upper-case letter), then we need to consider both - -- constructor and type class identifiers. - let rdr_names = dataTcOccs rdr_name - ; names_s <- mapM lookupInfoOccRn rdr_names - ; let names = concat names_s - ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) - ; return names } - -tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) -tcRnLookupName hsc_env name - = runTcInteractive hsc_env $ - tcRnLookupName' name - --- To look up a name we have to look in the local environment (tcl_lcl) --- as well as the global environment, which is what tcLookup does. --- But we also want a TyThing, so we have to convert: - -tcRnLookupName' :: Name -> TcRn TyThing -tcRnLookupName' name = do - tcthing <- tcLookup name - case tcthing of - AGlobal thing -> return thing - ATcId{tct_id=id} -> return (AnId id) - _ -> panic "tcRnLookupName'" - -tcRnGetInfo :: HscEnv - -> Name - -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst])) - --- Used to implement :info in GHCi --- --- Look up a RdrName and return all the TyThings it might be --- A capitalised RdrName is given to us in the DataName namespace, --- but we want to treat it as *both* a data constructor --- *and* as a type or class constructor; --- hence the call to dataTcOccs, and we return up to two results -tcRnGetInfo hsc_env name - = runTcInteractive hsc_env $ - do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) - -- Load the interface for all unqualified types and classes - -- That way we will find all the instance declarations - -- (Packages have not orphan modules, and we assume that - -- in the home package all relevant modules are loaded.) - - ; thing <- tcRnLookupName' name - ; fixity <- lookupFixityRn name - ; (cls_insts, fam_insts) <- lookupInsts thing - ; return (thing, fixity, cls_insts, fam_insts) } - - --- Lookup all class and family instances for a type constructor. --- --- This function filters all instances in the type environment, so there --- is a lot of duplicated work if it is called many times in the same --- type environment. If this becomes a problem, the NameEnv computed --- in GHC.getNameToInstancesIndex could be cached in TcM and both functions --- could be changed to consult that index. -lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) -lookupInsts (ATyCon tc) - = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs - ; (pkg_fie, home_fie) <- tcGetFamInstEnvs - -- Load all instances for all classes that are - -- in the type environment (which are all the ones - -- we've seen in any interface file so far) - - -- Return only the instances relevant to the given thing, i.e. - -- the instances whose head contains the thing's name. - ; let cls_insts = - [ ispec -- Search all - | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie - , instIsVisible vis_mods ispec - , tc_name `elemNameSet` orphNamesOfClsInst ispec ] - ; let fam_insts = - [ fispec - | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie - , tc_name `elemNameSet` orphNamesOfFamInst fispec ] - ; return (cls_insts, fam_insts) } - where - tc_name = tyConName tc - -lookupInsts _ = return ([],[]) - -loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () --- Load the interface for everything that is in scope unqualified --- This is so that we can accurately report the instances for --- something -loadUnqualIfaces hsc_env ictxt - = initIfaceTcRn $ do - mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) - where - this_pkg = thisPackage (hsc_dflags hsc_env) - - unqual_mods = [ nameModule name - | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) - , let name = gre_name gre - , nameIsFromExternalPackage this_pkg name - , isTcOcc (nameOccName name) -- Types and classes only - , unQualOK gre ] -- In scope unqualified - doc = text "Need interface for module whose export(s) are in scope unqualified" - - - -{- -************************************************************************ -* * - Degugging output -* * -************************************************************************ --} - -rnDump :: (Outputable a, Data a) => a -> TcRn () --- Dump, with a banner, if -ddump-rn -rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn)) } - -tcDump :: TcGblEnv -> TcRn () -tcDump env - = do { dflags <- getDynFlags ; - - -- Dump short output if -ddump-types or -ddump-tc - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (printForUserTcRn short_dump) ; - - -- Dump bindings if -ddump-tc - traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump); - - -- Dump bindings as an hsSyn AST if -ddump-tc-ast - traceOptTcRn Opt_D_dump_tc_ast (mkDumpDoc "Typechecker" ast_dump) - } - where - short_dump = pprTcGblEnv env - full_dump = pprLHsBinds (tcg_binds env) - -- NB: foreign x-d's have undefined's in their types; - -- hence can't show the tc_fords - ast_dump = text (showAstData NoBlankSrcSpan (tcg_binds env)) - --- It's unpleasant having both pprModGuts and pprModDetails here -pprTcGblEnv :: TcGblEnv -> SDoc -pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_rules = rules, - tcg_vects = vects, - tcg_imports = imports }) - = vcat [ ppr_types type_env - , ppr_tycons fam_insts type_env - , ppr_insts insts - , ppr_fam_insts fam_insts - , vcat (map ppr rules) - , vcat (map ppr vects) - , text "Dependent modules:" <+> - pprUFM (imp_dep_mods imports) (ppr . sort) - , text "Dependent packages:" <+> - ppr (S.toList $ imp_dep_pkgs imports)] - where -- The use of sort is just to reduce unnecessary - -- wobbling in testsuite output - -ppr_types :: TypeEnv -> SDoc -ppr_types type_env = sdocWithPprDebug $ \dbg -> - let - ids = [id | id <- typeEnvIds type_env, want_sig id] - want_sig id | dbg - = True - | otherwise - = isExternalName (idName id) && - (not (isDerivedOccName (getOccName id))) - -- Top-level user-defined things have External names. - -- Suppress internally-generated things unless -dppr-debug - in - text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids) - -ppr_tycons :: [FamInst] -> TypeEnv -> SDoc -ppr_tycons fam_insts type_env = sdocWithPprDebug $ \dbg -> - let - fi_tycons = famInstsRepTyCons fam_insts - tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] - want_tycon tycon | dbg = True - | otherwise = not (isImplicitTyCon tycon) && - isExternalName (tyConName tycon) && - not (tycon `elem` fi_tycons) - in - vcat [ text "TYPE CONSTRUCTORS" - , nest 2 (ppr_tydecls tycons) - , text "COERCION AXIOMS" - , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ] - -ppr_insts :: [ClsInst] -> SDoc -ppr_insts [] = empty -ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) - -ppr_fam_insts :: [FamInst] -> SDoc -ppr_fam_insts [] = empty -ppr_fam_insts fam_insts = - text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts) - -ppr_sigs :: [Var] -> SDoc -ppr_sigs ids - -- Print type signatures; sort by OccName - = vcat (map ppr_sig (sortBy (comparing getOccName) ids)) - where - ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id))) - -ppr_tydecls :: [TyCon] -> SDoc -ppr_tydecls tycons - -- Print type constructor info for debug purposes - -- Sort by OccName to reduce unnecessary changes - = vcat [ ppr (tyThingToIfaceDecl (ATyCon tc)) - | tc <- sortBy (comparing getOccName) tycons ] - -- The Outputable instance for IfaceDecl uses - -- showToIface, which is what we want here, whereas - -- pprTyThing uses ShowSome. - -{- -******************************************************************************** - -Type Checker Plugins - -******************************************************************************** --} - -withTcPlugins :: HscEnv -> TcM a -> TcM a -withTcPlugins hsc_env m = - do plugins <- liftIO (loadTcPlugins hsc_env) - case plugins of - [] -> m -- Common fast case - _ -> do ev_binds_var <- newTcEvBinds - (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins - -- This ensures that tcPluginStop is called even if a type - -- error occurs during compilation (Fix of #10078) - eitherRes <- tryM $ do - updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m - mapM_ (flip runTcPluginM ev_binds_var) stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - startPlugin ev_binds_var (TcPlugin start solve stop) = - do s <- runTcPluginM start ev_binds_var - return (solve s, stop s) - -loadTcPlugins :: HscEnv -> IO [TcPlugin] -#ifndef GHCI -loadTcPlugins _ = return [] -#else -loadTcPlugins hsc_env = - do named_plugins <- loadPlugins hsc_env - return $ catMaybes $ map load_plugin named_plugins - where - load_plugin (_, plug, opts) = tcPlugin plug opts -#endif diff --git a/typecheck/TcRnDriver.hs-boot b/typecheck/TcRnDriver.hs-boot deleted file mode 100644 --- a/typecheck/TcRnDriver.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module TcRnDriver where - -import DynFlags (DynFlags) -import Type (TyThing) -import TcRnTypes (TcM) -import Outputable (SDoc) -import Name (Name) - -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -missingBootThing :: Bool -> Name -> String -> SDoc -badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc diff --git a/typecheck/TcRnExports.hs b/typecheck/TcRnExports.hs deleted file mode 100644 --- a/typecheck/TcRnExports.hs +++ /dev/null @@ -1,881 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -module TcRnExports (tcRnExports, exports_from_avail) where - -import HsSyn -import PrelNames -import RdrName -import TcRnMonad -import TcEnv -import TcMType -import TcType -import RnNames -import RnEnv -import ErrUtils -import Id -import IdInfo -import Module -import Name -import NameEnv -import NameSet -import Avail -import TyCon -import SrcLoc -import HscTypes -import Outputable -import ConLike -import DataCon -import PatSyn -import FastString -import Maybes -import qualified GHC.LanguageExtensions as LangExt -import Util (capitalise) - - -import Control.Monad -import DynFlags -import RnHsDoc ( rnHsDoc ) -import RdrHsSyn ( setRdrNameSpace ) -import Data.Either ( partitionEithers ) - -{- -************************************************************************ -* * -\subsection{Export list processing} -* * -************************************************************************ - -Processing the export list. - -You might think that we should record things that appear in the export -list as ``occurrences'' (using @addOccurrenceName@), but you'd be -wrong. We do check (here) that they are in scope, but there is no -need to slurp in their actual declaration (which is what -@addOccurrenceName@ forces). - -Indeed, doing so would big trouble when compiling @PrelBase@, because -it re-exports @GHC@, which includes @takeMVar#@, whose type includes -@ConcBase.StateAndSynchVar#@, and so on... - -Note [Exports of data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose you see (Trac #5306) - module M where - import X( F ) - data instance F Int = FInt -What does M export? AvailTC F [FInt] - or AvailTC F [F,FInt]? -The former is strictly right because F isn't defined in this module. -But then you can never do an explicit import of M, thus - import M( F( FInt ) ) -because F isn't exported by M. Nor can you import FInt alone from here - import M( FInt ) -because we don't have syntax to support that. (It looks like an import of -the type FInt.) - -At one point I implemented a compromise: - * When constructing exports with no export list, or with module M( - module M ), we add the parent to the exports as well. - * But not when you see module M( f ), even if f is a - class method with a parent. - * Nor when you see module M( module N ), with N /= M. - -But the compromise seemed too much of a hack, so we backed it out. -You just have to use an explicit export list: - module M( F(..) ) where ... --} - -data ExportAccum -- The type of the accumulating parameter of - -- the main worker function in rnExports - = ExportAccum - [LIE Name] -- Export items with Names - ExportOccMap -- Tracks exported occurrence names - [AvailInfo] -- The accumulated exported stuff - -- Not nub'd! - -emptyExportAccum :: ExportAccum -emptyExportAccum = ExportAccum [] emptyOccEnv [] - -type ExportOccMap = OccEnv (Name, IE RdrName) - -- Tracks what a particular exported OccName - -- in an export list refers to, and which item - -- it came from. It's illegal to export two distinct things - -- that have the same occurrence name - -tcRnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list - -> TcGblEnv - -> RnM TcGblEnv - - -- Complains if two distinct exports have same OccName - -- Warns about identical exports. - -- Complains about exports items not in scope - -tcRnExports explicit_mod exports - tcg_env@TcGblEnv { tcg_mod = this_mod, - tcg_rdr_env = rdr_env, - tcg_imports = imports, - tcg_src = hsc_src } - = unsetWOptM Opt_WarnWarningsDeprecations $ - -- Do not report deprecations arising from the export - -- list, to avoid bleating about re-exporting a deprecated - -- thing (especially via 'module Foo' export item) - do { - -- If the module header is omitted altogether, then behave - -- as if the user had written "module Main(main) where..." - -- EXCEPT in interactive mode, when we behave as if he had - -- written "module Main where ..." - -- Reason: don't want to complain about 'main' not in scope - -- in interactive mode - ; dflags <- getDynFlags - ; let real_exports - | explicit_mod = exports - | ghcLink dflags == LinkInMemory = Nothing - | otherwise - = Just (noLoc [noLoc - (IEVar (noLoc (IEName $ noLoc main_RDR_Unqual)))]) - -- ToDo: the 'noLoc' here is unhelpful if 'main' - -- turns out to be out of scope - - ; let do_it = exports_from_avail real_exports rdr_env imports this_mod - ; (rn_exports, final_avails) - <- if hsc_src == HsigFile - then do (msgs, mb_r) <- tryTc do_it - case mb_r of - Just r -> return r - Nothing -> addMessages msgs >> failM - else checkNoErrs $ do_it - ; let final_ns = availsToNameSetWithSelectors final_avails - - ; traceRn "rnExports: Exports:" (ppr final_avails) - - ; let new_tcg_env = - tcg_env { tcg_exports = final_avails, - tcg_rn_exports = case tcg_rn_exports tcg_env of - Nothing -> Nothing - Just _ -> rn_exports, - tcg_dus = tcg_dus tcg_env `plusDU` - usesOnly final_ns } - ; failIfErrsM - ; return new_tcg_env } - -exports_from_avail :: Maybe (Located [LIE RdrName]) - -- Nothing => no explicit export list - -> GlobalRdrEnv - -> ImportAvails - -> Module - -> RnM (Maybe [LIE Name], [AvailInfo]) - -exports_from_avail Nothing rdr_env _imports _this_mod - -- The same as (module M) where M is the current module name, - -- so that's how we handle it, except we also export the data family - -- when a data instance is exported. - = let avails = - map fix_faminst . gresToAvailInfo - . filter isLocalGRE . globalRdrEnvElts $ rdr_env - in return (Nothing, avails) - where - -- #11164: when we define a data instance - -- but not data family, re-export the family - -- Even though we don't check whether this is actually a data family - -- only data families can locally define subordinate things (`ns` here) - -- without locally defining (and instead importing) the parent (`n`) - fix_faminst (AvailTC n ns flds) = - let new_ns = - case ns of - [] -> [n] - (p:_) -> if p == n then ns else n:ns - in AvailTC n new_ns flds - - fix_faminst avail = avail - - -exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod - = do ExportAccum ie_names _ exports - <- foldAndRecoverM do_litem emptyExportAccum rdr_items - let final_exports = nubAvails exports -- Combine families - return (Just ie_names, final_exports) - where - do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum - do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) - - -- Maps a parent to its in-scope children - kids_env :: NameEnv [GlobalRdrElt] - kids_env = mkChildEnv (globalRdrEnvElts rdr_env) - - - imported_modules = [ imv_name imv - | xs <- moduleEnvElts $ imp_mods imports - , imv <- importedByUser xs ] - - exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum - exports_from_item acc@(ExportAccum ie_names occs exports) - (L loc (IEModuleContents (L lm mod))) - | let earlier_mods = [ mod - | (L _ (IEModuleContents (L _ mod))) <- ie_names ] - , mod `elem` earlier_mods -- Duplicate export of M - = do { warnIf (Reason Opt_WarnDuplicateExports) True - (dupModuleExport mod) ; - return acc } - - | otherwise - = do { let { exportValid = (mod `elem` imported_modules) - || (moduleName this_mod == mod) - ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) - ; new_exports = map (availFromGRE . fst) gre_prs - ; names = map (gre_name . fst) gre_prs - ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs - } - - ; checkErr exportValid (moduleNotImported mod) - ; warnIf (Reason Opt_WarnDodgyExports) - (exportValid && null gre_prs) - (nullModuleExport mod) - - ; traceRn "efa" (ppr mod $$ ppr all_gres) - ; addUsedGREs all_gres - - ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names - -- This check_occs not only finds conflicts - -- between this item and others, but also - -- internally within this item. That is, if - -- 'M.x' is in scope in several ways, we'll have - -- several members of mod_avails with the same - -- OccName. - ; traceRn "export_mod" - (vcat [ ppr mod - , ppr new_exports ]) - ; return (ExportAccum (L loc (IEModuleContents (L lm mod)) : ie_names) - occs' - (new_exports ++ exports)) } - - exports_from_item acc@(ExportAccum lie_names occs exports) (L loc ie) - | isDoc ie - = do new_ie <- lookup_doc_ie ie - return (ExportAccum (L loc new_ie : lie_names) occs exports) - - | otherwise - = do (new_ie, avail) <- - setSrcSpan loc $ lookup_ie ie - if isUnboundName (ieName new_ie) - then return acc -- Avoid error cascade - else do - - occs' <- check_occs ie occs (availNames avail) - - return (ExportAccum (L loc new_ie : lie_names) occs' (avail : exports)) - - ------------- - lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo) - lookup_ie (IEVar (L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEVar (L l (replaceWrappedName rdr name)), avail) - - lookup_ie (IEThingAbs (L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs (L l (replaceWrappedName rdr name)), avail) - - lookup_ie ie@(IEThingAll n') - = do - (n, avail, flds) <- lookup_ie_all ie n' - let name = unLoc n - return (IEThingAll (replaceLWrappedName n' (unLoc n)) - , AvailTC name (name:avail) flds) - - - lookup_ie ie@(IEThingWith l wc sub_rdrs _) - = do - (lname, subs, avails, flds) - <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs - (_, all_avail, all_flds) <- - case wc of - NoIEWildcard -> return (lname, [], []) - IEWildcard _ -> lookup_ie_all ie l - let name = unLoc lname - return (IEThingWith (replaceLWrappedName l name) wc subs - (flds ++ (map noLoc all_flds)), - AvailTC name (name : avails ++ all_avail) - (map unLoc flds ++ all_flds)) - - - - - lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier - - lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] - -> RnM (Located Name, [LIEWrappedName Name], [Name], - [Located FieldLabel]) - lookup_ie_with (L l rdr) sub_rdrs - = do name <- lookupGlobalOccRn $ ieWrappedName rdr - (non_flds, flds) <- lookupChildrenExport name sub_rdrs - if isUnboundName name - then return (L l name, [], [name], []) - else return (L l name, non_flds - , map (ieWrappedName . unLoc) non_flds - , flds) - - lookup_ie_all :: IE RdrName -> LIEWrappedName RdrName - -> RnM (Located Name, [Name], [FieldLabel]) - lookup_ie_all ie (L l rdr) = - do name <- lookupGlobalOccRn $ ieWrappedName rdr - let gres = findChildren kids_env name - (non_flds, flds) = classifyGREs gres - addUsedKids (ieWrappedName rdr) gres - warnDodgyExports <- woptM Opt_WarnDodgyExports - when (null gres) $ - if isTyConName name - then when warnDodgyExports $ - addWarn (Reason Opt_WarnDodgyExports) - (dodgyExportWarn name) - else -- This occurs when you export T(..), but - -- only import T abstractly, or T is a synonym. - addErr (exportItemErr ie) - return (L l name, non_flds, flds) - - ------------- - lookup_doc_ie :: IE RdrName -> RnM (IE Name) - lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc - return (IEGroup lev rn_doc) - lookup_doc_ie (IEDoc doc) = do rn_doc <- rnHsDoc doc - return (IEDoc rn_doc) - lookup_doc_ie (IEDocNamed str) = return (IEDocNamed str) - lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier - - -- In an export item M.T(A,B,C), we want to treat the uses of - -- A,B,C as if they were M.A, M.B, M.C - -- Happily pickGREs does just the right thing - addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM () - addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres) - -classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel]) -classifyGREs = partitionEithers . map classifyGRE - -classifyGRE :: GlobalRdrElt -> Either Name FieldLabel -classifyGRE gre = case gre_par gre of - FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n) - FldParent _ (Just lbl) -> Right (FieldLabel lbl True n) - _ -> Left n - where - n = gre_name gre - -isDoc :: IE RdrName -> Bool -isDoc (IEDoc _) = True -isDoc (IEDocNamed _) = True -isDoc (IEGroup _ _) = True -isDoc _ = False - --- Renaming and typechecking of exports happens after everything else has --- been typechecked. - - - --- Renaming exports lists is a minefield. Five different things can appear in --- children export lists ( T(A, B, C) ). --- 1. Record selectors --- 2. Type constructors --- 3. Data constructors --- 4. Pattern Synonyms --- 5. Pattern Synonym Selectors --- --- However, things get put into weird name spaces. --- 1. Some type constructors are parsed as variables (-.->) for example. --- 2. All data constructors are parsed as type constructors --- 3. When there is ambiguity, we default type constructors to data --- constructors and require the explicit `type` keyword for type --- constructors. --- --- This function first establishes the possible namespaces that an --- identifier might be in (`choosePossibleNameSpaces`). --- --- Then for each namespace in turn, tries to find the correct identifier --- there returning the first positive result or the first terminating --- error. --- - - --- Records the result of looking up a child. -data ChildLookupResult - = NameNotFound -- We couldn't find a suitable name - | NameErr ErrMsg -- We found an unambiguous name - -- but there's another error - -- we should abort from - | FoundName Name -- We resolved to a normal name - | FoundFL FieldLabel -- We resolved to a FL - -instance Outputable ChildLookupResult where - ppr NameNotFound = text "NameNotFound" - ppr (FoundName n) = text "Found:" <+> ppr n - ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls - ppr (NameErr _) = text "Error" - --- Left biased accumulation monoid. Chooses the left-most positive occurrence. -instance Monoid ChildLookupResult where - mempty = NameNotFound - NameNotFound `mappend` m2 = m2 - NameErr m `mappend` _ = NameErr m -- Abort from the first error - FoundName n1 `mappend` _ = FoundName n1 - FoundFL fls `mappend` _ = FoundFL fls - -lookupChildrenExport :: Name -> [LIEWrappedName RdrName] - -> RnM ([LIEWrappedName Name], [Located FieldLabel]) -lookupChildrenExport parent rdr_items = - do - xs <- mapAndReportM doOne rdr_items - return $ partitionEithers xs - where - -- Pick out the possible namespaces in order of priority - -- This is a consequence of how the parser parses all - -- data constructors as type constructors. - choosePossibleNamespaces :: NameSpace -> [NameSpace] - choosePossibleNamespaces ns - | ns == varName = [varName, tcName] - | ns == tcName = [dataName, tcName] - | otherwise = [ns] - -- Process an individual child - doOne :: LIEWrappedName RdrName - -> RnM (Either (LIEWrappedName Name) (Located FieldLabel)) - doOne n = do - - let bareName = (ieWrappedName . unLoc) n - lkup v = lookupExportChild parent (setRdrNameSpace bareName v) - - name <- tryChildLookupResult $ map lkup $ - (choosePossibleNamespaces (rdrNameSpace bareName)) - - -- Default to data constructors for slightly better error - -- messages - let unboundName :: RdrName - unboundName = if rdrNameSpace bareName == varName - then bareName - else setRdrNameSpace bareName dataName - - case name of - NameNotFound -> do { ub <- reportUnboundName unboundName - ; let l = getLoc n - ; return (Left (L l (IEName (L l ub))))} - - FoundFL fls -> return $ Right (L (getLoc n) fls) - FoundName name -> return $ Left (replaceLWrappedName n name) - NameErr err_msg -> reportError err_msg >> failM - -tryChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult -tryChildLookupResult [x] = x -tryChildLookupResult (x:xs) = do - res <- x - case res of - FoundFL {} -> return res - FoundName {} -> return res - NameErr {} -> return res - _ -> tryChildLookupResult xs -tryChildLookupResult _ = panic "tryChildLookupResult:empty list" - - - --- | Also captures the current context -mkNameErr :: SDoc -> TcM ChildLookupResult -mkNameErr errMsg = do - tcinit <- tcInitTidyEnv - NameErr <$> mkErrTcM (tcinit, errMsg) - - --- | Used in export lists to lookup the children. -lookupExportChild :: Name -> RdrName -> RnM ChildLookupResult -lookupExportChild parent rdr_name - | isUnboundName parent - -- Avoid an error cascade - = return (FoundName (mkUnboundNameRdr rdr_name)) - - | otherwise = do - gre_env <- getGlobalRdrEnv - - let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name) - -- Disambiguate the lookup based on the parent information. - -- The remaining GREs are things that we *could* export here, note that - -- this includes things which have `NoParent`. Those are sorted in - -- `checkPatSynParent`. - traceRn "lookupExportChild original_gres:" (ppr original_gres) - case picked_gres original_gres of - NoOccurrence -> - noMatchingParentErr original_gres - UniqueOccurrence g -> - checkPatSynParent parent (gre_name g) - DisambiguatedOccurrence g -> - checkFld g - AmbiguousOccurrence gres -> - mkNameClashErr gres - where - -- Convert into FieldLabel if necessary - checkFld :: GlobalRdrElt -> RnM ChildLookupResult - checkFld g@GRE{gre_name, gre_par} = do - addUsedGRE True g - return $ case gre_par of - FldParent _ mfs -> do - FoundFL (fldParentToFieldLabel gre_name mfs) - _ -> FoundName gre_name - - fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel - fldParentToFieldLabel name mfs = - case mfs of - Nothing -> - let fs = occNameFS (nameOccName name) - in FieldLabel fs False name - Just fs -> FieldLabel fs True name - - -- Called when we fine no matching GREs after disambiguation but - -- there are three situations where this happens. - -- 1. There were none to begin with. - -- 2. None of the matching ones were the parent but - -- a. They were from an overloaded record field so we can report - -- a better error - -- b. The original lookup was actually ambiguous. - -- For example, the case where overloading is off and two - -- record fields are in scope from different record - -- constructors, neither of which is the parent. - noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult - noMatchingParentErr original_gres = do - overload_ok <- xoptM LangExt.DuplicateRecordFields - case original_gres of - [] -> return NameNotFound - [g] -> mkDcErrMsg parent (gre_name g) [p | Just p <- [getParent g]] - gss@(g:_:_) -> - if all isRecFldGRE gss && overload_ok - then mkNameErr (dcErrMsg parent "record selector" - (expectJust "noMatchingParentErr" (greLabel g)) - [ppr p | x <- gss, Just p <- [getParent x]]) - else mkNameClashErr gss - - mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult - mkNameClashErr gres = do - addNameClashErrRn rdr_name gres - return (FoundName (gre_name (head gres))) - - getParent :: GlobalRdrElt -> Maybe Name - getParent (GRE { gre_par = p } ) = - case p of - ParentIs cur_parent -> Just cur_parent - FldParent { par_is = cur_parent } -> Just cur_parent - NoParent -> Nothing - - picked_gres :: [GlobalRdrElt] -> DisambigInfo - picked_gres gres - | isUnqual rdr_name = mconcat (map right_parent gres) - | otherwise = mconcat (map right_parent (pickGREs rdr_name gres)) - - - right_parent :: GlobalRdrElt -> DisambigInfo - right_parent p - | Just cur_parent <- getParent p - = if parent == cur_parent - then DisambiguatedOccurrence p - else NoOccurrence - | otherwise - = UniqueOccurrence p - --- This domain specific datatype is used to record why we decided it was --- possible that a GRE could be exported with a parent. -data DisambigInfo - = NoOccurrence - -- The GRE could never be exported. It has the wrong parent. - | UniqueOccurrence GlobalRdrElt - -- The GRE has no parent. It could be a pattern synonym. - | DisambiguatedOccurrence GlobalRdrElt - -- The parent of the GRE is the correct parent - | AmbiguousOccurrence [GlobalRdrElt] - -- For example, two normal identifiers with the same name are in - -- scope. They will both be resolved to "UniqueOccurrence" and the - -- monoid will combine them to this failing case. - -instance Monoid DisambigInfo where - mempty = NoOccurrence - -- This is the key line: We prefer disambiguated occurrences to other - -- names. Notice that two disambiguated occurences are not ambiguous as - -- there is an internal invariant that a list of `DisambigInfo` arises - -- from a list of GREs which all have the same OccName. Thus, if we ever - -- have two DisambiguatedOccurences then they must have arisen from the - -- same GRE and hence it's safe to discard one. - _ `mappend` DisambiguatedOccurrence g' = DisambiguatedOccurrence g' - DisambiguatedOccurrence g' `mappend` _ = DisambiguatedOccurrence g' - - - NoOccurrence `mappend` m = m - m `mappend` NoOccurrence = m - UniqueOccurrence g `mappend` UniqueOccurrence g' = AmbiguousOccurrence [g, g'] - UniqueOccurrence g `mappend` AmbiguousOccurrence gs = AmbiguousOccurrence (g:gs) - AmbiguousOccurrence gs `mappend` UniqueOccurrence g' = AmbiguousOccurrence (g':gs) - AmbiguousOccurrence gs `mappend` AmbiguousOccurrence gs' = AmbiguousOccurrence (gs ++ gs') - - - - --- --- Note: [Typing Pattern Synonym Exports] --- It proved quite a challenge to precisely specify which pattern synonyms --- should be allowed to be bundled with which type constructors. --- In the end it was decided to be quite liberal in what we allow. Below is --- how Simon described the implementation. --- --- "Personally I think we should Keep It Simple. All this talk of --- satisfiability makes me shiver. I suggest this: allow T( P ) in all --- situations except where `P`'s type is ''visibly incompatible'' with --- `T`. --- --- What does "visibly incompatible" mean? `P` is visibly incompatible --- with --- `T` if --- * `P`'s type is of form `... -> S t1 t2` --- * `S` is a data/newtype constructor distinct from `T` --- --- Nothing harmful happens if we allow `P` to be exported with --- a type it can't possibly be useful for, but specifying a tighter --- relationship is very awkward as you have discovered." --- --- Note that this allows *any* pattern synonym to be bundled with any --- datatype type constructor. For example, the following pattern `P` can be --- bundled with any type. --- --- ``` --- pattern P :: (A ~ f) => f --- ``` --- --- So we provide basic type checking in order to help the user out, most --- pattern synonyms are defined with definite type constructors, but don't --- actually prevent a library author completely confusing their users if --- they want to. --- --- So, we check for exactly four things --- 1. The name arises from a pattern synonym definition. (Either a pattern --- synonym constructor or a pattern synonym selector) --- 2. The pattern synonym is only bundled with a datatype or newtype. --- 3. Check that the head of the result type constructor is an actual type --- constructor and not a type variable. (See above example) --- 4. Is so, check that this type constructor is the same as the parent --- type constructor. --- --- --- Note: [Types of TyCon] --- --- This check appears to be overlly complicated, Richard asked why it --- is not simply just `isAlgTyCon`. The answer for this is that --- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. --- (It is either a newtype or data depending on the number of methods) --- - --- | Given a resolved name in the children export list and a parent. Decide --- whether we are allowed to export the child with the parent. --- Invariant: gre_par == NoParent --- See note [Typing Pattern Synonym Exports] -checkPatSynParent :: Name -- ^ Type constructor - -> Name -- ^ Either a - -- a) Pattern Synonym Constructor - -- b) A pattern synonym selector - -> TcM ChildLookupResult -checkPatSynParent parent mpat_syn = do - parent_ty_con <- tcLookupTyCon parent - mpat_syn_thing <- tcLookupGlobal mpat_syn - let expected_res_ty = - mkTyConApp parent_ty_con (mkTyVarTys (tyConTyVars parent_ty_con)) - - handlePatSyn errCtxt = - addErrCtxt errCtxt - . tc_one_ps_export_with expected_res_ty parent_ty_con - -- 1. Check that the Id was actually from a thing associated with patsyns - case mpat_syn_thing of - AnId i - | isId i -> - case idDetails i of - RecSelId { sel_tycon = RecSelPatSyn p } -> handlePatSyn (selErr i) p - _ -> mkDcErrMsg parent mpat_syn [] - AConLike (PatSynCon p) -> handlePatSyn (psErr p) p - _ -> mkDcErrMsg parent mpat_syn [] - where - - psErr = exportErrCtxt "pattern synonym" - selErr = exportErrCtxt "pattern synonym record selector" - - assocClassErr :: SDoc - assocClassErr = - text "Pattern synonyms can be bundled only with datatypes." - - tc_one_ps_export_with :: TcTauType -- ^ TyCon type - -> TyCon -- ^ Parent TyCon - -> PatSyn -- ^ Corresponding bundled PatSyn - -- and pretty printed origin - -> TcM ChildLookupResult - tc_one_ps_export_with expected_res_ty ty_con pat_syn - - -- 2. See note [Types of TyCon] - | not $ isTyConWithSrcDataCons ty_con = mkNameErr assocClassErr - -- 3. Is the head a type variable? - | Nothing <- mtycon = return (FoundName mpat_syn) - -- 4. Ok. Check they are actually the same type constructor. - | Just p_ty_con <- mtycon, p_ty_con /= ty_con = mkNameErr typeMismatchError - -- 5. We passed! - | otherwise = return (FoundName mpat_syn) - - where - (_, _, _, _, _, res_ty) = patSynSig pat_syn - mtycon = fst <$> tcSplitTyConApp_maybe res_ty - typeMismatchError :: SDoc - typeMismatchError = - text "Pattern synonyms can only be bundled with matching type constructors" - $$ text "Couldn't match expected type of" - <+> quotes (ppr expected_res_ty) - <+> text "with actual type of" - <+> quotes (ppr res_ty) - - - - -{-===========================================================================-} - - -check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap -check_occs ie occs names -- 'names' are the entities specifed by 'ie' - = foldlM check occs names - where - check occs name - = case lookupOccEnv occs name_occ of - Nothing -> return (extendOccEnv occs name_occ (name, ie)) - - Just (name', ie') - | name == name' -- Duplicate export - -- But we don't want to warn if the same thing is exported - -- by two different module exports. See ticket #4478. - -> do { warnIf (Reason Opt_WarnDuplicateExports) - (not (dupExport_ok name ie ie')) - (dupExportWarn name_occ ie ie') - ; return occs } - - | otherwise -- Same occ name but different names: an error - -> do { global_env <- getGlobalRdrEnv ; - addErr (exportClashErr global_env name' name ie' ie) ; - return occs } - where - name_occ = nameOccName name - - -dupExport_ok :: Name -> IE RdrName -> IE RdrName -> Bool --- The Name is exported by both IEs. Is that ok? --- "No" iff the name is mentioned explicitly in both IEs --- or one of the IEs mentions the name *alone* --- "Yes" otherwise --- --- Examples of "no": module M( f, f ) --- module M( fmap, Functor(..) ) --- module M( module Data.List, head ) --- --- Example of "yes" --- module M( module A, module B ) where --- import A( f ) --- import B( f ) --- --- Example of "yes" (Trac #2436) --- module M( C(..), T(..) ) where --- class C a where { data T a } --- instance C Int where { data T Int = TInt } --- --- Example of "yes" (Trac #2436) --- module Foo ( T ) where --- data family T a --- module Bar ( T(..), module Foo ) where --- import Foo --- data instance T Int = TInt - -dupExport_ok n ie1 ie2 - = not ( single ie1 || single ie2 - || (explicit_in ie1 && explicit_in ie2) ) - where - explicit_in (IEModuleContents _) = False -- module M - explicit_in (IEThingAll r) - = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..) - explicit_in _ = True - - single IEVar {} = True - single IEThingAbs {} = True - single _ = False - - -dupModuleExport :: ModuleName -> SDoc -dupModuleExport mod - = hsep [text "Duplicate", - quotes (text "Module" <+> ppr mod), - text "in export list"] - -moduleNotImported :: ModuleName -> SDoc -moduleNotImported mod - = text "The export item `module" <+> ppr mod <> - text "' is not imported" - -nullModuleExport :: ModuleName -> SDoc -nullModuleExport mod - = text "The export item `module" <+> ppr mod <> ptext (sLit "' exports nothing") - - -dodgyExportWarn :: Name -> SDoc -dodgyExportWarn item = dodgyMsg (text "export") item - -exportErrCtxt :: Outputable o => String -> o -> SDoc -exportErrCtxt herald exp = - text "In the" <+> text (herald ++ ":") <+> ppr exp - - -addExportErrCtxt :: (HasOccName s, OutputableBndr s) => IE s -> TcM a -> TcM a -addExportErrCtxt ie = addErrCtxt exportCtxt - where - exportCtxt = text "In the export:" <+> ppr ie - -exportItemErr :: IE RdrName -> SDoc -exportItemErr export_item - = sep [ text "The export item" <+> quotes (ppr export_item), - text "attempts to export constructors or class methods that are not visible here" ] - - -dupExportWarn :: OccName -> IE RdrName -> IE RdrName -> SDoc -dupExportWarn occ_name ie1 ie2 - = hsep [quotes (ppr occ_name), - text "is exported by", quotes (ppr ie1), - text "and", quotes (ppr ie2)] - -dcErrMsg :: Outputable a => Name -> String -> a -> [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 (ppr 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) - -mkDcErrMsg :: Name -> Name -> [Name] -> TcM ChildLookupResult -mkDcErrMsg parent thing parents = do - ty_thing <- tcLookupGlobal thing - mkNameErr (dcErrMsg parent (tyThingCategory' ty_thing) thing (map ppr parents)) - where - tyThingCategory' :: TyThing -> String - tyThingCategory' (AnId i) - | isRecordSelector i = "record selector" - tyThingCategory' i = tyThingCategory i - - -exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName - -> MsgDoc -exportClashErr global_env name1 name2 ie1 ie2 - = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon - , ppr_export ie1' name1' - , ppr_export ie2' name2' ] - where - occ = nameOccName name1 - ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> - quotes (ppr name)) - 2 (pprNameProvenance (get_gre name))) - - -- get_gre finds a GRE for the Name, so that we can show its provenance - get_gre name - = fromMaybe (pprPanic "exportClashErr" (ppr name)) (lookupGRE_Name global_env name) - get_loc name = greSrcSpan (get_gre name) - (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2 - then (name1, ie1, name2, ie2) - else (name2, ie2, name1, ie1) diff --git a/typecheck/TcRnMonad.hs b/typecheck/TcRnMonad.hs deleted file mode 100644 --- a/typecheck/TcRnMonad.hs +++ /dev/null @@ -1,1856 +0,0 @@ -{- -(c) The University of Glasgow 2006 - - -Functions for working with the typechecker environment (setters, getters...). --} - -{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module TcRnMonad( - -- * Initalisation - initTc, initTcWithGbl, initTcInteractive, initTcForLookup, initTcRnIf, - - -- * Simple accessors - discardResult, - getTopEnv, updTopEnv, getGblEnv, updGblEnv, - setGblEnv, getLclEnv, updLclEnv, setLclEnv, - getEnvs, setEnvs, - xoptM, doptM, goptM, woptM, - setXOptM, unsetXOptM, unsetGOptM, unsetWOptM, - whenDOptM, whenGOptM, whenWOptM, whenXOptM, - getGhcMode, - withDoDynamicToo, - getEpsVar, - getEps, - updateEps, updateEps_, - getHpt, getEpsAndHpt, - - -- * Arrow scopes - newArrowScope, escapeArrowScope, - - -- * Unique supply - newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName, - newSysName, newSysLocalId, newSysLocalIds, - - -- * Accessing input/output - newTcRef, readTcRef, writeTcRef, updTcRef, - - -- * Debugging - traceTc, traceRn, traceOptTcRn, traceTcRn, - getPrintUnqualified, - printForUserTcRn, - traceIf, traceHiDiffs, traceOptIf, - debugTc, - - -- * Typechecker global environment - getIsGHCi, getGHCiMonad, getInteractivePrintName, - tcIsHsBootOrSig, tcSelfBootInfo, getGlobalRdrEnv, - getRdrEnvs, getImports, - getFixityEnv, extendFixityEnv, getRecFieldEnv, - getDeclaredDefaultTys, - addDependentFiles, - - -- * Error management - getSrcSpanM, setSrcSpan, addLocM, - wrapLocM, wrapLocFstM, wrapLocSndM, - getErrsVar, setErrsVar, - addErr, - failWith, failAt, - addErrAt, addErrs, - checkErr, - addMessages, - discardWarnings, - - -- * Shared error message stuff: renamer and typechecker - mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError, - reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, - tryTc, - askNoErrs, discardErrs, tryTcDiscardingErrs, - checkNoErrs, whenNoErrs, - ifErrsM, failIfErrsM, - checkTH, failTH, - - -- * Context management for the type checker - getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, - addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM, - - -- * Error message generation (type checker) - addErrTc, addErrsTc, - addErrTcM, mkErrTcM, - failWithTc, failWithTcM, - checkTc, checkTcM, - failIfTc, failIfTcM, - warnIf, warnTc, warnTcM, - addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn, - tcInitTidyEnv, tcInitOpenTidyEnv, mkErrInfo, - - -- * Type constraints - newTcEvBinds, - addTcEvBind, - getTcEvTyCoVars, getTcEvBindsMap, - chooseUniqueOccTc, - getConstraintVar, setConstraintVar, - emitConstraints, emitStaticConstraints, emitSimple, emitSimples, - emitImplication, emitImplications, emitInsoluble, - discardConstraints, captureConstraints, tryCaptureConstraints, - pushLevelAndCaptureConstraints, - pushTcLevelM_, pushTcLevelM, - getTcLevel, setTcLevel, isTouchableTcM, - getLclTypeEnv, setLclTypeEnv, - traceTcConstraints, emitWildCardHoleConstraints, - - -- * Template Haskell context - recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc, - getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage, - addModFinalizersWithLclEnv, - - -- * Safe Haskell context - recordUnsafeInfer, finalSafeMode, fixSafeInstances, - - -- * Stuff for the renamer's local env - getLocalRdrEnv, setLocalRdrEnv, - - -- * Stuff for interface decls - mkIfLclEnv, - initIfaceTcRn, - initIfaceCheck, - initIfaceLcl, - initIfaceLclWithSubst, - initIfaceLoad, - getIfModule, - failIfM, - forkM_maybe, - forkM, - setImplicitEnvM, - - withException, - - -- * Types etc. - module TcRnTypes, - module IOEnv - ) where - -#include "HsVersions.h" - -import TcRnTypes -- Re-export all -import IOEnv -- Re-export all -import TcEvidence - -import HsSyn hiding (LIE) -import HscTypes -import Module -import RdrName -import Name -import Type - -import TcType -import InstEnv -import FamInstEnv -import PrelNames - -import Id -import VarSet -import VarEnv -import ErrUtils -import SrcLoc -import NameEnv -import NameSet -import Bag -import Outputable -import UniqSupply -import DynFlags -import FastString -import Panic -import Util -import Annotations -import BasicTypes( TopLevelFlag ) -import Maybes - -import qualified GHC.LanguageExtensions as LangExt - -import Control.Exception -import Data.IORef -import Control.Monad -import Data.Set ( Set ) -import qualified Data.Set as Set - -import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers ) -import qualified Data.Map as Map - -{- -************************************************************************ -* * - initTc -* * -************************************************************************ --} - --- | Setup the initial typechecking environment -initTc :: HscEnv - -> HscSource - -> Bool -- True <=> retain renamed syntax trees - -> Module - -> RealSrcSpan - -> TcM r - -> IO (Messages, Maybe r) - -- Nothing => error thrown by the thing inside - -- (error messages should have been printed already) - -initTc hsc_env hsc_src keep_rn_syntax mod loc do_this - = do { keep_var <- newIORef emptyNameSet ; - used_gre_var <- newIORef [] ; - th_var <- newIORef False ; - th_splice_var<- newIORef False ; - th_locs_var <- newIORef Set.empty ; - infer_var <- newIORef (True, emptyBag) ; - dfun_n_var <- newIORef emptyOccSet ; - type_env_var <- case hsc_type_env_var hsc_env of { - Just (_mod, te_var) -> return te_var ; - Nothing -> newIORef emptyNameEnv } ; - - dependent_files_var <- newIORef [] ; - static_wc_var <- newIORef emptyWC ; - th_topdecls_var <- newIORef [] ; - th_foreign_files_var <- newIORef [] ; - th_topnames_var <- newIORef emptyNameSet ; - th_modfinalizers_var <- newIORef [] ; - th_state_var <- newIORef Map.empty ; - th_remote_state_var <- newIORef Nothing ; - let { - dflags = hsc_dflags hsc_env ; - - maybe_rn_syntax :: forall a. a -> Maybe a ; - maybe_rn_syntax empty_val - | dopt Opt_D_dump_rn_ast dflags = Just empty_val - | keep_rn_syntax = Just empty_val - | otherwise = Nothing ; - - gbl_env = TcGblEnv { - tcg_th_topdecls = th_topdecls_var, - tcg_th_foreign_files = th_foreign_files_var, - tcg_th_topnames = th_topnames_var, - tcg_th_modfinalizers = th_modfinalizers_var, - tcg_th_state = th_state_var, - tcg_th_remote_state = th_remote_state_var, - - tcg_mod = mod, - tcg_semantic_mod = - if thisPackage dflags == moduleUnitId mod - then canonicalizeHomeModule dflags (moduleName mod) - else mod, - tcg_src = hsc_src, - tcg_rdr_env = emptyGlobalRdrEnv, - tcg_fix_env = emptyNameEnv, - tcg_field_env = emptyNameEnv, - tcg_default = if moduleUnitId mod == primUnitId - then Just [] -- See Note [Default types] - else Nothing, - tcg_type_env = emptyNameEnv, - tcg_type_env_var = type_env_var, - tcg_inst_env = emptyInstEnv, - tcg_fam_inst_env = emptyFamInstEnv, - tcg_pending_fam_checks = emptyNameEnv, - tcg_ann_env = emptyAnnEnv, - tcg_th_used = th_var, - tcg_th_splice_used = th_splice_var, - tcg_th_top_level_locs - = th_locs_var, - tcg_exports = [], - tcg_imports = emptyImportAvails, - tcg_used_gres = used_gre_var, - tcg_dus = emptyDUs, - - tcg_rn_imports = [], - tcg_rn_exports = - if hsc_src == HsigFile - -- Always retain renamed syntax, so that we can give - -- better errors. (TODO: how?) - then Just [] - else maybe_rn_syntax [], - tcg_rn_decls = maybe_rn_syntax emptyRnGroup, - tcg_tr_module = Nothing, - tcg_binds = emptyLHsBinds, - tcg_imp_specs = [], - tcg_sigs = emptyNameSet, - tcg_ev_binds = emptyBag, - tcg_warns = NoWarnings, - tcg_anns = [], - tcg_tcs = [], - tcg_insts = [], - tcg_fam_insts = [], - tcg_rules = [], - tcg_fords = [], - tcg_vects = [], - tcg_patsyns = [], - tcg_merged = [], - tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var, - tcg_doc_hdr = Nothing, - tcg_hpc = False, - tcg_main = Nothing, - tcg_self_boot = NoSelfBoot, - tcg_safeInfer = infer_var, - tcg_dependent_files = dependent_files_var, - tcg_tc_plugins = [], - tcg_top_loc = loc, - tcg_static_wc = static_wc_var, - tcg_complete_matches = [] - } ; - } ; - - -- OK, here's the business end! - initTcWithGbl hsc_env gbl_env loc do_this - } - --- | Run a 'TcM' action in the context of an existing 'GblEnv'. -initTcWithGbl :: HscEnv - -> TcGblEnv - -> RealSrcSpan - -> TcM r - -> IO (Messages, Maybe r) -initTcWithGbl hsc_env gbl_env loc do_this - = do { tvs_var <- newIORef emptyVarSet - ; lie_var <- newIORef emptyWC - ; errs_var <- newIORef (emptyBag, emptyBag) - ; let lcl_env = TcLclEnv { - tcl_errs = errs_var, - tcl_loc = loc, -- Should be over-ridden very soon! - tcl_ctxt = [], - tcl_rdr = emptyLocalRdrEnv, - tcl_th_ctxt = topStage, - tcl_th_bndrs = emptyNameEnv, - tcl_arrow_ctxt = NoArrowCtxt, - tcl_env = emptyNameEnv, - tcl_bndrs = [], - tcl_tidy = emptyTidyEnv, - tcl_tyvars = tvs_var, - tcl_lie = lie_var, - tcl_tclvl = topTcLevel - } - - ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ - do { r <- tryM do_this - ; case r of - Right res -> return (Just res) - Left _ -> return Nothing } - - -- Check for unsolved constraints - -- If we succeed (maybe_res = Just r), there should be - -- no unsolved constraints. But if we exit via an - -- exception (maybe_res = Nothing), we may have skipped - -- solving, so don't panic then (Trac #13466) - ; lie <- readIORef (tcl_lie lcl_env) - ; when (isJust maybe_res && not (isEmptyWC lie)) $ - pprPanic "initTc: unsolved constraints" (ppr lie) - - -- Collect any error messages - ; msgs <- readIORef (tcl_errs lcl_env) - - ; let { final_res | errorsFound dflags msgs = Nothing - | otherwise = maybe_res } - - ; return (msgs, final_res) - } - where dflags = hsc_dflags hsc_env - -initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a) --- Initialise the type checker monad for use in GHCi -initTcInteractive hsc_env thing_inside - = initTc hsc_env HsSrcFile False - (icInteractiveModule (hsc_IC hsc_env)) - (realSrcLocSpan interactive_src_loc) - thing_inside - where - interactive_src_loc = mkRealSrcLoc (fsLit "") 1 1 - -initTcForLookup :: HscEnv -> TcM a -> IO a --- The thing_inside is just going to look up something --- in the environment, so we don't need much setup -initTcForLookup hsc_env thing_inside - = do { (msgs, m) <- initTcInteractive hsc_env thing_inside - ; case m of - Nothing -> throwIO $ mkSrcErr $ snd msgs - Just x -> return x } - -{- Note [Default types] -~~~~~~~~~~~~~~~~~~~~~~~ -The Integer type is simply not available in package ghc-prim (it is -declared in integer-gmp). So we set the defaulting types to (Just -[]), meaning there are no default types, rather then Nothing, which -means "use the default default types of Integer, Double". - -If you don't do this, attempted defaulting in package ghc-prim causes -an actual crash (attempting to look up the Integer type). - - -************************************************************************ -* * - Initialisation -* * -************************************************************************ --} - -initTcRnIf :: Char -- Tag for unique supply - -> HscEnv - -> gbl -> lcl - -> TcRnIf gbl lcl a - -> IO a -initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside - = do { us <- mkSplitUniqSupply uniq_tag ; - ; us_var <- newIORef us ; - - ; let { env = Env { env_top = hsc_env, - env_us = us_var, - env_gbl = gbl_env, - env_lcl = lcl_env} } - - ; runIOEnv env thing_inside - } - -{- -************************************************************************ -* * - Simple accessors -* * -************************************************************************ --} - -discardResult :: TcM a -> TcM () -discardResult a = a >> return () - -getTopEnv :: TcRnIf gbl lcl HscEnv -getTopEnv = do { env <- getEnv; return (env_top env) } - -updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updTopEnv upd = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = upd top }) - -getGblEnv :: TcRnIf gbl lcl gbl -getGblEnv = do { env <- getEnv; return (env_gbl env) } - -updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> - env { env_gbl = upd gbl }) - -setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) - -getLclEnv :: TcRnIf gbl lcl lcl -getLclEnv = do { env <- getEnv; return (env_lcl env) } - -updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> - env { env_lcl = upd lcl }) - -setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a -setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) - -getEnvs :: TcRnIf gbl lcl (gbl, lcl) -getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } - -setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a -setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) - --- Command-line flags - -xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool -xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } - -doptM :: DumpFlag -> TcRnIf gbl lcl Bool -doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } - -goptM :: GeneralFlag -> TcRnIf gbl lcl Bool -goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) } - -woptM :: WarningFlag -> TcRnIf gbl lcl Bool -woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } - -setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag}) - -unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag}) - -unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetGOptM flag = - updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag}) - -unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetWOptM flag = - updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag}) - --- | Do it flag is true -whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenDOptM flag thing_inside = do b <- doptM flag - when b thing_inside - -whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenGOptM flag thing_inside = do b <- goptM flag - when b thing_inside - -whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenWOptM flag thing_inside = do b <- woptM flag - when b thing_inside - -whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenXOptM flag thing_inside = do b <- xoptM flag - when b thing_inside - -getGhcMode :: TcRnIf gbl lcl GhcMode -getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } - -withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a -withDoDynamicToo = - updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) -> - top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags }) - -getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) -getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } - -getEps :: TcRnIf gbl lcl ExternalPackageState -getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } - --- | Update the external package state. Returns the second result of the --- modifier function. --- --- This is an atomic operation and forces evaluation of the modified EPS in --- order to avoid space leaks. -updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) - -> TcRnIf gbl lcl a -updateEps upd_fn = do - traceIf (text "updating EPS") - eps_var <- getEpsVar - atomicUpdMutVar' eps_var upd_fn - --- | Update the external package state. --- --- This is an atomic operation and forces evaluation of the modified EPS in --- order to avoid space leaks. -updateEps_ :: (ExternalPackageState -> ExternalPackageState) - -> TcRnIf gbl lcl () -updateEps_ upd_fn = do - traceIf (text "updating EPS_") - eps_var <- getEpsVar - atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ())) - -getHpt :: TcRnIf gbl lcl HomePackageTable -getHpt = do { env <- getTopEnv; return (hsc_HPT env) } - -getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) -getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) - ; return (eps, hsc_HPT env) } - --- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing --- an exception if it is an error. -withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a -withException do_this = do - r <- do_this - dflags <- getDynFlags - case r of - Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Succeeded result -> return result - -{- -************************************************************************ -* * - Arrow scopes -* * -************************************************************************ --} - -newArrowScope :: TcM a -> TcM a -newArrowScope - = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) } - --- Return to the stored environment (from the enclosing proc) -escapeArrowScope :: TcM a -> TcM a -escapeArrowScope - = updLclEnv $ \ env -> - case tcl_arrow_ctxt env of - NoArrowCtxt -> env - ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt - , tcl_lie = lie - , tcl_rdr = rdr_env } - -{- -************************************************************************ -* * - Unique supply -* * -************************************************************************ --} - -newUnique :: TcRnIf gbl lcl Unique -newUnique - = do { env <- getEnv ; - let { u_var = env_us env } ; - us <- readMutVar u_var ; - case takeUniqFromSupply us of { (uniq, us') -> do { - writeMutVar u_var us' ; - return $! uniq }}} - -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving - -- a chain of unevaluated supplies behind. - -- NOTE 2: we use the uniq in the supply from the MutVar directly, and - -- throw away one half of the new split supply. This is safe because this - -- is the only place we use that unique. Using the other half of the split - -- supply is safer, but slower. - -newUniqueSupply :: TcRnIf gbl lcl UniqSupply -newUniqueSupply - = do { env <- getEnv ; - let { u_var = env_us env } ; - us <- readMutVar u_var ; - case splitUniqSupply us of { (us1,us2) -> do { - writeMutVar u_var us1 ; - return us2 }}} - -cloneLocalName :: Name -> TcM Name --- Make a fresh Internal name with the same OccName and SrcSpan -cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name) - -newName :: OccName -> TcM Name -newName occ = do { loc <- getSrcSpanM - ; newNameAt occ loc } - -newNameAt :: OccName -> SrcSpan -> TcM Name -newNameAt occ span - = do { uniq <- newUnique - ; return (mkInternalName uniq occ span) } - -newSysName :: OccName -> TcRnIf gbl lcl Name -newSysName occ - = do { uniq <- newUnique - ; return (mkSystemName uniq occ) } - -newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId -newSysLocalId fs ty - = do { u <- newUnique - ; return (mkSysLocalOrCoVar fs u ty) } - -newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] -newSysLocalIds fs tys - = do { us <- newUniqueSupply - ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) } - -instance MonadUnique (IOEnv (Env gbl lcl)) where - getUniqueM = newUnique - getUniqueSupplyM = newUniqueSupply - -{- -************************************************************************ -* * - Accessing input/output -* * -************************************************************************ --} - -newTcRef :: a -> TcRnIf gbl lcl (TcRef a) -newTcRef = newMutVar - -readTcRef :: TcRef a -> TcRnIf gbl lcl a -readTcRef = readMutVar - -writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl () -writeTcRef = writeMutVar - -updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () --- Returns () -updTcRef ref fn = liftIO $ do { old <- readIORef ref - ; writeIORef ref (fn old) } - -{- -************************************************************************ -* * - Debugging -* * -************************************************************************ --} - - --- Typechecker trace -traceTc :: String -> SDoc -> TcRn () -traceTc = - labelledTraceOptTcRn Opt_D_dump_tc_trace - --- Renamer Trace -traceRn :: String -> SDoc -> TcRn () -traceRn = - labelledTraceOptTcRn Opt_D_dump_rn_trace - --- | Trace when a certain flag is enabled. This is like `traceOptTcRn` --- but accepts a string as a label and formats the trace message uniformly. -labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn () -labelledTraceOptTcRn flag herald doc = do - traceOptTcRn flag (formatTraceMsg herald doc) - -formatTraceMsg :: String -> SDoc -> SDoc -formatTraceMsg herald doc = hang (text herald) 2 doc - --- | Output a doc if the given 'DumpFlag' is set. --- --- By default this logs to stdout --- However, if the `-ddump-to-file` flag is set, --- then this will dump output to a file --- --- Just a wrapper for 'dumpSDoc' -traceOptTcRn :: DumpFlag -> SDoc -> TcRn () -traceOptTcRn flag doc - = do { dflags <- getDynFlags - ; when (dopt flag dflags) - (traceTcRn flag doc) - } - - -traceTcRn :: DumpFlag -> SDoc -> TcRn () --- ^ Unconditionally dump some trace output --- --- The DumpFlag is used only to set the output filename --- for --dump-to-file, not to decide whether or not to output --- That part is done by the caller -traceTcRn flag doc - = do { dflags <- getDynFlags - ; real_doc <- prettyDoc dflags doc - ; printer <- getPrintUnqualified dflags - ; liftIO $ dumpSDoc dflags printer flag "" real_doc } - where - -- Add current location if -dppr-debug - prettyDoc :: DynFlags -> SDoc -> TcRn SDoc - prettyDoc dflags doc = if hasPprDebug dflags - then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc } - else return doc -- The full location is usually way too much - - -getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified -getPrintUnqualified dflags - = do { rdr_env <- getGlobalRdrEnv - ; return $ mkPrintUnqualified dflags rdr_env } - --- | Like logInfoTcRn, but for user consumption -printForUserTcRn :: SDoc -> TcRn () -printForUserTcRn doc - = do { dflags <- getDynFlags - ; printer <- getPrintUnqualified dflags - ; liftIO (printOutputForUser dflags printer doc) } - -{- -traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is -available. Alas, they behave inconsistently with the other stuff; -e.g. are unaffected by -dump-to-file. --} - -traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () -traceIf = traceOptIf Opt_D_dump_if_trace -traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs - - -traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () -traceOptIf flag doc - = whenDOptM flag $ -- No RdrEnv available, so qualify everything - do { dflags <- getDynFlags - ; liftIO (putMsg dflags doc) } - -{- -************************************************************************ -* * - Typechecker global environment -* * -************************************************************************ --} - -getIsGHCi :: TcRn Bool -getIsGHCi = do { mod <- getModule - ; return (isInteractiveModule mod) } - -getGHCiMonad :: TcRn Name -getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } - -getInteractivePrintName :: TcRn Name -getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } - -tcIsHsBootOrSig :: TcRn Bool -tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } - -tcSelfBootInfo :: TcRn SelfBootInfo -tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) } - -getGlobalRdrEnv :: TcRn GlobalRdrEnv -getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } - -getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) -getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } - -getImports :: TcRn ImportAvails -getImports = do { env <- getGblEnv; return (tcg_imports env) } - -getFixityEnv :: TcRn FixityEnv -getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } - -extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a -extendFixityEnv new_bit - = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> - env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) - -getRecFieldEnv :: TcRn RecFieldEnv -getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } - -getDeclaredDefaultTys :: TcRn (Maybe [Type]) -getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } - -addDependentFiles :: [FilePath] -> TcRn () -addDependentFiles fs = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fs ++ dep_files) - -{- -************************************************************************ -* * - Error management -* * -************************************************************************ --} - -getSrcSpanM :: TcRn SrcSpan - -- Avoid clash with Name.getSrcLoc -getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) } - -setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -setSrcSpan (RealSrcSpan real_loc) thing_inside - = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside --- Don't overwrite useful info with useless: -setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside - -addLocM :: (a -> TcM b) -> Located a -> TcM b -addLocM fn (L loc a) = setSrcSpan loc $ fn a - -wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b) - -wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) -wrapLocFstM fn (L loc a) = - setSrcSpan loc $ do - (b,c) <- fn a - return (L loc b, c) - -wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c) -wrapLocSndM fn (L loc a) = - setSrcSpan loc $ do - (b,c) <- fn a - return (b, L loc c) - --- Reporting errors - -getErrsVar :: TcRn (TcRef Messages) -getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } - -setErrsVar :: TcRef Messages -> TcRn a -> TcRn a -setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) - -addErr :: MsgDoc -> TcRn () -addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } - -failWith :: MsgDoc -> TcRn a -failWith msg = addErr msg >> failM - -failAt :: SrcSpan -> MsgDoc -> TcRn a -failAt loc msg = addErrAt loc msg >> failM - -addErrAt :: SrcSpan -> MsgDoc -> TcRn () --- addErrAt is mainly (exclusively?) used by the renamer, where --- tidying is not an issue, but it's all lazy so the extra --- work doesn't matter -addErrAt loc msg = do { ctxt <- getErrCtxt - ; tidy_env <- tcInitTidyEnv - ; err_info <- mkErrInfo tidy_env ctxt - ; addLongErrAt loc msg err_info } - -addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () -addErrs msgs = mapM_ add msgs - where - add (loc,msg) = addErrAt loc msg - -checkErr :: Bool -> MsgDoc -> TcRn () --- Add the error if the bool is False -checkErr ok msg = unless ok (addErr msg) - -addMessages :: Messages -> TcRn () -addMessages msgs1 - = do { errs_var <- getErrsVar ; - msgs0 <- readTcRef errs_var ; - writeTcRef errs_var (unionMessages msgs0 msgs1) } - -discardWarnings :: TcRn a -> TcRn a --- Ignore warnings inside the thing inside; --- used to ignore-unused-variable warnings inside derived code -discardWarnings thing_inside - = do { errs_var <- getErrsVar - ; (old_warns, _) <- readTcRef errs_var - - ; result <- thing_inside - - -- Revert warnings to old_warns - ; (_new_warns, new_errs) <- readTcRef errs_var - ; writeTcRef errs_var (old_warns, new_errs) - - ; return result } - -{- -************************************************************************ -* * - Shared error message stuff: renamer and typechecker -* * -************************************************************************ --} - -mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg -mkLongErrAt loc msg extra - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - return $ mkLongErrMsg dflags loc printer msg extra } - -mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg -mkErrDocAt loc errDoc - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - return $ mkErrDoc dflags loc printer errDoc } - -addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () -addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError - -reportErrors :: [ErrMsg] -> TcM () -reportErrors = mapM_ reportError - -reportError :: ErrMsg -> TcRn () -reportError err - = do { traceTc "Adding error:" (pprLocErrMsg err) ; - errs_var <- getErrsVar ; - (warns, errs) <- readTcRef errs_var ; - writeTcRef errs_var (warns, errs `snocBag` err) } - -reportWarning :: WarnReason -> ErrMsg -> TcRn () -reportWarning reason err - = do { let warn = makeIntoWarning reason err - -- 'err' was built by mkLongErrMsg or something like that, - -- so it's of error severity. For a warning we downgrade - -- its severity to SevWarning - - ; traceTc "Adding warning:" (pprLocErrMsg warn) - ; errs_var <- getErrsVar - ; (warns, errs) <- readTcRef errs_var - ; writeTcRef errs_var (warns `snocBag` warn, errs) } - -try_m :: TcRn r -> TcRn (Either IOEnvFailure r) --- Does tryM, with a debug-trace on failure -try_m thing - = do { (mb_r, lie) <- tryCaptureConstraints thing - ; emitConstraints lie - - -- Debug trace - ; case mb_r of - Left exn -> traceTc "tryTc/recoverM recovering from" $ - text (showException exn) - Right {} -> return () - - ; return mb_r } - ------------------------ -recoverM :: TcRn r -- Recovery action; do this if the main one fails - -> TcRn r -- Main action: do this first; - -- if it generates errors, propagate them all - -> TcRn r --- Errors in 'thing' are retained -recoverM recover thing - = do { mb_res <- try_m thing ; - case mb_res of - Left _ -> recover - Right res -> return res } - - ------------------------ - --- | Drop elements of the input that fail, so the result --- list can be shorter than the argument list -mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] -mapAndRecoverM f = fmap reverse . foldAndRecoverM (\xs x -> (:xs) <$> f x ) [] - --- | The accumulator is not updated if the action fails -foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b -foldAndRecoverM _ acc [] = return acc -foldAndRecoverM f acc (x:xs) = - do { mb_r <- try_m (f acc x) - ; case mb_r of - Left _ -> foldAndRecoverM f acc xs - Right acc' -> foldAndRecoverM f acc' xs } - --- | Succeeds if applying the argument to all members of the lists succeeds, --- but nevertheless runs it on all arguments, to collect all errors. -mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b] -mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs) - ------------------------ -tryTc :: TcRn a -> TcRn (Messages, Maybe a) --- (tryTc m) executes m, and returns --- Just r, if m succeeds (returning r) --- Nothing, if m fails --- It also returns all the errors and warnings accumulated by m --- It always succeeds (never raises an exception) -tryTc thing_inside - = do { errs_var <- newTcRef emptyMessages ; - - res <- try_m $ -- Be sure to catch exceptions, so that - -- we guaranteed to read the messages out - -- of that brand-new errs_var! - setErrsVar errs_var $ - thing_inside ; - - msgs <- readTcRef errs_var ; - - return (msgs, case res of - Left _ -> Nothing - Right val -> Just val) - -- The exception is always the IOEnv built-in - -- in exception; see IOEnv.failM - } - ------------------------ -discardErrs :: TcRn a -> TcRn a --- (discardErrs m) runs m, --- discarding all error messages and warnings generated by m --- If m fails, discardErrs fails, and vice versa -discardErrs m - = do { errs_var <- newTcRef emptyMessages - ; setErrsVar errs_var m } - ------------------------ -tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r --- (tryTcDiscardingErrs recover main) tries 'main'; --- if 'main' succeeds with no error messages, it's the answer --- otherwise discard everything from 'main', including errors, --- and try 'recover' instead. -tryTcDiscardingErrs recover main - = do { (msgs, mb_res) <- tryTc main - ; dflags <- getDynFlags - ; case mb_res of - Just res | not (errorsFound dflags msgs) - -> -- 'main' succeeed with no error messages - do { addMessages msgs -- msgs might still have warnings - ; return res } - - _ -> -- 'main' failed, or produced an error message - recover -- Discard all errors and warnings entirely - } - ------------------------ --- (askNoErrs m) runs m --- If m fails, --- then (askNoErrs m) fails --- If m succeeds with result r, --- then (askNoErrs m) succeeds with result (r, b), --- where b is True iff m generated no errors --- Regardless of success or failure, --- propagate any errors/warnings generated by m -askNoErrs :: TcRn a -> TcRn (a, Bool) -askNoErrs m - = do { (msgs, mb_res) <- tryTc m - ; addMessages msgs -- Always propagate errors - ; case mb_res of - Nothing -> failM - Just res -> do { dflags <- getDynFlags - ; let errs_found = errorsFound dflags msgs - ; return (res, not errs_found) } } ------------------------ -checkNoErrs :: TcM r -> TcM r --- (checkNoErrs m) succeeds iff m succeeds and generates no errors --- If m fails then (checkNoErrsTc m) fails. --- If m succeeds, it checks whether m generated any errors messages --- (it might have recovered internally) --- If so, it fails too. --- Regardless, any errors generated by m are propagated to the enclosing context. -checkNoErrs main - = do { (res, no_errs) <- askNoErrs main - ; unless no_errs failM - ; return res } - ------------------------ -whenNoErrs :: TcM () -> TcM () -whenNoErrs thing = ifErrsM (return ()) thing - -ifErrsM :: TcRn r -> TcRn r -> TcRn r --- ifErrsM bale_out normal --- does 'bale_out' if there are errors in errors collection --- otherwise does 'normal' -ifErrsM bale_out normal - = do { errs_var <- getErrsVar ; - msgs <- readTcRef errs_var ; - dflags <- getDynFlags ; - if errorsFound dflags msgs then - bale_out - else - normal } - -failIfErrsM :: TcRn () --- Useful to avoid error cascades -failIfErrsM = ifErrsM failM (return ()) - -checkTH :: a -> String -> TcRn () -checkTH _ _ = return () -- OK - -failTH :: Outputable a => a -> String -> TcRn x -failTH e what -- Raise an error in a stage-1 compiler - = failWithTc (vcat [ hang (char 'A' <+> text what - <+> text "requires GHC with interpreter support:") - 2 (ppr e) - , text "Perhaps you are using a stage-1 compiler?" ]) - - -{- ********************************************************************* -* * - Context management for the type checker -* * -************************************************************************ --} - -getErrCtxt :: TcM [ErrCtxt] -getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } - -setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a -setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) - --- | Add a fixed message to the error context. This message should not --- do any tidying. -addErrCtxt :: MsgDoc -> TcM a -> TcM a -addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) - --- | Add a message to the error context. This message may do tidying. -addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a -addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) - --- | Add a fixed landmark message to the error context. A landmark --- message is always sure to be reported, even if there is a lot of --- context. It also doesn't count toward the maximum number of contexts --- reported. -addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a -addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) - --- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations --- and tidying. -addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a -addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts) - --- Helper function for the above -updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a -updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> - env { tcl_ctxt = upd ctxt }) - -popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) - -getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc -getCtLocM origin t_or_k - = do { env <- getLclEnv - ; return (CtLoc { ctl_origin = origin - , ctl_env = env - , ctl_t_or_k = t_or_k - , ctl_depth = initialSubGoalDepth }) } - -setCtLocM :: CtLoc -> TcM a -> TcM a --- Set the SrcSpan and error context from the CtLoc -setCtLocM (CtLoc { ctl_env = lcl }) thing_inside - = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl - , tcl_bndrs = tcl_bndrs lcl - , tcl_ctxt = tcl_ctxt lcl }) - thing_inside - -{- -************************************************************************ -* * - Error message generation (type checker) -* * -************************************************************************ - - The addErrTc functions add an error message, but do not cause failure. - The 'M' variants pass a TidyEnv that has already been used to - tidy up the message; we then use it to tidy the context messages --} - -addErrTc :: MsgDoc -> TcM () -addErrTc err_msg = do { env0 <- tcInitTidyEnv - ; addErrTcM (env0, err_msg) } - -addErrsTc :: [MsgDoc] -> TcM () -addErrsTc err_msgs = mapM_ addErrTc err_msgs - -addErrTcM :: (TidyEnv, MsgDoc) -> TcM () -addErrTcM (tidy_env, err_msg) - = do { ctxt <- getErrCtxt ; - loc <- getSrcSpanM ; - add_err_tcm tidy_env err_msg loc ctxt } - --- Return the error message, instead of reporting it straight away -mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg -mkErrTcM (tidy_env, err_msg) - = do { ctxt <- getErrCtxt ; - loc <- getSrcSpanM ; - err_info <- mkErrInfo tidy_env ctxt ; - mkLongErrAt loc err_msg err_info } - --- The failWith functions add an error message and cause failure - -failWithTc :: MsgDoc -> TcM a -- Add an error message and fail -failWithTc err_msg - = addErrTc err_msg >> failM - -failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail -failWithTcM local_and_msg - = addErrTcM local_and_msg >> failM - -checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true -checkTc True _ = return () -checkTc False err = failWithTc err - -checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () -checkTcM True _ = return () -checkTcM False err = failWithTcM err - -failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false -failIfTc False _ = return () -failIfTc True err = failWithTc err - -failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () - -- Check that the boolean is false -failIfTcM False _ = return () -failIfTcM True err = failWithTcM err - - --- Warnings have no 'M' variant, nor failure - --- | Display a warning if a condition is met. --- and the warning is enabled -warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn () -warnIf reason is_bad msg - = do { warn_on <- case reason of - NoReason -> return True - Reason warn_flag -> woptM warn_flag - ; when (warn_on && is_bad) $ - addWarn reason msg } - --- | Display a warning if a condition is met. -warnTc :: WarnReason -> Bool -> MsgDoc -> TcM () -warnTc reason warn_if_true warn_msg - | warn_if_true = addWarnTc reason warn_msg - | otherwise = return () - --- | Display a warning if a condition is met. -warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM () -warnTcM reason warn_if_true warn_msg - | warn_if_true = addWarnTcM reason warn_msg - | otherwise = return () - --- | Display a warning in the current context. -addWarnTc :: WarnReason -> MsgDoc -> TcM () -addWarnTc reason msg - = do { env0 <- tcInitTidyEnv ; - addWarnTcM reason (env0, msg) } - --- | Display a warning in a given context. -addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM () -addWarnTcM reason (env0, msg) - = do { ctxt <- getErrCtxt ; - err_info <- mkErrInfo env0 ctxt ; - add_warn reason msg err_info } - --- | Display a warning for the current source location. -addWarn :: WarnReason -> MsgDoc -> TcRn () -addWarn reason msg = add_warn reason msg Outputable.empty - --- | Display a warning for a given source location. -addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn () -addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty - --- | Display a warning, with an optional flag, for the current source --- location. -add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn () -add_warn reason msg extra_info - = do { loc <- getSrcSpanM - ; add_warn_at reason loc msg extra_info } - --- | Display a warning, with an optional flag, for a given location. -add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () -add_warn_at reason loc msg extra_info - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - let { warn = mkLongWarnMsg dflags loc printer - msg extra_info } ; - reportWarning reason warn } - -tcInitTidyEnv :: TcM TidyEnv -tcInitTidyEnv - = do { lcl_env <- getLclEnv - ; return (tcl_tidy lcl_env) } - --- | Get a 'TidyEnv' that includes mappings for all vars free in the given --- type. Useful when tidying open types. -tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv -tcInitOpenTidyEnv tvs - = do { env1 <- tcInitTidyEnv - ; let env2 = tidyFreeTyCoVars env1 tvs - ; return env2 } - - -{- ------------------------------------ - Other helper functions --} - -add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan - -> [ErrCtxt] - -> TcM () -add_err_tcm tidy_env err_msg loc ctxt - = do { err_info <- mkErrInfo tidy_env ctxt ; - addLongErrAt loc err_msg err_info } - -mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc --- Tidy the error info, trimming excessive contexts -mkErrInfo env ctxts --- = do --- dbg <- hasPprDebug <$> getDynFlags --- if dbg -- In -dppr-debug style the output --- then return empty -- just becomes too voluminous --- else go dbg 0 env ctxts - = go False 0 env ctxts - where - go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc - go _ _ _ [] = return empty - go dbg n env ((is_landmark, ctxt) : ctxts) - | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg - = do { (env', msg) <- ctxt env - ; let n' = if is_landmark then n else n+1 - ; rest <- go dbg n' env' ctxts - ; return (msg $$ rest) } - | otherwise - = go dbg n env ctxts - -mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts -mAX_CONTEXTS = 3 - --- debugTc is useful for monadic debugging code - -debugTc :: TcM () -> TcM () -debugTc thing - | debugIsOn = thing - | otherwise = return () - -{- -************************************************************************ -* * - Type constraints -* * -************************************************************************ --} - -newTcEvBinds :: TcM EvBindsVar -newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap - ; tcvs_ref <- newTcRef emptyVarSet - ; uniq <- newUnique - ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq) - ; return (EvBindsVar { ebv_binds = binds_ref - , ebv_tcvs = tcvs_ref - , ebv_uniq = uniq }) } - -getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet -getTcEvTyCoVars (EvBindsVar { ebv_tcvs = ev_ref }) - = readTcRef ev_ref - -getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap -getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) - = readTcRef ev_ref - -addTcEvBind :: EvBindsVar -> EvBind -> TcM () --- Add a binding to the TcEvBinds by side effect -addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind - = do { traceTc "addTcEvBind" $ ppr u $$ - ppr ev_bind - ; bnds <- readTcRef ev_ref - ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) } - -chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName -chooseUniqueOccTc fn = - do { env <- getGblEnv - ; let dfun_n_var = tcg_dfun_n env - ; set <- readTcRef dfun_n_var - ; let occ = fn set - ; writeTcRef dfun_n_var (extendOccSet set occ) - ; return occ } - -getConstraintVar :: TcM (TcRef WantedConstraints) -getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } - -setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a -setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) - -emitStaticConstraints :: WantedConstraints -> TcM () -emitStaticConstraints static_lie - = do { gbl_env <- getGblEnv - ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) } - -emitConstraints :: WantedConstraints -> TcM () -emitConstraints ct - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`andWC` ct) } - -emitSimple :: Ct -> TcM () -emitSimple ct - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addSimples` unitBag ct) } - -emitSimples :: Cts -> TcM () -emitSimples cts - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addSimples` cts) } - -emitImplication :: Implication -> TcM () -emitImplication ct - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addImplics` unitBag ct) } - -emitImplications :: Bag Implication -> TcM () -emitImplications ct - = unless (isEmptyBag ct) $ - do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addImplics` ct) } - -emitInsoluble :: Ct -> TcM () -emitInsoluble ct - = do { traceTc "emitInsoluble" (ppr ct) - ; lie_var <- getConstraintVar - ; updTcRef lie_var (`addInsols` unitBag ct) } - -emitInsolubles :: Cts -> TcM () -emitInsolubles cts - | isEmptyBag cts = return () - | otherwise = do { traceTc "emitInsolubles" (ppr cts) - ; lie_var <- getConstraintVar - ; updTcRef lie_var (`addInsols` cts) } - --- | Throw out any constraints emitted by the thing_inside -discardConstraints :: TcM a -> TcM a -discardConstraints thing_inside = fst <$> captureConstraints thing_inside - -tryCaptureConstraints :: TcM a -> TcM (Either IOEnvFailure a, WantedConstraints) --- (captureConstraints_maybe m) runs m, --- and returns the type constraints it generates --- It never throws an exception; instead if thing_inside fails, --- it returns Left exn and the insoluble constraints -tryCaptureConstraints thing_inside - = do { lie_var <- newTcRef emptyWC - ; mb_res <- tryM $ - updLclEnv (\ env -> env { tcl_lie = lie_var }) $ - thing_inside - ; lie <- readTcRef lie_var - - -- See Note [Constraints and errors] - ; let lie_to_keep = case mb_res of - Left {} -> insolublesOnly lie - Right {} -> lie - - ; return (mb_res, lie_to_keep) } - -captureConstraints :: TcM a -> TcM (a, WantedConstraints) --- (captureConstraints m) runs m, and returns the type constraints it generates -captureConstraints thing_inside - = do { (mb_res, lie) <- tryCaptureConstraints thing_inside - - -- See Note [Constraints and errors] - -- If the thing_inside threw an exception, emit the insoluble - -- constraints only (returned by tryCaptureConstraints) - -- so that they are not lost - ; case mb_res of - Left _ -> do { emitConstraints lie; failM } - Right res -> return (res, lie) } - -pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) -pushLevelAndCaptureConstraints thing_inside - = do { env <- getLclEnv - ; let tclvl' = pushTcLevel (tcl_tclvl env) - ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $ - captureConstraints thing_inside - ; return (tclvl', lie, res) } - -pushTcLevelM_ :: TcM a -> TcM a -pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x - -pushTcLevelM :: TcM a -> TcM (a, TcLevel) --- See Note [TcLevel assignment] in TcType -pushTcLevelM thing_inside - = do { env <- getLclEnv - ; let tclvl' = pushTcLevel (tcl_tclvl env) - ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) - thing_inside - ; return (res, tclvl') } - -getTcLevel :: TcM TcLevel -getTcLevel = do { env <- getLclEnv - ; return (tcl_tclvl env) } - -setTcLevel :: TcLevel -> TcM a -> TcM a -setTcLevel tclvl thing_inside - = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside - -isTouchableTcM :: TcTyVar -> TcM Bool -isTouchableTcM tv - = do { env <- getLclEnv - ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) } - -getLclTypeEnv :: TcM TcTypeEnv -getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } - -setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a --- Set the local type envt, but do *not* disturb other fields, --- notably the lie_var -setLclTypeEnv lcl_env thing_inside - = updLclEnv upd thing_inside - where - upd env = env { tcl_env = tcl_env lcl_env, - tcl_tyvars = tcl_tyvars lcl_env } - -traceTcConstraints :: String -> TcM () -traceTcConstraints msg - = do { lie_var <- getConstraintVar - ; lie <- readTcRef lie_var - ; traceOptTcRn Opt_D_dump_tc_trace $ - hang (text (msg ++ ": LIE:")) 2 (ppr lie) - } - -emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () -emitWildCardHoleConstraints wcs - = do { ct_loc <- getCtLocM HoleOrigin Nothing - ; emitInsolubles $ listToBag $ - map (do_one ct_loc) wcs } - where - do_one :: CtLoc -> (Name, TcTyVar) -> Ct - do_one ct_loc (name, tv) - = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv - , ctev_loc = ct_loc' } - , cc_hole = TypeHole (occName name) } - where - real_span = case nameSrcSpan name of - RealSrcSpan span -> span - UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints" - (ppr name <+> quotes (ftext str)) - -- Wildcards are defined locally, and so have RealSrcSpans - ct_loc' = setCtLocSpan ct_loc real_span - -{- Note [Constraints and errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (Trac #12124): - - foo :: Maybe Int - foo = return (case Left 3 of - Left -> 1 -- Hard error here! - _ -> 0) - -The call to 'return' will generate a (Monad m) wanted constraint; but -then there'll be "hard error" (i.e. an exception in the TcM monad), from -the unsaturated Left constructor pattern. - -We'll recover in tcPolyBinds, using recoverM. But then the final -tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly -un-filled-in, and will emit a misleading error message. - -The underlying problem is that an exception interrupts the constraint -gathering process. Bottom line: if we have an exception, it's best -simply to discard any gathered constraints. Hence in 'try_m' we -capture the constraints in a fresh variable, and only emit them into -the surrounding context if we exit normally. If an exception is -raised, simply discard the collected constraints... we have a hard -error to report. So this capture-the-emit dance isn't as stupid as it -looks :-). - -However suppose we throw an exception inside an invocation of -captureConstraints, and discard all the constraints. Some of those -contraints might be "variable out of scope" Hole constraints, and that -might have been the actual original cause of the exception! For -example (Trac #12529): - f = p @ Int -Here 'p' is out of scope, so we get an insolube Hole constraint. But -the visible type application fails in the monad (thows an exception). -We must not discard the out-of-scope error. - -So we /retain the insoluble constraints/ if there is an exception. -Hence: - - insolublesOnly in tryCaptureConstraints - - emitConstraints in the Left case of captureConstraints - - -************************************************************************ -* * - Template Haskell context -* * -************************************************************************ --} - -recordThUse :: TcM () -recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } - -recordThSpliceUse :: TcM () -recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } - --- | When generating an out-of-scope error message for a variable matching a --- binding in a later inter-splice group, the typechecker uses the splice --- locations to provide details in the message about the scope of that binding. -recordTopLevelSpliceLoc :: SrcSpan -> TcM () -recordTopLevelSpliceLoc (RealSrcSpan real_loc) - = do { env <- getGblEnv - ; let locs_var = tcg_th_top_level_locs env - ; locs0 <- readTcRef locs_var - ; writeTcRef locs_var (Set.insert real_loc locs0) } -recordTopLevelSpliceLoc (UnhelpfulSpan _) = return () - -getTopLevelSpliceLocs :: TcM (Set RealSrcSpan) -getTopLevelSpliceLocs - = do { env <- getGblEnv - ; readTcRef (tcg_th_top_level_locs env) } - -keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set -keepAlive name - = do { env <- getGblEnv - ; traceRn "keep alive" (ppr name) - ; updTcRef (tcg_keep env) (`extendNameSet` name) } - -getStage :: TcM ThStage -getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } - -getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage)) -getStageAndBindLevel name - = do { env <- getLclEnv; - ; case lookupNameEnv (tcl_th_bndrs env) name of - Nothing -> return Nothing - Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) } - -setStage :: ThStage -> TcM a -> TcRn a -setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) - --- | Adds the given modFinalizers to the global environment and set them to use --- the current local environment. -addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () -addModFinalizersWithLclEnv mod_finalizers - = do lcl_env <- getLclEnv - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - updTcRef th_modfinalizers_var $ \fins -> - setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers) - : fins - -{- -************************************************************************ -* * - Safe Haskell context -* * -************************************************************************ --} - --- | Mark that safe inference has failed --- See Note [Safe Haskell Overlapping Instances Implementation] --- although this is used for more than just that failure case. -recordUnsafeInfer :: WarningMessages -> TcM () -recordUnsafeInfer warns = - getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns) - --- | Figure out the final correct safe haskell mode -finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode -finalSafeMode dflags tcg_env = do - safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env) - return $ case safeHaskell dflags of - Sf_None | safeInferOn dflags && safeInf -> Sf_Safe - | otherwise -> Sf_None - s -> s - --- | Switch instances to safe instances if we're in Safe mode. -fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst] -fixSafeInstances sfMode | sfMode /= Sf_Safe = id -fixSafeInstances _ = map fixSafe - where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True } - in inst { is_flag = new_flag } - -{- -************************************************************************ -* * - Stuff for the renamer's local env -* * -************************************************************************ --} - -getLocalRdrEnv :: RnM LocalRdrEnv -getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } - -setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a -setLocalRdrEnv rdr_env thing_inside - = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside - -{- -************************************************************************ -* * - Stuff for interface decls -* * -************************************************************************ --} - -mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv -mkIfLclEnv mod loc boot - = IfLclEnv { if_mod = mod, - if_loc = loc, - if_boot = boot, - if_nsubst = Nothing, - if_implicits_env = Nothing, - if_tv_env = emptyFsEnv, - if_id_env = emptyFsEnv } - --- | Run an 'IfG' (top-level interface monad) computation inside an existing --- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv' --- based on 'TcGblEnv'. -initIfaceTcRn :: IfG a -> TcRn a -initIfaceTcRn thing_inside - = do { tcg_env <- getGblEnv - ; dflags <- getDynFlags - ; let mod = tcg_semantic_mod tcg_env - -- When we are instantiating a signature, we DEFINITELY - -- do not want to knot tie. - is_instantiate = unitIdIsDefinite (thisPackage dflags) && - not (null (thisUnitIdInsts dflags)) - ; let { if_env = IfGblEnv { - if_doc = text "initIfaceTcRn", - if_rec_types = - if is_instantiate - then Nothing - else Just (mod, get_type_env) - } - ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } - ; setEnvs (if_env, ()) thing_inside } - --- Used when sucking in a ModIface into a ModDetails to put in --- the HPT. Notably, unlike initIfaceCheck, this does NOT use --- hsc_type_env_var (since we're not actually going to typecheck, --- so this variable will never get updated!) -initIfaceLoad :: HscEnv -> IfG a -> IO a -initIfaceLoad hsc_env do_this - = do let gbl_env = IfGblEnv { - if_doc = text "initIfaceLoad", - if_rec_types = Nothing - } - initTcRnIf 'i' hsc_env gbl_env () do_this - -initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a --- Used when checking the up-to-date-ness of the old Iface --- Initialise the environment with no useful info at all -initIfaceCheck doc hsc_env do_this - = do let rec_types = case hsc_type_env_var hsc_env of - Just (mod,var) -> Just (mod, readTcRef var) - Nothing -> Nothing - gbl_env = IfGblEnv { - if_doc = text "initIfaceCheck" <+> doc, - if_rec_types = rec_types - } - initTcRnIf 'i' hsc_env gbl_env () do_this - -initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a -initIfaceLcl mod loc_doc hi_boot_file thing_inside - = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside - --- | Initialize interface typechecking, but with a 'NameShape' --- to apply when typechecking top-level 'OccName's (see --- 'lookupIfaceTop') -initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a -initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside - = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside - -getIfModule :: IfL Module -getIfModule = do { env <- getLclEnv; return (if_mod env) } - --------------------- -failIfM :: MsgDoc -> IfL a --- The Iface monad doesn't have a place to accumulate errors, so we --- just fall over fast if one happens; it "shouldn't happen". --- We use IfL here so that we can get context info out of the local env -failIfM msg - = do { env <- getLclEnv - ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; dflags <- getDynFlags - ; liftIO (putLogMsg dflags NoReason SevFatal - noSrcSpan (defaultErrStyle dflags) full_msg) - ; failM } - --------------------- -forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) --- Run thing_inside in an interleaved thread. --- It shares everything with the parent thread, so this is DANGEROUS. --- --- It returns Nothing if the computation fails --- --- It's used for lazily type-checking interface --- signatures, which is pretty benign - -forkM_maybe doc thing_inside - -- NB: Don't share the mutable env_us with the interleaved thread since env_us - -- does not get updated atomically (e.g. in newUnique and newUniqueSupply). - = do { child_us <- newUniqueSupply - ; child_env_us <- newMutVar child_us - -- see Note [Masking exceptions in forkM_maybe] - ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $ - do { traceIf (text "Starting fork {" <+> doc) - ; mb_res <- tryM $ - updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ - thing_inside - ; case mb_res of - Right r -> do { traceIf (text "} ending fork" <+> doc) - ; return (Just r) } - Left exn -> do { - - -- Bleat about errors in the forked thread, if -ddump-if-trace is on - -- Otherwise we silently discard errors. Errors can legitimately - -- happen when compiling interface signatures (see tcInterfaceSigs) - whenDOptM Opt_D_dump_if_trace $ do - dflags <- getDynFlags - let msg = hang (text "forkM failed:" <+> doc) - 2 (text (show exn)) - liftIO $ putLogMsg dflags - NoReason - SevFatal - noSrcSpan - (defaultErrStyle dflags) - msg - - ; traceIf (text "} ending fork (badly)" <+> doc) - ; return Nothing } - }} - -forkM :: SDoc -> IfL a -> IfL a -forkM doc thing_inside - = do { mb_res <- forkM_maybe doc thing_inside - ; return (case mb_res of - Nothing -> pgmError "Cannot continue after interface file error" - -- pprPanic "forkM" doc - Just r -> r) } - -setImplicitEnvM :: TypeEnv -> IfL a -> IfL a -setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl { if_implicits_env = Just tenv }) m - -{- -Note [Masking exceptions in forkM_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When using GHC-as-API it must be possible to interrupt snippets of code -executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible -by throwing an asynchronous interrupt to the GHC thread. However, there is a -subtle problem: runStmt first typechecks the code before running it, and the -exception might interrupt the type checker rather than the code. Moreover, the -typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and -more importantly might be inside an exception handler inside that -unsafeInterleaveIO. If that is the case, the exception handler will rethrow the -asynchronous exception as a synchronous exception, and the exception will end -up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed -discussion). We don't currently know a general solution to this problem, but -we can use uninterruptibleMask_ to avoid the situation. --} diff --git a/typecheck/TcRnTypes.hs b/typecheck/TcRnTypes.hs deleted file mode 100644 --- a/typecheck/TcRnTypes.hs +++ /dev/null @@ -1,3525 +0,0 @@ -{- -(c) The University of Glasgow 2006-2012 -(c) The GRASP Project, Glasgow University, 1992-2002 - - -Various types used during typechecking, please see TcRnMonad as well for -operations on these types. You probably want to import it, instead of this -module. - -All the monads exported here are built on top of the same IOEnv monad. The -monad functions like a Reader monad in the way it passes the environment -around. This is done to allow the environment to be manipulated in a stack -like fashion when entering expressions... ect. - -For state that is global and should be returned at the end (e.g not part -of the stack mechanism), you should use an TcRef (= IORef) to store them. --} - -{-# LANGUAGE CPP, ExistentialQuantification, GeneralizedNewtypeDeriving, - ViewPatterns #-} - -module TcRnTypes( - TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module - TcRef, - - -- The environment types - Env(..), - TcGblEnv(..), TcLclEnv(..), - IfGblEnv(..), IfLclEnv(..), - tcVisibleOrphanMods, - - -- Frontend types (shouldn't really be here) - FrontendResult(..), - - -- Renamer types - ErrCtxt, RecFieldEnv, - ImportAvails(..), emptyImportAvails, plusImportAvails, - WhereFrom(..), mkModDeps, modDepsElts, - - -- Typechecker types - TcTypeEnv, TcIdBinderStack, TcIdBinder(..), - TcTyThing(..), PromotionErr(..), - IdBindingInfo(..), ClosedTypeId, RhsNames, - IsGroupClosed(..), - SelfBootInfo(..), - pprTcTyThingCategory, pprPECategory, CompleteMatch(..), - - -- Desugaring types - DsM, DsLclEnv(..), DsGblEnv(..), PArrBuiltin(..), - DsMetaEnv, DsMetaVal(..), CompleteMatchMap, - mkCompleteMatchMap, extendCompleteMatchMap, - - -- Template Haskell - ThStage(..), SpliceType(..), PendingStuff(..), - topStage, topAnnStage, topSpliceStage, - ThLevel, impLevel, outerLevel, thLevel, - ForeignSrcLang(..), - - -- Arrows - ArrowCtxt(..), - - -- TcSigInfo - TcSigFun, TcSigInfo(..), TcIdSigInfo(..), - TcIdSigInst(..), TcPatSynInfo(..), - isPartialSig, hasCompleteSig, - - -- Canonical constraints - Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts, - singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, - isEmptyCts, isCTyEqCan, isCFunEqCan, - isPendingScDict, superClassesMightHelp, - isCDictCan_Maybe, isCFunEqCan_maybe, - isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, - isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt, - isUserTypeErrorCt, getUserTypeErrorMsg, - ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, - mkTcEqPredLikeEv, - mkNonCanonical, mkNonCanonicalCt, mkGivens, - ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, - ctEvTerm, ctEvCoercion, ctEvId, - tyCoVarsOfCt, tyCoVarsOfCts, - tyCoVarsOfCtList, tyCoVarsOfCtsList, - - WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, - andWC, unionsWC, mkSimpleWC, mkImplicWC, - addInsols, getInsolubles, insolublesOnly, addSimples, addImplics, - tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, dropDerivedInsols, - tyCoVarsOfWCList, trulyInsoluble, - isDroppableDerivedLoc, insolubleImplic, - arisesFromGivens, - - Implication(..), ImplicStatus(..), isInsolubleStatus, isSolvedStatus, - SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, - bumpSubGoalDepth, subGoalDepthExceeded, - CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, - ctLocTypeOrKind_maybe, - ctLocDepth, bumpCtLocDepth, - setCtLocOrigin, setCtLocEnv, setCtLocSpan, - CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, - ErrorThing(..), mkErrorThing, errorThingNumArgs_maybe, - TypeOrKind(..), isTypeLevel, isKindLevel, - pprCtOrigin, pprCtLoc, - pushErrCtxt, pushErrCtxtSameOrigin, - - SkolemInfo(..), pprSigSkolInfo, pprSkolInfo, - termEvidenceAllowed, - - CtEvidence(..), TcEvDest(..), - mkGivenLoc, mkKindLoc, toKindLoc, - isWanted, isGiven, isDerived, isGivenOrWDeriv, - ctEvRole, - - -- Constraint solver plugins - TcPlugin(..), TcPluginResult(..), TcPluginSolver, - TcPluginM, runTcPluginM, unsafeTcPluginTcM, - getEvBindsTcPluginM, - - CtFlavour(..), ShadowInfo(..), ctEvFlavour, - CtFlavourRole, ctEvFlavourRole, ctFlavourRole, - eqCanRewriteFR, eqMayRewriteFR, - eqCanDischarge, - funEqCanDischarge, funEqCanDischargeF, - - -- Pretty printing - pprEvVarTheta, - pprEvVars, pprEvVarWithType, - - -- Misc other types - TcId, TcIdSet, - Hole(..), holeOcc, - NameShape(..) - - ) where - -#include "HsVersions.h" - -import HsSyn -import CoreSyn -import HscTypes -import TcEvidence -import Type -import Class ( Class ) -import TyCon ( TyCon, tyConKind ) -import Coercion ( Coercion, mkHoleCo ) -import ConLike ( ConLike(..) ) -import DataCon ( DataCon, dataConUserType, dataConOrigArgTys ) -import PatSyn ( PatSyn, pprPatSynType ) -import Id ( idType, idName ) -import FieldLabel ( FieldLabel ) -import TcType -import Annotations -import InstEnv -import FamInstEnv -import PmExpr -import IOEnv -import RdrName -import Name -import NameEnv -import NameSet -import Avail -import Var -import FV -import VarEnv -import Module -import SrcLoc -import VarSet -import ErrUtils -import UniqFM -import UniqSupply -import BasicTypes -import Bag -import DynFlags -import Outputable -import ListSetOps -import FastString -import qualified GHC.LanguageExtensions as LangExt -import Fingerprint -import Util - -import Control.Monad (ap, liftM, msum) -#if __GLASGOW_HASKELL__ > 710 -import qualified Control.Monad.Fail as MonadFail -#endif -import Data.Set ( Set ) -import qualified Data.Set as S - -import Data.List ( sort ) -import Data.Map ( Map ) -import Data.Dynamic ( Dynamic ) -import Data.Typeable ( TypeRep ) -import GHCi.Message -import GHCi.RemoteTypes - -import qualified Language.Haskell.TH as TH - --- | A 'NameShape' is a substitution on 'Name's that can be used --- to refine the identities of a hole while we are renaming interfaces --- (see 'RnModIface'). Specifically, a 'NameShape' for --- 'ns_module_name' @A@, defines a mapping from @{A.T}@ --- (for some 'OccName' @T@) to some arbitrary other 'Name'. --- --- The most intruiging thing about a 'NameShape', however, is --- how it's constructed. A 'NameShape' is *implied* by the --- exported 'AvailInfo's of the implementor of an interface: --- if an implementor of signature @@ exports @M.T@, you implicitly --- define a substitution from @{H.T}@ to @M.T@. So a 'NameShape' --- is computed from the list of 'AvailInfo's that are exported --- by the implementation of a module, or successively merged --- together by the export lists of signatures which are joining --- together. --- --- It's not the most obvious way to go about doing this, but it --- does seem to work! --- --- NB: Can't boot this and put it in NameShape because then we --- start pulling in too many DynFlags things. -data NameShape = NameShape { - ns_mod_name :: ModuleName, - ns_exports :: [AvailInfo], - ns_map :: OccEnv Name - } - - -{- -************************************************************************ -* * - Standard monad definition for TcRn - All the combinators for the monad can be found in TcRnMonad -* * -************************************************************************ - -The monad itself has to be defined here, because it is mentioned by ErrCtxt --} - -type TcRnIf a b = IOEnv (Env a b) -type TcRn = TcRnIf TcGblEnv TcLclEnv -- Type inference -type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff -type IfG = IfM () -- Top level -type IfL = IfM IfLclEnv -- Nested -type DsM = TcRnIf DsGblEnv DsLclEnv -- Desugaring - --- TcRn is the type-checking and renaming monad: the main monad that --- most type-checking takes place in. The global environment is --- 'TcGblEnv', which tracks all of the top-level type-checking --- information we've accumulated while checking a module, while the --- local environment is 'TcLclEnv', which tracks local information as --- we move inside expressions. - --- | Historical "renaming monad" (now it's just 'TcRn'). -type RnM = TcRn - --- | Historical "type-checking monad" (now it's just 'TcRn'). -type TcM = TcRn - --- We 'stack' these envs through the Reader like monad infrastructure --- as we move into an expression (although the change is focused in --- the lcl type). -data Env gbl lcl - = Env { - env_top :: HscEnv, -- Top-level stuff that never changes - -- Includes all info about imported things - - env_us :: {-# UNPACK #-} !(IORef UniqSupply), - -- Unique supply for local variables - - env_gbl :: gbl, -- Info about things defined at the top level - -- of the module being compiled - - env_lcl :: lcl -- Nested stuff; changes as we go into - } - -instance ContainsDynFlags (Env gbl lcl) where - extractDynFlags env = hsc_dflags (env_top env) - -instance ContainsModule gbl => ContainsModule (Env gbl lcl) where - extractModule env = extractModule (env_gbl env) - - -{- -************************************************************************ -* * - The interface environments - Used when dealing with IfaceDecls -* * -************************************************************************ --} - -data IfGblEnv - = IfGblEnv { - -- Some information about where this environment came from; - -- useful for debugging. - if_doc :: SDoc, - -- The type environment for the module being compiled, - -- in case the interface refers back to it via a reference that - -- was originally a hi-boot file. - -- We need the module name so we can test when it's appropriate - -- to look in this env. - -- See Note [Tying the knot] in TcIface - if_rec_types :: Maybe (Module, IfG TypeEnv) - -- Allows a read effect, so it can be in a mutable - -- variable; c.f. handling the external package type env - -- Nothing => interactive stuff, no loops possible - } - -data IfLclEnv - = IfLclEnv { - -- The module for the current IfaceDecl - -- So if we see f = \x -> x - -- it means M.f = \x -> x, where M is the if_mod - -- NB: This is a semantic module, see - -- Note [Identity versus semantic module] - if_mod :: Module, - - -- Whether or not the IfaceDecl came from a boot - -- file or not; we'll use this to choose between - -- NoUnfolding and BootUnfolding - if_boot :: Bool, - - -- The field is used only for error reporting - -- if (say) there's a Lint error in it - if_loc :: SDoc, - -- Where the interface came from: - -- .hi file, or GHCi state, or ext core - -- plus which bit is currently being examined - - if_nsubst :: Maybe NameShape, - - -- This field is used to make sure "implicit" declarations - -- (anything that cannot be exported in mi_exports) get - -- wired up correctly in typecheckIfacesForMerging. Most - -- of the time it's @Nothing@. See Note [Resolving never-exported Names in TcIface] - -- in TcIface. - if_implicits_env :: Maybe TypeEnv, - - if_tv_env :: FastStringEnv TyVar, -- Nested tyvar bindings - if_id_env :: FastStringEnv Id -- Nested id binding - } - -{- -************************************************************************ -* * - Desugarer monad -* * -************************************************************************ - -Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around -a @UniqueSupply@ and some annotations, which -presumably include source-file location information: --} - --- If '-XParallelArrays' is given, the desugarer populates this table with the corresponding --- variables found in 'Data.Array.Parallel'. --- -data PArrBuiltin - = PArrBuiltin - { lengthPVar :: Var -- ^ lengthP - , replicatePVar :: Var -- ^ replicateP - , singletonPVar :: Var -- ^ singletonP - , mapPVar :: Var -- ^ mapP - , filterPVar :: Var -- ^ filterP - , zipPVar :: Var -- ^ zipP - , crossMapPVar :: Var -- ^ crossMapP - , indexPVar :: Var -- ^ (!:) - , emptyPVar :: Var -- ^ emptyP - , appPVar :: Var -- ^ (+:+) - , enumFromToPVar :: Var -- ^ enumFromToP - , enumFromThenToPVar :: Var -- ^ enumFromThenToP - } - -data DsGblEnv - = DsGblEnv - { ds_mod :: Module -- For SCC profiling - , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env - , ds_unqual :: PrintUnqualified - , ds_msgs :: IORef Messages -- Warning messages - , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, - -- possibly-imported things - , ds_dph_env :: GlobalRdrEnv -- exported entities of 'Data.Array.Parallel.Prim' - -- iff '-fvectorise' flag was given as well as - -- exported entities of 'Data.Array.Parallel' iff - -- '-XParallelArrays' was given; otherwise, empty - , ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays' - , ds_complete_matches :: CompleteMatchMap - -- Additional complete pattern matches - } - -instance ContainsModule DsGblEnv where - extractModule = ds_mod - -data DsLclEnv = DsLclEnv { - dsl_meta :: DsMetaEnv, -- Template Haskell bindings - dsl_loc :: RealSrcSpan, -- To put in pattern-matching error msgs - dsl_dicts :: Bag EvVar, -- Constraints from GADT pattern-matching - dsl_tm_cs :: Bag SimpleEq, - dsl_pm_iter :: IORef Int -- no iterations for pmcheck - } - --- Inside [| |] brackets, the desugarer looks --- up variables in the DsMetaEnv -type DsMetaEnv = NameEnv DsMetaVal - -data DsMetaVal - = DsBound Id -- Bound by a pattern inside the [| |]. - -- Will be dynamically alpha renamed. - -- The Id has type THSyntax.Var - - | DsSplice (HsExpr Id) -- These bindings are introduced by - -- the PendingSplices on a HsBracketOut - - -{- -************************************************************************ -* * - Global typechecker environment -* * -************************************************************************ --} - --- | 'FrontendResult' describes the result of running the --- frontend of a Haskell module. Usually, you'll get --- a 'FrontendTypecheck', since running the frontend involves --- typechecking a program, but for an hs-boot merge you'll --- just get a ModIface, since no actual typechecking occurred. --- --- This data type really should be in HscTypes, but it needs --- to have a TcGblEnv which is only defined here. -data FrontendResult - = FrontendTypecheck TcGblEnv - --- Note [Identity versus semantic module] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- When typechecking an hsig file, it is convenient to keep track --- of two different "this module" identifiers: --- --- - The IDENTITY module is simply thisPackage + the module --- name; i.e. it uniquely *identifies* the interface file --- we're compiling. For example, p[A=]:A is an --- identity module identifying the requirement named A --- from library p. --- --- - The SEMANTIC module, which is the actual module that --- this signature is intended to represent (e.g. if --- we have a identity module p[A=base:Data.IORef]:A, --- then the semantic module is base:Data.IORef) --- --- Which one should you use? --- --- - In the desugarer and later phases of compilation, --- identity and semantic modules coincide, since we never compile --- signatures (we just generate blank object files for --- hsig files.) --- --- A corrolary of this is that the following invariant holds at any point --- past desugaring, --- --- if I have a Module, this_mod, in hand representing the module --- currently being compiled, --- then moduleUnitId this_mod == thisPackage dflags --- --- - For any code involving Names, we want semantic modules. --- See lookupIfaceTop in IfaceEnv, mkIface and addFingerprints --- in MkIface, and tcLookupGlobal in TcEnv --- --- - When reading interfaces, we want the identity module to --- identify the specific interface we want (such interfaces --- should never be loaded into the EPS). However, if a --- hole module is requested, we look for A.hi --- in the home library we are compiling. (See LoadIface.) --- Similarly, in RnNames we check for self-imports using --- identity modules, to allow signatures to import their implementor. --- --- - For recompilation avoidance, you want the identity module, --- since that will actually say the specific interface you --- want to track (and recompile if it changes) - --- | 'TcGblEnv' describes the top-level of the module at the --- point at which the typechecker is finished work. --- It is this structure that is handed on to the desugarer --- For state that needs to be updated during the typechecking --- phase and returned at end, use a 'TcRef' (= 'IORef'). -data TcGblEnv - = TcGblEnv { - tcg_mod :: Module, -- ^ Module being compiled - tcg_semantic_mod :: Module, -- ^ If a signature, the backing module - -- See also Note [Identity versus semantic module] - tcg_src :: HscSource, - -- ^ What kind of module (regular Haskell, hs-boot, hsig) - - tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming - tcg_default :: Maybe [Type], - -- ^ Types used for defaulting. @Nothing@ => no @default@ decl - - tcg_fix_env :: FixityEnv, -- ^ Just for things in this module - tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module - -- See Note [The interactive package] in HscTypes - - tcg_type_env :: TypeEnv, - -- ^ Global type env for the module we are compiling now. All - -- TyCons and Classes (for this module) end up in here right away, - -- along with their derived constructors, selectors. - -- - -- (Ids defined in this module start in the local envt, though they - -- move to the global envt during zonking) - -- - -- NB: for what "things in this module" means, see - -- Note [The interactive package] in HscTypes - - tcg_type_env_var :: TcRef TypeEnv, - -- Used only to initialise the interface-file - -- typechecker in initIfaceTcRn, so that it can see stuff - -- bound in this module when dealing with hi-boot recursions - -- Updated at intervals (e.g. after dealing with types and classes) - - tcg_inst_env :: InstEnv, - -- ^ Instance envt for all /home-package/ modules; - -- Includes the dfuns in tcg_insts - tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances - tcg_ann_env :: AnnEnv, -- ^ And for annotations - - -- | Family instances we have to check for consistency. - -- Invariant: each FamInst in the list's fi_fam matches the - -- key of the entry in the 'NameEnv'. This gets consumed - -- by 'checkRecFamInstConsistency'. - -- See Note [Don't check hs-boot type family instances too early] - tcg_pending_fam_checks :: NameEnv [([FamInst], FamInstEnv)], - - -- Now a bunch of things about this module that are simply - -- accumulated, but never consulted until the end. - -- Nevertheless, it's convenient to accumulate them along - -- with the rest of the info from this module. - tcg_exports :: [AvailInfo], -- ^ What is exported - tcg_imports :: ImportAvails, - -- ^ Information about what was imported from where, including - -- things bound in this module. Also store Safe Haskell info - -- here about transative trusted packaage requirements. - - tcg_dus :: DefUses, -- ^ What is defined in this module and what is used. - tcg_used_gres :: TcRef [GlobalRdrElt], -- ^ Records occurrences of imported entities - -- See Note [Tracking unused binding and imports] - - tcg_keep :: TcRef NameSet, - -- ^ Locally-defined top-level names to keep alive. - -- - -- "Keep alive" means give them an Exported flag, so that the - -- simplifier does not discard them as dead code, and so that they - -- are exposed in the interface file (but not to export to the - -- user). - -- - -- Some things, like dict-fun Ids and default-method Ids are "born" - -- with the Exported flag on, for exactly the above reason, but some - -- we only discover as we go. Specifically: - -- - -- * The to/from functions for generic data types - -- - -- * Top-level variables appearing free in the RHS of an orphan - -- rule - -- - -- * Top-level variables appearing free in a TH bracket - - tcg_th_used :: TcRef Bool, - -- ^ @True@ <=> Template Haskell syntax used. - -- - -- We need this so that we can generate a dependency on the - -- Template Haskell package, because the desugarer is going - -- to emit loads of references to TH symbols. The reference - -- is implicit rather than explicit, so we have to zap a - -- mutable variable. - - tcg_th_splice_used :: TcRef Bool, - -- ^ @True@ <=> A Template Haskell splice was used. - -- - -- Splices disable recompilation avoidance (see #481) - - tcg_th_top_level_locs :: TcRef (Set RealSrcSpan), - -- ^ Locations of the top-level splices; used for providing details on - -- scope in error messages for out-of-scope variables - - tcg_dfun_n :: TcRef OccSet, - -- ^ Allows us to choose unique DFun names. - - tcg_merged :: [(Module, Fingerprint)], - -- ^ The requirements we merged with; we always have to recompile - -- if any of these changed. - - -- The next fields accumulate the payload of the module - -- The binds, rules and foreign-decl fields are collected - -- initially in un-zonked form and are finally zonked in tcRnSrcDecls - - tcg_rn_exports :: Maybe [Located (IE Name)], - -- Nothing <=> no explicit export list - -- Is always Nothing if we don't want to retain renamed - -- exports - - tcg_rn_imports :: [LImportDecl Name], - -- Keep the renamed imports regardless. They are not - -- voluminous and are needed if you want to report unused imports - - tcg_rn_decls :: Maybe (HsGroup Name), - -- ^ Renamed decls, maybe. @Nothing@ <=> Don't retain renamed - -- decls. - - tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile - - tcg_th_topdecls :: TcRef [LHsDecl RdrName], - -- ^ Top-level declarations from addTopDecls - - tcg_th_foreign_files :: TcRef [(ForeignSrcLang, String)], - -- ^ Foreign files emitted from TH. - - tcg_th_topnames :: TcRef NameSet, - -- ^ Exact names bound in top-level declarations in tcg_th_topdecls - - tcg_th_modfinalizers :: TcRef [TcM ()], - -- ^ Template Haskell module finalizers. - -- - -- They are computations in the @TcM@ monad rather than @Q@ because we - -- set them to use particular local environments. - - tcg_th_state :: TcRef (Map TypeRep Dynamic), - tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))), - -- ^ Template Haskell state - - tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings - - -- Things defined in this module, or (in GHCi) - -- in the declarations for a single GHCi command. - -- For the latter, see Note [The interactive package] in HscTypes - tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Types.Module - -- for which every module has a top-level defn - -- except in GHCi in which case we have Nothing - tcg_binds :: LHsBinds Id, -- Value bindings in this module - tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature - tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids - tcg_warns :: Warnings, -- ...Warnings and deprecations - tcg_anns :: [Annotation], -- ...Annotations - tcg_tcs :: [TyCon], -- ...TyCons and Classes - tcg_insts :: [ClsInst], -- ...Instances - tcg_fam_insts :: [FamInst], -- ...Family instances - tcg_rules :: [LRuleDecl Id], -- ...Rules - tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports - tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations - tcg_patsyns :: [PatSyn], -- ...Pattern synonyms - - tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs - tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the - -- prog uses hpc instrumentation. - - tcg_self_boot :: SelfBootInfo, -- ^ Whether this module has a - -- corresponding hi-boot file - - tcg_main :: Maybe Name, -- ^ The Name of the main - -- function, if this module is - -- the main module. - - tcg_safeInfer :: TcRef (Bool, WarningMessages), - -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell) - -- See Note [Safe Haskell Overlapping Instances Implementation], - -- although this is used for more than just that failure case. - - tcg_tc_plugins :: [TcPluginSolver], - -- ^ A list of user-defined plugins for the constraint solver. - - tcg_top_loc :: RealSrcSpan, - -- ^ The RealSrcSpan this module came from - - tcg_static_wc :: TcRef WantedConstraints, - -- ^ Wanted constraints of static forms. - -- See Note [Constraints in static forms]. - tcg_complete_matches :: [CompleteMatch] - } - --- NB: topModIdentity, not topModSemantic! --- Definition sites of orphan identities will be identity modules, not semantic --- modules. - --- Note [Constraints in static forms] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- When a static form produces constraints like --- --- f :: StaticPtr (Bool -> String) --- f = static show --- --- we collect them in tcg_static_wc and resolve them at the end --- of type checking. They need to be resolved separately because --- we don't want to resolve them in the context of the enclosing --- expression. Consider --- --- g :: Show a => StaticPtr (a -> String) --- g = static show --- --- If the @Show a0@ constraint that the body of the static form produces was --- resolved in the context of the enclosing expression, then the body of the --- static form wouldn't be closed because the Show dictionary would come from --- g's context instead of coming from the top level. - -tcVisibleOrphanMods :: TcGblEnv -> ModuleSet -tcVisibleOrphanMods tcg_env - = mkModuleSet (tcg_mod tcg_env : imp_orphs (tcg_imports tcg_env)) - -instance ContainsModule TcGblEnv where - extractModule env = tcg_semantic_mod env - -type RecFieldEnv = NameEnv [FieldLabel] - -- Maps a constructor name *in this module* - -- to the fields for that constructor. - -- This is used when dealing with ".." notation in record - -- construction and pattern matching. - -- The FieldEnv deals *only* with constructors defined in *this* - -- module. For imported modules, we get the same info from the - -- TypeEnv - -data SelfBootInfo - = NoSelfBoot -- No corresponding hi-boot file - | SelfBoot - { sb_mds :: ModDetails -- There was a hi-boot file, - , sb_tcs :: NameSet } -- defining these TyCons, --- What is sb_tcs used for? See Note [Extra dependencies from .hs-boot files] --- in RnSource - - -{- Note [Tracking unused binding and imports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We gather two sorts of usage information - - * tcg_dus (defs/uses) - Records *defined* Names (local, top-level) - and *used* Names (local or imported) - - Used (a) to report "defined but not used" - (see RnNames.reportUnusedNames) - (b) to generate version-tracking usage info in interface - files (see MkIface.mkUsedNames) - This usage info is mainly gathered by the renamer's - gathering of free-variables - - * tcg_used_gres - Used only to report unused import declarations - - Records each *occurrence* an *imported* (not locally-defined) entity. - The occurrence is recorded by keeping a GlobalRdrElt for it. - These is not the GRE that is in the GlobalRdrEnv; rather it - is recorded *after* the filtering done by pickGREs. So it reflect - /how that occurrence is in scope/. See Note [GRE filtering] in - RdrName. - - -************************************************************************ -* * - The local typechecker environment -* * -************************************************************************ - -Note [The Global-Env/Local-Env story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During type checking, we keep in the tcg_type_env - * All types and classes - * All Ids derived from types and classes (constructors, selectors) - -At the end of type checking, we zonk the local bindings, -and as we do so we add to the tcg_type_env - * Locally defined top-level Ids - -Why? Because they are now Ids not TcIds. This final GlobalEnv is - a) fed back (via the knot) to typechecking the - unfoldings of interface signatures - b) used in the ModDetails of this module --} - -data TcLclEnv -- Changes as we move inside an expression - -- Discarded after typecheck/rename; not passed on to desugarer - = TcLclEnv { - tcl_loc :: RealSrcSpan, -- Source span - tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_tclvl :: TcLevel, -- Birthplace for new unification variables - - tcl_th_ctxt :: ThStage, -- Template Haskell context - tcl_th_bndrs :: ThBindEnv, -- and binder info - -- The ThBindEnv records the TH binding level of in-scope Names - -- defined in this module (not imported) - -- We can't put this info in the TypeEnv because it's needed - -- (and extended) in the renamer, for untyed splices - - tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context - - tcl_rdr :: LocalRdrEnv, -- Local name envt - -- Maintained during renaming, of course, but also during - -- type checking, solely so that when renaming a Template-Haskell - -- splice we have the right environment for the renamer. - -- - -- Does *not* include global name envt; may shadow it - -- Includes both ordinary variables and type variables; - -- they are kept distinct because tyvar have a different - -- occurrence constructor (Name.TvOcc) - -- We still need the unsullied global name env so that - -- we can look up record field names - - tcl_env :: TcTypeEnv, -- The local type environment: - -- Ids and TyVars defined in this module - - tcl_bndrs :: TcIdBinderStack, -- Used for reporting relevant bindings - - tcl_tidy :: TidyEnv, -- Used for tidying types; contains all - -- in-scope type variables (but not term variables) - - tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars" - -- Namely, the in-scope TyVars bound in tcl_env, - -- plus the tyvars mentioned in the types of Ids bound - -- in tcl_lenv. - -- Why mutable? see notes with tcGetGlobalTyCoVars - - tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - tcl_errs :: TcRef Messages -- Place to accumulate errors - } - -type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) - -- Monadic so that we have a chance - -- to deal with bound type variables just before error - -- message construction - - -- Bool: True <=> this is a landmark context; do not - -- discard it when trimming for display - -type TcTypeEnv = NameEnv TcTyThing - -type ThBindEnv = NameEnv (TopLevelFlag, ThLevel) - -- Domain = all Ids bound in this module (ie not imported) - -- The TopLevelFlag tells if the binding is syntactically top level. - -- We need to know this, because the cross-stage persistence story allows - -- cross-stage at arbitrary types if the Id is bound at top level. - -- - -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being - -- bound at top level! See Note [Template Haskell levels] in TcSplice - -{- Note [Given Insts] - ~~~~~~~~~~~~~~~~~~ -Because of GADTs, we have to pass inwards the Insts provided by type signatures -and existential contexts. Consider - data T a where { T1 :: b -> b -> T [b] } - f :: Eq a => T a -> Bool - f (T1 x y) = [x]==[y] - -The constructor T1 binds an existential variable 'b', and we need Eq [b]. -Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we -pass it inwards. - --} - --- | Type alias for 'IORef'; the convention is we'll use this for mutable --- bits of data in 'TcGblEnv' which are updated during typechecking and --- returned at the end. -type TcRef a = IORef a --- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'? -type TcId = Id -type TcIdSet = IdSet - ---------------------------- --- The TcIdBinderStack ---------------------------- - -type TcIdBinderStack = [TcIdBinder] - -- This is a stack of locally-bound ids, innermost on top - -- Used ony in error reporting (relevantBindings in TcError) - -- We can't use the tcl_env type environment, because it doesn't - -- keep track of the nesting order - -data TcIdBinder - = TcIdBndr - TcId - TopLevelFlag -- Tells whether the binding is syntactically top-level - -- (The monomorphic Ids for a recursive group count - -- as not-top-level for this purpose.) - | TcIdBndr_ExpType -- Variant that allows the type to be specified as - -- an ExpType - Name - ExpType - TopLevelFlag - -instance Outputable TcIdBinder where - ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl) - ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl) - -instance HasOccName TcIdBinder where - occName (TcIdBndr id _) = (occName (idName id)) - occName (TcIdBndr_ExpType name _ _) = (occName name) - ---------------------------- --- Template Haskell stages and levels ---------------------------- - -data SpliceType = Typed | Untyped - -data ThStage -- See Note [Template Haskell state diagram] in TcSplice - = Splice SpliceType -- Inside a top-level splice - -- This code will be run *at compile time*; - -- the result replaces the splice - -- Binding level = 0 - - | RunSplice (TcRef [ForeignRef (TH.Q ())]) - -- Set when running a splice, i.e. NOT when renaming or typechecking the - -- Haskell code for the splice. See Note [RunSplice ThLevel]. - -- - -- Contains a list of mod finalizers collected while executing the splice. - -- - -- 'addModFinalizer' inserts finalizers here, and from here they are taken - -- to construct an @HsSpliced@ annotation for untyped splices. See Note - -- [Delaying modFinalizers in untyped splices] in "RnSplice". - -- - -- For typed splices, the typechecker takes finalizers from here and - -- inserts them in the list of finalizers in the global environment. - -- - -- See Note [Collecting modFinalizers in typed splices] in "TcSplice". - - | Comp -- Ordinary Haskell code - -- Binding level = 1 - - | Brack -- Inside brackets - ThStage -- Enclosing stage - PendingStuff - -data PendingStuff - = RnPendingUntyped -- Renaming the inside of an *untyped* bracket - (TcRef [PendingRnSplice]) -- Pending splices in here - - | RnPendingTyped -- Renaming the inside of a *typed* bracket - - | TcPending -- Typechecking the inside of a typed bracket - (TcRef [PendingTcSplice]) -- Accumulate pending splices here - (TcRef WantedConstraints) -- and type constraints here - -topStage, topAnnStage, topSpliceStage :: ThStage -topStage = Comp -topAnnStage = Splice Untyped -topSpliceStage = Splice Untyped - -instance Outputable ThStage where - ppr (Splice _) = text "Splice" - ppr (RunSplice _) = text "RunSplice" - ppr Comp = text "Comp" - ppr (Brack s _) = text "Brack" <> parens (ppr s) - -type ThLevel = Int - -- NB: see Note [Template Haskell levels] in TcSplice - -- Incremented when going inside a bracket, - -- decremented when going inside a splice - -- NB: ThLevel is one greater than the 'n' in Fig 2 of the - -- original "Template meta-programming for Haskell" paper - -impLevel, outerLevel :: ThLevel -impLevel = 0 -- Imported things; they can be used inside a top level splice -outerLevel = 1 -- Things defined outside brackets - -thLevel :: ThStage -> ThLevel -thLevel (Splice _) = 0 -thLevel (RunSplice _) = - -- See Note [RunSplice ThLevel]. - panic "thLevel: called when running a splice" -thLevel Comp = 1 -thLevel (Brack s _) = thLevel s + 1 - -{- Node [RunSplice ThLevel] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'RunSplice' stage is set when executing a splice, and only when running a -splice. In particular it is not set when the splice is renamed or typechecked. - -'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert -the finalizer (see Note [Delaying modFinalizers in untyped splices]), and -'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to -set 'RunSplice' when renaming or typechecking the splice, where 'Splice', 'Brak' -or 'Comp' are used instead. - --} - ---------------------------- --- Arrow-notation context ---------------------------- - -{- Note [Escaping the arrow scope] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In arrow notation, a variable bound by a proc (or enclosed let/kappa) -is not in scope to the left of an arrow tail (-<) or the head of (|..|). -For example - - proc x -> (e1 -< e2) - -Here, x is not in scope in e1, but it is in scope in e2. This can get -a bit complicated: - - let x = 3 in - proc y -> (proc z -> e1) -< e2 - -Here, x and z are in scope in e1, but y is not. - -We implement this by -recording the environment when passing a proc (using newArrowScope), -and returning to that (using escapeArrowScope) on the left of -< and the -head of (|..|). - -All this can be dealt with by the *renamer*. But the type checker needs -to be involved too. Example (arrowfail001) - class Foo a where foo :: a -> () - data Bar = forall a. Foo a => Bar a - get :: Bar -> () - get = proc x -> case x of Bar a -> foo -< a -Here the call of 'foo' gives rise to a (Foo a) constraint that should not -be captured by the pattern match on 'Bar'. Rather it should join the -constraints from further out. So we must capture the constraint bag -from further out in the ArrowCtxt that we push inwards. --} - -data ArrowCtxt -- Note [Escaping the arrow scope] - = NoArrowCtxt - | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints) - - ---------------------------- --- TcTyThing ---------------------------- - --- | A typecheckable thing available in a local context. Could be --- 'AGlobal' 'TyThing', but also lexically scoped variables, etc. --- See 'TcEnv' for how to retrieve a 'TyThing' given a 'Name'. -data TcTyThing - = AGlobal TyThing -- Used only in the return type of a lookup - - | ATcId -- Ids defined in this module; may not be fully zonked - { tct_id :: TcId - , tct_info :: IdBindingInfo -- See Note [Meaning of IdBindingInfo] - } - - | ATyVar Name TcTyVar -- The type variable to which the lexically scoped type - -- variable is bound. We only need the Name - -- for error-message purposes; it is the corresponding - -- Name in the domain of the envt - - | ATcTyCon TyCon -- Used temporarily, during kind checking, for the - -- tycons and clases in this recursive group - -- The TyCon is always a TcTyCon. Its kind - -- can be a mono-kind or a poly-kind; in TcTyClsDcls see - -- Note [Type checking recursive type and class declarations] - - | APromotionErr PromotionErr - -data PromotionErr - = TyConPE -- TyCon used in a kind before we are ready - -- data T :: T -> * where ... - | ClassPE -- Ditto Class - - | FamDataConPE -- Data constructor for a data family - -- See Note [AFamDataCon: not promoting data family constructors] - -- in TcEnv. - | PatSynPE -- Pattern synonyms - -- See Note [Don't promote pattern synonyms] in TcEnv - - | RecDataConPE -- Data constructor in a recursive loop - -- See Note [ARecDataCon: recusion and promoting data constructors] in TcTyClsDecls - | NoDataKindsTC -- -XDataKinds not enabled (for a tycon) - | NoDataKindsDC -- -XDataKinds not enabled (for a datacon) - | NoTypeInTypeTC -- -XTypeInType not enabled (for a tycon) - | NoTypeInTypeDC -- -XTypeInType not enabled (for a datacon) - -instance Outputable TcTyThing where -- Debugging only - ppr (AGlobal g) = ppr g - ppr elt@(ATcId {}) = text "Identifier" <> - brackets (ppr (tct_id elt) <> dcolon - <> ppr (varType (tct_id elt)) <> comma - <+> ppr (tct_info elt)) - ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv - ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) - ppr (APromotionErr err) = text "APromotionErr" <+> ppr err - --- | IdBindingInfo describes how an Id is bound. --- --- It is used for the following purposes: --- a) for static forms in TcExpr.checkClosedInStaticForm and --- b) to figure out when a nested binding can be generalised, --- in TcBinds.decideGeneralisationPlan. --- -data IdBindingInfo -- See Note [Meaning of IdBindingInfo and ClosedTypeId] - = NotLetBound - | ClosedLet - | NonClosedLet - RhsNames -- Used for (static e) checks only - ClosedTypeId -- Used for generalisation checks - -- and for (static e) checks - --- | IsGroupClosed describes a group of mutually-recursive bindings -data IsGroupClosed - = IsGroupClosed - (NameEnv RhsNames) -- Free var info for the RHS of each binding in the goup - -- Used only for (static e) checks - - ClosedTypeId -- True <=> all the free vars of the group are - -- imported or ClosedLet or - -- NonClosedLet with ClosedTypeId=True. - -- In particular, no tyvars, no NotLetBound - -type RhsNames = NameSet -- Names of variables, mentioned on the RHS of - -- a definition, that are not Global or ClosedLet - -type ClosedTypeId = Bool - -- See Note [Meaning of IdBindingInfo and ClosedTypeId] - -{- Note [Meaning of IdBindingInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NotLetBound means that - the Id is not let-bound (e.g. it is bound in a - lambda-abstraction or in a case pattern) - -ClosedLet means that - - The Id is let-bound, - - Any free term variables are also Global or ClosedLet - - Its type has no free variables (NB: a top-level binding subject - to the MR might have free vars in its type) - These ClosedLets can definitely be floated to top level; and we - may need to do so for static forms. - - Property: ClosedLet - is equivalent to - NonClosedLet emptyNameSet True - -(NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that - - The Id is let-bound - - - The fvs::RhsNames contains the free names of the RHS, - excluding Global and ClosedLet ones. - - - For the ClosedTypeId field see Note [Bindings with closed types] - -For (static e) to be valid, we need for every 'x' free in 'e', -x's binding must be floatable to top level. Specifically: - * x's RhsNames must be non-empty - * x's type has no free variables -See Note [Grand plan for static forms] in StaticPtrTable.hs. -This test is made in TcExpr.checkClosedInStaticForm. -Actually knowing x's RhsNames (rather than just its emptiness -or otherwise) is just so we can produce better error messages - -Note [Bindings with closed types: ClosedTypeId] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - f x = let g ys = map not ys - in ... - -Can we generalise 'g' under the OutsideIn algorithm? Yes, -because all g's free variables are top-level; that is they themselves -have no free type variables, and it is the type variables in the -environment that makes things tricky for OutsideIn generalisation. - -Here's the invariant: - If an Id has ClosedTypeId=True (in its IdBindingInfo), then - the Id's type is /definitely/ closed (has no free type variables). - Specifically, - a) The Id's acutal type is closed (has no free tyvars) - b) Either the Id has a (closed) user-supplied type signature - or all its free varaibles are Global/ClosedLet - or NonClosedLet with ClosedTypeId=True. - In particular, none are NotLetBound. - -Why is (b) needed? Consider - \x. (x :: Int, let y = x+1 in ...) -Initially x::alpha. If we happen to typecheck the 'let' before the -(x::Int), y's type will have a free tyvar; but if the other way round -it won't. So we treat any let-bound variable with a free -non-let-bound variable as not ClosedTypeId, regardless of what the -free vars of its type actually are. - -But if it has a signature, all is well: - \x. ...(let { y::Int; y = x+1 } in - let { v = y+2 } in ...)... -Here the signature on 'v' makes 'y' a ClosedTypeId, so we can -generalise 'v'. - -Note that: - - * A top-level binding may not have ClosedTypeId=True, if it suffers - from the MR - - * A nested binding may be closed (eg 'g' in the example we started - with). Indeed, that's the point; whether a function is defined at - top level or nested is orthogonal to the question of whether or - not it is closed. - - * A binding may be non-closed because it mentions a lexically scoped - *type variable* Eg - f :: forall a. blah - f x = let g y = ...(y::a)... - -Under OutsideIn we are free to generalise an Id all of whose free -variables have ClosedTypeId=True (or imported). This is an extension -compared to the JFP paper on OutsideIn, which used "top-level" as a -proxy for "closed". (It's not a good proxy anyway -- the MR can make -a top-level binding with a free type variable.) --} - -instance Outputable IdBindingInfo where - ppr NotLetBound = text "NotLetBound" - ppr ClosedLet = text "TopLevelLet" - ppr (NonClosedLet fvs closed_type) = - text "TopLevelLet" <+> ppr fvs <+> ppr closed_type - -instance Outputable PromotionErr where - ppr ClassPE = text "ClassPE" - ppr TyConPE = text "TyConPE" - ppr PatSynPE = text "PatSynPE" - ppr FamDataConPE = text "FamDataConPE" - ppr RecDataConPE = text "RecDataConPE" - ppr NoDataKindsTC = text "NoDataKindsTC" - ppr NoDataKindsDC = text "NoDataKindsDC" - ppr NoTypeInTypeTC = text "NoTypeInTypeTC" - ppr NoTypeInTypeDC = text "NoTypeInTypeDC" - -pprTcTyThingCategory :: TcTyThing -> SDoc -pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing -pprTcTyThingCategory (ATyVar {}) = text "Type variable" -pprTcTyThingCategory (ATcId {}) = text "Local identifier" -pprTcTyThingCategory (ATcTyCon {}) = text "Local tycon" -pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe - -pprPECategory :: PromotionErr -> SDoc -pprPECategory ClassPE = text "Class" -pprPECategory TyConPE = text "Type constructor" -pprPECategory PatSynPE = text "Pattern synonym" -pprPECategory FamDataConPE = text "Data constructor" -pprPECategory RecDataConPE = text "Data constructor" -pprPECategory NoDataKindsTC = text "Type constructor" -pprPECategory NoDataKindsDC = text "Data constructor" -pprPECategory NoTypeInTypeTC = text "Type constructor" -pprPECategory NoTypeInTypeDC = text "Data constructor" - -{- -************************************************************************ -* * - Operations over ImportAvails -* * -************************************************************************ --} - --- | 'ImportAvails' summarises what was imported from where, irrespective of --- whether the imported things are actually used or not. It is used: --- --- * when processing the export list, --- --- * when constructing usage info for the interface file, --- --- * to identify the list of directly imported modules for initialisation --- purposes and for optimised overlap checking of family instances, --- --- * when figuring out what things are really unused --- -data ImportAvails - = ImportAvails { - imp_mods :: ImportedMods, - -- = ModuleEnv [ImportedModsVal], - -- ^ Domain is all directly-imported modules - -- - -- See the documentation on ImportedModsVal in HscTypes for the - -- meaning of the fields. - -- - -- We need a full ModuleEnv rather than a ModuleNameEnv here, - -- because we might be importing modules of the same name from - -- different packages. (currently not the case, but might be in the - -- future). - - imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), - -- ^ Home-package modules needed by the module being compiled - -- - -- It doesn't matter whether any of these dependencies - -- are actually /used/ when compiling the module; they - -- are listed if they are below it at all. For - -- example, suppose M imports A which imports X. Then - -- compiling M might not need to consult X.hi, but X - -- is still listed in M's dependencies. - - imp_dep_pkgs :: Set InstalledUnitId, - -- ^ Packages needed by the module being compiled, whether directly, - -- or via other modules in this package, or via modules imported - -- from other packages. - - imp_trust_pkgs :: Set InstalledUnitId, - -- ^ This is strictly a subset of imp_dep_pkgs and records the - -- packages the current module needs to trust for Safe Haskell - -- compilation to succeed. A package is required to be trusted if - -- we are dependent on a trustworthy module in that package. - -- While perhaps making imp_dep_pkgs a tuple of (UnitId, Bool) - -- where True for the bool indicates the package is required to be - -- trusted is the more logical design, doing so complicates a lot - -- of code not concerned with Safe Haskell. - -- See Note [RnNames . Tracking Trust Transitively] - - imp_trust_own_pkg :: Bool, - -- ^ Do we require that our own package is trusted? - -- This is to handle efficiently the case where a Safe module imports - -- a Trustworthy module that resides in the same package as it. - -- See Note [RnNames . Trust Own Package] - - imp_orphs :: [Module], - -- ^ Orphan modules below us in the import tree (and maybe including - -- us for imported modules) - - imp_finsts :: [Module] - -- ^ Family instance modules below us in the import tree (and maybe - -- including us for imported modules) - } - -mkModDeps :: [(ModuleName, IsBootInterface)] - -> ModuleNameEnv (ModuleName, IsBootInterface) -mkModDeps deps = foldl add emptyUFM deps - where - add env elt@(m,_) = addToUFM env m elt - -modDepsElts - :: ModuleNameEnv (ModuleName, IsBootInterface) - -> [(ModuleName, IsBootInterface)] -modDepsElts = sort . nonDetEltsUFM - -- It's OK to use nonDetEltsUFM here because sorting by module names - -- restores determinism - -emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, - imp_dep_mods = emptyUFM, - imp_dep_pkgs = S.empty, - imp_trust_pkgs = S.empty, - imp_trust_own_pkg = False, - imp_orphs = [], - imp_finsts = [] } - --- | Union two ImportAvails --- --- This function is a key part of Import handling, basically --- for each import we create a separate ImportAvails structure --- and then union them all together with this function. -plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails -plusImportAvails - (ImportAvails { imp_mods = mods1, - imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, - imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, - imp_orphs = orphs1, imp_finsts = finsts1 }) - (ImportAvails { imp_mods = mods2, - imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, - imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, - imp_orphs = orphs2, imp_finsts = finsts2 }) - = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, - imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, - imp_dep_pkgs = dpkgs1 `S.union` dpkgs2, - imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, - imp_trust_own_pkg = tself1 || tself2, - imp_orphs = orphs1 `unionLists` orphs2, - imp_finsts = finsts1 `unionLists` finsts2 } - where - plus_mod_dep (m1, boot1) (m2, boot2) - = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) - -- Check mod-names match - (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that - -{- -************************************************************************ -* * -\subsection{Where from} -* * -************************************************************************ - -The @WhereFrom@ type controls where the renamer looks for an interface file --} - -data WhereFrom - = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) - | ImportBySystem -- Non user import. - | ImportByPlugin -- Importing a plugin; - -- See Note [Care with plugin imports] in LoadIface - -instance Outputable WhereFrom where - ppr (ImportByUser is_boot) | is_boot = text "{- SOURCE -}" - | otherwise = empty - ppr ImportBySystem = text "{- SYSTEM -}" - ppr ImportByPlugin = text "{- PLUGIN -}" - - -{- ********************************************************************* -* * - Type signatures -* * -********************************************************************* -} - --- These data types need to be here only because --- TcSimplify uses them, and TcSimplify is fairly --- low down in the module hierarchy - -type TcSigFun = Name -> Maybe TcSigInfo - -data TcSigInfo = TcIdSig TcIdSigInfo - | TcPatSynSig TcPatSynInfo - -data TcIdSigInfo -- See Note [Complete and partial type signatures] - = CompleteSig -- A complete signature with no wildcards, - -- so the complete polymorphic type is known. - { sig_bndr :: TcId -- The polymorphic Id with that type - - , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods, - -- the Name in the FunSigCtxt is not the same - -- as the TcId; the former is 'op', while the - -- latter is '$dmop' or some such - - , sig_loc :: SrcSpan -- Location of the type signature - } - - | PartialSig -- A partial type signature (i.e. includes one or more - -- wildcards). In this case it doesn't make sense to give - -- the polymorphic Id, because we are going to /infer/ its - -- type, so we can't make the polymorphic Id ab-initio - { psig_name :: Name -- Name of the function; used when report wildcards - , psig_hs_ty :: LHsSigWcType Name -- The original partial signature in HsSyn form - , sig_ctxt :: UserTypeCtxt - , sig_loc :: SrcSpan -- Location of the type signature - } - - -{- Note [Complete and partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type signature is partial when it contains one or more wildcards -(= type holes). The wildcard can either be: -* A (type) wildcard occurring in sig_theta or sig_tau. These are - stored in sig_wcs. - f :: Bool -> _ - g :: Eq _a => _a -> _a -> Bool -* Or an extra-constraints wildcard, stored in sig_cts: - h :: (Num a, _) => a -> a - -A type signature is a complete type signature when there are no -wildcards in the type signature, i.e. iff sig_wcs is empty and -sig_extra_cts is Nothing. --} - -data TcIdSigInst - = TISI { sig_inst_sig :: TcIdSigInfo - - , sig_inst_skols :: [(Name, TcTyVar)] - -- Instantiated type and kind variables, SigTvs - -- The Name is the Name that the renamer chose; - -- but the TcTyVar may come from instantiating - -- the type and hence have a different unique. - -- No need to keep track of whether they are truly lexically - -- scoped because the renamer has named them uniquely - -- See Note [Binding scoped type variables] in TcSigs - - , sig_inst_theta :: TcThetaType - -- Instantiated theta. In the case of a - -- PartialSig, sig_theta does not include - -- the extra-constraints wildcard - - , sig_inst_tau :: TcSigmaType -- Instantiated tau - -- See Note [sig_inst_tau may be polymorphic] - - -- Relevant for partial signature only - , sig_inst_wcs :: [(Name, TcTyVar)] - -- Like sig_inst_skols, but for wildcards. The named - -- wildcards scope over the binding, and hence their - -- Names may appear in type signatures in the binding - - , sig_inst_wcx :: Maybe TcTyVar - -- Extra-constraints wildcard to fill in, if any - } - -{- Note [sig_inst_tau may be polymorphic] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that "sig_inst_tau" might actually be a polymorphic type, -if the original function had a signature like - forall a. Eq a => forall b. Ord b => .... -But that's ok: tcMatchesFun (called by tcRhs) can deal with that -It happens, too! See Note [Polymorphic methods] in TcClassDcl. - -Note [Wildcards in partial signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wildcards in psig_wcs may stand for a type mentioning -the universally-quantified tyvars of psig_ty - -E.g. f :: forall a. _ -> a - f x = x -We get sig_inst_skols = [a] - sig_inst_tau = _22 -> a - sig_inst_wcs = [_22] -and _22 in the end is unified with the type 'a' - -Moreover the kind of a wildcard in sig_inst_wcs may mention -the universally-quantified tyvars sig_inst_skols -e.g. f :: t a -> t _ -Here we get - sig_inst_skols = [k:*, (t::k ->*), (a::k)] - sig_inst_tau = t a -> t _22 - sig_inst_wcs = [ _22::k ] --} - -data TcPatSynInfo - = TPSI { - patsig_name :: Name, - patsig_implicit_bndrs :: [TyVarBinder], -- Implicitly-bound kind vars (Inferred) and - -- implicitly-bound type vars (Specified) - -- See Note [The pattern-synonym signature splitting rule] in TcPatSyn - patsig_univ_bndrs :: [TyVar], -- Bound by explicit user forall - patsig_req :: TcThetaType, - patsig_ex_bndrs :: [TyVar], -- Bound by explicit user forall - patsig_prov :: TcThetaType, - patsig_body_ty :: TcSigmaType - } - -instance Outputable TcSigInfo where - ppr (TcIdSig idsi) = ppr idsi - ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi - -instance Outputable TcIdSigInfo where - ppr (CompleteSig { sig_bndr = bndr }) - = ppr bndr <+> dcolon <+> ppr (idType bndr) - ppr (PartialSig { psig_name = name, psig_hs_ty = hs_ty }) - = text "psig" <+> ppr name <+> dcolon <+> ppr hs_ty - -instance Outputable TcIdSigInst where - ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols - , sig_inst_theta = theta, sig_inst_tau = tau }) - = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ]) - -instance Outputable TcPatSynInfo where - ppr (TPSI{ patsig_name = name}) = ppr name - -isPartialSig :: TcIdSigInst -> Bool -isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = True -isPartialSig _ = False - --- | No signature or a partial signature -hasCompleteSig :: TcSigFun -> Name -> Bool -hasCompleteSig sig_fn name - = case sig_fn name of - Just (TcIdSig (CompleteSig {})) -> True - _ -> False - - -{- -************************************************************************ -* * -* Canonical constraints * -* * -* These are the constraints the low-level simplifier works with * -* * -************************************************************************ --} - --- The syntax of xi (ξ) types: --- xi ::= a | T xis | xis -> xis | ... | forall a. tau --- Two important notes: --- (i) No type families, unless we are under a ForAll --- (ii) Note that xi types can contain unexpanded type synonyms; --- however, the (transitive) expansions of those type synonyms --- will not contain any type functions, unless we are under a ForAll. --- We enforce the structure of Xi types when we flatten (TcCanonical) - -type Xi = Type -- In many comments, "xi" ranges over Xi - -type Cts = Bag Ct - -data Ct - -- Atomic canonical constraints - = CDictCan { -- e.g. Num xi - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - - cc_class :: Class, - cc_tyargs :: [Xi], -- cc_tyargs are function-free, hence Xi - - cc_pend_sc :: Bool -- See Note [The superclass story] in TcCanonical - -- True <=> (a) cc_class has superclasses - -- (b) we have not (yet) added those - -- superclasses as Givens - } - - | CIrredEvCan { -- These stand for yet-unusable predicates - cc_ev :: CtEvidence -- See Note [Ct/evidence invariant] - -- The ctev_pred of the evidence is - -- of form (tv xi1 xi2 ... xin) - -- or (tv1 ~ ty2) where the CTyEqCan kind invariant fails - -- or (F tys ~ ty) where the CFunEqCan kind invariant fails - -- See Note [CIrredEvCan constraints] - } - - | CTyEqCan { -- tv ~ rhs - -- Invariants: - -- * See Note [Applying the inert substitution] in TcFlatten - -- * tv not in tvs(rhs) (occurs check) - -- * If tv is a TauTv, then rhs has no foralls - -- (this avoids substituting a forall for the tyvar in other types) - -- * typeKind ty `tcEqKind` typeKind tv - -- * rhs may have at most one top-level cast - -- * rhs (perhaps under the one cast) is not necessarily function-free, - -- but it has no top-level function. - -- E.g. a ~ [F b] is fine - -- but a ~ F b is not - -- * If the equality is representational, rhs has no top-level newtype - -- See Note [No top-level newtypes on RHS of representational - -- equalities] in TcCanonical - -- * If rhs (perhaps under the cast) is also a tv, then it is oriented - -- to give best chance of - -- unification happening; eg if rhs is touchable then lhs is too - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_tyvar :: TcTyVar, - cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi) - -- See invariants above - - cc_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev - } - - | CFunEqCan { -- F xis ~ fsk - -- Invariants: - -- * isTypeFamilyTyCon cc_fun - -- * typeKind (F xis) = tyVarKind fsk - -- * always Nominal role - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_fun :: TyCon, -- A type function - - cc_tyargs :: [Xi], -- cc_tyargs are function-free (hence Xi) - -- Either under-saturated or exactly saturated - -- *never* over-saturated (because if so - -- we should have decomposed) - - cc_fsk :: TcTyVar -- [Given] always a FlatSkol skolem - -- [Wanted] always a FlatMetaTv unification variable - -- See Note [The flattening story] in TcFlatten - } - - | CNonCanonical { -- See Note [NonCanonical Semantics] in TcSMonad - cc_ev :: CtEvidence - } - - | CHoleCan { -- See Note [Hole constraints] - -- Treated as an "insoluble" constraint - -- See Note [Insoluble constraints] - cc_ev :: CtEvidence, - cc_hole :: Hole - } - --- | An expression or type hole -data Hole = ExprHole UnboundVar - -- ^ Either an out-of-scope variable or a "true" hole in an - -- expression (TypedHoles) - | TypeHole OccName - -- ^ A hole in a type (PartialTypeSignatures) - -holeOcc :: Hole -> OccName -holeOcc (ExprHole uv) = unboundVarOcc uv -holeOcc (TypeHole occ) = occ - -{- Note [Hole constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -CHoleCan constraints are used for two kinds of holes, -distinguished by cc_hole: - - * For holes in expressions (including variables not in scope) - e.g. f x = g _ x - - * For holes in type signatures - e.g. f :: _ -> _ - f x = [x,True] - -Note [CIrredEvCan constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CIrredEvCan constraints are used for constraints that are "stuck" - - we can't solve them (yet) - - we can't use them to solve other constraints - - but they may become soluble if we substitute for some - of the type variables in the constraint - -Example 1: (c Int), where c :: * -> Constraint. We can't do anything - with this yet, but if later c := Num, *then* we can solve it - -Example 2: a ~ b, where a :: *, b :: k, where k is a kind variable - We don't want to use this to substitute 'b' for 'a', in case - 'k' is subequently unifed with (say) *->*, because then - we'd have ill-kinded types floating about. Rather we want - to defer using the equality altogether until 'k' get resolved. - -Note [Ct/evidence invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field -of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for CDictCan, - ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct) -This holds by construction; look at the unique place where CDictCan is -built (in TcCanonical). - -In contrast, the type of the evidence *term* (ctev_dest / ctev_evar) in -the evidence may *not* be fully zonked; we are careful not to look at it -during constraint solving. See Note [Evidence field of CtEvidence]. --} - -mkNonCanonical :: CtEvidence -> Ct -mkNonCanonical ev = CNonCanonical { cc_ev = ev } - -mkNonCanonicalCt :: Ct -> Ct -mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } - -mkGivens :: CtLoc -> [EvId] -> [Ct] -mkGivens loc ev_ids - = map mk ev_ids - where - mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id - , ctev_pred = evVarPred ev_id - , ctev_loc = loc }) - -ctEvidence :: Ct -> CtEvidence -ctEvidence = cc_ev - -ctLoc :: Ct -> CtLoc -ctLoc = ctEvLoc . ctEvidence - -setCtLoc :: Ct -> CtLoc -> Ct -setCtLoc ct loc = ct { cc_ev = (cc_ev ct) { ctev_loc = loc } } - -ctOrigin :: Ct -> CtOrigin -ctOrigin = ctLocOrigin . ctLoc - -ctPred :: Ct -> PredType --- See Note [Ct/evidence invariant] -ctPred ct = ctEvPred (cc_ev ct) - --- | Makes a new equality predicate with the same role as the given --- evidence. -mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType -mkTcEqPredLikeEv ev - = case predTypeEqRel pred of - NomEq -> mkPrimEqPred - ReprEq -> mkReprPrimEqPred - where - pred = ctEvPred ev - --- | Get the flavour of the given 'Ct' -ctFlavour :: Ct -> CtFlavour -ctFlavour = ctEvFlavour . ctEvidence - --- | Get the equality relation for the given 'Ct' -ctEqRel :: Ct -> EqRel -ctEqRel = ctEvEqRel . ctEvidence - -instance Outputable Ct where - ppr ct = ppr (cc_ev ct) <+> parens pp_sort - where - pp_sort = case ct of - CTyEqCan {} -> text "CTyEqCan" - CFunEqCan {} -> text "CFunEqCan" - CNonCanonical {} -> text "CNonCanonical" - CDictCan { cc_pend_sc = pend_sc } - | pend_sc -> text "CDictCan(psc)" - | otherwise -> text "CDictCan" - CIrredEvCan {} -> text "CIrredEvCan" - CHoleCan { cc_hole = hole } -> text "CHoleCan:" <+> ppr (holeOcc hole) - -{- -************************************************************************ -* * - Simple functions over evidence variables -* * -************************************************************************ --} - ----------------- Getting free tyvars ------------------------- - --- | Returns free variables of constraints as a non-deterministic set -tyCoVarsOfCt :: Ct -> TcTyCoVarSet -tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt - --- | Returns free variables of constraints as a deterministically ordered. --- list. See Note [Deterministic FV] in FV. -tyCoVarsOfCtList :: Ct -> [TcTyCoVar] -tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt - --- | Returns free variables of constraints as a composable FV computation. --- See Note [Deterministic FV] in FV. -tyCoFVsOfCt :: Ct -> FV -tyCoFVsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) - = tyCoFVsOfType xi `unionFV` FV.unitFV tv - `unionFV` tyCoFVsOfType (tyVarKind tv) -tyCoFVsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) - = tyCoFVsOfTypes tys `unionFV` FV.unitFV fsk - `unionFV` tyCoFVsOfType (tyVarKind fsk) -tyCoFVsOfCt (CDictCan { cc_tyargs = tys }) = tyCoFVsOfTypes tys -tyCoFVsOfCt (CIrredEvCan { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev) -tyCoFVsOfCt (CHoleCan { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev) -tyCoFVsOfCt (CNonCanonical { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev) - --- | Returns free variables of a bag of constraints as a non-deterministic --- set. See Note [Deterministic FV] in FV. -tyCoVarsOfCts :: Cts -> TcTyCoVarSet -tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts - --- | Returns free variables of a bag of constraints as a deterministically --- odered list. See Note [Deterministic FV] in FV. -tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] -tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts - --- | Returns free variables of a bag of constraints as a composable FV --- computation. See Note [Deterministic FV] in FV. -tyCoFVsOfCts :: Cts -> FV -tyCoFVsOfCts = foldrBag (unionFV . tyCoFVsOfCt) emptyFV - --- | Returns free variables of WantedConstraints as a non-deterministic --- set. See Note [Deterministic FV] in FV. -tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC - --- | Returns free variables of WantedConstraints as a deterministically --- ordered list. See Note [Deterministic FV] in FV. -tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar] --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC - --- | Returns free variables of WantedConstraints as a composable FV --- computation. See Note [Deterministic FV] in FV. -tyCoFVsOfWC :: WantedConstraints -> FV --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol }) - = tyCoFVsOfCts simple `unionFV` - tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV` - tyCoFVsOfCts insol - --- | Returns free variables of Implication as a composable FV computation. --- See Note [Deterministic FV] in FV. -tyCoFVsOfImplic :: Implication -> FV --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoFVsOfImplic (Implic { ic_skols = skols - , ic_given = givens - , ic_wanted = wanted }) - = FV.delFVs (mkVarSet skols `unionVarSet` mkVarSet givens) - (tyCoFVsOfWC wanted `unionFV` tyCoFVsOfTypes (map evVarPred givens)) - -tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV -tyCoFVsOfBag tvs_of = foldrBag (unionFV . tvs_of) emptyFV - --------------------------- -dropDerivedSimples :: Cts -> Cts --- Drop all Derived constraints, but make [W] back into [WD], --- so that if we re-simplify these constraints we will get all --- the right derived constraints re-generated. Forgetting this --- step led to #12936 -dropDerivedSimples simples = mapMaybeBag dropDerivedCt simples - -dropDerivedCt :: Ct -> Maybe Ct -dropDerivedCt ct - = case ctEvFlavour ev of - Wanted WOnly -> Just (ct' { cc_ev = ev_wd }) - Wanted _ -> Just ct' - _ -> ASSERT( isDerivedCt ct ) Nothing - -- simples are all Wanted or Derived - where - ev = ctEvidence ct - ev_wd = ev { ctev_nosh = WDeriv } - ct' = setPendingScDict ct -- See Note [Resetting cc_pend_sc] - -{- Note [Resetting cc_pend_sc] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we discard Derived constraints, in dropDerivedSimples, we must -set the cc_pend_sc flag to True, so that if we re-process this -CDictCan we will re-generate its derived superclasses. Otherwise -we might miss some fundeps. Trac #13662 showed this up. - -See Note [The superclass story] in TcCanonical. --} - - -dropDerivedInsols :: Cts -> Cts --- See Note [Dropping derived constraints] -dropDerivedInsols insols = filterBag keep insols - where -- insols can include Given - keep ct - | isDerivedCt ct = not (isDroppableDerivedLoc (ctLoc ct)) - | otherwise = True - -isDroppableDerivedLoc :: CtLoc -> Bool --- Note [Dropping derived constraints] -isDroppableDerivedLoc loc - = case ctLocOrigin loc of - HoleOrigin {} -> False - KindEqOrigin {} -> False - GivenOrigin {} -> False - FunDepOrigin1 {} -> False - FunDepOrigin2 {} -> False - _ -> True - -arisesFromGivens :: Ct -> Bool -arisesFromGivens ct - = case ctEvidence ct of - CtGiven {} -> True - CtWanted {} -> False - CtDerived { ctev_loc = loc } -> from_given loc - where - from_given :: CtLoc -> Bool - from_given loc = from_given_origin (ctLocOrigin loc) - - from_given_origin :: CtOrigin -> Bool - from_given_origin (GivenOrigin {}) = True - from_given_origin (FunDepOrigin1 _ l1 _ l2) = from_given l1 && from_given l2 - from_given_origin (FunDepOrigin2 _ o1 _ _) = from_given_origin o1 - from_given_origin _ = False - -{- Note [Dropping derived constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we discard derived constraints at the end of constraint solving; -see dropDerivedWC. For example - - * If we have an unsolved [W] (Ord a), we don't want to complain about - an unsolved [D] (Eq a) as well. - - * If we have [W] a ~ Int, [W] a ~ Bool, improvement will generate - [D] Int ~ Bool, and we don't want to report that because it's incomprehensible. - That is why we don't rewrite wanteds with wanteds! - -But (tiresomely) we do keep *some* Derived insolubles: - - * Insoluble kind equalities (e.g. [D] * ~ (* -> *)) may arise from - a type equality a ~ Int#, say. In future they'll be Wanted, not Derived, - but at the moment they are Derived. - - * Insoluble derived equalities (e.g. [D] Int ~ Bool) may arise from - functional dependency interactions, either between Givens or - Wanteds. It seems sensible to retain these: - - For Givens they reflect unreachable code - - For Wanteds it is arguably better to get a fundep error than - a no-instance error (Trac #9612) - - * Type holes are derived constraints because they have no evidence - and we want to keep them so we get the error report - -Moreover, we keep *all* derived insolubles under some circumstances: - - * They are looked at by simplifyInfer, to decide whether to - generalise. Example: [W] a ~ Int, [W] a ~ Bool - We get [D] Int ~ Bool, and indeed the constraints are insoluble, - and we want simplifyInfer to see that, even though we don't - ultimately want to generate an (inexplicable) error message from - -To distinguish these cases we use the CtOrigin. - - -************************************************************************ -* * - CtEvidence - The "flavor" of a canonical constraint -* * -************************************************************************ --} - -isWantedCt :: Ct -> Bool -isWantedCt = isWanted . cc_ev - -isGivenCt :: Ct -> Bool -isGivenCt = isGiven . cc_ev - -isDerivedCt :: Ct -> Bool -isDerivedCt = isDerived . cc_ev - -isCTyEqCan :: Ct -> Bool -isCTyEqCan (CTyEqCan {}) = True -isCTyEqCan (CFunEqCan {}) = False -isCTyEqCan _ = False - -isCDictCan_Maybe :: Ct -> Maybe Class -isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls -isCDictCan_Maybe _ = Nothing - -isCIrredEvCan :: Ct -> Bool -isCIrredEvCan (CIrredEvCan {}) = True -isCIrredEvCan _ = False - -isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type]) -isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis) -isCFunEqCan_maybe _ = Nothing - -isCFunEqCan :: Ct -> Bool -isCFunEqCan (CFunEqCan {}) = True -isCFunEqCan _ = False - -isCNonCanonical :: Ct -> Bool -isCNonCanonical (CNonCanonical {}) = True -isCNonCanonical _ = False - -isHoleCt:: Ct -> Bool -isHoleCt (CHoleCan {}) = True -isHoleCt _ = False - -isOutOfScopeCt :: Ct -> Bool --- We treat expression holes representing out-of-scope variables a bit --- differently when it comes to error reporting -isOutOfScopeCt (CHoleCan { cc_hole = ExprHole (OutOfScope {}) }) = True -isOutOfScopeCt _ = False - -isExprHoleCt :: Ct -> Bool -isExprHoleCt (CHoleCan { cc_hole = ExprHole {} }) = True -isExprHoleCt _ = False - -isTypeHoleCt :: Ct -> Bool -isTypeHoleCt (CHoleCan { cc_hole = TypeHole {} }) = True -isTypeHoleCt _ = False - - -{- Note [Custom type errors in constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When GHC reports a type-error about an unsolved-constraint, we check -to see if the constraint contains any custom-type errors, and if so -we report them. Here are some examples of constraints containing type -errors: - -TypeError msg -- The actual constraint is a type error - -TypError msg ~ Int -- Some type was supposed to be Int, but ended up - -- being a type error instead - -Eq (TypeError msg) -- A class constraint is stuck due to a type error - -F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err - -It is also possible to have constraints where the type error is nested deeper, -for example see #11990, and also: - -Eq (F (TypeError msg)) -- Here the type error is nested under a type-function - -- call, which failed to evaluate because of it, - -- and so the `Eq` constraint was unsolved. - -- This may happen when one function calls another - -- and the called function produced a custom type error. --} - --- | A constraint is considered to be a custom type error, if it contains --- custom type errors anywhere in it. --- See Note [Custom type errors in constraints] -getUserTypeErrorMsg :: Ct -> Maybe Type -getUserTypeErrorMsg ct = findUserTypeError (ctPred ct) - where - findUserTypeError t = msum ( userTypeError_maybe t - : map findUserTypeError (subTys t) - ) - - subTys t = case splitAppTys t of - (t,[]) -> - case splitTyConApp_maybe t of - Nothing -> [] - Just (_,ts) -> ts - (t,ts) -> t : ts - - - - -isUserTypeErrorCt :: Ct -> Bool -isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of - Just _ -> True - _ -> False - -isPendingScDict :: Ct -> Maybe Ct --- Says whether cc_pend_sc is True, AND if so flips the flag -isPendingScDict ct@(CDictCan { cc_pend_sc = True }) - = Just (ct { cc_pend_sc = False }) -isPendingScDict _ = Nothing - -setPendingScDict :: Ct -> Ct --- Set the cc_pend_sc flag to True -setPendingScDict ct@(CDictCan { cc_pend_sc = False }) - = ct { cc_pend_sc = True } -setPendingScDict ct = ct - -superClassesMightHelp :: Ct -> Bool --- ^ True if taking superclasses of givens, or of wanteds (to perhaps --- expose more equalities or functional dependencies) might help to --- solve this constraint. See Note [When superclasses help] -superClassesMightHelp ct - = isWantedCt ct && not (is_ip ct) - where - is_ip (CDictCan { cc_class = cls }) = isIPClass cls - is_ip _ = False - -{- Note [When superclasses help] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -First read Note [The superclass story] in TcCanonical. - -We expand superclasses and iterate only if there is at unsolved wanted -for which expansion of superclasses (e.g. from given constraints) -might actually help. The function superClassesMightHelp tells if -doing this superclass expansion might help solve this constraint. -Note that - - * Superclasses help only for Wanted constraints. Derived constraints - are not really "unsolved" and we certainly don't want them to - trigger superclass expansion. This was a good part of the loop - in Trac #11523 - - * Even for Wanted constraints, we say "no" for implicit parameters. - we have [W] ?x::ty, expanding superclasses won't help: - - Superclasses can't be implicit parameters - - If we have a [G] ?x:ty2, then we'll have another unsolved - [D] ty ~ ty2 (from the functional dependency) - which will trigger superclass expansion. - - It's a bit of a special case, but it's easy to do. The runtime cost - is low because the unsolved set is usually empty anyway (errors - aside), and the first non-imlicit-parameter will terminate the search. - - The special case is worth it (Trac #11480, comment:2) because it - applies to CallStack constraints, which aren't type errors. If we have - f :: (C a) => blah - f x = ...undefined... - we'll get a CallStack constraint. If that's the only unsolved - constraint it'll eventually be solved by defaulting. So we don't - want to emit warnings about hitting the simplifier's iteration - limit. A CallStack constraint really isn't an unsolved - constraint; it can always be solved by defaulting. --} - -singleCt :: Ct -> Cts -singleCt = unitBag - -andCts :: Cts -> Cts -> Cts -andCts = unionBags - -listToCts :: [Ct] -> Cts -listToCts = listToBag - -ctsElts :: Cts -> [Ct] -ctsElts = bagToList - -consCts :: Ct -> Cts -> Cts -consCts = consBag - -snocCts :: Cts -> Ct -> Cts -snocCts = snocBag - -extendCtsList :: Cts -> [Ct] -> Cts -extendCtsList cts xs | null xs = cts - | otherwise = cts `unionBags` listToBag xs - -andManyCts :: [Cts] -> Cts -andManyCts = unionManyBags - -emptyCts :: Cts -emptyCts = emptyBag - -isEmptyCts :: Cts -> Bool -isEmptyCts = isEmptyBag - -pprCts :: Cts -> SDoc -pprCts cts = vcat (map ppr (bagToList cts)) - -{- -************************************************************************ -* * - Wanted constraints - These are forced to be in TcRnTypes because - TcLclEnv mentions WantedConstraints - WantedConstraint mentions CtLoc - CtLoc mentions ErrCtxt - ErrCtxt mentions TcM -* * -v%************************************************************************ --} - -data WantedConstraints - = WC { wc_simple :: Cts -- Unsolved constraints, all wanted - , wc_impl :: Bag Implication - , wc_insol :: Cts -- Insoluble constraints, can be - -- wanted, given, or derived - -- See Note [Insoluble constraints] - } - -emptyWC :: WantedConstraints -emptyWC = WC { wc_simple = emptyBag, wc_impl = emptyBag, wc_insol = emptyBag } - -mkSimpleWC :: [CtEvidence] -> WantedConstraints -mkSimpleWC cts - = WC { wc_simple = listToBag (map mkNonCanonical cts) - , wc_impl = emptyBag - , wc_insol = emptyBag } - -mkImplicWC :: Bag Implication -> WantedConstraints -mkImplicWC implic - = WC { wc_simple = emptyBag, wc_impl = implic, wc_insol = emptyBag } - -isEmptyWC :: WantedConstraints -> Bool -isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_insol = n }) - = isEmptyBag f && isEmptyBag i && isEmptyBag n - -andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints -andWC (WC { wc_simple = f1, wc_impl = i1, wc_insol = n1 }) - (WC { wc_simple = f2, wc_impl = i2, wc_insol = n2 }) - = WC { wc_simple = f1 `unionBags` f2 - , wc_impl = i1 `unionBags` i2 - , wc_insol = n1 `unionBags` n2 } - -unionsWC :: [WantedConstraints] -> WantedConstraints -unionsWC = foldr andWC emptyWC - -addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints -addSimples wc cts - = wc { wc_simple = wc_simple wc `unionBags` cts } - -- Consider: Put the new constraints at the front, so they get solved first - -addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints -addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } - -addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints -addInsols wc cts - = wc { wc_insol = wc_insol wc `unionBags` cts } - -getInsolubles :: WantedConstraints -> Cts -getInsolubles = wc_insol - -insolublesOnly :: WantedConstraints -> WantedConstraints --- Keep only the insolubles -insolublesOnly (WC { wc_insol = insols, wc_impl = implics }) - = WC { wc_simple = emptyBag - , wc_insol = insols - , wc_impl = mapBag implic_insols_only implics } - where - implic_insols_only implic - = implic { ic_wanted = insolublesOnly (ic_wanted implic) } - -dropDerivedWC :: WantedConstraints -> WantedConstraints --- See Note [Dropping derived constraints] -dropDerivedWC wc@(WC { wc_simple = simples, wc_insol = insols }) - = wc { wc_simple = dropDerivedSimples simples - , wc_insol = dropDerivedInsols insols } - -- The wc_impl implications are already (recursively) filtered - -isSolvedStatus :: ImplicStatus -> Bool -isSolvedStatus (IC_Solved {}) = True -isSolvedStatus _ = False - -isInsolubleStatus :: ImplicStatus -> Bool -isInsolubleStatus IC_Insoluble = True -isInsolubleStatus _ = False - -insolubleImplic :: Implication -> Bool -insolubleImplic ic = isInsolubleStatus (ic_status ic) - -insolubleWC :: WantedConstraints -> Bool -insolubleWC (WC { wc_impl = implics, wc_insol = insols }) - = anyBag trulyInsoluble insols - || anyBag insolubleImplic implics - -trulyInsoluble :: Ct -> Bool --- Constraints in the wc_insol set which ARE NOT --- treated as truly insoluble: --- a) type holes, arising from PartialTypeSignatures, --- b) "true" expression holes arising from TypedHoles --- --- A "expression hole" or "type hole" constraint isn't really an error --- at all; it's a report saying "_ :: Int" here. But an out-of-scope --- variable masquerading as expression holes IS treated as truly --- insoluble, so that it trumps other errors during error reporting. --- Yuk! -trulyInsoluble insol - | isHoleCt insol = isOutOfScopeCt insol - | otherwise = not (isGivenCt insol) -- See Note [Given insolubles] - -instance Outputable WantedConstraints where - ppr (WC {wc_simple = s, wc_impl = i, wc_insol = n}) - = text "WC" <+> braces (vcat - [ ppr_bag (text "wc_simple") s - , ppr_bag (text "wc_insol") n - , ppr_bag (text "wc_impl") i ]) - -ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc -ppr_bag doc bag - | isEmptyBag bag = empty - | otherwise = hang (doc <+> equals) - 2 (foldrBag (($$) . ppr) empty bag) - -{- Note [Given insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #14325, comment:) - class (a~b) => C a b - - foo :: C a b => a -> b - foo x = x - - hm3 :: C (f b) b => b -> f b - hm3 x = foo x - -From the [G] C (f b) b we get the insoluble [G] f b ~# b. Then we we also -get an unsolved [W] C b (f b). If trulyInsouble is true of this, we'll -set cec_suppress to True, and suppress reports of the [W] C b (f b). But we -may not report the insoluble [G] f b ~# b either (see Note [Given errors] -in TcErrors), so we may fail to report anything at all! Yikes. - -Bottom line: we must be certain to report anything trulyInsoluble. Easiest -way to guaranteed this is to make truly Insoluble false of Givens. - - -************************************************************************ -* * - Implication constraints -* * -************************************************************************ --} - -data Implication - = Implic { - ic_tclvl :: TcLevel, -- TcLevel of unification variables - -- allocated /inside/ this implication - - ic_skols :: [TcTyVar], -- Introduced skolems - ic_info :: SkolemInfo, -- See Note [Skolems in an implication] - -- See Note [Shadowing in a constraint] - - ic_given :: [EvVar], -- Given evidence variables - -- (order does not matter) - -- See Invariant (GivenInv) in TcType - - ic_no_eqs :: Bool, -- True <=> ic_givens have no equalities, for sure - -- False <=> ic_givens might have equalities - - ic_env :: TcLclEnv, -- Gives the source location and error context - -- for the implication, and hence for all the - -- given evidence variables - - ic_wanted :: WantedConstraints, -- The wanted - - ic_binds :: EvBindsVar, -- Points to the place to fill in the - -- abstraction and bindings. - - ic_needed :: VarSet, -- Union of the ics_need fields of any /discarded/ - -- solved implications in ic_wanted - - ic_status :: ImplicStatus - } - -data ImplicStatus - = IC_Solved -- All wanteds in the tree are solved, all the way down - { ics_need :: VarSet -- Evidence variables bound further out, - -- but needed by this solved implication - , ics_dead :: [EvVar] } -- Subset of ic_given that are not needed - -- See Note [Tracking redundant constraints] in TcSimplify - - | IC_Insoluble -- At least one insoluble constraint in the tree - - | IC_Unsolved -- Neither of the above; might go either way - -instance Outputable Implication where - ppr (Implic { ic_tclvl = tclvl, ic_skols = skols - , ic_given = given, ic_no_eqs = no_eqs - , ic_wanted = wanted, ic_status = status - , ic_binds = binds, ic_needed = needed , ic_info = info }) - = hang (text "Implic" <+> lbrace) - 2 (sep [ text "TcLevel =" <+> ppr tclvl - , text "Skolems =" <+> pprTyVars skols - , text "No-eqs =" <+> ppr no_eqs - , text "Status =" <+> ppr status - , hang (text "Given =") 2 (pprEvVars given) - , hang (text "Wanted =") 2 (ppr wanted) - , text "Binds =" <+> ppr binds - , text "Needed =" <+> ppr needed - , pprSkolInfo info ] <+> rbrace) - -instance Outputable ImplicStatus where - ppr IC_Insoluble = text "Insoluble" - ppr IC_Unsolved = text "Unsolved" - ppr (IC_Solved { ics_need = vs, ics_dead = dead }) - = text "Solved" - <+> (braces $ vcat [ text "Dead givens =" <+> ppr dead - , text "Needed =" <+> ppr vs ]) - -{- -Note [Needed evidence variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Th ic_need_evs field holds the free vars of ic_binds, and all the -ic_binds in nested implications. - - * Main purpose: if one of the ic_givens is not mentioned in here, it - is redundant. - - * solveImplication may drop an implication altogether if it has no - remaining 'wanteds'. But we still track the free vars of its - evidence binds, even though it has now disappeared. - -Note [Shadowing in a constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We assume NO SHADOWING in a constraint. Specifically - * The unification variables are all implicitly quantified at top - level, and are all unique - * The skolem variables bound in ic_skols are all freah when the - implication is created. -So we can safely substitute. For example, if we have - forall a. a~Int => ...(forall b. ...a...)... -we can push the (a~Int) constraint inwards in the "givens" without -worrying that 'b' might clash. - -Note [Skolems in an implication] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The skolems in an implication are not there to perform a skolem escape -check. That happens because all the environment variables are in the -untouchables, and therefore cannot be unified with anything at all, -let alone the skolems. - -Instead, ic_skols is used only when considering floating a constraint -outside the implication in TcSimplify.floatEqualities or -TcSimplify.approximateImplications - -Note [Insoluble constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some of the errors that we get during canonicalization are best -reported when all constraints have been simplified as much as -possible. For instance, assume that during simplification the -following constraints arise: - - [Wanted] F alpha ~ uf1 - [Wanted] beta ~ uf1 beta - -When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail -we will simply see a message: - 'Can't construct the infinite type beta ~ uf1 beta' -and the user has no idea what the uf1 variable is. - -Instead our plan is that we will NOT fail immediately, but: - (1) Record the "frozen" error in the ic_insols field - (2) Isolate the offending constraint from the rest of the inerts - (3) Keep on simplifying/canonicalizing - -At the end, we will hopefully have substituted uf1 := F alpha, and we -will be able to report a more informative error: - 'Can't construct the infinite type beta ~ F alpha beta' - -Insoluble constraints *do* include Derived constraints. For example, -a functional dependency might give rise to [D] Int ~ Bool, and we must -report that. If insolubles did not contain Deriveds, reportErrors would -never see it. - - -************************************************************************ -* * - Pretty printing -* * -************************************************************************ --} - -pprEvVars :: [EvVar] -> SDoc -- Print with their types -pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) - -pprEvVarTheta :: [EvVar] -> SDoc -pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) - -pprEvVarWithType :: EvVar -> SDoc -pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) - -{- -************************************************************************ -* * - CtEvidence -* * -************************************************************************ - -Note [Evidence field of CtEvidence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During constraint solving we never look at the type of ctev_evar/ctev_dest; -instead we look at the ctev_pred field. The evtm/evar field -may be un-zonked. - -Note [Bind new Givens immediately] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For Givens we make new EvVars and bind them immediately. Two main reasons: - * Gain sharing. E.g. suppose we start with g :: C a b, where - class D a => C a b - class (E a, F a) => D a - If we generate all g's superclasses as separate EvTerms we might - get selD1 (selC1 g) :: E a - selD2 (selC1 g) :: F a - selC1 g :: D a - which we could do more economically as: - g1 :: D a = selC1 g - g2 :: E a = selD1 g1 - g3 :: F a = selD2 g1 - - * For *coercion* evidence we *must* bind each given: - class (a~b) => C a b where .... - f :: C a b => .... - Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. - But that superclass selector can't (yet) appear in a coercion - (see evTermCoercion), so the easy thing is to bind it to an Id. - -So a Given has EvVar inside it rather than (as previously) an EvTerm. - -Note [Given in ctEvCoercion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When retrieving the evidence from a Given equality, we update the type of the EvVar -from the ctev_pred field. In Note [Evidence field of CtEvidence], we claim that -the type of the evidence is never looked at -- but this isn't true in the case of -a coercion that is used in a type. (See the comments in Note [Flattening] in TcFlatten -about the FTRNotFollowed case of flattenTyVar.) So, right here where we are retrieving -the coercion from a Given, we update the type to make sure it's zonked. - --} - --- | A place for type-checking evidence to go after it is generated. --- Wanted equalities are always HoleDest; other wanteds are always --- EvVarDest. -data TcEvDest - = EvVarDest EvVar -- ^ bind this var to the evidence - -- EvVarDest is always used for non-type-equalities - -- e.g. class constraints - - | HoleDest CoercionHole -- ^ fill in this hole with the evidence - -- HoleDest is always used for type-equalities - -- See Note [Coercion holes] in TyCoRep - -data CtEvidence - = CtGiven -- Truly given, not depending on subgoals - { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] - , ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence] - , ctev_loc :: CtLoc } - - - | CtWanted -- Wanted goal - { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] - , ctev_dest :: TcEvDest - , ctev_nosh :: ShadowInfo -- See Note [Constraint flavours] - , ctev_loc :: CtLoc } - - | CtDerived -- A goal that we don't really have to solve and can't - -- immediately rewrite anything other than a derived - -- (there's no evidence!) but if we do manage to solve - -- it may help in solving other goals. - { ctev_pred :: TcPredType - , ctev_loc :: CtLoc } - -ctEvPred :: CtEvidence -> TcPredType --- The predicate of a flavor -ctEvPred = ctev_pred - -ctEvLoc :: CtEvidence -> CtLoc -ctEvLoc = ctev_loc - -ctEvOrigin :: CtEvidence -> CtOrigin -ctEvOrigin = ctLocOrigin . ctEvLoc - --- | Get the equality relation relevant for a 'CtEvidence' -ctEvEqRel :: CtEvidence -> EqRel -ctEvEqRel = predTypeEqRel . ctEvPred - --- | Get the role relevant for a 'CtEvidence' -ctEvRole :: CtEvidence -> Role -ctEvRole = eqRelRole . ctEvEqRel - -ctEvTerm :: CtEvidence -> EvTerm -ctEvTerm ev@(CtWanted { ctev_dest = HoleDest _ }) = EvCoercion $ ctEvCoercion ev -ctEvTerm ev = EvId (ctEvId ev) - --- Always returns a coercion whose type is precisely ctev_pred of the CtEvidence. --- See also Note [Given in ctEvCoercion] -ctEvCoercion :: CtEvidence -> Coercion -ctEvCoercion (CtGiven { ctev_pred = pred_ty, ctev_evar = ev_id }) - = mkTcCoVarCo (setVarType ev_id pred_ty) -- See Note [Given in ctEvCoercion] -ctEvCoercion (CtWanted { ctev_dest = dest, ctev_pred = pred }) - | HoleDest hole <- dest - , Just (role, ty1, ty2) <- getEqPredTys_maybe pred - = -- ctEvCoercion is only called on type equalities - -- and they always have HoleDests - mkHoleCo hole role ty1 ty2 -ctEvCoercion ev - = pprPanic "ctEvCoercion" (ppr ev) - -ctEvId :: CtEvidence -> TcId -ctEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev -ctEvId (CtGiven { ctev_evar = ev }) = ev -ctEvId ctev = pprPanic "ctEvId:" (ppr ctev) - -instance Outputable TcEvDest where - ppr (HoleDest h) = text "hole" <> ppr h - ppr (EvVarDest ev) = ppr ev - -instance Outputable CtEvidence where - ppr ev = ppr (ctEvFlavour ev) - <+> pp_ev - <+> braces (ppr (ctl_depth (ctEvLoc ev))) <> dcolon - -- Show the sub-goal depth too - <+> ppr (ctEvPred ev) - where - pp_ev = case ev of - CtGiven { ctev_evar = v } -> ppr v - CtWanted {ctev_dest = d } -> ppr d - CtDerived {} -> text "_" - -isWanted :: CtEvidence -> Bool -isWanted (CtWanted {}) = True -isWanted _ = False - -isGiven :: CtEvidence -> Bool -isGiven (CtGiven {}) = True -isGiven _ = False - -isDerived :: CtEvidence -> Bool -isDerived (CtDerived {}) = True -isDerived _ = False - -{- -%************************************************************************ -%* * - CtFlavour -%* * -%************************************************************************ - -Note [Constraint flavours] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Constraints come in four flavours: - -* [G] Given: we have evidence - -* [W] Wanted WOnly: we want evidence - -* [D] Derived: any solution must satisfy this constraint, but - we don't need evidence for it. Examples include: - - superclasses of [W] class constraints - - equalities arising from functional dependencies - or injectivity - -* [WD] Wanted WDeriv: a single constraint that represents - both [W] and [D] - We keep them paired as one both for efficiency, and because - when we have a finite map F tys -> CFunEqCan, it's inconvenient - to have two CFunEqCans in the range - -The ctev_nosh field of a Wanted distinguishes between [W] and [WD] - -Wanted constraints are born as [WD], but are split into [W] and its -"shadow" [D] in TcSMonad.maybeEmitShadow. - -See Note [The improvement story and derived shadows] in TcSMonad --} - -data CtFlavour -- See Note [Constraint flavours] - = Given - | Wanted ShadowInfo - | Derived - deriving Eq - -data ShadowInfo - = WDeriv -- [WD] This Wanted constraint has no Derived shadow, - -- so it behaves like a pair of a Wanted and a Derived - | WOnly -- [W] It has a separate derived shadow - -- See Note [Derived shadows] - deriving( Eq ) - -isGivenOrWDeriv :: CtFlavour -> Bool -isGivenOrWDeriv Given = True -isGivenOrWDeriv (Wanted WDeriv) = True -isGivenOrWDeriv _ = False - -instance Outputable CtFlavour where - ppr Given = text "[G]" - ppr (Wanted WDeriv) = text "[WD]" - ppr (Wanted WOnly) = text "[W]" - ppr Derived = text "[D]" - -ctEvFlavour :: CtEvidence -> CtFlavour -ctEvFlavour (CtWanted { ctev_nosh = nosh }) = Wanted nosh -ctEvFlavour (CtGiven {}) = Given -ctEvFlavour (CtDerived {}) = Derived - --- | Whether or not one 'Ct' can rewrite another is determined by its --- flavour and its equality relation. See also --- Note [Flavours with roles] in TcSMonad -type CtFlavourRole = (CtFlavour, EqRel) - --- | Extract the flavour, role, and boxity from a 'CtEvidence' -ctEvFlavourRole :: CtEvidence -> CtFlavourRole -ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev) - --- | Extract the flavour, role, and boxity from a 'Ct' -ctFlavourRole :: Ct -> CtFlavourRole -ctFlavourRole = ctEvFlavourRole . cc_ev - -{- Note [eqCanRewrite] -~~~~~~~~~~~~~~~~~~~~~~ -(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form -tv ~ ty) can be used to rewrite ct2. It must satisfy the properties of -a can-rewrite relation, see Definition [Can-rewrite relation] in -TcSMonad. - -With the solver handling Coercible constraints like equality constraints, -the rewrite conditions must take role into account, never allowing -a representational equality to rewrite a nominal one. - -Note [Wanteds do not rewrite Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't allow Wanteds to rewrite Wanteds, because that can give rise -to very confusing type error messages. A good example is Trac #8450. -Here's another - f :: a -> Bool - f x = ( [x,'c'], [x,True] ) `seq` True -Here we get - [W] a ~ Char - [W] a ~ Bool -but we do not want to complain about Bool ~ Char! - -Note [Deriveds do rewrite Deriveds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -However we DO allow Deriveds to rewrite Deriveds, because that's how -improvement works; see Note [The improvement story] in TcInteract. - -However, for now at least I'm only letting (Derived,NomEq) rewrite -(Derived,NomEq) and not doing anything for ReprEq. If we have - eqCanRewriteFR (Derived, NomEq) (Derived, _) = True -then we lose property R2 of Definition [Can-rewrite relation] -in TcSMonad - R2. If f1 >= f, and f2 >= f, - then either f1 >= f2 or f2 >= f1 -Consider f1 = (Given, ReprEq) - f2 = (Derived, NomEq) - f = (Derived, ReprEq) - -I thought maybe we could never get Derived ReprEq constraints, but -we can; straight from the Wanteds during improvement. And from a Derived -ReprEq we could conceivably get a Derived NomEq improvement (by decomposing -a type constructor with Nomninal role), and hence unify. --} - -eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool --- Can fr1 actually rewrite fr2? --- Very important function! --- See Note [eqCanRewrite] --- See Note [Wanteds do not rewrite Wanteds] --- See Note [Deriveds do rewrite Deriveds] -eqCanRewriteFR (Given, NomEq) (_, _) = True -eqCanRewriteFR (Given, ReprEq) (_, ReprEq) = True -eqCanRewriteFR (Wanted WDeriv, NomEq) (Derived, NomEq) = True -eqCanRewriteFR (Derived, NomEq) (Derived, NomEq) = True -eqCanRewriteFR _ _ = False - -eqMayRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool --- Is it /possible/ that fr1 can rewrite fr2? --- This is used when deciding which inerts to kick out, --- at which time a [WD] inert may be split into [W] and [D] -eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True -eqMayRewriteFR (Derived, NomEq) (Wanted WDeriv, NomEq) = True -eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2 - ------------------ -{- Note [funEqCanDischarge] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have two CFunEqCans with the same LHS: - (x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2) -Can we drop x2 in favour of x1, either unifying -f2 (if it's a flatten meta-var) or adding a new Given -(f1 ~ f2), if x2 is a Given? - -Answer: yes if funEqCanDischarge is true. --} - -funEqCanDischarge - :: CtEvidence -> CtEvidence - -> ( SwapFlag -- NotSwapped => lhs can discharge rhs - -- Swapped => rhs can discharge lhs - , Bool) -- True <=> upgrade non-discharded one - -- from [W] to [WD] --- See Note [funEqCanDischarge] -funEqCanDischarge ev1 ev2 - = ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 ) - ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 ) - -- CFunEqCans are all Nominal, hence asserts - funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2) - -funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool) -funEqCanDischargeF Given _ = (NotSwapped, False) -funEqCanDischargeF _ Given = (IsSwapped, False) -funEqCanDischargeF (Wanted WDeriv) _ = (NotSwapped, False) -funEqCanDischargeF _ (Wanted WDeriv) = (IsSwapped, True) -funEqCanDischargeF (Wanted WOnly) (Wanted WOnly) = (NotSwapped, False) -funEqCanDischargeF (Wanted WOnly) Derived = (NotSwapped, True) -funEqCanDischargeF Derived (Wanted WOnly) = (IsSwapped, True) -funEqCanDischargeF Derived Derived = (NotSwapped, False) - - -{- Note [eqCanDischarge] -~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have two identical CTyEqCan equality constraints -(i.e. both LHS and RHS are the same) - (x1:a~t) `eqCanDischarge` (xs:a~t) -Can we just drop x2 in favour of x1? - -Answer: yes if eqCanDischarge is true. - -Note that we do /not/ allow Wanted to discharge Derived. -We must keep both. Why? Because the Derived may rewrite -other Deriveds in the model whereas the Wanted cannot. - -However a Wanted can certainly discharge an identical Wanted. So -eqCanDischarge does /not/ define a can-rewrite relation in the -sense of Definition [Can-rewrite relation] in TcSMonad. - -We /do/ say that a [W] can discharge a [WD]. In evidence terms it -certainly can, and the /caller/ arranges that the otherwise-lost [D] -is spat out as a new Derived. -} - -eqCanDischarge :: CtEvidence -> CtEvidence -> Bool --- See Note [eqCanDischarge] -eqCanDischarge ev1 ev2 = eqCanDischargeFR (ctEvFlavourRole ev1) - (ctEvFlavourRole ev2) - -eqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool -eqCanDischargeFR (_, ReprEq) (_, NomEq) = False -eqCanDischargeFR (f1,_) (f2, _) = eqCanDischargeF f1 f2 - -eqCanDischargeF :: CtFlavour -> CtFlavour -> Bool -eqCanDischargeF Given _ = True -eqCanDischargeF (Wanted _) (Wanted _) = True -eqCanDischargeF (Wanted WDeriv) Derived = True -eqCanDischargeF Derived Derived = True -eqCanDischargeF _ _ = False - - -{- -************************************************************************ -* * - SubGoalDepth -* * -************************************************************************ - -Note [SubGoalDepth] -~~~~~~~~~~~~~~~~~~~ -The 'SubGoalDepth' takes care of stopping the constraint solver from looping. - -The counter starts at zero and increases. It includes dictionary constraints, -equality simplification, and type family reduction. (Why combine these? Because -it's actually quite easy to mistake one for another, in sufficiently involved -scenarios, like ConstraintKinds.) - -The flag -fcontext-stack=n (not very well named!) fixes the maximium -level. - -* The counter includes the depth of type class instance declarations. Example: - [W] d{7} : Eq [Int] - That is d's dictionary-constraint depth is 7. If we use the instance - $dfEqList :: Eq a => Eq [a] - to simplify it, we get - d{7} = $dfEqList d'{8} - where d'{8} : Eq Int, and d' has depth 8. - - For civilised (decidable) instance declarations, each increase of - depth removes a type constructor from the type, so the depth never - gets big; i.e. is bounded by the structural depth of the type. - -* The counter also increments when resolving -equalities involving type functions. Example: - Assume we have a wanted at depth 7: - [W] d{7} : F () ~ a - If there is an type function equation "F () = Int", this would be rewritten to - [W] d{8} : Int ~ a - and remembered as having depth 8. - - Again, without UndecidableInstances, this counter is bounded, but without it - can resolve things ad infinitum. Hence there is a maximum level. - -* Lastly, every time an equality is rewritten, the counter increases. Again, - rewriting an equality constraint normally makes progress, but it's possible - the "progress" is just the reduction of an infinitely-reducing type family. - Hence we need to track the rewrites. - -When compiling a program requires a greater depth, then GHC recommends turning -off this check entirely by setting -freduction-depth=0. This is because the -exact number that works is highly variable, and is likely to change even between -minor releases. Because this check is solely to prevent infinite compilation -times, it seems safe to disable it when a user has ascertained that their program -doesn't loop at the type level. - --} - --- | See Note [SubGoalDepth] -newtype SubGoalDepth = SubGoalDepth Int - deriving (Eq, Ord, Outputable) - -initialSubGoalDepth :: SubGoalDepth -initialSubGoalDepth = SubGoalDepth 0 - -bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth -bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1) - -maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth -maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m) - -subGoalDepthExceeded :: DynFlags -> SubGoalDepth -> Bool -subGoalDepthExceeded dflags (SubGoalDepth d) - = mkIntWithInf d > reductionDepth dflags - -{- -************************************************************************ -* * - CtLoc -* * -************************************************************************ - -The 'CtLoc' gives information about where a constraint came from. -This is important for decent error message reporting because -dictionaries don't appear in the original source code. -type will evolve... --} - -data CtLoc = CtLoc { ctl_origin :: CtOrigin - , ctl_env :: TcLclEnv - , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure - , ctl_depth :: !SubGoalDepth } - -- The TcLclEnv includes particularly - -- source location: tcl_loc :: RealSrcSpan - -- context: tcl_ctxt :: [ErrCtxt] - -- binder stack: tcl_bndrs :: TcIdBinderStack - -- level: tcl_tclvl :: TcLevel - -mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc -mkGivenLoc tclvl skol_info env - = CtLoc { ctl_origin = GivenOrigin skol_info - , ctl_env = env { tcl_tclvl = tclvl } - , ctl_t_or_k = Nothing -- this only matters for error msgs - , ctl_depth = initialSubGoalDepth } - -mkKindLoc :: TcType -> TcType -- original *types* being compared - -> CtLoc -> CtLoc -mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc) - (KindEqOrigin s1 (Just s2) (ctLocOrigin loc) - (ctLocTypeOrKind_maybe loc)) - --- | Take a CtLoc and moves it to the kind level -toKindLoc :: CtLoc -> CtLoc -toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } - -ctLocEnv :: CtLoc -> TcLclEnv -ctLocEnv = ctl_env - -ctLocLevel :: CtLoc -> TcLevel -ctLocLevel loc = tcl_tclvl (ctLocEnv loc) - -ctLocDepth :: CtLoc -> SubGoalDepth -ctLocDepth = ctl_depth - -ctLocOrigin :: CtLoc -> CtOrigin -ctLocOrigin = ctl_origin - -ctLocSpan :: CtLoc -> RealSrcSpan -ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl - -ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind -ctLocTypeOrKind_maybe = ctl_t_or_k - -setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc -setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (lcl { tcl_loc = loc }) - -bumpCtLocDepth :: CtLoc -> CtLoc -bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d } - -setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc -setCtLocOrigin ctl orig = ctl { ctl_origin = orig } - -setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc -setCtLocEnv ctl env = ctl { ctl_env = env } - -pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc -pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) - = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } - -pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc --- Just add information w/o updating the origin! -pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) - = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } - -{- -************************************************************************ -* * - SkolemInfo -* * -************************************************************************ --} - --- SkolemInfo gives the origin of *given* constraints --- a) type variables are skolemised --- b) an implication constraint is generated -data SkolemInfo - = SigSkol -- A skolem that is created by instantiating - -- a programmer-supplied type signature - -- Location of the binding site is on the TyVar - -- See Note [SigSkol SkolemInfo] - UserTypeCtxt -- What sort of signature - TcType -- Original type signature (before skolemisation) - [(Name,TcTyVar)] -- Maps the original name of the skolemised tyvar - -- to its instantiated version - - | ClsSkol Class -- Bound at a class decl - - | DerivSkol Type -- Bound by a 'deriving' clause; - -- the type is the instance we are trying to derive - - | InstSkol -- Bound at an instance decl - | InstSC TypeSize -- A "given" constraint obtained by superclass selection. - -- If (C ty1 .. tyn) is the largest class from - -- which we made a superclass selection in the chain, - -- then TypeSize = sizeTypes [ty1, .., tyn] - -- See Note [Solving superclass constraints] in TcInstDcls - - | DataSkol -- Bound at a data type declaration - | FamInstSkol -- Bound at a family instance decl - | PatSkol -- An existential type variable bound by a pattern for - ConLike -- a data constructor with an existential type. - (HsMatchContext Name) - -- e.g. data T = forall a. Eq a => MkT a - -- f (MkT x) = ... - -- The pattern MkT x will allocate an existential type - -- variable for 'a'. - - | ArrowSkol -- An arrow form (see TcArrows) - - | IPSkol [HsIPName] -- Binding site of an implicit parameter - - | RuleSkol RuleName -- The LHS of a RULE - - | InferSkol [(Name,TcType)] - -- We have inferred a type for these (mutually-recursivive) - -- polymorphic Ids, and are now checking that their RHS - -- constraints are satisfied. - - | BracketSkol -- Template Haskell bracket - - | UnifyForAllSkol -- We are unifying two for-all types - TcType -- The instantiated type *inside* the forall - - | UnkSkol -- Unhelpful info (until I improve it) - -instance Outputable SkolemInfo where - ppr = pprSkolInfo - -termEvidenceAllowed :: SkolemInfo -> Bool --- Whether an implication constraint with this SkolemInfo --- is permitted to have term-level evidence. There is --- only one that is not, associated with unifiying --- forall-types -termEvidenceAllowed (UnifyForAllSkol {}) = False -termEvidenceAllowed _ = True - -pprSkolInfo :: SkolemInfo -> SDoc --- Complete the sentence "is a rigid type variable bound by..." -pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty -pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" - <+> pprWithCommas ppr ips -pprSkolInfo (ClsSkol cls) = text "the class declaration for" <+> quotes (ppr cls) -pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) -pprSkolInfo InstSkol = text "the instance declaration" -pprSkolInfo (InstSC n) = text "the instance declaration" <> ifPprDebug (parens (ppr n)) -pprSkolInfo DataSkol = text "a data type declaration" -pprSkolInfo FamInstSkol = text "a family instance declaration" -pprSkolInfo BracketSkol = text "a Template Haskell bracket" -pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name -pprSkolInfo ArrowSkol = text "an arrow form" -pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl - , text "in" <+> pprMatchContext mc ] -pprSkolInfo (InferSkol ids) = sep [ text "the inferred type of" - , vcat [ ppr name <+> dcolon <+> ppr ty - | (name,ty) <- ids ]] -pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty - --- UnkSkol --- For type variables the others are dealt with by pprSkolTvBinding. --- For Insts, these cases should not happen -pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol" - -pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc --- The type is already tidied -pprSigSkolInfo ctxt ty - = case ctxt of - FunSigCtxt f _ -> vcat [ text "the type signature for:" - , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ] - PatSynCtxt {} -> pprUserTypeCtxt ctxt -- See Note [Skolem info for pattern synonyms] - _ -> vcat [ pprUserTypeCtxt ctxt <> colon - , nest 2 (ppr ty) ] - -pprPatSkolInfo :: ConLike -> SDoc -pprPatSkolInfo (RealDataCon dc) - = sep [ text "a pattern with constructor:" - , nest 2 $ ppr dc <+> dcolon - <+> pprType (dataConUserType dc) <> comma ] - -- pprType prints forall's regardless of -fprint-explicit-foralls - -- which is what we want here, since we might be saying - -- type variable 't' is bound by ... - -pprPatSkolInfo (PatSynCon ps) - = sep [ text "a pattern with pattern synonym:" - , nest 2 $ ppr ps <+> dcolon - <+> pprPatSynType ps <> comma ] - -{- Note [Skolem info for pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For pattern synonym SkolemInfo we have - SigSkol (PatSynCtxt p) ty _ -but the type 'ty' is not very helpful. The full pattern-synonym type -has the provided and required pieces, which it is inconvenient to -record and display here. So we simply don't display the type at all, -contenting outselves with just the name of the pattern synonym, which -is fine. We could do more, but it doesn't seem worth it. - -Note [SigSkol SkolemInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we (deeply) skolemise a type - f :: forall a. a -> forall b. b -> a -Then we'll instantiate [a :-> a', b :-> b'], and with the instantiated - a' -> b' -> a. -But when, in an error message, we report that "b is a rigid type -variable bound by the type signature for f", we want to show the foralls -in the right place. So we proceed as follows: - -* In SigSkol we record - - the original signature forall a. a -> forall b. b -> a - - the instantiation mapping [a :-> a', b :-> b'] - -* Then when tidying in TcMType.tidySkolemInfo, we first tidy a' to - whatever it tidies to, say a''; and then we walk over the type - replacing the binder a by the tidied version a'', to give - forall a''. a'' -> forall b''. b'' -> a'' - We need to do this under function arrows, to match what deeplySkolemise - does. - -* Typically a'' will have a nice pretty name like "a", but the point is - that the foral-bound variables of the signature we report line up with - the instantiated skolems lying around in other types. - - -************************************************************************ -* * - CtOrigin -* * -************************************************************************ --} - -data CtOrigin - = GivenOrigin SkolemInfo - - -- All the others are for *wanted* constraints - | OccurrenceOf Name -- Occurrence of an overloaded identifier - | OccurrenceOfRecSel RdrName -- Occurrence of a record selector - | AppOrigin -- An application of some kind - - | SpecPragOrigin UserTypeCtxt -- Specialisation pragma for - -- function or instance - - | TypeEqOrigin { uo_actual :: TcType - , uo_expected :: TcType - , uo_thing :: Maybe ErrorThing - -- ^ The thing that has type "actual" - } - - | KindEqOrigin - TcType (Maybe TcType) -- A kind equality arising from unifying these two types - CtOrigin -- originally arising from this - (Maybe TypeOrKind) -- the level of the eq this arises from - - | IPOccOrigin HsIPName -- Occurrence of an implicit parameter - | OverLabelOrigin FastString -- Occurrence of an overloaded label - - | LiteralOrigin (HsOverLit Name) -- Occurrence of a literal - | NegateOrigin -- Occurrence of syntactic negation - - | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc - | PArrSeqOrigin (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:] - | SectionOrigin - | TupleOrigin -- (..,..) - | ExprSigOrigin -- e :: ty - | PatSigOrigin -- p :: ty - | PatOrigin -- Instantiating a polytyped pattern at a constructor - | ProvCtxtOrigin -- The "provided" context of a pattern synonym signature - (PatSynBind Name Name) -- Information about the pattern synonym, in particular - -- the name and the right-hand side - | RecordUpdOrigin - | ViewPatOrigin - - | ScOrigin TypeSize -- Typechecking superclasses of an instance declaration - -- If the instance head is C ty1 .. tyn - -- then TypeSize = sizeTypes [ty1, .., tyn] - -- See Note [Solving superclass constraints] in TcInstDcls - - | DerivOrigin -- Typechecking deriving - | DerivOriginDC DataCon Int - -- Checking constraints arising from this data con and field index - | DerivOriginCoerce Id Type Type - -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from - -- `ty1` to `ty2`. - | StandAloneDerivOrigin -- Typechecking stand-alone deriving - | DefaultOrigin -- Typechecking a default decl - | DoOrigin -- Arising from a do expression - | DoPatOrigin (LPat Name) -- Arising from a failable pattern in - -- a do expression - | MCompOrigin -- Arising from a monad comprehension - | MCompPatOrigin (LPat Name) -- Arising from a failable pattern in a - -- monad comprehension - | IfOrigin -- Arising from an if statement - | ProcOrigin -- Arising from a proc expression - | AnnOrigin -- An annotation - - | FunDepOrigin1 -- A functional dependency from combining - PredType CtLoc -- This constraint arising from ... - PredType CtLoc -- and this constraint arising from ... - - | FunDepOrigin2 -- A functional dependency from combining - PredType CtOrigin -- This constraint arising from ... - PredType SrcSpan -- and this top-level instance - -- We only need a CtOrigin on the first, because the location - -- is pinned on the entire error message - - | HoleOrigin - | UnboundOccurrenceOf OccName - | ListOrigin -- An overloaded list - | StaticOrigin -- A static form - | FailablePattern (LPat TcId) -- A failable pattern in do-notation for the - -- MonadFail Proposal (MFP). Obsolete when - -- actual desugaring to MonadFail.fail is live. - | Shouldn'tHappenOrigin String - -- the user should never see this one, - -- unless ImpredicativeTypes is on, where all - -- bets are off - | InstProvidedOrigin Module ClsInst - -- Skolem variable arose when we were testing if an instance - -- is solvable or not. - --- | A thing that can be stored for error message generation only. --- It is stored with a function to zonk and tidy the thing. -data ErrorThing - = forall a. Outputable a => ErrorThing a - (Maybe Arity) -- # of args, if known - (TidyEnv -> a -> TcM (TidyEnv, a)) - --- | Flag to see whether we're type-checking terms or kind-checking types -data TypeOrKind = TypeLevel | KindLevel - deriving Eq - -instance Outputable TypeOrKind where - ppr TypeLevel = text "TypeLevel" - ppr KindLevel = text "KindLevel" - -isTypeLevel :: TypeOrKind -> Bool -isTypeLevel TypeLevel = True -isTypeLevel KindLevel = False - -isKindLevel :: TypeOrKind -> Bool -isKindLevel TypeLevel = False -isKindLevel KindLevel = True - --- | Make an 'ErrorThing' that doesn't need tidying or zonking -mkErrorThing :: Outputable a => a -> ErrorThing -mkErrorThing thing = ErrorThing thing Nothing (\env x -> return (env, x)) - --- | Retrieve the # of arguments in the error thing, if known -errorThingNumArgs_maybe :: ErrorThing -> Maybe Arity -errorThingNumArgs_maybe (ErrorThing _ args _) = args - -instance Outputable CtOrigin where - ppr = pprCtOrigin - -instance Outputable ErrorThing where - ppr (ErrorThing thing _ _) = ppr thing - -ctoHerald :: SDoc -ctoHerald = text "arising from" - --- | Extract a suitable CtOrigin from a HsExpr -lexprCtOrigin :: LHsExpr Name -> CtOrigin -lexprCtOrigin (L _ e) = exprCtOrigin e - -exprCtOrigin :: HsExpr Name -> CtOrigin -exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name -exprCtOrigin (HsUnboundVar uv) = UnboundOccurrenceOf (unboundVarOcc uv) -exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" -exprCtOrigin (HsRecFld f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) -exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l -exprCtOrigin (HsIPVar ip) = IPOccOrigin ip -exprCtOrigin (HsOverLit lit) = LiteralOrigin lit -exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" -exprCtOrigin (HsLam matches) = matchesCtOrigin matches -exprCtOrigin (HsLamCase ms) = matchesCtOrigin ms -exprCtOrigin (HsApp e1 _) = lexprCtOrigin e1 -exprCtOrigin (HsAppType e1 _) = lexprCtOrigin e1 -exprCtOrigin (HsAppTypeOut {}) = panic "exprCtOrigin HsAppTypeOut" -exprCtOrigin (OpApp _ op _ _) = lexprCtOrigin op -exprCtOrigin (NegApp e _) = lexprCtOrigin e -exprCtOrigin (HsPar e) = lexprCtOrigin e -exprCtOrigin (SectionL _ _) = SectionOrigin -exprCtOrigin (SectionR _ _) = SectionOrigin -exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" -exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" -exprCtOrigin (HsCase _ matches) = matchesCtOrigin matches -exprCtOrigin (HsIf (Just syn) _ _ _) = exprCtOrigin (syn_expr syn) -exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" -exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs -exprCtOrigin (HsLet _ e) = lexprCtOrigin e -exprCtOrigin (HsDo _ _ _) = DoOrigin -exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list" -exprCtOrigin (ExplicitPArr {}) = Shouldn'tHappenOrigin "parallel array" -exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" -exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" -exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin -exprCtOrigin (ExprWithTySigOut {}) = panic "exprCtOrigin ExprWithTySigOut" -exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" -exprCtOrigin (PArrSeq {}) = Shouldn'tHappenOrigin "parallel array sequence" -exprCtOrigin (HsSCC _ _ e) = lexprCtOrigin e -exprCtOrigin (HsCoreAnn _ _ e) = lexprCtOrigin e -exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" -exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut" -exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut" -exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" -exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" -exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" -exprCtOrigin (HsArrApp {}) = panic "exprCtOrigin HsArrApp" -exprCtOrigin (HsArrForm {}) = panic "exprCtOrigin HsArrForm" -exprCtOrigin (HsTick _ e) = lexprCtOrigin e -exprCtOrigin (HsBinTick _ _ e) = lexprCtOrigin e -exprCtOrigin (HsTickPragma _ _ _ e) = lexprCtOrigin e -exprCtOrigin EWildPat = panic "exprCtOrigin EWildPat" -exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat" -exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat" -exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat" -exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" - --- | Extract a suitable CtOrigin from a MatchGroup -matchesCtOrigin :: MatchGroup Name (LHsExpr Name) -> CtOrigin -matchesCtOrigin (MG { mg_alts = alts }) - | L _ [L _ match] <- alts - , Match { m_grhss = grhss } <- match - = grhssCtOrigin grhss - - | otherwise - = Shouldn'tHappenOrigin "multi-way match" - --- | Extract a suitable CtOrigin from guarded RHSs -grhssCtOrigin :: GRHSs Name (LHsExpr Name) -> CtOrigin -grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss - --- | Extract a suitable CtOrigin from a list of guarded RHSs -lGRHSCtOrigin :: [LGRHS Name (LHsExpr Name)] -> CtOrigin -lGRHSCtOrigin [L _ (GRHS _ (L _ e))] = exprCtOrigin e -lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" - -pprCtLoc :: CtLoc -> SDoc --- "arising from ... at ..." --- Not an instance of Outputable because of the "arising from" prefix -pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl}) - = sep [ pprCtOrigin o - , text "at" <+> ppr (tcl_loc lcl)] - -pprCtOrigin :: CtOrigin -> SDoc --- "arising from ..." --- Not an instance of Outputable because of the "arising from" prefix -pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk - -pprCtOrigin (SpecPragOrigin ctxt) - = case ctxt of - FunSigCtxt n _ -> text "a SPECIALISE pragma for" <+> quotes (ppr n) - SpecInstCtxt -> text "a SPECIALISE INSTANCE pragma" - _ -> text "a SPECIALISE pragma" -- Never happens I think - -pprCtOrigin (FunDepOrigin1 pred1 loc1 pred2 loc2) - = hang (ctoHerald <+> text "a functional dependency between constraints:") - 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtLoc loc1) - , hang (quotes (ppr pred2)) 2 (pprCtLoc loc2) ]) - -pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) - = hang (ctoHerald <+> text "a functional dependency between:") - 2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1)) - 2 (pprCtOrigin orig1 ) - , hang (text "instance" <+> quotes (ppr pred2)) - 2 (text "at" <+> ppr loc2) ]) - -pprCtOrigin (KindEqOrigin t1 (Just t2) _ _) - = hang (ctoHerald <+> text "a kind equality arising from") - 2 (sep [ppr t1, char '~', ppr t2]) - -pprCtOrigin (KindEqOrigin t1 Nothing _ _) - = hang (ctoHerald <+> text "a kind equality when matching") - 2 (ppr t1) - -pprCtOrigin (UnboundOccurrenceOf name) - = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name) - -pprCtOrigin (DerivOriginDC dc n) - = hang (ctoHerald <+> text "the" <+> speakNth n - <+> text "field of" <+> quotes (ppr dc)) - 2 (parens (text "type" <+> quotes (ppr ty))) - where - ty = dataConOrigArgTys dc !! (n-1) - -pprCtOrigin (DerivOriginCoerce meth ty1 ty2) - = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth)) - 2 (sep [ text "from type" <+> quotes (ppr ty1) - , nest 2 $ text "to type" <+> quotes (ppr ty2) ]) - -pprCtOrigin (DoPatOrigin pat) - = ctoHerald <+> text "a do statement" - $$ - text "with the failable pattern" <+> quotes (ppr pat) - -pprCtOrigin (MCompPatOrigin pat) - = ctoHerald <+> hsep [ text "the failable pattern" - , quotes (ppr pat) - , text "in a statement in a monad comprehension" ] -pprCtOrigin (FailablePattern pat) - = ctoHerald <+> text "the failable pattern" <+> quotes (ppr pat) - $$ - text "(this will become an error in a future GHC release)" - -pprCtOrigin (Shouldn'tHappenOrigin note) - = sdocWithDynFlags $ \dflags -> - if xopt LangExt.ImpredicativeTypes dflags - then text "a situation created by impredicative types" - else - vcat [ text "<< This should not appear in error messages. If you see this" - , text "in an error message, please report a bug mentioning" <+> quotes (text note) <+> text "at" - , text "https://ghc.haskell.org/trac/ghc/wiki/ReportABug >>" ] - -pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) - = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") - 2 (text "the signature of" <+> quotes (ppr name)) - -pprCtOrigin (InstProvidedOrigin mod cls_inst) - = vcat [ text "arising when attempting to show that" - , ppr cls_inst - , text "is provided by" <+> quotes (ppr mod)] - -pprCtOrigin simple_origin - = ctoHerald <+> pprCtO simple_origin - --- | Short one-liners -pprCtO :: CtOrigin -> SDoc -pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] -pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] -pprCtO AppOrigin = text "an application" -pprCtO (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] -pprCtO (OverLabelOrigin l) = hsep [text "the overloaded label" - ,quotes (char '#' <> ppr l)] -pprCtO RecordUpdOrigin = text "a record update" -pprCtO ExprSigOrigin = text "an expression type signature" -pprCtO PatSigOrigin = text "a pattern type signature" -pprCtO PatOrigin = text "a pattern" -pprCtO ViewPatOrigin = text "a view pattern" -pprCtO IfOrigin = text "an if expression" -pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] -pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] -pprCtO (PArrSeqOrigin seq) = hsep [text "the parallel array sequence", quotes (ppr seq)] -pprCtO SectionOrigin = text "an operator section" -pprCtO TupleOrigin = text "a tuple" -pprCtO NegateOrigin = text "a use of syntactic negation" -pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" - <> ifPprDebug (parens (ppr n)) -pprCtO DerivOrigin = text "the 'deriving' clause of a data type declaration" -pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" -pprCtO DefaultOrigin = text "a 'default' declaration" -pprCtO DoOrigin = text "a do statement" -pprCtO MCompOrigin = text "a statement in a monad comprehension" -pprCtO ProcOrigin = text "a proc expression" -pprCtO (TypeEqOrigin t1 t2 _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2] -pprCtO AnnOrigin = text "an annotation" -pprCtO HoleOrigin = text "a use of" <+> quotes (text "_") -pprCtO ListOrigin = text "an overloaded list" -pprCtO StaticOrigin = text "a static form" -pprCtO _ = panic "pprCtOrigin" - -{- -Constraint Solver Plugins -------------------------- --} - -type TcPluginSolver = [Ct] -- given - -> [Ct] -- derived - -> [Ct] -- wanted - -> TcPluginM TcPluginResult - -newtype TcPluginM a = TcPluginM (EvBindsVar -> TcM a) - -instance Functor TcPluginM where - fmap = liftM - -instance Applicative TcPluginM where - pure x = TcPluginM (const $ pure x) - (<*>) = ap - -instance Monad TcPluginM where - fail x = TcPluginM (const $ fail x) - TcPluginM m >>= k = - TcPluginM (\ ev -> do a <- m ev - runTcPluginM (k a) ev) - -#if __GLASGOW_HASKELL__ > 710 -instance MonadFail.MonadFail TcPluginM where - fail x = TcPluginM (const $ fail x) -#endif - -runTcPluginM :: TcPluginM a -> EvBindsVar -> TcM a -runTcPluginM (TcPluginM m) = m - --- | This function provides an escape for direct access to --- the 'TcM` monad. It should not be used lightly, and --- the provided 'TcPluginM' API should be favoured instead. -unsafeTcPluginTcM :: TcM a -> TcPluginM a -unsafeTcPluginTcM = TcPluginM . const - --- | Access the 'EvBindsVar' carried by the 'TcPluginM' during --- constraint solving. Returns 'Nothing' if invoked during --- 'tcPluginInit' or 'tcPluginStop'. -getEvBindsTcPluginM :: TcPluginM EvBindsVar -getEvBindsTcPluginM = TcPluginM return - - -data TcPlugin = forall s. TcPlugin - { tcPluginInit :: TcPluginM s - -- ^ Initialize plugin, when entering type-checker. - - , tcPluginSolve :: s -> TcPluginSolver - -- ^ Solve some constraints. - -- TODO: WRITE MORE DETAILS ON HOW THIS WORKS. - - , tcPluginStop :: s -> TcPluginM () - -- ^ Clean up after the plugin, when exiting the type-checker. - } - -data TcPluginResult - = TcPluginContradiction [Ct] - -- ^ The plugin found a contradiction. - -- The returned constraints are removed from the inert set, - -- and recorded as insoluble. - - | TcPluginOk [(EvTerm,Ct)] [Ct] - -- ^ The first field is for constraints that were solved. - -- These are removed from the inert set, - -- and the evidence for them is recorded. - -- The second field contains new work, that should be processed by - -- the constraint solver. diff --git a/typecheck/TcRules.hs b/typecheck/TcRules.hs deleted file mode 100644 --- a/typecheck/TcRules.hs +++ /dev/null @@ -1,365 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - - -TcRules: Typechecking transformation rules --} - -{-# LANGUAGE ViewPatterns #-} - -module TcRules ( tcRules ) where - -import HsSyn -import TcRnMonad -import TcSimplify -import TcMType -import TcType -import TcHsType -import TcExpr -import TcEnv -import TcUnify( buildImplicationFor ) -import TcEvidence( mkTcCoVarCo ) -import Type -import Id -import Var( EvVar ) -import Name -import BasicTypes ( RuleName ) -import SrcLoc -import Outputable -import FastString -import Bag -import Data.List( partition ) - -{- -Note [Typechecking rules] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We *infer* the typ of the LHS, and use that type to *check* the type of -the RHS. That means that higher-rank rules work reasonably well. Here's -an example (test simplCore/should_compile/rule2.hs) produced by Roman: - - foo :: (forall m. m a -> m b) -> m a -> m b - foo f = ... - - bar :: (forall m. m a -> m a) -> m a -> m a - bar f = ... - - {-# RULES "foo/bar" foo = bar #-} - -He wanted the rule to typecheck. --} - -tcRules :: [LRuleDecls Name] -> TcM [LRuleDecls TcId] -tcRules decls = mapM (wrapLocM tcRuleDecls) decls - -tcRuleDecls :: RuleDecls Name -> TcM (RuleDecls TcId) -tcRuleDecls (HsRules src decls) - = do { tc_decls <- mapM (wrapLocM tcRule) decls - ; return (HsRules src tc_decls) } - -tcRule :: RuleDecl Name -> TcM (RuleDecl TcId) -tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) - = addErrCtxt (ruleCtxt $ snd $ unLoc name) $ - do { traceTc "---- Rule ------" (pprFullRuleName name) - - -- Note [Typechecking rules] - ; (vars, bndr_wanted) <- captureConstraints $ - tcRuleBndrs hs_bndrs - -- bndr_wanted constraints can include wildcard hole - -- constraints, which we should not forget about. - -- It may mention the skolem type variables bound by - -- the RULE. c.f. Trac #10072 - - ; let (id_bndrs, tv_bndrs) = partition isId vars - ; (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) - <- tcExtendTyVarEnv tv_bndrs $ - tcExtendIdEnv id_bndrs $ - do { -- See Note [Solve order for RULES] - ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) - ; (rhs', rhs_wanted) <- captureConstraints $ - tcMonoExpr rhs (mkCheckExpType rule_ty) - ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) } - - ; traceTc "tcRule 1" (vcat [ pprFullRuleName name - , ppr lhs_wanted - , ppr rhs_wanted ]) - ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted - ; (lhs_evs, residual_lhs_wanted) <- simplifyRule (snd $ unLoc name) - all_lhs_wanted - rhs_wanted - - -- SimplfyRule Plan, step 4 - -- Now figure out what to quantify over - -- c.f. TcSimplify.simplifyInfer - -- We quantify over any tyvars free in *either* the rule - -- *or* the bound variables. The latter is important. Consider - -- ss (x,(y,z)) = (x,z) - -- RULE: forall v. fst (ss v) = fst v - -- The type of the rhs of the rule is just a, but v::(a,(b,c)) - -- - -- We also need to get the completely-uconstrained tyvars of - -- the LHS, lest they otherwise get defaulted to Any; but we do that - -- during zonking (see TcHsSyn.zonkRule) - - ; let tpl_ids = lhs_evs ++ id_bndrs - ; forall_tkvs <- zonkTcTypesAndSplitDepVars $ - rule_ty : map idType tpl_ids - ; gbls <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level - -- monomorphic bindings from the MR; test tc111 - ; qtkvs <- quantifyZonkedTyVars gbls forall_tkvs - ; traceTc "tcRule" (vcat [ pprFullRuleName name - , ppr forall_tkvs - , ppr qtkvs - , ppr rule_ty - , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] - ]) - - -- SimplfyRule Plan, step 5 - -- Simplify the LHS and RHS constraints: - -- For the LHS constraints we must solve the remaining constraints - -- (a) so that we report insoluble ones - -- (b) so that we bind any soluble ones - ; let skol_info = RuleSkol (snd (unLoc name)) - ; (lhs_implic, lhs_binds) <- buildImplicationFor topTcLevel skol_info qtkvs - lhs_evs residual_lhs_wanted - ; (rhs_implic, rhs_binds) <- buildImplicationFor topTcLevel skol_info qtkvs - lhs_evs rhs_wanted - - ; emitImplications (lhs_implic `unionBags` rhs_implic) - ; return (HsRule name act - (map (noLoc . RuleBndr . noLoc) (qtkvs ++ tpl_ids)) - (mkHsDictLet lhs_binds lhs') fv_lhs - (mkHsDictLet rhs_binds rhs') fv_rhs) } - -tcRuleBndrs :: [LRuleBndr Name] -> TcM [Var] -tcRuleBndrs [] - = return [] -tcRuleBndrs (L _ (RuleBndr (L _ name)) : rule_bndrs) - = do { ty <- newOpenFlexiTyVarTy - ; vars <- tcRuleBndrs rule_bndrs - ; return (mkLocalId name ty : vars) } -tcRuleBndrs (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 - = do { let ctxt = RuleSigCtxt name - ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty - ; let id = mkLocalIdOrCoVar name id_ty - -- See Note [Pattern signature binders] in TcHsType - - -- The type variables scope over subsequent bindings; yuk - ; vars <- tcExtendTyVarEnv2 tvs $ - tcRuleBndrs rule_bndrs - ; return (map snd tvs ++ id : vars) } - -ruleCtxt :: FastString -> SDoc -ruleCtxt name = text "When checking the transformation rule" <+> - doubleQuotes (ftext name) - - -{- -********************************************************************************* -* * - Constraint simplification for rules -* * -*********************************************************************************** - -Note [The SimplifyRule Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Example. Consider the following left-hand side of a rule - f (x == y) (y > z) = ... -If we typecheck this expression we get constraints - d1 :: Ord a, d2 :: Eq a -We do NOT want to "simplify" to the LHS - forall x::a, y::a, z::a, d1::Ord a. - f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... -Instead we want - forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. - f ((==) d2 x y) ((>) d1 y z) = ... - -Here is another example: - fromIntegral :: (Integral a, Num b) => a -> b - {-# RULES "foo" fromIntegral = id :: Int -> Int #-} -In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But -we *dont* want to get - forall dIntegralInt. - fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int -because the scsel will mess up RULE matching. Instead we want - forall dIntegralInt, dNumInt. - fromIntegral Int Int dIntegralInt dNumInt = id Int - -Even if we have - g (x == y) (y == z) = .. -where the two dictionaries are *identical*, we do NOT WANT - forall x::a, y::a, z::a, d1::Eq a - f ((==) d1 x y) ((>) d1 y z) = ... -because that will only match if the dict args are (visibly) equal. -Instead we want to quantify over the dictionaries separately. - -In short, simplifyRuleLhs must *only* squash equalities, leaving -all dicts unchanged, with absolutely no sharing. - -Also note that we can't solve the LHS constraints in isolation: -Example foo :: Ord a => a -> a - foo_spec :: Int -> Int - {-# RULE "foo" foo = foo_spec #-} -Here, it's the RHS that fixes the type variable - -HOWEVER, under a nested implication things are different -Consider - f :: (forall a. Eq a => a->a) -> Bool -> ... - {-# RULES "foo" forall (v::forall b. Eq b => b->b). - f b True = ... - #-} -Here we *must* solve the wanted (Eq a) from the given (Eq a) -resulting from skolemising the argument type of g. So we -revert to SimplCheck when going under an implication. - - ---------- So the SimplifyRule Plan is this ----------------------- - -* Step 0: typecheck the LHS and RHS to get constraints from each - -* Step 1: Simplify the LHS and RHS constraints all together in one bag - We do this to discover all unification equalities - -* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take - advantage of those unifications - -* Setp 3: Partition the LHS constraints into the ones we will - quantify over, and the others. - See Note [RULE quantification over equalities] - -* Step 4: Decide on the type variables to quantify over - -* Step 5: Simplify the LHS and RHS constraints separately, using the - quantified constraints as givens - -Note [Solve order for RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In step 1 above, we need to be a bit careful about solve order. -Consider - f :: Int -> T Int - type instance T Int = Bool - - RULE f 3 = True - -From the RULE we get - lhs-constraints: T Int ~ alpha - rhs-constraints: Bool ~ alpha -where 'alpha' is the type that connects the two. If we glom them -all together, and solve the RHS constraint first, we might solve -with alpha := Bool. But then we'd end up with a RULE like - - RULE: f 3 |> (co :: T Int ~ Booo) = True - -which is terrible. We want - - RULE: f 3 = True |> (sym co :: Bool ~ T Int) - -So we are careful to solve the LHS constraints first, and *then* the -RHS constraints. Actually much of this is done by the on-the-fly -constraint solving, so the same order must be observed in -tcRule. - - -Note [RULE quantification over equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deciding which equalities to quantify over is tricky: - * We do not want to quantify over insoluble equalities (Int ~ Bool) - (a) because we prefer to report a LHS type error - (b) because if such things end up in 'givens' we get a bogus - "inaccessible code" error - - * But we do want to quantify over things like (a ~ F b), where - F is a type function. - -The difficulty is that it's hard to tell what is insoluble! -So we see whether the simplification step yielded any type errors, -and if so refrain from quantifying over *any* equalities. - -Note [Quantifying over coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Equality constraints from the LHS will emit coercion hole Wanteds. -These don't have a name, so we can't quantify over them directly. -Instead, because we really do want to quantify here, invent a new -EvVar for the coercion, fill the hole with the invented EvVar, and -then quantify over the EvVar. Not too tricky -- just some -impedance matching, really. - -Note [Simplify cloned constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At this stage, we're simplifying constraints only for insolubility -and for unification. Note that all the evidence is quickly discarded. -We use a clone of the real constraint. If we don't do this, -then RHS coercion-hole constraints get filled in, only to get filled -in *again* when solving the implications emitted from tcRule. That's -terrible, so we avoid the problem by cloning the constraints. - --} - -simplifyRule :: RuleName - -> WantedConstraints -- Constraints from LHS - -> WantedConstraints -- Constraints from RHS - -> TcM ( [EvVar] -- Quantify over these LHS vars - , WantedConstraints) -- Residual un-quantified LHS constraints --- See Note [The SimplifyRule Plan] --- NB: This consumes all simple constraints on the LHS, but not --- any LHS implication constraints. -simplifyRule name lhs_wanted rhs_wanted - = do { -- We allow ourselves to unify environment - -- variables: runTcS runs with topTcLevel - ; lhs_clone <- cloneWC lhs_wanted - ; rhs_clone <- cloneWC rhs_wanted - - -- Note [The SimplifyRule Plan] step 1 - -- First solve the LHS and *then* solve the RHS - -- Crucially, this performs unifications - -- See Note [Solve order for RULES] - -- See Note [Simplify cloned constraints] - ; insoluble <- runTcSDeriveds $ - do { lhs_resid <- solveWanteds lhs_clone - ; rhs_resid <- solveWanteds rhs_clone - ; return ( insolubleWC lhs_resid || - insolubleWC rhs_resid ) } - - -- Note [The SimplifyRule Plan] step 2 - ; zonked_lhs_simples <- zonkSimples (wc_simple lhs_wanted) - - -- Note [The SimplifyRule Plan] step 3 - ; let (quant_cts, no_quant_cts) = partitionBag (quantify_ct insoluble) - zonked_lhs_simples - - ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts) - - ; traceTc "simplifyRule" $ - vcat [ text "LHS of rule" <+> doubleQuotes (ftext name) - , text "lhs_wanted" <+> ppr lhs_wanted - , text "rhs_wanted" <+> ppr rhs_wanted - , text "zonked_lhs_simples" <+> ppr zonked_lhs_simples - , text "quant_cts" <+> ppr quant_cts - , text "no_quant_cts" <+> ppr no_quant_cts - ] - - ; return (quant_evs, lhs_wanted { wc_simple = no_quant_cts }) } - - where - quantify_ct :: Bool -> Ct -> Bool - quantify_ct insol ct - | EqPred _ t1 t2 <- classifyPredType (ctPred ct) - = not (insol || t1 `tcEqType` t2) - -- Note [RULE quantification over equalities] - - | otherwise - = True - - mk_quant_ev :: Ct -> TcM EvVar - mk_quant_ev ct - | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct - = case dest of - EvVarDest ev_id -> return ev_id - HoleDest hole -> -- See Note [Quantifying over coercion holes] - do { ev_id <- newEvVar pred - ; fillCoercionHole hole (mkTcCoVarCo ev_id) - ; return ev_id } - mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct) diff --git a/typecheck/TcSMonad.hs b/typecheck/TcSMonad.hs deleted file mode 100644 --- a/typecheck/TcSMonad.hs +++ /dev/null @@ -1,3122 +0,0 @@ -{-# LANGUAGE CPP, TypeFamilies #-} - --- Type definitions for the constraint solver -module TcSMonad ( - - -- The work list - WorkList(..), isEmptyWorkList, emptyWorkList, - extendWorkListNonEq, extendWorkListCt, extendWorkListDerived, - extendWorkListCts, extendWorkListEq, extendWorkListFunEq, - appendWorkList, extendWorkListImplic, - selectNextWorkItem, - workListSize, workListWantedCount, - getWorkList, updWorkListTcS, - - -- The TcS monad - TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, - failTcS, warnTcS, addErrTcS, - runTcSEqualities, - nestTcS, nestImplicTcS, setEvBindsTcS, buildImplication, - - runTcPluginTcS, addUsedGRE, addUsedGREs, - - -- Tracing etc - panicTcS, traceTcS, - traceFireTcS, bumpStepCountTcS, csTraceTcS, - wrapErrTcS, wrapWarnTcS, - - -- Evidence creation and transformation - MaybeNew(..), freshGoals, isFresh, getEvTerm, - - newTcEvBinds, - newWantedEq, emitNewWantedEq, - newWanted, newWantedEvVar, newWantedNC, newWantedEvVarNC, newDerivedNC, - newBoundEvVarId, - unifyTyVar, unflattenFmv, reportUnifications, - setEvBind, setWantedEq, setEqIfWanted, - setWantedEvTerm, setWantedEvBind, setEvBindIfWanted, - newEvVar, newGivenEvVar, newGivenEvVars, - emitNewDerived, emitNewDeriveds, emitNewDerivedEq, - checkReductionDepth, - - getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getLclEnv, - getTcEvBindsVar, getTcLevel, - getTcEvBindsAndTCVs, getTcEvBindsMap, - tcLookupClass, - tcLookupId, - - -- Inerts - InertSet(..), InertCans(..), - updInertTcS, updInertCans, updInertDicts, updInertIrreds, - getNoGivenEqs, setInertCans, - getInertEqs, getInertCans, getInertGivens, - getInertInsols, - emptyInert, getTcSInerts, setTcSInerts, - matchableGivens, prohibitedSuperClassSolve, - getUnsolvedInerts, - removeInertCts, getPendingScDicts, - addInertCan, addInertEq, insertFunEq, - emitInsoluble, emitWorkNC, emitWork, - isImprovable, - - -- The Model - kickOutAfterUnification, - - -- Inert Safe Haskell safe-overlap failures - addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask, - getSafeOverlapFailures, - - -- Inert CDictCans - DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict, - addDictsByClass, delDict, foldDicts, filterDicts, findDict, - - -- Inert CTyEqCans - EqualCtList, findTyEqs, foldTyEqs, isInInertEqs, - lookupFlattenTyVar, lookupInertTyVar, - - -- Inert solved dictionaries - addSolvedDict, lookupSolvedDict, - - -- Irreds - foldIrreds, - - -- The flattening cache - lookupFlatCache, extendFlatCache, newFlattenSkolem, -- Flatten skolems - - -- Inert CFunEqCans - updInertFunEqs, findFunEq, - findFunEqsByTyCon, - - instDFunType, -- Instantiation - - -- MetaTyVars - newFlexiTcSTy, instFlexi, instFlexiX, - cloneMetaTyVar, demoteUnfilledFmv, - tcInstType, tcInstSkolTyVarsX, - - TcLevel, isTouchableMetaTyVarTcS, - isFilledMetaTyVar_maybe, isFilledMetaTyVar, - zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo, - zonkTyCoVarsAndFVList, - zonkSimples, zonkWC, - - -- References - newTcRef, readTcRef, updTcRef, - - -- Misc - getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, - matchFam, matchFamTcM, - checkWellStagedDFun, - pprEq -- Smaller utils, re-exported from TcM - -- TODO (DV): these are only really used in the - -- instance matcher in TcSimplify. I am wondering - -- if the whole instance matcher simply belongs - -- here -) where - -#include "HsVersions.h" - -import HscTypes - -import qualified Inst as TcM -import InstEnv -import FamInst -import FamInstEnv - -import qualified TcRnMonad as TcM -import qualified TcMType as TcM -import qualified TcEnv as TcM - ( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass, tcLookupId ) -import PrelNames( heqTyConKey, eqTyConKey ) -import Kind -import TcType -import DynFlags -import Type -import Coercion -import Unify - -import TcEvidence -import Class -import TyCon -import TcErrors ( solverDepthErrorTcS ) - -import Name -import RdrName ( GlobalRdrEnv, GlobalRdrElt ) -import qualified RnEnv as TcM -import Var -import VarEnv -import VarSet -import Outputable -import Bag -import UniqSupply -import Util -import TcRnTypes - -import Unique -import UniqFM -import UniqDFM -import Maybes - -import TrieMap -import Control.Monad -#if __GLASGOW_HASKELL__ > 710 -import qualified Control.Monad.Fail as MonadFail -#endif -import MonadUtils -import Data.IORef -import Data.List ( foldl', partition ) - -#ifdef DEBUG -import Digraph -import UniqSet -#endif - -{- -************************************************************************ -* * -* Worklists * -* Canonical and non-canonical constraints that the simplifier has to * -* work on. Including their simplification depths. * -* * -* * -************************************************************************ - -Note [WorkList priorities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A WorkList contains canonical and non-canonical items (of all flavors). -Notice that each Ct now has a simplification depth. We may -consider using this depth for prioritization as well in the future. - -As a simple form of priority queue, our worklist separates out -equalities (wl_eqs) from the rest of the canonical constraints, -so that it's easier to deal with them first, but the separation -is not strictly necessary. Notice that non-canonical constraints -are also parts of the worklist. - -Note [Process derived items last] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can often solve all goals without processing *any* derived constraints. -The derived constraints are just there to help us if we get stuck. So -we keep them in a separate list. - -Note [Prioritise class equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We prioritise equalities in the solver (see selectWorkItem). But class -constraints like (a ~ b) and (a ~~ b) are actually equalities too; -see Note [The equality types story] in TysPrim. - -Failing to prioritise these is inefficient (more kick-outs etc). -But, worse, it can prevent us spotting a "recursive knot" among -Wanted constraints. See comment:10 of Trac #12734 for a worked-out -example. - -So we arrange to put these particular class constraints in the wl_eqs. - - NB: since we do not currently apply the substitution to the - inert_solved_dicts, the knot-tying still seems a bit fragile. - But this makes it better. --} - --- See Note [WorkList priorities] -data WorkList - = WL { wl_eqs :: [Ct] -- Both equality constraints and their - -- class-level variants (a~b) and (a~~b); - -- See Note [Prioritise class equalities] - - , wl_funeqs :: [Ct] -- LIFO stack of goals - - , wl_rest :: [Ct] - - , wl_deriv :: [CtEvidence] -- Implicitly non-canonical - -- See Note [Process derived items last] - - , wl_implics :: Bag Implication -- See Note [Residual implications] - } - -appendWorkList :: WorkList -> WorkList -> WorkList -appendWorkList - (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1 - , wl_deriv = ders1, wl_implics = implics1 }) - (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2 - , wl_deriv = ders2, wl_implics = implics2 }) - = WL { wl_eqs = eqs1 ++ eqs2 - , wl_funeqs = funeqs1 ++ funeqs2 - , wl_rest = rest1 ++ rest2 - , wl_deriv = ders1 ++ ders2 - , wl_implics = implics1 `unionBags` implics2 } - -workListSize :: WorkList -> Int -workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_deriv = ders, wl_rest = rest }) - = length eqs + length funeqs + length rest + length ders - -workListWantedCount :: WorkList -> Int -workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest }) - = count isWantedCt eqs + count isWantedCt rest - -extendWorkListEq :: Ct -> WorkList -> WorkList -extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl } - -extendWorkListEqs :: [Ct] -> WorkList -> WorkList -extendWorkListEqs cts wl = wl { wl_eqs = cts ++ wl_eqs wl } - -extendWorkListFunEq :: Ct -> WorkList -> WorkList -extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl } - -extendWorkListNonEq :: Ct -> WorkList -> WorkList --- Extension by non equality -extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } - -extendWorkListDerived :: CtLoc -> CtEvidence -> WorkList -> WorkList -extendWorkListDerived loc ev wl - | isDroppableDerivedLoc loc = wl { wl_deriv = ev : wl_deriv wl } - | otherwise = extendWorkListEq (mkNonCanonical ev) wl - -extendWorkListDeriveds :: CtLoc -> [CtEvidence] -> WorkList -> WorkList -extendWorkListDeriveds loc evs wl - | isDroppableDerivedLoc loc = wl { wl_deriv = evs ++ wl_deriv wl } - | otherwise = extendWorkListEqs (map mkNonCanonical evs) wl - -extendWorkListImplic :: Bag Implication -> WorkList -> WorkList -extendWorkListImplic implics wl = wl { wl_implics = implics `unionBags` wl_implics wl } - -extendWorkListCt :: Ct -> WorkList -> WorkList --- Agnostic -extendWorkListCt ct wl - = case classifyPredType (ctPred ct) of - EqPred NomEq ty1 _ - | Just tc <- tcTyConAppTyCon_maybe ty1 - , isTypeFamilyTyCon tc - -> extendWorkListFunEq ct wl - - EqPred {} - -> extendWorkListEq ct wl - - ClassPred cls _ -- See Note [Prioritise class equalites] - | cls `hasKey` heqTyConKey - || cls `hasKey` eqTyConKey - -> extendWorkListEq ct wl - - _ -> extendWorkListNonEq ct wl - -extendWorkListCts :: [Ct] -> WorkList -> WorkList --- Agnostic -extendWorkListCts cts wl = foldr extendWorkListCt wl cts - -isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs - , wl_rest = rest, wl_deriv = ders, wl_implics = implics }) - = null eqs && null rest && null funeqs && isEmptyBag implics && null ders - -emptyWorkList :: WorkList -emptyWorkList = WL { wl_eqs = [], wl_rest = [] - , wl_funeqs = [], wl_deriv = [], wl_implics = emptyBag } - -selectWorkItem :: WorkList -> Maybe (Ct, WorkList) -selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs - , wl_rest = rest }) - | ct:cts <- eqs = Just (ct, wl { wl_eqs = cts }) - | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes }) - | ct:cts <- rest = Just (ct, wl { wl_rest = cts }) - | otherwise = Nothing - -getWorkList :: TcS WorkList -getWorkList = do { wl_var <- getTcSWorkListRef - ; wrapTcS (TcM.readTcRef wl_var) } - -selectDerivedWorkItem :: WorkList -> Maybe (Ct, WorkList) -selectDerivedWorkItem wl@(WL { wl_deriv = ders }) - | ev:evs <- ders = Just (mkNonCanonical ev, wl { wl_deriv = evs }) - | otherwise = Nothing - -selectNextWorkItem :: TcS (Maybe Ct) -selectNextWorkItem - = do { wl_var <- getTcSWorkListRef - ; wl <- wrapTcS (TcM.readTcRef wl_var) - - ; let try :: Maybe (Ct,WorkList) -> TcS (Maybe Ct) -> TcS (Maybe Ct) - try mb_work do_this_if_fail - | Just (ct, new_wl) <- mb_work - = do { checkReductionDepth (ctLoc ct) (ctPred ct) - ; wrapTcS (TcM.writeTcRef wl_var new_wl) - ; return (Just ct) } - | otherwise - = do_this_if_fail - - ; try (selectWorkItem wl) $ - - do { ics <- getInertCans - ; if inert_count ics == 0 - then return Nothing - else try (selectDerivedWorkItem wl) (return Nothing) } } - --- Pretty printing -instance Outputable WorkList where - ppr (WL { wl_eqs = eqs, wl_funeqs = feqs - , wl_rest = rest, wl_implics = implics, wl_deriv = ders }) - = text "WL" <+> (braces $ - vcat [ ppUnless (null eqs) $ - text "Eqs =" <+> vcat (map ppr eqs) - , ppUnless (null feqs) $ - text "Funeqs =" <+> vcat (map ppr feqs) - , ppUnless (null rest) $ - text "Non-eqs =" <+> vcat (map ppr rest) - , ppUnless (null ders) $ - text "Derived =" <+> vcat (map ppr ders) - , ppUnless (isEmptyBag implics) $ - sdocWithPprDebug $ \dbg -> - if dbg -- Typically we only want the work list for this level - then text "Implics =" <+> vcat (map ppr (bagToList implics)) - else text "(Implics omitted)" - ]) - - -{- ********************************************************************* -* * - InertSet: the inert set -* * -* * -********************************************************************* -} - -data InertSet - = IS { inert_cans :: InertCans - -- Canonical Given, Wanted, Derived - -- Sometimes called "the inert set" - - , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour) - -- See Note [Type family equations] - -- If F tys :-> (co, rhs, flav), - -- then co :: F tys ~ rhs - -- flav is [G] or [WD] - -- - -- Just a hash-cons cache for use when flattening only - -- These include entirely un-processed goals, so don't use - -- them to solve a top-level goal, else you may end up solving - -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache - -- when allocating a new flatten-skolem. - -- Not necessarily inert wrt top-level equations (or inert_cans) - - -- NB: An ExactFunEqMap -- this doesn't match via loose types! - - , inert_solved_dicts :: DictMap CtEvidence - -- 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 = vcat [ ppr $ inert_cans is - , ppUnless (null dicts) $ - text "Solved dicts" <+> vcat (map ppr dicts) ] - where - dicts = bagToList (dictsToBag (inert_solved_dicts is)) - -emptyInert :: InertSet -emptyInert - = IS { inert_cans = IC { inert_count = 0 - , inert_eqs = emptyDVarEnv - , inert_dicts = emptyDicts - , inert_safehask = emptyDicts - , inert_funeqs = emptyFunEqs - , inert_irreds = emptyCts - , inert_insols = emptyCts } - , inert_flat_cache = emptyExactFunEqs - , inert_solved_dicts = emptyDictMap } - - -{- Note [Solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we apply a top-level instance declaration, we add the "solved" -dictionary to the inert_solved_dicts. In general, we use it to avoid -creating a new EvVar when we have a new goal that we have solved in -the past. - -But in particular, we can use it to create *recursive* dictionaries. -The simplest, degnerate case is - instance C [a] => C [a] where ... -If we have - [W] d1 :: C [x] -then we can apply the instance to get - d1 = $dfCList d - [W] d2 :: C [x] -Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1. - d1 = $dfCList d - d2 = d1 - -See Note [Example of recursive dictionaries] -Other notes about solved dictionaries - -* See also Note [Do not add superclasses of solved dictionaries] - -* The inert_solved_dicts field is not rewritten by equalities, so it may - get out of date. - -Note [Do not add superclasses of solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every member of inert_solved_dicts is the result of applying a dictionary -function, NOT of applying superclass selection to anything. -Consider - - class Ord a => C a where - instance Ord [a] => C [a] where ... - -Suppose we are trying to solve - [G] d1 : Ord a - [W] d2 : C [a] - -Then we'll use the instance decl to give - - [G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3 - [W] d3 : Ord [a] - -We must not add d4 : Ord [a] to the 'solved' set (by taking the -superclass of d2), otherwise we'll use it to solve d3, without ever -using d1, which would be a catastrophe. - -Solution: when extending the solved dictionaries, do not add superclasses. -That's why each element of the inert_solved_dicts is the result of applying -a dictionary function. - -Note [Example of recursive dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ---- Example 1 - - data D r = ZeroD | SuccD (r (D r)); - - instance (Eq (r (D r))) => Eq (D r) where - ZeroD == ZeroD = True - (SuccD a) == (SuccD b) = a == b - _ == _ = False; - - equalDC :: D [] -> D [] -> Bool; - equalDC = (==); - -We need to prove (Eq (D [])). Here's how we go: - - [W] d1 : Eq (D []) -By instance decl of Eq (D r): - [W] d2 : Eq [D []] where d1 = dfEqD d2 -By instance decl of Eq [a]: - [W] d3 : Eq (D []) where d2 = dfEqList d3 - d1 = dfEqD d2 -Now this wanted can interact with our "solved" d1 to get: - d3 = d1 - --- Example 2: -This code arises in the context of "Scrap Your Boilerplate with Class" - - class Sat a - class Data ctx a - instance Sat (ctx Char) => Data ctx Char -- dfunData1 - instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 - - class Data Maybe a => Foo a - - instance Foo t => Sat (Maybe t) -- dfunSat - - instance Data Maybe a => Foo a -- dfunFoo1 - instance Foo a => Foo [a] -- dfunFoo2 - instance Foo [Char] -- dfunFoo3 - -Consider generating the superclasses of the instance declaration - instance Foo a => Foo [a] - -So our problem is this - [G] d0 : Foo t - [W] d1 : Data Maybe [t] -- Desired superclass - -We may add the given in the inert set, along with its superclasses - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - WorkList - [W] d1 : Data Maybe [t] - -Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - WorkList: - [W] d2 : Sat (Maybe [t]) - [W] d3 : Data Maybe t - -Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList: - [W] d3 : Data Maybe t - [W] d4 : Foo [t] - -Now, we can just solve d3 from d01; d3 := d01 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList - [W] d4 : Foo [t] - -Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - d4 : Foo [t] - WorkList: - [W] d5 : Foo t - -Now, d5 can be solved! d5 := d0 - -Result - d1 := dfunData2 d2 d3 - d2 := dfunSat d4 - d3 := d01 - d4 := dfunFoo2 d5 - d5 := d0 --} - -{- ********************************************************************* -* * - InertCans: the canonical inerts -* * -* * -********************************************************************* -} - -data InertCans -- See Note [Detailed InertCans Invariants] for more - = IC { inert_eqs :: InertEqs - -- See Note [inert_eqs: the inert equalities] - -- All CTyEqCans; index is the LHS tyvar - -- Domain = skolems and untouchables; a touchable would be unified - - , inert_funeqs :: FunEqMap Ct - -- All CFunEqCans; index is the whole family head type. - -- All Nominal (that's an invarint of all CFunEqCans) - -- LHS is fully rewritten (modulo eqCanRewrite constraints) - -- wrt inert_eqs - -- Can include all flavours, [G], [W], [WD], [D] - -- See Note [Type family equations] - - , inert_dicts :: DictMap Ct - -- Dictionaries only - -- All fully rewritten (modulo flavour constraints) - -- wrt inert_eqs - - , inert_safehask :: DictMap Ct - -- Failed dictionary resolution due to Safe Haskell overlapping - -- instances restriction. We keep this separate from inert_dicts - -- as it doesn't cause compilation failure, just safe inference - -- failure. - -- - -- ^ See Note [Safe Haskell Overlapping Instances Implementation] - -- in TcSimplify - - , inert_irreds :: Cts - -- Irreducible predicates - - , inert_insols :: Cts - -- Frozen errors (as non-canonicals) - - , inert_count :: Int - -- Number of Wanted goals in - -- inert_eqs, inert_dicts, inert_safehask, inert_irreds - -- Does not include insolubles - -- When non-zero, keep trying to solved - } - -type InertEqs = DTyVarEnv EqualCtList -type EqualCtList = [Ct] -- See Note [EqualCtList invariants] - -{- Note [Detailed InertCans Invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The InertCans represents a collection of constraints with the following properties: - - * All canonical - - * No two dictionaries with the same head - * No two CIrreds with the same type - - * Family equations inert wrt top-level family axioms - - * Dictionaries have no matching top-level instance - - * Given family or dictionary constraints don't mention touchable - unification variables - - * Non-CTyEqCan constraints are fully rewritten with respect - to the CTyEqCan equalities (modulo canRewrite of course; - eg a wanted cannot rewrite a given) - - * CTyEqCan equalities: see Note [Applying the inert substitution] - in TcFlatten - -Note [EqualCtList invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * All are equalities - * All these equalities have the same LHS - * The list is never empty - * No element of the list can rewrite any other - * Derived before Wanted - -From the fourth invariant it follows that the list is - - A single [G], or - - Zero or one [D] or [WD], followd by any number of [W] - -The Wanteds can't rewrite anything which is why we put them last - -Note [Type family equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type-family equations, CFunEqCans, of form (ev : F tys ~ ty), -live in three places - - * The work-list, of course - - * The inert_funeqs are un-solved but fully processed, and in - the InertCans. They can be [G], [W], [WD], or [D]. - - * The inert_flat_cache. This is used when flattening, to get maximal - sharing. Everthing in the inert_flat_cache is [G] or [WD] - - It contains lots of things that are still in the work-list. - E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the - work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work - list. Now if we flatten w2 before we get to w3, we still want to - share that (G a). - Because it contains work-list things, DO NOT use the flat cache to solve - a top-level goal. Eg in the above example we don't want to solve w3 - using w3 itself! - -The CFunEqCan Ownership Invariant: - - * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv - It "owns" that fsk/fmv, in the sense that: - - reducing a [W/WD] CFunEqCan fills in the fmv - - unflattening a [W/WD] CFunEqCan fills in the fmv - (in both cases unless an occurs-check would result) - - * In contrast a [D] CFunEqCan does not "own" its fmv: - - reducing a [D] CFunEqCan does not fill in the fmv; - it just generates an equality - - unflattening ignores [D] CFunEqCans altogether - - -Note [inert_eqs: the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Definition [Can-rewrite relation] -A "can-rewrite" relation between flavours, written f1 >= f2, is a -binary relation with the following properties - - (R1) >= is transitive - (R2) If f1 >= f, and f2 >= f, - then either f1 >= f2 or f2 >= f1 - -Lemma. If f1 >= f then f1 >= f1 -Proof. By property (R2), with f1=f2 - -Definition [Generalised substitution] -A "generalised substitution" S is a set of triples (a -f-> t), where - a is a type variable - t is a type - f is a flavour -such that - (WF1) if (a -f1-> t1) in S - (a -f2-> t2) in S - then neither (f1 >= f2) nor (f2 >= f1) hold - (WF2) if (a -f-> t) is in S, then t /= a - -Definition [Applying a generalised substitution] -If S is a generalised substitution - S(f,a) = t, if (a -fs-> t) in S, and fs >= f - = a, otherwise -Application extends naturally to types S(f,t), modulo roles. -See Note [Flavours with roles]. - -Theorem: S(f,a) is well defined as a function. -Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S, - and f1 >= f and f2 >= f - Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1) - -Notation: repeated application. - S^0(f,t) = t - S^(n+1)(f,t) = S(f, S^n(t)) - -Definition: inert generalised substitution -A generalised substitution S is "inert" iff - - (IG1) there is an n such that - for every f,t, S^n(f,t) = S^(n+1)(f,t) - -By (IG1) we define S*(f,t) to be the result of exahaustively -applying S(f,_) to t. - ----------------------------------------------------------------- -Our main invariant: - the inert CTyEqCans should be an inert generalised substitution ----------------------------------------------------------------- - -Note that inertness is not the same as idempotence. To apply S to a -type, you may have to apply it recursive. But inertness does -guarantee that this recursive use will terminate. - -Note [Extending the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Theorem [Stability under extension] - This is the main theorem! - Suppose we have a "work item" - a -fw-> t - and an inert generalised substitution S, - such that - (T1) S(fw,a) = a -- LHS of work-item is a fixpoint of S(fw,_) - (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) - (T3) a not in t -- No occurs check in the work item - - (K1) for every (a -fs-> s) in S, then not (fw >= fs) - Reason: the work item is fully rewritten by S, hence not (fs >= fw) - but if (fw >= fs) then the work item could rewrite - the inert item - - (K2) for every (b -fs-> s) in S, where b /= a, then - (K2a) not (fs >= fs) - or (K2b) fs >= fw - or (K2c) not (fw >= fs) - or (K2d) a not in s - - (K3) See Note [K3: completeness of solving] - If (b -fs-> s) is in S with (fw >= fs), then - (K3a) If the role of fs is nominal: s /= a - (K3b) If the role of fs is representational: EITHER - a not in s, OR - the path from the top of s to a includes at least one non-newtype - - then the extended substitution T = S+(a -fw-> t) - is an inert generalised substitution. - -Conditions (T1-T3) are established by the canonicaliser -Conditions (K1-K3) are established by TcSMonad.kickOutRewritable - -The idea is that -* (T1-2) are guaranteed by exhaustively rewriting the work-item - with S(fw,_). - -* T3 is guaranteed by a simple occurs-check on the work item. - This is done during canonicalisation, in canEqTyVar; - (invariant: a CTyEqCan never has an occurs check). - -* (K1-3) are the "kick-out" criteria. (As stated, they are really the - "keep" criteria.) If the current inert S contains a triple that does - not satisfy (K1-3), then we remove it from S by "kicking it out", - and re-processing it. - -* Note that kicking out is a Bad Thing, because it means we have to - re-process a constraint. The less we kick out, the better. - TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed - this but haven't done the empirical study to check. - -* Assume we have G>=G, G>=W and that's all. Then, when performing - a unification we add a new given a -G-> ty. But doing so does NOT require - us to kick out an inert wanted that mentions a, because of (K2a). This - is a common case, hence good not to kick out. - -* Lemma (L2): if not (fw >= fw), then K1-K3 all hold. - Proof: using Definition [Can-rewrite relation], fw can't rewrite anything - and so K1-K3 hold. Intuitively, since fw can't rewrite anything, - adding it cannot cause any loops - This is a common case, because Wanteds cannot rewrite Wanteds. - -* Lemma (L1): The conditions of the Main Theorem imply that there is no - (a -fs-> t) in S, s.t. (fs >= fw). - Proof. Suppose the contrary (fs >= fw). Then because of (T1), - S(fw,a)=a. But since fs>=fw, S(fw,a) = s, hence s=a. But now we - have (a -fs-> a) in S, which contradicts (WF2). - -* The extended substitution satisfies (WF1) and (WF2) - - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1). - - (T3) guarantees (WF2). - -* (K2) is about inertness. Intuitively, any infinite chain T^0(f,t), - T^1(f,t), T^2(f,T).... must pass through the new work item infnitely - often, since the substitution without the work item is inert; and must - pass through at least one of the triples in S infnitely often. - - - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f), - and hence this triple never plays a role in application S(f,a). - It is always safe to extend S with such a triple. - - (NB: we could strengten K1) in this way too, but see K3. - - - (K2b): If this holds then, by (T2), b is not in t. So applying the - work item does not genenerate any new opportunities for applying S - - - (K2c): If this holds, we can't pass through this triple infinitely - often, because if we did then fs>=f, fw>=f, hence by (R2) - * either fw>=fs, contradicting K2c - * or fs>=fw; so by the argument in K2b we can't have a loop - - - (K2d): if a not in s, we hae no further opportunity to apply the - work item, similar to (K2b) - - NB: Dimitrios has a PDF that does this in more detail - -Key lemma to make it watertight. - Under the conditions of the Main Theorem, - forall f st fw >= f, a is not in S^k(f,t), for any k - -Also, consider roles more carefully. See Note [Flavours with roles] - -Note [K3: completeness of solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(K3) is not necessary for the extended substitution -to be inert. In fact K1 could be made stronger by saying - ... then (not (fw >= fs) or not (fs >= fs)) -But it's not enough for S to be inert; we also want completeness. -That is, we want to be able to solve all soluble wanted equalities. -Suppose we have - - work-item b -G-> a - inert-item a -W-> b - -Assuming (G >= W) but not (W >= W), this fulfills all the conditions, -so we could extend the inerts, thus: - - inert-items b -G-> a - a -W-> b - -But if we kicked-out the inert item, we'd get - - work-item a -W-> b - inert-item b -G-> a - -Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl. -So we add one more clause to the kick-out criteria - -Another way to understand (K3) is that we treat an inert item - a -f-> b -in the same way as - b -f-> a -So if we kick out one, we should kick out the other. The orientation -is somewhat accidental. - -When considering roles, we also need the second clause (K3b). Consider - - inert-item a -W/R-> b c - work-item c -G/N-> a - -The work-item doesn't get rewritten by the inert, because (>=) doesn't hold. -We've satisfied conditions (T1)-(T3) and (K1) and (K2). If all we had were -condition (K3a), then we would keep the inert around and add the work item. -But then, consider if we hit the following: - - work-item2 b -G/N-> Id - -where - - newtype Id x = Id x - -For similar reasons, if we only had (K3a), we wouldn't kick the -representational inert out. And then, we'd miss solving the inert, which -now reduced to reflexivity. The solution here is to kick out representational -inerts whenever the tyvar of a work item is "exposed", where exposed means -not under some proper data-type constructor, like [] or Maybe. See -isTyVarExposed in TcType. This is encoded in (K3b). - -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_insols = insols, inert_count = count }) - = braces $ vcat - [ ppUnless (isEmptyDVarEnv eqs) $ - text "Equalities:" - <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs) - , ppUnless (isEmptyTcAppMap funeqs) $ - text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs) - , ppUnless (isEmptyTcAppMap dicts) $ - text "Dictionaries =" <+> pprCts (dictsToBag dicts) - , ppUnless (isEmptyTcAppMap safehask) $ - text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask) - , ppUnless (isEmptyCts irreds) $ - text "Irreds =" <+> pprCts irreds - , ppUnless (isEmptyCts insols) $ - text "Insolubles =" <+> pprCts insols - , text "Unsolved goals =" <+> int count - ] - -{- ********************************************************************* -* * - Shadow constraints and improvement -* * -************************************************************************ - -Note [The improvement story and derived shadows] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not -rewrite Wanteds] in TcRnTypes), we may miss some opportunities for -solving. Here's a classic example (indexed-types/should_fail/T4093a) - - Ambiguity check for f: (Foo e ~ Maybe e) => Foo e - - We get [G] Foo e ~ Maybe e - [W] Foo e ~ Foo ee -- ee is a unification variable - [W] Foo ee ~ Maybe ee - - Flatten: [G] Foo e ~ fsk - [G] fsk ~ Maybe e -- (A) - - [W] Foo ee ~ fmv - [W] fmv ~ fsk -- (B) From Foo e ~ Foo ee - [W] fmv ~ Maybe ee - - --> rewrite (B) with (A) - [W] Foo ee ~ fmv - [W] fmv ~ Maybe e - [W] fmv ~ Maybe ee - - But now we appear to be stuck, since we don't rewrite Wanteds with - Wanteds. This is silly because we can see that ee := e is the - only solution. - -The basic plan is - * generate Derived constraints that shadow Wanted constraints - * allow Derived to rewrite Derived - * in order to cause some unifications to take place - * that in turn solve the original Wanteds - -The ONLY reason for all these Derived equalities is to tell us how to -unify a variable: that is, what Mark Jones calls "improvement". - -The same idea is sometimes also called "saturation"; find all the -equalities that must hold in any solution. - -Or, equivalently, you can think of the derived shadows as implementing -the "model": an non-idempotent but no-occurs-check substitution, -reflecting *all* *Nominal* equalities (a ~N ty) that are not -immediately soluble by unification. - -More specifically, here's how it works (Oct 16): - -* Wanted constraints are born as [WD]; this behaves like a - [W] and a [D] paired together. - -* When we are about to add a [WD] to the inert set, if it can - be rewritten by a [D] a ~ ty, then we split it into [W] and [D], - putting the latter into the work list (see maybeEmitShadow). - -In the example above, we get to the point where we are stuck: - [WD] Foo ee ~ fmv - [WD] fmv ~ Maybe e - [WD] fmv ~ Maybe ee - -But now when [WD] fmv ~ Maybe ee is about to be added, we'll -split it into [W] and [D], since the inert [WD] fmv ~ Maybe e -can rewrite it. Then: - work item: [D] fmv ~ Maybe ee - inert: [W] fmv ~ Maybe ee - [WD] fmv ~ Maybe e -- (C) - [WD] Foo ee ~ fmv - -See Note [Splitting WD constraints]. Now the work item is rewritten -by (C) and we soon get ee := e. - -Additional notes: - - * The derived shadow equalities live in inert_eqs, along with - the Givens and Wanteds; see Note [EqualCtList invariants]. - - * We make Derived shadows only for Wanteds, not Givens. So we - have only [G], not [GD] and [G] plus splitting. See - Note [Add derived shadows only for Wanteds] - - * We also get Derived equalities from functional dependencies - and type-function injectivity; see calls to unifyDerived. - - * This splitting business applies to CFunEqCans too; and then - we do apply type-function reductions to the [D] CFunEqCan. - See Note [Reduction for Derived CFunEqCans] - - * It's worth having [WD] rather than just [W] and [D] because - * efficiency: silly to process the same thing twice - * inert_funeqs, inert_dicts is a finite map keyed by - the type; it's inconvenient for it to map to TWO constraints - -Note [Splitting WD constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are about to add a [WD] constraint to the inert set; and we -know that the inert set has fully rewritten it. Should we split -it into [W] and [D], and put the [D] in the work list for further -work? - -* CDictCan (C tys) or CFunEqCan (F tys ~ fsk): - Yes if the inert set could rewrite tys to make the class constraint, - or type family, fire. That is, yes if the inert_eqs intersects - with the free vars of tys. For this test we use - (anyRewritableTyVar True) which ignores casts and coercions in tys, - because rewriting the casts or coercions won't make the thing fire - more often. - -* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'. - We need to check both 'a' and 'ty' against the inert set: - - Inert set contains [D] a ~ ty2 - Then we want to put [D] a ~ ty in the worklist, so we'll - get [D] ty ~ ty2 with consequent good things - - - Inert set contains [D] b ~ a, where b is in ty. - We can't just add [WD] a ~ ty[b] to the inert set, because - that breaks the inert-set invariants. If we tried to - canonicalise another [D] constraint mentioning 'a', we'd - get an infinite loop - - Moreover we must use (anyRewritableTyVar False) for the RHS, - because even tyvars in the casts and coercions could give - an infinite loop if we don't expose it - -* Others: nothing is gained by splitting. - -Note [Examples of how Derived shadows helps completeness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Trac #10009, a very nasty example: - - f :: (UnF (F b) ~ b) => F b -> () - - g :: forall a. (UnF (F a) ~ a) => a -> () - g _ = f (undefined :: F a) - - For g we get [G] UnF (F a) ~ a - [WD] UnF (F beta) ~ beta - [WD] F a ~ F beta - Flatten: - [G] g1: F a ~ fsk1 fsk1 := F a - [G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1 - [G] g3: fsk2 ~ a - - [WD] w1: F beta ~ fmv1 - [WD] w2: UnF fmv1 ~ fmv2 - [WD] w3: fmv2 ~ beta - [WD] w4: fmv1 ~ fsk1 -- From F a ~ F beta using flat-cache - -- and re-orient to put meta-var on left - -Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2 -React that with g2: [D] d2: fmv2 ~ fsk2 -React that with w3: [D] beta ~ fsk2 - and g3: [D] beta ~ a -- Hooray beta := a -And that is enough to solve everything - -Note [Add derived shadows only for Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only add shadows for Wanted constraints. That is, we have -[WD] but not [GD]; and maybeEmitShaodw looks only at [WD] -constraints. - -It does just possibly make sense ot add a derived shadow for a -Given. If we created a Derived shadow of a Given, it could be -rewritten by other Deriveds, and that could, conceivably, lead to a -useful unification. - -But (a) I have been unable to come up with an example of this - happening - (b) see Trac #12660 for how adding the derived shadows - of a Given led to an infinite loop. - (c) It's unlikely that rewriting derived Givens will lead - to a unification because Givens don't mention touchable - unification variables - -For (b) there may be other ways to solve the loop, but simply -reraining from adding derived shadows of Givens is particularly -simple. And it's more efficient too! - -Still, here's one possible reason for adding derived shadows -for Givens. Consider - work-item [G] a ~ [b], inerts has [D] b ~ a. -If we added the derived shadow (into the work list) - [D] a ~ [b] -When we process it, we'll rewrite to a ~ [a] and get an -occurs check. Without it we'll miss the occurs check (reporting -inaccessible code); but that's probably OK. - -Note [Keep CDictCan shadows as CDictCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class C a => D a b -and [G] D a b, [G] C a in the inert set. Now we insert -[D] b ~ c. We want to kick out a derived shadow for [D] D a b, -so we can rewrite it with the new constraint, and perhaps get -instance reduction or other consequences. - -BUT we do not want to kick out a *non-canonical* (D a b). If we -did, we would do this: - - rewrite it to [D] D a c, with pend_sc = True - - use expandSuperClasses to add C a - - go round again, which solves C a from the givens -This loop goes on for ever and triggers the simpl_loop limit. - -Solution: kick out the CDictCan which will have pend_sc = False, -because we've already added its superclasses. So we won't re-add -them. If we forget the pend_sc flag, our cunning scheme for avoiding -generating superclasses repeatedly will fail. - -See Trac #11379 for a case of this. - -Note [Do not do improvement for WOnly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do improvement between two constraints (e.g. for injectivity -or functional dependencies) only if both are "improvable". And -we improve a constraint wrt the top-level instances only if -it is improvable. - -Improvable: [G] [WD] [D} -Not improvable: [W] - -Reasons: - -* It's less work: fewer pairs to compare - -* Every [W] has a shadow [D] so nothing is lost - -* Consider [WD] C Int b, where 'b' is a skolem, and - class C a b | a -> b - instance C Int Bool - We'll do a fundep on it and emit [D] b ~ Bool - That will kick out constraint [WD] C Int b - Then we'll split it to [W] C Int b (keep in inert) - and [D] C Int b (in work list) - When processing the latter we'll rewrite it to - [D] C Int Bool - At that point it would be /stupid/ to interact it - with the inert [W] C Int b in the inert set; after all, - it's the very constraint from which the [D] C Int Bool - was split! We can avoid this by not doing improvement - on [W] constraints. This came up in Trac #12860. --} - -maybeEmitShadow :: InertCans -> Ct -> TcS Ct --- See Note [The improvement story and derived shadows] -maybeEmitShadow ics ct - | let ev = ctEvidence ct - , CtWanted { ctev_pred = pred, ctev_loc = loc - , ctev_nosh = WDeriv } <- ev - , shouldSplitWD (inert_eqs ics) ct - = do { traceTcS "Emit derived shadow" (ppr ct) - ; let derived_ev = CtDerived { ctev_pred = pred - , ctev_loc = loc } - shadow_ct = ct { cc_ev = derived_ev } - -- Te shadow constraint keeps the canonical shape. - -- This just saves work, but is sometimes important; - -- see Note [Keep CDictCan shadows as CDictCan] - ; emitWork [shadow_ct] - - ; let ev' = ev { ctev_nosh = WOnly } - ct' = ct { cc_ev = ev' } - -- Record that it now has a shadow - -- This is /the/ place we set the flag to WOnly - ; return ct' } - - | otherwise - = return ct - -shouldSplitWD :: InertEqs -> Ct -> Bool --- Precondition: 'ct' is [WD], and is inert --- True <=> we should split ct ito [W] and [D] because --- the inert_eqs can make progress on the [D] --- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys }) - = should_split_match_args inert_eqs tys - -- We don't need to split if the tv is the RHS fsk - -shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys }) - = should_split_match_args inert_eqs tys - -- NB True: ignore coercions - -- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty }) - = tv `elemDVarEnv` inert_eqs - || anyRewritableTyVar False (`elemDVarEnv` inert_eqs) ty - -- NB False: do not ignore casts and coercions - -- See Note [Splitting WD constraints] - -shouldSplitWD _ _ = False -- No point in splitting otherwise - -should_split_match_args :: InertEqs -> [TcType] -> Bool --- True if the inert_eqs can rewrite anything in the argument --- types, ignoring casts and coercions -should_split_match_args inert_eqs tys - = any (anyRewritableTyVar True (`elemDVarEnv` inert_eqs)) tys - -- NB True: ignore casts coercions - -- See Note [Splitting WD constraints] - -isImprovable :: CtEvidence -> Bool --- See Note [Do not do improvement for WOnly] -isImprovable (CtWanted { ctev_nosh = WOnly }) = False -isImprovable _ = True - - -{- ********************************************************************* -* * - Inert equalities -* * -********************************************************************* -} - -addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs -addTyEq old_eqs tv ct - = extendDVarEnv_C add_eq old_eqs tv [ct] - where - add_eq old_eqs _ - | isWantedCt ct - , (eq1 : eqs) <- old_eqs - = eq1 : ct : eqs - | otherwise - = ct : old_eqs - -foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b -foldTyEqs k eqs z - = foldDVarEnv (\cts z -> foldr k z cts) z eqs - -findTyEqs :: InertCans -> TyVar -> EqualCtList -findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` [] - -delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs -delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv - where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1 - isThisOne _ = False - -lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType -lookupInertTyVar ieqs tv - = case lookupDVarEnv ieqs tv of - Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs - _ -> Nothing - -lookupFlattenTyVar :: InertEqs -> TcTyVar -> TcType --- See Note [lookupFlattenTyVar] -lookupFlattenTyVar ieqs ftv - = lookupInertTyVar ieqs ftv `orElse` mkTyVarTy ftv - -{- Note [lookupFlattenTyVar] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an injective function F and - inert_funeqs: F t1 ~ fsk1 - F t2 ~ fsk2 - inert_eqs: fsk1 ~ fsk2 - -We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to -get the [D] t1 ~ t2 from the injectiveness of F. So we look up the -cc_fsk of CFunEqCans in the inert_eqs when trying to find derived -equalities arising from injectivity. --} - - -{- ********************************************************************* -* * - Adding an inert -* * -************************************************************************ - -Note [Adding an equality to the InertCans] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When adding an equality to the inerts: - -* Split [WD] into [W] and [D] if the inerts can rewrite the latter; - done by maybeEmitShadow. - -* Kick out any constraints that can be rewritten by the thing - we are adding. Done by kickOutRewritable. - -* Note that unifying a:=ty, is like adding [G] a~ty; just use - kickOutRewritable with Nominal, Given. See kickOutAfterUnification. - -Note [Kicking out CFunEqCan for fundeps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - New: [D] fmv1 ~ fmv2 - Inert: [W] F alpha ~ fmv1 - [W] F beta ~ fmv2 - -where F is injective. The new (derived) equality certainly can't -rewrite the inerts. But we *must* kick out the first one, to get: - - New: [W] F alpha ~ fmv1 - Inert: [W] F beta ~ fmv2 - [D] fmv1 ~ fmv2 - -and now improvement will discover [D] alpha ~ beta. This is important; -eg in Trac #9587. - -So in kickOutRewritable we look at all the tyvars of the -CFunEqCan, including the fsk. --} - -addInertEq :: Ct -> TcS () --- This is a key function, because of the kick-out stuff --- Precondition: item /is/ canonical --- See Note [Adding an equality to the InertCans] -addInertEq ct - = do { traceTcS "addInertEq {" $ - text "Adding new inert equality:" <+> ppr ct - - ; ics <- getInertCans - - ; ct@(CTyEqCan { cc_tyvar = tv, cc_ev = ev }) <- maybeEmitShadow ics ct - - ; (_, ics1) <- kickOutRewritable (ctEvFlavourRole ev) tv ics - - ; let ics2 = ics1 { inert_eqs = addTyEq (inert_eqs ics1) tv ct - , inert_count = bumpUnsolvedCount ev (inert_count ics1) } - ; setInertCans ics2 - - ; traceTcS "addInertEq }" $ empty } - --------------- -addInertCan :: Ct -> TcS () -- Constraints *other than* equalities -addInertCan ct - = do { traceTcS "insertInertCan {" $ - text "Trying to insert new non-eq inert item:" <+> ppr ct - - ; ics <- getInertCans - ; ct <- maybeEmitShadow ics ct - ; setInertCans (add_item ics ct) - - ; traceTcS "addInertCan }" $ empty } - -add_item :: InertCans -> Ct -> InertCans -add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) - = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item } - -add_item ics item@(CIrredEvCan { cc_ev = ev }) - = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item - , inert_count = bumpUnsolvedCount ev (inert_count ics) } - -- The 'False' is because the irreducible constraint might later instantiate - -- to an equality. - -- But since we try to simplify first, if there's a constraint function FC with - -- type instance FC Int = Show - -- we'll reduce a constraint (FC Int a) to Show a, and never add an inert irreducible - -add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) - = ics { inert_dicts = addDict (inert_dicts ics) cls tys item - , inert_count = bumpUnsolvedCount ev (inert_count ics) } - -add_item _ item - = pprPanic "upd_inert set: can't happen! Inserting " $ - ppr item -- CTyEqCan is dealt with by addInertEq - -- Can't be CNonCanonical, CHoleCan, - -- because they only land in inert_insols - -bumpUnsolvedCount :: CtEvidence -> Int -> Int -bumpUnsolvedCount ev n | isWanted ev = n+1 - | otherwise = n - - ------------------------------------------ -kickOutRewritable :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> TcTyVar -- The new equality is tv ~ ty - -> InertCans - -> TcS (Int, InertCans) -kickOutRewritable new_fr new_tv ics - = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics - n_kicked = workListSize kicked_out - - ; unless (n_kicked == 0) $ - do { updWorkListTcS (appendWorkList kicked_out) - ; csTraceTcS $ - hang (text "Kick out, tv =" <+> ppr new_tv) - 2 (vcat [ text "n-kicked =" <+> int n_kicked - , text "kicked_out =" <+> ppr kicked_out - , text "Residual inerts =" <+> ppr ics' ]) } - - ; return (n_kicked, ics') } - -kick_out_rewritable :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> TcTyVar -- The new equality is tv ~ ty - -> InertCans - -> (WorkList, InertCans) --- See Note [kickOutRewritable] -kick_out_rewritable new_fr new_tv ics@(IC { inert_eqs = tv_eqs - , inert_dicts = dictmap - , inert_safehask = safehask - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_insols = insols - , inert_count = n }) - | not (new_fr `eqMayRewriteFR` new_fr) - = (emptyWorkList, ics) - -- If new_fr can't rewrite itself, it can't rewrite - -- anything else, so no need to kick out anything. - -- (This is a common case: wanteds can't rewrite wanteds) - -- Lemma (L2) in Note [Extending the inert equalities] - - | otherwise - = (kicked_out, inert_cans_in) - where - inert_cans_in = IC { inert_eqs = tv_eqs_in - , inert_dicts = dicts_in - , inert_safehask = safehask -- ?? - , inert_funeqs = feqs_in - , inert_irreds = irs_in - , inert_insols = insols_in - , inert_count = n - workListWantedCount kicked_out } - - kicked_out = WL { wl_eqs = tv_eqs_out - , wl_funeqs = feqs_out - , wl_deriv = [] - , wl_rest = bagToList (dicts_out `andCts` irs_out - `andCts` insols_out) - , wl_implics = emptyBag } - - (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs - (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap - -- See Note [Kicking out CFunEqCan for fundeps] - (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap - (irs_out, irs_in) = partitionBag kick_out_ct irreds - (insols_out, insols_in) = partitionBag kick_out_ct insols - -- Kick out even insolubles: See Note [Kick out insolubles] - - fr_may_rewrite :: CtFlavourRole -> Bool - fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs - -- Can the new item rewrite the inert item? - - kick_out_ct :: Ct -> Bool - -- Kick it out if the new CTyEqCan can rewrite the inert one - -- See Note [kickOutRewritable] - kick_out_ct ct | let ev = ctEvidence ct - = fr_may_rewrite (ctEvFlavourRole ev) - && anyRewritableTyVar False (== new_tv) (ctEvPred ev) - -- False: ignore casts and coercions - -- NB: this includes the fsk of a CFunEqCan. It can't - -- actually be rewritten, but we need to kick it out - -- so we get to take advantage of injectivity - -- See Note [Kicking out CFunEqCan for fundeps] - - kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList) - -> ([Ct], DTyVarEnv EqualCtList) - kick_out_eqs eqs (acc_out, acc_in) - = (eqs_out ++ acc_out, case eqs_in of - [] -> acc_in - (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in) - where - (eqs_in, eqs_out) = partition keep_eq eqs - - -- Implements criteria K1-K3 in Note [Extending the inert equalities] - keep_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty, cc_ev = ev - , cc_eq_rel = eq_rel }) - | tv == new_tv - = not (fr_may_rewrite fs) -- (K1) - - | otherwise - = check_k2 && check_k3 - where - fs = ctEvFlavourRole ev - check_k2 = not (fs `eqMayRewriteFR` fs) -- (K2a) - || (fs `eqMayRewriteFR` new_fr) -- (K2b) - || not (fr_may_rewrite fs) -- (K2c) - || not (new_tv `elemVarSet` tyCoVarsOfType rhs_ty) -- (K2d) - - check_k3 - | fr_may_rewrite fs - = case eq_rel of - NomEq -> not (rhs_ty `eqType` mkTyVarTy new_tv) - ReprEq -> not (isTyVarExposed new_tv rhs_ty) - - | otherwise - = True - - keep_eq ct = pprPanic "keep_eq" (ppr ct) - -kickOutAfterUnification :: TcTyVar -> TcS Int -kickOutAfterUnification new_tv - = do { ics <- getInertCans - ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq) - new_tv ics - -- Given because the tv := xi is given; NomEq because - -- only nominal equalities are solved by unification - - ; setInertCans ics2 - ; return n_kicked } - -{- Note [kickOutRewritable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [inert_eqs: the inert equalities]. - -When we add a new inert equality (a ~N ty) to the inert set, -we must kick out any inert items that could be rewritten by the -new equality, to maintain the inert-set invariants. - - - We want to kick out an existing inert constraint if - a) the new constraint can rewrite the inert one - b) 'a' is free in the inert constraint (so that it *will*) - rewrite it if we kick it out. - - For (b) we use tyCoVarsOfCt, which returns the type variables /and - the kind variables/ that are directly visible in the type. Hence - we will have exposed all the rewriting we care about to make the - most precise kinds visible for matching classes etc. No need to - kick out constraints that mention type variables whose kinds - contain this variable! - - - A Derived equality can kick out [D] constraints in inert_eqs, - inert_dicts, inert_irreds etc. - - - We don't kick out constraints from inert_solved_dicts, and - inert_solved_funeqs optimistically. But when we lookup we have to - take the substitution into account - - -Note [Kick out 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. --} - - - --------------- -addInertSafehask :: InertCans -> Ct -> InertCans -addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_safehask = addDict (inert_dicts ics) cls tys item } - -addInertSafehask _ item - = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item - -insertSafeOverlapFailureTcS :: Ct -> TcS () --- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -insertSafeOverlapFailureTcS item - = updInertCans (\ics -> addInertSafehask ics item) - -getSafeOverlapFailures :: TcS Cts --- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -getSafeOverlapFailures - = do { IC { inert_safehask = safehask } <- getInertCans - ; return $ foldDicts consCts safehask emptyCts } - --------------- -addSolvedDict :: CtEvidence -> Class -> [Type] -> TcS () --- Add a new item in the solved set of the monad --- See Note [Solved dictionaries] -addSolvedDict item cls tys - | isIPPred (ctEvPred item) -- Never cache "solved" implicit parameters (not sure why!) - = return () - | otherwise - = do { traceTcS "updSolvedSetTcs:" $ ppr item - ; updInertTcS $ \ ics -> - ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } } - -{- ********************************************************************* -* * - Other inert-set operations -* * -********************************************************************* -} - -updInertTcS :: (InertSet -> InertSet) -> TcS () --- Modify the inert set with the supplied function -updInertTcS upd_fn - = do { is_var <- getTcSInertsRef - ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var - ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } - -getInertCans :: TcS InertCans -getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) } - -setInertCans :: InertCans -> TcS () -setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics } - -updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a --- Modify the inert set with the supplied function -updRetInertCans upd_fn - = do { is_var <- getTcSInertsRef - ; wrapTcS (do { inerts <- TcM.readTcRef is_var - ; let (res, cans') = upd_fn (inert_cans inerts) - ; TcM.writeTcRef is_var (inerts { inert_cans = cans' }) - ; return res }) } - -updInertCans :: (InertCans -> InertCans) -> TcS () --- Modify the inert set with the supplied function -updInertCans upd_fn - = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } - -updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertDicts upd_fn - = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) } - -updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertSafehask upd_fn - = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) } - -updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertFunEqs upd_fn - = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) } - -updInertIrreds :: (Cts -> Cts) -> TcS () --- Modify the inert set with the supplied function -updInertIrreds upd_fn - = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) } - -getInertEqs :: TcS (DTyVarEnv EqualCtList) -getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } - -getInertInsols :: TcS Cts -getInertInsols = do { inert <- getInertCans; return (inert_insols inert) } - -getInertGivens :: TcS [Ct] --- Returns the Given constraints in the inert set, --- with type functions *not* unflattened -getInertGivens - = do { inerts <- getInertCans - ; let all_cts = foldDicts (:) (inert_dicts inerts) - $ foldFunEqs (:) (inert_funeqs inerts) - $ concat (dVarEnvElts (inert_eqs inerts)) - ; return (filter isGivenCt all_cts) } - -getPendingScDicts :: TcS [Ct] --- Find all inert Given dictionaries whose cc_pend_sc flag is True --- Set the flag to False in the inert set, and return that Ct -getPendingScDicts = updRetInertCans get_sc_dicts - where - get_sc_dicts ic@(IC { inert_dicts = dicts }) - = (sc_pend_dicts, ic') - where - ic' = ic { inert_dicts = foldr add dicts sc_pend_dicts } - - sc_pend_dicts :: [Ct] - sc_pend_dicts = foldDicts get_pending dicts [] - - get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc = True - -- but flipping the flag - get_pending dict dicts - | Just dict' <- isPendingScDict 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) - -getUnsolvedInerts :: TcS ( Bag Implication - , Cts -- Tyvar eqs: a ~ ty - , Cts -- Fun eqs: F a ~ ty - , Cts -- Insoluble - , Cts ) -- All others --- Return all the unsolved [Wanted] or [Derived] constraints --- --- Post-condition: the returned simple constraints are all fully zonked --- (because they come from the inert set) --- the unsolved implics may not be -getUnsolvedInerts - = do { IC { inert_eqs = tv_eqs - , inert_funeqs = fun_eqs - , inert_irreds = irreds - , inert_dicts = idicts - , inert_insols = insols - } <- getInertCans - - ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts - unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts - unsolved_irreds = Bag.filterBag is_unsolved irreds - unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts - unsolved_others = unsolved_irreds `unionBags` unsolved_dicts - unsolved_insols = filterBag is_unsolved insols - - ; implics <- getWorkListImplics - - ; traceTcS "getUnsolvedInerts" $ - vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs - , text "fun eqs =" <+> ppr unsolved_fun_eqs - , text "insols =" <+> ppr unsolved_insols - , text "others =" <+> ppr unsolved_others - , text "implics =" <+> ppr implics ] - - ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs - , unsolved_insols, unsolved_others) } - where - add_if_unsolved :: Ct -> Cts -> Cts - add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts - | otherwise = cts - - is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived - - -- For CFunEqCans we ignore the Derived ones, and keep - -- only the Wanteds for flattening. The Derived ones - -- share a unification variable with the corresponding - -- Wanted, so we definitely don't want to to participate - -- in unflattening - -- See Note [Type family equations] - add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts - | otherwise = cts - -isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool --- True if (a ~N ty) is in the inert set, in either Given or Wanted -isInInertEqs eqs tv rhs - = case lookupDVarEnv eqs tv of - Nothing -> False - Just cts -> any (same_pred rhs) cts - where - same_pred rhs ct - | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct - , NomEq <- eq_rel - , rhs `eqType` rhs2 = True - | otherwise = False - -getNoGivenEqs :: TcLevel -- TcLevel of this implication - -> [TcTyVar] -- Skolems of this implication - -> TcS ( Bool -- True <=> definitely no residual given equalities - , Cts ) -- Insoluble constraints arising from givens --- See Note [When does an implication have given equalities?] -getNoGivenEqs tclvl skol_tvs - = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = iirreds - , inert_funeqs = funeqs - , inert_insols = insols }) - <- getInertCans - ; let local_fsks = foldFunEqs add_fsk funeqs emptyVarSet - - has_given_eqs = foldrBag ((||) . ev_given_here . ctEvidence) False - (iirreds `unionBags` insols) - || anyDVarEnv (eqs_given_here local_fsks) ieqs - - ; traceTcS "getNoGivenEqs" (vcat [ ppr has_given_eqs, ppr inerts - , ppr insols]) - ; return (not has_given_eqs, insols) } - where - eqs_given_here :: VarSet -> EqualCtList -> Bool - eqs_given_here local_fsks [CTyEqCan { cc_tyvar = tv, cc_ev = ev }] - -- Givens are always a sigleton - = not (skolem_bound_here local_fsks tv) && ev_given_here ev - eqs_given_here _ _ = False - - ev_given_here :: CtEvidence -> Bool - -- True for a Given bound by the curent implication, - -- i.e. the current level - ev_given_here ev - = isGiven ev - && tclvl == ctLocLevel (ctEvLoc ev) - - add_fsk :: Ct -> VarSet -> VarSet - add_fsk ct fsks | CFunEqCan { cc_fsk = tv, cc_ev = ev } <- ct - , isGiven ev = extendVarSet fsks tv - | otherwise = fsks - - skol_tv_set = mkVarSet skol_tvs - skolem_bound_here local_fsks tv -- See Note [Let-bound skolems] - = case tcTyVarDetails tv of - SkolemTv {} -> tv `elemVarSet` skol_tv_set - FlatSkol {} -> not (tv `elemVarSet` local_fsks) - _ -> False - --- | Returns Given constraints that might, --- potentially, match the given pred. This is used when checking to see if a --- Given might overlap with an instance. See Note [Instance and Given overlap] --- in TcInteract. -matchableGivens :: CtLoc -> PredType -> InertSet -> Cts -matchableGivens loc_w pred (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 - = 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 - , Just _ <- tcUnifyTys bind_meta_tv [ctEvPred ctev] [pred] - , not (prohibitedSuperClassSolve loc_g loc_w) - = True - - | otherwise - = False - where - ctev = cc_ev ct - - bind_meta_tv :: TcTyVar -> BindFlag - -- Any meta tyvar may be unified later, so we treat it as - -- bindable when unifying with givens. That ensures that we - -- conservatively assume that a meta tyvar might get unified with - -- something that matches the 'given', until demonstrated - -- otherwise. - bind_meta_tv tv | isMetaTyVar tv = BindMe - | otherwise = Skolem - -prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool --- See Note [Solving superclass constraints] in TcInstDcls -prohibitedSuperClassSolve from_loc solve_loc - | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc - , ScOrigin wanted_size <- ctLocOrigin solve_loc - = given_size >= wanted_size - | otherwise - = False - -{- Note [Unsolved Derived equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In getUnsolvedInerts, we return a derived equality from the inert_eqs -because it is a candidate for floating out of this implication. We -only float equalities with a meta-tyvar on the left, so we only pull -those out here. - -Note [When does an implication have given equalities?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider an implication - beta => alpha ~ Int -where beta is a unification variable that has already been unified -to () in an outer scope. Then we can float the (alpha ~ Int) out -just fine. So when deciding whether the givens contain an equality, -we should canonicalise first, rather than just looking at the original -givens (Trac #8644). - -So we simply look at the inert, canonical Givens and see if there are -any equalities among them, the calculation of has_given_eqs. There -are some wrinkles: - - * We must know which ones are bound in *this* implication and which - are bound further out. We can find that out from the TcLevel - of the Given, which is itself recorded in the tcl_tclvl field - of the TcLclEnv stored in the Given (ev_given_here). - - What about interactions between inner and outer givens? - - Outer given is rewritten by an inner given, then there must - have been an inner given equality, hence the “given-eq” flag - will be true anyway. - - - Inner given rewritten by outer, retains its level (ie. The inner one) - - * We must take account of *potential* equalities, like the one above: - beta => ...blah... - If we still don't know what beta is, we conservatively treat it as potentially - becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs. - - * When flattening givens, we generate Given equalities like - : F [a] ~ f, - with Refl evidence, and we *don't* want those to count as an equality - in the givens! After all, the entire flattening business is just an - internal matter, and the evidence does not mention any of the 'givens' - of this implication. So we do not treat inert_funeqs as a 'given equality'. - - * See Note [Let-bound skolems] for another wrinkle - - * We do *not* need to worry about representational equalities, because - these do not affect the ability to float constraints. - -Note [Let-bound skolems] -~~~~~~~~~~~~~~~~~~~~~~~~ -If * the inert set contains a canonical Given CTyEqCan (a ~ ty) -and * 'a' is a skolem bound in this very implication, b - -then: -a) The Given is pretty much a let-binding, like - f :: (a ~ b->c) => a -> a - Here the equality constraint is like saying - let a = b->c in ... - It is not adding any new, local equality information, - and hence can be ignored by has_given_eqs - -b) 'a' will have been completely substituted out in the inert set, - so we can safely discard it. Notably, it doesn't need to be - returned as part of 'fsks' - -For an example, see Trac #9211. --} - -removeInertCts :: [Ct] -> InertCans -> InertCans --- ^ Remove inert constraints from the 'InertCans', for use when a --- typechecker plugin wishes to discard a given. -removeInertCts cts icans = foldl' removeInertCt icans cts - -removeInertCt :: InertCans -> Ct -> InertCans -removeInertCt is ct = - case ct of - - CDictCan { cc_class = cl, cc_tyargs = tys } -> - is { inert_dicts = delDict (inert_dicts is) cl tys } - - CFunEqCan { cc_fun = tf, cc_tyargs = tys } -> - is { inert_funeqs = delFunEq (inert_funeqs is) tf tys } - - CTyEqCan { cc_tyvar = x, cc_rhs = ty } -> - is { inert_eqs = delTyEq (inert_eqs is) x ty } - - CIrredEvCan {} -> panic "removeInertCt: CIrredEvCan" - CNonCanonical {} -> panic "removeInertCt: CNonCanonical" - CHoleCan {} -> panic "removeInertCt: CHoleCan" - - -lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour)) -lookupFlatCache fam_tc tys - = do { IS { inert_flat_cache = flat_cache - , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts - ; return (firstJusts [lookup_inerts inert_funeqs, - lookup_flats flat_cache]) } - where - lookup_inerts inert_funeqs - | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis }) - <- findFunEq inert_funeqs fam_tc tys - , tys `eqTypes` xis -- The lookup might find a near-match; see - -- Note [Use loose types in inert set] - = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev) - | otherwise = Nothing - - lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys - - -lookupInInerts :: TcPredType -> TcS (Maybe CtEvidence) --- Is this exact predicate type cached in the solved or canonicals of the InertSet? -lookupInInerts pty - | ClassPred cls tys <- classifyPredType pty - = do { inerts <- getTcSInerts - ; return (lookupSolvedDict inerts cls tys `mplus` - lookupInertDict (inert_cans inerts) cls tys) } - | otherwise -- NB: No caching for equalities, IPs, holes, or errors - = return Nothing - --- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not --- match the input exactly. Note [Use loose types in inert set]. -lookupInertDict :: InertCans -> Class -> [Type] -> Maybe CtEvidence -lookupInertDict (IC { inert_dicts = dicts }) cls tys - = case findDict dicts cls tys of - Just ct -> Just (ctEvidence ct) - _ -> Nothing - --- | Look up a solved inert. NB: the returned 'CtEvidence' might not --- match the input exactly. See Note [Use loose types in inert set]. -lookupSolvedDict :: InertSet -> Class -> [Type] -> Maybe CtEvidence --- Returns just if exactly this predicate type exists in the solved. -lookupSolvedDict (IS { inert_solved_dicts = solved }) cls tys - = case findDict solved cls tys of - Just ev -> Just ev - _ -> Nothing - -{- ********************************************************************* -* * - Irreds -* * -********************************************************************* -} - -foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b -foldIrreds k irreds z = foldrBag k z irreds - - -{- ********************************************************************* -* * - TcAppMap -* * -************************************************************************ - -Note [Use loose types in inert set] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly -solvable from the other. So, we do lookup in the inert set using -loose types, which omit the kind-check. - -We must be careful when using the result of a lookup because it may -not match the requsted info exactly! - --} - -type TcAppMap a = UniqDFM (ListMap LooseTypeMap a) - -- Indexed by tycon then the arg types, using "loose" matching, where - -- we don't require kind equality. This allows, for example, (a |> co) - -- to match (a). - -- See Note [Use loose types in inert set] - -- Used for types and classes; hence UniqDFM - -- See Note [foldTM determinism] for why we use UniqDFM here - -isEmptyTcAppMap :: TcAppMap a -> Bool -isEmptyTcAppMap m = isNullUDFM m - -emptyTcAppMap :: TcAppMap a -emptyTcAppMap = emptyUDFM - -findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a -findTcApp m u tys = do { tys_map <- lookupUDFM m u - ; lookupTM tys tys_map } - -delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a -delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls - -insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a -insertTcApp m cls tys ct = alterUDFM alter_tm m cls - where - alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) - --- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b --- mapTcApp f = mapUDFM (mapTM f) - -filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct -filterTcAppMap f m - = mapUDFM do_tm m - where - do_tm tm = foldTM insert_mb tm emptyTM - insert_mb ct tm - | f ct = insertTM tys ct tm - | otherwise = tm - where - tys = case ct of - CFunEqCan { cc_tyargs = tys } -> tys - CDictCan { cc_tyargs = tys } -> tys - _ -> pprPanic "filterTcAppMap" (ppr ct) - -tcAppMapToBag :: TcAppMap a -> Bag a -tcAppMapToBag m = foldTcAppMap consBag m emptyBag - -foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b -foldTcAppMap k m z = foldUDFM (foldTM k) z m - - -{- ********************************************************************* -* * - DictMap -* * -********************************************************************* -} - -type DictMap a = TcAppMap a - -emptyDictMap :: DictMap a -emptyDictMap = emptyTcAppMap - --- sizeDictMap :: DictMap a -> Int --- sizeDictMap m = foldDicts (\ _ x -> x+1) m 0 - -findDict :: DictMap a -> Class -> [Type] -> Maybe a -findDict m cls tys = findTcApp m (getUnique cls) tys - -findDictsByClass :: DictMap a -> Class -> Bag a -findDictsByClass m cls - | Just tm <- lookupUDFM m cls = foldTM consBag tm emptyBag - | otherwise = emptyBag - -delDict :: DictMap a -> Class -> [Type] -> DictMap a -delDict m cls tys = delTcApp m (getUnique cls) tys - -addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a -addDict m cls tys item = insertTcApp m (getUnique cls) tys item - -addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct -addDictsByClass m cls items - = addToUDFM m cls (foldrBag add emptyTM items) - where - add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm - add ct _ = pprPanic "addDictsByClass" (ppr ct) - -filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct -filterDicts f m = filterTcAppMap f m - -partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct) -partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts) - where - k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) - | otherwise = (yeses, add ct noes) - add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m - = addDict m cls tys ct - add ct _ = pprPanic "partitionDicts" (ppr ct) - -dictsToBag :: DictMap a -> Bag a -dictsToBag = tcAppMapToBag - -foldDicts :: (a -> b -> b) -> DictMap a -> b -> b -foldDicts = foldTcAppMap - -emptyDicts :: DictMap a -emptyDicts = emptyTcAppMap - - -{- ********************************************************************* -* * - FunEqMap -* * -********************************************************************* -} - -type FunEqMap a = TcAppMap a -- A map whose key is a (TyCon, [Type]) pair - -emptyFunEqs :: TcAppMap a -emptyFunEqs = emptyTcAppMap - -findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a -findFunEq m tc tys = findTcApp m (getUnique tc) tys - -funEqsToBag :: FunEqMap a -> Bag a -funEqsToBag m = foldTcAppMap consBag m emptyBag - -findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] --- Get inert function equation constraints that have the given tycon --- in their head. Not that the constraints remain in the inert set. --- We use this to check for derived interactions with built-in type-function --- constructors. -findFunEqsByTyCon m tc - | Just tm <- lookupUDFM m tc = foldTM (:) tm [] - | otherwise = [] - -foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b -foldFunEqs = foldTcAppMap - --- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b --- mapFunEqs = mapTcApp - --- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct --- filterFunEqs = filterTcAppMap - -insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a -insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val - -partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct) --- Optimise for the case where the predicate is false --- partitionFunEqs is called only from kick-out, and kick-out usually --- kicks out very few equalities, so we want to optimise for that case -partitionFunEqs f m = (yeses, foldr del m yeses) - where - yeses = foldTcAppMap k m [] - k ct yeses | f ct = ct : yeses - | otherwise = yeses - del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m - = delFunEq m tc tys - del ct _ = pprPanic "partitionFunEqs" (ppr ct) - -delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a -delFunEq m tc tys = delTcApp m (getUnique tc) tys - ------------------------------- -type ExactFunEqMap a = UniqFM (ListMap TypeMap a) - -emptyExactFunEqs :: ExactFunEqMap a -emptyExactFunEqs = emptyUFM - -findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a -findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc) - ; lookupTM tys tys_map } - -insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a -insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc) - where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM)) - -{- -************************************************************************ -* * -* The TcS solver monad * -* * -************************************************************************ - -Note [The TcS monad] -~~~~~~~~~~~~~~~~~~~~ -The TcS monad is a weak form of the main Tc monad - -All you can do is - * fail - * allocate new variables - * fill in evidence variables - -Filling in a dictionary evidence variable means to create a binding -for it, so TcS carries a mutable location where the binding can be -added. This is initialised from the innermost implication constraint. --} - -data TcSEnv - = TcSEnv { - tcs_ev_binds :: EvBindsVar, - - tcs_unified :: IORef Int, - -- The number of unification variables we have filled - -- The important thing is whether it is non-zero - - tcs_count :: IORef Int, -- Global step count - - tcs_inerts :: IORef InertSet, -- Current inert set - - -- The main work-list and the flattening worklist - -- See Note [Work list priorities] and - tcs_worklist :: IORef WorkList -- Current worklist - } - ---------------- -newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } - -instance Functor TcS where - fmap f m = TcS $ fmap f . unTcS m - -instance Applicative TcS where - pure x = TcS (\_ -> return x) - (<*>) = ap - -instance Monad TcS where - fail err = TcS (\_ -> fail err) - m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs) - -#if __GLASGOW_HASKELL__ > 710 -instance MonadFail.MonadFail TcS where - fail err = TcS (\_ -> fail err) -#endif - -instance MonadUnique TcS where - getUniqueSupplyM = wrapTcS getUniqueSupplyM - --- Basic functionality --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -wrapTcS :: TcM a -> TcS a --- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS, --- and TcS is supposed to have limited functionality -wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds - -wrapErrTcS :: TcM a -> TcS a --- The thing wrapped should just fail --- There's no static check; it's up to the user --- Having a variant for each error message is too painful -wrapErrTcS = wrapTcS - -wrapWarnTcS :: TcM a -> TcS a --- The thing wrapped should just add a warning, or no-op --- There's no static check; it's up to the user -wrapWarnTcS = wrapTcS - -failTcS, panicTcS :: SDoc -> TcS a -warnTcS :: WarningFlag -> SDoc -> TcS () -addErrTcS :: SDoc -> TcS () -failTcS = wrapTcS . TcM.failWith -warnTcS flag = wrapTcS . TcM.addWarn (Reason flag) -addErrTcS = wrapTcS . TcM.addErr -panicTcS doc = pprPanic "TcCanonical" doc - -traceTcS :: String -> SDoc -> TcS () -traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) - -runTcPluginTcS :: TcPluginM a -> TcS a -runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar - -instance HasDynFlags TcS where - getDynFlags = wrapTcS getDynFlags - -getGlobalRdrEnvTcS :: TcS GlobalRdrEnv -getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv - -bumpStepCountTcS :: TcS () -bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env - ; n <- TcM.readTcRef ref - ; TcM.writeTcRef ref (n+1) } - -csTraceTcS :: SDoc -> TcS () -csTraceTcS doc - = wrapTcS $ csTraceTcM (return doc) - -traceFireTcS :: CtEvidence -> SDoc -> TcS () --- Dump a rule-firing trace -traceFireTcS ev doc - = TcS $ \env -> csTraceTcM $ - do { n <- TcM.readTcRef (tcs_count env) - ; tclvl <- TcM.getTcLevel - ; return (hang (text "Step" <+> int n - <> brackets (text "l:" <> ppr tclvl <> comma <> - text "d:" <> ppr (ctLocDepth (ctEvLoc ev))) - <+> doc <> colon) - 4 (ppr ev)) } - -csTraceTcM :: TcM SDoc -> TcM () --- Constraint-solver tracing, -ddump-cs-trace -csTraceTcM mk_doc - = do { dflags <- getDynFlags - ; when ( dopt Opt_D_dump_cs_trace dflags - || dopt Opt_D_dump_tc_trace dflags ) - ( do { msg <- mk_doc - ; TcM.traceTcRn Opt_D_dump_cs_trace msg }) } - -runTcS :: TcS a -- What to run - -> TcM (a, EvBindMap) -runTcS tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; res <- runTcSWithEvBinds ev_binds_var tcs - ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var - ; return (res, ev_binds) } - --- | This variant of 'runTcS' will keep solving, even when only Deriveds --- are left around. It also doesn't return any evidence, as callers won't --- need it. -runTcSDeriveds :: TcS a -> TcM a -runTcSDeriveds tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds ev_binds_var tcs } - --- | This can deal only with equality constraints. -runTcSEqualities :: TcS a -> TcM a -runTcSEqualities thing_inside - = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds ev_binds_var thing_inside } - -runTcSWithEvBinds :: EvBindsVar - -> TcS a - -> TcM a -runTcSWithEvBinds ev_binds_var tcs - = do { unified_var <- TcM.newTcRef 0 - ; step_count <- TcM.newTcRef 0 - ; inert_var <- TcM.newTcRef emptyInert - ; wl_var <- TcM.newTcRef emptyWorkList - ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_unified = unified_var - , tcs_count = step_count - , tcs_inerts = inert_var - , tcs_worklist = wl_var } - - -- Run the computation - ; res <- unTcS tcs env - - ; count <- TcM.readTcRef step_count - ; when (count > 0) $ - csTraceTcM $ return (text "Constraint solver steps =" <+> int count) - -#ifdef DEBUG - ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var - ; checkForCyclicBinds ev_binds -#endif - - ; return res } - -#ifdef DEBUG -checkForCyclicBinds :: EvBindMap -> TcM () -checkForCyclicBinds ev_binds_map - | null cycles - = return () - | null coercion_cycles - = TcM.traceTc "Cycle in evidence binds" $ ppr cycles - | otherwise - = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles - where - ev_binds = evBindMapBinds ev_binds_map - - cycles :: [[EvBind]] - cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges] - - coercion_cycles = [c | c <- cycles, any is_co_bind c] - is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b) - - edges :: [(EvBind, EvVar, [EvVar])] - edges = [ (bind, bndr, nonDetEltsUniqSet (evVarsOfTerm rhs)) - | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ] - -- It's OK to use nonDetEltsUFM here as - -- stronglyConnCompFromEdgedVertices is still deterministic even - -- if the edges are in nondeterministic order as explained in - -- Note [Deterministic SCC] in Digraph. -#endif - -setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a -setEvBindsTcS ref (TcS thing_inside) - = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref }) - -nestImplicTcS :: EvBindsVar - -> TcLevel -> TcS a - -> TcS a -nestImplicTcS ref inner_tclvl (TcS thing_inside) - = TcS $ \ TcSEnv { tcs_unified = unified_var - , tcs_inerts = old_inert_var - , tcs_count = count - } -> - do { inerts <- TcM.readTcRef old_inert_var - ; let nest_inert = inerts { inert_flat_cache = emptyExactFunEqs } - -- See Note [Do not inherit the flat cache] - ; new_inert_var <- TcM.newTcRef nest_inert - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = TcSEnv { tcs_ev_binds = ref - , tcs_unified = unified_var - , tcs_count = count - , tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } - ; res <- TcM.setTcLevel inner_tclvl $ - thing_inside nest_env - -#ifdef DEBUG - -- Perform a check that the thing_inside did not cause cycles - ; ev_binds <- TcM.getTcEvBindsMap ref - ; checkForCyclicBinds ev_binds -#endif - ; return res } - -{- Note [Do not inherit the flat cache] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to inherit the flat cache when processing nested -implications. Consider - a ~ F b, forall c. b~Int => blah -If we have F b ~ fsk in the flat-cache, and we push that into the -nested implication, we might miss that F b can be rewritten to F Int, -and hence perhpas solve it. Moreover, the fsk from outside is -flattened out after solving the outer level, but and we don't -do that flattening recursively. --} - -nestTcS :: TcS a -> TcS a --- Use the current untouchables, augmenting the current --- evidence bindings, and solved dictionaries --- But have no effect on the InertCans, or on the inert_flat_cache --- (we want to inherit the latter from processing the Givens) -nestTcS (TcS thing_inside) - = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> - do { inerts <- TcM.readTcRef inerts_var - ; new_inert_var <- TcM.newTcRef inerts - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = env { tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } - - ; res <- thing_inside nest_env - - ; new_inerts <- TcM.readTcRef new_inert_var - - -- we want to propogate the safe haskell failures - ; let old_ic = inert_cans inerts - new_ic = inert_cans new_inerts - nxt_ic = old_ic { inert_safehask = inert_safehask new_ic } - - ; TcM.writeTcRef inerts_var -- See Note [Propagate the solved dictionaries] - (inerts { inert_solved_dicts = inert_solved_dicts new_inerts - , inert_cans = nxt_ic }) - - ; return res } - -buildImplication :: SkolemInfo - -> [TcTyVar] -- Skolems - -> [EvVar] -- Givens - -> TcS result - -> TcS (Bag Implication, TcEvBinds, result) --- Just like TcUnify.buildImplication, but in the TcS monnad, --- using the work-list to gather the constraints -buildImplication skol_info skol_tvs givens (TcS thing_inside) - = TcS $ \ env -> - do { new_wl_var <- TcM.newTcRef emptyWorkList - ; tc_lvl <- TcM.getTcLevel - ; let new_tclvl = pushTcLevel tc_lvl - - ; res <- TcM.setTcLevel new_tclvl $ - thing_inside (env { tcs_worklist = new_wl_var }) - - ; wl@WL { wl_eqs = eqs } <- TcM.readTcRef new_wl_var - ; if null eqs - then return (emptyBag, emptyTcEvBinds, res) - else - do { env <- TcM.getLclEnv - ; ev_binds_var <- TcM.newTcEvBinds - ; let wc = ASSERT2( null (wl_funeqs wl) && null (wl_rest wl) && - null (wl_deriv wl) && null (wl_implics wl), ppr wl ) - WC { wc_simple = listToCts eqs - , wc_impl = emptyBag - , wc_insol = emptyCts } - imp = Implic { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_no_eqs = True - , ic_given = givens - , ic_wanted = wc - , ic_status = IC_Unsolved - , ic_binds = ev_binds_var - , ic_env = env - , ic_needed = emptyVarSet - , ic_info = skol_info } - ; return (unitBag imp, TcEvBinds ev_binds_var, res) } } - -{- -Note [Propagate the solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's really quite important that nestTcS does not discard the solved -dictionaries from the thing_inside. -Consider - Eq [a] - forall b. empty => Eq [a] -We solve the simple (Eq [a]), under nestTcS, and then turn our attention to -the implications. It's definitely fine to use the solved dictionaries on -the inner implications, and it can make a signficant performance difference -if you do so. --} - --- Getters and setters of TcEnv fields --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- Getter of inerts and worklist -getTcSInertsRef :: TcS (IORef InertSet) -getTcSInertsRef = TcS (return . tcs_inerts) - -getTcSWorkListRef :: TcS (IORef WorkList) -getTcSWorkListRef = TcS (return . tcs_worklist) - -getTcSInerts :: TcS InertSet -getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) - -setTcSInerts :: InertSet -> TcS () -setTcSInerts ics = do { r <- getTcSInertsRef; wrapTcS (TcM.writeTcRef r ics) } - -getWorkListImplics :: TcS (Bag Implication) -getWorkListImplics - = do { wl_var <- getTcSWorkListRef - ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) - ; return (wl_implics wl_curr) } - -updWorkListTcS :: (WorkList -> WorkList) -> TcS () -updWorkListTcS f - = do { wl_var <- getTcSWorkListRef - ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) - ; let new_work = f wl_curr - ; wrapTcS (TcM.writeTcRef wl_var new_work) } - -emitWorkNC :: [CtEvidence] -> TcS () -emitWorkNC evs - | null evs - = return () - | otherwise - = emitWork (map mkNonCanonical evs) - -emitWork :: [Ct] -> TcS () -emitWork cts - = do { traceTcS "Emitting fresh work" (vcat (map ppr cts)) - ; updWorkListTcS (extendWorkListCts cts) } - -emitInsoluble :: Ct -> TcS () --- Emits a non-canonical constraint that will stand for a frozen error in the inerts. -emitInsoluble ct - = do { traceTcS "Emit insoluble" (ppr ct $$ pprCtLoc (ctLoc ct)) - ; updInertTcS add_insol } - where - this_pred = ctPred ct - add_insol is@(IS { inert_cans = ics@(IC { inert_insols = old_insols }) }) - | already_there = is - | otherwise = is { inert_cans = ics { inert_insols = old_insols `snocCts` ct } } - where - already_there = not (isWantedCt ct) && anyBag (tcEqType this_pred . ctPred) old_insols - -- See Note [Do not add duplicate derived insolubles] - -newTcRef :: a -> TcS (TcRef a) -newTcRef x = wrapTcS (TcM.newTcRef x) - -readTcRef :: TcRef a -> TcS a -readTcRef ref = wrapTcS (TcM.readTcRef ref) - -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 - -getTcEvBindsAndTCVs :: EvBindsVar -> TcS (EvBindMap, TyCoVarSet) -getTcEvBindsAndTCVs ev_binds_var - = wrapTcS $ do { bnds <- TcM.getTcEvBindsMap ev_binds_var - ; tcvs <- TcM.getTcEvTyCoVars ev_binds_var - ; return (bnds, tcvs) } - -getTcEvBindsMap :: TcS EvBindMap -getTcEvBindsMap - = do { ev_binds_var <- getTcEvBindsVar - ; wrapTcS $ TcM.getTcEvBindsMap ev_binds_var } - -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) } - -unflattenFmv :: TcTyVar -> TcType -> TcS () --- Fill a flatten-meta-var, simply by unifying it. --- This does NOT count as a unification in tcs_unified. -unflattenFmv tv ty - = ASSERT2( isMetaTyVar tv, ppr tv ) - TcS $ \ _ -> - do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty) - ; TcM.writeMetaTyVar tv ty } - -reportUnifications :: TcS a -> TcS (Int, a) -reportUnifications (TcS thing_inside) - = TcS $ \ env -> - do { inner_unified <- TcM.newTcRef 0 - ; res <- thing_inside (env { tcs_unified = inner_unified }) - ; n_unifs <- TcM.readTcRef inner_unified - ; TcM.updTcRef (tcs_unified env) (+ n_unifs) - ; return (n_unifs, res) } - -getDefaultInfo :: TcS ([Type], (Bool, Bool)) -getDefaultInfo = wrapTcS TcM.tcGetDefaultTys - --- Just get some environments needed for instance looking up and matching --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -getInstEnvs :: TcS InstEnvs -getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs - -getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) -getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs - -getTopEnv :: TcS HscEnv -getTopEnv = wrapTcS $ TcM.getTopEnv - -getGblEnv :: TcS TcGblEnv -getGblEnv = wrapTcS $ TcM.getGblEnv - -getLclEnv :: TcS TcLclEnv -getLclEnv = wrapTcS $ TcM.getLclEnv - -tcLookupClass :: Name -> TcS Class -tcLookupClass c = wrapTcS $ TcM.tcLookupClass c - -tcLookupId :: Name -> TcS Id -tcLookupId n = wrapTcS $ TcM.tcLookupId n - --- Setting names as used (used in the deriving of Coercible evidence) --- Too hackish to expose it to TcS? In that case somehow extract the used --- constructors from the result of solveInteract -addUsedGREs :: [GlobalRdrElt] -> TcS () -addUsedGREs gres = wrapTcS $ TcM.addUsedGREs gres - -addUsedGRE :: Bool -> GlobalRdrElt -> TcS () -addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre - - --- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -checkWellStagedDFun :: PredType -> DFunId -> CtLoc -> TcS () -checkWellStagedDFun pred dfun_id loc - = wrapTcS $ TcM.setCtLocM loc $ - do { use_stage <- TcM.getStage - ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) } - where - pp_thing = text "instance for" <+> quotes (ppr pred) - bind_lvl = TcM.topIdLvl dfun_id - -pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2 - -isTouchableMetaTyVarTcS :: TcTyVar -> TcS Bool -isTouchableMetaTyVarTcS tv - = do { tclvl <- getTcLevel - ; return $ isTouchableMetaTyVar tclvl tv } - -isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) -isFilledMetaTyVar_maybe tv - = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } - -> do { cts <- wrapTcS (TcM.readTcRef ref) - ; case cts of - Indirect ty -> return (Just ty) - Flexi -> return Nothing } - _ -> return Nothing - -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) - -{- -Note [Do not add duplicate derived insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we *must* add an insoluble (Int ~ Bool) even if there is -one such there already, because they may come from distinct call -sites. Not only do we want an error message for each, but with --fdefer-type-errors we must generate evidence for each. But for -*derived* insolubles, we only want to report each one once. Why? - -(a) A constraint (C r s t) where r -> s, say, may generate the same fundep - equality many times, as the original constraint is successively rewritten. - -(b) Ditto the successive iterations of the main solver itself, as it traverses - the constraint tree. See example below. - -Also for *given* insolubles we may get repeated errors, as we -repeatedly traverse the constraint tree. These are relatively rare -anyway, so removing duplicates seems ok. (Alternatively we could take -the SrcLoc into account.) - -Note that the test does not need to be particularly efficient because -it is only used if the program has a type error anyway. - -Example of (b): assume a top-level class and instance declaration: - - class D a b | a -> b - instance D [a] [a] - -Assume we have started with an implication: - - forall c. Eq c => { wc_simple = D [c] c [W] } - -which we have simplified to: - - forall c. Eq c => { wc_simple = D [c] c [W] - , wc_insols = (c ~ [c]) [D] } - -For some reason, e.g. because we floated an equality somewhere else, -we might try to re-solve this implication. If we do not do a -dropDerivedWC, then we will end up trying to solve the following -constraints the second time: - - (D [c] c) [W] - (c ~ [c]) [D] - -which will result in two Deriveds to end up in the insoluble set: - - wc_simple = D [c] c [W] - wc_insols = (c ~ [c]) [D], (c ~ [c]) [D] --} - --- Flatten skolems --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -newFlattenSkolem :: CtFlavour -> CtLoc - -> TyCon -> [TcType] -- F xis - -> TcS (CtEvidence, Coercion, TcTyVar) -- [G/WD] x:: F xis ~ fsk -newFlattenSkolem flav loc tc xis - = do { stuff@(ev, co, fsk) <- new_skolem - ; let fsk_ty = mkTyVarTy fsk - ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev) - ; return stuff } - where - fam_ty = mkTyConApp tc xis - - new_skolem - | Given <- flav - = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty) - ; let co = mkNomReflCo fam_ty - ; ev <- newGivenEvVar loc (mkPrimEqPred fam_ty (mkTyVarTy fsk), - EvCoercion co) - ; return (ev, co, fsk) } - - | otherwise -- Generate a [WD] for both Wanted and Derived - -- See Note [No Derived CFunEqCans] - = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty) - ; (ev, hole_co) <- newWantedEq loc Nominal fam_ty (mkTyVarTy fmv) - ; return (ev, hole_co, fmv) } - -extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS () -extendFlatCache tc xi_args stuff@(_, ty, fl) - | isGivenOrWDeriv fl -- Maintain the invariant that inert_flat_cache - -- only has [G] and [WD] CFunEqCans - = do { dflags <- getDynFlags - ; when (gopt Opt_FlatCache dflags) $ - do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args - , ppr fl, ppr ty ]) - -- 'co' can be bottom, in the case of derived items - ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) -> - is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } } - - | otherwise - = return () - --- 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) - -demoteUnfilledFmv :: TcTyVar -> TcS () --- If a flatten-meta-var is still un-filled, --- turn it into an ordinary meta-var -demoteUnfilledFmv fmv - = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv - ; unless is_filled $ - do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv) - ; TcM.writeMetaTyVar fmv tv_ty } } - -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) - ; return (extendTvSubst subst tv ty') } - -tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) - -- ^ How to instantiate the type variables - -> Id -- ^ Type to instantiate - -> TcS ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result - -- (type vars, preds (incl equalities), rho) -tcInstType inst_tyvars id = wrapTcS (TcM.tcInstType inst_tyvars id) - -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 EvTerm - -isFresh :: MaybeNew -> Bool -isFresh (Fresh {}) = True -isFresh (Cached {}) = False - -freshGoals :: [MaybeNew] -> [CtEvidence] -freshGoals mns = [ ctev | Fresh ctev <- mns ] - -getEvTerm :: MaybeNew -> EvTerm -getEvTerm (Fresh ctev) = ctEvTerm ctev -getEvTerm (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 vars - = do { EvBindsVar { ebv_tcvs = ref } <- getTcEvBindsVar - ; wrapTcS $ - do { tcvs <- TcM.readTcRef ref - ; let tcvs' = tcvs `unionVarSet` vars - ; TcM.writeTcRef ref tcvs' } } - --- | Equalities only -setWantedEq :: TcEvDest -> Coercion -> TcS () -setWantedEq (HoleDest hole) co - = do { useVars (coVarsOfCo co) - ; wrapTcS $ TcM.fillCoercionHole hole co } -setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev) - --- | Equalities only -setEqIfWanted :: CtEvidence -> Coercion -> TcS () -setEqIfWanted (CtWanted { ctev_dest = dest }) co = setWantedEq dest co -setEqIfWanted _ _ = return () - --- | Good for equalities and non-equalities -setWantedEvTerm :: TcEvDest -> EvTerm -> TcS () -setWantedEvTerm (HoleDest hole) tm - = do { let co = evTermCoercion tm - ; useVars (coVarsOfCo co) - ; wrapTcS $ TcM.fillCoercionHole hole co } -setWantedEvTerm (EvVarDest ev) tm = setWantedEvBind ev tm - -setWantedEvBind :: EvVar -> EvTerm -> TcS () -setWantedEvBind ev_id tm = setEvBind (mkWantedEvBind ev_id tm) - -setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () -setEvBindIfWanted ev tm - = case ev of - CtWanted { ctev_dest = dest } - -> setWantedEvTerm dest tm - _ -> return () - -newTcEvBinds :: TcS EvBindsVar -newTcEvBinds = wrapTcS TcM.newTcEvBinds - -newEvVar :: TcPredType -> TcS EvVar -newEvVar pred = wrapTcS (TcM.newEvVar pred) - -newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence --- Make a new variable of the given PredType, --- immediately bind it to the given term --- and return its CtEvidence --- See Note [Bind new Givens immediately] in TcRnTypes -newGivenEvVar loc (pred, rhs) - = do { new_ev <- newBoundEvVarId pred rhs - ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) } - --- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the --- given term -newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar -newBoundEvVarId pred rhs - = do { new_ev <- newEvVar pred - ; setEvBind (mkGivenEvBind new_ev rhs) - ; return new_ev } - -newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] -newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts - -emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion --- | Emit a new Wanted equality into the work-list -emitNewWantedEq loc role ty1 ty2 - | otherwise - = do { (ev, co) <- newWantedEq loc role ty1 ty2 - ; updWorkListTcS $ - extendWorkListEq (mkNonCanonical ev) - ; return co } - --- | Make a new equality CtEvidence -newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion) -newWantedEq loc role ty1 ty2 - = do { hole <- wrapTcS $ TcM.newCoercionHole - ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty) - ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole - , ctev_nosh = WDeriv - , ctev_loc = loc} - , mkHoleCo hole role ty1 ty2 ) } - where - pty = mkPrimEqPredRole role ty1 ty2 - --- no equalities here. Use newWantedEq instead -newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence --- Don't look up in the solved/inerts; we know it's not there -newWantedEvVarNC loc pty - = do { new_ev <- newEvVar pty - ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ - pprCtLoc loc) - ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev - , ctev_nosh = WDeriv - , ctev_loc = loc })} - -newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew --- For anything except ClassPred, this is the same as newWantedEvVarNC -newWantedEvVar loc pty - = do { mb_ct <- lookupInInerts pty - ; case mb_ct of - Just ctev - | not (isDerived ctev) - -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev - ; return $ Cached (ctEvTerm ctev) } - _ -> do { ctev <- newWantedEvVarNC loc pty - ; return (Fresh ctev) } } - --- deals with both equalities and non equalities. Tries to look --- up non-equalities in the cache -newWanted :: CtLoc -> PredType -> TcS MaybeNew -newWanted loc pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = Fresh . fst <$> newWantedEq loc role ty1 ty2 - | otherwise - = newWantedEvVar loc pty - --- deals with both equalities and non equalities. Doesn't do any cache lookups. -newWantedNC :: CtLoc -> PredType -> TcS CtEvidence -newWantedNC loc pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = fst <$> newWantedEq loc role ty1 ty2 - | otherwise - = newWantedEvVarNC loc pty - -emitNewDerived :: CtLoc -> TcPredType -> TcS () -emitNewDerived loc pred - = do { ev <- newDerivedNC loc pred - ; traceTcS "Emitting new derived" (ppr ev) - ; updWorkListTcS (extendWorkListDerived loc ev) } - -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 loc 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 (extendWorkListDerived loc ev) } - -newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence -newDerivedNC loc pred - = do { -- checkReductionDepth loc pred - ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) } - --- --------- Check done in TcInteract.selectNewWorkItem???? --------- --- | Checks if the depth of the given location is too much. Fails if --- it's too big, with an appropriate error message. -checkReductionDepth :: CtLoc -> TcType -- ^ type being reduced - -> TcS () -checkReductionDepth loc ty - = do { dflags <- getDynFlags - ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $ - wrapErrTcS $ - solverDepthErrorTcS loc ty } - -matchFam :: TyCon -> [Type] -> TcS (Maybe (Coercion, TcType)) -matchFam tycon args = wrapTcS $ matchFamTcM tycon args - -matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (Coercion, TcType)) --- Given (F tys) return (ty, co), where co :: F tys ~ ty -matchFamTcM tycon args - = do { fam_envs <- FamInst.tcGetFamInstEnvs - ; let match_fam_result - = reduceTyFamApp_maybe fam_envs Nominal tycon args - ; TcM.traceTc "matchFamTcM" $ - vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args) - , ppr_res match_fam_result ] - ; return match_fam_result } - where - ppr_res Nothing = text "Match failed" - ppr_res (Just (co,ty)) = hang (text "Match succeeded:") - 2 (vcat [ text "Rewrites to:" <+> ppr ty - , text "Coercion:" <+> ppr co ]) - -{- -Note [Residual implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wl_implics in the WorkList are the residual implication -constraints that are generated while solving or canonicalising the -current worklist. Specifically, when canonicalising - (forall a. t1 ~ forall a. t2) -from which we get the implication - (forall a. t1 ~ t2) -See TcSMonad.deferTcSForAllEq --} - diff --git a/typecheck/TcSigs.hs b/typecheck/TcSigs.hs deleted file mode 100644 --- a/typecheck/TcSigs.hs +++ /dev/null @@ -1,773 +0,0 @@ -{- -(c) The University of Glasgow 2006-2012 -(c) The GRASP Project, Glasgow University, 1992-2002 - --} - -{-# LANGUAGE CPP #-} - -module TcSigs( - TcSigInfo(..), - TcIdSigInfo(..), TcIdSigInst, - TcPatSynInfo(..), - TcSigFun, - - isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName, - completeSigPolyId_maybe, - - tcTySigs, tcUserTypeSig, completeSigFromId, - tcInstSig, - - TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv, - mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags - ) where - -#include "HsVersions.h" - -import HsSyn -import TcHsType -import TcRnTypes -import TcRnMonad -import TcType -import TcMType -import TcValidity ( checkValidType ) -import TcUnify( tcSkolemise, unifyType, noThing ) -import Inst( topInstantiate ) -import TcEnv( tcLookupId ) -import TcEvidence( HsWrapper, (<.>) ) -import Type( mkTyVarBinders ) - -import DynFlags -import Var ( TyVar, tyVarName, tyVarKind ) -import Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) -import PrelNames( mkUnboundName ) -import BasicTypes -import Bag( foldrBag ) -import Module( getModule ) -import Name -import NameEnv -import VarSet -import Outputable -import SrcLoc -import Util( singleton ) -import Maybes( orElse ) -import Data.Maybe( mapMaybe ) -import Control.Monad( unless ) - - -{- ------------------------------------------------------------- - Note [Overview of type signatures] ----------------------------------------------------------------- -Type signatures, including partial signatures, are jolly tricky, -especially on value bindings. Here's an overview. - - f :: forall a. [a] -> [a] - g :: forall b. _ -> b - - f = ...g... - g = ...f... - -* HsSyn: a signature in a binding starts of as a TypeSig, in - type HsBinds.Sig - -* When starting a mutually recursive group, like f/g above, we - call tcTySig on each signature in the group. - -* tcTySig: Sig -> TcIdSigInfo - - For a /complete/ signature, like 'f' above, tcTySig kind-checks - the HsType, producing a Type, and wraps it in a CompleteSig, and - extend the type environment with this polymorphic 'f'. - - - For a /partial/signature, like 'g' above, tcTySig does nothing - Instead it just wraps the pieces in a PartialSig, to be handled - later. - -* tcInstSig: TcIdSigInfo -> TcIdSigInst - In tcMonoBinds, when looking at an individual binding, we use - tcInstSig to instantiate the signature forall's in the signature, - and attribute that instantiated (monomorphic) type to the - binder. You can see this in TcBinds.tcLhsId. - - The instantiation does the obvious thing for complete signatures, - but for /partial/ signatures it starts from the HsSyn, so it - has to kind-check it etc: tcHsPartialSigType. It's convenient - to do this at the same time as instantiation, because we can - make the wildcards into unification variables right away, raather - than somehow quantifying over them. And the "TcLevel" of those - unification variables is correct because we are in tcMonoBinds. - - -Note [Scoped tyvars] -~~~~~~~~~~~~~~~~~~~~ -The -XScopedTypeVariables flag brings lexically-scoped type variables -into scope for any explicitly forall-quantified type variables: - f :: forall a. a -> a - f x = e -Then 'a' is in scope inside 'e'. - -However, we do *not* support this - - For pattern bindings e.g - f :: forall a. a->a - (f,g) = e - -Note [Binding scoped type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type variables *brought into lexical scope* by a type signature -may be a subset of the *quantified type variables* of the signatures, -for two reasons: - -* With kind polymorphism a signature like - f :: forall f a. f a -> f a - may actually give rise to - f :: forall k. forall (f::k -> *) (a:k). f a -> f a - So the sig_tvs will be [k,f,a], but only f,a are scoped. - NB: the scoped ones are not necessarily the *inital* ones! - -* Even aside from kind polymorphism, there may be more instantiated - type variables than lexically-scoped ones. For example: - type T a = forall b. b -> (a,b) - f :: forall c. T c - Here, the signature for f will have one scoped type variable, c, - but two instantiated type variables, c' and b'. - -However, all of this only applies to the renamer. The typechecker -just puts all of them into the type environment; any lexical-scope -errors were dealt with by the renamer. - --} - - -{- ********************************************************************* -* * - Utility functions for TcSigInfo -* * -********************************************************************* -} - -tcIdSigName :: TcIdSigInfo -> Name -tcIdSigName (CompleteSig { sig_bndr = id }) = idName id -tcIdSigName (PartialSig { psig_name = n }) = n - -tcSigInfoName :: TcSigInfo -> Name -tcSigInfoName (TcIdSig idsi) = tcIdSigName idsi -tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi - -completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId -completeSigPolyId_maybe sig - | TcIdSig sig_info <- sig - , CompleteSig { sig_bndr = id } <- sig_info = Just id - | otherwise = Nothing - - -{- ********************************************************************* -* * - Typechecking user signatures -* * -********************************************************************* -} - -tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun) -tcTySigs hs_sigs - = checkNoErrs $ -- See Note [Fail eagerly on bad signatures] - do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs - ; let ty_sigs = concat ty_sigs_s - poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs - -- The returned [TcId] are the ones for which we have - -- a complete type signature. - -- See Note [Complete and partial type signatures] - env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs] - ; return (poly_ids, lookupNameEnv env) } - -tcTySig :: LSig Name -> TcM [TcSigInfo] -tcTySig (L _ (IdSig id)) - = do { let ctxt = FunSigCtxt (idName id) False - -- False: do not report redundant constraints - -- The user has no control over the signature! - sig = completeSigFromId ctxt id - ; return [TcIdSig sig] } - -tcTySig (L loc (TypeSig names sig_ty)) - = setSrcSpan loc $ - do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name) - | L _ name <- names ] - ; return (map TcIdSig sigs) } - -tcTySig (L loc (PatSynSig names sig_ty)) - = setSrcSpan loc $ - do { tpsigs <- sequence [ tcPatSynSig name sig_ty - | L _ name <- names ] - ; return (map TcPatSynSig tpsigs) } - -tcTySig _ = return [] - - -tcUserTypeSig :: SrcSpan -> LHsSigWcType Name -> Maybe Name -> TcM TcIdSigInfo --- A function or expression type signature --- Returns a fully quantified type signature; even the wildcards --- are quantified with ordinary skolems that should be instantiated --- --- The SrcSpan is what to declare as the binding site of the --- any skolems in the signature. For function signatures we --- use the whole `f :: ty' signature; for expression signatures --- just the type part. --- --- Just n => Function type signature name :: type --- Nothing => Expression type signature :: type -tcUserTypeSig loc hs_sig_ty mb_name - | isCompleteHsSig hs_sig_ty - = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty - ; return $ - CompleteSig { sig_bndr = mkLocalId name sigma_ty - , sig_ctxt = ctxt_T - , sig_loc = loc } } - -- Location of the in f :: - - -- Partial sig with wildcards - | otherwise - = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty - , sig_ctxt = ctxt_F, sig_loc = loc }) - where - name = case mb_name of - Just n -> n - Nothing -> mkUnboundName (mkVarOcc "") - ctxt_F = case mb_name of - Just n -> FunSigCtxt n False - Nothing -> ExprSigCtxt - ctxt_T = case mb_name of - Just n -> FunSigCtxt n True - Nothing -> ExprSigCtxt - - - -completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo --- Used for instance methods and record selectors -completeSigFromId ctxt id - = CompleteSig { sig_bndr = id - , sig_ctxt = ctxt - , sig_loc = getSrcSpan id } - -isCompleteHsSig :: LHsSigWcType Name -> Bool --- ^ If there are no wildcards, return a LHsSigType -isCompleteHsSig (HsWC { hswc_wcs = wcs }) = null wcs - -{- Note [Fail eagerly on bad signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a type signature is wrong, fail immediately: - - * the type sigs may bind type variables, so proceeding without them - can lead to a cascade of errors - - * the type signature might be ambiguous, in which case checking - the code against the signature will give a very similar error - to the ambiguity error. - -ToDo: this means we fall over if any type sig -is wrong (eg at the top level of the module), -which is over-conservative --} - -{- ********************************************************************* -* * - Type checking a pattern synonym signature -* * -************************************************************************ - -Note [Pattern synonym signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Pattern synonym signatures are surprisingly tricky (see Trac #11224 for example). -In general they look like this: - - pattern P :: forall univ_tvs. req_theta - => forall ex_tvs. prov_theta - => arg1 -> .. -> argn -> res_ty - -For parsing and renaming we treat the signature as an ordinary LHsSigType. - -Once we get to type checking, we decompose it into its parts, in tcPatSynSig. - -* Note that 'forall univ_tvs' and 'req_theta =>' - and 'forall ex_tvs' and 'prov_theta =>' - are all optional. We gather the pieces at the the top of tcPatSynSig - -* Initially the implicitly-bound tyvars (added by the renamer) include both - universal and existential vars. - -* After we kind-check the pieces and convert to Types, we do kind generalisation. - -Note [The pattern-synonym signature splitting rule] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a pattern signature, we must split - the kind-generalised variables, and - the implicitly-bound variables -into universal and existential. The rule is this -(see discussion on Trac #11224): - - The universal tyvars are the ones mentioned in - - univ_tvs: the user-specified (forall'd) universals - - req_theta - - res_ty - The existential tyvars are all the rest - -For example - - pattern P :: () => b -> T a - pattern P x = ... - -Here 'a' is universal, and 'b' is existential. But there is a wrinkle: -how do we split the arg_tys from req_ty? Consider - - pattern Q :: () => b -> S c -> T a - pattern Q x = ... - -This is an odd example because Q has only one syntactic argument, and -so presumably is defined by a view pattern matching a function. But -it can happen (Trac #11977, #12108). - -We don't know Q's arity from the pattern signature, so we have to wait -until we see the pattern declaration itself before deciding res_ty is, -and hence which variables are existential and which are universal. - -And that in turn is why TcPatSynInfo has a separate field, -patsig_implicit_bndrs, to capture the implicitly bound type variables, -because we don't yet know how to split them up. - -It's a slight compromise, because it means we don't really know the -pattern synonym's real signature until we see its declaration. So, -for example, in hs-boot file, we may need to think what to do... -(eg don't have any implicitly-bound variables). --} - -tcPatSynSig :: Name -> LHsSigType Name -> TcM TcPatSynInfo -tcPatSynSig name sig_ty - | HsIB { hsib_vars = implicit_hs_tvs - , hsib_body = hs_ty } <- sig_ty - , (univ_hs_tvs, hs_req, hs_ty1) <- splitLHsSigmaTy hs_ty - , (ex_hs_tvs, hs_prov, hs_body_ty) <- splitLHsSigmaTy hs_ty1 - = do { (implicit_tvs, (univ_tvs, req, ex_tvs, prov, body_ty)) - <- solveEqualities $ - tcImplicitTKBndrs implicit_hs_tvs $ - tcExplicitTKBndrs univ_hs_tvs $ \ univ_tvs -> - tcExplicitTKBndrs ex_hs_tvs $ \ ex_tvs -> - do { req <- tcHsContext hs_req - ; prov <- tcHsContext hs_prov - ; body_ty <- tcHsOpenType hs_body_ty - -- A (literal) pattern can be unlifted; - -- e.g. pattern Zero <- 0# (Trac #12094) - ; let bound_tvs - = unionVarSets [ allBoundVariabless req - , allBoundVariabless prov - , allBoundVariables body_ty - ] - ; return ( (univ_tvs, req, ex_tvs, prov, body_ty) - , bound_tvs) } - - -- Kind generalisation - ; kvs <- kindGeneralize $ - build_patsyn_type [] implicit_tvs univ_tvs req - ex_tvs prov body_ty - - -- These are /signatures/ so we zonk to squeeze out any kind - -- unification variables. Do this after quantifyTyVars which may - -- default kind variables to *. - ; traceTc "about zonk" empty - ; implicit_tvs <- mapM zonkTcTyCoVarBndr implicit_tvs - ; univ_tvs <- mapM zonkTcTyCoVarBndr univ_tvs - ; ex_tvs <- mapM zonkTcTyCoVarBndr ex_tvs - ; req <- zonkTcTypes req - ; prov <- zonkTcTypes prov - ; body_ty <- zonkTcType body_ty - - -- Now do validity checking - ; checkValidType ctxt $ - build_patsyn_type kvs implicit_tvs univ_tvs req ex_tvs prov body_ty - - -- arguments become the types of binders. We thus cannot allow - -- levity polymorphism here - ; let (arg_tys, _) = tcSplitFunTys body_ty - ; mapM_ (checkForLevPoly empty) arg_tys - - ; traceTc "tcTySig }" $ - vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs - , text "kvs" <+> ppr_tvs kvs - , text "univ_tvs" <+> ppr_tvs univ_tvs - , text "req" <+> ppr req - , text "ex_tvs" <+> ppr_tvs ex_tvs - , text "prov" <+> ppr prov - , text "body_ty" <+> ppr body_ty ] - ; return (TPSI { patsig_name = name - , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs ++ - mkTyVarBinders Specified implicit_tvs - , patsig_univ_bndrs = univ_tvs - , patsig_req = req - , patsig_ex_bndrs = ex_tvs - , patsig_prov = prov - , patsig_body_ty = body_ty }) } - where - ctxt = PatSynCtxt name - - build_patsyn_type kvs imp univ req ex prov body - = mkInvForAllTys kvs $ - mkSpecForAllTys (imp ++ univ) $ - mkFunTys req $ - mkSpecForAllTys ex $ - mkFunTys prov $ - body - -ppr_tvs :: [TyVar] -> SDoc -ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) - | tv <- tvs]) - - -{- ********************************************************************* -* * - Instantiating user signatures -* * -********************************************************************* -} - - -tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst --- Instantiate a type signature; only used with plan InferGen -tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) - = setSrcSpan loc $ -- Set the binding site of the tyvars - do { (tv_prs, theta, tau) <- tcInstType newMetaSigTyVars poly_id - -- See Note [Pattern bindings and complete signatures] - - ; return (TISI { sig_inst_sig = sig - , sig_inst_skols = tv_prs - , sig_inst_wcs = [] - , sig_inst_wcx = Nothing - , sig_inst_theta = theta - , sig_inst_tau = tau }) } - -tcInstSig sig@(PartialSig { psig_hs_ty = hs_ty - , sig_ctxt = ctxt - , sig_loc = loc }) - = setSrcSpan loc $ -- Set the binding site of the tyvars - do { (wcs, wcx, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty - ; return (TISI { sig_inst_sig = sig - , sig_inst_skols = map (\tv -> (tyVarName tv, tv)) tvs - , sig_inst_wcs = wcs - , sig_inst_wcx = wcx - , sig_inst_theta = theta - , sig_inst_tau = tau }) } - - -{- Note [Pattern bindings and complete signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = MkT a a - f :: forall a. a->a - g :: forall b. b->b - MkT f g = MkT (\x->x) (\y->y) -Here we'll infer a type from the pattern of 'T a', but if we feed in -the signature types for f and g, we'll end up unifying 'a' and 'b' - -So we instantiate f and g's signature with SigTv skolems -(newMetaSigTyVars) that can unify with each other. If too much -unification takes place, we'll find out when we do the final -impedance-matching check in TcBinds.mkExport - -See Note [Signature skolems] in TcType - -None of this applies to a function binding with a complete -signature, which doesn't use tcInstSig. See TcBinds.tcPolyCheck. --} - -{- ********************************************************************* -* * - Pragmas and PragEnv -* * -********************************************************************* -} - -type TcPragEnv = NameEnv [LSig Name] - -emptyPragEnv :: TcPragEnv -emptyPragEnv = emptyNameEnv - -lookupPragEnv :: TcPragEnv -> Name -> [LSig Name] -lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] - -extendPragEnv :: TcPragEnv -> (Name, LSig Name) -> TcPragEnv -extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig - ---------------- -mkPragEnv :: [LSig Name] -> LHsBinds Name -> TcPragEnv -mkPragEnv sigs binds - = foldl extendPragEnv emptyNameEnv prs - where - prs = mapMaybe get_sig sigs - - get_sig :: LSig Name -> Maybe (Name, LSig Name) - get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl)) - get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl)) - get_sig (L l (SCCFunSig st lnm@(L _ nm) str)) = Just (nm, L l $ SCCFunSig st lnm str) - get_sig _ = Nothing - - add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function - | Inline <- inl_inline inl_prag - -- add arity only for real INLINE pragmas, not INLINABLE - = case lookupNameEnv ar_env n of - Just ar -> inl_prag { inl_sat = Just ar } - Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n ) - -- There really should be a binding for every INLINE pragma - inl_prag - | otherwise - = inl_prag - - -- ar_env maps a local to the arity of its definition - ar_env :: NameEnv Arity - ar_env = foldrBag lhsBindArity emptyNameEnv binds - -lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity -lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env - = extendNameEnv env (unLoc id) (matchGroupArity ms) -lhsBindArity _ env = env -- PatBind/VarBind - - ------------------ -addInlinePrags :: TcId -> [LSig Name] -> TcM TcId -addInlinePrags poly_id prags_for_me - | inl@(L _ prag) : inls <- inl_prags - = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) - ; unless (null inls) (warn_multiple_inlines inl inls) - ; return (poly_id `setInlinePragma` prag) } - | otherwise - = return poly_id - where - inl_prags = [L loc prag | L loc (InlineSig _ prag) <- prags_for_me] - - warn_multiple_inlines _ [] = return () - - warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls) - | inlinePragmaActivation prag1 == inlinePragmaActivation prag2 - , isEmptyInlineSpec (inlinePragmaSpec prag1) - = -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop - -- and inl2 is a user NOINLINE pragma; we don't want to complain - warn_multiple_inlines inl2 inls - | otherwise - = setSrcSpan loc $ - addWarnTc NoReason - (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) - 2 (vcat (text "Ignoring all but the first" - : map pp_inl (inl1:inl2:inls)))) - - pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) - - -{- ********************************************************************* -* * - SPECIALISE pragmas -* * -************************************************************************ - -Note [Handling SPECIALISE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea is this: - - foo :: Num a => a -> b -> a - {-# SPECIALISE foo :: Int -> b -> Int #-} - -We check that - (forall a b. Num a => a -> b -> a) - is more polymorphic than - forall b. Int -> b -> Int -(for which we could use tcSubType, but see below), generating a HsWrapper -to connect the two, something like - wrap = /\b. Int b dNumInt -This wrapper is put in the TcSpecPrag, in the ABExport record of -the AbsBinds. - - - f :: (Eq a, Ix b) => a -> b -> Bool - {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} - f = - -From this the typechecker generates - - AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds - - SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX - -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) - -From these we generate: - - Rule: forall p, q, (dp:Ix p), (dq:Ix q). - f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq - - Spec bind: f_spec = wrap_fn - -Note that - - * The LHS of the rule may mention dictionary *expressions* (eg - $dfIxPair dp dq), and that is essential because the dp, dq are - needed on the RHS. - - * The RHS of f_spec, has a *copy* of 'binds', so that it - can fully specialise it. - - - -From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE: - - f_spec :: Int -> b -> Int - f_spec = wrap - - RULE: forall b (d:Num b). f b d = f_spec b - -The RULE is generated by taking apart the HsWrapper, which is a little -delicate, but works. - -Some wrinkles - -1. We don't use full-on tcSubType, because that does co and contra - variance and that in turn will generate too complex a LHS for the - RULE. So we use a single invocation of skolemise / - topInstantiate in tcSpecWrapper. (Actually I think that even - the "deeply" stuff may be too much, because it introduces lambdas, - though I think it can be made to work without too much trouble.) - -2. We need to take care with type families (Trac #5821). Consider - type instance F Int = Bool - f :: Num a => a -> F a - {-# SPECIALISE foo :: Int -> Bool #-} - - We *could* try to generate an f_spec with precisely the declared type: - f_spec :: Int -> Bool - f_spec = Int dNumInt |> co - - RULE: forall d. f Int d = f_spec |> sym co - - but the 'co' and 'sym co' are (a) playing no useful role, and (b) are - hard to generate. At all costs we must avoid this: - RULE: forall d. f Int d |> co = f_spec - because the LHS will never match (indeed it's rejected in - decomposeRuleLhs). - - So we simply do this: - - Generate a constraint to check that the specialised type (after - skolemiseation) is equal to the instantiated function type. - - But *discard* the evidence (coercion) for that constraint, - so that we ultimately generate the simpler code - f_spec :: Int -> F Int - f_spec = Int dNumInt - - RULE: forall d. f Int d = f_spec - You can see this discarding happening in - -3. Note that the HsWrapper can transform *any* function with the right - type prefix - forall ab. (Eq a, Ix b) => XXX - regardless of XXX. It's sort of polymorphic in XXX. This is - useful: we use the same wrapper to transform each of the class ops, as - well as the dict. That's what goes on in TcInstDcls.mk_meth_spec_prags --} - -tcSpecPrags :: Id -> [LSig Name] - -> TcM [LTcSpecPrag] --- Add INLINE and SPECIALSE pragmas --- INLINE prags are added to the (polymorphic) Id directly --- SPECIALISE prags are passed to the desugarer via TcSpecPrags --- Pre-condition: the poly_id is zonked --- Reason: required by tcSubExp -tcSpecPrags poly_id prag_sigs - = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) - ; unless (null bad_sigs) warn_discarded_sigs - ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } - where - spec_sigs = filter isSpecLSig prag_sigs - bad_sigs = filter is_bad_sig prag_sigs - is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) - - warn_discarded_sigs - = addWarnTc NoReason - (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) - 2 (vcat (map (ppr . getLoc) bad_sigs))) - --------------- -tcSpecPrag :: TcId -> Sig Name -> TcM [TcSpecPrag] -tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl) --- See Note [Handling SPECIALISE pragmas] --- --- The Name fun_name in the SpecSig may not be the same as that of the poly_id --- Example: SPECIALISE for a class method: the Name in the SpecSig is --- for the selector Id, but the poly_id is something like $cop --- However we want to use fun_name in the error message, since that is --- what the user wrote (Trac #8537) - = addErrCtxt (spec_ctxt prag) $ - do { warnIf NoReason (not (isOverloadedTy poly_ty || isInlinePragma inl)) - (text "SPECIALISE pragma for non-overloaded function" - <+> quotes (ppr fun_name)) - -- Note [SPECIALISE pragmas] - ; spec_prags <- mapM tc_one hs_tys - ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) - ; return spec_prags } - where - name = idName poly_id - poly_ty = idType poly_id - spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag) - - tc_one hs_ty - = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty - ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty spec_ty - ; return (SpecPrag poly_id wrap inl) } - -tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag) - --------------- -tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper --- A simpler variant of tcSubType, used for SPECIALISE pragmas --- See Note [Handling SPECIALISE pragmas], wrinkle 1 -tcSpecWrapper ctxt poly_ty spec_ty - = do { (sk_wrap, inst_wrap) - <- tcSkolemise ctxt spec_ty $ \ _ spec_tau -> - do { (inst_wrap, tau) <- topInstantiate orig poly_ty - ; _ <- unifyType noThing spec_tau tau - -- Deliberately ignore the evidence - -- See Note [Handling SPECIALISE pragmas], - -- wrinkle (2) - ; return inst_wrap } - ; return (sk_wrap <.> inst_wrap) } - where - orig = SpecPragOrigin ctxt - --------------- -tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] --- SPECIALISE pragmas for imported things -tcImpPrags prags - = do { this_mod <- getModule - ; dflags <- getDynFlags - ; if (not_specialising dflags) then - return [] - else do - { pss <- mapAndRecoverM (wrapLocM tcImpSpec) - [L loc (name,prag) - | (L loc prag@(SpecSig (L _ name) _ _)) <- prags - , not (nameIsLocalOrFrom this_mod name) ] - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } } - where - -- Ignore SPECIALISE pragmas for imported things - -- when we aren't specialising, or when we aren't generating - -- code. The latter happens when Haddocking the base library; - -- we don't wnat complaints about lack of INLINABLE pragmas - not_specialising dflags - | not (gopt Opt_Specialise dflags) = True - | otherwise = case hscTarget dflags of - HscNothing -> True - HscInterpreted -> True - _other -> False - -tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag] -tcImpSpec (name, prag) - = do { id <- tcLookupId name - ; unless (isAnyInlinePragma (idInlinePragma id)) - (addWarnTc NoReason (impSpecErr name)) - ; tcSpecPrag id prag } - -impSpecErr :: Name -> SDoc -impSpecErr name - = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) - 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma" - , parens $ sep - [ text "or its defining module" <+> quotes (ppr mod) - , text "was compiled without -O"]]) - where - mod = nameModule name diff --git a/typecheck/TcSimplify.hs b/typecheck/TcSimplify.hs deleted file mode 100644 --- a/typecheck/TcSimplify.hs +++ /dev/null @@ -1,2278 +0,0 @@ -{-# LANGUAGE CPP #-} - -module TcSimplify( - simplifyInfer, InferMode(..), - growThetaTyVars, - simplifyAmbiguityCheck, - simplifyDefault, - simplifyTop, simplifyTopImplic, captureTopConstraints, - simplifyInteractive, solveEqualities, - simplifyWantedsTcM, - tcCheckSatisfiability, - - -- For Rules we need these - solveWanteds, solveWantedsAndDrop, - approximateWC, runTcSDeriveds - ) where - -#include "HsVersions.h" - -import Bag -import Class ( Class, classKey, classTyCon ) -import DynFlags ( WarningFlag ( Opt_WarnMonomorphism ) - , WarnReason ( Reason ) - , DynFlags( solverIterations ) ) -import Id ( idType ) -import Inst -import ListSetOps -import Maybes -import Name -import Outputable -import PrelInfo -import PrelNames -import TcErrors -import TcEvidence -import TcInteract -import TcCanonical ( makeSuperClasses ) -import TcMType as TcM -import TcRnMonad as TcM -import TcSMonad as TcS -import TcType -import TrieMap () -- DV: for now -import Type -import TysWiredIn ( liftedRepTy ) -import Unify ( tcMatchTyKi ) -import Util -import Var -import VarSet -import UniqSet -import BasicTypes ( IntWithInf, intGtLimit ) -import ErrUtils ( emptyMessages ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.List ( partition ) - -{- -********************************************************************************* -* * -* External interface * -* * -********************************************************************************* --} - -captureTopConstraints :: TcM a -> TcM (a, WantedConstraints) --- (captureTopConstraints m) runs m, and returns the type constraints it --- generates plus the constraints produced by static forms inside. --- If it fails with an exception, it reports any insolubles --- (out of scope variables) before doing so -captureTopConstraints thing_inside - = do { static_wc_var <- TcM.newTcRef emptyWC ; - ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $ - TcM.tryCaptureConstraints thing_inside - ; stWC <- TcM.readTcRef static_wc_var - - -- See TcRnMonad Note [Constraints and errors] - -- If the thing_inside threw an exception, but generated some insoluble - -- constraints, report the latter before propagating the exception - -- Otherwise they will be lost altogether - ; case mb_res of - Right res -> return (res, lie `andWC` stWC) - Left {} -> do { _ <- reportUnsolved lie; failM } } - -- This call to reportUnsolved is the reason - -- this function is here instead of TcRnMonad - -simplifyTopImplic :: Bag Implication -> TcM () -simplifyTopImplic implics - = do { empty_binds <- simplifyTop (mkImplicWC implics) - - -- Since all the inputs are implications the returned bindings will be empty - ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds ) - - ; return () } - -simplifyTop :: WantedConstraints -> TcM (Bag EvBind) --- Simplify top-level constraints --- Usually these will be implications, --- but when there is nothing to quantify we don't wrap --- in a degenerate implication, so we do that here instead -simplifyTop wanteds - = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds - ; ((final_wc, unsafe_ol), binds1) <- runTcS $ - do { final_wc <- simpl_top wanteds - ; unsafe_ol <- getSafeOverlapFailures - ; return (final_wc, unsafe_ol) } - ; traceTc "End simplifyTop }" empty - - ; traceTc "reportUnsolved {" empty - ; binds2 <- reportUnsolved final_wc - ; traceTc "reportUnsolved }" empty - - ; traceTc "reportUnsolved (unsafe overlapping) {" empty - ; unless (isEmptyCts unsafe_ol) $ do { - -- grab current error messages and clear, warnAllUnsolved will - -- update error messages which we'll grab and then restore saved - -- messages. - ; errs_var <- getErrsVar - ; saved_msg <- TcM.readTcRef errs_var - ; TcM.writeTcRef errs_var emptyMessages - - ; warnAllUnsolved $ WC { wc_simple = unsafe_ol - , wc_insol = emptyCts - , wc_impl = emptyBag } - - ; whyUnsafe <- fst <$> TcM.readTcRef errs_var - ; TcM.writeTcRef errs_var saved_msg - ; recordUnsafeInfer whyUnsafe - } - ; traceTc "reportUnsolved (unsafe overlapping) }" empty - - ; return (evBindMapBinds binds1 `unionBags` binds2) } - --- | Type-check a thing that emits only equality constraints, then --- solve those constraints. Fails outright if there is trouble. -solveEqualities :: TcM a -> TcM a -solveEqualities thing_inside - = checkNoErrs $ -- See Note [Fail fast on kind errors] - do { (result, wanted) <- captureConstraints thing_inside - ; traceTc "solveEqualities {" $ text "wanted = " <+> ppr wanted - ; final_wc <- runTcSEqualities $ simpl_top wanted - ; traceTc "End solveEqualities }" empty - - ; traceTc "reportAllUnsolved {" empty - ; reportAllUnsolved final_wc - ; traceTc "reportAllUnsolved }" empty - ; return result } - -simpl_top :: WantedConstraints -> TcS WantedConstraints - -- See Note [Top-level Defaulting Plan] -simpl_top wanteds - = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds) - -- This is where the main work happens - ; try_tyvar_defaulting wc_first_go } - where - try_tyvar_defaulting :: WantedConstraints -> TcS WantedConstraints - try_tyvar_defaulting wc - | isEmptyWC wc - = return wc - | otherwise - = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc) - ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs - -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked - -- filter isMetaTyVar: we might have runtime-skolems in GHCi, - -- and we definitely don't want to try to assign to those! - -- The isTyVar is needed to weed out coercion variables - - ; defaulted <- mapM defaultTyVarTcS meta_tvs -- Has unification side effects - ; if or defaulted - then do { wc_residual <- nestTcS (solveWanteds wc) - -- See Note [Must simplify after defaulting] - ; try_class_defaulting wc_residual } - else try_class_defaulting wc } -- No defaulting took place - - try_class_defaulting :: WantedConstraints -> TcS WantedConstraints - try_class_defaulting wc - | isEmptyWC wc - = return wc - | otherwise -- See Note [When to do type-class defaulting] - = do { something_happened <- applyDefaultingRules wc - -- See Note [Top-level Defaulting Plan] - ; if something_happened - then do { wc_residual <- nestTcS (solveWantedsAndDrop wc) - ; try_class_defaulting wc_residual } - -- See Note [Overview of implicit CallStacks] in TcEvidence - else try_callstack_defaulting wc } - - try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints - try_callstack_defaulting wc - | isEmptyWC wc - = return wc - | otherwise - = defaultCallStacks wc - --- | Default any remaining @CallStack@ constraints to empty @CallStack@s. -defaultCallStacks :: WantedConstraints -> TcS WantedConstraints --- See Note [Overview of implicit CallStacks] in TcEvidence -defaultCallStacks wanteds - = do simples <- handle_simples (wc_simple wanteds) - mb_implics <- mapBagM handle_implic (wc_impl wanteds) - return (wanteds { wc_simple = simples - , wc_impl = catBagMaybes mb_implics }) - - where - - handle_simples simples - = catBagMaybes <$> mapBagM defaultCallStack simples - - handle_implic :: Implication -> TcS (Maybe Implication) - -- The Maybe is because solving the CallStack constraint - -- may well allow us to discard the implication entirely - handle_implic implic - | isSolvedStatus (ic_status implic) - = return (Just implic) - | otherwise - = do { wanteds <- setEvBindsTcS (ic_binds implic) $ - -- defaultCallStack sets a binding, so - -- we must set the correct binding group - defaultCallStacks (ic_wanted implic) - ; setImplicationStatus (implic { ic_wanted = wanteds }) } - - defaultCallStack ct - | Just _ <- isCallStackPred (ctPred ct) - = do { solveCallStack (cc_ev ct) EvCsEmpty - ; return Nothing } - - defaultCallStack ct - = return (Just ct) - - -{- Note [Fail fast on kind errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -solveEqualities is used to solve kind equalities when kind-checking -user-written types. If solving fails we should fail outright, rather -than just accumulate an error message, for two reasons: - - * A kind-bogus type signature may cause a cascade of knock-on - errors if we let it pass - - * More seriously, we don't have a convenient term-level place to add - deferred bindings for unsolved kind-equality constraints, so we - don't build evidence bindings (by usine reportAllUnsolved). That - means that we'll be left with with a type that has coercion holes - in it, something like - |> co-hole - where co-hole is not filled in. Eeek! That un-filled-in - hole actually causes GHC to crash with "fvProv falls into a hole" - See Trac #11563, #11520, #11516, #11399 - -So it's important to use 'checkNoErrs' here! - -Note [When to do type-class defaulting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC -was false, on the grounds that defaulting can't help solve insoluble -constraints. But if we *don't* do defaulting we may report a whole -lot of errors that would be solved by defaulting; these errors are -quite spurious because fixing the single insoluble error means that -defaulting happens again, which makes all the other errors go away. -This is jolly confusing: Trac #9033. - -So it seems better to always do type-class defaulting. - -However, always doing defaulting does mean that we'll do it in -situations like this (Trac #5934): - run :: (forall s. GenST s) -> Int - run = fromInteger 0 -We don't unify the return type of fromInteger with the given function -type, because the latter involves foralls. So we're left with - (Num alpha, alpha ~ (forall s. GenST s) -> Int) -Now we do defaulting, get alpha := Integer, and report that we can't -match Integer with (forall s. GenST s) -> Int. That's not totally -stupid, but perhaps a little strange. - -Another potential alternative would be to suppress *all* non-insoluble -errors if there are *any* insoluble errors, anywhere, but that seems -too drastic. - -Note [Must simplify after defaulting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may have a deeply buried constraint - (t:*) ~ (a:Open) -which we couldn't solve because of the kind incompatibility, and 'a' is free. -Then when we default 'a' we can solve the constraint. And we want to do -that before starting in on type classes. We MUST do it before reporting -errors, because it isn't an error! Trac #7967 was due to this. - -Note [Top-level Defaulting Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have considered two design choices for where/when to apply defaulting. - (i) Do it in SimplCheck mode only /whenever/ you try to solve some - simple constraints, maybe deep inside the context of implications. - This used to be the case in GHC 7.4.1. - (ii) Do it in a tight loop at simplifyTop, once all other constraints have - finished. This is the current story. - -Option (i) had many disadvantages: - a) Firstly, it was deep inside the actual solver. - b) Secondly, it was dependent on the context (Infer a type signature, - or Check a type signature, or Interactive) since we did not want - to always start defaulting when inferring (though there is an exception to - this, see Note [Default while Inferring]). - c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs: - f :: Int -> Bool - f x = const True (\y -> let w :: a -> a - w a = const a (y+1) - in w y) - We will get an implication constraint (for beta the type of y): - [untch=beta] forall a. 0 => Num beta - which we really cannot default /while solving/ the implication, since beta is - untouchable. - -Instead our new defaulting story is to pull defaulting out of the solver loop and -go with option (ii), implemented at SimplifyTop. Namely: - - First, have a go at solving the residual constraint of the whole - program - - Try to approximate it with a simple constraint - - Figure out derived defaulting equations for that simple constraint - - Go round the loop again if you did manage to get some equations - -Now, that has to do with class defaulting. However there exists type variable /kind/ -defaulting. Again this is done at the top-level and the plan is: - - At the top-level, once you had a go at solving the constraint, do - figure out /all/ the touchable unification variables of the wanted constraints. - - Apply defaulting to their kinds - -More details in Note [DefaultTyVar]. - -Note [Safe Haskell Overlapping Instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Safe Haskell, we apply an extra restriction to overlapping instances. The -motive is to prevent untrusted code provided by a third-party, changing the -behavior of trusted code through type-classes. This is due to the global and -implicit nature of type-classes that can hide the source of the dictionary. - -Another way to state this is: if a module M compiles without importing another -module N, changing M to import N shouldn't change the behavior of M. - -Overlapping instances with type-classes can violate this principle. However, -overlapping instances aren't always unsafe. They are just unsafe when the most -selected dictionary comes from untrusted code (code compiled with -XSafe) and -overlaps instances provided by other modules. - -In particular, in Safe Haskell at a call site with overlapping instances, we -apply the following rule to determine if it is a 'unsafe' overlap: - - 1) Most specific instance, I1, defined in an `-XSafe` compiled module. - 2) I1 is an orphan instance or a MPTC. - 3) At least one overlapped instance, Ix, is both: - A) from a different module than I1 - B) Ix is not marked `OVERLAPPABLE` - -This is a slightly involved heuristic, but captures the situation of an -imported module N changing the behavior of existing code. For example, if -condition (2) isn't violated, then the module author M must depend either on a -type-class or type defined in N. - -Secondly, when should these heuristics be enforced? We enforced them when the -type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. -This allows `-XUnsafe` modules to operate without restriction, and for Safe -Haskell inferrence to infer modules with unsafe overlaps as unsafe. - -One alternative design would be to also consider if an instance was imported as -a `safe` import or not and only apply the restriction to instances imported -safely. However, since instances are global and can be imported through more -than one path, this alternative doesn't work. - -Note [Safe Haskell Overlapping Instances Implementation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -How is this implemented? It's complicated! So we'll step through it all: - - 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where - we check if a particular type-class method call is safe or unsafe. We do this - through the return type, `ClsInstLookupResult`, where the last parameter is a - list of instances that are unsafe to overlap. When the method call is safe, - the list is null. - - 2) `TcInteract.matchClassInst` -- This module drives the instance resolution - / dictionary generation. The return type is `LookupInstResult`, which either - says no instance matched, or one found, and if it was a safe or unsafe - overlap. - - 3) `TcInteract.doTopReactDict` -- Takes a dictionary / class constraint and - tries to resolve it by calling (in part) `matchClassInst`. The resolving - mechanism has a work list (of constraints) that it process one at a time. If - the constraint can't be resolved, it's added to an inert set. When compiling - an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know - compilation should fail. These are handled as normal constraint resolution - failures from here-on (see step 6). - - Otherwise, we may be inferring safety (or using `-Wunsafe`), and - compilation should succeed, but print warnings and/or mark the compiled module - as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds - the unsafe (but resolved!) constraint to the `inert_safehask` field of - `InertCans`. - - 4) `TcSimplify.simplifyTop`: - * Call simpl_top, the top-level function for driving the simplifier for - constraint resolution. - - * Once finished, call `getSafeOverlapFailures` to retrieve the - list of overlapping instances that were successfully resolved, - but unsafe. Remember, this is only applicable for generating warnings - (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy` - cause compilation failure by not resolving the unsafe constraint at all. - - * For unresolved constraints (all types), call `TcErrors.reportUnsolved`, - while for resolved but unsafe overlapping dictionary constraints, call - `TcErrors.warnAllUnsolved`. Both functions convert constraints into a - warning message for the user. - - * In the case of `warnAllUnsolved` for resolved, but unsafe - dictionary constraints, we collect the generated warning - message (pop it) and call `TcRnMonad.recordUnsafeInfer` to - mark the module we are compiling as unsafe, passing the - warning message along as the reason. - - 5) `TcErrors.*Unsolved` -- Generates error messages for constraints by - actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we - know is the constraint that is unresolved or unsafe. For dictionary, all we - know is that we need a dictionary of type C, but not what instances are - available and how they overlap. So we once again call `lookupInstEnv` to - figure that out so we can generate a helpful error message. - - 6) `TcRnMonad.recordUnsafeInfer` -- Save the unsafe result and reason in an - IORef called `tcg_safeInfer`. - - 7) `HscMain.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling - `HscMain.markUnsafeInfer` (passing the reason along) when safe-inferrence - failed. - -Note [No defaulting in the ambiguity check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When simplifying constraints for the ambiguity check, we use -solveWantedsAndDrop, not simpl_top, so that we do no defaulting. -Trac #11947 was an example: - f :: Num a => Int -> Int -This is ambiguous of course, but we don't want to default the -(Num alpha) constraint to (Num Int)! Doing so gives a defaulting -warning, but no error. --} - ------------------- -simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () -simplifyAmbiguityCheck ty wanteds - = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) - ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds - -- NB: no defaulting! See Note [No defaulting in the ambiguity check] - - ; traceTc "End simplifyAmbiguityCheck }" empty - - -- Normally report all errors; but with -XAllowAmbiguousTypes - -- report only insoluble ones, since they represent genuinely - -- inaccessible code - ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes - ; traceTc "reportUnsolved(ambig) {" empty - ; unless (allow_ambiguous && not (insolubleWC final_wc)) - (discardResult (reportUnsolved final_wc)) - ; traceTc "reportUnsolved(ambig) }" empty - - ; return () } - ------------------- -simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) -simplifyInteractive wanteds - = traceTc "simplifyInteractive" empty >> - simplifyTop wanteds - ------------------- -simplifyDefault :: ThetaType -- Wanted; has no type variables in it - -> TcM () -- Succeeds if the constraint is soluble -simplifyDefault theta - = do { traceTc "simplifyDefault" empty - ; wanteds <- newWanteds DefaultOrigin theta - ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds)) - ; traceTc "reportUnsolved {" empty - ; reportAllUnsolved unsolved - ; traceTc "reportUnsolved }" empty - ; return () } - ------------------- -tcCheckSatisfiability :: Bag EvVar -> TcM Bool --- Return True if satisfiable, False if definitely contradictory -tcCheckSatisfiability given_ids - = do { lcl_env <- TcM.getLclEnv - ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env - ; (res, _ev_binds) <- runTcS $ - do { traceTcS "checkSatisfiability {" (ppr given_ids) - ; let given_cts = mkGivens given_loc (bagToList given_ids) - -- See Note [Superclasses and satisfiability] - ; solveSimpleGivens given_cts - ; insols <- getInertInsols - ; insols <- try_harder insols - ; traceTcS "checkSatisfiability }" (ppr insols) - ; return (isEmptyBag insols) } - ; return res } - where - try_harder :: Cts -> TcS Cts - -- Maybe we have to search up the superclass chain to find - -- an unsatisfiable constraint. Example: pmcheck/T3927b. - -- At the moment we try just once - try_harder insols - | not (isEmptyBag insols) -- We've found that it's definitely unsatisfiable - = return insols -- Hurrah -- stop now. - | otherwise - = do { pending_given <- getPendingScDicts - ; new_given <- makeSuperClasses pending_given - ; solveSimpleGivens new_given - ; getInertInsols } - -{- Note [Superclasses and satisfiability] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Expand superclasses before starting, because (Int ~ Bool), has -(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool) -as a superclass, and it's the latter that is insoluble. See -Note [The equality types story] in TysPrim. - -If we fail to prove unsatisfiability we (arbitrarily) try just once to -find superclasses, using try_harder. Reason: we might have a type -signature - f :: F op (Implements push) => .. -where F is a type function. This happened in Trac #3972. - -We could do more than once but we'd have to have /some/ limit: in the -the recursive case, we would go on forever in the common case where -the constraints /are/ satisfiable (Trac #10592 comment:12!). - -For stratightforard situations without type functions the try_harder -step does nothing. - - -*********************************************************************************** -* * -* Inference -* * -*********************************************************************************** - -Note [Inferring the type of a let-bound variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = rhs - -To infer f's type we do the following: - * Gather the constraints for the RHS with ambient level *one more than* - the current one. This is done by the call - pushLevelAndCaptureConstraints (tcMonoBinds...) - in TcBinds.tcPolyInfer - - * Call simplifyInfer to simplify the constraints and decide what to - quantify over. We pass in the level used for the RHS constraints, - here called rhs_tclvl. - -This ensures that the implication constraint we generate, if any, -has a strictly-increased level compared to the ambient level outside -the let binding. - --} - --- | How should we choose which constraints to quantify over? -data InferMode = ApplyMR -- ^ Apply the monomorphism restriction, - -- never quantifying over any constraints - | EagerDefaulting -- ^ See Note [TcRnExprMode] in TcRnDriver, - -- the :type +d case; this mode refuses - -- to quantify over any defaultable constraint - | NoRestrictions -- ^ Quantify over any constraint that - -- satisfies TcType.pickQuantifiablePreds - -instance Outputable InferMode where - ppr ApplyMR = text "ApplyMR" - ppr EagerDefaulting = text "EagerDefaulting" - ppr NoRestrictions = text "NoRestrictions" - -simplifyInfer :: TcLevel -- Used when generating the constraints - -> InferMode - -> [TcIdSigInst] -- Any signatures (possibly partial) - -> [(Name, TcTauType)] -- Variables to be generalised, - -- and their tau-types - -> WantedConstraints - -> TcM ([TcTyVar], -- Quantify over these type variables - [EvVar], -- ... and these constraints (fully zonked) - TcEvBinds, -- ... binding these evidence variables - Bool) -- True <=> there was an insoluble type error - -- in these bindings -simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds - | isEmptyWC wanteds - = do { gbl_tvs <- tcGetGlobalTyCoVars - ; dep_vars <- zonkTcTypesAndSplitDepVars (map snd name_taus) - ; qtkvs <- quantifyZonkedTyVars gbl_tvs dep_vars - ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) - ; return (qtkvs, [], emptyTcEvBinds, False) } - - | otherwise - = do { traceTc "simplifyInfer {" $ vcat - [ text "sigs =" <+> ppr sigs - , text "binds =" <+> ppr name_taus - , text "rhs_tclvl =" <+> ppr rhs_tclvl - , text "infer_mode =" <+> ppr infer_mode - , text "(unzonked) wanted =" <+> ppr wanteds - ] - - ; let partial_sigs = filter isPartialSig sigs - psig_theta = concatMap sig_inst_theta partial_sigs - - -- First do full-blown solving - -- NB: we must gather up all the bindings from doing - -- this solving; hence (runTcSWithEvBinds ev_binds_var). - -- And note that since there are nested implications, - -- calling solveWanteds will side-effect their evidence - -- bindings, so we can't just revert to the input - -- constraint. - - ; tc_lcl_env <- TcM.getLclEnv - ; ev_binds_var <- TcM.newTcEvBinds - ; psig_theta_vars <- mapM TcM.newEvVar psig_theta - ; wanted_transformed_incl_derivs - <- setTcLevel rhs_tclvl $ - runTcSWithEvBinds ev_binds_var $ - do { let loc = mkGivenLoc rhs_tclvl UnkSkol tc_lcl_env - psig_givens = mkGivens loc psig_theta_vars - ; _ <- solveSimpleGivens psig_givens - -- See Note [Add signature contexts as givens] - ; solveWanteds wanteds } - ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs - - - -- Find quant_pred_candidates, the predicates that - -- we'll consider quantifying over - -- NB1: wanted_transformed does not include anything provable from - -- the psig_theta; it's just the extra bit - -- NB2: We do not do any defaulting when inferring a type, this can lead - -- to less polymorphic types, see Note [Default while Inferring] - ; let definite_error = insolubleWC wanted_transformed_incl_derivs - -- See Note [Quantification with errors] - -- NB: must include derived errors in this test, - -- hence "incl_derivs" - wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs - quant_pred_candidates - | definite_error = [] - | otherwise = ctsPreds (approximateWC False wanted_transformed) - - -- Decide what type variables and constraints to quantify - -- NB: quant_pred_candidates is already fully zonked - -- NB: bound_theta are constraints we want to quantify over, - -- /apart from/ the psig_theta, which we always quantify over - ; (qtvs, bound_theta) <- decideQuantification infer_mode rhs_tclvl - name_taus partial_sigs - quant_pred_candidates - - -- Emit an implication constraint for the - -- remaining constraints from the RHS. - -- We must retain the psig_theta_vars, because we've used them in - -- evidence bindings constructed by solveWanteds earlier - ; psig_theta_vars <- mapM zonkId psig_theta_vars - ; bound_theta_vars <- mapM TcM.newEvVar bound_theta - ; let full_theta_vars = psig_theta_vars ++ bound_theta_vars - - ; emitResidualImplication rhs_tclvl tc_lcl_env ev_binds_var - name_taus qtvs full_theta_vars - wanted_transformed - - -- All done! - ; traceTc "} simplifyInfer/produced residual implication for quantification" $ - vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates - , text "psig_theta =" <+> ppr psig_theta - , text "bound_theta =" <+> ppr bound_theta - , text "full_theta =" <+> ppr (map idType full_theta_vars) - , text "qtvs =" <+> ppr qtvs - , text "definite_error =" <+> ppr definite_error ] - - ; return ( qtvs, full_theta_vars, TcEvBinds ev_binds_var, definite_error ) } - -- NB: full_theta_vars must be fully zonked - - --------------------- -emitResidualImplication :: TcLevel -> TcLclEnv -> EvBindsVar - -> [(Name, TcTauType)] -> [TcTyVar] -> [EvVar] - -> WantedConstraints -> TcM () -emitResidualImplication rhs_tclvl tc_lcl_env ev_binds_var - name_taus qtvs full_theta_vars wanteds - | isEmptyWC wanteds - = return () - | otherwise - = do { traceTc "emitResidualImplication" (ppr implic) - ; emitImplication implic } - where - implic = Implic { ic_tclvl = rhs_tclvl - , ic_skols = qtvs - , ic_no_eqs = False - , ic_given = full_theta_vars - , ic_wanted = wanteds - , ic_status = IC_Unsolved - , ic_binds = ev_binds_var - , ic_info = skol_info - , ic_needed = emptyVarSet - , ic_env = tc_lcl_env } - - full_theta = map idType full_theta_vars - skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) - | (name, ty) <- name_taus ] - -- Don't add the quantified variables here, because - -- they are also bound in ic_skols and we want them - -- to be tidied uniformly - --------------------- -ctsPreds :: Cts -> [PredType] -ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts - , let ev = ctEvidence ct ] - -{- Note [Add signature contexts as givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (Trac #11016): - f2 :: (?x :: Int) => _ - f2 = ?x -or this - f3 :: a ~ Bool => (a, _) - f3 = (True, False) -or theis - f4 :: (Ord a, _) => a -> Bool - f4 x = x==x - -We'll use plan InferGen because there are holes in the type. But: - * For f2 we want to have the (?x :: Int) constraint floating around - so that the functional dependencies kick in. Otherwise the - occurrence of ?x on the RHS produces constraint (?x :: alpha), and - we won't unify alpha:=Int. - * For f3 we want the (a ~ Bool) available to solve the wanted (a ~ Bool) - in the RHS - * For f4 we want to use the (Ord a) in the signature to solve the Eq a - constraint. - -Solution: in simplifyInfer, just before simplifying the constraints -gathered from the RHS, add Given constraints for the context of any -type signatures. - -************************************************************************ -* * - Quantification -* * -************************************************************************ - -Note [Deciding quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the monomorphism restriction does not apply, then we quantify as follows: - -* Step 1. Take the global tyvars, and "grow" them using the equality - constraints - E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can - happen because alpha is untouchable here) then do not quantify over - beta, because alpha fixes beta, and beta is effectively free in - the environment too - - We also account for the monomorphism restriction; if it applies, - add the free vars of all the constraints. - - Result is mono_tvs; we will not quantify over these. - -* Step 2. Default any non-mono tyvars (i.e ones that are definitely - not going to become further constrained), and re-simplify the - candidate constraints. - - Motivation for re-simplification (Trac #7857): imagine we have a - constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are - not free in the envt, and instance forall (a::*) (b::*). (C a) => C - (a -> b) The instance doesnt' match while l1,l2 are polymorphic, but - it will match when we default them to LiftedRep. - - This is all very tiresome. - -* Step 3: decide which variables to quantify over, as follows: - - - Take the free vars of the tau-type (zonked_tau_tvs) and "grow" - them using all the constraints. These are tau_tvs_plus - - - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being - careful to close over kinds, and to skolemise the quantified tyvars. - (This actually unifies each quantifies meta-tyvar with a fresh skolem.) - - Result is qtvs. - -* Step 4: Filter the constraints using pickQuantifiablePreds and the - qtvs. We have to zonk the constraints first, so they "see" the - freshly created skolems. - --} - -decideQuantification - :: InferMode - -> TcLevel - -> [(Name, TcTauType)] -- Variables to be generalised - -> [TcIdSigInst] -- Partial type signatures (if any) - -> [PredType] -- Candidate theta; already zonked - -> TcM ( [TcTyVar] -- Quantify over these (skolems) - , [PredType] ) -- and this context (fully zonked) --- See Note [Deciding quantification] -decideQuantification infer_mode rhs_tclvl name_taus psigs candidates - = do { -- Step 1: find the mono_tvs - ; (mono_tvs, candidates) <- decideMonoTyVars infer_mode - name_taus psigs candidates - - -- Step 2: default any non-mono tyvars, and re-simplify - -- This step may do some unification, but result candidates is zonked - ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates - - -- Step 3: decide which kind/type variables to quantify over - ; qtvs <- decideQuantifiedTyVars mono_tvs name_taus psigs candidates - - -- Step 4: choose which of the remaining candidate - -- predicates to actually quantify over - -- NB: decideQuantifiedTyVars turned some meta tyvars - -- into quantified skolems, so we have to zonk again - ; candidates <- TcM.zonkTcTypes candidates - ; let theta = pickQuantifiablePreds (mkVarSet qtvs) $ - mkMinimalBySCs $ -- See Note [Minimize by Superclasses] - candidates - - ; traceTc "decideQuantification" - (vcat [ text "infer_mode:" <+> ppr infer_mode - , text "candidates:" <+> ppr candidates - , text "mono_tvs:" <+> ppr mono_tvs - , text "qtvs:" <+> ppr qtvs - , text "theta:" <+> ppr theta ]) - ; return (qtvs, theta) } - ------------------- -decideMonoTyVars :: InferMode - -> [(Name,TcType)] - -> [TcIdSigInst] - -> [PredType] - -> TcM (TcTyCoVarSet, [PredType]) --- Decide which tyvars cannot be generalised: --- (a) Free in the environment --- (b) Mentioned in a constraint we can't generalise --- (c) Connected by an equality to (a) or (b) --- Also return the reduced set of constraint we can generalise -decideMonoTyVars infer_mode name_taus psigs candidates - = do { (no_quant, yes_quant) <- pick infer_mode candidates - - ; gbl_tvs <- tcGetGlobalTyCoVars - ; let eq_constraints = filter isEqPred candidates - constrained_tvs = tyCoVarsOfTypes no_quant - mono_tvs1 = growThetaTyVars eq_constraints $ - gbl_tvs `unionVarSet` constrained_tvs - - -- Always quantify over partial-sig qtvs, so they are not mono - -- Need to zonk them because they are meta-tyvar SigTvs - -- Note [Quantification and partial signatures], wrinkle 3 - ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ - concatMap (map snd . sig_inst_skols) psigs - ; let mono_tvs = mono_tvs1 `delVarSetList` psig_qtvs - - -- Warn about the monomorphism restriction - ; warn_mono <- woptM Opt_WarnMonomorphism - ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $ - do { taus <- mapM (TcM.zonkTcType . snd) name_taus - ; warnTc (Reason Opt_WarnMonomorphism) - (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) - mr_msg } - - ; traceTc "decideMonoTyVars" $ vcat - [ text "gbl_tvs =" <+> ppr gbl_tvs - , text "no_quant =" <+> ppr no_quant - , text "yes_quant =" <+> ppr yes_quant - , text "eq_constraints =" <+> ppr eq_constraints - , text "mono_tvs =" <+> ppr mono_tvs ] - - ; return (mono_tvs, yes_quant) } - where - pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType]) - -- Split the candidates into ones we definitely - -- won't quantify, and ones that we might - pick NoRestrictions cand = return ([], cand) - pick ApplyMR cand = return (cand, []) - pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings - ; return (partition (is_int_ct os) cand) } - - -- For EagerDefaulting, do not quantify over - -- over any interactive class constraint - is_int_ct ovl_strings pred - | Just (cls, _) <- getClassPredTys_maybe pred - = isInteractiveClass ovl_strings cls - | otherwise - = False - - pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus - mr_msg = hang (text "The Monomorphism Restriction applies to the binding" - <> plural name_taus <+> text "for" <+> pp_bndrs) - 2 (text "Consider giving a type signature for" - <+> if isSingleton name_taus then pp_bndrs - else text "these binders") - -------------------- -defaultTyVarsAndSimplify :: TcLevel - -> TyCoVarSet - -> [PredType] -- Assumed zonked - -> TcM [PredType] -- Guaranteed zonked --- Default any tyvar free in the constraints, --- and re-simplify in case the defaulting allows futher simplification -defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates - = do { -- Promote any tyvars that we cannot generalise - -- See Note [Promote momomorphic tyvars] - ; outer_tclvl <- TcM.getTcLevel - ; let prom_tvs = nonDetEltsUniqSet mono_tvs - -- It's OK to use nonDetEltsUniqSet here - -- because promoteTyVar is commutative - ; traceTc "decideMonoTyVars: promotion:" (ppr prom_tvs) - ; proms <- mapM (promoteTyVar outer_tclvl) prom_tvs - - -- Default any kind/levity vars - ; let DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} - = candidateQTyVarsOfTypes candidates - ; poly_kinds <- xoptM LangExt.PolyKinds - ; default_kvs <- mapM (default_one poly_kinds True) - (dVarSetElems cand_kvs) - ; default_tvs <- mapM (default_one poly_kinds False) - (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) - ; let some_default = or default_kvs || or default_tvs - - ; case () of - _ | some_default -> simplify_cand candidates - | or proms -> mapM TcM.zonkTcType candidates - | otherwise -> return candidates - } - where - default_one poly_kinds is_kind_var tv - | not (isMetaTyVar tv) - = return False - | tv `elemVarSet` mono_tvs - = return False - | otherwise - = defaultTyVar (not poly_kinds && is_kind_var) tv - - simplify_cand candidates - = do { clone_wanteds <- newWanteds DefaultOrigin candidates - ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $ - simplifyWantedsTcM clone_wanteds - -- Discard evidence; simples is fully zonked - - ; let new_candidates = ctsPreds simples - ; traceTc "Simplified after defaulting" $ - vcat [ text "Before:" <+> ppr candidates - , text "After:" <+> ppr new_candidates ] - ; return new_candidates } - ------------------- -decideQuantifiedTyVars - :: TyCoVarSet -- Monomorphic tyvars - -> [(Name,TcType)] -- Annotated theta and (name,tau) pairs - -> [TcIdSigInst] -- Parital signatures - -> [PredType] -- Candidates, zonked - -> TcM [TyVar] --- Fix what tyvars we are going to quantify over, and quantify them -decideQuantifiedTyVars mono_tvs name_taus psigs candidates - = do { -- Why psig_tys? We try to quantify over everything free in here - -- See Note [Quantification and partial signatures] - -- wrinkles 2 and 3 - ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs - , (_,tv) <- sig_inst_skols sig ] - ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs - , pred <- sig_inst_theta sig ] - ; tau_tys <- mapM (TcM.zonkTcType . snd) name_taus - - ; let -- Try to quantify over variables free in these types - psig_tys = psig_tv_tys ++ psig_theta - seed_tys = psig_tys ++ tau_tys - - -- Now "grow" those seeds to find ones reachable via 'candidates' - grown_tvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys) - - -- Now we have to classify them into kind variables and type variables - -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyZonkedTyVars - -- - -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces - -- them in that order, so that the final qtvs quantifies in the same - -- order as the partial signatures do (Trac #13524) - ; let DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} - = candidateQTyVarsOfTypes $ - psig_tys ++ candidates ++ tau_tys - pick = filterDVarSet (`elemVarSet` grown_tvs) - dvs_plus = DV { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs } - - ; mono_tvs <- TcM.zonkTyCoVarsAndFV mono_tvs - ; quantifyZonkedTyVars mono_tvs dvs_plus } - ------------------- -growThetaTyVars :: ThetaType -> TyCoVarSet -> TyVarSet --- See Note [Growing the tau-tvs using constraints] --- NB: only returns tyvars, never covars -growThetaTyVars theta tvs - | null theta = tvs_only - | otherwise = filterVarSet isTyVar $ - transCloVarSet mk_next seed_tvs - where - tvs_only = filterVarSet isTyVar tvs - seed_tvs = tvs `unionVarSet` tyCoVarsOfTypes ips - (ips, non_ips) = partition isIPPred theta - -- See Note [Inheriting implicit parameters] in TcType - - mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones - mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips - grow_one so_far pred tvs - | pred_tvs `intersectsVarSet` so_far = tvs `unionVarSet` pred_tvs - | otherwise = tvs - where - pred_tvs = tyCoVarsOfType pred - -{- Note [Promote momomorphic tyvars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Promote any type variables that are free in the environment. Eg - f :: forall qtvs. bound_theta => zonked_tau -The free vars of f's type become free in the envt, and hence will show -up whenever 'f' is called. They may currently at rhs_tclvl, but they -had better be unifiable at the outer_tclvl! Example: envt mentions -alpha[1] - tau_ty = beta[2] -> beta[2] - constraints = alpha ~ [beta] -we don't quantify over beta (since it is fixed by envt) -so we must promote it! The inferred type is just - f :: beta -> beta - -NB: promoteTyVar ignores coercion variables - -Note [Quantification and partial signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When choosing type variables to quantify, the basic plan is to -quantify over all type variables that are - * free in the tau_tvs, and - * not forced to be monomorphic (mono_tvs), - for example by being free in the environment. - -However, in the case of a partial type signature, be doing inference -*in the presence of a type signature*. For example: - f :: _ -> a - f x = ... -or - g :: (Eq _a) => _b -> _b -In both cases we use plan InferGen, and hence call simplifyInfer. But -those 'a' variables are skolems (actually SigTvs), and we should be -sure to quantify over them. This leads to several wrinkles: - -* Wrinkle 1. In the case of a type error - f :: _ -> Maybe a - f x = True && x - The inferred type of 'f' is f :: Bool -> Bool, but there's a - left-over error of form (HoleCan (Maybe a ~ Bool)). The error-reporting - machine expects to find a binding site for the skolem 'a', so we - add it to the quantified tyvars. - -* Wrinkle 2. Consider the partial type signature - f :: (Eq _) => Int -> Int - f x = x - In normal cases that makes sense; e.g. - g :: Eq _a => _a -> _a - g x = x - where the signature makes the type less general than it could - be. But for 'f' we must therefore quantify over the user-annotated - constraints, to get - f :: forall a. Eq a => Int -> Int - (thereby correctly triggering an ambiguity error later). If we don't - we'll end up with a strange open type - f :: Eq alpha => Int -> Int - which isn't ambiguous but is still very wrong. - - Bottom line: Try to quantify over any variable free in psig_theta, - just like the tau-part of the type. - -* Wrinkle 3 (Trac #13482). Also consider - f :: forall a. _ => Int -> Int - f x = if undefined :: a == undefined then x else 0 - Here we get an (Eq a) constraint, but it's not mentioned in the - psig_theta nor the type of 'f'. Moreover, if we have - f :: forall a. a -> _ - f x = not x - and a constraint (a ~ g), where 'g' is free in the environment, - we would not usually quanitfy over 'a'. But here we should anyway - (leading to a justified subsequent error) since 'a' is explicitly - quantified by the programmer. - - Bottom line: always quantify over the psig_tvs, regardless. - -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 [Growing the tau-tvs using constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(growThetaTyVars insts tvs) is the result of extending the set - of tyvars, tvs, using all conceivable links from pred - -E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e} -Then growThetaTyVars preds tvs = {a,b,c} - -Notice that - growThetaTyVars is conservative if v might be fixed by vs - => v `elem` grow(vs,C) - -Note [Quantification with errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we find that the RHS of the definition has some absolutely-insoluble -constraints (including especially "variable not in scope"), we - -* Abandon all attempts to find a context to quantify over, - and instead make the function fully-polymorphic in whatever - type we have found - -* Return a flag from simplifyInfer, indicating that we found an - insoluble constraint. This flag is used to suppress the ambiguity - check for the inferred type, which may well be bogus, and which - tends to obscure the real error. This fix feels a bit clunky, - but I failed to come up with anything better. - -Reasons: - - Avoid downstream errors - - Do not perform an ambiguity test on a bogus type, which might well - fail spuriously, thereby obfuscating the original insoluble error. - Trac #14000 is an example - -I tried an alterantive approach: simply failM, after emitting the -residual implication constraint; the exception will be caught in -TcBinds.tcPolyBinds, which gives all the binders in the group the type -(forall a. a). But that didn't work with -fdefer-type-errors, because -the recovery from failM emits no code at all, so there is no function -to run! But -fdefer-type-errors aspires to produce a runnable program. - -NB that we must include *derived* errors in the check for insolubles. -Example: - (a::*) ~ Int# -We get an insoluble derived error *~#, and we don't want to discard -it before doing the isInsolubleWC test! (Trac #8262) - -Note [Default while Inferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Our current plan is that defaulting only happens at simplifyTop and -not simplifyInfer. This may lead to some insoluble deferred constraints. -Example: - -instance D g => C g Int b - -constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha -type inferred = gamma -> gamma - -Now, if we try to default (alpha := Int) we will be able to refine the implication to - (forall b. 0 => C gamma Int b) -which can then be simplified further to - (forall b. 0 => D gamma) -Finally, we /can/ approximate this implication with (D gamma) and infer the quantified -type: forall g. D g => g -> g - -Instead what will currently happen is that we will get a quantified type -(forall g. g -> g) and an implication: - forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha - -Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an -unsolvable implication: - forall g. 0 => (forall b. 0 => D g) - -The concrete example would be: - h :: C g a s => g -> a -> ST s a - f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1) - -But it is quite tedious to do defaulting and resolve the implication constraints, and -we have not observed code breaking because of the lack of defaulting in inference, so -we don't do it for now. - - - -Note [Minimize by Superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we quantify over a constraint, in simplifyInfer we need to -quantify over a constraint that is minimal in some sense: For -instance, if the final wanted constraint is (Eq alpha, Ord alpha), -we'd like to quantify over Ord alpha, because we can just get Eq alpha -from superclass selection from Ord alpha. This minimization is what -mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint -to check the original wanted. - - -Note [Avoid unnecessary constraint simplification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -------- NB NB NB (Jun 12) ------------- - This note not longer applies; see the notes with Trac #4361. - But I'm leaving it in here so we remember the issue.) - ---------------------------------------- -When inferring the type of a let-binding, with simplifyInfer, -try to avoid unnecessarily simplifying class constraints. -Doing so aids sharing, but it also helps with delicate -situations like - - instance C t => C [t] where .. - - f :: C [t] => .... - f x = let g y = ...(constraint C [t])... - in ... -When inferring a type for 'g', we don't want to apply the -instance decl, because then we can't satisfy (C t). So we -just notice that g isn't quantified over 't' and partition -the constraints before simplifying. - -This only half-works, but then let-generalisation only half-works. - -********************************************************************************* -* * -* Main Simplifier * -* * -*********************************************************************************** - --} - -simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints --- Solve the specified Wanted constraints --- Discard the evidence binds --- Discards all Derived stuff in result --- Postcondition: fully zonked and unflattened constraints -simplifyWantedsTcM wanted - = do { traceTc "simplifyWantedsTcM {" (ppr wanted) - ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted)) - ; result <- TcM.zonkWC result - ; traceTc "simplifyWantedsTcM }" (ppr result) - ; return result } - -solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints --- Since solveWanteds returns the residual WantedConstraints, --- it should always be called within a runTcS or something similar, --- Result is not zonked -solveWantedsAndDrop wanted - = do { wc <- solveWanteds wanted - ; return (dropDerivedWC wc) } - -solveWanteds :: WantedConstraints -> TcS WantedConstraints --- so that the inert set doesn't mindlessly propagate. --- NB: wc_simples may be wanted /or/ derived now -solveWanteds wc@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics }) - = do { traceTcS "solveWanteds {" (ppr wc) - - ; wc1 <- solveSimpleWanteds simples - ; let WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 } = wc1 - - ; (floated_eqs, implics2) <- solveNestedImplications (implics `unionBags` implics1) - ; (no_new_scs, simples2) <- expandSuperClasses simples1 - - ; traceTcS "solveWanteds middle" $ vcat [ text "simples1 =" <+> ppr simples1 - , text "simples2 =" <+> ppr simples2 ] - - ; dflags <- getDynFlags - ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs - no_new_scs - (WC { wc_simple = simples2, wc_impl = implics2 - , wc_insol = insols `unionBags` insols1 }) - - ; bb <- TcS.getTcEvBindsMap - ; traceTcS "solveWanteds }" $ - vcat [ text "final wc =" <+> ppr final_wc - , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] - - ; return final_wc } - -simpl_loop :: Int -> IntWithInf -> Cts -> Bool - -> WantedConstraints - -> TcS WantedConstraints -simpl_loop n limit floated_eqs no_new_deriveds - wc@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics }) - | isEmptyBag floated_eqs && no_new_deriveds - = return wc -- Done! - - | n `intGtLimit` limit - = do { -- Add an error (not a warning) if we blow the limit, - -- Typically if we blow the limit we are going to report some other error - -- (an unsolved constraint), and we don't want that error to suppress - -- the iteration limit warning! - addErrTcS (hang (text "solveWanteds: too many iterations" - <+> parens (text "limit =" <+> ppr limit)) - 2 (vcat [ text "Unsolved:" <+> ppr wc - , ppUnless (isEmptyBag floated_eqs) $ - text "Floated equalities:" <+> ppr floated_eqs - , ppUnless no_new_deriveds $ - text "New deriveds found" - , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" - ])) - ; return wc } - - | otherwise - = do { let n_floated = lengthBag floated_eqs - ; csTraceTcS $ - text "simpl_loop iteration=" <> int n - <+> (parens $ hsep [ text "no new deriveds =" <+> ppr no_new_deriveds <> comma - , int n_floated <+> text "floated eqs" <> comma - , int (lengthBag simples) <+> text "simples to solve" ]) - - -- solveSimples may make progress if either float_eqs hold - ; (unifs1, wc1) <- reportUnifications $ - solveSimpleWanteds (floated_eqs `unionBags` simples) - -- Put floated_eqs first so they get solved first - -- NB: the floated_eqs may include /derived/ equalities - -- arising from fundeps inside an implication - - ; let WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 } = wc1 - ; (no_new_scs, simples2) <- expandSuperClasses simples1 - - -- We have already tried to solve the nested implications once - -- Try again only if we have unified some meta-variables - -- (which is a bit like adding more givens - -- See Note [Cutting off simpl_loop] - ; (floated_eqs2, implics2) <- if unifs1 == 0 && isEmptyBag implics1 - then return (emptyBag, implics) - else solveNestedImplications (implics `unionBags` implics1) - - ; simpl_loop (n+1) limit floated_eqs2 no_new_scs - (WC { wc_simple = simples2, wc_impl = implics2 - , wc_insol = insols `unionBags` insols1 }) } - -expandSuperClasses :: Cts -> TcS (Bool, Cts) --- If there are any unsolved wanteds, expand one step of --- superclasses for deriveds --- Returned Bool is True <=> no new superclass constraints added --- See Note [The superclass story] in TcCanonical -expandSuperClasses unsolved - | not (anyBag superClassesMightHelp unsolved) - = return (True, unsolved) - | otherwise - = do { traceTcS "expandSuperClasses {" empty - ; let (pending_wanted, unsolved') = mapAccumBagL get [] unsolved - get acc ct | Just ct' <- isPendingScDict ct - = (ct':acc, ct') - | otherwise - = (acc, ct) - ; pending_given <- getPendingScDicts - ; if null pending_given && null pending_wanted - then do { traceTcS "End expandSuperClasses no-op }" empty - ; return (True, unsolved) } - else - do { new_given <- makeSuperClasses pending_given - ; solveSimpleGivens new_given - ; new_wanted <- makeSuperClasses pending_wanted - ; traceTcS "End expandSuperClasses }" - (vcat [ text "Given:" <+> ppr pending_given - , text "Wanted:" <+> ppr new_wanted ]) - ; return (False, unsolved' `unionBags` listToBag new_wanted) } } - -solveNestedImplications :: Bag Implication - -> TcS (Cts, Bag Implication) --- Precondition: the TcS inerts may contain unsolved simples which have --- to be converted to givens before we go inside a nested implication. -solveNestedImplications implics - | isEmptyBag implics - = return (emptyBag, emptyBag) - | otherwise - = do { traceTcS "solveNestedImplications starting {" empty - ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics - ; let floated_eqs = concatBag floated_eqs_s - - -- ... and we are back in the original TcS inerts - -- Notice that the original includes the _insoluble_simples so it was safe to ignore - -- them in the beginning of this function. - ; traceTcS "solveNestedImplications end }" $ - vcat [ text "all floated_eqs =" <+> ppr floated_eqs - , text "unsolved_implics =" <+> ppr unsolved_implics ] - - ; return (floated_eqs, catBagMaybes unsolved_implics) } - -solveImplication :: Implication -- Wanted - -> TcS (Cts, -- All wanted or derived floated equalities: var = type - Maybe Implication) -- Simplified implication (empty or singleton) --- Precondition: The TcS monad contains an empty worklist and given-only inerts --- which after trying to solve this implication we must restore to their original value -solveImplication imp@(Implic { ic_tclvl = tclvl - , ic_binds = ev_binds_var - , ic_skols = skols - , ic_given = given_ids - , ic_wanted = wanteds - , ic_info = info - , ic_status = status - , ic_env = env }) - | isSolvedStatus status - = return (emptyCts, Just imp) -- Do nothing - - | otherwise -- Even for IC_Insoluble it is worth doing more work - -- The insoluble stuff might be in one sub-implication - -- and other unsolved goals in another; and we want to - -- solve the latter as much as possible - = do { inerts <- getTcSInerts - ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) - - -- Solve the nested constraints - ; (no_given_eqs, given_insols, residual_wanted) - <- nestImplicTcS ev_binds_var tclvl $ - do { let loc = mkGivenLoc tclvl info env - givens = mkGivens loc given_ids - ; solveSimpleGivens givens - - ; residual_wanted <- solveWanteds wanteds - -- solveWanteds, *not* solveWantedsAndDrop, because - -- we want to retain derived equalities so we can float - -- them out in floatEqualities - - ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols - -- Call getNoGivenEqs /after/ solveWanteds, because - -- solveWanteds can augment the givens, via expandSuperClasses, - -- to reveal given superclass equalities - - ; return (no_eqs, given_insols, residual_wanted) } - - ; (floated_eqs, residual_wanted) - <- floatEqualities skols no_given_eqs residual_wanted - - ; traceTcS "solveImplication 2" - (ppr given_insols $$ ppr residual_wanted) - ; let final_wanted = residual_wanted `addInsols` given_insols - - ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs - , ic_wanted = final_wanted }) - - ; (evbinds, tcvs) <- TcS.getTcEvBindsAndTCVs ev_binds_var - ; traceTcS "solveImplication end }" $ vcat - [ text "no_given_eqs =" <+> ppr no_given_eqs - , text "floated_eqs =" <+> ppr floated_eqs - , text "res_implic =" <+> ppr res_implic - , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) - , text "implication tvcs =" <+> ppr tcvs ] - - ; return (floated_eqs, res_implic) } - ----------------------- -setImplicationStatus :: Implication -> TcS (Maybe Implication) --- Finalise the implication returned from solveImplication: --- * Set the ic_status field --- * Trim the ic_wanted field to remove Derived constraints --- Precondition: the ic_status field is not already IC_Solved --- Return Nothing if we can discard the implication altogether -setImplicationStatus implic@(Implic { ic_binds = ev_binds_var - , ic_status = status - , ic_info = info - , ic_wanted = wc - , ic_needed = old_discarded_needs - , ic_given = givens }) - | ASSERT2( not (isSolvedStatus status ), ppr info ) - -- Precondition: we only set the status if it is not already solved - some_insoluble - = return $ Just $ - implic { ic_status = IC_Insoluble - , ic_needed = new_discarded_needs - , ic_wanted = pruned_wc } - - | some_unsolved - = do { traceTcS "setImplicationStatus" $ - vcat [ppr givens $$ ppr simples $$ ppr insols $$ ppr mb_implic_needs] - ; return $ Just $ - implic { ic_status = IC_Unsolved - , ic_needed = new_discarded_needs - , ic_wanted = pruned_wc } - } - - | otherwise -- Everything is solved; look at the implications - -- See Note [Tracking redundant constraints] - = do { ev_binds <- TcS.getTcEvBindsAndTCVs ev_binds_var - ; let all_needs = neededEvVars ev_binds $ - solved_implic_needs `unionVarSet` new_discarded_needs - - dead_givens | warnRedundantGivens info - = filterOut (`elemVarSet` all_needs) givens - | otherwise = [] -- None to report - - final_needs = all_needs `delVarSetList` givens - - discard_entire_implication -- Can we discard the entire implication? - = null dead_givens -- No warning from this implication - && isEmptyBag pruned_implics -- No live children - && isEmptyVarSet final_needs -- No needed vars to pass up to parent - - final_status = IC_Solved { ics_need = final_needs - , ics_dead = dead_givens } - final_implic = implic { ic_status = final_status - , ic_needed = emptyVarSet -- Irrelevant for IC_Solved - , ic_wanted = pruned_wc } - - -- Check that there are no term-level evidence bindings - -- in the cases where we have no place to put them - ; MASSERT2( termEvidenceAllowed info || isEmptyEvBindMap (fst ev_binds) - , ppr info $$ ppr ev_binds ) - - ; traceTcS "setImplicationStatus 2" $ - vcat [ppr givens $$ ppr ev_binds $$ ppr all_needs] - ; return $ if discard_entire_implication - then Nothing - else Just final_implic } - where - WC { wc_simple = simples, wc_impl = implics, wc_insol = insols } = wc - - some_insoluble = insolubleWC wc - some_unsolved = not (isEmptyBag simples && isEmptyBag insols) - || isNothing mb_implic_needs - - pruned_simples = dropDerivedSimples simples - pruned_insols = dropDerivedInsols insols - (pruned_implics, discarded_needs) = partitionBagWith discard_me implics - pruned_wc = wc { wc_simple = pruned_simples - , wc_insol = pruned_insols - , wc_impl = pruned_implics } - new_discarded_needs = foldrBag unionVarSet old_discarded_needs discarded_needs - - mb_implic_needs :: Maybe VarSet - -- Just vs => all implics are IC_Solved, with 'vs' needed - -- Nothing => at least one implic is not IC_Solved - mb_implic_needs = foldrBag add_implic (Just emptyVarSet) pruned_implics - Just solved_implic_needs = mb_implic_needs - - add_implic implic acc - | Just vs_acc <- acc - , IC_Solved { ics_need = vs } <- ic_status implic - = Just (vs `unionVarSet` vs_acc) - | otherwise = Nothing - - discard_me :: Implication -> Either Implication VarSet - discard_me ic - | IC_Solved { ics_dead = dead_givens, ics_need = needed } <- ic_status ic - -- Fully solved - , null dead_givens -- No redundant givens to report - , isEmptyBag (wc_impl (ic_wanted ic)) - -- And no children that might have things to report - = Right needed - | otherwise - = Left ic - -warnRedundantGivens :: SkolemInfo -> Bool -warnRedundantGivens (SigSkol ctxt _ _) - = case ctxt of - FunSigCtxt _ warn_redundant -> warn_redundant - ExprSigCtxt -> True - _ -> False - - -- To think about: do we want to report redundant givens for - -- pattern synonyms, PatSynSigSkol? c.f Trac #9953, comment:21. -warnRedundantGivens (InstSkol {}) = True -warnRedundantGivens _ = False - -neededEvVars :: (EvBindMap, TcTyVarSet) -> VarSet -> VarSet --- Find all the evidence variables that are "needed", --- and then delete all those bound by the evidence bindings --- See Note [Tracking redundant constraints] --- --- - Start from initial_seeds (from nested implications) --- - Add free vars of RHS of all Wanted evidence bindings --- and coercion variables accumulated in tcvs (all Wanted) --- - Do transitive closure through Given bindings --- e.g. Neede {a,b} --- Given a = sc_sel a2 --- Then a2 is needed too --- - Finally delete all the binders of the evidence bindings --- -neededEvVars (ev_binds, tcvs) initial_seeds - = needed `minusVarSet` bndrs - where - needed = transCloVarSet also_needs seeds - seeds = foldEvBindMap add_wanted initial_seeds ev_binds - `unionVarSet` tcvs - bndrs = foldEvBindMap add_bndr emptyVarSet ev_binds - - add_wanted :: EvBind -> VarSet -> VarSet - add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs - | is_given = needs -- Add the rhs vars of the Wanted bindings only - | otherwise = evVarsOfTerm rhs `unionVarSet` needs - - also_needs :: VarSet -> VarSet - also_needs needs - = nonDetFoldUniqSet add emptyVarSet needs - -- It's OK to use nonDetFoldUFM here because we immediately forget - -- about the ordering by creating a set - where - add v needs - | Just ev_bind <- lookupEvBind ev_binds v - , EvBind { eb_is_given = is_given, eb_rhs = rhs } <- ev_bind - , is_given - = evVarsOfTerm rhs `unionVarSet` needs - | otherwise - = needs - - add_bndr :: EvBind -> VarSet -> VarSet - add_bndr (EvBind { eb_lhs = v }) vs = extendVarSet vs v - - -{- -Note [Tracking redundant constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With Opt_WarnRedundantConstraints, GHC can report which -constraints of a type signature (or instance declaration) are -redundant, and can be omitted. Here is an overview of how it -works: - ------ What is a redundant constraint? - -* The things that can be redundant are precisely the Given - constraints of an implication. - -* A constraint can be redundant in two different ways: - a) It is implied by other givens. E.g. - f :: (Eq a, Ord a) => blah -- Eq a unnecessary - g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary - b) It is not needed by the Wanted constraints covered by the - implication E.g. - f :: Eq a => a -> Bool - f x = True -- Equality not used - -* To find (a), when we have two Given constraints, - we must be careful to drop the one that is a naked variable (if poss). - So if we have - f :: (Eq a, Ord a) => blah - then we may find [G] sc_sel (d1::Ord a) :: Eq a - [G] d2 :: Eq a - We want to discard d2 in favour of the superclass selection from - the Ord dictionary. This is done by TcInteract.solveOneFromTheOther - See Note [Replacement vs keeping]. - -* To find (b) we need to know which evidence bindings are 'wanted'; - hence the eb_is_given field on an EvBind. - ------ How tracking works - -* When the constraint solver finishes solving all the wanteds in - an implication, it sets its status to IC_Solved - - - The ics_dead field, of IC_Solved, records the subset of this - implication's ic_given that are redundant (not needed). - - - The ics_need field of IC_Solved then records all the - in-scope (given) evidence variables bound by the context, that - were needed to solve this implication, including all its nested - implications. (We remove the ic_given of this implication from - the set, of course.) - -* We compute which evidence variables are needed by an implication - in setImplicationStatus. A variable is needed if - a) it is free in the RHS of a Wanted EvBind, - b) it is free in the RHS of an EvBind whose LHS is needed, - c) it is in the ics_need of a nested implication. - -* We need to be careful not to discard an implication - prematurely, even one that is fully solved, because we might - thereby forget which variables it needs, and hence wrongly - report a constraint as redundant. But we can discard it once - its free vars have been incorporated into its parent; or if it - simply has no free vars. This careful discarding is also - handled in setImplicationStatus. - ------ Reporting redundant constraints - -* TcErrors does the actual warning, in warnRedundantConstraints. - -* We don't report redundant givens for *every* implication; only - for those which reply True to TcSimplify.warnRedundantGivens: - - - For example, in a class declaration, the default method *can* - use the class constraint, but it certainly doesn't *have* to, - and we don't want to report an error there. - - - More subtly, in a function definition - f :: (Ord a, Ord a, Ix a) => a -> a - f x = rhs - we do an ambiguity check on the type (which would find that one - of the Ord a constraints was redundant), and then we check that - the definition has that type (which might find that both are - redundant). We don't want to report the same error twice, so we - disable it for the ambiguity check. Hence using two different - FunSigCtxts, one with the warn-redundant field set True, and the - other set False in - - TcBinds.tcSpecPrag - - TcBinds.tcTySig - - This decision is taken in setImplicationStatus, rather than TcErrors - so that we can discard implication constraints that we don't need. - So ics_dead consists only of the *reportable* redundant givens. - ------ Shortcomings - -Consider (see Trac #9939) - f2 :: (Eq a, Ord a) => a -> a -> Bool - -- Ord a redundant, but Eq a is reported - f2 x y = (x == y) - -We report (Eq a) as redundant, whereas actually (Ord a) is. But it's -really not easy to detect that! - - -Note [Cutting off simpl_loop] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is very important not to iterate in simpl_loop unless there is a chance -of progress. Trac #8474 is a classic example: - - * There's a deeply-nested chain of implication constraints. - ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int - - * From the innermost one we get a [D] alpha ~ Int, - but alpha is untouchable until we get out to the outermost one - - * We float [D] alpha~Int out (it is in floated_eqs), but since alpha - is untouchable, the solveInteract in simpl_loop makes no progress - - * So there is no point in attempting to re-solve - ?yn:betan => [W] ?x:Int - via solveNestedImplications, because we'll just get the - same [D] again - - * If we *do* re-solve, we'll get an ininite loop. It is cut off by - the fixed bound of 10, but solving the next takes 10*10*...*10 (ie - exponentially many) iterations! - -Conclusion: we should call solveNestedImplications only if we did -some unification in solveSimpleWanteds; because that's the only way -we'll get more Givens (a unification is like adding a Given) to -allow the implication to make progress. --} - -promoteTyVar :: TcLevel -> TcTyVar -> TcM Bool --- When we float a constraint out of an implication we must restore --- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType --- Return True <=> we did some promotion --- See Note [Promoting unification variables] -promoteTyVar tclvl tv - | isFloatedTouchableMetaTyVar tclvl tv - = do { cloned_tv <- TcM.cloneMetaTyVar tv - ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv) - ; return True } - | otherwise - = return False - -promoteTyVarTcS :: TcLevel -> TcTyVar -> TcS () --- When we float a constraint out of an implication we must restore --- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType --- See Note [Promoting unification variables] --- We don't just call promoteTyVar because we want to use unifyTyVar, --- not writeMetaTyVar -promoteTyVarTcS tclvl tv - | isFloatedTouchableMetaTyVar tclvl tv - = do { cloned_tv <- TcS.cloneMetaTyVar tv - ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; unifyTyVar tv (mkTyVarTy rhs_tv) } - | otherwise - = return () - --- | Like 'defaultTyVar', but in the TcS monad. -defaultTyVarTcS :: TcTyVar -> TcS Bool -defaultTyVarTcS the_tv - | isRuntimeRepVar the_tv - = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) - ; unifyTyVar the_tv liftedRepTy - ; return True } - | otherwise - = return False -- the common case - -approximateWC :: Bool -> WantedConstraints -> Cts --- Postcondition: Wanted or Derived Cts --- See Note [ApproximateWC] -approximateWC float_past_equalities wc - = float_wc emptyVarSet wc - where - float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts - float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) - = filterBag is_floatable simples `unionBags` - do_bag (float_implic trapping_tvs) implics - where - is_floatable ct = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs - - float_implic :: TcTyCoVarSet -> Implication -> Cts - float_implic trapping_tvs imp - | float_past_equalities || ic_no_eqs imp - = float_wc new_trapping_tvs (ic_wanted imp) - | otherwise -- Take care with equalities - = emptyCts -- See (1) under Note [ApproximateWC] - where - new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp - do_bag :: (a -> Bag c) -> Bag a -> Bag c - do_bag f = foldrBag (unionBags.f) emptyBag - -{- Note [ApproximateWC] -~~~~~~~~~~~~~~~~~~~~~~~ -approximateWC takes a constraint, typically arising from the RHS of a -let-binding whose type we are *inferring*, and extracts from it some -*simple* constraints that we might plausibly abstract over. Of course -the top-level simple constraints are plausible, but we also float constraints -out from inside, if they are not captured by skolems. - -The same function is used when doing type-class defaulting (see the call -to applyDefaultingRules) to extract constraints that that might be defaulted. - -There is one caveat: - -1. When infering most-general types (in simplifyInfer), we do *not* - float anything out if the implication binds equality constraints, - because that defeats the OutsideIn story. Consider - data T a where - TInt :: T Int - MkT :: T a - - f TInt = 3::Int - - We get the implication (a ~ Int => res ~ Int), where so far we've decided - f :: T a -> res - We don't want to float (res~Int) out because then we'll infer - f :: T a -> Int - which is only on of the possible types. (GHC 7.6 accidentally *did* - float out of such implications, which meant it would happily infer - non-principal types.) - - HOWEVER (Trac #12797) in findDefaultableGroups we are not worried about - the most-general type; and we /do/ want to float out of equalities. - Hence the boolean flag to approximateWC. - ------- Historical note ----------- -There used to be a second caveat, driven by Trac #8155 - - 2. We do not float out an inner constraint that shares a type variable - (transitively) with one that is trapped by a skolem. Eg - forall a. F a ~ beta, Integral beta - We don't want to float out (Integral beta). Doing so would be bad - when defaulting, because then we'll default beta:=Integer, and that - makes the error message much worse; we'd get - Can't solve F a ~ Integer - rather than - Can't solve Integral (F a) - - Moreover, floating out these "contaminated" constraints doesn't help - when generalising either. If we generalise over (Integral b), we still - can't solve the retained implication (forall a. F a ~ b). Indeed, - arguably that too would be a harder error to understand. - -But this transitive closure stuff gives rise to a complex rule for -when defaulting actually happens, and one that was never documented. -Moreover (Trac #12923), the more complex rule is sometimes NOT what -you want. So I simply removed the extra code to implement the -contamination stuff. There was zero effect on the testsuite (not even -#8155). ------- End of historical note ----------- - - -Note [DefaultTyVar] -~~~~~~~~~~~~~~~~~~~ -defaultTyVar is used on any un-instantiated meta type variables to -default any RuntimeRep variables to LiftedRep. This is important -to ensure that instance declarations match. For example consider - - instance Show (a->b) - foo x = show (\_ -> True) - -Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r), -and that won't match the typeKind (*) in the instance decl. See tests -tc217 and tc175. - -We look only at touchable type variables. No further constraints -are going to affect these type variables, so it's time to do it by -hand. However we aren't ready to default them fully to () or -whatever, because the type-class defaulting rules have yet to run. - -An alternate implementation would be to emit a derived constraint setting -the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. - -Note [Promote _and_ default when inferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are inferring a type, we simplify the constraint, and then use -approximateWC to produce a list of candidate constraints. Then we MUST - - a) Promote any meta-tyvars that have been floated out by - approximateWC, to restore invariant (MetaTvInv) described in - Note [TcLevel and untouchable type variables] in TcType. - - b) Default the kind of any meta-tyvars that are not mentioned in - in the environment. - -To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we -have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it -should! If we don't solve the constraint, we'll stupidly quantify over -(C (a->Int)) and, worse, in doing so zonkQuantifiedTyVar will quantify over -(b:*) instead of (a:OpenKind), which can lead to disaster; see Trac #7332. -Trac #7641 is a simpler example. - -Note [Promoting unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we float an equality out of an implication we must "promote" free -unification variables of the equality, in order to maintain Invariant -(MetaTvInv) from Note [TcLevel and untouchable type variables] in TcType. for the -leftover implication. - -This is absolutely necessary. Consider the following example. We start -with two implications and a class with a functional dependency. - - class C x y | x -> y - instance C [a] [a] - - (I1) [untch=beta]forall b. 0 => F Int ~ [beta] - (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] - -We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. -They may react to yield that (beta := [alpha]) which can then be pushed inwards -the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that -(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable -beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: - - class C x y | x -> y where - op :: x -> y -> () - - instance C [a] [a] - - type family F a :: * - - h :: F Int -> () - h = undefined - - data TEx where - TEx :: a -> TEx - - f (x::beta) = - let g1 :: forall b. b -> () - g1 _ = h [x] - g2 z = case z of TEx y -> (h [[undefined]], op x [y]) - in (g1 '3', g2 undefined) - - - -********************************************************************************* -* * -* Floating equalities * -* * -********************************************************************************* - -Note [Float Equalities out of Implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For ordinary pattern matches (including existentials) we float -equalities out of implications, for instance: - data T where - MkT :: Eq a => a -> T - f x y = case x of MkT _ -> (y::Int) -We get the implication constraint (x::T) (y::alpha): - forall a. [untouchable=alpha] Eq a => alpha ~ Int -We want to float out the equality into a scope where alpha is no -longer untouchable, to solve the implication! - -But we cannot float equalities out of implications whose givens may -yield or contain equalities: - - data T a where - T1 :: T Int - T2 :: T Bool - T3 :: T a - - h :: T a -> a -> Int - - f x y = case x of - T1 -> y::Int - T2 -> y::Bool - T3 -> h x y - -We generate constraint, for (x::T alpha) and (y :: beta): - [untouchables = beta] (alpha ~ Int => beta ~ Int) -- From 1st branch - [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch - (alpha ~ beta) -- From 3rd branch - -If we float the equality (beta ~ Int) outside of the first implication and -the equality (beta ~ Bool) out of the second we get an insoluble constraint. -But if we just leave them inside the implications, we unify alpha := beta and -solve everything. - -Principle: - We do not want to float equalities out which may - need the given *evidence* to become soluble. - -Consequence: classes with functional dependencies don't matter (since there is -no evidence for a fundep equality), but equality superclasses do matter (since -they carry evidence). --} - -floatEqualities :: [TcTyVar] -> Bool - -> WantedConstraints - -> TcS (Cts, WantedConstraints) --- Main idea: see Note [Float Equalities out of Implications] --- --- Precondition: the wc_simple of the incoming WantedConstraints are --- fully zonked, so that we can see their free variables --- --- Postcondition: The returned floated constraints (Cts) are only --- Wanted or Derived --- --- Also performs some unifications (via promoteTyVar), adding to --- monadically-carried ty_binds. These will be used when processing --- floated_eqs later --- --- Subtleties: Note [Float equalities from under a skolem binding] --- Note [Skolem escape] -floatEqualities skols no_given_eqs - wanteds@(WC { wc_simple = simples }) - | not no_given_eqs -- There are some given equalities, so don't float - = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] - | otherwise - = do { outer_tclvl <- TcS.getTcLevel - ; mapM_ (promoteTyVarTcS outer_tclvl) - (tyCoVarsOfCtsList float_eqs) - -- See Note [Promoting unification variables] - - ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols - , text "Simples =" <+> ppr simples - , text "Floated eqs =" <+> ppr float_eqs]) - ; return ( float_eqs - , wanteds { wc_simple = remaining_simples } ) } - where - skol_set = mkVarSet skols - (float_eqs, remaining_simples) = partitionBag (usefulToFloat skol_set) simples - -usefulToFloat :: VarSet -> Ct -> Bool -usefulToFloat skol_set ct -- The constraint is un-flattened and de-canonicalised - = is_meta_var_eq pred && - (tyCoVarsOfType pred `disjointVarSet` skol_set) - where - pred = ctPred ct - - -- Float out alpha ~ ty, or ty ~ alpha - -- which might be unified outside - -- See Note [Which equalities to float] - is_meta_var_eq pred - | EqPred NomEq ty1 ty2 <- classifyPredType pred - = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of - (Just tv1, _) -> float_tv_eq tv1 ty2 - (_, Just tv2) -> float_tv_eq tv2 ty1 - _ -> False - | otherwise - = False - - float_tv_eq tv1 ty2 -- See Note [Which equalities to float] - = isMetaTyVar tv1 - && (not (isSigTyVar tv1) || isTyVarTy ty2) - -{- Note [Float equalities from under a skolem binding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Which of the simple equalities can we float out? Obviously, only -ones that don't mention the skolem-bound variables. But that is -over-eager. Consider - [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int -The second constraint doesn't mention 'a'. But if we float it, -we'll promote gamma[2] to gamma'[1]. Now suppose that we learn that -beta := Bool, and F a Bool = a, and G Bool _ = Int. Then we'll -we left with the constraint - [2] forall a. a ~ gamma'[1] -which is insoluble because gamma became untouchable. - -Solution: float only constraints that stand a jolly good chance of -being soluble simply by being floated, namely ones of form - a ~ ty -where 'a' is a currently-untouchable unification variable, but may -become touchable by being floated (perhaps by more than one level). - -We had a very complicated rule previously, but this is nice and -simple. (To see the notes, look at this Note in a version of -TcSimplify prior to Oct 2014). - -Note [Which equalities to float] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Which equalities should we float? We want to float ones where there -is a decent chance that floating outwards will allow unification to -happen. In particular: - - Float out equalities of form (alpha ~ ty) or (ty ~ alpha), where - - * alpha is a meta-tyvar. - - * And 'alpha' is not a SigTv with 'ty' being a non-tyvar. In that - case, floating out won't help either, and it may affect grouping - of error messages. - -Note [Skolem escape] -~~~~~~~~~~~~~~~~~~~~ -You might worry about skolem escape with all this floating. -For example, consider - [2] forall a. (a ~ F beta[2] delta, - Maybe beta[2] ~ gamma[1]) - -The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and -solve with gamma := beta. But what if later delta:=Int, and - F b Int = b. -Then we'd get a ~ beta[2], and solve to get beta:=a, and now the -skolem has escaped! - -But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2] -to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be. - - -********************************************************************************* -* * -* Defaulting and disambiguation * -* * -********************************************************************************* --} - -applyDefaultingRules :: WantedConstraints -> TcS Bool --- True <=> I did some defaulting, by unifying a meta-tyvar --- Input WantedConstraints are not necessarily zonked - -applyDefaultingRules wanteds - | isEmptyWC wanteds - = return False - | otherwise - = do { info@(default_tys, _) <- getDefaultInfo - ; wanteds <- TcS.zonkWC wanteds - - ; let groups = findDefaultableGroups info wanteds - - ; traceTcS "applyDefaultingRules {" $ - vcat [ text "wanteds =" <+> ppr wanteds - , text "groups =" <+> ppr groups - , text "info =" <+> ppr info ] - - ; something_happeneds <- mapM (disambigGroup default_tys) groups - - ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) - - ; return (or something_happeneds) } - -findDefaultableGroups - :: ( [Type] - , (Bool,Bool) ) -- (Overloaded strings, extended default rules) - -> WantedConstraints -- Unsolved (wanted or derived) - -> [(TyVar, [Ct])] -findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds - | null default_tys - = [] - | otherwise - = [ (tv, map fstOf3 group) - | group@((_,_,tv):_) <- unary_groups - , defaultable_tyvar tv - , defaultable_classes (map sndOf3 group) ] - where - simples = approximateWC True wanteds - (unaries, non_unaries) = partitionWith find_unary (bagToList simples) - unary_groups = equivClasses cmp_tv unaries - - unary_groups :: [[(Ct, Class, TcTyVar)]] -- (C tv) constraints - unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints - non_unaries :: [Ct] -- and *other* constraints - - -- Finds unary type-class constraints - -- But take account of polykinded classes like Typeable, - -- which may look like (Typeable * (a:*)) (Trac #8931) - find_unary :: Ct -> Either (Ct, Class, TyVar) Ct - find_unary cc - | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) - , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys - -- Ignore invisible arguments for this purpose - , Just tv <- tcGetTyVar_maybe ty - , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and - -- we definitely don't want to try to assign to those! - = Left (cc, cls, tv) - find_unary cc = Right cc -- Non unary or non dictionary - - bad_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries - bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries - - cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 - - defaultable_tyvar :: TcTyVar -> Bool - defaultable_tyvar tv - = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] - b2 = not (tv `elemVarSet` bad_tvs) - in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults] - - defaultable_classes :: [Class] -> Bool - defaultable_classes clss - | extended_defaults = any (isInteractiveClass ovl_strings) clss - | otherwise = all is_std_class clss && (any (isNumClass ovl_strings) clss) - - -- is_std_class adds IsString to the standard numeric classes, - -- when -foverloaded-strings is enabled - is_std_class cls = isStandardClass cls || - (ovl_strings && (cls `hasKey` isStringClassKey)) - ------------------------------- -disambigGroup :: [Type] -- The default types - -> (TcTyVar, [Ct]) -- All classes of the form (C a) - -- sharing same type variable - -> TcS Bool -- True <=> something happened, reflected in ty_binds - -disambigGroup [] _ - = return False -disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) - = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ]) - ; fake_ev_binds_var <- TcS.newTcEvBinds - ; tclvl <- TcS.getTcLevel - ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group - - ; if success then - -- Success: record the type variable binding, and return - do { unifyTyVar the_tv default_ty - ; wrapWarnTcS $ warnDefaulting wanteds default_ty - ; traceTcS "disambigGroup succeeded }" (ppr default_ty) - ; return True } - else - -- Failure: try with the next type - do { traceTcS "disambigGroup failed, will try other default types }" - (ppr default_ty) - ; disambigGroup default_tys group } } - where - try_group - | Just subst <- mb_subst - = do { lcl_env <- TcS.getLclEnv - ; let loc = CtLoc { ctl_origin = GivenOrigin UnkSkol - , ctl_env = lcl_env - , ctl_t_or_k = Nothing - , ctl_depth = initialSubGoalDepth } - ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred) - wanteds - ; fmap isEmptyWC $ - solveSimpleWanteds $ listToBag $ - map mkNonCanonical wanted_evs } - - | otherwise - = return False - - the_ty = mkTyVarTy the_tv - mb_subst = tcMatchTyKi the_ty default_ty - -- Make sure the kinds match too; hence this call to tcMatchTyKi - -- E.g. suppose the only constraint was (Typeable k (a::k)) - -- With the addition of polykinded defaulting we also want to reject - -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here. - --- In interactive mode, or with -XExtendedDefaultRules, --- we default Show a to Show () to avoid graututious errors on "show []" -isInteractiveClass :: Bool -- -XOverloadedStrings? - -> Class -> Bool -isInteractiveClass ovl_strings cls - = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys) - - -- isNumClass adds IsString to the standard numeric classes, - -- when -foverloaded-strings is enabled -isNumClass :: Bool -- -XOverloadedStrings? - -> Class -> Bool -isNumClass ovl_strings cls - = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) - - -{- -Note [Avoiding spurious errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When doing the unification for defaulting, we check for skolem -type variables, and simply don't default them. For example: - f = (*) -- Monomorphic - g :: Num a => a -> a - g x = f x x -Here, we get a complaint when checking the type signature for g, -that g isn't polymorphic enough; but then we get another one when -dealing with the (Num a) context arising from f's definition; -we try to unify a with Int (to default it), but find that it's -already been unified with the rigid variable from g's type sig. - -Note [Multi-parameter defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XExtendedDefaultRules, we default only based on single-variable -constraints, but do not exclude from defaulting any type variables which also -appear in multi-variable constraints. This means that the following will -default properly: - - default (Integer, Double) - - class A b (c :: Symbol) where - a :: b -> Proxy c - - instance A Integer c where a _ = Proxy - - main = print (a 5 :: Proxy "5") - -Note that if we change the above instance ("instance A Integer") to -"instance A Double", we get an error: - - No instance for (A Integer "5") - -This is because the first defaulted type (Integer) has successfully satisfied -its single-parameter constraints (in this case Num). --} diff --git a/typecheck/TcSplice.hs b/typecheck/TcSplice.hs deleted file mode 100644 --- a/typecheck/TcSplice.hs +++ /dev/null @@ -1,2002 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcSplice: Template Haskell splices --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiWayIf #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module TcSplice( - tcSpliceExpr, tcTypedBracket, tcUntypedBracket, --- runQuasiQuoteExpr, runQuasiQuotePat, --- runQuasiQuoteDecl, runQuasiQuoteType, - runAnnotation, - - runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, - tcTopSpliceExpr, lookupThName_maybe, - defaultRunMeta, runMeta', runRemoteModFinalizers, - finishTH - ) where - -#include "HsVersions.h" - -import HsSyn -import Annotations -import Name -import TcRnMonad -import TcType - -import Outputable -import TcExpr -import SrcLoc -import THNames -import TcUnify -import TcEnv - -import Control.Monad - -import GHCi.Message -import GHCi.RemoteTypes -import GHCi -import HscMain - -- These imports are the reason that TcSplice - -- is very high up the module hierarchy -import RnSplice( traceSplice, SpliceInfo(..) ) -import RdrName -import HscTypes -import Convert -import RnExpr -import RnEnv -import RnTypes -import TcHsSyn -import TcSimplify -import Type -import Kind -import NameSet -import TcMType -import TcHsType -import TcIface -import TyCoRep -import FamInst -import FamInstEnv -import InstEnv -import Inst -import NameEnv -import PrelNames -import TysWiredIn -import OccName -import Hooks -import Var -import Module -import LoadIface -import Class -import TyCon -import CoAxiom -import PatSyn -import ConLike -import DataCon -import TcEvidence( TcEvBinds(..) ) -import Id -import IdInfo -import DsExpr -import DsMonad -import GHC.Serialized -import ErrUtils -import Util -import Unique -import VarSet ( isEmptyVarSet, filterVarSet, mkVarSet, elemVarSet ) -import Data.List ( find ) -import Data.Maybe -import FastString -import BasicTypes hiding( SuccessFlag(..) ) -import Maybes( MaybeErr(..) ) -import DynFlags -import Panic -import Lexeme - -import qualified Language.Haskell.TH as TH --- THSyntax gives access to internal functions and data types -import qualified Language.Haskell.TH.Syntax as TH - --- Because GHC.Desugar might not be in the base library of the bootstrapping compiler -import GHC.Desugar ( AnnotationWrapper(..) ) - -import qualified Data.IntSet as IntSet -import Control.Exception -import Data.Binary -import Data.Binary.Get -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB -import Data.Dynamic ( fromDynamic, toDyn ) -import qualified Data.Map as Map -import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) -import Data.Data (Data) -import Data.Proxy ( Proxy (..) ) -import GHC.Exts ( unsafeCoerce# ) - -{- -************************************************************************ -* * -\subsection{Main interface + stubs for the non-GHCI case -* * -************************************************************************ --} - -tcTypedBracket :: HsBracket Name -> ExpRhoType -> TcM (HsExpr TcId) -tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) -tcSpliceExpr :: HsSplice Name -> ExpRhoType -> TcM (HsExpr TcId) - -- None of these functions add constraints to the LIE - --- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) --- runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName) --- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) --- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] - -runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation -{- -************************************************************************ -* * -\subsection{Quoting an expression} -* * -************************************************************************ --} - --- See Note [How brackets and nested splices are handled] --- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) -tcTypedBracket brack@(TExpBr expr) res_ty - = addErrCtxt (quotationCtxtDoc brack) $ - do { cur_stage <- getStage - ; ps_ref <- newMutVar [] - ; lie_var <- getConstraintVar -- Any constraints arising from nested splices - -- should get thrown into the constraint set - -- from outside the bracket - - -- Typecheck expr to make sure it is valid, - -- Throw away the typechecked expression but return its type. - -- We'll typecheck it again when we splice it in somewhere - ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $ - tcInferRhoNC expr - -- NC for no context; tcBracket does that - - ; meta_ty <- tcTExpTy expr_ty - ; ps' <- readMutVar ps_ref - ; texpco <- tcLookupId unsafeTExpCoerceName - ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") - (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty]) - (noLoc (HsTcBracketOut brack ps')))) - meta_ty res_ty } -tcTypedBracket other_brack _ - = pprPanic "tcTypedBracket" (ppr other_brack) - --- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) -tcUntypedBracket brack ps res_ty - = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) - ; ps' <- mapM tcPendingSplice ps - ; meta_ty <- tcBrackTy brack - ; traceTc "tc_bracket done untyped" (ppr meta_ty) - ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket") - (HsTcBracketOut brack ps') meta_ty res_ty } - ---------------- -tcBrackTy :: HsBracket Name -> TcM TcType -tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) -tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp) -tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) -tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec] -tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat) -tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL" -tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr" - ---------------- -tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice -tcPendingSplice (PendingRnSplice flavour splice_name expr) - = do { res_ty <- tcMetaTy meta_ty_name - ; expr' <- tcMonoExpr expr (mkCheckExpType res_ty) - ; return (PendingTcSplice splice_name expr') } - where - meta_ty_name = case flavour of - UntypedExpSplice -> expQTyConName - UntypedPatSplice -> patQTyConName - UntypedTypeSplice -> typeQTyConName - UntypedDeclSplice -> decsQTyConName - ---------------- --- Takes a tau and returns the type Q (TExp tau) -tcTExpTy :: TcType -> TcM TcType -tcTExpTy exp_ty - = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty) - ; q <- tcLookupTyCon qTyConName - ; texp <- tcLookupTyCon tExpTyConName - ; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) } - where - err_msg ty - = vcat [ text "Illegal polytype:" <+> ppr ty - , text "The type of a Typed Template Haskell expression must" <+> - text "not have any quantification." ] - -quotationCtxtDoc :: HsBracket Name -> SDoc -quotationCtxtDoc br_body - = hang (text "In the Template Haskell quotation") - 2 (ppr br_body) - - - -- The whole of the rest of the file is the else-branch (ie stage2 only) - -{- -Note [How top-level splices are handled] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Top-level splices (those not inside a [| .. |] quotation bracket) are handled -very straightforwardly: - - 1. tcTopSpliceExpr: typecheck the body e of the splice $(e) - - 2. runMetaT: desugar, compile, run it, and convert result back to - HsSyn RdrName (of the appropriate flavour, eg HsType RdrName, - HsExpr RdrName etc) - - 3. treat the result as if that's what you saw in the first place - e.g for HsType, rename and kind-check - for HsExpr, rename and type-check - - (The last step is different for decls, because they can *only* be - top-level: we return the result of step 2.) - -Note [How brackets and nested splices are handled] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Nested splices (those inside a [| .. |] quotation bracket), -are treated quite differently. - -Remember, there are two forms of bracket - typed [|| e ||] - and untyped [| e |] - -The life cycle of a typed bracket: - * Starts as HsBracket - - * When renaming: - * Set the ThStage to (Brack s RnPendingTyped) - * Rename the body - * Result is still a HsBracket - - * When typechecking: - * Set the ThStage to (Brack s (TcPending ps_var lie_var)) - * Typecheck the body, and throw away the elaborated result - * Nested splices (which must be typed) are typechecked, and - the results accumulated in ps_var; their constraints - accumulate in lie_var - * Result is a HsTcBracketOut rn_brack pending_splices - where rn_brack is the incoming renamed bracket - -The life cycle of a un-typed bracket: - * Starts as HsBracket - - * When renaming: - * Set the ThStage to (Brack s (RnPendingUntyped ps_var)) - * Rename the body - * Nested splices (which must be untyped) are renamed, and the - results accumulated in ps_var - * Result is still (HsRnBracketOut rn_body pending_splices) - - * When typechecking a HsRnBracketOut - * Typecheck the pending_splices individually - * Ignore the body of the bracket; just check that the context - expects a bracket of that type (e.g. a [p| pat |] bracket should - be in a context needing a (Q Pat) - * Result is a HsTcBracketOut rn_brack pending_splices - where rn_brack is the incoming renamed bracket - - -In both cases, desugaring happens like this: - * HsTcBracketOut is desugared by DsMeta.dsBracket. It - - a) Extends the ds_meta environment with the PendingSplices - attached to the bracket - - b) Converts the quoted (HsExpr Name) to a CoreExpr that, when - run, will produce a suitable TH expression/type/decl. This - is why we leave the *renamed* expression attached to the bracket: - the quoted expression should not be decorated with all the goop - added by the type checker - - * Each splice carries a unique Name, called a "splice point", thus - ${n}(e). The name is initialised to an (Unqual "splice") when the - splice is created; the renamer gives it a unique. - - * When DsMeta (used to desugar the body of the bracket) comes across - a splice, it looks up the splice's Name, n, in the ds_meta envt, - to find an (HsExpr Id) that should be substituted for the splice; - it just desugars it to get a CoreExpr (DsMeta.repSplice). - -Example: - Source: f = [| Just $(g 3) |] - The [| |] part is a HsBracket - - Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} - The [| |] part is a HsBracketOut, containing *renamed* - (not typechecked) expression - The "s7" is the "splice point"; the (g Int 3) part - is a typechecked expression - - Desugared: f = do { s7 <- g Int 3 - ; return (ConE "Data.Maybe.Just" s7) } - - -Note [Template Haskell state diagram] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here are the ThStages, s, their corresponding level numbers -(the result of (thLevel s)), and their state transitions. -The top level of the program is stage Comp: - - Start here - | - V - ----------- $ ------------ $ - | Comp | ---------> | Splice | -----| - | 1 | | 0 | <----| - ----------- ------------ - ^ | ^ | - $ | | [||] $ | | [||] - | v | v - -------------- ---------------- - | Brack Comp | | Brack Splice | - | 2 | | 1 | - -------------- ---------------- - -* Normal top-level declarations start in state Comp - (which has level 1). - Annotations start in state Splice, since they are - treated very like a splice (only without a '$') - -* Code compiled in state Splice (and only such code) - will be *run at compile time*, with the result replacing - the splice - -* The original paper used level -1 instead of 0, etc. - -* The original paper did not allow a splice within a - splice, but there is no reason not to. This is the - $ transition in the top right. - -Note [Template Haskell levels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Imported things are impLevel (= 0) - -* However things at level 0 are not *necessarily* imported. - eg $( \b -> ... ) here b is bound at level 0 - -* In GHCi, variables bound by a previous command are treated - as impLevel, because we have bytecode for them. - -* Variables are bound at the "current level" - -* The current level starts off at outerLevel (= 1) - -* The level is decremented by splicing $(..) - incremented by brackets [| |] - incremented by name-quoting 'f - -When a variable is used, we compare - bind: binding level, and - use: current level at usage site - - Generally - bind > use Always error (bound later than used) - [| \x -> $(f x) |] - - bind = use Always OK (bound same stage as used) - [| \x -> $(f [| x |]) |] - - bind < use Inside brackets, it depends - Inside splice, OK - Inside neither, OK - - For (bind < use) inside brackets, there are three cases: - - Imported things OK f = [| map |] - - Top-level things OK g = [| f |] - - Non-top-level Only if there is a liftable instance - h = \(x:Int) -> [| x |] - - To track top-level-ness we use the ThBindEnv in TcLclEnv - - For example: - f = ... - g1 = $(map ...) is OK - g2 = $(f ...) is not OK; because we havn't compiled f yet - --} - -{- -************************************************************************ -* * -\subsection{Splicing an expression} -* * -************************************************************************ --} - -tcSpliceExpr splice@(HsTypedSplice _ name expr) res_ty - = addErrCtxt (spliceCtxtDoc splice) $ - setSrcSpan (getLoc expr) $ do - { stage <- getStage - ; case stage of - Splice {} -> tcTopSplice expr res_ty - Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty - RunSplice _ -> - -- See Note [RunSplice ThLevel] in "TcRnTypes". - pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++ - "running another splice") (ppr splice) - Comp -> tcTopSplice expr res_ty - } -tcSpliceExpr splice _ - = pprPanic "tcSpliceExpr" (ppr splice) - -{- Note [Collecting modFinalizers in typed splices] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local -environment (see Note [Delaying modFinalizers in untyped splices] in -"RnSplice"). Thus after executing the splice, we move the finalizers to the -finalizer list in the global environment and set them to use the current local -environment (with 'addModFinalizersWithLclEnv'). - --} - -tcNestedSplice :: ThStage -> PendingStuff -> Name - -> LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id) - -- See Note [How brackets and nested splices are handled] - -- A splice inside brackets -tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty - = do { res_ty <- expTypeToType res_ty - ; meta_exp_ty <- tcTExpTy res_ty - ; expr' <- setStage pop_stage $ - setConstraintVar lie_var $ - tcMonoExpr expr (mkCheckExpType meta_exp_ty) - ; untypeq <- tcLookupId unTypeQName - ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr' - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) - - -- The returned expression is ignored; it's in the pending splices - ; return (panic "tcSpliceExpr") } - -tcNestedSplice _ _ splice_name _ _ - = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) - -tcTopSplice :: LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id) -tcTopSplice expr res_ty - = do { -- Typecheck the expression, - -- making sure it has type Q (T res_ty) - res_ty <- expTypeToType res_ty - ; meta_exp_ty <- tcTExpTy res_ty - ; zonked_q_expr <- tcTopSpliceExpr Typed $ - tcMonoExpr expr (mkCheckExpType meta_exp_ty) - - -- See Note [Collecting modFinalizers in typed splices]. - ; modfinalizers_ref <- newTcRef [] - -- Run the expression - ; expr2 <- setStage (RunSplice modfinalizers_ref) $ - runMetaE zonked_q_expr - ; mod_finalizers <- readTcRef modfinalizers_ref - ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers - ; traceSplice (SpliceInfo { spliceDescription = "expression" - , spliceIsDecl = False - , spliceSource = Just expr - , spliceGenerated = ppr expr2 }) - - -- Rename and typecheck the spliced-in expression, - -- making sure it has type res_ty - -- These steps should never fail; this is a *typed* splice - ; addErrCtxt (spliceResultDoc expr) $ do - { (exp3, _fvs) <- rnLExpr expr2 - ; exp4 <- tcMonoExpr exp3 (mkCheckExpType res_ty) - ; return (unLoc exp4) } } - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -spliceCtxtDoc :: HsSplice Name -> SDoc -spliceCtxtDoc splice - = hang (text "In the Template Haskell splice") - 2 (pprSplice splice) - -spliceResultDoc :: LHsExpr Name -> SDoc -spliceResultDoc expr - = sep [ text "In the result of the splice:" - , nest 2 (char '$' <> ppr expr) - , text "To see what the splice expanded to, use -ddump-splices"] - -------------------- -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) --- Note [How top-level splices are handled] --- Type check an expression that is the body of a top-level splice --- (the caller will compile and run it) --- Note that set the level to Splice, regardless of the original level, --- before typechecking the expression. For example: --- f x = $( ...$(g 3) ... ) --- The recursive call to tcPolyExpr will simply expand the --- inner escape before dealing with the outer one - -tcTopSpliceExpr isTypedSplice tc_action - = checkNoErrs $ -- checkNoErrs: must not try to run the thing - -- if the type checker fails! - unsetGOptM Opt_DeferTypeErrors $ - -- Don't defer type errors. Not only are we - -- going to run this code, but we do an unsafe - -- coerce, so we get a seg-fault if, say we - -- splice a type into a place where an expression - -- is expected (Trac #7276) - setStage (Splice isTypedSplice) $ - do { -- Typecheck the expression - (expr', wanted) <- captureConstraints tc_action - ; const_binds <- simplifyTop wanted - - -- Zonk it and tie the knot of dictionary bindings - ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') } - -{- -************************************************************************ -* * - Annotations -* * -************************************************************************ --} - -runAnnotation target expr = do - -- Find the classes we want instances for in order to call toAnnotationWrapper - loc <- getSrcSpanM - data_class <- tcLookupClass dataClassName - to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName - - -- Check the instances we require live in another module (we want to execute it..) - -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr - -- also resolves the LIE constraints to detect e.g. instance ambiguity - zonked_wrapped_expr' <- tcTopSpliceExpr Untyped $ - do { (expr', expr_ty) <- tcInferRhoNC expr - -- We manually wrap the typechecked expression in a call to toAnnotationWrapper - -- By instantiating the call >here< it gets registered in the - -- LIE consulted by tcTopSpliceExpr - -- and hence ensures the appropriate dictionary is bound by const_binds - ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] - ; let specialised_to_annotation_wrapper_expr - = L loc (HsWrap wrapper - (HsVar (L loc to_annotation_wrapper_id))) - ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) } - - -- Run the appropriately wrapped expression to get the value of - -- the annotation and its dictionaries. The return value is of - -- type AnnotationWrapper by construction, so this conversion is - -- safe - serialized <- runMetaAW zonked_wrapped_expr' - return Annotation { - ann_target = target, - ann_value = serialized - } - -convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized) -convertAnnotationWrapper fhv = do - dflags <- getDynFlags - if gopt Opt_ExternalInterpreter dflags - then do - Right <$> runTH THAnnWrapper fhv - else do - annotation_wrapper <- liftIO $ wormhole dflags fhv - return $ Right $ - case unsafeCoerce# annotation_wrapper of - AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> - -- Got the value and dictionaries: build the serialized value and - -- call it a day. We ensure that we seq the entire serialized value - -- in order that any errors in the user-written code for the - -- annotation are exposed at this point. This is also why we are - -- doing all this stuff inside the context of runMeta: it has the - -- facilities to deal with user error in a meta-level expression - seqSerialized serialized `seq` serialized - --- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms -seqSerialized :: Serialized -> () -seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () - - -{- -************************************************************************ -* * -\subsection{Running an expression} -* * -************************************************************************ --} - -runQuasi :: TH.Q a -> TcM a -runQuasi act = TH.runQ act - -runRemoteModFinalizers :: ThModFinalizers -> TcM () -runRemoteModFinalizers (ThModFinalizers finRefs) = do - dflags <- getDynFlags - let withForeignRefs [] f = f [] - withForeignRefs (x : xs) f = withForeignRef x $ \r -> - withForeignRefs xs $ \rs -> f (r : rs) - if gopt Opt_ExternalInterpreter dflags then do - hsc_env <- env_top <$> getEnv - withIServ hsc_env $ \i -> do - tcg <- getGblEnv - th_state <- readTcRef (tcg_th_remote_state tcg) - case th_state of - Nothing -> return () -- TH was not started, nothing to do - Just fhv -> do - liftIO $ withForeignRef fhv $ \st -> - withForeignRefs finRefs $ \qrefs -> - writeIServ i (putMessage (RunModFinalizers st qrefs)) - () <- runRemoteTH i [] - readQResult i - else do - qs <- liftIO (withForeignRefs finRefs $ mapM localRef) - runQuasi $ sequence_ qs - -runQResult - :: (a -> String) - -> (SrcSpan -> a -> b) - -> (ForeignHValue -> TcM a) - -> SrcSpan - -> ForeignHValue {- TH.Q a -} - -> TcM b -runQResult show_th f runQ expr_span hval - = do { th_result <- runQ hval - ; traceTc "Got TH result:" (text (show_th th_result)) - ; return (f expr_span th_result) } - - ------------------ -runMeta :: (MetaHook TcM -> LHsExpr Id -> TcM hs_syn) - -> LHsExpr Id - -> TcM hs_syn -runMeta unwrap e - = do { h <- getHooked runMetaHook defaultRunMeta - ; unwrap h e } - -defaultRunMeta :: MetaHook TcM -defaultRunMeta (MetaE r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp) -defaultRunMeta (MetaP r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat) -defaultRunMeta (MetaT r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType) -defaultRunMeta (MetaD r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) -defaultRunMeta (MetaAW r) - = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper) - -- We turn off showing the code in meta-level exceptions because doing so exposes - -- the toAnnotationWrapper function that we slap around the user's code - ----------------- -runMetaAW :: LHsExpr Id -- Of type AnnotationWrapper - -> TcM Serialized -runMetaAW = runMeta metaRequestAW - -runMetaE :: LHsExpr Id -- Of type (Q Exp) - -> TcM (LHsExpr RdrName) -runMetaE = runMeta metaRequestE - -runMetaP :: LHsExpr Id -- Of type (Q Pat) - -> TcM (LPat RdrName) -runMetaP = runMeta metaRequestP - -runMetaT :: LHsExpr Id -- Of type (Q Type) - -> TcM (LHsType RdrName) -runMetaT = runMeta metaRequestT - -runMetaD :: LHsExpr Id -- Of type Q [Dec] - -> TcM [LHsDecl RdrName] -runMetaD = runMeta metaRequestD - ---------------- -runMeta' :: Bool -- Whether code should be printed in the exception message - -> (hs_syn -> SDoc) -- how to print the code - -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x - -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that - -> TcM hs_syn -- Of type t -runMeta' show_code ppr_hs run_and_convert expr - = do { traceTc "About to run" (ppr expr) - ; recordThSpliceUse -- seems to be the best place to do this, - -- we catch all kinds of splices and annotations. - - -- Check that we've had no errors of any sort so far. - -- For example, if we found an error in an earlier defn f, but - -- recovered giving it type f :: forall a.a, it'd be very dodgy - -- to carry ont. Mind you, the staging restrictions mean we won't - -- actually run f, but it still seems wrong. And, more concretely, - -- see Trac #5358 for an example that fell over when trying to - -- reify a function with a "?" kind in it. (These don't occur - -- in type-correct programs. - ; failIfErrsM - - -- Desugar - ; ds_expr <- initDsTc (dsLExpr expr) - -- Compile and link it; might fail if linking fails - ; hsc_env <- getTopEnv - ; src_span <- getSrcSpanM - ; traceTc "About to run (desugared)" (ppr ds_expr) - ; either_hval <- tryM $ liftIO $ - HscMain.hscCompileCoreExpr hsc_env src_span ds_expr - ; case either_hval of { - Left exn -> fail_with_exn "compile and link" exn ; - Right hval -> do - - { -- Coerce it to Q t, and run it - - -- Running might fail if it throws an exception of any kind (hence tryAllM) - -- including, say, a pattern-match exception in the code we are running - -- - -- We also do the TH -> HS syntax conversion inside the same - -- exception-cacthing thing so that if there are any lurking - -- exceptions in the data structure returned by hval, we'll - -- encounter them inside the try - -- - -- See Note [Exceptions in TH] - let expr_span = getLoc expr - ; either_tval <- tryAllM $ - setSrcSpan expr_span $ -- Set the span so that qLocation can - -- see where this splice is - do { mb_result <- run_and_convert expr_span hval - ; case mb_result of - Left err -> failWithTc err - Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) - ; return $! result } } - - ; case either_tval of - Right v -> return v - Left se -> case fromException se of - Just IOEnvFailure -> failM -- Error already in Tc monad - _ -> fail_with_exn "run" se -- Exception - }}} - where - -- see Note [Concealed TH exceptions] - fail_with_exn :: Exception e => String -> e -> TcM a - fail_with_exn phase exn = do - exn_msg <- liftIO $ Panic.safeShowException exn - let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", - nest 2 (text exn_msg), - if show_code then text "Code:" <+> ppr expr else empty] - failWithTc msg - -{- -Note [Exceptions in TH] -~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have something like this - $( f 4 ) -where - f :: Int -> Q [Dec] - f n | n>3 = fail "Too many declarations" - | otherwise = ... - -The 'fail' is a user-generated failure, and should be displayed as a -perfectly ordinary compiler error message, not a panic or anything -like that. Here's how it's processed: - - * 'fail' is the monad fail. The monad instance for Q in TH.Syntax - effectively transforms (fail s) to - qReport True s >> fail - where 'qReport' comes from the Quasi class and fail from its monad - superclass. - - * The TcM monad is an instance of Quasi (see TcSplice), and it implements - (qReport True s) by using addErr to add an error message to the bag of errors. - The 'fail' in TcM raises an IOEnvFailure exception - - * 'qReport' forces the message to ensure any exception hidden in unevaluated - thunk doesn't get into the bag of errors. Otherwise the following splice - will triger panic (Trac #8987): - $(fail undefined) - See also Note [Concealed TH exceptions] - - * So, when running a splice, we catch all exceptions; then for - - an IOEnvFailure exception, we assume the error is already - in the error-bag (above) - - other errors, we add an error to the bag - and then fail - -Note [Concealed TH exceptions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When displaying the error message contained in an exception originated from TH -code, we need to make sure that the error message itself does not contain an -exception. For example, when executing the following splice: - - $( error ("foo " ++ error "bar") ) - -the message for the outer exception is a thunk which will throw the inner -exception when evaluated. - -For this reason, we display the message of a TH exception using the -'safeShowException' function, which recursively catches any exception thrown -when showing an error message. - - -To call runQ in the Tc monad, we need to make TcM an instance of Quasi: --} - -instance TH.Quasi TcM where - qNewName s = do { u <- newUnique - ; let i = getKey u - ; return (TH.mkNameU s i) } - - -- 'msg' is forced to ensure exceptions don't escape, - -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr (text msg) - qReport False msg = seqList msg $ addWarn NoReason (text msg) - - qLocation = do { m <- getModule - ; l <- getSrcSpanM - ; r <- case l of - UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" - (ppr l) - RealSrcSpan s -> return s - ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) - , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = unitIdString (moduleUnitId m) - , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) - , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } - - qLookupName = lookupName - qReify = reify - qReifyFixity nm = lookupThName nm >>= reifyFixity - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness nm = do { nm' <- lookupThName nm - ; dc <- tcLookupDataCon nm' - ; let bangs = dataConImplBangs dc - ; return (map reifyDecidedStrictness bangs) } - - -- For qRecover, discard error messages if - -- the recovery action is chosen. Otherwise - -- we'll only fail higher up. - qRecover recover main = tryTcDiscardingErrs recover main - qRunIO io = liftIO io - - qAddDependentFile fp = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fp:dep_files) - - qAddTopDecls thds = do - l <- getSrcSpanM - let either_hval = convertToHsDecls l thds - ds <- case either_hval of - Left exn -> pprPanic "qAddTopDecls: can't convert top-level declarations" exn - Right ds -> return ds - mapM_ (checkTopDecl . unLoc) ds - th_topdecls_var <- fmap tcg_th_topdecls getGblEnv - updTcRef th_topdecls_var (\topds -> ds ++ topds) - where - checkTopDecl :: HsDecl RdrName -> TcM () - checkTopDecl (ValD binds) - = mapM_ bindName (collectHsBindBinders binds) - checkTopDecl (SigD _) - = return () - checkTopDecl (AnnD _) - = return () - checkTopDecl (ForD (ForeignImport { fd_name = L _ name })) - = bindName name - checkTopDecl _ - = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" - - bindName :: RdrName -> TcM () - bindName (Exact n) - = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) - } - - bindName name = - addErr $ - hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) - 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") - - qAddForeignFile lang str = do - var <- fmap tcg_th_foreign_files getGblEnv - updTcRef var ((lang, str) :) - - qAddModFinalizer fin = do - r <- liftIO $ mkRemoteRef fin - fref <- liftIO $ mkForeignRef r (freeRemoteRef r) - addModFinalizerRef fref - - qGetQ :: forall a. Typeable a => TcM (Maybe a) - qGetQ = do - th_state_var <- fmap tcg_th_state getGblEnv - th_state <- readTcRef th_state_var - -- See #10596 for why we use a scoped type variable here. - return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) - - qPutQ x = do - th_state_var <- fmap tcg_th_state getGblEnv - updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) - - qIsExtEnabled = xoptM - - qExtsEnabled = do - dflags <- hsc_dflags <$> getTopEnv - return $ map toEnum $ IntSet.elems $ extensionFlags dflags - --- | Adds a mod finalizer reference to the local environment. -addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () -addModFinalizerRef finRef = do - th_stage <- getStage - case th_stage of - RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :) - -- This case happens only if a splice is executed and the caller does - -- not set the 'ThStage' to 'RunSplice' to collect finalizers. - -- See Note [Delaying modFinalizers in untyped splices] in RnSplice. - _ -> - pprPanic "addModFinalizer was called when no finalizers were collected" - (ppr th_stage) - --- | Releases the external interpreter state. -finishTH :: TcM () -finishTH = do - dflags <- getDynFlags - when (gopt Opt_ExternalInterpreter dflags) $ do - tcg <- getGblEnv - writeTcRef (tcg_th_remote_state tcg) Nothing - -runTHExp :: ForeignHValue -> TcM TH.Exp -runTHExp = runTH THExp - -runTHPat :: ForeignHValue -> TcM TH.Pat -runTHPat = runTH THPat - -runTHType :: ForeignHValue -> TcM TH.Type -runTHType = runTH THType - -runTHDec :: ForeignHValue -> TcM [TH.Dec] -runTHDec = runTH THDec - -runTH :: Binary a => THResultType -> ForeignHValue -> TcM a -runTH ty fhv = do - hsc_env <- env_top <$> getEnv - dflags <- getDynFlags - if not (gopt Opt_ExternalInterpreter dflags) - then do - -- Run it in the local TcM - hv <- liftIO $ wormhole dflags fhv - r <- runQuasi (unsafeCoerce# hv :: TH.Q a) - return r - else - -- Run it on the server. For an overview of how TH works with - -- Remote GHCi, see Note [Remote Template Haskell] in - -- libraries/ghci/GHCi/TH.hs. - withIServ hsc_env $ \i -> do - rstate <- getTHState i - loc <- TH.qLocation - liftIO $ - withForeignRef rstate $ \state_hv -> - withForeignRef fhv $ \q_hv -> - writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc))) - runRemoteTH i [] - bs <- readQResult i - return $! runGet get (LB.fromStrict bs) - - --- | communicate with a remotely-running TH computation until it finishes. --- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. -runRemoteTH - :: IServ - -> [Messages] -- saved from nested calls to qRecover - -> TcM () -runRemoteTH iserv recovers = do - THMsg msg <- liftIO $ readIServ iserv getTHMessage - case msg of - RunTHDone -> return () - StartRecover -> do -- Note [TH recover with -fexternal-interpreter] - v <- getErrsVar - msgs <- readTcRef v - writeTcRef v emptyMessages - runRemoteTH iserv (msgs : recovers) - EndRecover caught_error -> do - v <- getErrsVar - let (prev_msgs, rest) = case recovers of - [] -> panic "EndRecover" - a : b -> (a,b) - if caught_error - then writeTcRef v prev_msgs - else updTcRef v (unionMessages prev_msgs) - runRemoteTH iserv rest - _other -> do - r <- handleTHMessage msg - liftIO $ writeIServ iserv (put r) - runRemoteTH iserv recovers - --- | Read a value of type QResult from the iserv -readQResult :: Binary a => IServ -> TcM a -readQResult i = do - qr <- liftIO $ readIServ i get - case qr of - QDone a -> return a - QException str -> liftIO $ throwIO (ErrorCall str) - QFail str -> fail str - -{- Note [TH recover with -fexternal-interpreter] - -Recover is slightly tricky to implement. - -The meaning of "recover a b" is - - Do a - - If it finished successfully, then keep the messages it generated - - If it failed, discard any messages it generated, and do b - -The messages are managed by GHC in the TcM monad, whereas the -exception-handling is done in the ghc-iserv process, so we have to -coordinate between the two. - -On the server: - - emit a StartRecover message - - run "a" inside a catch - - if it finishes, emit EndRecover False - - if it fails, emit EndRecover True, then run "b" - -Back in GHC, when we receive: - - StartRecover - save the current messages and start with an empty set. - EndRecover caught_error - Restore the previous messages, - and merge in the new messages if caught_error is false. --} - --- | Retrieve (or create, if it hasn't been created already), the --- remote TH state. The TH state is a remote reference to an IORef --- QState living on the server, and we have to pass this to each RunTH --- call we make. --- --- The TH state is stored in tcg_th_remote_state in the TcGblEnv. --- -getTHState :: IServ -> TcM (ForeignRef (IORef QState)) -getTHState i = do - tcg <- getGblEnv - th_state <- readTcRef (tcg_th_remote_state tcg) - case th_state of - Just rhv -> return rhv - Nothing -> do - hsc_env <- env_top <$> getEnv - fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH - writeTcRef (tcg_th_remote_state tcg) (Just fhv) - return fhv - -wrapTHResult :: TcM a -> TcM (THResult a) -wrapTHResult tcm = do - e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic - case e of - Left e -> return (THException (show e)) - Right a -> return (THComplete a) - -handleTHMessage :: THMessage a -> TcM a -handleTHMessage msg = case msg of - NewName a -> wrapTHResult $ TH.qNewName a - Report b str -> wrapTHResult $ TH.qReport b str - LookupName b str -> wrapTHResult $ TH.qLookupName b str - Reify n -> wrapTHResult $ TH.qReify n - ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n - ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts - ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n - ReifyAnnotations lookup tyrep -> - wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) - ReifyModule m -> wrapTHResult $ TH.qReifyModule m - ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm - AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f - AddModFinalizer r -> do - hsc_env <- env_top <$> getEnv - wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef - AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs - AddForeignFile lang str -> wrapTHResult $ TH.qAddForeignFile lang str - IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext - ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled - _ -> panic ("handleTHMessage: unexpected message " ++ show msg) - -getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]] -getAnnotationsByTypeRep th_name tyrep - = do { name <- lookupThAnnLookup th_name - ; topEnv <- getTopEnv - ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing - ; tcg <- getGblEnv - ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep - ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep - ; return (selectedEpsHptAnns ++ selectedTcgAnns) } - -{- -************************************************************************ -* * - Instance Testing -* * -************************************************************************ --} - -reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] -reifyInstances th_nm th_tys - = addErrCtxt (text "In the argument of reifyInstances:" - <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ - do { loc <- getSrcSpanM - ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys) - -- #9262 says to bring vars into scope, like in HsForAllTy case - -- of rnHsTyKi - ; free_vars <- extractHsTyRdrTyVars rdr_ty - ; let tv_rdrs = freeKiTyVarsAllVars free_vars - -- Rename to HsType Name - ; ((tv_names, rn_ty), _fvs) - <- bindLRdrNames tv_rdrs $ \ tv_names -> - do { (rn_ty, fvs) <- rnLHsType doc rdr_ty - ; return ((tv_names, rn_ty), fvs) } - ; (_tvs, ty) - <- solveEqualities $ - tcImplicitTKBndrsType tv_names $ - fst <$> tcLHsType rn_ty - ; ty <- zonkTcTypeToType emptyZonkEnv ty - -- Substitute out the meta type variables - -- In particular, the type might have kind - -- variables inside it (Trac #7477) - - ; traceTc "reifyInstances" (ppr ty $$ ppr (typeKind ty)) - ; case splitTyConApp_maybe ty of -- This expands any type synonyms - Just (tc, tys) -- See Trac #7910 - | Just cls <- tyConClass_maybe tc - -> do { inst_envs <- tcGetInstEnvs - ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys - ; traceTc "reifyInstances1" (ppr matches) - ; reifyClassInstances cls (map fst matches ++ unifies) } - | isOpenFamilyTyCon tc - -> do { inst_envs <- tcGetFamInstEnvs - ; let matches = lookupFamInstEnv inst_envs tc tys - ; traceTc "reifyInstances2" (ppr matches) - ; reifyFamilyInstances tc (map fim_instance matches) } - _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) - 2 (text "is not a class constraint or type family application")) } - where - doc = ClassInstanceCtx - bale_out msg = failWithTc msg - - cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName) - cvt loc th_ty = case convertToHsType loc th_ty of - Left msg -> failWithTc msg - Right ty -> return ty - -{- -************************************************************************ -* * - Reification -* * -************************************************************************ --} - -lookupName :: Bool -- True <=> type namespace - -- False <=> value namespace - -> String -> TcM (Maybe TH.Name) -lookupName is_type_name s - = do { lcl_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv lcl_env rdr_name of - Just n -> return (Just (reifyName n)) - Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name - ; return (fmap reifyName mb_nm) } } - where - th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' - - occ_fs :: FastString - occ_fs = mkFastString (TH.nameBase th_name) - - occ :: OccName - occ | is_type_name - = if isLexVarSym occ_fs || isLexCon occ_fs - then mkTcOccFS occ_fs - else mkTyVarOccFS occ_fs - | otherwise - = if isLexCon occ_fs then mkDataOccFS occ_fs - else mkVarOccFS occ_fs - - rdr_name = case TH.nameModule th_name of - Nothing -> mkRdrUnqual occ - Just mod -> mkRdrQual (mkModuleName mod) occ - -getThing :: TH.Name -> TcM TcTyThing -getThing th_name - = do { name <- lookupThName th_name - ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) - ; tcLookupTh name } - -- ToDo: this tcLookup could fail, which would give a - -- rather unhelpful error message - where - ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" - ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" - ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" - ppr_ns _ = panic "reify/ppr_ns" - -reify :: TH.Name -> TcM TH.Info -reify th_name - = do { traceTc "reify 1" (text (TH.showName th_name)) - ; thing <- getThing th_name - ; traceTc "reify 2" (ppr thing) - ; reifyThing thing } - -lookupThName :: TH.Name -> TcM Name -lookupThName th_name = do - mb_name <- lookupThName_maybe th_name - case mb_name of - Nothing -> failWithTc (notInScope th_name) - Just name -> return name - -lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -lookupThName_maybe th_name - = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) - -- Pick the first that works - -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A - ; return (listToMaybe names) } - where - lookup rdr_name - = do { -- Repeat much of lookupOccRn, because we want - -- to report errors in a TH-relevant way - ; rdr_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv rdr_env rdr_name of - Just name -> return (Just name) - Nothing -> lookupGlobalOccRn_maybe rdr_name } - -tcLookupTh :: Name -> TcM TcTyThing --- This is a specialised version of TcEnv.tcLookup; specialised mainly in that --- it gives a reify-related error message on failure, whereas in the normal --- tcLookup, failure is a bug. -tcLookupTh name - = do { (gbl_env, lcl_env) <- getEnvs - ; case lookupNameEnv (tcl_env lcl_env) name of { - Just thing -> return thing; - Nothing -> - - case lookupNameEnv (tcg_type_env gbl_env) name of { - Just thing -> return (AGlobal thing); - Nothing -> - - -- EZY: I don't think this choice matters, no TH in signatures! - if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name - then -- It's defined in this module - failWithTc (notInEnv name) - - else - do { mb_thing <- tcLookupImported_maybe name - ; case mb_thing of - Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc msg - }}}} - -notInScope :: TH.Name -> SDoc -notInScope th_name = quotes (text (TH.pprint th_name)) <+> - text "is not in scope at a reify" - -- Ugh! Rather an indirect way to display the name - -notInEnv :: Name -> SDoc -notInEnv name = quotes (ppr name) <+> - text "is not in the type environment at a reify" - ------------------------------- -reifyRoles :: TH.Name -> TcM [TH.Role] -reifyRoles th_name - = do { thing <- getThing th_name - ; case thing of - AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (text "No roles associated with" <+> (ppr thing)) - } - where - reify_role Nominal = TH.NominalR - reify_role Representational = TH.RepresentationalR - reify_role Phantom = TH.PhantomR - ------------------------------- -reifyThing :: TcTyThing -> TcM TH.Info --- The only reason this is monadic is for error reporting, --- which in turn is mainly for the case when TH can't express --- some random GHC extension - -reifyThing (AGlobal (AnId id)) - = do { ty <- reifyType (idType id) - ; let v = reifyName id - ; case idDetails id of - ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls)) - RecSelId{sel_tycon=RecSelData tc} - -> return (TH.VarI (reifySelector id tc) ty Nothing) - _ -> return (TH.VarI v ty Nothing) - } - -reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc -reifyThing (AGlobal (AConLike (RealDataCon dc))) - = do { let name = dataConName dc - ; ty <- reifyType (idType (dataConWrapId dc)) - ; return (TH.DataConI (reifyName name) ty - (reifyName (dataConOrigTyCon dc))) - } - -reifyThing (AGlobal (AConLike (PatSynCon ps))) - = do { let name = reifyName ps - ; ty <- reifyPatSynType (patSynSig ps) - ; return (TH.PatSynI name ty) } - -reifyThing (ATcId {tct_id = id}) - = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even - -- though it may be incomplete - ; ty2 <- reifyType ty1 - ; return (TH.VarI (reifyName id) ty2 Nothing) } - -reifyThing (ATyVar tv tv1) - = do { ty1 <- zonkTcTyVar tv1 - ; ty2 <- reifyType ty1 - ; return (TH.TyVarI (reifyName tv) ty2) } - -reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) - -------------------------------------------- -reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn -reifyAxBranch fam_tc (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) - -- remove kind patterns (#8884) - = do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs - ; lhs' <- reifyTypes lhs_types_only - ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs) - lhs_types_only lhs' - ; rhs' <- reifyType rhs - ; return (TH.TySynEqn annot_th_lhs rhs') } - where - fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc) - -reifyTyCon :: TyCon -> TcM TH.Info -reifyTyCon tc - | Just cls <- tyConClass_maybe tc - = reifyClass cls - - | isFunTyCon tc - = return (TH.PrimTyConI (reifyName tc) 2 False) - - | isPrimTyCon tc - = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnliftedTyCon tc)) - - | isTypeFamilyTyCon tc - = do { let tvs = tyConTyVars tc - res_kind = tyConResKind tc - resVar = famTcResVar tc - - ; kind' <- reifyKind res_kind - ; let (resultSig, injectivity) = - case resVar of - Nothing -> (TH.KindSig kind', Nothing) - Just name -> - let thName = reifyName name - injAnnot = familyTyConInjectivityInfo tc - sig = TH.TyVarSig (TH.KindedTV thName kind') - inj = case injAnnot of - NotInjective -> Nothing - Injective ms -> - Just (TH.InjectivityAnn thName injRHS) - where - injRHS = map (reifyName . tyVarName) - (filterByList ms tvs) - in (sig, inj) - ; tvs' <- reifyTyVars tvs (Just tc) - ; let tfHead = - TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity - ; if isOpenTypeFamilyTyCon tc - then do { fam_envs <- tcGetFamInstEnvs - ; instances <- reifyFamilyInstances tc - (familyInstances fam_envs tc) - ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) } - else do { eqns <- - case isClosedSynFamilyTyConWithAxiom_maybe tc of - Just ax -> mapM (reifyAxBranch tc) $ - fromBranches $ coAxiomBranches ax - Nothing -> return [] - ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns) - []) } } - - | isDataFamilyTyCon tc - = do { let tvs = tyConTyVars tc - res_kind = tyConResKind tc - - ; kind' <- fmap Just (reifyKind res_kind) - - ; tvs' <- reifyTyVars tvs (Just tc) - ; fam_envs <- tcGetFamInstEnvs - ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) - ; return (TH.FamilyI - (TH.DataFamilyD (reifyName tc) tvs' kind') instances) } - - | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym - = do { rhs' <- reifyType rhs - ; tvs' <- reifyTyVars tvs (Just tc) - ; return (TH.TyConI - (TH.TySynD (reifyName tc) tvs' rhs')) - } - - | otherwise - = do { cxt <- reifyCxt (tyConStupidTheta tc) - ; let tvs = tyConTyVars tc - dataCons = tyConDataCons tc - -- see Note [Reifying GADT data constructors] - isGadt = any (not . null . dataConEqSpec) dataCons - ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons - ; r_tvs <- reifyTyVars tvs (Just tc) - ; let name = reifyName tc - deriv = [] -- Don't know about deriving - decl | isNewTyCon tc = - TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv - | otherwise = - TH.DataD cxt name r_tvs Nothing cons deriv - ; return (TH.TyConI decl) } - -reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con --- For GADTs etc, see Note [Reifying GADT data constructors] -reifyDataCon isGadtDataCon tys dc - = do { let -- used for H98 data constructors - (ex_tvs, theta, arg_tys) - = dataConInstSig dc tys - -- used for GADTs data constructors - (g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, g_res_ty) - = dataConFullSig dc - (srcUnpks, srcStricts) - = mapAndUnzip reifySourceBang (dataConSrcBangs dc) - dcdBangs = zipWith TH.Bang srcUnpks srcStricts - fields = dataConFieldLabels dc - name = reifyName dc - -- Universal tvs present in eq_spec need to be filtered out, as - -- they will not appear anywhere in the type. - eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec) - g_unsbst_univ_tvs = filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs - - ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys) - - ; main_con <- - if | not (null fields) && not isGadtDataCon -> - return $ TH.RecC name (zip3 (map reifyFieldLabel fields) - dcdBangs r_arg_tys) - | not (null fields) -> do - { res_ty <- reifyType g_res_ty - ; return $ TH.RecGadtC [name] - (zip3 (map (reifyName . flSelector) fields) - dcdBangs r_arg_tys) res_ty } - -- We need to check not isGadtDataCon here because GADT - -- constructors can be declared infix. - -- See Note [Infix GADT constructors] in TcTyClsDecls. - | dataConIsInfix dc && not isGadtDataCon -> - ASSERT( length arg_tys == 2 ) do - { let [r_a1, r_a2] = r_arg_tys - [s1, s2] = dcdBangs - ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) } - | isGadtDataCon -> do - { res_ty <- reifyType g_res_ty - ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty } - | otherwise -> - return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) - - ; let (ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs - , g_theta ) - | otherwise = ( ex_tvs, theta ) - ret_con | null ex_tvs' && null theta' = return main_con - | otherwise = do - { cxt <- reifyCxt theta' - ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing - ; return (TH.ForallC ex_tvs'' cxt main_con) } - ; ASSERT( length arg_tys == length dcdBangs ) - ret_con } - --- Note [Reifying GADT data constructors] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- At this point in the compilation pipeline we have no way of telling whether a --- data type was declared as a H98 data type or as a GADT. We have to rely on --- heuristics here. We look at dcEqSpec field of all data constructors in a --- data type declaration. If at least one data constructor has non-empty --- dcEqSpec this means that the data type must have been declared as a GADT. --- Consider these declarations: --- --- data T a where --- MkT :: forall a. (a ~ Int) => T a --- --- data T a where --- MkT :: T Int --- --- First declaration will be reified as a GADT. Second declaration will be --- reified as a normal H98 data type declaration. - ------------------------------- -reifyClass :: Class -> TcM TH.Info -reifyClass cls - = do { cxt <- reifyCxt theta - ; inst_envs <- tcGetInstEnvs - ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) - ; assocTys <- concatMapM reifyAT ats - ; ops <- concatMapM reify_op op_stuff - ; tvs' <- reifyTyVars tvs (Just $ classTyCon cls) - ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) - ; return (TH.ClassI dec insts) } - where - (tvs, fds, theta, _, ats, op_stuff) = classExtraBigSig cls - fds' = map reifyFunDep fds - reify_op (op, def_meth) - = do { ty <- reifyType (idType op) - ; let nm' = reifyName op - ; case def_meth of - Just (_, GenericDM gdm_ty) -> - do { gdm_ty' <- reifyType gdm_ty - ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty'] } - _ -> return [TH.SigD nm' ty] } - - reifyAT :: ClassATItem -> TcM [TH.Dec] - reifyAT (ATI tycon def) = do - tycon' <- reifyTyCon tycon - case tycon' of - TH.FamilyI dec _ -> do - let (tyName, tyArgs) = tfNames dec - (dec :) <$> maybe (return []) - (fmap (:[]) . reifyDefImpl tyName tyArgs . fst) - def - _ -> pprPanic "reifyAT" (text (show tycon')) - - reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec - reifyDefImpl n args ty = - TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty - - tfNames :: TH.Dec -> (TH.Name, [TH.Name]) - tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _)) - = (n, map bndrName args) - tfNames d = pprPanic "tfNames" (text (show d)) - - bndrName :: TH.TyVarBndr -> TH.Name - bndrName (TH.PlainTV n) = n - bndrName (TH.KindedTV n _) = n - ------------------------------- --- | Annotate (with TH.SigT) a type if the first parameter is True --- and if the type contains a free variable. --- This is used to annotate type patterns for poly-kinded tyvars in --- reifying class and type instances. See #8953 and th/T8953. -annotThType :: Bool -- True <=> annotate - -> TyCoRep.Type -> TH.Type -> TcM TH.Type - -- tiny optimization: if the type is annotated, don't annotate again. -annotThType _ _ th_ty@(TH.SigT {}) = return th_ty -annotThType True ty th_ty - | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty - = do { let ki = typeKind ty - ; th_ki <- reifyKind ki - ; return (TH.SigT th_ty th_ki) } -annotThType _ _ th_ty = return th_ty - --- | For every type variable in the input, --- report whether or not the tv is poly-kinded. This is used to eventually --- feed into 'annotThType'. -mkIsPolyTvs :: [TyVar] -> [Bool] -mkIsPolyTvs = map is_poly_tv - where - is_poly_tv tv = not $ - isEmptyVarSet $ - filterVarSet isTyVar $ - tyCoVarsOfType $ - tyVarKind tv - ------------------------------- -reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] -reifyClassInstances cls insts - = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts - where - tvs = filterOutInvisibleTyVars (classTyCon cls) (classTyVars cls) - -reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- includes only *visible* tvs - -> ClsInst -> TcM TH.Dec -reifyClassInstance is_poly_tvs i - = do { cxt <- reifyCxt theta - ; let vis_types = filterOutInvisibleTypes cls_tc types - ; thtypes <- reifyTypes vis_types - ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes - ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes - ; return $ (TH.InstanceD over cxt head_ty []) } - where - (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) - cls_tc = classTyCon cls - dfun = instanceDFunId i - over = case overlapMode (is_flag i) of - NoOverlap _ -> Nothing - Overlappable _ -> Just TH.Overlappable - Overlapping _ -> Just TH.Overlapping - Overlaps _ -> Just TH.Overlaps - Incoherent _ -> Just TH.Incoherent - ------------------------------- -reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] -reifyFamilyInstances fam_tc fam_insts - = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts - where - fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc) - -reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- includes only *visible* tvs - -> FamInst -> TcM TH.Dec -reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor - , fi_fam = fam - , fi_tvs = fam_tvs - , fi_tys = lhs - , fi_rhs = rhs }) - = case flavor of - SynFamilyInst -> - -- remove kind patterns (#8884) - do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs - ; th_lhs <- reifyTypes lhs_types_only - ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only - th_lhs - ; th_rhs <- reifyType rhs - ; return (TH.TySynInstD (reifyName fam) - (TH.TySynEqn annot_th_lhs th_rhs)) } - - DataFamilyInst rep_tc -> - do { let rep_tvs = tyConTyVars rep_tc - fam' = reifyName fam - - -- eta-expand lhs types, because sometimes data/newtype - -- instances are eta-reduced; See Trac #9692 - -- See Note [Eta reduction for data family axioms] - -- in TcInstDcls - (_rep_tc, rep_tc_args) = splitTyConApp rhs - etad_tyvars = dropList rep_tc_args rep_tvs - etad_tys = mkTyVarTys etad_tyvars - eta_expanded_tvs = mkTyVarTys fam_tvs `chkAppend` etad_tys - eta_expanded_lhs = lhs `chkAppend` etad_tys - dataCons = tyConDataCons rep_tc - -- see Note [Reifying GADT data constructors] - isGadt = any (not . null . dataConEqSpec) dataCons - ; cons <- mapM (reifyDataCon isGadt eta_expanded_tvs) dataCons - ; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs - ; th_tys <- reifyTypes types_only - ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys - ; return $ - if isNewTyCon rep_tc - then TH.NewtypeInstD [] fam' annot_th_tys Nothing (head cons) [] - else TH.DataInstD [] fam' annot_th_tys Nothing cons [] - } - where - fam_tc = famInstTyCon inst - ------------------------------- -reifyType :: TyCoRep.Type -> TcM TH.Type --- Monadic only because of failure -reifyType ty@(ForAllTy {}) = reify_for_all ty -reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } -reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) -reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here -reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) } -reifyType ty@(FunTy t1 t2) - | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) - | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } -reifyType ty@(CastTy {}) = noTH (sLit "kind casts") (ppr ty) -reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty) - -reify_for_all :: TyCoRep.Type -> TcM TH.Type -reify_for_all ty - = do { cxt' <- reifyCxt cxt; - ; tau' <- reifyType tau - ; tvs' <- reifyTyVars tvs Nothing - ; return (TH.ForallT tvs' cxt' tau') } - where - (tvs, cxt, tau) = tcSplitSigmaTy ty - -reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit -reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) -reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) - -reifyTypes :: [Type] -> TcM [TH.Type] -reifyTypes = mapM reifyType - -reifyPatSynType - :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type --- reifies a pattern synonym's type and returns its *complete* type --- signature; see NOTE [Pattern synonym signatures and Template --- Haskell] -reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) - = do { univTyVars' <- reifyTyVars univTyVars Nothing - ; req' <- reifyCxt req - ; exTyVars' <- reifyTyVars exTyVars Nothing - ; prov' <- reifyCxt prov - ; tau' <- reifyType (mkFunTys argTys resTy) - ; return $ TH.ForallT univTyVars' req' - $ TH.ForallT exTyVars' prov' tau' } - -reifyKind :: Kind -> TcM TH.Kind -reifyKind ki - = do { let (kis, ki') = splitFunTys ki - ; ki'_rep <- reifyNonArrowKind ki' - ; kis_rep <- mapM reifyKind kis - ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) } - where - reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT - | isConstraintKind k = return TH.ConstraintT - reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v)) - reifyNonArrowKind (FunTy _ k) = reifyKind k - reifyNonArrowKind (ForAllTy _ k) = reifyKind k - reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis - reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1 - ; k2' <- reifyKind k2 - ; return (TH.AppT k1' k2') - } - reifyNonArrowKind k = noTH (sLit "this kind") (ppr k) - -reify_kc_app :: TyCon -> [TyCoRep.Kind] -> TcM TH.Kind -reify_kc_app kc kis - = fmap (mkThAppTs r_kc) (mapM reifyKind vis_kis) - where - r_kc | isTupleTyCon kc = TH.TupleT (tyConArity kc) - | kc `hasKey` listTyConKey = TH.ListT - | otherwise = TH.ConT (reifyName kc) - - vis_kis = filterOutInvisibleTypes kc kis - -reifyCxt :: [PredType] -> TcM [TH.Pred] -reifyCxt = mapM reifyPred - -reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep -reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) - -reifyTyVars :: [TyVar] - -> Maybe TyCon -- the tycon if the tycovars are from a tycon. - -- Used to detect which tvs are implicit. - -> TcM [TH.TyVarBndr] -reifyTyVars tvs m_tc = mapM reify_tv tvs' - where - tvs' = case m_tc of - Just tc -> filterOutInvisibleTyVars tc tvs - Nothing -> tvs - - -- even if the kind is *, we need to include a kind annotation, - -- in case a poly-kind would be inferred without the annotation. - -- See #8953 or test th/T8953 - reify_tv tv = TH.KindedTV name <$> reifyKind kind - where - kind = tyVarKind tv - name = reifyName tv - -{- -Note [Kind annotations on TyConApps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A poly-kinded tycon sometimes needs a kind annotation to be unambiguous. -For example: - - type family F a :: k - type instance F Int = (Proxy :: * -> *) - type instance F Bool = (Proxy :: (* -> *) -> *) - -It's hard to figure out where these annotations should appear, so we do this: -Suppose the tycon is applied to n arguments. We strip off the first n -arguments of the tycon's kind. If there are any variables left in the result -kind, we put on a kind annotation. But we must be slightly careful: it's -possible that the tycon's kind will have fewer than n arguments, in the case -that the concrete application instantiates a result kind variable with an -arrow kind. So, if we run out of arguments, we conservatively put on a kind -annotation anyway. This should be a rare case, indeed. Here is an example: - - data T1 :: k1 -> k2 -> * - data T2 :: k1 -> k2 -> * - - type family G (a :: k) :: k - type instance G T1 = T2 - - type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above - -Here G's kind is (forall k. k -> k), and the desugared RHS of that last -instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to -the algorithm above, there are 3 arguments to G so we should peel off 3 -arguments in G's kind. But G's kind has only two arguments. This is the -rare special case, and we conservatively choose to put the annotation -in. - -See #8953 and test th/T8953. --} - -reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type -reify_tc_app tc tys - = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys) - ; maybe_sig_t (mkThAppTs r_tc tys') } - where - arity = tyConArity tc - tc_binders = tyConBinders tc - tc_res_kind = tyConResKind tc - - r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2) - | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2) - | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2) - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - | isTupleTyCon tc = if isPromotedDataCon tc - then TH.PromotedTupleT arity - else TH.TupleT arity - | tc `hasKey` listTyConKey = TH.ListT - | tc `hasKey` nilDataConKey = TH.PromotedNilT - | tc `hasKey` consDataConKey = TH.PromotedConsT - | tc `hasKey` heqTyConKey = TH.EqualityT - | tc `hasKey` eqPrimTyConKey = TH.EqualityT - | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) - | isPromotedDataCon tc = TH.PromotedT (reifyName tc) - | otherwise = TH.ConT (reifyName tc) - - -- See Note [Kind annotations on TyConApps] - maybe_sig_t th_type - | needs_kind_sig - = do { let full_kind = typeKind (mkTyConApp tc tys) - ; th_full_kind <- reifyKind full_kind - ; return (TH.SigT th_type th_full_kind) } - | otherwise - = return th_type - - needs_kind_sig - | GT <- compareLength tys tc_binders - = tcIsTyVarTy tc_res_kind - | otherwise - = not . isEmptyVarSet $ - filterVarSet isTyVar $ - tyCoVarsOfType $ - mkTyConKind (dropList tys tc_binders) tc_res_kind - -reifyPred :: TyCoRep.PredType -> TcM TH.Pred -reifyPred ty - -- We could reify the invisible parameter as a class but it seems - -- nicer to support them properly... - | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty) - | otherwise = reifyType ty - ------------------------------- -reifyName :: NamedThing n => n -> TH.Name -reifyName thing - | isExternalName name = mk_varg pkg_str mod_str occ_str - | otherwise = TH.mkNameU occ_str (getKey (getUnique name)) - -- Many of the things we reify have local bindings, and - -- NameL's aren't supposed to appear in binding positions, so - -- we use NameU. When/if we start to reify nested things, that - -- have free variables, we may need to generate NameL's for them. - where - name = getName thing - mod = ASSERT( isExternalName name ) nameModule name - pkg_str = unitIdString (moduleUnitId mod) - mod_str = moduleNameString (moduleName mod) - occ_str = occNameString occ - occ = nameOccName name - mk_varg | OccName.isDataOcc occ = TH.mkNameG_d - | OccName.isVarOcc occ = TH.mkNameG_v - | OccName.isTcOcc occ = TH.mkNameG_tc - | otherwise = pprPanic "reifyName" (ppr name) - --- See Note [Reifying field labels] -reifyFieldLabel :: FieldLabel -> TH.Name -reifyFieldLabel fl - | flIsOverloaded fl - = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str)) - | otherwise = TH.mkNameG_v pkg_str mod_str occ_str - where - name = flSelector fl - mod = ASSERT( isExternalName name ) nameModule name - pkg_str = unitIdString (moduleUnitId mod) - mod_str = moduleNameString (moduleName mod) - occ_str = unpackFS (flLabel fl) - -reifySelector :: Id -> TyCon -> TH.Name -reifySelector id tc - = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of - Just fl -> reifyFieldLabel fl - Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc) - ------------------------------- -reifyFixity :: Name -> TcM (Maybe TH.Fixity) -reifyFixity name - = do { (found, fix) <- lookupFixityRn_help name - ; return (if found then Just (conv_fix fix) else Nothing) } - where - conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d) - conv_dir BasicTypes.InfixR = TH.InfixR - conv_dir BasicTypes.InfixL = TH.InfixL - conv_dir BasicTypes.InfixN = TH.InfixN - -reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness -reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness -reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack -reifyUnpackedness SrcUnpack = TH.SourceUnpack - -reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness -reifyStrictness NoSrcStrict = TH.NoSourceStrictness -reifyStrictness SrcStrict = TH.SourceStrict -reifyStrictness SrcLazy = TH.SourceLazy - -reifySourceBang :: DataCon.HsSrcBang - -> (TH.SourceUnpackedness, TH.SourceStrictness) -reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s) - -reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness -reifyDecidedStrictness HsLazy = TH.DecidedLazy -reifyDecidedStrictness HsStrict = TH.DecidedStrict -reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack - ------------------------------- -lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget -lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) -lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) - = return $ ModuleTarget $ - mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn) - -reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] -reifyAnnotations th_name - = do { name <- lookupThAnnLookup th_name - ; topEnv <- getTopEnv - ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing - ; tcg <- getGblEnv - ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name - ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name - ; return (selectedEpsHptAnns ++ selectedTcgAnns) } - ------------------------------- -modToTHMod :: Module -> TH.Module -modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m) - (TH.ModName $ moduleNameString $ moduleName m) - -reifyModule :: TH.Module -> TcM TH.ModuleInfo -reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do - this_mod <- getModule - let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString) - if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod - where - reifyThisModule = do - usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports - return $ TH.ModuleInfo usages - - reifyFromIface reifMod = do - iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod - let usages = [modToTHMod m | usage <- mi_usages iface, - Just m <- [usageToModule (moduleUnitId reifMod) usage] ] - return $ TH.ModuleInfo usages - - usageToModule :: UnitId -> Usage -> Maybe Module - usageToModule _ (UsageFile {}) = Nothing - usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn - usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m - usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m - ------------------------------- -mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type -mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys - -noTH :: LitString -> SDoc -> TcM a -noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+> - text "in Template Haskell:", - nest 2 d]) - -ppr_th :: TH.Ppr a => a -> SDoc -ppr_th x = text (TH.pprint x) - -{- -Note [Reifying field labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When reifying a datatype declared with DuplicateRecordFields enabled, we want -the reified names of the fields to be labels rather than selector functions. -That is, we want (reify ''T) and (reify 'foo) to produce - - data T = MkT { foo :: Int } - foo :: T -> Int - -rather than - - data T = MkT { $sel:foo:MkT :: Int } - $sel:foo:MkT :: T -> Int - -because otherwise TH code that uses the field names as strings will silently do -the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather -than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the -environment, NameG can't be used to represent such fields. Instead, -reifyFieldLabel uses NameQ. - -However, this means that extracting the field name from the output of reify, and -trying to reify it again, may fail with an ambiguity error if there are multiple -such fields defined in the module (see the test case -overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to -the TH AST to make it able to represent duplicate record fields. --} diff --git a/typecheck/TcSplice.hs-boot b/typecheck/TcSplice.hs-boot deleted file mode 100644 --- a/typecheck/TcSplice.hs-boot +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE CPP #-} - -module TcSplice where -import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr ) -import HsExpr ( PendingRnSplice ) -import Name ( Name ) -import TcRnTypes( TcM, TcId ) -import TcType ( ExpRhoType ) -import Annotations ( Annotation, CoreAnnTarget ) - -import HsSyn ( LHsType, LPat, LHsDecl, ThModFinalizers ) -import RdrName ( RdrName ) -import TcRnTypes ( SpliceType ) -import qualified Language.Haskell.TH as TH - -tcSpliceExpr :: HsSplice Name - -> ExpRhoType - -> TcM (HsExpr TcId) - -tcUntypedBracket :: HsBracket Name - -> [PendingRnSplice] - -> ExpRhoType - -> TcM (HsExpr TcId) -tcTypedBracket :: HsBracket Name - -> ExpRhoType - -> TcM (HsExpr TcId) - -runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation - -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr TcId) -> TcM (LHsExpr TcId) - -runMetaE :: LHsExpr TcId -> TcM (LHsExpr RdrName) -runMetaP :: LHsExpr TcId -> TcM (LPat RdrName) -runMetaT :: LHsExpr TcId -> TcM (LHsType RdrName) -runMetaD :: LHsExpr TcId -> TcM [LHsDecl RdrName] - -lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -runQuasi :: TH.Q a -> TcM a -runRemoteModFinalizers :: ThModFinalizers -> TcM () -finishTH :: TcM () diff --git a/typecheck/TcTyClsDecls.hs b/typecheck/TcTyClsDecls.hs deleted file mode 100644 --- a/typecheck/TcTyClsDecls.hs +++ /dev/null @@ -1,3114 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - - -TcTyClsDecls: Typecheck type and class declarations --} - -{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} - -module TcTyClsDecls ( - tcTyAndClassDecls, tcAddImplicits, - - -- Functions used by TcInstDcls to check - -- data/type family instance declarations - kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon, - tcFamTyPats, tcTyFamInstEqn, famTyConShape, - tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, - wrongKindOfFamily, dataConCtxt - ) where - -#include "HsVersions.h" - -import HsSyn -import HscTypes -import BuildTyCl -import TcRnMonad -import TcEnv -import TcValidity -import TcHsSyn -import TcTyDecls -import TcClassDcl -import {-# SOURCE #-} TcInstDcls( tcInstDecls1 ) -import TcDeriv (DerivInfo) -import TcUnify -import TcHsType -import TcMType -import TysWiredIn ( unitTy ) -import TcType -import RnEnv( RoleAnnotEnv, mkRoleAnnotEnv, lookupRoleAnnot - , lookupConstructorFields ) -import FamInst -import FamInstEnv -import Coercion -import Type -import TyCoRep -- for checkValidRoles -import Kind -import Class -import CoAxiom -import TyCon -import DataCon -import Id -import Var -import VarEnv -import VarSet -import Module -import Name -import NameSet -import NameEnv -import Outputable -import Maybes -import Unify -import Util -import SrcLoc -import ListSetOps -import DynFlags -import Unique -import BasicTypes -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.List - -{- -************************************************************************ -* * -\subsection{Type checking for type and class declarations} -* * -************************************************************************ - -Note [Grouping of type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly -connected component of mutually dependent types and classes. We kind check and -type check each group separately to enhance kind polymorphism. Take the -following example: - - type Id a = a - data X = X (Id Int) - -If we were to kind check the two declarations together, we would give Id the -kind * -> *, since we apply it to an Int in the definition of X. But we can do -better than that, since Id really is kind polymorphic, and should get kind -forall (k::*). k -> k. Since it does not depend on anything else, it can be -kind-checked by itself, hence getting the most general kind. We then kind check -X, which works fine because we then know the polymorphic kind of Id, and simply -instantiate k to *. - -Note [Check role annotations in a second pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Role inference potentially depends on the types of all of the datacons declared -in a mutually recursive group. The validity of a role annotation, in turn, -depends on the result of role inference. Because the types of datacons might -be ill-formed (see #7175 and Note [Checking GADT return types]) we must check -*all* the tycons in a group for validity before checking *any* of the roles. -Thus, we take two passes over the resulting tycons, first checking for general -validity and then checking for valid role annotations. --} - -tcTyAndClassDecls :: [TyClGroup Name] -- Mutually-recursive groups in - -- dependency order - -> TcM ( TcGblEnv -- Input env extended by types and - -- classes - -- and their implicit Ids,DataCons - , [InstInfo Name] -- Source-code instance decls info - , [DerivInfo] -- data family deriving info - ) --- Fails if there are any errors -tcTyAndClassDecls tyclds_s - -- The code recovers internally, but if anything gave rise to - -- an error we'd better stop now, to avoid a cascade - -- Type check each group in dependency order folding the global env - = checkNoErrs $ fold_env [] [] tyclds_s - where - fold_env :: [InstInfo Name] - -> [DerivInfo] - -> [TyClGroup Name] - -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo]) - fold_env inst_info deriv_info [] - = do { gbl_env <- getGblEnv - ; return (gbl_env, inst_info, deriv_info) } - fold_env inst_info deriv_info (tyclds:tyclds_s) - = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds - ; setGblEnv tcg_env $ - -- remaining groups are typechecked in the extended global env. - fold_env (inst_info' ++ inst_info) - (deriv_info' ++ deriv_info) - tyclds_s } - -tcTyClGroup :: TyClGroup Name - -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo]) --- Typecheck one strongly-connected component of type, class, and instance decls --- See Note [TyClGroups and dependency analysis] in HsDecls -tcTyClGroup (TyClGroup { group_tyclds = tyclds - , group_roles = roles - , group_instds = instds }) - = do { let role_annots = mkRoleAnnotEnv roles - - -- Step 1: Typecheck the type/class declarations - ; traceTc "-------- tcTyClGroup ------------" empty - ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds)) - ; tyclss <- tcTyClDecls tyclds role_annots - - -- Step 1.5: Make sure we don't have any type synonym cycles - ; traceTc "Starting synonym cycle check" (ppr tyclss) - ; this_uid <- fmap thisPackage getDynFlags - ; checkSynCycles this_uid tyclss tyclds - ; traceTc "Done synonym cycle check" (ppr tyclss) - - ; traceTc "Starting family consistency check" (ppr tyclss) - ; forM_ tyclss checkRecFamInstConsistency - ; traceTc "Done family consistency" (ppr tyclss) - - -- Step 2: Perform the validity check on those types/classes - -- We can do this now because we are done with the recursive knot - -- Do it before Step 3 (adding implicit things) because the latter - -- expects well-formed TyCons - ; traceTc "Starting validity check" (ppr tyclss) - ; tyclss <- mapM checkValidTyCl tyclss - ; traceTc "Done validity check" (ppr tyclss) - ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss - -- See Note [Check role annotations in a second pass] - - -- Step 3: Add the implicit things; - -- we want them in the environment because - -- they may be mentioned in interface files - ; tcExtendTyConEnv tyclss $ - do { gbl_env <- tcAddImplicits tyclss - ; setGblEnv gbl_env $ - do { - -- Step 4: check instance declarations - ; (gbl_env, inst_info, datafam_deriv_info) <- tcInstDecls1 instds - - ; return (gbl_env, inst_info, datafam_deriv_info) } } } - -tcTyClDecls :: [LTyClDecl Name] -> RoleAnnotEnv -> TcM [TyCon] -tcTyClDecls tyclds role_annots - = do { -- Step 1: kind-check this group and returns the final - -- (possibly-polymorphic) kind of each TyCon and Class - -- See Note [Kind checking for type and class decls] - tc_tycons <- kcTyClGroup tyclds - ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons)) - - -- Step 2: type-check all groups together, returning - -- the final TyCons and Classes - -- - -- NB: We have to be careful here to NOT eagerly unfold - -- type synonyms, as we have not tested for type synonym - -- loops yet and could fall into a black hole. - ; fixM $ \ ~rec_tyclss -> do - { tcg_env <- getGblEnv - ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss - - -- Populate environment with knot-tied ATyCon for TyCons - -- NB: if the decls mention any ill-staged data cons - -- (see Note [Recusion and promoting data constructors]) - -- we will have failed already in kcTyClGroup, so no worries here - ; tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $ - - -- Also extend the local type envt with bindings giving - -- the (polymorphic) kind of each knot-tied TyCon or Class - -- See Note [Type checking recursive type and class declarations] - tcExtendKindEnv (foldl extendEnvWithTcTyCon emptyNameEnv tc_tycons) $ - - -- Kind and type check declarations for this group - mapM (tcTyClDecl roles) tyclds - } } - where - ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma - , ppr (tyConBinders tc) <> comma - , ppr (tyConResKind tc) ]) - -zipRecTyClss :: [TcTyCon] - -> [TyCon] -- Knot-tied - -> [(Name,TyThing)] --- Build a name-TyThing mapping for the TyCons bound by decls --- being careful not to look at the knot-tied [TyThing] --- The TyThings in the result list must have a visible ATyCon, --- because typechecking types (in, say, tcTyClDecl) looks at --- this outer constructor -zipRecTyClss tc_tycons rec_tycons - = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ] - where - rec_tc_env :: NameEnv TyCon - rec_tc_env = foldr add_tc emptyNameEnv rec_tycons - - add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon - add_tc tc env = foldr add_one_tc env (tc : tyConATs tc) - - add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon - add_one_tc tc env = extendNameEnv env (tyConName tc) tc - - get name = case lookupNameEnv rec_tc_env name of - Just tc -> tc - other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) - -{- -************************************************************************ -* * - Kind checking -* * -************************************************************************ - -Note [Kind checking for type and class decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Kind checking is done thus: - - 1. Make up a kind variable for each parameter of the declarations, - and extend the kind environment (which is in the TcLclEnv) - - 2. Kind check the declarations - -We need to kind check all types in the mutually recursive group -before we know the kind of the type variables. For example: - - class C a where - op :: D b => a -> b -> b - - class D c where - bop :: (Monad c) => ... - -Here, the kind of the locally-polymorphic type variable "b" -depends on *all the uses of class D*. For example, the use of -Monad c in bop's type signature means that D must have kind Type->Type. - -Note: we don't treat type synonyms specially (we used to, in the past); -in particular, even if we have a type synonym cycle, we still kind check -it normally, and test for cycles later (checkSynCycles). The reason -we can get away with this is because we have more systematic TYPE r -inference, which means that we can do unification between kinds that -aren't lifted (this historically was not true.) - -The downside of not directly reading off the kinds off the RHS of -type synonyms in topological order is that we don't transparently -support making synonyms of types with higher-rank kinds. But -you can always specify a CUSK directly to make this work out. -See tc269 for an example. - -Open type families -~~~~~~~~~~~~~~~~~~ -This treatment of type synonyms only applies to Haskell 98-style synonyms. -General type functions can be recursive, and hence, appear in `alg_decls'. - -The kind of an open type family is solely determinded by its kind signature; -hence, only kind signatures participate in the construction of the initial -kind environment (as constructed by `getInitialKind'). In fact, we ignore -instances of families altogether in the following. However, we need to include -the kinds of *associated* families into the construction of the initial kind -environment. (This is handled by `allDecls'). - - -See also Note [Kind checking recursive type and class declarations] - --} - - --- Note [Missed opportunity to retain higher-rank kinds] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In 'kcTyClGroup', there is a missed opportunity to make kind --- inference work in a few more cases. The idea is analogous --- to Note [Single function non-recursive binding special-case]: --- --- * If we have an SCC with a single decl, which is non-recursive, --- instead of creating a unification variable representing the --- kind of the decl and unifying it with the rhs, we can just --- read the type directly of the rhs. --- --- * Furthermore, we can update our SCC analysis to ignore --- dependencies on declarations which have CUSKs: we don't --- have to kind-check these all at once, since we can use --- the CUSK to initialize the kind environment. --- --- Unfortunately this requires reworking a bit of the code in --- 'kcLTyClDecl' so I've decided to punt unless someone shouts about it. --- -kcTyClGroup :: [LTyClDecl Name] -> TcM [TcTyCon] - --- Kind check this group, kind generalize, and return the resulting local env --- This binds the TyCons and Classes of the group, but not the DataCons --- See Note [Kind checking for type and class decls] --- Third return value is Nothing if the tycon be unsaturated; otherwise, --- the arity -kcTyClGroup decls - = do { mod <- getModule - ; traceTc "kcTyClGroup" (text "module" <+> ppr mod $$ vcat (map ppr decls)) - - -- Kind checking; - -- 1. Bind kind variables for decls - -- 2. Kind-check decls - -- 3. Generalise the inferred kinds - -- See Note [Kind checking for type and class decls] - - ; lcl_env <- solveEqualities $ - do { -- Step 1: Bind kind variables for all decls - initial_kinds <- getInitialKinds decls - ; traceTc "kcTyClGroup: initial kinds" $ - ppr initial_kinds - - -- Step 2: Set extended envt, kind-check the decls - ; tcExtendKindEnv initial_kinds $ - do { mapM_ kcLTyClDecl decls - ; getLclEnv } } - - -- Step 3: generalisation - -- Kind checking done for this group - -- Now we have to kind generalize the flexis - ; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls - - ; traceTc "kcTyClGroup result" (vcat (map pp_res res)) - ; return res } - - where - generalise :: TcTypeEnv -> Name -> TcM TcTyCon - -- For polymorphic things this is a no-op - generalise kind_env name - = do { let tc = case lookupNameEnv kind_env name of - Just (ATcTyCon tc) -> tc - _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env) - kc_binders = tyConBinders tc - kc_res_kind = tyConResKind tc - kc_tyvars = tyConTyVars tc - ; kvs <- kindGeneralize (mkTyConKind kc_binders kc_res_kind) - ; let all_binders = mkNamedTyConBinders Inferred kvs ++ kc_binders - - ; (env, all_binders') <- zonkTyVarBindersX emptyZonkEnv all_binders - ; kc_res_kind' <- zonkTcTypeToType env kc_res_kind - - -- Make sure kc_kind' has the final, zonked kind variables - ; traceTc "Generalise kind" $ - vcat [ ppr name, ppr kc_binders, ppr kvs, ppr all_binders, ppr kc_res_kind - , ppr all_binders', ppr kc_res_kind' - , ppr kc_tyvars, ppr (tcTyConScopedTyVars tc)] - - ; return (mkTcTyCon name all_binders' kc_res_kind' - (mightBeUnsaturatedTyCon tc) - (tcTyConScopedTyVars tc)) } - - generaliseTCD :: TcTypeEnv - -> LTyClDecl Name -> TcM [TcTyCon] - generaliseTCD kind_env (L _ decl) - | ClassDecl { tcdLName = (L _ name), tcdATs = ats } <- decl - = do { first <- generalise kind_env name - ; rest <- mapM ((generaliseFamDecl kind_env) . unLoc) ats - ; return (first : rest) } - - | FamDecl { tcdFam = fam } <- decl - = do { res <- generaliseFamDecl kind_env fam - ; return [res] } - - | otherwise - = do { res <- generalise kind_env (tcdName decl) - ; return [res] } - - generaliseFamDecl :: TcTypeEnv - -> FamilyDecl Name -> TcM TcTyCon - generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name }) - = generalise kind_env name - - pp_res tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc) - --------------- -mkTcTyConEnv :: TcTyCon -> TcTypeEnv -mkTcTyConEnv tc = unitNameEnv (getName tc) (ATcTyCon tc) - -extendEnvWithTcTyCon :: TcTypeEnv -> TcTyCon -> TcTypeEnv --- Makes a binding to put in the local envt, binding --- a name to a TcTyCon -extendEnvWithTcTyCon env tc - = extendNameEnv env (getName tc) (ATcTyCon tc) - --------------- -mkPromotionErrorEnv :: [LTyClDecl Name] -> TcTypeEnv --- Maps each tycon/datacon to a suitable promotion error --- tc :-> APromotionErr TyConPE --- dc :-> APromotionErr RecDataConPE --- See Note [ARecDataCon: Recursion and promoting data constructors] - -mkPromotionErrorEnv decls - = foldr (plusNameEnv . mk_prom_err_env . unLoc) - emptyNameEnv decls - -mk_prom_err_env :: TyClDecl Name -> TcTypeEnv -mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) - = unitNameEnv nm (APromotionErr ClassPE) - `plusNameEnv` - mkNameEnv [ (name, APromotionErr TyConPE) - | L _ (FamilyDecl { fdLName = L _ name }) <- ats ] - -mk_prom_err_env (DataDecl { tcdLName = L _ name - , tcdDataDefn = HsDataDefn { dd_cons = cons } }) - = unitNameEnv name (APromotionErr TyConPE) - `plusNameEnv` - mkNameEnv [ (con, APromotionErr RecDataConPE) - | L _ con' <- cons, L _ con <- getConNames con' ] - -mk_prom_err_env decl - = unitNameEnv (tcdName decl) (APromotionErr TyConPE) - -- Works for family declarations too - --------------- -getInitialKinds :: [LTyClDecl Name] -> TcM (NameEnv TcTyThing) --- Maps each tycon to its initial kind, --- and each datacon to a suitable promotion error --- tc :-> ATcTyCon (tc:initial_kind) --- dc :-> APromotionErr RecDataConPE --- See Note [ARecDataCon: Recursion and promoting data constructors] - -getInitialKinds decls - = tcExtendKindEnv promotion_err_env $ - do { tc_kinds <- mapM (addLocM getInitialKind) decls - ; return (foldl plusNameEnv promotion_err_env tc_kinds) } - where - promotion_err_env = mkPromotionErrorEnv decls - -getInitialKind :: TyClDecl Name - -> TcM (NameEnv TcTyThing) --- Allocate a fresh kind variable for each TyCon and Class --- For each tycon, return a NameEnv with --- name :-> ATcTyCon (TcCyCon with kind k)) --- where k is the kind of tc, derived from the LHS --- of the definition (and probably including --- kind unification variables) --- Example: data T a b = ... --- return (T, kv1 -> kv2 -> kv3) --- --- This pass deals with (ie incorporates into the kind it produces) --- * The kind signatures on type-variable binders --- * The result kinds signature on a TyClDecl --- --- No family instances are passed to getInitialKinds - -getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats }) - = do { let cusk = hsDeclHasCusk decl - ; (tycon, inner_prs) <- - kcHsTyVarBndrs name True cusk False True ktvs $ - do { inner_prs <- getFamDeclInitialKinds (Just cusk) ats - ; return (constraintKind, inner_prs) } - ; return (extendEnvWithTcTyCon inner_prs tycon) } - -getInitialKind decl@(DataDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig } }) - = do { (tycon, _) <- - kcHsTyVarBndrs name True (hsDeclHasCusk decl) False True ktvs $ - do { res_k <- case m_sig of - Just ksig -> tcLHsKindSig ksig - Nothing -> return liftedTypeKind - ; return (res_k, ()) } - ; return (mkTcTyConEnv tycon) } - -getInitialKind (FamDecl { tcdFam = decl }) - = getFamDeclInitialKind Nothing decl - -getInitialKind decl@(SynDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdRhs = rhs }) - = do { (tycon, _) <- kcHsTyVarBndrs name False (hsDeclHasCusk decl) - False {- not open -} True ktvs $ - do { res_k <- case kind_annotation rhs of - Nothing -> newMetaKindVar - Just ksig -> tcLHsKindSig ksig - ; return (res_k, ()) } - ; return (mkTcTyConEnv tycon) } - where - -- Keep this synchronized with 'hsDeclHasCusk'. - kind_annotation (L _ ty) = case ty of - HsParTy lty -> kind_annotation lty - HsKindSig _ k -> Just k - _ -> Nothing - ---------------------------------- -getFamDeclInitialKinds :: Maybe Bool -- if assoc., CUSKness of assoc. class - -> [LFamilyDecl Name] - -> TcM TcTypeEnv -getFamDeclInitialKinds mb_cusk decls - = do { tc_kinds <- mapM (addLocM (getFamDeclInitialKind mb_cusk)) decls - ; return (foldr plusNameEnv emptyNameEnv tc_kinds) } - -getFamDeclInitialKind :: Maybe Bool -- if assoc., CUSKness of assoc. class - -> FamilyDecl Name - -> TcM TcTypeEnv -getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name - , fdTyVars = ktvs - , fdResultSig = L _ resultSig - , fdInfo = info }) - = do { (tycon, _) <- - kcHsTyVarBndrs name unsat cusk open True ktvs $ - do { res_k <- case resultSig of - KindSig ki -> tcLHsKindSig ki - TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKindSig ki - _ -- open type families have * return kind by default - | open -> return liftedTypeKind - -- closed type families have their return kind inferred - -- by default - | otherwise -> newMetaKindVar - ; return (res_k, ()) } - ; return (mkTcTyConEnv tycon) } - where - cusk = famDeclHasCusk mb_cusk decl - (open, unsat) = case info of - DataFamily -> (True, True) - OpenTypeFamily -> (True, False) - ClosedTypeFamily _ -> (False, False) - ------------------------------------------------------------------------- -kcLTyClDecl :: LTyClDecl Name -> TcM () - -- See Note [Kind checking for type and class decls] -kcLTyClDecl (L loc decl) - = setSrcSpan loc $ tcAddDeclCtxt decl $ kcTyClDecl decl - -kcTyClDecl :: TyClDecl Name -> TcM () --- This function is used solely for its side effect on kind variables --- NB kind signatures on the type variables and --- result kind signature have already been dealt with --- by getInitialKind, so we can ignore them here. - -kcTyClDecl (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }) - | HsDataDefn { dd_cons = cons, dd_kindSig = Just _ } <- defn - = mapM_ (wrapLocM kcConDecl) cons - -- hs_tvs and dd_kindSig already dealt with in getInitialKind - -- If dd_kindSig is Just, this must be a GADT-style decl, - -- (see invariants of DataDefn declaration) - -- so (a) we don't need to bring the hs_tvs into scope, because the - -- ConDecls bind all their own variables - -- (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it - - | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn - = kcTyClTyVars name $ - do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM kcConDecl) cons } - -kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = lrhs }) - = kcTyClTyVars name $ - do { syn_tc <- kcLookupTcTyCon name - -- NB: check against the result kind that we allocated - -- in getInitialKinds. - ; discardResult $ tcCheckLHsType lrhs (tyConResKind syn_tc) } - -kcTyClDecl (ClassDecl { tcdLName = L _ name - , tcdCtxt = ctxt, tcdSigs = sigs }) - = kcTyClTyVars name $ - do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM kc_sig) sigs } - where - kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty - kc_sig _ = return () - -kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name - , fdInfo = fd_info })) --- closed type families look at their equations, but other families don't --- do anything here - = case fd_info of - ClosedTypeFamily (Just eqns) -> - do { fam_tc <- kcLookupTcTyCon fam_tc_name - ; mapM_ (kcTyFamInstEqn (famTyConShape fam_tc)) eqns } - _ -> return () - -------------------- -kcConDecl :: ConDecl Name -> TcM () -kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs - , con_cxt = ex_ctxt, con_details = details }) - = addErrCtxt (dataConCtxtName [name]) $ - -- the 'False' says that the existentials don't have a CUSK, as the - -- concept doesn't really apply here. We just need to bring the variables - -- into scope. - do { _ <- kcHsTyVarBndrs (unLoc name) False False False False - ((fromMaybe emptyLHsQTvs ex_tvs)) $ - do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt) - ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details) - ; return (panic "kcConDecl", ()) } - -- We don't need to check the telescope here, because that's - -- done in tcConDecl - ; return () } - -kcConDecl (ConDeclGADT { con_names = names - , con_type = ty }) - = addErrCtxt (dataConCtxtName names) $ - do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty - ; return () } - - -{- -Note [Recursion and promoting data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't want to allow promotion in a strongly connected component -when kind checking. - -Consider: - data T f = K (f (K Any)) - -When kind checking the `data T' declaration the local env contains the -mappings: - T -> ATcTyCon - K -> APromotionErr - -APromotionErr is only used for DataCons, and only used during type checking -in tcTyClGroup. - - -************************************************************************ -* * -\subsection{Type checking} -* * -************************************************************************ - -Note [Type checking recursive type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At this point we have completed *kind-checking* of a mutually -recursive group of type/class decls (done in kcTyClGroup). However, -we discarded the kind-checked types (eg RHSs of data type decls); -note that kcTyClDecl returns (). There are two reasons: - - * It's convenient, because we don't have to rebuild a - kinded HsDecl (a fairly elaborate type) - - * It's necessary, because after kind-generalisation, the - TyCons/Classes may now be kind-polymorphic, and hence need - to be given kind arguments. - -Example: - data T f a = MkT (f a) (T f a) -During kind-checking, we give T the kind T :: k1 -> k2 -> * -and figure out constraints on k1, k2 etc. Then we generalise -to get T :: forall k. (k->*) -> k -> * -So now the (T f a) in the RHS must be elaborated to (T k f a). - -However, during tcTyClDecl of T (above) we will be in a recursive -"knot". So we aren't allowed to look at the TyCon T itself; we are only -allowed to put it (lazily) in the returned structures. But when -kind-checking the RHS of T's decl, we *do* need to know T's kind (so -that we can correctly elaboarate (T k f a). How can we get T's kind -without looking at T? Delicate answer: during tcTyClDecl, we extend - - *Global* env with T -> ATyCon (the (not yet built) final TyCon for T) - *Local* env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T) - -Then: - - * During TcHsType.kcTyVar we look in the *local* env, to get the - known kind for T. - - * But in TcHsType.ds_type (and ds_var_app in particular) we look in - the *global* env to get the TyCon. But we must be careful not to - force the TyCon or we'll get a loop. - -This fancy footwork (with two bindings for T) is only necessary for the -TyCons or Classes of this recursive group. Earlier, finished groups, -live in the global env only. - -See also Note [Kind checking recursive type and class declarations] - -Note [Kind checking recursive type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before we can type-check the decls, we must kind check them. This -is done by establishing an "initial kind", which is a rather uninformed -guess at a tycon's kind (by counting arguments, mainly) and then -using this initial kind for recursive occurrences. - -The initial kind is stored in exactly the same way during kind-checking -as it is during type-checking (Note [Type checking recursive type and class -declarations]): in the *local* environment, with ATcTyCon. But we still -must store *something* in the *global* environment. Even though we -discard the result of kind-checking, we sometimes need to produce error -messages. These error messages will want to refer to the tycons being -checked, except that they don't exist yet, and it would be Terribly -Annoying to get the error messages to refer back to HsSyn. So we -create a TcTyCon and put it in the global env. This tycon can -print out its name and knows its kind, -but any other action taken on it will panic. Note -that TcTyCons are *not* knot-tied, unlike the rather valid but -knot-tied ones that occur during type-checking. - -Note [Declarations for wired-in things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For wired-in things we simply ignore the declaration -and take the wired-in information. That avoids complications. -e.g. the need to make the data constructor worker name for - a constraint tuple match the wired-in one --} - -tcTyClDecl :: RolesInfo -> LTyClDecl Name -> TcM TyCon -tcTyClDecl roles_info (L loc decl) - | Just thing <- wiredInNameTyThing_maybe (tcdName decl) - = case thing of -- See Note [Declarations for wired-in things] - ATyCon tc -> return tc - _ -> pprPanic "tcTyClDecl" (ppr thing) - - | otherwise - = setSrcSpan loc $ tcAddDeclCtxt decl $ - do { traceTc "tcTyAndCl-x" (ppr decl) - ; tcTyClDecl1 Nothing roles_info decl } - - -- "type family" declarations -tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl Name -> TcM TyCon -tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) - = tcFamDecl1 parent fd - - -- "type" synonym declaration -tcTyClDecl1 _parent roles_info - (SynDecl { tcdLName = L _ tc_name, tcdRhs = rhs }) - = ASSERT( isNothing _parent ) - tcTyClTyVars tc_name $ \ binders res_kind -> - tcTySynRhs roles_info tc_name binders res_kind rhs - - -- "data/newtype" declaration -tcTyClDecl1 _parent roles_info - (DataDecl { tcdLName = L _ tc_name, tcdDataDefn = defn }) - = ASSERT( isNothing _parent ) - tcTyClTyVars tc_name $ \ tycon_binders res_kind -> - tcDataDefn roles_info tc_name tycon_binders res_kind defn - -tcTyClDecl1 _parent roles_info - (ClassDecl { tcdLName = L _ class_name - , tcdCtxt = ctxt, tcdMeths = meths - , tcdFDs = fundeps, tcdSigs = sigs - , tcdATs = ats, tcdATDefs = at_defs }) - = ASSERT( isNothing _parent ) - do { clas <- fixM $ \ clas -> - -- We need the knot because 'clas' is passed into tcClassATs - tcTyClTyVars class_name $ \ binders res_kind -> - do { MASSERT( isConstraintKind 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' <- solveEqualities $ tcHsContext ctxt - ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt' - -- Squeeze out any kind unification variables - ; fds' <- mapM (addLocM tc_fundep) fundeps - ; sig_stuff <- tcClassSigs class_name sigs meths - ; at_stuff <- tcClassATs class_name clas ats at_defs - ; mindef <- tcClassMinimalDef class_name sigs sig_stuff - -- TODO: Allow us to distinguish between abstract class, - -- and concrete class with no methods (maybe by - -- specifying a trailing where or not - ; is_boot <- tcIsHsBootOrSig - ; let body | is_boot, null ctxt', null at_stuff, null sig_stuff - = Nothing - | otherwise - = Just (ctxt', at_stuff, sig_stuff, mindef) - ; clas <- buildClass class_name binders roles fds' body - ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$ - ppr fds') - ; return clas } - - ; return (classTyCon clas) } - where - tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; - ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; - ; return (tvs1', tvs2') } - -tcFamDecl1 :: Maybe Class -> FamilyDecl Name -> TcM TyCon -tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_name) - , fdTyVars = tvs, fdResultSig = L _ sig - , fdInjectivityAnn = inj }) - | DataFamily <- fam_info - = tcTyClTyVars tc_name $ \ binders res_kind -> do - { traceTc "data family:" (ppr tc_name) - ; checkFamFlag tc_name - ; (extra_binders, real_res_kind) <- tcDataKindSig res_kind - ; tc_rep_name <- newTyConRepName tc_name - ; let tycon = mkFamilyTyCon tc_name (binders `chkAppend` extra_binders) - real_res_kind - (resultVariableName sig) - (DataFamilyTyCon tc_rep_name) - parent NotInjective - ; return tycon } - - | OpenTypeFamily <- fam_info - = tcTyClTyVars tc_name $ \ binders res_kind -> do - { traceTc "open type family:" (ppr tc_name) - ; checkFamFlag tc_name - ; inj' <- tcInjectivity binders inj - ; let tycon = mkFamilyTyCon tc_name binders res_kind - (resultVariableName sig) OpenSynFamilyTyCon - parent inj' - ; return tycon } - - | ClosedTypeFamily mb_eqns <- fam_info - = -- Closed type families are a little tricky, because they contain the definition - -- of both the type family and the equations for a CoAxiom. - do { traceTc "Closed type family:" (ppr tc_name) - -- the variables in the header scope only over the injectivity - -- declaration but this is not involved here - ; (inj', binders, res_kind) - <- tcTyClTyVars tc_name - $ \ binders res_kind -> - do { inj' <- tcInjectivity binders inj - ; return (inj', binders, res_kind) } - - ; checkFamFlag tc_name -- make sure we have -XTypeFamilies - - -- If Nothing, this is an abstract family in a hs-boot file; - -- but eqns might be empty in the Just case as well - ; case mb_eqns of - Nothing -> - return $ mkFamilyTyCon tc_name binders res_kind - (resultVariableName sig) - AbstractClosedSynFamilyTyCon parent - inj' - Just eqns -> do { - - -- Process the equations, creating CoAxBranches - ; let fam_tc_shape = (tc_name, length $ hsQTvExplicit tvs, binders, res_kind) - - ; branches <- mapM (tcTyFamInstEqn fam_tc_shape Nothing) eqns - -- Do not attempt to drop equations dominated by earlier - -- ones here; in the case of mutual recursion with a data - -- type, we get a knot-tying failure. Instead we check - -- for this afterwards, in TcValidity.checkValidCoAxiom - -- Example: tc265 - - -- Create a CoAxiom, with the correct src location. It is Vitally - -- Important that we do not pass the branches into - -- newFamInstAxiomName. They have types that have been zonked inside - -- the knot and we will die if we look at them. This is OK here - -- because there will only be one axiom, so we don't need to - -- differentiate names. - -- See [Zonking inside the knot] in TcHsType - ; co_ax_name <- newFamInstAxiomName tc_lname [] - - ; let mb_co_ax - | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list - | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) - - fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig) - (ClosedSynFamilyTyCon mb_co_ax) parent inj' - - -- We check for instance validity later, when doing validity - -- checking for the tycon. Exception: checking equations - -- overlap done by dropDominatedAxioms - ; return fam_tc } } - - | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker - - --- | Maybe return a list of Bools that say whether a type family was declared --- injective in the corresponding type arguments. Length of the list is equal to --- the number of arguments (including implicit kind/coercion arguments). --- True on position --- N means that a function is injective in its Nth argument. False means it is --- not. -tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn Name) - -> TcM Injectivity -tcInjectivity _ Nothing - = return NotInjective - - -- User provided an injectivity annotation, so for each tyvar argument we - -- check whether a type family was declared injective in that argument. We - -- return a list of Bools, where True means that corresponding type variable - -- was mentioned in lInjNames (type family is injective in that argument) and - -- False means that it was not mentioned in lInjNames (type family is not - -- injective in that type variable). We also extend injectivity information to - -- kind variables, so if a user declares: - -- - -- type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a - -- - -- then we mark both `a` and `k1` as injective. - -- NB: the return kind is considered to be *input* argument to a type family. - -- Since injectivity allows to infer input arguments from the result in theory - -- we should always mark the result kind variable (`k3` in this example) as - -- injective. The reason is that result type has always an assigned kind and - -- therefore we can always infer the result kind if we know the result type. - -- But this does not seem to be useful in any way so we don't do it. (Another - -- reason is that the implementation would not be straightforward.) -tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) - = setSrcSpan loc $ - do { let tvs = binderVars tcbs - ; dflags <- getDynFlags - ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) - (text "Illegal injectivity annotation" $$ - text "Use TypeFamilyDependencies to allow this") - ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames - ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds - ; let inj_ktvs = filterVarSet isTyVar $ -- no injective coercion vars - closeOverKinds (mkVarSet inj_tvs) - ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs - ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs - , ppr inj_ktvs, ppr inj_bools ]) - ; return $ Injective inj_bools } - -tcTySynRhs :: RolesInfo - -> Name - -> [TyConBinder] -> Kind - -> LHsType Name -> TcM TyCon -tcTySynRhs roles_info tc_name binders res_kind hs_ty - = do { env <- getLclEnv - ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) - ; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind - ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty - ; let roles = roles_info tc_name - tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty - ; return tycon } - -tcDataDefn :: RolesInfo -> Name - -> [TyConBinder] -> Kind - -> HsDataDefn Name -> TcM TyCon - -- NB: not used for newtype/data instances (whether associated or not) -tcDataDefn roles_info - tc_name tycon_binders res_kind - (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = ctxt, dd_kindSig = mb_ksig - , dd_cons = cons }) - = do { (extra_bndrs, real_res_kind) <- tcDataKindSig res_kind - ; let final_bndrs = tycon_binders `chkAppend` extra_bndrs - roles = roles_info tc_name - - ; stupid_tc_theta <- solveEqualities $ tcHsContext ctxt - ; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv - stupid_tc_theta - ; kind_signatures <- xoptM LangExt.KindSignatures - ; tcg_env <- getGblEnv - ; let hsc_src = tcg_src tcg_env - - -- Check that we don't use kind signatures without Glasgow extensions - ; when (isJust mb_ksig) $ - checkTc (kind_signatures) (badSigTyDecl tc_name) - - ; gadt_syntax <- dataDeclChecks tc_name new_or_data stupid_theta cons - - ; tycon <- fixM $ \ tycon -> do - { let res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs)) - ; data_cons <- tcConDecls tycon (final_bndrs, res_ty) cons - ; tc_rhs <- mk_tc_rhs hsc_src tycon data_cons - ; tc_rep_nm <- newTyConRepName tc_name - ; return (mkAlgTyCon tc_name - final_bndrs - real_res_kind - roles - (fmap unLoc cType) - stupid_theta tc_rhs - (VanillaAlgTyCon tc_rep_nm) - gadt_syntax) } - ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs) - ; return tycon } - where - -- In hs-boot, a 'data' declaration with no constructors - -- indicates an nominally distinct abstract data type. - mk_tc_rhs HsBootFile _ [] - = return AbstractTyCon - - mk_tc_rhs HsigFile _ [] -- ditto - = return AbstractTyCon - - mk_tc_rhs _ tycon data_cons - = case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs tc_name tycon (head data_cons) - -{- -************************************************************************ -* * - Typechecking associated types (in class decls) - (including the associated-type defaults) -* * -************************************************************************ - -Note [Associated type defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The following is an example of associated type defaults: - class C a where - data D a - - type F a b :: * - type F a b = [a] -- Default - -Note that we can get default definitions only for type families, not data -families. --} - -tcClassATs :: Name -- The class name (not knot-tied) - -> Class -- The class parent of this associated type - -> [LFamilyDecl Name] -- Associated types. - -> [LTyFamDefltEqn Name] -- Associated type defaults. - -> TcM [ClassATItem] -tcClassATs class_name cls ats at_defs - = do { -- Complain about associated type defaults for non associated-types - sequence_ [ failWithTc (badATErr class_name n) - | n <- map at_def_tycon at_defs - , not (n `elemNameSet` at_names) ] - ; mapM tc_at ats } - where - at_def_tycon :: LTyFamDefltEqn Name -> Name - at_def_tycon (L _ eqn) = unLoc (tfe_tycon eqn) - - at_fam_name :: LFamilyDecl Name -> Name - at_fam_name (L _ decl) = unLoc (fdLName decl) - - at_names = mkNameSet (map at_fam_name ats) - - at_defs_map :: NameEnv [LTyFamDefltEqn Name] - -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' - at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv - (at_def_tycon at_def) [at_def]) - emptyNameEnv at_defs - - tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at - ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) - `orElse` [] - ; atd <- tcDefaultAssocDecl fam_tc at_defs - ; return (ATI fam_tc atd) } - -------------------------- -tcDefaultAssocDecl :: TyCon -- ^ Family TyCon (not knot-tied) - -> [LTyFamDefltEqn Name] -- ^ Defaults - -> TcM (Maybe (Type, SrcSpan)) -- ^ Type checked RHS -tcDefaultAssocDecl _ [] - = return Nothing -- No default declaration - -tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (text "More than one default declaration for" - <+> ppr (tfe_tycon (unLoc d1))) - -tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name - , tfe_pats = hs_tvs - , tfe_rhs = rhs })] - | HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } <- hs_tvs - = -- See Note [Type-checking default assoc decls] - setSrcSpan loc $ - tcAddFamInstCtxt (text "default type instance") tc_name $ - do { traceTc "tcDefaultAssocDecl" (ppr tc_name) - ; let shape@(fam_tc_name, fam_arity, _, _) = famTyConShape fam_tc - - -- Kind of family check - ; ASSERT( fam_tc_name == tc_name ) - checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - - -- Arity check - ; checkTc (length exp_vars == fam_arity) - (wrongNumberOfParmsErr fam_arity) - - -- Typecheck RHS - ; let pats = HsIB { hsib_vars = imp_vars ++ map hsLTyVarName exp_vars - , hsib_body = map hsLTyVarBndrToType exp_vars - , hsib_closed = False } -- this field is ignored, anyway - -- NB: Use tcFamTyPats, not tcTyClTyVars. The latter expects to get - -- the LHsQTyVars used for declaring a tycon, but the names here - -- are different. - ; (pats', rhs_ty) - <- tcFamTyPats shape Nothing pats - (discardResult . tcCheckLHsType rhs) $ \tvs pats rhs_kind -> - do { rhs_ty <- solveEqualities $ - tcCheckLHsType rhs rhs_kind - - -- Zonk the patterns etc into the Type world - ; (ze, _) <- zonkTyBndrsX emptyZonkEnv tvs - ; pats' <- zonkTcTypeToTypes ze pats - ; rhs_ty' <- zonkTcTypeToType ze rhs_ty - ; return (pats', rhs_ty') } - - -- See Note [Type-checking default assoc decls] - ; case tcMatchTys pats' (mkTyVarTys (tyConTyVars fam_tc)) of - Just subst -> return (Just (substTyUnchecked subst rhs_ty, loc) ) - Nothing -> failWithTc (defaultAssocKindErr fam_tc) - -- We check for well-formedness and validity later, - -- in checkValidClass - } - -{- Note [Type-checking default assoc decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this default declaration for an associated type - - class C a where - type F (a :: k) b :: * - type F x y = Proxy x -> y - -Note that the class variable 'a' doesn't scope over the default assoc -decl (rather oddly I think), and (less oddly) neither does the second -argument 'b' of the associated type 'F', or the kind variable 'k'. -Instead, the default decl is treated more like a top-level type -instance. - -However we store the default rhs (Proxy x -> y) in F's TyCon, using -F's own type variables, so we need to convert it to (Proxy a -> b). -We do this by calling tcMatchTys to match them up. This also ensures -that x's kind matches a's and similarly for y and b. The error -message isn't great, mind you. (Trac #11361 was caused by not doing a -proper tcMatchTys here.) -} - -------------------------- -kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM () -kcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) - (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name - , tfe_pats = pats - , tfe_rhs = hs_ty })) - = setSrcSpan loc $ - do { checkTc (fam_tc_name == eqn_tc_name) - (wrongTyFamName fam_tc_name eqn_tc_name) - ; discardResult $ - tc_fam_ty_pats fam_tc_shape Nothing -- not an associated type - pats (discardResult . (tcCheckLHsType hs_ty)) } - -tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInstInfo -> LTyFamInstEqn Name -> TcM CoAxBranch --- Needs to be here, not in TcInstDcls, because closed families --- (typechecked here) have TyFamInstEqns -tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo - (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name - , tfe_pats = pats - , tfe_rhs = hs_ty })) - = ASSERT( fam_tc_name == eqn_tc_name ) - setSrcSpan loc $ - tcFamTyPats fam_tc_shape mb_clsinfo pats - (discardResult . (tcCheckLHsType hs_ty)) $ - \tvs pats res_kind -> - do { rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind - - ; (ze, tvs') <- zonkTyBndrsX emptyZonkEnv tvs - ; pats' <- zonkTcTypeToTypes ze pats - ; rhs_ty' <- zonkTcTypeToType ze rhs_ty - ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTyVars tvs') - -- don't print out the pats here, as they might be zonked inside the knot - ; return (mkCoAxBranch tvs' [] pats' rhs_ty' - (map (const Nominal) tvs') - loc) } - -kcDataDefn :: Name -- ^ the family name, for error msgs only - -> HsTyPats Name -- ^ the patterns, for error msgs only - -> HsDataDefn Name -- ^ the RHS - -> TcKind -- ^ the expected kind - -> TcM () --- Used for 'data instance' only --- Ordinary 'data' is handled by kcTyClDec -kcDataDefn fam_name (HsIB { hsib_body = pats }) - (HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind }) res_k - = do { _ <- tcHsContext ctxt - ; checkNoErrs $ mapM_ (wrapLocM kcConDecl) cons - -- See Note [Failing early in kcDataDefn] - ; discardResult $ - case mb_kind of - Nothing -> unifyKind (Just hs_ty_pats) res_k liftedTypeKind - Just k -> do { k' <- tcLHsKindSig k - ; unifyKind (Just hs_ty_pats) res_k k' } } - where - hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar NotPromoted (noLoc fam_name)) pats - -{- -Kind check type patterns and kind annotate the embedded type variables. - type instance F [a] = rhs - - * Here we check that a type instance matches its kind signature, but we do - not check whether there is a pattern for each type index; the latter - check is only required for type synonym instances. - -Note [tc_fam_ty_pats vs tcFamTyPats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tc_fam_ty_pats does the type checking of the patterns, but it doesn't -zonk or generate any desugaring. It is used when kind-checking closed -type families. - -tcFamTyPats type checks the patterns, zonks, and then calls thing_inside -to generate a desugaring. It is used during type-checking (not kind-checking). - -Note [Type-checking type patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking the patterns of a family instance declaration, we can't -rely on using the family TyCon, because this is sometimes called -from within a type-checking knot. (Specifically for closed type families.) -The type FamTyConShape gives just enough information to do the job. - -See also Note [tc_fam_ty_pats vs tcFamTyPats] - -Note [Failing early in kcDataDefn] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to use checkNoErrs when calling kcConDecl. This is because kcConDecl -calls tcConDecl, which checks that the return type of a GADT-like constructor -is actually an instance of the type head. Without the checkNoErrs, potentially -two bad things could happen: - - 1) Duplicate error messages, because tcConDecl will be called again during - *type* checking (as opposed to kind checking) - 2) If we just keep blindly forging forward after both kind checking and type - checking, we can get a panic in rejigConRes. See Trac #8368. --} - ------------------ -type FamTyConShape = (Name, Arity, [TyConBinder], Kind) - -- See Note [Type-checking type patterns] - -famTyConShape :: TyCon -> FamTyConShape -famTyConShape fam_tc - = ( tyConName fam_tc - , length $ filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc) - , tyConBinders fam_tc - , tyConResKind fam_tc ) - -tc_fam_ty_pats :: FamTyConShape - -> Maybe ClsInstInfo - -> HsTyPats Name -- Patterns - -> (TcKind -> TcM ()) -- Kind checker for RHS - -- result is ignored - -> TcM ([Type], Kind) --- Check the type patterns of a type or data family instance --- type instance F = --- The 'tyvars' are the free type variables of pats --- --- NB: The family instance declaration may be an associated one, --- nested inside an instance decl, thus --- instance C [a] where --- type F [a] = ... --- In that case, the type variable 'a' will *already be in scope* --- (and, if C is poly-kinded, so will its kind parameter). - -tc_fam_ty_pats (name, _, binders, res_kind) mb_clsinfo - (HsIB { hsib_body = arg_pats, hsib_vars = tv_names }) - kind_checker - = do { -- Kind-check and quantify - -- See Note [Quantifying over family patterns] - (_, (insted_res_kind, typats)) <- tcImplicitTKBndrs tv_names $ - do { (insting_subst, _leftover_binders, args, leftovers, n) - <- tcInferArgs name binders (thdOf3 <$> mb_clsinfo) arg_pats - ; case leftovers of - hs_ty:_ -> addErrTc $ too_many_args hs_ty n - _ -> return () - -- don't worry about leftover_binders; TcValidity catches them - - ; let insted_res_kind = substTyUnchecked insting_subst res_kind - ; kind_checker insted_res_kind - ; return ((insted_res_kind, args), emptyVarSet) } - - ; return (typats, insted_res_kind) } - where - too_many_args hs_ty n - = hang (text "Too many parameters to" <+> ppr name <> colon) - 2 (vcat [ ppr hs_ty <+> text "is unexpected;" - , text (if n == 1 then "expected" else "expected only") <+> - speakNOf (n-1) (text "parameter") ]) - --- See Note [tc_fam_ty_pats vs tcFamTyPats] -tcFamTyPats :: FamTyConShape - -> Maybe ClsInstInfo - -> HsTyPats Name -- patterns - -> (TcKind -> TcM ()) -- kind-checker for RHS - -> ( [TcTyVar] -- Kind and type variables - -> [TcType] -- Kind and type arguments - -> TcKind - -> TcM a) -- NB: You can use solveEqualities here. - -> TcM a -tcFamTyPats fam_shape@(name,_,_,_) mb_clsinfo pats kind_checker thing_inside - = do { (typats, res_kind) - <- solveEqualities $ -- See Note [Constraints in patterns] - tc_fam_ty_pats fam_shape mb_clsinfo pats kind_checker - - {- TODO (RAE): This should be cleverer. Consider this: - - type family F a - - data G a where - MkG :: F a ~ Bool => G a - - type family Foo (x :: G a) :: F a - type instance Foo MkG = False - - This should probably be accepted. Yet the solveEqualities - will fail, unable to solve (F a ~ Bool) - We want to quantify over that proof. - But see Note [Constraints in patterns] - below, which is missing this piece. -} - - - -- Find free variables (after zonking) and turn - -- them into skolems, so that we don't subsequently - -- replace a meta kind var with (Any *) - -- Very like kindGeneralize - ; vars <- zonkTcTypesAndSplitDepVars typats - ; qtkvs <- quantifyZonkedTyVars emptyVarSet vars - - ; MASSERT( isEmptyVarSet $ coVarsOfTypes typats ) - -- This should be the case, because otherwise the solveEqualities - -- above would fail. TODO (RAE): Update once the solveEqualities - -- bit is cleverer. - - ; traceTc "tcFamTyPats" (ppr name $$ ppr typats $$ ppr qtkvs) - -- Don't print out too much, as we might be in the knot - - ; tcExtendTyVarEnv qtkvs $ - -- Extend envt with TcTyVars not TyVars, because the - -- kind checking etc done by thing_inside does not expect - -- to encounter TyVars; it expects TcTyVars - thing_inside qtkvs typats res_kind } - -{- -Note [Constraints in patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: This isn't the whole story. See comment in tcFamTyPats. - -At first glance, it seems there is a complicated story to tell in tcFamTyPats -around constraint solving. After all, type family patterns can now do -GADT pattern-matching, which is jolly complicated. But, there's a key fact -which makes this all simple: everything is at top level! There cannot -be untouchable type variables. There can't be weird interaction between -case branches. There can't be global skolems. - -This means that the semantics of type-level GADT matching is a little -different than term level. If we have - - data G a where - MkGBool :: G Bool - -And then - - type family F (a :: G k) :: k - type instance F MkGBool = True - -we get - - axF : F Bool (MkGBool ) ~ True - -Simple! No casting on the RHS, because we can affect the kind parameter -to F. - -If we ever introduce local type families, this all gets a lot more -complicated, and will end up looking awfully like term-level GADT -pattern-matching. - - -** The new story ** - -Here is really what we want: - -The matcher really can't deal with covars in arbitrary spots in coercions. -But it can deal with covars that are arguments to GADT data constructors. -So we somehow want to allow covars only in precisely those spots, then use -them as givens when checking the RHS. TODO (RAE): Implement plan. - - -Note [Quantifying over family patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to quantify over two different lots of kind variables: - -First, the ones that come from the kinds of the tyvar args of -tcTyVarBndrsKindGen, as usual - data family Dist a - - -- Proxy :: forall k. k -> * - data instance Dist (Proxy a) = DP - -- Generates data DistProxy = DP - -- ax8 k (a::k) :: Dist * (Proxy k a) ~ DistProxy k a - -- The 'k' comes from the tcTyVarBndrsKindGen (a::k) - -Second, the ones that come from the kind argument of the type family -which we pick up using the (tyCoVarsOfTypes typats) in the result of -the thing_inside of tcHsTyvarBndrsGen. - -- Any :: forall k. k - data instance Dist Any = DA - -- Generates data DistAny k = DA - -- ax7 k :: Dist k (Any k) ~ DistAny k - -- The 'k' comes from kindGeneralizeKinds (Any k) - -Note [Quantified kind variables of a family pattern] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider type family KindFam (p :: k1) (q :: k1) - data T :: Maybe k1 -> k2 -> * - type instance KindFam (a :: Maybe k) b = T a b -> Int -The HsBSig for the family patterns will be ([k], [a]) - -Then in the family instance we want to - * Bring into scope [ "k" -> k:*, "a" -> a:k ] - * Kind-check the RHS - * Quantify the type instance over k and k', as well as a,b, thus - type instance [k, k', a:Maybe k, b:k'] - KindFam (Maybe k) k' a b = T k k' a b -> Int - -Notice that in the third step we quantify over all the visibly-mentioned -type variables (a,b), but also over the implicitly mentioned kind variables -(k, k'). In this case one is bound explicitly but often there will be -none. The role of the kind signature (a :: Maybe k) is to add a constraint -that 'a' must have that kind, and to bring 'k' into scope. - - - -************************************************************************ -* * - Data types -* * -************************************************************************ --} - -dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM Bool -dataDeclChecks tc_name new_or_data stupid_theta cons - = do { -- Check that we don't use GADT syntax in H98 world - gadtSyntax_ok <- xoptM LangExt.GADTSyntax - ; let gadt_syntax = consUseGadtSyntax cons - ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) - - -- Check that the stupid theta is empty for a GADT-style declaration - ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) - - -- Check that a newtype has exactly one constructor - -- Do this before checking for empty data decls, so that - -- we don't suggest -XEmptyDataDecls for newtypes - ; checkTc (new_or_data == DataType || isSingleton cons) - (newtypeConError tc_name (length cons)) - - -- Check that there's at least one condecl, - -- or else we're reading an hs-boot file, or -XEmptyDataDecls - ; empty_data_decls <- xoptM LangExt.EmptyDataDecls - ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc (not (null cons) || empty_data_decls || is_boot) - (emptyConDeclsErr tc_name) - ; return gadt_syntax } - - ------------------------------------ -consUseGadtSyntax :: [LConDecl a] -> Bool -consUseGadtSyntax (L _ (ConDeclGADT { }) : _) = True -consUseGadtSyntax _ = False - -- All constructors have same shape - ------------------------------------ -tcConDecls :: TyCon -> ([TyConBinder], Type) - -> [LConDecl Name] -> TcM [DataCon] - -- Why both the tycon tyvars and binders? Because the tyvars - -- have all the names and the binders have the visibilities. -tcConDecls rep_tycon (tmpl_bndrs, res_tmpl) - = concatMapM $ addLocM $ - tcConDecl rep_tycon tmpl_bndrs res_tmpl - -tcConDecl :: TyCon -- Representation tycon. Knot-tied! - -> [TyConBinder] -> Type - -- Return type template (with its template tyvars) - -- (tvs, T tys), where T is the family TyCon - -> ConDecl Name - -> TcM [DataCon] - -tcConDecl rep_tycon tmpl_bndrs res_tmpl - (ConDeclH98 { con_name = name - , con_qvars = hs_qvars, con_cxt = hs_ctxt - , con_details = hs_details }) - = addErrCtxt (dataConCtxtName [name]) $ - do { traceTc "tcConDecl 1" (ppr name) - ; let (hs_kvs, hs_tvs) = case hs_qvars of - Nothing -> ([], []) - Just (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) - -> (kvs, tvs) - ; (imp_tvs, (exp_tvs, ctxt, arg_tys, field_lbls, stricts)) - <- solveEqualities $ - tcImplicitTKBndrs hs_kvs $ - tcExplicitTKBndrs hs_tvs $ \ exp_tvs -> - do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs) - ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt) - ; btys <- tcConArgs hs_details - ; field_lbls <- lookupConstructorFields (unLoc name) - ; let (arg_tys, stricts) = unzip btys - bound_vars = allBoundVariabless ctxt `unionVarSet` - allBoundVariabless arg_tys - ; return ((exp_tvs, ctxt, arg_tys, field_lbls, stricts), bound_vars) - } - -- imp_tvs are user-written kind variables, without an explicit binding site - -- exp_tvs have binding sites - -- the kvs below are those kind variables entirely unmentioned by the user - -- and discovered only by generalization - - -- Kind generalisation - ; let all_user_tvs = imp_tvs ++ exp_tvs - ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys all_user_tvs $ - mkFunTys ctxt $ - mkFunTys arg_tys $ - unitTy) - -- That type is a lie, of course. (It shouldn't end in ()!) - -- And we could construct a proper result type from the info - -- at hand. But the result would mention only the tmpl_tvs, - -- and so it just creates more work to do it right. Really, - -- we're doing this to get the right behavior around removing - -- any vars bound in exp_binders. - - ; kvs <- quantifyZonkedTyVars (mkVarSet (binderVars tmpl_bndrs)) vars - - -- Zonk to Types - ; (ze, qkvs) <- zonkTyBndrsX emptyZonkEnv kvs - ; (ze, user_qtvs) <- zonkTyBndrsX ze all_user_tvs - ; arg_tys <- zonkTcTypeToTypes ze arg_tys - ; ctxt <- zonkTcTypeToTypes ze ctxt - - ; fam_envs <- tcGetFamInstEnvs - - -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here - ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) - ; let - ex_tvs = mkTyVarBinders Inferred qkvs ++ - mkTyVarBinders Specified user_qtvs - buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixH98 name hs_details - ; rep_nm <- newTyConRepName name - - ; buildDataCon fam_envs name is_infix rep_nm - stricts Nothing field_lbls - (mkDataConUnivTyVarBinders tmpl_bndrs) - ex_tvs - [{- no eq_preds -}] ctxt arg_tys - res_tmpl rep_tycon - -- NB: we put data_tc, the type constructor gotten from the - -- constructor type signature into the data constructor; - -- that way checkValidDataCon can complain if it's wrong. - } - ; traceTc "tcConDecl 2" (ppr name) - ; mapM buildOneDataCon [name] - } - -tcConDecl rep_tycon tmpl_bndrs res_tmpl - (ConDeclGADT { con_names = names, con_type = ty }) - = addErrCtxt (dataConCtxtName names) $ - do { traceTc "tcConDecl 1" (ppr names) - ; (user_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details) - <- tcGadtSigType (ppr names) (unLoc $ head names) ty - - ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys user_tvs $ - mkFunTys ctxt $ - mkFunTys arg_tys $ - res_ty) - ; tkvs <- quantifyZonkedTyVars emptyVarSet vars - - -- Zonk to Types - ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv (tkvs ++ user_tvs) - ; arg_tys <- zonkTcTypeToTypes ze arg_tys - ; ctxt <- zonkTcTypeToTypes ze ctxt - ; res_ty <- zonkTcTypeToType ze res_ty - - ; let (univ_tvs, ex_tvs, eq_preds, res_ty', arg_subst) - = rejigConRes tmpl_bndrs res_tmpl qtkvs res_ty - -- NB: this is a /lazy/ binding, so we pass five thunks to buildDataCon - -- without yet forcing the guards in rejigConRes - -- See Note [Checking GADT return types] - - -- See Note [Wrong visibility for GADTs] - univ_bndrs = mkTyVarBinders Specified univ_tvs - ex_bndrs = mkTyVarBinders Specified ex_tvs - - ; fam_envs <- tcGetFamInstEnvs - - -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here - ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) - ; let - buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixGADT name hs_details - ; rep_nm <- newTyConRepName name - - ; buildDataCon fam_envs name is_infix - rep_nm - stricts Nothing field_lbls - univ_bndrs ex_bndrs eq_preds - (substTys arg_subst ctxt) - (substTys arg_subst arg_tys) - (substTy arg_subst res_ty') - rep_tycon - -- NB: we put data_tc, the type constructor gotten from the - -- constructor type signature into the data constructor; - -- that way checkValidDataCon can complain if it's wrong. - } - ; traceTc "tcConDecl 2" (ppr names) - ; mapM buildOneDataCon names - } - - -tcGadtSigType :: SDoc -> Name -> LHsSigType Name - -> TcM ( [TcTyVar], [PredType],[HsSrcBang], [FieldLabel], [Type], Type - , HsConDetails (LHsType Name) - (Located [LConDeclField Name]) ) -tcGadtSigType doc name ty@(HsIB { hsib_vars = vars }) - = do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty - ; (hs_details, res_ty) <- updateGadtResult failWithTc doc hs_details' res_ty' - ; (imp_tvs, (exp_tvs, ctxt, arg_tys, res_ty, field_lbls, stricts)) - <- solveEqualities $ - tcImplicitTKBndrs vars $ - tcExplicitTKBndrs gtvs $ \ exp_tvs -> - do { ctxt <- tcHsContext cxt - ; btys <- tcConArgs hs_details - ; ty' <- tcHsLiftedType res_ty - ; field_lbls <- lookupConstructorFields name - ; let (arg_tys, stricts) = unzip btys - bound_vars = allBoundVariabless ctxt `unionVarSet` - allBoundVariabless arg_tys - - ; return ((exp_tvs, ctxt, arg_tys, ty', field_lbls, stricts), bound_vars) - } - ; return (imp_tvs ++ exp_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty, hs_details) - } - -tcConIsInfixH98 :: Name - -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) - -> TcM Bool -tcConIsInfixH98 _ details - = case details of - InfixCon {} -> return True - _ -> return False - -tcConIsInfixGADT :: Name - -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) - -> TcM Bool -tcConIsInfixGADT con details - = case details of - InfixCon {} -> return True - RecCon {} -> return False - PrefixCon arg_tys -- See Note [Infix GADT constructors] - | isSymOcc (getOccName con) - , [_ty1,_ty2] <- arg_tys - -> do { fix_env <- getFixityEnv - ; return (con `elemNameEnv` fix_env) } - | otherwise -> return False - -tcConArgs :: HsConDeclDetails Name - -> TcM [(TcType, HsSrcBang)] -tcConArgs (PrefixCon btys) - = mapM tcConArg btys -tcConArgs (InfixCon bty1 bty2) - = do { bty1' <- tcConArg bty1 - ; bty2' <- tcConArg bty2 - ; return [bty1', bty2'] } -tcConArgs (RecCon fields) - = mapM tcConArg btys - where - -- We need a one-to-one mapping from field_names to btys - combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields) - explode (ns,ty) = zip ns (repeat ty) - exploded = concatMap explode combined - (_,btys) = unzip exploded - - -tcConArg :: LHsType Name -> TcM (TcType, HsSrcBang) -tcConArg bty - = do { traceTc "tcConArg 1" (ppr bty) - ; arg_ty <- tcHsOpenType (getBangType bty) - -- Newtypes can't have unboxed types, but we check - -- that in checkValidDataCon; this tcConArg stuff - -- doesn't happen for GADT-style declarations - ; traceTc "tcConArg 2" (ppr bty) - ; return (arg_ty, getBangStrictness bty) } - -{- -Note [Wrong visibility for GADTs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GADT tyvars shouldn't all be specified, but it's hard to do much better, as -described in #11721, which is duplicated here for convenience: - -Consider - - data X a where - MkX :: b -> Proxy a -> X a - -According to the rules around specified vs. generalized variables around -TypeApplications, the type of MkX should be - - MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a - -A few things to note: - - * The k isn't available for TypeApplications (that's why it's in braces), - because it is not user-written. - - * The b is quantified before the a, because b comes before a in the - user-written type signature for MkX. - -Both of these bullets are currently violated. GHCi reports MkX's type as - - MkX :: forall k (a :: k) b. b -> Proxy a -> X a - -It turns out that this is a hard to fix. The problem is that GHC expects data -constructors to have their universal variables followed by their existential -variables, always. And yet that's violated in the desired type for MkX. -Furthermore, given the way that GHC deals with GADT return types ("rejigging", -in technical parlance), it's inconvenient to get the specified/generalized -distinction correct. - -Given time constraints, I'm afraid fixing this all won't make it for 8.0. - -Happily, there is are easy-to-articulate rules governing GHC's current (wrong) -behavior. In a GADT-syntax data constructor: - - * All kind and type variables are considered specified and available for - visible type application. - - * Universal variables always come first, in precisely the order they appear - in the tycon. Note that universals that are constrained by a GADT return - type are missing from the datacon. - - * Existential variables come next. Their order is determined by a - user-written forall; or, if there is none, by taking the left-to-right - order in the datacon's type and doing a stable topological sort. (This - stable topological sort step is the same as for other user-written type - signatures.) - -Note [Infix GADT constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not currently have syntax to declare an infix constructor in GADT syntax, -but it makes a (small) difference to the Show instance. So as a slightly -ad-hoc solution, we regard a GADT data constructor as infix if - a) it is an operator symbol - b) it has two arguments - c) there is a fixity declaration for it -For example: - infix 6 (:--:) - data T a where - (:--:) :: t1 -> t2 -> T Int - - -Note [Checking GADT return types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is a delicacy around checking the return types of a datacon. The -central problem is dealing with a declaration like - - data T a where - MkT :: T a -> Q a - -Note that the return type of MkT is totally bogus. When creating the T -tycon, we also need to create the MkT datacon, which must have a "rejigged" -return type. That is, the MkT datacon's type must be transformed to have -a uniform return type with explicit coercions for GADT-like type parameters. -This rejigging is what rejigConRes does. The problem is, though, that checking -that the return type is appropriate is much easier when done over *Type*, -not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully -defined yet. - -So, we want to make rejigConRes lazy and then check the validity of -the return type in checkValidDataCon. To do this we /always/ return a -5-tuple from rejigConRes (so that we can extract ret_ty from it, which -checkValidDataCon needs), but the first four fields may be bogus if -the return type isn't valid (the last equation for rejigConRes). - -This is better than an earlier solution which reduced the number of -errors reported in one pass. See Trac #7175, and #10836. --} - --- Example --- data instance T (b,c) where --- TI :: forall e. e -> T (e,e) --- --- The representation tycon looks like this: --- data :R7T b c where --- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 --- In this case orig_res_ty = T (e,e) - -rejigConRes :: [TyConBinder] -> Type -- Template for result type; e.g. - -- data instance T [a] b c = ... - -- gives template ([a,b,c], T [a] b c) - -- Type must be of kind *! - -> [TyVar] -- where MkT :: forall x y z. ... - -> Type -- res_ty type must be of kind * - -> ([TyVar], -- Universal - [TyVar], -- Existential (distinct OccNames from univs) - [EqSpec], -- Equality predicates - Type, -- Typechecked return type - TCvSubst) -- Substitution to apply to argument types - -- We don't check that the TyCon given in the ResTy is - -- the same as the parent tycon, because checkValidDataCon will do it - -rejigConRes tmpl_bndrs res_tmpl dc_tvs res_ty - -- E.g. data T [a] b c where - -- MkT :: forall x y z. T [(x,y)] z z - -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs - -- (NB: unlike the H98 case, the dc_tvs are not all existential) - -- Then we generate - -- Univ tyvars Eq-spec - -- a a~(x,y) - -- b b~z - -- z - -- Existentials are the leftover type vars: [x,y] - -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z) - | Just subst <- ASSERT( isLiftedTypeKind (typeKind res_ty) ) - ASSERT( isLiftedTypeKind (typeKind res_tmpl) ) - tcMatchTy res_tmpl res_ty - = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst - raw_ex_tvs = dc_tvs `minusList` univ_tvs - (arg_subst, substed_ex_tvs) - = mapAccumL substTyVarBndr kind_subst raw_ex_tvs - - substed_eqs = map (substEqSpec arg_subst) raw_eqs - in - (univ_tvs, substed_ex_tvs, substed_eqs, res_ty, arg_subst) - - | otherwise - -- If the return type of the data constructor doesn't match the parent - -- type constructor, or the arity is wrong, the tcMatchTy will fail - -- e.g data T a b where - -- T1 :: Maybe a -- Wrong tycon - -- T2 :: T [a] -- Wrong arity - -- We are detect that later, in checkValidDataCon, but meanwhile - -- we must do *something*, not just crash. So we do something simple - -- albeit bogus, relying on checkValidDataCon to check the - -- bad-result-type error before seeing that the other fields look odd - -- See Note [Checking GADT return types] - = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, [], res_ty, emptyTCvSubst) - where - tmpl_tvs = binderVars tmpl_bndrs - -{- Note [mkGADTVars] -~~~~~~~~~~~~~~~~~~~~ -Running example: - -data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where - MkT :: forall (x1 : *) (y :: x1) (z :: *). - T x1 * (Proxy (y :: x1), z) z - -We need the rejigged type to be - - MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2). - forall (y :: x1) (z :: *). - (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z) - => T x1 k2 a b - -You might naively expect that z should become a universal tyvar, -not an existential. (After all, x1 becomes a universal tyvar.) -But z has kind * while b has kind k2, so the return type - T x1 k2 a z -is ill-kinded. Another way to say it is this: the universal -tyvars must have exactly the same kinds as the tyConTyVars. - -So we need an existential tyvar and a heterogeneous equality -constraint. (The b ~ z is a bit redundant with the k2 ~ * that -comes before in that b ~ z implies k2 ~ *. I'm sure we could do -some analysis that could eliminate k2 ~ *. But we don't do this -yet.) - -The data con signature has already been fully kind-checked. -The return type - - T x1 * (Proxy (y :: x1), z) z -becomes - qtkvs = [x1 :: *, y :: x1, z :: *] - res_tmpl = T x1 * (Proxy x1 y, z) z - -We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We -know this match will succeed because of the validity check (actually done -later, but laziness saves us -- see Note [Checking GADT return types]). -Thus, we get - - subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z } - -Now, we need to figure out what the GADT equalities should be. In this case, -we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a -renaming. The others should be GADT equalities. We also need to make -sure that the universally-quantified variables of the datacon match up -with the tyvars of the tycon, as required for Core context well-formedness. -(This last bit is why we have to rejig at all!) - -`choose` walks down the tycon tyvars, figuring out what to do with each one. -It carries two substitutions: - - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables - mentioned in the datacon signature. - - r_sub's domain is *result* tyvars, names written by the programmer in - the datacon signature. The final rejigged type will use these names, but - the subst is still needed because sometimes the printed name of these variables - is different. (See choose_tv_name, below.) - -Before explaining the details of `choose`, let's just look at its operation -on our example: - - choose [] [] {} {} [k1, k2, a, b] - --> -- first branch of `case` statement - choose - univs: [x1 :: *] - eq_spec: [] - t_sub: {k1 |-> x1} - r_sub: {x1 |-> x1} - t_tvs: [k2, a, b] - --> -- second branch of `case` statement - choose - univs: [k2 :: *, x1 :: *] - eq_spec: [k2 ~ *] - t_sub: {k1 |-> x1, k2 |-> k2} - r_sub: {x1 |-> x1} - t_tvs: [a, b] - --> -- second branch of `case` statement - choose - univs: [a :: k2, k2 :: *, x1 :: *] - eq_spec: [ a ~ (Proxy x1 y, z) - , k2 ~ * ] - t_sub: {k1 |-> x1, k2 |-> k2, a |-> a} - r_sub: {x1 |-> x1} - t_tvs: [b] - --> -- second branch of `case` statement - choose - univs: [b :: k2, a :: k2, k2 :: *, x1 :: *] - eq_spec: [ b ~ z - , a ~ (Proxy x1 y, z) - , k2 ~ * ] - t_sub: {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z} - r_sub: {x1 |-> x1} - t_tvs: [] - --> -- end of recursion - ( [x1 :: *, k2 :: *, a :: k2, b :: k2] - , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z] - , {x1 |-> x1} ) - -`choose` looks up each tycon tyvar in the matching (it *must* be matched!). - -* If it finds a bare result tyvar (the first branch of the `case` - statement), it checks to make sure that the result tyvar isn't yet - in the list of univ_tvs. If it is in that list, then we have a - repeated variable in the return type, and we in fact need a GADT - equality. - -* It then checks to make sure that the kind of the result tyvar - matches the kind of the template tyvar. This check is what forces - `z` to be existential, as it should be, explained above. - -* Assuming no repeated variables or kind-changing, we wish to use the - variable name given in the datacon signature (that is, `x1` not - `k1`), not the tycon signature (which may have been made up by - GHC). So, we add a mapping from the tycon tyvar to the result tyvar - to t_sub. - -* If we discover that a mapping in `subst` gives us a non-tyvar (the - second branch of the `case` statement), then we have a GADT equality - to create. We create a fresh equality, but we don't extend any - substitutions. The template variable substitution is meant for use - in universal tyvar kinds, and these shouldn't be affected by any - GADT equalities. - -This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways -of simplifying it: - -1) The first branch of the `case` statement is really an optimization, used -in order to get fewer GADT equalities. It might be possible to make a GADT -equality for *every* univ. tyvar, even if the equality is trivial, and then -either deal with the bigger type or somehow reduce it later. - -2) This algorithm strives to use the names for type variables as specified -by the user in the datacon signature. If we always used the tycon tyvar -names, for example, this would be simplified. This change would almost -certainly degrade error messages a bit, though. --} - --- ^ From information about a source datacon definition, extract out --- what the universal variables and the GADT equalities should be. --- See Note [mkGADTVars]. -mkGADTVars :: [TyVar] -- ^ The tycon vars - -> [TyVar] -- ^ The datacon vars - -> TCvSubst -- ^ The matching between the template result type - -- and the actual result type - -> ( [TyVar] - , [EqSpec] - , TCvSubst ) -- ^ The univ. variables, the GADT equalities, - -- and a subst to apply to the GADT equalities - -- and existentials. -mkGADTVars tmpl_tvs dc_tvs subst - = choose [] [] empty_subst empty_subst tmpl_tvs - where - in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) - `unionInScope` getTCvInScope subst - empty_subst = mkEmptyTCvSubst in_scope - - choose :: [TyVar] -- accumulator of univ tvs, reversed - -> [EqSpec] -- accumulator of GADT equalities, reversed - -> TCvSubst -- template substitution - -> TCvSubst -- res. substitution - -> [TyVar] -- template tvs (the univ tvs passed in) - -> ( [TyVar] -- the univ_tvs - , [EqSpec] -- GADT equalities - , TCvSubst ) -- a substitution to fix kinds in ex_tvs - - choose univs eqs _t_sub r_sub [] - = (reverse univs, reverse eqs, r_sub) - choose univs eqs t_sub r_sub (t_tv:t_tvs) - | Just r_ty <- lookupTyVar subst t_tv - = case getTyVar_maybe r_ty of - Just r_tv - | not (r_tv `elem` univs) - , tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv)) - -> -- simple, well-kinded variable substitution. - choose (r_tv:univs) eqs - (extendTvSubst t_sub t_tv r_ty') - (extendTvSubst r_sub r_tv r_ty') - t_tvs - where - r_tv1 = setTyVarName r_tv (choose_tv_name r_tv t_tv) - r_ty' = mkTyVarTy r_tv1 - - -- Not a simple substitution: make an equality predicate - _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs) - (extendTvSubst t_sub t_tv (mkTyVarTy t_tv')) - -- We've updated the kind of t_tv, - -- so add it to t_sub (Trac #14162) - r_sub t_tvs - where - t_tv' = updateTyVarKind (substTy t_sub) t_tv - - | otherwise - = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst) - - -- choose an appropriate name for a univ tyvar. - -- This *must* preserve the Unique of the result tv, so that we - -- can detect repeated variables. It prefers user-specified names - -- over system names. A result variable with a system name can - -- happen with GHC-generated implicit kind variables. - choose_tv_name :: TyVar -> TyVar -> Name - choose_tv_name r_tv t_tv - | isSystemName r_tv_name - = setNameUnique t_tv_name (getUnique r_tv_name) - - | otherwise - = r_tv_name - - where - r_tv_name = getName r_tv - t_tv_name = getName t_tv - -{- -Note [Substitution in template variables kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -data G (a :: Maybe k) where - MkG :: G Nothing - -With explicit kind variables - -data G k (a :: Maybe k) where - MkG :: G k1 (Nothing k1) - -Note how k1 is distinct from k. So, when we match the template -`G k a` against `G k1 (Nothing k1)`, we get a subst -[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two -mappings, we surely don't want to add (k, k1) to the list of -GADT equalities -- that would be overly complex and would create -more untouchable variables than we need. So, when figuring out -which tyvars are GADT-like and which aren't (the fundamental -job of `choose`), we want to treat `k` as *not* GADT-like. -Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1) -instead of (a :: Maybe k). This is the reason for dealing -with a substitution in here. - -However, we do not *always* want to substitute. Consider - -data H (a :: k) where - MkH :: H Int - -With explicit kind variables: - -data H k (a :: k) where - MkH :: H * Int - -Here, we have a kind-indexed GADT. The subst in question is -[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s -kind, because that would give a constructor with the type - -MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a - -The problem here is that a's kind is wrong -- it needs to be k, not *! -So, if the matching for a variable is anything but another bare variable, -we drop the mapping from the substitution before proceeding. This -was not an issue before kind-indexed GADTs because this case could -never happen. - -************************************************************************ -* * - Validity checking -* * -************************************************************************ - -Validity checking is done once the mutually-recursive knot has been -tied, so we can look at things freely. --} - -checkValidTyCl :: TyCon -> TcM TyCon -checkValidTyCl tc - = setSrcSpan (getSrcSpan tc) $ - addTyConCtxt tc $ - recoverM recovery_code - (do { traceTc "Starting validity for tycon" (ppr tc) - ; checkValidTyCon tc - ; traceTc "Done validity for tycon" (ppr tc) - ; return tc }) - where - recovery_code -- See Note [Recover from validity error] - = do { traceTc "Aborted validity for tycon" (ppr tc) - ; return fake_tc } - fake_tc | isFamilyTyCon tc || isTypeSynonymTyCon tc - = makeRecoveryTyCon tc - | otherwise - = tc - -{- Note [Recover from validity error] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We recover from a validity error in a type or class, which allows us -to report multiple validity errors. In the failure case we return a -TyCon of the right kind, but with no interesting behaviour -(makeRecoveryTyCon). Why? Suppose we have - type T a = Fun -where Fun is a type family of arity 1. The RHS is invalid, but we -want to go on checking validity of subsequent type declarations. -So we replace T with an abstract TyCon which will do no harm. -See indexed-types/should_fail/BadSock and Trac #10896 - -Painfully, though, we *don't* want to do this for classes. -Consider tcfail041: - class (?x::Int) => C a where ... - instance C Int -The class is invalid because of the superclass constraint. But -we still want it to look like a /class/, else the instance bleats -that the instance is mal-formed because it hasn't got a class in -the head. --} - -------------------------- --- For data types declared with record syntax, we require --- that each constructor that has a field 'f' --- (a) has the same result type --- (b) has the same type for 'f' --- module alpha conversion of the quantified type variables --- of the constructor. --- --- Note that we allow existentials to match because the --- fields can never meet. E.g --- data T where --- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T --- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T --- Here we do not complain about f1,f2 because they are existential - -checkValidTyCon :: TyCon -> TcM () -checkValidTyCon tc - | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim - = return () - - | otherwise - = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc)) - ; checkValidTyConTyVars tc - ; if | Just cl <- tyConClass_maybe tc - -> checkValidClass cl - - | Just syn_rhs <- synTyConRhs_maybe tc - -> do { checkValidType syn_ctxt syn_rhs - ; checkTySynRhs syn_ctxt syn_rhs } - - | Just fam_flav <- famTyConFlav_maybe tc - -> case fam_flav of - { ClosedSynFamilyTyCon (Just ax) - -> tcAddClosedTypeFamilyDeclCtxt tc $ - checkValidCoAxiom ax - ; ClosedSynFamilyTyCon Nothing -> return () - ; AbstractClosedSynFamilyTyCon -> - do { hsBoot <- tcIsHsBootOrSig - ; checkTc hsBoot $ - text "You may define an abstract closed type family" $$ - text "only in a .hs-boot file" } - ; DataFamilyTyCon {} -> return () - ; OpenSynFamilyTyCon -> return () - ; BuiltInSynFamTyCon _ -> return () } - - | otherwise -> do - { -- Check the context on the data decl - traceTc "cvtc1" (ppr tc) - ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) - - ; traceTc "cvtc2" (ppr tc) - - ; dflags <- getDynFlags - ; existential_ok <- xoptM LangExt.ExistentialQuantification - ; gadt_ok <- xoptM LangExt.GADTs - ; let ex_ok = existential_ok || gadt_ok - -- Data cons can have existential context - ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons - - -- Check that fields with the same name share a type - ; mapM_ check_fields groups }} - where - syn_ctxt = TySynCtxt name - name = tyConName tc - data_cons = tyConDataCons tc - - groups = equivClasses cmp_fld (concatMap get_fields data_cons) - cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2 - get_fields con = dataConFieldLabels con `zip` repeat con - -- dataConFieldLabels may return the empty list, which is fine - - -- See Note [GADT record selectors] in TcTyDecls - -- We must check (a) that the named field has the same - -- type in each constructor - -- (b) that those constructors have the same result type - -- - -- However, the constructors may have differently named type variable - -- and (worse) we don't know how the correspond to each other. E.g. - -- C1 :: forall a b. { f :: a, g :: b } -> T a b - -- C2 :: forall d c. { f :: c, g :: c } -> T c d - -- - -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's - -- result type against other candidates' types BOTH WAYS ROUND. - -- If they magically agrees, take the substitution and - -- apply them to the latter ones, and see if they match perfectly. - check_fields ((label, con1) : other_fields) - -- These fields all have the same name, but are from - -- different constructors in the data type - = recoverM (return ()) $ mapM_ checkOne other_fields - -- Check that all the fields in the group have the same type - -- NB: this check assumes that all the constructors of a given - -- data type use the same type variables - where - (_, _, _, res1) = dataConSig con1 - fty1 = dataConFieldType con1 lbl - lbl = flLabel label - - checkOne (_, con2) -- Do it bothways to ensure they are structurally identical - = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2 - ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 } - where - (_, _, _, res2) = dataConSig con2 - fty2 = dataConFieldType con2 lbl - check_fields [] = panic "checkValidTyCon/check_fields []" - -checkFieldCompat :: FieldLabelString -> DataCon -> DataCon - -> Type -> Type -> Type -> Type -> TcM () -checkFieldCompat fld con1 con2 res1 res2 fty1 fty2 - = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) - ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } - where - mb_subst1 = tcMatchTy res1 res2 - mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 - -------------------------------- --- | Check for ill-scoped telescopes in a tycon. --- For example: --- --- > data SameKind :: k -> k -> * -- this is OK --- > data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) --- --- The problem is that @b@ should be bound (implicitly) at the beginning, --- but its kind mentions @a@, which is not yet in scope. Kind generalization --- makes a mess of this, and ends up including @a@ twice in the final --- tyvars. So this function checks for duplicates and, if there are any, --- produces the appropriate error message. -checkValidTyConTyVars :: TyCon -> TcM () -checkValidTyConTyVars tc - = do { -- strip off the duplicates and look for ill-scoped things - -- but keep the *last* occurrence of each variable, as it's - -- most likely the one the user wrote - let stripped_tvs | duplicate_vars - = reverse $ nub $ reverse tvs - | otherwise - = tvs - vis_tvs = filterOutInvisibleTyVars tc tvs - extra | not (vis_tvs `equalLength` stripped_tvs) - = text "NB: Implicitly declared kind variables are put first." - | otherwise - = empty - ; checkValidTelescope (pprTyVars vis_tvs) stripped_tvs extra - `and_if_that_doesn't_error` - -- This triggers on test case dependent/should_fail/InferDependency - -- It reports errors around Note [Dependent LHsQTyVars] in TcHsType - when duplicate_vars ( - addErr (vcat [ text "Invalid declaration for" <+> - quotes (ppr tc) <> semi <+> text "you must explicitly" - , text "declare which variables are dependent on which others." - , hang (text "Inferred variable kinds:") - 2 (vcat (map pp_tv stripped_tvs)) ])) } - where - tvs = tyConTyVars tc - duplicate_vars = sizeVarSet (mkVarSet tvs) < length tvs - - pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - - -- only run try_second if the first reports no errors - and_if_that_doesn't_error :: TcM () -> TcM () -> TcM () - try_first `and_if_that_doesn't_error` try_second - = recoverM (return ()) $ - do { checkNoErrs try_first - ; try_second } - -------------------------------- -checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () -checkValidDataCon dflags existential_ok tc con - = setSrcSpan (srcLocSpan (getSrcLoc con)) $ - addErrCtxt (dataConCtxt con) $ - do { -- Check that the return type of the data constructor - -- matches the type constructor; eg reject this: - -- data T a where { MkT :: Bogus a } - -- It's important to do this first: - -- see Note [Checking GADT return types] - -- and c.f. Note [Check role annotations in a second pass] - let tc_tvs = tyConTyVars tc - res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) - orig_res_ty = dataConOrigResTy con - ; traceTc "checkValidDataCon" (vcat - [ ppr con, ppr tc, ppr tc_tvs - , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl) - , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)]) - - - ; checkTc (isJust (tcMatchTy res_ty_tmpl - orig_res_ty)) - (badDataConTyCon con res_ty_tmpl orig_res_ty) - -- Note that checkTc aborts if it finds an error. This is - -- critical to avoid panicking when we call dataConUserType - -- on an un-rejiggable datacon! - - ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con)) - - -- Check that the result type is a *monotype* - -- e.g. reject this: MkT :: T (forall a. a->a) - -- Reason: it's really the argument of an equality constraint - ; checkValidMonoType orig_res_ty - - -- Check all argument types for validity - ; checkValidType ctxt (dataConUserType con) - ; mapM_ (checkForLevPoly empty) - (dataConOrigArgTys con) - - -- Extra checks for newtype data constructors - ; when (isNewTyCon tc) (checkNewDataCon con) - - -- Check that existentials are allowed if they are used - ; checkTc (existential_ok || isVanillaDataCon con) - (badExistential con) - - -- Check that UNPACK pragmas and bangs work out - -- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!" - -- data T = MkT {-# UNPACK #-} !a -- Can't unpack - ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..] - - ; traceTc "Done validity of data con" $ - vcat [ ppr con - , text "Datacon user type:" <+> ppr (dataConUserType con) - , text "Datacon rep type:" <+> ppr (dataConRepType con) - , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con)) - , case tyConFamInst_maybe (dataConTyCon con) of - Nothing -> text "not family" - Just (f, _) -> ppr (tyConBinders f) ] - } - where - ctxt = ConArgCtxt (dataConName con) - - check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM () - check_bang (HsSrcBang _ _ SrcLazy) _ n - | not (xopt LangExt.StrictData dflags) - = addErrTc - (bad_bang n (text "Lazy annotation (~) without StrictData")) - check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n - | isSrcUnpacked want_unpack, not is_strict - = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'")) - | isSrcUnpacked want_unpack - , case rep_bang of { HsUnpack {} -> False; _ -> True } - , not (gopt Opt_OmitInterfacePragmas dflags) - -- If not optimising, se don't unpack, so don't complain! - -- See MkId.dataConArgRep, the (HsBang True) case - = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma")) - where - is_strict = case strict_mark of - NoSrcStrict -> xopt LangExt.StrictData dflags - bang -> isSrcStrict bang - - check_bang _ _ _ - = return () - - bad_bang n herald - = hang herald 2 (text "on the" <+> speakNth n - <+> text "argument of" <+> quotes (ppr con)) -------------------------------- -checkNewDataCon :: DataCon -> TcM () --- Further checks for the data constructor of a newtype -checkNewDataCon con - = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) - -- One argument - - ; checkTc (not (isUnliftedType arg_ty1)) $ - text "A newtype cannot have an unlifted argument type" - - ; check_con (null eq_spec) $ - text "A newtype constructor must have a return type of form T a1 ... an" - -- Return type is (T a b c) - - ; check_con (null theta) $ - text "A newtype constructor cannot have a context in its type" - - ; check_con (null ex_tvs) $ - text "A newtype constructor cannot have existential type variables" - -- No existentials - - ; checkTc (all ok_bang (dataConSrcBangs con)) - (newtypeStrictError con) - -- No strictness annotations - } - where - (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig con - check_con what msg - = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con)) - - (arg_ty1 : _) = arg_tys - - ok_bang (HsSrcBang _ _ SrcStrict) = False - ok_bang (HsSrcBang _ _ SrcLazy) = False - ok_bang _ = True - -------------------------------- -checkValidClass :: Class -> TcM () -checkValidClass cls - = do { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods - ; multi_param_type_classes <- xoptM LangExt.MultiParamTypeClasses - ; nullary_type_classes <- xoptM LangExt.NullaryTypeClasses - ; fundep_classes <- xoptM LangExt.FunctionalDependencies - ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses - - -- Check that the class is unary, unless multiparameter type classes - -- are enabled; also recognize deprecated nullary type classes - -- extension (subsumed by multiparameter type classes, Trac #8993) - ; checkTc (multi_param_type_classes || cls_arity == 1 || - (nullary_type_classes && cls_arity == 0)) - (classArityErr cls_arity cls) - ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls) - - -- Check the super-classes - ; checkValidTheta (ClassSCCtxt (className cls)) theta - - -- Now check for cyclic superclasses - -- If there are superclass cycles, checkClassCycleErrs bails. - ; unless undecidable_super_classes $ - case checkClassCycles cls of - Just err -> setSrcSpan (getSrcSpan cls) $ - addErrTc err - Nothing -> return () - - -- Check the class operations. - -- But only if there have been no earlier errors - -- See Note [Abort when superclass cycle is detected] - ; whenNoErrs $ - mapM_ (check_op constrained_class_methods) op_stuff - - -- Check the associated type defaults are well-formed and instantiated - ; mapM_ check_at at_stuff } - where - (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls - cls_arity = length $ filterOutInvisibleTyVars (classTyCon cls) tyvars - -- Ignore invisible variables - cls_tv_set = mkVarSet tyvars - mini_env = zipVarEnv tyvars (mkTyVarTys tyvars) - mb_cls = Just (cls, tyvars, mini_env) - - check_op constrained_class_methods (sel_id, dm) - = setSrcSpan (getSrcSpan sel_id) $ - addErrCtxt (classOpCtxt sel_id op_ty) $ do - { traceTc "class op type" (ppr op_ty) - ; checkValidType ctxt op_ty - -- This implements the ambiguity check, among other things - -- Example: tc223 - -- class Error e => Game b mv e | b -> mv e where - -- newBoard :: MonadState b m => m () - -- Here, MonadState has a fundep m->b, so newBoard is fine - - -- a method cannot be levity polymorphic, as we have to store the - -- method in a dictionary - -- example of what this prevents: - -- class BoundedX (a :: TYPE r) where minBound :: a - -- See Note [Levity polymorphism checking] in DsMonad - ; checkForLevPoly empty tau1 - - ; unless constrained_class_methods $ - mapM_ check_constraint (tail (cls_pred:op_theta)) - - ; check_dm ctxt sel_id cls_pred tau2 dm - } - where - ctxt = FunSigCtxt op_name True -- Report redundant class constraints - op_name = idName sel_id - op_ty = idType sel_id - (_,cls_pred,tau1) = tcSplitMethodTy op_ty - -- See Note [Splitting nested sigma types] - (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1 - - check_constraint :: TcPredType -> TcM () - check_constraint pred -- See Note [Class method constraints] - = when (not (isEmptyVarSet pred_tvs) && - pred_tvs `subVarSet` cls_tv_set) - (addErrTc (badMethPred sel_id pred)) - where - pred_tvs = tyCoVarsOfType pred - - check_at (ATI fam_tc m_dflt_rhs) - = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) - (noClassTyVarErr cls fam_tc) - -- Check that the associated type mentions at least - -- one of the class type variables - -- The check is disabled for nullary type classes, - -- since there is no possible ambiguity (Trac #10020) - - -- Check that any default declarations for associated types are valid - ; whenIsJust m_dflt_rhs $ \ (rhs, loc) -> - checkValidTyFamEqn mb_cls fam_tc - fam_tvs [] (mkTyVarTys fam_tvs) rhs loc } - where - fam_tvs = tyConTyVars fam_tc - - check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM () - -- Check validity of the /top-level/ generic-default type - -- E.g for class C a where - -- default op :: forall b. (a~b) => blah - -- we do not want to do an ambiguity check on a type with - -- a free TyVar 'a' (Trac #11608). See TcType - -- Note [TyVars and TcTyVars during type checking] in TcType - -- Hence the mkDefaultMethodType to close the type. - check_dm ctxt sel_id vanilla_cls_pred vanilla_tau - (Just (dm_name, dm_spec@(GenericDM dm_ty))) - = setSrcSpan (getSrcSpan dm_name) $ do - -- We have carefully set the SrcSpan on the generic - -- default-method Name to be that of the generic - -- default type signature - - -- First, we check that that the method's default type signature - -- aligns with the non-default type signature. - -- See Note [Default method type signatures must align] - let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls - -- Note that the second field of this tuple contains the context - -- of the default type signature, making it apparent that we - -- ignore method contexts completely when validity-checking - -- default type signatures. See the end of - -- Note [Default method type signatures must align] - -- to learn why this is OK. - -- - -- See also Note [Splitting nested sigma types] - -- for an explanation of why we don't use tcSplitSigmaTy here. - (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty - - -- Given this class definition: - -- - -- class C a b where - -- op :: forall p q. (Ord a, D p q) - -- => a -> b -> p -> (a, b) - -- default op :: forall r s. E r - -- => a -> b -> s -> (a, b) - -- - -- We want to match up two types of the form: - -- - -- Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb) - -- Default type sig: C a b => a -> b -> s -> (a, b) - -- - -- Notice that the two type signatures can be quantified over - -- different class type variables! Therefore, it's important that - -- we include the class predicate parts to match up a with aa and - -- b with bb. - vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau - dm_phi_ty = mkPhiTy [cls_pred] dm_tau - - traceTc "check_dm" $ vcat - [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty - , text "dm_phi_ty" <+> ppr dm_phi_ty ] - - -- Actually checking that the types align is done with a call to - -- tcMatchTys. We need to get a match in both directions to rule - -- out degenerate cases like these: - -- - -- class Foo a where - -- foo1 :: a -> b - -- default foo1 :: a -> Int - -- - -- foo2 :: a -> Int - -- default foo2 :: a -> b - unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] - [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ - hang (text "The default type signature for" - <+> ppr sel_id <> colon) - 2 (ppr dm_ty) - $$ (text "does not match its corresponding" - <+> text "non-default type signature") - - -- Now do an ambiguity check on the default type signature. - checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec) - check_dm _ _ _ _ _ = return () - -checkFamFlag :: Name -> TcM () --- Check that we don't use families without -XTypeFamilies --- The parser won't even parse them, but I suppose a GHC API --- client might have a go! -checkFamFlag tc_name - = do { idx_tys <- xoptM LangExt.TypeFamilies - ; checkTc idx_tys err_msg } - where - err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) - 2 (text "Use TypeFamilies to allow indexed type families") - -{- Note [Class method constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Haskell 2010 is supposed to reject - class C a where - op :: Eq a => a -> a -where the method type costrains only the class variable(s). (The extension --XConstrainedClassMethods switches off this check.) But regardless -we should not reject - class C a where - op :: (?x::Int) => a -> a -as pointed out in Trac #11793. So the test here rejects the program if - * -XConstrainedClassMethods is off - * the tyvars of the constraint are non-empty - * all the tyvars are class tyvars, none are locally quantified - -Note [Abort when superclass cycle is detected] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must avoid doing the ambiguity check for the methods (in -checkValidClass.check_op) when there are already errors accumulated. -This is because one of the errors may be a superclass cycle, and -superclass cycles cause canonicalization to loop. Here is a -representative example: - - class D a => C a where - meth :: D a => () - class C a => D a - -This fixes Trac #9415, #9739 - -Note [Default method type signatures must align] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC enforces the invariant that a class method's default type signature -must "align" with that of the method's non-default type signature, as per -GHC Trac #12918. For instance, if you have: - - class Foo a where - bar :: forall b. Context => a -> b - -Then a default type signature for bar must be alpha equivalent to -(forall b. a -> b). That is, the types must be the same modulo differences in -contexts. So the following would be acceptable default type signatures: - - default bar :: forall b. Context1 => a -> b - default bar :: forall x. Context2 => a -> x - -But the following are NOT acceptable default type signatures: - - default bar :: forall b. b -> a - default bar :: forall x. x - default bar :: a -> Int - -Note that a is bound by the class declaration for Foo itself, so it is -not allowed to differ in the default type signature. - -The default type signature (default bar :: a -> Int) deserves special mention, -since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To -write this, you need to declare the default type signature like so: - - default bar :: forall b. (b ~ Int). a -> b - -As noted in #12918, there are several reasons to do this: - -1. It would make no sense to have a type that was flat-out incompatible with - the non-default type signature. For instance, if you had: - - class Foo a where - bar :: a -> Int - default bar :: a -> Bool - - Then that would always fail in an instance declaration. So this check - nips such cases in the bud before they have the chance to produce - confusing error messages. - -2. Internally, GHC uses TypeApplications to instantiate the default method in - an instance. See Note [Default methods in instances] in TcInstDcls. - Thus, GHC needs to know exactly what the universally quantified type - variables are, and when instantiated that way, the default method's type - must match the expected type. - -3. Aesthetically, by only allowing the default type signature to differ in its - context, we are making it more explicit the ways in which the default type - signature is less polymorphic than the non-default type signature. - -You might be wondering: why are the contexts allowed to be different, but not -the rest of the type signature? That's because default implementations often -rely on assumptions that the more general, non-default type signatures do not. -For instance, in the Enum class declaration: - - class Enum a where - enum :: [a] - default enum :: (Generic a, GEnum (Rep a)) => [a] - enum = map to genum - - class GEnum f where - genum :: [f a] - -The default implementation for enum only works for types that are instances of -Generic, and for which their generic Rep type is an instance of GEnum. But -clearly enum doesn't _have_ to use this implementation, so naturally, the -context for enum is allowed to be different to accomodate this. As a result, -when we validity-check default type signatures, we ignore contexts completely. - -Note that when checking whether two type signatures match, we must take care to -split as many foralls as it takes to retrieve the tau types we which to check. -See Note [Splitting nested sigma types]. - -Note [Splitting nested sigma types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this type synonym and class definition: - - type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t - - class Each s t a b where - each :: Traversal s t a b - default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b - -It might seem obvious that the tau types in both type signatures for `each` -are the same, but actually getting GHC to conclude this is surprisingly tricky. -That is because in general, the form of a class method's non-default type -signature is: - - forall a. C a => forall d. D d => E a b - -And the general form of a default type signature is: - - forall f. F f => E a f -- The variable `a` comes from the class - -So it you want to get the tau types in each type signature, you might find it -reasonable to call tcSplitSigmaTy twice on the non-default type signature, and -call it once on the default type signature. For most classes and methods, this -will work, but Each is a bit of an exceptional case. The way `each` is written, -it doesn't quantify any additional type variables besides those of the Each -class itself, so the non-default type signature for `each` is actually this: - - forall s t a b. Each s t a b => Traversal s t a b - -Notice that there _appears_ to only be one forall. But there's actually another -forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy -twice, you'll also go under the forall in Traversal! That is, you'll end up -with: - - (a -> f b) -> s -> f t - -A problem arises because you only call tcSplitSigmaTy once on the default type -signature for `each`, which gives you - - Traversal s t a b - -Or, equivalently: - - forall f. Applicative f => (a -> f b) -> s -> f t - -This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will -say that the tau types for `each` are not equal. - -A solution to this problem is to use tcSplitNestedSigmaTys instead of -tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it -sees until it can't go any further, so if you called it on the default type -signature for `each`, it would return (a -> f b) -> s -> f t like we desired. - -************************************************************************ -* * - Checking role validity -* * -************************************************************************ --} - -checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM () -checkValidRoleAnnots role_annots tc - | isTypeSynonymTyCon tc = check_no_roles - | isFamilyTyCon tc = check_no_roles - | isAlgTyCon tc = check_roles - | otherwise = return () - where - -- Role annotations are given only on *explicit* variables, - -- but a tycon stores roles for all variables. - -- So, we drop the implicit roles (which are all Nominal, anyway). - name = tyConName tc - tyvars = tyConTyVars tc - roles = tyConRoles tc - (vis_roles, vis_vars) = unzip $ snd $ - partitionInvisibles tc (mkTyVarTy . snd) $ - zip roles tyvars - role_annot_decl_maybe = lookupRoleAnnot role_annots name - - check_roles - = whenIsJust role_annot_decl_maybe $ - \decl@(L loc (RoleAnnotDecl _ the_role_annots)) -> - addRoleAnnotCtxt name $ - setSrcSpan loc $ do - { role_annots_ok <- xoptM LangExt.RoleAnnotations - ; checkTc role_annots_ok $ needXRoleAnnotations tc - ; checkTc (vis_vars `equalLength` the_role_annots) - (wrongNumberOfRoles vis_vars decl) - ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles - -- Representational or phantom roles for class parameters - -- quickly lead to incoherence. So, we require - -- IncoherentInstances to have them. See #8773. - ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances - ; checkTc ( incoherent_roles_ok - || (not $ isClassTyCon tc) - || (all (== Nominal) vis_roles)) - incoherentRoles - - ; lint <- goptM Opt_DoCoreLinting - ; when lint $ checkValidRoles tc } - - check_no_roles - = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl - -checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () -checkRoleAnnot _ (L _ Nothing) _ = return () -checkRoleAnnot tv (L _ (Just r1)) r2 - = when (r1 /= r2) $ - addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 - --- This is a double-check on the role inference algorithm. It is only run when --- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls -checkValidRoles :: TyCon -> TcM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in CoreLint -checkValidRoles tc - | isAlgTyCon tc - -- tyConDataCons returns an empty list for data families - = mapM_ check_dc_roles (tyConDataCons tc) - | Just rhs <- synTyConRhs_maybe tc - = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs - | otherwise - = return () - where - check_dc_roles datacon - = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) - ; mapM_ (check_ty_roles role_env Representational) $ - eqSpecPreds eq_spec ++ theta ++ arg_tys } - -- See Note [Role-checking data constructor arguments] in TcTyDecls - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig datacon - univ_roles = zipVarEnv univ_tvs (tyConRoles tc) - -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs - ex_roles = mkVarEnv (map (, Nominal) ex_tvs) - role_env = univ_roles `plusVarEnv` ex_roles - - check_ty_roles env role (TyVarTy tv) - = case lookupVarEnv env tv of - Just role' -> unless (role' `ltRole` role || role' == role) $ - report_error $ text "type variable" <+> quotes (ppr tv) <+> - text "cannot have role" <+> ppr role <+> - text "because it was assigned role" <+> ppr role' - Nothing -> report_error $ text "type variable" <+> quotes (ppr tv) <+> - text "missing in environment" - - check_ty_roles env Representational (TyConApp tc tys) - = let roles' = tyConRoles tc in - zipWithM_ (maybe_check_ty_roles env) roles' tys - - check_ty_roles env Nominal (TyConApp _ tys) - = mapM_ (check_ty_roles env Nominal) tys - - check_ty_roles _ Phantom ty@(TyConApp {}) - = pprPanic "check_ty_roles" (ppr ty) - - check_ty_roles env role (AppTy ty1 ty2) - = check_ty_roles env role ty1 - >> check_ty_roles env Nominal ty2 - - check_ty_roles env role (FunTy ty1 ty2) - = check_ty_roles env role ty1 - >> check_ty_roles env role ty2 - - check_ty_roles env role (ForAllTy (TvBndr tv _) ty) - = check_ty_roles env Nominal (tyVarKind tv) - >> check_ty_roles (extendVarEnv env tv Nominal) role ty - - check_ty_roles _ _ (LitTy {}) = return () - - check_ty_roles env role (CastTy t _) - = check_ty_roles env role t - - check_ty_roles _ role (CoercionTy co) - = unless (role == Phantom) $ - report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role - - maybe_check_ty_roles env role ty - = when (role == Nominal || role == Representational) $ - check_ty_roles env role ty - - report_error doc - = addErrTc $ vcat [text "Internal error in role inference:", - doc, - text "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug"] - -{- -************************************************************************ -* * - Error messages -* * -************************************************************************ --} - -tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a -tcAddTyFamInstCtxt decl - = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl) - -tcMkDataFamInstCtxt :: DataFamInstDecl Name -> SDoc -tcMkDataFamInstCtxt decl - = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance") - (unLoc (dfid_tycon decl)) - -tcAddDataFamInstCtxt :: DataFamInstDecl Name -> TcM a -> TcM a -tcAddDataFamInstCtxt decl - = addErrCtxt (tcMkDataFamInstCtxt decl) - -tcMkFamInstCtxt :: SDoc -> Name -> SDoc -tcMkFamInstCtxt flavour tycon - = hsep [ text "In the" <+> flavour <+> text "declaration for" - , quotes (ppr tycon) ] - -tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a -tcAddFamInstCtxt flavour tycon thing_inside - = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside - -tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a -tcAddClosedTypeFamilyDeclCtxt tc - = addErrCtxt ctxt - where - ctxt = text "In the equations for closed type family" <+> - quotes (ppr tc) - -resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc -resultTypeMisMatch field_name con1 con2 - = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "have a common field" <+> quotes (ppr field_name) <> comma], - nest 2 $ text "but have different result types"] - -fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc -fieldTypeMisMatch field_name con1 con2 - = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "give different types for field", quotes (ppr field_name)] - -dataConCtxtName :: [Located Name] -> SDoc -dataConCtxtName [con] - = text "In the definition of data constructor" <+> quotes (ppr con) -dataConCtxtName con - = text "In the definition of data constructors" <+> interpp'SP con - -dataConCtxt :: Outputable a => a -> SDoc -dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con) - -classOpCtxt :: Var -> Type -> SDoc -classOpCtxt sel_id tau = sep [text "When checking the class method:", - nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] - -classArityErr :: Int -> Class -> SDoc -classArityErr n cls - | n == 0 = mkErr "No" "no-parameter" - | otherwise = mkErr "Too many" "multi-parameter" - where - mkErr howMany allowWhat = - vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), - parens (text ("Use MultiParamTypeClasses to allow " - ++ allowWhat ++ " classes"))] - -classFunDepsErr :: Class -> SDoc -classFunDepsErr cls - = vcat [text "Fundeps in class" <+> quotes (ppr cls), - parens (text "Use FunctionalDependencies to allow fundeps")] - -badMethPred :: Id -> TcPredType -> SDoc -badMethPred sel_id pred - = vcat [ hang (text "Constraint" <+> quotes (ppr pred) - <+> text "in the type of" <+> quotes (ppr sel_id)) - 2 (text "constrains only the class type variables") - , text "Use ConstrainedClassMethods to allow it" ] - -noClassTyVarErr :: Class -> TyCon -> SDoc -noClassTyVarErr clas fam_tc - = sep [ text "The associated type" <+> quotes (ppr fam_tc) - , text "mentions none of the type or kind variables of the class" <+> - quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] - -badDataConTyCon :: DataCon -> Type -> Type -> SDoc -badDataConTyCon data_con res_ty_tmpl actual_res_ty - = 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)) - -badGadtDecl :: Name -> SDoc -badGadtDecl tc_name - = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) - , nest 2 (parens $ text "Use GADTs to allow GADTs") ] - -badExistential :: DataCon -> SDoc -badExistential con - = hang (text "Data constructor" <+> quotes (ppr con) <+> - text "has existential type variables, a context, or a specialised result type") - 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con) - , parens $ text "Use ExistentialQuantification or GADTs to allow this" ]) - -badStupidTheta :: Name -> SDoc -badStupidTheta tc_name - = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) - -newtypeConError :: Name -> Int -> SDoc -newtypeConError tycon n - = sep [text "A newtype must have exactly one constructor,", - nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] - -newtypeStrictError :: DataCon -> SDoc -newtypeStrictError con - = sep [text "A newtype constructor cannot have a strictness annotation,", - nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] - -newtypeFieldErr :: DataCon -> Int -> SDoc -newtypeFieldErr con_name n_flds - = sep [text "The constructor of a newtype must have exactly one field", - nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] - -badSigTyDecl :: Name -> SDoc -badSigTyDecl tc_name - = vcat [ text "Illegal kind signature" <+> - quotes (ppr tc_name) - , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] - -emptyConDeclsErr :: Name -> SDoc -emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> text "has no constructors", - nest 2 $ text "(EmptyDataDecls permits this)"] - -wrongKindOfFamily :: TyCon -> SDoc -wrongKindOfFamily family - = text "Wrong category of family instance; declaration was for a" - <+> kindOfFamily - where - kindOfFamily | isTypeFamilyTyCon family = text "type family" - | isDataFamilyTyCon family = text "data family" - | otherwise = pprPanic "wrongKindOfFamily" (ppr family) - -wrongNumberOfParmsErr :: Arity -> SDoc -wrongNumberOfParmsErr max_args - = text "Number of parameters must match family declaration; expected" - <+> ppr max_args - -defaultAssocKindErr :: TyCon -> SDoc -defaultAssocKindErr fam_tc - = text "Kind mis-match on LHS of default declaration for" - <+> quotes (ppr fam_tc) - -wrongTyFamName :: Name -> Name -> SDoc -wrongTyFamName fam_tc_name eqn_tc_name - = hang (text "Mismatched type name in type family instance.") - 2 (vcat [ text "Expected:" <+> ppr fam_tc_name - , text " Actual:" <+> ppr eqn_tc_name ]) - -badRoleAnnot :: Name -> Role -> Role -> SDoc -badRoleAnnot var annot inferred - = hang (text "Role mismatch on variable" <+> ppr var <> colon) - 2 (sep [ text "Annotation says", ppr annot - , text "but role", ppr inferred - , text "is required" ]) - -wrongNumberOfRoles :: [a] -> LRoleAnnotDecl Name -> SDoc -wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ annots)) - = hang (text "Wrong number of roles listed in role annotation;" $$ - text "Expected" <+> (ppr $ length tyvars) <> comma <+> - text "got" <+> (ppr $ length annots) <> colon) - 2 (ppr d) - -illegalRoleAnnotDecl :: LRoleAnnotDecl Name -> TcM () -illegalRoleAnnotDecl (L loc (RoleAnnotDecl tycon _)) - = setErrCtxt [] $ - setSrcSpan loc $ - addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ - text "they are allowed only for datatypes and classes.") - -needXRoleAnnotations :: TyCon -> SDoc -needXRoleAnnotations tc - = text "Illegal role annotation for" <+> ppr tc <> char ';' $$ - text "did you intend to use RoleAnnotations?" - -incoherentRoles :: SDoc -incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> - text "for class parameters can lead to incoherence.") $$ - (text "Use IncoherentInstances to allow this; bad role found") - -addTyConCtxt :: TyCon -> TcM a -> TcM a -addTyConCtxt tc - = addErrCtxt ctxt - where - name = getName tc - flav = text (tyConFlavour tc) - ctxt = hsep [ text "In the", flav - , text "declaration for", quotes (ppr name) ] - -addRoleAnnotCtxt :: Name -> TcM a -> TcM a -addRoleAnnotCtxt name - = addErrCtxt $ - text "while checking a role annotation for" <+> quotes (ppr name) diff --git a/typecheck/TcTyDecls.hs b/typecheck/TcTyDecls.hs deleted file mode 100644 --- a/typecheck/TcTyDecls.hs +++ /dev/null @@ -1,1007 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 - - -Analysis functions over data types. Specifically, detecting recursive types. - -This stuff is only used for source-code decls; it's recorded in interface -files for imported data types. --} - -{-# LANGUAGE CPP #-} - -module TcTyDecls( - RolesInfo, - inferRoles, - checkSynCycles, - checkClassCycles, - - -- * Implicits - tcAddImplicits, mkDefaultMethodType, - - -- * Record selectors - mkRecSelBinds, mkOneRecordSelector - ) where - -#include "HsVersions.h" - -import TcRnMonad -import TcEnv -import TcBinds( tcRecSelBinds ) -import RnEnv( RoleAnnotEnv, lookupRoleAnnot ) -import TyCoRep( Type(..), Coercion(..), UnivCoProvenance(..) ) -import TcType -import TysWiredIn( unitTy ) -import MkCore( rEC_SEL_ERROR_ID ) -import HsSyn -import Class -import Type -import HscTypes -import TyCon -import ConLike -import DataCon -import Name -import NameEnv -import NameSet hiding (unitFV) -import RdrName ( mkVarUnqual ) -import Id -import IdInfo -import VarEnv -import VarSet -import NameSet ( NameSet, unitNameSet, extendNameSet, elemNameSet ) -import Coercion ( ltRole ) -import BasicTypes -import SrcLoc -import Unique ( mkBuiltinUnique ) -import Outputable -import Util -import Maybes -import Bag -import FastString -import FV -import Module - -import Control.Monad - -{- -************************************************************************ -* * - Cycles in type synonym declarations -* * -************************************************************************ --} - -synonymTyConsOfType :: Type -> [TyCon] --- Does not look through type synonyms at all --- Return a list of synonym tycons --- Keep this synchronized with 'expandTypeSynonyms' -synonymTyConsOfType ty - = nameEnvElts (go ty) - where - go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim - go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys - go (LitTy _) = emptyNameEnv - go (TyVarTy _) = emptyNameEnv - go (AppTy a b) = go a `plusNameEnv` go b - go (FunTy a b) = go a `plusNameEnv` go b - go (ForAllTy _ ty) = go ty - go (CastTy ty co) = go ty `plusNameEnv` go_co co - go (CoercionTy co) = go_co co - - -- Note [TyCon cycles through coercions?!] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Although, in principle, it's possible for a type synonym loop - -- could go through a coercion (since a coercion can refer to - -- a TyCon or Type), it doesn't seem possible to actually construct - -- a Haskell program which tickles this case. Here is an example - -- program which causes a coercion: - -- - -- type family Star where - -- Star = Type - -- - -- data T :: Star -> Type - -- data S :: forall (a :: Type). T a -> Type - -- - -- Here, the application 'T a' must first coerce a :: Type to a :: Star, - -- witnessed by the type family. But if we now try to make Type refer - -- to a type synonym which in turn refers to Star, we'll run into - -- trouble: we're trying to define and use the type constructor - -- in the same recursive group. Possibly this restriction will be - -- lifted in the future but for now, this code is "just for completeness - -- sake". - go_co (Refl _ ty) = go ty - go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs - go_co (AppCo co co') = go_co co `plusNameEnv` go_co co' - go_co (ForAllCo _ co co') = go_co co `plusNameEnv` go_co co' - go_co (FunCo _ co co') = go_co co `plusNameEnv` go_co co' - go_co (CoVarCo _) = emptyNameEnv - go_co (AxiomInstCo _ _ cs) = go_co_s cs - go_co (UnivCo p _ ty ty') = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty' - go_co (SymCo co) = go_co co - go_co (TransCo co co') = go_co co `plusNameEnv` go_co co' - go_co (NthCo _ co) = go_co co - go_co (LRCo _ co) = go_co co - go_co (InstCo co co') = go_co co `plusNameEnv` go_co co' - go_co (CoherenceCo co co') = go_co co `plusNameEnv` go_co co' - go_co (KindCo co) = go_co co - go_co (SubCo co) = go_co co - go_co (AxiomRuleCo _ cs) = go_co_s cs - - go_prov UnsafeCoerceProv = emptyNameEnv - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyNameEnv - go_prov (HoleProv _) = emptyNameEnv - - go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc - | otherwise = emptyNameEnv - go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys - go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos - --- | A monad for type synonym cycle checking, which keeps --- track of the TyCons which are known to be acyclic, or --- a failure message reporting that a cycle was found. -newtype SynCycleM a = SynCycleM { - runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) } - -type SynCycleState = NameSet - -instance Functor SynCycleM where - fmap = liftM - -instance Applicative SynCycleM where - pure x = SynCycleM $ \state -> Right (x, state) - (<*>) = ap - -instance Monad SynCycleM where - m >>= f = SynCycleM $ \state -> - case runSynCycleM m state of - Right (x, state') -> - runSynCycleM (f x) state' - Left err -> Left err - -failSynCycleM :: SrcSpan -> SDoc -> SynCycleM () -failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err) - --- | Test if a 'Name' is acyclic, short-circuiting if we've --- seen it already. -checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM () -checkNameIsAcyclic n m = SynCycleM $ \s -> - if n `elemNameSet` s - then Right ((), s) -- short circuit - else case runSynCycleM m s of - Right ((), s') -> Right ((), extendNameSet s' n) - Left err -> Left err - --- | Checks if any of the passed in 'TyCon's have cycles. --- Takes the 'UnitId' of the home package (as we can avoid --- checking those TyCons: cycles never go through foreign packages) and --- the corresponding @LTyClDecl Name@ for each 'TyCon', so we --- can give better error messages. -checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl Name] -> TcM () -checkSynCycles this_uid tcs tyclds = do - case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of - Left (loc, err) -> setSrcSpan loc $ failWithTc err - Right _ -> return () - where - -- Try our best to print the LTyClDecl for locally defined things - lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds) - - -- Short circuit if we've already seen this Name and concluded - -- it was acyclic. - go :: NameSet -> [TyCon] -> TyCon -> SynCycleM () - go so_far seen_tcs tc = - checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc - - -- Expand type synonyms, complaining if you find the same - -- type synonym a second time. - go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM () - go' so_far seen_tcs tc - | n `elemNameSet` so_far - = failSynCycleM (getSrcSpan (head seen_tcs)) $ - sep [ text "Cycle in type synonym declarations:" - , nest 2 (vcat (map ppr_decl seen_tcs)) ] - -- Optimization: we don't allow cycles through external packages, - -- so once we find a non-local name we are guaranteed to not - -- have a cycle. - -- - -- This won't hold once we get recursive packages with Backpack, - -- but for now it's fine. - | not (isHoleModule mod || - moduleUnitId mod == this_uid || - isInteractiveModule mod) - = return () - | Just ty <- synTyConRhs_maybe tc = - go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty - | otherwise = return () - where - n = tyConName tc - mod = nameModule n - ppr_decl tc = - case lookupNameEnv lcl_decls n of - Just (L loc decl) -> ppr loc <> colon <+> ppr decl - Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n <+> text "from external module" - where - n = tyConName tc - - go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM () - go_ty so_far seen_tcs ty = - mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty) - -{- Note [Superclass cycle check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The superclass cycle check for C decides if we can statically -guarantee that expanding C's superclass cycles transitively is -guaranteed to terminate. This is a Haskell98 requirement, -but one that we lift with -XUndecidableSuperClasses. - -The worry is that a superclass cycle could make the type checker loop. -More precisely, with a constraint (Given or Wanted) - C ty1 .. tyn -one approach is to instantiate all of C's superclasses, transitively. -We can only do so if that set is finite. - -This potential loop occurs only through superclasses. This, for -example, is fine - class C a where - op :: C b => a -> b -> b -even though C's full definition uses C. - -Making the check static also makes it conservative. Eg - type family F a - class F a => C a -Here an instance of (F a) might mention C: - type instance F [a] = C a -and now we'd have a loop. - -The static check works like this, starting with C - * Look at C's superclass predicates - * If any is a type-function application, - or is headed by a type variable, fail - * If any has C at the head, fail - * If any has a type class D at the head, - make the same test with D - -A tricky point is: what if there is a type variable at the head? -Consider this: - class f (C f) => C f - class c => Id c -and now expand superclasses for constraint (C Id): - C Id - --> Id (C Id) - --> C Id - --> .... -Each step expands superclasses one layer, and clearly does not terminate. --} - -checkClassCycles :: Class -> Maybe SDoc --- Nothing <=> ok --- Just err <=> possible cycle error -checkClassCycles cls - = do { (definite_cycle, err) <- go (unitNameSet (getName cls)) - cls (mkTyVarTys (classTyVars cls)) - ; let herald | definite_cycle = text "Superclass cycle for" - | otherwise = text "Potential superclass cycle for" - ; return (vcat [ herald <+> quotes (ppr cls) - , nest 2 err, hint]) } - where - hint = text "Use UndecidableSuperClasses to accept this" - - -- Expand superclasses starting with (C a b), complaining - -- if you find the same class a second time, or a type function - -- or predicate headed by a type variable - -- - -- NB: this code duplicates TcType.transSuperClasses, but - -- with more error message generation clobber - -- Make sure the two stay in sync. - go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) - go so_far cls tys = firstJusts $ - map (go_pred so_far) $ - immSuperClasses cls tys - - go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc) - -- Nothing <=> ok - -- Just (True, err) <=> definite cycle - -- Just (False, err) <=> possible cycle - go_pred so_far pred -- NB: tcSplitTyConApp looks through synonyms - | Just (tc, tys) <- tcSplitTyConApp_maybe pred - = go_tc so_far pred tc tys - | hasTyVarHead pred - = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:") - 2 (quotes (ppr pred))) - | otherwise - = Nothing - - go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc) - go_tc so_far pred tc tys - | isFamilyTyCon tc - = Just (False, hang (text "one of whose superclass constraints is headed by a type family:") - 2 (quotes (ppr pred))) - | Just cls <- tyConClass_maybe tc - = go_cls so_far cls tys - | otherwise -- Equality predicate, for example - = Nothing - - go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) - go_cls so_far cls tys - | cls_nm `elemNameSet` so_far - = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls)) - | isCTupleClass cls - = go so_far cls tys - | otherwise - = do { (b,err) <- go (so_far `extendNameSet` cls_nm) cls tys - ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls) - $$ err) } - where - cls_nm = getName cls - -{- -************************************************************************ -* * - Role inference -* * -************************************************************************ - -Note [Role inference] -~~~~~~~~~~~~~~~~~~~~~ -The role inference algorithm datatype definitions to infer the roles on the -parameters. Although these roles are stored in the tycons, we can perform this -algorithm on the built tycons, as long as we don't peek at an as-yet-unknown -roles field! Ah, the magic of laziness. - -First, we choose appropriate initial roles. For families and classes, roles -(including initial roles) are N. For datatypes, we start with the role in the -role annotation (if any), or otherwise use Phantom. This is done in -initialRoleEnv1. - -The function irGroup then propagates role information until it reaches a -fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a -monad RoleM, which is a combination reader and state monad. In its state are -the current RoleEnv, which gets updated by role propagation, and an update -bit, which we use to know whether or not we've reached the fixpoint. The -environment of RoleM contains the tycon whose parameters we are inferring, and -a VarEnv from parameters to their positions, so we can update the RoleEnv. -Between tycons, this reader information is missing; it is added by -addRoleInferenceInfo. - -There are two kinds of tycons to consider: algebraic ones (excluding classes) -and type synonyms. (Remember, families don't participate -- all their parameters -are N.) An algebraic tycon processes each of its datacons, in turn. Note that -a datacon's universally quantified parameters might be different from the parent -tycon's parameters, so we use the datacon's univ parameters in the mapping from -vars to positions. Note also that we don't want to infer roles for existentials -(they're all at N, too), so we put them in the set of local variables. As an -optimisation, we skip any tycons whose roles are already all Nominal, as there -nowhere else for them to go. For synonyms, we just analyse their right-hand sides. - -irType walks through a type, looking for uses of a variable of interest and -propagating role information. Because anything used under a phantom position -is at phantom and anything used under a nominal position is at nominal, the -irType function can assume that anything it sees is at representational. (The -other possibilities are pruned when they're encountered.) - -The rest of the code is just plumbing. - -How do we know that this algorithm is correct? It should meet the following -specification: - -Let Z be a role context -- a mapping from variables to roles. The following -rules define the property (Z |- t : r), where t is a type and r is a role: - -Z(a) = r' r' <= r -------------------------- RCVar -Z |- a : r - ----------- RCConst -Z |- T : r -- T is a type constructor - -Z |- t1 : r -Z |- t2 : N --------------- RCApp -Z |- t1 t2 : r - -forall i<=n. (r_i is R or N) implies Z |- t_i : r_i -roles(T) = r_1 .. r_n ----------------------------------------------------- RCDApp -Z |- T t_1 .. t_n : R - -Z, a:N |- t : r ----------------------- RCAll -Z |- forall a:k.t : r - - -We also have the following rules: - -For all datacon_i in type T, where a_1 .. a_n are universally quantified -and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p, -then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R, -then roles(T) = r_1 .. r_n - -roles(->) = R, R -roles(~#) = N, N - -With -dcore-lint on, the output of this algorithm is checked in checkValidRoles, -called from checkValidTycon. - -Note [Role-checking data constructor arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a where - MkT :: Eq b => F a -> (a->a) -> T (G a) - -Then we want to check the roles at which 'a' is used -in MkT's type. We want to work on the user-written type, -so we need to take into account - * the arguments: (F a) and (a->a) - * the context: C a b - * the result type: (G a) -- this is in the eq_spec - - -Note [Coercions in role inference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing -the kind of a type is totally irrelevant to the representation of that type. So, -we want to totally ignore coercions when doing role inference. This includes omitting -any type variables that appear in nominal positions but only within coercions. --} - -type RolesInfo = Name -> [Role] - -type RoleEnv = NameEnv [Role] -- from tycon names to roles - --- This, and any of the functions it calls, must *not* look at the roles --- field of a tycon we are inferring roles about! --- See Note [Role inference] -inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role] -inferRoles hsc_src annots tycons - = let role_env = initialRoleEnv hsc_src annots tycons - role_env' = irGroup role_env tycons in - \name -> case lookupNameEnv role_env' name of - Just roles -> roles - Nothing -> pprPanic "inferRoles" (ppr name) - -initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv -initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv . - map (initialRoleEnv1 hsc_src annots) - -initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role]) -initialRoleEnv1 hsc_src annots_env tc - | isFamilyTyCon tc = (name, map (const Nominal) bndrs) - | isAlgTyCon tc = (name, default_roles) - | isTypeSynonymTyCon tc = (name, default_roles) - | otherwise = pprPanic "initialRoleEnv1" (ppr tc) - where name = tyConName tc - bndrs = tyConBinders tc - argflags = map tyConBinderArgFlag bndrs - num_exps = count isVisibleArgFlag argflags - - -- if the number of annotations in the role annotation decl - -- is wrong, just ignore it. We check this in the validity check. - role_annots - = case lookupRoleAnnot annots_env name of - Just (L _ (RoleAnnotDecl _ annots)) - | annots `lengthIs` num_exps -> map unLoc annots - _ -> replicate num_exps Nothing - default_roles = build_default_roles argflags role_annots - - build_default_roles (argf : argfs) (m_annot : ras) - | isVisibleArgFlag argf - = (m_annot `orElse` default_role) : build_default_roles argfs ras - build_default_roles (_argf : argfs) ras - = Nominal : build_default_roles argfs ras - build_default_roles [] [] = [] - build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)" - (vcat [ppr tc, ppr role_annots]) - - default_role - | isClassTyCon tc = Nominal - -- Note [Default roles for abstract TyCons in hs-boot/hsig] - | HsBootFile <- hsc_src - , isAbstractTyCon tc = Representational - | HsigFile <- hsc_src - , isAbstractTyCon tc = Nominal - | otherwise = Phantom - --- Note [Default roles for abstract TyCons in hs-boot/hsig] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- What should the default role for an abstract TyCon be? --- --- Originally, we inferred phantom role for abstract TyCons --- in hs-boot files, because the type variables were never used. --- --- This was silly, because the role of the abstract TyCon --- was required to match the implementation, and the roles of --- data types are almost never phantom. Thus, in ticket #9204, --- the default was changed so be representational (the most common case). If --- the implementing data type was actually nominal, you'd get an easy --- to understand error, and add the role annotation yourself. --- --- Then Backpack was added, and with it we added role *subtyping* --- the matching judgment: if an abstract TyCon has a nominal --- parameter, it's OK to implement it with a representational --- parameter. But now, the representational default is not a good --- one, because you should *only* request representational if --- you're planning to do coercions. To be maximally flexible --- with what data types you will accept, you want the default --- for hsig files is nominal. We don't allow role subtyping --- with hs-boot files (it's good practice to give an exactly --- accurate role here, because any types that use the abstract --- type will propagate the role information.) - -irGroup :: RoleEnv -> [TyCon] -> RoleEnv -irGroup env tcs - = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in - if update - then irGroup env' tcs - else env' - -irTyCon :: TyCon -> RoleM () -irTyCon tc - | isAlgTyCon tc - = do { old_roles <- lookupRoles tc - ; unless (all (== Nominal) old_roles) $ -- also catches data families, - -- which don't want or need role inference - irTcTyVars tc $ - do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 - ; whenIsJust (tyConClass_maybe tc) irClass - ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }} - - | Just ty <- synTyConRhs_maybe tc - = irTcTyVars tc $ - irType emptyVarSet ty - - | otherwise - = return () - --- any type variable used in an associated type must be Nominal -irClass :: Class -> RoleM () -irClass cls - = mapM_ ir_at (classATs cls) - where - cls_tvs = classTyVars cls - cls_tv_set = mkVarSet cls_tvs - - ir_at at_tc - = mapM_ (updateRole Nominal) nvars - where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc - --- See Note [Role inference] -irDataCon :: DataCon -> RoleM () -irDataCon datacon - = setRoleInferenceVars univ_tvs $ - irExTyVars ex_tvs $ \ ex_var_set -> - mapM_ (irType ex_var_set) - (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys) - -- See Note [Role-checking data constructor arguments] - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig datacon - -irType :: VarSet -> Type -> RoleM () -irType = go - where - go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $ - updateRole Representational tv - go lcls (AppTy t1 t2) = go lcls t1 >> markNominal lcls t2 - go lcls (TyConApp tc tys) = do { roles <- lookupRolesX tc - ; zipWithM_ (go_app lcls) roles tys } - go lcls (ForAllTy tvb ty) = do { let tv = binderVar tvb - lcls' = extendVarSet lcls tv - ; markNominal lcls (tyVarKind tv) - ; go lcls' ty } - go lcls (FunTy arg res) = go lcls arg >> go lcls res - go _ (LitTy {}) = return () - -- See Note [Coercions in role inference] - go lcls (CastTy ty _) = go lcls ty - go _ (CoercionTy _) = return () - - go_app _ Phantom _ = return () -- nothing to do here - go_app lcls Nominal ty = markNominal lcls ty -- all vars below here are N - go_app lcls Representational ty = go lcls ty - -irTcTyVars :: TyCon -> RoleM a -> RoleM a -irTcTyVars tc thing - = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc) - where - go [] = thing - go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv) - ; addRoleInferenceVar tv $ go tvs } - -irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a -irExTyVars orig_tvs thing = go emptyVarSet orig_tvs - where - go lcls [] = thing lcls - go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv) - ; go (extendVarSet lcls tv) tvs } - -markNominal :: TyVarSet -- local variables - -> Type -> RoleM () -markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in - mapM_ (updateRole Nominal) nvars - where - -- get_ty_vars gets all the tyvars (no covars!) from a type *without* - -- recurring into coercions. Recall: coercions are totally ignored during - -- role inference. See [Coercions in role inference] - get_ty_vars :: Type -> FV - get_ty_vars (TyVarTy tv) = unitFV tv - get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 - get_ty_vars (FunTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 - get_ty_vars (TyConApp _ tys) = mapUnionFV get_ty_vars tys - get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty) - get_ty_vars (LitTy {}) = emptyFV - get_ty_vars (CastTy ty _) = get_ty_vars ty - get_ty_vars (CoercionTy _) = emptyFV - --- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps -lookupRolesX :: TyCon -> RoleM [Role] -lookupRolesX tc - = do { roles <- lookupRoles tc - ; return $ roles ++ repeat Nominal } - --- gets the roles either from the environment or the tycon -lookupRoles :: TyCon -> RoleM [Role] -lookupRoles tc - = do { env <- getRoleEnv - ; case lookupNameEnv env (tyConName tc) of - Just roles -> return roles - Nothing -> return $ tyConRoles tc } - --- tries to update a role; won't ever update a role "downwards" -updateRole :: Role -> TyVar -> RoleM () -updateRole role tv - = do { var_ns <- getVarNs - ; name <- getTyConName - ; case lookupVarEnv var_ns tv of - Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns) - Just n -> updateRoleEnv name n role } - --- the state in the RoleM monad -data RoleInferenceState = RIS { role_env :: RoleEnv - , update :: Bool } - --- the environment in the RoleM monad -type VarPositions = VarEnv Int - --- See [Role inference] -newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon - -> VarPositions - -> Int -- size of VarPositions - -> RoleInferenceState - -> (a, RoleInferenceState) } - -instance Functor RoleM where - fmap = liftM - -instance Applicative RoleM where - pure x = RM $ \_ _ _ state -> (x, state) - (<*>) = ap - -instance Monad RoleM where - a >>= f = RM $ \m_info vps nvps state -> - let (a', state') = unRM a m_info vps nvps state in - unRM (f a') m_info vps nvps state' - -runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool) -runRoleM env thing = (env', update) - where RIS { role_env = env', update = update } - = snd $ unRM thing Nothing emptyVarEnv 0 state - state = RIS { role_env = env - , update = False } - -setRoleInferenceTc :: Name -> RoleM a -> RoleM a -setRoleInferenceTc name thing = RM $ \m_name vps nvps state -> - ASSERT( isNothing m_name ) - ASSERT( isEmptyVarEnv vps ) - ASSERT( nvps == 0 ) - unRM thing (Just name) vps nvps state - -addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a -addRoleInferenceVar tv thing - = RM $ \m_name vps nvps state -> - ASSERT( isJust m_name ) - unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state - -setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a -setRoleInferenceVars tvs thing - = RM $ \m_name _vps _nvps state -> - ASSERT( isJust m_name ) - unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars") - state - -getRoleEnv :: RoleM RoleEnv -getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state) - -getVarNs :: RoleM VarPositions -getVarNs = RM $ \_ vps _ state -> (vps, state) - -getTyConName :: RoleM Name -getTyConName = RM $ \m_name _ _ state -> - case m_name of - Nothing -> panic "getTyConName" - Just name -> (name, state) - -updateRoleEnv :: Name -> Int -> Role -> RoleM () -updateRoleEnv name n role - = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((), - case lookupNameEnv role_env name of - Nothing -> pprPanic "updateRoleEnv" (ppr name) - Just roles -> let (before, old_role : after) = splitAt n roles in - if role `ltRole` old_role - then let roles' = before ++ role : after - role_env' = extendNameEnv role_env name roles' in - RIS { role_env = role_env', update = True } - else state ) - - -{- ********************************************************************* -* * - Building implicits -* * -********************************************************************* -} - -tcAddImplicits :: [TyCon] -> TcM TcGblEnv --- Given a [TyCon], add to the TcGblEnv --- * extend the TypeEnv with their implicitTyThings --- * extend the TypeEnv with any default method Ids --- * add bindings for record selectors --- * add bindings for type representations for the TyThings -tcAddImplicits tycons - = discardWarnings $ - tcExtendGlobalEnvImplicit implicit_things $ - tcExtendGlobalValEnv def_meth_ids $ - do { traceTc "tcAddImplicits" $ vcat - [ text "tycons" <+> ppr tycons - , text "implicits" <+> ppr implicit_things ] - ; tcRecSelBinds (mkRecSelBinds tycons) } - where - implicit_things = concatMap implicitTyConThings tycons - def_meth_ids = mkDefaultMethodIds tycons - -mkDefaultMethodIds :: [TyCon] -> [Id] --- We want to put the default-method Ids (both vanilla and generic) --- into the type environment so that they are found when we typecheck --- the filled-in default methods of each instance declaration --- See Note [Default method Ids and Template Haskell] -mkDefaultMethodIds tycons - = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec) - | tc <- tycons - , Just cls <- [tyConClass_maybe tc] - , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ] - -mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type --- Returns the top-level type of the default method -mkDefaultMethodType _ sel_id VanillaDM = idType sel_id -mkDefaultMethodType cls _ (GenericDM dm_ty) = mkSpecSigmaTy cls_tvs [pred] dm_ty - where - cls_tvs = classTyVars cls - pred = mkClassPred cls (mkTyVarTys cls_tvs) - -{- -************************************************************************ -* * - Building record selectors -* * -************************************************************************ --} - -{- -Note [Default method Ids and Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (Trac #4169): - class Numeric a where - fromIntegerNum :: a - fromIntegerNum = ... - - ast :: Q [Dec] - ast = [d| instance Numeric Int |] - -When we typecheck 'ast' we have done the first pass over the class decl -(in tcTyClDecls), but we have not yet typechecked the default-method -declarations (because they can mention value declarations). So we -must bring the default method Ids into scope first (so they can be seen -when typechecking the [d| .. |] quote, and typecheck them later. --} - -{- -************************************************************************ -* * - Building record selectors -* * -************************************************************************ --} - -mkRecSelBinds :: [TyCon] -> HsValBinds Name --- NB We produce *un-typechecked* bindings, rather like 'deriving' --- This makes life easier, because the later type checking will add --- all necessary type abstractions and applications -mkRecSelBinds tycons - = ValBindsOut binds sigs - where - (sigs, binds) = unzip rec_sels - rec_sels = map mkRecSelBind [ (tc,fld) - | tc <- tycons - , fld <- tyConFieldLabels tc ] - -mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, (RecFlag, LHsBinds Name)) -mkRecSelBind (tycon, fl) - = mkOneRecordSelector all_cons (RecSelData tycon) fl - where - all_cons = map RealDataCon (tyConDataCons tycon) - -mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel - -> (LSig Name, (RecFlag, LHsBinds Name)) -mkOneRecordSelector all_cons idDetails fl - = (L loc (IdSig sel_id), (NonRecursive, unitBag (L loc sel_bind))) - where - loc = getSrcSpan sel_name - lbl = flLabel fl - sel_name = flSelector fl - - sel_id = mkExportedLocalId rec_details sel_name sel_ty - rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty } - - -- Find a representative constructor, con1 - cons_w_field = conLikesWithFields all_cons [lbl] - con1 = ASSERT( not (null cons_w_field) ) head cons_w_field - - -- Selector type; Note [Polymorphic selectors] - field_ty = conLikeFieldType con1 lbl - data_tvs = tyCoVarsOfTypesWellScoped inst_tys - data_tv_set= mkVarSet data_tvs - is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set) - (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty - sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] - | otherwise = mkSpecForAllTys data_tvs $ - mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! - mkFunTy data_ty $ - mkSpecForAllTys field_tvs $ - mkPhiTy field_theta $ - -- req_theta is empty for normal DataCon - mkPhiTy req_theta $ - field_tau - - -- Make the binding: sel (C2 { fld = x }) = x - -- sel (C7 { fld = x }) = x - -- where cons_w_field = [C2,C7] - sel_bind = mkTopFunBind Generated sel_lname alts - where - alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname) - [] unit_rhs] - | otherwise = map mk_match cons_w_field ++ deflt - mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [L loc (mk_sel_pat con)] - (L loc (HsVar (L loc field_var))) - mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) - rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } - rec_field = noLoc (HsRecField - { hsRecFieldLbl - = L loc (FieldOcc (L loc $ mkVarUnqual lbl) sel_name) - , hsRecFieldArg = L loc (VarPat (L loc field_var)) - , hsRecPun = False }) - sel_lname = L loc sel_name - field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc - - -- Add catch-all default case unless the case is exhaustive - -- We do this explicitly so that we get a nice error message that - -- mentions this particular record selector - deflt | all dealt_with all_cons = [] - | otherwise = [mkSimpleMatch CaseAlt - [L loc (WildPat placeHolderType)] - (mkHsApp (L loc (HsVar - (L loc (getName rEC_SEL_ERROR_ID)))) - (L loc (HsLit msg_lit)))] - - -- Do not add a default case unless there are unmatched - -- constructors. We must take account of GADTs, else we - -- get overlap warning messages from the pattern-match checker - -- NB: we need to pass type args for the *representation* TyCon - -- to dataConCannotMatch, hence the calculation of inst_tys - -- This matters in data families - -- data instance T Int a where - -- A :: { fld :: Int } -> T Int Bool - -- B :: { fld :: Int } -> T Int Char - dealt_with :: ConLike -> Bool - dealt_with (PatSynCon _) = False -- We can't predict overlap - dealt_with con@(RealDataCon dc) = - con `elem` cons_w_field || dataConCannotMatch inst_tys dc - - (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1 - - eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) - inst_tys = substTyVars eq_subst univ_tvs - - unit_rhs = mkLHsTupleExpr [] - msg_lit = HsStringPrim NoSourceText (fastStringToByteString lbl) - -{- -Note [Polymorphic selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We take care to build the type of a polymorphic selector in the right -order, so that visible type application works. - - data Ord a => T a = MkT { field :: forall b. (Num a, Show b) => (a, b) } - -We want - - field :: forall a. Ord a => T a -> forall b. (Num a, Show b) => (a, b) - -Note [Naughty record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "naughty" field is one for which we can't define a record -selector, because an existential type variable would escape. For example: - data T = forall a. MkT { x,y::a } -We obviously can't define - x (MkT v _) = v -Nevertheless we *do* put a RecSelId into the type environment -so that if the user tries to use 'x' as a selector we can bleat -helpfully, rather than saying unhelpfully that 'x' is not in scope. -Hence the sel_naughty flag, to identify record selectors that don't really exist. - -In general, a field is "naughty" if its type mentions a type variable that -isn't in the result type of the constructor. Note that this *allows* -GADT record selectors (Note [GADT record selectors]) whose types may look -like sel :: T [a] -> a - -For naughty selectors we make a dummy binding - sel = () -so that the later type-check will add them to the environment, and they'll be -exported. The function is never called, because the typechecker spots the -sel_naughty field. - -Note [GADT record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For GADTs, we require that all constructors with a common field 'f' have the same -result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] -E.g. - data T where - T1 { f :: Maybe a } :: T [a] - T2 { f :: Maybe a, y :: b } :: T [a] - T3 :: T Int - -and now the selector takes that result type as its argument: - f :: forall a. T [a] -> Maybe a - -Details: the "real" types of T1,T2 are: - T1 :: forall r a. (r~[a]) => a -> T r - T2 :: forall r a b. (r~[a]) => a -> b -> T r - -So the selector loooks like this: - f :: forall a. T [a] -> Maybe a - f (a:*) (t:T [a]) - = case t of - T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) - T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) - T3 -> error "T3 does not have field f" - -Note the forall'd tyvars of the selector are just the free tyvars -of the result type; there may be other tyvars in the constructor's -type (e.g. 'b' in T2). - -Note the need for casts in the result! - -Note [Selector running example] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's OK to combine GADTs and type families. Here's a running example: - - data instance T [a] where - T1 { fld :: b } :: T [Maybe b] - -The representation type looks like this - data :R7T a where - T1 { fld :: b } :: :R7T (Maybe b) - -and there's coercion from the family type to the representation type - :CoR7T a :: T [a] ~ :R7T a - -The selector we want for fld looks like this: - - fld :: forall b. T [Maybe b] -> b - fld = /\b. \(d::T [Maybe b]). - case d `cast` :CoR7T (Maybe b) of - T1 (x::b) -> x - -The scrutinee of the case has type :R7T (Maybe b), which can be -gotten by appying the eq_spec to the univ_tvs of the data con. - --} diff --git a/typecheck/TcType.hs b/typecheck/TcType.hs deleted file mode 100644 --- a/typecheck/TcType.hs +++ /dev/null @@ -1,2580 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcType]{Types used in the typechecker} - -This module provides the Type interface for front-end parts of the -compiler. These parts - - * treat "source types" as opaque: - newtypes, and predicates are meaningful. - * look through usage types - -The "tc" prefix is for "TypeChecker", because the type checker -is the principal client. --} - -{-# LANGUAGE CPP, MultiWayIf, FlexibleContexts #-} - -module TcType ( - -------------------------------- - -- Types - TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, - TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, - TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcTyCon, - - ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType, - - SyntaxOpType(..), synKnownType, mkSynFunTys, - - -- TcLevel - TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, - strictlyDeeperThan, sameDepthAs, fmvTcLevel, - tcTypeLevel, tcTyVarLevel, maxTcLevel, - - -------------------------------- - -- MetaDetails - UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe, - TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, - MetaDetails(Flexi, Indirect), MetaInfo(..), - isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, - isSigTyVar, isOverlappableTyVar, isTyConableTyVar, - isFskTyVar, isFmvTyVar, isFlattenTyVar, - isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo, - isFlexi, isIndirect, isRuntimeUnkSkol, - metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, - isTouchableMetaTyVar, isTouchableOrFmv, - isFloatedTouchableMetaTyVar, - - -------------------------------- - -- Builders - mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, - mkNakedTyConApp, mkNakedAppTys, mkNakedAppTy, - mkNakedCastTy, - - -------------------------------- - -- Splitters - -- These are important because they do not look through newtypes - getTyVar, - tcSplitForAllTy_maybe, - tcSplitForAllTys, tcSplitPiTys, tcSplitForAllTyVarBndrs, - tcSplitPhiTy, tcSplitPredFunTy_maybe, - tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN, - tcSplitFunTysN, - tcSplitTyConApp, tcSplitTyConApp_maybe, - tcRepSplitTyConApp_maybe, tcRepSplitTyConApp_maybe', - tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, - tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe, - tcGetTyVar_maybe, tcGetTyVar, nextRole, - tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe, - - --------------------------------- - -- Predicates. - -- Again, newtypes are opaque - eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, - pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, - isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, - isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, - isIntegerTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred, - isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, - isPredTy, isTyVarClassPred, isTyVarExposed, isInsolubleOccursCheck, - checkValidClsArgs, hasTyVarHead, - isRigidEqPred, isRigidTy, - - --------------------------------- - -- Misc type manipulators - - deNoteType, - orphNamesOfType, orphNamesOfCo, - orphNamesOfTypes, orphNamesOfCoCon, - getDFunTyKey, - evVarPred_maybe, evVarPred, - - --------------------------------- - -- Predicate types - mkMinimalBySCs, transSuperClasses, - pickQuantifiablePreds, pickCapturedPreds, - immSuperClasses, - isImprovementPred, - - -- * Finding type instances - tcTyFamInsts, isTyFamFree, - - -- * Finding "exact" (non-dead) type variables - exactTyCoVarsOfType, exactTyCoVarsOfTypes, - candidateQTyVarsOfType, candidateQTyVarsOfTypes, CandidatesQTvs(..), - anyRewritableTyVar, - - -- * Extracting bound variables - allBoundVariables, allBoundVariabless, - - --------------------------------- - -- Foreign import and export - isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool - isFFIImportResultTy, -- :: DynFlags -> Type -> Bool - isFFIExportResultTy, -- :: Type -> Bool - isFFIExternalTy, -- :: Type -> Bool - isFFIDynTy, -- :: Type -> Type -> Bool - isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool - isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool - isFFILabelTy, -- :: Type -> Bool - isFFITy, -- :: Type -> Bool - isFunPtrTy, -- :: Type -> Bool - tcSplitIOType_maybe, -- :: Type -> Maybe Type - - -------------------------------- - -- Rexported from Kind - Kind, typeKind, - liftedTypeKind, - constraintKind, - isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues, - - -------------------------------- - -- Rexported from Type - Type, PredType, ThetaType, TyBinder, ArgFlag(..), - - mkForAllTy, mkForAllTys, mkInvForAllTys, mkSpecForAllTys, mkInvForAllTy, - mkFunTy, mkFunTys, - mkTyConApp, mkAppTy, mkAppTys, - mkTyConTy, mkTyVarTy, - mkTyVarTys, - - isClassPred, isEqPred, isNomEqPred, isIPPred, - mkClassPred, - isDictLikeTy, - tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, - isRuntimeRepVar, isKindLevPoly, - isVisibleBinder, isInvisibleBinder, - - -- Type substitutions - TCvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTCvSubst, - zipTvSubst, - mkTvSubstPrs, notElemTCvSubst, unionTCvSubst, - getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope, - extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope, - Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, - Type.extendTvSubst, - isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, - Type.substTy, substTys, substTyWith, substTyWithCoVars, - substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTheta, - - isUnliftedType, -- Source types are always lifted - isUnboxedTupleType, -- Ditto - isPrimitiveType, - - tcView, coreView, - - tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, - tyCoFVsOfType, tyCoFVsOfTypes, - tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet, - tyCoVarsOfTypeList, tyCoVarsOfTypesList, - noFreeVarsOfType, - - -------------------------------- - -- Transforming Types to TcTypes - toTcType, -- :: Type -> TcType - toTcTypeBag, -- :: Bag EvVar -> Bag EvVar - - pprKind, pprParendKind, pprSigmaType, - pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory, - pprTheta, pprThetaArrowTy, pprClassPred, - pprTvBndr, pprTvBndrs, - - TypeSize, sizeType, sizeTypes, toposortTyVars - - ) where - -#include "HsVersions.h" - --- friends: -import Kind -import TyCoRep -import Class -import Var -import ForeignCall -import VarSet -import Coercion -import Type -import RepType -import TyCon - --- others: -import DynFlags -import CoreFVs -import Name -- hiding (varName) - -- We use this to make dictionaries for type literals. - -- Perhaps there's a better way to do this? -import NameSet -import VarEnv -import PrelNames -import TysWiredIn( coercibleClass, unitTyCon, unitTyConKey - , listTyCon, constraintKind ) -import BasicTypes -import Util -import Bag -import Maybes -import Outputable -import FastString -import ErrUtils( Validity(..), MsgDoc, isValid ) -import FV -import qualified GHC.LanguageExtensions as LangExt - -import Data.IORef -import Data.Functor.Identity - -{- -************************************************************************ -* * - Types -* * -************************************************************************ - -The type checker divides the generic Type world into the -following more structured beasts: - -sigma ::= forall tyvars. phi - -- A sigma type is a qualified type - -- - -- Note that even if 'tyvars' is empty, theta - -- may not be: e.g. (?x::Int) => Int - - -- Note that 'sigma' is in prenex form: - -- all the foralls are at the front. - -- A 'phi' type has no foralls to the right of - -- an arrow - -phi :: theta => rho - -rho ::= sigma -> rho - | tau - --- A 'tau' type has no quantification anywhere --- Note that the args of a type constructor must be taus -tau ::= tyvar - | tycon tau_1 .. tau_n - | tau_1 tau_2 - | tau_1 -> tau_2 - --- In all cases, a (saturated) type synonym application is legal, --- provided it expands to the required form. - -Note [TcTyVars in the typechecker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker uses a lot of type variables with special properties, -notably being a unification variable with a mutable reference. These -use the 'TcTyVar' variant of Var.Var. - -However, the type checker and constraint solver can encounter type -variables that use the 'TyVar' variant of Var.Var, for a couple of -reasons: - - - When unifying or flattening under (forall a. ty) - - - When typechecking a class decl, say - class C (a :: k) where - foo :: T a -> Int - We have first kind-check the header; fix k and (a:k) to be - TyVars, bring 'k' and 'a' into scope, and kind check the - signature for 'foo'. In doing so we call solveEqualities to - solve any kind equalities in foo's signature. So the solver - may see free occurrences of 'k'. - -It's convenient to simply treat these TyVars as skolem constants, -which of course they are. So - -* Var.tcTyVarDetails succeeds on a TyVar, returning - vanillaSkolemTv, as well as on a TcTyVar. - -* tcIsTcTyVar returns True for both TyVar and TcTyVar variants - of Var.Var. The "tc" prefix means "a type variable that can be - encountered by the typechecker". - -This is a bit of a change from an earlier era when we remoselessly -insisted on real TcTyVars in the type checker. But that seems -unnecessary (for skolems, TyVars are fine) and it's now very hard -to guarantee, with the advent of kind equalities. - -Note [Coercion variables in free variable lists] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several places in the GHC codebase where functions like -tyCoVarsOfType, tyCoVarsOfCt, et al. are used to compute the free type -variables of a type. The "Co" part of these functions' names shouldn't be -dismissed, as it is entirely possible that they will include coercion variables -in addition to type variables! As a result, there are some places in TcType -where we must take care to check that a variable is a _type_ variable (using -isTyVar) before calling tcTyVarDetails--a partial function that is not defined -for coercion variables--on the variable. Failing to do so led to -GHC Trac #12785. --} - --- See Note [TcTyVars in the typechecker] -type TcTyVar = TyVar -- Used only during type inference -type TcCoVar = CoVar -- Used only during type inference -type TcType = Type -- A TcType can have mutable type variables -type TcTyCoVar = Var -- Either a TcTyVar or a CoVar - -- Invariant on ForAllTy in TcTypes: - -- forall a. T - -- a cannot occur inside a MutTyVar in T; that is, - -- T is "flattened" before quantifying over a - -type TcTyVarBinder = TyVarBinder -type TcTyCon = TyCon -- these can be the TcTyCon constructor - --- These types do not have boxy type variables in them -type TcPredType = PredType -type TcThetaType = ThetaType -type TcSigmaType = TcType -type TcRhoType = TcType -- Note [TcRhoType] -type TcTauType = TcType -type TcKind = Kind -type TcTyVarSet = TyVarSet -type TcTyCoVarSet = TyCoVarSet -type TcDTyVarSet = DTyVarSet -type TcDTyCoVarSet = DTyCoVarSet - - -{- ********************************************************************* -* * - ExpType: an "expected type" in the type checker -* * -********************************************************************* -} - --- | An expected type to check against during type-checking. --- See Note [ExpType] in TcMType, where you'll also find manipulators. -data ExpType = Check TcType - | Infer !InferResult - -data InferResult - = IR { ir_uniq :: Unique -- For debugging only - , ir_lvl :: TcLevel -- See Note [TcLevel of ExpType] in TcMType - , ir_inst :: Bool -- True <=> deeply instantiate before returning - -- i.e. return a RhoType - -- False <=> do not instantiate before returning - -- i.e. return a SigmaType - , ir_ref :: IORef (Maybe TcType) } - -- The type that fills in this hole should be a Type, - -- that is, its kind should be (TYPE rr) for some rr - -type ExpSigmaType = ExpType -type ExpRhoType = ExpType - -instance Outputable ExpType where - ppr (Check ty) = text "Check" <> braces (ppr ty) - ppr (Infer ir) = ppr ir - -instance Outputable InferResult where - ppr (IR { ir_uniq = u, ir_lvl = lvl - , ir_inst = inst }) - = text "Infer" <> braces (ppr u <> comma <> ppr lvl <+> ppr inst) - --- | Make an 'ExpType' suitable for checking. -mkCheckExpType :: TcType -> ExpType -mkCheckExpType = Check - - -{- ********************************************************************* -* * - SyntaxOpType -* * -********************************************************************* -} - --- | What to expect for an argument to a rebindable-syntax operator. --- Quite like 'Type', but allows for holes to be filled in by tcSyntaxOp. --- The callback called from tcSyntaxOp gets a list of types; the meaning --- of these types is determined by a left-to-right depth-first traversal --- of the 'SyntaxOpType' tree. So if you pass in --- --- > SynAny `SynFun` (SynList `SynFun` SynType Int) `SynFun` SynAny --- --- you'll get three types back: one for the first 'SynAny', the /element/ --- type of the list, and one for the last 'SynAny'. You don't get anything --- for the 'SynType', because you've said positively that it should be an --- Int, and so it shall be. --- --- This is defined here to avoid defining it in TcExpr.hs-boot. -data SyntaxOpType - = SynAny -- ^ Any type - | SynRho -- ^ A rho type, deeply skolemised or instantiated as appropriate - | SynList -- ^ A list type. You get back the element type of the list - | SynFun SyntaxOpType SyntaxOpType - -- ^ A function. - | SynType ExpType -- ^ A known type. -infixr 0 `SynFun` - --- | Like 'SynType' but accepts a regular TcType -synKnownType :: TcType -> SyntaxOpType -synKnownType = SynType . mkCheckExpType - --- | Like 'mkFunTys' but for 'SyntaxOpType' -mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType -mkSynFunTys arg_tys res_ty = foldr SynFun (SynType res_ty) arg_tys - - -{- -Note [TcRhoType] -~~~~~~~~~~~~~~~~ -A TcRhoType has no foralls or contexts at the top, or to the right of an arrow - YES (forall a. a->a) -> Int - NO forall a. a -> Int - NO Eq a => a -> a - NO Int -> forall a. a -> Int - - -************************************************************************ -* * - TyVarDetails, MetaDetails, MetaInfo -* * -************************************************************************ - -TyVarDetails gives extra info about type variables, used during type -checking. It's attached to mutable type variables only. -It's knot-tied back to Var.hs. There is no reason in principle -why Var.hs shouldn't actually have the definition, but it "belongs" here. - -Note [Signature skolems] -~~~~~~~~~~~~~~~~~~~~~~~~ -A SigTv is a specialised variant of TauTv, with the following invarints: - - * A SigTv can be unified only with a TyVar, - not with any other type - - * Its MetaDetails, if filled in, will always be another SigTv - or a SkolemTv - -SigTvs are only distinguished to improve error messages. -Consider this - - f :: forall a. [a] -> Int - f (x::b : xs) = 3 - -Here 'b' is a lexically scoped type variable, but it turns out to be -the same as the skolem 'a'. So we make them both SigTvs, which can unify -with each other. - -Similarly consider - data T (a:k1) = MkT (S a) - data S (b:k2) = MkS (T b) -When doing kind inference on {S,T} we don't want *skolems* for k1,k2, -because they end up unifying; we want those SigTvs again. - -SigTvs are used *only* for pattern type signatures. - -Note [TyVars and TcTyVars during type checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Var type has constructors TyVar and TcTyVar. They are used -as follows: - -* TcTyVar: used /only/ during type checking. Should never appear - afterwards. May contain a mutable field, in the MetaTv case. - -* TyVar: is never seen by the constraint solver, except locally - inside a type like (forall a. [a] ->[a]), where 'a' is a TyVar. - We instantiate these with TcTyVars before exposing the type - to the constraint solver. - -I have swithered about the latter invariant, excluding TyVars from the -constraint solver. It's not strictly essential, and indeed -(historically but still there) Var.tcTyVarDetails returns -vanillaSkolemTv for a TyVar. - -But ultimately I want to seeparate Type from TcType, and in that case -we would need to enforce the separation. --} - --- A TyVarDetails is inside a TyVar --- See Note [TyVars and TcTyVars] -data TcTyVarDetails - = SkolemTv -- A skolem - TcLevel -- Level of the implication that binds it - Bool -- True <=> this skolem type variable can be overlapped - -- when looking up instances - -- See Note [Binding when looking up instances] in InstEnv - - | FlatSkol -- A flatten-skolem. It stands for the TcType, and zonking - TcType -- will replace it by that type. - -- See Note [The flattening story] in TcFlatten - - | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi - -- interactive context - - | MetaTv { mtv_info :: MetaInfo - , mtv_ref :: IORef MetaDetails - , mtv_tclvl :: TcLevel } -- See Note [TcLevel and untouchable type variables] - -vanillaSkolemTv, superSkolemTv :: TcTyVarDetails --- See Note [Binding when looking up instances] in InstEnv -vanillaSkolemTv = SkolemTv (pushTcLevel topTcLevel) False -- Might be instantiated -superSkolemTv = SkolemTv (pushTcLevel topTcLevel) True -- Treat this as a completely distinct type - ------------------------------ -data MetaDetails - = Flexi -- Flexi type variables unify to become Indirects - | Indirect TcType - -data MetaInfo - = TauTv -- This MetaTv is an ordinary unification variable - -- A TauTv is always filled in with a tau-type, which - -- never contains any ForAlls. - - | SigTv -- A variant of TauTv, except that it should not be - -- unified with a type, only with a type variable - -- See Note [Signature skolems] - - | FlatMetaTv -- A flatten meta-tyvar - -- It is a meta-tyvar, but it is always untouchable, with level 0 - -- See Note [The flattening story] in TcFlatten - -instance Outputable MetaDetails where - ppr Flexi = text "Flexi" - ppr (Indirect ty) = text "Indirect" <+> ppr ty - -pprTcTyVarDetails :: TcTyVarDetails -> SDoc --- For debugging -pprTcTyVarDetails (RuntimeUnk {}) = text "rt" -pprTcTyVarDetails (FlatSkol {}) = text "fsk" -pprTcTyVarDetails (SkolemTv lvl True) = text "ssk" <> colon <> ppr lvl -pprTcTyVarDetails (SkolemTv lvl False) = text "sk" <> colon <> ppr lvl -pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) - = pp_info <> colon <> ppr tclvl - where - pp_info = case info of - TauTv -> text "tau" - SigTv -> text "sig" - FlatMetaTv -> text "fuv" - - -{- ********************************************************************* -* * - UserTypeCtxt -* * -********************************************************************* -} - -------------------------------------- --- UserTypeCtxt describes the origin of the polymorphic type --- in the places where we need to an expression has that type - -data UserTypeCtxt - = FunSigCtxt -- Function type signature, when checking the type - -- Also used for types in SPECIALISE pragmas - Name -- Name of the function - Bool -- True <=> report redundant constraints - -- This is usually True, but False for - -- * Record selectors (not important here) - -- * Class and instance methods. Here - -- the code may legitimately be more - -- polymorphic than the signature - -- generated from the class - -- declaration - - | InfSigCtxt Name -- Inferred type for function - | ExprSigCtxt -- Expression type signature - | TypeAppCtxt -- Visible type application - | ConArgCtxt Name -- Data constructor argument - | TySynCtxt Name -- RHS of a type synonym decl - | PatSynCtxt Name -- Type sig for a pattern synonym - | PatSigCtxt -- Type sig in pattern - -- eg f (x::t) = ... - -- or (x::t, y) = e - | RuleSigCtxt Name -- LHS of a RULE forall - -- RULE "foo" forall (x :: a -> a). f (Just x) = ... - | ResSigCtxt -- Result type sig - -- f x :: t = .... - | ForSigCtxt Name -- Foreign import or export signature - | DefaultDeclCtxt -- Types in a default declaration - | InstDeclCtxt -- An instance declaration - | SpecInstCtxt -- SPECIALISE instance pragma - | ThBrackCtxt -- Template Haskell type brackets [t| ... |] - | GenSigCtxt -- Higher-rank or impredicative situations - -- e.g. (f e) where f has a higher-rank type - -- We might want to elaborate this - | GhciCtxt -- GHCi command :kind - - | ClassSCCtxt Name -- Superclasses of a class - | SigmaCtxt -- Theta part of a normal for-all type - -- f :: => a -> a - | DataTyCtxt Name -- The "stupid theta" part of a data decl - -- data => T a = MkT a - -{- --- Notes re TySynCtxt --- We allow type synonyms that aren't types; e.g. type List = [] --- --- If the RHS mentions tyvars that aren't in scope, we'll --- quantify over them: --- e.g. type T = a->a --- will become type T = forall a. a->a --- --- With gla-exts that's right, but for H98 we should complain. --} - - -pprUserTypeCtxt :: UserTypeCtxt -> SDoc -pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) -pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) -pprUserTypeCtxt (RuleSigCtxt n) = text "a RULE for" <+> quotes (ppr n) -pprUserTypeCtxt ExprSigCtxt = text "an expression type signature" -pprUserTypeCtxt TypeAppCtxt = text "a type argument" -pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) -pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) -pprUserTypeCtxt ThBrackCtxt = text "a Template Haskell quotation [t|...|]" -pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" -pprUserTypeCtxt ResSigCtxt = text "a result type signature" -pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) -pprUserTypeCtxt DefaultDeclCtxt = text "a type in a `default' declaration" -pprUserTypeCtxt InstDeclCtxt = text "an instance declaration" -pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" -pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" -pprUserTypeCtxt GhciCtxt = text "a type in a GHCi command" -pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) -pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" -pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) -pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) - -isSigMaybe :: UserTypeCtxt -> Maybe Name -isSigMaybe (FunSigCtxt n _) = Just n -isSigMaybe (ConArgCtxt n) = Just n -isSigMaybe (ForSigCtxt n) = Just n -isSigMaybe (PatSynCtxt n) = Just n -isSigMaybe _ = Nothing - - -{- ********************************************************************* -* * - Untoucable type variables -* * -********************************************************************* -} - -newtype TcLevel = TcLevel Int deriving( Eq, Ord ) - -- See Note [TcLevel and untouchable type variables] for what this Int is - -- See also Note [TcLevel assignment] - -{- -Note [TcLevel and untouchable type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Each unification variable (MetaTv) - and each Implication - has a level number (of type TcLevel) - -* INVARIANTS. In a tree of Implications, - - (ImplicInv) The level number of an Implication is - STRICTLY GREATER THAN that of its parent - - (MetaTvInv) The level number of a unification variable is - LESS THAN OR EQUAL TO that of its parent - implication - -* A unification variable is *touchable* if its level number - is EQUAL TO that of its immediate parent implication. - -* INVARIANT - (GivenInv) The free variables of the ic_given of an - implication are all untouchable; ie their level - numbers are LESS THAN the ic_tclvl of the implication - -Note [Skolem escape prevention] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only unify touchable unification variables. Because of -(MetaTvInv), there can be no occurrences of the variable further out, -so the unification can't cause the skolems to escape. Example: - data T = forall a. MkT a (a->Int) - f x (MkT v f) = length [v,x] -We decide (x::alpha), and generate an implication like - [1]forall a. (a ~ alpha[0]) -But we must not unify alpha:=a, because the skolem would escape. - -For the cases where we DO want to unify, we rely on floating the -equality. Example (with same T) - g x (MkT v f) = x && True -We decide (x::alpha), and generate an implication like - [1]forall a. (Bool ~ alpha[0]) -We do NOT unify directly, bur rather float out (if the constraint -does not mention 'a') to get - (Bool ~ alpha[0]) /\ [1]forall a.() -and NOW we can unify alpha. - -The same idea of only unifying touchables solves another problem. -Suppose we had - (F Int ~ uf[0]) /\ [1](forall a. C a => F Int ~ beta[1]) -In this example, beta is touchable inside the implication. The -first solveSimpleWanteds step leaves 'uf' un-unified. Then we move inside -the implication where a new constraint - uf ~ beta -emerges. If we (wrongly) spontaneously solved it to get uf := beta, -the whole implication disappears but when we pop out again we are left with -(F Int ~ uf) which will be unified by our final zonking stage and -uf will get unified *once more* to (F Int). - -Note [TcLevel assignment] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We arrange the TcLevels like this - - 0 Level for flatten meta-vars - 1 Top level - 2 First-level implication constraints - 3 Second-level implication constraints - ...etc... - -The flatten meta-vars are all at level 0, just to make them untouchable. --} - -maxTcLevel :: TcLevel -> TcLevel -> TcLevel -maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b) - -fmvTcLevel :: TcLevel -> TcLevel --- See Note [TcLevel assignment] -fmvTcLevel _ = TcLevel 0 - -topTcLevel :: TcLevel --- See Note [TcLevel assignment] -topTcLevel = TcLevel 1 -- 1 = outermost level - -isTopTcLevel :: TcLevel -> Bool -isTopTcLevel (TcLevel 1) = True -isTopTcLevel _ = False - -pushTcLevel :: TcLevel -> TcLevel --- See Note [TcLevel assignment] -pushTcLevel (TcLevel us) = TcLevel (us + 1) - -strictlyDeeperThan :: TcLevel -> TcLevel -> Bool -strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl) - = tv_tclvl > ctxt_tclvl - -sameDepthAs :: TcLevel -> TcLevel -> Bool -sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) - = ctxt_tclvl == tv_tclvl -- NB: invariant ctxt_tclvl >= tv_tclvl - -- So <= would be equivalent - -checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool --- Checks (MetaTvInv) from Note [TcLevel and untouchable type variables] -checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) - = ctxt_tclvl >= tv_tclvl - -tcTyVarLevel :: TcTyVar -> TcLevel -tcTyVarLevel tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl - SkolemTv tv_lvl _ -> tv_lvl - FlatSkol ty -> tcTypeLevel ty - RuntimeUnk -> topTcLevel - -tcTypeLevel :: TcType -> TcLevel --- Max level of any free var of the type -tcTypeLevel ty - = foldDVarSet add topTcLevel (tyCoVarsOfTypeDSet ty) - where - add v lvl - | isTcTyVar v = lvl `maxTcLevel` tcTyVarLevel v - | otherwise = lvl - -instance Outputable TcLevel where - ppr (TcLevel us) = ppr us - -{- ********************************************************************* -* * - Finding type family instances -* * -************************************************************************ --} - --- | Finds outermost type-family applications occuring in a type, --- after expanding synonyms. In the list (F, tys) that is returned --- we guarantee that tys matches F's arity. For example, given --- type family F a :: * -> * (arity 1) --- calling tcTyFamInsts on (Maybe (F Int Bool) will return --- (F, [Int]), not (F, [Int,Bool]) --- --- This is important for its use in deciding termination of type --- instances (see Trac #11581). E.g. --- type instance G [Int] = ...(F Int )... --- we don't need to take into account when asking if --- the calls on the RHS are smaller than the LHS -tcTyFamInsts :: Type -> [(TyCon, [Type])] -tcTyFamInsts ty - | Just exp_ty <- tcView ty = tcTyFamInsts exp_ty -tcTyFamInsts (TyVarTy _) = [] -tcTyFamInsts (TyConApp tc tys) - | isTypeFamilyTyCon tc = [(tc, take (tyConArity tc) tys)] - | otherwise = concat (map tcTyFamInsts tys) -tcTyFamInsts (LitTy {}) = [] -tcTyFamInsts (ForAllTy bndr ty) = tcTyFamInsts (binderKind bndr) - ++ tcTyFamInsts ty -tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 -tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 -tcTyFamInsts (CastTy ty _) = tcTyFamInsts ty -tcTyFamInsts (CoercionTy _) = [] -- don't count tyfams in coercions, - -- as they never get normalized, anyway - -isTyFamFree :: Type -> Bool --- ^ Check that a type does not contain any type family applications. -isTyFamFree = null . tcTyFamInsts - -{- -************************************************************************ -* * - The "exact" free variables of a type -* * -************************************************************************ - -Note [Silly type synonym] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type T a = Int -What are the free tyvars of (T x)? Empty, of course! -Here's the example that Ralf Laemmel showed me: - foo :: (forall a. C u a -> C u a) -> u - mappend :: Monoid u => u -> u -> u - - bar :: Monoid u => u - bar = foo (\t -> t `mappend` t) -We have to generalise at the arg to f, and we don't -want to capture the constraint (Monad (C u a)) because -it appears to mention a. Pretty silly, but it was useful to him. - -exactTyCoVarsOfType is used by the type checker to figure out exactly -which type variables are mentioned in a type. It's also used in the -smart-app checking code --- see TcExpr.tcIdApp - -On the other hand, consider a *top-level* definition - f = (\x -> x) :: T a -> T a -If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then -if we have an application like (f "x") we get a confusing error message -involving Any. So the conclusion is this: when generalising - - at top level use tyCoVarsOfType - - in nested bindings use exactTyCoVarsOfType -See Trac #1813 for example. --} - -exactTyCoVarsOfType :: Type -> TyCoVarSet --- Find the free type variables (of any kind) --- but *expand* type synonyms. See Note [Silly type synonym] above. -exactTyCoVarsOfType ty - = go ty - where - go ty | Just ty' <- tcView ty = go ty' -- This is the key line - go (TyVarTy tv) = unitVarSet tv `unionVarSet` go (tyVarKind tv) - go (TyConApp _ tys) = exactTyCoVarsOfTypes tys - go (LitTy {}) = emptyVarSet - go (AppTy fun arg) = go fun `unionVarSet` go arg - go (FunTy arg res) = go arg `unionVarSet` go res - go (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderKind bndr) - go (CastTy ty co) = go ty `unionVarSet` goCo co - go (CoercionTy co) = goCo co - - goCo (Refl _ ty) = go ty - goCo (TyConAppCo _ _ args)= goCos args - goCo (AppCo co arg) = goCo co `unionVarSet` goCo arg - goCo (ForAllCo tv k_co co) - = goCo co `delVarSet` tv `unionVarSet` goCo k_co - goCo (FunCo _ co1 co2) = goCo co1 `unionVarSet` goCo co2 - goCo (CoVarCo v) = unitVarSet v `unionVarSet` go (varType v) - goCo (AxiomInstCo _ _ args) = goCos args - goCo (UnivCo p _ t1 t2) = goProv p `unionVarSet` go t1 `unionVarSet` go t2 - goCo (SymCo co) = goCo co - goCo (TransCo co1 co2) = goCo co1 `unionVarSet` goCo co2 - goCo (NthCo _ co) = goCo co - goCo (LRCo _ co) = goCo co - goCo (InstCo co arg) = goCo co `unionVarSet` goCo arg - goCo (CoherenceCo c1 c2) = goCo c1 `unionVarSet` goCo c2 - goCo (KindCo co) = goCo co - goCo (SubCo co) = goCo co - goCo (AxiomRuleCo _ c) = goCos c - - goCos cos = foldr (unionVarSet . goCo) emptyVarSet cos - - goProv UnsafeCoerceProv = emptyVarSet - goProv (PhantomProv kco) = goCo kco - goProv (ProofIrrelProv kco) = goCo kco - goProv (PluginProv _) = emptyVarSet - goProv (HoleProv _) = emptyVarSet - -exactTyCoVarsOfTypes :: [Type] -> TyVarSet -exactTyCoVarsOfTypes tys = mapUnionVarSet exactTyCoVarsOfType tys - -anyRewritableTyVar :: Bool -> (TcTyVar -> Bool) - -> TcType -> Bool --- (anyRewritableTyVar ignore_cos pred ty) returns True --- if the 'pred' returns True of free TyVar in 'ty' --- Do not look inside casts and coercions if 'ignore_cos' is True --- See Note [anyRewritableTyVar] -anyRewritableTyVar ignore_cos pred ty - = go emptyVarSet ty - where - go_tv bound tv | tv `elemVarSet` bound = False - | otherwise = pred tv - - go bound (TyVarTy tv) = go_tv bound tv - go _ (LitTy {}) = False - go bound (TyConApp _ tys) = any (go bound) tys - go bound (AppTy fun arg) = go bound fun || go bound arg - go bound (FunTy arg res) = go bound arg || go bound res - go bound (ForAllTy tv ty) = go (bound `extendVarSet` binderVar tv) ty - go bound (CastTy ty co) = go bound ty || go_co bound co - go bound (CoercionTy co) = go_co bound co - - go_co bound co - | ignore_cos = False - | otherwise = anyVarSet (go_tv bound) (tyCoVarsOfCo co) - -- We don't have an equivalent of anyRewritableTyVar for coercions - -- (at least not yet) so take the free vars and test them - -{- Note [anyRewritableTyVar] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -anyRewritableTyVar is used during kick-out from the inert set, -to decide if, given a new equality (a ~ ty), we should kick out -a constraint C. Rather than gather free variables and see if 'a' -is among them, we instead pass in a predicate; this is just efficiency. --} - -{- ********************************************************************* -* * - Bound variables in a type -* * -********************************************************************* -} - --- | Find all variables bound anywhere in a type. --- See also Note [Scope-check inferred kinds] in TcHsType -allBoundVariables :: Type -> TyVarSet -allBoundVariables ty = fvVarSet $ go ty - where - go :: Type -> FV - go (TyVarTy tv) = go (tyVarKind tv) - go (TyConApp _ tys) = mapUnionFV go tys - go (AppTy t1 t2) = go t1 `unionFV` go t2 - go (FunTy t1 t2) = go t1 `unionFV` go t2 - go (ForAllTy (TvBndr tv _) t2) = FV.unitFV tv `unionFV` - go (tyVarKind tv) `unionFV` go t2 - go (LitTy {}) = emptyFV - go (CastTy ty _) = go ty - go (CoercionTy {}) = emptyFV - -- any types mentioned in a coercion should also be mentioned in - -- a type. - -allBoundVariabless :: [Type] -> TyVarSet -allBoundVariabless = mapUnionVarSet allBoundVariables - -{- ********************************************************************* -* * - Type and kind variables in a type -* * -********************************************************************* -} - -data CandidatesQTvs -- See Note [Dependent type variables] - -- See Note [CandidatesQTvs determinism] - = DV { dv_kvs :: DTyCoVarSet -- "kind" variables (dependent) - , dv_tvs :: DTyVarSet -- "type" variables (non-dependent) - -- A variable may appear in both sets - -- E.g. T k (x::k) The first occurrence of k makes it - -- show up in dv_tvs, the second in dv_kvs - -- See Note [Dependent type variables] - } - -instance Monoid CandidatesQTvs where - mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet } - mappend (DV { dv_kvs = kv1, dv_tvs = tv1 }) - (DV { dv_kvs = kv2, dv_tvs = tv2 }) - = DV { dv_kvs = kv1 `unionDVarSet` kv2 - , dv_tvs = tv1 `unionDVarSet` tv2} - -instance Outputable CandidatesQTvs where - ppr (DV {dv_kvs = kvs, dv_tvs = tvs }) - = text "DV" <+> braces (sep [ text "dv_kvs =" <+> ppr kvs - , text "dv_tvs =" <+> ppr tvs ]) - -{- Note [Dependent type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell type inference we quantify over type variables; but we only -quantify over /kind/ variables when -XPolyKinds is on. Without -XPolyKinds -we default the kind variables to *. - -So, to support this defaulting, and only for that reason, when -collecting the free vars of a type, prior to quantifying, we must keep -the type and kind variables separate. - -But what does that mean in a system where kind variables /are/ type -variables? It's a fairly arbitrary distinction based on how the -variables appear: - - - "Kind variables" appear in the kind of some other free variable - PLUS any free coercion variables - - These are the ones we default to * if -XPolyKinds is off - - - "Type variables" are all free vars that are not kind variables - -E.g. In the type T k (a::k) - 'k' is a kind variable, because it occurs in the kind of 'a', - even though it also appears at "top level" of the type - 'a' is a type variable, because it doesn't - -We gather these variables using a CandidatesQTvs record: - DV { dv_kvs: Variables free in the kind of a free type variable - or of a forall-bound type variable - , dv_tvs: Variables sytactically free in the type } - -So: dv_kvs are the kind variables of the type - (dv_tvs - dv_kvs) are the type variable of the type - -Note that - -* A variable can occur in both. - T k (x::k) The first occurrence of k makes it - show up in dv_tvs, the second in dv_kvs - -* We include any coercion variables in the "dependent", - "kind-variable" set because we never quantify over them. - -* Both sets are un-ordered, of course. - -* The "kind variables" might depend on each other; e.g - (k1 :: k2), (k2 :: *) - The "type variables" do not depend on each other; if - one did, it'd be classified as a kind variable! - -Note [CandidatesQTvs determinism and order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Determinism: when we quantify over type variables we decide the - order in which they appear in the final type. Because the order of - type variables in the type can end up in the interface file and - affects some optimizations like worker-wrapper, we want this order to - be deterministic. - - To achieve that we use deterministic sets of variables that can be - converted to lists in a deterministic order. For more information - about deterministic sets see Note [Deterministic UniqFM] in UniqDFM. - -* Order: as well as being deterministic, we use an - accumulating-parameter style for candidateQTyVarsOfType so that we - add variables one at a time, left to right. That means we tend to - produce the variables in left-to-right order. This is just to make - it bit more predicatable for the programmer. --} - --- | Worker for 'splitDepVarsOfType'. This might output the same var --- in both sets, if it's used in both a type and a kind. --- See Note [CandidatesQTvs determinism and order] --- See Note [Dependent type variables] -candidateQTyVarsOfType :: Type -> CandidatesQTvs -candidateQTyVarsOfType = split_dvs emptyVarSet mempty - -split_dvs :: VarSet -> CandidatesQTvs -> Type -> CandidatesQTvs -split_dvs bound dvs ty - = go dvs ty - where - go dv (AppTy t1 t2) = go (go dv t1) t2 - go dv (TyConApp _ tys) = foldl go dv tys - go dv (FunTy arg res) = go (go dv arg) res - go dv (LitTy {}) = dv - go dv (CastTy ty co) = go dv ty `mappend` go_co co - go dv (CoercionTy co) = dv `mappend` go_co co - - go dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) (TyVarTy tv) - | tv `elemVarSet` bound - = dv - | otherwise - = DV { dv_kvs = kvs `unionDVarSet` - kill_bound (tyCoVarsOfTypeDSet (tyVarKind tv)) - , dv_tvs = tvs `extendDVarSet` tv } - - go dv (ForAllTy (TvBndr tv _) ty) - = DV { dv_kvs = kvs `unionDVarSet` - kill_bound (tyCoVarsOfTypeDSet (tyVarKind tv)) - , dv_tvs = tvs } - where - DV { dv_kvs = kvs, dv_tvs = tvs } = split_dvs (bound `extendVarSet` tv) dv ty - - go_co co = DV { dv_kvs = kill_bound (tyCoVarsOfCoDSet co) - , dv_tvs = emptyDVarSet } - - kill_bound free - | isEmptyVarSet bound = free - | otherwise = filterDVarSet (not . (`elemVarSet` bound)) free - --- | Like 'splitDepVarsOfType', but over a list of types -candidateQTyVarsOfTypes :: [Type] -> CandidatesQTvs -candidateQTyVarsOfTypes = foldl (split_dvs emptyVarSet) mempty - -{- -************************************************************************ -* * - Predicates -* * -************************************************************************ --} - -tcIsTcTyVar :: TcTyVar -> Bool --- See Note [TcTyVars in the typechecker] -tcIsTcTyVar tv = isTyVar tv - -isTouchableOrFmv :: TcLevel -> TcTyVar -> Bool -isTouchableOrFmv ctxt_tclvl tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } - -> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, - ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) - case info of - FlatMetaTv -> True - _ -> tv_tclvl `sameDepthAs` ctxt_tclvl - _ -> False - -isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool -isTouchableMetaTyVar ctxt_tclvl tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tv_tclvl } - -> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, - ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) - tv_tclvl `sameDepthAs` ctxt_tclvl - _ -> False - | otherwise = False - -isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool -isFloatedTouchableMetaTyVar ctxt_tclvl tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tv_tclvl } -> tv_tclvl `strictlyDeeperThan` ctxt_tclvl - _ -> False - | otherwise = False - -isImmutableTyVar :: TyVar -> Bool -isImmutableTyVar tv = isSkolemTyVar tv - -isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, - isMetaTyVar, isAmbiguousTyVar, - isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool - -isTyConableTyVar tv - -- True of a meta-type variable that can be filled in - -- with a type constructor application; in particular, - -- not a SigTv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_info = SigTv } -> False - _ -> True - | otherwise = True - -isFmvTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_info = FlatMetaTv } -> True - _ -> False - --- | True of both given and wanted flatten-skolems (fak and usk) -isFlattenTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - FlatSkol {} -> True - MetaTv { mtv_info = FlatMetaTv } -> True - _ -> False - --- | True of FlatSkol skolems only -isFskTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - FlatSkol {} -> True - _ -> False - -isSkolemTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv {} -> False - _other -> True - -isOverlappableTyVar tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - SkolemTv _ overlappable -> overlappable - _ -> False - | otherwise = False - -isMetaTyVar tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv {} -> True - _ -> False - | otherwise = False - --- isAmbiguousTyVar is used only when reporting type errors --- It picks out variables that are unbound, namely meta --- type variables and the RuntimUnk variables created by --- RtClosureInspect.zonkRTTIType. These are "ambiguous" in --- the sense that they stand for an as-yet-unknown type -isAmbiguousTyVar tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = case tcTyVarDetails tv of - MetaTv {} -> True - RuntimeUnk {} -> True - _ -> False - | otherwise = False - -isMetaTyVarTy :: TcType -> Bool -isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv -isMetaTyVarTy _ = False - -metaTyVarInfo :: TcTyVar -> MetaInfo -metaTyVarInfo tv - = case tcTyVarDetails tv of - MetaTv { mtv_info = info } -> info - _ -> pprPanic "metaTyVarInfo" (ppr tv) - -metaTyVarTcLevel :: TcTyVar -> TcLevel -metaTyVarTcLevel tv - = case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tclvl } -> tclvl - _ -> pprPanic "metaTyVarTcLevel" (ppr tv) - -metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel -metaTyVarTcLevel_maybe tv - = case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tclvl } -> Just tclvl - _ -> Nothing - -metaTyVarRef :: TyVar -> IORef MetaDetails -metaTyVarRef tv - = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } -> ref - _ -> pprPanic "metaTyVarRef" (ppr tv) - -setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar -setMetaTyVarTcLevel tv tclvl - = case tcTyVarDetails tv of - details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl }) - _ -> pprPanic "metaTyVarTcLevel" (ppr tv) - -isSigTyVar :: Var -> Bool -isSigTyVar tv - = case tcTyVarDetails tv of - MetaTv { mtv_info = SigTv } -> True - _ -> False - -isFlexi, isIndirect :: MetaDetails -> Bool -isFlexi Flexi = True -isFlexi _ = False - -isIndirect (Indirect _) = True -isIndirect _ = False - -isRuntimeUnkSkol :: TyVar -> Bool --- Called only in TcErrors; see Note [Runtime skolems] there -isRuntimeUnkSkol x - | RuntimeUnk <- tcTyVarDetails x = True - | otherwise = False - -{- -************************************************************************ -* * -\subsection{Tau, sigma and rho} -* * -************************************************************************ --} - -mkSigmaTy :: [TyVarBinder] -> [PredType] -> Type -> Type -mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) - --- | Make a sigma ty where all type variables are 'Inferred'. That is, --- they cannot be used with visible type application. -mkInfSigmaTy :: [TyVar] -> [PredType] -> Type -> Type -mkInfSigmaTy tyvars ty = mkSigmaTy (mkTyVarBinders Inferred tyvars) ty - --- | Make a sigma ty where all type variables are "specified". That is, --- they can be used with visible type application -mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type -mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyVarBinders Specified tyvars) preds ty - -mkPhiTy :: [PredType] -> Type -> Type -mkPhiTy = mkFunTys - ---------------- -getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to - -- construct a dictionary function name -getDFunTyKey ty | Just ty' <- coreView ty = getDFunTyKey ty' -getDFunTyKey (TyVarTy tv) = getOccName tv -getDFunTyKey (TyConApp tc _) = getOccName tc -getDFunTyKey (LitTy x) = getDFunTyLitKey x -getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (FunTy _ _) = getOccName funTyCon -getDFunTyKey (ForAllTy _ t) = getDFunTyKey t -getDFunTyKey (CastTy ty _) = getDFunTyKey ty -getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) - -getDFunTyLitKey :: TyLit -> OccName -getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) -getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm - ---------------- -mkNakedTyConApp :: TyCon -> [Type] -> Type --- Builds a TyConApp --- * without being strict in TyCon, --- * without satisfying the invariants of TyConApp --- A subsequent zonking will establish the invariants --- See Note [Type-checking inside the knot] in TcHsType -mkNakedTyConApp tc tys = TyConApp tc tys - -mkNakedAppTys :: Type -> [Type] -> Type --- See Note [Type-checking inside the knot] in TcHsType -mkNakedAppTys ty1 [] = ty1 -mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2) -mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2 - -mkNakedAppTy :: Type -> Type -> Type --- See Note [Type-checking inside the knot] in TcHsType -mkNakedAppTy ty1 ty2 = mkNakedAppTys ty1 [ty2] - -mkNakedCastTy :: Type -> Coercion -> Type --- Do simple, fast compaction; especially dealing with Refl --- for which it's plain stupid to create a cast --- This simple function killed off a huge number of Refl casts --- in types, at birth. --- Note that it's fine to do this even for a "mkNaked" function, --- because we don't look at TyCons. isReflCo checks if the coercion --- is structurally Refl; it does not check for shape k ~ k. -mkNakedCastTy ty co | isReflCo co = ty -mkNakedCastTy (CastTy ty co1) co2 = CastTy ty (co1 `mkTransCo` co2) -mkNakedCastTy ty co = CastTy ty co - -{- -************************************************************************ -* * -\subsection{Expanding and splitting} -* * -************************************************************************ - -These tcSplit functions are like their non-Tc analogues, but - *) they do not look through newtypes - -However, they are non-monadic and do not follow through mutable type -variables. It's up to you to make sure this doesn't matter. --} - --- | Splits a forall type into a list of 'TyBinder's and the inner type. --- Always succeeds, even if it returns an empty list. -tcSplitPiTys :: Type -> ([TyBinder], Type) -tcSplitPiTys = splitPiTys - -tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type) -tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty' -tcSplitForAllTy_maybe (ForAllTy tv ty) = Just (tv, ty) -tcSplitForAllTy_maybe _ = Nothing - --- | Like 'tcSplitPiTys', but splits off only named binders, returning --- just the tycovars. -tcSplitForAllTys :: Type -> ([TyVar], Type) -tcSplitForAllTys = splitForAllTys - --- | Like 'tcSplitForAllTys', but splits off only named binders. -tcSplitForAllTyVarBndrs :: Type -> ([TyVarBinder], Type) -tcSplitForAllTyVarBndrs = splitForAllTyVarBndrs - --- | Is this a ForAllTy with a named binder? -tcIsForAllTy :: Type -> Bool -tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy {}) = True -tcIsForAllTy _ = False - -tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) --- Split off the first predicate argument from a type -tcSplitPredFunTy_maybe ty - | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' -tcSplitPredFunTy_maybe (FunTy arg res) - | isPredTy arg = Just (arg, res) -tcSplitPredFunTy_maybe _ - = Nothing - -tcSplitPhiTy :: Type -> (ThetaType, Type) -tcSplitPhiTy ty - = split ty [] - where - split ty ts - = case tcSplitPredFunTy_maybe ty of - Just (pred, ty) -> split ty (pred:ts) - Nothing -> (reverse ts, ty) - --- | Split a sigma type into its parts. -tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) -tcSplitSigmaTy ty = case tcSplitForAllTys ty of - (tvs, rho) -> case tcSplitPhiTy rho of - (theta, tau) -> (tvs, theta, tau) - --- | Split a sigma type into its parts, going underneath as many @ForAllTy@s --- as possible. For example, given this type synonym: --- --- @ --- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t --- @ --- --- if you called @tcSplitSigmaTy@ on this type: --- --- @ --- forall s t a b. Each s t a b => Traversal s t a b --- @ --- --- then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But --- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return --- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@. -tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type) --- NB: This is basically a pure version of deeplyInstantiate (from Inst) that --- doesn't compute an HsWrapper. -tcSplitNestedSigmaTys ty - -- If there's a forall, split it apart and try splitting the rho type - -- underneath it. - | Just (arg_tys, tvs1, theta1, rho1) <- tcDeepSplitSigmaTy_maybe ty - = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1 - in (tvs1 ++ tvs2, theta1 ++ theta2, mkFunTys arg_tys rho2) - -- If there's no forall, we're done. - | otherwise = ([], [], ty) - ------------------------ -tcDeepSplitSigmaTy_maybe - :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType) --- Looks for a *non-trivial* quantified type, under zero or more function arrows --- By "non-trivial" we mean either tyvars or constraints are non-empty - -tcDeepSplitSigmaTy_maybe ty - | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty - , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty - = Just (arg_ty:arg_tys, tvs, theta, rho) - - | (tvs, theta, rho) <- tcSplitSigmaTy ty - , not (null tvs && null theta) - = Just ([], tvs, theta, rho) - - | otherwise = Nothing - ------------------------ -tcTyConAppTyCon :: Type -> TyCon -tcTyConAppTyCon ty - = case tcTyConAppTyCon_maybe ty of - Just tc -> tc - Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty) - --- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'. -tcTyConAppTyCon_maybe :: Type -> Maybe TyCon -tcTyConAppTyCon_maybe ty - | Just ty' <- tcView ty = tcTyConAppTyCon_maybe ty' -tcTyConAppTyCon_maybe (TyConApp tc _) - = Just tc -tcTyConAppTyCon_maybe (FunTy _ _) - = Just funTyCon -tcTyConAppTyCon_maybe _ - = Nothing - -tcTyConAppArgs :: Type -> [Type] -tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of - Just (_, args) -> args - Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) - -tcSplitTyConApp :: Type -> (TyCon, [Type]) -tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) - --- | Like 'tcRepSplitTyConApp_maybe', but returns 'Nothing' if, --- --- 1. the type is structurally not a type constructor application, or --- --- 2. the type is a function type (e.g. application of 'funTyCon'), but we --- currently don't even enough information to fully determine its RuntimeRep --- variables. For instance, @FunTy (a :: k) Int@. --- --- By contrast 'tcRepSplitTyConApp_maybe' panics in the second case. --- --- The behavior here is needed during canonicalization; see Note [FunTy and --- decomposing tycon applications] in TcCanonical for details. -tcRepSplitTyConApp_maybe' :: HasCallStack => Type -> Maybe (TyCon, [Type]) -tcRepSplitTyConApp_maybe' (TyConApp tc tys) = Just (tc, tys) -tcRepSplitTyConApp_maybe' (FunTy arg res) - | Just arg_rep <- getRuntimeRep_maybe arg - , Just res_rep <- getRuntimeRep_maybe res - = Just (funTyCon, [arg_rep, res_rep, arg, res]) -tcRepSplitTyConApp_maybe' _ = Nothing - - ------------------------ -tcSplitFunTys :: Type -> ([Type], Type) -tcSplitFunTys ty = case tcSplitFunTy_maybe ty of - Nothing -> ([], ty) - Just (arg,res) -> (arg:args, res') - where - (args,res') = tcSplitFunTys res - -tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) -tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' -tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res) -tcSplitFunTy_maybe _ = Nothing - -- Note the typeKind guard - -- Consider (?x::Int) => Bool - -- We don't want to treat this as a function type! - -- A concrete example is test tc230: - -- f :: () -> (?p :: ()) => () -> () - -- - -- g = f () () - -tcSplitFunTysN :: Arity -- N: Number of desired args - -> TcRhoType - -> Either Arity -- Number of missing arrows - ([TcSigmaType], -- Arg types (always N types) - TcSigmaType) -- The rest of the type --- ^ Split off exactly the specified number argument types --- Returns --- (Left m) if there are 'm' missing arrows in the type --- (Right (tys,res)) if the type looks like t1 -> ... -> tn -> res -tcSplitFunTysN n ty - | n == 0 - = Right ([], ty) - | Just (arg,res) <- tcSplitFunTy_maybe ty - = case tcSplitFunTysN (n-1) res of - Left m -> Left m - Right (args,body) -> Right (arg:args, body) - | otherwise - = Left n - -tcSplitFunTy :: Type -> (Type, Type) -tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) - -tcFunArgTy :: Type -> Type -tcFunArgTy ty = fst (tcSplitFunTy ty) - -tcFunResultTy :: Type -> Type -tcFunResultTy ty = snd (tcSplitFunTy ty) - --- | Strips off n *visible* arguments and returns the resulting type -tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type -tcFunResultTyN n ty - | Right (_, res_ty) <- tcSplitFunTysN n ty - = res_ty - | otherwise - = pprPanic "tcFunResultTyN" (ppr n <+> ppr ty) - ------------------------ -tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) -tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty' -tcSplitAppTy_maybe ty = tcRepSplitAppTy_maybe ty - -tcSplitAppTy :: Type -> (Type, Type) -tcSplitAppTy ty = case tcSplitAppTy_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "tcSplitAppTy" (pprType ty) - -tcSplitAppTys :: Type -> (Type, [Type]) -tcSplitAppTys ty - = go ty [] - where - go ty args = case tcSplitAppTy_maybe ty of - Just (ty', arg) -> go ty' (arg:args) - Nothing -> (ty,args) - ------------------------ -tcGetTyVar_maybe :: Type -> Maybe TyVar -tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty' -tcGetTyVar_maybe (TyVarTy tv) = Just tv -tcGetTyVar_maybe _ = Nothing - -tcGetTyVar :: String -> Type -> TyVar -tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty) - -tcIsTyVarTy :: Type -> Bool -tcIsTyVarTy ty | Just ty' <- tcView ty = tcIsTyVarTy ty' -tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as - -- this is only used for - -- e.g., FlexibleContexts -tcIsTyVarTy (TyVarTy _) = True -tcIsTyVarTy _ = False - ------------------------ -tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) --- Split the type of a dictionary function --- We don't use tcSplitSigmaTy, because a DFun may (with NDP) --- have non-Pred arguments, such as --- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m --- --- Also NB splitFunTys, not tcSplitFunTys; --- the latter specifically stops at PredTy arguments, --- and we don't want to do that here -tcSplitDFunTy ty - = case tcSplitForAllTys ty of { (tvs, rho) -> - case splitFunTys rho of { (theta, tau) -> - case tcSplitDFunHead tau of { (clas, tys) -> - (tvs, theta, clas, tys) }}} - -tcSplitDFunHead :: Type -> (Class, [Type]) -tcSplitDFunHead = getClassPredTys - -tcSplitMethodTy :: Type -> ([TyVar], PredType, Type) --- A class method (selector) always has a type like --- forall as. C as => blah --- So if the class looks like --- class C a where --- op :: forall b. (Eq a, Ix b) => a -> b --- the class method type looks like --- op :: forall a. C a => forall b. (Eq a, Ix b) => a -> b --- --- tcSplitMethodTy just peels off the outer forall and --- that first predicate -tcSplitMethodTy ty - | (sel_tyvars,sel_rho) <- tcSplitForAllTys ty - , Just (first_pred, local_meth_ty) <- tcSplitPredFunTy_maybe sel_rho - = (sel_tyvars, first_pred, local_meth_ty) - | otherwise - = pprPanic "tcSplitMethodTy" (ppr ty) - - -{- ********************************************************************* -* * - Type equalities -* * -********************************************************************* -} - -tcEqKind :: TcKind -> TcKind -> Bool -tcEqKind = tcEqType - -tcEqType :: TcType -> TcType -> Bool --- tcEqType is a proper implements the same Note [Non-trivial definitional --- equality] (in TyCoRep) as `eqType`, but Type.eqType believes (* == --- Constraint), and that is NOT what we want in the type checker! -tcEqType ty1 ty2 - = isNothing (tc_eq_type tcView ki1 ki2) && - isNothing (tc_eq_type tcView ty1 ty2) - where - ki1 = typeKind ty1 - ki2 = typeKind ty2 - --- | Just like 'tcEqType', but will return True for types of different kinds --- as long as their non-coercion structure is identical. -tcEqTypeNoKindCheck :: TcType -> TcType -> Bool -tcEqTypeNoKindCheck ty1 ty2 - = isNothing $ tc_eq_type tcView ty1 ty2 - --- | Like 'tcEqType', but returns information about whether the difference --- is visible in the case of a mismatch. --- @Nothing@ : the types are equal --- @Just True@ : the types differ, and the point of difference is visible --- @Just False@ : the types differ, and the point of difference is invisible -tcEqTypeVis :: TcType -> TcType -> Maybe Bool -tcEqTypeVis ty1 ty2 - = tc_eq_type tcView ty1 ty2 invis (tc_eq_type tcView ki1 ki2) - where - ki1 = typeKind ty1 - ki2 = typeKind ty2 - - -- convert Just True to Just False - invis :: Maybe Bool -> Maybe Bool - invis = fmap (const False) - -() :: Maybe Bool -> Maybe Bool -> Maybe Bool -Nothing x = x -Just True _ = Just True -Just _vis Just True = Just True -Just vis _ = Just vis -infixr 3 - --- | Real worker for 'tcEqType'. No kind check! -tc_eq_type :: (TcType -> Maybe TcType) -- ^ @tcView@, if you want unwrapping - -> Type -> Type -> Maybe Bool -tc_eq_type view_fun orig_ty1 orig_ty2 = go True orig_env orig_ty1 orig_ty2 - where - go :: Bool -> RnEnv2 -> Type -> Type -> Maybe Bool - go vis env t1 t2 | Just t1' <- view_fun t1 = go vis env t1' t2 - go vis env t1 t2 | Just t2' <- view_fun t2 = go vis env t1 t2' - - go vis env (TyVarTy tv1) (TyVarTy tv2) - = check vis $ rnOccL env tv1 == rnOccR env tv2 - - go vis _ (LitTy lit1) (LitTy lit2) - = check vis $ lit1 == lit2 - - go vis env (ForAllTy (TvBndr tv1 vis1) ty1) - (ForAllTy (TvBndr tv2 vis2) ty2) - = go (isVisibleArgFlag vis1) env (tyVarKind tv1) (tyVarKind tv2) - go vis (rnBndr2 env tv1 tv2) ty1 ty2 - check vis (vis1 == vis2) - -- Make sure we handle all FunTy cases since falling through to the - -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked - -- kind variable, which causes things to blow up. - go vis env (FunTy arg1 res1) (FunTy arg2 res2) - = go vis env arg1 arg2 go vis env res1 res2 - go vis env ty (FunTy arg res) - = eqFunTy vis env arg res ty - go vis env (FunTy arg res) ty - = eqFunTy vis env arg res ty - - -- See Note [Equality on AppTys] in Type - go vis env (AppTy s1 t1) ty2 - | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2 - = go vis env s1 s2 go vis env t1 t2 - go vis env ty1 (AppTy s2 t2) - | Just (s1, t1) <- tcRepSplitAppTy_maybe ty1 - = go vis env s1 s2 go vis env t1 t2 - go vis env (TyConApp tc1 ts1) (TyConApp tc2 ts2) - = check vis (tc1 == tc2) gos (tc_vis vis tc1) env ts1 ts2 - go vis env (CastTy t1 _) t2 = go vis env t1 t2 - go vis env t1 (CastTy t2 _) = go vis env t1 t2 - go _ _ (CoercionTy {}) (CoercionTy {}) = Nothing - go vis _ _ _ = Just vis - - gos _ _ [] [] = Nothing - gos (v:vs) env (t1:ts1) (t2:ts2) = go v env t1 t2 gos vs env ts1 ts2 - gos (v:_) _ _ _ = Just v - gos _ _ _ _ = panic "tc_eq_type" - - tc_vis :: Bool -> TyCon -> [Bool] - tc_vis True tc = viss ++ repeat True - -- the repeat True is necessary because tycons can legitimately - -- be oversaturated - where - bndrs = tyConBinders tc - viss = map (isVisibleArgFlag . tyConBinderArgFlag) bndrs - tc_vis False _ = repeat False -- if we're not in a visible context, our args - -- aren't either - - check :: Bool -> Bool -> Maybe Bool - check _ True = Nothing - check vis False = Just vis - - orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] - - -- @eqFunTy arg res ty@ is True when @ty@ equals @FunTy arg res@. This is - -- sometimes hard to know directly because @ty@ might have some casts - -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't - -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or - -- res is unzonked/unflattened. Thus this function, which handles this - -- corner case. - eqFunTy :: Bool -> RnEnv2 -> Type -> Type -> Type -> Maybe Bool - eqFunTy vis env arg res (FunTy arg' res') - = go vis env arg arg' go vis env res res' - eqFunTy vis env arg res ty@(AppTy{}) - | Just (tc, [_, _, arg', res']) <- get_args ty [] - , tc == funTyCon - = go vis env arg arg' go vis env res res' - where - get_args :: Type -> [Type] -> Maybe (TyCon, [Type]) - get_args (AppTy f x) args = get_args f (x:args) - get_args (CastTy t _) args = get_args t args - get_args (TyConApp tc tys) args = Just (tc, tys ++ args) - get_args _ _ = Nothing - eqFunTy vis _ _ _ _ - = Just vis - --- | Like 'pickyEqTypeVis', but returns a Bool for convenience -pickyEqType :: TcType -> TcType -> Bool --- Check when two types _look_ the same, _including_ synonyms. --- So (pickyEqType String [Char]) returns False --- This ignores kinds and coercions, because this is used only for printing. -pickyEqType ty1 ty2 - = isNothing $ - tc_eq_type (const Nothing) ty1 ty2 - -{- ********************************************************************* -* * - Predicate types -* * -************************************************************************ - -Deconstructors and tests on predicate types - -Note [Kind polymorphic type classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - class C f where... -- C :: forall k. k -> Constraint - g :: forall (f::*). C f => f -> f - -Here the (C f) in the signature is really (C * f), and we -don't want to complain that the * isn't a type variable! --} - -isTyVarClassPred :: PredType -> Bool -isTyVarClassPred ty = case getClassPredTys_maybe ty of - Just (_, tys) -> all isTyVarTy tys - _ -> False - -------------------------- -checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool --- If the Bool is True (flexible contexts), return True (i.e. ok) --- Otherwise, check that the type (not kind) args are all headed by a tyvar --- E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected --- This function is here rather than in TcValidity because it is --- called from TcSimplify, which itself is imported by TcValidity -checkValidClsArgs flexible_contexts cls kts - | flexible_contexts = True - | otherwise = all hasTyVarHead tys - where - tys = filterOutInvisibleTypes (classTyCon cls) kts - -hasTyVarHead :: Type -> Bool --- Returns true of (a t1 .. tn), where 'a' is a type variable -hasTyVarHead ty -- Haskell 98 allows predicates of form - | tcIsTyVarTy ty = True -- C (a ty1 .. tyn) - | otherwise -- where a is a type variable - = case tcSplitAppTy_maybe ty of - Just (ty, _) -> hasTyVarHead ty - Nothing -> False - -evVarPred_maybe :: EvVar -> Maybe PredType -evVarPred_maybe v = if isPredTy ty then Just ty else Nothing - where ty = varType v - -evVarPred :: EvVar -> PredType -evVarPred var - | debugIsOn - = case evVarPred_maybe var of - Just pred -> pred - Nothing -> pprPanic "tcEvVarPred" (ppr var <+> ppr (varType var)) - | otherwise - = varType var - ------------------- --- | 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 Trac #10608, #10351 - -- flex_ctxt <- xoptM Opt_FlexibleContexts - filter (pick_me flex_ctxt) theta - where - pick_me flex_ctxt pred - = case classifyPredType pred of - - ClassPred cls tys - | Just {} <- isCallStackPred pred - -- 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] - -> False - - | isIPClass cls -> True -- See note [Inheriting implicit parameters] - - | otherwise - -> pick_cls_pred flex_ctxt cls tys - - EqPred ReprEq ty1 ty2 -> pick_cls_pred flex_ctxt coercibleClass [ty1, ty2] - -- representational equality is like a class constraint - - EqPred NomEq ty1 ty2 -> quant_fun ty1 || quant_fun ty2 - IrredPred ty -> tyCoVarsOfType ty `intersectsVarSet` qtvs - - 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 Trac #10351. - - -- See Note [Quantifying over equality constraints] - quant_fun ty - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) | isTypeFamilyTyCon tc - -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs - _ -> False - -pickCapturedPreds - :: TyVarSet -- Quantifying over these - -> TcThetaType -- Proposed constraints to quantify - -> TcThetaType -- A subset that we can actually quantify --- A simpler version of pickQuantifiablePreds, used to winnow down --- the inferred constrains of a group of bindings, into those for --- one particular identifier -pickCapturedPreds qtvs theta - = filter captured theta - where - captured pred = isIPPred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) - - --- Superclasses - -type PredWithSCs = (PredType, [PredType]) - -mkMinimalBySCs :: [PredType] -> [PredType] --- Remove predicates that can be deduced from others by superclasses, --- including duplicate predicates. The result is a subset of the input. -mkMinimalBySCs ptys = go preds_with_scs [] - where - preds_with_scs :: [PredWithSCs] - preds_with_scs = [ (pred, pred : transSuperClasses pred) - | pred <- ptys ] - - go :: [PredWithSCs] -- Work list - -> [PredWithSCs] -- Accumulating result - -> [PredType] - go [] min_preds = map fst min_preds - go (work_item@(p,_) : work_list) min_preds - | p `in_cloud` work_list || p `in_cloud` min_preds - = go work_list min_preds - | otherwise - = go work_list (work_item : min_preds) - - in_cloud :: PredType -> [PredWithSCs] -> Bool - in_cloud p ps = or [ p `eqType` p' | (_, scs) <- ps, p' <- scs ] - -transSuperClasses :: PredType -> [PredType] --- (transSuperClasses p) returns (p's superclasses) not including p --- Stop if you encounter the same class again --- See Note [Expanding superclasses] -transSuperClasses p - = go emptyNameSet p - where - go :: NameSet -> PredType -> [PredType] - go rec_clss p - | ClassPred cls tys <- classifyPredType p - , let cls_nm = className cls - , not (cls_nm `elemNameSet` rec_clss) - , let rec_clss' | isCTupleClass cls = rec_clss - | otherwise = rec_clss `extendNameSet` cls_nm - = [ p' | sc <- immSuperClasses cls tys - , p' <- sc : go rec_clss' sc ] - | otherwise - = [] - -immSuperClasses :: Class -> [Type] -> [PredType] -immSuperClasses cls tys - = substTheta (zipTvSubst tyvars tys) sc_theta - where - (tyvars,sc_theta,_,_) = classBigSig cls - -isImprovementPred :: PredType -> Bool --- Either it's an equality, or has some functional dependency -isImprovementPred ty - = case classifyPredType ty of - EqPred NomEq t1 t2 -> not (t1 `tcEqType` t2) - EqPred ReprEq _ _ -> False - ClassPred cls _ -> classHasFds cls - IrredPred {} -> True -- Might have equalities after reduction? - -{- Note [Expanding superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we expand superclasses, we use the following algorithm: - -expand( so_far, pred ) returns the transitive superclasses of pred, - not including pred itself - 1. If pred is not a class constraint, return empty set - Otherwise pred = C ts - 2. If C is in so_far, return empty set (breaks loops) - 3. Find the immediate superclasses constraints of (C ts) - 4. For each such sc_pred, return (sc_pred : expand( so_far+C, D ss ) - -Notice that - - * With normal Haskell-98 classes, the loop-detector will never bite, - so we'll get all the superclasses. - - * Since there is only a finite number of distinct classes, expansion - must terminate. - - * The loop breaking is a bit conservative. Notably, a tuple class - could contain many times without threatening termination: - (Eq a, (Ord a, Ix a)) - And this is try of any class that we can statically guarantee - as non-recursive (in some sense). For now, we just make a special - case for tuples. Something better would be cool. - -See also TcTyDecls.checkClassCycles. - -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. - -************************************************************************ -* * -\subsection{Predicates} -* * -************************************************************************ --} - -isSigmaTy :: TcType -> Bool --- isSigmaTy returns true of any qualified type. It doesn't --- *necessarily* have any foralls. E.g --- f :: (?x::Int) => Int -> Int -isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty' -isSigmaTy (ForAllTy {}) = True -isSigmaTy (FunTy a _) = isPredTy a -isSigmaTy _ = False - -isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] -isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty' -isRhoTy (ForAllTy {}) = False -isRhoTy (FunTy a r) = not (isPredTy a) && isRhoTy r -isRhoTy _ = True - --- | Like 'isRhoTy', but also says 'True' for 'Infer' types -isRhoExpTy :: ExpType -> Bool -isRhoExpTy (Check ty) = isRhoTy ty -isRhoExpTy (Infer {}) = True - -isOverloadedTy :: Type -> Bool --- Yes for a type of a function that might require evidence-passing --- Used only by bindLocalMethods -isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' -isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty -isOverloadedTy (FunTy a _) = isPredTy a -isOverloadedTy _ = False - -isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, - isUnitTy, isCharTy, isAnyTy :: Type -> Bool -isFloatTy = is_tc floatTyConKey -isDoubleTy = is_tc doubleTyConKey -isIntegerTy = is_tc integerTyConKey -isIntTy = is_tc intTyConKey -isWordTy = is_tc wordTyConKey -isBoolTy = is_tc boolTyConKey -isUnitTy = is_tc unitTyConKey -isCharTy = is_tc charTyConKey -isAnyTy = is_tc anyTyConKey - --- | Does a type represent a floating-point number? -isFloatingTy :: Type -> Bool -isFloatingTy ty = isFloatTy ty || isDoubleTy ty - --- | Is a type 'String'? -isStringTy :: Type -> Bool -isStringTy ty - = case tcSplitTyConApp_maybe ty of - Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty - _ -> False - --- | Is a type a 'CallStack'? -isCallStackTy :: Type -> Bool -isCallStackTy ty - | Just tc <- tyConAppTyCon_maybe ty - = tc `hasKey` callStackTyConKey - | otherwise - = False - --- | Is a 'PredType' a 'CallStack' implicit parameter? --- --- If so, return the name of the parameter. -isCallStackPred :: PredType -> Maybe FastString -isCallStackPred pred - | Just (str, ty) <- isIPPred_maybe pred - , isCallStackTy ty - = Just str - | otherwise - = Nothing - -is_tc :: Unique -> Type -> Bool --- Newtypes are opaque to this -is_tc uniq ty = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> uniq == getUnique tc - Nothing -> False - --- | Does the given tyvar appear in the given type outside of any --- non-newtypes? Assume we're looking for @a@. Says "yes" for --- @a@, @N a@, @b a@, @a b@, @b (N a)@. Says "no" for --- @[a]@, @Maybe a@, @T a@, where @N@ is a newtype and @T@ is a datatype. -isTyVarExposed :: TcTyVar -> TcType -> Bool -isTyVarExposed tv (TyVarTy tv') = tv == tv' -isTyVarExposed tv (TyConApp tc tys) - | isNewTyCon tc = any (isTyVarExposed tv) tys - | otherwise = False -isTyVarExposed _ (LitTy {}) = False -isTyVarExposed tv (AppTy fun arg) = isTyVarExposed tv fun - || isTyVarExposed tv arg -isTyVarExposed _ (ForAllTy {}) = False -isTyVarExposed _ (FunTy {}) = False -isTyVarExposed tv (CastTy ty _) = isTyVarExposed tv ty -isTyVarExposed _ (CoercionTy {}) = False - --- | Is the equality --- a ~r ...a.... --- definitely insoluble or not? --- a ~r Maybe a -- Definitely insoluble --- a ~N ...(F a)... -- Not definitely insoluble --- -- Perhaps (F a) reduces to Int --- a ~R ...(N a)... -- Not definitely insoluble --- -- Perhaps newtype N a = MkN Int --- See Note [Occurs check error] in --- TcCanonical for the motivation for this function. -isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool -isInsolubleOccursCheck eq_rel tv ty - = go ty - where - go ty | Just ty' <- tcView ty = go ty' - go (TyVarTy tv') = tv == tv' || go (tyVarKind tv') - go (LitTy {}) = False - go (AppTy t1 t2) = go t1 || go t2 - go (FunTy t1 t2) = go t1 || go t2 - go (ForAllTy (TvBndr tv' _) inner_ty) - | tv' == tv = False - | otherwise = go (tyVarKind tv') || go inner_ty - go (CastTy ty _) = go ty -- ToDo: what about the coercion - go (CoercionTy _) = False -- ToDo: what about the coercion - go (TyConApp tc tys) - | isGenerativeTyCon tc role = any go tys - | otherwise = False - - role = eqRelRole eq_rel - -isRigidTy :: TcType -> Bool -isRigidTy ty - | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal - | Just {} <- tcSplitAppTy_maybe ty = True - | isForAllTy ty = True - | otherwise = False - -isRigidEqPred :: TcLevel -> PredTree -> Bool --- ^ True of all Nominal equalities that are solidly insoluble --- This means all equalities *except* --- * Meta-tv non-SigTv on LHS --- * Meta-tv SigTv on LHS, tyvar on right -isRigidEqPred tc_lvl (EqPred NomEq ty1 _) - | Just tv1 <- tcGetTyVar_maybe ty1 - = ASSERT2( tcIsTcTyVar tv1, ppr tv1 ) - not (isMetaTyVar tv1) || isTouchableMetaTyVar tc_lvl tv1 - - | otherwise -- LHS is not a tyvar - = True - -isRigidEqPred _ _ = False -- Not an equality - -{- -************************************************************************ -* * -\subsection{Transformation of Types to TcTypes} -* * -************************************************************************ --} - -toTcType :: Type -> TcType --- The constraint solver expects EvVars to have TcType, in which the --- free type variables are TcTyVars. So we convert from Type to TcType here --- A bit tiresome; but one day I expect the two types to be entirely separate --- in which case we'll definitely need to do this -toTcType = runIdentity . to_tc_type emptyVarSet - -toTcTypeBag :: Bag EvVar -> Bag EvVar -- All TyVars are transformed to TcTyVars -toTcTypeBag evvars = mapBag (\tv -> setTyVarKind tv (toTcType (tyVarKind tv))) evvars - -to_tc_mapper :: TyCoMapper VarSet Identity -to_tc_mapper - = TyCoMapper { tcm_smart = False -- more efficient not to use smart ctors - , tcm_tyvar = tyvar - , tcm_covar = covar - , tcm_hole = hole - , tcm_tybinder = tybinder } - where - tyvar :: VarSet -> TyVar -> Identity Type - tyvar ftvs tv - | Just var <- lookupVarSet ftvs tv = return $ TyVarTy var - | isTcTyVar tv = TyVarTy <$> updateTyVarKindM (to_tc_type ftvs) tv - | otherwise - = do { kind' <- to_tc_type ftvs (tyVarKind tv) - ; return $ TyVarTy $ mkTcTyVar (tyVarName tv) kind' vanillaSkolemTv } - - covar :: VarSet -> CoVar -> Identity Coercion - covar ftvs cv - | Just var <- lookupVarSet ftvs cv = return $ CoVarCo var - | otherwise = CoVarCo <$> updateVarTypeM (to_tc_type ftvs) cv - - hole :: VarSet -> CoercionHole -> Role -> Type -> Type - -> Identity Coercion - hole ftvs h r t1 t2 = mkHoleCo h r <$> to_tc_type ftvs t1 - <*> to_tc_type ftvs t2 - - tybinder :: VarSet -> TyVar -> ArgFlag -> Identity (VarSet, TyVar) - tybinder ftvs tv _vis = do { kind' <- to_tc_type ftvs (tyVarKind tv) - ; let tv' = mkTcTyVar (tyVarName tv) kind' - vanillaSkolemTv - ; return (ftvs `extendVarSet` tv', tv') } - -to_tc_type :: VarSet -> Type -> Identity TcType -to_tc_type = mapType to_tc_mapper - -{- -************************************************************************ -* * -\subsection{Misc} -* * -************************************************************************ - -Note [Visible type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC implements a generalisation of the algorithm described in the -"Visible Type Application" paper (available from -http://www.cis.upenn.edu/~sweirich/publications.html). A key part -of that algorithm is to distinguish user-specified variables from inferred -variables. For example, the following should typecheck: - - f :: forall a b. a -> b -> b - f = const id - - g = const id - - x = f @Int @Bool 5 False - y = g 5 @Bool False - -The idea is that we wish to allow visible type application when we are -instantiating a specified, fixed variable. In practice, specified, fixed -variables are either written in a type signature (or -annotation), OR are imported from another module. (We could do better here, -for example by doing SCC analysis on parts of a module and considering any -type from outside one's SCC to be fully specified, but this is very confusing to -users. The simple rule above is much more straightforward and predictable.) - -So, both of f's quantified variables are specified and may be instantiated. -But g has no type signature, so only id's variable is specified (because id -is imported). We write the type of g as forall {a}. a -> forall b. b -> b. -Note that the a is in braces, meaning it cannot be instantiated with -visible type application. - -Tracking specified vs. inferred variables is done conveniently by a field -in TyBinder. - --} - -deNoteType :: Type -> Type --- Remove all *outermost* type synonyms and other notes -deNoteType ty | Just ty' <- coreView ty = deNoteType ty' -deNoteType ty = ty - -{- -Find the free tycons and classes of a type. This is used in the front -end of the compiler. --} - -{- -************************************************************************ -* * -\subsection[TysWiredIn-ext-type]{External types} -* * -************************************************************************ - -The compiler's foreign function interface supports the passing of a -restricted set of types as arguments and results (the restricting factor -being the ) --} - -tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) --- (tcSplitIOType_maybe t) returns Just (IO,t',co) --- if co : t ~ IO t' --- returns Nothing otherwise -tcSplitIOType_maybe ty - = case tcSplitTyConApp_maybe ty of - Just (io_tycon, [io_res_ty]) - | io_tycon `hasKey` ioTyConKey -> - Just (io_tycon, io_res_ty) - _ -> - Nothing - -isFFITy :: Type -> Bool --- True for any TyCon that can possibly be an arg or result of an FFI call -isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty) - -isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity --- Checks for valid argument type for a 'foreign import' -isFFIArgumentTy dflags safety ty - = checkRepTyCon (legalOutgoingTyCon dflags safety) ty - -isFFIExternalTy :: Type -> Validity --- Types that are allowed as arguments of a 'foreign export' -isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty - -isFFIImportResultTy :: DynFlags -> Type -> Validity -isFFIImportResultTy dflags ty - = checkRepTyCon (legalFIResultTyCon dflags) ty - -isFFIExportResultTy :: Type -> Validity -isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty - -isFFIDynTy :: Type -> Type -> Validity --- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of --- either, and the wrapped function type must be equal to the given type. --- We assume that all types have been run through normaliseFfiType, so we don't --- need to worry about expanding newtypes here. -isFFIDynTy expected ty - -- Note [Foreign import dynamic] - -- In the example below, expected would be 'CInt -> IO ()', while ty would - -- be 'FunPtr (CDouble -> IO ())'. - | Just (tc, [ty']) <- splitTyConApp_maybe ty - , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] - , eqType ty' expected - = IsValid - | otherwise - = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma - , text " Actual:" <+> ppr ty ]) - -isFFILabelTy :: Type -> Validity --- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. -isFFILabelTy ty = checkRepTyCon ok ty - where - ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey - = IsValid - | otherwise - = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") - -isFFIPrimArgumentTy :: DynFlags -> Type -> Validity --- Checks for valid argument type for a 'foreign import prim' --- Currently they must all be simple unlifted types, or the well-known type --- Any, which can be used to pass the address to a Haskell object on the heap to --- the foreign function. -isFFIPrimArgumentTy dflags ty - | isAnyTy ty = IsValid - | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty - -isFFIPrimResultTy :: DynFlags -> Type -> Validity --- Checks for valid result type for a 'foreign import prim' Currently --- it must be an unlifted type, including unboxed tuples, unboxed --- sums, or the well-known type Any. -isFFIPrimResultTy dflags ty - | isAnyTy ty = IsValid - | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty - -isFunPtrTy :: Type -> Bool -isFunPtrTy ty - | Just (tc, [_]) <- splitTyConApp_maybe ty - = tc `hasKey` funPtrTyConKey - | otherwise - = False - --- normaliseFfiType gets run before checkRepTyCon, so we don't --- need to worry about looking through newtypes or type functions --- here; that's already been taken care of. -checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity -checkRepTyCon check_tc ty - = case splitTyConApp_maybe ty of - Just (tc, tys) - | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix)) - | otherwise -> case check_tc tc of - IsValid -> IsValid - NotValid extra -> NotValid (msg $$ extra) - Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type") - where - msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" - mk_nt_reason tc tys - | null tys = text "because its data constructor is not in scope" - | otherwise = text "because the data constructor for" - <+> quotes (ppr tc) <+> text "is not in scope" - nt_fix = text "Possible fix: import the data constructor to bring it into scope" - -{- -Note [Foreign import dynamic] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign -type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. - -We use isFFIDynTy to check whether a signature is well-formed. For example, -given a (illegal) declaration like: - -foreign import ccall "dynamic" - foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () - -isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried -result type 'CInt -> IO ()', and return False, as they are not equal. - - ----------------------------------------------- -These chaps do the work; they are not exported ----------------------------------------------- --} - -legalFEArgTyCon :: TyCon -> Validity -legalFEArgTyCon tc - -- It's illegal to make foreign exports that take unboxed - -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 - = boxedMarshalableTyCon tc - -legalFIResultTyCon :: DynFlags -> TyCon -> Validity -legalFIResultTyCon dflags tc - | tc == unitTyCon = IsValid - | otherwise = marshalableTyCon dflags tc - -legalFEResultTyCon :: TyCon -> Validity -legalFEResultTyCon tc - | tc == unitTyCon = IsValid - | otherwise = boxedMarshalableTyCon tc - -legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity --- Checks validity of types going from Haskell -> external world -legalOutgoingTyCon dflags _ tc - = marshalableTyCon dflags tc - -legalFFITyCon :: TyCon -> Validity --- True for any TyCon that can possibly be an arg or result of an FFI call -legalFFITyCon tc - | isUnliftedTyCon tc = IsValid - | tc == unitTyCon = IsValid - | otherwise = boxedMarshalableTyCon tc - -marshalableTyCon :: DynFlags -> TyCon -> Validity -marshalableTyCon dflags tc - | isUnliftedTyCon tc - , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) - , not (null (tyConPrimRep tc)) -- Note [Marshalling void] - = validIfUnliftedFFITypes dflags - | otherwise - = boxedMarshalableTyCon tc - -boxedMarshalableTyCon :: TyCon -> Validity -boxedMarshalableTyCon tc - | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey - , int32TyConKey, int64TyConKey - , wordTyConKey, word8TyConKey, word16TyConKey - , word32TyConKey, word64TyConKey - , floatTyConKey, doubleTyConKey - , ptrTyConKey, funPtrTyConKey - , charTyConKey - , stablePtrTyConKey - , boolTyConKey - ] - = IsValid - - | otherwise = NotValid empty - -legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity --- Check args of 'foreign import prim', only allow simple unlifted types. --- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since --- currently they're of the wrong kind to use in function args anyway. -legalFIPrimArgTyCon dflags tc - | isUnliftedTyCon tc - , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) - = validIfUnliftedFFITypes dflags - | otherwise - = NotValid unlifted_only - -legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity --- Check result type of 'foreign import prim'. Allow simple unlifted --- types and also unboxed tuple and sum result types. -legalFIPrimResultTyCon dflags tc - | isUnliftedTyCon tc - , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc - || not (null (tyConPrimRep tc)) -- Note [Marshalling void] - = validIfUnliftedFFITypes dflags - - | otherwise - = NotValid unlifted_only - -unlifted_only :: MsgDoc -unlifted_only = text "foreign import prim only accepts simple unlifted types" - -validIfUnliftedFFITypes :: DynFlags -> Validity -validIfUnliftedFFITypes dflags - | xopt LangExt.UnliftedFFITypes dflags = IsValid - | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes") - -{- -Note [Marshalling void] -~~~~~~~~~~~~~~~~~~~~~~~ -We don't treat State# (whose PrimRep is VoidRep) as marshalable. -In turn that means you can't write - foreign import foo :: Int -> State# RealWorld - -Reason: the back end falls over with panic "primRepHint:VoidRep"; - and there is no compelling reason to permit it --} - -{- -************************************************************************ -* * - The "Paterson size" of a type -* * -************************************************************************ --} - -{- -Note [Paterson conditions on PredTypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are considering whether *class* constraints terminate -(see Note [Paterson conditions]). Precisely, the Paterson conditions -would have us check that "the constraint has fewer constructors and variables -(taken together and counting repetitions) than the head.". - -However, we can be a bit more refined by looking at which kind of constraint -this actually is. There are two main tricks: - - 1. It seems like it should be OK not to count the tuple type constructor - for a PredType like (Show a, Eq a) :: Constraint, since we don't - count the "implicit" tuple in the ThetaType itself. - - In fact, the Paterson test just checks *each component* of the top level - ThetaType against the size bound, one at a time. By analogy, it should be - OK to return the size of the *largest* tuple component as the size of the - whole tuple. - - 2. Once we get into an implicit parameter or equality we - can't get back to a class constraint, so it's safe - to say "size 0". See Trac #4200. - -NB: we don't want to detect PredTypes in sizeType (and then call -sizePred on them), or we might get an infinite loop if that PredType -is irreducible. See Trac #5581. --} - -type TypeSize = IntWithInf - -sizeType :: Type -> TypeSize --- Size of a type: the number of variables and constructors --- Ignore kinds altogether -sizeType = go - where - go ty | Just exp_ty <- tcView ty = go exp_ty - go (TyVarTy {}) = 1 - go (TyConApp tc tys) - | isTypeFamilyTyCon tc = infinity -- Type-family applications can - -- expand to any arbitrary size - | otherwise = sizeTypes (filterOutInvisibleTypes tc tys) + 1 - go (LitTy {}) = 1 - go (FunTy arg res) = go arg + go res + 1 - go (AppTy fun arg) = go fun + go arg - go (ForAllTy (TvBndr tv vis) ty) - | isVisibleArgFlag vis = go (tyVarKind tv) + go ty + 1 - | otherwise = go ty + 1 - go (CastTy ty _) = go ty - go (CoercionTy {}) = 0 - -sizeTypes :: [Type] -> TypeSize -sizeTypes tys = sum (map sizeType tys) diff --git a/typecheck/TcType.hs-boot b/typecheck/TcType.hs-boot deleted file mode 100644 --- a/typecheck/TcType.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -module TcType where -import Outputable( SDoc ) - -data MetaDetails - -data TcTyVarDetails -pprTcTyVarDetails :: TcTyVarDetails -> SDoc -vanillaSkolemTv :: TcTyVarDetails diff --git a/typecheck/TcTypeNats.hs b/typecheck/TcTypeNats.hs deleted file mode 100644 --- a/typecheck/TcTypeNats.hs +++ /dev/null @@ -1,757 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module TcTypeNats - ( typeNatTyCons - , typeNatCoAxiomRules - , BuiltInSynFamily(..) - - , typeNatAddTyCon - , typeNatMulTyCon - , typeNatExpTyCon - , typeNatLeqTyCon - , typeNatSubTyCon - , typeNatCmpTyCon - , typeSymbolCmpTyCon - , typeSymbolAppendTyCon - ) where - -import Type -import Pair -import TcType ( TcType, tcEqType ) -import TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon - , Injectivity(..) ) -import Coercion ( Role(..) ) -import TcRnTypes ( Xi ) -import CoAxiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn ) -import Name ( Name, BuiltInSyntax(..) ) -import TysWiredIn -import TysPrim ( mkTemplateAnonTyConBinders ) -import PrelNames ( gHC_TYPELITS - , gHC_TYPENATS - , typeNatAddTyFamNameKey - , typeNatMulTyFamNameKey - , typeNatExpTyFamNameKey - , typeNatLeqTyFamNameKey - , typeNatSubTyFamNameKey - , typeNatCmpTyFamNameKey - , typeSymbolCmpTyFamNameKey - , typeSymbolAppendFamNameKey - ) -import FastString ( FastString - , fsLit, nilFS, nullFS, unpackFS, mkFastString, appendFS - ) -import qualified Data.Map as Map -import Data.Maybe ( isJust ) -import Data.List ( isPrefixOf, isSuffixOf ) - -{------------------------------------------------------------------------------- -Built-in type constructors for functions on type-level nats --} - -typeNatTyCons :: [TyCon] -typeNatTyCons = - [ typeNatAddTyCon - , typeNatMulTyCon - , typeNatExpTyCon - , typeNatLeqTyCon - , typeNatSubTyCon - , typeNatCmpTyCon - , typeSymbolCmpTyCon - , typeSymbolAppendTyCon - ] - -typeNatAddTyCon :: TyCon -typeNatAddTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamAdd - , sfInteractTop = interactTopAdd - , sfInteractInert = interactInertAdd - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "+") - typeNatAddTyFamNameKey typeNatAddTyCon - -typeNatSubTyCon :: TyCon -typeNatSubTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamSub - , sfInteractTop = interactTopSub - , sfInteractInert = interactInertSub - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-") - typeNatSubTyFamNameKey typeNatSubTyCon - -typeNatMulTyCon :: TyCon -typeNatMulTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamMul - , sfInteractTop = interactTopMul - , sfInteractInert = interactInertMul - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*") - typeNatMulTyFamNameKey typeNatMulTyCon - -typeNatExpTyCon :: TyCon -typeNatExpTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamExp - , sfInteractTop = interactTopExp - , sfInteractInert = interactInertExp - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^") - typeNatExpTyFamNameKey typeNatExpTyCon - -typeNatLeqTyCon :: TyCon -typeNatLeqTyCon = - mkFamilyTyCon name - (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) - boolTy - Nothing - (BuiltInSynFamTyCon ops) - Nothing - NotInjective - - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "<=?") - typeNatLeqTyFamNameKey typeNatLeqTyCon - ops = BuiltInSynFamily - { sfMatchFam = matchFamLeq - , sfInteractTop = interactTopLeq - , sfInteractInert = interactInertLeq - } - -typeNatCmpTyCon :: TyCon -typeNatCmpTyCon = - mkFamilyTyCon name - (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) - orderingKind - Nothing - (BuiltInSynFamTyCon ops) - Nothing - NotInjective - - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "CmpNat") - typeNatCmpTyFamNameKey typeNatCmpTyCon - ops = BuiltInSynFamily - { sfMatchFam = matchFamCmpNat - , sfInteractTop = interactTopCmpNat - , sfInteractInert = \_ _ _ _ -> [] - } - -typeSymbolCmpTyCon :: TyCon -typeSymbolCmpTyCon = - mkFamilyTyCon name - (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) - orderingKind - Nothing - (BuiltInSynFamTyCon ops) - Nothing - NotInjective - - where - name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol") - typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon - ops = BuiltInSynFamily - { sfMatchFam = matchFamCmpSymbol - , sfInteractTop = interactTopCmpSymbol - , sfInteractInert = \_ _ _ _ -> [] - } - -typeSymbolAppendTyCon :: TyCon -typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamAppendSymbol - , sfInteractTop = interactTopAppendSymbol - , sfInteractInert = interactInertAppendSymbol - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol") - typeSymbolAppendFamNameKey typeSymbolAppendTyCon - - - - --- Make a binary built-in constructor of kind: Nat -> Nat -> Nat -mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon -mkTypeNatFunTyCon2 op tcb = - mkFamilyTyCon op - (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) - typeNatKind - Nothing - (BuiltInSynFamTyCon tcb) - Nothing - NotInjective - --- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol -mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon -mkTypeSymbolFunTyCon2 op tcb = - mkFamilyTyCon op - (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) - typeSymbolKind - Nothing - (BuiltInSynFamTyCon tcb) - Nothing - NotInjective - - -{------------------------------------------------------------------------------- -Built-in rules axioms --------------------------------------------------------------------------------} - --- If you add additional rules, please remember to add them to --- `typeNatCoAxiomRules` also. -axAddDef - , axMulDef - , axExpDef - , axLeqDef - , axCmpNatDef - , axCmpSymbolDef - , axAppendSymbolDef - , axAdd0L - , axAdd0R - , axMul0L - , axMul0R - , axMul1L - , axMul1R - , axExp1L - , axExp0R - , axExp1R - , axLeqRefl - , axCmpNatRefl - , axCmpSymbolRefl - , axLeq0L - , axSubDef - , axSub0R - , axAppendSymbol0R - , axAppendSymbol0L - :: CoAxiomRule - -axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $ - \x y -> Just $ num (x + y) - -axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $ - \x y -> Just $ num (x * y) - -axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $ - \x y -> Just $ num (x ^ y) - -axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $ - \x y -> Just $ bool (x <= y) - -axCmpNatDef = mkBinAxiom "CmpNatDef" typeNatCmpTyCon - $ \x y -> Just $ ordering (compare x y) - -axCmpSymbolDef = - CoAxiomRule - { coaxrName = fsLit "CmpSymbolDef" - , coaxrAsmpRoles = [Nominal, Nominal] - , coaxrRole = Nominal - , coaxrProves = \cs -> - do [Pair s1 s2, Pair t1 t2] <- return cs - s2' <- isStrLitTy s2 - t2' <- isStrLitTy t2 - return (mkTyConApp typeSymbolCmpTyCon [s1,t1] === - ordering (compare s2' t2')) } - -axAppendSymbolDef = CoAxiomRule - { coaxrName = fsLit "AppendSymbolDef" - , coaxrAsmpRoles = [Nominal, Nominal] - , coaxrRole = Nominal - , coaxrProves = \cs -> - do [Pair s1 s2, Pair t1 t2] <- return cs - s2' <- isStrLitTy s2 - t2' <- isStrLitTy t2 - let z = mkStrLitTy (appendFS s2' t2') - return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z) - } - -axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $ - \x y -> fmap num (minus x y) - -axAdd0L = mkAxiom1 "Add0L" $ \(Pair s t) -> (num 0 .+. s) === t -axAdd0R = mkAxiom1 "Add0R" $ \(Pair s t) -> (s .+. num 0) === t -axSub0R = mkAxiom1 "Sub0R" $ \(Pair s t) -> (s .-. num 0) === t -axMul0L = mkAxiom1 "Mul0L" $ \(Pair s _) -> (num 0 .*. s) === num 0 -axMul0R = mkAxiom1 "Mul0R" $ \(Pair s _) -> (s .*. num 0) === num 0 -axMul1L = mkAxiom1 "Mul1L" $ \(Pair s t) -> (num 1 .*. s) === t -axMul1R = mkAxiom1 "Mul1R" $ \(Pair s t) -> (s .*. num 1) === t -axExp1L = mkAxiom1 "Exp1L" $ \(Pair s _) -> (num 1 .^. s) === num 1 -axExp0R = mkAxiom1 "Exp0R" $ \(Pair s _) -> (s .^. num 0) === num 1 -axExp1R = mkAxiom1 "Exp1R" $ \(Pair s t) -> (s .^. num 1) === t -axLeqRefl = mkAxiom1 "LeqRefl" $ \(Pair s _) -> (s <== s) === bool True -axCmpNatRefl = mkAxiom1 "CmpNatRefl" - $ \(Pair s _) -> (cmpNat s s) === ordering EQ -axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl" - $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ -axLeq0L = mkAxiom1 "Leq0L" $ \(Pair s _) -> (num 0 <== s) === bool True -axAppendSymbol0R = mkAxiom1 "Concat0R" - $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t -axAppendSymbol0L = mkAxiom1 "Concat0L" - $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t - -typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule -typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x)) - [ axAddDef - , axMulDef - , axExpDef - , axLeqDef - , axCmpNatDef - , axCmpSymbolDef - , axAppendSymbolDef - , axAdd0L - , axAdd0R - , axMul0L - , axMul0R - , axMul1L - , axMul1R - , axExp1L - , axExp0R - , axExp1R - , axLeqRefl - , axCmpNatRefl - , axCmpSymbolRefl - , axLeq0L - , axSubDef - , axAppendSymbol0R - , axAppendSymbol0L - ] - - - -{------------------------------------------------------------------------------- -Various utilities for making axioms and types --------------------------------------------------------------------------------} - -(.+.) :: Type -> Type -> Type -s .+. t = mkTyConApp typeNatAddTyCon [s,t] - -(.-.) :: Type -> Type -> Type -s .-. t = mkTyConApp typeNatSubTyCon [s,t] - -(.*.) :: Type -> Type -> Type -s .*. t = mkTyConApp typeNatMulTyCon [s,t] - -(.^.) :: Type -> Type -> Type -s .^. t = mkTyConApp typeNatExpTyCon [s,t] - -(<==) :: Type -> Type -> Type -s <== t = mkTyConApp typeNatLeqTyCon [s,t] - -cmpNat :: Type -> Type -> Type -cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t] - -cmpSymbol :: Type -> Type -> Type -cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t] - -appendSymbol :: Type -> Type -> Type -appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t] - -(===) :: Type -> Type -> Pair Type -x === y = Pair x y - -num :: Integer -> Type -num = mkNumLitTy - -bool :: Bool -> Type -bool b = if b then mkTyConApp promotedTrueDataCon [] - else mkTyConApp promotedFalseDataCon [] - -isBoolLitTy :: Type -> Maybe Bool -isBoolLitTy tc = - do (tc,[]) <- splitTyConApp_maybe tc - case () of - _ | tc == promotedFalseDataCon -> return False - | tc == promotedTrueDataCon -> return True - | otherwise -> Nothing - -orderingKind :: Kind -orderingKind = mkTyConApp orderingTyCon [] - -ordering :: Ordering -> Type -ordering o = - case o of - LT -> mkTyConApp promotedLTDataCon [] - EQ -> mkTyConApp promotedEQDataCon [] - GT -> mkTyConApp promotedGTDataCon [] - -isOrderingLitTy :: Type -> Maybe Ordering -isOrderingLitTy tc = - do (tc1,[]) <- splitTyConApp_maybe tc - case () of - _ | tc1 == promotedLTDataCon -> return LT - | tc1 == promotedEQDataCon -> return EQ - | tc1 == promotedGTDataCon -> return GT - | otherwise -> Nothing - -known :: (Integer -> Bool) -> TcType -> Bool -known p x = case isNumLitTy x of - Just a -> p a - Nothing -> False - - - - --- For the definitional axioms -mkBinAxiom :: String -> TyCon -> - (Integer -> Integer -> Maybe Type) -> CoAxiomRule -mkBinAxiom str tc f = - CoAxiomRule - { coaxrName = fsLit str - , coaxrAsmpRoles = [Nominal, Nominal] - , coaxrRole = Nominal - , coaxrProves = \cs -> - do [Pair s1 s2, Pair t1 t2] <- return cs - s2' <- isNumLitTy s2 - t2' <- isNumLitTy t2 - z <- f s2' t2' - return (mkTyConApp tc [s1,t1] === z) - } - - - -mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule -mkAxiom1 str f = - CoAxiomRule - { coaxrName = fsLit str - , coaxrAsmpRoles = [Nominal] - , coaxrRole = Nominal - , coaxrProves = \case [eqn] -> Just (f eqn) - _ -> Nothing - } - - -{------------------------------------------------------------------------------- -Evaluation --------------------------------------------------------------------------------} - -matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamAdd [s,t] - | Just 0 <- mbX = Just (axAdd0L, [t], t) - | Just 0 <- mbY = Just (axAdd0R, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axAddDef, [s,t], num (x + y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamAdd _ = Nothing - -matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamSub [s,t] - | Just 0 <- mbY = Just (axSub0R, [s], s) - | Just x <- mbX, Just y <- mbY, Just z <- minus x y = - Just (axSubDef, [s,t], num z) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamSub _ = Nothing - -matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamMul [s,t] - | Just 0 <- mbX = Just (axMul0L, [t], num 0) - | Just 0 <- mbY = Just (axMul0R, [s], num 0) - | Just 1 <- mbX = Just (axMul1L, [t], t) - | Just 1 <- mbY = Just (axMul1R, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axMulDef, [s,t], num (x * y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamMul _ = Nothing - -matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamExp [s,t] - | Just 0 <- mbY = Just (axExp0R, [s], num 1) - | Just 1 <- mbX = Just (axExp1L, [t], num 1) - | Just 1 <- mbY = Just (axExp1R, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axExpDef, [s,t], num (x ^ y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamExp _ = Nothing - -matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamLeq [s,t] - | Just 0 <- mbX = Just (axLeq0L, [t], bool True) - | Just x <- mbX, Just y <- mbY = - Just (axLeqDef, [s,t], bool (x <= y)) - | tcEqType s t = Just (axLeqRefl, [s], bool True) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamLeq _ = Nothing - -matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamCmpNat [s,t] - | Just x <- mbX, Just y <- mbY = - Just (axCmpNatDef, [s,t], ordering (compare x y)) - | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamCmpNat _ = Nothing - -matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamCmpSymbol [s,t] - | Just x <- mbX, Just y <- mbY = - Just (axCmpSymbolDef, [s,t], ordering (compare x y)) - | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ) - where mbX = isStrLitTy s - mbY = isStrLitTy t -matchFamCmpSymbol _ = Nothing - -matchFamAppendSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamAppendSymbol [s,t] - | Just x <- mbX, nullFS x = Just (axAppendSymbol0R, [t], t) - | Just y <- mbY, nullFS y = Just (axAppendSymbol0L, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axAppendSymbolDef, [s,t], mkStrLitTy (appendFS x y)) - where - mbX = isStrLitTy s - mbY = isStrLitTy t -matchFamAppendSymbol _ = Nothing - -{------------------------------------------------------------------------------- -Interact with axioms --------------------------------------------------------------------------------} - -interactTopAdd :: [Xi] -> Xi -> [Pair Type] -interactTopAdd [s,t] r - | Just 0 <- mbZ = [ s === num 0, t === num 0 ] -- (s + t ~ 0) => (s ~ 0, t ~ 0) - | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y] -- (5 + t ~ 8) => (t ~ 3) - | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x] -- (s + 5 ~ 8) => (s ~ 3) - where - mbX = isNumLitTy s - mbY = isNumLitTy t - mbZ = isNumLitTy r -interactTopAdd _ _ = [] - -{- -Note [Weakened interaction rule for subtraction] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A simpler interaction here might be: - - `s - t ~ r` --> `t + r ~ s` - -This would enable us to reuse all the code for addition. -Unfortunately, this works a little too well at the moment. -Consider the following example: - - 0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0) - -This (correctly) spots that the constraint cannot be solved. - -However, this may be a problem if the constraint did not -need to be solved in the first place! Consider the following example: - -f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5 -f = id - -Currently, GHC is strict while evaluating functions, so this does not -work, because even though the `If` should evaluate to `5 - 0`, we -also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`, -which fails. - -So, for the time being, we only add an improvement when the RHS is a constant, -which happens to work OK for the moment, although clearly we need to do -something more general. --} -interactTopSub :: [Xi] -> Xi -> [Pair Type] -interactTopSub [s,t] r - | Just z <- mbZ = [ s === (num z .+. t) ] -- (s - t ~ 5) => (5 + t ~ s) - where - mbZ = isNumLitTy r -interactTopSub _ _ = [] - - - - - -interactTopMul :: [Xi] -> Xi -> [Pair Type] -interactTopMul [s,t] r - | Just 1 <- mbZ = [ s === num 1, t === num 1 ] -- (s * t ~ 1) => (s ~ 1, t ~ 1) - | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y] -- (3 * t ~ 15) => (t ~ 5) - | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x] -- (s * 3 ~ 15) => (s ~ 5) - where - mbX = isNumLitTy s - mbY = isNumLitTy t - mbZ = isNumLitTy r -interactTopMul _ _ = [] - -interactTopExp :: [Xi] -> Xi -> [Pair Type] -interactTopExp [s,t] r - | Just 0 <- mbZ = [ s === num 0 ] -- (s ^ t ~ 0) => (s ~ 0) - | Just x <- mbX, Just z <- mbZ, Just y <- logExact z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3) - | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3) - where - mbX = isNumLitTy s - mbY = isNumLitTy t - mbZ = isNumLitTy r -interactTopExp _ _ = [] - -interactTopLeq :: [Xi] -> Xi -> [Pair Type] -interactTopLeq [s,t] r - | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ] -- (s <= 0) => (s ~ 0) - where - mbY = isNumLitTy t - mbZ = isBoolLitTy r -interactTopLeq _ _ = [] - -interactTopCmpNat :: [Xi] -> Xi -> [Pair Type] -interactTopCmpNat [s,t] r - | Just EQ <- isOrderingLitTy r = [ s === t ] -interactTopCmpNat _ _ = [] - -interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type] -interactTopCmpSymbol [s,t] r - | Just EQ <- isOrderingLitTy r = [ s === t ] -interactTopCmpSymbol _ _ = [] - -interactTopAppendSymbol :: [Xi] -> Xi -> [Pair Type] -interactTopAppendSymbol [s,t] r - -- (AppendSymbol a b ~ "") => (a ~ "", b ~ "") - | Just z <- mbZ, nullFS z = - [s === mkStrLitTy nilFS, t === mkStrLitTy nilFS ] - - -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar") - | Just x <- fmap unpackFS mbX, Just z <- fmap unpackFS mbZ, x `isPrefixOf` z = - [ t === mkStrLitTy (mkFastString $ drop (length x) z) ] - - -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo") - | Just y <- fmap unpackFS mbY, Just z <- fmap unpackFS mbZ, y `isSuffixOf` z = - [ t === mkStrLitTy (mkFastString $ take (length z - length y) z) ] - - where - mbX = isStrLitTy s - mbY = isStrLitTy t - mbZ = isStrLitTy r - -interactTopAppendSymbol _ _ = [] - -{------------------------------------------------------------------------------- -Interaction with inerts --------------------------------------------------------------------------------} - -interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertAdd [x1,y1] z1 [x2,y2] z2 - | sameZ && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 -interactInertAdd _ _ _ _ = [] - -interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertSub [x1,y1] z1 [x2,y2] z2 - | sameZ && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 -interactInertSub _ _ _ _ = [] - -interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertMul [x1,y1] z1 [x2,y2] z2 - | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 - -interactInertMul _ _ _ _ = [] - -interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertExp [x1,y1] z1 [x2,y2] z2 - | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 - -interactInertExp _ _ _ _ = [] - - -interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertLeq [x1,y1] z1 [x2,y2] z2 - | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ] - | bothTrue && tcEqType y1 x2 = [ (x1 <== y2) === bool True ] - | bothTrue && tcEqType y2 x1 = [ (x2 <== y1) === bool True ] - where bothTrue = isJust $ do True <- isBoolLitTy z1 - True <- isBoolLitTy z2 - return () - -interactInertLeq _ _ _ _ = [] - - -interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2 - | sameZ && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 -interactInertAppendSymbol _ _ _ _ = [] - - - -{- ----------------------------------------------------------------------------- -These inverse functions are used for simplifying propositions using -concrete natural numbers. ------------------------------------------------------------------------------ -} - --- | Subtract two natural numbers. -minus :: Integer -> Integer -> Maybe Integer -minus x y = if x >= y then Just (x - y) else Nothing - --- | Compute the exact logarithm of a natural number. --- The logarithm base is the second argument. -logExact :: Integer -> Integer -> Maybe Integer -logExact x y = do (z,True) <- genLog x y - return z - - --- | Divide two natural numbers. -divide :: Integer -> Integer -> Maybe Integer -divide _ 0 = Nothing -divide x y = case divMod x y of - (a,0) -> Just a - _ -> Nothing - --- | Compute the exact root of a natural number. --- The second argument specifies which root we are computing. -rootExact :: Integer -> Integer -> Maybe Integer -rootExact x y = do (z,True) <- genRoot x y - return z - - - -{- | Compute the the n-th root of a natural number, rounded down to -the closest natural number. The boolean indicates if the result -is exact (i.e., True means no rounding was done, False means rounded down). -The second argument specifies which root we are computing. -} -genRoot :: Integer -> Integer -> Maybe (Integer, Bool) -genRoot _ 0 = Nothing -genRoot x0 1 = Just (x0, True) -genRoot x0 root = Just (search 0 (x0+1)) - where - search from to = let x = from + div (to - from) 2 - a = x ^ root - in case compare a x0 of - EQ -> (x, True) - LT | x /= from -> search x to - | otherwise -> (from, False) - GT | x /= to -> search from x - | otherwise -> (from, False) - -{- | Compute the logarithm of a number in the given base, rounded down to the -closest integer. The boolean indicates if we the result is exact -(i.e., True means no rounding happened, False means we rounded down). -The logarithm base is the second argument. -} -genLog :: Integer -> Integer -> Maybe (Integer, Bool) -genLog x 0 = if x == 1 then Just (0, True) else Nothing -genLog _ 1 = Nothing -genLog 0 _ = Nothing -genLog x base = Just (exactLoop 0 x) - where - exactLoop s i - | i == 1 = (s,True) - | i < base = (s,False) - | otherwise = - let s1 = s + 1 - in s1 `seq` case divMod i base of - (j,r) - | r == 0 -> exactLoop s1 j - | otherwise -> (underLoop s1 j, False) - - underLoop s i - | i < base = s - | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base) diff --git a/typecheck/TcTypeNats.hs-boot b/typecheck/TcTypeNats.hs-boot deleted file mode 100644 --- a/typecheck/TcTypeNats.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module TcTypeNats where - -import TyCon (TyCon) - -typeNatTyCons :: [TyCon] diff --git a/typecheck/TcTypeable.hs b/typecheck/TcTypeable.hs deleted file mode 100644 --- a/typecheck/TcTypeable.hs +++ /dev/null @@ -1,701 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 --} - -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module TcTypeable(mkTypeableBinds) where - - -import BasicTypes ( SourceText(..), Boxity(..), neverInlinePragma ) -import TcBinds( addTypecheckedBinds ) -import IfaceEnv( newGlobalBinder ) -import TyCoRep( Type(..), TyLit(..) ) -import TcEnv -import TcEvidence ( mkWpTyApps ) -import TcRnMonad -import HscTypes ( lookupId ) -import PrelNames -import TysPrim ( primTyCons ) -import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon - , vecCountTyCon, vecElemTyCon - , nilDataCon, consDataCon ) -import Id -import Type -import Kind ( isTYPEApp ) -import TyCon -import DataCon -import Name ( Name, getOccName ) -import OccName -import Module -import HsSyn -import DynFlags -import Bag -import Var ( TyVarBndr(..) ) -import TrieMap -import Constants -import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) -import Outputable -import FastString ( FastString, mkFastString, fsLit ) - -import Control.Monad.Trans.State -import Control.Monad.Trans.Class (lift) -import Data.Maybe ( isJust ) -import Data.Word( Word64 ) - -{- Note [Grand plan for Typeable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The overall plan is this: - -1. Generate a binding for each module p:M - (done in TcTypeable by mkModIdBindings) - M.$trModule :: GHC.Types.Module - M.$trModule = Module "p" "M" - ("tr" is short for "type representation"; see GHC.Types) - - We might want to add the filename too. - This can be used for the lightweight stack-tracing stuff too - - Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv - -2. Generate a binding for every data type declaration T in module M, - M.$tcT :: GHC.Types.TyCon - M.$tcT = TyCon ...fingerprint info... - $trModule - "T" - 0# - kind_rep - - Here 0# is the number of arguments expected by the tycon to fully determine - its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a - recipe for computing the kind of an instantiation of the tycon (see - Note [Representing TyCon kinds] later in this file for details). - - We define (in TyCon) - - type TyConRepName = Name - - to use for these M.$tcT "tycon rep names". Note that these must be - treated as "never exported" names by Backpack (see - Note [Handling never-exported TyThings under Backpack]). Consequently - they get slightly special treatment in RnModIface.rnIfaceDecl. - -3. Record the TyConRepName in T's TyCon, including for promoted - data and type constructors, and kinds like * and #. - - The TyConRepName is not an "implicit Id". It's more like a record - selector: the TyCon knows its name but you have to go to the - interface file to find its type, value, etc - -4. Solve Typeable constraints. This is done by a custom Typeable solver, - currently in TcInteract, that use M.$tcT so solve (Typeable T). - -There are many wrinkles: - -* The timing of when we produce this bindings is rather important: they must be - defined after the rest of the module has been typechecked since we need to be - able to lookup Module and TyCon in the type environment and we may be - currently compiling GHC.Types (where they are defined). - -* GHC.Prim doesn't have any associated object code, so we need to put the - representations for types defined in this module elsewhere. We chose this - place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for - injecting the bindings for the GHC.Prim representions when compiling - GHC.Types. - -* TyCon.tyConRepModOcc is responsible for determining where to find - the representation binding for a given type. This is where we handle - the special case for GHC.Prim. - -* To save space and reduce dependencies, we need use quite low-level - representations for TyCon and Module. See GHC.Types - Note [Runtime representation of modules and tycons] - -* The KindReps can unfortunately get quite large. Moreover, the simplifier will - float out various pieces of them, resulting in numerous top-level bindings. - Consequently we mark the KindRep bindings as noinline, ensuring that the - float-outs don't make it into the interface file. This is important since - there is generally little benefit to inlining KindReps and they would - otherwise strongly affect compiler performance. - -* In general there are lots of things of kind *, * -> *, and * -> * -> *. To - reduce the number of bindings we need to produce, we generate their KindReps - once in GHC.Types. These are referred to as "built-in" KindReps below. - -* Even though KindReps aren't inlined, this scheme still has more of an effect on - compilation time than I'd like. This is especially true in the case of - families of type constructors (e.g. tuples and unboxed sums). The problem is - particularly bad in the case of sums, since each arity-N tycon brings with it - N promoted datacons, each with a KindRep whose size also scales with N. - Consequently we currently simply don't allow sums to be Typeable. - - In general we might consider moving some or all of this generation logic back - to the solver since the performance hit we take in doing this at - type-definition time is non-trivial and Typeable isn't very widely used. This - is discussed in #13261. - --} - --- | Generate the Typeable bindings for a module. This is the only --- entry-point of this module and is invoked by the typechecker driver in --- 'tcRnSrcDecls'. --- --- See Note [Grand plan for Typeable] in TcTypeable. -mkTypeableBinds :: TcM TcGblEnv -mkTypeableBinds - = do { -- Create a binding for $trModule. - -- Do this before processing any data type declarations, - -- which need tcg_tr_module to be initialised - ; tcg_env <- mkModIdBindings - -- Now we can generate the TyCon representations... - -- First we handle the primitive TyCons if we are compiling GHC.Types - ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos - - -- Then we produce bindings for the user-defined types in this module. - ; setGblEnv tcg_env $ - do { mod <- getModule - ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env) - mod_id = case tcg_tr_module tcg_env of -- Should be set by now - Just mod_id -> mod_id - Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons) - ; traceTc "mkTypeableBinds" (ppr tycons) - ; this_mod_todos <- todoForTyCons mod mod_id tycons - ; mkTypeRepTodoBinds (this_mod_todos : prim_todos) - } } - where - needs_typeable_binds tc - | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon] - = False - | otherwise = - isAlgTyCon tc - || isDataFamilyTyCon tc - || isClassTyCon tc - - -{- ********************************************************************* -* * - Building top-level binding for $trModule -* * -********************************************************************* -} - -mkModIdBindings :: TcM TcGblEnv -mkModIdBindings - = do { mod <- getModule - ; loc <- getSrcSpanM - ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc - ; trModuleTyCon <- tcLookupTyCon trModuleTyConName - ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon []) - ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod - - ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv - ; return (tcg_env { tcg_tr_module = Just mod_id } - `addTypecheckedBinds` [unitBag mod_bind]) } - -mkModIdRHS :: Module -> TcM (LHsExpr Id) -mkModIdRHS mod - = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName - ; trNameLit <- mkTrNameLit - ; return $ nlHsDataCon trModuleDataCon - `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod)) - `nlHsApp` trNameLit (moduleNameFS (moduleName mod)) - } - -{- ********************************************************************* -* * - Building type-representation bindings -* * -********************************************************************* -} - --- | Information we need about a 'TyCon' to generate its representation. We --- carry the 'Id' in order to share it between the generation of the @TyCon@ and --- @KindRep@ bindings. -data TypeableTyCon - = TypeableTyCon - { tycon :: !TyCon - , tycon_rep_id :: !Id - } - --- | A group of 'TyCon's in need of type-rep bindings. -data TypeRepTodo - = TypeRepTodo - { mod_rep_expr :: LHsExpr Id -- ^ Module's typerep binding - , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint - , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint - , todo_tycons :: [TypeableTyCon] - -- ^ The 'TyCon's in need of bindings kinds - } - | ExportedKindRepsTodo [(Kind, Id)] - -- ^ Build exported 'KindRep' bindings for the given set of kinds. - -todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo -todoForTyCons mod mod_id tycons = do - trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName - let mk_rep_id :: TyConRepName -> Id - mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy - - let typeable_tycons :: [TypeableTyCon] - typeable_tycons = - [ TypeableTyCon { tycon = tc'' - , tycon_rep_id = mk_rep_id rep_name - } - | tc <- tycons - , tc' <- tc : tyConATs tc - -- We need type representations for any associated types - , let promoted = map promoteDataCon (tyConDataCons tc') - , tc'' <- tc' : promoted - -- Don't make bindings for data-family instance tycons. - -- Do, however, make them for their promoted datacon (see #13915). - , not $ isFamInstTyCon tc'' - , Just rep_name <- pure $ tyConRepName_maybe tc'' - , typeIsTypeable $ dropForAlls $ tyConKind tc'' - ] - return TypeRepTodo { mod_rep_expr = nlHsVar mod_id - , pkg_fingerprint = pkg_fpr - , mod_fingerprint = mod_fpr - , todo_tycons = typeable_tycons - } - where - mod_fpr = fingerprintString $ moduleNameString $ moduleName mod - pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod - -todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo -todoForExportedKindReps kinds = do - trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName - let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy) - return $ ExportedKindRepsTodo $ map mkId kinds - --- | Generate TyCon bindings for a set of type constructors -mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv -mkTypeRepTodoBinds [] = getGblEnv -mkTypeRepTodoBinds todos - = do { stuff <- collect_stuff - - -- First extend the type environment with all of the bindings - -- which we are going to produce since we may need to refer to them - -- while generating kind representations (namely, when we want to - -- represent a TyConApp in a kind, we must be able to look up the - -- TyCon associated with the applied type constructor). - ; let produced_bndrs :: [Id] - produced_bndrs = [ tycon_rep_id - | todo@(TypeRepTodo{}) <- todos - , TypeableTyCon {..} <- todo_tycons todo - ] ++ - [ rep_id - | ExportedKindRepsTodo kinds <- todos - , (_, rep_id) <- kinds - ] - ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv - - ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds Id] - mk_binds todo@(TypeRepTodo {}) = - mapM (mkTyConRepBinds stuff todo) (todo_tycons todo) - mk_binds (ExportedKindRepsTodo kinds) = - mkExportedKindReps stuff kinds >> return [] - - ; (gbl_env, binds) <- setGblEnv gbl_env - $ runKindRepM (mapM mk_binds todos) - ; return $ gbl_env `addTypecheckedBinds` concat binds } - --- | Generate bindings for the type representation of a wired-in 'TyCon's --- defined by the virtual "GHC.Prim" module. This is where we inject the --- representation bindings for these primitive types into "GHC.Types" --- --- See Note [Grand plan for Typeable] in this module. -mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo]) -mkPrimTypeableTodos - = do { mod <- getModule - ; if mod == gHC_TYPES - then do { -- Build Module binding for GHC.Prim - trModuleTyCon <- tcLookupTyCon trModuleTyConName - ; let ghc_prim_module_id = - mkExportedVanillaId trGhcPrimModuleName - (mkTyConTy trModuleTyCon) - - ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id - <$> mkModIdRHS gHC_PRIM - - -- Extend our environment with above - ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id] - getGblEnv - ; let gbl_env' = gbl_env `addTypecheckedBinds` - [unitBag ghc_prim_module_bind] - - -- Build TypeRepTodos for built-in KindReps - ; todo1 <- todoForExportedKindReps builtInKindReps - -- Build TypeRepTodos for types in GHC.Prim - ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id - ghcPrimTypeableTyCons - ; return ( gbl_env' , [todo1, todo2]) - } - else do gbl_env <- getGblEnv - return (gbl_env, []) - } - --- | This is the list of primitive 'TyCon's for which we must generate bindings --- in "GHC.Types". This should include all types defined in "GHC.Prim". --- --- The majority of the types we need here are contained in 'primTyCons'. --- However, not all of them: in particular unboxed tuples are absent since we --- don't want to include them in the original name cache. See --- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more. -ghcPrimTypeableTyCons :: [TyCon] -ghcPrimTypeableTyCons = concat - [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon - , funTyCon, tupleTyCon Unboxed 0 ] - , map (tupleTyCon Unboxed) [2..mAX_TUPLE_SIZE] - , map sumTyCon [2..mAX_SUM_SIZE] - , primTyCons - ] - -data TypeableStuff - = Stuff { dflags :: DynFlags - , trTyConDataCon :: DataCon -- ^ of @TyCon@ - , trNameLit :: FastString -> LHsExpr Id - -- ^ To construct @TrName@s - -- The various TyCon and DataCons of KindRep - , kindRepTyCon :: TyCon - , kindRepTyConAppDataCon :: DataCon - , kindRepVarDataCon :: DataCon - , kindRepAppDataCon :: DataCon - , kindRepFunDataCon :: DataCon - , kindRepTYPEDataCon :: DataCon - , kindRepTypeLitSDataCon :: DataCon - , typeLitSymbolDataCon :: DataCon - , typeLitNatDataCon :: DataCon - } - --- | Collect various tidbits which we'll need to generate TyCon representations. -collect_stuff :: TcM TypeableStuff -collect_stuff = do - dflags <- getDynFlags - trTyConDataCon <- tcLookupDataCon trTyConDataConName - kindRepTyCon <- tcLookupTyCon kindRepTyConName - kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName - kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName - kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName - kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName - kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName - kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName - typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName - typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName - trNameLit <- mkTrNameLit - return Stuff {..} - --- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we --- can save the work of repeating lookups when constructing many TyCon --- representations. -mkTrNameLit :: TcM (FastString -> LHsExpr Id) -mkTrNameLit = do - trNameSDataCon <- tcLookupDataCon trNameSDataConName - let trNameLit :: FastString -> LHsExpr Id - trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit fs) - return trNameLit - --- | Make Typeable bindings for the given 'TyCon'. -mkTyConRepBinds :: TypeableStuff -> TypeRepTodo - -> TypeableTyCon -> KindRepM (LHsBinds Id) -mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..}) - = do -- Make a KindRep - let (bndrs, kind) = splitForAllTyVarBndrs (tyConKind tycon) - liftTc $ traceTc "mkTyConKindRepBinds" - (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind) - let ctx = mkDeBruijnContext (map binderVar bndrs) - kind_rep <- getKindRep stuff ctx kind - - -- Make the TyCon binding - let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep - tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs - return $ unitBag tycon_rep_bind - --- | Here is where we define the set of Typeable types. These exclude type --- families and polytypes. -tyConIsTypeable :: TyCon -> Bool -tyConIsTypeable tc = - isJust (tyConRepName_maybe tc) - && typeIsTypeable (dropForAlls $ tyConKind tc) - -- Ensure that the kind of the TyCon, with its initial foralls removed, - -- is representable (e.g. has no higher-rank polymorphism or type - -- synonyms). - --- | Is a particular 'Type' representable by @Typeable@? Here we look for --- polytypes and types containing casts (which may be, for instance, a type --- family). -typeIsTypeable :: Type -> Bool --- We handle types of the form (TYPE rep) specifically to avoid --- looping on (tyConIsTypeable RuntimeRep) -typeIsTypeable ty - | Just ty' <- coreView ty = typeIsTypeable ty' -typeIsTypeable ty - | Just _ <- isTYPEApp ty = True -typeIsTypeable (TyVarTy _) = True -typeIsTypeable (AppTy a b) = typeIsTypeable a && typeIsTypeable b -typeIsTypeable (FunTy a b) = typeIsTypeable a && typeIsTypeable b -typeIsTypeable (TyConApp tc args) = tyConIsTypeable tc - && all typeIsTypeable args -typeIsTypeable (ForAllTy{}) = False -typeIsTypeable (LitTy _) = True -typeIsTypeable (CastTy{}) = False -typeIsTypeable (CoercionTy{}) = False - --- | Maps kinds to 'KindRep' bindings. This binding may either be defined in --- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing') --- or a binding which we generated in the current module (in which case it will --- be 'Just' the RHS of the binding). -type KindRepEnv = TypeMap (Id, Maybe (LHsExpr Id)) - --- | A monad within which we will generate 'KindRep's. Here we keep an --- environment containing 'KindRep's which we've already generated so we can --- re-use them opportunistically. -newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a } - deriving (Functor, Applicative, Monad) - -liftTc :: TcRn a -> KindRepM a -liftTc = KindRepM . lift - --- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they --- can be reused across modules. -builtInKindReps :: [(Kind, Name)] -builtInKindReps = - [ (star, starKindRepName) - , (mkFunTy star star, starArrStarKindRepName) - , (mkFunTys [star, star] star, starArrStarArrStarKindRepName) - ] - where - star = liftedTypeKind - -initialKindRepEnv :: TcRn KindRepEnv -initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps - where - add_kind_rep acc (k,n) = do - id <- tcLookupId n - return $! extendTypeMap acc k (id, Nothing) - --- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's. -mkExportedKindReps :: TypeableStuff - -> [(Kind, Id)] -- ^ the kinds to generate bindings for - -> KindRepM () -mkExportedKindReps stuff@(Stuff {..}) = mapM_ kindrep_binding - where - empty_scope = mkDeBruijnContext [] - - kindrep_binding :: (Kind, Id) -> KindRepM () - kindrep_binding (kind, rep_bndr) = do - -- We build the binding manually here instead of using mkKindRepRhs - -- since the latter would find the built-in 'KindRep's in the - -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv'). - rhs <- mkKindRepRhs stuff empty_scope kind - addKindRepBind empty_scope kind rep_bndr rhs - -addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr Id -> KindRepM () -addKindRepBind in_scope k bndr rhs = - KindRepM $ modify' $ - \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs) - --- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking --- environment. -runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a) -runKindRepM (KindRepM action) = do - kindRepEnv <- initialKindRepEnv - (res, reps_env) <- runStateT action kindRepEnv - let rep_binds = foldTypeMap to_bind_pair [] reps_env - to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest - to_bind_pair (_, Nothing) rest = rest - tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv - let binds = map (uncurry mkVarBind) rep_binds - tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds] - return (tcg_env', res) - --- | Produce or find a 'KindRep' for the given kind. -getKindRep :: TypeableStuff -> CmEnv -- ^ in-scope kind variables - -> Kind -- ^ the kind we want a 'KindRep' for - -> KindRepM (LHsExpr Id) -getKindRep stuff@(Stuff {..}) in_scope = go - where - go :: Kind -> KindRepM (LHsExpr Id) - go = KindRepM . StateT . go' - - go' :: Kind -> KindRepEnv -> TcRn (LHsExpr Id, KindRepEnv) - go' k env - -- Look through type synonyms - | Just k' <- tcView k = go' k' env - - -- We've already generated the needed KindRep - | Just (id, _) <- lookupTypeMapWithScope env in_scope k - = return (nlHsVar id, env) - - -- We need to construct a new KindRep binding - | otherwise - = do -- Place a NOINLINE pragma on KindReps since they tend to be quite - -- large and bloat interface files. - rep_bndr <- (`setInlinePragma` neverInlinePragma) - <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon) - - -- do we need to tie a knot here? - flip runStateT env $ unKindRepM $ do - rhs <- mkKindRepRhs stuff in_scope k - addKindRepBind in_scope k rep_bndr rhs - return $ nlHsVar rep_bndr - --- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and --- in-scope kind variable set. -mkKindRepRhs :: TypeableStuff - -> CmEnv -- ^ in-scope kind variables - -> Kind -- ^ the kind we want a 'KindRep' for - -> KindRepM (LHsExpr Id) -- ^ RHS expression -mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep - where - new_kind_rep k - -- We handle TYPE separately to make it clear to consumers - -- (e.g. serializers) that there is a loop here (as - -- TYPE :: RuntimeRep -> TYPE 'LiftedRep) - | Just rr <- isTYPEApp k - = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon rr - - new_kind_rep (TyVarTy v) - | Just idx <- lookupCME in_scope v - = return $ nlHsDataCon kindRepVarDataCon - `nlHsApp` nlHsIntLit (fromIntegral idx) - | otherwise - = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v) - - new_kind_rep (AppTy t1 t2) - = do rep1 <- getKindRep stuff in_scope t1 - rep2 <- getKindRep stuff in_scope t2 - return $ nlHsDataCon kindRepAppDataCon - `nlHsApp` rep1 `nlHsApp` rep2 - - new_kind_rep k@(TyConApp tc tys) - | Just rep_name <- tyConRepName_maybe tc - = do rep_id <- liftTc $ lookupId rep_name - tys' <- mapM (getKindRep stuff in_scope) tys - return $ nlHsDataCon kindRepTyConAppDataCon - `nlHsApp` nlHsVar rep_id - `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys' - | otherwise - = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k) - - new_kind_rep (ForAllTy (TvBndr var _) ty) - = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) - - new_kind_rep (FunTy t1 t2) - = do rep1 <- getKindRep stuff in_scope t1 - rep2 <- getKindRep stuff in_scope t2 - return $ nlHsDataCon kindRepFunDataCon - `nlHsApp` rep1 `nlHsApp` rep2 - - new_kind_rep (LitTy (NumTyLit n)) - = return $ nlHsDataCon kindRepTypeLitSDataCon - `nlHsApp` nlHsDataCon typeLitNatDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n) - - new_kind_rep (LitTy (StrTyLit s)) - = return $ nlHsDataCon kindRepTypeLitSDataCon - `nlHsApp` nlHsDataCon typeLitSymbolDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s) - - new_kind_rep (CastTy ty co) - = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co) - - new_kind_rep (CoercionTy co) - = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co) - --- | Produce the right-hand-side of a @TyCon@ representation. -mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo - -> TyCon -- ^ the 'TyCon' we are producing a binding for - -> LHsExpr Id -- ^ its 'KindRep' - -> LHsExpr Id -mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep - = nlHsDataCon trTyConDataCon - `nlHsApp` nlHsLit (word64 dflags high) - `nlHsApp` nlHsLit (word64 dflags low) - `nlHsApp` mod_rep_expr todo - `nlHsApp` trNameLit (mkFastString tycon_str) - `nlHsApp` nlHsLit (int n_kind_vars) - `nlHsApp` kind_rep - where - n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon) - tycon_str = add_tick (occNameString (getOccName tycon)) - add_tick s | isPromotedDataCon tycon = '\'' : s - | otherwise = s - - -- This must match the computation done in - -- Data.Typeable.Internal.mkTyConFingerprint. - Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo - , mod_fingerprint todo - , fingerprintString tycon_str - ] - - int :: Int -> HsLit - int n = HsIntPrim (SourceText $ show n) (toInteger n) - -word64 :: DynFlags -> Word64 -> HsLit -word64 dflags n - | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n) - | otherwise = HsWordPrim NoSourceText (toInteger n) - -{- -Note [Representing TyCon kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -One of the operations supported by Typeable is typeRepKind, - - typeRepKind :: TypeRep (a :: k) -> TypeRep k - -Implementing this is a bit tricky. To see why let's consider the TypeRep -encoding of `Proxy Int` where - - data Proxy (a :: k) :: Type - -which looks like, - - $tcProxy :: TyCon - $trInt :: TypeRep Int - $trType :: TypeRep Type - - $trProxyType :: TypeRep (Proxy :: Type -> Type) - $trProxyType = TrTyCon $tcProxy - [$trType] -- kind variable instantiation - - $trProxy :: TypeRep (Proxy Int) - $trProxy = TrApp $trProxyType $trInt - -Note how $trProxyType encodes only the kind variables of the TyCon -instantiation. To compute the kind (Proxy Int) we need to have a recipe to -compute the kind of a concrete instantiation of Proxy. We call this recipe a -KindRep and store it in the TyCon produced for Proxy, - - type KindBndr = Int -- de Bruijn index - - data KindRep = KindRepTyConApp TyCon [KindRep] - | KindRepVar !KindBndr - | KindRepApp KindRep KindRep - | KindRepFun KindRep KindRep - -The KindRep for Proxy would look like, - - $tkProxy :: KindRep - $tkProxy = KindRepFun (KindRepVar 0) (KindRepTyConApp $trType []) - - -data Maybe a = Nothing | Just a - -'Just :: a -> Maybe a - -F :: forall k. k -> forall k'. k' -> Type --} - -mkList :: Type -> [LHsExpr Id] -> LHsExpr Id -mkList ty = foldr consApp (nilExpr ty) - where - cons = consExpr ty - consApp :: LHsExpr Id -> LHsExpr Id -> LHsExpr Id - consApp x xs = cons `nlHsApp` x `nlHsApp` xs - - nilExpr :: Type -> LHsExpr Id - nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon) - - consExpr :: Type -> LHsExpr Id - consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon) diff --git a/typecheck/TcUnify.hs b/typecheck/TcUnify.hs deleted file mode 100644 --- a/typecheck/TcUnify.hs +++ /dev/null @@ -1,2116 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Type subsumption and unification --} - -{-# LANGUAGE CPP, MultiWayIf, TupleSections, ScopedTypeVariables #-} - -module TcUnify ( - -- Full-blown subsumption - tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET, - tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS, - tcSubTypeDS_NC_O, tcSubTypeET, - checkConstraints, buildImplicationFor, - - -- Various unifications - unifyType, unifyTheta, unifyKind, noThing, - uType, promoteTcType, - swapOverTyVars, canSolveByUnification, - - -------------------------------- - -- Holes - tcInferInst, tcInferNoInst, - matchExpectedListTy, - matchExpectedPArrTy, - matchExpectedTyConApp, - matchExpectedAppTy, - matchExpectedFunTys, - matchActualFunTys, matchActualFunTysPart, - matchExpectedFunKind, - - wrapFunResCoercion, - - occCheckExpand, metaTyVarUpdateOK, - occCheckForErrors, OccCheckResult(..) - - ) where - -#include "HsVersions.h" - -import HsSyn -import TyCoRep -import TcMType -import TcRnMonad -import TcType -import Type -import Coercion -import TcEvidence -import Name ( isSystemName ) -import Inst -import TyCon -import TysWiredIn -import TysPrim( tYPE ) -import Var -import VarSet -import VarEnv -import ErrUtils -import DynFlags -import BasicTypes -import Name ( Name ) -import Bag -import Util -import Pair( pFst ) -import qualified GHC.LanguageExtensions as LangExt -import Outputable -import FastString - -import Control.Monad -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - matchExpected functions -* * -************************************************************************ - -Note [Herald for matchExpectedFunTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'herald' always looks like: - "The equation(s) for 'f' have" - "The abstraction (\x.e) takes" - "The section (+ x) expects" - "The function 'f' is applied to" - -This is used to construct a message of form - - The abstraction `\Just 1 -> ...' takes two arguments - but its type `Maybe a -> a' has only one - - The equation(s) for `f' have two arguments - but its type `Maybe a -> a' has only one - - The section `(f 3)' requires 'f' to take two arguments - but its type `Int -> Int' has only one - - The function 'f' is applied to two arguments - but its type `Int -> Int' has only one - -Note [matchExpectedFunTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -matchExpectedFunTys checks that a sigma has the form -of an n-ary function. It passes the decomposed type to the -thing_inside, and returns a wrapper to coerce between the two types - -It's used wherever a language construct must have a functional type, -namely: - A lambda expression - A function definition - An operator section - -This function must be written CPS'd because it needs to fill in the -ExpTypes produced for arguments before it can fill in the ExpType -passed in. - --} - --- Use this one when you have an "expected" type. -matchExpectedFunTys :: forall a. - SDoc -- See Note [Herald for matchExpectedFunTys] - -> Arity - -> ExpRhoType -- deeply skolemised - -> ([ExpSigmaType] -> ExpRhoType -> TcM a) - -- must fill in these ExpTypes here - -> TcM (a, HsWrapper) --- If matchExpectedFunTys n ty = (_, wrap) --- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, --- where [t1, ..., tn], ty_r are passed to the thing_inside -matchExpectedFunTys herald arity orig_ty thing_inside - = case orig_ty of - Check ty -> go [] arity ty - _ -> defer [] arity orig_ty - where - go acc_arg_tys 0 ty - = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType ty) - ; return (result, idHsWrapper) } - - go acc_arg_tys n ty - | Just ty' <- tcView ty = go acc_arg_tys n ty' - - go acc_arg_tys n (FunTy arg_ty res_ty) - = ASSERT( not (isPredTy arg_ty) ) - do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys) - (n-1) res_ty - ; return ( result - , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) } - where - doc = text "When inferring the argument type of a function with type" <+> - quotes (ppr orig_ty) - - go acc_arg_tys n ty@(TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty' -> go acc_arg_tys n ty' - Flexi -> defer acc_arg_tys n (mkCheckExpType ty) } - - -- In all other cases we bale out into ordinary unification - -- However unlike the meta-tyvar case, we are sure that the - -- number of arguments doesn't match arity of the original - -- type, so we can add a bit more context to the error message - -- (cf Trac #7869). - -- - -- It is not always an error, because specialized type may have - -- different arity, for example: - -- - -- > f1 = f2 'a' - -- > f2 :: Monad m => m Bool - -- > f2 = undefined - -- - -- But in that case we add specialized type into error context - -- anyway, because it may be useful. See also Trac #9605. - go acc_arg_tys n ty = addErrCtxtM mk_ctxt $ - defer acc_arg_tys n (mkCheckExpType ty) - - ------------ - defer :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (a, HsWrapper) - defer acc_arg_tys n fun_ty - = do { more_arg_tys <- replicateM n newInferExpTypeNoInst - ; res_ty <- newInferExpTypeInst - ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty - ; more_arg_tys <- mapM readExpType more_arg_tys - ; res_ty <- readExpType res_ty - ; let unif_fun_ty = mkFunTys more_arg_tys res_ty - ; wrap <- tcSubTypeDS AppOrigin GenSigCtxt unif_fun_ty fun_ty - -- Not a good origin at all :-( - ; return (result, wrap) } - - ------------ - mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc) - mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_tc_ty - ; let (args, _) = tcSplitFunTys ty - n_actual = length args - (env'', orig_ty') = tidyOpenType env' orig_tc_ty - ; return ( env'' - , mk_fun_tys_msg orig_ty' ty n_actual arity herald) } - where - orig_tc_ty = checkingExpType "matchExpectedFunTys" orig_ty - -- this is safe b/c we're called from "go" - --- Like 'matchExpectedFunTys', but used when you have an "actual" type, --- for example in function application -matchActualFunTys :: Outputable a - => SDoc -- See Note [Herald for matchExpectedFunTys] - -> CtOrigin - -> Maybe a -- the thing with type TcSigmaType - -> Arity - -> TcSigmaType - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) --- If matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r) --- then wrap : ty ~> (t1 -> ... -> tn -> ty_r) -matchActualFunTys herald ct_orig mb_thing arity ty - = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity - --- | Variant of 'matchActualFunTys' that works when supplied only part --- (that is, to the right of some arrows) of the full function type -matchActualFunTysPart :: Outputable a - => SDoc -- See Note [Herald for matchExpectedFunTys] - -> CtOrigin - -> Maybe a -- the thing with type TcSigmaType - -> Arity - -> TcSigmaType - -> [TcSigmaType] -- reversed args. See (*) below. - -> Arity -- overall arity of the function, for errs - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) -matchActualFunTysPart herald ct_orig mb_thing arity orig_ty - orig_old_args full_arity - = go arity orig_old_args orig_ty --- Does not allocate unnecessary meta variables: if the input already is --- a function, we just take it apart. Not only is this efficient, --- it's important for higher rank: the argument might be of form --- (forall a. ty) -> other --- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd --- hide the forall inside a meta-variable - --- (*) Sometimes it's necessary to call matchActualFunTys with only part --- (that is, to the right of some arrows) of the type of the function in --- question. (See TcExpr.tcArgs.) This argument is the reversed list of --- arguments already seen (that is, not part of the TcSigmaType passed --- in elsewhere). - - where - -- This function has a bizarre mechanic: it accumulates arguments on - -- the way down and also builds an argument list on the way up. Why: - -- 1. The returns args list and the accumulated args list might be different. - -- The accumulated args include all the arg types for the function, - -- including those from before this function was called. The returned - -- list should include only those arguments produced by this call of - -- matchActualFunTys - -- - -- 2. The HsWrapper can be built only on the way up. It seems (more) - -- bizarre to build the HsWrapper but not the arg_tys. - -- - -- Refactoring is welcome. - go :: Arity - -> [TcSigmaType] -- accumulator of arguments (reversed) - -> TcSigmaType -- the remainder of the type as we're processing - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) - go 0 _ ty = return (idHsWrapper, [], ty) - - go n acc_args ty - | not (null tvs && null theta) - = do { (wrap1, rho) <- topInstantiate ct_orig ty - ; (wrap2, arg_tys, res_ty) <- go n acc_args rho - ; return (wrap2 <.> wrap1, arg_tys, res_ty) } - where - (tvs, theta, _) = tcSplitSigmaTy ty - - go n acc_args ty - | Just ty' <- tcView ty = go n acc_args ty' - - go n acc_args (FunTy arg_ty res_ty) - = ASSERT( not (isPredTy arg_ty) ) - do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty - ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc - , arg_ty : tys, ty_r ) } - where - doc = text "When inferring the argument type of a function with type" <+> - quotes (ppr orig_ty) - - go n acc_args ty@(TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty' -> go n acc_args ty' - Flexi -> defer n ty } - - -- In all other cases we bale out into ordinary unification - -- However unlike the meta-tyvar case, we are sure that the - -- number of arguments doesn't match arity of the original - -- type, so we can add a bit more context to the error message - -- (cf Trac #7869). - -- - -- It is not always an error, because specialized type may have - -- different arity, for example: - -- - -- > f1 = f2 'a' - -- > f2 :: Monad m => m Bool - -- > f2 = undefined - -- - -- But in that case we add specialized type into error context - -- anyway, because it may be useful. See also Trac #9605. - go n acc_args ty = addErrCtxtM (mk_ctxt (reverse acc_args) ty) $ - defer n ty - - ------------ - defer n fun_ty - = do { arg_tys <- replicateM n newOpenFlexiTyVarTy - ; res_ty <- newOpenFlexiTyVarTy - ; let unif_fun_ty = mkFunTys arg_tys res_ty - ; co <- unifyType mb_thing fun_ty unif_fun_ty - ; return (mkWpCastN co, arg_tys, res_ty) } - - ------------ - mk_ctxt :: [TcSigmaType] -> TcSigmaType -> TidyEnv -> TcM (TidyEnv, MsgDoc) - mk_ctxt arg_tys res_ty env - = do { let ty = mkFunTys arg_tys res_ty - ; (env1, zonked) <- zonkTidyTcType env ty - -- zonking might change # of args - ; let (zonked_args, _) = tcSplitFunTys zonked - n_actual = length zonked_args - (env2, unzonked) = tidyOpenType env1 ty - ; return ( env2 - , mk_fun_tys_msg unzonked zonked n_actual full_arity herald) } - -mk_fun_tys_msg :: TcType -- the full type passed in (unzonked) - -> TcType -- the full type passed in (zonked) - -> Arity -- the # of args found - -> Arity -- the # of args wanted - -> SDoc -- overall herald - -> SDoc -mk_fun_tys_msg full_ty ty n_args full_arity herald - = herald <+> speakNOf full_arity (text "argument") <> comma $$ - if n_args == full_arity - then text "its type is" <+> quotes (pprType full_ty) <> - comma $$ - text "it is specialized to" <+> quotes (pprType ty) - else sep [text "but its type" <+> quotes (pprType ty), - if n_args == 0 then text "has none" - else text "has only" <+> speakN n_args] - ----------------------- -matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) --- Special case for lists -matchExpectedListTy exp_ty - = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty - ; return (co, elt_ty) } - ----------------------- -matchExpectedPArrTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) --- Special case for parrs -matchExpectedPArrTy exp_ty - = do { (co, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty - ; return (co, elt_ty) } - ---------------------- -matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> * - -> TcRhoType -- orig_ty - -> TcM (TcCoercionN, -- T k1 k2 k3 a b c ~N orig_ty - [TcSigmaType]) -- Element types, k1 k2 k3 a b c - --- It's used for wired-in tycons, so we call checkWiredInTyCon --- Precondition: never called with FunTyCon --- Precondition: input type :: * --- Postcondition: (T k1 k2 k3 a b c) is well-kinded - -matchExpectedTyConApp tc orig_ty - = ASSERT(tc /= funTyCon) go orig_ty - where - go ty - | Just ty' <- tcView ty - = go ty' - - go ty@(TyConApp tycon args) - | tc == tycon -- Common case - = return (mkTcNomReflCo ty, args) - - go (TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty -> go ty - Flexi -> defer } - - go _ = defer - - -- If the common case does not occur, instantiate a template - -- T k1 .. kn t1 .. tm, and unify with the original type - -- Doing it this way ensures that the types we return are - -- kind-compatible with T. For example, suppose we have - -- matchExpectedTyConApp T (f Maybe) - -- where data T a = MkT a - -- Then we don't want to instantate T's data constructors with - -- (a::*) ~ Maybe - -- because that'll make types that are utterly ill-kinded. - -- This happened in Trac #7368 - defer - = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc) - ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) - ; let args = mkTyVarTys arg_tvs - tc_template = mkTyConApp tc args - ; co <- unifyType noThing tc_template orig_ty - ; return (co, args) } - ----------------------- -matchExpectedAppTy :: TcRhoType -- orig_ty - -> TcM (TcCoercion, -- m a ~N orig_ty - (TcSigmaType, TcSigmaType)) -- Returns m, a --- If the incoming type is a mutable type variable of kind k, then --- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. - -matchExpectedAppTy orig_ty - = go orig_ty - where - go ty - | Just ty' <- tcView ty = go ty' - - | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty - = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty)) - - go (TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty -> go ty - Flexi -> defer } - - go _ = defer - - -- Defer splitting by generating an equality constraint - defer - = do { ty1 <- newFlexiTyVarTy kind1 - ; ty2 <- newFlexiTyVarTy kind2 - ; co <- unifyType noThing (mkAppTy ty1 ty2) orig_ty - ; return (co, (ty1, ty2)) } - - orig_kind = typeKind orig_ty - kind1 = mkFunTy liftedTypeKind orig_kind - kind2 = liftedTypeKind -- m :: * -> k - -- arg type :: * - -{- -************************************************************************ -* * - Subsumption checking -* * -************************************************************************ - -Note [Subsumption checking: tcSubType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All the tcSubType calls have the form - tcSubType actual_ty expected_ty -which checks - actual_ty <= expected_ty - -That is, that a value of type actual_ty is acceptable in -a place expecting a value of type expected_ty. I.e. that - - actual ty is more polymorphic than expected_ty - -It returns a coercion function - co_fn :: actual_ty ~ expected_ty -which takes an HsExpr of type actual_ty into one of type -expected_ty. - -These functions do not actually check for subsumption. They check if -expected_ty is an appropriate annotation to use for something of type -actual_ty. This difference matters when thinking about visible type -application. For example, - - forall a. a -> forall b. b -> b - DOES NOT SUBSUME - forall a b. a -> b -> b - -because the type arguments appear in a different order. (Neither does -it work the other way around.) BUT, these types are appropriate annotations -for one another. Because the user directs annotations, it's OK if some -arguments shuffle around -- after all, it's what the user wants. -Bottom line: none of this changes with visible type application. - -There are a number of wrinkles (below). - -Notice that Wrinkle 1 and 2 both require eta-expansion, which technically -may increase termination. We just put up with this, in exchange for getting -more predictable type inference. - -Wrinkle 1: Note [Deep skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want (forall a. Int -> a -> a) <= (Int -> forall a. a->a) -(see section 4.6 of "Practical type inference for higher rank types") -So we must deeply-skolemise the RHS before we instantiate the LHS. - -That is why tc_sub_type starts with a call to tcSkolemise (which does the -deep skolemisation), and then calls the DS variant (which assumes -that expected_ty is deeply skolemised) - -Wrinkle 2: Note [Co/contra-variance of subsumption checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider g :: (Int -> Int) -> Int - f1 :: (forall a. a -> a) -> Int - f1 = g - - f2 :: (forall a. a -> a) -> Int - f2 x = g x -f2 will typecheck, and it would be odd/fragile if f1 did not. -But f1 will only typecheck if we have that - (Int->Int) -> Int <= (forall a. a->a) -> Int -And that is only true if we do the full co/contravariant thing -in the subsumption check. That happens in the FunTy case of -tcSubTypeDS_NC_O, and is the sole reason for the WpFun form of -HsWrapper. - -Another powerful reason for doing this co/contra stuff is visible -in Trac #9569, involving instantiation of constraint variables, -and again involving eta-expansion. - -Wrinkle 3: Note [Higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider tc150: - f y = \ (x::forall a. a->a). blah -The following happens: -* We will infer the type of the RHS, ie with a res_ty = alpha. -* Then the lambda will split alpha := beta -> gamma. -* And then we'll check tcSubType IsSwapped beta (forall a. a->a) - -So it's important that we unify beta := forall a. a->a, rather than -skolemising the type. --} - - --- | Call this variant when you are in a higher-rank situation and --- you know the right-hand type is deeply skolemised. -tcSubTypeHR :: Outputable a - => CtOrigin -- ^ of the actual type - -> Maybe a -- ^ If present, it has type ty_actual - -> TcSigmaType -> ExpRhoType -> TcM HsWrapper -tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt - ------------------------- -tcSubTypeET :: CtOrigin -> UserTypeCtxt - -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper --- If wrap = tc_sub_type_et t1 t2 --- => wrap :: t1 ~> t2 -tcSubTypeET orig ctxt (Check ty_actual) ty_expected - = tc_sub_tc_type eq_orig orig ctxt ty_actual ty_expected - where - eq_orig = TypeEqOrigin { uo_actual = ty_expected - , uo_expected = ty_actual - , uo_thing = Nothing } - -tcSubTypeET _ _ (Infer inf_res) ty_expected - = ASSERT2( not (ir_inst inf_res), ppr inf_res $$ ppr ty_expected ) - do { co <- fillInferResult ty_expected inf_res - ; return (mkWpCastN (mkTcSymCo co)) } - ------------------------- -tcSubTypeO :: CtOrigin -- ^ of the actual type - -> UserTypeCtxt -- ^ of the expected type - -> TcSigmaType - -> ExpRhoType - -> TcM HsWrapper -tcSubTypeO orig ctxt ty_actual ty_expected - = addSubTypeCtxt ty_actual ty_expected $ - do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig - , pprUserTypeCtxt ctxt - , ppr ty_actual - , ppr ty_expected ]) - ; tcSubTypeDS_NC_O orig ctxt noThing ty_actual ty_expected } - -addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a -addSubTypeCtxt ty_actual ty_expected thing_inside - | isRhoTy ty_actual -- If there is no polymorphism involved, the - , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) - = thing_inside -- gives enough context by itself - | otherwise - = addErrCtxtM mk_msg thing_inside - where - mk_msg tidy_env - = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual - -- might not be filled if we're debugging. ugh. - ; mb_ty_expected <- readExpType_maybe ty_expected - ; (tidy_env, ty_expected) <- case mb_ty_expected of - Just ty -> second mkCheckExpType <$> - zonkTidyTcType tidy_env ty - Nothing -> return (tidy_env, ty_expected) - ; ty_expected <- readExpType ty_expected - ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected - ; let msg = vcat [ hang (text "When checking that:") - 4 (ppr ty_actual) - , nest 2 (hang (text "is more polymorphic than:") - 2 (ppr ty_expected)) ] - ; return (tidy_env, msg) } - ---------------- --- The "_NC" variants do not add a typechecker-error context; --- the caller is assumed to do that - -tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- Checks that actual <= expected --- Returns HsWrapper :: actual ~ expected -tcSubType_NC ctxt ty_actual ty_expected - = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) - ; tc_sub_tc_type origin origin ctxt ty_actual ty_expected } - where - origin = TypeEqOrigin { uo_actual = ty_actual - , uo_expected = ty_expected - , uo_thing = Nothing } - -tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper --- Just like tcSubType, but with the additional precondition that --- ty_expected is deeply skolemised (hence "DS") -tcSubTypeDS orig ctxt ty_actual ty_expected - = addSubTypeCtxt ty_actual ty_expected $ - do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) - ; tcSubTypeDS_NC_O orig ctxt noThing ty_actual ty_expected } - -tcSubTypeDS_NC_O :: Outputable a - => CtOrigin -- origin used for instantiation only - -> UserTypeCtxt - -> Maybe a - -> TcSigmaType -> ExpRhoType -> TcM HsWrapper --- Just like tcSubType, but with the additional precondition that --- ty_expected is deeply skolemised -tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected - = case ty_expected of - Infer inf_res -> fillInferResult_Inst inst_orig ty_actual inf_res - Check ty -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty - where - eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty - , uo_thing = mkErrorThing <$> m_thing } - ---------------- -tc_sub_tc_type :: CtOrigin -- used when calling uType - -> CtOrigin -- used when instantiating - -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- If wrap = tc_sub_type t1 t2 --- => wrap :: t1 ~> t2 -tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected - | is_poly ty_expected -- See Note [Don't skolemise unnecessarily] - , not (is_poly ty_actual) - = do { traceTc "tc_sub_tc_type (drop to equality)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; mkWpCastN <$> - uType eq_orig TypeLevel ty_actual ty_expected } - - | otherwise -- This is the general case - = do { traceTc "tc_sub_tc_type (general case)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $ - \ _ sk_rho -> - tc_sub_type_ds eq_orig inst_orig ctxt - ty_actual sk_rho - ; return (sk_wrap <.> inner_wrap) } - where - is_poly ty - | isForAllTy ty = True - | Just (_, res) <- splitFunTy_maybe ty = is_poly res - | otherwise = False - -- NB *not* tcSplitFunTy, because here we want - -- to decompose type-class arguments too - - -{- Note [Don't skolemise unnecessarily] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are trying to solve - (Char->Char) <= (forall a. a->a) -We could skolemise the 'forall a', and then complain -that (Char ~ a) is insoluble; but that's a pretty obscure -error. It's better to say that - (Char->Char) ~ (forall a. a->a) -fails. - -In general, - * if the RHS type an outermost forall (i.e. skolemisation - is the next thing we'd do) - * and the LHS has no top-level polymorphism (but looking deeply) -then we can revert to simple equality. --} - ---------------- -tc_sub_type_ds :: CtOrigin -- used when calling uType - -> CtOrigin -- used when instantiating - -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper --- If wrap = tc_sub_type_ds t1 t2 --- => wrap :: t1 ~> t2 --- Here is where the work actually happens! --- Precondition: ty_expected is deeply skolemised -tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected - = do { traceTc "tc_sub_type_ds" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; go ty_actual ty_expected } - where - go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e - | Just ty_e' <- tcView ty_e = go ty_a ty_e' - - go (TyVarTy tv_a) ty_e - = do { lookup_res <- lookupTcTyVar tv_a - ; case lookup_res of - Filled ty_a' -> - do { traceTc "tcSubTypeDS_NC_O following filled act meta-tyvar:" - (ppr tv_a <+> text "-->" <+> ppr ty_a') - ; tc_sub_type_ds eq_orig inst_orig ctxt ty_a' ty_e } - Unfilled _ -> unify } - - -- Historical note (Sept 16): there was a case here for - -- go ty_a (TyVarTy alpha) - -- which, in the impredicative case unified alpha := ty_a - -- where th_a is a polytype. Not only is this probably bogus (we - -- simply do not have decent story for imprdicative types), but it - -- caused Trac #12616 because (also bizarrely) 'deriving' code had - -- -XImpredicativeTypes on. I deleted the entire case. - - go (FunTy act_arg act_res) (FunTy exp_arg exp_res) - | not (isPredTy act_arg) - , not (isPredTy exp_arg) - = -- See Note [Co/contra-variance of subsumption checking] - do { res_wrap <- tc_sub_type_ds eq_orig inst_orig ctxt act_res exp_res - ; arg_wrap <- tc_sub_tc_type eq_orig given_orig ctxt exp_arg act_arg - ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) } - -- arg_wrap :: exp_arg ~> act_arg - -- res_wrap :: act-res ~> exp_res - where - given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) - doc = text "When checking that" <+> quotes (ppr ty_actual) <+> - text "is more polymorphic than" <+> quotes (ppr ty_expected) - - go ty_a ty_e - | let (tvs, theta, _) = tcSplitSigmaTy ty_a - , not (null tvs && null theta) - = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a - ; body_wrap <- tc_sub_type_ds - (eq_orig { uo_actual = in_rho - , uo_expected = ty_expected }) - inst_orig ctxt in_rho ty_e - ; return (body_wrap <.> in_wrap) } - - | otherwise -- Revert to unification - = inst_and_unify - -- It's still possible that ty_actual has nested foralls. Instantiate - -- these, as there's no way unification will succeed with them in. - -- See typecheck/should_compile/T11305 for an example of when this - -- is important. The problem is that we're checking something like - -- a -> forall b. b -> b <= alpha beta gamma - -- where we end up with alpha := (->) - - inst_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual - - -- if we haven't recurred through an arrow, then - -- the eq_orig will list ty_actual. In this case, - -- we want to update the origin to reflect the - -- instantiation. If we *have* recurred through - -- an arrow, it's better not to update. - ; let eq_orig' = case eq_orig of - TypeEqOrigin { uo_actual = orig_ty_actual } - | orig_ty_actual `tcEqType` ty_actual - , not (isIdHsWrapper wrap) - -> eq_orig { uo_actual = rho_a } - _ -> eq_orig - - ; cow <- uType eq_orig' TypeLevel rho_a ty_expected - ; return (mkWpCastN cow <.> wrap) } - - - -- use versions without synonyms expanded - unify = mkWpCastN <$> uType eq_orig TypeLevel ty_actual ty_expected - ------------------ --- needs both un-type-checked (for origins) and type-checked (for wrapping) --- expressions -tcWrapResult :: HsExpr Name -> HsExpr TcId -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr TcId) -tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) - --- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more --- convenient. -tcWrapResultO :: CtOrigin -> HsExpr TcId -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr TcId) -tcWrapResultO orig expr actual_ty res_ty - = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty - , text "Expected:" <+> ppr res_ty ]) - ; cow <- tcSubTypeDS_NC_O orig GenSigCtxt - (Just expr) actual_ty res_ty - ; return (mkHsWrap cow expr) } - ------------------------------------ -wrapFunResCoercion - :: [TcType] -- Type of args - -> HsWrapper -- HsExpr a -> HsExpr b - -> TcM HsWrapper -- HsExpr (arg_tys -> a) -> HsExpr (arg_tys -> b) -wrapFunResCoercion arg_tys co_fn_res - | isIdHsWrapper co_fn_res - = return idHsWrapper - | null arg_tys - = return co_fn_res - | otherwise - = do { arg_ids <- newSysLocalIds (fsLit "sub") arg_tys - ; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpEvVarApps arg_ids) } - - -{- ********************************************************************** -%* * - ExpType functions: tcInfer, fillInferResult -%* * -%********************************************************************* -} - --- | Infer a type using a fresh ExpType --- See also Note [ExpType] in TcMType --- Does not attempt to instantiate the inferred type -tcInferNoInst :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInferNoInst = tcInfer False - -tcInferInst :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType) -tcInferInst = tcInfer True - -tcInfer :: Bool -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInfer instantiate tc_check - = do { res_ty <- newInferExpType instantiate - ; result <- tc_check res_ty - ; res_ty <- readExpType res_ty - ; return (result, res_ty) } - -fillInferResult_Inst :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper --- If wrap = fillInferResult_Inst t1 t2 --- => wrap :: t1 ~> t2 --- See Note [Deep instantiation of InferResult] -fillInferResult_Inst orig ty inf_res@(IR { ir_inst = instantiate_me }) - | instantiate_me - = do { (wrap, rho) <- deeplyInstantiate orig ty - ; co <- fillInferResult rho inf_res - ; return (mkWpCastN co <.> wrap) } - - | otherwise - = do { co <- fillInferResult ty inf_res - ; return (mkWpCastN co) } - -fillInferResult :: TcType -> InferResult -> TcM TcCoercionN --- If wrap = fillInferResult t1 t2 --- => wrap :: t1 ~> t2 -fillInferResult orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl - , ir_ref = ref }) - = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty - - ; traceTc "Filling ExpType" $ - ppr u <+> text ":=" <+> ppr ty_to_fill_with - - ; when debugIsOn (check_hole ty_to_fill_with) - - ; writeTcRef ref (Just ty_to_fill_with) - - ; return ty_co } - where - check_hole ty -- Debug check only - = do { let ty_lvl = tcTypeLevel ty - ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl), - ppr u $$ ppr res_lvl $$ ppr ty_lvl $$ - ppr ty <+> ppr (typeKind ty) $$ ppr orig_ty ) - ; cts <- readTcRef ref - ; case cts of - Just already_there -> pprPanic "writeExpType" - (vcat [ ppr u - , ppr ty - , ppr already_there ]) - Nothing -> return () } - -{- Note [Deep instantiation of InferResult] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some cases we want to deeply instantiate before filling in -an InferResult, and in some cases not. That's why InferReult -has the ir_inst flag. - -* ir_inst = True: deeply instantantiate - - Consider - f x = (*) - We want to instantiate the type of (*) before returning, else we - will infer the type - f :: forall {a}. a -> forall b. Num b => b -> b -> b - This is surely confusing for users. - - And worse, the the monomorphism restriction won't properly. The MR is - dealt with in simplifyInfer, and simplifyInfer has no way of - instantiating. This could perhaps be worked around, but it may be - hard to know even when instantiation should happen. - - Another reason. Consider - f :: (?x :: Int) => a -> a - g y = let ?x = 3::Int in f - Here want to instantiate f's type so that the ?x::Int constraint - gets discharged by the enclosing implicit-parameter binding. - -* ir_inst = False: do not instantantiate - - Consider this (which uses visible type application): - - (let { f :: forall a. a -> a; f x = x } in f) @Int - - We'll call TcExpr.tcInferFun to infer the type of the (let .. in f) - And we don't want to instantite the type of 'f' when we reach it, - else the outer visible type application won't work --} - -{- ********************************************************************* -* * - Promoting types -* * -********************************************************************* -} - -promoteTcType :: TcLevel -> TcType -> TcM (TcCoercion, TcType) --- See Note [Promoting a type] --- promoteTcType level ty = (co, ty') --- * Returns ty' whose max level is just 'level' --- and whose kind is ~# to the kind of 'ty' --- and whose kind has form TYPE rr --- * and co :: ty ~ ty' --- * and emits constraints to justify the coercion -promoteTcType dest_lvl ty - = do { cur_lvl <- getTcLevel - ; if (cur_lvl `sameDepthAs` dest_lvl) - then dont_promote_it - else promote_it } - where - promote_it :: TcM (TcCoercion, TcType) - promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty - -- where alpha and rr are fresh and from level dest_lvl - = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy - ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr) - ; let eq_orig = TypeEqOrigin { uo_actual = ty - , uo_expected = prom_ty - , uo_thing = Nothing } - - ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty - ; return (co, prom_ty) } - - dont_promote_it :: TcM (TcCoercion, TcType) - dont_promote_it -- Check that ty :: TYPE rr, for some (fresh) rr - = do { res_kind <- newOpenTypeKind - ; let ty_kind = typeKind ty - kind_orig = TypeEqOrigin { uo_actual = ty_kind - , uo_expected = res_kind - , uo_thing = Nothing } - ; ki_co <- uType kind_orig KindLevel (typeKind ty) res_kind - ; let co = mkTcNomReflCo ty `mkTcCoherenceRightCo` ki_co - ; return (co, ty `mkCastTy` ki_co) } - -{- Note [Promoting a type] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #12427) - - data T where - MkT :: (Int -> Int) -> a -> T - - h y = case y of MkT v w -> v - -We'll infer the RHS type with an expected type ExpType of - (IR { ir_lvl = l, ir_ref = ref, ... ) -where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern -match will increase the level, so we'll end up in tcSubType, trying to -unify the type of v, - v :: Int -> Int -with the expected type. But this attempt takes place at level (l+1), -rightly so, since v's type could have mentioned existential variables, -(like w's does) and we want to catch that. - -So we - - create a new meta-var alpha[l+1] - - fill in the InferRes ref cell 'ref' with alpha - - emit an equality constraint, thus - [W] alpha[l+1] ~ (Int -> Int) - -That constraint will float outwards, as it should, unless v's -type mentions a skolem-captured variable. - -This approach fails if v has a higher rank type; see -Note [Promotion and higher rank types] - - -Note [Promotion and higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If v had a higher-rank type, say v :: (forall a. a->a) -> Int, -then we'd emit an equality - [W] alpha[l+1] ~ ((forall a. a->a) -> Int) -which will sadly fail because we can't unify a unification variable -with a polytype. But there is nothing really wrong with the program -here. - -We could just about solve this by "promote the type" of v, to expose -its polymorphic "shape" while still leaving constraints that will -prevent existential escape. But we must be careful! Exposing -the "shape" of the type is precisely what we must NOT do under -a GADT pattern match! So in this case we might promote the type -to - (forall a. a->a) -> alpha[l+1] -and emit the constraint - [W] alpha[l+1] ~ Int -Now the poromoted type can fill the ref cell, while the emitted -equality can float or not, according to the usual rules. - -But that's not quite right! We are exposing the arrow! We could -deal with that too: - (forall a. mu[l+1] a a) -> alpha[l+1] -with constraints - [W] alpha[l+1] ~ Int - [W] mu[l+1] ~ (->) -Here we abstract over the '->' inside the forall, in case that -is subject to an equality constraint from a GADT match. - -Note that we kept the outer (->) because that's part of -the polymorphic "shape". And becauuse of impredicativity, -GADT matches can't give equalities that affect polymorphic -shape. - -This reasoning just seems too complicated, so I decided not -to do it. These higher-rank notes are just here to record -the thinking. --} - -{- ********************************************************************* -* * - Generalisation -* * -********************************************************************* -} - --- | Take an "expected type" and strip off quantifiers to expose the --- type underneath, binding the new skolems for the @thing_inside@. --- The returned 'HsWrapper' has type @specific_ty -> expected_ty@. -tcSkolemise :: UserTypeCtxt -> TcSigmaType - -> ([TcTyVar] -> TcType -> TcM result) - -- ^ These are only ever used for scoped type variables. - -> TcM (HsWrapper, result) - -- ^ The expression has type: spec_ty -> expected_ty - -tcSkolemise ctxt expected_ty thing_inside - -- We expect expected_ty to be a forall-type - -- If not, the call is a no-op - = do { traceTc "tcSkolemise" Outputable.empty - ; (wrap, tv_prs, given, rho') <- deeplySkolemise expected_ty - - ; lvl <- getTcLevel - ; when debugIsOn $ - traceTc "tcSkolemise" $ vcat [ - ppr lvl, - text "expected_ty" <+> ppr expected_ty, - text "inst tyvars" <+> ppr tv_prs, - text "given" <+> ppr given, - text "inst type" <+> ppr rho' ] - - -- Generally we must check that the "forall_tvs" havn't been constrained - -- The interesting bit here is that we must include the free variables - -- of the expected_ty. Here's an example: - -- runST (newVar True) - -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool)) - -- for (newVar True), with s fresh. Then we unify with the runST's arg type - -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool. - -- So now s' isn't unconstrained because it's linked to a. - -- - -- However [Oct 10] now that the untouchables are a range of - -- TcTyVars, all this is handled automatically with no need for - -- extra faffing around - - ; let tvs' = map snd tv_prs - skol_info = SigSkol ctxt expected_ty tv_prs - - ; (ev_binds, result) <- checkConstraints skol_info tvs' given $ - thing_inside tvs' rho' - - ; return (wrap <.> mkWpLet ev_binds, result) } - -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op - --- | Variant of 'tcSkolemise' that takes an ExpType -tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType - -> (ExpRhoType -> TcM result) - -> TcM (HsWrapper, result) -tcSkolemiseET _ et@(Infer {}) thing_inside - = (idHsWrapper, ) <$> thing_inside et -tcSkolemiseET ctxt (Check ty) thing_inside - = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType - -checkConstraints :: SkolemInfo - -> [TcTyVar] -- Skolems - -> [EvVar] -- Given - -> TcM result - -> TcM (TcEvBinds, result) - -checkConstraints skol_info skol_tvs given thing_inside - = do { (implics, ev_binds, result) - <- buildImplication skol_info skol_tvs given thing_inside - ; emitImplications implics - ; return (ev_binds, result) } - -buildImplication :: SkolemInfo - -> [TcTyVar] -- Skolems - -> [EvVar] -- Given - -> TcM result - -> TcM (Bag Implication, TcEvBinds, result) -buildImplication skol_info skol_tvs given thing_inside - = do { tc_lvl <- getTcLevel - ; deferred_type_errors <- goptM Opt_DeferTypeErrors <||> - goptM Opt_DeferTypedHoles - ; if null skol_tvs && null given && (not deferred_type_errors || - not (isTopTcLevel tc_lvl)) - then do { res <- thing_inside - ; return (emptyBag, emptyTcEvBinds, res) } - -- Fast path. We check every function argument with - -- tcPolyExpr, which uses tcSkolemise and hence checkConstraints. - -- But with the solver producing unlifted equalities, we need - -- to have an EvBindsVar for them when they might be deferred to - -- runtime. Otherwise, they end up as top-level unlifted bindings, - -- which are verboten. See also Note [Deferred errors for coercion holes] - -- in TcErrors. - else - do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside - ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted - ; return (implics, ev_binds, result) }} - -buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar] - -> [EvVar] -> WantedConstraints - -> TcM (Bag Implication, TcEvBinds) -buildImplicationFor tclvl skol_info skol_tvs given wanted - | isEmptyWC wanted && null given - -- Optimisation : if there are no wanteds, and no givens - -- don't generate an implication at all. - -- Reason for the (null given): we don't want to lose - -- the "inaccessible alternative" error check - = return (emptyBag, emptyTcEvBinds) - - | otherwise - = ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) - do { ev_binds_var <- newTcEvBinds - ; env <- getLclEnv - ; let implic = Implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_no_eqs = False - , ic_given = given - , ic_wanted = wanted - , ic_status = IC_Unsolved - , ic_binds = ev_binds_var - , ic_env = env - , ic_needed = emptyVarSet - , ic_info = skol_info } - - ; return (unitBag implic, TcEvBinds ev_binds_var) } - -{- -************************************************************************ -* * - Boxy unification -* * -************************************************************************ - -The exported functions are all defined as versions of some -non-exported generic functions. --} - -unifyType :: Outputable a => Maybe a -- ^ If present, has type 'ty1' - -> TcTauType -> TcTauType -> TcM TcCoercionN --- Actual and expected types --- Returns a coercion : ty1 ~ ty2 -unifyType thing ty1 ty2 = uType origin TypeLevel ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 - , uo_thing = mkErrorThing <$> thing } - --- | Use this instead of 'Nothing' when calling 'unifyType' without --- a good "thing" (where the "thing" has the "actual" type passed in) --- This has an 'Outputable' instance, avoiding amgiguity problems. -noThing :: Maybe (HsExpr Name) -noThing = Nothing - -unifyKind :: Outputable a => Maybe a -> TcKind -> TcKind -> TcM CoercionN -unifyKind thing ty1 ty2 = uType origin KindLevel ty1 ty2 - where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 - , uo_thing = mkErrorThing <$> thing } - ---------------- -unifyPred :: PredType -> PredType -> TcM TcCoercionN --- Actual and expected types -unifyPred = unifyType noThing - ---------------- -unifyTheta :: TcThetaType -> TcThetaType -> TcM [TcCoercionN] --- Actual and expected types -unifyTheta theta1 theta2 - = do { checkTc (equalLength theta1 theta2) - (vcat [text "Contexts differ in length", - nest 2 $ parens $ text "Use RelaxedPolyRec to allow this"]) - ; zipWithM unifyPred theta1 theta2 } - -{- -%************************************************************************ -%* * - uType and friends -%* * -%************************************************************************ - -uType is the heart of the unifier. --} - -uType, uType_defer - :: CtOrigin - -> TypeOrKind - -> TcType -- ty1 is the *actual* type - -> TcType -- ty2 is the *expected* type - -> TcM Coercion - --------------- --- It is always safe to defer unification to the main constraint solver --- See Note [Deferred unification] -uType_defer origin t_or_k ty1 ty2 - = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2 - - -- Error trace only - -- NB. do *not* call mkErrInfo unless tracing is on, - -- because it is hugely expensive (#5631) - ; whenDOptM Opt_D_dump_tc_trace $ do - { ctxt <- getErrCtxt - ; doc <- mkErrInfo emptyTidyEnv ctxt - ; traceTc "utype_defer" (vcat [ppr co, ppr ty1, - ppr ty2, pprCtOrigin origin, doc]) - } - ; return co } - --------------- -uType origin t_or_k orig_ty1 orig_ty2 - = do { tclvl <- getTcLevel - ; traceTc "u_tys" $ vcat - [ text "tclvl" <+> ppr tclvl - , sep [ ppr orig_ty1, text "~", ppr orig_ty2] - , pprCtOrigin origin] - ; co <- go orig_ty1 orig_ty2 - ; if isReflCo co - then traceTc "u_tys yields no coercion" Outputable.empty - else traceTc "u_tys yields coercion:" (ppr co) - ; return co } - where - go :: TcType -> TcType -> TcM Coercion - -- The arguments to 'go' are always semantically identical - -- to orig_ty{1,2} except for looking through type synonyms - - -- Variables; go for uVar - -- Note that we pass in *original* (before synonym expansion), - -- so that type variables tend to get filled in with - -- the most informative version of the type - go (TyVarTy tv1) ty2 - = do { lookup_res <- lookupTcTyVar tv1 - ; case lookup_res of - Filled ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) - ; go ty1 ty2 } - Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 } - go ty1 (TyVarTy tv2) - = do { lookup_res <- lookupTcTyVar tv2 - ; case lookup_res of - Filled ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) - ; go ty1 ty2 } - Unfilled _ -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 } - - -- See Note [Expanding synonyms during unification] - go ty1@(TyConApp tc1 []) (TyConApp tc2 []) - | tc1 == tc2 - = return $ mkReflCo Nominal ty1 - - -- See Note [Expanding synonyms during unification] - -- - -- Also NB that we recurse to 'go' so that we don't push a - -- new item on the origin stack. As a result if we have - -- type Foo = Int - -- and we try to unify Foo ~ Bool - -- we'll end up saying "can't match Foo with Bool" - -- rather than "can't match "Int with Bool". See Trac #4535. - go ty1 ty2 - | Just ty1' <- tcView ty1 = go ty1' ty2 - | Just ty2' <- tcView ty2 = go ty1 ty2' - - go (CastTy t1 co1) t2 - = do { co_tys <- go t1 t2 - ; return (mkCoherenceLeftCo co_tys co1) } - - go t1 (CastTy t2 co2) - = do { co_tys <- go t1 t2 - ; return (mkCoherenceRightCo co_tys co2) } - - -- Functions (or predicate functions) just check the two parts - go (FunTy fun1 arg1) (FunTy fun2 arg2) - = do { co_l <- uType origin t_or_k fun1 fun2 - ; co_r <- uType origin t_or_k arg1 arg2 - ; return $ mkFunCo Nominal co_l co_r } - - -- Always defer if a type synonym family (type function) - -- is involved. (Data families behave rigidly.) - go ty1@(TyConApp tc1 _) ty2 - | isTypeFamilyTyCon tc1 = defer ty1 ty2 - go ty1 ty2@(TyConApp tc2 _) - | isTypeFamilyTyCon tc2 = defer ty1 ty2 - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - -- See Note [Mismatched type lists and application decomposition] - | tc1 == tc2, length tys1 == length tys2 - = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 ) - do { cos <- zipWithM (uType origin t_or_k) tys1 tys2 - ; return $ mkTyConAppCo Nominal tc1 cos } - - go (LitTy m) ty@(LitTy n) - | m == n - = return $ mkNomReflCo ty - - -- See Note [Care with type applications] - -- Do not decompose FunTy against App; - -- it's often a type error, so leave it for the constraint solver - go (AppTy s1 t1) (AppTy s2 t2) - = go_app s1 t1 s2 t2 - - go (AppTy s1 t1) (TyConApp tc2 ts2) - | Just (ts2', t2') <- snocView ts2 - = ASSERT( mightBeUnsaturatedTyCon tc2 ) - go_app s1 t1 (TyConApp tc2 ts2') t2' - - go (TyConApp tc1 ts1) (AppTy s2 t2) - | Just (ts1', t1') <- snocView ts1 - = ASSERT( mightBeUnsaturatedTyCon tc1 ) - go_app (TyConApp tc1 ts1') t1' s2 t2 - - go (CoercionTy co1) (CoercionTy co2) - = do { let ty1 = coercionType co1 - ty2 = coercionType co2 - ; kco <- uType (KindEqOrigin orig_ty1 (Just orig_ty2) origin - (Just t_or_k)) - KindLevel - ty1 ty2 - ; return $ mkProofIrrelCo Nominal kco co1 co2 } - - -- Anything else fails - -- E.g. unifying for-all types, which is relative unusual - go ty1 ty2 = defer ty1 ty2 - - ------------------ - defer ty1 ty2 -- See Note [Check for equality before deferring] - | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1) - | otherwise = uType_defer origin t_or_k ty1 ty2 - - ------------------ - go_app s1 t1 s2 t2 - = do { co_s <- uType origin t_or_k s1 s2 - ; co_t <- uType origin t_or_k t1 t2 - ; return $ mkAppCo co_s co_t } - -{- Note [Check for equality before deferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Particularly in ambiguity checks we can get equalities like (ty ~ ty). -If ty involves a type function we may defer, which isn't very sensible. -An egregious example of this was in test T9872a, which has a type signature - Proxy :: Proxy (Solutions Cubes) -Doing the ambiguity check on this signature generates the equality - Solutions Cubes ~ Solutions Cubes -and currently the constraint solver normalises both sides at vast cost. -This little short-cut in 'defer' helps quite a bit. - -Note [Care with type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note: type applications need a bit of care! -They can match FunTy and TyConApp, so use splitAppTy_maybe -NB: we've already dealt with type variables and Notes, -so if one type is an App the other one jolly well better be too - -Note [Mismatched type lists and application decomposition] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we find two TyConApps, you might think that the argument lists -are guaranteed equal length. But they aren't. Consider matching - w (T x) ~ Foo (T x y) -We do match (w ~ Foo) first, but in some circumstances we simply create -a deferred constraint; and then go ahead and match (T x ~ T x y). -This came up in Trac #3950. - -So either - (a) either we must check for identical argument kinds - when decomposing applications, - - (b) or we must be prepared for ill-kinded unification sub-problems - -Currently we adopt (b) since it seems more robust -- no need to maintain -a global invariant. - -Note [Expanding synonyms during unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We expand synonyms during unification, but: - * We expand *after* the variable case so that we tend to unify - variables with un-expanded type synonym. This just makes it - more likely that the inferred types will mention type synonyms - understandable to the user - - * We expand *before* the TyConApp case. For example, if we have - type Phantom a = Int - and are unifying - Phantom Int ~ Phantom Char - it is *wrong* to unify Int and Char. - - * The problem case immediately above can happen only with arguments - to the tycon. So we check for nullary tycons *before* expanding. - This is particularly helpful when checking (* ~ *), because * is - now a type synonym. - -Note [Deferred Unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, -and yet its consistency is undetermined. Previously, there was no way to still -make it consistent. So a mismatch error was issued. - -Now these unifications are deferred until constraint simplification, where type -family instances and given equations may (or may not) establish the consistency. -Deferred unifications are of the form - F ... ~ ... -or x ~ ... -where F is a type function and x is a type variable. -E.g. - id :: x ~ y => x -> y - id e = e - -involves the unification x = y. It is deferred until we bring into account the -context x ~ y to establish that it holds. - -If available, we defer original types (rather than those where closed type -synonyms have already been expanded via tcCoreView). This is, as usual, to -improve error messages. - - -************************************************************************ -* * - uVar and friends -* * -************************************************************************ - -@uVar@ is called when at least one of the types being unified is a -variable. It does {\em not} assume that the variable is a fixed point -of the substitution; rather, notice that @uVar@ (defined below) nips -back into @uTys@ if it turns out that the variable is already bound. --} - ----------- -uUnfilledVar :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1 - -> TcTauType -- Type 2 - -> TcM Coercion --- "Unfilled" means that the variable is definitely not a filled-in meta tyvar --- It might be a skolem, or untouchable, or meta - -uUnfilledVar origin t_or_k swapped tv1 ty2 - = do { ty2 <- zonkTcType ty2 - -- Zonk to expose things to the - -- occurs check, and so that if ty2 - -- looks like a type variable then it - -- /is/ a type variable - ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 } - ----------- -uUnfilledVar1 :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1 - -> TcTauType -- Type 2, zonked - -> TcM Coercion -uUnfilledVar1 origin t_or_k swapped tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 - = go tv2 - - | otherwise - = uUnfilledVar2 origin t_or_k swapped tv1 ty2 - - where - -- 'go' handles the case where both are - -- tyvars so we might want to swap - go tv2 | tv1 == tv2 -- Same type variable => no-op - = return (mkNomReflCo (mkTyVarTy tv1)) - - | swapOverTyVars tv1 tv2 -- Distinct type variables - = uUnfilledVar2 origin t_or_k (flipSwap swapped) - tv2 (mkTyVarTy tv1) - - | otherwise - = uUnfilledVar2 origin t_or_k swapped tv1 ty2 - ----------- -uUnfilledVar2 :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1 - -> TcTauType -- Type 2, zonked - -> TcM Coercion -uUnfilledVar2 origin t_or_k swapped tv1 ty2 - = do { dflags <- getDynFlags - ; cur_lvl <- getTcLevel - ; go dflags cur_lvl } - where - go dflags cur_lvl - | canSolveByUnification cur_lvl tv1 ty2 - , Just ty2' <- metaTyVarUpdateOK dflags tv1 ty2 - = do { co_k <- uType kind_origin KindLevel (typeKind ty2') (tyVarKind tv1) - ; co <- updateMeta tv1 ty2' co_k - ; return (maybe_sym swapped co) } - - | otherwise - = unSwap swapped (uType_defer origin t_or_k) ty1 ty2 - -- Occurs check or an untouchable: just defer - -- NB: occurs check isn't necessarily fatal: - -- eg tv1 occured in type family parameter - - ty1 = mkTyVarTy tv1 - kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k) - --- | apply sym iff swapped -maybe_sym :: SwapFlag -> Coercion -> Coercion -maybe_sym IsSwapped = mkSymCo -maybe_sym NotSwapped = id - -swapOverTyVars :: TcTyVar -> TcTyVar -> Bool -swapOverTyVars tv1 tv2 - | isFmvTyVar tv1 = False -- See Note [Fmv Orientation Invariant] - | isFmvTyVar tv2 = True - - | Just lvl1 <- metaTyVarTcLevel_maybe tv1 - -- If tv1 is touchable, swap only if tv2 is also - -- touchable and it's strictly better to update the latter - -- But see Note [Avoid unnecessary swaps] - = case metaTyVarTcLevel_maybe tv2 of - Nothing -> False - Just lvl2 | lvl2 `strictlyDeeperThan` lvl1 -> True - | lvl1 `strictlyDeeperThan` lvl2 -> False - | otherwise -> nicer_to_update tv2 - - -- So tv1 is not a meta tyvar - -- If only one is a meta tyvar, put it on the left - -- This is not because it'll be solved; but because - -- the floating step looks for meta tyvars on the left - | isMetaTyVar tv2 = True - - -- So neither is a meta tyvar (including FlatMetaTv) - - -- If only one is a flatten skolem, put it on the left - -- See Note [Eliminate flat-skols] - | not (isFlattenTyVar tv1), isFlattenTyVar tv2 = True - - | otherwise = False - - where - nicer_to_update tv2 - = (isSigTyVar tv1 && not (isSigTyVar tv2)) - || (isSystemName (Var.varName tv2) && not (isSystemName (Var.varName tv1))) - --- @trySpontaneousSolve wi@ solves equalities where one side is a --- touchable unification variable. --- Returns True <=> spontaneous solve happened -canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool -canSolveByUnification tclvl tv xi - | isTouchableMetaTyVar tclvl tv - = case metaTyVarInfo tv of - SigTv -> is_tyvar xi - _ -> True - - | otherwise -- Untouchable - = False - where - is_tyvar xi - = case tcGetTyVar_maybe xi of - Nothing -> False - Just tv -> case tcTyVarDetails tv of - MetaTv { mtv_info = info } - -> case info of - SigTv -> True - _ -> False - SkolemTv {} -> True - FlatSkol {} -> False - RuntimeUnk -> True - -{- Note [Fmv Orientation Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * We always orient a constraint - fmv ~ alpha - with fmv on the left, even if alpha is - a touchable unification variable - -Reason: doing it the other way round would unify alpha:=fmv, but that -really doesn't add any info to alpha. But a later constraint alpha ~ -Int might unlock everything. Comment:9 of #12526 gives a detailed -example. - -WARNING: I've gone to and fro on this one several times. -I'm now pretty sure that unifying alpha:=fmv is a bad idea! -So orienting with fmvs on the left is a good thing. - -This example comes from IndTypesPerfMerge. (Others include -T10226, T10009.) - From the ambiguity check for - f :: (F a ~ a) => a - we get: - [G] F a ~ a - [WD] F alpha ~ alpha, alpha ~ a - - From Givens we get - [G] F a ~ fsk, fsk ~ a - - Now if we flatten we get - [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a - - Now, if we unified alpha := fmv, we'd get - [WD] F fmv ~ fmv, [WD] fmv ~ a - And now we are stuck. - -So instead the Fmv Orientation Invariant puts te fmv on the -left, giving - [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a - - Now we get alpha:=a, and everything works out - -Note [Prevent unification with type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We prevent unification with type families because of an uneasy compromise. -It's perfectly sound to unify with type families, and it even improves the -error messages in the testsuite. It also modestly improves performance, at -least in some cases. But it's disastrous for test case perf/compiler/T3064. -Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a. -What do we do? Do we reduce F? Or do we use the given? Hard to know what's -best. GHC reduces. This is a disaster for T3064, where the type's size -spirals out of control during reduction. (We're not helped by the fact that -the flattener re-flattens all the arguments every time around.) If we prevent -unification with type families, then the solver happens to use the equality -before expanding the type family. - -It would be lovely in the future to revisit this problem and remove this -extra, unnecessary check. But we retain it for now as it seems to work -better in practice. - -Note [Refactoring hazard: checkTauTvUpdate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I (Richard E.) have a sad story about refactoring this code, retained here -to prevent others (or a future me!) from falling into the same traps. - -It all started with #11407, which was caused by the fact that the TyVarTy -case of defer_me didn't look in the kind. But it seemed reasonable to -simply remove the defer_me check instead. - -It referred to two Notes (since removed) that were out of date, and the -fast_check code in occurCheckExpand seemed to do just about the same thing as -defer_me. The one piece that defer_me did that wasn't repeated by -occurCheckExpand was the type-family check. (See Note [Prevent unification -with type families].) So I checked the result of occurCheckExpand for any -type family occurrences and deferred if there were any. This was done -in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 . - -This approach turned out not to be performant, because the expanded -type was bigger than the original type, and tyConsOfType (needed to -see if there are any type family occurrences) looks through type -synonyms. So it then struck me that we could dispense with the -defer_me check entirely. This simplified the code nicely, and it cut -the allocations in T5030 by half. But, as documented in Note [Prevent -unification with type families], this destroyed performance in -T3064. Regardless, I missed this regression and the change was -committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d . - -Bottom lines: - * defer_me is back, but now fixed w.r.t. #11407. - * Tread carefully before you start to refactor here. There can be - lots of hard-to-predict consequences. - -Note [Type synonyms and the occur check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking we try to update a variable with type synonyms not -expanded, which improves later error messages, unless looking -inside a type synonym may help resolve a spurious occurs check -error. Consider: - type A a = () - - f :: (A a -> a -> ()) -> () - f = \ _ -> () - - x :: () - x = f (\ x p -> p x) - -We will eventually get a constraint of the form t ~ A t. The ok function above will -properly expand the type (A t) to just (), which is ok to be unified with t. If we had -unified with the original type A t, we would lead the type checker into an infinite loop. - -Hence, if the occurs check fails for a type synonym application, then (and *only* then), -the ok function expands the synonym to detect opportunities for occurs check success using -the underlying definition of the type synonym. - -The same applies later on in the constraint interaction code; see TcInteract, -function @occ_check_ok@. - -Note [Non-TcTyVars in TcUnify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because the same code is now shared between unifying types and unifying -kinds, we sometimes will see proper TyVars floating around the unifier. -Example (from test case polykinds/PolyKinds12): - - type family Apply (f :: k1 -> k2) (x :: k1) :: k2 - type instance Apply g y = g y - -When checking the instance declaration, we first *kind-check* the LHS -and RHS, discovering that the instance really should be - - type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y - -During this kind-checking, all the tyvars will be TcTyVars. Then, however, -as a second pass, we desugar the RHS (which is done in functions prefixed -with "tc" in TcTyClsDecls"). By this time, all the kind-vars are proper -TyVars, not TcTyVars, get some kind unification must happen. - -Thus, we always check if a TyVar is a TcTyVar before asking if it's a -meta-tyvar. - -This used to not be necessary for type-checking (that is, before * :: *) -because expressions get desugared via an algorithm separate from -type-checking (with wrappers, etc.). Types get desugared very differently, -causing this wibble in behavior seen here. --} - -data LookupTyVarResult -- The result of a lookupTcTyVar call - = Unfilled TcTyVarDetails -- SkolemTv or virgin MetaTv - | Filled TcType - -lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult -lookupTcTyVar tyvar - | MetaTv { mtv_ref = ref } <- details - = do { meta_details <- readMutVar ref - ; case meta_details of - Indirect ty -> return (Filled ty) - Flexi -> do { is_touchable <- isTouchableTcM tyvar - -- Note [Unifying untouchables] - ; if is_touchable then - return (Unfilled details) - else - return (Unfilled vanillaSkolemTv) } } - | otherwise - = return (Unfilled details) - where - details = tcTyVarDetails tyvar - --- | Fill in a meta-tyvar -updateMeta :: TcTyVar -- ^ tv to fill in, tv :: k1 - -> TcType -- ^ ty2 :: k2 - -> Coercion -- ^ kind_co :: k2 ~N k1 - -> TcM Coercion -- ^ :: tv ~N ty2 (= ty2 |> kind_co ~N ty2) -updateMeta tv1 ty2 kind_co - = do { let ty2' = ty2 `mkCastTy` kind_co - ty2_refl = mkNomReflCo ty2 - co = mkCoherenceLeftCo ty2_refl kind_co - ; writeMetaTyVar tv1 ty2' - ; return co } - -{- -Note [Unifying untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat an untouchable type variable as if it was a skolem. That -ensures it won't unify with anything. It's a slight had, because -we return a made-up TcTyVarDetails, but I think it works smoothly. --} - --- | Breaks apart a function kind into its pieces. -matchExpectedFunKind :: Arity -- ^ # of args remaining, only for errors - -> TcType -- ^ type, only for errors - -> TcKind -- ^ function kind - -> TcM (Coercion, TcKind, TcKind) - -- ^ co :: old_kind ~ arg -> res -matchExpectedFunKind num_args_remaining ty = go - where - go k | Just k' <- tcView k = go k' - - go k@(TyVarTy kvar) - | isTcTyVar kvar, isMetaTyVar kvar - = do { maybe_kind <- readMetaTyVar kvar - ; case maybe_kind of - Indirect fun_kind -> go fun_kind - Flexi -> defer k } - - go k@(FunTy arg res) = return (mkNomReflCo k, arg, res) - go other = defer other - - defer k - = do { arg_kind <- newMetaKindVar - ; res_kind <- newMetaKindVar - ; let new_fun = mkFunTy arg_kind res_kind - thing = mkTypeErrorThingArgs ty num_args_remaining - origin = TypeEqOrigin { uo_actual = k - , uo_expected = new_fun - , uo_thing = Just thing - } - ; co <- uType origin KindLevel k new_fun - ; return (co, arg_kind, res_kind) } - - -{- ********************************************************************* -* * - Occurrence checking -* * -********************************************************************* -} - - -{- Note [Occurs check expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid -of occurrences of tv outside type function arguments, if that is -possible; otherwise, it returns Nothing. - -For example, suppose we have - type F a b = [a] -Then - occCheckExpand b (F Int b) = Just [Int] -but - occCheckExpand a (F a Int) = Nothing - -We don't promise to do the absolute minimum amount of expanding -necessary, but we try not to do expansions we don't need to. We -prefer doing inner expansions first. For example, - type F a b = (a, Int, a, [a]) - type G b = Char -We have - occCheckExpand b (F (G b)) = Just (F Char) -even though we could also expand F to get rid of b. - -The two variants of the function are to support TcUnify.checkTauTvUpdate, -which wants to prevent unification with type families. For more on this -point, see Note [Prevent unification with type families] in TcUnify. - -Note [Occurrence checking: look inside kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are considering unifying - (alpha :: *) ~ Int -> (beta :: alpha -> alpha) -This may be an error (what is that alpha doing inside beta's kind?), -but we must not make the mistake of actuallyy unifying or we'll -build an infinite data structure. So when looking for occurrences -of alpha in the rhs, we must look in the kinds of type variables -that occur there. - -NB: we may be able to remove the problem via expansion; see - Note [Occurs check expansion]. So we have to try that. - -Note [Checking for foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unless we have -XImpredicativeTypes (which is a totally unsupported -feature), we do not want to unify - alpha ~ (forall a. a->a) -> Int -So we look for foralls hidden inside the type, and it's convenient -to do that at the same time as the occurs check (which looks for -occurrences of alpha). - -However, it's not just a question of looking for foralls /anywhere/! -Consider - (alpha :: forall k. k->*) ~ (beta :: forall k. k->*) -This is legal; e.g. dependent/should_compile/T11635. - -We don't want to reject it because of the forall in beta's kind, -but (see Note [Occurrence checking: look inside kinds]) we do -need to look in beta's kind. So we carry a flag saying if a 'forall' -is OK, and sitch the flag on when stepping inside a kind. - -Why is it OK? Why does it not count as impredicative polymorphism? -The reason foralls are bad is because we reply on "seeing" foralls -when doing implicit instantiation. But the forall inside the kind is -fine. We'll generate a kind equality constraint - (forall k. k->*) ~ (forall k. k->*) -to check that the kinds of lhs and rhs are compatible. If alpha's -kind had instead been - (alpha :: kappa) -then this kind equality would rightly complain about unifying kappa -with (forall k. k->*) - --} - -data OccCheckResult a - = OC_OK a - | OC_Bad -- Forall or type family - | OC_Occurs - -instance Functor OccCheckResult where - fmap = liftM - -instance Applicative OccCheckResult where - pure = OC_OK - (<*>) = ap - -instance Monad OccCheckResult where - OC_OK x >>= k = k x - OC_Bad >>= _ = OC_Bad - OC_Occurs >>= _ = OC_Occurs - -occCheckForErrors :: DynFlags -> TcTyVar -> Type -> OccCheckResult () --- Just for error-message generation; so we return OccCheckResult --- so the caller can report the right kind of error --- Check whether --- a) the given variable occurs in the given type. --- b) there is a forall in the type (unless we have -XImpredicativeTypes) -occCheckForErrors dflags tv ty - = case preCheck dflags True tv ty of - OC_OK _ -> OC_OK () - OC_Bad -> OC_Bad - OC_Occurs -> case occCheckExpand tv ty of - Nothing -> OC_Occurs - Just _ -> OC_OK () - ----------------- -metaTyVarUpdateOK :: DynFlags - -> TcTyVar -- tv :: k1 - -> TcType -- ty :: k2 - -> Maybe TcType -- possibly-expanded ty --- (metaTyFVarUpdateOK tv ty) --- We are about to update the meta-tyvar tv with ty --- Check (a) that tv doesn't occur in ty (occurs check) --- (b) that ty does not have any foralls --- (in the impredicative case), or type functions --- --- We have two possible outcomes: --- (1) Return the type to update the type variable with, --- [we know the update is ok] --- (2) Return Nothing, --- [the update might be dodgy] --- --- Note that "Nothing" does not mean "definite error". For example --- type family F a --- type instance F Int = Int --- consider --- a ~ F a --- This is perfectly reasonable, if we later get a ~ Int. For now, though, --- we return Nothing, leaving it to the later constraint simplifier to --- sort matters out. --- --- See Note [Refactoring hazard: checkTauTvUpdate] - -metaTyVarUpdateOK dflags tv ty - = case preCheck dflags False tv ty of - -- False <=> type families not ok - -- See Note [Prevent unification with type families] - OC_OK _ -> Just ty - OC_Bad -> Nothing -- forall or type function - OC_Occurs -> occCheckExpand tv ty - -preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> OccCheckResult () --- A quick check for --- (a) a forall type (unless -XImpredivativeTypes) --- (b) a type family --- (c) an occurrence of the type variable (occurs check) --- --- For (a) and (b) we check only the top level of the type, NOT --- inside the kinds of variables it mentions. But for (c) we do --- look in the kinds of course. - -preCheck dflags ty_fam_ok tv ty - = fast_check ty - where - details = tcTyVarDetails tv - impredicative_ok = canUnifyWithPolyType dflags details - - ok :: OccCheckResult () - ok = OC_OK () - - fast_check :: TcType -> OccCheckResult () - fast_check (TyVarTy tv') - | tv == tv' = OC_Occurs - | otherwise = fast_check_occ (tyVarKind tv') - -- See Note [Occurrence checking: look inside kinds] - - fast_check (TyConApp tc tys) - | bad_tc tc = OC_Bad - | otherwise = mapM fast_check tys >> ok - fast_check (LitTy {}) = ok - fast_check (FunTy a r) = fast_check a >> fast_check r - fast_check (AppTy fun arg) = fast_check fun >> fast_check arg - fast_check (CastTy ty co) = fast_check ty >> fast_check_co co - fast_check (CoercionTy co) = fast_check_co co - fast_check (ForAllTy (TvBndr tv' _) ty) - | not impredicative_ok = OC_Bad - | tv == tv' = ok - | otherwise = do { fast_check_occ (tyVarKind tv') - ; fast_check_occ ty } - -- Under a forall we look only for occurrences of - -- the type variable - - -- For kinds, we only do an occurs check; we do not worry - -- about type families or foralls - -- See Note [Checking for foralls] - fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = OC_Occurs - | otherwise = ok - - -- For coercions, we are only doing an occurs check here; - -- no bother about impredicativity in coercions, as they're - -- inferred - fast_check_co co | tv `elemVarSet` tyCoVarsOfCo co = OC_Occurs - | otherwise = ok - - bad_tc :: TyCon -> Bool - bad_tc tc - | not (impredicative_ok || isTauTyCon tc) = True - | not (ty_fam_ok || isFamFreeTyCon tc) = True - | otherwise = False - -occCheckExpand :: TcTyVar -> TcType -> Maybe TcType --- See Note [Occurs check expansion] --- We may have needed to do some type synonym unfolding in order to --- get rid of the variable (or forall), so we also return the unfolded --- version of the type, which is guaranteed to be syntactically free --- of the given type variable. If the type is already syntactically --- free of the variable, then the same type is returned. -occCheckExpand tv ty - = go emptyVarEnv ty - where - go :: VarEnv TyVar -> Type -> Maybe Type - -- The VarEnv carries mappings necessary - -- because of kind expansion - go env (TyVarTy tv') - | tv == tv' = Nothing - | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'') - | otherwise = do { k' <- go env (tyVarKind tv') - ; return (mkTyVarTy $ - setTyVarKind tv' k') } - -- See Note [Occurrence checking: look inside kinds] - - go _ ty@(LitTy {}) = return ty - go env (AppTy ty1 ty2) = do { ty1' <- go env ty1 - ; ty2' <- go env ty2 - ; return (mkAppTy ty1' ty2') } - go env (FunTy ty1 ty2) = do { ty1' <- go env ty1 - ; ty2' <- go env ty2 - ; return (mkFunTy ty1' ty2') } - go env ty@(ForAllTy (TvBndr tv' vis) body_ty) - | tv == tv' = return ty - | otherwise = do { ki' <- go env (tyVarKind tv') - ; let tv'' = setTyVarKind tv' ki' - env' = extendVarEnv env tv' tv'' - ; body' <- go env' body_ty - ; return (ForAllTy (TvBndr tv'' vis) body') } - - -- For a type constructor application, first try expanding away the - -- offending variable from the arguments. If that doesn't work, next - -- see if the type constructor is a type synonym, and if so, expand - -- it and try again. - go env ty@(TyConApp tc tys) - = case mapM (go env) tys of - Just tys' -> return (mkTyConApp tc tys') - Nothing | Just ty' <- tcView ty -> go env ty' - | otherwise -> Nothing - -- Failing that, try to expand a synonym - - go env (CastTy ty co) = do { ty' <- go env ty - ; co' <- go_co env co - ; return (mkCastTy ty' co') } - go env (CoercionTy co) = do { co' <- go_co env co - ; return (mkCoercionTy co') } - - ------------------ - go_co env (Refl r ty) = do { ty' <- go env ty - ; return (mkReflCo r ty') } - -- Note: Coercions do not contain type synonyms - go_co env (TyConAppCo r tc args) = do { args' <- mapM (go_co env) args - ; return (mkTyConAppCo r tc args') } - go_co env (AppCo co arg) = do { co' <- go_co env co - ; arg' <- go_co env arg - ; return (mkAppCo co' arg') } - go_co env co@(ForAllCo tv' kind_co body_co) - | tv == tv' = return co - | otherwise = do { kind_co' <- go_co env kind_co - ; let tv'' = setTyVarKind tv' $ - pFst (coercionKind kind_co') - env' = extendVarEnv env tv' tv'' - ; body' <- go_co env' body_co - ; return (ForAllCo tv'' kind_co' body') } - go_co env (FunCo r co1 co2) = do { co1' <- go_co env co1 - ; co2' <- go_co env co2 - ; return (mkFunCo r co1' co2') } - go_co env (CoVarCo c) = do { k' <- go env (varType c) - ; return (mkCoVarCo (setVarType c k')) } - go_co env (AxiomInstCo ax ind args) = do { args' <- mapM (go_co env) args - ; return (mkAxiomInstCo ax ind args') } - go_co env (UnivCo p r ty1 ty2) = do { p' <- go_prov env p - ; ty1' <- go env ty1 - ; ty2' <- go env ty2 - ; return (mkUnivCo p' r ty1' ty2') } - go_co env (SymCo co) = do { co' <- go_co env co - ; return (mkSymCo co') } - go_co env (TransCo co1 co2) = do { co1' <- go_co env co1 - ; co2' <- go_co env co2 - ; return (mkTransCo co1' co2') } - go_co env (NthCo n co) = do { co' <- go_co env co - ; return (mkNthCo n co') } - go_co env (LRCo lr co) = do { co' <- go_co env co - ; return (mkLRCo lr co') } - go_co env (InstCo co arg) = do { co' <- go_co env co - ; arg' <- go_co env arg - ; return (mkInstCo co' arg') } - go_co env (CoherenceCo co1 co2) = do { co1' <- go_co env co1 - ; co2' <- go_co env co2 - ; return (mkCoherenceCo co1' co2') } - go_co env (KindCo co) = do { co' <- go_co env co - ; return (mkKindCo co') } - go_co env (SubCo co) = do { co' <- go_co env co - ; return (mkSubCo co') } - go_co env (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co env) cs - ; return (mkAxiomRuleCo ax cs') } - - ------------------ - go_prov _ UnsafeCoerceProv = return UnsafeCoerceProv - go_prov env (PhantomProv co) = PhantomProv <$> go_co env co - go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co - go_prov _ p@(PluginProv _) = return p - go_prov _ p@(HoleProv _) = return p - -canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool -canUnifyWithPolyType dflags details - = case details of - MetaTv { mtv_info = SigTv } -> False - MetaTv { mtv_info = TauTv } -> xopt LangExt.ImpredicativeTypes dflags - _other -> True - -- We can have non-meta tyvars in given constraints diff --git a/typecheck/TcUnify.hs-boot b/typecheck/TcUnify.hs-boot deleted file mode 100644 --- a/typecheck/TcUnify.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -module TcUnify where -import TcType ( TcTauType ) -import TcRnTypes ( TcM ) -import TcEvidence ( TcCoercion ) -import Outputable ( Outputable ) -import HsExpr ( HsExpr ) -import Name ( Name ) - --- This boot file exists only to tie the knot between --- TcUnify and Inst - -unifyType :: Outputable a => Maybe a -> TcTauType -> TcTauType -> TcM TcCoercion -unifyKind :: Outputable a => Maybe a -> TcTauType -> TcTauType -> TcM TcCoercion -noThing :: Maybe (HsExpr Name) diff --git a/typecheck/TcValidity.hs b/typecheck/TcValidity.hs deleted file mode 100644 --- a/typecheck/TcValidity.hs +++ /dev/null @@ -1,2036 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, TupleSections, ViewPatterns #-} - -module TcValidity ( - Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, - ContextKind(..), expectedKindInCtxt, - checkValidTheta, checkValidFamPats, - checkValidInstance, validDerivPred, - checkInstTermination, checkTySynRhs, - ClsInstInfo, checkValidCoAxiom, checkValidCoAxBranch, - checkValidTyFamEqn, - arityErr, badATErr, - checkValidTelescope, checkZonkValidTelescope, checkValidInferredKinds, - allDistinctTyVars - ) where - -#include "HsVersions.h" - -import Maybes - --- friends: -import TcUnify ( tcSubType_NC ) -import TcSimplify ( simplifyAmbiguityCheck ) -import TyCoRep -import TcType hiding ( sizeType, sizeTypes ) -import TcMType -import PrelNames -import Type -import Coercion -import Kind -import CoAxiom -import Class -import TyCon - --- others: -import HsSyn -- HsType -import TcRnMonad -- TcType, amongst others -import TcEnv ( tcGetInstEnvs ) -import FunDeps -import InstEnv ( InstMatch, lookupInstEnv ) -import FamInstEnv ( isDominatedBy, injectiveBranches, - InjectivityCheckResult(..) ) -import FamInst ( makeInjectivityErrors ) -import Name -import VarEnv -import VarSet -import UniqSet -import Var ( TyVarBndr(..), mkTyVar ) -import ErrUtils -import DynFlags -import Util -import ListSetOps -import SrcLoc -import Outputable -import BasicTypes -import Module -import Unique ( mkAlphaTyVarUnique ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.List ( (\\) ) - -{- -************************************************************************ -* * - Checking for ambiguity -* * -************************************************************************ - -Note [The ambiguity check for type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -checkAmbiguity is a check on *user-supplied type signatures*. It is -*purely* there to report functions that cannot possibly be called. So for -example we want to reject: - f :: C a => Int -The idea is there can be no legal calls to 'f' because every call will -give rise to an ambiguous constraint. We could soundly omit the -ambiguity check on type signatures entirely, at the expense of -delaying ambiguity errors to call sites. Indeed, the flag --XAllowAmbiguousTypes switches off the ambiguity check. - -What about things like this: - class D a b | a -> b where .. - h :: D Int b => Int -The Int may well fix 'b' at the call site, so that signature should -not be rejected. Moreover, using *visible* fundeps is too -conservative. Consider - class X a b where ... - class D a b | a -> b where ... - instance D a b => X [a] b where... - h :: X a b => a -> a -Here h's type looks ambiguous in 'b', but here's a legal call: - ...(h [True])... -That gives rise to a (X [Bool] beta) constraint, and using the -instance means we need (D Bool beta) and that fixes 'beta' via D's -fundep! - -Behind all these special cases there is a simple guiding principle. -Consider - - f :: - f = ...blah... - - g :: - g = f - -You would think that the definition of g would surely typecheck! -After all f has exactly the same type, and g=f. But in fact f's type -is instantiated and the instantiated constraints are solved against -the originals, so in the case an ambiguous type it won't work. -Consider our earlier example f :: C a => Int. Then in g's definition, -we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a), -and fail. - -So in fact we use this as our *definition* of ambiguity. We use a -very similar test for *inferred* types, to ensure that they are -unambiguous. See Note [Impedance matching] in TcBinds. - -This test is very conveniently implemented by calling - tcSubType -This neatly takes account of the functional dependecy stuff above, -and implicit parameter (see Note [Implicit parameters and ambiguity]). -And this is what checkAmbiguity does. - -What about this, though? - g :: C [a] => Int -Is every call to 'g' ambiguous? After all, we might have - instance C [a] where ... -at the call site. So maybe that type is ok! Indeed even f's -quintessentially ambiguous type might, just possibly be callable: -with -XFlexibleInstances we could have - instance C a where ... -and now a call could be legal after all! Well, we'll reject this -unless the instance is available *here*. - -Note [When to call checkAmbiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We call checkAmbiguity - (a) on user-specified type signatures - (b) in checkValidType - -Conncerning (b), you might wonder about nested foralls. What about - f :: forall b. (forall a. Eq a => b) -> b -The nested forall is ambiguous. Originally we called checkAmbiguity -in the forall case of check_type, but that had two bad consequences: - * We got two error messages about (Eq b) in a nested forall like this: - g :: forall a. Eq a => forall b. Eq b => a -> a - * If we try to check for ambiguity of an nested forall like - (forall a. Eq a => b), the implication constraint doesn't bind - all the skolems, which results in "No skolem info" in error - messages (see Trac #10432). - -To avoid this, we call checkAmbiguity once, at the top, in checkValidType. -(I'm still a bit worried about unbound skolems when the type mentions -in-scope type variables.) - -In fact, because of the co/contra-variance implemented in tcSubType, -this *does* catch function f above. too. - -Concerning (a) the ambiguity check is only used for *user* types, not -for types coming from inteface files. The latter can legitimately -have ambiguous types. Example - - class S a where s :: a -> (Int,Int) - instance S Char where s _ = (1,1) - f:: S a => [a] -> Int -> (Int,Int) - f (_::[a]) x = (a*x,b) - where (a,b) = s (undefined::a) - -Here the worker for f gets the type - fw :: forall a. S a => Int -> (# Int, Int #) - - -Note [Implicit parameters and ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Only a *class* predicate can give rise to ambiguity -An *implicit parameter* cannot. For example: - foo :: (?x :: [a]) => Int - foo = length ?x -is fine. The call site will supply a particular 'x' - -Furthermore, the type variables fixed by an implicit parameter -propagate to the others. E.g. - foo :: (Show a, ?x::[a]) => Int - foo = show (?x++?x) -The type of foo looks ambiguous. But it isn't, because at a call site -we might have - let ?x = 5::Int in foo -and all is well. In effect, implicit parameters are, well, parameters, -so we can take their type variables into account as part of the -"tau-tvs" stuff. This is done in the function 'FunDeps.grow'. --} - -checkAmbiguity :: UserTypeCtxt -> Type -> TcM () -checkAmbiguity ctxt ty - | wantAmbiguityCheck ctxt - = do { traceTc "Ambiguity check for" (ppr ty) - -- Solve the constraints eagerly because an ambiguous type - -- can cause a cascade of further errors. Since the free - -- tyvars are skolemised, we can safely use tcSimplifyTop - ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes - ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ - captureConstraints $ - tcSubType_NC ctxt ty ty - ; simplifyAmbiguityCheck ty wanted - - ; traceTc "Done ambiguity check for" (ppr ty) } - - | otherwise - = return () - where - mk_msg allow_ambiguous - = vcat [ text "In the ambiguity check for" <+> what - , ppUnless allow_ambiguous ambig_msg ] - ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes" - what | Just n <- isSigMaybe ctxt = quotes (ppr n) - | otherwise = pprUserTypeCtxt ctxt - -wantAmbiguityCheck :: UserTypeCtxt -> Bool -wantAmbiguityCheck ctxt - = case ctxt of -- See Note [When we don't check for ambiguity] - GhciCtxt -> False - TySynCtxt {} -> False - _ -> True - -checkUserTypeError :: Type -> TcM () --- Check to see if the type signature mentions "TypeError blah" --- anywhere in it, and fail if so. --- --- Very unsatisfactorily (Trac #11144) we need to tidy the type --- because it may have come from an /inferred/ signature, not a --- user-supplied one. This is really only a half-baked fix; --- the other errors in checkValidType don't do tidying, and so --- may give bad error messages when given an inferred type. -checkUserTypeError = check - where - check ty - | Just msg <- userTypeError_maybe ty = fail_with msg - | Just (_,ts) <- splitTyConApp_maybe ty = mapM_ check ts - | Just (t1,t2) <- splitAppTy_maybe ty = check t1 >> check t2 - | Just (_,t1) <- splitForAllTy_maybe ty = check t1 - | otherwise = return () - - fail_with msg = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_msg) = tidyOpenType env0 msg - ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) } - - -{- Note [When we don't check for ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a few places we do not want to check a user-specified type for ambiguity - -* GhciCtxt: Allow ambiguous types in GHCi's :kind command - E.g. type family T a :: * -- T :: forall k. k -> * - Then :k T should work in GHCi, not complain that - (T k) is ambiguous! - -* TySynCtxt: type T a b = C a b => blah - It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow - cure the ambiguity. So we defer the ambiguity check to the use site. - - There is also an implementation reason (Trac #11608). In the RHS of - a type synonym we don't (currently) instantiate 'a' and 'b' with - TcTyVars before calling checkValidType, so we get asertion failures - from doing an ambiguity check on a type with TyVars in it. Fixing this - would not be hard, but let's wait till there's a reason. - - -************************************************************************ -* * - Checking validity of a user-defined type -* * -************************************************************************ - -When dealing with a user-written type, we first translate it from an HsType -to a Type, performing kind checking, and then check various things that should -be true about it. We don't want to perform these checks at the same time -as the initial translation because (a) they are unnecessary for interface-file -types and (b) when checking a mutually recursive group of type and class decls, -we can't "look" at the tycons/classes yet. Also, the checks are rather -diverse, and used to really mess up the other code. - -One thing we check for is 'rank'. - - Rank 0: monotypes (no foralls) - Rank 1: foralls at the front only, Rank 0 inside - Rank 2: foralls at the front, Rank 1 on left of fn arrow, - - basic ::= tyvar | T basic ... basic - - r2 ::= forall tvs. cxt => r2a - r2a ::= r1 -> r2a | basic - r1 ::= forall tvs. cxt => r0 - r0 ::= r0 -> r0 | basic - -Another thing is to check that type synonyms are saturated. -This might not necessarily show up in kind checking. - type A i = i - data T k = MkT (k Int) - f :: T A -- BAD! --} - -checkValidType :: UserTypeCtxt -> Type -> TcM () --- Checks that a user-written type is valid for the given context --- Assumes argument is fully zonked --- Not used for instance decls; checkValidInstance instead -checkValidType ctxt ty - = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) - ; rankn_flag <- xoptM LangExt.RankNTypes - ; impred_flag <- xoptM LangExt.ImpredicativeTypes - ; let gen_rank :: Rank -> Rank - gen_rank r | rankn_flag = ArbitraryRank - | otherwise = r - - rank1 = gen_rank r1 - rank0 = gen_rank r0 - - r0 = rankZeroMonoType - r1 = LimitedRank True r0 - - rank - = case ctxt of - DefaultDeclCtxt-> MustBeMonoType - ResSigCtxt -> MustBeMonoType - PatSigCtxt -> rank0 - RuleSigCtxt _ -> rank1 - TySynCtxt _ -> rank0 - - ExprSigCtxt -> rank1 - TypeAppCtxt | impred_flag -> ArbitraryRank - | otherwise -> tyConArgMonoType - -- Normally, ImpredicativeTypes is handled in check_arg_type, - -- but visible type applications don't go through there. - -- So we do this check here. - - FunSigCtxt {} -> rank1 - InfSigCtxt _ -> ArbitraryRank -- Inferred type - ConArgCtxt _ -> rank1 -- We are given the type of the entire - -- constructor, hence rank 1 - PatSynCtxt _ -> rank1 - - ForSigCtxt _ -> rank1 - SpecInstCtxt -> rank1 - ThBrackCtxt -> rank1 - GhciCtxt -> ArbitraryRank - _ -> panic "checkValidType" - -- Can't happen; not used for *user* sigs - - ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) - - -- Check the internal validity of the type itself - ; check_type env ctxt rank ty - - ; checkUserTypeError ty - - -- Check for ambiguous types. See Note [When to call checkAmbiguity] - -- NB: this will happen even for monotypes, but that should be cheap; - -- and there may be nested foralls for the subtype test to examine - ; checkAmbiguity ctxt ty - - ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) } - -checkValidMonoType :: Type -> TcM () --- Assumes argument is fully zonked -checkValidMonoType ty - = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) - ; check_type env SigmaCtxt MustBeMonoType ty } - -checkTySynRhs :: UserTypeCtxt -> TcType -> TcM () -checkTySynRhs ctxt ty - | returnsConstraintKind actual_kind - = do { ck <- xoptM LangExt.ConstraintKinds - ; if ck - then when (isConstraintKind actual_kind) - (do { dflags <- getDynFlags - ; check_pred_ty emptyTidyEnv dflags ctxt ty }) - else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) } - - | otherwise - = return () - where - actual_kind = typeKind ty - --- | The kind expected in a certain context. -data ContextKind = TheKind Kind -- ^ a specific kind - | AnythingKind -- ^ any kind will do - | OpenKind -- ^ something of the form @TYPE _@ - --- Depending on the context, we might accept any kind (for instance, in a TH --- splice), or only certain kinds (like in type signatures). -expectedKindInCtxt :: UserTypeCtxt -> ContextKind -expectedKindInCtxt (TySynCtxt _) = AnythingKind -expectedKindInCtxt ThBrackCtxt = AnythingKind -expectedKindInCtxt GhciCtxt = AnythingKind --- The types in a 'default' decl can have varying kinds --- See Note [Extended defaults]" in TcEnv -expectedKindInCtxt DefaultDeclCtxt = AnythingKind -expectedKindInCtxt TypeAppCtxt = AnythingKind -expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind -expectedKindInCtxt InstDeclCtxt = TheKind constraintKind -expectedKindInCtxt SpecInstCtxt = TheKind constraintKind -expectedKindInCtxt _ = OpenKind - -{- -Note [Higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~ -Technically - Int -> forall a. a->a -is still a rank-1 type, but it's not Haskell 98 (Trac #5957). So the -validity checker allow a forall after an arrow only if we allow it -before -- that is, with Rank2Types or RankNTypes --} - -data Rank = ArbitraryRank -- Any rank ok - - | LimitedRank -- Note [Higher rank types] - Bool -- Forall ok at top - Rank -- Use for function arguments - - | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype - - | MustBeMonoType -- Monotype regardless of flags - - -rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank -rankZeroMonoType = MonoType (text "Perhaps you intended to use RankNTypes or Rank2Types") -tyConArgMonoType = MonoType (text "GHC doesn't yet support impredicative polymorphism") -synArgMonoType = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms") -constraintMonoType = MonoType (text "A constraint must be a monotype") - -funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result -funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) -funArgResRank other_rank = (other_rank, other_rank) - -forAllAllowed :: Rank -> Bool -forAllAllowed ArbitraryRank = True -forAllAllowed (LimitedRank forall_ok _) = forall_ok -forAllAllowed _ = False - ----------------------------------------- -check_type :: TidyEnv -> UserTypeCtxt -> Rank -> Type -> TcM () --- The args say what the *type context* requires, independent --- of *flag* settings. You test the flag settings at usage sites. --- --- Rank is allowed rank for function args --- Rank 0 means no for-alls anywhere - -check_type env ctxt rank ty - | not (null tvs && null theta) - = do { traceTc "check_type" (ppr ty $$ ppr (forAllAllowed rank)) - ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty) - -- Reject e.g. (Maybe (?x::Int => Int)), - -- with a decent error message - - ; check_valid_theta env' SigmaCtxt theta - -- Allow type T = ?x::Int => Int -> Int - -- but not type T = ?x::Int - - ; check_type env' ctxt rank tau -- Allow foralls to right of arrow - ; checkTcM (not (any (`elemVarSet` tyCoVarsOfType phi_kind) tvs)) - (forAllEscapeErr env' ty tau_kind) - } - where - (tvs, theta, tau) = tcSplitSigmaTy ty - tau_kind = typeKind tau - (env', _) = tidyTyCoVarBndrs env tvs - - phi_kind | null theta = tau_kind - | otherwise = liftedTypeKind - -- If there are any constraints, the kind is *. (#11405) - -check_type _ _ _ (TyVarTy _) = return () - -check_type env ctxt rank (FunTy arg_ty res_ty) - = do { check_type env ctxt arg_rank arg_ty - ; check_type env ctxt res_rank res_ty } - where - (arg_rank, res_rank) = funArgResRank rank - -check_type env ctxt rank (AppTy ty1 ty2) - = do { check_arg_type env ctxt rank ty1 - ; check_arg_type env ctxt rank ty2 } - -check_type env ctxt rank ty@(TyConApp tc tys) - | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - = check_syn_tc_app env ctxt rank ty tc tys - | isUnboxedTupleTyCon tc = check_ubx_tuple env ctxt ty tys - | otherwise = mapM_ (check_arg_type env ctxt rank) tys - -check_type _ _ _ (LitTy {}) = return () - -check_type env ctxt rank (CastTy ty _) = check_type env ctxt rank ty - -check_type _ _ _ ty = pprPanic "check_type" (ppr ty) - ----------------------------------------- -check_syn_tc_app :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType - -> TyCon -> [KindOrType] -> TcM () --- Used for type synonyms and type synonym families, --- which must be saturated, --- but not data families, which need not be saturated -check_syn_tc_app env ctxt rank ty tc tys - | tc_arity <= length tys -- Saturated - -- Check that the synonym has enough args - -- This applies equally to open and closed synonyms - -- It's OK to have an *over-applied* type synonym - -- data Tree a b = ... - -- type Foo a = Tree [a] - -- f :: Foo a b -> ... - = do { -- See Note [Liberal type synonyms] - ; liberal <- xoptM LangExt.LiberalTypeSynonyms - ; if not liberal || isTypeFamilyTyCon tc then - -- For H98 and synonym families, do check the type args - mapM_ check_arg tys - - else -- In the liberal case (only for closed syns), expand then check - case tcView ty of - Just ty' -> check_type env ctxt rank ty' - Nothing -> pprPanic "check_tau_type" (ppr ty) } - - | GhciCtxt <- ctxt -- Accept under-saturated type synonyms in - -- GHCi :kind commands; see Trac #7586 - = mapM_ check_arg tys - - | otherwise - = failWithTc (tyConArityErr tc tys) - where - tc_arity = tyConArity tc - check_arg | isTypeFamilyTyCon tc = check_arg_type env ctxt rank - | otherwise = check_type env ctxt synArgMonoType - ----------------------------------------- -check_ubx_tuple :: TidyEnv -> UserTypeCtxt -> KindOrType - -> [KindOrType] -> TcM () -check_ubx_tuple env ctxt ty tys - = do { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples - ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty) - - ; impred <- xoptM LangExt.ImpredicativeTypes - ; let rank' = if impred then ArbitraryRank else tyConArgMonoType - -- c.f. check_arg_type - -- However, args are allowed to be unlifted, or - -- more unboxed tuples, so can't use check_arg_ty - ; mapM_ (check_type env ctxt rank') tys } - ----------------------------------------- -check_arg_type :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType -> TcM () --- The sort of type that can instantiate a type variable, --- or be the argument of a type constructor. --- Not an unboxed tuple, but now *can* be a forall (since impredicativity) --- Other unboxed types are very occasionally allowed as type --- arguments depending on the kind of the type constructor --- --- For example, we want to reject things like: --- --- instance Ord a => Ord (forall s. T s a) --- and --- g :: T s (forall b.b) --- --- NB: unboxed tuples can have polymorphic or unboxed args. --- This happens in the workers for functions returning --- product types with polymorphic components. --- But not in user code. --- Anyway, they are dealt with by a special case in check_tau_type - -check_arg_type _ _ _ (CoercionTy {}) = return () - -check_arg_type env ctxt rank ty - = do { impred <- xoptM LangExt.ImpredicativeTypes - ; let rank' = case rank of -- Predictive => must be monotype - MustBeMonoType -> MustBeMonoType -- Monotype, regardless - _other | impred -> ArbitraryRank - | otherwise -> tyConArgMonoType - -- Make sure that MustBeMonoType is propagated, - -- so that we don't suggest -XImpredicativeTypes in - -- (Ord (forall a.a)) => a -> a - -- and so that if it Must be a monotype, we check that it is! - - ; check_type env ctxt rank' ty } - ----------------------------------------- -forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc) -forAllTyErr env rank ty - = ( env - , vcat [ hang herald 2 (ppr_tidy env ty) - , suggestion ] ) - where - (tvs, _theta, _tau) = tcSplitSigmaTy ty - herald | null tvs = text "Illegal qualified type:" - | otherwise = text "Illegal polymorphic type:" - suggestion = case rank of - LimitedRank {} -> text "Perhaps you intended to use RankNTypes or Rank2Types" - MonoType d -> d - _ -> Outputable.empty -- Polytype is always illegal - -forAllEscapeErr :: TidyEnv -> Type -> Kind -> (TidyEnv, SDoc) -forAllEscapeErr env ty tau_kind - = ( env - , hang (vcat [ text "Quantified type's kind mentions quantified type variable" - , text "(skolem escape)" ]) - 2 (vcat [ text " type:" <+> ppr_tidy env ty - , text "of kind:" <+> ppr_tidy env tau_kind ]) ) - -ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -ubxArgTyErr env ty = (env, sep [text "Illegal unboxed tuple type as function argument:", ppr_tidy env ty]) - -{- -Note [Liberal type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If -XLiberalTypeSynonyms is on, expand closed type synonyms *before* -doing validity checking. This allows us to instantiate a synonym defn -with a for-all type, or with a partially-applied type synonym. - e.g. type T a b = a - type S m = m () - f :: S (T Int) -Here, T is partially applied, so it's illegal in H98. But if you -expand S first, then T we get just - f :: Int -which is fine. - -IMPORTANT: suppose T is a type synonym. Then we must do validity -checking on an appliation (T ty1 ty2) - - *either* before expansion (i.e. check ty1, ty2) - *or* after expansion (i.e. expand T ty1 ty2, and then check) - BUT NOT BOTH - -If we do both, we get exponential behaviour!! - - data TIACons1 i r c = c i ::: r c - type TIACons2 t x = TIACons1 t (TIACons1 t x) - type TIACons3 t x = TIACons2 t (TIACons1 t x) - type TIACons4 t x = TIACons2 t (TIACons2 t x) - type TIACons7 t x = TIACons4 t (TIACons3 t x) - - -************************************************************************ -* * -\subsection{Checking a theta or source type} -* * -************************************************************************ - -Note [Implicit parameters in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Implicit parameters _only_ allowed in type signatures; not in instance -decls, superclasses etc. The reason for not allowing implicit params in -instances is a bit subtle. If we allowed - instance (?x::Int, Eq a) => Foo [a] where ... -then when we saw - (e :: (?x::Int) => t) -it would be unclear how to discharge all the potential uses of the ?x -in e. For example, a constraint Foo [Int] might come out of e, and -applying the instance decl would show up two uses of ?x. Trac #8912. --} - -checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () --- Assumes argument is fully zonked -checkValidTheta ctxt theta - = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) - ; addErrCtxtM (checkThetaCtxt ctxt theta) $ - check_valid_theta env ctxt theta } - -------------------------- -check_valid_theta :: TidyEnv -> UserTypeCtxt -> [PredType] -> TcM () -check_valid_theta _ _ [] - = return () -check_valid_theta env ctxt 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) theta } - where - (_,dups) = removeDups nonDetCmpType theta - -- It's OK to use nonDetCmpType because dups only appears in the - -- warning - -------------------------- -{- Note [Validity checking for constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We look through constraint synonyms so that we can see the underlying -constraint(s). For example - type Foo = ?x::Int - instance Foo => C T -We should reject the instance because it has an implicit parameter in -the context. - -But we record, in 'under_syn', whether we have looked under a synonym -to avoid requiring language extensions at the use site. Main example -(Trac #9838): - - {-# LANGUAGE ConstraintKinds #-} - module A where - type EqShow a = (Eq a, Show a) - - module B where - import A - foo :: EqShow a => a -> String - -We don't want to require ConstraintKinds in module B. --} - -check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM () --- Check the validity of a predicate in a signature --- See Note [Validity checking for constraints] -check_pred_ty env dflags ctxt pred - = do { check_type env SigmaCtxt constraintMonoType pred - ; check_pred_help False env dflags ctxt pred } - -check_pred_help :: Bool -- True <=> under a type synonym - -> TidyEnv - -> DynFlags -> UserTypeCtxt - -> PredType -> TcM () -check_pred_help under_syn env dflags ctxt pred - | Just pred' <- tcView pred -- Switch on under_syn when going under a - -- synonym (Trac #9838, yuk) - = check_pred_help True env dflags ctxt pred' - | otherwise - = case splitTyConApp_maybe pred of - Just (tc, tys) - | isTupleTyCon tc - -> check_tuple_pred under_syn env dflags ctxt pred tys - -- NB: this equality check must come first, because (~) is a class, - -- too. - | tc `hasKey` heqTyConKey || - tc `hasKey` eqTyConKey || - tc `hasKey` eqPrimTyConKey - -> check_eq_pred env dflags pred tc tys - | Just cls <- tyConClass_maybe tc - -> check_class_pred env dflags ctxt pred cls tys -- Includes Coercible - _ -> check_irred_pred under_syn env dflags ctxt pred - -check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TyCon -> [TcType] -> TcM () -check_eq_pred env dflags pred tc tys - = -- Equational constraints are valid in all contexts if type - -- families are permitted - do { checkTc (length tys == tyConArity tc) (tyConArityErr tc tys) - ; checkTcM (xopt LangExt.TypeFamilies dflags - || xopt LangExt.GADTs dflags) - (eqPredTyErr env pred) } - -check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM () -check_tuple_pred under_syn env dflags ctxt pred ts - = do { -- See Note [ConstraintKinds in predicates] - checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags) - (predTupleErr env pred) - ; mapM_ (check_pred_help under_syn env dflags ctxt) ts } - -- This case will not normally be executed because without - -- -XConstraintKinds tuple types are only kind-checked as * - -check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM () -check_irred_pred under_syn env dflags ctxt pred - -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint - -- where X is a type function - = do { -- If it looks like (x t1 t2), require ConstraintKinds - -- see Note [ConstraintKinds in predicates] - -- But (X t1 t2) is always ok because we just require ConstraintKinds - -- at the definition site (Trac #9838) - failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags) - && hasTyVarHead pred) - (predIrredErr env pred) - - -- Make sure it is OK to have an irred pred in this context - -- See Note [Irreducible predicates in superclasses] - ; failIfTcM (is_superclass ctxt - && not (xopt LangExt.UndecidableInstances dflags) - && has_tyfun_head pred) - (predSuperClassErr env pred) } - where - is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False } - has_tyfun_head ty - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isTypeFamilyTyCon tc - Nothing -> False - -{- Note [ConstraintKinds in predicates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't check for -XConstraintKinds under a type synonym, because that -was done at the type synonym definition site; see Trac #9838 -e.g. module A where - type C a = (Eq a, Ix a) -- Needs -XConstraintKinds - module B where - import A - f :: C a => a -> a -- Does *not* need -XConstraintKinds - -Note [Irreducible predicates in superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Allowing type-family calls in class superclasses is somewhat dangerous -because we can write: - - type family Fooish x :: * -> Constraint - type instance Fooish () = Foo - class Fooish () a => Foo a where - -This will cause the constraint simplifier to loop because every time we canonicalise a -(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately -solved to add+canonicalise another (Foo a) constraint. -} - -------------------------- -check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM () -check_class_pred env dflags ctxt pred cls tys - | isIPClass cls - = do { check_arity - ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) } - - | otherwise - = do { check_arity - ; warn_simp <- woptM Opt_WarnSimplifiableClassConstraints - ; when warn_simp check_simplifiable_class_constraint - ; checkTcM arg_tys_ok (predTyVarErr env pred) } - where - check_arity = checkTc (classArity cls == length tys) - (tyConArityErr (classTyCon cls) tys) - - -- Check the arguments of a class constraint - flexible_contexts = xopt LangExt.FlexibleContexts dflags - undecidable_ok = xopt LangExt.UndecidableInstances dflags - arg_tys_ok = case ctxt of - SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine - InstDeclCtxt -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys - -- Further checks on head and theta - -- in checkInstTermination - _ -> checkValidClsArgs flexible_contexts cls tys - - -- See Note [Simplifiable given constraints] - check_simplifiable_class_constraint - | xopt LangExt.MonoLocalBinds dflags - = return () - | DataTyCtxt {} <- ctxt -- Don't do this check for the "stupid theta" - = return () -- of a data type declaration - | otherwise - = do { envs <- tcGetInstEnvs - ; case lookupInstEnv False envs cls tys of - ([m], [], _) -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints) - (simplifiable_constraint_warn m) - _ -> return () } - - simplifiable_constraint_warn :: InstMatch -> SDoc - simplifiable_constraint_warn (match, _) - = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred))) - 2 (text "matches an instance declaration") - , ppr match - , hang (text "This makes type inference for inner bindings fragile;") - 2 (text "either use MonoLocalBinds, or simplify it using the instance") ] - -{- Note [Simplifiable given constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type signature like - f :: Eq [(a,b)] => a -> b -is very fragile, for reasons described at length in TcInteract -Note [Instance and Given overlap]. As that Note discusses, for the -most part the clever stuff in TcInteract means that we don't use a -top-level instance if a local Given might fire, so there is no -fragility. But if we /infer/ the type of a local let-binding, things -can go wrong (Trac #11948 is an example, discussed in the Note). - -So this warning is switched on only if we have NoMonoLocalBinds; in -that case the warning discourages users from writing simplifiable -class constraints. - -The warning only fires if the constraint in the signature -matches the top-level instances in only one way, and with no -unifiers -- that is, under the same circumstances that -TcInteract.matchInstEnv fires an interaction with the top -level instances. For example (Trac #13526), consider - - instance {-# OVERLAPPABLE #-} Eq (T a) where ... - instance Eq (T Char) where .. - f :: Eq (T a) => ... - -We don't want to complain about this, even though the context -(Eq (T a)) matches an instance, because the user may be -deliberately deferring the choice so that the Eq (T Char) -has a chance to fire when 'f' is called. And the fragility -only matters when there's a risk that the instance might -fire instead of the local 'given'; and there is no such -risk in this case. Just use the same rules as for instance -firing! --} - -------------------------- -okIPCtxt :: UserTypeCtxt -> Bool - -- See Note [Implicit parameters in instance decls] -okIPCtxt (FunSigCtxt {}) = True -okIPCtxt (InfSigCtxt {}) = True -okIPCtxt ExprSigCtxt = True -okIPCtxt TypeAppCtxt = True -okIPCtxt PatSigCtxt = True -okIPCtxt ResSigCtxt = True -okIPCtxt GenSigCtxt = True -okIPCtxt (ConArgCtxt {}) = True -okIPCtxt (ForSigCtxt {}) = True -- ?? -okIPCtxt ThBrackCtxt = True -okIPCtxt GhciCtxt = True -okIPCtxt SigmaCtxt = True -okIPCtxt (DataTyCtxt {}) = True -okIPCtxt (PatSynCtxt {}) = True -okIPCtxt (TySynCtxt {}) = True -- e.g. type Blah = ?x::Int - -- Trac #11466 - -okIPCtxt (ClassSCCtxt {}) = False -okIPCtxt (InstDeclCtxt {}) = False -okIPCtxt (SpecInstCtxt {}) = False -okIPCtxt (RuleSigCtxt {}) = False -okIPCtxt DefaultDeclCtxt = False - -{- -Note [Kind polymorphic type classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -MultiParam check: - - class C f where... -- C :: forall k. k -> Constraint - instance C Maybe where... - - The dictionary gets type [C * Maybe] even if it's not a MultiParam - type class. - -Flexibility check: - - class C f where... -- C :: forall k. k -> Constraint - data D a = D a - instance C D where - - The dictionary gets type [C * (D *)]. IA0_TODO it should be - generalized actually. --} - -checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc) -checkThetaCtxt ctxt theta env - = return ( env - , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta) - , text "While checking" <+> pprUserTypeCtxt ctxt ] ) - -eqPredTyErr, predTupleErr, predIrredErr, predSuperClassErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) -eqPredTyErr env pred - = ( env - , text "Illegal equational constraint" <+> ppr_tidy env pred $$ - parens (text "Use GADTs or TypeFamilies to permit this") ) -predTupleErr env pred - = ( env - , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) - 2 (parens constraintKindsMsg) ) -predIrredErr env pred - = ( env - , hang (text "Illegal constraint:" <+> ppr_tidy env pred) - 2 (parens constraintKindsMsg) ) -predSuperClassErr env pred - = ( env - , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred) - <+> text "in a superclass context") - 2 (parens undecidableMsg) ) - -predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) -predTyVarErr env pred - = (env - , vcat [ hang (text "Non type-variable argument") - 2 (text "in the constraint:" <+> ppr_tidy env pred) - , parens (text "Use FlexibleContexts to permit this") ]) - -badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc) -badIPPred env pred - = ( env - , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) - -constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -constraintSynErr env kind - = ( env - , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) - 2 (parens constraintKindsMsg) ) - -dupPredWarn :: TidyEnv -> [[PredType]] -> (TidyEnv, SDoc) -dupPredWarn env dups - = ( env - , text "Duplicate constraint" <> plural primaryDups <> text ":" - <+> pprWithCommas (ppr_tidy env) primaryDups ) - where - primaryDups = map head dups - -tyConArityErr :: TyCon -> [TcType] -> SDoc --- For type-constructor arity errors, be careful to report --- the number of /visible/ arguments required and supplied, --- ignoring the /invisible/ arguments, which the user does not see. --- (e.g. Trac #10516) -tyConArityErr tc tks - = arityErr (tyConFlavour tc) (tyConName tc) - tc_type_arity tc_type_args - where - vis_tks = filterOutInvisibleTypes tc tks - - -- tc_type_arity = number of *type* args expected - -- tc_type_args = number of *type* args encountered - tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) - tc_type_args = length vis_tks - -arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc -arityErr what name n m - = hsep [ text "The" <+> text what, quotes (ppr name), text "should have", - n_arguments <> comma, text "but has been given", - if m==0 then text "none" else int m] - where - n_arguments | n == 0 = text "no arguments" - | n == 1 = text "1 argument" - | True = hsep [int n, text "arguments"] - -{- -************************************************************************ -* * -\subsection{Checking for a decent instance head type} -* * -************************************************************************ - -@checkValidInstHead@ checks the type {\em and} its syntactic constraints: -it must normally look like: @instance Foo (Tycon a b c ...) ...@ - -The exceptions to this syntactic checking: (1)~if the @GlasgowExts@ -flag is on, or (2)~the instance is imported (they must have been -compiled elsewhere). In these cases, we let them go through anyway. - -We can also have instances for functions: @instance Foo (a -> b) ...@. --} - -checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () -checkValidInstHead ctxt clas cls_args - = do { dflags <- getDynFlags - - ; mod <- getModule - ; checkTc (getUnique clas `notElem` abstractClassKeys || - nameModule (getName clas) == mod) - (instTypeErr clas cls_args abstract_class_msg) - - ; when (clas `hasKey` hasFieldClassNameKey) $ - checkHasFieldInst clas cls_args - - -- Check language restrictions; - -- but not for SPECIALISE instance pragmas - ; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args - ; unless spec_inst_prag $ - do { checkTc (xopt LangExt.TypeSynonymInstances dflags || - all tcInstHeadTyNotSynonym ty_args) - (instTypeErr clas cls_args head_type_synonym_msg) - ; checkTc (xopt LangExt.FlexibleInstances dflags || - all tcInstHeadTyAppAllTyVars ty_args) - (instTypeErr clas cls_args head_type_args_tyvars_msg) - ; checkTc (xopt LangExt.MultiParamTypeClasses dflags || - length ty_args == 1 || -- Only count type arguments - (xopt LangExt.NullaryTypeClasses dflags && - null ty_args)) - (instTypeErr clas cls_args head_one_type_msg) } - - ; mapM_ checkValidTypePat ty_args } - where - spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False } - - head_type_synonym_msg = parens ( - text "All instance types must be of the form (T t1 ... tn)" $$ - text "where T is not a synonym." $$ - text "Use TypeSynonymInstances if you want to disable this.") - - head_type_args_tyvars_msg = parens (vcat [ - text "All instance types must be of the form (T a1 ... an)", - text "where a1 ... an are *distinct type variables*,", - text "and each type variable appears at most once in the instance head.", - text "Use FlexibleInstances if you want to disable this."]) - - head_one_type_msg = parens ( - text "Only one type can be given in an instance head." $$ - text "Use MultiParamTypeClasses if you want to allow more, or zero.") - - abstract_class_msg = - text "Manual instances of this class are not permitted." - -tcInstHeadTyNotSynonym :: Type -> Bool --- Used in Haskell-98 mode, for the argument types of an instance head --- These must not be type synonyms, but everywhere else type synonyms --- are transparent, so we need a special function here -tcInstHeadTyNotSynonym ty - = case ty of -- Do not use splitTyConApp, - -- because that expands synonyms! - TyConApp tc _ -> not (isTypeSynonymTyCon tc) - _ -> True - -tcInstHeadTyAppAllTyVars :: Type -> Bool --- Used in Haskell-98 mode, for the argument types of an instance head --- These must be a constructor applied to type variable arguments. --- But we allow kind instantiations. -tcInstHeadTyAppAllTyVars ty - | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty) - = ok (filterOutInvisibleTypes tc tys) -- avoid kinds - - | otherwise - = False - where - -- Check that all the types are type variables, - -- and that each is distinct - ok tys = equalLength tvs tys && hasNoDups tvs - where - tvs = mapMaybe tcGetTyVar_maybe tys - -dropCasts :: Type -> Type --- See Note [Casts during validity checking] --- This function can turn a well-kinded type into an ill-kinded --- one, so I've kept it local to this module --- To consider: drop only UnivCo(HoleProv) casts -dropCasts (CastTy ty _) = dropCasts ty -dropCasts (AppTy t1 t2) = mkAppTy (dropCasts t1) (dropCasts t2) -dropCasts (FunTy t1 t2) = mkFunTy (dropCasts t1) (dropCasts t2) -dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys) -dropCasts (ForAllTy b ty) = ForAllTy (dropCastsB b) (dropCasts ty) -dropCasts ty = ty -- LitTy, TyVarTy, CoercionTy - -dropCastsB :: TyVarBinder -> TyVarBinder -dropCastsB b = b -- Don't bother in the kind of a forall - -abstractClassKeys :: [Unique] -abstractClassKeys = [ heqTyConKey - , eqTyConKey - , coercibleTyConKey - ] -- See Note [Equality class instances] - -instTypeErr :: Class -> [Type] -> SDoc -> SDoc -instTypeErr cls tys msg - = hang (hang (text "Illegal instance declaration for") - 2 (quotes (pprClassPred cls tys))) - 2 msg - --- | See Note [Validity checking of HasField instances] -checkHasFieldInst :: Class -> [Type] -> TcM () -checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] = - case splitTyConApp_maybe r_ty of - Nothing -> whoops (text "Record data type must be specified") - Just (tc, _) - | isFamilyTyCon tc - -> whoops (text "Record data type may not be a data family") - | otherwise -> case isStrLitTy x_ty of - Just lbl - | isJust (lookupTyConFieldLabel lbl tc) - -> whoops (ppr tc <+> text "already has a field" - <+> quotes (ppr lbl)) - | otherwise -> return () - Nothing - | null (tyConFieldLabels tc) -> return () - | otherwise -> whoops (ppr tc <+> text "has fields") - where - whoops = addErrTc . instTypeErr cls tys -checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys) - -{- Note [Casts during validity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the (bogus) - instance Eq Char# -We elaborate to 'Eq (Char# |> UnivCo(hole))' where the hole is an -insoluble equality constraint for * ~ #. We'll report the insoluble -constraint separately, but we don't want to *also* complain that Eq is -not applied to a type constructor. So we look gaily look through -CastTys here. - -Another example: Eq (Either a). Then we actually get a cast in -the middle: - Eq ((Either |> g) a) - - -Note [Validity checking of HasField instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The HasField class has magic constraint solving behaviour (see Note -[HasField instances] in TcInteract). However, we permit users to -declare their own instances, provided they do not clash with the -built-in behaviour. In particular, we forbid: - - 1. `HasField _ r _` where r is a variable - - 2. `HasField _ (T ...) _` if T is a data family - (because it might have fields introduced later) - - 3. `HasField x (T ...) _` where x is a variable, - if T has any fields at all - - 4. `HasField "foo" (T ...) _` if T has a "foo" field - -The usual functional dependency checks also apply. - - -Note [Valid 'deriving' predicate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -validDerivPred checks for OK 'deriving' context. See Note [Exotic -derived instance contexts] in TcDeriv. However the predicate is -here because it uses sizeTypes, fvTypes. - -It checks for three things - - * No repeated variables (hasNoDups fvs) - - * No type constructors. This is done by comparing - sizeTypes tys == length (fvTypes tys) - sizeTypes counts variables and constructors; fvTypes returns variables. - So if they are the same, there must be no constructors. But there - might be applications thus (f (g x)). - - Note that tys only includes the visible arguments of the class type - constructor. Including the non-vivisble arguments can cause the following, - perfectly valid instance to be rejected: - class Category (cat :: k -> k -> *) where ... - newtype T (c :: * -> * -> *) a b = MkT (c a b) - instance Category c => Category (T c) where ... - since the first argument to Category is a non-visible *, which sizeTypes - would count as a constructor! See Trac #11833. - - * Also check for a bizarre corner case, when the derived instance decl - would look like - instance C a b => D (T a) where ... - Note that 'b' isn't a parameter of T. This gives rise to all sorts of - problems; in particular, it's hard to compare solutions for equality - when finding the fixpoint, and that means the inferContext loop does - not converge. See Trac #5287. - -Note [Equality class instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can't have users writing instances for the equality classes. But we -still need to be able to write instances for them ourselves. So we allow -instances only in the defining module. - --} - -validDerivPred :: TyVarSet -> PredType -> Bool --- See Note [Valid 'deriving' predicate] -validDerivPred tv_set pred - = case classifyPredType pred of - ClassPred cls tys -> cls `hasKey` typeableClassKey - -- Typeable constraints are bigger than they appear due - -- to kind polymorphism, but that's OK - || check_tys cls tys - EqPred {} -> False -- reject equality constraints - _ -> True -- Non-class predicates are ok - where - check_tys cls tys - = hasNoDups fvs - -- use sizePred to ignore implicit args - && sizePred pred == fromIntegral (length fvs) - && all (`elemVarSet` tv_set) fvs - where tys' = filterOutInvisibleTypes (classTyCon cls) tys - fvs = fvTypes tys' - -{- -************************************************************************ -* * -\subsection{Checking instance for termination} -* * -************************************************************************ --} - -{- Note [Instances and constraint synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, we don't allow instances for constraint synonyms at all. -Consider these (Trac #13267): - type C1 a = Show (a -> Bool) - instance C1 Int where -- I1 - show _ = "ur" - -This elicits "show is not a (visible) method of class C1", which isn't -a great message. But it comes from the renamer, so it's hard to improve. - -This needs a bit more care: - type C2 a = (Show a, Show Int) - instance C2 Int -- I2 - -If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose -the instance head, we'll expand the synonym on fly, and it'll look like - instance (%,%) (Show Int, Show Int) -and we /really/ don't want that. So we carefully do /not/ expand -synonyms, by matching on TyConApp directly. --} - -checkValidInstance :: UserTypeCtxt -> LHsSigType Name -> Type - -> TcM ([TyVar], ThetaType, Class, [Type]) -checkValidInstance ctxt hs_type ty - | not is_tc_app - = failWithTc (text "Instance head is not headed by a class") - - | isNothing mb_cls - = failWithTc (vcat [ text "Illegal instance for a" <+> text (tyConFlavour tc) - , text "A class instance must be for a class" ]) - - | not arity_ok - = failWithTc (text "Arity mis-match in instance head") - - | otherwise - = do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys) - ; traceTc "checkValidInstance {" (ppr ty) - ; checkValidTheta ctxt theta - - -- The Termination and Coverate Conditions - -- Check that instance inference will terminate (if we care) - -- For Haskell 98 this will already have been done by checkValidTheta, - -- but as we may be using other extensions we need to check. - -- - -- Note that the Termination Condition is *more conservative* than - -- the checkAmbiguity test we do on other type signatures - -- e.g. Bar a => Bar Int is ambiguous, but it also fails - -- the termination condition, because 'a' appears more often - -- in the constraint than in the head - ; undecidable_ok <- xoptM LangExt.UndecidableInstances - ; if undecidable_ok - then checkAmbiguity ctxt ty - else checkInstTermination inst_tys theta - - ; traceTc "cvi 2" (ppr ty) - - ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of - IsValid -> return () -- Check succeeded - NotValid msg -> addErrTc (instTypeErr clas inst_tys msg) - - ; traceTc "End checkValidInstance }" empty - - ; return (tvs, theta, clas, inst_tys) } - where - (tvs, theta, tau) = tcSplitSigmaTy ty - is_tc_app = case tau of { TyConApp {} -> True; _ -> False } - TyConApp tc inst_tys = tau -- See Note [Instances and constraint synonyms] - mb_cls = tyConClass_maybe tc - Just clas = mb_cls - arity_ok = inst_tys `lengthIs` classArity clas - - -- The location of the "head" of the instance - head_loc = getLoc (getLHsInstDeclHead hs_type) - -{- -Note [Paterson conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Termination test: the so-called "Paterson conditions" (see Section 5 of -"Understanding functional dependencies via Constraint Handling Rules, -JFP Jan 2007). - -We check that each assertion in the context satisfies: - (1) no variable has more occurrences in the assertion than in the head, and - (2) the assertion has fewer constructors and variables (taken together - and counting repetitions) than the head. -This is only needed with -fglasgow-exts, as Haskell 98 restrictions -(which have already been checked) guarantee termination. - -The underlying idea is that - - for any ground substitution, each assertion in the - context has fewer type constructors than the head. --} - -checkInstTermination :: [TcType] -> ThetaType -> TcM () --- See Note [Paterson conditions] -checkInstTermination tys theta - = check_preds theta - where - head_fvs = fvTypes tys - head_size = sizeTypes tys - - check_preds :: [PredType] -> TcM () - check_preds preds = mapM_ check preds - - check :: PredType -> TcM () - check pred - = case classifyPredType pred of - EqPred {} -> return () -- See Trac #4200. - IrredPred {} -> check2 pred (sizeType pred) - ClassPred cls tys - | isTerminatingClass cls - -> return () - - | isCTupleClass cls -- Look inside tuple predicates; Trac #8359 - -> check_preds tys - - | otherwise - -> check2 pred (sizeTypes $ filterOutInvisibleTypes (classTyCon cls) tys) - -- Other ClassPreds - - check2 pred pred_size - | not (null bad_tvs) = addErrTc (noMoreMsg bad_tvs what) - | pred_size >= head_size = addErrTc (smallerMsg what) - | otherwise = return () - where - what = text "constraint" <+> quotes (ppr pred) - bad_tvs = fvType pred \\ head_fvs - -smallerMsg :: SDoc -> SDoc -smallerMsg what - = vcat [ hang (text "The" <+> what) - 2 (text "is no smaller than the instance head") - , parens undecidableMsg ] - -noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -noMoreMsg tvs what - = vcat [ hang (text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs) - <+> occurs <+> text "more often") - 2 (sep [ text "in the" <+> what - , text "than in the instance head" ]) - , parens undecidableMsg ] - where - occurs = if isSingleton tvs then text "occurs" - else text "occur" - -undecidableMsg, constraintKindsMsg :: SDoc -undecidableMsg = text "Use UndecidableInstances to permit this" -constraintKindsMsg = text "Use ConstraintKinds to permit this" - -{- -Note [Associated type instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow this: - class C a where - type T x a - instance C Int where - type T (S y) Int = y - type T Z Int = Char - -Note that - a) The variable 'x' is not bound by the class decl - b) 'x' is instantiated to a non-type-variable in the instance - c) There are several type instance decls for T in the instance - -All this is fine. Of course, you can't give any *more* instances -for (T ty Int) elsewhere, because it's an *associated* type. - -Note [Checking consistent instantiation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Trac #11450 for background discussion on this check. - - class C a b where - type T a x b - -With this class decl, if we have an instance decl - instance C ty1 ty2 where ... -then the type instance must look like - type T ty1 v ty2 = ... -with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'. -For example: - - instance C [p] Int - type T [p] y Int = (p,y,y) - -Note that - -* We used to allow completely different bound variables in the - associated type instance; e.g. - instance C [p] Int - type T [q] y Int = ... - But from GHC 8.2 onwards, we don't. It's much simpler this way. - See Trac #11450. - -* When the class variable isn't used on the RHS of the type instance, - it's tempting to allow wildcards, thus - instance C [p] Int - type T [_] y Int = (y,y) - But it's awkward to do the test, and it doesn't work if the - variable is repeated: - instance C (p,p) Int - type T (_,_) y Int = (y,y) - Even though 'p' is not used on the RHS, we still need to use 'p' - on the LHS to establish the repeated pattern. So to keep it simple - we just require equality. - -* For variables in associated type families that are not bound by the class - itself, we do _not_ check if they are over-specific. In other words, - it's perfectly acceptable to have an instance like this: - - instance C [p] Int where - type T [p] (Maybe x) Int = x - - While the first and third arguments to T are required to be exactly [p] and - Int, respectively, since they are bound by C, the second argument is allowed - to be more specific than just a type variable. Furthermore, it is permissible - to define multiple equations for T that differ only in the non-class-bound - argument: - - instance C [p] Int where - type T [p] (Maybe x) Int = x - type T [p] (Either x y) Int = x -> y - - We once considered requiring that non-class-bound variables in associated - type family instances be instantiated with distinct type variables. However, - that requirement proved too restrictive in practice, as there were examples - of extremely simple associated type family instances that this check would - reject, and fixing them required tiresome boilerplate in the form of - auxiliary type families. For instance, you would have to define the above - example as: - - instance C [p] Int where - type T [p] x Int = CAux x - - type family CAux x where - CAux (Maybe x) = x - CAux (Either x y) = x -> y - - We decided that this restriction wasn't buying us much, so we opted not - to pursue that design (see also GHC Trac #13398). - -Implementation - * Form the mini-envt from the class type variables a,b - to the instance decl types [p],Int: [a->[p], b->Int] - - * Look at the tyvars a,x,b of the type family constructor T - (it shares tyvars with the class C) - - * Apply the mini-evnt to them, and check that the result is - consistent with the instance types [p] y Int. (where y can be any type, as - it is not scoped over the class type variables. - -We make all the instance type variables scope over the -type instances, of course, which picks up non-obvious kinds. Eg - class Foo (a :: k) where - type F a - instance Foo (b :: k -> k) where - type F b = Int -Here the instance is kind-indexed and really looks like - type F (k->k) (b::k->k) = Int -But if the 'b' didn't scope, we would make F's instance too -poly-kinded. --} - --- | Extra information about the parent instance declaration, needed --- when type-checking associated types. The 'Class' is the enclosing --- class, the [TyVar] are the type variable of the instance decl, --- and and the @VarEnv Type@ maps class variables to their instance --- types. -type ClsInstInfo = (Class, [TyVar], VarEnv Type) - -type AssocInstArgShape = (Maybe Type, Type) - -- AssocInstArgShape is used only for associated family instances - -- (mb_exp, actual) - -- mb_exp = Just ty => this arg corresponds to a class variable - -- = Nothing => it doesn't correspond to a class variable - -- e.g. class C b where - -- type F a b c - -- instance C [x] where - -- type F p [x] q - -- We get [AssocInstArgShape] = [ (Nothing, p) - -- , (Just [x], [x]) - -- , (Nothing, q)] - -checkConsistentFamInst - :: Maybe ClsInstInfo - -> TyCon -- ^ Family tycon - -> [TyVar] -- ^ Type variables of the family instance - -> [Type] -- ^ Type patterns from instance - -> TcM () --- See Note [Checking consistent instantiation] - -checkConsistentFamInst Nothing _ _ _ = return () -checkConsistentFamInst (Just (clas, inst_tvs, mini_env)) fam_tc _at_tvs at_tys - = do { -- Check that the associated type indeed comes from this class - checkTc (Just clas == tyConAssoc_maybe fam_tc) - (badATErr (className clas) (tyConName fam_tc)) - - -- Check type args first (more comprehensible) - ; checkTc (all check_arg type_shapes) pp_wrong_at_arg - - -- And now kind args - ; checkTc (all check_arg kind_shapes) - (pp_wrong_at_arg $$ ppSuggestExplicitKinds) - - ; traceTc "cfi" (vcat [ ppr inst_tvs - , ppr arg_shapes - , ppr mini_env ]) } - where - arg_shapes :: [AssocInstArgShape] - arg_shapes = [ (lookupVarEnv mini_env fam_tc_tv, at_ty) - | (fam_tc_tv, at_ty) <- tyConTyVars fam_tc `zip` at_tys ] - - (kind_shapes, type_shapes) = partitionInvisibles fam_tc snd arg_shapes - - check_arg :: AssocInstArgShape -> Bool - check_arg (Just exp_ty, at_ty) = exp_ty `tcEqType` at_ty - check_arg (Nothing, _ ) = True -- Arg position does not correspond - -- to a class variable - - pp_wrong_at_arg - = vcat [ text "Type indexes must match class instance head" - , pp_exp_act ] - - pp_exp_act - = vcat [ text "Expected:" <+> ppr (mkTyConApp fam_tc expected_args) - , text " Actual:" <+> ppr (mkTyConApp fam_tc at_tys) - , sdocWithDynFlags $ \dflags -> - ppWhen (has_poly_args dflags) $ - vcat [ text "where the `' arguments are type variables," - , text "distinct from each other and from the instance variables" ] ] - - expected_args = [ exp_ty `orElse` mk_tv at_ty | (exp_ty, at_ty) <- arg_shapes ] - mk_tv at_ty = mkTyVarTy (mkTyVar tv_name (typeKind at_ty)) - tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "") noSrcSpan - - has_poly_args dflags = any (isNothing . fst) shapes - where - shapes | gopt Opt_PrintExplicitKinds dflags = arg_shapes - | otherwise = type_shapes - -badATErr :: Name -> Name -> SDoc -badATErr clas op - = hsep [text "Class", quotes (ppr clas), - text "does not have an associated type", quotes (ppr op)] - - -{- -************************************************************************ -* * - Checking type instance well-formedness and termination -* * -************************************************************************ --} - -checkValidCoAxiom :: CoAxiom Branched -> TcM () -checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) - = do { mapM_ (checkValidCoAxBranch Nothing fam_tc) branch_list - ; foldlM_ check_branch_compat [] branch_list } - where - branch_list = fromBranches branches - injectivity = familyTyConInjectivityInfo fam_tc - - check_branch_compat :: [CoAxBranch] -- previous branches in reverse order - -> CoAxBranch -- current branch - -> TcM [CoAxBranch]-- current branch : previous branches - -- Check for - -- (a) this branch is dominated by previous ones - -- (b) failure of injectivity - check_branch_compat prev_branches cur_branch - | cur_branch `isDominatedBy` prev_branches - = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $ - inaccessibleCoAxBranch ax cur_branch - ; return prev_branches } - | otherwise - = do { check_injectivity prev_branches cur_branch - ; return (cur_branch : prev_branches) } - - -- Injectivity check: check whether a new (CoAxBranch) can extend - -- already checked equations without violating injectivity - -- annotation supplied by the user. - -- See Note [Verifying injectivity annotation] in FamInstEnv - check_injectivity prev_branches cur_branch - | Injective inj <- injectivity - = do { let conflicts = - fst $ foldl (gather_conflicts inj prev_branches cur_branch) - ([], 0) prev_branches - ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) - (makeInjectivityErrors ax cur_branch inj conflicts) } - | otherwise - = return () - - gather_conflicts inj prev_branches cur_branch (acc, n) branch - -- n is 0-based index of branch in prev_branches - = case injectiveBranches inj cur_branch branch of - InjectivityUnified ax1 ax2 - | ax1 `isDominatedBy` (replace_br prev_branches n ax2) - -> (acc, n + 1) - | otherwise - -> (branch : acc, n + 1) - InjectivityAccepted -> (acc, n + 1) - - -- Replace n-th element in the list. Assumes 0-based indexing. - replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch] - replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs - - --- Check that a "type instance" is well-formed (which includes decidability --- unless -XUndecidableInstances is given). --- -checkValidCoAxBranch :: Maybe ClsInstInfo - -> TyCon -> CoAxBranch -> TcM () -checkValidCoAxBranch mb_clsinfo fam_tc - (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = typats - , cab_rhs = rhs, cab_loc = loc }) - = checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc - --- | Do validity checks on a type family equation, including consistency --- with any enclosing class instance head, termination, and lack of --- polytypes. -checkValidTyFamEqn :: Maybe ClsInstInfo - -> TyCon -- ^ of the type family - -> [TyVar] -- ^ bound tyvars in the equation - -> [CoVar] -- ^ bound covars in the equation - -> [Type] -- ^ type patterns - -> Type -- ^ rhs - -> SrcSpan - -> TcM () -checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc - = setSrcSpan loc $ - do { checkValidFamPats mb_clsinfo fam_tc tvs cvs typats - - -- The argument patterns, and RHS, are all boxed tau types - -- E.g Reject type family F (a :: k1) :: k2 - -- type instance F (forall a. a->a) = ... - -- type instance F Int# = ... - -- type instance F Int = forall a. a->a - -- type instance F Int = Int# - -- See Trac #9357 - ; checkValidMonoType rhs - - -- We have a decidable instance unless otherwise permitted - ; undecidable_ok <- xoptM LangExt.UndecidableInstances - ; unless undecidable_ok $ - mapM_ addErrTc (checkFamInstRhs typats (tcTyFamInsts rhs)) } - --- Make sure that each type family application is --- (1) strictly smaller than the lhs, --- (2) mentions no type variable more often than the lhs, and --- (3) does not contain any further type family instances. --- -checkFamInstRhs :: [Type] -- lhs - -> [(TyCon, [Type])] -- type family instances - -> [MsgDoc] -checkFamInstRhs lhsTys famInsts - = mapMaybe check famInsts - where - size = sizeTypes lhsTys - fvs = fvTypes lhsTys - check (tc, tys) - | not (all isTyFamFree tys) = Just (nestedMsg what) - | not (null bad_tvs) = Just (noMoreMsg bad_tvs what) - | size <= sizeTypes tys = Just (smallerMsg what) - | otherwise = Nothing - where - what = text "type family application" <+> quotes (pprType (TyConApp tc tys)) - bad_tvs = fvTypes tys \\ fvs - -checkValidFamPats :: Maybe ClsInstInfo -> TyCon -> [TyVar] -> [CoVar] -> [Type] -> TcM () --- Patterns in a 'type instance' or 'data instance' decl should --- a) contain no type family applications --- (vanilla synonyms are fine, though) --- b) properly bind all their free type variables --- e.g. we disallow (Trac #7536) --- type T a = Int --- type instance F (T a) = a --- c) Have the right number of patterns --- d) For associated types, are consistently instantiated -checkValidFamPats mb_clsinfo fam_tc tvs cvs ty_pats - = do { -- A family instance must have exactly the same number of type - -- parameters as the family declaration. You can't write - -- type family F a :: * -> * - -- type instance F Int y = y - -- because then the type (F Int) would be like (\y.y) - checkTc (length ty_pats == fam_arity) $ - wrongNumberOfParmsErr (fam_arity - count isInvisibleTyConBinder fam_bndrs) - -- report only explicit arguments - - ; mapM_ checkValidTypePat ty_pats - - ; let unbound_tcvs = filterOut (`elemVarSet` exactTyCoVarsOfTypes ty_pats) (tvs ++ cvs) - ; checkTc (null unbound_tcvs) (famPatErr fam_tc unbound_tcvs ty_pats) - - -- Check that type patterns match the class instance head - ; checkConsistentFamInst mb_clsinfo fam_tc tvs ty_pats } - where - fam_arity = tyConArity fam_tc - fam_bndrs = tyConBinders fam_tc - - -checkValidTypePat :: Type -> TcM () --- Used for type patterns in class instances, --- and in type/data family instances -checkValidTypePat pat_ty - = do { -- Check that pat_ty is a monotype - checkValidMonoType pat_ty - -- One could imagine generalising to allow - -- instance C (forall a. a->a) - -- but we don't know what all the consequences might be - - -- Ensure that no type family instances occur a type pattern - ; checkTc (isTyFamFree pat_ty) $ - tyFamInstIllegalErr pat_ty } - --- Error messages - -wrongNumberOfParmsErr :: Arity -> SDoc -wrongNumberOfParmsErr exp_arity - = text "Number of parameters must match family declaration; expected" - <+> ppr exp_arity - -inaccessibleCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc -inaccessibleCoAxBranch fi_ax cur_branch - = text "Type family instance equation is overlapped:" $$ - nest 2 (pprCoAxBranch fi_ax cur_branch) - -tyFamInstIllegalErr :: Type -> SDoc -tyFamInstIllegalErr ty - = hang (text "Illegal type synonym family application in instance" <> - colon) 2 $ - ppr ty - -nestedMsg :: SDoc -> SDoc -nestedMsg what - = sep [ text "Illegal nested" <+> what - , parens undecidableMsg ] - -famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc -famPatErr fam_tc tvs pats - = hang (text "Family instance purports to bind type variable" <> plural tvs - <+> pprQuotedList tvs) - 2 (hang (text "but the real LHS (expanding synonyms) is:") - 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+> - text "= ...")) - -{- -************************************************************************ -* * - Telescope checking -* * -************************************************************************ - -Note [Bad telescopes] -~~~~~~~~~~~~~~~~~~~~~ -Now that we can mix type and kind variables, there are an awful lot of -ways to shoot yourself in the foot. Here are some. - - data SameKind :: k -> k -> * -- just to force unification - -1. data T1 a k (b :: k) (x :: SameKind a b) - -The problem here is that we discover that a and b should have the same -kind. But this kind mentions k, which is bound *after* a. -(Testcase: dependent/should_fail/BadTelescope) - -2. data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - -Note that b is not bound. Yet its kind mentions a. Because we have -a nice rule that all implicitly bound variables come before others, -this is bogus. (We could probably figure out to put b between a and c. -But I think this is doing users a disservice, in the long run.) -(Testcase: dependent/should_fail/BadTelescope4) - -3. t3 :: forall a. (forall k (b :: k). SameKind a b) -> () - -This is a straightforward skolem escape. Note that a and b need to have -the same kind. -(Testcase: polykinds/T11142) - -How do we deal with all of this? For TyCons, we have checkValidTyConTyVars. -That function looks to see if any of the tyConTyVars are repeated, but -it's really a telescope check. It works because all tycons are kind-generalized. -If there is a bad telescope, the kind-generalization will end up generalizing -over a variable bound later in the telescope. - -For non-tycons, we do scope checking when we bring tyvars into scope, -in tcImplicitTKBndrs and tcExplicitTKBndrs. Note that we also have to -sort implicit binders into a well-scoped order whenever we have implicit -binders to worry about. This is done in quantifyTyVars and in -tcImplicitTKBndrs. --} - --- | Check a list of binders to see if they make a valid telescope. --- The key property we're checking for is scoping. For example: --- > data SameKind :: k -> k -> * --- > data X a k (b :: k) (c :: SameKind a b) --- Kind inference says that a's kind should be k. But that's impossible, --- because k isn't in scope when a is bound. This check has to come before --- general validity checking, because once we kind-generalise, this sort --- of problem is harder to spot (as we'll generalise over the unbound --- k in a's type.) See also Note [Bad telescopes]. -checkValidTelescope :: SDoc -- the original user-written telescope - -> [TyVar] -- explicit vars (not necessarily zonked) - -> SDoc -- note to put at bottom of message - -> TcM () -checkValidTelescope hs_tvs orig_tvs extra - = discardResult $ checkZonkValidTelescope hs_tvs orig_tvs extra - --- | Like 'checkZonkValidTelescope', but returns the zonked tyvars -checkZonkValidTelescope :: SDoc - -> [TyVar] - -> SDoc - -> TcM [TyVar] -checkZonkValidTelescope hs_tvs orig_tvs extra - = do { orig_tvs <- mapM zonkTyCoVarKind orig_tvs - ; let (_, sorted_tidied_tvs) = tidyTyCoVarBndrs emptyTidyEnv $ - toposortTyVars orig_tvs - ; unless (go [] emptyVarSet orig_tvs) $ - addErr $ - vcat [ hang (text "These kind and type variables:" <+> hs_tvs $$ - text "are out of dependency order. Perhaps try this ordering:") - 2 (sep (map pprTyVar sorted_tidied_tvs)) - , extra ] - ; return orig_tvs } - - where - go :: [TyVar] -- misplaced variables - -> TyVarSet -> [TyVar] -> Bool - go errs in_scope [] = null (filter (`elemVarSet` in_scope) errs) - -- report an error only when the variable in the kind is brought - -- into scope later in the telescope. Otherwise, we'll just quantify - -- over it in kindGeneralize, as we should. - - go errs in_scope (tv:tvs) - = let bad_tvs = filterOut (`elemVarSet` in_scope) $ - tyCoVarsOfTypeList (tyVarKind tv) - in go (bad_tvs ++ errs) (in_scope `extendVarSet` tv) tvs - --- | After inferring kinds of type variables, check to make sure that the --- inferred kinds any of the type variables bound in a smaller scope. --- This is a skolem escape check. See also Note [Bad telescopes]. -checkValidInferredKinds :: [TyVar] -- ^ vars to check (zonked) - -> TyVarSet -- ^ vars out of scope - -> SDoc -- ^ suffix to error message - -> TcM () -checkValidInferredKinds orig_kvs out_of_scope extra - = do { let bad_pairs = [ (tv, kv) - | kv <- orig_kvs - , Just tv <- map (lookupVarSet out_of_scope) - (tyCoVarsOfTypeList (tyVarKind kv)) ] - report (tidyTyVarOcc env -> tv, tidyTyVarOcc env -> kv) - = addErr $ - text "The kind of variable" <+> - quotes (ppr kv) <> text ", namely" <+> - quotes (ppr (tyVarKind kv)) <> comma $$ - text "depends on variable" <+> - quotes (ppr tv) <+> text "from an inner scope" $$ - text "Perhaps bind" <+> quotes (ppr kv) <+> - text "sometime after binding" <+> - quotes (ppr tv) $$ - extra - ; mapM_ report bad_pairs } - - where - (env1, _) = tidyTyCoVarBndrs emptyTidyEnv orig_kvs - (env, _) = tidyTyCoVarBndrs env1 (nonDetEltsUniqSet out_of_scope) - -- It's OK to use nonDetEltsUniqSet here because it's only used for - -- generating the error message - -{- -************************************************************************ -* * -\subsection{Auxiliary functions} -* * -************************************************************************ --} - --- Free variables of a type, retaining repetitions, and expanding synonyms -fvType :: Type -> [TyCoVar] -fvType ty | Just exp_ty <- tcView ty = fvType exp_ty -fvType (TyVarTy tv) = [tv] -fvType (TyConApp _ tys) = fvTypes tys -fvType (LitTy {}) = [] -fvType (AppTy fun arg) = fvType fun ++ fvType arg -fvType (FunTy arg res) = fvType arg ++ fvType res -fvType (ForAllTy (TvBndr tv _) ty) - = fvType (tyVarKind tv) ++ - filter (/= tv) (fvType ty) -fvType (CastTy ty co) = fvType ty ++ fvCo co -fvType (CoercionTy co) = fvCo co - -fvTypes :: [Type] -> [TyVar] -fvTypes tys = concat (map fvType tys) - -fvCo :: Coercion -> [TyCoVar] -fvCo (Refl _ ty) = fvType ty -fvCo (TyConAppCo _ _ args) = concatMap fvCo args -fvCo (AppCo co arg) = fvCo co ++ fvCo arg -fvCo (ForAllCo tv h co) = filter (/= tv) (fvCo co) ++ fvCo h -fvCo (FunCo _ co1 co2) = fvCo co1 ++ fvCo co2 -fvCo (CoVarCo v) = [v] -fvCo (AxiomInstCo _ _ args) = concatMap fvCo args -fvCo (UnivCo p _ t1 t2) = fvProv p ++ fvType t1 ++ fvType t2 -fvCo (SymCo co) = fvCo co -fvCo (TransCo co1 co2) = fvCo co1 ++ fvCo co2 -fvCo (NthCo _ co) = fvCo co -fvCo (LRCo _ co) = fvCo co -fvCo (InstCo co arg) = fvCo co ++ fvCo arg -fvCo (CoherenceCo co1 co2) = fvCo co1 ++ fvCo co2 -fvCo (KindCo co) = fvCo co -fvCo (SubCo co) = fvCo co -fvCo (AxiomRuleCo _ cs) = concatMap fvCo cs - -fvProv :: UnivCoProvenance -> [TyCoVar] -fvProv UnsafeCoerceProv = [] -fvProv (PhantomProv co) = fvCo co -fvProv (ProofIrrelProv co) = fvCo co -fvProv (PluginProv _) = [] -fvProv (HoleProv h) = pprPanic "fvProv falls into a hole" (ppr h) - -sizeType :: Type -> Int --- Size of a type: the number of variables and constructors -sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty -sizeType (TyVarTy {}) = 1 -sizeType (TyConApp _ tys) = sizeTypes tys + 1 -sizeType (LitTy {}) = 1 -sizeType (AppTy fun arg) = sizeType fun + sizeType arg -sizeType (FunTy arg res) = sizeType arg + sizeType res + 1 -sizeType (ForAllTy _ ty) = sizeType ty -sizeType (CastTy ty _) = sizeType ty -sizeType (CoercionTy _) = 1 - -sizeTypes :: [Type] -> Int -sizeTypes = sum . map sizeType - --- Size of a predicate --- --- We are considering whether class constraints terminate. --- Equality constraints and constraints for the implicit --- parameter class always termiante so it is safe to say "size 0". --- (Implicit parameter constraints always terminate because --- there are no instances for them---they are only solved by --- "local instances" in expressions). --- See Trac #4200. -sizePred :: PredType -> Int -sizePred ty = goClass ty - where - goClass p = go (classifyPredType p) - - go (ClassPred cls tys') - | isTerminatingClass cls = 0 - | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys') - go (EqPred {}) = 0 - go (IrredPred ty) = sizeType ty - --- | When this says "True", ignore this class constraint during --- a termination check -isTerminatingClass :: Class -> Bool -isTerminatingClass cls - = isIPClass cls - || cls `hasKey` typeableClassKey - || cls `hasKey` coercibleTyConKey - || cls `hasKey` eqTyConKey - || cls `hasKey` heqTyConKey - --- | Tidy before printing a type -ppr_tidy :: TidyEnv -> Type -> SDoc -ppr_tidy env ty = pprType (tidyType env ty) - -allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool --- (allDistinctTyVars tvs tys) returns True if tys are --- a) all tyvars --- b) all distinct --- c) disjoint from tvs -allDistinctTyVars _ [] = True -allDistinctTyVars tkvs (ty : tys) - = case getTyVar_maybe ty of - Nothing -> False - Just tv | tv `elemVarSet` tkvs -> False - | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys diff --git a/types/Class.hs b/types/Class.hs deleted file mode 100644 --- a/types/Class.hs +++ /dev/null @@ -1,360 +0,0 @@ --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --- --- The @Class@ datatype - -{-# LANGUAGE CPP #-} - -module Class ( - Class, - ClassOpItem, - ClassATItem(..), - ClassMinimalDef, - DefMethInfo, pprDefMethInfo, - - FunDep, pprFundeps, pprFunDep, - - mkClass, mkAbstractClass, classTyVars, classArity, - classKey, className, classATs, classATItems, classTyCon, classMethods, - classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, - classAllSelIds, classSCSelId, classMinimalDef, classHasFds, - isAbstractClass, - naturallyCoherentClass - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TyCon ( TyCon ) -import {-# SOURCE #-} TyCoRep ( Type, PredType, pprType ) -import Var -import Name -import BasicTypes -import Unique -import Util -import SrcLoc -import PrelNames ( eqTyConKey, coercibleTyConKey, typeableClassKey, - heqTyConKey ) -import Outputable -import BooleanFormula (BooleanFormula, mkTrue) - -import qualified Data.Data as Data - -{- -************************************************************************ -* * -\subsection[Class-basic]{@Class@: basic definition} -* * -************************************************************************ - -A @Class@ corresponds to a Greek kappa in the static semantics: --} - -data Class - = Class { - classTyCon :: TyCon, -- The data type constructor for - -- dictionaries of this class - -- See Note [ATyCon for classes] in TyCoRep - - className :: Name, -- Just the cached name of the TyCon - classKey :: Unique, -- Cached unique of TyCon - - classTyVars :: [TyVar], -- The class kind and type variables; - -- identical to those of the TyCon - - classFunDeps :: [FunDep TyVar], -- The functional dependencies - - classBody :: ClassBody -- Superclasses, ATs, methods - - } - --- | e.g. --- --- > class C a b c | a b -> c, a c -> b where... --- --- Here fun-deps are [([a,b],[c]), ([a,c],[b])] --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'', - --- For details on above see note [Api annotations] in ApiAnnotation -type FunDep a = ([a],[a]) - -type ClassOpItem = (Id, DefMethInfo) - -- Selector function; contains unfolding - -- Default-method info - -type DefMethInfo = Maybe (Name, DefMethSpec Type) - -- Nothing No default method - -- Just ($dm, VanillaDM) A polymorphic default method, name $dm - -- Just ($gm, GenericDM ty) A generic default method, name $gm, type ty - -- The generic dm type is *not* quantified - -- over the class variables; ie has the - -- class variables free - -data ClassATItem - = ATI TyCon -- See Note [Associated type tyvar names] - (Maybe (Type, SrcSpan)) - -- Default associated type (if any) from this template - -- Note [Associated type defaults] - -type ClassMinimalDef = BooleanFormula Name -- Required methods - -data ClassBody - = AbstractClass - | ConcreteClass { - -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) - -- We need value-level selectors for both the dictionary - -- superclasses and the equality superclasses - classSCThetaStuff :: [PredType], -- Immediate superclasses, - classSCSels :: [Id], -- Selector functions to extract the - -- superclasses from a - -- dictionary of this class - -- Associated types - classATStuff :: [ClassATItem], -- Associated type families - - -- Class operations (methods, not superclasses) - classOpStuff :: [ClassOpItem], -- Ordered by tag - - -- Minimal complete definition - classMinimalDefStuff :: ClassMinimalDef - } - -- TODO: maybe super classes should be allowed in abstract class definitions - -classMinimalDef :: Class -> ClassMinimalDef -classMinimalDef Class{ classBody = ConcreteClass{ classMinimalDefStuff = d } } = d -classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction - -{- -Note [Associated type defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The following is an example of associated type defaults: - class C a where - data D a r - - type F x a b :: * - type F p q r = (p,q)->r -- Default - -Note that - - * The TyCons for the associated types *share type variables* with the - class, so that we can tell which argument positions should be - instantiated in an instance decl. (The first for 'D', the second - for 'F'.) - - * We can have default definitions only for *type* families, - not data families - - * In the default decl, the "patterns" should all be type variables, - but (in the source language) they don't need to be the same as in - the 'type' decl signature or the class. It's more like a - free-standing 'type instance' declaration. - - * HOWEVER, in the internal ClassATItem we rename the RHS to match the - tyConTyVars of the family TyCon. So in the example above we'd get - a ClassATItem of - ATI F ((x,a) -> b) - So the tyConTyVars of the family TyCon bind the free vars of - the default Type rhs - -The @mkClass@ function fills in the indirect superclasses. - -The SrcSpan is for the entire original declaration. --} - -mkClass :: Name -> [TyVar] - -> [FunDep TyVar] - -> [PredType] -> [Id] - -> [ClassATItem] - -> [ClassOpItem] - -> ClassMinimalDef - -> TyCon - -> Class - -mkClass cls_name tyvars fds super_classes superdict_sels at_stuff - op_stuff mindef tycon - = Class { classKey = nameUnique cls_name, - className = cls_name, - -- NB: tyConName tycon = cls_name, - -- But it takes a module loop to assert it here - classTyVars = tyvars, - classFunDeps = fds, - classBody = ConcreteClass { - classSCThetaStuff = super_classes, - classSCSels = superdict_sels, - classATStuff = at_stuff, - classOpStuff = op_stuff, - classMinimalDefStuff = mindef - }, - classTyCon = tycon } - -mkAbstractClass :: Name -> [TyVar] - -> [FunDep TyVar] - -> TyCon - -> Class - -mkAbstractClass cls_name tyvars fds tycon - = Class { classKey = nameUnique cls_name, - className = cls_name, - -- NB: tyConName tycon = cls_name, - -- But it takes a module loop to assert it here - classTyVars = tyvars, - classFunDeps = fds, - classBody = AbstractClass, - classTyCon = tycon } - -{- -Note [Associated type tyvar names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The TyCon of an associated type should use the same variable names as its -parent class. Thus - class C a b where - type F b x a :: * -We make F use the same Name for 'a' as C does, and similary 'b'. - -The reason for this is when checking instances it's easier to match -them up, to ensure they match. Eg - instance C Int [d] where - type F [d] x Int = .... -we should make sure that the first and third args match the instance -header. - -Having the same variables for class and tycon is also used in checkValidRoles -(in TcTyClsDecls) when checking a class's roles. - - -************************************************************************ -* * -\subsection[Class-selectors]{@Class@: simple selectors} -* * -************************************************************************ - -The rest of these functions are just simple selectors. --} - -classArity :: Class -> Arity -classArity clas = length (classTyVars clas) - -- Could memoise this - -classAllSelIds :: Class -> [Id] --- Both superclass-dictionary and method selectors -classAllSelIds c@(Class { classBody = ConcreteClass { classSCSels = sc_sels }}) - = sc_sels ++ classMethods c -classAllSelIds c = ASSERT( null (classMethods c) ) [] - -classSCSelId :: Class -> Int -> Id --- Get the n'th superclass selector Id --- where n is 0-indexed, and counts --- *all* superclasses including equalities -classSCSelId (Class { classBody = ConcreteClass { classSCSels = sc_sels } }) n - = ASSERT( n >= 0 && n < length sc_sels ) - sc_sels !! n -classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n) - -classMethods :: Class -> [Id] -classMethods (Class { classBody = ConcreteClass { classOpStuff = op_stuff } }) - = [op_sel | (op_sel, _) <- op_stuff] -classMethods _ = [] - -classOpItems :: Class -> [ClassOpItem] -classOpItems (Class { classBody = ConcreteClass { classOpStuff = op_stuff }}) - = op_stuff -classOpItems _ = [] - -classATs :: Class -> [TyCon] -classATs (Class { classBody = ConcreteClass { classATStuff = at_stuff } }) - = [tc | ATI tc _ <- at_stuff] -classATs _ = [] - -classATItems :: Class -> [ClassATItem] -classATItems (Class { classBody = ConcreteClass { classATStuff = at_stuff }}) - = at_stuff -classATItems _ = [] - -classSCTheta :: Class -> [PredType] -classSCTheta (Class { classBody = ConcreteClass { classSCThetaStuff = theta_stuff }}) - = theta_stuff -classSCTheta _ = [] - -classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) -classTvsFds c = (classTyVars c, classFunDeps c) - -classHasFds :: Class -> Bool -classHasFds (Class { classFunDeps = fds }) = not (null fds) - -classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem]) -classBigSig (Class {classTyVars = tyvars, - classBody = AbstractClass}) - = (tyvars, [], [], []) -classBigSig (Class {classTyVars = tyvars, - classBody = ConcreteClass { - classSCThetaStuff = sc_theta, - classSCSels = sc_sels, - classOpStuff = op_stuff - }}) - = (tyvars, sc_theta, sc_sels, op_stuff) - -classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem]) -classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, - classBody = AbstractClass}) - = (tyvars, fundeps, [], [], [], []) -classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, - classBody = ConcreteClass { - classSCThetaStuff = sc_theta, classSCSels = sc_sels, - classATStuff = ats, classOpStuff = op_stuff - }}) - = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) - -isAbstractClass :: Class -> Bool -isAbstractClass Class{ classBody = AbstractClass } = True -isAbstractClass _ = False - --- | If a class is "naturally coherent", then we needn't worry at all, in any --- way, about overlapping/incoherent instances. Just solve the thing! -naturallyCoherentClass :: Class -> Bool --- See also Note [The equality class story] in TysPrim. -naturallyCoherentClass cls - = cls `hasKey` heqTyConKey || - cls `hasKey` eqTyConKey || - cls `hasKey` coercibleTyConKey || - cls `hasKey` typeableClassKey - -{- -************************************************************************ -* * -\subsection[Class-instances]{Instance declarations for @Class@} -* * -************************************************************************ - -We compare @Classes@ by their keys (which include @Uniques@). --} - -instance Eq Class where - c1 == c2 = classKey c1 == classKey c2 - c1 /= c2 = classKey c1 /= classKey c2 - -instance Uniquable Class where - getUnique c = classKey c - -instance NamedThing Class where - getName clas = className clas - -instance Outputable Class where - ppr c = ppr (getName c) - -pprDefMethInfo :: DefMethInfo -> SDoc -pprDefMethInfo Nothing = empty -- No default method -pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n -pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method" - <+> ppr n <+> dcolon <+> pprType ty - -pprFundeps :: Outputable a => [FunDep a] -> SDoc -pprFundeps [] = empty -pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) - -pprFunDep :: Outputable a => FunDep a -> SDoc -pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs] - -instance Data.Data Class where - -- don't traverse? - toConstr _ = abstractConstr "Class" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Class" diff --git a/types/CoAxiom.hs b/types/CoAxiom.hs deleted file mode 100644 --- a/types/CoAxiom.hs +++ /dev/null @@ -1,517 +0,0 @@ --- (c) The University of Glasgow 2012 - -{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures, - ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-} - --- | Module for coercion axioms, used to represent type family instances --- and newtypes - -module CoAxiom ( - BranchFlag, Branched, Unbranched, BranchIndex, Branches, - manyBranches, unbranched, - fromBranches, numBranches, - mapAccumBranches, - - CoAxiom(..), CoAxBranch(..), - - toBranchedAxiom, toUnbranchedAxiom, - coAxiomName, coAxiomArity, coAxiomBranches, - coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, - coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, - coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars, - coAxBranchRoles, - coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, - placeHolderIncomps, - - Role(..), fsFromRole, - - CoAxiomRule(..), TypeEqn, - BuiltInSynFamily(..), trivialBuiltInFamily - ) where - -import {-# SOURCE #-} TyCoRep ( Type, pprType ) -import {-# SOURCE #-} TyCon ( TyCon ) -import Outputable -import FastString -import Name -import Unique -import Var -import Util -import Binary -import Pair -import BasicTypes -import Data.Typeable ( Typeable ) -import SrcLoc -import qualified Data.Data as Data -import Data.Array -import Data.List ( mapAccumL ) - -#include "HsVersions.h" - -{- -Note [Coercion axiom branches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In order to allow closed type families, an axiom needs to contain an -ordered list of alternatives, called branches. The kind of the coercion built -from an axiom is determined by which index is used when building the coercion -from the axiom. - -For example, consider the axiom derived from the following declaration: - -type family F a where - F [Int] = Bool - F [a] = Double - F (a b) = Char - -This will give rise to this axiom: - -axF :: { F [Int] ~ Bool - ; forall (a :: *). F [a] ~ Double - ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char - } - -The axiom is used with the AxiomInstCo constructor of Coercion. If we wish -to have a coercion showing that F (Maybe Int) ~ Char, it will look like - -axF[2] <*> :: F (Maybe Int) ~ Char --- or, written using concrete-ish syntax -- -AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int] - -Note that the index is 0-based. - -For type-checking, it is also necessary to check that no previous pattern -can unify with the supplied arguments. After all, it is possible that some -of the type arguments are lambda-bound type variables whose instantiation may -cause an earlier match among the branches. We wish to prohibit this behavior, -so the type checker rules out the choice of a branch where a previous branch -can unify. See also [Apartness] in FamInstEnv.hs. - -For example, the following is malformed, where 'a' is a lambda-bound type -variable: - -axF[2] <*> :: F (a Bool) ~ Char - -Why? Because a might be instantiated with [], meaning that branch 1 should -apply, not branch 2. This is a vital consistency check; without it, we could -derive Int ~ Bool, and that is a Bad Thing. - -Note [Branched axioms] -~~~~~~~~~~~~~~~~~~~~~~ -Although a CoAxiom has the capacity to store many branches, in certain cases, -we want only one. These cases are in data/newtype family instances, newtype -coercions, and type family instances. -Furthermore, these unbranched axioms are used in a -variety of places throughout GHC, and it would difficult to generalize all of -that code to deal with branched axioms, especially when the code can be sure -of the fact that an axiom is indeed a singleton. At the same time, it seems -dangerous to assume singlehood in various places through GHC. - -The solution to this is to label a CoAxiom with a phantom type variable -declaring whether it is known to be a singleton or not. The branches -are stored using a special datatype, declared below, that ensures that the -type variable is accurate. - -************************************************************************ -* * - Branches -* * -************************************************************************ --} - -type BranchIndex = Int -- The index of the branch in the list of branches - -- Counting from zero - --- promoted data type -data BranchFlag = Branched | Unbranched -type Branched = 'Branched -type Unbranched = 'Unbranched --- By using type synonyms for the promoted constructors, we avoid needing --- DataKinds and the promotion quote in client modules. This also means that --- we don't need to export the term-level constructors, which should never be used. - -newtype Branches (br :: BranchFlag) - = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch } -type role Branches nominal - -manyBranches :: [CoAxBranch] -> Branches Branched -manyBranches brs = ASSERT( snd bnds >= fst bnds ) - MkBranches (listArray bnds brs) - where - bnds = (0, length brs - 1) - -unbranched :: CoAxBranch -> Branches Unbranched -unbranched br = MkBranches (listArray (0, 0) [br]) - -toBranched :: Branches br -> Branches Branched -toBranched = MkBranches . unMkBranches - -toUnbranched :: Branches br -> Branches Unbranched -toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) ) - MkBranches arr - -fromBranches :: Branches br -> [CoAxBranch] -fromBranches = elems . unMkBranches - -branchesNth :: Branches br -> BranchIndex -> CoAxBranch -branchesNth (MkBranches arr) n = arr ! n - -numBranches :: Branches br -> Int -numBranches (MkBranches arr) = snd (bounds arr) + 1 - --- | The @[CoAxBranch]@ passed into the mapping function is a list of --- all previous branches, reversed -mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch) - -> Branches br -> Branches br -mapAccumBranches f (MkBranches arr) - = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr))) - where - go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) - go prev_branches cur_branch = ( cur_branch : prev_branches - , f prev_branches cur_branch ) - - -{- -************************************************************************ -* * - Coercion axioms -* * -************************************************************************ - -Note [Storing compatibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During axiom application, we need to be aware of which branches are compatible -with which others. The full explanation is in Note [Compatibility] in -FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on -the unification algorithm.) Although we could theoretically compute -compatibility on the fly, this is silly, so we store it in a CoAxiom. - -Specifically, each branch refers to all other branches with which it is -incompatible. This list might well be empty, and it will always be for the -first branch of any axiom. - -CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk -stored in cab_incomps. The incompatibilities are properly a property of the -axiom as a whole, and they are computed only when the final axiom is built. - -During serialization, the list is converted into a list of the indices -of the branches. --} - --- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data CoAxiom br - = CoAxiom -- Type equality axiom. - { co_ax_unique :: Unique -- Unique identifier - , co_ax_name :: Name -- Name for pretty-printing - , co_ax_role :: Role -- Role of the axiom's equality - , co_ax_tc :: TyCon -- The head of the LHS patterns - -- e.g. the newtype or family tycon - , co_ax_branches :: Branches br -- The branches that form this axiom - , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" - -- See Note [Implicit axioms] - -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. - } - -data CoAxBranch - = CoAxBranch - { cab_loc :: SrcSpan -- Location of the defining equation - -- See Note [CoAxiom locations] - , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh - -- See Note [CoAxBranch type variables] - , cab_cvs :: [CoVar] -- Bound coercion variables - -- Always empty, for now. - -- See Note [Constraints in patterns] - -- in TcTyClsDecls - , cab_roles :: [Role] -- See Note [CoAxBranch roles] - , cab_lhs :: [Type] -- Type patterns to match against - -- See Note [CoAxiom saturation] - , cab_rhs :: Type -- Right-hand side of the equality - , cab_incomps :: [CoAxBranch] -- The previous incompatible branches - -- See Note [Storing compatibility] - } - deriving Data.Data - -toBranchedAxiom :: CoAxiom br -> CoAxiom Branched -toBranchedAxiom (CoAxiom unique name role tc branches implicit) - = CoAxiom unique name role tc (toBranched branches) implicit - -toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched -toUnbranchedAxiom (CoAxiom unique name role tc branches implicit) - = CoAxiom unique name role tc (toUnbranched branches) implicit - -coAxiomNumPats :: CoAxiom br -> Int -coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) - -coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch -coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index - = branchesNth bs index - -coAxiomArity :: CoAxiom br -> BranchIndex -> Arity -coAxiomArity ax index - = length tvs + length cvs - where - CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index - -coAxiomName :: CoAxiom br -> Name -coAxiomName = co_ax_name - -coAxiomRole :: CoAxiom br -> Role -coAxiomRole = co_ax_role - -coAxiomBranches :: CoAxiom br -> Branches br -coAxiomBranches = co_ax_branches - -coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch -coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr }) - | snd (bounds arr) == 0 - = Just $ arr ! 0 - | otherwise - = Nothing - -coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch -coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr }) - = arr ! 0 - -coAxiomTyCon :: CoAxiom br -> TyCon -coAxiomTyCon = co_ax_tc - -coAxBranchTyVars :: CoAxBranch -> [TyVar] -coAxBranchTyVars = cab_tvs - -coAxBranchCoVars :: CoAxBranch -> [CoVar] -coAxBranchCoVars = cab_cvs - -coAxBranchLHS :: CoAxBranch -> [Type] -coAxBranchLHS = cab_lhs - -coAxBranchRHS :: CoAxBranch -> Type -coAxBranchRHS = cab_rhs - -coAxBranchRoles :: CoAxBranch -> [Role] -coAxBranchRoles = cab_roles - -coAxBranchSpan :: CoAxBranch -> SrcSpan -coAxBranchSpan = cab_loc - -isImplicitCoAxiom :: CoAxiom br -> Bool -isImplicitCoAxiom = co_ax_implicit - -coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] -coAxBranchIncomps = cab_incomps - --- See Note [Compatibility checking] in FamInstEnv -placeHolderIncomps :: [CoAxBranch] -placeHolderIncomps = panic "placeHolderIncomps" - -{- Note [CoAxiom saturation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* When co - -Note [CoAxBranch type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the case of a CoAxBranch of an associated type-family instance, -we use the *same* type variables (where possible) as the -enclosing class or instance. Consider - class C a b where - type F x b - type F [y] b = ... -- Second param must be b - - instance C Int [z] where - type F Int [z] = ... -- Second param must be [z] - -In the CoAxBranch in the instance decl (F Int [z]) we use the -same 'z', so that it's easy to check that that type is the same -as that in the instance header. - -Similarly in the CoAxBranch for the default decl for F in the -class decl, we use the same 'b' to make the same check easy. - -So, unlike FamInsts, there is no expectation that the cab_tvs -are fresh wrt each other, or any other CoAxBranch. - -Note [CoAxBranch roles] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider this code: - - newtype Age = MkAge Int - newtype Wrap a = MkWrap a - - convert :: Wrap Age -> Int - convert (MkWrap (MkAge i)) = i - -We want this to compile to: - - NTCo:Wrap :: forall a. Wrap a ~R a - NTCo:Age :: Age ~R Int - convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0]) - -But, note that NTCo:Age is at role R. Thus, we need to be able to pass -coercions at role R into axioms. However, we don't *always* want to be able to -do this, as it would be disastrous with type families. The solution is to -annotate the arguments to the axiom with roles, much like we annotate tycon -tyvars. Where do these roles get set? Newtype axioms inherit their roles from -the newtype tycon; family axioms are all at role N. - -Note [CoAxiom locations] -~~~~~~~~~~~~~~~~~~~~~~~~ -The source location of a CoAxiom is stored in two places in the -datatype tree. - * The first is in the location info buried in the Name of the - CoAxiom. This span includes all of the branches of a branched - CoAxiom. - * The second is in the cab_loc fields of the CoAxBranches. - -In the case of a single branch, we can extract the source location of -the branch from the name of the CoAxiom. In other cases, we need an -explicit SrcSpan to correctly store the location of the equation -giving rise to the FamInstBranch. - -Note [Implicit axioms] -~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Implicit TyThings] in HscTypes -* A CoAxiom arising from data/type family instances is not "implicit". - That is, it has its own IfaceAxiom declaration in an interface file - -* The CoAxiom arising from a newtype declaration *is* "implicit". - That is, it does not have its own IfaceAxiom declaration in an - interface file; instead the CoAxiom is generated by type-checking - the newtype declaration --} - -instance Eq (CoAxiom br) where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Uniquable (CoAxiom br) where - getUnique = co_ax_unique - -instance Outputable (CoAxiom br) where - ppr = ppr . getName - -instance NamedThing (CoAxiom br) where - getName = co_ax_name - -instance Typeable br => Data.Data (CoAxiom br) where - -- don't traverse? - toConstr _ = abstractConstr "CoAxiom" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "CoAxiom" - -instance Outputable CoAxBranch where - ppr (CoAxBranch { cab_loc = loc - , cab_lhs = lhs - , cab_rhs = rhs }) = - text "CoAxBranch" <+> parens (ppr loc) <> colon - <+> brackets (fsep (punctuate comma (map pprType lhs))) - <+> text "=>" <+> pprType rhs - -{- -************************************************************************ -* * - Roles -* * -************************************************************************ - -Roles are defined here to avoid circular dependencies. --} - --- See Note [Roles] in Coercion --- defined here to avoid cyclic dependency with Coercion --- --- Order of constructors matters: the Ord instance coincides with the *super*typing --- relation on roles. -data Role = Nominal | Representational | Phantom - deriving (Eq, Ord, Data.Data) - --- These names are slurped into the parser code. Changing these strings --- will change the **surface syntax** that GHC accepts! If you want to --- change only the pretty-printing, do some replumbing. See --- mkRoleAnnotDecl in RdrHsSyn -fsFromRole :: Role -> FastString -fsFromRole Nominal = fsLit "nominal" -fsFromRole Representational = fsLit "representational" -fsFromRole Phantom = fsLit "phantom" - -instance Outputable Role where - ppr = ftext . fsFromRole - -instance Binary Role where - put_ bh Nominal = putByte bh 1 - put_ bh Representational = putByte bh 2 - put_ bh Phantom = putByte bh 3 - - get bh = do tag <- getByte bh - case tag of 1 -> return Nominal - 2 -> return Representational - 3 -> return Phantom - _ -> panic ("get Role " ++ show tag) - -{- -************************************************************************ -* * - CoAxiomRule - Rules for building Evidence -* * -************************************************************************ - -Conditional axioms. The general idea is that a `CoAxiomRule` looks like this: - - forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2 - -My intention is to reuse these for both (~) and (~#). -The short-term plan is to use this datatype to represent the type-nat axioms. -In the longer run, it may be good to unify this and `CoAxiom`, -as `CoAxiom` is the special case when there are no assumptions. --} - --- | A more explicit representation for `t1 ~ t2`. -type TypeEqn = Pair Type - --- | For now, we work only with nominal equality. -data CoAxiomRule = CoAxiomRule - { coaxrName :: FastString - , coaxrAsmpRoles :: [Role] -- roles of parameter equations - , coaxrRole :: Role -- role of resulting equation - , coaxrProves :: [TypeEqn] -> Maybe TypeEqn - -- ^ coaxrProves returns @Nothing@ when it doesn't like - -- the supplied arguments. When this happens in a coercion - -- that means that the coercion is ill-formed, and Core Lint - -- checks for that. - } - -instance Data.Data CoAxiomRule where - -- don't traverse? - toConstr _ = abstractConstr "CoAxiomRule" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "CoAxiomRule" - -instance Uniquable CoAxiomRule where - getUnique = getUnique . coaxrName - -instance Eq CoAxiomRule where - x == y = coaxrName x == coaxrName y - -instance Ord CoAxiomRule where - compare x y = compare (coaxrName x) (coaxrName y) - -instance Outputable CoAxiomRule where - ppr = ppr . coaxrName - - --- Type checking of built-in families -data BuiltInSynFamily = BuiltInSynFamily - { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) - , sfInteractTop :: [Type] -> Type -> [TypeEqn] - , sfInteractInert :: [Type] -> Type -> - [Type] -> Type -> [TypeEqn] - } - --- Provides default implementations that do nothing. -trivialBuiltInFamily :: BuiltInSynFamily -trivialBuiltInFamily = BuiltInSynFamily - { sfMatchFam = \_ -> Nothing - , sfInteractTop = \_ _ -> [] - , sfInteractInert = \_ _ _ _ -> [] - } diff --git a/types/Coercion.hs b/types/Coercion.hs deleted file mode 100644 --- a/types/Coercion.hs +++ /dev/null @@ -1,1961 +0,0 @@ -{- -(c) The University of Glasgow 2006 --} - -{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts #-} - --- | Module for (a) type kinds and (b) type coercions, --- as used in System FC. See 'CoreSyn.Expr' for --- more on System FC and how coercions fit into it. --- -module Coercion ( - -- * Main data type - Coercion, CoercionN, CoercionR, CoercionP, - UnivCoProvenance, CoercionHole, LeftOrRight(..), - Var, CoVar, TyCoVar, - Role(..), ltRole, - - -- ** Functions over coercions - coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole, - coercionType, coercionKind, coercionKinds, - mkCoercionType, - coercionRole, coercionKindRole, - - -- ** Constructing coercions - mkReflCo, mkRepReflCo, mkNomReflCo, - mkCoVarCo, mkCoVarCos, - mkAxInstCo, mkUnbranchedAxInstCo, - mkAxInstRHS, mkUnbranchedAxInstRHS, - mkAxInstLHS, mkUnbranchedAxInstLHS, - mkPiCo, mkPiCos, mkCoCast, - mkSymCo, mkTransCo, mkTransAppCo, - mkNthCo, mkNthCoRole, mkLRCo, - mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunCos, - mkForAllCo, mkForAllCos, mkHomoForAllCos, mkHomoForAllCos_NoRefl, - mkPhantomCo, mkHomoPhantomCo, toPhantomCo, - mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo, - mkAxiomInstCo, mkProofIrrelCo, - downgradeRole, maybeSubCo, mkAxiomRuleCo, - mkCoherenceCo, mkCoherenceRightCo, mkCoherenceLeftCo, - mkKindCo, castCoercionKind, - - mkHeteroCoercionType, - - -- ** Decomposition - instNewTyCon_maybe, - - NormaliseStepper, NormaliseStepResult(..), composeSteppers, - mapStepResult, unwrapNewTypeStepper, - topNormaliseNewType_maybe, topNormaliseTypeX, - - decomposeCo, decomposeFunCo, getCoVar_maybe, - splitTyConAppCo_maybe, - splitAppCo_maybe, - splitFunCo_maybe, - splitForAllCo_maybe, - - nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, - - pickLR, - - isReflCo, isReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, - isReflCoVar_maybe, - - -- ** Coercion variables - mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, - isCoVar_maybe, - - -- ** Free variables - tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, - tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, - coercionSize, - - -- ** Substitution - CvSubstEnv, emptyCvSubstEnv, - lookupCoVar, - substCo, substCos, substCoVar, substCoVars, substCoWith, - substCoVarBndr, - extendTvSubstAndInScope, getCvSubstEnv, - - -- ** Lifting - liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, - emptyLiftingContext, extendLiftingContext, - liftCoSubstVarBndrCallback, isMappedByLC, - - mkSubstLiftingContext, zapLiftingContext, - substForAllCoBndrCallbackLC, lcTCvSubst, lcInScopeSet, - - LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, - substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, - - -- ** Comparison - eqCoercion, eqCoercionX, - - -- ** Forcing evaluation of coercions - seqCo, - - -- * Pretty-printing - pprCo, pprParendCo, pprCoBndr, - pprCoAxiom, pprCoAxBranch, pprCoAxBranchHdr, - - -- * Tidying - tidyCo, tidyCos, - - -- * Other - promoteCoercion - ) where - -#include "HsVersions.h" - -import TyCoRep -import Type -import TyCon -import CoAxiom -import Var -import VarEnv -import Name hiding ( varName ) -import Util -import BasicTypes -import Outputable -import Unique -import Pair -import SrcLoc -import PrelNames -import TysPrim ( eqPhantPrimTyCon ) -import ListSetOps -import Maybes -import UniqFM - -import Control.Monad (foldM) -import Control.Arrow ( first ) -import Data.Function ( on ) - -{- -%************************************************************************ -%* * - -- The coercion arguments always *precisely* saturate - -- arity of (that branch of) the CoAxiom. If there are - -- any left over, we use AppCo. See - -- See [Coercion axioms applied to coercions] in TyCoRep - -\subsection{Coercion variables} -%* * -%************************************************************************ --} - -coVarName :: CoVar -> Name -coVarName = varName - -setCoVarUnique :: CoVar -> Unique -> CoVar -setCoVarUnique = setVarUnique - -setCoVarName :: CoVar -> Name -> CoVar -setCoVarName = setVarName - - -{- -%************************************************************************ -%* * - Pretty-printing coercions -%* * -%************************************************************************ - -@pprCo@ is the standard @Coercion@ printer; the overloaded @ppr@ -function is defined to use this. @pprParendCo@ is the same, except it -puts parens around the type, except for the atomic cases. -@pprParendCo@ works just by setting the initial context precedence -very high. --} - --- Outputable instances are in TyCoRep, to avoid orphans - -pprCo, pprParendCo :: Coercion -> SDoc -pprCo co = ppr_co TopPrec co -pprParendCo co = ppr_co TyConPrec co - -ppr_co :: TyPrec -> Coercion -> SDoc -ppr_co _ (Refl r ty) = angleBrackets (ppr ty) <> ppr_role r - -ppr_co _ (TyConAppCo r tc cos) = pprTcAppCo TyConPrec ppr_co tc cos <> ppr_role r -ppr_co p (AppCo co arg) = maybeParen p TyConPrec $ - pprCo co <+> ppr_co TyConPrec arg -ppr_co p co@(ForAllCo {}) = ppr_forall_co p co -ppr_co p co@(FunCo {}) = ppr_fun_co p co -ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) -ppr_co p (AxiomInstCo con index args) - = pprPrefixApp p (ppr (getName con) <> brackets (ppr index)) - (map (ppr_co TyConPrec) args) - -ppr_co p co@(TransCo {}) = maybeParen p FunPrec $ - case trans_co_list co [] of - [] -> panic "ppr_co" - (co:cos) -> sep ( ppr_co FunPrec co - : [ char ';' <+> ppr_co FunPrec co | co <- cos]) -ppr_co p (InstCo co arg) = maybeParen p TyConPrec $ - pprParendCo co <> text "@" <> ppr_co TopPrec arg - -ppr_co p (UnivCo UnsafeCoerceProv r ty1 ty2) - = pprPrefixApp p (text "UnsafeCo" <+> ppr r) - [pprParendType ty1, pprParendType ty2] -ppr_co _ (UnivCo p r t1 t2) - = char 'U' - <> parens (ppr_prov <> comma <+> ppr t1 <> comma <+> ppr t2) - <> ppr_role r - where - ppr_prov = case p of - HoleProv h -> text "hole:" <> ppr h - PhantomProv kind_co -> text "phant:" <> ppr kind_co - ProofIrrelProv co -> text "irrel:" <> ppr co - PluginProv s -> text "plugin:" <> text s - UnsafeCoerceProv -> text "unsafe" - -ppr_co p (SymCo co) = pprPrefixApp p (text "Sym") [pprParendCo co] -ppr_co p (NthCo n co) = pprPrefixApp p (text "Nth:" <> int n) [pprParendCo co] -ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co] -ppr_co p (CoherenceCo c1 c2) = maybeParen p TyConPrec $ - (ppr_co FunPrec c1) <+> (text "|>") <+> - (ppr_co FunPrec c2) -ppr_co p (KindCo co) = pprPrefixApp p (text "kind") [pprParendCo co] -ppr_co p (SubCo co) = pprPrefixApp p (text "Sub") [pprParendCo co] -ppr_co p (AxiomRuleCo co cs) = maybeParen p TopPrec $ ppr_axiom_rule_co co cs - -ppr_axiom_rule_co :: CoAxiomRule -> [Coercion] -> SDoc -ppr_axiom_rule_co co ps = ppr (coaxrName co) <+> parens (interpp'SP ps) - -ppr_role :: Role -> SDoc -ppr_role r = underscore <> pp_role - where pp_role = case r of - Nominal -> char 'N' - Representational -> char 'R' - Phantom -> char 'P' - -trans_co_list :: Coercion -> [Coercion] -> [Coercion] -trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos) -trans_co_list co cos = co : cos - -ppr_fun_co :: TyPrec -> Coercion -> SDoc -ppr_fun_co p co = pprArrowChain p (split co) - where - split :: Coercion -> [SDoc] - split (FunCo _ arg res) - = ppr_co FunPrec arg : split res - split co = [ppr_co TopPrec co] - -ppr_forall_co :: TyPrec -> Coercion -> SDoc -ppr_forall_co p (ForAllCo tv h co) - = maybeParen p FunPrec $ - sep [pprCoBndr (tyVarName tv) h, ppr_co TopPrec co] -ppr_forall_co _ _ = panic "ppr_forall_co" - -pprCoBndr :: Name -> Coercion -> SDoc -pprCoBndr name eta = - forAllLit <+> parens (ppr name <+> dcolon <+> ppr eta) <> dot - -pprCoAxiom :: CoAxiom br -> SDoc -pprCoAxiom ax@(CoAxiom { co_ax_branches = branches }) - = hang (text "axiom" <+> ppr ax <+> dcolon) - 2 (vcat (map (ppr_co_ax_branch (const ppr) ax) $ fromBranches branches)) - -pprCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc -pprCoAxBranch = ppr_co_ax_branch pprRhs - where - pprRhs fam_tc (TyConApp tycon _) - | isDataFamilyTyCon fam_tc - = pprDataCons tycon - pprRhs _ rhs = ppr rhs - -pprCoAxBranchHdr :: CoAxiom br -> BranchIndex -> SDoc -pprCoAxBranchHdr ax index = pprCoAxBranch ax (coAxiomNthBranch ax index) - -ppr_co_ax_branch :: (TyCon -> Type -> SDoc) -> CoAxiom br -> CoAxBranch -> SDoc -ppr_co_ax_branch ppr_rhs - (CoAxiom { co_ax_tc = fam_tc, co_ax_name = name }) - (CoAxBranch { cab_tvs = tvs - , cab_cvs = cvs - , cab_lhs = lhs - , cab_rhs = rhs - , cab_loc = loc }) - = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll (mkTyVarBinders Inferred (tvs ++ cvs)) - , pprTypeApp fam_tc lhs <+> equals <+> ppr_rhs fam_tc rhs - , text "-- Defined" <+> pprLoc loc ] - where - pprLoc loc - | isGoodSrcSpan loc - = text "at" <+> ppr (srcSpanStart loc) - - | otherwise - = text "in" <+> - quotes (ppr (nameModule name)) - -{- -%************************************************************************ -%* * - Destructing coercions -%* * -%************************************************************************ - -Note [Function coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Remember that - (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep - -Hence - FunCo r co1 co2 :: (s1->t1) ~r (s2->t2) -is short for - TyConAppCo (->) co_rep1 co_rep2 co1 co2 -where co_rep1, co_rep2 are the coercions on the representations. --} - - --- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into --- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: --- --- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c] -decomposeCo :: Arity -> Coercion -> [Coercion] -decomposeCo arity co - = [mkNthCo n co | n <- [0..(arity-1)] ] - -- Remember, Nth is zero-indexed - -decomposeFunCo :: Coercion -> (Coercion, Coercion) --- Expects co :: (s1 -> t1) ~ (s2 -> t2) --- Returns (co1 :: s1~s2, co2 :: t1~t2) --- See Note [Function coercions] for the "2" and "3" -decomposeFunCo co = ASSERT2( all_ok, ppr co ) - (mkNthCo 2 co, mkNthCo 3 co) - where - Pair s1t1 s2t2 = coercionKind co - all_ok = isFunTy s1t1 && isFunTy s2t2 - --- | Attempts to obtain the type variable underlying a 'Coercion' -getCoVar_maybe :: Coercion -> Maybe CoVar -getCoVar_maybe (CoVarCo cv) = Just cv -getCoVar_maybe _ = Nothing - --- | Attempts to tease a coercion apart into a type constructor and the application --- of a number of coercion arguments to that constructor -splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) -splitTyConAppCo_maybe (Refl r ty) - = do { (tc, tys) <- splitTyConApp_maybe ty - ; let args = zipWith mkReflCo (tyConRolesX r tc) tys - ; return (tc, args) } -splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) -splitTyConAppCo_maybe (FunCo _ arg res) = Just (funTyCon, cos) - where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] -splitTyConAppCo_maybe _ = Nothing - --- first result has role equal to input; third result is Nominal -splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) --- ^ Attempt to take a coercion application apart. -splitAppCo_maybe (AppCo co arg) = Just (co, arg) -splitAppCo_maybe (TyConAppCo r tc args) - | mightBeUnsaturatedTyCon tc || args `lengthExceeds` tyConArity tc - -- Never create unsaturated type family apps! - , Just (args', arg') <- snocView args - , Just arg'' <- setNominalRole_maybe arg' - = Just ( mkTyConAppCo r tc args', arg'' ) - -- Use mkTyConAppCo to preserve the invariant - -- that identity coercions are always represented by Refl - -splitAppCo_maybe (Refl r ty) - | Just (ty1, ty2) <- splitAppTy_maybe ty - = Just (mkReflCo r ty1, mkNomReflCo ty2) -splitAppCo_maybe _ = Nothing - -splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) -splitFunCo_maybe (FunCo _ arg res) = Just (arg, res) -splitFunCo_maybe _ = Nothing - -splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) -splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) -splitForAllCo_maybe _ = Nothing - -------------------------------------------------------- --- and some coercion kind stuff - -coVarTypes :: CoVar -> Pair Type -coVarTypes cv - | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv - = Pair ty1 ty2 - -coVarKindsTypesRole :: CoVar -> (Kind,Kind,Type,Type,Role) -coVarKindsTypesRole cv - | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv) - = let role - | tc `hasKey` eqPrimTyConKey = Nominal - | tc `hasKey` eqReprPrimTyConKey = Representational - | otherwise = panic "coVarKindsTypesRole" - in (k1,k2,ty1,ty2,role) - | otherwise = pprPanic "coVarKindsTypesRole, non coercion variable" - (ppr cv $$ ppr (varType cv)) - -coVarKind :: CoVar -> Type -coVarKind cv - = ASSERT( isCoVar cv ) - varType cv - -coVarRole :: CoVar -> Role -coVarRole cv - | tc `hasKey` eqPrimTyConKey - = Nominal - | tc `hasKey` eqReprPrimTyConKey - = Representational - | otherwise - = pprPanic "coVarRole: unknown tycon" (ppr cv <+> dcolon <+> ppr (varType cv)) - - where - tc = case tyConAppTyCon_maybe (varType cv) of - Just tc0 -> tc0 - Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv) - --- | Makes a coercion type from two types: the types whose equality --- is proven by the relevant 'Coercion' -mkCoercionType :: Role -> Type -> Type -> Type -mkCoercionType Nominal = mkPrimEqPred -mkCoercionType Representational = mkReprPrimEqPred -mkCoercionType Phantom = \ty1 ty2 -> - let ki1 = typeKind ty1 - ki2 = typeKind ty2 - in - TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] - -mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type -mkHeteroCoercionType Nominal = mkHeteroPrimEqPred -mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred -mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType" - --- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@, --- produce a coercion @rep_co :: r1 ~ r2@. -mkRuntimeRepCo :: Coercion -> Coercion -mkRuntimeRepCo co - = mkNthCo 0 kind_co - where - kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 - -- (up to silliness with Constraint) - -isReflCoVar_maybe :: CoVar -> Maybe Coercion --- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) -isReflCoVar_maybe cv - | Pair ty1 ty2 <- coVarTypes cv - , ty1 `eqType` ty2 - = Just (Refl (coVarRole cv) ty1) - | otherwise - = Nothing - --- | Tests if this coercion is obviously reflexive. Guaranteed to work --- very quickly. Sometimes a coercion can be reflexive, but not obviously --- so. c.f. 'isReflexiveCo' -isReflCo :: Coercion -> Bool -isReflCo (Refl {}) = True -isReflCo _ = False - --- | Returns the type coerced if this coercion is reflexive. Guaranteed --- to work very quickly. Sometimes a coercion can be reflexive, but not --- obviously so. c.f. 'isReflexiveCo_maybe' -isReflCo_maybe :: Coercion -> Maybe (Type, Role) -isReflCo_maybe (Refl r ty) = Just (ty, r) -isReflCo_maybe _ = Nothing - --- | Slowly checks if the coercion is reflexive. Don't call this in a loop, --- as it walks over the entire coercion. -isReflexiveCo :: Coercion -> Bool -isReflexiveCo = isJust . isReflexiveCo_maybe - --- | Extracts the coerced type from a reflexive coercion. This potentially --- walks over the entire coercion, so avoid doing this in a loop. -isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) -isReflexiveCo_maybe (Refl r ty) = Just (ty, r) -isReflexiveCo_maybe co - | ty1 `eqType` ty2 - = Just (ty1, r) - | otherwise - = Nothing - where (Pair ty1 ty2, r) = coercionKindRole co - -{- -%************************************************************************ -%* * - Building coercions -%* * -%************************************************************************ - -These "smart constructors" maintain the invariants listed in the definition -of Coercion, and they perform very basic optimizations. - -Note [Role twiddling functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a plethora of functions for twiddling roles: - -mkSubCo: Requires a nominal input coercion and always produces a -representational output. This is used when you (the programmer) are sure you -know exactly that role you have and what you want. - -downgradeRole_maybe: This function takes both the input role and the output role -as parameters. (The *output* role comes first!) It can only *downgrade* a -role -- that is, change it from N to R or P, or from R to P. This one-way -behavior is why there is the "_maybe". If an upgrade is requested, this -function produces Nothing. This is used when you need to change the role of a -coercion, but you're not sure (as you're writing the code) of which roles are -involved. - -This function could have been written using coercionRole to ascertain the role -of the input. But, that function is recursive, and the caller of downgradeRole_maybe -often knows the input role. So, this is more efficient. - -downgradeRole: This is just like downgradeRole_maybe, but it panics if the -conversion isn't a downgrade. - -setNominalRole_maybe: This is the only function that can *upgrade* a coercion. -The result (if it exists) is always Nominal. The input can be at any role. It -works on a "best effort" basis, as it should never be strictly necessary to -upgrade a coercion during compilation. It is currently only used within GHC in -splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second -coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable -that splitAppCo_maybe is operating over a TyConAppCo that uses a -representational coercion. Hence the need for setNominalRole_maybe. -splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, -it is not absolutely critical that setNominalRole_maybe be complete. - -Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom -UnivCos are perfectly type-safe, whereas representational and nominal ones are -not. Indeed, `unsafeCoerce` is implemented via a representational UnivCo. -(Nominal ones are no worse than representational ones, so this function *will* -change a UnivCo Representational to a UnivCo Nominal.) - -Conal Elliott also came across a need for this function while working with the -GHC API, as he was decomposing Core casts. The Core casts use representational -coercions, as they must, but his use case required nominal coercions (he was -building a GADT). So, that's why this function is exported from this module. - -One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as -appropriate? I (Richard E.) have decided not to do this, because upgrading a -role is bizarre and a caller should have to ask for this behavior explicitly. - -Note [mkTransAppCo] -~~~~~~~~~~~~~~~~~~~ -Suppose we have - - co1 :: a ~R Maybe - co2 :: b ~R Int - -and we want - - co3 :: a b ~R Maybe Int - -This seems sensible enough. But, we can't let (co3 = co1 co2), because -that's ill-roled! Note that mkAppCo requires a *nominal* second coercion. - -The way around this is to use transitivity: - - co3 = (co1 _N) ; (Maybe co2) :: a b ~R Maybe Int - -Or, it's possible everything is the other way around: - - co1' :: Maybe ~R a - co2' :: Int ~R b - -and we want - - co3' :: Maybe Int ~R a b - -then - - co3' = (Maybe co2') ; (co1' _N) - -This is exactly what `mkTransAppCo` builds for us. Information for all -the arguments tends to be to hand at call sites, so it's quicker than -using, say, coercionKind. - --} - -mkReflCo :: Role -> Type -> Coercion -mkReflCo r ty - = Refl r ty - --- | Make a representational reflexive coercion -mkRepReflCo :: Type -> Coercion -mkRepReflCo = mkReflCo Representational - --- | Make a nominal reflexive coercion -mkNomReflCo :: Type -> Coercion -mkNomReflCo = mkReflCo Nominal - --- | Apply a type constructor to a list of coercions. It is the --- caller's responsibility to get the roles correct on argument coercions. -mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion -mkTyConAppCo r tc cos - | tc `hasKey` funTyConKey - , [_rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] - = -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd) - -- rep1 :: ra ~ rc rep2 :: rb ~ rd - -- co1 :: a ~ c co2 :: b ~ d - mkFunCo r co1 co2 - - -- Expand type synonyms - | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos - = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos - - | Just tys_roles <- traverse isReflCo_maybe cos - = Refl r (mkTyConApp tc (map fst tys_roles)) -- See Note [Refl invariant] - - | otherwise = TyConAppCo r tc cos - --- | Build a function 'Coercion' from two other 'Coercion's. That is, --- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@. -mkFunCo :: Role -> Coercion -> Coercion -> Coercion -mkFunCo r co1 co2 - -- See Note [Refl invariant] - | Just (ty1, _) <- isReflCo_maybe co1 - , Just (ty2, _) <- isReflCo_maybe co2 - = Refl r (mkFunTy ty1 ty2) - | otherwise = FunCo r co1 co2 - --- | Make nested function 'Coercion's -mkFunCos :: Role -> [Coercion] -> Coercion -> Coercion -mkFunCos r cos res_co = foldr (mkFunCo r) res_co cos - --- | Apply a 'Coercion' to another 'Coercion'. --- The second coercion must be Nominal, unless the first is Phantom. --- If the first is Phantom, then the second can be either Phantom or Nominal. -mkAppCo :: Coercion -- ^ :: t1 ~r t2 - -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 - -> Coercion -- ^ :: t1 s1 ~r t2 s2 -mkAppCo (Refl r ty1) arg - | Just (ty2, _) <- isReflCo_maybe arg - = Refl r (mkAppTy ty1 ty2) - - | Just (tc, tys) <- splitTyConApp_maybe ty1 - -- Expand type synonyms; a TyConAppCo can't have a type synonym (Trac #9102) - = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) - where - zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg] - zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys - zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... - -mkAppCo (TyConAppCo r tc args) arg - = case r of - Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) - Representational -> mkTyConAppCo Representational tc (args ++ [arg']) - where new_role = (tyConRolesRepresentational tc) !! (length args) - arg' = downgradeRole new_role Nominal arg - Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) -mkAppCo co arg = AppCo co arg --- Note, mkAppCo is careful to maintain invariants regarding --- where Refl constructors appear; see the comments in the definition --- of Coercion and the Note [Refl invariant] in TyCoRep. - --- | Applies multiple 'Coercion's to another 'Coercion', from left to right. --- See also 'mkAppCo'. -mkAppCos :: Coercion - -> [Coercion] - -> Coercion -mkAppCos co1 cos = foldl mkAppCo co1 cos - --- | Like `mkAppCo`, but allows the second coercion to be other than --- nominal. See Note [mkTransAppCo]. Role r3 cannot be more stringent --- than either r1 or r2. -mkTransAppCo :: Role -- ^ r1 - -> Coercion -- ^ co1 :: ty1a ~r1 ty1b - -> Type -- ^ ty1a - -> Type -- ^ ty1b - -> Role -- ^ r2 - -> Coercion -- ^ co2 :: ty2a ~r2 ty2b - -> Type -- ^ ty2a - -> Type -- ^ ty2b - -> Role -- ^ r3 - -> Coercion -- ^ :: ty1a ty2a ~r3 ty1b ty2b -mkTransAppCo r1 co1 ty1a ty1b r2 co2 ty2a ty2b r3 --- How incredibly fiddly! Is there a better way?? - = case (r1, r2, r3) of - (_, _, Phantom) - -> mkPhantomCo kind_co (mkAppTy ty1a ty2a) (mkAppTy ty1b ty2b) - where -- ty1a :: k1a -> k2a - -- ty1b :: k1b -> k2b - -- ty2a :: k1a - -- ty2b :: k1b - -- ty1a ty2a :: k2a - -- ty1b ty2b :: k2b - kind_co1 = mkKindCo co1 -- :: k1a -> k2a ~N k1b -> k2b - kind_co = mkNthCo 1 kind_co1 -- :: k2a ~N k2b - - (_, _, Nominal) - -> ASSERT( r1 == Nominal && r2 == Nominal ) - mkAppCo co1 co2 - (Nominal, Nominal, Representational) - -> mkSubCo (mkAppCo co1 co2) - (_, Nominal, Representational) - -> ASSERT( r1 == Representational ) - mkAppCo co1 co2 - (Nominal, Representational, Representational) - -> go (mkSubCo co1) - (_ , _, Representational) - -> ASSERT( r1 == Representational && r2 == Representational ) - go co1 - where - go co1_repr - | Just (tc1b, tys1b) <- splitTyConApp_maybe ty1b - , nextRole ty1b == r2 - = (mkAppCo co1_repr (mkNomReflCo ty2a)) `mkTransCo` - (mkTyConAppCo Representational tc1b - (zipWith mkReflCo (tyConRolesRepresentational tc1b) tys1b - ++ [co2])) - - | Just (tc1a, tys1a) <- splitTyConApp_maybe ty1a - , nextRole ty1a == r2 - = (mkTyConAppCo Representational tc1a - (zipWith mkReflCo (tyConRolesRepresentational tc1a) tys1a - ++ [co2])) - `mkTransCo` - (mkAppCo co1_repr (mkNomReflCo ty2b)) - - | otherwise - = pprPanic "mkTransAppCo" (vcat [ ppr r1, ppr co1, ppr ty1a, ppr ty1b - , ppr r2, ppr co2, ppr ty2a, ppr ty2b - , ppr r3 ]) - --- | Make a Coercion from a tyvar, a kind coercion, and a body coercion. --- The kind of the tyvar should be the left-hand kind of the kind coercion. -mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion -mkForAllCo tv kind_co co - | Refl r ty <- co - , Refl {} <- kind_co - = Refl r (mkInvForAllTy tv ty) - | otherwise - = ForAllCo tv kind_co co - --- | Make nested ForAllCos -mkForAllCos :: [(TyVar, Coercion)] -> Coercion -> Coercion -mkForAllCos bndrs (Refl r ty) - = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in - foldl (flip $ uncurry ForAllCo) - (Refl r $ mkInvForAllTys (reverse (map fst refls_rev'd)) ty) - non_refls_rev'd -mkForAllCos bndrs co = foldr (uncurry ForAllCo) co bndrs - --- | Make a Coercion quantified over a type variable; --- the variable has the same type in both sides of the coercion -mkHomoForAllCos :: [TyVar] -> Coercion -> Coercion -mkHomoForAllCos tvs (Refl r ty) - = Refl r (mkInvForAllTys tvs ty) -mkHomoForAllCos tvs ty = mkHomoForAllCos_NoRefl tvs ty - --- | Like 'mkHomoForAllCos', but doesn't check if the inner coercion --- is reflexive. -mkHomoForAllCos_NoRefl :: [TyVar] -> Coercion -> Coercion -mkHomoForAllCos_NoRefl tvs orig_co = foldr go orig_co tvs - where - go tv co = ForAllCo tv (mkNomReflCo (tyVarKind tv)) co - -mkCoVarCo :: CoVar -> Coercion --- cv :: s ~# t --- See Note [mkCoVarCo] -mkCoVarCo cv = CoVarCo cv - -mkCoVarCos :: [CoVar] -> [Coercion] -mkCoVarCos = map mkCoVarCo - -{- Note [mkCoVarCo] -~~~~~~~~~~~~~~~~~~~ -In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is -valid (although see Note [Unbound RULE binders] in Rules), but -it's a relatively expensive test and perhaps better done in -optCoercion. Not a big deal either way. --} - --- | Extract a covar, if possible. This check is dirty. Be ashamed --- of yourself. (It's dirty because it cares about the structure of --- a coercion, which is morally reprehensible.) -isCoVar_maybe :: Coercion -> Maybe CoVar -isCoVar_maybe (CoVarCo cv) = Just cv -isCoVar_maybe _ = Nothing - -mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] - -> Coercion --- mkAxInstCo can legitimately be called over-staturated; --- i.e. with more type arguments than the coercion requires -mkAxInstCo role ax index tys cos - | arity == n_tys = downgradeRole role ax_role $ - mkAxiomInstCo ax_br index (rtys `chkAppend` cos) - | otherwise = ASSERT( arity < n_tys ) - downgradeRole role ax_role $ - mkAppCos (mkAxiomInstCo ax_br index - (ax_args `chkAppend` cos)) - leftover_args - where - n_tys = length tys - ax_br = toBranchedAxiom ax - branch = coAxiomNthBranch ax_br index - tvs = coAxBranchTyVars branch - arity = length tvs - arg_roles = coAxBranchRoles branch - rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys - (ax_args, leftover_args) - = splitAt arity rtys - ax_role = coAxiomRole ax - --- worker function; just checks to see if it should produce Refl -mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion -mkAxiomInstCo ax index args - = ASSERT( coAxiomArity ax index == length args ) - AxiomInstCo ax index args - --- to be used only with unbranched axioms -mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched - -> [Type] -> [Coercion] -> Coercion -mkUnbranchedAxInstCo role ax tys cos - = mkAxInstCo role ax 0 tys cos - -mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type --- Instantiate the axiom with specified types, --- returning the instantiated RHS --- A companion to mkAxInstCo: --- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) -mkAxInstRHS ax index tys cos - = ASSERT( tvs `equalLength` tys1 ) - mkAppTys rhs' tys2 - where - branch = coAxiomNthBranch ax index - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - (tys1, tys2) = splitAtList tvs tys - rhs' = substTyWith tvs tys1 $ - substTyWithCoVars cvs cos $ - coAxBranchRHS branch - -mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type -mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 - --- | Return the left-hand type of the axiom, when the axiom is instantiated --- at the types given. -mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type -mkAxInstLHS ax index tys cos - = ASSERT( tvs `equalLength` tys1 ) - mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) - where - branch = coAxiomNthBranch ax index - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - (tys1, tys2) = splitAtList tvs tys - lhs_tys = substTysWith tvs tys1 $ - substTysWithCoVars cvs cos $ - coAxBranchLHS branch - fam_tc = coAxiomTyCon ax - --- | Instantiate the left-hand side of an unbranched axiom -mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type -mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 - --- | Manufacture an unsafe coercion from thin air. --- Currently (May 14) this is used only to implement the --- @unsafeCoerce#@ primitive. Optimise by pushing --- down through type constructors. -mkUnsafeCo :: Role -> Type -> Type -> Coercion -mkUnsafeCo role ty1 ty2 - = mkUnivCo UnsafeCoerceProv role ty1 ty2 - --- | Make a coercion from a coercion hole -mkHoleCo :: CoercionHole -> Role - -> Type -> Type -> Coercion -mkHoleCo h r t1 t2 = mkUnivCo (HoleProv h) r t1 t2 - --- | Make a universal coercion between two arbitrary types. -mkUnivCo :: UnivCoProvenance - -> Role -- ^ role of the built coercion, "r" - -> Type -- ^ t1 :: k1 - -> Type -- ^ t2 :: k2 - -> Coercion -- ^ :: t1 ~r t2 -mkUnivCo prov role ty1 ty2 - | ty1 `eqType` ty2 = Refl role ty1 - | otherwise = UnivCo prov role ty1 ty2 - --- | Create a symmetric version of the given 'Coercion' that asserts --- equality between the same types but in the other "direction", so --- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. -mkSymCo :: Coercion -> Coercion - --- Do a few simple optimizations, but don't bother pushing occurrences --- of symmetry to the leaves; the optimizer will take care of that. -mkSymCo co@(Refl {}) = co -mkSymCo (SymCo co) = co -mkSymCo (SubCo (SymCo co)) = SubCo co -mkSymCo co = SymCo co - --- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. --- (co1 ; co2) -mkTransCo :: Coercion -> Coercion -> Coercion -mkTransCo co1 (Refl {}) = co1 -mkTransCo (Refl {}) co2 = co2 -mkTransCo co1 co2 = TransCo co1 co2 - --- the Role is the desired one. It is the caller's responsibility to make --- sure this request is reasonable -mkNthCoRole :: Role -> Int -> Coercion -> Coercion -mkNthCoRole role n co - = downgradeRole role nth_role $ nth_co - where - nth_co = mkNthCo n co - nth_role = coercionRole nth_co - -mkNthCo :: Int -> Coercion -> Coercion -mkNthCo 0 (Refl _ ty) - | Just (tv, _) <- splitForAllTy_maybe ty - = Refl Nominal (tyVarKind tv) -mkNthCo n (Refl r ty) - = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty ) - mkReflCo r' (tyConAppArgN n ty) - where tc = tyConAppTyCon ty - r' = nthRole r tc n - - ok_tc_app :: Type -> Int -> Bool - ok_tc_app ty n - | Just (_, tys) <- splitTyConApp_maybe ty - = tys `lengthExceeds` n - | isForAllTy ty -- nth:0 pulls out a kind coercion from a hetero forall - = n == 0 - | otherwise - = False - -mkNthCo 0 (ForAllCo _ kind_co _) = kind_co - -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) - -- then (nth 0 co :: k1 ~ k2) - -mkNthCo n co@(FunCo _ arg res) - -- See Note [Function coercions] - -- If FunCo _ arg_co res_co :: (s1:TYPE sk1 -> s2:TYPE sk2) - -- ~ (t1:TYPE tk1 -> t2:TYPE tk2) - -- Then we want to behave as if co was - -- TyConAppCo argk_co resk_co arg_co res_co - -- where - -- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co) - -- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co) - -- i.e. mkRuntimeRepCo - = case n of - 0 -> mkRuntimeRepCo arg - 1 -> mkRuntimeRepCo res - 2 -> arg - 3 -> res - _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co) - -mkNthCo n (TyConAppCo _ _ arg_cos) = arg_cos `getNth` n - -mkNthCo n co = NthCo n co - -mkLRCo :: LeftOrRight -> Coercion -> Coercion -mkLRCo lr (Refl eq ty) = Refl eq (pickLR lr (splitAppTy ty)) -mkLRCo lr co = LRCo lr co - --- | Instantiates a 'Coercion'. -mkInstCo :: Coercion -> Coercion -> Coercion -mkInstCo (ForAllCo tv _kind_co body_co) (Refl _ arg) - = substCoWithUnchecked [tv] [arg] body_co -mkInstCo co arg = InstCo co arg - --- This could work harder to produce Refl coercions, but that would be --- quite inefficient. Seems better not to try. -mkCoherenceCo :: Coercion -> Coercion -> Coercion -mkCoherenceCo co1 (Refl {}) = co1 -mkCoherenceCo (CoherenceCo co1 co2) co3 - = CoherenceCo co1 (co2 `mkTransCo` co3) -mkCoherenceCo co1 co2 = CoherenceCo co1 co2 - --- | A CoherenceCo c1 c2 applies the coercion c2 to the left-hand type --- in the kind of c1. This function uses sym to get the coercion on the --- right-hand type of c1. Thus, if c1 :: s ~ t, then mkCoherenceRightCo c1 c2 --- has the kind (s ~ (t |> c2)) down through type constructors. --- The second coercion must be representational. -mkCoherenceRightCo :: Coercion -> Coercion -> Coercion -mkCoherenceRightCo c1 c2 = mkSymCo (mkCoherenceCo (mkSymCo c1) c2) - --- | An explicitly directed synonym of mkCoherenceCo. The second --- coercion must be representational. -mkCoherenceLeftCo :: Coercion -> Coercion -> Coercion -mkCoherenceLeftCo = mkCoherenceCo - -infixl 5 `mkCoherenceCo` -infixl 5 `mkCoherenceRightCo` -infixl 5 `mkCoherenceLeftCo` - --- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@. -mkKindCo :: Coercion -> Coercion -mkKindCo (Refl _ ty) = Refl Nominal (typeKind ty) -mkKindCo (UnivCo (PhantomProv h) _ _ _) = h -mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h -mkKindCo co - | Pair ty1 ty2 <- coercionKind co - -- generally, calling coercionKind during coercion creation is a bad idea, - -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, - -- so it's OK here. - , let tk1 = typeKind ty1 - tk2 = typeKind ty2 - , tk1 `eqType` tk2 - = Refl Nominal tk1 - | otherwise - = KindCo co - --- input coercion is Nominal; see also Note [Role twiddling functions] -mkSubCo :: Coercion -> Coercion -mkSubCo (Refl Nominal ty) = Refl Representational ty -mkSubCo (TyConAppCo Nominal tc cos) - = TyConAppCo Representational tc (applyRoles tc cos) -mkSubCo (FunCo Nominal arg res) - = FunCo Representational - (downgradeRole Representational Nominal arg) - (downgradeRole Representational Nominal res) -mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) - SubCo co - --- | Changes a role, but only a downgrade. See Note [Role twiddling functions] -downgradeRole_maybe :: Role -- ^ desired role - -> Role -- ^ current role - -> Coercion -> Maybe Coercion --- In (downgradeRole_maybe dr cr co) it's a precondition that --- cr = coercionRole co -downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) -downgradeRole_maybe Nominal Representational _ = Nothing -downgradeRole_maybe Phantom Phantom co = Just co -downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) -downgradeRole_maybe _ Phantom _ = Nothing -downgradeRole_maybe _ _ co = Just co - --- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. --- See Note [Role twiddling functions] -downgradeRole :: Role -- desired role - -> Role -- current role - -> Coercion -> Coercion -downgradeRole r1 r2 co - = case downgradeRole_maybe r1 r2 co of - Just co' -> co' - Nothing -> pprPanic "downgradeRole" (ppr co) - --- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. --- Note that the input coercion should always be nominal. -maybeSubCo :: EqRel -> Coercion -> Coercion -maybeSubCo NomEq = id -maybeSubCo ReprEq = mkSubCo - - -mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion -mkAxiomRuleCo = AxiomRuleCo - --- | Make a "coercion between coercions". -mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" - -> Coercion -- ^ :: phi1 ~N phi2 - -> Coercion -- ^ g1 :: phi1 - -> Coercion -- ^ g2 :: phi2 - -> Coercion -- ^ :: g1 ~r g2 - --- if the two coercion prove the same fact, I just don't care what --- the individual coercions are. -mkProofIrrelCo r (Refl {}) g _ = Refl r (CoercionTy g) -mkProofIrrelCo r kco g1 g2 = mkUnivCo (ProofIrrelProv kco) r - (mkCoercionTy g1) (mkCoercionTy g2) - -{- -%************************************************************************ -%* * - Roles -%* * -%************************************************************************ --} - --- | Converts a coercion to be nominal, if possible. --- See Note [Role twiddling functions] -setNominalRole_maybe :: Coercion -> Maybe Coercion -setNominalRole_maybe co - | Nominal <- coercionRole co = Just co -setNominalRole_maybe (SubCo co) = Just co -setNominalRole_maybe (Refl _ ty) = Just $ Refl Nominal ty -setNominalRole_maybe (TyConAppCo Representational tc cos) - = do { cos' <- mapM setNominalRole_maybe cos - ; return $ TyConAppCo Nominal tc cos' } -setNominalRole_maybe (FunCo Representational co1 co2) - = do { co1' <- setNominalRole_maybe co1 - ; co2' <- setNominalRole_maybe co2 - ; return $ FunCo Nominal co1' co2' - } -setNominalRole_maybe (SymCo co) - = SymCo <$> setNominalRole_maybe co -setNominalRole_maybe (TransCo co1 co2) - = TransCo <$> setNominalRole_maybe co1 <*> setNominalRole_maybe co2 -setNominalRole_maybe (AppCo co1 co2) - = AppCo <$> setNominalRole_maybe co1 <*> pure co2 -setNominalRole_maybe (ForAllCo tv kind_co co) - = ForAllCo tv kind_co <$> setNominalRole_maybe co -setNominalRole_maybe (NthCo n co) - = NthCo n <$> setNominalRole_maybe co -setNominalRole_maybe (InstCo co arg) - = InstCo <$> setNominalRole_maybe co <*> pure arg -setNominalRole_maybe (CoherenceCo co1 co2) - = CoherenceCo <$> setNominalRole_maybe co1 <*> pure co2 -setNominalRole_maybe (UnivCo prov _ co1 co2) - | case prov of UnsafeCoerceProv -> True -- it's always unsafe - PhantomProv _ -> False -- should always be phantom - ProofIrrelProv _ -> True -- it's always safe - PluginProv _ -> False -- who knows? This choice is conservative. - HoleProv _ -> False -- no no no. - = Just $ UnivCo prov Nominal co1 co2 -setNominalRole_maybe _ = Nothing - --- | Make a phantom coercion between two types. The coercion passed --- in must be a nominal coercion between the kinds of the --- types. -mkPhantomCo :: Coercion -> Type -> Type -> Coercion -mkPhantomCo h t1 t2 - = mkUnivCo (PhantomProv h) Phantom t1 t2 - --- | Make a phantom coercion between two types of the same kind. -mkHomoPhantomCo :: Type -> Type -> Coercion -mkHomoPhantomCo t1 t2 - = ASSERT( k1 `eqType` typeKind t2 ) - mkPhantomCo (mkNomReflCo k1) t1 t2 - where - k1 = typeKind t1 - --- takes any coercion and turns it into a Phantom coercion -toPhantomCo :: Coercion -> Coercion -toPhantomCo co - = mkPhantomCo (mkKindCo co) ty1 ty2 - where Pair ty1 ty2 = coercionKind co - --- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational -applyRoles :: TyCon -> [Coercion] -> [Coercion] -applyRoles tc cos - = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos - --- the Role parameter is the Role of the TyConAppCo --- defined here because this is intimiately concerned with the implementation --- of TyConAppCo -tyConRolesX :: Role -> TyCon -> [Role] -tyConRolesX Representational tc = tyConRolesRepresentational tc -tyConRolesX role _ = repeat role - -tyConRolesRepresentational :: TyCon -> [Role] -tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal - -nthRole :: Role -> TyCon -> Int -> Role -nthRole Nominal _ _ = Nominal -nthRole Phantom _ _ = Phantom -nthRole Representational tc n - = (tyConRolesRepresentational tc) `getNth` n - -ltRole :: Role -> Role -> Bool --- Is one role "less" than another? --- Nominal < Representational < Phantom -ltRole Phantom _ = False -ltRole Representational Phantom = True -ltRole Representational _ = False -ltRole Nominal Nominal = False -ltRole Nominal _ = True - -------------------------------- - --- | like mkKindCo, but aggressively & recursively optimizes to avoid using --- a KindCo constructor. The output role is nominal. -promoteCoercion :: Coercion -> Coercion - --- First cases handles anything that should yield refl. -promoteCoercion co = case co of - - _ | ki1 `eqType` ki2 - -> mkNomReflCo (typeKind ty1) - -- no later branch should return refl - -- The ASSERT( False )s throughout - -- are these cases explicitly, but they should never fire. - - Refl _ ty -> ASSERT( False ) - mkNomReflCo (typeKind ty) - - TyConAppCo _ tc args - | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args - -> co' - | otherwise - -> mkKindCo co - - AppCo co1 arg - | Just co' <- instCoercion (coercionKind (mkKindCo co1)) - (promoteCoercion co1) arg - -> co' - | otherwise - -> mkKindCo co - - ForAllCo _ _ g - -> promoteCoercion g - - FunCo _ _ _ - -> mkNomReflCo liftedTypeKind - - CoVarCo {} - -> mkKindCo co - - AxiomInstCo {} - -> mkKindCo co - - UnivCo UnsafeCoerceProv _ t1 t2 - -> mkUnsafeCo Nominal (typeKind t1) (typeKind t2) - UnivCo (PhantomProv kco) _ _ _ - -> kco - UnivCo (ProofIrrelProv kco) _ _ _ - -> kco - UnivCo (PluginProv _) _ _ _ - -> mkKindCo co - UnivCo (HoleProv _) _ _ _ - -> mkKindCo co - - SymCo g - -> mkSymCo (promoteCoercion g) - - TransCo co1 co2 - -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) - - NthCo n co1 - | Just (_, args) <- splitTyConAppCo_maybe co1 - , n < length args - -> promoteCoercion (args !! n) - - | Just _ <- splitForAllCo_maybe co - , n == 0 - -> ASSERT( False ) mkNomReflCo liftedTypeKind - - | otherwise - -> mkKindCo co - - LRCo lr co1 - | Just (lco, rco) <- splitAppCo_maybe co1 - -> case lr of - CLeft -> promoteCoercion lco - CRight -> promoteCoercion rco - - | otherwise - -> mkKindCo co - - InstCo g _ - -> promoteCoercion g - - CoherenceCo g h - -> mkSymCo h `mkTransCo` promoteCoercion g - - KindCo _ - -> ASSERT( False ) - mkNomReflCo liftedTypeKind - - SubCo g - -> promoteCoercion g - - AxiomRuleCo {} - -> mkKindCo co - - where - Pair ty1 ty2 = coercionKind co - ki1 = typeKind ty1 - ki2 = typeKind ty2 - --- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, --- where @g' = promoteCoercion (h w)@. --- fails if this is not possible, if @g@ coerces between a forall and an -> --- or if second parameter has a representational role and can't be used --- with an InstCo. The result role matches is representational. -instCoercion :: Pair Type -- type of the first coercion - -> Coercion -- ^ must be nominal - -> Coercion - -> Maybe Coercion -instCoercion (Pair lty rty) g w - | isForAllTy lty && isForAllTy rty - , Just w' <- setNominalRole_maybe w - = Just $ mkInstCo g w' - | isFunTy lty && isFunTy rty - = Just $ mkNthCo 3 g -- extract result type, which is the 4th argument to (->) - | otherwise -- one forall, one funty... - = Nothing - where - -instCoercions :: Coercion -> [Coercion] -> Maybe Coercion -instCoercions g ws - = let arg_ty_pairs = map coercionKind ws in - snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) - where - go :: (Pair Type, Coercion) -> (Pair Type, Coercion) - -> Maybe (Pair Type, Coercion) - go (g_tys, g) (w_tys, w) - = do { g' <- instCoercion g_tys g w - ; return (piResultTy <$> g_tys <*> w_tys, g') } - --- | Creates a new coercion with both of its types casted by different casts --- castCoercionKind g h1 h2, where g :: t1 ~ t2, has type (t1 |> h1) ~ (t2 |> h2) --- The second and third coercions must be nominal. -castCoercionKind :: Coercion -> Coercion -> Coercion -> Coercion -castCoercionKind g h1 h2 - = g `mkCoherenceLeftCo` h1 `mkCoherenceRightCo` h2 - --- See note [Newtype coercions] in TyCon - -mkPiCos :: Role -> [Var] -> Coercion -> Coercion -mkPiCos r vs co = foldr (mkPiCo r) co vs - --- | Make a forall 'Coercion', where both types related by the coercion --- are quantified over the same type variable. -mkPiCo :: Role -> Var -> Coercion -> Coercion -mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co - | otherwise = mkFunCo r (mkReflCo r (varType v)) co - --- The second coercion is sometimes lifted (~) and sometimes unlifted (~#). --- So, we have to make sure to supply the right parameter to decomposeCo. --- mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# s2) ~# (t1 ~# t2)) :: s2 ~# t2 --- Both coercions *must* have the same role. -mkCoCast :: Coercion -> Coercion -> Coercion -mkCoCast c g - = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 - where - -- g :: (s1 ~# s2) ~# (t1 ~# t2) - -- g1 :: s1 ~# t1 - -- g2 :: s2 ~# t2 - (_, args) = splitTyConApp (pFst $ coercionKind g) - n_args = length args - co_list = decomposeCo n_args g - g1 = co_list `getNth` (n_args - 2) - g2 = co_list `getNth` (n_args - 1) - -{- -%************************************************************************ -%* * - Newtypes -%* * -%************************************************************************ --} - --- | If @co :: T ts ~ rep_ty@ then: --- --- > instNewTyCon_maybe T ts = Just (rep_ty, co) --- --- Checks for a newtype, and for being saturated -instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) -instNewTyCon_maybe tc tys - | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype - , tvs `leLength` tys -- Check saturated enough - = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) - | otherwise - = Nothing - -{- -************************************************************************ -* * - Type normalisation -* * -************************************************************************ --} - --- | A function to check if we can reduce a type by one step. Used --- with 'topNormaliseTypeX'. -type NormaliseStepper ev = RecTcChecker - -> TyCon -- tc - -> [Type] -- tys - -> NormaliseStepResult ev - --- | The result of stepping in a normalisation function. --- See 'topNormaliseTypeX'. -data NormaliseStepResult ev - = NS_Done -- ^ Nothing more to do - | NS_Abort -- ^ Utter failure. The outer function should fail too. - | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; - -- ^ ev is evidence; - -- Usually a co :: old type ~ new type - -mapStepResult :: (ev1 -> ev2) - -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 -mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) -mapStepResult _ NS_Done = NS_Done -mapStepResult _ NS_Abort = NS_Abort - --- | Try one stepper and then try the next, if the first doesn't make --- progress. --- So if it returns NS_Done, it means that both steppers are satisfied -composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev - -> NormaliseStepper ev -composeSteppers step1 step2 rec_nts tc tys - = case step1 rec_nts tc tys of - success@(NS_Step {}) -> success - NS_Done -> step2 rec_nts tc tys - NS_Abort -> NS_Abort - --- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into --- a loop. If it would fall into a loop, it produces 'NS_Abort'. -unwrapNewTypeStepper :: NormaliseStepper Coercion -unwrapNewTypeStepper rec_nts tc tys - | Just (ty', co) <- instNewTyCon_maybe tc tys - = case checkRecTc rec_nts tc of - Just rec_nts' -> NS_Step rec_nts' ty' co - Nothing -> NS_Abort - - | otherwise - = NS_Done - --- | A general function for normalising the top-level of a type. It continues --- to use the provided 'NormaliseStepper' until that function fails, and then --- this function returns. The roles of the coercions produced by the --- 'NormaliseStepper' must all be the same, which is the role returned from --- the call to 'topNormaliseTypeX'. --- --- Typically ev is Coercion. --- --- If topNormaliseTypeX step plus ty = Just (ev, ty') --- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty' --- and ev = ev1 `plus` ev2 `plus` ... `plus` evn --- If it returns Nothing then no newtype unwrapping could happen -topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev) - -> Type -> Maybe (ev, Type) -topNormaliseTypeX stepper plus ty - | Just (tc, tys) <- splitTyConApp_maybe ty - , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys - = go rec_nts ev ty' - | otherwise - = Nothing - where - go rec_nts ev ty - | Just (tc, tys) <- splitTyConApp_maybe ty - = case stepper rec_nts tc tys of - NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty' - NS_Done -> Just (ev, ty) - NS_Abort -> Nothing - - | otherwise - = Just (ev, ty) - -topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) --- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. --- This function strips off @newtype@ layers enough to reveal something that isn't --- a @newtype@. Specifically, here's the invariant: --- --- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') --- --- then (a) @co : ty0 ~ ty'@. --- (b) ty' is not a newtype. --- --- The function returns @Nothing@ for non-@newtypes@, --- or unsaturated applications --- --- This function does *not* look through type families, because it has no access to --- the type family environment. If you do have that at hand, consider to use --- topNormaliseType_maybe, which should be a drop-in replacement for --- topNormaliseNewType_maybe --- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty' -topNormaliseNewType_maybe ty - = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty - -{- -%************************************************************************ -%* * - Comparison of coercions -%* * -%************************************************************************ --} - --- | Syntactic equality of coercions -eqCoercion :: Coercion -> Coercion -> Bool -eqCoercion = eqType `on` coercionType - --- | Compare two 'Coercion's, with respect to an RnEnv2 -eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool -eqCoercionX env = eqTypeX env `on` coercionType - -{- -%************************************************************************ -%* * - "Lifting" substitution - [(TyCoVar,Coercion)] -> Type -> Coercion -%* * -%************************************************************************ - -Note [Lifting coercions over types: liftCoSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The KPUSH rule deals with this situation - data T a = MkK (a -> Maybe a) - g :: T t1 ~ K t2 - x :: t1 -> Maybe t1 - - case (K @t1 x) |> g of - K (y:t2 -> Maybe t2) -> rhs - -We want to push the coercion inside the constructor application. -So we do this - - g' :: t1~t2 = Nth 0 g - - case K @t2 (x |> g' -> Maybe g') of - K (y:t2 -> Maybe t2) -> rhs - -The crucial operation is that we - * take the type of K's argument: a -> Maybe a - * and substitute g' for a -thus giving *coercion*. This is what liftCoSubst does. - -In the presence of kind coercions, this is a bit -of a hairy operation. So, we refer you to the paper introducing kind coercions, -available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf --} - --- ---------------------------------------------------- --- See Note [Lifting coercions over types: liftCoSubst] --- ---------------------------------------------------- - -data LiftingContext = LC TCvSubst LiftCoEnv - -- in optCoercion, we need to lift when optimizing InstCo. - -- See Note [Optimising InstCo] in OptCoercion - -- We thus propagate the substitution from OptCoercion here. - -instance Outputable LiftingContext where - ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) - -type LiftCoEnv = VarEnv Coercion - -- Maps *type variables* to *coercions*. - -- That's the whole point of this function! - --- like liftCoSubstWith, but allows for existentially-bound types as well -liftCoSubstWithEx :: Role -- desired role for output coercion - -> [TyVar] -- universally quantified tyvars - -> [Coercion] -- coercions to substitute for those - -> [TyVar] -- existentially quantified tyvars - -> [Type] -- types to be bound to ex vars - -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args) -liftCoSubstWithEx role univs omegas exs rhos - = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas) - psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos) - in (ty_co_subst psi role, substTyVars (lcSubstRight psi) exs) - -liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion --- NB: This really can be called with CoVars, when optimising axioms. -liftCoSubstWith r tvs cos ty - = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty - --- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) --- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where --- @lc_left@ is a substitution mapping type variables to the left-hand --- types of the mapped coercions in @lc@, and similar for @lc_right@. -liftCoSubst :: Role -> LiftingContext -> Type -> Coercion -liftCoSubst r lc@(LC subst env) ty - | isEmptyVarEnv env = Refl r (substTy subst ty) - | otherwise = ty_co_subst lc r ty - -emptyLiftingContext :: InScopeSet -> LiftingContext -emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv - -mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext -mkLiftingContext pairs - = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) - (mkVarEnv pairs) - -mkSubstLiftingContext :: TCvSubst -> LiftingContext -mkSubstLiftingContext subst = LC subst emptyVarEnv - --- | Extend a lifting context with a new /type/ mapping. -extendLiftingContext :: LiftingContext -- ^ original LC - -> TyVar -- ^ new variable to map... - -> Coercion -- ^ ...to this lifted version - -> LiftingContext -extendLiftingContext (LC subst env) tv arg - = ASSERT( isTyVar tv ) - LC subst (extendVarEnv env tv arg) - --- | Extend a lifting context with existential-variable bindings. --- This follows the lifting context extension definition in the --- "FC with Explicit Kind Equality" paper. -extendLiftingContextEx :: LiftingContext -- ^ original lifting context - -> [(TyVar,Type)] -- ^ ex. var / value pairs - -> LiftingContext --- Note that this is more involved than extendLiftingContext. That function --- takes a coercion to extend with, so it's assumed that the caller has taken --- into account any of the kind-changing stuff worried about here. -extendLiftingContextEx lc [] = lc -extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) --- This function adds bindings for *Nominal* coercions. Why? Because it --- works with existentially bound variables, which are considered to have --- nominal roles. - = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) - (extendVarEnv env v (mkSymCo $ mkCoherenceCo - (mkNomReflCo ty) - (ty_co_subst lc Nominal (tyVarKind v)))) - in extendLiftingContextEx lc' rest - --- | Erase the environments in a lifting context -zapLiftingContext :: LiftingContext -> LiftingContext -zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv - --- | Like 'substForAllCoBndr', but works on a lifting context -substForAllCoBndrCallbackLC :: Bool - -> (Coercion -> Coercion) - -> LiftingContext -> TyVar -> Coercion - -> (LiftingContext, TyVar, Coercion) -substForAllCoBndrCallbackLC sym sco (LC subst lc_env) tv co - = (LC subst' lc_env, tv', co') - where - (subst', tv', co') = substForAllCoBndrCallback sym sco subst tv co - --- | The \"lifting\" operation which substitutes coercions for type --- variables in a type to produce a coercion. --- --- For the inverse operation, see 'liftCoMatch' -ty_co_subst :: LiftingContext -> Role -> Type -> Coercion -ty_co_subst lc role ty - = go role ty - where - go :: Role -> Type -> Coercion - go Phantom ty = lift_phantom ty - go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ - liftCoSubstTyVar lc r tv - go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) - go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) - go r (FunTy ty1 ty2) = mkFunCo r (go r ty1) (go r ty2) - go r (ForAllTy (TvBndr v _) ty) - = let (lc', v', h) = liftCoSubstVarBndr lc v in - mkForAllCo v' h $! ty_co_subst lc' r ty - go r ty@(LitTy {}) = ASSERT( r == Nominal ) - mkReflCo r ty - go r (CastTy ty co) = castCoercionKind (go r ty) (substLeftCo lc co) - (substRightCo lc co) - go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) - (substRightCo lc co) - where kco = go Nominal (coercionType co) - - lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) - (substTy (lcSubstLeft lc) ty) - (substTy (lcSubstRight lc) ty) - -{- -Note [liftCoSubstTyVar] -~~~~~~~~~~~~~~~~~~~~~~~~~ -This function can fail if a coercion in the environment is of too low a role. - -liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and -also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting -lemma guarantees that the roles work out. If we fail in this -case, we really should panic -- something is deeply wrong. But, in matchAxiom, -failing is fine. matchAxiom is trying to find a set of coercions -that match, but it may fail, and this is healthy behavior. --} - --- See Note [liftCoSubstTyVar] -liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion -liftCoSubstTyVar (LC subst env) r v - | Just co_arg <- lookupVarEnv env v - = downgradeRole_maybe r (coercionRole co_arg) co_arg - - | otherwise - = Just $ Refl r (substTyVar subst v) - -liftCoSubstVarBndr :: LiftingContext -> TyVar - -> (LiftingContext, TyVar, Coercion) -liftCoSubstVarBndr lc tv - = let (lc', tv', h, _) = liftCoSubstVarBndrCallback callback lc tv in - (lc', tv', h) - where - callback lc' ty' = (ty_co_subst lc' Nominal ty', ()) - --- the callback must produce a nominal coercion -liftCoSubstVarBndrCallback :: (LiftingContext -> Type -> (Coercion, a)) - -> LiftingContext -> TyVar - -> (LiftingContext, TyVar, Coercion, a) -liftCoSubstVarBndrCallback fun lc@(LC subst cenv) old_var - = ( LC (subst `extendTCvInScope` new_var) new_cenv - , new_var, eta, stuff ) - where - old_kind = tyVarKind old_var - (eta, stuff) = fun lc old_kind - Pair k1 _ = coercionKind eta - new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) - - lifted = Refl Nominal (TyVarTy new_var) - new_cenv = extendVarEnv cenv old_var lifted - --- | Is a var in the domain of a lifting context? -isMappedByLC :: TyCoVar -> LiftingContext -> Bool -isMappedByLC tv (LC _ env) = tv `elemVarEnv` env - --- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 --- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 -substLeftCo :: LiftingContext -> Coercion -> Coercion -substLeftCo lc co - = substCo (lcSubstLeft lc) co - --- Ditto, but for t2 and g2 -substRightCo :: LiftingContext -> Coercion -> Coercion -substRightCo lc co - = substCo (lcSubstRight lc) co - --- | Apply "sym" to all coercions in a 'LiftCoEnv' -swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv -swapLiftCoEnv = mapVarEnv mkSymCo - -lcSubstLeft :: LiftingContext -> TCvSubst -lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env - -lcSubstRight :: LiftingContext -> TCvSubst -lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env - -liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst -liftEnvSubstLeft = liftEnvSubst pFst - -liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst -liftEnvSubstRight = liftEnvSubst pSnd - -liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst -liftEnvSubst selector subst lc_env - = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst - where - pairs = nonDetUFMToList lc_env - -- It's OK to use nonDetUFMToList here because we - -- immediately forget the ordering by creating - -- a VarEnv - (tpairs, cpairs) = partitionWith ty_or_co pairs - tenv = mkVarEnv_Directly tpairs - cenv = mkVarEnv_Directly cpairs - - ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) - ty_or_co (u, co) - | Just equality_co <- isCoercionTy_maybe equality_ty - = Right (u, equality_co) - | otherwise - = Left (u, equality_ty) - where - equality_ty = selector (coercionKind co) - --- | Extract the underlying substitution from the LiftingContext -lcTCvSubst :: LiftingContext -> TCvSubst -lcTCvSubst (LC subst _) = subst - --- | Get the 'InScopeSet' from a 'LiftingContext' -lcInScopeSet :: LiftingContext -> InScopeSet -lcInScopeSet (LC subst _) = getTCvInScope subst - -{- -%************************************************************************ -%* * - Sequencing on coercions -%* * -%************************************************************************ --} - -seqCo :: Coercion -> () -seqCo (Refl r ty) = r `seq` seqType ty -seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos -seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (ForAllCo tv k co) = seqType (tyVarKind tv) `seq` seqCo k - `seq` seqCo co -seqCo (FunCo r co1 co2) = r `seq` seqCo co1 `seq` seqCo co2 -seqCo (CoVarCo cv) = cv `seq` () -seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos -seqCo (UnivCo p r t1 t2) - = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 -seqCo (SymCo co) = seqCo co -seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (NthCo n co) = n `seq` seqCo co -seqCo (LRCo lr co) = lr `seq` seqCo co -seqCo (InstCo co arg) = seqCo co `seq` seqCo arg -seqCo (CoherenceCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (KindCo co) = seqCo co -seqCo (SubCo co) = seqCo co -seqCo (AxiomRuleCo _ cs) = seqCos cs - -seqProv :: UnivCoProvenance -> () -seqProv UnsafeCoerceProv = () -seqProv (PhantomProv co) = seqCo co -seqProv (ProofIrrelProv co) = seqCo co -seqProv (PluginProv _) = () -seqProv (HoleProv _) = () - -seqCos :: [Coercion] -> () -seqCos [] = () -seqCos (co:cos) = seqCo co `seq` seqCos cos - -{- -%************************************************************************ -%* * - The kind of a type, and of a coercion -%* * -%************************************************************************ - -Note [Computing a coercion kind and role] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To compute a coercion's kind is straightforward: see coercionKind. -But to compute a coercion's role, in the case for NthCo we need -its kind as well. So if we have two separate functions (one for kinds -and one for roles) we can get exponentially bad behaviour, since each -NthCo node makes a separate call to coercionKind, which traverses the -sub-tree again. This was part of the problem in Trac #9233. - -Solution: compute both together; hence coercionKindRole. We keep a -separate coercionKind function because it's a bit more efficient if -the kind is all you want. --} - -coercionType :: Coercion -> Type -coercionType co = case coercionKindRole co of - (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 - ------------------- --- | If it is the case that --- --- > c :: (t1 ~ t2) --- --- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. - -coercionKind :: Coercion -> Pair Type -coercionKind co = go co - where - go (Refl _ ty) = Pair ty ty - go (TyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos) - go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 - go (ForAllCo tv1 k_co co) - = let Pair _ k2 = go k_co - tv2 = setTyVarKind tv1 k2 - Pair ty1 ty2 = go co - subst = zipTvSubst [tv1] [TyVarTy tv2 `mk_cast_ty` mkSymCo k_co] - ty2' = substTyAddInScope subst ty2 in - -- We need free vars of ty2 in scope to satisfy the invariant - -- from Note [The substitution invariant] - -- This is doing repeated substitutions and probably doesn't - -- need to, see #11735 - mkInvForAllTy <$> Pair tv1 tv2 <*> Pair ty1 ty2' - go (FunCo _ co1 co2) = mkFunTy <$> go co1 <*> go co2 - go (CoVarCo cv) = coVarTypes cv - go (AxiomInstCo ax ind cos) - | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind - , let Pair tycos1 tycos2 = sequenceA (map go cos) - (tys1, cotys1) = splitAtList tvs tycos1 - (tys2, cotys2) = splitAtList tvs tycos2 - cos1 = map stripCoercionTy cotys1 - cos2 = map stripCoercionTy cotys2 - = ASSERT( cos `equalLength` (tvs ++ cvs) ) - -- Invariant of AxiomInstCo: cos should - -- exactly saturate the axiom branch - Pair (substTyWith tvs tys1 $ - substTyWithCoVars cvs cos1 $ - mkTyConApp (coAxiomTyCon ax) lhs) - (substTyWith tvs tys2 $ - substTyWithCoVars cvs cos2 rhs) - go (UnivCo _ _ ty1 ty2) = Pair ty1 ty2 - go (SymCo co) = swap $ go co - go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) - go g@(NthCo d co) - | Just argss <- traverse tyConAppArgs_maybe tys - = ASSERT( and $ ((d <) . length) <$> argss ) - (`getNth` d) <$> argss - - | d == 0 - , Just splits <- traverse splitForAllTy_maybe tys - = (tyVarKind . fst) <$> splits - - | otherwise - = pprPanic "coercionKind" (ppr g) - where - tys = go co - go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co - go (InstCo aco arg) = go_app aco [arg] - go (CoherenceCo g h) - = let Pair ty1 ty2 = go g in - Pair (mkCastTy ty1 h) ty2 - go (KindCo co) = typeKind <$> go co - go (SubCo co) = go co - go (AxiomRuleCo ax cos) = expectJust "coercionKind" $ - coaxrProves ax (map go cos) - - go_app :: Coercion -> [Coercion] -> Pair Type - -- Collect up all the arguments and apply all at once - -- See Note [Nested InstCos] - go_app (InstCo co arg) args = go_app co (arg:args) - go_app co args = piResultTys <$> go co <*> (sequenceA $ map go args) - - -- The real mkCastTy is too slow, and we can easily have nested ForAllCos. - mk_cast_ty :: Type -> Coercion -> Type - mk_cast_ty ty (Refl {}) = ty - mk_cast_ty ty co = CastTy ty co - --- | Apply 'coercionKind' to multiple 'Coercion's -coercionKinds :: [Coercion] -> Pair [Type] -coercionKinds tys = sequenceA $ map coercionKind tys - --- | Get a coercion's kind and role. --- Why both at once? See Note [Computing a coercion kind and role] -coercionKindRole :: Coercion -> (Pair Type, Role) -coercionKindRole = go - where - go (Refl r ty) = (Pair ty ty, r) - go (TyConAppCo r tc cos) - = (mkTyConApp tc <$> (sequenceA $ map coercionKind cos), r) - go (AppCo co1 co2) - = let (tys1, r1) = go co1 in - (mkAppTy <$> tys1 <*> coercionKind co2, r1) - go (ForAllCo tv1 k_co co) - = let Pair _ k2 = coercionKind k_co - tv2 = setTyVarKind tv1 k2 - (Pair ty1 ty2, r) = go co - subst = zipTvSubst [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo k_co] - ty2' = substTyAddInScope subst ty2 in - -- We need free vars of ty2 in scope to satisfy the invariant - -- from Note [The substitution invariant] - -- This is doing repeated substitutions and probably doesn't - -- need to, see #11735 - (mkInvForAllTy <$> Pair tv1 tv2 <*> Pair ty1 ty2', r) - go (FunCo r co1 co2) - = (mkFunTy <$> coercionKind co1 <*> coercionKind co2, r) - go (CoVarCo cv) = (coVarTypes cv, coVarRole cv) - go co@(AxiomInstCo ax _ _) = (coercionKind co, coAxiomRole ax) - go (UnivCo _ r ty1 ty2) = (Pair ty1 ty2, r) - go (SymCo co) = first swap $ go co - go (TransCo co1 co2) - = let (tys1, r) = go co1 in - (Pair (pFst tys1) (pSnd $ coercionKind co2), r) - go (NthCo d co) - | Just (tv1, _) <- splitForAllTy_maybe ty1 - = ASSERT( d == 0 ) - let (tv2, _) = splitForAllTy ty2 in - (tyVarKind <$> Pair tv1 tv2, Nominal) - - | otherwise - = let (tc1, args1) = splitTyConApp ty1 - (_tc2, args2) = splitTyConApp ty2 - in - ASSERT2( tc1 == _tc2, ppr d $$ ppr tc1 $$ ppr _tc2 ) - ((`getNth` d) <$> Pair args1 args2, nthRole r tc1 d) - - where - (Pair ty1 ty2, r) = go co - go co@(LRCo {}) = (coercionKind co, Nominal) - go (InstCo co arg) = go_app co [arg] - go (CoherenceCo co1 co2) - = let (Pair t1 t2, r) = go co1 in - (Pair (t1 `mkCastTy` co2) t2, r) - go co@(KindCo {}) = (coercionKind co, Nominal) - go (SubCo co) = (coercionKind co, Representational) - go co@(AxiomRuleCo ax _) = (coercionKind co, coaxrRole ax) - - go_app :: Coercion -> [Coercion] -> (Pair Type, Role) - -- Collect up all the arguments and apply all at once - -- See Note [Nested InstCos] - go_app (InstCo co arg) args = go_app co (arg:args) - go_app co args - = let (pair, r) = go co in - (piResultTys <$> pair <*> (sequenceA $ map coercionKind args), r) - --- | Retrieve the role from a coercion. -coercionRole :: Coercion -> Role -coercionRole = snd . coercionKindRole - -- There's not a better way to do this, because NthCo needs the *kind* - -- and role of its argument. Luckily, laziness should generally avoid - -- the need for computing kinds in other cases. - -{- -Note [Nested InstCos] -~~~~~~~~~~~~~~~~~~~~~ -In Trac #5631 we found that 70% of the entire compilation time was -being spent in coercionKind! The reason was that we had - (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos -where - g :: forall a1 a2 .. a100. phi -If we deal with the InstCos one at a time, we'll do this: - 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' - 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst -But this is a *quadratic* algorithm, and the blew up Trac #5631. -So it's very important to do the substitution simultaneously; -cf Type.piResultTys (which in fact we call here). - --} diff --git a/types/Coercion.hs-boot b/types/Coercion.hs-boot deleted file mode 100644 --- a/types/Coercion.hs-boot +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Coercion where - -import {-# SOURCE #-} TyCoRep -import {-# SOURCE #-} TyCon - -import BasicTypes ( LeftOrRight ) -import CoAxiom -import Var -import Outputable -import Pair -import Util - -mkReflCo :: Role -> Type -> Coercion -mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion -mkAppCo :: Coercion -> Coercion -> Coercion -mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion -mkFunCo :: Role -> Coercion -> Coercion -> Coercion -mkCoVarCo :: CoVar -> Coercion -mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion -mkPhantomCo :: Coercion -> Type -> Type -> Coercion -mkUnsafeCo :: Role -> Type -> Type -> Coercion -mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion -mkSymCo :: Coercion -> Coercion -mkTransCo :: Coercion -> Coercion -> Coercion -mkNthCo :: Int -> Coercion -> Coercion -mkLRCo :: LeftOrRight -> Coercion -> Coercion -mkInstCo :: Coercion -> Coercion -> Coercion -mkCoherenceCo :: Coercion -> Coercion -> Coercion -mkKindCo :: Coercion -> Coercion -mkSubCo :: Coercion -> Coercion -mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion - -mkFunCos :: Role -> [Coercion] -> Coercion -> Coercion - -isReflCo :: Coercion -> Bool -isReflexiveCo :: Coercion -> Bool -coVarKindsTypesRole :: CoVar -> (Kind, Kind, Type, Type, Role) -coVarRole :: CoVar -> Role - -mkCoercionType :: Role -> Type -> Type -> Type - -data LiftingContext -liftCoSubst :: Role -> LiftingContext -> Type -> Coercion -seqCo :: Coercion -> () - -coercionKind :: Coercion -> Pair Type -coercionType :: Coercion -> Type - -pprCo :: Coercion -> SDoc diff --git a/types/FamInstEnv.hs b/types/FamInstEnv.hs deleted file mode 100644 --- a/types/FamInstEnv.hs +++ /dev/null @@ -1,1724 +0,0 @@ --- (c) The University of Glasgow 2006 --- --- FamInstEnv: Type checked family instance declarations - -{-# LANGUAGE CPP, GADTs, ScopedTypeVariables #-} - -module FamInstEnv ( - FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, - famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, - pprFamInst, pprFamInsts, - mkImportedFamInst, - - FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, - extendFamInstEnv, extendFamInstEnvList, - famInstEnvElts, famInstEnvSize, familyInstances, - - -- * CoAxioms - mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, - mkNewTypeCoAxiom, - - FamInstMatch(..), - lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, - - isDominatedBy, apartnessCheck, - - -- Injectivity - InjectivityCheckResult(..), - lookupFamInstEnvInjectivityConflicts, injectiveBranches, - - -- Normalisation - topNormaliseType, topNormaliseType_maybe, - normaliseType, normaliseTcApp, - reduceTyFamApp_maybe, - pmTopNormaliseType_maybe, - - -- Flattening - flattenTys - ) where - -#include "HsVersions.h" - -import Unify -import Type -import TyCoRep -import TyCon -import DataCon (DataCon) -import Coercion -import CoAxiom -import VarSet -import VarEnv -import Name -import PrelNames ( eqPrimTyConKey ) -import UniqDFM -import Outputable -import Maybes -import TrieMap -import Unique -import Util -import Var -import Pair -import SrcLoc -import FastString -import MonadUtils -import Control.Monad -import Data.List( mapAccumL, find ) - -{- -************************************************************************ -* * - Type checked family instance heads -* * -************************************************************************ - -Note [FamInsts and CoAxioms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* CoAxioms and FamInsts are just like - DFunIds and ClsInsts - -* A CoAxiom is a System-FC thing: it can relate any two types - -* A FamInst is a Haskell source-language thing, corresponding - to a type/data family instance declaration. - - The FamInst contains a CoAxiom, which is the evidence - for the instance - - - The LHS of the CoAxiom is always of form F ty1 .. tyn - where F is a type family --} - -data FamInst -- See Note [FamInsts and CoAxioms] - = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom - -- introduced by this family - -- instance - -- INVARIANT: apart from freshening (see below) - -- fi_tvs = cab_tvs of the (single) axiom branch - -- fi_cvs = cab_cvs ...ditto... - -- fi_tys = cab_lhs ...ditto... - -- fi_rhs = cab_rhs ...ditto... - - , fi_flavor :: FamFlavor - - -- Everything below here is a redundant, - -- cached version of the two things above - -- except that the TyVars are freshened - , fi_fam :: Name -- Family name - - -- Used for "rough matching"; same idea as for class instances - -- See Note [Rough-match field] in InstEnv - , fi_tcs :: [Maybe Name] -- Top of type args - -- INVARIANT: fi_tcs = roughMatchTcs fi_tys - - -- Used for "proper matching"; ditto - , fi_tvs :: [TyVar] -- Template tyvars for full match - , fi_cvs :: [CoVar] -- Template covars for full match - -- Like ClsInsts, these variables are always fresh - -- See Note [Template tyvars are fresh] in InstEnv - - , fi_tys :: [Type] -- The LHS type patterns - -- May be eta-reduced; see Note [Eta reduction for data families] - - , fi_rhs :: Type -- the RHS, with its freshened vars - } - -data FamFlavor - = SynFamilyInst -- A synonym family - | DataFamilyInst TyCon -- A data family, with its representation TyCon - -{- Note [Eta reduction for data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - data family T a b :: * - newtype instance T Int a = MkT (IO a) deriving( Monad ) -We'd like this to work. - -From the 'newtype instance' you might think we'd get: - newtype TInt a = MkT (IO a) - axiom ax1 a :: T Int a ~ TInt a -- The newtype-instance part - axiom ax2 a :: TInt a ~ IO a -- The newtype part - -But now what can we do? We have this problem - Given: d :: Monad IO - Wanted: d' :: Monad (T Int) = d |> ???? -What coercion can we use for the ??? - -Solution: eta-reduce both axioms, thus: - axiom ax1 :: T Int ~ TInt - axiom ax2 :: TInt ~ IO -Now - d' = d |> Monad (sym (ax2 ; ax1)) - -This eta reduction happens for data instances as well as newtype -instances. Here we want to eta-reduce the data family axiom. -All this is done in TcInstDcls.tcDataFamInstDecl. - -See also Note [Newtype eta] in TyCon. - -Bottom line: - For a FamInst with fi_flavour = DataFamilyInst rep_tc, - - fi_tvs may be shorter than tyConTyVars of rep_tc - - fi_tys may be shorter than tyConArity of the family tycon - i.e. LHS is unsaturated - - fi_rhs will be (rep_tc fi_tvs) - i.e. RHS is un-saturated - - But when fi_flavour = SynFamilyInst, - - fi_tys has the exact arity of the family tycon --} - --- Obtain the axiom of a family instance -famInstAxiom :: FamInst -> CoAxiom Unbranched -famInstAxiom = fi_axiom - --- Split the left-hand side of the FamInst -famInstSplitLHS :: FamInst -> (TyCon, [Type]) -famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) - = (coAxiomTyCon axiom, lhs) - --- Get the RHS of the FamInst -famInstRHS :: FamInst -> Type -famInstRHS = fi_rhs - --- Get the family TyCon of the FamInst -famInstTyCon :: FamInst -> TyCon -famInstTyCon = coAxiomTyCon . famInstAxiom - --- Return the representation TyCons introduced by data family instances, if any -famInstsRepTyCons :: [FamInst] -> [TyCon] -famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] - --- Extracts the TyCon for this *data* (or newtype) instance -famInstRepTyCon_maybe :: FamInst -> Maybe TyCon -famInstRepTyCon_maybe fi - = case fi_flavor fi of - DataFamilyInst tycon -> Just tycon - SynFamilyInst -> Nothing - -dataFamInstRepTyCon :: FamInst -> TyCon -dataFamInstRepTyCon fi - = case fi_flavor fi of - DataFamilyInst tycon -> tycon - SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) - -{- -************************************************************************ -* * - Pretty printing -* * -************************************************************************ --} - -instance NamedThing FamInst where - getName = coAxiomName . fi_axiom - -instance Outputable FamInst where - ppr = pprFamInst - --- Prints the FamInst as a family instance declaration --- NB: FamInstEnv.pprFamInst is used only for internal, debug printing --- See pprTyThing.pprFamInst for printing for the user -pprFamInst :: FamInst -> SDoc -pprFamInst famInst - = hang (pprFamInstHdr famInst) 2 (ifPprDebug debug_stuff) - where - ax = fi_axiom famInst - debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax - , text "Tvs:" <+> ppr (fi_tvs famInst) - , text "LHS:" <+> ppr (fi_tys famInst) - , text "RHS:" <+> ppr (fi_rhs famInst) ] - -pprFamInstHdr :: FamInst -> SDoc -pprFamInstHdr fi@(FamInst {fi_flavor = flavor}) - = pprTyConSort <+> pp_instance <+> pp_head - where - -- For *associated* types, say "type T Int = blah" - -- For *top level* type instances, say "type instance T Int = blah" - pp_instance - | isTyConAssoc fam_tc = empty - | otherwise = text "instance" - - (fam_tc, etad_lhs_tys) = famInstSplitLHS fi - vanilla_pp_head = pprTypeApp fam_tc etad_lhs_tys - - pp_head | DataFamilyInst rep_tc <- flavor - , isAlgTyCon rep_tc - , let extra_tvs = dropList etad_lhs_tys (tyConTyVars rep_tc) - , not (null extra_tvs) - = getPprStyle $ \ sty -> - if debugStyle sty - then vanilla_pp_head -- With -dppr-debug just show it as-is - else pprTypeApp fam_tc (etad_lhs_tys ++ mkTyVarTys extra_tvs) - -- Without -dppr-debug, eta-expand - -- See Trac #8674 - -- (This is probably over the top now that we use this - -- only for internal debug printing; PprTyThing.pprFamInst - -- is used for user-level printing.) - | otherwise - = vanilla_pp_head - - pprTyConSort = case flavor of - SynFamilyInst -> text "type" - DataFamilyInst tycon - | isDataTyCon tycon -> text "data" - | isNewTyCon tycon -> text "newtype" - | isAbstractTyCon tycon -> text "data" - | otherwise -> text "WEIRD" <+> ppr tycon - -pprFamInsts :: [FamInst] -> SDoc -pprFamInsts finsts = vcat (map pprFamInst finsts) - -{- -Note [Lazy axiom match] -~~~~~~~~~~~~~~~~~~~~~~~ -It is Vitally Important that mkImportedFamInst is *lazy* in its axiom -parameter. The axiom is loaded lazily, via a forkM, in TcIface. Sometime -later, mkImportedFamInst is called using that axiom. However, the axiom -may itself depend on entities which are not yet loaded as of the time -of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the -axiom, a dependency loop spontaneously appears and GHC hangs. The solution -is simply for mkImportedFamInst never, ever to look inside of the axiom -until everything else is good and ready to do so. We can assume that this -readiness has been achieved when some other code pulls on the axiom in the -FamInst. Thus, we pattern match on the axiom lazily (in the where clause, -not in the parameter list) and we assert the consistency of names there -also. --} - --- Make a family instance representation from the information found in an --- interface file. In particular, we get the rough match info from the iface --- (instead of computing it here). -mkImportedFamInst :: Name -- Name of the family - -> [Maybe Name] -- Rough match info - -> CoAxiom Unbranched -- Axiom introduced - -> FamInst -- Resulting family instance -mkImportedFamInst fam mb_tcs axiom - = FamInst { - fi_fam = fam, - fi_tcs = mb_tcs, - fi_tvs = tvs, - fi_cvs = cvs, - fi_tys = tys, - fi_rhs = rhs, - fi_axiom = axiom, - fi_flavor = flavor } - where - -- See Note [Lazy axiom match] - ~(CoAxBranch { cab_lhs = tys - , cab_tvs = tvs - , cab_cvs = cvs - , cab_rhs = rhs }) = coAxiomSingleBranch axiom - - -- Derive the flavor for an imported FamInst rather disgustingly - -- Maybe we should store it in the IfaceFamInst? - flavor = case splitTyConApp_maybe rhs of - Just (tc, _) - | Just ax' <- tyConFamilyCoercion_maybe tc - , ax' == axiom - -> DataFamilyInst tc - _ -> SynFamilyInst - -{- -************************************************************************ -* * - FamInstEnv -* * -************************************************************************ - -Note [FamInstEnv] -~~~~~~~~~~~~~~~~~ -A FamInstEnv maps a family name to the list of known instances for that family. - -The same FamInstEnv includes both 'data family' and 'type family' instances. -Type families are reduced during type inference, but not data families; -the user explains when to use a data family instance by using constructors -and pattern matching. - -Nevertheless it is still useful to have data families in the FamInstEnv: - - - For finding overlaps and conflicts - - - For finding the representation type...see FamInstEnv.topNormaliseType - and its call site in Simplify - - - In standalone deriving instance Eq (T [Int]) we need to find the - representation type for T [Int] - -Note [Varying number of patterns for data family axioms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For data families, the number of patterns may vary between instances. -For example - data family T a b - data instance T Int a = T1 a | T2 - data instance T Bool [a] = T3 a - -Then we get a data type for each instance, and an axiom: - data TInt a = T1 a | T2 - data TBoolList a = T3 a - - axiom ax7 :: T Int ~ TInt -- Eta-reduced - axiom ax8 a :: T Bool [a] ~ TBoolList a - -These two axioms for T, one with one pattern, one with two; -see Note [Eta reduction for data families] - -Note [FamInstEnv determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We turn FamInstEnvs into a list in some places that don't directly affect -the ABI. That happens in family consistency checks and when producing output -for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard -to tell what it affects without following a chain of functions. It's also -easy to accidentally make that nondeterminism affect the ABI. Furthermore -the envs should be relatively small, so it should be free to use deterministic -maps here. Testing with nofib and validate detected no difference between -UniqFM and UniqDFM. -See Note [Deterministic UniqFM]. --} - -type FamInstEnv = UniqDFM FamilyInstEnv -- Maps a family to its instances - -- See Note [FamInstEnv] - -- See Note [FamInstEnv determinism] - -type FamInstEnvs = (FamInstEnv, FamInstEnv) - -- External package inst-env, Home-package inst-env - -newtype FamilyInstEnv - = FamIE [FamInst] -- The instances for a particular family, in any order - -instance Outputable FamilyInstEnv where - ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) - --- INVARIANTS: --- * The fs_tvs are distinct in each FamInst --- of a range value of the map (so we can safely unify them) - -emptyFamInstEnvs :: (FamInstEnv, FamInstEnv) -emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) - -emptyFamInstEnv :: FamInstEnv -emptyFamInstEnv = emptyUDFM - -famInstEnvElts :: FamInstEnv -> [FamInst] -famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts] - -- See Note [FamInstEnv determinism] - -famInstEnvSize :: FamInstEnv -> Int -famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0 - -- It's OK to use nonDetFoldUDFM here since we're just computing the - -- size. - -familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] -familyInstances (pkg_fie, home_fie) fam - = get home_fie ++ get pkg_fie - where - get env = case lookupUDFM env fam of - Just (FamIE insts) -> insts - Nothing -> [] - -extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv -extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis - -extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv -extendFamInstEnv inst_env - ins_item@(FamInst {fi_fam = cls_nm}) - = addToUDFM_C add inst_env cls_nm (FamIE [ins_item]) - where - add (FamIE items) _ = FamIE (ins_item:items) - -{- -************************************************************************ -* * - Compatibility -* * -************************************************************************ - -Note [Apartness] -~~~~~~~~~~~~~~~~ -In dealing with closed type families, we must be able to check that one type -will never reduce to another. This check is called /apartness/. The check -is always between a target (which may be an arbitrary type) and a pattern. -Here is how we do it: - -apart(target, pattern) = not (unify(flatten(target), pattern)) - -where flatten (implemented in flattenTys, below) converts all type-family -applications into fresh variables. (See Note [Flattening].) - -Note [Compatibility] -~~~~~~~~~~~~~~~~~~~~ -Two patterns are /compatible/ if either of the following conditions hold: -1) The patterns are apart. -2) The patterns unify with a substitution S, and their right hand sides -equal under that substitution. - -For open type families, only compatible instances are allowed. For closed -type families, the story is slightly more complicated. Consider the following: - -type family F a where - F Int = Bool - F a = Int - -g :: Show a => a -> F a -g x = length (show x) - -Should that type-check? No. We need to allow for the possibility that 'a' -might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int -only when we can be sure that 'a' is not Int. - -To achieve this, after finding a possible match within the equations, we have to -go back to all previous equations and check that, under the -substitution induced by the match, other branches are surely apart. (See -Note [Apartness].) This is similar to what happens with class -instance selection, when we need to guarantee that there is only a match and -no unifiers. The exact algorithm is different here because the the -potentially-overlapping group is closed. - -As another example, consider this: - -type family G x where - G Int = Bool - G a = Double - -type family H y --- no instances - -Now, we want to simplify (G (H Char)). We can't, because (H Char) might later -simplify to be Int. So, (G (H Char)) is stuck, for now. - -While everything above is quite sound, it isn't as expressive as we'd like. -Consider this: - -type family J a where - J Int = Int - J a = a - -Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if -b is instantiated with Int, but the RHSs coincide there, so it's all OK. - -So, the rule is this: when looking up a branch in a closed type family, we -find a branch that matches the target, but then we make sure that the target -is apart from every previous *incompatible* branch. We don't check the -branches that are compatible with the matching branch, because they are either -irrelevant (clause 1 of compatible) or benign (clause 2 of compatible). --} - --- See Note [Compatibility] -compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool -compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) - (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) - = case tcUnifyTysFG (const BindMe) lhs1 lhs2 of - SurelyApart -> True - Unifiable subst - | Type.substTyAddInScope subst rhs1 `eqType` - Type.substTyAddInScope subst rhs2 - -> True - _ -> False - --- | Result of testing two type family equations for injectiviy. -data InjectivityCheckResult - = InjectivityAccepted - -- ^ Either RHSs are distinct or unification of RHSs leads to unification of - -- LHSs - | InjectivityUnified CoAxBranch CoAxBranch - -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for - -- closed type families where equation after unification might be - -- overlpapped (in which case it is OK if they don't unify). Constructor - -- stores axioms after unification. - --- | Check whether two type family axioms don't violate injectivity annotation. -injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch - -> InjectivityCheckResult -injectiveBranches injectivity - ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) - ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) - -- See Note [Verifying injectivity annotation]. This function implements first - -- check described there. - = let getInjArgs = filterByList injectivity - in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification - Nothing -> InjectivityAccepted -- RHS are different, so equations are - -- injective. - Just subst -> -- RHS unify under a substitution - let lhs1Subst = Type.substTys subst (getInjArgs lhs1) - lhs2Subst = Type.substTys subst (getInjArgs lhs2) - -- If LHSs are equal under the substitution used for RHSs then this pair - -- of equations does not violate injectivity annotation. If LHSs are not - -- equal under that substitution then this pair of equations violates - -- injectivity annotation, but for closed type families it still might - -- be the case that one LHS after substitution is unreachable. - in if eqTypes lhs1Subst lhs2Subst - then InjectivityAccepted - else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 - , cab_rhs = Type.substTy subst rhs1 }) - ( ax2 { cab_lhs = Type.substTys subst lhs2 - , cab_rhs = Type.substTy subst rhs2 }) - --- takes a CoAxiom with unknown branch incompatibilities and computes --- the compatibilities --- See Note [Storing compatibility] in CoAxiom -computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch] -computeAxiomIncomps branches - = snd (mapAccumL go [] branches) - where - go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) - go prev_brs cur_br - = (cur_br : prev_brs, new_br) - where - new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } - - mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch] - mk_incomps prev_brs cur_br - = filter (not . compatibleBranches cur_br) prev_brs - -{- -************************************************************************ -* * - Constructing axioms - These functions are here because tidyType / tcUnifyTysFG - are not available in CoAxiom - - Also computeAxiomIncomps is too sophisticated for CoAxiom -* * -************************************************************************ - -Note [Tidy axioms when we build them] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We print out axioms and don't want to print stuff like - F k k a b = ... -Instead we must tidy those kind variables. See Trac #7524. --} - --- all axiom roles are Nominal, as this is only used with type families -mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars - -> [CoVar] -- possibly stale covars - -> [Type] -- LHS patterns - -> Type -- RHS - -> [Role] - -> SrcSpan - -> CoAxBranch -mkCoAxBranch tvs cvs lhs rhs roles loc - = CoAxBranch { cab_tvs = tvs1 - , cab_cvs = cvs1 - , cab_lhs = tidyTypes env lhs - , cab_roles = roles - , cab_rhs = tidyType env rhs - , cab_loc = loc - , cab_incomps = placeHolderIncomps } - where - (env1, tvs1) = tidyTyCoVarBndrs emptyTidyEnv tvs - (env, cvs1) = tidyTyCoVarBndrs env1 cvs - -- See Note [Tidy axioms when we build them] - --- all of the following code is here to avoid mutual dependencies with --- Coercion -mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched -mkBranchedCoAxiom ax_name fam_tc branches - = CoAxiom { co_ax_unique = nameUnique ax_name - , co_ax_name = ax_name - , co_ax_tc = fam_tc - , co_ax_role = Nominal - , co_ax_implicit = False - , co_ax_branches = manyBranches (computeAxiomIncomps branches) } - -mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched -mkUnbranchedCoAxiom ax_name fam_tc branch - = CoAxiom { co_ax_unique = nameUnique ax_name - , co_ax_name = ax_name - , co_ax_tc = fam_tc - , co_ax_role = Nominal - , co_ax_implicit = False - , co_ax_branches = unbranched (branch { cab_incomps = [] }) } - -mkSingleCoAxiom :: Role -> Name - -> [TyVar] -> [CoVar] -> TyCon -> [Type] -> Type - -> CoAxiom Unbranched --- Make a single-branch CoAxiom, incluidng making the branch itself --- Used for both type family (Nominal) and data family (Representational) --- axioms, hence passing in the Role -mkSingleCoAxiom role ax_name tvs cvs fam_tc lhs_tys rhs_ty - = CoAxiom { co_ax_unique = nameUnique ax_name - , co_ax_name = ax_name - , co_ax_tc = fam_tc - , co_ax_role = role - , co_ax_implicit = False - , co_ax_branches = unbranched (branch { cab_incomps = [] }) } - where - branch = mkCoAxBranch tvs cvs lhs_tys rhs_ty - (map (const Nominal) tvs) - (getSrcSpan ax_name) - --- | Create a coercion constructor (axiom) suitable for the given --- newtype 'TyCon'. The 'Name' should be that of a new coercion --- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and --- the type the appropriate right hand side of the @newtype@, with --- the free variables a subset of those 'TyVar's. -mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched -mkNewTypeCoAxiom name tycon tvs roles rhs_ty - = CoAxiom { co_ax_unique = nameUnique name - , co_ax_name = name - , co_ax_implicit = True -- See Note [Implicit axioms] in TyCon - , co_ax_role = Representational - , co_ax_tc = tycon - , co_ax_branches = unbranched (branch { cab_incomps = [] }) } - where - branch = mkCoAxBranch tvs [] (mkTyVarTys tvs) rhs_ty - roles (getSrcSpan name) - -{- -************************************************************************ -* * - Looking up a family instance -* * -************************************************************************ - -@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. -Multiple matches are only possible in case of type families (not data -families), and then, it doesn't matter which match we choose (as the -instances are guaranteed confluent). - -We return the matching family instances and the type instance at which it -matches. For example, if we lookup 'T [Int]' and have a family instance - - data instance T [a] = .. - -desugared to - - data :R42T a = .. - coe :Co:R42T a :: T [a] ~ :R42T a - -we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. --} - --- when matching a type family application, we get a FamInst, --- and the list of types the axiom should be applied to -data FamInstMatch = FamInstMatch { fim_instance :: FamInst - , fim_tys :: [Type] - , fim_cos :: [Coercion] - } - -- See Note [Over-saturated matches] - -instance Outputable FamInstMatch where - ppr (FamInstMatch { fim_instance = inst - , fim_tys = tys - , fim_cos = cos }) - = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos - -lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] -lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc - = get pkg_ie ++ get home_ie - where - get ie = case lookupUDFM ie fam_tc of - Nothing -> [] - Just (FamIE fis) -> fis - -lookupFamInstEnv - :: FamInstEnvs - -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -- Successful matches --- Precondition: the tycon is saturated (or over-saturated) - -lookupFamInstEnv - = lookup_fam_inst_env match - where - match _ _ tpl_tys tys = tcMatchTys tpl_tys tys - -lookupFamInstEnvConflicts - :: FamInstEnvs - -> FamInst -- Putative new instance - -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) --- E.g. when we are about to add --- f : type instance F [a] = a->a --- we do (lookupFamInstConflicts f [b]) --- to find conflicting matches --- --- Precondition: the tycon is saturated (or over-saturated) - -lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) - = lookup_fam_inst_env my_unify envs fam tys - where - (fam, tys) = famInstSplitLHS fam_inst - -- In example above, fam tys' = F [b] - - my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ - = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs, - (ppr fam <+> ppr tys) $$ - (ppr tpl_tvs <+> ppr tpl_tys) ) - -- Unification will break badly if the variables overlap - -- They shouldn't because we allocate separate uniques for them - if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch - then Nothing - else Just noSubst - -- Note [Family instance overlap conflicts] - - noSubst = panic "lookupFamInstEnvConflicts noSubst" - new_branch = coAxiomSingleBranch new_axiom - --------------------------------------------------------------------------------- --- Type family injectivity checking bits -- --------------------------------------------------------------------------------- - -{- Note [Verifying injectivity annotation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Injectivity means that the RHS of a type family uniquely determines the LHS (see -Note [Type inference for type families with injectivity]). User informs about -injectivity using an injectivity annotation and it is GHC's task to verify that -that annotation is correct wrt. to type family equations. Whenever we see a new -equation of a type family we need to make sure that adding this equation to -already known equations of a type family does not violate injectivity annotation -supplied by the user (see Note [Injectivity annotation]). Of course if the type -family has no injectivity annotation then no check is required. But if a type -family has injectivity annotation we need to make sure that the following -conditions hold: - -1. For each pair of *different* equations of a type family, one of the following - conditions holds: - - A: RHSs are different. - - B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution - then it must be possible to unify the LHSs under the same substitution. - Example: - - type family FunnyId a = r | r -> a - type instance FunnyId Int = Int - type instance FunnyId a = a - - RHSs of these two equations unify under [ a |-> Int ] substitution. - Under this substitution LHSs are equal therefore these equations don't - violate injectivity annotation. - - B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some - substitution then either the LHSs unify under the same substitution or - the LHS of the latter equation is overlapped by earlier equations. - Example 1: - - type family SwapIntChar a = r | r -> a where - SwapIntChar Int = Char - SwapIntChar Char = Int - SwapIntChar a = a - - Say we are checking the last two equations. RHSs unify under [ a |-> - Int ] substitution but LHSs don't. So we apply the substitution to LHS - of last equation and check whether it is overlapped by any of previous - equations. Since it is overlapped by the first equation we conclude - that pair of last two equations does not violate injectivity - annotation. - - A special case of B is when RHSs unify with an empty substitution ie. they - are identical. - - If any of the above two conditions holds we conclude that the pair of - equations does not violate injectivity annotation. But if we find a pair - of equations where neither of the above holds we report that this pair - violates injectivity annotation because for a given RHS we don't have a - unique LHS. (Note that (B) actually implies (A).) - - Note that we only take into account these LHS patterns that were declared - as injective. - -2. If a RHS of a type family equation is a bare type variable then - all LHS variables (including implicit kind variables) also have to be bare. - In other words, this has to be a sole equation of that type family and it has - to cover all possible patterns. So for example this definition will be - rejected: - - type family W1 a = r | r -> a - type instance W1 [a] = a - - If it were accepted we could call `W1 [W1 Int]`, which would reduce to - `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`, - which is bogus. - -3. If a RHS of a type family equation is a type family application then the type - family is rejected as not injective. - -4. If a LHS type variable that is declared as injective is not mentioned on - injective position in the RHS then the type family is rejected as not - injective. "Injective position" means either an argument to a type - constructor or argument to a type family on injective position. - -See also Note [Injective type families] in TyCon --} - - --- | Check whether an open type family equation can be added to already existing --- instance environment without causing conflicts with supplied injectivity --- annotations. Returns list of conflicting axioms (type instance --- declarations). -lookupFamInstEnvInjectivityConflicts - :: [Bool] -- injectivity annotation for this type family instance - -- INVARIANT: list contains at least one True value - -> FamInstEnvs -- all type instances seens so far - -> FamInst -- new type instance that we're checking - -> [CoAxBranch] -- conflicting instance delcarations -lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) - fam_inst@(FamInst { fi_axiom = new_axiom }) - -- See Note [Verifying injectivity annotation]. This function implements - -- check (1.B1) for open type families described there. - = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie - where - fam = famInstTyCon fam_inst - new_branch = coAxiomSingleBranch new_axiom - - -- filtering function used by `lookup_inj_fam_conflicts` to check whether - -- a pair of equations conflicts with the injectivity annotation. - isInjConflict (FamInst { fi_axiom = old_axiom }) - | InjectivityAccepted <- - injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch - = False -- no conflict - | otherwise = True - - lookup_inj_fam_conflicts ie - | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam - = map (coAxiomSingleBranch . fi_axiom) $ - filter isInjConflict insts - | otherwise = [] - - --------------------------------------------------------------------------------- --- Type family overlap checking bits -- --------------------------------------------------------------------------------- - -{- -Note [Family instance overlap conflicts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- In the case of data family instances, any overlap is fundamentally a - conflict (as these instances imply injective type mappings). - -- In the case of type family instances, overlap is admitted as long as - the right-hand sides of the overlapping rules coincide under the - overlap substitution. eg - type instance F a Int = a - type instance F Int b = b - These two overlap on (F Int Int) but then both RHSs are Int, - so all is well. We require that they are syntactically equal; - anything else would be difficult to test for at this stage. --} - ------------------------------------------------------------- --- Might be a one-way match or a unifier -type MatchFun = FamInst -- The FamInst template - -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst - -> [Type] -- Target to match against - -> Maybe TCvSubst - -lookup_fam_inst_env' -- The worker, local to this module - :: MatchFun - -> FamInstEnv - -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -lookup_fam_inst_env' match_fun ie fam match_tys - | isOpenFamilyTyCon fam - , Just (FamIE insts) <- lookupUDFM ie fam - = find insts -- The common case - | otherwise = [] - where - - find [] = [] - find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs - , fi_tys = tpl_tys }) : rest) - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = find rest - - -- Proper check - | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 - = (FamInstMatch { fim_instance = item - , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 - , fim_cos = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) - substCoVars subst tpl_cvs - }) - : find rest - - -- No match => try next - | otherwise - = find rest - - where - (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys - - -- Precondition: the tycon is saturated (or over-saturated) - - -- Deal with over-saturation - -- See Note [Over-saturated matches] - split_tys tpl_tys - | isTypeFamilyTyCon fam - = pre_rough_split_tys - - | otherwise - = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys - rough_tcs = roughMatchTcs match_tys1 - in (rough_tcs, match_tys1, match_tys2) - - (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys - pre_rough_split_tys - = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2) - -lookup_fam_inst_env -- The worker, local to this module - :: MatchFun - -> FamInstEnvs - -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -- Successful matches - --- Precondition: the tycon is saturated (or over-saturated) - -lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys - = lookup_fam_inst_env' match_fun home_ie fam tys - ++ lookup_fam_inst_env' match_fun pkg_ie fam tys - -{- -Note [Over-saturated matches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's ok to look up an over-saturated type constructor. E.g. - type family F a :: * -> * - type instance F (a,b) = Either (a->b) - -The type instance gives rise to a newtype TyCon (at a higher kind -which you can't do in Haskell!): - newtype FPair a b = FP (Either (a->b)) - -Then looking up (F (Int,Bool) Char) will return a FamInstMatch - (FPair, [Int,Bool,Char]) -The "extra" type argument [Char] just stays on the end. - -We handle data families and type families separately here: - - * For type families, all instances of a type family must have the - same arity, so we can precompute the split between the match_tys - and the overflow tys. This is done in pre_rough_split_tys. - - * For data family instances, though, we need to re-split for each - instance, because the breakdown might be different for each - instance. Why? Because of eta reduction; see - Note [Eta reduction for data families]. --} - --- checks if one LHS is dominated by a list of other branches --- in other words, if an application would match the first LHS, it is guaranteed --- to match at least one of the others. The RHSs are ignored. --- This algorithm is conservative: --- True -> the LHS is definitely covered by the others --- False -> no information --- It is currently (Oct 2012) used only for generating errors for --- inaccessible branches. If these errors go unreported, no harm done. --- This is defined here to avoid a dependency from CoAxiom to Unify -isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool -isDominatedBy branch branches - = or $ map match branches - where - lhs = coAxBranchLHS branch - match (CoAxBranch { cab_lhs = tys }) - = isJust $ tcMatchTys tys lhs - -{- -************************************************************************ -* * - Choosing an axiom application -* * -************************************************************************ - -The lookupFamInstEnv function does a nice job for *open* type families, -but we also need to handle closed ones when normalising a type: --} - -reduceTyFamApp_maybe :: FamInstEnvs - -> Role -- Desired role of result coercion - -> TyCon -> [Type] - -> Maybe (Coercion, Type) --- Attempt to do a *one-step* reduction of a type-family application --- but *not* newtypes --- Works on type-synonym families always; data-families only if --- the role we seek is representational --- It does *not* normlise the type arguments first, so this may not --- go as far as you want. If you want normalised type arguments, --- use normaliseTcArgs first. --- --- The TyCon can be oversaturated. --- Works on both open and closed families --- --- Always returns a *homogeneous* coercion -- type family reductions are always --- homogeneous -reduceTyFamApp_maybe envs role tc tys - | Phantom <- role - = Nothing - - | case role of - Representational -> isOpenFamilyTyCon tc - _ -> isOpenTypeFamilyTyCon tc - -- If we seek a representational coercion - -- (e.g. the call in topNormaliseType_maybe) then we can - -- unwrap data families as well as type-synonym families; - -- otherwise only type-synonym families - , FamInstMatch { fim_instance = FamInst { fi_axiom = ax } - , fim_tys = inst_tys - , fim_cos = inst_cos } : _ <- lookupFamInstEnv envs tc tys - -- NB: Allow multiple matches because of compatible overlap - - = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos - ty = pSnd (coercionKind co) - in Just (co, ty) - - | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc - , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys - = let co = mkAxInstCo role ax ind inst_tys inst_cos - ty = pSnd (coercionKind co) - in Just (co, ty) - - | Just ax <- isBuiltInSynFamTyCon_maybe tc - , Just (coax,ts,ty) <- sfMatchFam ax tys - = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) - in Just (co, ty) - - | otherwise - = Nothing - --- The axiom can be oversaturated. (Closed families only.) -chooseBranch :: CoAxiom Branched -> [Type] - -> Maybe (BranchIndex, [Type], [Coercion]) -- found match, with args -chooseBranch axiom tys - = do { let num_pats = coAxiomNumPats axiom - (target_tys, extra_tys) = splitAt num_pats tys - branches = coAxiomBranches axiom - ; (ind, inst_tys, inst_cos) - <- findBranch (fromBranches branches) target_tys - ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) } - --- The axiom must *not* be oversaturated -findBranch :: [CoAxBranch] -- branches to check - -> [Type] -- target types - -> Maybe (BranchIndex, [Type], [Coercion]) - -- coercions relate requested types to returned axiom LHS at role N -findBranch branches target_tys - = go 0 branches - where - go ind (branch@(CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs - , cab_lhs = tpl_lhs - , cab_incomps = incomps }) : rest) - = let in_scope = mkInScopeSet (unionVarSets $ - map (tyCoVarsOfTypes . coAxBranchLHS) incomps) - -- See Note [Flattening] below - flattened_target = flattenTys in_scope target_tys - in case tcMatchTys tpl_lhs target_tys of - Just subst -- matching worked. now, check for apartness. - | apartnessCheck flattened_target branch - -> -- matching worked & we're apart from all incompatible branches. - -- success - ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) - Just (ind, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) - - -- failure. keep looking - _ -> go (ind+1) rest - - -- fail if no branches left - go _ [] = Nothing - --- | Do an apartness check, as described in the "Closed Type Families" paper --- (POPL '14). This should be used when determining if an equation --- ('CoAxBranch') of a closed type family can be used to reduce a certain target --- type family application. -apartnessCheck :: [Type] -- ^ /flattened/ target arguments. Make sure - -- they're flattened! See Note [Flattening]. - -- (NB: This "flat" is a different - -- "flat" than is used in TcFlatten.) - -> CoAxBranch -- ^ the candidate equation we wish to use - -- Precondition: this matches the target - -> Bool -- ^ True <=> equation can fire -apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) - = all (isSurelyApart - . tcUnifyTysFG (const BindMe) flattened_target - . coAxBranchLHS) incomps - where - isSurelyApart SurelyApart = True - isSurelyApart _ = False - -{- -************************************************************************ -* * - Looking up a family instance -* * -************************************************************************ - -Note [Normalising types] -~~~~~~~~~~~~~~~~~~~~~~~~ -The topNormaliseType function removes all occurrences of type families -and newtypes from the top-level structure of a type. normaliseTcApp does -the type family lookup and is fairly straightforward. normaliseType is -a little more involved. - -The complication comes from the fact that a type family might be used in the -kind of a variable bound in a forall. We wish to remove this type family -application, but that means coming up with a fresh variable (with the new -kind). Thus, we need a substitution to be built up as we recur through the -type. However, an ordinary TCvSubst just won't do: when we hit a type variable -whose kind has changed during normalisation, we need both the new type -variable *and* the coercion. We could conjure up a new VarEnv with just this -property, but a usable substitution environment already exists: -LiftingContexts from the liftCoSubst family of functions, defined in Coercion. -A LiftingContext maps a type variable to a coercion and a coercion variable to -a pair of coercions. Let's ignore coercion variables for now. Because the -coercion a type variable maps to contains the destination type (via -coercionKind), we don't need to store that destination type separately. Thus, -a LiftingContext has what we need: a map from type variables to (Coercion, -Type) pairs. - -We also benefit because we can piggyback on the liftCoSubstVarBndr function to -deal with binders. However, I had to modify that function to work with this -application. Thus, we now have liftCoSubstVarBndrCallback, which takes -a function used to process the kind of the binder. We don't wish -to lift the kind, but instead normalise it. So, we pass in a callback function -that processes the kind of the binder. - -After that brilliant explanation of all this, I'm sure you've forgotten the -dangling reference to coercion variables. What do we do with those? Nothing at -all. The point of normalising types is to remove type family applications, but -there's no sense in removing these from coercions. We would just get back a -new coercion witnessing the equality between the same types as the original -coercion. Because coercions are irrelevant anyway, there is no point in doing -this. So, whenever we encounter a coercion, we just say that it won't change. -That's what the CoercionTy case is doing within normalise_type. - -Note [Normalisation and type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to be a bit careful about normalising in the presence of type -synonyms (Trac #13035). Suppose S is a type synonym, and we have - S t1 t2 -If S is family-free (on its RHS) we can just normalise t1 and t2 and -reconstruct (S t1' t2'). Expanding S could not reveal any new redexes -because type families are saturated. - -But if S has a type family on its RHS we expand /before/ normalising -the args t1, t2. If we normalise t1, t2 first, we'll re-normalise them -after expansion, and that can lead to /exponential/ behavour; see Trac #13035. - -Notice, though, that expanding first can in principle duplicate t1,t2, -which might contain redexes. I'm sure you could conjure up an exponential -case by that route too, but it hasn't happened in practice yet! --} - -topNormaliseType :: FamInstEnvs -> Type -> Type -topNormaliseType env ty = case topNormaliseType_maybe env ty of - Just (_co, ty') -> ty' - Nothing -> ty - -topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type) - --- ^ Get rid of *outermost* (or toplevel) --- * type function redex --- * data family redex --- * newtypes --- returning an appropriate Representational coercion. Specifically, if --- topNormaliseType_maybe env ty = Just (co, ty') --- then --- (a) co :: ty ~R ty' --- (b) ty' is not a newtype, and is not a type-family or data-family redex --- --- However, ty' can be something like (Maybe (F ty)), where --- (F ty) is a redex. - -topNormaliseType_maybe env ty - = topNormaliseTypeX stepper mkTransCo ty - where - stepper = unwrapNewTypeStepper `composeSteppers` tyFamStepper - - tyFamStepper rec_nts tc tys -- Try to step a type/data family - = let (args_co, ntys) = normaliseTcArgs env Representational tc tys in - -- NB: It's OK to use normaliseTcArgs here instead of - -- normalise_tc_args (which takes the LiftingContext described - -- in Note [Normalising types]) because the reduceTyFamApp below - -- works only at top level. We'll never recur in this function - -- after reducing the kind of a bound tyvar. - - case reduceTyFamApp_maybe env Representational tc ntys of - Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co) - _ -> NS_Done - ---------------- -pmTopNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Type, [DataCon], Type) --- ^ Get rid of *outermost* (or toplevel) --- * type function redex --- * data family redex --- * newtypes --- --- Behaves exactly like `topNormaliseType_maybe`, but instead of returning a --- coercion, it returns useful information for issuing pattern matching --- warnings. See Note [Type normalisation for EmptyCase] for details. -pmTopNormaliseType_maybe env typ - = do ((ty_f,tm_f), ty) <- topNormaliseTypeX stepper comb typ - return (eq_src_ty ty (typ : ty_f [ty]), tm_f [], ty) - where - -- Find the first type in the sequence of rewrites that is a data type, - -- newtype, or a data family application (not the representation tycon!). - -- This is the one that is equal (in source Haskell) to the initial type. - -- If none is found in the list, then all of them are type family - -- applications, so we simply return the last one, which is the *simplest*. - eq_src_ty :: Type -> [Type] -> Type - eq_src_ty ty tys = maybe ty id (find is_alg_or_data_family tys) - - is_alg_or_data_family :: Type -> Bool - is_alg_or_data_family ty = isClosedAlgType ty || isDataFamilyAppType ty - - -- For efficiency, represent both lists as difference lists. - -- comb performs the concatenation, for both lists. - comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2) - - stepper = newTypeStepper `composeSteppers` tyFamStepper - - -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into - -- a loop. If it would fall into a loop, it produces 'NS_Abort'. - newTypeStepper :: NormaliseStepper ([Type] -> [Type],[DataCon] -> [DataCon]) - newTypeStepper rec_nts tc tys - | Just (ty', _co) <- instNewTyCon_maybe tc tys - = case checkRecTc rec_nts tc of - Just rec_nts' -> let tyf = ((TyConApp tc tys):) - tmf = ((tyConSingleDataCon tc):) - in NS_Step rec_nts' ty' (tyf, tmf) - Nothing -> NS_Abort - | otherwise - = NS_Done - - tyFamStepper :: NormaliseStepper ([Type] -> [Type], [DataCon] -> [DataCon]) - tyFamStepper rec_nts tc tys -- Try to step a type/data family - = let (_args_co, ntys) = normaliseTcArgs env Representational tc tys in - -- NB: It's OK to use normaliseTcArgs here instead of - -- normalise_tc_args (which takes the LiftingContext described - -- in Note [Normalising types]) because the reduceTyFamApp below - -- works only at top level. We'll never recur in this function - -- after reducing the kind of a bound tyvar. - - case reduceTyFamApp_maybe env Representational tc ntys of - Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id) - _ -> NS_Done - -{- Note [Type normalisation for EmptyCase] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -EmptyCase is an exception for pattern matching, since it is strict. This means -that it boils down to checking whether the type of the scrutinee is inhabited. -Function pmTopNormaliseType_maybe gets rid of the outermost type function/data -family redex and newtypes, in search of an algebraic type constructor, which is -easier to check for inhabitation. - -It returns 3 results instead of one, because there are 2 subtle points: -1. Newtypes are isomorphic to the underlying type in core but not in the source - language, -2. The representational data family tycon is used internally but should not be - shown to the user - -Hence, if pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty), then - (a) src_ty is the rewritten type which we can show to the user. That is, the - type we get if we rewrite type families but not data families or - newtypes. - (b) dcs is the list of data constructors "skipped", every time we normalise a - newtype to it's core representation, we keep track of the source data - constructor. - (c) core_ty is the rewritten type. That is, - pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty) - implies - topNormaliseType_maybe env ty = Just (co, core_ty) - for some coercion co. - -To see how all cases come into play, consider the following example: - - data family T a :: * - data instance T Int = T1 | T2 Bool - -- Which gives rise to FC: - -- data T a - -- data R:TInt = T1 | T2 Bool - -- axiom ax_ti : T Int ~R R:TInt - - newtype G1 = MkG1 (T Int) - newtype G2 = MkG2 G1 - - type instance F Int = F Char - type instance F Char = G2 - -In this case pmTopNormaliseType_maybe env (F Int) results in - - Just (G2, [MkG2,MkG1], R:TInt) - -Which means that in source Haskell: - - G2 is equivalent to F Int (in contrast, G1 isn't). - - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int). --} - ---------------- -normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) --- See comments on normaliseType for the arguments of this function -normaliseTcApp env role tc tys - = initNormM env role (tyCoVarsOfTypes tys) $ - normalise_tc_app tc tys - --- See Note [Normalising types] about the LiftingContext -normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type) -normalise_tc_app tc tys - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , not (isFamFreeTyCon tc) -- Expand and try again - = -- A synonym with type families in the RHS - -- Expand and try again - -- See Note [Normalisation and type synonyms] - normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') - - | isFamilyTyCon tc - = -- A type-family application - do { env <- getEnv - ; role <- getRole - ; (args_co, ntys) <- normalise_tc_args tc tys - ; case reduceTyFamApp_maybe env role tc ntys of - Just (first_co, ty') - -> do { (rest_co,nty) <- normalise_type ty' - ; return ( args_co `mkTransCo` first_co `mkTransCo` rest_co - , nty ) } - _ -> -- No unique matching family instance exists; - -- we do not do anything - return (args_co, mkTyConApp tc ntys) } - - | otherwise - = -- A synonym with no type families in the RHS; or data type etc - -- Just normalise the arguments and rebuild - do { (args_co, ntys) <- normalise_tc_args tc tys - ; return (args_co, mkTyConApp tc ntys) } - ---------------- --- | Normalise arguments to a tycon -normaliseTcArgs :: FamInstEnvs -- ^ env't with family instances - -> Role -- ^ desired role of output coercion - -> TyCon -- ^ tc - -> [Type] -- ^ tys - -> (Coercion, [Type]) -- ^ co :: tc tys ~ tc new_tys -normaliseTcArgs env role tc tys - = initNormM env role (tyCoVarsOfTypes tys) $ - normalise_tc_args tc tys - -normalise_tc_args :: TyCon -> [Type] -- tc tys - -> NormM (Coercion, [Type]) -- (co, new_tys), where - -- co :: tc tys ~ tc new_tys -normalise_tc_args tc tys - = do { role <- getRole - ; (cois, ntys) <- zipWithAndUnzipM normalise_type_role - tys (tyConRolesX role tc) - ; return (mkTyConAppCo role tc cois, ntys) } - where - normalise_type_role ty r = withRole r $ normalise_type ty - ---------------- -normaliseType :: FamInstEnvs - -> Role -- desired role of coercion - -> Type -> (Coercion, Type) -normaliseType env role ty - = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty - -normalise_type :: Type -- old type - -> NormM (Coercion, Type) -- (coercion,new type), where - -- co :: old-type ~ new_type --- Normalise the input type, by eliminating *all* type-function redexes --- but *not* newtypes (which are visible to the programmer) --- Returns with Refl if nothing happens --- Does nothing to newtypes --- The returned coercion *must* be *homogeneous* --- See Note [Normalising types] --- Try to not to disturb type synonyms if possible - -normalise_type ty - = go ty - where - go (TyConApp tc tys) = normalise_tc_app tc tys - go ty@(LitTy {}) = do { r <- getRole - ; return (mkReflCo r ty, ty) } - go (AppTy ty1 ty2) - = do { (co, nty1) <- go ty1 - ; (arg, nty2) <- withRole Nominal $ go ty2 - ; return (mkAppCo co arg, mkAppTy nty1 nty2) } - go (FunTy ty1 ty2) - = do { (co1, nty1) <- go ty1 - ; (co2, nty2) <- go ty2 - ; r <- getRole - ; return (mkFunCo r co1 co2, mkFunTy nty1 nty2) } - go (ForAllTy (TvBndr tyvar vis) ty) - = do { (lc', tv', h, ki') <- normalise_tyvar_bndr tyvar - ; (co, nty) <- withLC lc' $ normalise_type ty - ; let tv2 = setTyVarKind tv' ki' - ; return (mkForAllCo tv' h co, ForAllTy (TvBndr tv2 vis) nty) } - go (TyVarTy tv) = normalise_tyvar tv - go (CastTy ty co) - = do { (nco, nty) <- go ty - ; lc <- getLC - ; let co' = substRightCo lc co - ; return (castCoercionKind nco co co', mkCastTy nty co') } - go (CoercionTy co) - = do { lc <- getLC - ; r <- getRole - ; let right_co = substRightCo lc co - ; return ( mkProofIrrelCo r - (liftCoSubst Nominal lc (coercionType co)) - co right_co - , mkCoercionTy right_co ) } - -normalise_tyvar :: TyVar -> NormM (Coercion, Type) -normalise_tyvar tv - = ASSERT( isTyVar tv ) - do { lc <- getLC - ; r <- getRole - ; return $ case liftCoSubstTyVar lc r tv of - Just co -> (co, pSnd $ coercionKind co) - Nothing -> (mkReflCo r ty, ty) } - where ty = mkTyVarTy tv - -normalise_tyvar_bndr :: TyVar -> NormM (LiftingContext, TyVar, Coercion, Kind) -normalise_tyvar_bndr tv - = do { lc1 <- getLC - ; env <- getEnv - ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal - ; return $ liftCoSubstVarBndrCallback callback lc1 tv } - --- | a monad for the normalisation functions, reading 'FamInstEnvs', --- a 'LiftingContext', and a 'Role'. -newtype NormM a = NormM { runNormM :: - FamInstEnvs -> LiftingContext -> Role -> a } - -initNormM :: FamInstEnvs -> Role - -> TyCoVarSet -- the in-scope variables - -> NormM a -> a -initNormM env role vars (NormM thing_inside) - = thing_inside env lc role - where - in_scope = mkInScopeSet vars - lc = emptyLiftingContext in_scope - -getRole :: NormM Role -getRole = NormM (\ _ _ r -> r) - -getLC :: NormM LiftingContext -getLC = NormM (\ _ lc _ -> lc) - -getEnv :: NormM FamInstEnvs -getEnv = NormM (\ env _ _ -> env) - -withRole :: Role -> NormM a -> NormM a -withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r - -withLC :: LiftingContext -> NormM a -> NormM a -withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r - -instance Monad NormM where - ma >>= fmb = NormM $ \env lc r -> - let a = runNormM ma env lc r in - runNormM (fmb a) env lc r - -instance Functor NormM where - fmap = liftM -instance Applicative NormM where - pure x = NormM $ \ _ _ _ -> x - (<*>) = ap - -{- -************************************************************************ -* * - Flattening -* * -************************************************************************ - -Note [Flattening] -~~~~~~~~~~~~~~~~~ -As described in "Closed type families with overlapping equations" -http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf -we need to flatten core types before unifying them, when checking for "surely-apart" -against earlier equations of a closed type family. -Flattening means replacing all top-level uses of type functions with -fresh variables, *taking care to preserve sharing*. That is, the type -(Either (F a b) (F a b)) should flatten to (Either c c), never (Either -c d). - -Here is a nice example of why it's all necessary: - - type family F a b where - F Int Bool = Char - F a b = Double - type family G a -- open, no instances - -How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match, -while the second equation does. But, before reducing, we must make sure that the -target can never become (F Int Bool). Well, no matter what G Float becomes, it -certainly won't become *both* Int and Bool, so indeed we're safe reducing -(F (G Float) (G Float)) to Double. - -This is necessary not only to get more reductions (which we might be -willing to give up on), but for substitutivity. If we have (F x x), we -can see that (F x x) can reduce to Double. So, it had better be the -case that (F blah blah) can reduce to Double, no matter what (blah) -is! Flattening as done below ensures this. - -flattenTys is defined here because of module dependencies. --} - -data FlattenEnv = FlattenEnv { fe_type_map :: TypeMap TyVar - , fe_subst :: TCvSubst } - -emptyFlattenEnv :: InScopeSet -> FlattenEnv -emptyFlattenEnv in_scope - = FlattenEnv { fe_type_map = emptyTypeMap - , fe_subst = mkEmptyTCvSubst in_scope } - --- See Note [Flattening] -flattenTys :: InScopeSet -> [Type] -> [Type] -flattenTys in_scope tys = snd $ coreFlattenTys env tys - where - -- when we hit a type function, we replace it with a fresh variable - -- but, we need to make sure that this fresh variable isn't mentioned - -- *anywhere* in the types we're flattening, even if locally-bound in - -- a forall. That way, we can ensure consistency both within and outside - -- of that forall. - all_in_scope = in_scope `extendInScopeSetSet` allTyVarsInTys tys - env = emptyFlattenEnv all_in_scope - -coreFlattenTys :: FlattenEnv -> [Type] -> (FlattenEnv, [Type]) -coreFlattenTys = go [] - where - go rtys env [] = (env, reverse rtys) - go rtys env (ty : tys) - = let (env', ty') = coreFlattenTy env ty in - go (ty' : rtys) env' tys - -coreFlattenTy :: FlattenEnv -> Type -> (FlattenEnv, Type) -coreFlattenTy = go - where - go env ty | Just ty' <- coreView ty = go env ty' - - go env (TyVarTy tv) = (env, substTyVar (fe_subst env) tv) - go env (AppTy ty1 ty2) = let (env1, ty1') = go env ty1 - (env2, ty2') = go env1 ty2 in - (env2, AppTy ty1' ty2') - go env (TyConApp tc tys) - -- NB: Don't just check if isFamilyTyCon: this catches *data* families, - -- which are generative and thus can be preserved during flattening - | not (isGenerativeTyCon tc Nominal) - = let (env', tv) = coreFlattenTyFamApp env tc tys in - (env', mkTyVarTy tv) - - | otherwise - = let (env', tys') = coreFlattenTys env tys in - (env', mkTyConApp tc tys') - - go env (FunTy ty1 ty2) = let (env1, ty1') = go env ty1 - (env2, ty2') = go env1 ty2 in - (env2, mkFunTy ty1' ty2') - - go env (ForAllTy (TvBndr tv vis) ty) - = let (env1, tv') = coreFlattenVarBndr env tv - (env2, ty') = go env1 ty in - (env2, ForAllTy (TvBndr tv' vis) ty') - - go env ty@(LitTy {}) = (env, ty) - - go env (CastTy ty co) = let (env1, ty') = go env ty - (env2, co') = coreFlattenCo env1 co in - (env2, CastTy ty' co') - - go env (CoercionTy co) = let (env', co') = coreFlattenCo env co in - (env', CoercionTy co') - --- when flattening, we don't care about the contents of coercions. --- so, just return a fresh variable of the right (flattened) type -coreFlattenCo :: FlattenEnv -> Coercion -> (FlattenEnv, Coercion) -coreFlattenCo env co - = (env2, mkCoVarCo covar) - where - (env1, kind') = coreFlattenTy env (coercionType co) - fresh_name = mkFlattenFreshCoName - subst1 = fe_subst env1 - in_scope = getTCvInScope subst1 - covar = uniqAway in_scope (mkCoVar fresh_name kind') - env2 = env1 { fe_subst = subst1 `extendTCvInScope` covar } - -coreFlattenVarBndr :: FlattenEnv -> TyVar -> (FlattenEnv, TyVar) -coreFlattenVarBndr env tv - | kind' `eqType` kind - = ( env { fe_subst = extendTvSubst old_subst tv (mkTyVarTy tv) } - -- override any previous binding for tv - , tv) - - | otherwise - = let new_tv = uniqAway (getTCvInScope old_subst) (setTyVarKind tv kind') - new_subst = extendTvSubstWithClone old_subst tv new_tv - in - (env' { fe_subst = new_subst }, new_tv) - where - kind = tyVarKind tv - (env', kind') = coreFlattenTy env kind - old_subst = fe_subst env - -coreFlattenTyFamApp :: FlattenEnv - -> TyCon -- type family tycon - -> [Type] -- args - -> (FlattenEnv, TyVar) -coreFlattenTyFamApp env fam_tc fam_args - = case lookupTypeMap type_map fam_ty of - Just tv -> (env, tv) - -- we need fresh variables here, but this is called far from - -- any good source of uniques. So, we just use the fam_tc's unique - -- and trust uniqAway to avoid clashes. Recall that the in_scope set - -- contains *all* tyvars, even locally bound ones elsewhere in the - -- overall type, so this really is fresh. - Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc - tv = uniqAway (getTCvInScope subst) $ - mkTyVar tyvar_name (typeKind fam_ty) - env' = env { fe_type_map = extendTypeMap type_map fam_ty tv - , fe_subst = extendTCvInScope subst tv } - in (env', tv) - where fam_ty = mkTyConApp fam_tc fam_args - FlattenEnv { fe_type_map = type_map - , fe_subst = subst } = env - --- | Get the set of all type variables mentioned anywhere in the list --- of types. These variables are not necessarily free. -allTyVarsInTys :: [Type] -> VarSet -allTyVarsInTys [] = emptyVarSet -allTyVarsInTys (ty:tys) = allTyVarsInTy ty `unionVarSet` allTyVarsInTys tys - --- | Get the set of all type variables mentioned anywhere in a type. -allTyVarsInTy :: Type -> VarSet -allTyVarsInTy = go - where - go (TyVarTy tv) = unitVarSet tv - go (TyConApp _ tys) = allTyVarsInTys tys - go (AppTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) - go (FunTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) - go (ForAllTy (TvBndr tv _) ty) = unitVarSet tv `unionVarSet` - go (tyVarKind tv) `unionVarSet` - go ty - -- Don't remove the tv from the set! - go (LitTy {}) = emptyVarSet - go (CastTy ty co) = go ty `unionVarSet` go_co co - go (CoercionTy co) = go_co co - - go_co (Refl _ ty) = go ty - go_co (TyConAppCo _ _ args) = go_cos args - go_co (AppCo co arg) = go_co co `unionVarSet` go_co arg - go_co (ForAllCo tv h co) - = unionVarSets [unitVarSet tv, go_co co, go_co h] - go_co (FunCo _ c1 c2) = go_co c1 `unionVarSet` go_co c2 - go_co (CoVarCo cv) = unitVarSet cv - go_co (AxiomInstCo _ _ cos) = go_cos cos - go_co (UnivCo p _ t1 t2) = go_prov p `unionVarSet` go t1 `unionVarSet` go t2 - go_co (SymCo co) = go_co co - go_co (TransCo c1 c2) = go_co c1 `unionVarSet` go_co c2 - go_co (NthCo _ co) = go_co co - go_co (LRCo _ co) = go_co co - go_co (InstCo co arg) = go_co co `unionVarSet` go_co arg - go_co (CoherenceCo c1 c2) = go_co c1 `unionVarSet` go_co c2 - go_co (KindCo co) = go_co co - go_co (SubCo co) = go_co co - go_co (AxiomRuleCo _ cs) = go_cos cs - - go_cos = foldr (unionVarSet . go_co) emptyVarSet - - go_prov UnsafeCoerceProv = emptyVarSet - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyVarSet - go_prov (HoleProv _) = emptyVarSet - -mkFlattenFreshTyName :: Uniquable a => a -> Name -mkFlattenFreshTyName unq - = mkSysTvName (getUnique unq) (fsLit "flt") - -mkFlattenFreshCoName :: Name -mkFlattenFreshCoName - = mkSystemVarName (deriveUnique eqPrimTyConKey 71) (fsLit "flc") diff --git a/types/InstEnv.hs b/types/InstEnv.hs deleted file mode 100644 --- a/types/InstEnv.hs +++ /dev/null @@ -1,996 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[InstEnv]{Utilities for typechecking instance declarations} - -The bits common to TcInstDcls and TcDeriv. --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -module InstEnv ( - DFunId, InstMatch, ClsInstLookupResult, - OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, - ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, - instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, - instanceDFunId, tidyClsInstDFun, instanceRoughTcs, - fuzzyClsInstCmp, orphNamesOfClsInst, - - InstEnvs(..), VisibleOrphanModules, InstEnv, - emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalClsInstHead, - extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, - memberInstEnv, instIsVisible, - classInstances, instanceBindFun, - instanceCantMatch, roughMatchTcs, - isOverlappable, isOverlapping, isIncoherent - ) where - -#include "HsVersions.h" - -import TcType -- InstEnv is really part of the type checker, - -- and depends on TcType in many ways -import CoreSyn ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) -import Module -import Class -import Var -import VarSet -import Name -import NameSet -import Unify -import Outputable -import ErrUtils -import BasicTypes -import UniqDFM -import Util -import Id -import Data.Data ( Data ) -import Data.Maybe ( isJust, isNothing ) - -{- -************************************************************************ -* * - ClsInst: the data type for type-class instances -* * -************************************************************************ --} - --- | A type-class instance. Note that there is some tricky laziness at work --- here. See Note [ClsInst laziness and the rough-match fields] for more --- details. -data ClsInst - = ClsInst { -- Used for "rough matching"; see - -- Note [ClsInst laziness and the rough-match fields] - -- INVARIANT: is_tcs = roughMatchTcs is_tys - is_cls_nm :: Name -- ^ Class name - , is_tcs :: [Maybe Name] -- ^ Top of type args - - -- | @is_dfun_name = idName . is_dfun@. - -- - -- We use 'is_dfun_name' for the visibility check, - -- 'instIsVisible', which needs to know the 'Module' which the - -- dictionary is defined in. However, we cannot use the 'Module' - -- attached to 'is_dfun' since doing so would mean we would - -- potentially pull in an entire interface file unnecessarily. - -- This was the cause of #12367. - , is_dfun_name :: Name - - -- Used for "proper matching"; see Note [Proper-match fields] - , is_tvs :: [TyVar] -- Fresh template tyvars for full match - -- See Note [Template tyvars are fresh] - , is_cls :: Class -- The real class - , is_tys :: [Type] -- Full arg types (mentioning is_tvs) - -- INVARIANT: is_dfun Id has type - -- forall is_tvs. (...) => is_cls is_tys - -- (modulo alpha conversion) - - , is_dfun :: DFunId -- See Note [Haddock assumptions] - - , is_flag :: OverlapFlag -- See detailed comments with - -- the decl of BasicTypes.OverlapFlag - , is_orphan :: IsOrphan - } - deriving Data - --- | A fuzzy comparison function for class instances, intended for sorting --- instances before displaying them to the user. -fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering -fuzzyClsInstCmp x y = - stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` - mconcat (map cmp (zip (is_tcs x) (is_tcs y))) - where - cmp (Nothing, Nothing) = EQ - cmp (Nothing, Just _) = LT - cmp (Just _, Nothing) = GT - cmp (Just x, Just y) = stableNameCmp x y - -isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool -isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) -isOverlapping i = hasOverlappingFlag (overlapMode (is_flag i)) -isIncoherent i = hasIncoherentFlag (overlapMode (is_flag i)) - -{- -Note [ClsInst laziness and the rough-match fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is -otherwise unused in the program. Then it's stupid to load B.hi, the data type -declaration for B.T -- and perhaps further instance declarations! - -We avoid this as follows: - -* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's - content. - -* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys - contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we - poke any of these fields we'll typecheck the DFunId declaration, and hence - pull in interfaces that it refers to. See Note [Proper-match fields]. - -* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and - is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking - inside the DFunId. The rough-match fields allow us to say "definitely does not - match", based only on Names. - - This laziness is very important; see Trac #12367. Try hard to avoid pulling on - the structured fields unless you really need the instance. - -* Another place to watch is InstEnv.instIsVisible, which needs the module to - which the ClsInst belongs. We can get this from is_dfun_name. - -* In is_tcs, - Nothing means that this type arg is a type variable - - (Just n) means that this type arg is a - TyConApp with a type constructor of n. - This is always a real tycon, never a synonym! - (Two different synonyms might match, but two - different real tycons can't.) - NB: newtypes are not transparent, though! --} - -{- -Note [Template tyvars are fresh] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The is_tvs field of a ClsInst has *completely fresh* tyvars. -That is, they are - * distinct from any other ClsInst - * distinct from any tyvars free in predicates that may - be looked up in the class instance environment -Reason for freshness: we use unification when checking for overlap -etc, and that requires the tyvars to be distinct. - -The invariant is checked by the ASSERT in lookupInstEnv'. - -Note [Proper-match fields] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The is_tvs, is_cls, is_tys fields are simply cached values, pulled -out (lazily) from the dfun id. They are cached here simply so -that we don't need to decompose the DFunId each time we want -to match it. The hope is that the rough-match fields mean -that we often never poke the proper-match fields. - -However, note that: - * is_tvs must be a superset of the free vars of is_tys - - * is_tvs, is_tys may be alpha-renamed compared to the ones in - the dfun Id - -Note [Haddock assumptions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -For normal user-written instances, Haddock relies on - - * the SrcSpan of - * the Name of - * the is_dfun of - * an Instance - -being equal to - - * the SrcSpan of - * the instance head type of - * the InstDecl used to construct the Instance. --} - -instanceDFunId :: ClsInst -> DFunId -instanceDFunId = is_dfun - -tidyClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst -tidyClsInstDFun tidy_dfun ispec - = ispec { is_dfun = tidy_dfun (is_dfun ispec) } - -instanceRoughTcs :: ClsInst -> [Maybe Name] -instanceRoughTcs = is_tcs - - -instance NamedThing ClsInst where - getName ispec = getName (is_dfun ispec) - -instance Outputable ClsInst where - ppr = pprInstance - -pprInstance :: ClsInst -> SDoc --- Prints the ClsInst as an instance declaration -pprInstance ispec - = hang (pprInstanceHdr ispec) - 2 (vcat [ text "--" <+> pprDefinedAt (getName ispec) - , ifPprDebug (ppr (is_dfun ispec)) ]) - --- * pprInstanceHdr is used in VStudio to populate the ClassView tree -pprInstanceHdr :: ClsInst -> SDoc --- Prints the ClsInst as an instance declaration -pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) - = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun) - -pprInstances :: [ClsInst] -> SDoc -pprInstances ispecs = vcat (map pprInstance ispecs) - -instanceHead :: ClsInst -> ([TyVar], Class, [Type]) --- Returns the head, using the fresh tyavs from the ClsInst -instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) - = (tvs, cls, tys) - where - (_, _, cls, _) = tcSplitDFunTy (idType dfun) - --- | Collects the names of concrete types and type constructors that make --- up the head of a class instance. For instance, given `class Foo a b`: --- --- `instance Foo (Either (Maybe Int) a) Bool` would yield --- [Either, Maybe, Int, Bool] --- --- Used in the implementation of ":info" in GHCi. --- --- The 'tcSplitSigmaTy' is because of --- instance Foo a => Baz T where ... --- The decl is an orphan if Baz and T are both not locally defined, --- even if Foo *is* locally defined -orphNamesOfClsInst :: ClsInst -> NameSet -orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys }) - = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm - -instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type]) --- Decomposes the DFunId -instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) - -mkLocalInstance :: DFunId -> OverlapFlag - -> [TyVar] -> Class -> [Type] - -> ClsInst --- Used for local instances, where we can safely pull on the DFunId. --- Consider using newClsInst instead; this will also warn if --- the instance is an orphan. -mkLocalInstance dfun oflag tvs cls tys - = ClsInst { is_flag = oflag, is_dfun = dfun - , is_tvs = tvs - , is_dfun_name = dfun_name - , is_cls = cls, is_cls_nm = cls_name - , is_tys = tys, is_tcs = roughMatchTcs tys - , is_orphan = orph - } - where - cls_name = className cls - dfun_name = idName dfun - this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name - is_local name = nameIsLocalOrFrom this_mod name - - -- Compute orphanhood. See Note [Orphans] in InstEnv - (cls_tvs, fds) = classTvsFds cls - arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] - - -- See Note [When exactly is an instance decl an orphan?] - orph | is_local cls_name = NotOrphan (nameOccName cls_name) - | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns - | otherwise = IsOrphan - - notOrphan NotOrphan{} = True - notOrphan _ = False - - mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name - -- that is not in the "determined" arguments - mb_ns | null fds = [choose_one arg_names] - | otherwise = map do_one fds - do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names - , not (tv `elem` rtvs)] - - choose_one nss = chooseOrphanAnchor (unionNameSets nss) - -mkImportedInstance :: Name -- ^ the name of the class - -> [Maybe Name] -- ^ the types which the class was applied to - -> Name -- ^ the 'Name' of the dictionary binding - -> DFunId -- ^ the 'Id' of the dictionary. - -> OverlapFlag -- ^ may this instance overlap? - -> IsOrphan -- ^ is this instance an orphan? - -> ClsInst --- Used for imported instances, where we get the rough-match stuff --- from the interface file --- The bound tyvars of the dfun are guaranteed fresh, because --- the dfun has been typechecked out of the same interface file -mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan - = ClsInst { is_flag = oflag, is_dfun = dfun - , is_tvs = tvs, is_tys = tys - , is_dfun_name = dfun_name - , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs - , is_orphan = orphan } - where - (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) - -{- -Note [When exactly is an instance decl an orphan?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - (see MkIface.instanceToIfaceInst, which implements this) -Roughly speaking, an instance is an orphan if its head (after the =>) -mentions nothing defined in this module. - -Functional dependencies complicate the situation though. Consider - - module M where { class C a b | a -> b } - -and suppose we are compiling module X: - - module X where - import M - data T = ... - instance C Int T where ... - -This instance is an orphan, because when compiling a third module Y we -might get a constraint (C Int v), and we'd want to improve v to T. So -we must make sure X's instances are loaded, even if we do not directly -use anything from X. - -More precisely, an instance is an orphan iff - - If there are no fundeps, then at least of the names in - the instance head is locally defined. - - If there are fundeps, then for every fundep, at least one of the - names free in a *non-determined* part of the instance head is - defined in this module. - -(Note that these conditions hold trivially if the class is locally -defined.) - - -************************************************************************ -* * - InstEnv, ClsInstEnv -* * -************************************************************************ - -A @ClsInstEnv@ all the instances of that class. The @Id@ inside a -ClsInstEnv mapping is the dfun for that instance. - -If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then - - forall a b, C t1 t2 t3 can be constructed by dfun - -or, to put it another way, we have - - instance (...) => C t1 t2 t3, witnessed by dfun --} - ---------------------------------------------------- -{- -Note [InstEnv determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We turn InstEnvs into a list in some places that don't directly affect -the ABI. That happens when we create output for `:info`. -Unfortunately that nondeterminism is nonlocal and it's hard to tell what it -affects without following a chain of functions. It's also easy to accidentally -make that nondeterminism affect the ABI. Furthermore the envs should be -relatively small, so it should be free to use deterministic maps here. -Testing with nofib and validate detected no difference between UniqFM and -UniqDFM. See also Note [Deterministic UniqFM] --} - -type InstEnv = UniqDFM ClsInstEnv -- Maps Class to instances for that class - -- See Note [InstEnv determinism] - --- | 'InstEnvs' represents the combination of the global type class instance --- environment, the local type class instance environment, and the set of --- transitively reachable orphan modules (according to what modules have been --- directly imported) used to test orphan instance visibility. -data InstEnvs = InstEnvs { - ie_global :: InstEnv, -- External-package instances - ie_local :: InstEnv, -- Home-package instances - ie_visible :: VisibleOrphanModules -- Set of all orphan modules transitively - -- reachable from the module being compiled - -- See Note [Instance lookup and orphan instances] - } - --- | Set of visible orphan modules, according to what modules have been directly --- imported. This is based off of the dep_orphs field, which records --- transitively reachable orphan modules (modules that define orphan instances). -type VisibleOrphanModules = ModuleSet - -newtype ClsInstEnv - = ClsIE [ClsInst] -- The instances for a particular class, in any order - -instance Outputable ClsInstEnv where - ppr (ClsIE is) = pprInstances is - --- INVARIANTS: --- * The is_tvs are distinct in each ClsInst --- of a ClsInstEnv (so we can safely unify them) - --- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: --- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] --- The "a" in the pattern must be one of the forall'd variables in --- the dfun type. - -emptyInstEnv :: InstEnv -emptyInstEnv = emptyUDFM - -instEnvElts :: InstEnv -> [ClsInst] -instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts] - -- See Note [InstEnv determinism] - --- | Test if an instance is visible, by checking that its origin module --- is in 'VisibleOrphanModules'. --- See Note [Instance lookup and orphan instances] -instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool -instIsVisible vis_mods ispec - -- NB: Instances from the interactive package always are visible. We can't - -- add interactive modules to the set since we keep creating new ones - -- as a GHCi session progresses. - | isInteractiveModule mod = True - | IsOrphan <- is_orphan ispec = mod `elemModuleSet` vis_mods - | otherwise = True - where - mod = nameModule $ is_dfun_name ispec - -classInstances :: InstEnvs -> Class -> [ClsInst] -classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls - = get home_ie ++ get pkg_ie - where - get env = case lookupUDFM env cls of - Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts - Nothing -> [] - --- | Checks for an exact match of ClsInst in the instance environment. --- We use this when we do signature checking in TcRnDriver -memberInstEnv :: InstEnv -> ClsInst -> Bool -memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = - maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items) - (lookupUDFM inst_env cls_nm) - where - identicalDFunType cls1 cls2 = - eqType (varType (is_dfun cls1)) (varType (is_dfun cls2)) - -extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv -extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs - -extendInstEnv :: InstEnv -> ClsInst -> InstEnv -extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) - = addToUDFM_C add inst_env cls_nm (ClsIE [ins_item]) - where - add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) - -deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv -deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) - = adjustUDFM adjust inst_env cls_nm - where - adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items) - -identicalClsInstHead :: ClsInst -> ClsInst -> Bool --- ^ True when when the instance heads are the same --- e.g. both are Eq [(a,b)] --- Used for overriding in GHCi --- Obviously should be insenstive to alpha-renaming -identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 }) - (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 }) - = cls_nm1 == cls_nm2 - && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields - && isJust (tcMatchTys tys1 tys2) - && isJust (tcMatchTys tys2 tys1) - -{- -************************************************************************ -* * - Looking up an instance -* * -************************************************************************ - -@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since -the env is kept ordered, the first match must be the only one. The -thing we are looking up can have an arbitrary "flexi" part. - -Note [Instance lookup and orphan instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are compiling a module M, and we have a zillion packages -loaded, and we are looking up an instance for C (T W). If we find a -match in module 'X' from package 'p', should be "in scope"; that is, - - is p:X in the transitive closure of modules imported from M? - -The difficulty is that the "zillion packages" might include ones loaded -through earlier invocations of the GHC API, or earlier module loads in GHCi. -They might not be in the dependencies of M itself; and if not, the instances -in them should not be visible. Trac #2182, #8427. - -There are two cases: - * If the instance is *not an orphan*, then module X defines C, T, or W. - And in order for those types to be involved in typechecking M, it - must be that X is in the transitive closure of M's imports. So we - can use the instance. - - * If the instance *is an orphan*, the above reasoning does not apply. - So we keep track of the set of orphan modules transitively below M; - this is the ie_visible field of InstEnvs, of type VisibleOrphanModules. - - If module p:X is in this set, then we can use the instance, otherwise - we can't. - -Note [Rules for instance lookup] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These functions implement the carefully-written rules in the user -manual section on "overlapping instances". At risk of duplication, -here are the rules. If the rules change, change this text and the -user manual simultaneously. The link may be this: -http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap - -The willingness to be overlapped or incoherent is a property of the -instance declaration itself, controlled as follows: - - * An instance is "incoherent" - if it has an INCOHERENT pragma, or - if it appears in a module compiled with -XIncoherentInstances. - - * An instance is "overlappable" - if it has an OVERLAPPABLE or OVERLAPS pragma, or - if it appears in a module compiled with -XOverlappingInstances, or - if the instance is incoherent. - - * An instance is "overlapping" - if it has an OVERLAPPING or OVERLAPS pragma, or - if it appears in a module compiled with -XOverlappingInstances, or - if the instance is incoherent. - compiled with -XOverlappingInstances. - -Now suppose that, in some client module, we are searching for an instance -of the target constraint (C ty1 .. tyn). The search works like this. - - * Find all instances I that match the target constraint; that is, the - target constraint is a substitution instance of I. These instance - declarations are the candidates. - - * Find all non-candidate instances that unify with the target - constraint. Such non-candidates instances might match when the - target constraint is further instantiated. If all of them are - incoherent, proceed; if not, the search fails. - - * Eliminate any candidate IX for which both of the following hold: - * There is another candidate IY that is strictly more specific; - that is, IY is a substitution instance of IX but not vice versa. - - * Either IX is overlappable or IY is overlapping. - - * If only one candidate remains, pick it. Otherwise if all remaining - candidates are incoherent, pick an arbitrary candidate. Otherwise fail. - -Note [Overlapping instances] (NB: these notes are quite old) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Overlap is permitted, but only in such a way that one can make -a unique choice when looking up. That is, overlap is only permitted if -one template matches the other, or vice versa. So this is ok: - - [a] [Int] - -but this is not - - (Int,a) (b,Int) - -If overlap is permitted, the list is kept most specific first, so that -the first lookup is the right choice. - - -For now we just use association lists. - -\subsection{Avoiding a problem with overlapping} - -Consider this little program: - -\begin{pseudocode} - class C a where c :: a - class C a => D a where d :: a - - instance C Int where c = 17 - instance D Int where d = 13 - - instance C a => C [a] where c = [c] - instance ({- C [a], -} D a) => D [a] where d = c - - instance C [Int] where c = [37] - - main = print (d :: [Int]) -\end{pseudocode} - -What do you think `main' prints (assuming we have overlapping instances, and -all that turned on)? Well, the instance for `D' at type `[a]' is defined to -be `c' at the same type, and we've got an instance of `C' at `[Int]', so the -answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because -the `C [Int]' instance is more specific). - -Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That -was easy ;-) Let's just consult hugs for good measure. Wait - if I use old -hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it -doesn't even compile! What's going on!? - -What hugs complains about is the `D [a]' instance decl. - -\begin{pseudocode} - ERROR "mj.hs" (line 10): Cannot build superclass instance - *** Instance : D [a] - *** Context supplied : D a - *** Required superclass : C [a] -\end{pseudocode} - -You might wonder what hugs is complaining about. It's saying that you -need to add `C [a]' to the context of the `D [a]' instance (as appears -in comments). But there's that `C [a]' instance decl one line above -that says that I can reduce the need for a `C [a]' instance to the -need for a `C a' instance, and in this case, I already have the -necessary `C a' instance (since we have `D a' explicitly in the -context, and `C' is a superclass of `D'). - -Unfortunately, the above reasoning indicates a premature commitment to the -generic `C [a]' instance. I.e., it prematurely rules out the more specific -instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to -add the context that hugs suggests (uncomment the `C [a]'), effectively -deferring the decision about which instance to use. - -Now, interestingly enough, 4.04 has this same bug, but it's covered up -in this case by a little known `optimization' that was disabled in -4.06. Ghc-4.04 silently inserts any missing superclass context into -an instance declaration. In this case, it silently inserts the `C -[a]', and everything happens to work out. - -(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for -`Mark Jones', although Mark claims no credit for the `optimization' in -question, and would rather it stopped being called the `Mark Jones -optimization' ;-) - -So, what's the fix? I think hugs has it right. Here's why. Let's try -something else out with ghc-4.04. Let's add the following line: - - d' :: D a => [a] - d' = c - -Everyone raise their hand who thinks that `d :: [Int]' should give a -different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The -`optimization' only applies to instance decls, not to regular -bindings, giving inconsistent behavior. - -Old hugs had this same bug. Here's how we fixed it: like GHC, the -list of instances for a given class is ordered, so that more specific -instances come before more generic ones. For example, the instance -list for C might contain: - ..., C Int, ..., C a, ... -When we go to look for a `C Int' instance we'll get that one first. -But what if we go looking for a `C b' (`b' is unconstrained)? We'll -pass the `C Int' instance, and keep going. But if `b' is -unconstrained, then we don't know yet if the more specific instance -will eventually apply. GHC keeps going, and matches on the generic `C -a'. The fix is to, at each step, check to see if there's a reverse -match, and if so, abort the search. This prevents hugs from -prematurely chosing a generic instance when a more specific one -exists. - ---Jeff -v -BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in -this test. Suppose the instance envt had - ..., forall a b. C a a b, ..., forall a b c. C a b c, ... -(still most specific first) -Now suppose we are looking for (C x y Int), where x and y are unconstrained. - C x y Int doesn't match the template {a,b} C a a b -but neither does - C a a b match the template {x,y} C x y Int -But still x and y might subsequently be unified so they *do* match. - -Simple story: unify, don't match. --} - -type DFunInstType = Maybe Type - -- Just ty => Instantiate with this type - -- Nothing => Instantiate with any type of this tyvar's kind - -- See Note [DFunInstType: instantiating types] - -type InstMatch = (ClsInst, [DFunInstType]) - -type ClsInstLookupResult - = ( [InstMatch] -- Successful matches - , [ClsInst] -- These don't match but do unify - , [InstMatch] ) -- Unsafe overlapped instances under Safe Haskell - -- (see Note [Safe Haskell Overlapping Instances] in - -- TcSimplify). - -{- -Note [DFunInstType: instantiating types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A successful match is a ClsInst, together with the types at which - the dfun_id in the ClsInst should be instantiated -The instantiating types are (Either TyVar Type)s because the dfun -might have some tyvars that *only* appear in arguments - dfun :: forall a b. C a b, Ord b => D [a] -When we match this against D [ty], we return the instantiating types - [Just ty, Nothing] -where the 'Nothing' indicates that 'b' can be freely instantiated. -(The caller instantiates it to a flexi type variable, which will - presumably later become fixed via functional dependencies.) --} - --- |Look up an instance in the given instance environment. The given class application must match exactly --- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, --- yield 'Left errorMessage'. -lookupUniqueInstEnv :: InstEnvs - -> Class -> [Type] - -> Either MsgDoc (ClsInst, [Type]) -lookupUniqueInstEnv instEnv cls tys - = case lookupInstEnv False instEnv cls tys of - ([(inst, inst_tys)], _, _) - | noFlexiVar -> Right (inst, inst_tys') - | otherwise -> Left $ text "flexible type variable:" <+> - (ppr $ mkTyConApp (classTyCon cls) tys) - where - inst_tys' = [ty | Just ty <- inst_tys] - noFlexiVar = all isJust inst_tys - _other -> Left $ text "instance not found" <+> - (ppr $ mkTyConApp (classTyCon cls) tys) - -lookupInstEnv' :: InstEnv -- InstEnv to look in - -> VisibleOrphanModules -- But filter against this - -> Class -> [Type] -- What we are looking for - -> ([InstMatch], -- Successful matches - [ClsInst]) -- These don't match but do unify --- The second component of the result pair happens when we look up --- Foo [a] --- in an InstEnv that has entries for --- Foo [Int] --- Foo [b] --- Then which we choose would depend on the way in which 'a' --- is instantiated. So we report that Foo [b] is a match (mapping b->a) --- but Foo [Int] is a unifier. This gives the caller a better chance of --- giving a suitable error message - -lookupInstEnv' ie vis_mods cls tys - = lookup ie - where - rough_tcs = roughMatchTcs tys - all_tvs = all isNothing rough_tcs - - -------------- - lookup env = case lookupUDFM env cls of - Nothing -> ([],[]) -- No instances for this class - Just (ClsIE insts) -> find [] [] insts - - -------------- - find ms us [] = (ms, us) - find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs - , is_tys = tpl_tys }) : rest) - | not (instIsVisible vis_mods item) - = find ms us rest -- See Note [Instance lookup and orphan instances] - - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = find ms us rest - - | Just subst <- tcMatchTys tpl_tys tys - = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest - - -- Does not match, so next check whether the things unify - -- See Note [Overlapping instances] and Note [Incoherent instances] - | isIncoherent item - = find ms us rest - - | otherwise - = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, - (ppr cls <+> ppr tys <+> ppr all_tvs) $$ - (ppr tpl_tvs <+> ppr tpl_tys) - ) - -- Unification will break badly if the variables overlap - -- They shouldn't because we allocate separate uniques for them - -- See Note [Template tyvars are fresh] - case tcUnifyTys instanceBindFun tpl_tys tys of - Just _ -> find ms (item:us) rest - Nothing -> find ms us rest - where - tpl_tv_set = mkVarSet tpl_tvs - ---------------- --- This is the common way to call this function. -lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions - -> InstEnvs -- External and home package inst-env - -> Class -> [Type] -- What we are looking for - -> ClsInstLookupResult --- ^ See Note [Rules for instance lookup] --- ^ See Note [Safe Haskell Overlapping Instances] in TcSimplify --- ^ See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -lookupInstEnv check_overlap_safe - (InstEnvs { ie_global = pkg_ie - , ie_local = home_ie - , ie_visible = vis_mods }) - cls - tys - = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $ - (final_matches, final_unifs, unsafe_overlapped) - where - (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys - (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys - all_matches = home_matches ++ pkg_matches - all_unifs = home_unifs ++ pkg_unifs - final_matches = foldr insert_overlapping [] all_matches - -- Even if the unifs is non-empty (an error situation) - -- we still prune the matches, so that the error message isn't - -- misleading (complaining of multiple matches when some should be - -- overlapped away) - - unsafe_overlapped - = case final_matches of - [match] -> check_safe match - _ -> [] - - -- If the selected match is incoherent, discard all unifiers - final_unifs = case final_matches of - (m:_) | isIncoherent (fst m) -> [] - _ -> all_unifs - - -- NOTE [Safe Haskell isSafeOverlap] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- We restrict code compiled in 'Safe' mode from overriding code - -- compiled in any other mode. The rationale is that code compiled - -- in 'Safe' mode is code that is untrusted by the ghc user. So - -- we shouldn't let that code change the behaviour of code the - -- user didn't compile in 'Safe' mode since that's the code they - -- trust. So 'Safe' instances can only overlap instances from the - -- same module. A same instance origin policy for safe compiled - -- instances. - check_safe (inst,_) - = case check_overlap_safe && unsafeTopInstance inst of - -- make sure it only overlaps instances from the same module - True -> go [] all_matches - -- most specific is from a trusted location. - False -> [] - where - go bad [] = bad - go bad (i@(x,_):unchecked) = - if inSameMod x || isOverlappable x - then go bad unchecked - else go (i:bad) unchecked - - inSameMod b = - let na = getName $ getName inst - la = isInternalName na - nb = getName $ getName b - lb = isInternalName nb - in (la && lb) || (nameModule na == nameModule nb) - - -- We consider the most specific instance unsafe when it both: - -- (1) Comes from a module compiled as `Safe` - -- (2) Is an orphan instance, OR, an instance for a MPTC - unsafeTopInstance inst = isSafeOverlap (is_flag inst) && - (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1) - ---------------- -insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] --- ^ Add a new solution, knocking out strictly less specific ones --- See Note [Rules for instance lookup] -insert_overlapping new_item [] = [new_item] -insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items) - | new_beats_old -- New strictly overrides old - , not old_beats_new - , new_inst `can_override` old_inst - = insert_overlapping new_item old_items - - | old_beats_new -- Old strictly overrides new - , not new_beats_old - , old_inst `can_override` new_inst - = old_item : old_items - - -- Discard incoherent instances; see Note [Incoherent instances] - | isIncoherent old_inst -- Old is incoherent; discard it - = insert_overlapping new_item old_items - | isIncoherent new_inst -- New is incoherent; discard it - = old_item : old_items - - -- Equal or incomparable, and neither is incoherent; keep both - | otherwise - = old_item : insert_overlapping new_item old_items - where - - new_beats_old = new_inst `more_specific_than` old_inst - old_beats_new = old_inst `more_specific_than` new_inst - - -- `instB` can be instantiated to match `instA` - -- or the two are equal - instA `more_specific_than` instB - = isJust (tcMatchTys (is_tys instB) (is_tys instA)) - - instA `can_override` instB - = isOverlapping instA || isOverlappable instB - -- Overlap permitted if either the more specific instance - -- is marked as overlapping, or the more general one is - -- marked as overlappable. - -- Latest change described in: Trac #9242. - -- Previous change: Trac #3877, Dec 10. - -{- -Note [Incoherent instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For some classes, the choice of a particular instance does not matter, any one -is good. E.g. consider - - class D a b where { opD :: a -> b -> String } - instance D Int b where ... - instance D a Int where ... - - g (x::Int) = opD x x -- Wanted: D Int Int - -For such classes this should work (without having to add an "instance D Int -Int", and using -XOverlappingInstances, which would then work). This is what --XIncoherentInstances is for: Telling GHC "I don't care which instance you use; -if you can use one, use it." - -Should this logic only work when *all* candidates have the incoherent flag, or -even when all but one have it? The right choice is the latter, which can be -justified by comparing the behaviour with how -XIncoherentInstances worked when -it was only about the unify-check (note [Overlapping instances]): - -Example: - class C a b c where foo :: (a,b,c) - instance C [a] b Int - instance [incoherent] [Int] b c - instance [incoherent] C a Int c -Thanks to the incoherent flags, - [Wanted] C [a] b Int -works: Only instance one matches, the others just unify, but are marked -incoherent. - -So I can write - (foo :: ([a],b,Int)) :: ([Int], Int, Int). -but if that works then I really want to be able to write - foo :: ([Int], Int, Int) -as well. Now all three instances from above match. None is more specific than -another, so none is ruled out by the normal overlapping rules. One of them is -not incoherent, but we still want this to compile. Hence the -"all-but-one-logic". - -The implementation is in insert_overlapping, where we remove matching -incoherent instances as long as there are others. - - - -************************************************************************ -* * - Binding decisions -* * -************************************************************************ --} - -instanceBindFun :: TyCoVar -> BindFlag -instanceBindFun tv | isOverlappableTyVar tv = Skolem - | otherwise = BindMe - -- Note [Binding when looking up instances] - -{- -Note [Binding when looking up instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When looking up in the instance environment, or family-instance environment, -we are careful about multiple matches, as described above in -Note [Overlapping instances] - -The key_tys can contain skolem constants, and we can guarantee that those -are never going to be instantiated to anything, so we should not involve -them in the unification test. Example: - class Foo a where { op :: a -> Int } - instance Foo a => Foo [a] -- NB overlap - instance Foo [Int] -- NB overlap - data T = forall a. Foo a => MkT a - f :: T -> Int - f (MkT x) = op [x,x] -The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd -complain, saying that the choice of instance depended on the instantiation -of 'a'; but of course it isn't *going* to be instantiated. - -We do this only for isOverlappableTyVar skolems. For example we reject - g :: forall a => [a] -> Int - g x = op x -on the grounds that the correct instance depends on the instantiation of 'a' --} diff --git a/types/Kind.hs b/types/Kind.hs deleted file mode 100644 --- a/types/Kind.hs +++ /dev/null @@ -1,192 +0,0 @@ --- (c) The University of Glasgow 2006-2012 - -{-# LANGUAGE CPP #-} -module Kind ( - -- * Main data type - Kind, typeKind, - - -- ** Predicates on Kinds - isLiftedTypeKind, isUnliftedTypeKind, - isConstraintKind, - isTYPEApp, - returnsTyCon, returnsConstraintKind, - isConstraintKindCon, - okArrowArgKind, okArrowResultKind, - - classifiesTypeWithValues, - isStarKind, isStarKindSynonymTyCon, - tcIsStarKind, - isKindLevPoly - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} Type ( typeKind, coreView, tcView - , splitTyConApp_maybe ) -import {-# SOURCE #-} DataCon ( DataCon ) - -import TyCoRep -import TyCon -import PrelNames - -import Outputable -import Util - -{- -************************************************************************ -* * - Functions over Kinds -* * -************************************************************************ - -Note [Kind Constraint and kind *] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The kind Constraint is the kind of classes and other type constraints. -The special thing about types of kind Constraint is that - * They are displayed with double arrow: - f :: Ord a => a -> a - * They are implicitly instantiated at call sites; so the type inference - engine inserts an extra argument of type (Ord a) at every call site - to f. - -However, once type inference is over, there is *no* distinction between -Constraint and *. Indeed we can have coercions between the two. Consider - class C a where - op :: a -> a -For this single-method class we may generate a newtype, which in turn -generates an axiom witnessing - C a ~ (a -> a) -so on the left we have Constraint, and on the right we have *. -See Trac #7451. - -Bottom line: although '*' and 'Constraint' are distinct TyCons, with -distinct uniques, they are treated as equal at all times except -during type inference. --} - -isConstraintKind :: Kind -> Bool -isConstraintKindCon :: TyCon -> Bool - -isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey - -isConstraintKind (TyConApp tc _) = isConstraintKindCon tc -isConstraintKind _ = False - -isTYPEApp :: Kind -> Maybe DataCon -isTYPEApp (TyConApp tc args) - | tc `hasKey` tYPETyConKey - , [arg] <- args - , Just (tc, []) <- splitTyConApp_maybe arg - , Just dc <- isPromotedDataCon_maybe tc - = Just dc -isTYPEApp _ = Nothing - --- | Does the given type "end" in the given tycon? For example @k -> [a] -> *@ --- ends in @*@ and @Maybe a -> [a]@ ends in @[]@. -returnsTyCon :: Unique -> Type -> Bool -returnsTyCon tc_u (ForAllTy _ ty) = returnsTyCon tc_u ty -returnsTyCon tc_u (FunTy _ ty) = returnsTyCon tc_u ty -returnsTyCon tc_u (TyConApp tc' _) = tc' `hasKey` tc_u -returnsTyCon _ _ = False - -returnsConstraintKind :: Kind -> Bool -returnsConstraintKind = returnsTyCon constraintKindTyConKey - --- | Tests whether the given kind (which should look like @TYPE x@) --- is something other than a constructor tree (that is, constructors at every node). -isKindLevPoly :: Kind -> Bool -isKindLevPoly k = ASSERT2( isStarKind k || _is_type, ppr k ) - -- the isStarKind check is necessary b/c of Constraint - go k - where - go ty | Just ty' <- coreView ty = go ty' - go TyVarTy{} = True - go AppTy{} = True -- it can't be a TyConApp - go (TyConApp tc tys) = isFamilyTyCon tc || any go tys - go ForAllTy{} = True - go (FunTy t1 t2) = go t1 || go t2 - go LitTy{} = False - go CastTy{} = True - go CoercionTy{} = True - - _is_type - | TyConApp typ [_] <- k - = typ `hasKey` tYPETyConKey - | otherwise - = False - - --------------------------------------------- --- Kinding for arrow (->) --- Says when a kind is acceptable on lhs or rhs of an arrow --- arg -> res --- --- See Note [Levity polymorphism] - -okArrowArgKind, okArrowResultKind :: Kind -> Bool -okArrowArgKind = classifiesTypeWithValues -okArrowResultKind = classifiesTypeWithValues - ------------------------------------------ --- Subkinding --- The tc variants are used during type-checking, where ConstraintKind --- is distinct from all other kinds --- After type-checking (in core), Constraint and liftedTypeKind are --- indistinguishable - --- | Does this classify a type allowed to have values? Responds True to things --- like *, #, TYPE Lifted, TYPE v, Constraint. -classifiesTypeWithValues :: Kind -> Bool --- ^ True of any sub-kind of OpenTypeKind -classifiesTypeWithValues t | Just t' <- coreView t = classifiesTypeWithValues t' -classifiesTypeWithValues (TyConApp tc [_]) = tc `hasKey` tYPETyConKey -classifiesTypeWithValues _ = False - --- | Is this kind equivalent to *? -tcIsStarKind :: Kind -> Bool -tcIsStarKind k | Just k' <- tcView k = isStarKind k' -tcIsStarKind (TyConApp tc [TyConApp ptr_rep []]) - = tc `hasKey` tYPETyConKey - && ptr_rep `hasKey` liftedRepDataConKey -tcIsStarKind _ = False - --- | Is this kind equivalent to *? -isStarKind :: Kind -> Bool -isStarKind k | Just k' <- coreView k = isStarKind k' -isStarKind (TyConApp tc [TyConApp ptr_rep []]) - = tc `hasKey` tYPETyConKey - && ptr_rep `hasKey` liftedRepDataConKey -isStarKind _ = False - -- See Note [Kind Constraint and kind *] - --- | Is the tycon @Constraint@? -isStarKindSynonymTyCon :: TyCon -> Bool -isStarKindSynonymTyCon tc = tc `hasKey` constraintKindTyConKey - - -{- Note [Levity polymorphism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is this type legal? - (a :: TYPE rep) -> Int - where 'rep :: RuntimeRep' - -You might think not, because no lambda can have a -runtime-rep-polymorphic binder. So no lambda has the -above type. BUT here's a way it can be useful (taken from -Trac #12708): - - data T rep (a :: TYPE rep) - = MkT (a -> Int) - - x1 :: T LiftedRep Int - x1 = MkT LiftedRep Int (\x::Int -> 3) - - x2 :: T IntRep Int# - x2 = MkT IntRep Int# (\x:Int# -> 3) - -Note that the lambdas are just fine! - -Hence, okArrowArgKind and okArrowResultKind both just -check that the type is of the form (TYPE r) for some -representation type r. --} diff --git a/types/OptCoercion.hs b/types/OptCoercion.hs deleted file mode 100644 --- a/types/OptCoercion.hs +++ /dev/null @@ -1,968 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP #-} - --- The default iteration limit is a bit too low for the definitions --- in this module. -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-} -#endif - -module OptCoercion ( optCoercion, checkAxInstCo ) where - -#include "HsVersions.h" - -import DynFlags -import TyCoRep -import Coercion -import Type hiding( substTyVarBndr, substTy ) -import TcType ( exactTyCoVarsOfType ) -import TyCon -import CoAxiom -import VarSet -import VarEnv -import Outputable -import FamInstEnv ( flattenTys ) -import Pair -import ListSetOps ( getNth ) -import Util -import Unify -import InstEnv -import Control.Monad ( zipWithM ) - -{- -%************************************************************************ -%* * - Optimising coercions -%* * -%************************************************************************ - -Note [Optimising coercion optimisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Looking up a coercion's role or kind is linear in the size of the -coercion. Thus, doing this repeatedly during the recursive descent -of coercion optimisation is disastrous. We must be careful to avoid -doing this if at all possible. - -Because it is generally easy to know a coercion's components' roles -from the role of the outer coercion, we pass down the known role of -the input in the algorithm below. We also keep functions opt_co2 -and opt_co3 separate from opt_co4, so that the former two do Phantom -checks that opt_co4 can avoid. This is a big win because Phantom coercions -rarely appear within non-phantom coercions -- only in some TyConAppCos -and some AxiomInstCos. We handle these cases specially by calling -opt_co2. - -Note [Optimising InstCo] -~~~~~~~~~~~~~~~~~~~~~~~~ -When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. - -Let's look at the typing rules. - -h : k1 ~ k2 -tv:k1 |- g : t1 ~ t2 ------------------------------ -ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h]) - -g1 : (all tv:k1.t1') ~ (all tv:k2.t2') -g2 : s1 ~ s2 --------------------- -InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] - -We thus want some coercion proving this: - - (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h]) - -If we substitute the *type* tv for the *coercion* -(g2 `mkCoherenceRightCo` sym h) in g, we'll get this result exactly. -This is bizarre, -though, because we're substituting a type variable with a coercion. However, -this operation already exists: it's called *lifting*, and defined in Coercion. -We just need to enhance the lifting operation to be able to deal with -an ambient substitution, which is why a LiftingContext stores a TCvSubst. - --} - -optCoercion :: TCvSubst -> Coercion -> NormalCo --- ^ optCoercion applies a substitution to a coercion, --- *and* optimises it to reduce its size -optCoercion env co - | hasNoOptCoercion unsafeGlobalDynFlags = substCo env co - | debugIsOn - = let out_co = opt_co1 lc False co - (Pair in_ty1 in_ty2, in_role) = coercionKindRole co - (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co - in - ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 && - substTyUnchecked env in_ty2 `eqType` out_ty2 && - in_role == out_role - , text "optCoercion changed types!" - $$ hang (text "in_co:") 2 (ppr co) - $$ hang (text "in_ty1:") 2 (ppr in_ty1) - $$ hang (text "in_ty2:") 2 (ppr in_ty2) - $$ hang (text "out_co:") 2 (ppr out_co) - $$ hang (text "out_ty1:") 2 (ppr out_ty1) - $$ hang (text "out_ty2:") 2 (ppr out_ty2) - $$ hang (text "subst:") 2 (ppr env) ) - out_co - - | otherwise = opt_co1 lc False co - where - lc = mkSubstLiftingContext env - -type NormalCo = Coercion - -- Invariants: - -- * The substitution has been fully applied - -- * For trans coercions (co1 `trans` co2) - -- co1 is not a trans, and neither co1 nor co2 is identity - -type NormalNonIdCo = NormalCo -- Extra invariant: not the identity - --- | Do we apply a @sym@ to the result? -type SymFlag = Bool - --- | Do we force the result to be representational? -type ReprFlag = Bool - --- | Optimize a coercion, making no assumptions. All coercions in --- the lifting context are already optimized (and sym'd if nec'y) -opt_co1 :: LiftingContext - -> SymFlag - -> Coercion -> NormalCo -opt_co1 env sym co = opt_co2 env sym (coercionRole co) co - --- See Note [Optimising coercion optimisation] --- | Optimize a coercion, knowing the coercion's role. No other assumptions. -opt_co2 :: LiftingContext - -> SymFlag - -> Role -- ^ The role of the input coercion - -> Coercion -> NormalCo -opt_co2 env sym Phantom co = opt_phantom env sym co -opt_co2 env sym r co = opt_co3 env sym Nothing r co - --- See Note [Optimising coercion optimisation] --- | Optimize a coercion, knowing the coercion's non-Phantom role. -opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo -opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co -opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co - -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore -opt_co3 env sym _ r co = opt_co4_wrap env sym False r co - --- See Note [Optimising coercion optimisation] --- | Optimize a non-phantom coercion. -opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo - -opt_co4_wrap = opt_co4 -{- -opt_co4_wrap env sym rep r co - = pprTrace "opt_co4_wrap {" - ( vcat [ text "Sym:" <+> ppr sym - , text "Rep:" <+> ppr rep - , text "Role:" <+> ppr r - , text "Co:" <+> ppr co ]) $ - ASSERT( r == coercionRole co ) - let result = opt_co4 env sym rep r co in - pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ - result --} - -opt_co4 env _ rep r (Refl _r ty) - = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ - text "Found role:" <+> ppr _r $$ - text "Type:" <+> ppr ty ) - liftCoSubst (chooseRole rep r) env ty - -opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co - -- surprisingly, we don't have to do anything to the env here. This is - -- because any "lifting" substitutions in the env are tied to ForAllCos, - -- which treat their left and right sides differently. We don't want to - -- exchange them. - -opt_co4 env sym rep r g@(TyConAppCo _r tc cos) - = ASSERT( r == _r ) - case (rep, r) of - (True, Nominal) -> - mkTyConAppCo Representational tc - (zipWith3 (opt_co3 env sym) - (map Just (tyConRolesRepresentational tc)) - (repeat Nominal) - cos) - (False, Nominal) -> - mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) - (_, Representational) -> - -- must use opt_co2 here, because some roles may be P - -- See Note [Optimising coercion optimisation] - mkTyConAppCo r tc (zipWith (opt_co2 env sym) - (tyConRolesRepresentational tc) -- the current roles - cos) - (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) - -opt_co4 env sym rep r (AppCo co1 co2) - = mkAppCo (opt_co4_wrap env sym rep r co1) - (opt_co4_wrap env sym False Nominal co2) - -opt_co4 env sym rep r (ForAllCo tv k_co co) - = case optForAllCoBndr env sym tv k_co of - (env', tv', k_co') -> mkForAllCo tv' k_co' $ - opt_co4_wrap env' sym rep r co - -- Use the "mk" functions to check for nested Refls - -opt_co4 env sym rep r (FunCo _r co1 co2) - = ASSERT( r == _r ) - if rep - then mkFunCo Representational co1' co2' - else mkFunCo r co1' co2' - where - co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap env sym rep r co2 - -opt_co4 env sym rep r (CoVarCo cv) - | Just co <- lookupCoVar (lcTCvSubst env) cv - = opt_co4_wrap (zapLiftingContext env) sym rep r co - - | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] - = Refl (chooseRole rep r) ty1 - - | otherwise - = ASSERT( isCoVar cv1 ) - wrapRole rep r $ wrapSym sym $ - CoVarCo cv1 - - where - Pair ty1 ty2 = coVarTypes cv1 - - cv1 = case lookupInScope (lcInScopeSet env) cv of - Just cv1 -> cv1 - Nothing -> WARN( True, text "opt_co: not in scope:" - <+> ppr cv $$ ppr env) - cv - -- cv1 might have a substituted kind! - - -opt_co4 env sym rep r (AxiomInstCo con ind cos) - -- Do *not* push sym inside top-level axioms - -- e.g. if g is a top-level axiom - -- g a : f a ~ a - -- then (sym (g ty)) /= g (sym ty) !! - = ASSERT( r == coAxiomRole con ) - wrapRole rep (coAxiomRole con) $ - wrapSym sym $ - -- some sub-cos might be P: use opt_co2 - -- See Note [Optimising coercion optimisation] - AxiomInstCo con ind (zipWith (opt_co2 env False) - (coAxBranchRoles (coAxiomNthBranch con ind)) - cos) - -- Note that the_co does *not* have sym pushed into it - -opt_co4 env sym rep r (UnivCo prov _r t1 t2) - = ASSERT( r == _r ) - opt_univ env sym prov (chooseRole rep r) t1 t2 - -opt_co4 env sym rep r (TransCo co1 co2) - -- sym (g `o` h) = sym h `o` sym g - | sym = opt_trans in_scope co2' co1' - | otherwise = opt_trans in_scope co1' co2' - where - co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap env sym rep r co2 - in_scope = lcInScopeSet env - - -opt_co4 env sym rep r co@(NthCo {}) = opt_nth_co env sym rep r co - -opt_co4 env sym rep r (LRCo lr co) - | Just pr_co <- splitAppCo_maybe co - = ASSERT( r == Nominal ) - opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) - | Just pr_co <- splitAppCo_maybe co' - = ASSERT( r == Nominal ) - if rep - then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) - else pick_lr lr pr_co - | otherwise - = wrapRole rep Nominal $ LRCo lr co' - where - co' = opt_co4_wrap env sym False Nominal co - - pick_lr CLeft (l, _) = l - pick_lr CRight (_, r) = r - --- See Note [Optimising InstCo] -opt_co4 env sym rep r (InstCo co1 arg) - -- forall over type... - | Just (tv, kind_co, co_body) <- splitForAllCo_maybe co1 - = opt_co4_wrap (extendLiftingContext env tv - (arg' `mkCoherenceRightCo` mkSymCo kind_co)) - sym rep r co_body - - -- See if it is a forall after optimization - -- If so, do an inefficient one-variable substitution, then re-optimize - - -- forall over type... - | Just (tv', kind_co', co_body') <- splitForAllCo_maybe co1' - = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' - (arg' `mkCoherenceRightCo` mkSymCo kind_co')) - False False r' co_body' - - | otherwise = InstCo co1' arg' - where - co1' = opt_co4_wrap env sym rep r co1 - r' = chooseRole rep r - arg' = opt_co4_wrap env sym False Nominal arg - -opt_co4 env sym rep r (CoherenceCo co1 co2) - | TransCo col1 cor1 <- co1 - = opt_co4_wrap env sym rep r (mkTransCo (mkCoherenceCo col1 co2) cor1) - - | TransCo col1' cor1' <- co1' - = if sym then opt_trans in_scope col1' - (optCoercion (zapTCvSubst (lcTCvSubst env)) - (mkCoherenceRightCo cor1' co2')) - else opt_trans in_scope (mkCoherenceCo col1' co2') cor1' - - | otherwise - = wrapSym sym $ mkCoherenceCo (opt_co4_wrap env False rep r co1) co2' - where co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap env False False Nominal co2 - in_scope = lcInScopeSet env - -opt_co4 env sym _rep r (KindCo co) - = ASSERT( r == Nominal ) - let kco' = promoteCoercion co in - case kco' of - KindCo co' -> promoteCoercion (opt_co1 env sym co') - _ -> opt_co4_wrap env sym False Nominal kco' - -- This might be able to be optimized more to do the promotion - -- and substitution/optimization at the same time - -opt_co4 env sym _ r (SubCo co) - = ASSERT( r == Representational ) - opt_co4_wrap env sym True Nominal co - --- This could perhaps be optimized more. -opt_co4 env sym rep r (AxiomRuleCo co cs) - = ASSERT( r == coaxrRole co ) - wrapRole rep r $ - wrapSym sym $ - AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) - -{- Note [Optimise CoVarCo to Refl] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have (c :: t~t) we can optimise it to Refl. That increases the -chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t) - -We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo] -in Coercion. --} - -------------- --- | Optimize a phantom coercion. The input coercion may not necessarily --- be a phantom, but the output sure will be. -opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo -opt_phantom env sym co - = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 - where - Pair ty1 ty2 = coercionKind co - -{- Note [Differing kinds] - ~~~~~~~~~~~~~~~~~~~~~~ -The two types may not have the same kind (although that would be very unusual). -But even if they have the same kind, and the same type constructor, the number -of arguments in a `CoTyConApp` can differ. Consider - - Any :: forall k. k - - Any * Int :: * - Any (*->*) Maybe Int :: * - -Hence the need to compare argument lengths; see Trac #13658 - -} - -opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role - -> Type -> Type -> Coercion -opt_univ env sym (PhantomProv h) _r ty1 ty2 - | sym = mkPhantomCo h' ty2' ty1' - | otherwise = mkPhantomCo h' ty1' ty2' - where - h' = opt_co4 env sym False Nominal h - ty1' = substTy (lcSubstLeft env) ty1 - ty2' = substTy (lcSubstRight env) ty2 - -opt_univ env sym prov role oty1 oty2 - | Just (tc1, tys1) <- splitTyConApp_maybe oty1 - , Just (tc2, tys2) <- splitTyConApp_maybe oty2 - , tc1 == tc2 - , equalLength tys1 tys2 -- see Note [Differing kinds] - -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); - -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps - = let roles = tyConRolesX role tc1 - arg_cos = zipWith3 (mkUnivCo prov) roles tys1 tys2 - arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos - in - mkTyConAppCo role tc1 arg_cos' - - -- can't optimize the AppTy case because we can't build the kind coercions. - - | Just (tv1, ty1) <- splitForAllTy_maybe oty1 - , Just (tv2, ty2) <- splitForAllTy_maybe oty2 - -- NB: prov isn't interesting here either - = let k1 = tyVarKind tv1 - k2 = tyVarKind tv2 - eta = mkUnivCo prov Nominal k1 k2 - -- eta gets opt'ed soon, but not yet. - ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 - - (env', tv1', eta') = optForAllCoBndr env sym tv1 eta - in - mkForAllCo tv1' eta' (opt_univ env' sym prov role ty1 ty2') - - | otherwise - = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 - ty2 = substTyUnchecked (lcSubstRight env) oty2 - (a, b) | sym = (ty2, ty1) - | otherwise = (ty1, ty2) - in - mkUnivCo prov' role a b - - where - prov' = case prov of - UnsafeCoerceProv -> prov - PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco - ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco - PluginProv _ -> prov - HoleProv h -> pprPanic "opt_univ fell into a hole" (ppr h) - - -------------- --- NthCo must be handled separately, because it's the one case where we can't --- tell quickly what the component coercion's role is from the containing --- coercion. To avoid repeated coercionRole calls as opt_co1 calls opt_co2, --- we just look for nested NthCo's, which can happen in practice. -opt_nth_co :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo -opt_nth_co env sym rep r = go [] - where - go ns (NthCo n co) = go (n:ns) co - -- previous versions checked if the tycon is decomposable. This - -- is redundant, because a non-decomposable tycon under an NthCo - -- is entirely bogus. See docs/core-spec/core-spec.pdf. - go ns co - = opt_nths ns co - - -- try to resolve 1 Nth - push_nth n (Refl r1 ty) - | Just (tc, args) <- splitTyConApp_maybe ty - = Just (Refl (nthRole r1 tc n) (args `getNth` n)) - | n == 0 - , Just (tv, _) <- splitForAllTy_maybe ty - = Just (Refl Nominal (tyVarKind tv)) - push_nth n (TyConAppCo _ _ cos) - = Just (cos `getNth` n) - push_nth 0 (ForAllCo _ eta _) - = Just eta - push_nth _ _ = Nothing - - -- input coercion is *not* yet sym'd or opt'd - opt_nths [] co = opt_co4_wrap env sym rep r co - opt_nths (n:ns) co - | Just co' <- push_nth n co - = opt_nths ns co' - - -- here, the co isn't a TyConAppCo, so we opt it, hoping to get - -- a TyConAppCo as output. We don't know the role, so we use - -- opt_co1. This is slightly annoying, because opt_co1 will call - -- coercionRole, but as long as we don't have a long chain of - -- NthCo's interspersed with some other coercion former, we should - -- be OK. - opt_nths ns co = opt_nths' ns (opt_co1 env sym co) - - -- input coercion *is* sym'd and opt'd - opt_nths' [] co - = if rep && (r == Nominal) - -- propagate the SubCo: - then opt_co4_wrap (zapLiftingContext env) False True r co - else co - opt_nths' (n:ns) co - | Just co' <- push_nth n co - = opt_nths' ns co' - opt_nths' ns co = wrapRole rep r (mk_nths ns co) - - mk_nths [] co = co - mk_nths (n:ns) co = mk_nths ns (mkNthCo n co) - -------------- -opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] -opt_transList is = zipWith (opt_trans is) - -opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo -opt_trans is co1 co2 - | isReflCo co1 = co2 - | otherwise = opt_trans1 is co1 co2 - -opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo --- First arg is not the identity -opt_trans1 is co1 co2 - | isReflCo co2 = co1 - | otherwise = opt_trans2 is co1 co2 - -opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo --- Neither arg is the identity -opt_trans2 is (TransCo co1a co1b) co2 - -- Don't know whether the sub-coercions are the identity - = opt_trans is co1a (opt_trans is co1b co2) - -opt_trans2 is co1 co2 - | Just co <- opt_trans_rule is co1 co2 - = co - -opt_trans2 is co1 (TransCo co2a co2b) - | Just co1_2a <- opt_trans_rule is co1 co2a - = if isReflCo co1_2a - then co2b - else opt_trans1 is co1_2a co2b - -opt_trans2 _ co1 co2 - = mkTransCo co1 co2 - ------- --- Optimize coercions with a top-level use of transitivity. -opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo - --- Push transitivity through matching destructors -opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2) - | d1 == d2 - , co1 `compatible_co` co2 - = fireTransRule "PushNth" in_co1 in_co2 $ - mkNthCo d1 (opt_trans is co1 co2) - -opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) - | d1 == d2 - , co1 `compatible_co` co2 - = fireTransRule "PushLR" in_co1 in_co2 $ - mkLRCo d1 (opt_trans is co1 co2) - --- Push transitivity inside instantiation -opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) - | ty1 `eqCoercion` ty2 - , co1 `compatible_co` co2 - = fireTransRule "TrPushInst" in_co1 in_co2 $ - mkInstCo (opt_trans is co1 co2) ty1 - -opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) - in_co2@(UnivCo p2 r2 _tyl2 tyr2) - | Just prov' <- opt_trans_prov p1 p2 - = ASSERT( r1 == r2 ) - fireTransRule "UnivCo" in_co1 in_co2 $ - mkUnivCo prov' r1 tyl1 tyr2 - where - -- if the provenances are different, opt'ing will be very confusing - opt_trans_prov UnsafeCoerceProv UnsafeCoerceProv = Just UnsafeCoerceProv - opt_trans_prov (PhantomProv kco1) (PhantomProv kco2) - = Just $ PhantomProv $ opt_trans is kco1 kco2 - opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2) - = Just $ ProofIrrelProv $ opt_trans is kco1 kco2 - opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1 - opt_trans_prov _ _ = Nothing - --- Push transitivity down through matching top-level constructors. -opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) - | tc1 == tc2 - = ASSERT( r1 == r2 ) - fireTransRule "PushTyConApp" in_co1 in_co2 $ - mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) - -opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) - = fireTransRule "TrPushApp" in_co1 in_co2 $ - mkAppCo (opt_trans is co1a co2a) - (opt_trans is co1b co2b) - --- Eta rules -opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 - | Just cos2 <- etaTyConAppCo_maybe tc co2 - = ASSERT( length cos1 == length cos2 ) - fireTransRule "EtaCompL" co1 co2 $ - mkTyConAppCo r tc (opt_transList is cos1 cos2) - -opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) - | Just cos1 <- etaTyConAppCo_maybe tc co1 - = ASSERT( length cos1 == length cos2 ) - fireTransRule "EtaCompR" co1 co2 $ - mkTyConAppCo r tc (opt_transList is cos1 cos2) - -opt_trans_rule is co1@(AppCo co1a co1b) co2 - | Just (co2a,co2b) <- etaAppCo_maybe co2 - = fireTransRule "EtaAppL" co1 co2 $ - mkAppCo (opt_trans is co1a co2a) - (opt_trans is co1b co2b) - -opt_trans_rule is co1 co2@(AppCo co2a co2b) - | Just (co1a,co1b) <- etaAppCo_maybe co1 - = fireTransRule "EtaAppR" co1 co2 $ - mkAppCo (opt_trans is co1a co2a) - (opt_trans is co1b co2b) - --- Push transitivity inside forall -opt_trans_rule is co1 co2 - | ForAllCo tv1 eta1 r1 <- co1 - , Just (tv2,eta2,r2) <- etaForAllCo_maybe co2 - = push_trans tv1 eta1 r1 tv2 eta2 r2 - - | ForAllCo tv2 eta2 r2 <- co2 - , Just (tv1,eta1,r1) <- etaForAllCo_maybe co1 - = push_trans tv1 eta1 r1 tv2 eta2 r2 - - where - push_trans tv1 eta1 r1 tv2 eta2 r2 - = fireTransRule "EtaAllTy" co1 co2 $ - mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') - where - is' = is `extendInScopeSet` tv1 - r2' = substCoWithUnchecked [tv2] [TyVarTy tv1] r2 - --- Push transitivity inside axioms -opt_trans_rule is co1 co2 - - -- See Note [Why call checkAxInstCo during optimisation] - -- TrPushSymAxR - | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , True <- sym - , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst - - -- TrPushAxR - | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , False <- sym - , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushAxR" co1 co2 newAxInst - - -- TrPushSymAxL - | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , True <- sym - , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst - - -- TrPushAxL - | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , False <- sym - , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushAxL" co1 co2 newAxInst - - -- TrPushAxSym/TrPushSymAx - | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe - , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe - , con1 == con2 - , ind1 == ind2 - , sym1 == not sym2 - , let branch = coAxiomNthBranch con1 ind1 - qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch - lhs = coAxNthLHS con1 ind1 - rhs = coAxBranchRHS branch - pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs) - , all (`elemVarSet` pivot_tvs) qtvs - = fireTransRule "TrPushAxSym" co1 co2 $ - if sym2 - -- TrPushAxSym - then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs - -- TrPushSymAx - else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs - where - co1_is_axiom_maybe = isAxiom_maybe co1 - co2_is_axiom_maybe = isAxiom_maybe co2 - role = coercionRole co1 -- should be the same as coercionRole co2! - -opt_trans_rule is co1 co2 - | Just (lco, lh) <- isCohRight_maybe co1 - , Just (rco, rh) <- isCohLeft_maybe co2 - , (coercionType lh) `eqType` (coercionType rh) - = opt_trans_rule is lco rco - -opt_trans_rule _ co1 co2 -- Identity rule - | (Pair ty1 _, r) <- coercionKindRole co1 - , Pair _ ty2 <- coercionKind co2 - , ty1 `eqType` ty2 - = fireTransRule "RedTypeDirRefl" co1 co2 $ - Refl r ty2 - -opt_trans_rule _ _ _ = Nothing - -fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion -fireTransRule _rule _co1 _co2 res - = -- pprTrace ("Trans rule fired: " ++ _rule) (vcat [ppr _co1, ppr _co2, ppr res]) $ - Just res - -{- -Note [Conflict checking with AxiomInstCo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following type family and axiom: - -type family Equal (a :: k) (b :: k) :: Bool -type instance where - Equal a a = True - Equal a b = False --- -Equal :: forall k::*. k -> k -> Bool -axEqual :: { forall k::*. forall a::k. Equal k a a ~ True - ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } - -We wish to disallow (axEqual[1] <*> ) :: (Equal * Int Int ~ -False) and that all is OK. But, all is not OK: we want to use the first branch -of the axiom in this case, not the second. The problem is that the parameters -of the first branch can unify with the supplied coercions, thus meaning that -the first branch should be taken. See also Note [Apartness] in -types/FamInstEnv.hs. - -Note [Why call checkAxInstCo during optimisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible that otherwise-good-looking optimisations meet with disaster -in the presence of axioms with multiple equations. Consider - -type family Equal (a :: *) (b :: *) :: Bool where - Equal a a = True - Equal a b = False -type family Id (a :: *) :: * where - Id a = a - -axEq :: { [a::*]. Equal a a ~ True - ; [a::*, b::*]. Equal a b ~ False } -axId :: [a::*]. Id a ~ a - -co1 = Equal (axId[0] Int) (axId[0] Bool) - :: Equal (Id Int) (Id Bool) ~ Equal Int Bool -co2 = axEq[1] - :: Equal Int Bool ~ False - -We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that -co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what -happens when we push the coercions inside? We get - -co3 = axEq[1] (axId[0] Int) (axId[0] Bool) - :: Equal (Id Int) (Id Bool) ~ False - -which is bogus! This is because the type system isn't smart enough to know -that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type -families. At the time of writing, I (Richard Eisenberg) couldn't think of -a way of detecting this any more efficient than just building the optimised -coercion and checking. --} - --- | Check to make sure that an AxInstCo is internally consistent. --- Returns the conflicting branch, if it exists --- See Note [Conflict checking with AxiomInstCo] -checkAxInstCo :: Coercion -> Maybe CoAxBranch --- defined here to avoid dependencies in Coercion --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in CoreLint -checkAxInstCo (AxiomInstCo ax ind cos) - = let branch = coAxiomNthBranch ax ind - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - incomps = coAxBranchIncomps branch - (tys, cotys) = splitAtList tvs (map (pFst . coercionKind) cos) - co_args = map stripCoercionTy cotys - subst = zipTvSubst tvs tys `composeTCvSubst` - zipCvSubst cvs co_args - target = Type.substTys subst (coAxBranchLHS branch) - in_scope = mkInScopeSet $ - unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps) - flattened_target = flattenTys in_scope target in - check_no_conflict flattened_target incomps - where - check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch - check_no_conflict _ [] = Nothing - check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) - -- See Note [Apartness] in FamInstEnv - | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp - = check_no_conflict flat rest - | otherwise - = Just b -checkAxInstCo _ = Nothing - - ------------ -wrapSym :: SymFlag -> Coercion -> Coercion -wrapSym sym co | sym = SymCo co - | otherwise = co - --- | Conditionally set a role to be representational -wrapRole :: ReprFlag - -> Role -- ^ current role - -> Coercion -> Coercion -wrapRole False _ = id -wrapRole True current = downgradeRole Representational current - --- | If we require a representational role, return that. Otherwise, --- return the "default" role provided. -chooseRole :: ReprFlag - -> Role -- ^ "default" role - -> Role -chooseRole True _ = Representational -chooseRole _ r = r - ------------ -isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) -isAxiom_maybe (SymCo co) - | Just (sym, con, ind, cos) <- isAxiom_maybe co - = Just (not sym, con, ind, cos) -isAxiom_maybe (AxiomInstCo con ind cos) - = Just (False, con, ind, cos) -isAxiom_maybe _ = Nothing - -matchAxiom :: Bool -- True = match LHS, False = match RHS - -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] -matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co - | CoAxBranch { cab_tvs = qtvs - , cab_cvs = [] -- can't infer these, so fail if there are any - , cab_roles = roles - , cab_lhs = lhs - , cab_rhs = rhs } <- coAxiomNthBranch ax ind - , Just subst <- liftCoMatch (mkVarSet qtvs) - (if sym then (mkTyConApp tc lhs) else rhs) - co - , all (`isMappedByLC` subst) qtvs - = zipWithM (liftCoSubstTyVar subst) roles qtvs - - | otherwise - = Nothing - -------------- --- destruct a CoherenceCo -isCohLeft_maybe :: Coercion -> Maybe (Coercion, Coercion) -isCohLeft_maybe (CoherenceCo co1 co2) = Just (co1, co2) -isCohLeft_maybe _ = Nothing - --- destruct a (sym (co1 |> co2)). --- if isCohRight_maybe co = Just (co1, co2), then (sym co1) `mkCohRightCo` co2 = co -isCohRight_maybe :: Coercion -> Maybe (Coercion, Coercion) -isCohRight_maybe (SymCo (CoherenceCo co1 co2)) = Just (mkSymCo co1, co2) -isCohRight_maybe _ = Nothing - -------------- -compatible_co :: Coercion -> Coercion -> Bool --- Check whether (co1 . co2) will be well-kinded -compatible_co co1 co2 - = x1 `eqType` x2 - where - Pair _ x1 = coercionKind co1 - Pair x2 _ = coercionKind co2 - -------------- -{- -etaForAllCo_maybe -~~~~~~~~~~~~~~~~~ -Suppose we have - - g : all a1:k1.t1 ~ all a2:k2.t2 - -but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: - - g' = all a1:(ForAllKindCo g).(InstCo g (a1 `mkCoherenceRightCo` ForAllKindCo g)) - -Call the kind coercion h1 and the body coercion h2. We can see that - - h2 : t1 ~ t2[a2 |-> (a1 |> h2)] - -According to the typing rule for ForAllCo, we get that - - g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h2)][a1 |-> a1 |> sym h2]) - -or - - g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) - -as desired. --} -etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) --- Try to make the coercion be of form (forall tv:kind_co. co) -etaForAllCo_maybe co - | ForAllCo tv kind_co r <- co - = Just (tv, kind_co, r) - - | Pair ty1 ty2 <- coercionKind co - , Just (tv1, _) <- splitForAllTy_maybe ty1 - , isForAllTy ty2 - , let kind_co = mkNthCo 0 co - = Just ( tv1, kind_co - , mkInstCo co (mkNomReflCo (TyVarTy tv1) `mkCoherenceRightCo` kind_co) ) - - | otherwise - = Nothing - -etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) --- If possible, split a coercion --- g :: t1a t1b ~ t2a t2b --- into a pair of coercions (left g, right g) -etaAppCo_maybe co - | Just (co1,co2) <- splitAppCo_maybe co - = Just (co1,co2) - | (Pair ty1 ty2, Nominal) <- coercionKindRole co - , Just (_,t1) <- splitAppTy_maybe ty1 - , Just (_,t2) <- splitAppTy_maybe ty2 - , let isco1 = isCoercionTy t1 - , let isco2 = isCoercionTy t2 - , isco1 == isco2 - = Just (LRCo CLeft co, LRCo CRight co) - | otherwise - = Nothing - -etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] --- If possible, split a coercion --- g :: T s1 .. sn ~ T t1 .. tn --- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] -etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) - = ASSERT( tc == tc2 ) Just cos2 - -etaTyConAppCo_maybe tc co - | mightBeUnsaturatedTyCon tc - , (Pair ty1 ty2, r) <- coercionKindRole co - , Just (tc1, tys1) <- splitTyConApp_maybe ty1 - , Just (tc2, tys2) <- splitTyConApp_maybe ty2 - , tc1 == tc2 - , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in TyCoRep - , let n = length tys1 - = ASSERT( tc == tc1 ) - ASSERT( n == length tys2 ) - Just (decomposeCo n co) - -- NB: n might be <> tyConArity tc - -- e.g. data family T a :: * -> * - -- g :: T a b ~ T c d - - | otherwise - = Nothing - -{- -Note [Eta for AppCo] -~~~~~~~~~~~~~~~~~~~~ -Suppose we have - g :: s1 t1 ~ s2 t2 - -Then we can't necessarily make - left g :: s1 ~ s2 - right g :: t1 ~ t2 -because it's possible that - s1 :: * -> * t1 :: * - s2 :: (*->*) -> * t2 :: * -> * -and in that case (left g) does not have the same -kind on either side. - -It's enough to check that - kind t1 = kind t2 -because if g is well-kinded then - kind (s1 t2) = kind (s2 t2) -and these two imply - kind s1 = kind s2 - --} - -optForAllCoBndr :: LiftingContext -> Bool - -> TyVar -> Coercion -> (LiftingContext, TyVar, Coercion) -optForAllCoBndr env sym - = substForAllCoBndrCallbackLC sym (opt_co4_wrap env sym False Nominal) env diff --git a/types/TyCoRep.hs b/types/TyCoRep.hs deleted file mode 100644 --- a/types/TyCoRep.hs +++ /dev/null @@ -1,2866 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 -\section[TyCoRep]{Type and Coercion - friends' interface} - -Note [The Type-related module hierarchy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Class - CoAxiom - TyCon imports Class, CoAxiom - TyCoRep imports Class, CoAxiom, TyCon - TysPrim imports TyCoRep ( including mkTyConTy ) - Kind imports TysPrim ( mainly for primitive kinds ) - Type imports Kind - Coercion imports Type --} - --- We expose the relevant stuff from this module via the Type module -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf #-} -{-# LANGUAGE ImplicitParams #-} - -module TyCoRep ( - TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, - - -- * Types - Type(..), - TyLit(..), - KindOrType, Kind, - PredType, ThetaType, -- Synonyms - ArgFlag(..), - - -- * Coercions - Coercion(..), - UnivCoProvenance(..), CoercionHole(..), - CoercionN, CoercionR, CoercionP, KindCoercion, - - -- * Functions over types - mkTyConTy, mkTyVarTy, mkTyVarTys, - mkFunTy, mkFunTys, mkForAllTy, mkForAllTys, - mkPiTy, mkPiTys, - isLiftedTypeKind, isUnliftedTypeKind, - isCoercionType, isRuntimeRepTy, isRuntimeRepVar, - isRuntimeRepKindedTy, dropRuntimeRepArgs, - sameVis, - - -- * Functions over binders - TyBinder(..), TyVarBinder, - binderVar, binderVars, binderKind, binderArgFlag, - delBinderVar, - isInvisibleArgFlag, isVisibleArgFlag, - isInvisibleBinder, isVisibleBinder, - - -- * Functions over coercions - pickLR, - - -- * Pretty-printing - pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, - pprSigmaType, - pprTheta, pprForAll, pprUserForAll, - pprTyVar, pprTyVars, - pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, pprTyLit, - TyPrec(..), maybeParen, pprTcAppCo, - pprPrefixApp, pprArrowChain, - pprDataCons, ppSuggestExplicitKinds, - - -- * Free variables - tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet, - tyCoFVsBndr, tyCoFVsOfType, tyCoVarsOfTypeList, - tyCoFVsOfTypes, tyCoVarsOfTypesList, - closeOverKindsDSet, closeOverKindsFV, closeOverKindsList, - coVarsOfType, coVarsOfTypes, - coVarsOfCo, coVarsOfCos, - tyCoVarsOfCo, tyCoVarsOfCos, - tyCoVarsOfCoDSet, - tyCoFVsOfCo, tyCoFVsOfCos, - tyCoVarsOfCoList, tyCoVarsOfProv, - closeOverKinds, - - noFreeVarsOfType, noFreeVarsOfCo, - - -- * Substitutions - TCvSubst(..), TvSubstEnv, CvSubstEnv, - emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, - emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, - mkTCvSubst, mkTvSubst, - getTvSubstEnv, - getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, - isInScope, notElemTCvSubst, - setTvSubstEnv, setCvSubstEnv, zapTCvSubst, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, - extendTCvSubst, - extendCvSubst, extendCvSubstWithClone, - extendTvSubst, extendTvSubstBinder, extendTvSubstWithClone, - extendTvSubstList, extendTvSubstAndInScope, - unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet, - zipTvSubst, zipCvSubst, - mkTvSubstPrs, - - substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, - substCoWith, - substTy, substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTyWithInScope, - substTys, substTheta, - lookupTyVar, substTyVarBndr, - substCo, substCos, substCoVar, substCoVars, lookupCoVar, - substCoVarBndr, cloneTyVarBndr, cloneTyVarBndrs, - substTyVar, substTyVars, - substForAllCoBndr, - substTyVarBndrCallback, substForAllCoBndrCallback, - checkValidSubst, isValidTCvSubst, - - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyOpenKind, - tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars, - tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyVarOcc, - tidyTopType, - tidyKind, - tidyCo, tidyCos, - tidyTyVarBinder, tidyTyVarBinders, - - -- * Sizes - typeSize, coercionSize, provSize - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} DataCon( dataConFullSig - , dataConUnivTyVarBinders, dataConExTyVarBinders - , DataCon, filterEqSpec ) -import {-# SOURCE #-} Type( isPredTy, isCoercionTy, mkAppTy, mkCastTy - , tyCoVarsOfTypesWellScoped - , tyCoVarsOfTypeWellScoped - , coreView, typeKind ) - -- Transitively pulls in a LOT of stuff, better to break the loop - -import {-# SOURCE #-} Coercion -import {-# SOURCE #-} ConLike ( ConLike(..), conLikeName ) -import {-# SOURCE #-} ToIface( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr - , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercion ) - --- friends: -import IfaceType -import Var -import VarEnv -import VarSet -import Name hiding ( varName ) -import TyCon -import Class -import CoAxiom -import FV - --- others -import BasicTypes ( LeftOrRight(..), TyPrec(..), maybeParen, pickLR ) -import PrelNames -import Outputable -import DynFlags -import FastString -import Pair -import UniqSupply -import Util -import UniqFM -import UniqSet - --- libraries -import qualified Data.Data as Data hiding ( TyCon ) -import Data.List -import Data.IORef ( IORef ) -- for CoercionHole - -{- -%************************************************************************ -%* * - TyThing -%* * -%************************************************************************ - -Despite the fact that DataCon has to be imported via a hi-boot route, -this module seems the right place for TyThing, because it's needed for -funTyCon and all the types in TysPrim. - -It is also SOURCE-imported into Name.hs - - -Note [ATyCon for classes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Both classes and type constructors are represented in the type environment -as ATyCon. You can tell the difference, and get to the class, with - isClassTyCon :: TyCon -> Bool - tyConClass_maybe :: TyCon -> Maybe Class -The Class and its associated TyCon have the same Name. --} - --- | A global typecheckable-thing, essentially anything that has a name. --- Not to be confused with a 'TcTyThing', which is also a typecheckable --- thing but in the *local* context. See 'TcEnv' for how to retrieve --- a 'TyThing' given a 'Name'. -data TyThing - = AnId Id - | AConLike ConLike - | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] - | ACoAxiom (CoAxiom Branched) - -instance Outputable TyThing where - ppr = pprShortTyThing - -instance NamedThing TyThing where -- Can't put this with the type - getName (AnId id) = getName id -- decl, because the DataCon instance - getName (ATyCon tc) = getName tc -- isn't visible there - getName (ACoAxiom cc) = getName cc - getName (AConLike cl) = conLikeName cl - -pprShortTyThing :: TyThing -> SDoc --- c.f. PprTyThing.pprTyThing, which prints all the details -pprShortTyThing thing - = pprTyThingCategory thing <+> quotes (ppr (getName thing)) - -pprTyThingCategory :: TyThing -> SDoc -pprTyThingCategory = text . capitalise . tyThingCategory - -tyThingCategory :: TyThing -> String -tyThingCategory (ATyCon tc) - | isClassTyCon tc = "class" - | otherwise = "type constructor" -tyThingCategory (ACoAxiom _) = "coercion axiom" -tyThingCategory (AnId _) = "identifier" -tyThingCategory (AConLike (RealDataCon _)) = "data constructor" -tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" - - -{- ********************************************************************** -* * - Type -* * -********************************************************************** -} - --- | The key representation of types within the compiler - -type KindOrType = Type -- See Note [Arguments to type constructors] - --- | The key type representing kinds in the compiler. -type Kind = Type - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Type - -- See Note [Non-trivial definitional equality] - = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) - - | AppTy - Type - Type -- ^ Type application to something other than a 'TyCon'. Parameters: - -- - -- 1) Function: must /not/ be a 'TyConApp', - -- must be another 'AppTy', or 'TyVarTy' - -- - -- 2) Argument type - - | TyConApp - TyCon - [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. - -- Invariant: saturated applications of 'FunTyCon' must - -- use 'FunTy' and saturated synonyms must use their own - -- constructors. However, /unsaturated/ 'FunTyCon's - -- do appear as 'TyConApp's. - -- Parameters: - -- - -- 1) Type constructor being applied to. - -- - -- 2) Type arguments. Might not have enough type arguments - -- here to saturate the constructor. - -- Even type synonyms are not necessarily saturated; - -- for example unsaturated type synonyms - -- can appear as the right hand side of a type synonym. - - | ForAllTy - {-# UNPACK #-} !TyVarBinder - Type -- ^ A Π type. - - | FunTy Type Type -- ^ t1 -> t2 Very common, so an important special case - - | LitTy TyLit -- ^ Type literals are similar to type constructors. - - | CastTy - Type - KindCoercion -- ^ A kind cast. The coercion is always nominal. - -- INVARIANT: The cast is never refl. - -- INVARIANT: The cast is "pushed down" as far as it - -- can go. See Note [Pushing down casts] - - | CoercionTy - Coercion -- ^ Injection of a Coercion into a type - -- This should only ever be used in the RHS of an AppTy, - -- in the list of a TyConApp, when applying a promoted - -- GADT data constructor - - deriving Data.Data - - --- NOTE: Other parts of the code assume that type literals do not contain --- types or type variables. -data TyLit - = NumTyLit Integer - | StrTyLit FastString - deriving (Eq, Ord, Data.Data) - -{- Note [Arguments to type constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because of kind polymorphism, in addition to type application we now -have kind instantiation. We reuse the same notations to do so. - -For example: - - Just (* -> *) Maybe - Right * Nat Zero - -are represented by: - - TyConApp (PromotedDataCon Just) [* -> *, Maybe] - TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] - -Important note: Nat is used as a *kind* and not as a type. This can be -confusing, since type-level Nat and kind-level Nat are identical. We -use the kind of (PromotedDataCon Right) to know if its arguments are -kinds or types. - -This kind instantiation only happens in TyConApp currently. - -Note [Pushing down casts] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (a :: k1 -> *), (b :: k1), and (co :: * ~ q). -The type (a b |> co) is `eqType` to ((a |> co') b), where -co' = (->) co. Thus, to make this visible to functions -that inspect types, we always push down coercions, preferring -the second form. Note that this also applies to TyConApps! - -Note [Non-trivial definitional equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is Int |> <*> the same as Int? YES! In order to reduce headaches, -we decide that any reflexive casts in types are just ignored. More -generally, the `eqType` function, which defines Core's type equality -relation, ignores casts and coercion arguments, as long as the -two types have the same kind. This allows us to be a little sloppier -in keeping track of coercions, which is a good thing. It also means -that eqType does not depend on eqCoercion, which is also a good thing. - -Why is this sensible? That is, why is something different than α-equivalence -appropriate for the implementation of eqType? - -Anything smaller than ~ and homogeneous is an appropriate definition for -equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any -expression of type τ can be transmuted to one of type σ at any point by -casting. The same is true of types of type τ. So in some sense, τ and σ are -interchangeable. - -But let's be more precise. If we examine the typing rules of FC (say, those in -http://www.cis.upenn.edu/~eir/papers/2015/equalities/equalities-extended.pdf) -there are several places where the same metavariable is used in two different -premises to a rule. (For example, see Ty_App.) There is an implicit equality -check here. What definition of equality should we use? By convention, we use -α-equivalence. Take any rule with one (or more) of these implicit equality -checks. Then there is an admissible rule that uses ~ instead of the implicit -check, adding in casts as appropriate. - -The only problem here is that ~ is heterogeneous. To make the kinds work out -in the admissible rule that uses ~, it is necessary to homogenize the -coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η; -we use η |> kind η, which is homogeneous. - -The effect of this all is that eqType, the implementation of the implicit -equality check, can use any homogeneous relation that is smaller than ~, as -those rules must also be admissible. - -What would go wrong if we insisted on the casts matching? See the beginning of -Section 8 in the unpublished paper above. Theoretically, nothing at all goes -wrong. But in practical terms, getting the coercions right proved to be -nightmarish. And types would explode: during kind-checking, we often produce -reflexive kind coercions. When we try to cast by these, mkCastTy just discards -them. But if we used an eqType that distinguished between Int and Int |> <*>, -then we couldn't discard -- the output of kind-checking would be enormous, -and we would need enormous casts with lots of CoherenceCo's to straighten -them out. - -Would anything go wrong if eqType respected type families? No, not at all. But -that makes eqType rather hard to implement. - -Thus, the guideline for eqType is that it should be the largest -easy-to-implement relation that is still smaller than ~ and homogeneous. The -precise choice of relation is somewhat incidental, as long as the smart -constructors and destructors in Type respect whatever relation is chosen. - -Another helpful principle with eqType is this: - - ** If (t1 eqType t2) then I can replace t1 by t2 anywhere. ** - -This principle also tells us that eqType must relate only types with the -same kinds. --} - -{- ********************************************************************** -* * - TyBinder and ArgFlag -* * -********************************************************************** -} - --- | A 'TyBinder' represents an argument to a function. TyBinders can be dependent --- ('Named') or nondependent ('Anon'). They may also be visible or not. --- See Note [TyBinders] -data TyBinder - = Named TyVarBinder -- A type-lambda binder - | Anon Type -- A term-lambda binder - -- Visibility is determined by the type (Constraint vs. *) - deriving Data.Data - --- | Remove the binder's variable from the set, if the binder has --- a variable. -delBinderVar :: VarSet -> TyVarBinder -> VarSet -delBinderVar vars (TvBndr tv _) = vars `delVarSet` tv - --- | Does this binder bind an invisible argument? -isInvisibleBinder :: TyBinder -> Bool -isInvisibleBinder (Named (TvBndr _ vis)) = isInvisibleArgFlag vis -isInvisibleBinder (Anon ty) = isPredTy ty - --- | Does this binder bind a visible argument? -isVisibleBinder :: TyBinder -> Bool -isVisibleBinder = not . isInvisibleBinder - - -{- Note [TyBinders] -~~~~~~~~~~~~~~~~~~~ -A ForAllTy contains a TyVarBinder. But a type can be decomposed -to a telescope consisting of a [TyBinder] - -A TyBinder represents the type of binders -- that is, the type of an -argument to a Pi-type. GHC Core currently supports two different -Pi-types: - - * A non-dependent function type, - written with ->, e.g. ty1 -> ty2 - represented as FunTy ty1 ty2. These are - lifted to Coercions with the corresponding FunCo. - - * A dependent compile-time-only polytype, - written with forall, e.g. forall (a:*). ty - represented as ForAllTy (TvBndr a v) ty - -Both Pi-types classify terms/types that take an argument. In other -words, if `x` is either a function or a polytype, `x arg` makes sense -(for an appropriate `arg`). - - -Note [TyBinders and ArgFlags] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A ForAllTy contains a TyVarBinder. Each TyVarBinder is equipped -with a ArgFlag, which says whether or not arguments for this -binder should be visible (explicit) in source Haskell. - ------------------------------------------------------------------------ - Occurrences look like this - TyBinder GHC displays type as in Haskell souce code ------------------------------------------------------------------------ -In the type of a term - Anon: f :: type -> type Arg required: f x - Named Inferred: f :: forall {a}. type Arg not allowed: f - Named Specified: f :: forall a. type Arg optional: f or f @Int - Named Required: Illegal: See Note [No Required TyBinder in terms] - -In the kind of a type - Anon: T :: kind -> kind Required: T * - Named Inferred: T :: forall {k}. kind Arg not allowed: T - Named Specified: T :: forall k. kind Arg not allowed[1]: T - Named Required: T :: forall k -> kind Required: T * ------------------------------------------------------------------------- - -[1] In types, in the Specified case, it would make sense to allow - optional kind applications, thus (T @*), but we have not - yet implemented that - ----- Examples of where the different visiblities come from ----- - -In term declarations: - -* Inferred. Function defn, with no signature: f1 x = x - We infer f1 :: forall {a}. a -> a, with 'a' Inferred - It's Inferred because it doesn't appear in any - user-written signature for f1 - -* Specified. Function defn, with signature (implicit forall): - f2 :: a -> a; f2 x = x - So f2 gets the type f2 :: forall a. a->a, with 'a' Specified - even though 'a' is not bound in the source code by an explicit forall - -* Specified. Function defn, with signature (explicit forall): - f3 :: forall a. a -> a; f3 x = x - So f3 gets the type f3 :: forall a. a->a, with 'a' Specified - -* Inferred/Specified. Function signature with inferred kind polymorphism. - f4 :: a b -> Int - So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int - Here 'k' is Inferred (it's not mentioned in the type), - but 'a' and 'b' are Specified. - -* Specified. Function signature with explicit kind polymorphism - f5 :: a (b :: k) -> Int - This time 'k' is Specified, because it is mentioned explicitly, - so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int - -* Similarly pattern synonyms: - Inferred - from inferred types (e.g. no pattern type signature) - - or from inferred kind polymorphism - -In type declarations: - -* Inferred (k) - data T1 a b = MkT1 (a b) - Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * - The kind variable 'k' is Inferred, since it is not mentioned - - Note that 'a' and 'b' correspond to /Anon/ TyBinders in T1's kind, - and Anon binders don't have a visibility flag. (Or you could think - of Anon having an implicit Required flag.) - -* Specified (k) - data T2 (a::k->*) b = MkT (a b) - Here T's kind is T :: forall (k:*). (k->*) -> k -> * - The kind variable 'k' is Specified, since it is mentioned in - the signature. - -* Required (k) - data T k (a::k->*) b = MkT (a b) - Here T's kind is T :: forall k:* -> (k->*) -> k -> * - The kind is Required, since it bound in a positional way in T's declaration - Every use of T must be explicitly applied to a kind - -* Inferred (k1), Specified (k) - data T a b (c :: k) = MkT (a b) (Proxy c) - Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * - So 'k' is Specified, because it appears explicitly, - but 'k1' is Inferred, because it does not - ----- Printing ----- - - We print forall types with enough syntax to tell you their visiblity - flag. But this is not source Haskell, and these types may not all - be parsable. - - Specified: a list of Specified binders is written between `forall` and `.`: - const :: forall a b. a -> b -> a - - Inferred: with -fprint-explicit-foralls, Inferred binders are written - in braces: - f :: forall {k} (a:k). S k a -> Int - Otherwise, they are printed like Specified binders. - - Required: binders are put between `forall` and `->`: - T :: forall k -> * - ----- Other points ----- - -* In classic Haskell, all named binders (that is, the type variables in - a polymorphic function type f :: forall a. a -> a) have been Inferred. - -* Inferred variables correspond to "generalized" variables from the - Visible Type Applications paper (ESOP'16). - -Note [No Required TyBinder in terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't allow Required foralls for term variables, including pattern -synonyms and data constructors. Why? Because then an application -would need a /compulsory/ type argument (possibly without an "@"?), -thus (f Int); and we don't have concrete syntax for that. - -We could change this decision, but Required, Named TyBinders are rare -anyway. (Most are Anons.) --} - - -{- ********************************************************************** -* * - PredType -* * -********************************************************************** -} - - --- | A type of the form @p@ of kind @Constraint@ represents a value whose type is --- the Haskell predicate @p@, where a predicate is what occurs before --- the @=>@ in a Haskell type. --- --- We use 'PredType' as documentation to mark those types that we guarantee to have --- this kind. --- --- It can be expanded into its representation, but: --- --- * The type checker must treat it as opaque --- --- * The rest of the compiler treats it as transparent --- --- Consider these examples: --- --- > f :: (Eq a) => a -> Int --- > g :: (?x :: Int -> Int) => a -> Int --- > h :: (r\l) => {r} => {l::Int | r} --- --- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" -type PredType = Type - --- | A collection of 'PredType's -type ThetaType = [PredType] - -{- -(We don't support TREX records yet, but the setup is designed -to expand to allow them.) - -A Haskell qualified type, such as that for f,g,h above, is -represented using - * a FunTy for the double arrow - * with a type of kind Constraint as the function argument - -The predicate really does turn into a real extra argument to the -function. If the argument has type (p :: Constraint) then the predicate p is -represented by evidence of type p. - - -%************************************************************************ -%* * - Simple constructors -%* * -%************************************************************************ - -These functions are here so that they can be used by TysPrim, -which in turn is imported by Type --} - --- named with "Only" to prevent naive use of mkTyVarTy -mkTyVarTy :: TyVar -> Type -mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) - TyVarTy v - -mkTyVarTys :: [TyVar] -> [Type] -mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy - -infixr 3 `mkFunTy` -- Associates to the right --- | Make an arrow type -mkFunTy :: Type -> Type -> Type -mkFunTy arg res = FunTy arg res - --- | Make nested arrow types -mkFunTys :: [Type] -> Type -> Type -mkFunTys tys ty = foldr mkFunTy ty tys - -mkForAllTy :: TyVar -> ArgFlag -> Type -> Type -mkForAllTy tv vis ty = ForAllTy (TvBndr tv vis) ty - --- | Wraps foralls over the type using the provided 'TyVar's from left to right -mkForAllTys :: [TyVarBinder] -> Type -> Type -mkForAllTys tyvars ty = foldr ForAllTy ty tyvars - -mkPiTy :: TyBinder -> Type -> Type -mkPiTy (Anon ty1) ty2 = FunTy ty1 ty2 -mkPiTy (Named tvb) ty = ForAllTy tvb ty - -mkPiTys :: [TyBinder] -> Type -> Type -mkPiTys tbs ty = foldr mkPiTy ty tbs - --- | Does this type classify a core (unlifted) Coercion? --- At either role nominal or representational --- (t1 ~# t2) or (t1 ~R# t2) -isCoercionType :: Type -> Bool -isCoercionType (TyConApp tc tys) - | (tc `hasKey` eqPrimTyConKey) || (tc `hasKey` eqReprPrimTyConKey) - , length tys == 4 - = True -isCoercionType _ = False - - --- | Create the plain type constructor type which has been applied to no type arguments at all. -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = TyConApp tycon [] - -{- -Some basic functions, put here to break loops eg with the pretty printer --} - -is_TYPE :: ( Type -- the single argument to TYPE; not a synonym - -> Bool ) -- what to return - -> Kind -> Bool -is_TYPE f ki | Just ki' <- coreView ki = is_TYPE f ki' -is_TYPE f (TyConApp tc [arg]) - | tc `hasKey` tYPETyConKey - = go arg - where - go ty | Just ty' <- coreView ty = go ty' - go ty = f ty -is_TYPE _ _ = False - --- | This version considers Constraint to be distinct from *. Returns True --- if the argument is equivalent to Type and False otherwise. -isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind = is_TYPE is_lifted - where - is_lifted (TyConApp lifted_rep []) = lifted_rep `hasKey` liftedRepDataConKey - is_lifted _ = False - --- | Returns True if the kind classifies unlifted types and False otherwise. --- Note that this returns False for levity-polymorphic kinds, which may --- be specialized to a kind that classifies unlifted types. -isUnliftedTypeKind :: Kind -> Bool -isUnliftedTypeKind = is_TYPE is_unlifted - where - is_unlifted (TyConApp rr _args) = not (rr `hasKey` liftedRepDataConKey) - is_unlifted _ = False - --- | Is this the type 'RuntimeRep'? -isRuntimeRepTy :: Type -> Bool -isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' -isRuntimeRepTy (TyConApp tc []) = tc `hasKey` runtimeRepTyConKey -isRuntimeRepTy _ = False - --- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) -isRuntimeRepKindedTy :: Type -> Bool -isRuntimeRepKindedTy = isRuntimeRepTy . typeKind - --- | Is a tyvar of type 'RuntimeRep'? -isRuntimeRepVar :: TyVar -> Bool -isRuntimeRepVar = isRuntimeRepTy . tyVarKind - --- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. --- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: --- --- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep --- , String, Int# ] == [String, Int#] --- -dropRuntimeRepArgs :: [Type] -> [Type] -dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy - -{- -%************************************************************************ -%* * - Coercions -%* * -%************************************************************************ --} - --- | A 'Coercion' is concrete evidence of the equality/convertibility --- of two types. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Coercion - -- Each constructor has a "role signature", indicating the way roles are - -- propagated through coercions. - -- - P, N, and R stand for coercions of the given role - -- - e stands for a coercion of a specific unknown role - -- (think "role polymorphism") - -- - "e" stands for an explicit role parameter indicating role e. - -- - _ stands for a parameter that is not a Role or Coercion. - - -- These ones mirror the shape of types - = -- Refl :: "e" -> _ -> e - Refl Role Type -- See Note [Refl invariant] - -- Invariant: applications of (Refl T) to a bunch of identity coercions - -- always show up as Refl. - -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). - - -- Applications of (Refl T) to some coercions, at least one of - -- which is NOT the identity, show up as TyConAppCo. - -- (They may not be fully saturated however.) - -- ConAppCo coercions (like all coercions other than Refl) - -- are NEVER the identity. - - -- Use (Refl Representational _), not (SubCo (Refl Nominal _)) - - -- These ones simply lift the correspondingly-named - -- Type constructors into Coercions - - -- TyConAppCo :: "e" -> _ -> ?? -> e - -- See Note [TyConAppCo roles] - | TyConAppCo Role TyCon [Coercion] -- lift TyConApp - -- The TyCon is never a synonym; - -- we expand synonyms eagerly - -- But it can be a type function - - | AppCo Coercion CoercionN -- lift AppTy - -- AppCo :: e -> N -> e - - -- See Note [Forall coercions] - | ForAllCo TyVar KindCoercion Coercion - -- ForAllCo :: _ -> N -> e -> e - - | FunCo Role Coercion Coercion -- lift FunTy - -- FunCo :: "e" -> e -> e -> e - - -- These are special - | CoVarCo CoVar -- :: _ -> (N or R) - -- result role depends on the tycon of the variable's type - - -- AxiomInstCo :: e -> _ -> [N] -> e - | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] - -- See also [CoAxiom index] - -- The coercion arguments always *precisely* saturate - -- arity of (that branch of) the CoAxiom. If there are - -- any left over, we use AppCo. - -- See [Coercion axioms applied to coercions] - - | UnivCo UnivCoProvenance Role Type Type - -- :: _ -> "e" -> _ -> _ -> e - - | SymCo Coercion -- :: e -> e - | TransCo Coercion Coercion -- :: e -> e -> e - - -- The number coercions should match exactly the expectations - -- of the CoAxiomRule (i.e., the rule is fully saturated). - | AxiomRuleCo CoAxiomRule [Coercion] - - | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) - -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles]) - -- Using NthCo on a ForAllCo gives an N coercion always - -- See Note [NthCo and newtypes] - - | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) - -- :: _ -> N -> N - | InstCo Coercion CoercionN - -- :: e -> N -> e - -- See Note [InstCo roles] - - -- Coherence applies a coercion to the left-hand type of another coercion - -- See Note [Coherence] - | CoherenceCo Coercion KindCoercion - -- :: e -> N -> e - - -- Extract a kind coercion from a (heterogeneous) type coercion - -- NB: all kind coercions are Nominal - | KindCo Coercion - -- :: e -> N - - | SubCo CoercionN -- Turns a ~N into a ~R - -- :: N -> R - - deriving Data.Data - -type CoercionN = Coercion -- always nominal -type CoercionR = Coercion -- always representational -type CoercionP = Coercion -- always phantom -type KindCoercion = CoercionN -- always nominal - -{- -Note [Refl invariant] -~~~~~~~~~~~~~~~~~~~~~ -Invariant 1: - -Coercions have the following invariant - Refl is always lifted as far as possible. - -You might think that a consequencs is: - Every identity coercions has Refl at the root - -But that's not quite true because of coercion variables. Consider - g where g :: Int~Int - Left h where h :: Maybe Int ~ Maybe Int -etc. So the consequence is only true of coercions that -have no coercion variables. - -Note [Coercion axioms applied to coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The reason coercion axioms can be applied to coercions and not just -types is to allow for better optimization. There are some cases where -we need to be able to "push transitivity inside" an axiom in order to -expose further opportunities for optimization. - -For example, suppose we have - - C a : t[a] ~ F a - g : b ~ c - -and we want to optimize - - sym (C b) ; t[g] ; C c - -which has the kind - - F b ~ F c - -(stopping through t[b] and t[c] along the way). - -We'd like to optimize this to just F g -- but how? The key is -that we need to allow axioms to be instantiated by *coercions*, -not just by types. Then we can (in certain cases) push -transitivity inside the axiom instantiations, and then react -opposite-polarity instantiations of the same axiom. In this -case, e.g., we match t[g] against the LHS of (C c)'s kind, to -obtain the substitution a |-> g (note this operation is sort -of the dual of lifting!) and hence end up with - - C g : t[b] ~ F c - -which indeed has the same kind as t[g] ; C c. - -Now we have - - sym (C b) ; C g - -which can be optimized to F g. - -Note [CoAxiom index] -~~~~~~~~~~~~~~~~~~~~ -A CoAxiom has 1 or more branches. Each branch has contains a list -of the free type variables in that branch, the LHS type patterns, -and the RHS type for that branch. When we apply an axiom to a list -of coercions, we must choose which branch of the axiom we wish to -use, as the different branches may have different numbers of free -type variables. (The number of type patterns is always the same -among branches, but that doesn't quite concern us here.) - -The Int in the AxiomInstCo constructor is the 0-indexed number -of the chosen branch. - -Note [Forall coercions] -~~~~~~~~~~~~~~~~~~~~~~~ -Constructing coercions between forall-types can be a bit tricky, -because the kinds of the bound tyvars can be different. - -The typing rule is: - - - kind_co : k1 ~ k2 - tv1:k1 |- co : t1 ~ t2 - ------------------------------------------------------------------- - ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ - all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) - -First, the TyVar stored in a ForAllCo is really an optimisation: this field -should be a Name, as its kind is redundant. Thinking of the field as a Name -is helpful in understanding what a ForAllCo means. - -The idea is that kind_co gives the two kinds of the tyvar. See how, in the -conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. - -Of course, a type variable can't have different kinds at the same time. So, -we arbitrarily prefer the first kind when using tv1 in the inner coercion -co, which shows that t1 equals t2. - -The last wrinkle is that we need to fix the kinds in the conclusion. In -t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of -the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with -(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it -mentions the same name with different kinds, but it *is* well-kinded, noting -that `(tv1:k2) |> sym kind_co` has kind k1. - -This all really would work storing just a Name in the ForAllCo. But we can't -add Names to, e.g., VarSets, and there generally is just an impedance mismatch -in a bunch of places. So we use tv1. When we need tv2, we can use -setTyVarKind. - -Note [Coherence] -~~~~~~~~~~~~~~~~ -The Coherence typing rule is thus: - - g1 : s ~ t s : k1 g2 : k1 ~ k2 - ------------------------------------ - CoherenceCo g1 g2 : (s |> g2) ~ t - -While this looks (and is) unsymmetric, a combination of other coercion -combinators can make the symmetric version. - -For role information, see Note [Roles and kind coercions]. - -Note [Predicate coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - g :: a~b -How can we coerce between types - ([c]~a) => [a] -> c -and - ([c]~b) => [b] -> c -where the equality predicate *itself* differs? - -Answer: we simply treat (~) as an ordinary type constructor, so these -types really look like - - ((~) [c] a) -> [a] -> c - ((~) [c] b) -> [b] -> c - -So the coercion between the two is obviously - - ((~) [c] g) -> [g] -> c - -Another way to see this to say that we simply collapse predicates to -their representation type (see Type.coreView and Type.predTypeRep). - -This collapse is done by mkPredCo; there is no PredCo constructor -in Coercion. This is important because we need Nth to work on -predicates too: - Nth 1 ((~) [c] g) = g -See Simplify.simplCoercionF, which generates such selections. - -Note [Roles] -~~~~~~~~~~~~ -Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated -in Trac #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see -http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation - -Here is one way to phrase the problem: - -Given: -newtype Age = MkAge Int -type family F x -type instance F Age = Bool -type instance F Int = Char - -This compiles down to: -axAge :: Age ~ Int -axF1 :: F Age ~ Bool -axF2 :: F Int ~ Char - -Then, we can make: -(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char - -Yikes! - -The solution is _roles_, as articulated in "Generative Type Abstraction and -Type-level Computation" (POPL 2010), available at -http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf - -The specification for roles has evolved somewhat since that paper. For the -current full details, see the documentation in docs/core-spec. Here are some -highlights. - -We label every equality with a notion of type equivalence, of which there are -three options: Nominal, Representational, and Phantom. A ground type is -nominally equivalent only with itself. A newtype (which is considered a ground -type in Haskell) is representationally equivalent to its representation. -Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" -to denote the equivalences. - -The axioms above would be: -axAge :: Age ~R Int -axF1 :: F Age ~N Bool -axF2 :: F Age ~N Char - -Then, because transitivity applies only to coercions proving the same notion -of equivalence, the above construction is impossible. - -However, there is still an escape hatch: we know that any two types that are -nominally equivalent are representationally equivalent as well. This is what -the form SubCo proves -- it "demotes" a nominal equivalence into a -representational equivalence. So, it would seem the following is possible: - -sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG - -What saves us here is that the arguments to a type function F, lifted into a -coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and -we are safe. - -Roles are attached to parameters to TyCons. When lifting a TyCon into a -coercion (through TyConAppCo), we need to ensure that the arguments to the -TyCon respect their roles. For example: - -data T a b = MkT a (F b) - -If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know -that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because -the type function F branches on b's *name*, not representation. So, we say -that 'a' has role Representational and 'b' has role Nominal. The third role, -Phantom, is for parameters not used in the type's definition. Given the -following definition - -data Q a = MkQ Int - -the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we -can construct the coercion Bool ~P Char (using UnivCo). - -See the paper cited above for more examples and information. - -Note [TyConAppCo roles] -~~~~~~~~~~~~~~~~~~~~~~~ -The TyConAppCo constructor has a role parameter, indicating the role at -which the coercion proves equality. The choice of this parameter affects -the required roles of the arguments of the TyConAppCo. To help explain -it, assume the following definition: - - type instance F Int = Bool -- Axiom axF : F Int ~N Bool - newtype Age = MkAge Int -- Axiom axAge : Age ~R Int - data Foo a = MkFoo a -- Role on Foo's parameter is Representational - -TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool - For (TyConAppCo Nominal) all arguments must have role Nominal. Why? - So that Foo Age ~N Foo Int does *not* hold. - -TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool -TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int - For (TyConAppCo Representational), all arguments must have the roles - corresponding to the result of tyConRoles on the TyCon. This is the - whole point of having roles on the TyCon to begin with. So, we can - have Foo Age ~R Foo Int, if Foo's parameter has role R. - - If a Representational TyConAppCo is over-saturated (which is otherwise fine), - the spill-over arguments must all be at Nominal. This corresponds to the - behavior for AppCo. - -TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool - All arguments must have role Phantom. This one isn't strictly - necessary for soundness, but this choice removes ambiguity. - -The rules here dictate the roles of the parameters to mkTyConAppCo -(should be checked by Lint). - -Note [NthCo and newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype N a = MkN Int - type role N representational - -This yields axiom - - NTCo:N :: forall a. N a ~R Int - -We can then build - - co :: forall a b. N a ~R N b - co = NTCo:N a ; sym (NTCo:N b) - -for any `a` and `b`. Because of the role annotation on N, if we use -NthCo, we'll get out a representational coercion. That is: - - NthCo 0 co :: forall a b. a ~R b - -Yikes! Clearly, this is terrible. The solution is simple: forbid -NthCo to be used on newtypes if the internal coercion is representational. - -This is not just some corner case discovered by a segfault somewhere; -it was discovered in the proof of soundness of roles and described -in the "Safe Coercions" paper (ICFP '14). - -Note [InstCo roles] -~~~~~~~~~~~~~~~~~~~ -Here is (essentially) the typing rule for InstCo: - -g :: (forall a. t1) ~r (forall a. t2) -w :: s1 ~N s2 -------------------------------- InstCo -InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) - -Note that the Coercion w *must* be nominal. This is necessary -because the variable a might be used in a "nominal position" -(that is, a place where role inference would require a nominal -role) in t1 or t2. If we allowed w to be representational, we -could get bogus equalities. - -A more nuanced treatment might be able to relax this condition -somewhat, by checking if t1 and/or t2 use their bound variables -in nominal ways. If not, having w be representational is OK. - - -%************************************************************************ -%* * - UnivCoProvenance -%* * -%************************************************************************ - -A UnivCo is a coercion whose proof does not directly express its role -and kind (indeed for some UnivCos, like UnsafeCoerceProv, there /is/ -no proof). - -The different kinds of UnivCo are described by UnivCoProvenance. Really -each is entirely separate, but they all share the need to represent their -role and kind, which is done in the UnivCo constructor. - --} - --- | For simplicity, we have just one UnivCo that represents a coercion from --- some type to some other type, with (in general) no restrictions on the --- type. The UnivCoProvenance specifies more exactly what the coercion really --- is and why a program should (or shouldn't!) trust the coercion. --- It is reasonable to consider each constructor of 'UnivCoProvenance' --- as a totally independent coercion form; their only commonality is --- that they don't tell you what types they coercion between. (That info --- is in the 'UnivCo' constructor of 'Coercion'. -data UnivCoProvenance - = UnsafeCoerceProv -- ^ From @unsafeCoerce#@. These are unsound. - - | PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom - -- roled coercions - - | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are - -- considered equivalent. See Note [ProofIrrelProv]. - -- Can be used in Nominal or Representational coercions - - | PluginProv String -- ^ From a plugin, which asserts that this coercion - -- is sound. The string is for the use of the plugin. - - | HoleProv CoercionHole -- ^ See Note [Coercion holes] - deriving Data.Data - -instance Outputable UnivCoProvenance where - ppr UnsafeCoerceProv = text "(unsafeCoerce#)" - ppr (PhantomProv _) = text "(phantom)" - ppr (ProofIrrelProv _) = text "(proof irrel.)" - ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) - ppr (HoleProv hole) = parens (text "hole" <> ppr hole) - --- | A coercion to be filled in by the type-checker. See Note [Coercion holes] -data CoercionHole - = CoercionHole { chUnique :: Unique -- ^ used only for debugging - , chCoercion :: IORef (Maybe Coercion) - } - -instance Data.Data CoercionHole where - -- don't traverse? - toConstr _ = abstractConstr "CoercionHole" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "CoercionHole" - -instance Outputable CoercionHole where - ppr (CoercionHole u _) = braces (ppr u) - - -{- Note [Phantom coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = T1 | T2 -Then we have - T s ~R T t -for any old s,t. The witness for this is (TyConAppCo T Rep co), -where (co :: s ~P t) is a phantom coercion built with PhantomProv. -The role of the UnivCo is always Phantom. The Coercion stored is the -(nominal) kind coercion between the types - kind(s) ~N kind (t) - -Note [Coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~ -During typechecking, constraint solving for type classes works by - - Generate an evidence Id, d7 :: Num a - - Wrap it in a Wanted constraint, [W] d7 :: Num a - - Use the evidence Id where the evidence is needed - - Solve the constraint later - - When solved, add an enclosing let-binding let d7 = .... in .... - which actually binds d7 to the (Num a) evidence - -For equality constraints we use a different strategy. See Note [The -equality types story] in TysPrim for background on equality constraints. - - For boxed equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just - like type classes above. (Indeed, boxed equality constraints *are* classes.) - - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2) - we use a different plan - -For unboxed equalities: - - Generate a CoercionHole, a mutable variable just like a unification - variable - - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest - - Use the CoercionHole in a Coercion, via HoleProv - - Solve the constraint later - - When solved, fill in the CoercionHole by side effect, instead of - doing the let-binding thing - -The main reason for all this is that there may be no good place to let-bind -the evidence for unboxed equalities: - - We emit constraints for kind coercions, to be used - to cast a type's kind. These coercions then must be used in types. Because - they might appear in a top-level type, there is no place to bind these - (unlifted) coercions in the usual way. - - - A coercion for (forall a. t1) ~ forall a. t2) will look like - forall a. (coercion for t1~t2) - But the coercion for (t1~t2) may mention 'a', and we don't have let-bindings - within coercions. We could add them, but coercion holes are easier. - -Other notes about HoleCo: - - * INVARIANT: CoercionHole and HoleProv are used only during type checking, - and should never appear in Core. Just like unification variables; a Type - can contain a TcTyVar, but only during type checking. If, one day, we - use type-level information to separate out forms that can appear during - type-checking vs forms that can appear in core proper, holes in Core will - be ruled out. - - * The Unique carried with a coercion hole is used solely for debugging. - - * Coercion holes can be compared for equality only like other coercions: - only by looking at the types coerced. - - * We don't use holes for other evidence because other evidence wants to - be /shared/. But coercions are entirely erased, so there's little - benefit to sharing. - -Note [ProofIrrelProv] -~~~~~~~~~~~~~~~~~~~~~ -A ProofIrrelProv is a coercion between coercions. For example: - - data G a where - MkG :: G Bool - -In core, we get - - G :: * -> * - MkG :: forall (a :: *). (a ~ Bool) -> G a - -Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want -a proof that ('MkG co1 a1) ~ ('MkG co2 a2). This will have to be - - TyConAppCo Nominal MkG [co3, co4] - where - co3 :: co1 ~ co2 - co4 :: a1 ~ a2 - -Note that - co1 :: a1 ~ Bool - co2 :: a2 ~ Bool - -Here, - co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) - where - co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) - co5 = TyConAppCo Nominal (~) [<*>, <*>, co4, ] - - -%************************************************************************ -%* * - Free variables of types and coercions -%* * -%************************************************************************ --} - -{- Note [Free variables of types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns -a VarSet that is closed over the types of its variables. More precisely, - if S = tyCoVarsOfType( t ) - and (a:k) is in S - then tyCoVarsOftype( k ) is a subset of S - -Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. - -We could /not/ close over the kinds of the variable occurrences, and -instead do so at call sites, but it seems that we always want to do -so, so it's easiest to do it here. --} - - --- | Returns free variables of a type, including kind variables as --- a non-deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfType :: Type -> TyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty - --- | `tyVarsOfType` that returns free variables of a type in a deterministic --- set. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. -tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty - --- | `tyVarsOfType` that returns free variables of a type in deterministic --- order. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. -tyCoVarsOfTypeList :: Type -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty - --- | The worker for `tyVarsOfType` and `tyVarsOfTypeList`. --- The previous implementation used `unionVarSet` which is O(n+m) and can --- make the function quadratic. --- It's exported, so that it can be composed with --- other functions that compute free variables. --- See Note [FV naming conventions] in FV. --- --- Eta-expanded because that makes it run faster (apparently) --- See Note [FV eta expansion] in FV for explanation. -tyCoFVsOfType :: Type -> FV --- See Note [Free variables of types] -tyCoFVsOfType (TyVarTy v) a b c = (unitFV v `unionFV` tyCoFVsOfType (tyVarKind v)) a b c -tyCoFVsOfType (TyConApp _ tys) a b c = tyCoFVsOfTypes tys a b c -tyCoFVsOfType (LitTy {}) a b c = emptyFV a b c -tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c -tyCoFVsOfType (FunTy arg res) a b c = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) a b c -tyCoFVsOfType (ForAllTy bndr ty) a b c = tyCoFVsBndr bndr (tyCoFVsOfType ty) a b c -tyCoFVsOfType (CastTy ty co) a b c = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) a b c -tyCoFVsOfType (CoercionTy co) a b c = tyCoFVsOfCo co a b c - -tyCoFVsBndr :: TyVarBinder -> FV -> FV --- Free vars of (forall b. ) -tyCoFVsBndr (TvBndr tv _) fvs = (delFV tv fvs) - `unionFV` tyCoFVsOfType (tyVarKind tv) - --- | Returns free variables of types, including kind variables as --- a non-deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypes :: [Type] -> TyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypes tys = fvVarSet $ tyCoFVsOfTypes tys - --- | Returns free variables of types, including kind variables as --- a non-deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypesSet :: TyVarEnv Type -> TyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypesSet tys = fvVarSet $ tyCoFVsOfTypes $ nonDetEltsUFM tys - -- It's OK to use nonDetEltsUFM here because we immediately forget the - -- ordering by returning a set - --- | Returns free variables of types, including kind variables as --- a deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys - --- | Returns free variables of types, including kind variables as --- a deterministically ordered list. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypesList :: [Type] -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys - -tyCoFVsOfTypes :: [Type] -> FV --- See Note [Free variables of types] -tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc -tyCoFVsOfTypes [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc - -tyCoVarsOfCo :: Coercion -> TyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfCo co = fvVarSet $ tyCoFVsOfCo co - --- | Get a deterministic set of the vars free in a coercion -tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co - -tyCoVarsOfCoList :: Coercion -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co - -tyCoFVsOfCo :: Coercion -> FV --- Extracts type and coercion variables from a coercion --- See Note [Free variables of types] -tyCoFVsOfCo (Refl _ ty) fv_cand in_scope acc = tyCoFVsOfType ty fv_cand in_scope acc -tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc -tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc - = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc -tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc - = (delFV tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc -tyCoFVsOfCo (FunCo _ co1 co2) fv_cand in_scope acc - = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc -tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc - = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc -tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc -tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc - = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 - `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc -tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc -tyCoFVsOfCo (NthCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc -tyCoFVsOfCo (CoherenceCo c1 c2) fv_cand in_scope acc = (tyCoFVsOfCo c1 `unionFV` tyCoFVsOfCo c2) fv_cand in_scope acc -tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc - -tyCoVarsOfProv :: UnivCoProvenance -> TyCoVarSet -tyCoVarsOfProv prov = fvVarSet $ tyCoFVsOfProv prov - -tyCoFVsOfProv :: UnivCoProvenance -> FV -tyCoFVsOfProv UnsafeCoerceProv fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfProv (HoleProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc - -tyCoVarsOfCos :: [Coercion] -> TyCoVarSet -tyCoVarsOfCos cos = fvVarSet $ tyCoFVsOfCos cos - -tyCoVarsOfCosSet :: CoVarEnv Coercion -> TyCoVarSet -tyCoVarsOfCosSet cos = fvVarSet $ tyCoFVsOfCos $ nonDetEltsUFM cos - -- It's OK to use nonDetEltsUFM here because we immediately forget the - -- ordering by returning a set - -tyCoFVsOfCos :: [Coercion] -> FV -tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc - -coVarsOfType :: Type -> CoVarSet -coVarsOfType (TyVarTy v) = coVarsOfType (tyVarKind v) -coVarsOfType (TyConApp _ tys) = coVarsOfTypes tys -coVarsOfType (LitTy {}) = emptyVarSet -coVarsOfType (AppTy fun arg) = coVarsOfType fun `unionVarSet` coVarsOfType arg -coVarsOfType (FunTy arg res) = coVarsOfType arg `unionVarSet` coVarsOfType res -coVarsOfType (ForAllTy (TvBndr tv _) ty) - = (coVarsOfType ty `delVarSet` tv) - `unionVarSet` coVarsOfType (tyVarKind tv) -coVarsOfType (CastTy ty co) = coVarsOfType ty `unionVarSet` coVarsOfCo co -coVarsOfType (CoercionTy co) = coVarsOfCo co - -coVarsOfTypes :: [Type] -> TyCoVarSet -coVarsOfTypes tys = mapUnionVarSet coVarsOfType tys - -coVarsOfCo :: Coercion -> CoVarSet --- Extract *coercion* variables only. Tiresome to repeat the code, but easy. -coVarsOfCo (Refl _ ty) = coVarsOfType ty -coVarsOfCo (TyConAppCo _ _ args) = coVarsOfCos args -coVarsOfCo (AppCo co arg) = coVarsOfCo co `unionVarSet` coVarsOfCo arg -coVarsOfCo (ForAllCo tv kind_co co) - = coVarsOfCo co `delVarSet` tv `unionVarSet` coVarsOfCo kind_co -coVarsOfCo (FunCo _ co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 -coVarsOfCo (CoVarCo v) = unitVarSet v `unionVarSet` coVarsOfType (varType v) -coVarsOfCo (AxiomInstCo _ _ args) = coVarsOfCos args -coVarsOfCo (UnivCo p _ t1 t2) = coVarsOfProv p `unionVarSet` coVarsOfTypes [t1, t2] -coVarsOfCo (SymCo co) = coVarsOfCo co -coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 -coVarsOfCo (NthCo _ co) = coVarsOfCo co -coVarsOfCo (LRCo _ co) = coVarsOfCo co -coVarsOfCo (InstCo co arg) = coVarsOfCo co `unionVarSet` coVarsOfCo arg -coVarsOfCo (CoherenceCo c1 c2) = coVarsOfCos [c1, c2] -coVarsOfCo (KindCo co) = coVarsOfCo co -coVarsOfCo (SubCo co) = coVarsOfCo co -coVarsOfCo (AxiomRuleCo _ cs) = coVarsOfCos cs - -coVarsOfProv :: UnivCoProvenance -> CoVarSet -coVarsOfProv UnsafeCoerceProv = emptyVarSet -coVarsOfProv (PhantomProv co) = coVarsOfCo co -coVarsOfProv (ProofIrrelProv co) = coVarsOfCo co -coVarsOfProv (PluginProv _) = emptyVarSet -coVarsOfProv (HoleProv _) = emptyVarSet - -coVarsOfCos :: [Coercion] -> CoVarSet -coVarsOfCos cos = mapUnionVarSet coVarsOfCo cos - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a non-deterministic set. -closeOverKinds :: TyVarSet -> TyVarSet -closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet - -- It's OK to use nonDetEltsUniqSet here because we immediately forget - -- about the ordering by returning a set. - --- | Given a list of tyvars returns a deterministic FV computation that --- returns the given tyvars with the kind variables free in the kinds of the --- given tyvars. -closeOverKindsFV :: [TyVar] -> FV -closeOverKindsFV tvs = - mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a deterministically ordered list. -closeOverKindsList :: [TyVar] -> [TyVar] -closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a deterministic set. -closeOverKindsDSet :: DTyVarSet -> DTyVarSet -closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems - --- | Returns True if this type has no free variables. Should be the same as --- isEmptyVarSet . tyCoVarsOfType, but faster in the non-forall case. -noFreeVarsOfType :: Type -> Bool -noFreeVarsOfType (TyVarTy _) = False -noFreeVarsOfType (AppTy t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 -noFreeVarsOfType (TyConApp _ tys) = all noFreeVarsOfType tys -noFreeVarsOfType ty@(ForAllTy {}) = isEmptyVarSet (tyCoVarsOfType ty) -noFreeVarsOfType (FunTy t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 -noFreeVarsOfType (LitTy _) = True -noFreeVarsOfType (CastTy ty co) = noFreeVarsOfType ty && noFreeVarsOfCo co -noFreeVarsOfType (CoercionTy co) = noFreeVarsOfCo co - --- | Returns True if this coercion has no free variables. Should be the same as --- isEmptyVarSet . tyCoVarsOfCo, but faster in the non-forall case. -noFreeVarsOfCo :: Coercion -> Bool -noFreeVarsOfCo (Refl _ ty) = noFreeVarsOfType ty -noFreeVarsOfCo (TyConAppCo _ _ args) = all noFreeVarsOfCo args -noFreeVarsOfCo (AppCo c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 -noFreeVarsOfCo co@(ForAllCo {}) = isEmptyVarSet (tyCoVarsOfCo co) -noFreeVarsOfCo (FunCo _ c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 -noFreeVarsOfCo (CoVarCo _) = False -noFreeVarsOfCo (AxiomInstCo _ _ args) = all noFreeVarsOfCo args -noFreeVarsOfCo (UnivCo p _ t1 t2) = noFreeVarsOfProv p && - noFreeVarsOfType t1 && - noFreeVarsOfType t2 -noFreeVarsOfCo (SymCo co) = noFreeVarsOfCo co -noFreeVarsOfCo (TransCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 -noFreeVarsOfCo (NthCo _ co) = noFreeVarsOfCo co -noFreeVarsOfCo (LRCo _ co) = noFreeVarsOfCo co -noFreeVarsOfCo (InstCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 -noFreeVarsOfCo (CoherenceCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 -noFreeVarsOfCo (KindCo co) = noFreeVarsOfCo co -noFreeVarsOfCo (SubCo co) = noFreeVarsOfCo co -noFreeVarsOfCo (AxiomRuleCo _ cs) = all noFreeVarsOfCo cs - --- | Returns True if this UnivCoProv has no free variables. Should be the same as --- isEmptyVarSet . tyCoVarsOfProv, but faster in the non-forall case. -noFreeVarsOfProv :: UnivCoProvenance -> Bool -noFreeVarsOfProv UnsafeCoerceProv = True -noFreeVarsOfProv (PhantomProv co) = noFreeVarsOfCo co -noFreeVarsOfProv (ProofIrrelProv co) = noFreeVarsOfCo co -noFreeVarsOfProv (PluginProv {}) = True -noFreeVarsOfProv (HoleProv {}) = True -- matches with coVarsOfProv, but I'm unsure - -{- -%************************************************************************ -%* * - Substitutions - Data type defined here to avoid unnecessary mutual recursion -%* * -%************************************************************************ --} - --- | Type & coercion substitution --- --- #tcvsubst_invariant# --- The following invariants must hold of a 'TCvSubst': --- --- 1. The in-scope set is needed /only/ to --- guide the generation of fresh uniques --- --- 2. In particular, the /kind/ of the type variables in --- the in-scope set is not relevant --- --- 3. The substitution is only applied ONCE! This is because --- in general such application will not reach a fixed point. -data TCvSubst - = TCvSubst InScopeSet -- The in-scope type and kind variables - TvSubstEnv -- Substitutes both type and kind variables - CvSubstEnv -- Substitutes coercion variables - -- See Note [Apply Once] - -- and Note [Extending the TvSubstEnv] - -- and Note [Substituting types and coercions] - -- and Note [The substitution invariant] - --- | A substitution of 'Type's for 'TyVar's --- and 'Kind's for 'KindVar's -type TvSubstEnv = TyVarEnv Type - -- A TvSubstEnv is used both inside a TCvSubst (with the apply-once - -- invariant discussed in Note [Apply Once]), and also independently - -- in the middle of matching, and unification (see Types.Unify) - -- So you have to look at the context to know if it's idempotent or - -- apply-once or whatever - --- | A substitution of 'Coercion's for 'CoVar's -type CvSubstEnv = CoVarEnv Coercion - -{- -Note [Apply Once] -~~~~~~~~~~~~~~~~~ -We use TCvSubsts to instantiate things, and we might instantiate - forall a b. ty -\with the types - [a, b], or [b, a]. -So the substitution might go [a->b, b->a]. A similar situation arises in Core -when we find a beta redex like - (/\ a /\ b -> e) b a -Then we also end up with a substitution that permutes type variables. Other -variations happen to; for example [a -> (a, b)]. - - **************************************************** - *** So a TCvSubst must be applied precisely once *** - **************************************************** - -A TCvSubst is not idempotent, but, unlike the non-idempotent substitution -we use during unifications, it must not be repeatedly applied. - -Note [Extending the TvSubstEnv] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #tcvsubst_invariant# for the invariants that must hold. - -This invariant allows a short-cut when the subst envs are empty: -if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) -holds --- then (substTy subst ty) does nothing. - -For example, consider: - (/\a. /\b:(a~Int). ...b..) Int -We substitute Int for 'a'. The Unique of 'b' does not change, but -nevertheless we add 'b' to the TvSubstEnv, because b's kind does change - -This invariant has several crucial consequences: - -* In substTyVarBndr, we need extend the TvSubstEnv - - if the unique has changed - - or if the kind has changed - -* In substTyVar, we do not need to consult the in-scope set; - the TvSubstEnv is enough - -* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty - -Note [Substituting types and coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Types and coercions are mutually recursive, and either may have variables -"belonging" to the other. Thus, every time we wish to substitute in a -type, we may also need to substitute in a coercion, and vice versa. -However, the constructor used to create type variables is distinct from -that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note -that it would be possible to use the CoercionTy constructor to combine -these environments, but that seems like a false economy. - -Note that the TvSubstEnv should *never* map a CoVar (built with the Id -constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, -the range of the TvSubstEnv should *never* include a type headed with -CoercionTy. - -Note [The substitution invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When calling (substTy subst ty) it should be the case that -the in-scope set in the substitution is a superset of both: - - * The free vars of the range of the substitution - * The free vars of ty minus the domain of the substitution - -If we want to substitute [a -> ty1, b -> ty2] I used to -think it was enough to generate an in-scope set that includes -fv(ty1,ty2). But that's not enough; we really should also take the -free vars of the type we are substituting into! Example: - (forall b. (a,b,x)) [a -> List b] -Then if we use the in-scope set {b}, there is a danger we will rename -the forall'd variable to 'x' by mistake, getting this: - (forall x. (List b, x, x)) - -Breaking this invariant caused the bug from #11371. --} - -emptyTvSubstEnv :: TvSubstEnv -emptyTvSubstEnv = emptyVarEnv - -emptyCvSubstEnv :: CvSubstEnv -emptyCvSubstEnv = emptyVarEnv - -composeTCvSubstEnv :: InScopeSet - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) --- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. --- It assumes that both are idempotent. --- Typically, @env1@ is the refinement to a base substitution @env2@ -composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) - = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 - , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) - -- First apply env1 to the range of env2 - -- Then combine the two, making sure that env1 loses if - -- both bind the same variable; that's why env1 is the - -- *left* argument to plusVarEnv, because the right arg wins - where - subst1 = TCvSubst in_scope tenv1 cenv1 - --- | Composes two substitutions, applying the second one provided first, --- like in function composition. -composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) - = TCvSubst is3 tenv3 cenv3 - where - is3 = is1 `unionInScope` is2 - (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) - -emptyTCvSubst :: TCvSubst -emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv - -mkEmptyTCvSubst :: InScopeSet -> TCvSubst -mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv - -isEmptyTCvSubst :: TCvSubst -> Bool - -- See Note [Extending the TvSubstEnv] -isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv - -mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst -mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv - -mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst --- ^ Make a TCvSubst with specified tyvar subst and empty covar subst -mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv - -getTvSubstEnv :: TCvSubst -> TvSubstEnv -getTvSubstEnv (TCvSubst _ env _) = env - -getCvSubstEnv :: TCvSubst -> CvSubstEnv -getCvSubstEnv (TCvSubst _ _ env) = env - -getTCvInScope :: TCvSubst -> InScopeSet -getTCvInScope (TCvSubst in_scope _ _) = in_scope - --- | Returns the free variables of the types in the range of a substitution as --- a non-deterministic set. -getTCvSubstRangeFVs :: TCvSubst -> VarSet -getTCvSubstRangeFVs (TCvSubst _ tenv cenv) - = unionVarSet tenvFVs cenvFVs - where - tenvFVs = tyCoVarsOfTypesSet tenv - cenvFVs = tyCoVarsOfCosSet cenv - -isInScope :: Var -> TCvSubst -> Bool -isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope - -notElemTCvSubst :: Var -> TCvSubst -> Bool -notElemTCvSubst v (TCvSubst _ tenv cenv) - | isTyVar v - = not (v `elemVarEnv` tenv) - | otherwise - = not (v `elemVarEnv` cenv) - -setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst -setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv - -setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst -setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv - -zapTCvSubst :: TCvSubst -> TCvSubst -zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv - -extendTCvInScope :: TCvSubst -> Var -> TCvSubst -extendTCvInScope (TCvSubst in_scope tenv cenv) var - = TCvSubst (extendInScopeSet in_scope var) tenv cenv - -extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst -extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv - -extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst -extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv - -extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst -extendTCvSubst subst v ty - | isTyVar v - = extendTvSubst subst v ty - | CoercionTy co <- ty - = extendCvSubst subst v co - | otherwise - = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) - -extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst -extendTvSubst (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv - -extendTvSubstBinder :: TCvSubst -> TyBinder -> Type -> TCvSubst -extendTvSubstBinder subst (Named bndr) ty - = extendTvSubst subst (binderVar bndr) ty -extendTvSubstBinder subst (Anon _) _ - = subst - -extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst --- Adds a new tv -> tv mapping, /and/ extends the in-scope set -extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) - (extendVarEnv tenv tv (mkTyVarTy tv')) - cenv - where - new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' - -extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst -extendCvSubst (TCvSubst in_scope tenv cenv) v co - = TCvSubst in_scope tenv (extendVarEnv cenv v co) - -extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst -extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) - tenv - (extendVarEnv cenv cv (mkCoVarCo cv')) - where - new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' - -extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst --- Also extends the in-scope set -extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) - (extendVarEnv tenv tv ty) - cenv - -extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst -extendTvSubstList subst tvs tys - = foldl2 extendTvSubst subst tvs tys - -unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst --- Works when the ranges are disjoint -unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) - = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) - && not (cenv1 `intersectsVarEnv` cenv2) ) - TCvSubst (in_scope1 `unionInScope` in_scope2) - (tenv1 `plusVarEnv` tenv2) - (cenv1 `plusVarEnv` cenv2) - --- mkTvSubstPrs and zipTvSubst generate the in-scope set from --- the types given; but it's just a thunk so with a bit of luck --- it'll never be evaluated - --- | Generates an in-scope set from the free variables in a list of types --- and a list of coercions -mkTyCoInScopeSet :: [Type] -> [Coercion] -> InScopeSet -mkTyCoInScopeSet tys cos - = mkInScopeSet (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos) - --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming --- environment. No CoVars, please! -zipTvSubst :: [TyVar] -> [Type] -> TCvSubst -zipTvSubst tvs tys - | debugIsOn - , not (all isTyVar tvs) || length tvs /= length tys - = pprTrace "zipTvSubst" (ppr tvs $$ ppr tys) emptyTCvSubst - | otherwise - = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv - where - tenv = zipTyEnv tvs tys - --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming --- environment. No TyVars, please! -zipCvSubst :: [CoVar] -> [Coercion] -> TCvSubst -zipCvSubst cvs cos - | debugIsOn - , not (all isCoVar cvs) || length cvs /= length cos - = pprTrace "zipCvSubst" (ppr cvs $$ ppr cos) emptyTCvSubst - | otherwise - = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv - where - cenv = zipCoEnv cvs cos - --- | Generates the in-scope set for the 'TCvSubst' from the types in the --- incoming environment. No CoVars, please! -mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst -mkTvSubstPrs prs = - ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs ) - mkTvSubst in_scope tenv - where tenv = mkVarEnv prs - in_scope = mkInScopeSet $ tyCoVarsOfTypes $ map snd prs - onlyTyVarsAndNoCoercionTy = - and [ isTyVar tv && not (isCoercionTy ty) - | (tv, ty) <- prs ] - -zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv -zipTyEnv tyvars tys - = ASSERT( all (not . isCoercionTy) tys ) - mkVarEnv (zipEqual "zipTyEnv" tyvars tys) - -- There used to be a special case for when - -- ty == TyVarTy tv - -- (a not-uncommon case) in which case the substitution was dropped. - -- But the type-tidier changes the print-name of a type variable without - -- changing the unique, and that led to a bug. Why? Pre-tidying, we had - -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. - -- And it happened that t was the type variable of the class. Post-tiding, - -- it got turned into {Foo t2}. The ext-core printer expanded this using - -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, - -- and so generated a rep type mentioning t not t2. - -- - -- Simplest fix is to nuke the "optimisation" - -zipCoEnv :: [CoVar] -> [Coercion] -> CvSubstEnv -zipCoEnv cvs cos = mkVarEnv (zipEqual "zipCoEnv" cvs cos) - -instance Outputable TCvSubst where - ppr (TCvSubst ins tenv cenv) - = brackets $ sep[ text "TCvSubst", - nest 2 (text "In scope:" <+> ppr ins), - nest 2 (text "Type env:" <+> ppr tenv), - nest 2 (text "Co env:" <+> ppr cenv) ] - -{- -%************************************************************************ -%* * - Performing type or kind substitutions -%* * -%************************************************************************ - -Note [Sym and ForAllCo] -~~~~~~~~~~~~~~~~~~~~~~~ -In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, -how do we push sym into a ForAllCo? It's a little ugly. - -Here is the typing rule: - -h : k1 ~# k2 -(tv : k1) |- g : ty1 ~# ty2 ----------------------------- -ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# - (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) - -Here is what we want: - -ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# - (ForAllTy (tv : k1) ty1) - - -Because the kinds of the type variables to the right of the colon are the kinds -coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). - -Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want - -ForAllCo tv h' g' : - (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# - (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) - -We thus see that we want - -g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] - -and thus g' = sym (g[tv |-> tv |> h']). - -Putting it all together, we get this: - -sym (ForAllCo tv h g) -==> -ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) - --} - --- | Type substitution, see 'zipTvSubst' -substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type --- Works only if the domain of the substitution is a --- superset of the type being substituted into -substTyWith tvs tys = ASSERT( length tvs == length tys ) - substTy (zipTvSubst tvs tys) - --- | Type substitution, see 'zipTvSubst'. Disables sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type -substTyWithUnchecked tvs tys - = ASSERT( length tvs == length tys ) - substTyUnchecked (zipTvSubst tvs tys) - --- | Substitute tyvars within a type using a known 'InScopeSet'. --- Pre-condition: the 'in_scope' set should satisfy Note [The substitution --- invariant]; specifically it should include the free vars of 'tys', --- and of 'ty' minus the domain of the subst. -substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type -substTyWithInScope in_scope tvs tys ty = - ASSERT( length tvs == length tys ) - substTy (mkTvSubst in_scope tenv) ty - where tenv = zipTyEnv tvs tys - --- | Coercion substitution, see 'zipTvSubst' -substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion -substCoWith tvs tys = ASSERT( length tvs == length tys ) - substCo (zipTvSubst tvs tys) - --- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion -substCoWithUnchecked tvs tys - = ASSERT( length tvs == length tys ) - substCoUnchecked (zipTvSubst tvs tys) - - - --- | Substitute covars within a type -substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type -substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) - --- | Type substitution, see 'zipTvSubst' -substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] -substTysWith tvs tys = ASSERT( length tvs == length tys ) - substTys (zipTvSubst tvs tys) - --- | Type substitution, see 'zipTvSubst' -substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] -substTysWithCoVars cvs cos = ASSERT( length cvs == length cos ) - substTys (zipCvSubst cvs cos) - --- | Substitute within a 'Type' after adding the free variables of the type --- to the in-scope set. This is useful for the case when the free variables --- aren't already in the in-scope set or easily available. --- See also Note [The substitution invariant]. -substTyAddInScope :: TCvSubst -> Type -> Type -substTyAddInScope subst ty = - substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty - --- | When calling `substTy` it should be the case that the in-scope set in --- the substitution is a superset of the free vars of the range of the --- substitution. --- See also Note [The substitution invariant]. -isValidTCvSubst :: TCvSubst -> Bool -isValidTCvSubst (TCvSubst in_scope tenv cenv) = - (tenvFVs `varSetInScope` in_scope) && - (cenvFVs `varSetInScope` in_scope) - where - tenvFVs = tyCoVarsOfTypesSet tenv - cenvFVs = tyCoVarsOfCosSet cenv - --- | This checks if the substitution satisfies the invariant from --- Note [The substitution invariant]. -checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a -checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a - = ASSERT2( isValidTCvSubst subst, - text "in_scope" <+> ppr in_scope $$ - text "tenv" <+> ppr tenv $$ - text "tenvFVs" - <+> ppr (tyCoVarsOfTypesSet tenv) $$ - text "cenv" <+> ppr cenv $$ - text "cenvFVs" - <+> ppr (tyCoVarsOfCosSet cenv) $$ - text "tys" <+> ppr tys $$ - text "cos" <+> ppr cos ) - ASSERT2( tysCosFVsInScope, - text "in_scope" <+> ppr in_scope $$ - text "tenv" <+> ppr tenv $$ - text "cenv" <+> ppr cenv $$ - text "tys" <+> ppr tys $$ - text "cos" <+> ppr cos $$ - text "needInScope" <+> ppr needInScope ) - a - where - substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv - -- It's OK to use nonDetKeysUFM here, because we only use this list to - -- remove some elements from a set - needInScope = (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos) - `delListFromUniqSet_Directly` substDomain - tysCosFVsInScope = needInScope `varSetInScope` in_scope - - --- | Substitute within a 'Type' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTy :: HasCallStack => TCvSubst -> Type -> Type -substTy subst ty - | isEmptyTCvSubst subst = ty - | otherwise = checkValidSubst subst [ty] [] $ - subst_ty subst ty - --- | Substitute within a 'Type' disabling the sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substTyUnchecked :: TCvSubst -> Type -> Type -substTyUnchecked subst ty - | isEmptyTCvSubst subst = ty - | otherwise = subst_ty subst ty - --- | Substitute within several 'Type's --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTys :: HasCallStack => TCvSubst -> [Type] -> [Type] -substTys subst tys - | isEmptyTCvSubst subst = tys - | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys - --- | Substitute within several 'Type's disabling the sanity checks. --- The problems that the sanity checks in substTys catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTysUnchecked to --- substTys and remove this function. Please don't use in new code. -substTysUnchecked :: TCvSubst -> [Type] -> [Type] -substTysUnchecked subst tys - | isEmptyTCvSubst subst = tys - | otherwise = map (subst_ty subst) tys - --- | Substitute within a 'ThetaType' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType -substTheta = substTys - --- | Substitute within a 'ThetaType' disabling the sanity checks. --- The problems that the sanity checks in substTys catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substThetaUnchecked to --- substTheta and remove this function. Please don't use in new code. -substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType -substThetaUnchecked = substTysUnchecked - - -subst_ty :: TCvSubst -> Type -> Type --- subst_ty is the main workhorse for type substitution --- --- Note that the in_scope set is poked only if we hit a forall --- so it may often never be fully computed -subst_ty subst ty - = go ty - where - go (TyVarTy tv) = substTyVar subst tv - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) - -- The mkAppTy smart constructor is important - -- we might be replacing (a Int), represented with App - -- by [Int], represented with TyConApp - go (TyConApp tc tys) = let args = map go tys - in args `seqList` TyConApp tc args - go (FunTy arg res) = (FunTy $! go arg) $! go res - go (ForAllTy (TvBndr tv vis) ty) - = case substTyVarBndrUnchecked subst tv of - (subst', tv') -> - (ForAllTy $! ((TvBndr $! tv') vis)) $! - (subst_ty subst' ty) - go (LitTy n) = LitTy $! n - go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) - go (CoercionTy co) = CoercionTy $! (subst_co subst co) - -substTyVar :: TCvSubst -> TyVar -> Type -substTyVar (TCvSubst _ tenv _) tv - = ASSERT( isTyVar tv ) - case lookupVarEnv tenv tv of - Just ty -> ty - Nothing -> TyVarTy tv - -substTyVars :: TCvSubst -> [TyVar] -> [Type] -substTyVars subst = map $ substTyVar subst - -lookupTyVar :: TCvSubst -> TyVar -> Maybe Type - -- See Note [Extending the TCvSubst] -lookupTyVar (TCvSubst _ tenv _) tv - = ASSERT( isTyVar tv ) - lookupVarEnv tenv tv - --- | Substitute within a 'Coercion' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion -substCo subst co - | isEmptyTCvSubst subst = co - | otherwise = checkValidSubst subst [] [co] $ subst_co subst co - --- | Substitute within a 'Coercion' disabling sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substCoUnchecked :: TCvSubst -> Coercion -> Coercion -substCoUnchecked subst co - | isEmptyTCvSubst subst = co - | otherwise = subst_co subst co - --- | Substitute within several 'Coercion's --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion] -substCos subst cos - | isEmptyTCvSubst subst = cos - | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos - -subst_co :: TCvSubst -> Coercion -> Coercion -subst_co subst co - = go co - where - go_ty :: Type -> Type - go_ty = subst_ty subst - - go :: Coercion -> Coercion - go (Refl r ty) = mkReflCo r $! go_ty ty - go (TyConAppCo r tc args)= let args' = map go args - in args' `seqList` mkTyConAppCo r tc args' - go (AppCo co arg) = (mkAppCo $! go co) $! go arg - go (ForAllCo tv kind_co co) - = case substForAllCoBndrUnchecked subst tv kind_co of { (subst', tv', kind_co') -> - ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co } - go (FunCo r co1 co2) = (mkFunCo r $! go co1) $! go co2 - go (CoVarCo cv) = substCoVar subst cv - go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos - go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! - (go_ty t1)) $! (go_ty t2) - go (SymCo co) = mkSymCo $! (go co) - go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) - go (NthCo d co) = mkNthCo d $! (go co) - go (LRCo lr co) = mkLRCo lr $! (go co) - go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg - go (CoherenceCo co1 co2) = (mkCoherenceCo $! (go co1)) $! (go co2) - go (KindCo co) = mkKindCo $! (go co) - go (SubCo co) = mkSubCo $! (go co) - go (AxiomRuleCo c cs) = let cs1 = map go cs - in cs1 `seqList` AxiomRuleCo c cs1 - - go_prov UnsafeCoerceProv = UnsafeCoerceProv - go_prov (PhantomProv kco) = PhantomProv (go kco) - go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) - go_prov p@(PluginProv _) = p - go_prov p@(HoleProv _) = p - -- NB: this last case is a little suspicious, but we need it. Originally, - -- there was a panic here, but it triggered from deeplySkolemise. Because - -- we only skolemise tyvars that are manually bound, this operation makes - -- sense, even over a coercion with holes. - -substForAllCoBndr :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion) -substForAllCoBndr subst - = substForAllCoBndrCallback False (substCo subst) subst - --- | Like 'substForAllCoBndr', but disables sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substForAllCoBndrUnchecked :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion) -substForAllCoBndrUnchecked subst - = substForAllCoBndrCallback False (substCoUnchecked subst) subst - --- See Note [Sym and ForAllCo] -substForAllCoBndrCallback :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyVar -> Coercion - -> (TCvSubst, TyVar, Coercion) -substForAllCoBndrCallback sym sco (TCvSubst in_scope tenv cenv) - old_var old_kind_co - = ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv - , new_var, new_kind_co ) - where - new_env | no_change && not sym = delVarEnv tenv old_var - | sym = extendVarEnv tenv old_var $ - TyVarTy new_var `CastTy` new_kind_co - | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - - no_kind_change = noFreeVarsOfCo old_kind_co - no_change = no_kind_change && (new_var == old_var) - - new_kind_co | no_kind_change = old_kind_co - | otherwise = sco old_kind_co - - Pair new_ki1 _ = coercionKind new_kind_co - - new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) - -substCoVar :: TCvSubst -> CoVar -> Coercion -substCoVar (TCvSubst _ _ cenv) cv - = case lookupVarEnv cenv cv of - Just co -> co - Nothing -> CoVarCo cv - -substCoVars :: TCvSubst -> [CoVar] -> [Coercion] -substCoVars subst cvs = map (substCoVar subst) cvs - -lookupCoVar :: TCvSubst -> Var -> Maybe Coercion -lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v - -substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndr = substTyVarBndrCallback substTy - --- | Like 'substTyVarBndr' but disables sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substTyVarBndrUnchecked :: TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndrUnchecked = substTyVarBndrCallback substTyUnchecked - --- | Substitute a tyvar in a binding position, returning an --- extended subst and a new tyvar. -substTyVarBndrCallback :: (TCvSubst -> Type -> Type) -- ^ the subst function - -> TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndrCallback subst_fn subst@(TCvSubst in_scope tenv cenv) old_var - = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst ) - ASSERT( isTyVar old_var ) - (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) - where - new_env | no_change = delVarEnv tenv old_var - | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - - _no_capture = not (new_var `elemVarSet` tyCoVarsOfTypesSet tenv) - -- Assertion check that we are not capturing something in the substitution - - old_ki = tyVarKind old_var - no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed - no_change = no_kind_change && (new_var == old_var) - -- no_change means that the new_var is identical in - -- all respects to the old_var (same unique, same kind) - -- See Note [Extending the TCvSubst] - -- - -- In that case we don't need to extend the substitution - -- to map old to new. But instead we must zap any - -- current substitution for the variable. For example: - -- (\x.e) with id_subst = [x |-> e'] - -- Here we must simply zap the substitution for x - - new_var | no_kind_change = uniqAway in_scope old_var - | otherwise = uniqAway in_scope $ - setTyVarKind old_var (subst_fn subst old_ki) - -- The uniqAway part makes sure the new variable is not already in scope - -substCoVarBndr :: TCvSubst -> CoVar -> (TCvSubst, CoVar) -substCoVarBndr subst@(TCvSubst in_scope tenv cenv) old_var - = ASSERT( isCoVar old_var ) - (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) - where - new_co = mkCoVarCo new_var - no_kind_change = all noFreeVarsOfType [t1, t2] - no_change = new_var == old_var && no_kind_change - - new_cenv | no_change = delVarEnv cenv old_var - | otherwise = extendVarEnv cenv old_var new_co - - new_var = uniqAway in_scope subst_old_var - subst_old_var = mkCoVar (varName old_var) new_var_type - - (_, _, t1, t2, role) = coVarKindsTypesRole old_var - t1' = substTy subst t1 - t2' = substTy subst t2 - new_var_type = mkCoercionType role t1' t2' - -- It's important to do the substitution for coercions, - -- because they can have free type variables - -cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) -cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq - = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars - (TCvSubst (extendInScopeSet in_scope tv') - (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') - where - old_ki = tyVarKind tv - no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed - - tv1 | no_kind_change = tv - | otherwise = setTyVarKind tv (substTy subst old_ki) - - tv' = setVarUnique tv1 uniq - -cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) -cloneTyVarBndrs subst [] _usupply = (subst, []) -cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) - where - (uniq, usupply') = takeUniqFromSupply usupply - (subst' , tv ) = cloneTyVarBndr subst t uniq - (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' - -{- -%************************************************************************ -%* * - Pretty-printing types - - Defined very early because of debug printing in assertions -%* * -%************************************************************************ - -@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is -defined to use this. @pprParendType@ is the same, except it puts -parens around the type, except for the atomic cases. @pprParendType@ -works just by setting the initial context precedence very high. - -Note [Precedence in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't keep the fixity of type operators in the operator. So the pretty printer -follows the following precedence order: - Type constructor application binds more tightly than - Operator applications which bind more tightly than - Function arrow - -So we might see a :+: T b -> c -meaning (a :+: (T b)) -> c - -Maybe operator applications should bind a bit less tightly? - -Anyway, that's the current story; it is used consistently for Type and HsType. --} - ------------------- - -pprType, pprParendType :: Type -> SDoc -pprType = pprIfaceType . tidyToIfaceType -pprParendType = pprParendIfaceType . tidyToIfaceType - -pprTyLit :: TyLit -> SDoc -pprTyLit = pprIfaceTyLit . toIfaceTyLit - -pprKind, pprParendKind :: Kind -> SDoc -pprKind = pprType -pprParendKind = pprParendType - -tidyToIfaceType :: Type -> IfaceType --- It's vital to tidy before converting to an IfaceType --- or nested binders will become indistinguishable! --- --- Also for the free type variables, tell toIfaceTypeX to --- leave them as IfaceFreeTyVar. This is super-important --- for debug printing. -tidyToIfaceType ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env ty) - where - env = tidyFreeTyCoVars emptyTidyEnv free_tcvs - free_tcvs = tyCoVarsOfTypeWellScoped ty - ------------- -pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = pprTypeApp (classTyCon clas) tys - ------------- -pprTheta :: ThetaType -> SDoc -pprTheta = pprIfaceContext . map tidyToIfaceType - -pprThetaArrowTy :: ThetaType -> SDoc -pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType - ------------------- -instance Outputable Type where - ppr ty = pprType ty - -instance Outputable TyLit where - ppr = pprTyLit - ------------------- - -pprSigmaType :: Type -> SDoc -pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType - -pprForAll :: [TyVarBinder] -> SDoc -pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) - --- | Print a user-level forall; see Note [When to print foralls] -pprUserForAll :: [TyVarBinder] -> SDoc -pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr - -pprTvBndrs :: [TyVarBinder] -> SDoc -pprTvBndrs tvs = sep (map pprTvBndr tvs) - -pprTvBndr :: TyVarBinder -> SDoc -pprTvBndr = pprTyVar . binderVar - -pprTyVars :: [TyVar] -> SDoc -pprTyVars tvs = sep (map pprTyVar tvs) - -pprTyVar :: TyVar -> SDoc --- Print a type variable binder with its kind (but not if *) --- Here we do not go via IfaceType, because the duplication with --- pprIfaceTvBndr is minimal, and the loss of uniques etc in --- debug printing is disastrous -pprTyVar tv - | isLiftedTypeKind kind = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> ppr kind) - where - kind = tyVarKind tv - -instance Outputable TyBinder where - ppr (Anon ty) = text "[anon]" <+> ppr ty - ppr (Named (TvBndr v Required)) = ppr v - ppr (Named (TvBndr v Specified)) = char '@' <> ppr v - ppr (Named (TvBndr v Inferred)) = braces (ppr v) - ------------------ -instance Outputable Coercion where -- defined here to avoid orphans - ppr = pprCo - -{- -Note [When to print foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Mostly we want to print top-level foralls when (and only when) the user specifies --fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses -too much information; see Trac #9018. - -So I'm trying out this rule: print explicit foralls if - a) User specifies -fprint-explicit-foralls, or - b) Any of the quantified type variables has a kind - that mentions a kind variable - -This catches common situations, such as a type siguature - f :: m a -which means - f :: forall k. forall (m :: k->*) (a :: k). m a -We really want to see both the "forall k" and the kind signatures -on m and a. The latter comes from pprTvBndr. - -Note [Infix type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With TypeOperators you can say - - f :: (a ~> b) -> b - -and the (~>) is considered a type variable. However, the type -pretty-printer in this module will just see (a ~> b) as - - App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") - -So it'll print the type in prefix form. To avoid confusion we must -remember to parenthesise the operator, thus - - (~>) a b -> b - -See Trac #2766. --} - -pprDataCons :: TyCon -> SDoc -pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons - where - sepWithVBars [] = empty - sepWithVBars docs = sep (punctuate (space <> vbar) docs) - -pprDataConWithArgs :: DataCon -> SDoc -pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] - where - (_univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc - univ_bndrs = dataConUnivTyVarBinders dc - ex_bndrs = dataConExTyVarBinders dc - forAllDoc = pprUserForAll $ (filterEqSpec eq_spec univ_bndrs ++ ex_bndrs) - thetaDoc = pprThetaArrowTy theta - argsDoc = hsep (fmap pprParendType arg_tys) - - -pprTypeApp :: TyCon -> [Type] -> SDoc -pprTypeApp tc tys - = pprIfaceTypeApp TopPrec (toIfaceTyCon tc) - (toIfaceTcArgs tc tys) - -- TODO: toIfaceTcArgs seems rather wasteful here - -pprTcAppCo :: TyPrec -> (TyPrec -> Coercion -> SDoc) - -> TyCon -> [Coercion] -> SDoc -pprTcAppCo p _pp tc cos - = pprIfaceCoTcApp p (toIfaceTyCon tc) (map toIfaceCoercion cos) - ------------------- - -pprPrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc -pprPrefixApp = pprIfacePrefixApp - ----------------- -pprArrowChain :: TyPrec -> [SDoc] -> SDoc --- pprArrowChain p [a,b,c] generates a -> b -> c -pprArrowChain _ [] = empty -pprArrowChain p (arg:args) = maybeParen p FunPrec $ - sep [arg, sep (map (arrow <+>) args)] - -ppSuggestExplicitKinds :: SDoc --- Print a helpful suggstion about -fprint-explicit-kinds, --- if it is not already on -ppSuggestExplicitKinds - = sdocWithDynFlags $ \ dflags -> - ppUnless (gopt Opt_PrintExplicitKinds dflags) $ - text "Use -fprint-explicit-kinds to see the kind arguments" - -{- -%************************************************************************ -%* * -\subsection{TidyType} -%* * -%************************************************************************ --} - --- | This tidies up a type for printing in an error message, or in --- an interface file. --- --- It doesn't change the uniques at all, just the print names. -tidyTyCoVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyTyCoVarBndrs (occ_env, subst) tvs - = mapAccumL tidyTyCoVarBndr tidy_env' tvs - where - -- Seed the occ_env with clashes among the names, see - -- Node [Tidying multiple names at once] in OccName - -- Se still go through tidyTyCoVarBndr so that each kind variable is tidied - -- with the correct tidy_env - occs = map getHelpfulOccName tvs - tidy_env' = (avoidClashesOccEnv occ_env occs, subst) - -tidyTyCoVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) -tidyTyCoVarBndr tidy_env@(occ_env, subst) tyvar - = case tidyOccName occ_env (getHelpfulOccName tyvar) of - (occ_env', occ') -> ((occ_env', subst'), tyvar') - where - subst' = extendVarEnv subst tyvar tyvar' - tyvar' = setTyVarKind (setTyVarName tyvar name') kind' - kind' = tidyKind tidy_env (tyVarKind tyvar) - name' = tidyNameOcc name occ' - name = tyVarName tyvar - -getHelpfulOccName :: TyCoVar -> OccName -getHelpfulOccName tyvar = occ1 - where - name = tyVarName tyvar - occ = getOccName name - -- A TcTyVar with a System Name is probably a unification variable; - -- when we tidy them we give them a trailing "0" (or 1 etc) - -- so that they don't take precedence for the un-modified name - -- Plus, indicating a unification variable in this way is a - -- helpful clue for users - occ1 | isSystemName name - , isTcTyVar tyvar - = mkTyVarOcc (occNameString occ ++ "0") - | otherwise - = occ - -tidyTyVarBinder :: TidyEnv -> TyVarBndr TyVar vis - -> (TidyEnv, TyVarBndr TyVar vis) -tidyTyVarBinder tidy_env (TvBndr tv vis) - = (tidy_env', TvBndr tv' vis) - where - (tidy_env', tv') = tidyTyCoVarBndr tidy_env tv - -tidyTyVarBinders :: TidyEnv -> [TyVarBndr TyVar vis] - -> (TidyEnv, [TyVarBndr TyVar vis]) -tidyTyVarBinders = mapAccumL tidyTyVarBinder - ---------------- -tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv --- ^ Add the free 'TyVar's to the env in tidy form, --- so that we can tidy the type they are free in -tidyFreeTyCoVars (full_occ_env, var_env) tyvars - = fst (tidyOpenTyCoVars (full_occ_env, var_env) tyvars) - - --------------- -tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars - ---------------- -tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) --- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name --- using the environment if one has not already been allocated. See --- also 'tidyTyCoVarBndr' -tidyOpenTyCoVar env@(_, subst) tyvar - = case lookupVarEnv subst tyvar of - Just tyvar' -> (env, tyvar') -- Already substituted - Nothing -> - let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) - in tidyTyCoVarBndr env' tyvar -- Treat it as a binder - ---------------- -tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar -tidyTyVarOcc env@(_, subst) tv - = case lookupVarEnv subst tv of - Nothing -> updateTyVarKind (tidyType env) tv - Just tv' -> tv' - ---------------- -tidyTypes :: TidyEnv -> [Type] -> [Type] -tidyTypes env tys = map (tidyType env) tys - ---------------- -tidyType :: TidyEnv -> Type -> Type -tidyType _ (LitTy n) = LitTy n -tidyType env (TyVarTy tv) = TyVarTy (tidyTyVarOcc env tv) -tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys - in args `seqList` TyConApp tycon args -tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) -tidyType env (FunTy fun arg) = (FunTy $! (tidyType env fun)) $! (tidyType env arg) -tidyType env (ty@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty - where - (tvs, vis, body_ty) = splitForAllTys' ty - (env', tvs') = tidyTyCoVarBndrs env tvs -tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) -tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) - - --- The following two functions differ from mkForAllTys and splitForAllTys in that --- they expect/preserve the ArgFlag argument. Thes belong to types/Type.hs, but --- how should they be named? -mkForAllTys' :: [(TyVar, ArgFlag)] -> Type -> Type -mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs - where - strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((TvBndr $! tv) $! vis)) $! ty - -splitForAllTys' :: Type -> ([TyVar], [ArgFlag], Type) -splitForAllTys' ty = go ty [] [] - where - go (ForAllTy (TvBndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) - go ty tvs viss = (reverse tvs, reverse viss, ty) - - ---------------- --- | Grabs the free type variables, tidies them --- and then uses 'tidyType' to work over the type itself -tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) -tidyOpenTypes env tys - = (env', tidyTypes (trimmed_occ_env, var_env) tys) - where - (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $ - tyCoVarsOfTypesWellScoped tys - trimmed_occ_env = initTidyOccEnv (map getOccName tvs') - -- The idea here was that we restrict the new TidyEnv to the - -- _free_ vars of the types, so that we don't gratuitously rename - -- the _bound_ variables of the types. - ---------------- -tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) -tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in - (env', ty') - ---------------- --- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) -tidyTopType :: Type -> Type -tidyTopType ty = tidyType emptyTidyEnv ty - ---------------- -tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) -tidyOpenKind = tidyOpenType - -tidyKind :: TidyEnv -> Kind -> Kind -tidyKind = tidyType - ----------------- -tidyCo :: TidyEnv -> Coercion -> Coercion -tidyCo env@(_, subst) co - = go co - where - go (Refl r ty) = Refl r (tidyType env ty) - go (TyConAppCo r tc cos) = let args = map go cos - in args `seqList` TyConAppCo r tc args - go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 - go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co) - where (envp, tvp) = tidyTyCoVarBndr env tv - -- the case above duplicates a bit of work in tidying h and the kind - -- of tv. But the alternative is to use coercionKind, which seems worse. - go (FunCo r co1 co2) = (FunCo r $! go co1) $! go co2 - go (CoVarCo cv) = case lookupVarEnv subst cv of - Nothing -> CoVarCo cv - Just cv' -> CoVarCo cv' - go (AxiomInstCo con ind cos) = let args = map go cos - in args `seqList` AxiomInstCo con ind args - go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! - tidyType env t1) $! tidyType env t2 - go (SymCo co) = SymCo $! go co - go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 - go (NthCo d co) = NthCo d $! go co - go (LRCo lr co) = LRCo lr $! go co - go (InstCo co ty) = (InstCo $! go co) $! go ty - go (CoherenceCo co1 co2) = (CoherenceCo $! go co1) $! go co2 - go (KindCo co) = KindCo $! go co - go (SubCo co) = SubCo $! go co - go (AxiomRuleCo ax cos) = let cos1 = tidyCos env cos - in cos1 `seqList` AxiomRuleCo ax cos1 - - go_prov UnsafeCoerceProv = UnsafeCoerceProv - go_prov (PhantomProv co) = PhantomProv (go co) - go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) - go_prov p@(PluginProv _) = p - go_prov p@(HoleProv _) = p - -tidyCos :: TidyEnv -> [Coercion] -> [Coercion] -tidyCos env = map (tidyCo env) - - -{- ********************************************************************* -* * - typeSize, coercionSize -* * -********************************************************************* -} - --- NB: We put typeSize/coercionSize here because they are mutually --- recursive, and have the CPR property. If we have mutual --- recursion across a hi-boot file, we don't get the CPR property --- and these functions allocate a tremendous amount of rubbish. --- It's not critical (because typeSize is really only used in --- debug mode, but I tripped over an example (T5642) in which --- typeSize was one of the biggest single allocators in all of GHC. --- And it's easy to fix, so I did. - --- NB: typeSize does not respect `eqType`, in that two types that --- are `eqType` may return different sizes. This is OK, because this --- function is used only in reporting, not decision-making. - -typeSize :: Type -> Int -typeSize (LitTy {}) = 1 -typeSize (TyVarTy {}) = 1 -typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (ForAllTy (TvBndr tv _) t) = typeSize (tyVarKind tv) + typeSize t -typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) -typeSize (CastTy ty co) = typeSize ty + coercionSize co -typeSize (CoercionTy co) = coercionSize co - -coercionSize :: Coercion -> Int -coercionSize (Refl _ ty) = typeSize ty -coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) -coercionSize (AppCo co arg) = coercionSize co + coercionSize arg -coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h -coercionSize (FunCo _ co1 co2) = 1 + coercionSize co1 + coercionSize co2 -coercionSize (CoVarCo _) = 1 -coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) -coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 -coercionSize (SymCo co) = 1 + coercionSize co -coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 -coercionSize (NthCo _ co) = 1 + coercionSize co -coercionSize (LRCo _ co) = 1 + coercionSize co -coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg -coercionSize (CoherenceCo c1 c2) = 1 + coercionSize c1 + coercionSize c2 -coercionSize (KindCo co) = 1 + coercionSize co -coercionSize (SubCo co) = 1 + coercionSize co -coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) - -provSize :: UnivCoProvenance -> Int -provSize UnsafeCoerceProv = 1 -provSize (PhantomProv co) = 1 + coercionSize co -provSize (ProofIrrelProv co) = 1 + coercionSize co -provSize (PluginProv _) = 1 -provSize (HoleProv h) = pprPanic "provSize hits a hole" (ppr h) diff --git a/types/TyCoRep.hs-boot b/types/TyCoRep.hs-boot deleted file mode 100644 --- a/types/TyCoRep.hs-boot +++ /dev/null @@ -1,23 +0,0 @@ -module TyCoRep where - -import Outputable ( SDoc ) -import Data.Data ( Data ) - -data Type -data TyThing -data Coercion -data UnivCoProvenance -data TCvSubst -data TyLit -data TyBinder - -type PredType = Type -type Kind = Type -type ThetaType = [PredType] - -pprKind :: Kind -> SDoc -pprType :: Type -> SDoc - -instance Data Type - -- To support Data instances in CoAxiom - diff --git a/types/TyCon.hs b/types/TyCon.hs deleted file mode 100644 --- a/types/TyCon.hs +++ /dev/null @@ -1,2433 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The @TyCon@ datatype --} - -{-# LANGUAGE CPP, FlexibleInstances #-} - -module TyCon( - -- * Main TyCon data types - TyCon, AlgTyConRhs(..), visibleDataCons, - AlgTyConFlav(..), isNoParent, - FamTyConFlav(..), Role(..), Injectivity(..), - RuntimeRepInfo(..), - - -- * TyConBinder - TyConBinder, TyConBndrVis(..), - mkNamedTyConBinder, mkNamedTyConBinders, - mkAnonTyConBinder, mkAnonTyConBinders, - tyConBinderArgFlag, isNamedTyConBinder, - isVisibleTyConBinder, isInvisibleTyConBinder, - - -- ** Field labels - tyConFieldLabels, lookupTyConFieldLabel, - - -- ** Constructing TyCons - mkAlgTyCon, - mkClassTyCon, - mkFunTyCon, - mkPrimTyCon, - mkKindTyCon, - mkLiftedPrimTyCon, - mkTupleTyCon, - mkSumTyCon, - mkSynonymTyCon, - mkFamilyTyCon, - mkPromotedDataCon, - mkTcTyCon, - - -- ** Predicates on TyCons - isAlgTyCon, isVanillaAlgTyCon, - isClassTyCon, isFamInstTyCon, - isFunTyCon, - isPrimTyCon, - isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isUnboxedSumTyCon, isPromotedTupleTyCon, - isTypeSynonymTyCon, - mightBeUnsaturatedTyCon, - isPromotedDataCon, isPromotedDataCon_maybe, - isKindTyCon, isLiftedTypeKindTyConName, - isTauTyCon, isFamFreeTyCon, - - isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, - isDataSumTyCon_maybe, - isEnumerationTyCon, - isNewTyCon, isAbstractTyCon, - isFamilyTyCon, isOpenFamilyTyCon, - isTypeFamilyTyCon, isDataFamilyTyCon, - isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, - familyTyConInjectivityInfo, - isBuiltInSynFamTyCon_maybe, - isUnliftedTyCon, - isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, - isTyConAssoc, tyConAssoc_maybe, - isImplicitTyCon, - isTyConWithSrcDataCons, - isTcTyCon, isTcLevPoly, - - -- ** Extracting information out of TyCons - tyConName, - tyConSkolem, - tyConKind, - tyConUnique, - tyConTyVars, - tyConCType, tyConCType_maybe, - tyConDataCons, tyConDataCons_maybe, - tyConSingleDataCon_maybe, tyConSingleDataCon, - tyConSingleAlgDataCon_maybe, - tyConFamilySize, - tyConStupidTheta, - tyConArity, - tyConRoles, - tyConFlavour, - tyConTuple_maybe, tyConClass_maybe, tyConATs, - tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, - tyConFamilyResVar_maybe, - synTyConDefn_maybe, synTyConRhs_maybe, - famTyConFlav_maybe, famTcResVar, - algTyConRhs, - newTyConRhs, newTyConEtadArity, newTyConEtadRhs, - unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, - newTyConDataCon_maybe, - algTcFields, - tyConRuntimeRepInfo, - tyConBinders, tyConResKind, - tcTyConScopedTyVars, - - -- ** Manipulating TyCons - expandSynTyCon_maybe, - makeRecoveryTyCon, - newTyConCo, newTyConCo_maybe, - pprPromotionQuote, mkTyConKind, - - -- * Runtime type representation - TyConRepName, tyConRepName_maybe, - mkPrelTyConRepName, - tyConRepModOcc, - - -- * Primitive representations of Types - PrimRep(..), PrimElemRep(..), - isVoidRep, isGcPtrRep, - primRepSizeW, primElemRepSizeB, - primRepIsFloat, - - -- * Recursion breaking - RecTcChecker, initRecTc, checkRecTc - -) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, pprType ) -import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind - , vecCountTyCon, vecElemTyCon, liftedTypeKind - , mkFunKind, mkForAllKind ) -import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels - , dataConTyCon ) - -import Binary -import Var -import Class -import BasicTypes -import DynFlags -import ForeignCall -import Name -import NameEnv -import CoAxiom -import PrelNames -import Maybes -import Outputable -import FastStringEnv -import FieldLabel -import Constants -import Util -import Unique( tyConRepNameUnique, dataConRepNameUnique ) -import UniqSet -import Module - -import qualified Data.Data as Data - -{- ------------------------------------------------ - Notes about type families ------------------------------------------------ - -Note [Type synonym families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Type synonym families, also known as "type functions", map directly - onto the type functions in FC: - - type family F a :: * - type instance F Int = Bool - ..etc... - -* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon - -* From the user's point of view (F Int) and Bool are simply - equivalent types. - -* A Haskell 98 type synonym is a degenerate form of a type synonym - family. - -* Type functions can't appear in the LHS of a type function: - type instance F (F Int) = ... -- BAD! - -* Translation of type family decl: - type family F a :: * - translates to - a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon - - type family G a :: * where - G Int = Bool - G Bool = Char - G a = () - translates to - a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the - appropriate CoAxiom representing the equations - -We also support injective type families -- see Note [Injective type families] - -Note [Data type families] -~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Wrappers for data instance tycons] in MkId.hs - -* Data type families are declared thus - data family T a :: * - data instance T Int = T1 | T2 Bool - - Here T is the "family TyCon". - -* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon - -* The user does not see any "equivalent types" as he did with type - synonym families. He just sees constructors with types - T1 :: T Int - T2 :: Bool -> T Int - -* Here's the FC version of the above declarations: - - data T a - data R:TInt = T1 | T2 Bool - axiom ax_ti : T Int ~R R:TInt - - Note that this is a *representational* coercion - The R:TInt is the "representation TyCons". - It has an AlgTyConFlav of - DataFamInstTyCon T [Int] ax_ti - -* The axiom ax_ti may be eta-reduced; see - Note [Eta reduction for data family axioms] in TcInstDcls - -* The data constructor T2 has a wrapper (which is what the - source-level "T2" invokes): - - $WT2 :: Bool -> T Int - $WT2 b = T2 b `cast` sym ax_ti - -* A data instance can declare a fully-fledged GADT: - - data instance T (a,b) where - X1 :: T (Int,Bool) - X2 :: a -> b -> T (a,b) - - Here's the FC version of the above declaration: - - data R:TPair a where - X1 :: R:TPair Int Bool - X2 :: a -> b -> R:TPair a b - axiom ax_pr :: T (a,b) ~R R:TPair a b - - $WX1 :: forall a b. a -> b -> T (a,b) - $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) - - The R:TPair are the "representation TyCons". - We have a bit of work to do, to unpick the result types of the - data instance declaration for T (a,b), to get the result type in the - representation; e.g. T (a,b) --> R:TPair a b - - The representation TyCon R:TList, has an AlgTyConFlav of - - DataFamInstTyCon T [(a,b)] ax_pr - -* Notice that T is NOT translated to a FC type function; it just - becomes a "data type" with no constructors, which can be coerced inot - into R:TInt, R:TPair by the axioms. These axioms - axioms come into play when (and *only* when) you - - use a data constructor - - do pattern matching - Rather like newtype, in fact - - As a result - - - T behaves just like a data type so far as decomposition is concerned - - - (T Int) is not implicitly converted to R:TInt during type inference. - Indeed the latter type is unknown to the programmer. - - - There *is* an instance for (T Int) in the type-family instance - environment, but it is only used for overlap checking - - - It's fine to have T in the LHS of a type function: - type instance F (T a) = [a] - - It was this last point that confused me! The big thing is that you - should not think of a data family T as a *type function* at all, not - even an injective one! We can't allow even injective type functions - on the LHS of a type function: - type family injective G a :: * - type instance F (G Int) = Bool - is no good, even if G is injective, because consider - type instance G Int = Bool - type instance F Bool = Char - - So a data type family is not an injective type function. It's just a - data type with some axioms that connect it to other data types. - -* The tyConTyVars of the representation tycon are the tyvars that the - user wrote in the patterns. This is important in TcDeriv, where we - bring these tyvars into scope before type-checking the deriving - clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. - -Note [Associated families and their parent class] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -*Associated* families are just like *non-associated* families, except -that they have a famTcParent field of (Just cls), which identifies the -parent class. - -However there is an important sharing relationship between - * the tyConTyVars of the parent Class - * the tyConTyvars of the associated TyCon - - class C a b where - data T p a - type F a q b - -Here the 'a' and 'b' are shared with the 'Class'; that is, they have -the same Unique. - -This is important. In an instance declaration we expect - * all the shared variables to be instantiated the same way - * the non-shared variables of the associated type should not - be instantiated at all - - instance C [x] (Tree y) where - data T p [x] = T1 x | T2 p - type F [x] q (Tree y) = (x,y,q) - -Note [TyCon Role signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every tycon has a role signature, assigning a role to each of the tyConTyVars -(or of equal length to the tyConArity, if there are no tyConTyVars). An -example demonstrates these best: say we have a tycon T, with parameters a at -nominal, b at representational, and c at phantom. Then, to prove -representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have -nominal equality between a1 and a2, representational equality between b1 and -b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This -might happen, say, with the following declaration: - - data T a b c where - MkT :: b -> T Int b c - -Data and class tycons have their roles inferred (see inferRoles in TcTyDecls), -as do vanilla synonym tycons. Family tycons have all parameters at role N, -though it is conceivable that we could relax this restriction. (->)'s and -tuples' parameters are at role R. Each primitive tycon declares its roles; -it's worth noting that (~#)'s parameters are at role N. Promoted data -constructors' type arguments are at role R. All kind arguments are at role -N. - -Note [Unboxed tuple RuntimeRep vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The contents of an unboxed tuple may have any representation. Accordingly, -the kind of the unboxed tuple constructor is runtime-representation -polymorphic. For example, - - (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). TYPE q -> TYPE r -> # - -These extra tyvars (v and w) cause some delicate processing around tuples, -where we used to be able to assume that the tycon arity and the -datacon arity were the same. - -Note [Injective type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow injectivity annotations for type families (both open and closed): - - type family F (a :: k) (b :: k) = r | r -> a - type family G a b = res | res -> a b where ... - -Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. -`famTcInj` maybe stores a list of Bools, where each entry corresponds to a -single element of `tyConTyVars` (both lists should have identical length). If no -injectivity annotation was provided `famTcInj` is Nothing. From this follows an -invariant that if `famTcInj` is a Just then at least one element in the list -must be True. - -See also: - * [Injectivity annotation] in HsDecls - * [Renaming injectivity annotation] in RnSource - * [Verifying injectivity annotation] in FamInstEnv - * [Type inference for type families with injectivity] in TcInteract - -************************************************************************ -* * - TyConBinder -* * -************************************************************************ --} - -type TyConBinder = TyVarBndr TyVar TyConBndrVis - -data TyConBndrVis - = NamedTCB ArgFlag - | AnonTCB - -mkAnonTyConBinder :: TyVar -> TyConBinder -mkAnonTyConBinder tv = TvBndr tv AnonTCB - -mkAnonTyConBinders :: [TyVar] -> [TyConBinder] -mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs - -mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder --- The odd argument order supports currying -mkNamedTyConBinder vis tv = TvBndr tv (NamedTCB vis) - -mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] --- The odd argument order supports currying -mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs - -tyConBinderArgFlag :: TyConBinder -> ArgFlag -tyConBinderArgFlag (TvBndr _ (NamedTCB vis)) = vis -tyConBinderArgFlag (TvBndr _ AnonTCB) = Required - -isNamedTyConBinder :: TyConBinder -> Bool -isNamedTyConBinder (TvBndr _ (NamedTCB {})) = True -isNamedTyConBinder _ = False - -isVisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool --- Works for IfaceTyConBinder too -isVisibleTyConBinder (TvBndr _ (NamedTCB vis)) = isVisibleArgFlag vis -isVisibleTyConBinder (TvBndr _ AnonTCB) = True - -isInvisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool --- Works for IfaceTyConBinder too -isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) - -mkTyConKind :: [TyConBinder] -> Kind -> Kind -mkTyConKind bndrs res_kind = foldr mk res_kind bndrs - where - mk :: TyConBinder -> Kind -> Kind - mk (TvBndr tv AnonTCB) k = mkFunKind (tyVarKind tv) k - mk (TvBndr tv (NamedTCB vis)) k = mkForAllKind tv vis k - -{- Note [The binders/kind/arity fields of a TyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All TyCons have this group of fields - tyConBinders :: [TyConBinder] - tyConResKind :: Kind - tyConTyVars :: [TyVra] -- Cached = binderVars tyConBinders - tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind - tyConArity :: Arity -- Cached = length tyConBinders - -They fit together like so: - -* tyConBinders gives the telescope of type variables on the LHS of the - type declaration. For example: - - type App a (b :: k) = a b - - tyConBinders = [ TvBndr (k::*) (NamedTCB Inferred) - , TvBndr (a:k->*) AnonTCB - , TvBndr (b:k) AnonTCB ] - - Note that that are three binders here, including the - kind variable k. - - See Note [TyBinders and ArgFlags] in TyCoRep for what - the visibility flag means. - -* Each TyConBinder tyConBinders has a TyVar, and that TyVar may - scope over some other part of the TyCon's definition. Eg - type T a = a->a - we have - tyConBinders = [ TvBndr (a:*) AnonTCB ] - synTcRhs = a->a - So the 'a' scopes over the synTcRhs - -* From the tyConBinders and tyConResKind we can get the tyConKind - E.g for our App example: - App :: forall k. (k->*) -> k -> * - - We get a 'forall' in the kind for each NamedTCB, and an arrow - for each AnonTCB - - tyConKind is the full kind of the TyCon, not just the result kind - -* tyConArity is the arguments this TyCon must be applied to, to be - considered saturated. Here we mean "applied to in the actual Type", - not surface syntax; i.e. including implicit kind variables. - So it's just (length tyConBinders) --} - -instance Outputable tv => Outputable (TyVarBndr tv TyConBndrVis) where - ppr (TvBndr v AnonTCB) = ppr v - ppr (TvBndr v (NamedTCB Required)) = ppr v - ppr (TvBndr v (NamedTCB Specified)) = char '@' <> ppr v - ppr (TvBndr v (NamedTCB Inferred)) = braces (ppr v) - -instance Binary TyConBndrVis where - put_ bh AnonTCB = putByte bh 0 - put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } - - get bh = do { h <- getByte bh - ; case h of - 0 -> return AnonTCB - _ -> do { vis <- get bh; return (NamedTCB vis) } } - - -{- ********************************************************************* -* * - The TyCon type -* * -************************************************************************ --} - - --- | TyCons represent type constructors. Type constructors are introduced by --- things such as: --- --- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of --- kind @*@ --- --- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor --- --- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor --- of kind @* -> *@ --- --- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor --- of kind @*@ --- --- This data type also encodes a number of primitive, built in type constructors --- such as those for function and tuple types. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data TyCon - = -- | The function type constructor, @(->)@ - FunTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - tcRepName :: TyConRepName - } - - -- | Algebraic data types, from - -- - @data@ declarations - -- - @newtype@ declarations - -- - data instance declarations - -- - type instance declarations - -- - the TyCon generated by a class declaration - -- - boxed tuples - -- - unboxed tuples - -- - constraint tuples - -- All these constructors are lifted and boxed except unboxed tuples - -- which should have an 'UnboxedAlgTyCon' parent. - -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. - -- See 'AlgTyConRhs' for more information. - | AlgTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - -- The tyConTyVars scope over: - -- - -- 1. The 'algTcStupidTheta' - -- 2. The cached types in algTyConRhs.NewTyCon - -- 3. The family instance types if present - -- - -- Note that it does /not/ scope over the data - -- constructors. - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - tyConCType :: Maybe CType,-- ^ The C type that should be used - -- for this type when using the FFI - -- and CAPI - - algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT - -- syntax? If so, that doesn't mean it's a - -- true GADT; only that the "where" form - -- was used. This field is used only to - -- guide pretty-printing - - algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data - -- type (always empty for GADTs). A - -- \"stupid theta\" is the context to - -- the left of an algebraic type - -- declaration, e.g. @Eq a@ in the - -- declaration @data Eq a => T a ...@. - - algTcRhs :: AlgTyConRhs, -- ^ Contains information about the - -- data constructors of the algebraic type - - algTcFields :: FieldLabelEnv, -- ^ Maps a label to information - -- about the field - - algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration - -- 'TyCon' for derived 'TyCon's representing - -- class or family instances, respectively. - - } - - -- | Represents type synonyms - | SynonymTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - -- tyConTyVars scope over: synTcRhs - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - synTcRhs :: Type, -- ^ Contains information about the expansion - -- of the synonym - - synIsTau :: Bool, -- True <=> the RHS of this synonym does not - -- have any foralls, after expanding any - -- nested synonyms - synIsFamFree :: Bool -- True <=> the RHS of this synonym does not mention - -- any type synonym families (data families - -- are fine), again after expanding any - -- nested synonyms - } - - -- | Represents families (both type and data) - -- Argument roles are all Nominal - | FamilyTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - -- tyConTyVars connect an associated family TyCon - -- with its parent class; see TcValidity.checkConsistentFamInst - - famTcResVar :: Maybe Name, -- ^ Name of result type variable, used - -- for pretty-printing with --show-iface - -- and for reifying TyCon in Template - -- Haskell - - famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, - -- abstract, built-in. See comments for - -- FamTyConFlav - - famTcParent :: Maybe Class, -- ^ For *associated* type/data families - -- The class in whose declaration the family is declared - -- See Note [Associated families and their parent class] - - famTcInj :: Injectivity -- ^ is this a type family injective in - -- its type variables? Nothing if no - -- injectivity annotation was given - } - - -- | Primitive types; cannot be defined in Haskell. This includes - -- the usual suspects (such as @Int#@) as well as foreign-imported - -- types and kinds (@*@, @#@, and @?@) - | PrimTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - isUnlifted :: Bool, -- ^ Most primitive tycons are unlifted (may - -- not contain bottom) but other are lifted, - -- e.g. @RealWorld@ - -- Only relevant if tyConKind = * - - primRepName :: Maybe TyConRepName -- Only relevant for kind TyCons - -- i.e, *, #, ? - } - - -- | Represents promoted data constructor. - | PromotedDataCon { -- See Note [Promoted data constructors] - tyConUnique :: Unique, -- ^ Same Unique as the data constructor - tyConName :: Name, -- ^ Same Name as the data constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars - dataCon :: DataCon, -- ^ Corresponding data constructor - tcRepName :: TyConRepName, - promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo' - } - - -- | These exist only during a recursive type/class type-checking knot. - | TcTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tyConUnsat :: Bool, -- ^ can this tycon be unsaturated? - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - tcTyConScopedTyVars :: [TyVar] -- ^ Scoped tyvars over the - -- tycon's body. See Note [TcTyCon] - } - --- | Represents right-hand-sides of 'TyCon's for algebraic types -data AlgTyConRhs - - -- | Says that we know nothing about this data type, except that - -- it's represented by a pointer. Used when we export a data type - -- abstractly into an .hi file. - = AbstractTyCon - - -- | Information about those 'TyCon's derived from a @data@ - -- declaration. This includes data types with no constructors at - -- all. - | DataTyCon { - data_cons :: [DataCon], - -- ^ The data type constructors; can be empty if the - -- user declares the type to have no constructors - -- - -- INVARIANT: Kept in order of increasing 'DataCon' - -- tag (see the tag assignment in DataCon.mkDataCon) - - is_enum :: Bool -- ^ Cached value: is this an enumeration type? - -- See Note [Enumeration types] - } - - | TupleTyCon { -- A boxed, unboxed, or constraint tuple - data_con :: DataCon, -- NB: it can be an *unboxed* tuple - tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint - -- tuple? - } - - | SumTyCon { - data_cons :: [DataCon] - } - - -- | Information about those 'TyCon's derived from a @newtype@ declaration - | NewTyCon { - data_con :: DataCon, -- ^ The unique constructor for the @newtype@. - -- It has no existentials - - nt_rhs :: Type, -- ^ Cached value: the argument type of the - -- constructor, which is just the representation - -- type of the 'TyCon' (remember that @newtype@s - -- do not exist at runtime so need a different - -- representation type). - -- - -- The free 'TyVar's of this type are the - -- 'tyConTyVars' from the corresponding 'TyCon' - - nt_etad_rhs :: ([TyVar], Type), - -- ^ Same as the 'nt_rhs', but this time eta-reduced. - -- Hence the list of 'TyVar's in this field may be - -- shorter than the declared arity of the 'TyCon'. - - -- See Note [Newtype eta] - nt_co :: CoAxiom Unbranched - -- The axiom coercion that creates the @newtype@ - -- from the representation 'Type'. - - -- See Note [Newtype coercions] - -- Invariant: arity = #tvs in nt_etad_rhs; - -- See Note [Newtype eta] - -- Watch out! If any newtypes become transparent - -- again check Trac #1072. - } - --- | Some promoted datacons signify extra info relevant to GHC. For example, --- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' --- constructor of 'PrimRep'. This data structure allows us to store this --- information right in the 'TyCon'. The other approach would be to look --- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. -data RuntimeRepInfo - = NoRRI -- ^ an ordinary promoted data con - | RuntimeRep ([Type] -> [PrimRep]) - -- ^ A constructor of @RuntimeRep@. The argument to the function should - -- be the list of arguments to the promoted datacon. - | VecCount Int -- ^ A constructor of @VecCount@ - | VecElem PrimElemRep -- ^ A constructor of @VecElem@ - --- | Extract those 'DataCon's that we are able to learn about. Note --- that visibility in this sense does not correspond to visibility in --- the context of any particular user program! -visibleDataCons :: AlgTyConRhs -> [DataCon] -visibleDataCons (AbstractTyCon {}) = [] -visibleDataCons (DataTyCon{ data_cons = cs }) = cs -visibleDataCons (NewTyCon{ data_con = c }) = [c] -visibleDataCons (TupleTyCon{ data_con = c }) = [c] -visibleDataCons (SumTyCon{ data_cons = cs }) = cs - --- ^ Both type classes as well as family instances imply implicit --- type constructors. These implicit type constructors refer to their parent --- structure (ie, the class or family from which they derive) using a type of --- the following form. -data AlgTyConFlav - = -- | An ordinary type constructor has no parent. - VanillaAlgTyCon - TyConRepName - - -- | An unboxed type constructor. The TyConRepName is a Maybe since we - -- currently don't allow unboxed sums to be Typeable since there are too - -- many of them. See #13276. - | UnboxedAlgTyCon - (Maybe TyConRepName) - - -- | Type constructors representing a class dictionary. - -- See Note [ATyCon for classes] in TyCoRep - | ClassTyCon - Class -- INVARIANT: the classTyCon of this Class is the - -- current tycon - TyConRepName - - -- | Type constructors representing an *instance* of a *data* family. - -- Parameters: - -- - -- 1) The type family in question - -- - -- 2) Instance types; free variables are the 'tyConTyVars' - -- of the current 'TyCon' (not the family one). INVARIANT: - -- the number of types matches the arity of the family 'TyCon' - -- - -- 3) A 'CoTyCon' identifying the representation - -- type with the type instance family - | DataFamInstTyCon -- See Note [Data type families] - (CoAxiom Unbranched) -- The coercion axiom. - -- A *Representational* coercion, - -- of kind T ty1 ty2 ~R R:T a b c - -- where T is the family TyCon, - -- and R:T is the representation TyCon (ie this one) - -- and a,b,c are the tyConTyVars of this TyCon - -- - -- BUT may be eta-reduced; see TcInstDcls - -- Note [Eta reduction for data family axioms] - - -- Cached fields of the CoAxiom, but adjusted to - -- use the tyConTyVars of this TyCon - TyCon -- The family TyCon - [Type] -- Argument types (mentions the tyConTyVars of this TyCon) - -- Match in length the tyConTyVars of the family TyCon - - -- E.g. data instance T [a] = ... - -- gives a representation tycon: - -- data R:TList a = ... - -- axiom co a :: T [a] ~ R:TList a - -- with R:TList's algTcParent = DataFamInstTyCon T [a] co - -instance Outputable AlgTyConFlav where - ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" - ppr (UnboxedAlgTyCon {}) = text "Unboxed ADT" - ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls - ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" - <+> ppr tc <+> sep (map pprType tys) - --- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class --- name, if any -okParent :: Name -> AlgTyConFlav -> Bool -okParent _ (VanillaAlgTyCon {}) = True -okParent _ (UnboxedAlgTyCon {}) = True -okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) -okParent _ (DataFamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys - -isNoParent :: AlgTyConFlav -> Bool -isNoParent (VanillaAlgTyCon {}) = True -isNoParent _ = False - --------------------- - -data Injectivity - = NotInjective - | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) - deriving( Eq ) - --- | Information pertaining to the expansion of a type synonym (@type@) -data FamTyConFlav - = -- | Represents an open type family without a fixed right hand - -- side. Additional instances can appear at any time. - -- - -- These are introduced by either a top level declaration: - -- - -- > data family T a :: * - -- - -- Or an associated data type declaration, within a class declaration: - -- - -- > class C a b where - -- > data T b :: * - DataFamilyTyCon - TyConRepName - - -- | An open type synonym family e.g. @type family F x y :: * -> *@ - | OpenSynFamilyTyCon - - -- | A closed type synonym family e.g. - -- @type family F x where { F Int = Bool }@ - | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) - -- See Note [Closed type families] - - -- | A closed type synonym family declared in an hs-boot file with - -- type family F a where .. - | AbstractClosedSynFamilyTyCon - - -- | Built-in type family used by the TypeNats solver - | BuiltInSynFamTyCon BuiltInSynFamily - -instance Outputable FamTyConFlav where - ppr (DataFamilyTyCon n) = text "data family" <+> ppr n - ppr OpenSynFamilyTyCon = text "open type family" - ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" - ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax - ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" - ppr (BuiltInSynFamTyCon _) = text "built-in type family" - -{- Note [Closed type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* In an open type family you can add new instances later. This is the - usual case. - -* In a closed type family you can only put equations where the family - is defined. - -A non-empty closed type family has a single axiom with multiple -branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed -type family with no equations does not have an axiom, because there is -nothing for the axiom to prove! - - -Note [Promoted data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All data constructors can be promoted to become a type constructor, -via the PromotedDataCon alternative in TyCon. - -* The TyCon promoted from a DataCon has the *same* Name and Unique as - the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, - say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) - -* Small note: We promote the *user* type of the DataCon. Eg - data T = MkT {-# UNPACK #-} !(Bool, Bool) - The promoted kind is - MkT :: (Bool,Bool) -> T - *not* - MkT :: Bool -> Bool -> T - -Note [Enumeration types] -~~~~~~~~~~~~~~~~~~~~~~~~ -We define datatypes with no constructors to *not* be -enumerations; this fixes trac #2578, Otherwise we -end up generating an empty table for - __closure_tbl -which is used by tagToEnum# to map Int# to constructors -in an enumeration. The empty table apparently upset -the linker. - -Moreover, all the data constructor must be enumerations, meaning -they have type (forall abc. T a b c). GADTs are not enumerations. -For example consider - data T a where - T1 :: T Int - T2 :: T Bool - T3 :: T a -What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. -See Trac #4528. - -Note [Newtype coercions] -~~~~~~~~~~~~~~~~~~~~~~~~ -The NewTyCon field nt_co is a CoAxiom which is used for coercing from -the representation type of the newtype, to the newtype itself. For -example, - - newtype T a = MkT (a -> a) - -the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. - -In the case that the right hand side is a type application -ending with the same type variables as the left hand side, we -"eta-contract" the coercion. So if we had - - newtype S a = MkT [a] - -then we would generate the arity 0 axiom CoS : S ~ []. The -primary reason we do this is to make newtype deriving cleaner. - -In the paper we'd write - axiom CoT : (forall t. T t) ~ (forall t. [t]) -and then when we used CoT at a particular type, s, we'd say - CoT @ s -which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) - -Note [Newtype eta] -~~~~~~~~~~~~~~~~~~ -Consider - newtype Parser a = MkParser (IO a) deriving Monad -Are these two types equal (to Core)? - Monad Parser - Monad IO -which we need to make the derived instance for Monad Parser. - -Well, yes. But to see that easily we eta-reduce the RHS type of -Parser, in this case to ([], Froogle), so that even unsaturated applications -of Parser will work right. This eta reduction is done when the type -constructor is built, and cached in NewTyCon. - -Here's an example that I think showed up in practice -Source code: - newtype T a = MkT [a] - newtype Foo m = MkFoo (forall a. m a -> Int) - - w1 :: Foo [] - w1 = ... - - w2 :: Foo T - w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) - -After desugaring, and discarding the data constructors for the newtypes, -we get: - w2 = w1 `cast` Foo CoT -so the coercion tycon CoT must have - kind: T ~ [] - and arity: 0 - -Note [TcTyCon] -~~~~~~~~~~~~~~ -TcTyCons are used for tow distinct purposes - -1. When recovering from a type error in a type declaration, - we want to put the erroneous TyCon in the environment in a - way that won't lead to more errors. We use a TcTyCon for this; - see makeRecoveryTyCon. - -2. When checking a type/class declaration (in module TcTyClsDecls), we come - upon knowledge of the eventual tycon in bits and pieces. First, we use - getInitialKinds to look over the user-provided kind signature of a tycon - (including, for example, the number of parameters written to the tycon) - to get an initial shape of the tycon's kind. Then, using these initial - kinds, we kind-check the body of the tycon (class methods, data constructors, - etc.), filling in the metavariables in the tycon's initial kind. - We then generalize to get the tycon's final, fixed kind. Finally, once - this has happened for all tycons in a mutually recursive group, we - can desugar the lot. - - For convenience, we store partially-known tycons in TcTyCons, which - might store meta-variables. These TcTyCons are stored in the local - environment in TcTyClsDecls, until the real full TyCons can be created - during desugaring. A desugared program should never have a TcTyCon. - - A challenging piece in all of this is that we end up taking three separate - passes over every declaration: one in getInitialKind (this pass look only - at the head, not the body), one in kcTyClDecls (to kind-check the body), - and a final one in tcTyClDecls (to desugar). In the latter two passes, - we need to connect the user-written type variables in an LHsQTyVars - with the variables in the tycon's inferred kind. Because the tycon might - not have a CUSK, this matching up is, in general, quite hard to do. - (Look through the git history between Dec 2015 and Apr 2016 for - TcHsType.splitTelescopeTvs!) Instead of trying, we just store the list - of type variables to bring into scope in the later passes when we create - a TcTyCon in getInitialKinds. Much easier this way! These tyvars are - brought into scope in kcTyClTyVars and tcTyClTyVars, both in TcHsType. - - It is important that the scoped type variables not be zonked, as some - scoped type variables come into existence as SigTvs. If we zonk, the - Unique will change and the user-written occurrences won't match up with - what we expect. - - In a TcTyCon, everything is zonked (except the scoped vars) after - the kind-checking pass. - -************************************************************************ -* * - TyConRepName -* * -********************************************************************* -} - -type TyConRepName = Name -- The Name of the top-level declaration - -- $tcMaybe :: Data.Typeable.Internal.TyCon - -- $tcMaybe = TyCon { tyConName = "Maybe", ... } - -tyConRepName_maybe :: TyCon -> Maybe TyConRepName -tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) - = Just rep_nm -tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm }) - = mb_rep_nm -tyConRepName_maybe (AlgTyCon { algTcParent = parent }) - | VanillaAlgTyCon rep_nm <- parent = Just rep_nm - | ClassTyCon _ rep_nm <- parent = Just rep_nm - | UnboxedAlgTyCon rep_nm <- parent = rep_nm -tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) - = Just rep_nm -tyConRepName_maybe (PromotedDataCon { tcRepName = rep_nm }) - = Just rep_nm -tyConRepName_maybe _ = Nothing - --- | Make a 'Name' for the 'Typeable' representation of the given wired-in type -mkPrelTyConRepName :: Name -> TyConRepName --- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. -mkPrelTyConRepName tc_name -- Prelude tc_name is always External, - -- so nameModule will work - = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) - where - name_occ = nameOccName tc_name - name_mod = nameModule tc_name - name_uniq = nameUnique tc_name - rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq - | otherwise = dataConRepNameUnique name_uniq - (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ - --- | The name (and defining module) for the Typeable representation (TyCon) of a --- type constructor. --- --- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. -tyConRepModOcc :: Module -> OccName -> (Module, OccName) -tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) - where - rep_module - | tc_module == gHC_PRIM = gHC_TYPES - | otherwise = tc_module - - -{- ********************************************************************* -* * - PrimRep -* * -************************************************************************ - -Note [rep swamp] - -GHC has a rich selection of types that represent "primitive types" of -one kind or another. Each of them makes a different set of -distinctions, and mostly the differences are for good reasons, -although it's probably true that we could merge some of these. - -Roughly in order of "includes more information": - - - A Width (cmm/CmmType) is simply a binary value with the specified - number of bits. It may represent a signed or unsigned integer, a - floating-point value, or an address. - - data Width = W8 | W16 | W32 | W64 | W80 | W128 - - - Size, which is used in the native code generator, is Width + - floating point information. - - data Size = II8 | II16 | II32 | II64 | FF32 | FF64 | FF80 - - it is necessary because e.g. the instruction to move a 64-bit float - on x86 (movsd) is different from the instruction to move a 64-bit - integer (movq), so the mov instruction is parameterised by Size. - - - CmmType wraps Width with more information: GC ptr, float, or - other value. - - data CmmType = CmmType CmmCat Width - - data CmmCat -- "Category" (not exported) - = GcPtrCat -- GC pointer - | BitsCat -- Non-pointer - | FloatCat -- Float - - It is important to have GcPtr information in Cmm, since we generate - info tables containing pointerhood for the GC from this. As for - why we have float (and not signed/unsigned) here, see Note [Signed - vs unsigned]. - - - ArgRep makes only the distinctions necessary for the call and - return conventions of the STG machine. It is essentially CmmType - + void. - - - PrimRep makes a few more distinctions than ArgRep: it divides - non-GC-pointers into signed/unsigned and addresses, information - that is necessary for passing these values to foreign functions. - -There's another tension here: whether the type encodes its size in -bytes, or whether its size depends on the machine word size. Width -and CmmType have the size built-in, whereas ArgRep and PrimRep do not. - -This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. - -On the other hand, CmmType includes some "nonsense" values, such as -CmmType GcPtrCat W32 on a 64-bit machine. --} - --- | A 'PrimRep' is an abstraction of a type. It contains information that --- the code generator needs in order to pass arguments, return results, --- and store values of this type. -data PrimRep - = VoidRep - | LiftedRep - | UnliftedRep -- ^ Unlifted pointer - | IntRep -- ^ Signed, word-sized value - | WordRep -- ^ Unsigned, word-sized value - | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) - | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) - | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') - | FloatRep - | DoubleRep - | VecRep Int PrimElemRep -- ^ A vector - deriving( Eq, Show ) - -data PrimElemRep - = Int8ElemRep - | Int16ElemRep - | Int32ElemRep - | Int64ElemRep - | Word8ElemRep - | Word16ElemRep - | Word32ElemRep - | Word64ElemRep - | FloatElemRep - | DoubleElemRep - deriving( Eq, Show ) - -instance Outputable PrimRep where - ppr r = text (show r) - -instance Outputable PrimElemRep where - ppr r = text (show r) - -isVoidRep :: PrimRep -> Bool -isVoidRep VoidRep = True -isVoidRep _other = False - -isGcPtrRep :: PrimRep -> Bool -isGcPtrRep LiftedRep = True -isGcPtrRep UnliftedRep = True -isGcPtrRep _ = False - --- | Find the size of a 'PrimRep', in words -primRepSizeW :: DynFlags -> PrimRep -> Int -primRepSizeW _ IntRep = 1 -primRepSizeW _ WordRep = 1 -primRepSizeW dflags Int64Rep = wORD64_SIZE `quot` wORD_SIZE dflags -primRepSizeW dflags Word64Rep = wORD64_SIZE `quot` wORD_SIZE dflags -primRepSizeW _ FloatRep = 1 -- NB. might not take a full word -primRepSizeW dflags DoubleRep = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags -primRepSizeW _ AddrRep = 1 -primRepSizeW _ LiftedRep = 1 -primRepSizeW _ UnliftedRep = 1 -primRepSizeW _ VoidRep = 0 -primRepSizeW dflags (VecRep len rep) = len * primElemRepSizeB rep `quot` wORD_SIZE dflags - -primElemRepSizeB :: PrimElemRep -> Int -primElemRepSizeB Int8ElemRep = 1 -primElemRepSizeB Int16ElemRep = 2 -primElemRepSizeB Int32ElemRep = 4 -primElemRepSizeB Int64ElemRep = 8 -primElemRepSizeB Word8ElemRep = 1 -primElemRepSizeB Word16ElemRep = 2 -primElemRepSizeB Word32ElemRep = 4 -primElemRepSizeB Word64ElemRep = 8 -primElemRepSizeB FloatElemRep = 4 -primElemRepSizeB DoubleElemRep = 8 - --- | Return if Rep stands for floating type, --- returns Nothing for vector types. -primRepIsFloat :: PrimRep -> Maybe Bool -primRepIsFloat FloatRep = Just True -primRepIsFloat DoubleRep = Just True -primRepIsFloat (VecRep _ _) = Nothing -primRepIsFloat _ = Just False - - -{- -************************************************************************ -* * - Field labels -* * -************************************************************************ --} - --- | The labels for the fields of this particular 'TyCon' -tyConFieldLabels :: TyCon -> [FieldLabel] -tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc - --- | The labels for the fields of this particular 'TyCon' -tyConFieldLabelEnv :: TyCon -> FieldLabelEnv -tyConFieldLabelEnv tc - | isAlgTyCon tc = algTcFields tc - | otherwise = emptyDFsEnv - --- | Look up a field label belonging to this 'TyCon' -lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel -lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl - --- | Make a map from strings to FieldLabels from all the data --- constructors of this algebraic tycon -fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv -fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl) - | fl <- dataConsFields (visibleDataCons rhs) ] - where - -- Duplicates in this list will be removed by 'mkFsEnv' - dataConsFields dcs = concatMap dataConFieldLabels dcs - - -{- -************************************************************************ -* * -\subsection{TyCon Construction} -* * -************************************************************************ - -Note: the TyCon constructors all take a Kind as one argument, even though -they could, in principle, work out their Kind from their other arguments. -But to do so they need functions from Types, and that makes a nasty -module mutual-recursion. And they aren't called from many places. -So we compromise, and move their Kind calculation to the call site. --} - --- | Given the name of the function type constructor and it's kind, create the --- corresponding 'TyCon'. It is recomended to use 'TyCoRep.funTyCon' if you want --- this functionality -mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon -mkFunTyCon name binders rep_nm - = FunTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConResKind = liftedTypeKind, - tyConKind = mkTyConKind binders liftedTypeKind, - tyConArity = length binders, - tcRepName = rep_nm - } - --- | This is the making of an algebraic 'TyCon'. Notably, you have to --- pass in the generic (in the -XGenerics sense) information about the --- type constructor - you can get hold of it easily (see Generics --- module) -mkAlgTyCon :: Name - -> [TyConBinder] -- ^ Binders of the 'TyCon' - -> Kind -- ^ Result kind - -> [Role] -- ^ The roles for each TyVar - -> Maybe CType -- ^ The C type this type corresponds to - -- when using the CAPI FFI - -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' - -> AlgTyConRhs -- ^ Information about data constructors - -> AlgTyConFlav -- ^ What flavour is it? - -- (e.g. vanilla, type family) - -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? - -> TyCon -mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn - = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConTyVars = binderVars binders, - tcRoles = roles, - tyConCType = cType, - algTcStupidTheta = stupid, - algTcRhs = rhs, - algTcFields = fieldsOfAlgTcRhs rhs, - algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, - algTcGadtSyntax = gadt_syn - } - --- | Simpler specialization of 'mkAlgTyCon' for classes -mkClassTyCon :: Name -> [TyConBinder] - -> [Role] -> AlgTyConRhs -> Class - -> Name -> TyCon -mkClassTyCon name binders roles rhs clas tc_rep_name - = mkAlgTyCon name binders constraintKind roles Nothing [] rhs - (ClassTyCon clas tc_rep_name) - False - -mkTupleTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ Result kind of the 'TyCon' - -> Arity -- ^ Arity of the tuple 'TyCon' - -> DataCon - -> TupleSort -- ^ Whether the tuple is boxed or unboxed - -> AlgTyConFlav - -> TyCon -mkTupleTyCon name binders res_kind arity con sort parent - = AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = binderVars binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = TupleTyCon { data_con = con, - tup_sort = sort }, - algTcFields = emptyDFsEnv, - algTcParent = parent - } - -mkSumTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ Kind of the resulting 'TyCon' - -> Arity -- ^ Arity of the sum - -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' - -> [DataCon] - -> AlgTyConFlav - -> TyCon -mkSumTyCon name binders res_kind arity tyvars cons parent - = AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = tyvars, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = SumTyCon { data_cons = cons }, - algTcFields = emptyDFsEnv, - algTcParent = parent - } - --- | Makes a tycon suitable for use during type-checking. --- The only real need for this is for printing error messages during --- a recursive type/class type-checking knot. It has a kind because --- TcErrors sometimes calls typeKind. --- See also Note [Kind checking recursive type and class declarations] --- in TcTyClsDecls. -mkTcTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ /result/ kind only - -> Bool -- ^ Can this be unsaturated? - -> [TyVar] -- ^ Scoped type variables, see Note [TcTyCon] - -> TyCon -mkTcTyCon name binders res_kind unsat scoped_tvs - = TcTyCon { tyConUnique = getUnique name - , tyConName = name - , tyConTyVars = binderVars binders - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConUnsat = unsat - , tyConArity = length binders - , tcTyConScopedTyVars = scoped_tvs } - --- | Create an unlifted primitive 'TyCon', such as @Int#@. -mkPrimTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind, never levity-polymorphic - -> [Role] -> TyCon -mkPrimTyCon name binders res_kind roles - = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name) - --- | Kind constructors -mkKindTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind - -> [Role] -> Name -> TyCon -mkKindTyCon name binders res_kind roles rep_nm - = tc - where - tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) - --- | Create a lifted primitive 'TyCon' such as @RealWorld@ -mkLiftedPrimTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind - -> [Role] -> TyCon -mkLiftedPrimTyCon name binders res_kind roles - = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) - where rep_nm = mkPrelTyConRepName name - -mkPrimTyCon' :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind, never levity-polymorphic - -- (If you need a levity-polymorphic PrimTyCon, change - -- isTcLevPoly.) - -> [Role] - -> Bool -> Maybe TyConRepName -> TyCon -mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm - = PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length roles, - tcRoles = roles, - isUnlifted = is_unlifted, - primRepName = rep_nm - } - --- | Create a type synonym 'TyCon' -mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> [Role] -> Type -> Bool -> Bool -> TyCon -mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free - = SynonymTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConTyVars = binderVars binders, - tcRoles = roles, - synTcRhs = rhs, - synIsTau = is_tau, - synIsFamFree = is_fam_free - } - --- | Create a type family 'TyCon' -mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> Maybe Name -> FamTyConFlav - -> Maybe Class -> Injectivity -> TyCon -mkFamilyTyCon name binders res_kind resVar flav parent inj - = FamilyTyCon - { tyConUnique = nameUnique name - , tyConName = name - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConArity = length binders - , tyConTyVars = binderVars binders - , famTcResVar = resVar - , famTcFlav = flav - , famTcParent = parent - , famTcInj = inj - } - - --- | Create a promoted data constructor 'TyCon' --- Somewhat dodgily, we give it the same Name --- as the data constructor itself; when we pretty-print --- the TyCon we add a quote; see the Outputable TyCon instance -mkPromotedDataCon :: DataCon -> Name -> TyConRepName - -> [TyConBinder] -> Kind -> [Role] - -> RuntimeRepInfo -> TyCon -mkPromotedDataCon con name rep_name binders res_kind roles rep_info - = PromotedDataCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConArity = length roles, - tcRoles = roles, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - dataCon = con, - tcRepName = rep_name, - promDcRepInfo = rep_info - } - -isFunTyCon :: TyCon -> Bool -isFunTyCon (FunTyCon {}) = True -isFunTyCon _ = False - --- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) -isAbstractTyCon :: TyCon -> Bool -isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True -isAbstractTyCon _ = False - --- | Make an fake, recovery 'TyCon' from an existing one. --- Used when recovering from errors -makeRecoveryTyCon :: TyCon -> TyCon -makeRecoveryTyCon tc - = mkTcTyCon (tyConName tc) - (tyConBinders tc) (tyConResKind tc) - (mightBeUnsaturatedTyCon tc) [{- no scoped vars -}] - --- | Does this 'TyCon' represent something that cannot be defined in Haskell? -isPrimTyCon :: TyCon -> Bool -isPrimTyCon (PrimTyCon {}) = True -isPrimTyCon _ = False - --- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can --- only be true for primitive and unboxed-tuple 'TyCon's -isUnliftedTyCon :: TyCon -> Bool -isUnliftedTyCon (PrimTyCon {isUnlifted = is_unlifted}) - = is_unlifted -isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) - | TupleTyCon { tup_sort = sort } <- rhs - = not (isBoxed (tupleSortBoxity sort)) -isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) - | SumTyCon {} <- rhs - = True -isUnliftedTyCon _ = False - --- | Returns @True@ if the supplied 'TyCon' resulted from either a --- @data@ or @newtype@ declaration -isAlgTyCon :: TyCon -> Bool -isAlgTyCon (AlgTyCon {}) = True -isAlgTyCon _ = False - --- | Returns @True@ for vanilla AlgTyCons -- that is, those created --- with a @data@ or @newtype@ declaration. -isVanillaAlgTyCon :: TyCon -> Bool -isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True -isVanillaAlgTyCon _ = False - -isDataTyCon :: TyCon -> Bool --- ^ Returns @True@ for data types that are /definitely/ represented by --- heap-allocated constructors. These are scrutinised by Core-level --- @case@ expressions, and they get info tables allocated for them. --- --- Generally, the function will be true for all @data@ types and false --- for @newtype@s, unboxed tuples, unboxed sums and type family --- 'TyCon's. But it is not guaranteed to return @True@ in all cases --- that it could. --- --- NB: for a data type family, only the /instance/ 'TyCon's --- get an info table. The family declaration 'TyCon' does not -isDataTyCon (AlgTyCon {algTcRhs = rhs}) - = case rhs of - TupleTyCon { tup_sort = sort } - -> isBoxed (tupleSortBoxity sort) - SumTyCon {} -> False - DataTyCon {} -> True - NewTyCon {} -> False - AbstractTyCon {} -> False -- We don't know, so return False -isDataTyCon _ = False - --- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds --- (where X is the role passed in): --- If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2) --- (where X1, X2, and X3, are the roles given by tyConRolesX tc X) --- See also Note [Decomposing equality] in TcCanonical -isInjectiveTyCon :: TyCon -> Role -> Bool -isInjectiveTyCon _ Phantom = False -isInjectiveTyCon (FunTyCon {}) _ = True -isInjectiveTyCon (AlgTyCon {}) Nominal = True -isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational - = isGenInjAlgRhs rhs -isInjectiveTyCon (SynonymTyCon {}) _ = False -isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) - Nominal = True -isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj -isInjectiveTyCon (FamilyTyCon {}) _ = False -isInjectiveTyCon (PrimTyCon {}) _ = True -isInjectiveTyCon (PromotedDataCon {}) _ = True -isInjectiveTyCon (TcTyCon {}) _ = True - -- Reply True for TcTyCon to minimise knock on type errors - -- See Note [TcTyCon] item (1) - --- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds --- (where X is the role passed in): --- If (T tys ~X t), then (t's head ~X T). --- See also Note [Decomposing equality] in TcCanonical -isGenerativeTyCon :: TyCon -> Role -> Bool -isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True -isGenerativeTyCon (FamilyTyCon {}) _ = False - -- in all other cases, injectivity implies generativity -isGenerativeTyCon tc r = isInjectiveTyCon tc r - --- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective --- with respect to representational equality? -isGenInjAlgRhs :: AlgTyConRhs -> Bool -isGenInjAlgRhs (TupleTyCon {}) = True -isGenInjAlgRhs (SumTyCon {}) = True -isGenInjAlgRhs (DataTyCon {}) = True -isGenInjAlgRhs (AbstractTyCon {}) = False -isGenInjAlgRhs (NewTyCon {}) = False - --- | Is this 'TyCon' that for a @newtype@ -isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True -isNewTyCon _ = False - --- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands --- into, and (possibly) a coercion from the representation type to the @newtype@. --- Returns @Nothing@ if this is not possible. -unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) -unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, - algTcRhs = NewTyCon { nt_co = co, - nt_rhs = rhs }}) - = Just (tvs, rhs, co) -unwrapNewTyCon_maybe _ = Nothing - -unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) -unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, - nt_etad_rhs = (tvs,rhs) }}) - = Just (tvs, rhs, co) -unwrapNewTyConEtad_maybe _ = Nothing - -isProductTyCon :: TyCon -> Bool --- True of datatypes or newtypes that have --- one, non-existential, data constructor --- See Note [Product types] -isProductTyCon tc@(AlgTyCon {}) - = case algTcRhs tc of - TupleTyCon {} -> True - DataTyCon{ data_cons = [data_con] } - -> null (dataConExTyVars data_con) - NewTyCon {} -> True - _ -> False -isProductTyCon _ = False - -isDataProductTyCon_maybe :: TyCon -> Maybe DataCon --- True of datatypes (not newtypes) with --- one, vanilla, data constructor --- See Note [Product types] -isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [con] } - | null (dataConExTyVars con) -- non-existential - -> Just con - TupleTyCon { data_con = con } - -> Just con - _ -> Nothing -isDataProductTyCon_maybe _ = Nothing - -isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon] -isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = cons } - | length cons > 1 - , all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this? - -> Just cons - SumTyCon { data_cons = cons } - | all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this? - -> Just cons - _ -> Nothing -isDataSumTyCon_maybe _ = Nothing - -{- Note [Product types] -~~~~~~~~~~~~~~~~~~~~~~~ -A product type is - * A data type (not a newtype) - * With one, boxed data constructor - * That binds no existential type variables - -The main point is that product types are amenable to unboxing for - * Strict function calls; we can transform - f (D a b) = e - to - fw a b = e - via the worker/wrapper transformation. (Question: couldn't this - work for existentials too?) - - * CPR for function results; we can transform - f x y = let ... in D a b - to - fw x y = let ... in (# a, b #) - -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. --} - - --- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? -isTypeSynonymTyCon :: TyCon -> Bool -isTypeSynonymTyCon (SynonymTyCon {}) = True -isTypeSynonymTyCon _ = False - -isTauTyCon :: TyCon -> Bool -isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau -isTauTyCon _ = True - -isFamFreeTyCon :: TyCon -> Bool -isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free -isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav -isFamFreeTyCon _ = True - --- As for newtypes, it is in some contexts important to distinguish between --- closed synonyms and synonym families, as synonym families have no unique --- right hand side to which a synonym family application can expand. --- - --- | True iff we can decompose (T a b c) into ((T a b) c) --- I.e. is it injective and generative w.r.t nominal equality? --- That is, if (T a b) ~N d e f, is it always the case that --- (T ~N d), (a ~N e) and (b ~N f)? --- Specifically NOT true of synonyms (open and otherwise) --- --- It'd be unusual to call mightBeUnsaturatedTyCon on a regular H98 --- type synonym, because you should probably have expanded it first --- But regardless, it's not decomposable -mightBeUnsaturatedTyCon :: TyCon -> Bool -mightBeUnsaturatedTyCon (SynonymTyCon {}) = False -mightBeUnsaturatedTyCon (FamilyTyCon { famTcFlav = flav}) = isDataFamFlav flav -mightBeUnsaturatedTyCon (TcTyCon { tyConUnsat = unsat }) = unsat -mightBeUnsaturatedTyCon _other = True - --- | Is this an algebraic 'TyCon' declared with the GADT syntax? -isGadtSyntaxTyCon :: TyCon -> Bool -isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res -isGadtSyntaxTyCon _ = False - --- | Is this an algebraic 'TyCon' which is just an enumeration of values? -isEnumerationTyCon :: TyCon -> Bool --- See Note [Enumeration types] in TyCon -isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs }) - = case rhs of - DataTyCon { is_enum = res } -> res - TupleTyCon {} -> arity == 0 - _ -> False -isEnumerationTyCon _ = False - --- | Is this a 'TyCon', synonym or otherwise, that defines a family? -isFamilyTyCon :: TyCon -> Bool -isFamilyTyCon (FamilyTyCon {}) = True -isFamilyTyCon _ = False - --- | Is this a 'TyCon', synonym or otherwise, that defines a family with --- instances? -isOpenFamilyTyCon :: TyCon -> Bool -isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav }) - | OpenSynFamilyTyCon <- flav = True - | DataFamilyTyCon {} <- flav = True -isOpenFamilyTyCon _ = False - --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isTypeFamilyTyCon :: TyCon -> Bool -isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav) -isTypeFamilyTyCon _ = False - --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isDataFamilyTyCon :: TyCon -> Bool -isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav -isDataFamilyTyCon _ = False - --- | Is this an open type family TyCon? -isOpenTypeFamilyTyCon :: TyCon -> Bool -isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True -isOpenTypeFamilyTyCon _ = False - --- | Is this a non-empty closed type family? Returns 'Nothing' for --- abstract or empty closed families. -isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) -isClosedSynFamilyTyConWithAxiom_maybe - (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb -isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing - --- | Try to read the injectivity information from a FamilyTyCon. --- For every other TyCon this function panics. -familyTyConInjectivityInfo :: TyCon -> Injectivity -familyTyConInjectivityInfo (FamilyTyCon { famTcInj = inj }) = inj -familyTyConInjectivityInfo _ = panic "familyTyConInjectivityInfo" - -isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily -isBuiltInSynFamTyCon_maybe - (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops -isBuiltInSynFamTyCon_maybe _ = Nothing - -isDataFamFlav :: FamTyConFlav -> Bool -isDataFamFlav (DataFamilyTyCon {}) = True -- Data family -isDataFamFlav _ = False -- Type synonym family - --- | Are we able to extract information 'TyVar' to class argument list --- mapping from a given 'TyCon'? -isTyConAssoc :: TyCon -> Bool -isTyConAssoc tc = isJust (tyConAssoc_maybe tc) - -tyConAssoc_maybe :: TyCon -> Maybe Class -tyConAssoc_maybe (FamilyTyCon { famTcParent = mb_cls }) = mb_cls -tyConAssoc_maybe _ = Nothing - --- The unit tycon didn't used to be classed as a tuple tycon --- but I thought that was silly so I've undone it --- If it can't be for some reason, it should be a AlgTyCon -isTupleTyCon :: TyCon -> Bool --- ^ Does this 'TyCon' represent a tuple? --- --- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to --- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they --- get spat into the interface file as tuple tycons, so I don't think --- it matters. -isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True -isTupleTyCon _ = False - -tyConTuple_maybe :: TyCon -> Maybe TupleSort -tyConTuple_maybe (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort} <- rhs = Just sort -tyConTuple_maybe _ = Nothing - --- | Is this the 'TyCon' for an unboxed tuple? -isUnboxedTupleTyCon :: TyCon -> Bool -isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort } <- rhs - = not (isBoxed (tupleSortBoxity sort)) -isUnboxedTupleTyCon _ = False - --- | Is this the 'TyCon' for a boxed tuple? -isBoxedTupleTyCon :: TyCon -> Bool -isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort } <- rhs - = isBoxed (tupleSortBoxity sort) -isBoxedTupleTyCon _ = False - --- | Is this the 'TyCon' for an unboxed sum? -isUnboxedSumTyCon :: TyCon -> Bool -isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) - | SumTyCon {} <- rhs - = True -isUnboxedSumTyCon _ = False - --- | Is this the 'TyCon' for a /promoted/ tuple? -isPromotedTupleTyCon :: TyCon -> Bool -isPromotedTupleTyCon tyCon - | Just dataCon <- isPromotedDataCon_maybe tyCon - , isTupleTyCon (dataConTyCon dataCon) = True - | otherwise = False - --- | Is this a PromotedDataCon? -isPromotedDataCon :: TyCon -> Bool -isPromotedDataCon (PromotedDataCon {}) = True -isPromotedDataCon _ = False - --- | Retrieves the promoted DataCon if this is a PromotedDataCon; -isPromotedDataCon_maybe :: TyCon -> Maybe DataCon -isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc -isPromotedDataCon_maybe _ = Nothing - --- | Is this tycon really meant for use at the kind level? That is, --- should it be permitted without -XDataKinds? -isKindTyCon :: TyCon -> Bool -isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys - --- | These TyCons should be allowed at the kind level, even without --- -XDataKinds. -kindTyConKeys :: UniqSet Unique -kindTyConKeys = unionManyUniqSets - ( mkUniqSet [ liftedTypeKindTyConKey, starKindTyConKey, unicodeStarKindTyConKey - , constraintKindTyConKey, tYPETyConKey ] - : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon - , vecCountTyCon, vecElemTyCon ] ) - where - tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) - -isLiftedTypeKindTyConName :: Name -> Bool -isLiftedTypeKindTyConName - = (`hasKey` liftedTypeKindTyConKey) <||> - (`hasKey` starKindTyConKey) <||> - (`hasKey` unicodeStarKindTyConKey) - --- | Identifies implicit tycons that, in particular, do not go into interface --- files (because they are implicitly reconstructed when the interface is --- read). --- --- Note that: --- --- * Associated families are implicit, as they are re-constructed from --- the class declaration in which they reside, and --- --- * Family instances are /not/ implicit as they represent the instance body --- (similar to a @dfun@ does that for a class instance). --- --- * Tuples are implicit iff they have a wired-in name --- (namely: boxed and unboxed tupeles are wired-in and implicit, --- but constraint tuples are not) -isImplicitTyCon :: TyCon -> Bool -isImplicitTyCon (FunTyCon {}) = True -isImplicitTyCon (PrimTyCon {}) = True -isImplicitTyCon (PromotedDataCon {}) = True -isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) - | TupleTyCon {} <- rhs = isWiredInName name - | SumTyCon {} <- rhs = True - | otherwise = False -isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent -isImplicitTyCon (SynonymTyCon {}) = False -isImplicitTyCon (TcTyCon {}) = False - -tyConCType_maybe :: TyCon -> Maybe CType -tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc -tyConCType_maybe _ = Nothing - --- | Is this a TcTyCon? (That is, one only used during type-checking?) -isTcTyCon :: TyCon -> Bool -isTcTyCon (TcTyCon {}) = True -isTcTyCon _ = False - --- | Could this TyCon ever be levity-polymorphic when fully applied? --- True is safe. False means we're sure. Does only a quick check --- based on the TyCon's category. --- Precondition: The fully-applied TyCon has kind (TYPE blah) -isTcLevPoly :: TyCon -> Bool -isTcLevPoly FunTyCon{} = False -isTcLevPoly (AlgTyCon { algTcParent = UnboxedAlgTyCon _ }) = True -isTcLevPoly AlgTyCon{} = False -isTcLevPoly SynonymTyCon{} = True -isTcLevPoly FamilyTyCon{} = True -isTcLevPoly PrimTyCon{} = False -isTcLevPoly TcTyCon{} = False -isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc) - -{- ------------------------------------------------ --- Expand type-constructor applications ------------------------------------------------ --} - -expandSynTyCon_maybe - :: TyCon - -> [tyco] -- ^ Arguments to 'TyCon' - -> Maybe ([(TyVar,tyco)], - Type, - [tyco]) -- ^ Returns a 'TyVar' substitution, the body - -- type of the synonym (not yet substituted) - -- and any arguments remaining from the - -- application - --- ^ Expand a type synonym application, if any -expandSynTyCon_maybe tc tys - | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc - = case arity `compare` length tys of - LT -> Just (tvs `zip` tys, rhs, drop arity tys) - EQ -> Just (tvs `zip` tys, rhs, []) - GT -> Nothing - | otherwise - = Nothing - ----------------- - --- | Check if the tycon actually refers to a proper `data` or `newtype` --- with user defined constructors rather than one from a class or other --- construction. -isTyConWithSrcDataCons :: TyCon -> Bool -isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) = - case rhs of - DataTyCon {} -> isSrcParent - NewTyCon {} -> isSrcParent - TupleTyCon {} -> isSrcParent - _ -> False - where - isSrcParent = isNoParent parent -isTyConWithSrcDataCons _ = False - - --- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no --- constructors could be found -tyConDataCons :: TyCon -> [DataCon] --- It's convenient for tyConDataCons to return the --- empty list for type synonyms etc -tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] - --- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' --- is the sort that can have any constructors (note: this does not include --- abstract algebraic types) -tyConDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs}) - = case rhs of - DataTyCon { data_cons = cons } -> Just cons - NewTyCon { data_con = con } -> Just [con] - TupleTyCon { data_con = con } -> Just [con] - SumTyCon { data_cons = cons } -> Just cons - _ -> Nothing -tyConDataCons_maybe _ = Nothing - --- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ --- type with one alternative, a tuple type or a @newtype@ then that constructor --- is returned. If the 'TyCon' has more than one constructor, or represents a --- primitive or function type constructor then @Nothing@ is returned. In any --- other case, the function panics -tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon -tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [c] } -> Just c - TupleTyCon { data_con = c } -> Just c - NewTyCon { data_con = c } -> Just c - _ -> Nothing -tyConSingleDataCon_maybe _ = Nothing - -tyConSingleDataCon :: TyCon -> DataCon -tyConSingleDataCon tc - = case tyConSingleDataCon_maybe tc of - Just c -> c - Nothing -> pprPanic "tyConDataCon" (ppr tc) - -tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon --- Returns (Just con) for single-constructor --- *algebraic* data types *not* newtypes -tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [c] } -> Just c - TupleTyCon { data_con = c } -> Just c - _ -> Nothing -tyConSingleAlgDataCon_maybe _ = Nothing - --- | Determine the number of value constructors a 'TyCon' has. Panics if the --- 'TyCon' is not algebraic or a tuple -tyConFamilySize :: TyCon -> Int -tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = cons } -> length cons - NewTyCon {} -> 1 - TupleTyCon {} -> 1 - SumTyCon { data_cons = cons } -> length cons - _ -> pprPanic "tyConFamilySize 1" (ppr tc) -tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) - --- | Extract an 'AlgTyConRhs' with information about data constructors from an --- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' -algTyConRhs :: TyCon -> AlgTyConRhs -algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs -algTyConRhs other = pprPanic "algTyConRhs" (ppr other) - --- | Extract type variable naming the result of injective type family -tyConFamilyResVar_maybe :: TyCon -> Maybe Name -tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res -tyConFamilyResVar_maybe _ = Nothing - --- | Get the list of roles for the type parameters of a TyCon -tyConRoles :: TyCon -> [Role] --- See also Note [TyCon Role signatures] -tyConRoles tc - = case tc of - { FunTyCon {} -> const_role Representational - ; AlgTyCon { tcRoles = roles } -> roles - ; SynonymTyCon { tcRoles = roles } -> roles - ; FamilyTyCon {} -> const_role Nominal - ; PrimTyCon { tcRoles = roles } -> roles - ; PromotedDataCon { tcRoles = roles } -> roles - ; TcTyCon {} -> const_role Nominal - } - where - const_role r = replicate (tyConArity tc) r - --- | Extract the bound type variables and type expansion of a type synonym --- 'TyCon'. Panics if the 'TyCon' is not a synonym -newTyConRhs :: TyCon -> ([TyVar], Type) -newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) - = (tvs, rhs) -newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) - --- | The number of type parameters that need to be passed to a newtype to --- resolve it. May be less than in the definition if it can be eta-contracted. -newTyConEtadArity :: TyCon -> Int -newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) - = length (fst tvs_rhs) -newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon) - --- | Extract the bound type variables and type expansion of an eta-contracted --- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym -newTyConEtadRhs :: TyCon -> ([TyVar], Type) -newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs -newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) - --- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to --- construct something with the @newtype@s type from its representation type --- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns --- @Nothing@ -newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) -newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co -newTyConCo_maybe _ = Nothing - -newTyConCo :: TyCon -> CoAxiom Unbranched -newTyConCo tc = case newTyConCo_maybe tc of - Just co -> co - Nothing -> pprPanic "newTyConCo" (ppr tc) - -newTyConDataCon_maybe :: TyCon -> Maybe DataCon -newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con -newTyConDataCon_maybe _ = Nothing - --- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context --- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration --- @data Eq a => T a ...@ -tyConStupidTheta :: TyCon -> [PredType] -tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid -tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) - --- | Extract the 'TyVar's bound by a vanilla type synonym --- and the corresponding (unsubstituted) right hand side. -synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) -synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) - = Just (tyvars, ty) -synTyConDefn_maybe _ = Nothing - --- | Extract the information pertaining to the right hand side of a type synonym --- (@type@) declaration. -synTyConRhs_maybe :: TyCon -> Maybe Type -synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs -synTyConRhs_maybe _ = Nothing - --- | Extract the flavour of a type family (with all the extra information that --- it carries) -famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav -famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav -famTyConFlav_maybe _ = Nothing - --- | Is this 'TyCon' that for a class instance? -isClassTyCon :: TyCon -> Bool -isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True -isClassTyCon _ = False - --- | If this 'TyCon' is that for a class instance, return the class it is for. --- Otherwise returns @Nothing@ -tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas -tyConClass_maybe _ = Nothing - --- | Return the associated types of the 'TyCon', if any -tyConATs :: TyCon -> [TyCon] -tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas -tyConATs _ = [] - ----------------------------------------------------------------------------- --- | Is this 'TyCon' that for a data family instance? -isFamInstTyCon :: TyCon -> Bool -isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} }) - = True -isFamInstTyCon _ = False - -tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) -tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts }) - = Just (f, ts, ax) -tyConFamInstSig_maybe _ = Nothing - --- | If this 'TyCon' is that of a data family instance, return the family in question --- and the instance types. Otherwise, return @Nothing@ -tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) -tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts }) - = Just (f, ts) -tyConFamInst_maybe _ = Nothing - --- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which --- represents a coercion identifying the representation type with the type --- instance family. Otherwise, return @Nothing@ -tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) -tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ }) - = Just ax -tyConFamilyCoercion_maybe _ = Nothing - --- | Extract any 'RuntimeRepInfo' from this TyCon -tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo -tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri -tyConRuntimeRepInfo _ = NoRRI - -- could panic in that second case. But Douglas Adams told me not to. - -{- -************************************************************************ -* * -\subsection[TyCon-instances]{Instance declarations for @TyCon@} -* * -************************************************************************ - -@TyCon@s are compared by comparing their @Unique@s. --} - -instance Eq TyCon where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Uniquable TyCon where - getUnique tc = tyConUnique tc - -instance Outputable TyCon where - -- At the moment a promoted TyCon has the same Name as its - -- corresponding TyCon, so we add the quote to distinguish it here - ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) - -tyConFlavour :: TyCon -> String -tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) - | ClassTyCon _ _ <- parent = "class" - | otherwise = case rhs of - TupleTyCon { tup_sort = sort } - | isBoxed (tupleSortBoxity sort) -> "tuple" - | otherwise -> "unboxed tuple" - SumTyCon {} -> "unboxed sum" - DataTyCon {} -> "data type" - NewTyCon {} -> "newtype" - AbstractTyCon {} -> "abstract type" -tyConFlavour (FamilyTyCon { famTcFlav = flav }) - | isDataFamFlav flav = "data family" - | otherwise = "type family" -tyConFlavour (SynonymTyCon {}) = "type synonym" -tyConFlavour (FunTyCon {}) = "built-in type" -tyConFlavour (PrimTyCon {}) = "built-in type" -tyConFlavour (PromotedDataCon {}) = "promoted data constructor" -tyConFlavour tc@(TcTyCon {}) - = pprPanic "tyConFlavour sees a TcTyCon" (ppr tc) - -pprPromotionQuote :: TyCon -> SDoc --- Promoted data constructors already have a tick in their OccName -pprPromotionQuote tc - = case tc of - PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types - _ -> empty - -instance NamedThing TyCon where - getName = tyConName - -instance Data.Data TyCon where - -- don't traverse? - toConstr _ = abstractConstr "TyCon" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "TyCon" - -instance Binary Injectivity where - put_ bh NotInjective = putByte bh 0 - put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs - - get bh = do { h <- getByte bh - ; case h of - 0 -> return NotInjective - _ -> do { xs <- get bh - ; return (Injective xs) } } - -{- -************************************************************************ -* * - Walking over recursive TyCons -* * -************************************************************************ - -Note [Expanding newtypes and products] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When expanding a type to expose a data-type constructor, we need to be -careful about newtypes, lest we fall into an infinite loop. Here are -the key examples: - - newtype Id x = MkId x - newtype Fix f = MkFix (f (Fix f)) - newtype T = MkT (T -> T) - - Type Expansion - -------------------------- - T T -> T - Fix Maybe Maybe (Fix Maybe) - Id (Id Int) Int - Fix Id NO NO NO - -Notice that - * We can expand T, even though it's recursive. - * We can expand Id (Id Int), even though the Id shows up - twice at the outer level, because Id is non-recursive - -So, when expanding, we keep track of when we've seen a recursive -newtype at outermost level; and bail out if we see it again. - -We sometimes want to do the same for product types, so that the -strictness analyser doesn't unbox infinitely deeply. - -More precisely, we keep a *count* of how many times we've seen it. -This is to account for - data instance T (a,b) = MkT (T a) (T b) -Then (Trac #10482) if we have a type like - T (Int,(Int,(Int,(Int,Int)))) -we can still unbox deeply enough during strictness analysis. -We have to treat T as potentially recursive, but it's still -good to be able to unwrap multiple layers. - -The function that manages all this is checkRecTc. --} - -data RecTcChecker = RC !Int (NameEnv Int) - -- The upper bound, and the number of times - -- we have encountered each TyCon - -initRecTc :: RecTcChecker --- Intialise with a fixed max bound of 100 --- We should probably have a flag for this -initRecTc = RC 100 emptyNameEnv - -checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker --- Nothing => Recursion detected --- Just rec_tcs => Keep going -checkRecTc (RC bound rec_nts) tc - = case lookupNameEnv rec_nts tc_name of - Just n | n >= bound -> Nothing - | otherwise -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1))) - Nothing -> Just (RC bound (extendNameEnv rec_nts tc_name 1)) - where - tc_name = tyConName tc - --- | Returns whether or not this 'TyCon' is definite, or a hole --- that may be filled in at some later point. See Note [Skolem abstract data] -tyConSkolem :: TyCon -> Bool -tyConSkolem = isHoleName . tyConName - --- Note [Skolem abstract data] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Skolem abstract data arises from data declarations in an hsig file. --- --- The best analogy is to interpret the types declared in signature files as --- elaborating to universally quantified type variables; e.g., --- --- unit p where --- signature H where --- data T --- data S --- module M where --- import H --- f :: (T ~ S) => a -> b --- f x = x --- --- elaborates as (with some fake structural types): --- --- p :: forall t s. { f :: forall a b. t ~ s => a -> b } --- p = { f = \x -> x } -- ill-typed --- --- It is clear that inside p, t ~ s is not provable (and --- if we tried to write a function to cast t to s, that --- would not work), but if we call p @Int @Int, clearly Int ~ Int --- is provable. The skolem variables are all distinct from --- one another, but we can't make assumptions like "f is --- inaccessible", because the skolem variables will get --- instantiated eventually! --- --- Skolem abstractness can apply to "non-abstract" data as well): --- --- unit p where --- signature H1 where --- data T = MkT --- signature H2 where --- data T = MkT --- module M where --- import qualified H1 --- import qualified H2 --- f :: (H1.T ~ H2.T) => a -> b --- f x = x --- --- This is why the test is on the original name of the TyCon, --- not whether it is abstract or not. diff --git a/types/TyCon.hs-boot b/types/TyCon.hs-boot deleted file mode 100644 --- a/types/TyCon.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module TyCon where - -data TyCon - -isTupleTyCon :: TyCon -> Bool -isUnboxedTupleTyCon :: TyCon -> Bool -isFunTyCon :: TyCon -> Bool diff --git a/types/Type.hs b/types/Type.hs deleted file mode 100644 --- a/types/Type.hs +++ /dev/null @@ -1,2459 +0,0 @@ --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1998 --- --- Type - public interface - -{-# LANGUAGE CPP, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Main functions for manipulating types and type-related things -module Type ( - -- Note some of this is just re-exports from TyCon.. - - -- * Main data types representing Types - -- $type_classification - - -- $representation_types - TyThing(..), Type, ArgFlag(..), KindOrType, PredType, ThetaType, - Var, TyVar, isTyVar, TyCoVar, TyBinder, TyVarBinder, - - -- ** Constructing and deconstructing types - mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, - getCastedTyVar_maybe, tyVarKind, - - mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, - splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, - - mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, - splitFunTys, funResultTy, funArgTy, - - mkTyConApp, mkTyConTy, - tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, - tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, - splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole, - tcRepSplitTyConApp_maybe, tcSplitTyConApp_maybe, - splitListTyConApp_maybe, - repSplitTyConApp_maybe, - - mkForAllTy, mkForAllTys, mkInvForAllTys, mkSpecForAllTys, - mkVisForAllTys, mkInvForAllTy, - splitForAllTys, splitForAllTyVarBndrs, - splitForAllTy_maybe, splitForAllTy, - splitPiTy_maybe, splitPiTy, splitPiTys, - mkPiTy, mkPiTys, mkTyConBindersPreferAnon, - mkLamType, mkLamTypes, - piResultTy, piResultTys, - applyTysX, dropForAlls, - - mkNumLitTy, isNumLitTy, - mkStrLitTy, isStrLitTy, - - getRuntimeRep_maybe, getRuntimeRepFromKind_maybe, - - mkCastTy, mkCoercionTy, splitCastTy_maybe, - - userTypeError_maybe, pprUserTypeErrorTy, - - coAxNthLHS, - stripCoercionTy, splitCoercionType_maybe, - - splitPiTysInvisible, filterOutInvisibleTypes, - filterOutInvisibleTyVars, partitionInvisibles, - synTyConResKind, - - modifyJoinResTy, setJoinResTy, - - -- Analyzing types - TyCoMapper(..), mapType, mapCoercion, - - -- (Newtypes) - newTyConInstRhs, - - -- Pred types - mkFamilyTyConApp, - isDictLikeTy, - mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, - equalityTyCon, - mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, - mkClassPred, - isClassPred, isEqPred, isNomEqPred, - isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, - isCTupleClass, - - -- Deconstructing predicate types - PredTree(..), EqRel(..), eqRelRole, classifyPredType, - getClassPredTys, getClassPredTys_maybe, - getEqPredTys, getEqPredTys_maybe, getEqPredRole, - predTypeEqRel, - - -- ** Binders - sameVis, - mkTyVarBinder, mkTyVarBinders, - mkAnonBinder, - isAnonTyBinder, isNamedTyBinder, - binderVar, binderVars, binderKind, binderArgFlag, - tyBinderType, - binderRelevantType_maybe, caseBinder, - isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, isInvisibleBinder, - tyConBindersTyBinders, - mkTyBinderTyConBinder, - - -- ** Common type constructors - funTyCon, - - -- ** Predicates on types - isTyVarTy, isFunTy, isDictTy, isPredTy, isCoercionTy, - isCoercionTy_maybe, isCoercionType, isForAllTy, - isPiTy, isTauTy, isFamFreeTy, - - isValidJoinPointType, - - -- (Lifting and boxity) - isLiftedType_maybe, isUnliftedType, isUnboxedTupleType, isUnboxedSumType, - isAlgType, isClosedAlgType, isDataFamilyAppType, - isPrimitiveType, isStrictType, - isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, - dropRuntimeRepArgs, - getRuntimeRep, getRuntimeRepFromKind, - - -- * Main data types representing Kinds - Kind, - - -- ** Finding the kind of a type - typeKind, isTypeLevPoly, resultIsLevPoly, - - -- ** Common Kind - liftedTypeKind, - - -- * Type free variables - tyCoFVsOfType, tyCoFVsBndr, - tyCoVarsOfType, tyCoVarsOfTypes, - tyCoVarsOfTypeDSet, - coVarsOfType, - coVarsOfTypes, closeOverKinds, closeOverKindsList, - noFreeVarsOfType, - splitVisVarsOfType, splitVisVarsOfTypes, - expandTypeSynonyms, - typeSize, - - -- * Well-scoped lists of variables - dVarSetElemsWellScoped, toposortTyVars, tyCoVarsOfTypeWellScoped, - tyCoVarsOfTypesWellScoped, - - -- * Type comparison - eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, - nonDetCmpTypesX, nonDetCmpTc, - eqVarBndrs, - - -- * Forcing evaluation of types - seqType, seqTypes, - - -- * Other views onto Types - coreView, tcView, - - tyConsOfType, - - -- * Main type substitution data types - TvSubstEnv, -- Representation widely visible - TCvSubst(..), -- Representation visible to a few friends - - -- ** Manipulating type substitutions - emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, - - mkTCvSubst, zipTvSubst, mkTvSubstPrs, - notElemTCvSubst, - getTvSubstEnv, setTvSubstEnv, - zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, - extendTCvSubst, extendCvSubst, - extendTvSubst, extendTvSubstBinder, - extendTvSubstList, extendTvSubstAndInScope, - extendTvSubstWithClone, - isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, - isEmptyTCvSubst, unionTCvSubst, - - -- ** Performing substitution on types and kinds - substTy, substTys, substTyWith, substTysWith, substTheta, - substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTyWithInScope, - substTyVarBndr, substTyVar, substTyVars, - cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, - - -- * Pretty-printing - pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprShortTyThing, - pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, - pprSigmaType, ppSuggestExplicitKinds, - pprTheta, pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, pprSourceTyCon, - TyPrec(..), maybeParen, - pprTyVar, pprTyVars, pprPrefixApp, pprArrowChain, - - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyOpenKind, - tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars, - tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyVarOcc, - tidyTopType, - tidyKind, - tidyTyVarBinder, tidyTyVarBinders - ) where - -#include "HsVersions.h" - -import BasicTypes - --- We import the representation and primitive functions from TyCoRep. --- Many things are reexported, but not the representation! - -import Kind -import TyCoRep - --- friends: -import Var -import VarEnv -import VarSet -import UniqSet - -import Class -import TyCon -import TysPrim -import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind - , typeSymbolKind, liftedTypeKind ) -import PrelNames -import CoAxiom -import {-# SOURCE #-} Coercion - --- others -import Util -import Outputable -import FastString -import Pair -import ListSetOps -import Digraph -import Unique ( nonDetCmpUnique ) -import SrcLoc ( SrcSpan ) -import OccName ( OccName ) -import Name ( mkInternalName ) - -import Maybes ( orElse ) -import Data.Maybe ( isJust, mapMaybe ) -import Control.Monad ( guard ) -import Control.Arrow ( first, second ) - --- $type_classification --- #type_classification# --- --- Types are one of: --- --- [Unboxed] Iff its representation is other than a pointer --- Unboxed types are also unlifted. --- --- [Lifted] Iff it has bottom as an element. --- Closures always have lifted types: i.e. any --- let-bound identifier in Core must have a lifted --- type. Operationally, a lifted object is one that --- can be entered. --- Only lifted types may be unified with a type variable. --- --- [Algebraic] Iff it is a type with one or more constructors, whether --- declared with @data@ or @newtype@. --- An algebraic type is one that can be deconstructed --- with a case expression. This is /not/ the same as --- lifted types, because we also include unboxed --- tuples in this classification. --- --- [Data] Iff it is a type declared with @data@, or a boxed tuple. --- --- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. --- --- Currently, all primitive types are unlifted, but that's not necessarily --- the case: for example, @Int@ could be primitive. --- --- Some primitive types are unboxed, such as @Int#@, whereas some are boxed --- but unlifted (such as @ByteArray#@). The only primitive types that we --- classify as algebraic are the unboxed tuples. --- --- Some examples of type classifications that may make this a bit clearer are: --- --- @ --- Type primitive boxed lifted algebraic --- ----------------------------------------------------------------------------- --- Int# Yes No No No --- ByteArray# Yes Yes No No --- (\# a, b \#) Yes No No Yes --- (\# a | b \#) Yes No No Yes --- ( a, b ) No Yes Yes Yes --- [a] No Yes Yes Yes --- @ - --- $representation_types --- A /source type/ is a type that is a separate type as far as the type checker is --- concerned, but which has a more low-level representation as far as Core-to-Core --- passes and the rest of the back end is concerned. --- --- You don't normally have to worry about this, as the utility functions in --- this module will automatically convert a source into a representation type --- if they are spotted, to the best of it's abilities. If you don't want this --- to happen, use the equivalent functions from the "TcType" module. - -{- -************************************************************************ -* * - Type representation -* * -************************************************************************ - -Note [coreView vs tcView] -~~~~~~~~~~~~~~~~~~~~~~~~~ -So far as the typechecker is concerned, 'Constraint' and 'TYPE LiftedRep' are distinct kinds. - -But in Core these two are treated as identical. - -We implement this by making 'coreView' convert 'Constraint' to 'TYPE LiftedRep' on the fly. -The function tcView (used in the type checker) does not do this. - -See also Trac #11715, which tracks removing this inconsistency. - --} - -{-# INLINE coreView #-} -coreView :: Type -> Maybe Type --- ^ This function Strips off the /top layer only/ of a type synonym --- application (if any) its underlying representation type. --- Returns Nothing if there is nothing to look through. --- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@. --- --- By being non-recursive and inlined, this case analysis gets efficiently --- joined onto the case analysis that the caller is already doing -coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') - -- The free vars of 'rhs' should all be bound by 'tenv', so it's - -- ok to use 'substTy' here. - -- See also Note [The substitution invariant] in TyCoRep. - -- Its important to use mkAppTys, rather than (foldl AppTy), - -- because the function part might well return a - -- partially-applied type constructor; indeed, usually will! -coreView (TyConApp tc []) - | isStarKindSynonymTyCon tc - = Just liftedTypeKind - -coreView _ = Nothing - --- | Gives the typechecker view of a type. This unwraps synonyms but --- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into --- TYPE LiftedRep. Returns Nothing if no unwrapping happens. --- See also Note [coreView vs tcView] in Type. -{-# INLINE tcView #-} -tcView :: Type -> Maybe Type -tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') - -- The free vars of 'rhs' should all be bound by 'tenv', so it's - -- ok to use 'substTy' here. - -- See also Note [The substitution invariant] in TyCoRep. - -- Its important to use mkAppTys, rather than (foldl AppTy), - -- because the function part might well return a - -- partially-applied type constructor; indeed, usually will! -tcView _ = Nothing - ------------------------------------------------ -expandTypeSynonyms :: Type -> Type --- ^ Expand out all type synonyms. Actually, it'd suffice to expand out --- just the ones that discard type variables (e.g. type Funny a = Int) --- But we don't know which those are currently, so we just expand all. --- --- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, --- not in the kinds of any TyCon or TyVar mentioned in the type. --- --- Keep this synchronized with 'synonymTyConsOfType' -expandTypeSynonyms ty - = go (mkEmptyTCvSubst in_scope) ty - where - in_scope = mkInScopeSet (tyCoVarsOfType ty) - - go subst (TyConApp tc tys) - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys - = let subst' = mkTvSubst in_scope (mkVarEnv tenv) - -- Make a fresh substitution; rhs has nothing to - -- do with anything that has happened so far - -- NB: if you make changes here, be sure to build an - -- /idempotent/ substitution, even in the nested case - -- type T a b = a -> b - -- type S x y = T y x - -- (Trac #11665) - in mkAppTys (go subst' rhs) tys' - | otherwise - = TyConApp tc expanded_tys - where - expanded_tys = (map (go subst) tys) - - go _ (LitTy l) = LitTy l - go subst (TyVarTy tv) = substTyVar subst tv - go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) - go subst (FunTy arg res) - = mkFunTy (go subst arg) (go subst res) - go subst (ForAllTy (TvBndr tv vis) t) - = let (subst', tv') = substTyVarBndrCallback go subst tv in - ForAllTy (TvBndr tv' vis) (go subst' t) - go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) - go subst (CoercionTy co) = mkCoercionTy (go_co subst co) - - go_co subst (Refl r ty) - = mkReflCo r (go subst ty) - -- NB: coercions are always expanded upon creation - go_co subst (TyConAppCo r tc args) - = mkTyConAppCo r tc (map (go_co subst) args) - go_co subst (AppCo co arg) - = mkAppCo (go_co subst co) (go_co subst arg) - go_co subst (ForAllCo tv kind_co co) - = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in - mkForAllCo tv' kind_co' (go_co subst' co) - go_co subst (FunCo r co1 co2) - = mkFunCo r (go_co subst co1) (go_co subst co2) - go_co subst (CoVarCo cv) - = substCoVar subst cv - go_co subst (AxiomInstCo ax ind args) - = mkAxiomInstCo ax ind (map (go_co subst) args) - go_co subst (UnivCo p r t1 t2) - = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) - go_co subst (SymCo co) - = mkSymCo (go_co subst co) - go_co subst (TransCo co1 co2) - = mkTransCo (go_co subst co1) (go_co subst co2) - go_co subst (NthCo n co) - = mkNthCo n (go_co subst co) - go_co subst (LRCo lr co) - = mkLRCo lr (go_co subst co) - go_co subst (InstCo co arg) - = mkInstCo (go_co subst co) (go_co subst arg) - go_co subst (CoherenceCo co1 co2) - = mkCoherenceCo (go_co subst co1) (go_co subst co2) - go_co subst (KindCo co) - = mkKindCo (go_co subst co) - go_co subst (SubCo co) - = mkSubCo (go_co subst co) - go_co subst (AxiomRuleCo ax cs) = AxiomRuleCo ax (map (go_co subst) cs) - - go_prov _ UnsafeCoerceProv = UnsafeCoerceProv - go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) - go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) - go_prov _ p@(PluginProv _) = p - go_prov _ (HoleProv h) = pprPanic "expandTypeSynonyms hit a hole" (ppr h) - - -- the "False" and "const" are to accommodate the type of - -- substForAllCoBndrCallback, which is general enough to - -- handle coercion optimization (which sometimes swaps the - -- order of a coercion) - go_cobndr subst = substForAllCoBndrCallback False (go_co subst) subst - -{- -************************************************************************ -* * - Analyzing types -* * -************************************************************************ - -These functions do a map-like operation over types, performing some operation -on all variables and binding sites. Primarily used for zonking. - -Note [Efficiency for mapCoercion ForAllCo case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As noted in Note [Forall coercions] in TyCoRep, a ForAllCo is a bit redundant. -It stores a TyVar and a Coercion, where the kind of the TyVar always matches -the left-hand kind of the coercion. This is convenient lots of the time, but -not when mapping a function over a coercion. - -The problem is that tcm_tybinder will affect the TyVar's kind and -mapCoercion will affect the Coercion, and we hope that the results will be -the same. Even if they are the same (which should generally happen with -correct algorithms), then there is an efficiency issue. In particular, -this problem seems to make what should be a linear algorithm into a potentially -exponential one. But it's only going to be bad in the case where there's -lots of foralls in the kinds of other foralls. Like this: - - forall a : (forall b : (forall c : ...). ...). ... - -This construction seems unlikely. So we'll do the inefficient, easy way -for now. - -Note [Specialising mappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These INLINABLE pragmas are indispensable. mapType/mapCoercion are used -to implement zonking, and it's vital that they get specialised to the TcM -monad. This specialisation happens automatically (that is, without a -SPECIALISE pragma) as long as the definitions are INLINABLE. For example, -this one change made a 20% allocation difference in perf/compiler/T5030. - --} - --- | This describes how a "map" operation over a type/coercion should behave -data TyCoMapper env m - = TyCoMapper - { tcm_smart :: Bool -- ^ Should the new type be created with smart - -- constructors? - , tcm_tyvar :: env -> TyVar -> m Type - , tcm_covar :: env -> CoVar -> m Coercion - , tcm_hole :: env -> CoercionHole -> Role - -> Type -> Type -> m Coercion - -- ^ What to do with coercion holes. See Note [Coercion holes] in - -- TyCoRep. - - , tcm_tybinder :: env -> TyVar -> ArgFlag -> m (env, TyVar) - -- ^ The returned env is used in the extended scope - } - -{-# INLINABLE mapType #-} -- See Note [Specialising mappers] -mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type -mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar - , tcm_tybinder = tybinder }) - env ty - = go ty - where - go (TyVarTy tv) = tyvar env tv - go (AppTy t1 t2) = mkappty <$> go t1 <*> go t2 - go t@(TyConApp _ []) = return t -- avoid allocation in this exceedingly - -- common case (mostly, for *) - go (TyConApp tc tys) = mktyconapp tc <$> mapM go tys - go (FunTy arg res) = FunTy <$> go arg <*> go res - go (ForAllTy (TvBndr tv vis) inner) - = do { (env', tv') <- tybinder env tv vis - ; inner' <- mapType mapper env' inner - ; return $ ForAllTy (TvBndr tv' vis) inner' } - go ty@(LitTy {}) = return ty - go (CastTy ty co) = mkcastty <$> go ty <*> mapCoercion mapper env co - go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co - - (mktyconapp, mkappty, mkcastty) - | smart = (mkTyConApp, mkAppTy, mkCastTy) - | otherwise = (TyConApp, AppTy, CastTy) - -{-# INLINABLE mapCoercion #-} -- See Note [Specialising mappers] -mapCoercion :: Monad m - => TyCoMapper env m -> env -> Coercion -> m Coercion -mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar - , tcm_hole = cohole, tcm_tybinder = tybinder }) - env co - = go co - where - go (Refl r ty) = Refl r <$> mapType mapper env ty - go (TyConAppCo r tc args) - = mktyconappco r tc <$> mapM go args - go (AppCo c1 c2) = mkappco <$> go c1 <*> go c2 - go (ForAllCo tv kind_co co) - = do { kind_co' <- go kind_co - ; (env', tv') <- tybinder env tv Inferred - ; co' <- mapCoercion mapper env' co - ; return $ mkforallco tv' kind_co' co' } - -- See Note [Efficiency for mapCoercion ForAllCo case] - go (FunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 - go (CoVarCo cv) = covar env cv - go (AxiomInstCo ax i args) - = mkaxiominstco ax i <$> mapM go args - go (UnivCo (HoleProv hole) r t1 t2) - = cohole env hole r t1 t2 - go (UnivCo p r t1 t2) - = mkunivco <$> go_prov p <*> pure r - <*> mapType mapper env t1 <*> mapType mapper env t2 - go (SymCo co) = mksymco <$> go co - go (TransCo c1 c2) = mktransco <$> go c1 <*> go c2 - go (AxiomRuleCo r cos) = AxiomRuleCo r <$> mapM go cos - go (NthCo i co) = mknthco i <$> go co - go (LRCo lr co) = mklrco lr <$> go co - go (InstCo co arg) = mkinstco <$> go co <*> go arg - go (CoherenceCo c1 c2) = mkcoherenceco <$> go c1 <*> go c2 - go (KindCo co) = mkkindco <$> go co - go (SubCo co) = mksubco <$> go co - - go_prov UnsafeCoerceProv = return UnsafeCoerceProv - go_prov (PhantomProv co) = PhantomProv <$> go co - go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co - go_prov p@(PluginProv _) = return p - go_prov (HoleProv _) = panic "mapCoercion" - - ( mktyconappco, mkappco, mkaxiominstco, mkunivco - , mksymco, mktransco, mknthco, mklrco, mkinstco, mkcoherenceco - , mkkindco, mksubco, mkforallco) - | smart - = ( mkTyConAppCo, mkAppCo, mkAxiomInstCo, mkUnivCo - , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo, mkCoherenceCo - , mkKindCo, mkSubCo, mkForAllCo ) - | otherwise - = ( TyConAppCo, AppCo, AxiomInstCo, UnivCo - , SymCo, TransCo, NthCo, LRCo, InstCo, CoherenceCo - , KindCo, SubCo, ForAllCo ) - -{- -************************************************************************ -* * -\subsection{Constructor-specific functions} -* * -************************************************************************ - - ---------------------------------------------------------------------- - TyVarTy - ~~~~~~~ --} - --- | Attempts to obtain the type variable underlying a 'Type', and panics with the --- given message if this is not a type variable type. See also 'getTyVar_maybe' -getTyVar :: String -> Type -> TyVar -getTyVar msg ty = case getTyVar_maybe ty of - Just tv -> tv - Nothing -> panic ("getTyVar: " ++ msg) - -isTyVarTy :: Type -> Bool -isTyVarTy ty = isJust (getTyVar_maybe ty) - --- | Attempts to obtain the type variable underlying a 'Type' -getTyVar_maybe :: Type -> Maybe TyVar -getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' - | otherwise = repGetTyVar_maybe ty - --- | If the type is a tyvar, possibly under a cast, returns it, along --- with the coercion. Thus, the co is :: kind tv ~R kind type -getCastedTyVar_maybe :: Type -> Maybe (TyVar, Coercion) -getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty' -getCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) -getCastedTyVar_maybe (TyVarTy tv) - = Just (tv, mkReflCo Nominal (tyVarKind tv)) -getCastedTyVar_maybe _ = Nothing - --- | Attempts to obtain the type variable underlying a 'Type', without --- any expansion -repGetTyVar_maybe :: Type -> Maybe TyVar -repGetTyVar_maybe (TyVarTy tv) = Just tv -repGetTyVar_maybe _ = Nothing - -{- ---------------------------------------------------------------------- - AppTy - ~~~~~ -We need to be pretty careful with AppTy to make sure we obey the -invariant that a TyConApp is always visibly so. mkAppTy maintains the -invariant: use it. - -Note [Decomposing fat arrow c=>t] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Can we unify (a b) with (Eq a => ty)? If we do so, we end up with -a partial application like ((=>) Eq a) which doesn't make sense in -source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). -Here's an example (Trac #9858) of how you might do it: - i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep - i p = typeRep p - - j = i (Proxy :: Proxy (Eq Int => Int)) -The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, -but suppose we want that. But then in the call to 'i', we end -up decomposing (Eq Int => Int), and we definitely don't want that. - -This really only applies to the type checker; in Core, '=>' and '->' -are the same, as are 'Constraint' and '*'. But for now I've put -the test in repSplitAppTy_maybe, which applies throughout, because -the other calls to splitAppTy are in Unify, which is also used by -the type checker (e.g. when matching type-function equations). - --} - --- | Applies a type to another, as in e.g. @k a@ -mkAppTy :: Type -> Type -> Type -mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) -mkAppTy ty1 ty2 = AppTy ty1 ty2 - -- Note that the TyConApp could be an - -- under-saturated type synonym. GHC allows that; e.g. - -- type Foo k = k a -> k a - -- type Id x = x - -- foo :: Foo Id -> Foo Id - -- - -- Here Id is partially applied in the type sig for Foo, - -- but once the type synonyms are expanded all is well - -mkAppTys :: Type -> [Type] -> Type -mkAppTys ty1 [] = ty1 -mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) -mkAppTys ty1 tys2 = foldl AppTy ty1 tys2 - -------------- -splitAppTy_maybe :: Type -> Maybe (Type, Type) --- ^ Attempt to take a type application apart, whether it is a --- function, type constructor, or plain type application. Note --- that type family applications are NEVER unsaturated by this! -splitAppTy_maybe ty | Just ty' <- coreView ty - = splitAppTy_maybe ty' -splitAppTy_maybe ty = repSplitAppTy_maybe ty - -------------- -repSplitAppTy_maybe :: Type -> Maybe (Type,Type) --- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that --- any Core view stuff is already done -repSplitAppTy_maybe (FunTy ty1 ty2) - = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - -repSplitAppTy_maybe (AppTy ty1 ty2) - = Just (ty1, ty2) - -repSplitAppTy_maybe (TyConApp tc tys) - | mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc - , Just (tys', ty') <- snocView tys - = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! - -repSplitAppTy_maybe _other = Nothing - --- this one doesn't braek apart (c => t). --- See Note [Decomposing fat arrow c=>t] --- Defined here to avoid module loops between Unify and TcType. -tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) --- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that --- any coreView stuff is already done. Refuses to look through (c => t) -tcRepSplitAppTy_maybe (FunTy ty1 ty2) - | isConstraintKind (typeKind ty1) - = Nothing -- See Note [Decomposing fat arrow c=>t] - - | otherwise - = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - -tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -tcRepSplitAppTy_maybe (TyConApp tc tys) - | mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc - , Just (tys', ty') <- snocView tys - = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! -tcRepSplitAppTy_maybe _other = Nothing - --- | Split a type constructor application into its type constructor and --- applied types. Note that this may fail in the case of a 'FunTy' with an --- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind --- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your --- type before using this function. --- --- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. -tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) --- Defined here to avoid module loops between Unify and TcType. -tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' -tcSplitTyConApp_maybe ty = tcRepSplitTyConApp_maybe ty - --- | Like 'tcSplitTyConApp_maybe' but doesn't look through type synonyms. -tcRepSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) --- Defined here to avoid module loops between Unify and TcType. -tcRepSplitTyConApp_maybe (TyConApp tc tys) - = Just (tc, tys) - -tcRepSplitTyConApp_maybe (FunTy arg res) - = Just (funTyCon, [arg_rep, res_rep, arg, res]) - where - arg_rep = getRuntimeRep arg - res_rep = getRuntimeRep res - -tcRepSplitTyConApp_maybe _ - = Nothing - -------------- -splitAppTy :: Type -> (Type, Type) --- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', --- and panics if this is not possible -splitAppTy ty = case splitAppTy_maybe ty of - Just pr -> pr - Nothing -> panic "splitAppTy" - -------------- -splitAppTys :: Type -> (Type, [Type]) --- ^ Recursively splits a type as far as is possible, leaving a residual --- type being applied to and the type arguments applied to it. Never fails, --- even if that means returning an empty list of type applications. -splitAppTys ty = split ty ty [] - where - split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args - split _ (AppTy ty arg) args = split ty ty (arg:args) - split _ (TyConApp tc tc_args) args - = let -- keep type families saturated - n | mightBeUnsaturatedTyCon tc = 0 - | otherwise = tyConArity tc - (tc_args1, tc_args2) = splitAt n tc_args - in - (TyConApp tc tc_args1, tc_args2 ++ args) - split _ (FunTy ty1 ty2) args - = ASSERT( null args ) - (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - - split orig_ty _ args = (orig_ty, args) - --- | Like 'splitAppTys', but doesn't look through type synonyms -repSplitAppTys :: Type -> (Type, [Type]) -repSplitAppTys ty = split ty [] - where - split (AppTy ty arg) args = split ty (arg:args) - split (TyConApp tc tc_args) args - = let n | mightBeUnsaturatedTyCon tc = 0 - | otherwise = tyConArity tc - (tc_args1, tc_args2) = splitAt n tc_args - in - (TyConApp tc tc_args1, tc_args2 ++ args) - split (FunTy ty1 ty2) args - = ASSERT( null args ) - (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - - split ty args = (ty, args) - -{- - LitTy - ~~~~~ --} - -mkNumLitTy :: Integer -> Type -mkNumLitTy n = LitTy (NumTyLit n) - --- | Is this a numeric literal. We also look through type synonyms. -isNumLitTy :: Type -> Maybe Integer -isNumLitTy ty | Just ty1 <- coreView ty = isNumLitTy ty1 -isNumLitTy (LitTy (NumTyLit n)) = Just n -isNumLitTy _ = Nothing - -mkStrLitTy :: FastString -> Type -mkStrLitTy s = LitTy (StrTyLit s) - --- | Is this a symbol literal. We also look through type synonyms. -isStrLitTy :: Type -> Maybe FastString -isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1 -isStrLitTy (LitTy (StrTyLit s)) = Just s -isStrLitTy _ = Nothing - - --- | Is this type a custom user error? --- If so, give us the kind and the error message. -userTypeError_maybe :: Type -> Maybe Type -userTypeError_maybe t - = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t - -- There may be more than 2 arguments, if the type error is - -- used as a type constructor (e.g. at kind `Type -> Type`). - - ; guard (tyConName tc == errorMessageTypeErrorFamName) - ; return msg } - --- | Render a type corresponding to a user type error into a SDoc. -pprUserTypeErrorTy :: Type -> SDoc -pprUserTypeErrorTy ty = - case splitTyConApp_maybe ty of - - -- Text "Something" - Just (tc,[txt]) - | tyConName tc == typeErrorTextDataConName - , Just str <- isStrLitTy txt -> ftext str - - -- ShowType t - Just (tc,[_k,t]) - | tyConName tc == typeErrorShowTypeDataConName -> ppr t - - -- t1 :<>: t2 - Just (tc,[t1,t2]) - | tyConName tc == typeErrorAppendDataConName -> - pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 - - -- t1 :$$: t2 - Just (tc,[t1,t2]) - | tyConName tc == typeErrorVAppendDataConName -> - pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 - - -- An uneavaluated type function - _ -> ppr ty - - - - -{- ---------------------------------------------------------------------- - FunTy - ~~~~~ - -Note [Representation of function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Functions (e.g. Int -> Char) are can be thought of as being applications -of funTyCon (known in Haskell surface syntax as (->)), - - (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) - (a :: TYPE r1) (b :: TYPE r2). - a -> b -> Type - -However, for efficiency's sake we represent saturated applications of (->) -with FunTy. For instance, the type, - - (->) r1 r2 a b - -is equivalent to, - - FunTy (Anon a) b - -Note how the RuntimeReps are implied in the FunTy representation. For this -reason we must be careful when recontructing the TyConApp representation (see, -for instance, splitTyConApp_maybe). - -In the compiler we maintain the invariant that all saturated applications of -(->) are represented with FunTy. - -See #11714. --} - -isFunTy :: Type -> Bool -isFunTy ty = isJust (splitFunTy_maybe ty) - -splitFunTy :: Type -> (Type, Type) --- ^ Attempts to extract the argument and result types from a type, and --- panics if that is not possible. See also 'splitFunTy_maybe' -splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' -splitFunTy (FunTy arg res) = (arg, res) -splitFunTy other = pprPanic "splitFunTy" (ppr other) - -splitFunTy_maybe :: Type -> Maybe (Type, Type) --- ^ Attempts to extract the argument and result types from a type -splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' -splitFunTy_maybe (FunTy arg res) = Just (arg, res) -splitFunTy_maybe _ = Nothing - -splitFunTys :: Type -> ([Type], Type) -splitFunTys ty = split [] ty ty - where - split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' - split args _ (FunTy arg res) = split (arg:args) res res - split args orig_ty _ = (reverse args, orig_ty) - -funResultTy :: Type -> Type --- ^ Extract the function result type and panic if that is not possible -funResultTy ty | Just ty' <- coreView ty = funResultTy ty' -funResultTy (FunTy _ res) = res -funResultTy ty = pprPanic "funResultTy" (ppr ty) - -funArgTy :: Type -> Type --- ^ Extract the function argument type and panic if that is not possible -funArgTy ty | Just ty' <- coreView ty = funArgTy ty' -funArgTy (FunTy arg _res) = arg -funArgTy ty = pprPanic "funArgTy" (ppr ty) - -piResultTy :: Type -> Type -> Type -piResultTy ty arg = case piResultTy_maybe ty arg of - Just res -> res - Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) - -piResultTy_maybe :: Type -> Type -> Maybe Type - --- ^ Just like 'piResultTys' but for a single argument --- Try not to iterate 'piResultTy', because it's inefficient to substitute --- one variable at a time; instead use 'piResultTys" -piResultTy_maybe ty arg - | Just ty' <- coreView ty = piResultTy_maybe ty' arg - - | FunTy _ res <- ty - = Just res - - | ForAllTy (TvBndr tv _) res <- ty - = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes [arg,res] - in Just (substTy (extendTvSubst empty_subst tv arg) res) - - | otherwise - = Nothing - --- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) --- where f :: f_ty --- 'piResultTys' is interesting because: --- 1. 'f_ty' may have more for-alls than there are args --- 2. Less obviously, it may have fewer for-alls --- For case 2. think of: --- piResultTys (forall a.a) [forall b.b, Int] --- This really can happen, but only (I think) in situations involving --- undefined. For example: --- undefined :: forall a. a --- Term: undefined @(forall b. b->b) @Int --- This term should have type (Int -> Int), but notice that --- there are more type args than foralls in 'undefined's type. - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs - --- This is a heavily used function (e.g. from typeKind), --- so we pay attention to efficiency, especially in the special case --- where there are no for-alls so we are just dropping arrows from --- a function type/kind. -piResultTys :: Type -> [Type] -> Type -piResultTys ty [] = ty -piResultTys ty orig_args@(arg:args) - | Just ty' <- coreView ty - = piResultTys ty' orig_args - - | FunTy _ res <- ty - = piResultTys res args - - | ForAllTy (TvBndr tv _) res <- ty - = go (extendVarEnv emptyTvSubstEnv tv arg) res args - - | otherwise - = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) - where - in_scope = mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) - - go :: TvSubstEnv -> Type -> [Type] -> Type - go tv_env ty [] = substTy (mkTvSubst in_scope tv_env) ty - - go tv_env ty all_args@(arg:args) - | Just ty' <- coreView ty - = go tv_env ty' all_args - - | FunTy _ res <- ty - = go tv_env res args - - | ForAllTy (TvBndr tv _) res <- ty - = go (extendVarEnv tv_env tv arg) res args - - | TyVarTy tv <- ty - , Just ty' <- lookupVarEnv tv_env tv - -- Deals with piResultTys (forall a. a) [forall b.b, Int] - = piResultTys ty' all_args - - | otherwise - = pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) - -applyTysX :: [TyVar] -> Type -> [Type] -> Type --- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys --- Assumes that (/\tvs. body_ty) is closed -applyTysX tvs body_ty arg_tys - = ASSERT2( length arg_tys >= n_tvs, pp_stuff ) - ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff ) - mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty) - (drop n_tvs arg_tys) - where - pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] - n_tvs = length tvs - -{- ---------------------------------------------------------------------- - TyConApp - ~~~~~~~~ --} - --- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to --- its arguments. Applies its arguments to the constructor from left to right. -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon - , [_rep1,_rep2,ty1,ty2] <- tys - = FunTy ty1 ty2 - - | otherwise - = TyConApp tycon tys - --- splitTyConApp "looks through" synonyms, because they don't --- mean a distinct type, but all other type-constructor applications --- including functions are returned as Just .. - --- | Retrieve the tycon heading this type, if there is one. Does /not/ --- look through synonyms. -tyConAppTyConPicky_maybe :: Type -> Maybe TyCon -tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc -tyConAppTyConPicky_maybe (FunTy {}) = Just funTyCon -tyConAppTyConPicky_maybe _ = Nothing - - --- | The same as @fst . splitTyConApp@ -tyConAppTyCon_maybe :: Type -> Maybe TyCon -tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty' -tyConAppTyCon_maybe (TyConApp tc _) = Just tc -tyConAppTyCon_maybe (FunTy {}) = Just funTyCon -tyConAppTyCon_maybe _ = Nothing - -tyConAppTyCon :: Type -> TyCon -tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) - --- | The same as @snd . splitTyConApp@ -tyConAppArgs_maybe :: Type -> Maybe [Type] -tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' -tyConAppArgs_maybe (TyConApp _ tys) = Just tys -tyConAppArgs_maybe (FunTy arg res) - | Just rep1 <- getRuntimeRep_maybe arg - , Just rep2 <- getRuntimeRep_maybe res - = Just [rep1, rep2, arg, res] -tyConAppArgs_maybe _ = Nothing - -tyConAppArgs :: Type -> [Type] -tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) - -tyConAppArgN :: Int -> Type -> Type --- Executing Nth -tyConAppArgN n ty - = case tyConAppArgs_maybe ty of - Just tys -> ASSERT2( n < length tys, ppr n <+> ppr tys ) tys `getNth` n - Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) - --- | Attempts to tease a type apart into a type constructor and the application --- of a number of arguments to that constructor. Panics if that is not possible. --- See also 'splitTyConApp_maybe' -splitTyConApp :: Type -> (TyCon, [Type]) -splitTyConApp ty = case splitTyConApp_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "splitTyConApp" (ppr ty) - --- | Attempts to tease a type apart into a type constructor and the application --- of a number of arguments to that constructor -splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' -splitTyConApp_maybe ty = repSplitTyConApp_maybe ty - --- | Like 'splitTyConApp_maybe', but doesn't look through synonyms. This --- assumes the synonyms have already been dealt with. -repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -repSplitTyConApp_maybe (FunTy arg res) - | Just arg_rep <- getRuntimeRep_maybe arg - , Just res_rep <- getRuntimeRep_maybe res - = Just (funTyCon, [arg_rep, res_rep, arg, res]) -repSplitTyConApp_maybe _ = Nothing - --- | Attempts to tease a list type apart and gives the type of the elements if --- successful (looks through type synonyms) -splitListTyConApp_maybe :: Type -> Maybe Type -splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of - Just (tc,[e]) | tc == listTyCon -> Just e - _other -> Nothing - --- | What is the role assigned to the next parameter of this type? Usually, --- this will be 'Nominal', but if the type is a 'TyConApp', we may be able to --- do better. The type does *not* have to be well-kinded when applied for this --- to work! -nextRole :: Type -> Role -nextRole ty - | Just (tc, tys) <- splitTyConApp_maybe ty - , let num_tys = length tys - , num_tys < tyConArity tc - = tyConRoles tc `getNth` num_tys - - | otherwise - = Nominal - -newTyConInstRhs :: TyCon -> [Type] -> Type --- ^ Unwrap one 'layer' of newtype on a type constructor and its --- arguments, using an eta-reduced version of the @newtype@ if possible. --- This requires tys to have at least @newTyConInstArity tycon@ elements. -newTyConInstRhs tycon tys - = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs ) - applyTysX tvs rhs tys - where - (tvs, rhs) = newTyConEtadRhs tycon - -{- ---------------------------------------------------------------------- - CastTy - ~~~~~~ -A casted type has its *kind* casted into something new. - -Note [No reflexive casts in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As far as possible, we would like to maintain the following property: - - (*) If (t1 `eqType` t2), then t1 and t2 are treated identically within GHC. - -The (*) property is very useful, because we have a tendency to compare two -types to see if they're equal, and then arbitrarily choose one. We don't -want this arbitrary choice to then matter later on. Maintaining (*) means -that every function that looks at a structure of a type must think about -casts. In places where we directly pattern-match, this consideration is -forced by consideration of the CastTy constructor. - -But, when we call a splitXXX function, it's easy to ignore the possibility -of casts. In particular, splitTyConApp is used extensively, and we don't -want it to fail on (T a b c |> co). Happily, if we have - (T a b c |> co) `eqType` (T d e f) -then co must be reflexive. Why? eqType checks that the kinds are equal, as -well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f). -By the kind check, we know that (T a b c |> co) and (T d e f) have the same -kind. So the only way that co could be non-reflexive is for (T a b c) to have -a different kind than (T d e f). But because T's kind is closed (all tycon kinds -are closed), the only way for this to happen is that one of the arguments has -to differ, leading to a contradiction. Thus, co is reflexive. - -Accordingly, by eliminating reflexive casts, splitTyConApp need not worry -about outermost casts to uphold (*). - -Unforunately, that's not the end of the story. Consider comparing - (T a b c) =? (T a b |> (co -> )) (c |> sym co) -These two types have the same kind (Type), but the left type is a TyConApp -while the right type is not. To handle this case, we will have to implement -some variant of the dreaded KPush algorithm (c.f. CoreOpt.pushCoDataCon). -This stone is left unturned for now, meaning that we don't yet uphold (*). - -The other place where (*) will be hard to guarantee is in splitAppTy, because -I (Richard E) can't think of a way to push coercions into AppTys. The good -news here is that splitAppTy is not used all that much, and so all clients of -that function can simply be told to use splitCastTy as well, in order to -uphold (*). This, too, is left undone, for now. - --} - -splitCastTy_maybe :: Type -> Maybe (Type, Coercion) -splitCastTy_maybe ty | Just ty' <- coreView ty = splitCastTy_maybe ty' -splitCastTy_maybe (CastTy ty co) = Just (ty, co) -splitCastTy_maybe _ = Nothing - --- | Make a 'CastTy'. The Coercion must be nominal. Checks the --- Coercion for reflexivity, dropping it if it's reflexive. --- See Note [No reflexive casts in types] -mkCastTy :: Type -> Coercion -> Type -mkCastTy ty co | isReflexiveCo co = ty --- NB: Do the slow check here. This is important to keep the splitXXX --- functions working properly. Otherwise, we may end up with something --- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) --- fails under splitFunTy_maybe. This happened with the cheaper check --- in test dependent/should_compile/dynamic-paper. - -mkCastTy (CastTy ty co1) co2 = mkCastTy ty (co1 `mkTransCo` co2) -mkCastTy ty co = CastTy ty co - -tyConBindersTyBinders :: [TyConBinder] -> [TyBinder] --- Return the tyConBinders in TyBinder form -tyConBindersTyBinders = map to_tyb - where - to_tyb (TvBndr tv (NamedTCB vis)) = Named (TvBndr tv vis) - to_tyb (TvBndr tv AnonTCB) = Anon (tyVarKind tv) - -{- --------------------------------------------------------------------- - CoercionTy - ~~~~~~~~~~ -CoercionTy allows us to inject coercions into types. A CoercionTy -should appear only in the right-hand side of an application. --} - -mkCoercionTy :: Coercion -> Type -mkCoercionTy = CoercionTy - -isCoercionTy :: Type -> Bool -isCoercionTy (CoercionTy _) = True -isCoercionTy _ = False - -isCoercionTy_maybe :: Type -> Maybe Coercion -isCoercionTy_maybe (CoercionTy co) = Just co -isCoercionTy_maybe _ = Nothing - -stripCoercionTy :: Type -> Coercion -stripCoercionTy (CoercionTy co) = co -stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) - -{- ---------------------------------------------------------------------- - SynTy - ~~~~~ - -Notes on type synonyms -~~~~~~~~~~~~~~~~~~~~~~ -The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try -to return type synonyms wherever possible. Thus - - type Foo a = a -> a - -we want - splitFunTys (a -> Foo a) = ([a], Foo a) -not ([a], a -> a) - -The reason is that we then get better (shorter) type signatures in -interfaces. Notably this plays a role in tcTySigs in TcBinds.hs. - - ---------------------------------------------------------------------- - ForAllTy - ~~~~~~~~ --} - --- | Make a dependent forall over an Inferred (as opposed to Specified) --- variable -mkInvForAllTy :: TyVar -> Type -> Type -mkInvForAllTy tv ty = ASSERT( isTyVar tv ) - ForAllTy (TvBndr tv Inferred) ty - --- | Like mkForAllTys, but assumes all variables are dependent and Inferred, --- a common case -mkInvForAllTys :: [TyVar] -> Type -> Type -mkInvForAllTys tvs ty = ASSERT( all isTyVar tvs ) - foldr mkInvForAllTy ty tvs - --- | Like mkForAllTys, but assumes all variables are dependent and specified, --- a common case -mkSpecForAllTys :: [TyVar] -> Type -> Type -mkSpecForAllTys tvs = ASSERT( all isTyVar tvs ) - mkForAllTys [ TvBndr tv Specified | tv <- tvs ] - --- | Like mkForAllTys, but assumes all variables are dependent and visible -mkVisForAllTys :: [TyVar] -> Type -> Type -mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) - mkForAllTys [ TvBndr tv Required | tv <- tvs ] - -mkLamType :: Var -> Type -> Type --- ^ Makes a @(->)@ type or an implicit forall type, depending --- on whether it is given a type variable or a term variable. --- This is used, for example, when producing the type of a lambda. --- Always uses Inferred binders. -mkLamTypes :: [Var] -> Type -> Type --- ^ 'mkLamType' for multiple type or value arguments - -mkLamType v ty - | isTyVar v = ForAllTy (TvBndr v Inferred) ty - | otherwise = FunTy (varType v) ty - -mkLamTypes vs ty = foldr mkLamType ty vs - --- | Given a list of type-level vars and a result type, makes TyBinders, preferring --- anonymous binders if the variable is, in fact, not dependent. --- All binders are /visible/. -mkTyConBindersPreferAnon :: [TyVar] -> Type -> [TyConBinder] -mkTyConBindersPreferAnon vars inner_ty = fst (go vars) - where - go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars - go [] = ([], tyCoVarsOfType inner_ty) - go (v:vs) | v `elemVarSet` fvs - = ( TvBndr v (NamedTCB Required) : binders - , fvs `delVarSet` v `unionVarSet` kind_vars ) - | otherwise - = ( TvBndr v AnonTCB : binders - , fvs `unionVarSet` kind_vars ) - where - (binders, fvs) = go vs - kind_vars = tyCoVarsOfType $ tyVarKind v - --- | Take a ForAllTy apart, returning the list of tyvars and the result type. --- This always succeeds, even if it returns only an empty list. Note that the --- result type returned may have free variables that were bound by a forall. -splitForAllTys :: Type -> ([TyVar], Type) -splitForAllTys ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy (TvBndr tv _) ty) tvs = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) - --- | Like 'splitPiTys' but split off only /named/ binders. -splitForAllTyVarBndrs :: Type -> ([TyVarBinder], Type) -splitForAllTyVarBndrs ty = split ty ty [] - where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b res) bs = split res res (b:bs) - split orig_ty _ bs = (reverse bs, orig_ty) - --- | Checks whether this is a proper forall (with a named binder) -isForAllTy :: Type -> Bool -isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty' -isForAllTy (ForAllTy {}) = True -isForAllTy _ = False - --- | Is this a function or forall? -isPiTy :: Type -> Bool -isPiTy ty | Just ty' <- coreView ty = isForAllTy ty' -isPiTy (ForAllTy {}) = True -isPiTy (FunTy {}) = True -isPiTy _ = False - --- | Take a forall type apart, or panics if that is not possible. -splitForAllTy :: Type -> (TyVar, Type) -splitForAllTy ty - | Just answer <- splitForAllTy_maybe ty = answer - | otherwise = pprPanic "splitForAllTy" (ppr ty) - --- | Drops all ForAllTys -dropForAlls :: Type -> Type -dropForAlls ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy _ res) = go res - go res = res - --- | Attempts to take a forall type apart, but only if it's a proper forall, --- with a named binder -splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) -splitForAllTy_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy (TvBndr tv _) ty) = Just (tv, ty) - go _ = Nothing - --- | Attempts to take a forall type apart; works with proper foralls and --- functions -splitPiTy_maybe :: Type -> Maybe (TyBinder, Type) -splitPiTy_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy bndr ty) = Just (Named bndr, ty) - go (FunTy arg res) = Just (Anon arg, res) - go _ = Nothing - --- | Takes a forall type apart, or panics -splitPiTy :: Type -> (TyBinder, Type) -splitPiTy ty - | Just answer <- splitPiTy_maybe ty = answer - | otherwise = pprPanic "splitPiTy" (ppr ty) - --- | Split off all TyBinders to a type, splitting both proper foralls --- and functions -splitPiTys :: Type -> ([TyBinder], Type) -splitPiTys ty = split ty ty [] - where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b res) bs = split res res (Named b : bs) - split _ (FunTy arg res) bs = split res res (Anon arg : bs) - split orig_ty _ bs = (reverse bs, orig_ty) - --- Like splitPiTys, but returns only *invisible* binders, including constraints --- Stops at the first visible binder -splitPiTysInvisible :: Type -> ([TyBinder], Type) -splitPiTysInvisible ty = split ty ty [] - where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b@(TvBndr _ vis) res) bs - | isInvisibleArgFlag vis = split res res (Named b : bs) - split _ (FunTy arg res) bs - | isPredTy arg = split res res (Anon arg : bs) - split orig_ty _ bs = (reverse bs, orig_ty) - --- | Given a tycon and its arguments, filters out any invisible arguments -filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] -filterOutInvisibleTypes tc tys = snd $ partitionInvisibles tc id tys - --- | Like 'filterOutInvisibles', but works on 'TyVar's -filterOutInvisibleTyVars :: TyCon -> [TyVar] -> [TyVar] -filterOutInvisibleTyVars tc tvs = snd $ partitionInvisibles tc mkTyVarTy tvs - --- | Given a tycon and a list of things (which correspond to arguments), --- partitions the things into --- Inferred or Specified ones and --- Required ones --- The callback function is necessary for this scenario: --- --- > T :: forall k. k -> k --- > partitionInvisibles T [forall m. m -> m -> m, S, R, Q] --- --- After substituting, we get --- --- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n --- --- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, --- and @Q@ is visible. --- --- If you're absolutely sure that your tycon's kind doesn't end in a variable, --- it's OK if the callback function panics, as that's the only time it's --- consulted. -partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) -partitionInvisibles tc get_ty = go emptyTCvSubst (tyConKind tc) - where - go _ _ [] = ([], []) - go subst (ForAllTy (TvBndr tv vis) res_ki) (x:xs) - | isVisibleArgFlag vis = second (x :) (go subst' res_ki xs) - | otherwise = first (x :) (go subst' res_ki xs) - where - subst' = extendTvSubst subst tv (get_ty x) - go subst (TyVarTy tv) xs - | Just ki <- lookupTyVar subst tv = go subst ki xs - go _ _ xs = ([], xs) -- something is ill-kinded. But this can happen - -- when printing errors. Assume everything is visible. - --- @isTauTy@ tests if a type has no foralls -isTauTy :: Type -> Bool -isTauTy ty | Just ty' <- coreView ty = isTauTy ty' -isTauTy (TyVarTy _) = True -isTauTy (LitTy {}) = True -isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (ForAllTy {}) = False -isTauTy (CastTy ty _) = isTauTy ty -isTauTy (CoercionTy _) = False -- Not sure about this - -{- -%************************************************************************ -%* * - TyBinders -%* * -%************************************************************************ --} - --- | Make a named binder -mkTyVarBinder :: ArgFlag -> Var -> TyVarBinder -mkTyVarBinder vis var = TvBndr var vis - --- | Make many named binders -mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder] -mkTyVarBinders vis = map (mkTyVarBinder vis) - --- | Make an anonymous binder -mkAnonBinder :: Type -> TyBinder -mkAnonBinder = Anon - --- | Does this binder bind a variable that is /not/ erased? Returns --- 'True' for anonymous binders. -isAnonTyBinder :: TyBinder -> Bool -isAnonTyBinder (Named {}) = False -isAnonTyBinder (Anon {}) = True - -isNamedTyBinder :: TyBinder -> Bool -isNamedTyBinder (Named {}) = True -isNamedTyBinder (Anon {}) = False - -tyBinderType :: TyBinder -> Type --- Barely used -tyBinderType (Named tvb) = binderKind tvb -tyBinderType (Anon ty) = ty - --- | Extract a relevant type, if there is one. -binderRelevantType_maybe :: TyBinder -> Maybe Type -binderRelevantType_maybe (Named {}) = Nothing -binderRelevantType_maybe (Anon ty) = Just ty - --- | Like 'maybe', but for binders. -caseBinder :: TyBinder -- ^ binder to scrutinize - -> (TyVarBinder -> a) -- ^ named case - -> (Type -> a) -- ^ anonymous case - -> a -caseBinder (Named v) f _ = f v -caseBinder (Anon t) _ d = d t - --- | Manufacture a new 'TyConBinder' from a 'TyBinder'. Anonymous --- 'TyBinder's are still assigned names as 'TyConBinder's, so we need --- the extra gunk with which to construct a 'Name'. Used when producing --- tyConTyVars from a datatype kind signature. Defined here to avoid module --- loops. -mkTyBinderTyConBinder :: TyBinder -> SrcSpan -> Unique -> OccName -> TyConBinder -mkTyBinderTyConBinder (Named (TvBndr tv argf)) _ _ _ = TvBndr tv (NamedTCB argf) -mkTyBinderTyConBinder (Anon kind) loc uniq occ - = TvBndr (mkTyVar (mkInternalName uniq occ loc) kind) AnonTCB - -{- -%************************************************************************ -%* * - Pred -* * -************************************************************************ - -Predicates on PredType - -Note [isPredTy complications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You would think that we could define - isPredTy ty = isConstraintKind (typeKind ty) -But there are a number of complications: - -* isPredTy is used when printing types, which can happen in debug - printing during type checking of not-fully-zonked types. So it's - not cool to say isConstraintKind (typeKind ty) because, absent - zonking, the type might be ill-kinded, and typeKind crashes. Hence the - rather tiresome story here - -* isPredTy must return "True" to *unlifted* coercions, such as (t1 ~# t2) - and (t1 ~R# t2), which are not of kind Constraint! Currently they are - of kind #. - -* If we do form the type '(C a => C [a]) => blah', then we'd like to - print it as such. But that means that isPredTy must return True for - (C a => C [a]). Admittedly that type is illegal in Haskell, but we - want to print it nicely in error messages. --} - --- | Is the type suitable to classify a given/wanted in the typechecker? -isPredTy :: Type -> Bool --- See Note [isPredTy complications] -isPredTy ty = go ty [] - where - go :: Type -> [KindOrType] -> Bool - go (AppTy ty1 ty2) args = go ty1 (ty2 : args) - go (TyVarTy tv) args = go_k (tyVarKind tv) args - go (TyConApp tc tys) args = ASSERT( null args ) -- TyConApp invariant - go_tc tc tys - go (FunTy arg res) [] - | isPredTy arg = isPredTy res -- (Eq a => C a) - | otherwise = False -- (Int -> Bool) - go (ForAllTy _ ty) [] = go ty [] - go (CastTy _ co) args = go_k (pSnd (coercionKind co)) args - go _ _ = False - - go_tc :: TyCon -> [KindOrType] -> Bool - go_tc tc args - | tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey - = length args == 4 -- ~# and ~R# sadly have result kind # - -- not Constraint; but we still want - -- isPredTy to reply True. - | otherwise = go_k (tyConKind tc) args - - go_k :: Kind -> [KindOrType] -> Bool - -- True <=> ('k' applied to 'kts') = Constraint - go_k k [] = isConstraintKind k - go_k k (arg:args) = case piResultTy_maybe k arg of - Just k' -> go_k k' args - Nothing -> WARN( True, text "isPredTy" <+> ppr ty ) - False - -- This last case shouldn't happen under most circumstances. It can - -- occur if we call isPredTy during kind checking, especially if one - -- of the following happens: - -- - -- 1. There is actually a kind error. Example in which this showed up: - -- polykinds/T11399 - -- 2. A type constructor application appears to be oversaturated. An - -- example of this occurred in GHC Trac #13187: - -- - -- {-# LANGUAGE PolyKinds #-} - -- type Const a b = b - -- f :: Const Int (,) Bool Char -> Char - -- - -- This code is actually fine, since Const is polymorphic in its - -- return kind. It does show that isPredTy could possibly report a - -- false negative if a constraint is similarly oversaturated, but - -- it's hard to do better than isPredTy currently does without - -- zonking, so we punt on such cases for now. - -isClassPred, isEqPred, isNomEqPred, isIPPred :: PredType -> Bool -isClassPred ty = case tyConAppTyCon_maybe ty of - Just tyCon | isClassTyCon tyCon -> True - _ -> False -isEqPred ty = case tyConAppTyCon_maybe ty of - Just tyCon -> tyCon `hasKey` eqPrimTyConKey - || tyCon `hasKey` eqReprPrimTyConKey - _ -> False - -isNomEqPred ty = case tyConAppTyCon_maybe ty of - Just tyCon -> tyCon `hasKey` eqPrimTyConKey - _ -> False - -isIPPred ty = case tyConAppTyCon_maybe ty of - Just tc -> isIPTyCon tc - _ -> False - -isIPTyCon :: TyCon -> Bool -isIPTyCon tc = tc `hasKey` ipClassKey - -- Class and its corresponding TyCon have the same Unique - -isIPClass :: Class -> Bool -isIPClass cls = cls `hasKey` ipClassKey - -isCTupleClass :: Class -> Bool -isCTupleClass cls = isTupleTyCon (classTyCon cls) - -isIPPred_maybe :: Type -> Maybe (FastString, Type) -isIPPred_maybe ty = - do (tc,[t1,t2]) <- splitTyConApp_maybe ty - guard (isIPTyCon tc) - x <- isStrLitTy t1 - return (x,t2) - -{- -Make PredTypes - ---------------------- Equality types --------------------------------- --} - --- | Makes a lifted equality predicate at the given role -mkPrimEqPredRole :: Role -> Type -> Type -> PredType -mkPrimEqPredRole Nominal = mkPrimEqPred -mkPrimEqPredRole Representational = mkReprPrimEqPred -mkPrimEqPredRole Phantom = panic "mkPrimEqPredRole phantom" - --- | Creates a primitive type equality predicate. --- Invariant: the types are not Coercions -mkPrimEqPred :: Type -> Type -> Type -mkPrimEqPred ty1 ty2 - = TyConApp eqPrimTyCon [k1, k2, ty1, ty2] - where - k1 = typeKind ty1 - k2 = typeKind ty2 - --- | Creates a primite type equality predicate with explicit kinds -mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type -mkHeteroPrimEqPred k1 k2 ty1 ty2 = TyConApp eqPrimTyCon [k1, k2, ty1, ty2] - --- | Creates a primitive representational type equality predicate --- with explicit kinds -mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type -mkHeteroReprPrimEqPred k1 k2 ty1 ty2 - = TyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] - --- | Try to split up a coercion type into the types that it coerces -splitCoercionType_maybe :: Type -> Maybe (Type, Type) -splitCoercionType_maybe ty - = do { (tc, [_, _, ty1, ty2]) <- splitTyConApp_maybe ty - ; guard $ tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey - ; return (ty1, ty2) } - -mkReprPrimEqPred :: Type -> Type -> Type -mkReprPrimEqPred ty1 ty2 - = TyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] - where - k1 = typeKind ty1 - k2 = typeKind ty2 - -equalityTyCon :: Role -> TyCon -equalityTyCon Nominal = eqPrimTyCon -equalityTyCon Representational = eqReprPrimTyCon -equalityTyCon Phantom = eqPhantPrimTyCon - --- --------------------- Dictionary types --------------------------------- - -mkClassPred :: Class -> [Type] -> PredType -mkClassPred clas tys = TyConApp (classTyCon clas) tys - -isDictTy :: Type -> Bool -isDictTy = isClassPred - -isDictLikeTy :: Type -> Bool --- Note [Dictionary-like types] -isDictLikeTy ty | Just ty' <- coreView ty = isDictLikeTy ty' -isDictLikeTy ty = case splitTyConApp_maybe ty of - Just (tc, tys) | isClassTyCon tc -> True - | isTupleTyCon tc -> all isDictLikeTy tys - _other -> False - -{- -Note [Dictionary-like types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Being "dictionary-like" means either a dictionary type or a tuple thereof. -In GHC 6.10 we build implication constraints which construct such tuples, -and if we land up with a binding - t :: (C [a], Eq [a]) - t = blah -then we want to treat t as cheap under "-fdicts-cheap" for example. -(Implication constraints are normally inlined, but sadly not if the -occurrence is itself inside an INLINE function! Until we revise the -handling of implication constraints, that is.) This turned out to -be important in getting good arities in DPH code. Example: - - class C a - class D a where { foo :: a -> a } - instance C a => D (Maybe a) where { foo x = x } - - bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) - {-# INLINE bar #-} - bar x y = (foo (Just x), foo (Just y)) - -Then 'bar' should jolly well have arity 4 (two dicts, two args), but -we ended up with something like - bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... - in \x,y. ) - -This is all a bit ad-hoc; eg it relies on knowing that implication -constraints build tuples. - - -Decomposing PredType --} - --- | A choice of equality relation. This is separate from the type 'Role' --- because 'Phantom' does not define a (non-trivial) equality relation. -data EqRel = NomEq | ReprEq - deriving (Eq, Ord) - -instance Outputable EqRel where - ppr NomEq = text "nominal equality" - ppr ReprEq = text "representational equality" - -eqRelRole :: EqRel -> Role -eqRelRole NomEq = Nominal -eqRelRole ReprEq = Representational - -data PredTree = ClassPred Class [Type] - | EqPred EqRel Type Type - | IrredPred PredType - -classifyPredType :: PredType -> PredTree -classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of - Just (tc, [_, _, ty1, ty2]) - | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2 - | tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2 - Just (tc, tys) - | Just clas <- tyConClass_maybe tc -> ClassPred clas tys - _ -> IrredPred ev_ty - -getClassPredTys :: PredType -> (Class, [Type]) -getClassPredTys ty = case getClassPredTys_maybe ty of - Just (clas, tys) -> (clas, tys) - Nothing -> pprPanic "getClassPredTys" (ppr ty) - -getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) -getClassPredTys_maybe ty = case splitTyConApp_maybe ty of - Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys) - _ -> Nothing - -getEqPredTys :: PredType -> (Type, Type) -getEqPredTys ty - = case splitTyConApp_maybe ty of - Just (tc, [_, _, ty1, ty2]) - | tc `hasKey` eqPrimTyConKey - || tc `hasKey` eqReprPrimTyConKey - -> (ty1, ty2) - _ -> pprPanic "getEqPredTys" (ppr ty) - -getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type) -getEqPredTys_maybe ty - = case splitTyConApp_maybe ty of - Just (tc, [_, _, ty1, ty2]) - | tc `hasKey` eqPrimTyConKey -> Just (Nominal, ty1, ty2) - | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2) - _ -> Nothing - -getEqPredRole :: PredType -> Role -getEqPredRole ty = eqRelRole (predTypeEqRel ty) - --- | Get the equality relation relevant for a pred type. -predTypeEqRel :: PredType -> EqRel -predTypeEqRel ty - | Just (tc, _) <- splitTyConApp_maybe ty - , tc `hasKey` eqReprPrimTyConKey - = ReprEq - | otherwise - = NomEq - -{- -%************************************************************************ -%* * - Well-scoped tyvars -* * -************************************************************************ --} - --- | Do a topological sort on a list of tyvars, --- so that binders occur before occurrences --- E.g. given [ a::k, k::*, b::k ] --- it'll return a well-scoped list [ k::*, a::k, b::k ] --- --- This is a deterministic sorting operation --- (that is, doesn't depend on Uniques). -toposortTyVars :: [TyVar] -> [TyVar] -toposortTyVars tvs = reverse $ - [ tv | (tv, _, _) <- topologicalSortG $ - graphFromEdgedVerticesOrd nodes ] - where - var_ids :: VarEnv Int - var_ids = mkVarEnv (zip tvs [1..]) - - nodes = [ ( tv - , lookupVarEnv_NF var_ids tv - , mapMaybe (lookupVarEnv var_ids) - (tyCoVarsOfTypeList (tyVarKind tv)) ) - | tv <- tvs ] - --- | Extract a well-scoped list of variables from a deterministic set of --- variables. The result is deterministic. --- NB: There used to exist varSetElemsWellScoped :: VarSet -> [Var] which --- took a non-deterministic set and produced a non-deterministic --- well-scoped list. If you care about the list being well-scoped you also --- most likely care about it being in deterministic order. -dVarSetElemsWellScoped :: DVarSet -> [Var] -dVarSetElemsWellScoped = toposortTyVars . dVarSetElems - --- | Get the free vars of a type in scoped order -tyCoVarsOfTypeWellScoped :: Type -> [TyVar] -tyCoVarsOfTypeWellScoped = toposortTyVars . tyCoVarsOfTypeList - --- | Get the free vars of types in scoped order -tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] -tyCoVarsOfTypesWellScoped = toposortTyVars . tyCoVarsOfTypesList - -{- -************************************************************************ -* * -\subsection{Type families} -* * -************************************************************************ --} - -mkFamilyTyConApp :: TyCon -> [Type] -> Type --- ^ Given a family instance TyCon and its arg types, return the --- corresponding family type. E.g: --- --- > data family T a --- > data instance T (Maybe b) = MkT b --- --- Where the instance tycon is :RTL, so: --- --- > mkFamilyTyConApp :RTL Int = T (Maybe Int) -mkFamilyTyConApp tc tys - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let tvs = tyConTyVars tc - fam_subst = ASSERT2( length tvs == length tys, ppr tc <+> ppr tys ) - zipTvSubst tvs tys - = mkTyConApp fam_tc (substTys fam_subst fam_tys) - | otherwise - = mkTyConApp tc tys - --- | Get the type on the LHS of a coercion induced by a type/data --- family instance. -coAxNthLHS :: CoAxiom br -> Int -> Type -coAxNthLHS ax ind = - mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) - --- | Pretty prints a 'TyCon', using the family instance in case of a --- representation tycon. For example: --- --- > data T [a] = ... --- --- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' -pprSourceTyCon :: TyCon -> SDoc -pprSourceTyCon tycon - | Just (fam_tc, tys) <- tyConFamInst_maybe tycon - = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon - | otherwise - = ppr tycon - --- @isTauTy@ tests if a type has no foralls -isFamFreeTy :: Type -> Bool -isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' -isFamFreeTy (TyVarTy _) = True -isFamFreeTy (LitTy {}) = True -isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc -isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b -isFamFreeTy (FunTy a b) = isFamFreeTy a && isFamFreeTy b -isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty -isFamFreeTy (CastTy ty _) = isFamFreeTy ty -isFamFreeTy (CoercionTy _) = False -- Not sure about this - -{- -************************************************************************ -* * -\subsection{Liftedness} -* * -************************************************************************ --} - --- | Returns Just True if this type is surely lifted, Just False --- if it is surely unlifted, Nothing if we can't be sure (i.e., it is --- levity polymorphic), and panics if the kind does not have the shape --- TYPE r. -isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool -isLiftedType_maybe ty = go (getRuntimeRep ty) - where - go rr | Just rr' <- coreView rr = go rr' - go (TyConApp lifted_rep []) - | lifted_rep `hasKey` liftedRepDataConKey = Just True - go (TyConApp {}) = Just False -- everything else is unlifted - go _ = Nothing -- levity polymorphic - --- | See "Type#type_classification" for what an unlifted type is. --- Panics on levity polymorphic types. -isUnliftedType :: HasDebugCallStack => Type -> Bool - -- isUnliftedType returns True for forall'd unlifted types: - -- x :: forall a. Int# - -- I found bindings like these were getting floated to the top level. - -- They are pretty bogus types, mind you. It would be better never to - -- construct them -isUnliftedType ty - = not (isLiftedType_maybe ty `orElse` - pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))) - --- | Extract the RuntimeRep classifier of a type. For instance, --- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not --- possible. -getRuntimeRep_maybe :: HasDebugCallStack - => Type -> Maybe Type -getRuntimeRep_maybe = getRuntimeRepFromKind_maybe . typeKind - --- | Extract the RuntimeRep classifier of a type. For instance, --- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. -getRuntimeRep :: HasDebugCallStack => Type -> Type -getRuntimeRep ty - = case getRuntimeRep_maybe ty of - Just r -> r - Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) - --- | Extract the RuntimeRep classifier of a type from its kind. For example, --- @getRuntimeRepFromKind * = LiftedRep@; Panics if this is not possible. -getRuntimeRepFromKind :: HasDebugCallStack - => Type -> Type -getRuntimeRepFromKind k = - case getRuntimeRepFromKind_maybe k of - Just r -> r - Nothing -> pprPanic "getRuntimeRepFromKind" - (ppr k <+> dcolon <+> ppr (typeKind k)) - --- | Extract the RuntimeRep classifier of a type from its kind. For example, --- @getRuntimeRepFromKind * = LiftedRep@; Returns 'Nothing' if this is not --- possible. -getRuntimeRepFromKind_maybe :: HasDebugCallStack - => Type -> Maybe Type -getRuntimeRepFromKind_maybe = go - where - go k | Just k' <- coreView k = go k' - go k - | Just (_tc, [arg]) <- splitTyConApp_maybe k - = ASSERT2( _tc `hasKey` tYPETyConKey, ppr k ) - Just arg - go _ = Nothing - -isUnboxedTupleType :: Type -> Bool -isUnboxedTupleType ty - = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey - -- NB: Do not use typePrimRep, as that can't tell the difference between - -- unboxed tuples and unboxed sums - - -isUnboxedSumType :: Type -> Bool -isUnboxedSumType ty - = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey - --- | See "Type#type_classification" for what an algebraic type is. --- Should only be applied to /types/, as opposed to e.g. partially --- saturated type constructors -isAlgType :: Type -> Bool -isAlgType ty - = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) - isAlgTyCon tc - _other -> False - --- | See "Type#type_classification" for what an algebraic type is. --- Should only be applied to /types/, as opposed to e.g. partially --- saturated type constructors. Closed type constructors are those --- with a fixed right hand side, as opposed to e.g. associated types -isClosedAlgType :: Type -> Bool -isClosedAlgType ty - = case splitTyConApp_maybe ty of - Just (tc, ty_args) | isAlgTyCon tc && not (isFamilyTyCon tc) - -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True - _other -> False - --- | Check whether a type is a data family type -isDataFamilyAppType :: Type -> Bool -isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of - Just tc -> isDataFamilyTyCon tc - _ -> False - --- | Computes whether an argument (or let right hand side) should --- be computed strictly or lazily, based only on its type. --- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types. -isStrictType :: HasDebugCallStack => Type -> Bool -isStrictType = isUnliftedType - -isPrimitiveType :: Type -> Bool --- ^ Returns true of types that are opaque to Haskell. -isPrimitiveType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) - isPrimTyCon tc - _ -> False - -{- -************************************************************************ -* * -\subsection{Join points} -* * -************************************************************************ --} - --- | Determine whether a type could be the type of a join point of given total --- arity, according to the polymorphism rule. A join point cannot be polymorphic --- in its return type, since given --- join j @a @b x y z = e1 in e2, --- the types of e1 and e2 must be the same, and a and b are not in scope for e2. --- (See Note [The polymorphism rule of join points] in CoreSyn.) Returns False --- also if the type simply doesn't have enough arguments. --- --- Note that we need to know how many arguments (type *and* value) the putative --- join point takes; for instance, if --- j :: forall a. a -> Int --- then j could be a binary join point returning an Int, but it could *not* be a --- unary join point returning a -> Int. --- --- TODO: See Note [Excess polymorphism and join points] -isValidJoinPointType :: JoinArity -> Type -> Bool -isValidJoinPointType arity ty - = valid_under emptyVarSet arity ty - where - valid_under tvs arity ty - | arity == 0 - = isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty) - | Just (t, ty') <- splitForAllTy_maybe ty - = valid_under (tvs `extendVarSet` t) (arity-1) ty' - | Just (_, res_ty) <- splitFunTy_maybe ty - = valid_under tvs (arity-1) res_ty - | otherwise - = False - -{- -************************************************************************ -* * -\subsection{Sequencing on types} -* * -************************************************************************ --} - -seqType :: Type -> () -seqType (LitTy n) = n `seq` () -seqType (TyVarTy tv) = tv `seq` () -seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (TyConApp tc tys) = tc `seq` seqTypes tys -seqType (ForAllTy (TvBndr tv _) ty) = seqType (tyVarKind tv) `seq` seqType ty -seqType (CastTy ty co) = seqType ty `seq` seqCo co -seqType (CoercionTy co) = seqCo co - -seqTypes :: [Type] -> () -seqTypes [] = () -seqTypes (ty:tys) = seqType ty `seq` seqTypes tys - -{- -************************************************************************ -* * - Comparison for types - (We don't use instances so that we know where it happens) -* * -************************************************************************ - -Note [Equality on AppTys] -~~~~~~~~~~~~~~~~~~~~~~~~~ -In our cast-ignoring equality, we want to say that the following two -are equal: - - (Maybe |> co) (Int |> co') ~? Maybe Int - -But the left is an AppTy while the right is a TyConApp. The solution is -to use repSplitAppTy_maybe to break up the TyConApp into its pieces and -then continue. Easy to do, but also easy to forget to do. - --} - -eqType :: Type -> Type -> Bool --- ^ Type equality on source types. Does not look through @newtypes@ or --- 'PredType's, but it does look through type synonyms. --- This first checks that the kinds of the types are equal and then --- checks whether the types are equal, ignoring casts and coercions. --- (The kind check is a recursive call, but since all kinds have type --- @Type@, there is no need to check the types of kinds.) --- See also Note [Non-trivial definitional equality] in TyCoRep. -eqType t1 t2 = isEqual $ nonDetCmpType t1 t2 - -- It's OK to use nonDetCmpType here and eqType is deterministic, - -- nonDetCmpType does equality deterministically - --- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. -eqTypeX :: RnEnv2 -> Type -> Type -> Bool -eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2 - -- It's OK to use nonDetCmpType here and eqTypeX is deterministic, - -- nonDetCmpTypeX does equality deterministically - --- | Type equality on lists of types, looking through type synonyms --- but not newtypes. -eqTypes :: [Type] -> [Type] -> Bool -eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2 - -- It's OK to use nonDetCmpType here and eqTypes is deterministic, - -- nonDetCmpTypes does equality deterministically - -eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 --- Check that the var lists are the same length --- and have matching kinds; if so, extend the RnEnv2 --- Returns Nothing if they don't match -eqVarBndrs env [] [] - = Just env -eqVarBndrs env (tv1:tvs1) (tv2:tvs2) - | eqTypeX env (tyVarKind tv1) (tyVarKind tv2) - = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 -eqVarBndrs _ _ _= Nothing - --- Now here comes the real worker - -{- -Note [nonDetCmpType nondeterminism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX -uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for -ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, -comparing type variables is nondeterministic, note the call to nonDetCmpVar in -nonDetCmpTypeX. -See Note [Unique Determinism] for more details. --} - -nonDetCmpType :: Type -> Type -> Ordering -nonDetCmpType t1 t2 - -- we know k1 and k2 have the same kind, because they both have kind *. - = nonDetCmpTypeX rn_env t1 t2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) - -nonDetCmpTypes :: [Type] -> [Type] -> Ordering -nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) - --- | An ordering relation between two 'Type's (known below as @t1 :: k1@ --- and @t2 :: k2@) -data TypeOrdering = TLT -- ^ @t1 < t2@ - | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, - -- therefore we can conclude @k1 ~ k2@ - | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so - -- they may differ in kind. - | TGT -- ^ @t1 > t2@ - deriving (Eq, Ord, Enum, Bounded) - -nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse - -- See Note [Non-trivial definitional equality] in TyCoRep -nonDetCmpTypeX env orig_t1 orig_t2 = - case go env orig_t1 orig_t2 of - -- If there are casts then we also need to do a comparison of the kinds of - -- the types being compared - TEQX -> toOrdering $ go env k1 k2 - ty_ordering -> toOrdering ty_ordering - where - k1 = typeKind orig_t1 - k2 = typeKind orig_t2 - - toOrdering :: TypeOrdering -> Ordering - toOrdering TLT = LT - toOrdering TEQ = EQ - toOrdering TEQX = EQ - toOrdering TGT = GT - - liftOrdering :: Ordering -> TypeOrdering - liftOrdering LT = TLT - liftOrdering EQ = TEQ - liftOrdering GT = TGT - - thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering - thenCmpTy TEQ rel = rel - thenCmpTy TEQX rel = hasCast rel - thenCmpTy rel _ = rel - - hasCast :: TypeOrdering -> TypeOrdering - hasCast TEQ = TEQX - hasCast rel = rel - - -- Returns both the resulting ordering relation between the two types - -- and whether either contains a cast. - go :: RnEnv2 -> Type -> Type -> TypeOrdering - go env t1 t2 - | Just t1' <- coreView t1 = go env t1' t2 - | Just t2' <- coreView t2 = go env t1 t2' - - go env (TyVarTy tv1) (TyVarTy tv2) - = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 - go env (ForAllTy (TvBndr tv1 _) t1) (ForAllTy (TvBndr tv2 _) t2) - = go env (tyVarKind tv1) (tyVarKind tv2) - `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 - -- See Note [Equality on AppTys] - go env (AppTy s1 t1) ty2 - | Just (s2, t2) <- repSplitAppTy_maybe ty2 - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env ty1 (AppTy s2 t2) - | Just (s1, t1) <- repSplitAppTy_maybe ty1 - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env (FunTy s1 t1) (FunTy s2 t2) - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) - = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 - go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2) - go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 - go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 - - go _ (CoercionTy {}) (CoercionTy {}) = TEQ - - -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy - go _ ty1 ty2 - = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) - where get_rank :: Type -> Int - get_rank (CastTy {}) - = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) - get_rank (TyVarTy {}) = 0 - get_rank (CoercionTy {}) = 1 - get_rank (AppTy {}) = 3 - get_rank (LitTy {}) = 4 - get_rank (TyConApp {}) = 5 - get_rank (FunTy {}) = 6 - get_rank (ForAllTy {}) = 7 - - gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering - gos _ [] [] = TEQ - gos _ [] _ = TLT - gos _ _ [] = TGT - gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 - -------------- -nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering -nonDetCmpTypesX _ [] [] = EQ -nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 - `thenCmp` nonDetCmpTypesX env tys1 tys2 -nonDetCmpTypesX _ [] _ = LT -nonDetCmpTypesX _ _ [] = GT - -------------- --- | Compare two 'TyCon's. NB: This should /never/ see the "star synonyms", --- as recognized by Kind.isStarKindSynonymTyCon. See Note --- [Kind Constraint and kind *] in Kind. --- See Note [nonDetCmpType nondeterminism] -nonDetCmpTc :: TyCon -> TyCon -> Ordering -nonDetCmpTc tc1 tc2 - = ASSERT( not (isStarKindSynonymTyCon tc1) && not (isStarKindSynonymTyCon tc2) ) - u1 `nonDetCmpUnique` u2 - where - u1 = tyConUnique tc1 - u2 = tyConUnique tc2 - -{- -************************************************************************ -* * - The kind of a type -* * -************************************************************************ --} - -typeKind :: Type -> Kind -typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys -typeKind (AppTy fun arg) = piResultTy (typeKind fun) arg -typeKind (LitTy l) = typeLiteralKind l -typeKind (FunTy {}) = liftedTypeKind -typeKind (ForAllTy _ ty) = typeKind ty -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (CastTy _ty co) = pSnd $ coercionKind co -typeKind (CoercionTy co) = coercionType co - -typeLiteralKind :: TyLit -> Kind -typeLiteralKind l = - case l of - NumTyLit _ -> typeNatKind - StrTyLit _ -> typeSymbolKind - --- | Returns True if a type is levity polymorphic. Should be the same --- as (isKindLevPoly . typeKind) but much faster. --- Precondition: The type has kind (TYPE blah) -isTypeLevPoly :: Type -> Bool -isTypeLevPoly = go - where - go ty@(TyVarTy {}) = check_kind ty - go ty@(AppTy {}) = check_kind ty - go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False - | otherwise = check_kind ty - go (ForAllTy _ ty) = go ty - go (FunTy {}) = False - go (LitTy {}) = False - go ty@(CastTy {}) = check_kind ty - go ty@(CoercionTy {}) = pprPanic "isTypeLevPoly co" (ppr ty) - - check_kind = isKindLevPoly . typeKind - --- | Looking past all pi-types, is the end result potentially levity polymorphic? --- Example: True for (forall r (a :: TYPE r). String -> a) --- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type) -resultIsLevPoly :: Type -> Bool -resultIsLevPoly = isTypeLevPoly . snd . splitPiTys - -{- -%************************************************************************ -%* * - Miscellaneous functions -%* * -%************************************************************************ - --} --- | All type constructors occurring in the type; looking through type --- synonyms, but not newtypes. --- When it finds a Class, it returns the class TyCon. -tyConsOfType :: Type -> UniqSet TyCon -tyConsOfType ty - = go ty - where - go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim - go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy {}) = emptyUniqSet - go (LitTy {}) = emptyUniqSet - go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys - go (AppTy a b) = go a `unionUniqSets` go b - go (FunTy a b) = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon - go (ForAllTy (TvBndr tv _) ty) = go ty `unionUniqSets` go (tyVarKind tv) - go (CastTy ty co) = go ty `unionUniqSets` go_co co - go (CoercionTy co) = go_co co - - go_co (Refl _ ty) = go ty - go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args - go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg - go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co - go_co (FunCo _ co1 co2) = go_co co1 `unionUniqSets` go_co co2 - go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args - go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 - go_co (CoVarCo {}) = emptyUniqSet - go_co (SymCo co) = go_co co - go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 - go_co (NthCo _ co) = go_co co - go_co (LRCo _ co) = go_co co - go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg - go_co (CoherenceCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 - go_co (KindCo co) = go_co co - go_co (SubCo co) = go_co co - go_co (AxiomRuleCo _ cs) = go_cos cs - - go_prov UnsafeCoerceProv = emptyUniqSet - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyUniqSet - go_prov (HoleProv _) = emptyUniqSet - -- this last case can happen from the tyConsOfType used from - -- checkTauTvUpdate - - go_s tys = foldr (unionUniqSets . go) emptyUniqSet tys - go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos - - go_tc tc = unitUniqSet tc - go_ax ax = go_tc $ coAxiomTyCon ax - --- | Find the result 'Kind' of a type synonym, --- after applying it to its 'arity' number of type variables --- Actually this function works fine on data types too, --- but they'd always return '*', so we never need to ask -synTyConResKind :: TyCon -> Kind -synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon)) - --- | Retrieve the free variables in this type, splitting them based --- on whether they are used visibly or invisibly. Invisible ones come --- first. -splitVisVarsOfType :: Type -> Pair TyCoVarSet -splitVisVarsOfType orig_ty = Pair invis_vars vis_vars - where - Pair invis_vars1 vis_vars = go orig_ty - invis_vars = invis_vars1 `minusVarSet` vis_vars - - go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) - go (AppTy t1 t2) = go t1 `mappend` go t2 - go (TyConApp tc tys) = go_tc tc tys - go (FunTy t1 t2) = go t1 `mappend` go t2 - go (ForAllTy (TvBndr tv _) ty) - = ((`delVarSet` tv) <$> go ty) `mappend` - (invisible (tyCoVarsOfType $ tyVarKind tv)) - go (LitTy {}) = mempty - go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) - go (CoercionTy co) = invisible $ tyCoVarsOfCo co - - invisible vs = Pair vs emptyVarSet - - go_tc tc tys = let (invis, vis) = partitionInvisibles tc id tys in - invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis - -splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet -splitVisVarsOfTypes = foldMap splitVisVarsOfType - -modifyJoinResTy :: Int -- Number of binders to skip - -> (Type -> Type) -- Function to apply to result type - -> Type -- Type of join point - -> Type -- New type --- INVARIANT: If any of the first n binders are foralls, those tyvars cannot --- appear in the original result type. See isValidJoinPointType. -modifyJoinResTy orig_ar f orig_ty - = go orig_ar orig_ty - where - go 0 ty = f ty - go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty - = mkPiTy arg_bndr (go (n-1) res_ty) - | otherwise - = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty) - -setJoinResTy :: Int -- Number of binders to skip - -> Type -- New result type - -> Type -- Type of join point - -> Type -- New type --- INVARIANT: Same as for modifyJoinResTy -setJoinResTy ar new_res_ty ty - = modifyJoinResTy ar (const new_res_ty) ty diff --git a/types/Type.hs-boot b/types/Type.hs-boot deleted file mode 100644 --- a/types/Type.hs-boot +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Type where -import TyCon -import Var ( TyVar ) -import {-# SOURCE #-} TyCoRep( Type, Coercion, Kind ) -import Util - -isPredTy :: Type -> Bool -isCoercionTy :: Type -> Bool - -mkAppTy :: Type -> Type -> Type -mkCastTy :: Type -> Coercion -> Type -piResultTy :: Type -> Type -> Type - -typeKind :: Type -> Kind -eqType :: Type -> Type -> Bool - -partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) - -coreView :: Type -> Maybe Type -tcView :: Type -> Maybe Type - -tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] -tyCoVarsOfTypeWellScoped :: Type -> [TyVar] -splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) diff --git a/types/Unify.hs b/types/Unify.hs deleted file mode 100644 --- a/types/Unify.hs +++ /dev/null @@ -1,1344 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -module Unify ( - tcMatchTy, tcMatchTyKi, - tcMatchTys, tcMatchTyKis, - tcMatchTyX, tcMatchTysX, tcMatchTyKisX, - ruleMatchTyKiX, - - -- * Rough matching - roughMatchTcs, instanceCantMatch, - typesCantMatch, - - -- Side-effect free unification - tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, - tcUnifyTysFG, tcUnifyTyWithTFs, - BindFlag(..), - UnifyResult, UnifyResultM(..), - - -- Matching a type against a lifted type (coercion) - liftCoMatch - ) where - -#include "HsVersions.h" - -import Var -import VarEnv -import VarSet -import Kind -import Name( Name ) -import Type hiding ( getTvSubstEnv ) -import Coercion hiding ( getCvSubstEnv ) -import TyCon -import TyCoRep hiding ( getTvSubstEnv, getCvSubstEnv ) -import Util -import Pair -import Outputable -import UniqFM -import UniqSet - -import Control.Monad -#if __GLASGOW_HASKELL__ > 710 -import qualified Control.Monad.Fail as MonadFail -#endif -import Control.Applicative hiding ( empty ) -import qualified Control.Applicative - -{- - -Unification is much tricker than you might think. - -1. The substitution we generate binds the *template type variables* - which are given to us explicitly. - -2. We want to match in the presence of foralls; - e.g (forall a. t1) ~ (forall b. t2) - - That is what the RnEnv2 is for; it does the alpha-renaming - that makes it as if a and b were the same variable. - Initialising the RnEnv2, so that it can generate a fresh - binder when necessary, entails knowing the free variables of - both types. - -3. We must be careful not to bind a template type variable to a - locally bound variable. E.g. - (forall a. x) ~ (forall b. b) - where x is the template type variable. Then we do not want to - bind x to a/b! This is a kind of occurs check. - The necessary locals accumulate in the RnEnv2. --} - --- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) --- @s@ such that @s(t1)@ equals @t2@. --- The returned substitution might bind coercion variables, --- if the variable is an argument to a GADT constructor. --- --- Precondition: typeKind ty1 `eqType` typeKind ty2 --- --- We don't pass in a set of "template variables" to be bound --- by the match, because tcMatchTy (and similar functions) are --- always used on top-level types, so we can bind any of the --- free variables of the LHS. -tcMatchTy :: Type -> Type -> Maybe TCvSubst -tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] - --- | Like 'tcMatchTy', but allows the kinds of the types to differ, --- and thus matches them as well. -tcMatchTyKi :: Type -> Type -> Maybe TCvSubst -tcMatchTyKi ty1 ty2 = tcMatchTyKis [ty1] [ty2] - --- | This is similar to 'tcMatchTy', but extends a substitution -tcMatchTyX :: TCvSubst -- ^ Substitution to extend - -> Type -- ^ Template - -> Type -- ^ Target - -> Maybe TCvSubst -tcMatchTyX subst ty1 ty2 = tcMatchTysX subst [ty1] [ty2] - --- | Like 'tcMatchTy' but over a list of types. -tcMatchTys :: [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot; in principle the template - -- variables could be free in the target -tcMatchTys tys1 tys2 - = tcMatchTysX (mkEmptyTCvSubst in_scope) tys1 tys2 - where - in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) - --- | Like 'tcMatchTyKi' but over a list of types. -tcMatchTyKis :: [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution -tcMatchTyKis tys1 tys2 - = tcMatchTyKisX (mkEmptyTCvSubst in_scope) tys1 tys2 - where - in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) - --- | Like 'tcMatchTys', but extending a substitution -tcMatchTysX :: TCvSubst -- ^ Substitution to extend - -> [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution -tcMatchTysX subst tys1 tys2 - = tc_match_tys_x False subst tys1 tys2 - --- | Like 'tcMatchTyKis', but extending a substitution -tcMatchTyKisX :: TCvSubst -- ^ Substitution to extend - -> [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution -tcMatchTyKisX subst tys1 tys2 - = tc_match_tys_x True subst tys1 tys2 - --- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' -tc_match_tys_x :: Bool -- ^ match kinds? - -> TCvSubst - -> [Type] - -> [Type] - -> Maybe TCvSubst -tc_match_tys_x match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 - = case tc_unify_tys (const BindMe) - False -- Matching, not unifying - False -- Not an injectivity check - match_kis - (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of - Unifiable (tv_env', cv_env') - -> Just $ TCvSubst in_scope tv_env' cv_env' - _ -> Nothing - --- | This one is called from the expression matcher, --- which already has a MatchEnv in hand -ruleMatchTyKiX - :: TyCoVarSet -- ^ template variables - -> RnEnv2 - -> TvSubstEnv -- ^ type substitution to extend - -> Type -- ^ Template - -> Type -- ^ Target - -> Maybe TvSubstEnv -ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target --- See Note [Kind coercions in Unify] - = case tc_unify_tys (matchBindFun tmpl_tvs) False False - True -- <-- this means to match the kinds - rn_env tenv emptyCvSubstEnv [tmpl] [target] of - Unifiable (tenv', _) -> Just tenv' - _ -> Nothing - -matchBindFun :: TyCoVarSet -> TyVar -> BindFlag -matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem - - -{- ********************************************************************* -* * - Rough matching -* * -********************************************************************* -} - --- See Note [Rough match] field in InstEnv - -roughMatchTcs :: [Type] -> [Maybe Name] -roughMatchTcs tys = map rough tys - where - rough ty - | Just (ty', _) <- splitCastTy_maybe ty = rough ty' - | Just (tc,_) <- splitTyConApp_maybe ty = Just (tyConName tc) - | otherwise = Nothing - -instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool --- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot --- possibly be instantiated to actual, nor vice versa; --- False is non-committal -instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as -instanceCantMatch _ _ = False -- Safe - -itemCantMatch :: Maybe Name -> Maybe Name -> Bool -itemCantMatch (Just t) (Just a) = t /= a -itemCantMatch _ _ = False - - -{- -************************************************************************ -* * - GADTs -* * -************************************************************************ - -Note [Pruning dead case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider data T a where - T1 :: T Int - T2 :: T a - - newtype X = MkX Int - newtype Y = MkY Char - - type family F a - type instance F Bool = Int - -Now consider case x of { T1 -> e1; T2 -> e2 } - -The question before the house is this: if I know something about the type -of x, can I prune away the T1 alternative? - -Suppose x::T Char. It's impossible to construct a (T Char) using T1, - Answer = YES we can prune the T1 branch (clearly) - -Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated -to 'Bool', in which case x::T Int, so - ANSWER = NO (clearly) - -We see here that we want precisely the apartness check implemented within -tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely -apart. Note that since we are simply dropping dead code, a conservative test -suffices. --} - --- | Given a list of pairs of types, are any two members of a pair surely --- apart, even after arbitrary type function evaluation and substitution? -typesCantMatch :: [(Type,Type)] -> Bool --- See Note [Pruning dead case alternatives] -typesCantMatch prs = any (uncurry cant_match) prs - where - cant_match :: Type -> Type -> Bool - cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of - SurelyApart -> True - _ -> False - -{- -************************************************************************ -* * - Unification -* * -************************************************************************ - -Note [Fine-grained unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- -no substitution to finite types makes these match. But, a substitution to -*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ]. -Why do we care? Consider these two type family instances: - -type instance F x x = Int -type instance F [y] y = Bool - -If we also have - -type instance Looper = [Looper] - -then the instances potentially overlap. The solution is to use unification -over infinite terms. This is possible (see [1] for lots of gory details), but -a full algorithm is a little more power than we need. Instead, we make a -conservative approximation and just omit the occurs check. - -[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf - -tcUnifyTys considers an occurs-check problem as the same as general unification -failure. - -tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check -failure ("MaybeApart"), or general failure ("SurelyApart"). - -See also Trac #8162. - -It's worth noting that unification in the presence of infinite types is not -complete. This means that, sometimes, a closed type family does not reduce -when it should. See test case indexed-types/should_fail/Overlap15 for an -example. - -Note [The substitution in MaybeApart] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? -Because consider unifying these: - -(a, a, Int) ~ (b, [b], Bool) - -If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we -apply the subst we have so far and discover that we need [b |-> [b]]. Because -this fails the occurs check, we say that the types are MaybeApart (see above -Note [Fine-grained unification]). But, we can't stop there! Because if we -continue, we discover that Int is SurelyApart from Bool, and therefore the -types are apart. This has practical consequences for the ability for closed -type family applications to reduce. See test case -indexed-types/should_compile/Overlap14. - -Note [Unifying with skolems] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we discover that two types unify if and only if a skolem variable is -substituted, we can't properly unify the types. But, that skolem variable -may later be instantiated with a unifyable type. So, we return maybeApart -in these cases. - -Note [Lists of different lengths are MaybeApart] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is unusual to call tcUnifyTys or tcUnifyTysFG with lists of different -lengths. The place where we know this can happen is from compatibleBranches in -FamInstEnv, when checking data family instances. Data family instances may be -eta-reduced; see Note [Eta reduction for data family axioms] in TcInstDcls. - -We wish to say that - - D :: * -> * -> * - axDF1 :: D Int ~ DFInst1 - axDF2 :: D Int Bool ~ DFInst2 - -overlap. If we conclude that lists of different lengths are SurelyApart, then -it will look like these do *not* overlap, causing disaster. See Trac #9371. - -In usages of tcUnifyTys outside of family instances, we always use tcUnifyTys, -which can't tell the difference between MaybeApart and SurelyApart, so those -usages won't notice this design choice. --} - --- | Simple unification of two types; all type variables are bindable --- Precondition: the kinds are already equal -tcUnifyTy :: Type -> Type -- All tyvars are bindable - -> Maybe TCvSubst - -- A regular one-shot (idempotent) substitution -tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2] - --- | Like 'tcUnifyTy', but also unifies the kinds -tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst -tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2] - --- | Unify two types, treating type family applications as possibly unifying --- with anything and looking through injective type family applications. --- Precondition: kinds are the same -tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; - -- False <=> do one-way matching. - -- See end of sec 5.2 from the paper - -> Type -> Type -> Maybe TCvSubst --- This algorithm is an implementation of the "Algorithm U" presented in --- the paper "Injective type families for Haskell", Figures 2 and 3. --- The code is incorporated with the standard unifier for convenience, but --- its operation should match the specification in the paper. -tcUnifyTyWithTFs twoWay t1 t2 - = case tc_unify_tys (const BindMe) twoWay True False - rn_env emptyTvSubstEnv emptyCvSubstEnv - [t1] [t2] of - Unifiable (subst, _) -> Just $ niFixTCvSubst subst - MaybeApart (subst, _) -> Just $ niFixTCvSubst subst - -- we want to *succeed* in questionable cases. This is a - -- pre-unification algorithm. - SurelyApart -> Nothing - where - rn_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [t1, t2] - ------------------ -tcUnifyTys :: (TyCoVar -> BindFlag) - -> [Type] -> [Type] - -> Maybe TCvSubst - -- ^ A regular one-shot (idempotent) substitution - -- that unifies the erased types. See comments - -- for 'tcUnifyTysFG' - --- The two types may have common type variables, and indeed do so in the --- second call to tcUnifyTys in FunDeps.checkClsFD -tcUnifyTys bind_fn tys1 tys2 - = case tcUnifyTysFG bind_fn tys1 tys2 of - Unifiable result -> Just result - _ -> Nothing - --- | Like 'tcUnifyTys' but also unifies the kinds -tcUnifyTyKis :: (TyCoVar -> BindFlag) - -> [Type] -> [Type] - -> Maybe TCvSubst -tcUnifyTyKis bind_fn tys1 tys2 - = case tcUnifyTyKisFG bind_fn tys1 tys2 of - Unifiable result -> Just result - _ -> Nothing - --- This type does double-duty. It is used in the UM (unifier monad) and to --- return the final result. See Note [Fine-grained unification] -type UnifyResult = UnifyResultM TCvSubst -data UnifyResultM a = Unifiable a -- the subst that unifies the types - | MaybeApart a -- the subst has as much as we know - -- it must be part of an most general unifier - -- See Note [The substitution in MaybeApart] - | SurelyApart - deriving Functor - -instance Applicative UnifyResultM where - pure = Unifiable - (<*>) = ap - -instance Monad UnifyResultM where - - SurelyApart >>= _ = SurelyApart - MaybeApart x >>= f = case f x of - Unifiable y -> MaybeApart y - other -> other - Unifiable x >>= f = f x - -instance Alternative UnifyResultM where - empty = SurelyApart - - a@(Unifiable {}) <|> _ = a - _ <|> b@(Unifiable {}) = b - a@(MaybeApart {}) <|> _ = a - _ <|> b@(MaybeApart {}) = b - SurelyApart <|> SurelyApart = SurelyApart - -instance MonadPlus UnifyResultM - --- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose --- domain elements all respond 'BindMe' to @bind_tv@) such that --- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned --- Coercions. This version requires that the kinds of the types are the same, --- if you unify left-to-right. -tcUnifyTysFG :: (TyVar -> BindFlag) - -> [Type] -> [Type] - -> UnifyResult -tcUnifyTysFG bind_fn tys1 tys2 - = tc_unify_tys_fg False bind_fn tys1 tys2 - -tcUnifyTyKisFG :: (TyVar -> BindFlag) - -> [Type] -> [Type] - -> UnifyResult -tcUnifyTyKisFG bind_fn tys1 tys2 - = tc_unify_tys_fg True bind_fn tys1 tys2 - -tc_unify_tys_fg :: Bool - -> (TyVar -> BindFlag) - -> [Type] -> [Type] - -> UnifyResult -tc_unify_tys_fg match_kis bind_fn tys1 tys2 - = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env - emptyTvSubstEnv emptyCvSubstEnv - tys1 tys2 - ; return $ niFixTCvSubst env } - where - vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 - env = mkRnEnv2 $ mkInScopeSet vars - --- | This function is actually the one to call the unifier -- a little --- too general for outside clients, though. -tc_unify_tys :: (TyVar -> BindFlag) - -> AmIUnifying -- ^ True <=> unify; False <=> match - -> Bool -- ^ True <=> doing an injectivity check - -> Bool -- ^ True <=> treat the kinds as well - -> RnEnv2 - -> TvSubstEnv -- ^ substitution to extend - -> CvSubstEnv - -> [Type] -> [Type] - -> UnifyResultM (TvSubstEnv, CvSubstEnv) -tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2 - = initUM tv_env cv_env $ - do { when match_kis $ - unify_tys env kis1 kis2 - ; unify_tys env tys1 tys2 - ; (,) <$> getTvSubstEnv <*> getCvSubstEnv } - where - env = UMEnv { um_bind_fun = bind_fn - , um_unif = unif - , um_inj_tf = inj_check - , um_rn_env = rn_env } - - kis1 = map typeKind tys1 - kis2 = map typeKind tys2 - -instance Outputable a => Outputable (UnifyResultM a) where - ppr SurelyApart = text "SurelyApart" - ppr (Unifiable x) = text "Unifiable" <+> ppr x - ppr (MaybeApart x) = text "MaybeApart" <+> ppr x - -{- -************************************************************************ -* * - Non-idempotent substitution -* * -************************************************************************ - -Note [Non-idempotent substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During unification we use a TvSubstEnv/CvSubstEnv pair that is - (a) non-idempotent - (b) loop-free; ie repeatedly applying it yields a fixed point - -Note [Finding the substitution fixpoint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Finding the fixpoint of a non-idempotent substitution arising from a -unification is harder than it looks, because of kinds. Consider - T k (H k (f:k)) ~ T * (g:*) -If we unify, we get the substitution - [ k -> * - , g -> H k (f:k) ] -To make it idempotent we don't want to get just - [ k -> * - , g -> H * (f:k) ] -We also want to substitute inside f's kind, to get - [ k -> * - , g -> H k (f:*) ] -If we don't do this, we may apply the substitution to something, -and get an ill-formed type, i.e. one where typeKind will fail. -This happened, for example, in Trac #9106. - -This is the reason for extending env with [f:k -> f:*], in the -definition of env' in niFixTvSubst --} - -niFixTCvSubst :: TvSubstEnv -> TCvSubst --- Find the idempotent fixed point of the non-idempotent substitution --- See Note [Finding the substitution fixpoint] --- ToDo: use laziness instead of iteration? -niFixTCvSubst tenv = f tenv - where - f tenv - | not_fixpoint = f (mapVarEnv (substTy subst') tenv) - | otherwise = subst - where - not_fixpoint = anyVarSet in_domain range_tvs - in_domain tv = tv `elemVarEnv` tenv - - range_tvs = nonDetFoldUFM (unionVarSet . tyCoVarsOfType) emptyVarSet tenv - -- It's OK to use nonDetFoldUFM here because we - -- forget the order immediately by creating a set - subst = mkTvSubst (mkInScopeSet range_tvs) tenv - - -- env' extends env by replacing any free type with - -- that same tyvar with a substituted kind - -- See note [Finding the substitution fixpoint] - tenv' = extendVarEnvList tenv [ (rtv, mkTyVarTy $ - setTyVarKind rtv $ - substTy subst $ - tyVarKind rtv) - | rtv <- nonDetEltsUniqSet range_tvs - -- It's OK to use nonDetEltsUniqSet here - -- because we forget the order - -- immediatedly by putting it in VarEnv - , not (in_domain rtv) ] - subst' = mkTvSubst (mkInScopeSet range_tvs) tenv' - -niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet --- Apply the non-idempotent substitution to a set of type variables, --- remembering that the substitution isn't necessarily idempotent --- This is used in the occurs check, before extending the substitution -niSubstTvSet tsubst tvs - = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs - -- It's OK to nonDetFoldUFM here because we immediately forget the - -- ordering by creating a set. - where - get tv - | Just ty <- lookupVarEnv tsubst tv - = niSubstTvSet tsubst (tyCoVarsOfType ty) - - | otherwise - = unitVarSet tv - -{- -************************************************************************ -* * - unify_ty: the main workhorse -* * -************************************************************************ - -Note [Specification of unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The pure unifier, unify_ty, defined in this module, tries to work out -a substitution to make two types say True to eqType. NB: eqType is -itself not purely syntactic; it accounts for CastTys; -see Note [Non-trivial definitional equality] in TyCoRep - -Unlike the "impure unifiers" in the typechecker (the eager unifier in -TcUnify, and the constraint solver itself in TcCanonical), the pure -unifier It does /not/ work up to ~. - -The algorithm implemented here is rather delicate, and we depend on it -to uphold certain properties. This is a summary of these required -properties. Any reference to "flattening" refers to the flattening -algorithm in FamInstEnv (See Note [Flattening] in FamInstEnv), not -the flattening algorithm in the solver. - -Notation: - θ,φ substitutions - ξ type-function-free types - τ,σ other types - τ♭ type τ, flattened - - ≡ eqType - -(U1) Soundness. - If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). - θ is a most general unifier for τ₁ and τ₂. - -(U2) Completeness. - If (unify ξ₁ ξ₂) = SurelyApart, - then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). - -These two properties are stated as Property 11 in the "Closed Type Families" -paper (POPL'14). Below, this paper is called [CTF]. - -(U3) Apartness under substitution. - If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, - for any θ. (Property 12 from [CTF]) - -(U4) Apart types do not unify. - If (unify ξ τ♭) = SurelyApart, then there exists no θ - such that θ(ξ) = θ(τ). (Property 13 from [CTF]) - -THEOREM. Completeness w.r.t ~ - If (unify τ₁♭ τ₂♭) = SurelyApart, - then there exists no proof that (τ₁ ~ τ₂). - -PROOF. See appendix of [CTF]. - - -The unification algorithm is used for type family injectivity, as described -in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run -in this mode, it has the following properties. - -(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even - after arbitrary type family reductions. Note that σ and τ are - not flattened here. - -(I2) If (unify σ τ) = MaybeApart θ, and if some - φ exists such that φ(σ) ~ φ(τ), then φ extends θ. - - -Furthermore, the RULES matching algorithm requires this property, -but only when using this algorithm for matching: - -(M1) If (match σ τ) succeeds with θ, then all matchable tyvars - in σ are bound in θ. - - Property M1 means that we must extend the substitution with, - say (a ↦ a) when appropriate during matching. - See also Note [Self-substitution when matching]. - -(M2) Completeness of matching. - If θ(σ) = τ, then (match σ τ) = Unifiable φ, - where θ is an extension of φ. - -Sadly, property M2 and I2 conflict. Consider - -type family F1 a b where - F1 Int Bool = Char - F1 Double String = Char - -Consider now two matching problems: - -P1. match (F1 a Bool) (F1 Int Bool) -P2. match (F1 a Bool) (F1 Double String) - -In case P1, we must find (a ↦ Int) to satisfy M2. -In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note -that the correct mapping for I2 is (a ↦ Int). There is no way to discover -this, but we musn't map a to anything else!) - -We thus must parameterize the algorithm over whether it's being used -for an injectivity check (refrain from looking at non-injective arguments -to type families) or not (do indeed look at those arguments). This is -implemented by the uf_inj_tf field of UmEnv. - -(It's all a question of whether or not to include equation (7) from Fig. 2 -of [ITF].) - -This extra parameter is a bit fiddly, perhaps, but seemingly less so than -having two separate, almost-identical algorithms. - -Note [Self-substitution when matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should happen when we're *matching* (not unifying) a1 with a1? We -should get a substitution [a1 |-> a1]. A successful match should map all -the template variables (except ones that disappear when expanding synonyms). -But when unifying, we don't want to do this, because we'll then fall into -a loop. - -This arrangement affects the code in three places: - - If we're matching a refined template variable, don't recur. Instead, just - check for equality. That is, if we know [a |-> Maybe a] and are matching - (a ~? Maybe Int), we want to just fail. - - - Skip the occurs check when matching. This comes up in two places, because - matching against variables is handled separately from matching against - full-on types. - -Note that this arrangement was provoked by a real failure, where the same -unique ended up in the template as in the target. (It was a rule firing when -compiling Data.List.NonEmpty.) - -Note [Matching coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - type family F a - - data G a where - MkG :: F a ~ Bool => G a - - type family Foo (x :: G a) :: F a - type instance Foo MkG = False - -We would like that to be accepted. For that to work, we need to introduce -a coercion variable on the left an then use it on the right. Accordingly, -at use sites of Foo, we need to be able to use matching to figure out the -value for the coercion. (See the desugared version: - - axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) - -) We never want this action to happen during *unification* though, when -all bets are off. - -Note [Kind coercions in Unify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We wish to match/unify while ignoring casts. But, we can't just ignore -them completely, or we'll end up with ill-kinded substitutions. For example, -say we're matching `a` with `ty |> co`. If we just drop the cast, we'll -return [a |-> ty], but `a` and `ty` might have different kinds. We can't -just match/unify their kinds, either, because this might gratuitously -fail. After all, `co` is the witness that the kinds are the same -- they -may look nothing alike. - -So, we pass a kind coercion to the match/unify worker. This coercion witnesses -the equality between the substed kind of the left-hand type and the substed -kind of the right-hand type. Note that we do not unify kinds at the leaves -(as we did previously). We thus have - -INVARIANT: In the call - unify_ty ty1 ty2 kco -it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where -`subst` is the ambient substitution in the UM monad. - -To get this coercion, we first have to match/unify -the kinds before looking at the types. Happily, we need look only one level -up, as all kinds are guaranteed to have kind *. - -When we're working with type applications (either TyConApp or AppTy) we -need to worry about establishing INVARIANT, as the kinds of the function -& arguments aren't (necessarily) included in the kind of the result. -When unifying two TyConApps, this is easy, because the two TyCons are -the same. Their kinds are thus the same. As long as we unify left-to-right, -we'll be sure to unify types' kinds before the types themselves. (For example, -think about Proxy :: forall k. k -> *. Unifying the first args matches up -the kinds of the second args.) - -For AppTy, we must unify the kinds of the functions, but once these are -unified, we can continue unifying arguments without worrying further about -kinds. - -The interface to this module includes both "...Ty" functions and -"...TyKi" functions. The former assume that INVARIANT is already -established, either because the kinds are the same or because the -list of types being passed in are the well-typed arguments to some -type constructor (see two paragraphs above). The latter take a separate -pre-pass over the kinds to establish INVARIANT. Sometimes, it's important -not to take the second pass, as it caused #12442. - -We thought, at one point, that this was all unnecessary: why should -casts be in types in the first place? But they are sometimes. In -dependent/should_compile/KindEqualities2, we see, for example the -constraint Num (Int |> (blah ; sym blah)). We naturally want to find -a dictionary for that constraint, which requires dealing with -coercions in this manner. --} - --------------- unify_ty: the main workhorse ----------- - -type AmIUnifying = Bool -- True <=> Unifying - -- False <=> Matching - -unify_ty :: UMEnv - -> Type -> Type -- Types to be unified and a co - -> Coercion -- A coercion between their kinds - -- See Note [Kind coercions in Unify] - -> UM () --- See Note [Specification of unification] --- Respects newtypes, PredTypes - -unify_ty env ty1 ty2 kco - -- TODO: More commentary needed here - | Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco - | Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco - | CastTy ty1' co <- ty1 = unify_ty env ty1' ty2 (co `mkTransCo` kco) - | CastTy ty2' co <- ty2 = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co) - -unify_ty env (TyVarTy tv1) ty2 kco - = uVar env tv1 ty2 kco -unify_ty env ty1 (TyVarTy tv2) kco - | um_unif env -- If unifying, can swap args - = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) - -unify_ty env ty1 ty2 _kco - | Just (tc1, tys1) <- mb_tc_app1 - , Just (tc2, tys2) <- mb_tc_app2 - , tc1 == tc2 || (tcIsStarKind ty1 && tcIsStarKind ty2) - = if isInjectiveTyCon tc1 Nominal - then unify_tys env tys1 tys2 - else do { let inj | isTypeFamilyTyCon tc1 - = case familyTyConInjectivityInfo tc1 of - NotInjective -> repeat False - Injective bs -> bs - | otherwise - = repeat False - - (inj_tys1, noninj_tys1) = partitionByList inj tys1 - (inj_tys2, noninj_tys2) = partitionByList inj tys2 - - ; unify_tys env inj_tys1 inj_tys2 - ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] - don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 } - - | Just (tc1, _) <- mb_tc_app1 - , not (isGenerativeTyCon tc1 Nominal) - -- E.g. unify_ty (F ty1) b = MaybeApart - -- because the (F ty1) behaves like a variable - -- NB: if unifying, we have already dealt - -- with the 'ty2 = variable' case - = maybeApart - - | Just (tc2, _) <- mb_tc_app2 - , not (isGenerativeTyCon tc2 Nominal) - , um_unif env - -- E.g. unify_ty [a] (F ty2) = MaybeApart, when unifying (only) - -- because the (F ty2) behaves like a variable - -- NB: we have already dealt with the 'ty1 = variable' case - = maybeApart - - where - mb_tc_app1 = tcSplitTyConApp_maybe ty1 - mb_tc_app2 = tcSplitTyConApp_maybe ty2 - - -- Applications need a bit of care! - -- They can match FunTy and TyConApp, so use splitAppTy_maybe - -- NB: we've already dealt with type variables, - -- so if one type is an App the other one jolly well better be too -unify_ty env (AppTy ty1a ty1b) ty2 _kco - | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 - = unify_ty_app env ty1a [ty1b] ty2a [ty2b] - -unify_ty env ty1 (AppTy ty2a ty2b) _kco - | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 - = unify_ty_app env ty1a [ty1b] ty2a [ty2b] - -unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () - -unify_ty env (ForAllTy (TvBndr tv1 _) ty1) (ForAllTy (TvBndr tv2 _) ty2) kco - = do { unify_ty env (tyVarKind tv1) (tyVarKind tv2) (mkNomReflCo liftedTypeKind) - ; let env' = umRnBndr2 env tv1 tv2 - ; unify_ty env' ty1 ty2 kco } - --- See Note [Matching coercion variables] -unify_ty env (CoercionTy co1) (CoercionTy co2) kco - = do { c_subst <- getCvSubstEnv - ; case co1 of - CoVarCo cv - | not (um_unif env) - , not (cv `elemVarEnv` c_subst) - , BindMe <- tvBindFlagL env cv - -> do { checkRnEnvRCo env co2 - ; let (co_l, co_r) = decomposeFunCo kco - -- cv :: t1 ~ t2 - -- co2 :: s1 ~ s2 - -- co_l :: t1 ~ s1 - -- co_r :: t2 ~ s2 - ; extendCvEnv cv (co_l `mkTransCo` - co2 `mkTransCo` - mkSymCo co_r) } - _ -> return () } - -unify_ty _ _ _ _ = surelyApart - -unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () -unify_ty_app env ty1 ty1args ty2 ty2args - | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 - , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2 - = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) - - | otherwise - = do { let ki1 = typeKind ty1 - ki2 = typeKind ty2 - -- See Note [Kind coercions in Unify] - ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind) - ; unify_ty env ty1 ty2 (mkNomReflCo ki1) - ; unify_tys env ty1args ty2args } - -unify_tys :: UMEnv -> [Type] -> [Type] -> UM () -unify_tys env orig_xs orig_ys - = go orig_xs orig_ys - where - go [] [] = return () - go (x:xs) (y:ys) - -- See Note [Kind coercions in Unify] - = do { unify_ty env x y (mkNomReflCo $ typeKind x) - ; go xs ys } - go _ _ = maybeApart -- See Note [Lists of different lengths are MaybeApart] - ---------------------------------- -uVar :: UMEnv - -> TyVar -- Variable to be unified - -> Type -- with this Type - -> Coercion -- :: kind tv ~N kind ty - -> UM () - -uVar env tv1 ty kco - = do { -- Check to see whether tv1 is refined by the substitution - subst <- getTvSubstEnv - ; case (lookupVarEnv subst tv1) of - Just ty' | um_unif env -- Unifying, so - -> unify_ty env ty' ty kco -- call back into unify - | otherwise - -> -- Matching, we don't want to just recur here. - -- this is because the range of the subst is the target - -- type, not the template type. So, just check for - -- normal type equality. - guard ((ty' `mkCastTy` kco) `eqType` ty) - Nothing -> uUnrefined env tv1 ty ty kco } -- No, continue - -uUnrefined :: UMEnv - -> TyVar -- variable to be unified - -> Type -- with this Type - -> Type -- (version w/ expanded synonyms) - -> Coercion -- :: kind tv ~N kind ty - -> UM () - --- We know that tv1 isn't refined - -uUnrefined env tv1 ty2 ty2' kco - | Just ty2'' <- coreView ty2' - = uUnrefined env tv1 ty2 ty2'' kco -- Unwrap synonyms - -- This is essential, in case we have - -- type Foo a = a - -- and then unify a ~ Foo a - - | TyVarTy tv2 <- ty2' - = do { let tv1' = umRnOccL env tv1 - tv2' = umRnOccR env tv2 - -- See Note [Self-substitution when matching] - ; when (tv1' /= tv2' || not (um_unif env)) $ do - { subst <- getTvSubstEnv - -- Check to see whether tv2 is refined - ; case lookupVarEnv subst tv2 of - { Just ty' | um_unif env -> uUnrefined env tv1 ty' ty' kco - ; _ -> do - { -- So both are unrefined - - -- And then bind one or the other, - -- depending on which is bindable - ; let b1 = tvBindFlagL env tv1 - b2 = tvBindFlagR env tv2 - ty1 = mkTyVarTy tv1 - ; case (b1, b2) of - (BindMe, _) -> do { checkRnEnvR env ty2 -- make sure ty2 is not a local - ; extendTvEnv tv1 (ty2 `mkCastTy` mkSymCo kco) } - (_, BindMe) | um_unif env - -> do { checkRnEnvL env ty1 -- ditto for ty1 - ; extendTvEnv tv2 (ty1 `mkCastTy` kco) } - - _ | tv1' == tv2' -> return () - -- How could this happen? If we're only matching and if - -- we're comparing forall-bound variables. - - _ -> maybeApart -- See Note [Unification with skolems] - }}}} - -uUnrefined env tv1 ty2 ty2' kco -- ty2 is not a type variable - = do { occurs <- elemNiSubstSet tv1 (tyCoVarsOfType ty2') - ; if um_unif env && occurs -- See Note [Self-substitution when matching] - then maybeApart -- Occurs check, see Note [Fine-grained unification] - else do bindTv env tv1 (ty2 `mkCastTy` mkSymCo kco) } - -- Bind tyvar to the synonym if poss - -elemNiSubstSet :: TyVar -> TyCoVarSet -> UM Bool -elemNiSubstSet v set - = do { tsubst <- getTvSubstEnv - ; return $ v `elemVarSet` niSubstTvSet tsubst set } - -bindTv :: UMEnv -> TyVar -> Type -> UM () -bindTv env tv ty -- ty is not a variable - = do { checkRnEnvR env ty -- make sure ty mentions no local variables - ; case tvBindFlagL env tv of - Skolem -> maybeApart -- See Note [Unification with skolems] - BindMe -> extendTvEnv tv ty - } - -{- -%************************************************************************ -%* * - Binding decisions -* * -************************************************************************ --} - -data BindFlag - = BindMe -- A regular type variable - - | Skolem -- This type variable is a skolem constant - -- Don't bind it; it only matches itself - deriving Eq - -{- -************************************************************************ -* * - Unification monad -* * -************************************************************************ --} - -data UMEnv = UMEnv { um_bind_fun :: TyVar -> BindFlag - -- User-supplied BindFlag function - , um_unif :: AmIUnifying - , um_inj_tf :: Bool -- Checking for injectivity? - -- See (end of) Note [Specification of unification] - , um_rn_env :: RnEnv2 } - -data UMState = UMState - { um_tv_env :: TvSubstEnv - , um_cv_env :: CvSubstEnv } - -newtype UM a = UM { unUM :: UMState -> UnifyResultM (UMState, a) } - -instance Functor UM where - fmap = liftM - -instance Applicative UM where - pure a = UM (\s -> pure (s, a)) - (<*>) = ap - -instance Monad UM where - fail _ = UM (\_ -> SurelyApart) -- failed pattern match - m >>= k = UM (\state -> - do { (state', v) <- unUM m state - ; unUM (k v) state' }) - --- need this instance because of a use of 'guard' above -instance Alternative UM where - empty = UM (\_ -> Control.Applicative.empty) - m1 <|> m2 = UM (\state -> - unUM m1 state <|> - unUM m2 state) - -instance MonadPlus UM - -#if __GLASGOW_HASKELL__ > 710 -instance MonadFail.MonadFail UM where - fail _ = UM (\_ -> SurelyApart) -- failed pattern match -#endif - -initUM :: TvSubstEnv -- subst to extend - -> CvSubstEnv - -> UM a -> UnifyResultM a -initUM subst_env cv_subst_env um - = case unUM um state of - Unifiable (_, subst) -> Unifiable subst - MaybeApart (_, subst) -> MaybeApart subst - SurelyApart -> SurelyApart - where - state = UMState { um_tv_env = subst_env - , um_cv_env = cv_subst_env } - -tvBindFlagL :: UMEnv -> TyVar -> BindFlag -tvBindFlagL env tv - | inRnEnvL (um_rn_env env) tv = Skolem - | otherwise = um_bind_fun env tv - -tvBindFlagR :: UMEnv -> TyVar -> BindFlag -tvBindFlagR env tv - | inRnEnvR (um_rn_env env) tv = Skolem - | otherwise = um_bind_fun env tv - -getTvSubstEnv :: UM TvSubstEnv -getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) - -getCvSubstEnv :: UM CvSubstEnv -getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) - -extendTvEnv :: TyVar -> Type -> UM () -extendTvEnv tv ty = UM $ \state -> - Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) - -extendCvEnv :: CoVar -> Coercion -> UM () -extendCvEnv cv co = UM $ \state -> - Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) - -umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv -umRnBndr2 env v1 v2 - = env { um_rn_env = rnBndr2 (um_rn_env env) v1 v2 } - -checkRnEnv :: (RnEnv2 -> VarEnv Var) -> UMEnv -> VarSet -> UM () -checkRnEnv get_set env varset = UM $ \ state -> - let env_vars = get_set (um_rn_env env) in - if isEmptyVarEnv env_vars || (getUniqSet varset `disjointVarEnv` env_vars) - -- NB: That isEmptyVarSet is a critical optimization; it - -- means we don't have to calculate the free vars of - -- the type, often saving quite a bit of allocation. - then Unifiable (state, ()) - else MaybeApart (state, ()) - --- | Converts any SurelyApart to a MaybeApart -don'tBeSoSure :: UM () -> UM () -don'tBeSoSure um = UM $ \ state -> - case unUM um state of - SurelyApart -> MaybeApart (state, ()) - other -> other - -checkRnEnvR :: UMEnv -> Type -> UM () -checkRnEnvR env ty = checkRnEnv rnEnvR env (tyCoVarsOfType ty) - -checkRnEnvL :: UMEnv -> Type -> UM () -checkRnEnvL env ty = checkRnEnv rnEnvL env (tyCoVarsOfType ty) - -checkRnEnvRCo :: UMEnv -> Coercion -> UM () -checkRnEnvRCo env co = checkRnEnv rnEnvR env (tyCoVarsOfCo co) - -umRnOccL :: UMEnv -> TyVar -> TyVar -umRnOccL env v = rnOccL (um_rn_env env) v - -umRnOccR :: UMEnv -> TyVar -> TyVar -umRnOccR env v = rnOccR (um_rn_env env) v - -umSwapRn :: UMEnv -> UMEnv -umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } - -maybeApart :: UM () -maybeApart = UM (\state -> MaybeApart (state, ())) - -surelyApart :: UM a -surelyApart = UM (\_ -> SurelyApart) - -{- -%************************************************************************ -%* * - Matching a (lifted) type against a coercion -%* * -%************************************************************************ - -This section defines essentially an inverse to liftCoSubst. It is defined -here to avoid a dependency from Coercion on this module. - --} - -data MatchEnv = ME { me_tmpls :: TyVarSet - , me_env :: RnEnv2 } - --- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if --- @liftCoMatch vars ty co == Just s@, then @listCoSubst s ty == co@, --- where @==@ there means that the result of 'liftCoSubst' has the same --- type as the original co; but may be different under the hood. --- That is, it matches a type against a coercion of the same --- "shape", and returns a lifting substitution which could have been --- used to produce the given coercion from the given type. --- Note that this function is incomplete -- it might return Nothing --- when there does indeed exist a possible lifting context. --- --- This function is incomplete in that it doesn't respect the equality --- in `eqType`. That is, it's possible that this will succeed for t1 and --- fail for t2, even when t1 `eqType` t2. That's because it depends on --- there being a very similar structure between the type and the coercion. --- This incompleteness shouldn't be all that surprising, especially because --- it depends on the structure of the coercion, which is a silly thing to do. --- --- The lifting context produced doesn't have to be exacting in the roles --- of the mappings. This is because any use of the lifting context will --- also require a desired role. Thus, this algorithm prefers mapping to --- nominal coercions where it can do so. -liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext -liftCoMatch tmpls ty co - = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co - ; cenv2 <- ty_co_match menv cenv1 ty co - (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) - ; return (LC (mkEmptyTCvSubst in_scope) cenv2) } - where - menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } - in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) - -- Like tcMatchTy, assume all the interesting variables - -- in ty are in tmpls - - ki = typeKind ty - ki_co = promoteCoercion co - ki_ki_co = mkNomReflCo liftedTypeKind - - Pair co_lkind co_rkind = coercionKind ki_co - --- | 'ty_co_match' does all the actual work for 'liftCoMatch'. -ty_co_match :: MatchEnv -- ^ ambient helpful info - -> LiftCoEnv -- ^ incoming subst - -> Type -- ^ ty, type to match - -> Coercion -- ^ co, coercion to match against - -> Coercion -- ^ :: kind of L type of substed ty ~N L kind of co - -> Coercion -- ^ :: kind of R type of substed ty ~N R kind of co - -> Maybe LiftCoEnv -ty_co_match menv subst ty co lkco rkco - | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco - - -- handle Refl case: - | tyCoVarsOfType ty `isNotInDomainOf` subst - , Just (ty', _) <- isReflCo_maybe co - , ty `eqType` ty' - = Just subst - - where - isNotInDomainOf :: VarSet -> VarEnv a -> Bool - isNotInDomainOf set env - = noneSet (\v -> elemVarEnv v env) set - - noneSet :: (Var -> Bool) -> VarSet -> Bool - noneSet f = allVarSet (not . f) - -ty_co_match menv subst ty co lkco rkco - | CastTy ty' co' <- ty - = ty_co_match menv subst ty' co (co' `mkTransCo` lkco) (co' `mkTransCo` rkco) - - | CoherenceCo co1 co2 <- co - = ty_co_match menv subst ty co1 (lkco `mkTransCo` mkSymCo co2) rkco - - | SymCo co' <- co - = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco - - -- Match a type variable against a non-refl coercion -ty_co_match menv subst (TyVarTy tv1) co lkco rkco - | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 - = if eqCoercionX (nukeRnEnvL rn_env) co1' co - then Just subst - else Nothing -- no match since tv1 matches two different coercions - - | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var - = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) - then Nothing -- occurs check failed - else Just $ extendVarEnv subst tv1' $ - castCoercionKind co (mkSymCo lkco) (mkSymCo rkco) - - | otherwise - = Nothing - - where - rn_env = me_env menv - tv1' = rnOccL rn_env tv1 - - -- just look through SubCo's. We don't really care about roles here. -ty_co_match menv subst ty (SubCo co) lkco rkco - = ty_co_match menv subst ty co lkco rkco - -ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco - | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy - = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] -ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco - | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 - -- yes, the one from Type, not TcType; this is for coercion optimization - = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] - -ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco - = ty_co_match_tc menv subst tc1 tys tc2 cos -ty_co_match menv subst (FunTy ty1 ty2) co _lkco _rkco - -- Despite the fact that (->) is polymorphic in four type variables (two - -- runtime rep and two types), we shouldn't need to explicitly unify the - -- runtime reps here; unifying the types themselves should be sufficient. - -- See Note [Representation of function types]. - | Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co - , tc == funTyCon - = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2] - in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos - -ty_co_match menv subst (ForAllTy (TvBndr tv1 _) ty1) - (ForAllCo tv2 kind_co2 co2) - lkco rkco - = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 - ki_ki_co ki_ki_co - ; let rn_env0 = me_env menv - rn_env1 = rnBndr2 rn_env0 tv1 tv2 - menv' = menv { me_env = rn_env1 } - ; ty_co_match menv' subst1 ty1 co2 lkco rkco } - where - ki_ki_co = mkNomReflCo liftedTypeKind - -ty_co_match _ subst (CoercionTy {}) _ _ _ - = Just subst -- don't inspect coercions - -ty_co_match menv subst ty co lkco rkco - | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco - | otherwise = Nothing - -ty_co_match_tc :: MatchEnv -> LiftCoEnv - -> TyCon -> [Type] - -> TyCon -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_tc menv subst tc1 tys1 tc2 cos2 - = do { guard (tc1 == tc2) - ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos } - where - Pair lkcos rkcos - = traverse (fmap mkNomReflCo . coercionKind) cos2 - -ty_co_match_app :: MatchEnv -> LiftCoEnv - -> Type -> [Type] -> Coercion -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_app menv subst ty1 ty1args co2 co2args - | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 - , Just (co2', co2a) <- splitAppCo_maybe co2 - = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) - - | otherwise - = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co - ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 - ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco - ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args - ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos } - where - ki1 = typeKind ty1 - ki2 = promoteCoercion co2 - ki_ki_co = mkNomReflCo liftedTypeKind - -ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] - -> [Coercion] -> [Coercion] -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_args _ subst [] [] _ _ = Just subst -ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos) - = do { subst' <- ty_co_match menv subst ty arg lkco rkco - ; ty_co_match_args menv subst' tys args lkcos rkcos } -ty_co_match_args _ _ _ _ _ _ = Nothing - -pushRefl :: Coercion -> Maybe Coercion -pushRefl (Refl Nominal (AppTy ty1 ty2)) - = Just (AppCo (Refl Nominal ty1) (mkNomReflCo ty2)) -pushRefl (Refl r (FunTy ty1 ty2)) - | Just rep1 <- getRuntimeRep_maybe ty1 - , Just rep2 <- getRuntimeRep_maybe ty2 - = Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2 - , mkReflCo r ty1, mkReflCo r ty2 ]) -pushRefl (Refl r (TyConApp tc tys)) - = Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) -pushRefl (Refl r (ForAllTy (TvBndr tv _) ty)) - = Just (mkHomoForAllCos_NoRefl [tv] (Refl r ty)) - -- NB: NoRefl variant. Otherwise, we get a loop! -pushRefl (Refl r (CastTy ty co)) = Just (castCoercionKind (Refl r ty) co co) -pushRefl _ = Nothing diff --git a/utils/Bag.hs b/utils/Bag.hs deleted file mode 100644 --- a/utils/Bag.hs +++ /dev/null @@ -1,332 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Bag: an unordered collection with duplicates --} - -{-# LANGUAGE ScopedTypeVariables, CPP #-} - -module Bag ( - Bag, -- abstract type - - emptyBag, unitBag, unionBags, unionManyBags, - mapBag, - elemBag, lengthBag, - filterBag, partitionBag, partitionBagWith, - concatBag, catBagMaybes, foldBag, foldrBag, foldlBag, - isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, - listToBag, bagToList, mapAccumBagL, - concatMapBag, mapMaybeBag, - foldrBagM, foldlBagM, mapBagM, mapBagM_, - flatMapBagM, flatMapBagPairM, - mapAndUnzipBagM, mapAccumBagLM, - anyBagM, filterBagM - ) where - -import Outputable -import Util - -import MonadUtils -import Control.Monad -import Data.Data -import Data.Maybe( mapMaybe ) -import Data.List ( partition, mapAccumL ) -import qualified Data.Foldable as Foldable - -infixr 3 `consBag` -infixl 3 `snocBag` - -data Bag a - = EmptyBag - | UnitBag a - | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty - | ListBag [a] -- INVARIANT: the list is non-empty - -emptyBag :: Bag a -emptyBag = EmptyBag - -unitBag :: a -> Bag a -unitBag = UnitBag - -lengthBag :: Bag a -> Int -lengthBag EmptyBag = 0 -lengthBag (UnitBag {}) = 1 -lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2 -lengthBag (ListBag xs) = length xs - -elemBag :: Eq a => a -> Bag a -> Bool -elemBag _ EmptyBag = False -elemBag x (UnitBag y) = x == y -elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 -elemBag x (ListBag ys) = any (x ==) ys - -unionManyBags :: [Bag a] -> Bag a -unionManyBags xs = foldr unionBags EmptyBag xs - --- This one is a bit stricter! The bag will get completely evaluated. - -unionBags :: Bag a -> Bag a -> Bag a -unionBags EmptyBag b = b -unionBags b EmptyBag = b -unionBags b1 b2 = TwoBags b1 b2 - -consBag :: a -> Bag a -> Bag a -snocBag :: Bag a -> a -> Bag a - -consBag elt bag = (unitBag elt) `unionBags` bag -snocBag bag elt = bag `unionBags` (unitBag elt) - -isEmptyBag :: Bag a -> Bool -isEmptyBag EmptyBag = True -isEmptyBag _ = False -- NB invariants - -isSingletonBag :: Bag a -> Bool -isSingletonBag EmptyBag = False -isSingletonBag (UnitBag _) = True -isSingletonBag (TwoBags _ _) = False -- Neither is empty -isSingletonBag (ListBag xs) = isSingleton xs - -filterBag :: (a -> Bool) -> Bag a -> Bag a -filterBag _ EmptyBag = EmptyBag -filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag -filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 - where sat1 = filterBag pred b1 - sat2 = filterBag pred b2 -filterBag pred (ListBag vs) = listToBag (filter pred vs) - -filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a) -filterBagM _ EmptyBag = return EmptyBag -filterBagM pred b@(UnitBag val) = do - flag <- pred val - if flag then return b - else return EmptyBag -filterBagM pred (TwoBags b1 b2) = do - sat1 <- filterBagM pred b1 - sat2 <- filterBagM pred b2 - return (sat1 `unionBags` sat2) -filterBagM pred (ListBag vs) = do - sat <- filterM pred vs - return (listToBag sat) - -allBag :: (a -> Bool) -> Bag a -> Bool -allBag _ EmptyBag = True -allBag p (UnitBag v) = p v -allBag p (TwoBags b1 b2) = allBag p b1 && allBag p b2 -allBag p (ListBag xs) = all p xs - -anyBag :: (a -> Bool) -> Bag a -> Bool -anyBag _ EmptyBag = False -anyBag p (UnitBag v) = p v -anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2 -anyBag p (ListBag xs) = any p xs - -anyBagM :: Monad m => (a -> m Bool) -> Bag a -> m Bool -anyBagM _ EmptyBag = return False -anyBagM p (UnitBag v) = p v -anyBagM p (TwoBags b1 b2) = do flag <- anyBagM p b1 - if flag then return True - else anyBagM p b2 -anyBagM p (ListBag xs) = anyM p xs - -concatBag :: Bag (Bag a) -> Bag a -concatBag bss = foldrBag add emptyBag bss - where - add bs rs = bs `unionBags` rs - -catBagMaybes :: Bag (Maybe a) -> Bag a -catBagMaybes bs = foldrBag add emptyBag bs - where - add Nothing rs = rs - add (Just x) rs = x `consBag` rs - -partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, - Bag a {- Don't -}) -partitionBag _ EmptyBag = (EmptyBag, EmptyBag) -partitionBag pred b@(UnitBag val) - = if pred val then (b, EmptyBag) else (EmptyBag, b) -partitionBag pred (TwoBags b1 b2) - = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) - where (sat1, fail1) = partitionBag pred b1 - (sat2, fail2) = partitionBag pred b2 -partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) - where (sats, fails) = partition pred vs - - -partitionBagWith :: (a -> Either b c) -> Bag a - -> (Bag b {- Left -}, - Bag c {- Right -}) -partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag) -partitionBagWith pred (UnitBag val) - = case pred val of - Left a -> (UnitBag a, EmptyBag) - Right b -> (EmptyBag, UnitBag b) -partitionBagWith pred (TwoBags b1 b2) - = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) - where (sat1, fail1) = partitionBagWith pred b1 - (sat2, fail2) = partitionBagWith pred b2 -partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) - where (sats, fails) = partitionWith pred vs - -foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative - -> (a -> r) -- Replace UnitBag with this - -> r -- Replace EmptyBag with this - -> Bag a - -> r - -{- Standard definition -foldBag t u e EmptyBag = e -foldBag t u e (UnitBag x) = u x -foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) -foldBag t u e (ListBag xs) = foldr (t.u) e xs --} - --- More tail-recursive definition, exploiting associativity of "t" -foldBag _ _ e EmptyBag = e -foldBag t u e (UnitBag x) = u x `t` e -foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 -foldBag t u e (ListBag xs) = foldr (t.u) e xs - -foldrBag :: (a -> r -> r) -> r - -> Bag a - -> r - -foldrBag _ z EmptyBag = z -foldrBag k z (UnitBag x) = k x z -foldrBag k z (TwoBags b1 b2) = foldrBag k (foldrBag k z b2) b1 -foldrBag k z (ListBag xs) = foldr k z xs - -foldlBag :: (r -> a -> r) -> r - -> Bag a - -> r - -foldlBag _ z EmptyBag = z -foldlBag k z (UnitBag x) = k z x -foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2 -foldlBag k z (ListBag xs) = foldl k z xs - -foldrBagM :: (Monad m) => (a -> b -> m b) -> b -> Bag a -> m b -foldrBagM _ z EmptyBag = return z -foldrBagM k z (UnitBag x) = k x z -foldrBagM k z (TwoBags b1 b2) = do { z' <- foldrBagM k z b2; foldrBagM k z' b1 } -foldrBagM k z (ListBag xs) = foldrM k z xs - -foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b -foldlBagM _ z EmptyBag = return z -foldlBagM k z (UnitBag x) = k z x -foldlBagM k z (TwoBags b1 b2) = do { z' <- foldlBagM k z b1; foldlBagM k z' b2 } -foldlBagM k z (ListBag xs) = foldlM k z xs - -mapBag :: (a -> b) -> Bag a -> Bag b -mapBag _ EmptyBag = EmptyBag -mapBag f (UnitBag x) = UnitBag (f x) -mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2) -mapBag f (ListBag xs) = ListBag (map f xs) - -concatMapBag :: (a -> Bag b) -> Bag a -> Bag b -concatMapBag _ EmptyBag = EmptyBag -concatMapBag f (UnitBag x) = f x -concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2) -concatMapBag f (ListBag xs) = foldr (unionBags . f) emptyBag xs - -mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b -mapMaybeBag _ EmptyBag = EmptyBag -mapMaybeBag f (UnitBag x) = case f x of - Nothing -> EmptyBag - Just y -> UnitBag y -mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) -mapMaybeBag f (ListBag xs) = ListBag (mapMaybe f xs) - -mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) -mapBagM _ EmptyBag = return EmptyBag -mapBagM f (UnitBag x) = do r <- f x - return (UnitBag r) -mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1 - r2 <- mapBagM f b2 - return (TwoBags r1 r2) -mapBagM f (ListBag xs) = do rs <- mapM f xs - return (ListBag rs) - -mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () -mapBagM_ _ EmptyBag = return () -mapBagM_ f (UnitBag x) = f x >> return () -mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 -mapBagM_ f (ListBag xs) = mapM_ f xs - -flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) -flatMapBagM _ EmptyBag = return EmptyBag -flatMapBagM f (UnitBag x) = f x -flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1 - r2 <- flatMapBagM f b2 - return (r1 `unionBags` r2) -flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs - where - k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) } - -flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) -flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag) -flatMapBagPairM f (UnitBag x) = f x -flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1 - (r2,s2) <- flatMapBagPairM f b2 - return (r1 `unionBags` r2, s1 `unionBags` s2) -flatMapBagPairM f (ListBag xs) = foldrM k (EmptyBag, EmptyBag) xs - where - k x (r2,s2) = do { (r1,s1) <- f x - ; return (r1 `unionBags` r2, s1 `unionBags` s2) } - -mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) -mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag) -mapAndUnzipBagM f (UnitBag x) = do (r,s) <- f x - return (UnitBag r, UnitBag s) -mapAndUnzipBagM f (TwoBags b1 b2) = do (r1,s1) <- mapAndUnzipBagM f b1 - (r2,s2) <- mapAndUnzipBagM f b2 - return (TwoBags r1 r2, TwoBags s1 s2) -mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs - let (rs,ss) = unzip ts - return (ListBag rs, ListBag ss) - -mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining funcction - -> acc -- ^ initial state - -> Bag x -- ^ inputs - -> (acc, Bag y) -- ^ final state, outputs -mapAccumBagL _ s EmptyBag = (s, EmptyBag) -mapAccumBagL f s (UnitBag x) = let (s1, x1) = f s x in (s1, UnitBag x1) -mapAccumBagL f s (TwoBags b1 b2) = let (s1, b1') = mapAccumBagL f s b1 - (s2, b2') = mapAccumBagL f s1 b2 - in (s2, TwoBags b1' b2') -mapAccumBagL f s (ListBag xs) = let (s', xs') = mapAccumL f s xs - in (s', ListBag xs') - -mapAccumBagLM :: Monad m - => (acc -> x -> m (acc, y)) -- ^ combining funcction - -> acc -- ^ initial state - -> Bag x -- ^ inputs - -> m (acc, Bag y) -- ^ final state, outputs -mapAccumBagLM _ s EmptyBag = return (s, EmptyBag) -mapAccumBagLM f s (UnitBag x) = do { (s1, x1) <- f s x; return (s1, UnitBag x1) } -mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s b1 - ; (s2, b2') <- mapAccumBagLM f s1 b2 - ; return (s2, TwoBags b1' b2') } -mapAccumBagLM f s (ListBag xs) = do { (s', xs') <- mapAccumLM f s xs - ; return (s', ListBag xs') } - -listToBag :: [a] -> Bag a -listToBag [] = EmptyBag -listToBag vs = ListBag vs - -bagToList :: Bag a -> [a] -bagToList b = foldrBag (:) [] b - -instance (Outputable a) => Outputable (Bag a) where - ppr bag = braces (pprWithCommas ppr (bagToList bag)) - -instance Data a => Data (Bag a) where - gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly - toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Bag" - dataCast1 x = gcast1 x - -instance Foldable.Foldable Bag where - foldr = foldrBag diff --git a/utils/Binary.hs b/utils/Binary.hs deleted file mode 100644 --- a/utils/Binary.hs +++ /dev/null @@ -1,1194 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} - -{-# OPTIONS_GHC -O -funbox-strict-fields #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- --- (c) The University of Glasgow 2002-2006 --- --- Binary I/O library, with special tweaks for GHC --- --- Based on the nhc98 Binary library, which is copyright --- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. --- Under the terms of the license for that software, we must tell you --- where you can obtain the original version of the Binary library, namely --- http://www.cs.york.ac.uk/fp/nhc98/ - -module Binary - ( {-type-} Bin, - {-class-} Binary(..), - {-type-} BinHandle, - SymbolTable, Dictionary, - - openBinMem, --- closeBin, - - seekBin, - seekBy, - tellBin, - castBin, - isEOFBin, - withBinBuffer, - - writeBinMem, - readBinMem, - - putAt, getAt, - - -- * For writing instances - putByte, - getByte, - - -- * Lazy Binary I/O - lazyGet, - lazyPut, - - -- * User data - UserData(..), getUserData, setUserData, - newReadState, newWriteState, - putDictionary, getDictionary, putFS, - ) where - -#include "HsVersions.h" - --- The *host* architecture version: -#include "MachDeps.h" - -import {-# SOURCE #-} Name (Name) -import FastString -import Panic -import UniqFM -import FastMutInt -import Fingerprint -import BasicTypes -import SrcLoc - -import Foreign -import Data.Array -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Unsafe as BS -import Data.IORef -import Data.Char ( ord, chr ) -import Data.Time -#if MIN_VERSION_base(4,10,0) -import Type.Reflection -import Type.Reflection.Unsafe -import Data.Kind (Type) -import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..)) -#else -import Data.Typeable -#endif -import Control.Monad ( when ) -import System.IO as IO -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO.Error ( mkIOError, eofErrorType ) -import GHC.Real ( Ratio(..) ) -import GHC.Serialized - -type BinArray = ForeignPtr Word8 - ---------------------------------------------------------------- --- BinHandle ---------------------------------------------------------------- - -data BinHandle - = BinMem { -- binary data stored in an unboxed array - bh_usr :: UserData, -- sigh, need parameterized modules :-) - _off_r :: !FastMutInt, -- the current offset - _sz_r :: !FastMutInt, -- size of the array (cached) - _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) - } - -- XXX: should really store a "high water mark" for dumping out - -- the binary data to a file. - -getUserData :: BinHandle -> UserData -getUserData bh = bh_usr bh - -setUserData :: BinHandle -> UserData -> BinHandle -setUserData bh us = bh { bh_usr = us } - --- | Get access to the underlying buffer. --- --- It is quite important that no references to the 'ByteString' leak out of the --- continuation lest terrible things happen. -withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a -withBinBuffer (BinMem _ ix_r _ arr_r) action = do - arr <- readIORef arr_r - ix <- readFastMutInt ix_r - withForeignPtr arr $ \ptr -> - BS.unsafePackCStringLen (castPtr ptr, ix) >>= action - - ---------------------------------------------------------------- --- Bin ---------------------------------------------------------------- - -newtype Bin a = BinPtr Int - deriving (Eq, Ord, Show, Bounded) - -castBin :: Bin a -> Bin b -castBin (BinPtr i) = BinPtr i - ---------------------------------------------------------------- --- class Binary ---------------------------------------------------------------- - -class Binary a where - put_ :: BinHandle -> a -> IO () - put :: BinHandle -> a -> IO (Bin a) - get :: BinHandle -> IO a - - -- define one of put_, put. Use of put_ is recommended because it - -- is more likely that tail-calls can kick in, and we rarely need the - -- position return value. - put_ bh a = do _ <- put bh a; return () - put bh a = do p <- tellBin bh; put_ bh a; return p - -putAt :: Binary a => BinHandle -> Bin a -> a -> IO () -putAt bh p x = do seekBin bh p; put_ bh x; return () - -getAt :: Binary a => BinHandle -> Bin a -> IO a -getAt bh p = do seekBin bh p; get bh - -openBinMem :: Int -> IO BinHandle -openBinMem size - | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" - | otherwise = do - arr <- mallocForeignPtrBytes size - arr_r <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r size - return (BinMem noUserData ix_r sz_r arr_r) - -tellBin :: BinHandle -> IO (Bin a) -tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) - -seekBin :: BinHandle -> Bin a -> IO () -seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do - sz <- readFastMutInt sz_r - if (p >= sz) - then do expandBin h p; writeFastMutInt ix_r p - else writeFastMutInt ix_r p - -seekBy :: BinHandle -> Int -> IO () -seekBy h@(BinMem _ ix_r sz_r _) off = do - sz <- readFastMutInt sz_r - ix <- readFastMutInt ix_r - let ix' = ix + off - if (ix' >= sz) - then do expandBin h ix'; writeFastMutInt ix_r ix' - else writeFastMutInt ix_r ix' - -isEOFBin :: BinHandle -> IO Bool -isEOFBin (BinMem _ ix_r sz_r _) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - return (ix >= sz) - -writeBinMem :: BinHandle -> FilePath -> IO () -writeBinMem (BinMem _ ix_r _ arr_r) fn = do - h <- openBinaryFile fn WriteMode - arr <- readIORef arr_r - ix <- readFastMutInt ix_r - withForeignPtr arr $ \p -> hPutBuf h p ix - hClose h - -readBinMem :: FilePath -> IO BinHandle --- Return a BinHandle with a totally undefined State -readBinMem filename = do - h <- openBinaryFile filename ReadMode - filesize' <- hFileSize h - let filesize = fromIntegral filesize' - arr <- mallocForeignPtrBytes filesize - count <- withForeignPtr arr $ \p -> hGetBuf h p filesize - when (count /= filesize) $ - error ("Binary.readBinMem: only read " ++ show count ++ " bytes") - hClose h - arr_r <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r filesize - return (BinMem noUserData ix_r sz_r arr_r) - --- expand the size of the array to include a specified offset -expandBin :: BinHandle -> Int -> IO () -expandBin (BinMem _ _ sz_r arr_r) off = do - sz <- readFastMutInt sz_r - let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) - arr <- readIORef arr_r - arr' <- mallocForeignPtrBytes sz' - withForeignPtr arr $ \old -> - withForeignPtr arr' $ \new -> - copyBytes new old sz - writeFastMutInt sz_r sz' - writeIORef arr_r arr' - --- ----------------------------------------------------------------------------- --- Low-level reading/writing of bytes - -putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () -putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix + size > sz) $ - expandBin h (ix + size) - arr <- readIORef arr_r - withForeignPtr arr $ \op -> f (op `plusPtr` ix) - writeFastMutInt ix_r (ix + size) - -getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a -getPrim (BinMem _ ix_r sz_r arr_r) size f = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix + size > sz) $ - ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) - arr <- readIORef arr_r - w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) - writeFastMutInt ix_r (ix + size) - return w - -putWord8 :: BinHandle -> Word8 -> IO () -putWord8 h w = putPrim h 1 (\op -> poke op w) - -getWord8 :: BinHandle -> IO Word8 -getWord8 h = getPrim h 1 peek - -putWord16 :: BinHandle -> Word16 -> IO () -putWord16 h w = putPrim h 2 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) - pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) - ) - -getWord16 :: BinHandle -> IO Word16 -getWord16 h = getPrim h 2 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - return $! w0 `shiftL` 8 .|. w1 - ) - -putWord32 :: BinHandle -> Word32 -> IO () -putWord32 h w = putPrim h 4 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) - pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) - pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) - pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) - ) - -getWord32 :: BinHandle -> IO Word32 -getWord32 h = getPrim h 4 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - w2 <- fromIntegral <$> peekElemOff op 2 - w3 <- fromIntegral <$> peekElemOff op 3 - - return $! (w0 `shiftL` 24) .|. - (w1 `shiftL` 16) .|. - (w2 `shiftL` 8) .|. - w3 - ) - -putWord64 :: BinHandle -> Word64 -> IO () -putWord64 h w = putPrim h 8 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) - pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) - pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) - pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) - pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) - pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) - pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) - pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) - ) - -getWord64 :: BinHandle -> IO Word64 -getWord64 h = getPrim h 8 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - w2 <- fromIntegral <$> peekElemOff op 2 - w3 <- fromIntegral <$> peekElemOff op 3 - w4 <- fromIntegral <$> peekElemOff op 4 - w5 <- fromIntegral <$> peekElemOff op 5 - w6 <- fromIntegral <$> peekElemOff op 6 - w7 <- fromIntegral <$> peekElemOff op 7 - - return $! (w0 `shiftL` 56) .|. - (w1 `shiftL` 48) .|. - (w2 `shiftL` 40) .|. - (w3 `shiftL` 32) .|. - (w4 `shiftL` 24) .|. - (w5 `shiftL` 16) .|. - (w6 `shiftL` 8) .|. - w7 - ) - -putByte :: BinHandle -> Word8 -> IO () -putByte bh w = putWord8 bh w - -getByte :: BinHandle -> IO Word8 -getByte h = getWord8 h - --- ----------------------------------------------------------------------------- --- Primitve Word writes - -instance Binary Word8 where - put_ = putWord8 - get = getWord8 - -instance Binary Word16 where - put_ h w = putWord16 h w - get h = getWord16 h - -instance Binary Word32 where - put_ h w = putWord32 h w - get h = getWord32 h - -instance Binary Word64 where - put_ h w = putWord64 h w - get h = getWord64 h - --- ----------------------------------------------------------------------------- --- Primitve Int writes - -instance Binary Int8 where - put_ h w = put_ h (fromIntegral w :: Word8) - get h = do w <- get h; return $! (fromIntegral (w::Word8)) - -instance Binary Int16 where - put_ h w = put_ h (fromIntegral w :: Word16) - get h = do w <- get h; return $! (fromIntegral (w::Word16)) - -instance Binary Int32 where - put_ h w = put_ h (fromIntegral w :: Word32) - get h = do w <- get h; return $! (fromIntegral (w::Word32)) - -instance Binary Int64 where - put_ h w = put_ h (fromIntegral w :: Word64) - get h = do w <- get h; return $! (fromIntegral (w::Word64)) - --- ----------------------------------------------------------------------------- --- Instances for standard types - -instance Binary () where - put_ _ () = return () - get _ = return () - -instance Binary Bool where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) - -instance Binary Char where - put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) - get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) - -instance Binary Int where - put_ bh i = put_ bh (fromIntegral i :: Int64) - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int64)) - -instance Binary a => Binary [a] where - put_ bh l = do - let len = length l - if (len < 0xff) - then putByte bh (fromIntegral len :: Word8) - else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32) - mapM_ (put_ bh) l - get bh = do - b <- getByte bh - len <- if b == 0xff - then get bh - else return (fromIntegral b :: Word32) - let loop 0 = return [] - loop n = do a <- get bh; as <- loop (n-1); return (a:as) - loop len - -instance (Binary a, Binary b) => Binary (a,b) where - put_ bh (a,b) = do put_ bh a; put_ bh b - get bh = do a <- get bh - b <- get bh - return (a,b) - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c - get bh = do a <- get bh - b <- get bh - c <- get bh - return (a,b,c) - -instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (a,b,c,d) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where - put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - return (a,b,c,d,e) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where - put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - return (a,b,c,d,e,f) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where - put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - g <- get bh - return (a,b,c,d,e,f,g) - -instance Binary a => Binary (Maybe a) where - put_ bh Nothing = putByte bh 0 - put_ bh (Just a) = do putByte bh 1; put_ bh a - get bh = do h <- getWord8 bh - case h of - 0 -> return Nothing - _ -> do x <- get bh; return (Just x) - -instance (Binary a, Binary b) => Binary (Either a b) where - put_ bh (Left a) = do putByte bh 0; put_ bh a - put_ bh (Right b) = do putByte bh 1; put_ bh b - get bh = do h <- getWord8 bh - case h of - 0 -> do a <- get bh ; return (Left a) - _ -> do b <- get bh ; return (Right b) - -instance Binary UTCTime where - put_ bh u = do put_ bh (utctDay u) - put_ bh (utctDayTime u) - get bh = do day <- get bh - dayTime <- get bh - return $ UTCTime { utctDay = day, utctDayTime = dayTime } - -instance Binary Day where - put_ bh d = put_ bh (toModifiedJulianDay d) - get bh = do i <- get bh - return $ ModifiedJulianDay { toModifiedJulianDay = i } - -instance Binary DiffTime where - put_ bh dt = put_ bh (toRational dt) - get bh = do r <- get bh - return $ fromRational r - ---to quote binary-0.3 on this code idea, --- --- TODO This instance is not architecture portable. GMP stores numbers as --- arrays of machine sized words, so the byte format is not portable across --- architectures with different endianess and word size. --- --- This makes it hard (impossible) to make an equivalent instance --- with code that is compilable with non-GHC. Do we need any instance --- Binary Integer, and if so, does it have to be blazing fast? Or can --- we just change this instance to be portable like the rest of the --- instances? (binary package has code to steal for that) --- --- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.hs - -instance Binary Integer where - put_ bh i - | i >= lo32 && i <= hi32 = do - putWord8 bh 0 - put_ bh (fromIntegral i :: Int32) - | otherwise = do - putWord8 bh 1 - put_ bh (show i) - where - lo32 = fromIntegral (minBound :: Int32) - hi32 = fromIntegral (maxBound :: Int32) - - get bh = do - int_kind <- getWord8 bh - case int_kind of - 0 -> fromIntegral <$> (get bh :: IO Int32) - _ -> do str <- get bh - case reads str of - [(i, "")] -> return i - _ -> fail ("Binary integer: got " ++ show str) - - {- - -- This code is currently commented out. - -- See https://ghc.haskell.org/trac/ghc/ticket/3379#comment:10 for - -- discussion. - - put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) - put_ bh (J# s# a#) = do - putByte bh 1 - put_ bh (I# s#) - let sz# = sizeofByteArray# a# -- in *bytes* - put_ bh (I# sz#) -- in *bytes* - putByteArray bh a# sz# - - get bh = do - b <- getByte bh - case b of - 0 -> do (I# i#) <- get bh - return (S# i#) - _ -> do (I# s#) <- get bh - sz <- get bh - (BA a#) <- getByteArray bh sz - return (J# s# a#) - -putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () -putByteArray bh a s# = loop 0# - where loop n# - | n# ==# s# = return () - | otherwise = do - putByte bh (indexByteArray a n#) - loop (n# +# 1#) - -getByteArray :: BinHandle -> Int -> IO ByteArray -getByteArray bh (I# sz) = do - (MBA arr) <- newByteArray sz - let loop n - | n ==# sz = return () - | otherwise = do - w <- getByte bh - writeByteArray arr n w - loop (n +# 1#) - loop 0# - freezeByteArray arr - -} - -{- -data ByteArray = BA ByteArray# -data MBA = MBA (MutableByteArray# RealWorld) - -newByteArray :: Int# -> IO MBA -newByteArray sz = IO $ \s -> - case newByteArray# sz s of { (# s, arr #) -> - (# s, MBA arr #) } - -freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray -freezeByteArray arr = IO $ \s -> - case unsafeFreezeByteArray# arr s of { (# s, arr #) -> - (# s, BA arr #) } - -writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () -writeByteArray arr i (W8# w) = IO $ \s -> - case writeWord8Array# arr i w s of { s -> - (# s, () #) } - -indexByteArray :: ByteArray# -> Int# -> Word8 -indexByteArray a# n# = W8# (indexWord8Array# a# n#) - --} -instance (Binary a) => Binary (Ratio a) where - put_ bh (a :% b) = do put_ bh a; put_ bh b - get bh = do a <- get bh; b <- get bh; return (a :% b) - -instance Binary (Bin a) where - put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32) - get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32))) - --- ----------------------------------------------------------------------------- --- Instances for Data.Typeable stuff - -#if MIN_VERSION_base(4,10,0) -instance Binary TyCon where - put_ bh tc = do - put_ bh (tyConPackage tc) - put_ bh (tyConModule tc) - put_ bh (tyConName tc) - put_ bh (tyConKindArgs tc) - put_ bh (tyConKindRep tc) - get bh = - mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -#else -instance Binary TyCon where - put_ bh tc = do - put_ bh (tyConPackage tc) - put_ bh (tyConModule tc) - put_ bh (tyConName tc) - get bh = - mkTyCon3 <$> get bh <*> get bh <*> get bh -#endif - -#if MIN_VERSION_base(4,10,0) -instance Binary VecCount where - put_ bh = putByte bh . fromIntegral . fromEnum - get bh = toEnum . fromIntegral <$> getByte bh - -instance Binary VecElem where - put_ bh = putByte bh . fromIntegral . fromEnum - get bh = toEnum . fromIntegral <$> getByte bh - -instance Binary RuntimeRep where - put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b - put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps - put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps - put_ bh LiftedRep = putByte bh 3 - put_ bh UnliftedRep = putByte bh 4 - put_ bh IntRep = putByte bh 5 - put_ bh WordRep = putByte bh 6 - put_ bh Int64Rep = putByte bh 7 - put_ bh Word64Rep = putByte bh 8 - put_ bh AddrRep = putByte bh 9 - put_ bh FloatRep = putByte bh 10 - put_ bh DoubleRep = putByte bh 11 - - get bh = do - tag <- getByte bh - case tag of - 0 -> VecRep <$> get bh <*> get bh - 1 -> TupleRep <$> get bh - 2 -> SumRep <$> get bh - 3 -> pure LiftedRep - 4 -> pure UnliftedRep - 5 -> pure IntRep - 6 -> pure WordRep - 7 -> pure Int64Rep - 8 -> pure Word64Rep - 9 -> pure AddrRep - 10 -> pure FloatRep - 11 -> pure DoubleRep - _ -> fail "Binary.putRuntimeRep: invalid tag" - -instance Binary KindRep where - put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k - put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr - put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b - put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b - put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r - put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r - - get bh = do - tag <- getByte bh - case tag of - 0 -> KindRepTyConApp <$> get bh <*> get bh - 1 -> KindRepVar <$> get bh - 2 -> KindRepApp <$> get bh <*> get bh - 3 -> KindRepFun <$> get bh <*> get bh - 4 -> KindRepTYPE <$> get bh - 5 -> KindRepTypeLit <$> get bh <*> get bh - _ -> fail "Binary.putKindRep: invalid tag" - -instance Binary TypeLitSort where - put_ bh TypeLitSymbol = putByte bh 0 - put_ bh TypeLitNat = putByte bh 1 - get bh = do - tag <- getByte bh - case tag of - 0 -> pure TypeLitSymbol - 1 -> pure TypeLitNat - _ -> fail "Binary.putTypeLitSort: invalid tag" - -putTypeRep :: BinHandle -> TypeRep a -> IO () --- Special handling for TYPE, (->), and RuntimeRep due to recursive kind --- relations. --- See Note [Mutually recursive representations of primitive types] -putTypeRep bh rep - | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) - = put_ bh (0 :: Word8) -putTypeRep bh (Con' con ks) = do - put_ bh (1 :: Word8) - put_ bh con - put_ bh ks -putTypeRep bh (App f x) = do - put_ bh (2 :: Word8) - putTypeRep bh f - putTypeRep bh x -putTypeRep bh (Fun arg res) = do - put_ bh (3 :: Word8) - putTypeRep bh arg - putTypeRep bh res -putTypeRep _ _ = fail "Binary.putTypeRep: Impossible" - -getSomeTypeRep :: BinHandle -> IO SomeTypeRep -getSomeTypeRep bh = do - tag <- get bh :: IO Word8 - case tag of - 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type) - 1 -> do con <- get bh :: IO TyCon - ks <- get bh :: IO [SomeTypeRep] - return $ SomeTypeRep $ mkTrCon con ks - - 2 -> do SomeTypeRep f <- getSomeTypeRep bh - SomeTypeRep x <- getSomeTypeRep bh - case typeRepKind f of - Fun arg res -> - case arg `eqTypeRep` typeRepKind x of - Just HRefl -> - case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of - Just HRefl -> return $ SomeTypeRep $ mkTrApp f x - _ -> failure "Kind mismatch in type application" [] - _ -> failure "Kind mismatch in type application" - [ " Found argument of kind: " ++ show (typeRepKind x) - , " Where the constructor: " ++ show f - , " Expects kind: " ++ show arg - ] - _ -> failure "Applied non-arrow" - [ " Applied type: " ++ show f - , " To argument: " ++ show x - ] - 3 -> do SomeTypeRep arg <- getSomeTypeRep bh - SomeTypeRep res <- getSomeTypeRep bh - case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of - Just HRefl -> - case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of - Just HRefl -> return $ SomeTypeRep $ Fun arg res - Nothing -> failure "Kind mismatch" [] - _ -> failure "Kind mismatch" [] - _ -> failure "Invalid SomeTypeRep" [] - where - failure description info = - fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ] - ++ map (" "++) info - -instance Typeable a => Binary (TypeRep (a :: k)) where - put_ = putTypeRep - get bh = do - SomeTypeRep rep <- getSomeTypeRep bh - case rep `eqTypeRep` expected of - Just HRefl -> pure rep - Nothing -> fail $ unlines - [ "Binary: Type mismatch" - , " Deserialized type: " ++ show rep - , " Expected type: " ++ show expected - ] - where expected = typeRep :: TypeRep a - -instance Binary SomeTypeRep where - put_ bh (SomeTypeRep rep) = putTypeRep bh rep - get = getSomeTypeRep -#else -instance Binary TypeRep where - put_ bh type_rep = do - let (ty_con, child_type_reps) = splitTyConApp type_rep - put_ bh ty_con - put_ bh child_type_reps - get bh = do - ty_con <- get bh - child_type_reps <- get bh - return (mkTyConApp ty_con child_type_reps) -#endif - --- ----------------------------------------------------------------------------- --- Lazy reading/writing - -lazyPut :: Binary a => BinHandle -> a -> IO () -lazyPut bh a = do - -- output the obj with a ptr to skip over it: - pre_a <- tellBin bh - put_ bh pre_a -- save a slot for the ptr - put_ bh a -- dump the object - q <- tellBin bh -- q = ptr to after object - putAt bh pre_a q -- fill in slot before a with ptr to q - seekBin bh q -- finally carry on writing at q - -lazyGet :: Binary a => BinHandle -> IO a -lazyGet bh = do - p <- get bh -- a BinPtr - p_a <- tellBin bh - a <- unsafeInterleaveIO $ do - -- NB: Use a fresh off_r variable in the child thread, for thread - -- safety. - off_r <- newFastMutInt - getAt bh { _off_r = off_r } p_a - seekBin bh p -- skip over the object for now - return a - --- ----------------------------------------------------------------------------- --- UserData --- ----------------------------------------------------------------------------- - --- | Information we keep around during interface file --- serialization/deserialization. Namely we keep the functions for serializing --- and deserializing 'Name's and 'FastString's. We do this because we actually --- use serialization in two distinct settings, --- --- * When serializing interface files themselves --- --- * When computing the fingerprint of an IfaceDecl (which we computing by --- hashing its Binary serialization) --- --- These two settings have different needs while serializing Names: --- --- * Names in interface files are serialized via a symbol table (see Note --- [Symbol table representation of names] in BinIface). --- --- * During fingerprinting a binding Name is serialized as the OccName and a --- non-binding Name is serialized as the fingerprint of the thing they --- represent. See Note [Fingerprinting IfaceDecls] for further discussion. --- -data UserData = - UserData { - -- for *deserialising* only: - ud_get_name :: BinHandle -> IO Name, - ud_get_fs :: BinHandle -> IO FastString, - - -- for *serialising* only: - ud_put_nonbinding_name :: BinHandle -> Name -> IO (), - -- ^ serialize a non-binding 'Name' (e.g. a reference to another - -- binding). - ud_put_binding_name :: BinHandle -> Name -> IO (), - -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl) - ud_put_fs :: BinHandle -> FastString -> IO () - } - -newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's - -> (BinHandle -> IO FastString) - -> UserData -newReadState get_name get_fs - = UserData { ud_get_name = get_name, - ud_get_fs = get_fs, - ud_put_nonbinding_name = undef "put_nonbinding_name", - ud_put_binding_name = undef "put_binding_name", - ud_put_fs = undef "put_fs" - } - -newWriteState :: (BinHandle -> Name -> IO ()) - -- ^ how to serialize non-binding 'Name's - -> (BinHandle -> Name -> IO ()) - -- ^ how to serialize binding 'Name's - -> (BinHandle -> FastString -> IO ()) - -> UserData -newWriteState put_nonbinding_name put_binding_name put_fs - = UserData { ud_get_name = undef "get_name", - ud_get_fs = undef "get_fs", - ud_put_nonbinding_name = put_nonbinding_name, - ud_put_binding_name = put_binding_name, - ud_put_fs = put_fs - } - -noUserData :: a -noUserData = undef "UserData" - -undef :: String -> a -undef s = panic ("Binary.UserData: no " ++ s) - ---------------------------------------------------------- --- The Dictionary ---------------------------------------------------------- - -type Dictionary = Array Int FastString -- The dictionary - -- Should be 0-indexed - -putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO () -putDictionary bh sz dict = do - put_ bh sz - mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) - -- It's OK to use nonDetEltsUFM here because the elements have indices - -- that array uses to create order - -getDictionary :: BinHandle -> IO Dictionary -getDictionary bh = do - sz <- get bh - elems <- sequence (take sz (repeat (getFS bh))) - return (listArray (0,sz-1) elems) - ---------------------------------------------------------- --- The Symbol Table ---------------------------------------------------------- - --- On disk, the symbol table is an array of IfExtName, when --- reading it in we turn it into a SymbolTable. - -type SymbolTable = Array Int Name - ---------------------------------------------------------- --- Reading and writing FastStrings ---------------------------------------------------------- - -putFS :: BinHandle -> FastString -> IO () -putFS bh fs = putBS bh $ fastStringToByteString fs - -getFS :: BinHandle -> IO FastString -getFS bh = do - l <- get bh :: IO Int - getPrim bh l (\src -> pure $! mkFastStringBytes src l ) - -putBS :: BinHandle -> ByteString -> IO () -putBS bh bs = - BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do - put_ bh l - putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l) - -getBS :: BinHandle -> IO ByteString -getBS bh = do - l <- get bh :: IO Int - BS.create l $ \dest -> do - getPrim bh l (\src -> BS.memcpy dest src l) - -instance Binary ByteString where - put_ bh f = putBS bh f - get bh = getBS bh - -instance Binary FastString where - put_ bh f = - case getUserData bh of - UserData { ud_put_fs = put_fs } -> put_fs bh f - - get bh = - case getUserData bh of - UserData { ud_get_fs = get_fs } -> get_fs bh - --- Here to avoid loop -instance Binary LeftOrRight where - put_ bh CLeft = putByte bh 0 - put_ bh CRight = putByte bh 1 - - get bh = do { h <- getByte bh - ; case h of - 0 -> return CLeft - _ -> return CRight } - -instance Binary Fingerprint where - put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 - get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) - -instance Binary FunctionOrData where - put_ bh IsFunction = putByte bh 0 - put_ bh IsData = putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> return IsFunction - 1 -> return IsData - _ -> panic "Binary FunctionOrData" - -instance Binary TupleSort where - put_ bh BoxedTuple = putByte bh 0 - put_ bh UnboxedTuple = putByte bh 1 - put_ bh ConstraintTuple = putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return BoxedTuple - 1 -> do return UnboxedTuple - _ -> do return ConstraintTuple - -instance Binary Activation where - put_ bh NeverActive = do - putByte bh 0 - put_ bh AlwaysActive = do - putByte bh 1 - put_ bh (ActiveBefore src aa) = do - putByte bh 2 - put_ bh src - put_ bh aa - put_ bh (ActiveAfter src ab) = do - putByte bh 3 - put_ bh src - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do return NeverActive - 1 -> do return AlwaysActive - 2 -> do src <- get bh - aa <- get bh - return (ActiveBefore src aa) - _ -> do src <- get bh - ab <- get bh - return (ActiveAfter src ab) - -instance Binary InlinePragma where - put_ bh (InlinePragma s a b c d) = do - put_ bh s - put_ bh a - put_ bh b - put_ bh c - put_ bh d - - get bh = do - s <- get bh - a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (InlinePragma s a b c d) - -instance Binary RuleMatchInfo where - put_ bh FunLike = putByte bh 0 - put_ bh ConLike = putByte bh 1 - get bh = do - h <- getByte bh - if h == 1 then return ConLike - else return FunLike - -instance Binary InlineSpec where - put_ bh EmptyInlineSpec = putByte bh 0 - put_ bh Inline = putByte bh 1 - put_ bh Inlinable = putByte bh 2 - put_ bh NoInline = putByte bh 3 - - get bh = do h <- getByte bh - case h of - 0 -> return EmptyInlineSpec - 1 -> return Inline - 2 -> return Inlinable - _ -> return NoInline - -instance Binary RecFlag where - put_ bh Recursive = do - putByte bh 0 - put_ bh NonRecursive = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return Recursive - _ -> do return NonRecursive - -instance Binary OverlapMode where - put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s - put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s - put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s - put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s - put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s - get bh = do - h <- getByte bh - case h of - 0 -> (get bh) >>= \s -> return $ NoOverlap s - 1 -> (get bh) >>= \s -> return $ Overlaps s - 2 -> (get bh) >>= \s -> return $ Incoherent s - 3 -> (get bh) >>= \s -> return $ Overlapping s - 4 -> (get bh) >>= \s -> return $ Overlappable s - _ -> panic ("get OverlapMode" ++ show h) - - -instance Binary OverlapFlag where - put_ bh flag = do put_ bh (overlapMode flag) - put_ bh (isSafeOverlap flag) - get bh = do - h <- get bh - b <- get bh - return OverlapFlag { overlapMode = h, isSafeOverlap = b } - -instance Binary FixityDirection where - put_ bh InfixL = do - putByte bh 0 - put_ bh InfixR = do - putByte bh 1 - put_ bh InfixN = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return InfixL - 1 -> do return InfixR - _ -> do return InfixN - -instance Binary Fixity where - put_ bh (Fixity src aa ab) = do - put_ bh src - put_ bh aa - put_ bh ab - get bh = do - src <- get bh - aa <- get bh - ab <- get bh - return (Fixity src aa ab) - -instance Binary WarningTxt where - put_ bh (WarningTxt s w) = do - putByte bh 0 - put_ bh s - put_ bh w - put_ bh (DeprecatedTxt s d) = do - putByte bh 1 - put_ bh s - put_ bh d - - get bh = do - h <- getByte bh - case h of - 0 -> do s <- get bh - w <- get bh - return (WarningTxt s w) - _ -> do s <- get bh - d <- get bh - return (DeprecatedTxt s d) - -instance Binary StringLiteral where - put_ bh (StringLiteral st fs) = do - put_ bh st - put_ bh fs - get bh = do - st <- get bh - fs <- get bh - return (StringLiteral st fs) - -instance Binary a => Binary (GenLocated SrcSpan a) where - put_ bh (L l x) = do - put_ bh l - put_ bh x - - get bh = do - l <- get bh - x <- get bh - return (L l x) - -instance Binary SrcSpan where - put_ bh (RealSrcSpan ss) = do - putByte bh 0 - put_ bh (srcSpanFile ss) - put_ bh (srcSpanStartLine ss) - put_ bh (srcSpanStartCol ss) - put_ bh (srcSpanEndLine ss) - put_ bh (srcSpanEndCol ss) - - put_ bh (UnhelpfulSpan s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> do f <- get bh - sl <- get bh - sc <- get bh - el <- get bh - ec <- get bh - return (mkSrcSpan (mkSrcLoc f sl sc) - (mkSrcLoc f el ec)) - _ -> do s <- get bh - return (UnhelpfulSpan s) - -instance Binary Serialized where - put_ bh (Serialized the_type bytes) = do - put_ bh the_type - put_ bh bytes - get bh = do - the_type <- get bh - bytes <- get bh - return (Serialized the_type bytes) - -instance Binary SourceText where - put_ bh NoSourceText = putByte bh 0 - put_ bh (SourceText s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> return NoSourceText - 1 -> do - s <- get bh - return (SourceText s) - _ -> panic $ "Binary SourceText:" ++ show h diff --git a/utils/BooleanFormula.hs b/utils/BooleanFormula.hs deleted file mode 100644 --- a/utils/BooleanFormula.hs +++ /dev/null @@ -1,260 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, - DeriveTraversable #-} - --------------------------------------------------------------------------------- --- | Boolean formulas without quantifiers and without negation. --- Such a formula consists of variables, conjunctions (and), and disjunctions (or). --- --- This module is used to represent minimal complete definitions for classes. --- -module BooleanFormula ( - BooleanFormula(..), LBooleanFormula, - mkFalse, mkTrue, mkAnd, mkOr, mkVar, - isFalse, isTrue, - eval, simplify, isUnsatisfied, - implies, impliesAtom, - pprBooleanFormula, pprBooleanFormulaNice - ) where - -import Data.List ( nub, intersperse ) -import Data.Data - -import MonadUtils -import Outputable -import Binary -import SrcLoc -import Unique -import UniqSet - ----------------------------------------------------------------------- --- Boolean formula type and smart constructors ----------------------------------------------------------------------- - -type LBooleanFormula a = Located (BooleanFormula a) - -data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a] - | Parens (LBooleanFormula a) - deriving (Eq, Data, Functor, Foldable, Traversable) - -mkVar :: a -> BooleanFormula a -mkVar = Var - -mkFalse, mkTrue :: BooleanFormula a -mkFalse = Or [] -mkTrue = And [] - --- Convert a Bool to a BooleanFormula -mkBool :: Bool -> BooleanFormula a -mkBool False = mkFalse -mkBool True = mkTrue - --- Make a conjunction, and try to simplify -mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a -mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd - where - -- See Note [Simplification of BooleanFormulas] - fromAnd :: LBooleanFormula a -> Maybe [LBooleanFormula a] - fromAnd (L _ (And xs)) = Just xs - -- assume that xs are already simplified - -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs - fromAnd (L _ (Or [])) = Nothing - -- in case of False we bail out, And [..,mkFalse,..] == mkFalse - fromAnd x = Just [x] - mkAnd' [x] = unLoc x - mkAnd' xs = And xs - -mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a -mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr - where - -- See Note [Simplification of BooleanFormulas] - fromOr (L _ (Or xs)) = Just xs - fromOr (L _ (And [])) = Nothing - fromOr x = Just [x] - mkOr' [x] = unLoc x - mkOr' xs = Or xs - - -{- -Note [Simplification of BooleanFormulas] -~~~~~~~~~~~~~~~~~~~~~~ -The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular, - 1. Collapsing nested ands and ors, so - `(mkAnd [x, And [y,z]]` - is represented as - `And [x,y,z]` - Implemented by `fromAnd`/`fromOr` - 2. Collapsing trivial ands and ors, so - `mkAnd [x]` becomes just `x`. - Implemented by mkAnd' / mkOr' - 3. Conjunction with false, disjunction with true is simplified, i.e. - `mkAnd [mkFalse,x]` becomes `mkFalse`. - 4. Common subexpression elimination: - `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`. - -This simplification is not exhaustive, in the sense that it will not produce -the smallest possible equivalent expression. For example, -`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently -is not. A general simplifier would need to use something like BDDs. - -The reason behind the (crude) simplifier is to make for more user friendly -error messages. E.g. for the code - > class Foo a where - > {-# MINIMAL bar, (foo, baq | foo, quux) #-} - > instance Foo Int where - > bar = ... - > baz = ... - > quux = ... -We don't show a ridiculous error message like - Implement () and (either (`foo' and ()) or (`foo' and ())) --} - ----------------------------------------------------------------------- --- Evaluation and simplification ----------------------------------------------------------------------- - -isFalse :: BooleanFormula a -> Bool -isFalse (Or []) = True -isFalse _ = False - -isTrue :: BooleanFormula a -> Bool -isTrue (And []) = True -isTrue _ = False - -eval :: (a -> Bool) -> BooleanFormula a -> Bool -eval f (Var x) = f x -eval f (And xs) = all (eval f . unLoc) xs -eval f (Or xs) = any (eval f . unLoc) xs -eval f (Parens x) = eval f (unLoc x) - --- Simplify a boolean formula. --- The argument function should give the truth of the atoms, or Nothing if undecided. -simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a -simplify f (Var a) = case f a of - Nothing -> Var a - Just b -> mkBool b -simplify f (And xs) = mkAnd (map (\(L l x) -> L l (simplify f x)) xs) -simplify f (Or xs) = mkOr (map (\(L l x) -> L l (simplify f x)) xs) -simplify f (Parens x) = simplify f (unLoc x) - --- Test if a boolean formula is satisfied when the given values are assigned to the atoms --- if it is, returns Nothing --- if it is not, return (Just remainder) -isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a) -isUnsatisfied f bf - | isTrue bf' = Nothing - | otherwise = Just bf' - where - f' x = if f x then Just True else Nothing - bf' = simplify f' bf - --- prop_simplify: --- eval f x == True <==> isTrue (simplify (Just . f) x) --- eval f x == False <==> isFalse (simplify (Just . f) x) - --- If the boolean formula holds, does that mean that the given atom is always true? -impliesAtom :: Eq a => BooleanFormula a -> a -> Bool -Var x `impliesAtom` y = x == y -And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs - -- we have all of xs, so one of them implying y is enough -Or xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs -Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y - -implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool -implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) - where - go :: Uniquable a => Clause a -> Clause a -> Bool - go l@Clause{ clauseExprs = hyp:hyps } r = - case hyp of - Var x | memberClauseAtoms x r -> True - | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r - Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r - And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r - Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' - go l r@Clause{ clauseExprs = con:cons } = - case con of - Var x | memberClauseAtoms x l -> True - | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons } - Parens con' -> go l r { clauseExprs = unLoc con':cons } - And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' - Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } - go _ _ = False - --- A small sequent calculus proof engine. -data Clause a = Clause { - clauseAtoms :: UniqSet a, - clauseExprs :: [BooleanFormula a] - } -extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a -extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x } - -memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool -memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c - ----------------------------------------------------------------------- --- Pretty printing ----------------------------------------------------------------------- - --- Pretty print a BooleanFormula, --- using the arguments as pretty printers for Var, And and Or respectively -pprBooleanFormula' :: (Rational -> a -> SDoc) - -> (Rational -> [SDoc] -> SDoc) - -> (Rational -> [SDoc] -> SDoc) - -> Rational -> BooleanFormula a -> SDoc -pprBooleanFormula' pprVar pprAnd pprOr = go - where - go p (Var x) = pprVar p x - go p (And []) = cparen (p > 0) $ empty - go p (And xs) = pprAnd p (map (go 3 . unLoc) xs) - go _ (Or []) = keyword $ text "FALSE" - go p (Or xs) = pprOr p (map (go 2 . unLoc) xs) - go p (Parens x) = go p (unLoc x) - --- Pretty print in source syntax, "a | b | c,d,e" -pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc -pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr - where - pprAnd p = cparen (p > 3) . fsep . punctuate comma - pprOr p = cparen (p > 2) . fsep . intersperse vbar - --- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? -pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc -pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 - where - pprVar _ = quotes . ppr - pprAnd p = cparen (p > 1) . pprAnd' - pprAnd' [] = empty - pprAnd' [x,y] = x <+> text "and" <+> y - pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs - pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) - -instance (OutputableBndr a) => Outputable (BooleanFormula a) where - ppr = pprBooleanFormulaNormal - -pprBooleanFormulaNormal :: (OutputableBndr a) - => BooleanFormula a -> SDoc -pprBooleanFormulaNormal = go - where - go (Var x) = pprPrefixOcc x - go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) - go (Or []) = keyword $ text "FALSE" - go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) - go (Parens x) = parens (go $ unLoc x) - - ----------------------------------------------------------------------- --- Binary ----------------------------------------------------------------------- - -instance Binary a => Binary (BooleanFormula a) where - put_ bh (Var x) = putByte bh 0 >> put_ bh x - put_ bh (And xs) = putByte bh 1 >> put_ bh xs - put_ bh (Or xs) = putByte bh 2 >> put_ bh xs - put_ bh (Parens x) = putByte bh 3 >> put_ bh x - - get bh = do - h <- getByte bh - case h of - 0 -> Var <$> get bh - 1 -> And <$> get bh - 2 -> Or <$> get bh - _ -> Parens <$> get bh diff --git a/utils/BufWrite.hs b/utils/BufWrite.hs deleted file mode 100644 --- a/utils/BufWrite.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - ------------------------------------------------------------------------------ --- --- Fast write-buffered Handles --- --- (c) The University of Glasgow 2005-2006 --- --- This is a simple abstraction over Handles that offers very fast write --- buffering, but without the thread safety that Handles provide. It's used --- to save time in Pretty.printDoc. --- ------------------------------------------------------------------------------ - -module BufWrite ( - BufHandle(..), - newBufHandle, - bPutChar, - bPutStr, - bPutFS, - bPutFZS, - bPutLitString, - bFlush, - ) where - -import FastString -import FastMutInt - -import Control.Monad ( when ) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Unsafe as BS -import Data.Char ( ord ) -import Foreign -import Foreign.C.String -import System.IO - --- ----------------------------------------------------------------------------- - -data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) - {-#UNPACK#-}!FastMutInt - Handle - -newBufHandle :: Handle -> IO BufHandle -newBufHandle hdl = do - ptr <- mallocBytes buf_size - r <- newFastMutInt - writeFastMutInt r 0 - return (BufHandle ptr r hdl) - -buf_size :: Int -buf_size = 8192 - -bPutChar :: BufHandle -> Char -> IO () -bPutChar b@(BufHandle buf r hdl) !c = do - i <- readFastMutInt r - if (i >= buf_size) - then do hPutBuf hdl buf buf_size - writeFastMutInt r 0 - bPutChar b c - else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) - writeFastMutInt r (i+1) - -bPutStr :: BufHandle -> String -> IO () -bPutStr (BufHandle buf r hdl) !str = do - i <- readFastMutInt r - loop str i - where loop "" !i = do writeFastMutInt r i; return () - loop (c:cs) !i - | i >= buf_size = do - hPutBuf hdl buf buf_size - loop (c:cs) 0 - | otherwise = do - pokeElemOff buf i (fromIntegral (ord c)) - loop cs (i+1) - -bPutFS :: BufHandle -> FastString -> IO () -bPutFS b fs = bPutBS b $ fastStringToByteString fs - -bPutFZS :: BufHandle -> FastZString -> IO () -bPutFZS b fs = bPutBS b $ fastZStringToByteString fs - -bPutBS :: BufHandle -> ByteString -> IO () -bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b - -bPutCStringLen :: BufHandle -> CStringLen -> IO () -bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do - i <- readFastMutInt r - if (i + len) >= buf_size - then do hPutBuf hdl buf i - writeFastMutInt r 0 - if (len >= buf_size) - then hPutBuf hdl ptr len - else bPutCStringLen b cstr - else do - copyBytes (buf `plusPtr` i) ptr len - writeFastMutInt r (i + len) - -bPutLitString :: BufHandle -> LitString -> Int -> IO () -bPutLitString b@(BufHandle buf r hdl) a len = a `seq` do - i <- readFastMutInt r - if (i+len) >= buf_size - then do hPutBuf hdl buf i - writeFastMutInt r 0 - if (len >= buf_size) - then hPutBuf hdl a len - else bPutLitString b a len - else do - copyBytes (buf `plusPtr` i) a len - writeFastMutInt r (i+len) - -bFlush :: BufHandle -> IO () -bFlush (BufHandle buf r hdl) = do - i <- readFastMutInt r - when (i > 0) $ hPutBuf hdl buf i - free buf - return () diff --git a/utils/Digraph.hs b/utils/Digraph.hs deleted file mode 100644 --- a/utils/Digraph.hs +++ /dev/null @@ -1,502 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP, ScopedTypeVariables #-} - -module Digraph( - Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, - - SCC(..), Node, flattenSCC, flattenSCCs, - stronglyConnCompG, - topologicalSortG, dfsTopSortG, - verticesG, edgesG, hasVertexG, - reachableG, reachablesG, transposeG, - outdegreeG, indegreeG, - vertexGroupsG, emptyG, - componentsG, - - findCycle, - - -- For backwards compatibility with the simpler version of Digraph - stronglyConnCompFromEdgedVerticesOrd, - stronglyConnCompFromEdgedVerticesOrdR, - stronglyConnCompFromEdgedVerticesUniq, - stronglyConnCompFromEdgedVerticesUniqR, - ) where - -#include "HsVersions.h" - ------------------------------------------------------------------------------- --- A version of the graph algorithms described in: --- --- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell'' --- by David King and John Launchbury --- --- Also included is some additional code for printing tree structures ... --- --- If you ever find yourself in need of algorithms for classifying edges, --- or finding connected/biconnected components, consult the history; Sigbjorn --- Finne contributed some implementations in 1997, although we've since --- removed them since they were not used anywhere in GHC. ------------------------------------------------------------------------------- - - -import Util ( minWith, count ) -import Outputable -import Maybes ( expectJust ) -import MonadUtils ( allM ) - --- Extensions -import Control.Monad ( filterM, liftM, liftM2 ) -import Control.Monad.ST - --- std interfaces -import Data.Maybe -import Data.Array -import Data.List hiding (transpose) -import Data.Array.ST -import qualified Data.Map as Map -import qualified Data.Set as Set - -import qualified Data.Graph as G -import Data.Graph hiding (Graph, Edge, transposeG, reachable) -import Data.Tree -import Unique -import UniqFM - -{- -************************************************************************ -* * -* Graphs and Graph Construction -* * -************************************************************************ - -Note [Nodes, keys, vertices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * A 'node' is a big blob of client-stuff - - * Each 'node' has a unique (client) 'key', but the latter - is in Ord and has fast comparison - - * Digraph then maps each 'key' to a Vertex (Int) which is - arranged densely in 0.n --} - -data Graph node = Graph { - gr_int_graph :: IntGraph, - gr_vertex_to_node :: Vertex -> node, - gr_node_to_vertex :: node -> Maybe Vertex - } - -data Edge node = Edge node node - -type Node key payload = (payload, key, [key]) - -- The payload is user data, just carried around in this module - -- The keys are ordered - -- The [key] are the dependencies of the node; - -- it's ok to have extra keys in the dependencies that - -- are not the key of any Node in the graph - -emptyGraph :: Graph a -emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) - --- See Note [Deterministic SCC] -graphFromEdgedVertices - :: ReduceFn key payload - -> [Node key payload] -- The graph; its ok for the - -- out-list to contain keys which aren't - -- a vertex key, they are ignored - -> Graph (Node key payload) -graphFromEdgedVertices _reduceFn [] = emptyGraph -graphFromEdgedVertices reduceFn edged_vertices = - Graph graph vertex_fn (key_vertex . key_extractor) - where key_extractor (_, k, _) = k - (bounds, vertex_fn, key_vertex, numbered_nodes) = - reduceFn edged_vertices key_extractor - graph = array bounds [ (v, sort $ mapMaybe key_vertex ks) - | (v, (_, _, ks)) <- numbered_nodes] - -- We normalize outgoing edges by sorting on node order, so - -- that the result doesn't depend on the order of the edges - --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -graphFromEdgedVerticesOrd - :: Ord key - => [Node key payload] -- The graph; its ok for the - -- out-list to contain keys which aren't - -- a vertex key, they are ignored - -> Graph (Node key payload) -graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd - --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -graphFromEdgedVerticesUniq - :: Uniquable key - => [Node key payload] -- The graph; its ok for the - -- out-list to contain keys which aren't - -- a vertex key, they are ignored - -> Graph (Node key payload) -graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq - -type ReduceFn key payload = - [Node key payload] -> (Node key payload -> key) -> - (Bounds, Vertex -> Node key payload - , key -> Maybe Vertex, [(Vertex, Node key payload)]) - -{- -Note [reduceNodesIntoVertices implementations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -reduceNodesIntoVertices is parameterized by the container type. -This is to accomodate key types that don't have an Ord instance -and hence preclude the use of Data.Map. An example of such type -would be Unique, there's no way to implement Ord Unique -deterministically. - -For such types, there's a version with a Uniquable constraint. -This leaves us with two versions of every function that depends on -reduceNodesIntoVertices, one with Ord constraint and the other with -Uniquable constraint. -For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq. - -The Uniq version should be a tiny bit more efficient since it uses -Data.IntMap internally. --} -reduceNodesIntoVertices - :: ([(key, Vertex)] -> m) - -> (key -> m -> Maybe Vertex) - -> ReduceFn key payload -reduceNodesIntoVertices fromList lookup nodes key_extractor = - (bounds, (!) vertex_map, key_vertex, numbered_nodes) - where - max_v = length nodes - 1 - bounds = (0, max_v) :: (Vertex, Vertex) - - -- Keep the order intact to make the result depend on input order - -- instead of key order - numbered_nodes = zip [0..] nodes - vertex_map = array bounds numbered_nodes - - key_map = fromList - [ (key_extractor node, v) | (v, node) <- numbered_nodes ] - key_vertex k = lookup k key_map - --- See Note [reduceNodesIntoVertices implementations] -reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload -reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup - --- See Note [reduceNodesIntoVertices implementations] -reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload -reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM) - -{- -************************************************************************ -* * -* SCC -* * -************************************************************************ --} - -type WorkItem key payload - = (Node key payload, -- Tip of the path - [payload]) -- Rest of the path; - -- [a,b,c] means c depends on b, b depends on a - --- | Find a reasonably short cycle a->b->c->a, in a strongly --- connected component. The input nodes are presumed to be --- a SCC, so you can start anywhere. -findCycle :: forall payload key. Ord key - => [Node key payload] -- The nodes. The dependencies can - -- contain extra keys, which are ignored - -> Maybe [payload] -- A cycle, starting with node - -- so each depends on the next -findCycle graph - = go Set.empty (new_work root_deps []) [] - where - env :: Map.Map key (Node key payload) - env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ] - - -- Find the node with fewest dependencies among the SCC modules - -- This is just a heuristic to find some plausible root module - root :: Node key payload - root = fst (minWith snd [ (node, count (`Map.member` env) deps) - | node@(_,_,deps) <- graph ]) - (root_payload,root_key,root_deps) = root - - - -- 'go' implements Dijkstra's algorithm, more or less - go :: Set.Set key -- Visited - -> [WorkItem key payload] -- Work list, items length n - -> [WorkItem key payload] -- Work list, items length n+1 - -> Maybe [payload] -- Returned cycle - -- Invariant: in a call (go visited ps qs), - -- visited = union (map tail (ps ++ qs)) - - go _ [] [] = Nothing -- No cycles - go visited [] qs = go visited qs [] - go visited (((payload,key,deps), path) : ps) qs - | key == root_key = Just (root_payload : reverse path) - | key `Set.member` visited = go visited ps qs - | key `Map.notMember` env = go visited ps qs - | otherwise = go (Set.insert key visited) - ps (new_qs ++ qs) - where - new_qs = new_work deps (payload : path) - - new_work :: [key] -> [payload] -> [WorkItem key payload] - new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] - -{- -************************************************************************ -* * -* Strongly Connected Component wrappers for Graph -* * -************************************************************************ - -Note: the components are returned topologically sorted: later components -depend on earlier ones, but not vice versa i.e. later components only have -edges going from them to earlier ones. --} - -{- -Note [Deterministic SCC] -~~~~~~~~~~~~~~~~~~~~~~~~ -stronglyConnCompFromEdgedVerticesUniq, -stronglyConnCompFromEdgedVerticesUniqR, -stronglyConnCompFromEdgedVerticesOrd and -stronglyConnCompFromEdgedVerticesOrdR -provide a following guarantee: -Given a deterministically ordered list of nodes it returns a deterministically -ordered list of strongly connected components, where the list of vertices -in an SCC is also deterministically ordered. -Note that the order of edges doesn't need to be deterministic for this to work. -We use the order of nodes to normalize the order of edges. --} - -stronglyConnCompG :: Graph node -> [SCC node] -stronglyConnCompG graph = decodeSccs graph forest - where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) - -decodeSccs :: Graph node -> Forest Vertex -> [SCC node] -decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest - = map decode forest - where - decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] - | otherwise = AcyclicSCC (vertex_fn v) - decode other = CyclicSCC (dec other []) - where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts - mentions_itself v = v `elem` (graph ! v) - - --- The following two versions are provided for backwards compatibility: --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesOrd - :: Ord key - => [Node key payload] - -> [SCC payload] -stronglyConnCompFromEdgedVerticesOrd - = map (fmap get_node) . stronglyConnCompFromEdgedVerticesOrdR - where get_node (n, _, _) = n - --- The following two versions are provided for backwards compatibility: --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesUniq - :: Uniquable key - => [Node key payload] - -> [SCC payload] -stronglyConnCompFromEdgedVerticesUniq - = map (fmap get_node) . stronglyConnCompFromEdgedVerticesUniqR - where get_node (n, _, _) = n - --- The "R" interface is used when you expect to apply SCC to --- (some of) the result of SCC, so you dont want to lose the dependency info --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesOrdR - :: Ord key - => [Node key payload] - -> [SCC (Node key payload)] -stronglyConnCompFromEdgedVerticesOrdR = - stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd - --- The "R" interface is used when you expect to apply SCC to --- (some of) the result of SCC, so you dont want to lose the dependency info --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesUniqR - :: Uniquable key - => [Node key payload] - -> [SCC (Node key payload)] -stronglyConnCompFromEdgedVerticesUniqR = - stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq - -{- -************************************************************************ -* * -* Misc wrappers for Graph -* * -************************************************************************ --} - -topologicalSortG :: Graph node -> [node] -topologicalSortG graph = map (gr_vertex_to_node graph) result - where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph) - -dfsTopSortG :: Graph node -> [[node]] -dfsTopSortG graph = - map (map (gr_vertex_to_node graph) . flatten) $ dfs g (topSort g) - where - g = gr_int_graph graph - -reachableG :: Graph node -> node -> [node] -reachableG graph from = map (gr_vertex_to_node graph) result - where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from) - result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex] - -reachablesG :: Graph node -> [node] -> [node] -reachablesG graph froms = map (gr_vertex_to_node graph) result - where result = {-# SCC "Digraph.reachable" #-} - reachable (gr_int_graph graph) vs - vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] - -hasVertexG :: Graph node -> node -> Bool -hasVertexG graph node = isJust $ gr_node_to_vertex graph node - -verticesG :: Graph node -> [node] -verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph) - -edgesG :: Graph node -> [Edge node] -edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph) - where v2n = gr_vertex_to_node graph - -transposeG :: Graph node -> Graph node -transposeG graph = Graph (G.transposeG (gr_int_graph graph)) - (gr_vertex_to_node graph) - (gr_node_to_vertex graph) - -outdegreeG :: Graph node -> node -> Maybe Int -outdegreeG = degreeG outdegree - -indegreeG :: Graph node -> node -> Maybe Int -indegreeG = degreeG indegree - -degreeG :: (G.Graph -> Table Int) -> Graph node -> node -> Maybe Int -degreeG degree graph node = let table = degree (gr_int_graph graph) - in fmap ((!) table) $ gr_node_to_vertex graph node - -vertexGroupsG :: Graph node -> [[node]] -vertexGroupsG graph = map (map (gr_vertex_to_node graph)) result - where result = vertexGroups (gr_int_graph graph) - -emptyG :: Graph node -> Bool -emptyG g = graphEmpty (gr_int_graph g) - -componentsG :: Graph node -> [[node]] -componentsG graph = map (map (gr_vertex_to_node graph) . flatten) - $ components (gr_int_graph graph) - -{- -************************************************************************ -* * -* Showing Graphs -* * -************************************************************************ --} - -instance Outputable node => Outputable (Graph node) where - ppr graph = vcat [ - hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)), - hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph)) - ] - -instance Outputable node => Outputable (Edge node) where - ppr (Edge from to) = ppr from <+> text "->" <+> ppr to - -graphEmpty :: G.Graph -> Bool -graphEmpty g = lo > hi - where (lo, hi) = bounds g - -{- -************************************************************************ -* * -* IntGraphs -* * -************************************************************************ --} - -type IntGraph = G.Graph - -{- ------------------------------------------------------------- --- Depth first search numbering ------------------------------------------------------------- --} - --- Data.Tree has flatten for Tree, but nothing for Forest -preorderF :: Forest a -> [a] -preorderF ts = concat (map flatten ts) - -{- ------------------------------------------------------------- --- Finding reachable vertices ------------------------------------------------------------- --} - --- This generalizes reachable which was found in Data.Graph -reachable :: IntGraph -> [Vertex] -> [Vertex] -reachable g vs = preorderF (dfs g vs) - -{- ------------------------------------------------------------- --- Total ordering on groups of vertices ------------------------------------------------------------- - -The plan here is to extract a list of groups of elements of the graph -such that each group has no dependence except on nodes in previous -groups (i.e. in particular they may not depend on nodes in their own -group) and is maximal such group. - -Clearly we cannot provide a solution for cyclic graphs. - -We proceed by iteratively removing elements with no outgoing edges -and their associated edges from the graph. - -This probably isn't very efficient and certainly isn't very clever. --} - -type Set s = STArray s Vertex Bool - -mkEmpty :: Bounds -> ST s (Set s) -mkEmpty bnds = newArray bnds False - -contains :: Set s -> Vertex -> ST s Bool -contains m v = readArray m v - -include :: Set s -> Vertex -> ST s () -include m v = writeArray m v True - -vertexGroups :: IntGraph -> [[Vertex]] -vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices) - where next_vertices = noOutEdges g - -noOutEdges :: IntGraph -> [Vertex] -noOutEdges g = [ v | v <- vertices g, null (g!v)] - -vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]] -vertexGroupsS provided g to_provide - = if null to_provide - then do { - all_provided <- allM (provided `contains`) (vertices g) - ; if all_provided - then return [] - else error "vertexGroup: cyclic graph" - } - else do { - mapM_ (include provided) to_provide - ; to_provide' <- filterM (vertexReady provided g) (vertices g) - ; rest <- vertexGroupsS provided g to_provide' - ; return $ to_provide : rest - } - -vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool -vertexReady provided g v = liftM2 (&&) (liftM not $ provided `contains` v) (allM (provided `contains`) (g!v)) diff --git a/utils/Encoding.hs b/utils/Encoding.hs deleted file mode 100644 --- a/utils/Encoding.hs +++ /dev/null @@ -1,448 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -O #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 1997-2006 --- --- Character encodings --- --- ----------------------------------------------------------------------------- - -module Encoding ( - -- * UTF-8 - utf8DecodeChar#, - utf8PrevChar, - utf8CharStart, - utf8DecodeChar, - utf8DecodeByteString, - utf8DecodeStringLazy, - utf8EncodeChar, - utf8EncodeString, - utf8EncodedLength, - countUTF8Chars, - - -- * Z-encoding - zEncodeString, - zDecodeString, - - -- * Base62-encoding - toBase62, - toBase62Padded - ) where - -import Foreign -import Foreign.ForeignPtr.Unsafe -import Data.Char -import qualified Data.Char as Char -import Numeric -import GHC.IO - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as BS - -import GHC.Exts - --- ----------------------------------------------------------------------------- --- UTF-8 - --- We can't write the decoder as efficiently as we'd like without --- resorting to unboxed extensions, unfortunately. I tried to write --- an IO version of this function, but GHC can't eliminate boxed --- results from an IO-returning function. --- --- We assume we can ignore overflow when parsing a multibyte character here. --- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences --- before decoding them (see StringBuffer.hs). - -{-# INLINE utf8DecodeChar# #-} -utf8DecodeChar# :: Addr# -> (# Char#, Int# #) -utf8DecodeChar# a# = - let !ch0 = word2Int# (indexWord8OffAddr# a# 0#) in - case () of - _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #) - - | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) -> - let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# - (ch1 -# 0x80#)), - 2# #) - - | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) -> - let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in - if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else - (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# - ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ch2 -# 0x80#)), - 3# #) - - | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) -> - let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in - if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else - let !ch3 = word2Int# (indexWord8OffAddr# a# 3#) in - if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else - (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# - ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# - ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ch3 -# 0x80#)), - 4# #) - - | otherwise -> fail 1# - where - -- all invalid sequences end up here: - fail :: Int# -> (# Char#, Int# #) - fail nBytes# = (# '\0'#, nBytes# #) - -- '\xFFFD' would be the usual replacement character, but - -- that's a valid symbol in Haskell, so will result in a - -- confusing parse error later on. Instead we use '\0' which - -- will signal a lexer error immediately. - -utf8DecodeChar :: Ptr Word8 -> (Char, Int) -utf8DecodeChar (Ptr a#) = - case utf8DecodeChar# a# of (# c#, nBytes# #) -> ( C# c#, I# nBytes# ) - --- UTF-8 is cleverly designed so that we can always figure out where --- the start of the current character is, given any position in a --- stream. This function finds the start of the previous character, --- assuming there *is* a previous character. -utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8) -utf8PrevChar p = utf8CharStart (p `plusPtr` (-1)) - -utf8CharStart :: Ptr Word8 -> IO (Ptr Word8) -utf8CharStart p = go p - where go p = do w <- peek p - if w >= 0x80 && w < 0xC0 - then go (p `plusPtr` (-1)) - else return p - -utf8DecodeByteString :: ByteString -> [Char] -utf8DecodeByteString (BS.PS ptr offset len) - = utf8DecodeStringLazy ptr offset len - -utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char] -utf8DecodeStringLazy fptr offset len - = unsafeDupablePerformIO $ unpack start - where - !start = unsafeForeignPtrToPtr fptr `plusPtr` offset - !end = start `plusPtr` len - - unpack p - | p >= end = touchForeignPtr fptr >> return [] - | otherwise = - case utf8DecodeChar# (unPtr p) of - (# c#, nBytes# #) -> do - rest <- unsafeDupableInterleaveIO $ unpack (p `plusPtr#` nBytes#) - return (C# c# : rest) - -countUTF8Chars :: Ptr Word8 -> Int -> IO Int -countUTF8Chars ptr len = go ptr 0 - where - !end = ptr `plusPtr` len - - go p !n - | p >= end = return n - | otherwise = do - case utf8DecodeChar# (unPtr p) of - (# _, nBytes# #) -> go (p `plusPtr#` nBytes#) (n+1) - -unPtr :: Ptr a -> Addr# -unPtr (Ptr a) = a - -plusPtr# :: Ptr a -> Int# -> Ptr a -plusPtr# ptr nBytes# = ptr `plusPtr` (I# nBytes#) - -utf8EncodeChar :: Char -> Ptr Word8 -> IO (Ptr Word8) -utf8EncodeChar c ptr = - let x = ord c in - case () of - _ | x > 0 && x <= 0x007f -> do - poke ptr (fromIntegral x) - return (ptr `plusPtr` 1) - -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we - -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8). - | x <= 0x07ff -> do - poke ptr (fromIntegral (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))) - pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x .&. 0x3F))) - return (ptr `plusPtr` 2) - | x <= 0xffff -> do - poke ptr (fromIntegral (0xE0 .|. (x `shiftR` 12) .&. 0x0F)) - pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x `shiftR` 6) .&. 0x3F)) - pokeElemOff ptr 2 (fromIntegral (0x80 .|. (x .&. 0x3F))) - return (ptr `plusPtr` 3) - | otherwise -> do - poke ptr (fromIntegral (0xF0 .|. (x `shiftR` 18))) - pokeElemOff ptr 1 (fromIntegral (0x80 .|. ((x `shiftR` 12) .&. 0x3F))) - pokeElemOff ptr 2 (fromIntegral (0x80 .|. ((x `shiftR` 6) .&. 0x3F))) - pokeElemOff ptr 3 (fromIntegral (0x80 .|. (x .&. 0x3F))) - return (ptr `plusPtr` 4) - -utf8EncodeString :: Ptr Word8 -> String -> IO () -utf8EncodeString ptr str = go ptr str - where go !_ [] = return () - go ptr (c:cs) = do - ptr' <- utf8EncodeChar c ptr - go ptr' cs - -utf8EncodedLength :: String -> Int -utf8EncodedLength str = go 0 str - where go !n [] = n - go n (c:cs) - | ord c > 0 && ord c <= 0x007f = go (n+1) cs - | ord c <= 0x07ff = go (n+2) cs - | ord c <= 0xffff = go (n+3) cs - | otherwise = go (n+4) cs - --- ----------------------------------------------------------------------------- --- The Z-encoding - -{- -This is the main name-encoding and decoding function. It encodes any -string into a string that is acceptable as a C name. This is done -right before we emit a symbol name into the compiled C or asm code. -Z-encoding of strings is cached in the FastString interface, so we -never encode the same string more than once. - -The basic encoding scheme is this. - -* Tuples (,,,) are coded as Z3T - -* Alphabetic characters (upper and lower) and digits - all translate to themselves; - except 'Z', which translates to 'ZZ' - and 'z', which translates to 'zz' - We need both so that we can preserve the variable/tycon distinction - -* Most other printable characters translate to 'zx' or 'Zx' for some - alphabetic character x - -* The others translate as 'znnnU' where 'nnn' is the decimal number - of the character - - Before After - -------------------------- - Trak Trak - foo_wib foozuwib - > zg - >1 zg1 - foo# foozh - foo## foozhzh - foo##1 foozhzh1 - fooZ fooZZ - :+ ZCzp - () Z0T 0-tuple - (,,,,) Z5T 5-tuple - (# #) Z1H unboxed 1-tuple (note the space) - (#,,,,#) Z5H unboxed 5-tuple - (NB: There is no Z1T nor Z0H.) --} - -type UserString = String -- As the user typed it -type EncodedString = String -- Encoded form - - -zEncodeString :: UserString -> EncodedString -zEncodeString cs = case maybe_tuple cs of - Just n -> n -- Tuples go to Z2T etc - Nothing -> go cs - where - go [] = [] - go (c:cs) = encode_digit_ch c ++ go' cs - go' [] = [] - go' (c:cs) = encode_ch c ++ go' cs - -unencodedChar :: Char -> Bool -- True for chars that don't need encoding -unencodedChar 'Z' = False -unencodedChar 'z' = False -unencodedChar c = c >= 'a' && c <= 'z' - || c >= 'A' && c <= 'Z' - || c >= '0' && c <= '9' - --- If a digit is at the start of a symbol then we need to encode it. --- Otherwise package names like 9pH-0.1 give linker errors. -encode_digit_ch :: Char -> EncodedString -encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c -encode_digit_ch c | otherwise = encode_ch c - -encode_ch :: Char -> EncodedString -encode_ch c | unencodedChar c = [c] -- Common case first - --- Constructors -encode_ch '(' = "ZL" -- Needed for things like (,), and (->) -encode_ch ')' = "ZR" -- For symmetry with ( -encode_ch '[' = "ZM" -encode_ch ']' = "ZN" -encode_ch ':' = "ZC" -encode_ch 'Z' = "ZZ" - --- Variables -encode_ch 'z' = "zz" -encode_ch '&' = "za" -encode_ch '|' = "zb" -encode_ch '^' = "zc" -encode_ch '$' = "zd" -encode_ch '=' = "ze" -encode_ch '>' = "zg" -encode_ch '#' = "zh" -encode_ch '.' = "zi" -encode_ch '<' = "zl" -encode_ch '-' = "zm" -encode_ch '!' = "zn" -encode_ch '+' = "zp" -encode_ch '\'' = "zq" -encode_ch '\\' = "zr" -encode_ch '/' = "zs" -encode_ch '*' = "zt" -encode_ch '_' = "zu" -encode_ch '%' = "zv" -encode_ch c = encode_as_unicode_char c - -encode_as_unicode_char :: Char -> EncodedString -encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str - else '0':hex_str - where hex_str = showHex (ord c) "U" - -- ToDo: we could improve the encoding here in various ways. - -- eg. strings of unicode characters come out as 'z1234Uz5678U', we - -- could remove the 'U' in the middle (the 'z' works as a separator). - -zDecodeString :: EncodedString -> UserString -zDecodeString [] = [] -zDecodeString ('Z' : d : rest) - | isDigit d = decode_tuple d rest - | otherwise = decode_upper d : zDecodeString rest -zDecodeString ('z' : d : rest) - | isDigit d = decode_num_esc d rest - | otherwise = decode_lower d : zDecodeString rest -zDecodeString (c : rest) = c : zDecodeString rest - -decode_upper, decode_lower :: Char -> Char - -decode_upper 'L' = '(' -decode_upper 'R' = ')' -decode_upper 'M' = '[' -decode_upper 'N' = ']' -decode_upper 'C' = ':' -decode_upper 'Z' = 'Z' -decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch - -decode_lower 'z' = 'z' -decode_lower 'a' = '&' -decode_lower 'b' = '|' -decode_lower 'c' = '^' -decode_lower 'd' = '$' -decode_lower 'e' = '=' -decode_lower 'g' = '>' -decode_lower 'h' = '#' -decode_lower 'i' = '.' -decode_lower 'l' = '<' -decode_lower 'm' = '-' -decode_lower 'n' = '!' -decode_lower 'p' = '+' -decode_lower 'q' = '\'' -decode_lower 'r' = '\\' -decode_lower 's' = '/' -decode_lower 't' = '*' -decode_lower 'u' = '_' -decode_lower 'v' = '%' -decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch - --- Characters not having a specific code are coded as z224U (in hex) -decode_num_esc :: Char -> EncodedString -> UserString -decode_num_esc d rest - = go (digitToInt d) rest - where - go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest - go n ('U' : rest) = chr n : zDecodeString rest - go n other = error ("decode_num_esc: " ++ show n ++ ' ':other) - -decode_tuple :: Char -> EncodedString -> UserString -decode_tuple d rest - = go (digitToInt d) rest - where - -- NB. recurse back to zDecodeString after decoding the tuple, because - -- the tuple might be embedded in a longer name. - go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest - go 0 ('T':rest) = "()" ++ zDecodeString rest - go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest - go 1 ('H':rest) = "(# #)" ++ zDecodeString rest - go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest - go n other = error ("decode_tuple: " ++ show n ++ ' ':other) - -{- -Tuples are encoded as - Z3T or Z3H -for 3-tuples or unboxed 3-tuples respectively. No other encoding starts - Z - -* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) - There are no unboxed 0-tuples. - -* "()" is the tycon for a boxed 0-tuple. - There are no boxed 1-tuples. --} - -maybe_tuple :: UserString -> Maybe EncodedString - -maybe_tuple "(# #)" = Just("Z1H") -maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of - (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") - _ -> Nothing -maybe_tuple "()" = Just("Z0T") -maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of - (n, ')' : _) -> Just ('Z' : shows (n+1) "T") - _ -> Nothing -maybe_tuple _ = Nothing - -count_commas :: Int -> String -> (Int, String) -count_commas n (',' : cs) = count_commas (n+1) cs -count_commas n cs = (n,cs) - - -{- -************************************************************************ -* * - Base 62 -* * -************************************************************************ - -Note [Base 62 encoding 128-bit integers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instead of base-62 encoding a single 128-bit integer -(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers -(2 * ceil(10.75) characters). Luckily for us, it's the same number of -characters! --} - --------------------------------------------------------------------------- --- Base 62 - --- The base-62 code is based off of 'locators' --- ((c) Operational Dynamics Consulting, BSD3 licensed) - --- | Size of a 64-bit word when written as a base-62 string -word64Base62Len :: Int -word64Base62Len = 11 - --- | Converts a 64-bit word into a base-62 string -toBase62Padded :: Word64 -> String -toBase62Padded w = pad ++ str - where - pad = replicate len '0' - len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) - str = toBase62 w - -toBase62 :: Word64 -> String -toBase62 w = showIntAtBase 62 represent w "" - where - represent :: Int -> Char - represent x - | x < 10 = Char.chr (48 + x) - | x < 36 = Char.chr (65 + x - 10) - | x < 62 = Char.chr (97 + x - 36) - | otherwise = error "represent (base 62): impossible!" diff --git a/utils/Exception.hs b/utils/Exception.hs deleted file mode 100644 --- a/utils/Exception.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-deprecations #-} -module Exception - ( - module Control.Exception, - module Exception - ) - where - -import Control.Exception -import Control.Monad.IO.Class - -catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO = Control.Exception.catch - -handleIO :: (IOException -> IO a) -> IO a -> IO a -handleIO = flip catchIO - -tryIO :: IO a -> IO (Either IOException a) -tryIO = try - --- | A monad that can catch exceptions. A minimal definition --- requires a definition of 'gcatch'. --- --- Implementations on top of 'IO' should implement 'gmask' to --- eventually call the primitive 'Control.Exception.mask'. --- These are used for --- implementations that support asynchronous exceptions. The default --- implementations of 'gbracket' and 'gfinally' use 'gmask' --- thus rarely require overriding. --- -class MonadIO m => ExceptionMonad m where - - -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gcatch :: Exception e => m a -> (e -> m a) -> m a - - -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gmask :: ((m a -> m a) -> m b) -> m b - - -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gbracket :: m a -> (a -> m b) -> (a -> m c) -> m c - - -- | Generalised version of 'Control.Exception.finally', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gfinally :: m a -> m b -> m a - - gbracket before after thing = - gmask $ \restore -> do - a <- before - r <- restore (thing a) `gonException` after a - _ <- after a - return r - - a `gfinally` sequel = - gmask $ \restore -> do - r <- restore a `gonException` sequel - _ <- sequel - return r - -instance ExceptionMonad IO where - gcatch = Control.Exception.catch - gmask f = mask (\x -> f x) - -gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a) -gtry act = gcatch (act >>= \a -> return (Right a)) - (\e -> return (Left e)) - --- | Generalised version of 'Control.Exception.handle', allowing an arbitrary --- exception handling monad instead of just 'IO'. -ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a -ghandle = flip gcatch - --- | Always executes the first argument. If this throws an exception the --- second argument is executed and the exception is raised again. -gonException :: (ExceptionMonad m) => m a -> m b -> m a -gonException ioA cleanup = ioA `gcatch` \e -> - do _ <- cleanup - liftIO $ throwIO (e :: SomeException) - diff --git a/utils/FV.hs b/utils/FV.hs deleted file mode 100644 --- a/utils/FV.hs +++ /dev/null @@ -1,199 +0,0 @@ -{- -(c) Bartosz Nitka, Facebook 2015 - -Utilities for efficiently and deterministically computing free variables. - --} - -{-# LANGUAGE BangPatterns #-} - -module FV ( - -- * Deterministic free vars computations - FV, InterestingVarFun, - - -- * Running the computations - fvVarListVarSet, fvVarList, fvVarSet, fvDVarSet, - - -- ** Manipulating those computations - unitFV, - emptyFV, - mkFVs, - unionFV, - unionsFV, - delFV, - delFVs, - filterFV, - mapUnionFV, - ) where - -import Var -import VarSet - --- | Predicate on possible free variables: returns @True@ iff the variable is --- interesting -type InterestingVarFun = Var -> Bool - --- Note [Deterministic FV] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- When computing free variables, the order in which you get them affects --- the results of floating and specialization. If you use UniqFM to collect --- them and then turn that into a list, you get them in nondeterministic --- order as described in Note [Deterministic UniqFM] in UniqDFM. - --- A naive algorithm for free variables relies on merging sets of variables. --- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log --- factor. It's cheaper to incrementally add to a list and use a set to check --- for duplicates. -type FV = InterestingVarFun - -- Used for filtering sets as we build them - -> VarSet - -- Locally bound variables - -> ([Var], VarSet) - -- List to preserve ordering and set to check for membership, - -- so that the list doesn't have duplicates - -- For explanation of why using `VarSet` is not deterministic see - -- Note [Deterministic UniqFM] in UniqDFM. - -> ([Var], VarSet) - --- Note [FV naming conventions] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- To get the performance and determinism that FV provides, FV computations --- need to built up from smaller FV computations and then evaluated with --- one of `fvVarList`, `fvDVarSet`, `fvVarListVarSet`. That means the functions --- returning FV need to be exported. --- --- The conventions are: --- --- a) non-deterministic functions: --- * a function that returns VarSet --- e.g. `tyVarsOfType` --- b) deterministic functions: --- * a worker that returns FV --- e.g. `tyFVsOfType` --- * a function that returns [Var] --- e.g. `tyVarsOfTypeList` --- * a function that returns DVarSet --- e.g. `tyVarsOfTypeDSet` --- --- Where tyVarsOfType, tyVarsOfTypeList, tyVarsOfTypeDSet are implemented --- in terms of the worker evaluated with fvVarSet, fvVarList, fvDVarSet --- respectively. - --- | Run a free variable computation, returning a list of distinct free --- variables in deterministic order and a non-deterministic set containing --- those variables. -fvVarListVarSet :: FV -> ([Var], VarSet) -fvVarListVarSet fv = fv (const True) emptyVarSet ([], emptyVarSet) - --- | Run a free variable computation, returning a list of distinct free --- variables in deterministic order. -fvVarList :: FV -> [Var] -fvVarList = fst . fvVarListVarSet - --- | Run a free variable computation, returning a deterministic set of free --- variables. Note that this is just a wrapper around the version that --- returns a deterministic list. If you need a list you should use --- `fvVarList`. -fvDVarSet :: FV -> DVarSet -fvDVarSet = mkDVarSet . fst . fvVarListVarSet - --- | Run a free variable computation, returning a non-deterministic set of --- free variables. Don't use if the set will be later converted to a list --- and the order of that list will impact the generated code. -fvVarSet :: FV -> VarSet -fvVarSet = snd . fvVarListVarSet - --- Note [FV eta expansion] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- Let's consider an eta-reduced implementation of freeVarsOf using FV: --- --- freeVarsOf (App a b) = freeVarsOf a `unionFV` freeVarsOf b --- --- If GHC doesn't eta-expand it, after inlining unionFV we end up with --- --- freeVarsOf = \x -> --- case x of --- App a b -> \fv_cand in_scope acc -> --- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc --- --- which has to create a thunk, resulting in more allocations. --- --- On the other hand if it is eta-expanded: --- --- freeVarsOf (App a b) fv_cand in_scope acc = --- (freeVarsOf a `unionFV` freeVarsOf b) fv_cand in_scope acc --- --- after inlining unionFV we have: --- --- freeVarsOf = \x fv_cand in_scope acc -> --- case x of --- App a b -> --- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc --- --- which saves allocations. --- --- GHC when presented with knowledge about all the call sites, correctly --- eta-expands in this case. Unfortunately due to the fact that freeVarsOf gets --- exported to be composed with other functions, GHC doesn't have that --- information and has to be more conservative here. --- --- Hence functions that get exported and return FV need to be manually --- eta-expanded. See also #11146. - --- | Add a variable - when free, to the returned free variables. --- Ignores duplicates and respects the filtering function. -unitFV :: Id -> FV -unitFV var fv_cand in_scope acc@(have, haveSet) - | var `elemVarSet` in_scope = acc - | var `elemVarSet` haveSet = acc - | fv_cand var = (var:have, extendVarSet haveSet var) - | otherwise = acc -{-# INLINE unitFV #-} - --- | Return no free variables. -emptyFV :: FV -emptyFV _ _ acc = acc -{-# INLINE emptyFV #-} - --- | Union two free variable computations. -unionFV :: FV -> FV -> FV -unionFV fv1 fv2 fv_cand in_scope acc = - fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc -{-# INLINE unionFV #-} - --- | Mark the variable as not free by putting it in scope. -delFV :: Var -> FV -> FV -delFV var fv fv_cand !in_scope acc = - fv fv_cand (extendVarSet in_scope var) acc -{-# INLINE delFV #-} - --- | Mark many free variables as not free. -delFVs :: VarSet -> FV -> FV -delFVs vars fv fv_cand !in_scope acc = - fv fv_cand (in_scope `unionVarSet` vars) acc -{-# INLINE delFVs #-} - --- | Filter a free variable computation. -filterFV :: InterestingVarFun -> FV -> FV -filterFV fv_cand2 fv fv_cand1 in_scope acc = - fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc -{-# INLINE filterFV #-} - --- | Map a free variable computation over a list and union the results. -mapUnionFV :: (a -> FV) -> [a] -> FV -mapUnionFV _f [] _fv_cand _in_scope acc = acc -mapUnionFV f (a:as) fv_cand in_scope acc = - mapUnionFV f as fv_cand in_scope $! f a fv_cand in_scope $! acc -{-# INLINABLE mapUnionFV #-} - --- | Union many free variable computations. -unionsFV :: [FV] -> FV -unionsFV fvs fv_cand in_scope acc = mapUnionFV id fvs fv_cand in_scope acc -{-# INLINE unionsFV #-} - --- | Add multiple variables - when free, to the returned free variables. --- Ignores duplicates and respects the filtering function. -mkFVs :: [Var] -> FV -mkFVs vars fv_cand in_scope acc = - mapUnionFV unitFV vars fv_cand in_scope acc -{-# INLINE mkFVs #-} diff --git a/utils/FastFunctions.hs b/utils/FastFunctions.hs deleted file mode 100644 --- a/utils/FastFunctions.hs +++ /dev/null @@ -1,19 +0,0 @@ -{- -(c) The University of Glasgow, 2000-2006 --} - -{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} - -module FastFunctions ( - inlinePerformIO, - ) where - -#include "HsVersions.h" - -import GHC.Exts -import GHC.IO (IO(..)) - --- Just like unsafePerformIO, but we inline it. -{-# INLINE inlinePerformIO #-} -inlinePerformIO :: IO a -> a -inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r diff --git a/utils/FastMutInt.hs b/utils/FastMutInt.hs deleted file mode 100644 --- a/utils/FastMutInt.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -O #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected --- --- (c) The University of Glasgow 2002-2006 --- --- Unboxed mutable Ints - -module FastMutInt( - FastMutInt, newFastMutInt, - readFastMutInt, writeFastMutInt, - - FastMutPtr, newFastMutPtr, - readFastMutPtr, writeFastMutPtr - ) where - -import Data.Bits -import GHC.Base -import GHC.Ptr - -newFastMutInt :: IO FastMutInt -readFastMutInt :: FastMutInt -> IO Int -writeFastMutInt :: FastMutInt -> Int -> IO () - -newFastMutPtr :: IO FastMutPtr -readFastMutPtr :: FastMutPtr -> IO (Ptr a) -writeFastMutPtr :: FastMutPtr -> Ptr a -> IO () - -data FastMutInt = FastMutInt (MutableByteArray# RealWorld) - -newFastMutInt = IO $ \s -> - case newByteArray# size s of { (# s, arr #) -> - (# s, FastMutInt arr #) } - where !(I# size) = finiteBitSize (0 :: Int) - -readFastMutInt (FastMutInt arr) = IO $ \s -> - case readIntArray# arr 0# s of { (# s, i #) -> - (# s, I# i #) } - -writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> - case writeIntArray# arr 0# i s of { s -> - (# s, () #) } - -data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld) - -newFastMutPtr = IO $ \s -> - case newByteArray# size s of { (# s, arr #) -> - (# s, FastMutPtr arr #) } - -- GHC assumes 'sizeof (Int) == sizeof (Ptr a)' - where !(I# size) = finiteBitSize (0 :: Int) - -readFastMutPtr (FastMutPtr arr) = IO $ \s -> - case readAddrArray# arr 0# s of { (# s, i #) -> - (# s, Ptr i #) } - -writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s -> - case writeAddrArray# arr 0# i s of { s -> - (# s, () #) } diff --git a/utils/FastString.hs b/utils/FastString.hs deleted file mode 100644 --- a/utils/FastString.hs +++ /dev/null @@ -1,620 +0,0 @@ --- (c) The University of Glasgow, 1997-2006 - -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, - GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -O -funbox-strict-fields #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- | --- There are two principal string types used internally by GHC: --- --- ['FastString'] --- --- * A compact, hash-consed, representation of character strings. --- * Comparison is O(1), and you can get a 'Unique.Unique' from them. --- * Generated by 'fsLit'. --- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'. --- --- ['LitString'] --- --- * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@). --- * Practically no operations. --- * Outputing them is fast. --- * Generated by 'sLit'. --- * Turn into 'Outputable.SDoc' with 'Outputable.ptext' --- * Requires manual memory management. --- Improper use may lead to memory leaks or dangling pointers. --- * It assumes Latin-1 as the encoding, therefore it cannot represent --- arbitrary Unicode strings. --- --- Use 'LitString' unless you want the facilities of 'FastString'. -module FastString - ( - -- * ByteString - fastStringToByteString, - mkFastStringByteString, - fastZStringToByteString, - unsafeMkByteString, - hashByteString, - - -- * FastZString - FastZString, - hPutFZS, - zString, - lengthFZS, - - -- * FastStrings - FastString(..), -- not abstract, for now. - - -- ** Construction - fsLit, - mkFastString, - mkFastStringBytes, - mkFastStringByteList, - mkFastStringForeignPtr, - mkFastString#, - - -- ** Deconstruction - unpackFS, -- :: FastString -> String - bytesFS, -- :: FastString -> [Word8] - - -- ** Encoding - zEncodeFS, - - -- ** Operations - uniqueOfFS, - lengthFS, - nullFS, - appendFS, - headFS, - tailFS, - concatFS, - consFS, - nilFS, - - -- ** Outputing - hPutFS, - - -- ** Internal - getFastStringTable, - hasZEncoding, - - -- * LitStrings - LitString, - - -- ** Construction - sLit, - mkLitString#, - mkLitString, - - -- ** Deconstruction - unpackLitString, - - -- ** Operations - lengthLS - ) where - -#include "HsVersions.h" - -import Encoding -import FastFunctions -import Panic -import Util - -import Control.DeepSeq -import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Unsafe as BS -import Foreign.C -import GHC.Exts -import System.IO -import System.IO.Unsafe ( unsafePerformIO ) -import Data.Data -import Data.IORef ( IORef, newIORef, readIORef, atomicModifyIORef' ) -import Data.Maybe ( isJust ) -import Data.Char -import Data.List ( elemIndex ) - -import GHC.IO ( IO(..), unsafeDupablePerformIO ) - -import Foreign - -#if STAGE >= 2 -import GHC.Conc.Sync (sharedCAF) -#endif - -import GHC.Base ( unpackCString# ) - -#define hASH_TBL_SIZE 4091 -#define hASH_TBL_SIZE_UNBOXED 4091# - - -fastStringToByteString :: FastString -> ByteString -fastStringToByteString f = fs_bs f - -fastZStringToByteString :: FastZString -> ByteString -fastZStringToByteString (FastZString bs) = bs - --- This will drop information if any character > '\xFF' -unsafeMkByteString :: String -> ByteString -unsafeMkByteString = BSC.pack - -hashByteString :: ByteString -> Int -hashByteString bs - = inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - return $ hashStr (castPtr ptr) len - --- ----------------------------------------------------------------------------- - -newtype FastZString = FastZString ByteString - deriving NFData - -hPutFZS :: Handle -> FastZString -> IO () -hPutFZS handle (FastZString bs) = BS.hPut handle bs - -zString :: FastZString -> String -zString (FastZString bs) = - inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen - -lengthFZS :: FastZString -> Int -lengthFZS (FastZString bs) = BS.length bs - -mkFastZStringString :: String -> FastZString -mkFastZStringString str = FastZString (BSC.pack str) - --- ----------------------------------------------------------------------------- - -{-| -A 'FastString' is an array of bytes, hashed to support fast O(1) -comparison. It is also associated with a character encoding, so that -we know how to convert a 'FastString' to the local encoding, or to the -Z-encoding used by the compiler internally. - -'FastString's support a memoized conversion to the Z-encoding via zEncodeFS. --} - -data FastString = FastString { - uniq :: {-# UNPACK #-} !Int, -- unique id - n_chars :: {-# UNPACK #-} !Int, -- number of chars - fs_bs :: {-# UNPACK #-} !ByteString, - fs_ref :: {-# UNPACK #-} !(IORef (Maybe FastZString)) - } - -instance Eq FastString where - f1 == f2 = uniq f1 == uniq f2 - -instance Ord FastString where - -- Compares lexicographically, not by unique - a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } - a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } - a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } - a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } - max x y | x >= y = x - | otherwise = y - min x y | x <= y = x - | otherwise = y - compare a b = cmpFS a b - -instance IsString FastString where - fromString = fsLit - -instance Monoid FastString where - mempty = nilFS - mappend = appendFS - mconcat = concatFS - -instance Show FastString where - show fs = show (unpackFS fs) - -instance Data FastString where - -- don't traverse? - toConstr _ = abstractConstr "FastString" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "FastString" - -cmpFS :: FastString -> FastString -> Ordering -cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) = - if u1 == u2 then EQ else - compare (fastStringToByteString f1) (fastStringToByteString f2) - -foreign import ccall unsafe "ghc_memcmp" - memcmp :: Ptr a -> Ptr b -> Int -> IO Int - --- ----------------------------------------------------------------------------- --- Construction - -{- -Internally, the compiler will maintain a fast string symbol table, providing -sharing and fast comparison. Creation of new @FastString@s then covertly does a -lookup, re-using the @FastString@ if there was a hit. - -The design of the FastString hash table allows for lockless concurrent reads -and updates to multiple buckets with low synchronization overhead. - -See Note [Updating the FastString table] on how it's updated. --} -data FastStringTable = - FastStringTable - {-# UNPACK #-} !(IORef Int) -- the unique ID counter shared with all buckets - (MutableArray# RealWorld (IORef [FastString])) -- the array of mutable buckets - -string_table :: FastStringTable -{-# NOINLINE string_table #-} -string_table = unsafePerformIO $ do - uid <- newIORef 603979776 -- ord '$' * 0x01000000 - tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED (panic "string_table") s1# of - (# s2#, arr# #) -> - (# s2#, FastStringTable uid arr# #) - forM_ [0.. hASH_TBL_SIZE-1] $ \i -> do - bucket <- newIORef [] - updTbl tab i bucket - - -- use the support wired into the RTS to share this CAF among all images of - -- libHSghc -#if STAGE < 2 - return tab -#else - sharedCAF tab getOrSetLibHSghcFastStringTable - --- from the RTS; thus we cannot use this mechanism when STAGE<2; the previous --- RTS might not have this symbol -foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" - getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) -#endif - -{- - -We include the FastString table in the `sharedCAF` mechanism because we'd like -FastStrings created by a Core plugin to have the same uniques as corresponding -strings created by the host compiler itself. For example, this allows plugins -to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or -even re-invoke the parser. - -In particular, the following little sanity test was failing in a plugin -prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not -be looked up /by the plugin/. - - let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" - putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts - -`mkTcOcc` involves the lookup (or creation) of a FastString. Since the -plugin's FastString.string_table is empty, constructing the RdrName also -allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These -uniques are almost certainly unequal to the ones that the host compiler -originally assigned to those FastStrings. Thus the lookup fails since the -domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's -unique. - -Maintaining synchronization of the two instances of this global is rather -difficult because of the uses of `unsafePerformIO` in this module. Not -synchronizing them risks breaking the rather major invariant that two -FastStrings with the same unique have the same string. Thus we use the -lower-level `sharedCAF` mechanism that relies on Globals.c. - --} - -lookupTbl :: FastStringTable -> Int -> IO (IORef [FastString]) -lookupTbl (FastStringTable _ arr#) (I# i#) = - IO $ \ s# -> readArray# arr# i# s# - -updTbl :: FastStringTable -> Int -> IORef [FastString] -> IO () -updTbl (FastStringTable _uid arr#) (I# i#) ls = do - (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) }) - -mkFastString# :: Addr# -> FastString -mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) - where ptr = Ptr a# - -{- Note [Updating the FastString table] - -The procedure goes like this: - -1. Read the relevant bucket and perform a look up of the string. -2. If it exists, return it. -3. Otherwise grab a unique ID, create a new FastString and atomically attempt - to update the relevant bucket with this FastString: - - * Double check that the string is not in the bucket. Another thread may have - inserted it while we were creating our string. - * Return the existing FastString if it exists. The one we preemptively - created will get GCed. - * Otherwise, insert and return the string we created. --} - -{- Note [Double-checking the bucket] - -It is not necessary to check the entire bucket the second time. We only have to -check the strings that are new to the bucket since the last time we read it. --} - -mkFastStringWith :: (Int -> IO FastString) -> Ptr Word8 -> Int -> IO FastString -mkFastStringWith mk_fs !ptr !len = do - let hash = hashStr ptr len - bucket <- lookupTbl string_table hash - ls1 <- readIORef bucket - res <- bucket_match ls1 len ptr - case res of - Just v -> return v - Nothing -> do - n <- get_uid - new_fs <- mk_fs n - - atomicModifyIORef' bucket $ \ls2 -> - -- Note [Double-checking the bucket] - let delta_ls = case ls1 of - [] -> ls2 - l:_ -> case l `elemIndex` ls2 of - Nothing -> panic "mkFastStringWith" - Just idx -> take idx ls2 - - -- NB: Might as well use inlinePerformIO, since the call to - -- bucket_match doesn't perform any IO that could be floated - -- out of this closure or erroneously duplicated. - in case inlinePerformIO (bucket_match delta_ls len ptr) of - Nothing -> (new_fs:ls2, new_fs) - Just fs -> (ls2,fs) - where - !(FastStringTable uid _arr) = string_table - - get_uid = atomicModifyIORef' uid $ \n -> (n+1,n) - -mkFastStringBytes :: Ptr Word8 -> Int -> FastString -mkFastStringBytes !ptr !len = - -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is - -- idempotent. - unsafeDupablePerformIO $ - mkFastStringWith (copyNewFastString ptr len) ptr len - --- | Create a 'FastString' from an existing 'ForeignPtr'; the difference --- between this and 'mkFastStringBytes' is that we don't have to copy --- the bytes if the string is new to the table. -mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString -mkFastStringForeignPtr ptr !fp len - = mkFastStringWith (mkNewFastString fp ptr len) ptr len - --- | Create a 'FastString' from an existing 'ForeignPtr'; the difference --- between this and 'mkFastStringBytes' is that we don't have to copy --- the bytes if the string is new to the table. -mkFastStringByteString :: ByteString -> FastString -mkFastStringByteString bs = - inlinePerformIO $ - BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do - let ptr' = castPtr ptr - mkFastStringWith (mkNewFastStringByteString bs ptr' len) ptr' len - --- | Creates a UTF-8 encoded 'FastString' from a 'String' -mkFastString :: String -> FastString -mkFastString str = - inlinePerformIO $ do - let l = utf8EncodedLength str - buf <- mallocForeignPtrBytes l - withForeignPtr buf $ \ptr -> do - utf8EncodeString ptr str - mkFastStringForeignPtr ptr buf l - --- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ -mkFastStringByteList :: [Word8] -> FastString -mkFastStringByteList str = - inlinePerformIO $ do - let l = Prelude.length str - buf <- mallocForeignPtrBytes l - withForeignPtr buf $ \ptr -> do - pokeArray (castPtr ptr) str - mkFastStringForeignPtr ptr buf l - --- | Creates a Z-encoded 'FastString' from a 'String' -mkZFastString :: String -> FastZString -mkZFastString = mkFastZStringString - -bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString) -bucket_match [] _ _ = return Nothing -bucket_match (v@(FastString _ _ bs _):ls) len ptr - | len == BS.length bs = do - b <- BS.unsafeUseAsCString bs $ \buf -> - cmpStringPrefix ptr (castPtr buf) len - if b then return (Just v) - else bucket_match ls len ptr - | otherwise = - bucket_match ls len ptr - -mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int - -> IO FastString -mkNewFastString fp ptr len uid = do - ref <- newIORef Nothing - n_chars <- countUTF8Chars ptr len - return (FastString uid n_chars (BS.fromForeignPtr fp 0 len) ref) - -mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int - -> IO FastString -mkNewFastStringByteString bs ptr len uid = do - ref <- newIORef Nothing - n_chars <- countUTF8Chars ptr len - return (FastString uid n_chars bs ref) - -copyNewFastString :: Ptr Word8 -> Int -> Int -> IO FastString -copyNewFastString ptr len uid = do - fp <- copyBytesToForeignPtr ptr len - ref <- newIORef Nothing - n_chars <- countUTF8Chars ptr len - return (FastString uid n_chars (BS.fromForeignPtr fp 0 len) ref) - -copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8) -copyBytesToForeignPtr ptr len = do - fp <- mallocForeignPtrBytes len - withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len - return fp - -cmpStringPrefix :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool -cmpStringPrefix ptr1 ptr2 len = - do r <- memcmp ptr1 ptr2 len - return (r == 0) - - -hashStr :: Ptr Word8 -> Int -> Int - -- use the Addr to produce a hash value between 0 & m (inclusive) -hashStr (Ptr a#) (I# len#) = loop 0# 0# - where - loop h n | isTrue# (n ==# len#) = I# h - | otherwise = loop h2 (n +# 1#) - where !c = ord# (indexCharOffAddr# a# n) - !h2 = (c +# (h *# 128#)) `remInt#` - hASH_TBL_SIZE# - --- ----------------------------------------------------------------------------- --- Operations - --- | Returns the length of the 'FastString' in characters -lengthFS :: FastString -> Int -lengthFS f = n_chars f - --- | Returns @True@ if this 'FastString' is not Z-encoded but already has --- a Z-encoding cached (used in producing stats). -hasZEncoding :: FastString -> Bool -hasZEncoding (FastString _ _ _ ref) = - inlinePerformIO $ do - m <- readIORef ref - return (isJust m) - --- | Returns @True@ if the 'FastString' is empty -nullFS :: FastString -> Bool -nullFS f = BS.null (fs_bs f) - --- | Unpacks and decodes the FastString -unpackFS :: FastString -> String -unpackFS (FastString _ _ bs _) = utf8DecodeByteString bs - --- | Gives the UTF-8 encoded bytes corresponding to a 'FastString' -bytesFS :: FastString -> [Word8] -bytesFS fs = BS.unpack $ fastStringToByteString fs - --- | Returns a Z-encoded version of a 'FastString'. This might be the --- original, if it was already Z-encoded. The first time this --- function is applied to a particular 'FastString', the results are --- memoized. --- -zEncodeFS :: FastString -> FastZString -zEncodeFS fs@(FastString _ _ _ ref) = - inlinePerformIO $ do - m <- readIORef ref - case m of - Just zfs -> return zfs - Nothing -> do - atomicModifyIORef' ref $ \m' -> case m' of - Nothing -> let zfs = mkZFastString (zEncodeString (unpackFS fs)) - in (Just zfs, zfs) - Just zfs -> (m', zfs) - -appendFS :: FastString -> FastString -> FastString -appendFS fs1 fs2 = mkFastStringByteString - $ BS.append (fastStringToByteString fs1) - (fastStringToByteString fs2) - -concatFS :: [FastString] -> FastString -concatFS = mkFastStringByteString . BS.concat . map fs_bs - -headFS :: FastString -> Char -headFS (FastString _ 0 _ _) = panic "headFS: Empty FastString" -headFS (FastString _ _ bs _) = - inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> - return (fst (utf8DecodeChar (castPtr ptr))) - -tailFS :: FastString -> FastString -tailFS (FastString _ 0 _ _) = panic "tailFS: Empty FastString" -tailFS (FastString _ _ bs _) = - inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> - do let (_, n) = utf8DecodeChar (castPtr ptr) - return $! mkFastStringByteString (BS.drop n bs) - -consFS :: Char -> FastString -> FastString -consFS c fs = mkFastString (c : unpackFS fs) - -uniqueOfFS :: FastString -> Int -uniqueOfFS (FastString u _ _ _) = u - -nilFS :: FastString -nilFS = mkFastString "" - --- ----------------------------------------------------------------------------- --- Stats - -getFastStringTable :: IO [[FastString]] -getFastStringTable = do - buckets <- forM [0.. hASH_TBL_SIZE-1] $ \idx -> do - bucket <- lookupTbl string_table idx - readIORef bucket - return buckets - --- ----------------------------------------------------------------------------- --- Outputting 'FastString's - --- |Outputs a 'FastString' with /no decoding at all/, that is, you --- get the actual bytes in the 'FastString' written to the 'Handle'. -hPutFS :: Handle -> FastString -> IO () -hPutFS handle fs = BS.hPut handle $ fastStringToByteString fs - --- ToDo: we'll probably want an hPutFSLocal, or something, to output --- in the current locale's encoding (for error messages and suchlike). - --- ----------------------------------------------------------------------------- --- LitStrings, here for convenience only. - --- | A 'LitString' is a pointer to some null-terminated array of bytes. -type LitString = Ptr Word8 ---Why do we recalculate length every time it's requested? ---If it's commonly needed, we should perhaps have ---data LitString = LitString {-#UNPACK#-}!Addr# {-#UNPACK#-}!Int# - --- | Wrap an unboxed address into a 'LitString'. -mkLitString# :: Addr# -> LitString -mkLitString# a# = Ptr a# - --- | Encode a 'String' into a newly allocated 'LitString' using Latin-1 --- encoding. The original string must not contain non-Latin-1 characters --- (above codepoint @0xff@). -{-# INLINE mkLitString #-} -mkLitString :: String -> LitString -mkLitString s = - unsafePerformIO (do - p <- mallocBytes (length s + 1) - let - loop :: Int -> String -> IO () - loop !n [] = pokeByteOff p n (0 :: Word8) - loop n (c:cs) = do - pokeByteOff p n (fromIntegral (ord c) :: Word8) - loop (1+n) cs - loop 0 s - return p - ) - --- | Decode a 'LitString' back into a 'String' using Latin-1 encoding. --- This does not free the memory associated with 'LitString'. -unpackLitString :: LitString -> String -unpackLitString (Ptr p) = unpackCString# p - --- | Compute the length of a 'LitString', which must necessarily be --- null-terminated. -lengthLS :: LitString -> Int -lengthLS = ptrStrLength - --- ----------------------------------------------------------------------------- --- under the carpet - -foreign import ccall unsafe "ghc_strlen" - ptrStrLength :: Ptr Word8 -> Int - -{-# NOINLINE sLit #-} -sLit :: String -> LitString -sLit x = mkLitString x - -{-# NOINLINE fsLit #-} -fsLit :: String -> FastString -fsLit x = mkFastString x - -{-# RULES "slit" - forall x . sLit (unpackCString# x) = mkLitString# x #-} -{-# RULES "fslit" - forall x . fsLit (unpackCString# x) = mkFastString# x #-} diff --git a/utils/FastStringEnv.hs b/utils/FastStringEnv.hs deleted file mode 100644 --- a/utils/FastStringEnv.hs +++ /dev/null @@ -1,98 +0,0 @@ -{- -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[FastStringEnv]{@FastStringEnv@: FastString environments} --} - -module FastStringEnv ( - -- * FastString environments (maps) - FastStringEnv, - - -- ** Manipulating these environments - mkFsEnv, - emptyFsEnv, unitFsEnv, - extendFsEnv_C, extendFsEnv_Acc, extendFsEnv, - extendFsEnvList, extendFsEnvList_C, - filterFsEnv, - plusFsEnv, plusFsEnv_C, alterFsEnv, - lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv, - elemFsEnv, mapFsEnv, - - -- * Deterministic FastString environments (maps) - DFastStringEnv, - - -- ** Manipulating these environments - mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv - ) where - -import UniqFM -import UniqDFM -import Maybes -import FastString - - --- | A non-deterministic set of FastStrings. --- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not --- deterministic and why it matters. Use DFastStringEnv if the set eventually --- gets converted into a list or folded over in a way where the order --- changes the generated code. -type FastStringEnv a = UniqFM a -- Domain is FastString - -emptyFsEnv :: FastStringEnv a -mkFsEnv :: [(FastString,a)] -> FastStringEnv a -alterFsEnv :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a -extendFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a -extendFsEnv_Acc :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b -extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a -plusFsEnv :: FastStringEnv a -> FastStringEnv a -> FastStringEnv a -plusFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastStringEnv a -> FastStringEnv a -extendFsEnvList :: FastStringEnv a -> [(FastString,a)] -> FastStringEnv a -extendFsEnvList_C :: (a->a->a) -> FastStringEnv a -> [(FastString,a)] -> FastStringEnv a -delFromFsEnv :: FastStringEnv a -> FastString -> FastStringEnv a -delListFromFsEnv :: FastStringEnv a -> [FastString] -> FastStringEnv a -elemFsEnv :: FastString -> FastStringEnv a -> Bool -unitFsEnv :: FastString -> a -> FastStringEnv a -lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a -lookupFsEnv_NF :: FastStringEnv a -> FastString -> a -filterFsEnv :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt -mapFsEnv :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 - -emptyFsEnv = emptyUFM -unitFsEnv x y = unitUFM x y -extendFsEnv x y z = addToUFM x y z -extendFsEnvList x l = addListToUFM x l -lookupFsEnv x y = lookupUFM x y -alterFsEnv = alterUFM -mkFsEnv l = listToUFM l -elemFsEnv x y = elemUFM x y -plusFsEnv x y = plusUFM x y -plusFsEnv_C f x y = plusUFM_C f x y -extendFsEnv_C f x y z = addToUFM_C f x y z -mapFsEnv f x = mapUFM f x -extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b -extendFsEnvList_C x y z = addListToUFM_C x y z -delFromFsEnv x y = delFromUFM x y -delListFromFsEnv x y = delListFromUFM x y -filterFsEnv x y = filterUFM x y - -lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n) - --- Deterministic FastStringEnv --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DFastStringEnv. - -type DFastStringEnv a = UniqDFM a -- Domain is FastString - -emptyDFsEnv :: DFastStringEnv a -emptyDFsEnv = emptyUDFM - -dFsEnvElts :: DFastStringEnv a -> [a] -dFsEnvElts = eltsUDFM - -mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a -mkDFsEnv l = listToUDFM l - -lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a -lookupDFsEnv = lookupUDFM diff --git a/utils/Fingerprint.hsc b/utils/Fingerprint.hsc deleted file mode 100644 --- a/utils/Fingerprint.hsc +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE CPP #-} - --- ---------------------------------------------------------------------------- --- --- (c) The University of Glasgow 2006 --- --- Fingerprints for recompilation checking and ABI versioning. --- --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance --- --- ---------------------------------------------------------------------------- - -module Fingerprint ( - readHexFingerprint, - fingerprintByteString, - -- * Re-exported from GHC.Fingerprint - Fingerprint(..), fingerprint0, - fingerprintFingerprints, - fingerprintData, - fingerprintString, - getFileHash - ) where - -#include "md5.h" -##include "HsVersions.h" - -import Foreign -import GHC.IO -import Numeric ( readHex ) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS - -import GHC.Fingerprint - --- useful for parsing the output of 'md5sum', should we want to do that. -readHexFingerprint :: String -> Fingerprint -readHexFingerprint s = Fingerprint w1 w2 - where (s1,s2) = splitAt 16 s - [(w1,"")] = readHex s1 - [(w2,"")] = readHex (take 16 s2) - --- this can move to GHC.Fingerprint in GHC 8.6 -fingerprintByteString :: BS.ByteString -> Fingerprint -fingerprintByteString bs = unsafeDupablePerformIO $ - BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len diff --git a/utils/FiniteMap.hs b/utils/FiniteMap.hs deleted file mode 100644 --- a/utils/FiniteMap.hs +++ /dev/null @@ -1,29 +0,0 @@ --- Some extra functions to extend Data.Map - -module FiniteMap ( - insertList, - insertListWith, - deleteList, - foldRight, foldRightWithKey - ) where - -import Data.Map (Map) -import qualified Data.Map as Map - -insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt -insertList xs m = foldl (\m (k, v) -> Map.insert k v m) m xs - -insertListWith :: Ord key - => (elt -> elt -> elt) - -> [(key,elt)] - -> Map key elt - -> Map key elt -insertListWith f xs m0 = foldl (\m (k, v) -> Map.insertWith f k v m) m0 xs - -deleteList :: Ord key => [key] -> Map key elt -> Map key elt -deleteList ks m = foldl (flip Map.delete) m ks - -foldRight :: (elt -> a -> a) -> a -> Map key elt -> a -foldRight = Map.foldr -foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a -foldRightWithKey = Map.foldrWithKey diff --git a/utils/GraphBase.hs b/utils/GraphBase.hs deleted file mode 100644 --- a/utils/GraphBase.hs +++ /dev/null @@ -1,105 +0,0 @@ - --- | Types for the general graph colorer. -module GraphBase ( - Triv, - Graph (..), - initGraph, - graphMapModify, - - Node (..), newNode, -) - - -where - -import UniqSet -import UniqFM - - --- | A fn to check if a node is trivially colorable --- For graphs who's color classes are disjoint then a node is 'trivially colorable' --- when it has less neighbors and exclusions than available colors for that node. --- --- For graph's who's color classes overlap, ie some colors alias other colors, then --- this can be a bit more tricky. There is a general way to calculate this, but --- it's likely be too slow for use in the code. The coloring algorithm takes --- a canned function which can be optimised by the user to be specific to the --- specific graph being colored. --- --- for details, see "A Generalised Algorithm for Graph-Coloring Register Allocation" --- Smith, Ramsey, Holloway - PLDI 2004. --- -type Triv k cls color - = cls -- the class of the node we're trying to color. - -> UniqSet k -- the node's neighbors. - -> UniqSet color -- the node's exclusions. - -> Bool - - --- | The Interference graph. --- There used to be more fields, but they were turfed out in a previous revision. --- maybe we'll want more later.. --- -data Graph k cls color - = Graph { - -- | All active nodes in the graph. - graphMap :: UniqFM (Node k cls color) } - - --- | An empty graph. -initGraph :: Graph k cls color -initGraph - = Graph - { graphMap = emptyUFM } - - --- | Modify the finite map holding the nodes in the graph. -graphMapModify - :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color)) - -> Graph k cls color -> Graph k cls color - -graphMapModify f graph - = graph { graphMap = f (graphMap graph) } - - - --- | Graph nodes. --- Represents a thing that can conflict with another thing. --- For the register allocater the nodes represent registers. --- -data Node k cls color - = Node { - -- | A unique identifier for this node. - nodeId :: k - - -- | The class of this node, - -- determines the set of colors that can be used. - , nodeClass :: cls - - -- | The color of this node, if any. - , nodeColor :: Maybe color - - -- | Neighbors which must be colored differently to this node. - , nodeConflicts :: UniqSet k - - -- | Colors that cannot be used by this node. - , nodeExclusions :: UniqSet color - - -- | Colors that this node would prefer to be, in decending order. - , nodePreference :: [color] - - -- | Neighbors that this node would like to be colored the same as. - , nodeCoalesce :: UniqSet k } - - --- | An empty node. -newNode :: k -> cls -> Node k cls color -newNode k cls - = Node - { nodeId = k - , nodeClass = cls - , nodeColor = Nothing - , nodeConflicts = emptyUniqSet - , nodeExclusions = emptyUniqSet - , nodePreference = [] - , nodeCoalesce = emptyUniqSet } diff --git a/utils/GraphColor.hs b/utils/GraphColor.hs deleted file mode 100644 --- a/utils/GraphColor.hs +++ /dev/null @@ -1,371 +0,0 @@ --- | Graph Coloring. --- This is a generic graph coloring library, abstracted over the type of --- the node keys, nodes and colors. --- - -module GraphColor ( - module GraphBase, - module GraphOps, - module GraphPpr, - colorGraph -) - -where - -import GraphBase -import GraphOps -import GraphPpr - -import Unique -import UniqFM -import UniqSet -import Outputable - -import Data.Maybe -import Data.List - - --- | Try to color a graph with this set of colors. --- Uses Chaitin's algorithm to color the graph. --- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes --- are pushed onto a stack and removed from the graph. --- Once this process is complete the graph can be colored by removing nodes from --- the stack (ie in reverse order) and assigning them colors different to their neighbors. --- -colorGraph - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq cls, Ord k - , Outputable k, Outputable cls, Outputable color) - => Bool -- ^ whether to do iterative coalescing - -> Int -- ^ how many times we've tried to color this graph so far. - -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to color. - - -> ( Graph k cls color -- the colored graph. - , UniqSet k -- the set of nodes that we couldn't find a color for. - , UniqFM k ) -- map of regs (r1 -> r2) that were coalesced - -- r1 should be replaced by r2 in the source - -colorGraph iterative spinCount colors triv spill graph0 - = let - -- If we're not doing iterative coalescing then do an aggressive coalescing first time - -- around and then conservative coalescing for subsequent passes. - -- - -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if - -- there is a lot of register pressure and we do it on every round then it can make the - -- graph less colorable and prevent the algorithm from converging in a sensible number - -- of cycles. - -- - (graph_coalesced, kksCoalesce1) - = if iterative - then (graph0, []) - else if spinCount == 0 - then coalesceGraph True triv graph0 - else coalesceGraph False triv graph0 - - -- run the scanner to slurp out all the trivially colorable nodes - -- (and do coalescing if iterative coalescing is enabled) - (ksTriv, ksProblems, kksCoalesce2) - = colorScan iterative triv spill graph_coalesced - - -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. - -- We need to apply all the coalescences found by the scanner to the original - -- graph before doing assignColors. - -- - -- Because we've got the whole, non-pruned graph here we turn on aggressive coalecing - -- to force all the (conservative) coalescences found during scanning. - -- - (graph_scan_coalesced, _) - = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 - - -- color the trivially colorable nodes - -- during scanning, keys of triv nodes were added to the front of the list as they were found - -- this colors them in the reverse order, as required by the algorithm. - (graph_triv, ksNoTriv) - = assignColors colors graph_scan_coalesced ksTriv - - -- try and color the problem nodes - -- problem nodes are the ones that were left uncolored because they weren't triv. - -- theres a change we can color them here anyway. - (graph_prob, ksNoColor) - = assignColors colors graph_triv ksProblems - - -- if the trivially colorable nodes didn't color then something is probably wrong - -- with the provided triv function. - -- - in if not $ null ksNoTriv - then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty - ( empty - $$ text "ksTriv = " <> ppr ksTriv - $$ text "ksNoTriv = " <> ppr ksNoTriv - $$ text "colors = " <> ppr colors - $$ empty - $$ dotGraph (\_ -> text "white") triv graph_triv) - - else ( graph_prob - , mkUniqSet ksNoColor -- the nodes that didn't color (spills) - , if iterative - then (listToUFM kksCoalesce2) - else (listToUFM kksCoalesce1)) - - --- | Scan through the conflict graph separating out trivially colorable and --- potentially uncolorable (problem) nodes. --- --- Checking whether a node is trivially colorable or not is a resonably expensive operation, --- so after a triv node is found and removed from the graph it's no good to return to the 'start' --- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. --- --- To ward against this, during each pass through the graph we collect up a list of triv nodes --- that were found, and only remove them once we've finished the pass. The more nodes we can delete --- at once the more likely it is that nodes we've already checked will become trivially colorable --- for the next pass. --- --- TODO: add work lists to finding triv nodes is easier. --- If we've just scanned the graph, and removed triv nodes, then the only --- nodes that we need to rescan are the ones we've removed edges from. - -colorScan - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool -- ^ whether to do iterative coalescing - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to scan - - -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce - -colorScan iterative triv spill graph - = colorScan_spin iterative triv spill graph [] [] [] - -colorScan_spin - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool - -> Triv k cls color - -> (Graph k cls color -> k) - -> Graph k cls color - -> [k] - -> [k] - -> [(k, k)] - -> ([k], [k], [(k, k)]) - -colorScan_spin iterative triv spill graph - ksTriv ksSpill kksCoalesce - - -- if the graph is empty then we're done - | isNullUFM $ graphMap graph - = (ksTriv, ksSpill, reverse kksCoalesce) - - -- Simplify: - -- Look for trivially colorable nodes. - -- If we can find some then remove them from the graph and go back for more. - -- - | nsTrivFound@(_:_) - <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - - -- for iterative coalescing we only want non-move related - -- nodes here - && (not iterative || isEmptyUniqSet (nodeCoalesce node))) - $ graph - - , ksTrivFound <- map nodeId nsTrivFound - , graph2 <- foldr (\k g -> let Just g' = delNode k g - in g') - graph ksTrivFound - - = colorScan_spin iterative triv spill graph2 - (ksTrivFound ++ ksTriv) - ksSpill - kksCoalesce - - -- Coalesce: - -- If we're doing iterative coalescing and no triv nodes are available - -- then it's time for a coalescing pass. - | iterative - = case coalesceGraph False triv graph of - - -- we were able to coalesce something - -- go back to Simplify and see if this frees up more nodes to be trivially colorable. - (graph2, kksCoalesceFound @(_:_)) - -> colorScan_spin iterative triv spill graph2 - ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) - - -- Freeze: - -- nothing could be coalesced (or was triv), - -- time to choose a node to freeze and give up on ever coalescing it. - (graph2, []) - -> case freezeOneInGraph graph2 of - - -- we were able to freeze something - -- hopefully this will free up something for Simplify - (graph3, True) - -> colorScan_spin iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- we couldn't find something to freeze either - -- time for a spill - (graph3, False) - -> colorScan_spill iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- spill time - | otherwise - = colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce - - --- Select: --- we couldn't find any triv nodes or things to freeze or coalesce, --- and the graph isn't empty yet.. We'll have to choose a spill --- candidate and leave it uncolored. --- -colorScan_spill - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool - -> Triv k cls color - -> (Graph k cls color -> k) - -> Graph k cls color - -> [k] - -> [k] - -> [(k, k)] - -> ([k], [k], [(k, k)]) - -colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce - - = let kSpill = spill graph - Just graph' = delNode kSpill graph - in colorScan_spin iterative triv spill graph' - ksTriv (kSpill : ksSpill) kksCoalesce - - --- | Try to assign a color to all these nodes. - -assignColors - :: ( Uniquable k, Uniquable cls, Uniquable color - , Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> [k] -- ^ nodes to assign a color to. - -> ( Graph k cls color -- the colored graph - , [k]) -- the nodes that didn't color. - -assignColors colors graph ks - = assignColors' colors graph [] ks - - where assignColors' _ graph prob [] - = (graph, prob) - - assignColors' colors graph prob (k:ks) - = case assignColor colors k graph of - - -- couldn't color this node - Nothing -> assignColors' colors graph (k : prob) ks - - -- this node colored ok, so do the rest - Just graph' -> assignColors' colors graph' prob ks - - - assignColor colors u graph - | Just c <- selectColor colors graph u - = Just (setColor u c graph) - - | otherwise - = Nothing - - - --- | Select a color for a certain node --- taking into account preferences, neighbors and exclusions. --- returns Nothing if no color can be assigned to this node. --- -selectColor - :: ( Uniquable k, Uniquable cls, Uniquable color - , Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> k -- ^ key of the node to select a color for. - -> Maybe color - -selectColor colors graph u - = let -- lookup the node - Just node = lookupNode graph u - - -- lookup the available colors for the class of this node. - colors_avail - = case lookupUFM colors (nodeClass node) of - Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) - Just cs -> cs - - -- find colors we can't use because they're already being used - -- by a node that conflicts with this one. - Just nsConflicts - = sequence - $ map (lookupNode graph) - $ nonDetEltsUniqSet - $ nodeConflicts node - -- See Note [Unique Determinism and code generation] - - colors_conflict = mkUniqSet - $ catMaybes - $ map nodeColor nsConflicts - - -- the prefs of our neighbors - colors_neighbor_prefs - = mkUniqSet - $ concat $ map nodePreference nsConflicts - - -- colors that are still valid for us - colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) - colors_ok = minusUniqSet colors_ok_ex colors_conflict - - -- the colors that we prefer, and are still ok - colors_ok_pref = intersectUniqSets - (mkUniqSet $ nodePreference node) colors_ok - - -- the colors that we could choose while being nice to our neighbors - colors_ok_nice = minusUniqSet - colors_ok colors_neighbor_prefs - - -- the best of all possible worlds.. - colors_ok_pref_nice - = intersectUniqSets - colors_ok_nice colors_ok_pref - - -- make the decision - chooseColor - - -- everyone is happy, yay! - | not $ isEmptyUniqSet colors_ok_pref_nice - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) - (nodePreference node) - = Just c - - -- we've got one of our preferences - | not $ isEmptyUniqSet colors_ok_pref - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) - (nodePreference node) - = Just c - - -- it wasn't a preference, but it was still ok - | not $ isEmptyUniqSet colors_ok - , c : _ <- nonDetEltsUniqSet colors_ok - -- See Note [Unique Determinism and code generation] - = Just c - - -- no colors were available for us this time. - -- looks like we're going around the loop again.. - | otherwise - = Nothing - - in chooseColor - - - diff --git a/utils/GraphOps.hs b/utils/GraphOps.hs deleted file mode 100644 --- a/utils/GraphOps.hs +++ /dev/null @@ -1,678 +0,0 @@ --- | Basic operations on graphs. --- - -module GraphOps ( - addNode, delNode, getNode, lookupNode, modNode, - size, - union, - addConflict, delConflict, addConflicts, - addCoalesce, delCoalesce, - addExclusion, addExclusions, - addPreference, - coalesceNodes, coalesceGraph, - freezeNode, freezeOneInGraph, freezeAllInGraph, - scanGraph, - setColor, - validateGraph, - slurpNodeConflictCount -) -where - -import GraphBase - -import Outputable -import Unique -import UniqSet -import UniqFM - -import Data.List hiding (union) -import Data.Maybe - --- | Lookup a node from the graph. -lookupNode - :: Uniquable k - => Graph k cls color - -> k -> Maybe (Node k cls color) - -lookupNode graph k - = lookupUFM (graphMap graph) k - - --- | Get a node from the graph, throwing an error if it's not there -getNode - :: Uniquable k - => Graph k cls color - -> k -> Node k cls color - -getNode graph k - = case lookupUFM (graphMap graph) k of - Just node -> node - Nothing -> panic "ColorOps.getNode: not found" - - --- | Add a node to the graph, linking up its edges -addNode :: Uniquable k - => k -> Node k cls color - -> Graph k cls color -> Graph k cls color - -addNode k node graph - = let - -- add back conflict edges from other nodes to this one - map_conflict = - nonDetFoldUniqSet - -- It's OK to use nonDetFoldUFM here because the - -- operation is commutative - (adjustUFM_C (\n -> n { nodeConflicts = - addOneToUniqSet (nodeConflicts n) k})) - (graphMap graph) - (nodeConflicts node) - - -- add back coalesce edges from other nodes to this one - map_coalesce = - nonDetFoldUniqSet - -- It's OK to use nonDetFoldUFM here because the - -- operation is commutative - (adjustUFM_C (\n -> n { nodeCoalesce = - addOneToUniqSet (nodeCoalesce n) k})) - map_conflict - (nodeCoalesce node) - - in graph - { graphMap = addToUFM map_coalesce k node} - - --- | Delete a node and all its edges from the graph. -delNode :: (Uniquable k) - => k -> Graph k cls color -> Maybe (Graph k cls color) - -delNode k graph - | Just node <- lookupNode graph k - = let -- delete conflict edges from other nodes to this one. - graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph - $ nonDetEltsUniqSet (nodeConflicts node) - - -- delete coalesce edge from other nodes to this one. - graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 - $ nonDetEltsUniqSet (nodeCoalesce node) - -- See Note [Unique Determinism and code generation] - - -- delete the node - graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 - - in Just graph3 - - | otherwise - = Nothing - - --- | Modify a node in the graph. --- returns Nothing if the node isn't present. --- -modNode :: Uniquable k - => (Node k cls color -> Node k cls color) - -> k -> Graph k cls color -> Maybe (Graph k cls color) - -modNode f k graph - = case lookupNode graph k of - Just Node{} - -> Just - $ graphMapModify - (\fm -> let Just node = lookupUFM fm k - node' = f node - in addToUFM fm k node') - graph - - Nothing -> Nothing - - --- | Get the size of the graph, O(n) -size :: Graph k cls color -> Int - -size graph - = sizeUFM $ graphMap graph - - --- | Union two graphs together. -union :: Graph k cls color -> Graph k cls color -> Graph k cls color - -union graph1 graph2 - = Graph - { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } - - --- | Add a conflict between nodes to the graph, creating the nodes required. --- Conflicts are virtual regs which need to be colored differently. -addConflict - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color - -addConflict (u1, c1) (u2, c2) - = let addNeighbor u c u' - = adjustWithDefaultUFM - (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) - (newNode u c) { nodeConflicts = unitUniqSet u' } - u - - in graphMapModify - ( addNeighbor u1 c1 u2 - . addNeighbor u2 c2 u1) - - --- | Delete a conflict edge. k1 -> k2 --- returns Nothing if the node isn't in the graph -delConflict - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) - -delConflict k1 k2 - = modNode - (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) - k1 - - --- | Add some conflicts to the graph, creating nodes if required. --- All the nodes in the set are taken to conflict with each other. -addConflicts - :: Uniquable k - => UniqSet k -> (k -> cls) - -> Graph k cls color -> Graph k cls color - -addConflicts conflicts getClass - - -- just a single node, but no conflicts, create the node anyway. - | (u : []) <- nonDetEltsUniqSet conflicts - = graphMapModify - $ adjustWithDefaultUFM - id - (newNode u (getClass u)) - u - - | otherwise - = graphMapModify - $ \fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm - $ nonDetEltsUniqSet conflicts - -- See Note [Unique Determinism and code generation] - - -addConflictSet1 :: Uniquable k - => k -> (k -> cls) -> UniqSet k - -> UniqFM (Node k cls color) - -> UniqFM (Node k cls color) -addConflictSet1 u getClass set - = case delOneFromUniqSet set u of - set' -> adjustWithDefaultUFM - (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) - (newNode u (getClass u)) { nodeConflicts = set' } - u - - --- | Add an exclusion to the graph, creating nodes if required. --- These are extra colors that the node cannot use. -addExclusion - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> color - -> Graph k cls color -> Graph k cls color - -addExclusion u getClass color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) - (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } - u - -addExclusions - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> [color] - -> Graph k cls color -> Graph k cls color - -addExclusions u getClass colors graph - = foldr (addExclusion u getClass) graph colors - - --- | Add a coalescence edge to the graph, creating nodes if requried. --- It is considered adventageous to assign the same color to nodes in a coalesence. -addCoalesce - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color - -addCoalesce (u1, c1) (u2, c2) - = let addCoalesce u c u' - = adjustWithDefaultUFM - (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) - (newNode u c) { nodeCoalesce = unitUniqSet u' } - u - - in graphMapModify - ( addCoalesce u1 c1 u2 - . addCoalesce u2 c2 u1) - - --- | Delete a coalescence edge (k1 -> k2) from the graph. -delCoalesce - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) - -delCoalesce k1 k2 - = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) - k1 - - --- | Add a color preference to the graph, creating nodes if required. --- The most recently added preference is the most prefered. --- The algorithm tries to assign a node it's prefered color if possible. --- -addPreference - :: Uniquable k - => (k, cls) -> color - -> Graph k cls color -> Graph k cls color - -addPreference (u, c) color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodePreference = color : (nodePreference node) }) - (newNode u c) { nodePreference = [color] } - u - - --- | Do aggressive coalescing on this graph. --- returns the new graph and the list of pairs of nodes that got coalesced together. --- for each pair, the resulting node will have the least key and be second in the pair. --- -coalesceGraph - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> ( Graph k cls color - , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the - -- coalescing was applied. - -coalesceGraph aggressive triv graph - = coalesceGraph' aggressive triv graph [] - -coalesceGraph' - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool - -> Triv k cls color - -> Graph k cls color - -> [(k, k)] - -> ( Graph k cls color - , [(k, k)]) -coalesceGraph' aggressive triv graph kkPairsAcc - = let - -- find all the nodes that have coalescence edges - cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - -- build a list of pairs of keys for node's we'll try and coalesce - -- every pair of nodes will appear twice in this list - -- ie [(k1, k2), (k2, k1) ... ] - -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for - -- build a list of what nodes get coalesced together for later on. - -- - cList = [ (nodeId node1, k2) - | node1 <- cNodes - , k2 <- nonDetEltsUniqSet $ nodeCoalesce node1 ] - -- See Note [Unique Determinism and code generation] - - -- do the coalescing, returning the new graph and a list of pairs of keys - -- that got coalesced together. - (graph', mPairs) - = mapAccumL (coalesceNodes aggressive triv) graph cList - - -- keep running until there are no more coalesces can be found - in case catMaybes mPairs of - [] -> (graph', reverse kkPairsAcc) - pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) - - --- | Coalesce this pair of nodes unconditionally \/ aggressively. --- The resulting node is the one with the least key. --- --- returns: Just the pair of keys if the nodes were coalesced --- the second element of the pair being the least one --- --- Nothing if either of the nodes weren't in the graph - -coalesceNodes - :: (Uniquable k, Ord k, Eq cls) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> (k, k) -- ^ keys of the nodes to be coalesced - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes aggressive triv graph (k1, k2) - | (kMin, kMax) <- if k1 < k2 - then (k1, k2) - else (k2, k1) - - -- the nodes being coalesced must be in the graph - , Just nMin <- lookupNode graph kMin - , Just nMax <- lookupNode graph kMax - - -- can't coalesce conflicting modes - , not $ elementOfUniqSet kMin (nodeConflicts nMax) - , not $ elementOfUniqSet kMax (nodeConflicts nMin) - - -- can't coalesce the same node - , nodeId nMin /= nodeId nMax - - = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - - -- don't do the coalescing after all - | otherwise - = (graph, Nothing) - -coalesceNodes_merge - :: (Uniquable k, Eq cls) - => Bool - -> Triv k cls color - -> Graph k cls color - -> k -> k - -> Node k cls color - -> Node k cls color - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - - -- sanity checks - | nodeClass nMin /= nodeClass nMax - = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes." - - | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) - = error "GraphOps.coalesceNodes: can't coalesce colored nodes." - - --- - | otherwise - = let - -- the new node gets all the edges from its two components - node = - Node { nodeId = kMin - , nodeClass = nodeClass nMin - , nodeColor = Nothing - - -- nodes don't conflict with themselves.. - , nodeConflicts - = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax - - , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) - , nodePreference = nodePreference nMin ++ nodePreference nMax - - -- nodes don't coalesce with themselves.. - , nodeCoalesce - = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax - } - - in coalesceNodes_check aggressive triv graph kMin kMax node - -coalesceNodes_check - :: Uniquable k - => Bool - -> Triv k cls color - -> Graph k cls color - -> k -> k - -> Node k cls color - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes_check aggressive triv graph kMin kMax node - - -- Unless we're coalescing aggressively, if the result node is not trivially - -- colorable then don't do the coalescing. - | not aggressive - , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - = (graph, Nothing) - - | otherwise - = let -- delete the old nodes from the graph and add the new one - Just graph1 = delNode kMax graph - Just graph2 = delNode kMin graph1 - graph3 = addNode kMin node graph2 - - in (graph3, Just (kMax, kMin)) - - --- | Freeze a node --- This is for the iterative coalescer. --- By freezing a node we give up on ever coalescing it. --- Move all its coalesce edges into the frozen set - and update --- back edges from other nodes. --- -freezeNode - :: Uniquable k - => k -- ^ key of the node to freeze - -> Graph k cls color -- ^ the graph - -> Graph k cls color -- ^ graph with that node frozen - -freezeNode k - = graphMapModify - $ \fm -> - let -- freeze all the edges in the node to be frozen - Just node = lookupUFM fm k - node' = node - { nodeCoalesce = emptyUniqSet } - - fm1 = addToUFM fm k node' - - -- update back edges pointing to this node - freezeEdge k node - = if elementOfUniqSet k (nodeCoalesce node) - then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } - else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" - -- If the edge isn't actually in the coelesce set then just ignore it. - - fm2 = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1 - -- It's OK to use nonDetFoldUFM here because the operation - -- is commutative - $ nodeCoalesce node - - in fm2 - - --- | Freeze one node in the graph --- This if for the iterative coalescer. --- Look for a move related node of low degree and freeze it. --- --- We probably don't need to scan the whole graph looking for the node of absolute --- lowest degree. Just sample the first few and choose the one with the lowest --- degree out of those. Also, we don't make any distinction between conflicts of different --- classes.. this is just a heuristic, after all. --- --- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv --- right here, and add it to a worklist if known triv\/non-move nodes. --- -freezeOneInGraph - :: (Uniquable k) - => Graph k cls color - -> ( Graph k cls color -- the new graph - , Bool ) -- whether we found a node to freeze - -freezeOneInGraph graph - = let compareNodeDegree n1 n2 - = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) - - candidates - = sortBy compareNodeDegree - $ take 5 -- 5 isn't special, it's just a small number. - $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph - - in case candidates of - - -- there wasn't anything available to freeze - [] -> (graph, False) - - -- we found something to freeze - (n : _) - -> ( freezeNode (nodeId n) graph - , True) - - --- | Freeze all the nodes in the graph --- for debugging the iterative allocator. --- -freezeAllInGraph - :: (Uniquable k) - => Graph k cls color - -> Graph k cls color - -freezeAllInGraph graph - = foldr freezeNode graph - $ map nodeId - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - --- | Find all the nodes in the graph that meet some criteria --- -scanGraph - :: (Node k cls color -> Bool) - -> Graph k cls color - -> [Node k cls color] - -scanGraph match graph - = filter match $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - --- | validate the internal structure of a graph --- all its edges should point to valid nodes --- If they don't then throw an error --- -validateGraph - :: (Uniquable k, Outputable k, Eq color) - => SDoc -- ^ extra debugging info to display on error - -> Bool -- ^ whether this graph is supposed to be colored. - -> Graph k cls color -- ^ graph to validate - -> Graph k cls color -- ^ validated graph - -validateGraph doc isColored graph - - -- Check that all edges point to valid nodes. - | edges <- unionManyUniqSets - ( (map nodeConflicts $ nonDetEltsUFM $ graphMap graph) - ++ (map nodeCoalesce $ nonDetEltsUFM $ graphMap graph)) - - , nodes <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph - , badEdges <- minusUniqSet edges nodes - , not $ isEmptyUniqSet badEdges - = pprPanic "GraphOps.validateGraph" - ( text "Graph has edges that point to non-existent nodes" - $$ text " bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr) - $$ doc ) - - -- Check that no conflicting nodes have the same color - | badNodes <- filter (not . (checkNode graph)) - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Node has same color as one of it's conflicts" - $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc) - - -- If this is supposed to be a colored graph, - -- check that all nodes have a color. - | isColored - , badNodes <- filter (\n -> isNothing $ nodeColor n) - $ nonDetEltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Supposably colored graph has uncolored nodes." - $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc ) - - - -- graph looks ok - | otherwise - = graph - - --- | If this node is colored, check that all the nodes which --- conflict with it have different colors. -checkNode - :: (Uniquable k, Eq color) - => Graph k cls color - -> Node k cls color - -> Bool -- ^ True if this node is ok - -checkNode graph node - | Just color <- nodeColor node - , Just neighbors <- sequence $ map (lookupNode graph) - $ nonDetEltsUniqSet $ nodeConflicts node - -- See Note [Unique Determinism and code generation] - - , neighbourColors <- catMaybes $ map nodeColor neighbors - , elem color neighbourColors - = False - - | otherwise - = True - - - --- | Slurp out a map of how many nodes had a certain number of conflict neighbours - -slurpNodeConflictCount - :: Graph k cls color - -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) - -slurpNodeConflictCount graph - = addListToUFM_C - (\(c1, n1) (_, n2) -> (c1, n1 + n2)) - emptyUFM - $ map (\node - -> let count = sizeUniqSet $ nodeConflicts node - in (count, (count, 1))) - $ nonDetEltsUFM - -- See Note [Unique Determinism and code generation] - $ graphMap graph - - --- | Set the color of a certain node -setColor - :: Uniquable k - => k -> color - -> Graph k cls color -> Graph k cls color - -setColor u color - = graphMapModify - $ adjustUFM_C - (\n -> n { nodeColor = Just color }) - u - - -{-# INLINE adjustWithDefaultUFM #-} -adjustWithDefaultUFM - :: Uniquable k - => (a -> a) -> a -> k - -> UniqFM a -> UniqFM a - -adjustWithDefaultUFM f def k map - = addToUFM_C - (\old _ -> f old) - map - k def - --- Argument order different from UniqFM's adjustUFM -{-# INLINE adjustUFM_C #-} -adjustUFM_C - :: Uniquable k - => (a -> a) - -> k -> UniqFM a -> UniqFM a - -adjustUFM_C f k map - = case lookupUFM map k of - Nothing -> map - Just a -> addToUFM map k (f a) - diff --git a/utils/GraphPpr.hs b/utils/GraphPpr.hs deleted file mode 100644 --- a/utils/GraphPpr.hs +++ /dev/null @@ -1,171 +0,0 @@ - --- | Pretty printing of graphs. - -module GraphPpr ( - dumpGraph, - dotGraph -) -where - -import GraphBase - -import Outputable -import Unique -import UniqSet -import UniqFM - -import Data.List -import Data.Maybe - - --- | Pretty print a graph in a somewhat human readable format. -dumpGraph - :: (Outputable k, Outputable color) - => Graph k cls color -> SDoc - -dumpGraph graph - = text "Graph" - $$ pprUFM (graphMap graph) (vcat . map dumpNode) - -dumpNode - :: (Outputable k, Outputable color) - => Node k cls color -> SDoc - -dumpNode node - = text "Node " <> ppr (nodeId node) - $$ text "conflicts " - <> parens (int (sizeUniqSet $ nodeConflicts node)) - <> text " = " - <> ppr (nodeConflicts node) - - $$ text "exclusions " - <> parens (int (sizeUniqSet $ nodeExclusions node)) - <> text " = " - <> ppr (nodeExclusions node) - - $$ text "coalesce " - <> parens (int (sizeUniqSet $ nodeCoalesce node)) - <> text " = " - <> ppr (nodeCoalesce node) - - $$ space - - - --- | Pretty print a graph in graphviz .dot format. --- Conflicts get solid edges. --- Coalescences get dashed edges. -dotGraph - :: ( Uniquable k - , Outputable k, Outputable cls, Outputable color) - => (color -> SDoc) -- ^ What graphviz color to use for each node color - -- It's usually safe to return X11 style colors here, - -- ie "red", "green" etc or a hex triplet #aaff55 etc - -> Triv k cls color - -> Graph k cls color -> SDoc - -dotGraph colorMap triv graph - = let nodes = nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - in vcat - ( [ text "graph G {" ] - ++ map (dotNode colorMap triv) nodes - ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes) - ++ [ text "}" - , space ]) - - -dotNode :: ( Outputable k, Outputable cls, Outputable color) - => (color -> SDoc) - -> Triv k cls color - -> Node k cls color -> SDoc - -dotNode colorMap triv node - = let name = ppr $ nodeId node - cls = ppr $ nodeClass node - - excludes - = hcat $ punctuate space - $ map (\n -> text "-" <> ppr n) - $ nonDetEltsUniqSet $ nodeExclusions node - -- See Note [Unique Determinism and code generation] - - preferences - = hcat $ punctuate space - $ map (\n -> text "+" <> ppr n) - $ nodePreference node - - expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)] - then empty - else text "\\n" <> (excludes <+> preferences) - - -- if the node has been colored then show that, - -- otherwise indicate whether it looks trivially colorable. - color - | Just c <- nodeColor node - = text "\\n(" <> ppr c <> text ")" - - | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - = text "\\n(" <> text "triv" <> text ")" - - | otherwise - = text "\\n(" <> text "spill?" <> text ")" - - label = name <> text " :: " <> cls - <> expref - <> color - - pcolorC = case nodeColor node of - Nothing -> text "style=filled fillcolor=white" - Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c) - - - pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]" - <> space <> doubleQuotes name - <> text ";" - - in pout - - --- | Nodes in the graph are doubly linked, but we only want one edge for each --- conflict if the graphviz graph. Traverse over the graph, but make sure --- to only print the edges for each node once. - -dotNodeEdges - :: ( Uniquable k - , Outputable k) - => UniqSet k - -> Node k cls color - -> (UniqSet k, Maybe SDoc) - -dotNodeEdges visited node - | elementOfUniqSet (nodeId node) visited - = ( visited - , Nothing) - - | otherwise - = let dconflicts - = map (dotEdgeConflict (nodeId node)) - $ nonDetEltsUniqSet - -- See Note [Unique Determinism and code generation] - $ minusUniqSet (nodeConflicts node) visited - - dcoalesces - = map (dotEdgeCoalesce (nodeId node)) - $ nonDetEltsUniqSet - -- See Note [Unique Determinism and code generation] - $ minusUniqSet (nodeCoalesce node) visited - - out = vcat dconflicts - $$ vcat dcoalesces - - in ( addOneToUniqSet visited (nodeId node) - , Just out) - - where dotEdgeConflict u1 u2 - = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) - <> text ";" - - dotEdgeCoalesce u1 u2 - = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) - <> space <> text "[ style = dashed ];" diff --git a/utils/IOEnv.hs b/utils/IOEnv.hs deleted file mode 100644 --- a/utils/IOEnv.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE CPP #-} - --- --- (c) The University of Glasgow 2002-2006 --- --- The IO Monad with an environment --- --- The environment is passed around as a Reader monad but --- as its in the IO monad, mutable references can be used --- for updating state. --- - -module IOEnv ( - IOEnv, -- Instance of Monad - - -- Monad utilities - module MonadUtils, - - -- Errors - failM, failWithM, - IOEnvFailure(..), - - -- Getting at the environment - getEnv, setEnv, updEnv, - - runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, - tryM, tryAllM, tryMostM, fixM, - - -- I/O operations - IORef, newMutVar, readMutVar, writeMutVar, updMutVar, - atomicUpdMutVar, atomicUpdMutVar' - ) where - -import DynFlags -import Exception -import Module -import Panic - -import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, - atomicModifyIORef, atomicModifyIORef' ) -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO ( fixIO ) -import Control.Monad -#if __GLASGOW_HASKELL__ > 710 -import qualified Control.Monad.Fail as MonadFail -#endif -import MonadUtils -import Control.Applicative (Alternative(..)) - ----------------------------------------------------------------------- --- Defining the monad type ----------------------------------------------------------------------- - - -newtype IOEnv env a = IOEnv (env -> IO a) - -unIOEnv :: IOEnv env a -> (env -> IO a) -unIOEnv (IOEnv m) = m - -instance Monad (IOEnv m) where - (>>=) = thenM - (>>) = (*>) - fail _ = failM -- Ignore the string - -#if __GLASGOW_HASKELL__ > 710 -instance MonadFail.MonadFail (IOEnv m) where - fail _ = failM -- Ignore the string -#endif - - -instance Applicative (IOEnv m) where - pure = returnM - IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env ) - (*>) = thenM_ - -instance Functor (IOEnv m) where - fmap f (IOEnv m) = IOEnv (\ env -> fmap f (m env)) - -returnM :: a -> IOEnv env a -returnM a = IOEnv (\ _ -> return a) - -thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b -thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ; - unIOEnv (f r) env }) - -thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b -thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env }) - -failM :: IOEnv env a -failM = IOEnv (\ _ -> throwIO IOEnvFailure) - -failWithM :: String -> IOEnv env a -failWithM s = IOEnv (\ _ -> ioError (userError s)) - -data IOEnvFailure = IOEnvFailure - -instance Show IOEnvFailure where - show IOEnvFailure = "IOEnv failure" - -instance Exception IOEnvFailure - -instance ExceptionMonad (IOEnv a) where - gcatch act handle = - IOEnv $ \s -> unIOEnv act s `gcatch` \e -> unIOEnv (handle e) s - gmask f = - IOEnv $ \s -> gmask $ \io_restore -> - let - g_restore (IOEnv m) = IOEnv $ \s -> io_restore (m s) - in - unIOEnv (f g_restore) s - -instance ContainsDynFlags env => HasDynFlags (IOEnv env) where - getDynFlags = do env <- getEnv - return $ extractDynFlags env - -instance ContainsModule env => HasModule (IOEnv env) where - getModule = do env <- getEnv - return $ extractModule env - ----------------------------------------------------------------------- --- Fundamental combinators specific to the monad ----------------------------------------------------------------------- - - ---------------------------- -runIOEnv :: env -> IOEnv env a -> IO a -runIOEnv env (IOEnv m) = m env - - ---------------------------- -{-# NOINLINE fixM #-} - -- Aargh! Not inlining fixM alleviates a space leak problem. - -- Normally fixM is used with a lazy tuple match: if the optimiser is - -- shown the definition of fixM, it occasionally transforms the code - -- in such a way that the code generator doesn't spot the selector - -- thunks. Sigh. - -fixM :: (a -> IOEnv env a) -> IOEnv env a -fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) - - ---------------------------- -tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r) --- Reflect UserError exceptions (only) into IOEnv monad --- Other exceptions are not caught; they are simply propagated as exns --- --- The idea is that errors in the program being compiled will give rise --- to UserErrors. But, say, pattern-match failures in GHC itself should --- not be caught here, else they'll be reported as errors in the program --- begin compiled! -tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env)) - -tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a) -tryIOEnvFailure = try - --- XXX We shouldn't be catching everything, e.g. timeouts -tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r) --- Catch *all* exceptions --- This is used when running a Template-Haskell splice, when --- even a pattern-match failure is a programmer error -tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env)) - -tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r) -tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) - ---------------------------- -unsafeInterleaveM :: IOEnv env a -> IOEnv env a -unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) - -uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a -uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env)) - ----------------------------------------------------------------------- --- Alternative/MonadPlus ----------------------------------------------------------------------- - -instance Alternative (IOEnv env) where - empty = IOEnv (const empty) - m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env) - -instance MonadPlus (IOEnv env) - ----------------------------------------------------------------------- --- Accessing input/output ----------------------------------------------------------------------- - -instance MonadIO (IOEnv env) where - liftIO io = IOEnv (\ _ -> io) - -newMutVar :: a -> IOEnv env (IORef a) -newMutVar val = liftIO (newIORef val) - -writeMutVar :: IORef a -> a -> IOEnv env () -writeMutVar var val = liftIO (writeIORef var val) - -readMutVar :: IORef a -> IOEnv env a -readMutVar var = liftIO (readIORef var) - -updMutVar :: IORef a -> (a -> a) -> IOEnv env () -updMutVar var upd = liftIO (modifyIORef var upd) - --- | Atomically update the reference. Does not force the evaluation of the --- new variable contents. For strict update, use 'atomicUpdMutVar''. -atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b -atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd) - --- | Strict variant of 'atomicUpdMutVar'. -atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b -atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd) - ----------------------------------------------------------------------- --- Accessing the environment ----------------------------------------------------------------------- - -getEnv :: IOEnv env env -{-# INLINE getEnv #-} -getEnv = IOEnv (\ env -> return env) - --- | Perform a computation with a different environment -setEnv :: env' -> IOEnv env' a -> IOEnv env a -{-# INLINE setEnv #-} -setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env) - --- | Perform a computation with an altered environment -updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a -{-# INLINE updEnv #-} -updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) diff --git a/utils/Json.hs b/utils/Json.hs deleted file mode 100644 --- a/utils/Json.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE GADTs #-} -module Json where - -import Outputable -import Data.Char -import Numeric - --- | Simple data type to represent JSON documents. -data JsonDoc where - JSNull :: JsonDoc - JSBool :: Bool -> JsonDoc - JSInt :: Int -> JsonDoc - JSString :: String -> JsonDoc - JSArray :: [JsonDoc] -> JsonDoc - JSObject :: [(String, JsonDoc)] -> JsonDoc - - --- This is simple and slow as it is only used for error reporting -renderJSON :: JsonDoc -> SDoc -renderJSON d = - case d of - JSNull -> text "null" - JSBool b -> text $ if b then "true" else "false" - JSInt n -> ppr n - JSString s -> doubleQuotes $ text $ escapeJsonString s - JSArray as -> brackets $ pprList renderJSON as - JSObject fs -> braces $ pprList renderField fs - where - renderField :: (String, JsonDoc) -> SDoc - renderField (s, j) = doubleQuotes (text s) <> colon <+> renderJSON j - - pprList pp xs = hcat (punctuate comma (map pp xs)) - -escapeJsonString :: String -> String -escapeJsonString = concatMap escapeChar - where - escapeChar '\b' = "\\b" - escapeChar '\f' = "\\f" - escapeChar '\n' = "\\n" - escapeChar '\r' = "\\r" - escapeChar '\t' = "\\t" - escapeChar '"' = "\\\"" - escapeChar '\\' = "\\\\" - escapeChar c | isControl c || fromEnum c >= 0x7f = uni_esc c - escapeChar c = [c] - - uni_esc c = "\\u" ++ (pad 4 (showHex (fromEnum c) "")) - - pad n cs | len < n = replicate (n-len) '0' ++ cs - | otherwise = cs - where len = length cs - -class ToJson a where - json :: a -> JsonDoc diff --git a/utils/ListSetOps.hs b/utils/ListSetOps.hs deleted file mode 100644 --- a/utils/ListSetOps.hs +++ /dev/null @@ -1,155 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[ListSetOps]{Set-like operations on lists} --} - -{-# LANGUAGE CPP #-} - -module ListSetOps ( - unionLists, minusList, - - -- Association lists - Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, - - -- Duplicate handling - hasNoDups, runs, removeDups, findDupsEq, - equivClasses, - - -- Indexing - getNth - ) where - -#include "HsVersions.h" - -import Outputable -import Util - -import Data.List - -getNth :: Outputable a => [a] -> Int -> a -getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) - xs !! n - -{- -************************************************************************ -* * - Treating lists as sets - Assumes the lists contain no duplicates, but are unordered -* * -************************************************************************ --} - - -unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a] --- Assumes that the arguments contain no duplicates -unionLists xs ys - = WARN(length xs > 100 || length ys > 100, ppr xs $$ ppr ys) - [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys - -minusList :: (Eq a) => [a] -> [a] -> [a] --- Everything in the first list that is not in the second list: -minusList xs ys = [ x | x <- xs, isn'tIn "minusList" x ys] - -{- -************************************************************************ -* * -\subsection[Utils-assoc]{Association lists} -* * -************************************************************************ - -Inefficient finite maps based on association lists and equality. --} - --- A finite mapping based on equality and association lists -type Assoc a b = [(a,b)] - -assoc :: (Eq a) => String -> Assoc a b -> a -> b -assocDefault :: (Eq a) => b -> Assoc a b -> a -> b -assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b -assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b -assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b - -assocDefaultUsing _ deflt [] _ = deflt -assocDefaultUsing eq deflt ((k,v) : rest) key - | k `eq` key = v - | otherwise = assocDefaultUsing eq deflt rest key - -assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key -assocDefault deflt list key = assocDefaultUsing (==) deflt list key -assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key - -assocMaybe alist key - = lookup alist - where - lookup [] = Nothing - lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest - -{- -************************************************************************ -* * -\subsection[Utils-dups]{Duplicate-handling} -* * -************************************************************************ --} - -hasNoDups :: (Eq a) => [a] -> Bool - -hasNoDups xs = f [] xs - where - f _ [] = True - f seen_so_far (x:xs) = if x `is_elem` seen_so_far - then False - else f (x:seen_so_far) xs - - is_elem = isIn "hasNoDups" - -equivClasses :: (a -> a -> Ordering) -- Comparison - -> [a] - -> [[a]] - -equivClasses _ [] = [] -equivClasses _ stuff@[_] = [stuff] -equivClasses cmp items = runs eq (sortBy cmp items) - where - eq a b = case cmp a b of { EQ -> True; _ -> False } - -{- -The first cases in @equivClasses@ above are just to cut to the point -more quickly... - -@runs@ groups a list into a list of lists, each sublist being a run of -identical elements of the input list. It is passed a predicate @p@ which -tells when two elements are equal. --} - -runs :: (a -> a -> Bool) -- Equality - -> [a] - -> [[a]] - -runs _ [] = [] -runs p (x:xs) = case (span (p x) xs) of - (first, rest) -> (x:first) : (runs p rest) - -removeDups :: (a -> a -> Ordering) -- Comparison function - -> [a] - -> ([a], -- List with no duplicates - [[a]]) -- List of duplicate groups. One representative from - -- each group appears in the first result - -removeDups _ [] = ([], []) -removeDups _ [x] = ([x],[]) -removeDups cmp xs - = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') -> - (xs', dups) } - where - collect_dups _ [] = panic "ListSetOps: removeDups" - collect_dups dups_so_far [x] = (dups_so_far, x) - collect_dups dups_so_far dups@(x:_) = (dups:dups_so_far, x) - -findDupsEq :: (a->a->Bool) -> [a] -> [[a]] -findDupsEq _ [] = [] -findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs - | otherwise = (x:eq_xs) : findDupsEq eq neq_xs - where (eq_xs, neq_xs) = partition (eq x) xs diff --git a/utils/ListT.hs b/utils/ListT.hs deleted file mode 100644 --- a/utils/ListT.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -------------------------------------------------------------------------- --- | --- Module : Control.Monad.Logic --- Copyright : (c) Dan Doel --- License : BSD3 --- --- Maintainer : dan.doel@gmail.com --- Stability : experimental --- Portability : non-portable (multi-parameter type classes) --- --- A backtracking, logic programming monad. --- --- Adapted from the paper --- /Backtracking, Interleaving, and Terminating --- Monad Transformers/, by --- Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry --- (). -------------------------------------------------------------------------- - -module ListT ( - ListT(..), - runListT, - select, - fold - ) where - -import Control.Applicative - -import Control.Monad - -------------------------------------------------------------------------- --- | A monad transformer for performing backtracking computations --- layered over another monad 'm' -newtype ListT m a = - ListT { unListT :: forall r. (a -> m r -> m r) -> m r -> m r } - -select :: Monad m => [a] -> ListT m a -select xs = foldr (<|>) mzero (map pure xs) - -fold :: ListT m a -> (a -> m r -> m r) -> m r -> m r -fold = runListT - -------------------------------------------------------------------------- --- | Runs a ListT computation with the specified initial success and --- failure continuations. -runListT :: ListT m a -> (a -> m r -> m r) -> m r -> m r -runListT = unListT - -instance Functor (ListT f) where - fmap f lt = ListT $ \sk fk -> unListT lt (sk . f) fk - -instance Applicative (ListT f) where - pure a = ListT $ \sk fk -> sk a fk - f <*> a = ListT $ \sk fk -> unListT f (\g fk' -> unListT a (sk . g) fk') fk - -instance Alternative (ListT f) where - empty = ListT $ \_ fk -> fk - f1 <|> f2 = ListT $ \sk fk -> unListT f1 sk (unListT f2 sk fk) - -instance Monad (ListT m) where - m >>= f = ListT $ \sk fk -> unListT m (\a fk' -> unListT (f a) sk fk') fk - fail _ = ListT $ \_ fk -> fk - -instance MonadPlus (ListT m) where - mzero = ListT $ \_ fk -> fk - m1 `mplus` m2 = ListT $ \sk fk -> unListT m1 sk (unListT m2 sk fk) diff --git a/utils/Maybes.hs b/utils/Maybes.hs deleted file mode 100644 --- a/utils/Maybes.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module Maybes ( - module Data.Maybe, - - MaybeErr(..), -- Instance of Monad - failME, isSuccess, - - orElse, - firstJust, firstJusts, - whenIsJust, - expectJust, - - -- * MaybeT - MaybeT(..), liftMaybeT, tryMaybeT - ) where - -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Exception (catch, SomeException(..)) -import Data.Maybe -import Util (HasCallStack) - -infixr 4 `orElse` - -{- -************************************************************************ -* * -\subsection[Maybe type]{The @Maybe@ type} -* * -************************************************************************ --} - -firstJust :: Maybe a -> Maybe a -> Maybe a -firstJust a b = firstJusts [a, b] - --- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or --- @Nothing@ otherwise. -firstJusts :: [Maybe a] -> Maybe a -firstJusts = msum - -expectJust :: HasCallStack => String -> Maybe a -> a -{-# INLINE expectJust #-} -expectJust _ (Just x) = x -expectJust err Nothing = error ("expectJust " ++ err) - -whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenIsJust (Just x) f = f x -whenIsJust Nothing _ = return () - --- | Flipped version of @fromMaybe@, useful for chaining. -orElse :: Maybe a -> a -> a -orElse = flip fromMaybe - -{- -************************************************************************ -* * -\subsection[MaybeT type]{The @MaybeT@ monad transformer} -* * -************************************************************************ --} - --- We had our own MaybeT in the past. Now we reuse transformer's MaybeT - -liftMaybeT :: Monad m => m a -> MaybeT m a -liftMaybeT act = MaybeT $ Just `liftM` act - --- | Try performing an 'IO' action, failing on error. -tryMaybeT :: IO a -> MaybeT IO a -tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler - where - handler (SomeException _) = return Nothing - -{- -************************************************************************ -* * -\subsection[MaybeErr type]{The @MaybeErr@ type} -* * -************************************************************************ --} - -data MaybeErr err val = Succeeded val | Failed err - -instance Functor (MaybeErr err) where - fmap = liftM - -instance Applicative (MaybeErr err) where - pure = Succeeded - (<*>) = ap - -instance Monad (MaybeErr err) where - Succeeded v >>= k = k v - Failed e >>= _ = Failed e - -isSuccess :: MaybeErr err val -> Bool -isSuccess (Succeeded {}) = True -isSuccess (Failed {}) = False - -failME :: err -> MaybeErr err val -failME e = Failed e diff --git a/utils/MonadUtils.hs b/utils/MonadUtils.hs deleted file mode 100644 --- a/utils/MonadUtils.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Utilities related to Monad and Applicative classes --- Mostly for backwards compatibility. - -module MonadUtils - ( Applicative(..) - , (<$>) - - , MonadFix(..) - , MonadIO(..) - - , liftIO1, liftIO2, liftIO3, liftIO4 - - , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM - , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M - , mapAccumLM - , mapSndM - , concatMapM - , mapMaybeM - , fmapMaybeM, fmapEitherM - , anyM, allM, orM - , foldlM, foldlM_, foldrM - , maybeMapM - , whenM, unlessM - ) where - -------------------------------------------------------------------------------- --- Imports -------------------------------------------------------------------------------- - -import Maybes - -import Control.Monad -import Control.Monad.Fix -import Control.Monad.IO.Class -#if __GLASGOW_HASKELL__ < 800 -import Control.Monad.Trans.Error () -- for orphan `instance MonadPlus IO` -#endif - -------------------------------------------------------------------------------- --- Lift combinators --- These are used throughout the compiler -------------------------------------------------------------------------------- - --- | Lift an 'IO' operation with 1 argument into another monad -liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b -liftIO1 = (.) liftIO - --- | Lift an 'IO' operation with 2 arguments into another monad -liftIO2 :: MonadIO m => (a -> b -> IO c) -> a -> b -> m c -liftIO2 = ((.).(.)) liftIO - --- | Lift an 'IO' operation with 3 arguments into another monad -liftIO3 :: MonadIO m => (a -> b -> c -> IO d) -> a -> b -> c -> m d -liftIO3 = ((.).((.).(.))) liftIO - --- | Lift an 'IO' operation with 4 arguments into another monad -liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e -liftIO4 = (((.).(.)).((.).(.))) liftIO - -------------------------------------------------------------------------------- --- Common functions --- These are used throughout the compiler -------------------------------------------------------------------------------- - -zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] -zipWith3M _ [] _ _ = return [] -zipWith3M _ _ [] _ = return [] -zipWith3M _ _ _ [] = return [] -zipWith3M f (x:xs) (y:ys) (z:zs) - = do { r <- f x y z - ; rs <- zipWith3M f xs ys zs - ; return $ r:rs - } - -zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () -zipWith3M_ f as bs cs = do { _ <- zipWith3M f as bs cs - ; return () } - -zipWith4M :: Monad m => (a -> b -> c -> d -> m e) - -> [a] -> [b] -> [c] -> [d] -> m [e] -zipWith4M _ [] _ _ _ = return [] -zipWith4M _ _ [] _ _ = return [] -zipWith4M _ _ _ [] _ = return [] -zipWith4M _ _ _ _ [] = return [] -zipWith4M f (x:xs) (y:ys) (z:zs) (a:as) - = do { r <- f x y z a - ; rs <- zipWith4M f xs ys zs as - ; return $ r:rs - } - - -zipWithAndUnzipM :: Monad m - => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) -{-# INLINABLE zipWithAndUnzipM #-} --- See Note [flatten_many performance] in TcFlatten for why this --- pragma is essential. -zipWithAndUnzipM f (x:xs) (y:ys) - = do { (c, d) <- f x y - ; (cs, ds) <- zipWithAndUnzipM f xs ys - ; return (c:cs, d:ds) } -zipWithAndUnzipM _ _ _ = return ([], []) - --- | mapAndUnzipM for triples -mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) -mapAndUnzip3M _ [] = return ([],[],[]) -mapAndUnzip3M f (x:xs) = do - (r1, r2, r3) <- f x - (rs1, rs2, rs3) <- mapAndUnzip3M f xs - return (r1:rs1, r2:rs2, r3:rs3) - -mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e]) -mapAndUnzip4M _ [] = return ([],[],[],[]) -mapAndUnzip4M f (x:xs) = do - (r1, r2, r3, r4) <- f x - (rs1, rs2, rs3, rs4) <- mapAndUnzip4M f xs - return (r1:rs1, r2:rs2, r3:rs3, r4:rs4) - -mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f]) -mapAndUnzip5M _ [] = return ([],[],[],[],[]) -mapAndUnzip5M f (x:xs) = do - (r1, r2, r3, r4, r5) <- f x - (rs1, rs2, rs3, rs4, rs5) <- mapAndUnzip5M f xs - return (r1:rs1, r2:rs2, r3:rs3, r4:rs4, r5:rs5) - --- | Monadic version of mapAccumL -mapAccumLM :: Monad m - => (acc -> x -> m (acc, y)) -- ^ combining function - -> acc -- ^ initial state - -> [x] -- ^ inputs - -> m (acc, [y]) -- ^ final state, outputs -mapAccumLM _ s [] = return (s, []) -mapAccumLM f s (x:xs) = do - (s1, x') <- f s x - (s2, xs') <- mapAccumLM f s1 xs - return (s2, x' : xs') - --- | Monadic version of mapSnd -mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] -mapSndM _ [] = return [] -mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) } - --- | Monadic version of concatMap -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = liftM concat (mapM f xs) - --- | Monadic version of mapMaybe -mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM f = liftM catMaybes . mapM f - --- | Monadic version of fmap -fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) -fmapMaybeM _ Nothing = return Nothing -fmapMaybeM f (Just x) = f x >>= (return . Just) - --- | Monadic version of fmap -fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) -fmapEitherM fl _ (Left a) = fl a >>= (return . Left) -fmapEitherM _ fr (Right b) = fr b >>= (return . Right) - --- | Monadic version of 'any', aborts the computation at the first @True@ value -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM _ [] = return False -anyM f (x:xs) = do b <- f x - if b then return True - else anyM f xs - --- | Monad version of 'all', aborts the computation at the first @False@ value -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool -allM _ [] = return True -allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False) - --- | Monadic version of or -orM :: Monad m => m Bool -> m Bool -> m Bool -orM m1 m2 = m1 >>= \x -> if x then return True else m2 - --- | Monadic version of foldl -foldlM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a -foldlM = foldM - --- | Monadic version of foldl that discards its result -foldlM_ :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m () -foldlM_ = foldM_ - --- | Monadic version of foldr -foldrM :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a -foldrM _ z [] = return z -foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r } - --- | Monadic version of fmap specialised for Maybe -maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) -maybeMapM _ Nothing = return Nothing -maybeMapM m (Just x) = liftM Just $ m x - --- | Monadic version of @when@, taking the condition in the monad -whenM :: Monad m => m Bool -> m () -> m () -whenM mb thing = do { b <- mb - ; when b thing } - --- | Monadic version of @unless@, taking the condition in the monad -unlessM :: Monad m => m Bool -> m () -> m () -unlessM condM acc = do { cond <- condM - ; unless cond acc } diff --git a/utils/OrdList.hs b/utils/OrdList.hs deleted file mode 100644 --- a/utils/OrdList.hs +++ /dev/null @@ -1,128 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - - -This is useful, general stuff for the Native Code Generator. - -Provide trees (of instructions), so that lists of instructions -can be appended in linear time. --} - -{-# LANGUAGE CPP #-} -module OrdList ( - OrdList, - nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL, - mapOL, fromOL, toOL, foldrOL, foldlOL -) where - -import Outputable - -#if __GLASGOW_HASKELL__ > 710 -import Data.Semigroup ( Semigroup ) -import qualified Data.Semigroup as Semigroup -#endif - -infixl 5 `appOL` -infixl 5 `snocOL` -infixr 5 `consOL` - -data OrdList a - = None - | One a - | Many [a] -- Invariant: non-empty - | Cons a (OrdList a) - | Snoc (OrdList a) a - | Two (OrdList a) -- Invariant: non-empty - (OrdList a) -- Invariant: non-empty - -instance Outputable a => Outputable (OrdList a) where - ppr ol = ppr (fromOL ol) -- Convert to list and print that - -#if __GLASGOW_HASKELL__ > 710 -instance Semigroup (OrdList a) where - (<>) = appOL -#endif - -instance Monoid (OrdList a) where - mempty = nilOL - mappend = appOL - mconcat = concatOL - -instance Functor OrdList where - fmap = mapOL - -instance Foldable OrdList where - foldr = foldrOL - -instance Traversable OrdList where - traverse f xs = toOL <$> traverse f (fromOL xs) - -nilOL :: OrdList a -isNilOL :: OrdList a -> Bool - -unitOL :: a -> OrdList a -snocOL :: OrdList a -> a -> OrdList a -consOL :: a -> OrdList a -> OrdList a -appOL :: OrdList a -> OrdList a -> OrdList a -concatOL :: [OrdList a] -> OrdList a -lastOL :: OrdList a -> a - -nilOL = None -unitOL as = One as -snocOL as b = Snoc as b -consOL a bs = Cons a bs -concatOL aas = foldr appOL None aas - -lastOL None = panic "lastOL" -lastOL (One a) = a -lastOL (Many as) = last as -lastOL (Cons _ as) = lastOL as -lastOL (Snoc _ a) = a -lastOL (Two _ as) = lastOL as - -isNilOL None = True -isNilOL _ = False - -None `appOL` b = b -a `appOL` None = a -One a `appOL` b = Cons a b -a `appOL` One b = Snoc a b -a `appOL` b = Two a b - -fromOL :: OrdList a -> [a] -fromOL a = go a [] - where go None acc = acc - go (One a) acc = a : acc - go (Cons a b) acc = a : go b acc - go (Snoc a b) acc = go a (b:acc) - go (Two a b) acc = go a (go b acc) - go (Many xs) acc = xs ++ acc - -mapOL :: (a -> b) -> OrdList a -> OrdList b -mapOL _ None = None -mapOL f (One x) = One (f x) -mapOL f (Cons x xs) = Cons (f x) (mapOL f xs) -mapOL f (Snoc xs x) = Snoc (mapOL f xs) (f x) -mapOL f (Two x y) = Two (mapOL f x) (mapOL f y) -mapOL f (Many xs) = Many (map f xs) - -foldrOL :: (a->b->b) -> b -> OrdList a -> b -foldrOL _ z None = z -foldrOL k z (One x) = k x z -foldrOL k z (Cons x xs) = k x (foldrOL k z xs) -foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs -foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1 -foldrOL k z (Many xs) = foldr k z xs - -foldlOL :: (b->a->b) -> b -> OrdList a -> b -foldlOL _ z None = z -foldlOL k z (One x) = k z x -foldlOL k z (Cons x xs) = foldlOL k (k z x) xs -foldlOL k z (Snoc xs x) = k (foldlOL k z xs) x -foldlOL k z (Two b1 b2) = foldlOL k (foldlOL k z b1) b2 -foldlOL k z (Many xs) = foldl k z xs - -toOL :: [a] -> OrdList a -toOL [] = None -toOL xs = Many xs diff --git a/utils/Outputable.hs b/utils/Outputable.hs deleted file mode 100644 --- a/utils/Outputable.hs +++ /dev/null @@ -1,1194 +0,0 @@ -{-# LANGUAGE CPP, ImplicitParams #-} -{- -(c) The University of Glasgow 2006-2012 -(c) The GRASP Project, Glasgow University, 1992-1998 --} - --- | This module defines classes and functions for pretty-printing. It also --- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. --- --- The interface to this module is very similar to the standard Hughes-PJ pretty printing --- module, except that it exports a number of additional functions that are rarely used, --- and works over the 'SDoc' type. -module Outputable ( - -- * Type classes - Outputable(..), OutputableBndr(..), - - -- * Pretty printing combinators - SDoc, runSDoc, initSDocContext, - docToSDoc, sdocWithPprDebug, - interppSP, interpp'SP, - pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, - pprWithBars, - empty, isEmpty, nest, - char, - text, ftext, ptext, ztext, - int, intWithCommas, integer, float, double, rational, doublePrec, - parens, cparen, brackets, braces, quotes, quote, - doubleQuotes, angleBrackets, paBrackets, - semi, comma, colon, dcolon, space, equals, dot, vbar, - arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, - blankLine, forAllLit, kindStar, bullet, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, - hang, hangNotEmpty, punctuate, ppWhen, ppUnless, - speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, - unicodeSyntax, - - coloured, keyword, - - -- * Converting 'SDoc' into strings and outputing it - printSDoc, printSDocLn, printForUser, printForUserPartWay, - printForC, bufLeftRenderSDoc, - pprCode, mkCodeStyle, - showSDoc, showSDocUnsafe, showSDocOneLine, - showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, - showSDocUnqual, showPpr, - renderWithStyle, - - pprInfixVar, pprPrefixVar, - pprHsChar, pprHsString, pprHsBytes, - - primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix, - primInt64Suffix, primWord64Suffix, primIntSuffix, - - pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64, - - pprFastFilePath, - - -- * Controlling the style in which output is printed - BindingSite(..), - - PprStyle, CodeStyle(..), PrintUnqualified(..), - QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, - reallyAlwaysQualify, reallyAlwaysQualifyNames, - alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, - neverQualify, neverQualifyNames, neverQualifyModules, - alwaysQualifyPackages, neverQualifyPackages, - QualifyName(..), queryQual, - sdocWithDynFlags, sdocWithPlatform, - getPprStyle, withPprStyle, withPprStyleDoc, setStyleColoured, - pprDeeper, pprDeeperList, pprSetDepth, - codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - ifPprDebug, qualName, qualModule, qualPackage, - mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, - mkUserStyle, cmdlineParserStyle, Depth(..), - - -- * Error handling and debugging utilities - pprPanic, pprSorry, assertPprPanic, pprPgmError, - pprTrace, pprTraceDebug, pprTraceIt, warnPprTrace, pprSTrace, - trace, pgmError, panic, sorry, assertPanic, - pprDebugAndThen, callStackDoc - ) where - -import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput, - targetPlatform, pprUserLength, pprCols, - useUnicode, useUnicodeSyntax, - shouldUseColor, unsafeGlobalDynFlags ) -import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) -import {-# SOURCE #-} OccName( OccName ) - -import BufWrite (BufHandle) -import FastString -import qualified Pretty -import Util -import Platform -import qualified PprColour as Col -import Pretty ( Doc, Mode(..) ) -import Panic -import GHC.Serialized -import GHC.LanguageExtensions (Extension) - -import Control.Exception (finally) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Char -import qualified Data.Map as M -import Data.Int -import qualified Data.IntMap as IM -import Data.Set (Set) -import qualified Data.Set as Set -import Data.String -import Data.Word -import System.IO ( Handle ) -import System.FilePath -import Text.Printf -import Numeric (showFFloat) -import Data.Graph (SCC(..)) -import Data.List (intersperse) - -import GHC.Fingerprint -import GHC.Show ( showMultiLineString ) - -{- -************************************************************************ -* * -\subsection{The @PprStyle@ data type} -* * -************************************************************************ --} - -data PprStyle - = PprUser PrintUnqualified Depth Coloured - -- Pretty-print in a way that will make sense to the - -- ordinary user; must be very close to Haskell - -- syntax, etc. - -- Assumes printing tidied code: non-system names are - -- printed without uniques. - - | PprDump PrintUnqualified - -- For -ddump-foo; less verbose than PprDebug, but more than PprUser - -- Does not assume tidied code: non-external names - -- are printed with uniques. - - | PprDebug -- Full debugging output - - | PprCode CodeStyle - -- Print code; either C or assembler - -data CodeStyle = CStyle -- The format of labels differs for C and assembler - | AsmStyle - -data Depth = AllTheWay - | PartWay Int -- 0 => stop - -data Coloured - = Uncoloured - | Coloured - --- ----------------------------------------------------------------------------- --- Printing original names - --- | When printing code that contains original names, we need to map the --- original names back to something the user understands. This is the --- purpose of the triple of functions that gets passed around --- when rendering 'SDoc'. -data PrintUnqualified = QueryQualify { - queryQualifyName :: QueryQualifyName, - queryQualifyModule :: QueryQualifyModule, - queryQualifyPackage :: QueryQualifyPackage -} - --- | given an /original/ name, this function tells you which module --- name it should be qualified with when printing for the user, if --- any. For example, given @Control.Exception.catch@, which is in scope --- as @Exception.catch@, this function will return @Just "Exception"@. --- Note that the return value is a ModuleName, not a Module, because --- in source code, names are qualified by ModuleNames. -type QueryQualifyName = Module -> OccName -> QualifyName - --- | For a given module, we need to know whether to print it with --- a package name to disambiguate it. -type QueryQualifyModule = Module -> Bool - --- | For a given package, we need to know whether to print it with --- the component id to disambiguate it. -type QueryQualifyPackage = UnitId -> Bool - --- See Note [Printing original names] in HscTypes -data QualifyName -- Given P:M.T - = NameUnqual -- It's in scope unqualified as "T" - -- OR nothing called "T" is in scope - - | NameQual ModuleName -- It's in scope qualified as "X.T" - - | NameNotInScope1 -- It's not in scope at all, but M.T is not bound - -- in the current scope, so we can refer to it as "M.T" - - | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in - -- the current scope, so we must refer to it as "P:M.T" - -instance Outputable QualifyName where - ppr NameUnqual = text "NameUnqual" - ppr (NameQual _mod) = text "NameQual" -- can't print the mod without module loops :( - ppr NameNotInScope1 = text "NameNotInScope1" - ppr NameNotInScope2 = text "NameNotInScope2" - -reallyAlwaysQualifyNames :: QueryQualifyName -reallyAlwaysQualifyNames _ _ = NameNotInScope2 - --- | NB: This won't ever show package IDs -alwaysQualifyNames :: QueryQualifyName -alwaysQualifyNames m _ = NameQual (moduleName m) - -neverQualifyNames :: QueryQualifyName -neverQualifyNames _ _ = NameUnqual - -alwaysQualifyModules :: QueryQualifyModule -alwaysQualifyModules _ = True - -neverQualifyModules :: QueryQualifyModule -neverQualifyModules _ = False - -alwaysQualifyPackages :: QueryQualifyPackage -alwaysQualifyPackages _ = True - -neverQualifyPackages :: QueryQualifyPackage -neverQualifyPackages _ = False - -reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified -reallyAlwaysQualify - = QueryQualify reallyAlwaysQualifyNames - alwaysQualifyModules - alwaysQualifyPackages -alwaysQualify = QueryQualify alwaysQualifyNames - alwaysQualifyModules - alwaysQualifyPackages -neverQualify = QueryQualify neverQualifyNames - neverQualifyModules - neverQualifyPackages - -defaultUserStyle :: DynFlags -> PprStyle -defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay - -defaultDumpStyle :: DynFlags -> PprStyle - -- Print without qualifiers to reduce verbosity, unless -dppr-debug -defaultDumpStyle dflags - | hasPprDebug dflags = PprDebug - | otherwise = PprDump neverQualify - -mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle -mkDumpStyle dflags print_unqual - | hasPprDebug dflags = PprDebug - | otherwise = PprDump print_unqual - -defaultErrStyle :: DynFlags -> PprStyle --- Default style for error messages, when we don't know PrintUnqualified --- It's a bit of a hack because it doesn't take into account what's in scope --- Only used for desugarer warnings, and typechecker errors in interface sigs --- NB that -dppr-debug will still get into PprDebug style -defaultErrStyle dflags = mkErrStyle dflags neverQualify - --- | Style for printing error messages -mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle -mkErrStyle dflags qual = - mkUserStyle dflags qual (PartWay (pprUserLength dflags)) - -cmdlineParserStyle :: DynFlags -> PprStyle -cmdlineParserStyle dflags = mkUserStyle dflags alwaysQualify AllTheWay - -mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle -mkUserStyle dflags unqual depth - | hasPprDebug dflags = PprDebug - | otherwise = PprUser unqual depth Uncoloured - -setStyleColoured :: Bool -> PprStyle -> PprStyle -setStyleColoured col style = - case style of - PprUser q d _ -> PprUser q d c - _ -> style - where - c | col = Coloured - | otherwise = Uncoloured - -instance Outputable PprStyle where - ppr (PprUser {}) = text "user-style" - ppr (PprCode {}) = text "code-style" - ppr (PprDump {}) = text "dump-style" - ppr (PprDebug {}) = text "debug-style" - -{- -Orthogonal to the above printing styles are (possibly) some -command-line flags that affect printing (often carried with the -style). The most likely ones are variations on how much type info is -shown. - -The following test decides whether or not we are actually generating -code (either C or assembly), or generating interface files. - -************************************************************************ -* * -\subsection{The @SDoc@ data type} -* * -************************************************************************ --} - --- | Represents a pretty-printable document. --- --- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc', --- or 'renderWithStyle'. Avoid calling 'runSDoc' directly as it breaks the --- abstraction layer. -newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } - -data SDocContext = SDC - { sdocStyle :: !PprStyle - , sdocLastColour :: !Col.PprColour - -- ^ The most recently used colour. This allows nesting colours. - , sdocDynFlags :: !DynFlags - } - -instance IsString SDoc where - fromString = text - -initSDocContext :: DynFlags -> PprStyle -> SDocContext -initSDocContext dflags sty = SDC - { sdocStyle = sty - , sdocLastColour = Col.colReset - , sdocDynFlags = dflags - } - -withPprStyle :: PprStyle -> SDoc -> SDoc -withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} - --- | This is not a recommended way to render 'SDoc', since it breaks the --- abstraction layer of 'SDoc'. Prefer to use 'printSDoc', 'printSDocLn', --- 'bufLeftRenderSDoc', or 'renderWithStyle' instead. -withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc -withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty) - -sdocWithPprDebug :: (Bool -> SDoc) -> SDoc -sdocWithPprDebug f = sdocWithDynFlags $ \dflags -> f (hasPprDebug dflags) - -pprDeeper :: SDoc -> SDoc -pprDeeper d = SDoc $ \ctx -> case ctx of - SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..." - SDC{sdocStyle=PprUser q (PartWay n) c} -> - runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c} - _ -> runSDoc d ctx - --- | Truncate a list that is longer than the current depth. -pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc -pprDeeperList f ds - | null ds = f [] - | otherwise = SDoc work - where - work ctx@SDC{sdocStyle=PprUser q (PartWay n) c} - | n==0 = Pretty.text "..." - | otherwise = - runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c} - where - go _ [] = [] - go i (d:ds) | i >= n = [text "...."] - | otherwise = d : go (i+1) ds - work other_ctx = runSDoc (f ds) other_ctx - -pprSetDepth :: Depth -> SDoc -> SDoc -pprSetDepth depth doc = SDoc $ \ctx -> - case ctx of - SDC{sdocStyle=PprUser q _ c} -> - runSDoc doc ctx{sdocStyle = PprUser q depth c} - _ -> - runSDoc doc ctx - -getPprStyle :: (PprStyle -> SDoc) -> SDoc -getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx - -sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc -sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx - -sdocWithPlatform :: (Platform -> SDoc) -> SDoc -sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) - -qualName :: PprStyle -> QueryQualifyName -qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ -qualName (PprDump q) mod occ = queryQualifyName q mod occ -qualName _other mod _ = NameQual (moduleName mod) - -qualModule :: PprStyle -> QueryQualifyModule -qualModule (PprUser q _ _) m = queryQualifyModule q m -qualModule (PprDump q) m = queryQualifyModule q m -qualModule _other _m = True - -qualPackage :: PprStyle -> QueryQualifyPackage -qualPackage (PprUser q _ _) m = queryQualifyPackage q m -qualPackage (PprDump q) m = queryQualifyPackage q m -qualPackage _other _m = True - -queryQual :: PprStyle -> PrintUnqualified -queryQual s = QueryQualify (qualName s) - (qualModule s) - (qualPackage s) - -codeStyle :: PprStyle -> Bool -codeStyle (PprCode _) = True -codeStyle _ = False - -asmStyle :: PprStyle -> Bool -asmStyle (PprCode AsmStyle) = True -asmStyle _other = False - -dumpStyle :: PprStyle -> Bool -dumpStyle (PprDump {}) = True -dumpStyle _other = False - -debugStyle :: PprStyle -> Bool -debugStyle PprDebug = True -debugStyle _other = False - -userStyle :: PprStyle -> Bool -userStyle (PprUser {}) = True -userStyle _other = False - -ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style -ifPprDebug d = SDoc $ \ctx -> - case ctx of - SDC{sdocStyle=PprDebug} -> runSDoc d ctx - _ -> Pretty.empty - --- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the --- terminal doesn't get screwed up by the ANSI color codes if an exception --- is thrown during pretty-printing. -printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () -printSDoc mode dflags handle sty doc = - Pretty.printDoc_ mode cols handle (runSDoc doc ctx) - `finally` - Pretty.printDoc_ mode cols handle - (runSDoc (coloured Col.colReset empty) ctx) - where - cols = pprCols dflags - ctx = initSDocContext dflags sty - --- | Like 'printSDoc' but appends an extra newline. -printSDocLn :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () -printSDocLn mode dflags handle sty doc = - printSDoc mode dflags handle sty (doc $$ text "") - -printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () -printForUser dflags handle unqual doc - = printSDocLn PageMode dflags handle - (mkUserStyle dflags unqual AllTheWay) doc - -printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc - -> IO () -printForUserPartWay dflags handle d unqual doc - = printSDocLn PageMode dflags handle - (mkUserStyle dflags unqual (PartWay d)) doc - --- | Like 'printSDocLn' but specialized with 'LeftMode' and --- @'PprCode' 'CStyle'@. This is typically used to output C-- code. -printForC :: DynFlags -> Handle -> SDoc -> IO () -printForC dflags handle doc = - printSDocLn LeftMode dflags handle (PprCode CStyle) doc - --- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that --- outputs to a 'BufHandle'. -bufLeftRenderSDoc :: DynFlags -> BufHandle -> PprStyle -> SDoc -> IO () -bufLeftRenderSDoc dflags bufHandle sty doc = - Pretty.bufLeftRender bufHandle (runSDoc doc (initSDocContext dflags sty)) - -pprCode :: CodeStyle -> SDoc -> SDoc -pprCode cs d = withPprStyle (PprCode cs) d - -mkCodeStyle :: CodeStyle -> PprStyle -mkCodeStyle = PprCode - --- Can't make SDoc an instance of Show because SDoc is just a function type --- However, Doc *is* an instance of Show --- showSDoc just blasts it out as a string -showSDoc :: DynFlags -> SDoc -> String -showSDoc dflags sdoc = renderWithStyle dflags sdoc (defaultUserStyle dflags) - --- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be --- initialised yet. -showSDocUnsafe :: SDoc -> String -showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc - -showPpr :: Outputable a => DynFlags -> a -> String -showPpr dflags thing = showSDoc dflags (ppr thing) - -showSDocUnqual :: DynFlags -> SDoc -> String --- Only used by Haddock -showSDocUnqual dflags sdoc = showSDoc dflags sdoc - -showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String --- Allows caller to specify the PrintUnqualified to use -showSDocForUser dflags unqual doc - = renderWithStyle dflags doc (mkUserStyle dflags unqual AllTheWay) - -showSDocDump :: DynFlags -> SDoc -> String -showSDocDump dflags d = renderWithStyle dflags d (defaultDumpStyle dflags) - -showSDocDebug :: DynFlags -> SDoc -> String -showSDocDebug dflags d = renderWithStyle dflags d PprDebug - -renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String -renderWithStyle dflags sdoc sty - = let s = Pretty.style{ Pretty.mode = PageMode, - Pretty.lineLength = pprCols dflags } - in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty) - --- This shows an SDoc, but on one line only. It's cheaper than a full --- showSDoc, designed for when we're getting results like "Foo.bar" --- and "foo{uniq strictness}" so we don't want fancy layout anyway. -showSDocOneLine :: DynFlags -> SDoc -> String -showSDocOneLine dflags d - = let s = Pretty.style{ Pretty.mode = OneLineMode, - Pretty.lineLength = pprCols dflags } in - Pretty.renderStyle s $ - runSDoc d (initSDocContext dflags (defaultUserStyle dflags)) - -showSDocDumpOneLine :: DynFlags -> SDoc -> String -showSDocDumpOneLine dflags d - = let s = Pretty.style{ Pretty.mode = OneLineMode, - Pretty.lineLength = irrelevantNCols } in - Pretty.renderStyle s $ - runSDoc d (initSDocContext dflags (defaultDumpStyle dflags)) - -irrelevantNCols :: Int --- Used for OneLineMode and LeftMode when number of cols isn't used -irrelevantNCols = 1 - -isEmpty :: DynFlags -> SDoc -> Bool -isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext - where dummySDocContext = initSDocContext dflags PprDebug - -docToSDoc :: Doc -> SDoc -docToSDoc d = SDoc (\_ -> d) - -empty :: SDoc -char :: Char -> SDoc -text :: String -> SDoc -ftext :: FastString -> SDoc -ptext :: LitString -> SDoc -ztext :: FastZString -> SDoc -int :: Int -> SDoc -integer :: Integer -> SDoc -float :: Float -> SDoc -double :: Double -> SDoc -rational :: Rational -> SDoc - -empty = docToSDoc $ Pretty.empty -char c = docToSDoc $ Pretty.char c - -text s = docToSDoc $ Pretty.text s -{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire - -ftext s = docToSDoc $ Pretty.ftext s -ptext s = docToSDoc $ Pretty.ptext s -ztext s = docToSDoc $ Pretty.ztext s -int n = docToSDoc $ Pretty.int n -integer n = docToSDoc $ Pretty.integer n -float n = docToSDoc $ Pretty.float n -double n = docToSDoc $ Pretty.double n -rational n = docToSDoc $ Pretty.rational n - --- | @doublePrec p n@ shows a floating point number @n@ with @p@ --- digits of precision after the decimal point. -doublePrec :: Int -> Double -> SDoc -doublePrec p n = text (showFFloat (Just p) n "") - -parens, braces, brackets, quotes, quote, - paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc - -parens d = SDoc $ Pretty.parens . runSDoc d -braces d = SDoc $ Pretty.braces . runSDoc d -brackets d = SDoc $ Pretty.brackets . runSDoc d -quote d = SDoc $ Pretty.quote . runSDoc d -doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d -angleBrackets d = char '<' <> d <> char '>' -paBrackets d = text "[:" <> d <> text ":]" - -cparen :: Bool -> SDoc -> SDoc -cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d - --- 'quotes' encloses something in single quotes... --- but it omits them if the thing begins or ends in a single quote --- so that we don't get `foo''. Instead we just have foo'. -quotes d = - sdocWithDynFlags $ \dflags -> - if useUnicode dflags - then char '‘' <> d <> char '’' - else SDoc $ \sty -> - let pp_d = runSDoc d sty - str = show pp_d - in case (str, snocView str) of - (_, Just (_, '\'')) -> pp_d - ('\'' : _, _) -> pp_d - _other -> Pretty.quotes pp_d - -semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc -arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc -lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc - -blankLine = docToSDoc $ Pretty.text "" -dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") -arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") -larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") -darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") -arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") -larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") -arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") -larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") -semi = docToSDoc $ Pretty.semi -comma = docToSDoc $ Pretty.comma -colon = docToSDoc $ Pretty.colon -equals = docToSDoc $ Pretty.equals -space = docToSDoc $ Pretty.space -underscore = char '_' -dot = char '.' -vbar = char '|' -lparen = docToSDoc $ Pretty.lparen -rparen = docToSDoc $ Pretty.rparen -lbrack = docToSDoc $ Pretty.lbrack -rbrack = docToSDoc $ Pretty.rbrack -lbrace = docToSDoc $ Pretty.lbrace -rbrace = docToSDoc $ Pretty.rbrace - -forAllLit :: SDoc -forAllLit = unicodeSyntax (char '∀') (text "forall") - -kindStar :: SDoc -kindStar = unicodeSyntax (char '★') (char '*') - -bullet :: SDoc -bullet = unicode (char '•') (char '*') - -unicodeSyntax :: SDoc -> SDoc -> SDoc -unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags -> - if useUnicode dflags && useUnicodeSyntax dflags - then unicode - else plain - -unicode :: SDoc -> SDoc -> SDoc -unicode unicode plain = sdocWithDynFlags $ \dflags -> - if useUnicode dflags - then unicode - else plain - -nest :: Int -> SDoc -> SDoc --- ^ Indent 'SDoc' some specified amount -(<>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally without a gap -(<+>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally with a gap between them -($$) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together vertically; if there is --- no vertical overlap it "dovetails" the two onto one line -($+$) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together vertically - -nest n d = SDoc $ Pretty.nest n . runSDoc d -(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) -(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) -($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) -($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) - -hcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally -hsep :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally with a space between each one -vcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' vertically with dovetailing -sep :: [SDoc] -> SDoc --- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits -cat :: [SDoc] -> SDoc --- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits -fsep :: [SDoc] -> SDoc --- ^ A paragraph-fill combinator. It's much like sep, only it --- keeps fitting things on one line until it can't fit any more. -fcat :: [SDoc] -> SDoc --- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' - - -hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] -hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] -vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] -sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] -cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] -fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] -fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] - -hang :: SDoc -- ^ The header - -> Int -- ^ Amount to indent the hung body - -> SDoc -- ^ The hung body, indented and placed below the header - -> SDoc -hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) - --- | This behaves like 'hang', but does not indent the second document --- when the header is empty. -hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc -hangNotEmpty d1 n d2 = - SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty) - -punctuate :: SDoc -- ^ The punctuation - -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements - -> [SDoc] -- ^ Punctuated list -punctuate _ [] = [] -punctuate p (d:ds) = go d ds - where - go d [] = [d] - go d (e:es) = (d <> p) : go e es - -ppWhen, ppUnless :: Bool -> SDoc -> SDoc -ppWhen True doc = doc -ppWhen False _ = empty - -ppUnless True _ = empty -ppUnless False doc = doc - --- | Apply the given colour\/style for the argument. --- --- Only takes effect if colours are enabled. -coloured :: Col.PprColour -> SDoc -> SDoc -coloured col sdoc = - sdocWithDynFlags $ \dflags -> - if shouldUseColor dflags - then SDoc $ \ctx@SDC{ sdocLastColour = lastCol } -> - case ctx of - SDC{ sdocStyle = PprUser _ _ Coloured } -> - let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in - Pretty.zeroWidthText (Col.renderColour col) - Pretty.<> runSDoc sdoc ctx' - Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol) - _ -> runSDoc sdoc ctx - else sdoc - -keyword :: SDoc -> SDoc -keyword = coloured Col.colBold - -{- -************************************************************************ -* * -\subsection[Outputable-class]{The @Outputable@ class} -* * -************************************************************************ --} - --- | Class designating that some type has an 'SDoc' representation -class Outputable a where - ppr :: a -> SDoc - pprPrec :: Rational -> a -> SDoc - -- 0 binds least tightly - -- We use Rational because there is always a - -- Rational between any other two Rationals - - ppr = pprPrec 0 - pprPrec _ = ppr - -instance Outputable Char where - ppr c = text [c] - -instance Outputable Bool where - ppr True = text "True" - ppr False = text "False" - -instance Outputable Ordering where - ppr LT = text "LT" - ppr EQ = text "EQ" - ppr GT = text "GT" - -instance Outputable Int32 where - ppr n = integer $ fromIntegral n - -instance Outputable Int64 where - ppr n = integer $ fromIntegral n - -instance Outputable Int where - ppr n = int n - -instance Outputable Word16 where - ppr n = integer $ fromIntegral n - -instance Outputable Word32 where - ppr n = integer $ fromIntegral n - -instance Outputable Word where - ppr n = integer $ fromIntegral n - -instance Outputable () where - ppr _ = text "()" - -instance (Outputable a) => Outputable [a] where - ppr xs = brackets (fsep (punctuate comma (map ppr xs))) - -instance (Outputable a) => Outputable (Set a) where - ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) - -instance (Outputable a, Outputable b) => Outputable (a, b) where - ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) - -instance Outputable a => Outputable (Maybe a) where - ppr Nothing = text "Nothing" - ppr (Just x) = text "Just" <+> ppr x - -instance (Outputable a, Outputable b) => Outputable (Either a b) where - ppr (Left x) = text "Left" <+> ppr x - ppr (Right y) = text "Right" <+> ppr y - --- ToDo: may not be used -instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where - ppr (x,y,z) = - parens (sep [ppr x <> comma, - ppr y <> comma, - ppr z ]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d) => - Outputable (a, b, c, d) where - ppr (a,b,c,d) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => - Outputable (a, b, c, d, e) where - ppr (a,b,c,d,e) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d <> comma, - ppr e]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => - Outputable (a, b, c, d, e, f) where - ppr (a,b,c,d,e,f) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d <> comma, - ppr e <> comma, - ppr f]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => - Outputable (a, b, c, d, e, f, g) where - ppr (a,b,c,d,e,f,g) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d <> comma, - ppr e <> comma, - ppr f <> comma, - ppr g]) - -instance Outputable FastString where - ppr fs = ftext fs -- Prints an unadorned string, - -- no double quotes or anything - -instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where - ppr m = ppr (M.toList m) -instance (Outputable elt) => Outputable (IM.IntMap elt) where - ppr m = ppr (IM.toList m) - -instance Outputable Fingerprint where - ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) - -instance Outputable a => Outputable (SCC a) where - ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) - ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) - -instance Outputable Serialized where - ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) - -instance Outputable Extension where - ppr = text . show - -{- -************************************************************************ -* * -\subsection{The @OutputableBndr@ class} -* * -************************************************************************ --} - --- | 'BindingSite' is used to tell the thing that prints binder what --- language construct is binding the identifier. This can be used --- to decide how much info to print. --- Also see Note [Binding-site specific printing] in PprCore -data BindingSite - = LambdaBind -- ^ The x in (\x. e) - | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... } - | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... } - | LetBind -- ^ The x in (let x = rhs in e) - --- | When we print a binder, we often want to print its type too. --- The @OutputableBndr@ class encapsulates this idea. -class Outputable a => OutputableBndr a where - pprBndr :: BindingSite -> a -> SDoc - pprBndr _b x = ppr x - - pprPrefixOcc, pprInfixOcc :: a -> SDoc - -- Print an occurrence of the name, suitable either in the - -- prefix position of an application, thus (f a b) or ((+) x) - -- or infix position, thus (a `f` b) or (x + y) - - bndrIsJoin_maybe :: a -> Maybe Int - bndrIsJoin_maybe _ = Nothing - -- When pretty-printing we sometimes want to find - -- whether the binder is a join point. You might think - -- we could have a function of type (a->Var), but Var - -- isn't available yet, alas - -{- -************************************************************************ -* * -\subsection{Random printing helpers} -* * -************************************************************************ --} - --- We have 31-bit Chars and will simply use Show instances of Char and String. - --- | Special combinator for showing character literals. -pprHsChar :: Char -> SDoc -pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) - | otherwise = text (show c) - --- | Special combinator for showing string literals. -pprHsString :: FastString -> SDoc -pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) - --- | Special combinator for showing bytestring literals. -pprHsBytes :: ByteString -> SDoc -pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs - in vcat (map text (showMultiLineString escaped)) <> char '#' - where escape :: Word8 -> String - escape w = let c = chr (fromIntegral w) - in if isAscii c - then [c] - else '\\' : show w - --- Postfix modifiers for unboxed literals. --- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`. -primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc -primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc -primCharSuffix = char '#' -primFloatSuffix = char '#' -primIntSuffix = char '#' -primDoubleSuffix = text "##" -primWordSuffix = text "##" -primInt64Suffix = text "L#" -primWord64Suffix = text "L##" - --- | Special combinator for showing unboxed literals. -pprPrimChar :: Char -> SDoc -pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc -pprPrimChar c = pprHsChar c <> primCharSuffix -pprPrimInt i = integer i <> primIntSuffix -pprPrimWord w = integer w <> primWordSuffix -pprPrimInt64 i = integer i <> primInt64Suffix -pprPrimWord64 w = integer w <> primWord64Suffix - ---------------------- --- Put a name in parens if it's an operator -pprPrefixVar :: Bool -> SDoc -> SDoc -pprPrefixVar is_operator pp_v - | is_operator = parens pp_v - | otherwise = pp_v - --- Put a name in backquotes if it's not an operator -pprInfixVar :: Bool -> SDoc -> SDoc -pprInfixVar is_operator pp_v - | is_operator = pp_v - | otherwise = char '`' <> pp_v <> char '`' - ---------------------- -pprFastFilePath :: FastString -> SDoc -pprFastFilePath path = text $ normalise $ unpackFS path - -{- -************************************************************************ -* * -\subsection{Other helper functions} -* * -************************************************************************ --} - -pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use - -> [a] -- ^ The things to be pretty printed - -> SDoc -- ^ 'SDoc' where the things have been pretty printed, - -- comma-separated and finally packed into a paragraph. -pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) - -pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use - -> [a] -- ^ The things to be pretty printed - -> SDoc -- ^ 'SDoc' where the things have been pretty printed, - -- bar-separated and finally packed into a paragraph. -pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) - --- | Returns the separated concatenation of the pretty printed things. -interppSP :: Outputable a => [a] -> SDoc -interppSP xs = sep (map ppr xs) - --- | Returns the comma-separated concatenation of the pretty printed things. -interpp'SP :: Outputable a => [a] -> SDoc -interpp'SP xs = sep (punctuate comma (map ppr xs)) - --- | Returns the comma-separated concatenation of the quoted pretty printed things. --- --- > [x,y,z] ==> `x', `y', `z' -pprQuotedList :: Outputable a => [a] -> SDoc -pprQuotedList = quotedList . map ppr - -quotedList :: [SDoc] -> SDoc -quotedList xs = hsep (punctuate comma (map quotes xs)) - -quotedListWithOr :: [SDoc] -> SDoc --- [x,y,z] ==> `x', `y' or `z' -quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs) -quotedListWithOr xs = quotedList xs - -quotedListWithNor :: [SDoc] -> SDoc --- [x,y,z] ==> `x', `y' nor `z' -quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) -quotedListWithNor xs = quotedList xs - -{- -************************************************************************ -* * -\subsection{Printing numbers verbally} -* * -************************************************************************ --} - -intWithCommas :: Integral a => a -> SDoc --- Prints a big integer with commas, eg 345,821 -intWithCommas n - | n < 0 = char '-' <> intWithCommas (-n) - | q == 0 = int (fromIntegral r) - | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r) - where - (q,r) = n `quotRem` 1000 - zeroes | r >= 100 = empty - | r >= 10 = char '0' - | otherwise = text "00" - --- | Converts an integer to a verbal index: --- --- > speakNth 1 = text "first" --- > speakNth 5 = text "fifth" --- > speakNth 21 = text "21st" -speakNth :: Int -> SDoc -speakNth 1 = text "first" -speakNth 2 = text "second" -speakNth 3 = text "third" -speakNth 4 = text "fourth" -speakNth 5 = text "fifth" -speakNth 6 = text "sixth" -speakNth n = hcat [ int n, text suffix ] - where - suffix | n <= 20 = "th" -- 11,12,13 are non-std - | last_dig == 1 = "st" - | last_dig == 2 = "nd" - | last_dig == 3 = "rd" - | otherwise = "th" - - last_dig = n `rem` 10 - --- | Converts an integer to a verbal multiplicity: --- --- > speakN 0 = text "none" --- > speakN 5 = text "five" --- > speakN 10 = text "10" -speakN :: Int -> SDoc -speakN 0 = text "none" -- E.g. "he has none" -speakN 1 = text "one" -- E.g. "he has one" -speakN 2 = text "two" -speakN 3 = text "three" -speakN 4 = text "four" -speakN 5 = text "five" -speakN 6 = text "six" -speakN n = int n - --- | Converts an integer and object description to a statement about the --- multiplicity of those objects: --- --- > speakNOf 0 (text "melon") = text "no melons" --- > speakNOf 1 (text "melon") = text "one melon" --- > speakNOf 3 (text "melon") = text "three melons" -speakNOf :: Int -> SDoc -> SDoc -speakNOf 0 d = text "no" <+> d <> char 's' -speakNOf 1 d = text "one" <+> d -- E.g. "one argument" -speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" - --- | Determines the pluralisation suffix appropriate for the length of a list: --- --- > plural [] = char 's' --- > plural ["Hello"] = empty --- > plural ["Hello", "World"] = char 's' -plural :: [a] -> SDoc -plural [_] = empty -- a bit frightening, but there you are -plural _ = char 's' - --- | Determines the form of to be appropriate for the length of a list: --- --- > isOrAre [] = text "are" --- > isOrAre ["Hello"] = text "is" --- > isOrAre ["Hello", "World"] = text "are" -isOrAre :: [a] -> SDoc -isOrAre [_] = text "is" -isOrAre _ = text "are" - --- | Determines the form of to do appropriate for the length of a list: --- --- > doOrDoes [] = text "do" --- > doOrDoes ["Hello"] = text "does" --- > doOrDoes ["Hello", "World"] = text "do" -doOrDoes :: [a] -> SDoc -doOrDoes [_] = text "does" -doOrDoes _ = text "do" - -{- -************************************************************************ -* * -\subsection{Error handling} -* * -************************************************************************ --} - -callStackDoc :: HasCallStack => SDoc -callStackDoc = - hang (text "Call stack:") 4 (vcat $ map text $ lines prettyCurrentCallStack) - -pprPanic :: HasCallStack => String -> SDoc -> a --- ^ Throw an exception saying "bug in GHC" -pprPanic s doc = panicDoc s (doc $$ callStackDoc) - -pprSorry :: String -> SDoc -> a --- ^ Throw an exception saying "this isn't finished yet" -pprSorry = sorryDoc - - -pprPgmError :: String -> SDoc -> a --- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) -pprPgmError = pgmErrorDoc - -pprTraceDebug :: String -> SDoc -> a -> a -pprTraceDebug str doc x - | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x - | otherwise = x - -pprTrace :: String -> SDoc -> a -> a --- ^ If debug output is on, show some 'SDoc' on the screen -pprTrace str doc x - | hasNoDebugOutput unsafeGlobalDynFlags = x - | otherwise = - pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x - --- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@ -pprTraceIt :: Outputable a => String -> a -> a -pprTraceIt desc x = pprTrace desc (ppr x) x - - --- | If debug output is on, show some 'SDoc' on the screen along --- with a call stack when available. -pprSTrace :: HasCallStack => SDoc -> a -> a -pprSTrace doc = pprTrace "" (doc $$ callStackDoc) - -warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a --- ^ Just warn about an assertion failure, recording the given file and line number. --- Should typically be accessed with the WARN macros -warnPprTrace _ _ _ _ x | not debugIsOn = x -warnPprTrace _ _file _line _msg x - | hasNoDebugOutput unsafeGlobalDynFlags = x -warnPprTrace False _file _line _msg x = x -warnPprTrace True file line msg x - = pprDebugAndThen unsafeGlobalDynFlags trace heading msg x - where - heading = hsep [text "WARNING: file", text file <> comma, text "line", int line] - --- | Panic with an assertation failure, recording the given file and --- line number. Should typically be accessed with the ASSERT family of macros -assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a -assertPprPanic _file _line msg - = pprPanic "ASSERT failed!" doc - where - doc = sep [ msg, callStackDoc ] - -pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a -pprDebugAndThen dflags cont heading pretty_msg - = cont (showSDocDump dflags doc) - where - doc = sep [heading, nest 2 pretty_msg] diff --git a/utils/Outputable.hs-boot b/utils/Outputable.hs-boot deleted file mode 100644 --- a/utils/Outputable.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Outputable where - -data SDoc - -showSDocUnsafe :: SDoc -> String diff --git a/utils/Pair.hs b/utils/Pair.hs deleted file mode 100644 --- a/utils/Pair.hs +++ /dev/null @@ -1,54 +0,0 @@ -{- -A simple homogeneous pair type with useful Functor, Applicative, and -Traversable instances. --} - -{-# LANGUAGE CPP #-} - -module Pair ( Pair(..), unPair, toPair, swap, pLiftFst, pLiftSnd ) where - -#include "HsVersions.h" - -import Outputable - -data Pair a = Pair { pFst :: a, pSnd :: a } --- Note that Pair is a *unary* type constructor --- whereas (,) is binary - --- The important thing about Pair is that it has a *homogenous* --- Functor instance, so you can easily apply the same function --- to both components -instance Functor Pair where - fmap f (Pair x y) = Pair (f x) (f y) - -instance Applicative Pair where - pure x = Pair x x - (Pair f g) <*> (Pair x y) = Pair (f x) (g y) - -instance Foldable Pair where - foldMap f (Pair x y) = f x `mappend` f y - -instance Traversable Pair where - traverse f (Pair x y) = Pair <$> f x <*> f y - -instance Monoid a => Monoid (Pair a) where - mempty = Pair mempty mempty - Pair a1 b1 `mappend` Pair a2 b2 = Pair (a1 `mappend` a2) (b1 `mappend` b2) - -instance Outputable a => Outputable (Pair a) where - ppr (Pair a b) = ppr a <+> char '~' <+> ppr b - -unPair :: Pair a -> (a,a) -unPair (Pair x y) = (x,y) - -toPair :: (a,a) -> Pair a -toPair (x,y) = Pair x y - -swap :: Pair a -> Pair a -swap (Pair x y) = Pair y x - -pLiftFst :: (a -> a) -> Pair a -> Pair a -pLiftFst f (Pair a b) = Pair (f a) b - -pLiftSnd :: (a -> a) -> Pair a -> Pair a -pLiftSnd f (Pair a b) = Pair a (f b) diff --git a/utils/Panic.hs b/utils/Panic.hs deleted file mode 100644 --- a/utils/Panic.hs +++ /dev/null @@ -1,298 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP Project, Glasgow University, 1992-2000 - -Defines basic functions for printing error messages. - -It's hard to put these functions anywhere else without causing -some unnecessary loops in the module dependency graph. --} - -{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} - -module Panic ( - GhcException(..), showGhcException, - throwGhcException, throwGhcExceptionIO, - handleGhcException, - progName, - pgmError, - - panic, sorry, assertPanic, trace, - panicDoc, sorryDoc, pgmErrorDoc, - - Exception.Exception(..), showException, safeShowException, - try, tryMost, throwTo, - - withSignalHandlers, -) where -#include "HsVersions.h" - -import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe) - -import Config -import Exception - -import Control.Monad.IO.Class -import Control.Concurrent -import Debug.Trace ( trace ) -import System.IO.Unsafe -import System.Environment - -#ifndef mingw32_HOST_OS -import System.Posix.Signals as S -#endif - -#if defined(mingw32_HOST_OS) -import GHC.ConsoleHandler as S -#endif - -import GHC.Stack -import System.Mem.Weak ( deRefWeak ) - --- | GHC's own exception type --- error messages all take the form: --- --- @ --- : --- @ --- --- If the location is on the command line, or in GHC itself, then --- ="ghc". All of the error types below correspond to --- a of "ghc", except for ProgramError (where the string is --- assumed to contain a location already, so we don't print one). - -data GhcException - -- | Some other fatal signal (SIGHUP,SIGTERM) - = Signal Int - - -- | Prints the short usage msg after the error - | UsageError String - - -- | A problem with the command line arguments, but don't print usage. - | CmdLineError String - - -- | The 'impossible' happened. - | Panic String - | PprPanic String SDoc - - -- | The user tickled something that's known not to work yet, - -- but we're not counting it as a bug. - | Sorry String - | PprSorry String SDoc - - -- | An installation problem. - | InstallationError String - - -- | An error in the user's code, probably. - | ProgramError String - | PprProgramError String SDoc - -instance Exception GhcException - -instance Show GhcException where - showsPrec _ e@(ProgramError _) = showGhcException e - showsPrec _ e@(CmdLineError _) = showString ": " . showGhcException e - showsPrec _ e = showString progName . showString ": " . showGhcException e - - --- | The name of this GHC. -progName :: String -progName = unsafePerformIO (getProgName) -{-# NOINLINE progName #-} - - --- | Short usage information to display when we are given the wrong cmd line arguments. -short_usage :: String -short_usage = "Usage: For basic information, try the `--help' option." - - --- | Show an exception as a string. -showException :: Exception e => e -> String -showException = show - --- | Show an exception which can possibly throw other exceptions. --- Used when displaying exception thrown within TH code. -safeShowException :: Exception e => e -> IO String -safeShowException e = do - -- ensure the whole error message is evaluated inside try - r <- try (return $! forceList (showException e)) - case r of - Right msg -> return msg - Left e' -> safeShowException (e' :: SomeException) - where - forceList [] = [] - forceList xs@(x : xt) = x `seq` forceList xt `seq` xs - --- | Append a description of the given exception to this string. --- --- Note that this uses 'DynFlags.unsafeGlobalDynFlags', which may have some --- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called. --- If the error message to be printed includes a pretty-printer document --- which forces one of these fields this call may bottom. -showGhcException :: GhcException -> ShowS -showGhcException exception - = case exception of - UsageError str - -> showString str . showChar '\n' . showString short_usage - - CmdLineError str -> showString str - PprProgramError str sdoc -> - showString str . showString "\n\n" . - showString (showSDocUnsafe sdoc) - ProgramError str -> showString str - InstallationError str -> showString str - Signal n -> showString "signal: " . shows n - - PprPanic s sdoc -> - panicMsg $ showString s . showString "\n\n" - . showString (showSDocUnsafe sdoc) - Panic s -> panicMsg (showString s) - - PprSorry s sdoc -> - sorryMsg $ showString s . showString "\n\n" - . showString (showSDocUnsafe sdoc) - Sorry s -> sorryMsg (showString s) - where - sorryMsg :: ShowS -> ShowS - sorryMsg s = - showString "sorry! (unimplemented feature or known bug)\n" - . showString (" (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t") - . s . showString "\n" - - panicMsg :: ShowS -> ShowS - panicMsg s = - showString "panic! (the 'impossible' happened)\n" - . showString (" (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t") - . s . showString "\n\n" - . showString "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n" - - -throwGhcException :: GhcException -> a -throwGhcException = Exception.throw - -throwGhcExceptionIO :: GhcException -> IO a -throwGhcExceptionIO = Exception.throwIO - -handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a -handleGhcException = ghandle - - --- | Panics and asserts. -panic, sorry, pgmError :: String -> a -panic x = unsafeDupablePerformIO $ do - stack <- ccsToStrings =<< getCurrentCCS x - if null stack - then throwGhcException (Panic x) - else throwGhcException (Panic (x ++ '\n' : renderStack stack)) - -sorry x = throwGhcException (Sorry x) -pgmError x = throwGhcException (ProgramError x) - -panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a -panicDoc x doc = throwGhcException (PprPanic x doc) -sorryDoc x doc = throwGhcException (PprSorry x doc) -pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) - - --- | Throw an failed assertion exception for a given filename and line number. -assertPanic :: String -> Int -> a -assertPanic file line = - Exception.throw (Exception.AssertionFailed - ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) - - --- | Like try, but pass through UserInterrupt and Panic exceptions. --- Used when we want soft failures when reading interface files, for example. --- TODO: I'm not entirely sure if this is catching what we really want to catch -tryMost :: IO a -> IO (Either SomeException a) -tryMost action = do r <- try action - case r of - Left se -> - case fromException se of - -- Some GhcException's we rethrow, - Just (Signal _) -> throwIO se - Just (Panic _) -> throwIO se - -- others we return - Just _ -> return (Left se) - Nothing -> - case fromException se of - -- All IOExceptions are returned - Just (_ :: IOException) -> - return (Left se) - -- Anything else is rethrown - Nothing -> throwIO se - Right v -> return (Right v) - --- | We use reference counting for signal handlers -{-# NOINLINE signalHandlersRefCount #-} -#if !defined(mingw32_HOST_OS) -signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler - ,S.Handler,S.Handler)) -#else -signalHandlersRefCount :: MVar (Word, Maybe S.Handler) -#endif -signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing) - - --- | Temporarily install standard signal handlers for catching ^C, which just --- throw an exception in the current thread. -withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a -withSignalHandlers act = do - main_thread <- liftIO myThreadId - wtid <- liftIO (mkWeakThreadId main_thread) - - let - interrupt = do - r <- deRefWeak wtid - case r of - Nothing -> return () - Just t -> throwTo t UserInterrupt - -#if !defined(mingw32_HOST_OS) - let installHandlers = do - let installHandler' a b = installHandler a b Nothing - hdlQUIT <- installHandler' sigQUIT (Catch interrupt) - hdlINT <- installHandler' sigINT (Catch interrupt) - -- see #3656; in the future we should install these automatically for - -- all Haskell programs in the same way that we install a ^C handler. - let fatal_signal n = throwTo main_thread (Signal (fromIntegral n)) - hdlHUP <- installHandler' sigHUP (Catch (fatal_signal sigHUP)) - hdlTERM <- installHandler' sigTERM (Catch (fatal_signal sigTERM)) - return (hdlQUIT,hdlINT,hdlHUP,hdlTERM) - - let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do - _ <- installHandler sigQUIT hdlQUIT Nothing - _ <- installHandler sigINT hdlINT Nothing - _ <- installHandler sigHUP hdlHUP Nothing - _ <- installHandler sigTERM hdlTERM Nothing - return () -#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 () - - let installHandlers = installHandler (Catch sig_handler) - let uninstallHandlers = installHandler -- directly install the old handler -#endif - - -- install signal handlers if necessary - let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case - (0,Nothing) -> do - hdls <- installHandlers - return (1,Just hdls) - (c,oldHandlers) -> return (c+1,oldHandlers) - - -- uninstall handlers if necessary - let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case - (1,Just hdls) -> do - _ <- uninstallHandlers hdls - return (0,Nothing) - (c,oldHandlers) -> return (c-1,oldHandlers) - - mayInstallHandlers - act `gfinally` mayUninstallHandlers diff --git a/utils/Platform.hs b/utils/Platform.hs deleted file mode 100644 --- a/utils/Platform.hs +++ /dev/null @@ -1,172 +0,0 @@ - --- | A description of the platform we're compiling for. --- -module Platform ( - Platform(..), - Arch(..), - OS(..), - ArmISA(..), - ArmISAExt(..), - ArmABI(..), - PPC_64ABI(..), - - target32Bit, - isARM, - osElfTarget, - osMachOTarget, - osSubsectionsViaSymbols, - platformUsesFrameworks, - platformBinariesAreStaticLibs, -) - -where - --- | Contains enough information for the native code generator to emit --- code for this platform. -data Platform - = Platform { - platformArch :: Arch, - platformOS :: OS, - -- Word size in bytes (i.e. normally 4 or 8, - -- for 32bit and 64bit platforms respectively) - platformWordSize :: {-# UNPACK #-} !Int, - platformUnregisterised :: Bool, - platformHasGnuNonexecStack :: Bool, - platformHasIdentDirective :: Bool, - platformHasSubsectionsViaSymbols :: Bool, - platformIsCrossCompiling :: Bool - } - deriving (Read, Show, Eq) - - --- | Architectures that the native code generator knows about. --- TODO: It might be nice to extend these constructors with information --- about what instruction set extensions an architecture might support. --- -data Arch - = ArchUnknown - | ArchX86 - | ArchX86_64 - | ArchPPC - | ArchPPC_64 - { ppc_64ABI :: PPC_64ABI - } - | ArchSPARC - | ArchSPARC64 - | ArchARM - { armISA :: ArmISA - , armISAExt :: [ArmISAExt] - , armABI :: ArmABI - } - | ArchARM64 - | ArchAlpha - | ArchMipseb - | ArchMipsel - | ArchJavaScript - deriving (Read, Show, Eq) - -isARM :: Arch -> Bool -isARM (ArchARM {}) = True -isARM ArchARM64 = True -isARM _ = False - --- | Operating systems that the native code generator knows about. --- Having OSUnknown should produce a sensible default, but no promises. -data OS - = OSUnknown - | OSLinux - | OSDarwin - | OSiOS - | OSSolaris2 - | OSMinGW32 - | OSFreeBSD - | OSDragonFly - | OSOpenBSD - | OSNetBSD - | OSKFreeBSD - | OSHaiku - | OSQNXNTO - | OSAndroid - | OSAIX - deriving (Read, Show, Eq) - --- | ARM Instruction Set Architecture, Extensions and ABI --- -data ArmISA - = ARMv5 - | ARMv6 - | ARMv7 - deriving (Read, Show, Eq) - -data ArmISAExt - = VFPv2 - | VFPv3 - | VFPv3D16 - | NEON - | IWMMX2 - deriving (Read, Show, Eq) - -data ArmABI - = SOFT - | SOFTFP - | HARD - deriving (Read, Show, Eq) - --- | PowerPC 64-bit ABI --- -data PPC_64ABI - = ELF_V1 - | ELF_V2 - deriving (Read, Show, Eq) - --- | This predicate tells us whether the platform is 32-bit. -target32Bit :: Platform -> Bool -target32Bit p = platformWordSize p == 4 - --- | This predicate tells us whether the OS supports ELF-like shared libraries. -osElfTarget :: OS -> Bool -osElfTarget OSLinux = True -osElfTarget OSFreeBSD = True -osElfTarget OSDragonFly = True -osElfTarget OSOpenBSD = True -osElfTarget OSNetBSD = True -osElfTarget OSSolaris2 = True -osElfTarget OSDarwin = False -osElfTarget OSiOS = False -osElfTarget OSMinGW32 = False -osElfTarget OSKFreeBSD = True -osElfTarget OSHaiku = True -osElfTarget OSQNXNTO = False -osElfTarget OSAndroid = True -osElfTarget OSAIX = False -osElfTarget OSUnknown = False - -- Defaulting to False is safe; it means don't rely on any - -- ELF-specific functionality. It is important to have a default for - -- portability, otherwise we have to answer this question for every - -- new platform we compile on (even unreg). - --- | This predicate tells us whether the OS support Mach-O shared libraries. -osMachOTarget :: OS -> Bool -osMachOTarget OSDarwin = True -osMachOTarget _ = False - -osUsesFrameworks :: OS -> Bool -osUsesFrameworks OSDarwin = True -osUsesFrameworks OSiOS = True -osUsesFrameworks _ = False - -platformUsesFrameworks :: Platform -> Bool -platformUsesFrameworks = osUsesFrameworks . platformOS - -osBinariesAreStaticLibs :: OS -> Bool -osBinariesAreStaticLibs OSiOS = True -osBinariesAreStaticLibs _ = False - -osSubsectionsViaSymbols :: OS -> Bool -osSubsectionsViaSymbols OSDarwin = True -osSubsectionsViaSymbols OSiOS = True -osSubsectionsViaSymbols _ = False - -platformBinariesAreStaticLibs :: Platform -> Bool -platformBinariesAreStaticLibs = osBinariesAreStaticLibs . platformOS - diff --git a/utils/PprColour.hs b/utils/PprColour.hs deleted file mode 100644 --- a/utils/PprColour.hs +++ /dev/null @@ -1,95 +0,0 @@ -module PprColour where -import Data.Maybe (fromMaybe) -import Util (OverridingBool(..), split) - --- | A colour\/style for use with 'coloured'. -newtype PprColour = PprColour { renderColour :: String } - --- | Allow colours to be combined (e.g. bold + red); --- In case of conflict, right side takes precedence. -instance Monoid PprColour where - mempty = PprColour mempty - PprColour s1 `mappend` PprColour s2 = PprColour (s1 `mappend` s2) - -renderColourAfresh :: PprColour -> String -renderColourAfresh c = renderColour (colReset `mappend` c) - -colCustom :: String -> PprColour -colCustom "" = mempty -colCustom s = PprColour ("\27[" ++ s ++ "m") - -colReset :: PprColour -colReset = colCustom "0" - -colBold :: PprColour -colBold = colCustom ";1" - -colBlackFg :: PprColour -colBlackFg = colCustom "30" - -colRedFg :: PprColour -colRedFg = colCustom "31" - -colGreenFg :: PprColour -colGreenFg = colCustom "32" - -colYellowFg :: PprColour -colYellowFg = colCustom "33" - -colBlueFg :: PprColour -colBlueFg = colCustom "34" - -colMagentaFg :: PprColour -colMagentaFg = colCustom "35" - -colCyanFg :: PprColour -colCyanFg = colCustom "36" - -colWhiteFg :: PprColour -colWhiteFg = colCustom "37" - -data Scheme = - Scheme - { sHeader :: PprColour - , sMessage :: PprColour - , sWarning :: PprColour - , sError :: PprColour - , sFatal :: PprColour - , sMargin :: PprColour - } - -defaultScheme :: Scheme -defaultScheme = - Scheme - { sHeader = mempty - , sMessage = colBold - , sWarning = colBold `mappend` colMagentaFg - , sError = colBold `mappend` colRedFg - , sFatal = colBold `mappend` colRedFg - , sMargin = colBold `mappend` colBlueFg - } - --- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@ --- environment variable). -parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme) -parseScheme "always" (_, cs) = (Always, cs) -parseScheme "auto" (_, cs) = (Auto, cs) -parseScheme "never" (_, cs) = (Never, cs) -parseScheme input (b, cs) = - ( b - , Scheme - { sHeader = fromMaybe (sHeader cs) (lookup "header" table) - , sMessage = fromMaybe (sMessage cs) (lookup "message" table) - , sWarning = fromMaybe (sWarning cs) (lookup "warning" table) - , sError = fromMaybe (sError cs) (lookup "error" table) - , sFatal = fromMaybe (sFatal cs) (lookup "fatal" table) - , sMargin = fromMaybe (sMargin cs) (lookup "margin" table) - } - ) - where - table = do - w <- split ':' input - let (k, v') = break (== '=') w - case v' of - '=' : v -> return (k, colCustom v) - _ -> [] diff --git a/utils/Pretty.hs b/utils/Pretty.hs deleted file mode 100644 --- a/utils/Pretty.hs +++ /dev/null @@ -1,1050 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} - ------------------------------------------------------------------------------ --- | --- Module : Pretty --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : David Terei --- Stability : stable --- Portability : portable --- --- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators --- --- Based on /The Design of a Pretty-printing Library/ --- in Advanced Functional Programming, --- Johan Jeuring and Erik Meijer (eds), LNCS 925 --- --- ------------------------------------------------------------------------------ - -{- -Note [Differences between libraries/pretty and compiler/utils/Pretty.hs] - -For historical reasons, there are two different copies of `Pretty` in the GHC -source tree: - * `libraries/pretty` is a submodule containing - https://github.com/haskell/pretty. This is the `pretty` library as released - on hackage. It is used by several other libraries in the GHC source tree - (e.g. template-haskell and Cabal). - * `compiler/utils/Pretty.hs` (this module). It is used by GHC only. - -There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and -https://ghc.haskell.org/trac/ghc/ticket/10735 to try to get rid of GHC's copy -of Pretty. - -Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following -major differences: - * GHC's copy uses `Faststring` for performance reasons. - * GHC's copy has received a backported bugfix for #12227, which was - released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside", - https://github.com/haskell/pretty/pull/35). - -Other differences are minor. Both copies define some extra functions and -instances not defined in the other copy. To see all differences, do this in a -ghc git tree: - - $ cd libraries/pretty - $ git checkout v1.1.2.0 - $ cd - - $ vimdiff compiler/utils/Pretty.hs \ - libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs - -For parity with `pretty-1.1.2.1`, the following two `pretty` commits would -have to be backported: - * "Resolve foldr-strictness stack overflow bug" - (307b8173f41cd776eae8f547267df6d72bff2d68) - * "Special-case reduce for horiz/vert" - (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c) -This has not been done sofar, because these commits seem to cause more -allocation in the compiler (see thomie's comments in -https://github.com/haskell/pretty/pull/9). --} - -module Pretty ( - - -- * The document type - Doc, TextDetails(..), - - -- * Constructing documents - - -- ** Converting values into documents - char, text, ftext, ptext, ztext, sizedText, zeroWidthText, - int, integer, float, double, rational, - - -- ** Simple derived documents - semi, comma, colon, space, equals, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, - - -- ** Wrapping documents in delimiters - parens, brackets, braces, quotes, quote, doubleQuotes, - maybeParens, - - -- ** Combining documents - empty, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, - nest, - hang, hangNotEmpty, punctuate, - - -- * Predicates on documents - isEmpty, - - -- * Rendering documents - - -- ** Rendering with a particular style - Style(..), - style, - renderStyle, - Mode(..), - - -- ** General rendering - fullRender, - - -- ** GHC-specific rendering - printDoc, printDoc_, - bufLeftRender -- performance hack - - ) where - -import BufWrite -import FastString -import Panic -import System.IO -import Prelude hiding (error) - ---for a RULES -import GHC.Base ( unpackCString# ) -import GHC.Ptr ( Ptr(..) ) - --- Don't import Util( assertPanic ) because it makes a loop in the module structure - - --- --------------------------------------------------------------------------- --- The Doc calculus - -{- -Laws for $$ -~~~~~~~~~~~ - (x $$ y) $$ z = x $$ (y $$ z) - empty $$ x = x - x $$ empty = x - - ...ditto $+$... - -Laws for <> -~~~~~~~~~~~ - (x <> y) <> z = x <> (y <> z) - empty <> x = empty - x <> empty = x - - ...ditto <+>... - -Laws for text -~~~~~~~~~~~~~ - text s <> text t = text (s++t) - text "" <> x = x, if x non-empty - -** because of law n6, t2 only holds if x doesn't -** start with `nest'. - - -Laws for nest -~~~~~~~~~~~~~ - nest 0 x = x - nest k (nest k' x) = nest (k+k') x - nest k (x <> y) = nest k x <> nest k y - nest k (x $$ y) = nest k x $$ nest k y - nest k empty = empty - x <> nest k y = x <> y, if x non-empty - -** Note the side condition on ! It is this that -** makes it OK for empty to be a left unit for <>. - -Miscellaneous -~~~~~~~~~~~~~ - (text s <> x) $$ y = text s <> ((text "" <> x) $$ - nest (-length s) y) - - (x $$ y) <> z = x $$ (y <> z) - if y non-empty - - -Laws for list versions -~~~~~~~~~~~~~~~~~~~~~~ - sep (ps++[empty]++qs) = sep (ps ++ qs) - ...ditto hsep, hcat, vcat, fill... - - nest k (sep ps) = sep (map (nest k) ps) - ...ditto hsep, hcat, vcat, fill... - -Laws for oneLiner -~~~~~~~~~~~~~~~~~ - oneLiner (nest k p) = nest k (oneLiner p) - oneLiner (x <> y) = oneLiner x <> oneLiner y - -You might think that the following verion of would -be neater: - -<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ - nest (-length s) y) - -But it doesn't work, for if x=empty, we would have - - text s $$ y = text s <> (empty $$ nest (-length s) y) - = text s <> nest (-length s) y --} - --- --------------------------------------------------------------------------- --- Operator fixity - -infixl 6 <> -infixl 6 <+> -infixl 5 $$, $+$ - - --- --------------------------------------------------------------------------- --- The Doc data type - --- | The abstract type of documents. --- A Doc represents a *set* of layouts. A Doc with --- no occurrences of Union or NoDoc represents just one layout. -data Doc - = Empty -- empty - | NilAbove Doc -- text "" $$ x - | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x - | Nest {-# UNPACK #-} !Int Doc -- nest k x - | Union Doc Doc -- ul `union` ur - | NoDoc -- The empty set of documents - | Beside Doc Bool Doc -- True <=> space between - | Above Doc Bool Doc -- True <=> never overlap - -{- -Here are the invariants: - -1) The argument of NilAbove is never Empty. Therefore - a NilAbove occupies at least two lines. - -2) The argument of @TextBeside@ is never @Nest@. - -3) The layouts of the two arguments of @Union@ both flatten to the same - string. - -4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. - -5) A @NoDoc@ may only appear on the first line of the left argument of an - union. Therefore, the right argument of an union can never be equivalent - to the empty set (@NoDoc@). - -6) An empty document is always represented by @Empty@. It can't be - hidden inside a @Nest@, or a @Union@ of two @Empty@s. - -7) The first line of every layout in the left argument of @Union@ is - longer than the first line of any layout in the right argument. - (1) ensures that the left argument has a first line. In view of - (3), this invariant means that the right argument must have at - least two lines. - -Notice the difference between - * NoDoc (no documents) - * Empty (one empty document; no height and no width) - * text "" (a document containing the empty string; - one line high, but has no width) --} - - --- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. -type RDoc = Doc - --- | The TextDetails data type --- --- A TextDetails represents a fragment of text that will be --- output at some point. -data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment - | Str String -- ^ A whole String fragment - | PStr FastString -- a hashed string - | ZStr FastZString -- a z-encoded string - | LStr {-# UNPACK #-} !LitString {-#UNPACK #-} !Int - -- a '\0'-terminated array of bytes - -instance Show Doc where - showsPrec _ doc cont = fullRender (mode style) (lineLength style) - (ribbonsPerLine style) - txtPrinter cont doc - - --- --------------------------------------------------------------------------- --- Values and Predicates on GDocs and TextDetails - --- | A document of height and width 1, containing a literal character. -char :: Char -> Doc -char c = textBeside_ (Chr c) 1 Empty - --- | A document of height 1 containing a literal string. --- 'text' satisfies the following laws: --- --- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ --- --- * @'text' \"\" '<>' x = x@, if @x@ non-empty --- --- The side condition on the last law is necessary because @'text' \"\"@ --- has height 1, while 'empty' has no height. -text :: String -> Doc -text s = case length s of {sl -> textBeside_ (Str s) sl Empty} -{-# NOINLINE [0] text #-} -- Give the RULE a chance to fire - -- It must wait till after phase 1 when - -- the unpackCString first is manifested - --- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the --- intermediate packing/unpacking of the string. -{-# RULES - "text/str" forall a. text (unpackCString# a) = ptext (Ptr a) - #-} - -ftext :: FastString -> Doc -ftext s = case lengthFS s of {sl -> textBeside_ (PStr s) sl Empty} - -ptext :: LitString -> Doc -ptext s = case lengthLS s of {sl -> textBeside_ (LStr s sl) sl Empty} - -ztext :: FastZString -> Doc -ztext s = case lengthFZS s of {sl -> textBeside_ (ZStr s) sl Empty} - --- | Some text with any width. (@text s = sizedText (length s) s@) -sizedText :: Int -> String -> Doc -sizedText l s = textBeside_ (Str s) l Empty - --- | Some text, but without any width. Use for non-printing text --- such as a HTML or Latex tags -zeroWidthText :: String -> Doc -zeroWidthText = sizedText 0 - --- | The empty document, with no height and no width. --- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere --- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. -empty :: Doc -empty = Empty - --- | Returns 'True' if the document is empty -isEmpty :: Doc -> Bool -isEmpty Empty = True -isEmpty _ = False - --- | Produce spacing for indenting the amount specified. --- --- an old version inserted tabs being 8 columns apart in the output. -spaces :: Int -> String -spaces !n = replicate n ' ' - -{- -Q: What is the reason for negative indentation (i.e. argument to indent - is < 0) ? - -A: -This indicates an error in the library client's code. -If we compose a <> b, and the first line of b is more indented than some -other lines of b, the law (<> eats nests) may cause the pretty -printer to produce an invalid layout: - -doc |0123345 ------------------- -d1 |a...| -d2 |...b| - |c...| - -d1<>d2 |ab..| - c|....| - -Consider a <> b, let `s' be the length of the last line of `a', `k' the -indentation of the first line of b, and `k0' the indentation of the -left-most line b_i of b. - -The produced layout will have negative indentation if `k - k0 > s', as -the first line of b will be put on the (s+1)th column, effectively -translating b horizontally by (k-s). Now if the i^th line of b has an -indentation k0 < (k-s), it is translated out-of-page, causing -`negative indentation'. --} - - -semi :: Doc -- ^ A ';' character -comma :: Doc -- ^ A ',' character -colon :: Doc -- ^ A ':' character -space :: Doc -- ^ A space character -equals :: Doc -- ^ A '=' character -lparen :: Doc -- ^ A '(' character -rparen :: Doc -- ^ A ')' character -lbrack :: Doc -- ^ A '[' character -rbrack :: Doc -- ^ A ']' character -lbrace :: Doc -- ^ A '{' character -rbrace :: Doc -- ^ A '}' character -semi = char ';' -comma = char ',' -colon = char ':' -space = char ' ' -equals = char '=' -lparen = char '(' -rparen = char ')' -lbrack = char '[' -rbrack = char ']' -lbrace = char '{' -rbrace = char '}' - -spaceText, nlText :: TextDetails -spaceText = Chr ' ' -nlText = Chr '\n' - -int :: Int -> Doc -- ^ @int n = text (show n)@ -integer :: Integer -> Doc -- ^ @integer n = text (show n)@ -float :: Float -> Doc -- ^ @float n = text (show n)@ -double :: Double -> Doc -- ^ @double n = text (show n)@ -rational :: Rational -> Doc -- ^ @rational n = text (show n)@ -int n = text (show n) -integer n = text (show n) -float n = text (show n) -double n = text (show n) -rational n = text (show n) - -parens :: Doc -> Doc -- ^ Wrap document in @(...)@ -brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ -braces :: Doc -> Doc -- ^ Wrap document in @{...}@ -quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ -quote :: Doc -> Doc -doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ -quotes p = char '`' <> p <> char '\'' -quote p = char '\'' <> p -doubleQuotes p = char '"' <> p <> char '"' -parens p = char '(' <> p <> char ')' -brackets p = char '[' <> p <> char ']' -braces p = char '{' <> p <> char '}' - --- | Apply 'parens' to 'Doc' if boolean is true. -maybeParens :: Bool -> Doc -> Doc -maybeParens False = id -maybeParens True = parens - --- --------------------------------------------------------------------------- --- Structural operations on GDocs - --- | Perform some simplification of a built up @GDoc@. -reduceDoc :: Doc -> RDoc -reduceDoc (Beside p g q) = beside p g (reduceDoc q) -reduceDoc (Above p g q) = above p g (reduceDoc q) -reduceDoc p = p - --- | List version of '<>'. -hcat :: [Doc] -> Doc -hcat = reduceAB . foldr (beside_' False) empty - --- | List version of '<+>'. -hsep :: [Doc] -> Doc -hsep = reduceAB . foldr (beside_' True) empty - --- | List version of '$$'. -vcat :: [Doc] -> Doc -vcat = reduceAB . foldr (above_' False) empty - --- | Nest (or indent) a document by a given number of positions --- (which may also be negative). 'nest' satisfies the laws: --- --- * @'nest' 0 x = x@ --- --- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ --- --- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ --- --- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ --- --- * @'nest' k 'empty' = 'empty'@ --- --- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty --- --- The side condition on the last law is needed because --- 'empty' is a left identity for '<>'. -nest :: Int -> Doc -> Doc -nest k p = mkNest k (reduceDoc p) - --- | @hang d1 n d2 = sep [d1, nest n d2]@ -hang :: Doc -> Int -> Doc -> Doc -hang d1 n d2 = sep [d1, nest n d2] - --- | Apply 'hang' to the arguments if the first 'Doc' is not empty. -hangNotEmpty :: Doc -> Int -> Doc -> Doc -hangNotEmpty d1 n d2 = if isEmpty d1 - then d2 - else hang d1 n d2 - --- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ -punctuate :: Doc -> [Doc] -> [Doc] -punctuate _ [] = [] -punctuate p (x:xs) = go x xs - where go y [] = [y] - go y (z:zs) = (y <> p) : go z zs - --- mkNest checks for Nest's invariant that it doesn't have an Empty inside it -mkNest :: Int -> Doc -> Doc -mkNest k _ | k `seq` False = undefined -mkNest k (Nest k1 p) = mkNest (k + k1) p -mkNest _ NoDoc = NoDoc -mkNest _ Empty = Empty -mkNest 0 p = p -mkNest k p = nest_ k p - --- mkUnion checks for an empty document -mkUnion :: Doc -> Doc -> Doc -mkUnion Empty _ = Empty -mkUnion p q = p `union_` q - -beside_' :: Bool -> Doc -> Doc -> Doc -beside_' _ p Empty = p -beside_' g p q = Beside p g q - -above_' :: Bool -> Doc -> Doc -> Doc -above_' _ p Empty = p -above_' g p q = Above p g q - -reduceAB :: Doc -> Doc -reduceAB (Above Empty _ q) = q -reduceAB (Beside Empty _ q) = q -reduceAB doc = doc - -nilAbove_ :: RDoc -> RDoc -nilAbove_ = NilAbove - --- Arg of a TextBeside is always an RDoc -textBeside_ :: TextDetails -> Int -> RDoc -> RDoc -textBeside_ = TextBeside - -nest_ :: Int -> RDoc -> RDoc -nest_ = Nest - -union_ :: RDoc -> RDoc -> RDoc -union_ = Union - - --- --------------------------------------------------------------------------- --- Vertical composition @$$@ - --- | Above, except that if the last line of the first argument stops --- at least one position before the first line of the second begins, --- these two lines are overlapped. For example: --- --- > text "hi" $$ nest 5 (text "there") --- --- lays out as --- --- > hi there --- --- rather than --- --- > hi --- > there --- --- '$$' is associative, with identity 'empty', and also satisfies --- --- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. --- -($$) :: Doc -> Doc -> Doc -p $$ q = above_ p False q - --- | Above, with no overlapping. --- '$+$' is associative, with identity 'empty'. -($+$) :: Doc -> Doc -> Doc -p $+$ q = above_ p True q - -above_ :: Doc -> Bool -> Doc -> Doc -above_ p _ Empty = p -above_ Empty _ q = q -above_ p g q = Above p g q - -above :: Doc -> Bool -> RDoc -> RDoc -above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) -above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) -above p g q = aboveNest p g 0 (reduceDoc q) - --- Specification: aboveNest p g k q = p $g$ (nest k q) -aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc -aboveNest _ _ k _ | k `seq` False = undefined -aboveNest NoDoc _ _ _ = NoDoc -aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` - aboveNest p2 g k q - -aboveNest Empty _ k q = mkNest k q -aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) - -- p can't be Empty, so no need for mkNest - -aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) -aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest - where - !k1 = k - sl - rest = case p of - Empty -> nilAboveNest g k1 q - _ -> aboveNest p g k1 q -aboveNest (Above {}) _ _ _ = error "aboveNest Above" -aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" - --- Specification: text s <> nilaboveNest g k q --- = text s <> (text "" $g$ nest k q) -nilAboveNest :: Bool -> Int -> RDoc -> RDoc -nilAboveNest _ k _ | k `seq` False = undefined -nilAboveNest _ _ Empty = Empty - -- Here's why the "text s <>" is in the spec! -nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q -nilAboveNest g k q | not g && k > 0 -- No newline if no overlap - = textBeside_ (Str (spaces k)) k q - | otherwise -- Put them really above - = nilAbove_ (mkNest k q) - - --- --------------------------------------------------------------------------- --- Horizontal composition @<>@ - --- We intentionally avoid Data.Monoid.(<>) here due to interactions of --- Data.Monoid.(<>) and (<+>). See --- http://www.haskell.org/pipermail/libraries/2011-November/017066.html - --- | Beside. --- '<>' is associative, with identity 'empty'. -(<>) :: Doc -> Doc -> Doc -p <> q = beside_ p False q - --- | Beside, separated by space, unless one of the arguments is 'empty'. --- '<+>' is associative, with identity 'empty'. -(<+>) :: Doc -> Doc -> Doc -p <+> q = beside_ p True q - -beside_ :: Doc -> Bool -> Doc -> Doc -beside_ p _ Empty = p -beside_ Empty _ q = q -beside_ p g q = Beside p g q - --- Specification: beside g p q = p q -beside :: Doc -> Bool -> RDoc -> RDoc -beside NoDoc _ _ = NoDoc -beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q -beside Empty _ q = q -beside (Nest k p) g q = nest_ k $! beside p g q -beside p@(Beside p1 g1 q1) g2 q2 - | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 - | otherwise = beside (reduceDoc p) g2 q2 -beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q -beside (NilAbove p) g q = nilAbove_ $! beside p g q -beside (TextBeside s sl p) g q = textBeside_ s sl rest - where - rest = case p of - Empty -> nilBeside g q - _ -> beside p g q - --- Specification: text "" <> nilBeside g p --- = text "" p -nilBeside :: Bool -> RDoc -> RDoc -nilBeside _ Empty = Empty -- Hence the text "" in the spec -nilBeside g (Nest _ p) = nilBeside g p -nilBeside g p | g = textBeside_ spaceText 1 p - | otherwise = p - - --- --------------------------------------------------------------------------- --- Separate, @sep@ - --- Specification: sep ps = oneLiner (hsep ps) --- `union` --- vcat ps - --- | Either 'hsep' or 'vcat'. -sep :: [Doc] -> Doc -sep = sepX True -- Separate with spaces - --- | Either 'hcat' or 'vcat'. -cat :: [Doc] -> Doc -cat = sepX False -- Don't - -sepX :: Bool -> [Doc] -> Doc -sepX _ [] = empty -sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps - - --- Specification: sep1 g k ys = sep (x : map (nest k) ys) --- = oneLiner (x nest k (hsep ys)) --- `union` x $$ nest k (vcat ys) -sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc -sep1 _ _ k _ | k `seq` False = undefined -sep1 _ NoDoc _ _ = NoDoc -sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` - aboveNest q False k (reduceDoc (vcat ys)) - -sep1 g Empty k ys = mkNest k (sepX g ys) -sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) - -sep1 _ (NilAbove p) k ys = nilAbove_ - (aboveNest p False k (reduceDoc (vcat ys))) -sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) -sep1 _ (Above {}) _ _ = error "sep1 Above" -sep1 _ (Beside {}) _ _ = error "sep1 Beside" - --- Specification: sepNB p k ys = sep1 (text "" <> p) k ys --- Called when we have already found some text in the first item --- We have to eat up nests -sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc -sepNB g (Nest _ p) k ys - = sepNB g p k ys -- Never triggered, because of invariant (2) -sepNB g Empty k ys - = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` - -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) - nilAboveNest False k (reduceDoc (vcat ys)) - where - rest | g = hsep ys - | otherwise = hcat ys -sepNB g p k ys - = sep1 g p k ys - - --- --------------------------------------------------------------------------- --- @fill@ - --- | \"Paragraph fill\" version of 'cat'. -fcat :: [Doc] -> Doc -fcat = fill False - --- | \"Paragraph fill\" version of 'sep'. -fsep :: [Doc] -> Doc -fsep = fill True - --- Specification: --- --- fill g docs = fillIndent 0 docs --- --- fillIndent k [] = [] --- fillIndent k [p] = p --- fillIndent k (p1:p2:ps) = --- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) --- (remove_nests (oneLiner p2) : ps) --- `Union` --- (p1 $*$ nest (-k) (fillIndent 0 ps)) --- --- $*$ is defined for layouts (not Docs) as --- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 --- | otherwise = layout1 $+$ layout2 - -fill :: Bool -> [Doc] -> RDoc -fill _ [] = empty -fill g (p:ps) = fill1 g (reduceDoc p) 0 ps - -fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc -fill1 _ _ k _ | k `seq` False = undefined -fill1 _ NoDoc _ _ = NoDoc -fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` - aboveNest q False k (fill g ys) -fill1 g Empty k ys = mkNest k (fill g ys) -fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) -fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) -fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) -fill1 _ (Above {}) _ _ = error "fill1 Above" -fill1 _ (Beside {}) _ _ = error "fill1 Beside" - -fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc -fillNB _ _ k _ | k `seq` False = undefined -fillNB g (Nest _ p) k ys = fillNB g p k ys - -- Never triggered, because of invariant (2) -fillNB _ Empty _ [] = Empty -fillNB g Empty k (Empty:ys) = fillNB g Empty k ys -fillNB g Empty k (y:ys) = fillNBE g k y ys -fillNB g p k ys = fill1 g p k ys - - -fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc -fillNBE g k y ys - = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) - -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) - `mkUnion` nilAboveNest False k (fill g (y:ys)) - where k' = if g then k - 1 else k - -elideNest :: Doc -> Doc -elideNest (Nest _ d) = d -elideNest d = d - --- --------------------------------------------------------------------------- --- Selecting the best layout - -best :: Int -- Line length - -> Int -- Ribbon length - -> RDoc - -> RDoc -- No unions in here! -best w0 r = get w0 - where - get :: Int -- (Remaining) width of line - -> Doc -> Doc - get w _ | w == 0 && False = undefined - get _ Empty = Empty - get _ NoDoc = NoDoc - get w (NilAbove p) = nilAbove_ (get w p) - get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) - get w (Nest k p) = nest_ k (get (w - k) p) - get w (p `Union` q) = nicest w r (get w p) (get w q) - get _ (Above {}) = error "best get Above" - get _ (Beside {}) = error "best get Beside" - - get1 :: Int -- (Remaining) width of line - -> Int -- Amount of first line already eaten up - -> Doc -- This is an argument to TextBeside => eat Nests - -> Doc -- No unions in here! - - get1 w _ _ | w == 0 && False = undefined - get1 _ _ Empty = Empty - get1 _ _ NoDoc = NoDoc - get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) - get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) - get1 w sl (Nest _ p) = get1 w sl p - get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) - (get1 w sl q) - get1 _ _ (Above {}) = error "best get1 Above" - get1 _ _ (Beside {}) = error "best get1 Beside" - -nicest :: Int -> Int -> Doc -> Doc -> Doc -nicest !w !r = nicest1 w r 0 - -nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc -nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p - | otherwise = q - -fits :: Int -- Space available - -> Doc - -> Bool -- True if *first line* of Doc fits in space available -fits n _ | n < 0 = False -fits _ NoDoc = False -fits _ Empty = True -fits _ (NilAbove _) = True -fits n (TextBeside _ sl p) = fits (n - sl) p -fits _ (Above {}) = error "fits Above" -fits _ (Beside {}) = error "fits Beside" -fits _ (Union {}) = error "fits Union" -fits _ (Nest {}) = error "fits Nest" - --- | @first@ returns its first argument if it is non-empty, otherwise its second. -first :: Doc -> Doc -> Doc -first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused - | otherwise = q - -nonEmptySet :: Doc -> Bool -nonEmptySet NoDoc = False -nonEmptySet (_ `Union` _) = True -nonEmptySet Empty = True -nonEmptySet (NilAbove _) = True -nonEmptySet (TextBeside _ _ p) = nonEmptySet p -nonEmptySet (Nest _ p) = nonEmptySet p -nonEmptySet (Above {}) = error "nonEmptySet Above" -nonEmptySet (Beside {}) = error "nonEmptySet Beside" - --- @oneLiner@ returns the one-line members of the given set of @GDoc@s. -oneLiner :: Doc -> Doc -oneLiner NoDoc = NoDoc -oneLiner Empty = Empty -oneLiner (NilAbove _) = NoDoc -oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) -oneLiner (Nest k p) = nest_ k (oneLiner p) -oneLiner (p `Union` _) = oneLiner p -oneLiner (Above {}) = error "oneLiner Above" -oneLiner (Beside {}) = error "oneLiner Beside" - - --- --------------------------------------------------------------------------- --- Rendering - --- | A rendering style. -data Style - = Style { mode :: Mode -- ^ The rendering mode - , lineLength :: Int -- ^ Length of line, in chars - , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length - } - --- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). -style :: Style -style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } - --- | Rendering mode. -data Mode = PageMode -- ^ Normal - | ZigZagMode -- ^ With zig-zag cuts - | LeftMode -- ^ No indentation, infinitely long lines - | OneLineMode -- ^ All on one line - --- | Render the @Doc@ to a String using the given @Style@. -renderStyle :: Style -> Doc -> String -renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) - txtPrinter "" - --- | Default TextDetails printer -txtPrinter :: TextDetails -> String -> String -txtPrinter (Chr c) s = c:s -txtPrinter (Str s1) s2 = s1 ++ s2 -txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 -txtPrinter (ZStr s1) s2 = zString s1 ++ s2 -txtPrinter (LStr s1 _) s2 = unpackLitString s1 ++ s2 - --- | The general rendering interface. -fullRender :: Mode -- ^ Rendering mode - -> Int -- ^ Line length - -> Float -- ^ Ribbons per line - -> (TextDetails -> a -> a) -- ^ What to do with text - -> a -- ^ What to do at the end - -> Doc -- ^ The document - -> a -- ^ Result -fullRender OneLineMode _ _ txt end doc - = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) -fullRender LeftMode _ _ txt end doc - = easyDisplay nlText first txt end (reduceDoc doc) - -fullRender m lineLen ribbons txt rest doc - = display m lineLen ribbonLen txt rest doc' - where - doc' = best bestLineLen ribbonLen (reduceDoc doc) - - bestLineLen, ribbonLen :: Int - ribbonLen = round (fromIntegral lineLen / ribbons) - bestLineLen = case m of - ZigZagMode -> maxBound - _ -> lineLen - -easyDisplay :: TextDetails - -> (Doc -> Doc -> Doc) - -> (TextDetails -> a -> a) - -> a - -> Doc - -> a -easyDisplay nlSpaceText choose txt end - = lay - where - lay NoDoc = error "easyDisplay: NoDoc" - lay (Union p q) = lay (choose p q) - lay (Nest _ p) = lay p - lay Empty = end - lay (NilAbove p) = nlSpaceText `txt` lay p - lay (TextBeside s _ p) = s `txt` lay p - lay (Above {}) = error "easyDisplay Above" - lay (Beside {}) = error "easyDisplay Beside" - -display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a -display m !page_width !ribbon_width txt end doc - = case page_width - ribbon_width of { gap_width -> - case gap_width `quot` 2 of { shift -> - let - lay k _ | k `seq` False = undefined - lay k (Nest k1 p) = lay (k + k1) p - lay _ Empty = end - lay k (NilAbove p) = nlText `txt` lay k p - lay k (TextBeside s sl p) - = case m of - ZigZagMode | k >= gap_width - -> nlText `txt` ( - Str (replicate shift '/') `txt` ( - nlText `txt` - lay1 (k - shift) s sl p )) - - | k < 0 - -> nlText `txt` ( - Str (replicate shift '\\') `txt` ( - nlText `txt` - lay1 (k + shift) s sl p )) - - _ -> lay1 k s sl p - lay _ (Above {}) = error "display lay Above" - lay _ (Beside {}) = error "display lay Beside" - lay _ NoDoc = error "display lay NoDoc" - lay _ (Union {}) = error "display lay Union" - - lay1 !k s !sl p = let !r = k + sl - in indent k (s `txt` lay2 r p) - - lay2 k _ | k `seq` False = undefined - lay2 k (NilAbove p) = nlText `txt` lay k p - lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p - lay2 k (Nest _ p) = lay2 k p - lay2 _ Empty = end - lay2 _ (Above {}) = error "display lay2 Above" - lay2 _ (Beside {}) = error "display lay2 Beside" - lay2 _ NoDoc = error "display lay2 NoDoc" - lay2 _ (Union {}) = error "display lay2 Union" - - -- optimise long indentations using LitString chunks of 8 spaces - indent !n r | n >= 8 = LStr (sLit " ") 8 `txt` - indent (n - 8) r - | otherwise = Str (spaces n) `txt` r - in - lay 0 doc - }} - -printDoc :: Mode -> Int -> Handle -> Doc -> IO () --- printDoc adds a newline to the end -printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") - -printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () --- printDoc_ does not add a newline at the end, so that --- successive calls can output stuff on the same line --- Rather like putStr vs putStrLn -printDoc_ LeftMode _ hdl doc - = do { printLeftRender hdl doc; hFlush hdl } -printDoc_ mode pprCols hdl doc - = do { fullRender mode pprCols 1.5 put done doc ; - hFlush hdl } - where - put (Chr c) next = hPutChar hdl c >> next - put (Str s) next = hPutStr hdl s >> next - put (PStr s) next = hPutStr hdl (unpackFS s) >> next - -- NB. not hPutFS, we want this to go through - -- the I/O library's encoding layer. (#3398) - put (ZStr s) next = hPutFZS hdl s >> next - put (LStr s l) next = hPutLitString hdl s l >> next - - done = return () -- hPutChar hdl '\n' - - -- some versions of hPutBuf will barf if the length is zero -hPutLitString :: Handle -> Ptr a -> Int -> IO () -hPutLitString handle a l = if l == 0 - then return () - else hPutBuf handle a l - --- Printing output in LeftMode is performance critical: it's used when --- dumping C and assembly output, so we allow ourselves a few dirty --- hacks: --- --- (1) we specialise fullRender for LeftMode with IO output. --- --- (2) we add a layer of buffering on top of Handles. Handles --- don't perform well with lots of hPutChars, which is mostly --- what we're doing here, because Handles have to be thread-safe --- and async exception-safe. We only have a single thread and don't --- care about exceptions, so we add a layer of fast buffering --- over the Handle interface. - -printLeftRender :: Handle -> Doc -> IO () -printLeftRender hdl doc = do - b <- newBufHandle hdl - bufLeftRender b doc - bFlush b - -bufLeftRender :: BufHandle -> Doc -> IO () -bufLeftRender b doc = layLeft b (reduceDoc doc) - -layLeft :: BufHandle -> Doc -> IO () -layLeft b _ | b `seq` False = undefined -- make it strict in b -layLeft _ NoDoc = error "layLeft: NoDoc" -layLeft b (Union p q) = layLeft b (first p q) -layLeft b (Nest _ p) = layLeft b p -layLeft b Empty = bPutChar b '\n' -layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p -layLeft b (TextBeside s _ p) = put b s >> layLeft b p - where - put b _ | b `seq` False = undefined - put b (Chr c) = bPutChar b c - put b (Str s) = bPutStr b s - put b (PStr s) = bPutFS b s - put b (ZStr s) = bPutFZS b s - put b (LStr s l) = bPutLitString b s l -layLeft _ _ = panic "layLeft: Unhandled case" - --- Define error=panic, for easier comparison with libraries/pretty. -error :: String -> a -error = panic diff --git a/utils/State.hs b/utils/State.hs deleted file mode 100644 --- a/utils/State.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE UnboxedTuples #-} - -module State where - -newtype State s a = State { runState' :: s -> (# a, s #) } - -instance Functor (State s) where - fmap f m = State $ \s -> case runState' m s of - (# r, s' #) -> (# f r, s' #) - -instance Applicative (State s) where - pure x = State $ \s -> (# x, s #) - m <*> n = State $ \s -> case runState' m s of - (# f, s' #) -> case runState' n s' of - (# x, s'' #) -> (# f x, s'' #) - -instance Monad (State s) where - m >>= n = State $ \s -> case runState' m s of - (# r, s' #) -> runState' (n r) s' - -get :: State s s -get = State $ \s -> (# s, s #) - -gets :: (s -> a) -> State s a -gets f = State $ \s -> (# f s, s #) - -put :: s -> State s () -put s' = State $ \_ -> (# (), s' #) - -modify :: (s -> s) -> State s () -modify f = State $ \s -> (# (), f s #) - - -evalState :: State s a -> s -> a -evalState s i = case runState' s i of - (# a, _ #) -> a - - -execState :: State s a -> s -> s -execState s i = case runState' s i of - (# _, s' #) -> s' - - -runState :: State s a -> s -> (a, s) -runState s i = case runState' s i of - (# a, s' #) -> (a, s') diff --git a/utils/Stream.hs b/utils/Stream.hs deleted file mode 100644 --- a/utils/Stream.hs +++ /dev/null @@ -1,104 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 2012 --- --- Monadic streams --- --- ----------------------------------------------------------------------------- -module Stream ( - Stream(..), yield, liftIO, - collect, fromList, - Stream.map, Stream.mapM, Stream.mapAccumL - ) where - -import Control.Monad - --- | --- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence --- of elements of type @a@ followed by a result of type @b@. --- --- More concretely, a value of type @Stream m a b@ can be run using @runStream@ --- in the Monad @m@, and it delivers either --- --- * the final result: @Left b@, or --- * @Right (a,str)@, where @a@ is the next element in the stream, and @str@ --- is a computation to get the rest of the stream. --- --- Stream is itself a Monad, and provides an operation 'yield' that --- produces a new element of the stream. This makes it convenient to turn --- existing monadic computations into streams. --- --- The idea is that Stream is useful for making a monadic computation --- that produces values from time to time. This can be used for --- knitting together two complex monadic operations, so that the --- producer does not have to produce all its values before the --- consumer starts consuming them. We make the producer into a --- Stream, and the consumer pulls on the stream each time it wants a --- new value. --- -newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) } - -instance Monad f => Functor (Stream f a) where - fmap = liftM - -instance Monad m => Applicative (Stream m a) where - pure a = Stream (return (Left a)) - (<*>) = ap - -instance Monad m => Monad (Stream m a) where - - Stream m >>= k = Stream $ do - r <- m - case r of - Left b -> runStream (k b) - Right (a,str) -> return (Right (a, str >>= k)) - -yield :: Monad m => a -> Stream m a () -yield a = Stream (return (Right (a, return ()))) - -liftIO :: IO a -> Stream IO b a -liftIO io = Stream $ io >>= return . Left - --- | Turn a Stream into an ordinary list, by demanding all the elements. -collect :: Monad m => Stream m a () -> m [a] -collect str = go str [] - where - go str acc = do - r <- runStream str - case r of - Left () -> return (reverse acc) - Right (a, str') -> go str' (a:acc) - --- | Turn a list into a 'Stream', by yielding each element in turn. -fromList :: Monad m => [a] -> Stream m a () -fromList = mapM_ yield - --- | Apply a function to each element of a 'Stream', lazily -map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x -map f str = Stream $ do - r <- runStream str - case r of - Left x -> return (Left x) - Right (a, str') -> return (Right (f a, Stream.map f str')) - --- | Apply a monadic operation to each element of a 'Stream', lazily -mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x -mapM f str = Stream $ do - r <- runStream str - case r of - Left x -> return (Left x) - Right (a, str') -> do - b <- f a - return (Right (b, Stream.mapM f str')) - --- | analog of the list-based 'mapAccumL' on Streams. This is a simple --- way to map over a Stream while carrying some state around. -mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a () - -> Stream m b c -mapAccumL f c str = Stream $ do - r <- runStream str - case r of - Left () -> return (Left c) - Right (a, str') -> do - (c',b) <- f c a - return (Right (b, mapAccumL f c' str')) diff --git a/utils/StringBuffer.hs b/utils/StringBuffer.hs deleted file mode 100644 --- a/utils/StringBuffer.hs +++ /dev/null @@ -1,310 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The University of Glasgow, 1997-2006 - - -Buffers for scanning string input stored in external arrays. --} - -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -O #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - -module StringBuffer - ( - StringBuffer(..), - -- non-abstract for vs\/HaskellService - - -- * Creation\/destruction - hGetStringBuffer, - hGetStringBufferBlock, - appendStringBuffers, - stringToStringBuffer, - - -- * Inspection - nextChar, - currentChar, - prevChar, - atEnd, - - -- * Moving and comparison - stepOn, - offsetBytes, - byteDiff, - atLine, - - -- * Conversion - lexemeToString, - lexemeToFastString, - - -- * Parsing integers - parseUnsignedInteger, - ) where - -#include "HsVersions.h" - -import Encoding -import FastString -import FastFunctions -import Outputable -import Util - -import Data.Maybe -import Control.Exception -import System.IO -import System.IO.Unsafe ( unsafePerformIO ) -import GHC.IO.Encoding.UTF8 ( mkUTF8 ) -import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) - -import GHC.Exts - -import Foreign - --- ----------------------------------------------------------------------------- --- The StringBuffer type - --- |A StringBuffer is an internal pointer to a sized chunk of bytes. --- The bytes are intended to be *immutable*. There are pure --- operations to read the contents of a StringBuffer. --- --- A StringBuffer may have a finalizer, depending on how it was --- obtained. --- -data StringBuffer - = StringBuffer { - buf :: {-# UNPACK #-} !(ForeignPtr Word8), - len :: {-# UNPACK #-} !Int, -- length - cur :: {-# UNPACK #-} !Int -- current pos - } - -- The buffer is assumed to be UTF-8 encoded, and furthermore - -- we add three '\0' bytes to the end as sentinels so that the - -- decoder doesn't have to check for overflow at every single byte - -- of a multibyte sequence. - -instance Show StringBuffer where - showsPrec _ s = showString "" - --- ----------------------------------------------------------------------------- --- Creation / Destruction - --- | Read a file into a 'StringBuffer'. The resulting buffer is automatically --- managed by the garbage collector. -hGetStringBuffer :: FilePath -> IO StringBuffer -hGetStringBuffer fname = do - h <- openBinaryFile fname ReadMode - size_i <- hFileSize h - offset_i <- skipBOM h size_i 0 -- offset is 0 initially - let size = fromIntegral $ size_i - offset_i - buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> do - r <- if size == 0 then return 0 else hGetBuf h ptr size - hClose h - if (r /= size) - then ioError (userError "short read of file") - else newUTF8StringBuffer buf ptr size - -hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer -hGetStringBufferBlock handle wanted - = do size_i <- hFileSize handle - offset_i <- hTell handle >>= skipBOM handle size_i - let size = min wanted (fromIntegral $ size_i-offset_i) - buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> - do r <- if size == 0 then return 0 else hGetBuf handle ptr size - if r /= size - then ioError (userError $ "short read of file: "++show(r,size,size_i,handle)) - else newUTF8StringBuffer buf ptr size - --- | Skip the byte-order mark if there is one (see #1744 and #6016), --- and return the new position of the handle in bytes. --- --- This is better than treating #FEFF as whitespace, --- because that would mess up layout. We don't have a concept --- of zero-width whitespace in Haskell: all whitespace codepoints --- have a width of one column. -skipBOM :: Handle -> Integer -> Integer -> IO Integer -skipBOM h size offset = - -- Only skip BOM at the beginning of a file. - if size > 0 && offset == 0 - then do - -- Validate assumption that handle is in binary mode. - ASSERTM( hGetEncoding h >>= return . isNothing ) - -- Temporarily select utf8 encoding with error ignoring, - -- to make `hLookAhead` and `hGetChar` return full Unicode characters. - bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do - c <- hLookAhead h - if c == '\xfeff' - then hGetChar h >> hTell h - else return offset - else return offset - where - safeEncoding = mkUTF8 IgnoreCodingFailure - -newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer -newUTF8StringBuffer buf ptr size = do - pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] - -- sentinels for UTF-8 decoding - return $ StringBuffer buf size 0 - -appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer -appendStringBuffers sb1 sb2 - = do newBuf <- mallocForeignPtrArray (size+3) - withForeignPtr newBuf $ \ptr -> - withForeignPtr (buf sb1) $ \sb1Ptr -> - withForeignPtr (buf sb2) $ \sb2Ptr -> - do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len - copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len - pokeArray (ptr `advancePtr` size) [0,0,0] - return (StringBuffer newBuf size 0) - where sb1_len = calcLen sb1 - sb2_len = calcLen sb2 - calcLen sb = len sb - cur sb - size = sb1_len + sb2_len - --- | Encode a 'String' into a 'StringBuffer' as UTF-8. The resulting buffer --- is automatically managed by the garbage collector. -stringToStringBuffer :: String -> StringBuffer -stringToStringBuffer str = - unsafePerformIO $ do - let size = utf8EncodedLength str - buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> do - utf8EncodeString ptr str - pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] - -- sentinels for UTF-8 decoding - return (StringBuffer buf size 0) - --- ----------------------------------------------------------------------------- --- Grab a character - --- | Return the first UTF-8 character of a nonempty 'StringBuffer' and as well --- the remaining portion (analogous to 'Data.List.uncons'). __Warning:__ The --- behavior is undefined if the 'StringBuffer' is empty. The result shares --- the same buffer as the original. Similar to 'utf8DecodeChar', if the --- character cannot be decoded as UTF-8, '\0' is returned. -{-# INLINE nextChar #-} -nextChar :: StringBuffer -> (Char,StringBuffer) -nextChar (StringBuffer buf len (I# cur#)) = - -- Getting our fingers dirty a little here, but this is performance-critical - inlinePerformIO $ do - withForeignPtr buf $ \(Ptr a#) -> do - case utf8DecodeChar# (a# `plusAddr#` cur#) of - (# c#, nBytes# #) -> - let cur' = I# (cur# +# nBytes#) in - return (C# c#, StringBuffer buf len cur') - --- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous --- to 'Data.List.head'). __Warning:__ The behavior is undefined if the --- 'StringBuffer' is empty. Similar to 'utf8DecodeChar', if the character --- cannot be decoded as UTF-8, '\0' is returned. -currentChar :: StringBuffer -> Char -currentChar = fst . nextChar - -prevChar :: StringBuffer -> Char -> Char -prevChar (StringBuffer _ _ 0) deflt = deflt -prevChar (StringBuffer buf _ cur) _ = - inlinePerformIO $ do - withForeignPtr buf $ \p -> do - p' <- utf8PrevChar (p `plusPtr` cur) - return (fst (utf8DecodeChar p')) - --- ----------------------------------------------------------------------------- --- Moving - --- | Return a 'StringBuffer' with the first UTF-8 character removed (analogous --- to 'Data.List.tail'). __Warning:__ The behavior is undefined if the --- 'StringBuffer' is empty. The result shares the same buffer as the --- original. -stepOn :: StringBuffer -> StringBuffer -stepOn s = snd (nextChar s) - --- | Return a 'StringBuffer' with the first @n@ bytes removed. __Warning:__ --- If there aren't enough characters, the returned 'StringBuffer' will be --- invalid and any use of it may lead to undefined behavior. The result --- shares the same buffer as the original. -offsetBytes :: Int -- ^ @n@, the number of bytes - -> StringBuffer - -> StringBuffer -offsetBytes i s = s { cur = cur s + i } - --- | Compute the difference in offset between two 'StringBuffer's that share --- the same buffer. __Warning:__ The behavior is undefined if the --- 'StringBuffer's use separate buffers. -byteDiff :: StringBuffer -> StringBuffer -> Int -byteDiff s1 s2 = cur s2 - cur s1 - --- | Check whether a 'StringBuffer' is empty (analogous to 'Data.List.null'). -atEnd :: StringBuffer -> Bool -atEnd (StringBuffer _ l c) = l == c - --- | Computes a 'StringBuffer' which points to the first character of the --- wanted line. Lines begin at 1. -atLine :: Int -> StringBuffer -> Maybe StringBuffer -atLine line sb@(StringBuffer buf len _) = - inlinePerformIO $ - withForeignPtr buf $ \p -> do - p' <- skipToLine line len p - if p' == nullPtr - then return Nothing - else - let - delta = p' `minusPtr` p - in return $ Just (sb { cur = delta - , len = len - delta - }) - -skipToLine :: Int -> Int -> Ptr Word8 -> IO (Ptr Word8) -skipToLine !line !len !op0 = go 1 op0 - where - !opend = op0 `plusPtr` len - - go !i_line !op - | op >= opend = pure nullPtr - | i_line == line = pure op - | otherwise = do - w <- peek op :: IO Word8 - case w of - 10 -> go (i_line + 1) (plusPtr op 1) - 13 -> do - -- this is safe because a 'StringBuffer' is - -- guaranteed to have 3 bytes sentinel values. - w' <- peek (plusPtr op 1) :: IO Word8 - case w' of - 10 -> go (i_line + 1) (plusPtr op 2) - _ -> go (i_line + 1) (plusPtr op 1) - _ -> go i_line (plusPtr op 1) - --- ----------------------------------------------------------------------------- --- Conversion - --- | Decode the first @n@ bytes of a 'StringBuffer' as UTF-8 into a 'String'. --- Similar to 'utf8DecodeChar', if the character cannot be decoded as UTF-8, --- they will be replaced with '\0'. -lexemeToString :: StringBuffer - -> Int -- ^ @n@, the number of bytes - -> String -lexemeToString _ 0 = "" -lexemeToString (StringBuffer buf _ cur) bytes = - utf8DecodeStringLazy buf cur bytes - -lexemeToFastString :: StringBuffer - -> Int -- ^ @n@, the number of bytes - -> FastString -lexemeToFastString _ 0 = nilFS -lexemeToFastString (StringBuffer buf _ cur) len = - inlinePerformIO $ - withForeignPtr buf $ \ptr -> - return $! mkFastStringBytes (ptr `plusPtr` cur) len - --- ----------------------------------------------------------------------------- --- Parsing integer strings in various bases -parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer -parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int - = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let - go i x | i == len = x - | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of - char -> go (i + 1) (x * radix + toInteger (char_to_int char)) - in go 0 0 diff --git a/utils/UnVarGraph.hs b/utils/UnVarGraph.hs deleted file mode 100644 --- a/utils/UnVarGraph.hs +++ /dev/null @@ -1,136 +0,0 @@ -{- - -Copyright (c) 2014 Joachim Breitner - -A data structure for undirected graphs of variables -(or in plain terms: Sets of unordered pairs of numbers) - - -This is very specifically tailored for the use in CallArity. In particular it -stores the graph as a union of complete and complete bipartite graph, which -would be very expensive to store as sets of edges or as adjanceny lists. - -It does not normalize the graphs. This means that g `unionUnVarGraph` g is -equal to g, but twice as expensive and large. - --} -module UnVarGraph - ( UnVarSet - , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets - , delUnVarSet - , elemUnVarSet, isEmptyUnVarSet - , UnVarGraph - , emptyUnVarGraph - , unionUnVarGraph, unionUnVarGraphs - , completeGraph, completeBipartiteGraph - , neighbors - , delNode - ) where - -import Id -import VarEnv -import UniqFM -import Outputable -import Data.List -import Bag -import Unique - -import qualified Data.IntSet as S - --- We need a type for sets of variables (UnVarSet). --- We do not use VarSet, because for that we need to have the actual variable --- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. --- Therefore, use a IntSet directly (which is likely also a bit more efficient). - --- Set of uniques, i.e. for adjancet nodes -newtype UnVarSet = UnVarSet (S.IntSet) - deriving Eq - -k :: Var -> Int -k v = getKey (getUnique v) - -emptyUnVarSet :: UnVarSet -emptyUnVarSet = UnVarSet S.empty - -elemUnVarSet :: Var -> UnVarSet -> Bool -elemUnVarSet v (UnVarSet s) = k v `S.member` s - - -isEmptyUnVarSet :: UnVarSet -> Bool -isEmptyUnVarSet (UnVarSet s) = S.null s - -delUnVarSet :: UnVarSet -> Var -> UnVarSet -delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s - -mkUnVarSet :: [Var] -> UnVarSet -mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs - -varEnvDom :: VarEnv a -> UnVarSet -varEnvDom ae = UnVarSet $ ufmToSet_Directly ae - -unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet -unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) - -unionUnVarSets :: [UnVarSet] -> UnVarSet -unionUnVarSets = foldr unionUnVarSet emptyUnVarSet - -instance Outputable UnVarSet where - ppr (UnVarSet s) = braces $ - hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] - - --- The graph type. A list of complete bipartite graphs -data Gen = CBPG UnVarSet UnVarSet -- complete bipartite - | CG UnVarSet -- complete -newtype UnVarGraph = UnVarGraph (Bag Gen) - -emptyUnVarGraph :: UnVarGraph -emptyUnVarGraph = UnVarGraph emptyBag - -unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph -{- -Premature optimisation, it seems. -unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) - | s1 == s3 && s2 == s4 - = pprTrace "unionUnVarGraph fired" empty $ - completeGraph (s1 `unionUnVarSet` s2) -unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) - | s2 == s3 && s1 == s4 - = pprTrace "unionUnVarGraph fired2" empty $ - completeGraph (s1 `unionUnVarSet` s2) --} -unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) - = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ - UnVarGraph (g1 `unionBags` g2) - -unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph -unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph - --- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } -completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph -completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 - -completeGraph :: UnVarSet -> UnVarGraph -completeGraph s = prune $ UnVarGraph $ unitBag $ CG s - -neighbors :: UnVarGraph -> Var -> UnVarSet -neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g - where go (CG s) = (if v `elemUnVarSet` s then [s] else []) - go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ - (if v `elemUnVarSet` s2 then [s1] else []) - -delNode :: UnVarGraph -> Var -> UnVarGraph -delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g - where go (CG s) = CG (s `delUnVarSet` v) - go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) - -prune :: UnVarGraph -> UnVarGraph -prune (UnVarGraph g) = UnVarGraph $ filterBag go g - where go (CG s) = not (isEmptyUnVarSet s) - go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) - -instance Outputable Gen where - ppr (CG s) = ppr s <> char '²' - ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 -instance Outputable UnVarGraph where - ppr (UnVarGraph g) = ppr g diff --git a/utils/UniqDFM.hs b/utils/UniqDFM.hs deleted file mode 100644 --- a/utils/UniqDFM.hs +++ /dev/null @@ -1,398 +0,0 @@ -{- -(c) Bartosz Nitka, Facebook, 2015 - -UniqDFM: Specialised deterministic finite maps, for things with @Uniques@. - -Basically, the things need to be in class @Uniquable@, and we use the -@getUnique@ method to grab their @Uniques@. - -This is very similar to @UniqFM@, the major difference being that the order of -folding is not dependent on @Unique@ ordering, giving determinism. -Currently the ordering is determined by insertion order. - -See Note [Unique Determinism] in Unique for explanation why @Unique@ ordering -is not deterministic. --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -Wall #-} - -module UniqDFM ( - -- * Unique-keyed deterministic mappings - UniqDFM, -- abstract type - - -- ** Manipulating those mappings - emptyUDFM, - unitUDFM, - addToUDFM, - addToUDFM_C, - addListToUDFM, - delFromUDFM, - delListFromUDFM, - adjustUDFM, - alterUDFM, - mapUDFM, - plusUDFM, - plusUDFM_C, - lookupUDFM, lookupUDFM_Directly, - elemUDFM, - foldUDFM, - eltsUDFM, - filterUDFM, filterUDFM_Directly, - isNullUDFM, - sizeUDFM, - intersectUDFM, udfmIntersectUFM, - intersectsUDFM, - disjointUDFM, disjointUdfmUfm, - minusUDFM, - listToUDFM, - udfmMinusUFM, - partitionUDFM, - anyUDFM, allUDFM, - pprUDFM, - - udfmToList, - udfmToUfm, - nonDetFoldUDFM, - alwaysUnsafeUfmToUdfm, - ) where - -import Unique ( Uniquable(..), Unique, getKey ) -import Outputable - -import qualified Data.IntMap as M -import Data.Data -import Data.List (sortBy) -import Data.Function (on) -import UniqFM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap) - --- Note [Deterministic UniqFM] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- A @UniqDFM@ is just like @UniqFM@ with the following additional --- property: the function `udfmToList` returns the elements in some --- deterministic order not depending on the Unique key for those elements. --- --- If the client of the map performs operations on the map in deterministic --- order then `udfmToList` returns them in deterministic order. --- --- There is an implementation cost: each element is given a serial number --- as it is added, and `udfmToList` sorts it's result by this serial --- number. So you should only use `UniqDFM` if you need the deterministic --- property. --- --- `foldUDFM` also preserves determinism. --- --- Normal @UniqFM@ when you turn it into a list will use --- Data.IntMap.toList function that returns the elements in the order of --- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with --- with a list ordered by @Uniques@. --- The order of @Uniques@ is known to be not stable across rebuilds. --- See Note [Unique Determinism] in Unique. --- --- --- There's more than one way to implement this. The implementation here tags --- every value with the insertion time that can later be used to sort the --- values when asked to convert to a list. --- --- An alternative would be to have --- --- data UniqDFM ele = UDFM (M.IntMap ele) [ele] --- --- where the list determines the order. This makes deletion tricky as we'd --- only accumulate elements in that list, but makes merging easier as you --- can just merge both structures independently. --- Deletion can probably be done in amortized fashion when the size of the --- list is twice the size of the set. - --- | A type of values tagged with insertion time -data TaggedVal val = - TaggedVal - val - {-# UNPACK #-} !Int -- ^ insertion time - deriving Data - -taggedFst :: TaggedVal val -> val -taggedFst (TaggedVal v _) = v - -taggedSnd :: TaggedVal val -> Int -taggedSnd (TaggedVal _ i) = i - -instance Eq val => Eq (TaggedVal val) where - (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2 - -instance Functor TaggedVal where - fmap f (TaggedVal val i) = TaggedVal (f val) i - --- | Type of unique deterministic finite maps -data UniqDFM ele = - UDFM - !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and - -- values are tagged with insertion time. - -- The invariant is that all the tags will - -- be distinct within a single map - {-# UNPACK #-} !Int -- Upper bound on the values' insertion - -- time. See Note [Overflow on plusUDFM] - deriving (Data, Functor) - -emptyUDFM :: UniqDFM elt -emptyUDFM = UDFM M.empty 0 - -unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt -unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1 - -addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt -> UniqDFM elt -addToUDFM m k v = addToUDFM_Directly m (getUnique k) v - -addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt -addToUDFM_Directly (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) - where - tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i - -- Keep the old tag, but insert the new value - -- This means that udfmToList typically returns elements - -- in the order of insertion, rather than the reverse - -addToUDFM_Directly_C - :: (elt -> elt -> elt) -- old -> new -> result - -> UniqDFM elt - -> Unique -> elt - -> UniqDFM elt -addToUDFM_Directly_C f (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) - where - tf (TaggedVal new_v _) (TaggedVal old_v old_i) - = TaggedVal (f old_v new_v) old_i - -- Flip the arguments, because M.insertWith uses (new->old->result) - -- but f needs (old->new->result) - -- Like addToUDFM_Directly, keep the old tag - -addToUDFM_C - :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result - -> UniqDFM elt -- old - -> key -> elt -- new - -> UniqDFM elt -- result -addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v - -addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt -addListToUDFM = foldl (\m (k, v) -> addToUDFM m k v) - -addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt -addListToUDFM_Directly = foldl (\m (k, v) -> addToUDFM_Directly m k v) - -addListToUDFM_Directly_C - :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt -addListToUDFM_Directly_C f = foldl (\m (k, v) -> addToUDFM_Directly_C f m k v) - -delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt -delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i - -plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt -plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j) - -- we will use the upper bound on the tag as a proxy for the set size, - -- to insert the smaller one into the bigger one - | i > j = insertUDFMIntoLeft_C f udfml udfmr - | otherwise = insertUDFMIntoLeft_C f udfmr udfml - --- Note [Overflow on plusUDFM] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- There are multiple ways of implementing plusUDFM. --- The main problem that needs to be solved is overlap on times of --- insertion between different keys in two maps. --- Consider: --- --- A = fromList [(a, (x, 1))] --- B = fromList [(b, (y, 1))] --- --- If you merge them naively you end up with: --- --- C = fromList [(a, (x, 1)), (b, (y, 1))] --- --- Which loses information about ordering and brings us back into --- non-deterministic world. --- --- The solution I considered before would increment the tags on one of the --- sets by the upper bound of the other set. The problem with this approach --- is that you'll run out of tags for some merge patterns. --- Say you start with A with upper bound 1, you merge A with A to get A' and --- the upper bound becomes 2. You merge A' with A' and the upper bound --- doubles again. After 64 merges you overflow. --- This solution would have the same time complexity as plusUFM, namely O(n+m). --- --- The solution I ended up with has time complexity of --- O(m log m + m * min (n+m, W)) where m is the smaller set. --- It simply inserts the elements of the smaller set into the larger --- set in the order that they were inserted into the smaller set. That's --- O(m log m) for extracting the elements from the smaller set in the --- insertion order and O(m * min(n+m, W)) to insert them into the bigger --- set. - -plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j) - -- we will use the upper bound on the tag as a proxy for the set size, - -- to insert the smaller one into the bigger one - | i > j = insertUDFMIntoLeft udfml udfmr - | otherwise = insertUDFMIntoLeft udfmr udfml - -insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr - -insertUDFMIntoLeft_C - :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt -insertUDFMIntoLeft_C f udfml udfmr = - addListToUDFM_Directly_C f udfml $ udfmToList udfmr - -lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt -lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m - -lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt -lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m - -elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool -elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m - --- | Performs a deterministic fold over the UniqDFM. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). -foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a -foldUDFM k z m = foldr k z (eltsUDFM m) - --- | Performs a nondeterministic fold over the UniqDFM. --- It's O(n), same as the corresponding function on `UniqFM`. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a -nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m - -eltsUDFM :: UniqDFM elt -> [elt] -eltsUDFM (UDFM m _i) = - map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m - -filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt -filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i - -filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt -filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i - where - p' k (TaggedVal v _) = p (getUnique k) v - --- | Converts `UniqDFM` to a list, with elements in deterministic order. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). -udfmToList :: UniqDFM elt -> [(Unique, elt)] -udfmToList (UDFM m _i) = - [ (getUnique k, taggedFst v) - | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] - -isNullUDFM :: UniqDFM elt -> Bool -isNullUDFM (UDFM m _) = M.null m - -sizeUDFM :: UniqDFM elt -> Int -sizeUDFM (UDFM m _i) = M.size m - -intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i - -- M.intersection is left biased, that means the result will only have - -- a subset of elements from the left set, so `i` is a good upper bound. - -udfmIntersectUFM :: UniqDFM elt -> UniqFM elt -> UniqDFM elt -udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i - -- M.intersection is left biased, that means the result will only have - -- a subset of elements from the left set, so `i` is a good upper bound. - -intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool -intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y) - -disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool -disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y) - -disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool -disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y)) - -minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1 -minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i - -- M.difference returns a subset of a left set, so `i` is a good upper - -- bound. - -udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 -udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i - -- M.difference returns a subset of a left set, so `i` is a good upper - -- bound. - --- | Partition UniqDFM into two UniqDFMs according to the predicate -partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt) -partitionUDFM p (UDFM m i) = - case M.partition (p . taggedFst) m of - (left, right) -> (UDFM left i, UDFM right i) - --- | Delete a list of elements from a UniqDFM -delListFromUDFM :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt -delListFromUDFM = foldl delFromUDFM - --- | This allows for lossy conversion from UniqDFM to UniqFM -udfmToUfm :: UniqDFM elt -> UniqFM elt -udfmToUfm (UDFM m _i) = - listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m] - -listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt -listToUDFM = foldl (\m (k, v) -> addToUDFM m k v) emptyUDFM - -listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt -listToUDFM_Directly = foldl (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM - --- | Apply a function to a particular element -adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt -adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i - --- | The expression (alterUDFM f k map) alters value x at k, or absence --- thereof. alterUDFM can be used to insert, delete, or update a value in --- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are --- more efficient. -alterUDFM - :: Uniquable key - => (Maybe elt -> Maybe elt) -- How to adjust - -> UniqDFM elt -- old - -> key -- new - -> UniqDFM elt -- result -alterUDFM f (UDFM m i) k = - UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) - where - alterf Nothing = inject $ f Nothing - alterf (Just (TaggedVal v _)) = inject $ f (Just v) - inject Nothing = Nothing - inject (Just v) = Just $ TaggedVal v i - --- | Map a function over every value in a UniqDFM -mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2 -mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i - -anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool -anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m - -allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool -allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m - -instance Monoid (UniqDFM a) where - mempty = emptyUDFM - mappend = plusUDFM - --- This should not be used in commited code, provided for convenience to --- make ad-hoc conversions when developing -alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt -alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList - --- Output-ery - -instance Outputable a => Outputable (UniqDFM a) where - ppr ufm = pprUniqDFM ppr ufm - -pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc -pprUniqDFM ppr_elt ufm - = brackets $ fsep $ punctuate comma $ - [ ppr uq <+> text ":->" <+> ppr_elt elt - | (uq, elt) <- udfmToList ufm ] - -pprUDFM :: UniqDFM a -- ^ The things to be pretty printed - -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUDFM ufm pp = pp (eltsUDFM ufm) diff --git a/utils/UniqDSet.hs b/utils/UniqDSet.hs deleted file mode 100644 --- a/utils/UniqDSet.hs +++ /dev/null @@ -1,103 +0,0 @@ --- (c) Bartosz Nitka, Facebook, 2015 - --- | --- Specialised deterministic sets, for things with @Uniques@ --- --- Based on @UniqDFMs@ (as you would expect). --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need it. --- --- Basically, the things need to be in class @Uniquable@. - -module UniqDSet ( - -- * Unique set type - UniqDSet, -- type synonym for UniqFM a - - -- ** Manipulating these sets - delOneFromUniqDSet, delListFromUniqDSet, - emptyUniqDSet, - unitUniqDSet, - mkUniqDSet, - addOneToUniqDSet, addListToUniqDSet, - unionUniqDSets, unionManyUniqDSets, - minusUniqDSet, uniqDSetMinusUniqSet, - intersectUniqDSets, - intersectsUniqDSets, - foldUniqDSet, - elementOfUniqDSet, - filterUniqDSet, - sizeUniqDSet, - isEmptyUniqDSet, - lookupUniqDSet, - uniqDSetToList, - partitionUniqDSet - ) where - -import UniqDFM -import UniqSet -import Unique - -type UniqDSet a = UniqDFM a - -emptyUniqDSet :: UniqDSet a -emptyUniqDSet = emptyUDFM - -unitUniqDSet :: Uniquable a => a -> UniqDSet a -unitUniqDSet x = unitUDFM x x - -mkUniqDSet :: Uniquable a => [a] -> UniqDSet a -mkUniqDSet = foldl addOneToUniqDSet emptyUniqDSet - -addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a -addOneToUniqDSet set x = addToUDFM set x x - -addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a -addListToUniqDSet = foldl addOneToUniqDSet - -delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a -delOneFromUniqDSet = delFromUDFM - -delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a -delListFromUniqDSet = delListFromUDFM - -unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a -unionUniqDSets = plusUDFM - -unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a -unionManyUniqDSets [] = emptyUniqDSet -unionManyUniqDSets sets = foldr1 unionUniqDSets sets - -minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a -minusUniqDSet = minusUDFM - -uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet a -> UniqDSet a -uniqDSetMinusUniqSet xs ys = udfmMinusUFM xs (getUniqSet ys) - -intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a -intersectUniqDSets = intersectUDFM - -intersectsUniqDSets :: UniqDSet a -> UniqDSet a -> Bool -intersectsUniqDSets = intersectsUDFM - -foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b -foldUniqDSet = foldUDFM - -elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool -elementOfUniqDSet = elemUDFM - -filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a -filterUniqDSet = filterUDFM - -sizeUniqDSet :: UniqDSet a -> Int -sizeUniqDSet = sizeUDFM - -isEmptyUniqDSet :: UniqDSet a -> Bool -isEmptyUniqDSet = isNullUDFM - -lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a -lookupUniqDSet = lookupUDFM - -uniqDSetToList :: UniqDSet a -> [a] -uniqDSetToList = eltsUDFM - -partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) -partitionUniqDSet = partitionUDFM diff --git a/utils/UniqFM.hs b/utils/UniqFM.hs deleted file mode 100644 --- a/utils/UniqFM.hs +++ /dev/null @@ -1,411 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - - -UniqFM: Specialised finite maps, for things with @Uniques@. - -Basically, the things need to be in class @Uniquable@, and we use the -@getUnique@ method to grab their @Uniques@. - -(A similar thing to @UniqSet@, as opposed to @Set@.) - -The interface is based on @FiniteMap@s, but the implementation uses -@Data.IntMap@, which is both maintained and faster than the past -implementation (see commit log). - -The @UniqFM@ interface maps directly to Data.IntMap, only -``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased -and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order -of arguments of combining function. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -Wall #-} - -module UniqFM ( - -- * Unique-keyed mappings - UniqFM, -- abstract type - - -- ** Manipulating those mappings - emptyUFM, - unitUFM, - unitDirectlyUFM, - listToUFM, - listToUFM_Directly, - listToUFM_C, - addToUFM,addToUFM_C,addToUFM_Acc, - addListToUFM,addListToUFM_C, - addToUFM_Directly, - addListToUFM_Directly, - adjustUFM, alterUFM, - adjustUFM_Directly, - delFromUFM, - delFromUFM_Directly, - delListFromUFM, - delListFromUFM_Directly, - plusUFM, - plusUFM_C, - plusUFM_CD, - plusMaybeUFM_C, - plusUFMList, - minusUFM, - intersectUFM, - intersectUFM_C, - disjointUFM, - equalKeysUFM, - nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly, - anyUFM, allUFM, seqEltsUFM, - mapUFM, mapUFM_Directly, - elemUFM, elemUFM_Directly, - filterUFM, filterUFM_Directly, partitionUFM, - sizeUFM, - isNullUFM, - lookupUFM, lookupUFM_Directly, - lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, - nonDetEltsUFM, eltsUFM, nonDetKeysUFM, - ufmToSet_Directly, - nonDetUFMToList, ufmToIntMap, - pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM - ) where - -import Unique ( Uniquable(..), Unique, getKey ) -import Outputable - -import Data.List (foldl') - -import qualified Data.IntMap as M -#if MIN_VERSION_containers(0,5,9) -import qualified Data.IntMap.Merge.Lazy as M -import Control.Applicative (Const (..)) -import qualified Data.Monoid as Mon -#endif -import qualified Data.IntSet as S -import Data.Typeable -import Data.Data -#if __GLASGOW_HASKELL__ > 710 -import Data.Semigroup ( Semigroup ) -import qualified Data.Semigroup as Semigroup -#endif - - -newtype UniqFM ele = UFM (M.IntMap ele) - deriving (Data, Eq, Functor, Typeable) - -- We used to derive Traversable and Foldable, but they were nondeterministic - -- and not obvious at the call site. You can use explicit nonDetEltsUFM - -- and fold a list if needed. - -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. - -emptyUFM :: UniqFM elt -emptyUFM = UFM M.empty - -isNullUFM :: UniqFM elt -> Bool -isNullUFM (UFM m) = M.null m - -unitUFM :: Uniquable key => key -> elt -> UniqFM elt -unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v) - --- when you've got the Unique already -unitDirectlyUFM :: Unique -> elt -> UniqFM elt -unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) - -listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt -listToUFM = foldl (\m (k, v) -> addToUFM m k v) emptyUFM - -listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt -listToUFM_Directly = foldl (\m (u, v) -> addToUFM_Directly m u v) emptyUFM - -listToUFM_C - :: Uniquable key - => (elt -> elt -> elt) - -> [(key, elt)] - -> UniqFM elt -listToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) emptyUFM - -addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt -addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) - -addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt -addListToUFM = foldl (\m (k, v) -> addToUFM m k v) - -addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt -addListToUFM_Directly = foldl (\m (k, v) -> addToUFM_Directly m k v) - -addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt -addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) - -addToUFM_C - :: Uniquable key - => (elt -> elt -> elt) -- old -> new -> result - -> UniqFM elt -- old - -> key -> elt -- new - -> UniqFM elt -- result --- Arguments of combining function of M.insertWith and addToUFM_C are flipped. -addToUFM_C f (UFM m) k v = - UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) - -addToUFM_Acc - :: Uniquable key - => (elt -> elts -> elts) -- Add to existing - -> (elt -> elts) -- New element - -> UniqFM elts -- old - -> key -> elt -- new - -> UniqFM elts -- result -addToUFM_Acc exi new (UFM m) k v = - UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) - -alterUFM - :: Uniquable key - => (Maybe elt -> Maybe elt) -- How to adjust - -> UniqFM elt -- old - -> key -- new - -> UniqFM elt -- result -alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) - -addListToUFM_C - :: Uniquable key - => (elt -> elt -> elt) - -> UniqFM elt -> [(key,elt)] - -> UniqFM elt -addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) - -adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt -adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) - -adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt -adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) - -delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt -delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) - -delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt -delListFromUFM = foldl delFromUFM - -delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt -delListFromUFM_Directly = foldl delFromUFM_Directly - -delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt -delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) - --- Bindings in right argument shadow those in the left -plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt --- M.union is left-biased, plusUFM should be right-biased. -plusUFM (UFM x) (UFM y) = UFM (M.union y x) - -- Note (M.union y x), with arguments flipped - -- M.union is left-biased, plusUFM should be right-biased. - -plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt -plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) - --- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the --- combinding function and `d1` resp. `d2` as the default value if --- there is no entry in `m1` reps. `m2`. The domain is the union of --- the domains of `m1` and `m2`. --- --- Representative example: --- --- @ --- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 --- == {A: f 1 42, B: f 2 3, C: f 23 4 } --- @ -plusUFM_CD - :: (elt -> elt -> elt) - -> UniqFM elt -- map X - -> elt -- default for X - -> UniqFM elt -- map Y - -> elt -- default for Y - -> UniqFM elt -plusUFM_CD f (UFM xm) dx (UFM ym) dy - = UFM $ M.mergeWithKey - (\_ x y -> Just (x `f` y)) - (M.map (\x -> x `f` dy)) - (M.map (\y -> dx `f` y)) - xm ym - -plusMaybeUFM_C :: (elt -> elt -> Maybe elt) - -> UniqFM elt -> UniqFM elt -> UniqFM elt -plusMaybeUFM_C f (UFM xm) (UFM ym) - = UFM $ M.mergeWithKey - (\_ x y -> x `f` y) - id - id - xm ym - -plusUFMList :: [UniqFM elt] -> UniqFM elt -plusUFMList = foldl' plusUFM emptyUFM - -minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 -minusUFM (UFM x) (UFM y) = UFM (M.difference x y) - -intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 -intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) - -intersectUFM_C - :: (elt1 -> elt2 -> elt3) - -> UniqFM elt1 - -> UniqFM elt2 - -> UniqFM elt3 -intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) - -disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool -disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y) - -foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a -foldUFM k z (UFM m) = M.foldr k z m - -mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 -mapUFM f (UFM m) = UFM (M.map f m) - -mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 -mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) - -filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt -filterUFM p (UFM m) = UFM (M.filter p m) - -filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt -filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) - -partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt) -partitionUFM p (UFM m) = - case M.partition p m of - (left, right) -> (UFM left, UFM right) - -sizeUFM :: UniqFM elt -> Int -sizeUFM (UFM m) = M.size m - -elemUFM :: Uniquable key => key -> UniqFM elt -> Bool -elemUFM k (UFM m) = M.member (getKey $ getUnique k) m - -elemUFM_Directly :: Unique -> UniqFM elt -> Bool -elemUFM_Directly u (UFM m) = M.member (getKey u) m - -lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt -lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m - --- when you've got the Unique already -lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt -lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m - -lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt -lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m - -lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt -lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m - -eltsUFM :: UniqFM elt -> [elt] -eltsUFM (UFM m) = M.elems m - -ufmToSet_Directly :: UniqFM elt -> S.IntSet -ufmToSet_Directly (UFM m) = M.keysSet m - -anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool -anyUFM p (UFM m) = M.foldr ((||) . p) False m - -allUFM :: (elt -> Bool) -> UniqFM elt -> Bool -allUFM p (UFM m) = M.foldr ((&&) . p) True m - -seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> () -seqEltsUFM seqList = seqList . nonDetEltsUFM - -- It's OK to use nonDetEltsUFM here because the type guarantees that - -- the only interesting thing this function can do is to force the - -- elements. - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetEltsUFM :: UniqFM elt -> [elt] -nonDetEltsUFM (UFM m) = M.elems m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetKeysUFM :: UniqFM elt -> [Unique] -nonDetKeysUFM (UFM m) = map getUnique $ M.keys m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a -nonDetFoldUFM k z (UFM m) = M.foldr k z m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a -nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetUFMToList :: UniqFM elt -> [(Unique, elt)] -nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m - -ufmToIntMap :: UniqFM elt -> M.IntMap elt -ufmToIntMap (UFM m) = m - --- Determines whether two 'UniqFm's contain the same keys. -equalKeysUFM :: UniqFM a -> UniqFM b -> Bool -#if MIN_VERSION_containers(0,5,9) -equalKeysUFM (UFM m1) (UFM m2) = Mon.getAll $ getConst $ - M.mergeA (M.traverseMissing (\_ _ -> Const (Mon.All False))) - (M.traverseMissing (\_ _ -> Const (Mon.All False))) - (M.zipWithAMatched (\_ _ _ -> Const (Mon.All True))) m1 m2 -#else -equalKeysUFM (UFM m1) (UFM m2) = M.keys m1 == M.keys m2 -#endif - --- Instances - -#if __GLASGOW_HASKELL__ > 710 -instance Semigroup (UniqFM a) where - (<>) = plusUFM -#endif - -instance Monoid (UniqFM a) where - mempty = emptyUFM - mappend = plusUFM - --- Output-ery - -instance Outputable a => Outputable (UniqFM a) where - ppr ufm = pprUniqFM ppr ufm - -pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc -pprUniqFM ppr_elt ufm - = brackets $ fsep $ punctuate comma $ - [ ppr uq <+> text ":->" <+> ppr_elt elt - | (uq, elt) <- nonDetUFMToList ufm ] - -- It's OK to use nonDetUFMToList here because we only use it for - -- pretty-printing. - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetEltsUFM. -pprUFM :: UniqFM a -- ^ The things to be pretty printed - -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUFM ufm pp = pp (nonDetEltsUFM ufm) - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetUFMToList. -pprUFMWithKeys - :: UniqFM a -- ^ The things to be pretty printed - -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm) - --- | Determines the pluralisation suffix appropriate for the length of a set --- in the same way that plural from Outputable does for lists. -pluralUFM :: UniqFM a -> SDoc -pluralUFM ufm - | sizeUFM ufm == 1 = empty - | otherwise = char 's' diff --git a/utils/UniqSet.hs b/utils/UniqSet.hs deleted file mode 100644 --- a/utils/UniqSet.hs +++ /dev/null @@ -1,206 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - -\section[UniqSet]{Specialised sets, for things with @Uniques@} - -Based on @UniqFMs@ (as you would expect). - -Basically, the things need to be in class @Uniquable@. --} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module UniqSet ( - -- * Unique set type - UniqSet, -- type synonym for UniqFM a - getUniqSet, - pprUniqSet, - - -- ** Manipulating these sets - emptyUniqSet, - unitUniqSet, - mkUniqSet, - addOneToUniqSet, addListToUniqSet, - delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, - delListFromUniqSet_Directly, - unionUniqSets, unionManyUniqSets, - minusUniqSet, uniqSetMinusUFM, - intersectUniqSets, - restrictUniqSetToUFM, - uniqSetAny, uniqSetAll, - elementOfUniqSet, - elemUniqSet_Directly, - filterUniqSet, - filterUniqSet_Directly, - sizeUniqSet, - isEmptyUniqSet, - lookupUniqSet, - lookupUniqSet_Directly, - partitionUniqSet, - mapUniqSet, - unsafeUFMToUniqSet, - nonDetEltsUniqSet, - nonDetKeysUniqSet, - nonDetFoldUniqSet, - nonDetFoldUniqSet_Directly - ) where - -import UniqFM -import Unique -import Data.Coerce -import Outputable -import Data.Foldable (foldl') -import Data.Data -#if __GLASGOW_HASKELL__ >= 801 -import qualified Data.Semigroup -#endif - -{- -************************************************************************ -* * -\subsection{The signature of the module} -* * -************************************************************************ --} - -emptyUniqSet :: UniqSet a -unitUniqSet :: Uniquable a => a -> UniqSet a -mkUniqSet :: Uniquable a => [a] -> UniqSet a - -addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a -addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a - -delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a -delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a -delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a -delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a - -unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a -unionManyUniqSets :: [UniqSet a] -> UniqSet a -minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a -intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a -restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a -uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a - -elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool -elemUniqSet_Directly :: Unique -> UniqSet a -> Bool -filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a -filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt -partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) - -sizeUniqSet :: UniqSet a -> Int -isEmptyUniqSet :: UniqSet a -> Bool -lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b -lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a - -nonDetEltsUniqSet :: UniqSet elt -> [elt] -nonDetKeysUniqSet :: UniqSet elt -> [Unique] - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a - -mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b - -{- -************************************************************************ -* * -\subsection{Implementation using ``UniqFM''} -* * -************************************************************************ --} - --- Note [Unsound mapUniqSet] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- UniqSet has the following invariant: --- The keys in the map are the uniques of the values --- It means that to implement mapUniqSet you'd have to update --- both the keys and the values. There used to be an implementation --- that only updated the values and it's been removed, because it broke --- the invariant. - -newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a} deriving Data - --- Two 'UniqSet's are considered equal if they contain the same --- uniques. -instance Eq (UniqSet a) where - UniqSet a == UniqSet b = equalKeysUFM a b - -getUniqSet :: UniqSet a -> UniqFM a -getUniqSet = getUniqSet' - --- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ --- assuming, without checking, that it maps each 'Unique' to a value --- that has that 'Unique'. See Note [Unsound mapUniqSet]. -unsafeUFMToUniqSet :: UniqFM a -> UniqSet a -unsafeUFMToUniqSet = UniqSet - -instance Outputable a => Outputable (UniqSet a) where - ppr = pprUniqSet ppr -#if __GLASGOW_HASKELL__ >= 801 -instance Data.Semigroup.Semigroup (UniqSet a) where - (<>) = mappend -#endif -instance Monoid (UniqSet a) where - mempty = UniqSet mempty - UniqSet s `mappend` UniqSet t = UniqSet (s `mappend` t) - -pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc -pprUniqSet f (UniqSet s) = pprUniqFM f s - -emptyUniqSet = UniqSet emptyUFM -unitUniqSet x = UniqSet $ unitUFM x x -mkUniqSet = foldl' addOneToUniqSet emptyUniqSet - -addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) -addListToUniqSet = foldl' addOneToUniqSet - -delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) -delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u) -delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l) -delListFromUniqSet_Directly (UniqSet s) l = - UniqSet (delListFromUFM_Directly s l) - -unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) - -unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet - -minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) -uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t) - - -intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) -restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m) - -elementOfUniqSet a (UniqSet s) = elemUFM a s -elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s -filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s) -filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s) - -partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s) - -sizeUniqSet (UniqSet s) = sizeUFM s -isEmptyUniqSet (UniqSet s) = isNullUFM s -lookupUniqSet (UniqSet s) k = lookupUFM s k -lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k - -uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool -uniqSetAny p (UniqSet s) = anyUFM p s - -uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool -uniqSetAll p (UniqSet s) = allUFM p s - -nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s -nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s -nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet' -nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet' - -mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet diff --git a/utils/Util.hs b/utils/Util.hs deleted file mode 100644 --- a/utils/Util.hs +++ /dev/null @@ -1,1371 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE BangPatterns #-} -#if __GLASGOW_HASKELL__ < 800 --- For CallStack business -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE FlexibleContexts #-} -#endif - --- | Highly random utility functions --- -module Util ( - -- * Flags dependent on the compiler build - ghciSupported, debugIsOn, ncgDebugIsOn, - ghciTablesNextToCode, - isWindowsHost, isDarwinHost, - - -- * General list processing - zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, - zipLazy, stretchZipWith, zipWithAndUnzip, - - zipWithLazy, zipWith3Lazy, - - filterByList, filterByLists, partitionByList, - - unzipWith, - - mapFst, mapSnd, chkAppend, - mapAndUnzip, mapAndUnzip3, mapAccumL2, - nOfThem, filterOut, partitionWith, splitEithers, - - dropWhileEndLE, spanEnd, - - foldl1', foldl2, count, all2, - - lengthExceeds, lengthIs, lengthAtLeast, - listLengthCmp, atLength, - equalLength, compareLength, leLength, - - isSingleton, only, singleton, - notNull, snocView, - - isIn, isn'tIn, - - chunkList, - - changeLast, - - -- * Tuples - fstOf3, sndOf3, thdOf3, - firstM, first3M, - fst3, snd3, third3, - uncurry3, - liftFst, liftSnd, - - -- * List operations controlled by another list - takeList, dropList, splitAtList, split, - dropTail, capitalise, - - -- * For loop - nTimes, - - -- * Sorting - sortWith, minWith, nubSort, - - -- * Comparisons - isEqual, eqListBy, eqMaybeBy, - thenCmp, cmpList, - removeSpaces, - (<&&>), (<||>), - - -- * Edit distance - fuzzyMatch, fuzzyLookup, - - -- * Transitive closures - transitiveClosure, - - -- * Strictness - seqList, - - -- * Module names - looksLikeModuleName, - looksLikePackageName, - - -- * Argument processing - getCmd, toCmdArgs, toArgs, - - -- * Integers - exactLog2, - - -- * Floating point - readRational, - - -- * read helpers - maybeRead, maybeReadFuzzy, - - -- * IO-ish utilities - doesDirNameExist, - getModificationUTCTime, - modificationTimeIfExists, - hSetTranslit, - - global, consIORef, globalM, - sharedGlobal, sharedGlobalM, - - -- * Filenames and paths - Suffix, - splitLongestPrefix, - escapeSpaces, - Direction(..), reslash, - makeRelativeTo, - - -- * Utils for defining Data instances - abstractConstr, abstractDataType, mkNoRepType, - - -- * Utils for printing C code - charToC, - - -- * Hashing - hashString, - - -- * Call stacks -#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) - GHC.Stack.CallStack, -#endif - HasCallStack, - HasDebugCallStack, - prettyCurrentCallStack, - - -- * Utils for flags - OverridingBool(..), - overrideWith, - ) where - -#include "HsVersions.h" - -import Exception -import Panic - -import Data.Data -import Data.IORef ( IORef, newIORef, atomicModifyIORef' ) -import System.IO.Unsafe ( unsafePerformIO ) -import Data.List hiding (group) - -import GHC.Exts -import qualified GHC.Stack - -import Control.Applicative ( liftA2 ) -import Control.Monad ( liftM ) -import GHC.IO.Encoding (mkTextEncoding, textEncodingName) -import GHC.Conc.Sync ( sharedCAF ) -import System.IO (Handle, hGetEncoding, hSetEncoding) -import System.IO.Error as IO ( isDoesNotExistError ) -import System.Directory ( doesDirectoryExist, getModificationTime ) -import System.FilePath - -import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper) -import Data.Int -import Data.Ratio ( (%) ) -import Data.Ord ( comparing ) -import Data.Bits -import Data.Word -import qualified Data.IntMap as IM -import qualified Data.Set as Set - -import Data.Time - -infixr 9 `thenCmp` - -{- -************************************************************************ -* * -\subsection{Is DEBUG on, are we on Windows, etc?} -* * -************************************************************************ - -These booleans are global constants, set by CPP flags. They allow us to -recompile a single module (this one) to change whether or not debug output -appears. They sometimes let us avoid even running CPP elsewhere. - -It's important that the flags are literal constants (True/False). Then, -with -0, tests of the flags in other modules will simplify to the correct -branch of the conditional, thereby dropping debug code altogether when -the flags are off. --} - -ghciSupported :: Bool -#ifdef GHCI -ghciSupported = True -#else -ghciSupported = False -#endif - -debugIsOn :: Bool -#ifdef DEBUG -debugIsOn = True -#else -debugIsOn = False -#endif - -ncgDebugIsOn :: Bool -#ifdef NCG_DEBUG -ncgDebugIsOn = True -#else -ncgDebugIsOn = False -#endif - -ghciTablesNextToCode :: Bool -#ifdef GHCI_TABLES_NEXT_TO_CODE -ghciTablesNextToCode = True -#else -ghciTablesNextToCode = False -#endif - -isWindowsHost :: Bool -#ifdef mingw32_HOST_OS -isWindowsHost = True -#else -isWindowsHost = False -#endif - -isDarwinHost :: Bool -#ifdef darwin_HOST_OS -isDarwinHost = True -#else -isDarwinHost = False -#endif - -{- -************************************************************************ -* * -\subsection{A for loop} -* * -************************************************************************ --} - --- | Compose a function with itself n times. (nth rather than twice) -nTimes :: Int -> (a -> a) -> (a -> a) -nTimes 0 _ = id -nTimes 1 f = f -nTimes n f = f . nTimes (n-1) f - -fstOf3 :: (a,b,c) -> a -sndOf3 :: (a,b,c) -> b -thdOf3 :: (a,b,c) -> c -fstOf3 (a,_,_) = a -sndOf3 (_,b,_) = b -thdOf3 (_,_,c) = c - -fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) -fst3 f (a, b, c) = (f a, b, c) - -snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) -snd3 f (a, b, c) = (a, f b, c) - -third3 :: (c -> d) -> (a, b, c) -> (a, b, d) -third3 f (a, b, c) = (a, b, f c) - -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d -uncurry3 f (a, b, c) = f a b c - -liftFst :: (a -> b) -> (a, c) -> (b, c) -liftFst f (a,c) = (f a, c) - -liftSnd :: (a -> b) -> (c, a) -> (c, b) -liftSnd f (c,a) = (c, f a) - -firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) -firstM f (x, y) = liftM (\x' -> (x', y)) (f x) - -first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) -first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) - -{- -************************************************************************ -* * -\subsection[Utils-lists]{General list processing} -* * -************************************************************************ --} - -filterOut :: (a->Bool) -> [a] -> [a] --- ^ Like filter, only it reverses the sense of the test -filterOut _ [] = [] -filterOut p (x:xs) | p x = filterOut p xs - | otherwise = x : filterOut p xs - -partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) --- ^ Uses a function to determine which of two output lists an input element should join -partitionWith _ [] = ([],[]) -partitionWith f (x:xs) = case f x of - Left b -> (b:bs, cs) - Right c -> (bs, c:cs) - where (bs,cs) = partitionWith f xs - -splitEithers :: [Either a b] -> ([a], [b]) --- ^ Teases a list of 'Either's apart into two lists -splitEithers [] = ([],[]) -splitEithers (e : es) = case e of - Left x -> (x:xs, ys) - Right y -> (xs, y:ys) - where (xs,ys) = splitEithers es - -chkAppend :: [a] -> [a] -> [a] --- Checks for the second arguemnt being empty --- Used in situations where that situation is common -chkAppend xs ys - | null ys = xs - | otherwise = xs ++ ys - -{- -A paranoid @zip@ (and some @zipWith@ friends) that checks the lists -are of equal length. Alastair Reid thinks this should only happen if -DEBUGging on; hey, why not? --} - -zipEqual :: String -> [a] -> [b] -> [(a,b)] -zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] -zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] - -#ifndef DEBUG -zipEqual _ = zip -zipWithEqual _ = zipWith -zipWith3Equal _ = zipWith3 -zipWith4Equal _ = zipWith4 -#else -zipEqual _ [] [] = [] -zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs -zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg) - -zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs -zipWithEqual _ _ [] [] = [] -zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg) - -zipWith3Equal msg z (a:as) (b:bs) (c:cs) - = z a b c : zipWith3Equal msg z as bs cs -zipWith3Equal _ _ [] [] [] = [] -zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg) - -zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) - = z a b c d : zipWith4Equal msg z as bs cs ds -zipWith4Equal _ _ [] [] [] [] = [] -zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) -#endif - --- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) -zipLazy :: [a] -> [b] -> [(a,b)] -zipLazy [] _ = [] -zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys - --- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. --- The length of the output is always the same as the length of the first --- list. -zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] -zipWithLazy _ [] _ = [] -zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs - --- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. --- The length of the output is always the same as the length of the first --- list. -zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] -zipWith3Lazy _ [] _ _ = [] -zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs - --- | 'filterByList' takes a list of Bools and a list of some elements and --- filters out these elements for which the corresponding value in the list of --- Bools is False. This function does not check whether the lists have equal --- length. -filterByList :: [Bool] -> [a] -> [a] -filterByList (True:bs) (x:xs) = x : filterByList bs xs -filterByList (False:bs) (_:xs) = filterByList bs xs -filterByList _ _ = [] - --- | 'filterByLists' takes a list of Bools and two lists as input, and --- outputs a new list consisting of elements from the last two input lists. For --- each Bool in the list, if it is 'True', then it takes an element from the --- former list. If it is 'False', it takes an element from the latter list. --- The elements taken correspond to the index of the Bool in its list. --- For example: --- --- @ --- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" --- @ --- --- This function does not check whether the lists have equal length. -filterByLists :: [Bool] -> [a] -> [a] -> [a] -filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys -filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys -filterByLists _ _ _ = [] - --- | 'partitionByList' takes a list of Bools and a list of some elements and --- partitions the list according to the list of Bools. Elements corresponding --- to 'True' go to the left; elements corresponding to 'False' go to the right. --- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ --- This function does not check whether the lists have equal --- length. -partitionByList :: [Bool] -> [a] -> ([a], [a]) -partitionByList = go [] [] - where - go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs - go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs - go trues falses _ _ = (reverse trues, reverse falses) - -stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] --- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in --- the places where @p@ returns @True@ - -stretchZipWith _ _ _ [] _ = [] -stretchZipWith p z f (x:xs) ys - | p x = f x z : stretchZipWith p z f xs ys - | otherwise = case ys of - [] -> [] - (y:ys) -> f x y : stretchZipWith p z f xs ys - -mapFst :: (a->c) -> [(a,b)] -> [(c,b)] -mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] - -mapFst f xys = [(f x, y) | (x,y) <- xys] -mapSnd f xys = [(x, f y) | (x,y) <- xys] - -mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) - -mapAndUnzip _ [] = ([], []) -mapAndUnzip f (x:xs) - = let (r1, r2) = f x - (rs1, rs2) = mapAndUnzip f xs - in - (r1:rs1, r2:rs2) - -mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) - -mapAndUnzip3 _ [] = ([], [], []) -mapAndUnzip3 f (x:xs) - = let (r1, r2, r3) = f x - (rs1, rs2, rs3) = mapAndUnzip3 f xs - in - (r1:rs1, r2:rs2, r3:rs3) - -zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) -zipWithAndUnzip f (a:as) (b:bs) - = let (r1, r2) = f a b - (rs1, rs2) = zipWithAndUnzip f as bs - in - (r1:rs1, r2:rs2) -zipWithAndUnzip _ _ _ = ([],[]) - -mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) -mapAccumL2 f s1 s2 xs = (s1', s2', ys) - where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of - (s1', s2', y) -> ((s1', s2'), y)) - (s1, s2) xs - -nOfThem :: Int -> a -> [a] -nOfThem n thing = replicate n thing - --- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: --- --- @ --- atLength atLenPred atEndPred ls n --- | n < 0 = atLenPred ls --- | length ls < n = atEndPred (n - length ls) --- | otherwise = atLenPred (drop n ls) --- @ -atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) - -- NB: arg passed to this function may be [] - -> b -- Called when length ls < n - -> [a] - -> Int - -> b -atLength atLenPred atEnd ls0 n0 - | n0 < 0 = atLenPred ls0 - | otherwise = go n0 ls0 - where - -- go's first arg n >= 0 - go 0 ls = atLenPred ls - go _ [] = atEnd -- n > 0 here - go n (_:xs) = go (n-1) xs - --- Some special cases of atLength: - --- | @(lengthExceeds xs n) = (length xs > n)@ -lengthExceeds :: [a] -> Int -> Bool -lengthExceeds lst n - | n < 0 - = True - | otherwise - = atLength notNull False lst n - -lengthAtLeast :: [a] -> Int -> Bool -lengthAtLeast = atLength (const True) False - --- | @(lengthIs xs n) = (length xs == n)@ -lengthIs :: [a] -> Int -> Bool -lengthIs lst n - | n < 0 - = False - | otherwise - = atLength null False lst n - -listLengthCmp :: [a] -> Int -> Ordering -listLengthCmp = atLength atLen atEnd - where - atEnd = LT -- Not yet seen 'n' elts, so list length is < n. - - atLen [] = EQ - atLen _ = GT - -equalLength :: [a] -> [b] -> Bool -equalLength [] [] = True -equalLength (_:xs) (_:ys) = equalLength xs ys -equalLength _ _ = False - -compareLength :: [a] -> [b] -> Ordering -compareLength [] [] = EQ -compareLength (_:xs) (_:ys) = compareLength xs ys -compareLength [] _ = LT -compareLength _ [] = GT - -leLength :: [a] -> [b] -> Bool --- ^ True if length xs <= length ys -leLength xs ys = case compareLength xs ys of - LT -> True - EQ -> True - GT -> False - ----------------------------- -singleton :: a -> [a] -singleton x = [x] - -isSingleton :: [a] -> Bool -isSingleton [_] = True -isSingleton _ = False - -notNull :: [a] -> Bool -notNull [] = False -notNull _ = True - -only :: [a] -> a -#ifdef DEBUG -only [a] = a -#else -only (a:_) = a -#endif -only _ = panic "Util: only" - --- Debugging/specialising versions of \tr{elem} and \tr{notElem} - -isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool - -# ifndef DEBUG -isIn _msg x ys = x `elem` ys -isn'tIn _msg x ys = x `notElem` ys - -# else /* DEBUG */ -isIn msg x ys - = elem100 0 x ys - where - elem100 :: Eq a => Int -> a -> [a] -> Bool - elem100 _ _ [] = False - elem100 i x (y:ys) - | i > 100 = trace ("Over-long elem in " ++ msg) (x `elem` (y:ys)) - | otherwise = x == y || elem100 (i + 1) x ys - -isn'tIn msg x ys - = notElem100 0 x ys - where - notElem100 :: Eq a => Int -> a -> [a] -> Bool - notElem100 _ _ [] = True - notElem100 i x (y:ys) - | i > 100 = trace ("Over-long notElem in " ++ msg) (x `notElem` (y:ys)) - | otherwise = x /= y && notElem100 (i + 1) x ys -# endif /* DEBUG */ - - --- | Split a list into chunks of /n/ elements -chunkList :: Int -> [a] -> [[a]] -chunkList _ [] = [] -chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs - --- | Replace the last element of a list with another element. -changeLast :: [a] -> a -> [a] -changeLast [] _ = panic "changeLast" -changeLast [_] x = [x] -changeLast (x:xs) x' = x : changeLast xs x' - -{- -************************************************************************ -* * -\subsubsection{Sort utils} -* * -************************************************************************ --} - -minWith :: Ord b => (a -> b) -> [a] -> a -minWith get_key xs = ASSERT( not (null xs) ) - head (sortWith get_key xs) - -nubSort :: Ord a => [a] -> [a] -nubSort = Set.toAscList . Set.fromList - -{- -************************************************************************ -* * -\subsection[Utils-transitive-closure]{Transitive closure} -* * -************************************************************************ - -This algorithm for transitive closure is straightforward, albeit quadratic. --} - -transitiveClosure :: (a -> [a]) -- Successor function - -> (a -> a -> Bool) -- Equality predicate - -> [a] - -> [a] -- The transitive closure - -transitiveClosure succ eq xs - = go [] xs - where - go done [] = done - go done (x:xs) | x `is_in` done = go done xs - | otherwise = go (x:done) (succ x ++ xs) - - _ `is_in` [] = False - x `is_in` (y:ys) | eq x y = True - | otherwise = x `is_in` ys - -{- -************************************************************************ -* * -\subsection[Utils-accum]{Accumulating} -* * -************************************************************************ - -A combination of foldl with zip. It works with equal length lists. --} - -foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc -foldl2 _ z [] [] = z -foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs -foldl2 _ _ _ _ = panic "Util: foldl2" - -all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool --- True if the lists are the same length, and --- all corresponding elements satisfy the predicate -all2 _ [] [] = True -all2 p (x:xs) (y:ys) = p x y && all2 p xs ys -all2 _ _ _ = False - --- Count the number of times a predicate is true - -count :: (a -> Bool) -> [a] -> Int -count p = go 0 - where go !n [] = n - go !n (x:xs) | p x = go (n+1) xs - | otherwise = go n xs - -{- -@splitAt@, @take@, and @drop@ but with length of another -list giving the break-off point: --} - -takeList :: [b] -> [a] -> [a] --- (takeList as bs) trims bs to the be same length --- as as, unless as is longer in which case it's a no-op -takeList [] _ = [] -takeList (_:xs) ls = - case ls of - [] -> [] - (y:ys) -> y : takeList xs ys - -dropList :: [b] -> [a] -> [a] -dropList [] xs = xs -dropList _ xs@[] = xs -dropList (_:xs) (_:ys) = dropList xs ys - - -splitAtList :: [b] -> [a] -> ([a], [a]) -splitAtList [] xs = ([], xs) -splitAtList _ xs@[] = (xs, xs) -splitAtList (_:xs) (y:ys) = (y:ys', ys'') - where - (ys', ys'') = splitAtList xs ys - --- drop from the end of a list -dropTail :: Int -> [a] -> [a] --- Specification: dropTail n = reverse . drop n . reverse --- Better implemention due to Joachim Breitner --- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html -dropTail n xs - = go (drop n xs) xs - where - go (_:ys) (x:xs) = x : go ys xs - go _ _ = [] -- Stop when ys runs out - -- It'll always run out before xs does - --- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, --- but is lazy in the elements and strict in the spine. For reasonably short lists, --- such as path names and typical lines of text, dropWhileEndLE is generally --- faster than dropWhileEnd. Its advantage is magnified when the predicate is --- expensive--using dropWhileEndLE isSpace to strip the space off a line of text --- is generally much faster than using dropWhileEnd isSpace for that purpose. --- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse --- Pay attention to the short-circuit (&&)! The order of its arguments is the only --- difference between dropWhileEnd and dropWhileEndLE. -dropWhileEndLE :: (a -> Bool) -> [a] -> [a] -dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] - --- | @spanEnd p l == reverse (span p (reverse l))@. The first list --- returns actually comes after the second list (when you look at the --- input list). -spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) -spanEnd p l = go l [] [] l - where go yes _rev_yes rev_no [] = (yes, reverse rev_no) - go yes rev_yes rev_no (x:xs) - | p x = go yes (x : rev_yes) rev_no xs - | otherwise = go xs [] (x : rev_yes ++ rev_no) xs - - -snocView :: [a] -> Maybe ([a],a) - -- Split off the last element -snocView [] = Nothing -snocView xs = go [] xs - where - -- Invariant: second arg is non-empty - go acc [x] = Just (reverse acc, x) - go acc (x:xs) = go (x:acc) xs - go _ [] = panic "Util: snocView" - -split :: Char -> String -> [String] -split c s = case rest of - [] -> [chunk] - _:rest -> chunk : split c rest - where (chunk, rest) = break (==c) s - --- | Convert a word to title case by capitalising the first letter -capitalise :: String -> String -capitalise [] = [] -capitalise (c:cs) = toUpper c : cs - - -{- -************************************************************************ -* * -\subsection[Utils-comparison]{Comparisons} -* * -************************************************************************ --} - -isEqual :: Ordering -> Bool --- Often used in (isEqual (a `compare` b)) -isEqual GT = False -isEqual EQ = True -isEqual LT = False - -thenCmp :: Ordering -> Ordering -> Ordering -{-# INLINE thenCmp #-} -thenCmp EQ ordering = ordering -thenCmp ordering _ = ordering - -eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool -eqListBy _ [] [] = True -eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys -eqListBy _ _ _ = False - -eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool -eqMaybeBy _ Nothing Nothing = True -eqMaybeBy eq (Just x) (Just y) = eq x y -eqMaybeBy _ _ _ = False - -cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering - -- `cmpList' uses a user-specified comparer - -cmpList _ [] [] = EQ -cmpList _ [] _ = LT -cmpList _ _ [] = GT -cmpList cmp (a:as) (b:bs) - = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } - -removeSpaces :: String -> String -removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace - --- Boolean operators lifted to Applicative -(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool -(<&&>) = liftA2 (&&) -infixr 3 <&&> -- same as (&&) - -(<||>) :: Applicative f => f Bool -> f Bool -> f Bool -(<||>) = liftA2 (||) -infixr 2 <||> -- same as (||) - -{- -************************************************************************ -* * -\subsection{Edit distance} -* * -************************************************************************ --} - --- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. --- See: . --- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing --- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). --- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and --- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation -restrictedDamerauLevenshteinDistance :: String -> String -> Int -restrictedDamerauLevenshteinDistance str1 str2 - = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 - where - m = length str1 - n = length str2 - -restrictedDamerauLevenshteinDistanceWithLengths - :: Int -> Int -> String -> String -> Int -restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 - | m <= n - = if n <= 32 -- n must be larger so this check is sufficient - then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 - else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 - - | otherwise - = if m <= 32 -- m must be larger so this check is sufficient - then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 - else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 - -restrictedDamerauLevenshteinDistance' - :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int -restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 - | [] <- str1 = n - | otherwise = extractAnswer $ - foldl' (restrictedDamerauLevenshteinDistanceWorker - (matchVectors str1) top_bit_mask vector_mask) - (0, 0, m_ones, 0, m) str2 - where - m_ones@vector_mask = (2 ^ m) - 1 - top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy - extractAnswer (_, _, _, _, distance) = distance - -restrictedDamerauLevenshteinDistanceWorker - :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv - -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) -restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask - (pm, d0, vp, vn, distance) char2 - = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ - seq pm' $ seq d0' $ seq vp' $ seq vn' $ - seq distance'' $ seq char2 $ - (pm', d0', vp', vn', distance'') - where - pm' = IM.findWithDefault 0 (ord char2) str1_mvs - - d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) - .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn - -- No need to mask the shiftL because of the restricted range of pm - - hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) - hn' = d0' .&. vp - - hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask - hn'_shift = (hn' `shiftL` 1) .&. vector_mask - vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) - vn' = d0' .&. hp'_shift - - distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance - distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' - -sizedComplement :: Bits bv => bv -> bv -> bv -sizedComplement vector_mask vect = vector_mask `xor` vect - -matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv -matchVectors = snd . foldl' go (0 :: Int, IM.empty) - where - go (ix, im) char = let ix' = ix + 1 - im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im - in seq ix' $ seq im' $ (ix', im') - -{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' - :: Word32 -> Int -> Int -> String -> String -> Int #-} -{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' - :: Integer -> Int -> Int -> String -> String -> Int #-} - -{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker - :: IM.IntMap Word32 -> Word32 -> Word32 - -> (Word32, Word32, Word32, Word32, Int) - -> Char -> (Word32, Word32, Word32, Word32, Int) #-} -{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker - :: IM.IntMap Integer -> Integer -> Integer - -> (Integer, Integer, Integer, Integer, Int) - -> Char -> (Integer, Integer, Integer, Integer, Int) #-} - -{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} -{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} - -{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} -{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} - -fuzzyMatch :: String -> [String] -> [String] -fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] - --- | Search for possible matches to the users input in the given list, --- returning a small number of ranked results -fuzzyLookup :: String -> [(String,a)] -> [a] -fuzzyLookup user_entered possibilites - = map fst $ take mAX_RESULTS $ sortBy (comparing snd) - [ (poss_val, distance) | (poss_str, poss_val) <- possibilites - , let distance = restrictedDamerauLevenshteinDistance - poss_str user_entered - , distance <= fuzzy_threshold ] - where - -- Work out an approriate match threshold: - -- We report a candidate if its edit distance is <= the threshold, - -- The threshold is set to about a quarter of the # of characters the user entered - -- Length Threshold - -- 1 0 -- Don't suggest *any* candidates - -- 2 1 -- for single-char identifiers - -- 3 1 - -- 4 1 - -- 5 1 - -- 6 2 - -- - fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) - mAX_RESULTS = 3 - -{- -************************************************************************ -* * -\subsection[Utils-pairs]{Pairs} -* * -************************************************************************ --} - -unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] -unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs - -seqList :: [a] -> b -> b -seqList [] b = b -seqList (x:xs) b = x `seq` seqList xs b - - -{- -************************************************************************ -* * - Globals and the RTS -* * -************************************************************************ - -When a plugin is loaded, it currently gets linked against a *newly -loaded* copy of the GHC package. This would not be a problem, except -that the new copy has its own mutable state that is not shared with -that state that has already been initialized by the original GHC -package. - -(Note that if the GHC executable was dynamically linked this -wouldn't be a problem, because we could share the GHC library it -links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) - -The solution is to make use of @sharedCAF@ through @sharedGlobal@ -for globals that are shared between multiple copies of ghc packages. --} - --- Global variables: - -global :: a -> IORef a -global a = unsafePerformIO (newIORef a) - -consIORef :: IORef [a] -> a -> IO () -consIORef var x = do - atomicModifyIORef' var (\xs -> (x:xs,())) - -globalM :: IO a -> IORef a -globalM ma = unsafePerformIO (ma >>= newIORef) - --- Shared global variables: - -sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -sharedGlobal a get_or_set = unsafePerformIO $ - newIORef a >>= flip sharedCAF get_or_set - -sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -sharedGlobalM ma get_or_set = unsafePerformIO $ - ma >>= newIORef >>= flip sharedCAF get_or_set - --- Module names: - -looksLikeModuleName :: String -> Bool -looksLikeModuleName [] = False -looksLikeModuleName (c:cs) = isUpper c && go cs - where go [] = True - go ('.':cs) = looksLikeModuleName cs - go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs - --- Similar to 'parse' for Distribution.Package.PackageName, --- but we don't want to depend on Cabal. -looksLikePackageName :: String -> Bool -looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-' - -{- -Akin to @Prelude.words@, but acts like the Bourne shell, treating -quoted strings as Haskell Strings, and also parses Haskell [String] -syntax. --} - -getCmd :: String -> Either String -- Error - (String, String) -- (Cmd, Rest) -getCmd s = case break isSpace $ dropWhile isSpace s of - ([], _) -> Left ("Couldn't find command in " ++ show s) - res -> Right res - -toCmdArgs :: String -> Either String -- Error - (String, [String]) -- (Cmd, Args) -toCmdArgs s = case getCmd s of - Left err -> Left err - Right (cmd, s') -> case toArgs s' of - Left err -> Left err - Right args -> Right (cmd, args) - -toArgs :: String -> Either String -- Error - [String] -- Args -toArgs str - = case dropWhile isSpace str of - s@('[':_) -> case reads s of - [(args, spaces)] - | all isSpace spaces -> - Right args - _ -> - Left ("Couldn't read " ++ show str ++ " as [String]") - s -> toArgs' s - where - toArgs' :: String -> Either String [String] - -- Remove outer quotes: - -- > toArgs' "\"foo\" \"bar baz\"" - -- Right ["foo", "bar baz"] - -- - -- Keep inner quotes: - -- > toArgs' "-DFOO=\"bar baz\"" - -- Right ["-DFOO=\"bar baz\""] - toArgs' s = case dropWhile isSpace s of - [] -> Right [] - ('"' : _) -> do - -- readAsString removes outer quotes - (arg, rest) <- readAsString s - (arg:) `fmap` toArgs' rest - s' -> case break (isSpace <||> (== '"')) s' of - (argPart1, s''@('"':_)) -> do - (argPart2, rest) <- readAsString s'' - -- show argPart2 to keep inner quotes - ((argPart1 ++ show argPart2):) `fmap` toArgs' rest - (arg, s'') -> (arg:) `fmap` toArgs' s'' - - readAsString :: String -> Either String (String, String) - readAsString s = case reads s of - [(arg, rest)] - -- rest must either be [] or start with a space - | all isSpace (take 1 rest) -> - Right (arg, rest) - _ -> - Left ("Couldn't read " ++ show s ++ " as String") ------------------------------------------------------------------------------ --- Integers - --- This algorithm for determining the $\log_2$ of exact powers of 2 comes --- from GCC. It requires bit manipulation primitives, and we use GHC --- extensions. Tough. - -exactLog2 :: Integer -> Maybe Integer -exactLog2 x - = if (x <= 0 || x >= 2147483648) then - Nothing - else - if (x .&. (-x)) /= x then - Nothing - else - Just (pow2 x) - where - pow2 x | x == 1 = 0 - | otherwise = 1 + pow2 (x `shiftR` 1) - - -{- --- ----------------------------------------------------------------------------- --- Floats --} - -readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" -readRational__ r = do - (n,d,s) <- readFix r - (k,t) <- readExp s - return ((n%1)*10^^(k-d), t) - where - readFix r = do - (ds,s) <- lexDecDigits r - (ds',t) <- lexDotDigits s - return (read (ds++ds'), length ds', t) - - readExp (e:s) | e `elem` "eE" = readExp' s - readExp s = return (0,s) - - readExp' ('+':s) = readDec s - readExp' ('-':s) = do (k,t) <- readDec s - return (-k,t) - readExp' s = readDec s - - readDec s = do - (ds,r) <- nonnull isDigit s - return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], - r) - - lexDecDigits = nonnull isDigit - - lexDotDigits ('.':s) = return (span isDigit s) - lexDotDigits s = return ("",s) - - nonnull p s = do (cs@(_:_),t) <- return (span p s) - return (cs,t) - -readRational :: String -> Rational -- NB: *does* handle a leading "-" -readRational top_s - = case top_s of - '-' : xs -> - (read_me xs) - xs -> read_me xs - where - read_me s - = case (do { (x,"") <- readRational__ s ; return x }) of - [x] -> x - [] -> error ("readRational: no parse:" ++ top_s) - _ -> error ("readRational: ambiguous parse:" ++ top_s) - - ------------------------------------------------------------------------------ --- read helpers - -maybeRead :: Read a => String -> Maybe a -maybeRead str = case reads str of - [(x, "")] -> Just x - _ -> Nothing - -maybeReadFuzzy :: Read a => String -> Maybe a -maybeReadFuzzy str = case reads str of - [(x, s)] - | all isSpace s -> - Just x - _ -> - Nothing - ------------------------------------------------------------------------------ --- Verify that the 'dirname' portion of a FilePath exists. --- -doesDirNameExist :: FilePath -> IO Bool -doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath) - ------------------------------------------------------------------------------ --- Backwards compatibility definition of getModificationTime - -getModificationUTCTime :: FilePath -> IO UTCTime -getModificationUTCTime = getModificationTime - --- -------------------------------------------------------------- --- check existence & modification time at the same time - -modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) -modificationTimeIfExists f = do - (do t <- getModificationUTCTime f; return (Just t)) - `catchIO` \e -> if isDoesNotExistError e - then return Nothing - else ioError e - --- -------------------------------------------------------------- --- 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 () - --- split a string at the last character where 'pred' is True, --- returning a pair of strings. The first component holds the string --- up (but not including) the last character for which 'pred' returned --- True, the second whatever comes after (but also not including the --- last character). --- --- If 'pred' returns False for all characters in the string, the original --- string is returned in the first component (and the second one is just --- empty). -splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) -splitLongestPrefix str pred - | null r_pre = (str, []) - | otherwise = (reverse (tail r_pre), reverse r_suf) - -- 'tail' drops the char satisfying 'pred' - where (r_suf, r_pre) = break pred (reverse str) - -escapeSpaces :: String -> String -escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" - -type Suffix = String - --------------------------------------------------------------- --- * Search path --------------------------------------------------------------- - -data Direction = Forwards | Backwards - -reslash :: Direction -> FilePath -> FilePath -reslash d = f - where f ('/' : xs) = slash : f xs - f ('\\' : xs) = slash : f xs - f (x : xs) = x : f xs - f "" = "" - slash = case d of - Forwards -> '/' - Backwards -> '\\' - -makeRelativeTo :: FilePath -> FilePath -> FilePath -this `makeRelativeTo` that = directory thisFilename - where (thisDirectory, thisFilename) = splitFileName this - thatDirectory = dropFileName that - directory = joinPath $ f (splitPath thisDirectory) - (splitPath thatDirectory) - - f (x : xs) (y : ys) - | x == y = f xs ys - f xs ys = replicate (length ys) ".." ++ xs - -{- -************************************************************************ -* * -\subsection[Utils-Data]{Utils for defining Data instances} -* * -************************************************************************ - -These functions helps us to define Data instances for abstract types. --} - -abstractConstr :: String -> Constr -abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix - -abstractDataType :: String -> DataType -abstractDataType n = mkDataType n [abstractConstr n] - -{- -************************************************************************ -* * -\subsection[Utils-C]{Utils for printing C code} -* * -************************************************************************ --} - -charToC :: Word8 -> String -charToC w = - case chr (fromIntegral w) of - '\"' -> "\\\"" - '\'' -> "\\\'" - '\\' -> "\\\\" - c | c >= ' ' && c <= '~' -> [c] - | otherwise -> ['\\', - chr (ord '0' + ord c `div` 64), - chr (ord '0' + ord c `div` 8 `mod` 8), - chr (ord '0' + ord c `mod` 8)] - -{- -************************************************************************ -* * -\subsection[Utils-Hashing]{Utils for hashing} -* * -************************************************************************ --} - --- | A sample hash function for Strings. We keep multiplying by the --- golden ratio and adding. The implementation is: --- --- > hashString = foldl' f golden --- > where f m c = fromIntegral (ord c) * magic + hashInt32 m --- > magic = 0xdeadbeef --- --- Where hashInt32 works just as hashInt shown above. --- --- Knuth argues that repeated multiplication by the golden ratio --- will minimize gaps in the hash space, and thus it's a good choice --- for combining together multiple keys to form one. --- --- Here we know that individual characters c are often small, and this --- produces frequent collisions if we use ord c alone. A --- particular problem are the shorter low ASCII and ISO-8859-1 --- character strings. We pre-multiply by a magic twiddle factor to --- obtain a good distribution. In fact, given the following test: --- --- > testp :: Int32 -> Int --- > testp k = (n - ) . length . group . sort . map hs . take n $ ls --- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] --- > hs = foldl' f golden --- > f m c = fromIntegral (ord c) * k + hashInt32 m --- > n = 100000 --- --- We discover that testp magic = 0. -hashString :: String -> Int32 -hashString = foldl' f golden - where f m c = fromIntegral (ord c) * magic + hashInt32 m - magic = fromIntegral (0xdeadbeef :: Word32) - -golden :: Int32 -golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 --- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 --- but that has bad mulHi properties (even adding 2^32 to get its inverse) --- Whereas the above works well and contains no hash duplications for --- [-32767..65536] - --- | A sample (and useful) hash function for Int32, --- implemented by extracting the uppermost 32 bits of the 64-bit --- result of multiplying by a 33-bit constant. The constant is from --- Knuth, derived from the golden ratio: --- --- > golden = round ((sqrt 5 - 1) * 2^32) --- --- We get good key uniqueness on small inputs --- (a problem with previous versions): --- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 --- -hashInt32 :: Int32 -> Int32 -hashInt32 x = mulHi x golden + x - --- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply -mulHi :: Int32 -> Int32 -> Int32 -mulHi a b = fromIntegral (r `shiftR` 32) - where r :: Int64 - r = fromIntegral a * fromIntegral b - --- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint. -#if __GLASGOW_HASKELL__ >= 800 -type HasCallStack = GHC.Stack.HasCallStack -#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) -type HasCallStack = (?callStack :: GHC.Stack.CallStack) --- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1 -#else -type HasCallStack = (() :: Constraint) -#endif - --- | A call stack constraint, but only when 'isDebugOn'. -#if DEBUG -type HasDebugCallStack = HasCallStack -#else -type HasDebugCallStack = (() :: Constraint) -#endif - --- | Pretty-print the current callstack -#if __GLASGOW_HASKELL__ >= 800 -prettyCurrentCallStack :: HasCallStack => String -prettyCurrentCallStack = GHC.Stack.prettyCallStack GHC.Stack.callStack -#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) -prettyCurrentCallStack :: (?callStack :: GHC.Stack.CallStack) => String -prettyCurrentCallStack = GHC.Stack.showCallStack ?callStack -#else -prettyCurrentCallStack :: HasCallStack => String -prettyCurrentCallStack = "Call stack unavailable" -#endif - -data OverridingBool - = Auto - | Always - | Never - deriving Show - -overrideWith :: Bool -> OverridingBool -> Bool -overrideWith b Auto = b -overrideWith _ Always = True -overrideWith _ Never = False diff --git a/utils/md5.h b/utils/md5.h deleted file mode 100644 --- a/utils/md5.h +++ /dev/null @@ -1,24 +0,0 @@ -/* MD5 message digest */ -#ifndef _MD5_H -#define _MD5_H - -#include "HsFFI.h" - -typedef HsWord32 word32; -typedef HsWord8 byte; - -struct MD5Context { - word32 buf[4]; - word32 bytes[2]; - word32 in[16]; -}; - -void MD5Init(struct MD5Context *context); -void MD5Update(struct MD5Context *context, byte const *buf, int len); -void MD5Final(byte digest[16], struct MD5Context *context); -void MD5Transform(word32 buf[4], word32 const in[16]); - -#endif /* _MD5_H */ - - - diff --git a/vectorise/Vectorise.hs b/vectorise/Vectorise.hs deleted file mode 100644 --- a/vectorise/Vectorise.hs +++ /dev/null @@ -1,356 +0,0 @@ --- Main entry point to the vectoriser. It is invoked iff the option '-fvectorise' is passed. --- --- This module provides the function 'vectorise', which vectorises an entire (desugared) module. --- It vectorises all type declarations and value bindings. It also processes all VECTORISE pragmas --- (aka vectorisation declarations), which can lead to the vectorisation of imported data types --- and the enrichment of imported functions with vectorised versions. - -module Vectorise ( vectorise ) -where - -import Vectorise.Type.Env -import Vectorise.Type.Type -import Vectorise.Convert -import Vectorise.Utils.Hoisting -import Vectorise.Exp -import Vectorise.Env -import Vectorise.Monad - -import HscTypes hiding ( MonadThings(..) ) -import CoreUnfold ( mkInlineUnfoldingWithArity ) -import PprCore -import CoreSyn -import CoreMonad ( CoreM, getHscEnv ) -import Type -import Id -import DynFlags -import Outputable -import Util ( zipLazy ) -import MonadUtils - -import Control.Monad - - --- |Vectorise a single module. --- -vectorise :: ModGuts -> CoreM ModGuts -vectorise guts - = do { hsc_env <- getHscEnv - ; liftIO $ vectoriseIO hsc_env guts - } - --- Vectorise a single monad, given the dynamic compiler flags and HscEnv. --- -vectoriseIO :: HscEnv -> ModGuts -> IO ModGuts -vectoriseIO hsc_env guts - = do { -- Get information about currently loaded external packages. - ; eps <- hscEPS hsc_env - - -- Combine vectorisation info from the current module, and external ones. - ; let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps - - -- Run the main VM computation. - ; Just (info', guts') <- initV hsc_env guts info (vectModule guts) - ; return (guts' { mg_vect_info = info' }) - } - --- Vectorise a single module, in the VM monad. --- -vectModule :: ModGuts -> VM ModGuts -vectModule guts@(ModGuts { mg_tcs = tycons - , mg_binds = binds - , mg_fam_insts = fam_insts - , mg_vect_decls = vect_decls - }) - = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ - pprCoreBindings binds - - -- Pick out all 'VECTORISE [SCALAR] type' and 'VECTORISE class' pragmas - ; let ty_vect_decls = [vd | vd@(VectType _ _ _) <- vect_decls] - cls_vect_decls = [vd | vd@(VectClass _) <- vect_decls] - - -- Vectorise the type environment. This will add vectorised - -- type constructors, their representations, and the - -- corresponding data constructors. Moreover, we produce - -- bindings for dfuns and family instances of the classes - -- and type families used in the DPH library to represent - -- array types. - ; (new_tycons, new_fam_insts, tc_binds) <- vectTypeEnv tycons ty_vect_decls cls_vect_decls - - -- Family instance environment for /all/ home-package modules including those instances - -- generated by 'vectTypeEnv'. - ; (_, fam_inst_env) <- readGEnv global_fam_inst_env - - -- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers - -- NB: Need to vectorise the imported bindings first (local bindings may depend on them). - ; let impBinds = [(imp_id, expr) | Vect imp_id expr <- vect_decls, isGlobalId imp_id] - ; binds_imp <- mapM vectImpBind impBinds - ; binds_top <- mapM vectTopBind binds - - ; return $ guts { mg_tcs = tycons ++ new_tycons - -- we produce no new classes or instances, only new class type constructors - -- and dfuns - , mg_binds = Rec tc_binds : (binds_top ++ binds_imp) - , mg_fam_inst_env = fam_inst_env - , mg_fam_insts = fam_insts ++ new_fam_insts - } - } - --- Try to vectorise a top-level binding. If it doesn't vectorise, or if it is entirely scalar, then --- omit vectorisation of that binding. --- --- For example, for the binding --- --- @ --- foo :: Int -> Int --- foo = \x -> x + x --- @ --- --- we get --- @ --- foo :: Int -> Int --- foo = \x -> vfoo $: x --- --- v_foo :: Closure void vfoo lfoo --- v_foo = closure vfoo lfoo void --- --- vfoo :: Void -> Int -> Int --- vfoo = ... --- --- lfoo :: PData Void -> PData Int -> PData Int --- lfoo = ... --- @ --- --- @vfoo@ is the "vectorised", or scalar, version that does the same as the original function foo, --- but takes an explicit environment. --- --- @lfoo@ is the "lifted" version that works on arrays. --- --- @v_foo@ combines both of these into a `Closure` that also contains the environment. --- --- The original binding @foo@ is rewritten to call the vectorised version present in the closure. --- --- Vectorisation may be suppressed by annotating a binding with a 'NOVECTORISE' pragma. If this --- pragma is used in a group of mutually recursive bindings, either all or no binding must have --- the pragma. If only some bindings are annotated, a fatal error is being raised. (In the case of --- scalar bindings, we only omit vectorisation if all bindings in a group are scalar.) --- --- FIXME: Once we support partial vectorisation, we may be able to vectorise parts of a group, or --- we may emit a warning and refrain from vectorising the entire group. --- -vectTopBind :: CoreBind -> VM CoreBind -vectTopBind b@(NonRec var expr) - = do - { traceVt "= Vectorise non-recursive top-level variable" (ppr var) - - ; (hasNoVect, vectDecl) <- lookupVectDecl var - ; if hasNoVect - then do - { -- 'NOVECTORISE' pragma => leave this binding as it is - ; traceVt "NOVECTORISE" $ ppr var - ; return b - } - else do - { vectRhs <- case vectDecl of - Just (_, expr') -> - -- 'VECTORISE' pragma => just use the provided vectorised rhs - do - { traceVt "VECTORISE" $ ppr var - ; addGlobalParallelVar var - ; return $ Just (False, inlineMe, expr') - } - Nothing -> - -- no pragma => standard vectorisation of rhs - do - { traceVt "[Vanilla]" $ ppr var <+> char '=' <+> ppr expr - ; vectTopExpr var expr - } - ; hs <- takeHoisted -- make sure we clean those out (even if we skip) - ; case vectRhs of - { Nothing -> - -- scalar binding => leave this binding as it is - do - { traceVt "scalar binding [skip]" $ ppr var - ; return b - } - ; Just (parBind, inline, expr') -> do - { - -- vanilla case => create an appropriate top-level binding & add it to the vectorisation map - ; when parBind $ - addGlobalParallelVar var - ; var' <- vectTopBinder var inline expr' - - -- We replace the original top-level binding by a value projected from the vectorised - -- closure and add any newly created hoisted top-level bindings. - ; cexpr <- tryConvert var var' expr - ; return . Rec $ (var, cexpr) : (var', expr') : hs - } } } } - `orElseErrV` - do - { emitVt " Could NOT vectorise top-level binding" $ ppr var - ; return b - } -vectTopBind b@(Rec binds) - = do - { traceVt "= Vectorise recursive top-level variables" $ ppr vars - - ; vectDecls <- mapM lookupVectDecl vars - ; let hasNoVects = map fst vectDecls - ; if and hasNoVects - then do - { -- 'NOVECTORISE' pragmas => leave this entire binding group as it is - ; traceVt "NOVECTORISE" $ ppr vars - ; return b - } - else do - { if or hasNoVects - then do - { -- Inconsistent 'NOVECTORISE' pragmas => bail out - ; dflags <- getDynFlags - ; cantVectorise dflags noVectoriseErr (ppr b) - } - else do - { traceVt "[Vanilla]" $ vcat [ppr var <+> char '=' <+> ppr expr | (var, expr) <- binds] - - -- For all bindings *with* a pragma, just use the pragma-supplied vectorised expression - ; newBindsWPragma <- concat <$> - sequence [ vectTopBindAndConvert bind inlineMe expr' - | (bind, (_, Just (_, expr'))) <- zip binds vectDecls] - - -- Standard vectorisation of all rhses that are *without* a pragma. - -- NB: The reason for 'fixV' is rather subtle: 'vectTopBindAndConvert' adds entries for - -- the bound variables in the recursive group to the vectorisation map, which in turn - -- are needed by 'vectPolyExprs' (unless it returns 'Nothing'). - ; let bindsWOPragma = [bind | (bind, (_, Nothing)) <- zip binds vectDecls] - ; (newBinds, _) <- fixV $ - \ ~(_, exprs') -> - do - { -- Create appropriate top-level bindings, enter them into the vectorisation map, and - -- vectorise the right-hand sides - ; newBindsWOPragma <- concat <$> - sequence [vectTopBindAndConvert bind inline expr - | (bind, ~(inline, expr)) <- zipLazy bindsWOPragma exprs'] - -- irrefutable pattern and 'zipLazy' to tie the knot; - -- hence, can't use 'zipWithM' - ; vectRhses <- vectTopExprs bindsWOPragma - ; hs <- takeHoisted -- make sure we clean those out (even if we skip) - - ; case vectRhses of - Nothing -> - -- scalar bindings => skip all bindings except those with pragmas and retract the - -- entries into the vectorisation map for the scalar bindings - do - { traceVt "scalar bindings [skip]" $ ppr vars - ; mapM_ (undefGlobalVar . fst) bindsWOPragma - ; return (bindsWOPragma ++ newBindsWPragma, exprs') - } - Just (parBind, exprs') -> - -- vanilla case => record parallel variables and return the final bindings - do - { when parBind $ - mapM_ addGlobalParallelVar vars - ; return (newBindsWOPragma ++ newBindsWPragma ++ hs, exprs') - } - } - ; return $ Rec newBinds - } } } - `orElseErrV` - do - { emitVt " Could NOT vectorise top-level bindings" $ ppr vars - ; return b - } - where - vars = map fst binds - noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group" - - -- Replace the original top-level bindings by a values projected from the vectorised - -- closures and add any newly created hoisted top-level bindings to the group. - vectTopBindAndConvert (var, expr) inline expr' - = do - { var' <- vectTopBinder var inline expr' - ; cexpr <- tryConvert var var' expr - ; return [(var, cexpr), (var', expr')] - } - --- Add a vectorised binding to an imported top-level variable that has a VECTORISE pragma --- in this module. --- --- RESTRICTION: Currently, we cannot use the pragma for mutually recursive definitions. --- -vectImpBind :: (Id, CoreExpr) -> VM CoreBind -vectImpBind (var, expr) - = do - { traceVt "= Add vectorised binding to imported variable" (ppr var) - - ; var' <- vectTopBinder var inlineMe expr - ; return $ NonRec var' expr - } - --- |Make the vectorised version of this top level binder, and add the mapping between it and the --- original to the state. For some binder @foo@ the vectorised version is @$v_foo@ --- --- NOTE: 'vectTopBinder' *MUST* be lazy in inline and expr because of how it is used inside of --- 'fixV' in 'vectTopBind'. --- -vectTopBinder :: Var -- ^ Name of the binding. - -> Inline -- ^ Whether it should be inlined, used to annotate it. - -> CoreExpr -- ^ RHS of binding, used to set the 'Unfolding' of the returned 'Var'. - -> VM Var -- ^ Name of the vectorised binding. -vectTopBinder var inline expr - = do { -- Vectorise the type attached to the var. - ; vty <- vectType (idType var) - - -- If there is a vectorisation declaration for this binding, make sure its type matches - ; (_, vectDecl) <- lookupVectDecl var - ; case vectDecl of - Nothing -> return () - Just (vdty, _) - | eqType vty vdty -> return () - | otherwise -> - do - { dflags <- getDynFlags - ; cantVectorise dflags ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $ - (text "Expected type" <+> ppr vty) - $$ - (text "Inferred type" <+> ppr vdty) - } - -- Make the vectorised version of binding's name, and set the unfolding used for inlining - ; var' <- liftM (`setIdUnfolding` unfolding) - $ mkVectId var vty - - -- Add the mapping between the plain and vectorised name to the state. - ; defGlobalVar var var' - - ; return var' - } - where - unfolding = case inline of - Inline arity -> mkInlineUnfoldingWithArity arity expr - DontInline -> noUnfolding -{- -!!!TODO: dfuns and unfoldings: - -- Do not inline the dfun; instead give it a magic DFunFunfolding - -- See Note [ClassOp/DFun selection] - -- See also note [Single-method classes] - dfun_id_w_fun - | isNewTyCon class_tc - = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } - | otherwise - = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty dfun_args - `setInlinePragma` dfunInlinePragma - -} - --- |Project out the vectorised version of a binding from some closure, or return the original body --- if that doesn't work. --- -tryConvert :: Var -- ^Name of the original binding (eg @foo@) - -> Var -- ^Name of vectorised version of binding (eg @$vfoo@) - -> CoreExpr -- ^The original body of the binding. - -> VM CoreExpr -tryConvert var vect_var rhs - = fromVect (idType var) (Var vect_var) - `orElseErrV` - do - { emitVt " Could NOT call vectorised from original version" $ ppr var <+> dcolon <+> ppr (idType var) - ; return rhs - } diff --git a/vectorise/Vectorise/Builtins.hs b/vectorise/Vectorise/Builtins.hs deleted file mode 100644 --- a/vectorise/Vectorise/Builtins.hs +++ /dev/null @@ -1,35 +0,0 @@ --- Types and functions declared in 'Data.Array.Parallel.Prim' and used by the vectoriser. --- --- The @Builtins@ structure holds the name of all the things in 'Data.Array.Parallel.Prim' that --- appear in code generated by the vectoriser. - -module Vectorise.Builtins ( - -- * Restrictions - mAX_DPH_SCALAR_ARGS, - - -- * Builtins - Builtins(..), - - -- * Wrapped selectors - selTy, selsTy, - selReplicate, - selTags, - selElements, - selsLength, - sumTyCon, - prodTyCon, - prodDataCon, - replicatePD_PrimVar, - emptyPD_PrimVar, - packByTagPD_PrimVar, - combinePDVar, - combinePD_PrimVar, - scalarZip, - closureCtrFun, - - -- * Initialisation - initBuiltins, initBuiltinVars, -) where - -import Vectorise.Builtins.Base -import Vectorise.Builtins.Initialise diff --git a/vectorise/Vectorise/Builtins/Base.hs b/vectorise/Vectorise/Builtins/Base.hs deleted file mode 100644 --- a/vectorise/Vectorise/Builtins/Base.hs +++ /dev/null @@ -1,217 +0,0 @@ --- |Builtin types and functions used by the vectoriser. These are all defined in --- 'Data.Array.Parallel.Prim'. - -module Vectorise.Builtins.Base ( - -- * Hard config - mAX_DPH_PROD, - mAX_DPH_SUM, - mAX_DPH_COMBINE, - mAX_DPH_SCALAR_ARGS, - aLL_DPH_PRIM_TYCONS, - - -- * Builtins - Builtins(..), - - -- * Projections - selTy, selsTy, - selReplicate, - selTags, - selElements, - selsLength, - sumTyCon, - prodTyCon, - prodDataCon, - replicatePD_PrimVar, - emptyPD_PrimVar, - packByTagPD_PrimVar, - combinePDVar, - combinePD_PrimVar, - scalarZip, - closureCtrFun -) where - -import TysPrim -import BasicTypes -import Class -import CoreSyn -import TysWiredIn hiding (sumTyCon) -import Type -import TyCon -import DataCon -import NameEnv -import Name -import Outputable - -import Data.Array - - --- Cardinality of the various families of types and functions exported by the DPH library. - -mAX_DPH_PROD :: Int -mAX_DPH_PROD = 5 - -mAX_DPH_SUM :: Int -mAX_DPH_SUM = 2 - -mAX_DPH_COMBINE :: Int -mAX_DPH_COMBINE = 2 - -mAX_DPH_SCALAR_ARGS :: Int -mAX_DPH_SCALAR_ARGS = 8 - --- Types from 'GHC.Prim' supported by DPH --- -aLL_DPH_PRIM_TYCONS :: [Name] -aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doublePrimTyCon] - - --- |Holds the names of the types and functions from 'Data.Array.Parallel.Prim' that are used by the --- vectoriser. --- -data Builtins - = Builtins - { parrayTyCon :: TyCon -- ^ PArray - , pdataTyCon :: TyCon -- ^ PData - , pdatasTyCon :: TyCon -- ^ PDatas - , prClass :: Class -- ^ PR - , prTyCon :: TyCon -- ^ PR - , preprTyCon :: TyCon -- ^ PRepr - , paClass :: Class -- ^ PA - , paTyCon :: TyCon -- ^ PA - , paDataCon :: DataCon -- ^ PA - , paPRSel :: Var -- ^ PA - , replicatePDVar :: Var -- ^ replicatePD - , replicatePD_PrimVars :: NameEnv Var -- ^ replicatePD_Int# etc. - , emptyPDVar :: Var -- ^ emptyPD - , emptyPD_PrimVars :: NameEnv Var -- ^ emptyPD_Int# etc. - , packByTagPDVar :: Var -- ^ packByTagPD - , packByTagPD_PrimVars :: NameEnv Var -- ^ packByTagPD_Int# etc. - , combinePDVars :: Array Int Var -- ^ combinePD - , combinePD_PrimVarss :: Array Int (NameEnv Var) -- ^ combine2PD_Int# etc. - , scalarClass :: Class -- ^ Scalar - , scalarZips :: Array Int Var -- ^ map, zipWith, zipWith3 - , voidTyCon :: TyCon -- ^ Void - , voidVar :: Var -- ^ void - , fromVoidVar :: Var -- ^ fromVoid - , sumTyCons :: Array Int TyCon -- ^ Sum2 .. Sum3 - , wrapTyCon :: TyCon -- ^ Wrap - , pvoidVar :: Var -- ^ pvoid - , pvoidsVar :: Var -- ^ pvoids - , closureTyCon :: TyCon -- ^ :-> - , closureVar :: Var -- ^ closure - , liftedClosureVar :: Var -- ^ liftedClosure - , applyVar :: Var -- ^ $: - , liftedApplyVar :: Var -- ^ liftedApply - , closureCtrFuns :: Array Int Var -- ^ closure1 .. closure3 - , selTys :: Array Int Type -- ^ Sel2 - , selsTys :: Array Int Type -- ^ Sels2 - , selsLengths :: Array Int CoreExpr -- ^ lengthSels2 - , selReplicates :: Array Int CoreExpr -- ^ replicate2 - , selTagss :: Array Int CoreExpr -- ^ tagsSel2 - , selElementss :: Array (Int, Int) CoreExpr -- ^ elementsSel2_0 .. elementsSel_2_1 - , liftingContext :: Var -- ^ lc - } - - --- Projections ---------------------------------------------------------------- --- We use these wrappers instead of indexing the `Builtin` structure directly --- because they give nicer panic messages if the indexed thing cannot be found. - -selTy :: Int -> Builtins -> Type -selTy = indexBuiltin "selTy" selTys - -selsTy :: Int -> Builtins -> Type -selsTy = indexBuiltin "selsTy" selsTys - -selsLength :: Int -> Builtins -> CoreExpr -selsLength = indexBuiltin "selLength" selsLengths - -selReplicate :: Int -> Builtins -> CoreExpr -selReplicate = indexBuiltin "selReplicate" selReplicates - -selTags :: Int -> Builtins -> CoreExpr -selTags = indexBuiltin "selTags" selTagss - -selElements :: Int -> Int -> Builtins -> CoreExpr -selElements i j = indexBuiltin "selElements" selElementss (i, j) - -sumTyCon :: Int -> Builtins -> TyCon -sumTyCon = indexBuiltin "sumTyCon" sumTyCons - -prodTyCon :: Int -> Builtins -> TyCon -prodTyCon n _ - | n >= 2 && n <= mAX_DPH_PROD - = tupleTyCon Boxed n - | otherwise - = pprPanic "prodTyCon" (ppr n) - -prodDataCon :: Int -> Builtins -> DataCon -prodDataCon n bi - = case tyConDataCons (prodTyCon n bi) of - [con] -> con - _ -> pprPanic "prodDataCon" (ppr n) - -replicatePD_PrimVar :: TyCon -> Builtins -> Var -replicatePD_PrimVar tc bi - = lookupEnvBuiltin "replicatePD_PrimVar" (replicatePD_PrimVars bi) (tyConName tc) - -emptyPD_PrimVar :: TyCon -> Builtins -> Var -emptyPD_PrimVar tc bi - = lookupEnvBuiltin "emptyPD_PrimVar" (emptyPD_PrimVars bi) (tyConName tc) - -packByTagPD_PrimVar :: TyCon -> Builtins -> Var -packByTagPD_PrimVar tc bi - = lookupEnvBuiltin "packByTagPD_PrimVar" (packByTagPD_PrimVars bi) (tyConName tc) - -combinePDVar :: Int -> Builtins -> Var -combinePDVar = indexBuiltin "combinePDVar" combinePDVars - -combinePD_PrimVar :: Int -> TyCon -> Builtins -> Var -combinePD_PrimVar i tc bi - = lookupEnvBuiltin "combinePD_PrimVar" - (indexBuiltin "combinePD_PrimVar" combinePD_PrimVarss i bi) (tyConName tc) - -scalarZip :: Int -> Builtins -> Var -scalarZip = indexBuiltin "scalarZip" scalarZips - -closureCtrFun :: Int -> Builtins -> Var -closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns - --- | Get an element from one of the arrays of `Builtins`. --- Panic if the indexed thing is not in the array. -indexBuiltin :: (Ix i, Outputable i) - => String -- ^ Name of the selector we've used, for panic messages. - -> (Builtins -> Array i a) -- ^ Field selector for the `Builtins`. - -> i -- ^ Index into the array. - -> Builtins - -> a -indexBuiltin fn f i bi - | inRange (bounds xs) i = xs ! i - | otherwise - = pprSorry "Vectorise.Builtins.indexBuiltin" - (vcat [ text "" - , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <> - text "' is not yet implemented." - , text "This function does not appear in your source program, but it is needed" - , text "to compile your code in the backend. This is a known, current limitation" - , text "of DPH. If you want it to work, you should send mail to ghc-commits@haskell.org" - , text "and ask what you can do to help (it might involve some GHC hacking)."]) - where xs = f bi - - --- | Get an entry from one of a 'NameEnv' of `Builtins`. Panic if the named item is not in the array. -lookupEnvBuiltin :: String -- Function name for error messages - -> NameEnv a -- Name environment - -> Name -- Index into the name environment - -> a -lookupEnvBuiltin fn env n - | Just r <- lookupNameEnv env n = r - | otherwise - = pprSorry "Vectorise.Builtins.lookupEnvBuiltin" - (vcat [ text "" - , text "DPH builtin function '" <> text fn <> text "_" <> ppr n <> - text "' is not yet implemented." - , text "This function does not appear in your source program, but it is needed" - , text "to compile your code in the backend. This is a known, current limitation" - , text "of DPH. If you want it to work, you should send mail to ghc-commits@haskell.org" - , text "and ask what you can do to help (it might involve some GHC hacking)."]) diff --git a/vectorise/Vectorise/Builtins/Initialise.hs b/vectorise/Vectorise/Builtins/Initialise.hs deleted file mode 100644 --- a/vectorise/Vectorise/Builtins/Initialise.hs +++ /dev/null @@ -1,232 +0,0 @@ --- Set up the data structures provided by 'Vectorise.Builtins'. - -module Vectorise.Builtins.Initialise ( - -- * Initialisation - initBuiltins, initBuiltinVars -) where - -import Vectorise.Builtins.Base - -import BasicTypes -import TysPrim -import DsMonad -import TysWiredIn -import DataCon -import TyCon -import Class -import CoreSyn -import Type -import NameEnv -import Name -import Id -import FastString -import Outputable - -import Control.Monad -import Data.Array - - --- |Create the initial map of builtin types and functions. --- -initBuiltins :: DsM Builtins -initBuiltins - = do { -- 'PArray: representation type for parallel arrays - ; parrayTyCon <- externalTyCon (fsLit "PArray") - - -- 'PData': type family mapping array element types to array representation types - -- Not all backends use `PDatas`. - ; pdataTyCon <- externalTyCon (fsLit "PData") - ; pdatasTyCon <- externalTyCon (fsLit "PDatas") - - -- 'PR': class of basic array operators operating on 'PData' types - ; prClass <- externalClass (fsLit "PR") - ; let prTyCon = classTyCon prClass - - -- 'PRepr': type family mapping element types to representation types - ; preprTyCon <- externalTyCon (fsLit "PRepr") - - -- 'PA': class of basic operations on arrays (parametrised by the element type) - ; paClass <- externalClass (fsLit "PA") - ; let paTyCon = classTyCon paClass - [paDataCon] = tyConDataCons paTyCon - paPRSel = classSCSelId paClass 0 - - -- Functions on array representations - ; replicatePDVar <- externalVar (fsLit "replicatePD") - ; replicate_vars <- mapM externalVar (suffixed "replicatePA" aLL_DPH_PRIM_TYCONS) - ; emptyPDVar <- externalVar (fsLit "emptyPD") - ; empty_vars <- mapM externalVar (suffixed "emptyPA" aLL_DPH_PRIM_TYCONS) - ; packByTagPDVar <- externalVar (fsLit "packByTagPD") - ; packByTag_vars <- mapM externalVar (suffixed "packByTagPA" aLL_DPH_PRIM_TYCONS) - ; let combineNamesD = [("combine" ++ show i ++ "PD") | i <- [2..mAX_DPH_COMBINE]] - ; let combineNamesA = [("combine" ++ show i ++ "PA") | i <- [2..mAX_DPH_COMBINE]] - ; combines <- mapM externalVar (map mkFastString combineNamesD) - ; combines_vars <- mapM (mapM externalVar) $ - map (\name -> suffixed name aLL_DPH_PRIM_TYCONS) combineNamesA - ; let replicatePD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS replicate_vars) - emptyPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS empty_vars) - packByTagPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS packByTag_vars) - combinePDVars = listArray (2, mAX_DPH_COMBINE) combines - combinePD_PrimVarss = listArray (2, mAX_DPH_COMBINE) - [ mkNameEnv (zip aLL_DPH_PRIM_TYCONS vars) - | vars <- combines_vars] - - -- 'Scalar': class moving between plain unboxed arrays and 'PData' representations - ; scalarClass <- externalClass (fsLit "Scalar") - - -- N-ary maps ('zipWith' family) - ; scalar_map <- externalVar (fsLit "scalar_map") - ; scalar_zip2 <- externalVar (fsLit "scalar_zipWith") - ; scalar_zips <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) - ; let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) - (scalar_map : scalar_zip2 : scalar_zips) - - -- Types and functions for generic type representations - ; voidTyCon <- externalTyCon (fsLit "Void") - ; voidVar <- externalVar (fsLit "void") - ; fromVoidVar <- externalVar (fsLit "fromVoid") - ; sum_tcs <- mapM externalTyCon (numbered "Sum" 2 mAX_DPH_SUM) - ; let sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs - ; wrapTyCon <- externalTyCon (fsLit "Wrap") - ; pvoidVar <- externalVar (fsLit "pvoid") - ; pvoidsVar <- externalVar (fsLit "pvoids#") - - -- Types and functions for closure conversion - ; closureTyCon <- externalTyCon (fsLit ":->") - ; closureVar <- externalVar (fsLit "closure") - ; liftedClosureVar <- externalVar (fsLit "liftedClosure") - ; applyVar <- externalVar (fsLit "$:") - ; liftedApplyVar <- externalVar (fsLit "liftedApply") - ; closures <- mapM externalVar (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) - ; let closureCtrFuns = listArray (1, mAX_DPH_SCALAR_ARGS) closures - - -- Types and functions for selectors - ; sel_tys <- mapM externalType (numbered "Sel" 2 mAX_DPH_SUM) - ; sels_tys <- mapM externalType (numbered "Sels" 2 mAX_DPH_SUM) - ; sels_length <- mapM externalFun (numbered_hash "lengthSels" 2 mAX_DPH_SUM) - ; sel_replicates <- mapM externalFun (numbered_hash "replicateSel" 2 mAX_DPH_SUM) - ; sel_tags <- mapM externalFun (numbered "tagsSel" 2 mAX_DPH_SUM) - ; sel_elements <- mapM mk_elements [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] - ; let selTys = listArray (2, mAX_DPH_SUM) sel_tys - selsTys = listArray (2, mAX_DPH_SUM) sels_tys - selsLengths = listArray (2, mAX_DPH_SUM) sels_length - selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates - selTagss = listArray (2, mAX_DPH_SUM) sel_tags - selElementss = array ((2, 0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_elements - - -- Distinct local variable - ; liftingContext <- liftM (\u -> mkSysLocalOrCoVar (fsLit "lc") u intPrimTy) newUnique - - ; return $ Builtins - { parrayTyCon = parrayTyCon - , pdataTyCon = pdataTyCon - , pdatasTyCon = pdatasTyCon - , preprTyCon = preprTyCon - , prClass = prClass - , prTyCon = prTyCon - , paClass = paClass - , paTyCon = paTyCon - , paDataCon = paDataCon - , paPRSel = paPRSel - , replicatePDVar = replicatePDVar - , replicatePD_PrimVars = replicatePD_PrimVars - , emptyPDVar = emptyPDVar - , emptyPD_PrimVars = emptyPD_PrimVars - , packByTagPDVar = packByTagPDVar - , packByTagPD_PrimVars = packByTagPD_PrimVars - , combinePDVars = combinePDVars - , combinePD_PrimVarss = combinePD_PrimVarss - , scalarClass = scalarClass - , scalarZips = scalarZips - , voidTyCon = voidTyCon - , voidVar = voidVar - , fromVoidVar = fromVoidVar - , sumTyCons = sumTyCons - , wrapTyCon = wrapTyCon - , pvoidVar = pvoidVar - , pvoidsVar = pvoidsVar - , closureTyCon = closureTyCon - , closureVar = closureVar - , liftedClosureVar = liftedClosureVar - , applyVar = applyVar - , liftedApplyVar = liftedApplyVar - , closureCtrFuns = closureCtrFuns - , selTys = selTys - , selsTys = selsTys - , selsLengths = selsLengths - , selReplicates = selReplicates - , selTagss = selTagss - , selElementss = selElementss - , liftingContext = liftingContext - } - } - where - suffixed :: String -> [Name] -> [FastString] - suffixed pfx ns = [mkFastString (pfx ++ "_" ++ (occNameString . nameOccName) n) | n <- ns] - - -- Make a list of numbered strings in some range, eg foo3, foo4, foo5 - numbered :: String -> Int -> Int -> [FastString] - numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]] - - numbered_hash :: String -> Int -> Int -> [FastString] - numbered_hash pfx m n = [mkFastString (pfx ++ show i ++ "#") | i <- [m..n]] - - mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr) - mk_elements (i,j) - = do { v <- externalVar $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#") - ; return ((i, j), Var v) - } - --- |Get the mapping of names in the Prelude to names in the DPH library. --- -initBuiltinVars :: Builtins -> DsM [(Var, Var)] --- FIXME: must be replaced by VECTORISE pragmas!!! -initBuiltinVars (Builtins { }) - = do - cvars <- mapM externalVar cfs - return $ zip (map dataConWorkId cons) cvars - where - (cons, cfs) = unzip preludeDataCons - - preludeDataCons :: [(DataCon, FastString)] - preludeDataCons - = [mk_tup n (mkFastString $ "tup" ++ show n) | n <- [2..5]] - where - mk_tup n name = (tupleDataCon Boxed n, name) - - --- Auxiliary look up functions ----------------------------------------------- - --- |Lookup a variable given its name and the module that contains it. -externalVar :: FastString -> DsM Var -externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId - - --- |Like `externalVar` but wrap the `Var` in a `CoreExpr`. -externalFun :: FastString -> DsM CoreExpr -externalFun fs = Var <$> externalVar fs - - --- |Lookup a 'TyCon' in 'Data.Array.Parallel.Prim', given its name. --- Panic if there isn't one. -externalTyCon :: FastString -> DsM TyCon -externalTyCon fs = dsLookupDPHRdrEnv (mkTcOccFS fs) >>= dsLookupTyCon - - --- |Lookup some `Type` in 'Data.Array.Parallel.Prim', given its name. -externalType :: FastString -> DsM Type -externalType fs - = do tycon <- externalTyCon fs - return $ mkTyConApp tycon [] - - --- |Lookup a 'Class' in 'Data.Array.Parallel.Prim', given its name. -externalClass :: FastString -> DsM Class -externalClass fs - = do { tycon <- dsLookupDPHRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon - ; case tyConClass_maybe tycon of - Nothing -> pprPanic "Vectorise.Builtins.Initialise" $ - text "Data.Array.Parallel.Prim." <> - ftext fs <+> text "is not a type class" - Just cls -> return cls - } diff --git a/vectorise/Vectorise/Convert.hs b/vectorise/Vectorise/Convert.hs deleted file mode 100644 --- a/vectorise/Vectorise/Convert.hs +++ /dev/null @@ -1,105 +0,0 @@ -module Vectorise.Convert - ( fromVect - ) -where - -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Type.Type - -import CoreSyn -import TyCon -import Type -import TyCoRep -import NameSet -import FastString -import Outputable - -import Control.Applicative -import Prelude -- avoid redundant import warning due to AMP - --- |Convert a vectorised expression such that it computes the non-vectorised equivalent of its --- value. --- --- For functions, we eta expand the function and convert the arguments and result: - --- For example --- @ --- \(x :: Double) -> --- \(y :: Double) -> --- ($v_foo $: x) $: y --- @ --- --- We use the type of the original binding to work out how many outer lambdas to add. --- -fromVect :: Type -- ^ The type of the original binding. - -> CoreExpr -- ^ Expression giving the closure to use, eg @$v_foo@. - -> VM CoreExpr - --- Convert the type to the core view if it isn't already. --- -fromVect ty expr - | Just ty' <- coreView ty - = fromVect ty' expr - --- For each function constructor in the original type we add an outer --- lambda to bind the parameter variable, and an inner application of it. -fromVect (FunTy arg_ty res_ty) expr - = do - arg <- newLocalVar (fsLit "x") arg_ty - varg <- toVect arg_ty (Var arg) - varg_ty <- vectType arg_ty - vres_ty <- vectType res_ty - apply <- builtin applyVar - body <- fromVect res_ty - $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg] - return $ Lam arg body - --- If the type isn't a function, then we can't current convert it unless the type is scalar (i.e., --- is identical to the non-vectorised version). --- -fromVect ty expr - = identityConv ty >> return expr - --- Convert an expression such that it evaluates to the vectorised equivalent of the value of the --- original expression. --- --- WARNING: Currently only works for the scalar types, where the vectorised value coincides with the --- original one. --- -toVect :: Type -> CoreExpr -> VM CoreExpr -toVect ty expr = identityConv ty >> return expr - --- |Check that the type is neutral under type vectorisation — i.e., all involved type constructor --- are not altered by vectorisation as they contain no parallel arrays. --- -identityConv :: Type -> VM () -identityConv ty - | Just ty' <- coreView ty - = identityConv ty' -identityConv (TyConApp tycon tys) - = do { mapM_ identityConv tys - ; identityConvTyCon tycon - } -identityConv (LitTy {}) = noV $ text "identityConv: not sure about literal types under vectorisation" -identityConv (TyVarTy {}) = noV $ text "identityConv: type variable changes under vectorisation" -identityConv (AppTy {}) = noV $ text "identityConv: type appl. changes under vectorisation" -identityConv (FunTy {}) = noV $ text "identityConv: function type changes under vectorisation" -identityConv (ForAllTy {}) = noV $ text "identityConv: quantified type changes under vectorisation" -identityConv (CastTy {}) = noV $ text "identityConv: not sure about casted types under vectorisation" -identityConv (CoercionTy {}) = noV $ text "identityConv: not sure about coercions under vectorisation" - --- |Check that this type constructor is not changed by vectorisation — i.e., it does not embed any --- parallel arrays. --- -identityConvTyCon :: TyCon -> VM () -identityConvTyCon tc - = do - { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons - ; parray <- builtin parrayTyCon - ; if isParallel && not (tc == parray) - then noV idErr - else return () - } - where - idErr = text "identityConvTyCon: type constructor contains parallel arrays" <+> ppr tc diff --git a/vectorise/Vectorise/Env.hs b/vectorise/Vectorise/Env.hs deleted file mode 100644 --- a/vectorise/Vectorise/Env.hs +++ /dev/null @@ -1,238 +0,0 @@ -module Vectorise.Env ( - Scope(..), - - -- * Local Environments - LocalEnv(..), - emptyLocalEnv, - - -- * Global Environments - GlobalEnv(..), - initGlobalEnv, - extendImportedVarsEnv, - extendFamEnv, - setPAFunsEnv, - setPRFunsEnv, - modVectInfo -) where - -import HscTypes -import InstEnv -import FamInstEnv -import CoreSyn -import Type -import Class -import TyCon -import DataCon -import VarEnv -import VarSet -import Var -import NameSet -import Name -import NameEnv -import FastString -import UniqDFM -import UniqSet - - -import Data.Maybe - - --- |Indicates what scope something (a variable) is in. --- -data Scope a b - = Global a - | Local b - - --- LocalEnv ------------------------------------------------------------------- - --- |The local environment. --- -data LocalEnv - = LocalEnv - { local_vars :: VarEnv (Var, Var) - -- ^Mapping from local variables to their vectorised and lifted versions. - - , local_tyvars :: [TyVar] - -- ^In-scope type variables. - - , local_tyvar_pa :: VarEnv CoreExpr - -- ^Mapping from tyvars to their PA dictionaries. - - , local_bind_name :: FastString - -- ^Local binding name. This is only used to generate better names for hoisted - -- expressions. - } - --- |Create an empty local environment. --- -emptyLocalEnv :: LocalEnv -emptyLocalEnv = LocalEnv - { local_vars = emptyVarEnv - , local_tyvars = [] - , local_tyvar_pa = emptyVarEnv - , local_bind_name = fsLit "fn" - } - - --- GlobalEnv ------------------------------------------------------------------ - --- |The global environment: entities that exist at top-level. --- -data GlobalEnv - = GlobalEnv - { global_vect_avoid :: Bool - -- ^'True' implies to avoid vectorisation as far as possible. - - , global_vars :: VarEnv Var - -- ^Mapping from global variables to their vectorised versions — aka the /vectorisation - -- map/. - - , global_parallel_vars :: DVarSet - -- ^The domain of 'global_vars'. - -- - -- This information is not redundant as it is impossible to extract the domain from a - -- 'VarEnv' (which is keyed on uniques alone). Moreover, we have mapped variables that - -- do not involve parallelism — e.g., the workers of vectorised, but scalar data types. - -- In addition, workers of parallel data types that we could not vectorise also need to - -- be tracked. - - , global_vect_decls :: VarEnv (Maybe (Type, CoreExpr)) - -- ^Mapping from global variables that have a vectorisation declaration to the right-hand - -- side of that declaration and its type and mapping variables that have NOVECTORISE - -- declarations to 'Nothing'. - - , global_tycons :: NameEnv TyCon - -- ^Mapping from TyCons to their vectorised versions. The vectorised version will be - -- identical to the original version if it is not changed by vectorisation. In any case, - -- if a tycon appears in the domain of this mapping, it was successfully vectorised. - - , global_parallel_tycons :: NameSet - -- ^Type constructors whose definition directly or indirectly includes a parallel type, - -- such as '[::]'. - -- - -- NB: This information is not redundant as some types have got a mapping in - -- 'global_tycons' (to a type other than themselves) and are still not parallel. An - -- example is '(->)'. Moreover, some types have *not* got a mapping in 'global_tycons' - -- (because they couldn't be vectorised), but still contain parallel types. - - , global_datacons :: NameEnv DataCon - -- ^Mapping from DataCons to their vectorised versions. - - , global_pa_funs :: NameEnv Var - -- ^Mapping from TyCons to their PA dfuns. - - , global_pr_funs :: NameEnv Var - -- ^Mapping from TyCons to their PR dfuns. - - , global_inst_env :: InstEnvs - -- ^External package inst-env & home-package inst-env for class instances. - - , global_fam_inst_env :: FamInstEnvs - -- ^External package inst-env & home-package inst-env for family instances. - - , global_bindings :: [(Var, CoreExpr)] - -- ^Hoisted bindings — temporary storage for toplevel bindings during code gen. - } - --- |Create an initial global environment. --- --- We add scalar variables and type constructors identified by vectorisation pragmas already here --- to the global table, so that we can query scalarness during vectorisation, and especially, when --- vectorising the scalar entities' definitions themselves. --- -initGlobalEnv :: Bool - -> VectInfo - -> [CoreVect] - -> InstEnvs - -> FamInstEnvs - -> GlobalEnv -initGlobalEnv vectAvoid info vectDecls instEnvs famInstEnvs - = GlobalEnv - { global_vect_avoid = vectAvoid - , global_vars = mapVarEnv snd $ udfmToUfm $ vectInfoVar info - , global_vect_decls = mkVarEnv vects - , global_parallel_vars = vectInfoParallelVars info - , global_parallel_tycons = vectInfoParallelTyCons info - , global_tycons = mapNameEnv snd $ vectInfoTyCon info - , global_datacons = mapNameEnv snd $ vectInfoDataCon info - , global_pa_funs = emptyNameEnv - , global_pr_funs = emptyNameEnv - , global_inst_env = instEnvs - , global_fam_inst_env = famInstEnvs - , global_bindings = [] - } - where - vects = [(var, Just (ty, exp)) | Vect var exp@(Var rhs_var) <- vectDecls - , let ty = varType rhs_var] ++ - -- FIXME: we currently only allow RHSes consisting of a - -- single variable to be able to obtain the type without - -- inference — see also 'TcBinds.tcVect' - [(var, Nothing) | NoVect var <- vectDecls] - - --- Operators on Global Environments ------------------------------------------- - --- |Extend the list of global variables in an environment. --- -extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv -extendImportedVarsEnv ps genv - = genv { global_vars = extendVarEnvList (global_vars genv) ps } - --- |Extend the list of type family instances. --- -extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv -extendFamEnv new genv - = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) } - where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv - --- |Set the list of PA functions in an environment. --- -setPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv -setPAFunsEnv ps genv = genv { global_pa_funs = mkNameEnv ps } - --- |Set the list of PR functions in an environment. --- -setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv -setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps } - --- |Compute vectorisation information that goes into 'ModGuts' (and is stored in interface files). --- The incoming 'vectInfo' is that from the 'HscEnv' and 'EPS'. The outgoing one contains only the --- declarations for the currently compiled module; this includes variables, type constructors, and --- data constructors referenced in VECTORISE pragmas, even if they are defined in an imported --- module. --- --- The variables explicitly include class selectors and dfuns. --- -modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo -modVectInfo env mg_ids mg_tyCons vectDecls info - = info - { vectInfoVar = mk_denv ids (global_vars env) - , vectInfoTyCon = mk_env tyCons (global_tycons env) - , vectInfoDataCon = mk_env dataCons (global_datacons env) - , vectInfoParallelVars = (global_parallel_vars env `minusDVarSet` vectInfoParallelVars info) - `udfmIntersectUFM` (getUniqSet $ mkVarSet ids) - , vectInfoParallelTyCons = global_parallel_tycons env `minusNameSet` vectInfoParallelTyCons info - } - where - vectIds = [id | Vect id _ <- vectDecls] ++ - [id | VectInst id <- vectDecls] - vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls] ++ - [tycon | VectClass tycon <- vectDecls] - vectDataCons = concatMap tyConDataCons vectTypeTyCons - ids = mg_ids ++ vectIds ++ dataConIds ++ selIds - tyCons = mg_tyCons ++ vectTypeTyCons - dataCons = concatMap tyConDataCons mg_tyCons ++ vectDataCons - dataConIds = map dataConWorkId dataCons - selIds = concat [ classAllSelIds cls - | tycon <- tyCons - , cls <- maybeToList . tyConClass_maybe $ tycon] - - -- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv' - mk_env decls inspectedEnv = mkNameEnv $ mk_assoc_env decls inspectedEnv - mk_denv decls inspectedEnv = listToUDFM $ mk_assoc_env decls inspectedEnv - mk_assoc_env decls inspectedEnv - = [(name, (decl, to)) - | decl <- decls - , let name = getName decl - , Just to <- [lookupNameEnv inspectedEnv name]] diff --git a/vectorise/Vectorise/Exp.hs b/vectorise/Vectorise/Exp.hs deleted file mode 100644 --- a/vectorise/Vectorise/Exp.hs +++ /dev/null @@ -1,1258 +0,0 @@ -{-# LANGUAGE CPP, TupleSections #-} - --- |Vectorisation of expressions. - -module Vectorise.Exp - ( -- * Vectorise right-hand sides of toplevel bindings - vectTopExpr - , vectTopExprs - , vectScalarFun - , vectScalarDFun - ) -where - -#include "HsVersions.h" - -import Vectorise.Type.Type -import Vectorise.Var -import Vectorise.Convert -import Vectorise.Vect -import Vectorise.Env -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Utils - -import CoreUtils -import MkCore -import CoreSyn -import CoreFVs -import Class -import DataCon -import TyCon -import TcType -import Type -import TyCoRep -import Var -import VarEnv -import VarSet -import NameSet -import Id -import BasicTypes( isStrongLoopBreaker ) -import Literal -import TysPrim -import Outputable -import FastString -import DynFlags -import Util - -import Control.Monad -import Data.Maybe -import Data.List - - --- Main entry point to vectorise expressions ----------------------------------- - --- |Vectorise a polymorphic expression that forms a *non-recursive* binding. --- --- Return 'Nothing' if the expression is scalar; otherwise, the first component of the result --- (which is of type 'Bool') indicates whether the expression is parallel (i.e., whether it is --- tagged as 'VIParr'). --- --- We have got the non-recursive case as a special case as it doesn't require to compute --- vectorisation information twice. --- -vectTopExpr :: Var -> CoreExpr -> VM (Maybe (Bool, Inline, CoreExpr)) -vectTopExpr var expr - = do - { exprVI <- encapsulateScalars <=< vectAvoidInfo emptyVarSet . freeVars $ expr - ; if isVIEncaps exprVI - then - return Nothing - else do - { vExpr <- closedV $ - inBind var $ - vectAnnPolyExpr False exprVI - ; inline <- computeInline exprVI - ; return $ Just (isVIParr exprVI, inline, vectorised vExpr) - } - } - --- Compute the inlining hint for the right-hand side of a top-level binding. --- -computeInline :: CoreExprWithVectInfo -> VM Inline -computeInline ((_, VIDict), _) = return $ DontInline -computeInline (_, AnnTick _ expr) = computeInline expr -computeInline expr@(_, AnnLam _ _) = Inline <$> polyArity tvs - where - (tvs, _) = collectAnnTypeBinders expr -computeInline _expr = return $ DontInline - --- |Vectorise a recursive group of top-level polymorphic expressions. --- --- Return 'Nothing' if the expression group is scalar; otherwise, the first component of the result --- (which is of type 'Bool') indicates whether the expressions are parallel (i.e., whether they are --- tagged as 'VIParr'). --- -vectTopExprs :: [(Var, CoreExpr)] -> VM (Maybe (Bool, [(Inline, CoreExpr)])) -vectTopExprs binds - = do - { exprVIs <- mapM (vectAvoidAndEncapsulate emptyVarSet) exprs - ; if all isVIEncaps exprVIs - -- if all bindings are scalar => don't vectorise this group of bindings - then return Nothing - else do - { -- non-scalar bindings need to be vectorised - ; let areVIParr = any isVIParr exprVIs - ; revised_exprVIs <- if not areVIParr - -- if no binding is parallel => 'exprVIs' is ready for vectorisation - then return exprVIs - -- if any binding is parallel => recompute the vectorisation info - else mapM (vectAvoidAndEncapsulate (mkVarSet vars)) exprs - - ; vExprs <- zipWithM vect vars revised_exprVIs - ; return $ Just (areVIParr, vExprs) - } - } - where - (vars, exprs) = unzip binds - - vectAvoidAndEncapsulate pvs = encapsulateScalars <=< vectAvoidInfo pvs . freeVars - - vect var exprVI - = do - { vExpr <- closedV $ - inBind var $ - vectAnnPolyExpr (isStrongLoopBreaker $ idOccInfo var) exprVI - ; inline <- computeInline exprVI - ; return (inline, vectorised vExpr) - } - --- |Vectorise a polymorphic expression annotated with vectorisation information. --- --- The special case of dictionary functions is currently handled separately. (Would be neater to --- integrate them, though!) --- -vectAnnPolyExpr :: Bool -> CoreExprWithVectInfo -> VM VExpr -vectAnnPolyExpr loop_breaker (_, AnnTick tickish expr) - -- traverse through ticks - = vTick tickish <$> vectAnnPolyExpr loop_breaker expr -vectAnnPolyExpr loop_breaker expr - | isVIDict expr - -- special case the right-hand side of dictionary functions - = (, undefined) <$> vectDictExpr (deAnnotate expr) - | otherwise - -- collect and vectorise type abstractions; then, descent into the body - = polyAbstract tvs $ \args -> - mapVect (mkLams $ tvs ++ args) <$> vectFnExpr False loop_breaker mono - where - (tvs, mono) = collectAnnTypeBinders expr - --- Encapsulate every purely sequential subexpression of a (potentially) parallel expression into a --- lambda abstraction over all its free variables followed by the corresponding application to those --- variables. We can, then, avoid the vectorisation of the ensapsulated subexpressions. --- --- Preconditions: --- --- * All free variables and the result type must be /simple/ types. --- * The expression is sufficiently complex (to warrant special treatment). For now, that is --- every expression that is not constant and contains at least one operation. --- --- --- The user has an option to choose between aggressive and minimal vectorisation avoidance. With --- minimal vectorisation avoidance, we only encapsulate individual scalar operations. With --- aggressive vectorisation avoidance, we encapsulate subexpression that are as big as possible. --- -encapsulateScalars :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo -encapsulateScalars ce@(_, AnnType _ty) - = return ce -encapsulateScalars ce@((_, VISimple), AnnVar _v) - -- NB: diverts from the paper: encapsulate scalar variables (including functions) - = liftSimpleAndCase ce -encapsulateScalars ce@(_, AnnVar _v) - = return ce -encapsulateScalars ce@(_, AnnLit _) - = return ce -encapsulateScalars ((fvs, vi), AnnTick tck expr) - = do - { encExpr <- encapsulateScalars expr - ; return ((fvs, vi), AnnTick tck encExpr) - } -encapsulateScalars ce@((fvs, vi), AnnLam bndr expr) - = do - { vectAvoid <- isVectAvoidanceAggressive - ; varsS <- allScalarVarTypeSet fvs - -- NB: diverts from the paper: we need to check the scalarness of bound variables as well, - -- as 'vectScalarFun' will handle them just the same as those introduced for the 'fvs' - -- by encapsulation. - ; bndrsS <- allScalarVarType bndrs - ; case (vi, vectAvoid && varsS && bndrsS) of - (VISimple, True) -> liftSimpleAndCase ce - _ -> do - { encExpr <- encapsulateScalars expr - ; return ((fvs, vi), AnnLam bndr encExpr) - } - } - where - (bndrs, _) = collectAnnBndrs ce -encapsulateScalars ce@((fvs, vi), AnnApp ce1 ce2) - = do - { vectAvoid <- isVectAvoidanceAggressive - ; varsS <- allScalarVarTypeSet fvs - ; case (vi, (vectAvoid || isSimpleApplication ce) && varsS) of - (VISimple, True) -> liftSimpleAndCase ce - _ -> do - { encCe1 <- encapsulateScalars ce1 - ; encCe2 <- encapsulateScalars ce2 - ; return ((fvs, vi), AnnApp encCe1 encCe2) - } - } - where - isSimpleApplication :: CoreExprWithVectInfo -> Bool - isSimpleApplication (_, AnnTick _ ce) = isSimpleApplication ce - isSimpleApplication (_, AnnCast ce _) = isSimpleApplication ce - isSimpleApplication ce | isSimple ce = True - isSimpleApplication (_, AnnApp ce1 ce2) = isSimple ce1 && isSimpleApplication ce2 - isSimpleApplication _ = False - -- - isSimple :: CoreExprWithVectInfo -> Bool - isSimple (_, AnnType {}) = True - isSimple (_, AnnVar {}) = True - isSimple (_, AnnLit {}) = True - isSimple (_, AnnTick _ ce) = isSimple ce - isSimple (_, AnnCast ce _) = isSimple ce - isSimple _ = False -encapsulateScalars ce@((fvs, vi), AnnCase scrut bndr ty alts) - = do - { vectAvoid <- isVectAvoidanceAggressive - ; varsS <- allScalarVarTypeSet fvs - ; case (vi, vectAvoid && varsS) of - (VISimple, True) -> liftSimpleAndCase ce - _ -> do - { encScrut <- encapsulateScalars scrut - ; encAlts <- mapM encAlt alts - ; return ((fvs, vi), AnnCase encScrut bndr ty encAlts) - } - } - where - encAlt (con, bndrs, expr) = (con, bndrs,) <$> encapsulateScalars expr -encapsulateScalars ce@((fvs, vi), AnnLet (AnnNonRec bndr expr1) expr2) - = do - { vectAvoid <- isVectAvoidanceAggressive - ; varsS <- allScalarVarTypeSet fvs - ; case (vi, vectAvoid && varsS) of - (VISimple, True) -> liftSimpleAndCase ce - _ -> do - { encExpr1 <- encapsulateScalars expr1 - ; encExpr2 <- encapsulateScalars expr2 - ; return ((fvs, vi), AnnLet (AnnNonRec bndr encExpr1) encExpr2) - } - } -encapsulateScalars ce@((fvs, vi), AnnLet (AnnRec binds) expr) - = do - { vectAvoid <- isVectAvoidanceAggressive - ; varsS <- allScalarVarTypeSet fvs - ; case (vi, vectAvoid && varsS) of - (VISimple, True) -> liftSimpleAndCase ce - _ -> do - { encBinds <- mapM encBind binds - ; encExpr <- encapsulateScalars expr - ; return ((fvs, vi), AnnLet (AnnRec encBinds) encExpr) - } - } - where - encBind (bndr, expr) = (bndr,) <$> encapsulateScalars expr -encapsulateScalars ((fvs, vi), AnnCast expr coercion) - = do - { encExpr <- encapsulateScalars expr - ; return ((fvs, vi), AnnCast encExpr coercion) - } -encapsulateScalars _ - = panic "Vectorise.Exp.encapsulateScalars: unknown constructor" - --- Lambda-lift the given simple expression and apply it to the abstracted free variables. --- --- If the expression is a case expression scrutinising anything, but a scalar type, then lift --- each alternative individually. --- -liftSimpleAndCase :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo -liftSimpleAndCase aexpr@((fvs, _vi), AnnCase expr bndr t alts) - = do - { vi <- vectAvoidInfoTypeOf expr - ; if (vi == VISimple) - then - liftSimple aexpr -- if the scrutinee is scalar, we need no special treatment - else do - { alts' <- mapM (\(ac, bndrs, aexpr) -> (ac, bndrs,) <$> liftSimpleAndCase aexpr) alts - ; return ((fvs, vi), AnnCase expr bndr t alts') - } - } -liftSimpleAndCase aexpr = liftSimple aexpr - -liftSimple :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo -liftSimple ((fvs, vi), AnnVar v) - | v `elemDVarSet` fvs -- special case to avoid producing: (\v -> v) v - && not (isToplevel v) -- NB: if 'v' not free or is toplevel, we must get the 'VIEncaps' - = return $ ((fvs, vi), AnnVar v) -liftSimple aexpr@((fvs_orig, VISimple), expr) - = do - { let liftedExpr = mkAnnApps (mkAnnLams (reverse vars) fvs expr) vars - - ; traceVt "encapsulate:" $ ppr (deAnnotate aexpr) $$ text "==>" $$ ppr (deAnnotate liftedExpr) - - ; return $ liftedExpr - } - where - vars = dVarSetElems fvs - fvs = filterDVarSet (not . isToplevel) fvs_orig -- only include 'Id's that are not toplevel - - mkAnnLams :: [Var] -> DVarSet -> AnnExpr' Var (DVarSet, VectAvoidInfo) -> CoreExprWithVectInfo - mkAnnLams [] fvs expr = ASSERT(isEmptyDVarSet fvs) - ((emptyDVarSet, VIEncaps), expr) - mkAnnLams (v:vs) fvs expr = mkAnnLams vs (fvs `delDVarSet` v) (AnnLam v ((fvs, VIEncaps), expr)) - - mkAnnApps :: CoreExprWithVectInfo -> [Var] -> CoreExprWithVectInfo - mkAnnApps aexpr [] = aexpr - mkAnnApps aexpr (v:vs) = mkAnnApps (mkAnnApp aexpr v) vs - - mkAnnApp :: CoreExprWithVectInfo -> Var -> CoreExprWithVectInfo - mkAnnApp aexpr@((fvs, _vi), _expr) v - = ((fvs `extendDVarSet` v, VISimple), AnnApp aexpr ((unitDVarSet v, VISimple), AnnVar v)) -liftSimple aexpr - = pprPanic "Vectorise.Exp.liftSimple: not simple" $ ppr (deAnnotate aexpr) - -isToplevel :: Var -> Bool -isToplevel v | isId v = case realIdUnfolding v of - NoUnfolding -> False - BootUnfolding -> False - OtherCon {} -> True - DFunUnfolding {} -> True - CoreUnfolding {uf_is_top = top} -> top - | otherwise = False - --- |Vectorise an expression. --- -vectExpr :: CoreExprWithVectInfo -> VM VExpr - -vectExpr aexpr - -- encapsulated expression of functional type => try to vectorise as a scalar subcomputation - | (isFunTy . annExprType $ aexpr) && isVIEncaps aexpr - = vectFnExpr True False aexpr - -- encapsulated constant => vectorise as a scalar constant - | isVIEncaps aexpr - = traceVt "vectExpr (encapsulated constant):" (ppr . deAnnotate $ aexpr) >> - vectConst (deAnnotate aexpr) - -vectExpr (_, AnnVar v) - = vectVar v - -vectExpr (_, AnnLit lit) - = vectConst $ Lit lit - -vectExpr aexpr@(_, AnnLam _ _) - = traceVt "vectExpr [AnnLam]:" (ppr . deAnnotate $ aexpr) >> - vectFnExpr True False aexpr - - -- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty'; - -- its only purpose is to abort the program, but we need to adjust the type to keep CoreLint - -- happy. --- FIXME: can't be do this with a VECTORISE pragma on 'pAT_ERROR_ID' now? -vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err) - | v == pAT_ERROR_ID - = do - { (vty, lty) <- vectAndLiftType ty - ; return (mkCoreApps (Var v) [Type (getRuntimeRep vty), Type vty, err'], - mkCoreApps (Var v) [Type lty, err']) - } - where - err' = deAnnotate err - - -- type application (handle multiple consecutive type applications simultaneously to ensure the - -- PA dictionaries are put at the right places) -vectExpr e@(_, AnnApp _ arg) - | isAnnTypeArg arg - = vectPolyApp e - - -- Lifted literal -vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit)) - | Just _con <- isDataConId_maybe v - = do - { let vexpr = App (Var v) (Lit lit) - ; lexpr <- liftPD vexpr - ; return (vexpr, lexpr) - } - - -- value application (dictionary or user value) -vectExpr e@(_, AnnApp fn arg) - | isPredTy arg_ty -- dictionary application (whose result is not a dictionary) - = vectPolyApp e - | otherwise -- user value - = do - { -- vectorise the types - ; varg_ty <- vectType arg_ty - ; vres_ty <- vectType res_ty - - -- vectorise the function and argument expression - ; vfn <- vectExpr fn - ; varg <- vectExpr arg - - -- the vectorised function is a closure; apply it to the vectorised argument - ; mkClosureApp varg_ty vres_ty vfn varg - } - where - (arg_ty, res_ty) = splitFunTy . exprType $ deAnnotate fn - -vectExpr (_, AnnCase scrut bndr ty alts) - | Just (tycon, ty_args) <- splitTyConApp_maybe scrut_ty - , isAlgTyCon tycon - = vectAlgCase tycon ty_args scrut bndr ty alts - | otherwise - = do - { dflags <- getDynFlags - ; cantVectorise dflags "Can't vectorise expression (no algebraic type constructor)" $ - ppr scrut_ty - } - where - scrut_ty = exprType (deAnnotate scrut) - -vectExpr (_, AnnLet (AnnNonRec bndr rhs) body) - = do - { traceVt "let binding (non-recursive)" Outputable.empty - ; vrhs <- localV $ - inBind bndr $ - vectAnnPolyExpr False rhs - ; traceVt "let body (non-recursive)" Outputable.empty - ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) - ; return $ vLet (vNonRec vbndr vrhs) vbody - } - -vectExpr (_, AnnLet (AnnRec bs) body) - = do - { (vbndrs, (vrhss, vbody)) <- vectBndrsIn bndrs $ do - { traceVt "let bindings (recursive)" Outputable.empty - ; vrhss <- zipWithM vect_rhs bndrs rhss - ; traceVt "let body (recursive)" Outputable.empty - ; vbody <- vectExpr body - ; return (vrhss, vbody) - } - ; return $ vLet (vRec vbndrs vrhss) vbody - } - where - (bndrs, rhss) = unzip bs - - vect_rhs bndr rhs = localV $ - inBind bndr $ - vectAnnPolyExpr (isStrongLoopBreaker $ idOccInfo bndr) rhs - -vectExpr (_, AnnTick tickish expr) - = vTick tickish <$> vectExpr expr - -vectExpr (_, AnnType ty) - = vType <$> vectType ty - -vectExpr e - = do - { dflags <- getDynFlags - ; cantVectorise dflags "Can't vectorise expression (vectExpr)" $ ppr (deAnnotate e) - } - --- |Vectorise an expression that *may* have an outer lambda abstraction. If the expression is marked --- as encapsulated ('VIEncaps'), vectorise it as a scalar computation (using a generalised scalar --- zip). --- --- We do not handle type variables at this point, as they will already have been stripped off by --- 'vectPolyExpr'. We also only have to worry about one set of dictionary arguments as we (1) only --- deal with Haskell 2011 and (2) class selectors are vectorised elsewhere. --- -vectFnExpr :: Bool -- ^If we process the RHS of a binding, whether that binding - -- should be inlined - -> Bool -- ^Whether the binding is a loop breaker - -> CoreExprWithVectInfo -- ^Expression to vectorise; must have an outer `AnnLam` - -> VM VExpr -vectFnExpr inline loop_breaker aexpr@(_ann, AnnLam bndr body) - -- predicate abstraction: leave as a normal abstraction, but vectorise the predicate type - | isId bndr - && isPredTy (idType bndr) - = do - { vBndr <- vectBndr bndr - ; vbody <- vectFnExpr inline loop_breaker body - ; return $ mapVect (mkLams [vectorised vBndr]) vbody - } - -- encapsulated non-predicate abstraction: vectorise as a scalar computation - | isId bndr && isVIEncaps aexpr - = vectScalarFun . deAnnotate $ aexpr - -- non-predicate abstraction: vectorise as a non-scalar computation - | isId bndr - = vectLam inline loop_breaker aexpr - | otherwise - = do - { dflags <- getDynFlags - ; cantVectorise dflags "Vectorise.Exp.vectFnExpr: Unexpected type lambda" $ - ppr (deAnnotate aexpr) - } -vectFnExpr _ _ aexpr - -- encapsulated function: vectorise as a scalar computation - | (isFunTy . annExprType $ aexpr) && isVIEncaps aexpr - = vectScalarFun . deAnnotate $ aexpr - | otherwise - -- not an abstraction: vectorise as a non-scalar vanilla expression - -- NB: we can get here due to the recursion in the first case above and from 'vectAnnPolyExpr' - = vectExpr aexpr - --- |Vectorise type and dictionary applications. --- --- These are always headed by a variable (as we don't support higher-rank polymorphism), but may --- involve two sets of type variables and dictionaries. Consider, --- --- > class C a where --- > m :: D b => b -> a --- --- The type of 'm' is 'm :: forall a. C a => forall b. D b => b -> a'. --- -vectPolyApp :: CoreExprWithVectInfo -> VM VExpr -vectPolyApp e0 - = case e4 of - (_, AnnVar var) - -> do { -- get the vectorised form of the variable - ; vVar <- lookupVar var - ; traceVt "vectPolyApp of" (ppr var) - - -- vectorise type and dictionary arguments - ; vDictsOuter <- mapM vectDictExpr (map deAnnotate dictsOuter) - ; vDictsInner <- mapM vectDictExpr (map deAnnotate dictsInner) - ; vTysOuter <- mapM vectType tysOuter - ; vTysInner <- mapM vectType tysInner - - ; let reconstructOuter v = (`mkApps` vDictsOuter) <$> polyApply v vTysOuter - - ; case vVar of - Local (vv, lv) - -> do { MASSERT( null dictsInner ) -- local vars cannot be class selectors - ; traceVt " LOCAL" (text "") - ; (,) <$> reconstructOuter (Var vv) <*> reconstructOuter (Var lv) - } - Global vv - | isDictComp var -- dictionary computation - -> do { -- in a dictionary computation, the innermost, non-empty set of - -- arguments are non-vectorised arguments, where no 'PA'dictionaries - -- are needed for the type variables - ; ve <- if null dictsInner - then - return $ Var vv `mkTyApps` vTysOuter `mkApps` vDictsOuter - else - reconstructOuter - (Var vv `mkTyApps` vTysInner `mkApps` vDictsInner) - ; traceVt " GLOBAL (dict):" (ppr ve) - ; vectConst ve - } - | otherwise -- non-dictionary computation - -> do { MASSERT( null dictsInner ) - ; ve <- reconstructOuter (Var vv) - ; traceVt " GLOBAL (non-dict):" (ppr ve) - ; vectConst ve - } - } - _ -> pprSorry "Cannot vectorise programs with higher-rank types:" (ppr . deAnnotate $ e0) - where - -- if there is only one set of variables or dictionaries, it will be the outer set - (e1, dictsOuter) = collectAnnDictArgs e0 - (e2, tysOuter) = collectAnnTypeArgs e1 - (e3, dictsInner) = collectAnnDictArgs e2 - (e4, tysInner) = collectAnnTypeArgs e3 - -- - isDictComp var = (isJust . isClassOpId_maybe $ var) || isDFunId var - --- |Vectorise the body of a dfun. --- --- Dictionary computations are special for the following reasons. The application of dictionary --- functions are always saturated, so there is no need to create closures. Dictionary computations --- don't depend on array values, so they are always scalar computations whose result we can --- replicate (instead of executing them in parallel). --- --- NB: To keep things simple, we are not rewriting any of the bindings introduced in a dictionary --- computation. Consequently, the variable case needs to deal with cases where binders are --- in the vectoriser environments and where that is not the case. --- -vectDictExpr :: CoreExpr -> VM CoreExpr -vectDictExpr (Var var) - = do { mb_scope <- lookupVar_maybe var - ; case mb_scope of - Nothing -> return $ Var var -- binder from within the dict. computation - Just (Local (vVar, _)) -> return $ Var vVar -- local vectorised variable - Just (Global vVar) -> return $ Var vVar -- global vectorised variable - } -vectDictExpr (Lit lit) - = pprPanic "Vectorise.Exp.vectDictExpr: literal in dictionary computation" (ppr lit) -vectDictExpr (Lam bndr e) - = Lam bndr <$> vectDictExpr e -vectDictExpr (App fn arg) - = App <$> vectDictExpr fn <*> vectDictExpr arg -vectDictExpr (Case e bndr ty alts) - = Case <$> vectDictExpr e <*> pure bndr <*> vectType ty <*> mapM vectDictAlt alts - where - vectDictAlt (con, bs, e) = (,,) <$> vectDictAltCon con <*> pure bs <*> vectDictExpr e - -- - vectDictAltCon (DataAlt datacon) = DataAlt <$> maybeV dataConErr (lookupDataCon datacon) - where - dataConErr = text "Cannot vectorise data constructor:" <+> ppr datacon - vectDictAltCon (LitAlt lit) = return $ LitAlt lit - vectDictAltCon DEFAULT = return DEFAULT -vectDictExpr (Let bnd body) - = Let <$> vectDictBind bnd <*> vectDictExpr body - where - vectDictBind (NonRec bndr e) = NonRec bndr <$> vectDictExpr e - vectDictBind (Rec bnds) = Rec <$> mapM (\(bndr, e) -> (bndr,) <$> vectDictExpr e) bnds -vectDictExpr e@(Cast _e _coe) - = pprSorry "Vectorise.Exp.vectDictExpr: cast" (ppr e) -vectDictExpr (Tick tickish e) - = Tick tickish <$> vectDictExpr e -vectDictExpr (Type ty) - = Type <$> vectType ty -vectDictExpr (Coercion coe) - = pprSorry "Vectorise.Exp.vectDictExpr: coercion" (ppr coe) - --- |Vectorise an expression of functional type, where all arguments and the result are of primitive --- types (i.e., 'Int', 'Float', 'Double' etc., which have instances of the 'Scalar' type class) and --- which does not contain any subcomputations that involve parallel arrays. Such functionals do not --- require the full blown vectorisation transformation; instead, they can be lifted by application --- of a member of the zipWith family (i.e., 'map', 'zipWith', zipWith3', etc.) --- --- Dictionary functions are also scalar functions (as dictionaries themselves are not vectorised, --- instead they become dictionaries of vectorised methods). We treat them differently, though see --- "Note [Scalar dfuns]" in 'Vectorise'. --- -vectScalarFun :: CoreExpr -> VM VExpr -vectScalarFun expr - = do - { traceVt "vectScalarFun:" (ppr expr) - ; let (arg_tys, res_ty) = splitFunTys (exprType expr) - ; mkScalarFun arg_tys res_ty expr - } - --- Generate code for a scalar function by generating a scalar closure. If the function is a --- dictionary function, vectorise it as dictionary code. --- -mkScalarFun :: [Type] -> Type -> CoreExpr -> VM VExpr -mkScalarFun arg_tys res_ty expr - | isPredTy res_ty - = do { vExpr <- vectDictExpr expr - ; return (vExpr, unused) - } - | otherwise - = do { traceVt "mkScalarFun: " $ ppr expr $$ text " ::" <+> - ppr (mkFunTys arg_tys res_ty) - - ; fn_var <- hoistExpr (fsLit "fn") expr DontInline - ; zipf <- zipScalars arg_tys res_ty - ; clo <- scalarClosure arg_tys res_ty (Var fn_var) (zipf `App` Var fn_var) - ; clo_var <- hoistExpr (fsLit "clo") clo DontInline - ; lclo <- liftPD (Var clo_var) - ; return (Var clo_var, lclo) - } - where - unused = error "Vectorise.Exp.mkScalarFun: we don't lift dictionary expressions" - --- |Vectorise a dictionary function that has a 'VECTORISE SCALAR instance' pragma. --- --- In other words, all methods in that dictionary are scalar functions — to be vectorised with --- 'vectScalarFun'. The dictionary "function" itself may be a constant, though. --- --- NB: You may think that we could implement this function guided by the struture of the Core --- expression of the right-hand side of the dictionary function. We cannot proceed like this as --- 'vectScalarDFun' must also work for *imported* dfuns, where we don't necessarily have access --- to the Core code of the unvectorised dfun. --- --- Here an example — assume, --- --- > class Eq a where { (==) :: a -> a -> Bool } --- > instance (Eq a, Eq b) => Eq (a, b) where { (==) = ... } --- > {-# VECTORISE SCALAR instance Eq (a, b) } --- --- The unvectorised dfun for the above instance has the following signature: --- --- > $dEqPair :: forall a b. Eq a -> Eq b -> Eq (a, b) --- --- We generate the following (scalar) vectorised dfun (liberally using TH notation): --- --- > $v$dEqPair :: forall a b. V:Eq a -> V:Eq b -> V:Eq (a, b) --- > $v$dEqPair = /\a b -> \dEqa :: V:Eq a -> \dEqb :: V:Eq b -> --- > D:V:Eq $(vectScalarFun True recFns --- > [| (==) @(a, b) ($dEqPair @a @b $(unVect dEqa) $(unVect dEqb)) |]) --- --- NB: --- * '(,)' vectorises to '(,)' — hence, the type constructor in the result type remains the same. --- * We share the '$(unVect di)' sub-expressions between the different selectors, but duplicate --- the application of the unvectorised dfun, to enable the dictionary selection rules to fire. --- -vectScalarDFun :: Var -- ^ Original dfun - -> VM CoreExpr -vectScalarDFun var - = do { -- bring the type variables into scope - ; mapM_ defLocalTyVar tvs - - -- vectorise dictionary argument types and generate variables for them - ; vTheta <- mapM vectType theta - ; vThetaBndr <- mapM (newLocalVar (fsLit "vd")) vTheta - ; let vThetaVars = varsToCoreExprs vThetaBndr - - -- vectorise superclass dictionaries and methods as scalar expressions - ; thetaVars <- mapM (newLocalVar (fsLit "d")) theta - ; thetaExprs <- zipWithM unVectDict theta vThetaVars - ; let thetaDictBinds = zipWith NonRec thetaVars thetaExprs - dict = Var var `mkTyApps` (mkTyVarTys tvs) `mkVarApps` thetaVars - scsOps = map (\selId -> varToCoreExpr selId `mkTyApps` tys `mkApps` [dict]) - selIds - ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun e) scsOps - - -- vectorised applications of the class-dictionary data constructor - ; Just vDataCon <- lookupDataCon dataCon - ; vTys <- mapM vectType tys - ; let vBody = thetaDictBinds `mkLets` mkCoreConApps vDataCon (map Type vTys ++ vScsOps) - - ; return $ mkLams (tvs ++ vThetaBndr) vBody - } - where - ty = varType var - (tvs, theta, pty) = tcSplitSigmaTy ty -- 'theta' is the instance context - (cls, tys) = tcSplitDFunHead pty -- 'pty' is the instance head - selIds = classAllSelIds cls - dataCon = classDataCon cls - --- Build a value of the dictionary before vectorisation from original, unvectorised type and an --- expression computing the vectorised dictionary. --- --- Given the vectorised version of a dictionary 'vd :: V:C vt1..vtn', generate code that computes --- the unvectorised version, thus: --- --- > D:C op1 .. opm --- > where --- > opi = $(fromVect opTyi [| vSeli @vt1..vtk vd |]) --- --- where 'opTyi' is the type of the i-th superclass or op of the unvectorised dictionary. --- -unVectDict :: Type -> CoreExpr -> VM CoreExpr -unVectDict ty e - = do { vTys <- mapM vectType tys - ; let meths = map (\sel -> Var sel `mkTyApps` vTys `mkApps` [e]) selIds - ; scOps <- zipWithM fromVect methTys meths - ; return $ mkCoreConApps dataCon (map Type tys ++ scOps) - } - where - (tycon, tys) = splitTyConApp ty - Just dataCon = isDataProductTyCon_maybe tycon - Just cls = tyConClass_maybe tycon - methTys = dataConInstArgTys dataCon tys - selIds = classAllSelIds cls - --- Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures. --- --- All non-dictionary free variables go into the closure's environment, whereas the dictionary --- variables are passed explicit (as conventional arguments) into the body during closure --- construction. --- -vectLam :: Bool -- ^ Should the RHS of a binding be inlined? - -> Bool -- ^ Whether the binding is a loop breaker. - -> CoreExprWithVectInfo -- ^ Body of abstraction. - -> VM VExpr -vectLam inline loop_breaker expr@((fvs, _vi), AnnLam _ _) - = do { traceVt "fully vectorise a lambda expression" (ppr . deAnnotate $ expr) - - ; let (bndrs, body) = collectAnnValBinders expr - - -- grab the in-scope type variables - ; tyvars <- localTyVars - - -- collect and vectorise all /local/ free variables - ; vfvs <- readLEnv $ \env -> - [ (var, fromJust mb_vv) - | var <- dVarSetElems fvs - , let mb_vv = lookupVarEnv (local_vars env) var - , isJust mb_vv -- its local == is in local var env - ] - -- separate dictionary from non-dictionary variables in the free variable set - ; let (vvs_dict, vvs_nondict) = partition (isPredTy . varType . fst) vfvs - (_fvs_dict, vfvs_dict) = unzip vvs_dict - (fvs_nondict, vfvs_nondict) = unzip vvs_nondict - - -- compute the type of the vectorised closure - ; arg_tys <- mapM (vectType . idType) bndrs - ; res_ty <- vectType (exprType $ deAnnotate body) - - ; let arity = length fvs_nondict + length bndrs - vfvs_dict' = map vectorised vfvs_dict - ; buildClosures tyvars vfvs_dict' vfvs_nondict arg_tys res_ty - . hoistPolyVExpr tyvars vfvs_dict' (maybe_inline arity) - $ do { -- generate the vectorised body of the lambda abstraction - ; lc <- builtin liftingContext - ; (vbndrs, vbody) <- vectBndrsIn (fvs_nondict ++ bndrs) $ vectExpr body - - ; vbody' <- break_loop lc res_ty vbody - ; return $ vLams lc vbndrs vbody' - } - } - where - maybe_inline n | inline = Inline n - | otherwise = DontInline - - -- If this is the body of a binding marked as a loop breaker, add a recursion termination test - -- to the /lifted/ version of the function body. The termination tests checks if the lifting - -- context is empty. If so, it returns an empty array of the (lifted) result type instead of - -- executing the function body. This is the test from the last line (defining \mathcal{L}') - -- in Figure 6 of HtM. - break_loop lc ty (ve, le) - | loop_breaker - = do { dflags <- getDynFlags - ; empty <- emptyPD ty - ; lty <- mkPDataType ty - ; return (ve, mkWildCase (Var lc) intPrimTy lty - [(DEFAULT, [], le), - (LitAlt (mkMachInt dflags 0), [], empty)]) - } - | otherwise = return (ve, le) -vectLam _ _ _ = panic "Vectorise.Exp.vectLam: not a lambda" - --- Vectorise an algebraic case expression. --- --- We convert --- --- case e :: t of v { ... } --- --- to --- --- V: let v' = e in case v' of _ { ... } --- L: let v' = e in case v' `cast` ... of _ { ... } --- --- When lifting, we have to do it this way because v must have the type --- [:V(T):] but the scrutinee must be cast to the representation type. We also --- have to handle the case where v is a wild var correctly. --- - --- FIXME: this is too lazy...is it? -vectAlgCase :: TyCon -> [Type] -> CoreExprWithVectInfo -> Var -> Type - -> [(AltCon, [Var], CoreExprWithVectInfo)] - -> VM VExpr -vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)] - = do - { traceVt "scrutinee (DEFAULT only)" Outputable.empty - ; vscrut <- vectExpr scrut - ; (vty, lty) <- vectAndLiftType ty - ; traceVt "alternative body (DEFAULT only)" Outputable.empty - ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) - ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody - } -vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)] - = do - { traceVt "scrutinee (one shot w/o binders)" Outputable.empty - ; vscrut <- vectExpr scrut - ; (vty, lty) <- vectAndLiftType ty - ; traceVt "alternative body (one shot w/o binders)" Outputable.empty - ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) - ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody - } -vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)] - = do - { traceVt "scrutinee (one shot w/ binders)" Outputable.empty - ; vexpr <- vectExpr scrut - ; (vty, lty) <- vectAndLiftType ty - ; traceVt "alternative body (one shot w/ binders)" Outputable.empty - ; (vbndr, (vbndrs, (vect_body, lift_body))) - <- vect_scrut_bndr - . vectBndrsIn bndrs - $ vectExpr body - ; let (vect_bndrs, lift_bndrs) = unzip vbndrs - ; (vscrut, lscrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr) - ; vect_dc <- maybeV dataConErr (lookupDataCon dc) - - ; let vcase = mk_wild_case vscrut vty vect_dc vect_bndrs vect_body - lcase = mk_wild_case lscrut lty pdata_dc lift_bndrs lift_body - - ; return $ vLet (vNonRec vbndr vexpr) (vcase, lcase) - } - where - vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut") - | otherwise = vectBndrIn bndr - - mk_wild_case expr ty dc bndrs body - = mkWildCase expr (exprType expr) ty [(DataAlt dc, bndrs, body)] - - dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc) - -vectAlgCase tycon _ty_args scrut bndr ty alts - = do - { traceVt "scrutinee (general case)" Outputable.empty - ; vexpr <- vectExpr scrut - - ; vect_tc <- vectTyCon tycon - ; (vty, lty) <- vectAndLiftType ty - - ; let arity = length (tyConDataCons vect_tc) - ; sel_ty <- builtin (selTy arity) - ; sel_bndr <- newLocalVar (fsLit "sel") sel_ty - ; let sel = Var sel_bndr - - ; traceVt "alternatives' body (general case)" Outputable.empty - ; (vbndr, valts) <- vect_scrut_bndr - $ mapM (proc_alt arity sel vty lty) alts' - ; let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts - - ; (vect_scrut, lift_scrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr) - - ; let (vect_bodies, lift_bodies) = unzip vbodies - - ; vdummy <- newDummyVar (exprType vect_scrut) - ; ldummy <- newDummyVar (exprType lift_scrut) - ; let vect_case = Case vect_scrut vdummy vty - (zipWith3 mk_vect_alt vect_dcs vect_bndrss vect_bodies) - - ; lc <- builtin liftingContext - ; lbody <- combinePD vty (Var lc) sel lift_bodies - ; let lift_case = Case lift_scrut ldummy lty - [(DataAlt pdata_dc, sel_bndr : concat lift_bndrss, - lbody)] - - ; return . vLet (vNonRec vbndr vexpr) - $ (vect_case, lift_case) - } - where - vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut") - | otherwise = vectBndrIn bndr - - alts' = sortBy (\(alt1, _, _) (alt2, _, _) -> cmp alt1 alt2) alts - - cmp (DataAlt dc1) (DataAlt dc2) = dataConTag dc1 `compare` dataConTag dc2 - cmp DEFAULT DEFAULT = EQ - cmp DEFAULT _ = LT - cmp _ DEFAULT = GT - cmp _ _ = panic "vectAlgCase/cmp" - - proc_alt arity sel _ lty (DataAlt dc, bndrs, body@((fvs_body, _), _)) - = do - dflags <- getDynFlags - vect_dc <- maybeV dataConErr (lookupDataCon dc) - let ntag = dataConTagZ vect_dc - tag = mkDataConTag dflags vect_dc - fvs = fvs_body `delDVarSetList` bndrs - - sel_tags <- liftM (`App` sel) (builtin (selTags arity)) - lc <- builtin liftingContext - elems <- builtin (selElements arity ntag) - - (vbndrs, vbody) - <- vectBndrsIn bndrs - . localV - $ do - { binds <- mapM (pack_var (Var lc) sel_tags tag) - . filter isLocalId - $ dVarSetElems fvs - ; traceVt "case alternative:" (ppr . deAnnotate $ body) - ; (ve, le) <- vectExpr body - ; return (ve, Case (elems `App` sel) lc lty - [(DEFAULT, [], (mkLets (concat binds) le))]) - } - -- empty <- emptyPD vty - -- return (ve, Case (elems `App` sel) lc lty - -- [(DEFAULT, [], Let (NonRec flags_var flags_expr) - -- $ mkLets (concat binds) le), - -- (LitAlt (mkMachInt 0), [], empty)]) - let (vect_bndrs, lift_bndrs) = unzip vbndrs - return (vect_dc, vect_bndrs, lift_bndrs, vbody) - where - dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc) - - proc_alt _ _ _ _ _ = panic "vectAlgCase/proc_alt" - - mk_vect_alt vect_dc bndrs body = (DataAlt vect_dc, bndrs, body) - - -- Pack a variable for a case alternative context *if* the variable is vectorised. If it - -- isn't, ignore it as scalar variables don't need to be packed. - pack_var len tags t v - = do - { r <- lookupVar_maybe v - ; case r of - Just (Local (vv, lv)) -> - do - { lv' <- cloneVar lv - ; expr <- packByTagPD (idType vv) (Var lv) len tags t - ; updLEnv (\env -> env { local_vars = extendVarEnv (local_vars env) v (vv, lv') }) - ; return [(NonRec lv' expr)] - } - _ -> return [] - } - - --- Support to compute information for vectorisation avoidance ------------------ - --- Annotation for Core AST nodes that describes how they should be handled during vectorisation --- and especially if vectorisation of the corresponding computation can be avoided. --- -data VectAvoidInfo = VIParr -- tree contains parallel computations - | VISimple -- result type is scalar & no parallel subcomputation - | VIComplex -- any result type, no parallel subcomputation - | VIEncaps -- tree encapsulated by 'liftSimple' - | VIDict -- dictionary computation (never parallel) - deriving (Eq, Show) - --- Core expression annotated with free variables and vectorisation-specific information. --- -type CoreExprWithVectInfo = AnnExpr Id (DVarSet, VectAvoidInfo) - --- Yield the type of an annotated core expression. --- -annExprType :: AnnExpr Var ann -> Type -annExprType = exprType . deAnnotate - --- Project the vectorisation information from an annotated Core expression. --- -vectAvoidInfoOf :: CoreExprWithVectInfo -> VectAvoidInfo -vectAvoidInfoOf ((_, vi), _) = vi - --- Is this a 'VIParr' node? --- -isVIParr :: CoreExprWithVectInfo -> Bool -isVIParr = (== VIParr) . vectAvoidInfoOf - --- Is this a 'VIEncaps' node? --- -isVIEncaps :: CoreExprWithVectInfo -> Bool -isVIEncaps = (== VIEncaps) . vectAvoidInfoOf - --- Is this a 'VIDict' node? --- -isVIDict :: CoreExprWithVectInfo -> Bool -isVIDict = (== VIDict) . vectAvoidInfoOf - --- 'VIParr' if either argument is 'VIParr'; otherwise, the first argument. --- -unlessVIParr :: VectAvoidInfo -> VectAvoidInfo -> VectAvoidInfo -unlessVIParr _ VIParr = VIParr -unlessVIParr vi _ = vi - --- 'VIParr' if either arguments vectorisation information is 'VIParr'; otherwise, the vectorisation --- information of the first argument is produced. --- -unlessVIParrExpr :: VectAvoidInfo -> CoreExprWithVectInfo -> VectAvoidInfo -infixl `unlessVIParrExpr` -unlessVIParrExpr e1 e2 = e1 `unlessVIParr` vectAvoidInfoOf e2 - --- Compute Core annotations to determine for which subexpressions we can avoid vectorisation. --- --- * The first argument is the set of free, local variables whose evaluation may entail parallelism. --- -vectAvoidInfo :: VarSet -> CoreExprWithFVs -> VM CoreExprWithVectInfo -vectAvoidInfo pvs ce@(_, AnnVar v) - = do - { gpvs <- globalParallelVars - ; vi <- if v `elemVarSet` pvs || v `elemDVarSet` gpvs - then return VIParr - else vectAvoidInfoTypeOf ce - ; viTrace ce vi [] - ; when (vi == VIParr) $ - traceVt " reason:" $ if v `elemVarSet` pvs then text "local" else - if v `elemDVarSet` gpvs then text "global" else text "parallel type" - - ; return ((fvs, vi), AnnVar v) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo _pvs ce@(_, AnnLit lit) - = do - { vi <- vectAvoidInfoTypeOf ce - ; viTrace ce vi [] - ; return ((fvs, vi), AnnLit lit) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo pvs ce@(_, AnnApp e1 e2) - = do - { ceVI <- vectAvoidInfoTypeOf ce - ; eVI1 <- vectAvoidInfo pvs e1 - ; eVI2 <- vectAvoidInfo pvs e2 - ; let vi = ceVI `unlessVIParrExpr` eVI1 `unlessVIParrExpr` eVI2 - -- ; viTrace ce vi [eVI1, eVI2] - ; return ((fvs, vi), AnnApp eVI1 eVI2) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo pvs ce@(_, AnnLam var body) - = do - { bodyVI <- vectAvoidInfo pvs body - ; varVI <- vectAvoidInfoType $ varType var - ; let vi = vectAvoidInfoOf bodyVI `unlessVIParr` varVI - -- ; viTrace ce vi [bodyVI] - ; return ((fvs, vi), AnnLam var bodyVI) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo pvs ce@(_, AnnLet (AnnNonRec var e) body) - = do - { ceVI <- vectAvoidInfoTypeOf ce - ; eVI <- vectAvoidInfo pvs e - ; isScalarTy <- isScalar $ varType var - ; (bodyVI, vi) <- if isVIParr eVI && not isScalarTy - then do -- binding is parallel - { bodyVI <- vectAvoidInfo (pvs `extendVarSet` var) body - ; return (bodyVI, VIParr) - } - else do -- binding doesn't affect parallelism - { bodyVI <- vectAvoidInfo pvs body - ; return (bodyVI, ceVI `unlessVIParrExpr` bodyVI) - } - -- ; viTrace ce vi [eVI, bodyVI] - ; return ((fvs, vi), AnnLet (AnnNonRec var eVI) bodyVI) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo pvs ce@(_, AnnLet (AnnRec bnds) body) - = do - { ceVI <- vectAvoidInfoTypeOf ce - ; bndsVI <- mapM (vectAvoidInfoBnd pvs) bnds - ; parrBndrs <- map fst <$> filterM isVIParrBnd bndsVI - ; if not . null $ parrBndrs - then do -- body may trigger parallelism via at least one binding - { new_pvs <- filterM ((not <$>) . isScalar . varType) parrBndrs - ; let extendedPvs = pvs `extendVarSetList` new_pvs - ; bndsVI <- mapM (vectAvoidInfoBnd extendedPvs) bnds - ; bodyVI <- vectAvoidInfo extendedPvs body - -- ; viTrace ce VIParr (map snd bndsVI ++ [bodyVI]) - ; return ((fvs, VIParr), AnnLet (AnnRec bndsVI) bodyVI) - } - else do -- demanded bindings cannot trigger parallelism - { bodyVI <- vectAvoidInfo pvs body - ; let vi = ceVI `unlessVIParrExpr` bodyVI - -- ; viTrace ce vi (map snd bndsVI ++ [bodyVI]) - ; return ((fvs, vi), AnnLet (AnnRec bndsVI) bodyVI) - } - } - where - fvs = freeVarsOf ce - vectAvoidInfoBnd pvs (var, e) = (var,) <$> vectAvoidInfo pvs e - - isVIParrBnd (var, eVI) - = do - { isScalarTy <- isScalar (varType var) - ; return $ isVIParr eVI && not isScalarTy - } - -vectAvoidInfo pvs ce@(_, AnnCase e var ty alts) - = do - { ceVI <- vectAvoidInfoTypeOf ce - ; eVI <- vectAvoidInfo pvs e - ; altsVI <- mapM (vectAvoidInfoAlt (isVIParr eVI)) alts - ; let alteVIs = [eVI | (_, _, eVI) <- altsVI] - vi = foldl unlessVIParrExpr ceVI (eVI:alteVIs) -- NB: same effect as in the paper - -- ; viTrace ce vi (eVI : alteVIs) - ; return ((fvs, vi), AnnCase eVI var ty altsVI) - } - where - fvs = freeVarsOf ce - vectAvoidInfoAlt scrutIsPar (con, bndrs, e) - = do - { allScalar <- allScalarVarType bndrs - ; let altPvs | scrutIsPar && not allScalar = pvs `extendVarSetList` bndrs - | otherwise = pvs - ; (con, bndrs,) <$> vectAvoidInfo altPvs e - } - -vectAvoidInfo pvs ce@(_, AnnCast e (fvs_ann, ann)) - = do - { eVI <- vectAvoidInfo pvs e - ; return ((fvs, vectAvoidInfoOf eVI), AnnCast eVI ((freeVarsOfAnn fvs_ann, VISimple), ann)) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo pvs ce@(_, AnnTick tick e) - = do - { eVI <- vectAvoidInfo pvs e - ; return ((fvs, vectAvoidInfoOf eVI), AnnTick tick eVI) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo _pvs ce@(_, AnnType ty) - = return ((fvs, VISimple), AnnType ty) - where - fvs = freeVarsOf ce - -vectAvoidInfo _pvs ce@(_, AnnCoercion coe) - = return ((fvs, VISimple), AnnCoercion coe) - where - fvs = freeVarsOf ce - --- Compute vectorisation avoidance information for a type. --- -vectAvoidInfoType :: Type -> VM VectAvoidInfo -vectAvoidInfoType ty - | isPredTy ty - = return VIDict - | Just (arg, res) <- splitFunTy_maybe ty - = do - { argVI <- vectAvoidInfoType arg - ; resVI <- vectAvoidInfoType res - ; case (argVI, resVI) of - (VISimple, VISimple) -> return VISimple -- NB: diverts from the paper: scalar functions - (_ , VIDict) -> return VIDict - _ -> return $ VIComplex `unlessVIParr` argVI `unlessVIParr` resVI - } - | otherwise - = do - { parr <- maybeParrTy ty - ; if parr - then return VIParr - else do - { scalar <- isScalar ty - ; if scalar - then return VISimple - else return VIComplex - } } - --- Compute vectorisation avoidance information for the type of a Core expression (with FVs). --- -vectAvoidInfoTypeOf :: AnnExpr Var ann -> VM VectAvoidInfo -vectAvoidInfoTypeOf = vectAvoidInfoType . annExprType - --- Checks whether the type might be a parallel array type. --- -maybeParrTy :: Type -> VM Bool -maybeParrTy ty - -- looking through newtypes - | Just ty' <- coreView ty - = (== VIParr) <$> vectAvoidInfoType ty' - -- decompose constructor applications - | Just (tc, ts) <- splitTyConApp_maybe ty - = do - { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons - ; if isParallel - then return True - else or <$> mapM maybeParrTy ts - } - -- must be a Named ForAllTy because anon ones respond to splitTyConApp_maybe -maybeParrTy (ForAllTy _ ty) = maybeParrTy ty -maybeParrTy _ = return False - --- Are the types of all variables in the 'Scalar' class or toplevel variables? --- --- NB: 'liftSimple' does not abstract over toplevel variables. --- -allScalarVarType :: [Var] -> VM Bool -allScalarVarType vs = and <$> mapM isScalarOrToplevel vs - where - isScalarOrToplevel v | isToplevel v = return True - | otherwise = isScalar (varType v) - --- Are the types of all variables in the set in the 'Scalar' class or toplevel variables? --- -allScalarVarTypeSet :: DVarSet -> VM Bool -allScalarVarTypeSet = allScalarVarType . dVarSetElems - --- Debugging support --- -viTrace :: CoreExprWithFVs -> VectAvoidInfo -> [CoreExprWithVectInfo] -> VM () -viTrace ce vi vTs - = traceVt ("vect info: " ++ show vi ++ "[" ++ - (concat $ map ((++ " ") . show . vectAvoidInfoOf) vTs) ++ "]") - (ppr $ deAnnotate ce) diff --git a/vectorise/Vectorise/Generic/Description.hs b/vectorise/Vectorise/Generic/Description.hs deleted file mode 100644 --- a/vectorise/Vectorise/Generic/Description.hs +++ /dev/null @@ -1,292 +0,0 @@ --- |Compute a description of the generic representation that we use for a user defined data type. --- --- During vectorisation, we generate a PRepr and PA instance for each user defined --- data type. The PA dictionary contains methods to convert the user type to and --- from our generic representation. This module computes a description of what --- that generic representation is. --- -module Vectorise.Generic.Description - ( CompRepr(..) - , ProdRepr(..) - , ConRepr(..) - , SumRepr(..) - , tyConRepr - , sumReprType - , compOrigType - ) -where - -import Vectorise.Utils -import Vectorise.Monad -import Vectorise.Builtins - -import CoreSyn -import DataCon -import TyCon -import Type -import Control.Monad -import Outputable - - --- | Describes the generic representation of a data type. --- If the data type has multiple constructors then we bundle them --- together into a generic sum type. -data SumRepr - = -- | Data type has no data constructors. - EmptySum - - -- | Data type has a single constructor. - | UnarySum ConRepr - - -- | Data type has multiple constructors. - | Sum { -- | Representation tycon for the sum (eg Sum2) - repr_sum_tc :: TyCon - - -- | PData version of the sum tycon (eg PDataSum2) - -- This TyCon doesn't appear explicitly in the source program. - -- See Note [PData TyCons]. - , repr_psum_tc :: TyCon - - -- | PDatas version of the sum tycon (eg PDatasSum2) - , repr_psums_tc :: TyCon - - -- | Type of the selector (eg Sel2) - , repr_sel_ty :: Type - - -- | Type of multi-selector (eg Sel2s) - , repr_sels_ty :: Type - - -- | Function to get the length of a Sels of this type. - , repr_selsLength_v :: CoreExpr - - -- | Type of each data constructor. - , repr_con_tys :: [Type] - - -- | Generic representation types of each data constructor. - , repr_cons :: [ConRepr] - } - - --- | Describes the representation type of a data constructor. -data ConRepr - = ConRepr - { repr_dc :: DataCon - , repr_prod :: ProdRepr - } - --- | Describes the representation type of the fields \/ components of a constructor. --- If the data constructor has multiple fields then we bundle them --- together into a generic product type. -data ProdRepr - = -- | Data constructor has no fields. - EmptyProd - - -- | Data constructor has a single field. - | UnaryProd CompRepr - - -- | Data constructor has several fields. - | Prod { -- | Representation tycon for the product (eg Tuple2) - repr_tup_tc :: TyCon - - -- | PData version of the product tycon (eg PDataTuple2) - , repr_ptup_tc :: TyCon - - -- | PDatas version of the product tycon (eg PDatasTuple2s) - -- Not all lifted backends use `PDatas`. - , repr_ptups_tc :: TyCon - - -- | Types of each field. - , repr_comp_tys :: [Type] - - -- | Generic representation types for each field. - , repr_comps :: [CompRepr] - } - - --- | Describes the representation type of a data constructor field. -data CompRepr - = Keep Type - CoreExpr -- PR dictionary for the type - | Wrap Type - - -------------------------------------------------------------------------------- - --- |Determine the generic representation of a data type, given its tycon. --- -tyConRepr :: TyCon -> VM SumRepr -tyConRepr tc - = sum_repr (tyConDataCons tc) - where - -- Build the representation type for a data type with the given constructors. - -- The representation types for each individual constructor are bundled - -- together into a generic sum type. - sum_repr :: [DataCon] -> VM SumRepr - sum_repr [] = return EmptySum - sum_repr [con] = liftM UnarySum (con_repr con) - sum_repr cons - = do let arity = length cons - rs <- mapM con_repr cons - tys <- mapM conReprType rs - - -- Get the 'Sum' tycon of this arity (eg Sum2). - sum_tc <- builtin (sumTyCon arity) - - -- Get the 'PData' and 'PDatas' tycons for the sum. - psum_tc <- pdataReprTyConExact sum_tc - psums_tc <- pdatasReprTyConExact sum_tc - - sel_ty <- builtin (selTy arity) - sels_ty <- builtin (selsTy arity) - selsLength_v <- builtin (selsLength arity) - return $ Sum - { repr_sum_tc = sum_tc - , repr_psum_tc = psum_tc - , repr_psums_tc = psums_tc - , repr_sel_ty = sel_ty - , repr_sels_ty = sels_ty - , repr_selsLength_v = selsLength_v - , repr_con_tys = tys - , repr_cons = rs - } - - -- Build the representation type for a single data constructor. - con_repr con = liftM (ConRepr con) (prod_repr (dataConRepArgTys con)) - - -- Build the representation type for the fields of a data constructor. - -- The representation types for each individual field are bundled - -- together into a generic product type. - prod_repr :: [Type] -> VM ProdRepr - prod_repr [] = return EmptyProd - prod_repr [ty] = liftM UnaryProd (comp_repr ty) - prod_repr tys - = do let arity = length tys - rs <- mapM comp_repr tys - tys' <- mapM compReprType rs - - -- Get the Prod \/ Tuple tycon of this arity (eg Tuple2) - tup_tc <- builtin (prodTyCon arity) - - -- Get the 'PData' and 'PDatas' tycons for the product. - ptup_tc <- pdataReprTyConExact tup_tc - ptups_tc <- pdatasReprTyConExact tup_tc - - return $ Prod - { repr_tup_tc = tup_tc - , repr_ptup_tc = ptup_tc - , repr_ptups_tc = ptups_tc - , repr_comp_tys = tys' - , repr_comps = rs - } - - -- Build the representation type for a single data constructor field. - comp_repr ty = liftM (Keep ty) (prDictOfReprType ty) - `orElseV` return (Wrap ty) - --- |Yield the type of this sum representation. --- -sumReprType :: SumRepr -> VM Type -sumReprType EmptySum = voidType -sumReprType (UnarySum r) = conReprType r -sumReprType (Sum { repr_sum_tc = sum_tc, repr_con_tys = tys }) - = return $ mkTyConApp sum_tc tys - --- Yield the type of this constructor representation. --- -conReprType :: ConRepr -> VM Type -conReprType (ConRepr _ r) = prodReprType r - --- Yield the type of of this product representation. --- -prodReprType :: ProdRepr -> VM Type -prodReprType EmptyProd = voidType -prodReprType (UnaryProd r) = compReprType r -prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys }) - = return $ mkTyConApp tup_tc tys - --- Yield the type of this data constructor field \/ component representation. --- -compReprType :: CompRepr -> VM Type -compReprType (Keep ty _) = return ty -compReprType (Wrap ty) = mkWrapType ty - --- |Yield the original component type of a data constructor component representation. --- -compOrigType :: CompRepr -> Type -compOrigType (Keep ty _) = ty -compOrigType (Wrap ty) = ty - - --- Outputable instances ------------------------------------------------------- -instance Outputable SumRepr where - ppr ss - = case ss of - EmptySum - -> text "EmptySum" - - UnarySum con - -> sep [text "UnarySum", ppr con] - - Sum sumtc psumtc psumstc selty selsty selsLength contys cons - -> text "Sum" $+$ braces (nest 4 - $ sep [ text "repr_sum_tc = " <> ppr sumtc - , text "repr_psum_tc = " <> ppr psumtc - , text "repr_psums_tc = " <> ppr psumstc - , text "repr_sel_ty = " <> ppr selty - , text "repr_sels_ty = " <> ppr selsty - , text "repr_selsLength_v = " <> ppr selsLength - , text "repr_con_tys = " <> ppr contys - , text "repr_cons = " <> ppr cons]) - - -instance Outputable ConRepr where - ppr (ConRepr dc pr) - = text "ConRepr" $+$ braces (nest 4 - $ sep [ text "repr_dc = " <> ppr dc - , text "repr_prod = " <> ppr pr]) - - -instance Outputable ProdRepr where - ppr ss - = case ss of - EmptyProd - -> text "EmptyProd" - - UnaryProd cr - -> sep [text "UnaryProd", ppr cr] - - Prod tuptcs ptuptcs ptupstcs comptys comps - -> sep [text "Prod", ppr tuptcs, ppr ptuptcs, ppr ptupstcs, ppr comptys, ppr comps] - - -instance Outputable CompRepr where - ppr ss - = case ss of - Keep t ce - -> text "Keep" $+$ sep [ppr t, ppr ce] - - Wrap t - -> sep [text "Wrap", ppr t] - - --- Notes ---------------------------------------------------------------------- -{- -Note [PData TyCons] -~~~~~~~~~~~~~~~~~~~ -When PData is a type family, the compiler generates a type constructor for each -instance, which is named after the family and instance type. This type -constructor does not appear in the source program. Rather, it is implicitly -defined by the data instance. For example with: - - data family PData a - - data instance PData (Sum2 a b) - = PSum2 U.Sel2 - (PData a) - (PData b) - -The type constructor corresponding to the instance will be named 'PDataSum2', -and this is what we will get in the repr_psum_tc field of SumRepr.Sum. - --} - diff --git a/vectorise/Vectorise/Generic/PADict.hs b/vectorise/Vectorise/Generic/PADict.hs deleted file mode 100644 --- a/vectorise/Vectorise/Generic/PADict.hs +++ /dev/null @@ -1,126 +0,0 @@ - -module Vectorise.Generic.PADict - ( buildPADict - ) where - -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Generic.Description -import Vectorise.Generic.PAMethods ( buildPAScAndMethods ) -import Vectorise.Utils - -import BasicTypes -import CoreSyn -import CoreUtils -import CoreUnfold -import Module -import TyCon -import CoAxiom -import Type -import Id -import Var -import Name -import FastString - - --- |Build the PA dictionary function for some type and hoist it to top level. --- --- The PA dictionary holds fns that convert values to and from their vectorised representations. --- --- @Recall the definition: --- class PR (PRepr a) => PA a where --- toPRepr :: a -> PRepr a --- fromPRepr :: PRepr a -> a --- toArrPRepr :: PData a -> PData (PRepr a) --- fromArrPRepr :: PData (PRepr a) -> PData a --- toArrPReprs :: PDatas a -> PDatas (PRepr a) --- fromArrPReprs :: PDatas (PRepr a) -> PDatas a --- --- Example: --- df :: forall a. PR (PRepr a) -> PA a -> PA (T a) --- df = /\a. \(c:PR (PRepr a)) (d:PA a). MkPA c ($PR_df a d) ($toPRepr a d) ... --- $dPR_df :: forall a. PA a -> PR (PRepr (T a)) --- $dPR_df = .... --- $toRepr :: forall a. PA a -> T a -> PRepr (T a) --- $toPRepr = ... --- The "..." stuff is filled in by buildPAScAndMethods --- @ --- -buildPADict - :: TyCon -- ^ tycon of the type being vectorised. - -> CoAxiom Unbranched - -- ^ Coercion between the type and - -- its vectorised representation. - -> TyCon -- ^ PData instance tycon - -> TyCon -- ^ PDatas instance tycon - -> SumRepr -- ^ representation used for the type being vectorised. - -> VM Var -- ^ name of the top-level dictionary function. - -buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr - = polyAbstract tvs $ \args -> -- The args are the dictionaries we lambda abstract over; and they - -- are put in the envt, so when we need a (PA a) we can find it in - -- the envt; they don't include the silent superclass args yet - do { mod <- liftDs getModule - ; let dfun_name = mkLocalisedOccName mod mkPADFunOcc vect_tc_name - - -- The superclass dictionary is a (silent) argument if the tycon is polymorphic... - ; let mk_super_ty = do { r <- mkPReprType inst_ty - ; pr_cls <- builtin prClass - ; return $ mkClassPred pr_cls [r] - } - ; super_tys <- sequence [mk_super_ty | not (null tvs)] - ; super_args <- mapM (newLocalVar (fsLit "pr")) super_tys - ; let val_args = super_args ++ args - all_args = tvs ++ val_args - - -- ...it is constant otherwise - ; super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_ax [] | null tvs] - - -- Get ids for each of the methods in the dictionary, including superclass - ; paMethodBuilders <- buildPAScAndMethods - ; method_ids <- mapM (method val_args dfun_name) paMethodBuilders - - -- Expression to build the dictionary. - ; pa_dc <- builtin paDataCon - ; let dict = mkLams all_args (mkConApp pa_dc con_args) - con_args = Type inst_ty - : map Var super_args -- the superclass dictionary is either - ++ super_consts -- lambda-bound or constant - ++ map (method_call val_args) method_ids - - -- Build the type of the dictionary function. - ; pa_cls <- builtin paClass - ; let dfun_ty = mkInvForAllTys tvs - $ mkFunTys (map varType val_args) - (mkClassPred pa_cls [inst_ty]) - - -- Set the unfolding for the inliner. - ; raw_dfun <- newExportedVar dfun_name dfun_ty - ; let dfun_unf = mkDFunUnfolding all_args pa_dc con_args - dfun = raw_dfun `setIdUnfolding` dfun_unf - `setInlinePragma` dfunInlinePragma - - -- Add the new binding to the top-level environment. - ; hoistBinding dfun dict - ; return dfun - } - where - tvs = tyConTyVars vect_tc - arg_tys = mkTyVarTys tvs - inst_ty = mkTyConApp vect_tc arg_tys - vect_tc_name = getName vect_tc - - method args dfun_name (name, build) - = localV - $ do expr <- build vect_tc prepr_ax pdata_tc pdatas_tc repr - let body = mkLams (tvs ++ args) expr - raw_var <- newExportedVar (method_name dfun_name name) (exprType body) - let var = raw_var - `setIdUnfolding` mkInlineUnfoldingWithArity - (length args) body - `setInlinePragma` alwaysInlinePragma - hoistBinding var body - return var - - method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args) - method_name dfun_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name) diff --git a/vectorise/Vectorise/Generic/PAMethods.hs b/vectorise/Vectorise/Generic/PAMethods.hs deleted file mode 100644 --- a/vectorise/Vectorise/Generic/PAMethods.hs +++ /dev/null @@ -1,584 +0,0 @@ - --- | Generate methods for the PA class. --- --- TODO: there is a large amount of redundancy here between the --- a, PData a, and PDatas a forms. See if we can factor some of this out. --- -module Vectorise.Generic.PAMethods - ( buildPReprTyCon - , buildPAScAndMethods - ) where - -import Vectorise.Utils -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Generic.Description -import CoreSyn -import CoreUtils -import FamInstEnv -import MkCore ( mkWildCase, mkCoreLet ) -import TyCon -import CoAxiom -import Type -import OccName -import Coercion -import MkId -import FamInst -import TysPrim( intPrimTy ) - -import DynFlags -import FastString -import MonadUtils -import Control.Monad -import Outputable - - -buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst -buildPReprTyCon orig_tc vect_tc repr - = do name <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc) - rhs_ty <- sumReprType repr - prepr_tc <- builtin preprTyCon - let axiom = mkSingleCoAxiom Nominal name tyvars [] prepr_tc instTys rhs_ty - liftDs $ newFamInst SynFamilyInst axiom - where - tyvars = tyConTyVars vect_tc - instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc] - --- buildPAScAndMethods -------------------------------------------------------- - --- | This says how to build the PR superclass and methods of PA --- Recall the definition of the PA class: --- --- @ --- class class PR (PRepr a) => PA a where --- toPRepr :: a -> PRepr a --- fromPRepr :: PRepr a -> a --- --- toArrPRepr :: PData a -> PData (PRepr a) --- fromArrPRepr :: PData (PRepr a) -> PData a --- --- toArrPReprs :: PDatas a -> PDatas (PRepr a) --- fromArrPReprs :: PDatas (PRepr a) -> PDatas a --- @ --- -type PAInstanceBuilder - = TyCon -- ^ Vectorised TyCon - -> CoAxiom Unbranched - -- ^ Coercion to the representation TyCon - -> TyCon -- ^ 'PData' TyCon - -> TyCon -- ^ 'PDatas' TyCon - -> SumRepr -- ^ Description of generic representation. - -> VM CoreExpr -- ^ Instance function. - - -buildPAScAndMethods :: VM [(String, PAInstanceBuilder)] -buildPAScAndMethods - = return [ ("toPRepr", buildToPRepr) - , ("fromPRepr", buildFromPRepr) - , ("toArrPRepr", buildToArrPRepr) - , ("fromArrPRepr", buildFromArrPRepr) - , ("toArrPReprs", buildToArrPReprs) - , ("fromArrPReprs", buildFromArrPReprs)] - - --- buildToPRepr --------------------------------------------------------------- --- | Build the 'toRepr' method of the PA class. -buildToPRepr :: PAInstanceBuilder -buildToPRepr vect_tc repr_ax _ _ repr - = do let arg_ty = mkTyConApp vect_tc ty_args - - -- Get the representation type of the argument. - res_ty <- mkPReprType arg_ty - - -- Var to bind the argument - arg <- newLocalVar (fsLit "x") arg_ty - - -- Build the expression to convert the argument to the generic representation. - result <- to_sum (Var arg) arg_ty res_ty repr - - return $ Lam arg result - where - ty_args = mkTyVarTys (tyConTyVars vect_tc) - - wrap_repr_inst = wrapTypeUnbranchedFamInstBody repr_ax ty_args [] - - -- CoreExp to convert the given argument to the generic representation. - -- We start by doing a case branch on the possible data constructors. - to_sum :: CoreExpr -> Type -> Type -> SumRepr -> VM CoreExpr - to_sum _ _ _ EmptySum - = do void <- builtin voidVar - return $ wrap_repr_inst $ Var void - - to_sum arg arg_ty res_ty (UnarySum r) - = do (pat, vars, body) <- con_alt r - return $ mkWildCase arg arg_ty res_ty - [(pat, vars, wrap_repr_inst body)] - - to_sum arg arg_ty res_ty (Sum { repr_sum_tc = sum_tc - , repr_con_tys = tys - , repr_cons = cons }) - = do alts <- mapM con_alt cons - let alts' = [(pat, vars, wrap_repr_inst - $ mkConApp sum_con (map Type tys ++ [body])) - | ((pat, vars, body), sum_con) - <- zip alts (tyConDataCons sum_tc)] - return $ mkWildCase arg arg_ty res_ty alts' - - con_alt (ConRepr con r) - = do (vars, body) <- to_prod r - return (DataAlt con, vars, body) - - -- CoreExp to convert data constructor fields to the generic representation. - to_prod :: ProdRepr -> VM ([Var], CoreExpr) - to_prod EmptyProd - = do void <- builtin voidVar - return ([], Var void) - - to_prod (UnaryProd comp) - = do var <- newLocalVar (fsLit "x") (compOrigType comp) - body <- to_comp (Var var) comp - return ([var], body) - - to_prod (Prod { repr_tup_tc = tup_tc - , repr_comp_tys = tys - , repr_comps = comps }) - = do vars <- newLocalVars (fsLit "x") (map compOrigType comps) - exprs <- zipWithM to_comp (map Var vars) comps - let [tup_con] = tyConDataCons tup_tc - return (vars, mkConApp tup_con (map Type tys ++ exprs)) - - -- CoreExp to convert a data constructor component to the generic representation. - to_comp :: CoreExpr -> CompRepr -> VM CoreExpr - to_comp expr (Keep _ _) = return expr - to_comp expr (Wrap ty) = wrapNewTypeBodyOfWrap expr ty - - --- buildFromPRepr ------------------------------------------------------------- - --- |Build the 'fromPRepr' method of the PA class. --- -buildFromPRepr :: PAInstanceBuilder -buildFromPRepr vect_tc repr_ax _ _ repr - = do - arg_ty <- mkPReprType res_ty - arg <- newLocalVar (fsLit "x") arg_ty - - result <- from_sum (unwrapTypeUnbranchedFamInstScrut repr_ax ty_args [] (Var arg)) - repr - return $ Lam arg result - where - ty_args = mkTyVarTys (tyConTyVars vect_tc) - res_ty = mkTyConApp vect_tc ty_args - - from_sum _ EmptySum - = do dummy <- builtin fromVoidVar - return $ Var dummy `App` Type res_ty - - from_sum expr (UnarySum r) = from_con expr r - from_sum expr (Sum { repr_sum_tc = sum_tc - , repr_con_tys = tys - , repr_cons = cons }) - = do vars <- newLocalVars (fsLit "x") tys - es <- zipWithM from_con (map Var vars) cons - return $ mkWildCase expr (exprType expr) res_ty - [(DataAlt con, [var], e) - | (con, var, e) <- zip3 (tyConDataCons sum_tc) vars es] - - from_con expr (ConRepr con r) - = from_prod expr (mkConApp con $ map Type ty_args) r - - from_prod _ con EmptyProd = return con - from_prod expr con (UnaryProd r) - = do e <- from_comp expr r - return $ con `App` e - - from_prod expr con (Prod { repr_tup_tc = tup_tc - , repr_comp_tys = tys - , repr_comps = comps - }) - = do vars <- newLocalVars (fsLit "y") tys - es <- zipWithM from_comp (map Var vars) comps - let [tup_con] = tyConDataCons tup_tc - return $ mkWildCase expr (exprType expr) res_ty - [(DataAlt tup_con, vars, con `mkApps` es)] - - from_comp expr (Keep _ _) = return expr - from_comp expr (Wrap ty) = unwrapNewTypeBodyOfWrap expr ty - - --- buildToArrRepr ------------------------------------------------------------- - --- |Build the 'toArrRepr' method of the PA class. --- -buildToArrPRepr :: PAInstanceBuilder -buildToArrPRepr vect_tc repr_co pdata_tc _ r - = do arg_ty <- mkPDataType el_ty - res_ty <- mkPDataType =<< mkPReprType el_ty - arg <- newLocalVar (fsLit "xs") arg_ty - - pdata_co <- mkBuiltinCo pdataTyCon - let co = mkAppCo pdata_co - $ mkSymCo - $ mkUnbranchedAxInstCo Nominal repr_co ty_args [] - - scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) - - (vars, result) <- to_sum r - - return . Lam arg - $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty - [(DataAlt pdata_dc, vars, mkCast result co)] - where - ty_args = mkTyVarTys $ tyConTyVars vect_tc - el_ty = mkTyConApp vect_tc ty_args - [pdata_dc] = tyConDataCons pdata_tc - - to_sum ss - = case ss of - EmptySum -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid) - UnarySum r -> to_con r - Sum{} - -> do let psum_tc = repr_psum_tc ss - let [psum_con] = tyConDataCons psum_tc - (vars, exprs) <- mapAndUnzipM to_con (repr_cons ss) - sel <- newLocalVar (fsLit "sel") (repr_sel_ty ss) - return ( sel : concat vars - , wrapFamInstBody psum_tc (repr_con_tys ss) - $ mkConApp psum_con - $ map Type (repr_con_tys ss) ++ (Var sel : exprs)) - - to_prod ss - = case ss of - EmptyProd -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid) - UnaryProd r - -> do pty <- mkPDataType (compOrigType r) - var <- newLocalVar (fsLit "x") pty - expr <- to_comp (Var var) r - return ([var], expr) - Prod{} - -> do let [ptup_con] = tyConDataCons (repr_ptup_tc ss) - ptys <- mapM (mkPDataType . compOrigType) (repr_comps ss) - vars <- newLocalVars (fsLit "x") ptys - exprs <- zipWithM to_comp (map Var vars) (repr_comps ss) - return ( vars - , wrapFamInstBody (repr_ptup_tc ss) (repr_comp_tys ss) - $ mkConApp ptup_con - $ map Type (repr_comp_tys ss) ++ exprs) - - to_con (ConRepr _ r) = to_prod r - - to_comp expr (Keep _ _) = return expr - to_comp expr (Wrap ty) = wrapNewTypeBodyOfPDataWrap expr ty - - --- buildFromArrPRepr ---------------------------------------------------------- - --- |Build the 'fromArrPRepr' method for the PA class. --- -buildFromArrPRepr :: PAInstanceBuilder -buildFromArrPRepr vect_tc repr_co pdata_tc _ r - = do arg_ty <- mkPDataType =<< mkPReprType el_ty - res_ty <- mkPDataType el_ty - arg <- newLocalVar (fsLit "xs") arg_ty - - pdata_co <- mkBuiltinCo pdataTyCon - let co = mkAppCo pdata_co - $ mkUnbranchedAxInstCo Nominal repr_co var_tys [] - - let scrut = mkCast (Var arg) co - - let mk_result args - = wrapFamInstBody pdata_tc var_tys - $ mkConApp pdata_con - $ map Type var_tys ++ args - - (expr, _) <- fixV $ \ ~(_, args) -> - from_sum res_ty (mk_result args) scrut r - - return $ Lam arg expr - where - var_tys = mkTyVarTys $ tyConTyVars vect_tc - el_ty = mkTyConApp vect_tc var_tys - [pdata_con] = tyConDataCons pdata_tc - - from_sum res_ty res expr ss - = case ss of - EmptySum -> return (res, []) - UnarySum r -> from_con res_ty res expr r - Sum {} - -> do let psum_tc = repr_psum_tc ss - let [psum_con] = tyConDataCons psum_tc - sel <- newLocalVar (fsLit "sel") (repr_sel_ty ss) - ptys <- mapM mkPDataType (repr_con_tys ss) - vars <- newLocalVars (fsLit "xs") ptys - (res', args) <- fold from_con res_ty res (map Var vars) (repr_cons ss) - let scrut = unwrapFamInstScrut psum_tc (repr_con_tys ss) expr - let body = mkWildCase scrut (exprType scrut) res_ty - [(DataAlt psum_con, sel : vars, res')] - return (body, Var sel : args) - - from_prod res_ty res expr ss - = case ss of - EmptyProd -> return (res, []) - UnaryProd r -> from_comp res_ty res expr r - Prod {} - -> do let ptup_tc = repr_ptup_tc ss - let [ptup_con] = tyConDataCons ptup_tc - ptys <- mapM mkPDataType (repr_comp_tys ss) - vars <- newLocalVars (fsLit "ys") ptys - (res', args) <- fold from_comp res_ty res (map Var vars) (repr_comps ss) - let scrut = unwrapFamInstScrut ptup_tc (repr_comp_tys ss) expr - let body = mkWildCase scrut (exprType scrut) res_ty - [(DataAlt ptup_con, vars, res')] - return (body, args) - - from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r - - from_comp _ res expr (Keep _ _) = return (res, [expr]) - from_comp _ res expr (Wrap ty) = do { expr' <- unwrapNewTypeBodyOfPDataWrap expr ty - ; return (res, [expr']) - } - - fold f res_ty res exprs rs - = foldrM f' (res, []) (zip exprs rs) - where - f' (expr, r) (res, args) - = do (res', args') <- f res_ty res expr r - return (res', args' ++ args) - - --- buildToArrPReprs ----------------------------------------------------------- --- | Build the 'toArrPReprs' instance for the PA class. --- This converts a PData of elements into the generic representation. -buildToArrPReprs :: PAInstanceBuilder -buildToArrPReprs vect_tc repr_co _ pdatas_tc r - = do - -- The argument type of the instance. - -- eg: 'PDatas (Tree a b)' - arg_ty <- mkPDatasType el_ty - - -- The result type. - -- eg: 'PDatas (PRepr (Tree a b))' - res_ty <- mkPDatasType =<< mkPReprType el_ty - - -- Variable to bind the argument to the instance - -- eg: (xss :: PDatas (Tree a b)) - varg <- newLocalVar (fsLit "xss") arg_ty - - -- Coercion to case between the (PRepr a) type and its instance. - pdatas_co <- mkBuiltinCo pdatasTyCon - let co = mkAppCo pdatas_co - $ mkSymCo - $ mkUnbranchedAxInstCo Nominal repr_co ty_args [] - - let scrut = unwrapFamInstScrut pdatas_tc ty_args (Var varg) - (vars, result) <- to_sum r - - return $ Lam varg - $ mkWildCase scrut (mkTyConApp pdatas_tc ty_args) res_ty - [(DataAlt pdatas_dc, vars, mkCast result co)] - - where - -- The element type of the argument. - -- eg: 'Tree a b'. - ty_args = mkTyVarTys $ tyConTyVars vect_tc - el_ty = mkTyConApp vect_tc ty_args - - -- PDatas data constructor - [pdatas_dc] = tyConDataCons pdatas_tc - - to_sum ss - = case ss of - -- We can't convert data types with no data. - -- See Note: [Empty PDatas]. - EmptySum -> do dflags <- getDynFlags - return ([], errorEmptyPDatas dflags el_ty) - UnarySum r -> do dflags <- getDynFlags - to_con (errorEmptyPDatas dflags el_ty) r - - Sum{} - -> do let psums_tc = repr_psums_tc ss - let [psums_con] = tyConDataCons psums_tc - sels <- newLocalVar (fsLit "sels") (repr_sels_ty ss) - - -- Take the number of selectors to serve as the length of - -- and PDatas Void arrays in the product. See Note [Empty PDatas]. - let xSums = App (repr_selsLength_v ss) (Var sels) - - xSums_var <- newLocalVar (fsLit "xsum") intPrimTy - - (vars, exprs) <- mapAndUnzipM (to_con xSums_var) (repr_cons ss) - return ( sels : concat vars - , wrapFamInstBody psums_tc (repr_con_tys ss) - $ mkCoreLet (NonRec xSums_var xSums) - -- mkCoreLet ensures that the let/app invariant holds - $ mkConApp psums_con - $ map Type (repr_con_tys ss) ++ (Var sels : exprs)) - - to_prod xSums ss - = case ss of - EmptyProd - -> do pvoids <- builtin pvoidsVar - return ([], App (Var pvoids) (Var xSums) ) - - UnaryProd r - -> do pty <- mkPDatasType (compOrigType r) - var <- newLocalVar (fsLit "x") pty - expr <- to_comp (Var var) r - return ([var], expr) - - Prod{} - -> do let [ptups_con] = tyConDataCons (repr_ptups_tc ss) - ptys <- mapM (mkPDatasType . compOrigType) (repr_comps ss) - vars <- newLocalVars (fsLit "x") ptys - exprs <- zipWithM to_comp (map Var vars) (repr_comps ss) - return ( vars - , wrapFamInstBody (repr_ptups_tc ss) (repr_comp_tys ss) - $ mkConApp ptups_con - $ map Type (repr_comp_tys ss) ++ exprs) - - to_con xSums (ConRepr _ r) - = to_prod xSums r - - to_comp expr (Keep _ _) = return expr - to_comp expr (Wrap ty) = wrapNewTypeBodyOfPDatasWrap expr ty - - --- buildFromArrPReprs --------------------------------------------------------- -buildFromArrPReprs :: PAInstanceBuilder -buildFromArrPReprs vect_tc repr_co _ pdatas_tc r - = do - -- The argument type of the instance. - -- eg: 'PDatas (PRepr (Tree a b))' - arg_ty <- mkPDatasType =<< mkPReprType el_ty - - -- The result type. - -- eg: 'PDatas (Tree a b)' - res_ty <- mkPDatasType el_ty - - -- Variable to bind the argument to the instance - -- eg: (xss :: PDatas (PRepr (Tree a b))) - varg <- newLocalVar (fsLit "xss") arg_ty - - -- Build the coercion between PRepr and the instance type - pdatas_co <- mkBuiltinCo pdatasTyCon - let co = mkAppCo pdatas_co - $ mkUnbranchedAxInstCo Nominal repr_co var_tys [] - - let scrut = mkCast (Var varg) co - - let mk_result args - = wrapFamInstBody pdatas_tc var_tys - $ mkConApp pdatas_con - $ map Type var_tys ++ args - - (expr, _) <- fixV $ \ ~(_, args) -> - from_sum res_ty (mk_result args) scrut r - - return $ Lam varg expr - where - -- The element type of the argument. - -- eg: 'Tree a b'. - ty_args = mkTyVarTys $ tyConTyVars vect_tc - el_ty = mkTyConApp vect_tc ty_args - - var_tys = mkTyVarTys $ tyConTyVars vect_tc - [pdatas_con] = tyConDataCons pdatas_tc - - from_sum res_ty res expr ss - = case ss of - -- We can't convert data types with no data. - -- See Note: [Empty PDatas]. - EmptySum -> do dflags <- getDynFlags - return (res, errorEmptyPDatas dflags el_ty) - UnarySum r -> from_con res_ty res expr r - - Sum {} - -> do let psums_tc = repr_psums_tc ss - let [psums_con] = tyConDataCons psums_tc - sel <- newLocalVar (fsLit "sels") (repr_sels_ty ss) - ptys <- mapM mkPDatasType (repr_con_tys ss) - vars <- newLocalVars (fsLit "xs") ptys - (res', args) <- fold from_con res_ty res (map Var vars) (repr_cons ss) - let scrut = unwrapFamInstScrut psums_tc (repr_con_tys ss) expr - let body = mkWildCase scrut (exprType scrut) res_ty - [(DataAlt psums_con, sel : vars, res')] - return (body, Var sel : args) - - from_prod res_ty res expr ss - = case ss of - EmptyProd -> return (res, []) - UnaryProd r -> from_comp res_ty res expr r - Prod {} - -> do let ptups_tc = repr_ptups_tc ss - let [ptups_con] = tyConDataCons ptups_tc - ptys <- mapM mkPDatasType (repr_comp_tys ss) - vars <- newLocalVars (fsLit "ys") ptys - (res', args) <- fold from_comp res_ty res (map Var vars) (repr_comps ss) - let scrut = unwrapFamInstScrut ptups_tc (repr_comp_tys ss) expr - let body = mkWildCase scrut (exprType scrut) res_ty - [(DataAlt ptups_con, vars, res')] - return (body, args) - - from_con res_ty res expr (ConRepr _ r) - = from_prod res_ty res expr r - - from_comp _ res expr (Keep _ _) = return (res, [expr]) - from_comp _ res expr (Wrap ty) = do { expr' <- unwrapNewTypeBodyOfPDatasWrap expr ty - ; return (res, [expr']) - } - - fold f res_ty res exprs rs - = foldrM f' (res, []) (zip exprs rs) - where - f' (expr, r) (res, args) - = do (res', args') <- f res_ty res expr r - return (res', args' ++ args) - - --- Notes ---------------------------------------------------------------------- -{- -Note [Empty PDatas] -~~~~~~~~~~~~~~~~~~~ -We don't support "empty" data types like the following: - - data Empty0 - data Empty1 = MkEmpty1 - data Empty2 = MkEmpty2 Empty0 - ... - -There is no parallel data associcated with these types, so there is no where -to store the length of the PDatas array with our standard representation. - -Enumerations like the following are ok: - data Bool = True | False - -The native and generic representations are: - type instance (PDatas Bool) = VPDs:Bool Sels2 - type instance (PDatas (Repr Bool)) = PSum2s Sels2 (PDatas Void) (PDatas Void) - -To take the length of a (PDatas Bool) we take the length of the contained Sels2. -When converting a (PDatas Bool) to a (PDatas (Repr Bool)) we use this length to -initialise the two (PDatas Void) arrays. - -However, with this: - data Empty1 = MkEmpty1 - -The native and generic representations would be: - type instance (PDatas Empty1) = VPDs:Empty1 - type instance (PDatas (Repr Empty1)) = PVoids Int - -The 'Int' argument of PVoids is supposed to store the length of the PDatas -array. When converting the (PDatas Empty1) to a (PDatas (Repr Empty1)) we -need to come up with a value for it, but there isn't one. - -To fix this we'd need to add an Int field to VPDs:Empty1 as well, but that's -too much hassle and there's no point running a parallel computation on no -data anyway. --} -errorEmptyPDatas :: DynFlags -> Type -> a -errorEmptyPDatas dflags tc - = cantVectorise dflags "Vectorise.PAMethods" - $ vcat [ text "Cannot vectorise data type with no parallel data " <> quotes (ppr tc) - , text "Data types to be vectorised must contain at least one constructor" - , text "with at least one field." ] diff --git a/vectorise/Vectorise/Generic/PData.hs b/vectorise/Vectorise/Generic/PData.hs deleted file mode 100644 --- a/vectorise/Vectorise/Generic/PData.hs +++ /dev/null @@ -1,168 +0,0 @@ - --- | Build instance tycons for the PData and PDatas type families. --- --- TODO: the PData and PDatas cases are very similar. --- We should be able to factor out the common parts. -module Vectorise.Generic.PData - ( buildPDataTyCon - , buildPDatasTyCon ) -where - -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Generic.Description -import Vectorise.Utils -import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) - -import BasicTypes ( SourceText(..) ) -import BuildTyCl -import DataCon -import TyCon -import Type -import FamInst -import FamInstEnv -import TcMType -import Name -import Util -import MonadUtils -import Control.Monad - - --- buildPDataTyCon ------------------------------------------------------------ --- | Build the PData instance tycon for a given type constructor. -buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst -buildPDataTyCon orig_tc vect_tc repr - = fixV $ \fam_inst -> - do let repr_tc = dataFamInstRepTyCon fam_inst - name' <- mkLocalisedName mkPDataTyConOcc orig_name - rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr - pdata <- builtin pdataTyCon - buildDataFamInst name' pdata vect_tc rhs - where - orig_name = tyConName orig_tc - -buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst -buildDataFamInst name' fam_tc vect_tc rhs - = do { axiom_name <- mkDerivedName mkInstTyCoOcc name' - - ; (_, tyvars') <- liftDs $ freshenTyVarBndrs tyvars - ; let ax = mkSingleCoAxiom Representational axiom_name tyvars' [] fam_tc pat_tys rep_ty - tys' = mkTyVarTys tyvars' - rep_ty = mkTyConApp rep_tc tys' - pat_tys = [mkTyConApp vect_tc tys'] - rep_tc = mkAlgTyCon name' - (mkTyConBindersPreferAnon tyvars' liftedTypeKind) - liftedTypeKind - (map (const Nominal) tyvars') - Nothing - [] -- no stupid theta - rhs - (DataFamInstTyCon ax fam_tc pat_tys) - False -- not GADT syntax - ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax } - where - tyvars = tyConTyVars vect_tc - -buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs -buildPDataTyConRhs orig_name vect_tc repr_tc repr - = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr - return $ DataTyCon { data_cons = [data_con], is_enum = False } - - -buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon -buildPDataDataCon orig_name vect_tc repr_tc repr - = do let tvs = tyConTyVars vect_tc - dc_name <- mkLocalisedName mkPDataDataConOcc orig_name - comp_tys <- mkSumTys repr_sel_ty mkPDataType repr - fam_envs <- readGEnv global_fam_inst_env - rep_nm <- liftDs $ newTyConRepName dc_name - liftDs $ buildDataCon fam_envs dc_name - False -- not infix - rep_nm - (map (const no_bang) comp_tys) - (Just $ map (const HsLazy) comp_tys) - [] -- no field labels - (mkTyVarBinders Specified tvs) - [] -- no existentials - [] -- no eq spec - [] -- no context - comp_tys - (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) - repr_tc - where - no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict - - --- buildPDatasTyCon ----------------------------------------------------------- --- | Build the PDatas instance tycon for a given type constructor. -buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst -buildPDatasTyCon orig_tc vect_tc repr - = fixV $ \fam_inst -> - do let repr_tc = dataFamInstRepTyCon fam_inst - name' <- mkLocalisedName mkPDatasTyConOcc orig_name - rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr - pdatas <- builtin pdatasTyCon - buildDataFamInst name' pdatas vect_tc rhs - where - orig_name = tyConName orig_tc - -buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs -buildPDatasTyConRhs orig_name vect_tc repr_tc repr - = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr - return $ DataTyCon { data_cons = [data_con], is_enum = False } - - -buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon -buildPDatasDataCon orig_name vect_tc repr_tc repr - = do let tvs = tyConTyVars vect_tc - dc_name <- mkLocalisedName mkPDatasDataConOcc orig_name - - comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr - fam_envs <- readGEnv global_fam_inst_env - rep_nm <- liftDs $ newTyConRepName dc_name - liftDs $ buildDataCon fam_envs dc_name - False -- not infix - rep_nm - (map (const no_bang) comp_tys) - (Just $ map (const HsLazy) comp_tys) - [] -- no field labels - (mkTyVarBinders Specified tvs) - [] -- no existentials - [] -- no eq spec - [] -- no context - comp_tys - (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) - repr_tc - where - no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict - - --- Utils ---------------------------------------------------------------------- --- | Flatten a SumRepr into a list of data constructor types. -mkSumTys - :: (SumRepr -> Type) - -> (Type -> VM Type) - -> SumRepr - -> VM [Type] - -mkSumTys repr_selX_ty mkTc repr - = sum_tys repr - where - sum_tys EmptySum = return [] - sum_tys (UnarySum r) = con_tys r - sum_tys d@(Sum { repr_cons = cons }) - = liftM (repr_selX_ty d :) (concatMapM con_tys cons) - - con_tys (ConRepr _ r) = prod_tys r - - prod_tys EmptyProd = return [] - prod_tys (UnaryProd r) = liftM singleton (comp_ty r) - prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps - - comp_ty r = mkTc (compOrigType r) - -{- -mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type]) -mk_fam_inst fam_tc arg_tc - = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc]) --} diff --git a/vectorise/Vectorise/Monad.hs b/vectorise/Vectorise/Monad.hs deleted file mode 100644 --- a/vectorise/Vectorise/Monad.hs +++ /dev/null @@ -1,195 +0,0 @@ -module Vectorise.Monad ( - module Vectorise.Monad.Base, - module Vectorise.Monad.Naming, - module Vectorise.Monad.Local, - module Vectorise.Monad.Global, - module Vectorise.Monad.InstEnv, - initV, - - -- * Builtins - liftBuiltinDs, - builtin, - builtins, - - -- * Variables - lookupVar, - lookupVar_maybe, - addGlobalParallelVar, - addGlobalParallelTyCon, -) where - -import Vectorise.Monad.Base -import Vectorise.Monad.Naming -import Vectorise.Monad.Local -import Vectorise.Monad.Global -import Vectorise.Monad.InstEnv -import Vectorise.Builtins -import Vectorise.Env - -import CoreSyn -import TcRnMonad -import DsMonad -import HscTypes hiding ( MonadThings(..) ) -import DynFlags -import MonadUtils (liftIO) -import InstEnv -import Class -import TyCon -import NameSet -import VarSet -import VarEnv -import Var -import Id -import Name -import ErrUtils -import Outputable -import Module - -import Control.Monad (join) - --- |Run a vectorisation computation. --- -initV :: HscEnv - -> ModGuts - -> VectInfo - -> VM a - -> IO (Maybe (VectInfo, a)) -initV hsc_env guts info thing_inside - = do { dumpIfVtTrace "Incoming VectInfo" (ppr info) - - ; (_, res) <- initDsWithModGuts hsc_env guts go - ; case join res of - Nothing - -> dumpIfVtTrace "Vectorisation FAILED!" empty - Just (info', _) - -> dumpIfVtTrace "Outgoing VectInfo" (ppr info') - - ; return $ join res - } - where - dflags = hsc_dflags hsc_env - - dumpIfVtTrace = dumpIfSet_dyn dflags Opt_D_dump_vt_trace - - bindsToIds (NonRec v _) = [v] - bindsToIds (Rec binds) = map fst binds - - ids = concatMap bindsToIds (mg_binds guts) - - go - = do { -- set up tables of builtin entities - ; builtins <- initBuiltins - ; builtin_vars <- initBuiltinVars builtins - - -- set up class and type family envrionments - ; eps <- liftIO $ hscEPS hsc_env - ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts) - instEnvs = InstEnvs (eps_inst_env eps) - (mg_inst_env guts) - (mkModuleSet (dep_orphs (mg_deps guts))) - builtin_pas = initClassDicts instEnvs (paClass builtins) -- grab all 'PA' and.. - builtin_prs = initClassDicts instEnvs (prClass builtins) -- ..'PR' class instances - - -- construct the initial global environment - ; let genv = extendImportedVarsEnv builtin_vars - . setPAFunsEnv builtin_pas - . setPRFunsEnv builtin_prs - $ initGlobalEnv (gopt Opt_VectorisationAvoidance dflags) - info (mg_vect_decls guts) instEnvs famInstEnvs - - -- perform vectorisation - ; r <- runVM thing_inside builtins genv emptyLocalEnv - ; case r of - Yes genv _ x -> return $ Just (new_info genv, x) - No reason -> do { unqual <- mkPrintUnqualifiedDs - ; liftIO $ - printOutputForUser dflags unqual $ - mkDumpDoc "Warning: vectorisation failure:" reason - ; return Nothing - } - } - - new_info genv = modVectInfo genv ids (mg_tcs guts) (mg_vect_decls guts) info - - -- For a given DPH class, produce a mapping from type constructor (in head position) to the - -- instance dfun for that type constructor and class. (DPH class instances cannot overlap in - -- head constructors.) - -- - initClassDicts :: InstEnvs -> Class -> [(Name, Var)] - initClassDicts insts cls = map find $ classInstances insts cls - where - find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) - | otherwise = pprPanic invalidInstance (ppr i) - - invalidInstance = "Invalid DPH instance (overlapping in head constructor)" - --- Builtins ------------------------------------------------------------------- - --- |Lift a desugaring computation using the `Builtins` into the vectorisation monad. --- -liftBuiltinDs :: (Builtins -> DsM a) -> VM a -liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)} - --- |Project something from the set of builtins. --- -builtin :: (Builtins -> a) -> VM a -builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi)) - --- |Lift a function using the `Builtins` into the vectorisation monad. --- -builtins :: (a -> Builtins -> b) -> VM (a -> b) -builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi)) - - --- Var ------------------------------------------------------------------------ - --- |Lookup the vectorised, and if local, also the lifted version of a variable. --- --- * If it's in the global environment we get the vectorised version. --- * If it's in the local environment we get both the vectorised and lifted version. --- -lookupVar :: Var -> VM (Scope Var (Var, Var)) -lookupVar v - = do { mb_res <- lookupVar_maybe v - ; case mb_res of - Just x -> return x - Nothing -> - do dflags <- getDynFlags - dumpVar dflags v - } - -lookupVar_maybe :: Var -> VM (Maybe (Scope Var (Var, Var))) -lookupVar_maybe v - = do { r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v - ; case r of - Just e -> return $ Just (Local e) - Nothing -> fmap Global <$> (readGEnv $ \env -> lookupVarEnv (global_vars env) v) - } - -dumpVar :: DynFlags -> Var -> a -dumpVar dflags var - | Just _ <- isClassOpId_maybe var - = cantVectorise dflags "ClassOpId not vectorised:" (ppr var) - | otherwise - = cantVectorise dflags "Variable not vectorised:" (ppr var) - - --- Global parallel entities ---------------------------------------------------- - --- |Mark the given variable as parallel — i.e., executing the associated code might involve --- parallel array computations. --- -addGlobalParallelVar :: Var -> VM () -addGlobalParallelVar var - = do { traceVt "addGlobalParallelVar" (ppr var) - ; updGEnv $ \env -> env{global_parallel_vars = extendDVarSet (global_parallel_vars env) var} - } - --- |Mark the given type constructor as parallel — i.e., its values might embed parallel arrays. --- -addGlobalParallelTyCon :: TyCon -> VM () -addGlobalParallelTyCon tycon - = do { traceVt "addGlobalParallelTyCon" (ppr tycon) - ; updGEnv $ \env -> - env{global_parallel_tycons = extendNameSet (global_parallel_tycons env) (tyConName tycon)} - } diff --git a/vectorise/Vectorise/Monad/Base.hs b/vectorise/Vectorise/Monad/Base.hs deleted file mode 100644 --- a/vectorise/Vectorise/Monad/Base.hs +++ /dev/null @@ -1,243 +0,0 @@ --- |The Vectorisation monad. - -module Vectorise.Monad.Base ( - -- * The Vectorisation Monad - VResult(..), - VM(..), - - -- * Lifting - liftDs, - - -- * Error Handling - cantVectorise, - maybeCantVectorise, - maybeCantVectoriseM, - - -- * Debugging - emitVt, traceVt, dumpOptVt, dumpVt, - - -- * Control - noV, traceNoV, - ensureV, traceEnsureV, - onlyIfV, - tryV, tryErrV, - maybeV, traceMaybeV, - orElseV, orElseErrV, - fixV, -) where - -import Vectorise.Builtins -import Vectorise.Env - -import DsMonad -import TcRnMonad -import ErrUtils -import Outputable -import DynFlags - -import Control.Monad - - --- The Vectorisation Monad ---------------------------------------------------- - --- |Vectorisation can either succeed with new envionment and a value, or return with failure --- (including a description of the reason for failure). --- -data VResult a - = Yes GlobalEnv LocalEnv a - | No SDoc - -newtype VM a - = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) } - -instance Monad VM where - VM p >>= f = VM $ \bi genv lenv -> do - r <- p bi genv lenv - case r of - Yes genv' lenv' x -> runVM (f x) bi genv' lenv' - No reason -> return $ No reason - -instance Applicative VM where - pure x = VM $ \_ genv lenv -> return (Yes genv lenv x) - (<*>) = ap - -instance Functor VM where - fmap = liftM - -instance MonadIO VM where - liftIO = liftDs . liftIO - -instance HasDynFlags VM where - getDynFlags = liftDs getDynFlags - --- Lifting -------------------------------------------------------------------- - --- |Lift a desugaring computation into the vectorisation monad. --- -liftDs :: DsM a -> VM a -liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) } - - --- Error Handling ------------------------------------------------------------- - --- |Throw a `pgmError` saying we can't vectorise something. --- -cantVectorise :: DynFlags -> String -> SDoc -> a -cantVectorise dflags s d = pgmError - . showSDoc dflags - $ vcat [text "*** Vectorisation error ***", - nest 4 $ sep [text s, nest 4 d]] - --- |Like `fromJust`, but `pgmError` on Nothing. --- -maybeCantVectorise :: DynFlags -> String -> SDoc -> Maybe a -> a -maybeCantVectorise dflags s d Nothing = cantVectorise dflags s d -maybeCantVectorise _ _ _ (Just x) = x - --- |Like `maybeCantVectorise` but in a `Monad`. --- -maybeCantVectoriseM :: (Monad m, HasDynFlags m) - => String -> SDoc -> m (Maybe a) -> m a -maybeCantVectoriseM s d p - = do - r <- p - case r of - Just x -> return x - Nothing -> - do dflags <- getDynFlags - cantVectorise dflags s d - - --- Debugging ------------------------------------------------------------------ - --- |Output a trace message if -ddump-vt-trace is active. --- -emitVt :: String -> SDoc -> VM () -emitVt herald doc - = liftDs $ do - dflags <- getDynFlags - liftIO . printOutputForUser dflags alwaysQualify $ - hang (text herald) 2 doc - --- |Output a trace message if -ddump-vt-trace is active. --- -traceVt :: String -> SDoc -> VM () -traceVt herald doc - = liftDs $ traceOptIf Opt_D_dump_vt_trace $ hang (text herald) 2 doc - --- |Dump the given program conditionally. --- -dumpOptVt :: DumpFlag -> String -> SDoc -> VM () -dumpOptVt flag header doc - = do { b <- liftDs $ doptM flag - ; if b - then dumpVt header doc - else return () - } - --- |Dump the given program unconditionally. --- -dumpVt :: String -> SDoc -> VM () -dumpVt header doc - = do { unqual <- liftDs mkPrintUnqualifiedDs - ; dflags <- liftDs getDynFlags - ; liftIO $ printOutputForUser dflags unqual (mkDumpDoc header doc) - } - - --- Control -------------------------------------------------------------------- - --- |Return some result saying we've failed. --- -noV :: SDoc -> VM a -noV reason = VM $ \_ _ _ -> return $ No reason - --- |Like `traceNoV` but also emit some trace message to stderr. --- -traceNoV :: String -> SDoc -> VM a -traceNoV s d = pprTrace s d $ noV d - --- |If `True` then carry on, otherwise fail. --- -ensureV :: SDoc -> Bool -> VM () -ensureV reason False = noV reason -ensureV _reason True = return () - --- |Like `ensureV` but if we fail then emit some trace message to stderr. --- -traceEnsureV :: String -> SDoc -> Bool -> VM () -traceEnsureV s d False = traceNoV s d -traceEnsureV _ _ True = return () - --- |If `True` then return the first argument, otherwise fail. --- -onlyIfV :: SDoc -> Bool -> VM a -> VM a -onlyIfV reason b p = ensureV reason b >> p - --- |Try some vectorisation computaton. --- --- If it succeeds then return `Just` the result; otherwise, return `Nothing` after emitting a --- failure message. --- -tryErrV :: VM a -> VM (Maybe a) -tryErrV (VM p) = VM $ \bi genv lenv -> - do - r <- p bi genv lenv - case r of - Yes genv' lenv' x -> return (Yes genv' lenv' (Just x)) - No reason -> do { unqual <- mkPrintUnqualifiedDs - ; dflags <- getDynFlags - ; liftIO $ - printInfoForUser dflags unqual $ - text "Warning: vectorisation failure:" <+> reason - ; return (Yes genv lenv Nothing) - } - --- |Try some vectorisation computaton. --- --- If it succeeds then return `Just` the result; otherwise, return `Nothing` without emitting a --- failure message. --- -tryV :: VM a -> VM (Maybe a) -tryV (VM p) = VM $ \bi genv lenv -> - do - r <- p bi genv lenv - case r of - Yes genv' lenv' x -> return (Yes genv' lenv' (Just x)) - No _reason -> return (Yes genv lenv Nothing) - --- |If `Just` then return the value, otherwise fail. --- -maybeV :: SDoc -> VM (Maybe a) -> VM a -maybeV reason p = maybe (noV reason) return =<< p - --- |Like `maybeV` but emit a message to stderr if we fail. --- -traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a -traceMaybeV s d p = maybe (traceNoV s d) return =<< p - --- |Try the first computation, --- --- * if it succeeds then take the returned value, --- * if it fails then run the second computation instead while emitting a failure message. --- -orElseErrV :: VM a -> VM a -> VM a -orElseErrV p q = maybe q return =<< tryErrV p - --- |Try the first computation, --- --- * if it succeeds then take the returned value, --- * if it fails then run the second computation instead without emitting a failure message. --- -orElseV :: VM a -> VM a -> VM a -orElseV p q = maybe q return =<< tryV p - --- |Fixpoint in the vectorisation monad. --- -fixV :: (a -> VM a) -> VM a -fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv ) - where - -- NOTE: It is essential that we are lazy in r above so do not replace - -- calls to this function by an explicit case. - unYes (Yes _ _ x) = x - unYes (No reason) = pprPanic "Vectorise.Monad.Base.fixV: no result" reason diff --git a/vectorise/Vectorise/Monad/Global.hs b/vectorise/Vectorise/Monad/Global.hs deleted file mode 100644 --- a/vectorise/Vectorise/Monad/Global.hs +++ /dev/null @@ -1,237 +0,0 @@ --- Operations on the global state of the vectorisation monad. - -module Vectorise.Monad.Global ( - readGEnv, - setGEnv, - updGEnv, - - -- * Configuration - isVectAvoidanceAggressive, - - -- * Vars - defGlobalVar, undefGlobalVar, - - -- * Vectorisation declarations - lookupVectDecl, - - -- * Scalars - globalParallelVars, globalParallelTyCons, - - -- * TyCons - lookupTyCon, - defTyConName, defTyCon, globalVectTyCons, - - -- * Datacons - lookupDataCon, - defDataCon, - - -- * PA Dictionaries - lookupTyConPA, - defTyConPAs, - - -- * PR Dictionaries - lookupTyConPR -) where - -import Vectorise.Monad.Base -import Vectorise.Env - -import CoreSyn -import Type -import TyCon -import DataCon -import DynFlags -import NameEnv -import NameSet -import Name -import VarEnv -import VarSet -import Var as Var -import Outputable - - --- Global Environment --------------------------------------------------------- - --- |Project something from the global environment. --- -readGEnv :: (GlobalEnv -> a) -> VM a -readGEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f genv)) - --- |Set the value of the global environment. --- -setGEnv :: GlobalEnv -> VM () -setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ()) - --- |Update the global environment using the provided function. --- -updGEnv :: (GlobalEnv -> GlobalEnv) -> VM () -updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ()) - - --- Configuration -------------------------------------------------------------- - --- |Should we avoid as much vectorisation as possible? --- --- Set by '-f[no]-vectorisation-avoidance' --- -isVectAvoidanceAggressive :: VM Bool -isVectAvoidanceAggressive = readGEnv global_vect_avoid - - --- Vars ----------------------------------------------------------------------- - --- |Add a mapping between a global var and its vectorised version to the state. --- -defGlobalVar :: Var -> Var -> VM () -defGlobalVar v v' - = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v') - - -- check for duplicate vectorisation - ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v - ; case currentDef of - Just old_v' -> - do dflags <- getDynFlags - cantVectorise dflags "Variable is already vectorised:" $ - ppr v <+> moduleOf v old_v' - Nothing -> return () - - ; updGEnv $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' } - } - where - moduleOf var var' | var == var' - = text "vectorises to itself" - | Just mod <- nameModule_maybe (Var.varName var') - = text "in module" <+> ppr mod - | otherwise - = text "in the current module" - --- |Remove the mapping of a variable in the vectorisation map. --- -undefGlobalVar :: Var -> VM () -undefGlobalVar v - = do - { traceVt "REMOVING global var mapping:" (ppr v) - ; updGEnv $ \env -> env { global_vars = delVarEnv (global_vars env) v } - } - - --- Vectorisation declarations ------------------------------------------------- - --- |Check whether a variable has a vectorisation declaration. --- --- The first component of the result indicates whether the variable has a 'NOVECTORISE' declaration. --- The second component contains the given type and expression in case of a 'VECTORISE' declaration. --- -lookupVectDecl :: Var -> VM (Bool, Maybe (Type, CoreExpr)) -lookupVectDecl var - = readGEnv $ \env -> - case lookupVarEnv (global_vect_decls env) var of - Nothing -> (False, Nothing) - Just Nothing -> (True, Nothing) - Just vectDecl -> (False, vectDecl) - - --- Parallel entities ----------------------------------------------------------- - --- |Get the set of global parallel variables. --- -globalParallelVars :: VM DVarSet -globalParallelVars = readGEnv global_parallel_vars - --- |Get the set of all parallel type constructors (those that may embed parallelism) including both --- both those parallel type constructors declared in an imported module and those declared in the --- current module. --- -globalParallelTyCons :: VM NameSet -globalParallelTyCons = readGEnv global_parallel_tycons - - --- TyCons --------------------------------------------------------------------- - --- |Determine the vectorised version of a `TyCon`. The vectorisation map in the global environment --- contains a vectorised version if the original `TyCon` embeds any parallel arrays. --- -lookupTyCon :: TyCon -> VM (Maybe TyCon) -lookupTyCon tc - = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) - --- |Add a mapping between plain and vectorised `TyCon`s to the global environment. --- --- The second argument is only to enable tracing for (mutually) recursively defined type --- constructors, where we /must not/ pull at the vectorised type constructors (because that would --- pull too early at the recursive knot). --- -defTyConName :: TyCon -> Name -> TyCon -> VM () -defTyConName tc nameOfTc' tc' - = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr nameOfTc') - - -- check for duplicate vectorisation - ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) - ; case currentDef of - Just old_tc' -> - do dflags <- getDynFlags - cantVectorise dflags "Type constructor or class is already vectorised:" $ - ppr tc <+> moduleOf tc old_tc' - Nothing -> return () - - ; updGEnv $ \env -> - env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' } - } - where - moduleOf tc tc' | tc == tc' - = text "vectorises to itself" - | Just mod <- nameModule_maybe (tyConName tc') - = text "in module" <+> ppr mod - | otherwise - = text "in the current module" - --- |Add a mapping between plain and vectorised `TyCon`s to the global environment. --- -defTyCon :: TyCon -> TyCon -> VM () -defTyCon tc tc' = defTyConName tc (tyConName tc') tc' - --- |Get the set of all vectorised type constructors. --- -globalVectTyCons :: VM (NameEnv TyCon) -globalVectTyCons = readGEnv global_tycons - - --- DataCons ------------------------------------------------------------------- - --- |Lookup the vectorised version of a `DataCon` from the global environment. --- -lookupDataCon :: DataCon -> VM (Maybe DataCon) -lookupDataCon dc - | isTupleTyCon (dataConTyCon dc) - = return (Just dc) - | otherwise - = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc) - --- |Add the mapping between plain and vectorised `DataCon`s to the global environment. --- -defDataCon :: DataCon -> DataCon -> VM () -defDataCon dc dc' = updGEnv $ \env -> - env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' } - - --- 'PA' dictionaries ------------------------------------------------------------ - --- |Lookup the 'PA' dfun of a vectorised type constructor in the global environment. --- -lookupTyConPA :: TyCon -> VM (Maybe Var) -lookupTyConPA tc - = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc) - --- |Associate vectorised type constructors with the dfun of their 'PA' instances in the global --- environment. --- -defTyConPAs :: [(TyCon, Var)] -> VM () -defTyConPAs ps = updGEnv $ \env -> - env { global_pa_funs = extendNameEnvList (global_pa_funs env) - [(tyConName tc, pa) | (tc, pa) <- ps] } - - --- PR Dictionaries ------------------------------------------------------------ - -lookupTyConPR :: TyCon -> VM (Maybe Var) -lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc) diff --git a/vectorise/Vectorise/Monad/InstEnv.hs b/vectorise/Vectorise/Monad/InstEnv.hs deleted file mode 100644 --- a/vectorise/Vectorise/Monad/InstEnv.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Vectorise.Monad.InstEnv - ( existsInst - , lookupInst - , lookupFamInst - ) -where - -import Vectorise.Monad.Global -import Vectorise.Monad.Base -import Vectorise.Env - -import DynFlags -import FamInstEnv -import InstEnv -import Class -import Type -import TyCon -import Outputable -import Util - - -#include "HsVersions.h" - - --- Check whether a unique class instance for a given class and type arguments exists. --- -existsInst :: Class -> [Type] -> VM Bool -existsInst cls tys - = do { instEnv <- readGEnv global_inst_env - ; return $ either (const False) (const True) (lookupUniqueInstEnv instEnv cls tys) - } - --- Look up the dfun of a class instance. --- --- The match must be unique —i.e., match exactly one instance— but the --- type arguments used for matching may be more specific than those of --- the class instance declaration. The found class instances must not have --- any type variables in the instance context that do not appear in the --- instances head (i.e., no flexi vars); for details for what this means, --- see the docs at InstEnv.lookupInstEnv. --- -lookupInst :: Class -> [Type] -> VM (DFunId, [Type]) -lookupInst cls tys - = do { instEnv <- readGEnv global_inst_env - ; case lookupUniqueInstEnv instEnv cls tys of - Right (inst, inst_tys) -> return (instanceDFunId inst, inst_tys) - Left err -> - do dflags <- getDynFlags - cantVectorise dflags "Vectorise.Monad.InstEnv.lookupInst:" err - } - --- Look up a family instance. --- --- The match must be unique - ie, match exactly one instance - but the --- type arguments used for matching may be more specific than those of --- the family instance declaration. --- --- Return the family instance and its type instance. For example, if we have --- --- lookupFamInst 'T' '[Int]' yields (':R42T', 'Int') --- --- then we have a coercion (ie, type instance of family instance coercion) --- --- :Co:R42T Int :: T [Int] ~ :R42T Int --- --- which implies that :R42T was declared as 'data instance T [a]'. --- -lookupFamInst :: TyCon -> [Type] -> VM FamInstMatch -lookupFamInst tycon tys - = ASSERT( isOpenFamilyTyCon tycon ) - do { instEnv <- readGEnv global_fam_inst_env - ; case lookupFamInstEnv instEnv tycon tys of - [match] -> return match - _other -> - do dflags <- getDynFlags - cantVectorise dflags "Vectorise.Monad.InstEnv.lookupFamInst: not found: " - (ppr $ mkTyConApp tycon tys) - } diff --git a/vectorise/Vectorise/Monad/Local.hs b/vectorise/Vectorise/Monad/Local.hs deleted file mode 100644 --- a/vectorise/Vectorise/Monad/Local.hs +++ /dev/null @@ -1,100 +0,0 @@ -module Vectorise.Monad.Local - ( readLEnv - , setLEnv - , updLEnv - , localV - , closedV - , getBindName - , inBind - , lookupTyVarPA - , defLocalTyVar - , defLocalTyVarWithPA - , localTyVars - ) -where - -import Vectorise.Monad.Base -import Vectorise.Env - -import CoreSyn -import Name -import VarEnv -import Var -import FastString - --- Local Environment ---------------------------------------------------------- - --- |Project something from the local environment. --- -readLEnv :: (LocalEnv -> a) -> VM a -readLEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv)) - --- |Set the local environment. --- -setLEnv :: LocalEnv -> VM () -setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ()) - --- |Update the environment using the provided function. --- -updLEnv :: (LocalEnv -> LocalEnv) -> VM () -updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ()) - --- |Perform a computation in its own local environment. --- This does not alter the environment of the current state. --- -localV :: VM a -> VM a -localV p - = do - { env <- readLEnv id - ; x <- p - ; setLEnv env - ; return x - } - --- |Perform a computation in an empty local environment. --- -closedV :: VM a -> VM a -closedV p - = do - { env <- readLEnv id - ; setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env }) - ; x <- p - ; setLEnv env - ; return x - } - --- |Get the name of the local binding currently being vectorised. --- -getBindName :: VM FastString -getBindName = readLEnv local_bind_name - --- |Run a vectorisation computation in a local environment, --- with this id set as the current binding. --- -inBind :: Id -> VM a -> VM a -inBind id p - = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) } - p - --- |Lookup a PA tyvars from the local environment. -lookupTyVarPA :: Var -> VM (Maybe CoreExpr) -lookupTyVarPA tv - = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv - --- |Add a tyvar to the local environment. -defLocalTyVar :: TyVar -> VM () -defLocalTyVar tv = updLEnv $ \env -> - env { local_tyvars = tv : local_tyvars env - , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv - } - --- |Add mapping between a tyvar and pa dictionary to the local environment. -defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM () -defLocalTyVarWithPA tv pa = updLEnv $ \env -> - env { local_tyvars = tv : local_tyvars env - , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa - } - --- |Get the set of tyvars from the local environment. -localTyVars :: VM [TyVar] -localTyVars = readLEnv (reverse . local_tyvars) diff --git a/vectorise/Vectorise/Monad/Naming.hs b/vectorise/Vectorise/Monad/Naming.hs deleted file mode 100644 --- a/vectorise/Vectorise/Monad/Naming.hs +++ /dev/null @@ -1,130 +0,0 @@ --- |Computations in the vectorisation monad concerned with naming and fresh variable generation. - -module Vectorise.Monad.Naming - ( mkLocalisedName - , mkDerivedName - , mkVectId - , cloneVar - , newExportedVar - , newLocalVar - , newLocalVars - , newDummyVar - , newTyVar - , newCoVar - ) -where - -import Vectorise.Monad.Base - -import DsMonad -import TcType -import Type -import Var -import Module -import Name -import SrcLoc -import MkId -import Id -import IdInfo( IdDetails(VanillaId) ) -import FastString - -import Control.Monad - - --- Naming --------------------------------------------------------------------- - --- |Create a localised variant of a name, using the provided function to transform its `OccName`. --- --- If the name external, encode the original name's module into the new 'OccName'. The result is --- always an internal system name. --- -mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name -mkLocalisedName mk_occ name - = do { mod <- liftDs getModule - ; u <- liftDs newUnique - ; let occ_name = mkLocalisedOccName mod mk_occ name - - new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name) - | otherwise = mkSystemName u occ_name - - ; return new_name } - -mkDerivedName :: (OccName -> OccName) -> Name -> VM Name --- Similar to mkLocalisedName, but assumes the --- incoming name is from this module. --- Works on External names only -mkDerivedName mk_occ name - = do { u <- liftDs newUnique - ; return (mkExternalName u (nameModule name) - (mk_occ (nameOccName name)) - (nameSrcSpan name)) } - --- |Produce the vectorised variant of an `Id` with the given vectorised type, while taking care that --- vectorised dfun ids must be dfuns again. --- --- Force the new name to be a system name and, if the original was an external name, disambiguate --- the new name with the module name of the original. --- -mkVectId :: Id -> Type -> VM Id -mkVectId id ty - = do { name <- mkLocalisedName mkVectOcc (getName id) - ; let id' | isDFunId id = MkId.mkDictFunId name tvs theta cls tys - | isExportedId id = Id.mkExportedLocalId VanillaId name ty - | otherwise = Id.mkLocalIdOrCoVar name ty - ; return id' - } - where - -- Decompose a dictionary function signature: \forall tvs. theta -> cls tys - -- NB: We do *not* use closures '(:->)' for vectorised predicate abstraction as dictionary - -- functions are always fully applied. - (tvs, theta, pty) = tcSplitSigmaTy ty - (cls, tys) = tcSplitDFunHead pty - --- |Make a fresh instance of this var, with a new unique. --- -cloneVar :: Var -> VM Var -cloneVar var = liftM (setIdUnique var) (liftDs newUnique) - --- |Make a fresh exported variable with the given type. --- -newExportedVar :: OccName -> Type -> VM Var -newExportedVar occ_name ty - = do mod <- liftDs getModule - u <- liftDs newUnique - - let name = mkExternalName u mod occ_name noSrcSpan - - return $ Id.mkExportedLocalId VanillaId name ty - --- |Make a fresh local variable with the given type. --- The variable's name is formed using the given string as the prefix. --- -newLocalVar :: FastString -> Type -> VM Var -newLocalVar fs ty - = do u <- liftDs newUnique - return $ mkSysLocalOrCoVar fs u ty - --- |Make several fresh local variables with the given types. --- The variable's names are formed using the given string as the prefix. --- -newLocalVars :: FastString -> [Type] -> VM [Var] -newLocalVars fs = mapM (newLocalVar fs) - --- |Make a new local dummy variable. --- -newDummyVar :: Type -> VM Var -newDummyVar = newLocalVar (fsLit "vv") - --- |Make a fresh type variable with the given kind. --- The variable's name is formed using the given string as the prefix. --- -newTyVar :: FastString -> Kind -> VM Var -newTyVar fs k - = do u <- liftDs newUnique - return $ mkTyVar (mkSysTvName u fs) k - --- |Make a fresh coercion variable with the given kind. -newCoVar :: FastString -> Kind -> VM Var -newCoVar fs k - = do u <- liftDs newUnique - return $ mkCoVar (mkSystemVarName u fs) k diff --git a/vectorise/Vectorise/Type/Classify.hs b/vectorise/Vectorise/Type/Classify.hs deleted file mode 100644 --- a/vectorise/Vectorise/Type/Classify.hs +++ /dev/null @@ -1,128 +0,0 @@ --- Extract from a list of type constructors those (1) which need to be vectorised and (2) those --- that could be, but need not be vectorised (as a scalar representation is sufficient and more --- efficient). The type constructors that cannot be vectorised will be dropped. --- --- A type constructor will only be vectorised if it is --- --- (1) a data type constructor, with vanilla data constructors (i.e., data constructors admitted by --- Haskell 98) and --- (2) at least one of the type constructors that appears in its definition is also vectorised. --- --- If (1) is met, but not (2), the type constructor may appear in vectorised code, but there is no --- need to vectorise that type constructor itself. This holds, for example, for all enumeration --- types. As '([::])' is being vectorised, any type constructor whose definition involves --- '([::])', either directly or indirectly, will be vectorised. - -module Vectorise.Type.Classify - ( classifyTyCons - ) -where - -import NameSet -import UniqSet -import UniqFM -import DataCon -import TyCon -import TyCoRep -import qualified Type -import PrelNames -import Digraph - --- |From a list of type constructors, extract those that can be vectorised, returning them in two --- sets, where the first result list /must be/ vectorised and the second result list /need not be/ --- vectorised. The third result list are those type constructors that we cannot convert (either --- because they use language extensions or because they dependent on type constructors for which --- no vectorised version is available). --- --- NB: In order to be able to vectorise a type constructor, we require members of the depending set --- (i.e., those type constructors that the current one depends on) to be vectorised only if they --- are also parallel (i.e., appear in the second argument to the function). --- --- The first argument determines the /conversion status/ of external type constructors as follows: --- --- * tycons which have converted versions are mapped to 'True' --- * tycons which are not changed by vectorisation are mapped to 'False' --- * tycons which haven't been converted (because they can't or weren't vectorised) are not --- elements of the map --- -classifyTyCons :: UniqFM Bool -- ^type constructor vectorisation status - -> NameSet -- ^tycons involving parallel arrays - -> [TyCon] -- ^type constructors that need to be classified - -> ( [TyCon] -- to be converted - , [TyCon] -- need not be converted (but could be) - , [TyCon] -- involve parallel arrays (whether converted or not) - , [TyCon] -- can't be converted - ) -classifyTyCons convStatus parTyCons tcs = classify [] [] [] [] convStatus parTyCons (tyConGroups tcs) - where - classify conv keep par novect _ _ [] = (conv, keep, par, novect) - classify conv keep par novect cs pts ((tcs, ds) : rs) - | can_convert && must_convert - = classify (tcs ++ conv) keep (par ++ tcs_par) novect (cs `addListToUFM` [(tc, True) | tc <- tcs]) pts' rs - | can_convert - = classify conv (tcs ++ keep) (par ++ tcs_par) novect (cs `addListToUFM` [(tc, False) | tc <- tcs]) pts' rs - | otherwise - = classify conv keep (par ++ tcs_par) (tcs ++ novect) cs pts' rs - where - refs = ds `delListFromUniqSet` tcs - - -- the tycons that directly or indirectly depend on parallel arrays - tcs_par | uniqSetAny ((`elemNameSet` parTyCons) . tyConName) refs = tcs - | otherwise = [] - - pts' = pts `extendNameSetList` map tyConName tcs_par - - can_convert = (isEmptyUniqSet (filterUniqSet ((`elemNameSet` pts) . tyConName) (refs `uniqSetMinusUFM` cs)) - && all convertable tcs) - || isShowClass tcs - must_convert = anyUFM id (intersectUFM_C const cs (getUniqSet refs)) - && (not . isShowClass $ tcs) - - -- We currently admit Haskell 2011-style data and newtype declarations as well as type - -- constructors representing classes. - convertable tc - = (isDataTyCon tc || isNewTyCon tc) && all isVanillaDataCon (tyConDataCons tc) - || isClassTyCon tc - - -- !!!FIXME: currently we allow 'Show' in vectorised code without actually providing a - -- vectorised definition (to be able to vectorise 'Num') - isShowClass [tc] = tyConName tc == showClassName - isShowClass _ = False - --- Used to group type constructors into mutually dependent groups. --- -type TyConGroup = ([TyCon], UniqSet TyCon) - --- Compute mutually recursive groups of tycons in topological order. --- -tyConGroups :: [TyCon] -> [TyConGroup] -tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVerticesUniq edges) - where - edges = [((tc, ds), tc, nonDetEltsUniqSet ds) | tc <- tcs - , let ds = tyConsOfTyCon tc] - -- It's OK to use nonDetEltsUniqSet here as - -- stronglyConnCompFromEdgedVertices is still deterministic even - -- if the edges are in nondeterministic order as explained in - -- Note [Deterministic SCC] in Digraph. - - mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds) - mk_grp (CyclicSCC els) = (tcs, unionManyUniqSets dss) - where - (tcs, dss) = unzip els - --- |Collect the set of TyCons used by the representation of some data type. --- -tyConsOfTyCon :: TyCon -> UniqSet TyCon -tyConsOfTyCon = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons - --- |Collect the set of TyCons that occur in these types. --- -tyConsOfTypes :: [Type] -> UniqSet TyCon -tyConsOfTypes = unionManyUniqSets . map tyConsOfType - --- |Collect the set of TyCons that occur in this type. --- -tyConsOfType :: Type -> UniqSet TyCon -tyConsOfType ty = filterUniqSet not_tuple_or_unlifted $ Type.tyConsOfType ty - where not_tuple_or_unlifted tc = not (isUnliftedTyCon tc || isTupleTyCon tc) - diff --git a/vectorise/Vectorise/Type/Env.hs b/vectorise/Vectorise/Type/Env.hs deleted file mode 100644 --- a/vectorise/Vectorise/Type/Env.hs +++ /dev/null @@ -1,455 +0,0 @@ -{-# LANGUAGE CPP #-} - --- Vectorise a modules type and class declarations. --- --- This produces new type constructors and family instances top be included in the module toplevel --- as well as bindings for worker functions, dfuns, and the like. - -module Vectorise.Type.Env ( - vectTypeEnv, -) where - -#include "HsVersions.h" - -import Vectorise.Env -import Vectorise.Vect -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Type.TyConDecl -import Vectorise.Type.Classify -import Vectorise.Generic.PADict -import Vectorise.Generic.PAMethods -import Vectorise.Generic.PData -import Vectorise.Generic.Description -import Vectorise.Utils - -import CoreSyn -import CoreUtils -import CoreUnfold -import DataCon -import TyCon -import CoAxiom -import Type -import FamInstEnv -import Id -import MkId -import NameEnv -import NameSet -import UniqFM -import OccName -import Unique - -import Util -import Outputable -import DynFlags -import FastString -import MonadUtils - -import Control.Monad -import Data.Maybe -import Data.List - - --- Note [Pragmas to vectorise tycons] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- All imported type constructors that are not mapped to a vectorised type in the vectorisation map --- (possibly because the defining module was not compiled with vectorisation) may be used in scalar --- code encapsulated in vectorised code. If a such a type constructor 'T' is a member of the --- 'Scalar' class (and hence also of 'PData' and 'PRepr'), it may also be used in vectorised code, --- where 'T' represents itself, but the representation of 'T' still remains opaque in vectorised --- code (i.e., it can only be used in scalar code). --- --- An example is the treatment of 'Int'. 'Int's can be used in vectorised code and remain unchanged --- by vectorisation. However, the representation of 'Int' by the 'I#' data constructor wrapping an --- 'Int#' is not exposed in vectorised code. Instead, computations involving the representation need --- to be confined to scalar code. --- --- VECTORISE pragmas for type constructors cover four different flavours of vectorising data type --- constructors: --- --- (1) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised --- code, where 'T' and the 'Cn' are automatically vectorised in the same manner as data types --- declared in a vectorised module. This includes the case where the vectoriser determines that --- the original representation of 'T' may be used in vectorised code (as it does not embed any --- parallel arrays.) This case is for type constructors that are *imported* from a non- --- vectorised module, but that we want to use with full vectorisation support. --- --- An example is the treatment of 'Ordering' and '[]'. The former remains unchanged by --- vectorisation, whereas the latter is fully vectorised. --- --- 'PData' and 'PRepr' instances are automatically generated by the vectoriser. --- --- Type constructors declared with {-# VECTORISE type T #-} are treated in this manner. --- --- (2) Data type constructor 'T' that may be used in vectorised code, where 'T' is represented by an --- explicitly given 'Tv', but the representation of 'T' is opaque in vectorised code (i.e., the --- constructors of 'T' may not occur in vectorised code). --- --- An example is the treatment of '[::]'. The type '[::]' can be used in vectorised code and is --- vectorised to 'PArray'. However, the representation of '[::]' is not exposed in vectorised --- code. Instead, computations involving the representation need to be confined to scalar code. --- --- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated --- by the vectoriser). --- --- Type constructors declared with {-# VECTORISE type T = Tv #-} are treated in this manner --- manner. (The vectoriser never treats a type constructor automatically in this manner.) --- --- (3) Data type constructor 'T' that does not contain any parallel arrays and has explicitly --- provided 'PData' and 'PRepr' instances (and maybe also a 'Scalar' instance), which together --- with the type's constructors 'Cn' may be used in vectorised code. The type 'T' and its --- constructors 'Cn' are represented by themselves in vectorised code. --- --- An example is 'Bool', which is represented by itself in vectorised code (as it cannot embed --- any parallel arrays). However, we do not want any automatic generation of class and family --- instances, which is why Case (1) does not apply. --- --- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated --- by the vectoriser). --- --- Type constructors declared with {-# VECTORISE SCALAR type T #-} are treated in this manner. --- --- (4) Data type constructor 'T' that does not contain any parallel arrays and that, in vectorised --- code, is represented by an explicitly given 'Tv', but the representation of 'T' is opaque in --- vectorised code and 'T' is regarded to be scalar — i.e., it may be used in encapsulated --- scalar subcomputations. --- --- An example is the treatment of '(->)'. Types '(->)' can be used in vectorised code and are --- vectorised to '(:->)'. However, the representation of '(->)' is not exposed in vectorised --- code. Instead, computations involving the representation need to be confined to scalar code --- and may be part of encapsulated scalar computations. --- --- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated --- by the vectoriser). --- --- Type constructors declared with {-# VECTORISE SCALAR type T = Tv #-} are treated in this --- manner. (The vectoriser never treats a type constructor automatically in this manner.) --- --- In addition, we have also got a single pragma form for type classes: {-# VECTORISE class C #-}. --- It implies that the class type constructor may be used in vectorised code together with its data --- constructor. We generally produce a vectorised version of the data type and data constructor. --- We do not generate 'PData' and 'PRepr' instances for class type constructors. This pragma is the --- default for all type classes declared in a vectorised module, but the pragma can also be used --- explitly on imported classes. - --- Note [Vectorising classes] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We vectorise classes essentially by just vectorising their desugared Core representation, but we --- do generate a 'Class' structure along the way (see 'Vectorise.Type.TyConDecl.vectTyConDecl'). --- --- Here is an example illustrating the mapping — assume --- --- class Num a where --- (+) :: a -> a -> a --- --- It desugars to --- --- data Num a = D:Num { (+) :: a -> a -> a } --- --- which we vectorise to --- --- data V:Num a = D:V:Num { ($v+) :: PArray a :-> PArray a :-> PArray a } --- --- while adding the following entries to the vectorisation map: --- --- tycon : Num --> V:Num --- datacon: D:Num --> D:V:Num --- var : (+) --> ($v+) - --- |Vectorise type constructor including class type constructors. --- -vectTypeEnv :: [TyCon] -- Type constructors defined in this module - -> [CoreVect] -- All 'VECTORISE [SCALAR] type' declarations in this module - -> [CoreVect] -- All 'VECTORISE class' declarations in this module - -> VM ( [TyCon] -- old TyCons ++ new TyCons - , [FamInst] -- New type family instances. - , [(Var, CoreExpr)]) -- New top level bindings. -vectTypeEnv tycons vectTypeDecls vectClassDecls - = do { traceVt "** vectTypeEnv" $ ppr tycons - - ; let -- {-# VECTORISE type T -#} (ONLY the imported tycons) - impVectTyCons = ( [tycon | VectType False tycon Nothing <- vectTypeDecls] - ++ [tycon | VectClass tycon <- vectClassDecls]) - \\ tycons - - -- {-# VECTORISE type T = Tv -#} (imported & local tycons with an /RHS/) - vectTyConsWithRHS = [ (tycon, rhs) - | VectType False tycon (Just rhs) <- vectTypeDecls] - - -- {-# VECTORISE SCALAR type T = Tv -#} (imported & local tycons with an /RHS/) - scalarTyConsWithRHS = [ (tycon, rhs) - | VectType True tycon (Just rhs) <- vectTypeDecls] - - -- {-# VECTORISE SCALAR type T -#} (imported & local /scalar/ tycons without an RHS) - scalarTyConsNoRHS = [tycon | VectType True tycon Nothing <- vectTypeDecls] - - -- Check that is not a VECTORISE SCALAR tycon nor VECTORISE tycons with explicit rhs? - vectSpecialTyConNames = mkNameSet . map tyConName $ - scalarTyConsNoRHS ++ - map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS) - notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames - - -- Build a map containing all vectorised type constructor. If the vectorised type - -- constructor differs from the original one, then it is mapped to 'True'; if they are - -- both the same, then it maps to 'False'. - ; vectTyCons <- globalVectTyCons - ; let vectTyConBase = mapUFM_Directly isDistinct vectTyCons -- 'True' iff tc /= V[[tc]] - isDistinct u tc = u /= getUnique tc - vectTyConFlavour = vectTyConBase - `plusNameEnv` - mkNameEnv [ (tyConName tycon, True) - | (tycon, _) <- vectTyConsWithRHS ++ scalarTyConsWithRHS] - `plusNameEnv` - mkNameEnv [ (tyConName tycon, False) -- original representation - | tycon <- scalarTyConsNoRHS] - - - -- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2) - -- that we could, but don't need to vectorise. Type constructors that are not data - -- type constructors or use non-Haskell98 features are being dropped. They may not - -- appear in vectorised code. (We also drop the local type constructors appearing in a - -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as - -- these are being handled separately. NB: Some type constructors may be marked SCALAR - -- /and/ have an explicit right-hand side.) - -- - -- Furthermore, 'par_tcs' are those type constructors (converted or not) whose - -- definition, directly or indirectly, depends on parallel arrays. Finally, 'drop_tcs' - -- are all type constructors that cannot be vectorised. - ; parallelTyCons <- (`extendNameSetList` map (tyConName . fst) vectTyConsWithRHS) <$> - globalParallelTyCons - ; let maybeVectoriseTyCons = filter notVectSpecialTyCon tycons ++ impVectTyCons - (conv_tcs, keep_tcs, par_tcs, drop_tcs) - = classifyTyCons vectTyConFlavour parallelTyCons maybeVectoriseTyCons - - ; traceVt " known parallel : " $ ppr parallelTyCons - ; traceVt " VECT SCALAR : " $ ppr (scalarTyConsNoRHS ++ map fst scalarTyConsWithRHS) - ; traceVt " VECT [class] : " $ ppr impVectTyCons - ; traceVt " VECT with rhs : " $ ppr (map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS)) - ; traceVt " -- after classification (local and VECT [class] tycons) --" Outputable.empty - ; traceVt " reuse : " $ ppr keep_tcs - ; traceVt " convert : " $ ppr conv_tcs - - -- warn the user about unvectorised type constructors - ; let explanation = text "(They use unsupported language extensions" - $$ text "or depend on type constructors that are" <+> - text "not vectorised)" - drop_tcs_nosyn = filter (not . isTypeFamilyTyCon) . - filter (not . isTypeSynonymTyCon) $ drop_tcs - ; unless (null drop_tcs_nosyn) $ - emitVt "Warning: cannot vectorise these type constructors:" $ - pprQuotedList drop_tcs_nosyn $$ explanation - - ; mapM_ addParallelTyConAndCons $ par_tcs ++ map fst vectTyConsWithRHS - - ; let mapping = - -- Type constructors that we found we don't need to vectorise and those - -- declared VECTORISE SCALAR /without/ an explicit right-hand side, use the same - -- representation in both unvectorised and vectorised code; they are not - -- abstract. - [(tycon, tycon, False) | tycon <- keep_tcs ++ scalarTyConsNoRHS] - -- We do the same for type constructors declared VECTORISE SCALAR /without/ - -- an explicit right-hand side - ++ [(tycon, vTycon, True) | (tycon, vTycon) <- vectTyConsWithRHS ++ scalarTyConsWithRHS] - ; syn_tcs <- catMaybes <$> mapM defTyConDataCons mapping - - -- Vectorise all the data type declarations that we can and must vectorise (enter the - -- type and data constructors into the vectorisation map on-the-fly.) - ; new_tcs <- vectTyConDecls conv_tcs - - ; let dumpTc tc vTc = traceVt "---" (ppr tc <+> text "::" <+> ppr (dataConSig tc) $$ - ppr vTc <+> text "::" <+> ppr (dataConSig vTc)) - dataConSig tc | Just dc <- tyConSingleDataCon_maybe tc = dataConRepType dc - | otherwise = panic "dataConSig" - ; zipWithM_ dumpTc (filter isClassTyCon conv_tcs) (filter isClassTyCon new_tcs) - - -- We don't need new representation types for dictionary constructors. The constructors - -- are always fully applied, and we don't need to lift them to arrays as a dictionary - -- of a particular type always has the same value. - ; let orig_tcs = filter (not . isClassTyCon) $ keep_tcs ++ conv_tcs - vect_tcs = filter (not . isClassTyCon) $ keep_tcs ++ new_tcs - - -- Build 'PRepr' and 'PData' instance type constructors and family instances for all - -- type constructors with vectorised representations. - ; reprs <- mapM tyConRepr vect_tcs - ; repr_fis <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs - ; pdata_fis <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs - ; pdatas_fis <- zipWith3M buildPDatasTyCon orig_tcs vect_tcs reprs - - ; let fam_insts = repr_fis ++ pdata_fis ++ pdatas_fis - repr_axs = map famInstAxiom repr_fis - pdata_tcs = famInstsRepTyCons pdata_fis - pdatas_tcs = famInstsRepTyCons pdatas_fis - - ; updGEnv $ extendFamEnv fam_insts - - -- Generate workers for the vectorised data constructors, dfuns for the 'PA' instances of - -- the vectorised type constructors, and associate the type constructors with their dfuns - -- in the global environment. We get back the dfun bindings (which we will subsequently - -- inject into the modules toplevel). - ; (_, binds) <- fixV $ \ ~(dfuns, _) -> - do { defTyConPAs (zipLazy vect_tcs dfuns) - - -- Query the 'PData' instance type constructors for type constructors that have a - -- VECTORISE SCALAR type pragma without an explicit right-hand side (this is Item - -- (3) of "Note [Pragmas to vectorise tycons]" above). - ; pdata_scalar_tcs <- mapM pdataReprTyConExact scalarTyConsNoRHS - - -- Build workers for all vectorised data constructors (except abstract ones) - ; sequence_ $ - zipWith3 vectDataConWorkers (orig_tcs ++ scalarTyConsNoRHS) - (vect_tcs ++ scalarTyConsNoRHS) - (pdata_tcs ++ pdata_scalar_tcs) - - -- Build a 'PA' dictionary for all type constructors (except abstract ones & those - -- defined with an explicit right-hand side where the dictionary is user-supplied) - ; dfuns <- sequence $ - zipWith4 buildTyConPADict - vect_tcs - repr_axs - pdata_tcs - pdatas_tcs - - ; binds <- takeHoisted - ; return (dfuns, binds) - } - - -- Return the vectorised variants of type constructors as well as the generated instance - -- type constructors, family instances, and dfun bindings. - ; return ( new_tcs ++ pdata_tcs ++ pdatas_tcs ++ syn_tcs - , fam_insts, binds) - } - where - addParallelTyConAndCons tycon - = do - { addGlobalParallelTyCon tycon - ; mapM_ addGlobalParallelVar [ id | dc <- tyConDataCons tycon - , AnId id <- dataConImplicitTyThings dc ] - -- Ignoring the promoted tycon; hope that's ok - } - - -- Add a mapping from the original to vectorised type constructor to the vectorisation map. - -- Unless the type constructor is abstract, also mappings from the original's data constructors - -- to the vectorised type's data constructors. - -- - -- We have three cases: (1) original and vectorised type constructor are the same, (2) the - -- name of the vectorised type constructor is canonical (as prescribed by 'mkVectTyConOcc'), or - -- (3) the name is not canonical. In the third case, we additionally introduce a type synonym - -- with the canonical name that is set equal to the non-canonical name (so that we find the - -- right type constructor when reading vectorisation information from interface files). - -- - defTyConDataCons (origTyCon, vectTyCon, isAbstract) - = do - { canonName <- mkLocalisedName mkVectTyConOcc origName - ; if origName == vectName -- Case (1) - || vectName == canonName -- Case (2) - then do - { defTyCon origTyCon vectTyCon -- T --> vT - ; defDataCons -- Ci --> vCi - ; return Nothing - } - else do -- Case (3) - { let synTyCon = mkSyn canonName (mkTyConTy vectTyCon) -- type S = vT - ; defTyCon origTyCon synTyCon -- T --> S - ; defDataCons -- Ci --> vCi - ; return $ Just synTyCon - } - } - where - origName = tyConName origTyCon - vectName = tyConName vectTyCon - - mkSyn canonName ty = buildSynTyCon canonName [] (typeKind ty) [] ty - - defDataCons - | isAbstract = return () - | otherwise - = do { MASSERT(length (tyConDataCons origTyCon) == length (tyConDataCons vectTyCon)) - ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon) - } - - --- Helpers -------------------------------------------------------------------- - -buildTyConPADict :: TyCon -> CoAxiom Unbranched -> TyCon -> TyCon -> VM Var -buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc - = tyConRepr vect_tc >>= buildPADict vect_tc prepr_ax pdata_tc pdatas_tc - --- Produce a custom-made worker for the data constructors of a vectorised data type. This includes --- all data constructors that may be used in vectorised code — i.e., all data constructors of data --- types with 'VECTORISE [SCALAR] type' pragmas with an explicit right-hand side. Also adds a mapping --- from the original to vectorised worker into the vectorisation map. --- --- FIXME: It's not nice that we need create a special worker after the data constructors has --- already been constructed. Also, I don't think the worker is properly added to the data --- constructor. Seems messy. -vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM () -vectDataConWorkers orig_tc vect_tc arr_tc - = do { traceVt "Building vectorised worker for datatype" (ppr orig_tc) - - ; bs <- sequence - . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys - $ zipWith4 mk_data_con (tyConDataCons vect_tc) - rep_tys - (inits rep_tys) - (tail $ tails rep_tys) - ; mapM_ (uncurry hoistBinding) bs - } - where - tyvars = tyConTyVars vect_tc - var_tys = mkTyVarTys tyvars - ty_args = map Type var_tys - res_ty = mkTyConApp vect_tc var_tys - - cons = tyConDataCons vect_tc - arity = length cons - [arr_dc] = tyConDataCons arr_tc - - rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc - - mk_data_con con tys pre post - = do dflags <- getDynFlags - liftM2 (,) (vect_data_con con) - (lift_data_con tys pre post (mkDataConTag dflags con)) - - sel_replicate len tag - | arity > 1 = do - rep <- builtin (selReplicate arity) - return [rep `mkApps` [len, tag]] - - | otherwise = return [] - - vect_data_con con = return $ mkConApp con ty_args - lift_data_con tys pre_tys post_tys tag - = do - len <- builtin liftingContext - args <- mapM (newLocalVar (fsLit "xs")) - =<< mapM mkPDataType tys - - sel <- sel_replicate (Var len) tag - - pre <- mapM emptyPD (concat pre_tys) - post <- mapM emptyPD (concat post_tys) - - return . mkLams (len : args) - . wrapFamInstBody arr_tc var_tys - . mkConApp arr_dc - $ ty_args ++ sel ++ pre ++ map Var args ++ post - - def_worker data_con arg_tys mk_body - = do - arity <- polyArity tyvars - body <- closedV - . inBind orig_worker - . polyAbstract tyvars $ \args -> - liftM (mkLams (tyvars ++ args) . vectorised) - $ buildClosures tyvars [] [] arg_tys res_ty mk_body - - raw_worker <- mkVectId orig_worker (exprType body) - let vect_worker = raw_worker `setIdUnfolding` - mkInlineUnfoldingWithArity arity body - defGlobalVar orig_worker vect_worker - return (vect_worker, body) - where - orig_worker = dataConWorkId data_con diff --git a/vectorise/Vectorise/Type/TyConDecl.hs b/vectorise/Vectorise/Type/TyConDecl.hs deleted file mode 100644 --- a/vectorise/Vectorise/Type/TyConDecl.hs +++ /dev/null @@ -1,214 +0,0 @@ - -module Vectorise.Type.TyConDecl ( - vectTyConDecls -) where - -import Vectorise.Type.Type -import Vectorise.Monad -import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) -import BuildTyCl( TcMethInfo, buildClass, buildDataCon, newTyConRepName ) -import OccName -import Class -import Type -import TyCon -import DataCon -import DynFlags -import BasicTypes( DefMethSpec(..) ) -import SrcLoc( SrcSpan, noSrcSpan ) -import Var -import Name -import Outputable -import Util -import Control.Monad - - --- |Vectorise some (possibly recursively defined) type constructors. --- -vectTyConDecls :: [TyCon] -> VM [TyCon] -vectTyConDecls tcs = fixV $ \tcs' -> - do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs - ; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs') - ; zipWithM vectTyConDecl tcs names' - } - --- |Vectorise a single type constructor. --- -vectTyConDecl :: TyCon -> Name -> VM TyCon -vectTyConDecl tycon name' - - -- Type constructor representing a type class - | Just cls <- tyConClass_maybe tycon - = do { unless (null $ classATs cls) $ - do dflags <- getDynFlags - cantVectorise dflags "Associated types are not yet supported" (ppr cls) - - -- vectorise superclass constraint (types) - ; theta' <- mapM vectType (classSCTheta cls) - - -- vectorise method selectors - ; let opItems = classOpItems cls - Just datacon = tyConSingleDataCon_maybe tycon - argTys = dataConRepArgTys datacon -- all selector types - opTys = drop (length argTys - length opItems) argTys -- only method types - ; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys] - - -- construct the vectorised class (this also creates the class type constructors and its - -- data constructor) - -- - -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types - ; cls' <- liftDs $ - buildClass - name' -- new name: "V:Class" - (tyConBinders tycon) -- keep original kind - (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety - (snd . classTvsFds $ cls) -- keep the original functional dependencies - (Just ( - theta', -- superclasses - [], -- no associated types (for the moment) - methods', -- method info - (classMinimalDef cls))) -- Inherit minimal complete definition from cls - - -- the original dictionary constructor must map to the vectorised one - ; let tycon' = classTyCon cls' - Just datacon = tyConSingleDataCon_maybe tycon - Just datacon' = tyConSingleDataCon_maybe tycon' - ; defDataCon datacon datacon' - - -- the original superclass and methods selectors must map to the vectorised ones - ; let selIds = classAllSelIds cls - selIds' = classAllSelIds cls' - ; zipWithM_ defGlobalVar selIds selIds' - - -- return the type constructor of the vectorised class - ; return tycon' - } - - -- Regular algebraic type constructor — for now, Haskell 2011-style only - | isAlgTyCon tycon - = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $ - do dflags <- getDynFlags - cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon) - - -- vectorise the data constructor of the class tycon - ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon) - - -- keep the original GADT flags - ; let gadt_flag = isGadtSyntaxTyCon tycon - - -- build the vectorised type constructor - ; tc_rep_name <- mkDerivedName mkTyConRepOcc name' - ; return $ mkAlgTyCon - name' -- new name - (tyConBinders tycon) - (tyConResKind tycon) -- keep original kind - (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety - Nothing - [] -- no stupid theta - rhs' -- new constructor defs - (VanillaAlgTyCon tc_rep_name) - gadt_flag -- whether in GADT syntax - } - - -- some other crazy thing that we don't handle - | otherwise - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon) - --- |Vectorise a class method. (Don't enter it into the vectorisation map yet.) --- -vectMethod :: Id -> DefMethInfo -> Type -> VM TcMethInfo -vectMethod id defMeth ty - = do { -- Vectorise the method type. - ; ty' <- vectType ty - - -- Create a name for the vectorised method. - ; id' <- mkVectId id ty' - - ; return (Var.varName id', ty', defMethSpecOfDefMeth defMeth) - } - --- | Convert a `DefMethInfo` to a `DefMethSpec`, which discards the name field in --- the `DefMeth` constructor of the `DefMeth`. -defMethSpecOfDefMeth :: DefMethInfo -> Maybe (DefMethSpec (SrcSpan, Type)) -defMethSpecOfDefMeth Nothing = Nothing -defMethSpecOfDefMeth (Just (_, VanillaDM)) = Just VanillaDM -defMethSpecOfDefMeth (Just (_, GenericDM ty)) = Just (GenericDM (noSrcSpan, ty)) - --- |Vectorise the RHS of an algebraic type. --- -vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs -vectAlgTyConRhs tc (AbstractTyCon {}) - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc) -vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons - , is_enum = is_enum - }) - = do { data_cons' <- mapM vectDataCon data_cons - ; zipWithM_ defDataCon data_cons data_cons' - ; return $ DataTyCon { data_cons = data_cons' - , is_enum = is_enum - } - } - -vectAlgTyConRhs tc (TupleTyCon { data_con = con }) - = vectAlgTyConRhs tc (DataTyCon { data_cons = [con], is_enum = False }) - -- I'm not certain this is what you want to do for tuples, - -- but it's the behaviour we had before I refactored the - -- representation of AlgTyConRhs to add tuples - -vectAlgTyConRhs tc (SumTyCon { data_cons = cons }) - = -- FIXME (osa): I'm pretty sure this is broken.. TupleTyCon case is probably - -- also broken when the tuple is unboxed. - vectAlgTyConRhs tc (DataTyCon { data_cons = cons - , is_enum = all (((==) 0) . dataConRepArity) cons }) - -vectAlgTyConRhs tc (NewTyCon {}) - = do dflags <- getDynFlags - cantVectorise dflags noNewtypeErr (ppr tc) - where - noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration" - --- |Vectorise a data constructor by vectorising its argument and return types.. --- -vectDataCon :: DataCon -> VM DataCon -vectDataCon dc - | not . null $ ex_tvs - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc) - | not . null $ eq_spec - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc) - | not . null $ dataConFieldLabels dc - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc) - | not . null $ theta - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc) - | otherwise - = do { name' <- mkLocalisedName mkVectDataConOcc name - ; tycon' <- vectTyCon tycon - ; arg_tys <- mapM vectType rep_arg_tys - ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs) - ; fam_envs <- readGEnv global_fam_inst_env - ; rep_nm <- liftDs $ newTyConRepName name' - ; liftDs $ buildDataCon fam_envs - name' - (dataConIsInfix dc) -- infix if the original is - rep_nm - (dataConSrcBangs dc) -- strictness as original constructor - (Just $ dataConImplBangs dc) - [] -- no labelled fields for now - univ_bndrs -- universally quantified vars - [] -- no existential tvs for now - [] -- no equalities for now - [] -- no context for now - arg_tys -- argument types - ret_ty -- return type - tycon' -- representation tycon - } - where - name = dataConName dc - rep_arg_tys = dataConRepArgTys dc - tycon = dataConTyCon dc - (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc - univ_bndrs = dataConUnivTyVarBinders dc diff --git a/vectorise/Vectorise/Type/Type.hs b/vectorise/Vectorise/Type/Type.hs deleted file mode 100644 --- a/vectorise/Vectorise/Type/Type.hs +++ /dev/null @@ -1,87 +0,0 @@ --- Apply the vectorisation transformation to types. This is the \mathcal{L}_t scheme in HtM. - -module Vectorise.Type.Type - ( vectTyCon - , vectAndLiftType - , vectType - ) -where - -import Vectorise.Utils -import Vectorise.Monad -import Vectorise.Builtins -import TcType -import Type -import TyCoRep -import TyCon -import Control.Monad -import Control.Applicative -import Data.Maybe -import Outputable -import Prelude -- avoid redundant import warning due to AMP - --- |Vectorise a type constructor. Unless there is a vectorised version (stripped of embedded --- parallel arrays), the vectorised version is the same as the original. --- -vectTyCon :: TyCon -> VM TyCon -vectTyCon tc = maybe tc id <$> lookupTyCon tc - --- |Produce the vectorised and lifted versions of a type. --- --- NB: Here we are limited to properly handle predicates at the toplevel only. Anything embedded --- in what is called the 'body_ty' below will end up as an argument to the type family 'PData'. --- -vectAndLiftType :: Type -> VM (Type, Type) -vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty' -vectAndLiftType ty - = do { padicts <- liftM catMaybes $ mapM paDictArgType tyvars - ; vmono_ty <- vectType mono_ty - ; lmono_ty <- mkPDataType vmono_ty - ; return (abstractType tyvars (padicts ++ theta) vmono_ty, - abstractType tyvars (padicts ++ theta) lmono_ty) - } - where - (tyvars, phiTy) = splitForAllTys ty - (theta, mono_ty) = tcSplitPhiTy phiTy - --- |Vectorise a type. --- --- For each quantified var we need to add a PA dictionary out the front of the type. --- So forall a. C a => a -> a --- turns into forall a. PA a => Cv a => a :-> a --- -vectType :: Type -> VM Type -vectType ty - | Just ty' <- coreView ty - = vectType ty' -vectType (TyVarTy tv) = return $ TyVarTy tv -vectType (LitTy l) = return $ LitTy l -vectType (AppTy ty1 ty2) = AppTy <$> vectType ty1 <*> vectType ty2 -vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys -vectType (FunTy ty1 ty2) - | isPredTy ty1 - = mkFunTy <$> vectType ty1 <*> vectType ty2 -- don't build a closure for dictionary abstraction - | otherwise - = TyConApp <$> builtin closureTyCon <*> mapM vectType [ty1, ty2] -vectType ty@(ForAllTy {}) - = do { -- strip off consecutive foralls - ; let (tyvars, tyBody) = splitForAllTys ty - - -- vectorise the body - ; vtyBody <- vectType tyBody - - -- make a PA dictionary for each of the type variables - ; dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars - - -- add the PA dictionaries after the foralls - ; return $ abstractType tyvars dictsPA vtyBody - } -vectType ty@(CastTy {}) - = pprSorry "Vectorise.Type.Type.vectType: CastTy" (ppr ty) -vectType ty@(CoercionTy {}) - = pprSorry "Vectorise.Type.Type.vectType: CoercionTy" (ppr ty) - --- |Add quantified vars and dictionary parameters to the front of a type. --- -abstractType :: [TyVar] -> [Type] -> Type -> Type -abstractType tyvars dicts = mkInvForAllTys tyvars . mkFunTys dicts diff --git a/vectorise/Vectorise/Utils.hs b/vectorise/Vectorise/Utils.hs deleted file mode 100644 --- a/vectorise/Vectorise/Utils.hs +++ /dev/null @@ -1,165 +0,0 @@ -module Vectorise.Utils ( - module Vectorise.Utils.Base, - module Vectorise.Utils.Closure, - module Vectorise.Utils.Hoisting, - module Vectorise.Utils.PADict, - module Vectorise.Utils.Poly, - - -- * Annotated Exprs - collectAnnTypeArgs, - collectAnnDictArgs, - collectAnnTypeBinders, - collectAnnValBinders, - isAnnTypeArg, - - -- * PD Functions - replicatePD, emptyPD, packByTagPD, - combinePD, liftPD, - - -- * Scalars - isScalar, zipScalars, scalarClosure, - - -- * Naming - newLocalVar -) where - -import Vectorise.Utils.Base -import Vectorise.Utils.Closure -import Vectorise.Utils.Hoisting -import Vectorise.Utils.PADict -import Vectorise.Utils.Poly -import Vectorise.Monad -import Vectorise.Builtins -import CoreSyn -import CoreUtils -import Id -import Type -import Control.Monad - - --- Annotated Exprs ------------------------------------------------------------ - -collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type]) -collectAnnTypeArgs expr = go expr [] - where - go (_, AnnApp f (_, AnnType ty)) tys = go f (ty : tys) - go e tys = (e, tys) - -collectAnnDictArgs :: AnnExpr Var ann -> (AnnExpr Var ann, [AnnExpr Var ann]) -collectAnnDictArgs expr = go expr [] - where - go e@(_, AnnApp f arg) dicts - | isPredTy . exprType . deAnnotate $ arg = go f (arg : dicts) - | otherwise = (e, dicts) - go e dicts = (e, dicts) - -collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) -collectAnnTypeBinders expr = go [] expr - where - go bs (_, AnnLam b e) | isTyVar b = go (b : bs) e - go bs e = (reverse bs, e) - --- |Collect all consecutive value binders that are not dictionaries. --- -collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) -collectAnnValBinders expr = go [] expr - where - go bs (_, AnnLam b e) | isId b - && (not . isPredTy . idType $ b) = go (b : bs) e - go bs e = (reverse bs, e) - -isAnnTypeArg :: AnnExpr b ann -> Bool -isAnnTypeArg (_, AnnType _) = True -isAnnTypeArg _ = False - - --- PD "Parallel Data" Functions ----------------------------------------------- --- --- Given some data that has a PA dictionary, we can convert it to its --- representation type, perform some operation on the data, then convert it back. --- --- In the DPH backend, the types of these functions are defined --- in dph-common/D.A.P.Lifted/PArray.hs --- - --- |An empty array of the given type. --- -emptyPD :: Type -> VM CoreExpr -emptyPD = paMethod emptyPDVar emptyPD_PrimVar - --- |Produce an array containing copies of a given element. --- -replicatePD :: CoreExpr -- ^ Number of copies in the resulting array. - -> CoreExpr -- ^ Value to replicate. - -> VM CoreExpr -replicatePD len x - = liftM (`mkApps` [len,x]) - $ paMethod replicatePDVar replicatePD_PrimVar (exprType x) - --- |Select some elements from an array that correspond to a particular tag value and pack them into a new --- array. --- --- > packByTagPD Int# [:23, 42, 95, 50, 27, 49:] 3 [:1, 2, 1, 2, 3, 2:] 2 --- > ==> [:42, 50, 49:] --- -packByTagPD :: Type -- ^ Element type. - -> CoreExpr -- ^ Source array. - -> CoreExpr -- ^ Length of resulting array. - -> CoreExpr -- ^ Tag values of elements in source array. - -> CoreExpr -- ^ The tag value for the elements to select. - -> VM CoreExpr -packByTagPD ty xs len tags t - = liftM (`mkApps` [xs, len, tags, t]) - (paMethod packByTagPDVar packByTagPD_PrimVar ty) - --- |Combine some arrays based on a selector. The selector says which source array to choose for each --- element of the resulting array. --- -combinePD :: Type -- ^ Element type - -> CoreExpr -- ^ Length of resulting array - -> CoreExpr -- ^ Selector. - -> [CoreExpr] -- ^ Arrays to combine. - -> VM CoreExpr -combinePD ty len sel xs - = liftM (`mkApps` (len : sel : xs)) - (paMethod (combinePDVar n) (combinePD_PrimVar n) ty) - where - n = length xs - --- |Like `replicatePD` but use the lifting context in the vectoriser state. --- -liftPD :: CoreExpr -> VM CoreExpr -liftPD x - = do - lc <- builtin liftingContext - replicatePD (Var lc) x - - --- Scalars -------------------------------------------------------------------- - -isScalar :: Type -> VM Bool -isScalar ty - = do - { scalar <- builtin scalarClass - ; existsInst scalar [ty] - } - -zipScalars :: [Type] -> Type -> VM CoreExpr -zipScalars arg_tys res_ty - = do - { scalar <- builtin scalarClass - ; (dfuns, _) <- mapAndUnzipM (\ty -> lookupInst scalar [ty]) ty_args - ; zipf <- builtin (scalarZip $ length arg_tys) - ; return $ Var zipf `mkTyApps` ty_args `mkApps` map Var dfuns - } - where - ty_args = arg_tys ++ [res_ty] - -scalarClosure :: [Type] -> Type -> CoreExpr -> CoreExpr -> VM CoreExpr -scalarClosure arg_tys res_ty scalar_fun array_fun - = do - { ctr <- builtin (closureCtrFun $ length arg_tys) - ; pas <- mapM paDictOfType (init arg_tys) - ; return $ Var ctr `mkTyApps` (arg_tys ++ [res_ty]) - `mkApps` (pas ++ [scalar_fun, array_fun]) - } diff --git a/vectorise/Vectorise/Utils/Base.hs b/vectorise/Vectorise/Utils/Base.hs deleted file mode 100644 --- a/vectorise/Vectorise/Utils/Base.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Vectorise.Utils.Base - ( voidType - , newLocalVVar - - , mkDataConTag, dataConTagZ - , mkWrapType - , mkClosureTypes - , mkPReprType - , mkPDataType, mkPDatasType - , splitPrimTyCon - , mkBuiltinCo - - , wrapNewTypeBodyOfWrap - , unwrapNewTypeBodyOfWrap - , wrapNewTypeBodyOfPDataWrap - , unwrapNewTypeBodyOfPDataWrap - , wrapNewTypeBodyOfPDatasWrap - , unwrapNewTypeBodyOfPDatasWrap - - , pdataReprTyCon - , pdataReprTyConExact - , pdatasReprTyConExact - , pdataUnwrapScrut - - , preprFamInst -) where - -import Vectorise.Monad -import Vectorise.Vect -import Vectorise.Builtins - -import CoreSyn -import CoreUtils -import FamInstEnv -import Coercion -import Type -import TyCon -import DataCon -import MkId -import DynFlags -import FastString - -#include "HsVersions.h" - --- Simple Types --------------------------------------------------------------- - -voidType :: VM Type -voidType = mkBuiltinTyConApp voidTyCon [] - - --- Name Generation ------------------------------------------------------------ - -newLocalVVar :: FastString -> Type -> VM VVar -newLocalVVar fs vty - = do - lty <- mkPDataType vty - vv <- newLocalVar fs vty - lv <- newLocalVar fs lty - return (vv,lv) - - --- Constructors --------------------------------------------------------------- - -mkDataConTag :: DynFlags -> DataCon -> CoreExpr -mkDataConTag dflags = mkIntLitInt dflags . dataConTagZ - -dataConTagZ :: DataCon -> Int -dataConTagZ con = dataConTag con - fIRST_TAG - - --- Type Construction ---------------------------------------------------------- - --- |Make an application of the 'Wrap' type constructor. --- -mkWrapType :: Type -> VM Type -mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty] - --- |Make an application of the closure type constructor. --- -mkClosureTypes :: [Type] -> Type -> VM Type -mkClosureTypes = mkBuiltinTyConApps closureTyCon - --- |Make an application of the 'PRepr' type constructor. --- -mkPReprType :: Type -> VM Type -mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty] - --- | Make an application of the 'PData' tycon to some argument. --- -mkPDataType :: Type -> VM Type -mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty] - --- | Make an application of the 'PDatas' tycon to some argument. --- -mkPDatasType :: Type -> VM Type -mkPDatasType ty = mkBuiltinTyConApp pdatasTyCon [ty] - --- Make an application of a builtin type constructor to some arguments. --- -mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type -mkBuiltinTyConApp get_tc tys - = do { tc <- builtin get_tc - ; return $ mkTyConApp tc tys - } - --- Make a cascading application of a builtin type constructor. --- -mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type -mkBuiltinTyConApps get_tc tys ty - = do { tc <- builtin get_tc - ; return $ foldr (mk tc) ty tys - } - where - mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] - - --- Type decomposition --------------------------------------------------------- - --- |Checks if a type constructor is defined in 'GHC.Prim' (e.g., 'Int#'); if so, returns it. --- -splitPrimTyCon :: Type -> Maybe TyCon -splitPrimTyCon ty - | Just (tycon, []) <- splitTyConApp_maybe ty - , isPrimTyCon tycon - = Just tycon - | otherwise = Nothing - - --- Coercion Construction ----------------------------------------------------- - --- |Make a representational coercion to some builtin type. --- -mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion -mkBuiltinCo get_tc - = do { tc <- builtin get_tc - ; return $ mkTyConAppCo Representational tc [] - } - - --- Wrapping and unwrapping the 'Wrap' newtype --------------------------------- - --- |Apply the constructor wrapper of the 'Wrap' /newtype/. --- -wrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr -wrapNewTypeBodyOfWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; return $ wrapNewTypeBody wrap_tc [ty] e - } - --- |Strip the constructor wrapper of the 'Wrap' /newtype/. --- -unwrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr -unwrapNewTypeBodyOfWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; return $ unwrapNewTypeBody wrap_tc [ty] e - } - --- |Apply the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'. --- -wrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr -wrapNewTypeBodyOfPDataWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; pwrap_tc <- pdataReprTyConExact wrap_tc - ; return $ wrapNewTypeBody pwrap_tc [ty] e - } - --- |Strip the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'. --- -unwrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr -unwrapNewTypeBodyOfPDataWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; pwrap_tc <- pdataReprTyConExact wrap_tc - ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e) - } - --- |Apply the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'. --- -wrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr -wrapNewTypeBodyOfPDatasWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; pwrap_tc <- pdatasReprTyConExact wrap_tc - ; return $ wrapNewTypeBody pwrap_tc [ty] e - } - --- |Strip the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'. --- -unwrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr -unwrapNewTypeBodyOfPDatasWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; pwrap_tc <- pdatasReprTyConExact wrap_tc - ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e) - } - - --- 'PData' representation types ---------------------------------------------- - --- |Get the representation tycon of the 'PData' data family for a given type. --- --- This tycon does not appear explicitly in the source program — see Note [PData TyCons] in --- 'Vectorise.Generic.Description': --- --- @pdataReprTyCon {Sum2} = {PDataSum2}@ --- --- The type for which we look up a 'PData' instance may be more specific than the type in the --- instance declaration. In that case the second component of the result will be more specific than --- a set of distinct type variables. --- -pdataReprTyCon :: Type -> VM (TyCon, [Type]) -pdataReprTyCon ty - = do - { FamInstMatch { fim_instance = famInst - , fim_tys = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty]) - ; return (dataFamInstRepTyCon famInst, tys) - } - --- |Get the representation tycon of the 'PData' data family for a given type constructor. --- --- For example, for a binary type constructor 'T', we determine the representation type constructor --- for 'PData (T a b)'. --- -pdataReprTyConExact :: TyCon -> VM TyCon -pdataReprTyConExact tycon - = do { -- look up the representation tycon; if there is a match at all, it will be be exact - ; -- (i.e.,' _tys' will be distinct type variables) - ; (ptycon, _tys) <- pdataReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon)) - ; return ptycon - } - --- |Get the representation tycon of the 'PDatas' data family for a given type constructor. --- --- For example, for a binary type constructor 'T', we determine the representation type constructor --- for 'PDatas (T a b)'. --- -pdatasReprTyConExact :: TyCon -> VM TyCon -pdatasReprTyConExact tycon - = do { -- look up the representation tycon; if there is a match at all, it will be be exact - ; (FamInstMatch { fim_instance = ptycon }) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon)) - ; return $ dataFamInstRepTyCon ptycon - } - where - pdatasReprTyCon ty = builtin pdatasTyCon >>= (`lookupFamInst` [ty]) - --- |Unwrap a 'PData' representation scrutinee. --- -pdataUnwrapScrut :: VExpr -> VM (CoreExpr, CoreExpr, DataCon) -pdataUnwrapScrut (ve, le) - = do { (tc, arg_tys) <- pdataReprTyCon ty - ; let [dc] = tyConDataCons tc - ; return (ve, unwrapFamInstScrut tc arg_tys le, dc) - } - where - ty = exprType ve - - --- 'PRepr' representation types ---------------------------------------------- - --- |Get the representation tycon of the 'PRepr' type family for a given type. --- -preprFamInst :: Type -> VM FamInstMatch -preprFamInst ty = builtin preprTyCon >>= (`lookupFamInst` [ty]) diff --git a/vectorise/Vectorise/Utils/Closure.hs b/vectorise/Vectorise/Utils/Closure.hs deleted file mode 100644 --- a/vectorise/Vectorise/Utils/Closure.hs +++ /dev/null @@ -1,161 +0,0 @@ --- |Utils concerning closure construction and application. - -module Vectorise.Utils.Closure - ( mkClosure - , mkClosureApp - , buildClosures - ) -where - -import Vectorise.Builtins -import Vectorise.Vect -import Vectorise.Monad -import Vectorise.Utils.Base -import Vectorise.Utils.PADict -import Vectorise.Utils.Hoisting - -import CoreSyn -import Type -import MkCore -import CoreUtils -import TyCon -import DataCon -import MkId -import TysWiredIn -import BasicTypes( Boxity(..) ) -import FastString - - --- |Make a closure. --- -mkClosure :: Type -- ^ Type of the argument. - -> Type -- ^ Type of the result. - -> Type -- ^ Type of the environment. - -> VExpr -- ^ The function to apply. - -> VExpr -- ^ The environment to use. - -> VM VExpr -mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv) - = do dict <- paDictOfType env_ty - mkv <- builtin closureVar - mkl <- builtin liftedClosureVar - return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv], - Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv]) - --- |Make a closure application. --- -mkClosureApp :: Type -- ^ Type of the argument. - -> Type -- ^ Type of the result. - -> VExpr -- ^ Closure to apply. - -> VExpr -- ^ Argument to use. - -> VM VExpr -mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg) - = do vapply <- builtin applyVar - lapply <- builtin liftedApplyVar - lc <- builtin liftingContext - return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg], - Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, lclo, larg]) - --- |Build a set of 'n' closures corresponding to an 'n'-ary vectorised function. The length of --- the list of types of arguments determines the arity. --- --- In addition to a set of type variables, a set of value variables is passed during closure --- /construction/. In contrast, the closure environment and the arguments are passed during closure --- application. --- -buildClosures :: [TyVar] -- ^ Type variables passed during closure construction. - -> [Var] -- ^ Variables passed during closure construction. - -> [VVar] -- ^ Variables in the environment. - -> [Type] -- ^ Type of the arguments. - -> Type -- ^ Type of result. - -> VM VExpr - -> VM VExpr -buildClosures _tvs _vars _env [] _res_ty mk_body - = mk_body -buildClosures tvs vars env [arg_ty] res_ty mk_body - = buildClosure tvs vars env arg_ty res_ty mk_body -buildClosures tvs vars env (arg_ty : arg_tys) res_ty mk_body - = do { res_ty' <- mkClosureTypes arg_tys res_ty - ; arg <- newLocalVVar (fsLit "x") arg_ty - ; buildClosure tvs vars env arg_ty res_ty' - . hoistPolyVExpr tvs vars (Inline (length env + 1)) - $ do { lc <- builtin liftingContext - ; clo <- buildClosures tvs vars (env ++ [arg]) arg_tys res_ty mk_body - ; return $ vLams lc (env ++ [arg]) clo - } - } - --- Build a closure taking one extra argument during closure application. --- --- (clo , aclo (Arr lc xs1 ... xsn) ) --- where --- f = \env v -> case env of -> e x1 ... xn v --- f^ = \env v -> case env of Arr l xs1 ... xsn -> e^ l x1 ... xn v --- --- In addition to a set of type variables, a set of value variables is passed during closure --- /construction/. In contrast, the closure environment and the closure argument are passed during --- closure application. --- -buildClosure :: [TyVar] -- ^Type variables passed during closure construction. - -> [Var] -- ^Variables passed during closure construction. - -> [VVar] -- ^Variables in the environment. - -> Type -- ^Type of the closure argument. - -> Type -- ^Type of the result. - -> VM VExpr - -> VM VExpr -buildClosure tvs vars vvars arg_ty res_ty mk_body - = do { (env_ty, env, bind) <- buildEnv vvars - ; env_bndr <- newLocalVVar (fsLit "env") env_ty - ; arg_bndr <- newLocalVVar (fsLit "arg") arg_ty - - -- generate the closure function as a hoisted binding - ; fn <- hoistPolyVExpr tvs vars (Inline 2) $ - do { lc <- builtin liftingContext - ; body <- mk_body - ; return . vLams lc [env_bndr, arg_bndr] - $ bind (vVar env_bndr) - (vVarApps lc body (vvars ++ [arg_bndr])) - } - - ; mkClosure arg_ty res_ty env_ty fn env - } - --- Build the environment for a single closure. --- -buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr) -buildEnv [] - = do - ty <- voidType - void <- builtin voidVar - pvoid <- builtin pvoidVar - return (ty, vVar (void, pvoid), \_ body -> body) -buildEnv [v] - = return (vVarType v, vVar v, - \env body -> vLet (vNonRec v env) body) -buildEnv vs - = do (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty - - let venv_con = tupleDataCon Boxed (length vs) - [lenv_con] = tyConDataCons lenv_tc - - venv = mkCoreTup (map Var vvs) - lenv = Var (dataConWrapId lenv_con) - `mkTyApps` lenv_tyargs - `mkApps` map Var lvs - - vbind env body = mkWildCase env ty (exprType body) - [(DataAlt venv_con, vvs, body)] - - lbind env body = - let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs env - in - mkWildCase scrut (exprType scrut) (exprType body) - [(DataAlt lenv_con, lvs, body)] - - bind (venv, lenv) (vbody, lbody) = (vbind venv vbody, - lbind lenv lbody) - - return (ty, (venv, lenv), bind) - where - (vvs, lvs) = unzip vs - tys = map vVarType vs - ty = mkBoxedTupleTy tys diff --git a/vectorise/Vectorise/Utils/Hoisting.hs b/vectorise/Vectorise/Utils/Hoisting.hs deleted file mode 100644 --- a/vectorise/Vectorise/Utils/Hoisting.hs +++ /dev/null @@ -1,98 +0,0 @@ -module Vectorise.Utils.Hoisting - ( Inline(..) - , addInlineArity - , inlineMe - - , hoistBinding - , hoistExpr - , hoistVExpr - , hoistPolyVExpr - , takeHoisted - ) -where - -import Vectorise.Monad -import Vectorise.Env -import Vectorise.Vect -import Vectorise.Utils.Poly - -import CoreSyn -import CoreUtils -import CoreUnfold -import Type -import Id -import BasicTypes (Arity) -import FastString -import Control.Monad -import Control.Applicative -import Prelude -- avoid redundant import warning due to AMP - --- Inline --------------------------------------------------------------------- - --- |Records whether we should inline a particular binding. --- -data Inline - = Inline Arity - | DontInline - --- |Add to the arity contained within an `Inline`, if any. --- -addInlineArity :: Inline -> Int -> Inline -addInlineArity (Inline m) n = Inline (m+n) -addInlineArity DontInline _ = DontInline - --- |Says to always inline a binding. --- -inlineMe :: Inline -inlineMe = Inline 0 - - --- Hoisting -------------------------------------------------------------------- - -hoistBinding :: Var -> CoreExpr -> VM () -hoistBinding v e = updGEnv $ \env -> - env { global_bindings = (v,e) : global_bindings env } - -hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var -hoistExpr fs expr inl - = do - var <- mk_inline `liftM` newLocalVar fs (exprType expr) - hoistBinding var expr - return var - where - mk_inline var = case inl of - Inline arity -> var `setIdUnfolding` - mkInlineUnfoldingWithArity arity expr - DontInline -> var - -hoistVExpr :: VExpr -> Inline -> VM VVar -hoistVExpr (ve, le) inl - = do - fs <- getBindName - vv <- hoistExpr ('v' `consFS` fs) ve inl - lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1) - return (vv, lv) - --- |Hoist a polymorphic vectorised expression into a new top-level binding (representing a closure --- function). --- --- The hoisted expression is parameterised by (1) a set of type variables and (2) a set of value --- variables that are passed as conventional type and value arguments. The latter is implicitly --- extended by the set of 'PA' dictionaries required for the type variables. --- -hoistPolyVExpr :: [TyVar] -> [Var] -> Inline -> VM VExpr -> VM VExpr -hoistPolyVExpr tvs vars inline p - = do { inline' <- addInlineArity inline . (+ length vars) <$> polyArity tvs - ; expr <- closedV . polyAbstract tvs $ \args -> - mapVect (mkLams $ tvs ++ args ++ vars) <$> p - ; fn <- hoistVExpr expr inline' - ; let varArgs = varsToCoreExprs vars - ; mapVect (\e -> e `mkApps` varArgs) <$> polyVApply (vVar fn) (mkTyVarTys tvs) - } - -takeHoisted :: VM [(Var, CoreExpr)] -takeHoisted - = do - env <- readGEnv id - setGEnv $ env { global_bindings = [] } - return $ global_bindings env diff --git a/vectorise/Vectorise/Utils/PADict.hs b/vectorise/Vectorise/Utils/PADict.hs deleted file mode 100644 --- a/vectorise/Vectorise/Utils/PADict.hs +++ /dev/null @@ -1,229 +0,0 @@ -module Vectorise.Utils.PADict ( - paDictArgType, - paDictOfType, - paMethod, - prDictOfReprType, - prDictOfPReprInstTyCon -) where - -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Utils.Base - -import CoreSyn -import CoreUtils -import FamInstEnv -import Coercion -import Type -import TyCoRep -import TyCon -import CoAxiom -import Var -import Outputable -import DynFlags -import FastString -import Control.Monad - - --- |Construct the PA argument type for the tyvar. For the tyvar (v :: *) it's --- just PA v. For (v :: (* -> *) -> *) it's --- --- > forall (a :: * -> *). (forall (b :: *). PA b -> PA (a b)) -> PA (v a) --- -paDictArgType :: TyVar -> VM (Maybe Type) -paDictArgType tv = go (mkTyVarTy tv) (tyVarKind tv) - where - go ty (FunTy k1 k2) - = do - tv <- if isCoercionType k1 - then newCoVar (fsLit "c") k1 - else newTyVar (fsLit "a") k1 - mty1 <- go (mkTyVarTy tv) k1 - case mty1 of - Just ty1 -> do - mty2 <- go (mkAppTy ty (mkTyVarTy tv)) k2 - return $ fmap (mkInvForAllTy tv . mkFunTy ty1) mty2 - Nothing -> go ty k2 - - go ty k - | isLiftedTypeKind k - = do - pa_cls <- builtin paClass - return $ Just $ mkClassPred pa_cls [ty] - - go _ _ = return Nothing - - --- |Get the PA dictionary for some type --- -paDictOfType :: Type -> VM CoreExpr -paDictOfType ty - = paDictOfTyApp ty_fn ty_args - where - (ty_fn, ty_args) = splitAppTys ty - - paDictOfTyApp :: Type -> [Type] -> VM CoreExpr - paDictOfTyApp ty_fn ty_args - | Just ty_fn' <- coreView ty_fn - = paDictOfTyApp ty_fn' ty_args - - -- for type variables, look up the dfun and apply to the PA dictionaries - -- of the type arguments - paDictOfTyApp (TyVarTy tv) ty_args - = do - { dfun <- maybeCantVectoriseM "No PA dictionary for type variable" - (ppr tv <+> text "in" <+> ppr ty) - $ lookupTyVarPA tv - ; dicts <- mapM paDictOfType ty_args - ; return $ dfun `mkTyApps` ty_args `mkApps` dicts - } - - -- for tycons, we also need to apply the dfun to the PR dictionary of - -- the representation type if the tycon is polymorphic - paDictOfTyApp (TyConApp tc []) ty_args - = do - { dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty) - $ lookupTyConPA tc - ; super <- super_dict tc ty_args - ; dicts <- mapM paDictOfType ty_args - ; return $ Var dfun `mkTyApps` ty_args `mkApps` super `mkApps` dicts - } - where - noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)" - - super_dict _ [] = return [] - super_dict tycon ty_args - = do - { pr <- prDictOfPReprInst (TyConApp tycon ty_args) - ; return [pr] - } - - paDictOfTyApp _ _ = getDynFlags >>= failure - - failure dflags = cantVectorise dflags "Can't construct PA dictionary for type" (ppr ty) - --- |Produce code that refers to a method of the 'PA' class. --- -paMethod :: (Builtins -> Var) -> (TyCon -> Builtins -> Var) -> Type -> VM CoreExpr -paMethod _ query ty - | Just tycon <- splitPrimTyCon ty -- Is 'ty' from 'GHC.Prim' (e.g., 'Int#')? - = liftM Var $ builtin (query tycon) -paMethod method _ ty - = do - { fn <- builtin method - ; dict <- paDictOfType ty - ; return $ mkApps (Var fn) [Type ty, dict] - } - --- |Given a type @ty@, return the PR dictionary for @PRepr ty@. --- -prDictOfPReprInst :: Type -> VM CoreExpr -prDictOfPReprInst ty - = do - { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args }) - <- preprFamInst ty - ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args - } - --- |Given a type @ty@, its PRepr synonym tycon and its type arguments, --- return the PR @PRepr ty@. Suppose we have: --- --- > type instance PRepr (T a1 ... an) = t --- --- which is internally translated into --- --- > type :R:PRepr a1 ... an = t --- --- and the corresponding coercion. Then, --- --- > prDictOfPReprInstTyCon (T a1 ... an) :R:PRepr u1 ... un = PR (T u1 ... un) --- --- Note that @ty@ is only used for error messages --- -prDictOfPReprInstTyCon :: Type -> CoAxiom Unbranched -> [Type] -> VM CoreExpr -prDictOfPReprInstTyCon _ty prepr_ax prepr_args - = do - let rhs = mkUnbranchedAxInstRHS prepr_ax prepr_args [] - dict <- prDictOfReprType' rhs - pr_co <- mkBuiltinCo prTyCon - let co = mkAppCo pr_co - $ mkSymCo - $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args [] - return $ mkCast dict co - --- |Get the PR dictionary for a type. The argument must be a representation --- type. --- -prDictOfReprType :: Type -> VM CoreExpr -prDictOfReprType ty - | Just (tycon, tyargs) <- splitTyConApp_maybe ty - = do - prepr <- builtin preprTyCon - if tycon == prepr - then do - let [ty'] = tyargs - pa <- paDictOfType ty' - sel <- builtin paPRSel - return $ Var sel `App` Type ty' `App` pa - else do - -- a representation tycon must have a PR instance - dfun <- maybeV (text "look up PR dictionary for" <+> ppr tycon) $ - lookupTyConPR tycon - prDFunApply dfun tyargs - - | otherwise - = do - -- it is a tyvar or an application of a tyvar - -- determine the PR dictionary from its PA dictionary - -- - -- NOTE: This assumes that PRepr t ~ t is for all representation types - -- t - -- - -- FIXME: This doesn't work for kinds other than * at the moment. We'd - -- have to simply abstract the term over the missing type arguments. - pa <- paDictOfType ty - prsel <- builtin paPRSel - return $ Var prsel `mkApps` [Type ty, pa] - -prDictOfReprType' :: Type -> VM CoreExpr -prDictOfReprType' ty = prDictOfReprType ty `orElseV` - do dflags <- getDynFlags - cantVectorise dflags "No PR dictionary for representation type" - (ppr ty) - --- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding --- to the argument types. -prDFunApply :: Var -> [Type] -> VM CoreExpr -prDFunApply dfun tys - | Just [] <- ctxs -- PR (a :-> b) doesn't have a context - = return $ Var dfun `mkTyApps` tys - - | Just tycons <- ctxs - , length tycons == length tys - = do - pa <- builtin paTyCon - pr <- builtin prTyCon - dflags <- getDynFlags - args <- zipWithM (dictionary dflags pa pr) tys tycons - return $ Var dfun `mkTyApps` tys `mkApps` args - - | otherwise = do dflags <- getDynFlags - invalid dflags - where - -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then - -- ctxs is Just [PA, PR] - ctxs = fmap (map fst) - $ sequence - $ map splitTyConApp_maybe - $ fst - $ splitFunTys - $ snd - $ splitForAllTys - $ varType dfun - - dictionary dflags pa pr ty tycon - | tycon == pa = paDictOfType ty - | tycon == pr = prDictOfReprType ty - | otherwise = invalid dflags - - invalid dflags = cantVectorise dflags "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys) diff --git a/vectorise/Vectorise/Utils/Poly.hs b/vectorise/Vectorise/Utils/Poly.hs deleted file mode 100644 --- a/vectorise/Vectorise/Utils/Poly.hs +++ /dev/null @@ -1,72 +0,0 @@ --- |Auxiliary functions to vectorise type abstractions. - -module Vectorise.Utils.Poly - ( polyAbstract - , polyApply - , polyVApply - , polyArity - ) -where - -import Vectorise.Vect -import Vectorise.Monad -import Vectorise.Utils.PADict -import CoreSyn -import Type -import FastString -import Control.Monad - - --- Vectorisation of type arguments ------------------------------------------------------------- - --- |Vectorise under the 'PA' dictionary variables corresponding to a set of type arguments. --- --- The dictionary variables are new local variables that are entered into the local vectorisation --- map. --- --- The purpose of this function is to introduce the additional 'PA' dictionary arguments that are --- needed when vectorising type abstractions. --- -polyAbstract :: [TyVar] -> ([Var] -> VM a) -> VM a -polyAbstract tvs p - = localV - $ do { mdicts <- mapM mk_dict_var tvs - ; zipWithM_ (\tv -> maybe (defLocalTyVar tv) - (defLocalTyVarWithPA tv . Var)) tvs mdicts - ; p (mk_args mdicts) - } - where - mk_dict_var tv - = do { r <- paDictArgType tv - ; case r of - Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty) - Nothing -> return Nothing - } - - mk_args mdicts = [dict | Just dict <- mdicts] - --- |Determine the number of 'PA' dictionary arguments required for a set of type variables (depends --- on their kinds). --- -polyArity :: [TyVar] -> VM Int -polyArity tvs - = do { tys <- mapM paDictArgType tvs - ; return $ length [() | Just _ <- tys] - } - --- |Apply a expression to its type arguments as well as 'PA' dictionaries for these type arguments. --- -polyApply :: CoreExpr -> [Type] -> VM CoreExpr -polyApply expr tys - = do { dicts <- mapM paDictOfType tys - ; return $ expr `mkTyApps` tys `mkApps` dicts - } - --- |Apply a vectorised expression to a set of type arguments together with 'PA' dictionaries for --- these type arguments. --- -polyVApply :: VExpr -> [Type] -> VM VExpr -polyVApply expr tys - = do { dicts <- mapM paDictOfType tys - ; return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr - } diff --git a/vectorise/Vectorise/Var.hs b/vectorise/Vectorise/Var.hs deleted file mode 100644 --- a/vectorise/Vectorise/Var.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE TupleSections #-} - --- |Vectorise variables and literals. - -module Vectorise.Var - ( vectBndr - , vectBndrNew - , vectBndrIn - , vectBndrNewIn - , vectBndrsIn - , vectVar - , vectConst - ) -where - -import Vectorise.Utils -import Vectorise.Monad -import Vectorise.Env -import Vectorise.Vect -import Vectorise.Type.Type -import CoreSyn -import Type -import VarEnv -import Id -import FastString -import Control.Applicative -import Prelude -- avoid redundant import warning due to AMP - --- Binders ---------------------------------------------------------------------------------------- - --- |Vectorise a binder variable, along with its attached type. --- -vectBndr :: Var -> VM VVar -vectBndr v - = do (vty, lty) <- vectAndLiftType (idType v) - let vv = v `Id.setIdType` vty - lv = v `Id.setIdType` lty - - updLEnv (mapTo vv lv) - - return (vv, lv) - where - mapTo vv lv env = env { local_vars = extendVarEnv (local_vars env) v (vv, lv) } - --- |Vectorise a binder variable, along with its attached type, but give the result a new name. --- -vectBndrNew :: Var -> FastString -> VM VVar -vectBndrNew v fs - = do vty <- vectType (idType v) - vv <- newLocalVVar fs vty - updLEnv (upd vv) - return vv - where - upd vv env = env { local_vars = extendVarEnv (local_vars env) v vv } - --- |Vectorise a binder then run a computation with that binder in scope. --- -vectBndrIn :: Var -> VM a -> VM (VVar, a) -vectBndrIn v p - = localV - $ do vv <- vectBndr v - x <- p - return (vv, x) - --- |Vectorise a binder, give it a new name, then run a computation with that binder in scope. --- -vectBndrNewIn :: Var -> FastString -> VM a -> VM (VVar, a) -vectBndrNewIn v fs p - = localV - $ do vv <- vectBndrNew v fs - x <- p - return (vv, x) - --- |Vectorise some binders, then run a computation with them in scope. --- -vectBndrsIn :: [Var] -> VM a -> VM ([VVar], a) -vectBndrsIn vs p - = localV - $ do vvs <- mapM vectBndr vs - x <- p - return (vvs, x) - - --- Variables -------------------------------------------------------------------------------------- - --- |Vectorise a variable, producing the vectorised and lifted versions. --- -vectVar :: Var -> VM VExpr -vectVar var - = do { vVar <- lookupVar var - ; case vVar of - Local (vv, lv) -> return (Var vv, Var lv) -- local variables have a vect & lifted version - Global vv -> vectConst (Var vv) -- global variables get replicated - } - - --- Constants -------------------------------------------------------------------------------------- - --- |Constants are lifted by replication along the integer context in the `VM` state for the number --- of elements in the result array. --- -vectConst :: CoreExpr -> VM VExpr -vectConst c = (c,) <$> liftPD c diff --git a/vectorise/Vectorise/Vect.hs b/vectorise/Vectorise/Vect.hs deleted file mode 100644 --- a/vectorise/Vectorise/Vect.hs +++ /dev/null @@ -1,126 +0,0 @@ --- |Simple vectorised constructors and projections. --- -module Vectorise.Vect - ( Vect, VVar, VExpr, VBind - - , vectorised - , lifted - , mapVect - - , vVarType - , vNonRec - , vRec - , vVar - , vType - , vTick - , vLet - , vLams - , vVarApps - , vCaseDEFAULT - ) -where - -import CoreSyn -import Type ( Type ) -import Var - --- |Contains the vectorised and lifted versions of some thing. --- -type Vect a = (a,a) -type VVar = Vect Var -type VExpr = Vect CoreExpr -type VBind = Vect CoreBind - --- |Get the vectorised version of a thing. --- -vectorised :: Vect a -> a -vectorised = fst - --- |Get the lifted version of a thing. --- -lifted :: Vect a -> a -lifted = snd - --- |Apply some function to both the vectorised and lifted versions of a thing. --- -mapVect :: (a -> b) -> Vect a -> Vect b -mapVect f (x, y) = (f x, f y) - --- |Combine vectorised and lifted versions of two things componentwise. --- -zipWithVect :: (a -> b -> c) -> Vect a -> Vect b -> Vect c -zipWithVect f (x1, y1) (x2, y2) = (f x1 x2, f y1 y2) - --- |Get the type of a vectorised variable. --- -vVarType :: VVar -> Type -vVarType = varType . vectorised - --- |Wrap a vectorised variable as a vectorised expression. --- -vVar :: VVar -> VExpr -vVar = mapVect Var - --- |Wrap a vectorised type as a vectorised expression. --- -vType :: Type -> VExpr -vType ty = (Type ty, Type ty) - --- |Make a vectorised note. --- -vTick :: Tickish Id -> VExpr -> VExpr -vTick = mapVect . Tick - --- |Make a vectorised non-recursive binding. --- -vNonRec :: VVar -> VExpr -> VBind -vNonRec = zipWithVect NonRec - --- |Make a vectorised recursive binding. --- -vRec :: [VVar] -> [VExpr] -> VBind -vRec vs es = (Rec (zip vvs ves), Rec (zip lvs les)) - where - (vvs, lvs) = unzip vs - (ves, les) = unzip es - --- |Make a vectorised let expression. --- -vLet :: VBind -> VExpr -> VExpr -vLet = zipWithVect Let - --- |Make a vectorised lambda abstraction. --- --- The lifted version also binds the lifting context 'lc'. --- -vLams :: Var -- ^ Var bound to the lifting context. - -> [VVar] -- ^ Parameter vars for the abstraction. - -> VExpr -- ^ Body of the abstraction. - -> VExpr -vLams lc vs (ve, le) - = (mkLams vvs ve, mkLams (lc:lvs) le) - where - (vvs, lvs) = unzip vs - --- |Apply an expression to a set of argument variables. --- --- The lifted version is also applied to the variable of the lifting context. --- -vVarApps :: Var -> VExpr -> [VVar] -> VExpr -vVarApps lc (ve, le) vvs - = (ve `mkVarApps` vs, le `mkVarApps` (lc : ls)) - where - (vs, ls) = unzip vvs - - -vCaseDEFAULT :: VExpr -- scrutinee - -> VVar -- bnder - -> Type -- type of vectorised version - -> Type -- type of lifted version - -> VExpr -- body of alternative. - -> VExpr -vCaseDEFAULT (vscrut, lscrut) (vbndr, lbndr) vty lty (vbody, lbody) - = (Case vscrut vbndr vty (mkDEFAULT vbody), - Case lscrut lbndr lty (mkDEFAULT lbody)) - where - mkDEFAULT e = [(DEFAULT, [], e)]